diff --git a/collects/afm/Courier-Bold.afm b/collects/afm/Courier-Bold.afm
new file mode 100644
index 0000000000..8bd82daa28
--- /dev/null
+++ b/collects/afm/Courier-Bold.afm
@@ -0,0 +1,341 @@
+StartFontMetrics 2.0
+Comment Copyright (c) 1984 Adobe Systems Incorporated. All Rights Reserved.
+Comment Creation Date:Mon Apr 6 17:11:38 PDT 1987
+FontName Courier-Bold
+EncodingScheme AdobeStandardEncoding
+FullName Courier Bold
+FamilyName Courier
+Weight Bold
+ItalicAngle 0.0
+IsFixedPitch true
+UnderlinePosition -85
+UnderlineThickness 100
+Version 001.004
+FontBBox -100 -350 700 855
+CapHeight 633
+XHeight 487
+Descender -257
+Ascender 674
+StartCharMetrics 260
+C 32 ; WX 600 ; N space ; B 500 -100 700 100 ;
+C 33 ; WX 600 ; N exclam ; B 170 -65 430 689 ;
+C 34 ; WX 600 ; N quotedbl ; B 66 254 534 663 ;
+C 35 ; WX 600 ; N numbersign ; B 12 -142 588 725 ;
+C 36 ; WX 600 ; N dollar ; B 33 -173 567 735 ;
+C 37 ; WX 600 ; N percent ; B 7 -65 593 689 ;
+C 38 ; WX 600 ; N ampersand ; B 25 -65 558 600 ;
+C 39 ; WX 600 ; N quoteright ; B 75 244 400 674 ;
+C 40 ; WX 600 ; N parenleft ; B 214 -204 538 683 ;
+C 41 ; WX 600 ; N parenright ; B 67 -204 391 683 ;
+C 42 ; WX 600 ; N asterisk ; B 33 150 567 674 ;
+C 43 ; WX 600 ; N plus ; B -8 -48 608 610 ;
+C 44 ; WX 600 ; N comma ; B 75 -215 400 215 ;
+C 45 ; WX 600 ; N hyphen ; B -8 181 608 381 ;
+C 46 ; WX 600 ; N period ; B 190 -50 410 150 ;
+C 47 ; WX 600 ; N slash ; B 33 -163 567 746 ;
+C 48 ; WX 600 ; N zero ; B 33 -65 567 689 ;
+C 49 ; WX 600 ; N one ; B 33 -50 567 674 ;
+C 50 ; WX 600 ; N two ; B 4 -50 558 689 ;
+C 51 ; WX 600 ; N three ; B 16 -65 579 689 ;
+C 52 ; WX 600 ; N four ; B 25 -50 558 674 ;
+C 53 ; WX 600 ; N five ; B 16 -65 579 674 ;
+C 54 ; WX 600 ; N six ; B 56 -65 590 689 ;
+C 55 ; WX 600 ; N seven ; B 25 -50 558 674 ;
+C 56 ; WX 600 ; N eight ; B 33 -65 567 689 ;
+C 57 ; WX 600 ; N nine ; B 56 -65 590 689 ;
+C 58 ; WX 600 ; N colon ; B 190 -50 410 472 ;
+C 59 ; WX 600 ; N semicolon ; B 79 -176 410 472 ;
+C 60 ; WX 600 ; N less ; B -8 -48 608 610 ;
+C 61 ; WX 600 ; N equal ; B -29 88 629 474 ;
+C 62 ; WX 600 ; N greater ; B -8 -48 608 610 ;
+C 63 ; WX 600 ; N question ; B 54 -65 567 648 ;
+C 64 ; WX 600 ; N at ; B 26 -142 559 705 ;
+C 65 ; WX 600 ; N A ; B -71 -50 671 633 ;
+C 66 ; WX 600 ; N B ; B -37 -50 621 633 ;
+C 67 ; WX 600 ; N C ; B -17 -65 614 648 ;
+C 68 ; WX 600 ; N D ; B -37 -50 600 633 ;
+C 69 ; WX 600 ; N E ; B -37 -50 600 633 ;
+C 70 ; WX 600 ; N F ; B -37 -50 600 633 ;
+C 71 ; WX 600 ; N G ; B -17 -65 642 648 ;
+C 72 ; WX 600 ; N H ; B -27 -50 631 633 ;
+C 73 ; WX 600 ; N I ; B 33 -50 567 633 ;
+C 74 ; WX 600 ; N J ; B 4 -65 663 633 ;
+C 75 ; WX 600 ; N K ; B -37 -50 652 633 ;
+C 76 ; WX 600 ; N L ; B -17 -50 621 633 ;
+C 77 ; WX 600 ; N M ; B -69 -50 673 633 ;
+C 78 ; WX 600 ; N N ; B -58 -50 642 633 ;
+C 79 ; WX 600 ; N O ; B -29 -65 629 648 ;
+C 80 ; WX 600 ; N P ; B -37 -50 579 633 ;
+C 81 ; WX 600 ; N Q ; B -29 -196 629 648 ;
+C 82 ; WX 600 ; N R ; B -37 -50 669 633 ;
+C 83 ; WX 600 ; N S ; B 12 -65 588 648 ;
+C 84 ; WX 600 ; N T ; B -8 -50 608 633 ;
+C 85 ; WX 600 ; N U ; B -40 -65 640 633 ;
+C 86 ; WX 600 ; N V ; B -71 -50 671 633 ;
+C 87 ; WX 600 ; N W ; B -60 -50 660 633 ;
+C 88 ; WX 600 ; N X ; B -40 -50 640 633 ;
+C 89 ; WX 600 ; N Y ; B -29 -50 629 633 ;
+C 90 ; WX 600 ; N Z ; B 23 -50 577 633 ;
+C 91 ; WX 600 ; N bracketleft ; B 200 -204 525 674 ;
+C 92 ; WX 600 ; N backslash ; B 33 -163 567 746 ;
+C 93 ; WX 600 ; N bracketright ; B 75 -204 400 674 ;
+C 94 ; WX 600 ; N asciicircum ; B 33 275 567 674 ;
+C 95 ; WX 600 ; N underscore ; B -92 -350 692 -150 ;
+C 96 ; WX 600 ; N quoteleft ; B 200 244 525 674 ;
+C 97 ; WX 600 ; N a ; B -8 -65 621 502 ;
+C 98 ; WX 600 ; N b ; B -58 -65 621 674 ;
+C 99 ; WX 600 ; N c ; B 4 -65 615 502 ;
+C 100 ; WX 600 ; N d ; B -17 -65 663 674 ;
+C 101 ; WX 600 ; N e ; B -17 -65 600 502 ;
+C 102 ; WX 600 ; N f ; B 25 -50 621 674 ; L i fi ; L l fl ;
+C 103 ; WX 600 ; N g ; B -17 -257 642 502 ;
+C 104 ; WX 600 ; N h ; B -37 -50 631 674 ;
+C 105 ; WX 600 ; N i ; B 12 -50 588 725 ;
+C 106 ; WX 600 ; N j ; B 67 -257 538 725 ;
+C 107 ; WX 600 ; N k ; B -17 -50 621 674 ;
+C 108 ; WX 600 ; N l ; B 12 -50 588 674 ;
+C 109 ; WX 600 ; N m ; B -69 -50 673 502 ;
+C 110 ; WX 600 ; N n ; B -27 -50 621 502 ;
+C 111 ; WX 600 ; N o ; B -8 -65 608 502 ;
+C 112 ; WX 600 ; N p ; B -58 -257 621 502 ;
+C 113 ; WX 600 ; N q ; B -17 -257 663 502 ;
+C 114 ; WX 600 ; N r ; B 4 -50 621 501 ;
+C 115 ; WX 600 ; N s ; B 23 -65 577 502 ;
+C 116 ; WX 600 ; N t ; B -37 -65 579 642 ;
+C 117 ; WX 600 ; N u ; B -37 -65 621 487 ;
+C 118 ; WX 600 ; N v ; B -50 -50 650 487 ;
+C 119 ; WX 600 ; N w ; B -50 -50 650 487 ;
+C 120 ; WX 600 ; N x ; B -29 -50 629 487 ;
+C 121 ; WX 600 ; N y ; B -29 -257 629 487 ;
+C 122 ; WX 600 ; N z ; B 35 -50 569 487 ;
+C 123 ; WX 600 ; N braceleft ; B 117 -204 483 674 ;
+C 124 ; WX 600 ; N bar ; B 200 -204 400 674 ;
+C 125 ; WX 600 ; N braceright ; B 117 -204 483 674 ;
+C 126 ; WX 600 ; N asciitilde ; B 12 129 588 433 ;
+C 161 ; WX 600 ; N exclamdown ; B 170 -257 430 475 ;
+C 162 ; WX 600 ; N cent ; B 33 -79 549 725 ;
+C 163 ; WX 600 ; N sterling ; B -17 -50 600 648 ;
+C 164 ; WX 600 ; N fraction ; B -29 60 629 552 ;
+C 165 ; WX 600 ; N yen ; B -29 -50 629 633 ;
+C 166 ; WX 600 ; N florin ; B 7 -173 598 689 ;
+C 167 ; WX 600 ; N section ; B -14 -147 614 689 ;
+C 168 ; WX 600 ; N currency ; B 23 15 577 569 ;
+C 169 ; WX 600 ; N quotesingle ; B 170 244 430 674 ;
+C 170 ; WX 600 ; N quotedblleft ; B 33 280 567 678 ;
+C 171 ; WX 600 ; N guillemotleft ; B -17 -50 621 487 ;
+C 172 ; WX 600 ; N guilsinglleft ; B -17 -50 392 487 ;
+C 173 ; WX 600 ; N guilsinglright ; B 213 -50 621 487 ;
+C 174 ; WX 600 ; N fi ; B -70 -50 670 725 ;
+C 175 ; WX 600 ; N fl ; B -70 -50 670 674 ;
+C 177 ; WX 600 ; N endash ; B -8 181 608 381 ;
+C 178 ; WX 600 ; N dagger ; B 44 -142 556 674 ;
+C 179 ; WX 600 ; N daggerdbl ; B 44 -142 556 674 ;
+C 180 ; WX 600 ; N periodcentered ; B 190 206 410 406 ;
+C 182 ; WX 600 ; N paragraph ; B -1 -147 605 689 ;
+C 183 ; WX 600 ; N bullet ; B 200 206 400 406 ;
+C 184 ; WX 600 ; N quotesinglbase ; B 75 -225 400 204 ;
+C 185 ; WX 600 ; N quotedblbase ; B 33 -199 567 199 ;
+C 186 ; WX 600 ; N quotedblright ; B 33 280 567 678 ;
+C 187 ; WX 600 ; N guillemotright ; B -17 -50 621 487 ;
+C 188 ; WX 600 ; N ellipsis ; B 0 -65 600 135 ;
+C 189 ; WX 600 ; N perthousand ; B -50 -65 650 689 ;
+C 191 ; WX 600 ; N questiondown ; B 33 -257 546 475 ;
+C 193 ; WX 600 ; N grave ; B 75 390 400 689 ;
+C 194 ; WX 600 ; N acute ; B 200 390 525 689 ;
+C 195 ; WX 600 ; N circumflex ; B 75 390 525 674 ;
+C 196 ; WX 600 ; N tilde ; B 65 381 535 640 ;
+C 197 ; WX 600 ; N macron ; B 75 416 525 616 ;
+C 198 ; WX 600 ; N breve ; B 75 390 525 674 ;
+C 199 ; WX 600 ; N dotaccent ; B 200 431 400 631 ;
+C 200 ; WX 600 ; N dieresis ; B 96 431 504 631 ;
+C 202 ; WX 600 ; N ring ; B 127 353 473 694 ;
+C 203 ; WX 600 ; N cedilla ; B 130 -246 457 100 ;
+C 205 ; WX 600 ; N hungarumlaut ; B 75 390 525 689 ;
+C 206 ; WX 600 ; N ogonek ; B 200 -225 513 100 ;
+C 207 ; WX 600 ; N caron ; B 75 390 525 674 ;
+C 208 ; WX 600 ; N emdash ; B -79 181 679 381 ;
+C 225 ; WX 600 ; N AE ; B -70 -50 670 633 ;
+C 227 ; WX 600 ; N ordfeminine ; B 68 120 539 649 ;
+C 232 ; WX 600 ; N Lslash ; B -37 -50 621 633 ;
+C 233 ; WX 600 ; N Oslash ; B -40 -121 640 683 ;
+C 234 ; WX 600 ; N OE ; B -70 -50 670 633 ;
+C 235 ; WX 600 ; N ordmasculine ; B 72 120 530 649 ;
+C 241 ; WX 600 ; N ae ; B -70 -65 660 502 ;
+C 245 ; WX 600 ; N dotlessi ; B 12 -50 588 487 ;
+C 248 ; WX 600 ; N lslash ; B 12 -50 588 674 ;
+C 249 ; WX 600 ; N oslash ; B -27 -121 623 538 ;
+C 250 ; WX 600 ; N oe ; B -70 -65 660 502 ;
+C 251 ; WX 600 ; N germandbls ; B -37 -65 579 674 ;
+C -1 ; WX 600 ; N Aacute ; B -71 -50 671 839 ;
+C -1 ; WX 600 ; N Acircumflex ; B -71 -50 671 824 ;
+C -1 ; WX 600 ; N Adieresis ; B -71 -50 671 781 ;
+C -1 ; WX 600 ; N Agrave ; B -71 -50 671 839 ;
+C -1 ; WX 600 ; N Aring ; B -71 -50 671 855 ;
+C -1 ; WX 600 ; N Atilde ; B -71 -50 671 790 ;
+C -1 ; WX 600 ; N Ccedilla ; B -17 -246 614 648 ;
+C -1 ; WX 600 ; N Eacute ; B -37 -50 600 839 ;
+C -1 ; WX 600 ; N Ecircumflex ; B -37 -50 600 824 ;
+C -1 ; WX 600 ; N Edieresis ; B -37 -50 600 781 ;
+C -1 ; WX 600 ; N Egrave ; B -37 -50 600 839 ;
+C -1 ; WX 600 ; N Eth ; B -37 -50 600 633 ;
+C -1 ; WX 600 ; N Gcaron ; B -17 -65 642 824 ;
+C -1 ; WX 600 ; N IJ ; B -70 -65 670 633 ;
+C -1 ; WX 600 ; N Iacute ; B 33 -50 567 839 ;
+C -1 ; WX 600 ; N Icircumflex ; B 33 -50 567 824 ;
+C -1 ; WX 600 ; N Idieresis ; B 33 -50 567 781 ;
+C -1 ; WX 600 ; N Idot ; B 33 -50 567 781 ;
+C -1 ; WX 600 ; N Igrave ; B 33 -50 567 839 ;
+C -1 ; WX 600 ; N LL ; B -80 -50 680 633 ;
+C -1 ; WX 600 ; N Ntilde ; B -58 -50 642 790 ;
+C -1 ; WX 600 ; N Oacute ; B -29 -65 629 839 ;
+C -1 ; WX 600 ; N Ocircumflex ; B -29 -65 629 824 ;
+C -1 ; WX 600 ; N Odieresis ; B -29 -65 629 781 ;
+C -1 ; WX 600 ; N Ograve ; B -29 -65 629 839 ;
+C -1 ; WX 600 ; N Otilde ; B -29 -65 629 790 ;
+C -1 ; WX 600 ; N Scaron ; B 12 -65 588 824 ;
+C -1 ; WX 600 ; N Scedilla ; B 12 -246 588 648 ;
+C -1 ; WX 600 ; N Thorn ; B -37 -50 599 633 ;
+C -1 ; WX 600 ; N Uacute ; B -40 -65 640 839 ;
+C -1 ; WX 600 ; N Ucircumflex ; B -40 -65 640 824 ;
+C -1 ; WX 600 ; N Udieresis ; B -40 -65 640 781 ;
+C -1 ; WX 600 ; N Ugrave ; B -40 -65 640 839 ;
+C -1 ; WX 600 ; N Yacute ; B -29 -50 629 839 ;
+C -1 ; WX 600 ; N Ydieresis ; B -29 -50 629 781 ;
+C -1 ; WX 600 ; N Zcaron ; B 23 -50 577 824 ;
+C -1 ; WX 600 ; N aacute ; B -8 -65 621 710 ;
+C -1 ; WX 600 ; N acircumflex ; B -8 -65 621 703 ;
+C -1 ; WX 600 ; N adieresis ; B -8 -65 621 652 ;
+C -1 ; WX 600 ; N agrave ; B -8 -65 621 710 ;
+C -1 ; WX 600 ; N aring ; B -8 -65 621 746 ;
+C -1 ; WX 600 ; N arrowboth ; B -100 50 700 550 ;
+C -1 ; WX 600 ; N arrowdown ; B 50 -50 550 689 ;
+C -1 ; WX 600 ; N arrowleft ; B -100 50 700 550 ;
+C -1 ; WX 600 ; N arrowright ; B -100 50 700 550 ;
+C -1 ; WX 600 ; N arrowup ; B 50 -50 550 689 ;
+C -1 ; WX 600 ; N atilde ; B -8 -65 621 678 ;
+C -1 ; WX 600 ; N brokenbar ; B 200 -204 400 674 ;
+C -1 ; WX 600 ; N ccedilla ; B 4 -246 615 502 ;
+C -1 ; WX 600 ; N center ; B -60 -50 660 684 ;
+C -1 ; WX 600 ; N copyright ; B -80 -65 680 648 ;
+C -1 ; WX 600 ; N dectab ; B -65 -50 665 308 ;
+C -1 ; WX 600 ; N degree ; B 75 234 525 674 ;
+C -1 ; WX 600 ; N divide ; B -8 -9 608 591 ;
+C -1 ; WX 600 ; N down ; B 94 -50 506 502 ;
+C -1 ; WX 600 ; N eacute ; B -17 -65 600 714 ;
+C -1 ; WX 600 ; N ecircumflex ; B -17 -65 600 703 ;
+C -1 ; WX 600 ; N edieresis ; B -17 -65 600 652 ;
+C -1 ; WX 600 ; N egrave ; B -17 -65 600 714 ;
+C -1 ; WX 600 ; N eth ; B -8 -65 608 689 ;
+C -1 ; WX 600 ; N format ; B -75 -257 125 674 ;
+C -1 ; WX 600 ; N gcaron ; B -17 -257 642 695 ;
+C -1 ; WX 600 ; N graybox ; B -25 -100 625 700 ;
+C -1 ; WX 600 ; N iacute ; B 12 -50 588 710 ;
+C -1 ; WX 600 ; N icircumflex ; B 12 -50 588 684 ;
+C -1 ; WX 600 ; N idieresis ; B 12 -50 588 652 ;
+C -1 ; WX 600 ; N igrave ; B 12 -50 588 706 ;
+C -1 ; WX 600 ; N ij ; B -50 -257 610 725 ;
+C -1 ; WX 600 ; N indent ; B -6 0 606 412 ;
+C -1 ; WX 600 ; N largebullet ; B 200 206 400 406 ;
+C -1 ; WX 600 ; N left ; B -6 0 606 412 ;
+C -1 ; WX 600 ; N lira ; B -17 -50 600 648 ;
+C -1 ; WX 600 ; N ll ; B -60 -50 660 674 ;
+C -1 ; WX 600 ; N logicalnot ; B -8 94 608 454 ;
+C -1 ; WX 600 ; N merge ; B 94 -50 506 502 ;
+C -1 ; WX 600 ; N minus ; B -8 181 608 381 ;
+C -1 ; WX 600 ; N mu ; B -37 -257 621 487 ;
+C -1 ; WX 600 ; N multiply ; B 22 -48 578 530 ;
+C -1 ; WX 600 ; N notegraphic ; B 80 -65 520 689 ;
+C -1 ; WX 600 ; N ntilde ; B -27 -50 621 678 ;
+C -1 ; WX 600 ; N oacute ; B -8 -65 608 699 ;
+C -1 ; WX 600 ; N ocircumflex ; B -8 -65 608 703 ;
+C -1 ; WX 600 ; N odieresis ; B -8 -65 608 652 ;
+C -1 ; WX 600 ; N ograve ; B -8 -65 608 699 ;
+C -1 ; WX 600 ; N onehalf ; B -70 -65 670 674 ;
+C -1 ; WX 600 ; N onequarter ; B -70 -50 670 674 ;
+C -1 ; WX 600 ; N onesuperior ; B 100 140 500 674 ;
+C -1 ; WX 600 ; N otilde ; B -8 -65 608 657 ;
+C -1 ; WX 600 ; N overscore ; B -92 489 692 689 ;
+C -1 ; WX 600 ; N plusminus ; B -8 -50 608 610 ;
+C -1 ; WX 600 ; N prescription ; B -37 -50 669 633 ;
+C -1 ; WX 600 ; N registered ; B -80 -65 680 648 ;
+C -1 ; WX 600 ; N return ; B -84 -50 684 668 ;
+C -1 ; WX 600 ; N scaron ; B 23 -65 577 695 ;
+C -1 ; WX 600 ; N scedilla ; B 23 -246 577 502 ;
+C -1 ; WX 600 ; N square ; B -84 -50 684 668 ;
+C -1 ; WX 600 ; N stop ; B -84 -50 684 668 ;
+C -1 ; WX 600 ; N tab ; B -84 -50 684 668 ;
+C -1 ; WX 600 ; N thorn ; B -58 -257 621 674 ;
+C -1 ; WX 600 ; N threequarters ; B -70 -50 670 689 ;
+C -1 ; WX 600 ; N threesuperior ; B 95 131 512 689 ;
+C -1 ; WX 600 ; N trademark ; B -80 170 680 633 ;
+C -1 ; WX 600 ; N twosuperior ; B 80 140 491 689 ;
+C -1 ; WX 600 ; N uacute ; B -37 -65 621 706 ;
+C -1 ; WX 600 ; N ucircumflex ; B -37 -65 621 684 ;
+C -1 ; WX 600 ; N udieresis ; B -37 -65 621 652 ;
+C -1 ; WX 600 ; N ugrave ; B -37 -65 621 706 ;
+C -1 ; WX 600 ; N up ; B 94 -50 506 502 ;
+C -1 ; WX 600 ; N yacute ; B -29 -257 629 706 ;
+C -1 ; WX 600 ; N ydieresis ; B -29 -257 629 631 ;
+C -1 ; WX 600 ; N zcaron ; B 35 -50 569 695 ;
+EndCharMetrics
+StartComposites 58
+CC Zcaron 2 ; PCC Z 0 0 ; PCC caron 0 146 ;
+CC zcaron 2 ; PCC z 0 0 ; PCC caron 0 0 ;
+CC Scaron 2 ; PCC S 0 0 ; PCC caron 0 146 ;
+CC scaron 2 ; PCC s 0 0 ; PCC caron 0 0 ;
+CC Ccedilla 2 ; PCC C 0 0 ; PCC cedilla 0 0 ;
+CC ccedilla 2 ; PCC c 0 0 ; PCC cedilla 0 0 ;
+CC Yacute 2 ; PCC Y 0 0 ; PCC acute 0 146 ;
+CC yacute 2 ; PCC y 0 0 ; PCC acute 0 0 ;
+CC Ydieresis 2 ; PCC Y 0 0 ; PCC dieresis 0 146 ;
+CC ydieresis 2 ; PCC y 0 0 ; PCC dieresis 0 0 ;
+CC Uacute 2 ; PCC U 0 0 ; PCC acute 0 146 ;
+CC Ucircumflex 2 ; PCC U 0 0 ; PCC circumflex 0 146 ;
+CC Udieresis 2 ; PCC U 0 0 ; PCC dieresis 0 146 ;
+CC Ugrave 2 ; PCC U 0 0 ; PCC grave 0 146 ;
+CC uacute 2 ; PCC u 0 0 ; PCC acute 0 0 ;
+CC ucircumflex 2 ; PCC u 0 0 ; PCC circumflex 0 0 ;
+CC udieresis 2 ; PCC u 0 0 ; PCC dieresis 0 0 ;
+CC ugrave 2 ; PCC u 0 0 ; PCC grave 0 0 ;
+CC Iacute 2 ; PCC I 0 0 ; PCC acute 0 146 ;
+CC Icircumflex 2 ; PCC I 0 0 ; PCC circumflex 0 146 ;
+CC Idieresis 2 ; PCC I 0 0 ; PCC dieresis 0 146 ;
+CC Igrave 2 ; PCC I 0 0 ; PCC grave 0 146 ;
+CC iacute 2 ; PCC dotlessi 0 0 ; PCC acute 0 0 ;
+CC icircumflex 2 ; PCC dotlessi 0 0 ; PCC circumflex 0 0 ;
+CC idieresis 2 ; PCC dotlessi 0 0 ; PCC dieresis 0 0 ;
+CC igrave 2 ; PCC dotlessi 0 0 ; PCC grave 0 0 ;
+CC Eacute 2 ; PCC E 0 0 ; PCC acute 0 146 ;
+CC Ecircumflex 2 ; PCC E 0 0 ; PCC circumflex 0 146 ;
+CC Edieresis 2 ; PCC E 0 0 ; PCC dieresis 0 146 ;
+CC Egrave 2 ; PCC E 0 0 ; PCC grave 0 146 ;
+CC eacute 2 ; PCC e 0 0 ; PCC acute 0 0 ;
+CC ecircumflex 2 ; PCC e 0 0 ; PCC circumflex 0 0 ;
+CC edieresis 2 ; PCC e 0 0 ; PCC dieresis 0 0 ;
+CC egrave 2 ; PCC e 0 0 ; PCC grave 0 0 ;
+CC Aacute 2 ; PCC A 0 0 ; PCC acute 0 146 ;
+CC Acircumflex 2 ; PCC A 0 0 ; PCC circumflex 0 146 ;
+CC Adieresis 2 ; PCC A 0 0 ; PCC dieresis 0 146 ;
+CC Agrave 2 ; PCC A 0 0 ; PCC grave 0 146 ;
+CC aacute 2 ; PCC a 0 0 ; PCC acute 0 0 ;
+CC acircumflex 2 ; PCC a 0 0 ; PCC circumflex 0 0 ;
+CC adieresis 2 ; PCC a 0 0 ; PCC dieresis 0 0 ;
+CC agrave 2 ; PCC a 0 0 ; PCC grave 0 0 ;
+CC Oacute 2 ; PCC O 0 0 ; PCC acute 0 146 ;
+CC Ocircumflex 2 ; PCC O 0 0 ; PCC circumflex 0 146 ;
+CC Odieresis 2 ; PCC O 0 0 ; PCC dieresis 0 146 ;
+CC Ograve 2 ; PCC O 0 0 ; PCC grave 0 146 ;
+CC oacute 2 ; PCC o 0 0 ; PCC acute 0 0 ;
+CC ocircumflex 2 ; PCC o 0 0 ; PCC circumflex 0 0 ;
+CC odieresis 2 ; PCC o 0 0 ; PCC dieresis 0 0 ;
+CC ograve 2 ; PCC o 0 0 ; PCC grave 0 0 ;
+CC Atilde 2 ; PCC A 0 0 ; PCC tilde 0 146 ;
+CC atilde 2 ; PCC a 0 0 ; PCC tilde 0 0 ;
+CC Ntilde 2 ; PCC N 0 0 ; PCC tilde 0 146 ;
+CC ntilde 2 ; PCC n 0 0 ; PCC tilde 0 0 ;
+CC Otilde 2 ; PCC O 0 0 ; PCC tilde 0 146 ;
+CC otilde 2 ; PCC o 0 0 ; PCC tilde 0 0 ;
+CC Aring 2 ; PCC A 0 0 ; PCC ring 0 146 ;
+CC aring 2 ; PCC a 0 0 ; PCC ring 0 0 ;
+EndComposites
+EndFontMetrics
diff --git a/collects/afm/Courier-BoldOblique.afm b/collects/afm/Courier-BoldOblique.afm
new file mode 100644
index 0000000000..aeb3d90726
--- /dev/null
+++ b/collects/afm/Courier-BoldOblique.afm
@@ -0,0 +1,341 @@
+StartFontMetrics 2.0
+Comment Copyright (c) 1984 Adobe Systems Incorporated. All Rights Reserved.
+Comment Creation Date:Mon Apr 6 17:40:32 PDT 1987
+FontName Courier-BoldOblique
+EncodingScheme AdobeStandardEncoding
+FullName Courier Bold Oblique
+FamilyName Courier
+Weight Bold
+ItalicAngle -12.0
+IsFixedPitch true
+UnderlinePosition -85
+UnderlineThickness 100
+Version 001.004
+FontBBox -145 -350 817 855
+CapHeight 633
+XHeight 487
+Descender -257
+Ascender 674
+StartCharMetrics 260
+C 32 ; WX 600 ; N space ; B 500 -100 700 100 ;
+C 33 ; WX 600 ; N exclam ; B 197 -65 549 689 ;
+C 34 ; WX 600 ; N quotedbl ; B 171 254 654 663 ;
+C 35 ; WX 600 ; N numbersign ; B 52 -142 672 725 ;
+C 36 ; WX 600 ; N dollar ; B 51 -173 659 735 ;
+C 37 ; WX 600 ; N percent ; B 58 -65 671 689 ;
+C 38 ; WX 600 ; N ampersand ; B 52 -65 607 600 ;
+C 39 ; WX 600 ; N quoteright ; B 148 244 522 674 ;
+C 40 ; WX 600 ; N parenleft ; B 255 -204 662 683 ;
+C 41 ; WX 600 ; N parenright ; B 45 -204 452 683 ;
+C 42 ; WX 600 ; N asterisk ; B 131 150 665 674 ;
+C 43 ; WX 600 ; N plus ; B 52 -48 668 610 ;
+C 44 ; WX 600 ; N comma ; B 51 -215 424 215 ;
+C 45 ; WX 600 ; N hyphen ; B 52 181 668 381 ;
+C 46 ; WX 600 ; N period ; B 201 -50 421 150 ;
+C 47 ; WX 600 ; N slash ; B 20 -163 704 746 ;
+C 48 ; WX 600 ; N zero ; B 82 -65 649 689 ;
+C 49 ; WX 600 ; N one ; B 44 -50 578 674 ;
+C 50 ; WX 600 ; N two ; B 15 -50 656 689 ;
+C 51 ; WX 600 ; N three ; B 30 -65 659 689 ;
+C 52 ; WX 600 ; N four ; B 65 -50 618 674 ;
+C 53 ; WX 600 ; N five ; B 33 -65 660 674 ;
+C 54 ; WX 600 ; N six ; B 108 -65 712 689 ;
+C 55 ; WX 600 ; N seven ; B 136 -50 680 674 ;
+C 56 ; WX 600 ; N eight ; B 64 -65 655 689 ;
+C 57 ; WX 600 ; N nine ; B 67 -65 665 689 ;
+C 58 ; WX 600 ; N colon ; B 201 -50 489 472 ;
+C 59 ; WX 600 ; N semicolon ; B 63 -176 489 472 ;
+C 60 ; WX 600 ; N less ; B 52 -48 716 610 ;
+C 61 ; WX 600 ; N equal ; B 11 88 708 474 ;
+C 62 ; WX 600 ; N greater ; B 3 -48 668 610 ;
+C 63 ; WX 600 ; N question ; B 148 -65 657 648 ;
+C 64 ; WX 600 ; N at ; B 61 -142 640 705 ;
+C 65 ; WX 600 ; N A ; B -60 -50 682 633 ;
+C 66 ; WX 600 ; N B ; B -26 -50 670 633 ;
+C 67 ; WX 600 ; N C ; B 31 -65 713 648 ;
+C 68 ; WX 600 ; N D ; B -26 -50 670 633 ;
+C 69 ; WX 600 ; N E ; B -26 -50 692 633 ;
+C 70 ; WX 600 ; N F ; B -26 -50 713 633 ;
+C 71 ; WX 600 ; N G ; B 29 -65 713 648 ;
+C 72 ; WX 600 ; N H ; B -16 -50 723 633 ;
+C 73 ; WX 600 ; N I ; B 44 -50 680 633 ;
+C 74 ; WX 600 ; N J ; B 22 -65 776 633 ;
+C 75 ; WX 600 ; N K ; B -26 -50 744 633 ;
+C 76 ; WX 600 ; N L ; B -6 -50 665 633 ;
+C 77 ; WX 600 ; N M ; B -58 -50 776 633 ;
+C 78 ; WX 600 ; N N ; B -26 -50 755 633 ;
+C 79 ; WX 600 ; N O ; B 26 -65 696 648 ;
+C 80 ; WX 600 ; N P ; B -26 -50 666 633 ;
+C 81 ; WX 600 ; N Q ; B 26 -196 696 648 ;
+C 82 ; WX 600 ; N R ; B -26 -50 680 633 ;
+C 83 ; WX 600 ; N S ; B 23 -65 680 648 ;
+C 84 ; WX 600 ; N T ; B 72 -50 721 633 ;
+C 85 ; WX 600 ; N U ; B 61 -65 753 633 ;
+C 86 ; WX 600 ; N V ; B 42 -50 784 633 ;
+C 87 ; WX 600 ; N W ; B 50 -50 773 633 ;
+C 88 ; WX 600 ; N X ; B -29 -50 742 633 ;
+C 89 ; WX 600 ; N Y ; B 76 -50 742 633 ;
+C 90 ; WX 600 ; N Z ; B 34 -50 669 633 ;
+C 91 ; WX 600 ; N bracketleft ; B 178 -204 647 674 ;
+C 92 ; WX 600 ; N backslash ; B 170 -163 554 746 ;
+C 93 ; WX 600 ; N bracketright ; B 53 -204 522 674 ;
+C 94 ; WX 600 ; N asciicircum ; B 113 275 647 674 ;
+C 95 ; WX 600 ; N underscore ; B -145 -350 639 -150 ;
+C 96 ; WX 600 ; N quoteleft ; B 322 244 598 674 ;
+C 97 ; WX 600 ; N a ; B 16 -65 632 502 ;
+C 98 ; WX 600 ; N b ; B -47 -65 670 674 ;
+C 99 ; WX 600 ; N c ; B 44 -65 672 502 ;
+C 100 ; WX 600 ; N d ; B 23 -65 701 674 ;
+C 101 ; WX 600 ; N e ; B 25 -65 650 502 ;
+C 102 ; WX 600 ; N f ; B 36 -50 740 674 ; L i fi ; L l fl ;
+C 103 ; WX 600 ; N g ; B 25 -257 724 502 ;
+C 104 ; WX 600 ; N h ; B -16 -50 642 674 ;
+C 105 ; WX 600 ; N i ; B 23 -50 599 725 ;
+C 106 ; WX 600 ; N j ; B 34 -257 620 725 ;
+C 107 ; WX 600 ; N k ; B -6 -50 661 674 ;
+C 108 ; WX 600 ; N l ; B 23 -50 599 674 ;
+C 109 ; WX 600 ; N m ; B -58 -50 684 502 ;
+C 110 ; WX 600 ; N n ; B -16 -50 632 502 ;
+C 111 ; WX 600 ; N o ; B 34 -65 656 502 ;
+C 112 ; WX 600 ; N p ; B -91 -257 671 502 ;
+C 113 ; WX 600 ; N q ; B 27 -257 745 502 ;
+C 114 ; WX 600 ; N r ; B 15 -50 699 501 ;
+C 115 ; WX 600 ; N s ; B 34 -65 638 502 ;
+C 116 ; WX 600 ; N t ; B 45 -65 599 642 ;
+C 117 ; WX 600 ; N u ; B 45 -65 640 487 ;
+C 118 ; WX 600 ; N v ; B 32 -50 732 487 ;
+C 119 ; WX 600 ; N w ; B 32 -50 732 487 ;
+C 120 ; WX 600 ; N x ; B -18 -50 690 487 ;
+C 121 ; WX 600 ; N y ; B -62 -257 711 487 ;
+C 122 ; WX 600 ; N z ; B 46 -50 640 487 ;
+C 123 ; WX 600 ; N braceleft ; B 168 -204 605 674 ;
+C 124 ; WX 600 ; N bar ; B 178 -204 522 674 ;
+C 125 ; WX 600 ; N braceright ; B 95 -204 534 674 ;
+C 126 ; WX 600 ; N asciitilde ; B 67 129 652 433 ;
+C 161 ; WX 600 ; N exclamdown ; B 143 -257 490 475 ;
+C 162 ; WX 600 ; N cent ; B 96 -79 643 725 ;
+C 163 ; WX 600 ; N sterling ; B 15 -50 620 648 ;
+C 164 ; WX 600 ; N fraction ; B 5 60 725 552 ;
+C 165 ; WX 600 ; N yen ; B 77 -50 742 633 ;
+C 166 ; WX 600 ; N florin ; B -6 -173 720 689 ;
+C 167 ; WX 600 ; N section ; B 18 -147 697 689 ;
+C 168 ; WX 600 ; N currency ; B 47 15 677 569 ;
+C 169 ; WX 600 ; N quotesingle ; B 273 244 552 674 ;
+C 170 ; WX 600 ; N quotedblleft ; B 156 280 648 678 ;
+C 171 ; WX 600 ; N guillemotleft ; B 27 -50 703 487 ;
+C 172 ; WX 600 ; N guilsinglleft ; B 27 -50 474 487 ;
+C 173 ; WX 600 ; N guilsinglright ; B 224 -50 665 487 ;
+C 174 ; WX 600 ; N fi ; B -59 -50 681 725 ;
+C 175 ; WX 600 ; N fl ; B -59 -50 687 674 ;
+C 177 ; WX 600 ; N endash ; B 52 181 668 381 ;
+C 178 ; WX 600 ; N dagger ; B 126 -142 638 674 ;
+C 179 ; WX 600 ; N daggerdbl ; B 75 -142 638 674 ;
+C 180 ; WX 600 ; N periodcentered ; B 255 206 475 406 ;
+C 182 ; WX 600 ; N paragraph ; B 72 -147 730 689 ;
+C 183 ; WX 600 ; N bullet ; B 265 206 465 406 ;
+C 184 ; WX 600 ; N quotesinglbase ; B 48 -225 422 204 ;
+C 185 ; WX 600 ; N quotedblbase ; B 12 -199 588 199 ;
+C 186 ; WX 600 ; N quotedblright ; B 114 280 690 678 ;
+C 187 ; WX 600 ; N guillemotright ; B -6 -50 665 487 ;
+C 188 ; WX 600 ; N ellipsis ; B 7 -65 607 135 ;
+C 189 ; WX 600 ; N perthousand ; B 55 -65 679 689 ;
+C 191 ; WX 600 ; N questiondown ; B 26 -257 533 475 ;
+C 193 ; WX 600 ; N grave ; B 200 390 504 689 ;
+C 194 ; WX 600 ; N acute ; B 304 390 650 689 ;
+C 195 ; WX 600 ; N circumflex ; B 179 390 629 674 ;
+C 196 ; WX 600 ; N tilde ; B 171 381 646 640 ;
+C 197 ; WX 600 ; N macron ; B 185 416 635 616 ;
+C 198 ; WX 600 ; N breve ; B 196 390 647 674 ;
+C 199 ; WX 600 ; N dotaccent ; B 313 431 513 631 ;
+C 200 ; WX 600 ; N dieresis ; B 209 431 617 631 ;
+C 202 ; WX 600 ; N ring ; B 237 353 586 694 ;
+C 203 ; WX 600 ; N cedilla ; B 103 -246 436 100 ;
+C 205 ; WX 600 ; N hungarumlaut ; B 179 390 650 689 ;
+C 206 ; WX 600 ; N ogonek ; B 184 -225 490 100 ;
+C 207 ; WX 600 ; N caron ; B 197 390 647 674 ;
+C 208 ; WX 600 ; N emdash ; B -19 181 739 381 ;
+C 225 ; WX 600 ; N AE ; B -59 -50 763 633 ;
+C 227 ; WX 600 ; N ordfeminine ; B 114 120 590 649 ;
+C 232 ; WX 600 ; N Lslash ; B -6 -50 665 633 ;
+C 233 ; WX 600 ; N Oslash ; B -44 -121 764 683 ;
+C 234 ; WX 600 ; N OE ; B -16 -50 763 633 ;
+C 235 ; WX 600 ; N ordmasculine ; B 118 120 623 649 ;
+C 241 ; WX 600 ; N ae ; B -39 -65 711 502 ;
+C 245 ; WX 600 ; N dotlessi ; B 23 -50 599 487 ;
+C 248 ; WX 600 ; N lslash ; B 23 -50 604 674 ;
+C 249 ; WX 600 ; N oslash ; B -31 -121 716 538 ;
+C 250 ; WX 600 ; N oe ; B -30 -65 711 502 ;
+C 251 ; WX 600 ; N germandbls ; B -26 -65 618 674 ;
+C -1 ; WX 600 ; N Aacute ; B -60 -50 682 839 ;
+C -1 ; WX 600 ; N Acircumflex ; B -60 -50 682 824 ;
+C -1 ; WX 600 ; N Adieresis ; B -60 -50 682 781 ;
+C -1 ; WX 600 ; N Agrave ; B -60 -50 682 839 ;
+C -1 ; WX 600 ; N Aring ; B -60 -50 682 855 ;
+C -1 ; WX 600 ; N Atilde ; B -60 -50 682 790 ;
+C -1 ; WX 600 ; N Ccedilla ; B 31 -246 713 648 ;
+C -1 ; WX 600 ; N Eacute ; B -26 -50 692 839 ;
+C -1 ; WX 600 ; N Ecircumflex ; B -26 -50 692 824 ;
+C -1 ; WX 600 ; N Edieresis ; B -26 -50 692 781 ;
+C -1 ; WX 600 ; N Egrave ; B -26 -50 692 839 ;
+C -1 ; WX 600 ; N Eth ; B -26 -50 670 633 ;
+C -1 ; WX 600 ; N Gcaron ; B 29 -65 713 824 ;
+C -1 ; WX 600 ; N IJ ; B -59 -65 783 633 ;
+C -1 ; WX 600 ; N Iacute ; B 44 -50 680 839 ;
+C -1 ; WX 600 ; N Icircumflex ; B 44 -50 680 824 ;
+C -1 ; WX 600 ; N Idieresis ; B 44 -50 680 781 ;
+C -1 ; WX 600 ; N Idot ; B 44 -50 680 781 ;
+C -1 ; WX 600 ; N Igrave ; B 44 -50 680 839 ;
+C -1 ; WX 600 ; N LL ; B -69 -50 712 633 ;
+C -1 ; WX 600 ; N Ntilde ; B -26 -50 755 790 ;
+C -1 ; WX 600 ; N Oacute ; B 26 -65 696 839 ;
+C -1 ; WX 600 ; N Ocircumflex ; B 26 -65 696 824 ;
+C -1 ; WX 600 ; N Odieresis ; B 26 -65 696 781 ;
+C -1 ; WX 600 ; N Ograve ; B 26 -65 696 839 ;
+C -1 ; WX 600 ; N Otilde ; B 26 -65 696 790 ;
+C -1 ; WX 600 ; N Scaron ; B 23 -65 680 824 ;
+C -1 ; WX 600 ; N Scedilla ; B 23 -246 680 648 ;
+C -1 ; WX 600 ; N Thorn ; B -26 -50 663 633 ;
+C -1 ; WX 600 ; N Uacute ; B 61 -65 753 839 ;
+C -1 ; WX 600 ; N Ucircumflex ; B 61 -65 753 824 ;
+C -1 ; WX 600 ; N Udieresis ; B 61 -65 753 781 ;
+C -1 ; WX 600 ; N Ugrave ; B 61 -65 753 839 ;
+C -1 ; WX 600 ; N Yacute ; B 76 -50 742 839 ;
+C -1 ; WX 600 ; N Ydieresis ; B 76 -50 742 781 ;
+C -1 ; WX 600 ; N Zcaron ; B 34 -50 679 824 ;
+C -1 ; WX 600 ; N aacute ; B 16 -65 632 710 ;
+C -1 ; WX 600 ; N acircumflex ; B 16 -65 635 703 ;
+C -1 ; WX 600 ; N adieresis ; B 16 -65 632 652 ;
+C -1 ; WX 600 ; N agrave ; B 16 -65 632 710 ;
+C -1 ; WX 600 ; N aring ; B 16 -65 632 746 ;
+C -1 ; WX 600 ; N arrowboth ; B -36 50 764 550 ;
+C -1 ; WX 600 ; N arrowdown ; B 93 -50 593 689 ;
+C -1 ; WX 600 ; N arrowleft ; B -36 50 764 550 ;
+C -1 ; WX 600 ; N arrowright ; B -36 50 764 550 ;
+C -1 ; WX 600 ; N arrowup ; B 143 -50 643 689 ;
+C -1 ; WX 600 ; N atilde ; B 16 -65 654 678 ;
+C -1 ; WX 600 ; N brokenbar ; B 178 -204 522 674 ;
+C -1 ; WX 600 ; N ccedilla ; B 44 -246 672 502 ;
+C -1 ; WX 600 ; N center ; B 2 -50 722 684 ;
+C -1 ; WX 600 ; N copyright ; B -27 -65 743 648 ;
+C -1 ; WX 600 ; N dectab ; B -54 -50 676 308 ;
+C -1 ; WX 600 ; N degree ; B 171 234 624 674 ;
+C -1 ; WX 600 ; N divide ; B 52 -9 668 591 ;
+C -1 ; WX 600 ; N down ; B 127 -50 539 502 ;
+C -1 ; WX 600 ; N eacute ; B 25 -65 650 714 ;
+C -1 ; WX 600 ; N ecircumflex ; B 25 -65 650 703 ;
+C -1 ; WX 600 ; N edieresis ; B 25 -65 650 652 ;
+C -1 ; WX 600 ; N egrave ; B 25 -65 650 714 ;
+C -1 ; WX 600 ; N eth ; B 28 -65 695 689 ;
+C -1 ; WX 600 ; N format ; B -108 -257 247 674 ;
+C -1 ; WX 600 ; N gcaron ; B 25 -257 724 695 ;
+C -1 ; WX 600 ; N graybox ; B -25 -100 753 700 ;
+C -1 ; WX 600 ; N iacute ; B 23 -50 599 710 ;
+C -1 ; WX 600 ; N icircumflex ; B 23 -50 599 684 ;
+C -1 ; WX 600 ; N idieresis ; B 23 -50 599 652 ;
+C -1 ; WX 600 ; N igrave ; B 23 -50 599 706 ;
+C -1 ; WX 600 ; N ij ; B -39 -257 692 725 ;
+C -1 ; WX 600 ; N indent ; B 38 0 650 412 ;
+C -1 ; WX 600 ; N largebullet ; B 265 206 465 406 ;
+C -1 ; WX 600 ; N left ; B 38 0 650 412 ;
+C -1 ; WX 600 ; N lira ; B 15 -50 620 648 ;
+C -1 ; WX 600 ; N ll ; B -49 -50 682 674 ;
+C -1 ; WX 600 ; N logicalnot ; B 67 94 683 454 ;
+C -1 ; WX 600 ; N merge ; B 127 -50 569 502 ;
+C -1 ; WX 600 ; N minus ; B 52 181 668 381 ;
+C -1 ; WX 600 ; N mu ; B 13 -257 640 487 ;
+C -1 ; WX 600 ; N multiply ; B 33 -48 669 530 ;
+C -1 ; WX 600 ; N notegraphic ; B 107 -65 639 689 ;
+C -1 ; WX 600 ; N ntilde ; B -16 -50 632 678 ;
+C -1 ; WX 600 ; N oacute ; B 34 -65 656 699 ;
+C -1 ; WX 600 ; N ocircumflex ; B 34 -65 656 703 ;
+C -1 ; WX 600 ; N odieresis ; B 34 -65 656 652 ;
+C -1 ; WX 600 ; N ograve ; B 34 -65 656 699 ;
+C -1 ; WX 600 ; N onehalf ; B -14 -65 725 674 ;
+C -1 ; WX 600 ; N onequarter ; B -14 -50 741 674 ;
+C -1 ; WX 600 ; N onesuperior ; B 151 140 551 674 ;
+C -1 ; WX 600 ; N otilde ; B 34 -65 656 657 ;
+C -1 ; WX 600 ; N overscore ; B 33 489 817 689 ;
+C -1 ; WX 600 ; N plusminus ; B 3 -50 677 610 ;
+C -1 ; WX 600 ; N prescription ; B -26 -50 680 633 ;
+C -1 ; WX 600 ; N registered ; B -27 -65 743 648 ;
+C -1 ; WX 600 ; N return ; B -24 -50 805 668 ;
+C -1 ; WX 600 ; N scaron ; B 34 -65 651 695 ;
+C -1 ; WX 600 ; N scedilla ; B 34 -246 638 502 ;
+C -1 ; WX 600 ; N square ; B -73 -50 805 668 ;
+C -1 ; WX 600 ; N stop ; B -73 -50 805 668 ;
+C -1 ; WX 600 ; N tab ; B -73 -50 744 668 ;
+C -1 ; WX 600 ; N thorn ; B -91 -257 671 674 ;
+C -1 ; WX 600 ; N threequarters ; B -3 -50 711 689 ;
+C -1 ; WX 600 ; N threesuperior ; B 155 131 612 689 ;
+C -1 ; WX 600 ; N trademark ; B 18 170 793 633 ;
+C -1 ; WX 600 ; N twosuperior ; B 131 140 601 689 ;
+C -1 ; WX 600 ; N uacute ; B 45 -65 640 706 ;
+C -1 ; WX 600 ; N ucircumflex ; B 45 -65 640 684 ;
+C -1 ; WX 600 ; N udieresis ; B 45 -65 640 652 ;
+C -1 ; WX 600 ; N ugrave ; B 45 -65 640 706 ;
+C -1 ; WX 600 ; N up ; B 157 -50 569 502 ;
+C -1 ; WX 600 ; N yacute ; B -62 -257 711 706 ;
+C -1 ; WX 600 ; N ydieresis ; B -62 -257 711 631 ;
+C -1 ; WX 600 ; N zcaron ; B 46 -50 651 695 ;
+EndCharMetrics
+StartComposites 58
+CC Zcaron 2 ; PCC Z 0 0 ; PCC caron 0 146 ;
+CC zcaron 2 ; PCC z 0 0 ; PCC caron 0 0 ;
+CC Scaron 2 ; PCC S 0 0 ; PCC caron 0 146 ;
+CC scaron 2 ; PCC s 0 0 ; PCC caron 0 0 ;
+CC Ccedilla 2 ; PCC C 0 0 ; PCC cedilla 0 0 ;
+CC ccedilla 2 ; PCC c 0 0 ; PCC cedilla 0 0 ;
+CC Yacute 2 ; PCC Y 0 0 ; PCC acute 0 146 ;
+CC yacute 2 ; PCC y 0 0 ; PCC acute 0 0 ;
+CC Ydieresis 2 ; PCC Y 0 0 ; PCC dieresis 0 146 ;
+CC ydieresis 2 ; PCC y 0 0 ; PCC dieresis 0 0 ;
+CC Uacute 2 ; PCC U 0 0 ; PCC acute 0 146 ;
+CC Ucircumflex 2 ; PCC U 0 0 ; PCC circumflex 0 146 ;
+CC Udieresis 2 ; PCC U 0 0 ; PCC dieresis 0 146 ;
+CC Ugrave 2 ; PCC U 0 0 ; PCC grave 0 146 ;
+CC uacute 2 ; PCC u 0 0 ; PCC acute 0 0 ;
+CC ucircumflex 2 ; PCC u 0 0 ; PCC circumflex 0 0 ;
+CC udieresis 2 ; PCC u 0 0 ; PCC dieresis 0 0 ;
+CC ugrave 2 ; PCC u 0 0 ; PCC grave 0 0 ;
+CC Iacute 2 ; PCC I 0 0 ; PCC acute 0 146 ;
+CC Icircumflex 2 ; PCC I 0 0 ; PCC circumflex 0 146 ;
+CC Idieresis 2 ; PCC I 0 0 ; PCC dieresis 0 146 ;
+CC Igrave 2 ; PCC I 0 0 ; PCC grave 0 146 ;
+CC iacute 2 ; PCC dotlessi 0 0 ; PCC acute 0 0 ;
+CC icircumflex 2 ; PCC dotlessi 0 0 ; PCC circumflex 0 0 ;
+CC idieresis 2 ; PCC dotlessi 0 0 ; PCC dieresis 0 0 ;
+CC igrave 2 ; PCC dotlessi 0 0 ; PCC grave 0 0 ;
+CC Eacute 2 ; PCC E 0 0 ; PCC acute 0 146 ;
+CC Ecircumflex 2 ; PCC E 0 0 ; PCC circumflex 0 146 ;
+CC Edieresis 2 ; PCC E 0 0 ; PCC dieresis 0 146 ;
+CC Egrave 2 ; PCC E 0 0 ; PCC grave 0 146 ;
+CC eacute 2 ; PCC e 0 0 ; PCC acute 0 0 ;
+CC ecircumflex 2 ; PCC e 0 0 ; PCC circumflex 0 0 ;
+CC edieresis 2 ; PCC e 0 0 ; PCC dieresis 0 0 ;
+CC egrave 2 ; PCC e 0 0 ; PCC grave 0 0 ;
+CC Aacute 2 ; PCC A 0 0 ; PCC acute 0 146 ;
+CC Acircumflex 2 ; PCC A 0 0 ; PCC circumflex 0 146 ;
+CC Adieresis 2 ; PCC A 0 0 ; PCC dieresis 0 146 ;
+CC Agrave 2 ; PCC A 0 0 ; PCC grave 0 146 ;
+CC aacute 2 ; PCC a 0 0 ; PCC acute 0 0 ;
+CC acircumflex 2 ; PCC a 0 0 ; PCC circumflex 0 0 ;
+CC adieresis 2 ; PCC a 0 0 ; PCC dieresis 0 0 ;
+CC agrave 2 ; PCC a 0 0 ; PCC grave 0 0 ;
+CC Oacute 2 ; PCC O 0 0 ; PCC acute 0 146 ;
+CC Ocircumflex 2 ; PCC O 0 0 ; PCC circumflex 0 146 ;
+CC Odieresis 2 ; PCC O 0 0 ; PCC dieresis 0 146 ;
+CC Ograve 2 ; PCC O 0 0 ; PCC grave 0 146 ;
+CC oacute 2 ; PCC o 0 0 ; PCC acute 0 0 ;
+CC ocircumflex 2 ; PCC o 0 0 ; PCC circumflex 0 0 ;
+CC odieresis 2 ; PCC o 0 0 ; PCC dieresis 0 0 ;
+CC ograve 2 ; PCC o 0 0 ; PCC grave 0 0 ;
+CC Atilde 2 ; PCC A 0 0 ; PCC tilde 0 146 ;
+CC atilde 2 ; PCC a 0 0 ; PCC tilde 0 0 ;
+CC Ntilde 2 ; PCC N 0 0 ; PCC tilde 0 146 ;
+CC ntilde 2 ; PCC n 0 0 ; PCC tilde 0 0 ;
+CC Otilde 2 ; PCC O 0 0 ; PCC tilde 0 146 ;
+CC otilde 2 ; PCC o 0 0 ; PCC tilde 0 0 ;
+CC Aring 2 ; PCC A 0 0 ; PCC ring 0 146 ;
+CC aring 2 ; PCC a 0 0 ; PCC ring 0 0 ;
+EndComposites
+EndFontMetrics
diff --git a/collects/afm/Courier-Oblique.afm b/collects/afm/Courier-Oblique.afm
new file mode 100644
index 0000000000..9e463b9604
--- /dev/null
+++ b/collects/afm/Courier-Oblique.afm
@@ -0,0 +1,341 @@
+StartFontMetrics 2.0
+Comment Copyright (c) 1984 Adobe Systems Incorporated. All Rights Reserved.
+Comment Creation Date:Mon Apr 6 17:05:22 PDT 1987
+FontName Courier-Oblique
+EncodingScheme AdobeStandardEncoding
+FullName Courier Oblique
+FamilyName Courier
+Weight Medium
+ItalicAngle -12.0
+IsFixedPitch true
+UnderlinePosition -82
+UnderlineThickness 40
+Version 001.004
+FontBBox -85 -290 759 795
+CapHeight 583
+XHeight 437
+Descender -207
+Ascender 624
+StartCharMetrics 260
+C 32 ; WX 600 ; N space ; B 560 -40 640 40 ;
+C 33 ; WX 600 ; N exclam ; B 257 -5 483 639 ;
+C 34 ; WX 600 ; N quotedbl ; B 231 314 594 603 ;
+C 35 ; WX 600 ; N numbersign ; B 116 -82 608 665 ;
+C 36 ; WX 600 ; N dollar ; B 111 -113 601 675 ;
+C 37 ; WX 600 ; N percent ; B 118 -35 611 639 ;
+C 38 ; WX 600 ; N ampersand ; B 112 -35 547 540 ;
+C 39 ; WX 600 ; N quoteright ; B 208 304 462 613 ;
+C 40 ; WX 600 ; N parenleft ; B 315 -144 602 623 ;
+C 41 ; WX 600 ; N parenright ; B 105 -144 392 623 ;
+C 42 ; WX 600 ; N asterisk ; B 191 210 605 624 ;
+C 43 ; WX 600 ; N plus ; B 112 12 608 550 ;
+C 44 ; WX 600 ; N comma ; B 111 -155 364 155 ;
+C 45 ; WX 600 ; N hyphen ; B 112 241 608 321 ;
+C 46 ; WX 600 ; N period ; B 261 10 361 90 ;
+C 47 ; WX 600 ; N slash ; B 80 -103 644 686 ;
+C 48 ; WX 600 ; N zero ; B 139 -35 590 639 ;
+C 49 ; WX 600 ; N one ; B 97 -20 511 624 ;
+C 50 ; WX 600 ; N two ; B 68 -20 596 639 ;
+C 51 ; WX 600 ; N three ; B 90 -35 599 639 ;
+C 52 ; WX 600 ; N four ; B 125 -20 560 624 ;
+C 53 ; WX 600 ; N five ; B 93 -35 602 624 ;
+C 54 ; WX 600 ; N six ; B 167 -35 654 639 ;
+C 55 ; WX 600 ; N seven ; B 196 -20 622 624 ;
+C 56 ; WX 600 ; N eight ; B 124 -35 595 639 ;
+C 57 ; WX 600 ; N nine ; B 120 -35 606 639 ;
+C 58 ; WX 600 ; N colon ; B 261 10 425 392 ;
+C 59 ; WX 600 ; N semicolon ; B 123 -116 425 392 ;
+C 60 ; WX 600 ; N less ; B 112 12 656 550 ;
+C 61 ; WX 600 ; N equal ; B 75 168 644 394 ;
+C 62 ; WX 600 ; N greater ; B 63 12 608 550 ;
+C 63 ; WX 600 ; N question ; B 211 -5 597 598 ;
+C 64 ; WX 600 ; N at ; B 120 -82 580 644 ;
+C 65 ; WX 600 ; N A ; B -7 -20 615 583 ;
+C 66 ; WX 600 ; N B ; B 27 -20 610 583 ;
+C 67 ; WX 600 ; N C ; B 91 -35 655 598 ;
+C 68 ; WX 600 ; N D ; B 27 -20 610 583 ;
+C 69 ; WX 600 ; N E ; B 27 -20 634 583 ;
+C 70 ; WX 600 ; N F ; B 27 -20 655 583 ;
+C 71 ; WX 600 ; N G ; B 89 -35 655 598 ;
+C 72 ; WX 600 ; N H ; B 37 -20 665 583 ;
+C 73 ; WX 600 ; N I ; B 97 -20 622 583 ;
+C 74 ; WX 600 ; N J ; B 82 -35 718 583 ;
+C 75 ; WX 600 ; N K ; B 27 -20 686 583 ;
+C 76 ; WX 600 ; N L ; B 47 -20 605 583 ;
+C 77 ; WX 600 ; N M ; B -5 -20 718 583 ;
+C 78 ; WX 600 ; N N ; B 27 -20 697 583 ;
+C 79 ; WX 600 ; N O ; B 83 -35 636 598 ;
+C 80 ; WX 600 ; N P ; B 27 -20 606 583 ;
+C 81 ; WX 600 ; N Q ; B 84 -136 636 598 ;
+C 82 ; WX 600 ; N R ; B 27 -20 613 583 ;
+C 83 ; WX 600 ; N S ; B 76 -35 622 598 ;
+C 84 ; WX 600 ; N T ; B 129 -20 663 583 ;
+C 85 ; WX 600 ; N U ; B 119 -35 695 583 ;
+C 86 ; WX 600 ; N V ; B 104 -20 726 583 ;
+C 87 ; WX 600 ; N W ; B 103 -20 715 583 ;
+C 88 ; WX 600 ; N X ; B 24 -20 684 583 ;
+C 89 ; WX 600 ; N Y ; B 129 -20 684 583 ;
+C 90 ; WX 600 ; N Z ; B 87 -20 611 583 ;
+C 91 ; WX 600 ; N bracketleft ; B 238 -144 589 624 ;
+C 92 ; WX 600 ; N backslash ; B 230 -103 494 686 ;
+C 93 ; WX 600 ; N bracketright ; B 113 -144 464 624 ;
+C 94 ; WX 600 ; N asciicircum ; B 173 335 587 624 ;
+C 95 ; WX 600 ; N underscore ; B -85 -290 579 -210 ;
+C 96 ; WX 600 ; N quoteleft ; B 382 304 538 613 ;
+C 97 ; WX 600 ; N a ; B 74 -35 565 452 ;
+C 98 ; WX 600 ; N b ; B 6 -35 610 624 ;
+C 99 ; WX 600 ; N c ; B 104 -35 614 452 ;
+C 100 ; WX 600 ; N d ; B 83 -35 643 624 ;
+C 101 ; WX 600 ; N e ; B 85 -35 590 452 ;
+C 102 ; WX 600 ; N f ; B 89 -20 682 624 ; L i fi ; L l fl ;
+C 103 ; WX 600 ; N g ; B 85 -207 666 452 ;
+C 104 ; WX 600 ; N h ; B 37 -20 575 624 ;
+C 105 ; WX 600 ; N i ; B 76 -20 532 665 ;
+C 106 ; WX 600 ; N j ; B 92 -207 562 665 ;
+C 107 ; WX 600 ; N k ; B 47 -20 603 624 ;
+C 108 ; WX 600 ; N l ; B 76 -20 532 624 ;
+C 109 ; WX 600 ; N m ; B -5 -20 621 452 ;
+C 110 ; WX 600 ; N n ; B 37 -20 565 452 ;
+C 111 ; WX 600 ; N o ; B 91 -35 597 452 ;
+C 112 ; WX 600 ; N p ; B -33 -207 612 452 ;
+C 113 ; WX 600 ; N q ; B 85 -207 687 452 ;
+C 114 ; WX 600 ; N r ; B 68 -20 639 448 ;
+C 115 ; WX 600 ; N s ; B 87 -35 580 452 ;
+C 116 ; WX 600 ; N t ; B 107 -35 541 582 ;
+C 117 ; WX 600 ; N u ; B 107 -35 582 437 ;
+C 118 ; WX 600 ; N v ; B 94 -20 674 437 ;
+C 119 ; WX 600 ; N w ; B 94 -20 674 437 ;
+C 120 ; WX 600 ; N x ; B 35 -20 632 437 ;
+C 121 ; WX 600 ; N y ; B -4 -207 653 437 ;
+C 122 ; WX 600 ; N z ; B 99 -20 582 437 ;
+C 123 ; WX 600 ; N braceleft ; B 228 -144 547 624 ;
+C 124 ; WX 600 ; N bar ; B 238 -144 464 624 ;
+C 125 ; WX 600 ; N braceright ; B 155 -144 474 624 ;
+C 126 ; WX 600 ; N asciitilde ; B 127 189 592 373 ;
+C 161 ; WX 600 ; N exclamdown ; B 209 -207 430 415 ;
+C 162 ; WX 600 ; N cent ; B 156 -19 583 665 ;
+C 163 ; WX 600 ; N sterling ; B 68 -20 560 598 ;
+C 164 ; WX 600 ; N fraction ; B 65 120 665 492 ;
+C 165 ; WX 600 ; N yen ; B 137 -20 684 583 ;
+C 166 ; WX 600 ; N florin ; B 54 -113 663 639 ;
+C 167 ; WX 600 ; N section ; B 78 -87 637 629 ;
+C 168 ; WX 600 ; N currency ; B 107 75 617 509 ;
+C 169 ; WX 600 ; N quotesingle ; B 333 304 492 613 ;
+C 170 ; WX 600 ; N quotedblleft ; B 216 340 588 619 ;
+C 171 ; WX 600 ; N guillemotleft ; B 87 -20 645 437 ;
+C 172 ; WX 600 ; N guilsinglleft ; B 87 -20 416 437 ;
+C 173 ; WX 600 ; N guilsinglright ; B 277 -20 605 437 ;
+C 174 ; WX 600 ; N fi ; B -6 -20 628 665 ;
+C 175 ; WX 600 ; N fl ; B -6 -20 629 624 ;
+C 177 ; WX 600 ; N endash ; B 112 241 608 321 ;
+C 178 ; WX 600 ; N dagger ; B 188 -82 580 624 ;
+C 179 ; WX 600 ; N daggerdbl ; B 135 -82 580 624 ;
+C 180 ; WX 600 ; N periodcentered ; B 315 266 415 346 ;
+C 182 ; WX 600 ; N paragraph ; B 132 -87 670 629 ;
+C 183 ; WX 600 ; N bullet ; B 325 266 405 346 ;
+C 184 ; WX 600 ; N quotesinglbase ; B 108 -165 362 144 ;
+C 185 ; WX 600 ; N quotedblbase ; B 72 -139 528 139 ;
+C 186 ; WX 600 ; N quotedblright ; B 174 340 630 619 ;
+C 187 ; WX 600 ; N guillemotright ; B 47 -20 605 437 ;
+C 188 ; WX 600 ; N ellipsis ; B 67 -5 547 75 ;
+C 189 ; WX 600 ; N perthousand ; B 117 -35 619 639 ;
+C 191 ; WX 600 ; N questiondown ; B 85 -207 470 415 ;
+C 193 ; WX 600 ; N grave ; B 262 450 444 639 ;
+C 194 ; WX 600 ; N acute ; B 364 450 592 639 ;
+C 195 ; WX 600 ; N circumflex ; B 239 450 569 624 ;
+C 196 ; WX 600 ; N tilde ; B 231 441 586 580 ;
+C 197 ; WX 600 ; N macron ; B 245 476 575 556 ;
+C 198 ; WX 600 ; N breve ; B 258 450 589 624 ;
+C 199 ; WX 600 ; N dotaccent ; B 373 491 453 571 ;
+C 200 ; WX 600 ; N dieresis ; B 269 491 557 571 ;
+C 202 ; WX 600 ; N ring ; B 297 413 526 634 ;
+C 203 ; WX 600 ; N cedilla ; B 163 -186 376 40 ;
+C 205 ; WX 600 ; N hungarumlaut ; B 239 450 592 639 ;
+C 206 ; WX 600 ; N ogonek ; B 244 -165 430 40 ;
+C 207 ; WX 600 ; N caron ; B 259 450 589 624 ;
+C 208 ; WX 600 ; N emdash ; B 41 241 679 321 ;
+C 225 ; WX 600 ; N AE ; B -6 -20 705 583 ;
+C 227 ; WX 600 ; N ordfeminine ; B 174 179 529 598 ;
+C 232 ; WX 600 ; N Lslash ; B 47 -20 605 583 ;
+C 233 ; WX 600 ; N Oslash ; B 16 -61 704 623 ;
+C 234 ; WX 600 ; N OE ; B 42 -20 705 583 ;
+C 235 ; WX 600 ; N ordmasculine ; B 178 179 563 598 ;
+C 241 ; WX 600 ; N ae ; B 19 -35 651 452 ;
+C 245 ; WX 600 ; N dotlessi ; B 76 -20 532 437 ;
+C 248 ; WX 600 ; N lslash ; B 76 -20 544 624 ;
+C 249 ; WX 600 ; N oslash ; B 29 -61 656 478 ;
+C 250 ; WX 600 ; N oe ; B 28 -35 651 452 ;
+C 251 ; WX 600 ; N germandbls ; B 27 -35 558 624 ;
+C -1 ; WX 600 ; N Aacute ; B -7 -20 615 789 ;
+C -1 ; WX 600 ; N Acircumflex ; B -7 -20 615 774 ;
+C -1 ; WX 600 ; N Adieresis ; B -7 -20 615 721 ;
+C -1 ; WX 600 ; N Agrave ; B -7 -20 615 789 ;
+C -1 ; WX 600 ; N Aring ; B -7 -20 615 795 ;
+C -1 ; WX 600 ; N Atilde ; B -7 -20 615 730 ;
+C -1 ; WX 600 ; N Ccedilla ; B 91 -186 655 598 ;
+C -1 ; WX 600 ; N Eacute ; B 27 -20 634 789 ;
+C -1 ; WX 600 ; N Ecircumflex ; B 27 -20 634 774 ;
+C -1 ; WX 600 ; N Edieresis ; B 27 -20 634 721 ;
+C -1 ; WX 600 ; N Egrave ; B 27 -20 634 789 ;
+C -1 ; WX 600 ; N Eth ; B 27 -20 610 583 ;
+C -1 ; WX 600 ; N Gcaron ; B 89 -35 655 774 ;
+C -1 ; WX 600 ; N IJ ; B -6 -35 725 583 ;
+C -1 ; WX 600 ; N Iacute ; B 97 -20 622 789 ;
+C -1 ; WX 600 ; N Icircumflex ; B 97 -20 622 774 ;
+C -1 ; WX 600 ; N Idieresis ; B 97 -20 622 721 ;
+C -1 ; WX 600 ; N Idot ; B 97 -20 622 721 ;
+C -1 ; WX 600 ; N Igrave ; B 97 -20 622 789 ;
+C -1 ; WX 600 ; N LL ; B -16 -20 652 583 ;
+C -1 ; WX 600 ; N Ntilde ; B 27 -20 697 730 ;
+C -1 ; WX 600 ; N Oacute ; B 83 -35 636 789 ;
+C -1 ; WX 600 ; N Ocircumflex ; B 83 -35 636 774 ;
+C -1 ; WX 600 ; N Odieresis ; B 83 -35 636 721 ;
+C -1 ; WX 600 ; N Ograve ; B 83 -35 636 789 ;
+C -1 ; WX 600 ; N Otilde ; B 83 -35 636 730 ;
+C -1 ; WX 600 ; N Scaron ; B 76 -35 622 774 ;
+C -1 ; WX 600 ; N Scedilla ; B 76 -186 622 598 ;
+C -1 ; WX 600 ; N Thorn ; B 27 -20 603 583 ;
+C -1 ; WX 600 ; N Uacute ; B 119 -35 695 789 ;
+C -1 ; WX 600 ; N Ucircumflex ; B 119 -35 695 774 ;
+C -1 ; WX 600 ; N Udieresis ; B 119 -35 695 721 ;
+C -1 ; WX 600 ; N Ugrave ; B 119 -35 695 789 ;
+C -1 ; WX 600 ; N Yacute ; B 129 -20 684 789 ;
+C -1 ; WX 600 ; N Ydieresis ; B 129 -20 684 721 ;
+C -1 ; WX 600 ; N Zcaron ; B 87 -20 621 774 ;
+C -1 ; WX 600 ; N aacute ; B 74 -35 565 660 ;
+C -1 ; WX 600 ; N acircumflex ; B 74 -35 575 653 ;
+C -1 ; WX 600 ; N adieresis ; B 74 -35 565 592 ;
+C -1 ; WX 600 ; N agrave ; B 74 -35 565 660 ;
+C -1 ; WX 600 ; N aring ; B 74 -35 565 686 ;
+C -1 ; WX 600 ; N arrowboth ; B 24 110 704 490 ;
+C -1 ; WX 600 ; N arrowdown ; B 146 -20 526 639 ;
+C -1 ; WX 600 ; N arrowleft ; B 24 110 704 490 ;
+C -1 ; WX 600 ; N arrowright ; B 24 110 704 490 ;
+C -1 ; WX 600 ; N arrowup ; B 205 -20 585 639 ;
+C -1 ; WX 600 ; N atilde ; B 74 -35 594 618 ;
+C -1 ; WX 600 ; N brokenbar ; B 238 -144 464 624 ;
+C -1 ; WX 600 ; N ccedilla ; B 104 -186 614 452 ;
+C -1 ; WX 600 ; N center ; B 62 -20 662 624 ;
+C -1 ; WX 600 ; N copyright ; B 33 -35 683 598 ;
+C -1 ; WX 600 ; N dectab ; B -1 -20 609 248 ;
+C -1 ; WX 600 ; N degree ; B 231 294 564 624 ;
+C -1 ; WX 600 ; N divide ; B 112 51 608 531 ;
+C -1 ; WX 600 ; N down ; B 181 -20 473 452 ;
+C -1 ; WX 600 ; N eacute ; B 85 -35 590 664 ;
+C -1 ; WX 600 ; N ecircumflex ; B 85 -35 590 653 ;
+C -1 ; WX 600 ; N edieresis ; B 85 -35 590 592 ;
+C -1 ; WX 600 ; N egrave ; B 85 -35 590 664 ;
+C -1 ; WX 600 ; N eth ; B 87 -35 637 639 ;
+C -1 ; WX 600 ; N format ; B -50 -207 189 624 ;
+C -1 ; WX 600 ; N gcaron ; B 85 -207 666 645 ;
+C -1 ; WX 600 ; N graybox ; B 35 -40 693 640 ;
+C -1 ; WX 600 ; N iacute ; B 76 -20 532 660 ;
+C -1 ; WX 600 ; N icircumflex ; B 76 -20 532 634 ;
+C -1 ; WX 600 ; N idieresis ; B 76 -20 532 592 ;
+C -1 ; WX 600 ; N igrave ; B 76 -20 532 656 ;
+C -1 ; WX 600 ; N ij ; B 14 -207 634 665 ;
+C -1 ; WX 600 ; N indent ; B 98 60 590 352 ;
+C -1 ; WX 600 ; N largebullet ; B 325 266 405 346 ;
+C -1 ; WX 600 ; N left ; B 98 60 590 352 ;
+C -1 ; WX 600 ; N lira ; B 68 -20 560 598 ;
+C -1 ; WX 600 ; N ll ; B 4 -20 624 624 ;
+C -1 ; WX 600 ; N logicalnot ; B 127 154 623 394 ;
+C -1 ; WX 600 ; N merge ; B 181 -20 511 452 ;
+C -1 ; WX 600 ; N minus ; B 112 241 608 321 ;
+C -1 ; WX 600 ; N mu ; B 71 -207 582 437 ;
+C -1 ; WX 600 ; N multiply ; B 93 12 609 470 ;
+C -1 ; WX 600 ; N notegraphic ; B 167 -5 573 639 ;
+C -1 ; WX 600 ; N ntilde ; B 37 -20 569 618 ;
+C -1 ; WX 600 ; N oacute ; B 91 -35 597 649 ;
+C -1 ; WX 600 ; N ocircumflex ; B 91 -35 597 653 ;
+C -1 ; WX 600 ; N odieresis ; B 91 -35 597 592 ;
+C -1 ; WX 600 ; N ograve ; B 91 -35 597 649 ;
+C -1 ; WX 600 ; N onehalf ; B 46 -20 665 624 ;
+C -1 ; WX 600 ; N onequarter ; B 46 -20 681 624 ;
+C -1 ; WX 600 ; N onesuperior ; B 211 200 491 624 ;
+C -1 ; WX 600 ; N otilde ; B 91 -35 597 597 ;
+C -1 ; WX 600 ; N overscore ; B 95 559 759 639 ;
+C -1 ; WX 600 ; N plusminus ; B 56 -20 617 550 ;
+C -1 ; WX 600 ; N prescription ; B 27 -20 613 583 ;
+C -1 ; WX 600 ; N registered ; B 33 -35 683 598 ;
+C -1 ; WX 600 ; N return ; B 36 -20 745 608 ;
+C -1 ; WX 600 ; N scaron ; B 87 -35 593 645 ;
+C -1 ; WX 600 ; N scedilla ; B 87 -186 580 452 ;
+C -1 ; WX 600 ; N square ; B -20 -20 745 608 ;
+C -1 ; WX 600 ; N stop ; B -20 -20 745 608 ;
+C -1 ; WX 600 ; N tab ; B -20 -20 684 608 ;
+C -1 ; WX 600 ; N thorn ; B -33 -207 612 624 ;
+C -1 ; WX 600 ; N threequarters ; B 57 -20 651 639 ;
+C -1 ; WX 600 ; N threesuperior ; B 215 191 552 639 ;
+C -1 ; WX 600 ; N trademark ; B 78 230 735 583 ;
+C -1 ; WX 600 ; N twosuperior ; B 191 200 541 639 ;
+C -1 ; WX 600 ; N uacute ; B 107 -35 582 656 ;
+C -1 ; WX 600 ; N ucircumflex ; B 107 -35 582 634 ;
+C -1 ; WX 600 ; N udieresis ; B 107 -35 582 592 ;
+C -1 ; WX 600 ; N ugrave ; B 107 -35 582 656 ;
+C -1 ; WX 600 ; N up ; B 219 -20 511 452 ;
+C -1 ; WX 600 ; N yacute ; B -4 -207 653 656 ;
+C -1 ; WX 600 ; N ydieresis ; B -4 -207 653 571 ;
+C -1 ; WX 600 ; N zcaron ; B 99 -20 593 645 ;
+EndCharMetrics
+StartComposites 58
+CC Zcaron 2 ; PCC Z 0 0 ; PCC caron 0 146 ;
+CC zcaron 2 ; PCC z 0 0 ; PCC caron 0 0 ;
+CC Scaron 2 ; PCC S 0 0 ; PCC caron 0 146 ;
+CC scaron 2 ; PCC s 0 0 ; PCC caron 0 0 ;
+CC Ccedilla 2 ; PCC C 0 0 ; PCC cedilla 0 0 ;
+CC ccedilla 2 ; PCC c 0 0 ; PCC cedilla 0 0 ;
+CC Yacute 2 ; PCC Y 0 0 ; PCC acute 0 146 ;
+CC yacute 2 ; PCC y 0 0 ; PCC acute 0 0 ;
+CC Ydieresis 2 ; PCC Y 0 0 ; PCC dieresis 0 146 ;
+CC ydieresis 2 ; PCC y 0 0 ; PCC dieresis 0 0 ;
+CC Uacute 2 ; PCC U 0 0 ; PCC acute 0 146 ;
+CC Ucircumflex 2 ; PCC U 0 0 ; PCC circumflex 0 146 ;
+CC Udieresis 2 ; PCC U 0 0 ; PCC dieresis 0 146 ;
+CC Ugrave 2 ; PCC U 0 0 ; PCC grave 0 146 ;
+CC uacute 2 ; PCC u 0 0 ; PCC acute 0 0 ;
+CC ucircumflex 2 ; PCC u 0 0 ; PCC circumflex 0 0 ;
+CC udieresis 2 ; PCC u 0 0 ; PCC dieresis 0 0 ;
+CC ugrave 2 ; PCC u 0 0 ; PCC grave 0 0 ;
+CC Iacute 2 ; PCC I 0 0 ; PCC acute 0 146 ;
+CC Icircumflex 2 ; PCC I 0 0 ; PCC circumflex 0 146 ;
+CC Idieresis 2 ; PCC I 0 0 ; PCC dieresis 0 146 ;
+CC Igrave 2 ; PCC I 0 0 ; PCC grave 0 146 ;
+CC iacute 2 ; PCC dotlessi 0 0 ; PCC acute 0 0 ;
+CC icircumflex 2 ; PCC dotlessi 0 0 ; PCC circumflex 0 0 ;
+CC idieresis 2 ; PCC dotlessi 0 0 ; PCC dieresis 0 0 ;
+CC igrave 2 ; PCC dotlessi 0 0 ; PCC grave 0 0 ;
+CC Eacute 2 ; PCC E 0 0 ; PCC acute 0 146 ;
+CC Ecircumflex 2 ; PCC E 0 0 ; PCC circumflex 0 146 ;
+CC Edieresis 2 ; PCC E 0 0 ; PCC dieresis 0 146 ;
+CC Egrave 2 ; PCC E 0 0 ; PCC grave 0 146 ;
+CC eacute 2 ; PCC e 0 0 ; PCC acute 0 0 ;
+CC ecircumflex 2 ; PCC e 0 0 ; PCC circumflex 0 0 ;
+CC edieresis 2 ; PCC e 0 0 ; PCC dieresis 0 0 ;
+CC egrave 2 ; PCC e 0 0 ; PCC grave 0 0 ;
+CC Aacute 2 ; PCC A 0 0 ; PCC acute 0 146 ;
+CC Acircumflex 2 ; PCC A 0 0 ; PCC circumflex 0 146 ;
+CC Adieresis 2 ; PCC A 0 0 ; PCC dieresis 0 146 ;
+CC Agrave 2 ; PCC A 0 0 ; PCC grave 0 146 ;
+CC aacute 2 ; PCC a 0 0 ; PCC acute 0 0 ;
+CC acircumflex 2 ; PCC a 0 0 ; PCC circumflex 0 0 ;
+CC adieresis 2 ; PCC a 0 0 ; PCC dieresis 0 0 ;
+CC agrave 2 ; PCC a 0 0 ; PCC grave 0 0 ;
+CC Oacute 2 ; PCC O 0 0 ; PCC acute 0 146 ;
+CC Ocircumflex 2 ; PCC O 0 0 ; PCC circumflex 0 146 ;
+CC Odieresis 2 ; PCC O 0 0 ; PCC dieresis 0 146 ;
+CC Ograve 2 ; PCC O 0 0 ; PCC grave 0 146 ;
+CC oacute 2 ; PCC o 0 0 ; PCC acute 0 0 ;
+CC ocircumflex 2 ; PCC o 0 0 ; PCC circumflex 0 0 ;
+CC odieresis 2 ; PCC o 0 0 ; PCC dieresis 0 0 ;
+CC ograve 2 ; PCC o 0 0 ; PCC grave 0 0 ;
+CC Atilde 2 ; PCC A 0 0 ; PCC tilde 0 146 ;
+CC atilde 2 ; PCC a 0 0 ; PCC tilde 0 0 ;
+CC Ntilde 2 ; PCC N 0 0 ; PCC tilde 0 146 ;
+CC ntilde 2 ; PCC n 0 0 ; PCC tilde 0 0 ;
+CC Otilde 2 ; PCC O 0 0 ; PCC tilde 0 146 ;
+CC otilde 2 ; PCC o 0 0 ; PCC tilde 0 0 ;
+CC Aring 2 ; PCC A 0 0 ; PCC ring 0 146 ;
+CC aring 2 ; PCC a 0 0 ; PCC ring 0 0 ;
+EndComposites
+EndFontMetrics
diff --git a/collects/afm/Courier.afm b/collects/afm/Courier.afm
new file mode 100644
index 0000000000..e9daaef0b9
--- /dev/null
+++ b/collects/afm/Courier.afm
@@ -0,0 +1,341 @@
+StartFontMetrics 2.0
+Comment Copyright (c) 1984 Adobe Systems Incorporated. All Rights Reserved.
+Comment Creation Date:Fri Apr 3 12:03:11 PST 1987
+FontName Courier
+EncodingScheme AdobeStandardEncoding
+FullName Courier
+FamilyName Courier
+Weight Medium
+ItalicAngle 0.0
+IsFixedPitch true
+UnderlinePosition -82
+UnderlineThickness 40
+Version 001.004
+FontBBox -40 -290 640 795
+CapHeight 583
+XHeight 437
+Descender -207
+Ascender 624
+StartCharMetrics 260
+C 32 ; WX 600 ; N space ; B 560 -40 640 40 ;
+C 33 ; WX 600 ; N exclam ; B 240 -5 360 639 ;
+C 34 ; WX 600 ; N quotedbl ; B 126 314 474 603 ;
+C 35 ; WX 600 ; N numbersign ; B 72 -82 528 665 ;
+C 36 ; WX 600 ; N dollar ; B 93 -113 507 675 ;
+C 37 ; WX 600 ; N percent ; B 67 -35 533 639 ;
+C 38 ; WX 600 ; N ampersand ; B 85 -35 498 540 ;
+C 39 ; WX 600 ; N quoteright ; B 135 304 340 613 ;
+C 40 ; WX 600 ; N parenleft ; B 274 -144 478 623 ;
+C 41 ; WX 600 ; N parenright ; B 127 -144 331 623 ;
+C 42 ; WX 600 ; N asterisk ; B 93 210 507 624 ;
+C 43 ; WX 600 ; N plus ; B 52 12 548 550 ;
+C 44 ; WX 600 ; N comma ; B 135 -155 340 155 ;
+C 45 ; WX 600 ; N hyphen ; B 52 241 548 321 ;
+C 46 ; WX 600 ; N period ; B 250 10 350 90 ;
+C 47 ; WX 600 ; N slash ; B 93 -103 507 686 ;
+C 48 ; WX 600 ; N zero ; B 93 -35 507 639 ;
+C 49 ; WX 600 ; N one ; B 93 -20 507 624 ;
+C 50 ; WX 600 ; N two ; B 64 -20 498 639 ;
+C 51 ; WX 600 ; N three ; B 76 -35 519 639 ;
+C 52 ; WX 600 ; N four ; B 85 -20 498 624 ;
+C 53 ; WX 600 ; N five ; B 76 -35 519 624 ;
+C 54 ; WX 600 ; N six ; B 116 -35 530 639 ;
+C 55 ; WX 600 ; N seven ; B 85 -20 498 624 ;
+C 56 ; WX 600 ; N eight ; B 93 -35 507 639 ;
+C 57 ; WX 600 ; N nine ; B 116 -35 530 639 ;
+C 58 ; WX 600 ; N colon ; B 250 10 350 392 ;
+C 59 ; WX 600 ; N semicolon ; B 139 -116 350 392 ;
+C 60 ; WX 600 ; N less ; B 52 12 548 550 ;
+C 61 ; WX 600 ; N equal ; B 31 168 569 394 ;
+C 62 ; WX 600 ; N greater ; B 52 12 548 550 ;
+C 63 ; WX 600 ; N question ; B 114 -5 507 598 ;
+C 64 ; WX 600 ; N at ; B 85 -82 498 644 ;
+C 65 ; WX 600 ; N A ; B -11 -20 611 583 ;
+C 66 ; WX 600 ; N B ; B 23 -20 561 583 ;
+C 67 ; WX 600 ; N C ; B 43 -35 554 598 ;
+C 68 ; WX 600 ; N D ; B 23 -20 540 583 ;
+C 69 ; WX 600 ; N E ; B 23 -20 540 583 ;
+C 70 ; WX 600 ; N F ; B 23 -20 540 583 ;
+C 71 ; WX 600 ; N G ; B 43 -35 582 598 ;
+C 72 ; WX 600 ; N H ; B 33 -20 571 583 ;
+C 73 ; WX 600 ; N I ; B 93 -20 507 583 ;
+C 74 ; WX 600 ; N J ; B 64 -35 603 583 ;
+C 75 ; WX 600 ; N K ; B 23 -20 592 583 ;
+C 76 ; WX 600 ; N L ; B 43 -20 561 583 ;
+C 77 ; WX 600 ; N M ; B -9 -20 613 583 ;
+C 78 ; WX 600 ; N N ; B 2 -20 582 583 ;
+C 79 ; WX 600 ; N O ; B 31 -35 569 598 ;
+C 80 ; WX 600 ; N P ; B 23 -20 519 583 ;
+C 81 ; WX 600 ; N Q ; B 31 -136 569 598 ;
+C 82 ; WX 600 ; N R ; B 23 -20 609 583 ;
+C 83 ; WX 600 ; N S ; B 72 -35 528 598 ;
+C 84 ; WX 600 ; N T ; B 52 -20 548 583 ;
+C 85 ; WX 600 ; N U ; B 20 -35 580 583 ;
+C 86 ; WX 600 ; N V ; B -11 -20 611 583 ;
+C 87 ; WX 600 ; N W ; B 0 -20 600 583 ;
+C 88 ; WX 600 ; N X ; B 20 -20 580 583 ;
+C 89 ; WX 600 ; N Y ; B 31 -20 569 583 ;
+C 90 ; WX 600 ; N Z ; B 83 -20 517 583 ;
+C 91 ; WX 600 ; N bracketleft ; B 260 -144 465 624 ;
+C 92 ; WX 600 ; N backslash ; B 93 -103 507 686 ;
+C 93 ; WX 600 ; N bracketright ; B 135 -144 340 624 ;
+C 94 ; WX 600 ; N asciicircum ; B 93 335 507 624 ;
+C 95 ; WX 600 ; N underscore ; B -32 -290 632 -210 ;
+C 96 ; WX 600 ; N quoteleft ; B 260 304 465 613 ;
+C 97 ; WX 600 ; N a ; B 52 -35 561 452 ;
+C 98 ; WX 600 ; N b ; B 2 -35 561 624 ;
+C 99 ; WX 600 ; N c ; B 64 -35 555 452 ;
+C 100 ; WX 600 ; N d ; B 43 -35 603 624 ;
+C 101 ; WX 600 ; N e ; B 43 -35 540 452 ;
+C 102 ; WX 600 ; N f ; B 85 -20 561 624 ; L i fi ; L l fl ;
+C 103 ; WX 600 ; N g ; B 43 -207 582 452 ;
+C 104 ; WX 600 ; N h ; B 23 -20 571 624 ;
+C 105 ; WX 600 ; N i ; B 72 -20 528 665 ;
+C 106 ; WX 600 ; N j ; B 127 -207 478 665 ;
+C 107 ; WX 600 ; N k ; B 43 -20 561 624 ;
+C 108 ; WX 600 ; N l ; B 72 -20 528 624 ;
+C 109 ; WX 600 ; N m ; B -9 -20 613 452 ;
+C 110 ; WX 600 ; N n ; B 33 -20 561 452 ;
+C 111 ; WX 600 ; N o ; B 52 -35 548 452 ;
+C 112 ; WX 600 ; N p ; B 2 -207 561 452 ;
+C 113 ; WX 600 ; N q ; B 43 -207 603 452 ;
+C 114 ; WX 600 ; N r ; B 64 -20 561 448 ;
+C 115 ; WX 600 ; N s ; B 83 -35 517 452 ;
+C 116 ; WX 600 ; N t ; B 23 -35 519 582 ;
+C 117 ; WX 600 ; N u ; B 23 -35 561 437 ;
+C 118 ; WX 600 ; N v ; B 10 -20 590 437 ;
+C 119 ; WX 600 ; N w ; B 10 -20 590 437 ;
+C 120 ; WX 600 ; N x ; B 31 -20 569 437 ;
+C 121 ; WX 600 ; N y ; B 31 -207 569 437 ;
+C 122 ; WX 600 ; N z ; B 95 -20 509 437 ;
+C 123 ; WX 600 ; N braceleft ; B 177 -144 423 624 ;
+C 124 ; WX 600 ; N bar ; B 260 -144 340 624 ;
+C 125 ; WX 600 ; N braceright ; B 177 -144 423 624 ;
+C 126 ; WX 600 ; N asciitilde ; B 72 189 528 373 ;
+C 161 ; WX 600 ; N exclamdown ; B 240 -207 360 415 ;
+C 162 ; WX 600 ; N cent ; B 93 -19 489 665 ;
+C 163 ; WX 600 ; N sterling ; B 43 -20 540 598 ;
+C 164 ; WX 600 ; N fraction ; B 31 120 569 492 ;
+C 165 ; WX 600 ; N yen ; B 31 -20 569 583 ;
+C 166 ; WX 600 ; N florin ; B 67 -113 538 639 ;
+C 167 ; WX 600 ; N section ; B 46 -87 554 629 ;
+C 168 ; WX 600 ; N currency ; B 83 75 517 509 ;
+C 169 ; WX 600 ; N quotesingle ; B 230 304 370 613 ;
+C 170 ; WX 600 ; N quotedblleft ; B 93 340 507 619 ;
+C 171 ; WX 600 ; N guillemotleft ; B 43 -20 561 437 ;
+C 172 ; WX 600 ; N guilsinglleft ; B 43 -20 332 437 ;
+C 173 ; WX 600 ; N guilsinglright ; B 273 -20 561 437 ;
+C 174 ; WX 600 ; N fi ; B -10 -20 610 665 ;
+C 175 ; WX 600 ; N fl ; B -10 -20 610 624 ;
+C 177 ; WX 600 ; N endash ; B 52 241 548 321 ;
+C 178 ; WX 600 ; N dagger ; B 104 -82 496 624 ;
+C 179 ; WX 600 ; N daggerdbl ; B 104 -82 496 624 ;
+C 180 ; WX 600 ; N periodcentered ; B 250 266 350 346 ;
+C 182 ; WX 600 ; N paragraph ; B 59 -87 545 629 ;
+C 183 ; WX 600 ; N bullet ; B 260 266 340 346 ;
+C 184 ; WX 600 ; N quotesinglbase ; B 135 -165 340 144 ;
+C 185 ; WX 600 ; N quotedblbase ; B 93 -139 507 139 ;
+C 186 ; WX 600 ; N quotedblright ; B 93 340 507 619 ;
+C 187 ; WX 600 ; N guillemotright ; B 43 -20 561 437 ;
+C 188 ; WX 600 ; N ellipsis ; B 60 -5 540 75 ;
+C 189 ; WX 600 ; N perthousand ; B 10 -35 590 639 ;
+C 191 ; WX 600 ; N questiondown ; B 93 -207 486 415 ;
+C 193 ; WX 600 ; N grave ; B 135 450 340 639 ;
+C 194 ; WX 600 ; N acute ; B 260 450 465 639 ;
+C 195 ; WX 600 ; N circumflex ; B 135 450 465 624 ;
+C 196 ; WX 600 ; N tilde ; B 125 441 475 580 ;
+C 197 ; WX 600 ; N macron ; B 135 476 465 556 ;
+C 198 ; WX 600 ; N breve ; B 135 450 465 624 ;
+C 199 ; WX 600 ; N dotaccent ; B 260 491 340 571 ;
+C 200 ; WX 600 ; N dieresis ; B 156 491 444 571 ;
+C 202 ; WX 600 ; N ring ; B 187 413 413 634 ;
+C 203 ; WX 600 ; N cedilla ; B 190 -186 397 40 ;
+C 205 ; WX 600 ; N hungarumlaut ; B 135 450 465 639 ;
+C 206 ; WX 600 ; N ogonek ; B 260 -165 453 40 ;
+C 207 ; WX 600 ; N caron ; B 135 450 465 624 ;
+C 208 ; WX 600 ; N emdash ; B -19 241 619 321 ;
+C 225 ; WX 600 ; N AE ; B -10 -20 610 583 ;
+C 227 ; WX 600 ; N ordfeminine ; B 127 179 478 598 ;
+C 232 ; WX 600 ; N Lslash ; B 23 -20 561 583 ;
+C 233 ; WX 600 ; N Oslash ; B 20 -61 580 623 ;
+C 234 ; WX 600 ; N OE ; B -10 -20 610 583 ;
+C 235 ; WX 600 ; N ordmasculine ; B 131 179 469 598 ;
+C 241 ; WX 600 ; N ae ; B -10 -35 600 452 ;
+C 245 ; WX 600 ; N dotlessi ; B 72 -20 528 437 ;
+C 248 ; WX 600 ; N lslash ; B 72 -20 528 624 ;
+C 249 ; WX 600 ; N oslash ; B 33 -61 563 478 ;
+C 250 ; WX 600 ; N oe ; B -10 -35 600 452 ;
+C 251 ; WX 600 ; N germandbls ; B 23 -35 519 624 ;
+C -1 ; WX 600 ; N Aacute ; B -11 -20 611 789 ;
+C -1 ; WX 600 ; N Acircumflex ; B -11 -20 611 774 ;
+C -1 ; WX 600 ; N Adieresis ; B -11 -20 611 721 ;
+C -1 ; WX 600 ; N Agrave ; B -11 -20 611 789 ;
+C -1 ; WX 600 ; N Aring ; B -11 -20 611 795 ;
+C -1 ; WX 600 ; N Atilde ; B -11 -20 611 730 ;
+C -1 ; WX 600 ; N Ccedilla ; B 43 -186 554 598 ;
+C -1 ; WX 600 ; N Eacute ; B 23 -20 540 789 ;
+C -1 ; WX 600 ; N Ecircumflex ; B 23 -20 540 774 ;
+C -1 ; WX 600 ; N Edieresis ; B 23 -20 540 721 ;
+C -1 ; WX 600 ; N Egrave ; B 23 -20 540 789 ;
+C -1 ; WX 600 ; N Eth ; B 23 -20 540 583 ;
+C -1 ; WX 600 ; N Gcaron ; B 43 -35 582 774 ;
+C -1 ; WX 600 ; N IJ ; B -10 -35 610 583 ;
+C -1 ; WX 600 ; N Iacute ; B 93 -20 507 789 ;
+C -1 ; WX 600 ; N Icircumflex ; B 93 -20 507 774 ;
+C -1 ; WX 600 ; N Idieresis ; B 93 -20 507 721 ;
+C -1 ; WX 600 ; N Idot ; B 93 -20 507 721 ;
+C -1 ; WX 600 ; N Igrave ; B 93 -20 507 789 ;
+C -1 ; WX 600 ; N LL ; B -20 -20 620 583 ;
+C -1 ; WX 600 ; N Ntilde ; B 2 -20 582 730 ;
+C -1 ; WX 600 ; N Oacute ; B 31 -35 569 789 ;
+C -1 ; WX 600 ; N Ocircumflex ; B 31 -35 569 774 ;
+C -1 ; WX 600 ; N Odieresis ; B 31 -35 569 721 ;
+C -1 ; WX 600 ; N Ograve ; B 31 -35 569 789 ;
+C -1 ; WX 600 ; N Otilde ; B 31 -35 569 730 ;
+C -1 ; WX 600 ; N Scaron ; B 72 -35 528 774 ;
+C -1 ; WX 600 ; N Scedilla ; B 72 -186 528 598 ;
+C -1 ; WX 600 ; N Thorn ; B 23 -20 539 583 ;
+C -1 ; WX 600 ; N Uacute ; B 20 -35 580 789 ;
+C -1 ; WX 600 ; N Ucircumflex ; B 20 -35 580 774 ;
+C -1 ; WX 600 ; N Udieresis ; B 20 -35 580 721 ;
+C -1 ; WX 600 ; N Ugrave ; B 20 -35 580 789 ;
+C -1 ; WX 600 ; N Yacute ; B 31 -20 569 789 ;
+C -1 ; WX 600 ; N Ydieresis ; B 31 -20 569 721 ;
+C -1 ; WX 600 ; N Zcaron ; B 83 -20 517 774 ;
+C -1 ; WX 600 ; N aacute ; B 52 -35 561 660 ;
+C -1 ; WX 600 ; N acircumflex ; B 52 -35 561 653 ;
+C -1 ; WX 600 ; N adieresis ; B 52 -35 561 592 ;
+C -1 ; WX 600 ; N agrave ; B 52 -35 561 660 ;
+C -1 ; WX 600 ; N aring ; B 52 -35 561 686 ;
+C -1 ; WX 600 ; N arrowboth ; B -40 110 640 490 ;
+C -1 ; WX 600 ; N arrowdown ; B 110 -20 490 639 ;
+C -1 ; WX 600 ; N arrowleft ; B -40 110 640 490 ;
+C -1 ; WX 600 ; N arrowright ; B -40 110 640 490 ;
+C -1 ; WX 600 ; N arrowup ; B 110 -20 490 639 ;
+C -1 ; WX 600 ; N atilde ; B 52 -35 561 618 ;
+C -1 ; WX 600 ; N brokenbar ; B 260 -144 340 624 ;
+C -1 ; WX 600 ; N ccedilla ; B 64 -186 555 452 ;
+C -1 ; WX 600 ; N center ; B 0 -20 600 624 ;
+C -1 ; WX 600 ; N copyright ; B -20 -35 620 598 ;
+C -1 ; WX 600 ; N dectab ; B -5 -20 605 248 ;
+C -1 ; WX 600 ; N degree ; B 135 294 465 624 ;
+C -1 ; WX 600 ; N divide ; B 52 51 548 531 ;
+C -1 ; WX 600 ; N down ; B 154 -20 446 452 ;
+C -1 ; WX 600 ; N eacute ; B 43 -35 540 664 ;
+C -1 ; WX 600 ; N ecircumflex ; B 43 -35 540 653 ;
+C -1 ; WX 600 ; N edieresis ; B 43 -35 540 592 ;
+C -1 ; WX 600 ; N egrave ; B 43 -35 540 664 ;
+C -1 ; WX 600 ; N eth ; B 52 -35 548 639 ;
+C -1 ; WX 600 ; N format ; B -15 -207 65 624 ;
+C -1 ; WX 600 ; N gcaron ; B 43 -207 582 645 ;
+C -1 ; WX 600 ; N graybox ; B 35 -40 565 640 ;
+C -1 ; WX 600 ; N iacute ; B 72 -20 528 660 ;
+C -1 ; WX 600 ; N icircumflex ; B 72 -20 528 634 ;
+C -1 ; WX 600 ; N idieresis ; B 72 -20 528 592 ;
+C -1 ; WX 600 ; N igrave ; B 72 -20 528 656 ;
+C -1 ; WX 600 ; N ij ; B 10 -207 550 665 ;
+C -1 ; WX 600 ; N indent ; B 54 60 546 352 ;
+C -1 ; WX 600 ; N largebullet ; B 260 266 340 346 ;
+C -1 ; WX 600 ; N left ; B 54 60 546 352 ;
+C -1 ; WX 600 ; N lira ; B 43 -20 540 598 ;
+C -1 ; WX 600 ; N ll ; B 0 -20 600 624 ;
+C -1 ; WX 600 ; N logicalnot ; B 52 154 548 394 ;
+C -1 ; WX 600 ; N merge ; B 154 -20 446 452 ;
+C -1 ; WX 600 ; N minus ; B 52 241 548 321 ;
+C -1 ; WX 600 ; N mu ; B 23 -207 561 437 ;
+C -1 ; WX 600 ; N multiply ; B 82 12 518 470 ;
+C -1 ; WX 600 ; N notegraphic ; B 150 -5 450 639 ;
+C -1 ; WX 600 ; N ntilde ; B 33 -20 561 618 ;
+C -1 ; WX 600 ; N oacute ; B 52 -35 548 649 ;
+C -1 ; WX 600 ; N ocircumflex ; B 52 -35 548 653 ;
+C -1 ; WX 600 ; N odieresis ; B 52 -35 548 592 ;
+C -1 ; WX 600 ; N ograve ; B 52 -35 548 649 ;
+C -1 ; WX 600 ; N onehalf ; B -10 -20 610 624 ;
+C -1 ; WX 600 ; N onequarter ; B -10 -20 610 624 ;
+C -1 ; WX 600 ; N onesuperior ; B 160 200 440 624 ;
+C -1 ; WX 600 ; N otilde ; B 52 -35 548 597 ;
+C -1 ; WX 600 ; N overscore ; B -32 559 632 639 ;
+C -1 ; WX 600 ; N plusminus ; B 52 -20 548 550 ;
+C -1 ; WX 600 ; N prescription ; B 23 -20 609 583 ;
+C -1 ; WX 600 ; N registered ; B -20 -35 620 598 ;
+C -1 ; WX 600 ; N return ; B -24 -20 624 608 ;
+C -1 ; WX 600 ; N scaron ; B 83 -35 517 645 ;
+C -1 ; WX 600 ; N scedilla ; B 83 -186 517 452 ;
+C -1 ; WX 600 ; N square ; B -24 -20 624 608 ;
+C -1 ; WX 600 ; N stop ; B -24 -20 624 608 ;
+C -1 ; WX 600 ; N tab ; B -24 -20 624 608 ;
+C -1 ; WX 600 ; N thorn ; B 2 -207 561 624 ;
+C -1 ; WX 600 ; N threequarters ; B -10 -20 610 639 ;
+C -1 ; WX 600 ; N threesuperior ; B 155 191 452 639 ;
+C -1 ; WX 600 ; N trademark ; B -20 230 620 583 ;
+C -1 ; WX 600 ; N twosuperior ; B 140 200 431 639 ;
+C -1 ; WX 600 ; N uacute ; B 23 -35 561 656 ;
+C -1 ; WX 600 ; N ucircumflex ; B 23 -35 561 634 ;
+C -1 ; WX 600 ; N udieresis ; B 23 -35 561 592 ;
+C -1 ; WX 600 ; N ugrave ; B 23 -35 561 656 ;
+C -1 ; WX 600 ; N up ; B 154 -20 446 452 ;
+C -1 ; WX 600 ; N yacute ; B 31 -207 569 656 ;
+C -1 ; WX 600 ; N ydieresis ; B 31 -207 569 571 ;
+C -1 ; WX 600 ; N zcaron ; B 95 -20 509 645 ;
+EndCharMetrics
+StartComposites 58
+CC Zcaron 2 ; PCC Z 0 0 ; PCC caron 0 146 ;
+CC zcaron 2 ; PCC z 0 0 ; PCC caron 0 0 ;
+CC Scaron 2 ; PCC S 0 0 ; PCC caron 0 146 ;
+CC scaron 2 ; PCC s 0 0 ; PCC caron 0 0 ;
+CC Ccedilla 2 ; PCC C 0 0 ; PCC cedilla 0 0 ;
+CC ccedilla 2 ; PCC c 0 0 ; PCC cedilla 0 0 ;
+CC Yacute 2 ; PCC Y 0 0 ; PCC acute 0 146 ;
+CC yacute 2 ; PCC y 0 0 ; PCC acute 0 0 ;
+CC Ydieresis 2 ; PCC Y 0 0 ; PCC dieresis 0 146 ;
+CC ydieresis 2 ; PCC y 0 0 ; PCC dieresis 0 0 ;
+CC Uacute 2 ; PCC U 0 0 ; PCC acute 0 146 ;
+CC Ucircumflex 2 ; PCC U 0 0 ; PCC circumflex 0 146 ;
+CC Udieresis 2 ; PCC U 0 0 ; PCC dieresis 0 146 ;
+CC Ugrave 2 ; PCC U 0 0 ; PCC grave 0 146 ;
+CC uacute 2 ; PCC u 0 0 ; PCC acute 0 0 ;
+CC ucircumflex 2 ; PCC u 0 0 ; PCC circumflex 0 0 ;
+CC udieresis 2 ; PCC u 0 0 ; PCC dieresis 0 0 ;
+CC ugrave 2 ; PCC u 0 0 ; PCC grave 0 0 ;
+CC Iacute 2 ; PCC I 0 0 ; PCC acute 0 146 ;
+CC Icircumflex 2 ; PCC I 0 0 ; PCC circumflex 0 146 ;
+CC Idieresis 2 ; PCC I 0 0 ; PCC dieresis 0 146 ;
+CC Igrave 2 ; PCC I 0 0 ; PCC grave 0 146 ;
+CC iacute 2 ; PCC dotlessi 0 0 ; PCC acute 0 0 ;
+CC icircumflex 2 ; PCC dotlessi 0 0 ; PCC circumflex 0 0 ;
+CC idieresis 2 ; PCC dotlessi 0 0 ; PCC dieresis 0 0 ;
+CC igrave 2 ; PCC dotlessi 0 0 ; PCC grave 0 0 ;
+CC Eacute 2 ; PCC E 0 0 ; PCC acute 0 146 ;
+CC Ecircumflex 2 ; PCC E 0 0 ; PCC circumflex 0 146 ;
+CC Edieresis 2 ; PCC E 0 0 ; PCC dieresis 0 146 ;
+CC Egrave 2 ; PCC E 0 0 ; PCC grave 0 146 ;
+CC eacute 2 ; PCC e 0 0 ; PCC acute 0 0 ;
+CC ecircumflex 2 ; PCC e 0 0 ; PCC circumflex 0 0 ;
+CC edieresis 2 ; PCC e 0 0 ; PCC dieresis 0 0 ;
+CC egrave 2 ; PCC e 0 0 ; PCC grave 0 0 ;
+CC Aacute 2 ; PCC A 0 0 ; PCC acute 0 146 ;
+CC Acircumflex 2 ; PCC A 0 0 ; PCC circumflex 0 146 ;
+CC Adieresis 2 ; PCC A 0 0 ; PCC dieresis 0 146 ;
+CC Agrave 2 ; PCC A 0 0 ; PCC grave 0 146 ;
+CC aacute 2 ; PCC a 0 0 ; PCC acute 0 0 ;
+CC acircumflex 2 ; PCC a 0 0 ; PCC circumflex 0 0 ;
+CC adieresis 2 ; PCC a 0 0 ; PCC dieresis 0 0 ;
+CC agrave 2 ; PCC a 0 0 ; PCC grave 0 0 ;
+CC Oacute 2 ; PCC O 0 0 ; PCC acute 0 146 ;
+CC Ocircumflex 2 ; PCC O 0 0 ; PCC circumflex 0 146 ;
+CC Odieresis 2 ; PCC O 0 0 ; PCC dieresis 0 146 ;
+CC Ograve 2 ; PCC O 0 0 ; PCC grave 0 146 ;
+CC oacute 2 ; PCC o 0 0 ; PCC acute 0 0 ;
+CC ocircumflex 2 ; PCC o 0 0 ; PCC circumflex 0 0 ;
+CC odieresis 2 ; PCC o 0 0 ; PCC dieresis 0 0 ;
+CC ograve 2 ; PCC o 0 0 ; PCC grave 0 0 ;
+CC Atilde 2 ; PCC A 0 0 ; PCC tilde 0 146 ;
+CC atilde 2 ; PCC a 0 0 ; PCC tilde 0 0 ;
+CC Ntilde 2 ; PCC N 0 0 ; PCC tilde 0 146 ;
+CC ntilde 2 ; PCC n 0 0 ; PCC tilde 0 0 ;
+CC Otilde 2 ; PCC O 0 0 ; PCC tilde 0 146 ;
+CC otilde 2 ; PCC o 0 0 ; PCC tilde 0 0 ;
+CC Aring 2 ; PCC A 0 0 ; PCC ring 0 146 ;
+CC aring 2 ; PCC a 0 0 ; PCC ring 0 0 ;
+EndComposites
+EndFontMetrics
diff --git a/collects/afm/Helvetica-Bold.afm b/collects/afm/Helvetica-Bold.afm
new file mode 100644
index 0000000000..e51fd308b3
--- /dev/null
+++ b/collects/afm/Helvetica-Bold.afm
@@ -0,0 +1,433 @@
+StartFontMetrics 2.0
+Comment Copyright (c) 1984 Adobe Systems Incorporated. All Rights Reserved.
+Comment Creation Date:Sun Feb 8 19:34:17 PST 1987
+FontName Helvetica-Bold
+EncodingScheme AdobeStandardEncoding
+FullName Helvetica Bold
+FamilyName Helvetica
+Weight Bold
+ItalicAngle 0.0
+IsFixedPitch false
+UnderlinePosition -106
+UnderlineThickness 73
+Version 001.002
+Notice Helvetica is a registered trademark of Allied Corporation.
+FontBBox -173 -221 1003 936
+CapHeight 729
+XHeight 542
+Descender -219
+Ascender 729
+StartCharMetrics 228
+C 32 ; WX 278 ; N space ; B 0 0 0 0 ;
+C 33 ; WX 333 ; N exclam ; B 112 0 262 729 ;
+C 34 ; WX 474 ; N quotedbl ; B 50 470 424 729 ;
+C 35 ; WX 556 ; N numbersign ; B 3 -30 553 696 ;
+C 36 ; WX 556 ; N dollar ; B 22 -125 526 765 ;
+C 37 ; WX 889 ; N percent ; B 22 -18 863 708 ;
+C 38 ; WX 722 ; N ampersand ; B 55 -20 694 729 ;
+C 39 ; WX 278 ; N quoteright ; B 66 469 201 729 ;
+C 40 ; WX 333 ; N parenleft ; B 40 -202 303 729 ;
+C 41 ; WX 333 ; N parenright ; B 22 -202 285 729 ;
+C 42 ; WX 389 ; N asterisk ; B 23 385 356 730 ;
+C 43 ; WX 584 ; N plus ; B 50 -10 534 474 ;
+C 44 ; WX 278 ; N comma ; B 64 -174 214 146 ;
+C 45 ; WX 333 ; N hyphen ; B 26 208 298 344 ;
+C 46 ; WX 278 ; N period ; B 64 0 214 146 ;
+C 47 ; WX 278 ; N slash ; B 2 -14 275 715 ;
+C 48 ; WX 556 ; N zero ; B 29 -23 517 725 ;
+C 49 ; WX 556 ; N one ; B 68 0 378 709 ;
+C 50 ; WX 556 ; N two ; B 30 0 515 726 ;
+C 51 ; WX 556 ; N three ; B 29 -23 516 726 ;
+C 52 ; WX 556 ; N four ; B 24 0 522 709 ;
+C 53 ; WX 556 ; N five ; B 27 -24 517 709 ;
+C 54 ; WX 556 ; N six ; B 32 -23 519 727 ;
+C 55 ; WX 556 ; N seven ; B 29 0 528 709 ;
+C 56 ; WX 556 ; N eight ; B 22 -23 525 726 ;
+C 57 ; WX 556 ; N nine ; B 28 -23 516 728 ;
+C 58 ; WX 333 ; N colon ; B 113 0 263 521 ;
+C 59 ; WX 333 ; N semicolon ; B 113 -174 263 521 ;
+C 60 ; WX 584 ; N less ; B 40 -10 529 474 ;
+C 61 ; WX 584 ; N equal ; B 50 52 534 412 ;
+C 62 ; WX 584 ; N greater ; B 40 -10 529 474 ;
+C 63 ; WX 611 ; N question ; B 64 0 556 744 ;
+C 64 ; WX 975 ; N at ; B 27 -136 947 746 ;
+C 65 ; WX 722 ; N A ; B 26 0 703 729 ;
+C 66 ; WX 722 ; N B ; B 82 0 666 729 ;
+C 67 ; WX 722 ; N C ; B 44 -23 685 741 ;
+C 68 ; WX 722 ; N D ; B 77 0 681 729 ;
+C 69 ; WX 667 ; N E ; B 79 0 624 729 ;
+C 70 ; WX 611 ; N F ; B 74 0 586 729 ;
+C 71 ; WX 778 ; N G ; B 42 -24 711 741 ;
+C 72 ; WX 722 ; N H ; B 68 0 657 729 ;
+C 73 ; WX 278 ; N I ; B 63 0 213 729 ;
+C 74 ; WX 556 ; N J ; B 24 -23 486 729 ;
+C 75 ; WX 722 ; N K ; B 74 0 717 729 ;
+C 76 ; WX 611 ; N L ; B 80 0 579 729 ;
+C 77 ; WX 833 ; N M ; B 66 0 776 729 ;
+C 78 ; WX 722 ; N N ; B 68 0 661 729 ;
+C 79 ; WX 778 ; N O ; B 40 -23 742 741 ;
+C 80 ; WX 667 ; N P ; B 76 0 633 729 ;
+C 81 ; WX 778 ; N Q ; B 43 -54 745 741 ;
+C 82 ; WX 722 ; N R ; B 80 0 677 729 ;
+C 83 ; WX 667 ; N S ; B 32 -23 633 741 ;
+C 84 ; WX 611 ; N T ; B 14 0 598 729 ;
+C 85 ; WX 722 ; N U ; B 76 -23 654 729 ;
+C 86 ; WX 667 ; N V ; B 24 0 647 729 ;
+C 87 ; WX 944 ; N W ; B 13 0 932 729 ;
+C 88 ; WX 667 ; N X ; B 22 0 653 729 ;
+C 89 ; WX 667 ; N Y ; B 27 0 650 729 ;
+C 90 ; WX 611 ; N Z ; B 30 0 578 729 ;
+C 91 ; WX 333 ; N bracketleft ; B 66 -202 308 729 ;
+C 92 ; WX 278 ; N backslash ; B -12 -21 289 708 ;
+C 93 ; WX 333 ; N bracketright ; B 18 -202 260 729 ;
+C 94 ; WX 584 ; N asciicircum ; B 61 271 522 696 ;
+C 95 ; WX 556 ; N underscore ; B -22 -200 578 -130 ;
+C 96 ; WX 278 ; N quoteleft ; B 67 469 202 729 ;
+C 97 ; WX 556 ; N a ; B 27 -24 524 551 ;
+C 98 ; WX 611 ; N b ; B 59 -23 575 729 ;
+C 99 ; WX 556 ; N c ; B 34 -23 522 551 ;
+C 100 ; WX 611 ; N d ; B 29 -23 545 729 ;
+C 101 ; WX 556 ; N e ; B 22 -23 525 551 ;
+C 102 ; WX 333 ; N f ; B 14 0 313 729 ; L i fi ; L l fl ;
+C 103 ; WX 611 ; N g ; B 34 -220 541 551 ;
+C 104 ; WX 611 ; N h ; B 67 0 541 729 ;
+C 105 ; WX 278 ; N i ; B 67 0 207 729 ;
+C 106 ; WX 278 ; N j ; B 4 -219 210 729 ;
+C 107 ; WX 556 ; N k ; B 59 0 548 729 ;
+C 108 ; WX 278 ; N l ; B 67 0 207 729 ;
+C 109 ; WX 889 ; N m ; B 60 0 824 553 ;
+C 110 ; WX 611 ; N n ; B 63 0 546 551 ;
+C 111 ; WX 611 ; N o ; B 35 -23 569 551 ;
+C 112 ; WX 611 ; N p ; B 58 -219 574 551 ;
+C 113 ; WX 611 ; N q ; B 28 -219 544 551 ;
+C 114 ; WX 389 ; N r ; B 63 0 370 553 ;
+C 115 ; WX 556 ; N s ; B 29 -23 520 551 ;
+C 116 ; WX 333 ; N t ; B 14 -23 301 678 ;
+C 117 ; WX 611 ; N u ; B 58 -23 541 542 ;
+C 118 ; WX 556 ; N v ; B 14 0 536 542 ;
+C 119 ; WX 778 ; N w ; B 5 0 766 542 ;
+C 120 ; WX 556 ; N x ; B 16 0 535 542 ;
+C 121 ; WX 556 ; N y ; B 9 -219 538 542 ;
+C 122 ; WX 500 ; N z ; B 21 0 468 542 ;
+C 123 ; WX 389 ; N braceleft ; B 37 -202 317 729 ;
+C 124 ; WX 280 ; N bar ; B 100 -202 180 729 ;
+C 125 ; WX 389 ; N braceright ; B 72 -202 352 729 ;
+C 126 ; WX 584 ; N asciitilde ; B 60 144 519 322 ;
+C 161 ; WX 333 ; N exclamdown ; B 66 -187 216 542 ;
+C 162 ; WX 556 ; N cent ; B 37 -122 522 637 ;
+C 163 ; WX 556 ; N sterling ; B 31 -20 537 717 ;
+C 164 ; WX 167 ; N fraction ; B -173 -20 337 715 ;
+C 165 ; WX 556 ; N yen ; B 5 0 552 705 ;
+C 166 ; WX 556 ; N florin ; B 21 -221 535 745 ;
+C 167 ; WX 556 ; N section ; B 33 -201 518 728 ;
+C 168 ; WX 556 ; N currency ; B 26 105 530 604 ;
+C 169 ; WX 238 ; N quotesingle ; B 50 469 188 729 ;
+C 170 ; WX 500 ; N quotedblleft ; B 71 469 433 729 ;
+C 171 ; WX 556 ; N guillemotleft ; B 88 71 468 484 ;
+C 172 ; WX 333 ; N guilsinglleft ; B 83 73 250 476 ;
+C 173 ; WX 333 ; N guilsinglright ; B 80 73 247 476 ;
+C 174 ; WX 611 ; N fi ; B 9 0 548 729 ;
+C 175 ; WX 611 ; N fl ; B 12 0 546 729 ;
+C 177 ; WX 556 ; N endash ; B -9 208 557 313 ;
+C 178 ; WX 556 ; N dagger ; B 31 -195 523 708 ;
+C 179 ; WX 556 ; N daggerdbl ; B 28 -195 520 708 ;
+C 180 ; WX 278 ; N periodcentered ; B 64 318 188 442 ;
+C 182 ; WX 556 ; N paragraph ; B 20 -195 529 729 ;
+C 183 ; WX 350 ; N bullet ; B 50 175 300 425 ;
+C 184 ; WX 278 ; N quotesinglbase ; B 66 -135 201 125 ;
+C 185 ; WX 500 ; N quotedblbase ; B 72 -164 432 141 ;
+C 186 ; WX 500 ; N quotedblright ; B 73 469 440 729 ;
+C 187 ; WX 556 ; N guillemotright ; B 88 71 462 482 ;
+C 188 ; WX 1000 ; N ellipsis ; B 92 0 908 146 ;
+C 189 ; WX 1000 ; N perthousand ; B 11 -20 990 745 ;
+C 191 ; WX 611 ; N questiondown ; B 51 -192 544 542 ;
+C 193 ; WX 333 ; N grave ; B 17 595 213 745 ;
+C 194 ; WX 333 ; N acute ; B 121 595 317 745 ;
+C 195 ; WX 333 ; N circumflex ; B 8 598 326 745 ;
+C 196 ; WX 333 ; N tilde ; B -9 595 345 729 ;
+C 197 ; WX 333 ; N macron ; B 16 629 315 717 ;
+C 198 ; WX 333 ; N breve ; B 35 593 299 736 ;
+C 199 ; WX 333 ; N dotaccent ; B 112 607 222 729 ;
+C 200 ; WX 333 ; N dieresis ; B 18 609 314 731 ;
+C 202 ; WX 333 ; N ring ; B 77 565 257 745 ;
+C 203 ; WX 333 ; N cedilla ; B 27 -220 294 -9 ;
+C 205 ; WX 333 ; N hungarumlaut ; B -44 595 340 745 ;
+C 206 ; WX 333 ; N ogonek ; B 45 -195 268 38 ;
+C 207 ; WX 333 ; N caron ; B 9 598 327 745 ;
+C 208 ; WX 1000 ; N emdash ; B -7 208 1003 313 ;
+C 225 ; WX 1000 ; N AE ; B 1 0 966 729 ;
+C 227 ; WX 370 ; N ordfeminine ; B 31 277 329 746 ;
+C 232 ; WX 611 ; N Lslash ; B 0 0 597 729 ;
+C 233 ; WX 778 ; N Oslash ; B 31 -34 755 754 ;
+C 234 ; WX 1000 ; N OE ; B 28 -20 970 741 ;
+C 235 ; WX 365 ; N ordmasculine ; B 23 276 343 745 ;
+C 241 ; WX 889 ; N ae ; B 27 -20 857 555 ;
+C 245 ; WX 278 ; N dotlessi ; B 67 0 207 542 ;
+C 248 ; WX 278 ; N lslash ; B 0 0 252 729 ;
+C 249 ; WX 611 ; N oslash ; B 11 -34 598 561 ;
+C 250 ; WX 944 ; N oe ; B 23 -21 920 554 ;
+C 251 ; WX 611 ; N germandbls ; B 67 -16 575 730 ;
+C -1 ; WX 722 ; N Aacute ; B 26 0 703 936 ;
+C -1 ; WX 722 ; N Acircumflex ; B 26 0 703 936 ;
+C -1 ; WX 722 ; N Adieresis ; B 26 0 703 922 ;
+C -1 ; WX 722 ; N Agrave ; B 26 0 703 936 ;
+C -1 ; WX 722 ; N Aring ; B 26 0 703 936 ;
+C -1 ; WX 722 ; N Atilde ; B 26 0 703 920 ;
+C -1 ; WX 722 ; N Ccedilla ; B 44 -220 685 741 ;
+C -1 ; WX 667 ; N Eacute ; B 79 0 624 936 ;
+C -1 ; WX 667 ; N Ecircumflex ; B 79 0 624 936 ;
+C -1 ; WX 667 ; N Edieresis ; B 79 0 624 922 ;
+C -1 ; WX 667 ; N Egrave ; B 79 0 624 936 ;
+C -1 ; WX 722 ; N Eth ; B -18 0 681 729 ;
+C -1 ; WX 278 ; N Iacute ; B 63 0 290 936 ;
+C -1 ; WX 278 ; N Icircumflex ; B -19 0 299 936 ;
+C -1 ; WX 278 ; N Idieresis ; B -9 0 287 922 ;
+C -1 ; WX 278 ; N Igrave ; B -10 0 213 936 ;
+C -1 ; WX 722 ; N Ntilde ; B 68 0 661 920 ;
+C -1 ; WX 778 ; N Oacute ; B 40 -23 742 936 ;
+C -1 ; WX 778 ; N Ocircumflex ; B 40 -23 742 936 ;
+C -1 ; WX 778 ; N Odieresis ; B 40 -23 742 922 ;
+C -1 ; WX 778 ; N Ograve ; B 40 -23 742 936 ;
+C -1 ; WX 778 ; N Otilde ; B 40 -23 742 920 ;
+C -1 ; WX 667 ; N Scaron ; B 32 -23 633 936 ;
+C -1 ; WX 667 ; N Thorn ; B 76 0 633 729 ;
+C -1 ; WX 722 ; N Uacute ; B 76 -23 654 936 ;
+C -1 ; WX 722 ; N Ucircumflex ; B 76 -23 654 936 ;
+C -1 ; WX 722 ; N Udieresis ; B 76 -23 654 922 ;
+C -1 ; WX 722 ; N Ugrave ; B 76 -23 654 936 ;
+C -1 ; WX 667 ; N Yacute ; B 27 0 650 932 ;
+C -1 ; WX 667 ; N Ydieresis ; B 27 0 650 922 ;
+C -1 ; WX 611 ; N Zcaron ; B 30 0 578 936 ;
+C -1 ; WX 556 ; N aacute ; B 27 -24 524 745 ;
+C -1 ; WX 556 ; N acircumflex ; B 27 -24 524 745 ;
+C -1 ; WX 556 ; N adieresis ; B 27 -24 524 731 ;
+C -1 ; WX 556 ; N agrave ; B 27 -24 524 745 ;
+C -1 ; WX 556 ; N aring ; B 27 -24 524 745 ;
+C -1 ; WX 556 ; N atilde ; B 27 -24 524 729 ;
+C -1 ; WX 280 ; N brokenbar ; B 100 -202 180 729 ;
+C -1 ; WX 556 ; N ccedilla ; B 34 -220 522 551 ;
+C -1 ; WX 737 ; N copyright ; B -14 -20 751 745 ;
+C -1 ; WX 400 ; N degree ; B 50 425 350 725 ;
+C -1 ; WX 584 ; N divide ; B 50 -10 534 474 ;
+C -1 ; WX 556 ; N eacute ; B 22 -23 525 745 ;
+C -1 ; WX 556 ; N ecircumflex ; B 22 -23 525 745 ;
+C -1 ; WX 556 ; N edieresis ; B 22 -23 525 731 ;
+C -1 ; WX 556 ; N egrave ; B 22 -23 525 745 ;
+C -1 ; WX 611 ; N eth ; B 35 -23 569 730 ;
+C -1 ; WX 278 ; N iacute ; B 67 0 290 745 ;
+C -1 ; WX 278 ; N icircumflex ; B -19 0 299 745 ;
+C -1 ; WX 278 ; N idieresis ; B -9 0 287 731 ;
+C -1 ; WX 278 ; N igrave ; B -10 0 207 745 ;
+C -1 ; WX 584 ; N logicalnot ; B 40 121 544 412 ;
+C -1 ; WX 584 ; N minus ; B 40 174 544 290 ;
+C -1 ; WX 611 ; N mu ; B 58 -219 541 542 ;
+C -1 ; WX 584 ; N multiply ; B 50 -10 534 474 ;
+C -1 ; WX 611 ; N ntilde ; B 63 0 546 729 ;
+C -1 ; WX 611 ; N oacute ; B 35 -23 569 745 ;
+C -1 ; WX 611 ; N ocircumflex ; B 35 -23 569 745 ;
+C -1 ; WX 611 ; N odieresis ; B 35 -23 569 731 ;
+C -1 ; WX 611 ; N ograve ; B 35 -23 569 745 ;
+C -1 ; WX 834 ; N onehalf ; B 30 -20 803 715 ;
+C -1 ; WX 834 ; N onequarter ; B 30 -20 804 715 ;
+C -1 ; WX 333 ; N onesuperior ; B 46 284 247 709 ;
+C -1 ; WX 611 ; N otilde ; B 35 -23 569 729 ;
+C -1 ; WX 584 ; N plusminus ; B 40 0 544 674 ;
+C -1 ; WX 737 ; N registered ; B -14 -20 751 745 ;
+C -1 ; WX 556 ; N scaron ; B 29 -23 520 745 ;
+C -1 ; WX 611 ; N thorn ; B 58 -219 574 729 ;
+C -1 ; WX 834 ; N threequarters ; B 30 -20 804 725 ;
+C -1 ; WX 333 ; N threesuperior ; B 8 271 325 720 ;
+C -1 ; WX 1000 ; N trademark ; B 71 341 929 745 ;
+C -1 ; WX 333 ; N twosuperior ; B 9 284 324 719 ;
+C -1 ; WX 611 ; N uacute ; B 58 -23 541 745 ;
+C -1 ; WX 611 ; N ucircumflex ; B 58 -23 541 745 ;
+C -1 ; WX 611 ; N udieresis ; B 58 -23 541 731 ;
+C -1 ; WX 611 ; N ugrave ; B 58 -23 541 745 ;
+C -1 ; WX 556 ; N yacute ; B 9 -219 538 745 ;
+C -1 ; WX 556 ; N ydieresis ; B 9 -219 538 731 ;
+C -1 ; WX 500 ; N zcaron ; B 21 0 468 745 ;
+EndCharMetrics
+StartKernData
+StartKernPairs 101
+
+KPX A y -37
+KPX A w -18
+KPX A v -37
+KPX A space -37
+KPX A quoteright -55
+KPX A Y -92
+KPX A W -55
+KPX A V -74
+KPX A T -74
+
+KPX F period -111
+KPX F comma -111
+KPX F A -55
+
+KPX L y -37
+KPX L space -18
+KPX L quoteright -55
+KPX L Y -92
+KPX L W -55
+KPX L V -74
+KPX L T -74
+
+KPX P space -18
+KPX P period -129
+KPX P comma -129
+KPX P A -74
+
+KPX R Y -37
+KPX R W -18
+KPX R V -18
+
+KPX T y -74
+KPX T w -74
+KPX T u -74
+KPX T semicolon -111
+KPX T s -74
+KPX T r -55
+KPX T period -111
+KPX T o -74
+KPX T i -18
+KPX T hyphen -55
+KPX T e -74
+KPX T comma -111
+KPX T colon -111
+KPX T c -74
+KPX T a -74
+KPX T O -18
+KPX T A -74
+
+KPX V y -37
+KPX V u -37
+KPX V semicolon -55
+KPX V r -55
+KPX V period -92
+KPX V o -74
+KPX V i -18
+KPX V hyphen -55
+KPX V e -55
+KPX V comma -92
+KPX V colon -55
+KPX V a -55
+KPX V A -74
+
+KPX W y -18
+KPX W u -18
+KPX W semicolon -18
+KPX W r -18
+KPX W period -55
+KPX W o -18
+KPX W i -9
+KPX W hyphen -20
+KPX W e -18
+KPX W comma -55
+KPX W colon -18
+KPX W a -37
+KPX W A -55
+
+KPX Y v -55
+KPX Y u -55
+KPX Y space -18
+KPX Y semicolon -74
+KPX Y q -74
+KPX Y period -111
+KPX Y p -55
+KPX Y o -74
+KPX Y i -37
+KPX Y hyphen -55
+KPX Y e -55
+KPX Y comma -111
+KPX Y colon -74
+KPX Y a -55
+KPX Y A -92
+
+KPX f quoteright 18
+
+KPX one one -55
+
+KPX quoteleft quoteleft -37
+
+KPX quoteright space -55
+KPX quoteright s -37
+KPX quoteright quoteright -37
+
+KPX r quoteright 37
+KPX r period -55
+KPX r comma -55
+
+KPX space Y -18
+KPX space A -37
+
+KPX v period -74
+KPX v comma -74
+
+KPX w period -37
+KPX w comma -37
+
+KPX y period -74
+KPX y comma -74
+EndKernPairs
+EndKernData
+StartComposites 58
+CC Zcaron 2 ; PCC Z 0 0 ; PCC caron 139 191 ;
+CC zcaron 2 ; PCC z 0 0 ; PCC caron 83 0 ;
+CC Scaron 2 ; PCC S 0 0 ; PCC caron 167 191 ;
+CC scaron 2 ; PCC s 0 0 ; PCC caron 111 0 ;
+CC Ccedilla 2 ; PCC C 0 0 ; PCC cedilla 207 0 ;
+CC ccedilla 2 ; PCC c 0 0 ; PCC cedilla 117 0 ;
+CC Yacute 2 ; PCC Y 0 0 ; PCC acute 167 187 ;
+CC yacute 2 ; PCC y 0 0 ; PCC acute 111 0 ;
+CC Ydieresis 2 ; PCC Y 0 0 ; PCC dieresis 167 191 ;
+CC ydieresis 2 ; PCC y 0 0 ; PCC dieresis 111 0 ;
+CC Uacute 2 ; PCC U 0 0 ; PCC acute 197 191 ;
+CC Ucircumflex 2 ; PCC U 0 0 ; PCC circumflex 197 191 ;
+CC Udieresis 2 ; PCC U 0 0 ; PCC dieresis 197 191 ;
+CC Ugrave 2 ; PCC U 0 0 ; PCC grave 197 191 ;
+CC uacute 2 ; PCC u 0 0 ; PCC acute 139 0 ;
+CC ucircumflex 2 ; PCC u 0 0 ; PCC circumflex 139 0 ;
+CC udieresis 2 ; PCC u 0 0 ; PCC dieresis 139 0 ;
+CC ugrave 2 ; PCC u 0 0 ; PCC grave 139 0 ;
+CC Iacute 2 ; PCC I 0 0 ; PCC acute -27 191 ;
+CC Icircumflex 2 ; PCC I 0 0 ; PCC circumflex -27 191 ;
+CC Idieresis 2 ; PCC I 0 0 ; PCC dieresis -27 191 ;
+CC Igrave 2 ; PCC I 0 0 ; PCC grave -27 191 ;
+CC iacute 2 ; PCC dotlessi 0 0 ; PCC acute -27 0 ;
+CC icircumflex 2 ; PCC dotlessi 0 0 ; PCC circumflex -27 0 ;
+CC idieresis 2 ; PCC dotlessi 0 0 ; PCC dieresis -27 0 ;
+CC igrave 2 ; PCC dotlessi 0 0 ; PCC grave -27 0 ;
+CC Eacute 2 ; PCC E 0 0 ; PCC acute 188 191 ;
+CC Ecircumflex 2 ; PCC E 0 0 ; PCC circumflex 188 191 ;
+CC Edieresis 2 ; PCC E 0 0 ; PCC dieresis 188 191 ;
+CC Egrave 2 ; PCC E 0 0 ; PCC grave 188 191 ;
+CC eacute 2 ; PCC e 0 0 ; PCC acute 111 0 ;
+CC ecircumflex 2 ; PCC e 0 0 ; PCC circumflex 111 0 ;
+CC edieresis 2 ; PCC e 0 0 ; PCC dieresis 111 0 ;
+CC egrave 2 ; PCC e 0 0 ; PCC grave 111 0 ;
+CC Aacute 2 ; PCC A 0 0 ; PCC acute 197 191 ;
+CC Acircumflex 2 ; PCC A 0 0 ; PCC circumflex 197 191 ;
+CC Adieresis 2 ; PCC A 0 0 ; PCC dieresis 197 191 ;
+CC Agrave 2 ; PCC A 0 0 ; PCC grave 197 191 ;
+CC aacute 2 ; PCC a 0 0 ; PCC acute 111 0 ;
+CC acircumflex 2 ; PCC a 0 0 ; PCC circumflex 111 0 ;
+CC adieresis 2 ; PCC a 0 0 ; PCC dieresis 111 0 ;
+CC agrave 2 ; PCC a 0 0 ; PCC grave 111 0 ;
+CC Oacute 2 ; PCC O 0 0 ; PCC acute 222 191 ;
+CC Ocircumflex 2 ; PCC O 0 0 ; PCC circumflex 222 191 ;
+CC Odieresis 2 ; PCC O 0 0 ; PCC dieresis 222 191 ;
+CC Ograve 2 ; PCC O 0 0 ; PCC grave 222 191 ;
+CC oacute 2 ; PCC o 0 0 ; PCC acute 139 0 ;
+CC ocircumflex 2 ; PCC o 0 0 ; PCC circumflex 139 0 ;
+CC odieresis 2 ; PCC o 0 0 ; PCC dieresis 139 0 ;
+CC ograve 2 ; PCC o 0 0 ; PCC grave 139 0 ;
+CC Atilde 2 ; PCC A 0 0 ; PCC tilde 197 191 ;
+CC atilde 2 ; PCC a 0 0 ; PCC tilde 111 0 ;
+CC Ntilde 2 ; PCC N 0 0 ; PCC tilde 200 191 ;
+CC ntilde 2 ; PCC n 0 0 ; PCC tilde 146 0 ;
+CC Otilde 2 ; PCC O 0 0 ; PCC tilde 222 191 ;
+CC otilde 2 ; PCC o 0 0 ; PCC tilde 139 0 ;
+CC Aring 2 ; PCC A 0 0 ; PCC ring 197 191 ;
+CC aring 2 ; PCC a 0 0 ; PCC ring 111 0 ;
+EndComposites
+EndFontMetrics
diff --git a/collects/afm/Helvetica-BoldOblique.afm b/collects/afm/Helvetica-BoldOblique.afm
new file mode 100644
index 0000000000..9820c4b5c7
--- /dev/null
+++ b/collects/afm/Helvetica-BoldOblique.afm
@@ -0,0 +1,431 @@
+StartFontMetrics 2.0
+Comment Copyright (c) 1984 Adobe Systems Incorporated. All Rights Reserved.
+Comment Creation Date:Sun Feb 8 20:39:16 PST 1987
+FontName Helvetica-BoldOblique
+EncodingScheme AdobeStandardEncoding
+FullName Helvetica Bold Oblique
+FamilyName Helvetica
+Weight Bold
+ItalicAngle -12.0
+IsFixedPitch false
+UnderlinePosition -106
+UnderlineThickness 105
+Version 001.002
+Notice Helvetica is a registered trademark of Allied Corporation
+FontBBox -177 -221 1107 936
+CapHeight 729
+XHeight 542
+Descender -219
+Ascender 729
+StartCharMetrics 228
+C 32 ; WX 278 ; N space ; B 0 0 0 0 ;
+C 33 ; WX 333 ; N exclam ; B 112 0 417 729 ;
+C 34 ; WX 474 ; N quotedbl ; B 177 470 579 729 ;
+C 35 ; WX 556 ; N numbersign ; B 33 -30 660 696 ;
+C 36 ; WX 556 ; N dollar ; B 59 -125 628 765 ;
+C 37 ; WX 889 ; N percent ; B 129 -18 903 708 ;
+C 38 ; WX 722 ; N ampersand ; B 89 -20 720 729 ;
+C 39 ; WX 278 ; N quoteright ; B 166 469 356 729 ;
+C 40 ; WX 333 ; N parenleft ; B 84 -202 458 729 ;
+C 41 ; WX 333 ; N parenright ; B -21 -202 356 729 ;
+C 42 ; WX 389 ; N asterisk ; B 145 385 478 730 ;
+C 43 ; WX 584 ; N plus ; B 87 -10 596 474 ;
+C 44 ; WX 278 ; N comma ; B 27 -174 245 146 ;
+C 45 ; WX 333 ; N hyphen ; B 70 208 371 344 ;
+C 46 ; WX 278 ; N period ; B 64 0 245 146 ;
+C 47 ; WX 278 ; N slash ; B -1 -14 427 715 ;
+C 48 ; WX 556 ; N zero ; B 81 -23 614 725 ;
+C 49 ; WX 556 ; N one ; B 172 0 529 709 ;
+C 50 ; WX 556 ; N two ; B 30 0 628 726 ;
+C 51 ; WX 556 ; N three ; B 67 -23 613 726 ;
+C 52 ; WX 556 ; N four ; B 57 0 599 709 ;
+C 53 ; WX 556 ; N five ; B 59 -24 641 709 ;
+C 54 ; WX 556 ; N six ; B 85 -23 625 727 ;
+C 55 ; WX 556 ; N seven ; B 131 0 679 709 ;
+C 56 ; WX 556 ; N eight ; B 60 -23 620 726 ;
+C 57 ; WX 556 ; N nine ; B 68 -23 611 728 ;
+C 58 ; WX 333 ; N colon ; B 113 0 374 521 ;
+C 59 ; WX 333 ; N semicolon ; B 76 -174 374 521 ;
+C 60 ; WX 584 ; N less ; B 77 -10 630 474 ;
+C 61 ; WX 584 ; N equal ; B 61 52 622 412 ;
+C 62 ; WX 584 ; N greater ; B 38 -10 591 474 ;
+C 63 ; WX 611 ; N question ; B 168 0 672 744 ;
+C 64 ; WX 975 ; N at ; B 73 -136 1032 746 ;
+C 65 ; WX 722 ; N A ; B 26 0 703 729 ;
+C 66 ; WX 722 ; N B ; B 82 0 762 729 ;
+C 67 ; WX 722 ; N C ; B 107 -23 793 741 ;
+C 68 ; WX 722 ; N D ; B 77 0 776 729 ;
+C 69 ; WX 667 ; N E ; B 79 0 762 729 ;
+C 70 ; WX 611 ; N F ; B 74 0 741 729 ;
+C 71 ; WX 778 ; N G ; B 107 -24 819 741 ;
+C 72 ; WX 722 ; N H ; B 68 0 812 729 ;
+C 73 ; WX 278 ; N I ; B 63 0 368 729 ;
+C 74 ; WX 556 ; N J ; B 59 -23 641 729 ;
+C 75 ; WX 722 ; N K ; B 74 0 843 729 ;
+C 76 ; WX 611 ; N L ; B 80 0 606 729 ;
+C 77 ; WX 833 ; N M ; B 66 0 931 729 ;
+C 78 ; WX 722 ; N N ; B 68 0 816 729 ;
+C 79 ; WX 778 ; N O ; B 106 -23 828 741 ;
+C 80 ; WX 667 ; N P ; B 76 0 747 729 ;
+C 81 ; WX 778 ; N Q ; B 109 -54 831 741 ;
+C 82 ; WX 722 ; N R ; B 80 0 785 729 ;
+C 83 ; WX 667 ; N S ; B 76 -23 725 741 ;
+C 84 ; WX 611 ; N T ; B 142 0 753 729 ;
+C 85 ; WX 722 ; N U ; B 119 -23 809 729 ;
+C 86 ; WX 667 ; N V ; B 179 0 802 729 ;
+C 87 ; WX 944 ; N W ; B 168 0 1087 729 ;
+C 88 ; WX 667 ; N X ; B 22 0 802 729 ;
+C 89 ; WX 667 ; N Y ; B 182 0 805 729 ;
+C 90 ; WX 611 ; N Z ; B 30 0 733 729 ;
+C 91 ; WX 333 ; N bracketleft ; B 23 -202 463 729 ;
+C 92 ; WX 278 ; N backslash ; B 138 -21 285 708 ;
+C 93 ; WX 333 ; N bracketright ; B -25 -202 415 729 ;
+C 94 ; WX 584 ; N asciicircum ; B 119 271 580 696 ;
+C 95 ; WX 556 ; N underscore ; B -65 -200 550 -130 ;
+C 96 ; WX 278 ; N quoteleft ; B 167 469 357 729 ;
+C 97 ; WX 556 ; N a ; B 50 -24 578 551 ;
+C 98 ; WX 611 ; N b ; B 59 -23 640 729 ;
+C 99 ; WX 556 ; N c ; B 77 -23 597 551 ;
+C 100 ; WX 611 ; N d ; B 79 -23 700 729 ;
+C 101 ; WX 556 ; N e ; B 64 -23 591 551 ;
+C 102 ; WX 333 ; N f ; B 90 0 464 729 ; L i fi ; L l fl ;
+C 103 ; WX 611 ; N g ; B 26 -220 656 551 ;
+C 104 ; WX 611 ; N h ; B 67 0 629 729 ;
+C 105 ; WX 278 ; N i ; B 67 0 362 729 ;
+C 106 ; WX 278 ; N j ; B -43 -219 365 729 ;
+C 107 ; WX 556 ; N k ; B 59 0 651 729 ;
+C 108 ; WX 278 ; N l ; B 67 0 362 729 ;
+C 109 ; WX 889 ; N m ; B 60 0 911 553 ;
+C 110 ; WX 611 ; N n ; B 63 0 629 551 ;
+C 111 ; WX 611 ; N o ; B 82 -23 634 551 ;
+C 112 ; WX 611 ; N p ; B 11 -219 637 551 ;
+C 113 ; WX 611 ; N q ; B 72 -219 659 551 ;
+C 114 ; WX 389 ; N r ; B 63 0 487 553 ;
+C 115 ; WX 556 ; N s ; B 60 -23 589 551 ;
+C 116 ; WX 333 ; N t ; B 101 -23 414 678 ;
+C 117 ; WX 611 ; N u ; B 88 -23 656 542 ;
+C 118 ; WX 556 ; N v ; B 129 0 651 542 ;
+C 119 ; WX 778 ; N w ; B 120 0 881 542 ;
+C 120 ; WX 556 ; N x ; B 16 0 648 542 ;
+C 121 ; WX 556 ; N y ; B 37 -219 653 542 ;
+C 122 ; WX 500 ; N z ; B 21 0 575 542 ;
+C 123 ; WX 389 ; N braceleft ; B 84 -202 472 729 ;
+C 124 ; WX 280 ; N bar ; B 57 -202 335 729 ;
+C 125 ; WX 389 ; N braceright ; B 29 -202 419 729 ;
+C 126 ; WX 584 ; N asciitilde ; B 97 144 581 322 ;
+C 161 ; WX 333 ; N exclamdown ; B 26 -187 331 542 ;
+C 162 ; WX 556 ; N cent ; B 79 -122 598 637 ;
+C 163 ; WX 556 ; N sterling ; B 49 -20 629 717 ;
+C 164 ; WX 167 ; N fraction ; B -177 -20 489 715 ;
+C 165 ; WX 556 ; N yen ; B 107 0 702 705 ;
+C 166 ; WX 556 ; N florin ; B -21 -221 690 745 ;
+C 167 ; WX 556 ; N section ; B 56 -201 596 728 ;
+C 168 ; WX 556 ; N currency ; B 66 105 644 604 ;
+C 169 ; WX 238 ; N quotesingle ; B 177 469 343 729 ;
+C 170 ; WX 500 ; N quotedblleft ; B 171 469 588 729 ;
+C 171 ; WX 556 ; N guillemotleft ; B 135 71 571 484 ;
+C 172 ; WX 333 ; N guilsinglleft ; B 128 73 351 476 ;
+C 173 ; WX 333 ; N guilsinglright ; B 96 73 319 476 ;
+C 174 ; WX 611 ; N fi ; B 85 0 703 729 ;
+C 175 ; WX 611 ; N fl ; B 88 0 701 729 ;
+C 177 ; WX 556 ; N endash ; B 35 208 624 313 ;
+C 178 ; WX 556 ; N dagger ; B 109 -195 626 708 ;
+C 179 ; WX 556 ; N daggerdbl ; B 35 -195 623 708 ;
+C 180 ; WX 278 ; N periodcentered ; B 143 318 270 442 ;
+C 182 ; WX 556 ; N paragraph ; B 121 -195 684 729 ;
+C 183 ; WX 350 ; N bullet ; B 111 175 367 425 ;
+C 184 ; WX 278 ; N quotesinglbase ; B 37 -135 228 125 ;
+C 185 ; WX 500 ; N quotedblbase ; B 37 -164 462 141 ;
+C 186 ; WX 500 ; N quotedblright ; B 173 469 595 729 ;
+C 187 ; WX 556 ; N guillemotright ; B 103 71 533 482 ;
+C 188 ; WX 1000 ; N ellipsis ; B 92 0 939 146 ;
+C 189 ; WX 1000 ; N perthousand ; B 72 -20 1021 745 ;
+C 191 ; WX 611 ; N questiondown ; B 52 -192 556 542 ;
+C 193 ; WX 333 ; N grave ; B 175 595 339 745 ;
+C 194 ; WX 333 ; N acute ; B 247 595 475 745 ;
+C 195 ; WX 333 ; N circumflex ; B 135 598 453 745 ;
+C 196 ; WX 333 ; N tilde ; B 117 595 500 729 ;
+C 197 ; WX 333 ; N macron ; B 150 629 467 717 ;
+C 198 ; WX 333 ; N breve ; B 188 593 455 736 ;
+C 199 ; WX 333 ; N dotaccent ; B 241 607 377 729 ;
+C 200 ; WX 333 ; N dieresis ; B 147 609 469 731 ;
+C 202 ; WX 333 ; N ring ; B 214 565 398 745 ;
+C 203 ; WX 333 ; N cedilla ; B -13 -220 270 -9 ;
+C 205 ; WX 333 ; N hungarumlaut ; B 82 595 498 745 ;
+C 206 ; WX 333 ; N ogonek ; B 23 -195 248 38 ;
+C 207 ; WX 333 ; N caron ; B 167 598 485 745 ;
+C 208 ; WX 1000 ; N emdash ; B 37 208 1070 313 ;
+C 225 ; WX 1000 ; N AE ; B 1 0 1104 729 ;
+C 227 ; WX 370 ; N ordfeminine ; B 96 277 451 746 ;
+C 232 ; WX 611 ; N Lslash ; B 54 0 624 729 ;
+C 233 ; WX 778 ; N Oslash ; B 34 -34 906 754 ;
+C 234 ; WX 1000 ; N OE ; B 90 -20 1107 741 ;
+C 235 ; WX 365 ; N ordmasculine ; B 92 276 471 745 ;
+C 241 ; WX 889 ; N ae ; B 54 -20 927 555 ;
+C 245 ; WX 278 ; N dotlessi ; B 67 0 322 542 ;
+C 248 ; WX 278 ; N lslash ; B 50 0 372 729 ;
+C 249 ; WX 611 ; N oslash ; B 12 -34 709 561 ;
+C 250 ; WX 944 ; N oe ; B 71 -21 986 554 ;
+C 251 ; WX 611 ; N germandbls ; B 67 -16 654 730 ;
+C -1 ; WX 722 ; N Aacute ; B 26 0 714 936 ;
+C -1 ; WX 722 ; N Acircumflex ; B 26 0 703 936 ;
+C -1 ; WX 722 ; N Adieresis ; B 26 0 708 922 ;
+C -1 ; WX 722 ; N Agrave ; B 26 0 703 936 ;
+C -1 ; WX 722 ; N Aring ; B 26 0 703 936 ;
+C -1 ; WX 722 ; N Atilde ; B 26 0 739 920 ;
+C -1 ; WX 722 ; N Ccedilla ; B 107 -220 793 741 ;
+C -1 ; WX 667 ; N Eacute ; B 79 0 762 936 ;
+C -1 ; WX 667 ; N Ecircumflex ; B 79 0 762 936 ;
+C -1 ; WX 667 ; N Edieresis ; B 79 0 762 922 ;
+C -1 ; WX 667 ; N Egrave ; B 79 0 762 936 ;
+C -1 ; WX 722 ; N Eth ; B 53 0 776 729 ;
+C -1 ; WX 278 ; N Iacute ; B 63 0 489 936 ;
+C -1 ; WX 278 ; N Icircumflex ; B 63 0 467 936 ;
+C -1 ; WX 278 ; N Idieresis ; B 63 0 483 922 ;
+C -1 ; WX 278 ; N Igrave ; B 63 0 368 936 ;
+C -1 ; WX 722 ; N Ntilde ; B 68 0 816 920 ;
+C -1 ; WX 778 ; N Oacute ; B 106 -23 828 936 ;
+C -1 ; WX 778 ; N Ocircumflex ; B 106 -23 828 936 ;
+C -1 ; WX 778 ; N Odieresis ; B 106 -23 828 922 ;
+C -1 ; WX 778 ; N Ograve ; B 106 -23 828 936 ;
+C -1 ; WX 778 ; N Otilde ; B 106 -23 828 920 ;
+C -1 ; WX 667 ; N Scaron ; B 76 -23 725 936 ;
+C -1 ; WX 667 ; N Thorn ; B 76 0 730 729 ;
+C -1 ; WX 722 ; N Uacute ; B 119 -23 809 936 ;
+C -1 ; WX 722 ; N Ucircumflex ; B 119 -23 809 936 ;
+C -1 ; WX 722 ; N Udieresis ; B 119 -23 809 922 ;
+C -1 ; WX 722 ; N Ugrave ; B 119 -23 809 936 ;
+C -1 ; WX 667 ; N Yacute ; B 182 0 805 932 ;
+C -1 ; WX 667 ; N Ydieresis ; B 182 0 805 922 ;
+C -1 ; WX 611 ; N Zcaron ; B 30 0 733 936 ;
+C -1 ; WX 556 ; N aacute ; B 50 -24 587 745 ;
+C -1 ; WX 556 ; N acircumflex ; B 50 -24 578 745 ;
+C -1 ; WX 556 ; N adieresis ; B 50 -24 581 731 ;
+C -1 ; WX 556 ; N agrave ; B 50 -24 578 745 ;
+C -1 ; WX 556 ; N aring ; B 50 -24 578 745 ;
+C -1 ; WX 556 ; N atilde ; B 50 -24 612 729 ;
+C -1 ; WX 280 ; N brokenbar ; B 57 -202 335 729 ;
+C -1 ; WX 556 ; N ccedilla ; B 77 -220 597 551 ;
+C -1 ; WX 737 ; N copyright ; B 54 -20 837 745 ;
+C -1 ; WX 400 ; N degree ; B 169 425 476 725 ;
+C -1 ; WX 584 ; N divide ; B 87 -10 596 474 ;
+C -1 ; WX 556 ; N eacute ; B 64 -23 591 745 ;
+C -1 ; WX 556 ; N ecircumflex ; B 64 -23 591 745 ;
+C -1 ; WX 556 ; N edieresis ; B 64 -23 591 731 ;
+C -1 ; WX 556 ; N egrave ; B 64 -23 591 745 ;
+C -1 ; WX 611 ; N eth ; B 82 -23 633 730 ;
+C -1 ; WX 278 ; N iacute ; B 67 0 448 745 ;
+C -1 ; WX 278 ; N icircumflex ; B 67 0 426 745 ;
+C -1 ; WX 278 ; N idieresis ; B 67 0 442 731 ;
+C -1 ; WX 278 ; N igrave ; B 67 0 322 745 ;
+C -1 ; WX 584 ; N logicalnot ; B 103 121 632 412 ;
+C -1 ; WX 584 ; N minus ; B 77 174 606 290 ;
+C -1 ; WX 611 ; N mu ; B 11 -219 656 542 ;
+C -1 ; WX 584 ; N multiply ; B 66 -10 617 474 ;
+C -1 ; WX 611 ; N ntilde ; B 63 0 646 729 ;
+C -1 ; WX 611 ; N oacute ; B 82 -23 634 745 ;
+C -1 ; WX 611 ; N ocircumflex ; B 82 -23 634 745 ;
+C -1 ; WX 611 ; N odieresis ; B 82 -23 634 731 ;
+C -1 ; WX 611 ; N ograve ; B 82 -23 634 745 ;
+C -1 ; WX 834 ; N onehalf ; B 120 -20 871 715 ;
+C -1 ; WX 834 ; N onequarter ; B 151 -20 846 715 ;
+C -1 ; WX 333 ; N onesuperior ; B 169 284 398 709 ;
+C -1 ; WX 611 ; N otilde ; B 82 -23 639 729 ;
+C -1 ; WX 584 ; N plusminus ; B 40 0 639 674 ;
+C -1 ; WX 737 ; N registered ; B 55 -20 837 745 ;
+C -1 ; WX 556 ; N scaron ; B 60 -23 597 745 ;
+C -1 ; WX 611 ; N thorn ; B 11 -219 641 729 ;
+C -1 ; WX 834 ; N threequarters ; B 116 -20 863 725 ;
+C -1 ; WX 333 ; N threesuperior ; B 92 271 442 720 ;
+C -1 ; WX 1000 ; N trademark ; B 213 341 1087 745 ;
+C -1 ; WX 333 ; N twosuperior ; B 69 284 452 719 ;
+C -1 ; WX 611 ; N uacute ; B 88 -23 656 745 ;
+C -1 ; WX 611 ; N ucircumflex ; B 88 -23 656 745 ;
+C -1 ; WX 611 ; N udieresis ; B 88 -23 656 731 ;
+C -1 ; WX 611 ; N ugrave ; B 88 -23 656 745 ;
+C -1 ; WX 556 ; N yacute ; B 37 -219 653 745 ;
+C -1 ; WX 556 ; N ydieresis ; B 37 -219 653 731 ;
+C -1 ; WX 500 ; N zcaron ; B 21 0 575 745 ;
+EndCharMetrics
+StartKernData
+StartKernPairs 99
+
+KPX A space -37
+KPX A quoteright -55
+KPX A Y -74
+KPX A W -55
+KPX A V -74
+KPX A T -74
+
+KPX F period -111
+KPX F comma -111
+KPX F A -55
+
+KPX L space -18
+KPX L quoteright -74
+KPX L Y -74
+KPX L W -55
+KPX L V -55
+KPX L T -74
+
+KPX P space -37
+KPX P period -129
+KPX P comma -129
+KPX P A -74
+
+KPX R Y -18
+KPX R W -18
+KPX R T -18
+
+KPX T y -37
+KPX T w -37
+KPX T u -18
+KPX T semicolon -74
+KPX T s -37
+KPX T r -18
+KPX T period -74
+KPX T o -37
+KPX T i -18
+KPX T hyphen -55
+KPX T e -37
+KPX T comma -74
+KPX T colon -74
+KPX T c -37
+KPX T a -37
+KPX T O -18
+KPX T A -74
+
+KPX V y -18
+KPX V u -18
+KPX V semicolon -37
+KPX V r -18
+KPX V period -92
+KPX V o -37
+KPX V i -37
+KPX V hyphen -37
+KPX V e -37
+KPX V comma -92
+KPX V colon -37
+KPX V a -37
+KPX V A -74
+
+KPX W y -18
+KPX W u -18
+KPX W semicolon -37
+KPX W r -18
+KPX W period -74
+KPX W o -18
+KPX W i -9
+KPX W hyphen -37
+KPX W e -18
+KPX W comma -74
+KPX W colon -37
+KPX W a -18
+KPX W A -55
+
+KPX Y v -37
+KPX Y u -37
+KPX Y space -18
+KPX Y semicolon -55
+KPX Y q -37
+KPX Y period -92
+KPX Y p -37
+KPX Y i -37
+KPX Y o -37
+KPX Y hyphen -74
+KPX Y e -37
+KPX Y comma -92
+KPX Y colon -55
+KPX Y a -37
+KPX Y A -74
+
+KPX f quoteright 18
+KPX f f -18
+
+KPX one one -74
+
+KPX quoteleft quoteleft -37
+
+KPX quoteright t 18
+KPX quoteright space -37
+KPX quoteright s -18
+KPX quoteright quoteright -37
+
+KPX r quoteright 37
+KPX r period -55
+KPX r comma -55
+
+KPX space Y -18
+KPX space A -37
+
+KPX v period -55
+KPX v comma -55
+
+KPX w period -37
+KPX w comma -37
+
+KPX y period -37
+KPX y comma -37
+EndKernPairs
+EndKernData
+StartComposites 58
+CC Zcaron 2 ; PCC Z 0 0 ; PCC caron 139 187 ;
+CC zcaron 2 ; PCC z 0 0 ; PCC caron 83 0 ;
+CC Scaron 2 ; PCC S 0 0 ; PCC caron 167 187 ;
+CC scaron 2 ; PCC s 0 0 ; PCC caron 111 0 ;
+CC Ccedilla 2 ; PCC C 0 0 ; PCC cedilla 194 0 ;
+CC ccedilla 2 ; PCC c 0 0 ; PCC cedilla 111 0 ;
+CC Yacute 2 ; PCC Y 0 0 ; PCC acute 167 187 ;
+CC yacute 2 ; PCC y 0 0 ; PCC acute 111 0 ;
+CC Ydieresis 2 ; PCC Y 0 0 ; PCC dieresis 167 187 ;
+CC ydieresis 2 ; PCC y 0 0 ; PCC dieresis 111 0 ;
+CC Uacute 2 ; PCC U 0 0 ; PCC acute 194 187 ;
+CC Ucircumflex 2 ; PCC U 0 0 ; PCC circumflex 194 187 ;
+CC Udieresis 2 ; PCC U 0 0 ; PCC dieresis 194 187 ;
+CC Ugrave 2 ; PCC U 0 0 ; PCC grave 194 187 ;
+CC uacute 2 ; PCC u 0 0 ; PCC acute 139 0 ;
+CC ucircumflex 2 ; PCC u 0 0 ; PCC circumflex 139 0 ;
+CC udieresis 2 ; PCC u 0 0 ; PCC dieresis 139 0 ;
+CC ugrave 2 ; PCC u 0 0 ; PCC grave 139 0 ;
+CC Iacute 2 ; PCC I 0 0 ; PCC acute -27 187 ;
+CC Icircumflex 2 ; PCC I 0 0 ; PCC circumflex -27 187 ;
+CC Idieresis 2 ; PCC I 0 0 ; PCC dieresis -27 187 ;
+CC Igrave 2 ; PCC I 0 0 ; PCC grave -27 187 ;
+CC iacute 2 ; PCC dotlessi 0 0 ; PCC acute -27 0 ;
+CC icircumflex 2 ; PCC dotlessi 0 0 ; PCC circumflex -27 0 ;
+CC idieresis 2 ; PCC dotlessi 0 0 ; PCC dieresis -27 0 ;
+CC igrave 2 ; PCC dotlessi 0 0 ; PCC grave -27 0 ;
+CC Eacute 2 ; PCC E 0 0 ; PCC acute 167 187 ;
+CC Ecircumflex 2 ; PCC E 0 0 ; PCC circumflex 167 187 ;
+CC Edieresis 2 ; PCC E 0 0 ; PCC dieresis 167 187 ;
+CC Egrave 2 ; PCC E 0 0 ; PCC grave 167 187 ;
+CC eacute 2 ; PCC e 0 0 ; PCC acute 111 0 ;
+CC ecircumflex 2 ; PCC e 0 0 ; PCC circumflex 111 0 ;
+CC edieresis 2 ; PCC e 0 0 ; PCC dieresis 111 0 ;
+CC egrave 2 ; PCC e 0 0 ; PCC grave 111 0 ;
+CC Aacute 2 ; PCC A 0 0 ; PCC acute 194 187 ;
+CC Acircumflex 2 ; PCC A 0 0 ; PCC circumflex 194 187 ;
+CC Adieresis 2 ; PCC A 0 0 ; PCC dieresis 194 187 ;
+CC Agrave 2 ; PCC A 0 0 ; PCC grave 194 187 ;
+CC aacute 2 ; PCC a 0 0 ; PCC acute 111 0 ;
+CC acircumflex 2 ; PCC a 0 0 ; PCC circumflex 111 0 ;
+CC adieresis 2 ; PCC a 0 0 ; PCC dieresis 111 0 ;
+CC agrave 2 ; PCC a 0 0 ; PCC grave 111 0 ;
+CC Oacute 2 ; PCC O 0 0 ; PCC acute 222 187 ;
+CC Ocircumflex 2 ; PCC O 0 0 ; PCC circumflex 222 187 ;
+CC Odieresis 2 ; PCC O 0 0 ; PCC dieresis 222 187 ;
+CC Ograve 2 ; PCC O 0 0 ; PCC grave 222 187 ;
+CC oacute 2 ; PCC o 0 0 ; PCC acute 139 0 ;
+CC ocircumflex 2 ; PCC o 0 0 ; PCC circumflex 139 0 ;
+CC odieresis 2 ; PCC o 0 0 ; PCC dieresis 139 0 ;
+CC ograve 2 ; PCC o 0 0 ; PCC grave 139 0 ;
+CC Atilde 2 ; PCC A 0 0 ; PCC tilde 194 187 ;
+CC atilde 2 ; PCC a 0 0 ; PCC tilde 111 0 ;
+CC Ntilde 2 ; PCC N 0 0 ; PCC tilde 194 187 ;
+CC ntilde 2 ; PCC n 0 0 ; PCC tilde 139 0 ;
+CC Otilde 2 ; PCC O 0 0 ; PCC tilde 222 187 ;
+CC otilde 2 ; PCC o 0 0 ; PCC tilde 139 0 ;
+CC Aring 2 ; PCC A 0 0 ; PCC ring 194 187 ;
+CC aring 2 ; PCC a 0 0 ; PCC ring 111 0 ;
+EndComposites
+EndFontMetrics
diff --git a/collects/afm/Helvetica-Oblique.afm b/collects/afm/Helvetica-Oblique.afm
new file mode 100644
index 0000000000..3df18088f7
--- /dev/null
+++ b/collects/afm/Helvetica-Oblique.afm
@@ -0,0 +1,430 @@
+StartFontMetrics 2.0
+Comment Copyright (c) 1984 Adobe Systems Incorporated. All Rights Reserved.
+Comment Creation Date:Sun Feb 8 20:00:37 PST 1987
+FontName Helvetica-Oblique
+EncodingScheme AdobeStandardEncoding
+FullName Helvetica Oblique
+FamilyName Helvetica
+Weight Medium
+ItalicAngle -12.0
+IsFixedPitch false
+UnderlinePosition -106
+UnderlineThickness 73
+Version 001.002
+Notice Helvetica is a registered trademark of Allied Corporation.
+FontBBox -178 -220 1108 944
+CapHeight 729
+XHeight 525
+Descender -219
+Ascender 729
+StartCharMetrics 228
+C 32 ; WX 278 ; N space ; B 0 0 0 0 ;
+C 33 ; WX 278 ; N exclam ; B 124 0 363 729 ;
+C 34 ; WX 355 ; N quotedbl ; B 177 462 455 708 ;
+C 35 ; WX 556 ; N numbersign ; B 54 -20 649 698 ;
+C 36 ; WX 556 ; N dollar ; B 69 -125 613 770 ;
+C 37 ; WX 889 ; N percent ; B 134 -20 895 708 ;
+C 38 ; WX 667 ; N ampersand ; B 83 -23 644 710 ;
+C 39 ; WX 222 ; N quoteright ; B 165 476 308 708 ;
+C 40 ; WX 333 ; N parenleft ; B 113 -213 446 729 ;
+C 41 ; WX 333 ; N parenright ; B -7 -213 325 729 ;
+C 42 ; WX 389 ; N asterisk ; B 169 452 471 740 ;
+C 43 ; WX 584 ; N plus ; B 92 -10 591 474 ;
+C 44 ; WX 278 ; N comma ; B 55 -150 214 104 ;
+C 45 ; WX 333 ; N hyphen ; B 97 240 351 313 ;
+C 46 ; WX 278 ; N period ; B 87 0 213 104 ;
+C 47 ; WX 278 ; N slash ; B -12 -21 434 708 ;
+C 48 ; WX 556 ; N zero ; B 98 -23 598 709 ;
+C 49 ; WX 556 ; N one ; B 208 0 498 709 ;
+C 50 ; WX 556 ; N two ; B 34 0 620 710 ;
+C 51 ; WX 556 ; N three ; B 71 -23 599 709 ;
+C 52 ; WX 556 ; N four ; B 63 0 573 709 ;
+C 53 ; WX 556 ; N five ; B 70 -23 629 709 ;
+C 54 ; WX 556 ; N six ; B 93 -23 611 709 ;
+C 55 ; WX 556 ; N seven ; B 137 0 671 709 ;
+C 56 ; WX 556 ; N eight ; B 74 -23 604 709 ;
+C 57 ; WX 556 ; N nine ; B 83 -23 599 709 ;
+C 58 ; WX 278 ; N colon ; B 110 0 326 525 ;
+C 59 ; WX 278 ; N semicolon ; B 78 -150 325 516 ;
+C 60 ; WX 584 ; N less ; B 87 -10 635 474 ;
+C 61 ; WX 584 ; N equal ; B 74 112 609 352 ;
+C 62 ; WX 584 ; N greater ; B 48 -10 596 474 ;
+C 63 ; WX 556 ; N question ; B 184 0 630 738 ;
+C 64 ; WX 1015 ; N at ; B 80 -146 1036 737 ;
+C 65 ; WX 667 ; N A ; B 17 0 653 729 ;
+C 66 ; WX 667 ; N B ; B 79 0 711 729 ;
+C 67 ; WX 722 ; N C ; B 112 -23 770 741 ;
+C 68 ; WX 722 ; N D ; B 89 0 759 729 ;
+C 69 ; WX 667 ; N E ; B 90 0 751 729 ;
+C 70 ; WX 611 ; N F ; B 90 0 734 729 ;
+C 71 ; WX 778 ; N G ; B 109 -23 809 741 ;
+C 72 ; WX 722 ; N H ; B 83 0 799 729 ;
+C 73 ; WX 278 ; N I ; B 100 0 349 729 ;
+C 74 ; WX 500 ; N J ; B 47 -26 581 729 ;
+C 75 ; WX 667 ; N K ; B 79 0 813 729 ;
+C 76 ; WX 556 ; N L ; B 80 0 551 729 ;
+C 77 ; WX 833 ; N M ; B 75 0 916 729 ;
+C 78 ; WX 722 ; N N ; B 76 0 801 729 ;
+C 79 ; WX 778 ; N O ; B 104 -23 828 741 ;
+C 80 ; WX 667 ; N P ; B 91 0 733 730 ;
+C 81 ; WX 778 ; N Q ; B 104 -59 828 741 ;
+C 82 ; WX 722 ; N R ; B 93 0 770 729 ;
+C 83 ; WX 667 ; N S ; B 89 -23 714 741 ;
+C 84 ; WX 611 ; N T ; B 158 0 748 729 ;
+C 85 ; WX 722 ; N U ; B 124 -23 800 729 ;
+C 86 ; WX 667 ; N V ; B 185 0 800 729 ;
+C 87 ; WX 944 ; N W ; B 177 0 1084 729 ;
+C 88 ; WX 667 ; N X ; B 22 0 794 729 ;
+C 89 ; WX 667 ; N Y ; B 168 0 816 729 ;
+C 90 ; WX 611 ; N Z ; B 28 0 737 729 ;
+C 91 ; WX 278 ; N bracketleft ; B 19 -214 405 729 ;
+C 92 ; WX 278 ; N backslash ; B 147 -20 280 729 ;
+C 93 ; WX 278 ; N bracketright ; B -23 -215 364 729 ;
+C 94 ; WX 469 ; N asciicircum ; B 115 333 496 713 ;
+C 95 ; WX 556 ; N underscore ; B -59 -175 551 -125 ;
+C 96 ; WX 222 ; N quoteleft ; B 163 459 308 708 ;
+C 97 ; WX 556 ; N a ; B 65 -23 568 540 ;
+C 98 ; WX 556 ; N b ; B 54 -23 588 729 ;
+C 99 ; WX 500 ; N c ; B 76 -23 554 540 ;
+C 100 ; WX 556 ; N d ; B 73 -23 650 729 ;
+C 101 ; WX 556 ; N e ; B 84 -23 580 541 ;
+C 102 ; WX 278 ; N f ; B 89 0 413 733 ; L i fi ; L l fl ;
+C 103 ; WX 556 ; N g ; B 32 -220 601 540 ;
+C 104 ; WX 556 ; N h ; B 70 0 574 729 ;
+C 105 ; WX 222 ; N i ; B 66 0 305 729 ;
+C 106 ; WX 222 ; N j ; B -65 -220 308 729 ;
+C 107 ; WX 500 ; N k ; B 58 0 584 729 ;
+C 108 ; WX 222 ; N l ; B 68 0 307 729 ;
+C 109 ; WX 833 ; N m ; B 71 0 852 540 ;
+C 110 ; WX 556 ; N n ; B 70 0 574 540 ;
+C 111 ; WX 556 ; N o ; B 80 -23 576 540 ;
+C 112 ; WX 556 ; N p ; B 7 -219 586 540 ;
+C 113 ; WX 556 ; N q ; B 71 -219 607 540 ;
+C 114 ; WX 333 ; N r ; B 69 0 436 540 ;
+C 115 ; WX 500 ; N s ; B 61 -24 520 540 ;
+C 116 ; WX 278 ; N t ; B 97 -24 366 667 ;
+C 117 ; WX 556 ; N u ; B 88 -23 594 525 ;
+C 118 ; WX 500 ; N v ; B 122 0 598 525 ;
+C 119 ; WX 722 ; N w ; B 118 0 820 525 ;
+C 120 ; WX 500 ; N x ; B 17 0 583 525 ;
+C 121 ; WX 500 ; N y ; B 8 -219 590 525 ;
+C 122 ; WX 500 ; N z ; B 31 0 557 525 ;
+C 123 ; WX 334 ; N braceleft ; B 91 -214 431 731 ;
+C 124 ; WX 260 ; N bar ; B 54 -215 315 729 ;
+C 125 ; WX 334 ; N braceright ; B -16 -214 324 731 ;
+C 126 ; WX 584 ; N asciitilde ; B 137 267 594 438 ;
+C 161 ; WX 333 ; N exclamdown ; B 76 -214 317 525 ;
+C 162 ; WX 556 ; N cent ; B 96 -120 585 628 ;
+C 163 ; WX 556 ; N sterling ; B 44 -21 628 726 ;
+C 164 ; WX 167 ; N fraction ; B -178 -21 486 708 ;
+C 165 ; WX 556 ; N yen ; B 100 0 696 710 ;
+C 166 ; WX 556 ; N florin ; B -32 -214 696 742 ;
+C 167 ; WX 556 ; N section ; B 63 -215 589 729 ;
+C 168 ; WX 556 ; N currency ; B 110 126 593 554 ;
+C 169 ; WX 191 ; N quotesingle ; B 173 462 292 708 ;
+C 170 ; WX 333 ; N quotedblleft ; B 146 459 449 708 ;
+C 171 ; WX 556 ; N guillemotleft ; B 147 106 548 438 ;
+C 172 ; WX 333 ; N guilsinglleft ; B 140 112 336 436 ;
+C 173 ; WX 333 ; N guilsinglright ; B 109 112 307 436 ;
+C 174 ; WX 500 ; N fi ; B 83 0 591 733 ;
+C 175 ; WX 500 ; N fl ; B 88 0 585 733 ;
+C 177 ; WX 556 ; N endash ; B 46 240 628 313 ;
+C 178 ; WX 556 ; N dagger ; B 127 -178 620 710 ;
+C 179 ; WX 556 ; N daggerdbl ; B 51 -178 620 710 ;
+C 180 ; WX 278 ; N periodcentered ; B 166 318 293 442 ;
+C 182 ; WX 537 ; N paragraph ; B 145 -178 677 729 ;
+C 183 ; WX 350 ; N bullet ; B 120 220 376 470 ;
+C 184 ; WX 222 ; N quotesinglbase ; B 37 -129 180 103 ;
+C 185 ; WX 333 ; N quotedblbase ; B 20 -129 322 103 ;
+C 186 ; WX 333 ; N quotedblright ; B 150 476 452 708 ;
+C 187 ; WX 556 ; N guillemotright ; B 121 106 518 438 ;
+C 188 ; WX 1000 ; N ellipsis ; B 115 0 907 104 ;
+C 189 ; WX 1000 ; N perthousand ; B 93 -20 1024 740 ;
+C 191 ; WX 611 ; N questiondown ; B 86 -213 531 525 ;
+C 193 ; WX 333 ; N grave ; B 179 592 357 740 ;
+C 194 ; WX 333 ; N acute ; B 218 592 458 740 ;
+C 195 ; WX 333 ; N circumflex ; B 146 591 433 741 ;
+C 196 ; WX 333 ; N tilde ; B 130 589 471 716 ;
+C 197 ; WX 333 ; N macron ; B 160 621 450 694 ;
+C 198 ; WX 333 ; N breve ; B 165 594 471 729 ;
+C 199 ; WX 333 ; N dotaccent ; B 244 605 370 709 ;
+C 200 ; WX 333 ; N dieresis ; B 159 605 446 708 ;
+C 202 ; WX 333 ; N ring ; B 216 566 396 741 ;
+C 203 ; WX 333 ; N cedilla ; B 1 -214 264 0 ;
+C 205 ; WX 333 ; N hungarumlaut ; B 91 592 505 740 ;
+C 206 ; WX 333 ; N ogonek ; B 35 -189 246 15 ;
+C 207 ; WX 333 ; N caron ; B 176 590 463 740 ;
+C 208 ; WX 1000 ; N emdash ; B 42 240 1068 313 ;
+C 225 ; WX 1000 ; N AE ; B 11 0 1087 729 ;
+C 227 ; WX 370 ; N ordfeminine ; B 107 301 441 740 ;
+C 232 ; WX 556 ; N Lslash ; B 61 0 570 729 ;
+C 233 ; WX 778 ; N Oslash ; B 32 -23 867 742 ;
+C 234 ; WX 1000 ; N OE ; B 101 -20 1108 739 ;
+C 235 ; WX 365 ; N ordmasculine ; B 114 301 452 741 ;
+C 241 ; WX 889 ; N ae ; B 59 -20 915 546 ;
+C 245 ; WX 278 ; N dotlessi ; B 94 0 290 525 ;
+C 248 ; WX 222 ; N lslash ; B 62 0 312 729 ;
+C 249 ; WX 611 ; N oslash ; B 19 -27 639 548 ;
+C 250 ; WX 944 ; N oe ; B 85 -22 966 540 ;
+C 251 ; WX 611 ; N germandbls ; B 126 -20 655 729 ;
+C -1 ; WX 667 ; N Aacute ; B 17 0 667 939 ;
+C -1 ; WX 667 ; N Acircumflex ; B 17 0 653 940 ;
+C -1 ; WX 667 ; N Adieresis ; B 17 0 655 907 ;
+C -1 ; WX 667 ; N Agrave ; B 17 0 653 939 ;
+C -1 ; WX 667 ; N Aring ; B 17 0 653 940 ;
+C -1 ; WX 667 ; N Atilde ; B 17 0 680 915 ;
+C -1 ; WX 722 ; N Ccedilla ; B 112 -214 770 741 ;
+C -1 ; WX 667 ; N Eacute ; B 90 0 751 939 ;
+C -1 ; WX 667 ; N Ecircumflex ; B 90 0 751 940 ;
+C -1 ; WX 667 ; N Edieresis ; B 90 0 751 907 ;
+C -1 ; WX 667 ; N Egrave ; B 90 0 751 939 ;
+C -1 ; WX 722 ; N Eth ; B 73 0 759 729 ;
+C -1 ; WX 278 ; N Iacute ; B 100 0 479 939 ;
+C -1 ; WX 278 ; N Icircumflex ; B 100 0 454 940 ;
+C -1 ; WX 278 ; N Idieresis ; B 100 0 467 907 ;
+C -1 ; WX 278 ; N Igrave ; B 100 0 378 939 ;
+C -1 ; WX 722 ; N Ntilde ; B 76 0 801 915 ;
+C -1 ; WX 778 ; N Oacute ; B 104 -23 828 939 ;
+C -1 ; WX 778 ; N Ocircumflex ; B 104 -23 828 940 ;
+C -1 ; WX 778 ; N Odieresis ; B 104 -23 828 907 ;
+C -1 ; WX 778 ; N Ograve ; B 104 -23 828 939 ;
+C -1 ; WX 778 ; N Otilde ; B 104 -23 828 915 ;
+C -1 ; WX 667 ; N Scaron ; B 89 -23 714 939 ;
+C -1 ; WX 667 ; N Thorn ; B 91 0 707 729 ;
+C -1 ; WX 722 ; N Uacute ; B 124 -23 800 939 ;
+C -1 ; WX 722 ; N Ucircumflex ; B 124 -23 800 940 ;
+C -1 ; WX 722 ; N Udieresis ; B 124 -23 800 907 ;
+C -1 ; WX 722 ; N Ugrave ; B 124 -23 800 939 ;
+C -1 ; WX 667 ; N Yacute ; B 168 0 816 944 ;
+C -1 ; WX 667 ; N Ydieresis ; B 168 0 816 907 ;
+C -1 ; WX 611 ; N Zcaron ; B 28 0 737 939 ;
+C -1 ; WX 556 ; N aacute ; B 65 -23 570 740 ;
+C -1 ; WX 556 ; N acircumflex ; B 65 -23 568 741 ;
+C -1 ; WX 556 ; N adieresis ; B 65 -23 568 708 ;
+C -1 ; WX 556 ; N agrave ; B 65 -23 568 740 ;
+C -1 ; WX 556 ; N aring ; B 65 -23 568 741 ;
+C -1 ; WX 556 ; N atilde ; B 65 -23 583 716 ;
+C -1 ; WX 260 ; N brokenbar ; B 54 -215 315 729 ;
+C -1 ; WX 500 ; N ccedilla ; B 76 -214 554 540 ;
+C -1 ; WX 737 ; N copyright ; B 55 -23 836 741 ;
+C -1 ; WX 400 ; N degree ; B 165 409 472 709 ;
+C -1 ; WX 584 ; N divide ; B 92 -10 591 474 ;
+C -1 ; WX 556 ; N eacute ; B 84 -23 580 740 ;
+C -1 ; WX 556 ; N ecircumflex ; B 84 -23 580 741 ;
+C -1 ; WX 556 ; N edieresis ; B 84 -23 580 708 ;
+C -1 ; WX 556 ; N egrave ; B 84 -23 580 740 ;
+C -1 ; WX 556 ; N eth ; B 80 -23 572 729 ;
+C -1 ; WX 278 ; N iacute ; B 94 0 431 740 ;
+C -1 ; WX 278 ; N icircumflex ; B 94 0 406 741 ;
+C -1 ; WX 278 ; N idieresis ; B 94 0 419 708 ;
+C -1 ; WX 278 ; N igrave ; B 94 0 330 740 ;
+C -1 ; WX 584 ; N logicalnot ; B 99 82 619 352 ;
+C -1 ; WX 584 ; N minus ; B 81 194 601 270 ;
+C -1 ; WX 556 ; N mu ; B 18 -219 594 525 ;
+C -1 ; WX 584 ; N multiply ; B 59 -10 625 476 ;
+C -1 ; WX 556 ; N ntilde ; B 70 0 589 716 ;
+C -1 ; WX 556 ; N oacute ; B 80 -23 576 740 ;
+C -1 ; WX 556 ; N ocircumflex ; B 80 -23 576 741 ;
+C -1 ; WX 556 ; N odieresis ; B 80 -23 576 708 ;
+C -1 ; WX 556 ; N ograve ; B 80 -23 576 740 ;
+C -1 ; WX 834 ; N onehalf ; B 116 -21 869 709 ;
+C -1 ; WX 834 ; N onequarter ; B 147 -21 836 709 ;
+C -1 ; WX 333 ; N onesuperior ; B 184 284 370 709 ;
+C -1 ; WX 556 ; N otilde ; B 80 -23 583 716 ;
+C -1 ; WX 584 ; N plusminus ; B 40 0 621 618 ;
+C -1 ; WX 737 ; N registered ; B 55 -23 836 741 ;
+C -1 ; WX 500 ; N scaron ; B 61 -24 547 740 ;
+C -1 ; WX 556 ; N thorn ; B 7 -219 588 729 ;
+C -1 ; WX 834 ; N threequarters ; B 114 -21 868 709 ;
+C -1 ; WX 333 ; N threesuperior ; B 96 270 435 709 ;
+C -1 ; WX 1000 ; N trademark ; B 208 320 1096 741 ;
+C -1 ; WX 333 ; N twosuperior ; B 71 284 447 710 ;
+C -1 ; WX 556 ; N uacute ; B 88 -23 594 740 ;
+C -1 ; WX 556 ; N ucircumflex ; B 88 -23 594 741 ;
+C -1 ; WX 556 ; N udieresis ; B 88 -23 594 708 ;
+C -1 ; WX 556 ; N ugrave ; B 88 -23 594 740 ;
+C -1 ; WX 500 ; N yacute ; B 8 -219 590 740 ;
+C -1 ; WX 500 ; N ydieresis ; B 8 -219 590 708 ;
+C -1 ; WX 500 ; N zcaron ; B 31 0 557 740 ;
+EndCharMetrics
+StartKernData
+StartKernPairs 98
+
+KPX A y -9
+KPX A w -18
+KPX A v -18
+KPX A space -37
+KPX A quoteright -37
+KPX A Y -74
+KPX A W -18
+KPX A V -55
+KPX A T -74
+
+KPX F space -18
+KPX F period -129
+KPX F comma -129
+KPX F A -74
+
+KPX L y -18
+KPX L space -18
+KPX L quoteright -55
+KPX L Y -92
+KPX L W -37
+KPX L V -55
+KPX L T -74
+
+KPX P space -37
+KPX P period -129
+KPX P comma -129
+KPX P A -74
+
+KPX R Y -37
+KPX R W -18
+KPX R V -18
+KPX R T -18
+
+KPX T y -74
+KPX T w -74
+KPX T u -74
+KPX T semicolon -74
+KPX T s -92
+KPX T r -74
+KPX T period -92
+KPX T o -92
+KPX T i -9
+KPX T hyphen -92
+KPX T e -92
+KPX T comma -92
+KPX T colon -74
+KPX T c -92
+KPX T a -92
+KPX T O -18
+KPX T A -74
+
+KPX V y -18
+KPX V u -18
+KPX V semicolon -18
+KPX V r -18
+KPX V period -74
+KPX V o -37
+KPX V i -18
+KPX V hyphen -37
+KPX V e -37
+KPX V comma -74
+KPX V colon -18
+KPX V a -37
+KPX V A -55
+
+KPX W period -37
+KPX W i -9
+KPX W hyphen -18
+KPX W e -18
+KPX W comma -37
+KPX W a -18
+KPX W A -18
+
+KPX Y v -37
+KPX Y u -37
+KPX Y space -18
+KPX Y semicolon -37
+KPX Y q -55
+KPX Y period -92
+KPX Y p -55
+KPX Y o -55
+KPX Y i -18
+KPX Y hyphen -74
+KPX Y e -55
+KPX Y comma -92
+KPX Y colon -37
+KPX Y a -74
+KPX Y A -55
+
+KPX f quoteright 37
+
+KPX one one -74
+
+KPX quoteleft quoteleft -37
+
+KPX quoteright space -55
+KPX quoteright s -18
+KPX quoteright quoteright -37
+
+KPX r quoteright 37
+KPX r period -37
+KPX r hyphen -18
+KPX r comma -55
+
+KPX space Y -18
+KPX space A -37
+
+KPX v period -74
+KPX v comma -74
+
+KPX w period -55
+KPX w comma -55
+
+KPX y period -74
+KPX y comma -74
+EndKernPairs
+EndKernData
+StartComposites 58
+CC Zcaron 2 ; PCC Z 0 0 ; PCC caron 139 204 ;
+CC zcaron 2 ; PCC z 0 0 ; PCC caron 83 0 ;
+CC Scaron 2 ; PCC S 0 0 ; PCC caron 167 204 ;
+CC scaron 2 ; PCC s 0 0 ; PCC caron 83 0 ;
+CC Ccedilla 2 ; PCC C 0 0 ; PCC cedilla 194 0 ;
+CC ccedilla 2 ; PCC c 0 0 ; PCC cedilla 83 0 ;
+CC Yacute 2 ; PCC Y 0 0 ; PCC acute 167 204 ;
+CC yacute 2 ; PCC y 0 0 ; PCC acute 83 0 ;
+CC Ydieresis 2 ; PCC Y 0 0 ; PCC dieresis 167 204 ;
+CC ydieresis 2 ; PCC y 0 0 ; PCC dieresis 83 0 ;
+CC Uacute 2 ; PCC U 0 0 ; PCC acute 194 204 ;
+CC Ucircumflex 2 ; PCC U 0 0 ; PCC circumflex 194 204 ;
+CC Udieresis 2 ; PCC U 0 0 ; PCC dieresis 194 204 ;
+CC Ugrave 2 ; PCC U 0 0 ; PCC grave 194 204 ;
+CC uacute 2 ; PCC u 0 0 ; PCC acute 111 0 ;
+CC ucircumflex 2 ; PCC u 0 0 ; PCC circumflex 111 0 ;
+CC udieresis 2 ; PCC u 0 0 ; PCC dieresis 111 0 ;
+CC ugrave 2 ; PCC u 0 0 ; PCC grave 111 0 ;
+CC Iacute 2 ; PCC I 0 0 ; PCC acute -27 204 ;
+CC Icircumflex 2 ; PCC I 0 0 ; PCC circumflex -27 204 ;
+CC Idieresis 2 ; PCC I 0 0 ; PCC dieresis -27 204 ;
+CC Igrave 2 ; PCC I 0 0 ; PCC grave -27 204 ;
+CC iacute 2 ; PCC dotlessi 0 0 ; PCC acute -27 0 ;
+CC icircumflex 2 ; PCC dotlessi 0 0 ; PCC circumflex -27 0 ;
+CC idieresis 2 ; PCC dotlessi 0 0 ; PCC dieresis -27 0 ;
+CC igrave 2 ; PCC dotlessi 0 0 ; PCC grave -27 0 ;
+CC Eacute 2 ; PCC E 0 0 ; PCC acute 167 204 ;
+CC Ecircumflex 2 ; PCC E 0 0 ; PCC circumflex 167 204 ;
+CC Edieresis 2 ; PCC E 0 0 ; PCC dieresis 167 204 ;
+CC Egrave 2 ; PCC E 0 0 ; PCC grave 167 204 ;
+CC eacute 2 ; PCC e 0 0 ; PCC acute 111 0 ;
+CC ecircumflex 2 ; PCC e 0 0 ; PCC circumflex 111 0 ;
+CC edieresis 2 ; PCC e 0 0 ; PCC dieresis 111 0 ;
+CC egrave 2 ; PCC e 0 0 ; PCC grave 111 0 ;
+CC Aacute 2 ; PCC A 0 0 ; PCC acute 167 204 ;
+CC Acircumflex 2 ; PCC A 0 0 ; PCC circumflex 167 204 ;
+CC Adieresis 2 ; PCC A 0 0 ; PCC dieresis 167 204 ;
+CC Agrave 2 ; PCC A 0 0 ; PCC grave 167 204 ;
+CC aacute 2 ; PCC a 0 0 ; PCC acute 111 0 ;
+CC acircumflex 2 ; PCC a 0 0 ; PCC circumflex 111 0 ;
+CC adieresis 2 ; PCC a 0 0 ; PCC dieresis 111 0 ;
+CC agrave 2 ; PCC a 0 0 ; PCC grave 111 0 ;
+CC Oacute 2 ; PCC O 0 0 ; PCC acute 222 204 ;
+CC Ocircumflex 2 ; PCC O 0 0 ; PCC circumflex 222 204 ;
+CC Odieresis 2 ; PCC O 0 0 ; PCC dieresis 222 204 ;
+CC Ograve 2 ; PCC O 0 0 ; PCC grave 222 204 ;
+CC oacute 2 ; PCC o 0 0 ; PCC acute 111 0 ;
+CC ocircumflex 2 ; PCC o 0 0 ; PCC circumflex 111 0 ;
+CC odieresis 2 ; PCC o 0 0 ; PCC dieresis 111 0 ;
+CC ograve 2 ; PCC o 0 0 ; PCC grave 111 0 ;
+CC Atilde 2 ; PCC A 0 0 ; PCC tilde 167 204 ;
+CC atilde 2 ; PCC a 0 0 ; PCC tilde 111 0 ;
+CC Ntilde 2 ; PCC N 0 0 ; PCC tilde 194 204 ;
+CC ntilde 2 ; PCC n 0 0 ; PCC tilde 111 0 ;
+CC Otilde 2 ; PCC O 0 0 ; PCC tilde 222 204 ;
+CC otilde 2 ; PCC o 0 0 ; PCC tilde 111 0 ;
+CC Aring 2 ; PCC A 0 0 ; PCC ring 167 204 ;
+CC aring 2 ; PCC a 0 0 ; PCC ring 111 0 ;
+EndComposites
+EndFontMetrics
diff --git a/collects/afm/Helvetica.afm b/collects/afm/Helvetica.afm
new file mode 100644
index 0000000000..1c04802c0f
--- /dev/null
+++ b/collects/afm/Helvetica.afm
@@ -0,0 +1,437 @@
+StartFontMetrics 2.0
+Comment Copyright (c) 1984 Adobe Systems Incorporated. All Rights Reserved.
+Comment Creation Date:Sun Feb 8 18:48:01 PST 1987
+FontName Helvetica
+EncodingScheme AdobeStandardEncoding
+FullName Helvetica
+FamilyName Helvetica
+Weight Medium
+ItalicAngle 0.0
+IsFixedPitch false
+UnderlinePosition -97
+UnderlineThickness 73
+Version 001.002
+Notice Helvetica is a registered trademark of Allied Corporation.
+FontBBox -174 -220 1001 944
+CapHeight 729
+XHeight 525
+Descender -219
+Ascender 729
+StartCharMetrics 228
+C 32 ; WX 278 ; N space ; B 0 0 0 0 ;
+C 33 ; WX 278 ; N exclam ; B 124 0 208 729 ;
+C 34 ; WX 355 ; N quotedbl ; B 52 462 305 708 ;
+C 35 ; WX 556 ; N numbersign ; B 14 -20 542 698 ;
+C 36 ; WX 556 ; N dollar ; B 33 -125 518 770 ;
+C 37 ; WX 889 ; N percent ; B 29 -20 859 708 ;
+C 38 ; WX 667 ; N ampersand ; B 52 -23 637 710 ;
+C 39 ; WX 222 ; N quoteright ; B 64 476 158 708 ;
+C 40 ; WX 333 ; N parenleft ; B 73 -213 291 729 ;
+C 41 ; WX 333 ; N parenright ; B 38 -213 256 729 ;
+C 42 ; WX 389 ; N asterisk ; B 40 452 343 740 ;
+C 43 ; WX 584 ; N plus ; B 50 -10 534 474 ;
+C 44 ; WX 278 ; N comma ; B 87 -150 192 104 ;
+C 45 ; WX 333 ; N hyphen ; B 46 240 284 313 ;
+C 46 ; WX 278 ; N period ; B 87 0 191 104 ;
+C 47 ; WX 278 ; N slash ; B -8 -21 284 708 ;
+C 48 ; WX 556 ; N zero ; B 43 -23 507 709 ;
+C 49 ; WX 556 ; N one ; B 102 0 347 709 ;
+C 50 ; WX 556 ; N two ; B 34 0 511 710 ;
+C 51 ; WX 556 ; N three ; B 32 -23 506 709 ;
+C 52 ; WX 556 ; N four ; B 28 0 520 709 ;
+C 53 ; WX 556 ; N five ; B 35 -23 513 709 ;
+C 54 ; WX 556 ; N six ; B 43 -23 513 709 ;
+C 55 ; WX 556 ; N seven ; B 46 0 520 709 ;
+C 56 ; WX 556 ; N eight ; B 37 -23 513 709 ;
+C 57 ; WX 556 ; N nine ; B 38 -23 509 709 ;
+C 58 ; WX 278 ; N colon ; B 110 0 214 525 ;
+C 59 ; WX 278 ; N semicolon ; B 110 -150 215 516 ;
+C 60 ; WX 584 ; N less ; B 45 -10 534 474 ;
+C 61 ; WX 584 ; N equal ; B 50 112 534 352 ;
+C 62 ; WX 584 ; N greater ; B 50 -10 539 474 ;
+C 63 ; WX 556 ; N question ; B 77 0 509 738 ;
+C 64 ; WX 1015 ; N at ; B 34 -146 951 737 ;
+C 65 ; WX 667 ; N A ; B 17 0 653 729 ;
+C 66 ; WX 667 ; N B ; B 79 0 623 729 ;
+C 67 ; WX 722 ; N C ; B 48 -23 677 741 ;
+C 68 ; WX 722 ; N D ; B 89 0 667 729 ;
+C 69 ; WX 667 ; N E ; B 90 0 613 729 ;
+C 70 ; WX 611 ; N F ; B 90 0 579 729 ;
+C 71 ; WX 778 ; N G ; B 44 -23 709 741 ;
+C 72 ; WX 722 ; N H ; B 83 0 644 729 ;
+C 73 ; WX 278 ; N I ; B 100 0 194 729 ;
+C 74 ; WX 500 ; N J ; B 17 -26 426 729 ;
+C 75 ; WX 667 ; N K ; B 79 0 658 729 ;
+C 76 ; WX 556 ; N L ; B 80 0 533 729 ;
+C 77 ; WX 833 ; N M ; B 75 0 761 729 ;
+C 78 ; WX 722 ; N N ; B 76 0 646 729 ;
+C 79 ; WX 778 ; N O ; B 38 -23 742 741 ;
+C 80 ; WX 667 ; N P ; B 91 0 617 730 ;
+C 81 ; WX 778 ; N Q ; B 38 -59 742 741 ;
+C 82 ; WX 722 ; N R ; B 93 0 679 729 ;
+C 83 ; WX 667 ; N S ; B 48 -23 621 741 ;
+C 84 ; WX 611 ; N T ; B 21 0 593 729 ;
+C 85 ; WX 722 ; N U ; B 85 -23 645 729 ;
+C 86 ; WX 667 ; N V ; B 30 0 645 729 ;
+C 87 ; WX 944 ; N W ; B 22 0 929 729 ;
+C 88 ; WX 667 ; N X ; B 22 0 649 729 ;
+C 89 ; WX 667 ; N Y ; B 13 0 661 729 ;
+C 90 ; WX 611 ; N Z ; B 28 0 583 729 ;
+C 91 ; WX 278 ; N bracketleft ; B 64 -214 250 729 ;
+C 92 ; WX 278 ; N backslash ; B -8 -20 284 729 ;
+C 93 ; WX 278 ; N bracketright ; B 23 -215 209 729 ;
+C 94 ; WX 469 ; N asciicircum ; B 44 333 425 713 ;
+C 95 ; WX 556 ; N underscore ; B -22 -175 578 -125 ;
+C 96 ; WX 222 ; N quoteleft ; B 65 459 158 708 ;
+C 97 ; WX 556 ; N a ; B 42 -23 535 540 ;
+C 98 ; WX 556 ; N b ; B 54 -23 523 729 ;
+C 99 ; WX 500 ; N c ; B 31 -23 477 540 ;
+C 100 ; WX 556 ; N d ; B 26 -23 495 729 ;
+C 101 ; WX 556 ; N e ; B 40 -23 513 541 ;
+C 102 ; WX 278 ; N f ; B 18 0 258 733 ; L i fi ; L l fl ;
+C 103 ; WX 556 ; N g ; B 29 -220 489 540 ;
+C 104 ; WX 556 ; N h ; B 70 0 486 729 ;
+C 105 ; WX 222 ; N i ; B 66 0 150 729 ;
+C 106 ; WX 222 ; N j ; B -18 -220 153 729 ;
+C 107 ; WX 500 ; N k ; B 58 0 502 729 ;
+C 108 ; WX 222 ; N l ; B 68 0 152 729 ;
+C 109 ; WX 833 ; N m ; B 71 0 763 540 ;
+C 110 ; WX 556 ; N n ; B 70 0 487 540 ;
+C 111 ; WX 556 ; N o ; B 36 -23 510 540 ;
+C 112 ; WX 556 ; N p ; B 54 -219 523 540 ;
+C 113 ; WX 556 ; N q ; B 26 -219 495 540 ;
+C 114 ; WX 333 ; N r ; B 69 0 321 540 ;
+C 115 ; WX 500 ; N s ; B 34 -24 459 540 ;
+C 116 ; WX 278 ; N t ; B 14 -24 254 667 ;
+C 117 ; WX 556 ; N u ; B 65 -23 482 525 ;
+C 118 ; WX 500 ; N v ; B 10 0 486 525 ;
+C 119 ; WX 722 ; N w ; B 6 0 708 525 ;
+C 120 ; WX 500 ; N x ; B 17 0 473 525 ;
+C 121 ; WX 500 ; N y ; B 20 -219 478 525 ;
+C 122 ; WX 500 ; N z ; B 31 0 457 525 ;
+C 123 ; WX 334 ; N braceleft ; B 43 -214 276 731 ;
+C 124 ; WX 260 ; N bar ; B 100 -215 160 729 ;
+C 125 ; WX 334 ; N braceright ; B 29 -214 262 731 ;
+C 126 ; WX 584 ; N asciitilde ; B 75 267 508 438 ;
+C 161 ; WX 333 ; N exclamdown ; B 121 -214 205 525 ;
+C 162 ; WX 556 ; N cent ; B 52 -120 510 628 ;
+C 163 ; WX 556 ; N sterling ; B 26 -21 535 726 ;
+C 164 ; WX 167 ; N fraction ; B -174 -21 336 708 ;
+C 165 ; WX 556 ; N yen ; B 11 0 545 710 ;
+C 166 ; WX 556 ; N florin ; B 11 -214 542 742 ;
+C 167 ; WX 556 ; N section ; B 44 -215 506 729 ;
+C 168 ; WX 556 ; N currency ; B 67 126 489 554 ;
+C 169 ; WX 191 ; N quotesingle ; B 48 462 142 708 ;
+C 170 ; WX 333 ; N quotedblleft ; B 48 459 299 708 ;
+C 171 ; WX 556 ; N guillemotleft ; B 98 106 455 438 ;
+C 172 ; WX 333 ; N guilsinglleft ; B 91 112 243 436 ;
+C 173 ; WX 333 ; N guilsinglright ; B 85 112 239 436 ;
+C 174 ; WX 500 ; N fi ; B 12 0 436 733 ;
+C 175 ; WX 500 ; N fl ; B 17 0 430 733 ;
+C 177 ; WX 556 ; N endash ; B -5 240 561 313 ;
+C 178 ; WX 556 ; N dagger ; B 38 -178 513 710 ;
+C 179 ; WX 556 ; N daggerdbl ; B 38 -178 513 710 ;
+C 180 ; WX 278 ; N periodcentered ; B 87 318 211 442 ;
+C 182 ; WX 537 ; N paragraph ; B 48 -178 522 729 ;
+C 183 ; WX 350 ; N bullet ; B 50 220 300 470 ;
+C 184 ; WX 222 ; N quotesinglbase ; B 64 -129 158 103 ;
+C 185 ; WX 333 ; N quotedblbase ; B 47 -129 300 103 ;
+C 186 ; WX 333 ; N quotedblright ; B 49 476 302 708 ;
+C 187 ; WX 556 ; N guillemotright ; B 98 106 451 438 ;
+C 188 ; WX 1000 ; N ellipsis ; B 115 0 885 104 ;
+C 189 ; WX 1000 ; N perthousand ; B 9 -20 993 740 ;
+C 191 ; WX 611 ; N questiondown ; B 95 -213 528 525 ;
+C 193 ; WX 333 ; N grave ; B 22 592 231 740 ;
+C 194 ; WX 333 ; N acute ; B 92 592 301 740 ;
+C 195 ; WX 333 ; N circumflex ; B 20 591 307 741 ;
+C 196 ; WX 333 ; N tilde ; B 5 589 319 716 ;
+C 197 ; WX 333 ; N macron ; B 28 621 302 694 ;
+C 198 ; WX 333 ; N breve ; B 15 594 316 729 ;
+C 199 ; WX 333 ; N dotaccent ; B 115 605 219 709 ;
+C 200 ; WX 333 ; N dieresis ; B 30 605 296 708 ;
+C 202 ; WX 333 ; N ring ; B 79 566 255 741 ;
+C 203 ; WX 333 ; N cedilla ; B 39 -214 287 0 ;
+C 205 ; WX 333 ; N hungarumlaut ; B -35 592 348 740 ;
+C 206 ; WX 333 ; N ogonek ; B 57 -189 265 15 ;
+C 207 ; WX 333 ; N caron ; B 19 590 306 740 ;
+C 208 ; WX 1000 ; N emdash ; B -9 240 1001 313 ;
+C 225 ; WX 1000 ; N AE ; B 11 0 950 729 ;
+C 227 ; WX 370 ; N ordfeminine ; B 37 301 333 740 ;
+C 232 ; WX 556 ; N Lslash ; B 0 0 552 729 ;
+C 233 ; WX 778 ; N Oslash ; B 30 -23 744 742 ;
+C 234 ; WX 1000 ; N OE ; B 43 -20 959 739 ;
+C 235 ; WX 365 ; N ordmasculine ; B 40 301 324 741 ;
+C 241 ; WX 889 ; N ae ; B 34 -20 845 546 ;
+C 245 ; WX 278 ; N dotlessi ; B 94 0 178 525 ;
+C 248 ; WX 222 ; N lslash ; B 0 0 212 729 ;
+C 249 ; WX 611 ; N oslash ; B 18 -27 529 548 ;
+C 250 ; WX 944 ; N oe ; B 40 -22 899 540 ;
+C 251 ; WX 611 ; N germandbls ; B 126 -20 566 729 ;
+C -1 ; WX 667 ; N Aacute ; B 17 0 653 939 ;
+C -1 ; WX 667 ; N Acircumflex ; B 17 0 653 940 ;
+C -1 ; WX 667 ; N Adieresis ; B 17 0 653 907 ;
+C -1 ; WX 667 ; N Agrave ; B 17 0 653 939 ;
+C -1 ; WX 667 ; N Aring ; B 17 0 653 940 ;
+C -1 ; WX 667 ; N Atilde ; B 17 0 653 915 ;
+C -1 ; WX 722 ; N Ccedilla ; B 48 -214 677 741 ;
+C -1 ; WX 667 ; N Eacute ; B 90 0 613 939 ;
+C -1 ; WX 667 ; N Ecircumflex ; B 90 0 613 940 ;
+C -1 ; WX 667 ; N Edieresis ; B 90 0 613 907 ;
+C -1 ; WX 667 ; N Egrave ; B 90 0 613 939 ;
+C -1 ; WX 722 ; N Eth ; B 0 0 667 729 ;
+C -1 ; WX 278 ; N Iacute ; B 71 0 280 939 ;
+C -1 ; WX 278 ; N Icircumflex ; B -1 0 286 940 ;
+C -1 ; WX 278 ; N Idieresis ; B 9 0 275 907 ;
+C -1 ; WX 278 ; N Igrave ; B 1 0 210 939 ;
+C -1 ; WX 722 ; N Ntilde ; B 76 0 646 915 ;
+C -1 ; WX 778 ; N Oacute ; B 38 -23 742 939 ;
+C -1 ; WX 778 ; N Ocircumflex ; B 38 -23 742 940 ;
+C -1 ; WX 778 ; N Odieresis ; B 38 -23 742 907 ;
+C -1 ; WX 778 ; N Ograve ; B 38 -23 742 939 ;
+C -1 ; WX 778 ; N Otilde ; B 38 -23 742 915 ;
+C -1 ; WX 667 ; N Scaron ; B 48 -23 621 939 ;
+C -1 ; WX 667 ; N Thorn ; B 91 0 617 729 ;
+C -1 ; WX 722 ; N Uacute ; B 85 -23 645 939 ;
+C -1 ; WX 722 ; N Ucircumflex ; B 85 -23 645 940 ;
+C -1 ; WX 722 ; N Udieresis ; B 85 -23 645 907 ;
+C -1 ; WX 722 ; N Ugrave ; B 85 -23 645 939 ;
+C -1 ; WX 667 ; N Yacute ; B 13 0 661 944 ;
+C -1 ; WX 667 ; N Ydieresis ; B 13 0 661 907 ;
+C -1 ; WX 611 ; N Zcaron ; B 28 0 583 939 ;
+C -1 ; WX 556 ; N aacute ; B 42 -23 535 740 ;
+C -1 ; WX 556 ; N acircumflex ; B 42 -23 535 741 ;
+C -1 ; WX 556 ; N adieresis ; B 42 -23 535 708 ;
+C -1 ; WX 556 ; N agrave ; B 42 -23 535 740 ;
+C -1 ; WX 556 ; N aring ; B 42 -23 535 741 ;
+C -1 ; WX 556 ; N atilde ; B 42 -23 535 716 ;
+C -1 ; WX 260 ; N brokenbar ; B 100 -215 160 729 ;
+C -1 ; WX 500 ; N ccedilla ; B 31 -214 477 540 ;
+C -1 ; WX 737 ; N copyright ; B -13 -23 751 741 ;
+C -1 ; WX 400 ; N degree ; B 50 409 350 709 ;
+C -1 ; WX 584 ; N divide ; B 50 -10 534 474 ;
+C -1 ; WX 556 ; N eacute ; B 40 -23 513 740 ;
+C -1 ; WX 556 ; N ecircumflex ; B 40 -23 513 741 ;
+C -1 ; WX 556 ; N edieresis ; B 40 -23 513 708 ;
+C -1 ; WX 556 ; N egrave ; B 40 -23 513 740 ;
+C -1 ; WX 556 ; N eth ; B 36 -23 510 729 ;
+C -1 ; WX 278 ; N iacute ; B 65 0 274 740 ;
+C -1 ; WX 278 ; N icircumflex ; B -7 0 280 741 ;
+C -1 ; WX 278 ; N idieresis ; B 3 0 269 708 ;
+C -1 ; WX 278 ; N igrave ; B -5 0 204 740 ;
+C -1 ; WX 584 ; N logicalnot ; B 40 82 544 352 ;
+C -1 ; WX 584 ; N minus ; B 40 194 544 270 ;
+C -1 ; WX 556 ; N mu ; B 65 -219 482 525 ;
+C -1 ; WX 584 ; N multiply ; B 50 -10 534 476 ;
+C -1 ; WX 556 ; N ntilde ; B 70 0 487 716 ;
+C -1 ; WX 556 ; N oacute ; B 36 -23 510 740 ;
+C -1 ; WX 556 ; N ocircumflex ; B 36 -23 510 741 ;
+C -1 ; WX 556 ; N odieresis ; B 36 -23 510 708 ;
+C -1 ; WX 556 ; N ograve ; B 36 -23 510 740 ;
+C -1 ; WX 834 ; N onehalf ; B 30 -21 804 709 ;
+C -1 ; WX 834 ; N onequarter ; B 30 -21 804 709 ;
+C -1 ; WX 333 ; N onesuperior ; B 60 284 219 709 ;
+C -1 ; WX 556 ; N otilde ; B 36 -23 510 716 ;
+C -1 ; WX 584 ; N plusminus ; B 40 0 544 618 ;
+C -1 ; WX 737 ; N registered ; B -13 -23 751 741 ;
+C -1 ; WX 500 ; N scaron ; B 34 -24 459 740 ;
+C -1 ; WX 556 ; N thorn ; B 54 -219 523 729 ;
+C -1 ; WX 834 ; N threequarters ; B 30 -21 804 709 ;
+C -1 ; WX 333 ; N threesuperior ; B 12 270 320 709 ;
+C -1 ; WX 1000 ; N trademark ; B 63 320 938 741 ;
+C -1 ; WX 333 ; N twosuperior ; B 11 284 321 710 ;
+C -1 ; WX 556 ; N uacute ; B 65 -23 482 740 ;
+C -1 ; WX 556 ; N ucircumflex ; B 65 -23 482 741 ;
+C -1 ; WX 556 ; N udieresis ; B 65 -23 482 708 ;
+C -1 ; WX 556 ; N ugrave ; B 65 -23 482 740 ;
+C -1 ; WX 500 ; N yacute ; B 20 -219 478 740 ;
+C -1 ; WX 500 ; N ydieresis ; B 20 -219 478 708 ;
+C -1 ; WX 500 ; N zcaron ; B 31 0 457 740 ;
+EndCharMetrics
+StartKernData
+StartKernPairs 105
+
+KPX A y -18
+KPX A w -18
+KPX A v -18
+KPX A space -55
+KPX A quoteright -74
+KPX A Y -74
+KPX A W -37
+KPX A V -74
+KPX A T -74
+
+KPX F period -111
+KPX F comma -111
+KPX F A -55
+
+KPX L y -37
+KPX L space -37
+KPX L quoteright -55
+KPX L Y -74
+KPX L W -74
+KPX L V -74
+KPX L T -74
+
+KPX P space -18
+KPX P period -129
+KPX P comma -129
+KPX P A -74
+
+KPX R Y -18
+KPX R W -18
+KPX R V -18
+KPX R T -18
+
+KPX T y -55
+KPX T w -55
+KPX T u -37
+KPX T space -18
+KPX T semicolon -111
+KPX T s -111
+KPX T r -37
+KPX T period -111
+KPX T o -111
+KPX T i -37
+KPX T hyphen -55
+KPX T e -111
+KPX T comma -111
+KPX T colon -111
+KPX T c -111
+KPX T a -111
+KPX T O -18
+KPX T A -74
+
+KPX V y -37
+KPX V u -37
+KPX V semicolon -37
+KPX V r -37
+KPX V period -92
+KPX V o -55
+KPX V i -18
+KPX V hyphen -55
+KPX V e -55
+KPX V comma -92
+KPX V colon -37
+KPX V a -74
+KPX V A -74
+
+KPX W y -9
+KPX W u -18
+KPX W semicolon -18
+KPX W r -18
+KPX W period -55
+KPX W o -18
+KPX W i 0
+KPX W hyphen -18
+KPX W e -18
+KPX W comma -55
+KPX W colon -18
+KPX W a -37
+KPX W A -37
+
+KPX Y v -55
+KPX Y u -55
+KPX Y space -18
+KPX Y semicolon -65
+KPX Y q -92
+KPX Y period -129
+KPX Y p -74
+KPX Y o -92
+KPX Y i -37
+KPX Y hyphen -92
+KPX Y e -92
+KPX Y comma -129
+KPX Y colon -55
+KPX Y a -74
+KPX Y A -74
+
+KPX f quoteright 18
+KPX f f -18
+
+KPX one one -74
+
+KPX quoteleft quoteleft -18
+
+KPX quoteright space -37
+KPX quoteright s -18
+KPX quoteright quoteright -18
+
+KPX r quoteright 37
+KPX r period -55
+KPX r comma -55
+
+KPX space Y -18
+KPX space T -18
+KPX space A -55
+
+KPX v period -74
+KPX v comma -74
+
+KPX w period -55
+KPX w comma -55
+
+KPX y period -74
+KPX y comma -74
+EndKernPairs
+EndKernData
+StartComposites 58
+CC Zcaron 2 ; PCC Z 0 0 ; PCC caron 139 199 ;
+CC zcaron 2 ; PCC z 0 0 ; PCC caron 83 0 ;
+CC Scaron 2 ; PCC S 0 0 ; PCC caron 167 199 ;
+CC scaron 2 ; PCC s 0 0 ; PCC caron 83 0 ;
+CC Ccedilla 2 ; PCC C 0 0 ; PCC cedilla 207 0 ;
+CC ccedilla 2 ; PCC c 0 0 ; PCC cedilla 96 0 ;
+CC Yacute 2 ; PCC Y 0 0 ; PCC acute 167 204 ;
+CC yacute 2 ; PCC y 0 0 ; PCC acute 83 0 ;
+CC Ydieresis 2 ; PCC Y 0 0 ; PCC dieresis 167 199 ;
+CC ydieresis 2 ; PCC y 0 0 ; PCC dieresis 83 0 ;
+CC Uacute 2 ; PCC U 0 0 ; PCC acute 194 199 ;
+CC Ucircumflex 2 ; PCC U 0 0 ; PCC circumflex 194 199 ;
+CC Udieresis 2 ; PCC U 0 0 ; PCC dieresis 194 199 ;
+CC Ugrave 2 ; PCC U 0 0 ; PCC grave 194 199 ;
+CC uacute 2 ; PCC u 0 0 ; PCC acute 111 0 ;
+CC ucircumflex 2 ; PCC u 0 0 ; PCC circumflex 111 0 ;
+CC udieresis 2 ; PCC u 0 0 ; PCC dieresis 111 0 ;
+CC ugrave 2 ; PCC u 0 0 ; PCC grave 111 0 ;
+CC Iacute 2 ; PCC I 0 0 ; PCC acute -21 199 ;
+CC Icircumflex 2 ; PCC I 0 0 ; PCC circumflex -21 199 ;
+CC Idieresis 2 ; PCC I 0 0 ; PCC dieresis -21 199 ;
+CC Igrave 2 ; PCC I 0 0 ; PCC grave -21 199 ;
+CC iacute 2 ; PCC dotlessi 0 0 ; PCC acute -27 0 ;
+CC icircumflex 2 ; PCC dotlessi 0 0 ; PCC circumflex -27 0 ;
+CC idieresis 2 ; PCC dotlessi 0 0 ; PCC dieresis -27 0 ;
+CC igrave 2 ; PCC dotlessi 0 0 ; PCC grave -27 0 ;
+CC Eacute 2 ; PCC E 0 0 ; PCC acute 188 199 ;
+CC Ecircumflex 2 ; PCC E 0 0 ; PCC circumflex 188 199 ;
+CC Edieresis 2 ; PCC E 0 0 ; PCC dieresis 188 199 ;
+CC Egrave 2 ; PCC E 0 0 ; PCC grave 188 199 ;
+CC eacute 2 ; PCC e 0 0 ; PCC acute 117 0 ;
+CC ecircumflex 2 ; PCC e 0 0 ; PCC circumflex 117 0 ;
+CC edieresis 2 ; PCC e 0 0 ; PCC dieresis 117 0 ;
+CC egrave 2 ; PCC e 0 0 ; PCC grave 117 0 ;
+CC Aacute 2 ; PCC A 0 0 ; PCC acute 167 199 ;
+CC Acircumflex 2 ; PCC A 0 0 ; PCC circumflex 167 199 ;
+CC Adieresis 2 ; PCC A 0 0 ; PCC dieresis 167 199 ;
+CC Agrave 2 ; PCC A 0 0 ; PCC grave 167 199 ;
+CC aacute 2 ; PCC a 0 0 ; PCC acute 111 0 ;
+CC acircumflex 2 ; PCC a 0 0 ; PCC circumflex 111 0 ;
+CC adieresis 2 ; PCC a 0 0 ; PCC dieresis 111 0 ;
+CC agrave 2 ; PCC a 0 0 ; PCC grave 111 0 ;
+CC Oacute 2 ; PCC O 0 0 ; PCC acute 222 199 ;
+CC Ocircumflex 2 ; PCC O 0 0 ; PCC circumflex 222 199 ;
+CC Odieresis 2 ; PCC O 0 0 ; PCC dieresis 222 199 ;
+CC Ograve 2 ; PCC O 0 0 ; PCC grave 222 199 ;
+CC oacute 2 ; PCC o 0 0 ; PCC acute 111 0 ;
+CC ocircumflex 2 ; PCC o 0 0 ; PCC circumflex 111 0 ;
+CC odieresis 2 ; PCC o 0 0 ; PCC dieresis 111 0 ;
+CC ograve 2 ; PCC o 0 0 ; PCC grave 111 0 ;
+CC Atilde 2 ; PCC A 0 0 ; PCC tilde 167 199 ;
+CC atilde 2 ; PCC a 0 0 ; PCC tilde 111 0 ;
+CC Ntilde 2 ; PCC N 0 0 ; PCC tilde 200 199 ;
+CC ntilde 2 ; PCC n 0 0 ; PCC tilde 117 0 ;
+CC Otilde 2 ; PCC O 0 0 ; PCC tilde 222 199 ;
+CC otilde 2 ; PCC o 0 0 ; PCC tilde 111 0 ;
+CC Aring 2 ; PCC A 0 0 ; PCC ring 167 199 ;
+CC aring 2 ; PCC a 0 0 ; PCC ring 111 0 ;
+EndComposites
+EndFontMetrics
diff --git a/collects/afm/Symbol.afm b/collects/afm/Symbol.afm
new file mode 100644
index 0000000000..b2bd583a0b
--- /dev/null
+++ b/collects/afm/Symbol.afm
@@ -0,0 +1,211 @@
+StartFontMetrics 2.0
+Comment Matthew added a "mugreek" mapping (Nov 2004)
+Comment Copyright (c) 1985, 1987, 1989, 1990 Adobe Systems Incorporated.  All rights reserved.
+Comment Creation Date: Wed Jan 17 21:48:26 1990
+Comment UniqueID 27004
+Comment VMusage 28489 37622
+FontName Symbol
+FullName Symbol
+FamilyName Symbol
+Weight Medium
+ItalicAngle 0
+IsFixedPitch false
+FontBBox -180 -293 1090 1010
+UnderlinePosition -98
+UnderlineThickness 54
+Version 001.007
+Notice Copyright (c) 1985, 1987, 1989, 1990 Adobe Systems Incorporated.  All rights reserved.
+EncodingScheme FontSpecific
+StartCharMetrics 189
+C 32 ; WX 250 ; N space ; B 0 0 0 0 ;
+C 33 ; WX 333 ; N exclam ; B 128 -17 240 672 ;
+C 34 ; WX 713 ; N universal ; B 31 0 681 705 ;
+C 35 ; WX 500 ; N numbersign ; B 20 -16 481 673 ;
+C 36 ; WX 549 ; N existential ; B 25 0 478 707 ;
+C 37 ; WX 833 ; N percent ; B 63 -36 771 655 ;
+C 38 ; WX 778 ; N ampersand ; B 41 -18 750 661 ;
+C 39 ; WX 439 ; N suchthat ; B 48 -17 414 500 ;
+C 40 ; WX 333 ; N parenleft ; B 53 -191 300 673 ;
+C 41 ; WX 333 ; N parenright ; B 30 -191 277 673 ;
+C 42 ; WX 500 ; N asteriskmath ; B 65 134 427 551 ;
+C 43 ; WX 549 ; N plus ; B 10 0 539 533 ;
+C 44 ; WX 250 ; N comma ; B 56 -152 194 104 ;
+C 45 ; WX 549 ; N minus ; B 11 233 535 288 ;
+C 46 ; WX 250 ; N period ; B 69 -17 181 95 ;
+C 47 ; WX 278 ; N slash ; B 0 -18 254 646 ;
+C 48 ; WX 500 ; N zero ; B 23 -17 471 685 ;
+C 49 ; WX 500 ; N one ; B 117 0 390 673 ;
+C 50 ; WX 500 ; N two ; B 25 0 475 686 ;
+C 51 ; WX 500 ; N three ; B 39 -17 435 685 ;
+C 52 ; WX 500 ; N four ; B 16 0 469 685 ;
+C 53 ; WX 500 ; N five ; B 29 -17 443 685 ;
+C 54 ; WX 500 ; N six ; B 36 -17 467 685 ;
+C 55 ; WX 500 ; N seven ; B 24 -16 448 673 ;
+C 56 ; WX 500 ; N eight ; B 54 -18 440 685 ;
+C 57 ; WX 500 ; N nine ; B 31 -18 460 685 ;
+C 58 ; WX 278 ; N colon ; B 81 -17 193 460 ;
+C 59 ; WX 278 ; N semicolon ; B 83 -152 221 460 ;
+C 60 ; WX 549 ; N less ; B 26 0 523 522 ;
+C 61 ; WX 549 ; N equal ; B 11 141 537 390 ;
+C 62 ; WX 549 ; N greater ; B 26 0 523 522 ;
+C 63 ; WX 444 ; N question ; B 70 -17 412 686 ;
+C 64 ; WX 549 ; N congruent ; B 11 0 537 475 ;
+C 65 ; WX 722 ; N Alpha ; B 4 0 684 673 ;
+C 66 ; WX 667 ; N Beta ; B 29 0 592 673 ;
+C 67 ; WX 722 ; N Chi ; B -9 0 704 673 ;
+C 68 ; WX 612 ; N Delta ; B 6 0 608 688 ;
+C 69 ; WX 611 ; N Epsilon ; B 32 0 617 673 ;
+C 70 ; WX 763 ; N Phi ; B 26 0 741 673 ;
+C 71 ; WX 603 ; N Gamma ; B 24 0 609 673 ;
+C 72 ; WX 722 ; N Eta ; B 39 0 729 673 ;
+C 73 ; WX 333 ; N Iota ; B 32 0 316 673 ;
+C 74 ; WX 631 ; N theta1 ; B 18 -18 623 689 ;
+C 75 ; WX 722 ; N Kappa ; B 35 0 722 673 ;
+C 76 ; WX 686 ; N Lambda ; B 6 0 680 688 ;
+C 77 ; WX 889 ; N Mu ; B 28 0 887 673 ;
+C 78 ; WX 722 ; N Nu ; B 29 -8 720 673 ;
+C 79 ; WX 722 ; N Omicron ; B 41 -17 715 685 ;
+C 80 ; WX 768 ; N Pi ; B 25 0 745 673 ;
+C 81 ; WX 741 ; N Theta ; B 41 -17 715 685 ;
+C 82 ; WX 556 ; N Rho ; B 28 0 563 673 ;
+C 83 ; WX 592 ; N Sigma ; B 5 0 589 673 ;
+C 84 ; WX 611 ; N Tau ; B 33 0 607 673 ;
+C 85 ; WX 690 ; N Upsilon ; B -8 0 694 673 ;
+C 86 ; WX 439 ; N sigma1 ; B 40 -233 436 500 ;
+C 87 ; WX 768 ; N Omega ; B 34 0 736 688 ;
+C 88 ; WX 645 ; N Xi ; B 40 0 599 673 ;
+C 89 ; WX 795 ; N Psi ; B 15 0 781 684 ;
+C 90 ; WX 611 ; N Zeta ; B 44 0 636 673 ;
+C 91 ; WX 333 ; N bracketleft ; B 86 -155 299 674 ;
+C 92 ; WX 863 ; N therefore ; B 163 0 701 478 ;
+C 93 ; WX 333 ; N bracketright ; B 33 -155 246 674 ;
+C 94 ; WX 658 ; N perpendicular ; B 15 0 652 674 ;
+C 95 ; WX 500 ; N underscore ; B -2 -252 502 -206 ;
+C 96 ; WX 500 ; N radicalex ; B 480 881 1090 917 ;
+C 97 ; WX 631 ; N alpha ; B 41 -18 622 500 ;
+C 98 ; WX 549 ; N beta ; B 61 -223 515 741 ;
+C 99 ; WX 549 ; N chi ; B 12 -231 522 499 ;
+C 100 ; WX 494 ; N delta ; B 40 -19 481 740 ;
+C 101 ; WX 439 ; N epsilon ; B 22 -19 427 502 ;
+C 102 ; WX 521 ; N phi ; B 27 -224 490 671 ;
+C 103 ; WX 411 ; N gamma ; B 5 -225 484 499 ;
+C 104 ; WX 603 ; N eta ; B 0 -202 527 514 ;
+C 105 ; WX 329 ; N iota ; B 0 -17 301 503 ;
+C 106 ; WX 603 ; N phi1 ; B 36 -224 587 499 ;
+C 107 ; WX 549 ; N kappa ; B 33 0 558 501 ;
+C 108 ; WX 549 ; N lambda ; B 24 -17 548 739 ;
+C 109 ; WX 576 ; N mu ; B 33 -223 567 500 ;
+C 109 ; WX 576 ; N mugreek ; B 33 -223 567 500 ;
+C 110 ; WX 521 ; N nu ; B -9 -16 475 507 ;
+C 111 ; WX 549 ; N omicron ; B 35 -19 501 499 ;
+C 112 ; WX 549 ; N pi ; B 10 -19 530 487 ;
+C 113 ; WX 521 ; N theta ; B 43 -17 485 690 ;
+C 114 ; WX 549 ; N rho ; B 50 -230 490 499 ;
+C 115 ; WX 603 ; N sigma ; B 30 -21 588 500 ;
+C 116 ; WX 439 ; N tau ; B 10 -19 418 500 ;
+C 117 ; WX 576 ; N upsilon ; B 7 -18 535 507 ;
+C 118 ; WX 713 ; N omega1 ; B 12 -18 671 583 ;
+C 119 ; WX 686 ; N omega ; B 42 -17 684 500 ;
+C 120 ; WX 493 ; N xi ; B 27 -224 469 766 ;
+C 121 ; WX 686 ; N psi ; B 12 -228 701 500 ;
+C 122 ; WX 494 ; N zeta ; B 60 -225 467 756 ;
+C 123 ; WX 480 ; N braceleft ; B 58 -183 397 673 ;
+C 124 ; WX 200 ; N bar ; B 65 -177 135 673 ;
+C 125 ; WX 480 ; N braceright ; B 79 -183 418 673 ;
+C 126 ; WX 549 ; N similar ; B 17 203 529 307 ;
+C 161 ; WX 620 ; N Upsilon1 ; B -2 0 610 685 ;
+C 162 ; WX 247 ; N minute ; B 27 459 228 735 ;
+C 163 ; WX 549 ; N lessequal ; B 29 0 526 639 ;
+C 164 ; WX 167 ; N fraction ; B -180 -12 340 677 ;
+C 165 ; WX 713 ; N infinity ; B 26 124 688 404 ;
+C 166 ; WX 500 ; N florin ; B 2 -193 494 686 ;
+C 167 ; WX 753 ; N club ; B 86 -26 660 533 ;
+C 168 ; WX 753 ; N diamond ; B 142 -36 600 550 ;
+C 169 ; WX 753 ; N heart ; B 117 -33 631 532 ;
+C 170 ; WX 753 ; N spade ; B 113 -36 629 548 ;
+C 171 ; WX 1042 ; N arrowboth ; B 24 -15 1024 511 ;
+C 172 ; WX 987 ; N arrowleft ; B 32 -15 942 511 ;
+C 173 ; WX 603 ; N arrowup ; B 45 0 571 910 ;
+C 174 ; WX 987 ; N arrowright ; B 49 -15 959 511 ;
+C 175 ; WX 603 ; N arrowdown ; B 45 -22 571 888 ;
+C 176 ; WX 400 ; N degree ; B 50 385 350 685 ;
+C 177 ; WX 549 ; N plusminus ; B 10 0 539 645 ;
+C 178 ; WX 411 ; N second ; B 20 459 413 737 ;
+C 179 ; WX 549 ; N greaterequal ; B 29 0 526 639 ;
+C 180 ; WX 549 ; N multiply ; B 17 8 533 524 ;
+C 181 ; WX 713 ; N proportional ; B 27 123 639 404 ;
+C 182 ; WX 494 ; N partialdiff ; B 26 -20 462 746 ;
+C 183 ; WX 460 ; N bullet ; B 50 113 410 473 ;
+C 184 ; WX 549 ; N divide ; B 10 71 536 456 ;
+C 185 ; WX 549 ; N notequal ; B 15 -25 540 549 ;
+C 186 ; WX 549 ; N equivalence ; B 14 82 538 443 ;
+C 187 ; WX 549 ; N approxequal ; B 14 135 527 394 ;
+C 188 ; WX 1000 ; N ellipsis ; B 111 -17 889 95 ;
+C 189 ; WX 603 ; N arrowvertex ; B 280 -120 336 1010 ;
+C 190 ; WX 1000 ; N arrowhorizex ; B -60 220 1050 276 ;
+C 191 ; WX 658 ; N carriagereturn ; B 15 -16 602 629 ;
+C 192 ; WX 823 ; N aleph ; B 175 -18 661 658 ;
+C 193 ; WX 686 ; N Ifraktur ; B 10 -53 578 740 ;
+C 194 ; WX 795 ; N Rfraktur ; B 26 -15 759 734 ;
+C 195 ; WX 987 ; N weierstrass ; B 159 -211 870 573 ;
+C 196 ; WX 768 ; N circlemultiply ; B 43 -17 733 673 ;
+C 197 ; WX 768 ; N circleplus ; B 43 -15 733 675 ;
+C 198 ; WX 823 ; N emptyset ; B 39 -24 781 719 ;
+C 199 ; WX 768 ; N intersection ; B 40 0 732 509 ;
+C 200 ; WX 768 ; N union ; B 40 -17 732 492 ;
+C 201 ; WX 713 ; N propersuperset ; B 20 0 673 470 ;
+C 202 ; WX 713 ; N reflexsuperset ; B 20 -125 673 470 ;
+C 203 ; WX 713 ; N notsubset ; B 36 -70 690 540 ;
+C 204 ; WX 713 ; N propersubset ; B 37 0 690 470 ;
+C 205 ; WX 713 ; N reflexsubset ; B 37 -125 690 470 ;
+C 206 ; WX 713 ; N element ; B 45 0 505 468 ;
+C 207 ; WX 713 ; N notelement ; B 45 -58 505 555 ;
+C 208 ; WX 768 ; N angle ; B 26 0 738 673 ;
+C 209 ; WX 713 ; N gradient ; B 36 -19 681 718 ;
+C 210 ; WX 790 ; N registerserif ; B 50 -17 740 673 ;
+C 211 ; WX 790 ; N copyrightserif ; B 51 -15 741 675 ;
+C 212 ; WX 890 ; N trademarkserif ; B 18 293 855 673 ;
+C 213 ; WX 823 ; N product ; B 25 -101 803 751 ;
+C 214 ; WX 549 ; N radical ; B 10 -38 515 917 ;
+C 215 ; WX 250 ; N dotmath ; B 69 210 169 310 ;
+C 216 ; WX 713 ; N logicalnot ; B 15 0 680 288 ;
+C 217 ; WX 603 ; N logicaland ; B 23 0 583 454 ;
+C 218 ; WX 603 ; N logicalor ; B 30 0 578 477 ;
+C 219 ; WX 1042 ; N arrowdblboth ; B 27 -20 1023 510 ;
+C 220 ; WX 987 ; N arrowdblleft ; B 30 -15 939 513 ;
+C 221 ; WX 603 ; N arrowdblup ; B 39 2 567 911 ;
+C 222 ; WX 987 ; N arrowdblright ; B 45 -20 954 508 ;
+C 223 ; WX 603 ; N arrowdbldown ; B 44 -19 572 890 ;
+C 224 ; WX 494 ; N lozenge ; B 18 0 466 745 ;
+C 225 ; WX 329 ; N angleleft ; B 25 -198 306 746 ;
+C 226 ; WX 790 ; N registersans ; B 50 -20 740 670 ;
+C 227 ; WX 790 ; N copyrightsans ; B 49 -15 739 675 ;
+C 228 ; WX 786 ; N trademarksans ; B 5 293 725 673 ;
+C 229 ; WX 713 ; N summation ; B 14 -108 695 752 ;
+C 230 ; WX 384 ; N parenlefttp ; B 40 -293 436 926 ;
+C 231 ; WX 384 ; N parenleftex ; B 40 -85 92 925 ;
+C 232 ; WX 384 ; N parenleftbt ; B 40 -293 436 926 ;
+C 233 ; WX 384 ; N bracketlefttp ; B 0 -80 341 926 ;
+C 234 ; WX 384 ; N bracketleftex ; B 0 -79 55 925 ;
+C 235 ; WX 384 ; N bracketleftbt ; B 0 -80 340 926 ;
+C 236 ; WX 494 ; N bracelefttp ; B 201 -75 439 926 ;
+C 237 ; WX 494 ; N braceleftmid ; B 14 -85 255 935 ;
+C 238 ; WX 494 ; N braceleftbt ; B 201 -70 439 926 ;
+C 239 ; WX 494 ; N braceex ; B 201 -80 255 935 ;
+C 241 ; WX 329 ; N angleright ; B 21 -198 302 746 ;
+C 242 ; WX 274 ; N integral ; B 2 -107 291 916 ;
+C 243 ; WX 686 ; N integraltp ; B 332 -83 715 921 ;
+C 244 ; WX 686 ; N integralex ; B 332 -88 415 975 ;
+C 245 ; WX 686 ; N integralbt ; B 39 -81 415 921 ;
+C 246 ; WX 384 ; N parenrighttp ; B 54 -293 450 926 ;
+C 247 ; WX 384 ; N parenrightex ; B 398 -85 450 925 ;
+C 248 ; WX 384 ; N parenrightbt ; B 54 -293 450 926 ;
+C 249 ; WX 384 ; N bracketrighttp ; B 22 -80 360 926 ;
+C 250 ; WX 384 ; N bracketrightex ; B 305 -79 360 925 ;
+C 251 ; WX 384 ; N bracketrightbt ; B 20 -80 360 926 ;
+C 252 ; WX 494 ; N bracerighttp ; B 17 -75 255 926 ;
+C 253 ; WX 494 ; N bracerightmid ; B 201 -85 442 935 ;
+C 254 ; WX 494 ; N bracerightbt ; B 17 -70 255 926 ;
+C -1 ; WX 790 ; N apple ; B 56 -3 733 808 ;
+EndCharMetrics
+EndFontMetrics
diff --git a/collects/afm/Times-Bold.afm b/collects/afm/Times-Bold.afm
new file mode 100644
index 0000000000..73d79fff19
--- /dev/null
+++ b/collects/afm/Times-Bold.afm
@@ -0,0 +1,456 @@
+StartFontMetrics 2.0
+Comment Copyright (c) 1984 Adobe Systems Incorporated. All Rights Reserved.
+Comment Creation Date:Sun Feb 8 02:56:11 PST 1987
+FontName Times-Bold
+EncodingScheme AdobeStandardEncoding
+FullName Times Bold
+FamilyName Times
+Weight Bold
+ItalicAngle 0.0
+IsFixedPitch false
+UnderlinePosition -99
+UnderlineThickness 95
+Version 001.002
+Notice Times is a trademark of Allied Corporation.
+FontBBox -172 -256 1008 965
+CapHeight 681
+XHeight 460
+Descender -210
+Ascender 670
+StartCharMetrics 228
+C 32 ; WX 250 ; N space ; B 0 0 0 0 ;
+C 33 ; WX 333 ; N exclam ; B 84 -18 248 690 ;
+C 34 ; WX 555 ; N quotedbl ; B 67 371 425 690 ;
+C 35 ; WX 500 ; N numbersign ; B -13 -17 514 684 ;
+C 36 ; WX 500 ; N dollar ; B 28 -116 474 732 ;
+C 37 ; WX 1000 ; N percent ; B 122 -11 881 692 ;
+C 38 ; WX 833 ; N ampersand ; B 54 -17 773 690 ;
+C 39 ; WX 333 ; N quoteright ; B 77 347 257 680 ;
+C 40 ; WX 333 ; N parenleft ; B 49 -169 301 699 ;
+C 41 ; WX 333 ; N parenright ; B 26 -169 278 699 ;
+C 42 ; WX 500 ; N asterisk ; B 57 262 445 690 ;
+C 43 ; WX 570 ; N plus ; B 50 -10 520 460 ;
+C 44 ; WX 250 ; N comma ; B 37 -181 214 157 ;
+C 45 ; WX 333 ; N hyphen ; B 48 170 283 285 ;
+C 46 ; WX 250 ; N period ; B 43 -19 207 145 ;
+C 47 ; WX 278 ; N slash ; B 1 -17 279 750 ;
+C 48 ; WX 500 ; N zero ; B 26 -18 472 690 ;
+C 49 ; WX 500 ; N one ; B 61 0 448 690 ;
+C 50 ; WX 500 ; N two ; B 18 0 473 683 ;
+C 51 ; WX 500 ; N three ; B 17 -19 463 683 ;
+C 52 ; WX 500 ; N four ; B 23 0 472 681 ;
+C 53 ; WX 500 ; N five ; B 23 -17 465 681 ;
+C 54 ; WX 500 ; N six ; B 30 -18 470 684 ;
+C 55 ; WX 500 ; N seven ; B 23 0 468 679 ;
+C 56 ; WX 500 ; N eight ; B 22 -17 470 685 ;
+C 57 ; WX 500 ; N nine ; B 26 -18 468 684 ;
+C 58 ; WX 333 ; N colon ; B 83 -18 247 473 ;
+C 59 ; WX 333 ; N semicolon ; B 85 -181 262 472 ;
+C 60 ; WX 570 ; N less ; B 45 -10 520 460 ;
+C 61 ; WX 570 ; N equal ; B 50 91 520 375 ;
+C 62 ; WX 570 ; N greater ; B 50 -10 525 460 ;
+C 63 ; WX 500 ; N question ; B 57 -17 438 681 ;
+C 64 ; WX 930 ; N at ; B 50 -147 889 677 ;
+C 65 ; WX 722 ; N A ; B 22 0 696 681 ;
+C 66 ; WX 667 ; N B ; B 24 0 609 681 ;
+C 67 ; WX 722 ; N C ; B 42 -17 669 690 ;
+C 68 ; WX 722 ; N D ; B 22 0 684 681 ;
+C 69 ; WX 667 ; N E ; B 21 0 637 681 ;
+C 70 ; WX 611 ; N F ; B 17 0 582 681 ;
+C 71 ; WX 778 ; N G ; B 41 -17 748 690 ;
+C 72 ; WX 778 ; N H ; B 26 0 748 681 ;
+C 73 ; WX 389 ; N I ; B 17 0 366 680 ;
+C 74 ; WX 500 ; N J ; B 9 -89 475 681 ;
+C 75 ; WX 778 ; N K ; B 29 0 761 681 ;
+C 76 ; WX 667 ; N L ; B 21 0 633 681 ;
+C 77 ; WX 944 ; N M ; B 21 0 914 681 ;
+C 78 ; WX 722 ; N N ; B 20 -10 697 681 ;
+C 79 ; WX 778 ; N O ; B 43 -18 733 690 ;
+C 80 ; WX 611 ; N P ; B 24 0 593 681 ;
+C 81 ; WX 778 ; N Q ; B 24 -182 751 690 ;
+C 82 ; WX 722 ; N R ; B 26 0 695 681 ;
+C 83 ; WX 556 ; N S ; B 43 -19 506 690 ;
+C 84 ; WX 667 ; N T ; B 30 0 629 681 ;
+C 85 ; WX 722 ; N U ; B 20 -19 700 681 ;
+C 86 ; WX 722 ; N V ; B 22 -18 696 681 ;
+C 87 ; WX 1000 ; N W ; B 19 -18 979 680 ;
+C 88 ; WX 722 ; N X ; B 23 0 695 681 ;
+C 89 ; WX 722 ; N Y ; B 19 0 697 680 ;
+C 90 ; WX 667 ; N Z ; B 37 0 624 681 ;
+C 91 ; WX 333 ; N bracketleft ; B 73 -142 296 674 ;
+C 92 ; WX 278 ; N backslash ; B 1 -17 279 750 ;
+C 93 ; WX 333 ; N bracketright ; B 38 -142 261 674 ;
+C 94 ; WX 581 ; N asciicircum ; B 102 290 486 690 ;
+C 95 ; WX 500 ; N underscore ; B -2 -256 502 -182 ;
+C 96 ; WX 333 ; N quoteleft ; B 72 357 252 691 ;
+C 97 ; WX 500 ; N a ; B 25 -19 484 472 ;
+C 98 ; WX 556 ; N b ; B 29 -18 512 670 ;
+C 99 ; WX 444 ; N c ; B 24 -17 423 472 ;
+C 100 ; WX 556 ; N d ; B 31 -17 523 670 ;
+C 101 ; WX 444 ; N e ; B 25 -18 415 474 ;
+C 102 ; WX 333 ; N f ; B 20 0 386 690 ; L i fi ; L l fl ;
+C 103 ; WX 500 ; N g ; B 25 -210 474 472 ;
+C 104 ; WX 556 ; N h ; B 29 0 523 670 ;
+C 105 ; WX 278 ; N i ; B 27 0 249 690 ;
+C 106 ; WX 333 ; N j ; B -57 -212 256 690 ;
+C 107 ; WX 556 ; N k ; B 24 0 528 670 ;
+C 108 ; WX 278 ; N l ; B 25 0 247 670 ;
+C 109 ; WX 833 ; N m ; B 28 0 804 471 ;
+C 110 ; WX 556 ; N n ; B 28 0 523 473 ;
+C 111 ; WX 500 ; N o ; B 25 -18 473 472 ;
+C 112 ; WX 556 ; N p ; B 30 -210 513 473 ;
+C 113 ; WX 556 ; N q ; B 32 -210 535 472 ;
+C 114 ; WX 444 ; N r ; B 29 0 417 473 ;
+C 115 ; WX 389 ; N s ; B 29 -17 359 472 ;
+C 116 ; WX 333 ; N t ; B 22 -19 320 627 ;
+C 117 ; WX 556 ; N u ; B 23 -17 524 460 ;
+C 118 ; WX 500 ; N v ; B 20 -14 479 460 ;
+C 119 ; WX 722 ; N w ; B 10 -14 709 460 ;
+C 120 ; WX 500 ; N x ; B 11 0 488 460 ;
+C 121 ; WX 500 ; N y ; B 19 -212 475 460 ;
+C 122 ; WX 444 ; N z ; B 25 0 414 460 ;
+C 123 ; WX 394 ; N braceleft ; B 44 -142 342 674 ;
+C 124 ; WX 220 ; N bar ; B 77 -195 151 720 ;
+C 125 ; WX 394 ; N braceright ; B 38 -142 336 674 ;
+C 126 ; WX 520 ; N asciitilde ; B 19 237 493 461 ;
+C 161 ; WX 333 ; N exclamdown ; B 85 -210 249 498 ;
+C 162 ; WX 500 ; N cent ; B 44 -148 460 586 ;
+C 163 ; WX 500 ; N sterling ; B 25 -17 471 682 ;
+C 164 ; WX 167 ; N fraction ; B -172 -17 335 690 ;
+C 165 ; WX 500 ; N yen ; B -20 0 521 681 ;
+C 166 ; WX 500 ; N florin ; B 2 -157 496 713 ;
+C 167 ; WX 500 ; N section ; B 63 -148 438 677 ;
+C 168 ; WX 500 ; N currency ; B 3 105 498 604 ;
+C 169 ; WX 278 ; N quotesingle ; B 69 371 205 690 ;
+C 170 ; WX 500 ; N quotedblleft ; B 33 346 479 679 ;
+C 171 ; WX 500 ; N guillemotleft ; B 25 44 471 436 ;
+C 172 ; WX 333 ; N guilsinglleft ; B 51 44 302 436 ;
+C 173 ; WX 333 ; N guilsinglright ; B 26 44 277 436 ;
+C 174 ; WX 556 ; N fi ; B 24 0 532 690 ;
+C 175 ; WX 556 ; N fl ; B 25 0 529 691 ;
+C 177 ; WX 500 ; N endash ; B -4 179 500 270 ;
+C 178 ; WX 500 ; N dagger ; B 52 -141 446 690 ;
+C 179 ; WX 500 ; N daggerdbl ; B 57 -138 451 681 ;
+C 180 ; WX 250 ; N periodcentered ; B 43 270 167 394 ;
+C 182 ; WX 540 ; N paragraph ; B 30 -190 533 681 ;
+C 183 ; WX 350 ; N bullet ; B 50 175 300 425 ;
+C 184 ; WX 333 ; N quotesinglbase ; B 77 -179 257 154 ;
+C 185 ; WX 500 ; N quotedblbase ; B 31 -179 477 154 ;
+C 186 ; WX 500 ; N quotedblright ; B 31 347 477 680 ;
+C 187 ; WX 500 ; N guillemotright ; B 24 44 470 436 ;
+C 188 ; WX 1000 ; N ellipsis ; B 85 -18 915 146 ;
+C 189 ; WX 1000 ; N perthousand ; B 1 -55 993 718 ;
+C 191 ; WX 500 ; N questiondown ; B 56 -210 437 488 ;
+C 193 ; WX 333 ; N grave ; B 26 523 242 695 ;
+C 194 ; WX 333 ; N acute ; B 83 523 299 695 ;
+C 195 ; WX 333 ; N circumflex ; B 28 520 304 690 ;
+C 196 ; WX 333 ; N tilde ; B 34 559 298 671 ;
+C 197 ; WX 333 ; N macron ; B 34 543 297 600 ;
+C 198 ; WX 333 ; N breve ; B 32 529 300 667 ;
+C 199 ; WX 333 ; N dotaccent ; B 112 515 222 625 ;
+C 200 ; WX 333 ; N dieresis ; B 33 556 297 652 ;
+C 202 ; WX 333 ; N ring ; B 55 522 279 746 ;
+C 203 ; WX 333 ; N cedilla ; B 42 -211 293 -10 ;
+C 205 ; WX 333 ; N hungarumlaut ; B 32 539 320 753 ;
+C 206 ; WX 333 ; N ogonek ; B 60 -179 277 70 ;
+C 207 ; WX 333 ; N caron ; B 32 520 298 690 ;
+C 208 ; WX 1000 ; N emdash ; B -2 185 1008 280 ;
+C 225 ; WX 1000 ; N AE ; B 19 0 954 681 ;
+C 227 ; WX 300 ; N ordfeminine ; B 12 286 288 685 ;
+C 232 ; WX 667 ; N Lslash ; B 0 0 612 681 ;
+C 233 ; WX 778 ; N Oslash ; B 45 -75 735 740 ;
+C 234 ; WX 1000 ; N OE ; B 24 -7 979 683 ;
+C 235 ; WX 330 ; N ordmasculine ; B 31 286 299 685 ;
+C 241 ; WX 722 ; N ae ; B 30 -17 691 474 ;
+C 245 ; WX 278 ; N dotlessi ; B 28 0 250 460 ;
+C 248 ; WX 278 ; N lslash ; B 0 0 326 670 ;
+C 249 ; WX 500 ; N oslash ; B 27 -95 474 550 ;
+C 250 ; WX 722 ; N oe ; B 26 -17 689 473 ;
+C 251 ; WX 556 ; N germandbls ; B 22 -18 513 689 ;
+C -1 ; WX 722 ; N Aacute ; B 22 0 696 914 ;
+C -1 ; WX 722 ; N Acircumflex ; B 22 0 696 909 ;
+C -1 ; WX 722 ; N Adieresis ; B 22 0 696 871 ;
+C -1 ; WX 722 ; N Agrave ; B 22 0 696 914 ;
+C -1 ; WX 722 ; N Aring ; B 22 0 696 965 ;
+C -1 ; WX 722 ; N Atilde ; B 22 0 696 890 ;
+C -1 ; WX 722 ; N Ccedilla ; B 42 -211 669 690 ;
+C -1 ; WX 667 ; N Eacute ; B 21 0 637 914 ;
+C -1 ; WX 667 ; N Ecircumflex ; B 21 0 637 909 ;
+C -1 ; WX 667 ; N Edieresis ; B 21 0 637 871 ;
+C -1 ; WX 667 ; N Egrave ; B 21 0 637 914 ;
+C -1 ; WX 722 ; N Eth ; B 22 0 685 681 ;
+C -1 ; WX 389 ; N Iacute ; B 17 0 366 914 ;
+C -1 ; WX 389 ; N Icircumflex ; B 17 0 366 909 ;
+C -1 ; WX 389 ; N Idieresis ; B 17 0 366 871 ;
+C -1 ; WX 389 ; N Igrave ; B 17 0 366 914 ;
+C -1 ; WX 722 ; N Ntilde ; B 20 -10 697 890 ;
+C -1 ; WX 778 ; N Oacute ; B 43 -18 733 914 ;
+C -1 ; WX 778 ; N Ocircumflex ; B 43 -18 733 909 ;
+C -1 ; WX 778 ; N Odieresis ; B 43 -18 733 871 ;
+C -1 ; WX 778 ; N Ograve ; B 43 -18 733 914 ;
+C -1 ; WX 778 ; N Otilde ; B 43 -18 733 890 ;
+C -1 ; WX 556 ; N Scaron ; B 43 -19 506 909 ;
+C -1 ; WX 611 ; N Thorn ; B 24 0 594 681 ;
+C -1 ; WX 722 ; N Uacute ; B 20 -19 700 914 ;
+C -1 ; WX 722 ; N Ucircumflex ; B 20 -19 700 909 ;
+C -1 ; WX 722 ; N Udieresis ; B 20 -19 700 871 ;
+C -1 ; WX 722 ; N Ugrave ; B 20 -19 700 914 ;
+C -1 ; WX 722 ; N Yacute ; B 19 0 697 916 ;
+C -1 ; WX 722 ; N Ydieresis ; B 19 0 697 871 ;
+C -1 ; WX 667 ; N Zcaron ; B 37 0 624 909 ;
+C -1 ; WX 500 ; N aacute ; B 25 -19 484 695 ;
+C -1 ; WX 500 ; N acircumflex ; B 25 -19 484 690 ;
+C -1 ; WX 500 ; N adieresis ; B 25 -19 484 652 ;
+C -1 ; WX 500 ; N agrave ; B 25 -19 484 695 ;
+C -1 ; WX 500 ; N aring ; B 25 -19 484 746 ;
+C -1 ; WX 500 ; N atilde ; B 25 -19 484 671 ;
+C -1 ; WX 220 ; N brokenbar ; B 77 -195 151 720 ;
+C -1 ; WX 444 ; N ccedilla ; B 24 -211 423 472 ;
+C -1 ; WX 747 ; N copyright ; B 16 -17 730 690 ;
+C -1 ; WX 400 ; N degree ; B 50 390 350 690 ;
+C -1 ; WX 570 ; N divide ; B 50 -10 520 460 ;
+C -1 ; WX 444 ; N eacute ; B 25 -18 415 695 ;
+C -1 ; WX 444 ; N ecircumflex ; B 25 -18 415 690 ;
+C -1 ; WX 444 ; N edieresis ; B 25 -18 415 652 ;
+C -1 ; WX 444 ; N egrave ; B 25 -18 415 695 ;
+C -1 ; WX 500 ; N eth ; B 26 -17 474 670 ;
+C -1 ; WX 278 ; N iacute ; B 28 0 265 695 ;
+C -1 ; WX 278 ; N icircumflex ; B -6 0 270 690 ;
+C -1 ; WX 278 ; N idieresis ; B -1 0 263 652 ;
+C -1 ; WX 278 ; N igrave ; B -8 0 250 695 ;
+C -1 ; WX 570 ; N logicalnot ; B 50 94 520 375 ;
+C -1 ; WX 570 ; N minus ; B 50 188 520 262 ;
+C -1 ; WX 556 ; N mu ; B 23 -210 524 460 ;
+C -1 ; WX 570 ; N multiply ; B 50 -10 520 460 ;
+C -1 ; WX 556 ; N ntilde ; B 28 0 523 671 ;
+C -1 ; WX 500 ; N oacute ; B 25 -18 473 695 ;
+C -1 ; WX 500 ; N ocircumflex ; B 25 -18 473 690 ;
+C -1 ; WX 500 ; N odieresis ; B 25 -18 473 652 ;
+C -1 ; WX 500 ; N ograve ; B 25 -18 473 695 ;
+C -1 ; WX 750 ; N onehalf ; B 30 -18 720 690 ;
+C -1 ; WX 750 ; N onequarter ; B 30 -18 720 690 ;
+C -1 ; WX 300 ; N onesuperior ; B 24 276 275 690 ;
+C -1 ; WX 500 ; N otilde ; B 25 -18 473 671 ;
+C -1 ; WX 570 ; N plusminus ; B 50 0 520 600 ;
+C -1 ; WX 747 ; N registered ; B 16 -17 730 690 ;
+C -1 ; WX 389 ; N scaron ; B 29 -17 359 690 ;
+C -1 ; WX 556 ; N thorn ; B 30 -210 513 670 ;
+C -1 ; WX 750 ; N threequarters ; B 30 -18 720 690 ;
+C -1 ; WX 300 ; N threesuperior ; B 5 269 294 690 ;
+C -1 ; WX 1000 ; N trademark ; B 30 277 970 681 ;
+C -1 ; WX 300 ; N twosuperior ; B 2 276 298 686 ;
+C -1 ; WX 556 ; N uacute ; B 23 -17 524 695 ;
+C -1 ; WX 556 ; N ucircumflex ; B 23 -17 524 690 ;
+C -1 ; WX 556 ; N udieresis ; B 23 -17 524 652 ;
+C -1 ; WX 556 ; N ugrave ; B 23 -17 524 695 ;
+C -1 ; WX 500 ; N yacute ; B 19 -212 475 695 ;
+C -1 ; WX 500 ; N ydieresis ; B 19 -212 475 652 ;
+C -1 ; WX 444 ; N zcaron ; B 25 0 414 690 ;
+EndCharMetrics
+StartKernData
+StartKernPairs 124
+
+KPX A y -74
+KPX A w -74
+KPX A v -74
+KPX A space -55
+KPX A quoteright -74
+KPX A Y -92
+KPX A W -111
+KPX A V -129
+KPX A T -74
+
+KPX F space -37
+KPX F period -92
+KPX F comma -92
+KPX F A -74
+
+KPX L y -55
+KPX L space -55
+KPX L quoteright -92
+KPX L Y -92
+KPX L W -92
+KPX L V -92
+KPX L T -92
+
+KPX P space -55
+KPX P period -92
+KPX P comma -92
+KPX P A -74
+
+KPX R y -35
+KPX R Y -35
+KPX R W -35
+KPX R V -35
+KPX R T -35
+
+KPX T y -74
+KPX T w -74
+KPX T u -92
+KPX T space -18
+KPX T semicolon -74
+KPX T s -92
+KPX T r -74
+KPX T period -74
+KPX T o -92
+KPX T i -18
+KPX T hyphen -92
+KPX T e -92
+KPX T comma -74
+KPX T colon -74
+KPX T c -92
+KPX T a -92
+KPX T O -18
+KPX T A -74
+
+KPX V y -92
+KPX V u -92
+KPX V space -18
+KPX V semicolon -92
+KPX V r -74
+KPX V period -129
+KPX V o -92
+KPX V i -37
+KPX V hyphen -74
+KPX V e -92
+KPX V comma -129
+KPX V colon -92
+KPX V a -92
+KPX V O -20
+KPX V A -129
+
+KPX W y -37
+KPX W u -18
+KPX W space -18
+KPX W semicolon -55
+KPX W r -18
+KPX W period -92
+KPX W o -55
+KPX W i -18
+KPX W hyphen -37
+KPX W e -55
+KPX W comma -92
+KPX W colon -55
+KPX W a -55
+KPX W A -111
+
+KPX Y v -111
+KPX Y u -92
+KPX Y space -37
+KPX Y semicolon -92
+KPX Y q -111
+KPX Y period -92
+KPX Y p -92
+KPX Y o -111
+KPX Y i -37
+KPX Y hyphen -92
+KPX Y e -111
+KPX Y comma -92
+KPX Y colon -92
+KPX Y a -111
+KPX Y A -92
+
+KPX f quoteright 55
+KPX f f 0
+
+KPX one one -55
+
+KPX quoteleft quoteleft -74
+
+KPX quoteright space -74
+KPX quoteright s -37
+KPX quoteright quoteright -74
+
+KPX r z 0
+KPX r y 0
+KPX r x 0
+KPX r w 0
+KPX r t 0
+KPX r space -18
+KPX r quoteright 18
+KPX r q -18
+KPX r period -92
+KPX r o -18
+KPX r hyphen -37
+KPX r h 0
+KPX r e -18
+KPX r comma -92
+KPX r c -18
+
+KPX space Y -37
+KPX space W -18
+KPX space V -18
+KPX space T -18
+KPX space A -55
+
+KPX v period -55
+KPX v comma -55
+
+KPX w period -55
+KPX w comma -55
+
+KPX y period -55
+KPX y comma -55
+EndKernPairs
+EndKernData
+StartComposites 58
+CC Zcaron 2 ; PCC Z 0 0 ; PCC caron 167 219 ;
+CC zcaron 2 ; PCC z 0 0 ; PCC caron 55 0 ;
+CC Scaron 2 ; PCC S 0 0 ; PCC caron 111 219 ;
+CC scaron 2 ; PCC s 0 0 ; PCC caron 28 0 ;
+CC Ccedilla 2 ; PCC C 0 0 ; PCC cedilla 207 0 ;
+CC ccedilla 2 ; PCC c 0 0 ; PCC cedilla 68 0 ;
+CC Yacute 2 ; PCC Y 0 0 ; PCC acute 194 221 ;
+CC yacute 2 ; PCC y 0 0 ; PCC acute 83 0 ;
+CC Ydieresis 2 ; PCC Y 0 0 ; PCC dieresis 194 219 ;
+CC ydieresis 2 ; PCC y 0 0 ; PCC dieresis 83 0 ;
+CC Uacute 2 ; PCC U 0 0 ; PCC acute 221 219 ;
+CC Ucircumflex 2 ; PCC U 0 0 ; PCC circumflex 221 219 ;
+CC Udieresis 2 ; PCC U 0 0 ; PCC dieresis 221 219 ;
+CC Ugrave 2 ; PCC U 0 0 ; PCC grave 221 219 ;
+CC uacute 2 ; PCC u 0 0 ; PCC acute 104 0 ;
+CC ucircumflex 2 ; PCC u 0 0 ; PCC circumflex 104 0 ;
+CC udieresis 2 ; PCC u 0 0 ; PCC dieresis 104 0 ;
+CC ugrave 2 ; PCC u 0 0 ; PCC grave 104 0 ;
+CC Iacute 2 ; PCC I 0 0 ; PCC acute 28 219 ;
+CC Icircumflex 2 ; PCC I 0 0 ; PCC circumflex 28 219 ;
+CC Idieresis 2 ; PCC I 0 0 ; PCC dieresis 28 219 ;
+CC Igrave 2 ; PCC I 0 0 ; PCC grave 28 219 ;
+CC iacute 2 ; PCC dotlessi 0 0 ; PCC acute -34 0 ;
+CC icircumflex 2 ; PCC dotlessi 0 0 ; PCC circumflex -34 0 ;
+CC idieresis 2 ; PCC dotlessi 0 0 ; PCC dieresis -34 0 ;
+CC igrave 2 ; PCC dotlessi 0 0 ; PCC grave -34 0 ;
+CC Eacute 2 ; PCC E 0 0 ; PCC acute 174 219 ;
+CC Ecircumflex 2 ; PCC E 0 0 ; PCC circumflex 174 219 ;
+CC Edieresis 2 ; PCC E 0 0 ; PCC dieresis 174 219 ;
+CC Egrave 2 ; PCC E 0 0 ; PCC grave 174 219 ;
+CC eacute 2 ; PCC e 0 0 ; PCC acute 61 0 ;
+CC ecircumflex 2 ; PCC e 0 0 ; PCC circumflex 61 0 ;
+CC edieresis 2 ; PCC e 0 0 ; PCC dieresis 61 0 ;
+CC egrave 2 ; PCC e 0 0 ; PCC grave 61 0 ;
+CC Aacute 2 ; PCC A 0 0 ; PCC acute 187 219 ;
+CC Acircumflex 2 ; PCC A 0 0 ; PCC circumflex 187 219 ;
+CC Adieresis 2 ; PCC A 0 0 ; PCC dieresis 187 219 ;
+CC Agrave 2 ; PCC A 0 0 ; PCC grave 187 219 ;
+CC aacute 2 ; PCC a 0 0 ; PCC acute 76 0 ;
+CC acircumflex 2 ; PCC a 0 0 ; PCC circumflex 76 0 ;
+CC adieresis 2 ; PCC a 0 0 ; PCC dieresis 76 0 ;
+CC agrave 2 ; PCC a 0 0 ; PCC grave 76 0 ;
+CC Oacute 2 ; PCC O 0 0 ; PCC acute 222 219 ;
+CC Ocircumflex 2 ; PCC O 0 0 ; PCC circumflex 222 219 ;
+CC Odieresis 2 ; PCC O 0 0 ; PCC dieresis 222 219 ;
+CC Ograve 2 ; PCC O 0 0 ; PCC grave 222 219 ;
+CC oacute 2 ; PCC o 0 0 ; PCC acute 83 0 ;
+CC ocircumflex 2 ; PCC o 0 0 ; PCC circumflex 83 0 ;
+CC odieresis 2 ; PCC o 0 0 ; PCC dieresis 83 0 ;
+CC ograve 2 ; PCC o 0 0 ; PCC grave 83 0 ;
+CC Atilde 2 ; PCC A 0 0 ; PCC tilde 187 219 ;
+CC atilde 2 ; PCC a 0 0 ; PCC tilde 76 0 ;
+CC Ntilde 2 ; PCC N 0 0 ; PCC tilde 194 219 ;
+CC ntilde 2 ; PCC n 0 0 ; PCC tilde 111 0 ;
+CC Otilde 2 ; PCC O 0 0 ; PCC tilde 222 219 ;
+CC otilde 2 ; PCC o 0 0 ; PCC tilde 83 0 ;
+CC Aring 2 ; PCC A 0 0 ; PCC ring 187 219 ;
+CC aring 2 ; PCC a 0 0 ; PCC ring 76 0 ;
+EndComposites
+EndFontMetrics
diff --git a/collects/afm/Times-BoldItalic.afm b/collects/afm/Times-BoldItalic.afm
new file mode 100644
index 0000000000..51966146d6
--- /dev/null
+++ b/collects/afm/Times-BoldItalic.afm
@@ -0,0 +1,440 @@
+StartFontMetrics 2.0
+Comment Copyright (c) 1984 Adobe Systems Incorporated. All Rights Reserved.
+Comment Creation Date:Wed Apr 15 14:01:19 PST 1987
+FontName Times-BoldItalic
+EncodingScheme AdobeStandardEncoding
+FullName Times Bold Italic
+FamilyName Bold Italic
+Weight Bold
+ItalicAngle -15.0
+IsFixedPitch false
+UnderlinePosition -98
+UnderlineThickness 54
+Version 001.003
+Notice Times is a trademark of Allied Corporation.
+FontBBox -168 -232 1014 894
+CapHeight 662
+XHeight 458
+Descender -203
+Ascender 682
+StartCharMetrics 228
+C 32 ; WX 250 ; N space ; B 0 0 0 0 ;
+C 33 ; WX 389 ; N exclam ; B 66 -13 367 676 ;
+C 34 ; WX 555 ; N quotedbl ; B 142 367 549 693 ;
+C 35 ; WX 500 ; N numbersign ; B 4 0 496 662 ;
+C 36 ; WX 500 ; N dollar ; B -20 -101 492 723 ;
+C 37 ; WX 833 ; N percent ; B 39 -8 784 685 ;
+C 38 ; WX 778 ; N ampersand ; B 41 -19 727 676 ;
+C 39 ; WX 333 ; N quoteright ; B 80 362 282 675 ;
+C 40 ; WX 333 ; N parenleft ; B 28 -179 340 676 ;
+C 41 ; WX 333 ; N parenright ; B -44 -179 268 676 ;
+C 42 ; WX 500 ; N asterisk ; B 56 244 445 676 ;
+C 43 ; WX 570 ; N plus ; B 33 0 537 505 ;
+C 44 ; WX 250 ; N comma ; B -10 -181 192 132 ;
+C 45 ; WX 333 ; N hyphen ; B 33 167 299 282 ;
+C 46 ; WX 250 ; N period ; B 23 -13 170 133 ;
+C 47 ; WX 278 ; N slash ; B -11 -18 289 682 ;
+C 48 ; WX 500 ; N zero ; B 17 -13 472 676 ;
+C 49 ; WX 500 ; N one ; B 5 0 415 676 ;
+C 50 ; WX 500 ; N two ; B -27 0 441 676 ;
+C 51 ; WX 500 ; N three ; B -15 -13 445 676 ;
+C 52 ; WX 500 ; N four ; B -15 0 498 676 ;
+C 53 ; WX 500 ; N five ; B -11 -13 482 662 ;
+C 54 ; WX 500 ; N six ; B 23 -13 504 676 ;
+C 55 ; WX 500 ; N seven ; B 51 0 519 662 ;
+C 56 ; WX 500 ; N eight ; B 3 -13 471 676 ;
+C 57 ; WX 500 ; N nine ; B -12 -13 470 676 ;
+C 58 ; WX 333 ; N colon ; B 52 -13 291 458 ;
+C 59 ; WX 333 ; N semicolon ; B 13 -181 291 458 ;
+C 60 ; WX 570 ; N less ; B 31 -14 540 524 ;
+C 61 ; WX 570 ; N equal ; B 33 116 537 401 ;
+C 62 ; WX 570 ; N greater ; B 31 -14 540 524 ;
+C 63 ; WX 500 ; N question ; B 78 -13 465 676 ;
+C 64 ; WX 832 ; N at ; B -9 -150 838 691 ;
+C 65 ; WX 667 ; N A ; B -51 0 602 676 ;
+C 66 ; WX 667 ; N B ; B -24 0 618 662 ;
+C 67 ; WX 667 ; N C ; B 22 -18 660 677 ;
+C 68 ; WX 722 ; N D ; B -31 0 693 662 ;
+C 69 ; WX 667 ; N E ; B -27 0 646 662 ;
+C 70 ; WX 667 ; N F ; B -20 0 646 662 ;
+C 71 ; WX 722 ; N G ; B 21 -18 699 676 ;
+C 72 ; WX 778 ; N H ; B -24 0 791 662 ;
+C 73 ; WX 389 ; N I ; B -22 0 412 662 ;
+C 74 ; WX 500 ; N J ; B -45 -98 519 662 ;
+C 75 ; WX 667 ; N K ; B -31 0 685 662 ;
+C 76 ; WX 611 ; N L ; B -22 0 584 662 ;
+C 77 ; WX 889 ; N M ; B -29 -12 907 662 ;
+C 78 ; WX 722 ; N N ; B -27 -18 740 662 ;
+C 79 ; WX 722 ; N O ; B 27 -18 684 676 ;
+C 80 ; WX 611 ; N P ; B -27 0 608 662 ;
+C 81 ; WX 722 ; N Q ; B 27 -203 684 676 ;
+C 82 ; WX 667 ; N R ; B -29 0 616 662 ;
+C 83 ; WX 556 ; N S ; B 6 -18 524 676 ;
+C 84 ; WX 611 ; N T ; B 39 0 632 662 ;
+C 85 ; WX 722 ; N U ; B 66 -18 736 662 ;
+C 86 ; WX 667 ; N V ; B 48 -18 692 662 ;
+C 87 ; WX 889 ; N W ; B 48 -18 914 662 ;
+C 88 ; WX 667 ; N X ; B -24 0 687 662 ;
+C 89 ; WX 611 ; N Y ; B 46 0 625 662 ;
+C 90 ; WX 611 ; N Z ; B -1 0 594 662 ;
+C 91 ; WX 333 ; N bracketleft ; B -7 -157 388 682 ;
+C 92 ; WX 278 ; N backslash ; B 1 0 465 682 ;
+C 93 ; WX 333 ; N bracketright ; B -65 -157 330 682 ;
+C 94 ; WX 570 ; N asciicircum ; B 34 259 536 662 ;
+C 95 ; WX 500 ; N underscore ; B 0 -127 500 -89 ;
+C 96 ; WX 333 ; N quoteleft ; B 117 363 319 676 ;
+C 97 ; WX 500 ; N a ; B 9 -14 480 458 ;
+C 98 ; WX 500 ; N b ; B 21 -13 474 682 ;
+C 99 ; WX 444 ; N c ; B 25 -13 418 458 ;
+C 100 ; WX 500 ; N d ; B 9 -13 541 682 ;
+C 101 ; WX 444 ; N e ; B 25 -13 413 458 ;
+C 102 ; WX 333 ; N f ; B -146 -203 460 682 ; L i fi ; L l fl ;
+C 103 ; WX 500 ; N g ; B -27 -203 498 458 ;
+C 104 ; WX 556 ; N h ; B 12 -13 518 682 ;
+C 105 ; WX 278 ; N i ; B 25 -13 284 676 ;
+C 106 ; WX 278 ; N j ; B -152 -203 311 676 ;
+C 107 ; WX 500 ; N k ; B 10 -13 511 682 ;
+C 108 ; WX 278 ; N l ; B 31 -13 312 682 ;
+C 109 ; WX 778 ; N m ; B 16 -13 744 458 ;
+C 110 ; WX 556 ; N n ; B 24 -13 518 458 ;
+C 111 ; WX 500 ; N o ; B 27 -13 467 458 ;
+C 112 ; WX 500 ; N p ; B -79 -203 481 458 ;
+C 113 ; WX 500 ; N q ; B 21 -203 486 459 ;
+C 114 ; WX 389 ; N r ; B 9 0 415 458 ;
+C 115 ; WX 389 ; N s ; B 16 -13 364 459 ;
+C 116 ; WX 278 ; N t ; B 16 -14 305 592 ;
+C 117 ; WX 556 ; N u ; B 48 -13 521 458 ;
+C 118 ; WX 444 ; N v ; B 50 -13 432 458 ;
+C 119 ; WX 667 ; N w ; B 50 -13 642 458 ;
+C 120 ; WX 500 ; N x ; B -5 -13 498 458 ;
+C 121 ; WX 444 ; N y ; B -60 -203 423 458 ;
+C 122 ; WX 389 ; N z ; B -24 -58 394 448 ;
+C 123 ; WX 348 ; N braceleft ; B 31 -154 381 686 ;
+C 124 ; WX 220 ; N bar ; B 70 0 151 682 ;
+C 125 ; WX 348 ; N braceright ; B -31 -161 319 679 ;
+C 126 ; WX 570 ; N asciitilde ; B 33 158 537 353 ;
+C 161 ; WX 389 ; N exclamdown ; B 21 -232 321 458 ;
+C 162 ; WX 500 ; N cent ; B 50 -142 443 570 ;
+C 163 ; WX 500 ; N sterling ; B -32 -13 505 676 ;
+C 164 ; WX 167 ; N fraction ; B -161 0 327 662 ;
+C 165 ; WX 500 ; N yen ; B -15 0 565 662 ;
+C 166 ; WX 500 ; N florin ; B -86 -154 530 682 ;
+C 167 ; WX 500 ; N section ; B 36 -143 454 676 ;
+C 168 ; WX 500 ; N currency ; B -3 110 503 612 ;
+C 169 ; WX 278 ; N quotesingle ; B 126 367 295 693 ;
+C 170 ; WX 500 ; N quotedblleft ; B 57 363 513 676 ;
+C 171 ; WX 500 ; N guillemotleft ; B 21 33 474 416 ;
+C 172 ; WX 333 ; N guilsinglleft ; B 42 33 310 416 ;
+C 173 ; WX 333 ; N guilsinglright ; B 23 38 291 421 ;
+C 174 ; WX 556 ; N fi ; B -157 -203 538 682 ;
+C 175 ; WX 556 ; N fl ; B -149 -203 577 682 ;
+C 177 ; WX 500 ; N endash ; B -11 176 511 266 ;
+C 178 ; WX 500 ; N dagger ; B 90 -146 489 676 ;
+C 179 ; WX 500 ; N daggerdbl ; B 11 -143 487 675 ;
+C 180 ; WX 250 ; N periodcentered ; B 51 179 200 328 ;
+C 182 ; WX 500 ; N paragraph ; B 61 -189 592 682 ;
+C 183 ; WX 350 ; N bullet ; B 50 175 300 425 ;
+C 184 ; WX 333 ; N quotesinglbase ; B 66 -181 268 132 ;
+C 185 ; WX 500 ; N quotedblbase ; B -57 -181 398 132 ;
+C 186 ; WX 500 ; N quotedblright ; B 56 362 509 675 ;
+C 187 ; WX 500 ; N guillemotright ; B 21 38 474 421 ;
+C 188 ; WX 1000 ; N ellipsis ; B 93 -13 906 133 ;
+C 189 ; WX 1000 ; N perthousand ; B 7 -49 985 699 ;
+C 191 ; WX 500 ; N questiondown ; B 30 -203 417 487 ;
+C 193 ; WX 333 ; N grave ; B 115 511 325 690 ;
+C 194 ; WX 333 ; N acute ; B 168 511 405 690 ;
+C 195 ; WX 333 ; N circumflex ; B 70 510 394 682 ;
+C 196 ; WX 333 ; N tilde ; B 69 530 424 648 ;
+C 197 ; WX 333 ; N macron ; B 81 547 420 616 ;
+C 198 ; WX 333 ; N breve ; B 99 511 414 671 ;
+C 199 ; WX 333 ; N dotaccent ; B 180 519 308 648 ;
+C 200 ; WX 333 ; N dieresis ; B 85 519 424 648 ;
+C 202 ; WX 333 ; N ring ; B 141 466 352 676 ;
+C 203 ; WX 333 ; N cedilla ; B 32 -216 264 5 ;
+C 205 ; WX 333 ; N hungarumlaut ; B 28 538 339 750 ;
+C 206 ; WX 333 ; N ogonek ; B -37 -173 192 44 ;
+C 207 ; WX 333 ; N caron ; B 109 511 437 683 ;
+C 208 ; WX 1000 ; N emdash ; B -14 176 1014 266 ;
+C 225 ; WX 944 ; N AE ; B -41 0 931 662 ;
+C 227 ; WX 266 ; N ordfeminine ; B -24 286 291 676 ;
+C 232 ; WX 611 ; N Lslash ; B -22 0 584 662 ;
+C 233 ; WX 722 ; N Oslash ; B 27 -124 684 754 ;
+C 234 ; WX 944 ; N OE ; B 23 -8 936 670 ;
+C 235 ; WX 300 ; N ordmasculine ; B 1 286 300 676 ;
+C 241 ; WX 722 ; N ae ; B 15 -13 685 458 ;
+C 245 ; WX 278 ; N dotlessi ; B 27 -13 260 458 ;
+C 248 ; WX 278 ; N lslash ; B 12 -13 326 682 ;
+C 249 ; WX 500 ; N oslash ; B 27 -118 467 556 ;
+C 250 ; WX 722 ; N oe ; B 26 -13 687 458 ;
+C 251 ; WX 500 ; N germandbls ; B -168 -203 497 682 ;
+C -1 ; WX 667 ; N Aacute ; B -51 0 602 894 ;
+C -1 ; WX 667 ; N Acircumflex ; B -51 0 602 886 ;
+C -1 ; WX 667 ; N Adieresis ; B -51 0 602 852 ;
+C -1 ; WX 667 ; N Agrave ; B -51 0 602 894 ;
+C -1 ; WX 667 ; N Aring ; B -51 0 602 880 ;
+C -1 ; WX 667 ; N Atilde ; B -51 0 602 852 ;
+C -1 ; WX 667 ; N Ccedilla ; B 22 -216 660 677 ;
+C -1 ; WX 667 ; N Eacute ; B -27 0 646 894 ;
+C -1 ; WX 667 ; N Ecircumflex ; B -27 0 646 886 ;
+C -1 ; WX 667 ; N Edieresis ; B -27 0 646 852 ;
+C -1 ; WX 667 ; N Egrave ; B -27 0 646 894 ;
+C -1 ; WX 722 ; N Eth ; B -31 0 693 662 ;
+C -1 ; WX 389 ; N Iacute ; B -22 0 433 894 ;
+C -1 ; WX 389 ; N Icircumflex ; B -22 0 422 886 ;
+C -1 ; WX 389 ; N Idieresis ; B -22 0 452 852 ;
+C -1 ; WX 389 ; N Igrave ; B -22 0 412 894 ;
+C -1 ; WX 722 ; N Ntilde ; B -27 -18 740 852 ;
+C -1 ; WX 722 ; N Oacute ; B 27 -18 684 894 ;
+C -1 ; WX 722 ; N Ocircumflex ; B 27 -18 684 886 ;
+C -1 ; WX 722 ; N Odieresis ; B 27 -18 684 852 ;
+C -1 ; WX 722 ; N Ograve ; B 27 -18 684 894 ;
+C -1 ; WX 722 ; N Otilde ; B 27 -18 684 852 ;
+C -1 ; WX 556 ; N Scaron ; B 6 -18 549 887 ;
+C -1 ; WX 611 ; N Thorn ; B -27 0 572 662 ;
+C -1 ; WX 722 ; N Uacute ; B 66 -18 736 894 ;
+C -1 ; WX 722 ; N Ucircumflex ; B 66 -18 736 886 ;
+C -1 ; WX 722 ; N Udieresis ; B 66 -18 736 852 ;
+C -1 ; WX 722 ; N Ugrave ; B 66 -18 736 894 ;
+C -1 ; WX 611 ; N Yacute ; B 46 0 625 894 ;
+C -1 ; WX 611 ; N Ydieresis ; B 46 0 625 852 ;
+C -1 ; WX 611 ; N Zcaron ; B -1 0 594 887 ;
+C -1 ; WX 500 ; N aacute ; B 9 -14 489 690 ;
+C -1 ; WX 500 ; N acircumflex ; B 9 -14 480 682 ;
+C -1 ; WX 500 ; N adieresis ; B 9 -14 508 648 ;
+C -1 ; WX 500 ; N agrave ; B 9 -14 480 690 ;
+C -1 ; WX 500 ; N aring ; B 9 -14 480 676 ;
+C -1 ; WX 500 ; N atilde ; B 9 -14 508 648 ;
+C -1 ; WX 220 ; N brokenbar ; B 70 0 151 682 ;
+C -1 ; WX 444 ; N ccedilla ; B 25 -216 418 458 ;
+C -1 ; WX 747 ; N copyright ; B 23 -18 723 676 ;
+C -1 ; WX 400 ; N degree ; B 70 376 370 676 ;
+C -1 ; WX 570 ; N divide ; B 33 0 537 505 ;
+C -1 ; WX 444 ; N eacute ; B 25 -13 461 690 ;
+C -1 ; WX 444 ; N ecircumflex ; B 25 -13 450 682 ;
+C -1 ; WX 444 ; N edieresis ; B 25 -13 480 648 ;
+C -1 ; WX 444 ; N egrave ; B 25 -13 413 690 ;
+C -1 ; WX 500 ; N eth ; B 27 -13 498 682 ;
+C -1 ; WX 278 ; N iacute ; B 27 -13 378 690 ;
+C -1 ; WX 278 ; N icircumflex ; B 27 -13 367 682 ;
+C -1 ; WX 278 ; N idieresis ; B 27 -13 397 648 ;
+C -1 ; WX 278 ; N igrave ; B 27 -13 298 690 ;
+C -1 ; WX 606 ; N logicalnot ; B 51 120 555 401 ;
+C -1 ; WX 606 ; N minus ; B 51 210 555 300 ;
+C -1 ; WX 576 ; N mu ; B -63 -210 521 458 ;
+C -1 ; WX 570 ; N multiply ; B 33 0 537 504 ;
+C -1 ; WX 556 ; N ntilde ; B 24 -13 536 648 ;
+C -1 ; WX 500 ; N oacute ; B 27 -13 489 690 ;
+C -1 ; WX 500 ; N ocircumflex ; B 27 -13 478 682 ;
+C -1 ; WX 500 ; N odieresis ; B 27 -13 508 648 ;
+C -1 ; WX 500 ; N ograve ; B 27 -13 467 690 ;
+C -1 ; WX 750 ; N onehalf ; B 30 0 720 676 ;
+C -1 ; WX 750 ; N onequarter ; B 30 0 720 676 ;
+C -1 ; WX 300 ; N onesuperior ; B 17 270 283 676 ;
+C -1 ; WX 500 ; N otilde ; B 27 -13 508 648 ;
+C -1 ; WX 570 ; N plusminus ; B 33 0 537 665 ;
+C -1 ; WX 747 ; N registered ; B 23 -18 723 676 ;
+C -1 ; WX 389 ; N scaron ; B 16 -13 465 683 ;
+C -1 ; WX 500 ; N thorn ; B -79 -203 474 682 ;
+C -1 ; WX 750 ; N threequarters ; B 30 0 720 676 ;
+C -1 ; WX 300 ; N threesuperior ; B 0 263 299 676 ;
+C -1 ; WX 1000 ; N trademark ; B 40 272 980 676 ;
+C -1 ; WX 300 ; N twosuperior ; B -2 270 302 676 ;
+C -1 ; WX 556 ; N uacute ; B 48 -13 521 690 ;
+C -1 ; WX 556 ; N ucircumflex ; B 48 -13 521 682 ;
+C -1 ; WX 556 ; N udieresis ; B 48 -13 536 648 ;
+C -1 ; WX 556 ; N ugrave ; B 48 -13 521 690 ;
+C -1 ; WX 444 ; N yacute ; B -60 -203 461 690 ;
+C -1 ; WX 444 ; N ydieresis ; B -60 -203 480 648 ;
+C -1 ; WX 389 ; N zcaron ; B -24 -58 465 683 ;
+EndCharMetrics
+StartKernData
+StartKernPairs 108
+
+KPX A y -74
+KPX A w -74
+KPX A v -74
+KPX A space -55
+KPX A quoteright -74
+KPX A Y -55
+KPX A W -92
+KPX A V -74
+KPX A T -55
+
+KPX F space -18
+KPX F period -129
+KPX F comma -129
+KPX F A -92
+
+KPX L y -37
+KPX L space -37
+KPX L quoteright -55
+KPX L Y -37
+KPX L W -37
+KPX L V -37
+KPX L T -18
+
+KPX P space -37
+KPX P period -129
+KPX P comma -129
+KPX P A -74
+
+KPX R y -18
+KPX R Y -18
+KPX R W -18
+KPX R V -18
+
+KPX T y -37
+KPX T w -37
+KPX T u -37
+KPX T semicolon -74
+KPX T s -92
+KPX T r -37
+KPX T period -92
+KPX T o -92
+KPX T i -37
+KPX T hyphen -92
+KPX T e -92
+KPX T comma -92
+KPX T colon -74
+KPX T c -92
+KPX T a -92
+KPX T O -18
+KPX T A -55
+
+KPX V y -74
+KPX V u -55
+KPX V space -18
+KPX V semicolon -74
+KPX V r -55
+KPX V period -129
+KPX V o -111
+KPX V i -55
+KPX V hyphen -55
+KPX V e -111
+KPX V comma -129
+KPX V colon -74
+KPX V a -111
+KPX V A -74
+
+KPX W y -55
+KPX W u -55
+KPX W space -18
+KPX W semicolon -55
+KPX W r -74
+KPX W period -74
+KPX W o -74
+KPX W i -37
+KPX W hyphen -37
+KPX W e -74
+KPX W comma -74
+KPX W colon -55
+KPX W a -74
+KPX W A -74
+
+KPX Y v -92
+KPX Y u -92
+KPX Y space -37
+KPX Y semicolon -92
+KPX Y q -111
+KPX Y period -74
+KPX Y p -74
+KPX Y o -111
+KPX Y i -55
+KPX Y hyphen -92
+KPX Y e -111
+KPX Y comma -92
+KPX Y colon -92
+KPX Y a -92
+KPX Y A -74
+
+KPX f quoteright 55
+KPX f f -18
+
+KPX one one -55
+
+KPX quoteleft quoteleft -74
+
+KPX quoteright t -37
+KPX quoteright space -74
+KPX quoteright s -74
+KPX quoteright quoteright -74
+
+KPX r quoteright 37
+KPX r period -55
+KPX r comma -55
+
+KPX space Y -18
+KPX space W -18
+KPX space A -37
+
+KPX v period -37
+KPX v comma -37
+
+KPX w period -37
+KPX w comma -37
+
+KPX y period -37
+KPX y comma -37
+EndKernPairs
+EndKernData
+StartComposites 58
+CC Zcaron 2 ; PCC Z 0 0 ; PCC caron 139 204 ;
+CC zcaron 2 ; PCC z 0 0 ; PCC caron 28 0 ;
+CC Scaron 2 ; PCC S 0 0 ; PCC caron 111 204 ;
+CC scaron 2 ; PCC s 0 0 ; PCC caron 28 0 ;
+CC Ccedilla 2 ; PCC C 0 0 ; PCC cedilla 167 0 ;
+CC ccedilla 2 ; PCC c 0 0 ; PCC cedilla 55 0 ;
+CC Yacute 2 ; PCC Y 0 0 ; PCC acute 139 204 ;
+CC yacute 2 ; PCC y 0 0 ; PCC acute 55 0 ;
+CC Ydieresis 2 ; PCC Y 0 0 ; PCC dieresis 139 204 ;
+CC ydieresis 2 ; PCC y 0 0 ; PCC dieresis 55 0 ;
+CC Uacute 2 ; PCC U 0 0 ; PCC acute 194 204 ;
+CC Ucircumflex 2 ; PCC U 0 0 ; PCC circumflex 194 204 ;
+CC Udieresis 2 ; PCC U 0 0 ; PCC dieresis 194 204 ;
+CC Ugrave 2 ; PCC U 0 0 ; PCC grave 194 204 ;
+CC uacute 2 ; PCC u 0 0 ; PCC acute 111 0 ;
+CC ucircumflex 2 ; PCC u 0 0 ; PCC circumflex 111 0 ;
+CC udieresis 2 ; PCC u 0 0 ; PCC dieresis 111 0 ;
+CC ugrave 2 ; PCC u 0 0 ; PCC grave 111 0 ;
+CC Iacute 2 ; PCC I 0 0 ; PCC acute 28 204 ;
+CC Icircumflex 2 ; PCC I 0 0 ; PCC circumflex 28 204 ;
+CC Idieresis 2 ; PCC I 0 0 ; PCC dieresis 28 204 ;
+CC Igrave 2 ; PCC I 0 0 ; PCC grave 28 204 ;
+CC iacute 2 ; PCC dotlessi 0 0 ; PCC acute -27 0 ;
+CC icircumflex 2 ; PCC dotlessi 0 0 ; PCC circumflex -27 0 ;
+CC idieresis 2 ; PCC dotlessi 0 0 ; PCC dieresis -27 0 ;
+CC igrave 2 ; PCC dotlessi 0 0 ; PCC grave -27 0 ;
+CC Eacute 2 ; PCC E 0 0 ; PCC acute 167 204 ;
+CC Ecircumflex 2 ; PCC E 0 0 ; PCC circumflex 167 204 ;
+CC Edieresis 2 ; PCC E 0 0 ; PCC dieresis 167 204 ;
+CC Egrave 2 ; PCC E 0 0 ; PCC grave 167 204 ;
+CC eacute 2 ; PCC e 0 0 ; PCC acute 55 0 ;
+CC ecircumflex 2 ; PCC e 0 0 ; PCC circumflex 55 0 ;
+CC edieresis 2 ; PCC e 0 0 ; PCC dieresis 55 0 ;
+CC egrave 2 ; PCC e 0 0 ; PCC grave 55 0 ;
+CC Aacute 2 ; PCC A 0 0 ; PCC acute 167 204 ;
+CC Acircumflex 2 ; PCC A 0 0 ; PCC circumflex 167 204 ;
+CC Adieresis 2 ; PCC A 0 0 ; PCC dieresis 167 204 ;
+CC Agrave 2 ; PCC A 0 0 ; PCC grave 167 204 ;
+CC aacute 2 ; PCC a 0 0 ; PCC acute 83 0 ;
+CC acircumflex 2 ; PCC a 0 0 ; PCC circumflex 83 0 ;
+CC adieresis 2 ; PCC a 0 0 ; PCC dieresis 83 0 ;
+CC agrave 2 ; PCC a 0 0 ; PCC grave 83 0 ;
+CC Oacute 2 ; PCC O 0 0 ; PCC acute 194 204 ;
+CC Ocircumflex 2 ; PCC O 0 0 ; PCC circumflex 194 204 ;
+CC Odieresis 2 ; PCC O 0 0 ; PCC dieresis 194 204 ;
+CC Ograve 2 ; PCC O 0 0 ; PCC grave 194 204 ;
+CC oacute 2 ; PCC o 0 0 ; PCC acute 83 0 ;
+CC ocircumflex 2 ; PCC o 0 0 ; PCC circumflex 83 0 ;
+CC odieresis 2 ; PCC o 0 0 ; PCC dieresis 83 0 ;
+CC ograve 2 ; PCC o 0 0 ; PCC grave 83 0 ;
+CC Atilde 2 ; PCC A 0 0 ; PCC tilde 167 204 ;
+CC atilde 2 ; PCC a 0 0 ; PCC tilde 83 0 ;
+CC Ntilde 2 ; PCC N 0 0 ; PCC tilde 194 204 ;
+CC ntilde 2 ; PCC n 0 0 ; PCC tilde 111 0 ;
+CC Otilde 2 ; PCC O 0 0 ; PCC tilde 194 204 ;
+CC otilde 2 ; PCC o 0 0 ; PCC tilde 83 0 ;
+CC Aring 2 ; PCC A 0 0 ; PCC ring 167 204 ;
+CC aring 2 ; PCC a 0 0 ; PCC ring 83 0 ;
+EndComposites
+EndFontMetrics
diff --git a/collects/afm/Times-Italic.afm b/collects/afm/Times-Italic.afm
new file mode 100644
index 0000000000..e0bd23a9f3
--- /dev/null
+++ b/collects/afm/Times-Italic.afm
@@ -0,0 +1,452 @@
+StartFontMetrics 2.0
+Comment Copyright (c) 1984 Adobe Systems Incorporated. All Rights Reserved.
+Comment Creation Date:Sun Feb 8 03:54:53 PST 1987
+FontName Times-Italic
+EncodingScheme AdobeStandardEncoding
+FullName Times Italic
+FamilyName Times
+Weight Medium
+ItalicAngle -15.5
+IsFixedPitch false
+UnderlinePosition -96
+UnderlineThickness 48
+Version 001.002
+Notice Times is a trademark of Allied Corporation.
+FontBBox -176 -252 990 930
+CapHeight 660
+XHeight 446
+Descender -206
+Ascender 684
+StartCharMetrics 228
+C 32 ; WX 250 ; N space ; B 0 0 0 0 ;
+C 33 ; WX 333 ; N exclam ; B 46 -10 296 670 ;
+C 34 ; WX 420 ; N quotedbl ; B 107 442 402 673 ;
+C 35 ; WX 500 ; N numbersign ; B -7 -6 508 683 ;
+C 36 ; WX 500 ; N dollar ; B 13 -102 481 735 ;
+C 37 ; WX 833 ; N percent ; B 63 -14 770 682 ;
+C 38 ; WX 778 ; N ampersand ; B 60 -22 698 673 ;
+C 39 ; WX 333 ; N quoteright ; B 69 458 206 678 ;
+C 40 ; WX 333 ; N parenleft ; B 41 -180 312 662 ;
+C 41 ; WX 333 ; N parenright ; B 19 -178 286 664 ;
+C 42 ; WX 500 ; N asterisk ; B 60 268 434 684 ;
+C 43 ; WX 675 ; N plus ; B 85 0 589 505 ;
+C 44 ; WX 250 ; N comma ; B 57 -126 194 94 ;
+C 45 ; WX 333 ; N hyphen ; B 55 192 276 254 ;
+C 46 ; WX 250 ; N period ; B 75 -10 175 90 ;
+C 47 ; WX 278 ; N slash ; B 2 -14 252 641 ;
+C 48 ; WX 500 ; N zero ; B 19 -9 470 683 ;
+C 49 ; WX 500 ; N one ; B 31 0 390 684 ;
+C 50 ; WX 500 ; N two ; B -7 0 429 682 ;
+C 51 ; WX 500 ; N three ; B -7 -12 443 682 ;
+C 52 ; WX 500 ; N four ; B -8 0 454 681 ;
+C 53 ; WX 500 ; N five ; B -12 -15 462 666 ;
+C 54 ; WX 500 ; N six ; B 24 -8 497 685 ;
+C 55 ; WX 500 ; N seven ; B 56 -12 512 666 ;
+C 56 ; WX 500 ; N eight ; B 12 -7 475 681 ;
+C 57 ; WX 500 ; N nine ; B 10 -18 470 684 ;
+C 58 ; WX 333 ; N colon ; B 86 -10 284 444 ;
+C 59 ; WX 333 ; N semicolon ; B 63 -124 292 441 ;
+C 60 ; WX 675 ; N less ; B 83 -7 592 515 ;
+C 61 ; WX 675 ; N equal ; B 85 125 589 383 ;
+C 62 ; WX 675 ; N greater ; B 82 -7 591 515 ;
+C 63 ; WX 500 ; N question ; B 105 -10 439 670 ;
+C 64 ; WX 920 ; N at ; B 39 -191 866 648 ;
+C 65 ; WX 611 ; N A ; B -45 0 564 672 ;
+C 66 ; WX 611 ; N B ; B -28 0 562 660 ;
+C 67 ; WX 667 ; N C ; B 33 -23 653 672 ;
+C 68 ; WX 722 ; N D ; B -27 0 671 660 ;
+C 69 ; WX 611 ; N E ; B -17 0 609 660 ;
+C 70 ; WX 611 ; N F ; B -17 0 609 660 ;
+C 71 ; WX 722 ; N G ; B 31 -23 701 672 ;
+C 72 ; WX 722 ; N H ; B -26 0 742 660 ;
+C 73 ; WX 333 ; N I ; B -26 0 357 660 ;
+C 74 ; WX 444 ; N J ; B -36 -22 479 660 ;
+C 75 ; WX 667 ; N K ; B -15 0 702 660 ;
+C 76 ; WX 556 ; N L ; B -32 0 535 660 ;
+C 77 ; WX 833 ; N M ; B -24 0 850 660 ;
+C 78 ; WX 667 ; N N ; B -36 -12 698 660 ;
+C 79 ; WX 722 ; N O ; B 42 -23 676 671 ;
+C 80 ; WX 611 ; N P ; B -16 0 582 660 ;
+C 81 ; WX 722 ; N Q ; B 41 -186 681 671 ;
+C 82 ; WX 611 ; N R ; B -32 0 566 660 ;
+C 83 ; WX 500 ; N S ; B 9 -22 483 674 ;
+C 84 ; WX 556 ; N T ; B 32 0 602 660 ;
+C 85 ; WX 722 ; N U ; B 77 -21 747 660 ;
+C 86 ; WX 611 ; N V ; B 44 -20 659 660 ;
+C 87 ; WX 833 ; N W ; B 35 -20 875 660 ;
+C 88 ; WX 611 ; N X ; B -45 0 633 660 ;
+C 89 ; WX 556 ; N Y ; B 44 0 600 660 ;
+C 90 ; WX 556 ; N Z ; B -19 0 581 660 ;
+C 91 ; WX 389 ; N bracketleft ; B 22 -170 391 654 ;
+C 92 ; WX 278 ; N backslash ; B 2 -12 252 651 ;
+C 93 ; WX 389 ; N bracketright ; B -31 -170 341 654 ;
+C 94 ; WX 422 ; N asciicircum ; B 0 254 503 660 ;
+C 95 ; WX 500 ; N underscore ; B -9 -252 510 -206 ;
+C 96 ; WX 333 ; N quoteleft ; B 149 457 286 677 ;
+C 97 ; WX 500 ; N a ; B 15 -11 474 446 ;
+C 98 ; WX 500 ; N b ; B 24 -12 475 682 ;
+C 99 ; WX 444 ; N c ; B 32 -11 420 446 ;
+C 100 ; WX 500 ; N d ; B 15 -11 521 684 ;
+C 101 ; WX 444 ; N e ; B 34 -13 412 446 ;
+C 102 ; WX 278 ; N f ; B -148 -207 415 684 ; L i fi ; L l fl ;
+C 103 ; WX 500 ; N g ; B 10 -209 471 445 ;
+C 104 ; WX 500 ; N h ; B 23 -10 473 684 ;
+C 105 ; WX 278 ; N i ; B 43 -10 263 660 ;
+C 106 ; WX 278 ; N j ; B -109 -207 287 660 ;
+C 107 ; WX 444 ; N k ; B 16 -12 460 685 ;
+C 108 ; WX 278 ; N l ; B 41 -10 276 685 ;
+C 109 ; WX 722 ; N m ; B 11 -10 698 447 ;
+C 110 ; WX 500 ; N n ; B 23 -10 471 447 ;
+C 111 ; WX 500 ; N o ; B 27 -13 467 448 ;
+C 112 ; WX 500 ; N p ; B -75 -206 465 446 ;
+C 113 ; WX 500 ; N q ; B 20 -206 483 445 ;
+C 114 ; WX 389 ; N r ; B 24 0 392 446 ;
+C 115 ; WX 389 ; N s ; B 16 -14 367 446 ;
+C 116 ; WX 278 ; N t ; B 38 -10 288 548 ;
+C 117 ; WX 500 ; N u ; B 42 -11 472 447 ;
+C 118 ; WX 444 ; N v ; B 24 -11 423 444 ;
+C 119 ; WX 667 ; N w ; B 14 -10 650 447 ;
+C 120 ; WX 444 ; N x ; B -31 -10 450 446 ;
+C 121 ; WX 444 ; N y ; B -27 -209 420 445 ;
+C 122 ; WX 389 ; N z ; B 2 0 380 434 ;
+C 123 ; WX 400 ; N braceleft ; B 65 -179 411 675 ;
+C 124 ; WX 275 ; N bar ; B -22 -188 251 670 ;
+C 125 ; WX 400 ; N braceright ; B -66 -179 300 675 ;
+C 126 ; WX 541 ; N asciitilde ; B 18 169 522 340 ;
+C 161 ; WX 389 ; N exclamdown ; B 59 -213 317 468 ;
+C 162 ; WX 500 ; N cent ; B 62 -146 449 564 ;
+C 163 ; WX 500 ; N sterling ; B -5 -9 498 672 ;
+C 164 ; WX 167 ; N fraction ; B -176 -15 338 672 ;
+C 165 ; WX 500 ; N yen ; B 13 0 609 684 ;
+C 166 ; WX 500 ; N florin ; B 3 -189 492 688 ;
+C 167 ; WX 500 ; N section ; B 42 -96 455 743 ;
+C 168 ; WX 500 ; N currency ; B 3 105 498 604 ;
+C 169 ; WX 214 ; N quotesingle ; B 99 453 247 678 ;
+C 170 ; WX 556 ; N quotedblleft ; B 166 457 510 677 ;
+C 171 ; WX 500 ; N guillemotleft ; B 54 39 444 400 ;
+C 172 ; WX 333 ; N guilsinglleft ; B 60 39 285 400 ;
+C 173 ; WX 333 ; N guilsinglright ; B 49 34 269 406 ;
+C 174 ; WX 500 ; N fi ; B -136 -207 468 684 ;
+C 175 ; WX 500 ; N fl ; B -140 -207 509 684 ;
+C 177 ; WX 500 ; N endash ; B -3 194 501 242 ;
+C 178 ; WX 500 ; N dagger ; B 92 -93 480 734 ;
+C 179 ; WX 500 ; N daggerdbl ; B 20 -93 482 743 ;
+C 180 ; WX 250 ; N periodcentered ; B 75 192 199 316 ;
+C 182 ; WX 523 ; N paragraph ; B 87 -196 533 675 ;
+C 183 ; WX 350 ; N bullet ; B 50 175 300 425 ;
+C 184 ; WX 333 ; N quotesinglbase ; B 83 -126 220 94 ;
+C 185 ; WX 556 ; N quotedblbase ; B 63 -126 407 94 ;
+C 186 ; WX 556 ; N quotedblright ; B 68 458 412 678 ;
+C 187 ; WX 500 ; N guillemotright ; B 59 34 442 406 ;
+C 188 ; WX 889 ; N ellipsis ; B 62 -10 828 90 ;
+C 189 ; WX 1000 ; N perthousand ; B 9 -65 990 690 ;
+C 191 ; WX 500 ; N questiondown ; B 55 -215 395 462 ;
+C 193 ; WX 333 ; N grave ; B 160 491 333 659 ;
+C 194 ; WX 333 ; N acute ; B 154 501 375 680 ;
+C 195 ; WX 333 ; N circumflex ; B 96 495 374 669 ;
+C 196 ; WX 333 ; N tilde ; B 114 518 386 639 ;
+C 197 ; WX 333 ; N macron ; B 120 543 380 603 ;
+C 198 ; WX 333 ; N breve ; B 140 512 401 645 ;
+C 199 ; WX 333 ; N dotaccent ; B 112 515 222 625 ;
+C 200 ; WX 333 ; N dieresis ; B 117 534 389 634 ;
+C 202 ; WX 333 ; N ring ; B 239 509 433 703 ;
+C 203 ; WX 333 ; N cedilla ; B -30 -206 214 0 ;
+C 205 ; WX 333 ; N hungarumlaut ; B 62 532 348 749 ;
+C 206 ; WX 333 ; N ogonek ; B -44 -159 169 40 ;
+C 207 ; WX 333 ; N caron ; B 138 495 422 669 ;
+C 208 ; WX 889 ; N emdash ; B -65 194 945 242 ;
+C 225 ; WX 889 ; N AE ; B -46 0 889 660 ;
+C 227 ; WX 276 ; N ordfeminine ; B 32 300 310 677 ;
+C 232 ; WX 556 ; N Lslash ; B 0 0 567 660 ;
+C 233 ; WX 722 ; N Oslash ; B 40 -110 683 738 ;
+C 234 ; WX 944 ; N OE ; B 30 -10 943 668 ;
+C 235 ; WX 310 ; N ordmasculine ; B 45 301 310 679 ;
+C 241 ; WX 667 ; N ae ; B 24 -12 638 448 ;
+C 245 ; WX 278 ; N dotlessi ; B 47 -10 226 447 ;
+C 248 ; WX 278 ; N lslash ; B 0 -10 264 685 ;
+C 249 ; WX 500 ; N oslash ; B 28 -132 468 560 ;
+C 250 ; WX 667 ; N oe ; B 26 -15 643 445 ;
+C 251 ; WX 500 ; N germandbls ; B -167 -209 492 684 ;
+C -1 ; WX 611 ; N Aacute ; B -45 0 564 907 ;
+C -1 ; WX 611 ; N Acircumflex ; B -45 0 564 896 ;
+C -1 ; WX 611 ; N Adieresis ; B -45 0 564 861 ;
+C -1 ; WX 611 ; N Agrave ; B -45 0 564 886 ;
+C -1 ; WX 611 ; N Aring ; B -45 0 564 930 ;
+C -1 ; WX 611 ; N Atilde ; B -45 0 564 866 ;
+C -1 ; WX 667 ; N Ccedilla ; B 33 -206 653 672 ;
+C -1 ; WX 611 ; N Eacute ; B -17 0 609 907 ;
+C -1 ; WX 611 ; N Ecircumflex ; B -17 0 609 896 ;
+C -1 ; WX 611 ; N Edieresis ; B -17 0 609 861 ;
+C -1 ; WX 611 ; N Egrave ; B -17 0 609 886 ;
+C -1 ; WX 722 ; N Eth ; B -27 0 671 660 ;
+C -1 ; WX 333 ; N Iacute ; B -26 0 389 907 ;
+C -1 ; WX 333 ; N Icircumflex ; B -26 0 388 896 ;
+C -1 ; WX 333 ; N Idieresis ; B -26 0 403 861 ;
+C -1 ; WX 333 ; N Igrave ; B -26 0 357 886 ;
+C -1 ; WX 667 ; N Ntilde ; B -36 -12 698 866 ;
+C -1 ; WX 722 ; N Oacute ; B 42 -23 676 907 ;
+C -1 ; WX 722 ; N Ocircumflex ; B 42 -23 676 896 ;
+C -1 ; WX 722 ; N Odieresis ; B 42 -23 676 861 ;
+C -1 ; WX 722 ; N Ograve ; B 42 -23 676 886 ;
+C -1 ; WX 722 ; N Otilde ; B 42 -23 676 866 ;
+C -1 ; WX 500 ; N Scaron ; B 9 -22 506 896 ;
+C -1 ; WX 611 ; N Thorn ; B -16 0 547 660 ;
+C -1 ; WX 722 ; N Uacute ; B 77 -21 747 907 ;
+C -1 ; WX 722 ; N Ucircumflex ; B 77 -21 747 896 ;
+C -1 ; WX 722 ; N Udieresis ; B 77 -21 747 861 ;
+C -1 ; WX 722 ; N Ugrave ; B 77 -21 747 886 ;
+C -1 ; WX 556 ; N Yacute ; B 44 0 600 894 ;
+C -1 ; WX 556 ; N Ydieresis ; B 44 0 600 861 ;
+C -1 ; WX 556 ; N Zcaron ; B -19 0 581 896 ;
+C -1 ; WX 500 ; N aacute ; B 15 -11 474 680 ;
+C -1 ; WX 500 ; N acircumflex ; B 15 -11 474 669 ;
+C -1 ; WX 500 ; N adieresis ; B 15 -11 479 634 ;
+C -1 ; WX 500 ; N agrave ; B 15 -11 474 659 ;
+C -1 ; WX 500 ; N aring ; B 15 -11 474 703 ;
+C -1 ; WX 500 ; N atilde ; B 15 -11 476 639 ;
+C -1 ; WX 275 ; N brokenbar ; B -22 -188 251 670 ;
+C -1 ; WX 444 ; N ccedilla ; B 32 -206 420 446 ;
+C -1 ; WX 760 ; N copyright ; B 40 -22 719 672 ;
+C -1 ; WX 400 ; N degree ; B 70 384 370 684 ;
+C -1 ; WX 675 ; N divide ; B 85 0 589 505 ;
+C -1 ; WX 444 ; N eacute ; B 34 -13 444 680 ;
+C -1 ; WX 444 ; N ecircumflex ; B 34 -13 443 669 ;
+C -1 ; WX 444 ; N edieresis ; B 34 -13 458 634 ;
+C -1 ; WX 444 ; N egrave ; B 34 -13 412 659 ;
+C -1 ; WX 500 ; N eth ; B 27 -13 487 682 ;
+C -1 ; WX 278 ; N iacute ; B 47 -10 341 680 ;
+C -1 ; WX 278 ; N icircumflex ; B 47 -10 340 669 ;
+C -1 ; WX 278 ; N idieresis ; B 47 -10 355 634 ;
+C -1 ; WX 278 ; N igrave ; B 47 -10 299 659 ;
+C -1 ; WX 675 ; N logicalnot ; B 85 113 589 383 ;
+C -1 ; WX 675 ; N minus ; B 85 222 589 286 ;
+C -1 ; WX 500 ; N mu ; B -60 -206 472 446 ;
+C -1 ; WX 675 ; N multiply ; B 85 0 589 504 ;
+C -1 ; WX 500 ; N ntilde ; B 23 -10 471 639 ;
+C -1 ; WX 500 ; N oacute ; B 27 -13 467 680 ;
+C -1 ; WX 500 ; N ocircumflex ; B 27 -13 467 669 ;
+C -1 ; WX 500 ; N odieresis ; B 27 -13 479 634 ;
+C -1 ; WX 500 ; N ograve ; B 27 -13 467 659 ;
+C -1 ; WX 750 ; N onehalf ; B 30 -15 720 684 ;
+C -1 ; WX 750 ; N onequarter ; B 30 -15 720 684 ;
+C -1 ; WX 300 ; N onesuperior ; B 43 274 277 683 ;
+C -1 ; WX 500 ; N otilde ; B 27 -13 476 639 ;
+C -1 ; WX 675 ; N plusminus ; B 85 0 589 645 ;
+C -1 ; WX 760 ; N registered ; B 40 -22 719 672 ;
+C -1 ; WX 389 ; N scaron ; B 16 -14 450 669 ;
+C -1 ; WX 500 ; N thorn ; B -75 -206 465 682 ;
+C -1 ; WX 750 ; N threequarters ; B 30 -15 720 684 ;
+C -1 ; WX 300 ; N threesuperior ; B 13 267 306 684 ;
+C -1 ; WX 980 ; N trademark ; B 35 268 945 672 ;
+C -1 ; WX 300 ; N twosuperior ; B 8 274 292 684 ;
+C -1 ; WX 500 ; N uacute ; B 42 -11 472 680 ;
+C -1 ; WX 500 ; N ucircumflex ; B 42 -11 472 669 ;
+C -1 ; WX 500 ; N udieresis ; B 42 -11 473 634 ;
+C -1 ; WX 500 ; N ugrave ; B 42 -11 472 659 ;
+C -1 ; WX 444 ; N yacute ; B -27 -209 431 680 ;
+C -1 ; WX 444 ; N ydieresis ; B -27 -209 445 634 ;
+C -1 ; WX 389 ; N zcaron ; B 2 0 450 669 ;
+EndCharMetrics
+StartKernData
+StartKernPairs 120
+
+KPX A y -55
+KPX A w -55
+KPX A v -55
+KPX A space -18
+KPX A quoteright -37
+KPX A Y -55
+KPX A W -37
+KPX A V -50
+KPX A T -37
+
+KPX F period -129
+KPX F comma -129
+KPX F A -129
+
+KPX L y -30
+KPX L space -18
+KPX L quoteright -37
+KPX L Y -20
+KPX L W -37
+KPX L V -37
+KPX L T -20
+
+KPX P space -18
+KPX P period -129
+KPX P comma -129
+KPX P A -129
+
+KPX R y -18
+KPX R Y -18
+KPX R W -18
+KPX R V -18
+KPX R T 0
+
+KPX T y -74
+KPX T w -74
+KPX T u -55
+KPX T space -18
+KPX T semicolon -65
+KPX T s -92
+KPX T r -55
+KPX T period -74
+KPX T o -92
+KPX T i -55
+KPX T hyphen -74
+KPX T e -92
+KPX T comma -74
+KPX T colon -55
+KPX T c -92
+KPX T a -92
+KPX T O -18
+KPX T A -74
+
+KPX V y -92
+KPX V u -74
+KPX V space -18
+KPX V semicolon -74
+KPX V r -74
+KPX V period -129
+KPX V o -111
+KPX V i -74
+KPX V hyphen -55
+KPX V e -111
+KPX V comma -129
+KPX V colon -65
+KPX V a -111
+KPX V O -30
+KPX V A -74
+
+KPX W y -92
+KPX W u -55
+KPX W semicolon -65
+KPX W r -55
+KPX W period -92
+KPX W o -92
+KPX W i -55
+KPX W hyphen -37
+KPX W e -92
+KPX W comma -92
+KPX W colon -65
+KPX W a -92
+KPX W A -70
+
+KPX Y v -92
+KPX Y u -92
+KPX Y semicolon -65
+KPX Y q -111
+KPX Y period -92
+KPX Y p -92
+KPX Y o -92
+KPX Y i -74
+KPX Y hyphen -74
+KPX Y e -92
+KPX Y comma -92
+KPX Y colon -65
+KPX Y a -92
+KPX Y A -70
+
+KPX f quoteright 92
+
+KPX one one -74
+
+KPX quoteleft quoteleft -111
+
+KPX quoteright t -111
+KPX quoteright space -111
+KPX quoteright s -129
+KPX quoteright quoteright -111
+
+KPX r y 0
+KPX r x 0
+KPX r w 0
+KPX r v 0
+KPX r u 0
+KPX r t 0
+KPX r r 0
+KPX r quoteright 37
+KPX r q -37
+KPX r period -111
+KPX r o -37
+KPX r hyphen -20
+KPX r h -18
+KPX r g -37
+KPX r e -37
+KPX r d -37
+KPX r comma -111
+KPX r c -37
+
+KPX space A -18
+
+KPX v period -74
+KPX v comma -74
+
+KPX w period -74
+KPX w comma -74
+
+KPX y period -55
+KPX y comma -55
+EndKernPairs
+EndKernData
+StartComposites 58
+CC Zcaron 2 ; PCC Z 0 0 ; PCC caron 111 227 ;
+CC zcaron 2 ; PCC z 0 0 ; PCC caron 28 0 ;
+CC Scaron 2 ; PCC S 0 0 ; PCC caron 83 227 ;
+CC scaron 2 ; PCC s 0 0 ; PCC caron 28 0 ;
+CC Ccedilla 2 ; PCC C 0 0 ; PCC cedilla 188 0 ;
+CC ccedilla 2 ; PCC c 0 0 ; PCC cedilla 61 0 ;
+CC Yacute 2 ; PCC Y 0 0 ; PCC acute 111 214 ;
+CC yacute 2 ; PCC y 0 0 ; PCC acute 55 0 ;
+CC Ydieresis 2 ; PCC Y 0 0 ; PCC dieresis 111 227 ;
+CC ydieresis 2 ; PCC y 0 0 ; PCC dieresis 55 0 ;
+CC Uacute 2 ; PCC U 0 0 ; PCC acute 228 227 ;
+CC Ucircumflex 2 ; PCC U 0 0 ; PCC circumflex 228 227 ;
+CC Udieresis 2 ; PCC U 0 0 ; PCC dieresis 228 227 ;
+CC Ugrave 2 ; PCC U 0 0 ; PCC grave 228 227 ;
+CC uacute 2 ; PCC u 0 0 ; PCC acute 83 0 ;
+CC ucircumflex 2 ; PCC u 0 0 ; PCC circumflex 83 0 ;
+CC udieresis 2 ; PCC u 0 0 ; PCC dieresis 83 0 ;
+CC ugrave 2 ; PCC u 0 0 ; PCC grave 83 0 ;
+CC Iacute 2 ; PCC I 0 0 ; PCC acute 14 227 ;
+CC Icircumflex 2 ; PCC I 0 0 ; PCC circumflex 14 227 ;
+CC Idieresis 2 ; PCC I 0 0 ; PCC dieresis 14 227 ;
+CC Igrave 2 ; PCC I 0 0 ; PCC grave 14 227 ;
+CC iacute 2 ; PCC dotlessi 0 0 ; PCC acute -34 0 ;
+CC icircumflex 2 ; PCC dotlessi 0 0 ; PCC circumflex -34 0 ;
+CC idieresis 2 ; PCC dotlessi 0 0 ; PCC dieresis -34 0 ;
+CC igrave 2 ; PCC dotlessi 0 0 ; PCC grave -34 0 ;
+CC Eacute 2 ; PCC E 0 0 ; PCC acute 160 227 ;
+CC Ecircumflex 2 ; PCC E 0 0 ; PCC circumflex 160 227 ;
+CC Edieresis 2 ; PCC E 0 0 ; PCC dieresis 160 227 ;
+CC Egrave 2 ; PCC E 0 0 ; PCC grave 160 227 ;
+CC eacute 2 ; PCC e 0 0 ; PCC acute 68 0 ;
+CC ecircumflex 2 ; PCC e 0 0 ; PCC circumflex 68 0 ;
+CC edieresis 2 ; PCC e 0 0 ; PCC dieresis 68 0 ;
+CC egrave 2 ; PCC e 0 0 ; PCC grave 68 0 ;
+CC Aacute 2 ; PCC A 0 0 ; PCC acute 146 227 ;
+CC Acircumflex 2 ; PCC A 0 0 ; PCC circumflex 146 227 ;
+CC Adieresis 2 ; PCC A 0 0 ; PCC dieresis 146 227 ;
+CC Agrave 2 ; PCC A 0 0 ; PCC grave 146 227 ;
+CC aacute 2 ; PCC a 0 0 ; PCC acute 89 0 ;
+CC acircumflex 2 ; PCC a 0 0 ; PCC circumflex 89 0 ;
+CC adieresis 2 ; PCC a 0 0 ; PCC dieresis 89 0 ;
+CC agrave 2 ; PCC a 0 0 ; PCC grave 89 0 ;
+CC Oacute 2 ; PCC O 0 0 ; PCC acute 221 227 ;
+CC Ocircumflex 2 ; PCC O 0 0 ; PCC circumflex 221 227 ;
+CC Odieresis 2 ; PCC O 0 0 ; PCC dieresis 221 227 ;
+CC Ograve 2 ; PCC O 0 0 ; PCC grave 221 227 ;
+CC oacute 2 ; PCC o 0 0 ; PCC acute 89 0 ;
+CC ocircumflex 2 ; PCC o 0 0 ; PCC circumflex 89 0 ;
+CC odieresis 2 ; PCC o 0 0 ; PCC dieresis 89 0 ;
+CC ograve 2 ; PCC o 0 0 ; PCC grave 89 0 ;
+CC Atilde 2 ; PCC A 0 0 ; PCC tilde 146 227 ;
+CC atilde 2 ; PCC a 0 0 ; PCC tilde 89 0 ;
+CC Ntilde 2 ; PCC N 0 0 ; PCC tilde 181 227 ;
+CC ntilde 2 ; PCC n 0 0 ; PCC tilde 76 0 ;
+CC Otilde 2 ; PCC O 0 0 ; PCC tilde 221 227 ;
+CC otilde 2 ; PCC o 0 0 ; PCC tilde 89 0 ;
+CC Aring 2 ; PCC A 0 0 ; PCC ring 80 227 ;
+CC aring 2 ; PCC a 0 0 ; PCC ring 29 0 ;
+EndComposites
+EndFontMetrics
diff --git a/collects/afm/Times-Roman.afm b/collects/afm/Times-Roman.afm
new file mode 100644
index 0000000000..df37da381a
--- /dev/null
+++ b/collects/afm/Times-Roman.afm
@@ -0,0 +1,445 @@
+StartFontMetrics 2.0
+Comment Copyright (c) 1984 Adobe Systems Incorporated. All Rights Reserved.
+Comment Creation Date:Sun Feb 8 01:48:39 PST 1987
+FontName Times-Roman
+EncodingScheme AdobeStandardEncoding
+FullName Times Roman
+FamilyName Times
+Weight Roman
+ItalicAngle 0.0
+IsFixedPitch false
+UnderlinePosition -109
+UnderlineThickness 49
+Version 001.002
+Notice Times Roman is a trademark of Allied Corporation.
+FontBBox -170 -223 1024 896
+CapHeight 662
+XHeight 448
+Descender -217
+Ascender 682
+StartCharMetrics 228
+C 32 ; WX 250 ; N space ; B 0 0 0 0 ;
+C 33 ; WX 333 ; N exclam ; B 109 -14 224 676 ;
+C 34 ; WX 408 ; N quotedbl ; B 70 445 337 685 ;
+C 35 ; WX 500 ; N numbersign ; B 4 0 495 662 ;
+C 36 ; WX 500 ; N dollar ; B 44 -87 456 727 ;
+C 37 ; WX 833 ; N percent ; B 61 -14 772 676 ;
+C 38 ; WX 778 ; N ampersand ; B 42 -14 750 676 ;
+C 39 ; WX 333 ; N quoteright ; B 103 432 242 676 ;
+C 40 ; WX 333 ; N parenleft ; B 49 -177 304 676 ;
+C 41 ; WX 333 ; N parenright ; B 29 -177 284 676 ;
+C 42 ; WX 500 ; N asterisk ; B 64 265 437 683 ;
+C 43 ; WX 564 ; N plus ; B 30 7 534 512 ;
+C 44 ; WX 250 ; N comma ; B 63 -143 202 101 ;
+C 45 ; WX 333 ; N hyphen ; B 43 194 289 257 ;
+C 46 ; WX 250 ; N period ; B 68 -14 183 101 ;
+C 47 ; WX 278 ; N slash ; B -12 -108 302 682 ;
+C 48 ; WX 500 ; N zero ; B 24 -14 476 676 ;
+C 49 ; WX 500 ; N one ; B 111 0 394 676 ;
+C 50 ; WX 500 ; N two ; B 30 0 475 676 ;
+C 51 ; WX 500 ; N three ; B 44 -14 431 676 ;
+C 52 ; WX 500 ; N four ; B 12 0 472 676 ;
+C 53 ; WX 500 ; N five ; B 32 -14 438 688 ;
+C 54 ; WX 500 ; N six ; B 35 -14 468 682 ;
+C 55 ; WX 500 ; N seven ; B 20 -14 449 662 ;
+C 56 ; WX 500 ; N eight ; B 53 -14 442 676 ;
+C 57 ; WX 500 ; N nine ; B 30 -22 460 676 ;
+C 58 ; WX 278 ; N colon ; B 81 -14 196 458 ;
+C 59 ; WX 278 ; N semicolon ; B 63 -143 202 458 ;
+C 60 ; WX 564 ; N less ; B 27 0 536 522 ;
+C 61 ; WX 564 ; N equal ; B 30 132 534 390 ;
+C 62 ; WX 564 ; N greater ; B 27 0 536 522 ;
+C 63 ; WX 444 ; N question ; B 49 -14 395 676 ;
+C 64 ; WX 921 ; N at ; B 0 -155 819 675 ;
+C 65 ; WX 722 ; N A ; B 15 0 706 676 ;
+C 66 ; WX 667 ; N B ; B 20 0 596 662 ;
+C 67 ; WX 667 ; N C ; B 33 -14 637 676 ;
+C 68 ; WX 722 ; N D ; B 20 0 689 662 ;
+C 69 ; WX 611 ; N E ; B 12 0 597 662 ;
+C 70 ; WX 556 ; N F ; B 12 0 544 662 ;
+C 71 ; WX 722 ; N G ; B 27 -14 704 676 ;
+C 72 ; WX 722 ; N H ; B 20 0 703 662 ;
+C 73 ; WX 333 ; N I ; B 18 0 316 662 ;
+C 74 ; WX 389 ; N J ; B 10 -14 376 662 ;
+C 75 ; WX 722 ; N K ; B 20 0 709 662 ;
+C 76 ; WX 611 ; N L ; B 12 0 598 662 ;
+C 77 ; WX 889 ; N M ; B 19 0 871 662 ;
+C 78 ; WX 722 ; N N ; B 12 -14 709 662 ;
+C 79 ; WX 722 ; N O ; B 33 -14 688 676 ;
+C 80 ; WX 556 ; N P ; B 11 0 542 662 ;
+C 81 ; WX 722 ; N Q ; B 33 -177 701 676 ;
+C 82 ; WX 667 ; N R ; B 12 0 654 662 ;
+C 83 ; WX 556 ; N S ; B 42 -14 491 676 ;
+C 84 ; WX 611 ; N T ; B 18 0 594 662 ;
+C 85 ; WX 722 ; N U ; B 16 -14 705 662 ;
+C 86 ; WX 722 ; N V ; B 20 -14 701 662 ;
+C 87 ; WX 944 ; N W ; B 9 -14 936 662 ;
+C 88 ; WX 722 ; N X ; B 12 0 706 662 ;
+C 89 ; WX 722 ; N Y ; B 22 0 703 662 ;
+C 90 ; WX 611 ; N Z ; B 7 0 597 662 ;
+C 91 ; WX 333 ; N bracketleft ; B 88 -156 299 662 ;
+C 92 ; WX 278 ; N backslash ; B -83 0 361 682 ;
+C 93 ; WX 333 ; N bracketright ; B 34 -156 245 662 ;
+C 94 ; WX 469 ; N asciicircum ; B 13 256 456 662 ;
+C 95 ; WX 500 ; N underscore ; B 0 -133 500 -84 ;
+C 96 ; WX 333 ; N quoteleft ; B 91 432 230 676 ;
+C 97 ; WX 444 ; N a ; B 37 -10 442 458 ;
+C 98 ; WX 500 ; N b ; B 9 -10 474 682 ;
+C 99 ; WX 444 ; N c ; B 25 -10 412 458 ;
+C 100 ; WX 500 ; N d ; B 26 -13 491 682 ;
+C 101 ; WX 444 ; N e ; B 22 -10 421 458 ;
+C 102 ; WX 333 ; N f ; B 20 0 383 682 ; L i fi ; L l fl ;
+C 103 ; WX 500 ; N g ; B 27 -217 470 458 ;
+C 104 ; WX 500 ; N h ; B 9 0 490 682 ;
+C 105 ; WX 278 ; N i ; B 22 0 259 682 ;
+C 106 ; WX 278 ; N j ; B -54 -217 212 682 ;
+C 107 ; WX 500 ; N k ; B 1 0 500 682 ;
+C 108 ; WX 278 ; N l ; B 20 0 259 682 ;
+C 109 ; WX 778 ; N m ; B 13 0 764 458 ;
+C 110 ; WX 500 ; N n ; B 9 0 490 458 ;
+C 111 ; WX 500 ; N o ; B 30 -10 470 458 ;
+C 112 ; WX 500 ; N p ; B 2 -217 470 458 ;
+C 113 ; WX 500 ; N q ; B 24 -217 498 459 ;
+C 114 ; WX 333 ; N r ; B 4 0 335 458 ;
+C 115 ; WX 389 ; N s ; B 51 -10 348 458 ;
+C 116 ; WX 278 ; N t ; B 13 -10 279 580 ;
+C 117 ; WX 500 ; N u ; B 9 -10 479 448 ;
+C 118 ; WX 500 ; N v ; B 10 -10 468 448 ;
+C 119 ; WX 722 ; N w ; B 21 -10 694 448 ;
+C 120 ; WX 500 ; N x ; B 17 0 479 448 ;
+C 121 ; WX 500 ; N y ; B 15 -217 476 448 ;
+C 122 ; WX 444 ; N z ; B 25 0 418 448 ;
+C 123 ; WX 480 ; N braceleft ; B 110 -165 341 682 ;
+C 124 ; WX 200 ; N bar ; B 68 0 132 682 ;
+C 125 ; WX 480 ; N braceright ; B 139 -165 370 682 ;
+C 126 ; WX 541 ; N asciitilde ; B 18 176 522 347 ;
+C 161 ; WX 333 ; N exclamdown ; B 109 -217 224 458 ;
+C 162 ; WX 500 ; N cent ; B 53 -138 448 579 ;
+C 163 ; WX 500 ; N sterling ; B 11 -14 491 676 ;
+C 164 ; WX 167 ; N fraction ; B -170 -14 346 676 ;
+C 165 ; WX 500 ; N yen ; B -43 0 502 662 ;
+C 166 ; WX 500 ; N florin ; B 6 -185 490 676 ;
+C 167 ; WX 500 ; N section ; B 72 -148 426 676 ;
+C 168 ; WX 500 ; N currency ; B -2 99 503 600 ;
+C 169 ; WX 180 ; N quotesingle ; B 47 445 133 685 ;
+C 170 ; WX 444 ; N quotedblleft ; B 27 432 399 676 ;
+C 171 ; WX 500 ; N guillemotleft ; B 32 35 449 422 ;
+C 172 ; WX 333 ; N guilsinglleft ; B 45 35 271 422 ;
+C 173 ; WX 333 ; N guilsinglright ; B 62 36 288 423 ;
+C 174 ; WX 556 ; N fi ; B 33 0 521 678 ;
+C 175 ; WX 556 ; N fl ; B 29 0 521 682 ;
+C 177 ; WX 500 ; N endash ; B -7 201 507 250 ;
+C 178 ; WX 500 ; N dagger ; B 54 -149 440 676 ;
+C 179 ; WX 500 ; N daggerdbl ; B 54 -153 439 676 ;
+C 180 ; WX 250 ; N periodcentered ; B 68 204 183 319 ;
+C 182 ; WX 453 ; N paragraph ; B 0 -207 373 662 ;
+C 183 ; WX 350 ; N bullet ; B 50 175 300 425 ;
+C 184 ; WX 333 ; N quotesinglbase ; B 103 -143 242 101 ;
+C 185 ; WX 444 ; N quotedblbase ; B 45 -143 417 101 ;
+C 186 ; WX 444 ; N quotedblright ; B 45 432 417 676 ;
+C 187 ; WX 500 ; N guillemotright ; B 51 35 468 422 ;
+C 188 ; WX 1000 ; N ellipsis ; B 110 -14 891 101 ;
+C 189 ; WX 1000 ; N perthousand ; B 3 -14 1024 676 ;
+C 191 ; WX 444 ; N questiondown ; B 49 -217 395 458 ;
+C 193 ; WX 333 ; N grave ; B 16 507 243 678 ;
+C 194 ; WX 333 ; N acute ; B 93 507 317 678 ;
+C 195 ; WX 333 ; N circumflex ; B 11 507 323 674 ;
+C 196 ; WX 333 ; N tilde ; B 1 532 332 638 ;
+C 197 ; WX 333 ; N macron ; B 11 547 323 601 ;
+C 198 ; WX 333 ; N breve ; B 26 507 308 664 ;
+C 199 ; WX 333 ; N dotaccent ; B 116 523 216 623 ;
+C 200 ; WX 333 ; N dieresis ; B 18 523 316 623 ;
+C 202 ; WX 333 ; N ring ; B 67 483 266 682 ;
+C 203 ; WX 333 ; N cedilla ; B 53 -215 262 0 ;
+C 205 ; WX 333 ; N hungarumlaut ; B 8 528 372 700 ;
+C 206 ; WX 333 ; N ogonek ; B 68 -155 245 -10 ;
+C 207 ; WX 333 ; N caron ; B 11 507 323 674 ;
+C 208 ; WX 1000 ; N emdash ; B -8 201 1007 250 ;
+C 225 ; WX 889 ; N AE ; B 5 0 869 662 ;
+C 227 ; WX 276 ; N ordfeminine ; B 15 307 278 676 ;
+C 232 ; WX 611 ; N Lslash ; B 12 0 598 662 ;
+C 233 ; WX 722 ; N Oslash ; B 33 -80 688 734 ;
+C 234 ; WX 889 ; N OE ; B 21 -7 877 669 ;
+C 235 ; WX 310 ; N ordmasculine ; B 15 307 301 676 ;
+C 241 ; WX 667 ; N ae ; B 38 -10 634 458 ;
+C 245 ; WX 278 ; N dotlessi ; B 22 0 259 458 ;
+C 248 ; WX 278 ; N lslash ; B 20 0 259 682 ;
+C 249 ; WX 500 ; N oslash ; B 30 -108 470 549 ;
+C 250 ; WX 722 ; N oe ; B 30 -10 690 458 ;
+C 251 ; WX 500 ; N germandbls ; B 12 -10 468 682 ;
+C -1 ; WX 722 ; N Aacute ; B 15 0 706 892 ;
+C -1 ; WX 722 ; N Acircumflex ; B 15 0 706 888 ;
+C -1 ; WX 722 ; N Adieresis ; B 15 0 706 837 ;
+C -1 ; WX 722 ; N Agrave ; B 15 0 706 892 ;
+C -1 ; WX 722 ; N Aring ; B 15 0 706 896 ;
+C -1 ; WX 722 ; N Atilde ; B 15 0 706 852 ;
+C -1 ; WX 667 ; N Ccedilla ; B 33 -215 637 676 ;
+C -1 ; WX 611 ; N Eacute ; B 12 0 597 892 ;
+C -1 ; WX 611 ; N Ecircumflex ; B 12 0 597 888 ;
+C -1 ; WX 611 ; N Edieresis ; B 12 0 597 837 ;
+C -1 ; WX 611 ; N Egrave ; B 12 0 597 892 ;
+C -1 ; WX 722 ; N Eth ; B 20 0 689 662 ;
+C -1 ; WX 333 ; N Iacute ; B 18 0 317 892 ;
+C -1 ; WX 333 ; N Icircumflex ; B 11 0 323 888 ;
+C -1 ; WX 333 ; N Idieresis ; B 18 0 316 837 ;
+C -1 ; WX 333 ; N Igrave ; B 16 0 316 892 ;
+C -1 ; WX 722 ; N Ntilde ; B 12 -14 709 852 ;
+C -1 ; WX 722 ; N Oacute ; B 33 -14 688 892 ;
+C -1 ; WX 722 ; N Ocircumflex ; B 33 -14 688 888 ;
+C -1 ; WX 722 ; N Odieresis ; B 33 -14 688 837 ;
+C -1 ; WX 722 ; N Ograve ; B 33 -14 688 892 ;
+C -1 ; WX 722 ; N Otilde ; B 33 -14 688 852 ;
+C -1 ; WX 556 ; N Scaron ; B 42 -14 491 888 ;
+C -1 ; WX 556 ; N Thorn ; B 11 0 542 662 ;
+C -1 ; WX 722 ; N Uacute ; B 16 -14 705 892 ;
+C -1 ; WX 722 ; N Ucircumflex ; B 16 -14 705 888 ;
+C -1 ; WX 722 ; N Udieresis ; B 16 -14 705 837 ;
+C -1 ; WX 722 ; N Ugrave ; B 16 -14 705 892 ;
+C -1 ; WX 722 ; N Yacute ; B 22 0 703 892 ;
+C -1 ; WX 722 ; N Ydieresis ; B 22 0 703 837 ;
+C -1 ; WX 611 ; N Zcaron ; B 7 0 597 888 ;
+C -1 ; WX 444 ; N aacute ; B 37 -10 442 678 ;
+C -1 ; WX 444 ; N acircumflex ; B 37 -10 442 674 ;
+C -1 ; WX 444 ; N adieresis ; B 37 -10 442 623 ;
+C -1 ; WX 444 ; N agrave ; B 37 -10 442 678 ;
+C -1 ; WX 444 ; N aring ; B 37 -10 442 682 ;
+C -1 ; WX 444 ; N atilde ; B 37 -10 442 638 ;
+C -1 ; WX 200 ; N brokenbar ; B 68 0 132 682 ;
+C -1 ; WX 444 ; N ccedilla ; B 25 -215 412 458 ;
+C -1 ; WX 760 ; N copyright ; B 42 -14 717 676 ;
+C -1 ; WX 400 ; N degree ; B 50 376 350 676 ;
+C -1 ; WX 564 ; N divide ; B 30 10 534 512 ;
+C -1 ; WX 444 ; N eacute ; B 22 -10 421 678 ;
+C -1 ; WX 444 ; N ecircumflex ; B 22 -10 421 674 ;
+C -1 ; WX 444 ; N edieresis ; B 22 -10 421 623 ;
+C -1 ; WX 444 ; N egrave ; B 22 -10 421 678 ;
+C -1 ; WX 500 ; N eth ; B 30 -10 470 682 ;
+C -1 ; WX 278 ; N iacute ; B 22 0 290 678 ;
+C -1 ; WX 278 ; N icircumflex ; B -16 0 296 674 ;
+C -1 ; WX 278 ; N idieresis ; B -9 0 289 623 ;
+C -1 ; WX 278 ; N igrave ; B -11 0 259 678 ;
+C -1 ; WX 564 ; N logicalnot ; B 30 120 534 390 ;
+C -1 ; WX 564 ; N minus ; B 30 229 534 293 ;
+C -1 ; WX 500 ; N mu ; B 9 -223 479 448 ;
+C -1 ; WX 564 ; N multiply ; B 30 8 534 512 ;
+C -1 ; WX 500 ; N ntilde ; B 9 0 490 638 ;
+C -1 ; WX 500 ; N oacute ; B 30 -10 470 678 ;
+C -1 ; WX 500 ; N ocircumflex ; B 30 -10 470 674 ;
+C -1 ; WX 500 ; N odieresis ; B 30 -10 470 623 ;
+C -1 ; WX 500 ; N ograve ; B 30 -10 470 678 ;
+C -1 ; WX 750 ; N onehalf ; B 30 -14 720 676 ;
+C -1 ; WX 750 ; N onequarter ; B 30 -14 720 676 ;
+C -1 ; WX 300 ; N onesuperior ; B 58 270 242 676 ;
+C -1 ; WX 500 ; N otilde ; B 30 -10 470 638 ;
+C -1 ; WX 564 ; N plusminus ; B 30 0 534 612 ;
+C -1 ; WX 760 ; N registered ; B 43 -14 718 676 ;
+C -1 ; WX 389 ; N scaron ; B 39 -10 351 674 ;
+C -1 ; WX 500 ; N thorn ; B 2 -217 470 682 ;
+C -1 ; WX 750 ; N threequarters ; B 30 -14 720 676 ;
+C -1 ; WX 300 ; N threesuperior ; B 24 262 275 676 ;
+C -1 ; WX 980 ; N trademark ; B 35 258 945 662 ;
+C -1 ; WX 300 ; N twosuperior ; B 5 270 294 676 ;
+C -1 ; WX 500 ; N uacute ; B 9 -10 479 678 ;
+C -1 ; WX 500 ; N ucircumflex ; B 9 -10 479 674 ;
+C -1 ; WX 500 ; N udieresis ; B 9 -10 479 623 ;
+C -1 ; WX 500 ; N ugrave ; B 9 -10 479 678 ;
+C -1 ; WX 500 ; N yacute ; B 15 -217 476 678 ;
+C -1 ; WX 500 ; N ydieresis ; B 15 -217 476 623 ;
+C -1 ; WX 444 ; N zcaron ; B 25 0 418 674 ;
+EndCharMetrics
+StartKernData
+StartKernPairs 113
+
+KPX A y -92
+KPX A w -92
+KPX A v -74
+KPX A space -55
+KPX A quoteright -111
+KPX A Y -92
+KPX A W -80
+KPX A V -129
+KPX A T -111
+
+KPX F period -80
+KPX F comma -80
+KPX F A -74
+
+KPX L y -55
+KPX L space -37
+KPX L quoteright -92
+KPX L Y -100
+KPX L W -74
+KPX L V -92
+KPX L T -92
+
+KPX P space -37
+KPX P period -111
+KPX P comma -111
+KPX P A -92
+
+KPX R y -40
+KPX R Y -55
+KPX R W -55
+KPX R V -80
+KPX R T -60
+
+KPX T y -70
+KPX T w -70
+KPX T u -35
+KPX T space -18
+KPX T semicolon -55
+KPX T s -70
+KPX T r -35
+KPX T period -74
+KPX T o -70
+KPX T i -35
+KPX T hyphen -92
+KPX T e -70
+KPX T comma -74
+KPX T colon -50
+KPX T c -70
+KPX T a -70
+KPX T O -18
+KPX T A -80
+
+KPX V y -111
+KPX V u -60
+KPX V space -18
+KPX V semicolon -74
+KPX V r -60
+KPX V period -129
+KPX V o -129
+KPX V i -60
+KPX V hyphen -92
+KPX V e -111
+KPX V comma -129
+KPX V colon -74
+KPX V a -111
+KPX V A -129
+
+KPX W y -60
+KPX W u -40
+KPX W space -18
+KPX W semicolon -37
+KPX W r -40
+KPX W period -92
+KPX W o -80
+KPX W i -40
+KPX W hyphen -55
+KPX W e -80
+KPX W comma -92
+KPX W colon -37
+KPX W a -80
+KPX W A -111
+
+KPX Y v -100
+KPX Y u -111
+KPX Y space -37
+KPX Y semicolon -92
+KPX Y q -111
+KPX Y period -129
+KPX Y p -92
+KPX Y o -100
+KPX Y i -55
+KPX Y hyphen -111
+KPX Y e -100
+KPX Y comma -129
+KPX Y colon -92
+KPX Y a -100
+KPX Y A -111
+
+KPX f quoteright 55
+KPX f f -18
+
+KPX one one -37
+
+KPX quoteleft quoteleft -74
+
+KPX quoteright t -18
+KPX quoteright space -74
+KPX quoteright s -55
+KPX quoteright quoteright -74
+
+KPX r quoteright 37
+KPX r period -55
+KPX r hyphen -20
+KPX r g -18
+KPX r comma -40
+
+KPX space Y -37
+KPX space W -18
+KPX space V -18
+KPX space T -18
+KPX space A -55
+
+KPX v period -65
+KPX v comma -65
+
+KPX w period -65
+KPX w comma -65
+
+KPX y period -65
+KPX y comma -65
+EndKernPairs
+EndKernData
+StartComposites 58
+CC Zcaron 2 ; PCC Z 0 0 ; PCC caron 139 214 ;
+CC zcaron 2 ; PCC z 0 0 ; PCC caron 55 0 ;
+CC Scaron 2 ; PCC S 0 0 ; PCC caron 111 214 ;
+CC scaron 2 ; PCC s 0 0 ; PCC caron 28 0 ;
+CC Ccedilla 2 ; PCC C 0 0 ; PCC cedilla 167 0 ;
+CC ccedilla 2 ; PCC c 0 0 ; PCC cedilla 55 0 ;
+CC Yacute 2 ; PCC Y 0 0 ; PCC acute 194 214 ;
+CC yacute 2 ; PCC y 0 0 ; PCC acute 83 0 ;
+CC Ydieresis 2 ; PCC Y 0 0 ; PCC dieresis 194 214 ;
+CC ydieresis 2 ; PCC y 0 0 ; PCC dieresis 83 0 ;
+CC Uacute 2 ; PCC U 0 0 ; PCC acute 194 214 ;
+CC Ucircumflex 2 ; PCC U 0 0 ; PCC circumflex 194 214 ;
+CC Udieresis 2 ; PCC U 0 0 ; PCC dieresis 194 214 ;
+CC Ugrave 2 ; PCC U 0 0 ; PCC grave 194 214 ;
+CC uacute 2 ; PCC u 0 0 ; PCC acute 83 0 ;
+CC ucircumflex 2 ; PCC u 0 0 ; PCC circumflex 83 0 ;
+CC udieresis 2 ; PCC u 0 0 ; PCC dieresis 83 0 ;
+CC ugrave 2 ; PCC u 0 0 ; PCC grave 83 0 ;
+CC Iacute 2 ; PCC I 0 0 ; PCC acute 0 214 ;
+CC Icircumflex 2 ; PCC I 0 0 ; PCC circumflex 0 214 ;
+CC Idieresis 2 ; PCC I 0 0 ; PCC dieresis 0 214 ;
+CC Igrave 2 ; PCC I 0 0 ; PCC grave 0 214 ;
+CC iacute 2 ; PCC dotlessi 0 0 ; PCC acute -27 0 ;
+CC icircumflex 2 ; PCC dotlessi 0 0 ; PCC circumflex -27 0 ;
+CC idieresis 2 ; PCC dotlessi 0 0 ; PCC dieresis -27 0 ;
+CC igrave 2 ; PCC dotlessi 0 0 ; PCC grave -27 0 ;
+CC Eacute 2 ; PCC E 0 0 ; PCC acute 139 214 ;
+CC Ecircumflex 2 ; PCC E 0 0 ; PCC circumflex 139 214 ;
+CC Edieresis 2 ; PCC E 0 0 ; PCC dieresis 139 214 ;
+CC Egrave 2 ; PCC E 0 0 ; PCC grave 139 214 ;
+CC eacute 2 ; PCC e 0 0 ; PCC acute 55 0 ;
+CC ecircumflex 2 ; PCC e 0 0 ; PCC circumflex 55 0 ;
+CC edieresis 2 ; PCC e 0 0 ; PCC dieresis 55 0 ;
+CC egrave 2 ; PCC e 0 0 ; PCC grave 55 0 ;
+CC Aacute 2 ; PCC A 0 0 ; PCC acute 194 214 ;
+CC Acircumflex 2 ; PCC A 0 0 ; PCC circumflex 194 214 ;
+CC Adieresis 2 ; PCC A 0 0 ; PCC dieresis 194 214 ;
+CC Agrave 2 ; PCC A 0 0 ; PCC grave 194 214 ;
+CC aacute 2 ; PCC a 0 0 ; PCC acute 55 0 ;
+CC acircumflex 2 ; PCC a 0 0 ; PCC circumflex 55 0 ;
+CC adieresis 2 ; PCC a 0 0 ; PCC dieresis 55 0 ;
+CC agrave 2 ; PCC a 0 0 ; PCC grave 55 0 ;
+CC Oacute 2 ; PCC O 0 0 ; PCC acute 194 214 ;
+CC Ocircumflex 2 ; PCC O 0 0 ; PCC circumflex 194 214 ;
+CC Odieresis 2 ; PCC O 0 0 ; PCC dieresis 194 214 ;
+CC Ograve 2 ; PCC O 0 0 ; PCC grave 194 214 ;
+CC oacute 2 ; PCC o 0 0 ; PCC acute 83 0 ;
+CC ocircumflex 2 ; PCC o 0 0 ; PCC circumflex 83 0 ;
+CC odieresis 2 ; PCC o 0 0 ; PCC dieresis 83 0 ;
+CC ograve 2 ; PCC o 0 0 ; PCC grave 83 0 ;
+CC Atilde 2 ; PCC A 0 0 ; PCC tilde 194 214 ;
+CC atilde 2 ; PCC a 0 0 ; PCC tilde 55 0 ;
+CC Ntilde 2 ; PCC N 0 0 ; PCC tilde 194 214 ;
+CC ntilde 2 ; PCC n 0 0 ; PCC tilde 83 0 ;
+CC Otilde 2 ; PCC O 0 0 ; PCC tilde 194 214 ;
+CC otilde 2 ; PCC o 0 0 ; PCC tilde 83 0 ;
+CC Aring 2 ; PCC A 0 0 ; PCC ring 194 214 ;
+CC aring 2 ; PCC a 0 0 ; PCC ring 55 0 ;
+EndComposites
+EndFontMetrics
diff --git a/collects/afm/ZapfChancery-MediumItalic.afm b/collects/afm/ZapfChancery-MediumItalic.afm
new file mode 100644
index 0000000000..80876e7d4e
--- /dev/null
+++ b/collects/afm/ZapfChancery-MediumItalic.afm
@@ -0,0 +1,437 @@
+StartFontMetrics 2.0
+Comment Copyright (c) 1984 Adobe Systems Incorporated.  All Rights Reserved.
+Comment Creation Date:Tue Apr 21 09:12:34 PST 1987
+FontName ZapfChancery-MediumItalic
+EncodingScheme AdobeStandardEncoding
+FullName ITC Zapf Chancery Medium Italic
+FamilyName ITC Zapf Chancery
+Weight Medium
+ItalicAngle -14.0
+IsFixedPitch false
+UnderlinePosition -120
+UnderlineThickness 50
+Version 001.003
+Notice ITC Zapf Chancery is a registered trademark of International Typeface Corporation.
+FontBBox -133 -257 1078 811
+CapHeight 587
+XHeight 408
+Descender -248
+Ascender 678
+StartCharMetrics 228
+C 32 ; WX 220 ; N space ; B 0 0 0 0 ;
+C 33 ; WX 280 ; N exclam ; B 109 -9 347 588 ;
+C 34 ; WX 220 ; N quotedbl ; B 170 494 333 681 ;
+C 35 ; WX 440 ; N numbersign ; B 63 -1 596 575 ;
+C 36 ; WX 440 ; N dollar ; B 60 -145 461 675 ;
+C 37 ; WX 680 ; N percent ; B 162 -7 701 585 ;
+C 38 ; WX 780 ; N ampersand ; B 121 -15 855 558 ;
+C 39 ; WX 240 ; N quoteright ; B 228 455 358 675 ;
+C 40 ; WX 260 ; N parenleft ; B 116 -165 412 667 ;
+C 41 ; WX 220 ; N parenright ; B 17 -164 313 668 ;
+C 42 ; WX 420 ; N asterisk ; B 220 376 512 676 ;
+C 43 ; WX 520 ; N plus ; B 103 0 513 410 ;
+C 44 ; WX 220 ; N comma ; B 30 -98 215 171 ;
+C 45 ; WX 280 ; N hyphen ; B 115 173 300 236 ;
+C 46 ; WX 220 ; N period ; B 107 -9 228 127 ;
+C 47 ; WX 340 ; N slash ; B -6 -168 535 677 ;
+C 48 ; WX 440 ; N zero ; B 94 -7 489 576 ;
+C 49 ; WX 440 ; N one ; B 82 1 434 584 ;
+C 50 ; WX 440 ; N two ; B 47 -17 469 572 ;
+C 51 ; WX 440 ; N three ; B 36 -6 457 576 ;
+C 52 ; WX 440 ; N four ; B 69 -26 455 585 ;
+C 53 ; WX 440 ; N five ; B 67 -8 565 641 ;
+C 54 ; WX 440 ; N six ; B 95 -8 532 585 ;
+C 55 ; WX 440 ; N seven ; B 165 -18 541 612 ;
+C 56 ; WX 440 ; N eight ; B 75 -9 494 573 ;
+C 57 ; WX 440 ; N nine ; B 42 -8 480 576 ;
+C 58 ; WX 260 ; N colon ; B 98 -9 289 408 ;
+C 59 ; WX 240 ; N semicolon ; B 29 -98 277 408 ;
+C 60 ; WX 520 ; N less ; B 120 -17 557 429 ;
+C 61 ; WX 520 ; N equal ; B 108 113 518 297 ;
+C 62 ; WX 520 ; N greater ; B 119 -17 556 429 ;
+C 63 ; WX 380 ; N question ; B 130 -9 497 583 ;
+C 64 ; WX 700 ; N at ; B 102 -15 765 690 ;
+C 65 ; WX 620 ; N A ; B 23 -16 687 593 ;
+C 66 ; WX 600 ; N B ; B 75 0 642 618 ;
+C 67 ; WX 520 ; N C ; B 88 -73 635 592 ;
+C 68 ; WX 700 ; N D ; B 86 0 759 618 ;
+C 69 ; WX 620 ; N E ; B 76 -8 668 587 ;
+C 70 ; WX 580 ; N F ; B 60 -114 733 621 ;
+C 71 ; WX 620 ; N G ; B 118 -236 670 592 ;
+C 72 ; WX 680 ; N H ; B 33 -7 908 681 ;
+C 73 ; WX 380 ; N I ; B 81 0 481 573 ;
+C 74 ; WX 400 ; N J ; B 1 -122 491 573 ;
+C 75 ; WX 660 ; N K ; B 88 -143 851 578 ;
+C 76 ; WX 580 ; N L ; B 33 -6 631 577 ;
+C 77 ; WX 840 ; N M ; B 58 -9 1009 671 ;
+C 78 ; WX 700 ; N N ; B 40 -158 915 682 ;
+C 79 ; WX 600 ; N O ; B 104 -13 652 589 ;
+C 80 ; WX 540 ; N P ; B 37 2 645 602 ;
+C 81 ; WX 600 ; N Q ; B 104 -189 851 589 ;
+C 82 ; WX 600 ; N R ; B 38 -147 826 615 ;
+C 83 ; WX 460 ; N S ; B 0 -67 517 590 ;
+C 84 ; WX 500 ; N T ; B 58 0 718 650 ;
+C 85 ; WX 740 ; N U ; B 116 -10 778 581 ;
+C 86 ; WX 640 ; N V ; B 104 -8 809 689 ;
+C 87 ; WX 880 ; N W ; B 104 -17 1035 677 ;
+C 88 ; WX 560 ; N X ; B 0 -13 671 580 ;
+C 89 ; WX 560 ; N Y ; B 31 -152 763 608 ;
+C 90 ; WX 620 ; N Z ; B 62 -18 675 598 ;
+C 91 ; WX 240 ; N bracketleft ; B 47 -164 404 667 ;
+C 92 ; WX 480 ; N backslash ; B 185 0 484 578 ;
+C 93 ; WX 320 ; N bracketright ; B 23 -164 381 667 ;
+C 94 ; WX 520 ; N asciicircum ; B 212 447 472 681 ;
+C 95 ; WX 500 ; N underscore ; B 0 -145 500 -95 ;
+C 96 ; WX 240 ; N quoteleft ; B 229 435 384 675 ;
+C 97 ; WX 420 ; N a ; B 87 -11 492 415 ;
+C 98 ; WX 420 ; N b ; B 87 -17 466 678 ;
+C 99 ; WX 340 ; N c ; B 87 -13 383 411 ;
+C 100 ; WX 440 ; N d ; B 87 -12 629 678 ;
+C 101 ; WX 340 ; N e ; B 87 -12 380 412 ;
+C 102 ; WX 320 ; N f ; B -99 -247 541 680 ; L i fi ; L l fl ;
+C 103 ; WX 400 ; N g ; B -78 -248 481 409 ;
+C 104 ; WX 440 ; N h ; B 75 -15 506 679 ;
+C 105 ; WX 240 ; N i ; B 81 -12 311 617 ;
+C 106 ; WX 220 ; N j ; B -133 -247 303 617 ;
+C 107 ; WX 440 ; N k ; B 87 -148 655 675 ;
+C 108 ; WX 240 ; N l ; B 87 -11 434 681 ;
+C 109 ; WX 620 ; N m ; B 81 -10 693 413 ;
+C 110 ; WX 460 ; N n ; B 81 -15 520 411 ;
+C 111 ; WX 400 ; N o ; B 87 -13 449 411 ;
+C 112 ; WX 440 ; N p ; B -8 -248 482 411 ;
+C 113 ; WX 400 ; N q ; B 87 -250 485 480 ;
+C 114 ; WX 300 ; N r ; B 81 -10 409 411 ;
+C 115 ; WX 320 ; N s ; B 41 -15 377 410 ;
+C 116 ; WX 320 ; N t ; B 96 -12 392 504 ;
+C 117 ; WX 460 ; N u ; B 82 -12 518 416 ;
+C 118 ; WX 440 ; N v ; B 87 -13 510 438 ;
+C 119 ; WX 680 ; N w ; B 87 -13 757 445 ;
+C 120 ; WX 420 ; N x ; B 70 -159 583 408 ;
+C 121 ; WX 400 ; N y ; B 11 -249 473 415 ;
+C 122 ; WX 440 ; N z ; B 46 -12 475 426 ;
+C 123 ; WX 240 ; N braceleft ; B 105 -164 405 668 ;
+C 124 ; WX 520 ; N bar ; B 314 0 363 578 ;
+C 125 ; WX 240 ; N braceright ; B 10 -164 307 668 ;
+C 126 ; WX 520 ; N asciitilde ; B 86 146 526 261 ;
+C 161 ; WX 280 ; N exclamdown ; B 57 -187 295 410 ;
+C 162 ; WX 440 ; N cent ; B 127 -76 453 647 ;
+C 163 ; WX 440 ; N sterling ; B 4 -54 436 578 ;
+C 164 ; WX 60 ; N fraction ; B -115 -4 280 585 ;
+C 165 ; WX 440 ; N yen ; B -11 0 623 578 ;
+C 166 ; WX 440 ; N florin ; B -49 -247 587 682 ;
+C 167 ; WX 420 ; N section ; B 63 -165 464 576 ;
+C 168 ; WX 440 ; N currency ; B 50 106 480 532 ;
+C 169 ; WX 160 ; N quotesingle ; B 170 494 259 681 ;
+C 170 ; WX 340 ; N quotedblleft ; B 229 435 500 675 ;
+C 171 ; WX 340 ; N guillemotleft ; B 98 -9 404 414 ;
+C 172 ; WX 240 ; N guilsinglleft ; B 98 -9 285 415 ;
+C 173 ; WX 260 ; N guilsinglright ; B 86 -2 284 424 ;
+C 174 ; WX 520 ; N fi ; B -104 -248 606 681 ;
+C 175 ; WX 520 ; N fl ; B -105 -247 710 690 ;
+C 177 ; WX 500 ; N endash ; B 31 173 578 236 ;
+C 178 ; WX 460 ; N dagger ; B 98 -138 529 607 ;
+C 179 ; WX 480 ; N daggerdbl ; B 98 -138 529 608 ;
+C 180 ; WX 220 ; N periodcentered ; B 108 147 229 283 ;
+C 182 ; WX 500 ; N paragraph ; B 29 -247 650 585 ;
+C 183 ; WX 600 ; N bullet ; B 228 117 568 458 ;
+C 184 ; WX 180 ; N quotesinglbase ; B 40 -109 170 111 ;
+C 185 ; WX 280 ; N quotedblbase ; B 41 -109 286 111 ;
+C 186 ; WX 360 ; N quotedblright ; B 228 455 473 675 ;
+C 187 ; WX 380 ; N guillemotright ; B 87 -2 407 424 ;
+C 188 ; WX 1000 ; N ellipsis ; B 106 -9 893 127 ;
+C 189 ; WX 960 ; N perthousand ; B 162 -7 975 585 ;
+C 191 ; WX 400 ; N questiondown ; B 57 -181 425 410 ;
+C 193 ; WX 220 ; N grave ; B 173 444 281 639 ;
+C 194 ; WX 300 ; N acute ; B 205 444 388 639 ;
+C 195 ; WX 340 ; N circumflex ; B 183 442 397 640 ;
+C 196 ; WX 440 ; N tilde ; B 183 481 513 602 ;
+C 197 ; WX 440 ; N macron ; B 183 513 515 569 ;
+C 198 ; WX 440 ; N breve ; B 183 486 516 597 ;
+C 199 ; WX 220 ; N dotaccent ; B 206 480 309 602 ;
+C 200 ; WX 360 ; N dieresis ; B 183 480 419 602 ;
+C 202 ; WX 300 ; N ring ; B 228 452 409 631 ;
+C 203 ; WX 300 ; N cedilla ; B 41 -189 216 6 ;
+C 205 ; WX 400 ; N hungarumlaut ; B 183 444 463 639 ;
+C 206 ; WX 280 ; N ogonek ; B 58 -193 216 -41 ;
+C 207 ; WX 340 ; N caron ; B 234 442 447 640 ;
+C 208 ; WX 1000 ; N emdash ; B 31 173 1078 236 ;
+C 225 ; WX 740 ; N AE ; B 32 -5 798 571 ;
+C 227 ; WX 260 ; N ordfeminine ; B 81 253 324 576 ;
+C 232 ; WX 580 ; N Lslash ; B 33 -6 631 577 ;
+C 233 ; WX 660 ; N Oslash ; B 110 -128 707 687 ;
+C 234 ; WX 820 ; N OE ; B 104 -12 870 588 ;
+C 235 ; WX 260 ; N ordmasculine ; B 98 253 323 576 ;
+C 241 ; WX 540 ; N ae ; B 87 -13 588 441 ;
+C 245 ; WX 240 ; N dotlessi ; B 81 -11 311 412 ;
+C 248 ; WX 300 ; N lslash ; B 87 -11 491 681 ;
+C 249 ; WX 440 ; N oslash ; B 92 -147 467 545 ;
+C 250 ; WX 560 ; N oe ; B 88 -13 602 409 ;
+C 251 ; WX 420 ; N germandbls ; B -127 -248 506 681 ;
+C -1 ; WX 620 ; N Aacute ; B 23 -16 687 810 ;
+C -1 ; WX 620 ; N Acircumflex ; B 23 -16 687 811 ;
+C -1 ; WX 620 ; N Adieresis ; B 23 -16 699 773 ;
+C -1 ; WX 620 ; N Agrave ; B 23 -16 687 810 ;
+C -1 ; WX 620 ; N Aring ; B 23 -16 687 802 ;
+C -1 ; WX 620 ; N Atilde ; B 23 -16 753 773 ;
+C -1 ; WX 520 ; N Ccedilla ; B 88 -257 635 592 ;
+C -1 ; WX 620 ; N Eacute ; B 76 -8 668 810 ;
+C -1 ; WX 620 ; N Ecircumflex ; B 76 -8 668 811 ;
+C -1 ; WX 620 ; N Edieresis ; B 76 -8 668 773 ;
+C -1 ; WX 620 ; N Egrave ; B 76 -8 668 810 ;
+C -1 ; WX 700 ; N Eth ; B 86 0 759 618 ;
+C -1 ; WX 380 ; N Iacute ; B 81 0 528 810 ;
+C -1 ; WX 380 ; N Icircumflex ; B 81 0 487 811 ;
+C -1 ; WX 380 ; N Idieresis ; B 81 0 481 773 ;
+C -1 ; WX 380 ; N Igrave ; B 81 0 481 810 ;
+C -1 ; WX 700 ; N Ntilde ; B 40 -158 915 773 ;
+C -1 ; WX 600 ; N Oacute ; B 104 -13 652 810 ;
+C -1 ; WX 600 ; N Ocircumflex ; B 104 -13 652 811 ;
+C -1 ; WX 600 ; N Odieresis ; B 104 -13 652 773 ;
+C -1 ; WX 600 ; N Ograve ; B 104 -13 652 810 ;
+C -1 ; WX 600 ; N Otilde ; B 104 -13 678 773 ;
+C -1 ; WX 460 ; N Scaron ; B 0 -67 607 811 ;
+C -1 ; WX 540 ; N Thorn ; B 37 2 619 573 ;
+C -1 ; WX 740 ; N Uacute ; B 116 -10 778 810 ;
+C -1 ; WX 740 ; N Ucircumflex ; B 116 -10 778 811 ;
+C -1 ; WX 740 ; N Udieresis ; B 116 -10 778 773 ;
+C -1 ; WX 740 ; N Ugrave ; B 116 -10 778 810 ;
+C -1 ; WX 560 ; N Yacute ; B 31 -152 763 810 ;
+C -1 ; WX 560 ; N Ydieresis ; B 31 -152 763 773 ;
+C -1 ; WX 620 ; N Zcaron ; B 62 -18 675 811 ;
+C -1 ; WX 420 ; N aacute ; B 87 -11 492 639 ;
+C -1 ; WX 420 ; N acircumflex ; B 87 -11 492 640 ;
+C -1 ; WX 420 ; N adieresis ; B 87 -11 492 602 ;
+C -1 ; WX 420 ; N agrave ; B 87 -11 492 639 ;
+C -1 ; WX 420 ; N aring ; B 87 -11 492 631 ;
+C -1 ; WX 420 ; N atilde ; B 87 -11 503 602 ;
+C -1 ; WX 520 ; N brokenbar ; B 314 0 363 578 ;
+C -1 ; WX 340 ; N ccedilla ; B 61 -189 383 411 ;
+C -1 ; WX 740 ; N copyright ; B 136 -10 830 683 ;
+C -1 ; WX 400 ; N degree ; B 190 336 430 576 ;
+C -1 ; WX 520 ; N divide ; B 103 0 513 410 ;
+C -1 ; WX 340 ; N eacute ; B 87 -12 408 639 ;
+C -1 ; WX 340 ; N ecircumflex ; B 87 -12 397 640 ;
+C -1 ; WX 340 ; N edieresis ; B 87 -12 409 602 ;
+C -1 ; WX 340 ; N egrave ; B 87 -12 380 639 ;
+C -1 ; WX 400 ; N eth ; B 87 -13 557 681 ;
+C -1 ; WX 240 ; N iacute ; B 81 -11 358 639 ;
+C -1 ; WX 240 ; N icircumflex ; B 81 -11 347 640 ;
+C -1 ; WX 240 ; N idieresis ; B 81 -11 359 602 ;
+C -1 ; WX 240 ; N igrave ; B 81 -11 311 639 ;
+C -1 ; WX 520 ; N logicalnot ; B 55 33 559 297 ;
+C -1 ; WX 520 ; N minus ; B 55 180 559 230 ;
+C -1 ; WX 460 ; N mu ; B 15 -249 518 416 ;
+C -1 ; WX 520 ; N multiply ; B 103 0 513 410 ;
+C -1 ; WX 460 ; N ntilde ; B 81 -15 523 602 ;
+C -1 ; WX 400 ; N oacute ; B 87 -13 449 639 ;
+C -1 ; WX 400 ; N ocircumflex ; B 87 -13 449 640 ;
+C -1 ; WX 400 ; N odieresis ; B 87 -13 449 602 ;
+C -1 ; WX 400 ; N ograve ; B 87 -13 449 639 ;
+C -1 ; WX 660 ; N onehalf ; B 96 -9 659 585 ;
+C -1 ; WX 660 ; N onequarter ; B 96 -16 653 585 ;
+C -1 ; WX 264 ; N onesuperior ; B 86 230 314 579 ;
+C -1 ; WX 400 ; N otilde ; B 87 -13 493 602 ;
+C -1 ; WX 520 ; N plusminus ; B 103 0 513 410 ;
+C -1 ; WX 740 ; N registered ; B 135 -10 828 683 ;
+C -1 ; WX 320 ; N scaron ; B 41 -15 437 640 ;
+C -1 ; WX 440 ; N thorn ; B -8 -248 482 678 ;
+C -1 ; WX 660 ; N threequarters ; B 79 -16 663 585 ;
+C -1 ; WX 264 ; N threesuperior ; B 69 224 343 573 ;
+C -1 ; WX 1000 ; N trademark ; B 165 269 1050 673 ;
+C -1 ; WX 264 ; N twosuperior ; B 80 219 354 572 ;
+C -1 ; WX 460 ; N uacute ; B 82 -12 518 639 ;
+C -1 ; WX 460 ; N ucircumflex ; B 82 -12 518 640 ;
+C -1 ; WX 460 ; N udieresis ; B 82 -12 518 602 ;
+C -1 ; WX 460 ; N ugrave ; B 82 -12 518 639 ;
+C -1 ; WX 400 ; N yacute ; B 11 -249 473 639 ;
+C -1 ; WX 400 ; N ydieresis ; B 11 -249 473 602 ;
+C -1 ; WX 440 ; N zcaron ; B 46 -12 497 640 ;
+EndCharMetrics
+StartKernData
+StartKernPairs 104
+
+KPX A y 3
+KPX A w -12
+KPX A v -10
+KPX A Y 19
+KPX A W -21
+KPX A V -20
+KPX A T 25
+
+KPX F period -137
+KPX F comma -63
+KPX F A -64
+
+KPX L y 0
+KPX L Y -20
+KPX L W -40
+KPX L V -40
+KPX L T -20
+
+KPX P period -66
+KPX P comma -69
+KPX P A 16
+
+KPX R y 32
+KPX R Y 70
+KPX R W 6
+KPX R V 6
+KPX R T 51
+
+KPX S t -20
+KPX S p -10
+
+KPX T y 2
+KPX T w 0
+KPX T u -1
+KPX T semicolon 50
+KPX T s 0
+KPX T r -2
+KPX T period -2
+KPX T o -19
+KPX T i 40
+KPX T hyphen -10
+KPX T e -15
+KPX T comma 29
+KPX T colon 34
+KPX T c -6
+KPX T a -8
+KPX T A 15
+
+KPX V y 0
+KPX V u 0
+KPX V r 0
+KPX V o -50
+KPX V i 21
+KPX V e -50
+KPX V a -50
+KPX V semicolon 27
+KPX V period -72
+KPX V hyphen -10
+KPX V comma -16
+KPX V colon -11
+KPX V A -14
+
+KPX W y 15
+KPX W u 15
+KPX W semicolon 4
+KPX W r 15
+KPX W period -96
+KPX W o -25
+KPX W i 15
+KPX W hyphen -10
+KPX W e -25
+KPX W comma -38
+KPX W colon -24
+KPX W a -25
+KPX W A -7
+
+KPX Y v -22
+KPX Y u -8
+KPX Y semicolon 25
+KPX Y q -64
+KPX Y period -65
+KPX Y p -4
+KPX Y o -65
+KPX Y i 40
+KPX Y hyphen -10
+KPX Y e -60
+KPX Y comma 0
+KPX Y colon -4
+KPX Y a -63
+KPX Y A -24
+
+KPX a t -10
+
+KPX d t -10
+
+KPX f f -57
+
+KPX g g 20
+
+KPX o t -20
+
+KPX r r 20
+KPX r q 0
+KPX r period -45
+KPX r o -8
+KPX r n 45
+KPX r m 45
+KPX r l 10
+KPX r hyphen 10
+KPX r h 3
+KPX r g -30
+KPX r f 11
+KPX r e -12
+KPX r d -25
+KPX r comma -40
+KPX r c -16
+
+KPX s t -20
+
+KPX v y 20
+
+KPX w e 20
+EndKernPairs
+EndKernData
+StartComposites 58
+CC Zcaron 2 ; PCC Z 0 0 ; PCC caron 195 172 ;
+CC zcaron 2 ; PCC z 0 0 ; PCC caron 50 0 ;
+CC Scaron 2 ; PCC S 0 0 ; PCC caron 160 172 ;
+CC scaron 2 ; PCC s 0 0 ; PCC caron -10 0 ;
+CC Ccedilla 2 ; PCC C 0 0 ; PCC cedilla 137 -68 ;
+CC ccedilla 2 ; PCC c 0 0 ; PCC cedilla 20 0 ;
+CC Yacute 2 ; PCC Y 0 0 ; PCC acute 130 172 ;
+CC yacute 2 ; PCC y 0 0 ; PCC acute 50 0 ;
+CC Ydieresis 2 ; PCC Y 0 0 ; PCC dieresis 250 172 ;
+CC ydieresis 2 ; PCC y 0 0 ; PCC dieresis 20 0 ;
+CC Uacute 2 ; PCC U 0 0 ; PCC acute 320 172 ;
+CC Ucircumflex 2 ; PCC U 0 0 ; PCC circumflex 300 172 ;
+CC Udieresis 2 ; PCC U 0 0 ; PCC dieresis 320 172 ;
+CC Ugrave 2 ; PCC U 0 0 ; PCC grave 330 172 ;
+CC uacute 2 ; PCC u 0 0 ; PCC acute 80 0 ;
+CC ucircumflex 2 ; PCC u 0 0 ; PCC circumflex 60 0 ;
+CC udieresis 2 ; PCC u 0 0 ; PCC dieresis 50 0 ;
+CC ugrave 2 ; PCC u 0 0 ; PCC grave 120 0 ;
+CC Iacute 2 ; PCC I 0 0 ; PCC acute 140 172 ;
+CC Icircumflex 2 ; PCC I 0 0 ; PCC circumflex 90 172 ;
+CC Idieresis 2 ; PCC I 0 0 ; PCC dieresis 60 172 ;
+CC Igrave 2 ; PCC I 0 0 ; PCC grave 120 172 ;
+CC iacute 2 ; PCC dotlessi 0 0 ; PCC acute -30 0 ;
+CC icircumflex 2 ; PCC dotlessi 0 0 ; PCC circumflex -50 0 ;
+CC idieresis 2 ; PCC dotlessi 0 0 ; PCC dieresis -60 0 ;
+CC igrave 2 ; PCC dotlessi 0 0 ; PCC grave 10 0 ;
+CC Eacute 2 ; PCC E 0 0 ; PCC acute 260 172 ;
+CC Ecircumflex 2 ; PCC E 0 0 ; PCC circumflex 210 172 ;
+CC Edieresis 2 ; PCC E 0 0 ; PCC dieresis 205 172 ;
+CC Egrave 2 ; PCC E 0 0 ; PCC grave 255 172 ;
+CC eacute 2 ; PCC e 0 0 ; PCC acute 20 0 ;
+CC ecircumflex 2 ; PCC e 0 0 ; PCC circumflex 0 0 ;
+CC edieresis 2 ; PCC e 0 0 ; PCC dieresis -10 0 ;
+CC egrave 2 ; PCC e 0 0 ; PCC grave 60 0 ;
+CC Aacute 2 ; PCC A 0 0 ; PCC acute 260 172 ;
+CC Acircumflex 2 ; PCC A 0 0 ; PCC circumflex 255 172 ;
+CC Adieresis 2 ; PCC A 0 0 ; PCC dieresis 280 172 ;
+CC Agrave 2 ; PCC A 0 0 ; PCC grave 300 172 ;
+CC aacute 2 ; PCC a 0 0 ; PCC acute 60 0 ;
+CC acircumflex 2 ; PCC a 0 0 ; PCC circumflex 40 0 ;
+CC adieresis 2 ; PCC a 0 0 ; PCC dieresis 30 0 ;
+CC agrave 2 ; PCC a 0 0 ; PCC grave 100 0 ;
+CC Oacute 2 ; PCC O 0 0 ; PCC acute 250 172 ;
+CC Ocircumflex 2 ; PCC O 0 0 ; PCC circumflex 200 172 ;
+CC Odieresis 2 ; PCC O 0 0 ; PCC dieresis 225 172 ;
+CC Ograve 2 ; PCC O 0 0 ; PCC grave 245 172 ;
+CC oacute 2 ; PCC o 0 0 ; PCC acute 50 0 ;
+CC ocircumflex 2 ; PCC o 0 0 ; PCC circumflex 30 0 ;
+CC odieresis 2 ; PCC o 0 0 ; PCC dieresis 20 0 ;
+CC ograve 2 ; PCC o 0 0 ; PCC grave 90 0 ;
+CC Atilde 2 ; PCC A 0 0 ; PCC tilde 240 172 ;
+CC atilde 2 ; PCC a 0 0 ; PCC tilde -10 0 ;
+CC Ntilde 2 ; PCC N 0 0 ; PCC tilde 280 172 ;
+CC ntilde 2 ; PCC n 0 0 ; PCC tilde 10 0 ;
+CC Otilde 2 ; PCC O 0 0 ; PCC tilde 165 172 ;
+CC otilde 2 ; PCC o 0 0 ; PCC tilde -20 0 ;
+CC Aring 2 ; PCC A 0 0 ; PCC ring 275 172 ;
+CC aring 2 ; PCC a 0 0 ; PCC ring 60 0 ;
+EndComposites
+EndFontMetrics
diff --git a/collects/afm/glyphlist.txt b/collects/afm/glyphlist.txt
new file mode 100644
index 0000000000..a1a22702a8
--- /dev/null
+++ b/collects/afm/glyphlist.txt
@@ -0,0 +1,4291 @@
+# Name:          Adobe Glyph List
+# Table version: 2.0
+# Date:          September 20, 2002
+#
+# See http://partners.adobe.com/asn/developer/typeforum/unicodegn.html
+#
+# Format: Semicolon-delimited fields:
+#            (1) glyph name
+#            (2) Unicode scalar value
+A;0041
+AE;00C6
+AEacute;01FC
+AEmacron;01E2
+AEsmall;F7E6
+Aacute;00C1
+Aacutesmall;F7E1
+Abreve;0102
+Abreveacute;1EAE
+Abrevecyrillic;04D0
+Abrevedotbelow;1EB6
+Abrevegrave;1EB0
+Abrevehookabove;1EB2
+Abrevetilde;1EB4
+Acaron;01CD
+Acircle;24B6
+Acircumflex;00C2
+Acircumflexacute;1EA4
+Acircumflexdotbelow;1EAC
+Acircumflexgrave;1EA6
+Acircumflexhookabove;1EA8
+Acircumflexsmall;F7E2
+Acircumflextilde;1EAA
+Acute;F6C9
+Acutesmall;F7B4
+Acyrillic;0410
+Adblgrave;0200
+Adieresis;00C4
+Adieresiscyrillic;04D2
+Adieresismacron;01DE
+Adieresissmall;F7E4
+Adotbelow;1EA0
+Adotmacron;01E0
+Agrave;00C0
+Agravesmall;F7E0
+Ahookabove;1EA2
+Aiecyrillic;04D4
+Ainvertedbreve;0202
+Alpha;0391
+Alphatonos;0386
+Amacron;0100
+Amonospace;FF21
+Aogonek;0104
+Aring;00C5
+Aringacute;01FA
+Aringbelow;1E00
+Aringsmall;F7E5
+Asmall;F761
+Atilde;00C3
+Atildesmall;F7E3
+Aybarmenian;0531
+B;0042
+Bcircle;24B7
+Bdotaccent;1E02
+Bdotbelow;1E04
+Becyrillic;0411
+Benarmenian;0532
+Beta;0392
+Bhook;0181
+Blinebelow;1E06
+Bmonospace;FF22
+Brevesmall;F6F4
+Bsmall;F762
+Btopbar;0182
+C;0043
+Caarmenian;053E
+Cacute;0106
+Caron;F6CA
+Caronsmall;F6F5
+Ccaron;010C
+Ccedilla;00C7
+Ccedillaacute;1E08
+Ccedillasmall;F7E7
+Ccircle;24B8
+Ccircumflex;0108
+Cdot;010A
+Cdotaccent;010A
+Cedillasmall;F7B8
+Chaarmenian;0549
+Cheabkhasiancyrillic;04BC
+Checyrillic;0427
+Chedescenderabkhasiancyrillic;04BE
+Chedescendercyrillic;04B6
+Chedieresiscyrillic;04F4
+Cheharmenian;0543
+Chekhakassiancyrillic;04CB
+Cheverticalstrokecyrillic;04B8
+Chi;03A7
+Chook;0187
+Circumflexsmall;F6F6
+Cmonospace;FF23
+Coarmenian;0551
+Csmall;F763
+D;0044
+DZ;01F1
+DZcaron;01C4
+Daarmenian;0534
+Dafrican;0189
+Dcaron;010E
+Dcedilla;1E10
+Dcircle;24B9
+Dcircumflexbelow;1E12
+Dcroat;0110
+Ddotaccent;1E0A
+Ddotbelow;1E0C
+Decyrillic;0414
+Deicoptic;03EE
+Delta;2206
+Deltagreek;0394
+Dhook;018A
+Dieresis;F6CB
+DieresisAcute;F6CC
+DieresisGrave;F6CD
+Dieresissmall;F7A8
+Digammagreek;03DC
+Djecyrillic;0402
+Dlinebelow;1E0E
+Dmonospace;FF24
+Dotaccentsmall;F6F7
+Dslash;0110
+Dsmall;F764
+Dtopbar;018B
+Dz;01F2
+Dzcaron;01C5
+Dzeabkhasiancyrillic;04E0
+Dzecyrillic;0405
+Dzhecyrillic;040F
+E;0045
+Eacute;00C9
+Eacutesmall;F7E9
+Ebreve;0114
+Ecaron;011A
+Ecedillabreve;1E1C
+Echarmenian;0535
+Ecircle;24BA
+Ecircumflex;00CA
+Ecircumflexacute;1EBE
+Ecircumflexbelow;1E18
+Ecircumflexdotbelow;1EC6
+Ecircumflexgrave;1EC0
+Ecircumflexhookabove;1EC2
+Ecircumflexsmall;F7EA
+Ecircumflextilde;1EC4
+Ecyrillic;0404
+Edblgrave;0204
+Edieresis;00CB
+Edieresissmall;F7EB
+Edot;0116
+Edotaccent;0116
+Edotbelow;1EB8
+Efcyrillic;0424
+Egrave;00C8
+Egravesmall;F7E8
+Eharmenian;0537
+Ehookabove;1EBA
+Eightroman;2167
+Einvertedbreve;0206
+Eiotifiedcyrillic;0464
+Elcyrillic;041B
+Elevenroman;216A
+Emacron;0112
+Emacronacute;1E16
+Emacrongrave;1E14
+Emcyrillic;041C
+Emonospace;FF25
+Encyrillic;041D
+Endescendercyrillic;04A2
+Eng;014A
+Enghecyrillic;04A4
+Enhookcyrillic;04C7
+Eogonek;0118
+Eopen;0190
+Epsilon;0395
+Epsilontonos;0388
+Ercyrillic;0420
+Ereversed;018E
+Ereversedcyrillic;042D
+Escyrillic;0421
+Esdescendercyrillic;04AA
+Esh;01A9
+Esmall;F765
+Eta;0397
+Etarmenian;0538
+Etatonos;0389
+Eth;00D0
+Ethsmall;F7F0
+Etilde;1EBC
+Etildebelow;1E1A
+Euro;20AC
+Ezh;01B7
+Ezhcaron;01EE
+Ezhreversed;01B8
+F;0046
+Fcircle;24BB
+Fdotaccent;1E1E
+Feharmenian;0556
+Feicoptic;03E4
+Fhook;0191
+Fitacyrillic;0472
+Fiveroman;2164
+Fmonospace;FF26
+Fourroman;2163
+Fsmall;F766
+G;0047
+GBsquare;3387
+Gacute;01F4
+Gamma;0393
+Gammaafrican;0194
+Gangiacoptic;03EA
+Gbreve;011E
+Gcaron;01E6
+Gcedilla;0122
+Gcircle;24BC
+Gcircumflex;011C
+Gcommaaccent;0122
+Gdot;0120
+Gdotaccent;0120
+Gecyrillic;0413
+Ghadarmenian;0542
+Ghemiddlehookcyrillic;0494
+Ghestrokecyrillic;0492
+Gheupturncyrillic;0490
+Ghook;0193
+Gimarmenian;0533
+Gjecyrillic;0403
+Gmacron;1E20
+Gmonospace;FF27
+Grave;F6CE
+Gravesmall;F760
+Gsmall;F767
+Gsmallhook;029B
+Gstroke;01E4
+H;0048
+H18533;25CF
+H18543;25AA
+H18551;25AB
+H22073;25A1
+HPsquare;33CB
+Haabkhasiancyrillic;04A8
+Hadescendercyrillic;04B2
+Hardsigncyrillic;042A
+Hbar;0126
+Hbrevebelow;1E2A
+Hcedilla;1E28
+Hcircle;24BD
+Hcircumflex;0124
+Hdieresis;1E26
+Hdotaccent;1E22
+Hdotbelow;1E24
+Hmonospace;FF28
+Hoarmenian;0540
+Horicoptic;03E8
+Hsmall;F768
+Hungarumlaut;F6CF
+Hungarumlautsmall;F6F8
+Hzsquare;3390
+I;0049
+IAcyrillic;042F
+IJ;0132
+IUcyrillic;042E
+Iacute;00CD
+Iacutesmall;F7ED
+Ibreve;012C
+Icaron;01CF
+Icircle;24BE
+Icircumflex;00CE
+Icircumflexsmall;F7EE
+Icyrillic;0406
+Idblgrave;0208
+Idieresis;00CF
+Idieresisacute;1E2E
+Idieresiscyrillic;04E4
+Idieresissmall;F7EF
+Idot;0130
+Idotaccent;0130
+Idotbelow;1ECA
+Iebrevecyrillic;04D6
+Iecyrillic;0415
+Ifraktur;2111
+Igrave;00CC
+Igravesmall;F7EC
+Ihookabove;1EC8
+Iicyrillic;0418
+Iinvertedbreve;020A
+Iishortcyrillic;0419
+Imacron;012A
+Imacroncyrillic;04E2
+Imonospace;FF29
+Iniarmenian;053B
+Iocyrillic;0401
+Iogonek;012E
+Iota;0399
+Iotaafrican;0196
+Iotadieresis;03AA
+Iotatonos;038A
+Ismall;F769
+Istroke;0197
+Itilde;0128
+Itildebelow;1E2C
+Izhitsacyrillic;0474
+Izhitsadblgravecyrillic;0476
+J;004A
+Jaarmenian;0541
+Jcircle;24BF
+Jcircumflex;0134
+Jecyrillic;0408
+Jheharmenian;054B
+Jmonospace;FF2A
+Jsmall;F76A
+K;004B
+KBsquare;3385
+KKsquare;33CD
+Kabashkircyrillic;04A0
+Kacute;1E30
+Kacyrillic;041A
+Kadescendercyrillic;049A
+Kahookcyrillic;04C3
+Kappa;039A
+Kastrokecyrillic;049E
+Kaverticalstrokecyrillic;049C
+Kcaron;01E8
+Kcedilla;0136
+Kcircle;24C0
+Kcommaaccent;0136
+Kdotbelow;1E32
+Keharmenian;0554
+Kenarmenian;053F
+Khacyrillic;0425
+Kheicoptic;03E6
+Khook;0198
+Kjecyrillic;040C
+Klinebelow;1E34
+Kmonospace;FF2B
+Koppacyrillic;0480
+Koppagreek;03DE
+Ksicyrillic;046E
+Ksmall;F76B
+L;004C
+LJ;01C7
+LL;F6BF
+Lacute;0139
+Lambda;039B
+Lcaron;013D
+Lcedilla;013B
+Lcircle;24C1
+Lcircumflexbelow;1E3C
+Lcommaaccent;013B
+Ldot;013F
+Ldotaccent;013F
+Ldotbelow;1E36
+Ldotbelowmacron;1E38
+Liwnarmenian;053C
+Lj;01C8
+Ljecyrillic;0409
+Llinebelow;1E3A
+Lmonospace;FF2C
+Lslash;0141
+Lslashsmall;F6F9
+Lsmall;F76C
+M;004D
+MBsquare;3386
+Macron;F6D0
+Macronsmall;F7AF
+Macute;1E3E
+Mcircle;24C2
+Mdotaccent;1E40
+Mdotbelow;1E42
+Menarmenian;0544
+Mmonospace;FF2D
+Msmall;F76D
+Mturned;019C
+Mu;039C
+N;004E
+NJ;01CA
+Nacute;0143
+Ncaron;0147
+Ncedilla;0145
+Ncircle;24C3
+Ncircumflexbelow;1E4A
+Ncommaaccent;0145
+Ndotaccent;1E44
+Ndotbelow;1E46
+Nhookleft;019D
+Nineroman;2168
+Nj;01CB
+Njecyrillic;040A
+Nlinebelow;1E48
+Nmonospace;FF2E
+Nowarmenian;0546
+Nsmall;F76E
+Ntilde;00D1
+Ntildesmall;F7F1
+Nu;039D
+O;004F
+OE;0152
+OEsmall;F6FA
+Oacute;00D3
+Oacutesmall;F7F3
+Obarredcyrillic;04E8
+Obarreddieresiscyrillic;04EA
+Obreve;014E
+Ocaron;01D1
+Ocenteredtilde;019F
+Ocircle;24C4
+Ocircumflex;00D4
+Ocircumflexacute;1ED0
+Ocircumflexdotbelow;1ED8
+Ocircumflexgrave;1ED2
+Ocircumflexhookabove;1ED4
+Ocircumflexsmall;F7F4
+Ocircumflextilde;1ED6
+Ocyrillic;041E
+Odblacute;0150
+Odblgrave;020C
+Odieresis;00D6
+Odieresiscyrillic;04E6
+Odieresissmall;F7F6
+Odotbelow;1ECC
+Ogoneksmall;F6FB
+Ograve;00D2
+Ogravesmall;F7F2
+Oharmenian;0555
+Ohm;2126
+Ohookabove;1ECE
+Ohorn;01A0
+Ohornacute;1EDA
+Ohorndotbelow;1EE2
+Ohorngrave;1EDC
+Ohornhookabove;1EDE
+Ohorntilde;1EE0
+Ohungarumlaut;0150
+Oi;01A2
+Oinvertedbreve;020E
+Omacron;014C
+Omacronacute;1E52
+Omacrongrave;1E50
+Omega;2126
+Omegacyrillic;0460
+Omegagreek;03A9
+Omegaroundcyrillic;047A
+Omegatitlocyrillic;047C
+Omegatonos;038F
+Omicron;039F
+Omicrontonos;038C
+Omonospace;FF2F
+Oneroman;2160
+Oogonek;01EA
+Oogonekmacron;01EC
+Oopen;0186
+Oslash;00D8
+Oslashacute;01FE
+Oslashsmall;F7F8
+Osmall;F76F
+Ostrokeacute;01FE
+Otcyrillic;047E
+Otilde;00D5
+Otildeacute;1E4C
+Otildedieresis;1E4E
+Otildesmall;F7F5
+P;0050
+Pacute;1E54
+Pcircle;24C5
+Pdotaccent;1E56
+Pecyrillic;041F
+Peharmenian;054A
+Pemiddlehookcyrillic;04A6
+Phi;03A6
+Phook;01A4
+Pi;03A0
+Piwrarmenian;0553
+Pmonospace;FF30
+Psi;03A8
+Psicyrillic;0470
+Psmall;F770
+Q;0051
+Qcircle;24C6
+Qmonospace;FF31
+Qsmall;F771
+R;0052
+Raarmenian;054C
+Racute;0154
+Rcaron;0158
+Rcedilla;0156
+Rcircle;24C7
+Rcommaaccent;0156
+Rdblgrave;0210
+Rdotaccent;1E58
+Rdotbelow;1E5A
+Rdotbelowmacron;1E5C
+Reharmenian;0550
+Rfraktur;211C
+Rho;03A1
+Ringsmall;F6FC
+Rinvertedbreve;0212
+Rlinebelow;1E5E
+Rmonospace;FF32
+Rsmall;F772
+Rsmallinverted;0281
+Rsmallinvertedsuperior;02B6
+S;0053
+SF010000;250C
+SF020000;2514
+SF030000;2510
+SF040000;2518
+SF050000;253C
+SF060000;252C
+SF070000;2534
+SF080000;251C
+SF090000;2524
+SF100000;2500
+SF110000;2502
+SF190000;2561
+SF200000;2562
+SF210000;2556
+SF220000;2555
+SF230000;2563
+SF240000;2551
+SF250000;2557
+SF260000;255D
+SF270000;255C
+SF280000;255B
+SF360000;255E
+SF370000;255F
+SF380000;255A
+SF390000;2554
+SF400000;2569
+SF410000;2566
+SF420000;2560
+SF430000;2550
+SF440000;256C
+SF450000;2567
+SF460000;2568
+SF470000;2564
+SF480000;2565
+SF490000;2559
+SF500000;2558
+SF510000;2552
+SF520000;2553
+SF530000;256B
+SF540000;256A
+Sacute;015A
+Sacutedotaccent;1E64
+Sampigreek;03E0
+Scaron;0160
+Scarondotaccent;1E66
+Scaronsmall;F6FD
+Scedilla;015E
+Schwa;018F
+Schwacyrillic;04D8
+Schwadieresiscyrillic;04DA
+Scircle;24C8
+Scircumflex;015C
+Scommaaccent;0218
+Sdotaccent;1E60
+Sdotbelow;1E62
+Sdotbelowdotaccent;1E68
+Seharmenian;054D
+Sevenroman;2166
+Shaarmenian;0547
+Shacyrillic;0428
+Shchacyrillic;0429
+Sheicoptic;03E2
+Shhacyrillic;04BA
+Shimacoptic;03EC
+Sigma;03A3
+Sixroman;2165
+Smonospace;FF33
+Softsigncyrillic;042C
+Ssmall;F773
+Stigmagreek;03DA
+T;0054
+Tau;03A4
+Tbar;0166
+Tcaron;0164
+Tcedilla;0162
+Tcircle;24C9
+Tcircumflexbelow;1E70
+Tcommaaccent;0162
+Tdotaccent;1E6A
+Tdotbelow;1E6C
+Tecyrillic;0422
+Tedescendercyrillic;04AC
+Tenroman;2169
+Tetsecyrillic;04B4
+Theta;0398
+Thook;01AC
+Thorn;00DE
+Thornsmall;F7FE
+Threeroman;2162
+Tildesmall;F6FE
+Tiwnarmenian;054F
+Tlinebelow;1E6E
+Tmonospace;FF34
+Toarmenian;0539
+Tonefive;01BC
+Tonesix;0184
+Tonetwo;01A7
+Tretroflexhook;01AE
+Tsecyrillic;0426
+Tshecyrillic;040B
+Tsmall;F774
+Twelveroman;216B
+Tworoman;2161
+U;0055
+Uacute;00DA
+Uacutesmall;F7FA
+Ubreve;016C
+Ucaron;01D3
+Ucircle;24CA
+Ucircumflex;00DB
+Ucircumflexbelow;1E76
+Ucircumflexsmall;F7FB
+Ucyrillic;0423
+Udblacute;0170
+Udblgrave;0214
+Udieresis;00DC
+Udieresisacute;01D7
+Udieresisbelow;1E72
+Udieresiscaron;01D9
+Udieresiscyrillic;04F0
+Udieresisgrave;01DB
+Udieresismacron;01D5
+Udieresissmall;F7FC
+Udotbelow;1EE4
+Ugrave;00D9
+Ugravesmall;F7F9
+Uhookabove;1EE6
+Uhorn;01AF
+Uhornacute;1EE8
+Uhorndotbelow;1EF0
+Uhorngrave;1EEA
+Uhornhookabove;1EEC
+Uhorntilde;1EEE
+Uhungarumlaut;0170
+Uhungarumlautcyrillic;04F2
+Uinvertedbreve;0216
+Ukcyrillic;0478
+Umacron;016A
+Umacroncyrillic;04EE
+Umacrondieresis;1E7A
+Umonospace;FF35
+Uogonek;0172
+Upsilon;03A5
+Upsilon1;03D2
+Upsilonacutehooksymbolgreek;03D3
+Upsilonafrican;01B1
+Upsilondieresis;03AB
+Upsilondieresishooksymbolgreek;03D4
+Upsilonhooksymbol;03D2
+Upsilontonos;038E
+Uring;016E
+Ushortcyrillic;040E
+Usmall;F775
+Ustraightcyrillic;04AE
+Ustraightstrokecyrillic;04B0
+Utilde;0168
+Utildeacute;1E78
+Utildebelow;1E74
+V;0056
+Vcircle;24CB
+Vdotbelow;1E7E
+Vecyrillic;0412
+Vewarmenian;054E
+Vhook;01B2
+Vmonospace;FF36
+Voarmenian;0548
+Vsmall;F776
+Vtilde;1E7C
+W;0057
+Wacute;1E82
+Wcircle;24CC
+Wcircumflex;0174
+Wdieresis;1E84
+Wdotaccent;1E86
+Wdotbelow;1E88
+Wgrave;1E80
+Wmonospace;FF37
+Wsmall;F777
+X;0058
+Xcircle;24CD
+Xdieresis;1E8C
+Xdotaccent;1E8A
+Xeharmenian;053D
+Xi;039E
+Xmonospace;FF38
+Xsmall;F778
+Y;0059
+Yacute;00DD
+Yacutesmall;F7FD
+Yatcyrillic;0462
+Ycircle;24CE
+Ycircumflex;0176
+Ydieresis;0178
+Ydieresissmall;F7FF
+Ydotaccent;1E8E
+Ydotbelow;1EF4
+Yericyrillic;042B
+Yerudieresiscyrillic;04F8
+Ygrave;1EF2
+Yhook;01B3
+Yhookabove;1EF6
+Yiarmenian;0545
+Yicyrillic;0407
+Yiwnarmenian;0552
+Ymonospace;FF39
+Ysmall;F779
+Ytilde;1EF8
+Yusbigcyrillic;046A
+Yusbigiotifiedcyrillic;046C
+Yuslittlecyrillic;0466
+Yuslittleiotifiedcyrillic;0468
+Z;005A
+Zaarmenian;0536
+Zacute;0179
+Zcaron;017D
+Zcaronsmall;F6FF
+Zcircle;24CF
+Zcircumflex;1E90
+Zdot;017B
+Zdotaccent;017B
+Zdotbelow;1E92
+Zecyrillic;0417
+Zedescendercyrillic;0498
+Zedieresiscyrillic;04DE
+Zeta;0396
+Zhearmenian;053A
+Zhebrevecyrillic;04C1
+Zhecyrillic;0416
+Zhedescendercyrillic;0496
+Zhedieresiscyrillic;04DC
+Zlinebelow;1E94
+Zmonospace;FF3A
+Zsmall;F77A
+Zstroke;01B5
+a;0061
+aabengali;0986
+aacute;00E1
+aadeva;0906
+aagujarati;0A86
+aagurmukhi;0A06
+aamatragurmukhi;0A3E
+aarusquare;3303
+aavowelsignbengali;09BE
+aavowelsigndeva;093E
+aavowelsigngujarati;0ABE
+abbreviationmarkarmenian;055F
+abbreviationsigndeva;0970
+abengali;0985
+abopomofo;311A
+abreve;0103
+abreveacute;1EAF
+abrevecyrillic;04D1
+abrevedotbelow;1EB7
+abrevegrave;1EB1
+abrevehookabove;1EB3
+abrevetilde;1EB5
+acaron;01CE
+acircle;24D0
+acircumflex;00E2
+acircumflexacute;1EA5
+acircumflexdotbelow;1EAD
+acircumflexgrave;1EA7
+acircumflexhookabove;1EA9
+acircumflextilde;1EAB
+acute;00B4
+acutebelowcmb;0317
+acutecmb;0301
+acutecomb;0301
+acutedeva;0954
+acutelowmod;02CF
+acutetonecmb;0341
+acyrillic;0430
+adblgrave;0201
+addakgurmukhi;0A71
+adeva;0905
+adieresis;00E4
+adieresiscyrillic;04D3
+adieresismacron;01DF
+adotbelow;1EA1
+adotmacron;01E1
+ae;00E6
+aeacute;01FD
+aekorean;3150
+aemacron;01E3
+afii00208;2015
+afii08941;20A4
+afii10017;0410
+afii10018;0411
+afii10019;0412
+afii10020;0413
+afii10021;0414
+afii10022;0415
+afii10023;0401
+afii10024;0416
+afii10025;0417
+afii10026;0418
+afii10027;0419
+afii10028;041A
+afii10029;041B
+afii10030;041C
+afii10031;041D
+afii10032;041E
+afii10033;041F
+afii10034;0420
+afii10035;0421
+afii10036;0422
+afii10037;0423
+afii10038;0424
+afii10039;0425
+afii10040;0426
+afii10041;0427
+afii10042;0428
+afii10043;0429
+afii10044;042A
+afii10045;042B
+afii10046;042C
+afii10047;042D
+afii10048;042E
+afii10049;042F
+afii10050;0490
+afii10051;0402
+afii10052;0403
+afii10053;0404
+afii10054;0405
+afii10055;0406
+afii10056;0407
+afii10057;0408
+afii10058;0409
+afii10059;040A
+afii10060;040B
+afii10061;040C
+afii10062;040E
+afii10063;F6C4
+afii10064;F6C5
+afii10065;0430
+afii10066;0431
+afii10067;0432
+afii10068;0433
+afii10069;0434
+afii10070;0435
+afii10071;0451
+afii10072;0436
+afii10073;0437
+afii10074;0438
+afii10075;0439
+afii10076;043A
+afii10077;043B
+afii10078;043C
+afii10079;043D
+afii10080;043E
+afii10081;043F
+afii10082;0440
+afii10083;0441
+afii10084;0442
+afii10085;0443
+afii10086;0444
+afii10087;0445
+afii10088;0446
+afii10089;0447
+afii10090;0448
+afii10091;0449
+afii10092;044A
+afii10093;044B
+afii10094;044C
+afii10095;044D
+afii10096;044E
+afii10097;044F
+afii10098;0491
+afii10099;0452
+afii10100;0453
+afii10101;0454
+afii10102;0455
+afii10103;0456
+afii10104;0457
+afii10105;0458
+afii10106;0459
+afii10107;045A
+afii10108;045B
+afii10109;045C
+afii10110;045E
+afii10145;040F
+afii10146;0462
+afii10147;0472
+afii10148;0474
+afii10192;F6C6
+afii10193;045F
+afii10194;0463
+afii10195;0473
+afii10196;0475
+afii10831;F6C7
+afii10832;F6C8
+afii10846;04D9
+afii299;200E
+afii300;200F
+afii301;200D
+afii57381;066A
+afii57388;060C
+afii57392;0660
+afii57393;0661
+afii57394;0662
+afii57395;0663
+afii57396;0664
+afii57397;0665
+afii57398;0666
+afii57399;0667
+afii57400;0668
+afii57401;0669
+afii57403;061B
+afii57407;061F
+afii57409;0621
+afii57410;0622
+afii57411;0623
+afii57412;0624
+afii57413;0625
+afii57414;0626
+afii57415;0627
+afii57416;0628
+afii57417;0629
+afii57418;062A
+afii57419;062B
+afii57420;062C
+afii57421;062D
+afii57422;062E
+afii57423;062F
+afii57424;0630
+afii57425;0631
+afii57426;0632
+afii57427;0633
+afii57428;0634
+afii57429;0635
+afii57430;0636
+afii57431;0637
+afii57432;0638
+afii57433;0639
+afii57434;063A
+afii57440;0640
+afii57441;0641
+afii57442;0642
+afii57443;0643
+afii57444;0644
+afii57445;0645
+afii57446;0646
+afii57448;0648
+afii57449;0649
+afii57450;064A
+afii57451;064B
+afii57452;064C
+afii57453;064D
+afii57454;064E
+afii57455;064F
+afii57456;0650
+afii57457;0651
+afii57458;0652
+afii57470;0647
+afii57505;06A4
+afii57506;067E
+afii57507;0686
+afii57508;0698
+afii57509;06AF
+afii57511;0679
+afii57512;0688
+afii57513;0691
+afii57514;06BA
+afii57519;06D2
+afii57534;06D5
+afii57636;20AA
+afii57645;05BE
+afii57658;05C3
+afii57664;05D0
+afii57665;05D1
+afii57666;05D2
+afii57667;05D3
+afii57668;05D4
+afii57669;05D5
+afii57670;05D6
+afii57671;05D7
+afii57672;05D8
+afii57673;05D9
+afii57674;05DA
+afii57675;05DB
+afii57676;05DC
+afii57677;05DD
+afii57678;05DE
+afii57679;05DF
+afii57680;05E0
+afii57681;05E1
+afii57682;05E2
+afii57683;05E3
+afii57684;05E4
+afii57685;05E5
+afii57686;05E6
+afii57687;05E7
+afii57688;05E8
+afii57689;05E9
+afii57690;05EA
+afii57694;FB2A
+afii57695;FB2B
+afii57700;FB4B
+afii57705;FB1F
+afii57716;05F0
+afii57717;05F1
+afii57718;05F2
+afii57723;FB35
+afii57793;05B4
+afii57794;05B5
+afii57795;05B6
+afii57796;05BB
+afii57797;05B8
+afii57798;05B7
+afii57799;05B0
+afii57800;05B2
+afii57801;05B1
+afii57802;05B3
+afii57803;05C2
+afii57804;05C1
+afii57806;05B9
+afii57807;05BC
+afii57839;05BD
+afii57841;05BF
+afii57842;05C0
+afii57929;02BC
+afii61248;2105
+afii61289;2113
+afii61352;2116
+afii61573;202C
+afii61574;202D
+afii61575;202E
+afii61664;200C
+afii63167;066D
+afii64937;02BD
+agrave;00E0
+agujarati;0A85
+agurmukhi;0A05
+ahiragana;3042
+ahookabove;1EA3
+aibengali;0990
+aibopomofo;311E
+aideva;0910
+aiecyrillic;04D5
+aigujarati;0A90
+aigurmukhi;0A10
+aimatragurmukhi;0A48
+ainarabic;0639
+ainfinalarabic;FECA
+aininitialarabic;FECB
+ainmedialarabic;FECC
+ainvertedbreve;0203
+aivowelsignbengali;09C8
+aivowelsigndeva;0948
+aivowelsigngujarati;0AC8
+akatakana;30A2
+akatakanahalfwidth;FF71
+akorean;314F
+alef;05D0
+alefarabic;0627
+alefdageshhebrew;FB30
+aleffinalarabic;FE8E
+alefhamzaabovearabic;0623
+alefhamzaabovefinalarabic;FE84
+alefhamzabelowarabic;0625
+alefhamzabelowfinalarabic;FE88
+alefhebrew;05D0
+aleflamedhebrew;FB4F
+alefmaddaabovearabic;0622
+alefmaddaabovefinalarabic;FE82
+alefmaksuraarabic;0649
+alefmaksurafinalarabic;FEF0
+alefmaksurainitialarabic;FEF3
+alefmaksuramedialarabic;FEF4
+alefpatahhebrew;FB2E
+alefqamatshebrew;FB2F
+aleph;2135
+allequal;224C
+alpha;03B1
+alphatonos;03AC
+amacron;0101
+amonospace;FF41
+ampersand;0026
+ampersandmonospace;FF06
+ampersandsmall;F726
+amsquare;33C2
+anbopomofo;3122
+angbopomofo;3124
+angkhankhuthai;0E5A
+angle;2220
+anglebracketleft;3008
+anglebracketleftvertical;FE3F
+anglebracketright;3009
+anglebracketrightvertical;FE40
+angleleft;2329
+angleright;232A
+angstrom;212B
+anoteleia;0387
+anudattadeva;0952
+anusvarabengali;0982
+anusvaradeva;0902
+anusvaragujarati;0A82
+aogonek;0105
+apaatosquare;3300
+aparen;249C
+apostrophearmenian;055A
+apostrophemod;02BC
+apple;F8FF
+approaches;2250
+approxequal;2248
+approxequalorimage;2252
+approximatelyequal;2245
+araeaekorean;318E
+araeakorean;318D
+arc;2312
+arighthalfring;1E9A
+aring;00E5
+aringacute;01FB
+aringbelow;1E01
+arrowboth;2194
+arrowdashdown;21E3
+arrowdashleft;21E0
+arrowdashright;21E2
+arrowdashup;21E1
+arrowdblboth;21D4
+arrowdbldown;21D3
+arrowdblleft;21D0
+arrowdblright;21D2
+arrowdblup;21D1
+arrowdown;2193
+arrowdownleft;2199
+arrowdownright;2198
+arrowdownwhite;21E9
+arrowheaddownmod;02C5
+arrowheadleftmod;02C2
+arrowheadrightmod;02C3
+arrowheadupmod;02C4
+arrowhorizex;F8E7
+arrowleft;2190
+arrowleftdbl;21D0
+arrowleftdblstroke;21CD
+arrowleftoverright;21C6
+arrowleftwhite;21E6
+arrowright;2192
+arrowrightdblstroke;21CF
+arrowrightheavy;279E
+arrowrightoverleft;21C4
+arrowrightwhite;21E8
+arrowtableft;21E4
+arrowtabright;21E5
+arrowup;2191
+arrowupdn;2195
+arrowupdnbse;21A8
+arrowupdownbase;21A8
+arrowupleft;2196
+arrowupleftofdown;21C5
+arrowupright;2197
+arrowupwhite;21E7
+arrowvertex;F8E6
+asciicircum;005E
+asciicircummonospace;FF3E
+asciitilde;007E
+asciitildemonospace;FF5E
+ascript;0251
+ascriptturned;0252
+asmallhiragana;3041
+asmallkatakana;30A1
+asmallkatakanahalfwidth;FF67
+asterisk;002A
+asteriskaltonearabic;066D
+asteriskarabic;066D
+asteriskmath;2217
+asteriskmonospace;FF0A
+asterisksmall;FE61
+asterism;2042
+asuperior;F6E9
+asymptoticallyequal;2243
+at;0040
+atilde;00E3
+atmonospace;FF20
+atsmall;FE6B
+aturned;0250
+aubengali;0994
+aubopomofo;3120
+audeva;0914
+augujarati;0A94
+augurmukhi;0A14
+aulengthmarkbengali;09D7
+aumatragurmukhi;0A4C
+auvowelsignbengali;09CC
+auvowelsigndeva;094C
+auvowelsigngujarati;0ACC
+avagrahadeva;093D
+aybarmenian;0561
+ayin;05E2
+ayinaltonehebrew;FB20
+ayinhebrew;05E2
+b;0062
+babengali;09AC
+backslash;005C
+backslashmonospace;FF3C
+badeva;092C
+bagujarati;0AAC
+bagurmukhi;0A2C
+bahiragana;3070
+bahtthai;0E3F
+bakatakana;30D0
+bar;007C
+barmonospace;FF5C
+bbopomofo;3105
+bcircle;24D1
+bdotaccent;1E03
+bdotbelow;1E05
+beamedsixteenthnotes;266C
+because;2235
+becyrillic;0431
+beharabic;0628
+behfinalarabic;FE90
+behinitialarabic;FE91
+behiragana;3079
+behmedialarabic;FE92
+behmeeminitialarabic;FC9F
+behmeemisolatedarabic;FC08
+behnoonfinalarabic;FC6D
+bekatakana;30D9
+benarmenian;0562
+bet;05D1
+beta;03B2
+betasymbolgreek;03D0
+betdagesh;FB31
+betdageshhebrew;FB31
+bethebrew;05D1
+betrafehebrew;FB4C
+bhabengali;09AD
+bhadeva;092D
+bhagujarati;0AAD
+bhagurmukhi;0A2D
+bhook;0253
+bihiragana;3073
+bikatakana;30D3
+bilabialclick;0298
+bindigurmukhi;0A02
+birusquare;3331
+blackcircle;25CF
+blackdiamond;25C6
+blackdownpointingtriangle;25BC
+blackleftpointingpointer;25C4
+blackleftpointingtriangle;25C0
+blacklenticularbracketleft;3010
+blacklenticularbracketleftvertical;FE3B
+blacklenticularbracketright;3011
+blacklenticularbracketrightvertical;FE3C
+blacklowerlefttriangle;25E3
+blacklowerrighttriangle;25E2
+blackrectangle;25AC
+blackrightpointingpointer;25BA
+blackrightpointingtriangle;25B6
+blacksmallsquare;25AA
+blacksmilingface;263B
+blacksquare;25A0
+blackstar;2605
+blackupperlefttriangle;25E4
+blackupperrighttriangle;25E5
+blackuppointingsmalltriangle;25B4
+blackuppointingtriangle;25B2
+blank;2423
+blinebelow;1E07
+block;2588
+bmonospace;FF42
+bobaimaithai;0E1A
+bohiragana;307C
+bokatakana;30DC
+bparen;249D
+bqsquare;33C3
+braceex;F8F4
+braceleft;007B
+braceleftbt;F8F3
+braceleftmid;F8F2
+braceleftmonospace;FF5B
+braceleftsmall;FE5B
+bracelefttp;F8F1
+braceleftvertical;FE37
+braceright;007D
+bracerightbt;F8FE
+bracerightmid;F8FD
+bracerightmonospace;FF5D
+bracerightsmall;FE5C
+bracerighttp;F8FC
+bracerightvertical;FE38
+bracketleft;005B
+bracketleftbt;F8F0
+bracketleftex;F8EF
+bracketleftmonospace;FF3B
+bracketlefttp;F8EE
+bracketright;005D
+bracketrightbt;F8FB
+bracketrightex;F8FA
+bracketrightmonospace;FF3D
+bracketrighttp;F8F9
+breve;02D8
+brevebelowcmb;032E
+brevecmb;0306
+breveinvertedbelowcmb;032F
+breveinvertedcmb;0311
+breveinverteddoublecmb;0361
+bridgebelowcmb;032A
+bridgeinvertedbelowcmb;033A
+brokenbar;00A6
+bstroke;0180
+bsuperior;F6EA
+btopbar;0183
+buhiragana;3076
+bukatakana;30D6
+bullet;2022
+bulletinverse;25D8
+bulletoperator;2219
+bullseye;25CE
+c;0063
+caarmenian;056E
+cabengali;099A
+cacute;0107
+cadeva;091A
+cagujarati;0A9A
+cagurmukhi;0A1A
+calsquare;3388
+candrabindubengali;0981
+candrabinducmb;0310
+candrabindudeva;0901
+candrabindugujarati;0A81
+capslock;21EA
+careof;2105
+caron;02C7
+caronbelowcmb;032C
+caroncmb;030C
+carriagereturn;21B5
+cbopomofo;3118
+ccaron;010D
+ccedilla;00E7
+ccedillaacute;1E09
+ccircle;24D2
+ccircumflex;0109
+ccurl;0255
+cdot;010B
+cdotaccent;010B
+cdsquare;33C5
+cedilla;00B8
+cedillacmb;0327
+cent;00A2
+centigrade;2103
+centinferior;F6DF
+centmonospace;FFE0
+centoldstyle;F7A2
+centsuperior;F6E0
+chaarmenian;0579
+chabengali;099B
+chadeva;091B
+chagujarati;0A9B
+chagurmukhi;0A1B
+chbopomofo;3114
+cheabkhasiancyrillic;04BD
+checkmark;2713
+checyrillic;0447
+chedescenderabkhasiancyrillic;04BF
+chedescendercyrillic;04B7
+chedieresiscyrillic;04F5
+cheharmenian;0573
+chekhakassiancyrillic;04CC
+cheverticalstrokecyrillic;04B9
+chi;03C7
+chieuchacirclekorean;3277
+chieuchaparenkorean;3217
+chieuchcirclekorean;3269
+chieuchkorean;314A
+chieuchparenkorean;3209
+chochangthai;0E0A
+chochanthai;0E08
+chochingthai;0E09
+chochoethai;0E0C
+chook;0188
+cieucacirclekorean;3276
+cieucaparenkorean;3216
+cieuccirclekorean;3268
+cieuckorean;3148
+cieucparenkorean;3208
+cieucuparenkorean;321C
+circle;25CB
+circlemultiply;2297
+circleot;2299
+circleplus;2295
+circlepostalmark;3036
+circlewithlefthalfblack;25D0
+circlewithrighthalfblack;25D1
+circumflex;02C6
+circumflexbelowcmb;032D
+circumflexcmb;0302
+clear;2327
+clickalveolar;01C2
+clickdental;01C0
+clicklateral;01C1
+clickretroflex;01C3
+club;2663
+clubsuitblack;2663
+clubsuitwhite;2667
+cmcubedsquare;33A4
+cmonospace;FF43
+cmsquaredsquare;33A0
+coarmenian;0581
+colon;003A
+colonmonetary;20A1
+colonmonospace;FF1A
+colonsign;20A1
+colonsmall;FE55
+colontriangularhalfmod;02D1
+colontriangularmod;02D0
+comma;002C
+commaabovecmb;0313
+commaaboverightcmb;0315
+commaaccent;F6C3
+commaarabic;060C
+commaarmenian;055D
+commainferior;F6E1
+commamonospace;FF0C
+commareversedabovecmb;0314
+commareversedmod;02BD
+commasmall;FE50
+commasuperior;F6E2
+commaturnedabovecmb;0312
+commaturnedmod;02BB
+compass;263C
+congruent;2245
+contourintegral;222E
+control;2303
+controlACK;0006
+controlBEL;0007
+controlBS;0008
+controlCAN;0018
+controlCR;000D
+controlDC1;0011
+controlDC2;0012
+controlDC3;0013
+controlDC4;0014
+controlDEL;007F
+controlDLE;0010
+controlEM;0019
+controlENQ;0005
+controlEOT;0004
+controlESC;001B
+controlETB;0017
+controlETX;0003
+controlFF;000C
+controlFS;001C
+controlGS;001D
+controlHT;0009
+controlLF;000A
+controlNAK;0015
+controlRS;001E
+controlSI;000F
+controlSO;000E
+controlSOT;0002
+controlSTX;0001
+controlSUB;001A
+controlSYN;0016
+controlUS;001F
+controlVT;000B
+copyright;00A9
+copyrightsans;F8E9
+copyrightserif;F6D9
+cornerbracketleft;300C
+cornerbracketlefthalfwidth;FF62
+cornerbracketleftvertical;FE41
+cornerbracketright;300D
+cornerbracketrighthalfwidth;FF63
+cornerbracketrightvertical;FE42
+corporationsquare;337F
+cosquare;33C7
+coverkgsquare;33C6
+cparen;249E
+cruzeiro;20A2
+cstretched;0297
+curlyand;22CF
+curlyor;22CE
+currency;00A4
+cyrBreve;F6D1
+cyrFlex;F6D2
+cyrbreve;F6D4
+cyrflex;F6D5
+d;0064
+daarmenian;0564
+dabengali;09A6
+dadarabic;0636
+dadeva;0926
+dadfinalarabic;FEBE
+dadinitialarabic;FEBF
+dadmedialarabic;FEC0
+dagesh;05BC
+dageshhebrew;05BC
+dagger;2020
+daggerdbl;2021
+dagujarati;0AA6
+dagurmukhi;0A26
+dahiragana;3060
+dakatakana;30C0
+dalarabic;062F
+dalet;05D3
+daletdagesh;FB33
+daletdageshhebrew;FB33
+dalethatafpatah;05D3 05B2
+dalethatafpatahhebrew;05D3 05B2
+dalethatafsegol;05D3 05B1
+dalethatafsegolhebrew;05D3 05B1
+dalethebrew;05D3
+dalethiriq;05D3 05B4
+dalethiriqhebrew;05D3 05B4
+daletholam;05D3 05B9
+daletholamhebrew;05D3 05B9
+daletpatah;05D3 05B7
+daletpatahhebrew;05D3 05B7
+daletqamats;05D3 05B8
+daletqamatshebrew;05D3 05B8
+daletqubuts;05D3 05BB
+daletqubutshebrew;05D3 05BB
+daletsegol;05D3 05B6
+daletsegolhebrew;05D3 05B6
+daletsheva;05D3 05B0
+daletshevahebrew;05D3 05B0
+dalettsere;05D3 05B5
+dalettserehebrew;05D3 05B5
+dalfinalarabic;FEAA
+dammaarabic;064F
+dammalowarabic;064F
+dammatanaltonearabic;064C
+dammatanarabic;064C
+danda;0964
+dargahebrew;05A7
+dargalefthebrew;05A7
+dasiapneumatacyrilliccmb;0485
+dblGrave;F6D3
+dblanglebracketleft;300A
+dblanglebracketleftvertical;FE3D
+dblanglebracketright;300B
+dblanglebracketrightvertical;FE3E
+dblarchinvertedbelowcmb;032B
+dblarrowleft;21D4
+dblarrowright;21D2
+dbldanda;0965
+dblgrave;F6D6
+dblgravecmb;030F
+dblintegral;222C
+dbllowline;2017
+dbllowlinecmb;0333
+dbloverlinecmb;033F
+dblprimemod;02BA
+dblverticalbar;2016
+dblverticallineabovecmb;030E
+dbopomofo;3109
+dbsquare;33C8
+dcaron;010F
+dcedilla;1E11
+dcircle;24D3
+dcircumflexbelow;1E13
+dcroat;0111
+ddabengali;09A1
+ddadeva;0921
+ddagujarati;0AA1
+ddagurmukhi;0A21
+ddalarabic;0688
+ddalfinalarabic;FB89
+dddhadeva;095C
+ddhabengali;09A2
+ddhadeva;0922
+ddhagujarati;0AA2
+ddhagurmukhi;0A22
+ddotaccent;1E0B
+ddotbelow;1E0D
+decimalseparatorarabic;066B
+decimalseparatorpersian;066B
+decyrillic;0434
+degree;00B0
+dehihebrew;05AD
+dehiragana;3067
+deicoptic;03EF
+dekatakana;30C7
+deleteleft;232B
+deleteright;2326
+delta;03B4
+deltaturned;018D
+denominatorminusonenumeratorbengali;09F8
+dezh;02A4
+dhabengali;09A7
+dhadeva;0927
+dhagujarati;0AA7
+dhagurmukhi;0A27
+dhook;0257
+dialytikatonos;0385
+dialytikatonoscmb;0344
+diamond;2666
+diamondsuitwhite;2662
+dieresis;00A8
+dieresisacute;F6D7
+dieresisbelowcmb;0324
+dieresiscmb;0308
+dieresisgrave;F6D8
+dieresistonos;0385
+dihiragana;3062
+dikatakana;30C2
+dittomark;3003
+divide;00F7
+divides;2223
+divisionslash;2215
+djecyrillic;0452
+dkshade;2593
+dlinebelow;1E0F
+dlsquare;3397
+dmacron;0111
+dmonospace;FF44
+dnblock;2584
+dochadathai;0E0E
+dodekthai;0E14
+dohiragana;3069
+dokatakana;30C9
+dollar;0024
+dollarinferior;F6E3
+dollarmonospace;FF04
+dollaroldstyle;F724
+dollarsmall;FE69
+dollarsuperior;F6E4
+dong;20AB
+dorusquare;3326
+dotaccent;02D9
+dotaccentcmb;0307
+dotbelowcmb;0323
+dotbelowcomb;0323
+dotkatakana;30FB
+dotlessi;0131
+dotlessj;F6BE
+dotlessjstrokehook;0284
+dotmath;22C5
+dottedcircle;25CC
+doubleyodpatah;FB1F
+doubleyodpatahhebrew;FB1F
+downtackbelowcmb;031E
+downtackmod;02D5
+dparen;249F
+dsuperior;F6EB
+dtail;0256
+dtopbar;018C
+duhiragana;3065
+dukatakana;30C5
+dz;01F3
+dzaltone;02A3
+dzcaron;01C6
+dzcurl;02A5
+dzeabkhasiancyrillic;04E1
+dzecyrillic;0455
+dzhecyrillic;045F
+e;0065
+eacute;00E9
+earth;2641
+ebengali;098F
+ebopomofo;311C
+ebreve;0115
+ecandradeva;090D
+ecandragujarati;0A8D
+ecandravowelsigndeva;0945
+ecandravowelsigngujarati;0AC5
+ecaron;011B
+ecedillabreve;1E1D
+echarmenian;0565
+echyiwnarmenian;0587
+ecircle;24D4
+ecircumflex;00EA
+ecircumflexacute;1EBF
+ecircumflexbelow;1E19
+ecircumflexdotbelow;1EC7
+ecircumflexgrave;1EC1
+ecircumflexhookabove;1EC3
+ecircumflextilde;1EC5
+ecyrillic;0454
+edblgrave;0205
+edeva;090F
+edieresis;00EB
+edot;0117
+edotaccent;0117
+edotbelow;1EB9
+eegurmukhi;0A0F
+eematragurmukhi;0A47
+efcyrillic;0444
+egrave;00E8
+egujarati;0A8F
+eharmenian;0567
+ehbopomofo;311D
+ehiragana;3048
+ehookabove;1EBB
+eibopomofo;311F
+eight;0038
+eightarabic;0668
+eightbengali;09EE
+eightcircle;2467
+eightcircleinversesansserif;2791
+eightdeva;096E
+eighteencircle;2471
+eighteenparen;2485
+eighteenperiod;2499
+eightgujarati;0AEE
+eightgurmukhi;0A6E
+eighthackarabic;0668
+eighthangzhou;3028
+eighthnotebeamed;266B
+eightideographicparen;3227
+eightinferior;2088
+eightmonospace;FF18
+eightoldstyle;F738
+eightparen;247B
+eightperiod;248F
+eightpersian;06F8
+eightroman;2177
+eightsuperior;2078
+eightthai;0E58
+einvertedbreve;0207
+eiotifiedcyrillic;0465
+ekatakana;30A8
+ekatakanahalfwidth;FF74
+ekonkargurmukhi;0A74
+ekorean;3154
+elcyrillic;043B
+element;2208
+elevencircle;246A
+elevenparen;247E
+elevenperiod;2492
+elevenroman;217A
+ellipsis;2026
+ellipsisvertical;22EE
+emacron;0113
+emacronacute;1E17
+emacrongrave;1E15
+emcyrillic;043C
+emdash;2014
+emdashvertical;FE31
+emonospace;FF45
+emphasismarkarmenian;055B
+emptyset;2205
+enbopomofo;3123
+encyrillic;043D
+endash;2013
+endashvertical;FE32
+endescendercyrillic;04A3
+eng;014B
+engbopomofo;3125
+enghecyrillic;04A5
+enhookcyrillic;04C8
+enspace;2002
+eogonek;0119
+eokorean;3153
+eopen;025B
+eopenclosed;029A
+eopenreversed;025C
+eopenreversedclosed;025E
+eopenreversedhook;025D
+eparen;24A0
+epsilon;03B5
+epsilontonos;03AD
+equal;003D
+equalmonospace;FF1D
+equalsmall;FE66
+equalsuperior;207C
+equivalence;2261
+erbopomofo;3126
+ercyrillic;0440
+ereversed;0258
+ereversedcyrillic;044D
+escyrillic;0441
+esdescendercyrillic;04AB
+esh;0283
+eshcurl;0286
+eshortdeva;090E
+eshortvowelsigndeva;0946
+eshreversedloop;01AA
+eshsquatreversed;0285
+esmallhiragana;3047
+esmallkatakana;30A7
+esmallkatakanahalfwidth;FF6A
+estimated;212E
+esuperior;F6EC
+eta;03B7
+etarmenian;0568
+etatonos;03AE
+eth;00F0
+etilde;1EBD
+etildebelow;1E1B
+etnahtafoukhhebrew;0591
+etnahtafoukhlefthebrew;0591
+etnahtahebrew;0591
+etnahtalefthebrew;0591
+eturned;01DD
+eukorean;3161
+euro;20AC
+evowelsignbengali;09C7
+evowelsigndeva;0947
+evowelsigngujarati;0AC7
+exclam;0021
+exclamarmenian;055C
+exclamdbl;203C
+exclamdown;00A1
+exclamdownsmall;F7A1
+exclammonospace;FF01
+exclamsmall;F721
+existential;2203
+ezh;0292
+ezhcaron;01EF
+ezhcurl;0293
+ezhreversed;01B9
+ezhtail;01BA
+f;0066
+fadeva;095E
+fagurmukhi;0A5E
+fahrenheit;2109
+fathaarabic;064E
+fathalowarabic;064E
+fathatanarabic;064B
+fbopomofo;3108
+fcircle;24D5
+fdotaccent;1E1F
+feharabic;0641
+feharmenian;0586
+fehfinalarabic;FED2
+fehinitialarabic;FED3
+fehmedialarabic;FED4
+feicoptic;03E5
+female;2640
+ff;FB00
+ffi;FB03
+ffl;FB04
+fi;FB01
+fifteencircle;246E
+fifteenparen;2482
+fifteenperiod;2496
+figuredash;2012
+filledbox;25A0
+filledrect;25AC
+finalkaf;05DA
+finalkafdagesh;FB3A
+finalkafdageshhebrew;FB3A
+finalkafhebrew;05DA
+finalkafqamats;05DA 05B8
+finalkafqamatshebrew;05DA 05B8
+finalkafsheva;05DA 05B0
+finalkafshevahebrew;05DA 05B0
+finalmem;05DD
+finalmemhebrew;05DD
+finalnun;05DF
+finalnunhebrew;05DF
+finalpe;05E3
+finalpehebrew;05E3
+finaltsadi;05E5
+finaltsadihebrew;05E5
+firsttonechinese;02C9
+fisheye;25C9
+fitacyrillic;0473
+five;0035
+fivearabic;0665
+fivebengali;09EB
+fivecircle;2464
+fivecircleinversesansserif;278E
+fivedeva;096B
+fiveeighths;215D
+fivegujarati;0AEB
+fivegurmukhi;0A6B
+fivehackarabic;0665
+fivehangzhou;3025
+fiveideographicparen;3224
+fiveinferior;2085
+fivemonospace;FF15
+fiveoldstyle;F735
+fiveparen;2478
+fiveperiod;248C
+fivepersian;06F5
+fiveroman;2174
+fivesuperior;2075
+fivethai;0E55
+fl;FB02
+florin;0192
+fmonospace;FF46
+fmsquare;3399
+fofanthai;0E1F
+fofathai;0E1D
+fongmanthai;0E4F
+forall;2200
+four;0034
+fourarabic;0664
+fourbengali;09EA
+fourcircle;2463
+fourcircleinversesansserif;278D
+fourdeva;096A
+fourgujarati;0AEA
+fourgurmukhi;0A6A
+fourhackarabic;0664
+fourhangzhou;3024
+fourideographicparen;3223
+fourinferior;2084
+fourmonospace;FF14
+fournumeratorbengali;09F7
+fouroldstyle;F734
+fourparen;2477
+fourperiod;248B
+fourpersian;06F4
+fourroman;2173
+foursuperior;2074
+fourteencircle;246D
+fourteenparen;2481
+fourteenperiod;2495
+fourthai;0E54
+fourthtonechinese;02CB
+fparen;24A1
+fraction;2044
+franc;20A3
+g;0067
+gabengali;0997
+gacute;01F5
+gadeva;0917
+gafarabic;06AF
+gaffinalarabic;FB93
+gafinitialarabic;FB94
+gafmedialarabic;FB95
+gagujarati;0A97
+gagurmukhi;0A17
+gahiragana;304C
+gakatakana;30AC
+gamma;03B3
+gammalatinsmall;0263
+gammasuperior;02E0
+gangiacoptic;03EB
+gbopomofo;310D
+gbreve;011F
+gcaron;01E7
+gcedilla;0123
+gcircle;24D6
+gcircumflex;011D
+gcommaaccent;0123
+gdot;0121
+gdotaccent;0121
+gecyrillic;0433
+gehiragana;3052
+gekatakana;30B2
+geometricallyequal;2251
+gereshaccenthebrew;059C
+gereshhebrew;05F3
+gereshmuqdamhebrew;059D
+germandbls;00DF
+gershayimaccenthebrew;059E
+gershayimhebrew;05F4
+getamark;3013
+ghabengali;0998
+ghadarmenian;0572
+ghadeva;0918
+ghagujarati;0A98
+ghagurmukhi;0A18
+ghainarabic;063A
+ghainfinalarabic;FECE
+ghaininitialarabic;FECF
+ghainmedialarabic;FED0
+ghemiddlehookcyrillic;0495
+ghestrokecyrillic;0493
+gheupturncyrillic;0491
+ghhadeva;095A
+ghhagurmukhi;0A5A
+ghook;0260
+ghzsquare;3393
+gihiragana;304E
+gikatakana;30AE
+gimarmenian;0563
+gimel;05D2
+gimeldagesh;FB32
+gimeldageshhebrew;FB32
+gimelhebrew;05D2
+gjecyrillic;0453
+glottalinvertedstroke;01BE
+glottalstop;0294
+glottalstopinverted;0296
+glottalstopmod;02C0
+glottalstopreversed;0295
+glottalstopreversedmod;02C1
+glottalstopreversedsuperior;02E4
+glottalstopstroke;02A1
+glottalstopstrokereversed;02A2
+gmacron;1E21
+gmonospace;FF47
+gohiragana;3054
+gokatakana;30B4
+gparen;24A2
+gpasquare;33AC
+gradient;2207
+grave;0060
+gravebelowcmb;0316
+gravecmb;0300
+gravecomb;0300
+gravedeva;0953
+gravelowmod;02CE
+gravemonospace;FF40
+gravetonecmb;0340
+greater;003E
+greaterequal;2265
+greaterequalorless;22DB
+greatermonospace;FF1E
+greaterorequivalent;2273
+greaterorless;2277
+greateroverequal;2267
+greatersmall;FE65
+gscript;0261
+gstroke;01E5
+guhiragana;3050
+guillemotleft;00AB
+guillemotright;00BB
+guilsinglleft;2039
+guilsinglright;203A
+gukatakana;30B0
+guramusquare;3318
+gysquare;33C9
+h;0068
+haabkhasiancyrillic;04A9
+haaltonearabic;06C1
+habengali;09B9
+hadescendercyrillic;04B3
+hadeva;0939
+hagujarati;0AB9
+hagurmukhi;0A39
+haharabic;062D
+hahfinalarabic;FEA2
+hahinitialarabic;FEA3
+hahiragana;306F
+hahmedialarabic;FEA4
+haitusquare;332A
+hakatakana;30CF
+hakatakanahalfwidth;FF8A
+halantgurmukhi;0A4D
+hamzaarabic;0621
+hamzadammaarabic;0621 064F
+hamzadammatanarabic;0621 064C
+hamzafathaarabic;0621 064E
+hamzafathatanarabic;0621 064B
+hamzalowarabic;0621
+hamzalowkasraarabic;0621 0650
+hamzalowkasratanarabic;0621 064D
+hamzasukunarabic;0621 0652
+hangulfiller;3164
+hardsigncyrillic;044A
+harpoonleftbarbup;21BC
+harpoonrightbarbup;21C0
+hasquare;33CA
+hatafpatah;05B2
+hatafpatah16;05B2
+hatafpatah23;05B2
+hatafpatah2f;05B2
+hatafpatahhebrew;05B2
+hatafpatahnarrowhebrew;05B2
+hatafpatahquarterhebrew;05B2
+hatafpatahwidehebrew;05B2
+hatafqamats;05B3
+hatafqamats1b;05B3
+hatafqamats28;05B3
+hatafqamats34;05B3
+hatafqamatshebrew;05B3
+hatafqamatsnarrowhebrew;05B3
+hatafqamatsquarterhebrew;05B3
+hatafqamatswidehebrew;05B3
+hatafsegol;05B1
+hatafsegol17;05B1
+hatafsegol24;05B1
+hatafsegol30;05B1
+hatafsegolhebrew;05B1
+hatafsegolnarrowhebrew;05B1
+hatafsegolquarterhebrew;05B1
+hatafsegolwidehebrew;05B1
+hbar;0127
+hbopomofo;310F
+hbrevebelow;1E2B
+hcedilla;1E29
+hcircle;24D7
+hcircumflex;0125
+hdieresis;1E27
+hdotaccent;1E23
+hdotbelow;1E25
+he;05D4
+heart;2665
+heartsuitblack;2665
+heartsuitwhite;2661
+hedagesh;FB34
+hedageshhebrew;FB34
+hehaltonearabic;06C1
+heharabic;0647
+hehebrew;05D4
+hehfinalaltonearabic;FBA7
+hehfinalalttwoarabic;FEEA
+hehfinalarabic;FEEA
+hehhamzaabovefinalarabic;FBA5
+hehhamzaaboveisolatedarabic;FBA4
+hehinitialaltonearabic;FBA8
+hehinitialarabic;FEEB
+hehiragana;3078
+hehmedialaltonearabic;FBA9
+hehmedialarabic;FEEC
+heiseierasquare;337B
+hekatakana;30D8
+hekatakanahalfwidth;FF8D
+hekutaarusquare;3336
+henghook;0267
+herutusquare;3339
+het;05D7
+hethebrew;05D7
+hhook;0266
+hhooksuperior;02B1
+hieuhacirclekorean;327B
+hieuhaparenkorean;321B
+hieuhcirclekorean;326D
+hieuhkorean;314E
+hieuhparenkorean;320D
+hihiragana;3072
+hikatakana;30D2
+hikatakanahalfwidth;FF8B
+hiriq;05B4
+hiriq14;05B4
+hiriq21;05B4
+hiriq2d;05B4
+hiriqhebrew;05B4
+hiriqnarrowhebrew;05B4
+hiriqquarterhebrew;05B4
+hiriqwidehebrew;05B4
+hlinebelow;1E96
+hmonospace;FF48
+hoarmenian;0570
+hohipthai;0E2B
+hohiragana;307B
+hokatakana;30DB
+hokatakanahalfwidth;FF8E
+holam;05B9
+holam19;05B9
+holam26;05B9
+holam32;05B9
+holamhebrew;05B9
+holamnarrowhebrew;05B9
+holamquarterhebrew;05B9
+holamwidehebrew;05B9
+honokhukthai;0E2E
+hookabovecomb;0309
+hookcmb;0309
+hookpalatalizedbelowcmb;0321
+hookretroflexbelowcmb;0322
+hoonsquare;3342
+horicoptic;03E9
+horizontalbar;2015
+horncmb;031B
+hotsprings;2668
+house;2302
+hparen;24A3
+hsuperior;02B0
+hturned;0265
+huhiragana;3075
+huiitosquare;3333
+hukatakana;30D5
+hukatakanahalfwidth;FF8C
+hungarumlaut;02DD
+hungarumlautcmb;030B
+hv;0195
+hyphen;002D
+hypheninferior;F6E5
+hyphenmonospace;FF0D
+hyphensmall;FE63
+hyphensuperior;F6E6
+hyphentwo;2010
+i;0069
+iacute;00ED
+iacyrillic;044F
+ibengali;0987
+ibopomofo;3127
+ibreve;012D
+icaron;01D0
+icircle;24D8
+icircumflex;00EE
+icyrillic;0456
+idblgrave;0209
+ideographearthcircle;328F
+ideographfirecircle;328B
+ideographicallianceparen;323F
+ideographiccallparen;323A
+ideographiccentrecircle;32A5
+ideographicclose;3006
+ideographiccomma;3001
+ideographiccommaleft;FF64
+ideographiccongratulationparen;3237
+ideographiccorrectcircle;32A3
+ideographicearthparen;322F
+ideographicenterpriseparen;323D
+ideographicexcellentcircle;329D
+ideographicfestivalparen;3240
+ideographicfinancialcircle;3296
+ideographicfinancialparen;3236
+ideographicfireparen;322B
+ideographichaveparen;3232
+ideographichighcircle;32A4
+ideographiciterationmark;3005
+ideographiclaborcircle;3298
+ideographiclaborparen;3238
+ideographicleftcircle;32A7
+ideographiclowcircle;32A6
+ideographicmedicinecircle;32A9
+ideographicmetalparen;322E
+ideographicmoonparen;322A
+ideographicnameparen;3234
+ideographicperiod;3002
+ideographicprintcircle;329E
+ideographicreachparen;3243
+ideographicrepresentparen;3239
+ideographicresourceparen;323E
+ideographicrightcircle;32A8
+ideographicsecretcircle;3299
+ideographicselfparen;3242
+ideographicsocietyparen;3233
+ideographicspace;3000
+ideographicspecialparen;3235
+ideographicstockparen;3231
+ideographicstudyparen;323B
+ideographicsunparen;3230
+ideographicsuperviseparen;323C
+ideographicwaterparen;322C
+ideographicwoodparen;322D
+ideographiczero;3007
+ideographmetalcircle;328E
+ideographmooncircle;328A
+ideographnamecircle;3294
+ideographsuncircle;3290
+ideographwatercircle;328C
+ideographwoodcircle;328D
+ideva;0907
+idieresis;00EF
+idieresisacute;1E2F
+idieresiscyrillic;04E5
+idotbelow;1ECB
+iebrevecyrillic;04D7
+iecyrillic;0435
+ieungacirclekorean;3275
+ieungaparenkorean;3215
+ieungcirclekorean;3267
+ieungkorean;3147
+ieungparenkorean;3207
+igrave;00EC
+igujarati;0A87
+igurmukhi;0A07
+ihiragana;3044
+ihookabove;1EC9
+iibengali;0988
+iicyrillic;0438
+iideva;0908
+iigujarati;0A88
+iigurmukhi;0A08
+iimatragurmukhi;0A40
+iinvertedbreve;020B
+iishortcyrillic;0439
+iivowelsignbengali;09C0
+iivowelsigndeva;0940
+iivowelsigngujarati;0AC0
+ij;0133
+ikatakana;30A4
+ikatakanahalfwidth;FF72
+ikorean;3163
+ilde;02DC
+iluyhebrew;05AC
+imacron;012B
+imacroncyrillic;04E3
+imageorapproximatelyequal;2253
+imatragurmukhi;0A3F
+imonospace;FF49
+increment;2206
+infinity;221E
+iniarmenian;056B
+integral;222B
+integralbottom;2321
+integralbt;2321
+integralex;F8F5
+integraltop;2320
+integraltp;2320
+intersection;2229
+intisquare;3305
+invbullet;25D8
+invcircle;25D9
+invsmileface;263B
+iocyrillic;0451
+iogonek;012F
+iota;03B9
+iotadieresis;03CA
+iotadieresistonos;0390
+iotalatin;0269
+iotatonos;03AF
+iparen;24A4
+irigurmukhi;0A72
+ismallhiragana;3043
+ismallkatakana;30A3
+ismallkatakanahalfwidth;FF68
+issharbengali;09FA
+istroke;0268
+isuperior;F6ED
+iterationhiragana;309D
+iterationkatakana;30FD
+itilde;0129
+itildebelow;1E2D
+iubopomofo;3129
+iucyrillic;044E
+ivowelsignbengali;09BF
+ivowelsigndeva;093F
+ivowelsigngujarati;0ABF
+izhitsacyrillic;0475
+izhitsadblgravecyrillic;0477
+j;006A
+jaarmenian;0571
+jabengali;099C
+jadeva;091C
+jagujarati;0A9C
+jagurmukhi;0A1C
+jbopomofo;3110
+jcaron;01F0
+jcircle;24D9
+jcircumflex;0135
+jcrossedtail;029D
+jdotlessstroke;025F
+jecyrillic;0458
+jeemarabic;062C
+jeemfinalarabic;FE9E
+jeeminitialarabic;FE9F
+jeemmedialarabic;FEA0
+jeharabic;0698
+jehfinalarabic;FB8B
+jhabengali;099D
+jhadeva;091D
+jhagujarati;0A9D
+jhagurmukhi;0A1D
+jheharmenian;057B
+jis;3004
+jmonospace;FF4A
+jparen;24A5
+jsuperior;02B2
+k;006B
+kabashkircyrillic;04A1
+kabengali;0995
+kacute;1E31
+kacyrillic;043A
+kadescendercyrillic;049B
+kadeva;0915
+kaf;05DB
+kafarabic;0643
+kafdagesh;FB3B
+kafdageshhebrew;FB3B
+kaffinalarabic;FEDA
+kafhebrew;05DB
+kafinitialarabic;FEDB
+kafmedialarabic;FEDC
+kafrafehebrew;FB4D
+kagujarati;0A95
+kagurmukhi;0A15
+kahiragana;304B
+kahookcyrillic;04C4
+kakatakana;30AB
+kakatakanahalfwidth;FF76
+kappa;03BA
+kappasymbolgreek;03F0
+kapyeounmieumkorean;3171
+kapyeounphieuphkorean;3184
+kapyeounpieupkorean;3178
+kapyeounssangpieupkorean;3179
+karoriisquare;330D
+kashidaautoarabic;0640
+kashidaautonosidebearingarabic;0640
+kasmallkatakana;30F5
+kasquare;3384
+kasraarabic;0650
+kasratanarabic;064D
+kastrokecyrillic;049F
+katahiraprolongmarkhalfwidth;FF70
+kaverticalstrokecyrillic;049D
+kbopomofo;310E
+kcalsquare;3389
+kcaron;01E9
+kcedilla;0137
+kcircle;24DA
+kcommaaccent;0137
+kdotbelow;1E33
+keharmenian;0584
+kehiragana;3051
+kekatakana;30B1
+kekatakanahalfwidth;FF79
+kenarmenian;056F
+kesmallkatakana;30F6
+kgreenlandic;0138
+khabengali;0996
+khacyrillic;0445
+khadeva;0916
+khagujarati;0A96
+khagurmukhi;0A16
+khaharabic;062E
+khahfinalarabic;FEA6
+khahinitialarabic;FEA7
+khahmedialarabic;FEA8
+kheicoptic;03E7
+khhadeva;0959
+khhagurmukhi;0A59
+khieukhacirclekorean;3278
+khieukhaparenkorean;3218
+khieukhcirclekorean;326A
+khieukhkorean;314B
+khieukhparenkorean;320A
+khokhaithai;0E02
+khokhonthai;0E05
+khokhuatthai;0E03
+khokhwaithai;0E04
+khomutthai;0E5B
+khook;0199
+khorakhangthai;0E06
+khzsquare;3391
+kihiragana;304D
+kikatakana;30AD
+kikatakanahalfwidth;FF77
+kiroguramusquare;3315
+kiromeetorusquare;3316
+kirosquare;3314
+kiyeokacirclekorean;326E
+kiyeokaparenkorean;320E
+kiyeokcirclekorean;3260
+kiyeokkorean;3131
+kiyeokparenkorean;3200
+kiyeoksioskorean;3133
+kjecyrillic;045C
+klinebelow;1E35
+klsquare;3398
+kmcubedsquare;33A6
+kmonospace;FF4B
+kmsquaredsquare;33A2
+kohiragana;3053
+kohmsquare;33C0
+kokaithai;0E01
+kokatakana;30B3
+kokatakanahalfwidth;FF7A
+kooposquare;331E
+koppacyrillic;0481
+koreanstandardsymbol;327F
+koroniscmb;0343
+kparen;24A6
+kpasquare;33AA
+ksicyrillic;046F
+ktsquare;33CF
+kturned;029E
+kuhiragana;304F
+kukatakana;30AF
+kukatakanahalfwidth;FF78
+kvsquare;33B8
+kwsquare;33BE
+l;006C
+labengali;09B2
+lacute;013A
+ladeva;0932
+lagujarati;0AB2
+lagurmukhi;0A32
+lakkhangyaothai;0E45
+lamaleffinalarabic;FEFC
+lamalefhamzaabovefinalarabic;FEF8
+lamalefhamzaaboveisolatedarabic;FEF7
+lamalefhamzabelowfinalarabic;FEFA
+lamalefhamzabelowisolatedarabic;FEF9
+lamalefisolatedarabic;FEFB
+lamalefmaddaabovefinalarabic;FEF6
+lamalefmaddaaboveisolatedarabic;FEF5
+lamarabic;0644
+lambda;03BB
+lambdastroke;019B
+lamed;05DC
+lameddagesh;FB3C
+lameddageshhebrew;FB3C
+lamedhebrew;05DC
+lamedholam;05DC 05B9
+lamedholamdagesh;05DC 05B9 05BC
+lamedholamdageshhebrew;05DC 05B9 05BC
+lamedholamhebrew;05DC 05B9
+lamfinalarabic;FEDE
+lamhahinitialarabic;FCCA
+laminitialarabic;FEDF
+lamjeeminitialarabic;FCC9
+lamkhahinitialarabic;FCCB
+lamlamhehisolatedarabic;FDF2
+lammedialarabic;FEE0
+lammeemhahinitialarabic;FD88
+lammeeminitialarabic;FCCC
+lammeemjeeminitialarabic;FEDF FEE4 FEA0
+lammeemkhahinitialarabic;FEDF FEE4 FEA8
+largecircle;25EF
+lbar;019A
+lbelt;026C
+lbopomofo;310C
+lcaron;013E
+lcedilla;013C
+lcircle;24DB
+lcircumflexbelow;1E3D
+lcommaaccent;013C
+ldot;0140
+ldotaccent;0140
+ldotbelow;1E37
+ldotbelowmacron;1E39
+leftangleabovecmb;031A
+lefttackbelowcmb;0318
+less;003C
+lessequal;2264
+lessequalorgreater;22DA
+lessmonospace;FF1C
+lessorequivalent;2272
+lessorgreater;2276
+lessoverequal;2266
+lesssmall;FE64
+lezh;026E
+lfblock;258C
+lhookretroflex;026D
+lira;20A4
+liwnarmenian;056C
+lj;01C9
+ljecyrillic;0459
+ll;F6C0
+lladeva;0933
+llagujarati;0AB3
+llinebelow;1E3B
+llladeva;0934
+llvocalicbengali;09E1
+llvocalicdeva;0961
+llvocalicvowelsignbengali;09E3
+llvocalicvowelsigndeva;0963
+lmiddletilde;026B
+lmonospace;FF4C
+lmsquare;33D0
+lochulathai;0E2C
+logicaland;2227
+logicalnot;00AC
+logicalnotreversed;2310
+logicalor;2228
+lolingthai;0E25
+longs;017F
+lowlinecenterline;FE4E
+lowlinecmb;0332
+lowlinedashed;FE4D
+lozenge;25CA
+lparen;24A7
+lslash;0142
+lsquare;2113
+lsuperior;F6EE
+ltshade;2591
+luthai;0E26
+lvocalicbengali;098C
+lvocalicdeva;090C
+lvocalicvowelsignbengali;09E2
+lvocalicvowelsigndeva;0962
+lxsquare;33D3
+m;006D
+mabengali;09AE
+macron;00AF
+macronbelowcmb;0331
+macroncmb;0304
+macronlowmod;02CD
+macronmonospace;FFE3
+macute;1E3F
+madeva;092E
+magujarati;0AAE
+magurmukhi;0A2E
+mahapakhhebrew;05A4
+mahapakhlefthebrew;05A4
+mahiragana;307E
+maichattawalowleftthai;F895
+maichattawalowrightthai;F894
+maichattawathai;0E4B
+maichattawaupperleftthai;F893
+maieklowleftthai;F88C
+maieklowrightthai;F88B
+maiekthai;0E48
+maiekupperleftthai;F88A
+maihanakatleftthai;F884
+maihanakatthai;0E31
+maitaikhuleftthai;F889
+maitaikhuthai;0E47
+maitholowleftthai;F88F
+maitholowrightthai;F88E
+maithothai;0E49
+maithoupperleftthai;F88D
+maitrilowleftthai;F892
+maitrilowrightthai;F891
+maitrithai;0E4A
+maitriupperleftthai;F890
+maiyamokthai;0E46
+makatakana;30DE
+makatakanahalfwidth;FF8F
+male;2642
+mansyonsquare;3347
+maqafhebrew;05BE
+mars;2642
+masoracirclehebrew;05AF
+masquare;3383
+mbopomofo;3107
+mbsquare;33D4
+mcircle;24DC
+mcubedsquare;33A5
+mdotaccent;1E41
+mdotbelow;1E43
+meemarabic;0645
+meemfinalarabic;FEE2
+meeminitialarabic;FEE3
+meemmedialarabic;FEE4
+meemmeeminitialarabic;FCD1
+meemmeemisolatedarabic;FC48
+meetorusquare;334D
+mehiragana;3081
+meizierasquare;337E
+mekatakana;30E1
+mekatakanahalfwidth;FF92
+mem;05DE
+memdagesh;FB3E
+memdageshhebrew;FB3E
+memhebrew;05DE
+menarmenian;0574
+merkhahebrew;05A5
+merkhakefulahebrew;05A6
+merkhakefulalefthebrew;05A6
+merkhalefthebrew;05A5
+mhook;0271
+mhzsquare;3392
+middledotkatakanahalfwidth;FF65
+middot;00B7
+mieumacirclekorean;3272
+mieumaparenkorean;3212
+mieumcirclekorean;3264
+mieumkorean;3141
+mieumpansioskorean;3170
+mieumparenkorean;3204
+mieumpieupkorean;316E
+mieumsioskorean;316F
+mihiragana;307F
+mikatakana;30DF
+mikatakanahalfwidth;FF90
+minus;2212
+minusbelowcmb;0320
+minuscircle;2296
+minusmod;02D7
+minusplus;2213
+minute;2032
+miribaarusquare;334A
+mirisquare;3349
+mlonglegturned;0270
+mlsquare;3396
+mmcubedsquare;33A3
+mmonospace;FF4D
+mmsquaredsquare;339F
+mohiragana;3082
+mohmsquare;33C1
+mokatakana;30E2
+mokatakanahalfwidth;FF93
+molsquare;33D6
+momathai;0E21
+moverssquare;33A7
+moverssquaredsquare;33A8
+mparen;24A8
+mpasquare;33AB
+mssquare;33B3
+msuperior;F6EF
+mturned;026F
+mu;00B5
+mu1;00B5
+muasquare;3382
+muchgreater;226B
+muchless;226A
+mufsquare;338C
+mugreek;03BC
+mugsquare;338D
+muhiragana;3080
+mukatakana;30E0
+mukatakanahalfwidth;FF91
+mulsquare;3395
+multiply;00D7
+mumsquare;339B
+munahhebrew;05A3
+munahlefthebrew;05A3
+musicalnote;266A
+musicalnotedbl;266B
+musicflatsign;266D
+musicsharpsign;266F
+mussquare;33B2
+muvsquare;33B6
+muwsquare;33BC
+mvmegasquare;33B9
+mvsquare;33B7
+mwmegasquare;33BF
+mwsquare;33BD
+n;006E
+nabengali;09A8
+nabla;2207
+nacute;0144
+nadeva;0928
+nagujarati;0AA8
+nagurmukhi;0A28
+nahiragana;306A
+nakatakana;30CA
+nakatakanahalfwidth;FF85
+napostrophe;0149
+nasquare;3381
+nbopomofo;310B
+nbspace;00A0
+ncaron;0148
+ncedilla;0146
+ncircle;24DD
+ncircumflexbelow;1E4B
+ncommaaccent;0146
+ndotaccent;1E45
+ndotbelow;1E47
+nehiragana;306D
+nekatakana;30CD
+nekatakanahalfwidth;FF88
+newsheqelsign;20AA
+nfsquare;338B
+ngabengali;0999
+ngadeva;0919
+ngagujarati;0A99
+ngagurmukhi;0A19
+ngonguthai;0E07
+nhiragana;3093
+nhookleft;0272
+nhookretroflex;0273
+nieunacirclekorean;326F
+nieunaparenkorean;320F
+nieuncieuckorean;3135
+nieuncirclekorean;3261
+nieunhieuhkorean;3136
+nieunkorean;3134
+nieunpansioskorean;3168
+nieunparenkorean;3201
+nieunsioskorean;3167
+nieuntikeutkorean;3166
+nihiragana;306B
+nikatakana;30CB
+nikatakanahalfwidth;FF86
+nikhahitleftthai;F899
+nikhahitthai;0E4D
+nine;0039
+ninearabic;0669
+ninebengali;09EF
+ninecircle;2468
+ninecircleinversesansserif;2792
+ninedeva;096F
+ninegujarati;0AEF
+ninegurmukhi;0A6F
+ninehackarabic;0669
+ninehangzhou;3029
+nineideographicparen;3228
+nineinferior;2089
+ninemonospace;FF19
+nineoldstyle;F739
+nineparen;247C
+nineperiod;2490
+ninepersian;06F9
+nineroman;2178
+ninesuperior;2079
+nineteencircle;2472
+nineteenparen;2486
+nineteenperiod;249A
+ninethai;0E59
+nj;01CC
+njecyrillic;045A
+nkatakana;30F3
+nkatakanahalfwidth;FF9D
+nlegrightlong;019E
+nlinebelow;1E49
+nmonospace;FF4E
+nmsquare;339A
+nnabengali;09A3
+nnadeva;0923
+nnagujarati;0AA3
+nnagurmukhi;0A23
+nnnadeva;0929
+nohiragana;306E
+nokatakana;30CE
+nokatakanahalfwidth;FF89
+nonbreakingspace;00A0
+nonenthai;0E13
+nonuthai;0E19
+noonarabic;0646
+noonfinalarabic;FEE6
+noonghunnaarabic;06BA
+noonghunnafinalarabic;FB9F
+noonhehinitialarabic;FEE7 FEEC
+nooninitialarabic;FEE7
+noonjeeminitialarabic;FCD2
+noonjeemisolatedarabic;FC4B
+noonmedialarabic;FEE8
+noonmeeminitialarabic;FCD5
+noonmeemisolatedarabic;FC4E
+noonnoonfinalarabic;FC8D
+notcontains;220C
+notelement;2209
+notelementof;2209
+notequal;2260
+notgreater;226F
+notgreaternorequal;2271
+notgreaternorless;2279
+notidentical;2262
+notless;226E
+notlessnorequal;2270
+notparallel;2226
+notprecedes;2280
+notsubset;2284
+notsucceeds;2281
+notsuperset;2285
+nowarmenian;0576
+nparen;24A9
+nssquare;33B1
+nsuperior;207F
+ntilde;00F1
+nu;03BD
+nuhiragana;306C
+nukatakana;30CC
+nukatakanahalfwidth;FF87
+nuktabengali;09BC
+nuktadeva;093C
+nuktagujarati;0ABC
+nuktagurmukhi;0A3C
+numbersign;0023
+numbersignmonospace;FF03
+numbersignsmall;FE5F
+numeralsigngreek;0374
+numeralsignlowergreek;0375
+numero;2116
+nun;05E0
+nundagesh;FB40
+nundageshhebrew;FB40
+nunhebrew;05E0
+nvsquare;33B5
+nwsquare;33BB
+nyabengali;099E
+nyadeva;091E
+nyagujarati;0A9E
+nyagurmukhi;0A1E
+o;006F
+oacute;00F3
+oangthai;0E2D
+obarred;0275
+obarredcyrillic;04E9
+obarreddieresiscyrillic;04EB
+obengali;0993
+obopomofo;311B
+obreve;014F
+ocandradeva;0911
+ocandragujarati;0A91
+ocandravowelsigndeva;0949
+ocandravowelsigngujarati;0AC9
+ocaron;01D2
+ocircle;24DE
+ocircumflex;00F4
+ocircumflexacute;1ED1
+ocircumflexdotbelow;1ED9
+ocircumflexgrave;1ED3
+ocircumflexhookabove;1ED5
+ocircumflextilde;1ED7
+ocyrillic;043E
+odblacute;0151
+odblgrave;020D
+odeva;0913
+odieresis;00F6
+odieresiscyrillic;04E7
+odotbelow;1ECD
+oe;0153
+oekorean;315A
+ogonek;02DB
+ogonekcmb;0328
+ograve;00F2
+ogujarati;0A93
+oharmenian;0585
+ohiragana;304A
+ohookabove;1ECF
+ohorn;01A1
+ohornacute;1EDB
+ohorndotbelow;1EE3
+ohorngrave;1EDD
+ohornhookabove;1EDF
+ohorntilde;1EE1
+ohungarumlaut;0151
+oi;01A3
+oinvertedbreve;020F
+okatakana;30AA
+okatakanahalfwidth;FF75
+okorean;3157
+olehebrew;05AB
+omacron;014D
+omacronacute;1E53
+omacrongrave;1E51
+omdeva;0950
+omega;03C9
+omega1;03D6
+omegacyrillic;0461
+omegalatinclosed;0277
+omegaroundcyrillic;047B
+omegatitlocyrillic;047D
+omegatonos;03CE
+omgujarati;0AD0
+omicron;03BF
+omicrontonos;03CC
+omonospace;FF4F
+one;0031
+onearabic;0661
+onebengali;09E7
+onecircle;2460
+onecircleinversesansserif;278A
+onedeva;0967
+onedotenleader;2024
+oneeighth;215B
+onefitted;F6DC
+onegujarati;0AE7
+onegurmukhi;0A67
+onehackarabic;0661
+onehalf;00BD
+onehangzhou;3021
+oneideographicparen;3220
+oneinferior;2081
+onemonospace;FF11
+onenumeratorbengali;09F4
+oneoldstyle;F731
+oneparen;2474
+oneperiod;2488
+onepersian;06F1
+onequarter;00BC
+oneroman;2170
+onesuperior;00B9
+onethai;0E51
+onethird;2153
+oogonek;01EB
+oogonekmacron;01ED
+oogurmukhi;0A13
+oomatragurmukhi;0A4B
+oopen;0254
+oparen;24AA
+openbullet;25E6
+option;2325
+ordfeminine;00AA
+ordmasculine;00BA
+orthogonal;221F
+oshortdeva;0912
+oshortvowelsigndeva;094A
+oslash;00F8
+oslashacute;01FF
+osmallhiragana;3049
+osmallkatakana;30A9
+osmallkatakanahalfwidth;FF6B
+ostrokeacute;01FF
+osuperior;F6F0
+otcyrillic;047F
+otilde;00F5
+otildeacute;1E4D
+otildedieresis;1E4F
+oubopomofo;3121
+overline;203E
+overlinecenterline;FE4A
+overlinecmb;0305
+overlinedashed;FE49
+overlinedblwavy;FE4C
+overlinewavy;FE4B
+overscore;00AF
+ovowelsignbengali;09CB
+ovowelsigndeva;094B
+ovowelsigngujarati;0ACB
+p;0070
+paampssquare;3380
+paasentosquare;332B
+pabengali;09AA
+pacute;1E55
+padeva;092A
+pagedown;21DF
+pageup;21DE
+pagujarati;0AAA
+pagurmukhi;0A2A
+pahiragana;3071
+paiyannoithai;0E2F
+pakatakana;30D1
+palatalizationcyrilliccmb;0484
+palochkacyrillic;04C0
+pansioskorean;317F
+paragraph;00B6
+parallel;2225
+parenleft;0028
+parenleftaltonearabic;FD3E
+parenleftbt;F8ED
+parenleftex;F8EC
+parenleftinferior;208D
+parenleftmonospace;FF08
+parenleftsmall;FE59
+parenleftsuperior;207D
+parenlefttp;F8EB
+parenleftvertical;FE35
+parenright;0029
+parenrightaltonearabic;FD3F
+parenrightbt;F8F8
+parenrightex;F8F7
+parenrightinferior;208E
+parenrightmonospace;FF09
+parenrightsmall;FE5A
+parenrightsuperior;207E
+parenrighttp;F8F6
+parenrightvertical;FE36
+partialdiff;2202
+paseqhebrew;05C0
+pashtahebrew;0599
+pasquare;33A9
+patah;05B7
+patah11;05B7
+patah1d;05B7
+patah2a;05B7
+patahhebrew;05B7
+patahnarrowhebrew;05B7
+patahquarterhebrew;05B7
+patahwidehebrew;05B7
+pazerhebrew;05A1
+pbopomofo;3106
+pcircle;24DF
+pdotaccent;1E57
+pe;05E4
+pecyrillic;043F
+pedagesh;FB44
+pedageshhebrew;FB44
+peezisquare;333B
+pefinaldageshhebrew;FB43
+peharabic;067E
+peharmenian;057A
+pehebrew;05E4
+pehfinalarabic;FB57
+pehinitialarabic;FB58
+pehiragana;307A
+pehmedialarabic;FB59
+pekatakana;30DA
+pemiddlehookcyrillic;04A7
+perafehebrew;FB4E
+percent;0025
+percentarabic;066A
+percentmonospace;FF05
+percentsmall;FE6A
+period;002E
+periodarmenian;0589
+periodcentered;00B7
+periodhalfwidth;FF61
+periodinferior;F6E7
+periodmonospace;FF0E
+periodsmall;FE52
+periodsuperior;F6E8
+perispomenigreekcmb;0342
+perpendicular;22A5
+perthousand;2030
+peseta;20A7
+pfsquare;338A
+phabengali;09AB
+phadeva;092B
+phagujarati;0AAB
+phagurmukhi;0A2B
+phi;03C6
+phi1;03D5
+phieuphacirclekorean;327A
+phieuphaparenkorean;321A
+phieuphcirclekorean;326C
+phieuphkorean;314D
+phieuphparenkorean;320C
+philatin;0278
+phinthuthai;0E3A
+phisymbolgreek;03D5
+phook;01A5
+phophanthai;0E1E
+phophungthai;0E1C
+phosamphaothai;0E20
+pi;03C0
+pieupacirclekorean;3273
+pieupaparenkorean;3213
+pieupcieuckorean;3176
+pieupcirclekorean;3265
+pieupkiyeokkorean;3172
+pieupkorean;3142
+pieupparenkorean;3205
+pieupsioskiyeokkorean;3174
+pieupsioskorean;3144
+pieupsiostikeutkorean;3175
+pieupthieuthkorean;3177
+pieuptikeutkorean;3173
+pihiragana;3074
+pikatakana;30D4
+pisymbolgreek;03D6
+piwrarmenian;0583
+plus;002B
+plusbelowcmb;031F
+pluscircle;2295
+plusminus;00B1
+plusmod;02D6
+plusmonospace;FF0B
+plussmall;FE62
+plussuperior;207A
+pmonospace;FF50
+pmsquare;33D8
+pohiragana;307D
+pointingindexdownwhite;261F
+pointingindexleftwhite;261C
+pointingindexrightwhite;261E
+pointingindexupwhite;261D
+pokatakana;30DD
+poplathai;0E1B
+postalmark;3012
+postalmarkface;3020
+pparen;24AB
+precedes;227A
+prescription;211E
+primemod;02B9
+primereversed;2035
+product;220F
+projective;2305
+prolongedkana;30FC
+propellor;2318
+propersubset;2282
+propersuperset;2283
+proportion;2237
+proportional;221D
+psi;03C8
+psicyrillic;0471
+psilipneumatacyrilliccmb;0486
+pssquare;33B0
+puhiragana;3077
+pukatakana;30D7
+pvsquare;33B4
+pwsquare;33BA
+q;0071
+qadeva;0958
+qadmahebrew;05A8
+qafarabic;0642
+qaffinalarabic;FED6
+qafinitialarabic;FED7
+qafmedialarabic;FED8
+qamats;05B8
+qamats10;05B8
+qamats1a;05B8
+qamats1c;05B8
+qamats27;05B8
+qamats29;05B8
+qamats33;05B8
+qamatsde;05B8
+qamatshebrew;05B8
+qamatsnarrowhebrew;05B8
+qamatsqatanhebrew;05B8
+qamatsqatannarrowhebrew;05B8
+qamatsqatanquarterhebrew;05B8
+qamatsqatanwidehebrew;05B8
+qamatsquarterhebrew;05B8
+qamatswidehebrew;05B8
+qarneyparahebrew;059F
+qbopomofo;3111
+qcircle;24E0
+qhook;02A0
+qmonospace;FF51
+qof;05E7
+qofdagesh;FB47
+qofdageshhebrew;FB47
+qofhatafpatah;05E7 05B2
+qofhatafpatahhebrew;05E7 05B2
+qofhatafsegol;05E7 05B1
+qofhatafsegolhebrew;05E7 05B1
+qofhebrew;05E7
+qofhiriq;05E7 05B4
+qofhiriqhebrew;05E7 05B4
+qofholam;05E7 05B9
+qofholamhebrew;05E7 05B9
+qofpatah;05E7 05B7
+qofpatahhebrew;05E7 05B7
+qofqamats;05E7 05B8
+qofqamatshebrew;05E7 05B8
+qofqubuts;05E7 05BB
+qofqubutshebrew;05E7 05BB
+qofsegol;05E7 05B6
+qofsegolhebrew;05E7 05B6
+qofsheva;05E7 05B0
+qofshevahebrew;05E7 05B0
+qoftsere;05E7 05B5
+qoftserehebrew;05E7 05B5
+qparen;24AC
+quarternote;2669
+qubuts;05BB
+qubuts18;05BB
+qubuts25;05BB
+qubuts31;05BB
+qubutshebrew;05BB
+qubutsnarrowhebrew;05BB
+qubutsquarterhebrew;05BB
+qubutswidehebrew;05BB
+question;003F
+questionarabic;061F
+questionarmenian;055E
+questiondown;00BF
+questiondownsmall;F7BF
+questiongreek;037E
+questionmonospace;FF1F
+questionsmall;F73F
+quotedbl;0022
+quotedblbase;201E
+quotedblleft;201C
+quotedblmonospace;FF02
+quotedblprime;301E
+quotedblprimereversed;301D
+quotedblright;201D
+quoteleft;2018
+quoteleftreversed;201B
+quotereversed;201B
+quoteright;2019
+quoterightn;0149
+quotesinglbase;201A
+quotesingle;0027
+quotesinglemonospace;FF07
+r;0072
+raarmenian;057C
+rabengali;09B0
+racute;0155
+radeva;0930
+radical;221A
+radicalex;F8E5
+radoverssquare;33AE
+radoverssquaredsquare;33AF
+radsquare;33AD
+rafe;05BF
+rafehebrew;05BF
+ragujarati;0AB0
+ragurmukhi;0A30
+rahiragana;3089
+rakatakana;30E9
+rakatakanahalfwidth;FF97
+ralowerdiagonalbengali;09F1
+ramiddlediagonalbengali;09F0
+ramshorn;0264
+ratio;2236
+rbopomofo;3116
+rcaron;0159
+rcedilla;0157
+rcircle;24E1
+rcommaaccent;0157
+rdblgrave;0211
+rdotaccent;1E59
+rdotbelow;1E5B
+rdotbelowmacron;1E5D
+referencemark;203B
+reflexsubset;2286
+reflexsuperset;2287
+registered;00AE
+registersans;F8E8
+registerserif;F6DA
+reharabic;0631
+reharmenian;0580
+rehfinalarabic;FEAE
+rehiragana;308C
+rehyehaleflamarabic;0631 FEF3 FE8E 0644
+rekatakana;30EC
+rekatakanahalfwidth;FF9A
+resh;05E8
+reshdageshhebrew;FB48
+reshhatafpatah;05E8 05B2
+reshhatafpatahhebrew;05E8 05B2
+reshhatafsegol;05E8 05B1
+reshhatafsegolhebrew;05E8 05B1
+reshhebrew;05E8
+reshhiriq;05E8 05B4
+reshhiriqhebrew;05E8 05B4
+reshholam;05E8 05B9
+reshholamhebrew;05E8 05B9
+reshpatah;05E8 05B7
+reshpatahhebrew;05E8 05B7
+reshqamats;05E8 05B8
+reshqamatshebrew;05E8 05B8
+reshqubuts;05E8 05BB
+reshqubutshebrew;05E8 05BB
+reshsegol;05E8 05B6
+reshsegolhebrew;05E8 05B6
+reshsheva;05E8 05B0
+reshshevahebrew;05E8 05B0
+reshtsere;05E8 05B5
+reshtserehebrew;05E8 05B5
+reversedtilde;223D
+reviahebrew;0597
+reviamugrashhebrew;0597
+revlogicalnot;2310
+rfishhook;027E
+rfishhookreversed;027F
+rhabengali;09DD
+rhadeva;095D
+rho;03C1
+rhook;027D
+rhookturned;027B
+rhookturnedsuperior;02B5
+rhosymbolgreek;03F1
+rhotichookmod;02DE
+rieulacirclekorean;3271
+rieulaparenkorean;3211
+rieulcirclekorean;3263
+rieulhieuhkorean;3140
+rieulkiyeokkorean;313A
+rieulkiyeoksioskorean;3169
+rieulkorean;3139
+rieulmieumkorean;313B
+rieulpansioskorean;316C
+rieulparenkorean;3203
+rieulphieuphkorean;313F
+rieulpieupkorean;313C
+rieulpieupsioskorean;316B
+rieulsioskorean;313D
+rieulthieuthkorean;313E
+rieultikeutkorean;316A
+rieulyeorinhieuhkorean;316D
+rightangle;221F
+righttackbelowcmb;0319
+righttriangle;22BF
+rihiragana;308A
+rikatakana;30EA
+rikatakanahalfwidth;FF98
+ring;02DA
+ringbelowcmb;0325
+ringcmb;030A
+ringhalfleft;02BF
+ringhalfleftarmenian;0559
+ringhalfleftbelowcmb;031C
+ringhalfleftcentered;02D3
+ringhalfright;02BE
+ringhalfrightbelowcmb;0339
+ringhalfrightcentered;02D2
+rinvertedbreve;0213
+rittorusquare;3351
+rlinebelow;1E5F
+rlongleg;027C
+rlonglegturned;027A
+rmonospace;FF52
+rohiragana;308D
+rokatakana;30ED
+rokatakanahalfwidth;FF9B
+roruathai;0E23
+rparen;24AD
+rrabengali;09DC
+rradeva;0931
+rragurmukhi;0A5C
+rreharabic;0691
+rrehfinalarabic;FB8D
+rrvocalicbengali;09E0
+rrvocalicdeva;0960
+rrvocalicgujarati;0AE0
+rrvocalicvowelsignbengali;09C4
+rrvocalicvowelsigndeva;0944
+rrvocalicvowelsigngujarati;0AC4
+rsuperior;F6F1
+rtblock;2590
+rturned;0279
+rturnedsuperior;02B4
+ruhiragana;308B
+rukatakana;30EB
+rukatakanahalfwidth;FF99
+rupeemarkbengali;09F2
+rupeesignbengali;09F3
+rupiah;F6DD
+ruthai;0E24
+rvocalicbengali;098B
+rvocalicdeva;090B
+rvocalicgujarati;0A8B
+rvocalicvowelsignbengali;09C3
+rvocalicvowelsigndeva;0943
+rvocalicvowelsigngujarati;0AC3
+s;0073
+sabengali;09B8
+sacute;015B
+sacutedotaccent;1E65
+sadarabic;0635
+sadeva;0938
+sadfinalarabic;FEBA
+sadinitialarabic;FEBB
+sadmedialarabic;FEBC
+sagujarati;0AB8
+sagurmukhi;0A38
+sahiragana;3055
+sakatakana;30B5
+sakatakanahalfwidth;FF7B
+sallallahoualayhewasallamarabic;FDFA
+samekh;05E1
+samekhdagesh;FB41
+samekhdageshhebrew;FB41
+samekhhebrew;05E1
+saraaathai;0E32
+saraaethai;0E41
+saraaimaimalaithai;0E44
+saraaimaimuanthai;0E43
+saraamthai;0E33
+saraathai;0E30
+saraethai;0E40
+saraiileftthai;F886
+saraiithai;0E35
+saraileftthai;F885
+saraithai;0E34
+saraothai;0E42
+saraueeleftthai;F888
+saraueethai;0E37
+saraueleftthai;F887
+sarauethai;0E36
+sarauthai;0E38
+sarauuthai;0E39
+sbopomofo;3119
+scaron;0161
+scarondotaccent;1E67
+scedilla;015F
+schwa;0259
+schwacyrillic;04D9
+schwadieresiscyrillic;04DB
+schwahook;025A
+scircle;24E2
+scircumflex;015D
+scommaaccent;0219
+sdotaccent;1E61
+sdotbelow;1E63
+sdotbelowdotaccent;1E69
+seagullbelowcmb;033C
+second;2033
+secondtonechinese;02CA
+section;00A7
+seenarabic;0633
+seenfinalarabic;FEB2
+seeninitialarabic;FEB3
+seenmedialarabic;FEB4
+segol;05B6
+segol13;05B6
+segol1f;05B6
+segol2c;05B6
+segolhebrew;05B6
+segolnarrowhebrew;05B6
+segolquarterhebrew;05B6
+segoltahebrew;0592
+segolwidehebrew;05B6
+seharmenian;057D
+sehiragana;305B
+sekatakana;30BB
+sekatakanahalfwidth;FF7E
+semicolon;003B
+semicolonarabic;061B
+semicolonmonospace;FF1B
+semicolonsmall;FE54
+semivoicedmarkkana;309C
+semivoicedmarkkanahalfwidth;FF9F
+sentisquare;3322
+sentosquare;3323
+seven;0037
+sevenarabic;0667
+sevenbengali;09ED
+sevencircle;2466
+sevencircleinversesansserif;2790
+sevendeva;096D
+seveneighths;215E
+sevengujarati;0AED
+sevengurmukhi;0A6D
+sevenhackarabic;0667
+sevenhangzhou;3027
+sevenideographicparen;3226
+seveninferior;2087
+sevenmonospace;FF17
+sevenoldstyle;F737
+sevenparen;247A
+sevenperiod;248E
+sevenpersian;06F7
+sevenroman;2176
+sevensuperior;2077
+seventeencircle;2470
+seventeenparen;2484
+seventeenperiod;2498
+seventhai;0E57
+sfthyphen;00AD
+shaarmenian;0577
+shabengali;09B6
+shacyrillic;0448
+shaddaarabic;0651
+shaddadammaarabic;FC61
+shaddadammatanarabic;FC5E
+shaddafathaarabic;FC60
+shaddafathatanarabic;0651 064B
+shaddakasraarabic;FC62
+shaddakasratanarabic;FC5F
+shade;2592
+shadedark;2593
+shadelight;2591
+shademedium;2592
+shadeva;0936
+shagujarati;0AB6
+shagurmukhi;0A36
+shalshelethebrew;0593
+shbopomofo;3115
+shchacyrillic;0449
+sheenarabic;0634
+sheenfinalarabic;FEB6
+sheeninitialarabic;FEB7
+sheenmedialarabic;FEB8
+sheicoptic;03E3
+sheqel;20AA
+sheqelhebrew;20AA
+sheva;05B0
+sheva115;05B0
+sheva15;05B0
+sheva22;05B0
+sheva2e;05B0
+shevahebrew;05B0
+shevanarrowhebrew;05B0
+shevaquarterhebrew;05B0
+shevawidehebrew;05B0
+shhacyrillic;04BB
+shimacoptic;03ED
+shin;05E9
+shindagesh;FB49
+shindageshhebrew;FB49
+shindageshshindot;FB2C
+shindageshshindothebrew;FB2C
+shindageshsindot;FB2D
+shindageshsindothebrew;FB2D
+shindothebrew;05C1
+shinhebrew;05E9
+shinshindot;FB2A
+shinshindothebrew;FB2A
+shinsindot;FB2B
+shinsindothebrew;FB2B
+shook;0282
+sigma;03C3
+sigma1;03C2
+sigmafinal;03C2
+sigmalunatesymbolgreek;03F2
+sihiragana;3057
+sikatakana;30B7
+sikatakanahalfwidth;FF7C
+siluqhebrew;05BD
+siluqlefthebrew;05BD
+similar;223C
+sindothebrew;05C2
+siosacirclekorean;3274
+siosaparenkorean;3214
+sioscieuckorean;317E
+sioscirclekorean;3266
+sioskiyeokkorean;317A
+sioskorean;3145
+siosnieunkorean;317B
+siosparenkorean;3206
+siospieupkorean;317D
+siostikeutkorean;317C
+six;0036
+sixarabic;0666
+sixbengali;09EC
+sixcircle;2465
+sixcircleinversesansserif;278F
+sixdeva;096C
+sixgujarati;0AEC
+sixgurmukhi;0A6C
+sixhackarabic;0666
+sixhangzhou;3026
+sixideographicparen;3225
+sixinferior;2086
+sixmonospace;FF16
+sixoldstyle;F736
+sixparen;2479
+sixperiod;248D
+sixpersian;06F6
+sixroman;2175
+sixsuperior;2076
+sixteencircle;246F
+sixteencurrencydenominatorbengali;09F9
+sixteenparen;2483
+sixteenperiod;2497
+sixthai;0E56
+slash;002F
+slashmonospace;FF0F
+slong;017F
+slongdotaccent;1E9B
+smileface;263A
+smonospace;FF53
+sofpasuqhebrew;05C3
+softhyphen;00AD
+softsigncyrillic;044C
+sohiragana;305D
+sokatakana;30BD
+sokatakanahalfwidth;FF7F
+soliduslongoverlaycmb;0338
+solidusshortoverlaycmb;0337
+sorusithai;0E29
+sosalathai;0E28
+sosothai;0E0B
+sosuathai;0E2A
+space;0020
+spacehackarabic;0020
+spade;2660
+spadesuitblack;2660
+spadesuitwhite;2664
+sparen;24AE
+squarebelowcmb;033B
+squarecc;33C4
+squarecm;339D
+squarediagonalcrosshatchfill;25A9
+squarehorizontalfill;25A4
+squarekg;338F
+squarekm;339E
+squarekmcapital;33CE
+squareln;33D1
+squarelog;33D2
+squaremg;338E
+squaremil;33D5
+squaremm;339C
+squaremsquared;33A1
+squareorthogonalcrosshatchfill;25A6
+squareupperlefttolowerrightfill;25A7
+squareupperrighttolowerleftfill;25A8
+squareverticalfill;25A5
+squarewhitewithsmallblack;25A3
+srsquare;33DB
+ssabengali;09B7
+ssadeva;0937
+ssagujarati;0AB7
+ssangcieuckorean;3149
+ssanghieuhkorean;3185
+ssangieungkorean;3180
+ssangkiyeokkorean;3132
+ssangnieunkorean;3165
+ssangpieupkorean;3143
+ssangsioskorean;3146
+ssangtikeutkorean;3138
+ssuperior;F6F2
+sterling;00A3
+sterlingmonospace;FFE1
+strokelongoverlaycmb;0336
+strokeshortoverlaycmb;0335
+subset;2282
+subsetnotequal;228A
+subsetorequal;2286
+succeeds;227B
+suchthat;220B
+suhiragana;3059
+sukatakana;30B9
+sukatakanahalfwidth;FF7D
+sukunarabic;0652
+summation;2211
+sun;263C
+superset;2283
+supersetnotequal;228B
+supersetorequal;2287
+svsquare;33DC
+syouwaerasquare;337C
+t;0074
+tabengali;09A4
+tackdown;22A4
+tackleft;22A3
+tadeva;0924
+tagujarati;0AA4
+tagurmukhi;0A24
+taharabic;0637
+tahfinalarabic;FEC2
+tahinitialarabic;FEC3
+tahiragana;305F
+tahmedialarabic;FEC4
+taisyouerasquare;337D
+takatakana;30BF
+takatakanahalfwidth;FF80
+tatweelarabic;0640
+tau;03C4
+tav;05EA
+tavdages;FB4A
+tavdagesh;FB4A
+tavdageshhebrew;FB4A
+tavhebrew;05EA
+tbar;0167
+tbopomofo;310A
+tcaron;0165
+tccurl;02A8
+tcedilla;0163
+tcheharabic;0686
+tchehfinalarabic;FB7B
+tchehinitialarabic;FB7C
+tchehmedialarabic;FB7D
+tchehmeeminitialarabic;FB7C FEE4
+tcircle;24E3
+tcircumflexbelow;1E71
+tcommaaccent;0163
+tdieresis;1E97
+tdotaccent;1E6B
+tdotbelow;1E6D
+tecyrillic;0442
+tedescendercyrillic;04AD
+teharabic;062A
+tehfinalarabic;FE96
+tehhahinitialarabic;FCA2
+tehhahisolatedarabic;FC0C
+tehinitialarabic;FE97
+tehiragana;3066
+tehjeeminitialarabic;FCA1
+tehjeemisolatedarabic;FC0B
+tehmarbutaarabic;0629
+tehmarbutafinalarabic;FE94
+tehmedialarabic;FE98
+tehmeeminitialarabic;FCA4
+tehmeemisolatedarabic;FC0E
+tehnoonfinalarabic;FC73
+tekatakana;30C6
+tekatakanahalfwidth;FF83
+telephone;2121
+telephoneblack;260E
+telishagedolahebrew;05A0
+telishaqetanahebrew;05A9
+tencircle;2469
+tenideographicparen;3229
+tenparen;247D
+tenperiod;2491
+tenroman;2179
+tesh;02A7
+tet;05D8
+tetdagesh;FB38
+tetdageshhebrew;FB38
+tethebrew;05D8
+tetsecyrillic;04B5
+tevirhebrew;059B
+tevirlefthebrew;059B
+thabengali;09A5
+thadeva;0925
+thagujarati;0AA5
+thagurmukhi;0A25
+thalarabic;0630
+thalfinalarabic;FEAC
+thanthakhatlowleftthai;F898
+thanthakhatlowrightthai;F897
+thanthakhatthai;0E4C
+thanthakhatupperleftthai;F896
+theharabic;062B
+thehfinalarabic;FE9A
+thehinitialarabic;FE9B
+thehmedialarabic;FE9C
+thereexists;2203
+therefore;2234
+theta;03B8
+theta1;03D1
+thetasymbolgreek;03D1
+thieuthacirclekorean;3279
+thieuthaparenkorean;3219
+thieuthcirclekorean;326B
+thieuthkorean;314C
+thieuthparenkorean;320B
+thirteencircle;246C
+thirteenparen;2480
+thirteenperiod;2494
+thonangmonthothai;0E11
+thook;01AD
+thophuthaothai;0E12
+thorn;00FE
+thothahanthai;0E17
+thothanthai;0E10
+thothongthai;0E18
+thothungthai;0E16
+thousandcyrillic;0482
+thousandsseparatorarabic;066C
+thousandsseparatorpersian;066C
+three;0033
+threearabic;0663
+threebengali;09E9
+threecircle;2462
+threecircleinversesansserif;278C
+threedeva;0969
+threeeighths;215C
+threegujarati;0AE9
+threegurmukhi;0A69
+threehackarabic;0663
+threehangzhou;3023
+threeideographicparen;3222
+threeinferior;2083
+threemonospace;FF13
+threenumeratorbengali;09F6
+threeoldstyle;F733
+threeparen;2476
+threeperiod;248A
+threepersian;06F3
+threequarters;00BE
+threequartersemdash;F6DE
+threeroman;2172
+threesuperior;00B3
+threethai;0E53
+thzsquare;3394
+tihiragana;3061
+tikatakana;30C1
+tikatakanahalfwidth;FF81
+tikeutacirclekorean;3270
+tikeutaparenkorean;3210
+tikeutcirclekorean;3262
+tikeutkorean;3137
+tikeutparenkorean;3202
+tilde;02DC
+tildebelowcmb;0330
+tildecmb;0303
+tildecomb;0303
+tildedoublecmb;0360
+tildeoperator;223C
+tildeoverlaycmb;0334
+tildeverticalcmb;033E
+timescircle;2297
+tipehahebrew;0596
+tipehalefthebrew;0596
+tippigurmukhi;0A70
+titlocyrilliccmb;0483
+tiwnarmenian;057F
+tlinebelow;1E6F
+tmonospace;FF54
+toarmenian;0569
+tohiragana;3068
+tokatakana;30C8
+tokatakanahalfwidth;FF84
+tonebarextrahighmod;02E5
+tonebarextralowmod;02E9
+tonebarhighmod;02E6
+tonebarlowmod;02E8
+tonebarmidmod;02E7
+tonefive;01BD
+tonesix;0185
+tonetwo;01A8
+tonos;0384
+tonsquare;3327
+topatakthai;0E0F
+tortoiseshellbracketleft;3014
+tortoiseshellbracketleftsmall;FE5D
+tortoiseshellbracketleftvertical;FE39
+tortoiseshellbracketright;3015
+tortoiseshellbracketrightsmall;FE5E
+tortoiseshellbracketrightvertical;FE3A
+totaothai;0E15
+tpalatalhook;01AB
+tparen;24AF
+trademark;2122
+trademarksans;F8EA
+trademarkserif;F6DB
+tretroflexhook;0288
+triagdn;25BC
+triaglf;25C4
+triagrt;25BA
+triagup;25B2
+ts;02A6
+tsadi;05E6
+tsadidagesh;FB46
+tsadidageshhebrew;FB46
+tsadihebrew;05E6
+tsecyrillic;0446
+tsere;05B5
+tsere12;05B5
+tsere1e;05B5
+tsere2b;05B5
+tserehebrew;05B5
+tserenarrowhebrew;05B5
+tserequarterhebrew;05B5
+tserewidehebrew;05B5
+tshecyrillic;045B
+tsuperior;F6F3
+ttabengali;099F
+ttadeva;091F
+ttagujarati;0A9F
+ttagurmukhi;0A1F
+tteharabic;0679
+ttehfinalarabic;FB67
+ttehinitialarabic;FB68
+ttehmedialarabic;FB69
+tthabengali;09A0
+tthadeva;0920
+tthagujarati;0AA0
+tthagurmukhi;0A20
+tturned;0287
+tuhiragana;3064
+tukatakana;30C4
+tukatakanahalfwidth;FF82
+tusmallhiragana;3063
+tusmallkatakana;30C3
+tusmallkatakanahalfwidth;FF6F
+twelvecircle;246B
+twelveparen;247F
+twelveperiod;2493
+twelveroman;217B
+twentycircle;2473
+twentyhangzhou;5344
+twentyparen;2487
+twentyperiod;249B
+two;0032
+twoarabic;0662
+twobengali;09E8
+twocircle;2461
+twocircleinversesansserif;278B
+twodeva;0968
+twodotenleader;2025
+twodotleader;2025
+twodotleadervertical;FE30
+twogujarati;0AE8
+twogurmukhi;0A68
+twohackarabic;0662
+twohangzhou;3022
+twoideographicparen;3221
+twoinferior;2082
+twomonospace;FF12
+twonumeratorbengali;09F5
+twooldstyle;F732
+twoparen;2475
+twoperiod;2489
+twopersian;06F2
+tworoman;2171
+twostroke;01BB
+twosuperior;00B2
+twothai;0E52
+twothirds;2154
+u;0075
+uacute;00FA
+ubar;0289
+ubengali;0989
+ubopomofo;3128
+ubreve;016D
+ucaron;01D4
+ucircle;24E4
+ucircumflex;00FB
+ucircumflexbelow;1E77
+ucyrillic;0443
+udattadeva;0951
+udblacute;0171
+udblgrave;0215
+udeva;0909
+udieresis;00FC
+udieresisacute;01D8
+udieresisbelow;1E73
+udieresiscaron;01DA
+udieresiscyrillic;04F1
+udieresisgrave;01DC
+udieresismacron;01D6
+udotbelow;1EE5
+ugrave;00F9
+ugujarati;0A89
+ugurmukhi;0A09
+uhiragana;3046
+uhookabove;1EE7
+uhorn;01B0
+uhornacute;1EE9
+uhorndotbelow;1EF1
+uhorngrave;1EEB
+uhornhookabove;1EED
+uhorntilde;1EEF
+uhungarumlaut;0171
+uhungarumlautcyrillic;04F3
+uinvertedbreve;0217
+ukatakana;30A6
+ukatakanahalfwidth;FF73
+ukcyrillic;0479
+ukorean;315C
+umacron;016B
+umacroncyrillic;04EF
+umacrondieresis;1E7B
+umatragurmukhi;0A41
+umonospace;FF55
+underscore;005F
+underscoredbl;2017
+underscoremonospace;FF3F
+underscorevertical;FE33
+underscorewavy;FE4F
+union;222A
+universal;2200
+uogonek;0173
+uparen;24B0
+upblock;2580
+upperdothebrew;05C4
+upsilon;03C5
+upsilondieresis;03CB
+upsilondieresistonos;03B0
+upsilonlatin;028A
+upsilontonos;03CD
+uptackbelowcmb;031D
+uptackmod;02D4
+uragurmukhi;0A73
+uring;016F
+ushortcyrillic;045E
+usmallhiragana;3045
+usmallkatakana;30A5
+usmallkatakanahalfwidth;FF69
+ustraightcyrillic;04AF
+ustraightstrokecyrillic;04B1
+utilde;0169
+utildeacute;1E79
+utildebelow;1E75
+uubengali;098A
+uudeva;090A
+uugujarati;0A8A
+uugurmukhi;0A0A
+uumatragurmukhi;0A42
+uuvowelsignbengali;09C2
+uuvowelsigndeva;0942
+uuvowelsigngujarati;0AC2
+uvowelsignbengali;09C1
+uvowelsigndeva;0941
+uvowelsigngujarati;0AC1
+v;0076
+vadeva;0935
+vagujarati;0AB5
+vagurmukhi;0A35
+vakatakana;30F7
+vav;05D5
+vavdagesh;FB35
+vavdagesh65;FB35
+vavdageshhebrew;FB35
+vavhebrew;05D5
+vavholam;FB4B
+vavholamhebrew;FB4B
+vavvavhebrew;05F0
+vavyodhebrew;05F1
+vcircle;24E5
+vdotbelow;1E7F
+vecyrillic;0432
+veharabic;06A4
+vehfinalarabic;FB6B
+vehinitialarabic;FB6C
+vehmedialarabic;FB6D
+vekatakana;30F9
+venus;2640
+verticalbar;007C
+verticallineabovecmb;030D
+verticallinebelowcmb;0329
+verticallinelowmod;02CC
+verticallinemod;02C8
+vewarmenian;057E
+vhook;028B
+vikatakana;30F8
+viramabengali;09CD
+viramadeva;094D
+viramagujarati;0ACD
+visargabengali;0983
+visargadeva;0903
+visargagujarati;0A83
+vmonospace;FF56
+voarmenian;0578
+voicediterationhiragana;309E
+voicediterationkatakana;30FE
+voicedmarkkana;309B
+voicedmarkkanahalfwidth;FF9E
+vokatakana;30FA
+vparen;24B1
+vtilde;1E7D
+vturned;028C
+vuhiragana;3094
+vukatakana;30F4
+w;0077
+wacute;1E83
+waekorean;3159
+wahiragana;308F
+wakatakana;30EF
+wakatakanahalfwidth;FF9C
+wakorean;3158
+wasmallhiragana;308E
+wasmallkatakana;30EE
+wattosquare;3357
+wavedash;301C
+wavyunderscorevertical;FE34
+wawarabic;0648
+wawfinalarabic;FEEE
+wawhamzaabovearabic;0624
+wawhamzaabovefinalarabic;FE86
+wbsquare;33DD
+wcircle;24E6
+wcircumflex;0175
+wdieresis;1E85
+wdotaccent;1E87
+wdotbelow;1E89
+wehiragana;3091
+weierstrass;2118
+wekatakana;30F1
+wekorean;315E
+weokorean;315D
+wgrave;1E81
+whitebullet;25E6
+whitecircle;25CB
+whitecircleinverse;25D9
+whitecornerbracketleft;300E
+whitecornerbracketleftvertical;FE43
+whitecornerbracketright;300F
+whitecornerbracketrightvertical;FE44
+whitediamond;25C7
+whitediamondcontainingblacksmalldiamond;25C8
+whitedownpointingsmalltriangle;25BF
+whitedownpointingtriangle;25BD
+whiteleftpointingsmalltriangle;25C3
+whiteleftpointingtriangle;25C1
+whitelenticularbracketleft;3016
+whitelenticularbracketright;3017
+whiterightpointingsmalltriangle;25B9
+whiterightpointingtriangle;25B7
+whitesmallsquare;25AB
+whitesmilingface;263A
+whitesquare;25A1
+whitestar;2606
+whitetelephone;260F
+whitetortoiseshellbracketleft;3018
+whitetortoiseshellbracketright;3019
+whiteuppointingsmalltriangle;25B5
+whiteuppointingtriangle;25B3
+wihiragana;3090
+wikatakana;30F0
+wikorean;315F
+wmonospace;FF57
+wohiragana;3092
+wokatakana;30F2
+wokatakanahalfwidth;FF66
+won;20A9
+wonmonospace;FFE6
+wowaenthai;0E27
+wparen;24B2
+wring;1E98
+wsuperior;02B7
+wturned;028D
+wynn;01BF
+x;0078
+xabovecmb;033D
+xbopomofo;3112
+xcircle;24E7
+xdieresis;1E8D
+xdotaccent;1E8B
+xeharmenian;056D
+xi;03BE
+xmonospace;FF58
+xparen;24B3
+xsuperior;02E3
+y;0079
+yaadosquare;334E
+yabengali;09AF
+yacute;00FD
+yadeva;092F
+yaekorean;3152
+yagujarati;0AAF
+yagurmukhi;0A2F
+yahiragana;3084
+yakatakana;30E4
+yakatakanahalfwidth;FF94
+yakorean;3151
+yamakkanthai;0E4E
+yasmallhiragana;3083
+yasmallkatakana;30E3
+yasmallkatakanahalfwidth;FF6C
+yatcyrillic;0463
+ycircle;24E8
+ycircumflex;0177
+ydieresis;00FF
+ydotaccent;1E8F
+ydotbelow;1EF5
+yeharabic;064A
+yehbarreearabic;06D2
+yehbarreefinalarabic;FBAF
+yehfinalarabic;FEF2
+yehhamzaabovearabic;0626
+yehhamzaabovefinalarabic;FE8A
+yehhamzaaboveinitialarabic;FE8B
+yehhamzaabovemedialarabic;FE8C
+yehinitialarabic;FEF3
+yehmedialarabic;FEF4
+yehmeeminitialarabic;FCDD
+yehmeemisolatedarabic;FC58
+yehnoonfinalarabic;FC94
+yehthreedotsbelowarabic;06D1
+yekorean;3156
+yen;00A5
+yenmonospace;FFE5
+yeokorean;3155
+yeorinhieuhkorean;3186
+yerahbenyomohebrew;05AA
+yerahbenyomolefthebrew;05AA
+yericyrillic;044B
+yerudieresiscyrillic;04F9
+yesieungkorean;3181
+yesieungpansioskorean;3183
+yesieungsioskorean;3182
+yetivhebrew;059A
+ygrave;1EF3
+yhook;01B4
+yhookabove;1EF7
+yiarmenian;0575
+yicyrillic;0457
+yikorean;3162
+yinyang;262F
+yiwnarmenian;0582
+ymonospace;FF59
+yod;05D9
+yoddagesh;FB39
+yoddageshhebrew;FB39
+yodhebrew;05D9
+yodyodhebrew;05F2
+yodyodpatahhebrew;FB1F
+yohiragana;3088
+yoikorean;3189
+yokatakana;30E8
+yokatakanahalfwidth;FF96
+yokorean;315B
+yosmallhiragana;3087
+yosmallkatakana;30E7
+yosmallkatakanahalfwidth;FF6E
+yotgreek;03F3
+yoyaekorean;3188
+yoyakorean;3187
+yoyakthai;0E22
+yoyingthai;0E0D
+yparen;24B4
+ypogegrammeni;037A
+ypogegrammenigreekcmb;0345
+yr;01A6
+yring;1E99
+ysuperior;02B8
+ytilde;1EF9
+yturned;028E
+yuhiragana;3086
+yuikorean;318C
+yukatakana;30E6
+yukatakanahalfwidth;FF95
+yukorean;3160
+yusbigcyrillic;046B
+yusbigiotifiedcyrillic;046D
+yuslittlecyrillic;0467
+yuslittleiotifiedcyrillic;0469
+yusmallhiragana;3085
+yusmallkatakana;30E5
+yusmallkatakanahalfwidth;FF6D
+yuyekorean;318B
+yuyeokorean;318A
+yyabengali;09DF
+yyadeva;095F
+z;007A
+zaarmenian;0566
+zacute;017A
+zadeva;095B
+zagurmukhi;0A5B
+zaharabic;0638
+zahfinalarabic;FEC6
+zahinitialarabic;FEC7
+zahiragana;3056
+zahmedialarabic;FEC8
+zainarabic;0632
+zainfinalarabic;FEB0
+zakatakana;30B6
+zaqefgadolhebrew;0595
+zaqefqatanhebrew;0594
+zarqahebrew;0598
+zayin;05D6
+zayindagesh;FB36
+zayindageshhebrew;FB36
+zayinhebrew;05D6
+zbopomofo;3117
+zcaron;017E
+zcircle;24E9
+zcircumflex;1E91
+zcurl;0291
+zdot;017C
+zdotaccent;017C
+zdotbelow;1E93
+zecyrillic;0437
+zedescendercyrillic;0499
+zedieresiscyrillic;04DF
+zehiragana;305C
+zekatakana;30BC
+zero;0030
+zeroarabic;0660
+zerobengali;09E6
+zerodeva;0966
+zerogujarati;0AE6
+zerogurmukhi;0A66
+zerohackarabic;0660
+zeroinferior;2080
+zeromonospace;FF10
+zerooldstyle;F730
+zeropersian;06F0
+zerosuperior;2070
+zerothai;0E50
+zerowidthjoiner;FEFF
+zerowidthnonjoiner;200C
+zerowidthspace;200B
+zeta;03B6
+zhbopomofo;3113
+zhearmenian;056A
+zhebrevecyrillic;04C2
+zhecyrillic;0436
+zhedescendercyrillic;0497
+zhedieresiscyrillic;04DD
+zihiragana;3058
+zikatakana;30B8
+zinorhebrew;05AE
+zlinebelow;1E95
+zmonospace;FF5A
+zohiragana;305E
+zokatakana;30BE
+zparen;24B5
+zretroflexhook;0290
+zstroke;01B6
+zuhiragana;305A
+zukatakana;30BA
+#--end
diff --git a/collects/afm/glyphshortlist.txt b/collects/afm/glyphshortlist.txt
new file mode 100644
index 0000000000..1032c601e8
--- /dev/null
+++ b/collects/afm/glyphshortlist.txt
@@ -0,0 +1,406 @@
+# Like glyphlist.txt, but includes only
+#  those names used in the .afm fonts
+#  distirbuted with PLT Scheme. Extra
+#  entries in this file map to FFFF
+#  to avoid triggering the use fo glyphlist.txt
+#  for names that won't be there, either.
+space;0020
+exclam;0021
+quotedbl;0022
+numbersign;0023
+dollar;0024
+percent;0025
+ampersand;0026
+quoteright;2019
+parenleft;0028
+parenright;0029
+asterisk;002A
+plus;002B
+comma;002C
+hyphen;002D
+period;002E
+slash;002F
+zero;0030
+one;0031
+two;0032
+three;0033
+four;0034
+five;0035
+six;0036
+seven;0037
+eight;0038
+nine;0039
+colon;003A
+semicolon;003B
+less;003C
+equal;003D
+greater;003E
+question;003F
+at;0040
+A;0041
+B;0042
+C;0043
+D;0044
+E;0045
+F;0046
+G;0047
+H;0048
+I;0049
+J;004A
+K;004B
+L;004C
+M;004D
+N;004E
+O;004F
+P;0050
+Q;0051
+R;0052
+S;0053
+T;0054
+U;0055
+V;0056
+W;0057
+X;0058
+Y;0059
+Z;005A
+bracketleft;005B
+backslash;005C
+bracketright;005D
+asciicircum;005E
+underscore;005F
+quoteleft;2018
+a;0061
+b;0062
+c;0063
+d;0064
+e;0065
+f;0066
+g;0067
+h;0068
+i;0069
+j;006A
+k;006B
+l;006C
+m;006D
+n;006E
+o;006F
+p;0070
+q;0071
+r;0072
+s;0073
+t;0074
+u;0075
+v;0076
+w;0077
+x;0078
+y;0079
+z;007A
+braceleft;007B
+bar;007C
+braceright;007D
+asciitilde;007E
+exclamdown;00A1
+cent;00A2
+sterling;00A3
+fraction;2044
+yen;00A5
+florin;0192
+section;00A7
+currency;00A4
+quotesingle;0027
+quotedblleft;201C
+guillemotleft;00AB
+guilsinglleft;2039
+guilsinglright;203A
+fi;FB01
+fl;FB02
+endash;2013
+dagger;2020
+daggerdbl;2021
+periodcentered;00B7
+paragraph;00B6
+bullet;2022
+quotesinglbase;201A
+quotedblbase;201E
+quotedblright;201D
+guillemotright;00BB
+ellipsis;2026
+perthousand;2030
+questiondown;00BF
+grave;0060
+acute;00B4
+circumflex;02C6
+tilde;02DC
+macron;00AF
+breve;02D8
+dotaccent;02D9
+dieresis;00A8
+ring;02DA
+cedilla;00B8
+hungarumlaut;02DD
+ogonek;02DB
+caron;02C7
+emdash;2014
+AE;00C6
+ordfeminine;00AA
+Lslash;0141
+Oslash;00D8
+OE;0152
+ordmasculine;00BA
+ae;00E6
+dotlessi;0131
+lslash;0142
+oslash;00F8
+oe;0153
+germandbls;00DF
+Aacute;00C1
+Acircumflex;00C2
+Adieresis;00C4
+Agrave;00C0
+Aring;00C5
+Atilde;00C3
+Ccedilla;00C7
+Eacute;00C9
+Ecircumflex;00CA
+Edieresis;00CB
+Egrave;00C8
+Eth;00D0
+Gcaron;01E6
+IJ;0132
+Iacute;00CD
+Icircumflex;00CE
+Idieresis;00CF
+Idot;0130
+Igrave;00CC
+LL;F6BF
+Ntilde;00D1
+Oacute;00D3
+Ocircumflex;00D4
+Odieresis;00D6
+Ograve;00D2
+Otilde;00D5
+Scaron;0160
+Scedilla;015E
+Thorn;00DE
+Uacute;00DA
+Ucircumflex;00DB
+Udieresis;00DC
+Ugrave;00D9
+Yacute;00DD
+Ydieresis;0178
+Zcaron;017D
+aacute;00E1
+acircumflex;00E2
+adieresis;00E4
+agrave;00E0
+aring;00E5
+arrowboth;2194
+arrowdown;2193
+arrowleft;2190
+arrowright;2192
+arrowup;2191
+atilde;00E3
+brokenbar;00A6
+ccedilla;00E7
+center;FFFF
+copyright;00A9
+dectab;FFFF
+degree;00B0
+divide;00F7
+down;FFFF
+eacute;00E9
+ecircumflex;00EA
+edieresis;00EB
+egrave;00E8
+eth;00F0
+format;FFFF
+gcaron;01E7
+graybox;FFFF
+iacute;00ED
+icircumflex;00EE
+idieresis;00EF
+igrave;00EC
+ij;0133
+indent;FFFF
+largebullet;FFFF
+left;FFFF
+lira;20A4
+ll;F6C0
+logicalnot;00AC
+merge;FFFF
+minus;2212
+mu;00B5
+multiply;00D7
+notegraphic;FFFF
+ntilde;00F1
+oacute;00F3
+ocircumflex;00F4
+odieresis;00F6
+ograve;00F2
+onehalf;00BD
+onequarter;00BC
+onesuperior;00B9
+otilde;00F5
+overscore;00AF
+plusminus;00B1
+prescription;211E
+registered;00AE
+return;FFFF
+scaron;0161
+scedilla;015F
+square;FFFF
+stop;FFFF
+tab;FFFF
+thorn;00FE
+threequarters;00BE
+threesuperior;00B3
+trademark;2122
+twosuperior;00B2
+uacute;00FA
+ucircumflex;00FB
+udieresis;00FC
+ugrave;00F9
+up;FFFF
+yacute;00FD
+ydieresis;00FF
+zcaron;017E
+universal;2200
+existential;2203
+suchthat;220B
+asteriskmath;2217
+congruent;2245
+Alpha;0391
+Beta;0392
+Chi;03A7
+Delta;2206
+Epsilon;0395
+Phi;03A6
+Gamma;0393
+Eta;0397
+Iota;0399
+theta1;03D1
+Kappa;039A
+Lambda;039B
+Mu;039C
+Nu;039D
+Omicron;039F
+Pi;03A0
+Theta;0398
+Rho;03A1
+Sigma;03A3
+Tau;03A4
+Upsilon;03A5
+sigma1;03C2
+Omega;2126
+Xi;039E
+Psi;03A8
+Zeta;0396
+therefore;2234
+perpendicular;22A5
+radicalex;F8E5
+alpha;03B1
+beta;03B2
+chi;03C7
+delta;03B4
+epsilon;03B5
+phi;03C6
+gamma;03B3
+eta;03B7
+iota;03B9
+phi1;03D5
+kappa;03BA
+lambda;03BB
+nu;03BD
+omicron;03BF
+pi;03C0
+theta;03B8
+rho;03C1
+sigma;03C3
+tau;03C4
+upsilon;03C5
+omega1;03D6
+omega;03C9
+xi;03BE
+psi;03C8
+zeta;03B6
+similar;223C
+Upsilon1;03D2
+minute;2032
+lessequal;2264
+infinity;221E
+club;2663
+diamond;2666
+heart;2665
+spade;2660
+second;2033
+greaterequal;2265
+proportional;221D
+partialdiff;2202
+notequal;2260
+equivalence;2261
+approxequal;2248
+arrowvertex;F8E6
+arrowhorizex;F8E7
+carriagereturn;21B5
+aleph;2135
+Ifraktur;2111
+Rfraktur;211C
+weierstrass;2118
+circlemultiply;2297
+circleplus;2295
+emptyset;2205
+intersection;2229
+union;222A
+propersuperset;2283
+reflexsuperset;2287
+notsubset;2284
+propersubset;2282
+reflexsubset;2286
+element;2208
+notelement;2209
+angle;2220
+gradient;2207
+registerserif;F6DA
+copyrightserif;F6D9
+trademarkserif;F6DB
+product;220F
+radical;221A
+dotmath;22C5
+logicaland;2227
+logicalor;2228
+arrowdblboth;21D4
+arrowdblleft;21D0
+arrowdblup;21D1
+arrowdblright;21D2
+arrowdbldown;21D3
+lozenge;25CA
+angleleft;2329
+registersans;F8E8
+copyrightsans;F8E9
+trademarksans;F8EA
+summation;2211
+parenlefttp;F8EB
+parenleftex;F8EC
+parenleftbt;F8ED
+bracketlefttp;F8EE
+bracketleftex;F8EF
+bracketleftbt;F8F0
+bracelefttp;F8F1
+braceleftmid;F8F2
+braceleftbt;F8F3
+braceex;F8F4
+angleright;232A
+integral;222B
+integraltp;2320
+integralex;F8F5
+integralbt;2321
+parenrighttp;F8F6
+parenrightex;F8F7
+parenrightbt;F8F8
+bracketrighttp;F8F9
+bracketrightex;F8FA
+bracketrightbt;F8FB
+bracerighttp;F8FC
+bracerightmid;F8FD
+bracerightbt;F8FE
+apple;F8FF
diff --git a/collects/algol60/algol60.ss b/collects/algol60/algol60.ss
new file mode 100644
index 0000000000..37959a756d
--- /dev/null
+++ b/collects/algol60/algol60.ss
@@ -0,0 +1,38 @@
+#cs(module algol60 mzscheme
+     (require-for-syntax "parse.ss" 
+			 ;; Parses to generate an AST. Identifiers in the AST
+			 ;; are represented as syntax objects with source location.
+			 
+                         "simplify.ss"
+			 ;; Desugars the AST, transforming `for' to `if'+`goto',
+			 ;; and flattening `if' statements so they are always
+			 ;; of the for `if <exp> then goto <label> else goto <label>'
+
+                         "compile.ss"
+			 ;; Compiles a simplified AST to Scheme.
+
+                         (lib "file.ss"))
+
+     ;; By using #'here for the context of identifiers
+     ;; introduced by compilation, the identifiers can
+     ;; refer to runtime functions and primitives, as
+     ;; well as mzscheme:
+     (require "runtime.ss" "prims.ss")
+              
+     
+     (provide include-algol)
+     
+     (define-syntax (include-algol stx)
+       (syntax-case stx ()
+         [(_ str)
+          (string? (syntax-e (syntax str)))
+          
+	  (compile-simplified
+	   (simplify 
+	    (parse-a60-file 
+	     (normalize-path (syntax-e (syntax str))
+			     (or
+			      (current-load-relative-directory)
+			      (current-directory))))
+	    #'here)
+	   #'here)])))
diff --git a/collects/algol60/base.ss b/collects/algol60/base.ss
new file mode 100644
index 0000000000..3197ee5e72
--- /dev/null
+++ b/collects/algol60/base.ss
@@ -0,0 +1,7 @@
+(module base mzscheme
+  (require "prims.ss"
+	   "runtime.ss")
+
+  (provide (all-from mzscheme)
+	   (all-from "prims.ss")
+           (all-from "runtime.ss")))
diff --git a/collects/algol60/bd-tool.ss b/collects/algol60/bd-tool.ss
new file mode 100644
index 0000000000..e835d5228e
--- /dev/null
+++ b/collects/algol60/bd-tool.ss
@@ -0,0 +1,22 @@
+(module bd-tool mzscheme 
+  (require (lib "encode-decode.ss" "framework" "private")) 
+  (decode 6d54db8e9b3010fd95291512aeea248d7a9156ea457dea733f60251b
+	  4fc05b63b3b649367fdfb18140225e12983973e676864a62a32d541e
+	  5f07ed112aa325149d47b50ba1189f0a36996b234248f6d930581d83
+	  6ed6a6e89c1943950f758b1d168c7c0a4fda227827e5954b25ae3f09
+	  8f11aa4a4115b0765605fe43894825d483f768239fcc8c25026109f8
+	  9d8808c23b67630b8ac137b6188934998e237e4a2875c3653786df25
+	  efc43fe44ebe601d09143bd19750c9411bc57b41e455ed8c21a77676
+	  3414c234ce7c3d50a78554bb97be29ee32191da3c1ed64d4e9076a35
+	  f936f3eed30c2868aab6c1c82f5ac596c167b6e96d51376d4cee5c41
+	  bdc5cb555d82ec3222c7132c506ca8854138ec8e5ff2cfcaabbcb8f0
+	  31784e7680c343f8e47f7f623379efdd592b84b4fa5fcb40f22b5449
+	  237b1209cc7a784a0e8e6fbdf3313c43a5bbf474ef7e5e68fa5604fc
+	  0467a7d583f1f8601c6760f1c2534e7ef2a2c312c2d0a32f0995d53b
+	  bd5256dba2d7314f530e31e6355b34a9db04e1da86286cd459926b45
+	  65702258fca3ad4c277013c106b1111d0922c92c53e039b2d515ac37
+	  a8b430ae29a1f823fafe0abfb58f2d49e923fc4db27a57a4f1a79ad6
+	  311d86201aea785a9d7af0cf453e70de28d5aa40c0dbd621b4ee92f3
+	  41f53ab8340de9bc42bf12d68489e34184782581cd6085d4212ac616
+	  fcc66cea56d80679ddd201d2f12fa5a4b9d16720cc733713d1a525d4
+	  dd91dd0444ec7b7c8b94e969fc5be901363592a7c9d87f))
diff --git a/collects/algol60/bd.jpg b/collects/algol60/bd.jpg
new file mode 100644
index 0000000000..689dda07cf
Binary files /dev/null and b/collects/algol60/bd.jpg differ
diff --git a/collects/algol60/compile.ss b/collects/algol60/compile.ss
new file mode 100644
index 0000000000..969290e329
--- /dev/null
+++ b/collects/algol60/compile.ss
@@ -0,0 +1,531 @@
+#cs(module compile mzscheme
+     (require "parse.ss"
+              (lib "match.ss")
+              (lib "list.ss"))
+     
+     (provide compile-simplified)
+
+     ;; The compiler generates references to prim.ss and
+     ;; runtime.ss exports, as well as MzScheme forms
+     ;; and functions. The `ctx' argument provides
+     ;; an appropriate context for those bindings (in
+     ;; the form of a syntax object to use with d->s-o).
+     (define (compile-simplified stmt ctx)
+       (datum->syntax-object 
+	ctx
+	(parameterize ([current-compile-context ctx])
+	  (compile-a60 stmt 'void (empty-context) #t))))
+
+     (define current-compile-context (make-parameter #f))
+     
+     (define (compile-a60 stmt next-label context add-to-top-level?)
+       (match stmt
+         [($ a60:block decls statements)
+          (compile-block decls statements next-label context add-to-top-level?)]
+         [else
+          (compile-statement stmt next-label context)]))
+     
+     (define (compile-block decls statements next-label context add-to-top-level?)
+       (let* ([labels-with-numbers (map car statements)]
+              [labels (map (lambda (l)
+                             (if (stx-number? l)
+				 (datum->syntax-object
+				  l
+				  (string->symbol (format "~a" (syntax-e l)))
+				  l
+				  l)
+                                 l))
+                           labels-with-numbers)]
+              ;; Build environment by adding labels, then decls:
+              [context (foldl (lambda (decl context)
+                                (match decl
+                                  [($ a60:proc-decl result-type var arg-vars by-value-vars arg-specs body)
+                                   (add-procedure context var result-type arg-vars by-value-vars arg-specs)]
+                                  [($ a60:type-decl type ids)
+                                   (add-atoms context ids type)]
+                                  [($ a60:array-decl type arrays)
+                                   (add-arrays context 
+                                               (map car arrays) ; names
+                                               (map cdr arrays) ; dimensions
+                                               type)]
+                                  [($ a60:switch-decl name exprs)
+                                   (add-switch context name)]))
+                              (add-labels
+                               context
+                               labels)
+                              decls)])
+         ;; Generate bindings and initialization for all decls,
+         ;; plus all statements (thunked):
+	 (let ([bindings
+		(append
+		 (apply
+		  append
+                  ;; Decls:
+		  (map (lambda (decl)
+			 (match decl
+                           [($ a60:proc-decl result-type var arg-vars by-value-vars arg-specs body)
+                            (let ([code
+                                   `(lambda (kont . ,arg-vars)
+                                      ;; Extract by-value variables
+                                      (let ,(map (lambda (var)
+                                                   `[,var (get-value ,var)])
+                                                 by-value-vars)
+                                        ;; Set up the result variable and done continuation:
+                                        ,(let ([result-var (gensym 'prec-result)]
+                                               [done (gensym 'done)])
+                                           `(let* ([,result-var undefined]
+                                                   [,done (lambda () (kont ,result-var))])
+                                              ;; Include the compiled body:
+                                              ,(compile-a60 body done
+                                                            (add-settable-procedure
+                                                             (add-bindings
+                                                              context
+                                                              arg-vars
+                                                              by-value-vars
+                                                              arg-specs)
+                                                             var
+                                                             result-type
+                                                             result-var)
+                                                            #f)))))])
+                              (if add-to-top-level?
+                                  `([,var
+                                     (let ([tmp ,code])
+                                       (namespace-set-variable-value! ',var tmp)
+                                       tmp)])
+                                  `([,var
+                                     ,code])))]
+			   [($ a60:type-decl type ids)
+			    (map (lambda (id) `[,id undefined]) ids)]
+			   [($ a60:array-decl type arrays)
+			    (map (lambda (array) 
+				   `[,(car array) (make-array
+						   ,@(apply
+						      append
+						      (map
+						       (lambda (bp)
+							 (list
+							  (compile-expression (car bp) context 'num)
+							  (compile-expression (cdr bp) context 'num)))
+						       (cdr array))))])
+				 arrays)]
+			   [($ a60:switch-decl name exprs)
+			    `([,name (make-switch ,@(map (lambda (e) `(lambda () ,(compile-expression e context 'des)))
+							 exprs))])]
+			   [else (error "can't compile decl")]))
+		       decls))
+                 ;; Statements: most of the work is in `compile-statement', but
+                 ;;  we provide the continuation label:
+		 (cdr
+		  (foldr (lambda (stmt label next-label+compiled)
+			   (cons label
+				 (cons
+				  `[,label
+				    (lambda ()
+				      ,(compile-statement (cdr stmt) 
+							  (car next-label+compiled)
+							  context))]
+				  (cdr next-label+compiled))))
+			 (cons next-label null)
+			 statements
+			 labels)))])
+           ;; Check for duplicate bindings:
+	   (let ([dup (check-duplicate-identifier (filter identifier? (map car bindings)))])
+	     (when dup
+	       (raise-syntax-error
+		#f
+		"name defined twice"
+		dup)))
+           ;; Generate code; body of leterec jumps to the first statement label.
+	   `(letrec ,bindings 
+              (,(caar statements))))))
+     
+     (define (compile-statement statement next-label context)
+       (match statement
+         [($ a60:block decls statements)
+          (compile-block decls statements next-label context #f)]
+         [($ a60:branch test ($ a60:goto then) ($ a60:goto else))
+          `(if (check-boolean ,(compile-expression test context 'bool))
+               (goto ,(check-label then context))
+               (goto ,(check-label else context)))]
+         [($ a60:goto label)
+          (at (expression-location label)
+              `(goto ,(compile-expression label context 'des)))]
+         [($ a60:dummy)
+          `(,next-label)]
+         [($ a60:call proc args)
+          (at (expression-location proc)
+              `(,(compile-expression proc context 'func)
+                (lambda (val) 
+                  (,next-label))
+                ,@(map (lambda (arg) (compile-argument arg context))
+                       args)))]
+         [($ a60:assign vars val)
+          ;; >>>>>>>>>>>>>>> Start clean-up here <<<<<<<<<<<<<<<<<
+          ;; Lift out the spec-finding part, and use it to generate
+          ;; an expected type that is passed to `compile-expression':
+          `(begin
+             (let ([val ,(compile-expression val context 'numbool)])
+               ,@(map (lambda (avar)
+                        (let ([var (a60:variable-name avar)])
+                          (at var
+                              (cond
+                                [(null? (a60:variable-indices avar))
+                                 (cond
+                                   [(call-by-name-variable? var context)
+                                    => (lambda (spec)
+                                         `(set-target! ,var ',var (coerce ',(spec-coerce-target spec) val)))]
+                                   [(procedure-result-variable? var context)
+                                    `(set! ,(procedure-result-variable-name var context) 
+                                           (coerce ',(spec-coerce-target (procedure-result-spec var context)) val))]
+                                   [(or (settable-variable? var context)
+                                        (array-element? var context))
+                                    => (lambda (spec)
+                                         `(,(if (own-variable? var context) 'set-box! 'set!)
+                                           ,var
+                                           (coerce ',(spec-coerce-target spec) val)))]
+                                   [else (raise-syntax-error #f "confused by assignment" (expression-location var))])]
+                                [else
+                                 (let ([spec (or (array-element? var context)
+                                                 (call-by-name-variable? var context))])
+                                   `(array-set! ,(compile-expression (make-a60:variable var null) context 'numbool)
+                                                (coerce ',(spec-coerce-target spec) val)
+                                                ,@(map (lambda (e) (compile-expression e context 'num)) 
+                                                       (a60:variable-indices avar))))]))))
+                      vars))
+             (,next-label))]
+         [else (error "can't compile statement")]))
+     
+     (define (compile-expression expr context type)
+       (match expr
+         [(? (lambda (x) (and (syntax? x) (number? (syntax-e x)))) n) 
+	  (if (eq? type 'des)
+	      ;; Need a label:
+	      (check-label (datum->syntax-object expr
+						 (string->symbol (number->string (syntax-e expr)))
+						 expr
+						 expr)
+			   context)
+	      ;; Normal use of a number:
+	      (begin
+		(check-type 'num type expr) 
+		(as-builtin n)))]
+         [(? (lambda (x) (and (syntax? x) (boolean? (syntax-e x)))) n) (check-type 'bool type expr) (as-builtin n)]
+         [(? (lambda (x) (and (syntax? x) (string? (syntax-e x)))) n)  (check-type 'string type expr) (as-builtin n)]
+         [(? identifier? i) (compile-expression (make-a60:variable i null) context type)]
+         [(? symbol? i) ; either a generated label or 'val:
+	  (unless (eq? expr 'val)
+	    (check-type 'des type expr))
+	  (datum->syntax-object #f i)]
+         [($ a60:subscript array index)
+          ;; Maybe a switch index, or maybe an array reference
+	  (at array
+	      (cond
+	       [(array-element? array context)
+		`(array-ref ,array ,(compile-expression index context 'num))]
+	       [(switch-variable? array context)
+		`(switch-ref ,array ,(compile-expression index context 'num))]
+	       [else (raise-syntax-error
+		      #f
+		      "confused by variable"
+		      array)]))]
+         [($ a60:binary t argt op e1 e2)
+	  (check-type t type expr)
+          (at op
+              `(,(as-builtin op) ,(compile-expression e1 context argt) ,(compile-expression e2 context argt)))]
+         [($ a60:unary t argt op e1)
+	  (check-type t type expr)
+          (at op
+              `(,(as-builtin op) ,(compile-expression e1 context argt)))]
+         [($ a60:variable var subscripts)
+          (let ([sub (lambda (wrap v)
+                       (wrap
+                        (if (null? subscripts)
+                            v
+                            `(array-ref ,v ,@(map (lambda (e) (compile-expression e context 'num)) subscripts)))))])
+            (cond
+              [(call-by-name-variable? var context)
+               => (lambda (spec)
+                    (check-spec-type spec type var)
+                    (sub (lambda (val) `(coerce ',(spec-coerce-target spec) ,val)) `(get-value ,var)))]
+	      [(primitive-variable? var context)
+	       => (lambda (name)
+		    (sub values
+                         (datum->syntax-object
+			  (current-compile-context)
+			  name
+			  var
+			  var)))]
+              [(and (procedure-result-variable? var context)
+                    (not (eq? type 'func)))
+               (unless (null? subscripts)
+                 (raise-syntax-error "confused by subscripts" var))
+               (let ([spec (procedure-result-spec var context)])
+                 (check-spec-type spec type var)
+                 (at var
+                     `(coerce
+                       ',(spec-coerce-target spec)
+                       ,(procedure-result-variable-name var context))))]
+              [(or (procedure-result-variable? var context)
+                   (procedure-variable? var context)
+                   (label-variable? var context)
+                   (settable-variable? var context)
+                   (array-element? var context))
+               => (lambda (spec)
+                    (let ([spec (if (or (procedure-result-variable? var context)
+                                        (procedure-variable? var context)
+                                        (and (array-element? var context)
+                                             (null? subscripts)))
+                                    #f ;; need just the proc or array...
+                                    spec)])
+                      (check-spec-type spec type var)
+                      (let ([target (spec-coerce-target spec)])
+                        (sub (if target
+                                 (lambda (v) `(coerce ',target ,v))
+                                 values)
+                             (if (own-variable? var context)
+                                 `(unbox ,var)
+                                 var)))))]
+              [else (raise-syntax-error
+                     #f
+                     "confused by expression"
+                     (expression-location var))]))]
+                   
+         [($ a60:app func args)
+          (at (expression-location func)
+              `(,(compile-expression func context 'func)
+                values
+                ,@(map (lambda (e) (compile-argument e context))
+                       args)))]
+         [($ a60:if test then else)
+          `(if (check-boolean ,(compile-expression test context 'bool))
+	       ,(compile-expression then context type)
+	       ,(compile-expression else context type))]
+         [else (error 'compile-expression "can't compile expression ~a" expr)]))
+     
+     (define (expression-location expr)
+       (if (syntax? expr)
+           expr
+           (match expr
+             [($ a60:subscript array index) (expression-location array)]
+             [($ a60:binary type argtype op e1 e2) op]
+             [($ a60:unary type argtype op e1) op]
+             [($ a60:variable var subscripts) (expression-location var)]
+             [($ a60:app func args)
+              (expression-location func)]
+             [else #f])))
+     
+     (define (compile-argument arg context)
+       (cond
+         [(and (a60:variable? arg) 
+               (not (let ([v  (a60:variable-name arg)])
+		      (or (procedure-variable? v context)
+			  (label-variable? v context)
+			  (primitive-variable? v context)))))
+          `(case-lambda
+             [() ,(compile-expression arg context 'any)]
+             [(val)  ,(compile-statement (make-a60:assign (list arg) 'val) 'void context)])]
+         [(identifier? arg)
+          (compile-argument (make-a60:variable arg null) context)]
+         [else `(lambda () ,(compile-expression arg context 'any))]))
+
+     (define (check-type got expected expr)
+       (or (eq? expected 'any)
+	   (case got
+	     [(num) (memq expected '(num numbool))]
+	     [(bool) (memq expected '(bool numbool))]
+	     [(des) (memq expected '(des))]
+	     [(func) (memq expected '(func))]
+	     [else #f])
+	   (raise-syntax-error #f
+			       (format "type mismatch (~a != ~a)" got expected)
+			       expr)))
+     
+     (define (check-spec-type spec type expr)
+       (let ([target (spec-coerce-target spec)])
+         (when target
+           (case (syntax-e target)
+             [(integer real) (check-type 'num type expr)]
+             [(boolean) (check-type 'bool type expr)]
+             [(procedure) (check-type 'func type expr)]))))
+       
+
+     (define (check-label l context)
+       (if (or (symbol? l)
+	       (label-variable? l context))
+	   l
+	   (raise-syntax-error
+	    #f
+	    "undefined label"
+	    l)))
+     
+     (define (at stx expr)
+       (if (syntax? stx)
+           (datum->syntax-object (current-compile-context) expr stx)
+           expr))
+
+     (define (as-builtin stx)
+       ;; Preserve source loc, but change to reference to
+       ;; a builtin operation by changing the context:
+       (datum->syntax-object
+	(current-compile-context)
+	(syntax-e stx)
+	stx
+	stx))
+
+     ;; --------------------
+     
+     (define (empty-context)
+       `(((sign prim sign)
+	  (entier prim entier)
+
+	  (sin prim a60:sin)
+	  (cos prim a60:cos)
+	  (acrtan prim a60:arctan)
+	  (sqrt prim a60:sqrt)
+	  (abs prim a60:abs)
+	  (ln prim a60:ln)
+	  (exp prim a60:exp)
+
+	  (prints prim prints)
+	  (printn prim printn)
+	  (printsln prim printsln)
+	  (printnln prim printnln))))
+     
+     (define (add-labels context l)
+       (cons (map (lambda (lbl) (cons (if (symbol? lbl)
+                                          (datum->syntax-object #f lbl)
+                                          lbl)
+                                      'label)) l)
+             context))
+     
+     (define (add-procedure context var result-type arg-vars by-value-vars arg-specs)
+       (cons (list (cons var 'procedure))
+             context))
+     
+     (define (add-settable-procedure context var result-type result-var)
+       (cons (list (cons var `(settable-procedure ,result-var ,result-type)))
+             context))
+     
+     (define (add-atoms context ids type)
+       (cons (map (lambda (id) (cons id type)) ids)
+             context))
+
+     (define (add-arrays context names dimensionses type)
+       (cons (map (lambda (name dimensions)
+                    (cons name `(array ,type ,(length dimensions))))
+                  names dimensionses)
+             context))
+
+     (define (add-switch context name)
+       (cons (list (cons name 'switch))
+             context))
+     
+     (define (add-bindings context arg-vars by-value-vars arg-specs)
+       (cons (map (lambda (var)
+                    (let ([spec (or (ormap (lambda (spec)
+                                             (and (ormap (lambda (x) (bound-identifier=? var x))
+                                                         (cdr spec))
+                                                  (car spec)))
+                                           arg-specs)
+                                    #'unknown)])
+                    (cons var
+                          (if (ormap (lambda (x) (bound-identifier=? var x)) by-value-vars)
+                              spec
+                              (list 'by-name spec)))))
+                  arg-vars)
+             context))
+     
+     ;; var-binding : syntax context -> symbol
+     ;; returns an identifier indicating where the var is
+     ;; bound, or 'free if it isn't. The compiler inserts
+     ;; top-level procedure definitions into the namespace; if 
+     ;; the variable is bound there, it is a procedure.
+     (define (var-binding var context)
+       (cond
+         [(null? context)
+          (let/ec k
+            (namespace-variable-value (syntax-e var)
+                                      #t 
+                                      (lambda () (k 'free)))
+            'procedure)]
+         [else
+          (let ([m (var-in-rib var (car context))])
+            (or m (var-binding var (cdr context))))]))
+     
+     (define (var-in-rib var rib)
+       (ormap (lambda (b)
+                (if (symbol? (car b))
+                    ;; primitives:
+                    (and (eq? (syntax-e var) (car b))
+                         (cdr b))
+                    ;; everything else:
+                    (and (bound-identifier=? var (car b))
+                         (cdr b))))
+              rib))
+     
+     (define (primitive-variable? var context)
+       (let ([v (var-binding var context)])
+	 (and (pair? v)
+	      (eq? (car v) 'prim)
+	      (cadr v))))
+
+     (define (call-by-name-variable? var context)
+       (let ([v (var-binding var context)])
+         (and (pair? v)
+              (eq? (car v) 'by-name)
+              (cadr v))))
+     
+     (define (procedure-variable? var context)
+       (let ([v (var-binding var context)])
+         (eq? v 'procedure)))
+
+     (define (procedure-result-variable? var context)
+       (let ([v (var-binding var context)])
+         (and (pair? v)
+              (eq? (car v) 'settable-procedure)
+              (cdr v))))
+     
+     (define (procedure-result-variable-name var context)
+       (let ([v (procedure-result-variable? var context)])
+         (car v)))
+
+     (define (procedure-result-spec var context)
+       (let ([v (procedure-result-variable? var context)])
+         (cadr v)))
+
+     (define (label-variable? var context)
+       (let ([v (var-binding var context)])
+         (eq? v 'label)))
+         
+     (define (switch-variable? var context)
+       (let ([v (var-binding var context)])
+         (eq? v 'switch)))
+         
+     (define (settable-variable? var context)
+       (let ([v (var-binding var context)])
+         (or (box? v)
+             (and (syntax? v)
+                  (memq (syntax-e v) '(integer real boolean))
+                  v))))
+     
+     (define (own-variable? var context)
+       (let ([v (var-binding var context)])
+         (box? v)))
+
+     (define (array-element? var context)
+       (let ([v (var-binding var context)])
+         (and (pair? v)
+              (eq? (car v) 'array)
+              (or (cadr v)
+                  #'unknown))))
+     
+     (define (spec-coerce-target spec)
+       (cond
+         [(and (syntax? spec) (memq (syntax-e spec) '(string label switch real integer boolean unknown))) spec]
+         [(and (syntax? spec) (memq (syntax-e spec) '(unknown))) #f]
+         [(or (not spec) (not (pair? spec))) #f]
+         [(eq? (car spec) 'array) (cadr spec)]
+         [(eq? (car spec) 'procedure) #'procedure]
+         [else #f]))
+     
+     (define (stx-number? a) (and (syntax? a) (number? (syntax-e a)))))
diff --git a/collects/algol60/doc.txt b/collects/algol60/doc.txt
new file mode 100644
index 0000000000..0a626106b9
--- /dev/null
+++ b/collects/algol60/doc.txt
@@ -0,0 +1,61 @@
+_Algol 60_
+
+The "Algol 60" language for DrScheme implements the language define by
+the "Revised Report on the Algorithmic Language Algol 60", edited by
+Peter Naur.
+
+
+The "algol60.ss" library provides an `include-algol' form for including
+an Algol 60 program as an expression in a Scheme program:
+
+>  (include-algol file-path-string)
+
+The included Algol 60 program is closed (i.e., it doesn't see any
+bindings in the included context), and the result is always void.
+
+
+Language
+--------
+
+The DrScheme/`include-algol' implementation departs from the
+specification in the following minor ways:
+
+  * strings are not permitted to contain nested quotes;
+
+  * identifiers cannot contain whitespace;
+
+  * argument separators are constrained to be identifiers (i.e., they
+    cannot be keywords, and they cannot consistnt of multiple
+    identifiers separated by whitespace); and
+
+  * numbers containing exponents (using the "10" subscript) are not
+    supported.
+
+Identifiers and keywords are case-sensitive. The boldface/underlined
+keywords of the report are represented by the obvious character
+sequence, as are most operators. A few operators do not fit into
+ASCII, and they are mapped as follows:
+
+  times             *
+  quotient          div
+  exponential       ^
+  less or equal     <=
+  greater or equal  >=
+  not equal         !=
+  equivalence       ==
+  implication       =>
+  and               &
+  or                |
+  negation          !
+
+In addition to the standard functions, the following output functions
+are supported:
+
+  prints(E)    prints the string E
+  printsln(E)  prints the string E followed by a newline
+  printn(E)    prints the number E
+  printnln(E)  prints the number E followed by a newline
+
+A prompt in DrScheme's Interactions window accepts whole programs only
+for the Algol 60 language.
+
diff --git a/collects/algol60/examples/euler.a60 b/collects/algol60/examples/euler.a60
new file mode 100644
index 0000000000..1b819a3af9
--- /dev/null
+++ b/collects/algol60/examples/euler.a60
@@ -0,0 +1,33 @@
+begin
+
+procedure euler (fct,sum,eps,tim); value eps,tim; integer tim;
+real procedure fct; real sum,eps;
+comment euler computes the sum of fct(i) for i from zero up to
+infinity by means of a suitably refined euler transformation. The
+summation is stopped as soon as tim times in succession the absolute
+value of the terms of the transformed series are found to be less than
+eps. Hence, one should provide a function fct with one integer argument,
+an upper bound eps, and an integer tim. The output is the sum sum. euler
+is particularly efficient in the case of a slowly convergent or
+divergent alternating series;
+begin integer i,k,n,t; array m[0:15]; real mn,mp,ds;
+i:=n:=t:=0; m[0]:=fct(0); sum:=m[0]/2;
+nextterm: i:=i+1; mn:=fct(i);
+        for k:=0 step 1 until n do
+            begin mp:=(mn+m[k])/2; m[k]:=mn;
+                mn:=mp end;
+        if (abs(mn)<abs(m[n])) & (n<15) then
+            begin ds:=mn/2; n:=n+1; m[n]:=mn end
+        else ds:=mn;
+        sum:=sum+ds;
+        if abs(ds)<eps then t:=t+1 else t:=0;
+        if t<tim then goto nextterm
+end;
+
+procedure inv(v) ; inv := 1.0/((v+1)^2);
+
+real result;
+euler(inv, result, 0.00005, 10);
+printnln(result);
+
+end
diff --git a/collects/algol60/examples/jensen.a60 b/collects/algol60/examples/jensen.a60
new file mode 100644
index 0000000000..9e56b72abe
--- /dev/null
+++ b/collects/algol60/examples/jensen.a60
@@ -0,0 +1,14 @@
+begin
+  integer procedure SIGMA(x, i, n);
+    value n;
+    integer x, i, n;
+  begin
+    integer sum;
+    sum:=0;
+    for i:=1 step 1 until n do
+        sum:=sum+x;
+    SIGMA:=sum;
+  end;
+  integer q;
+  printnln(SIGMA(q*2-1, q, 7));
+end
diff --git a/collects/algol60/examples/nqueen.a60 b/collects/algol60/examples/nqueen.a60
new file mode 100644
index 0000000000..493bc589e2
--- /dev/null
+++ b/collects/algol60/examples/nqueen.a60
@@ -0,0 +1,124 @@
+begin
+        comment
+          -- From the NASE A60 distribution --
+                Find a solution for the `N queen problem.
+                (got the algorithm from a Modula program from
+                 Martin Neitzel).
+        ;
+
+        integer N, MAXN;
+
+        MAXN := 9;              comment maximum size;
+        N := 2;                 comment current size;
+
+tryNextN:
+
+        begin
+
+        integer array column [1 : N];
+        Boolean array empcol [1 : N];
+        Boolean array empup [-N+1 : N-1];
+        Boolean array empdo [2 : 2*N];
+        integer i;
+
+        procedure print;
+        comment
+                print the current solution in a chessboard alike
+                picture ;
+        begin
+                integer i, j;
+
+                procedure outframe;
+                begin
+                        integer i;
+
+                        for i := 1 step 1 until N do
+                                prints (`+---');
+                        printsln (`+')
+                end;
+
+                for j := 1 step 1 until N do begin
+                        outframe;
+                        prints (`|');
+                        for i := 1 step 1 until N do begin
+                                if N + 1 - j = column [i] then
+                                        prints (` Q |')
+                                else
+                                        prints (`   |')
+                        end;
+                        printsln (`')
+                end;
+                outframe;
+        end;
+
+
+        procedure set (x);
+        value x;
+        integer x;
+        begin
+                integer y;
+        
+                for y := 1 step 1 until N do
+                begin
+                        if empcol [ y ] & empup [ x-y ] 
+                                        & empdo [ x+y ] then
+                        begin
+                                column [ y ] := x ;
+                                empcol [ y ] := false ;
+                                empup [ x-y ] := false ;
+                                empdo [ x+y ] := false ;
+                                if x = N then
+                                        goto gotone
+                                else
+                                        set ( x + 1 ) ;
+                                empdo [ x+y ] := true ;
+                                empup [ x-y ] := true ;
+                                empcol [ y ] := true ;
+                                column [ y ] := 0
+                        end
+                end
+        end;
+
+        comment
+                main program start
+        ;
+
+        prints (`looking onto a ');
+        printn (N);
+        prints (` x ');
+        printn (N);
+        printsln (` chessboard...');
+
+        for i := 1 step 1 until N do
+        begin
+                 column [ i ] := 0 ;
+                 empcol [ i ] := true
+        end;
+
+        for i := -N+1 step 1 until N-1 do
+                 empup [ i ] := true ;
+
+        for  i := 2 step 1 until 2*N do
+                 empdo [ i ] := true ;
+
+        set ( 1 ) ;
+
+        printsln (`NO SOLUTION.');
+        goto contN;
+
+gotone:
+        printsln(`SOLVED');
+        print;
+
+contN:
+        if N < MAXN then begin
+                N := N + 1;
+                goto tryNextN
+        end;
+
+        printsln (`done.')
+
+        end
+end
+
+
diff --git a/collects/algol60/examples/primes.a60 b/collects/algol60/examples/primes.a60
new file mode 100644
index 0000000000..80af372177
--- /dev/null
+++ b/collects/algol60/examples/primes.a60
@@ -0,0 +1,67 @@
+begin
+        comment
+          -- From the NASE A60 distribution --
+                calculation of the prime numbers between 2 and 200
+        ;
+
+        integer NN;
+
+        NN := 200;
+
+        begin
+                comment first algorithm (check division in a loop) ;
+
+                Boolean procedure isprime (n);
+                value n;
+                integer n;
+                begin
+                        Boolean procedure even (n);
+                        value n; integer n;
+                                even := entier (n / 2) * 2 = n;
+                        integer i;
+
+                        isprime := false;
+                        if even (n) & n != 2 then
+                                goto ret;
+
+                        for i := 3 step 2 until n div 2 do
+                                if entier (n / i) * i = n then
+                                        goto ret;
+                        isprime := true;
+                    ret:
+
+                end;
+
+                integer i;
+
+                printsln (`first:');
+
+                for i := 2 step 1 until NN do
+                        if isprime (i) then
+                                printnln (i);
+                printsln (`done.')
+        end;
+
+        begin
+                comment second algorithm (sieve) ;
+
+
+                Boolean array arr [2 : NN];
+                integer i, j;
+
+                printsln (`second:');
+
+                for i := 2 step 1 until NN do
+                        arr [i] := true;
+
+                for i := 2 step 1 until NN div 2 do
+                        for j := 2 * i step i until NN do
+                                arr [j] := false;
+                
+                for i := 2 step 1 until NN do
+                        if arr [i] then
+                                printnln (i);
+                printsln (`done.')
+
+        end
+end             
diff --git a/collects/algol60/get-base.ss b/collects/algol60/get-base.ss
new file mode 100644
index 0000000000..cb462f60f4
--- /dev/null
+++ b/collects/algol60/get-base.ss
@@ -0,0 +1,3 @@
+(module get-base (lib "base.ss" "algol60")
+  (provide base-importing-stx)
+  (define base-importing-stx #'here))
diff --git a/collects/algol60/info.ss b/collects/algol60/info.ss
new file mode 100644
index 0000000000..5040dca0eb
--- /dev/null
+++ b/collects/algol60/info.ss
@@ -0,0 +1,4 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Algol 60")
+  (define doc.txt "doc.txt")
+  (define tools (list (list "tool.ss"))))
diff --git a/collects/algol60/parse.ss b/collects/algol60/parse.ss
new file mode 100644
index 0000000000..cde3cea777
--- /dev/null
+++ b/collects/algol60/parse.ss
@@ -0,0 +1,413 @@
+#cs(module parse mzscheme
+     (require (lib "lex.ss" "parser-tools")
+              (prefix : (lib "lex-sre.ss" "parser-tools"))
+              (lib "yacc.ss" "parser-tools")
+              (lib "readerr.ss" "syntax")
+              "prims.ss")
+     
+     (define-lex-abbrevs [lex:letter (:or (:/ #\a #\z) (:/ #\A #\Z))]
+                         [lex:digit (:/ #\0 #\9)]
+                         [lex:whitespace (:or #\newline #\return #\tab #\space #\vtab)]
+                         [lex:comment (:: (:* lex:whitespace) "comment" (:* (:~ #\;)) #\;)])
+     
+     (define-tokens non-terminals (<logical-value> 
+                                   <type> <identifier> 
+                                   <unsigned-integer> <unsigned-float> <string>
+                                   
+                                   GOTO IF THEN ELSE FOR DO STEP UNTIL WHILE
+                                   OWN ARRAY STRING PROCEDURE SWITCH LABEL VALUE
+                                   BEGIN END
+                                   POWER PLUS MINUS TIMES SLASH DIVIDE
+                                   LESS LESS-OR-EQUAL EQUAL GREATER-OR-EQUAL GREATER NOT-EQUAL ASSIGN
+                                   NEGATE AND OR IMPLIES EQUIV
+                                   COMMA COLON SEMICOLON
+                                   OPEN CLOSE OPENSQ CLOSESQ
+                                   EOF
+                                   UNPARSEABLE))
+     
+     (define stx-for-original-property (read-syntax #f (open-input-string "original")))
+     
+     (define-syntax (token stx)
+       (syntax-case stx ()
+         [(_ name val)
+          (identifier? (syntax name))
+          (let ([name (syntax name)])
+            (with-syntax ([token-name (datum->syntax-object
+                                       name
+                                       (string->symbol
+                                        (format "token-~a" (syntax-e name))))]
+                          [source-name (datum->syntax-object name 'source-name)]
+                          [start-pos (datum->syntax-object name 'start-pos)]
+                          [end-pos (datum->syntax-object name 'end-pos)])
+              (syntax 
+	       (token-name 
+		(datum->syntax-object #f val
+				      (list
+				       source-name
+				       (position-line start-pos)
+				       (position-col start-pos)
+				       (position-offset start-pos)
+				       (- (position-offset end-pos)
+					  (position-offset start-pos)))
+				      stx-for-original-property)))))]))
+     (define-syntax (ttoken stx)
+       (syntax-case stx ()
+         [(_ name)
+          (identifier? (syntax name))
+          (syntax (token name 'name))]))
+     
+     (define (lex source-name)
+       (lexer
+        [(:+ lex:whitespace) (void)]
+        ["true" (token <logical-value> #t)]
+        ["false" (token <logical-value> #f)]
+        ["real" (token <type> 'real)]
+        ["integer" (token <type> 'integer)]
+        ["Boolean" (token <type> 'boolean)]
+        ["goto" (ttoken GOTO)]
+        ["if" (ttoken IF)]
+        ["then" (ttoken THEN)]
+        ["else" (ttoken ELSE)]
+        ["for" (ttoken FOR)]
+        ["do" (ttoken DO)]
+        ["step" (ttoken STEP)]
+        ["until" (ttoken UNTIL)]
+        ["while" (ttoken WHILE)]
+        ["own" (ttoken OWN)]
+        ["array" (ttoken ARRAY)]
+        ["string" (ttoken STRING)]
+        ["procedure" (ttoken PROCEDURE)]
+        ["switch" (ttoken SWITCH)]
+        ["label" (ttoken LABEL)]
+        ["value" (ttoken VALUE)]
+        [(:: "begin" lex:comment) (ttoken BEGIN)]
+        ["begin" (ttoken BEGIN)]
+        [(:: "end" lex:comment) (ttoken BEGIN)]
+        ["end" (ttoken END)]
+        ["^" (token POWER 'expt)]
+        ["+" (token PLUS '+)]
+        ["-" (token MINUS '-)]
+        ["*" (token TIMES '*)]
+        ["/" (token SLASH '/)]
+        ["div" (token DIVIDE 'quotient)]
+        ["<" (token LESS '<)]
+        ["<=" (token LESS-OR-EQUAL '<=)]
+        ["=" (token EQUAL '=)]
+        [">" (token GREATER '>)]
+        [">=" (token GREATER-OR-EQUAL '>=)]
+        ["!=" (token NOT-EQUAL '!=)]
+        ["!" (token NEGATE '!)]
+        ["&" (token AND '&)]
+        ["|" (token OR '\|)]
+        ["=>" (token IMPLIES '=>)]
+        ["==" (token EQUIV '==)]
+        [":=" (ttoken ASSIGN)]
+        ["," (ttoken COMMA)]
+        [":" (ttoken COLON)]
+        [(:: ";" lex:comment) (ttoken SEMICOLON)]
+        [";" (ttoken SEMICOLON)]
+        ["(" (ttoken OPEN)]
+        [")" (ttoken CLOSE)]
+        ["[" (ttoken OPENSQ)]
+        ["]" (ttoken CLOSESQ)]
+        [(:: lex:letter (:* (:or lex:letter lex:digit))) (token <identifier> (string->symbol lexeme))]
+        [(:+ lex:digit) (token <unsigned-integer> (string->number lexeme))]
+        [(:or (:: (:+ lex:digit) #\. (:* lex:digit))
+              (:: (:* lex:digit) #\. (:+ lex:digit))) (token <unsigned-float> (string->number lexeme))]
+        [(:: #\` (:* (:~ #\' #\`)) #\') (let ([s lexeme])
+                                          (token <string> (substring s 1 (sub1 (string-length s)))))]
+        [(eof) (ttoken EOF)]
+        [any-char (token UNPARSEABLE (string->symbol lexeme))]))
+     
+     (define parse
+       (parser
+        (tokens non-terminals)
+        (start <program>)
+        (end EOF)
+        (error (lambda (a b stx) 
+		 (raise-read-error (format "parse error near ~a" (syntax-e stx))
+				   (syntax-source stx)
+				   (syntax-line stx)
+				   (syntax-column stx)
+				   (syntax-position stx)
+				   (syntax-span stx))))
+        (suppress)
+        (grammar 
+         ;; ==================== Expressions ====================
+         (<expression> [(<arithmetic-expression>) $1]
+                       [(<Boolean-expression>) $1]
+                       [(<designational-expression>) $1])
+         ;; -------------------- Numbers --------------------
+         (<arithmetic-expression> [(<simple-arithmetic-expression>) $1]
+                                  [(IF <Boolean-expression> 
+                                       THEN <simple-arithmetic-expression> 
+                                       ELSE <arithmetic-expression>)
+                                   (make-a60:if $2 $4 $6)])
+         (<simple-arithmetic-expression> [(<term>) $1]
+                                         [(<adding-operator> <term>) (make-a60:unary 'num 'num $1 $2)]
+                                         [(<simple-arithmetic-expression> <adding-operator> <term>) 
+                                          (make-a60:binary 'num 'num $2 $1 $3)])
+         (<term> [(<factor>) $1]
+                 [(<term> <multiplying-operator> <factor>) (make-a60:binary 'num 'num $2 $1 $3)])
+         (<factor> [(<primary>) $1]
+                   [(<factor> POWER <primary>) (make-a60:binary 'num 'num $2 $1 $3)])
+         (<adding-operator> [(PLUS) $1]
+                            [(MINUS) $1])
+         (<multiplying-operator> [(TIMES) $1]
+                                 [(SLASH) $1]
+                                 [(DIVIDE) $1])
+         (<primary> [(<unsigned-integer>) $1]
+                    [(<unsigned-float>) $1]
+                    [(<variable>) $1]
+                    [(<function-designator>) $1]
+                    [(OPEN <arithmetic-expression> CLOSE) $2])
+         ;; -------------------- Booleans --------------------
+         (<relational-operator> [(LESS) $1]
+                                [(LESS-OR-EQUAL) $1]
+                                [(EQUAL) $1]
+                                [(GREATER-OR-EQUAL) $1]
+                                [(GREATER) $1]
+                                [(NOT-EQUAL) $1])
+         (<relation> [(<simple-arithmetic-expression> <relational-operator> <simple-arithmetic-expression>)
+                      (make-a60:binary 'bool 'num $2 $1 $3)])
+         (<Boolean-primary> [(<logical-value>) $1]
+                            [(<variable>) $1]
+                            [(<function-designator>) $1]
+                            [(<relation>) $1]
+                            [(OPEN <Boolean-expression> CLOSE) $2])
+         (<Boolean-secondary> [(<Boolean-primary>) $1]
+                              [(NEGATE <Boolean-primary>) (make-a60:unary 'bool 'bool $1 $2)])
+         (<Boolean-factor> [(<Boolean-secondary>) $1]
+                           [(<Boolean-factor> AND <Boolean-secondary>) (make-a60:binary 'bool 'bool $2 $1 $3)])
+         (<Boolean-term> [(<Boolean-factor>) $1]
+                         [(<Boolean-term> OR <Boolean-factor>)  (make-a60:binary 'bool 'bool $2 $1 $3)])
+         
+         (<implication> [(<Boolean-term>) $1]
+                        [(<implication> IMPLIES <Boolean-term>) (make-a60:binary 'bool 'bool $2 $1 $3)])
+         (<simple-Boolean> [(<implication>) $1]
+                           [(<simple-Boolean> EQUIV <implication>) (make-a60:binary 'bool 'bool $2 $1 $3)])
+         (<Boolean-expression> [(<simple-Boolean>) $1]
+                               [(IF <Boolean-expression> 
+                                    THEN <simple-Boolean> 
+                                    ELSE <Boolean-expression>)
+                                (make-a60:if $2 $4 $6)])
+         ;; -------------------- Designationals --------------------
+         (<label> [(<identifier>) $1]
+                  [(<unsigned-integer>) $1])
+         (<switch-identifier> [(<identifier>) $1])
+         (<switch-designator> [(<switch-identifier> OPENSQ <arithmetic-expression> CLOSESQ)
+                               (make-a60:subscript $1 $3)])
+         (<simple-designational-expression> [(<label>) $1]
+                                            [(<switch-designator>) $1]
+                                            [(OPEN <designational-expression> CLOSE) $2])
+         (<designational-expression> [(<simple-designational-expression>) $1]
+                                     [(IF <Boolean-expression> 
+                                          THEN <simple-designational-expression> 
+                                          ELSE <designational-expression>)
+                                      (make-a60:if $2 $4 $6)])
+         ;; -------------------- Variables --------------------
+         (<subscript-list> [(<arithmetic-expression>) (list $1)]
+                           [(<subscript-list> COMMA <arithmetic-expression>) (append $1 (list $3))])
+         (<subscripted-variable> [(<identifier> OPENSQ <subscript-list> CLOSESQ) (make-a60:variable $1 $3)])
+         (<variable> [(<identifier>) (make-a60:variable $1 null)]
+                     [(<subscripted-variable>) $1])
+         ;; -------------------- Function calls --------------------
+         (<function-designator> [(<identifier> <actual-parameter-part>) (make-a60:app $1 $2)])
+         ;; ==================== Statements ====================
+         ;;  - - - - - - - - - - non-empty - - - - - - - - - - 
+         (<unlabelled-basic-nonempty-statement> [(<assignment-statement>) $1]
+                                                [(<go-to-statement>) $1]
+                                                [(<procedure-statement>) $1])
+         (<basic-nonempty-statement> [(<unlabelled-basic-nonempty-statement>) $1]
+                                     [(<label> COLON <basic-statement>) (make-a60:label $1 $3)])
+         (<unconditional-nonempty-statement> [(<basic-nonempty-statement>) $1]
+                                             [(<compound-statement>) $1]
+                                             [(<block>) $1])
+         (<nonempty-statement> [(<unconditional-nonempty-statement>) $1]
+                               [(<conditional-statement>) $1]
+                               [(<for-statement>) $1])
+         ;;  - - - - - - - - - - possibly empty - - - - - - - - - -          
+         (<unlabelled-basic-statement> [(<unlabelled-basic-nonempty-statement>) $1]
+                                       [(<dummy-statement>) $1])
+         (<basic-statement> [(<unlabelled-basic-statement>) $1]
+                            [(<label> COLON <basic-statement>) (make-a60:label $1 $3)])
+         (<unconditional-statement> [(<basic-statement>) $1]
+                                    [(<unconditional-nonempty-statement>) $1])
+         (<statement> [(<unconditional-statement>) $1]
+                      [(<nonempty-statement>) $1])
+         ;; -------------------- block and compound --------------------
+         (<compound-tail> [(<statement> END) (list $1)]
+                          [(<statement> SEMICOLON <compound-tail>) (cons $1 $3)])
+         (<block-head> [(BEGIN <declaration>) (list $2)]
+                       [(<block-head> SEMICOLON <declaration>) (append $1 (list $3))])
+         (<unlabelled-block> [(<block-head> SEMICOLON <compound-tail>) (make-a60:block $1 $3)])
+         (<unlabelled-compound> [(BEGIN <compound-tail>) (make-a60:compound $2)])
+         
+         (<compound-statement> [(<unlabelled-compound>) $1]
+                               [(<label> COLON <compound-statement>) (make-a60:label $1 $3)])
+         (<block> [(<unlabelled-block>) $1]
+                  [(<label> COLON <block>) (make-a60:label $1 $3)])
+         ;; -------------------- assignment --------------------
+         (<left-part> [(<variable> ASSIGN) $1])
+         (<left-part-list> [(<left-part>) (list $1)]
+                           [(<left-part-list> <left-part>) (append $1 (list $2))])
+         (<assignment-statement> [(<left-part-list> <arithmetic-expression>) (make-a60:assign $1 $2)]
+                                 [(<left-part-list> <Boolean-expression>) (make-a60:assign $1 $2)])
+         ;; -------------------- goto --------------------
+         (<go-to-statement> [(GOTO <designational-expression>) (make-a60:goto $2)])
+         ;; -------------------- dummy --------------------
+         (<dummy-statement> [() (make-a60:compound null)])
+         ;; -------------------- conditional --------------------
+         (<conditional-statement> [(IF <Boolean-expression> THEN <unconditional-statement>)
+                                   (make-a60:branch $2 $4 (make-a60:compound null))]
+                                  [(IF <Boolean-expression> THEN <unconditional-statement> ELSE <statement>)
+                                   (make-a60:branch $2 $4 $6)]
+                                  [(IF <Boolean-expression> THEN <for-statement>)
+                                   (make-a60:branch $2 $4 (make-a60:compound null))]
+                                  [(<label> COLON <conditional-statement>) (make-a60:label $1 $3)])
+         ;; -------------------- for --------------------
+         (<for-list-element> [(<arithmetic-expression>) (make-a60:for-number $1)]
+                             [(<arithmetic-expression> STEP <arithmetic-expression> UNTIL <arithmetic-expression>)
+                              (make-a60:for-step $1 $3 $5)]
+                             [(<arithmetic-expression> WHILE <Boolean-expression>) (make-a60:for-while $1 $3)])
+         (<for-list> [(<for-list-element>) (list $1)]
+                     [(<for-list> COMMA <for-list-element>) (append $1 (list $3))])
+         (<for-statement> [(FOR <variable> ASSIGN <for-list> DO <statement>)
+                           (make-a60:for $2 $4 $6)]
+                          [(<label> COLON <for-statement>) (make-a60:label $1 $3)])
+         ;; -------------------- procedure statement --------------------
+         (<actual-parameter> [(<string>) $1]
+                             [(<expression>) $1]
+                             ; [(<identifier>) $1] ; switch, array, or procedure
+                             )
+         (<parameter-delimiter> [(COMMA) (void)]
+                                [(CLOSE <identifier> COLON OPEN) (void)]) ;; <identifier> was <letter-string>!
+         (<actual-parameter-list> [(<actual-parameter>) (list $1)]
+                                  [(<actual-parameter-list> <parameter-delimiter> <actual-parameter>)
+                                   (append $1 (list $3))])
+         (<actual-parameter-part> [() null]
+                                  [(OPEN <actual-parameter-list> CLOSE) $2])
+         (<procedure-statement> [(<identifier> <actual-parameter-part>) (make-a60:call $1 $2)])
+         ;; ==================== Declarations ====================
+         (<declaration> [(<type-declaration>) $1]
+                        [(<array-declaration>) $1]
+                        [(<switch-declaration>) $1]
+                        [(<procedure-declaration>) $1])
+         ;; -------------------- Simple --------------------
+         (<type-list> [(<identifier>) (list $1)]
+                      [(<identifier> COMMA <type-list>) (cons $1 $3)])
+         (<local-or-own-type> [(<type>) $1]
+                              [(OWN <type>) (box $2)]) ; box => own
+         (<type-declaration> [(<local-or-own-type> <type-list>) (make-a60:type-decl $1 $2)])
+         ;; -------------------- Arrays --------------------
+         (<bound-pair> [(<arithmetic-expression> COLON <arithmetic-expression>) (cons $1 $3)])
+         (<bound-pair-list> [(<bound-pair>) (list $1)]
+                            [(<bound-pair-list> COMMA <bound-pair>) (append $1 (list $3))])
+         (<array-segment> [(<identifier> OPENSQ <bound-pair-list> CLOSESQ) (list (cons $1 $3))]
+                          [(<identifier> COMMA <array-segment>) (cons (cons $1 (cdar $3)) $3)])
+         (<array-list> [(<array-segment>) $1]
+                       [(<array-list> COMMA <array-segment>) (append $1 $3)])
+         (<array-declaration> [(ARRAY <array-list>) (make-a60:array-decl #'unknown $2)]
+                              [(<local-or-own-type> ARRAY <array-list>) (make-a60:array-decl $1 $3)])
+         ;; -------------------- Switches --------------------
+         (<switch-list> [(<designational-expression>) (list $1)]
+                        [(<switch-list> COMMA <designational-expression>) (append $1 (list $3))])
+         (<switch-declaration> [(SWITCH <switch-identifier> ASSIGN <switch-list>) (make-a60:switch-decl $2 $4)])
+         ;; -------------------- Procedures --------------------
+         (<formal-parameter> [(<identifier>) $1])
+         (<formal-parameter-list> [(<formal-parameter>) (list $1)]
+                                  [(<formal-parameter-list> <parameter-delimiter> <formal-parameter>) 
+                                   (append $1 (list $3))])
+         (<formal-parameter-part> [() null]
+                                  [(OPEN <formal-parameter-list> CLOSE) $2])
+         (<identifier-list> [(<identifier>) (list $1)]
+                            [(<identifier-list> COMMA <identifier>) (append $1 (list $3))])
+         (<value-part> [(VALUE <identifier-list> SEMICOLON) $2]
+                       [() null])
+         (<specifier> [(STRING) 'string]
+                      [(<type>) $1]
+                      [(ARRAY) '(array #'unknown)]
+                      [(<type> ARRAY) `(array ,$1)]
+                      [(LABEL) 'label]
+                      [(SWITCH) 'switch]
+                      [(PROCEDURE) '(procedure #'unknown)]
+                      [(<type> PROCEDURE) `(procedure ,$1)])
+         (<nonempty-specification-part> [(<specifier> <identifier-list> SEMICOLON) (list (cons $1 $2))]
+                                        [(<nonempty-specification-part> <specifier> <identifier-list> SEMICOLON)
+                                         (append $1 (list (cons $2 $3)))])
+         (<specification-part> [() null]
+                               [(<nonempty-specification-part>) $1])
+         (<procedure-heading> [(<identifier> <formal-parameter-part> SEMICOLON <value-part> <specification-part>)
+                               (list $1 $2 $4 $5)])
+         (<procedure-body> [(<nonempty-statement>) $1])
+         (<procedure-declaration> [(PROCEDURE <procedure-heading> <procedure-body>)
+                                   (make-a60:proc-decl #'unknown (car $2) (cadr $2) (caddr $2) (cadddr $2) $3)]
+                                  [(<type> PROCEDURE <procedure-heading> <procedure-body>)
+                                   (make-a60:proc-decl $1 (car $3) (cadr $3) (caddr $3) (cadddr $3) $4)])
+         ;; ==================== Program ====================
+         (<program> [(<block>) $1]
+                    [(<compound-statement>) $1]))))
+     
+     (define-syntax (define-a60-structs stx)
+       (syntax-case stx ()
+         [(_ (struct-name (field ...)) ...)
+          (with-syntax ([(a60:struct ...) (map (lambda (id)
+						 (datum->syntax-object
+						  id
+						  (string->symbol
+						   (format "a60:~a" (syntax-e id)))))
+                                               (syntax->list (syntax (struct-name ...))))])
+            (syntax (begin (define-struct a60:struct (field ...)) ...
+                           (provide (struct a60:struct (field ...)) ...))))]))
+     
+     (define-a60-structs
+      ;; Expressions
+      (if (test then else))
+      (unary (type argtype op arg))
+      (binary (type argtype op arg1 arg2))
+      (subscript (array index))
+      (variable (name indices))
+      (app (func args))
+      ;; plus numbers, strings, and booleans
+
+      ;; Statements
+      (block (decls statements))
+      (compound (statements))
+      (assign (variables rhs))
+      (goto (target))
+      (branch (test then else))
+      (call (proc args))
+      (for (variable values body))
+      (dummy ())
+      (label (name statement))
+      
+      ;; for values
+      (for-number (value))
+      (for-step (start step end))
+      (for-while (value test))
+
+      ;; declarations
+      (type-decl (type vars))
+      (array-decl (type vars))
+      (switch-decl (var cases))
+      (proc-decl (result-type var arg-vars by-value-vars arg-specs body)))
+     
+     (define (parse-a60-port port file)
+       (let ([lexer (lex file)])
+	 (port-count-lines! port)
+         (parse
+          (lambda () 
+            (let loop ()
+              (let ([v (lexer port)])
+                (if (void? v)
+                    (loop)
+                    v)))))))
+     
+     (define (parse-a60-file file)
+       (with-input-from-file file
+         (lambda ()
+           (parse-a60-port (current-input-port)
+                           (path->complete-path file)))))
+
+      (provide parse-a60-file parse-a60-port))
+   
\ No newline at end of file
diff --git a/collects/algol60/prims.ss b/collects/algol60/prims.ss
new file mode 100644
index 0000000000..aaa15ba6e6
--- /dev/null
+++ b/collects/algol60/prims.ss
@@ -0,0 +1,106 @@
+(module prims mzscheme
+  (provide != ! & \|
+           => ==
+           sign entier
+
+	   a60:sin
+           a60:cos
+           a60:arctan
+           a60:sqrt
+           a60:abs
+           a60:ln
+           a60:exp
+
+           prints printn
+           printsln printnln)
+  
+  (define (!= a b)
+    (not (= a b)))
+  
+  (define (! a)
+    (unless (boolean? a)
+      (raise-type-error '! "boolean" a))
+    (not a))
+  
+  (define (& a b)
+    (unless (boolean? a)
+      (raise-type-error '& "boolean" 0 a b))
+    (unless (boolean? b)
+      (raise-type-error '& "boolean" 1 a b))
+    (and a b))
+  
+  (define (\| a b)
+    (unless (boolean? a)
+      (raise-type-error '\| "boolean" 0 a b))
+    (unless (boolean? b)
+      (raise-type-error '\| "boolean" 1 a b))
+    (or a b))
+  
+  (define (=> a b)
+    (unless (boolean? a)
+      (raise-type-error '=> "boolean" 0 a b))
+    (unless (boolean? b)
+      (raise-type-error '=> "boolean" 1 a b))
+    (or (not a) b))
+  
+  (define (== a b)
+    (unless (boolean? a)
+      (raise-type-error '== "boolean" 0 a b))
+    (unless (boolean? b)
+      (raise-type-error '== "boolean" 1 a b))
+    (eq? a b))
+  
+  (define (get-number who v)
+    (let ([v (v)])
+      (unless (number? v)
+	(raise-type-error who "number" v))
+      v))
+
+  (define (get-string who v)
+    (let ([v (v)])
+      (unless (string? v)
+	(raise-type-error who "string" v))
+      v))
+
+  (define (sign k v)
+    (k (let ([v (get-number 'sign v)])
+         (cond
+           [(< v 0) -1]
+           [(> v 0) 1]
+           [else 0]))))
+  
+  (define (entier k v)
+    (k (inexact->exact (floor (get-number 'entier v)))))
+
+  (define (a60:abs k v)
+    (k (abs (get-number 'abs v))))
+  
+  (define (a60:sqrt k v)
+    (k (sqrt (get-number 'sqrt v))))
+  
+  (define (a60:sin k v)
+    (k (sin (get-number 'sin v))))
+  
+  (define (a60:cos k v)
+    (k (cos (get-number 'cos v))))
+  
+  (define (a60:exp k v)
+    (k (exp (get-number 'exp v))))
+  
+  (define (a60:arctan k v)
+    (k (atan (get-number 'arctan v))))
+  
+  (define (a60:ln k v)
+    (k (log (get-number 'ln v))))
+  
+  (define (printsln k v)
+    (k (printf "~a~n" (get-string 'printsln v))))
+  
+  (define (printnln k v)
+    (k (printf "~a~n" (get-number 'printnln v))))
+  
+  (define (prints k v)
+    (k (printf "~a" (get-string 'prints v))))
+  
+  (define (printn k v)
+    (k (printf "~a" (get-number 'printn v)))))
diff --git a/collects/algol60/runtime.ss b/collects/algol60/runtime.ss
new file mode 100644
index 0000000000..ab813a810a
--- /dev/null
+++ b/collects/algol60/runtime.ss
@@ -0,0 +1,108 @@
+(module runtime mzscheme
+  
+  (provide (struct a60:array (vec dimens))
+           (struct a60:switch (choices))
+           undefined
+           check-boolean
+           goto
+           get-value
+           set-target!
+           make-array
+           array-ref
+           array-set!
+           make-switch
+           switch-ref
+           coerce)
+           
+  (define-struct a60:array (vec dimens))
+  (define-struct a60:switch (choices))
+  
+  (define undefined (letrec ([x x]) x))
+  (define (check-boolean b) b)
+  (define (goto f) (f))
+  (define (get-value v) (v))
+  (define (set-target! t name v)
+    (unless (procedure-arity-includes? t 1)
+      (error 'assignment "formal-argument variable ~a is assigned, but actual argument was not assignable"
+             name))
+    (t v))
+  
+  (define (bad what v)
+    (error '|bad value| "expected a ~a, got ~e" what v))
+  (define (coerce type v)
+    (cond
+      [(eq? type 'integer) 
+       (if (number? v)
+           (inexact->exact (floor v))
+           (bad 'number v))]
+      [(eq? type 'real) 
+       (if (number? v)
+           (exact->inexact v)
+           (bad 'number v))]
+      [(eq? type 'boolean) 
+       (if (boolean? v)
+           v
+           (bad 'boolean v))]
+      [else v]))
+  
+  (define (make-array . dimens)
+    (make-a60:array
+     ((let loop ([dimens dimens])
+        (if (null? dimens)
+            (lambda () undefined)
+            (let ([start (car dimens)]
+                  [end (cadr dimens)])
+              (let ([build (loop (cddr dimens))])
+                (lambda () 
+                  (let ([len (add1 (- end start))])
+                    (let ([v (make-vector len)])
+                      (let loop ([len len])
+                        (unless (zero? len)
+                          (vector-set! v (sub1 len) (build))
+                          (loop (sub1 len))))
+                      v))))))))
+     dimens))
+
+  (define (check-array a is who)
+    (unless (a60:array? a)
+      (error who "not an array: ~e" a))
+    (unless (= (length is) (/ (length (a60:array-dimens a)) 2))
+      (error who "array dimension ~a doesn't match the number of provided indices ~a"
+             (length is) (/ (length (a60:array-dimens a)) 2))))
+  
+  (define (check-index who dimens indices)
+    (unless (and (number? (car indices))
+                 (exact? (car indices))
+                 (integer? (car indices)))
+      (error who "index is not an integer: ~e"
+             (car indices)))
+    (unless (<= (car dimens) (car indices) (cadr dimens))
+      (error who "index ~a out of range ~a:~a"
+             (car indices) (car dimens) (cadr dimens))))
+  
+  (define (array-ref a . indices)
+    (check-array a indices 'array-reference)
+    (let loop ([v (a60:array-vec a)][indices indices][dimens (a60:array-dimens a)])
+      (check-index 'array-reference dimens indices)
+      (let ([i (vector-ref v (- (car indices) (car dimens)))])
+        (if (null? (cdr indices))
+            i
+            (loop i (cdr indices) (cddr dimens))))))
+  
+  (define (array-set! a val . indices)
+    (check-array a indices 'array-assignment)
+    (let loop ([v (a60:array-vec a)][indices indices][dimens (a60:array-dimens a)])
+      (check-index 'array-assignment dimens indices)
+      (if (null? (cdr indices))
+          (vector-set! v (- (car indices) (car dimens)) val)
+          (loop (vector-ref v (- (car indices) (car dimens))) (cdr indices) (cddr dimens)))))
+  
+  (define (make-switch . choices)
+    (make-a60:switch (list->vector choices)))
+  (define (switch-ref sw index)
+    (unless (and (number? index)
+                 (integer? index)
+                 (exact? index)
+                 (<= 1 index (vector-length (a60:switch-choices sw))))
+      (error "bad switch index: " index))
+    ((vector-ref (a60:switch-choices sw) (sub1 index)))))
diff --git a/collects/algol60/simplify.ss b/collects/algol60/simplify.ss
new file mode 100644
index 0000000000..0b782aaf55
--- /dev/null
+++ b/collects/algol60/simplify.ss
@@ -0,0 +1,170 @@
+#cs(module simplify mzscheme
+     (require "parse.ss"
+              "prims.ss"
+              (lib "match.ss"))
+     
+     (provide simplify)
+      
+     ;; flatten/label-block : list-of-decl list-of-stmt -> block-stmt
+     ;; Desugars `for', converts `if' so that it's always of the form
+     ;; `if <test> then goto <label> else goto <label>', flattens
+     ;; compound statements into the enclosing block, and gives every
+     ;; statement exactly one label. The result usually has lots of
+     ;; "dummy" statements that could easily be eliminated by merging
+     ;; labels.
+     (define (flatten/label-block decls statements ->stx)
+       (define extra-decls null)
+       (define new-statements
+         (let loop ([l statements])
+           (if (null? l)
+               null
+               (match (car l)
+                 [($ a60:block decls statements)
+                  (cons (cons (gensym 'block) (flatten/label-block decls statements ->stx))
+                        (loop (cdr l)))]
+                 [($ a60:compound statements)
+                  (loop (append statements (cdr l)))]
+                 [($ a60:branch test then else)
+                  (if (and (a60:goto? then) (a60:goto? else))
+                      (cons (cons (gensym 'branch) (car l))
+                            (loop (cdr l)))
+                      (let ([then-label (gensym 'then)]
+                            [else-label (gensym 'else)]
+                            [cont-label (gensym 'if-cont)])
+                        (loop
+                         (list*
+                          (make-a60:branch test (make-a60:goto then-label) (make-a60:goto else-label))
+                          (make-a60:label then-label then)
+                          (make-a60:goto cont-label)
+                          (make-a60:label else-label else)
+                          (make-a60:label cont-label (make-a60:dummy))
+                          (cdr l)))))]
+                 [($ a60:for variable val-exprs body)
+                  (let ([body-label (gensym 'for-body)]
+                        [cont-label (gensym 'for-cont)])
+                    (letrec ([make-init+test+increment+loop
+                              (lambda (value)
+                                (match value
+                                  [($ a60:for-number value)
+                                   (values (make-a60:assign (list variable) (make-a60:binary 'num 'num
+											     (->stx '+) 
+											     (->stx '0)
+											     value)) ; +0 => number
+                                           (->stx #t)
+                                           (make-a60:dummy)
+                                           #f)]
+                                  [($ a60:for-step start step end)
+                                   (values (make-a60:assign (list variable) start)
+                                           (make-a60:binary 'bool 'num
+							    (->stx '<=)
+                                                            (make-a60:binary 'num 'num
+									     (->stx '*)
+                                                                             (make-a60:binary 'num 'num (->stx '-) variable end)
+                                                                             (make-a60:app (->stx 'sign) (list step)))
+                                                            (->stx '0))
+                                           (make-a60:assign (list variable) (make-a60:binary 'num 'num (->stx '+) variable step))
+                                           #t)]
+                                  [($ a60:for-while value test)
+                                   (values (make-a60:assign (list variable) value)
+                                           test
+                                           (make-a60:assign (list variable) value)
+                                           #t)]))])
+                      (if (= 1 (length val-exprs))
+                          (let-values ([(init test inc loop?) (make-init+test+increment+loop (car val-exprs))])
+                            (loop (list*
+                                   init
+                                   (make-a60:label body-label (make-a60:dummy))
+                                   (make-a60:branch test 
+                                                    (make-a60:compound
+                                                     (list
+                                                      body
+                                                      inc
+                                                      (if loop?
+                                                          (make-a60:goto body-label)
+                                                          (make-a60:dummy))))
+                                                    (make-a60:dummy))
+                                   (cdr l))))
+                          (let* ([stage-name (datum->syntax-object #f (gensym 'stage-number))]
+                                 [switch-name (datum->syntax-object #f (gensym 'stage-switch))]
+                                 [end-switch-name (datum->syntax-object #f (gensym 'stage-switch))]
+                                 [stage-var (make-a60:variable stage-name null)]
+                                 [start-labels (map (lambda (x) (gensym 'stage)) (append val-exprs (list 'extra)))]
+                                 [end-labels (map (lambda (x) (gensym 'stage)) val-exprs)])
+                            (set! extra-decls (list* stage-name 
+                                                     (cons switch-name start-labels)
+                                                     (cons end-switch-name end-labels)
+                                                     extra-decls))
+                            (loop
+                             (append
+                              (list (make-a60:assign (list stage-var) (->stx '0)))
+                              (let loop ([start-labels start-labels][end-labels end-labels][val-exprs val-exprs])
+                                (if (null? val-exprs)
+                                    (list (make-a60:label (car start-labels) (make-a60:dummy)))
+                                    (let-values ([(init test inc loop?) (make-init+test+increment+loop (car val-exprs))])
+                                      (list*
+                                       (make-a60:label (car start-labels) (make-a60:dummy))
+                                       init
+                                       (make-a60:branch test 
+                                                        (make-a60:goto body-label)
+                                                        (make-a60:compound                                                   
+                                                         (list
+                                                          (make-a60:assign (list stage-var) (make-a60:binary 'num 'num
+													     (->stx '+)
+													     (->stx '1)
+													     stage-var))
+                                                          (make-a60:goto (make-a60:subscript switch-name stage-var)))))
+                                       (make-a60:label (car end-labels) (make-a60:dummy))
+                                       inc
+                                       (if loop?
+                                           (make-a60:goto (car start-labels))
+                                           (make-a60:goto (cadr start-labels)))
+                                       (loop (cdr start-labels)
+                                             (cdr end-labels)
+                                             (cdr val-exprs))))))
+                              (list 
+                               (make-a60:goto cont-label)
+                               (make-a60:label body-label (make-a60:dummy))
+                               body
+                               (make-a60:goto (make-a60:subscript end-switch-name stage-var))
+                               (make-a60:label cont-label (make-a60:dummy)))
+                              (cdr l)))))))]
+                 [($ a60:label name statement)
+                  (cons (cons name (make-a60:dummy))
+                        (loop (cons statement (cdr l))))]
+                 [else
+                  (cons (cons (gensym 'other) (car l))
+                        (loop (cdr l)))]))))
+       (make-a60:block
+        (append
+         (map (lambda (decl)
+                (match decl
+                  [($ a60:proc-decl result-type var arg-vars by-value-vars arg-specs body)
+                   (make-a60:proc-decl result-type var arg-vars by-value-vars arg-specs
+                                       (simplify-statement body ->stx))]
+                  [else decl]))
+              decls)
+         (map (lambda (extra)
+                (if (identifier? extra)
+                    (make-a60:type-decl (->stx 'integer) (list extra))
+                    (make-a60:switch-decl (car extra) (map (lambda (x) 
+                                                             (make-a60:variable (datum->syntax-object #f x) null)) 
+                                                           (cdr extra)))))
+              extra-decls))
+        (if (null? new-statements)
+            (list (cons (gensym 'other) (make-a60:dummy)))
+            new-statements)))
+
+     (define (simplify stmt ctx)
+       (simplify-statement stmt (lambda (x)
+				  (datum->syntax-object
+				   ctx
+				   x))))
+     
+     (define (simplify-statement stmt ->stx)
+	 (match stmt
+         [($ a60:block decls statements)
+          (flatten/label-block decls statements ->stx)]
+         [($ a60:compound statements)
+          (flatten/label-block null statements ->stx)]
+         [else stmt])))
+   
\ No newline at end of file
diff --git a/collects/algol60/tool.ss b/collects/algol60/tool.ss
new file mode 100644
index 0000000000..ab14959400
--- /dev/null
+++ b/collects/algol60/tool.ss
@@ -0,0 +1,116 @@
+(module tool mzscheme
+  (require (lib "tool.ss" "drscheme")
+           (lib "mred.ss" "mred")
+           (lib "unitsig.ss")
+           (lib "class.ss")
+           "parse.ss"
+           "simplify.ss"
+           "compile.ss"
+	   "get-base.ss"
+	   (lib "embed.ss" "compiler")
+	   (lib "string-constant.ss" "string-constants")
+	   (prefix bd: "bd-tool.ss"))
+
+  (provide tool@)
+
+  (define tool@
+    (unit/sig drscheme:tool-exports^
+      (import drscheme:tool^)
+      
+      (define-values/invoke-unit/sig drscheme:tool-exports^
+	bd:tool@
+	bd
+	drscheme:tool^)
+
+      (define (phase1) (bd:phase1))
+      (define (phase2) 
+	(bd:phase2)
+        (drscheme:language-configuration:add-language
+         (make-object (override-mrflow-methods
+                       ((drscheme:language:get-default-mixin) 
+                        lang%)))))
+      
+      (define (override-mrflow-methods %)
+	(if (method-in-interface? 'render-value-set (class->interface %))
+	    (class %
+	      (inherit [super-render-value-set render-value-set]
+		       [super-get-mrflow-primitives-filename get-mrflow-primitives-filename])
+	      (define/override (render-value-set . x)
+		;; needs to be filled in!
+		(super-render-value-set . x))
+	      (define/override (get-mrflow-primitives-filename)
+		(build-path (collection-path "mrflow")
+			    "primitives"
+			    "algol60.ss"))
+	      (super-instantiate ()))
+	    %))
+
+      (define lang%
+        (class* object% (drscheme:language:language<%>)
+          (define/public (config-panel parent)
+            (case-lambda
+              [() null]
+              [(x) (void)]))
+          (define/public (get-comment-character) (values "'COMMENT'" #\*))
+          (define/public (default-settings) null)
+          (define/public (default-settings? x) #t)
+          (define/private (front-end port settings)
+            (let ([name (object-name port)])
+              (lambda ()
+                (if (eof-object? (peek-char port))
+                    eof
+		    (compile-simplified 
+		     (simplify (parse-a60-port port name) base-importing-stx) 
+		     base-importing-stx)))))
+          (define/public (front-end/complete-program port settings teachpack-cache) (front-end port settings))
+          (define/public (front-end/interaction port settings teachpack-cache) (front-end port settings))
+          (define/public (get-style-delta) #f)
+          (define/public (get-language-position)
+	    (list (string-constant experimental-languages)
+		  "Algol 60"))
+          (define/public (order-manuals x) 
+            (values 
+             (list #"drscheme" #"tour" #"help")
+             #f))
+          (define/public (get-language-name) "Algol 60")
+          (define/public (get-language-url) #f)
+          (define/public (get-language-numbers) (list 1000 10))
+          (define/public (get-teachpack-names) null)
+          (define/public (marshall-settings x) x)
+          (define/public (on-execute settings run-in-user-thread)
+            (dynamic-require '(lib "base.ss" "algol60") #f)
+            (let ([path ((current-module-name-resolver) '(lib "base.ss" "algol60") #f #f)]
+                  [n (current-namespace)])
+              (run-in-user-thread
+               (lambda ()
+		 (error-display-handler 
+		  (drscheme:debug:make-debug-error-display-handler (error-display-handler)))
+		 (current-eval 
+		  (drscheme:debug:make-debug-eval-handler (current-eval)))
+                 (with-handlers ([void (lambda (x)
+                                         (printf "~a~n"
+                                                 (exn-message x)))])
+                   (namespace-attach-module n path)
+                   (namespace-require path))))))
+          (define/public (render-value value settings port) (write value port))
+          (define/public (render-value/format value settings port width) (write value port))
+          (define/public (unmarshall-settings x) x)
+	  (define/public (create-executable settings parent src-file teachpacks)
+	    (let ([dst-file (drscheme:language:put-executable
+			     parent src-file #f #f
+			     (string-constant save-a-mzscheme-stand-alone-executable))])
+	      (when dst-file
+		(let ([code (compile-simplified (simplify (parse-a60-file src-file)
+							  base-importing-stx)
+						base-importing-stx)])
+		  (make-embedding-executable dst-file
+					     #f #f
+					     '((#f (lib "base.ss" "algol60")))
+					     null
+					     (compile
+					      `(module m (lib "base.ss" "algol60")
+						 ,code))
+					     (list "-mvqe" "(require m)"))))))
+	  (define/public (get-one-line-summary) "Algol 60 (not Scheme at all!)")
+          
+          (super-instantiate ()))))))
diff --git a/collects/browser/browser-sig.ss b/collects/browser/browser-sig.ss
new file mode 100644
index 0000000000..6b99d9bef3
--- /dev/null
+++ b/collects/browser/browser-sig.ss
@@ -0,0 +1,11 @@
+(module browser-sig mzscheme
+  (require (lib "unitsig.ss")
+           "private/sig.ss")
+  
+  (provide browser^)
+
+  (define-signature browser^
+    ((open hyper^)
+     (open html-export^)
+     (open bullet-export^))))
+
diff --git a/collects/browser/browser-unit.ss b/collects/browser/browser-unit.ss
new file mode 100644
index 0000000000..148abdd902
--- /dev/null
+++ b/collects/browser/browser-unit.ss
@@ -0,0 +1,44 @@
+(module browser-unit mzscheme
+  (require (lib "unitsig.ss")
+           (lib "mred-sig.ss" "mred")
+           (lib "plt-installer-sig.ss" "setup")
+           (lib "tcp-sig.ss" "net")
+           (lib "url-sig.ss" "net")
+           (lib "url-unit.ss" "net")
+           "browser-sig.ss"
+           "private/bullet.ss"
+           "private/html.ss"
+           "private/hyper.ss"
+           "private/sig.ss")
+  
+  (provide browser@)
+  
+  (define pre-browser@
+    (compound-unit/sig
+      (import (plt-installer : setup:plt-installer^)
+              (mred : mred^)
+              (tcp : net:tcp^)
+              (url : net:url^))
+      (link [html : html^ (html@ mred url)]
+            [hyper : hyper^ (hyper@ html mred plt-installer url)]
+	    [bullet-size : bullet-export^ ((unit/sig bullet-export^
+					     (import)
+					     (rename (html:bullet-size bullet-size))
+					     (define html:bullet-size bullet-size)))])
+      (export (open hyper)
+	      (open bullet-size)
+              (open (html : html-export^)))))
+  
+  
+  ;; this extra layer of wrapper here is only to
+  ;; ensure that the browser^ signature actually matches
+  ;; the export of the pre-browser@ unit.
+  ;; (it didn't before, so now we check.)
+  (define browser@
+    (compound-unit/sig
+      (import  (plt-installer : setup:plt-installer^)
+               (mred : mred^)
+               (tcp : net:tcp^)
+               (url : net:url^))
+      (link [pre-browser : browser^ (pre-browser@ plt-installer mred tcp url)])
+      (export (open pre-browser)))))
diff --git a/collects/browser/browser.ss b/collects/browser/browser.ss
new file mode 100644
index 0000000000..d90647f9d5
--- /dev/null
+++ b/collects/browser/browser.ss
@@ -0,0 +1,19 @@
+(module browser mzscheme
+  (require (lib "unitsig.ss")
+           (lib "mred.ss" "mred")
+           (lib "mred-sig.ss" "mred")
+           (lib "plt-installer-sig.ss" "setup")
+           (lib "plt-installer.ss" "setup")
+           (lib "tcp-sig.ss" "net")
+           (lib "url-sig.ss" "net")
+           (lib "url.ss" "net")
+           "browser-sig.ss"
+           "browser-unit.ss")
+  
+  (provide-signature-elements browser^)
+  
+  (define-values/invoke-unit/sig browser^ browser@ #f
+                                 setup:plt-installer^
+                                 mred^
+                                 net:tcp^
+                                 net:url^))
diff --git a/collects/browser/bullet-snip.ss b/collects/browser/bullet-snip.ss
new file mode 100644
index 0000000000..3d0f0c85ba
--- /dev/null
+++ b/collects/browser/bullet-snip.ss
@@ -0,0 +1,3 @@
+(module bullet-snip mzscheme
+  (require "private/bullet.ss")
+  (provide (rename bullet-snip-class snip-class)))
diff --git a/collects/browser/doc.txt b/collects/browser/doc.txt
new file mode 100644
index 0000000000..38f1c53840
--- /dev/null
+++ b/collects/browser/doc.txt
@@ -0,0 +1,449 @@
+
+The _browser.ss_ library in the "browser" collection provides the
+following procedures and classes for parsing and viewing _HTML_ files.
+The "htmltext.ss" library (described further below) provides a
+simplified interface for rendering to a subclass of the MrEd text%
+class. The "external.ss" library (described even further below)
+provides utilities for launching an external browser (such as
+Mozilla).
+
+The browser (and htmltext) supports basic HTML commands, plus special
+Scheme hyperlinks of the form <A MZSCHEME=sexpr>...</A>. When the user
+clicks on such a link, the string `sexpr' is parsed as a Scheme
+program and evaluated. Since `sexpr' is likely to contain Scheme
+strings, and since escape characters are difficult for people to read,
+a vertical bar (|) character in sexpr is converted to a double-quote
+(") character before it is parsed. Thus,
+
+  <A MZSCHEME="|This goes nowhere.|">Nowhere</A>
+
+creates a "Nowhere" hyperlink, which executes the Scheme program
+
+  "This goes nowhere."
+
+The value of that program is a string. When a Scheme hyperlink returns
+a string, it is parsed as a new HTML document. Thus, where the use
+clicks on "Nowhere", the result is a new page that says "This goes
+nowhere."
+
+The browser also treats comment forms containing MZSCHEME=sexpr
+specially.  Whereas the <A MZSCHEME=sexpr>...</A> form executes the
+expression when the user clicks, the MZSCHEME expression in a comment
+is executed immediately during HTML rendering. If the result is a
+string, the comment is replaced in the input HTML stream with the
+content of the string. Thus,
+
+ <!-- MZSCHEME="(format |<B>Here</B>: ~a| (current-directory))" -->
+
+inserts the path of the current working directory into the containing
+document (and "Here" is boldfaced). If the result is a snip instead of
+a string, it replaces the comment in the document. Other types of
+return values are ignored.
+
+If the html file is being accessed as a "file:" url, the
+current-load-relative-directory parameter is set to the directory
+during the evaluation of the mzscheme code (in both examples). The
+Scheme code is executed through `eval'.
+
+The MZSCHEME forms are disabled unless the web page is a
+file: url that points into the `doc' collection.
+
+----------------------------------------
+
+> (open-url url) - Opens the given url
+  (either a string, url record, or port) 
+  in a vanilla browser frame and returns
+  the frame. The frame is an instance of
+  hyper-frame%.
+  
+-----------------------------------------
+
+The html-img-ok parameter controls image rendering for the browser.
+
+> (html-img-ok on?) - Sets the value of the parameter to on?
+> (html-img-ok) - Returns the current value of the parameter
+
+The html-eval-ok parameter controls the evaluation of 
+`MZSCHEME=' tags. If the parameter is #f, they are disabled.
+
+> (html-eval-ok on?) - Sets the value of the parameter to on?
+> (html-eval-ok) - Returns the current value of the parameter
+
+
+------------------------------------------------------------
+
+> (hyper-frame-mixin frame%) - Extends the given frame% class.
+
+   The result of this mixin takes one argument, a url
+   string. During the initialization of objects created from
+   this mixin, the code shows the frame and visits the url.
+
+> get-hyper-panel% :: (send hyper-frame get-hyper-panel%)
+  returns the class that is instantiated with the frame is created.
+  Must be a panel with hyper-panel-mixin mixed in. Defaults to
+  just returning hyper-panel%.
+
+> get-hyper-panel :: (send hyper-frame get-hyper-panel) - returns the hyper panel
+  in this frame
+  
+----------------------------------------
+
+> hyper-frame% = (hyper-frame-mixin frame%)
+
+------------------------------------------------------------
+
+> (hyper-no-show-frame-mixin frame%) - Extends the given frame% class.
+
+  This is the same as the hyper-frame-mixin, except that it
+  doesn't show the frame and the initialization arguments
+  are unchanged.
+
+----------------------------------------
+
+> hyper-no-show-frame% = (hyper-frame-no-show-mixin frame%)
+
+----------------------------------------
+
+> (hyper-text-mixin text%) - Extends the given text% class. The
+   initializtion arguments are extended with a four new first
+   arguments: a url or a port to be loaded into the text% object, a
+   top-level-window or #f to use as a parent for status dialogs, a
+   progress procedure used as for `get-url', and either #f or a post
+   string to be sent to a web server (technically changing the GET to
+   a POST).
+
+   Sets the autowrap-bitmap to #f.
+   
+   An instance of a (hyper-text-mixin text%) class should be displayed
+   only in an instance of a class created with `hyper-canvas-mixin'
+   (described below).
+
+   The mixin adds the following methods:
+
+>   map-shift-style :: (send o map-shift-style start end shift-style)
+     Maps the given style over the given range
+
+>   make-link-style :: (send o make-link-style start end)
+     Changes the style for the given range to the link style
+
+>   get-url :: (send o get-url)
+     Returns the URL displayed by the editor, or #f if there
+     is none.
+
+>   get-title :: (send o get-title)
+>   set-title :: (send o set-title string)
+     Gets or sets the page's title
+
+>   hyper-delta
+     A style-delta% object; override it to set the link style
+
+>   add-tag ::(send o add-tag name-string pos)
+     Installs a tag.
+
+>   find-tag :: (send o find-tag name-string/number)
+     Finds the location of a tag in the buffer (where tags are
+     installed in HTML with <A NAME="name">) and returns its
+     position. If `name' is a number, the number is returned (assumed
+     to be an offset rather than a tag). Otherwise, if the tag is not
+     found, #f is returned.
+
+>   remove-tag :: (send o remove-tag name)
+     Removes a tag.
+
+>   post-url :: (send o post-url string[url] post-data-bytes)
+     Follows the link in the string. post-data-bytes defaults to #f
+
+>   add-link :: (send o add-link start end url-string)
+     Installs a hyperlink.
+
+>   add-scheme-callback :: (send o add-scheme-callback start end scheme-string)
+     Installs a Scheme evaluation hyperlink.
+
+>   add-scheme-callback :: (send o add-thunk-callback start end thunk)
+     Installs a thunk-based hyperlink.
+
+>   eval-scheme-string :: (send o eval-scheme-string string)
+     Called to handle the <A MZSCHEME="expr">...</A> tag and <!
+     MZSCHEME="expr"> comments (see above). Evaluates the string; if
+     the result is a string, it is opened as an HTML page.
+
+>  reload :: (send o reload)
+
+    Reloads the current page.
+     
+>  remap-url :: (send o remap-url url) -> url or string or #f
+
+   When visiting a new page, this method is called to remap
+   the url. The remapped url is used in place of the
+   original url. If this method returns #f, the page doesn't
+   go anywhere.
+
+   This method may be killed (if the user clicks the
+   ``stop'' button)
+
+----------------------------------------
+
+> hyper-text% = (hyper-text-mixin text:keymap%)
+
+  This is an extension of the keymap class, to support standard keybindings
+  in the browser window. It adds the following method:
+
+>   get-hyper-keymap :: (send o get-hyper-keymap) -> keymap% object
+    Returns a keymap suitable for frame-level handling of events to
+    redirect page-up, etc. to the browser canvas.
+
+----------------------------------------
+
+> (hyper-canvas-mixin editor-canvas%) - Extends the given
+  editor-canvas% class. The intialization arguments are unchanged.
+
+  The canvas's parent should be an instance of a class derived with
+  `hyper-panel-mixin' (described below).
+
+  The mixin adds the following methods:
+
+>   get-editor% :: (send o get-editor%)
+     Returns the class used to implement the editor in the browser
+     window. It should be derived from hyper-text% and should pass on the
+     initialization arguments to hyper-text%
+
+     The dynamic extent of the initialization of this
+     editor is called on a thread that may be killed (via a
+     custodian shutdown)
+
+     In that case, the editor in the browser's
+     editor-canvas may not be an instance of this class.
+
+>   current-page :: (send o current-page)
+     Returns a reprsentation of the currently displayed page, which
+     includes a particular editor and a visible range within the
+     editor.
+ 
+>   goto-url :: (send o goto-url url relative-to-url [progress-proc] [post-data-bytes #f])
+     Changes to the given url, loading it by calling the `make-editor'
+     method. If `relative-to-url' is not #f, it must be a URL for
+     resolving `url' as a relative URL. `url' may also be a port, in
+     which case, `relative-to-url' must be #f.
+
+     The `progress-proc' procedure is called with a boolean at the
+     point where the URL has been resolved and enough progress has
+     been made to dismiss any message that the URL is being
+     resolved. The procedure is called with #t if the URL will be
+     loaded into a browser window, #f otherwise (e.g., the user will
+     save the URL content to a file).
+
+     If `post-data-bytes' is a byte string instead of false, the URL
+     GET is changed to a POST with the given data.
+
+>   set-page :: (send o set-page page notify?)
+     Changes to the given page. If `notify?' is not #f, the canvas's
+     parent is notified about the change by calling its `leaving-page'
+     method.
+
+>   after-set-page :: (send o after-set-page)
+     Called during `set-page'. Defaultly does nothing.
+
+----------------------------------------
+
+> hyper-canvas% = (hyper-canvas-mixin editor-canvas%)
+
+----------------------------------------
+
+> (hyper-panel-mixin area-container%) - Extends the given area
+  container class. The initialization arguments are unchanged, but
+  initialization creates controls and a hyper text canvas.  The
+  controls permit a user to move back and forth in the hypertext
+  history.
+
+  The mixin adds a initialization argument, info-line?, which is a
+  boolean indicating whether the browser should contain a line to
+  display special "DOCNOTE" tags in a page. Such tags are used
+  primarily by the PLT documentation.
+
+  The mixin adds the following instance variables:
+
+>   make-canvas :: (send o make-canvas container)
+     Creates the panel's hypertext canvas, an instance of a class
+     derived using `hyper-canvas-mixin' (described above). This
+     method is called during initialization.
+
+>   get-canvas% :: (send o get-canvas%)
+     Returns the class instantiated by make-canvas. It must be derived from
+     hyper-canvas% 
+
+
+>   make-control-bar-panel :: (send o make-control-bar-panel container)
+     Create's the panel's sub-container for the control bar containing
+     the navigation buttons. If #f is returned, the panel will have no
+     control bar. The default method instantiates horizontal-panel%.
+
+>   rewind :: (send o rewind)
+     Goes back one page, if possible.
+
+>   forward :: (send o forward)
+     Goes forward one page, if possible.
+
+>   get-canvas :: (send o get-canvas)
+     Gets the hypertext canvas.
+
+>   on-navigate :: (send o on-navigate)
+     Callback that is invoked any time the displayed hypertext page
+     changes (either by clicking on a link in the canvas or by
+     `rewind' or `forward' calls).
+
+>   leaving-page :: (send o leaving-page page new-page)
+     This method is called by the hypertext canvas to notify the
+     panel that the hypertext page changed. The `page' is #f
+     if `new-page' is the first page for the canvas. See also
+     `page->editor' (decsribed below).
+
+>   filter-notes :: (send o filter-notes list-of-strings)
+     Given the notes from a page as a list of strings (where
+     each string is a note), returns a single string to print
+     above the page.
+
+>   reload :: (send o reload)
+
+   Reloads the currently visible page by calling the reload method of
+   the currently displayed hyper-text.
+----------------------------------------
+
+> hyper-panel% = (hyper-panel-mixin vertical-panel%)
+
+----------------------------------------
+
+> (editor->page editor) - Creates a page record for the given editor,
+  suitable for use with the `set-page' method of hyper-canvas-mixin.
+
+> (page->editor page) - Extracts the editor from a page record.
+
+> (on-installer-run [proc]) - Parameter for a procedure to be invoked
+  after the installer is run on a .plt file
+
+> (bullet-size [n]) - Parameter controlling the point size of a
+  bullet
+
+-----------------------------------------
+
+> image-map-snip% extends image-snip%
+  init:  html-text : (is-a?/c html-text<%>)
+
+Instances of this class behave like image-snip% objects,
+except they have a <map> ... </map> associated with them and
+when clicking on them (in the map) they will cause their
+init arg text to follow the corresponding link.
+
+> (send an-image-map-snip set-key key-string)
+
+  Sets the key for the image map (eg, "#key").
+
+> (send an-image-map-snip get-key)
+
+  Returns the current key.
+
+> (send an-image-map-snip add-area shape-string list-of-numbers href-string)
+
+  Registers the shape named by the shape-string whose
+  coordinates are specified by the list-of-numbers to go to
+  the href named href-string when that region of the image
+  is clicked on.
+
+-----------------------------------------
+
+The _browser-unit.ss_ library in the "browser" collection is a
+unitized version of the code documented above.  It imports unit
+matching thefollowing signatures:
+
+    setup:plt-installer^
+    mred^
+    net:tcp^ (see "tcp-sig.ss" in the "net" collection)
+    net:url^ (see "url-sig.ss" in the "url" collection)
+
+ It exports the browser^ signature.
+ 
+-----------------------------------------
+
+The _browser-sig.ss_ library in the "browser" collection defines
+the browser^ signature with all of the names listed above.
+
+
+========================================
+_htmltext.ss_
+========================================
+
+> html-text<%>
+
+An interface that extends text% with the following methods:
+
+> get-url :: (send t get-url) --- returns a base URL used for building
+  relative URLs, or #f if no base is available
+
+> set-title :: (send t set-title str) --- registers the title `str'
+  for the rendered page
+
+> add-link :: (send t add-link start-pos end-pos url-string) ---
+  registers a hyperlink for the given region in rendered page
+
+> add-tag :: (send t label pos) --- registers a tag at the given
+  position in the rendered page
+
+> make-link-style :: (send t make-link-style start-pos end-pos) ---
+  modifies the style of the rendered page from start-pos to end-pos to
+  look like a hyperlink
+
+> add-scheme-callback :: (send t add-scheme-callback pos endpos code-string)
+  --- registers a code-evaluating hyperlink for the given region
+
+> add-thunk-callback :: (send t add-scheme-callback pos endpos thunk)
+  --- registers a thunk-invoking hyperlink for the given region
+
+> post-url :: (send t post-url url post-data-bytes)
+  --- performs a post to the given `url' with the given  post data
+
+----------------------------------------
+
+> (html-text-mixin text%-subclass) -> html-text<%> implementation
+
+Extends the given text% class with implementations of the html-text<%>
+methods. Hyperlinks are attched to clickbacks that use `send-url'
+(from the "sendurl.ss" library of the "net" collection).
+
+> (render-html-to-text input-port html-text<%>-obj load-img? eval-mz?)
+
+Reads HTML from `input-port' and renders it to `html-text<%>-obj'.  If
+`load-img?' is false, then images are rendered as Xed-out boxes. If
+`eval-mz?' is false, then MZSCHEME hyperlink expressions and comments
+are not evaluated.
+
+========================================
+_external.ss_
+========================================
+
+> (send-url str [separate-window? #t])
+  Like 'send-url' in (lib "sendurl.ss" "net"), but under Unix,
+  the user is prompted for a browser to use if none is recorded
+  in the preferences file.
+
+> (browser-preference? v)
+  Returns #t if v is a valid browser preference
+
+> (update-browser-preference url-or-#f)
+  Under Unix, prompts the user for a browser preference and records
+  the user choice as a framework preference (even if one is already
+  recorded). If `url-or-#f' is not #f, it is used in the dialog to
+  explain which URL is to be opened; if it is #f, the 'internal will
+  be one of the options for the user.
+
+> (install-help-browser-preference-panel)
+  Installs a framework preference panel for "Browser" options.
+
+> (add-to-browser-prefs-panel proc)
+  The `proc' must be a procedure that takes a panel% argument.  It
+  will be called when the "Browser" panel is constructed for
+  preferences. The supplied argument is the panel, so `proc' can add
+  additional option controls. If the panel is already created, `proc'
+  is called immediately.
+
+> tool@
+  A unit that implements a DrScheme tool to add the "Browser"
+  preference panel.
diff --git a/collects/browser/external.ss b/collects/browser/external.ss
new file mode 100644
index 0000000000..43f02dbb90
--- /dev/null
+++ b/collects/browser/external.ss
@@ -0,0 +1,315 @@
+(module external mzscheme
+  (require (lib "string-constant.ss" "string-constants")
+           (lib "mred.ss" "mred")
+           (lib "class.ss")
+           (lib "file.ss")
+           (lib "list.ss")
+           (lib "match.ss")
+           (prefix raw: (lib "sendurl.ss" "net"))
+           (lib "url.ss" "net")
+           (prefix fw: (lib "framework.ss" "framework")))
+  (provide send-url
+           (rename raw:browser-preference? browser-preference?)
+           update-browser-preference
+	   install-help-browser-preference-panel
+	   add-to-browser-prefs-panel)
+  
+  ; : -> bool
+  (define (unix-browser?)
+    (and (eq? (system-type) 'unix)
+	 (not (equal? "ppc-darwin" (system-library-subpath)))))
+  
+  (fw:preferences:set-default
+   'external-browser
+   (get-preference 'external-browser (lambda () #f))
+   raw:browser-preference?)
+  
+  (define http-proxy-preference 'plt:http-proxy)
+
+  ;; proxy-pref? : any -> boolean
+  ;; determines if the input is a valid setting for the
+  ;; http-proxy-preference pref
+  (define (proxy-pref? x)
+    (match x
+      [#f #t]
+      [`("http" ,(? string?) ,(? number?)) #t]
+      [else #f]))
+  
+  ;; sync-current-proxy-servers : proxy-pref -> void
+  ;; syncs current-proxy-servers parameter with the proxy-pref-val
+  (define (sync-current-proxy-servers pref-val)
+    (let* ([ops (current-proxy-servers)]
+           [removed (remove-all-proxies "http" ops)])
+      (current-proxy-servers
+       (if pref-val
+           (cons pref-val removed)
+           removed))))
+
+  (define (remove-all-proxies scheme proxies)
+    (filter (lambda (x) 
+              (and (pair? x)
+                   (not (equal? (car x) scheme))))
+            proxies))
+  
+  (fw:preferences:set-default http-proxy-preference #f proxy-pref?)
+  (sync-current-proxy-servers (fw:preferences:get http-proxy-preference))
+  (fw:preferences:add-callback http-proxy-preference (lambda (p v) (sync-current-proxy-servers v)))
+    
+  (define send-url
+    (if (unix-browser?)
+        (lambda (url . args)
+          (when (or (get-preference 'external-browser (lambda () #f))
+		    ;; either the preference doesn't exist or is #f
+		    (update-browser-preference url))
+	    (apply raw:send-url url args)))
+        raw:send-url))
+  
+  ; : str -> void
+  ; to prompt the user for a browser preference and update the preference
+  (define (update-browser-preference url)
+    (or (not (unix-browser?))
+	(choose-browser url)))
+  
+  ; : (U symbol #f) -> void
+  ; to set the default browser
+  (define (set-browser! browser)
+    (fw:preferences:set 'external-browser browser))
+  
+  ;; Tries to put low-level prefs three times, sleeping a bit in
+  ;; between, then gives up.
+  (define (try-put-preferences names vals)
+    (let loop ([tries 0])
+      (unless (= tries 3)
+	(put-preferences names vals 
+			 (lambda (lock-file)
+			   (sleep 0.2)
+			   (loop (add1 tries)))))))
+
+  (define unix-browser-names
+    (map (lambda (s)
+	   (let ([l (string->list (symbol->string s))])
+	     (list->string (cons (char-upcase (car l)) (cdr l)))))
+	 raw:unix-browser-list))
+
+  ;; : (U str #f) -> (U symbol #f)
+  ;; to prompt the user for a browser preference
+  ;;  #f for the URL indicates a pre-emptive request by Help Desk,
+  ;;  and in that case, the user can choose to use the internal
+  ;;  broswer.
+  (define (choose-browser url)
+    (let* ([title (string-constant choose-browser)]
+           [d (make-object dialog% title)]
+           [main-pane (make-object vertical-pane% d)]
+	   [internal-ok? (not url)]
+           [ok? #f]
+	   [orig-external (fw:preferences:get 'external-browser)])
+      (make-object message% title main-pane)
+      (when url
+	(make-object message% (format "URL: ~a" url) main-pane))
+      (let-values ([(panel callbacks) (make-help-browser-preference-panel internal-ok? #f (lambda (f) (f main-pane)))])
+	(let*-values ([(button-pane) (instantiate horizontal-panel% (main-pane)
+						  (alignment '(right center)))]
+		      [(ok-button cancel-button)
+		       (fw:gui-utils:ok/cancel-buttons
+			button-pane
+			(lambda (b e) (set! ok? #t) (send d show #f))
+			(lambda (b e) 
+			  (fw:preferences:set 'external-browser orig-external)
+			  (send d show #f)))]
+		      [(enable-button) (lambda (_n _v)
+					 (queue-callback
+					  (lambda ()
+					    (send ok-button enable (fw:preferences:get 'external-browser)))))])
+	  (send ok-button enable #f)
+	  (set! callbacks
+		(cons
+		 (fw:preferences:add-callback 'external-browser enable-button)
+		 callbacks)))
+	(send d show #t)
+	(map (lambda (f) (f)) callbacks)
+	ok?)))
+  
+  (define panel-installed? #f)
+  (define prefs-panel #f)
+  (define synchronized? #f)
+  (define additions null)
+
+  (define (install-help-browser-preference-panel)
+    (unless panel-installed?
+      (set! panel-installed? #t)
+      (make-help-browser-preference-panel
+       #t #t
+       (lambda (f) (fw:preferences:add-panel
+		    (string-constant browser)
+		    (lambda (parent)
+		      (let-values ([(panel cbs) (f parent)])
+		        (set! prefs-panel panel)
+			(map (lambda (f) (f panel)) additions)
+			(set! additions null)
+			panel)))))))
+
+  (define (add-to-browser-prefs-panel proc)
+    (if prefs-panel
+	(proc prefs-panel)
+	(set! additions (append additions (list proc)))))
+  
+  (define (make-help-browser-preference-panel set-help? ask-later? mk)
+    
+    (mk
+     (lambda (parent)
+       (define callbacks null)
+       (let ([pref-panel (instantiate vertical-panel% ()
+				       (parent parent) (alignment '(left center)))])
+
+	 ;; -------------------- external browser for Unix --------------------
+	 (when (unix-browser?)
+	   (unless synchronized?
+	     ;; Keep 'external-browser in sync
+	     (fw:preferences:add-callback 'external-browser
+					  (lambda (name browser)
+					    (try-put-preferences (list 'external-browser) (list browser)))))
+
+	   (letrec ([v-panel (instantiate group-box-panel% ()
+					  (parent pref-panel)
+					  (alignment '(right center))
+					  (stretchable-height #f)
+					  (label (string-constant external-browser-choice-title)))]
+		    [h-panel (instantiate horizontal-panel% ()
+					  (parent v-panel)
+					  (alignment '(center bottom)))]
+		    [none-index (length raw:unix-browser-list)]
+		    [custom-index (add1 none-index)]
+		    [r (instantiate radio-box% ()
+				    (label #f)
+				    (choices (append unix-browser-names
+						     (list (string-constant no-browser)
+							   (string-constant browser-command-line-label))))
+				    (parent h-panel)
+				    (callback
+				     (lambda (radio event)
+				       (let ([n (send radio get-selection)])
+					 (set-browser!
+					  (cond
+					   [(= n none-index) #f]
+					   [(= n custom-index) (get-custom)]
+					   [else (list-ref raw:unix-browser-list n)]))))))]
+		    [select-custom
+		     (lambda (_ __)
+		       (send r set-selection custom-index)
+		       (set-browser! (get-custom)))]
+		    [get-custom
+		     (lambda () (cons (send pre get-value) (send post get-value)))]
+		    [template-panel (instantiate horizontal-panel% (h-panel)
+						 (spacing 0)
+						 (stretchable-height #f))]
+		    [pre (instantiate text-field% ()
+				      (label #f) (parent template-panel) (callback select-custom)
+				      (horiz-margin 0))]
+		    [mess (instantiate message% () (label "<URL>") (parent template-panel)
+				       (horiz-margin 0))]
+		    [post (instantiate text-field% ()
+				       (label #f) (parent template-panel) (callback select-custom)
+				       (horiz-margin 0))]
+		    [note1 (instantiate message% ((string-constant browser-cmdline-expl-line-1)
+						  v-panel))]
+		    [note2 (instantiate message% ((string-constant browser-cmdline-expl-line-2)
+						  v-panel))]
+		    [refresh-controls (lambda (pref)
+					(if (pair? pref)
+					    (begin
+					      (send r set-selection custom-index)
+					      (send pre set-value (car pref))
+					      (send post set-value (cdr pref)))
+					    (let init ([x raw:unix-browser-list] [n 0])
+					      (cond
+					       [(null? x) (send r set-selection n)]
+					       [else (if (eq? pref (car x))
+							 (send r set-selection n)
+							 (init (cdr x) (add1 n)))]))))])
+
+	     (unless ask-later?
+	       (send r enable none-index #f))
+
+	     (refresh-controls (fw:preferences:get 'external-browser))
+	     (set! callbacks
+		   (cons
+		    (fw:preferences:add-callback 'external-browser
+						 (lambda (name browser)
+						   (refresh-controls browser)))
+		    callbacks))
+
+	     (let disable ([x raw:unix-browser-list] [n 0])
+	       (cond
+		[(null? x) (void)]
+		[else (unless (find-executable-path (symbol->string (car x)) #f)
+			(send r enable n #f))
+		      (disable (cdr x) (add1 n))]))))
+
+	 ;; -------------------- proxy for doc downloads --------------------
+	 (when set-help?
+	   (letrec ([p (instantiate group-box-panel% ()
+				    (label (string-constant http-proxy))
+				    (parent pref-panel)
+				    (stretchable-height #f)
+				    (alignment '(left top)))]
+		    [rb (make-object radio-box% 
+				     #f (list (string-constant proxy-direct-connection)
+					      (string-constant proxy-use-proxy))
+				     p
+				     (lambda (r e)
+				       (let ([proxy? (= 1 (send r get-selection))])
+					 (send proxy-spec enable proxy?)
+					 (if proxy?
+					     (update-proxy)
+					     (fw:preferences:set http-proxy-preference #f)))))]
+		    [proxy-spec (instantiate horizontal-panel% (p)
+					     [stretchable-width #f]
+					     [stretchable-height #f]
+					     [alignment '(left center)])]
+		    [update-proxy (lambda ()
+				    (let ([host (send host get-value)]
+					  [port (send port get-value)])
+				      (let ([ok? (and (regexp-match "^[-0-9a-zA-Z.]+$" host)
+						      (regexp-match "^[0-9]+$" port)
+						      (string->number port)
+						      (<= 1 (string->number port) 65535))])
+					(when ok?
+					  (fw:preferences:set 
+					   http-proxy-preference
+					   (list "http" host (string->number port))))
+					(send bad-host show (not ok?)))))]
+		    [host (make-object text-field%
+				       (string-constant proxy-host)
+				       proxy-spec (lambda (x y) (update-proxy))
+				       "www.someplacethatisaproxy.domain.comm")]
+		    [port (make-object text-field%
+				       (string-constant proxy-port)
+				       proxy-spec (lambda (x y) (update-proxy)) "65535")]
+		    [bad-host (make-object message%
+					   (string-constant proxy-bad-host)
+					   p)]
+		    [update-gui
+		     (lambda (proxy-val)
+		       (send bad-host show #f)
+		       (if proxy-val 
+			   (begin
+			     (send rb set-selection 1)
+			     (send proxy-spec enable #t)
+			     (unless (string=? (cadr proxy-val) (send host get-value))
+			       (send host set-value (cadr proxy-val)))
+			     (unless (equal? (caddr proxy-val) (string->number (send port get-value)))
+			       (send port set-value (number->string (caddr proxy-val)))))
+			   (begin
+			     (send rb set-selection 0)
+			     (send proxy-spec enable #f)
+			     (send host set-value "")
+			     (send port set-value ""))))])
+      
+	     (fw:preferences:add-callback http-proxy-preference
+					  (lambda (name val)
+					    (update-gui val)))
+	     (update-gui (fw:preferences:get http-proxy-preference))
+	     (send bad-host show #f)))
+
+	 (set! synchronized? #t)
+	 (values pref-panel callbacks))))))
diff --git a/collects/browser/htmltext.ss b/collects/browser/htmltext.ss
new file mode 100644
index 0000000000..9aa0af87b3
--- /dev/null
+++ b/collects/browser/htmltext.ss
@@ -0,0 +1,77 @@
+
+(module htmltext mzscheme
+  (require (lib "unitsig.ss")
+           (lib "class.ss")
+           "private/sig.ss"
+           "private/html.ss"
+           "private/bullet.ss"
+	   (lib "url.ss" "net")
+	   (lib "url-sig.ss" "net")
+           (lib "mred.ss" "mred")
+           (lib "mred-sig.ss" "mred")
+	   (lib "external.ss" "browser"))
+           
+  (define-values/invoke-unit/sig 
+     html^
+     (compound-unit/sig
+       (import (MRED : mred^) (URL : net:url^))
+       (link [HTML : html^ (html@ MRED URL)])
+       (export (open HTML)))
+     #f
+     mred^
+     net:url^)
+  
+  (define html-text<%>
+    (interface ((class->interface text%))
+      get-url
+      set-title
+      add-link
+      add-tag
+      make-link-style
+      add-scheme-callback
+      add-thunk-callback
+      post-url))
+
+  (define url-delta (make-object style-delta% 'change-underline #t))
+  (send url-delta set-delta-foreground "blue")
+
+  (define html-text-mixin
+    (mixin ((class->interface text%)) (html-text<%>)
+      (inherit change-style set-clickback)
+      
+      (define/public (get-url) #f)
+      (define/public (set-title s) (void))
+      (define/public (add-link pos end-pos url-string)
+	(set-clickback pos end-pos (lambda (e start-pos eou-pos)
+				     (send-url url-string))))
+      (define/public (add-tag label pos) (void))
+      (define/public (make-link-style pos endpos) 
+	(change-style url-delta pos endpos))
+      (define/public (add-scheme-callback pos endpos scheme) (void))
+      (define/public (add-thunk-callback pos endpos thunk)
+	(set-clickback pos endpos (lambda (e start-pos eou-pos)
+				     (thunk))))
+      (define/public (post-url url post-data)
+	(message-box "HTML" 
+		     (format "Cannot perform post: ~e"
+			     post-data)
+		     #f
+		     '(stop ok)))
+      (super-new)))
+
+  (define (render-html-to-text port text%-obj img-ok? eval-ok?)
+    (unless (input-port? port)
+      (raise-type-error 'render-html-to-text "input port" 0 (list port text%-obj)))
+    (unless (text%-obj . is-a? . html-text<%>)
+      (raise-type-error 'render-html-to-text "html-text<%> object" 0 (list port text%-obj)))
+    (parameterize ([html-eval-ok eval-ok?]
+		   [html-img-ok img-ok?])
+      (dynamic-wind
+	  (lambda () (send text%-obj begin-edit-sequence #f))
+	  (lambda () (html-convert port text%-obj))
+	  (lambda () (send text%-obj end-edit-sequence)))))
+  
+  (provide html-text<%>
+	   html-text-mixin
+           render-html-to-text))
+
diff --git a/collects/browser/info.ss b/collects/browser/info.ss
new file mode 100644
index 0000000000..474062ee03
--- /dev/null
+++ b/collects/browser/info.ss
@@ -0,0 +1,6 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Browser")
+  (define doc.txt "doc.txt")
+  (define tools (list (list "tool.ss")))
+  (define tool-names (list "Browser")))
+
diff --git a/collects/browser/private/btree.ss b/collects/browser/private/btree.ss
new file mode 100644
index 0000000000..c9bc19e4c6
--- /dev/null
+++ b/collects/browser/private/btree.ss
@@ -0,0 +1,225 @@
+(module btree mzscheme
+  (require "sig.ss"
+           (lib "unitsig.ss"))
+  
+  (provide btree@)
+  
+;; Implements a red-black tree with relative indexing along right
+;; splines. This allows the usual O(log(n)) operations, plus a
+;; O(log(n)) shift operation.
+  
+;; (This is the same data structure as used for lines by MrEd's text%
+;; class, but that one is implemented in C++.)
+  (define btree@
+    (unit/sig relative-btree^
+      (import)
+      (rename (create-btree make-btree))
+      
+      (define-struct btree (root))
+      
+      (define-struct node (pos data parent left right color))
+      
+      (define (adjust-offsets n new-child)
+        (when new-child
+          (set-node-pos! new-child (- (node-pos new-child)
+                                      (node-pos n)))))
+      
+      (define (deadjust-offsets n old-child)
+        (when old-child
+          (set-node-pos! old-child (+ (node-pos old-child)
+                                      (node-pos n)))))
+      
+      (define (rotate-left n btree)
+        (let ([old-right (node-right n)])
+          (deadjust-offsets n old-right)
+          
+          (let ([r (node-left old-right)])
+            (set-node-right! n r)
+            (when r
+              (set-node-parent! r n)))
+          
+          (let ([p (node-parent n)])
+            (set-node-parent! old-right p)
+            (cond
+              [(not p) (set-btree-root! btree old-right)]
+              [(eq? n (node-left p)) (set-node-left! p old-right)]
+              [else                 (set-node-right! p old-right)]))
+          
+          (set-node-left! old-right n)
+          (set-node-parent! n old-right)))
+      
+      (define (rotate-right n btree)
+        (let ([old-left (node-left n)])
+          (adjust-offsets old-left n)
+          
+          (let ([l (node-right old-left)])
+            (set-node-left! n l)
+            (when l
+              (set-node-parent! l n)))
+          
+          (let ([p (node-parent n)])
+            (set-node-parent! old-left p)
+            (cond
+              [(not p) (set-btree-root! btree old-left)]
+              [(eq? n (node-left p)) (set-node-left! p old-left)]
+              [else                 (set-node-right! p old-left)]))
+          
+          (set-node-right! old-left n)
+          (set-node-parent! n old-left)))
+      
+      
+      (define (insert before? n btree pos data)
+        (let ([new (make-node pos data #f #f #f 'black)])
+          (if (not (btree-root btree))
+              (set-btree-root! btree new)
+              
+              (begin
+                
+                (set-node-color! new 'red)
+                
+                ; Insert into tree
+                (if before?
+                    
+                    (if (not (node-left n))
+                        (begin
+                          (set-node-left! n new)
+                          (set-node-parent! new n))
+                        
+                        (let loop ([node (node-left n)])
+                          (if (node-right node)
+                              (loop (node-right node))
+                              (begin
+                                (set-node-right! node new)
+                                (set-node-parent! new node)))))
+                    
+                    (if (not (node-right n))
+                        (begin
+                          (set-node-right! n new)
+                          (set-node-parent! new n))
+                        
+                        (let loop ([node (node-right n)])
+                          (if (node-left node)
+                              (loop (node-left node))
+                              (begin
+                                (set-node-left! node new)
+                                (set-node-parent! new node))))))
+                
+                ; Make value in new node relative to right-hand parents
+                (let loop ([node new])
+                  (let ([p (node-parent node)])
+                    (when p
+                      (when (eq? node (node-right p))
+                        (adjust-offsets p new))
+                      (loop p))))
+                
+                ; Balance tree
+                (let loop ([node new])
+                  (let ([p (node-parent node)])
+                    (when (and (not (eq? node (btree-root btree)))
+                               (eq? 'red (node-color p)))
+                      (let* ([recolor-k
+                              (lambda (y)
+                                (set-node-color! p 'black)
+                                (set-node-color! y 'black)
+                                (let ([pp (node-parent p)])
+                                  (set-node-color! pp 'red)
+                                  (loop pp)))]
+                             [rotate-k
+                              (lambda (rotate node)
+                                (let ([p (node-parent node)])
+                                  (set-node-color! p 'black)
+                                  (let ([pp (node-parent p)])
+                                    (set-node-color! pp 'red)
+                                    (rotate pp btree)
+                                    (loop pp))))]
+                             [k
+                              (lambda (node-y long-rotate always-rotate)
+                                (let ([y (node-y (node-parent p))])
+                                  (if (and y (eq? 'red (node-color y)))
+                                      (recolor-k y)
+                                      (let ([k (lambda (node)
+                                                 (rotate-k always-rotate node))])
+                                        (if (eq? node (node-y p))
+                                            (begin
+                                              (long-rotate p btree)
+                                              (k p))
+                                            (k node))))))])
+                        (if (eq? p (node-left (node-parent p)))
+                            (k node-right rotate-left rotate-right)
+                            (k node-left rotate-right rotate-left))))))
+                
+                (set-node-color! (btree-root btree) 'black)))))
+      
+      (define (find-following-node btree pos)
+        (let ([root (btree-root btree)])
+          (let loop ([n root]
+                     [so-far root]
+                     [so-far-pos (and root (node-pos root))]
+                     [v 0])
+            (if (not n) 
+                (values so-far so-far-pos)
+                (let ([npos (+ (node-pos n) v)])
+                  (cond
+                    [(<= pos npos)
+                     (loop (node-left n) n npos v)]
+                    [(or (not so-far-pos)
+                         (> npos so-far-pos))
+                     (loop (node-right n) n npos npos)]
+                    [else
+                     (loop (node-right n) so-far so-far-pos npos)]))))))
+      
+      (define (create-btree)
+        (make-btree #f))
+      
+      (define (btree-get btree pos)
+        (let-values ([(n npos) (find-following-node btree pos)])
+          (and n
+               (= npos pos)
+               (node-data n))))
+      
+      (define (btree-put! btree pos data)
+        (let-values ([(n npos) (find-following-node btree pos)])
+          (if (and n (= npos pos))
+              (set-node-data! n data)
+              (insert (and n (< pos npos))
+                      n btree pos data))))
+      
+      (define (btree-shift! btree start delta)
+        (let loop ([n (btree-root btree)]
+                   [v 0])
+          (when n
+            (let ([npos (node-pos n)])
+              (cond
+                [(< start (+ v npos))
+                 (set-node-pos! n (+ npos delta))
+                 (loop (node-left n) v)]
+                [else
+                 (loop (node-right n) (+ v npos))])))))
+      
+      (define (btree-for-each btree f)
+        (when (btree-root btree)
+          (let loop ([n (btree-root btree)]
+                     [v 0])
+            (when (node-left n)
+              (loop (node-left n) v))
+            (f (+ v (node-pos n)) (node-data n))
+            (when (node-right n)
+              (loop (node-right n)
+                    (+ v (node-pos n)))))))
+      
+      (define (btree-map btree f)
+        (let ([start (cons #f null)])
+          (let loop ([n (btree-root btree)]
+                     [l start]
+                     [v 0])
+            (if (not n)
+                l
+                (let ([pre (loop (node-left n) l v)]
+                      [here (cons (f (+ v (node-pos n))
+                                     (node-data n))
+                                  null)])
+                  (set-cdr! pre here)
+                  (loop (node-right n)
+                        here
+                        (+ v (node-pos n))))))
+          (cdr start))))))
diff --git a/collects/browser/private/bullet.ss b/collects/browser/private/bullet.ss
new file mode 100644
index 0000000000..618fa1d99f
--- /dev/null
+++ b/collects/browser/private/bullet.ss
@@ -0,0 +1,96 @@
+(module bullet mzscheme 
+  (require (lib "unitsig.ss")
+           (lib "mred.ss" "mred")
+           "sig.ss"
+           (lib "class.ss"))
+  
+  (provide bullet-snip%
+	   get-bullet-width
+	   bullet-size
+	   bullet-snip-class)
+  
+  (define snip-class-name "(lib \"bullet-snip.ss\" \"browser\")")
+
+  (define bullet-size 
+    (make-parameter
+     (let ([s (send (send (send (make-object text%) get-style-list) basic-style)
+		    get-size)])
+       (max 7 (quotient s 2)))))
+  
+  (define (get-bullet-width)
+    (* 2 (bullet-size)))
+  
+  (define transparent-brush (send the-brush-list find-or-create-brush "WHITE" 'transparent))
+  
+  (define bullet-snip%
+    (class snip% 
+      (init-field depth)
+      (inherit set-snipclass set-count get-style)
+      (define bsize (bullet-size))
+      (define/private (zero b) (when b (set-box! b 0)))
+      [define/private get-height
+	(lambda (dc)
+	  (let ([s (get-style)])
+	    (max bsize (- (send s get-text-height dc)
+			  (send s get-text-descent dc)))))]
+      
+      [define/override get-extent
+	(lambda (dc x y wbox hbox descentbox spacebox
+		    lspacebox rspacebox)
+	  (when hbox
+	    (set-box! hbox (get-height dc)))
+	  (when wbox
+	    (set-box! wbox (* 2 bsize)))
+	  (zero descentbox)
+	  (zero spacebox)
+	  (zero rspacebox)
+	  (zero lspacebox))]
+      [define/override draw
+	(lambda (dc x y . other)
+	  (let ([y (+ y (ceiling (/ (- (get-height dc) bsize) 2)))])
+	    (let-values ([(draw solid?)
+			  (case depth
+			    [(0) (values (lambda (x y w h) (send dc draw-ellipse x y w h)) #t)]
+			    [(1) (values (lambda (x y w h) (send dc draw-ellipse x y w h)) #f)]
+			    [else (values (lambda (x y w h) (send dc draw-rectangle x y w h)) #f)])])
+	      (let ([b (send dc get-brush)])
+		(send dc set-brush
+		      (if solid?
+			  (send the-brush-list
+				find-or-create-brush
+				(send (send dc get-pen) get-color)
+				'solid)
+			  transparent-brush))
+		(draw x y bsize bsize)
+		(send dc set-brush b)))))]
+      [define/override copy
+	(lambda ()
+	  (make-object bullet-snip% depth))]
+      [define/override write
+	(lambda (stream)
+	  (send stream put depth))]
+      [define/override get-text
+	(lambda (offset num flattened?)
+	  (if (< num 1)
+	      ""
+	      (if flattened?
+		  "* "
+		  "*")))]
+      (super-new)
+      (set-snipclass bullet-snip-class)
+      (set-count 1)))
+  
+  (define bullet-snip-class
+    (make-object 
+     (class snip-class%
+       (inherit set-classname)
+       [define/override read
+	 (lambda (stream)
+	   (let ([d-box (box 0)])
+	     (send stream get d-box)
+	     (make-object bullet-snip% (unbox d-box))))]
+       (super-new)
+       (set-classname snip-class-name))))
+
+  (send (get-the-snip-class-list) add bullet-snip-class))
+
diff --git a/collects/browser/private/entity-names.ss b/collects/browser/private/entity-names.ss
new file mode 100644
index 0000000000..a1d5d82a7b
--- /dev/null
+++ b/collects/browser/private/entity-names.ss
@@ -0,0 +1,261 @@
+(module entity-names mzscheme
+  (provide entity-name->integer)
+
+  (define table 
+    #cs#hasheq((nbsp . 160)
+	       (iexcl . 161)
+	       (cent . 162)
+	       (pound . 163)
+	       (curren . 164)
+	       (yen . 165)
+	       (brvbar . 166)
+	       (sect . 167)
+	       (uml . 168)
+	       (copy . 169)
+	       (ordf . 170)
+	       (laquo . 171)
+	       (not . 172)
+	       (shy . 173)
+	       (reg . 174)
+	       (macr . 175)
+	       (deg . 176)
+	       (plusmn . 177)
+	       (sup2 . 178)
+	       (sup3 . 179)
+	       (acute . 180)
+	       (micro . 181)
+	       (para . 182)
+	       (middot . 183)
+	       (cedil . 184)
+	       (sup1 . 185)
+	       (ordm . 186)
+	       (raquo . 187)
+	       (frac14 . 188)
+	       (frac12 . 189)
+	       (frac34 . 190)
+	       (iquest . 191)
+	       (Agrave . 192)
+	       (Aacute . 193)
+	       (Acirc . 194)
+	       (Atilde . 195)
+	       (Auml . 196)
+	       (Aring . 197)
+	       (AElig . 198)
+	       (Ccedil . 199)
+	       (Egrave . 200)
+	       (Eacute . 201)
+	       (Ecirc . 202)
+	       (Euml . 203)
+	       (Igrave . 204)
+	       (Iacute . 205)
+	       (Icirc . 206)
+	       (Iuml . 207)
+	       (ETH . 208)
+	       (Ntilde . 209)
+	       (Ograve . 210)
+	       (Oacute . 211)
+	       (Ocirc . 212)
+	       (Otilde . 213)
+	       (Ouml . 214)
+	       (times . 215)
+	       (Oslash . 216)
+	       (Ugrave . 217)
+	       (Uacute . 218)
+	       (Ucirc . 219)
+	       (Uuml . 220)
+	       (Yacute . 221)
+	       (THORN . 222)
+	       (szlig . 223)
+	       (agrave . 224)
+	       (aacute . 225)
+	       (acirc . 226)
+	       (atilde . 227)
+	       (auml . 228)
+	       (aring . 229)
+	       (aelig . 230)
+	       (ccedil . 231)
+	       (egrave . 232)
+	       (eacute . 233)
+	       (ecirc . 234)
+	       (euml . 235)
+	       (igrave . 236)
+	       (iacute . 237)
+	       (icirc . 238)
+	       (iuml . 239)
+	       (eth . 240)
+	       (ntilde . 241)
+	       (ograve . 242)
+	       (oacute . 243)
+	       (ocirc . 244)
+	       (otilde . 245)
+	       (ouml . 246)
+	       (divide . 247)
+	       (oslash . 248)
+	       (ugrave . 249)
+	       (uacute . 250)
+	       (ucirc . 251)
+	       (uuml . 252)
+	       (yacute . 253)
+	       (thorn . 254)
+	       (yuml . 255)
+	       (fnof . 402)
+	       (Alpha . 913)
+	       (Beta . 914)
+	       (Gamma . 915)
+	       (Delta . 916)
+	       (Epsilon . 917)
+	       (Zeta . 918)
+	       (Eta . 919)
+	       (Theta . 920)
+	       (Iota . 921)
+	       (Kappa . 922)
+	       (Lambda . 923)
+	       (Mu . 924)
+	       (Nu . 925)
+	       (Xi . 926)
+	       (Omicron . 927)
+	       (Pi . 928)
+	       (Rho . 929)
+	       (Sigma . 931)
+	       (Tau . 932)
+	       (Upsilon . 933)
+	       (Phi . 934)
+	       (Chi . 935)
+	       (Psi . 936)
+	       (Omega . 937)
+	       (alpha . 945)
+	       (beta . 946)
+	       (gamma . 947)
+	       (delta . 948)
+	       (epsilon . 949)
+	       (zeta . 950)
+	       (eta . 951)
+	       (theta . 952)
+	       (iota . 953)
+	       (kappa . 954)
+	       (lambda . 955)
+	       (mu . 956)
+	       (nu . 957)
+	       (xi . 958)
+	       (omicron . 959)
+	       (pi . 960)
+	       (rho . 961)
+	       (sigmaf . 962)
+	       (sigma . 963)
+	       (tau . 964)
+	       (upsilon . 965)
+	       (phi . 966)
+	       (chi . 967)
+	       (psi . 968)
+	       (omega . 969)
+	       (thetasym . 977)
+	       (upsih . 978)
+	       (piv . 982)
+	       (bull . 8226)
+	       (hellip . 8230)
+	       (prime . 8242)
+	       (Prime . 8243)
+	       (oline . 8254)
+	       (frasl . 8260)
+	       (weierp . 8472)
+	       (image . 8465)
+	       (real . 8476)
+	       (trade . 8482)
+	       (alefsym . 8501)
+	       (larr . 8592)
+	       (uarr . 8593)
+	       (rarr . 8594)
+	       (darr . 8595)
+	       (harr . 8596)
+	       (crarr . 8629)
+	       (lArr . 8656)
+	       (uArr . 8657)
+	       (rArr . 8658)
+	       (dArr . 8659)
+	       (hArr . 8660)
+	       (forall . 8704)
+	       (part . 8706)
+	       (exist . 8707)
+	       (empty . 8709)
+	       (nabla . 8711)
+	       (isin . 8712)
+	       (notin . 8713)
+	       (ni . 8715)
+	       (prod . 8719)
+	       (sum . 8721)
+	       (minus . 8722)
+	       (lowast . 8727)
+	       (radic . 8730)
+	       (prop . 8733)
+	       (infin . 8734)
+	       (ang . 8736)
+	       (and . 8743)
+	       (or . 8744)
+	       (cap . 8745)
+	       (cup . 8746)
+	       (int . 8747)
+	       (there4 . 8756)
+	       (sim . 8764)
+	       (cong . 8773)
+	       (asymp . 8776)
+	       (ne . 8800)
+	       (equiv . 8801)
+	       (le . 8804)
+	       (ge . 8805)
+	       (sub . 8834)
+	       (sup . 8835)
+	       (nsub . 8836)
+	       (sube . 8838)
+	       (supe . 8839)
+	       (oplus . 8853)
+	       (otimes . 8855)
+	       (perp . 8869)
+	       (sdot . 8901)
+	       (lceil . 8968)
+	       (rceil . 8969)
+	       (lfloor . 8970)
+	       (rfloor . 8971)
+	       (lang . 9001)
+	       (rang . 9002)
+	       (loz . 9674)
+	       (spades . 9824)
+	       (clubs . 9827)
+	       (hearts . 9829)
+	       (diams . 9830)
+	       (quot . 34)
+	       (amp . 38)
+	       (lt . 60)
+	       (gt . 62)
+	       (OElig . 338)
+	       (oelig . 339)
+	       (Scaron . 352)
+	       (scaron . 353)
+	       (Yuml . 376)
+	       (circ . 710)
+	       (tilde . 732)
+	       (ensp . 8194)
+	       (emsp . 8195)
+	       (thinsp . 8201)
+	       (zwnj . 8204)
+	       (zwj . 8205)
+	       (lrm . 8206)
+	       (rlm . 8207)
+	       (ndash . 8211)
+	       (mdash . 8212)
+	       (lsquo . 8216)
+	       (rsquo . 8217)
+	       (sbquo . 8218)
+	       (ldquo . 8220)
+	       (rdquo . 8221)
+	       (bdquo . 8222)
+	       (dagger . 8224)
+	       (Dagger . 8225)
+	       (permil . 8240)
+	       (lsaquo . 8249)
+	       (rsaquo . 8250)
+	       (euro . 8364)))
+
+  (define (entity-name->integer s)
+    (hash-table-get table s (lambda () #f))))
+
+
diff --git a/collects/browser/private/html.ss b/collects/browser/private/html.ss
new file mode 100644
index 0000000000..1329b96d89
--- /dev/null
+++ b/collects/browser/private/html.ss
@@ -0,0 +1,1259 @@
+
+(module html mzscheme
+  (require (lib "unitsig.ss")
+           "sig.ss"
+           (lib "mred-sig.ss" "mred")
+           (lib "file.ss")
+           (lib "etc.ss")
+           (lib "list.ss")
+           (lib "string.ss")
+           (lib "port.ss")
+           (lib "url-sig.ss" "net")
+	   (rename (lib "html.ss" "html") read-html-as-xml read-html-as-xml)
+	   (rename (lib "html.ss" "html") read-html-comments read-html-comments)
+	   (rename (lib "html.ss" "html") use-html-spec use-html-spec)
+	   (all-except (lib "xml.ss" "xml") read-comments)
+           (lib "class.ss")
+	   "bullet.ss"
+	   "option-snip.ss"
+	   "entity-names.ss")
+
+  (provide html@)
+
+  (define html@
+    (unit/sig html^
+      (import mred^
+              net:url^)
+      
+      ;; CACHE
+      (define NUM-CACHED 10)
+      (define cached (make-vector 10 'no-image))
+      (define cached-name (make-vector 10 #f)) ; string or #f
+      (define cached-use (make-vector 10 0))
+      
+      (define html-status-handler
+        (make-parameter
+         void
+         (lambda (f)
+           (unless (and (procedure? f)
+                        (procedure-arity-includes? f 1))
+             (raise-type-error 'html-status-handler
+                               "procedure of arity 1"
+                               f))
+           f)))
+      
+      (define (status . args)
+        ((html-status-handler) (apply format args)))
+      
+      (define status-stack (make-parameter null))
+      
+      ;; load-status : boolean string (union #f url) -> void
+      (define (load-status push? what url)
+        (let ([s (format "Loading ~a ~a..." 
+                         what 
+                         (if url
+                             (trim 150 (url->string url))
+                             "unknown url"))])
+          (status-stack (cons s (if push? (status-stack) null)))
+          (status "~a" s)))
+      
+      (define (pop-status)
+        (status-stack (cdr (status-stack)))
+        (status "~a" (car (status-stack))))
+      (define (trim len s)
+        (if ((string-length s) . <= . len)
+            s
+            (string-append (substring s 0 (- len 4)) " ...")))
+
+      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;
+      ;; Imap maps
+      ;;
+
+      (define-struct image-map-rect (href left top right bottom))
+      
+      (define finger-cursor (make-object cursor% 'arrow))
+      
+      (define image-map-snip%
+        (class image-snip%
+          
+          (init-field html-text)
+          
+          (field [key "#key"])
+          (define/public (set-key k) (set! key k))
+          (define/public (get-key) key)
+          
+          (field [rects null])
+          
+          (define/public (set-rects rs) (set! rects rs))
+          
+          (inherit get-admin)
+          
+          (define/private (find-rect x y)
+            (let loop ([rects rects])
+              (cond
+                [(null? rects) #f]
+                [else
+                 (let ([rect (car rects)])
+                   (if (and (<= (image-map-rect-left rect) x (image-map-rect-right rect))
+                            (<= (image-map-rect-top rect) y (image-map-rect-bottom rect)))
+                       rect
+                       (loop (cdr rects))))])))
+          
+          ;; add-area : string (listof number) string -> void
+          ;; currently only supports rect shapes
+          (define/public (add-area shape coords href)
+            (when (and (equal? shape "rect")
+                       (= 4 (length coords)))
+              (let ([x1 (car coords)]
+                    [y1 (cadr coords)]
+                    [x2 (caddr coords)]
+                    [y2 (cadddr coords)])
+                (set! rects (cons (make-image-map-rect
+                                   href
+                                   (min x1 x2)
+                                   (min y1 y2)
+                                   (max x1 x2)
+                                   (max y1 y2))
+                                  rects)))))
+          
+          (define/override (on-event dc x y editor-x editor-y evt)
+            (when (send evt button-up?)
+              (let* ([snipx (- (send evt get-x) x)]
+                     [snipy (- (send evt get-y) y)]
+                     [rect (find-rect snipx snipy)])
+                (when rect
+                  (send html-text post-url (image-map-rect-href rect)))))
+            (super on-event dc x y editor-x editor-y evt))
+          
+          (define/override (adjust-cursor dc x y editor-x editor-y evt)
+            (let ([snipx (- (send evt get-x) x)]
+                  [snipy (- (send evt get-y) y)])
+              (if (find-rect snipx snipy)
+                  finger-cursor
+                  #f)))
+
+          ;; warning: buggy. This doesn't actually copy the bitmap
+          ;; over because there's no get-bitmap method for image-snip%
+          ;; at the time of this writing.
+          (define/override (copy)
+            (let ([cp (new image-map-snip% (html-text html-text))])
+              (send cp set-key key)
+              (send cp set-rects rects)))
+          
+          (super-make-object)
+          
+          (inherit set-flags get-flags)
+          (set-flags (cons 'handles-events (get-flags)))))
+      
+      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;
+      ;; Hardwired Scheme colorization; should come from a .css file
+      ;;
+
+      (define (make-scheme-color-delta col)
+	(let ([d (make-object style-delta%)])
+	  (send d set-delta-foreground col)
+	  d))
+
+      (define scheme-code-delta (make-scheme-color-delta "brown"))
+      (define scheme-code-delta/keyword
+	(let ([d (make-scheme-color-delta (make-object color% #x99 0 0))])
+          (send d set-weight-on 'bold)
+	  d))
+      (define scheme-code-delta/variable (make-scheme-color-delta "navy"))
+      (define scheme-code-delta/global (make-scheme-color-delta "purple"))
+      (define scheme-code-delta/selfeval (make-scheme-color-delta "forest green"))
+      (define scheme-code-delta/comment (make-scheme-color-delta "cornflower blue"))
+      (define navigation-delta (let ([d (make-scheme-color-delta "red")])
+				 (send d set-style-on 'italic)
+				 d))
+
+      (define current-style-class (make-parameter null))
+
+      (define (lookup-class-delta class)
+	(let ([class-path (cons class (current-style-class))])
+	  (cond
+	   [(sub-path? class-path '("scheme")) scheme-code-delta]
+	   [(sub-path? class-path '("keyword" "scheme")) scheme-code-delta/keyword]
+	   [(sub-path? class-path '("variable" "scheme")) scheme-code-delta/variable]
+	   [(sub-path? class-path '("global" "scheme")) scheme-code-delta/global]
+	   [(or (sub-path? class-path '("selfeval" "scheme"))
+		(sub-path? class-path '("schemeresponse"))) scheme-code-delta/selfeval]
+	   [(sub-path? class-path '("comment" "scheme")) scheme-code-delta/comment]
+	   [(sub-path? class-path '("navigation")) navigation-delta]
+	   [else #f])))
+
+      (define (sub-path? a b)
+	(cond
+	 [(null? b) #t]
+	 [(null? a) #f]
+	 [else (and (equal? (car a) (car b))
+		    (sub-path? (cdr a) (cdr b)))]))
+
+      (define (with-style-class class thunk)
+	(if class
+	    (parameterize ([current-style-class (cons class (current-style-class))])
+	      (thunk))
+	    (thunk)))
+
+      (define (lookup-span-class-delta class) (lookup-class-delta class))
+
+      (define re:hexcolor 
+	(regexp "^#([0-9a-fA-F][0-9a-fA-F])([0-9a-fA-F][0-9a-fA-F])([0-9a-fA-F][0-9a-fA-F])$"))
+      
+      (define color-string->color
+	(lambda (str)
+	  (let ([m (regexp-match re:hexcolor str)])
+	    (if m
+		(make-object color%
+			     (string->number (cadr m) 16)
+			     (string->number (caddr m) 16)
+			     (string->number (cadddr m) 16))
+		(send the-color-database find-color str)))))
+
+      (define html-eval-ok (make-parameter #t))
+      (define html-img-ok (make-parameter #t))
+      
+      (define (get-bitmap-from-url url)
+        (if (html-img-ok)
+            (let ([tmp-filename (make-temporary-file "mredimg~a")])
+              (load-status #t "image" url)
+              (call-with-output-file* tmp-filename
+                                      (lambda (op)
+                                        (with-handlers ([exn:fail? 
+                                                         (lambda (x)
+                                                           (printf "exn.9 ~s\n" (and (exn? x)
+                                                                                     (exn-message x)))
+                                                           (void))])
+                                          (call/input-url 
+                                           url
+                                           get-pure-port
+                                           (lambda (ip)
+                                             (copy-port ip op)))))
+                                      'truncate)
+              (pop-status)
+              (let* ([upath (url-path url)]
+                     [bitmap (make-object bitmap% tmp-filename)])
+                (with-handlers ([exn:fail?
+                                 (lambda (x)
+                                   (message-box "Warning"
+                                                (format "Could not delete file ~s~n~n~a"
+                                                        tmp-filename
+                                                        (if (exn? x)
+                                                            (exn-message x)
+                                                            x))))])
+                  (delete-file tmp-filename))
+                (if (send bitmap ok?)
+                    bitmap
+                    #f)))
+            #f))
+      
+      ;; cache-bitmap : string -> (is-a?/c bitmap%)
+      (define (cache-bitmap url)
+        (let ([url-string (url->string url)])
+          (let loop ([n 0])
+            (cond
+              [(= n NUM-CACHED)
+               ;; Look for item to uncache
+               (vector-set! cached-use 0 (max 0 (sub1 (vector-ref cached-use 0))))
+               (let ([m (let loop ([n 1][m (vector-ref cached-use 0)])
+                          (if (= n NUM-CACHED)
+                              m
+                              (begin
+                                (vector-set! cached-use n (max 0 (sub1 (vector-ref cached-use n))))
+                                (loop (add1 n) (min m (vector-ref cached-use n))))))])
+                 (let loop ([n 0])
+                   (if (= (vector-ref cached-use n) m)
+                       (let ([bitmap (get-bitmap-from-url url)])
+                         (cond
+                           [bitmap
+                            (vector-set! cached n bitmap)
+                            (vector-set! cached-name n url-string)
+                            (vector-set! cached-use n 5)
+                            bitmap]
+                           [else #f]))
+                       (loop (add1 n)))))]
+              [(equal? url-string (vector-ref cached-name n))
+               (vector-set! cached-use n (min 10 (add1 (vector-ref cached-use n))))
+               (vector-ref cached n)]
+              [else
+               (loop (add1 n))]))))
+
+      (define (update-image-maps image-map-snips image-maps)
+        (for-each
+         (lambda (image-map-snip)
+           (let ([image-map-key (send image-map-snip get-key)])
+             (let loop ([image-maps image-maps])
+               (cond
+                 [(null? image-maps) (void)]
+                 [else
+                  (let* ([image-map (car image-maps)]
+                         [name (get-field image-map 'name)])
+                    (if (and name 
+                             (equal? (format "#~a" name)
+                                     (send image-map-snip get-key)))
+                        (find/add-areas image-map-snip image-map)
+                        (loop (cdr image-maps))))]))))
+         image-map-snips))
+      
+      (define (find/add-areas image-map-snip image-map)
+        (let loop ([sexp image-map])
+          (cond
+            [(and (pair? sexp)
+                  (eq? (car sexp) 'area)
+                  (pair? (cdr sexp)))
+             (add-area image-map-snip (cadr sexp))
+             (loop (cddr sexp))]
+            [(pair? sexp)
+             (loop (car sexp))
+             (loop (cdr sexp))]
+            [else (void)])))
+      
+      ;; add-area : snip (listof (list sym string))[assoc] -> void
+      ;; the second arg type is actually `any', but if it
+      ;; matches the above, it is interprted propoerly;
+      ;; otherwise silently nothing happens.
+      (define (add-area image-map-snip sexp)
+        (let ([shape #f]
+              [coords #f]
+              [href #f])
+          (let loop ([sexp sexp])
+            (cond
+              [(pair? sexp)
+               (let ([fst (car sexp)])
+                 (when (and (pair? fst)
+                            (symbol? (car fst))
+                            (pair? (cdr fst))
+                            (string? (cadr fst)))
+                   (case (car fst)
+                     [(shape) (set! shape (cadr fst))]
+                     [(coords) (set! coords (cadr fst))]
+                     [(href) (set! href (cadr fst))]
+                     [else (void)]))
+                 (loop (cdr sexp)))]
+              [else (void)]))
+          (when (and shape coords href)
+            (let ([p-coords (parse-coords coords)])
+              (when p-coords
+                (send image-map-snip add-area shape p-coords href))))))
+      
+      ;; parse-coords : string -> (listof number)
+      ;; separates out a bunch of comma separated numbers in a string
+      ;; into a list of scheme numbers
+      (define (parse-coords str)
+        (let loop ([str str])
+          (cond
+            [(regexp-match #rx"^[ \t\n]*([0-9]+)[ \t\n]*,(.*)$" str)
+             =>
+             (lambda (m)
+               (let ([num (cadr m)]
+                     [rst (caddr m)])
+                 (cons (string->number num)
+                       (loop rst))))]
+            [(regexp-match #rx"^[ \t\n]*([0-9]+)[ \t\n]*" str)
+             =>
+             (lambda (m)
+               (list (string->number (cadr m))))]
+            [else null])))
+      
+      (define (make-get-field str)
+        (let ([s (apply
+                  string-append
+                  (map
+                   (lambda (c)
+                     (format "[~a~a]"
+                             (char-upcase c)
+                             (char-downcase c)))
+                   (string->list str)))]
+              [spc (string #\space #\tab #\newline #\return #\vtab)])
+          (let ([re:plain (regexp (format "(^|[~a])~a[~a]*=[~a]*([^~a]*)" spc s spc spc spc))]
+                [re:quote (regexp (format "(^|[~a])~a[~a]*=[~a]*\"([^\"]*)\"" spc s spc spc))])
+            (lambda (args)
+              (let ([m (or (regexp-match re:quote args)
+                           (regexp-match re:plain args))])
+                (and m (caddr m)))))))
+      
+      (define (get-field e name)
+        (let ([a (assq name (cadr e))])
+          (and a (cadr a))))
+      
+      (define get-mzscheme-arg
+	(let ([get-mz (make-get-field "mzscheme")])
+	  (lambda (str)
+	    (let ([v (get-mz str)])
+	      (and v (filter-mzscheme v))))))
+
+      (define filter-mzscheme 
+	(lambda (v)
+	  (regexp-replace* "[|]" v "\"")))
+		      		       
+      (define face-list #f)
+
+      (define default-font (make-object font% 12 'default))
+      
+      (define re:quot (regexp "[&][qQ][uU][oO][tT][;]"))
+      (define re:amp (regexp "[&][aA][mM][pP][;]"))
+
+      (define re:empty (regexp (format "^[ ~c]*$" (integer->char 160))))
+
+      (define-struct form (action target method parts active-select))
+      (define (protect-chars s)
+        (apply string-append 
+               (map (lambda (c)
+                      (if (or (char-alphabetic? c)
+                              (char-numeric? c))
+                          (string c)
+                          (format "%~a"
+                                  (let ([s (format "0~x" (or (char->integer c) 65))])
+                                    (substring s (- (string-length s) 2) (string-length s))))))
+                      (string->list s))))
+      
+      (define re:true (regexp-quote "true" #f))
+      (define (true? s) (regexp-match re:true s))
+
+      (define verbatim-tags '(listing xmp plaintext))
+      (define preformatted-tags '(pre))
+      (define exact-whitespace-tags (append verbatim-tags
+					    preformatted-tags))
+      (define comment-tags '(script))
+      (define atomic-tags '(p br hr li dd dt img html meta link input))
+      (define enum-tags '(ul dl ol menu))
+
+      (define space-eating-tags '(title p div center br h1 h2 h3 h4
+					li dt dd
+					ul ol dl menu
+					samp kbd pre blockquote
+					table tr td))
+
+      (define whitespace-string "[ \t\n\r\v\f]+")
+      (define re:whitespace (regexp whitespace-string))
+      (define re:starting-whitespace (regexp (format "^~a" whitespace-string)))
+      (define re:ending-whitespace (regexp (format "~a$" whitespace-string)))
+      (define re:leading-newline (regexp "^(\r|\n|(\r\n))"))
+      
+      (define (remove-leading-newline c)
+	(cond
+	 [(string? c)
+	  (let ([s (regexp-match-positions re:leading-newline c)])
+	    (cond
+	     [(and s (= (cdar s) (length s)))
+	      ;; It's all newline:
+	      (values "" #t)]
+	     [s (values (substring c (cdar s) (string-length c)) #t)]
+	     [else (values c #t)]))]
+	 [(pair? c)
+	  (let loop ([b (cddr c)][accum null])
+	    (if (null? b)
+		(values (list* (car c) (cadr c) (reverse accum)) #f)
+		(let-values ([(d done?) (remove-leading-newline (car b))])
+		  (if done?
+		      (values (list* (car c) (cadr c) (append (reverse accum)
+							      (list d)
+							      (cdr b)))
+			      #t)
+		      (loop (cdr b) (cons d accum))))))]
+	 [else (values c #f)]))
+
+      (define (fixup-whitespace c leading-ok?)
+        (cond
+          [(string? c)
+           (let ([s (regexp-match-positions re:starting-whitespace c)]
+                 [e (regexp-match-positions re:ending-whitespace c)])
+             (if (and s e
+                      (= (caar s) (caar e)))
+                 ;; It's all whitespace:
+                 (if leading-ok?
+                     (values " " #f)
+                     (values "" #f))
+                 ;; Normal case:
+                 (values
+                  (string-append
+                   (if (and s leading-ok?) " " "")
+                   (regexp-replace* re:whitespace
+                                    (substring c 
+                                               (if s
+                                                   (cdar s)
+                                                   0)
+                                               (if e
+                                                   (caar e)
+                                                   (string-length c)))
+                                    " ")
+                   (if e " " ""))
+                  (not e))))]
+          [(symbol? c) (values c #t)]
+          [(number? c) (values c #t)]
+          [(comment? c)
+           (let ([code (get-mzscheme-arg (comment-text c))])
+             (if code
+                 (let ([s (with-handlers ([exn:fail?
+                                           (lambda (exn)
+                                             (format
+                                              "<font color=\"red\">Error during &lt;!-- MZSCHEME=... --&gt;: <i>~a</i></font>"
+                                              (if (exn? exn)
+                                                  (exn-message exn)
+                                                  (format "~s" exn))))])
+                            (if (html-eval-ok)
+                                (eval (read (open-input-string code)))
+                                (error "disabled")))])
+                   (if (string? s)
+                       (let ([content (read-html (open-input-string s))])
+                         (fixup-whitespace content leading-ok?))
+                       (values "" leading-ok?)))
+                 (values "" leading-ok?)))]
+         [(pi? c) (values "" leading-ok?)] ;; processing instruction
+	 [else (let ([tag (car c)])
+		 (if (memq tag exact-whitespace-tags)
+		     (let-values ([(s done?) (remove-leading-newline c)])
+		       (values s #f))
+		     (let-values ([(body leading-ok?)
+				   (let loop ([l (cddr c)][leading-ok? 
+							   (and leading-ok?
+								(not (memq tag space-eating-tags)))])
+				     (if (null? l)
+					 (values null leading-ok?)
+					 (let*-values ([(f l-ok?)
+							(fixup-whitespace (car l) leading-ok?)]
+						       [(r l-ok?)
+							(loop (cdr l) l-ok?)])
+					   (values (cons f r) l-ok?))))])
+		       (values
+			(list*
+			 tag
+			 (cadr c) ; attributes
+			 body)
+			(and leading-ok?
+			     (not (memq tag space-eating-tags)))))))]))
+
+      (define (read-html a-port)
+        (let* ([xml (parameterize ([read-html-comments #t]
+                                   [use-html-spec #f])
+                      (read-html-as-xml a-port))]
+               [xexpr `(html () ,@(map xml->xexpr xml))])
+          xexpr))
+          
+      (define (parse-html a-port)
+        (let ([raw (read-html a-port)])
+          (let-values ([(v ?) (fixup-whitespace raw #f)])
+            v)))
+
+      (define html-convert
+        (lambda (a-port a-text)	    
+          (let ([content (parse-html a-port)])
+            (with-method ([a-text-insert (a-text insert)]
+                          [current-pos (a-text last-position)]
+                          [delete (a-text delete)]
+                          [get-character (a-text get-character)]
+                          [change-style (a-text change-style)])
+              (letrec ([image-map-snips null]
+                       [image-maps null]
+                       
+                       [insert 
+                        (lambda (what)
+                          (a-text-insert what (current-pos)))]
+                       
+                       [insert-newlines
+                        (lambda (num forced-lines para-base)
+                          (let ([num (max num forced-lines)])
+                            (unless (zero? num)
+                              (let loop ([pos (current-pos)][num num])
+                                (unless (or (zero? num) (<= pos para-base))
+                                  (let ([c (get-character (sub1 pos))])
+                                    (if (eq? c #\newline)
+                                        (loop (sub1 pos) (sub1 num))
+                                        (insert (make-string num #\newline)))))))))]
+                       
+                       [backover-newlines
+                        (lambda (pos base)
+                          (if (= pos base)
+                              base
+                              (let ([c (get-character (sub1 pos))])
+                                (if (eq? c #\newline)
+                                    (backover-newlines (sub1 pos) base)
+                                    pos))))]
+                       
+                       [whitespaces (string #\space #\tab #\newline #\return)]
+                       
+                       [delta:fixed (make-object style-delta% 'change-family 'modern)]
+                       [delta:default-face (make-object style-delta% 'change-family 'default)]
+                       [delta:bold (make-object style-delta% 'change-bold)] 
+                       [delta:underline (make-object style-delta% 'change-underline #t)]
+                       [delta:italic (make-object style-delta% 'change-italic)]
+                       [delta:h1 (let ([d (make-object style-delta% 'change-bold)])
+                                   (send d set-size-mult 2.0)
+                                   d)]
+                       [delta:h2 (let ([d (make-object style-delta% 'change-bold)])
+                                   (send d set-size-mult 1.5)
+                                   d)]
+                       [delta:h3 (let ([d (make-object style-delta% 'change-bold)])
+                                   (send d set-size-mult 1.2)
+                                   d)]
+                       [delta:h4 (make-object style-delta% 'change-bold)]
+                       [delta:subscript (let ([d (make-object style-delta%)])
+                                          (send d set-alignment-on 'bottom)
+                                          (send d set-size-mult 0.8)
+                                          d)]
+                       [delta:superscript (let ([d (make-object style-delta%)])
+                                            (send d set-alignment-on 'top)
+                                            (send d set-size-mult 0.8)
+                                            d)]
+                       [delta:small (let ([d (make-object style-delta%)])
+                                      (send d set-size-mult 0.75)
+                                      d)]
+                       
+                       [delta:center (make-object style-delta% 'change-alignment 'center)]
+                       [delta:symbol (make-object style-delta% 'change-family 'symbol)]
+                       
+                       [html-error
+                        (lambda args
+                          (when #f ; treat them all as ignored warnings
+                            (apply error 'html args)))]
+                       
+                       [re:transparent #rx"[Tt][Rr][Aa][Nn][Ss][Pp][Aa][Rr][Ee][Nn][Tt]"]
+                       
+                       [parse-image-source
+                        (lambda (s)
+                          (let ([src (get-field s 'src)]
+                                [base-url (send a-text get-url)])
+                            (and src
+                                 (with-handlers ([exn:fail? (lambda (x) #f)])
+                                   (if base-url
+                                       (combine-url/relative base-url src)
+                                       (string->url src))))))]
+                       
+                       [unescape 
+                        (lambda (s)
+                          (apply string-append 
+                                 (map (lambda (x)
+                                        (if (pcdata? x)
+                                            (pcdata-string x)
+                                            ""))
+                                      (read-html-as-xml 
+                                       (open-input-string s)))))]
+                       [parse-href
+                        (let ([href-error
+                               (lambda (s)
+                                 (html-error "bad reference in ~s" s))])
+                          (lambda (s)
+                            (let* ([url-string
+                                    (cond 
+                                      [(get-field s 'href)
+                                       => (lambda (str)
+                                            (if (string=? str "")
+                                                (begin (href-error s)
+                                                       #f)
+                                                (unescape str)))]
+                                      [else #f])]
+                                   [label (get-field s 'name)]
+                                   [scheme (let ([v (get-field s 'mzscheme)])
+                                             (and v (filter-mzscheme v)))])
+                              (values url-string label scheme))))]
+                       
+                       [parse-font
+                        (let ([face-regexp (regexp "([^,]*), *(.*)")])
+                          (lambda (args)
+                            (let ([size-string (get-field args 'size)]
+                                  [face-string (get-field args 'face)]
+                                  [color-string (get-field args 'color)]
+                                  [bg-color-string (get-field args 'bgcolor)])
+                              (let ([size
+                                     (and size-string
+                                          (let* ([n (string->number size-string)])
+                                            (and n
+                                                 (integer? n)
+                                                 (<= -127 n 127)
+                                                 (cond
+                                                   [(char=? #\+ (string-ref size-string 0))
+                                                    (make-object style-delta% 'change-bigger n)]
+                                                   [(negative? n)
+                                                    (make-object style-delta% 'change-smaller (- n))]
+                                                   [else
+                                                    (cond
+                                                      [(n . < . 2)
+                                                       (make-object style-delta% 'change-smaller (- 2 n))]
+                                                      [(n . > . 2)
+                                                       (make-object style-delta% 'change-bigger (- n 2))]
+                                                      [else #f])]))))]
+                                    [face (and face-string
+                                               (or
+                                                (and (string=? face-string "monospace")
+                                                     (make-object style-delta% 'change-family 'modern))
+                                                (let ([f (let loop ([f face-string])
+                                                           (let ([m (regexp-match face-regexp f)]
+                                                                 [try-face (lambda (s)
+                                                                             (unless face-list
+                                                                               (set! face-list (get-face-list)))
+                                                                             (ormap
+                                                                              (lambda (s-norm)
+                                                                                (and (string-ci=? s s-norm)
+                                                                                     s-norm))
+                                                                              face-list))])
+                                                             (if m
+                                                                 (or (try-face (cadr m))
+                                                                     (loop (caddr m)))
+                                                                 (try-face f))))])
+                                                  (and f
+                                                       (let ([d (make-object style-delta%)])
+                                                         (send d set-delta-face f))))))]
+                                    [color (let ([clr (and color-string (color-string->color color-string))])
+                                             (and clr
+                                                  (let ([d (make-object style-delta%)])
+                                                    (send d set-delta-foreground clr))))]
+                                    [bg-color (let ([bg-clr (and bg-color-string
+                                                                 (color-string->color bg-color-string))])
+                                                (and bg-clr
+                                                     (let ([d (make-object style-delta%)])
+                                                       (send d set-delta-background bg-clr))))])
+                                (let loop ([delta #f][l (list size face color bg-color)])
+                                  (cond
+                                    [(null? l) delta]
+                                    [(not (car l)) (loop delta (cdr l))]
+                                    [else (if delta
+                                              (loop (begin
+                                                      (send delta collapse (car l))
+                                                      delta)
+                                                    (cdr l))
+                                              (loop (car l) (cdr l)))]))))))]
+                       
+                       [make-unsupported
+                        (lambda (tag args)
+                          (let ([name (get-field args 'name)]
+                                [type (get-field args 'type)])
+                            (if (and (eq? tag 'input) type (string=? type "hidden"))
+                                "" ; hidden input
+                                (format "[~a~a NOT SUPPORTED]"
+                                        (if name
+                                            (format "~a " name)
+                                            "")
+                                        (case tag
+                                          [(select) "POPUP MENU"]
+                                          [(textarea) "TEXT AREA"]
+                                          [(input) (if type
+                                                       (case (string->symbol type)
+                                                         [(text) "TEXT FIELD"]
+                                                         [else "BUTTON"])
+                                                       "BUTTON")])))))]
+                       
+                       [heading (lambda (delta forced-lines rest para-base)
+                                  (insert-newlines 2 forced-lines para-base)
+                                  (let-values ([(start-pos) (current-pos)]
+                                               [(r rfl) (rest)]
+                                               [(end-pos) (current-pos)])
+                                    (insert-newlines 2 rfl para-base)
+                                    (values
+                                     (lambda ()
+                                       (change-style delta start-pos end-pos)
+                                       (r))
+                                     rfl)))]
+                       
+                       [styler (opt-lambda (delta rest [drop-empty? #f])
+                                 (let*-values ([(start-pos) (current-pos)]
+                                               [(r rfl) (rest)]
+                                               [(end-pos) (current-pos)])
+                                   (if (and drop-empty?
+                                            (regexp-match re:empty (send a-text get-text start-pos end-pos)))
+                                       (begin
+                                         (delete start-pos end-pos)
+                                         (values void rfl))
+                                       (values
+                                        (lambda ()
+                                          (change-style delta start-pos end-pos)
+                                          (r))
+                                        rfl))))]
+                       
+                       [maybe-bg-color (lambda (e rest drop-empty?)
+                                         (let* ([c (get-field e 'bgcolor)]
+                                                [color (and c (color-string->color c))])
+                                           (cond
+                                             [color
+                                              (styler (let ([d (make-object style-delta%)])
+                                                        (send d set-delta-background color)
+                                                        d)
+                                                      rest
+                                                      drop-empty?)]
+                                             [drop-empty?
+                                              (let*-values ([(start-pos) (current-pos)]
+                                                            [(r rfl) (rest)]
+                                                            [(end-pos) (current-pos)])
+                                                (values (if (regexp-match re:empty (send a-text get-text start-pos end-pos))
+                                                            void
+                                                            r)
+                                                        rfl))]
+                                             [else
+                                              (rest)])))]
+                       
+                       [para-aligner (lambda (alignment delta rest)
+                                       (let*-values ([(start-pos) (current-pos)]
+                                                     [(r rfl) (rest)]
+                                                     [(end-pos) (current-pos)])
+                                         (values
+                                          (lambda ()
+                                            (let ([last-para (send a-text position-paragraph 
+                                                                   (backover-newlines end-pos start-pos))])
+                                              (let loop ([para (send a-text position-paragraph start-pos)])
+                                                (if (eq? alignment 'left-outdent)
+                                                    (begin
+                                                      (send a-text set-paragraph-alignment para 'left)
+                                                      (send a-text set-paragraph-margins para 0 (* 2 (get-bullet-width)) 0))
+                                                    (send a-text set-paragraph-alignment para alignment))
+                                                (when delta
+                                                  (change-style delta start-pos end-pos))
+                                                (unless (= para last-para)
+                                                  (loop (add1 para)))))
+                                            (r))
+                                          rfl)))]
+                       
+                       ;; translate-number : number -> void
+                       [translate-number
+                        (lambda (e)
+                          (cond
+                            [(and (not (= e #xFFFF))
+                                  (not (= e #xFFFE))
+                                  (not (<= #xD800 e #xDFFF))
+                                  (send default-font screen-glyph-exists? (integer->char e)))
+                             ;; The call to `string' here should be removed. It
+                             ;; was here to avoid a v299.6 bug.
+                             (insert (string (integer->char e)))
+                             void]
+                            [(<= 913 e 969)
+                             (let ([lp (current-pos)])
+                               (insert (string (integer->char (+ (- e 913) (char->integer #\A)))))
+                               (lambda ()
+                                 (change-style delta:symbol lp (+ lp 1))))]
+                            
+                            ;; poor ascii approximations. probably these
+                            ;; (and other) characters exist somewhere,
+                            ;; but I don't know where.
+                            [(= e 160) (insert " ") void]
+                            [(= e 338) (insert "OE") void]
+                            [(= e 339) (insert "oe") void]
+                            [(= e 732) (insert "~") void]
+                            [(= e 710) (insert "^") void]
+                            [(= e 8242) (insert "'") void]
+                            [(= e 8243) (insert "''") void]
+                            [(= e 8260) (insert "/") void]
+                            [(= e 8722) (insert "-") void]
+                            [(= e 8727) (insert "*") void]
+                            [(= e 8764) (insert "~") void]
+                            [(= e 8804) (insert "<") void]
+                            [(= e 8805) (insert ">") void]
+                            [(= e 8211) (insert "--") void]
+                            [(= e 8212) (insert "---") void]
+                            
+                            [else (insert (format "&#~a;" e))
+                                  void]))]
+                       
+                       ;; ========================================
+                       ;; This is the main formatting function.
+                       ;; It consumes:
+                       ;;   e : xexpr - the HTML content
+                       ;;   para-base : num - a marker for a paragraph start (e.g.,
+                       ;;                     the bullet for <li>), though the actual
+                       ;;                     paragraph start may be later
+                       ;;   enum-depth : num - current depth of enumerations
+                       ;; The result is a function of no arguments that finalizes
+                       ;;  the region for `e', which normally means applying font changes.
+                       ;;  (The changes have to be applied outside-in, so that local
+                       ;;  specifications override enclosing ones.)
+                       ;; Translate must not modify any existing text, and the
+                       ;;  result function must not move any items.
+                       [translate
+                        (lambda (e para-base enum-depth forced-lines form)
+                          (cond
+                            [(string? e) 
+                             (let ([lp (current-pos)])
+                               (insert e)
+                               ;; we change the style here directly
+                               ;; since we want this style to only appear
+                               ;; if the style is overridden by the context
+                               (change-style delta:default-face 
+                                             lp
+                                             (+ lp (string-length e)))
+                               (values void
+                                       0))]
+                            [(symbol? e) 
+                             (let ([a (entity-name->integer e)])
+                               (if a
+                                   (values (translate-number a) 0)
+                                   (begin
+                                     (insert (format "&~a;" e))
+                                     (values void 0))))]
+                            [(number? e) 
+                             (values (translate-number e) 0)]
+                            [(or (comment? e) (pi? e)) (values void forced-lines)]
+                            [else (let* ([tag (car e)]
+                                         [rest/base/depth/form/fl
+                                          (lambda (para-base enum-depth form forced-lines)
+                                            (let* ([p (foldl (lambda (x p) 
+                                                               (let-values ([(f fl) (translate x para-base enum-depth (car p) form)])
+                                                                 (cons fl (cons f (cdr p)))))
+                                                             (cons forced-lines null)
+                                                             (cddr e))]
+                                                   [l (reverse! (cdr p))])
+                                              (values (lambda ()
+                                                        (map (lambda (f) (f)) l))
+                                                      (car p))))]
+                                         [rest/base/depth
+                                          (lambda (para-base enum-depth)
+                                            (rest/base/depth/form/fl para-base enum-depth form forced-lines))]
+                                         [rest/form (lambda (form) (rest/base/depth/form/fl para-base enum-depth form forced-lines))]
+                                         [rest/form (lambda (form) (rest/base/depth/form/fl para-base enum-depth form forced-lines))]
+                                         [rest (lambda () (rest/base/depth/form/fl para-base enum-depth form forced-lines))]
+                                         [rest/fl (lambda (fl) (rest/base/depth/form/fl para-base enum-depth form fl))])
+                                    (case tag
+                                      [(title)
+                                       (let ([pos (current-pos)])
+                                         ;; Render content
+                                         (rest)
+                                         (send a-text set-title (send a-text get-text pos (current-pos)))
+                                         (delete pos (current-pos)))
+                                       (values void forced-lines)]
+                                      [(a)
+                                       (let-values ([(url-string label scheme) (parse-href e)])
+                                         (let* ([style (get-field e 'style)]
+                                                [pos (current-pos)])
+                                           (let-values ([(r rfl) (rest)])
+                                             (let ([end-pos (current-pos)])
+                                               (cond
+                                                 [url-string
+                                                  (send a-text add-link pos end-pos (regexp-replace* re:amp url-string "\\&"))
+                                                  ;; might have a label, too:
+                                                  (when label
+                                                    (send a-text add-tag label pos))
+                                                  (values
+                                                   (lambda ()
+                                                     (when (or (not style)
+                                                               (not (regexp-match re:transparent style)))
+                                                       (send a-text make-link-style pos end-pos))
+                                                     (r))
+                                                   rfl)]
+                                                 [label
+                                                  (send a-text add-tag label pos)
+                                                  (values r rfl)]
+                                                 [scheme
+                                                  (send a-text add-scheme-callback pos end-pos scheme)
+                                                  (values
+                                                   (lambda ()
+                                                     (when (or (not style)
+                                                               (not (regexp-match re:transparent style)))
+                                                       (send a-text make-link-style pos end-pos))
+                                                     (r))
+                                                   rfl)]
+                                                 [else (values r rfl)])))))]
+                                      [(style) (values void forced-lines)]
+                                      [(h1) (heading delta:h1 forced-lines rest para-base)]
+                                      [(h2) (heading delta:h2 forced-lines rest para-base)]
+                                      [(h3) (heading delta:h3 forced-lines rest para-base)]
+                                      [(h4) (heading delta:h4 forced-lines rest para-base)]
+                                      [(b strong) (styler delta:bold rest)]
+                                      [(i em var dfn cite) (styler delta:italic rest)]
+                                      [(u) (styler delta:underline rest)]
+                                      [(sup) (styler delta:superscript rest)]
+                                      [(sub) (styler delta:subscript rest)]
+                                      [(small) (styler delta:small rest)]
+                                      [(font)
+                                       (let ([delta (parse-font e)])
+                                         (if delta
+                                             (styler delta rest)
+                                             (rest)))]
+                                      [(li dd dt)
+                                       (insert-newlines 1 forced-lines para-base)
+                                       (let ([pos (current-pos)]
+                                             [bullet? (eq? tag 'li)])
+                                         (when bullet?
+                                           (let ([before (current-pos)])
+                                             (insert (make-object bullet-snip% (sub1 enum-depth)))
+                                             (change-style (send (send a-text get-style-list) find-named-style "Standard")
+                                                           before
+                                                           (+ before 1))))
+                                         (let*-values ([(r rfl) (rest/base/depth (add1 pos) enum-depth)]
+                                                       [(end-pos) (current-pos)])
+                                           (values
+                                            (lambda ()
+                                              (let ([end-para (send a-text position-paragraph 
+                                                                    (backover-newlines end-pos pos))]
+                                                    [left-margin (* 2 (get-bullet-width) enum-depth)])
+                                                (let loop ([para (send a-text position-paragraph pos)]
+                                                           [first? #t])
+                                                  (send a-text set-paragraph-margins
+                                                        para
+                                                        (if first?
+                                                            (max 0 (- left-margin
+                                                                      (if bullet?
+                                                                          (get-bullet-width)
+                                                                          0)))
+                                                            left-margin)
+                                                        left-margin
+                                                        0)
+                                                  (unless (= para end-para)
+                                                    (loop (add1 para) #f))))
+                                              (r))
+                                            rfl)))]
+                                      [(ul menu ol dl)
+                                       (insert-newlines (if (zero? enum-depth) 2 1) forced-lines para-base)
+                                       (let-values ([(r rfl)
+                                                     (rest/base/depth para-base (add1 enum-depth))])
+                                         (insert-newlines (if (zero? enum-depth) 2 1) rfl para-base)
+                                         (values r rfl))]
+                                      [(p)
+                                       (insert-newlines 2 forced-lines para-base)
+                                       (let-values ([(r rfl) (rest)])
+                                         (insert-newlines 2 rfl para-base)
+                                         (values r rfl))]
+                                      [(blockquote)
+                                       (insert-newlines 2 forced-lines para-base)
+                                       (let*-values ([(pos) (current-pos)]
+                                                     [(r rfl) (rest/base/depth para-base (add1 enum-depth))]
+                                                     [(end-pos) (current-pos)])
+                                         (begin0
+                                           (values
+                                            (lambda ()
+                                              (let ([end-para (send a-text position-paragraph 
+                                                                    (backover-newlines end-pos pos))]
+                                                    [left-margin (* 2 (get-bullet-width) (add1 enum-depth))])
+                                                (let loop ([para (send a-text position-paragraph pos)])
+                                                  (send a-text set-paragraph-margins
+                                                        para
+                                                        left-margin
+                                                        left-margin
+                                                        left-margin)
+                                                  (unless (= para end-para)
+                                                    (loop (add1 para)))))
+                                              (r))
+                                            rfl)
+                                           (insert-newlines 2 rfl para-base)))]
+                                      [(center)
+                                       (insert-newlines 2 forced-lines para-base)
+                                       (let-values ([(r rfl)
+                                                     (para-aligner 'center #f rest)])
+                                         (insert-newlines 2 rfl para-base)
+                                         (values r rfl))]
+                                      [(div)
+                                       (insert-newlines 1 forced-lines para-base)
+                                       (let* ([align (get-field e 'align)]
+                                              [class (get-field e 'class)]
+                                              [delta (and class (lookup-class-delta class))])
+                                         (with-style-class
+                                          class
+                                          (lambda ()
+                                            (let-values ([(r rfl)
+                                                          (cond
+                                                            [(and (string? align) (string-ci=? align "center"))
+                                                             (para-aligner 'center delta rest)]
+                                                            [(and (string? align) (string-ci=? align "left"))
+                                                             (para-aligner 'left delta rest)]
+                                                            [(and (string? align) (string-ci=? align "left-outdent"))
+                                                             (para-aligner 'left-outdent delta rest)]
+                                                            [(or (and (string? align) (string-ci=? align "right"))
+                                                                 (and (string? class) (string-ci=? class "navigation")))
+                                                             (para-aligner 'right delta rest)]
+                                                            [delta
+                                                             (styler delta rest)]
+                                                            [else (rest)])])
+                                              (insert-newlines 1 rfl para-base)
+                                              (values r rfl)))))]
+                                      [(br)
+                                       (insert-newlines 1 (+ 1 forced-lines) para-base)
+                                       (rest/fl (+ forced-lines 1))]
+                                      [(table)
+                                       (insert-newlines 1 forced-lines para-base)
+                                       (let-values ([(r rfl)
+                                                     (maybe-bg-color e rest #t)])
+                                         (insert-newlines 1 rfl para-base)
+                                         (values r (max 1 rfl)))]
+                                      [(tr)
+                                       (insert-newlines 1 forced-lines para-base)
+                                       (let-values ([(r rfl)
+                                                     (maybe-bg-color e rest #t)])
+                                         (insert-newlines 1 rfl para-base)
+                                         (values r rfl))]
+                                      [(td)
+                                       (maybe-bg-color e rest #t)]
+                                      [(map) 
+                                       (set! image-maps (cons e image-maps))
+                                       (rest)]
+                                      [(img)
+                                       (let* ([url (parse-image-source e)]
+                                              [alt (get-field e 'alt)]
+                                              [bitmap (and url (cache-bitmap url))]
+                                              [usemap (get-field e 'usemap)])
+                                         (cond
+                                           [(and bitmap usemap)
+                                            (let ([pos (current-pos)]
+                                                  [image-map-snip (make-object image-map-snip% a-text)])
+                                              (send image-map-snip set-bitmap bitmap)
+                                              (send image-map-snip set-key usemap)
+                                              (insert image-map-snip)
+                                              (set! image-map-snips (cons image-map-snip image-map-snips))
+                                              (change-style delta:center pos (add1 pos)))]
+                                           [bitmap
+                                            (let ([pos (current-pos)])
+                                              (insert (make-object image-snip% bitmap))
+                                              (change-style delta:center pos (add1 pos)))]
+                                           [alt
+                                            (insert alt)]
+                                           [else
+                                            (let ([pos (current-pos)])
+                                              (insert (new image-snip%))
+                                              (change-style delta:center pos (add1 pos)))])
+                                         (rest))]
+                                      [(form)
+                                       (rest/form (make-form (get-field e 'action) (get-field e 'target) (get-field e 'method) null #f))]
+                                      [(input select textarea)
+                                       (let ([unsupported (make-unsupported tag e)]
+                                             [pos (current-pos)]
+                                             [type (let ([t (get-field e 'type)])
+                                                     (and t (string->symbol t)))]
+                                             [send-form (lambda (add-self?)
+                                                          (let ([post-string
+                                                                 (apply 
+                                                                  string-append
+                                                                  (map (lambda (v)
+                                                                         (if (car v)
+                                                                             (format "~a=~a&"
+                                                                                     (car v)
+                                                                                     (protect-chars (or ((cdr v))
+                                                                                                        "?")))
+                                                                             ""))
+                                                                       (form-parts form)))])
+                                                            (send a-text post-url
+                                                                  (form-action form)
+								  (string->bytes/utf-8
+								   (if add-self?
+								       ;; Add this button
+								       (format "~a~a=~a" 
+									       post-string 
+									       (get-field e 'name) 
+									       (protect-chars (get-field e 'value)))
+								       ;; remove trailing &
+								       (substring post-string 
+										  0 
+										  (max 0 (sub1 (string-length post-string)))))))))])
+                                         (let-values ([(name cb get-val)
+                                                       (cond
+                                                         [(eq? tag 'select)
+                                                          (let ([select (make-object option-snip%)])
+                                                            (set-form-active-select! form select)
+                                                            (insert select)
+                                                            (values (get-field e 'name)
+                                                                    #f
+                                                                    (lambda () 
+                                                                      (send select get-value))))]
+                                                         [(or (and (eq? tag 'input)
+                                                                   (or (not type) (eq? type 'text)))
+                                                              (eq? tag 'textarea))
+                                                          (let* ([text (make-object text%)]
+                                                                 [snip (make-object editor-snip% text)]
+                                                                 [size (get-field e 'size)]
+                                                                 [val (get-field e 'value)])
+                                                            (let ([km (send text get-keymap)])
+                                                              ((current-text-keymap-initializer) km)
+                                                              (unless (eq? tag 'textarea)
+                                                                (send km add-function "send-form"
+                                                                      (lambda (t e)
+                                                                        (send-form #f)))
+                                                                (send km map-function "enter" "send-form")))
+                                                            (let ([width (* 10 (or (and size (string->number size))
+                                                                                   25))])
+                                                              (send text set-min-width width)
+                                                              (send text set-max-width width))
+                                                            (when val
+                                                              (send text insert val))
+                                                            (insert snip)
+                                                            (values
+                                                             (get-field e 'name)
+                                                             #f
+                                                             (lambda () (send text get-text))))]
+                                                         [(and (eq? tag 'input)
+                                                               (eq? type 'submit))
+                                                          (insert (get-field e 'value))
+                                                          (values
+                                                           #f ; because we leave out this button when it's not pushed
+                                                           (lambda ()
+                                                             (send-form #t))
+                                                           #f)]
+                                                         [(and (eq? tag 'input)
+                                                               (eq? type 'checkbox))
+                                                          (let ([cb (make-object checkbox-snip% (true? (or (get-field e 'value) "false")))])
+                                                            (insert cb)
+                                                            (values
+                                                             (get-field e 'name)
+                                                             #f
+                                                             (lambda () (if (send cb get-value)
+                                                                            "true"
+                                                                            "false"))))]
+                                                         [(and (eq? tag 'input)
+                                                               (eq? type 'hidden))
+                                                          (values
+                                                           (get-field e 'name)
+                                                           #f
+                                                           (lambda () (regexp-replace* re:quot (get-field e 'value) "\"")))]
+                                                         [else
+                                                          (insert unsupported)
+                                                          (values #f #f #f)])])
+                                           (set-form-parts! form
+                                                            (cons (cons name
+                                                                        (or get-val
+                                                                            (lambda ()
+                                                                              (get-field e 'value))))
+                                                                  (form-parts form)))
+                                           (let-values ([(r rfl) (rest)]
+                                                        [(end-pos) (current-pos)])
+                                             (set-form-active-select! form #f)
+                                             (values
+                                              (lambda ()
+                                                (cond
+                                                  [cb
+                                                   (send a-text make-link-style pos end-pos)
+                                                   (send a-text add-thunk-callback pos end-pos cb)]
+                                                  [else
+                                                   (change-style delta:default-face pos end-pos)])
+                                                (r))
+                                              rfl))))]
+                                      [(option)
+                                       (let-values ([(pos) (current-pos)]
+                                                    [(r rfl) (rest)]
+                                                    [(val) (get-field e 'value)]
+                                                    [(selected?) (true? (or (get-field e 'selected) 
+                                                                            "false"))]
+                                                    [(end-pos) (current-pos)])
+                                         (let ([str (send a-text get-text pos end-pos)]
+                                               [select (form-active-select form)])
+                                           (delete pos end-pos)
+                                           (when select
+                                             (send select add-option str (or val str))
+                                             (when selected?
+                                               (send select set-value val)))
+                                           (values r rfl)))]
+                                      [(tt code samp kbd pre)
+                                       (when (memq tag '(pre))
+                                         (insert-newlines 2 forced-lines para-base))
+                                       (let-values ([(r rfl)
+                                                     (let* ([class (get-field e 'class)]
+                                                            [delta (and class (lookup-class-delta class))])
+                                                       (with-style-class
+                                                        class
+                                                        (lambda ()
+                                                          (styler (if delta
+                                                                      (let ([d (make-object style-delta% 'change-nothing)])
+                                                                        (send d copy delta)
+                                                                        (send d collapse delta:fixed)
+                                                                        d)
+                                                                      delta:fixed)
+                                                                  rest))))])
+                                         (when (memq tag '(pre))
+                                           (insert-newlines 2 rfl para-base))
+                                         (values r rfl))]
+                                      [(span)
+                                       (let* ([class (get-field e 'class)]
+                                              [delta (and class (lookup-class-delta class))])
+                                         (if delta
+                                             (styler delta rest)
+                                             (rest)))]
+                                      [else (rest)]))]))])
+                (load-status #f "page" (send a-text get-url))
+                (let-values ([(f fl) (translate content 0 0 0 (make-form #f #f #f null #f))])
+                  (f))
+                (send a-text add-tag "top" 0)
+                (update-image-maps image-map-snips image-maps)
+                (send a-text set-position 0)))))))))
diff --git a/collects/browser/private/hyper.ss b/collects/browser/private/hyper.ss
new file mode 100644
index 0000000000..9b68e2c4cc
--- /dev/null
+++ b/collects/browser/private/hyper.ss
@@ -0,0 +1,1083 @@
+#| 
+A test case:
+
+(module tmp mzscheme
+   (require (lib "class.ss")
+	    (lib "mred.ss" "mred")
+	    (lib "browser.ss" "browser")
+            (lib "framework.ss" "framework"))
+   
+   (define f%
+     (frame:status-line-mixin 
+      frame:basic%))
+   
+   (define f (new f%
+                  (label "My Frame")
+                  (width 400)
+                  (height 300)))
+   (define browser (new hyper-panel% 
+                        (info-line? #f)
+                        (parent (send f get-area-container))))
+   (send f show #t)
+   
+   (send (send browser get-canvas)
+	 goto-url
+	 ;; The starting URL:
+	 "http://www.htdp.org/";
+	 ;; #f means not a relative URL:
+	 #f))
+|#
+
+(module hyper mzscheme
+  (require (lib "unitsig.ss")
+           (lib "class.ss")
+           "sig.ss"
+           "../browser-sig.ss"
+           (lib "file.ss")
+           (lib "list.ss")
+           (lib "string.ss")
+           (lib "etc.ss")
+           (lib "url-sig.ss" "net")
+           (lib "head.ss" "net")
+           (lib "mred-sig.ss" "mred")
+           (lib "framework.ss" "framework")
+           (lib "string-constant.ss" "string-constants")
+           (lib "plt-installer-sig.ss" "setup"))
+  
+  (provide hyper@)
+  
+  (define hyper@
+    (unit/sig hyper^
+      (import html^
+              mred^
+              setup:plt-installer^
+              net:url^)
+      
+      (define-struct (exn:file-saved-instead exn) (pathname))
+      (define-struct (exn:cancelled exn) ())
+      
+      (define history-limit 20)
+      
+      (define-struct hyperlink (anchor-start anchor-end url-string))
+      
+      (define-struct hypertag (name position))
+
+      (define (same-page-url? a b)
+        (or (eq? a b)
+            (and (url? a) (url? b)
+                 ;; fragment can be different
+                 (equal? (url-scheme a) (url-scheme b))
+                 (equal? (url-host a) (url-host b))
+                 
+                 ;; assume that url-paths are all strings 
+                 ;; (other wise the pages are treated as different)
+                 (equal? (url-path a) (url-path b))
+                 
+                 (equal? (url-query a) (url-query b)))))
+		 
+
+      (define hyper-text<%>
+        (interface ()
+          init-browser-status-line
+          update-browser-status-line
+          close-browser-status-line
+          url-allows-evaling?))
+      
+      (define hyper-text-mixin
+        (mixin ((class->interface text%) editor:keymap<%>) (hyper-text<%>)
+          (inherit begin-edit-sequence end-edit-sequence lock erase clear-undos
+                   change-style
+                   set-modified auto-wrap
+                   find-snip get-snip-position set-clickback get-canvas
+                   insert last-position hide-caret
+                   get-end-position set-autowrap-bitmap)
+          
+          (init-field url top-level-window)
+          (init progress)
+          (init-field [post-data #f])
+          
+          (define/pubment (url-allows-evaling? url)
+            (cond
+              [(port? url) #f]
+              [(and (url? url)
+                    (equal? "file" (url-scheme url)))
+               (with-handlers ([exn:fail:filesystem? (lambda (x) #f)])
+                 (path-below?
+                  (normal-case-path (normalize-path (build-path (collection-path "mzlib") 
+                                                                'up
+                                                                'up)))
+                  (normal-case-path (normalize-path (apply build-path (url-path url))))))]
+              [else (inner #f url-allows-evaling? url)]))
+          
+          (define doc-notes null)
+          (define title #f)
+          (define htmling? #f)
+          (define redirection #f)
+          (define hypertags-list (list (make-hypertag "top" 0)))
+          (define hyper-delta (make-object style-delta% 'change-underline #t))
+          (let ([mult (send hyper-delta get-foreground-mult)]
+                [add (send hyper-delta get-foreground-add)])
+            (send mult set 0 0 0)
+            (send add set 0 0 255))
+          
+          (define/override (get-keymaps) (cons hyper-keymap (super get-keymaps)))
+          (define/public (get-hyper-keymap) hyper-keymap)
+          
+          (define/augment (after-set-position)
+            (unless (zero? (get-end-position))
+              (hide-caret #f))
+            (inner (void) after-set-position))          
+
+          ;; get-redirection : -> (union false? url?)
+          ;; #f indicates no redirection, url is where it redirects to
+          (define/public (get-redirection) redirection)
+          
+          (define/public (add-document-note note)
+            (set! doc-notes (append doc-notes (list note))))
+          (define/public (get-document-notes) doc-notes)
+          
+          (define/public (make-link-style start end) (change-style hyper-delta start end))
+          (define/public (get-url) (and (url? url) url))
+          
+          (define/public post-url
+            (opt-lambda (url-string [post-data #f])
+              (on-url-click
+               (lambda (url-string post-data)
+                 (with-handlers ([(lambda (x) #t)
+                                  (lambda (x)
+                                    (unless (or (exn:break? x)
+                                                (exn:file-saved-instead? x)
+                                                (exn:cancelled? x))
+                                      ((error-display-handler)
+                                       (if (exn? x) (exn-message x) (format "~s" x))
+                                       x)))])
+                   (send (get-canvas) goto-url url-string (get-url) void post-data)))
+               url-string
+               post-data)))
+          
+          (define/public (on-url-click f x post-data) 
+            (let ([c (get-canvas)])
+              (if c
+                  (send c on-url-click f x post-data)
+                  (f x post-data))))
+          (define/public (get-title) (or title (and (url? url) (url->string url))))
+          (define/public (set-title t) (set! title t))
+          
+          (define/public (add-tag name pos)
+            (for-each (lambda (tag) 
+                        (when (string=? name (hypertag-name tag))
+                          (remove-tag  name)))
+                      hypertags-list)
+            (let ([new-tag (make-hypertag name pos)])
+              (set! hypertags-list
+                    (let insert-loop ([tags-left hypertags-list])
+                      (cond [(null? tags-left)(cons new-tag ())]
+                            [(> pos (hypertag-position (car tags-left)))
+                             (cons new-tag tags-left)]
+                            [else (cons (car tags-left)
+                                        (insert-loop (cdr tags-left)))])))))
+          
+          (define/public (find-tag name)
+            (if (and (integer? name) (positive? name))
+                name
+                (and (string? name)
+                     (ormap (lambda (x) 
+                              (and (string=? name (hypertag-name x)) 
+                                   (hypertag-position x)))
+                            hypertags-list))))
+          (define/public (remove-tag name)
+            (set! hypertags-list
+                  (filter (lambda (x) (not (string=? name (hypertag-name x))))
+                          hypertags-list)))
+          (define/public (add-link start end url-string)
+            (let* ([new-link (make-hyperlink start end url-string)])
+              (set-clickback start end 
+                             (lambda (x y z)
+                               (post-url url-string)))))
+          
+          ;; remember the directory when the callback is added (during parsing)
+          ;; and restore it during the evaluation of the callback.
+          (define/public (add-scheme-callback start end scheme-string)
+            (let ([dir (current-load-relative-directory)])
+              (set-clickback 
+               start end 
+               (lambda (edit start end)
+                 (if (url-allows-evaling? url)
+                     (parameterize ([current-load-relative-directory dir])
+                       (eval-scheme-string scheme-string))
+                     (message-box (string-constant help-desk)
+                                  "<A MZSCHEME= ...> disabled"))))))
+          (define/public (add-thunk-callback start end thunk)
+            (set-clickback 
+             start end 
+             (lambda (edit start end)
+               (thunk))))
+          
+          (define/public (eval-scheme-string s)
+            (let ([v 
+                   (dynamic-wind
+                    begin-busy-cursor
+                    (lambda () 
+                      (with-handlers ([exn:fail? (build-html-error-message s)])
+                        (eval-string s)))
+                    end-busy-cursor)])
+              (when (string? v)
+                (send (get-canvas) goto-url
+                      (open-input-string v)
+                      (get-url)))))
+          
+          (define/public (init-browser-status-line top-level-window)
+            (send top-level-window open-status-line 'browser:hyper.ss))
+          (define/public (update-browser-status-line top-level-window s)
+            (send top-level-window update-status-line 'browser:hyper.ss s))
+          (define/public (close-browser-status-line top-level-window)
+            (send top-level-window close-status-line 'browser:hyper.ss))
+          
+          (define/public reload
+            (opt-lambda ([progress void])
+              (when url
+                (init-browser-status-line top-level-window)
+                (update-browser-status-line 
+                 top-level-window 
+                 (format "Visiting ~a"
+                         (cond
+                           [(url? url) (url->string url)]
+                           [else "page"])))
+                (let ([headers (get-headers/read-from-port progress)])
+                  ;; Page is a redirection?
+                  (let ([m (regexp-match "^HTTP/[^ ]+ 301 " headers)])
+                    (when m
+                      (let ([loc (extract-field "location" headers)])
+                        (when loc
+                          (set! redirection 
+                                (cond
+                                  [(url? url)
+                                   (combine-url/relative url loc)]
+                                  [else
+                                   (string->url loc)])))))))
+                (close-browser-status-line top-level-window))))
+          
+          (define/private (get-headers/read-from-port progress)
+            (cond
+              [(port? url) 
+               (read-from-port url empty-header progress)
+               empty-header]
+              [else
+               (let* ([busy? #t]
+                      [stop-busy (lambda ()
+                                   (when busy?
+                                     (set! busy? #f)
+                                     (end-busy-cursor)))])
+                 (with-handlers ([(lambda (x) (and #f (exn:fail? x) busy?))
+                                  (lambda (x) 
+                                    (call/input-url 
+                                     url
+                                     (if post-data 
+                                         (case-lambda
+                                           [(u) (post-pure-port u post-data)]
+                                           [(u s) (post-pure-port u post-data s)])
+                                         get-pure-port)
+                                     (lambda (p)
+                                       (stop-busy)
+                                       (read-from-port p empty-header progress))))])
+                   (call/input-url 
+                    url 
+                    (if post-data 
+                        (case-lambda
+                          [(u) (post-impure-port u post-data)]
+                          [(u s) (post-impure-port u post-data s)])
+                        get-impure-port)
+                    (lambda (p)
+                      (let ([headers (purify-port p)])
+                        (stop-busy)
+                        (read-from-port p headers progress)
+                        headers)))))]))
+          
+          (define/private (read-from-port p mime-headers progress)
+            (let ([wrapping-on? #t])
+              (dynamic-wind
+               (lambda ()
+                 (lock #f)
+                 (begin-edit-sequence #f)
+                 (set! htmling? #t))
+               (lambda ()
+                 (erase)
+                 (clear-undos)
+                 (let* ([mime-type (extract-field "content-type" mime-headers)]
+                        [html? (and mime-type (regexp-match #rx"text/html" mime-type))])
+                   (cond
+                     [(or (and mime-type (regexp-match #rx"application/" mime-type))
+                          (and (url? url)
+                               (not (null? (url-path url)))
+                               (regexp-match "[.]plt$" (car (last-pair (url-path url))))
+                               ; document-not-found produces HTML:
+                               (not html?)))
+                      ; Save the file
+                      (progress #f)
+                      (let* ([orig-name (and (url? url)
+                                             (let ([p (url-path url)])
+                                               (and (not (null? p))
+                                                    (car (last-pair p)))))]
+                             [size (let ([s (extract-field "content-length" mime-headers)])
+                                     (and s (let ([m (regexp-match #rx"[0-9]+" s)])
+                                              (and m (string->number (car m))))))]
+                             [install?
+                              (and (and orig-name (regexp-match #rx"[.]plt$" orig-name))
+                                   (let ([d (make-object dialog% (string-constant install?))]
+                                         [d? #f]
+                                         [i? #f])
+                                     (make-object message%
+                                       (string-constant you-have-selected-an-installable-package)
+                                       d)
+                                     (make-object message% 
+                                       (string-constant do-you-want-to-install-it?) d)
+                                     (when size
+                                       (make-object message%
+                                         (format (string-constant paren-file-size) size) d))
+                                     (let ([hp (make-object horizontal-panel% d)])
+                                       (send hp set-alignment 'center 'center)
+                                       (send (make-object button% 
+                                               (string-constant download-and-install)
+                                               hp
+                                               (lambda (b e)
+                                                 (set! i? #t)
+                                                 (send d show #f))
+                                               '(border))
+                                             focus)
+                                       (make-object button% (string-constant download) hp
+                                         (lambda (b e)
+                                           (set! d? #t)
+                                           (send d show #f)))
+                                       (make-object button% (string-constant cancel) hp
+                                         (lambda (b e)
+                                           (send d show #f))))
+                                     (send d center)
+                                     (send d show #t)
+                                     (unless (or d? i?)
+                                       (raise (make-exn:cancelled
+                                               "Package Cancelled"
+                                               (current-continuation-marks))))
+                                     i?))]
+                             [tmp-plt-filename
+                              (if install?
+                                  (make-temporary-file "tmp~a.plt")
+                                  (put-file 
+                                   (if size
+                                       (format 
+                                        (string-constant save-downloaded-file/size)
+                                        size)
+                                       (string-constant save-downloaded-file))
+                                   #f ; should be calling window!
+                                   #f
+                                   orig-name))])
+                        (begin-busy-cursor) ; turn the cursor back on
+                        (when tmp-plt-filename
+                          (let* ([d (make-object dialog% (string-constant downloading) top-level-window)]
+                                 [message (make-object message% 
+                                            (string-constant downloading-file...)
+                                            d)]
+                                 [gauge (if size
+                                            (make-object gauge% #f 100 d)
+                                            #f)]
+                                 [exn #f]
+                                 ; Semaphores to avoid race conditions:
+                                 [wait-to-start (make-semaphore 0)]
+                                 [wait-to-break (make-semaphore 0)]
+                                 ; Thread to perform the download:
+                                 [t (thread
+                                     (lambda ()
+                                       (semaphore-wait wait-to-start)
+                                       (with-handlers ([void
+                                                        (lambda (x)
+                                                          (when (not (exn:break? x))
+                                                            (set! exn x)))])
+                                         (semaphore-post wait-to-break)
+                                         (with-output-to-file tmp-plt-filename
+                                           (lambda ()
+                                             (let loop ([total 0])
+                                               (when gauge
+                                                 (send gauge set-value 
+                                                       (inexact->exact
+                                                        (floor (* 100 (/ total size))))))
+                                               (let ([bts (read-bytes 1024 p)])
+                                                 (unless (eof-object? bts)
+                                                   (write-bytes bts)
+                                                   (loop (+ total (bytes-length bts)))))))
+                                           'binary 'truncate))
+                                       (send d show #f)))])
+                            (send d center)
+                            (make-object button% (string-constant &stop)
+                              d (lambda (b e)
+                                  (semaphore-wait wait-to-break)
+                                  (set! tmp-plt-filename #f)
+                                  (send d show #f)
+                                  (break-thread t)))
+                            ; Let thread run only after the dialog is shown
+                            (queue-callback (lambda () (semaphore-post wait-to-start)))
+                            (send d show #t)
+                            (when exn (raise exn)))
+                          (let ([sema (make-semaphore 0)])
+                            (when (and tmp-plt-filename install?)
+                              (run-installer tmp-plt-filename
+                                             (lambda ()
+                                               (semaphore-post sema)))
+                              (yield sema))))
+                        (raise
+                         (if tmp-plt-filename
+                             (make-exn:file-saved-instead
+                              (if install?
+                                  (string-constant package-was-installed)
+                                  (string-constant download-was-saved))
+                              (current-continuation-marks)
+                              tmp-plt-filename)
+                             (make-exn:cancelled "The download was cancelled."
+                                                 (current-continuation-marks)))))]
+                     [(or (and (url? url)
+                               (not (null? (url-path url)))
+                               (regexp-match "[.]html?$" (car (last-pair (url-path url)))))
+                          (port? url)
+                          html?)
+                      ; HTML
+                      (progress #t)
+                      (let* ([directory
+                              (or (if (and (url? url)
+                                           (string=? "file" (url-scheme url)))
+                                      (let ([path (url-path url)])
+                                        (let-values ([(base name dir?) (split-path path)])
+                                          (if (string? base)
+                                              base
+                                              #f)))
+                                      #f)
+                                  (current-load-relative-directory))])
+                        (parameterize ([html-status-handler 
+                                        (lambda (s)
+                                          (update-browser-status-line top-level-window s))]
+                                       [current-load-relative-directory directory]
+                                       [html-eval-ok (url-allows-evaling? url)])
+                          (html-convert p this)))]
+                     [else
+                      ; Text
+                      (progress #t)
+                      (begin-edit-sequence)
+                      (let loop ()
+                        (let ([r (read-line p 'any)])
+                          (unless (eof-object? r)
+                            (insert r)
+                            (insert #\newline)
+                            (loop))))
+                      (change-style (make-object style-delta% 'change-family 'modern)
+                                    0 (last-position))
+                      (set! wrapping-on? #f)
+                      (end-edit-sequence)])))
+               (lambda ()
+                 (end-edit-sequence)
+                 (end-busy-cursor)
+                 (set! htmling? #f)
+                 (set-modified #f)
+                 (auto-wrap wrapping-on?)
+                 (set-autowrap-bitmap #f)
+                 (lock #t)
+                 (close-input-port p)))))
+          
+          (inherit find-position get-snip-location
+                   get-dc get-between-threshold
+                   editor-location-to-dc-location
+                   dc-location-to-editor-location)
+          ;; use on-event rather than on-default-event since we want
+          ;; to override the caret handling snip in the case that
+          ;; an image-map-snip is there.
+          (define/override (on-event event)
+            (let* ([edge-close-b (box 0)]
+                   [on-it-b (box #f)]
+                   [dc-event-x (send event get-x)]
+                   [dc-event-y (send event get-y)])
+              (let-values ([(editor-event-x editor-event-y) 
+                            (dc-location-to-editor-location dc-event-x dc-event-y)])
+                (let ([pos (find-position editor-event-x editor-event-y #f on-it-b edge-close-b)])
+                  (cond
+                    [(and (unbox on-it-b)
+                          (not (<= (abs (unbox edge-close-b))
+                                   (get-between-threshold))))
+                     (let ([snip (find-snip pos 'after-or-none)])
+                       (cond
+                         [(and snip (is-a? snip image-map-snip%))
+                          (let ([bsnip-left (box 0)]
+                                [bsnip-top (box 0)]
+                                [bsnip-right (box 0)]
+                                [bsnip-bot (box 0)])
+                            (get-snip-location snip bsnip-left bsnip-top #f)
+                            (get-snip-location snip bsnip-right bsnip-bot #t)
+                            (let ([snip-left (unbox bsnip-left)]
+                                  [snip-top (unbox bsnip-top)]
+                                  [snip-right (unbox bsnip-right)]
+                                  [snip-bot (unbox bsnip-bot)])
+                              (cond
+                                [(and (<= snip-left editor-event-x snip-right)
+                                      (<= snip-top editor-event-y snip-bot))
+                                 (let-values ([(x y) (editor-location-to-dc-location snip-left snip-top)])
+                                   (send snip on-event (get-dc) x y snip-left snip-top event))]
+                                [else (super on-event event)])))]
+                         [else (super on-event event)]))]
+                    [else (super on-event event)])))))
+          
+          (super-new)
+          
+          ;; load url, but the user might break:
+          (with-handlers ([exn:break? void])
+            ;(printf "url: ~a\n" (if (url? url) (url->string url) url)) ;; handy for debugging help desk
+            (reload progress))))
+      
+      ;; build-html-error-message : exn -> string[html]
+      (define ((build-html-error-message str) exn)
+        (string-append
+         "<html><head><title>Error Evaluating Scheme</title></head>"
+         "<body>"
+         "<h2>Error Evaluating Scheme Code</h2>"
+         (format "<pre>\n~a\n</pre>" str)
+         "<p><p>"
+         (format "<font color=\"red\">~a</font>" 
+                 (regexp-replace* #rx"<" (regexp-replace* #rx">" (exn-message exn) "&lt;") "&gt;"))
+         "</body></html>"))
+        
+      (define hyper-text% (hyper-text-mixin text:keymap%))
+
+      (define hyper-keymap (make-object keymap%))
+      (send hyper-keymap add-function "rewind" 
+            (lambda (txt evt)
+              (call-with-hyper-panel
+               txt
+               (lambda (panel)
+                 (send panel rewind)))))
+      (send hyper-keymap add-function "forward" 
+            (lambda (txt evt)
+              (call-with-hyper-panel
+               txt
+               (lambda (panel)
+                 (send panel forward)))))
+      (send hyper-keymap add-function "do-wheel" 
+            (lambda (txt evt)
+	      ;; Redirect the event to the canvas, which should
+	      ;;  handle the event
+	      (send (send txt get-canvas) on-char evt)))
+      (add-text-keymap-functions hyper-keymap)
+      (send hyper-keymap map-function "d:[" "rewind")
+      (send hyper-keymap map-function "a:[" "rewind")
+      (send hyper-keymap map-function "c:[" "rewind")
+      (send hyper-keymap map-function "d:left" "rewind")
+      (send hyper-keymap map-function "a:left" "rewind")
+      (send hyper-keymap map-function "c:left" "rewind")
+      (send hyper-keymap map-function "m:left" "rewind")
+      (send hyper-keymap map-function "d:]" "forward")
+      (send hyper-keymap map-function "a:]" "forward")
+      (send hyper-keymap map-function "c:]" "forward")
+      (send hyper-keymap map-function "d:right" "forward")
+      (send hyper-keymap map-function "a:right" "forward")
+      (send hyper-keymap map-function "c:right" "forward")
+      (send hyper-keymap map-function "m:right" "forward")
+      (send hyper-keymap map-function "wheelup" "do-wheel")
+      (send hyper-keymap map-function "pageup" "previous-page")
+      (send hyper-keymap map-function "wheeldown" "do-wheel")
+      (send hyper-keymap map-function "pagedown" "next-page")
+      
+      ;; call-with-hyper-panel : object ((is-a?/c hyper-panel<%>) -> void) -> void
+      (define (call-with-hyper-panel text f)
+        (when (is-a? text hyper-text<%>)
+          (let ([canvas (send text get-canvas)])
+            (when canvas
+              (let ([tlw (send canvas get-top-level-window)])
+                (when (is-a? tlw hyper-frame<%>)
+                  (f (send tlw get-hyper-panel))))))))
+            
+      ;; path-below? : string[normalized-path] string[normalized-path] -> boolean
+      ;; returns #t if subpath points to a place below top
+      (define (path-below? top longer)
+        (let loop ([top (explode-path top)]
+                   [longer (explode-path longer)])
+          (cond
+            [(null? top) #t]
+            [(null? longer) #f]
+            [(equal? (car top) (car longer))
+             (loop (cdr top) (cdr longer))]
+            [else #f])))
+
+      (keymap:add-to-right-button-menu/before
+       (let ([old (keymap:add-to-right-button-menu/before)])
+         (lambda (menu editor event)
+           (when (is-a? editor hyper-text<%>)
+             (let* ([panel (let ([canvas (send editor get-canvas)])
+                             (and canvas
+                                  (send (send canvas get-top-level-window) get-hyper-panel)))]
+                    [back
+                     (instantiate menu-item% ()
+                       (label (string-append "< " (string-constant rewind-in-browser-history)))
+                       (parent menu)
+                       (callback
+                        (lambda (_1 _2)
+                          (when panel
+                            (send panel rewind)))))]
+                    [forward
+                     (instantiate menu-item% ()
+                       (label (string-append (string-constant forward-in-browser-history) " >"))
+                       (parent menu)
+                       (callback
+                        (lambda (_1 _2)
+                          (when panel
+                            (send panel forward)))))])
+               (send back enable (send panel can-rewind?))
+               (send forward enable (send panel can-forward?))
+               (instantiate separator-menu-item% ()
+                 (parent menu))))
+           (old menu editor event))))
+      
+      (define hyper-canvas-mixin
+        (mixin ((class->interface editor-canvas%)) ()
+          (inherit get-editor set-editor refresh get-parent get-top-level-window)
+          
+          (define/public (get-editor%) hyper-text%)
+          
+          (define/public (current-page)
+            (let ([e (get-editor)])
+              (and e 
+                   (let ([sbox (box 0)]
+                         [ebox (box 0)])
+                     (send e get-visible-position-range sbox ebox)
+                     (list e (unbox sbox) (unbox ebox))))))
+          (define/public (on-url-click k url post-data)
+            (send (get-parent) on-url-click k url post-data))
+          (define/public goto-url
+            (opt-lambda (in-url relative [progress void] [post-data #f])
+              (let ([tlw (get-top-level-window)])
+                (when (and tlw
+                           (is-a? tlw hyper-frame<%>))
+                  (let ([pre-url (cond
+                                   [(url? in-url) in-url]
+                                   [(port? in-url) in-url]
+                                   [(string? in-url)
+                                    (if relative
+                                        (combine-url/relative relative in-url)
+                                        (string->url in-url))]
+                                   [else (error 'goto-url "unknown url ~e\n" in-url)])]
+                        [killable-cust (make-custodian)]
+                        [hyper-panel (send tlw get-hyper-panel)])
+                    (let-values ([(e url)
+                                  (let ([e-now (get-editor)])
+                                    (cond
+                                      [(and e-now
+                                            (not post-data)
+                                            (same-page-url? pre-url (send e-now get-url)))
+                                       (progress #t)
+                                       (values e-now pre-url)]
+                                      [else
+                                       (send hyper-panel set-stop-callback 
+                                             (lambda ()
+                                               (custodian-shutdown-all killable-cust)))
+                                       (send hyper-panel enable-browsing #f)
+                                       (begin0
+                                         (make-editor/setup-kill killable-cust 
+                                                                 (get-editor%)
+                                                                 tlw
+                                                                 pre-url
+                                                                 progress
+                                                                 post-data
+                                                                 (lambda (x) (remap-url x)))
+                                         (send hyper-panel set-stop-callback void)
+                                         (send hyper-panel enable-browsing #t))]))])
+                      (when e
+                        (let* ([tag-pos (send e find-tag (and (url? url) (url-fragment url)))])
+                          
+                          (unless (and tag-pos (positive? tag-pos))
+                            (send e hide-caret #t))
+                          (set-page (list e (or tag-pos 0) (send e last-position)) #t)
+                          (when tag-pos (send e set-position tag-pos))))))))))
+          
+          ;; remap-url : url? -> (union #f url?)
+          ;; this method is intended to be overridden so that derived classes can change
+          ;; the behavior of the browser. Calls to this method may be killed.
+          (define/public (remap-url url)
+            url)
+          
+          (define/public (after-set-page) (void))
+          (define/public (set-page page notify?)
+            (let ([e (car page)]
+                  [spos (cadr page)]
+                  [epos (caddr page)]
+                  [curr (get-editor)]
+                  [current (current-page)])
+              ; Pre-size the editor to avoid visible reflow
+              (when curr
+                (let ([wbox (box 0)])
+                  (send curr get-view-size wbox (box 0))
+                  (when (send e auto-wrap)
+                    (send e set-max-width (unbox wbox)))))
+              (send e begin-edit-sequence)
+              (when notify?
+                (send (get-parent) leaving-page current (list e 0 0)))
+              (set-editor e (and current (zero? (cadr current)) (zero? spos)))
+              (send e scroll-to-position spos #f epos 'start)
+              (send e end-edit-sequence)
+              (after-set-page)
+              (when (or (positive? spos) (not current) (positive? (cadr current)))
+                (refresh))))
+          (super-new)))
+      
+      ;; make-editor/setup-kill : custodian editor-class frame%-instance 
+      ;;                          url (boolean??? -> void) ??? (url -> (union port #f url))
+      ;;                       -> (values (union #f editor) (union #f url))
+      ;; if cust is shutdown, the url will stop being loaded and a dummy editor is returned.
+      (define (make-editor/setup-kill cust html-editor% tlw init-url progress post-data remap-url)
+        (let* ([c (make-channel)]
+               [t (parameterize ([current-custodian cust])
+                    (thread
+                     (lambda ()
+                       (channel-put
+                        c
+                        (make-editor/follow-redirections html-editor%
+                                                         tlw
+                                                         init-url
+                                                         progress
+                                                         post-data
+                                                         remap-url)))))]
+               [ans #f])
+          (yield
+           (choice-evt
+            (handle-evt c (lambda (x) (set! ans x)))
+            (handle-evt (thread-dead-evt t)
+                        (lambda (_)
+                          (let ([t (new hyper-text% 
+                                        (url #f)
+                                        (top-level-window tlw)
+                                        (progress void))])
+                            (send t insert "Stopped.")
+                            (set! ans (cons t #f)))))))
+          (values (car ans) (cdr ans))))
+      
+      ;; make-editor/follow-redirections : editor-class frame%-instance
+      ;;                                   url (boolean??? -> void) ??? (url -> (union port #f url))
+      ;;                                -> (cons (union #f editor) (union #f url))
+      ;; builds an html editor using make-editor and follows any redictions,
+      ;; but stops after 10 redirections (just in case there are too many
+      ;; of these things, give the user a chance to stop)
+      (define (make-editor/follow-redirections html-editor% tlw init-url progress post-data remap-url)
+        (let loop ([n 10]
+                   [unmapped-url init-url])
+          (let ([url (if (url? unmapped-url)
+                         (let ([rurl (remap-url unmapped-url)])
+                           (unless (or (url? rurl)
+                                       (input-port? rurl)
+                                       (not rurl))
+                             (error 'remap-url
+                                    "expected a url struct, an input-port, or #f, got ~e"
+                                    rurl))
+                           rurl)
+                         unmapped-url)])
+            (if url
+                (let ([html-editor (new html-editor%
+                                        [url url]
+                                        [top-level-window tlw]
+                                        [progress progress]
+                                        [post-data post-data])])
+                  (cond
+                    [(zero? n) 
+                     (cons html-editor url)]
+                    [(send html-editor get-redirection)
+                     =>
+                     (lambda (new-url) (loop (- n 1) new-url))]
+                    [else
+                     (cons html-editor url)]))
+                (cons #f #f)))))
+      
+      (define hyper-canvas% (hyper-canvas-mixin canvas:basic%))
+      
+      (define info-canvas%
+        (class canvas%
+          (inherit min-client-height get-dc stretchable-height
+                   get-parent enable refresh show)
+          (field
+            [text ""])
+          [define/override on-paint
+             (lambda ()
+               (let ([dc (get-dc)])
+                 (send dc clear)
+                 (send dc draw-text text 4 2)))]
+          [define/public erase-info (lambda ()
+                          (unless (string=? text "")
+                            (set! text "")
+                            (let ([dc (get-dc)])
+                              (send dc clear))))]
+            [define/public set-info (lambda (t)
+                        (set! text t)
+                        (if (string=? t "")
+                            (show #f)
+                            (let ([dc (get-dc)])
+                              (send dc clear)
+                              (show #t)
+                              (refresh))))]
+          (super-instantiate ())
+          (stretchable-height #f)
+          (enable #f)
+          (show #f)
+          (let ([font (make-object font% (send normal-control-font get-point-size) 
+				   'default 'normal 'normal)]
+                [dc (get-dc)])
+            (send dc set-font font)
+            (send dc set-text-foreground (make-object color% "FOREST GREEN"))
+            (let-values ([(w h d a) (send dc get-text-extent "X" font)])
+              (min-client-height (+ 4 (inexact->exact (ceiling h))))))))
+      
+      (define hyper-panel<%>
+        (interface ()
+          current-page
+          rewind
+          forward
+          can-rewind?
+          can-forward?
+          get-canvas%
+          make-canvas
+          make-control-bar-panel
+          
+          set-init-page
+          goto-init-page
+          
+          on-navigate
+          filter-notes
+          get-canvas
+          on-url-click 
+          reload
+          leaving-page
+          get-stop-button
+          set-stop-callback
+          
+          enable-browsing))
+      
+      (define hyper-panel-mixin
+        (mixin (area-container<%>) (hyper-panel<%>)
+          (init info-line?)
+          (inherit reflow-container)
+          (super-new)
+          
+          (define browsing-on? #t)
+          (define/public (enable-browsing on?)
+            (set! browsing-on? on?)
+            (cond
+              [on?
+               (send stop-button enable #f)
+               (update-buttons)]
+              [else 
+               (send stop-button enable #t)
+               (when home (send home enable #f))
+               (when forw (send forw enable #f))
+               (when back (send back enable #f))
+               (when choice (send choice enable #f))]))
+          
+          (define/private (clear-info)
+            (when info 
+              (send info erase-info)))
+          (define/private (update-info page)
+            (when (and info page)
+              (let ([notes (send (page->editor page) get-document-notes)])
+                (send info set-info
+                      (filter-notes notes (send (page->editor page) get-url))))))
+          (define/private (go page)
+            (clear-info)
+            (send c set-page page #f)
+            (update-info page)
+            (update-buttons/set-page page)
+            (on-navigate))
+          
+          (define/public (current-page) (send c current-page))
+          (define/public (rewind)
+            (unless (null? past)
+              (let ([page (car past)])
+                (set! future (cons (send c current-page) future))
+                (set! past (cdr past))
+                (go page))))
+          (define/public (forward)
+            (unless (null? future)
+              (let ([page (car future)])
+                (set! past (cons (send c current-page) past))
+                (set! future (cdr future))
+                (go page))))
+          (define/public (can-forward?) (and browsing-on? (not (null? future))))
+          (define/public (can-rewind?) (and browsing-on? (not (null? past))))
+          [define/public get-canvas% (lambda () hyper-canvas%)]
+          [define/public make-canvas (lambda (f) (make-object (get-canvas%) f))]
+          [define/public make-control-bar-panel (lambda (f) (make-object horizontal-panel% f))]
+          (field
+           [past null]
+           [future null] 
+           
+           
+           ;; (union #f                             -- no init page
+           ;;         string                        -- delayed init page
+           ;;         url                           -- delayed init page
+           ;;         (list editor number numer))   -- forced init page
+           [init-page #f]
+
+           [hp (make-control-bar-panel this)]
+           [control-bar? (is-a? hp area-container<%>)]
+           [back (and control-bar?
+                      (make-object button%
+                        (string-append "< " (string-constant rewind-in-browser-history))
+                        hp
+                        (lambda (b ev) 
+                          (rewind))))]
+           [forw (and control-bar?
+                      (make-object button% 
+                        (string-append (string-constant forward-in-browser-history) " >")
+                        hp
+                        (lambda (b ev) 
+                          (forward))))])
+          
+          (define/private (home-callback)
+            (cond
+              [(or (url? init-page)
+                   (string? init-page))
+               
+               ; handle stopping when loading the home page
+               (with-handlers ([exn:break? 
+                                (lambda (x) (void))])
+                 (send c goto-url init-page #f)
+                 (update-buttons))]
+              [else 
+               (send c set-page init-page #t)]))
+          (field
+           [home (and control-bar?
+                      (make-object button% (string-constant home) hp
+                        (lambda (b ev)
+                          (home-callback))))])
+          
+          (define the-page #f)
+          (define/private (update-buttons/set-page page)
+            (unless init-page
+              (set! init-page page))
+            (set! the-page page)
+            (update-buttons))
+          (define/private (update-buttons)
+            (when control-bar?
+              (send home enable (or (url? init-page) (string? init-page)))
+              (send back enable (pair? past))
+              (send forw enable (pair? future))
+              
+              (send choice clear)
+              (for-each
+               (lambda (p)
+                 (send choice append 
+                       (let ([s (send (car p) get-title)])
+                         (if s 
+                             (gui-utils:trim-string s 200)
+                             (string-constant untitled)))))
+               (append (reverse future)
+                       (if the-page (list the-page) null)
+                       past))
+              (let ([c (send choice get-number)])
+                (unless (zero? c)
+                  (send choice set-selection (length future))))))
+          (field
+           [choice (and control-bar?
+                        (make-object choice% #f null hp
+                          (lambda (ch e)
+                            (let* ([l (append (reverse past)
+                                              (list (send c current-page))
+                                              future)]
+                                   [pos (- (send choice get-number) (send choice get-selection) 1)])
+                              (let loop ([l l][pre null][pos pos])
+                                (cond
+                                  [(zero? pos)
+                                   (set! past pre)
+                                   (set! future (cdr l))
+                                   (go (car l))]
+                                  [else (loop (cdr l)
+                                              (cons (car l) pre)
+                                              (sub1 pos))]))))))]
+           [stop-callback void]
+           [stop-button
+            (and control-bar?
+                 (new button%
+                      (label (string-constant stop))
+                      (parent hp)
+                      (callback (lambda (x y) (stop-callback)))))])
+          (define/public (get-stop-button) stop-button)
+          (define/public (set-stop-callback bc) (set! stop-callback bc))
+          (when stop-button (send stop-button enable #f))
+          
+          (field
+           [info (and info-line?
+                      (make-object info-canvas% this))]
+           [c (make-canvas this)])
+          
+          ;; set-init-page : (union string url) -> void
+          [define/public set-init-page
+            (lambda (p)
+              (set! init-page p))]
+          [define/public goto-init-page
+            (lambda ()
+              (home-callback))]
+          
+          [define/public on-navigate (lambda () (void))]
+          [define/public filter-notes (lambda (l) (apply string-append l))]
+          [define/public get-canvas (lambda () c)]
+          [define/public on-url-click (lambda (k url post-data) (k url post-data))]
+          
+          [define/public reload
+            (lambda ()
+              (let ([c (get-canvas)])
+                (and c 
+                     (let ([e (send c get-editor)])
+                       (and e
+                            (send e reload))))))]
+          
+          (define/public (leaving-page page new-page)
+            (set! future null)
+            (when page
+              (set! past (cons page past)))
+            (when (> (length past) history-limit)
+              (set! past
+                    (let loop ([l past])
+                      (if (null? (cdr l))
+                          null
+                          (cons (car l) (loop (cdr l)))))))
+            (clear-info)
+            (update-buttons/set-page new-page)
+            (update-info new-page))
+          (when control-bar?
+            (send choice stretchable-width #t)
+            (send hp stretchable-height #f))
+          (update-buttons/set-page #f)))
+      
+      (define hyper-panel% (hyper-panel-mixin vertical-panel%))
+      
+      (define hyper-frame<%>
+        (interface ()
+          get-hyper-panel
+          get-hyper-panel%))
+      
+      (define hyper-no-show-frame-mixin
+        (mixin (frame:status-line<%>) (hyper-frame<%>)
+          (field [p #f])
+          (define/public get-hyper-panel% (lambda () hyper-panel%))
+          (define/public get-hyper-panel (lambda () p))
+          (inherit show get-area-container)
+          (super-instantiate ())
+          (set! p (make-object (get-hyper-panel%) #f (get-area-container)))))
+      
+      (define hyper-frame-mixin
+        (compose
+         (mixin (hyper-frame<%> top-level-window<%>) ()
+           (init start-url)
+           (inherit show get-hyper-panel)
+           (super-instantiate ())
+           (show #t)
+           (send (send (get-hyper-panel) get-canvas) goto-url start-url #f))
+         hyper-no-show-frame-mixin))
+      
+      (define hyper-frame% (hyper-frame-mixin (frame:status-line-mixin frame:basic%)))
+      (define hyper-no-show-frame% (hyper-no-show-frame-mixin (frame:status-line-mixin frame:basic%)))
+      
+      (define (editor->page e) (list e 0 0))
+      (define (page->editor e) (car e))
+      
+      (define (same-page? a b)
+        (eq? (car a) (car b)))
+      
+      (define (open-url file)
+        (make-object hyper-frame% file (string-constant browser) #f 500 450)))))
diff --git a/collects/browser/private/info.ss b/collects/browser/private/info.ss
new file mode 100644
index 0000000000..67b8513ec2
--- /dev/null
+++ b/collects/browser/private/info.ss
@@ -0,0 +1,2 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Browser private"))
diff --git a/collects/browser/private/option-snip.ss b/collects/browser/private/option-snip.ss
new file mode 100644
index 0000000000..4088905064
--- /dev/null
+++ b/collects/browser/private/option-snip.ss
@@ -0,0 +1,201 @@
+(module option-snip mzscheme
+  (require (lib "mred.ss" "mred")
+	   (lib "class.ss")
+	   (lib "string.ss"))
+
+  (provide option-snip%
+           checkbox-snip%)
+
+  (define inset 2)
+  (define arrow-sep 5)
+  (define arrow-height 5)
+
+  (define arrow (list (make-object point% 0 0)
+		      (make-object point% arrow-height arrow-height)
+		      (make-object point% (* 2 arrow-height) 0)))
+
+  (define arrow-cursor (make-object cursor% 'arrow))
+
+  (define option-snip%
+    (class snip%
+      (inherit get-admin set-snipclass set-count get-style get-flags set-flags)
+      (init-field [options null])
+      (define w #f)
+      (define h #f)
+      (define d #f)
+      (define current-option #f)
+      (define look-for-option #f) ; a box when we're looking (in case we're looking for #f)
+
+      (define/public (add-option o v)
+	(set! options (append options (list (cons o v))))
+	(when (and look-for-option
+		   (equal? v (unbox look-for-option)))
+	  (set! current-option (cons o v)))
+	(set! w #f)
+	(set! h #f)
+	(let ([a (get-admin)])
+	  (when a
+	    (send a resized this #t))))
+      
+      (define/public (get-value)
+        (with-handlers ([exn:fail? (lambda (x) #f)])
+          (cdr (or current-option
+                   (car options)))))
+
+      (define/public (set-value v)
+	(let ([o (ormap (lambda (o) (and (equal? v (cdr o)) o)) options)])
+	  (if o
+	      (set! current-option o)
+	      (set! look-for-option (box v)))))
+
+      (override*
+	[get-extent  ; called by an editor to get the snip's size
+	 (lambda (dc x y wbox hbox descentbox spacebox lspacebox rspacebox)
+	   (unless w
+	     (let ([font (send (get-style) get-font)])
+	       (let ([w+h+ds
+		      (map (lambda (o)
+			     (let-values ([(tw th td ta) (send dc get-text-extent (car o) font)])
+			       (list tw th td)))
+			   options)])
+		 (if (null? w+h+ds)
+		     (begin
+		       (set! w 10)
+		       (set! h 10)
+		       (set! d 2))
+		     (begin
+		       (set! w (+ (* 2 inset) arrow-sep 2 (* 2 arrow-height) (apply max (map car w+h+ds))))
+		       (set! h (+ (* 2 inset) 1 (apply max arrow-height (map cadr w+h+ds))))
+		       (set! d (+ inset 1 (apply max (map caddr w+h+ds)))))))))
+	   (when hbox
+	     (set-box! hbox h))
+	   (when wbox
+	     (set-box! wbox w))
+	   (when descentbox
+	     (set-box! descentbox d))
+	   (when spacebox
+	     (set-box! spacebox 0))
+	   (when rspacebox
+	     (set-box! rspacebox 0))
+	   (when lspacebox
+	     (set-box! lspacebox 0)))]
+	[draw  ; called by an editor to draw the snip
+	 (lambda (dc x y . other)
+	   (unless w
+	     (get-extent dc x y #f #f #f #f #f #f))
+	   (send dc draw-rectangle x y (sub1 w) (sub1 h))
+	   (send dc draw-line (+ x 1) (+ y h -1) (+ x w -1) (+ y h -1))
+	   (send dc draw-line (+ x w -1) (+ y 1) (+ x w -1) (+ y h -1))
+	   (let ([pen (send dc get-pen)]
+		 [brush (send dc get-brush)])
+	     (send dc set-brush (send the-brush-list find-or-create-brush (send pen get-color) 'solid))
+	     (send dc draw-polygon arrow 
+		   (+ x (- w 2 inset (* 2 arrow-height)))
+		   (+ y (/ (- h arrow-height) 2)))
+	     (send dc set-brush brush))
+	   (unless (null? options)
+	     (send dc draw-text (car (or current-option (car options))) (+ x inset) (+ y inset))))]
+	[copy
+	 (lambda ()
+	   (make-object option-snip% options))]
+	[size-cache-invalid
+	 (lambda () (set! w #f) (set! h #f))]
+	[on-event (lambda (dc x y editorx editory event)
+		    (when (send event button-down?)
+		      (let ([popup (make-object popup-menu%)])
+			(for-each (lambda (o)
+				    (make-object menu-item% (car o) popup
+						 (lambda (i e)
+						   (set! current-option o)
+						   (let ([a (get-admin)])
+						     (when a
+						       (send a needs-update this 0 0 w h))))))
+				  options)
+			(let ([a (get-admin)])
+			  (when a
+			    (send a popup-menu popup this 0 0))))))]
+	[adjust-cursor (lambda (dc x y editorx editory event)
+			 arrow-cursor)])
+      (super-instantiate ())
+      (set-flags (cons 'handles-events (get-flags)))
+      (set-count 1)))
+  
+  (define cb-width 12)
+  (define cb-height 12)
+  
+  (define checkbox-snip%
+    (class snip%
+      (inherit get-admin set-snipclass set-count get-style get-flags set-flags)
+      (init-field [checked? #f])
+      (define tracking? #f)
+      (define hit? #f)
+      (define w cb-width)
+      (define h cb-height)
+
+      (define/public (get-value) checked?)
+      
+      (override*
+	[get-extent  ; called by an editor to get the snip's size
+	 (lambda (dc x y wbox hbox descentbox spacebox lspacebox rspacebox)
+	   (when hbox
+	     (set-box! hbox h))
+	   (when wbox
+	     (set-box! wbox w))
+	   (when descentbox
+	     (set-box! descentbox 0))
+	   (when spacebox
+	     (set-box! spacebox 0))
+	   (when rspacebox
+	     (set-box! rspacebox 0))
+	   (when lspacebox
+	     (set-box! lspacebox 0)))]
+	[draw  ; called by an editor to draw the snip
+	 (lambda (dc x y . other)
+	   (send dc draw-rectangle x y w h)
+           (when tracking?
+             (send dc draw-rectangle (+ x 1) (+ y 1) (- w 2) (- h 2)))
+           (when (or (and (not hit?) checked?)
+                     (and hit? (not checked?)))
+             (send dc draw-line x y (+ x w -1) (+ y h -1))
+             (send dc draw-line x (+ y h -1) (+ x w -1) y)))]
+	[copy
+	 (lambda ()
+	   (make-object checkbox-snip% checked?))]
+	[on-event (lambda (dc x y editorx editory event)
+		    (when (send event button-down?)
+                      (set! tracking? #t)
+                      (refresh)
+                      (set! hit? #f))
+                    (if (or (send event button-down?)
+                            (and tracking? (send event dragging?))
+                            (and tracking? (send event button-up?)))
+                        (if (and (<= 0 (- (send event get-x) x))
+				 (<= 0 (- (send event get-y) y)))
+                            (when (not hit?)
+                              (set! hit? #t)
+                              (refresh))
+                            (when hit?
+                              (set! hit? #f)
+                              (refresh)))
+                        (when tracking?
+                          (set! tracking? #f)
+                          (set! hit? #f)
+                          (refresh)))
+                    (when (and tracking?
+                               (and tracking? (send event button-up?)))
+                      (set! tracking? #f)
+                      (when hit?
+                        (set! hit? #f)
+                        (set! checked? (not checked?)))
+                      (refresh)))]
+	[adjust-cursor (lambda (dc x y editorx editory event)
+			 arrow-cursor)])
+
+      (define/private (refresh)
+        (let ([a (get-admin)])
+          (when a
+            (send a needs-update this 0 0 w h))))
+
+      (super-instantiate ())
+      (set-flags (cons 'handles-events (get-flags)))
+      (set-count 1))))
\ No newline at end of file
diff --git a/collects/browser/private/sig.ss b/collects/browser/private/sig.ss
new file mode 100644
index 0000000000..562d4b3bf2
--- /dev/null
+++ b/collects/browser/private/sig.ss
@@ -0,0 +1,58 @@
+(module sig mzscheme
+  (require (lib "unitsig.ss"))
+  
+  (provide relative-btree^
+           bullet-export^
+           hyper^
+           html-export^
+           html^)
+
+  (define-signature html-export^
+    (html-img-ok
+     html-eval-ok
+     image-map-snip%))
+  
+  (define-signature html^
+    (html-convert
+     html-status-handler
+     (open html-export^)))
+  
+  (define-signature bullet-export^
+    (bullet-size))
+  
+  (define-signature hyper^
+    (open-url
+     (struct exn:file-saved-instead (pathname))
+     (struct exn:cancelled ())
+     
+     hyper-text<%>
+     hyper-text-mixin
+     hyper-text%
+     
+     hyper-canvas-mixin
+     hyper-canvas%
+     
+     hyper-panel<%>
+     hyper-panel-mixin
+     hyper-panel%
+     
+     hyper-frame<%>
+     hyper-frame-mixin
+     hyper-frame%
+     
+     hyper-no-show-frame-mixin
+     hyper-no-show-frame%
+     
+     editor->page
+     page->editor))
+     
+  (define-signature relative-btree^
+    (make-btree
+     
+     btree-get
+     btree-put!
+     
+     btree-shift!
+     
+     btree-for-each
+     btree-map)))
diff --git a/collects/browser/tool.ss b/collects/browser/tool.ss
new file mode 100644
index 0000000000..0d724dbe9e
--- /dev/null
+++ b/collects/browser/tool.ss
@@ -0,0 +1,15 @@
+(module tool mzscheme
+  (require (lib "external.ss" "browser")
+           (lib "unitsig.ss")
+           (lib "tool.ss" "drscheme"))
+  (provide tool@)
+
+  ;; to add a preference pannel to drscheme that sets the browser preference
+  (define tool@
+    (unit/sig drscheme:tool-exports^
+      (import drscheme:tool^)
+      
+      (define phase1 void)
+      (define phase2 void)
+      
+      (install-help-browser-preference-panel))))
diff --git a/collects/compiler/cffi.ss b/collects/compiler/cffi.ss
new file mode 100644
index 0000000000..65b414455c
--- /dev/null
+++ b/collects/compiler/cffi.ss
@@ -0,0 +1,324 @@
+
+;; Implements the c-lambda and c-declare forms for interfacing to C.
+;; The macros communicate information to mzc using a 'mzc-cffi
+;; property. When this property information is ignored, the result is
+;; an expression that (eventually) produces an error. The mzc compiler
+;; notices the information, however, and substitutes a different kind
+;; of expression.
+
+(module cffi mzscheme
+  (require (lib "stx.ss" "syntax"))
+  (require-for-syntax (lib "name.ss" "syntax")
+                      (lib "path-spec.ss" "syntax"))
+
+  (define-syntax c-lambda
+    (let ([re:fname (regexp "^[a-zA-Z_0-9]+$")]
+	  [parse-type
+	   (lambda (t stx for-return?)
+	     (let ([literals (syntax-e
+			      (quote-syntax 
+			       (bool
+				char unsigned-char signed-char 
+				int unsigned-int
+				short unsigned-short
+				long unsigned-long
+				float double
+				scheme-object
+				char-string nonnull-char-string)))])
+	       (let ([v (and (identifier? t)
+			     (ormap (lambda (i) 
+				      (and (module-identifier=? i t) i))
+				    literals))])
+		 (cond
+		  [v (syntax-e v)]
+		  [(and for-return? 
+			;; FIXME: void is not lexically scoped
+			(eq? (syntax-e t) 'void))
+		   'void]
+		  [(let ([l (syntax->list t)])
+		     (and l (= 2 (length l))
+			  (identifier? (car l))
+			  (string? (syntax-e (cadr l)))
+			  (module-identifier=? (car l) (quote-syntax pointer))
+			  l))
+		   => (lambda (l)
+			`(pointer , (syntax-e (cadr l))))]
+		  [else
+		   (raise-syntax-error
+		    'c-lambda
+		    "bad type"
+		    stx
+		    t)]))))]
+	  [make-declaration (lambda (type name)
+			      (if (pair? type)
+				  (format "  ~a* ~a;\n"
+					  (cadr type)
+					  name)
+				  (format "  ~a ~a;\n"
+					  (cadr (assq type
+						      '((bool "int")
+							(char "char")
+							(unsigned-char "unsigned char")
+							(signed-char "signed char") 
+							(int "int")
+							(unsigned-int "unsigned int")
+							(short "short")
+							(unsigned-short "unsigned short")
+							(long "long")
+							(unsigned-long "unsigned long")
+							(float "float")
+							(double "double")
+							(scheme-object "Scheme_Object*")
+							(char-string "char*")
+							(nonnull-char-string "char*"))))
+					  name)))]
+	  [extract-c-value (lambda (type c-var scheme-var pos proc-name)
+			     (cond
+			      [(eq? type 'bool) 
+			       (format "  ~a = SCHEME_TRUEP(~a);\n" c-var scheme-var)]
+			      [(eq? type 'scheme-object) 
+			       (format "  ~a = ~a;\n" c-var scheme-var)]
+			      [else
+			       (let-values ([(setup tester unwrapper type-name done)
+					     (if (pair? type)
+						 (values #f
+							 (format "(SCHEME_FALSEP(~~a) ~
+                                                                  || (SCHEME_CPTRP(~a) && SCHEME_BYTE_STRINGP(SCHEME_CPTR_TYPE(~a)) ~
+                                                                      && !strcmp(SCHEME_BYTE_STR_VAL(SCHEME_CPTR_TYPE(~a)), ~s)))"
+								 scheme-var scheme-var scheme-var (cadr type))
+							 (format "(SCHEME_TRUEP(~~a) ? SCHEME_CPTR_VAL(~a) : NULL)"
+								 scheme-var)
+							 (format "cpointer of type ~s or #f"
+								 (cadr type))
+							 #f)
+						 (case type
+						   [(char unsigned-char signed-char) 
+						    (values #f
+							    "SCHEME_CHARP(~a)"
+							    "SCHEME_CHAR_VAL(~a)"
+							    "character"
+							    #f)]
+						   [(int long) 
+						    (values " { long tmp;\n"
+							    "scheme_get_int_val(~a, &tmp)"
+							    "tmp  /* ~a */"
+							    (format "exact integer between (expt 2 -31) ~
+                                                                     and (sub1 (expr 2 31)) inclusive")
+							    " }\n")]
+						   [(unsigned-int unsigned-long)
+						    (values " { unsigned long tmp;\n"
+							    "scheme_get_unsigned_int_val(~a, &tmp)"
+							    "tmp /* ~a */"
+							    "exact integer between 0 and (sub1 (expr 2 32)) inclusive"
+							    " }\n")]
+						   [(short)
+						    (values #f
+							    "(SCHEME_INTP(~a) \
+                                                             && (long)((short)SCHEME_INT_VAL(~a)) == SCHEME_iNT_VAL(~a))"
+							    "SCHEME_INT_VAL(~a)"
+							    (format "exact integer between (expt 2 -15) ~
+                                                                     and (sub1 (expr 2 15)) inclusive")
+							    #f)]
+						   [(unsigned-short)
+						    (values #f
+							    "(SCHEME_INTP(~a) ~
+                                                              && (long)((unsigned short)SCHEME_INT_VAL(~a)) ~
+                                                                        == SCHEME_iNT_VAL(~a))"
+							    "SCHEME_INT_VAL(~a)"
+							    "exact integer between 0 and (sub1 (expr 2 16)) inclusive"
+							    #f)]
+						   [(float double)
+						    (values #f
+							    "SCHEME_REALP(~a)"
+							    "scheme_real_to_double(~a)"
+							    "real number"
+							    #f)]
+						   [(char-string)
+						    (values #f
+							    (format "SCHEME_FALSEP(~~a) || SCHEME_BYTE_STRINGP(~a)"
+								    scheme-var)
+							    (format "(SCHEME_FALSEP(~~a) ? NULL : SCHEME_BYTE_STR_VAL(~a))" 
+								    scheme-var)
+							    "byte string or #f"
+							    #f)]
+						   [(nonnull-char-string)
+						    (values #f
+							    "SCHEME_BYTE_STRINGP(~a)"
+							    "SCHEME_BYTE_STR_VAL(~a)" 
+							    "byte string"
+							    #f)]
+						   [else (error 'cffi "bad type for arg: ~a" type)]))])
+				 (string-append
+				  (or setup "")
+				  (format "  if (~a) {\n" (format tester scheme-var))
+				  (format "    ~a = ~a;\n" c-var (format unwrapper scheme-var))
+				  (format "  } else {\n")
+				  (format "    scheme_wrong_type(~s, ~s, ~a, argc, argv);\n    return NULL;\n"
+					  (symbol->string proc-name) type-name pos)
+				  (format "  }\n")
+				  (or done "")))]))]
+
+	  [build-scheme-value (lambda (type scheme-var c-var)
+				(let ([builder
+				       (if (pair? type)
+					   (format "(~a ? scheme_make_cptr(~~a, scheme_make_byte_string(~s)) : scheme_false)" 
+						   c-var
+						   (cadr type))
+					   (case type
+					     [(bool) "(~a ? scheme_true : scheme_false)"]
+					     [(char unsigned-char signed-char) 
+					      "scheme_make_character((unsigned char)~a)"]
+					     [(int long) 
+					      "scheme_make_integer_value(~a)"]
+					     [(unsigned-int unsigned-long)
+					      "scheme_make_integer_value_from_unsigned(~a)"]
+					     [(char-string)
+					      (format "(~~a ? scheme_make_byte_string(~a) : scheme_false)"
+						      c-var)]
+					     [(float double)
+					      "scheme_make_double(~a)"]
+					     [(nonnull-char-string)
+					      "scheme_make_byte_string(~a)"]
+					     [(scheme-object) "~a"]
+					     [else (error 'cffi "bad type for result: ~a" type)]))])
+				  (format "  ~a = ~a;\n"
+					  scheme-var
+					  (format builder c-var))))]
+	  [ffi-index 0])
+
+      (lambda (stx)
+	(syntax-case stx ()
+	  [(_ (arg-type ...) result-type code)
+	   (let ([arg-types (map
+			     (lambda (t)
+			       (parse-type t stx #f))
+			     (syntax->list (syntax (arg-type ...))))]
+		 [result-type (parse-type (syntax result-type) stx #t)]
+		 [code (syntax code)]
+		 [proc-name (or (let ([s (syntax-local-infer-name stx)])
+				  (if (syntax? s)
+				      (syntax-e s)
+				      s))
+				'c-lambda-procedure)])
+	     (unless (string? (syntax-e code))
+	       (raise-syntax-error
+		'c-lambda
+		"not a code or function-name string"
+		stx
+		code))
+	     
+	     ;; Generate the function body
+	     (let ([fname (format "mzc_cffi_~a" ffi-index)]
+		   [code (apply
+			  string-append
+			  (append
+			   (let loop ([n 1][arg-types arg-types])
+			     (if (null? arg-types)
+				 null
+				 (cons
+				  (make-declaration (car arg-types) (format "___arg~a" n))
+				  (loop (add1 n) (cdr arg-types)))))
+			   (if (eq? 'void result-type)
+			       null
+			       (list (make-declaration result-type "___result")
+				     "  Scheme_Object *converted_result;\n"))
+			   (let loop ([n 1][arg-types arg-types])
+			     (if (null? arg-types)
+				 null
+				 (cons
+				  (extract-c-value (car arg-types)
+						   (format "___arg~a" n) 
+						   (format "argv[~a]" (sub1 n))
+						   (sub1 n)
+						   proc-name)
+				  (loop (add1 n) (cdr arg-types)))))
+			   (list " {\n")
+			   (list
+			    (if (regexp-match re:fname (syntax-e code))
+				;; Generate function call
+				(string-append
+				 (if (eq? result-type 'void)
+				     "  "
+				     "  ___result = ")
+				 (syntax-e code)
+				 "("
+				 (let loop ([n 1][arg-types arg-types])
+				   (if (null? arg-types)
+				       ""
+				       (string-append
+					(format "___arg~a~a" 
+						n
+						(if (pair? (cdr arg-types))
+						    ", "
+						    ""))
+					(loop (add1 n) (cdr arg-types)))))
+				 ");\n")
+				;; Use literal code
+				(string-append (syntax-e code) "\n")))
+			   (if (eq? result-type 'void)
+			       null
+			       (list
+				(build-scheme-value result-type "converted_result" "___result")))
+			   (list
+			    "#ifdef ___AT_END\n"
+			    "  ___AT_END\n"
+			    "#undef ___AT_END\n"
+			    "#endif\n")
+			   (list " }\n")
+			   (list
+			    (if (eq? result-type 'void)
+				"  return scheme_void;\n"
+				"  return converted_result;\n"))))])
+	       (set! ffi-index (add1 ffi-index))
+	       (with-syntax ([fname fname]
+			     [code code]
+			     [arity (length arg-types)]
+			     [proc-name proc-name]
+			     [args (generate-temporaries arg-types)])
+		 (let ([stx-out (syntax
+				 (lambda args
+				   (error 'proc-name "c-lambda expression not compiled by mzc")
+				   '(fname
+				     proc-name
+				     arity
+				     code)))])
+		   (syntax-property stx-out 'mzc-cffi 'c-lambda)))))]))))
+  
+  (define-syntax (c-declare stx)
+    (unless (memq (syntax-local-context) '(top-level module))
+      (raise-syntax-error #f "only allowed at the top-level or a module top-level" stx))
+    (syntax-case stx ()
+      [(_ str)
+       (let ([decl (syntax str)])
+	 (unless (string? (syntax-e decl))
+	   (raise-syntax-error 'c-declare "declaration is not a string" stx decl))
+	 (let ([stx-out (syntax
+			 (error 'c-declare 
+				"declaration not compiled by mzc: ~e"
+				str))])
+	   (syntax-property stx-out 'mzc-cffi 'c-declare)))]))
+
+
+  (define-syntax (c-include stx)
+    (unless (memq (syntax-local-context) '(top-level module))
+      (raise-syntax-error #f "only allowed at the top-level or a module top-level" stx))
+    (syntax-case stx () 
+      [(_ path)
+       (let ([pathname (resolve-path-spec #'path #'path stx #'build-path)])
+         (let ([str
+                (with-handlers ([exn:fail?
+                                 (lambda (x)
+                                   (raise-syntax-error
+                                    #f
+                                    (format "error reading file ~e: ~a"
+                                            pathname
+                                            (if (exn? x)
+                                                (exn-message x)
+                                                x))))])
+                  (with-input-from-file pathname
+                    (lambda () (read-string (file-size pathname)))))])
+           (quasisyntax/loc stx (c-declare #,str))))]))
+      
+  (provide c-lambda
+	   c-declare
+           c-include))
diff --git a/collects/compiler/comp-unit.ss b/collects/compiler/comp-unit.ss
new file mode 100644
index 0000000000..d6087aab11
--- /dev/null
+++ b/collects/compiler/comp-unit.ss
@@ -0,0 +1,7 @@
+
+(module comp-unit mzscheme
+  (require "private/base.ss")
+
+  (define comp@ base@)
+
+  (provide comp@))
diff --git a/collects/compiler/compiler-unit.ss b/collects/compiler/compiler-unit.ss
new file mode 100644
index 0000000000..5e1b138e52
--- /dev/null
+++ b/collects/compiler/compiler-unit.ss
@@ -0,0 +1,278 @@
+;; Main compilation procedures
+;; (c) 1997-2001 PLT
+
+;; The various procedures provided by this library are implemented
+;;  by dynamically linking to code supplied by the MzLib, dynext, and
+;;  compiler collections.
+
+;; The Scheme->C compiler is loaded as either sploadr.ss (link in
+;;  real MrSpidey) or loadr.ss (link in trivial MrSpidey stubs).
+
+(module compiler-unit mzscheme 
+  (require (lib "unitsig.ss"))
+
+  (require "sig.ss")
+  (require (lib "file-sig.ss" "dynext")
+	   (lib "link-sig.ss" "dynext")
+	   (lib "compile-sig.ss" "dynext")
+	   
+	   (lib "make-sig.ss" "make")
+	   (lib "collection-sig.ss" "make")
+
+	   (lib "toplevel.ss" "syntax")
+	   (lib "moddep.ss" "syntax"))
+
+  (require (lib "list.ss")
+	   (lib "file.ss")
+	   (lib "compile.ss") ; gets compile-file
+	   (lib "cm.ss")
+	   (lib "getinfo.ss" "setup"))
+
+  (provide compiler@)
+
+  (define orig-namespace (current-namespace))
+
+  ;; ;;;;;;;; ----- The main compiler unit ------ ;;;;;;;;;;
+  (define compiler@
+    (unit/sig compiler^
+      (import compiler:option^
+	      dynext:compile^
+	      dynext:link^
+	      dynext:file^)
+
+      (define compile-notify-handler
+	(make-parameter void))
+
+      (define current-compiler-dynamic-require-wrapper
+	(make-parameter (lambda (thunk)
+			  (parameterize ([current-namespace orig-namespace])
+			    (thunk)))))
+
+      (define (c-dynamic-require path id)
+	((current-compiler-dynamic-require-wrapper)
+	 (lambda ()
+	   (dynamic-require path id))))
+      (define (c-get-info cp)
+	((current-compiler-dynamic-require-wrapper)
+	 (lambda ()
+	   (get-info cp))))
+
+      (define (make-extension-compiler mode prefix)
+	(let ([u (c-dynamic-require `(lib "base.ss" "compiler" "private")
+				    'base@)]
+	      [init (unit/sig ()
+		      (import compiler:inner^)
+		      (eval-compile-prefix prefix)
+		      (case mode
+			[(compile-extension) compile-extension]
+			[(compile-extension-to-c) compile-extension-to-c]
+			[(compile-c-extension) compile-c-extension]
+			[(compile-extension-part) compile-extension-part]
+			[(compile-extension-part-to-c) compile-extension-part-to-c]
+			[(compile-c-extension-part) compile-c-extension-part]))])
+	  (invoke-unit/sig
+	   (compound-unit/sig
+	    (import (COMPILE : dynext:compile^)
+		    (LINK : dynext:link^)
+		    (DFILE : dynext:file^)
+		    (OPTION : compiler:option^))
+	    (link [COMPILER : compiler:inner^ (u COMPILE
+						 LINK
+						 DFILE
+						 OPTION)] 
+		  [INIT : () (init COMPILER)])
+	    (export))
+	   dynext:compile^
+	   dynext:link^
+	   dynext:file^
+	   compiler:option^)))
+
+      (define (make-compiler mode) 
+	(lambda (prefix)
+	  (let ([c (make-extension-compiler mode prefix)])
+	    (lambda (source-files destination-directory)
+	      (map
+	       (lambda (source-file)
+		 (c source-file (or destination-directory 'same)))
+	       source-files)))))
+
+      (define (make-unprefixed-compiler mode)
+	(let ([f #f])
+	  (lambda (source-files destination-directory)
+	    (unless f
+	      (set! f ((make-compiler mode) '(void))))
+	    (f source-files destination-directory))))
+
+      (define compile-extensions
+	(make-compiler 'compile-extension))
+      (define compile-extensions-to-c
+	(make-compiler 'compile-extension-to-c))
+      (define compile-c-extensions
+	(make-unprefixed-compiler 'compile-c-extension))
+
+      (define compile-extension-parts
+	(make-compiler 'compile-extension-part))
+      (define compile-extension-parts-to-c
+	(make-compiler 'compile-extension-part-to-c))
+      (define compile-c-extension-parts
+	(make-unprefixed-compiler 'compile-c-extension-part))
+
+      (define (link/glue-extension-parts link? source-files destination-directory)
+	(let ([u (c-dynamic-require '(lib "ld-unit.ss" "compiler") 'ld@)]
+	      [init (unit/sig ()
+		      (import compiler:linker^)
+		      (if link?
+			  link-extension
+			  glue-extension))])
+	  (let ([f (invoke-unit/sig
+		    (compound-unit/sig
+		     (import (COMPILE : dynext:compile^)
+			     (LINK : dynext:link^)
+			     (DFILE : dynext:file^)
+			     (OPTION : compiler:option^))
+		     (link [LINKER : compiler:linker^ (u COMPILE 
+							 LINK
+							 DFILE
+							 OPTION)]
+			   [INIT : () (init LINKER)])
+		     (export))
+		    dynext:compile^
+		    dynext:link^
+		    dynext:file^
+		    compiler:option^)])
+	    (f source-files destination-directory))))
+
+      (define (link-extension-parts source-files destination-directory)
+	(link/glue-extension-parts #t source-files destination-directory))
+
+      (define (glue-extension-parts source-files destination-directory)
+	(link/glue-extension-parts #f source-files destination-directory))
+
+      (define (compile-to-zo src dest namespace eval?)
+	((if eval? (lambda (t) (t)) with-module-reading-parameterization)
+	 (lambda ()
+	   (parameterize ([current-namespace namespace])
+	     (compile-file src dest
+			   (if eval?
+			       (lambda (expr)
+				 (expand-syntax-top-level-with-compile-time-evals expr))
+			       values)))))
+	(printf " [output to \"~a\"]~n" dest))
+
+      (define (compile-zos prefix)
+	(let ([n (if prefix (make-namespace) (current-namespace))])
+	  (when prefix
+	    (eval prefix n))
+	  (lambda (source-files destination-directory)
+	    (let ([file-bases (map
+			       (lambda (file)
+				 (let ([f (extract-base-filename/ss file 'mzc)])
+				   (if destination-directory
+				       (let-values ([(base file dir?) (split-path f)])
+					 (build-path (if (eq? destination-directory 'auto)
+							 (let ([d (build-path (if (eq? base 'relative)
+										  'same
+										  base)
+									      "compiled")])
+							   (unless (directory-exists? d)
+							     (make-directory* d))
+							   d)
+							 destination-directory)
+						     file))
+				       f)))
+			       source-files)])
+	      (for-each
+	       (lambda (f b)
+		 (let ([zo (append-zo-suffix b)])
+		   (compile-to-zo f zo n prefix)))
+	       source-files file-bases)))))
+
+      (define (compile-directory dir info zos?)
+	(let ([make (c-dynamic-require '(lib "make-unit.ss" "make") 'make@)]
+	      [coll (c-dynamic-require '(lib "collection-unit.ss" "make") 'make:collection@)]
+	      [init (unit/sig ()
+		      (import make^ make:collection^)
+		      (values make-collection make-notify-handler))])
+	  (let-values ([(make-collection make-notify-handler)
+			(invoke-unit/sig
+			 (compound-unit/sig
+                           (import (DFILE : dynext:file^)
+                                   (OPTION : compiler:option^)
+                                   (COMPILER : compiler^))
+                           (link [MAKE : make^ (make)]
+                                 [COLL : make:collection^ (coll MAKE
+                                                                DFILE
+                                                                OPTION
+                                                                COMPILER)]
+                                 [INIT : () (init MAKE COLL)])
+                           (export))
+			 dynext:file^
+			 compiler:option^
+			 compiler^)])
+	    (let ([orig (current-directory)])
+	      (dynamic-wind
+               (lambda () (current-directory dir))
+               (lambda ()
+                 (parameterize ([current-load-relative-directory dir])
+                   ;; Compile the collection files via make-collection
+                   (let ([sses (filter
+                                extract-base-filename/ss
+                                (directory-list))])
+                     (let ([filtered-sses
+                            (remove*
+                             (map string->path
+                                  (info 
+                                   (if zos? 
+                                       'compile-zo-omit-files 
+                                       'compile-extension-omit-files)
+                                   (lambda () null)))
+                             (remove*
+                              (map string->path
+                                   (info 'compile-omit-files (lambda () null)))
+                              sses))])
+                       (if zos?
+                           ;; Verbose compilation manager:
+                           (parameterize ([manager-trace-handler (lambda (s) (printf "~a~n" s))]
+                                          [manager-compile-notify-handler (lambda (path)
+                                                                            ((compile-notify-handler) path))])
+                             (map (make-caching-managed-compile-zo) filtered-sses))
+                           ;; Old collection compiler:
+                           (parameterize ([make-notify-handler (lambda (path)
+                                                                 ((compile-notify-handler) path))])
+                             (make-collection
+                              ((or info (lambda (a f) (f)))
+                               'name 
+                               (lambda () (error 'compile-collection "info did not provide a name in ~e" 
+                                                 dir)))
+                              filtered-sses
+                              (if zos? #("zo") #()))))))))
+               (lambda () (current-directory orig)))
+	      (when (compile-subcollections)
+		(for-each
+                 ;; bug! planet files will do the wrong thing here
+		 (lambda (s)
+		   (unless (and (pair? s) (list? s) (andmap string? s))
+		     (error 'compile-collection "bad sub-collection path: ~a" s))
+		   (let ((p (apply build-path dir s)))
+                     (compile-directory p (get-info/full p) zos?)))
+		 (info 'compile-subcollections (lambda () null))))))))
+      
+      (define (compile-collection cp zos?)
+        (let ([dir (apply collection-path cp)]
+              [info (c-get-info cp)])
+          (compile-directory dir info zos?)))
+
+      (define (compile-collection-extension collection . cp)
+	(compile-collection (cons collection cp) #f))
+      
+      (define (compile-collection-zos collection . cp)
+	(compile-collection (cons collection cp) #t))
+      
+      (define (compile-directory-extension dir info)
+        (compile-directory dir info #f))
+      
+      (define (compile-directory-zos dir info)
+        (compile-directory dir info #t))
+      
+      
+      )))
diff --git a/collects/compiler/compiler.ss b/collects/compiler/compiler.ss
new file mode 100644
index 0000000000..caf139681c
--- /dev/null
+++ b/collects/compiler/compiler.ss
@@ -0,0 +1,28 @@
+
+(module compiler mzscheme
+  (require (lib "unitsig.ss"))
+  
+  (require "sig.ss")
+
+  (require (lib "compile-sig.ss" "dynext"))
+  (require (lib "link-sig.ss" "dynext"))
+  (require (lib "file-sig.ss" "dynext"))
+  ;;
+  (require (lib "compile.ss" "dynext"))
+  (require (lib "link.ss" "dynext"))
+  (require (lib "file.ss" "dynext"))
+
+  (require "option.ss")
+
+  (require "compiler-unit.ss")
+
+  (define-values/invoke-unit/sig compiler^
+    compiler@
+    #f
+    compiler:option^
+    dynext:compile^
+    dynext:link^
+    dynext:file^)
+
+  (provide-signature-elements compiler^))
+
diff --git a/collects/compiler/doc.txt b/collects/compiler/doc.txt
new file mode 100644
index 0000000000..21bc2e470c
--- /dev/null
+++ b/collects/compiler/doc.txt
@@ -0,0 +1,534 @@
+
+The Compiler
+============
+
+To use the compiler within a Scheme program, require _compiler.ss_:
+  (require (lib "compiler.ss" "compiler"))
+The _compiler.ss_ library defines the following functions (plus a few
+signatures).  Options that control the compiler are documented in the
+next section.
+
+ Single-file extension compilation
+ ---------------------------------
+
+>  ((compile-extensions expr) scheme-file-list dest-dir)
+
+      `(compile-extensions expr)' returns a compiler that is
+      initialized with the elaboration-time expression `expr', as
+      described below.
+
+      The compiler takes a list of Scheme files and compiles each of
+      them to an extension, placing the resulting extensions in the
+      directory specified by `dest-dir'.  If `dest-dir' is #f, each
+      extension is placed in the same directory as its source file.
+      If `dest-dir' is 'auto, each extension file is placed in a
+      "compiled/native/<PLATFORM>" subdirectory relative to the source
+      file, where <PLATFORM> is the result of
+      `system-library-subpath'. (The directory is created if
+      necessary.)
+
+      `expr' effect:
+
+       If `expr' is anything other than #f, then a namespace is
+       created for compiling the files that are supplied later; `expr'
+       is evaluated to initialize the created namespace. For example,
+       `expr' might load a set of macros. In addition, the
+       expansion-time part of each expression later compiled is
+       evaluated in the namespace before being compiled, so that the
+       effects are visible when compiling later expressions.
+
+       If `expr' is #f, then no compilation namespace is created, and
+       expressions in the files are assumed to compile independently
+       (so there's no need to evaluate the expansion-time part of an
+       expression to compile).
+
+       Typically, `expr' is #f for compiling `module' files and
+       `(void)' for compiling files with top-level definitions and
+       expressions.
+
+>  ((compile-extensions-to-c expr) scheme-file-list dest-dir)
+
+     Like `compile-extensions', but only .c files are produced, not
+     extensions.
+
+>  (compile-c-extensions c-file-list dest-dir)
+
+     Compiles each .c file (usually produced with `compile-extensions-to-c') 
+     in c-file-list to an extension.  `dest-dir' is handled as in
+     `compile-extensions'.
+
+ Multi-file extension compilation
+ ---------------------------------
+
+>  ((compile-extension-parts expr) scheme-file-list dest-dir)
+
+      `(compile-extension-parts expr)' returns a compiler that is
+      initialized with the elaboration-time expression `expr'.
+
+      See `compile-extension' above for information about the effect
+      of `expr'.
+
+      The compiler takes a list of Scheme files and compiles each of
+      them to a linkable object and a .kp (constant pool) file,
+      placing the resulting objects and .kp files in the directory
+      specified by `dest-dir'.  If `dest-dir' is #f, each object and
+      .kp file is placed in the same directory as its source file.  If
+      `dest-dir' is 'auto, each .kp file is placed in a
+      "compiled/native" subdirectory relative to the source file, and
+      each object file is placed in "compiled/native/<PLATFORM>",
+      where <PLATFORM> is the result of `system-library-subpath'. (The
+      directory is created if necessary.)
+
+>  ((compile-extension-parts-to-c expr)  scheme-file-list dest-dir)
+
+     Like `compile-extension-parts', but only .c and .kp files are
+     produced, not compiled objects. If `dest-dir' is 'auto, each
+     output file is placed in a "compiled/native" subdirectory
+     relative to the source file.
+
+>  (compile-c-extension-parts c-file-list dest-dir)
+
+     Compiles each .c file (produced with `compile-extension-parts-to-c')
+     in c-file-list to an extension.
+
+>  (link-extension-parts obj-and-kp-file-list dest-dir)
+
+     Links objects for a multi-object extension together, using .kp
+     files to generate and link pooled constants.  The objects and
+     .kp files in `obj-and-kp-file' can be in any order.  The resulting
+     extension "_loader" is placed in the directory specified by `dest-dir'.
+
+>  (glue-extension-parts obj-and-kp-file-list dest-dir)
+
+     Like `link-extension-parts', but only a "_loader" object file
+     is generated; this object file is linked with all the other
+     object files to produce the "_loader" extension.
+
+ zo compilation
+ --------------
+
+>  ((compile-zos expr) scheme-file-list dest-dir)
+
+      `(compile-zos expr)' returns a compiler that is initialized with
+      the elaboration-time expression `expr'.
+
+      See `compile-extensions' above for information about the effect
+      of `expr'.
+
+      The returned compiler takes a list of Scheme files and compiles
+      each of them to a .zo file, placing the resulting .zo files in
+      the directory specified by `dest-dir'.  If `dest-dir' is #f,
+      each .zo file is placed in the same directory as its source
+      file. If `dest-dir' is 'auto, each .zo file is placed in a
+      "compiled" subdirectory relative to the source file. (The
+      directory is created if necessary.)
+ 
+ Collection compilation
+ ----------------------
+
+>  (compile-collection-extension collection sub-collection ...)
+
+      Compiles the specified (sub-)collection to an extension
+      "_loader", putting intermediate .c and .kp files in the
+      collection's "compiled/native" directory, and object files and
+      the resulting "_loader" extension in the collection's
+      "compiled/native/PLATFORM" directory (where `PLATFORM' is the
+      system name for the current platform).
+
+      The collection compiler reads the collection's _info.ss_ file
+      (see the mzc manual for information about info.ss) to obtain
+      information about compiling the collection.  The following
+      fields are used:
+
+>      name - the name of the collection as a string.
+
+>      compile-omit-files - a list of filenames (without paths); all
+         Scheme files in the collection are compiled except for the
+         files in this list.  If a file contains elaboration time
+         expressions (e.g., macros, signatures) that are not intended
+         to be local to the file, then the file should be included in
+         this list.
+
+>      compile-extension-omit-files - a list of filenames to extend
+         the list returned for `compile-omit-files'. Unlike the list
+         returned for `compile-omit-files', this extension is not used
+         when compiling .zo files.
+
+>      compile-subcollections - a list of collection paths, where each
+         path is a list of strings. `compile-collection-extension' is 
+         applied to each of the collections.
+
+      Only the `name' field is required from info.ss.(Note: Setup PLT
+      uses this field as an indication that the collection should be
+      compiled.)
+
+      The compilation process is driven by the 'make-collection'
+      function in the "collection.ss" library of the "make"
+      collection.
+
+>  (compile-directory-extension path info-function)
+
+      Like `compile-collection-extension', but compiles the given 
+      directory rather than a collection. Also takes an info
+      function (the result of `get-info' or `get-info/full'; see 
+      the setup collection's documentation for more information)
+      that will be used to guide compilation instead of looking for
+      an info.ss file in the directory.
+
+>  (compile-collection-zos collection sub-collection ...)
+
+      Compiles the specified (sub-)collection files to .zo files.
+      The .zo files are placed into the collection's "compiled"
+      directory.
+
+      The _info.ss_ file is used as in `compile-collection-extension',
+      except for `compile-extension-omit-files'. In addition, the
+      following two fields are used:
+
+>      compile-zo-omit-files - a list of filenames to extend the
+         list returned for 'compile-omit-files.
+
+      The compilation process is driven by the `managed-compile-zo'
+      function in the "cm.ss" library of the "mzlib" collection.
+
+>  (compile-directory-zos path info-function)
+
+      Like `compile-collection-zos', but compiles the given directory
+      rather than a collection. Also takes an info function (the
+      result of `get-info' or `get-info/full'; see the setup
+      collection's documentation for more information) that will be
+      used to guide compilation instead of looking for an info.ss file
+      in the directory.
+
+
+ Loading compiler support
+ ------------------------
+
+The compiler unit loads certain tools on demand via `dynamic-require'
+and `get-info'. If the namespace used during compilation is different
+from the namespace used to load the compiler, or if other load-related
+parameters are set, then the following parameter can be used to
+restore settings for `dyanmic-require'.
+
+>  current-compiler-dynamic-require-wrapper
+
+    A parameter whose value is a procedure that takes a thunk to
+    apply. The default wrapper sets the current namespace (via
+    `parameterize') before calling the thunk; it sets it to the
+    namespace that was current at the time that the "compiler-unit.ss"
+    module was evaluated.
+
+---------------------------------------------------------------------------
+
+Options for the Compiler
+========================
+
+To set options for the _compile.ss_ extension compiler, use the
+_option.ss_ module. Options are set by the following parameters:
+
+> verbose - #t causes the compiler to print
+     verbose messages about its operations.  Default = #f.
+
+> setup-prefix - a string to embed in public names.
+     This is used mainly for compiling extensions with the collection
+     name so that cross-extension conflicts are less likely in
+     architectures that expose the public names of loaded extensions.
+     Note that `compile-collection' handles prefixing automatically
+     (by setting this option).  Default = "".
+
+> clean-intermediate-files - #t keeps intermediate
+     .c/.o files.  Default = #f.
+
+> compile-subcollections - #t uses info.ss's
+     'compile-subcollections' for compiling collections. Default = #t.
+
+> compile-for-embedded - #t creates .c files and
+     object files to be linked directly with an embedded MzScheme
+     run-time system, instead of .c files and object files to
+     be dynamically loaded into MzScheme as an extension.
+     Default = #f.
+
+> propagate-constants - #t improves the code by
+     propogating constants.  Default = #t.
+
+> assume-primitives - #t equates X with #%X when
+     #%X exists.  This is useful only with non-unitized code.
+     Default = #f.
+
+> stupid - Allow obvious non-syntactic errors; e.g.:
+    ((lambda () 0) 1 2 3).  Default = #f.
+
+> vehicles - Controls how closures are compiled.  The
+    possible values are: 'vehicles:automatic - auto-groups
+                         'vehicles:functions - groups by procedue
+                         'vechicles:units - groups by unit
+                         'vehicles:monolithic - groups randomly
+    Default = 'vehicles:automatic.
+
+> vehicles:monoliths - Sets the number of random
+    groups for 'vehicles:monolithic.
+
+> seed - Sets the randomizer seed for
+    'vehicles:monolithic.
+
+> max-exprs-per-top-level-set - Sets the number of
+    top-level Scheme expressions crammed into one C function.  Default
+    = 25.
+
+> unpack-environments - #f might help for
+    register-poor architectures.  Default = #t.
+
+> debug - #t creates debug.txt debugging file.  Default
+    = #f.
+
+> test - #t ignores top-level expressions with syntax
+   errors.  Default = #f.
+
+More options are defined by the compile.ss and link.ss libraries in
+the `dynext' collection . Those options control the actual C compiler
+and linker that are used. See doc.txt in the `dynext' collection for
+more information about those options.
+
+The _option-unit.ss_ library is a unit/sig matching the signature
+>    compiler:option^
+which contains these options. The _sig.ss_ library defines the
+`compiler:option^' signature.
+
+---------------------------------------------------------------------------
+
+The Compiler as a Unit
+======================
+
+The _compiler-unit.ss_ library provides a unit/sig 
+>      compiler@
+matching the signature
+>      compiler^ 
+which provides the compiler.ss functions.  This signature and all
+auxilliary signatures needed by compiler@ are defined by the
+_sig.ss_ library.
+
+The signed unit requires the following imports:
+
+   compiler:option^ - From sig.ss, impl by _option-unit.ss_ or _option.ss_
+   dynext:compile^ - From the `dynext' collection
+   dynext:link^
+   dynext:file^
+
+---------------------------------------------------------------------------
+
+Low-level Extension Compiler and Linker
+=======================================
+
+The high-level compiler.ss interface relies on low-level
+implementations of the extension compiler and linker.
+
+The _comp-unit.ss_ and _ld-unit.ss_ libraries define unit/sigs for the
+low-level extension compiler and multi-file linker,
+> ld@
+and
+> comp@
+respectively.
+
+The low-level compiler functions from comp@ are:
+
+> (eval-compile-prefix expr) - Evaluates an elaboration-time
+    S-expression `expr'.  Future calls to mzc:compile-XXX will see the
+    effects of the elaboration expression.
+
+> (compile-extension scheme-source dest-dir) - Compiles a
+    single Scheme file to an extension.
+
+> (compile-extension-to-c scheme-source dest-dir) - Compiles
+    a single Scheme file to a .c file.
+
+> (compile-c-extension c-source dest-dir) - Compiles a single .c
+    file to an extension.
+
+> (compile-extension-part scheme-source dest-dir) - Compiles a
+    single Scheme file to a compiled object and .kp file toward a
+    multi-file extension.
+
+> (compile-extension-part-to-c scheme-source dest-dir) - Compiles
+    a single Scheme file to .c and .kp files towards a multi-file
+    extension.
+
+> (compile-c-extension-part c-source dest-dir) - Compiles a single
+    .c file to a compiled object towards a multi-file extension.
+
+The low-level linker functions from ld@ are:
+
+> (link-extension object-and-kp-file-list dest-dir) - Links
+    compiled object and .kp files into a multi-file extension.
+
+
+Both unit/sigs requires the following imports:
+
+   dynext:compile^ - From the `dynext' collection
+   dynext:link^
+   dynext:file^
+   compiler:option^ - From sig.ss, impl by _option-unit.ss_ or _option.ss_
+
+---------------------------------------------------------------------------
+
+Embedding Scheme Code to Create a Stand-alone Executable
+========================================================
+
+The _embed.ss_ library provides a function to embed Scheme code into a
+copy of MzScheme or MrEd, thus creating a _stand-alone_ Scheme
+executable.
+
+Embedding walks the module dependency graph to find all modules needed
+by some initial set of top-level modules, compiling them if needed,
+and combining them into a "module bundle". In addition to the module
+code, the bundle extends the module name resolver, so that modules can
+be `require'd with their original names, and they will be retrieved
+from the bundle instead of the filesystem.
+
+The `make-embedding-executable' function combines the bundle with an
+executable (MzScheme or MrEd). The `write-module-bundle' function
+prints the bundle to the current output port, instead; this stream can
+be `load'ed directly by a running program, as long as the
+`read-accept-compiled' parameter is true.
+
+The _embedr-unit.ss_ library provides a signed unit, _compiler:embed@_
+that imports nothing and exports the functions below. The
+_embedr-sig.ss_ library provides the signature, _compiler:embed^_.
+
+> (make-embedding-executable dest mred? verbose? mod-list literal-file-list literal-sexpr cmdline-list [aux launcher? variant])
+  - Copies the MzScheme (if `mred?' is #f) or MrEd (otherwise) binary,
+  embedding code into the copied executable to be loaded on startup.
+  The source executable is located relative to the "mzlib" collection.
+
+  See the mzc documentation for a simpler interface that is
+  well-suited to programs defined with `module'.
+
+  The embeddeding executable is written to `dest', which is
+  overwritten if it exists already (as a file or directory).
+
+  The embedded code consists of module declaratons followed by
+  additional (arbitrary) code. When a module is embedded, every module
+  that it imports is also embedded. Library modules are embedded so
+  that they are accessible via their `lib' paths in the initial
+  namespace' except as specified in `mod-list', other modules
+  (accessed via local paths and absolte paths) are embedded with a
+  generated prefix, so that they are not directly accessible.
+
+  The `mod-list' argument designates modules to be embedded, as
+  described below. The `literal-file-list' and `literal-sexp'
+  arguments specifiy literal code to be copied into the executable:
+  the content of each file in `literal-file-list' is copied in order
+  (with no intervening space), followed by `literal-sexp'. The
+  `literal-file-list' files or `literal-sexp' can contain compiled
+  bytecode, and it's possible that the content of the
+  `literal-file-list' files only parse when concatenated; the files
+  and expression are not compiled or inspected in any way during the
+  embedding process. If `literal-sexp' is #f, no literal expression is
+  included in the executable.
+
+  The `cmdline-list' argument contains command-line strings that are
+  prefixed onto any actual command-line arguments that are provided to
+  the embedding executable. A command-line argument that evaluates an
+  expression or loads a file will be executed after the embedded code
+  is loaded.
+
+  Each element of the `mod-list' argument is a 2-item list, where the
+  first item is a prefix for the module name, and the second item is a
+  module path datum (that's in the format understood by the default
+  module name resolver). The prefix can be a symbol, #f to indicate no
+  prefix, or #t to indicate an auto-generated prefix. For example,
+
+    '((#f "m.ss"))
+
+  embeds the module `m' from the file "m.ss", without prefixing the
+  name of the module; the `literal-sexpr' argument to go with the
+  above might be '(require m).
+
+  All modules are compiled before they are embedded into the target
+  executable.
+
+  When embedding into a copy of MrEd, a "-Z" flag should usually be
+  included in the list of command-line flags, so that the target
+  executable has a chance to see an embedded declaration of (lib
+  "mred.ss" "mred"). Then, if the literal code expect to have MrEd and
+  the class library required into the top-level namespace, literal
+  `require's for thoselibraries should be included at the start.
+
+   The optional `aux' argument is an association list for
+   platform-specific options (i.e., it is a list of pairs where the
+   first element of the pair is a key symbol and the second element is
+   the value for that key). The currently supported keys are as
+   follows:
+
+      _'icns_ (Mac OS X) - an icon file path (suffix ".icns") to
+              use for the executable's desktop icon
+
+      _'ico_ (Windows) - an icon file path (suffix ".ico") to
+              use for the executable's desktop icon; the executable
+              will have 16x16, 32x32, and 48x48 icons at 4-bit,
+              8-bit, and 32-bit (RBBA) depths; the icons are
+              copied and generated from any 16x16, 32x32, and 48x48
+              icons in the ".ico" file
+
+      _'creator_ (Mac OS X) - provides a 4-character string to use as
+              the application signature.
+
+      _'file-types_ (Mac OS X) - provides a list of association lists,
+              one for each type of file handled by the application;
+              each association is a 2-element list, where the first (key)
+              element is a string recognized by Finder, and the second
+              element is a plist value (see doc.tx in the "xml" collection);
+              see plt/collects/drscheme/drscheme.filetypes for an example.
+
+      -'resource-files_ (Mac OS X) - extra files to copy into the
+              "Resources" directory of the generated executable
+
+      _'forget-exe?_ (Windows, Mac OS X) - a boolean; #t for a launcher
+              (see `launcher?' below) does not preserve the original
+              executable name for `(find-system-path 'exec-file)'; the
+              main consequence is that library collections will be
+              found relative to the launcher instead of the original
+              executable
+
+   See also `build-aux-from-path' in the "launcher" collection. The
+   default `aux' is `null'.
+
+   If `launcher?' is #t, then no `modules' should be null,
+   `literal-file-list' should be null, `literal-sexp' should be #f,
+   and the platform should be Windows or Mac OS X. The embedding
+   executable is created in such a way that `(find-system-path
+   'exec-file)' produces the source MzScheme or MrEd path instead of
+   the embedding executable.
+
+   The `variant' argument indicates which variant of the original
+   binary to use for embedding. The default is 'normal, and typically
+   the only other possibility is '3m. See `current-launcher-variant'
+   in the "launcher" collection for more information.
+
+
+> (write-module-bundle verbose? mod-list literal-file-list literal-sexpr)
+  - Like `make-embedding-executable', but the module bundle is written
+  to the current output port instead of being embedded into an
+  executable.  The output of this function can be `read' to load and
+  instantiate `mod-list' and its dependencies, adjust the module name
+  resolver to find the newly loaded modules, evaluate the forms
+  included from `literal-file-list', and finally evaluate
+  `literal-sexpr'. The `read-accept-compiled' parameter must be true
+  to read the stream.
+
+
+> (embedding-executable-is-directory? mred?) - Returns #t if
+  Mzscheme/MrEd executables for the current platform correspond to
+  directories (as on Mac OS X).
+
+
+> (embedding-executable-put-file-extension+style+filters mred?) -
+  Returns three values suitable for use as the `extension', `style',
+  and `filters' arguments to `put-file', respectively. If
+  MzScheme/MrEd launchers for this platform are directories, the
+  `style' result is suitable for use with `get-directory', and the
+  `extension' result may be a string indicating a required extension
+  for the directory name (e.g., ".app" for Mac OS X).
+
+
+> (embedding-executable-add-suffix path mred?) - Returns a path with a
+  suitable executable suffix added, if it's not present already.
diff --git a/collects/compiler/embed-sig.ss b/collects/compiler/embed-sig.ss
new file mode 100644
index 0000000000..d6fd69d078
--- /dev/null
+++ b/collects/compiler/embed-sig.ss
@@ -0,0 +1,11 @@
+
+(module embed-sig mzscheme
+  (require (lib "unitsig.ss"))
+  (provide compiler:embed^)
+
+  (define-signature compiler:embed^
+    (make-embedding-executable
+     write-module-bundle
+     embedding-executable-is-directory?
+     embedding-executable-put-file-extension+style+filters
+     embedding-executable-add-suffix)))
diff --git a/collects/compiler/embed-unit.ss b/collects/compiler/embed-unit.ss
new file mode 100644
index 0000000000..e8da04ec55
--- /dev/null
+++ b/collects/compiler/embed-unit.ss
@@ -0,0 +1,563 @@
+
+(module embed-unit mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "file.ss")
+	   (lib "list.ss")
+	   (lib "etc.ss")
+	   (lib "port.ss")
+	   (lib "moddep.ss" "syntax")
+	   (lib "plist.ss" "xml")
+	   "embed-sig.ss"
+	   "private/winicon.ss")
+
+  (provide compiler:embed@)
+
+  (define compiler:embed@
+    (unit/sig compiler:embed^
+      (import)
+
+      (define (embedding-executable-is-directory? mred?)
+	(eq? 'macosx (system-type)))
+      
+      (define (embedding-executable-put-file-extension+style+filters mred?)
+	(case (system-type)
+	  [(windows) (values ".exe" null '(("Executable" "*.exe")))]
+	  [(macosx) (values ".app" '(enter-packages) #f)]
+	  [else (values #f null null)]))
+
+      (define (embedding-executable-add-suffix path mred?)
+	(let* ([path (if (string? path)
+			 (string->path path)
+			 path)]
+	       [fixup (lambda (re sfx)
+			(if (regexp-match re (path->bytes path))
+			    path
+			    (path-replace-suffix path sfx)))])
+	  (case (system-type)
+	    [(windows) (fixup #rx#"[.][eE][xX][eE]$" #".exe")]
+	    [(macosx) (if mred?
+			  (fixup #rx#"[.][aA][pP][pP]$" #".app")
+			  path)]
+	    [else path])))
+      
+      ;; Find executable relative to the "mzlib"
+      ;; collection.
+      (define (find-exe mred? variant)
+	(let* ([c-path (collection-path "mzlib")]
+	       [base (build-path c-path 'up 'up)]
+	       [fail
+		(lambda ()
+		  (error 'make-embedding-executable
+			 "can't find ~a executable"
+			 (if mred? "MrEd" "MzScheme")))]
+	       [variant-suffix (case variant
+				 [(normal) ""]
+				 [(3m) "3m"])])
+	  (let ([exe (build-path
+		      base
+		      (case (system-type)
+			[(macosx)
+			 (cond
+			  [(not mred?)
+			   ;; Need MzScheme:
+			   (build-path "bin" (string-append 
+					      "mzscheme"
+					      variant-suffix))]
+			  [mred?
+			   ;; Need MrEd:
+			   (build-path (format "MrEd~a.app" variant-suffix)
+				       "Contents" "MacOS" 
+				       (format "MrEd~a" variant-suffix))])]
+			[(windows)
+			 (format "~a~a.exe" (if mred?
+						"mred"
+						"mzscheme")
+				 variant-suffix)]
+			[(unix)
+			 (build-path "bin"
+				     (format "~a~a" (if mred?
+							"mred"
+							"mzscheme")
+					     variant-suffix))]
+			[(macos)
+			 (format "~a~a" (if mred?
+					    "MrEd"
+					    "MzScheme")
+				 variant-suffix)]))])
+	    (unless (or (file-exists? exe)
+			(directory-exists? exe))
+	      (fail))
+	    exe)))
+
+      ;; Find the magic point in the binary:
+      (define (find-cmdline)
+	(let ([m (regexp-match-positions #"\\[Replace me for EXE hack" (current-input-port))])
+	  (if m
+	      (caar m)
+	      (error 
+	       'make-embedding-executable
+	       (format
+		"can't find cmdline position in executable")))))
+
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+      (define (prepare-macosx-mred exec-name dest aux variant)
+	(let* ([name (let-values ([(base name dir?) (split-path dest)])
+		       (path-replace-suffix name #""))]
+	       [variant-suffix (case variant
+				 [(normal) ""]
+				 [(3m) "3m"])]
+	       [src (build-path (collection-path "launcher")
+				(format "Starter~a.app" variant-suffix))]
+	       [creator (let ([c (assq 'creator aux)])
+			  (or (and c
+				   (cdr c))
+			      "MrSt"))]
+	       [file-types (let ([m (assq 'file-types aux)])
+			     (and m
+				  (pair? (cdr m))
+				  (cdr m)))]
+	       [resource-files (let ([m (assq 'resource-files aux)])
+				 (and m
+				      (cdr m)))])
+	  (when creator
+	    (unless (and (string? creator) (= 4 (string-length creator)))
+	      (error 'make-executable "creator is not a 4-character string: ~e" creator)))
+	  (when file-types
+	    (unless (and (list? file-types)
+			 (andmap list? file-types)
+			 (andmap (lambda (spec)
+				   (andmap (lambda (p)
+					     (and (list? p)
+						  (= 2 (length p))
+						  (string? (car p))))
+					   spec))
+				 file-types))
+	      (error 'make-executable "bad file-types spec: ~e" file-types)))
+	  (when resource-files
+	    (unless (and (list? resource-files)
+			 (andmap path-string?
+				 resource-files))
+	      (error 'make-executable "resource-files is not a list of paths: ~e" resource-files)))
+
+	  (when (or (directory-exists? dest)
+		    (file-exists? dest)
+		    (link-exists? dest))
+	    (delete-directory/files dest))
+	  (make-directory* (build-path dest "Contents" "Resources"))
+	  (make-directory* (build-path dest "Contents" "MacOS"))
+	  (copy-file exec-name (build-path dest "Contents" "MacOS" name))
+	  (copy-file (build-path src "Contents" "PkgInfo")
+		     (build-path dest "Contents" "PkgInfo"))
+	  (let ([icon (or (let ([icon (assq 'icns aux)])
+			    (and icon
+				 (cdr icon)))
+			  (build-path src "Contents" "Resources" 
+				      (format "Starter~a.icns" variant-suffix)))])
+	    (copy-file icon
+		       (build-path dest "Contents" "Resources" 
+				   (format "Starter~a.icns" variant-suffix))))
+	  (let ([orig-plist (call-with-input-file (build-path src
+							      "Contents"
+							      "Info.plist")
+			      read-plist)]
+		[plist-replace (lambda (plist . l)
+				 (let loop ([plist plist][l l])
+				   (if (null? l)
+				       plist
+				       (let ([key (car l)]
+					     [val (cadr l)])
+					 (loop `(dict
+						 ,@(let loop ([c (cdr plist)])
+						     (cond
+						      [(null? c) (list (list 'assoc-pair key val))]
+						      [(string=? (cadar c) key)
+						       (cons (list 'assoc-pair key val)
+							     (cdr c))]
+						      [else
+						       (cons (car c)
+							     (loop (cdr c)))])))
+					       (cddr l))))))])
+	    (let* ([new-plist (plist-replace
+			       orig-plist
+			       
+			       "CFBundleExecutable" 
+			       (path->string name)
+			       
+			       "CFBundleSignature"
+			       creator
+			       
+			       "CFBundleIdentifier" 
+			       (format "org.plt-scheme.~a" (path->string name)))]
+		   [new-plist (if file-types
+				  (plist-replace
+				   new-plist
+				   
+				   "CFBundleDocumentTypes"
+				   (cons 'array
+					 (map (lambda (spec)
+						(cons
+						 'dict
+						 (map (lambda (p)
+							(list
+							 'assoc-pair
+							 (car p)
+							   (cadr p)))
+						      spec)))
+					      file-types)))
+				  
+				  new-plist)])
+	      (call-with-output-file (build-path dest 
+						 "Contents" 
+						 "Info.plist")
+		(lambda (port)
+		  (write-plist new-plist port))
+		'truncate)))
+	  (call-with-output-file (build-path dest 
+					     "Contents" 
+					     "PkgInfo")
+	    (lambda (port)
+	      (fprintf port "APPL~a" creator))
+	    'truncate)
+	  (when resource-files
+	    (for-each (lambda (p)
+			(let-values ([(base name dir?) (split-path p)])
+			  (copy-file p (build-path dest
+						   "Contents" 
+						   "Resources"
+						   name))))
+		      resource-files))
+	  (build-path dest "Contents" "MacOS" name)))
+
+      (define (finish-osx-mred dest flags exec-name keep-exe?)
+	(call-with-output-file (build-path dest 
+					   "Contents" 
+					   "Resources" 
+					   "starter-info")
+	  (lambda (port)
+	    (write-plist 
+	     `(dict ,@(if keep-exe?
+			  `((assoc-pair "executable name"
+					,(path->string exec-name)))
+			  null)
+		    (assoc-pair "stored arguments"
+				(array ,@flags)))
+	     port))
+	  'truncate))
+
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+      ;; Represent modules with lists starting with the filename, so we
+      ;; can use assoc:
+      (define (make-mod normal-file-path normal-module-path code name prefix full-name relative-mappings)
+	(list normal-file-path normal-module-path code
+	      name prefix full-name relative-mappings))
+
+      (define (mod-file m) (car m))
+      (define (mod-mod-path m) (cadr m))
+      (define (mod-code m) (caddr m))
+      (define (mod-name m) (list-ref m 3))
+      (define (mod-prefix m) (list-ref m 4))
+      (define (mod-full-name m) (list-ref m 5))
+      (define (mod-mappings m) (list-ref m 6))
+      
+      (define (generate-prefix)
+	(format "#%embedded:~a:" (gensym)))
+      
+      (define (normalize filename)
+	(simplify-path (expand-path filename)))
+
+      ;; Loads module code, using .zo if there, compiling from .scm if not
+      (define (get-code filename module-path codes prefixes verbose?)
+	(when verbose?
+	  (fprintf (current-error-port) "Getting ~s~n" filename))
+	(let ([a (assoc filename (unbox codes))])
+	  (if a
+	      ;; Already have this module. Make sure that library-referenced
+	      ;;  modules are consistently referenced through library paths:
+	      (let ([found-lib? (and (pair? (mod-mod-path a))
+				     (eq? 'lib (car (mod-mod-path a))))]
+		    [look-lib? (and (pair? module-path)
+				    (eq? 'lib (car module-path)))])
+		(cond
+		 [(and found-lib? look-lib?)
+		  'ok]
+		 [(or found-lib? look-lib?)
+		  (error 'find-module
+			 "module referenced both as a library and through a path: ~a"
+			 filename)]
+		 [else 'ok]))
+	      ;; First use of the module. Get code and then get code for imports.
+	      (let ([code (get-module-code filename)])
+		(let-values ([(imports fs-imports ft-imports) (module-compiled-imports code)])
+		  (let ([name (let-values ([(base name dir?) (split-path filename)])
+				(path->string (path-replace-suffix name #"")))]
+			[prefix (let ([a (assoc filename prefixes)])
+				  (if a
+				      (cdr a)
+				      (generate-prefix)))]
+			[all-file-imports (filter (lambda (x) (not (symbol? x)))
+						  (append imports fs-imports ft-imports))])
+		    (let ([sub-files (map (lambda (i) (normalize (resolve-module-path-index i filename)))
+					  all-file-imports)]
+			  [sub-paths (map (lambda (i) (collapse-module-path-index i module-path))
+					  all-file-imports)])
+		      ;; Get code for imports:
+		      (for-each (lambda (sub-filename sub-path)
+				  (get-code sub-filename
+					    sub-path
+					    codes
+					    prefixes
+					    verbose?))
+				sub-files sub-paths)
+		      ;; Build up relative module resolutions, relative to this one,
+		      ;; that will be requested at run-time.
+		      (let ([mappings (map (lambda (sub-i sub-filename)
+					     (let-values ([(path base) (module-path-index-split sub-i)])
+					       ;; Assert: base should refer to this module:
+					       (let-values ([(path2 base2) (module-path-index-split base)])
+						 (when (or path2 base2)
+						   (error 'embed "unexpected nested module path index")))
+					       (let ([m (assoc sub-filename (unbox codes))])
+						 (cons path (mod-full-name m)))))
+					   all-file-imports sub-files)])
+			;; Record the module
+			(set-box! codes
+				  (cons (make-mod filename module-path code 
+						  name prefix (string->symbol
+							       (format "~a~a" prefix name))
+						  mappings)
+					(unbox codes)))))))))))
+	    
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+      (define (make-module-name-resolver code-l)
+	`(let ([orig (current-module-name-resolver)]
+	       [ns (current-namespace)]
+	       [mapping-table (quote
+			       ,(map
+				 (lambda (m)
+				   `(,(mod-full-name m)
+				     ,(mod-mappings m)))
+				 code-l))]
+	       [library-table (quote
+			       ,(filter values
+					(map (lambda (m)
+					       (let ([path (mod-mod-path m)])
+						 (if (and (pair? path)
+							  (eq? 'lib (car path)))
+						     (cons path (mod-full-name m))
+						     #f)))
+					     code-l)))])
+	   (current-module-name-resolver
+	    (lambda (name rel-to stx)
+	      (if (or (not name)
+		      (not (eq? (current-namespace) ns)))
+		  ;; a notification,or wrong namespace
+		  (orig name rel-to stx)
+		  ;; Have a relative mapping?
+		  (let ([a (assoc rel-to mapping-table)])
+		    (if a
+			(let ([a2 (assoc name (cadr a))])
+			  (if a2
+			      (cdr a2)
+			      (error 'embedding-module-name-resolver
+				     "unexpected relative mapping request: ~e in ~e"
+				     name rel-to)))
+			;; A library mapping that we have? 
+			(let ([a3 (and (pair? name)
+				       (eq? (car name) 'lib)
+				       (ormap (lambda (lib-entry)
+						(with-handlers ([exn:fail? (lambda (x) #f)])
+						  ;; To check equality of library references,
+						  ;; we have to consider relative paths in the
+						  ;; filename part of the name.
+						  (let loop ([a (build-path
+								 (apply build-path 
+									'same
+									(cddar lib-entry))
+								 (cadar lib-entry))]
+							     [b (build-path
+								 (apply build-path 
+									'same
+									(let ([d (cddr name)])
+									  (if (null? d)
+									      '("mzlib")
+									      d)))
+								 (cadr name))])
+						    (if (equal? a b)
+							lib-entry
+							(let-values ([(abase aname d?) (split-path a)])
+							  (if (eq? aname 'same)
+							      (loop abase b)
+							      (let-values ([(bbase bname a?) (split-path b)])
+								(if (eq? bname 'same)
+								    (loop a bbase)
+								    (if (equal? aname bname)
+									(loop abase bbase)
+									#f)))))))))
+					      library-table))])
+			  (if a3
+			      ;; Have it:
+			      (cdr a3)
+			      ;; Let default handler try:
+			      (orig name rel-to stx))))))))))
+
+      ;; Write a module bundle that can be loaded with 'load' (do not embed it
+      ;; into an executable). The bundle is written to the current output port.
+      (define (write-module-bundle verbose? modules literal-files literal-expression)
+	(let* ([module-paths (map cadr modules)]
+	       [files (map
+		       (lambda (mp)
+			 (let ([f (resolve-module-path mp #f)])
+			   (unless f
+			     (error 'write-module-bundle "bad module path: ~e" mp))
+			   (normalize f)))
+		       module-paths)]
+	       [collapsed-mps (map
+			       (lambda (mp)
+				 (collapse-module-path mp "."))
+			       module-paths)]
+	       [prefix-mapping (map (lambda (f m)
+				      (cons f (let ([p (car m)])
+						(cond
+						 [(symbol? p) (symbol->string p)]
+						 [(eq? p #t) (generate-prefix)]
+						 [(not p) ""]
+						 [else (error
+							'write-module-bundle
+							"bad prefix: ~e"
+							p)]))))
+				    files modules)]
+	       ;; Each element is created with `make-mod'.
+	       ;; As we descend the module tree, we append to the front after
+	       ;; loasing imports, so the list in the right order.
+	       [codes (box null)])
+	  (for-each (lambda (f mp) (get-code f mp codes prefix-mapping verbose?))
+		    files
+		    collapsed-mps)
+	  ;; Install a module name resolver that redirects
+	  ;; to the embedded modules
+	  (write (make-module-name-resolver (unbox codes)))
+	  (let ([l (unbox codes)])
+	    (for-each
+	     (lambda (nc)
+	       (when verbose?
+		 (fprintf (current-error-port) "Writing module from ~s~n" (mod-file nc)))
+	       (write `(current-module-name-prefix ',(string->symbol (mod-prefix nc))))
+	       (write (mod-code nc)))
+	     l))
+	  (write '(current-module-name-prefix #f))
+	  (newline)
+	  (for-each (lambda (f)
+		      (when verbose?
+			(fprintf (current-error-port) "Copying from ~s~n" f))
+		      (call-with-input-file*
+		       f
+		       (lambda (i)
+			 (copy-port i (current-output-port)))))
+		    literal-files)
+	  (when literal-expression
+	    (write literal-expression))))
+
+      ;; Use `write-module-bundle', but figure out how to put it into an executable
+      (define make-embedding-executable
+	(opt-lambda (dest mred? verbose? 
+			  modules 
+			  literal-files literal-expression
+			  cmdline
+			  [aux null]
+			  [launcher? #f]
+			  [variant 'normal])
+	  (define keep-exe? (and launcher?
+				 (let ([m (assq 'forget-exe? aux)])
+				   (or (not m)
+				       (not (cdr m))))))
+	  (define long-cmdline? (or (eq? (system-type) 'windows)
+				    (and mred? (eq? 'macosx (system-type)))))
+	  (unless (or long-cmdline?
+		      ((apply + (length cmdline) (map (lambda (s)
+							(bytes-length (string->bytes/utf-8 s)))
+						      cmdline)) . < . 50))
+	    (error 'make-embedding-executable "command line too long"))
+	  (let ([exe (find-exe mred? variant)])
+	    (when verbose?
+	      (fprintf (current-error-port) "Copying to ~s~n" dest))
+	    (let-values ([(dest-exe osx?)
+			  (if (and mred? (eq? 'macosx (system-type)))
+			      (values (prepare-macosx-mred exe dest aux variant) #t)
+			      (begin
+				(when (or (file-exists? dest)
+					  (directory-exists? dest)
+					  (link-exists? dest))
+				  ;; Delete-file isn't enough if the target
+				  ;;  is supposed to be a directory. But
+				  ;;  currently, that happens only for MrEd 
+				  ;;  on Mac OS X, which is handles above.
+				  (delete-file dest))
+				(copy-file exe dest)
+				(values dest #f)))])
+	      (with-handlers ([void (lambda (x)
+				      (if osx?
+					  (when (directory-exists? dest)
+					    (delete-directory/files dest))
+					  (when (file-exists? dest)
+					    (delete-file dest)))
+				      (raise x))])
+		(let ([start (file-size dest-exe)])
+		  (with-output-to-file dest-exe
+		    (lambda ()
+		      (write-module-bundle verbose? modules literal-files literal-expression))
+		    'append)
+		  (let ([end (file-size dest-exe)])
+		    (when verbose?
+		      (fprintf (current-error-port) "Setting command line~n"))
+		    (let ([start-s (number->string start)]
+			  [end-s (number->string end)])
+		      (let ([full-cmdline (append
+					   (if launcher?
+					       (if (and (eq? 'windows (system-type))
+							keep-exe?)
+						   (list (path->string exe)) ; argv[0]
+						   null)
+					       (list "-k" start-s end-s))
+					   cmdline)])
+			(if osx?
+			    (finish-osx-mred dest full-cmdline exe keep-exe?)
+			    (let ([cmdpos (with-input-from-file dest-exe find-cmdline)]
+				  [out (open-output-file dest-exe 'update)])
+			      (dynamic-wind
+				  void
+				  (lambda ()
+				    (if long-cmdline?
+					;; write cmdline at end:
+					(file-position out end)
+					(begin
+					  ;; write (short) cmdline in the normal position:
+					  (file-position out cmdpos)
+					  (display "!" out)))
+				    (for-each
+				     (lambda (s)
+				       (fprintf out "~a~a~c"
+						(integer->integer-bytes 
+						 (add1 (bytes-length (string->bytes/utf-8 s)) )
+						 4 #t #f)
+						s
+						#\000))
+				     full-cmdline)
+				    (display "\0\0\0\0" out)
+				    (when long-cmdline?
+				      ;; cmdline written at the end;
+				      ;; now put forwarding information at the normal cmdline pos
+				      (let ([new-end (file-position out)])
+					(file-position out cmdpos)
+					(fprintf out "~a...~a~a"
+						 (if keep-exe? "*" "?")
+						 (integer->integer-bytes end 4 #t #f)
+						 (integer->integer-bytes (- new-end end) 4 #t #f)))))
+				  (lambda ()
+				    (close-output-port out)))
+			      (let ([m (and (eq? 'windows (system-type))
+					    (assq 'ico aux))])
+				(when m
+				  (install-icon dest-exe (cdr m))))))))))))))))))
diff --git a/collects/compiler/embed.ss b/collects/compiler/embed.ss
new file mode 100644
index 0000000000..0346389379
--- /dev/null
+++ b/collects/compiler/embed.ss
@@ -0,0 +1,31 @@
+
+(module embed mzscheme
+  (require (lib "unitsig.ss")
+           (lib "contract.ss"))
+  
+  (require "sig.ss")
+  
+  (require "embed-unit.ss"
+	   "embed-sig.ss")
+  
+  (define-values/invoke-unit/sig compiler:embed^
+                                 compiler:embed@
+                                 #f)
+  
+  (provide/contract [make-embedding-executable
+                     (opt-> (path-string?
+                             any/c
+                             any/c
+                             (listof (list/c (union boolean? symbol?) any/c))
+                             (listof path-string?)
+                             any/c
+                             (listof string?))
+                            ((listof (cons/c symbol? any/c))
+                             any/c
+                             symbol?)
+                            void?)])
+  (provide write-module-bundle
+           embedding-executable-is-directory?
+           embedding-executable-put-file-extension+style+filters
+	   embedding-executable-add-suffix))
+
diff --git a/collects/compiler/info.ss b/collects/compiler/info.ss
new file mode 100644
index 0000000000..e13ab00fa8
--- /dev/null
+++ b/collects/compiler/info.ss
@@ -0,0 +1,12 @@
+
+(module info (lib "infotab.ss" "setup")
+  (define doc.txt "doc.txt")
+  (define name "mzc")
+
+  (define mzscheme-launcher-libraries (list "start.ss"))
+  (define mzscheme-launcher-names (list "mzc"))
+  (define mred-launcher-libraries (list "start.ss"))
+  (define mred-launcher-names (list "gmzc"))
+
+  (define compile-omit-files
+    '("mrspidey.ss" "mrspideyf.ss" "mrspideyi.ss" "embedr.ss")))
diff --git a/collects/compiler/ld-unit.ss b/collects/compiler/ld-unit.ss
new file mode 100644
index 0000000000..8b718939fc
--- /dev/null
+++ b/collects/compiler/ld-unit.ss
@@ -0,0 +1,304 @@
+
+(module ld-unit mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "list.ss"))
+
+  (require "sig.ss")
+
+  (require (lib "file-sig.ss" "dynext")
+	   (lib "link-sig.ss" "dynext")
+	   (lib "compile-sig.ss" "dynext"))
+
+  (provide ld@)
+
+  (define ld@
+    (unit/sig compiler:linker^
+      (import dynext:compile^
+	      dynext:link^
+	      dynext:file^
+	      (compiler:option : compiler:option^))
+      (rename (link-extension* link-extension))
+
+
+      ;; Copied from library.ss; please fix me!
+      (define compiler:bad-chars
+	(string->list "#+-.*/<=>!?:$%_&~^@;^()[]{}|\\,~\"`' "))
+      (define (compiler:clean-string s)
+	(let* ((str (string->list s)))
+	  (list->string
+	   (map (lambda (c) (if (member c compiler:bad-chars)
+				#\_
+				c))
+		str))))
+
+      (define (link-extension*
+	       files
+	       dest-dir)
+	(do-link-extension #t files dest-dir))
+
+      (define (glue-extension
+	       files
+	       dest-dir)
+	(do-link-extension #f files dest-dir))
+
+      (define (do-link-extension
+	       link?
+	       files
+	       dest-dir)
+
+	(define _loader.c (append-c-suffix "_loader"))
+	(define _loader.o (append-object-suffix "_loader"))
+	(define _loader.so (append-extension-suffix "_loader"))
+	
+	(define __ (printf "\"~a\":~n" (build-path dest-dir _loader.c)))
+
+	(define all-names
+	  (map
+	   (lambda (file)
+	     (let*-values ([(base name dir?) (split-path file)])
+	       (let ([o (extract-base-filename/o name)]
+		     [kp (extract-base-filename/kp name)])
+		 (cond
+		  [o (list 'o file o)]
+		  [kp (cons 'kp file)]
+		  [else (error 'mzld "file is not a compiled object for constant pool file: ~a"
+			       file)]))))
+	   files))
+
+	(define-values (o-files ; just .o files
+			names ; just .o names
+			kps) ; just .kp files
+	  (let loop ([l all-names][ofs null][os null][kps null])
+	    (if (null? l)
+		(values (reverse ofs) 
+			(map path->string (reverse os))
+			(reverse kps))
+		(if (eq? (caar l) 'o)
+		    (loop (cdr l) (cons (cadar l) ofs) (cons (caddar l) os) kps)
+		    (loop (cdr l) ofs os (cons (cdar l) kps))))))
+
+	(define linker-prefix (compiler:option:setup-prefix))
+
+	(define suffixes
+	  (let ([linker-prefix (compiler:clean-string linker-prefix)])
+	    (map
+	     (lambda (name)
+	       (string-append linker-prefix "_" (compiler:clean-string name)))
+	     names)))
+
+	(define symbol-table (make-hash-table))
+	(define (add-symbol s spos pos uninterned?)
+	  (let ([v (hash-table-get symbol-table s (lambda () null))])
+	    (hash-table-put! symbol-table s
+			     (cons (list spos pos) v))))
+	
+	;; Read in symbol info
+	(define kp-suffixes/counts
+	  (let loop ([kps kps][kpos 0])
+	    (if (null? kps)
+		null
+		(let-values ([(suffix count)
+			      (call-with-input-file (car kps)
+				(lambda (in)
+				  (let ([info (read in)])
+				    (let ([suffix (car info)]
+					  [symbols (cdadr info)])
+				      (let loop ([l symbols][p 0])
+					(unless (null? l)
+					  (let ([s (car l)])
+					    ;; s might be a list containing a symbol to
+					    ;; indicate that it's uninterned
+					    (add-symbol (if (string? s) 
+							    (string->symbol s)
+							    (string->uninterned-symbol (car s)))
+							kpos p
+							(pair? s)))
+					  (loop (cdr l) (add1 p))))
+				      (values suffix (length symbols))))))])
+		  (let ([rest (loop (cdr kps) 
+				    (if (zero? count)
+					kpos
+					(add1 kpos)))])
+		    (if (zero? count)
+			rest
+			(cons (cons suffix count) rest)))))))
+
+	;; Compile content of symbol table into dispatching information
+	(define symbols (hash-table-map symbol-table (lambda (key info) key)))
+	(define symbol-dispatches
+	  (apply
+	   append
+	   (hash-table-map 
+	    symbol-table
+	    (lambda (key info)
+	      (cons (length info)
+		    (apply append info))))))
+
+	(with-output-to-file
+	    (build-path dest-dir _loader.c)
+	  (lambda ()
+	    (printf "#include \"~ascheme.h\"~n"
+		    (if (compiler:option:compile-for-embedded)
+			""
+			"e"))
+	    (printf "#include \"mzclink.h\"~n~n")
+	    
+	    (for-each
+	     (lambda (suffix)
+	       (printf "extern Scheme_Object * scheme_setup~a(Scheme_Env *e);~n" suffix)
+	       (printf "extern Scheme_Object * scheme_reload~a(Scheme_Env *e);~n" suffix))
+	     suffixes)
+	    (for-each
+	     (lambda (kp-suffix/count)
+	       (let ([suffix (car kp-suffix/count)]
+		     [count (cdr kp-suffix/count)])
+		 (printf "extern Scheme_Object * SYMBOLS~a[~a];~n" 
+			 suffix count)))
+	     kp-suffixes/counts)
+	    
+	    (printf "~nstatic struct {~n")
+	    (for-each
+	     (lambda (suffix)
+	       (printf "  Scheme_Object * ~a_symbol;~n" suffix))
+	     suffixes)
+	    (printf "} syms;~n~n")
+
+	    
+	    (unless (null? symbols)
+	      (printf "static const char *SYMBOL_STRS[~a] = {~n" (length symbols))
+	      (for-each
+	       (lambda (s)
+		 (printf "  ~s,~n" (symbol->string s)))
+	       symbols)
+	      (printf "}; /* end of SYMBOL_STRS */~n~n")
+
+	      (printf "static long SYMBOL_LENS[~a] = {~n" (length symbols))
+	      (for-each
+	       (lambda (s)
+		 (printf "  ~s,~n" (string-length (symbol->string s))))
+	       symbols)
+	      (printf "}; /* end of SYMBOL_LENS */~n~n")
+	      
+	      (printf "static char SYMBOL_INTERNS[~a] = {~n" (length symbols))
+	      (for-each
+	       (lambda (s)
+		 (printf "  ~s,~n" (if (eq? s (string->symbol (symbol->string s))) 1 0)))
+	       symbols)
+	      (printf "}; /* end of SYMBOL_INTERNS */~n~n")
+	      
+	      (printf "static const int SYMBOL_DISPATCHES[~a] = {~n  " (length symbol-dispatches))
+	      (let loop ([l symbol-dispatches][line 0])
+		(unless (null? l)
+		  (if (= line 20)
+		      (begin
+			(printf "~n  ")
+			(loop l 0))
+		      (begin
+			(printf "~a, " (car l))
+			(loop (cdr l) (add1 line))))))
+	      (printf "~n}; /* end of SYMBOL_DISPATCHES */~n~n")
+
+	      (printf "static setup_pooled_symbols(void) {~n  Scheme_Object * * symbol_tables[~a];~n  int i, j;~n"
+		      (length kp-suffixes/counts))
+	      (let loop ([l kp-suffixes/counts][p 0])
+		(unless (null? l)
+		  (printf "  symbol_tables[~a] = SYMBOLS~a;~n  scheme_register_extension_global(&SYMBOLS~a, sizeof(SYMBOLS~a));~n"
+			  p (caar l)
+			  (caar l) (caar l))
+		  (loop (cdr l) (add1 p))))
+	      (printf "  for (i = j = 0; i < ~a; i++) {~n" (length symbols))
+	      (printf "    Scheme_Object * s;~n")
+	      (printf "    int c, k;~n")
+	      (printf "    if (SYMBOL_INTERNS[i])~n")
+	      (printf "       s = scheme_intern_exact_symbol(SYMBOL_STRS[i], SYMBOL_LENS[i]);~n")
+	      (printf "    else~n")
+	      (printf "       s = scheme_make_exact_symbol(SYMBOL_STRS[i], SYMBOL_LENS[i]);~n")
+	      (printf "    c = SYMBOL_DISPATCHES[j++];~n")
+	      (printf "    for (k = c; k--; j += 2)~n")
+	      (printf "      symbol_tables[SYMBOL_DISPATCHES[j]][SYMBOL_DISPATCHES[j+1]] = s;~n")
+	      (printf "  }~n")
+	      (printf "}~n~n"))
+
+	    (printf "static Scheme_Object * loader_dispatch(void *v, int argc, Scheme_Object * * argv) {~n")
+	    (printf "  Scheme_Env * env = scheme_get_env(scheme_current_config());~n")
+	    (printf "  return ((Scheme_Object *(*)(Scheme_Env *))v)(env);~n}~n~n")
+	    
+	    (printf "static Scheme_Object * loader_dispatch_all(int argc, Scheme_Object * * argv) {~n")
+	    (printf "  Scheme_Env * env = scheme_get_env(scheme_current_config());~n")
+	    (printf "  Scheme_Object * v = scheme_void;~n")
+	    (for-each
+	     (lambda (suffix)
+	       (printf "  v = LOCAL_PROC(scheme_reload~a)(env);~n"
+		       suffix))
+	     suffixes)
+	    (printf "  return v;~n}~n~n")
+	    
+	    (printf "static Scheme_Object * loader(int argc, Scheme_Object * * argv) {~n")
+	    (printf "  Scheme_Object *a[2];~n")
+	    (printf "  Scheme_Object * name = argv[0];~n")
+	    (printf "  if (name == scheme_true) {~n")
+	    (printf "    a[0] = scheme_make_prim_w_arity(loader_dispatch_all, \"_loader-dispatch-all\", 0, 0);~n")
+	    (printf "    a[1] = scheme_false;~n")
+	    (printf "  }~n")
+	    (for-each
+	     (lambda (suffix)
+	       (printf "  else if (name == syms.~a_symbol) {~n" suffix)
+	       (printf "    a[0] = scheme_make_closed_prim_w_arity(loader_dispatch, LOCAL_PROC(scheme_reload~a), \"_loader-dispatch\", 0, 0);~n" suffix)
+	       (printf "    a[1] = ~ascheme_module_name();~n" suffix)
+	       (printf "  }~n"))
+	     suffixes)
+	    (printf "  else {~n")
+	    (printf "    a[0] = scheme_false;~n")
+	    (printf "    a[1] = scheme_false;~n")
+	    (printf "  }~n")
+	    (printf "  return scheme_values(2, a);~n}~n~n")
+	    
+	    (printf "Scheme_Object * scheme_reload(Scheme_Env * env) {~n")
+	    (printf "  return scheme_make_prim_w_arity(loader, \"_loader\", 1, 1);~n}~n~n")
+	    
+	    (printf "Scheme_Object * scheme_initialize(Scheme_Env * env) {~n")
+	    (unless (null? symbols)
+	      (printf "  setup_pooled_symbols();~n"))
+	    (for-each
+	     (lambda (suffix)
+	       ;; (printf "  printf(\"~a is %lx\\n\", scheme_setup~a);~n" suffix suffix)
+	       (printf "  LOCAL_PROC(scheme_setup~a)(env);~n" suffix))
+	     suffixes)
+	    (printf "  scheme_register_extension_global(&syms, sizeof(syms));~n")
+	    (for-each
+	     (lambda (suffix name)
+	       (printf "  syms.~a_symbol = scheme_intern_exact_symbol(~s, ~a);~n" suffix name (string-length name)))
+	     suffixes names)
+	    (printf "  return scheme_reload(env);~n}~n")
+	    (printf "Scheme_Object * scheme_module_name() { return NULL; }~n"))
+	  'truncate)
+	
+	(let ([tmp-dir (let ([d (getenv "PLTLDTMPDIR")])
+			 (and d (directory-exists? d) d))])
+	  
+	  (compile-extension (not (compiler:option:verbose))
+			     (build-path dest-dir _loader.c)
+			     (build-path dest-dir _loader.o)
+			     (list (collection-path "compiler")))
+	  
+	  (when (compiler:option:clean-intermediate-files)
+	    (delete-file (build-path dest-dir _loader.c)))
+
+	  (if link?
+	      (begin
+		(link-extension (not (compiler:option:verbose))
+				(cons (build-path dest-dir _loader.o) o-files) 
+				(build-path (if tmp-dir
+						tmp-dir
+						dest-dir)
+					    _loader.so))    
+		(when tmp-dir
+		  (copy-file (build-path tmp-dir _loader.so)
+			     (build-path dest-dir _loader.so))
+		  (delete-file (build-path tmp-dir _loader.so)))
+		
+		(when (compiler:option:clean-intermediate-files)
+		  (delete-file (build-path dest-dir _loader.o)))
+		
+		(printf " [output to \"~a\"]~n" (build-path dest-dir _loader.so)))
+	      (printf " [output to \"~a\"]~n" (build-path dest-dir _loader.o))))))))
diff --git a/collects/compiler/mzc.h b/collects/compiler/mzc.h
new file mode 100644
index 0000000000..472b23d802
--- /dev/null
+++ b/collects/compiler/mzc.h
@@ -0,0 +1,273 @@
+
+#include <stdlib.h>
+#include <stdarg.h>
+
+#define GLOBAL_VARREF(x) ((x)->val ? (Scheme_Object *)(x)->val : \
+  (scheme_unbound_global(x), (Scheme_Object *)NULL))
+#define CHECK_GLOBAL_BOUND(x) \
+    if (!(x)->val) scheme_raise_exn(MZEXN_UNIT, \
+				    "invoke-unit: cannot link to undefined identifier: %S", \
+				    (Scheme_Object*)(x)->key);
+
+#define DO_FUEL_POLL ((scheme_fuel_counter-- <= 0) ? (scheme_process_block(0), 0) : 0)
+
+#define _scheme_direct_apply_primitive_multi_poll(prim, argc, argv) \
+    (DO_FUEL_POLL, _scheme_direct_apply_primitive_multi(prim, argc, argv))
+#define _scheme_direct_apply_primitive_poll(prim, argc, argv) \
+    (DO_FUEL_POLL, _scheme_direct_apply_primitive(prim, argc, argv))
+#define _scheme_direct_apply_closed_primitive_multi_poll(prim, argc, argv) \
+    (DO_FUEL_POLL, _scheme_direct_apply_closed_primitive_multi(prim, argc, argv))
+#define _scheme_direct_apply_closed_primitive_poll(prim, argc, argv) \
+    (DO_FUEL_POLL, _scheme_direct_apply_closed_primitive(prim, argc, argv))
+
+#ifdef KEEP_CLOSURE_COUNT
+static int closure_alloc_cnt;
+static void print_closures()
+{
+  printf("closures allocated in " MZC_SRC_FILE ": %d\n", closure_alloc_cnt);
+}
+# define CLOSURE_ALLOC_PP closure_alloc_inc(), 
+static void closure_alloc_inc()
+{
+  if (!closure_alloc_cnt)
+    atexit(print_closures);
+  closure_alloc_cnt++;
+}
+#else
+# define CLOSURE_ALLOC_PP /**/
+#endif
+
+#define _scheme_make_c_proc_closure(cfunc, rec, name, amin, amax, flags) \
+  (CLOSURE_ALLOC_PP (Scheme_Object *)_scheme_fill_prim_closure(&rec->prim, cfunc, &rec->data, name, amin, amax, flags))
+
+#define _scheme_make_c_proc_closure_empty(cfunc, rec, name, amin, amax, flags) \
+  (CLOSURE_ALLOC_PP (Scheme_Object *)_scheme_fill_prim_closure(&rec->prim, cfunc, NULL, name, amin, amax, flags))
+
+#define _scheme_make_c_case_proc_closure(cfunc, rec, name, ccnt, cses, flags) \
+  (CLOSURE_ALLOC_PP (Scheme_Object *)_scheme_fill_prim_case_closure(&rec->prim, cfunc, &rec->data, name, ccnt, cses, flags))
+
+#define _scheme_make_c_case_proc_closure_empty(cfunc, rec, name, ccnt, cses, flags) \
+  (CLOSURE_ALLOC_PP (Scheme_Object *)_scheme_fill_prim_case_closure(&rec->prim, cfunc, NULL, name, ccnt, cses, flags))
+
+#define NO_MULTIPLE_VALUES(res) \
+	if (res == SCHEME_MULTIPLE_VALUES) \
+	    scheme_wrong_return_arity(NULL, 1, scheme_multiple_count, scheme_multiple_array, NULL);
+#define CHECK_MULTIPLE_VALUES(res, expected) \
+	if (res != SCHEME_MULTIPLE_VALUES || scheme_multiple_count != expected) \
+        scheme_wrong_return_arity(NULL, expected, \
+                                  (res == SCHEME_MULTIPLE_VALUES ? scheme_multiple_count : 1), \
+								  (res == SCHEME_MULTIPLE_VALUES ? scheme_multiple_array : (Scheme_Object**)res), \
+                                  NULL);
+
+#define SCHEME_DETATCH_MV_BUFFER(mv, pr) if (SAME_OBJ(mv, pr->values_buffer)) pr->values_buffer = NULL
+
+#define SCHEME_CURRENT_ENV(pr) scheme_get_env(NULL)
+
+typedef struct {
+  Scheme_Object * val;
+  Scheme_Object ** array;
+  int count;
+} _Scheme_Begin0_Rec;
+
+typedef struct {
+  Scheme_Cont_Frame_Data cf;
+  Scheme_Object *val;
+} _Scheme_WCM_Rec;
+
+#define _scheme_apply_ckp(f, argc, argv) (SCHEME_CLSD_PRIMP(f) ? _scheme_apply_closed_prim(f, argc, argv) : _scheme_apply(f, argc, argv))
+#define _scheme_apply_multi_ckp(f, argc, argv) (SCHEME_CLSD_PRIMP(f) ? _scheme_apply_closed_prim_multi(f, argc, argv) : _scheme_apply_multi(f, argc, argv))
+
+#define MZC_EQP(ltp, av, bv) (SAME_OBJ(av, bv))
+#define MZC_EQVP(ltp, av, bv) (SAME_OBJ(av, bv) || scheme_eqv(av, bv))
+#define MZC_EQUALP(ltp, av, bv) scheme_equal(av, bv)
+#define MZC_NOTP(p, av) (SCHEME_FALSEP(av))
+#define MZC_NULLP(p, av) (SCHEME_NULLP(av))
+#define MZC_PAIRP(p, av) (SCHEME_PAIRP(av))
+#define MZC_SYMBOLP(p, av) (SCHEME_SYMBOLP(av))
+#define MZC_STRINGP(p, av) (SCHEME_CHAR_STRINGP(av))
+#define MZC_BYTESP(p, av) (SCHEME_BYTE_STRINGP(av))
+#define MZC_VECTORP(p, av) (SCHEME_VECTORP(av))
+#define MZC_NUMBERP(p, av) (SCHEME_NUMBERP(av))
+#define MZC_PROCEDUREP(p, av) (SCHEME_PROCP(av))
+#define MZC_EOFP(p, av) (SCHEME_EOFP(av))
+#define MZC_CHARP(p, av) (SCHEME_CHARP(av))
+
+#define MZC_CONS(p, av, bv) scheme_make_pair(av, bv)
+#define MZC_LIST1(p, av) scheme_make_pair(av, scheme_null)
+#define MZC_LIST2(p, av, bv) scheme_make_pair(av, scheme_make_pair(bv, scheme_null))
+#define MZC_APPEND(p, av, bv) scheme_append(av, bv)
+
+#define MZC_FOR_SYNTAX_IN_ENV(ignored, proc) scheme_apply_for_syntax_in_env(proc, env)
+
+#if MZC_UNSAFE
+/* Unsafe versions */
+#define MZC_CAR(p, av) SCHEME_CAR(av)
+#define MZC_CDR(p, av) SCHEME_CDR(av)
+#define MZC_CADR(p, av) SCHEME_CAR(SCHEME_CDR(av))
+#define MZC_CDDR(p, av) SCHEME_CDR(SCHEME_CDR(av))
+#define MZC_CDAR(p, av) SCHEME_CDR(SCHEME_CAR(av))
+#define MZC_CAAR(p, av) SCHEME_CAR(SCHEME_CAR(av))
+#define MZC_CADDR(p, av) SCHEME_CADR(SCHEME_CDR(av))
+#define MZC_SET_CAR(p, av, bv) (SCHEME_CAR(av)=bv, scheme_void)
+#define MZC_SET_CDR(p, av, bv) (SCHEME_CDR(av)=bv, scheme_void)
+
+# define MZC_VECTOR_REF(p, v, i) SCHEME_VEC_ELS(v)[SCHEME_INT_VAL(i)]
+# define MZC_VECTOR_SET(p, v, i, x) (SCHEME_VEC_ELS(v)[SCHEME_INT_VAL(i)] = x, scheme_void)
+
+# define MZC_STRING_REF(p, v, i) scheme_make_character(SCHEME_CHAR_STR_VAL(v)[SCHEME_INT_VAL(i)])
+# define MZC_STRING_SET(p, v, i, x) (SCHEME_CHAR_STR_VAL(v)[SCHEME_INT_VAL(i)] = SCHEME_CHAR_VAL(x), scheme_void)
+
+# define MZC_BYTES_REF(p, v, i) scheme_make_integer(SCHEME_BYTE_STR_VAL(v)[SCHEME_INT_VAL(i)])
+# define MZC_BYTES_SET(p, v, i, x) (SCHEME_BYTE_STR_VAL(v)[SCHEME_INT_VAL(i)] = SCHEME_INT_VAL(x), scheme_void)
+
+#define MZC_CHAR_TO_INTEGER(p, v) scheme_make_integer((unsigned char)SCHEME_CHAR_VAL(v))
+/* End unsafe versions */
+#else
+/* Safe versions */
+#define MZC_CAR(p, av) (SCHEME_PAIRP(av) ? SCHEME_CAR(av) : (arg[0] = av, _scheme_direct_apply_primitive_multi(p, 1, arg)))
+#define MZC_CDR(p, av) (SCHEME_PAIRP(av) ? SCHEME_CDR(av) : (arg[0] = av, _scheme_direct_apply_primitive_multi(p, 1, arg)))
+#define MZC_CADR(p, av) ((SCHEME_PAIRP(av) && SCHEME_PAIRP(SCHEME_CDR(av))) ? SCHEME_CAR(SCHEME_CDR(av)) : (arg[0] = av, _scheme_direct_apply_primitive_multi(p, 1, arg)))
+#define MZC_CDDR(p, av) ((SCHEME_PAIRP(av) && SCHEME_PAIRP(SCHEME_CDR(av))) ? SCHEME_CDR(SCHEME_CDR(av)) : (arg[0] = av, _scheme_direct_apply_primitive_multi(p, 1, arg)))
+#define MZC_CDAR(p, av) ((SCHEME_PAIRP(av) && SCHEME_PAIRP(SCHEME_CAR(av))) ? SCHEME_CDR(SCHEME_CAR(av)) : (arg[0] = av, _scheme_direct_apply_primitive_multi(p, 1, arg)))
+#define MZC_CAAR(p, av) ((SCHEME_PAIRP(av) && SCHEME_PAIRP(SCHEME_CAR(av))) ? SCHEME_CAR(SCHEME_CAR(av)) : (arg[0] = av, _scheme_direct_apply_primitive_multi(p, 1, arg)))
+#define MZC_CADDR(p, av) ((SCHEME_PAIRP(av) && SCHEME_PAIRP(SCHEME_CDR(av)) && SCHEME_PAIRP(SCHEME_CDR(SCHEME_CDR(av)))) ? SCHEME_CADR(SCHEME_CDR(av)) : (arg[0] = av, _scheme_direct_apply_primitive_multi(p, 1, arg)))
+#define MZC_SET_CAR(p, av, bv) (SCHEME_MUTABLE_PAIRP(av) ? (SCHEME_CAR(av)=bv, scheme_void) : (arg[0] = av, arg[1] = bv, _scheme_direct_apply_primitive_multi(p, 2, arg)))
+#define MZC_SET_CDR(p, av, bv) (SCHEME_MUTABLE_PAIRP(av) ? (SCHEME_CDR(av)=bv, scheme_void) : (arg[0] = av, arg[1] = bv, _scheme_direct_apply_primitive_multi(p, 2, arg)))
+
+#define MZC_CHAR_TO_INTEGER(p, v) (SCHEME_CHARP(v) ? scheme_make_integer((unsigned char)SCHEME_CHAR_VAL(v)) \
+                                   : (arg[0] = v, _scheme_direct_apply_primitive_multi(p, 1, arg)))
+
+# define MZC_VECTOR_REF(p, v, i) ((SCHEME_INTP(i) && SCHEME_VECTORP(v) && (SCHEME_INT_VAL(i) >= 0) \
+                                  && (SCHEME_INT_VAL(i) < SCHEME_VEC_SIZE(v)) \
+                                 ? SCHEME_VEC_ELS(v)[SCHEME_INT_VAL(i)] \
+				  : (arg[0] = v, arg[1] = i, _scheme_direct_apply_primitive_multi(p, 2, arg))))
+# define MZC_VECTOR_SET(p, v, i, x) ((SCHEME_INTP(i) && SCHEME_VECTORP(v) && (SCHEME_INT_VAL(i) >= 0) \
+                                    && (SCHEME_INT_VAL(i) < SCHEME_VEC_SIZE(v)) \
+                                    ? (SCHEME_VEC_ELS(v)[SCHEME_INT_VAL(i)] = x, scheme_void) \
+				    : (arg[0] = v, arg[1] = i, arg[2] = x, _scheme_direct_apply_primitive_multi(p, 3, arg))))
+# define MZC_STRING_REF(p, v, i) ((SCHEME_INTP(i) && SCHEME_CHAR_STRINGP(v) && (SCHEME_INT_VAL(i) >= 0) \
+                                  && (SCHEME_INT_VAL(i) < SCHEME_CHAR_STRLEN_VAL(v)) \
+                                  ? scheme_make_character(SCHEME_CHAR_STR_VAL(v)[SCHEME_INT_VAL(i)]) \
+				  : (arg[0] = v, arg[1] = i, _scheme_direct_apply_primitive_multi(p, 2, arg))))
+# define MZC_STRING_SET(p, v, i, x) ((SCHEME_INTP(i) && SCHEME_MUTABLE_CHAR_STRINGP(v) && SCHEME_CHARP(x) && (SCHEME_INT_VAL(i) >= 0) \
+                                      && (SCHEME_INT_VAL(i) < SCHEME_CHAR_STRLEN_VAL(v)) \
+                                     ? (SCHEME_CHAR_STR_VAL(v)[SCHEME_INT_VAL(i)] = SCHEME_CHAR_VAL(x), scheme_void) \
+				     : (arg[0] = v, arg[1] = i, arg[2] = x, _scheme_direct_apply_primitive_multi(p, 3, arg))))
+# define MZC_BYTES_REF(p, v, i) ((SCHEME_INTP(i) && SCHEME_BYTE_STRINGP(v) && (SCHEME_INT_VAL(i) >= 0) \
+                                  && (SCHEME_INT_VAL(i) < SCHEME_BYTE_STRLEN_VAL(v)) \
+                                  ? scheme_make_integer(SCHEME_BYTE_STR_VAL(v)[SCHEME_INT_VAL(i)]) \
+				  : (arg[0] = v, arg[1] = i, _scheme_direct_apply_primitive_multi(p, 2, arg))))
+# define MZC_BYTES_SET(p, v, i, x) ((SCHEME_INTP(i) && SCHEME_MUTABLE_BYTE_STRINGP(v) && SCHEME_INTP(x) \
+                                      && (SCHEME_INT_VAL(x) >= 0) && (SCHEME_INT_VAL(x) <= 255) \
+                                      && (SCHEME_INT_VAL(i) >= 0) && (SCHEME_INT_VAL(i) < SCHEME_BYTE_STRLEN_VAL(v)) \
+                                     ? (SCHEME_BYTE_STR_VAL(v)[SCHEME_INT_VAL(i)] = SCHEME_INT_VAL(x), scheme_void) \
+				     : (arg[0] = v, arg[1] = i, arg[2] = x, _scheme_direct_apply_primitive_multi(p, 3, arg))))
+/* End safe versions */
+#endif
+
+#define _MZC_DBLP(obj) SAME_TYPE(_SCHEME_TYPE(obj), scheme_double_type)
+     
+#define MZC_ZEROP(zp, av) (SCHEME_INTP(av) \
+                                ? (av == scheme_make_integer(0)) \
+                                : (_MZC_DBLP(av) \
+                                   ? !SCHEME_DBL_VAL(av) \
+                                   : (arg[0] = av, SCHEME_TRUEP(_scheme_direct_apply_primitive_multi(zp, 1, arg)))))
+
+#define MZC_ARITH_COMPARE(cp, av, bv, compareop) \
+                                     ((SCHEME_INTP(av) && SCHEME_INTP(bv)) \
+                                      ? (SCHEME_INT_VAL(av) compareop SCHEME_INT_VAL(bv)) \
+                                      : ((SCHEME_DBLP(av) && SCHEME_DBLP(bv)) \
+                                         ? (SCHEME_DBL_VAL(av) compareop SCHEME_DBL_VAL(bv)) \
+                                         : (arg[0] = av, arg[1] = bv, SCHEME_TRUEP(_scheme_direct_apply_primitive_multi(cp, 2, arg)))))
+
+#define MZC_LTP(cp, av, bv) MZC_ARITH_COMPARE(cp, av, bv, <)
+#define MZC_GTP(cp, av, bv) MZC_ARITH_COMPARE(cp, av, bv, >)
+#define MZC_LTEP(cp, av, bv) MZC_ARITH_COMPARE(cp, av, bv, <=)
+#define MZC_GTEP(cp, av, bv) MZC_ARITH_COMPARE(cp, av, bv, >=)
+#define MZC_EQLP(cp, av, bv) MZC_ARITH_COMPARE(cp, av, bv, ==)
+
+#if MZC_FIXNUM
+/* Numerically incorrect */
+#define MZC_ADD1(p, av) (SCHEME_INTP(av) \
+                         ? scheme_make_integer(SCHEME_INT_VAL(av)+1) \
+                         : (arg[0] = av, _scheme_direct_apply_primitive_multi(p, 1, arg)))
+#define MZC_SUB1(p, av) (SCHEME_INTP(av) \
+                         ? scheme_make_integer(SCHEME_INT_VAL(av)-1) \
+                         : (arg[0] = av, _scheme_direct_apply_primitive_multi(p, 1, arg)))
+
+#define MZC_ARITH_OP(cp, av, bv, op, revop) \
+                      ((SCHEME_INTP(av) && SCHEME_INTP(bv)) \
+                        ? scheme_make_integer(SCHEME_INT_VAL(av) op SCHEME_INT_VAL(bv)) \
+                        : ((SCHEME_DBLP(av) && SCHEME_DBLP(bv)) \
+                           ? scheme_make_double(SCHEME_DBL_VAL(av) op SCHEME_DBL_VAL(bv)) \
+                           : (arg[0] = av, arg[1] = bv, _scheme_direct_apply_primitive_multi(cp, 2, arg))))
+
+#define MZC_TIMES2(cp, av, bv) MZC_ARITH_OP(cp, av, bv, *, /)
+
+/* End numerically incorrect */
+#else
+/* Numerically correct */
+#define MZC_ADD1(p, av) ((SCHEME_INTP(av) && (SCHEME_INT_VAL(av) < 0x3FFFFFFF)) \
+                         ? scheme_make_integer(SCHEME_INT_VAL(av)+1) \
+                         : (arg[0] = av, _scheme_direct_apply_primitive_multi(p, 1, arg)))
+#define MZC_SUB1(p, av) ((SCHEME_INTP(av) && (SCHEME_INT_VAL(av) > (-0x3FFFFFFF))) \
+                         ? scheme_make_integer(SCHEME_INT_VAL(av)-1) \
+                         : (arg[0] = av, _scheme_direct_apply_primitive_multi(p, 1, arg)))
+
+#define MZC_ARITH_OP(cp, av, bv, op, revop) \
+                      ((SCHEME_INTP(av) && SCHEME_INTP(bv) \
+                        && (((SCHEME_INT_VAL(scheme_make_integer(SCHEME_INT_VAL(av) op SCHEME_INT_VAL(bv))) \
+                              revop SCHEME_INT_VAL(bv)) \
+                             == SCHEME_INT_VAL(av)))) \
+                        ? scheme_make_integer(SCHEME_INT_VAL(av) op SCHEME_INT_VAL(bv)) \
+                        : ((SCHEME_DBLP(av) && SCHEME_DBLP(bv)) \
+                           ? scheme_make_double(SCHEME_DBL_VAL(av) op SCHEME_DBL_VAL(bv)) \
+                           : (arg[0] = av, arg[1] = bv, _scheme_direct_apply_primitive_multi(cp, 2, arg))))
+/* End numerically correct */
+#endif
+
+#define MZC_PLUS2(cp, av, bv) MZC_ARITH_OP(cp, av, bv, +, -)
+#define MZC_MINUS2(cp, av, bv) MZC_ARITH_OP(cp, av, bv, -, +)
+
+#define MZC_MAXMIN_OP(cp, av, bv, minlt) \
+            ((SCHEME_INTP(av) && SCHEME_INTP(bv)) \
+             ? ((SCHEME_INT_VAL(av) minlt SCHEME_INT_VAL(bv)) ? av : bv) \
+             : (arg[0] = av, arg[1] = bv, _scheme_direct_apply_primitive_multi(cp, 2, arg)))
+
+#define MZC_MAX2(cp, av, bv) MZC_MAXMIN_OP(cp, av, bv, >)
+#define MZC_MIN2(cp, av, bv) MZC_MAXMIN_OP(cp, av, bv, <)
+
+#define MZC_QUOTIENT(cp, av, bv) \
+            ((SCHEME_INTP(av) && SCHEME_INTP(bv) && SCHEME_INT_VAL(bv)) \
+             ? scheme_make_integer(SCHEME_INT_VAL(av) / SCHEME_INT_VAL(bv)) \
+             : (arg[0] = av, arg[1] = bv, _scheme_direct_apply_primitive_multi(cp, 2, arg)))
+
+static MSC_IZE(inline) Scheme_Object *mzc_force_value(Scheme_Object *v)
+{
+  return _scheme_force_value(v);
+}
+
+#define _scheme_direct_apply_closed_primitive_multi_fv(prim, argc, argv) \
+    mzc_force_value(_scheme_direct_apply_closed_primitive_multi(prim, argc, argv))
+#define _scheme_direct_apply_closed_primitive_fv(prim, argc, argv) \
+    scheme_check_one_value(_scheme_direct_apply_closed_primitive_multi_fv(prim, argc, argv))
+
+static int mzc_strlen(const char *c) {
+  int l;
+  for (l = 0; c[l]; l++);
+  return l;
+}
+
+#if 0
+static Scheme_Object *DEBUG_CHECK(Scheme_Object *v)
+{
+  if ((SCHEME_TYPE(v) < _scheme_values_types_) || (SCHEME_TYPE(v) > _scheme_last_type_ + 5)) {
+    /* Could be a boxed value ... */
+    Scheme_Object *o = *(Scheme_Object **)v;
+    if ((SCHEME_TYPE(v) < _scheme_values_types_) || (SCHEME_TYPE(v) > _scheme_last_type_ + 5)) {
+      printf("wrong!\n");
+    }
+  }
+  return v;
+}
+#endif
diff --git a/collects/compiler/mzclink.h b/collects/compiler/mzclink.h
new file mode 100644
index 0000000000..3d2cd0c874
--- /dev/null
+++ b/collects/compiler/mzclink.h
@@ -0,0 +1,2 @@
+
+#define LOCAL_PROC(x) x
diff --git a/collects/compiler/option-unit.ss b/collects/compiler/option-unit.ss
new file mode 100644
index 0000000000..514f1a5ce7
--- /dev/null
+++ b/collects/compiler/option-unit.ss
@@ -0,0 +1,41 @@
+
+(module option-unit mzscheme
+  (require (lib "unitsig.ss"))
+
+  (require "sig.ss")
+
+  (provide compiler:option@)
+
+  (define compiler:option@
+    (unit/sig compiler:option^
+      (import)
+      
+      (define propagate-constants (make-parameter #t))
+      (define assume-primitives (make-parameter #f))
+      (define stupid (make-parameter #f))
+      
+      (define vehicles (make-parameter 'vehicles:automatic))
+      (define vehicles:monoliths (make-parameter 1))
+      (define seed (make-parameter 2001))
+      (define max-monoliths 32)
+      
+      (define max-inline-size (make-parameter 50))
+
+      (define unsafe (make-parameter #f))
+      (define disable-interrupts (make-parameter #f))
+      (define fixnum-arithmetic (make-parameter #f))
+
+      (define verbose (make-parameter #f))
+      (define debug (make-parameter #f))
+      (define test (make-parameter #f))
+      (define clean-intermediate-files (make-parameter #t))
+
+      (define max-exprs-per-top-level-set (make-parameter 25))
+      
+      (define setup-prefix (make-parameter ""))
+
+      (define compile-subcollections (make-parameter #t))
+      (define compile-for-embedded (make-parameter #f))
+      
+      ;; Maybe #f helps for register-poor architectures?
+      (define unpack-environments (make-parameter #f)))))
diff --git a/collects/compiler/option.ss b/collects/compiler/option.ss
new file mode 100644
index 0000000000..e5eee5de12
--- /dev/null
+++ b/collects/compiler/option.ss
@@ -0,0 +1,12 @@
+
+(module option mzscheme
+  (require (lib "unitsig.ss"))
+
+  (require "sig.ss")
+  (require "option-unit.ss")
+
+  (define-values/invoke-unit/sig
+    compiler:option^
+    compiler:option@)
+
+  (provide-signature-elements compiler:option^))
diff --git a/collects/compiler/private/analyze.ss b/collects/compiler/private/analyze.ss
new file mode 100644
index 0000000000..2ac57e6482
--- /dev/null
+++ b/collects/compiler/private/analyze.ss
@@ -0,0 +1,1413 @@
+;; lexical analysis phase of the compiler
+;; (c) 1996-1997 Sebastian Good
+;; (c) 1997-2001 PLT
+
+;; For closures, variable sets, such as the free variables,
+;;  are computed.
+;; Constants are transformed into varrefs to top-level
+;;  constant definitions. A list of these is kept, and
+;;  code is generated to create the constants and prefixed
+;;  onto the output code. See also const.ss.
+;; Global and primitive varrefs are collected into a list,
+;;  so they can all be looked up once.
+;; Letrec expressions that don't just bind procedures are
+;;  changed to let+set!. Letrecs that remain after this
+;;  phase are well-behaved procedure binders.
+;; Some simple arity checks are performed, and return-arity
+;;  information is kept for closures. Ultimately, the return-
+;;  arity information is used to compile away some return
+;;  value count checks.
+;; Constants are propagated.
+;; Constant let-bound variables are eliminated (unless they
+;;   are improperly used in the let body).
+;; Procedure applications are inlined.
+;; Syntax constants created, so quote-syntax turns into a
+;;   varref
+
+;;; Annotatitons: ----------------------------------------------
+;;    binding - `binding' structure: UPDATED occasionally:
+;;         rec? field for letrec bindings
+;;         known-but-used? field for ill-used bindings
+;;    quote - zodiac:varref (global var containing a constructed 
+;;         constant) or an immediate constant
+;;    app - `app' structure: UPDATED tail? flag
+;;    lambda - `procedure-code' structure
+;;    with-continuation-mark - might set annotation to #f, which
+;;         indicates that begin0-like handling is not needed
+;;    quote-syntax - zodiac:varref (global var containing a constructed 
+;;         constant)
+;;; ------------------------------------------------------------
+
+(module analyze mzscheme
+  (require (lib "unitsig.ss")
+	  (lib "list.ss")
+	  (lib "etc.ss"))
+
+  (require (lib "zodiac-sig.ss" "syntax"))
+
+  (require "sig.ss")
+  (require "../sig.ss")
+
+  (provide analyze@)
+  (define analyze@
+    (unit/sig compiler:analyze^
+      (import (compiler:option : compiler:option^)
+	      compiler:library^
+	      compiler:cstructs^
+	      (zodiac : zodiac^)
+	      compiler:zlayer^
+	      compiler:prephase^
+	      compiler:anorm^
+	      compiler:known^
+	      compiler:const^
+	      compiler:rep^
+	      compiler:vm2c^
+	      compiler:driver^)
+      
+      (define-struct mod-glob (cname   ;; a made-up name that encodes module + var
+			       modname
+			       varname 
+			       position
+			       exp-time?
+			       exp-def?
+			       in-module?))
+
+      (define-struct modref-info (globals
+				  et-globals
+				  modidx-const)) ; #f => local to module body
+
+      (define compiler:global-symbols (make-hash-table))
+      (define compiler:add-global-varref!
+	(case-lambda 
+	 [(varref) (compiler:add-global-varref!
+		    (zodiac:top-level-varref-module varref)
+		    (zodiac:varref-var varref)
+		    varref
+		    (zodiac:top-level-varref-exptime? varref)
+		    (zodiac:top-level-varref-expdef? varref)
+		    (zodiac:top-level-varref-position varref))]
+	 [(modname varname ast et? ed? position)
+	  (let* ([et? (and et?
+			   ;; Just use run-time for #%kernel, since it's the same, and
+			   ;;  the compiler generates references to #%kernel names
+			   (not (eq? '#%kernel modname)))]
+		 [info (hash-table-get compiler:global-symbols modname
+				       (lambda ()
+					 (let ([p (make-modref-info 
+						   #f #f
+						   (if (module-path-index? modname)
+						       (let-values ([(name base) (module-path-index-split modname)])
+							 (if name
+							     (compiler:construct-const-code!
+							      (zodiac:make-zread
+							       (datum->syntax-object
+								#f
+								modname
+								(zodiac:zodiac-stx ast)))
+							      #t)
+							     #f))
+						       modname))])
+					   (hash-table-put! compiler:global-symbols modname p)
+					   p)))]
+		 [t (or ((if et? modref-info-et-globals modref-info-globals) info)
+			(let ([t (make-hash-table)])
+			  ((if et? set-modref-info-et-globals! set-modref-info-globals!) info t)
+			  t))])
+	    (hash-table-get t varname
+			    (lambda ()
+			      ;; vm->c function also generates a symbol constant:
+			      (let ([n (make-mod-glob (vm->c:generate-modglob-name modname varname)
+						      modname varname position et? ed?
+						      (and ast (varref:has-attribute? 
+								ast
+								varref:in-module)))])
+				(unless ast
+				  (compiler:internal-error
+				   #f
+				   "unexpected global name generation for ~a (~a;~a)" 
+				   varname modname et?))
+				(hash-table-put! t varname n)
+				n))))]))
+
+      (define (ensure-top-level varref)
+	(if (zodiac:top-level-varref-module varref)
+	    (begin
+	      (compiler:warning
+	       varref
+	       (format "definition of name `~a' mapped by --prim or `require'; compiled uses of the name will ignore this definition"
+		       (zodiac:varref-var varref)))
+	      (let ([new (zodiac:make-top-level-varref
+			  (datum->syntax-object
+			   #f ; no context
+			   (syntax-e (zodiac:zodiac-stx varref))
+			   (zodiac:zodiac-stx varref))
+			  (make-empty-box)
+			  (zodiac:varref-var varref)
+			  #f
+			  (box #f) ; slot - fresh because the variable can't be referenced from anywhere
+			  #f #f #f)])
+		(set-annotation! new (varref:empty-attributes))
+		new))
+	    varref))
+
+      (define (compiler:get-module-path-constant modname)
+	(modref-info-modidx-const (hash-table-get compiler:global-symbols modname void)))
+
+      (define (compiler:get-global-symbols) compiler:global-symbols)
+
+      (define compiler:primitive-refs empty-set)
+      (define compiler:add-primitive-varref!
+	(lambda (varref)
+	  (set! compiler:primitive-refs
+		(set-union-singleton compiler:primitive-refs
+				     (zodiac:varref-var varref)))))
+      (define (compiler:get-primitive-refs) compiler:primitive-refs)
+
+      (define compiler:max-arity-allowed 11739) ; meant to be a sane limit
+      
+      (define compiler:define-list null)
+      (define compiler:per-load-define-list null)
+      (define compiler:per-invoke-define-list null)
+      (define compiler:local-define-list null)
+      (define compiler:local-per-load-define-list null)
+      (define compiler:local-per-invoke-define-list null)
+
+      (define (compiler:get-define-list) compiler:define-list)
+      (define (compiler:get-per-load-define-list) compiler:per-load-define-list)
+      (define (compiler:get-per-invoke-define-list) compiler:per-invoke-define-list)
+      
+      (define (compiler:init-define-lists!)
+	(set! compiler:define-list null)
+	(set! compiler:per-load-define-list null)
+	(set! compiler:per-invoke-define-list null)
+	(set! compiler:global-symbols (make-hash-table))
+	(set! compiler:primitive-refs empty-set))
+      
+      (define (compiler:add-local-define-list! def)
+	(set! compiler:local-define-list 
+	      (cons def compiler:local-define-list)))
+      (define (compiler:add-local-per-load-define-list! def)
+	(set! compiler:local-per-load-define-list 
+	      (cons def compiler:local-per-load-define-list)))
+      (define (compiler:add-local-per-invoke-define-list! def)
+	(set! compiler:local-per-invoke-define-list 
+	      (cons def compiler:local-per-invoke-define-list)))
+
+      (define (prepare-local-lists)
+	(set! compiler:local-define-list null)
+	(set! compiler:local-per-load-define-list null)
+	(set! compiler:local-per-invoke-define-list null))
+
+      (define (move-over-local-lists)
+	(set! compiler:define-list
+	      (append! compiler:define-list 
+		       (reverse! compiler:local-define-list)))
+	(set! compiler:per-load-define-list
+	      (append! compiler:per-load-define-list 
+		       (reverse! compiler:local-per-load-define-list)))
+	(set! compiler:per-invoke-define-list
+	      (append! compiler:per-invoke-define-list 
+		       (reverse! compiler:local-per-invoke-define-list)))
+	
+	(set! compiler:local-define-list null)
+	(set! compiler:local-per-load-define-list null)
+	(set! compiler:local-per-invoke-define-list null))
+
+      (define (compiler:finish-syntax-constants!)
+	(set! compiler:local-define-list null)
+	(set! compiler:local-per-load-define-list null)
+	(set! compiler:local-per-invoke-define-list null)
+
+	(begin0
+	 ;; Return this result - it's a number
+	 (const:finish-syntax-constants!)
+
+	 (unless (and (null? compiler:local-per-load-define-list)
+		      (null? compiler:local-per-invoke-define-list))
+	   (set! compiler:define-list
+		 (append! compiler:define-list 
+			  (reverse! compiler:local-define-list)))
+	   (set! compiler:per-load-define-list
+		 (append! compiler:per-load-define-list 
+			  (reverse! compiler:local-per-load-define-list)))
+	   (set! compiler:per-invoke-define-list
+		 (append! compiler:per-invoke-define-list 
+			  (reverse! compiler:local-per-invoke-define-list)))
+
+	   (set! compiler:local-define-list null)
+	   (set! compiler:local-per-load-define-list null)
+	   (set! compiler:local-per-invoke-define-list null))))
+      
+      ;; Temporary structure used in building up case-lambda info
+      (define-struct case-info 
+	(body case-code global-vars used-vars captured-vars max-arity return-multi))
+
+      (define (list->zodiac:quote l ast)
+	(zodiac:make-quote-form
+	 (zodiac:zodiac-stx ast)
+	 (make-empty-box)
+	 (zodiac:structurize-syntax l ast)))
+
+      ;; Turns a virtual set-values! into an expression using normal
+      ;; set!s. The result must be a-normalized, have the right
+      ;; binding annotations, and the right known-value links.
+      (define letrec-multiple-set!->single-set!
+	(lambda (orig-zbindings vars val ast)
+	  (cond
+	   [(null? vars)
+	    ;; zero value set!  -- weirdos
+	    (zodiac:make-let-values-form
+	     (zodiac:zodiac-stx ast)
+	     (make-empty-box)
+	     (list null)
+	     (list val)
+	     (zodiac:make-special-constant 'void))]
+	   
+	   [else
+	    ;; single or multiple value set! 
+	    (let* ([names (map (lambda (_) (gensym)) vars)]
+		   [zbindings (map (lambda (name orig-zbinding)
+				     (let ([zb (zodiac:make-lexical-binding
+						(zodiac:zodiac-stx ast)
+						(make-empty-box)
+						name
+						name)])
+				       (let ([old-binding (get-annotation orig-zbinding)]
+					     [new-binding (make-unknown-letbound-binding #f)])
+					 (set-annotation! zb new-binding)
+					 ;; Copy known info from the old binding to the new one.
+					 (when (binding-known? old-binding)
+					   (set-binding-known?! new-binding #t)
+					   (set-binding-val! new-binding (binding-val old-binding))))
+				       zb))
+				   names orig-zbindings)])
+	      ;; The original bindings will be set!ed, so they must now be marked as
+	      ;;  a special kind of "mutable" for boxing.
+	      (map (lambda (zb) (set-binding-letrec-set?! (get-annotation zb) #t)) orig-zbindings)
+	      ;; If it's one binding, make sure known? is set:
+	      (when (= 1 (length zbindings))
+		(let ([binding (get-annotation (car zbindings))])
+		  (unless (binding-known? binding)
+		    (set-binding-known?! binding #t)
+		    (set-binding-val! binding val))))
+	      ;; Make the new expession
+	      (zodiac:make-let-values-form
+	       (zodiac:zodiac-stx ast)
+	       (make-empty-box)
+	       (list zbindings)
+	       (list val)
+	       (let ([set!s (let loop ([zbindings zbindings] [vars vars])
+			      (if (null? zbindings)
+				  null
+				  (cons
+				   (zodiac:make-set!-form
+				    (zodiac:zodiac-stx ast)
+				    (make-empty-box)
+				    (car vars)
+				    (zodiac:binding->lexical-varref
+				     (car zbindings)))
+				   (loop (cdr zbindings) (cdr vars)))))])
+		 (if (= 1 (length set!s))
+		     (car set!s)
+		     (zodiac:make-begin-form
+		      (zodiac:zodiac-stx ast)
+		      (zodiac:parsed-back ast)
+		      set!s)))))])))
+
+      ;; turns a 'bad' letrec into let+set!, also returning a procedure
+      ;; to set! the body to the correct form, to avoid re-analyzing it
+      ;; the 'body' is set to (void)
+      (define letrec->let+set!
+	(lambda (ast)
+	  (let* ([body
+		  (zodiac:make-begin-form
+		   (zodiac:zodiac-stx ast)
+		   (make-empty-box)
+		   (let linearize-set! ([varses (zodiac:letrec-values-form-vars ast)]
+					[vals (zodiac:letrec-values-form-vals ast)])
+		     (if (null? varses)
+			 (list (zodiac:letrec-values-form-body ast))
+			 (let* ([vars (car varses)] 
+				[val (car vals)])
+			   (cons
+			    ;; must turn set!-values into set! form
+			    (letrec-multiple-set!->single-set!
+			     vars
+			     (map zodiac:binding->lexical-varref vars)
+			     val
+			     ast)
+			    (linearize-set! (cdr varses) (cdr vals)))))))]
+		 [let-form
+		  ;; In this phase, we must only construct let-vales forms with one clause
+		  (let loop ([varses (zodiac:letrec-values-form-vars ast)])
+		    (if (null? varses)
+			body
+			(let ([vars (car varses)])
+			  (zodiac:make-let-values-form 
+			   (zodiac:zodiac-stx ast)
+			   (make-empty-box) ; (zodiac:parsed-back ast)
+			   (list vars)
+			   (list
+			    (if (= 1 (length vars))
+				(zodiac:make-special-constant 'undefined)
+				(compiler:make-const-constructor 
+				 ast
+				 'values
+				 (map (lambda (_) (zodiac:make-special-constant 
+						   'undefined))
+				      vars))))
+			   (loop (cdr varses))))))])
+	    let-form)))
+
+      ;; Tells us which constants we can replace directly with their text
+      (define (can-propagate-constant? ast)
+	(or (zodiac:quote-form? ast)
+	    ;; (zodiac:lexical-varref? ast) to do this, we must put renamed vars in
+	    ;; environments as their old name...
+	    (and (zodiac:top-level-varref? ast)
+		 (or (varref:has-attribute? ast varref:primitive)
+		     (varref:has-attribute? ast varref:static)))))
+
+      ;; Which expressions can we drop entirely (e.g., RHS of a let when the value is known)?
+      (define (can-drop-expression? ast)
+	(or (zodiac:quote-form? ast)
+	    (zodiac:bound-varref? ast)
+	    (and (zodiac:top-level-varref? ast)
+		 (varref:has-attribute? ast varref:static))))
+
+      (define (or-multi a-multi b-multi)
+	(case a-multi
+	  [(#f) b-multi]
+	  [(possible) (or b-multi 'possible)]
+	  [(#t) #t]))
+
+      ;;----------------------------------------------------------------------
+      ;; INLINING
+
+      ;; Only inline fairly simple things; also check for variables needed
+      ;;  that are not in the destination scope
+      (define (expression-inline-cost body env init-size)
+	(let loop ([body body][env env][size init-size][k (lambda (x) x)])
+	  (if (>= size (compiler:option:max-inline-size))
+	      size
+	      (cond
+	       [(zodiac:quote-form? body) (k size)]
+	       [(zodiac:bound-varref? body)
+		(if (memq (zodiac:bound-varref-binding body) env)
+		    (k size)
+		    ;; Out of scope - no inling
+		    (* 2 (compiler:option:max-inline-size)))]
+	       [(zodiac:varref? body) (k size)]
+	       [(zodiac:app? body) (loop (zodiac:app-fun body) 
+					 env
+					 (+ size  (length (zodiac:app-args body)) 1)
+					 (lambda (size)
+					   (let kloop ([l (zodiac:app-args body)][size size])
+					     (if (null? l)
+						 (k size)
+						 (loop (car l) env size
+						       (lambda (size)
+							 (kloop (cdr l) size)))))))]
+	       [(zodiac:if-form? body) (loop (zodiac:if-form-test body) env (+ size 3)
+					     (lambda (size)
+					       (loop (zodiac:if-form-else body) env size
+						     (lambda (size)
+						       (loop (zodiac:if-form-then body) env size k)))))]
+	       [(zodiac:set!-form? body) (loop (zodiac:set!-form-val body) env (+ size 3) k)]
+	       [(zodiac:let-values-form? body) (loop (car (zodiac:let-values-form-vals body)) 
+						     env
+						     (+ size 3)
+						     (lambda (size)
+						       (loop (zodiac:let-values-form-body body)
+							     (append (car (zodiac:let-values-form-vars body)) env)
+							     size k)))]
+	       [(zodiac:begin-form? body) (let bloop ([size size][exprs (zodiac:begin-form-bodies body)])
+					    (if (null? exprs)
+						(k size)
+						(loop (car exprs)
+						      env
+						      (+ size 1)
+						      (lambda (size)
+							(bloop size (cdr exprs))))))]
+	       [else (* 2 (compiler:option:max-inline-size))]))))
+
+      ;; We copy inlined bodies to generate unique structure values
+      ;;  for every distinct program point. But we don't copy
+      ;;  quote forms, so the same run-time value will be used for
+      ;;  the quote form in all its instantiations. We also don't
+      ;;  know whether it's been analyzed in this phase, yet.
+      (define (copy-inlined-binding ast)
+	(let ([b (zodiac:make-lexical-binding
+		  (zodiac:zodiac-stx ast)
+		  (make-empty-box)
+		  (gensym (string-append (symbol->string (zodiac:binding-var ast)) "i"))
+		  (zodiac:binding-orig-name ast))]
+	      [a (get-annotation ast)])
+	  (set-annotation! b (copy-binding a))
+	  b))
+      (define (copy-inlined-body ast binding-map)
+	(cond
+	 [(or (and (zodiac:lexical-varref? ast) 
+		   zodiac:make-lexical-varref))
+	  =>
+	  (lambda (f)
+	    (let* ([binding (let* ([binding (zodiac:bound-varref-binding ast)]
+				   [remapped (assq binding binding-map)])
+			      (if remapped
+				  (cdr remapped)
+				  binding))]
+		   [new-ast (f (zodiac:zodiac-stx ast)
+			       (make-empty-box)
+			       (zodiac:binding-var binding)
+			       binding)])
+	      ;; Copy attribute set:
+	      (set-annotation! new-ast (get-annotation ast))
+	      new-ast))]
+	 [(zodiac:top-level-varref? ast)
+	  (let ([new-ast (zodiac:make-top-level-varref
+			  (zodiac:zodiac-stx ast)
+			  (make-empty-box)
+			  (zodiac:varref-var ast)
+			  (zodiac:top-level-varref-module ast)
+			  (zodiac:top-level-varref-slot ast)
+			  (zodiac:top-level-varref-exptime? ast)
+			  (zodiac:top-level-varref-expdef? ast)
+			  (zodiac:top-level-varref-position ast))])
+	    ;; Copy attribute set:
+	    (set-annotation! new-ast (get-annotation ast))
+	    new-ast)]
+	 [(zodiac:quote-form? ast) ast]
+	 [(zodiac:app? ast)
+	  (let ([new-ast (zodiac:make-app
+			  (zodiac:zodiac-stx ast)
+			  (make-empty-box)
+			  (copy-inlined-body (zodiac:app-fun ast) binding-map)
+			  (map (lambda (x) (copy-inlined-body x binding-map)) (zodiac:app-args ast)))]
+		[appinfo (get-annotation ast)])
+	    (set-annotation! new-ast
+			     (make-app #f
+				       (app-prim? appinfo)
+				       (app-prim-name appinfo)))
+	    new-ast)]
+	 [(zodiac:if-form? ast)
+	  (zodiac:make-if-form
+	   (zodiac:zodiac-stx ast)
+	   (make-empty-box)
+	   (copy-inlined-body (zodiac:if-form-test ast) binding-map)
+	   (copy-inlined-body (zodiac:if-form-then ast) binding-map)
+	   (copy-inlined-body (zodiac:if-form-else ast) binding-map))]
+	 [(zodiac:set!-form? ast)
+	  (zodiac:make-set!-form
+	   (zodiac:zodiac-stx ast)
+	   (make-empty-box)
+	   (copy-inlined-body (zodiac:set!-form-var ast) binding-map)
+	   (copy-inlined-body (zodiac:set!-form-val ast) binding-map))]
+	 [(zodiac:let-values-form? ast)
+	  (let* ([vars (car (zodiac:let-values-form-vars ast))]
+		 [val (car (zodiac:let-values-form-vals ast))]
+		 [new-val (copy-inlined-body val binding-map)]
+		 [new-vars (map copy-inlined-binding vars)]
+		 [new-binding-map (append (map cons vars new-vars) binding-map)]
+		 [new-body (copy-inlined-body (zodiac:let-values-form-body ast) new-binding-map)])
+	    
+	    ;; Update known-value information; if it was known to be = to a varref or binding,
+	    ;; we may have replaced it with a new varref or binding.
+	    (when (= 1 (length new-vars))
+	      (let ([binding (get-annotation (car new-vars))])
+		(when (binding-known? binding)
+		  (let ([known (binding-val binding)])
+		    (when (or (zodiac:bound-varref? known)
+			      (zodiac:binding? known))
+		      (let* ([known-zbinding (if (zodiac:binding? known)
+						 known
+						 (zodiac:bound-varref-binding known))]
+			     [found (assq known-zbinding binding-map)])
+			(when found
+			  ;; Yep - that varref/binding was replaced
+			  (set-binding-val! binding (cdr found)))))))))
+	    
+	    (zodiac:make-let-values-form
+	     (zodiac:zodiac-stx ast)
+	     (make-empty-box)
+	     (list new-vars)
+	     (list new-val)
+	     new-body))]
+	 [(zodiac:begin-form? ast)
+	  (zodiac:make-begin-form
+	   (zodiac:zodiac-stx ast)
+	   (make-empty-box)
+	   (map (lambda (x) (copy-inlined-body x binding-map))
+		(zodiac:begin-form-bodies ast)))]
+	 [else (compiler:internal-error
+		ast
+		(format "copy-inlined-body: can't copy ~a"
+			ast))]))
+
+      (define (check-for-inlining ast env inlined tail? inline dont-inline)
+	(if (>= inlined (compiler:option:max-inline-size))
+	    (dont-inline "depth")
+	    (let ([c (zodiac:app-fun ast)])
+	      (if (not (zodiac:bound-varref? c))
+		  (dont-inline `(format "not a varref: ~a" ,c))
+		  (let* ([val (extract-varref-known-val c)])
+		    (if (not (zodiac:case-lambda-form? val))
+			(dont-inline `(format "not a lambda: ~a" ,val))
+			;; We're going to inline the body if the arg count matches
+			(let loop ([argses (zodiac:case-lambda-form-args val)]
+				   [bodies (zodiac:case-lambda-form-bodies val)])
+			  (cond
+			   [(null? argses) (dont-inline "no arg match")]
+			   [(and (zodiac:list-arglist? (car argses))
+				 (= (length (zodiac:app-args ast))
+				    (length (zodiac:arglist-vars (car argses)))))
+			    ;; Inline if lexical scope of destination includes the lexical
+			    ;;  scope of the source, and simple enough
+			    (let* ([body (car bodies)]
+				   [orig-vars (zodiac:arglist-vars (car argses))]
+				   [new-size (expression-inline-cost 
+					      body (append orig-vars env) 
+					      (if tail?
+						  (max 5 inlined)
+						  inlined))])
+			      (if (< new-size (compiler:option:max-inline-size))
+				  (let* ([vars (map copy-inlined-binding orig-vars)]
+					 [vals (zodiac:app-args ast)]
+					 [new-body (copy-inlined-body body (map cons orig-vars vars))]
+					 [v (let loop ([vars vars][vals vals])
+					      (if (null? vars)
+						  new-body
+						  (zodiac:make-let-values-form
+						   (zodiac:zodiac-stx ast)
+						   (make-empty-box)
+						   (list (list (car vars)))
+						   (list (car vals))
+						   (loop (cdr vars) (cdr vals)))))])
+				    ;; Unless mutable, the new bindings have known
+				    ;;  value expressions
+				    (for-each
+				     (lambda (var val)
+				       (let ([binding (get-annotation var)])
+					 (unless (binding-mutable? binding)
+					   (set-binding-known?! binding #t)
+					   (set-binding-val! binding val))))
+				     vars (extract-ast-known-value vals))
+				    (inline v new-size))
+				  (dont-inline "too complex")))]
+			   [else (loop (cdr argses) (cdr bodies))]))))))))
+      
+
+      ;;----------------------------------------------------------------------
+      ;; analyze-expression takes 4 arguments
+      ;;  1) an AST to transform
+      ;;  2) a set of bound variables (the lexical environment)
+      ;;  3) tail?
+      ;;
+      ;; it returns 6 values
+      ;;  1) a destructively altered AST
+      ;;  2) a set of variables occurring free in that expression [free-vars]
+      ;;  3) a set of variables which are bound by lets in that expression [local-vars]
+      ;;  4) global variables and mutable `constants' used in the expression [global-vars]
+      ;;  5) local variables (including given bound set) that are used directly or captured by nested closures [used-vars]
+      ;;  6) free and local variables that are captured by nested closures [captured-vars]
+      ;;  7) a list of `code' structures
+      ;;  8) maximum arity to a call made in this expression
+      ;;  9) returns multiple values?: #t, 'possible, or #f
+      ;;
+      (define analyze-expression!
+	(lambda (ast just-bound-vars env tail?)
+	  (let ([local-vars just-bound-vars]
+		[locals-used empty-set]
+		[captured-vars empty-set]
+		[free-vars empty-set]
+		[global-vars empty-set]
+		[codes null]
+		[max-arity 1])
+	    (letrec
+		([add-local-var! (lambda (var)
+				   (set! local-vars
+					 (set-union-singleton local-vars var)))]
+		 [remove-local-var! (lambda (var)
+				      (set! local-vars
+					    (set-minus local-vars (make-singleton-set var))))]
+		 [add-free-var! (lambda (var)
+				  (set! free-vars
+					(set-union-singleton free-vars var)))]
+		 [add-used-var! (lambda (var)
+				  (set! locals-used
+					(set-union-singleton locals-used var)))]
+		 [add-global-var! (lambda (var)
+				    (set! global-vars
+					  (set-union-singleton global-vars var)))]
+		 [add-child-code! (lambda (c)
+				    (set! codes (cons c codes)))]
+		 [register-arity! (lambda (n) (set! max-arity (max n max-arity)))]  
+		 [register-code-vars!
+		  (lambda (code can-lift?)
+		    ;; all variables which are free in nested closures are
+		    ;; free in this closure (since we need them in the
+		    ;; environment) except those that are already in the
+		    ;; environment: just-bound-vars (typically the arguments)
+		    ;; and local-vars. New captured variables are also
+		    ;; added: free variables and captured variables in
+		    ;; nested closures. (Captured variables are always
+		    ;; a subset of free + used.)
+		    (set! free-vars
+			  (set-union (set-minus (code-free-vars code)
+						local-vars)
+				     free-vars))
+		    (set! locals-used
+			  (set-union (set-intersect local-vars
+						    (code-free-vars code))
+				     locals-used))
+		    (set! captured-vars
+			  (set-union (set-minus (code-free-vars code)
+						local-vars)
+				     captured-vars))
+		    (set! global-vars
+			  (set-union (code-global-vars code) global-vars)))]
+		 [analyze-code-body!
+		  (lambda (ast locals env tail? code)
+		    (add-child-code! code)
+		    (let-values ([(body free-vars
+					local-vars 
+					global-vars 
+					used-vars
+					captured-vars
+					children
+					L-max-arity
+					multi)
+				  (analyze-expression! ast
+						       locals
+						       (append (set->list locals) env)
+						       tail?)])
+		      
+		      (set-code-free-vars! code (set-union free-vars
+							   (code-free-vars code)))
+		      (set-code-local-vars! code (set-union local-vars
+							    (code-local-vars code)))
+		      (set-code-global-vars! code (set-union global-vars
+							     (code-global-vars code)))
+		      (set-code-used-vars! code (set-union used-vars
+							   (code-used-vars code)))
+		      (set-code-captured-vars! code (set-union captured-vars
+							       (code-captured-vars code)))
+		      (set-code-children! code children)
+		      (for-each (lambda (c) (set-code-parent! c code)) children)
+		      (set-closure-code-max-arity! code (max L-max-arity
+							     (closure-code-max-arity code)))
+		      (set-closure-code-return-multi! code multi)
+		      
+		      body))]
+		 [analyze-varref!
+		  (lambda (ast env tail? need-varref?)
+		    (cond
+		     
+		     ;;-----------------------------------------------------------------
+		     ;; VARIABLE REFERENCES (A-VALUES)
+		     ;;
+		     ;;    We need to catalogue which variables are used in this 
+		     ;;    expression.  if a lexical varref is not in the 
+		     ;;    environment, it is free
+		     ;;
+		     ;;    if the bound structure indicates this variable is known at
+		     ;;    compile time, replace the varref with the const-ref
+		     ;;    since we can propagate varrefs, we need to make sure we
+		     ;;    capture the right name in closures.
+		     ;;
+		     [(zodiac:bound-varref? ast)
+		      
+		      ;; check to see if it's known.  If so, just return the known value.
+		      
+		      (let* ([zbinding (zodiac:bound-varref-binding ast)]
+			     [binding (compiler:bound-varref->binding ast)]
+			     [known-value (extract-varref-known-val ast)])
+			
+			;; Extra checking for debugging:
+			;; (unless (memq zbinding env) (compiler:internal-error ast "unbound variable"))
+			
+			(cond 
+			 [(and (compiler:option:propagate-constants)
+			       known-value 
+			       (can-propagate-constant? known-value)
+			       (not need-varref?))
+			  
+			  ;; Propogate a mzc-determined constant!
+			  ;; This could be a quote-form that was installed
+			  ;; as a known value before it was
+			  ;; analyzed. If so, extract the constructed
+			  ;; constant from the backbox.
+			  ;; In any case, check for adding PLS to the closure.
+			  (let ([c (if (zodiac:quote-form? known-value)
+				       
+				       (let ([a (get-annotation known-value)])
+					 (if (zodiac:varref? a)
+					     a
+					     (analyze-quote! known-value #f)))
+
+				       known-value)])
+			    
+			    (when (and (zodiac:varref? c)
+				       (varref:has-attribute? c varref:per-load-static))
+			      (add-global-var! const:the-per-load-statics-table))
+			    (when (and (zodiac:varref? c)
+				       (varref:has-attribute? c varref:per-invoke-static))
+			      (add-global-var! (varref:invoke-module ast)))
+			    
+			    c)]
+			 
+			 [else   
+			  ;; otherwise we don't know the value -- therefore just
+			  ;; do the normal free-variable analysis
+			  
+			  (if (not (set-memq? (zodiac:bound-varref-binding ast)
+					      local-vars))
+			      
+			      (begin 
+				(add-free-var! (zodiac:bound-varref-binding ast))
+				(varref:add-attribute! ast varref:env)
+				
+				;; If this variable has an anchor, include it in the list of free vars
+				(let ([a (binding-anchor (get-annotation (zodiac:bound-varref-binding ast)))])
+				  (when a
+				    (add-free-var! a)))
+				
+				ast)
+			      
+			      (begin
+				(add-used-var! (zodiac:bound-varref-binding ast))
+				
+				;; If this variable has an anchor, include it in the list of used vars
+				(let ([a (binding-anchor (get-annotation (zodiac:bound-varref-binding ast)))])
+				  (when a
+				    (add-used-var! a)))
+				
+				ast))]))]
+		     
+		     [(zodiac:top-level-varref? ast)
+		      
+		      ;; A varref may need to generate module-index values.
+		      (prepare-local-lists)
+
+		      (cond
+		       [(varref:has-attribute? ast varref:primitive)
+			(compiler:add-primitive-varref! ast)]
+		       [(varref:has-attribute? ast varref:per-load-static)
+			(add-global-var! const:the-per-load-statics-table)]
+		       [(varref:has-attribute? ast varref:per-invoke-static)
+			(add-global-var! (varref:invoke-module ast))]
+		       [(varref:has-attribute? ast varref:static)
+			(void)]
+		       [else
+			(add-global-var! (compiler:add-global-varref! ast))])
+		      (compiler:add-global-varref! ast)
+
+		      ;; Was a module-index value generated?
+		      (move-over-local-lists)
+
+		      ast]
+		     
+		     [else (compiler:internal-error 
+			    ast
+			    "analyze: expected a variable; got ~a" ast)]))]
+		 
+		 ;;-----------------------------------------------------------------
+		 ;; CONSTANTS (A-VALUES)
+		 ;;   literal constants -- send them off to the constant
+		 ;;   constructors!!  This produces code in b-normal form
+		 ;;   and adds defines to the local-define-list. This list
+		 ;;   must be reversed since the dependencies are backwards
+		 ;;   ahh, the excitement of multiple values...
+		 [analyze-quote!
+		  (lambda (ast known-immutable?)
+		    (prepare-local-lists)
+		    (let ([ret (compiler:construct-const-code! 
+				(zodiac:quote-form-expr ast)
+				(or known-immutable?
+				    (eq? 'immutable (get-annotation ast))))])
+		      ;; Put a pointer to the constructed constant in the quote-form's backbox
+		      (set-annotation! ast ret)
+		      
+		      (move-over-local-lists)
+
+		      ;; If this `constant' is mutable, register the per-load
+		      ;; statics pointer as a `global'
+		      (when (and (zodiac:top-level-varref? ret)
+				 (varref:has-attribute? ret varref:per-load-static))
+			(add-global-var! const:the-per-load-statics-table))
+		      (when (and (zodiac:top-level-varref? ret)
+				 (varref:has-attribute? ret varref:per-invoke-static))
+			(add-global-var! (varref:invoke-module ret)))
+		      
+		      ret))]
+		 
+		 [analyze!-ast
+		  ;; Like analyze, but drop the multi-return info in the result
+		  (lambda (ast env inlined)
+		    (let-values ([(ast multi) (analyze! ast env inlined #f #f)])
+		      ast))]
+		 
+		 [analyze!-sv
+		  ;; Like analyze, but make sure the expression is not definitely
+		  ;;  multi-valued
+		  (lambda (ast env inlined)
+		    (let-values ([(ast multi) (analyze! ast env inlined #f #f)])
+		      (when (eq? multi #t)
+			((if (compiler:option:stupid) compiler:warning compiler:error)
+			 ast
+			 "returning zero or multiple values to a context expecting 1 value"))
+		      ast))]
+		 
+		 [analyze!
+		  ;; Returns (values ast multi)
+		  ;;    where multi = #f, #t, 'possible
+		  (lambda (ast env inlined tail? wcm-tail?)
+		    (when (compiler:option:debug)
+		      (zodiac:print-start! (debug:get-port) ast)
+		      (newline (debug:get-port)))
+		    
+		    (cond
+		     
+		     ;;-----------------------------------------------------------------
+		     ;; CONSTANTS (A-VALUES)
+		     [(zodiac:quote-form? ast)
+		      (values (analyze-quote! ast #f) #f)]
+		     
+		     ;;-----------------------------------------------------------------
+		     ;; VARIABLE REFERENCES (A-VALUES)
+		     ;;
+		     ;;    We need to catalogue which variables are used in this 
+		     ;;    expression.  if a lexical varref is not in the 
+		     ;;    environment, it is free
+		     ;;
+		     ;;    if the bound structure indicates this variable is known at
+		     ;;    compile time, replace the varref with the const-ref
+		     ;;    since we can propagate varrefs, we need to make sure we
+		     ;;    capture the right name in closures.
+		     ;;
+		     [(zodiac:bound-varref? ast) 
+		      (values (analyze-varref! ast env tail? #f) #f)]
+
+		     [(zodiac:top-level-varref? ast)
+		      (values (analyze-varref! ast env tail? #f) #f)]
+		     
+		     ;;--------------------------------------------------------------------
+		     ;; LAMBDA EXPRESSIONS
+		     ;;    with lambda, we need to make a recursive call.  We
+		     ;;    extend the lexical environment with everything that's
+		     ;;    been declared locally so far.  From the analyze-expression
+		     ;;    we have information about what free variables they use	
+		     ;;
+		     [(zodiac:case-lambda-form? ast)
+		      (let* ([code
+			      (make-procedure-code empty-set empty-set empty-set empty-set empty-set
+						   'unknown-proc-parent #f null
+						   #f #f #f #f 0 #f (get-annotation ast) ; ann. = name
+						   'unknown-case-infos #f 
+						   'unknown-liftable
+						   (and (syntax-property (zodiac:zodiac-stx ast) 'method-arity-error)
+							;; Make sure that no case accepts 0 arguments:
+							(andmap
+							 (lambda (a) (not (null? (zodiac:arglist-vars a))))
+							 (zodiac:case-lambda-form-args ast))))]
+			     [case-infos
+			      (map
+			       (lambda (args body)
+				 (let ([args (zodiac:arglist-vars args)])
+				   
+				   (let-values 
+				       ([(lambda-body free-lambda-vars
+						      local-lambda-vars 
+						      global-lambda-vars 
+						      used-lambda-vars
+						      captured-lambda-vars
+						      children-codes
+						      L-max-arity
+						      multi)
+					 
+					 (let ([just-bound (improper-list->set args)])
+					   (analyze-expression! body
+								just-bound
+								(append (set->list just-bound) env)
+								#t))])
+				     
+				     (let ([case-code (make-case-code
+						       free-lambda-vars
+						       local-lambda-vars
+						       global-lambda-vars
+						       used-lambda-vars
+						       captured-lambda-vars
+						       code #f children-codes
+						       #f)])
+				       (for-each (lambda (c) (set-code-case-parent! c case-code))
+						 children-codes)
+				       (make-case-info lambda-body case-code 
+						       global-lambda-vars
+						       used-lambda-vars 
+						       captured-lambda-vars 
+						       L-max-arity
+						       multi)))))
+			       (zodiac:case-lambda-form-args ast)
+			       (zodiac:case-lambda-form-bodies ast))]
+			     [case-codes (map case-info-case-code case-infos)]
+			     [all-children (apply append (map code-children case-codes))])
+			(set-procedure-code-case-codes! code case-codes)
+			(set-code-children! code all-children)
+			(for-each (lambda (c) (set-code-parent! c code)) all-children)
+			(add-child-code! code)
+			(let loop ([l case-infos])
+			  (if (null? l)
+			      (begin
+				;; set the body
+				(zodiac:set-case-lambda-form-bodies! ast (map case-info-body case-infos))
+
+				;; now annotate this lambda form with the code
+				(set-annotation! ast code)
+
+				;; Propogate free, used, and captured vars:
+				(register-code-vars! code #t)
+
+				;; finally return it
+				(values ast #f))
+			      
+			      (begin
+				(set-code-free-vars! 
+				 code
+				 (set-union (code-free-vars
+					     (case-info-case-code (car l)))
+					    (code-free-vars code)))
+				(set-code-local-vars! 
+				 code
+				 (set-union (code-local-vars
+					     (case-info-case-code (car l)))
+					    (code-local-vars code)))
+				(set-code-global-vars!
+				 code
+				 (set-union (case-info-global-vars (car l))
+					    (code-global-vars code)))
+				(set-code-used-vars!
+				 code
+				 (set-union (case-info-used-vars (car l))
+					    (code-used-vars code)))
+				(set-code-captured-vars!
+				 code
+				 (set-union (case-info-captured-vars (car l))
+					    (code-captured-vars code)))
+				(set-closure-code-max-arity!
+				 code
+				 (max (closure-code-max-arity code)
+				      (case-info-max-arity (car l))))
+				(set-closure-code-return-multi! 
+				 code
+				 (or-multi (closure-code-return-multi code)
+					   (case-info-return-multi (car l))))
+				(loop (cdr l))))))]
+		     
+		     ;;--------------------------------------------------------------
+		     ;; LET EXPRESSIONS
+		     ;;    keep track of the bindings introduced so that each
+		     ;;    expression can keep track of all the bindings it needs
+		     ;;    this flattens environments
+		     ;;    Several values may be bound at once.
+		     ;;
+		     ;;    in let, variables are assumed to be
+		     ;;    immutable and known; we store this information
+		     ;;    in the binding structure in the compiler:bound structure..
+		     ;;
+		     ;;    (let ([x (set! y A)]) M) ->
+		     ;;      (begin (set! y A) (let ([x (void)]) M))
+		     ;;
+		     ;;    if the variable bound is constant, the let is discarded,
+		     ;;    and the value is naturally propagated.
+		     ;;
+		     [(zodiac:let-values-form? ast)
+		      (let*-values ([(val val-multi) 
+				     (analyze! (car (zodiac:let-values-form-vals ast)) env inlined #f #f)]
+				    [(vars) (car (zodiac:let-values-form-vars ast))]
+				    [(convert-set!-val)
+				     (lambda ()   
+				       (set-car! (zodiac:let-values-form-vals ast)
+						 (zodiac:make-special-constant 
+						  'void))
+				       (zodiac:make-begin-form 	   
+					(zodiac:zodiac-stx ast)
+					(make-empty-box)
+					(list val ast)))])
+			
+			(if (= 1 (length (car (zodiac:let-values-form-vars ast))))
+			    
+					; this is a one-value binding let
+			    (let* ([var (car vars)]
+				   [binding (get-annotation var)])
+			      
+			      (when (eq? val-multi #t)
+				((if (compiler:option:stupid) compiler:warning compiler:error)
+				 ast
+				 "returning zero or multiple values to a context expecting 1 value"))
+			      
+			      (add-local-var! var)
+			      
+			      (let-values ([(body body-multi)
+					    (analyze! (zodiac:let-values-form-body ast) 
+						      (cons var env)
+						      inlined tail? wcm-tail?)]
+					   [(known-val) (extract-varref-known-val var)])
+				
+				(if (and (compiler:option:propagate-constants)
+					 (not (binding-mutable? binding))
+					 known-val
+					 (can-propagate-constant? known-val)
+					 (can-drop-expression? val)
+					 ;; can't eliminiate if a letrec->let variable
+					 (not (binding-letrec-set? binding))
+					 ;; can't eliminate if it is used by a bad application
+					 ;;   or by invoke
+					 (not (binding-known-but-used? binding)))
+				    
+				    ;; discard the let:
+				    (begin
+				      (remove-local-var! var)
+				      (values body body-multi))
+
+				    ;; otherwise, process normally
+				    (begin
+				      
+				      (set-car! (car (zodiac:let-values-form-vars ast)) 
+						var)
+				      (zodiac:set-let-values-form-body! ast body)
+				      
+				      (if (zodiac:set!-form? val)
+					  
+					  ;; if we're binding the result of a set!-form, 
+					  ;; turn it into
+					  ;; a void.
+					  (values (convert-set!-val) #f)
+					  
+					  ;; if it's any other expression, we're done.
+					  (begin
+					    (set-car! (zodiac:let-values-form-vals ast)
+						      val)
+					    (values ast body-multi)))))))
+			    
+			    ;; this is a multiple (or zero) value binding let
+			    ;; the values are unknown to simple analysis so skip
+			    ;; that stuff
+			    (begin
+			      (set-car! (zodiac:let-values-form-vars ast) vars)
+					; these are all new bindings
+			      (for-each add-local-var! vars)
+					; analyze the body
+			      (let-values ([(body body-multi) 
+					    (analyze! (zodiac:let-values-form-body ast)
+						      (append vars env)
+						      inlined
+						      tail? wcm-tail?)])
+				(zodiac:set-let-values-form-body! ast body)
+				
+				(if (zodiac:set!-form? val)
+				    (begin
+				      ((if (compiler:option:stupid) compiler:warning compiler:error)
+				       val
+				       (format
+					"returning 1 value (void) to a context expecting ~a values"
+					(length vars)))
+				      (when (compiler:option:stupid)
+					(values (convert-set!-val) #f)))
+					; if it's any other option, we're done
+				    (begin
+				      (set-car! (zodiac:let-values-form-vals ast) val)
+				      (values ast body-multi)))))
+			    
+			    ))]
+
+		     ;;-----------------------------------------------------------------
+		     ;; LETREC EXPRESSIONS
+		     ;;
+		     ;; if the letrec form binds only lambda values and those bindings
+		     ;; are not mutable, we keep this as a letrec, otherwise we 
+		     ;; transform it to a let+set! combination as R4RS.
+		     ;;
+		     [(zodiac:letrec-values-form? ast)
+
+		      (if (and 
+			   ;; Well-behaved if everything's a closure
+			   (andmap zodiac:case-lambda-form? 
+				   (zodiac:letrec-values-form-vals ast))
+			   ;; and all are one-variable bindings
+			   (andmap (lambda (l) (= 1 (length l))) 
+				   (zodiac:letrec-values-form-vars ast))
+			   ;; and all are immutable
+			   (andmap (lambda (l)
+				     (not (binding-mutable? (get-annotation (car l)))))
+				   (zodiac:letrec-values-form-vars ast)))
+			  
+			  ;;-----------------------------------------------------------
+			  ;; WELL-BEHAVED LETREC (incomplete bindings never exposed)
+			  ;;  mark appropriate variables as letrec bound
+			  ;;
+			  (let* ([vars (map car (zodiac:letrec-values-form-vars ast))])
+			    (set! local-vars (set-union (list->set vars) local-vars))
+			    (let ([new-env (append vars env)])
+			      (let-values ([(vals) (map (lambda (val)
+							  (analyze!-sv val new-env inlined))
+							(zodiac:letrec-values-form-vals ast))]
+					   [(body body-multi) (analyze! 
+							       (zodiac:letrec-values-form-body ast) 
+							       new-env
+							       inlined
+							       tail? wcm-tail?)]
+					   [(vars) (map car (zodiac:letrec-values-form-vars ast))])
+				
+				(for-each (lambda (var) (set-binding-rec?! (get-annotation var) #t))
+					  vars)
+				(zodiac:set-letrec-values-form-vals! ast vals)
+				(zodiac:set-letrec-values-form-body! ast body)
+				
+				(values ast body-multi))))
+			  
+			  ;;-----------------------------------------------------------
+			  ;; POSSIBLY POORLY BEHAVED LETREC
+			  ;;   rewrite as let+set!
+			  ;;
+			  (begin
+			    (when (compiler:option:verbose)
+			      (compiler:warning ast "letrec will be rewritten with set!"))
+			    (debug "rewriting letrec~n")
+			    (let ([new-ast (letrec->let+set! ast)])
+			      (debug "reanalyzing...~n")
+			      (analyze! new-ast env inlined tail? wcm-tail?))))]
+
+		     ;;-----------------------------------------------------
+		     ;; IF EXPRESSIONS
+		     ;;
+		     ;; just analyze the 3 branches.  Very easy
+		     [(zodiac:if-form? ast)
+		      (zodiac:set-if-form-test! ast (analyze!-sv (zodiac:if-form-test ast) env inlined))
+		      (let-values ([(then then-multi) (analyze! (zodiac:if-form-then ast) env inlined tail? wcm-tail?)]
+				   [(else else-multi) (analyze! (zodiac:if-form-else ast) env inlined tail? wcm-tail?)])
+			(zodiac:set-if-form-then! ast then)
+			(zodiac:set-if-form-else! ast else)
+			
+			(values ast (or-multi then-multi else-multi)))]
+		     
+		     ;;--------------------------------------------------------
+		     ;; BEGIN EXPRESSIONS
+		     ;;
+		     ;; analyze the branches
+		     [(zodiac:begin-form? ast)
+
+		      (let ([last-multi
+			     (let loop ([bodies (zodiac:begin-form-bodies ast)])
+			       (if (null? (cdr bodies))
+				   (let-values ([(e last-multi) (analyze! (car bodies) env inlined tail? wcm-tail?)])
+				     (set-car! bodies e)
+				     last-multi)
+				   (begin
+				     (set-car! bodies (analyze!-ast (car bodies) env inlined))
+				     (loop (cdr bodies)))))])
+
+			(values ast last-multi))]
+		     
+		     
+		     ;;--------------------------------------------------------
+		     ;; BEGIN0 EXPRESSIONS
+		     ;;
+		     ;; analyze the branches
+		     [(zodiac:begin0-form? ast)
+		      (let-values ([(0expr 0expr-multi) (analyze! (zodiac:begin0-form-first ast) env inlined #f #f)])
+			(zodiac:set-begin0-form-first! ast 0expr)
+			(zodiac:set-begin0-form-rest! ast (analyze!-ast (zodiac:begin0-form-rest ast) env inlined))
+			(let ([var (get-annotation ast)])
+			  (add-local-var! var))
+			(values ast 0expr-multi))]
+		     
+		     ;;--------------------------------------------------------
+		     ;; SET! EXPRESSIONS
+		     ;;
+		     ;; we analyze the target, which will register it as being
+		     ;; mutable or used, as necessary.  Then we analyze the value.
+		     ;;
+		     [(zodiac:set!-form? ast)
+
+		      (let ([target (analyze-varref! (zodiac:set!-form-var ast) env #f #t)])
+			(zodiac:set-set!-form-var! ast target)
+			(zodiac:set-set!-form-val! 
+			 ast 
+			 (analyze!-sv (zodiac:set!-form-val ast) env inlined)))
+		      
+		      (values ast #f)]
+		     
+		     ;;---------------------------------------------------------
+		     ;; DEFINE EXPRESSIONS
+		     ;;
+		     ;; defines are very tricky, eh what?
+		     ;;
+		     [(zodiac:define-values-form? ast)
+
+		      (prepare-local-lists)
+
+		      (zodiac:set-define-values-form-vars!
+		       ast
+		       (map (lambda (v) 
+			      (let ([v (if (varref:current-invoke-module)
+					   v
+					   ;; Make sure v is not mapped to an import:
+					   (ensure-top-level v))])
+				(analyze-varref! v env #f #t)))
+			    (zodiac:define-values-form-vars ast)))
+
+		      (move-over-local-lists)
+
+		      (zodiac:set-define-values-form-val! 
+		       ast
+		       (analyze!-ast (zodiac:define-values-form-val ast) env inlined))
+		      (values ast #f)]
+		     
+		     ;;----------------------------------------------------------
+		     ;; DEFINE-SYNTAX
+		     ;;
+		     [(zodiac:define-syntaxes-form? ast)
+		      (for-each (lambda (name)
+				  (compiler:get-symbol-const! #f (zodiac:varref-var name)))
+				(zodiac:define-syntaxes-form-names ast))
+		      (zodiac:set-define-syntaxes-form-expr!
+		       ast
+		       (analyze!-ast (zodiac:define-syntaxes-form-expr ast) env inlined))
+		      (values ast #f)]
+		     
+		     ;;-------------------------------------------------------------------
+		     ;; APPLICATIONS
+		     ;;   analyze all the parts.  replace with a compiler:app
+		     ;;    annotated with tail?
+		     ;;  If this is a call to a primitive, check the arity.
+		     ;;
+		     [(zodiac:app? ast)
+		      (check-for-inlining
+		       ast
+		       env
+		       inlined
+		       tail?
+		       (lambda (new-ast new-inlined)
+			 (when (compiler:option:verbose)
+			   (compiler:warning ast "inlining procedure call"))
+					; We inlined - analyze the new form
+			 (analyze! new-ast env new-inlined tail? wcm-tail?))
+		       (lambda (why)
+			 '(begin
+			    (zodiac:print-start! (current-output-port) ast) 
+			    (printf "no inlining: ~a~n" (eval why)))
+			 (let* ([fun (let ([v (analyze!-sv (zodiac:app-fun ast) env inlined)])
+				       (if (zodiac:varref? v)
+					   v
+					   ;; known non-procedure!
+					   (let ([var (zodiac:app-fun ast)])
+					     ((if (compiler:option:stupid)
+						  compiler:warning 
+						  compiler:error)
+					      ast 
+					      "application of a non-procedure")
+					     (if (zodiac:varref? var)
+						 (begin
+						   (set-binding-known-but-used?! 
+						    (get-annotation (zodiac:bound-varref-binding var)) 
+						    #t)
+						   (analyze-varref! var env #f #t))
+						 (analyze!-sv var env inlined)))))]
+				[primfun (app-prim-name (get-annotation ast))]
+				[multi (if primfun
+					   (let ([a (primitive-result-arity 
+						     (dynamic-require '#%kernel primfun))])
+					     (cond
+					      [(and (number? a) (= a 1)) #f]
+					      [(number? a) #t]
+					      [else 'possible]))
+					   'possible)]
+				[args (map (lambda (arg)
+					     (analyze!-sv arg env inlined))
+					   (zodiac:app-args ast))])
+			   
+					; for all functions, do this stuff
+			   (zodiac:set-app-fun! ast fun)
+			   (zodiac:set-app-args! ast args)
+			   (set-app-tail?! (get-annotation ast) tail?)
+
+			   (register-arity! (length args))
+
+			   (values ast multi))))]
+		     
+		     ;;-------------------------------------------------------------------
+		     ;; WITH-CONTINUATION-MARK
+		     ;;
+		     ;; analyze the key, val, and body
+		     ;;
+		     [(zodiac:with-continuation-mark-form? ast)
+		      
+		      (zodiac:set-with-continuation-mark-form-key!
+		       ast
+		       (analyze!-sv (zodiac:with-continuation-mark-form-key ast) env inlined))
+		      
+		      (zodiac:set-with-continuation-mark-form-val!
+		       ast
+		       (analyze!-sv (zodiac:with-continuation-mark-form-val ast) env inlined))
+		      
+		      (let-values ([(body body-multi) 
+				    (analyze! (zodiac:with-continuation-mark-form-body ast) env inlined tail? #t)])
+			
+			(if (or tail? wcm-tail?)
+					; No frame push, so no need for begin0-like handling
+			    (set-annotation! ast #f)
+			    
+			    (let ([var (get-annotation ast)])
+			      (add-local-var! var)))
+
+			(zodiac:set-with-continuation-mark-form-body!
+			 ast
+			 body)
+
+			(values ast body-multi))]
+
+		     ;;-----------------------------------------------------------------
+		     ;; QUOTE-SYNTAX
+		     ;;
+		     ;; Construct constant.
+		     ;;
+		     [(zodiac:quote-syntax-form? ast)
+		      (let ([ret (const:make-syntax-constant (zodiac:quote-syntax-form-expr ast))])
+			;; Put a pointer to the constructed constant in the quote-form's backbox
+			(set-annotation! ast ret)
+
+			;; This variable is per-load:
+			(add-global-var! const:the-per-load-statics-table)
+			
+			(values ret #f))]
+		     
+		     ;;-----------------------------------------------------------
+		     ;; MODULE
+		     ;;
+		     [(zodiac:module-form? ast)
+
+		      (zodiac:set-module-form-body!
+		       ast
+		       (analyze!-ast (zodiac:module-form-body ast) env inlined))
+		      
+		      (values ast #f)]
+		     
+
+		     [else (compiler:internal-error
+			    ast
+			    (format "unsupported syntactic form (~a)"
+				    (if (struct? ast)
+					(vector-ref (struct->vector ast) 0)
+					ast)))]))])
+	      
+	      ;; analyze the expression and return it with the local variables
+	      ;; it creates.  
+	      (let-values ([(ast multi) (analyze! ast env 0 tail? #f)])
+		(values ast
+			free-vars
+			local-vars
+			global-vars
+			locals-used
+			captured-vars
+			codes
+			max-arity
+			multi)))))))))
diff --git a/collects/compiler/private/anorm.ss b/collects/compiler/private/anorm.ss
new file mode 100644
index 0000000000..e3c0b36f9c
--- /dev/null
+++ b/collects/compiler/private/anorm.ss
@@ -0,0 +1,371 @@
+;; A-Normalizer
+;; (c) 1996-7 Sebastian Good
+;; (c) 1997-8 PLT, Rice University
+
+; This file contains an "a-normalizer" for Zodiac abstract
+;  syntax trees for Scheme.
+; This linear time algorithm is adapted from "The Essence
+;  of Compiling with Continuations"(Flanagan/Sabry/Duba/Felleisen)
+
+; For unknown historical reasons, this phase is implemented as a
+;  non-destructive procedure on ASTs.
+
+; An expressions is given a name when
+;  1) it is not already the RHS of a let-assignment
+;  2) it is not a tail expression
+;  3) the value is not known to be ignored
+; There's also a special hack for the test part of an
+;  `if' expression: it might be preserved as an
+;  application inlined in the `if' form.
+
+; After a-normalizations, all let expressions are "linearized": one
+;  binding clause for each let-values expression. (Of course, the
+;  single clause can bind multiple variables.) This linearization does
+;  not apply to letrec expressions.
+
+;;; Annotatitons: ----------------------------------------------
+;;    begin0 - lexical-binding for storing 0th expression result
+;;    with-continuation-mark - lexical-binding for storing body
+;;                             result
+;;; ------------------------------------------------------------
+
+(module anorm mzscheme
+  (require (lib "unitsig.ss")
+	  (lib "list.ss")
+	  (lib "etc.ss"))
+
+  (require (lib "zodiac-sig.ss" "syntax"))
+
+  (require "sig.ss")
+  (require "../sig.ss")
+
+  (provide anorm@)
+  (define anorm@
+    (unit/sig
+	compiler:anorm^
+      (import (compiler:option : compiler:option^)
+	      compiler:library^
+	      compiler:cstructs^
+	      (zodiac : zodiac^)
+	      compiler:zlayer^
+	      compiler:driver^)
+
+      (define compiler:a-value?
+	(one-of zodiac:quote-form? zodiac:varref? zodiac:quote-syntax-form?))
+
+      (define a-normalize
+	(letrec ([linearize-let-values
+		  (lambda (ast)
+		    (let ([vars (zodiac:let-values-form-vars ast)])
+		      (cond
+		       [(null? (cdr vars)) ast] ; to prevent N^2 behavior
+		       [else
+			(let linear ([vars vars]
+				     [vals (zodiac:let-values-form-vals ast)])
+			  (if (null? vars)
+			      (zodiac:let-values-form-body ast)
+			      (zodiac:make-let-values-form (zodiac:zodiac-stx ast)
+							   (make-empty-box)
+							   (list (car vars))
+							   (list (car vals))
+							   (linear (cdr vars) 
+								   (cdr vals)))))])))]
+		 [normalize-name
+		  (lambda (ast k)
+		    (normalize-name/special-a-values ast k (lambda (x) #f)))]
+		 [normalize-name/special-a-values
+		  ;; The magic goodie that names expressions.  If the expression
+		  ;; handed in is not an immediate a-value, it is named and the
+		  ;; computation continues; syntax correlation exists!
+		  (lambda (ast k special-a-value?)
+		    (a-normalize
+		     ast
+		     (lambda (exp)
+		       (if (or (compiler:a-value? exp) (special-a-value? exp))
+			   (k exp)
+			   (let* ([tname (gensym)]
+				  [tbound (zodiac:make-lexical-binding
+					   (zodiac:zodiac-stx exp)
+					   (make-empty-box)
+					   tname
+					   tname)]
+				  [varref (zodiac:binding->lexical-varref tbound)])
+			     ;; hack: #f annotation => not mutable, or anything else
+			     ;; (The hack is resolved by the prephase:is-mutable?, etc.
+			     ;; procedures.)
+			     (set-annotation! tbound #f) 
+			     (let ([body (k varref)])
+			       (zodiac:make-let-values-form
+				(zodiac:zodiac-stx exp)
+				(make-empty-box)
+				(list (list tbound))
+				(list exp)
+				body)))))))]
+		 ;; This names a list of expressions (eg argument list)
+		 [normalize-name*
+		  (lambda (ast* k)
+		    (if (null? ast*)
+			(k null)
+			(normalize-name
+			 (car ast*)
+			 (lambda (term)
+			   (normalize-name* (cdr ast*)
+					    (lambda (term*)
+					      (k (cons term term*))))))))]
+
+
+		 [a-normalize
+		  (lambda (ast k)
+		    (when (compiler:option:debug)
+		      (zodiac:print-start! (debug:get-port) ast)
+		      (newline (debug:get-port)))
+		    (cond 
+		     
+		     ;;----------------------------------------------------------------
+		     ;; LAMBDA EXPRESSIONS
+		     ;;    We must make a recursive call to normalize the body.
+		     ;;    Otherwise, we just pass them on.  Lambda must be queried
+		     ;;    before a-value, since lambda might be an a-value
+		     ;;
+		     ;; (norm (lambda x M)) -> (lambda x (norm M))
+		     ;;
+		     [(zodiac:case-lambda-form? ast)
+		      (k (zodiac:make-case-lambda-form
+			  (zodiac:zodiac-stx ast)
+			  (zodiac:parsed-back ast)
+			  (zodiac:case-lambda-form-args ast)
+			  (map (lambda (body)
+				 (a-normalize body identity))
+			       (zodiac:case-lambda-form-bodies ast))))]
+		     
+		     ;;--------------------------------------------------------------
+		     ;; A-VALUES
+		     ;;    a-values are passed along unharmed.  We have to handle
+		     ;;    lambda separately above, but otherwise
+		     ;;
+		     ;; (norm a-value) -> a-value
+		     ;;
+		     [(compiler:a-value? ast) (k ast)]
+		     
+		     ;;--------------------------------------------------------------
+		     ;; LET EXPRESSIONS
+		     ;;    with let, we must normalize the bound expressions
+		     ;;    as well as the body.  We only bind one variable per
+		     ;;    let in Core Scheme, so we have to expand these out
+		     ;;    Zodiac already tells us if something is unbound, so we
+		     ;;    can linearize this let as we like.
+		     ;;
+		     ;;    we treat letrec separately to reduce the cost of 
+		     ;;    optimization
+		     ;;    later.  We don't have to look for special cases of set!
+		     ;;    we do not guarantee a-values in the vals slot of the letrec
+		     ;;    since we do each of those in its own context, otherwise we
+		     ;;    can get bindings messed up.
+		     ;;
+		     ;; (norm (let x M B) k) -> 
+		     ;;       (norm M (lambda V (let x V (norm B k))))
+		     ;; (norm (letrec [x M] ... B)) -> 
+		     ;;     (letrec [x (norm M)] ... (norm B))
+		     ;;
+		     [(zodiac:let-values-form? ast)
+		      (if (null? (zodiac:let-values-form-vars ast))
+			  (a-normalize (zodiac:let-values-form-body ast) k)
+			  (let ([linear (linearize-let-values ast)])
+			    (a-normalize
+			     (car (zodiac:let-values-form-vals ast))
+			     (lambda (V)
+			       (zodiac:make-let-values-form 
+				(zodiac:zodiac-stx linear)
+				(zodiac:parsed-back linear)
+				(zodiac:let-values-form-vars 
+				 linear)
+				(list V)
+				(a-normalize 
+				 (zodiac:let-values-form-body 
+				  linear)
+				 k))))))]
+		     
+		     [(zodiac:letrec-values-form? ast)
+		      (let ([vals (map (lambda (val) (a-normalize val identity))
+				       (zodiac:letrec-values-form-vals ast))])
+			(zodiac:make-letrec-values-form
+			 (zodiac:zodiac-stx ast)
+			 (zodiac:parsed-back ast)
+			 (zodiac:letrec-values-form-vars ast)
+			 vals
+			 (a-normalize (zodiac:letrec-values-form-body ast) k)))]
+		     
+		     ;;---------------------------------------------------------------
+		     ;; IF EXPRESSIONS
+		     ;;
+		     ;; We do not make a recursive call for the test since it is in the
+		     ;; current 'context'.  We want only a-values in the test slot,
+		     ;; or an application of a primitive function to a-values. 
+		     ;;
+		     ;; We specially allow primitive applications
+		     ;; of a-values so the optimizer can recognize tests that can be
+		     ;; implemented primitively, e.g., (zero? x)
+		     ;;
+		     ;; (norm (if A B C) k) ->
+		     ;;   (name A (lambda test (k (if test (norm B) (norm C)))))
+		     ;;
+		     [(zodiac:if-form? ast)
+		      (normalize-name/special-a-values
+		       (zodiac:if-form-test ast)
+		       (lambda (test)
+			 (k (zodiac:make-if-form (zodiac:zodiac-stx ast)
+						 (zodiac:parsed-back ast)
+						 test    
+						 (a-normalize (zodiac:if-form-then ast)
+							      identity)
+						 (a-normalize (zodiac:if-form-else ast)
+							      identity))))
+		       (lambda (x)
+			 (and (zodiac:app? x)
+			      (let ([fun (zodiac:app-fun x)])
+				(and (zodiac:top-level-varref? fun)
+				     (varref:has-attribute? fun varref:primitive))))))]
+		     
+		     ;;----------------------------------------------------------------
+		     ;; BEGIN EXPRESSIONS
+		     ;;
+		     ;;    Begins pass through as begins, but every body is 
+		     ;;    a-normalized.
+		     ;;    We are guaranteed no empty begins
+		     ;;
+		     ;; (norm (begin A B) k) ->
+		     ;;    (norm A (lambda first (begin first (norm B k))))
+		     ;;
+		     [(zodiac:begin-form? ast)   
+		      (k (zodiac:make-begin-form
+			  (zodiac:zodiac-stx ast)
+			  (zodiac:parsed-back ast)
+			  (map (lambda (b) (a-normalize b identity)) 
+			       (zodiac:begin-form-bodies ast))))]
+		     
+		     ;;----------------------------------------------------------------
+		     ;; BEGIN0 EXPRESSIONS
+		     ;;
+		     ;;    The first is named in a special way, and the rest passes through
+		     ;;
+		     ;; (norm (begin0 A B) k) ->
+		     ;;    (k (begin0 (norm A identity) (norm B identity)))
+		     ;;
+		     [(zodiac:begin0-form? ast)
+		      (let* ([tname (gensym)]
+			     [tbound (zodiac:make-lexical-binding
+				      (zodiac:zodiac-stx ast)
+				      (make-empty-box)
+				      tname
+				      tname)]
+			     [begin0-exp
+			      (zodiac:make-begin0-form
+			       (zodiac:zodiac-stx ast)
+			       (zodiac:parsed-back ast)
+			       (list
+				(a-normalize (zodiac:begin0-form-first ast) identity)
+				(a-normalize (zodiac:begin0-form-rest ast) identity)))])
+			(set-annotation! begin0-exp tbound)
+			(k begin0-exp))]
+
+		     ;;-----------------------------------------------------------
+		     ;; MODULE
+		     ;;
+		     [(zodiac:module-form? ast)
+		      (k (zodiac:make-module-form
+			  (zodiac:zodiac-stx ast)
+			  (zodiac:parsed-back ast)
+			  (zodiac:module-form-name ast)
+			  (zodiac:module-form-requires ast)
+			  (zodiac:module-form-for-syntax-requires ast)
+			  (zodiac:module-form-for-template-requires ast)
+			  (a-normalize (zodiac:module-form-body ast) identity)
+			  #f ; see split-module in driver.ss
+			  (zodiac:module-form-provides ast)
+			  (zodiac:module-form-syntax-provides ast)
+			  (zodiac:module-form-indirect-provides ast)
+			  (zodiac:module-form-kernel-reprovide-hint ast)
+			  (zodiac:module-form-self-path-index ast)))]
+
+		     ;;---------------------------------------------------------------
+		     ;; SET! EXPRESSIONS / DEFINE EXPRESSIONS
+		     ;;    
+		     ;; (norm (set! x M)) -> (name M (lambda val (set! x M)))
+		     ;; (norm (define x M))->(define x (norm M identity))
+		     ;;
+		     [(zodiac:set!-form? ast)
+		      (normalize-name 
+		       (zodiac:set!-form-val ast)
+		       (lambda (norm-val)
+			 (k (zodiac:make-set!-form
+			     (zodiac:zodiac-stx ast)
+			     (zodiac:parsed-back ast)
+			     (zodiac:set!-form-var ast)
+			     norm-val))))]
+		     
+		     [(zodiac:define-values-form? ast)
+		      (k (zodiac:make-define-values-form
+			  (zodiac:zodiac-stx ast)
+			  (zodiac:parsed-back ast)
+			  (zodiac:define-values-form-vars ast)
+			  (a-normalize (zodiac:define-values-form-val ast) identity)))]
+		     
+		     ;;----------------------------------------------------------
+		     ;; DEFINE-SYNTAX
+		     ;;
+		     [(zodiac:define-syntaxes-form? ast)
+		      (k (zodiac:make-define-syntaxes-form 
+			  (zodiac:zodiac-stx ast)
+			  (zodiac:parsed-back ast)
+			  (zodiac:define-syntaxes-form-names ast)
+			  (a-normalize (zodiac:define-syntaxes-form-expr ast) identity)))]
+		     
+		     ;;---------------------------------------------------------------
+		     ;; APPLICATIONS
+		     ;;    We will always apply the a-normalization to the function
+		     ;;    position of arguments
+		     ;;    first normalize the function, then the list of arguments
+		     ;;
+		     ;; (norm (M A ...) k) ->
+		     ;;  (name M 
+		     ;;       (lambda fun (name* A .. (lambda term .. (fun term ..)))))
+		     [(zodiac:app? ast)
+		      (normalize-name 
+		       (zodiac:app-fun ast)
+		       (lambda (norm-fun)
+			 (normalize-name*
+			  (zodiac:app-args ast)
+			  (lambda (norm-terms)
+			    (k (zodiac:make-app (zodiac:zodiac-stx ast)
+						(zodiac:parsed-back ast)
+						norm-fun
+						norm-terms))))))]
+		     
+		     ;;-----------------------------------------------------------
+		     ;; WITH-CONTINUATION-MARK
+		     ;;
+		     [(zodiac:with-continuation-mark-form? ast)
+		      (normalize-name
+		       (zodiac:with-continuation-mark-form-key ast)
+		       (lambda (key)
+			 (normalize-name
+			  (zodiac:with-continuation-mark-form-val ast)
+			  (lambda (val)
+			    (let* ([tname (gensym)]
+				   [tbound (zodiac:make-lexical-binding
+					    (zodiac:zodiac-stx ast)
+					    (make-empty-box)
+					    tname
+					    tname)]
+				   [wcm (zodiac:make-with-continuation-mark-form
+					 (zodiac:zodiac-stx ast)
+					 (zodiac:parsed-back ast)
+					 key val
+					 (a-normalize
+					  (zodiac:with-continuation-mark-form-body ast)
+					  identity))])
+			      (set-annotation! wcm tbound)
+			      (k wcm))))))]
+
+		     [else (error 'a-normalize "unsupported ~a" ast)]))])
+	  a-normalize)))))
diff --git a/collects/compiler/private/base.ss b/collects/compiler/private/base.ss
new file mode 100644
index 0000000000..2c51b15b3e
--- /dev/null
+++ b/collects/compiler/private/base.ss
@@ -0,0 +1,217 @@
+
+(module base mzscheme
+  (require (lib "unitsig.ss"))
+
+  (require "../sig.ss")
+  (require "sig.ss")
+
+  (require (lib "zodiac-sig.ss" "syntax")
+	   (lib "zodiac-unit.ss" "syntax"))
+
+  (require (lib "file-sig.ss" "dynext")
+	   (lib "link-sig.ss" "dynext")
+	   (lib "compile-sig.ss" "dynext"))
+
+  (require "zlayer.ss"
+	   "library.ss"
+	   "cstructs.ss"
+	   "prephase.ss"
+	   "anorm.ss"
+	   "const.ss"
+	   "known.ss"
+	   "analyze.ss"
+	   "lift.ss"
+	   "closure.ss"
+	   "vehicle.ss"
+	   "rep.ss"
+	   "vmscheme.ss"
+	   "vmphase.ss"
+	   "vmopt.ss"
+	   "vm2c.ss"
+	   "toplevel.ss"
+	   "driver.ss")
+
+  ;; The core Scheme->C compiler linkage, including everything
+  ;;  that's common to MrSpidey and non-MrSpidey compilation.
+
+  (provide base@)
+
+  (define base@
+    (compound-unit/sig
+     (import (COMPILE : dynext:compile^)
+	     (LINK : dynext:link^)
+	     (DFILE : dynext:file^)
+	     (OPTIONS : compiler:option^))
+     (link
+      [ZODIAC : zodiac^ (zodiac@)]
+      [ZLAYER : compiler:zlayer^ (zlayer@
+				  OPTIONS
+				  ZODIAC
+				  CSTRUCTS
+				  DRIVER)]
+      [LIBRARY : compiler:library^ (library@
+				    ZODIAC)]
+      [CSTRUCTS : compiler:cstructs^ (cstructs@
+				      LIBRARY
+				      ZODIAC
+				      ZLAYER)]
+      [PREPHASE : compiler:prephase^ (prephase@
+				      OPTIONS
+				      LIBRARY
+				      CSTRUCTS
+				      ZODIAC
+				      ZLAYER
+				      DRIVER)]
+      [ANORM : compiler:anorm^ (anorm@
+				OPTIONS
+				LIBRARY
+				CSTRUCTS
+				ZODIAC
+				ZLAYER
+				DRIVER)]
+      [CONST : compiler:const^ (const@
+				OPTIONS
+				LIBRARY
+				CSTRUCTS
+				ZODIAC
+				ANALYZE
+				ZLAYER
+				VMSTRUCTS
+				TOP-LEVEL
+				DRIVER)]
+      [KNOWN : compiler:known^ (known@
+				OPTIONS
+				LIBRARY
+				CSTRUCTS
+				ZODIAC
+				ZLAYER
+				PREPHASE
+				ANORM
+				CONST
+				CLOSURE
+				REP
+				DRIVER)]
+      [ANALYZE : compiler:analyze^ (analyze@
+				    OPTIONS
+				    LIBRARY
+				    CSTRUCTS
+				    ZODIAC
+				    ZLAYER
+				    PREPHASE
+				    ANORM
+				    KNOWN
+				    CONST
+				    REP
+				    VM2C
+				    DRIVER)]
+      [LIFT : compiler:lift^ (lift@
+			      OPTIONS
+			      LIBRARY
+			      CSTRUCTS
+			      ZODIAC
+			      ZLAYER
+			      KNOWN
+			      TOP-LEVEL
+			      ANALYZE
+			      CONST
+			      CLOSURE
+			      DRIVER)]
+      [CLOSURE : compiler:closure^ (closure@
+				    OPTIONS
+				    LIBRARY
+				    CSTRUCTS
+				    ZODIAC
+				    ZLAYER
+				    CONST
+				    DRIVER)]
+      [VEHICLE : compiler:vehicle^ (vehicle@
+				    OPTIONS
+				    LIBRARY
+				    CSTRUCTS
+				    ZODIAC
+				    ZLAYER
+				    CONST
+				    KNOWN
+				    CLOSURE
+				    DRIVER)]
+      [REP : compiler:rep^ (rep@
+			    LIBRARY
+			    CSTRUCTS
+			    ANALYZE
+			    ZODIAC
+			    ZLAYER
+			    CONST
+			    VEHICLE
+			    DRIVER)]
+      [VMSTRUCTS : compiler:vmstructs^ (vmscheme@
+					LIBRARY
+					CSTRUCTS
+					ZODIAC
+					ZLAYER
+					DRIVER)]
+      [VMPHASE : compiler:vmphase^ (vmphase@
+				    OPTIONS
+				    LIBRARY
+				    CSTRUCTS
+				    ZODIAC
+				    ZLAYER
+				    ANALYZE
+				    CONST
+				    VMSTRUCTS
+				    REP
+				    CLOSURE
+				    VEHICLE
+				    DRIVER)]
+      [VMOPT : compiler:vmopt^ (vmopt@
+				OPTIONS
+				LIBRARY
+				CSTRUCTS
+				ZODIAC
+				ZLAYER
+				VMSTRUCTS
+				KNOWN
+				REP
+				VMPHASE
+				DRIVER)]
+      [VM2C : compiler:vm2c^ (vm2c@
+			      OPTIONS
+			      LIBRARY
+			      CSTRUCTS
+			      ZODIAC
+			      ZLAYER
+			      ANALYZE
+			      CONST
+			      REP
+			      CLOSURE
+			      VEHICLE
+			      VMSTRUCTS
+			      DRIVER)]
+      [TOP-LEVEL : compiler:top-level^ (toplevel@
+					LIBRARY
+					CSTRUCTS)]
+      [DRIVER : compiler:driver^ (driver@
+				  OPTIONS
+				  LIBRARY
+				  CSTRUCTS
+				  ZODIAC
+				  ZLAYER
+				  PREPHASE
+				  ANORM
+				  KNOWN
+				  ANALYZE
+				  CONST
+				  LIFT
+				  CLOSURE
+				  VEHICLE
+				  REP
+				  VMSTRUCTS
+				  VMPHASE
+				  VMOPT
+				  VM2C
+				  TOP-LEVEL
+				  COMPILE
+				  LINK
+				  DFILE)])
+     (export (open (DRIVER : compiler:inner^))))))
+
+
diff --git a/collects/compiler/private/closure.ss b/collects/compiler/private/closure.ss
new file mode 100644
index 0000000000..b473c60382
--- /dev/null
+++ b/collects/compiler/private/closure.ss
@@ -0,0 +1,291 @@
+;; collect closure-making expressions
+;; (c) 1996-1997 Sebastian Good
+;; (c) 1997-2001 PLT
+
+;; Closure-making expressions, such as lambda, are
+;;  replaced with explicit make-closure AST nodes.
+;; Closures that with empty free-variable sets are replaced
+;;  with varrefs to a one-time created global closure. These
+;;  create-once closures are collected into a list for
+;;  special handling.
+;; All closure-making AST nodes, which were replaced with
+;;  make-closure nodes, are collected into the list
+;;  compiler:closure-list.
+
+;;; Annotatitons: ----------------------------------------------
+;;    <no annotation changes>
+;;; ------------------------------------------------------------
+
+(module closure mzscheme
+  (require (lib "unitsig.ss")
+	  (lib "list.ss")
+	  (lib "etc.ss"))
+
+  (require (lib "zodiac-sig.ss" "syntax"))
+
+  (require "sig.ss")
+  (require "../sig.ss")
+
+  (provide closure@)
+  (define closure@
+    (unit/sig
+	compiler:closure^
+      (import (compiler:option : compiler:option^)
+	      compiler:library^
+	      compiler:cstructs^
+	      (zodiac : zodiac^)
+	      compiler:zlayer^
+	      compiler:const^
+	      compiler:driver^)
+
+      (define compiler:closure-list null)
+      (define compiler:add-closure!
+	(lambda (l)
+	  (set! compiler:closure-list
+		(cons l compiler:closure-list))))
+      (define (compiler:get-closure-list) compiler:closure-list)
+
+      (define-struct (top-level-varref/bind-from-lift zodiac:top-level-varref) (lambda pls?))
+
+      ;; fully lifted lambdas (i.e., really static, not per-load)
+      (define compiler:lifted-lambda-vars null) 
+      (define compiler:lifted-lambdas null) 
+      ;; one-time closure-creation to be performed per-load
+      (define compiler:once-closures-list null)
+      (define compiler:once-closures-globals-list null)
+
+      (define (compiler:get-lifted-lambda-vars) compiler:lifted-lambda-vars) 
+      (define (compiler:get-lifted-lambdas) compiler:lifted-lambdas) 
+      (define (compiler:get-once-closures-list) compiler:once-closures-list)
+      (define (compiler:get-once-closures-globals-list) compiler:once-closures-globals-list)
+
+      (define compiler:add-lifted-lambda!
+	(lambda (lam pls?)
+	  ;; Set the closure's liftable field to a new top-level-varref
+	  (let* ([code (get-annotation lam)]
+		 [var (gensym (if pls? 
+				  (if (varref:current-invoke-module)
+				      'pmilifted
+				      'pllifted)
+				  'lifted))]
+		 [sv (make-top-level-varref/bind-from-lift
+		      (zodiac:zodiac-stx lam)
+		      (make-empty-box)
+		      var
+		      #f
+		      (box '())
+		      #f
+		      #f
+		      #f
+		      lam
+		      (and pls? (or (varref:current-invoke-module) pls?)))]
+		 [def (zodiac:make-define-values-form 
+		       (zodiac:zodiac-stx lam)
+		       (make-empty-box)
+		       (list sv) lam)])
+	    (set-annotation! sv (varref:empty-attributes))
+	    (varref:add-attribute! sv varref:static)
+
+	    ;; Set the procedure annoation's `liftable' field to a list
+	    ;;  cotaining the sv, which indicates that it was just convrted;
+	    ;;  (list sv) is changed to sv by a pass in lift.ss.
+	    (set-procedure-code-liftable! code (list sv)) 
+
+	    (if pls?
+		(let ([def (if (varref:current-invoke-module)
+			       (let ([def (zodiac:make-module-form
+					   (zodiac:zodiac-stx def)
+					   (make-empty-box)
+					   #f #f #f #f
+					   def #f
+					   #f #f #f #f #f)])
+				 (set-annotation! 
+				  def 
+				  (let ([mi (varref:current-invoke-module)])
+				    (make-module-info mi
+						      #f
+						      (if (varref:module-invoke-syntax? mi)
+							  'syntax-body
+							  'body))))
+				 def)
+			       def)])
+		  
+		  (let ([mi (varref:current-invoke-module)])
+		    (varref:add-attribute! sv (or mi varref:per-load-static))
+		    ((if mi
+			 (lambda (v) (compiler:add-per-invoke-static-list! v mi))
+			 compiler:add-per-load-static-list!)
+		     var)
+		    (set! compiler:once-closures-list (cons def compiler:once-closures-list))
+		    (set! compiler:once-closures-globals-list (cons (code-global-vars code) compiler:once-closures-globals-list))))
+		(begin
+		  (set! compiler:lifted-lambda-vars (cons sv compiler:lifted-lambda-vars))
+		  (set! compiler:lifted-lambdas (cons def compiler:lifted-lambdas)))))))
+      
+      (define (compiler:init-once-closure-lists!)
+	(set! compiler:once-closures-list null)
+	(set! compiler:once-closures-globals-list null))
+      
+      (define (compiler:init-closure-lists!)
+	(set! compiler:closure-list null)
+	(set! compiler:lifted-lambda-vars null)
+	(compiler:init-once-closure-lists!)
+	(compiler:init-lifted-lambda-list!))
+      
+      (define (compiler:init-lifted-lambda-list!)
+	(set! compiler:lifted-lambdas null))
+
+      (define closure-expression!
+	(letrec
+	    ([transform-closure!
+	      (lambda (ast args)
+		(compiler:add-closure! ast)
+		(let* ([code (get-annotation ast)]
+		       [name (closure-code-name code)]
+		       [free (code-free-vars code)]
+		       [mk-closure (make-compiler:make-closure 
+				    (zodiac:zodiac-stx ast)
+				    ast free args
+				    name)])
+		  mk-closure))]
+	     [transform!
+	      (lambda (ast)
+		(cond
+		 
+		 ;;------------------------------------------------------------------
+		 ;; CONSTANTS
+		 ;;
+		 [(zodiac:quote-form? ast) ast]
+		 
+		 ;;------------------------------------------------------------------
+		 ;; VARIABLE REFERENCES
+		 ;;
+		 [(zodiac:varref? ast) ast]
+
+		 ;;------------------------------------------------------------------
+		 ;; LAMBDA EXPRESSIONS
+		 ;;
+		 ;; We turn this into a make-closure form and catalogue the code body
+		 ;; we also decide which vehicle in which to put the body
+		 ;;
+		 [(zodiac:case-lambda-form? ast)
+		  (zodiac:set-case-lambda-form-bodies! ast 
+						       (map (lambda (body)
+							      (transform! body))
+							    (zodiac:case-lambda-form-bodies ast)))
+		  (transform-closure! ast null)]
+
+		 ;;------------------------------------------------------------------
+		 ;; LET EXPRESSIONS
+		 ;;
+		 [(zodiac:let-values-form? ast)
+		  (zodiac:set-let-values-form-vals! 
+		   ast (map transform! (zodiac:let-values-form-vals ast)))
+		  (zodiac:set-let-values-form-body! 
+		   ast (transform! (zodiac:let-values-form-body ast)))
+		  ast]
+
+		 [(zodiac:letrec-values-form? ast)
+		  (zodiac:set-letrec-values-form-vals! 
+		   ast 
+		   (map transform! (zodiac:letrec-values-form-vals ast)))
+		  (zodiac:set-letrec-values-form-body! 
+		   ast (transform! (zodiac:letrec-values-form-body ast)))
+		  ast]
+		 
+		 ;;-----------------------------------------------------------------
+		 ;; IF EXPRESSIONS
+		 ;;
+		 [(zodiac:if-form? ast)
+		  (zodiac:set-if-form-test! ast (transform! (zodiac:if-form-test ast)))
+		  (zodiac:set-if-form-then! ast (transform! (zodiac:if-form-then ast)))
+		  (zodiac:set-if-form-else! ast (transform! (zodiac:if-form-else ast)))
+		  ast]
+
+		 ;;------------------------------------------------------------------
+		 ;; BEGIN EXPRESSIONS
+		 ;;
+		 [(zodiac:begin-form? ast)
+		  (map! transform! (zodiac:begin-form-bodies ast))
+		  ast]
+		 
+		 ;;------------------------------------------------------------------
+		 ;; BEGIN0 EXPRESSIONS
+		 ;;
+		 [(zodiac:begin0-form? ast)
+		  (zodiac:set-begin0-form-first!
+		   ast (transform! (zodiac:begin0-form-first ast)))
+		  (zodiac:set-begin0-form-rest!
+		   ast (transform! (zodiac:begin0-form-rest ast)))
+		  ast]
+		 
+		 ;;------------------------------------------------------------------
+		 ;; DEFINE/SET! EXPRESSIONS
+		 ;;
+		 [(zodiac:set!-form? ast)
+		  (zodiac:set-set!-form-val! ast (transform! (zodiac:set!-form-val ast)))
+		  ast]
+		 
+		 [(zodiac:define-values-form? ast)
+		  (zodiac:set-define-values-form-val! 
+		   ast 
+		   (transform! (zodiac:define-values-form-val ast)))
+		  ast]
+		 
+		 ;;------------------------------------------------------------------
+		 ;; DEFINE-SYNTAX
+		 ;;
+		 [(zodiac:define-syntaxes-form? ast)
+		  (zodiac:set-define-syntaxes-form-expr! 
+		   ast 
+		   (transform! (zodiac:define-syntaxes-form-expr ast)))
+		  ast]
+		 
+		 ;;-----------------------------------------------------------------
+		 ;; APPLICATIONS
+		 ;;
+		 ;; Now we should be applying closures to arguments.  The actual
+		 ;; extraction of code and environment parts will happen in the 
+		 ;; vm translation
+		 ;;
+		 [(zodiac:app? ast)
+		  (zodiac:set-app-fun! ast (transform! (zodiac:app-fun ast)))
+		  (zodiac:set-app-args! ast (map transform! (zodiac:app-args ast)))
+		  ast]
+		 
+		 ;;-------------------------------------------------------------------
+		 ;; WITH-CONTINUATION-MARK
+		 ;;
+		 ;;
+		 [(zodiac:with-continuation-mark-form? ast)
+		  
+		  (zodiac:set-with-continuation-mark-form-key!
+		   ast
+		   (transform! (zodiac:with-continuation-mark-form-key ast)))
+		  
+		  (zodiac:set-with-continuation-mark-form-val!
+		   ast
+		   (transform! (zodiac:with-continuation-mark-form-val ast)))
+		  
+		  (zodiac:set-with-continuation-mark-form-body!
+		   ast
+		   (transform! (zodiac:with-continuation-mark-form-body ast)))
+		  
+		  ast]
+		 
+		 ;;-----------------------------------------------------------
+		 ;; MODULE
+		 ;;
+		 [(zodiac:module-form? ast)
+		  
+		  (zodiac:set-module-form-body!
+		   ast
+		   (transform! (zodiac:module-form-body ast)))
+		  
+		  ast]
+		 
+		 [else (compiler:internal-error 
+			ast 
+			(format
+			 "closure-expression: form not supported: ~a" ast))]))])
+	  (lambda (ast) (transform! ast)))))))
diff --git a/collects/compiler/private/const.ss b/collects/compiler/private/const.ss
new file mode 100644
index 0000000000..69b0a3aa2d
--- /dev/null
+++ b/collects/compiler/private/const.ss
@@ -0,0 +1,625 @@
+;; constant construction code generator
+;; (c) 1996-7 Sebastian Good
+;; (c) 1997-8 PLT, Rice University
+
+; Handles code-generation for constructing constants.
+
+; Symbols and floating point numbers are handled specially,
+;  in a way that allows the generated C code to be both 
+;  efficient and small. 
+; Other kinds of constants are constrcted by generating code
+;  that is prefixed onto the beginning of the program.
+
+(module const mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "list.ss")
+	   (lib "etc.ss"))
+
+  (require (lib "zodiac-sig.ss" "syntax")
+	   (lib "stx.ss" "syntax"))
+
+  (require "sig.ss")
+  (require "../sig.ss")
+
+  (provide const@)
+  (define const@
+    (unit/sig compiler:const^
+      (import (compiler:option : compiler:option^)
+	      compiler:library^
+	      compiler:cstructs^
+	      (zodiac : zodiac^)
+	      compiler:analyze^
+	      compiler:zlayer^
+	      compiler:vmstructs^
+	      compiler:top-level^
+	      compiler:driver^)
+      
+      (define const:symbol-table (make-hash-table))
+      (define const:symbol-counter 0)
+      (define const:inexact-table (make-hash-table))
+      (define const:inexact-counter 0)
+      (define const:number-table (make-hash-table))
+      (define const:string-table (make-hash-table))
+      (define const:bytes-table (make-hash-table))
+      (define const:string-counter 0)
+
+      (define (const:get-symbol-table) const:symbol-table)
+      (define (const:get-symbol-counter) const:symbol-counter)
+      (define (const:get-inexact-table) const:inexact-table)
+      (define (const:get-inexact-counter) const:inexact-counter)
+      (define (const:get-string-table) const:string-table)
+      (define (const:get-bytes-table) const:bytes-table)
+
+      (define vector-table (make-hash-table))
+
+      (define compiler:static-list null)
+      (define compiler:per-load-static-list null)
+      (define compiler:per-invoke-static-list null)
+
+      (define (compiler:get-static-list) compiler:static-list)
+      (define (compiler:get-per-load-static-list) compiler:per-load-static-list)
+      (define (compiler:get-per-invoke-static-list) compiler:per-invoke-static-list)
+
+      (define new-uninterned-symbols null) ; list of (cons sym pos)
+
+      (define syntax-strings null) ; list of syntax-string structs
+
+      (define (const:init-tables!)
+	(set! const:symbol-table (make-hash-table))
+	(set! const:symbol-counter 0)
+	(set! const:inexact-table (make-hash-table))
+	(set! const:inexact-counter 0)
+	(set! const:number-table (make-hash-table))
+	(set! const:string-table (make-hash-table 'equal))
+	(set! const:bytes-table (make-hash-table 'equal))
+	(set! const:string-counter 0)
+	(set! compiler:static-list null)
+	(set! compiler:per-load-static-list null)
+	(set! compiler:per-invoke-static-list null)
+	(set! vector-table (make-hash-table))
+	(set! new-uninterned-symbols null)
+	(set! syntax-strings null))
+
+      (define (const:intern-string s)
+	(let ([table
+	       (if (string? s) 
+		   const:string-table 
+		   const:bytes-table)])
+	  (hash-table-get 
+	   table
+	   s
+	   (lambda ()
+	     (begin0
+	      const:string-counter
+	      (hash-table-put! table s const:string-counter)
+	      (set! const:string-counter (add1 const:string-counter)))))))
+
+      (define (compiler:add-per-load-static-list! var)
+	(set! compiler:per-load-static-list
+	      (cons var compiler:per-load-static-list)))
+
+      (define (compiler:add-per-invoke-static-list! var mi)
+	(set! compiler:per-invoke-static-list
+	      (cons (cons var mi) compiler:per-invoke-static-list)))
+
+      (define-values (const:the-per-load-statics-table
+		      const:per-load-statics-table?)
+	(let-struct const:per-load-statics-table ()
+		    (values (make-const:per-load-statics-table)
+			    const:per-load-statics-table?)))
+
+      (define (wrap-module-definition def mi)
+	(let ([def (zodiac:make-module-form
+		    (zodiac:zodiac-stx def)
+		    (make-empty-box)
+		    #f #f #f #f
+		    def #f
+		    #f #f #f #f #f)])
+	  (set-annotation! 
+	   def 
+	   (make-module-info mi 
+			     #f
+			     (if (varref:module-invoke-syntax? mi)
+				 'syntax-body
+				 'body)))
+	  def))
+
+      ;; we need to make this in a-normalized, analyzed form from the beginning
+      (define compiler:add-const!
+	(lambda (code attr)
+	  (let* ([var (gensym 'const)]
+		 [sv (zodiac:make-top-level-varref 
+		      (zodiac:zodiac-stx code)
+		      (make-empty-box) 
+		      var
+		      #f
+		      (box '())
+		      #f
+		      #f
+		      #f)]
+		 [def (zodiac:make-define-values-form 
+		       (zodiac:zodiac-stx code)
+		       (make-empty-box) (list sv) code)])
+	    
+	    (set-annotation! sv (varref:empty-attributes))
+	    (varref:add-attribute! sv varref:static)
+	    (varref:add-attribute! sv attr)
+	    (cond
+	     [(eq? attr varref:per-load-static)
+	      (set! compiler:per-load-static-list
+		    (cons var compiler:per-load-static-list)) 
+	      (compiler:add-local-per-load-define-list! def)]
+	     [(varref:module-invoke? attr)
+	      (set! compiler:per-invoke-static-list
+		    (cons (cons var attr) compiler:per-invoke-static-list)) 
+	      (let ([def (wrap-module-definition def attr)])
+		(compiler:add-local-per-invoke-define-list! def))]
+	     [else
+	      (set! compiler:static-list (cons var compiler:static-list))
+	      (compiler:add-local-define-list! def)])
+	    sv)))
+
+      (define compiler:get-special-const!
+	(lambda (ast sym attrib table counter)
+	  (let ([v (hash-table-get table sym (lambda () #f))])
+	    (if v
+		(values v counter)
+		(let ([sv (zodiac:make-top-level-varref 
+			   (and ast (zodiac:zodiac-stx ast))
+			   (make-empty-box) 
+			   (string->symbol (number->string counter))
+			   #f
+			   (box '())
+			   #f
+			   #f
+			   #f)])
+		  
+		  (set-annotation! sv (varref:empty-attributes))
+		  (varref:add-attribute! sv attrib)
+		  (varref:add-attribute! sv varref:static)
+
+		  (hash-table-put! table sym sv)
+		  (values sv (add1 counter)))))))
+
+      (define compiler:get-symbol-const!
+	(lambda (ast sym)
+	  (let-values ([(sv c) (compiler:get-special-const! ast sym varref:symbol
+							    const:symbol-table
+							    const:symbol-counter)])
+	    (when (c . > . const:symbol-counter)
+	      (unless (eq? sym (string->symbol (symbol->string sym)))
+		(set! new-uninterned-symbols (cons
+					      (cons sym const:symbol-counter)
+					      new-uninterned-symbols)))
+	      (set! const:symbol-counter c))
+	    sv)))
+
+      (define (get-new-uninterned-symbols!)
+	(begin0
+	 new-uninterned-symbols
+	 (set! new-uninterned-symbols null)))
+
+      (define-struct syntax-string (str mi uposes ustart id))
+
+      (define (compiler:add-syntax-string! str mi uninterned-positions uninterned-start)
+	(let ([naya (make-syntax-string str mi uninterned-positions uninterned-start
+					(length syntax-strings))])
+	  (set! syntax-strings (cons naya syntax-strings))
+	  naya))
+
+      (define (const:get-syntax-strings)
+	syntax-strings)
+
+      (define compiler:get-inexact-real-const!
+	(lambda (v ast)
+	  (let ([sym (string->symbol (number->string v))])
+	    (let-values ([(sv c) (compiler:get-special-const! ast sym varref:inexact
+							      const:inexact-table
+							      const:inexact-counter)])
+	      (set! const:inexact-counter c)
+	      sv))))
+
+      (define compiler:re-quote 
+	(lambda (ast)
+	  (zodiac:make-quote-form (zodiac:zodiac-stx ast)
+				  (make-empty-box)
+				  ast)))
+
+      ;; [make this in analyzed form...]
+      (define compiler:make-const-constructor
+	(lambda (ast constructor-name args)
+	  (let* ([v (zodiac:make-top-level-varref
+		     ;; FIXME?: wrong syntax
+		     (zodiac:zodiac-stx ast)
+		     (make-empty-box) 
+		     constructor-name
+		     '#%kernel
+		     (box '())
+		     #f
+		     #f
+		     #f)]
+		 [app  (zodiac:make-app 
+			(zodiac:zodiac-stx ast)
+			(make-empty-box)
+			v
+			args)])
+	    (set-annotation! v (varref:empty-attributes))
+	    (varref:add-attribute! v varref:primitive)
+	    (set-annotation! app (make-app #f #t constructor-name))
+	    (block:register-max-arity! (get-s:file-block) (length args))
+	    (compiler:add-global-varref! v)
+	    (compiler:add-primitive-varref! v)
+	    app)))
+
+      (define ht-eol (gensym))
+
+      (define (get-hash-id elem)
+	(cond
+	 [(zodiac:quote-form? elem) (let ([o (zodiac:quote-form-expr elem)])
+				      (if (number? (zodiac:zread-object o))
+					  (zodiac:zread-object o)
+					  o))]
+	 [else elem]))
+
+      (define (find-immutable-vector constructor elems)
+	(let ([ht (hash-table-get vector-table constructor (lambda () #f))])
+	  (and ht
+	       (let loop ([ht ht][l elems])
+		 (if (null? l)
+		     (hash-table-get ht ht-eol (lambda () #f))
+		     (let ([ht (hash-table-get ht (get-hash-id (car l)) (lambda () #f))])
+		       (and ht (loop ht (cdr l)))))))))
+      
+      (define (remember-immutable-vector constructor elems const)
+	(let ([ht (hash-table-get vector-table constructor make-hash-table)])
+	  (hash-table-put! vector-table constructor ht)
+	  (let loop ([ht ht][l elems])
+	    (if (null? l)
+		(hash-table-put! ht ht-eol const)
+		(let* ([hash-id (get-hash-id (car l))]
+		       [htn (hash-table-get ht hash-id make-hash-table)])
+		  (hash-table-put! ht hash-id htn)
+		  (loop htn (cdr l)))))))
+
+      (define (construct-vector-constant ast constructor known-immutable?)
+	(let* ([elems (map (lambda (x)
+			     (compiler:construct-const-code! 
+			      (zodiac:make-zread x)
+			      known-immutable?))
+			   (let ([p (zodiac:zodiac-stx ast)])
+			     (or (syntax->list p)
+				 (and (vector? (syntax-e p))
+				      (vector->list (syntax-e p)))
+				 (and (or (regexp? (syntax-e p))
+					  (byte-regexp? (syntax-e p)))
+				      (list (datum->syntax-object #f (object-name (syntax-e p)))))
+				 (let loop ([p p])
+				   (cond
+				    [(stx-pair? p)
+				     (cons (stx-car p)
+					   (loop (stx-cdr p)))]
+				    [else
+				     (list p)])))))]
+	       [known-immutable? (or known-immutable? (null? elems))])
+	  (or (and known-immutable?
+		   (find-immutable-vector constructor elems))
+	      (let ([const (compiler:add-const! 
+			    (compiler:make-const-constructor 
+			     ast
+			     constructor
+			     elems)
+			    (if known-immutable?
+				varref:static
+				varref:per-load-static))])
+		(when known-immutable?
+		  (remember-immutable-vector constructor elems const))
+		const))))
+
+      (define (big-and-simple/cyclic? datum size ht)
+	(cond
+	 [(null? datum) (negative? size)]
+	 [(hash-table-get ht datum (lambda () #f)) 'cyclic]
+	 [(pair? datum)
+	  (hash-table-put! ht datum #t)
+	  (let ([v (big-and-simple/cyclic? (car datum) 0 ht)])
+	    (if (eq? v 'cyclic)
+		'cyclic
+		(let ([v2 (big-and-simple/cyclic? (cdr datum) (sub1 size) ht)])
+		  (if (eq? v2 'cyclic)
+		      'cyclic
+		      (and v v2)))))]
+	 [(vector? datum)
+	  (let ([len (vector-length datum)])
+	    (and (hash-table-put! ht datum #t)
+		 (let loop ([i 0][so-far? #f])
+		   (if (= i len)
+		       so-far?
+		       (let ([v (big-and-simple/cyclic? (vector-ref datum i) (- size i) ht)])
+			 (if (eq? v 'cyclic)
+			     'cyclic
+			     (loop (add1 i) (or so-far? v))))))))]
+	 [(hash-table? datum) 'cyclic] ;; assume content is ok and cyclic
+	 [(and (negative? size)
+	       (or (number? datum)
+		   (string? datum)
+		   (bytes? datum)
+		   (symbol? datum)
+		   (boolean? datum)
+		   (regexp? datum)
+		   (byte-regexp? datum)))
+	  #t]
+	 [else #f]))
+	 
+      (define-struct compiled-string (id len))
+
+      (define (construct-big-constant ast stx known-immutable?)
+	(let* ([s (let ([p (open-output-bytes)])
+		    (write (compile `(quote ,stx)) p)
+		    (get-output-bytes p))]
+	       [id (const:intern-string s)])
+	  (let ([const (compiler:add-const!
+			(compiler:re-quote
+			 (zodiac:make-zread
+			  (datum->syntax-object
+			   #f
+			   ;; HACK!
+			   (make-compiled-string id (bytes-length s)))))
+			(if known-immutable?
+			    varref:static
+			    varref:per-load-static))])
+	    const)))
+
+      (define compiler:construct-const-code!
+	(lambda (ast known-immutable?)
+	  (cond
+	   ;; base case - constant does not have to be built
+	   [(vm:literal-constant? ast) (compiler:re-quote ast)]
+
+	   ;; c-lambda (kindof a hack)
+	   [(c-lambda? ast)
+	    (compiler:add-const! (compiler:re-quote 
+				  (zodiac:make-zread
+				   (datum->syntax-object
+				    #f
+				    ast ;; See vm2c.ss
+				    #f)))
+				 varref:static)]
+	   
+	   ;; a box has a constant inside it to mess with, yet it's
+	   ;; still a scalar
+	   [(box? (zodiac:zread-object ast))
+	    (compiler:add-const! (compiler:make-const-constructor
+				  ast
+				  'box
+				  (list (compiler:construct-const-code!
+					 (zodiac:make-zread (unbox (zodiac:zread-object ast)))
+					 known-immutable?)))
+				 (if known-immutable?
+				     varref:static
+				     varref:per-load-static))]
+
+	   ;; Do symbols at most once:
+	   [(symbol? (zodiac:zread-object ast))
+	    (let ([sym (zodiac:zread-object ast)])
+	      (compiler:get-symbol-const! ast sym))]
+	   
+	   ;; Numbers that must be built
+	   [(number? (zodiac:zread-object ast))
+	    (let ([n (zodiac:zread-object ast)])
+	      (if (and (inexact? n) (eqv? 0 (imag-part n))
+		       (not (member n '(+inf.0 -inf.0 +nan.0 -0.0))))
+		  (compiler:get-inexact-real-const! n ast)
+		  (let ([sym (string->symbol (number->string n))])
+		    (hash-table-get const:number-table
+				    sym
+				    (lambda ()
+				      (let ([num (compiler:add-const! 
+						  (compiler:re-quote ast) 
+						  varref:static)])
+					(hash-table-put! const:number-table sym num)
+					num))))))]
+
+	   ;; big/cyclic constants
+	   [(big-and-simple/cyclic? (syntax-object->datum (zodiac:zodiac-stx ast)) 20 (make-hash-table))
+	    (construct-big-constant ast (zodiac:zodiac-stx ast) known-immutable?)]
+	   
+	   ;; lists
+	   [(stx-list? (zodiac:zodiac-stx ast))
+	    (construct-vector-constant ast 'list known-immutable?)]
+	   
+	   ;; improper lists
+	   [(pair? (zodiac:zread-object ast))
+	    (construct-vector-constant ast 'list* known-immutable?)]
+
+	   [(void? (zodiac:zread-object ast))
+	    (zodiac:make-special-constant 'void)]
+
+	   ;; vectors
+	   [(vector? (zodiac:zread-object ast))
+	    (construct-vector-constant ast 'vector known-immutable?)]
+	   
+	   ;; regexp
+	   [(regexp? (zodiac:zread-object ast))
+	    (construct-vector-constant ast 'regexp #t)]
+	   [(byte-regexp? (zodiac:zread-object ast))
+	    (construct-vector-constant ast 'byte-regexp #t)]
+	   
+	   ;; comes from module paths in analyze:
+	   [(module-path-index? (zodiac:zread-object ast))
+	    (let-values ([(path base) (module-path-index-split (zodiac:zread-object ast))])
+	      (if (or path base)
+		  (let ([wrap (lambda (v)
+				(zodiac:make-zread 
+				 (datum->syntax-object
+				  #f
+				  v
+				  (zodiac:zodiac-stx ast))))])
+		    (compiler:add-const! (compiler:make-const-constructor
+					  ast
+					  'module-path-index-join
+					  (list (compiler:construct-const-code!
+						 (wrap path)
+						 known-immutable?)
+						(compiler:construct-const-code!
+						 (wrap base)
+						 known-immutable?)))
+					 (or (varref:current-invoke-module)
+					     (if known-immutable?
+						 varref:static
+						 varref:per-load-static))))
+		  (zodiac:make-special-constant 'self_modidx)))]
+
+	   ;; other atomic constants that must be built
+	   [else
+	    (when (or (string? (zodiac:zread-object ast))
+		      (bytes? (zodiac:zread-object ast)))
+	      (const:intern-string (zodiac:zread-object ast)))
+	    (compiler:add-const! (compiler:re-quote ast) 
+				 varref:static)])))
+
+      (define syntax-constants null)
+
+      (define (const:reset-syntax-constants!)
+	(set! syntax-constants null))
+
+      (define (const:make-syntax-constant stx)
+	;; Marhsall to a string constant, and read back out at run-time.
+	;;  For sharing of syntax info, put all syntax objects for a given
+	;;  top-level expression into one marshal step.
+	(let* ([var (gensym 'conststx)]
+	       [sv (zodiac:make-top-level-varref 
+		    stx
+		    (make-empty-box) 
+		    var
+		    #f
+		    (box '())
+		    #f
+		    #f
+		    #f)])
+	  (set! syntax-constants (cons (cons sv stx)
+				       syntax-constants))
+	  (set-annotation! sv (varref:empty-attributes))
+	  (varref:add-attribute! sv varref:static)
+	  (varref:add-attribute! sv (or (varref:current-invoke-module)
+					varref:per-load-static))
+	  (if (varref:current-invoke-module)
+	      (set! compiler:per-invoke-static-list
+		    (cons (cons var (varref:current-invoke-module))
+			  compiler:per-invoke-static-list))
+	      (set! compiler:per-load-static-list
+		    (cons var compiler:per-load-static-list)))
+	  sv))
+
+      ;; We collect syntax objects together to share the cost of of
+      ;; the rename tables. More gnerally, to get the expansion-time
+      ;; info to use-time, we use the bytecode writer built into
+      ;; MzScheme, putting multiple syntax objects together into a
+      ;; syntax vector. The scheme_eval_compiled_stx_string() will
+      ;; unpack it, and perform any necessary phase shifts. To perform
+      ;; the module mapping associated with the phase shift,
+      ;; scheme_eval_compiled_stx_string() expects the "syntax" vector
+      ;; to have a module index path (the "self" path) as its last
+      ;; element.
+      ;; Returns a max-arity.
+      (define (const:finish-syntax-constants!)
+	(if (null? syntax-constants)
+	    0
+	    (let* ([s (open-output-bytes)]
+		   [uninterned-symbol-info (get-new-uninterned-symbols!)]
+		   [c (compile `(quote-syntax ,(list->vector 
+						(let ([l (map cdr syntax-constants)]
+						      [mi (varref:current-invoke-module)])
+						  (append 
+						   l 
+						   (map car uninterned-symbol-info) ; car gets the syms
+						   (if mi
+						       (list (varref:module-invoke-context-path-index mi))
+						       null))))))])
+	      (display c s)
+	      (let ([syntax-string (get-output-bytes s)])
+		(let* ([strvar (compiler:add-syntax-string! 
+				syntax-string
+				(varref:current-invoke-module)
+				(map cdr uninterned-symbol-info) ; cdr gets positions
+				(length syntax-constants))] ; starting place for symbols
+		       [vecvar (gensym 'conststxvec)]
+		       [sv (zodiac:make-top-level-varref
+			    #f
+			    (make-empty-box) 
+			    vecvar
+			    #f
+			    (box '())
+			    #f
+			    #f
+			    #f)])
+
+		  (set-annotation! sv (varref:empty-attributes))
+		  (varref:add-attribute! sv varref:static)
+		  (varref:add-attribute! sv (or (varref:current-invoke-module)
+						varref:per-load-static))
+		  (if (varref:current-invoke-module)
+		      (set! compiler:per-invoke-static-list
+			    (cons (cons vecvar (varref:current-invoke-module))
+				  compiler:per-invoke-static-list))
+		      (set! compiler:per-load-static-list
+			    (cons vecvar compiler:per-load-static-list)))
+
+		  ((if (varref:current-invoke-module)
+		       compiler:add-local-per-invoke-define-list!
+		       compiler:add-local-per-load-define-list!)
+		   (let ([def
+			  (zodiac:make-define-values-form 
+			   #f
+			   (make-empty-box) (list sv)
+			   (compiler:re-quote 
+			    (zodiac:make-zread
+			     (datum->syntax-object
+			      #f
+			      strvar ;; <------ HACK! See "HACK!" in vm2c.ss
+			      #f))))])
+		     (if (varref:current-invoke-module)
+			 (wrap-module-definition def (varref:current-invoke-module))
+			 def)))
+
+		  ;; Create construction code for each
+		  ;;  syntax variable:
+		  (let loop ([l syntax-constants]
+			     [pos 0])
+		    (unless (null? l)
+		      (let ([app (zodiac:make-app
+				  (cdar l)
+				  (make-empty-box) 
+				  (zodiac:make-top-level-varref
+				   (cdar l)
+				   (make-empty-box) 
+				   'vector-ref
+				   '#%kernel
+				   (box '())
+				   #f
+				   #f
+				   #f)
+				  (list
+				   sv
+				   (compiler:re-quote
+				    (zodiac:make-zread
+				     (datum->syntax-object
+				      #f
+				      pos
+				      (cdar l))))))])
+			(set-annotation! app (make-app #f #t 'vector-ref))
+			((if (varref:current-invoke-module)
+			     compiler:add-local-per-invoke-define-list!
+			     compiler:add-local-per-load-define-list!)
+			 (let ([def
+				(zodiac:make-define-values-form 
+				 (cdar l)
+				 (make-empty-box) (list (caar l))
+				 app)])
+			   (if (varref:current-invoke-module)
+			       (wrap-module-definition def (varref:current-invoke-module))
+			       def)))
+			(loop (cdr l) (add1 pos)))))))
+	      (set! syntax-constants null)
+	      ;; We make an application with 2 arguments
+	      2))))))
+
diff --git a/collects/compiler/private/cstructs.ss b/collects/compiler/private/cstructs.ss
new file mode 100644
index 0000000000..3560328893
--- /dev/null
+++ b/collects/compiler/private/cstructs.ss
@@ -0,0 +1,264 @@
+;; Compiler structures
+;; (c) 1996-1997 Sebastian Good
+;; (c) 1997-2001 PLT
+
+;; Mostly structure definitions, mostly for annotations.
+
+(module cstructs mzscheme
+  (require (lib "unitsig.ss")
+	  (lib "list.ss")
+	  (lib "etc.ss"))
+
+  (require (lib "zodiac-sig.ss" "syntax"))
+
+  (require "sig.ss")
+  (require "../sig.ss")
+
+  (provide cstructs@)
+  (define cstructs@
+    (unit/sig compiler:cstructs^
+      (import compiler:library^
+	      (zodiac : zodiac^)
+	      compiler:zlayer^)
+
+      ;;----------------------------------------------------------------------------
+      ;; VARREF ATTRIBUTES
+      ;;  Used as the annotation for zodiac:varref objects
+
+      (define-struct va (flags invoke-module))
+
+      (define (varref:empty-attributes) (make-va 0 #f))
+      (define (varref:add-attribute! ast attr)
+	(let ([va (get-annotation ast)])
+	  (let ([attr (if (varref:module-invoke? attr)
+			  (begin
+			    (set-va-invoke-module! va attr)
+			    varref:per-invoke-static)
+			  attr)])
+	    (set-va-flags! va (bitwise-ior attr (va-flags va))))))
+      (define (varref:has-attribute? ast attr)
+	(let ([anno (get-annotation ast)])
+	  (and (va? anno) (positive? (bitwise-and (va-flags anno) attr)))))
+      (define (varref:invoke-module ast)
+	(let ([anno (get-annotation ast)])
+	  (and (va? anno) (va-invoke-module anno))))
+
+      (define varref:static 1)
+      (define varref:per-load-static 2)
+      (define varref:per-invoke-static 4)
+      (define varref:primitive 8)
+      (define varref:symbol 16)
+      (define varref:inexact 32)
+      (define varref:env 64)
+      (define varref:in-module 128)
+      (define varref:module-stx-string 256)
+
+      (define mi-counter -1)
+      (define-struct varref:module-invoke (id syntax? context-path-index))
+      (define (make-module-invokes self-path-index)
+	(set! mi-counter (add1 mi-counter))
+	(values (make-varref:module-invoke mi-counter #f self-path-index)
+		(make-varref:module-invoke mi-counter #t self-path-index)))
+
+      (define (get-num-module-invokes)
+	(add1 mi-counter))
+
+      (define (is-module-invoke? mi num)
+	(and (varref:module-invoke? mi)
+	     (= num (varref:module-invoke-id mi))))
+
+      (define (varref:reset-module-id!) (set! mi-counter -1))
+      
+      ;;----------------------------------------------------------------------------
+      ;; AST NODES
+      ;;  New AST nodes to augment the zodiac set:
+      
+      ;; AST node for the creation of a closure (replaces, e.g., a lambda expression)
+      (define-struct (compiler:make-closure zodiac:zodiac) (lambda free-vars args name))
+
+      ;;----------------------------------------------------------------------------
+      ;; ANNOTATION STRUCTURES
+      ;;
+
+      ;; mzc annotation for a zodiac:binding, installed in the `known'
+      ;; analysis phase
+      (define-struct binding (rec?       ; part of a letrec recursive binding set
+			      mutable?   ; set!ed? (but not for unit or letrec definitions)
+			      unit-i/e?  ; is imported/exported (including uses by invoke)
+			      anchor     ; zodiac:binding - anchor binding for this binding
+			      letrec-set?; set! to implement a letrec
+			      ivar?      ; is a class ivar?
+			      known?     ; known to have a fixed value? (i.e., it's not
+			      ;; mutated or detectably #<undefined> for a while?)
+			      val
+			      ;; ``known'' value as an abitrary AST (so it's
+			      ;; really only *known* if this is a constant
+			      known-but-used? 
+			      ;; known value used in an improper way?
+			      ;; if so, always preserve the variable (i.e., don't
+			      ;; propagate it away entirely)
+			      rep        ; reprsentation (#f until rep-choosing phase)
+			      ))
+
+      ;; copy a binding record
+      (define (copy-binding b)
+	(make-binding (binding-rec? b)
+		      (binding-mutable? b)
+		      (binding-unit-i/e? b)
+		      (binding-anchor b)
+		      (binding-letrec-set? b)
+		      (binding-ivar? b)
+		      (binding-known? b)
+		      (binding-val b)
+		      (binding-known-but-used? b)
+		      (binding-rep b)))
+
+      (define (copy-binding-for-light-closures b)
+	(make-binding #f
+		      #f
+		      #f
+		      #f
+		      #f 
+		      #f
+		      (binding-known? b) (binding-val b)
+		      #f
+		      #f))
+
+      (define binder:empty-anno
+	(make-binding #f
+		      #f
+		      #f
+		      #f
+		      #f
+		      #f
+		      #f
+		      #f
+		      #f
+		      #f))
+
+      (define-struct code (; The following fields, XXX-vars, are
+			   ;; all sets of zodiac:bindings
+			   free-vars
+			   ;; lexical variables that are free in the 
+			   ;; code (i.e., kept in a closure)
+			   local-vars 
+			   ;; variables introduced during the evaluation
+			   ;; of the code; includes, for example, the argument
+			   ;; variables if this is a lambda closure
+			   global-vars 
+			   ;; ``global'' variables used by this code;
+			   ;; we capture globals that are specific to
+			   ;; the namespace at load-time
+			   used-vars
+			   ;; local variables that are eventually used in
+			   ;; an expression after they are introduced in the
+			   ;; code
+			   captured-vars 
+			   ;; free and used variables that are free within
+			   ;; a closure that is created by this code
+
+			   parent
+			   ;; #f if this is a top-level expression, container
+			   ;; code otherwise
+			   case-parent
+			   ;; #f, unless it's a code in a case-lambda, then
+			   ;; it's the case-code containing this code
+
+			   children
+			   ;; list of children code structures
+			   ))
+
+      ;; Structure for the annotation given to closures, such
+      ;;  as lambdas or units. The actual annotation will be
+      ;;  an instance of a sub-type of `code', depending on
+      ;;  the kind of closure.
+      (define-struct (closure-code code)
+	(; Representation and implementation info
+	 rep 
+	 alloc-rep
+	 label   ; integer - id within vehicle
+	 vehicle ; integer - vehicle id
+	 
+	 max-arity
+	 ;; max number of args in applications
+	 ;; within the closure (which is unrelated
+	 ;; to the number of arguments used to invoke
+	 ;; this closure, if it happens to be a
+	 ;; lambda)
+	 
+	 return-multi 
+	 ;; #f (always single), #t (never single), 
+	 ;; or 'possible
+	 
+	 name
+	 ;; inferred name - can be #f, a varref, a binding,
+	 ;;                 or a list of inferred names.
+	 ;;   (see also vm->c:extract-inferred-name)
+	 ))
+
+      ;; Annotation type for case-lambda closures:
+      (define-struct (procedure-code closure-code) 
+	(case-codes 
+	 ;; A list of case-code records
+	 case-arities
+	 ;; An integer indicating which
+	 ;; arity record in compiler:case-lambdas
+	 ;; contains MzScheme information for
+	 ;; the arity of the case-lambda. For
+	 ;; single-case lambdas, this is #f
+	 ;; because the arity information is
+	 ;; inlined.
+	 liftable
+	 ;; top-level-varref => procedure is lifted
+	 method?
+	 ;; #t => arity errors hide first argument
+	 ;;  (triggered by 'method-arity-error property)
+	 ))
+
+      (define-struct (case-code code)
+	(; Does the compilation of this case use continue?
+	 ;; If so, output the case body within while(1){...}
+	 has-continue?))
+
+      ;; annotations given to zodiac:app AST nodes
+      (define-struct app (tail?
+			  ;; tail application?
+			  prim?
+			  ;; application of a known primitive?
+			  prim-name
+			  ;; MzScheme name for the known primitive, or #f
+			  ))
+
+      (define-struct module-info (invoke
+				  ;; a module-invoke record
+				  syntax-invoke
+				  ;; another module-invoke record
+				  part
+				  ;; 'body, 'syntax-body, or 'constructor
+				  ))
+
+      (define varref:current-invoke-module (make-parameter #f))
+
+      ;;----------------------------------------------------------------------------
+      ;; ACCESSOR
+      ;;
+
+      ;; Retrives the *annotation* of a zodiac:binding for a zodiac:bound-varref.
+      ;; (Compare to zodiac:bound-varref-binding, which returns the
+      ;; zodiac:binding itself, rather than its annotation.)
+      (define compiler:bound-varref->binding 
+	(compose get-annotation zodiac:bound-varref-binding))
+
+      ;;----------------------------------------------------------------------------
+      ;; special constants
+      ;;
+      (define-struct c-lambda (function-name scheme-name body arity))
+      
+      ;;----------------------------------------------------------------------------
+      ;; error/warning structures
+      ;;
+      (define-struct compiler:message (ast message))
+      (define-struct (compiler:error-msg compiler:message) ())
+      (define-struct (compiler:fatal-error-msg compiler:message) ())
+      (define-struct (compiler:internal-error-msg compiler:message) ())
+      (define-struct (compiler:warning-msg compiler:message) ()))))
diff --git a/collects/compiler/private/driver.ss b/collects/compiler/private/driver.ss
new file mode 100644
index 0000000000..3f438a2370
--- /dev/null
+++ b/collects/compiler/private/driver.ss
@@ -0,0 +1,1413 @@
+;; Compiler driver routines 
+;; (c) 1996-1997 Sebastian Good
+;; (c) 1997-2001 PLT
+;;
+;; Scheme->C compilation Overview
+;; ------------------------------
+;;
+;; Compilation is performed in a number of phases,
+;;  each of which is implemented in its own unit:
+;;
+;;   1) Reading/parsing - Zodiac collection
+;;   2) Prephase - prephase.ss
+;;   3) A-normalization - anorm.ss
+;;   4) Known-value analysis - known.ss
+;;   5) Lexical analysis and inlining - analyze.ss
+;;   6) Static procedure lifting - lift.ss
+;;   7) Static procedure lifting after LWCC - lift.ss (optional)
+;;   8) Closure conversion - closure.ss
+;;   9) Closure vehicle assignment - vehicle.ss
+;;  10) Representation choosing - rep.ss
+;;  11) Scheme to virtual machine translation - vmphase.ss
+;;  12) Optimizations on VM code - vmopt.ss
+;;  13) VM to C translation - vm2c.ss
+;;
+;; For more information about a phase, see the file
+;;  implementing that phase.
+;;
+;; All steps up to vmphase.ss work on a Scheme program, representated
+;;  as a zodiac AST. The AST produced by zodiac is destructively
+;;  modified by each phase (usually); mzc-specific information is
+;;  stored in the AST as ``annotations''. At the implementation file
+;;  for each phase, the annotations installed or changed by the phase
+;;  are listed.
+;;
+;; All nodes in the AST must be unique, except for nodes representing
+;;  constant values. Don't even reuse varref or binding nodes within
+;;  an AST.
+;;
+;; C code is compiled and linked via procedures provided by the
+;;  dynext collection.
+;;
+;; In this implementation, `var' is used for variable names in
+;;  confusing and inconsistent ways. There are two different
+;;  AST entities that could be called "var":
+;;     1) binding instances of variables, e.g., the formal
+;;        arguments of a lambda; these are always called
+;;        `bindings' in Zodiac terminology
+;;     2) bound instances of variables, e.g., a free variable 
+;;        in a sub-expression; these are always called
+;;        `varrefs' in Zodiac terminology.
+;;  Almost all information about a variable is stored with a
+;;   zodiac:binding AST node, and very little information is
+;;   stored with a zodiac:varref AST node.
+;;  To make matters worse, the name `binding' is overloaded.
+;;    `zodiac:binding' is the name of a Zodiac structure
+;;    type, and `binding' is also the name of the structure
+;;    type for annotations attached to zodiac:binding objects.
+;;  If you create a new lexical binding, note that the procedure
+;;    zodiac:binding->lexical-varref will create varrefs to 
+;;    the binding.
+
+(module driver mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "list.ss")
+	   (lib "file.ss")
+	   (lib "etc.ss")
+	   (lib "pretty.ss")
+	   (prefix src2src: "../src2src.ss"))
+  
+  (require (lib "zodiac-sig.ss" "syntax")
+	   (lib "toplevel.ss" "syntax")
+	   (lib "compile-sig.ss" "dynext")
+	   (lib "link-sig.ss" "dynext")
+	   (lib "file-sig.ss" "dynext"))
+
+  (require "../sig.ss")
+  (require "sig.ss")
+
+  (provide driver@)
+
+  (define driver@
+    (unit/sig compiler:driver^
+      (import (compiler:option : compiler:option^)
+	      compiler:library^
+	      compiler:cstructs^
+	      (zodiac : zodiac^)
+	      compiler:zlayer^
+	      compiler:prephase^
+	      compiler:anorm^
+	      compiler:known^
+	      compiler:analyze^
+	      compiler:const^
+	      compiler:lift^
+	      compiler:closure^
+	      compiler:vehicle^
+	      compiler:rep^
+	      compiler:vmstructs^
+	      compiler:vmphase^
+	      compiler:vmopt^
+	      compiler:vm2c^
+	      compiler:top-level^
+	      dynext:compile^
+	      dynext:link^
+	      dynext:file^)
+      (rename (compile-extension* compile-extension))
+      
+      (define debug:file "dump.txt")
+      (define debug:port #f)
+      (define (debug:get-port) debug:port)
+      (define debug
+	(lambda x
+	  (when (and (compiler:option:debug) debug:port)
+	    (apply fprintf (cons debug:port x))
+	    (flush-output debug:port))))
+  
+      ;;----------------------------------------------------------------------------
+      ;; FILE PROCESSING FUNCTIONS
+      ;;
+      
+      ;; takes an input-name from the compile command and returns 4 values
+      ;; 1) an input path
+      ;; 2) a C output path
+      ;; 3) a constant pool output path
+      ;; 4) an obj output path
+      ;; 5) a dll output path
+      ;; 6) a scheme_setup suffix
+      (define s:process-filenames
+	(lambda (input-name dest-dir from-c? tmp-c? tmp-o?)
+	  (let-values ([(basedir file dir?) (split-path input-name)])
+	    (let* ([dest-dir (if (eq? dest-dir 'auto)
+				 (let ([d (build-path (if (eq? basedir 'relative)
+							  'same
+							  basedir)
+						      "compiled"
+						      "native"
+						      (system-library-subpath))])
+				   (unless (directory-exists? d)
+				     (make-directory* d))
+				   d)
+				 dest-dir)]
+		   [path-prefix (lambda (a b)
+				  (bytes->path (bytes-append a (path->bytes b))))]
+		   [sbase (extract-base-filename/ss file (if from-c? #f 'mzc))]
+		   [cbase (extract-base-filename/c file (if from-c? 'mzc #f))]
+		   [base (or sbase cbase)]
+		   [c-dir (if tmp-c?
+			      (find-system-path 'temp-dir)
+			      dest-dir)]
+		   [c-prefix (if tmp-c?
+				 (lambda (s) (path-prefix #"mzcTMP" s))
+				 values)]
+		   [o-dir (if tmp-o?
+			      (find-system-path 'temp-dir)
+			      dest-dir)]
+		   [o-prefix (if tmp-o?
+				 (lambda (s) (path-prefix #"mzcTMP" s))
+				 values)])
+	      (unless base
+		(error 'mzc "not a Scheme or C file: ~a" input-name))
+	      (values (if sbase 
+			  input-name
+			  #f)
+		      (if cbase 
+			  input-name 
+			  (build-path c-dir (c-prefix (append-c-suffix base))))
+		      (build-path o-dir (o-prefix (append-constant-pool-suffix base)))
+		      (build-path o-dir (o-prefix (append-object-suffix base)))
+		      (build-path dest-dir (append-extension-suffix base))
+		      (string-append (compiler:clean-string (compiler:option:setup-prefix)) 
+				     "_" 
+				     (compiler:clean-string (path->string base))))))))
+      
+      (define elaboration-exn-handler
+	(lambda (exn)
+	  (compiler:fatal-error 
+	   #f
+	   (format "Error during elaboration: ~a" 
+		   (if (exn? exn)
+		       (exn-message exn)
+		       exn)))
+	  (raise exn)))
+      
+      (define prefix-exn-handler
+	(lambda (exn)
+	  (compiler:fatal-error 
+	   #f
+	   (format "Error during prefix loading: ~a" 
+		   (if (exn? exn)
+		       (exn-message exn)
+		       exn)))
+	  (raise exn)))
+      
+      (define top-level-exn-handler
+	(lambda (exn)
+	  (set! compiler:messages (reverse! compiler:messages))
+	  (compiler:report-messages! #t)
+	  (exit 1)))
+  
+      (define s:expand-top-level-expressions!
+	(lambda (input-directory reader verbose?)
+	  (when verbose? (printf "~n Reading... ") (flush-output))
+	  ;; During reads, errors are truly fatal
+	  (let ([exprs (let ([failed? #f])
+			 (let loop ([n 1])
+			   (let ([sexp (reader)])
+			     (if (eof-object? sexp)
+				 null
+				 (begin 
+				   (when (compiler:option:debug)
+				     (debug "~a[~a.~a]_"
+					    n
+					    (zodiac:location-line
+					     (zodiac:zodiac-start sexp))
+					    (zodiac:location-column
+					     (zodiac:zodiac-start sexp))))
+				   (cons sexp (loop (+ n 1))))))))])
+	    (unless (null? compiler:messages) (when (compiler:option:verbose) (newline)))
+	    (compiler:report-messages! #t)
+	    (when verbose? (printf " expanding...~n"))
+	    (parameterize ([current-load-relative-directory input-directory])
+	      (map (lambda (expr)
+		     (let ([expanded ((if has-prefix?
+					  expand-top-level-with-compile-time-evals
+					  expand) 
+				      expr)])
+		       (zodiac:syntax->zodiac 
+			(let ([p (src2src:optimize expanded #t)])
+			  '(with-output-to-file "/tmp/l.ss"
+			     (lambda () (pretty-print (syntax-object->datum p)))
+			     'replace)
+			  (let ([opt-expanded (expand p)])
+			    ;; (pretty-print (syntax-object->datum opt-expanded))
+			    opt-expanded)))))
+		   exprs)))))
+
+      (define elaborate-namespace (make-namespace))
+	   
+      (define has-prefix? #f)
+
+      (define (eval-compile-prefix prefix)
+	(set! has-prefix? (and prefix #t))
+	(with-handlers ([void top-level-exn-handler])
+	  (with-handlers ([void prefix-exn-handler])
+	    (parameterize ([current-namespace elaborate-namespace])
+	      (eval (or prefix
+			;; Need MzScheme and cffi:
+			'(begin
+			   (require (lib "cffi.ss" "compiler"))
+			   (require-for-syntax mzscheme))))))))
+
+      ;;----------------------------------------------------------------------
+      ;; Misc utils
+
+      ;; see (single) use for info:
+      (define (split-module m)
+	(let ([info (get-annotation m)])
+	  (let ([mk
+		 (lambda (expr mode)
+		   (let ([ast (zodiac:make-module-form
+			       (zodiac:zodiac-stx expr)
+			       (make-empty-box)
+			       (zodiac:module-form-name m)
+			       (zodiac:module-form-requires m)
+			       (zodiac:module-form-for-syntax-requires m)
+			       (zodiac:module-form-for-template-requires m)
+			       expr #f
+			       (zodiac:module-form-provides m)
+			       (zodiac:module-form-syntax-provides m)
+			       (zodiac:module-form-indirect-provides m)
+			       (zodiac:module-form-kernel-reprovide-hint m)
+			       (zodiac:module-form-self-path-index m))])
+		     (set-annotation! 
+		      ast 
+		      (make-module-info ((if (eq? mode 'syntax-body)
+					     module-info-syntax-invoke
+					     module-info-invoke)
+					 info)
+					#f 
+					mode))
+		     ast))]
+		[body->list
+		 (lambda (expr)
+		   (if (zodiac:begin-form? expr)
+		       (zodiac:begin-form-bodies expr)
+		       (list expr)))])
+	    (append
+	     (map (lambda (x) (mk x 'body))
+		  (body->list
+		   (zodiac:module-form-body m)))
+	     (map (lambda (x) (mk x 'syntax-body))
+		  (body->list
+		   (zodiac:module-form-syntax-body m)))
+	     (list (mk 
+		    ;; Construct constant expression for module construction info:
+		    (let ([q (zodiac:make-quote-form
+			      (zodiac:zodiac-stx m)
+			      (make-empty-box)
+			      (zodiac:make-zread
+			       (datum->syntax-object
+				#f
+				(list (zodiac:module-form-name m)
+				      (zodiac:module-form-requires m)
+				      (zodiac:module-form-for-syntax-requires m)
+				      (zodiac:module-form-for-template-requires m)
+				      (filter (if (zodiac:module-form-kernel-reprovide-hint m)
+						  (lambda (x) (or (symbol? x)
+								  (not (eq? '#%kernel (car x)))))
+						  (lambda (x) #t))
+					      (zodiac:module-form-provides m))
+				      (zodiac:module-form-syntax-provides m)
+				      (zodiac:module-form-indirect-provides m)
+				      (zodiac:module-form-kernel-reprovide-hint m))
+				(zodiac:zodiac-stx m))))])
+		      (set-annotation! q 'immutable)
+		      q)
+		    'constructor))))))
+
+      ;; takes a list of a-normalized expressions and analyzes them
+      ;; returns the analyzed code, a list of local variable lists, 
+      ;; used variable lists, and captured variable lists
+      (define s:analyze-source-list
+	(lambda (source)
+	  (let loop ([sexps source] [source-acc null] 
+				    [locals-acc null] [globals-acc null] [used-acc null] [captured-acc null]
+				    [children-acc null]
+				    [max-arity 0])
+	    (if (null? sexps)
+		(values (reverse! source-acc)
+			(map (lambda (loc glob used cap children)
+			       (let ([c (make-code empty-set
+						   loc
+						   glob
+						   used
+						   cap
+						   #f
+						   #f
+						   children)])
+				 (for-each (lambda (child) (set-code-parent! child c)) children)
+				 c))
+			     (reverse! locals-acc)
+			     (reverse! globals-acc)
+			     (reverse! used-acc)
+			     (reverse! captured-acc)
+			     (reverse! children-acc))
+			max-arity)
+		(begin
+		  (varref:current-invoke-module 
+		   (and (zodiac:module-form? (car sexps))
+			(let ([info (get-annotation (car sexps))])
+			  (and (not (eq? (module-info-part info) 'constructor))
+			       (module-info-invoke info)))))
+
+		  ;; (printf "~a~n" (syntax-line (zodiac:zodiac-stx (car sexps))))
+
+		  (let-values ([(exp free-vars local-vars global-vars used-vars captured-vars
+				     children new-max-arity multi)
+				(analyze-expression! (car sexps) empty-set null (null? (cdr sexps)))])
+
+		    
+		    (let ([sc-max-arity
+			   ;; Adds to const, per-load-const, per-invoke-const lists:
+			   (if (or (null? (cdr sexps))
+				   (not (zodiac:module-form? (car sexps)))
+				   (not (zodiac:module-form? (cadr sexps)))
+				   (let ([a1 (get-annotation (car sexps))]
+					 [a2 (get-annotation (cadr sexps))])
+				     (not (and (eq? (module-info-part a1)
+						    (module-info-part a2))
+					       (eq? (module-info-invoke a1)
+						    (module-info-invoke a2))))))
+			       (compiler:finish-syntax-constants!)
+			       0)])
+
+		      (varref:current-invoke-module #f)
+		      
+		      (loop (cdr sexps) 
+			    (cons exp source-acc) 
+			    (cons local-vars locals-acc)
+			    (cons global-vars globals-acc)
+			    (cons used-vars used-acc)
+			    (cons captured-vars captured-acc)
+			    (cons children children-acc)
+			    (max max-arity new-max-arity sc-max-arity)))))))))
+
+      ;; Lift static procedures
+      (define s:lift
+	(lambda ()
+	  (compiler:init-lifted-lambda-list!)
+	  (compiler:init-once-closure-lists!)
+
+	  (let ([l (map lift-lambdas! (block-source s:file-block) (block-codes s:file-block))]
+		[reset-globals (lambda (code globals)
+				 (set-code-global-vars! code globals)
+				 code)])
+	    
+	    ;; Splice lifted lambda definitions into the program in the right
+	    ;; place: statics after true constants, and per-load statics after
+	    ;; per-load constants.
+	    (let loop ([n number-of-true-constants]
+		       [l l][c (block-codes s:file-block)]
+		       [l-acc null][c-acc null])
+	      (if (zero? n)
+		  (let loop ([n number-of-per-load-constants]
+			     [l l][c c]
+			     [pll-acc null][plc-acc null])
+		    (if (zero? n)
+			(begin
+			  (set-block-source! 
+			   s:file-block
+			   (append (reverse l-acc)
+				   (compiler:get-lifted-lambdas)
+				   (reverse pll-acc)
+				   (compiler:get-once-closures-list)
+				   (map car l)))
+			  (set-block-codes!
+			   s:file-block 
+			   (append (reverse c-acc) 
+				   (map
+				    (lambda (ll)
+				      (make-code empty-set
+						 empty-set
+						 empty-set ; no globals
+						 empty-set
+						 empty-set
+						 #f #f
+						 (list 
+						  (get-annotation 
+						   (zodiac:define-values-form-val ll)))))
+				    (compiler:get-lifted-lambdas))
+				   (reverse plc-acc)
+				   (map (lambda (ll globs) 
+					  (make-code empty-set
+						     empty-set
+						     globs
+						     empty-set
+						     empty-set
+						     #f #f
+						     (list
+						      (get-annotation 
+						       (zodiac:define-values-form-val 
+							(if (zodiac:module-form? ll)
+							    (zodiac:module-form-body ll)
+							    ll))))))
+					(compiler:get-once-closures-list)
+					(compiler:get-once-closures-globals-list))
+				   (map reset-globals c (map cdr l)))))
+			(loop (sub1 n) (cdr l) (cdr c) 
+			      (cons (caar l) pll-acc) (cons (reset-globals (car c) (cdar l)) plc-acc))))
+		  (loop (sub1 n) (cdr l) (cdr c) 
+			(cons (caar l) l-acc) (cons (reset-globals (car c) (cdar l)) c-acc)))))
+	  
+	  ;; Lifted lambdas are true constants:
+	  (set! number-of-true-constants (+ number-of-true-constants
+					    (length (compiler:get-lifted-lambdas))))))
+
+      (define s:append-block-sources!
+	(lambda (file-block l)
+	  (set-block-codes!
+	   file-block
+	   (append!
+	    (map
+	     (lambda (glob)
+	       (make-code empty-set
+			  empty-set
+			  empty-set
+			  empty-set
+			  empty-set
+			  #f #f null))
+	     l)
+	    (block-codes file-block)))
+	  (set-block-source! 
+	   file-block
+	   (append! l (block-source file-block)))))
+
+      (define (open-input-scheme-file path)
+	(let ([p (let ([open (with-handlers ([exn:fail? (lambda (x) #f)])
+			       (dynamic-require '(lib "mred.ss" "mred") 'open-input-graphical-file))])
+		   (if open
+		       ;; Handles WXME files:
+		       (open path)
+		       ;; Check for WXME and give a nice error message:
+		       (let ([p (open-input-file path)])
+			 (when (regexp-match-peek "^WXME01[0-9][0-9] ## " p)
+			   (close-input-port p)
+			   (error 'compile-file
+				  "file appears to have graphical syntax (try graphical-mzc): ~a"
+				  path))
+			 p)))])
+	  ;; Skip leading "#!:
+	  (let loop ([s (regexp-match-peek #rx"^#![^\r\n]*" p)])
+	    (when s
+	      (read-line p)
+	      (when (regexp-match #rx"\\\\$" (car s))
+		(loop (regexp-match-peek #rx"^[^\r\n]*" p)))))
+	  p))
+
+      ;;-------------------------------------------------------------------------------
+      ;; ERROR/WARNING REPORTING/HANDLING ROUTINES
+      ;;
+      (define compiler:messages null)
+      (define compiler:make-message
+	(lambda (constructor)
+	  (lambda (ast message)
+	    (set! compiler:messages (cons (constructor ast message)
+					  compiler:messages)))))
+      (define compiler:error (compiler:make-message make-compiler:fatal-error-msg))
+      (define compiler:fatal-error compiler:error)
+      (define compiler:internal-error
+	(case-lambda
+	 [(ast message)
+	  (set! compiler:messages 
+		(reverse! (cons (make-compiler:internal-error-msg ast message)
+				compiler:messages)))
+	  (compiler:report-messages! #t)]
+	 [(ast fmt . args)
+	  (compiler:internal-error ast (apply format fmt args))]))
+      
+      (define compiler:warning (compiler:make-message make-compiler:warning-msg))
+
+      (define compiler:report-messages!
+	(lambda (stop-on-errors?)
+	  (let ([error-count 0]
+		[fatal-error-count 0]
+		[msgs (reverse! compiler:messages)])
+	    (set! compiler:messages null)
+	    (for-each (lambda (message)
+			(when (compiler:error-msg? message) 
+			  (set! error-count (add1 error-count)))
+			(when (or (compiler:fatal-error-msg? message) 
+				  (compiler:internal-error-msg? message))
+			  (set! fatal-error-count (add1 fatal-error-count)))
+
+			(let* ([ast (compiler:message-ast message)]
+			       [string (compiler:message-message message)])
+			  (zodiac:print-start! (current-output-port) ast)
+			  (printf 
+			   "~a: ~a~n"
+			   (cond
+			    [(compiler:error-msg? message) "Error"]
+			    [(compiler:warning-msg? message) "Warning"]
+			    [(compiler:fatal-error-msg? message) "Error"]
+			    [(compiler:internal-error-msg? message) "INTERNAL ERROR"]
+			    [else (error 'report-messages "internal error")])
+			   string)
+			  (when (compiler:internal-error-msg? message)
+			    (printf 
+			     (string-append
+			      " please report the bug using Help Desk~n"
+			      "  or http://bugs.plt-scheme.org/~n"
+			      "  and include a transcript in verbose mode~n")))))
+		      
+		      msgs)
+	    (when (and stop-on-errors?
+		       (or (positive? error-count)
+			   (positive? fatal-error-count)))
+	      (error "Errors encountered.  Compilation aborted.")))))
+
+      (define total-cpu-time 0)
+      (define total-real-time 0)
+      (define verbose-time
+	(lambda (thunk)
+	  (let-values ([(vals cpu real gc) (time-apply thunk null)])
+	    (set! total-cpu-time (+ total-cpu-time cpu))
+	    (set! total-real-time (+ total-real-time real))
+	    (when (compiler:option:verbose)
+	      (printf "      [cpu: ~ams, real: ~ams, gc: ~ams]~n" cpu real gc))
+	    (apply values vals))))
+
+      ;;-----------------------------------------------------------------------------
+      ;; File-level Block information
+      
+      (define s:file-block (make-empty-block))
+      (define s:max-arity 0) ; compilation-wide max
+      (define s:register-max-arity!
+	(lambda (n) (set! s:max-arity (max s:max-arity n))))
+
+      (define number-of-true-constants 0)
+      (define number-of-per-load-constants 0)
+      
+      (define s:unit-list null) ; list of units in the code
+      
+      (define compiler:setup-suffix "")
+
+      (define (get-s:file-block) s:file-block)
+      (define (compiler:get-setup-suffix) compiler:setup-suffix)
+
+      (define c-declares null)
+      (define (register-c-declaration str)
+	(set! c-declares (cons str c-declares)))
+
+      (define c-lambdas null)
+      (define (register-c-lambda-function name body)
+	(set! c-lambdas (cons (cons name body) c-lambdas)))
+
+      ;;-----------------------------------------------------------------------------
+      ;; THE MAIN DRIVING ROUTINE
+
+      (define (compile-extension* input-name dest-directory)
+	(s:compile #f #f #f input-name dest-directory))
+      (define (compile-extension-to-c input-name dest-directory)
+	(s:compile #t #f #f input-name dest-directory))
+      (define (compile-c-extension input-name dest-directory)
+	(s:compile #f #f #t input-name dest-directory))
+
+      (define (compile-extension-part input-name dest-directory)
+	(s:compile #f #t #f input-name dest-directory))
+      (define (compile-extension-part-to-c input-name dest-directory)
+	(s:compile #t #t #f input-name dest-directory))
+      (define (compile-c-extension-part input-name dest-directory)
+	(s:compile #f #t #t input-name dest-directory))
+
+      (define compiler:multi-o-constant-pool (make-parameter #f))
+
+      (define compiler:module-decl-name #f)
+
+      (define s:compile
+	(lambda (c-only? multi-o? from-c? input-name dest-directory)
+	  (define input-directory 
+	    (let-values ([(base file dir?)
+			  (split-path (path->complete-path input-name))])
+	      base))
+	  (compiler:multi-o-constant-pool multi-o?)
+	  (set! s:file-block (make-empty-block))
+	  (set! s:max-arity 0)
+	  (set! total-cpu-time 0)
+	  (set! total-real-time 0)
+	  (random-seed (compiler:option:seed))
+	  (set! compiler:messages null)
+	  (set! c-declares null)
+	  (set! c-lambdas null)
+	  (const:init-tables!)
+	  (compiler:init-closure-lists!)
+	  (varref:reset-module-id!)
+	  ; process the input string - try to open the input file
+	  (let-values ([(input-path c-output-path 
+				    constant-pool-output-path obj-output-path dll-output-path 
+				    setup-suffix)
+			(s:process-filenames input-name dest-directory from-c? 
+					     (and (compiler:option:clean-intermediate-files)
+						  (not c-only?))
+					     (and (compiler:option:clean-intermediate-files)
+						  (not multi-o?)))])
+	    (unless (or (not input-path) (file-exists? input-path))
+	      (error 's:compile "could not open ~a for input" input-path))
+	    (set! compiler:setup-suffix
+		  (if multi-o?
+		      setup-suffix
+		      ""))
+	    
+	    (for-each (lambda (path)
+			(when (file-exists? path) (delete-file path)))
+		      (list (if input-path c-output-path obj-output-path) 
+			    (if input-path constant-pool-output-path obj-output-path) 
+			    obj-output-path dll-output-path))
+	
+	    (when (compiler:option:debug)
+	      (when (file-exists? debug:file) (delete-file debug:file))
+	      (set! debug:port (open-output-file debug:file 'text)))
+	
+	    (when input-path 
+	      (parameterize ([main-source-file input-path])
+		(let ([input-port (open-input-scheme-file input-path)])
+		  (port-count-lines! input-port)
+
+		  ;;-----------------------------------------------------------------------
+		  ;; read all top-level s-expressions
+		  ;;
+	      
+		  (printf "\"~a\": " input-path)
+		  (unless (compiler:option:verbose) (newline))
+		  (let ([read-thunk
+			 (lambda ()
+			   (with-handlers ([void top-level-exn-handler])
+			     (with-handlers ([void elaboration-exn-handler])
+			       (parameterize ([current-namespace elaborate-namespace]
+					      [compiler:escape-on-error #t])
+				 (set-block-source! 
+				  s:file-block
+				  (s:expand-top-level-expressions! 
+				   input-directory
+				   (lambda ()
+				     (read-syntax (path->complete-path input-path) input-port))
+				   (compiler:option:verbose)))))))])
+		    (verbose-time read-thunk)
+		    (close-input-port input-port)
+		    (set! input-port #f)
+		
+		    (compiler:report-messages! #t))
+	
+		  ;; (print-struct #t) (map (lambda (ast) (pretty-print ast)) (block-source s:file-block))
+		  
+		  ;; (map (lambda(ast)(pretty-print (zodiac->sexp/annotate ast))) (block-source s:file-block))
+		  
+		  ;; (print-graph #t) (display (car (block-source s:file-block))) (newline)
+
+		  ;;-----------------------------------------------------------------------
+		  ;; record module name, if a single declaration
+
+		  (set-single-module-mode! #f)
+		  (when (and (= 1 (length (block-source s:file-block)))
+			     (zodiac:module-form? (car (block-source s:file-block))))
+		    (set-single-module-mode! #t)
+		    (set! compiler:module-decl-name 
+			  (syntax-e (zodiac:module-form-name (car (block-source s:file-block))))))
+
+		  ;;-----------------------------------------------------------------------
+		  ;; Run a preprocessing phase on the input
+		  ;;
+	      
+		  (when (compiler:option:verbose) (printf " pre-processing and scanning for errors~n"))
+		  (when (compiler:option:debug) (debug " = PREPHASE =~n"))
+	      
+		  (let ([prephase-thunk 
+			 (lambda () 
+			   (set-block-source! 
+			    s:file-block
+			    (let loop ([source (block-source s:file-block)]
+				       [errors compiler:messages])
+			      (if (null? source)
+				  source
+				  (let ([ast (prephase! (car source) #f (null? (cdr source)) #f)])
+				    (if (eq? errors compiler:messages)
+					
+					;; no errors here
+					(if (zodiac:module-form? ast)
+					    ;; If it's a module, split it into three parts:
+					    ;;   - body
+					    ;;   - syntax definitions
+					    ;;   - module registration
+					    ;; That way, the global variable sets, etc., are
+					    ;; kept separate.
+					    (append (split-module ast) (loop (cdr source) errors))
+
+					    ;; Normal expr
+					    (cons ast (loop (cdr source) errors)))
+					
+					;; error, drop this one
+					(loop (cdr source) compiler:messages)))))))])
+		    (verbose-time prephase-thunk))
+		  (compiler:report-messages! (not (compiler:option:test)))
+		  (when (compiler:option:test)
+		    (printf "skipping over top-level expressions with errors...~n"))
+	      
+	      ; (map (lambda (ast) (pretty-print (zodiac->sexp/annotate ast))) (block-source s:file-block))
+	      
+	      ;;-----------------------------------------------------------------------
+	      ;; A-normalize input
+	      ;;
+	      
+	      (when (compiler:option:verbose) (printf " transforming to a-normal form~n"))
+	      (when (compiler:option:debug) (debug " = ANORM =~n"))
+	      
+	      (let ([anorm-thunk
+		     (lambda ()
+		       (set-block-source! 
+			s:file-block 
+			(map (lambda (s) (a-normalize s identity)) 
+			     (block-source s:file-block))))])
+		(verbose-time anorm-thunk))
+	      
+	      ; (map (lambda (ast) (pretty-print (zodiac->sexp/annotate ast))) (block-source s:file-block))
+	      
+	      ;;-----------------------------------------------------------------------
+	      ;; known-value analysis
+	      ;;
+
+	      (when (compiler:option:verbose) 
+		(printf " determining known bindings~n"))
+	      (when (compiler:option:debug)
+		(debug " = KNOWN =~n"))
+
+	      ; analyze top level expressions
+	      (let ([known-thunk
+		     (lambda ()
+		       (set-block-source! 
+			s:file-block 
+			(map (lambda (s) (analyze-knowns! s)) 
+			     (block-source s:file-block))))])
+		(verbose-time known-thunk))
+
+	      (compiler:report-messages! #t)
+	      
+	      ; (map (lambda (ast) (pretty-print (zodiac->sexp/annotate ast))) (block-source s:file-block))
+
+	      ;;-----------------------------------------------------------------------
+	      ;; B-form transformation and analysis
+	      ;;
+
+	      (when (compiler:option:verbose) 
+		(printf " transforming to b-normal form, analyzing, and inlining~n"))
+	      (when (compiler:option:debug)
+		(debug " = ANALYZE =~n"))
+
+	      ; analyze top level expressions, cataloguing local variables
+	      (compiler:init-define-lists!)
+	      (const:reset-syntax-constants!)
+	      (let ([bnorm-thunk
+		     (lambda ()
+		       (let-values ([(new-source new-codes max-arity)
+				     (s:analyze-source-list 
+				      (block-source s:file-block))])
+			 (set-block-source! s:file-block new-source)
+			 (set-block-codes! s:file-block new-codes)
+			 (block:register-max-arity! s:file-block max-arity)
+			 (s:register-max-arity! max-arity))
+		       
+		       ; take constant construction code and place it in front of the 
+		       ; previously generated code. True constants first.
+		       (set! number-of-true-constants (length (compiler:get-define-list)))
+		       (set! number-of-per-load-constants (+ (length (compiler:get-per-load-define-list))
+							     (length (compiler:get-per-invoke-define-list))))
+		       (s:append-block-sources! s:file-block 
+						(append
+						 (compiler:get-define-list)
+						 (compiler:get-per-load-define-list)
+						 (compiler:get-per-invoke-define-list))))])
+		(verbose-time bnorm-thunk))
+	      (compiler:report-messages! #t)
+	      
+	      ; (map (lambda (ast) (pretty-print (zodiac->sexp/annotate ast))) (block-source s:file-block))
+
+	      ;;-----------------------------------------------------------------------
+	      ;; Lift static procedures
+	      ;;
+
+	      (when (compiler:option:verbose) 
+		(printf " finding static procedures~n"))
+	      (when (compiler:option:debug)
+		(debug " = LIFT =~n"))
+
+	      (let ([lift-thunk s:lift])
+		(verbose-time lift-thunk))
+	      (compiler:report-messages! #t)
+	      
+	      ; (map (lambda (ast) (pretty-print (zodiac->sexp/annotate ast))) (block-source s:file-block))
+
+	      ;;-----------------------------------------------------------------------
+	      ;; Closure conversion and explicit control transformation
+	      ;;
+	      
+	      (when (compiler:option:verbose) 
+		(printf " closure conversion and explicit control transformation~n"))
+	      
+	      (let ([closure-thunk
+		     (lambda ()
+		       (set-block-source! 
+			s:file-block
+			(map closure-expression! (block-source s:file-block))))])
+		(verbose-time closure-thunk))
+
+	      ;;-----------------------------------------------------------------------
+	      ;; Vehicle assignment
+	      ;;
+	      ;; Set export list offset for units at the same time
+	      ;;
+	      
+	      (when (compiler:option:verbose)
+		(printf " closure->vehicle mapping~n"))
+	      
+	      (when (eq? (compiler:option:vehicles) 'vehicles:automatic)
+		(for-each 
+		 (lambda (L)
+		   (when (zodiac:case-lambda-form? L)
+		     (map (lambda (body)
+			    (relate-lambdas! L body))
+			  (zodiac:case-lambda-form-bodies L))))
+		 (compiler:get-closure-list)))
+	      
+	      (when (eq? (compiler:option:vehicles) 'vehicles:units)
+		(compiler:fatal-error 
+		 #f 
+		 "unit-wise vehicle mapping not currently supported~n"))
+	      (let ([vehicle-thunk
+		     (lambda ()
+		       (compiler:init-vehicles!)
+		       (compiler:reset-label-number!)
+		       (choose-vehicles!))])
+		(verbose-time vehicle-thunk))
+
+	      ;;-----------------------------------------------------------------------
+	      ;; Representation Choosing 
+	      ;;    From this stage, we have to work with separate code bodies, as well
+	      ;;    as the list of top-level expressions.
+	      
+	      (when (compiler:option:verbose) 
+		(printf 
+		 " choosing data representations~n"))
+	      
+	      (let ([rep-thunk
+		     (lambda ()
+		       (compiler:init-structs!)
+		       ; top-level
+		       (map
+			(lambda (c)
+			  (choose-binding-representations! 
+			   (code-local-vars c)
+			   (code-global-vars c)
+			   (code-used-vars c)
+			   (code-captured-vars c)))
+			(block-codes s:file-block))
+		       ; code-bodies
+		       (for-each (lambda (L)
+				   (let* ([code (get-annotation L)]
+					  [locals (code-local-vars code)]
+					  [globals (code-global-vars code)]
+					  [used (code-used-vars code)]
+					  [captured (code-captured-vars code)])
+				     (choose-binding-representations! locals globals used captured)
+				     (choose-closure-representation! code)))
+				 (compiler:get-closure-list)))])
+		(verbose-time rep-thunk))
+
+	      ; (map (lambda (ast) (pretty-print (zodiac->sexp/annotate ast))) (block-source s:file-block))
+	      
+	      ;;-----------------------------------------------------------------------
+	      ;; Virtual Machine Scheme translation
+	      ;;   Here we turn our code into VM Scheme as we enter the arena of
+	      ;;    low level transformations and optimizations.
+	      ;;   This transformation may create new local variables, so
+	      ;;    we have to update the local variable set for each top-level
+	      ;;    expression or code body.
+	      
+	      (when (compiler:option:verbose) (printf " transforming to Virtual Machine form~n"))
+	      (when (compiler:option:debug) (debug " = VMPHASE =~n"))
+	      
+	      (let ([vmphase-thunk
+		     (lambda ()
+		       ; top-level.  The last expression will be in tail position and should
+		       ; return its value
+		       (let loop ([s (block-source s:file-block)]
+				  [l (block-codes s:file-block)])
+			 (unless (null? s)
+			   (let-values ([(vm new-locals)
+					 (vm-phase (car s) 
+						   #t
+						   #f
+						   (if (null? (cdr s))
+						       (lambda (ast)
+							 (make-vm:return 
+							  (zodiac:zodiac-stx ast)
+							  ast))
+						       (lambda (ast)
+							 (make-vm:void
+							  (zodiac:zodiac-stx ast)
+							  ast)))
+						   (null? (cdr s)))])
+			     (set-car! s vm)
+			     (add-code-local+used-vars! (car l) new-locals))
+			   (loop (cdr s) (cdr l))))
+		       ; code-bodies
+		       (for-each 
+			(lambda (L)
+			  (let* ([code (get-annotation L)]
+				 [tail-pos (lambda (ast)
+					     (make-vm:return 
+					      (zodiac:zodiac-stx ast)
+					      ast))]
+				 [new-locals
+				  (cond
+				   [(zodiac:case-lambda-form? L)
+				    (let-values ([(vms new-locals)
+						  (let loop ([l (zodiac:case-lambda-form-bodies L)]
+							     [case-codes (procedure-code-case-codes 
+									  (get-annotation L))]
+							     [vms null])
+						    (if (null? l)
+							(values (reverse! vms) 
+								; empty: already added via case
+								empty-set) 
+							(let-values ([(vm new-locals)
+								      (vm-phase (car l) #t #f tail-pos #t)])
+							  (add-code-local+used-vars! 
+							   (car case-codes)
+							   new-locals )
+							  (loop (cdr l)
+								(cdr case-codes)
+								(cons vm vms)))))])
+				      (zodiac:set-case-lambda-form-bodies! L vms)
+				      new-locals)]
+				   [else (compiler:internal-error
+					  L
+					  "vmphase: unknown closure type")])])
+			    (add-code-local+used-vars! code new-locals)))
+			(compiler:get-closure-list)))])
+		(verbose-time vmphase-thunk))
+
+	      (compiler:report-messages! #t)
+
+	      ; (print-struct #t)
+	      ; (map (lambda (ast) (pretty-print ast)) (block-source s:file-block))
+
+	      ;;-----------------------------------------------------------------------
+	      ;; Virtual Machine Optimization Pass
+	      ;;
+	      ;;  As in the previous phase, new local variables may be created.
+	      
+	      (when (compiler:option:verbose) (printf " optimizing Virtual Machine code~n"))
+	      
+	      (let ([vmopt-thunk
+		     (lambda ()
+		       ; top-level
+		       (let loop ([bl (block-source s:file-block)]
+				  [cl (block-codes s:file-block)])
+			 (unless (null? bl)
+			   (let-values ([(b new-locs) ((vm-optimize! #f #f) (car bl))])
+			     (set-car! bl b)
+			     (add-code-local+used-vars! (car cl) new-locs))
+			   (loop (cdr bl) (cdr cl))))
+		       
+		       ; code-bodies
+		       (for-each (lambda (L)
+				   (let ([code (get-annotation L)])
+				     (cond
+				      [(zodiac:case-lambda-form? L)
+				       (let loop ([bodies (zodiac:case-lambda-form-bodies L)]
+						  [case-codes (procedure-code-case-codes code)]
+						  [i 0])
+					 (unless (null? bodies)
+					   (let-values ([(new-body new-locs) ((vm-optimize! L i) (car bodies))])
+					     (set-car! bodies new-body)
+					     (add-code-local+used-vars! (car case-codes)
+									new-locs)
+					     (loop (cdr bodies)
+						   (cdr case-codes)
+						   (add1 i)))))]
+				      [else (compiler:internal-error
+					     L
+					     "vmopt: unknown closure type")])))
+				 (compiler:get-closure-list)))])
+		(verbose-time vmopt-thunk))
+		 
+	      (compiler:report-messages! #t)
+			  
+	      ;;-----------------------------------------------------------------------
+	      ;; Virtual Machine -> ANSI C translation
+	      ;;
+	      (when (compiler:option:verbose)
+		(printf " [emitting ~a C to \"~a\"]~n" 
+			"ANSI"
+			c-output-path))
+	
+	      (let ([vm2c-thunk
+		     (lambda ()
+		       (parameterize ([read-case-sensitive #t]) ;; so symbols containing uppercase print like we want
+			 (let ([c-port #f])
+			   (dynamic-wind 
+					;pre
+			       (lambda () (set! c-port (open-output-file c-output-path)))
+			       
+					;value
+			       (lambda ()
+				 (fprintf c-port "#define MZC_SRC_FILE ~s~n" input-name)
+				 (when (compiler:option:unsafe) (fprintf c-port "#define MZC_UNSAFE 1~n"))
+				 (when (compiler:option:disable-interrupts) (fprintf c-port "#define MZC_DISABLE_INTERRUPTS 1~n"))
+				 (when (compiler:option:fixnum-arithmetic) (fprintf c-port "#define MZC_FIXNUM 1~n"))
+				 
+				 (fprintf c-port "~n#include \"~ascheme.h\"~n"
+					  (if (compiler:option:compile-for-embedded)
+					      ""
+					      "e"))
+				 
+				 (unless (null? c-declares)
+				   (fprintf c-port "~n/* c-declare literals */~n~n")
+				   (for-each
+				    (lambda (c-declare)
+				      (fprintf c-port "~a~n" c-declare))
+				    (reverse c-declares))
+				   (fprintf c-port "~n/* done with c-declare literals */~n~n"))
+
+				 (unless (null? c-lambdas)
+				   (fprintf c-port "~n/* c-lambda implementations */~n~n")
+				   (for-each
+				    (lambda (c-lambda)
+				      (let ([name (car c-lambda)]
+					    [body (cdr c-lambda)])
+					(fprintf c-port "Scheme_Object *~a(int argc, Scheme_Object **argv) {\n"
+						 name)
+					(fprintf c-port "~a~n" body)
+					(fprintf c-port "}~n")))
+				    (reverse c-lambdas))
+				   (fprintf c-port "~n/* done with c-lambda implementations */~n~n"))
+
+				 (fprintf c-port "#include \"mzc.h\"~n~n")
+				 (vm->c:emit-struct-definitions! (compiler:get-structs) c-port)
+				 (vm->c:emit-symbol-declarations! c-port)
+				 (vm->c:emit-syntax-string-declarations! c-port)
+				 (vm->c:emit-inexact-declarations! c-port)
+				 (vm->c:emit-string-declarations! c-port)
+				 (vm->c:emit-prim-ref-declarations! c-port)
+				 (vm->c:emit-static-declarations! c-port)
+				 
+				 (let loop ([n 0])
+				   (unless (= n (compiler:get-total-vehicles))
+				     (vm->c:emit-vehicle-declaration c-port n)
+				     (loop (+ n 1))))
+				 (newline c-port)
+				 
+				 (unless (compiler:multi-o-constant-pool)
+				   (fprintf c-port "~nstatic void make_symbols()~n{~n")
+				   (vm->c:emit-symbol-definitions! c-port)
+				   (fprintf c-port "}~n"))
+
+				 (fprintf c-port "~nstatic void make_syntax_strings()~n{~n")
+				 (vm->c:emit-syntax-string-definitions! c-port)
+				 (fprintf c-port "}~n")
+				 
+				 (unless (zero? (const:get-inexact-counter))
+				   (fprintf c-port "~nstatic void make_inexacts()~n{~n")
+				   (vm->c:emit-inexact-definitions! c-port)
+				   (fprintf c-port "}~n"))
+
+				 (fprintf c-port "~nstatic void gc_registration()~n{~n")
+				 (vm->c:emit-registration! c-port)
+				 (fprintf c-port "}~n")
+
+				 (fprintf c-port "~nstatic void init_prims(Scheme_Env * env)~n{~n")
+				 (vm->c:emit-prim-ref-definitions! c-port)
+				 (fprintf c-port "}~n")
+				 
+				 (unless (null? (compiler:get-case-lambdas))
+				   (fprintf c-port "~nstatic void init_cases_arities()~n{~n")
+				   (vm->c:emit-case-arities-definitions! c-port)
+				   (fprintf c-port "}~n"))
+				 (newline c-port)
+
+				 (let* ([codes (block-codes s:file-block)]
+					[locals (map code-local-vars codes)]
+					[globals (map code-global-vars codes)]
+					[init-constants-count
+					 (if (zero? number-of-true-constants)
+					     -1
+					     (vm->c:emit-top-levels! "init_constants" #f #f #t number-of-true-constants
+								     (block-source s:file-block)
+								     locals globals
+								     (block-max-arity s:file-block)
+								     #f #f ; no module entries
+								     c-port))]
+					[invoke-counts
+					 (let loop ([i 0])
+					   (if (= i (get-num-module-invokes))
+					       null
+					       (cons
+						(let loop ([syntax? #f])
+						  (cons
+						   (vm->c:emit-top-levels! (format "module~a_body_~a" 
+										   (if syntax? "_syntax" "")
+										   i)
+									   #f #f #f -1
+									   (block-source s:file-block)
+									   locals
+									   globals
+									   (block-max-arity s:file-block)
+									   i syntax?
+									   c-port)
+						   (if syntax? 
+						       null
+						       (loop #t))))
+						(loop (add1 i)))))]
+					[_ (let loop ([i 0][counts invoke-counts])
+					     (unless (= i (get-num-module-invokes))
+					       (vm->c:emit-module-glue! c-port i (caar counts) (cadar counts))
+					       (loop (add1 i) (cdr counts))))]
+					[top-level-count
+					 (vm->c:emit-top-levels! "top_level" #t #t #f -1
+								 (list-tail (block-source s:file-block) number-of-true-constants)
+								 (list-tail locals number-of-true-constants)
+								 (list-tail globals number-of-true-constants)
+								 (block-max-arity s:file-block)
+								 #f #f ; no module entries
+								 c-port)])
+				   (fprintf c-port
+					    "Scheme_Object * scheme_reload~a(Scheme_Env * env)~n{~n"
+					    compiler:setup-suffix)
+				   (fprintf c-port"~aScheme_Per_Load_Statics *PLS;~n"
+					    vm->c:indent-spaces)
+				   (fprintf c-port 
+					    "~aPLS = (Scheme_Per_Load_Statics *)scheme_malloc(sizeof(Scheme_Per_Load_Statics));~n"
+					    vm->c:indent-spaces)
+				   (let loop ([c 0])
+				     (fprintf c-port "~a~atop_level_~a(env, PLS);~n" 
+					      vm->c:indent-spaces 
+					      (if (= c top-level-count) "return " "")
+					      c)
+				     (unless (= c top-level-count)
+				       (loop (add1 c))))
+				   (fprintf c-port 
+					    "}~n~n")
+
+				   (fprintf c-port
+					    "~nvoid scheme_setup~a(Scheme_Env * env)~n{~n"
+					    compiler:setup-suffix)
+				   (fprintf c-port
+					    "~ascheme_set_tail_buffer_size(~a);~n"
+					    vm->c:indent-spaces
+					    s:max-arity)
+				   (fprintf c-port "~agc_registration();~n"
+					    vm->c:indent-spaces)
+				   (unless (compiler:multi-o-constant-pool)
+				     (fprintf c-port "~amake_symbols();~n"
+					      vm->c:indent-spaces))
+				   (fprintf c-port "~amake_syntax_strings();~n"
+					    vm->c:indent-spaces)
+				   (unless (zero? (const:get-inexact-counter))
+				     (fprintf c-port "~amake_inexacts();~n"
+					      vm->c:indent-spaces))
+				   (fprintf c-port "~ainit_prims(env);~n"
+					    vm->c:indent-spaces)
+				   (unless (null? (compiler:get-case-lambdas))
+				     (fprintf c-port "~ainit_cases_arities();~n"
+					      vm->c:indent-spaces))		       
+
+				   (let loop ([c 0])
+				     (unless (> c init-constants-count)
+				       (fprintf c-port "~ainit_constants_~a(env);~n" 
+						vm->c:indent-spaces
+						c)
+				       (loop (add1 c))))
+
+				   (fprintf c-port 
+					    "}~n~n")
+				   
+				   (when (string=? "" compiler:setup-suffix)
+				     (fprintf c-port
+					      "~nScheme_Object * scheme_initialize(Scheme_Env * env)~n{~n")
+				     (fprintf c-port "~ascheme_setup~a(env);~n"
+					      vm->c:indent-spaces
+					      compiler:setup-suffix)
+				     (fprintf c-port "~areturn scheme_reload~a(env);~n"
+					      vm->c:indent-spaces
+					      compiler:setup-suffix)
+				     (fprintf c-port 
+					      "}~n~n"))
+
+				   (fprintf c-port
+					    "~nScheme_Object * ~ascheme_module_name()~n{~n~areturn "
+					    compiler:setup-suffix
+					    vm->c:indent-spaces)
+				   (if compiler:module-decl-name
+				       (let ([s (symbol->string compiler:module-decl-name)])
+					 (fprintf c-port "scheme_intern_exact_symbol(~s, ~a)" s (string-length s)))
+				       (fprintf c-port "scheme_false"))
+				   (fprintf c-port ";~n}~n"))
+
+				 (let emit-vehicles ([vehicle-number 0])
+				   (unless (= vehicle-number (compiler:get-total-vehicles))
+				     (let* ([vehicle (get-vehicle vehicle-number)]
+					    [lambda-list (vehicle-lambdas vehicle)])
+				       
+				       (vm->c:emit-vehicle-header c-port vehicle-number)
+				       (vm->c:emit-vehicle-prologue c-port vehicle)
+				       
+				       ;; get the lambdas that appear in this vehicle
+				       
+				       ;; sort the functions by index to get an optimal case statement
+				       ;; even for stupid compilers
+				       (set! lambda-list
+					     (quicksort lambda-list
+							(lambda (l1 l2)
+							  (< (closure-code-label (get-annotation l1))
+							     (closure-code-label (get-annotation l2))))))
+				       (for-each (lambda (L)
+						   (let ([code (get-annotation L)]
+							 [start (zodiac:zodiac-start L)])
+						     (fprintf c-port "~a/* code body ~a ~a [~a,~a] */~n"
+							      vm->c:indent-spaces (closure-code-label code)
+							      (let ([n (closure-code-name code)])
+								(if n
+								    (protect-comment 
+								     (vm->c:extract-inferred-name n))
+								    ""))
+							      (zodiac:location-line start)
+							      (zodiac:location-column start))
+						     (cond
+						      [(zodiac:case-lambda-form? L)
+						       (let-values ([(count suffix?) 
+								     (vm->c:emit-function-prologue L c-port)])
+							 (let loop ([i 0])
+							   (unless (= i count)
+							     (let* ([indent
+								     (string-append
+								      vm->c:indent-spaces vm->c:indent-spaces
+								      (if suffix?  vm->c:indent-spaces ""))]
+								    [undefines
+								     (vm->c:emit-case-prologue L i
+											       (lambda ()
+												 (if suffix?
+												     (fprintf c-port "~a~a/* begin case ~a */~n~a~a{~n" 
+													      vm->c:indent-spaces vm->c:indent-spaces i
+													      vm->c:indent-spaces vm->c:indent-spaces)
+												     (when (zero? i)
+												       (fprintf c-port "~a{~n" vm->c:indent-spaces))))
+											       (if suffix? (format "c~a" i) "")
+											       indent
+											       c-port)])
+							       (vm->c-expression (list-ref (zodiac:case-lambda-form-bodies L) i)
+										 code
+										 c-port
+										 (* (if suffix? 3 2) vm->c:indent-by)
+										 #f)
+							       (vm->c:emit-case-epilogue L i undefines indent c-port)
+							       (when suffix?
+								 (fprintf c-port "~a~a} /* end case ~a */~n" 
+									  vm->c:indent-spaces 
+									  vm->c:indent-spaces i)))
+							     
+							     (loop (add1 i))))
+							 (vm->c:emit-function-epilogue code 
+										       (if suffix? "" "}")
+										       c-port))]
+						      [else
+						       (compiler:internal-error
+							L
+							"vm2c: unknown closure type")])
+						     (newline c-port)))
+						 lambda-list))
+				     
+				     (vm->c:emit-vehicle-epilogue c-port vehicle-number)
+				     (newline c-port)
+				     (emit-vehicles (+ 1 vehicle-number)))))
+			       
+			       ;; post (dynamic wind cleanup)
+			       (lambda ()  (close-output-port c-port))))))])
+		(with-handlers ([void (lambda (exn)
+					(delete-file c-output-path)
+					(raise exn))])
+		  (verbose-time vm2c-thunk)))
+	      
+	      (compiler:report-messages! #t)
+	      
+	      ;; Write out symbols for multi-o constant pool
+	      (when (compiler:multi-o-constant-pool)
+		(call-with-output-file constant-pool-output-path
+		  (lambda (port)
+		    (fprintf port "(~s~n (symbols~n" compiler:setup-suffix)
+		    (vm->c:emit-symbol-list! port "" #f)
+		    (fprintf port "  )~n )~n")))))))
+
+	;;--------------------------------------------------------------------
+	;; COMPILATION TO NATIVE CODE
+	;;
+	
+	(if c-only?
+	    (printf " [output to \"~a\"]~n" c-output-path)
+	    
+	    (begin
+	      (unless input-path
+		(printf "\"~a\": ~n" c-output-path))
+	      
+	      (when (compiler:option:verbose) (printf " [compiling native code to \"~a\"]~n"
+						      obj-output-path))
+	      
+	      ;; Compile
+	      (let ([compile-thunk
+		     (lambda ()
+		       (with-handlers
+			   ([void (lambda (exn)
+				    (compiler:fatal-error
+				     #f
+				     (string-append
+				      " C compiler did not complete successfully"
+				      (string #\newline)
+				      (exn-message exn)))
+				    (compiler:report-messages! #t))])
+			 (compile-extension (not (compiler:option:verbose)) 
+					    c-output-path obj-output-path
+					    (list (collection-path "compiler")))))])
+		(verbose-time compile-thunk))
+	      
+	      ;; clean-up
+	      (when (and (compiler:option:clean-intermediate-files)
+			 input-path)
+		(delete-file c-output-path))
+	      
+	      (if multi-o?
+		  (printf " [output to \"~a\"]~n" obj-output-path)
+		  
+		  (begin
+		    ;; Link
+		    (when (compiler:option:verbose) (printf " [linking to \"~a\"]~n"
+							    dll-output-path))
+		    (let ([link-thunk
+			   (lambda ()
+			     (with-handlers
+				 ([void (lambda (exn)
+					  (compiler:fatal-error 
+					   #f 
+					   (string-append 
+					    " linker did not link successfully"
+					    (string #\newline)
+					    (exn-message exn)))
+					  (compiler:report-messages! #t))])
+			       (link-extension (not (compiler:option:verbose)) (list obj-output-path) dll-output-path)))])
+		      (verbose-time link-thunk))
+		    
+		    ;; clean-up
+		    (when (compiler:option:clean-intermediate-files)
+		      (delete-file obj-output-path))
+		    
+		    (printf " [output to \"~a\"]~n" dll-output-path)))))
+	
+	(when debug:port
+	  (close-output-port debug:port))
+	
+	;; clean up for the garbage collector
+	(compiler:init-define-lists!)
+	(const:init-tables!)
+	(compiler:init-closure-lists!)
+	(compiler:init-structs!)
+	(set! s:file-block #f)
+	(when (compiler:option:verbose)
+	  (printf " finished [cpu ~a, real ~a].~n"
+		  total-cpu-time
+		  total-real-time))))))))
diff --git a/collects/compiler/private/embed.ss b/collects/compiler/private/embed.ss
new file mode 100644
index 0000000000..860c356ccf
--- /dev/null
+++ b/collects/compiler/private/embed.ss
@@ -0,0 +1,7 @@
+
+(module embed mzscheme
+  (require (lib "embed.ss" "compiler"))
+  (define mzc:make-embedding-executable make-embedding-executable)
+  (define mzc:embedding-executable-add-suffix embedding-executable-add-suffix)
+  (provide mzc:make-embedding-executable
+	   mzc:embedding-executable-add-suffix))
diff --git a/collects/compiler/private/info.ss b/collects/compiler/private/info.ss
new file mode 100644
index 0000000000..ef67fd4fc2
--- /dev/null
+++ b/collects/compiler/private/info.ss
@@ -0,0 +1,3 @@
+
+(module info (lib "infotab.ss" "setup")
+  (define name "mzc private"))
diff --git a/collects/compiler/private/known.ss b/collects/compiler/private/known.ss
new file mode 100644
index 0000000000..29a9c31e87
--- /dev/null
+++ b/collects/compiler/private/known.ss
@@ -0,0 +1,566 @@
+;; Known-value analysis
+;; (c) 1996-1997 Sebastian Good
+;; (c) 1997-2001 PLT
+
+;; Sets the the real annotation for zodiac:binding AST nodes,
+;; setting the known? and known-val fields as possible.
+
+;; Known-value analysis is used for constant propagation, but
+;;  more importantly, it's used for compiling tail recursion
+;;  as a goto. mzc can only compile tail recursion as a goto
+;;  when it knows the actual destination of the jump.
+
+;; Note that ``known'' means we know an AST that provides the
+;; value; this AST could be arbitrarily complex, so we really
+;; only know the value if the known AST is simple enough.
+
+;;; Annotatitons: ----------------------------------------------
+;;    binding - `binding' structure (replaces prephase 
+;;      binding-properties structure)
+;;    application - `app' structure
+;;; ------------------------------------------------------------
+
+(module known mzscheme
+  (require (lib "unitsig.ss")
+	  (lib "list.ss")
+	  (lib "etc.ss"))
+
+  (require (lib "zodiac-sig.ss" "syntax"))
+
+  (require "sig.ss")
+  (require "../sig.ss")
+
+  (provide known@)
+  (define known@
+    (unit/sig compiler:known^
+      (import (compiler:option : compiler:option^)
+	      compiler:library^
+	      compiler:cstructs^
+	      (zodiac : zodiac^)
+	      compiler:zlayer^
+	      compiler:prephase^
+	      compiler:anorm^
+	      compiler:const^
+	      compiler:closure^
+	      compiler:rep^
+	      compiler:driver^)
+      
+      ;; helper functions to create a binding annotation
+      (define make-known-binding
+	(lambda (bound val)
+	  (make-binding #f (prephase:is-mutable? bound) 
+			'not-unit (prephase:binding-anchor bound)
+			#f (prephase:is-ivar? bound)
+			#t val #f #f)))
+      (define make-unknown-letbound-binding
+	(lambda (mutable?)
+	  (make-binding #f mutable?
+			#f #f
+			#f #f
+			#f #f #f #f)))
+      (define make-unknown-binding
+	(lambda (bound)
+	  (make-binding #f (prephase:is-mutable? bound) 
+			'not-unit (prephase:binding-anchor bound)
+			#f (prephase:is-ivar? bound)
+			#f #f #f #f)))
+      (define make-begin0-binding
+	(lambda (bound)
+	  (make-binding #f #f #f #f #f #f
+			#f #f #f (make-rep:atomic 'begin0-saver))))
+      (define make-wcm-binding
+	(lambda (bound)
+	  (make-binding #f #f #f #f #f #f
+			#f #f #f (make-rep:atomic 'wcm-saver))))
+
+      ;; Determine whether a varref is a known primitive
+      (define (analyze:prim-fun fun)
+	(and (zodiac:top-level-varref? fun)
+	     (varref:has-attribute? fun varref:primitive)
+	     (primitive? (namespace-variable-value (zodiac:varref-var fun)))
+	     (zodiac:varref-var fun)))
+
+      ;; Some prims call given procedures directly, some install procedures
+      ;;  to be called later, and some call previously installed procedures.
+      ;;  We care abot the installers and callers.
+      (define prims-that-induce-procedure-calls
+	'(apply map for-each andmap ormap make-promise
+		  dynamic-wind thread call-in-nested-thread
+		  make-object call-with-values time-apply
+		  call-with-output-file call-with-input-file
+		  with-output-to-file with-input-from-file
+		  exit-handler current-eval current-exception-handler
+		  current-prompt-read current-load
+		  call-with-escape-continuation call-with-current-continuation
+		  current-print port-display-handler port-write-handler
+		  port-print-handler global-port-print-handler
+		  error-display-handler error-escape-handler
+		  port-read-handler error-value->string-handler
+		  call/ec call/cc hash-table-get
+		  hash-table-map hash-table-for-each make-input-port make-output-port))
+
+      ;; The valueable? predicate is used to determine how many variables
+      ;;  are reliably set in a mutually-recursive binding context.
+      ;; Along the way, we set more `known-binding' information in let and letrec.
+      (define (analyze:valueable? v extra-known-bindings extra-unknown-bindings known-lambdas set-known?)
+	(let loop ([v v][extra-known-bindings extra-known-bindings])
+	  (cond
+	   [(zodiac:quote-form? v) #t]
+	   [(zodiac:bound-varref? v)
+	    ;; the varref must not be unit-i/e?, or it must be in extra-known-bindings
+	    ;; and it must not be in extra-unknown-bindings
+	    (let ([zbinding (zodiac:bound-varref-binding v)])
+	      (and (not (memq zbinding extra-unknown-bindings))
+		   (memq zbinding extra-known-bindings)))]
+	   [(zodiac:varref? v) #t]
+	   [(zodiac:case-lambda-form? v) #t]
+	   [(zodiac:begin-form? v)
+	    (andmap (lambda (v) (loop v extra-known-bindings)) (zodiac:begin-form-bodies v))]
+	   [(zodiac:begin0-form? v)
+	    (andmap (lambda (v) (loop v extra-known-bindings)) (zodiac:begin0-form-bodies v))]
+	   [(zodiac:with-continuation-mark-form? v)
+	    (and (loop (zodiac:with-continuation-mark-form-key v) extra-known-bindings)
+		 (loop (zodiac:with-continuation-mark-form-val v) extra-known-bindings)
+		 (loop (zodiac:with-continuation-mark-form-body v) extra-known-bindings))]
+	   [(zodiac:set!-form? v) #f] ; because it changes a variable
+	   [(zodiac:if-form? v)
+	    (and (loop (zodiac:if-form-test v) extra-known-bindings)
+		 (loop (zodiac:if-form-then v) extra-known-bindings)
+		 (loop (zodiac:if-form-else v) extra-known-bindings))]
+	   [(zodiac:let-values-form? v)
+	    (and (andmap (lambda (vars v) (if (loop v extra-known-bindings)
+					      (begin
+						(when (and set-known?
+							   (= 1 (length vars)))
+						  (prephase:set-known-val! (car vars) v))
+						#t)
+					      #f))
+			 (zodiac:let-values-form-vars v)
+			 (zodiac:let-values-form-vals v))
+		 (loop (zodiac:let-values-form-body v)
+		       (append (apply append (zodiac:let-values-form-vars v))
+			       extra-known-bindings)))]
+	   [(zodiac:letrec-values-form? v)
+	    (and (andmap (lambda (vars v) (if (loop v extra-known-bindings)
+					      (begin
+						(when (and set-known?
+							   (= 1 (length vars)))
+						  (prephase:set-known-val! (car vars) v))
+						#t)
+					      #f))
+			 (zodiac:letrec-values-form-vars v)
+			 (zodiac:letrec-values-form-vals v))
+		 (loop (zodiac:letrec-values-form-body v)
+		       (append (apply append (zodiac:letrec-values-form-vars v))
+			       extra-known-bindings)))]
+	   [(zodiac:app? v)
+	    (let* ([fun (zodiac:app-fun v)]
+		   [primfun (analyze:prim-fun fun)]
+		   [args (zodiac:app-args v)]
+		   [args-ok? (lambda ()
+			       (andmap (lambda (v) (loop v extra-known-bindings)) 
+				       args))])
+	      (if primfun
+
+		  ;; Check whether the primitive can call any procedures:
+		  (and (not (memq primfun prims-that-induce-procedure-calls))
+		       (args-ok?))
+		  
+		  ;; Interesting special case: call a known function
+		  (and (loop fun extra-known-bindings)
+		       (args-ok?)
+		       (let ([simple-case-lambda?
+			      ;; We know nothing about the args; still valueable?
+			      ;; What if we're trying to check a recursive function?
+			      ;;  If we encounter a cycle, the body is valueable.
+			      (lambda (v)
+				(or (memq v known-lambdas)
+				    (andmap
+				     (lambda (body) (analyze:valueable? 
+						     body 
+						     extra-known-bindings
+						     extra-unknown-bindings
+						     (cons v known-lambdas)
+						     #f))
+				     (zodiac:case-lambda-form-bodies v))))])
+			 (cond
+			  [(zodiac:bound-varref? fun)
+			   (let ([v (extract-varref-known-val fun)])
+			     (and v 
+				  (cond
+				   [(zodiac:case-lambda-form? v)
+				    (simple-case-lambda? v)]
+				   [(zodiac:top-level-varref? v)
+				    ;; Could be a friendly primitive...
+				    (let ([primfun (analyze:prim-fun v)])
+				      (and primfun
+					   (not (memq primfun prims-that-induce-procedure-calls))))]
+				   [else #f])))]
+			  [(zodiac:case-lambda-form? fun) (simple-case-lambda? fun)]
+			  [else #f])))))]
+
+	   [else #f])))
+
+      ;; extract-ast-known-value tries to extract a useful value from a known-value AST
+      (define (extract-ast-known-value v)
+	(let extract-value ([v v])
+	  (cond
+	   [(zodiac:set!-form? v) (zodiac:make-special-constant 'void)]
+	   [(zodiac:begin-form? v) (extract-value (car (last-pair (zodiac:begin-form-bodies v))))]
+	   [(zodiac:begin0-form? v) (extract-value (car (zodiac:begin0-form-bodies v)))]
+	   [(zodiac:with-continuation-mark-form? v) (extract-value (zodiac:with-continuation-mark-form-body v))]
+	   [(zodiac:let-values-form? v) (extract-value (zodiac:let-values-form-body v))]
+	   [(zodiac:letrec-values-form? v) (extract-value (zodiac:letrec-values-form-body v))]
+	   [(zodiac:app? v)
+	    (let ([fun (analyze:prim-fun (zodiac:app-fun v))])
+	      (if fun
+		  (let ([args (map extract-value (zodiac:app-args v))])
+		    (case fun
+		      [(void) (zodiac:make-special-constant 'void)]
+		      [(char->integer) 
+		       (with-handlers ([void (lambda (x) v)])
+			 (let ([args (map (lambda (a) (syntax-e (zodiac:zodiac-stx (zodiac:quote-form-expr a)))) args)])
+			   (let ([new-v (apply (namespace-variable-value fun) args)])
+			     (zodiac:make-quote-form
+			      (zodiac:zodiac-stx v)
+			      (make-empty-box)
+			      (zodiac:structurize-syntax new-v v)))))]
+		      [else v]))
+		  v))]
+	   [(top-level-varref/bind-from-lift? v) (top-level-varref/bind-from-lift-lambda v)]
+	   [(zodiac:bound-varref? v) (extract-ast-known-value (extract-varref-known-val v))]
+	   [else v])))
+
+      ;; extract-varref-known-val works for bindings, too.
+      (define (extract-varref-known-val v)
+	(if (top-level-varref/bind-from-lift? v)
+	    (top-level-varref/bind-from-lift-lambda v)
+	    (let loop ([v v])
+	      (let* ([zbinding (if (zodiac:binding? v)
+				   v
+				   (zodiac:bound-varref-binding v))]
+		     [binding (get-annotation zbinding)]
+		     [result (lambda (v)
+			       (cond
+				[(top-level-varref/bind-from-lift? v)
+				 (extract-varref-known-val v)]
+				[(or (zodiac:bound-varref? v)
+				     (zodiac:binding? v))
+				 (loop v)]
+				[else v]))])
+		(and binding
+		     (cond
+		      [(binding? binding)
+		       (and (binding-known? binding)
+			    (result (binding-val binding)))]
+		      [else
+		       (result (prephase:known-val zbinding))]))))))
+
+      ;; analyze-knowns! sets the annotation for binding occurrences, setting information
+      ;; about known variables. Also sets the annotation for applications.
+      (define analyze-knowns!
+	(letrec ([analyze!
+		  (lambda (ast)
+		    (when (compiler:option:debug)
+		      (zodiac:print-start! (debug:get-port) ast)
+		      (newline (debug:get-port)))
+		    
+		    (cond
+		     
+		     ;;-----------------------------------------------------------------
+		     ;; CONSTANTS (A-VALUES)
+		     [(zodiac:quote-form? ast) ast]
+		     
+		     ;;-----------------------------------------------------------------
+		     ;; VARIABLE REFERENCES (A-VALUES)
+		     ;;
+		     [(zodiac:bound-varref? ast) ast]
+		     [(zodiac:top-level-varref? ast) ast]
+		     
+		     ;;--------------------------------------------------------------------
+		     ;; LAMBDA EXPRESSIONS
+		     ;;    analyze the bodies, and set binding info for the binding vars
+		     ;;
+		     [(zodiac:case-lambda-form? ast)
+		      (zodiac:set-case-lambda-form-bodies! 
+		       ast 
+		       (map
+			(lambda (args body)
+			  
+			  ;; annotate each binding with our information
+			  (for-each
+			   (lambda (bound) (set-annotation! bound (make-known-binding bound #f)))
+			   (zodiac:arglist-vars args))
+			  
+			  (analyze! body))
+			(zodiac:case-lambda-form-args ast)
+			(zodiac:case-lambda-form-bodies ast)))
+
+		      ast]
+		     
+		     ;;--------------------------------------------------------------
+		     ;; LET EXPRESSIONS
+		     ;;    Several values may be bound at once, in which case 'known'
+		     ;;    analysis is not performed.
+		     ;;
+		     ;;   Variables are assumed to be immutable and known, unless
+		     ;;    proven otherwise; we store this information
+		     ;;    in the binding structure in the compiler:bound structure.
+		     ;;
+		     [(zodiac:let-values-form? ast)
+		      (let* ([val (analyze! (car (zodiac:let-values-form-vals ast)))]
+			     [vars (car (zodiac:let-values-form-vars ast))]
+			     [bindings (map 
+					(lambda (var)
+					  (make-known-binding var (extract-ast-known-value val)))
+					vars)])
+			
+			(for-each set-annotation! vars bindings)
+			(set-car! (zodiac:let-values-form-vals ast) val)
+			
+			(if (= 1 (length vars))
+			    
+					; this is a one-value binding let
+			    (let* ([var (car vars)])
+			      
+			      (when (binding-mutable? (car bindings))
+				(set-binding-known?! (car bindings) #f)))
+			    
+					; this is a multiple (or zero) value binding let
+					; the values are unknown to simple analysis so skip
+					; that stuff;
+					; nothing is known
+			    (for-each (lambda (binding) (set-binding-known?! binding #f))
+				      bindings))
+
+					; analyze the body
+			(let ([body (analyze! (zodiac:let-values-form-body ast))])
+			  (zodiac:set-let-values-form-body! ast body)))
+		      
+		      ast]
+
+		     ;;-----------------------------------------------------------------
+		     ;; LETREC EXPRESSIONS
+		     ;;
+		     [(zodiac:letrec-values-form? ast)
+		      
+		      (let* ([varses (zodiac:letrec-values-form-vars ast)]
+			     [vals (zodiac:letrec-values-form-vals ast)])
+			
+					; Annotate each binding occurrence
+			(for-each
+			 (lambda (vars)
+			   (for-each (lambda (var)
+				       (let ([binding (make-unknown-binding var)])
+					 (set-annotation! var binding)))
+				     vars))
+			 varses)
+			
+					; Mark known letrec-bound vars
+			(let loop ([varses varses][vals vals][done-vars null])
+			  (unless (null? vals)
+			    (when (analyze:valueable? (car vals) done-vars (apply append varses) null #t)
+			      
+					; Continue known marking
+			      (let ([vars (car varses)])
+				(when (= 1 (length vars))
+				  (let ([binding (get-annotation (car vars))])
+				    (unless (binding-mutable? binding)
+				      (set-binding-known?! binding #t)
+				      (set-binding-val! binding (car vals)))))
+				(loop (cdr varses) (cdr vals)
+				      (append vars done-vars))))))
+
+			(zodiac:set-letrec-values-form-vals! ast (map analyze! vals))
+			
+			(zodiac:set-letrec-values-form-body!
+			 ast
+			 (analyze! (zodiac:letrec-values-form-body ast)))
+			
+			ast)]
+		     
+		     ;;-----------------------------------------------------
+		     ;; IF EXPRESSIONS
+		     ;;
+		     ;;  analyze the 3 branches.
+		     ;;
+		     [(zodiac:if-form? ast)
+		      (zodiac:set-if-form-test! ast (analyze! (zodiac:if-form-test ast)))
+		      (let ([then (analyze! (zodiac:if-form-then ast))]
+			    [else (analyze! (zodiac:if-form-else ast))])
+			(zodiac:set-if-form-then! ast then)
+			(zodiac:set-if-form-else! ast else)
+			
+			ast)]
+		     
+		     ;;--------------------------------------------------------
+		     ;; BEGIN EXPRESSIONS
+		     ;;
+		     ;; analyze the branches
+		     [(zodiac:begin-form? ast)
+		      
+		      (let loop ([bodies (zodiac:begin-form-bodies ast)])
+			(if (null? (cdr bodies))
+			    (let ([e (analyze! (car bodies))])
+			      (set-car! bodies e))
+			    (begin
+			      (set-car! bodies (analyze! (car bodies)))
+			      (loop (cdr bodies)))))
+		      
+		      ast]
+		     
+		     
+		     ;;--------------------------------------------------------
+		     ;; BEGIN0 EXPRESSIONS
+		     ;;
+		     ;; analyze the branches
+		     [(zodiac:begin0-form? ast)
+		      (zodiac:set-begin0-form-first! ast (analyze! (zodiac:begin0-form-first ast)))
+		      (zodiac:set-begin0-form-rest! ast (analyze! (zodiac:begin0-form-rest ast)))
+		      (let ([var (get-annotation ast)])
+			(set-annotation! var (make-begin0-binding var)))
+		      ast]
+		     
+		     ;;--------------------------------------------------------
+		     ;; SET! EXPRESSIONS
+		     ;;
+		     ;; we analyze the target, which will register it as being
+		     ;; mutable or used, as necessary.  Then we analyze the value.
+		     ;;
+		     [(zodiac:set!-form? ast)
+
+		      (let ([target (analyze! (zodiac:set!-form-var ast))])
+			(when (zodiac:bound-varref? target)
+			  (let ([binding (compiler:bound-varref->binding target)])
+			    (unless (binding-mutable? binding)
+			      (compiler:internal-error 
+			       target 
+			       (string-append
+				"analyze: variable found in set! but not"
+				" marked mutable by prephase!")))
+			    (when (binding-mutable? binding)
+			      (set-binding-known?! binding #f))))
+			(zodiac:set-set!-form-var! ast target)
+			(zodiac:set-set!-form-val! 
+			 ast 
+			 (analyze! (zodiac:set!-form-val ast))))
+		      
+		      ast]
+		     
+		     ;;---------------------------------------------------------
+		     ;; DEFINE EXPRESSIONS
+		     ;;
+		     [(zodiac:define-values-form? ast)
+		      (zodiac:set-define-values-form-vars!
+		       ast
+		       (map (lambda (v) (analyze! v))
+			    (zodiac:define-values-form-vars ast)))
+		      (zodiac:set-define-values-form-val! 
+		       ast
+		       (analyze! (zodiac:define-values-form-val ast)))
+		      ast]
+		     
+		     ;;----------------------------------------------------------
+		     ;; DEFINE-SYNTAX
+		     ;;
+		     [(zodiac:define-syntaxes-form? ast)
+		      (zodiac:set-define-syntaxes-form-expr!
+		       ast
+		       (analyze! (zodiac:define-syntaxes-form-expr ast)))
+		      ast]
+		     
+		     ;;-------------------------------------------------------------------
+		     ;; APPLICATIONS
+		     ;;  analyze all the parts, and note whether the rator is
+		     ;;  a primitive;
+		     ;;  if this is a call to a primitive, check the arity.
+		     ;;
+		     [(zodiac:app? ast)
+		      
+		      (let* ([fun (analyze! (zodiac:app-fun ast))]
+			     [args (map (lambda (arg) (analyze! arg))
+					(zodiac:app-args ast))]
+			     [primfun (analyze:prim-fun fun)]
+			     [primfun-arity-ok?
+			      ;; check the arity for primitive apps -- just an error check
+			      (and primfun
+				   (let* ([num-args (length args)]
+					  [arity-ok? (procedure-arity-includes?
+						      (namespace-variable-value primfun)
+						      num-args)])
+				     (unless arity-ok?
+				       ((if (compiler:option:stupid)
+					    compiler:warning
+					    compiler:error)
+					ast
+					(format "~a got ~a argument~a"
+						(zodiac:varref-var fun)
+						num-args
+						(if (= num-args 1)
+						    ""
+						    "s"))))
+				     arity-ok?))]
+			     [prim? (and primfun primfun-arity-ok?)])
+			
+					; for all functions, do this stuff
+			(zodiac:set-app-fun! ast fun)
+			(zodiac:set-app-args! ast args)
+			(set-annotation! 
+			 ast 
+			 (make-app #f prim? (and prim? primfun)))
+			
+			ast)]
+		     
+		     ;;-------------------------------------------------------------------
+		     ;; WITH-CONTINUATION-MARK
+		     ;;
+		     ;; analyze the key, val, and body, and the binding in the annotation
+		     ;;
+		     [(zodiac:with-continuation-mark-form? ast)
+		      
+		      (zodiac:set-with-continuation-mark-form-key!
+		       ast
+		       (analyze! (zodiac:with-continuation-mark-form-key ast)))
+		      
+		      (zodiac:set-with-continuation-mark-form-val!
+		       ast
+		       (analyze! (zodiac:with-continuation-mark-form-val ast)))
+		      
+		      (zodiac:set-with-continuation-mark-form-body!
+		       ast
+		       (analyze! (zodiac:with-continuation-mark-form-body ast)))
+
+		      (let ([var (get-annotation ast)])
+			(set-annotation! var (make-wcm-binding var)))
+		      
+		      ast]
+
+		     ;;-----------------------------------------------------------------
+		     ;; QUOTE-SYNTAX
+		     ;;
+		     ;; Construct constant.
+		     ;;
+		     [(zodiac:quote-syntax-form? ast)
+		      ast]
+		     
+		     ;;-----------------------------------------------------------
+		     ;; MODULE
+		     ;;
+		     [(zodiac:module-form? ast)
+
+		      (zodiac:set-module-form-body!
+		       ast
+		       (analyze! (zodiac:module-form-body ast)))
+
+		      ast]
+		     
+
+		     [else (compiler:internal-error
+			    ast
+			    (format "unsupported syntactic form (~a)"
+				    (if (struct? ast)
+					(vector-ref (struct->vector ast) 0)
+					ast)))]))])
+	  
+	  (lambda (ast)
+	    (analyze! ast)))))))
diff --git a/collects/compiler/private/library.ss b/collects/compiler/private/library.ss
new file mode 100644
index 0000000000..492fe2b653
--- /dev/null
+++ b/collects/compiler/private/library.ss
@@ -0,0 +1,335 @@
+;; Library of functions for the compiler
+;; (c) 1996-7 Sebastian Good
+;; (c) 1997-8 PLT, Rice University
+
+(module library mzscheme
+  (require (lib "unitsig.ss")
+	  (lib "list.ss")
+	  (lib "etc.ss"))
+
+  (require (lib "zodiac-sig.ss" "syntax"))
+
+  (require "sig.ss")
+
+  (provide library@)
+  (define library@
+    (unit/sig compiler:library^
+      (import (zodiac : zodiac^))
+
+      (define logical-inverse
+	(lambda (fun)
+	  (lambda (obj)
+	    (not (fun obj)))))
+
+      (define one-of
+	(case-lambda
+	 [(p1 p2) (lambda (obj)
+		    (or (p1 obj) (p2 obj)))]
+	 [preds 
+	  (lambda (obj)
+	    (ormap (lambda (p) (p obj)) preds))]))
+
+      (define all-of
+	(lambda preds
+	  (lambda (obj)
+	    (andmap (lambda (p) (p obj)) preds))))
+
+      (define none-of
+	(lambda preds
+	  (logical-inverse (apply one-of preds))))
+
+      (define vector-map ; modified by PAS, but looks to be unused
+	(lambda (f vec)
+	  (let* ([vec-len (vector-length vec)]
+		 [x (make-vector vec-len)])
+	    (let loop ((i 0))
+	      (if (>= i vec-len)
+		  x
+		  (begin (vector-set! x i (f (vector-ref vec i)))
+			 (loop (add1 i))))))))
+
+      (define improper-map
+	(lambda (f ilist)
+	  (cond 
+	   ((pair? ilist) (cons (f (car ilist)) (improper-map f (cdr ilist))))
+	   ((null? ilist) null)
+	   (else (f ilist)))))
+
+      (define begin-map!
+	(lambda (non-tail tail list)
+	  (if (null? list)
+	      null
+	      (begin
+		(let loop ([list list] [next (cdr list)])
+		  (let ([tail? (null? next)])
+		    (set-car! list ((if tail? tail non-tail) (car list)))
+		    (unless tail? (loop next (cdr next)))))
+		list))))
+
+      (define begin-map
+	(lambda (non-tail tail list)
+	  (if (null? list)
+	      null
+	      (let ([tail? (null? (cdr list))])
+		(cons ((if tail? tail non-tail) (car list)) 
+		      (begin-map non-tail tail (cdr list)))))))
+
+      (define map!
+	(lambda (fun list)
+	  (let loop ([l list])
+	    (if (null? l)
+		list
+		(begin (set-car! l (fun (car l))) (loop (cdr l)))))))
+
+      (define list-index
+	(lambda (obj list)
+	  (cond
+	   [(null? list) (error 'list-index "~a not found int ~a" obj list)]
+	   [(eq? obj (car list)) 0]
+	   [else (add1 (list-index obj (cdr list)))])))
+
+      (define list-last
+	(lambda (list)
+	  (if (null? list)
+	      (error 'list-last "~a is empty!" list)
+	      (let loop ([a list] [b (cdr list)])
+		(if (null? b)
+		    (car a)
+		    (loop b (cdr b)))))))
+
+      ;; Set operations
+
+      ;; -----> Begin bit-vector implementation <-----
+      #|
+      (define set-next-index 0)
+      (define index-vector (make-vector 100))
+      (define singleton-vector (make-vector 100))
+      (define index-table (make-hash-table))
+
+      (define (index->object i) (vector-ref index-vector i))
+      (define (object->index o) 
+	(let ([i (hash-table-get index-table o (lambda () #f))])
+	  (or i
+	      (let ([i set-next-index])
+		(set! set-next-index (add1 set-next-index))
+		(unless (< i (vector-length index-vector))
+		  (printf "grow ~a~n" i)
+		  (let* ([old-iv index-vector]
+			 [old-sv singleton-vector]
+			 [old-size (vector-length index-vector)]
+			 [new-size (* 2 old-size)])
+		    (set! index-vector (make-vector new-size))
+		    (set! singleton-vector (make-vector new-size))
+		    (let loop ([n 0])
+		      (unless (= n old-size)
+			(vector-set! index-vector n (vector-ref old-iv n))
+			(vector-set! singleton-vector n (vector-ref old-sv n))
+			(loop (add1 n))))))
+		(vector-set! index-vector i o)
+		(vector-set! singleton-vector i (arithmetic-shift 1 i))
+		(hash-table-put! index-table o i)
+		i))))
+      (define (object->singleton o) 
+	(let ([i (object->index o)])
+	  (vector-ref singleton-vector i)))
+      (define (set->objects s)
+	(letrec ([dloop ; double-search
+		  (lambda (s i n d)
+		    (if (zero? s)
+			null
+			(if (positive? (bitwise-and s i))
+			    (if (= n 1)
+				(cons (index->object d)
+				      (dloop (arithmetic-shift s -1) 1 1 (add1 d)))		
+				(let ([n/2 (quotient n 2)])
+					; It's in d+n/2...d+n
+				  (bloop (arithmetic-shift s (- n/2)) (arithmetic-shift i (- n/2)) n/2 (+ d n/2))))
+			    (dloop s (bitwise-ior i (arithmetic-shift i n)) (* n 2) d))))]
+		 [bloop 
+		  (lambda (s i n d)
+		    (if (= n 1)
+			(cons (index->object d)
+			      (dloop (arithmetic-shift s -1) 1 1 (add1 d)))		
+			(let* ([n/2 (quotient n 2)]
+			       [low_i (arithmetic-shift i (- n/2))])
+			  (if (positive? (bitwise-and s low_i))
+			      (bloop s low_i n/2 d)
+			      (bloop (arithmetic-shift s (- n/2)) low_i n/2 (+ d n/2))))))])
+	  (dloop s 1 1 0)))
+
+      (define (set->list s) (reverse! (set->objects s))) ; something relies on the order
+      (define empty-set 0)
+      (define make-singleton-set object->singleton)
+      (define (list->set l)
+	(let loop ([l l][s 0])
+	  (if (null? l)
+	      s
+	      (loop (cdr l) (set-union s (object->singleton (car l)))))))
+      (define (set-memq? o s)
+	(positive? (bitwise-and s (object->singleton o))))
+
+      (define set-union bitwise-ior)
+      (define set-intersect bitwise-and)
+      (define (set-union-singleton s o) (set-union s (object->singleton o)))
+      (define (set-minus s1 s2) (bitwise-and s1 (bitwise-not s2)))
+      (define (set-subset? s1 s2) (zero? (bitwise-xor s1 (bitwise-and s1 s2))))
+      (define set-empty? zero?)
+      (define set? integer?) ; cheat
+      |#
+      ;; -----> End bit-vector implementation <------
+
+      ;; -----> Begin list implementation <------
+
+      (define-struct set (%m))
+      (define empty-set (make-set null))
+      (define make-singleton-set (compose make-set list))
+      (define list->set
+	(lambda (l)
+					; (unless (list? l) (error 'list->set "~a not a list" l))
+	  (make-set l)))
+      (define set->list set-%m)
+      (define set-memq?
+	(lambda (obj set)
+	  (memq obj (set->list set))))
+      (define set-empty? (compose null? set->list))
+
+      (define set-union ; O(|a|*|b|)
+	(lambda (a b)
+	  (let union ([a (set->list a)]
+		      [b (set->list b)])
+	    (cond
+	     [(null? a) (list->set b)]
+	     [(memq (car a) b) (union (cdr a) b)]
+	     [else (union (cdr a) (cons (car a) b))]))))
+
+      (define set-union-singleton
+	(lambda (set obj)
+	  (when (void? obj)
+	    (error 'stop))
+	  (if (memq obj (set->list set))
+	      set
+	      (list->set (cons obj (set->list set))))))
+
+      (define set-minus ; O(|a|*|b|)
+	(lambda (a b)
+	  (let minus ([a (set->list a)]
+		      [b (set->list b)]
+		      [acc null])
+	    (cond
+	     [(null? a) (list->set acc)]
+	     [(memq (car a) b) (minus (cdr a) b acc)]
+	     [else (minus (cdr a) b (cons (car a) acc))]))))
+
+      (define set-intersect ; O(|a|*|b|)
+	(lambda (a b)
+	  (if (or (set-empty? a)
+		  (set-empty? b))
+	      empty-set
+	      (let intersect ([a (set->list a)]
+			      [acc null])
+		(cond
+		 [(null? a) (list->set acc)]
+		 [(set-memq? (car a) b) (intersect (cdr a) (cons (car a) acc))]
+		 [else (intersect (cdr a) acc)])))))
+
+      (define (set-subset? s1 s2)
+	(if (eq? s1 s2)
+	    #t
+	    (let ([l1 (set->list s1)]
+		  [l2 (set->list s2)])
+	      (andmap (lambda (elt) (memq elt l2)) l1))))
+
+      ;; -----> End list implementation <-----
+
+      (define set-remove 
+	(lambda (e s)
+	  (set-minus s (make-singleton-set e))))
+
+      (define improper-list->set
+	(lambda (l)
+	  (let loop ([l l][acc null])
+	    (cond
+	     [(null? l) (list->set acc)]
+	     [(pair? l) (loop (cdr l) (cons (car l) acc))]
+	     [else (list->set (cons l acc))]))))
+
+      (define set-find
+	(lambda (p s)
+	  (let ([lst (set->list s)])
+	    (let loop ([l lst])
+	      (cond [(null? l) #f]
+		    [(p (car l)) (car l)]
+		    [else (loop (cdr l))])))))
+
+      (define set-map
+	(lambda (f s)
+	  (list->set (map f (set->list s)))))
+
+      (define set-filter
+	(lambda (f s)
+	  (list->set (filter f (set->list s)))))
+
+      (define symbol-append
+	(lambda s
+	  (let loop ([str ""] [s s])
+	    (if (null? s)
+		(string->symbol str)
+		(loop (string-append str (symbol->string (car s))) (cdr s))))))
+
+      (define (remove-duplicates elts)
+	(if (null? elts)
+	    '()
+	    (if (memq (car elts) (cdr elts))
+		(remove-duplicates (cdr elts))
+		(cons (car elts) (remove-duplicates (cdr elts))))))
+
+					; end binder set ops
+
+      (define compiler:formals->arity
+	(lambda (f)
+	  (let ([L (length (zodiac:arglist-vars f))])
+	    (cond
+	     [(zodiac:sym-arglist? f) (values 0 -1)]
+	     [(zodiac:list-arglist? f) (values L L)]
+	     [(zodiac:ilist-arglist? f) (values (- L 1) -1)]))))
+
+      (define compiler:formals->arity*
+	(lambda (fs)
+	  (cond
+	   [(null? fs) (values -1 0)]
+	   [(null? (cdr fs)) (compiler:formals->arity (car fs))]
+	   [else (let-values ([(a- a+) (compiler:formals->arity (car fs))]
+			      [(b- b+) (compiler:formals->arity* (cdr fs))])
+		   (values (min a- b-)
+			   (if (or (negative? b+) (negative? a+))
+			       -1
+			       (max a+ b+))))])))
+      
+      (define compiler:gensym gensym)
+      (define compiler:label-number 0)
+      (define (compiler:reset-label-number!)
+	(set! compiler:label-number 0))
+      (define compiler:genlabel
+	(lambda ()
+	  (begin0 compiler:label-number
+		  (set! compiler:label-number (add1 compiler:label-number)))))
+      (define (compiler:get-label-number) compiler:label-number)
+
+      (define re:bad-char (regexp "[][#+-.*/<=>!?:$%_&~^@;^(){}|\\,~\"`' \000-\040]"))
+      (define re:starts-with-number (regexp "^[0-9]"))
+
+      (define (compiler:clean-string s)
+	(let ([s (regexp-replace* re:bad-char s "_")])
+	  (if (regexp-match re:starts-with-number s)
+	      (string-append "_" s)
+	      s)))
+
+      (define (protect-comment s)
+	(string-append
+	 (regexp-replace* "[*]/"
+			  (regexp-replace* "/[*]" s "-")
+			  "-")
+	 " "))
+
+      (define (global-defined-value* v)
+	(and v (namespace-variable-value v))))))
diff --git a/collects/compiler/private/lift.ss b/collects/compiler/private/lift.ss
new file mode 100644
index 0000000000..1814f5333e
--- /dev/null
+++ b/collects/compiler/private/lift.ss
@@ -0,0 +1,607 @@
+;; A kind of lambda-lifting
+;; (c) 1997-2001 PLT
+
+;; Finds liftable procedures, sets their `liftable' field, and
+;;  replaces lexical variables for liftable procedures with
+;;  globals variables. This transformation can be applied
+;;  anytime (and multiple times) after analyze.ss and before
+;;  closure.ss.
+;; Liftable lambdas are procedures whose free variables include only
+;;  lexical variables bound to known-lifted procedures, primitive
+;;  globals, and statics. (No namespace-sentsitive globals and no
+;;  per-load statics.) Per-load liftable lambdas are lifted to per-load
+;;  allocation; per-load liftable lambdas can have other per-load
+;;  liftable lambdas and values in their closure.
+
+;; TODO: get rid of let{rec}-bound variables that are useless
+;;  because they are bound to lifted procedures.
+
+;;; Annotatitons: ----------------------------------------------
+;;    lambda - sets `liftable' in the procedure-code structure
+;;; ------------------------------------------------------------
+
+(module lift mzscheme
+  (require (lib "unitsig.ss")
+	  (lib "list.ss")
+	  (lib "etc.ss"))
+
+  (require (lib "zodiac-sig.ss" "syntax"))
+
+  (require "sig.ss")
+  (require "../sig.ss")
+
+  (provide lift@)
+  (define lift@
+    (unit/sig compiler:lift^
+      (import (compiler:option : compiler:option^)
+	      compiler:library^
+	      compiler:cstructs^
+	      (zodiac : zodiac^)
+	      compiler:zlayer^
+	      compiler:known^
+	      compiler:top-level^
+	      compiler:analyze^
+	      compiler:const^
+	      compiler:closure^
+	      compiler:driver^)
+
+      (define lifting-allowed? #t)
+      (define mutual-lifting-allowed? #t)
+      (define per-load-lifting-only? #f)
+
+      (define procedures null)
+
+      (define single-module-mode? #f)
+      (define (set-single-module-mode! v)
+	(set! single-module-mode? v))
+
+      ;; find-all-procedures!
+      (define find-all-procedures!
+	(letrec ([find!
+		  (lambda (ast)
+		    (cond
+		     ;;-----------------------------------------------------------------
+		     ;; CONSTANTS (A-VALUES)
+		     [(zodiac:quote-form? ast) (void)]
+		     
+		     ;;-----------------------------------------------------------------
+		     ;; VARIABLE REFERENCES (A-VALUES)
+		     ;;
+		     [(zodiac:bound-varref? ast) (void)]
+
+		     [(zodiac:top-level-varref? ast) (void)]
+		     
+		     ;;--------------------------------------------------------------------
+		     ;; LAMBDA EXPRESSIONS
+		     ;;
+		     [(zodiac:case-lambda-form? ast)
+		      (set! procedures (cons (cons ast (varref:current-invoke-module )) procedures))
+		      (for-each find! (zodiac:case-lambda-form-bodies ast))]
+		     
+		     ;;--------------------------------------------------------------
+		     ;; LET EXPRESSIONS
+		     [(zodiac:let-values-form? ast)
+		      (find! (car (zodiac:let-values-form-vals ast)))
+		      (find! (zodiac:let-values-form-body ast))]
+
+		     ;;-----------------------------------------------------------------
+		     ;; LETREC EXPRESSIONS
+		     ;;
+		     [(zodiac:letrec-values-form? ast)
+		      (for-each find! (zodiac:letrec-values-form-vals ast))
+		      (find! (zodiac:letrec-values-form-body ast))]
+		     
+		     ;;-----------------------------------------------------
+		     ;; IF EXPRESSIONS
+		     ;;
+		     ;;  analyze the 3 branches.
+		     ;;
+		     [(zodiac:if-form? ast)
+		      (find! (zodiac:if-form-test ast))
+		      (find! (zodiac:if-form-then ast))
+		      (find! (zodiac:if-form-else ast))]
+
+		     ;;--------------------------------------------------------
+		     ;; BEGIN EXPRESSIONS
+		     ;;
+		     ;; analyze the branches
+		     [(zodiac:begin-form? ast)
+		      (for-each find! (zodiac:begin-form-bodies ast))]
+		     
+		     ;;--------------------------------------------------------
+		     ;; BEGIN0 EXPRESSIONS
+		     ;;
+		     ;; analyze the branches
+		     [(zodiac:begin0-form? ast)
+		      (find! (zodiac:begin0-form-first ast))
+		      (find! (zodiac:begin0-form-rest ast))]
+		     
+		     ;;--------------------------------------------------------
+		     ;; SET! EXPRESSIONS
+		     ;;
+		     ;; we analyze the target, which will register it as being
+		     ;; mutable or used, as necessary.  Then we analyze the value.
+		     ;;
+		     [(zodiac:set!-form? ast)
+		      (find! (zodiac:set!-form-val ast))]
+		     
+		     ;;---------------------------------------------------------
+		     ;; DEFINE EXPRESSIONS
+		     ;;
+		     [(zodiac:define-values-form? ast)
+		      (find! (zodiac:define-values-form-val ast))]
+		     
+		     ;;---------------------------------------------------------
+		     ;; DEFINE-SYNTAXES
+		     ;;
+		     [(zodiac:define-syntaxes-form? ast)
+		      (find! (zodiac:define-syntaxes-form-expr ast))]
+		     
+		     ;;-------------------------------------------------------------------
+		     ;; APPLICATIONS
+		     ;;  analyze all the parts, and note whether the rator is
+		     ;;  a primitive;
+		     ;;  if this is a call to a primitive, check the arity.
+		     ;;
+		     [(zodiac:app? ast)
+		      (find! (zodiac:app-fun ast))
+		      (for-each find! (zodiac:app-args ast))]
+		     
+		     ;;-------------------------------------------------------------------
+		     ;; WITH-CONTINUATION-MARK
+		     ;;
+		     ;; analyze the key, val, and body
+		     ;;
+		     [(zodiac:with-continuation-mark-form? ast)
+		      (find! (zodiac:with-continuation-mark-form-key ast))
+		      (find! (zodiac:with-continuation-mark-form-val ast))
+		      (find! (zodiac:with-continuation-mark-form-body ast))]
+
+		     ;;-----------------------------------------------------------
+		     ;; MODULE
+		     ;;
+		     [(zodiac:module-form? ast)
+		      (parameterize ([varref:current-invoke-module 
+				      (module-info-invoke (get-annotation ast))])
+			(find! (zodiac:module-form-body ast)))]
+		     
+		     [else (compiler:internal-error
+			    ast
+			    (format "unsupported syntactic form (~a)"
+				    (if (struct? ast)
+					(vector-ref (struct->vector ast) 0)
+					ast)))]))])
+	  
+	  (lambda (ast)
+	    (set! procedures null)
+	    (find! ast))))
+
+      ;; Recursively determines the `liftable' field in the procedure
+      ;; record. If a cycle is encountered, return 'cycle or 'pls-cycle
+      ;; (the latter of any part of the cycle had "globals" in its
+      ;; "closure")
+      (define (get-liftable! lambda)
+	(let ([code (get-annotation lambda)])
+	  (if (eq? (procedure-code-liftable code) 'unknown-liftable)
+	      (if (and lifting-allowed?
+		       (or mutual-lifting-allowed? 
+			   (set-empty? (code-free-vars code)))
+		       (or single-module-mode?
+			   (andmap (case-lambda 
+				    [(var)
+				     (or (not (mod-glob? var))
+					 (let ([modname (mod-glob-modname var)])
+					   (if (eq? modname '#%kernel)
+					       #t
+					       (not modname))))])
+				   (set->list (code-global-vars code)))))
+		  ;; Liftable only if there are no free (non-pls) global vars
+		  (begin
+		    ;; Mark this one in case we encounter a cycle:
+		    (set-procedure-code-liftable! code 'cycle)
+		    ;; Check each free variable
+		    (let ([r (let loop ([l (set->list (code-free-vars code))]
+					[pls? (or per-load-lifting-only?
+						  (not (set-empty? (code-global-vars code))))]
+					[cycle? #f])
+			       (if (null? l)
+				   ;; It's liftable, assuming any cycles are resolved
+				   (cond
+				    [(and pls? cycle?) 'pls-cycle]
+				    [cycle? 'cycle]
+				    [pls? 'pls]
+				    [else 'static])
+				   
+				   ;; Check the free variable - references a liftable proc?
+				   (let ([v (extract-ast-known-value (extract-varref-known-val (car l)))])
+				     (if (zodiac:case-lambda-form? v)
+					 (let ([vl (let ([l (get-liftable! v)])
+						     (cond
+						      [(top-level-varref/bind-from-lift? l)
+						       ;; lifted in a previous phase
+						       (if (top-level-varref/bind-from-lift-pls? l)
+							   'pls
+							   'static)]
+						      [(pair? l)
+						       ;; lifted already in this phase
+						       (if (top-level-varref/bind-from-lift-pls? (car l))
+							   'pls
+							   'static)]
+						      [else l]))])
+					   (if vl
+					       (loop (cdr l)
+						     (or pls? (eq? vl 'pls) (eq? vl 'pls-cycle))
+						     (or cycle? (eq? vl 'cycle) (eq? vl 'pls-cycle)))
+					       #f))
+					 #f))))])
+		      (cond
+		       [(not r) (set-procedure-code-liftable! code #f) 
+			#f]
+		       [(or (eq? r 'cycle) (eq? r 'pls-cycle))
+			(set-procedure-code-liftable! code 'unknown-liftable) 
+			r]
+		       [(eq? r 'pls) (set-procedure-code-liftable! code 'pls) 
+			'pls]
+		       [else (set-procedure-code-liftable! code 'static) 
+			     'static])))
+		  (begin
+		    (set-procedure-code-liftable! code #f)
+		    #f))
+	      (procedure-code-liftable code))))
+
+      (define (set-liftable! lambda)
+	(unless (top-level-varref/bind-from-lift? (procedure-code-liftable (get-annotation lambda)))
+	  (let ([v (get-liftable! lambda)])
+	    (when v
+	      (let ([pls? (or (eq? v 'pls) (eq? v 'pls-cycle))])
+		(when (compiler:option:verbose)
+		  (compiler:warning lambda (format "found static procedure~a"
+						   (if pls? " (per-load)" ""))))
+		(compiler:add-lifted-lambda! lambda pls?))))))
+
+      ;; lift-lambdas! uses the `liftable' procedure annotation with known-value
+      ;;  analysis to replace lexical variables referencing known liftable
+      ;;  procedures with top-level-varrefs referencing the lifted
+      ;;  procedure
+      ;; Since per-load lifting rarranges global variable sets, we
+      ;;  recompute them.
+      ;; Returns (cons ast global-var-set)
+      (define lift-lambdas!
+	(letrec ([lift!
+		  (lambda (ast code)
+		    (when (compiler:option:debug)
+		      (zodiac:print-start! (debug:get-port) ast)
+		      (newline (debug:get-port)))
+		    
+		    (cond
+		     
+		     ;;-----------------------------------------------------------------
+		     ;; CONSTANTS (A-VALUES)
+		     [(zodiac:quote-form? ast) ast]
+		     
+		     ;;-----------------------------------------------------------------
+		     ;; VARIABLE REFERENCES (A-VALUES)
+		     ;;
+		     [(zodiac:bound-varref? ast)
+		      (let ([v (extract-ast-known-value (extract-varref-known-val ast))])
+						
+			(if (zodiac:case-lambda-form? v)
+
+			    (let ([lifted (let ([l (procedure-code-liftable (get-annotation v))])
+					    (if (pair? l) (car l) l))])
+			      (if lifted
+				  
+				  ;; The procedure was lifted
+				  (begin
+				    (when code
+				      (remove-code-free-vars! code (make-singleton-set 
+								    (zodiac:bound-varref-binding ast))))
+				    (when (top-level-varref/bind-from-lift-pls? lifted)
+				      (add-global! (or (varref:current-invoke-module)
+						       const:the-per-load-statics-table)))
+				    lifted)
+				  
+				  ;; No change
+				  ast))
+
+			    ;; No change
+			    ast))]
+		     
+		     [(zodiac:top-level-varref? ast)
+
+		      (cond
+		       [(varref:has-attribute? ast varref:primitive)
+			(void)]
+		       [(varref:has-attribute? ast varref:per-load-static)
+			(add-global! const:the-per-load-statics-table)]
+		       [(varref:has-attribute? ast varref:per-invoke-static)
+			(add-global! (varref:invoke-module ast))]
+		       [(varref:has-attribute? ast varref:static)
+			(void)]
+		       [else (add-global! (compiler:add-global-varref! ast))])
+		      
+		      ast]
+		     
+		     ;;--------------------------------------------------------------------
+		     ;; LAMBDA EXPRESSIONS
+		     ;;    analyze the bodies, and set binding info for the binding vars
+		     ;;
+		     [(zodiac:case-lambda-form? ast)
+		      (let ([code (get-annotation ast)]
+			    [save-globals globals])
+			;; We're recomputing globals...
+			(set-code-global-vars! code empty-set)
+
+			(zodiac:set-case-lambda-form-bodies! 
+			 ast 
+			 (map (lambda (b ccode)
+				(set! globals empty-set)
+				;; Analyze case
+				(let ([b (lift! b ccode)])
+				  ;; Set and merge globals
+				  (set-code-global-vars! ccode globals)
+				  (set-code-global-vars! code
+							 (set-union globals
+								    (code-global-vars code)))
+
+				  b))
+			      (zodiac:case-lambda-form-bodies ast)
+			      (procedure-code-case-codes code)))
+			
+			;; If it being lifted ON THIS PASS, the value of `lifted' will be a list;
+			;;  in that case, return the new static varref
+			(let ([lifted (procedure-code-liftable code)])
+			  (if (or (not lifted) (top-level-varref/bind-from-lift? lifted))
+			      
+			      ;; Not lifted (or not on this pass)
+			      (begin
+				(set! globals (set-union save-globals (code-global-vars code)))
+				ast)
+			      
+			      ;; Lifting on this pass
+			      (let ([lifted (car lifted)])
+				(set-procedure-code-liftable! code lifted)
+				
+				(if (top-level-varref/bind-from-lift-pls? lifted)
+				    (set! globals (set-union-singleton 
+						   save-globals
+						   (or (varref:current-invoke-module)
+						       const:the-per-load-statics-table)))
+				    (set! globals save-globals))
+				
+				lifted))))]
+
+		     ;;--------------------------------------------------------------
+		     ;; LET EXPRESSIONS
+		     ;;
+		     [(zodiac:let-values-form? ast)
+		      (let* ([val (lift! (car (zodiac:let-values-form-vals ast)) code)])
+			(set-car! (zodiac:let-values-form-vals ast) val)
+			
+			;; lift in body expressions
+			(let ([body (lift! (zodiac:let-values-form-body ast) code)])
+
+			  (if (and (= 1 (length (car (zodiac:let-values-form-vars ast))))
+				   (top-level-varref/bind-from-lift? val)
+				   (not (binding-mutable? (get-annotation (caar (zodiac:let-values-form-vars ast))))))
+
+			      ;; Let binding value is a lifted procedure, drop the variable
+			      (let ([var (caar (zodiac:let-values-form-vars ast))])
+				(remove-local-var! code var)
+				body)
+
+			      (begin
+				(zodiac:set-let-values-form-body! ast body)
+				ast))))]
+
+		     ;;-----------------------------------------------------------------
+		     ;; LETREC EXPRESSIONS
+		     ;;
+		     [(zodiac:letrec-values-form? ast)
+		      
+		      (let* ([varses (zodiac:letrec-values-form-vars ast)]
+			     [vals (zodiac:letrec-values-form-vals ast)])
+			
+			(zodiac:set-letrec-values-form-vals! 
+			 ast 
+			 (map (lambda (val) (lift! val code)) vals))
+			
+			(zodiac:set-letrec-values-form-body!
+			 ast
+			 (lift! (zodiac:letrec-values-form-body ast) code))
+			
+			(let loop ([varses varses][vals (zodiac:letrec-values-form-vals ast)]
+				   [vss-accum null][vs-accum null])
+			  (if (null? varses)
+
+			      (begin
+				(zodiac:set-letrec-values-form-vars! ast (reverse! vss-accum))
+				(zodiac:set-letrec-values-form-vals! ast (reverse! vs-accum)))
+
+			      (let ([vars (car varses)]
+				    [val (car vals)])
+				(if (and (= 1 (length vars))
+					 (top-level-varref/bind-from-lift? val))
+				    ;; Let binding value is a lifted procedure, drop the variable
+				    (begin
+				      (remove-local-var! code (car vars))
+				      (loop (cdr varses) (cdr vals) vss-accum vs-accum))
+
+				    ;; Normal binding
+				    (loop (cdr varses) (cdr vals) (cons vars vss-accum) (cons val vs-accum))))))
+
+			(if (null? (zodiac:letrec-values-form-vars ast))
+
+			    ;; All binding values were lifted; return the body
+			    (zodiac:letrec-values-form-body ast)
+			    
+			    ast))]
+		     
+		     ;;-----------------------------------------------------
+		     ;; IF EXPRESSIONS
+		     ;;
+		     ;;  analyze the 3 branches.
+		     ;;
+		     [(zodiac:if-form? ast)
+		      (zodiac:set-if-form-test! ast (lift! (zodiac:if-form-test ast) code))
+		      (let ([then (lift! (zodiac:if-form-then ast) code)]
+			    [else (lift! (zodiac:if-form-else ast) code)])
+			(zodiac:set-if-form-then! ast then)
+			(zodiac:set-if-form-else! ast else)
+			
+			ast)]
+		     
+		     ;;--------------------------------------------------------
+		     ;; BEGIN EXPRESSIONS
+		     ;;
+		     [(zodiac:begin-form? ast)
+		      
+		      (zodiac:set-begin-form-bodies!
+		       ast
+		       (map (lambda (b) (lift! b code))
+			    (zodiac:begin-form-bodies ast)))
+		      
+		      ast]
+		     
+		     
+		     ;;--------------------------------------------------------
+		     ;; BEGIN0 EXPRESSIONS
+		     ;;
+		     ;; analyze the branches
+		     [(zodiac:begin0-form? ast)
+		      (zodiac:set-begin0-form-first! ast (lift! (zodiac:begin0-form-first ast) code))
+		      (zodiac:set-begin0-form-rest! ast (lift! (zodiac:begin0-form-rest ast) code))
+
+		      ast]
+		     
+		     ;;--------------------------------------------------------
+		     ;; SET! EXPRESSIONS
+		     ;;
+		     ;;
+		     [(zodiac:set!-form? ast)
+
+		      ;; Possibly a top-level-varref; put it in the global-var set
+		      (lift! (zodiac:set!-form-var ast) code)
+
+		      (zodiac:set-set!-form-val! 
+		       ast 
+		       (lift! (zodiac:set!-form-val ast) code))
+		      
+		      ast]
+		     
+		     ;;---------------------------------------------------------
+		     ;; DEFINE EXPRESSIONS
+		     ;;
+		     [(zodiac:define-values-form? ast)
+		      
+		      ;; Top-level-varrefs; put them in the global-var set
+		      (for-each (lambda (v) (lift! v code)) (zodiac:define-values-form-vars ast))
+
+		      (zodiac:set-define-values-form-val! 
+		       ast
+		       (lift! (zodiac:define-values-form-val ast) code))
+		      
+		      ast]
+		     
+		     ;;---------------------------------------------------------
+		     ;; DEFINE-SYNTAXES
+		     ;;
+		     [(zodiac:define-syntaxes-form? ast)
+		      
+		      (zodiac:set-define-syntaxes-form-expr!
+		       ast
+		       (lift! (zodiac:define-syntaxes-form-expr ast) code))
+		      
+		      ast]
+		     
+		     ;;-------------------------------------------------------------------
+		     ;; APPLICATIONS
+		     ;;  analyze all the parts, and note whether the rator is
+		     ;;  a primitive;
+		     ;;  if this is a call to a primitive, check the arity.
+		     ;;
+		     [(zodiac:app? ast)
+		      
+		      (let* ([fun (lift! (zodiac:app-fun ast) code)]
+			     [args (map (lambda (arg) (lift! arg code))
+					(zodiac:app-args ast))])
+			(zodiac:set-app-fun! ast fun)
+			(zodiac:set-app-args! ast args))
+
+		      ast]
+		     
+		     ;;-------------------------------------------------------------------
+		     ;; WITH-CONTINUATION-MARK
+		     ;;
+		     ;; analyze the key, val, and body
+		     ;;
+		     [(zodiac:with-continuation-mark-form? ast)
+
+		      (zodiac:set-with-continuation-mark-form-key!
+		       ast
+		       (lift! (zodiac:with-continuation-mark-form-key ast) code))
+		      
+		      (zodiac:set-with-continuation-mark-form-val!
+		       ast
+		       (lift! (zodiac:with-continuation-mark-form-val ast) code))
+		      
+		      (zodiac:set-with-continuation-mark-form-body!
+		       ast
+		       (lift! (zodiac:with-continuation-mark-form-body ast) code))
+
+		      ast]
+
+		     ;;-----------------------------------------------------------
+		     ;; MODULE
+		     ;;
+		     [(zodiac:module-form? ast)
+
+		      (parameterize ([varref:current-invoke-module (module-info-invoke (get-annotation ast))])
+			(zodiac:set-module-form-body!
+			 ast
+			 (lift! (zodiac:module-form-body ast) code)))
+		      
+		      ast]
+
+		     [else (compiler:internal-error
+			    ast
+			    (format "unsupported syntactic form (~a)"
+				    (if (struct? ast)
+					(vector-ref (struct->vector ast) 0)
+					ast)))]))]
+		 [remove-local-var! (lambda (code var)
+				      (let ([vars (make-singleton-set var)])
+					(set-code-local-vars! code (set-minus (code-local-vars code) vars))
+					(set-code-captured-vars! code (set-minus (code-captured-vars code) vars))
+					;; Is it a case code?
+					(when (case-code? code)
+					  (let ([code (code-parent code)])
+					    (remove-local-var! code var)))))]
+		 [globals empty-set]
+		 [add-global! (lambda (v) (set! globals (set-union-singleton globals v)))])
+	  
+	  (lambda (ast code)
+	    ;; Find all the procedures
+	    (find-all-procedures! ast)
+
+	    ;; If we marked it as unliftable before, mark it as unknown
+	    ;;  now because we'll check again:
+	    (for-each
+	     (lambda (l)
+	       (let ([l (car l)])
+		 (let ([c (get-annotation l)])
+		   (unless (procedure-code-liftable c)
+		     (set-procedure-code-liftable! c 'unknown-liftable)))))
+	     procedures)
+
+	    ;; Set liftable flags
+	    (for-each (lambda (l)
+			(let ([l (car l)]
+			      [mi (cdr l)])
+			  (parameterize ([varref:current-invoke-module mi])
+			    (set-liftable! l))))
+		      procedures)
+
+	    (set! globals empty-set)
+	    (let ([ast (lift! ast code)])
+	      (cons ast globals))))))))
diff --git a/collects/compiler/private/prephase.ss b/collects/compiler/private/prephase.ss
new file mode 100644
index 0000000000..2848c1c7f7
--- /dev/null
+++ b/collects/compiler/private/prephase.ss
@@ -0,0 +1,683 @@
+;; pre-compilation scan
+;; (c) 1996-1997 Sebastian Good
+;; (c) 1997-2001 PLT
+
+; Notes mutability of lexical variables.
+; Performs a few very-high-level optimizations, such as
+;  throwing away constant expressions in a begin.
+; Performs a few ad hoc optimizations, like (+ x 1)
+;  => (add1 x)
+; Normalizes the expression forms:
+;   - begin/begin0: flattened as much as possible; empty
+;     and one-expression begins are eliminated
+;   - ((lambda (x1 ... xn) e) a1 ... an1) => let expression
+;   - (define-values () e) => (let-values [() e] (void))
+; (After this phase, a zodiac:top-level-varref is always
+;  a global variable.)
+; Infers names for closures and interfaces. (Do this early so
+;  that elaboration doesn't mangle the names.)
+; Detects global varrefs to built-in primitives.
+; Detects known immutability of signature vectors produced by */sig
+;  forms
+; Lambdas that are really c-lambdas are converted to quote forms
+;  containing c-lambda records
+; Applications that are really c-declares are converted to voids
+; Converts define-for-syntax to define-syntaxes (where id module
+;  phase distinguishes them in the end)
+
+;;; Annotatitons: ----------------------------------------------
+;;    binding - `binding-properties' structure
+;;        (this is temporary; the next phase will change the
+;;         annotation)
+;;    varref - empty set of varref attrributes, except that
+;;        the varref:primitive attribute can be added, and
+;;        the varref:in-module attribute can be added
+;;    quote - 'immutable for known immutable quoted vars
+;;    lambda - an inferred name (temporary)
+;;    module - a module-info record
+;;    define-[for-]syntax - in-mod?, wrap RHS with 
+;;                          (for-syntax-in-env (lambda () ...))
+;;; ------------------------------------------------------------
+
+(module prephase mzscheme
+  (require (lib "unitsig.ss"))
+
+  (require (lib "zodiac-sig.ss" "syntax"))
+
+  (require "sig.ss")
+  (require "../sig.ss")
+
+  (provide prephase@)
+  (define prephase@
+    (unit/sig
+	compiler:prephase^
+      (import (compiler:option : compiler:option^)
+	      compiler:library^
+	      compiler:cstructs^
+	      (zodiac : zodiac^)
+	      compiler:zlayer^
+	      compiler:driver^)
+
+      (define-struct binding-properties (mutable? unit-i/e? ivar? anchor known-val))
+
+      (define (prephase:init-binding-properties! binding mutable? unit-i/e? ivar?)
+	(set-annotation! binding (make-binding-properties mutable? unit-i/e? ivar? #f #f)))
+
+      (define (prephase:set-mutable! binding mutable?)
+	(set-binding-properties-mutable?! (get-annotation binding) mutable?))
+      (define (prephase:set-binding-anchor! binding a)
+	(set-binding-properties-anchor! (get-annotation binding) a))
+
+      (define (prephase:is-mutable? binding)
+	(let ([p (get-annotation binding)])
+	  (and p (binding-properties-mutable? p))))
+      (define (prephase:is-ivar? binding)
+	(let ([p (get-annotation binding)])
+	  (and p (binding-properties-ivar? p))))
+      (define (prephase:binding-anchor binding)
+	(let ([p (get-annotation binding)])
+	  (and p (binding-properties-anchor p))))
+
+      ;; Used in analyze to temporarily store known-value information for
+      ;;  let[rec] bindings
+      (define (prephase:known-val binding)
+	(let ([p (get-annotation binding)])
+	  (and p (binding-properties-known-val p))))
+      (define (prephase:set-known-val! binding v)
+	(let ([p (get-annotation binding)])
+	  (if p
+	      (set-binding-properties-known-val! p v)
+	      (begin
+		(prephase:init-binding-properties! binding #f #f #f)
+		(prephase:set-known-val! binding v)))))
+
+      ;; what can be thrown away in a begin?
+      (define prephase:dead-expression?
+	(one-of zodiac:bound-varref? zodiac:quote-form?
+		zodiac:case-lambda-form?))
+
+      ;; what can be ``pushed''?: (begin0 x ...) => (begin ... x)
+      (define prephase:begin0-pushable?
+	(one-of zodiac:case-lambda-form? zodiac:quote-form?))
+
+      ;; returns a true value if the symbol refers to a primitive function.
+      (define prephase:primitive-name?
+	(lambda (ast)
+	  (let ([m (zodiac:top-level-varref-module ast)])
+	    (or (eq? '#%kernel m)
+		(and (box? m)
+		     (eq? '#%kernel (unbox m)))))))
+
+      (define (preprocess:adhoc-app-optimization ast prephase-it)
+	(let ([fun (zodiac:app-fun ast)])
+	  (and (zodiac:top-level-varref? fun)
+	       (prephase:primitive-name? fun)
+	       (let ([name (zodiac:varref-var fun)]
+		     [args (zodiac:app-args ast)]
+		     [new-fun (lambda (newname)
+				(prephase-it
+				 (zodiac:make-top-level-varref
+				  ;; FIXME?: wrong syntax
+				  (zodiac:zodiac-stx fun)
+				  (make-empty-box)
+				  newname
+				  '#%kernel
+				  (box '())
+				  #f
+				  #f
+				  #f)))])
+		 (case name
+		   [(void) (if (null? args)
+			       (prephase-it (zodiac:make-special-constant 'void))
+			       #f)]
+		   [(list) (if (null? args)
+			       (prephase-it (zodiac:make-special-constant 'null))
+			       #f)]
+		   [(+ -) (when (and (= 2 (length args))
+				     (zodiac:quote-form? (cadr args))
+				     (equal? 1 (syntax-e (zodiac:zodiac-stx (zodiac:quote-form-expr (cadr args))))))
+			    (let ([newname (if (eq? name '+) 'add1 'sub1)])
+			      (zodiac:set-app-fun! ast (new-fun newname))
+			      (zodiac:set-app-args! ast (list (car args)))))
+		    #f] ; always return #f => use the (possibly mutated) ast
+		   [(verify-linkage-signature-match)
+		    ;; Important optimization for compound-unit/sig: mark signature-defining vectors
+		    ;;  as immutable
+		    (when (= 5 (length args))
+		      ;; Mark 1st, 2nd, 4th, and 5th as 'immutable quotes
+		      (let ([mark (lambda (qf)
+				    (when (zodiac:quote-form? qf)
+				      (set-annotation! qf 'immutable)))])
+			(mark (list-ref args 0))
+			(mark (list-ref args 1))
+			(mark (list-ref args 3))
+			(mark (list-ref args 4))))
+		    #f]
+		   [else #f])))))
+
+      (define for-syntax-slot (box #f))
+
+      ;;----------------------------------------------------------------------------
+      ;; PREPHASE MAIN FUNCTION
+      ;;
+      (define prephase!
+	(letrec ([prephase!
+		  (lambda (ast in-mod? need-val? name)
+		    (when (compiler:option:debug)
+		      (zodiac:print-start! (debug:get-port) ast)
+		      (newline (debug:get-port)))
+		    (cond
+		     ;;----------------------------------------------------------
+		     ;; CONSTANTS
+		     ;;
+		     [(zodiac:quote-form? ast) ast]
+		     
+		     ;;----------------------------------------------------------
+		     ;; VARIABLE REFERENCES
+		     ;;
+		     ;; set up all varrefs with an attribute set
+		     ;; note all varrefs to primitives
+		     ;; change unit-bound `top-levels' to lexicals
+		     ;;
+		     [(zodiac:varref? ast)
+
+		      (set-annotation! ast (varref:empty-attributes))
+			    
+		      (when (zodiac:top-level-varref? ast)
+			(when (prephase:primitive-name? ast)
+			  (varref:add-attribute! ast varref:primitive))
+			(when in-mod?
+			  (varref:add-attribute! ast varref:in-module)))
+		      
+		      ast]
+		     
+		     ;;----------------------------------------------------------
+		     ;; LAMBDA EXPRESSIONS
+		     ;;
+		     [(zodiac:case-lambda-form? ast)
+		      ;; Check for 'mzc-cffi attribute:
+		      (if (syntax-property (zodiac:zodiac-stx ast) 'mzc-cffi)
+
+			  ;; A C glue function. Change to a quote so it gets treated atomically
+			  (let* ([quote-expr (cadr
+					      (zodiac:begin-form-bodies (car (zodiac:case-lambda-form-bodies ast))))]
+				 [elems (syntax-e (zodiac:zodiac-stx (zodiac:quote-form-expr quote-expr)))]
+				 [fname (syntax-e (car elems))]
+				 [sname (syntax-e (cadr elems))]
+				 [arity (syntax-e (caddr elems))]
+				 [body (syntax-e (cadddr elems))])
+			    (register-c-lambda-function fname body)
+			    (zodiac:make-quote-form
+			     (zodiac:zodiac-stx ast)
+			     (zodiac:parsed-back ast)
+			     (zodiac:make-zread
+			      (datum->syntax-object
+			       #f
+			       (make-c-lambda fname sname body arity)
+			       #f))))
+			  
+			  ;; Normal lambda
+			  (let ([args (zodiac:case-lambda-form-args ast)]
+				[bodies (zodiac:case-lambda-form-bodies ast)])
+			    (for-each
+			     (lambda (args)
+			       (for-each (lambda (b) (prephase:init-binding-properties! b #f #f #f))
+					 (zodiac:arglist-vars args)))
+			     args)
+			    (let ([ast (zodiac:make-case-lambda-form
+					(zodiac:zodiac-stx ast)
+					(zodiac:parsed-back ast)
+					args
+					(begin-map (lambda (e) (prephase! e in-mod? #f #f))
+						   (lambda (e) (prephase! e in-mod? #t #f))
+						   bodies))])
+			      (set-annotation! ast name)
+			      ast)))]
+		     
+		     ;;----------------------------------------------------------
+		     ;; LET EXPRESSIONS
+		     ;;
+		     [(zodiac:let-values-form? ast)
+		      (for-each 
+		       (lambda (l)
+			 (for-each (lambda (b) (prephase:init-binding-properties! b #f #f #f))
+				   l))
+		       (zodiac:let-values-form-vars ast))
+		      (zodiac:set-let-values-form-vals!
+		       ast
+		       (map (lambda (e name) (prephase! e in-mod? #t name))
+			    (zodiac:let-values-form-vals ast)
+			    (zodiac:let-values-form-vars ast)))
+		      (zodiac:set-let-values-form-body!
+		       ast
+		       (prephase! (zodiac:let-values-form-body ast) in-mod? need-val? name))
+		      ast]
+		     
+		     ;;-----------------------------------------------------------
+		     ;; LETREC EXPRESSIONS
+		     ;;
+		     [(zodiac:letrec-values-form? ast)
+		      (for-each (lambda (l)
+				  (for-each (lambda (b) 
+					      (prephase:init-binding-properties! b #f #f #f))
+					    l))
+				(zodiac:letrec-values-form-vars ast))
+		      (zodiac:set-letrec-values-form-vals!
+		       ast
+		       (map (lambda (e name) (prephase! e in-mod? #t name))
+			    (zodiac:letrec-values-form-vals ast)
+			    (zodiac:letrec-values-form-vars ast)))
+		      (zodiac:set-letrec-values-form-body!
+		       ast
+		       (prephase! 
+			(zodiac:letrec-values-form-body ast)
+			in-mod?
+			need-val?
+			name))
+
+		      ;; ????? Obsolete? ????
+		      ;; this will mark the letrec so it is NOT retraversed by
+		      ;; a possible future call to a-normalize! (the mutating version)
+		      ;; (set-annotation! ast #f)
+
+		      ast]
+		     
+		     ;;-----------------------------------------------------------
+		     ;; IF EXPRESSIONS
+		     ;;
+		     [(zodiac:if-form? ast)
+		      (zodiac:set-if-form-test! 
+		       ast
+		       (prephase! (zodiac:if-form-test ast) in-mod? #t #f))
+		      (zodiac:set-if-form-then!
+		       ast
+		       (prephase! (zodiac:if-form-then ast) in-mod? need-val? name))
+		      (zodiac:set-if-form-else!
+		       ast
+		       (prephase! (zodiac:if-form-else ast) in-mod? need-val? name))
+
+		      ;; Ad hoc optimization: (if (not x) y z) => (if x z y)
+		      (let ([test (zodiac:if-form-test ast)])
+			(when (and (zodiac:app? test)
+				   (zodiac:top-level-varref? (zodiac:app-fun test))
+				   (eq? 'not (zodiac:varref-var (zodiac:app-fun test)))
+				   (prephase:primitive-name? (zodiac:app-fun test))
+				   (= 1 (length (zodiac:app-args test))))
+			  (let ([then (zodiac:if-form-then ast)]
+				[else (zodiac:if-form-else ast)])
+			    (zodiac:set-if-form-test! ast (car (zodiac:app-args test)))
+			    (zodiac:set-if-form-then! ast else)
+			    (zodiac:set-if-form-else! ast then))))
+
+		      ast]
+		     
+		     ;;-----------------------------------------------------------
+		     ;; BEGIN EXPRESSIONS
+		     ;; 
+		     ;; flatten, throw away dead values
+		     ;;
+		     [(zodiac:begin-form? ast)
+		      (let ([bodies (zodiac:begin-form-bodies ast)])
+			(if (null? bodies)
+					; must be a top-level begin...
+			    (zodiac:make-special-constant 'void)
+
+					; Normal begin
+			    (begin
+			      (begin-map! (lambda (e) (prephase! e in-mod? #f #f))
+					  (lambda (e) (prephase! e in-mod? need-val? name))
+					  bodies)
+			      (let ([final-bodies
+				     (let loop ([bodies bodies])
+				       (cond
+					; last expr in begin, finished
+					[(null? (cdr bodies)) bodies]
+					
+					; flatten begins
+					[(zodiac:begin-form? (car bodies))
+					 (loop (append! (zodiac:begin-form-bodies (car bodies))
+							(cdr bodies)))]
+					
+					; flatten begin0s, too
+					[(zodiac:begin0-form? (car bodies))
+					 (loop (append! (zodiac:begin0-form-bodies (car bodies))
+							(cdr bodies)))]
+					
+					; throw away dead values if possible
+					[(prephase:dead-expression? (car bodies))
+					 (loop (cdr bodies))]
+					
+					; otherwise
+					[else (cons (car bodies) (loop (cdr bodies)))]))])
+				(if (null? (cdr final-bodies))
+				    (car final-bodies)
+				    (begin
+				      (zodiac:set-begin-form-bodies! ast final-bodies)
+				      ast))))))]
+
+		     ;;-----------------------------------------------------------
+		     ;; BEGIN0 EXPRESSIONS
+		     ;; 
+		     ;; the 1st place is special -- the rest is just a begin
+		     ;; do our begin rewrites, then transform to a general form
+		     ;; if necessary
+		     ;;
+		     ;; if the value isn't going to be used, then the whole thing
+		     ;; is a begin
+		     ;;
+		     [(zodiac:begin0-form? ast)
+		      (if (not need-val?)
+
+			  ;; The value is ignored anyway - make it a begin
+			  (prephase!
+			   (zodiac:make-begin-form (zodiac:zodiac-stx ast)
+						   (zodiac:parsed-back ast)
+						   (zodiac:begin0-form-bodies ast))
+			   in-mod? 
+			   #f
+			   #f)
+
+			  (let ([ast
+				 (let ([make-begin
+					(lambda (bodies)
+					  (zodiac:make-begin-form (zodiac:zodiac-stx ast)
+								  (zodiac:parsed-back ast)
+								  bodies))]
+				       [bodies (zodiac:begin0-form-bodies ast)])
+				   
+					; simplify the first position
+				   (set-car! bodies (prephase! (car bodies) in-mod? need-val? name))
+				   
+					; then simplify the begin0
+				   (cond
+				    
+					; (begin0 M) --> M
+				    [(null? (cdr bodies)) (car bodies)]
+				    
+					; (begin0 <push> ...) --> (begin ... <push>))
+				    [(prephase:begin0-pushable? (car bodies))
+				     (prephase! 
+				      (make-begin (append (cdr bodies) (list (car bodies))))
+				      in-mod? 
+				      need-val?
+				      name)]
+				    
+					; (begin0 M ...) --> (begin0 M (begin ...))
+				    [else
+				     (set-cdr!
+				      (zodiac:begin0-form-bodies ast)
+				      (list (prephase! (make-begin (cdr bodies)) in-mod? #f #f)))
+				     ast]
+				    
+				    ))])
+			    (if (zodiac:begin0-form? ast)
+				ast ; (prephase:convert-begin0 ast)
+				ast)))]
+		     
+		     
+
+		     
+		     ;;-----------------------------------------------------------
+		     ;; SET! EXPRESSIONS
+		     ;;
+		     ;; Mark lexical bindings as mutable
+		     ;;
+		     [(zodiac:set!-form? ast)
+		      (zodiac:set-set!-form-var! ast
+						 (prephase!
+						  (zodiac:set!-form-var ast)
+						  in-mod? 
+						  #t
+						  #f))
+		      (let ([target (zodiac:set!-form-var ast)])
+			(when (zodiac:bound-varref? target)
+			  (prephase:set-mutable! 
+			   (zodiac:bound-varref-binding target) #t))
+			
+			(zodiac:set-set!-form-val! ast 
+						   (prephase! 
+						    (zodiac:set!-form-val ast)
+						    in-mod? 
+						    #t
+						    (zodiac:set!-form-var ast)))
+			ast)]		  
+		     
+		     ;;-----------------------------------------------------------
+		     ;; DEFINE EXPRESSIONS
+		     ;;
+		     ;;
+		     [(zodiac:define-values-form? ast)
+
+		      (if (null? (zodiac:define-values-form-vars ast))
+
+			  ;; (define-values () e) => (let-values [() e] (void))
+			  (zodiac:make-let-values-form 
+			   (zodiac:zodiac-stx ast)
+			   (zodiac:parsed-back ast)
+			   (list null)
+			   (list (prephase! (zodiac:define-values-form-val ast) in-mod? #t #f))
+			   (zodiac:make-special-constant 'void))
+			  
+			  ;; Normal prephase
+			  (begin
+			    (zodiac:set-define-values-form-vars!
+			     ast
+			     (map (lambda (e) (prephase! e in-mod? #t #f))
+				  (zodiac:define-values-form-vars ast)))
+			    (zodiac:set-define-values-form-val!
+			     ast
+			     (prephase! (zodiac:define-values-form-val ast) in-mod? #t (zodiac:define-values-form-vars ast)))
+			    ast))]
+		     
+		     ;;----------------------------------------------------------
+		     ;; DEFINE-SYNTAX or DEFINE-FOR-SYNTAX
+		     ;;
+		     [(or (zodiac:define-syntaxes-form? ast)
+			  (zodiac:define-for-syntax-form? ast))
+		      (let ([get-names (if (zodiac:define-for-syntax-form? ast)
+					   zodiac:define-for-syntax-form-names
+					   zodiac:define-syntaxes-form-names)]
+			    [get-expr (if (zodiac:define-for-syntax-form? ast)
+					  zodiac:define-for-syntax-form-expr
+					  zodiac:define-syntaxes-form-expr)])
+			(let ([ast
+			       (zodiac:make-define-syntaxes-form 
+				(zodiac:zodiac-stx ast)
+				(zodiac:parsed-back ast)
+				(map (lambda (e) (prephase! e in-mod? #t #f))
+				     (get-names ast))
+				(prephase! (zodiac:make-app 
+					    (zodiac:zodiac-stx ast)
+					    (make-empty-box)
+					    (zodiac:make-top-level-varref
+					     for-syntax-in-env-stx
+					     (make-empty-box)
+					     'for-syntax-in-env
+					     #f
+					     for-syntax-slot
+					     #t
+					     #f
+					     #f)
+					    (list
+					     (zodiac:make-case-lambda-form
+					      (zodiac:zodiac-stx ast)
+					      (make-empty-box)
+					      (list (zodiac:make-list-arglist null))
+					      (list (get-expr ast)))))
+					   in-mod?
+					   #t (get-names ast)))])
+			  (set-annotation! ast in-mod?)
+			  ast))]
+		     
+		     ;;-----------------------------------------------------------
+		     ;; APPLICATIONS
+		     ;;
+		     ;; check for unsupported syntactic forms that end up
+		     ;; looking like applications
+		     ;;
+		     ;; We'll hack in a rewrite here that turns
+		     ;; ((lambda (x*) M) y*) -> (let ([x y]*) M)
+		     ;;
+		     [(zodiac:app? ast)
+		      ;; Check for 'mzc-cffi attribute:
+		      (if (syntax-property (zodiac:zodiac-stx ast) 'mzc-cffi)
+			  
+			  ;; Really a c-declare
+			  (let* ([quote-expr (caddr (zodiac:app-args ast))]
+				 [str (syntax-e (zodiac:zodiac-stx (zodiac:quote-form-expr quote-expr)))])
+			    (register-c-declaration str)
+			    ;; return a void
+			    (zodiac:make-quote-form (zodiac:zodiac-stx ast)
+						    (make-empty-box)
+						    (zodiac:make-zread
+						     (datum->syntax-object #f (void) #f))))
+			  
+			  (let ([process-normally
+				 (lambda ()
+				   (zodiac:set-app-fun!
+				    ast
+				    (prephase! (zodiac:app-fun ast) in-mod? #t #f))
+				   (let ([adhoc (preprocess:adhoc-app-optimization 
+						 ast
+						 (lambda (x)
+						   (prephase! x in-mod? #t #f)))])
+				     (if adhoc
+					 (prephase! adhoc in-mod? need-val? name)
+					 (begin
+					   (zodiac:set-app-args!
+					    ast
+					    (map (lambda (e) (prephase! e in-mod? #t #f))
+						 (zodiac:app-args ast)))
+					   ast))))])
+			    
+			    (if (and (zodiac:case-lambda-form? (zodiac:app-fun ast))
+				     (not (syntax-property (zodiac:zodiac-stx (zodiac:app-fun ast)) 'mzc-cffi))
+				     (= 1 (length (zodiac:case-lambda-form-args 
+						   (zodiac:app-fun ast))))
+				     (zodiac:list-arglist? 
+				      (car (zodiac:case-lambda-form-args
+					    (zodiac:app-fun ast)))))
+				
+				;; optimize to let
+				(let* ([L (zodiac:app-fun ast)]
+				       [args (zodiac:app-args ast)]
+				       [ids (zodiac:arglist-vars 
+					     (car (zodiac:case-lambda-form-args L)))]
+				       [body (car (zodiac:case-lambda-form-bodies L))]
+				       [ok? (= (length ids) (length args))])
+				  (unless ok?
+				    ((if (compiler:option:stupid) compiler:warning compiler:error)
+				     ast 
+				     "wrong number of arguments to literal function"))
+				  (if (not ok?)
+				      (process-normally)
+				      (prephase!
+				       (zodiac:make-let-values-form
+					(zodiac:zodiac-stx ast)
+					(zodiac:parsed-back ast)
+					(map list ids)
+					args
+					body)
+				       in-mod? 
+				       need-val?
+				       name)))
+				
+				;; don't optimize
+				(process-normally))))]
+		     
+		     ;;-----------------------------------------------------------
+		     ;; WITH-CONTINUATION-MARK
+		     ;;
+		     [(zodiac:with-continuation-mark-form? ast)
+		      
+		      (zodiac:set-with-continuation-mark-form-key!
+		       ast
+		       (prephase! (zodiac:with-continuation-mark-form-key ast) in-mod? #t #f))
+		      
+		      (zodiac:set-with-continuation-mark-form-val!
+		       ast
+		       (prephase! (zodiac:with-continuation-mark-form-val ast) in-mod? #t #f))
+		      
+		      (zodiac:set-with-continuation-mark-form-body!
+		       ast
+		       (prephase! (zodiac:with-continuation-mark-form-body ast) in-mod? need-val? name))
+		      
+		      ast]
+
+		     ;;-----------------------------------------------------------
+		     ;; REQUIRE/PROVIDE
+		     ;;
+		     [(zodiac:require/provide-form? ast)
+		      ;; Change to namespace[-transformer]-require calls:
+		      (let-values ([(elems proc)
+				    (syntax-case (zodiac:zodiac-stx ast) (require require-for-syntax)
+				      [(require . elem)
+				       (values (syntax->list (syntax elem))
+					       'namespace-require)]
+				      [(require-for-syntax . elem)
+				       (values (syntax->list (syntax elem))
+					       'namespace-transformer-require)])])
+			(let ([proc (zodiac:make-top-level-varref
+				     (datum->syntax-object
+				      #f
+				      'namespace-require
+				      (zodiac:zodiac-stx ast))
+				     (make-empty-box)
+				     proc
+				     '#%kernel
+				     (box '())
+				     #f
+				     #f
+				     #f)])
+
+			  (prephase!
+			   (zodiac:make-begin-form
+			    (zodiac:zodiac-stx ast)
+			    (make-empty-box)
+			    (map (lambda (elem)
+				   (zodiac:make-app
+				    (zodiac:zodiac-stx ast)
+				    (make-empty-box)
+				    proc
+				    (list (zodiac:make-quote-form
+					   (zodiac:zodiac-stx ast)
+					   (make-empty-box)
+					   (zodiac:make-zread
+					    elem)))))
+				 elems))
+			   in-mod? need-val? name)))]
+
+		     ;;-----------------------------------------------------------
+		     ;; QUOTE-SYNTAX
+		     ;;
+		     [(zodiac:quote-syntax-form? ast)
+		      ast]
+
+		     ;;-----------------------------------------------------------
+		     ;; MODULE
+		     ;;
+		     [(zodiac:module-form? ast)
+
+		      (let-values ([(mi smi) (make-module-invokes
+					      (zodiac:module-form-self-path-index ast))])
+			(set-annotation! ast (make-module-info mi smi #f)))
+
+		      (zodiac:set-module-form-body!
+		       ast
+		       (prephase! (zodiac:module-form-body ast)
+				  #t #f #f))
+		      (zodiac:set-module-form-syntax-body!
+		       ast
+		       (prephase! (zodiac:module-form-syntax-body ast)
+				  #t #f #f))
+		      ast]
+		     
+
+		     ;;-----------------------------------------------------------
+		     ;; Unsupported forms
+		     ;;
+		     [else (compiler:fatal-error 
+			    ast 
+			    (format "unsupported syntactic form ~a" ast))
+			   ast]))])
+	  prephase!)))))
diff --git a/collects/compiler/private/rep.ss b/collects/compiler/private/rep.ss
new file mode 100644
index 0000000000..9e92c3724a
--- /dev/null
+++ b/collects/compiler/private/rep.ss
@@ -0,0 +1,240 @@
+;; Representation choosing phase of the the compiler
+;; (c) 1996-1997 Sebastian Good
+;; (c) 1997-201 PLT
+
+;; Chooses the representation of all bindings, and also
+;;  closures.
+
+;; Currently, all variables for Scheme values are represented
+;;  as Scheme_Object* values. But representations are also
+;;  chosen for closures and indirected Scheme variables, so
+;;  not everything is a Scheme_Object*.
+
+;;; Annotatitons: ----------------------------------------------
+;;    binding - `binding' structure UPDATED: rep field set
+;;; ------------------------------------------------------------
+
+(module rep mzscheme
+  (require (lib "unitsig.ss"))
+
+  (require (lib "zodiac-sig.ss" "syntax"))
+
+  (require "sig.ss")
+  (require "../sig.ss")
+
+  (provide rep@)
+  (define rep@
+    (unit/sig compiler:rep^
+      (import compiler:library^
+	      compiler:cstructs^
+	      compiler:analyze^
+	      (zodiac : zodiac^)
+	      compiler:zlayer^
+	      compiler:const^
+	      compiler:vehicle^
+	      compiler:driver^)
+
+      ;;----------------------------------------------------------------------------
+      ;; REPRESENTATION (TYPE) LANGUAGE
+      ;;
+      ;; future : add const?
+      ;;
+
+      (define-struct rep:atomic (type))
+      ;; Where type is one of: 
+      ;;  'scheme-object 
+      ;;  'scheme-bucket
+      ;;  'scheme-per-load-static
+      ;;  'scheme-per-invoke-static
+      ;;  'label
+      ;;  'prim
+      ;;  'prim-case
+      ;;  'begin0-saver
+      ;;  'wcm-saver
+      (define-struct rep:pointer (to))
+      (define-struct rep:struct (name orig-name fields))
+      (define-struct rep:struct-field (name orig-name rep))
+
+      (define-struct (rep:atomic/invoke rep:atomic) (module-invoke))
+
+      (define (rep:same-shape? a b)
+	(let ([al (rep:struct-fields a)]
+	      [bl (rep:struct-fields b)])
+	  (and (= (length al) (length bl))
+	       (andmap (lambda (af bf)
+			 (let ([ar (rep:struct-field-rep af)]
+			       [br (rep:struct-field-rep bf)]) 
+			   (or (and (rep:atomic? ar)
+				    (rep:atomic? br)
+				    (eq? (rep:atomic-type ar)
+					 (rep:atomic-type br))
+				    (or (not (rep:atomic/invoke? ar))
+					(eq? (rep:atomic/invoke-module-invoke ar)
+					     (rep:atomic/invoke-module-invoke br))))
+			       (and (rep:struct? ar)
+				    (rep:struct? br)
+				    (eq? (rep:struct-name ar)
+					 (rep:struct-name br))))))
+		       al bl))))
+
+      (define compiler:struct-index 0)
+      (define compiler:structs null)
+      (define (compiler:init-structs!)
+	(set! compiler:structs null))
+      (define compiler:add-struct!
+	(lambda (struct)
+	  (let loop ([l compiler:structs])
+	    (cond
+	     [(null? l)
+	      (let ([name (string->symbol (format "mergedStructs~a" compiler:struct-index))])
+		(set! compiler:struct-index (add1 compiler:struct-index))
+		(set-rep:struct-name! struct name)
+		(let loop ([l (rep:struct-fields struct)][n 0])
+		  (unless (null? l)
+		    (unless (rep:struct-field-name (car l))
+		      (set-rep:struct-field-name! (car l)
+						  (string->symbol
+						   (format "f~a" n))))
+		    (loop (cdr l) (add1 n)))))
+	      (set! compiler:structs (cons struct compiler:structs))]
+	     [(rep:same-shape? struct (car l))
+	      (set-rep:struct-name! struct (rep:struct-name (car l)))
+	      (let loop ([nl (rep:struct-fields struct)]
+			 [ol (rep:struct-fields (car l))])
+		(unless (null? nl)
+		  (set-rep:struct-field-name! (car nl)
+					      (rep:struct-field-name (car ol)))
+		  (loop (cdr nl) (cdr ol))))]
+	     [else (loop (cdr l))]))))
+      (define (compiler:get-structs) compiler:structs)
+
+      (define (rep:find-field struct orig-name)
+	(let loop ([l (rep:struct-fields struct)])
+	  (if (null? l)
+	      (compiler:internal-error 
+	       #f 
+	       (format
+		"vm:find-field: ~a not found in ~a" orig-name
+		(rep:struct-fields struct)))
+	      (if (eq? (rep:struct-field-orig-name (car l)) orig-name)
+		  (rep:struct-field-name (car l))
+		  (loop (cdr l))))))
+
+      ;;----------------------------------------------------------------------------
+      ;; choose-binding-representations! implements the lion's share of work in 
+      ;; chosing representations.  It takes 3 inputs:
+      ;;   1) a <set> of variables occurring local to an expression
+      ;;   2) a <set> of those variables which are globals
+      ;;   3) a <set> of those variables which are used
+      ;;   4) a <set> of those variables which are captured
+      ;; and returns no values
+      ;;
+      ;; As a side effect, it sets the representation fields of all those
+      ;; struct:bindings living in those compiler:bound guys.
+
+      (define choose-binding-representations!
+	(lambda (local-vars global-vars used-vars captured-vars)
+	  (let ([set-rep!
+		 (lambda (local-var)
+		   (let ([binding (get-annotation local-var)])
+		     (unless (binding-rep binding)
+		       (set-binding-rep! binding
+					 (if (or (binding-mutable? binding)
+						 (binding-letrec-set? binding)
+						 (binding-ivar? binding))
+					     (make-rep:pointer 
+					      (make-rep:atomic 'scheme-object))
+					     (make-rep:atomic 'scheme-object))))))])
+	    (for-each set-rep! (set->list local-vars)))))
+
+      ;;----------------------------------------------------------------------------
+      ;; choose-closure-representation! chooses representations for a closure
+      ;; it takes 1 input
+      ;;   1) a code structure
+      ;;
+      ;; and returns no values
+      ;;
+      ;; As a side effect, it sets the closure-code-rep field of the code structure
+      ;; based on its free variables.  It must be called _after_ binding
+      ;; representations have been chosen
+      ;;
+      (define choose-closure-representation!
+	(lambda (code)
+	  (let* ([base (gensym)]
+		 [struct (let ([fields
+				(append! (if (vehicle:only-code-in-vehicle? code)
+					     null
+					     (list
+					      (make-rep:struct-field 'label
+								     'label
+								     (make-rep:atomic 'label))))
+					 (map (lambda (bound)
+						(make-rep:struct-field
+						 ;; field-name
+						 #f
+						 (zodiac:binding-var bound)
+						 ;; field-type
+						 (binding-rep (get-annotation bound))))
+					      (set->list (code-free-vars code)))
+					 (map (lambda (global)
+						(make-rep:struct-field
+						 ;; field-name
+						 (if (const:per-load-statics-table? global)
+						     'pls
+						     (if (varref:module-invoke? global)
+							 'pmis
+							 #f))
+						 (if (or (const:per-load-statics-table? global)
+							 (varref:module-invoke? global))
+						     global
+						     (mod-glob-cname global))
+						 ;; field-type
+						 (if (const:per-load-statics-table? global)
+						     (make-rep:atomic 'scheme-per-load-static)
+						     (if (varref:module-invoke? global)
+							 (make-rep:atomic/invoke 
+							  'scheme-per-invoke-static
+							  global)
+							 (make-rep:atomic 'scheme-bucket)))))
+					      (set->list (code-global-vars code))))])
+			   (if (null? fields)
+			       #f ; empty structure - don't use anything
+			       (make-rep:struct 
+				;; name
+				#f
+				(symbol-append 'struct base)
+				fields)))])
+	    (when struct
+	      (compiler:add-struct! struct))
+	    (let* ([fields (append (cond
+				    [(procedure-code? code)
+				     (list
+				      (make-rep:struct-field 'prim
+							     'prim
+							     (if (= 1 (length (procedure-code-case-codes code)))
+								 (make-rep:atomic 'prim)
+								 (make-rep:atomic 'prim-case))))]
+				    [else
+				     (compiler:internal-error
+				      #f
+				      "unknown closure code type: ~s" code)])
+				   (if struct
+				       (list
+					(make-rep:struct-field 'data
+							       'data
+							       struct))
+				       null))]
+		   [alloc-struct (if (null? fields)
+				     #f
+				     (make-rep:struct 
+					; name
+				      #f
+				      (symbol-append 'allocstruct base)
+				      fields))])
+	      (when alloc-struct
+		(compiler:add-struct! alloc-struct))
+	      
+	      (set-closure-code-rep! code struct)
+	      (set-closure-code-alloc-rep! code alloc-struct)))))
+
+      )))
diff --git a/collects/compiler/private/sig.ss b/collects/compiler/private/sig.ss
new file mode 100644
index 0000000000..1810757839
--- /dev/null
+++ b/collects/compiler/private/sig.ss
@@ -0,0 +1,460 @@
+
+(module sig mzscheme
+  (require (lib "unitsig.ss"))
+
+  (require "../sig.ss")
+  (require (lib "zodiac-sig.ss" "syntax"))
+
+  (define for-syntax-in-env-stx #'for-syntax-in-env)
+  (provide for-syntax-in-env-stx)
+
+  (provide compiler:library^)
+  (define-signature compiler:library^
+    (logical-inverse
+     one-of
+     all-of
+     none-of
+     vector-map
+     improper-map
+     begin-map!
+     begin-map
+     map!
+     list-index
+     list-last
+
+     set?
+     empty-set
+     make-singleton-set
+     list->set
+     set->list
+     improper-list->set
+     set-memq?
+     set-empty?
+     set-find
+     set-union
+     set-union-singleton
+     set-minus
+     set-remove
+     set-intersect
+     set-subset?
+     set-map
+     set-filter
+     remove-duplicates
+     symbol-append
+     compiler:formals->arity
+     compiler:formals->arity*
+     compiler:gensym
+     compiler:genlabel
+     compiler:clean-string
+     protect-comment
+     global-defined-value*
+
+     compiler:get-label-number
+     compiler:reset-label-number!))
+
+  (provide compiler:cstructs^)
+  (define-signature compiler:cstructs^
+    (varref:empty-attributes
+     varref:add-attribute!
+     varref:has-attribute?
+     varref:invoke-module
+
+     varref:static
+     varref:per-load-static
+     varref:per-invoke-static
+     varref:primitive
+     varref:symbol
+     varref:inexact
+     varref:env
+     varref:in-module
+     varref:module-stx-string
+
+     (struct varref:module-invoke (id syntax? context-path-index))
+     make-module-invokes
+     get-num-module-invokes
+     is-module-invoke?
+
+     varref:reset-module-id!
+
+     (struct compiler:make-closure (lambda free-vars args name))
+     
+     (struct binding (rec?       ; part of a letrec recursive binding set
+		      mutable?   ; set!ed?
+		      anchor     ; anchor binding for this binding
+		      letrec-set?; set! for a letrec definition
+		      ivar?      ; is a class ivar?
+		      known? val ; has known value?
+		      known-but-used? ; known value used in an improper way?
+		      rep))      ; reprsentation
+     copy-binding
+
+     copy-binding-for-light-closures
+
+     binder:empty-anno 
+
+     (struct code (free-vars local-vars global-vars used-vars captured-vars
+			     parent case-parent children))
+
+     (struct closure-code (rep alloc-rep label vehicle
+			       max-arity
+			       return-multi ; #f, #t, or 'possible
+			       name))
+
+     (struct procedure-code (case-codes case-arities liftable method?))
+
+     (struct case-code (has-continue?))
+
+     (struct app (tail? prim? prim-name))
+
+     (struct module-info (invoke syntax-invoke part))
+
+     varref:current-invoke-module
+
+     compiler:bound-varref->binding 
+
+     (struct c-lambda (function-name scheme-name body arity))
+
+     (struct compiler:message (ast message))
+     (struct compiler:error-msg ())
+     (struct compiler:fatal-error-msg ())
+     (struct compiler:internal-error-msg ())
+     (struct compiler:warning-msg ())))
+
+  (provide compiler:zlayer^)
+  (define-signature compiler:zlayer^
+    (static-error
+     dynamic-error
+     internal-error
+     
+     compiler:empty-annotation
+     make-empty-box
+     get-annotation
+     set-annotation!
+     annotated?
+     remove-annotation!
+
+     compiler:escape-on-error
+
+     zodiac:begin0-form-first
+     zodiac:begin0-form-rest
+     zodiac:set-begin0-form-first!
+     zodiac:set-begin0-form-rest!
+
+     undefined?
+
+     zodiac:make-special-constant
+     self_modidx
+     
+     zodiac:binding->lexical-varref
+
+     main-source-file
+     zodiac:print-start!
+
+     zodiac->sexp/annotate))
+
+  (provide compiler:prephase^)
+  (define-signature compiler:prephase^
+    (prephase:init-binding-properties!
+     prephase:set-mutable!
+     prephase:set-binding-anchor!
+     prephase:is-mutable?
+     prephase:is-ivar?
+     prephase:binding-anchor
+     prephase:known-val
+     prephase:set-known-val!
+
+     prephase!))
+
+  (provide compiler:anorm^)
+  (define-signature compiler:anorm^
+    (a-normalize))
+
+  (provide compiler:const^)
+  (define-signature compiler:const^
+    (const:init-tables!
+     const:the-per-load-statics-table
+     const:per-load-statics-table?
+
+     const:get-symbol-counter
+     const:get-symbol-table
+
+     const:get-inexact-counter
+     const:get-inexact-table
+
+     const:get-string-table
+     const:get-bytes-table
+     const:intern-string
+
+     compiler:add-const!
+     compiler:get-symbol-const!
+     compiler:construct-const-code!
+
+     compiler:get-static-list
+     compiler:get-per-load-static-list
+     compiler:get-per-invoke-static-list
+     
+     compiler:add-per-load-static-list!
+     compiler:add-per-invoke-static-list!
+
+     compiler:make-const-constructor
+
+     const:make-syntax-constant
+
+     const:reset-syntax-constants!
+     const:finish-syntax-constants!
+
+     (struct syntax-string (str mi uposes ustart id))
+     const:get-syntax-strings
+
+     (struct compiled-string (id len))))
+
+  (provide compiler:rep^)
+  (define-signature compiler:rep^
+    ((struct rep:atomic (type))
+     (struct rep:pointer (to))
+     (struct rep:struct (name orig-name fields))
+     (struct rep:struct-field (name orig-name rep))
+
+     (struct rep:atomic/invoke (module-invoke))
+
+     compiler:get-structs
+     compiler:init-structs!
+
+     rep:find-field
+
+     choose-binding-representations!
+     choose-closure-representation!))
+
+  (provide compiler:known^)
+  (define-signature compiler:known^
+    (make-unknown-letbound-binding
+     extract-varref-known-val
+     extract-ast-known-value
+     analyze-knowns!))
+
+  (provide compiler:analyze^)
+  (define-signature compiler:analyze^
+    (compiler:get-global-symbols
+     compiler:get-primitive-refs
+
+     compiler:get-define-list
+     compiler:get-per-load-define-list
+     compiler:get-per-invoke-define-list
+
+     compiler:init-define-lists!
+
+     compiler:add-global-varref!
+     compiler:add-primitive-varref!
+
+     compiler:add-local-define-list!
+     compiler:add-local-per-load-define-list!
+     compiler:add-local-per-invoke-define-list!
+     
+     (struct case-info (body case-code global-vars used-vars captured-vars max-arity))
+
+     (struct mod-glob (cname modname varname position exp-time? exp-def? in-module?))
+     compiler:get-module-path-constant
+
+     compiler:finish-syntax-constants!
+
+     analyze-expression!))
+
+  (provide compiler:lift^)
+  (define-signature compiler:lift^
+    (lift-lambdas!
+     set-single-module-mode!))
+
+  (provide compiler:closure^)
+  (define-signature compiler:closure^
+    (compiler:get-closure-list
+
+     compiler:get-once-closures-list
+     compiler:get-once-closures-globals-list
+     compiler:get-lifted-lambdas
+     compiler:get-lifted-lambda-vars
+
+     compiler:init-closure-lists!
+     compiler:init-once-closure-lists!
+     compiler:init-lifted-lambda-list!
+     compiler:add-lifted-lambda!
+     (struct top-level-varref/bind-from-lift (lambda pls?))
+
+     closure-expression!))
+
+  (provide compiler:vehicle^)
+  (define-signature compiler:vehicle^
+    ((struct vehicle (total-labels lambdas max-arity))
+     (struct procedure-vehicle (max-args))
+
+     compiler:get-vehicles
+     compiler:get-total-vehicles
+     compiler:get-case-lambdas
+
+     compiler:init-vehicles!
+
+     get-vehicle
+     relate-lambdas!
+
+     vehicle:only-code-in-vehicle?
+
+     choose-vehicles!))
+
+  (provide compiler:vmstructs^)
+  (define-signature compiler:vmstructs^
+    ((struct vm:sequence (vals))
+     (struct vm:if (test then else))
+     (struct vm:module-body (vals invoke syntax?))
+
+     (struct vm:void (val))
+     (struct vm:return (val))
+     (struct vm:tail-apply (closure argc prim))
+     (struct vm:tail-call (label closure set-env?))
+     (struct vm:continue ())
+     
+     (struct vm:set! (vars val mode))
+     (struct vm:generic-args (closure tail? prim vals))
+     (struct vm:register-args (vars vals))
+     (struct vm:args (type vals))
+     (struct vm:begin0-mark! (var val))
+     (struct vm:begin0-setup! (var))
+     (struct vm:syntax! (vars val in-mod?))
+     
+     (struct vm:alloc (type))
+     (struct vm:build-constant (text))
+     (struct vm:make-closure (closure))
+     (struct vm:make-procedure-closure (vehicle min-arity max-arity name empty? method?))
+     (struct vm:make-case-procedure-closure (vehicle num-cases case-arities name empty? method?))
+     (struct vm:apply (closure argc known? multi? prim simple-tail-prim?))
+     (struct vm:macro-apply (name primitive args tail? bool?))
+     (struct vm:call (label closure))
+     (struct vm:begin0-extract (var))
+     (struct vm:wcm-mark! (key val))
+     (struct vm:wcm-push! (var))
+     (struct vm:wcm-pop! (var))
+     (struct vm:wcm-remember! (var val))
+     (struct vm:wcm-extract (var))
+     (struct vm:check-global (var))
+     (struct vm:module-create (shape id))
+
+     (struct vm:global-varref (var))
+     (struct vm:bucket (var))
+     (struct vm:per-load-statics-table ())
+     (struct vm:per-invoke-statics-table ())
+     (struct vm:cast (val rep)) ; last resort
+
+     (struct vm:local-varref (var binding))
+     (struct vm:static-varref (var))
+     (struct vm:static-varref-from-lift (lambda))
+     (struct vm:per-load-static-varref ())
+     (struct vm:per-invoke-static-varref ())
+     (struct vm:per-load-static-varref-from-lift (lambda))
+     (struct vm:per-invoke-static-varref-from-lift (lambda))
+     (struct vm:primitive-varref (var))
+     (struct vm:symbol-varref (var))
+     (struct vm:inexact-varref (var))
+     (struct vm:struct-ref (field var))
+     (struct vm:deref (var))
+     (struct vm:ref (var))
+
+     (struct vm:immediate (text))
+     
+     (struct vm:struct-type (fields))
+
+     vm:box-struct-type
+
+     arg-type:register
+     arg-type:arg
+     arg-type:tail-arg
+
+     target-type:global
+     target-type:lexical
+     target-type:static
+
+     vm:control-return?
+
+     vm:fixnum?
+     
+     vm:literal-constant?))
+
+  (provide compiler:vmphase^)
+  (define-signature compiler:vmphase^
+    (vm:convert-bound-varref
+     vm-phase))
+
+  (provide compiler:vmopt^)
+  (define-signature compiler:vmopt^
+    (vm-optimize!))
+
+  (provide compiler:driver^)
+  (define-signature compiler:driver^
+    ((open compiler:inner^)
+
+     compiler:error
+     compiler:fatal-error
+     compiler:internal-error
+     compiler:warning
+
+     get-s:file-block
+     s:register-max-arity!
+     compiler:get-setup-suffix
+
+     compiler:multi-o-constant-pool
+
+     register-c-lambda-function
+     register-c-declaration
+
+     debug
+     debug:get-port))
+
+  (provide compiler:top-level^)
+  (define-signature compiler:top-level^
+    ((struct block (source codes max-arity))
+     make-empty-block
+     block:register-max-arity!
+
+     add-code-local+used-vars!
+     remove-code-free-vars!))
+
+  (provide compiler:vm2c^)
+  (define-signature compiler:vm2c^
+    (vm->c:generate-modglob-name
+
+     vm->c:indent-by
+     vm->c:indent-spaces
+
+     vm->c:extract-inferred-name
+
+     vm->c:emit-symbol-list!
+     vm->c:emit-symbol-declarations!
+     vm->c:emit-symbol-definitions!
+     vm->c:emit-syntax-string-declarations!
+     vm->c:emit-syntax-string-definitions!
+     vm->c:emit-inexact-declarations!
+     vm->c:emit-inexact-definitions!
+     vm->c:emit-string-declarations!
+     vm->c:emit-prim-ref-declarations!
+     vm->c:emit-prim-ref-definitions!
+     vm->c:emit-struct-definitions!
+     vm->c:emit-static-declarations!
+     vm->c:emit-registration!
+     vm->c:emit-case-arities-definitions!
+     vm->c:emit-top-levels!
+     vm->c:emit-module-glue!
+     vm->c:emit-vehicle-prototype
+     vm->c:emit-vehicle-declaration
+     vm->c:emit-vehicle-header
+     vm->c:emit-vehicle-prologue
+     vm->c:emit-vehicle-epilogue
+     vm->c:convert-type-definition
+     vm->c:emit-function-prologue
+     vm->c:emit-case-prologue
+     vm->c:emit-case-epilogue
+     vm->c:emit-function-epilogue
+     vm->c-expression))
+
+  (provide compiler:basic-link^)
+  (define-signature compiler:basic-link^
+    ((unit ZODIAC : zodiac^)
+     (unit ZLAYER : compiler:zlayer^)
+     (unit DRIVER : compiler:driver^)
+     (unit LIBRARY : compiler:library^))))
diff --git a/collects/compiler/private/toplevel.ss b/collects/compiler/private/toplevel.ss
new file mode 100644
index 0000000000..2c12979c92
--- /dev/null
+++ b/collects/compiler/private/toplevel.ss
@@ -0,0 +1,84 @@
+;; routines for top-level entities
+;; (c) 1996-1997 Sebastian Good
+;; (c) 1997-2001 PLT
+
+(module toplevel mzscheme
+  (require (lib "unitsig.ss"))
+
+  (require "sig.ss")
+
+  (provide toplevel@)
+  (define toplevel@
+    (unit/sig
+	compiler:top-level^
+      (import compiler:library^
+	      compiler:cstructs^)
+      
+      ;;-------------------------------------------------------------
+      ;; This contains information about a top-level block, either at
+      ;; file level, or within a unit; typically a sequence of defines
+      ;; but could be anything
+      ;;
+      (define-struct block (source ; list of top-level ASTs
+			    codes  ; list of `code' structures (in parallel with source)
+			    max-arity))
+      (define make-empty-block (lambda () (make-block null null 0)))
+
+      (define block:register-max-arity!
+	(lambda (b n)
+	  (set-block-max-arity! b (max n (block-max-arity b)))))
+
+      ;; Add a local variable to a code record.
+      ;; If the local variable is in a case-code, add it from
+      ;;  the case-code and it will be automatically added
+      ;;  to the case-code's parent procedure-code.
+      (define (add-code-local+used-vars! code vars)
+	(set-code-local-vars! code (set-union vars (code-local-vars code)))
+	(set-code-used-vars! code (set-union vars (code-used-vars code)))
+	(when (case-code? code)
+	  ;; If this is just a case, also add it to the parent,
+	  ;; which is the real closure
+	  (add-code-local+used-vars! (code-parent code) vars)))
+      
+      ;; Remove a free variable from a code record.
+      ;; If the free variable is used in a case-code, remove it from
+      ;;  the case-code and it will be automatically removed
+      ;;  from the case-code's parent procedure-code (if appropriate).
+      (define (remove-code-free-vars! code vars)
+	(set-code-free-vars! code (set-minus (code-free-vars code) vars))
+	(set-code-captured-vars! code (set-minus (code-captured-vars code) vars))
+	(let ([code (if (case-code? code)
+			;; If this is just a case, recalculate the parent's free,
+			;;  which is the free set for the real closure
+			(let ([code (code-parent code)])
+			  (let loop ([fv empty-set]
+				     [cv empty-set]
+				     [cases (procedure-code-case-codes code)])
+			    (if (null? cases)
+				(begin
+				  (set-code-free-vars! code fv)
+				  (set-code-captured-vars! code cv))
+				(loop (set-union (code-free-vars (car cases)) fv)
+				      (set-union (code-captured-vars (car cases)) cv)
+				      (cdr cases))))
+			  code)
+			code)])
+	  ;; At this point, we go the code's parent and
+	  ;;   adjust the free/captured variable information.
+	  (let ([pcode (or (code-case-parent code)
+			   (code-parent code))])
+	    (when pcode
+	      (let ([children (code-children pcode)])
+		(unless (ormap (lambda (child)
+				 (not (set-empty? (set-intersect vars (code-free-vars code)))))
+			       children)
+		  ;; No other child uses the variable
+		  (remove-code-free-vars! pcode vars)))))))
+
+      ;; Notes on some other possible functions:
+      ;;   add-code-global-vars - add to all [case-]ancestors
+      ;;   remove-code-captured-vars - parent handling is the same
+      ;;                               as remove-code-free-vars
+
+      )))
+
diff --git a/collects/compiler/private/vehicle.ss b/collects/compiler/private/vehicle.ss
new file mode 100644
index 0000000000..67645b2fb2
--- /dev/null
+++ b/collects/compiler/private/vehicle.ss
@@ -0,0 +1,251 @@
+;; vehicle choosing phase for closures
+;; (c) 1996-1997 Sebastian Good
+;; (c) 1997-2001 PLT
+
+; Assign closures to ``vehicles'', and collect information for
+;  MzScheme about the closures.
+; A vehicle is a C function that implements the body of a
+;  closure. Multiple closures may be assigned to a single
+;  vehicle to improve the performance of tail calls.
+
+; The relate-lambdas! procedure is used to put procedure
+;  code into equivalence sets. If A contains a tail-call to
+;  B, they're put in the same equivalence class, and then
+;  they'll be implemented in the same vehicle, so A's call
+;  to B can be implemented as a goto.
+
+;;; Annotatitons: ----------------------------------------------
+;;    lambda: `code' structure UPDATED: label and
+;;       vehicle are set
+;;; ------------------------------------------------------------
+
+(module vehicle mzscheme
+  (require (lib "unitsig.ss"))
+
+  (require (lib "zodiac-sig.ss" "syntax"))
+
+  (require "sig.ss")
+  (require "../sig.ss")
+
+  (provide vehicle@)
+  (define vehicle@
+    (unit/sig
+	compiler:vehicle^
+      (import (compiler:option : compiler:option^)
+	      compiler:library^
+	      compiler:cstructs^
+	      (zodiac : zodiac^)
+	      compiler:zlayer^
+	      compiler:const^
+	      compiler:known^
+	      compiler:closure^
+	      compiler:driver^)
+
+      ;; Used for union-find for lambda vehicles:
+      (define (get-vehicle-top code)
+	(let loop ([code code])
+	  (let ([c (closure-code-vehicle code)])
+	    (if (code? c)
+		(let ([top (loop c)])
+		  (set-closure-code-vehicle! code top)
+		  top)
+		code))))
+      
+      (define-struct vehicle (total-labels lambdas max-arity))
+      (define-struct (procedure-vehicle vehicle) (max-args))
+      
+      (define vehicle:procedure 'vehicle:procedure)
+
+      (define vehicles:automatic 'vehicles:automatic)
+      (define vehicles:functions 'vehicles:functions)
+      (define vehicles:monolithic 'vehicles:monolithic)
+      
+      (define (make-empty-vehicle type)
+	(case type
+	  [(vehicle:procedure) (make-procedure-vehicle 0 null 0 0)]))
+      (define (vehicle-is-type? v type)
+	(case type
+	  [(vehicle:procedure) (procedure-vehicle? v)]))
+      
+      (define compiler:vehicles #f)
+      (define compiler:total-vehicles 0)
+      (define vehicle:add-lambda! 
+	(lambda (v type l)
+	  (let ([old-v (hash-table-get compiler:vehicles v 
+				       (lambda () (make-empty-vehicle type)))])
+	    (unless (vehicle-is-type? old-v type)
+	      (compiler:internal-error
+	       #f
+	       "can't use vehicle ~a as type ~a"
+	       old-v type))
+	    (set-vehicle-lambdas! old-v (cons l (vehicle-lambdas old-v)))
+	    (hash-table-put! compiler:vehicles v old-v))))
+      (define vehicle:register-max-arity!
+	(lambda (v n)
+	  (set-vehicle-max-arity! v (max n (vehicle-max-arity v)))))
+      (define vehicle:register-max-args!
+	(lambda (v n)
+	  (set-procedure-vehicle-max-args! v (max n (procedure-vehicle-max-args v)))))
+
+      ;; These lists are built up backwards, so reverse it before outputting the list
+      (define compiler:case-lambdas null)
+
+      (define (compiler:get-vehicles) compiler:vehicles)
+      (define (compiler:get-total-vehicles) compiler:total-vehicles)
+      (define (compiler:get-case-lambdas) compiler:case-lambdas)
+      
+      (define (compiler:init-vehicles!)
+	(set! compiler:vehicles (make-hash-table))
+	(set! compiler:total-vehicles 0)
+	(set! compiler:case-lambdas null))
+
+      (define choose-vehicles!
+	(lambda ()
+	  (when (eq? (compiler:option:vehicles) vehicles:monolithic) 
+	    (set! compiler:total-vehicles (compiler:option:vehicles:monoliths)))
+
+	  (for-each (lambda (L)
+		      (let* ([code (get-annotation L)]
+			     [type (cond
+				    [(zodiac:case-lambda-form? L) vehicle:procedure])]
+			     [new-vehicle
+			      (lambda ()
+				(begin0 compiler:total-vehicles
+					(set! compiler:total-vehicles
+					      (+ 1 compiler:total-vehicles))))]
+			     [vnum (case (compiler:option:vehicles)
+				     [(vehicles:automatic)
+				      (case type
+					[(vehicle:procedure) 
+					 (let* ([top (get-vehicle-top code)]
+						[n (or (closure-code-vehicle top)
+						       (new-vehicle))])
+					   (set-closure-code-vehicle! top n)
+					   (set-closure-code-vehicle! code n)
+					   n)])]
+				     [(vehicles:monolithic) 
+				      (case type
+					[(vehicle:procedure) (random (compiler:option:vehicles:monoliths))])]
+				     [(vehicles:functions) (new-vehicle)]
+				     [else (compiler:internal-error 
+					    #f 
+					    (format "bad option:vehicles - ~a" (compiler:option:vehicles)))])])
+			(set-closure-code-vehicle! code vnum)
+			(vehicle:add-lambda! vnum type L)
+			;; assign label, too
+			(let* ([vehicle (hash-table-get compiler:vehicles 
+							vnum
+							(lambda ()
+							  (compiler:internal-error 
+							   #f "bad hash table lookup (2)~n")))]
+			       [curr-label (vehicle-total-labels vehicle)])
+			  (vehicle:register-max-arity! vehicle (closure-code-max-arity code))
+			  (s:register-max-arity! (closure-code-max-arity code))
+			  (cond
+			   [(procedure-vehicle? vehicle)
+			    (vehicle:register-max-args! 
+			     vehicle
+			     (apply max
+				    (cons
+				     0
+				     (map (lambda (a) (length (zodiac:arglist-vars a)))
+					  (zodiac:case-lambda-form-args L)))))]
+			   [else (void)])
+			  (set-closure-code-label! code curr-label)
+			  (set-vehicle-total-labels! vehicle (+ 1 curr-label)))
+
+			;; We take this opportunity to collect other top-level info
+			;; that is closure-type-specific
+			(cond
+			 [(zodiac:case-lambda-form? L)
+			  (unless (= 1 (length (zodiac:case-lambda-form-args L)))
+			    (set-procedure-code-case-arities! code (length compiler:case-lambdas))
+			    (set! compiler:case-lambdas (cons L compiler:case-lambdas)))])))
+
+		    (compiler:get-closure-list))))
+
+      (define (get-vehicle vehicle-number)
+	(hash-table-get compiler:vehicles 
+			vehicle-number
+			(lambda () 
+			  ;; not an error because random placement
+			  ;; may leave some vehicles empty
+			  (let ([v (make-empty-vehicle vehicle:procedure)])
+			    (hash-table-put! compiler:vehicles vehicle-number v)
+			    v))))
+
+
+      ;; Traverse an AST and relate closure current-lambda to Y if
+      ;; the AST includes a tail-call to Y.
+      (define relate-lambdas!
+	(letrec
+	    ([same-vehicle!
+	      (lambda (a b)
+		(let ([a-top (get-vehicle-top (get-annotation a))]
+		      [b-top (get-vehicle-top (get-annotation b))])
+		  (unless (eq? a-top b-top)
+		    (set-closure-code-vehicle! a-top b-top))))]
+	     
+	     [relate!
+	      (lambda (current-lambda ast)
+		(cond
+		 
+		 ;;------------------------------------------------------------------
+		 ;; LET EXPRESSIONS
+		 ;;
+		 [(zodiac:let-values-form? ast)
+		  (relate! current-lambda (zodiac:let-values-form-body ast))]
+
+		 [(zodiac:letrec-values-form? ast)
+		  (relate! current-lambda (zodiac:letrec-values-form-body ast))]
+		 
+		 ;;-----------------------------------------------------------------
+		 ;; IF EXPRESSIONS
+		 ;;
+		 [(zodiac:if-form? ast)
+		  (relate! current-lambda (zodiac:if-form-then ast))
+		  (relate! current-lambda (zodiac:if-form-else ast))]
+
+		 ;;------------------------------------------------------------------
+		 ;; BEGIN EXPRESSIONS
+		 ;;
+		 [(zodiac:begin-form? ast)
+		  (let loop ([l (zodiac:begin-form-bodies ast)])
+		    (if (null? (cdr l))
+			(relate! current-lambda (car l))
+			(loop (cdr l))))]
+		 
+		 ;;------------------------------------------------------------------
+		 ;; WITH-CONTINUATION-MARK EXPRESSIONS
+		 ;;
+		 [(zodiac:with-continuation-mark-form? ast)
+		  (relate! current-lambda (zodiac:with-continuation-mark-form-body ast))]
+		 
+		 ;;-----------------------------------------------------------
+		 ;; MODULE
+		 ;;
+		 [(zodiac:module-form? ast)
+		  (relate! current-lambda (zodiac:module-form-body ast))]
+		 
+		 ;;-----------------------------------------------------------------
+		 ;; APPLICATIONS
+		 ;;
+		 ;; Check for known func & relate to this one
+		 ;;
+		 [(zodiac:app? ast)
+		  (let ([f (zodiac:app-fun ast)])
+		    (cond
+		     [(or (zodiac:bound-varref? f)
+			  (top-level-varref/bind-from-lift? f))
+		      (let ([known (extract-varref-known-val f)])
+			(and known
+			     (when (zodiac:case-lambda-form? known)
+			       (same-vehicle! current-lambda known))))]
+		     [else (void)]))]
+		 
+		 [else (void)]))])
+	  (lambda (current-lambda ast) (relate! current-lambda ast))))
+
+      (define (vehicle:only-code-in-vehicle? code)
+	(= (vehicle-total-labels (get-vehicle (closure-code-vehicle code))) 1)))))
+
diff --git a/collects/compiler/private/vm2c.ss b/collects/compiler/private/vm2c.ss
new file mode 100644
index 0000000000..e8a3b7e27b
--- /dev/null
+++ b/collects/compiler/private/vm2c.ss
@@ -0,0 +1,1733 @@
+;; VM Scheme -> C translation module
+;; (c) 1996-1997 Sebastian Good
+;; (c) 1997-2001 PLT
+
+(module vm2c mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "list.ss"))
+
+  (require (lib "zodiac-sig.ss" "syntax")
+	   (lib "primitives.ss" "syntax"))
+
+  (require "sig.ss")
+  (require "../sig.ss")
+
+  (provide vm2c@)
+  (define vm2c@
+    (unit/sig
+	compiler:vm2c^
+      (import (compiler:option : compiler:option^)
+	      compiler:library^
+	      compiler:cstructs^
+	      (zodiac : zodiac^)
+	      compiler:zlayer^
+	      compiler:analyze^
+	      compiler:const^
+	      compiler:rep^
+	      compiler:closure^
+	      compiler:vehicle^
+	      compiler:vmstructs^
+	      compiler:driver^)
+
+      (define local-vars-at-top? #f)
+
+      (define (interned? sym)
+	(eq? sym (string->symbol (symbol->string sym))))
+
+      (define vm->c:indent-by 4)
+      (define vm->c:indent-spaces
+	(make-string vm->c:indent-by #\space))
+
+      (define (vm->c:generate-modglob-name m s)
+	(when (symbol? m)
+	  (compiler:get-symbol-const! #f m)) ;; generates symbol const
+	(compiler:get-symbol-const! #f s) ;; generates symbol const
+	(let ([mname (cond
+		      [(symbol? m) m]
+		      [(not m) '||]
+		      [else 
+		       ;; try to find a useful part of the module-path-index;
+		       ;; this is just for debugging.
+		       (let-values ([(path base) (module-path-index-split m)])
+			 (cond
+			  [(and (pair? path)
+				(eq? 'lib (car path))
+				(pair? (cdr path))
+				(string? (cadr path)))
+			   (string->symbol (cadr path))]
+			  [else (string->symbol "MoD")]))])])
+	  (let ([name (symbol-append 'GL (compiler:gensym) mname '_ s)])
+	    (string->symbol (compiler:clean-string (symbol->string name))))))
+
+      (define vm->c:bucket-name
+	(lambda (mod var)
+	  ;; Shouldn't generate any new names:
+	  (mod-glob-cname (compiler:add-global-varref! mod var #f #f #f #f))))
+
+      (define (vm->c:SYMBOLS-name)
+	(if (compiler:multi-o-constant-pool)
+	    (format "SYMBOLS~a" (compiler:get-setup-suffix))
+	    "SYMBOLS"))
+
+      (define (vm->c:INEXACTS-name)
+	"INEXACTS")
+
+      (define (vm->c:STRING-name)
+	"STRINGS")
+
+      (define (vm->c:make-symbol-const-string sc)
+	(format "~a[~a]" (vm->c:SYMBOLS-name) (zodiac:varref-var sc)))
+
+      (define (vm->c:emit-list! port comma c-comment? table counter -symbol->string)
+	(let ([v (make-vector counter)])
+	  (hash-table-for-each
+	   table
+	   (lambda (sym b)
+	     (vector-set! v (string->number (symbol->string (zodiac:varref-var b))) sym)))
+	  (let loop ([i 0])
+	    (unless (= i (vector-length v))
+	      (fprintf port "  ~s~a ~a~n" (-symbol->string (vector-ref v i)) comma 
+		       (if c-comment? 
+			   (format "/* ~a */" i)
+			   (format "; ~a" i)))
+	      (loop (add1 i))))))
+
+      (define (vm->c:emit-symbol-list! port comma c-comment?)
+	(vm->c:emit-list! port comma c-comment? (const:get-symbol-table) (const:get-symbol-counter) 
+			  (if c-comment?
+			      symbol->string
+			      ;; Hack: wrap with parens to indicate uninterned
+			      (lambda (s)
+				((if (interned? s)
+				     values
+				     list)
+				 (symbol->string s))))))
+
+      (define (vm->c:emit-symbol-length-list! port comma c-comment?)
+	(vm->c:emit-list! port comma c-comment? (const:get-symbol-table) (const:get-symbol-counter) 
+			  (lambda (s) (string-length (symbol->string s)))))
+
+      (define (vm->c:emit-symbol-declarations! port)
+	(unless (zero? (const:get-symbol-counter))
+	  (unless (compiler:multi-o-constant-pool)
+	    (fprintf port "static const char *SYMBOL_STRS[~a] = {~n" (const:get-symbol-counter))
+	    (vm->c:emit-symbol-list! port "," #t)
+	    (fprintf port "}; /* end of SYMBOL_STRS */~n~n")
+	    (fprintf port "static const long SYMBOL_LENS[~a] = {~n" (const:get-symbol-counter))
+	    (vm->c:emit-symbol-length-list! port "," #t)
+	    (fprintf port "}; /* end of SYMBOL_LENS */~n~n"))
+
+	  (fprintf port "~aScheme_Object * ~a[~a];~n~n"
+		   (if (compiler:multi-o-constant-pool) "" "static ")
+		   (vm->c:SYMBOLS-name)
+		   (const:get-symbol-counter))))
+
+      (define (vm->c:emit-syntax-string-declarations! port)
+	(let ([l (const:get-syntax-strings)])
+	  (unless (null? l)
+	    (fprintf port "static Scheme_Object *SS[~a];~n~n" (length l))
+	    (for-each
+	     (lambda (ss)
+	       (emit-string port
+			    "char"
+			    (syntax-string-str ss)
+			    (format "SYNTAX_STRING_~a" (syntax-string-id ss))))
+	     l))))
+
+      (define (vm->c:emit-inexact-list! port comma comment?)
+	(vm->c:emit-list! port comma comment? (const:get-inexact-table) (const:get-inexact-counter)
+			  (lambda (x) (string->number (symbol->string x)))))
+
+      (define (vm->c:emit-inexact-declarations! port)
+	(unless (zero? (const:get-inexact-counter))
+	  (fprintf port "static const double INEXACT_NUMBERS[~a] = {~n" (const:get-inexact-counter))
+	  (vm->c:emit-inexact-list! port "," #t)
+	  (fprintf port "}; /* end of INEXACT_NUMBERS */~n~n")
+	  (fprintf port "static Scheme_Object * ~a[~a];~n~n" 
+		   (vm->c:INEXACTS-name)
+		   (const:get-inexact-counter))))
+
+      (define (emit-string-declarations! port table kind)
+	(hash-table-for-each
+	 table
+	 (lambda (str index)
+	   (emit-string port kind str (format "STRING_~a" index)))))
+
+      (define (vm->c:emit-string-declarations! port)
+	(emit-string-declarations! port (const:get-string-table) "mzchar")
+	(emit-string-declarations! port (const:get-bytes-table) "char"))
+
+      (define emit-string
+	(lambda (port kind str name)
+	  (let* ([len (if (string? str)
+			  (string-length str)
+			  (bytes-length str))])
+	    (let ([friendly (if (string? str)
+				(substring str 0 (min len 24))
+				(bytes->string/latin-1 (subbytes str 0 (min len 24))))])
+	      (fprintf port
+		       "/* ~a */~n"
+		       (list->string (map (lambda (i)
+					    (cond
+					     [(eq? i #\/) #\_]
+					     [(<= 32 (char->integer i) 121)
+					      i]
+					     [else #\_]))
+					  (string->list friendly)))))
+	    (fprintf port "static const ~a ~a[~a] = {" kind name (add1 len))
+	    (let loop ([i 0])
+	      (unless (= i len)
+		(when (zero? (modulo i 20))
+		  (fprintf port "~n    "))
+		(fprintf port "~a, " (if (string? str)
+					 (char->integer (string-ref str i))
+					 (bytes-ref str i)))
+		(loop (add1 i)))))
+	  (fprintf port "0 }; /* end of ~a */~n~n" name)))
+
+      (define (vm->c:emit-symbol-definitions! port)
+	(unless (zero? (const:get-symbol-counter))
+	  (fprintf port "  int i;~n")
+	  (fprintf port "  for (i = ~a; i--; )~n    SYMBOLS[i] = scheme_intern_exact_symbol(SYMBOL_STRS[i], SYMBOL_LENS[i]);~n"
+		   (const:get-symbol-counter))
+	  ;; Some symbols might be uninterned...
+	  (hash-table-for-each
+	   (const:get-symbol-table)
+	   (lambda (sym b)
+	     (unless (interned? sym)
+	       (let ([pos (zodiac:varref-var b)])
+		 (fprintf port "  SYMBOLS[~a] = scheme_make_exact_symbol(SYMBOL_STRS[~a], SYMBOL_LENS[~a]); /* uninterned */~n"
+			  pos pos pos)))))))
+
+      (define (vm->c:emit-syntax-string-definitions! port)
+	(let ([l (const:get-syntax-strings)])
+	  (unless (null? l)
+	    (for-each
+	     (lambda (ss)
+	       (let ([id (syntax-string-id ss)]
+		     [symbols (vm->c:SYMBOLS-name)])
+		 (fprintf port "  SS[~a] = scheme_load_compiled_stx_string(SYNTAX_STRING_~a, ~a);~n"
+			  id id (bytes-length (syntax-string-str ss)))
+		 ;; Reset uninterned symbols:
+		 (let loop ([uposes (syntax-string-uposes ss)][i (syntax-string-ustart ss)])
+		   (unless (null? uposes)
+		     (fprintf port "  ~a[~a] = scheme_compiled_stx_symbol(SCHEME_VEC_ELS(SS[~a])[~a]);~n"
+			      symbols (car uposes) id i)
+		     (loop (cdr uposes) (add1 i))))))
+	     l))))
+
+      (define (vm->c:emit-inexact-definitions! port)
+	(unless (zero? (const:get-inexact-counter))
+	  (fprintf port "  int i;~n")
+	  (fprintf port "  for (i = ~a; i--; )~n    INEXACTS[i] = scheme_make_double(INEXACT_NUMBERS[i]);~n"
+		   (const:get-inexact-counter))))
+
+      (define vm->c:emit-prim-ref-declarations!
+	(lambda (port)
+	  (unless (set-empty? (compiler:get-primitive-refs))
+	    (fprintf port "/* primitives referenced by the code */~n")
+	    (fprintf port "static struct {~n")
+	    (for-each (lambda (a)
+			(fprintf port "  Scheme_Object * ~a;~n"
+				 (vm->c:convert-symbol 
+				  (vm->c:bucket-name
+				   '#%kernel
+				   a))))
+		      (set->list (compiler:get-primitive-refs)))
+	    (fprintf port "} P;~n")
+	    (newline port))))
+
+      (define vm->c:emit-prim-ref-definitions!
+	(lambda (port)
+	  (unless (set-empty? (compiler:get-primitive-refs))
+	    (fprintf port "   /* primitives referenced by the code */~n")
+	    (for-each (lambda (a)
+			(fprintf port "~aP.~a = scheme_module_bucket(~a, ~a, -1, env)->val;~n"
+				 vm->c:indent-spaces
+				 (vm->c:convert-symbol (vm->c:bucket-name '#%kernel a))
+				 (vm->c:make-symbol-const-string (compiler:get-symbol-const! #f '#%kernel))
+				 (vm->c:make-symbol-const-string (compiler:get-symbol-const! #f a))))
+		      (set->list (compiler:get-primitive-refs))))))
+
+      (define vm->c:emit-struct-definitions!
+	(lambda (structs port)
+	  (fprintf port "/* compiler-written structures */~n")
+	  (for-each (lambda (struct)
+		      (fprintf port "struct ~a~n{~n"
+			       (vm->c:convert-symbol
+				(rep:struct-name struct)))
+		      (for-each
+		       (lambda (field)
+			 (fprintf port "~a~a ~a;~n"
+				  vm->c:indent-spaces
+				  (vm->c:convert-type-definition
+				   (rep:struct-field-rep field))
+				  (vm->c:convert-symbol
+				   (rep:struct-field-name field)))) 
+		       (rep:struct-fields struct))
+		      (fprintf port "};~n"))
+		    (reverse structs))
+	  (newline port)))
+
+      (define (compiler:any-statics?)
+	(not (and (null? (compiler:get-static-list))
+		  (null? (compiler:get-case-lambdas))
+		  (null? (compiler:get-lifted-lambda-vars)))))
+
+      (define (emit-static-variable-fields! port l)
+	(unless (null? l)
+	  (fprintf port "  /* Write fields as an array to help C compilers */~n")
+	  (fprintf port "  /* that don't like really big records. */~n")
+	  (fprintf port "  Scheme_Object * _consts_[~a];~n" (length l))
+	  (let svloop ([l l][n 0])
+	    (unless (null? l)
+	      (fprintf port "# define ~a _consts_[~a]~n"
+		       (vm->c:convert-symbol (car l)) n)
+	      (svloop (cdr l) (add1 n))))))
+
+      ;; when statics have binding information, this will look more like 
+      ;; emit-local-variable-declarations!
+      (define vm->c:emit-static-declarations!
+	(lambda (port)
+	  (unless (not (compiler:any-statics?))
+	    (fprintf port "/* compiler-written static variables */~n")
+	    (fprintf port "static struct {~n")
+	    (emit-static-variable-fields! port (compiler:get-static-list))
+	    (unless (null? (compiler:get-case-lambdas))
+	      (fprintf port "  mzshort *casesArities[~a];~n"
+		       (length (compiler:get-case-lambdas))))
+	    (for-each
+	     (lambda (ll)
+	       (fprintf port "  Scheme_Object * ~a;~n" 
+			(vm->c:convert-symbol (zodiac:varref-var ll))))
+	     (compiler:get-lifted-lambda-vars))
+	    (fprintf port "} S;~n~n"))
+
+	  (fprintf port "/* compiler-written per-load static variables */~n")
+	  (fprintf port "typedef struct Scheme_Per_Load_Statics {~n")
+	  (if (null? (compiler:get-per-load-static-list))
+	      (fprintf port "  int dummy;~n")
+	      (emit-static-variable-fields! port (compiler:get-per-load-static-list)))
+	  (fprintf port "} Scheme_Per_Load_Statics;~n")
+	  (newline port)
+
+	  (let ([ht (make-hash-table)])
+	    ;; Gather per-invoke statics with the same invoke id
+	    (let ([l (compiler:get-per-invoke-static-list)])
+	      (for-each (lambda (p)
+			  (let ([mi (cdr p)]
+				[var (car p)])
+			    (hash-table-put! ht (varref:module-invoke-id mi)
+					     (cons (cons var (varref:module-invoke-syntax? mi))
+						   (hash-table-get
+						    ht
+						    (varref:module-invoke-id mi)
+						    (lambda () null))))))
+			l)
+	      ;; Make sure that every module has a struct:
+	      (let loop ([i 0])
+		(unless (= i (get-num-module-invokes))
+		  (hash-table-get ht i (lambda ()
+					 (hash-table-put! ht i null)))
+		  (loop (add1 i))))
+	      (hash-table-for-each
+	       ht
+	       (lambda (id vars)
+		 (fprintf port "/* compiler-written per-invoke variables for module ~a */~n" id)
+		 (let ([vars (map car (filter (lambda (i) (not (cdr i))) vars))]
+		       [syntax-vars (map car (filter (lambda (i) (cdr i)) vars))])
+		   (fprintf port "typedef struct Scheme_Per_Invoke_Statics_~a {~n" id)
+		   (if (null? vars)
+		       (fprintf port "  int dummy;~n")
+		       (emit-static-variable-fields! port vars))
+		   (fprintf port "} Scheme_Per_Invoke_Statics_~a;~n" id)
+		   (fprintf port "typedef struct Scheme_Per_Invoke_Syntax_Statics_~a {~n" id)
+		   (if (null? syntax-vars)
+		       (fprintf port "  int dummy;~n")
+		       (emit-static-variable-fields! port syntax-vars))
+		   (fprintf port "} Scheme_Per_Invoke_Syntax_Statics_~a;~n" id)
+		   (newline port))))))))
+      
+      ;; when statics have binding information, this need only register
+      ;; pointer declarations
+      (define vm->c:emit-registration!
+	(lambda (port)
+	  (fprintf port "~a/* register compiler-written static variables with GC */~n"
+		   vm->c:indent-spaces)
+	  (let ([register
+		 (lambda (v)
+		   (fprintf port "~ascheme_register_extension_global(&~a, sizeof(~a));~n"
+			    vm->c:indent-spaces v v))])
+	    (unless (or (zero? (const:get-symbol-counter)) (compiler:multi-o-constant-pool))
+	      (register "SYMBOLS"))
+	    (unless (zero? (const:get-inexact-counter))
+	      (register "INEXACTS"))
+	    (unless (set-empty? (compiler:get-primitive-refs))
+	      (register "P"))
+	    (unless (not (compiler:any-statics?))
+	      (register "S"))
+	    (unless (null? (const:get-syntax-strings))
+	      (register "SS")))
+	  (newline port)))
+
+      (define (vm->c:emit-case-arities-definitions! port)
+	(fprintf port "   /* arity information for compiled case-lambdas */~n")
+	(let caloop ([l (reverse (compiler:get-case-lambdas))][pos 0])
+	  (unless (null? l)
+	    (let* ([ast (car l)]
+		   [args (zodiac:case-lambda-form-args ast)])
+	      (if (null? args)
+		  (fprintf port "~aS.casesArities[~a] = NULL;~n"
+			   vm->c:indent-spaces pos)
+		  (begin
+		    (fprintf port "~a{~n~a  mzshort * arities;~n" 
+			     vm->c:indent-spaces vm->c:indent-spaces)
+		    (fprintf port "~a  arities = (mzshort *)scheme_malloc_atomic(~a * sizeof(mzshort));~n"
+			     vm->c:indent-spaces
+			     (* 2 (length args)))
+		    (let cailoop ([l args][n 0])
+		      (unless (null? l)
+			(let-values ([(min-arity max-arity) (compiler:formals->arity (car l))])
+			  (fprintf port "~a  arities[~a] = ~a;~n~a  arities[~a] = ~a;~n"
+				   vm->c:indent-spaces (* 2 n) min-arity
+				   vm->c:indent-spaces (add1 (* 2 n)) max-arity))
+			(cailoop (cdr l) (add1 n))))
+		    (fprintf port "~a  S.casesArities[~a] = arities;~n"
+			     vm->c:indent-spaces pos)
+		    (fprintf port "~a}~n" vm->c:indent-spaces))))
+	    (caloop (cdr l) (add1 pos)))))
+
+      (define (vm->c:emit-top-levels! kind return? per-load? null-self-modidx? count vm-list locals-list 
+				      globals-list max-arity module mod-syntax? c-port)
+	;; count == -1 => go to the end of the list
+	(let tls-loop ([i 0]
+		       [n 0]
+		       [vml vm-list]
+		       [ll locals-list]
+		       [bl globals-list])
+	  (fprintf c-port
+		   "static ~a ~a_~a(Scheme_Env * env~a~a)~n{~n"
+		   (if return? "Scheme_Object *" "void")
+		   kind i
+		   (if (or per-load? module) ", Scheme_Per_Load_Statics *PLS" "")
+		   (if module
+		       (format 
+			", long phase_shift, Scheme_Object *self_modidx, Scheme_Per_Invoke_~aStatics_~a *PMIS" 
+			(if mod-syntax? "Syntax_" "")
+			module)
+		       ""))
+	  (when null-self-modidx? (fprintf c-port "#define self_modidx NULL~n"))
+	  (when (> max-arity 0)
+	    (fprintf c-port
+		     "~aScheme_Object * arg[~a];~n"
+		     vm->c:indent-spaces
+		     max-arity)
+	    (fprintf c-port "~aScheme_Thread * pr = scheme_current_thread;~n"
+		     vm->c:indent-spaces)
+	    (fprintf c-port "~aScheme_Object ** tail_buf;~n"
+		     vm->c:indent-spaces))
+	  (let loop ([c (compiler:option:max-exprs-per-top-level-set)][n n][vml vml][ll ll][bl bl])
+	    (if (or (zero? c) (null? vml) (= n count))
+		(begin
+		  (unless (or (null? vml) (= n count) (not return?))
+		    (fprintf c-port "~areturn NULL;~n" vm->c:indent-spaces))
+		  (when null-self-modidx? (fprintf c-port "#undef self_modidx~n"))
+		  (fprintf c-port 
+			   "} /* end of ~a_~a */~n~n" kind i)
+		  (if (or (null? vml) (= n count))
+		      i
+		      (tls-loop (add1 i) n vml ll bl)))
+		(if (not (or (and (not module)
+				  (not (vm:module-body? (car vml))))
+			     (and module
+				  (vm:module-body? (car vml))
+				  (is-module-invoke? (vm:module-body-invoke (car vml))  module)
+				  (eq? (vm:module-body-syntax? (car vml)) mod-syntax?))))
+		    (loop c n (cdr vml) (cdr ll) (cdr bl))
+		    (begin
+		      (let ([start (zodiac:zodiac-start (car vml))])
+			(fprintf c-port "~a{ /* [~a,~a] */~n" vm->c:indent-spaces
+				 (zodiac:location-line start)
+				 (zodiac:location-column start)))
+		      (vm->c:emit-local-variable-declarations! 
+		       (car ll)
+		       (string-append vm->c:indent-spaces vm->c:indent-spaces)
+		       c-port)
+		      (vm->c:emit-local-bucket-declarations! 
+		       (car bl)
+		       (string-append vm->c:indent-spaces vm->c:indent-spaces)
+		       #t
+		       c-port)
+		      (vm->c:emit-bucket-lookups! 
+		       (car bl)
+		       (string-append vm->c:indent-spaces vm->c:indent-spaces)
+		       c-port)
+		      
+		      (vm->c-expression (car vml) #f c-port vm->c:indent-by #t)
+		      
+		      (fprintf c-port "~a}~n" vm->c:indent-spaces)
+		      
+		      (loop (sub1 c) (add1 n) (cdr vml) (cdr ll) (cdr bl))))))))
+
+      (define (vm->c:emit-module-glue! port id num num-syntax)
+	(define (out syntax? n)
+	  (fprintf port "static void module_invoke~a_~a(" 
+		   (if syntax? "_syntax" "") id)
+	  (fprintf port "Scheme_Env *env, long phase_shift, Scheme_Object *self_modidx, void *pls)~n")
+	  (fprintf port "{~n~aScheme_Per_Invoke_~aStatics_~a *PMIS;~n" 
+		   vm->c:indent-spaces (if syntax? "Syntax_" "") id)
+	  (let ([s (format "Scheme_Per_Invoke_~aStatics_~a"
+			   (if syntax? "Syntax_" "") id)])
+	    (fprintf port "~aPMIS = (~a *)scheme_malloc(sizeof(~a));~n" 
+		     vm->c:indent-spaces s s))
+	  (let loop ([j 0])
+	    (unless (j . > . n)
+	      (fprintf port "~amodule_~abody_~a_~a(env, (Scheme_Per_Load_Statics *)pls, phase_shift, self_modidx, PMIS);~n"
+		       vm->c:indent-spaces (if syntax? "syntax_" "") id j)
+	      (loop (add1 j))))
+	  (fprintf port "}~n~n"))
+
+	(out #f num)
+	(out #t num-syntax))
+
+      (define vm->c:emit-vehicle-prototype
+	(lambda (port number)
+	  (let ([v (get-vehicle number)])
+	    (fprintf port 
+		     "static ~a vehicle_~a(~a)"
+		     "Scheme_Object *"
+		     number
+		     (cond
+		      [(procedure-vehicle? v)
+		       "void * void_param, int argc, Scheme_Object *argv[]"]
+		      [else
+		       (compiler:internal-error
+			#f
+			"vm->c:emit-vehicle-prototype: unknown closure kind ~a"
+			v)])))))
+
+      (define vm->c:emit-vehicle-declaration
+	(lambda (port number)
+	  (vm->c:emit-vehicle-prototype port number)
+	  (fprintf port "; /* ~a */ ~n"
+		   (vehicle-total-labels (get-vehicle number)))))
+
+      (define vm->c:emit-vehicle-header
+	(lambda (port number)
+	  (vm->c:emit-vehicle-prototype port number)
+	  (fprintf port "~n{~n")))
+
+      (define vm->c:emit-vehicle-prologue
+	(lambda (port vehicle)
+	  (let ([max-arity (vehicle-max-arity vehicle)]
+		[max-args (if (procedure-vehicle? vehicle)
+			      (procedure-vehicle-max-args vehicle)
+			      0)])
+	    (when (> max-arity 0)
+					; emit declaration of argument stack 
+	      (fprintf port "~aScheme_Object * arg[~a];~n" 
+		       vm->c:indent-spaces 
+		       max-arity))
+	    (when (> max-args 0)
+					; emit declaration of global variables for argument passing
+	      (let loop ([n 0])
+		(unless (= n max-args)
+		  (fprintf port "~aregister long reg~a;~n" vm->c:indent-spaces n)
+		  (loop (+ n 1)))))
+	    (when (> max-arity 0)
+					; tail-buffer-setup
+	      (fprintf port "~aScheme_Thread * pr = scheme_current_thread;~n"
+		       vm->c:indent-spaces)
+	      (fprintf port "~aScheme_Object ** tail_buf;~n"
+		       vm->c:indent-spaces)))
+
+	  (when local-vars-at-top?
+	    (for-each
+	     (lambda (L)
+	       (let ([locals (code-local-vars (get-annotation L))])
+		 (vm->c:emit-local-variable-declarations! locals vm->c:indent-spaces port)))
+	     (vehicle-lambdas vehicle)))
+	  
+					; emit jump to function...
+	  (when (> (vehicle-total-labels vehicle) 1)
+					; emit switch dispatcher
+	    (fprintf port "~aswitch(*(unsigned int*)void_param)~n~a{ " 
+		     vm->c:indent-spaces
+		     vm->c:indent-spaces )
+	    (let loop ([n 0])
+	      (when (and (zero? (modulo n 3))
+			 (not (= n (compiler:get-label-number))))
+		(fprintf port "~n~a~a" vm->c:indent-spaces vm->c:indent-spaces))
+	      (if (= n (sub1 (vehicle-total-labels vehicle)))
+		  (fprintf port "default: goto FGN~a;" n)
+		  (begin
+		    (fprintf port "case ~a: goto FGN~a;" n n)
+		    (loop (add1 n)))))
+	    (fprintf port "~n~a}~n" vm->c:indent-spaces))))
+
+      (define vm->c:emit-vehicle-epilogue
+	(lambda (port number)
+	  (fprintf port "} /* end of vehicle # ~a */~n" number)))
+
+      ;; Will be expanded to hold environments, perhaps, etc.
+      (define vm->c:convert-type-definition
+	(lambda (rep)
+	  (cond
+	   [(rep:atomic? rep) (case (rep:atomic-type rep)
+				[(scheme-object) "Scheme_Object *"]
+				[(scheme-bucket) "Scheme_Bucket *"]
+				[(scheme-per-load-static) "struct Scheme_Per_Load_Statics *"]
+				[(scheme-per-invoke-static) 
+				 (let ([mi (rep:atomic/invoke-module-invoke rep)])
+				   (format "struct Scheme_Per_Invoke_~aStatics_~a *"
+					   (if (varref:module-invoke-syntax? mi)
+					       "Syntax_"
+					       "")
+					   (varref:module-invoke-id mi)))]
+				[(label) "int"]
+				[(prim) "Scheme_Closed_Primitive_Proc"]
+				[(prim-case) "Scheme_Closed_Case_Primitive_Proc"]
+				[(begin0-saver) "_Scheme_Begin0_Rec"]
+				[(wcm-saver) "_Scheme_WCM_Rec"]
+				[else (compiler:internal-error 
+				       #f
+				       (format
+					"vm->c:convert-type-definition: ~a not valid atomic type"
+					(rep:atomic-type rep)))])]
+	   [(rep:pointer? rep)
+	    (string-append (vm->c:convert-type-definition (rep:pointer-to rep))
+			   " *")]
+	   [(rep:struct? rep)
+	    (format "struct ~a" (vm->c:convert-symbol (rep:struct-name rep)))]
+	   [else (compiler:internal-error 
+		  #f
+		  (format "vm->c:convert-type-definition: ~a not a valid representation" rep))])))
+
+      ;; must handle structs as well as atomic types
+      (define vm->c:type-definition->malloc
+	(lambda (rep)
+	  (let ([s (if (rep:struct? rep)
+		       (string-append "struct " (vm->c:convert-symbol (rep:struct-name rep)))
+		       (vm->c:convert-type-definition rep))])
+	  (format "(~a *)scheme_malloc(sizeof(~a))" s s))))
+
+      (define vm->c:emit-local-variable-declarations!
+	(lambda (locals indent port)
+	  (let loop ([locals (set->list locals)])
+	    (if (null? locals)
+		(void)
+		(let* ([bound (car locals)]
+		       [rep (binding-rep (get-annotation bound))])
+		  (fprintf port "~a~a ~a;~n"
+			   indent
+			   (vm->c:convert-type-definition rep)
+			   (vm->c:convert-symbol (zodiac:binding-var bound)))
+		  (loop (cdr locals)))))))
+
+      (define vm->c:emit-local-bucket-declarations!
+	(lambda (globals indent top-level? port)
+	  (for-each 
+	   (lambda (var)
+	     (cond
+	      [(const:per-load-statics-table? var)
+	       (unless top-level?
+		 (fprintf port "~aScheme_Per_Load_Statics * PLS;~n"
+			  indent))]
+	      [(varref:module-invoke? var)
+	       (unless top-level?
+		 (fprintf port "~aScheme_Per_Invoke_Statics_~a * PMIS;~n"
+			  indent (varref:module-invoke-id var)))]
+	      [else
+	       (fprintf port "~aScheme_Bucket * G~a;~n"
+			indent
+			(vm->c:convert-symbol (mod-glob-cname var)))]))
+	   (set->list globals))))
+
+      (define vm->c:emit-bucket-lookups!
+	(lambda (globals indent port)
+	  (for-each 
+	   (lambda (var)
+	     (unless (or (const:per-load-statics-table? var)
+			 (varref:module-invoke? var))
+	       (let* ([name (vm->c:convert-symbol (mod-glob-cname var))]
+		      [et? (mod-glob-exp-time? var)]
+		      [ed? (mod-glob-exp-def? var)]
+		      [position (mod-glob-position var)]
+		      [mod (mod-glob-modname var)]
+		      [in-mod? (mod-glob-in-module? var)]
+		      [var (mod-glob-varname var)]
+		      [modidx (and (not (symbol? mod))
+				   (compiler:get-module-path-constant mod))]
+		      [mod-local (and mod (not (symbol? mod)) (not modidx))]
+		      [mod-far (and mod (or (symbol? mod) modidx))])
+		 (fprintf port "~aG~a = scheme_~a~a~a_bucket(~a~a~a, ~a~a~a);~n"
+			  indent 
+			  name 
+			  (if et? "exptime_" "")
+			  (if ed? "expdef_" "")
+			  (if mod-far "module" "global")
+			  (if mod-far
+			      (if (symbol? mod)
+				  (vm->c:make-symbol-const-string (compiler:get-symbol-const! #f mod))
+				  (format
+				   "~a~a"
+				   (cond
+				    [(varref:has-attribute? modidx varref:per-load-static) "PLS->"]
+				    [(varref:has-attribute? modidx varref:per-invoke-static) "PMIS->"]
+				    [else "S."])
+				   (vm->c:convert-symbol (zodiac:varref-var modidx))))
+			      "")
+			  (if mod-far ", " "")
+			  (vm->c:make-symbol-const-string (compiler:get-symbol-const! #f var))
+			  (if mod-far (or position -1) "")
+			  (if mod-far ", " "")
+			  (if (or mod-local in-mod?) "env" "SCHEME_CURRENT_ENV(pr)")))))
+	   (set->list globals))))
+
+      (define binding-boxed? binding-mutable?)
+
+      (define vm->c:extract-arguments-into-variables!
+	(lambda (args normal? get-rep get-dest dest-boxed? get-src get-cast has-default? indent port)
+					; Reverse order for the sake of noticing default arguments
+	  (let loop ([args (reverse args)] [n (sub1 (length args))] [last? #t])
+	    (unless (null? args)
+	      (let* ([has-default? (has-default? n)]
+		     [argv-n
+		      (lambda ()
+			(if has-default?
+			    (format "((argc > ~a) ? ~a : (arg_set_level = ~a, scheme_undefined))" n (get-src n) n)
+			    (get-src n)))])
+		(cond
+		 [(or normal? (not last?))
+		  (fprintf port "~a~a = " indent (get-dest n))
+		  (if (dest-boxed? n)
+		      ;; if the binding is mutable, we need to make a box and fill it with
+		      ;; the correct value
+		      (let ([rep (get-rep n)])
+			(fprintf port "~ascheme_malloc(sizeof(~a));~n" 
+				 (get-cast n #f)
+				 (vm->c:convert-type-definition
+				  (rep:pointer-to rep)))
+			(fprintf port "~a*(~a)~a = (~a)~a;~n"
+				 indent
+				 (vm->c:convert-type-definition rep)
+				 (get-dest n) 
+				 (vm->c:convert-type-definition (rep:pointer-to rep))
+				 (argv-n)))
+		      
+		      (fprintf port "~a~a;~n" (get-cast n #t) (argv-n)))
+		  (loop (cdr args) (sub1 n) #f)]
+		 
+		 [else ; the rest get pulled into a list
+		  (when (dest-boxed? n)
+		    (fprintf port
+			     "~a~a = ~ascheme_malloc(sizeof(Scheme_Object *));~n"
+			     indent
+			     (get-dest n)
+			     (get-cast n #f)))
+		  (fprintf port 
+			   "~a~a~a = ~ascheme_build_list(argc-~a, argv+~a);~n"
+			   indent
+			   (if (dest-boxed? n)
+			       "*(Scheme_Object * *)" 
+			       "")
+			   (get-dest n)
+			   (if (dest-boxed? n)
+			       ""
+			       (get-cast n #t))
+			   n
+			   n)
+
+		  (loop (cdr args) (sub1 n) #f)]))))))
+
+      (define vm->c:pack-global-registers!
+	(lambda (L which indent port)
+	  (let* ([arglist (list-ref (zodiac:case-lambda-form-args L) which)]
+		 [args (zodiac:arglist-vars arglist)])
+	    (vm->c:extract-arguments-into-variables!
+	     args
+	     (zodiac:list-arglist? arglist)
+	     (lambda (n) "") ; rep not used since never boxed
+	     (lambda (n) (format "reg~a" n))
+	     (lambda (n) #f) ; never boxed
+	     (lambda (n) (format "argv[~a]" n))
+	     (lambda (n deref) "(long)")
+	     (lambda (n) #f)
+	     indent port))))
+
+      (define vm->c:emit-private-box-initializations
+					; Currently, each is filled with undefined, but specialized representations
+					;  will require something different
+	(lambda (bindings indent port)
+	  (for-each
+	   (lambda (binding)
+	     (let* ([rep (binding-rep (get-annotation binding))]
+		    [derep (rep:pointer-to rep)])
+	       (fprintf port "~a~a = (~a)~a;~n~a*(~a) = scheme_undefined;~n"
+			indent
+			(vm->c:convert-symbol (zodiac:binding-var binding))
+			(vm->c:convert-type-definition rep)
+			(vm->c:type-definition->malloc derep)
+			
+			indent
+			(vm->c:convert-symbol (zodiac:binding-var binding)))))
+	   bindings)))
+
+      (define vm->c:emit-undefines
+	(lambda (undefines indent port)
+	  (for-each
+	   (lambda (name)
+	     (fprintf port "#~aundef ~a~n"
+		      indent name))
+	   undefines)))
+
+      (define vm->c:emit-function-prologue
+	(lambda (L port)
+	  (let* ([code (get-annotation L)]
+		 [label (closure-code-label code)])
+	    (if (= 1 (length (zodiac:case-lambda-form-bodies L)))
+		(values 1 #f)
+		(begin
+		  ;; The foreign entry label      
+		  (fprintf port "FGN~a:~n" label)
+		  (let loop ([args (zodiac:case-lambda-form-args L)][i 0])
+		    (if (null? args)
+			(begin
+			  (fprintf port "~a~ascheme_case_lambda_wrong_count(~s, argc, argv, ~a, ~a"
+				   vm->c:indent-spaces vm->c:indent-spaces
+				   (vm->c:extract-inferred-name (closure-code-name code))
+				   (if (procedure-code-method? code) "1" "0")
+				   (length (zodiac:case-lambda-form-args L)))
+			  (let loop ([l (zodiac:case-lambda-form-args L)])
+			    (unless (null? l)
+			      (let-values ([(min-arity max-arity)
+					    (compiler:formals->arity (car l))])
+				(fprintf port ", ~a, ~a" min-arity max-arity)
+				(loop (cdr l)))))
+			  (fprintf port ");~n")
+			  (fprintf port "~a~areturn NULL;~n"
+				   vm->c:indent-spaces vm->c:indent-spaces)
+			  (values i #t))
+			(let ([a (car args)])
+			  (cond
+			   [(zodiac:sym-arglist? a)
+			    (fprintf port "~a~agoto FGN~ac~a;~n" 
+				     vm->c:indent-spaces vm->c:indent-spaces
+				     label
+				     i)
+			    (values (add1 i) #t)]
+			   [(zodiac:list-arglist? a)
+			    (fprintf port "~a~aif (argc == ~a) goto FGN~ac~a;~n"
+				     vm->c:indent-spaces vm->c:indent-spaces
+				     (length (zodiac:arglist-vars a))
+				     label
+				     i)
+			    (loop (cdr args) (add1 i))]
+			   [else
+			    (fprintf port "~a~aif (argc >= ~a) goto FGN~ac~a;~n"
+				     vm->c:indent-spaces vm->c:indent-spaces
+				     (sub1 (length (zodiac:arglist-vars a)))
+				     label
+				     i)
+			    (loop (cdr args) (add1 i))])))))))))
+
+      (define vm->c:emit-extract-env-variables
+	(lambda (code vars indent port)
+	  ;; now pull environment variables into registers
+	  ;; this is easy because of the way we've set up environments
+	  (let loop ([vars vars][undefines null])
+	    (if (null? vars)
+		undefines
+		(let* ([var (if (pair? vars) (car vars) vars)]
+		       [vname (zodiac:binding-var var)]
+		       [name (vm->c:convert-symbol vname)]
+		       [fname (rep:find-field (closure-code-rep code) vname)])
+		  (fprintf port (if (compiler:option:unpack-environments)
+				    "~a~a = env->~a;~n"
+				    "#~adefine ~a env->~a~n")
+			   indent
+			   name
+			   fname)
+		  (let ([undefines (if (compiler:option:unpack-environments)
+				       undefines
+				       (cons name undefines))])
+		    (if (pair? vars)
+			(loop (cdr vars) undefines)
+			undefines)))))))
+
+      (define vm->c:emit-extract-bucket-variables
+	(lambda (code vars indent port)
+	  ;; pull bucket variables into registers
+	  (let loop ([vars vars][undefines null])
+	    (if (null? vars)
+		undefines
+		(let ([var (car vars)])
+		  (cond
+		   [(const:per-load-statics-table? var)
+		    (begin
+		      (fprintf port 
+			       (if (compiler:option:unpack-environments)
+				   "~aPLS = env->pls;~n"
+				   "#~adefine PLS env->pls~n")
+			       indent)
+		      (loop (cdr vars)
+			    (if (compiler:option:unpack-environments)
+				undefines
+				(cons "PLS" undefines))))]
+		   [(varref:module-invoke? var)
+		    (begin
+		      (fprintf port 
+			       (if (compiler:option:unpack-environments)
+				   "~aPMIS = env->pmis;~n"
+				   "#~adefine PMIS env->pmis~n")
+			       indent)
+		      (loop (cdr vars)
+			    (if (compiler:option:unpack-environments)
+				undefines
+				(cons "PMIS" undefines))))]
+		   [else
+		    (let* ([vname (mod-glob-cname var)]
+			   [name (vm->c:convert-symbol vname)]
+			   [fname (rep:find-field (closure-code-rep code) vname)])
+		      (fprintf port 
+			       (if (compiler:option:unpack-environments)
+				   "~aG~a = env->~a;~n"
+				   "#~adefine G~a env->~a~n")
+			       indent
+			       name
+			       fname)
+		      (loop (cdr vars)
+			    (if (compiler:option:unpack-environments)
+				undefines
+				(cons (string-append "G" name) undefines))))]))))))
+      
+      (define vm->c:emit-case-prologue
+	(lambda (L which pre-decl lsuffix indent port)
+	  (let* ([code (get-annotation L)]
+		 [case-code (list-ref (procedure-code-case-codes code) which)]
+		 [label (closure-code-label code)]
+		 [undefines null]
+		 [used-free-set
+					; Only unpack anchors if they're captured
+		  (let* ([free-set (code-free-vars case-code)]
+			 [free-list (set->list free-set)]
+			 [captured-list (set->list (code-captured-vars code))]
+			 [uncaptured-anchor-set
+			  (list->set
+			   (let loop ([l free-list])
+			     (if (null? l)
+				 null
+				 (let ([zb (car l)])
+				   (let ([a (binding-anchor (get-annotation zb))])
+				     (if (and a (not (member zb captured-list)))
+					 (cons a (loop (cdr l)))
+					 (loop (cdr l))))))))])
+		    (set-minus free-set uncaptured-anchor-set))])
+					; The foreign entry label      
+	    (fprintf port "FGN~a~a:~n" label lsuffix)
+					; Pull arguments to global registers      
+	    (vm->c:pack-global-registers! L which indent port)
+
+					; The local entry label
+	    (fprintf port "LOC~a~a:~n" label lsuffix)
+	    (pre-decl)
+	    (unless local-vars-at-top?
+	      (vm->c:emit-local-variable-declarations! (code-local-vars case-code) indent port))
+
+	    (when (compiler:option:unpack-environments)
+	      (vm->c:emit-local-variable-declarations! used-free-set indent port)
+	      (vm->c:emit-local-bucket-declarations! (code-global-vars case-code) indent #f port))
+	    
+	    (let ([r (closure-code-rep code)])
+	      (when r
+					; (fprintf port "~aconst ~a * env;~n" indent (vm->c:convert-type-definition r))
+		(fprintf port "#~adefine env ((const ~a *)void_param)~n" indent (vm->c:convert-type-definition r))))
+	    
+					; Registers into local vars
+	    (let* ([args (zodiac:arglist-vars (list-ref (zodiac:case-lambda-form-args L) which))])
+	      (vm->c:extract-arguments-into-variables!
+	       args
+	       #t ; since regN already builds lists as appropriate
+	       (lambda (n) (binding-rep (get-annotation (list-ref args n))))
+	       (lambda (n) (vm->c:convert-symbol (zodiac:binding-var (list-ref args n))))
+	       (lambda (n) (binding-boxed? (get-annotation (list-ref args n))))
+	       (lambda (n) (format "reg~a" n))
+	       (lambda (n deref) (format "(~a)"
+					 (vm->c:convert-type-definition
+					  (let* ([binding (get-annotation (list-ref args n))]
+						 [rep (binding-rep binding)])
+					    (if (and deref (binding-boxed? binding))
+						(rep:pointer-to rep)
+						rep)))))
+	       (lambda (n) #f)
+	       indent port))
+
+					; reduce register pressure by doing all the env calculations
+					; after the args have been done
+					; equate the local registers with the global argument registers
+					; starting with the env
+	    #|
+	    (let ([r (closure-code-rep code)])
+	      (when r
+		(fprintf port "~aenv = (~a *)void_param;~n"
+			 indent
+			 (vm->c:convert-type-definition r))))
+	    |#
+
+					; now pull environment variables into registers
+	    (set! undefines
+		  (append (vm->c:emit-extract-env-variables
+			   code
+			   (set->list used-free-set)
+			   indent port)
+			  undefines))
+
+					; pull bucket variables into registers
+	    (set! undefines
+		  (append (vm->c:emit-extract-bucket-variables
+			   code
+			   (set->list (code-global-vars case-code))
+			   indent port)
+			  undefines))
+
+	    (when (case-code-has-continue? case-code)
+	      (fprintf port "~awhile(1)~n" indent))
+
+	    undefines)))
+
+      (define vm->c:emit-case-epilogue
+	(lambda (code which undefines indent port)
+	  (fprintf port "#~aundef env~n" indent)
+	  (vm->c:emit-undefines undefines indent port)))
+
+      (define vm->c:emit-function-epilogue
+	(lambda (code close port)
+	  (fprintf port "~a~a /* end of function body ~a */~n" 
+		   vm->c:indent-spaces close (closure-code-label code))))
+
+      (define vm->c:convert-symbol
+	(lambda (sym)
+	  (compiler:clean-string (symbol->string sym))))
+
+      (define vm->c:convert-char
+	(lambda (char)
+	  (if ((char->integer char) . > . 127)
+	      (char->integer char)
+	      (format
+	       "'~a'"
+	       (cond 
+		[(char=? char #\tab) "\\t"]
+		[(char=? char #\newline) "\\n"]
+		[(char=? char #\return) "\\r"]
+		[(char=? char #\space) " "]
+		[(or (char-alphabetic? char) (char-numeric? char)) (string char)]
+		[else (let ([text (number->string (char->integer char) 8)])
+			(string-append "\\"
+				       (make-string (- 3 (string-length text)) #\0)
+				       text))])))))
+
+      (define vm->c:convert-special-constant
+	(lambda (ast)
+	  (cond
+	   [(void? (syntax-e (zodiac:zodiac-stx ast))) "scheme_void"]
+	   [(undefined? (syntax-e (zodiac:zodiac-stx ast))) "scheme_undefined"]
+	   [else (compiler:internal-error 
+		  #f 
+		  (format
+		   "vm->c:convert-special-constant: ~a not correct" ast))])))
+      
+
+      (define vm->c:block-statement?
+	(one-of vm:if? vm:sequence? vm:module-body?))
+
+      (define vm->c:extract-inferred-name
+	(let ([nullsym (string->symbol "NULL")])
+	  (lambda (var)
+	    (cond
+	     [(list? var)
+	      (if (= (length var) 1)
+		  (vm->c:extract-inferred-name (car var))
+		  nullsym)]
+	     [(zodiac:binding? var)
+	      (symbol->string (zodiac:binding-orig-name var))]
+	     [(zodiac:bound-varref? var)
+	      (vm->c:extract-inferred-name (zodiac:bound-varref-binding var))]
+	     [(zodiac:varref? var)
+	      (symbol->string (zodiac:varref-var var))]
+	     [(not var) nullsym]
+	     [else (compiler:internal-error
+		    #f
+		    (format "vm->c:extract-inferred-name: bad var type: ~a"
+			    var))]))))
+
+      (define single-arity?
+	(one-of vm:global-varref?
+		vm:local-varref?
+		vm:static-varref?
+		vm:primitive-varref?
+		vm:symbol-varref?
+		vm:struct-ref?
+		vm:deref?
+		vm:ref?
+		vm:cast?
+		vm:immediate?))
+
+      (define is-primitive?
+	(one-of primitive? primitive-closure?))
+
+      (define vm->c-expression
+	(lambda (ast code port indent-level no-seq-braces?)
+	  (let process ([ast ast] [indent-level indent-level] [own-line? #t] [braces? (not no-seq-braces?)])
+	    (letrec ([emit-indentation (lambda () (display
+						   (make-string indent-level #\ )
+						   port))]
+		     [indent (lambda () (+ indent-level vm->c:indent-by))]
+		     [emit (lambda s (apply fprintf (cons port s)))]
+		     [emit-expr (lambda s
+				  (when own-line? (emit-indentation))
+				  (apply emit s))]
+		     [emit-macro-application
+		      (lambda (ast)
+			(let ([args (vm:macro-apply-args ast)])
+			  (emit "~a(" (vm:macro-apply-name ast))
+			  (process (vm:macro-apply-primitive ast) indent-level #f #f)
+			  (for-each (lambda (a) 
+				      (emit ", ~a" (vm->c:convert-symbol (zodiac:binding-var a))))
+				    args)
+			  (emit ")")))])
+
+	      (cond
+	       
+	       ;; (%sequence V ...) -> { M; ... }
+	       [(or (vm:sequence? ast)
+		    (vm:module-body? ast))
+		(let* ([seq ((if (vm:sequence? ast) vm:sequence-vals vm:module-body-vals) ast)])
+		  (when braces? (emit-indentation) (emit "{~n"))
+		  (for-each (lambda (v)
+			      (process v (indent) #t #t)
+			      (unless (vm->c:block-statement? v) (emit ";~n")))
+			    seq)
+		  (when braces? (emit-indentation) (emit "}~n")))]
+	       
+	       ;; (if R (sequence V) (sequence V)) ->
+	       ;;    if (!SCHEME_FALSEP(A)) { V ... } else { V ...}
+	       [(vm:if? ast)
+		(emit-indentation)
+		(let iloop ([ast ast])
+		  (let ([test (vm:if-test ast)]
+			[then (vm:if-then ast)]
+			[else (vm:if-else ast)])
+		    
+		    (emit "if (")
+		    (let ([direct? (and (vm:macro-apply? test)
+					(vm:macro-apply-bool? test))])
+		      (if direct?
+			  (emit-macro-application test)
+			  (begin
+			    (emit "!SCHEME_FALSEP(")
+			    (process test indent-level #f #t)
+			    (emit ")"))))
+		    (emit ")~n")
+		    (process (vm:if-then ast) indent-level #t #t)
+		    (let ([else-vals (vm:sequence-vals else)])
+		      (cond 
+		       [(and (= 1 (length else-vals))
+			     (vm:if? (car else-vals)))
+			(emit-indentation) (emit "else ")
+			(iloop (car else-vals))]
+		       [(not (null? else-vals))
+			(emit-indentation) (emit "else~n")
+			(process (vm:if-else ast) indent-level #f #t)]
+		       [else (void)]))))]
+	       
+	       ;; begin0 stuff
+	       [(vm:begin0-mark!? ast)
+		(let ([var (vm->c:convert-symbol
+			    (vm:local-varref-var (vm:begin0-mark!-var ast)))])
+		  (emit-indentation)
+		  (emit "~a.val = " var)
+		  (process (vm:begin0-mark!-val ast) indent-level #f #t))]
+	       [(vm:begin0-setup!? ast)
+		(let ([var (vm->c:convert-symbol
+			    (vm:local-varref-var (vm:begin0-setup!-var ast)))])
+		  (emit-indentation)
+		  (emit "if (~a.val == SCHEME_MULTIPLE_VALUES) {~n" var)
+		  (emit-indentation)
+		  (emit "  ~a.array = pr->ku.multiple.array;~n" var)
+		  (emit-indentation)
+		  (emit "  ~a.count = pr->ku.multiple.count;~n" var)
+		  (emit-indentation)
+		  (emit "  SCHEME_DETATCH_MV_BUFFER(~a.array, pr);~n" var)
+		  (emit-indentation)
+		  (emit "} else ~a.array = NULL" var))]
+	       [(vm:begin0-extract? ast)
+		(let ([var (vm->c:convert-symbol
+			    (vm:local-varref-var (vm:begin0-extract-var ast)))])
+		  (emit "(pr->ku.multiple.array = ~a.array," var)
+		  (emit " pr->ku.multiple.count = ~a.count, " var)
+		  (emit " ~a.val)" var))]
+
+	       ;; single value: (set! L R) -> L = R;
+	       ;; multiple value:
+	       [(vm:set!? ast)
+		(let* ([process-target!
+			(lambda (target)
+			  (let ([type (car target)]
+				[target (cdr target)])
+			    (cond
+			     [(eq? type target-type:lexical) 
+			      (process target indent-level #f #t)]
+			     [(eq? type target-type:global)
+			      (let ([bucket-name (vm->c:convert-symbol (mod-glob-cname target))])
+				(emit "G~a->val" bucket-name))]
+			     [else (compiler:internal-error 
+				    #f
+				    (format "~a: bad set! target type" type))])))]
+		       [process-set!
+			(lambda (target val process-val?)
+			  (let ([mode (vm:set!-mode ast)])
+			    (if mode
+				(begin
+				  (emit "scheme_set_global_bucket(~s, " (car mode))
+				  (emit "G~a, " (vm->c:convert-symbol (mod-glob-cname (cdr target))))
+				  (if process-val? 
+				      (process val indent-level #f #t)
+				      (emit val))
+				  (emit ", ~a)" (cadr mode)))
+				(begin
+				  (process-target! target)
+				  (emit " = ")
+				  (if process-val? 
+				      (process val indent-level #f #t)
+				      (emit val))))))]
+		       [vars (vm:set!-vars ast)]
+		       [val (vm:set!-val ast)]
+		       [num-to-set (length vars)]
+		       [return-arity
+			(or (and (single-arity? val)
+				 1)
+			    (and (vm:apply? val) 
+				 (vm:apply-prim val)
+				 (let ([proc (global-defined-value* (vm:apply-prim val))])
+				   (and
+				    (is-primitive? proc)
+				    (primitive-result-arity proc))))
+			    
+			    )])
+		  (emit-indentation)
+		  (let ([return-arity-ok?
+			 (and return-arity
+			      (number? return-arity)
+			      (= return-arity num-to-set))])
+		    (if (= num-to-set 1)		      
+			
+			(process-set! (car vars) val #t)
+			
+			(begin
+			  (emit "{ Scheme_Object * res = ")
+			  (process val indent-level #f #t)
+			  (emit "; ")
+			  (unless return-arity-ok?
+			    (emit "CHECK_MULTIPLE_VALUES(res, ~a);" num-to-set))
+			  (emit "}")
+			  (if (not (null? vars))
+			      (emit "~n"))
+			  (let aloop ([vars vars] [n 0])
+			    (unless (null? vars)
+			      (emit-indentation)
+			      (process-set! (car vars) (format "scheme_multiple_array[~a]" n) #f)
+			      (emit ";~n")
+			      (aloop (cdr vars) (+ n 1))))
+			  ))))]
+	       
+	       
+	       ;; (define-syntax! x R) or (define-for-syntax! x R)
+	       [(vm:syntax!? ast)
+		(let* ([process-set!
+			(lambda (target val process-val? return-arity-ok?)
+			  (let ([sym
+				 (vm->c:make-symbol-const-string 
+				  (compiler:get-symbol-const! #f (zodiac:varref-var target)))]
+				[in-module? (varref:has-attribute? target varref:in-module)])
+			    (when process-val? 
+			      (emit "{ Scheme_Object *mcv = ")
+			      (process val indent-level #f #t)
+			      (emit "; "))
+			    (unless return-arity-ok?
+			      (emit " if (mcv != SCHEME_MULTIPLE_VALUES || scheme_multiple_count) {")
+			      (emit " NO_MULTIPLE_VALUES(mcv); "))
+			    (let ([for-stx? (zodiac:top-level-varref-expdef? target)])
+			      (emit "scheme_~a(~ascheme_global_~abucket(~a, ~a), "
+				    (if for-stx? "set_global_bucket" "install_macro")
+				    (if for-stx? "NULL, " "")
+				    (if for-stx? "" "keyword_")
+				    sym
+				    (if in-module? "env" "SCHEME_CURRENT_ENV(pr)"))
+			      (if process-val? 
+				  (emit "mcv")
+				  (emit val))
+			      (when for-stx?
+				(emit ", 1"))
+			      (emit ")"))
+			    (when (or (not return-arity-ok?) process-val?)
+			      (emit ";"))
+			    (unless return-arity-ok?
+			      (emit " }"))
+			    (when process-val?
+			      (emit " }"))))]
+		       [vars (vm:syntax!-vars ast)]
+		       [val (vm:syntax!-val ast)]
+		       [in-mod? (vm:syntax!-in-mod? ast)]
+		       [num-to-set (length vars)]
+		       [return-arity (if (single-arity? val) 
+					 1
+					 #f)])
+		  (emit-indentation)
+		  (let ([return-arity-ok?
+			 (and return-arity
+			      (number? return-arity)
+			      (= return-arity num-to-set))])
+		    (if (= num-to-set 1)		      
+			
+			(process-set! (car vars) val #t return-arity-ok?)
+			
+			(begin
+			  (emit "{ Scheme_Object * res = ")
+			  (process val indent-level #f #t)
+			  (emit "; ")
+			  (unless return-arity-ok?
+			    (unless in-mod?
+			      (emit "if (res != SCHEME_MULTIPLE_VALUES || scheme_multiple_count) "))
+			    (emit "CHECK_MULTIPLE_VALUES(res, ~a);" num-to-set))
+			  (emit "}")
+			  (if (not (null? vars))
+			      (emit "~n"))
+			  (unless in-mod?
+			    (emit-indentation)
+			    (emit "if (scheme_multiple_count) {~n"))
+			  (let aloop ([vars vars] [n 0])
+			    (unless (null? vars)
+			      (emit-indentation)
+			      (process-set! (car vars) (format "scheme_multiple_array[~a]" n) #f #t)
+			      (emit ";~n")
+			      (aloop (cdr vars) (+ n 1))))
+			  (unless in-mod?
+			    (emit-indentation)
+			    (emit "}~n"))
+			  ))))]
+
+	       ;; (%args A ...) -> arg[0] = A; ...
+	       [(vm:args? ast)
+		;; skip tail_buf setup if no args
+		(when (and (eq? arg-type:tail-arg (vm:args-type ast))
+			   (not (null? (vm:args-vals ast))))
+		  (emit-indentation)
+		  (emit "tail_buf = scheme_tail_apply_buffer_wp(~a, pr);~n"
+			(length (vm:args-vals ast))))
+		(if (null? (vm:args-vals ast))
+		    (emit-indentation)
+		    (let arloop ([n 0] [args (vm:args-vals ast)])
+		      (unless (null? args)
+			(emit-indentation)
+			(let ([argtype (vm:args-type ast)])
+			  (cond
+			   [(eq? arg-type:arg argtype) (emit "arg[~a] = " n)]
+			   [(eq? arg-type:tail-arg argtype) (emit "tail_buf[~a] = " n)]
+			   [(eq? arg-type:register argtype) (emit "reg~a = (long)" n)]
+			   [else (compiler:internal-error 
+				  #f (format "vm->c: ~a unknown arg type" (vm:args-type ast)))]))
+			;; (emit "DEBUG_CHECK(") ;; DEBUGGING
+			(process (car args) indent-level #f #t)
+			;; (emit ")") ;; DEBUGGING
+			(unless (null? (cdr args))
+			  (emit ";~n"))
+			(arloop (add1 n) (cdr args)))))]
+
+	       [(vm:register-args? ast)
+		(let ([vars (vm:register-args-vars ast)]
+		      [vals (vm:register-args-vals ast)])
+		  (let raloop ([vars vars][vals vals])
+		    (let ([var (car vars)]
+			  [val (car vals)])
+		      (emit-indentation)
+		      (emit "~a = " (vm->c:convert-symbol (zodiac:binding-var var)))
+		      (process val indent-level #f #f)
+		      (unless (null? (cdr vars))
+			(emit ";~n")
+			(raloop (cdr vars) (cdr vals))))))]
+
+	       ;; (alloc ) -> malloc
+	       ;; a bit complicated
+	       [(vm:alloc? ast)
+		(emit (vm->c:type-definition->malloc (vm:alloc-type ast)))]
+
+	       ;; (make-closure) -> _scheme_make_c_closure
+	       [(vm:make-procedure-closure? ast)
+		(emit "_scheme_make_c_proc_closure~a(vehicle_~a, " 
+		      (if (vm:make-procedure-closure-empty? ast)
+			  "_empty"
+			  "")
+		      (vm:make-procedure-closure-vehicle ast))
+		(process (vm:make-closure-closure ast) indent-level #f #t)
+		(emit ", ~s, ~a, ~a, ~a)" 
+		      (vm->c:extract-inferred-name (vm:make-procedure-closure-name ast))
+		      (vm:make-procedure-closure-min-arity ast)
+		      (vm:make-procedure-closure-max-arity ast)
+		      (if (vm:make-procedure-closure-method? ast) "SCHEME_PRIM_IS_METHOD" "0"))]
+
+	       [(vm:make-case-procedure-closure? ast)
+		(emit "_scheme_make_c_case_proc_closure~a(vehicle_~a, " 
+		      (if (vm:make-case-procedure-closure-empty? ast)
+			  "_empty"
+			  "")
+		      (vm:make-case-procedure-closure-vehicle ast))
+		(process (vm:make-closure-closure ast) indent-level #f #t)
+		(emit ", ~s, ~a, S.casesArities[~a], ~a)" 
+		      (vm->c:extract-inferred-name (vm:make-case-procedure-closure-name ast))
+		      (vm:make-case-procedure-closure-num-cases ast)
+		      (vm:make-case-procedure-closure-case-arities ast)
+		      (if (vm:make-case-procedure-closure-method? ast) "SCHEME_PRIM_IS_METHOD" "0"))]
+
+	       [(vm:deref? ast)
+		(emit "(*")
+		(process (vm:deref-var ast) indent-level #f #t)
+		(emit ")")]
+
+	       [(vm:ref? ast)
+		(emit "(&")
+		(process (vm:ref-var ast) indent-level #f #t)
+		(emit ")")]
+	       
+					; optimize (*X).Y to X->Y
+	       [(vm:struct-ref? ast)
+		(let ([var (vm:struct-ref-var ast)])
+		  (if (vm:deref? var)
+		      (begin
+			(process (vm:deref-var var) indent-level #f #t)
+			(emit "->"))
+		      (begin
+			(process (vm:struct-ref-var ast) indent-level #f #t)
+			(emit ".")))
+		  (emit "~a" (vm->c:convert-symbol (vm:struct-ref-field ast))))]
+
+	       [(vm:cast? ast)
+		(emit "(")
+		(emit (vm->c:convert-type-definition (vm:cast-rep ast)))
+		(emit ")(")
+		(process (vm:cast-val ast) indent-level #f #t)
+		(emit ")")]
+
+	       [(vm:check-global? ast)
+		(emit-expr (format "CHECK_GLOBAL_BOUND(G~a)"
+				   (vm->c:convert-symbol
+				    (mod-glob-cname (vm:check-global-var ast)))))]
+	       
+	       [(vm:module-create? ast)
+		(emit-expr "scheme_declare_module(")
+		(process (vm:module-create-shape ast) indent-level #f #f)
+		(emit ", module_invoke_~a, module_invoke_syntax_~a, PLS, SCHEME_CURRENT_ENV(pr)"
+		      (vm:module-create-id ast) (vm:module-create-id ast))
+		(emit ")")]
+
+	       ;; with-continuation-mark
+	       [(vm:wcm-mark!? ast)
+		(emit-expr "scheme_set_cont_mark(")
+		(process (vm:wcm-mark!-key ast) indent-level #f #f)
+		(emit ", ")
+		(process (vm:wcm-mark!-val ast) indent-level #f #f)
+		(emit ")")]
+	       [(vm:wcm-push!? ast)
+		(let ([var (vm->c:convert-symbol
+			    (vm:local-varref-var (vm:wcm-push!-var ast)))])
+		  (emit-indentation)
+		  (emit "scheme_push_continuation_frame(&~a.cf)" var))]
+	       [(vm:wcm-pop!? ast)
+		(let ([var (vm->c:convert-symbol
+			    (vm:local-varref-var (vm:wcm-pop!-var ast)))])
+		  (emit-indentation)
+		  (emit "scheme_pop_continuation_frame(&~a.cf)" var))]
+	       [(vm:wcm-remember!? ast)
+		(let ([var (vm->c:convert-symbol
+			    (vm:local-varref-var (vm:wcm-remember!-var ast)))])
+		  (emit-indentation)
+		  (emit "scheme_temp_dec_mark_depth();~n")
+		  (emit-indentation)
+		  (emit "~a.val = " var)
+		  (process (vm:wcm-remember!-val ast) indent-level #f #t)
+		  (emit ";~n")
+		  (emit-indentation)
+		  (emit "scheme_temp_inc_mark_depth()"))]
+	       [(vm:wcm-extract? ast)
+		(let ([var (vm->c:convert-symbol
+			    (vm:local-varref-var (vm:wcm-extract-var ast)))])
+		  (emit "~a.val" var))]
+	       
+	       ;; (continue) -> continue;
+	       [(vm:continue? ast)
+		(unless (compiler:option:disable-interrupts)
+		  (emit-expr "SCHEME_USE_FUEL(1);~n"))
+		(emit-expr "continue")]
+	       
+	       ;; use NULL instead of tail_buf if no args
+	       ;; (tail-apply A <argc>) -> return _scheme_tail_apply(A, argc);
+	       [(vm:tail-apply? ast)
+		(emit-expr "return _scheme_tail_apply_no_copy_wp(")
+		(process (vm:tail-apply-closure ast) indent-level #f #t)
+		(let ([c (vm:tail-apply-argc ast)])
+		  (emit ", ~a, ~a, pr)" c (if (zero? c) "NULL" 'tail_buf)))]
+	       
+	       ;; (tail-call <label> <closure>) -> void_param = SCHEME_CLSD_PRIM_DATA(<closure>);
+	       ;;                                  goto LOC<label>;
+	       [(vm:tail-call? ast)
+		(when (vm:tail-call-set-env? ast)
+		  (emit-indentation)
+		  (emit "void_param = SCHEME_CLSD_PRIM_DATA(")
+		  (process (vm:tail-call-closure ast) indent-level #f #t)
+		  (emit ");~n"))
+		;; be nice to threads & user breaks:
+		(unless (compiler:option:disable-interrupts)
+		  (emit-indentation)
+		  (emit "SCHEME_USE_FUEL(1);~n"))
+		(emit-indentation)
+					; unless its to a variable arity function! ARGH
+		(let* ([label (vm:tail-call-label ast)]
+		       [l (if (number? label)
+			      label
+			      (format "~ac~a" (car label) (cdr label)))])
+		  (emit "goto LOC~a" l))]
+
+	       ;; (return R) -> return R
+	       [(vm:return? ast)
+		(emit-indentation)
+		(emit "return ")
+		(process (vm:return-val ast) indent-level #f #t)]
+
+	       ;; fortunately, void contexts can accept any number of values,
+	       ;; so there's no need to check for return arity
+	       [(vm:void? ast)
+		(emit-indentation)
+		(process (vm:void-val ast) indent-level #f #t)]
+	       
+	       ;; (global-varref x) --> GLOBAL_VARREF(x)
+	       [(vm:global-varref? ast)
+		(emit-expr "GLOBAL_VARREF(G~a)"
+			   (vm->c:convert-symbol
+			    (mod-glob-cname (vm:global-varref-var ast))))]
+
+	       ;; (global-varref x) --> Gx
+	       [(vm:bucket? ast)
+		(emit-expr "G~a"
+			   (vm->c:convert-symbol
+			    (mod-glob-cname (vm:bucket-var ast))))]
+
+	       [(vm:per-load-statics-table? ast)
+		(emit-expr "PLS")]
+
+	       [(vm:per-invoke-statics-table? ast)
+		(emit-expr "PMIS")]
+
+	       ;; use apply-known? flag
+	       ;; 0 args => pass NULL for arg vector
+	       ;; (apply A <argc>) --> _scheme_apply(A, argc, arg)
+	       [(vm:apply? ast)
+		(emit-expr "")
+		(when (vm:apply-simple-tail-prim? ast)
+		  (emit "return "))
+		(emit "_scheme_~a("
+		      (let ([v (global-defined-value* (vm:apply-prim ast))])
+			(cond
+			 [(and (primitive-closure? v) 
+			       (not (memq (object-name v) (internal-tail-chain-prims))))
+			  (if (or (vm:apply-multi? ast)
+				  (primitive-result-arity v))
+			      "direct_apply_closed_primitive_multi"
+			      "direct_apply_closed_primitive")]
+			 [(and (primitive? v)
+			       (not (memq (object-name v) (internal-tail-chain-prims))))
+			  (if (or (vm:apply-multi? ast)
+				  (primitive-result-arity v))
+			      "direct_apply_primitive_multi"
+			      "direct_apply_primitive")]
+			 [(vm:apply-known? ast) 
+			  (if (vm:apply-multi? ast)
+			      (if (compiler:option:disable-interrupts)
+				  "direct_apply_closed_primitive_multi_fv"
+				  "apply_known_closed_prim_multi")
+			      (if (compiler:option:disable-interrupts)
+				  (if (compiler:option:unsafe)
+				      "direct_apply_closed_primitive_multi_fv"
+				      "direct_apply_closed_primitive_fv")
+				  "apply_known_closed_prim"))]
+			 [(vm:apply-multi? ast) "apply_multi"]
+			 [else "apply"])))
+		(process (vm:apply-closure ast) indent-level #f #t)
+		(let ([c (vm:apply-argc ast)])
+		  (emit ", ~a, ~a)" c (if (zero? c) "NULL" 'arg)))]
+
+	       ;; Inlined macro-based applications
+	       [(vm:macro-apply? ast) 
+		(emit-expr "")
+		(when (vm:macro-apply-tail? ast)
+		  (emit "return "))
+		(when (vm:macro-apply-bool? ast) (emit "(("))
+		(emit-macro-application ast)
+		(when (vm:macro-apply-bool? ast) (emit ") ? scheme_true : scheme_false)"))]
+	       
+	       [(vm:call? ast)
+		(emit-expr "_scheme_force_value(compiled(SCHEME_CLSD_PRIM_DATA(")
+		(process (vm:call-closure ast) indent-level #f #t)
+		(emit "), 0, arg))")]
+
+	       ;; (bound-varref x) -> x
+	       [(vm:local-varref? ast) 
+		(emit-expr (vm->c:convert-symbol
+			    (vm:local-varref-var ast)))]
+	       
+	       ;; (primitive-varref x) -> x->val
+	       [(vm:primitive-varref? ast)
+		(emit-expr "P.~a"
+			   (vm->c:convert-symbol (mod-glob-cname (vm:primitive-varref-var ast))))]
+	       
+	       ;; (symbol-varref x) -> symbols[x]
+	       [(vm:symbol-varref? ast)
+		(emit-expr "~a[~a]" 
+			   (vm->c:SYMBOLS-name)
+			   (vm:symbol-varref-var ast))]
+
+	       ;; (inexact-varref x) -> inexacts[x]
+	       [(vm:inexact-varref? ast)
+		(emit-expr "~a[~a]" 
+			   (vm->c:INEXACTS-name)
+			   (vm:inexact-varref-var ast))]
+
+	       [(vm:per-load-static-varref? ast)
+		(emit-expr "PLS->~a" (vm->c:convert-symbol (vm:static-varref-var ast)))]
+	       
+	       [(vm:per-invoke-static-varref? ast)
+		(emit-expr "PMIS->~a" (vm->c:convert-symbol (vm:static-varref-var ast)))]
+	       
+	       [(vm:static-varref? ast)
+		(emit-expr "S.~a" (vm->c:convert-symbol (vm:static-varref-var ast)))]
+	       
+	       ;; (immediate x)
+	       [(vm:immediate? ast)
+		(let ([tast (vm:immediate-text ast)])
+		  (cond 
+		   
+		   ;;--------------------------------------------------------------
+		   ;; CONSTANTS
+		   ;;
+		   ;; labels
+		   [(number? tast)
+		    (emit-expr "~a" tast)]
+		   
+		   [(boolean? (zodiac:zread-object tast))
+		    (if (zodiac:zread-object tast)
+			(emit-expr "scheme_true")
+			(emit-expr "scheme_false"))]
+		   
+		   [(number? (zodiac:zread-object tast))
+		    (emit-expr "scheme_make_integer(~a)" (zodiac:zread-object tast))]
+		   
+		   [(char? (zodiac:zread-object tast))
+		    (emit-expr "scheme_make_character(~a)"
+			       (vm->c:convert-char
+				(zodiac:zread-object tast)))]
+		   
+		   [(null? (zodiac:zread-object tast))
+		    (emit-expr "scheme_null")]
+		   
+		   [(eq? (zodiac:zread-object tast) self_modidx)
+		    (emit-expr "self_modidx")]
+		   
+		   [(or (void? (zodiac:zread-object tast))
+			(undefined? (zodiac:zread-object tast)))
+		    (emit-expr (vm->c:convert-special-constant tast))]
+		   
+		   [else (compiler:internal-error
+			  ast
+			  (format "vm->c-expression: ~a not an immediate: ~e" 
+				  tast (zodiac:zread-object tast)))]))]
+	       
+	       [(vm:build-constant? ast)
+		(let ([ast (vm:build-constant-text ast)])
+		  (cond
+		   [(string? (zodiac:zread-object ast))
+		    (fprintf port "scheme_make_immutable_sized_char_string((mzchar *)STRING_~a, ~a, 0)" 
+			     (const:intern-string (zodiac:zread-object ast))
+			     (string-length (zodiac:zread-object ast)))]
+		   [(bytes? (zodiac:zread-object ast))
+		    (fprintf port "scheme_make_immutable_sized_byte_string((char *)STRING_~a, ~a, 0)" 
+			     (const:intern-string (zodiac:zread-object ast))
+			     (bytes-length (zodiac:zread-object ast)))]
+		   [(symbol? (zodiac:zread-object ast))
+		    (let ([s (symbol->string (zodiac:zread-object ast))])
+		      (emit-expr "scheme_intern_exact_symbol(~s, ~a)" s (string-length s)))]
+		   [(number? (zodiac:zread-object ast))
+		    (let process ([num (zodiac:zread-object ast)])
+		      (cond
+		       ;; NaN, inf
+		       [(member num  (list +NaN.0 +inf.0 -inf.0 -0.0)) 
+			(emit-expr "scheme_eval_string(\"~a\", env)" num)]
+		       ;; complex numbers
+		       [(not (eqv? 0 (imag-part num)))
+			(emit-expr "scheme_make_complex(")
+			(process (real-part num))
+			(emit ", ")
+			(process (imag-part num))
+			(emit ")")]
+		       ;; floating point numbers
+		       [(inexact? num)
+			(emit-expr "scheme_make_double(~a)" num)]
+		       ;; integers (fixnums & bignums)
+		       [(integer? num)
+			(if (vm:fixnum? num) 
+			    (emit-expr "scheme_make_integer(~a)" num)
+			    (emit-expr "scheme_read_bignum_bytes(\"~a\", 0, 10)" num))]
+					; rational numbers
+		       [else
+			(emit-expr "scheme_make_rational(")
+			(process (numerator num))
+			(emit ", ")
+			(process (denominator num))
+			(emit ")")]))]
+
+		   [(void? (zodiac:zread-object ast))
+		    (emit "scheme_void")]
+
+		   [(eq? (zodiac:zread-object ast) self_modidx)
+		    (emit-expr "self_modidx")]
+		   
+		   ;; HACK! - abused constants to communicate
+		   ;;  a direct call to scheme_make_prim_w_arity
+		   [(c-lambda? (zodiac:zread-object ast))
+		    (let ([cl (zodiac:zread-object ast)])
+		      (emit-expr "scheme_make_prim_w_arity(~a, ~s, ~a, ~a)"
+				 (c-lambda-function-name cl)
+				 (symbol->string (c-lambda-scheme-name cl))
+				 (c-lambda-arity cl)
+				 (c-lambda-arity cl)))]
+		   
+		   ;; HACK! - abused constants to communicate
+		   ;;  a direct call to scheme_read_compiled_stx_string():
+		   [(syntax-string? (zodiac:zread-object ast))
+		    (let ([id (syntax-string-id (zodiac:zread-object ast))]
+			  [for-mod? (syntax-string-mi (zodiac:zread-object ast))])
+		      (emit-expr "scheme_eval_compiled_stx_string(SS[~a], SCHEME_CURRENT_ENV(pr), ~a, ~a)"
+				 id
+				 (if for-mod? "phase_shift" "0")
+				 (if for-mod? "self_modidx" "NULL")))]
+		   
+		   ;; HACK! - abused constants to communicate
+		   ;;  a direct call to scheme_eval_compiled_string():
+		   [(compiled-string? (zodiac:zread-object ast))
+		    (let ([cs (zodiac:zread-object ast)])
+		      (emit-expr "scheme_eval_compiled_sized_string(STRING_~a, ~a, NULL)"
+				 (compiled-string-id cs)
+				 (compiled-string-len cs)))]
+		   
+		   [else (compiler:internal-error
+			  ast
+			  (format "vm:build-constant: not supported ~a" ast))]))]
+	       
+	       [else (compiler:internal-error #f (format "vm2c: ~a not supported" ast))]))))))))
diff --git a/collects/compiler/private/vmopt.ss b/collects/compiler/private/vmopt.ss
new file mode 100644
index 0000000000..019e5c020f
--- /dev/null
+++ b/collects/compiler/private/vmopt.ss
@@ -0,0 +1,583 @@
+;; VM Optimization pass
+;; (c) 1996-1997 Sebastian Good
+;; (c) 1997-201 PLT
+
+;; This pass only allows T & V statements to be expanded into multiple
+;; statments there is not a mechanism to expand R, A, or L
+;; expressions. (See vmscheme.ss.)
+
+(module vmopt mzscheme
+  
+  (require (lib "unitsig.ss")
+	  (lib "list.ss")
+	  (lib "etc.ss"))
+
+  (require (lib "zodiac-sig.ss" "syntax"))
+
+  (require "sig.ss")
+  (require "../sig.ss")
+
+  (provide vmopt@)
+  (define vmopt@
+    (unit/sig
+	compiler:vmopt^
+      (import (compiler:option : compiler:option^)
+	      compiler:library^
+	      compiler:cstructs^
+	      (zodiac : zodiac^)
+	      compiler:zlayer^
+	      compiler:vmstructs^
+	      compiler:known^
+	      compiler:rep^
+	      compiler:vmphase^
+	      compiler:driver^)
+
+      (define satisfies-arity?
+	(lambda (arity L arglist)
+	  (let-values ([(min-arity max-arity) (compiler:formals->arity*
+					       (if arglist
+						   (list arglist)
+						   (zodiac:case-lambda-form-args L)))])
+	    (if (= -1 max-arity)
+		(>= arity min-arity)
+		(= arity min-arity)))))
+
+      (define (select-case L argc)
+	(if L
+	    (let loop ([args (zodiac:case-lambda-form-args L)][i 0])
+	      (cond
+	       [(null? args) (values #f #f)]
+	       [(satisfies-arity? argc L (car args)) (values i (car args))]
+	       [else (loop (cdr args) (add1 i))]))
+	    (values #f #f)))
+
+      (define (case-label L label case)
+	(if (= 1 (length (zodiac:case-lambda-form-args L)))
+	    label
+	    (begin
+	      (unless case
+		(compiler:internal-error 
+		 #f 
+		 (format "vm-optimize: bad case label ~a" case)))
+	      (cons label case))))
+
+      (define a-val/l-val/immediate? (one-of vm:global-varref? vm:primitive-varref? vm:local-varref? 
+					     vm:symbol-varref? vm:inexact-varref? 
+					     vm:static-varref? vm:bucket?
+					     vm:per-load-statics-table? vm:per-invoke-statics-table?
+					     vm:struct-ref? vm:deref? vm:immediate?))
+
+      (define vm-optimize!
+	(lambda (current-lambda current-case)
+	  (letrec ([closure-info
+		    (lambda (closure)
+		      (let* ([L #f]
+			     [closure-label
+			      (let loop ([closure closure])
+				(cond
+				 [(or (vm:local-varref? closure)
+				      (vm:static-varref-from-lift? closure)
+				      (vm:per-load-static-varref-from-lift? closure)
+				      (vm:per-invoke-static-varref-from-lift? closure))
+				  (let ([known 
+					 (cond
+					  [(vm:local-varref? closure) (extract-varref-known-val 
+								       (vm:local-varref-binding closure))]
+					  [(vm:static-varref-from-lift? closure)
+					   (vm:static-varref-from-lift-lambda closure)]
+					  [(vm:per-load-static-varref-from-lift? closure)
+					   (vm:per-load-static-varref-from-lift-lambda closure)]
+					  [else
+					   (vm:per-invoke-static-varref-from-lift-lambda closure)])])
+				    (and known
+					 (zodiac:case-lambda-form? known)
+					 (begin (set! L known) #t)
+					 (closure-code-label 
+					  (get-annotation known))))]
+				 [(vm:deref? closure) (loop (vm:deref-var closure))]
+				 [else #f]))])
+			(values L closure-label)))]
+		   
+		   ;; This takes action based on the label associated with the closure 
+		   ;; passed in. There is a HACK here.  The 'known' value of this lexical
+		   ;; varref is a lambda, even though we have eliminated lambda.
+		   [with-closure
+		    (lambda (closure closure-case unknown call recur)
+		      (let-values ([(L closure-label) (closure-info closure)])
+			(let ([same-vehicle? 
+			       (and L
+				    current-vehicle
+				    (= current-vehicle 
+				       (closure-code-vehicle (get-annotation L))))])
+			  ((cond
+			    [(not closure-label) unknown]
+			    [(not current-lambda) call]
+			    [(not current-label) call]
+			    [(not current-vehicle) call]
+			    [(and same-vehicle? (= closure-label current-label) (= closure-case current-case)) recur]
+			    [else call])
+			   closure-label 
+			   closure-case
+			   L
+			   same-vehicle?
+			   ))))]
+		   [current-label
+		    (and current-lambda
+			 (closure-code-label (get-annotation current-lambda)))]
+		   [current-vehicle
+		    (and current-lambda
+			 (closure-code-vehicle (get-annotation current-lambda)))]
+		   [new-locs empty-set]
+		   [add-local-var!
+		    (lambda (binding)
+		      (set! new-locs (set-union-singleton new-locs binding)))]
+		   [process!
+		    (lambda (ast)
+		      (cond
+		       
+		       ;;====================================================================
+		       ;; BLOCK STATMENTS (B & S)
+		       
+		       ;;--------------------------------------------------------------------
+		       ;; SEQUENCE STATMENTS
+		       ;;
+		       ;; very simple.  gather the transformations for each of the 
+		       ;; instructions weave them back together into one sequence
+		       ;;
+		       [(vm:sequence? ast)
+			(set-vm:sequence-vals! ast
+					       (apply append! 
+						      (map process! (vm:sequence-vals ast))))
+			ast]
+
+		       [(vm:module-body? ast)
+			(set-vm:module-body-vals! ast
+						  (apply append! 
+							 (map process! (vm:module-body-vals ast))))
+			ast]
+		       
+		       ;;--------------------------------------------------------------------
+		       ;; IF STATEMENTS
+		       ;;
+		       ;; to reduce the nesting of ifs, especially in functional code, we
+		       ;; do the following optimization
+		       ;; (if A (sequence ... (RET X)) B) -->
+		       ;; (if A (sequence ... (RET X))), B
+		       ;; where RET is any instruction that terminates control such as
+		       ;; a return, tail-call, etc.
+		       ;;
+		       [(vm:if? ast)
+			(let*-values ([(test) (apply append (map process! (vm:if-test ast)))]
+				      [(test-setup test) (let loop ([l test][acc null])
+							   (if (null? (cdr l))
+							       (values (reverse! acc) (car l))
+							       (loop (cdr l) (cons (car l) acc))))])
+			  (append
+			   test-setup
+			   (begin
+			     (set-vm:if-test! ast test)
+			     (set-vm:if-then! ast (process! (vm:if-then ast)))
+			     (set-vm:if-else! ast (process! (vm:if-else ast)))
+			     (let* ([seq (vm:sequence-vals (vm:if-then ast))]
+				    [last (and (pair? seq) ; optimizations can make it null
+					       (list-last seq))])
+			       (if (vm:control-return? last)
+				   (begin0
+				    (cons ast (vm:sequence-vals (vm:if-else ast)))
+				    (set-vm:if-else! ast (make-vm:sequence #f '())))
+				   (list ast))))))]
+
+		       
+		       ;;--------------------------------------------------------------------
+		       ;; BEGIN0 STATMENTS
+		       ;;
+		       ;;
+		       [(vm:begin0-mark!? ast)
+			(set-vm:begin0-mark!-var! ast (car (process! (vm:begin0-mark!-var ast))))
+			(set-vm:begin0-mark!-val! ast (car (process! (vm:begin0-mark!-val ast))))
+			(list ast)]
+
+		       [(vm:begin0-setup!? ast)
+			(set-vm:begin0-setup!-var! ast (car (process! (vm:begin0-setup!-var ast))))
+			(list ast)]
+
+		       [(vm:begin0-extract? ast)
+			(set-vm:begin0-extract-var! ast (car (process! (vm:begin0-extract-var ast))))
+			(list ast)]
+
+		       ;;====================================================================
+		       ;; TAIL POSITION STATEMENTS
+		       
+		       ;;--------------------------------------------------------------------
+		       ;; VOID STATEMENT
+		       ;;
+		       ;; with dead code flags, we could throw it out
+		       ;;
+		       [(vm:void? ast)
+			(let ([val (car (process! (vm:void-val ast)))])
+			  (if (vm:immediate? val)
+			      null
+			      (begin
+				(set-vm:void-val! ast val)
+				(list ast))))]
+		       
+		       ;;--------------------------------------------------------------------
+		       ;; RETURN STATEMENT
+		       ;; 
+		       [(vm:return? ast) 
+			(set-vm:return-val! ast (car (process! (vm:return-val ast))))
+			(list ast)]
+		       
+		       ;;--------------------------------------------------------------------
+		       ;; TAIL-APPLY STATEMENT
+		       ;; 
+		       ;; if this is to a known function, turn this into a tail CALL
+		       ;; or if it is a tail-recursion, turn into a CONTINUE
+		       ;;
+		       [(vm:tail-apply? ast)
+			(list
+			 (let*-values ([(closure) (vm:tail-apply-closure ast)]
+				       [(L closure-label) (closure-info closure)]
+				       [(cl-case arglist) (select-case L (vm:tail-apply-argc ast))])
+			   (if (and L (not (and cl-case
+						(zodiac:list-arglist?  arglist)
+						(satisfies-arity? (vm:tail-apply-argc ast) L arglist))))
+			       
+			       ast
+			       
+			       (with-closure 
+				closure
+				cl-case
+				;; unknown tail call site
+				(lambda (_ __ ___ ____) ast)
+				
+				;; known tail call site
+				;; if the environment is empty, allow the backend to
+				;; eliminate the env-setting instruction
+				(lambda (label cl-case _ same-vehicle?)
+				  (let* ([code (get-annotation L)]
+					 [free-vars (code-free-vars code)]
+					 [global-vars (code-global-vars code)])
+				    (if same-vehicle?
+					(make-vm:tail-call
+					 (zodiac:zodiac-stx ast)
+					 (case-label L label cl-case)
+					 closure
+					 (or (not (set-empty? free-vars))
+					     (not (set-empty? global-vars))))
+					ast)))
+				
+				;; known tail recursion site
+				(lambda (label cl-case _ __)
+				  (if (zodiac:list-arglist? arglist)
+				      (begin
+					;; Mark the case as having a continue
+					(set-case-code-has-continue?! 
+					 (list-ref (procedure-code-case-codes (get-annotation L)) cl-case) 
+					 #t)
+					(make-vm:continue (zodiac:zodiac-stx ast)))
+				      (make-vm:tail-call (zodiac:zodiac-stx ast)
+							 (case-label L label cl-case)
+							 closure)))))))]
+		       
+		       ;;====================================================================
+		       ;; NON-TAIL POSITION STATEMENTS
+		       
+		       ;;--------------------------------------------------------------------
+		       ;; SET! STATEMENTS
+		       ;;
+		       ;; if this binds multiple values, be sure the apply on the other end
+		       ;; is a multi-apply
+		       ;;
+		       [(vm:set!? ast)
+			(when (vm:apply? (vm:set!-val ast))
+			  (set-vm:apply-multi?!
+			   (vm:set!-val ast)
+			   (not (= 1 (length (vm:set!-vars ast))))))
+			(set-vm:set!-val! ast (car (process! (vm:set!-val ast))))
+			(list ast)]
+		       
+		       ;;--------------------------------------------------------------------
+		       ;; ARGS
+		       ;;
+		       ;; We implement a mapping of many types of function calls to 3 arg 
+		       ;; types and check for arity if the call is to a known function
+		       ;; 
+		       ;;
+		       [(vm:generic-args? ast)
+			(if (vm:generic-args-prim ast)
+			    (list (make-vm:args (zodiac:zodiac-stx ast)
+						(if (vm:generic-args-tail? ast)
+						    arg-type:tail-arg
+						    arg-type:arg)
+						(vm:generic-args-vals ast)))
+			    (let*-values ([(L closure-label) 
+					   (closure-info (vm:generic-args-closure ast))]
+					  [(tail?) (vm:generic-args-tail? ast)]
+					  [(vals) (vm:generic-args-vals ast)]
+					  [(cl-case arglist) (select-case L (length (vm:generic-args-vals ast)))])
+			      (if (and closure-label
+				       cl-case
+				       (zodiac:list-arglist? arglist))
+				  
+				  ;; known function, fixed arity
+				  (if (not (satisfies-arity? (length (vm:generic-args-vals ast)) 
+							     L arglist))
+				      (begin 
+					((if (compiler:option:stupid) compiler:warning compiler:error )
+					 ast 
+					 "procedure called with wrong number of arguments")
+					(list (make-vm:args (zodiac:zodiac-stx ast)
+							    (if tail?
+								arg-type:tail-arg
+								arg-type:arg)
+							    vals)))
+				      
+				      (with-closure 
+				       (vm:generic-args-closure ast)
+				       cl-case
+
+				       ;; unknown function - could be at a level where an 
+				       ;; optimized jump is not allowed
+				       (lambda (_ __ ___ ____)
+					 (list (make-vm:args (zodiac:zodiac-stx ast)
+							     (if tail? 
+								 arg-type:tail-arg
+								 arg-type:arg)
+							     vals)))
+				       
+				       ;; known call
+				       (lambda (label cl-case L same-vehicle?)
+					 (list (make-vm:args (zodiac:zodiac-stx ast)
+							     (if tail?
+								 (if same-vehicle?
+								     arg-type:register
+								     arg-type:tail-arg)
+								 arg-type:arg)
+							     vals)))
+				       
+				       ;; known recursion
+				       ;; tail recursion we just optimize to 
+				       ;; set! of local variables
+				       (lambda (label cl-case L _)
+					 (if (not tail?)
+					     (list (make-vm:args (zodiac:zodiac-stx ast)
+								 arg-type:arg vals))
+					     (let ([bindings (zodiac:arglist-vars 
+							      (list-ref (zodiac:case-lambda-form-args L) 
+									cl-case))])
+					       (let loop ([bindings bindings][vals vals][set-ok? #f])
+						 (if (null? bindings)
+						     null
+						     (let* ([binding (car bindings)]
+							    [val (car vals)]
+							    [this-binding? 
+							     (lambda (val)
+							       (let loop ([val val])
+								 (or (and (vm:local-varref? val)
+									  (eq? (vm:local-varref-binding val)
+									       binding))
+								     (and (vm:deref? val)
+									  (loop (vm:deref-var val))))))])
+						       ;; If this is x = x, skip it.
+						       (if (this-binding? val)
+							   (loop (cdr bindings) (cdr vals) #f)
+							   
+							   ;; Check whether the binding we're about to set is needed later as a value.
+							   ;; If so, invent a new register
+							   (if (and (not set-ok?)
+								    (ormap this-binding? (cdr vals)))
+							       (let* ([rep (binding-rep (get-annotation binding))]
+								      [name (gensym)]
+								      [new-binding (let ([b (zodiac:make-binding 
+											     #f
+											     (make-empty-box)
+											     name name)])
+										     (set-annotation! b
+												      (make-binding #f #t #f #f #f #f #f #f #f
+														    (if (rep:pointer? rep)
+															(rep:pointer-to rep)
+															rep)))
+										     b)]
+								      [v (make-vm:local-varref #f name new-binding)])
+								 (add-local-var! new-binding)
+								 ;; Start over; replace uses of binding in vals with uses of new-binding
+								 (loop (cons new-binding bindings)
+								       (list* (let ([v (make-vm:local-varref 
+											#f
+											(zodiac:binding-var binding)
+											binding)])
+										(if (rep:pointer? rep)
+										    (make-vm:deref #f v)
+										    v))
+									      (car vals)
+									      (map
+									       (lambda (val)
+										 (if (this-binding? val)
+										     v
+										     val))
+									       (cdr vals)))
+								       #t))
+							       
+							       ;; Normal set
+							       (let*-values ([(vref) 
+									      (zodiac:binding->lexical-varref binding)]
+									     [(vm _) (vm-phase vref #f #f identity #f)]
+									     [(vm) (car (vm:sequence-vals vm))])
+								 (cons (make-vm:set! 
+									(zodiac:zodiac-stx val)
+									(list
+									 (cons target-type:lexical vm))
+									val
+									#f)
+								       (loop (cdr bindings) (cdr vals) #f)))))))))))))
+				  
+				  ;; unknown or variable arity function call - always use args
+				  (if (or (not closure-label)
+					  (and closure-label (satisfies-arity? (length vals) 
+									       L arglist)))
+				      
+				      (list (make-vm:args (zodiac:zodiac-stx ast)
+							  (if tail?
+							      arg-type:tail-arg
+							      arg-type:arg)
+							  vals))
+				      
+				      (begin
+					((if (compiler:option:stupid) compiler:warning compiler:error)
+					 ast
+					 "procedure called with wrong number of arguments")
+					(list (make-vm:args (zodiac:zodiac-stx ast)
+							    (if tail?
+								arg-type:tail-arg
+								arg-type:arg)
+							    vals)))))))]
+		       
+		       ;;--------------------------------------------------------------------
+		       ;; ARGS
+		       ;;
+		       ;; args that have already been assigned to register variables
+		       ;;
+		       [(vm:register-args? ast) (list ast)]
+
+		       ;;--------------------------------------------------------------------
+		       ;; SYNTAX! DEFINITIONS
+		       [(vm:syntax!? ast) 
+			(set-vm:syntax!-val! ast (car (process! (vm:syntax!-val ast))))
+			(list ast)]
+		       
+		       ;;====================================================================
+		       ;; R-VALUES (ONE STEP COMPUTATIONS)
+		       
+		       ;;--------------------------------------------------------------------
+		       ;; ALLOC EXPRESSION
+		       ;;
+		       [(vm:alloc? ast) (list ast)]
+		       
+		       ;;--------------------------------------------------------------------
+		       ;; BUILD-CONSTANT
+		       ;;
+		       [(vm:build-constant? ast) (list ast)]
+		       
+		       ;;--------------------------------------------------------------------
+		       ;; MAKE-CLOSURE, all kinds (wrap closure?)
+		       ;;
+		       [(vm:make-closure? ast) 
+			(set-vm:make-closure-closure! 
+			 ast
+			 (let ([cc (vm:make-closure-closure ast)])
+			   (and cc (car (process! cc)))))
+			(list ast)]
+		       
+		       ;;--------------------------------------------------------------------
+		       ;; APPLY EXPRESSION
+		       ;;
+		       ;; check for primitive applications
+		       ;; check for variable arity applications
+		       ;; check for applications that can return multiple values
+		       ;;
+		       [(vm:apply? ast)
+			(if (not (vm:apply-prim ast))
+			    (let*-values ([(closure) (vm:apply-closure ast)]
+					  [(L closure-label) (closure-info closure)]
+					  [(cl-case arglist) (select-case L (vm:apply-argc ast))]
+					  [(check-known-sv)
+					   (lambda ()
+					     (when (not (closure-code-return-multi
+							 (get-annotation L)))
+					; Known proc returns a single value, so we can
+					; use the more efficient multi call form
+					       (set-vm:apply-multi?! ast #t)))])
+			      (if (or (not cl-case)
+				      (and cl-case (not (zodiac:list-arglist? arglist)))
+				      (and cl-case (not (satisfies-arity? (vm:apply-argc ast) L arglist))))
+				  (list ast)
+				  
+				  (with-closure closure
+						cl-case
+						
+					; unknown application
+						(lambda (_ __ ___ ____) (list ast))
+						
+					; known call
+						(lambda (label _ __ ___) 
+						  (check-known-sv)
+						  (set-vm:apply-known?! ast #t)
+						  (list ast))
+						
+					; known recursion
+						(lambda (label _ __ ____) 
+						  (check-known-sv)
+						  (set-vm:apply-known?! ast #t)
+						  (list ast)))))
+			    (list ast))]
+
+
+		       [(vm:macro-apply? ast) (list ast)]
+
+		       ;;--------------------------------------------------------------------
+		       ;; MODULE CONSTRUCTION
+		       ;;
+		       [(vm:module-create? ast) (list ast)]
+		       
+		       ;;--------------------------------------------------------------------
+		       ;; WITH-CONTINUATION-MARK
+		       ;;
+		       [(vm:wcm-mark!? ast)
+			(set-vm:wcm-mark!-key! ast (car (process! (vm:wcm-mark!-key ast))))
+			(set-vm:wcm-mark!-val! ast (car (process! (vm:wcm-mark!-val ast))))
+			(list ast)]
+
+		       [(vm:wcm-push!? ast)
+			(set-vm:wcm-push!-var! ast (car (process! (vm:wcm-push!-var ast))))
+			(list ast)]
+
+		       [(vm:wcm-pop!? ast)
+			(set-vm:wcm-pop!-var! ast (car (process! (vm:wcm-pop!-var ast))))
+			(list ast)]
+		       
+		       [(vm:wcm-remember!? ast)
+			(set-vm:wcm-remember!-var! ast (car (process! (vm:wcm-remember!-var ast))))
+			(set-vm:wcm-remember!-val! ast (car (process! (vm:wcm-remember!-val ast))))
+			(list ast)]
+		       
+		       [(vm:wcm-extract? ast)
+			(set-vm:wcm-extract-var! ast (car (process! (vm:wcm-extract-var ast))))
+			(list ast)]
+		       
+		       ;;====================================================================
+		       ;; A-VALUES, L-VALUES, IMMEDIATES
+
+		       [(a-val/l-val/immediate? 
+			 ast)
+			(list ast)]
+		       
+		       [else
+			(compiler:internal-error 
+			 #f 
+			 (format "vm-optimize: unrecognized form ~a" ast))]))])
+	    (lambda (ast)
+	      (set! new-locs empty-set)
+	      (values
+	       (process! ast)
+	       new-locs))))))))
diff --git a/collects/compiler/private/vmphase.ss b/collects/compiler/private/vmphase.ss
new file mode 100644
index 0000000000..6f12941984
--- /dev/null
+++ b/collects/compiler/private/vmphase.ss
@@ -0,0 +1,1004 @@
+;; Scheme->VMScheme conversion phase
+;; (c) 1996-1997 Sebastian Good
+;; (c) 1997-2001 PLT, Rice University
+
+;; Takes a zodiac:* AST and produces a vm:* AST. Some
+;;  zodiac:* AST elements are still used, particularly
+;;  bindings and varrefs. 
+
+;; Well-applied known primitives are sometimes compiled
+;;  to macro uses (where the macros are defined in mzc.h).
+
+(module vmphase mzscheme 
+  (require (lib "unitsig.ss")
+	   (lib "list.ss")
+	   (lib "etc.ss"))
+
+  (require (lib "zodiac-sig.ss" "syntax")
+	   (lib "primitives.ss" "syntax"))
+
+  (require "sig.ss"
+	   "../sig.ss")
+
+  (provide vmphase@)
+  (define vmphase@
+    (unit/sig compiler:vmphase^
+      (import (compiler:option : compiler:option^)
+	      compiler:library^
+	      compiler:cstructs^
+	      (zodiac : zodiac^)
+	      compiler:zlayer^
+	      compiler:analyze^
+	      compiler:const^
+	      compiler:vmstructs^
+	      compiler:rep^
+	      compiler:closure^
+	      compiler:vehicle^
+	      compiler:driver^)
+
+      ;; vm:convert-bound-varref takes a bound-varref and turns it 
+      ;; into a vm:local-varref, taking into account its representation.
+      (define vm:convert-bound-varref
+	(lambda (ast)
+	  (let* ([ref (make-vm:local-varref
+		       (zodiac:zodiac-stx ast)
+		       (zodiac:varref-var ast)
+		       (zodiac:bound-varref-binding ast))]
+		 
+		 ;; this might not be true in the future, but it is true now
+		 [boxed? (rep:pointer?
+			  (binding-rep
+			   (compiler:bound-varref->binding ast)))]
+		 [ref (if boxed?
+			  (make-vm:deref #f ref)
+			  ref)])
+	    ref)))
+
+      (define (check-primitive-as-macro prim argc prim-k normal-k)
+	(if (and prim 
+		 (or (eq? prim 'for-syntax-in-env)
+		     (procedure-arity-includes? (dynamic-require 'mzscheme prim) argc)))
+	    (let* ([argc=? (lambda (x) (= x argc))]
+		   [special-bool (case prim
+				   [(eq?) "MZC_EQP"]
+				   [(eqv?) "MZC_EQVP"]
+				   [(equal?) "MZC_EQUALP"]
+				   [(null?) "MZC_NULLP"]
+				   [(pair?) "MZC_PAIRP"]
+				   [(not) "MZC_NOTP"]
+				   [(symbol?) "MZC_SYMBOLP"]
+				   [(string?) "MZC_STRINGP"]
+				   [(bytes?) "MZC_BYTESP"]
+				   [(vector?) "MZC_VECTORP"]
+				   [(number?) "MZC_NUMBERP"]
+				   [(procedure?) "MZC_PROCEDUREP"]
+				   [(char?) "MZC_CHARP"]
+				   [(eof-object?) "MZC_EOFP"]
+				   [(zero?) "MZC_ZEROP"]
+				   [(<) (and (argc=? 2) "MZC_LTP")]
+				   [(>) (and (argc=? 2) "MZC_GTP")]
+				   [(<=) (and (argc=? 2) "MZC_LTEP")]
+				   [(>=) (and (argc=? 2) "MZC_GTEP")]
+				   [(=) (and (argc=? 2) "MZC_EQLP")]
+				   [else #f])])
+	      (if special-bool
+		  (prim-k special-bool #t)
+		  (let ([special (case prim
+				   [(cons) "MZC_CONS"]
+				   [(list) (cond
+					      [(argc=? 1) "MZC_LIST1"]
+					      [(argc=? 2) "MZC_LIST2"]
+					      [else #f])]
+				   [(append) (and (argc=? 2) "MZC_APPEND")]
+				   [(car) "MZC_CAR"]
+				   [(cdr) "MZC_CDR"]
+				   [(cadr) "MZC_CADR"]
+				   [(cddr) "MZC_CDDR"]
+				   [(caar) "MZC_CAAR"]
+				   [(cdar) "MZC_CDAR"]
+				   [(caddr) "MZC_CADDR"]
+				   [(set-car!) "MZC_SET_CAR"]
+				   [(set-cdr!) "MZC_SET_CDR"]
+				   [(vector-ref) "MZC_VECTOR_REF"]
+				   [(vector-set!) "MZC_VECTOR_SET"]
+				   [(string-ref) "MZC_STRING_REF"]
+				   [(string-set!) "MZC_STRING_SET"]
+				   [(bytes-ref) "MZC_BYTES_REF"]
+				   [(bytes-set!) "MZC_BYTES_SET"]
+				   [(char->integer) "MZC_CHAR_TO_INTEGER"]
+				   [(add1) "MZC_ADD1"]
+				   [(sub1) "MZC_SUB1"]
+				   [(+) (and (argc=? 2) "MZC_PLUS2")]
+				   [(-) (and (argc=? 2) "MZC_MINUS2")]
+				   [(*) (and (argc=? 2) (compiler:option:fixnum-arithmetic) "MZC_TIMES2")]
+				   [(min) (and (argc=? 2) "MZC_MIN2")]
+				   [(max) (and (argc=? 2) "MZC_MAX2")]
+				   [(quotient) (and (argc=? 2) "MZC_QUOTIENT")]
+				   [(for-syntax-in-env) "MZC_FOR_SYNTAX_IN_ENV"]
+				   [else #f])])
+		    (if special
+			(prim-k special #f)
+			(normal-k)))))
+	    (normal-k)))
+
+
+      (define (simple-tail-prim? prim)
+	;; Since "simple" primitives don't end with a tail call,
+	;;  there's no harm in calling them directly when
+	;;  they're in a tail position. We avoid he overhead of
+	;;  a tail call this way.
+	(and prim (not (memq prim (internal-tail-chain-prims)))))
+
+      ;; vm-phase takes 2 arguments:
+      ;; 1) an s-expression to be transformed
+      ;; 2) a value which may be #f for non-tail transformation,
+      ;;    or a procedure to apply to a value found in tail position
+      ;; 3) a boolean value for whether this expression is in tail
+      ;;    position or not.
+      ;;
+      ;; and returns 2 values:
+      ;; 1) a vm-scheme sequence
+      ;; 2) new local variables introduced
+
+      (define vm-phase
+	(letrec 
+	    ([new-locals empty-set]
+	     [add-new-local! (lambda (l)
+			       (set! new-locals
+				     (set-union (list->set (list l)) new-locals)))]
+	     [make-record (lambda (pointer env-rep)
+			    (make-vm:set! #f (list (cons target-type:lexical pointer))
+					  (make-vm:alloc #f env-rep) #f))]
+	     [make-closure (lambda (leaf tail-pos tail? pointer vehicle L name closure-rep)
+			     (let ([m (cond
+				       [(zodiac:case-lambda-form? L)
+					(if (= 1 (length (zodiac:case-lambda-form-args L)))
+					    (let-values ([(min-arity max-arity)
+							  (compiler:formals->arity
+							   (car (zodiac:case-lambda-form-args L)))])
+					      (make-vm:make-procedure-closure #f
+									      pointer
+									      vehicle
+									      min-arity
+									      max-arity
+									      name
+									      (not closure-rep)
+									      (procedure-code-method? (get-annotation L))))
+					    (make-vm:make-case-procedure-closure #f
+										 pointer
+										 vehicle
+										 (length (zodiac:case-lambda-form-args L))
+										 (procedure-code-case-arities (get-annotation L))
+										 name
+										 (not closure-rep)
+										 (procedure-code-method? (get-annotation L))))]
+				       [else
+					(compiler:internal-error
+					 #f
+					 "unknown closure kind: ~a" L)])])
+			       (if tail-pos (leaf (tail-pos m)) (leaf m))))]
+	     
+	     [fill-label (lambda (pointer code)
+			   (if (vehicle:only-code-in-vehicle? code)
+			       null ; no label field in this case
+			       (list (make-vm:set!
+				      #f
+				      (list 
+				       (cons
+					target-type:lexical
+					(make-vm:struct-ref #f 'label 
+							    (make-vm:struct-ref #f 'data
+										(make-vm:deref #f 
+											       pointer)))))
+				      (make-vm:immediate #f (closure-code-label code))
+				      #f))))]
+
+	     [fill-env
+	      (lambda (pointer code)
+		(map (lambda (field var)
+		       (if (zodiac:binding? var)
+			   ;; Local variable
+			   (let* ([var (convert
+					(zodiac:binding->lexical-varref var)
+					#f
+					identity
+					#f
+					#f
+					#t)]
+				  ;; we have to copy pointers if necessary!
+				  [var (if (vm:deref? var)
+					   (vm:deref-var var)
+					   var)])
+			     (make-vm:set! #f 
+					   (list (cons
+						  target-type:lexical
+						  (make-vm:struct-ref #f 
+								      (rep:struct-field-name field)
+								      (make-vm:struct-ref #f 'data
+											  (make-vm:deref #f 
+													 pointer)))))
+					   var #f))
+			   ;; Propogate global bucket
+			   (let* ([var (cond
+					[(const:per-load-statics-table? 
+					  (rep:struct-field-orig-name field))
+					 (make-vm:per-load-statics-table #f)]
+					[(varref:module-invoke?
+					  (rep:struct-field-orig-name field))
+					 (make-vm:per-invoke-statics-table #f)]
+					[else
+					 (make-vm:bucket #f var)])])
+			     (make-vm:set! #f 
+					   (list (cons
+						  target-type:lexical
+						  (make-vm:struct-ref #f 
+								      (rep:struct-field-name field)
+								      (make-vm:struct-ref #f 'data
+											  (make-vm:deref #f 
+													 pointer)))))
+					   var #f))))
+		     (let ([fields (let ([cr (closure-code-rep code)])
+				     (if cr 
+					 (rep:struct-fields cr)
+					 null))])
+		       (if (vehicle:only-code-in-vehicle? code)
+			   fields
+			   (cdr fields))) ; knock the label field off
+		     (append (set->list (code-free-vars code))
+			     (set->list (code-global-vars code)))))]
+	     [convert
+	      (lambda (ast multi? leaf tail-pos tail? used?)
+		(when (compiler:option:debug)
+		  (zodiac:print-start! (debug:get-port) ast)
+		  (fprintf (debug:get-port) "~a~n" ast))
+		(cond
+		 
+		 ;;-----------------------------------------------------------------
+		 ;; BEGIN FORM
+		 ;;
+		 [(zodiac:begin-form? ast)
+		  (apply append!
+			 (begin-map!
+			  ;; non-tail, not used
+			  (lambda (b) (convert b 
+					       #t
+					       list 
+					       (lambda (x) (make-vm:void #f x))
+					       #f
+					       #f))
+			  ;; tail
+			  (lambda (b) (convert b multi? leaf tail-pos tail? used?))
+			  ;; list
+			  (zodiac:begin-form-bodies ast)))]
+		 
+		 ;;-----------------------------------------------------------------
+		 ;; BEGIN0 FORM
+		 ;;
+		 [(zodiac:begin0-form? ast)
+		  (let* ([var (convert (zodiac:binding->lexical-varref
+					(get-annotation ast))
+				       #f
+				       identity
+				       #f
+				       #f
+				       #t)]
+			 [first (convert (zodiac:begin0-form-first ast) 
+					 multi?
+					 (lambda (val) (list (make-vm:begin0-mark! #f var val)))
+					 #f #f #t)]
+			 [rest (convert (zodiac:begin0-form-rest ast) #t list #f #f #f)]
+			 [begin0-setup
+			  (make-vm:begin0-setup!
+			   (zodiac:zodiac-stx ast)
+			   var)]
+			 [begin0-extract
+			  (make-vm:begin0-extract
+			   (zodiac:zodiac-stx ast)
+			   var)])
+		    (append first
+			    (list begin0-setup)
+			    rest
+			    (if tail-pos
+				(leaf (tail-pos begin0-extract))
+				(leaf begin0-extract))))]
+
+		 ;;-----------------------------------------------------------------
+		 ;; IF FORM
+		 ;;
+		 [(zodiac:if-form? ast)
+		  (let ([test (convert (zodiac:if-form-test ast) #f list #f #f #t)]
+			[then (convert (zodiac:if-form-then ast) multi? leaf tail-pos tail? used?)]
+			[else (convert (zodiac:if-form-else ast) multi? leaf tail-pos tail? used?)])
+		    (list (make-vm:if     
+			   (zodiac:zodiac-stx ast)
+			   test
+			   (make-vm:sequence #f
+					     then)
+			   (make-vm:sequence #f
+					     else))))]
+		 
+		 ;;-----------------------------------------------------------------
+		 ;; LET FORM
+		 ;;
+		 ;; let forms are more complicated, since we have to reduce their
+		 ;; strength.  We send along a leaf function to set! the variable
+		 ;; to the result of the let.
+		 ;; if we are binding a variable that lives at the end of a pointer
+		 ;; make that box AFTER the calculation -- temporary variable needed
+		 ;; this is to avoid exposing box creation to call/cc
+		 ;; note that mv-application automatically creates a temporary
+		 ;; container
+		 ;;
+		 ;; let [x A] M --> (set! x A) M ...
+		 ;; let [x A] M, where A is mutable --> (set! t A) (set! x box) (set-box! x t)
+		 ;; let [x (A A*)] M --> {set up args, set! apply} M ...
+		 ;; let [x (if A M M)] M --> (if A M[t/set!] M[t/set!]) M ...
+		 ;; let [x (lambda)] M --> {make-closure,set!} M ...
+		 ;;
+		 [(zodiac:let-values-form? ast)
+		  (let* ([vars (map (lambda (vref)
+				      (cons
+				       target-type:lexical
+				       (convert (zodiac:binding->lexical-varref vref)
+						#f
+						identity
+						#f
+						#f
+						#t)))
+				    (car (zodiac:let-values-form-vars ast)))]
+			 [val (car (zodiac:let-values-form-vals ast))]
+			 [reps (map (lambda (bound)
+				      (binding-rep
+				       (get-annotation bound)))
+				    (car (zodiac:let-values-form-vars ast)))]
+			 [temps-needed? (ormap (lambda (zb)
+						 (let ([b (get-annotation zb)])
+						   (or (binding-mutable? b)
+						       (binding-letrec-set? b)
+						       (binding-letrec-set? b))))
+					       (car (zodiac:let-values-form-vars ast)))]
+			 [body (convert (zodiac:let-values-form-body ast) multi? leaf tail-pos tail? used?)])
+		    
+		    (if (not temps-needed?)
+			
+			(append! (convert val
+					  (not (= 1 (length vars)))
+					  (lambda (val) (list (make-vm:set! #f vars val #f)))
+					  #f
+					  #f
+					  #t)
+				 body)
+			
+			(let* ([tnames (map (lambda (_) (compiler:gensym)) vars)]
+			       [tbounds (map (lambda (name rep)
+					       (let ([b (zodiac:make-binding 
+							 #f
+							 (make-empty-box)
+							 name name)])
+						 (set-annotation! b
+								  (make-binding #f #t #f #f #f #f #f #f #f
+										(if (rep:pointer? rep)
+										    (rep:pointer-to rep)
+										    rep)))
+						 b))
+					     tnames
+					     reps)]			 
+			       [trefs (map (lambda (bound)
+					     (convert (zodiac:binding->lexical-varref bound) 
+						      #f
+						      identity
+						      #f
+						      #f
+						      #t))
+					   tbounds)]
+			       [set-temps
+				(convert val
+					 (not (= 1 (length vars)))
+					 (lambda (val)
+					   (list (make-vm:set! 
+						  #f
+						  (map (lambda (r) (cons target-type:lexical r)) trefs)
+						  val #f)))
+					 #f #f #t)]
+			       [make-boxes 
+				(apply append!
+				       (map (lambda (rep var)
+					      (if (rep:pointer? rep)
+						  (list 
+						   (make-vm:set! 
+						    #f
+						    (list (cons target-type:lexical
+								(vm:deref-var (cdr var))))
+						    (make-vm:alloc #f (rep:pointer-to rep))
+						    #f))
+						  null))
+					    reps
+					    vars))]
+			       
+			       [set-vars
+				(map (lambda (var tvar) (make-vm:set! #f (list var) tvar #f))
+				     vars
+				     trefs)])
+			  (for-each add-new-local! tbounds)
+			  (append! set-temps make-boxes set-vars body)) 		  
+			))]
+		 
+		 ;;-----------------------------------------------------------------
+		 ;; LETREC FORM
+		 ;;
+		 ;; allocate all closures first, then create closure objects, then
+		 ;; fill in the structs
+		 ;;
+		 ;; inline closure allocation (use closure-alloc-rep)
+		 ;; Handle non-lambdas because thunk-allocation optimization may
+		 ;; have taken place
+		 ;;
+		 [(zodiac:letrec-values-form? ast)
+		  (let* ([Ls (foldr (lambda (val l)
+				      (if (compiler:make-closure? val)
+					  (cons (compiler:make-closure-lambda val)
+						l)
+					  l))
+				    null
+				    (zodiac:letrec-values-form-vals ast))]
+			 [codes (map get-annotation Ls)]
+			 [closure-reps (map closure-code-rep codes)]
+			 [closure-alloc-reps (map closure-code-alloc-rep codes)]
+			 [vehicles (map closure-code-vehicle codes)]
+			 [new-bounds
+			  (map (lambda (closure-alloc-rep)
+				 (let* ([n (compiler:gensym)]
+					[b (zodiac:make-binding 
+					    #f
+					    (make-empty-box)
+					    n
+					    n)])
+				   (set-annotation! b
+						    (make-binding #f ;rec?
+								  #t ;mutable?
+								  #f ;unit-i/e?
+								  #f ;anchor
+								  #f ;letrec-set?
+								  #f ;ivar?
+								  #f ;known?
+								  #f ;val
+								  #f ;known-but-used?
+								  (make-rep:pointer closure-alloc-rep)))
+				   b))
+			       closure-alloc-reps)]
+			 [new-vars (map
+				    (lambda (b)
+				      (convert (zodiac:binding->lexical-varref b)
+					       #f
+					       identity
+					       #f
+					       #f
+					       #t))
+				    new-bounds)]
+			 [pointers (map vm:deref-var new-vars)]
+			 [vars (foldr (lambda (var val l)
+					(if (compiler:make-closure? val)
+					    (cons (convert (zodiac:binding->lexical-varref 
+							    (car var))
+							   #f
+							   identity
+							   #f
+							   #f
+							   #t)
+						  l)
+					    l))
+				      null
+				      (zodiac:letrec-values-form-vars ast)
+				      (zodiac:letrec-values-form-vals ast))]
+			 [names (foldr (lambda (var val l)
+					 (if (compiler:make-closure? val)
+					     (cons (compiler:make-closure-name val)
+						   l)
+					     l))
+				       null
+				       (zodiac:letrec-values-form-vars ast)
+				       (zodiac:letrec-values-form-vals ast))]
+			 [nonrec-assigns 
+			  (foldr (lambda (var val l)
+				   (if (compiler:make-closure? val)
+				       l
+				       (cons (make-vm:set! 
+					      #f
+					      (list (cons
+						     target-type:lexical
+						     (convert (zodiac:binding->lexical-varref 
+							       (car var))
+							      #f
+							      identity
+							      #f
+							      #f
+							      #t)))
+					      (convert val
+						       #f
+						       identity
+						       #f
+						       #f
+						       #t)
+					      #f)
+					     l)))
+				 null
+				 (zodiac:letrec-values-form-vars ast)
+				 (zodiac:letrec-values-form-vals ast))])
+		    (for-each add-new-local! new-bounds)
+		    (append!
+		     nonrec-assigns
+		     (map make-record pointers closure-alloc-reps)
+		     (map (lambda (var pointer vehicle L name closure-rep)
+			    (make-closure (lambda (c) (make-vm:set! #f
+								    (list (cons
+									   target-type:lexical
+									   var))
+								    c #f))
+					  #f
+					  #f
+					  pointer
+					  vehicle
+					  L
+					  name
+					  closure-rep))
+			  vars
+			  pointers
+			  vehicles
+			  Ls
+			  names
+			  closure-reps)
+		     (apply append (map fill-label pointers codes))
+		     (apply append! (map fill-env pointers codes))
+		     (convert (zodiac:letrec-values-form-body ast) multi? leaf tail-pos tail? used?)))]
+		 
+		 
+		 
+		 ;;-----------------------------------------------------------------
+		 ;; MAKE-CLOSURE FORM
+		 ;;
+		 ;; we make a struct, create the closure, then fill it in
+		 ;;
+		 ;; inline closure allocation (use closure-alloc-rep)
+		 [(compiler:make-closure? ast)
+		  (let* ([L (compiler:make-closure-lambda ast)]
+			 [name (compiler:make-closure-name ast)]
+			 [code (get-annotation L)]
+			 [label (closure-code-label code)]
+			 [closure-rep (closure-code-rep code)]
+			 [closure-alloc-rep (closure-code-alloc-rep code)]
+			 [vehicle (closure-code-vehicle code)]
+			 [n (compiler:gensym)]
+			 ;; a variable in which to construct the closure
+			 [new-bound 
+			  (if closure-alloc-rep
+			      (zodiac:make-binding 
+			       (zodiac:zodiac-stx L)
+			       (make-empty-box)
+			       n
+			       n)
+			      #f)]
+			 [_ (when new-bound
+			      (set-annotation! new-bound
+					       (make-binding #f ;rec?
+							     #t ;mutable?
+							     #f ;unit-i/e?
+							     #f ;anchor
+							     #f ;letrec-set?
+							     #f ;ivar?
+							     #f ;known?
+							     #f ;val
+							     #f ;known-but-used?
+							     (make-rep:pointer closure-alloc-rep))))]
+			 ;; the reference to the closure
+			 [new-var (and new-bound
+				       (convert (zodiac:binding->lexical-varref new-bound)
+						#f
+						identity
+						#f
+						#f
+						#t))]
+			 ;; the reference to the pointer to the closure
+			 [pointer (and new-var (vm:deref-var new-var))]
+			 
+			 ;; set up arguments to closure-maker
+			 [make-args (map (lambda (a) (convert a #f identity #f #f #t)) (compiler:make-closure-args ast))]
+			 [get-args (if (null? make-args)
+				       ()
+				       (list (make-vm:generic-args (zodiac:zodiac-stx ast)
+								   #f #f #f make-args)))])
+		    (set-closure-code-label! code label)
+		    (when new-bound
+		      (add-new-local! new-bound))
+		    `( ,@get-args
+		       ,@(if closure-alloc-rep
+			     (list (make-record pointer closure-alloc-rep))
+			     null)
+		       ,@(fill-label pointer code)
+		       ,@(fill-env pointer code)
+		       ,@(make-closure leaf 
+				       tail-pos 
+				       tail? 
+				       pointer
+				       vehicle
+				       L
+				       name
+				       closure-rep)))]
+		 
+		 ;;-----------------------------------------------------------------
+		 ;; SET! FORM
+		 ;;
+		 ;; we need to distinguish between setting a global & reffing it
+		 ;; if we are in tail position, we need to do the void thing
+		 ;;
+		 [(zodiac:set!-form? ast)
+		  (let* ([var (zodiac:set!-form-var ast)]
+			 [val (convert (zodiac:set!-form-val ast)
+				       #f
+				       identity #f #f #t)]
+			 [set!-exp
+			  (make-vm:set!		     
+			   (zodiac:zodiac-stx ast)
+			   (list (if (zodiac:top-level-varref? var)
+				     (cons target-type:global (compiler:add-global-varref! var))
+				     (cons target-type:lexical 
+					   (convert var
+						    #f
+						    identity
+						    #f
+						    #f
+						    #t))))
+			   val
+			   (if (zodiac:top-level-varref? var)
+			       (list "set!" 0)
+			       #f))])
+		    (if tail-pos
+			(cons set!-exp
+			      (leaf (tail-pos (make-vm:immediate #f
+								 (zodiac:make-special-constant 'void)))))
+			(if used?
+			    (cons set!-exp
+				  (leaf (make-vm:immediate #f
+							   (zodiac:make-special-constant 'void))))
+			    (leaf set!-exp))))]
+		 
+		 ;;-----------------------------------------------------------------
+		 ;; DEFINE FORM
+		 ;;
+		 ;; defines either introduce global bindings or initialize static 
+		 ;; bindings. They are all turned into set! here
+		 ;;
+		 [(zodiac:define-values-form? ast)	    
+		  (let* ([vars (zodiac:define-values-form-vars ast)]
+			 [val (zodiac:define-values-form-val ast)]
+			 [body
+			  (cond
+			   ;; DEFINE STATIC VARREF - written by compiler
+			   [(and (varref:has-attribute? (car vars) varref:static) (null? (cdr vars)))
+			    (convert val
+				     #f
+				     (lambda (val)
+				       (list
+					(make-vm:set! #f
+						      (list (cons
+							     target-type:static
+							     (convert (car vars) #f identity #f #f #t)))
+						      val #f)))
+				     #f
+				     #f
+				     #t)]
+			   
+			   ;; DEFINE GLOBAL VARREFS - user written
+			   [(and (andmap zodiac:top-level-varref? vars)
+				 (andmap (lambda (v)
+					   (not (varref:has-attribute? v varref:static)))
+					 vars))
+			    (convert val
+				     (not (= (length vars) 1))
+				     (lambda (val)
+				       (list
+					(make-vm:set! #f
+						      (map (lambda (v)
+							     (cons target-type:global
+								   (compiler:add-global-varref! v)))
+							   vars)
+						      val (list "define-values" 1))))
+				     #f
+				     #f
+				     #t)]
+			   
+			   [else (compiler:internal-error ast "bad define")])])
+		    
+		    (if tail-pos
+			(append! body
+				 (leaf (tail-pos 
+					(make-vm:immediate #f
+							   (zodiac:make-special-constant 'void)))))
+			(leaf body)))]
+
+		 
+		 ;;-----------------------------------------------------------------
+		 ;; DEFINE-SYNTAXES
+		 ;;
+		 [(zodiac:define-syntaxes-form? ast)	    
+		  (let* ([vars (zodiac:define-syntaxes-form-names ast)]
+			 [val (zodiac:define-syntaxes-form-expr ast)]
+			 [in-mod? (get-annotation ast)]
+			 [body
+			  (convert val
+				   ;; At top level, always multi, because 
+				   ;;  zero results => just decl
+				   (and in-mod?
+					(not (= (length vars) 1)))
+				   (lambda (val)
+				     (list
+				      (make-vm:syntax! #f
+						       vars
+						       val
+						       in-mod?)))
+				   #f
+				   #f
+				   #t)])
+
+		    (if tail-pos
+			(append! body
+				 (leaf (tail-pos 
+					(make-vm:immediate 
+					 #f
+					 (zodiac:make-special-constant 'void)))))
+			(leaf body)))]
+		 
+		 ;;-------------------------------------------------------------------
+		 ;; WITH-CONTINUATION-MARK
+		 ;;
+		 ;;
+		 [(zodiac:with-continuation-mark-form? ast)
+		  (let* ([wcm-var (get-annotation ast)]
+			 [var (and wcm-var
+				   (convert (zodiac:binding->lexical-varref wcm-var)
+					    #f
+					    identity
+					    #f
+					    #f
+					    #t))]
+			 [key (convert (zodiac:with-continuation-mark-form-key ast) #f identity #f #f #t)]
+			 [val (convert (zodiac:with-continuation-mark-form-val ast) #f identity #f #f #t)]
+			 [body (convert (zodiac:with-continuation-mark-form-body ast)
+					multi?
+					(lambda (val) 
+					  (if var
+					      (list (make-vm:wcm-remember!
+						     (zodiac:zodiac-stx ast)
+						     var val))
+					      (leaf val)))
+					(and (not wcm-var) tail-pos)
+					(and (not wcm-var) tail?)
+					used?)]
+			 [extract
+			  (and wcm-var
+			       (make-vm:wcm-extract
+				(zodiac:zodiac-stx ast)
+				var))]
+			 [mark (make-vm:wcm-mark!
+				(zodiac:zodiac-stx ast)
+				key val)]
+			 [push (and wcm-var
+				    (make-vm:wcm-push!
+				     (zodiac:zodiac-stx ast)
+				     var))]
+			 [pop (and wcm-var
+				   (make-vm:wcm-pop!
+				    (zodiac:zodiac-stx ast)
+				    var))])
+		    (if wcm-var
+			
+			(append (list push mark)
+				body 
+				(list pop)
+				(if tail-pos
+				    (leaf (tail-pos extract))
+				    (leaf extract)))
+			
+			(cons mark body)))]
+		 
+		 ;;-----------------------------------------------------------------
+		 ;; APPLICATIONS
+		 ;;
+		 ;; distinguish between tail & non-tail calls
+		 ;; implement tail calls to "simple" primitives a regular calls
+		 ;; no need to pass anything to tail here because it's already
+		 ;;  a tail value if its a tail-apply
+		 ;; the vm-optimizer will refine the multi-ness of this application,
+		 ;;  and worry about inter & intra-vehicle calls
+		 ;;
+		 [(zodiac:app? ast)
+		  (unless (eq? tail? (app-tail? (get-annotation ast))) 
+		    (compiler:internal-error 
+		     ast 
+		     "vmscheme: annotated tail? (= ~a) does not match calculated tail? (= ~a)"
+		     (app-tail? (get-annotation ast)) tail?))
+		  (let* ([prim (let* ([fun (zodiac:app-fun ast)]
+				      [name (and (zodiac:varref? fun)
+						 (zodiac:varref-var fun))])
+				 (and (zodiac:top-level-varref? fun)
+				      (or (and (varref:has-attribute? fun varref:primitive)
+					       (let ([v (dynamic-require 'mzscheme name)])
+						 (or (primitive? v) 
+						     (primitive-closure? v)))
+					       (zodiac:varref-var fun))
+					  (and (identifier? (zodiac:zodiac-stx fun))
+					       (module-identifier=? (zodiac:zodiac-stx fun) 
+								    for-syntax-in-env-stx)
+					       'for-syntax-in-env))))]
+			 [simple-tail-prim? (and tail? (simple-tail-prim? prim))]
+			 [closure (convert (zodiac:app-fun ast) #f identity #f #f #t)]
+			 [args (zodiac:app-args ast)]
+			 [argc (length args)]
+			 [converted-args
+			  (map (lambda (A)
+				 (convert A #f identity #f #f #t))
+			       args)])
+		    (check-primitive-as-macro
+		     prim argc
+		     (lambda (special bool?)
+		       (let* ([arg-locals (map (lambda (x)
+						 (let* ([name (gensym 'macapply)]
+							[b (zodiac:make-binding 
+							    #f
+							    (make-empty-box)
+							    name name)])
+						   (set-annotation! b
+								    (make-binding #f #t #f #f #f #f #f #f #f
+										  (make-rep:atomic 'scheme-object)))
+						   b))
+					       args)])
+			 (for-each add-new-local! arg-locals)
+			 (cons (make-vm:register-args (zodiac:zodiac-stx ast)
+						      arg-locals
+						      converted-args)
+			       (leaf (make-vm:macro-apply (zodiac:zodiac-stx ast)
+							  special
+							  closure
+							  arg-locals
+							  tail?
+							  bool?)))))
+		     (lambda ()
+		       (cons (make-vm:generic-args (zodiac:zodiac-stx ast)
+						   closure
+						   (and tail? (not simple-tail-prim?))
+						   prim
+						   converted-args)
+			     (if tail?
+				 (if simple-tail-prim?
+				     (leaf (make-vm:apply
+					    (zodiac:zodiac-stx ast)
+					    closure 
+					    argc
+					    #f 
+					    #t ; tail-call: multi always ok
+					    prim
+					    #t))
+				     (leaf (make-vm:tail-apply
+					    (zodiac:zodiac-stx ast)
+					    closure
+					    argc
+					    prim)))
+				 (leaf (make-vm:apply
+					(zodiac:zodiac-stx ast)
+					closure 
+					argc
+					#f 
+					multi?
+					prim
+					#f)))))))]
+		 
+		 
+		 ;;-----------------------------------------------------------------
+		 ;; VARREFS
+		 ;;
+		 ;; Variables might be boxes, in which case we must turn
+		 ;; them into derefs
+		 ;; Env-varrefs have already been pulled into registers for us
+		 ;; varrefs might be in tail position, so we need to convert them
+		 ;; to tail statements.
+		 ;;
+		 [(zodiac:bound-varref? ast)
+		  (let ([vm-ref (vm:convert-bound-varref ast)])
+		    (if tail-pos
+			(leaf (tail-pos vm-ref))
+			(leaf vm-ref)))]
+		 
+		 ;; will change when representations can be chosen 
+		 ;; for static variables
+		 [(zodiac:top-level-varref? ast)
+		  (let* ([ignore-ast (lambda (maker)
+				       (lambda (a d ast)
+					 (maker a d)))]
+			 [convert-global (lambda (maker)
+					   (lambda (a d ast)
+					     (maker a (compiler:add-global-varref! ast))))]
+			 [maker 
+			  (cond
+			   [(top-level-varref/bind-from-lift? ast)
+			    (lambda (a d ast)
+			      ((if (top-level-varref/bind-from-lift-pls? ast)
+				   (if (varref:module-invoke? (top-level-varref/bind-from-lift-pls? ast))
+				       make-vm:per-invoke-static-varref-from-lift
+				       make-vm:per-load-static-varref-from-lift)
+				   make-vm:static-varref-from-lift)
+			       a d (top-level-varref/bind-from-lift-lambda ast)))]
+			   [(varref:has-attribute? ast varref:per-load-static)
+			    (ignore-ast make-vm:per-load-static-varref)]
+			   [(varref:has-attribute? ast varref:per-invoke-static)
+			    (ignore-ast make-vm:per-invoke-static-varref)]
+			   [(varref:has-attribute? ast varref:primitive)
+			    (convert-global make-vm:primitive-varref)]
+			   [(varref:has-attribute? ast varref:symbol)
+			    (ignore-ast make-vm:symbol-varref)]
+			   [(varref:has-attribute? ast varref:inexact)
+			    (ignore-ast make-vm:inexact-varref)]
+			   [(varref:has-attribute? ast varref:static)
+			    (ignore-ast make-vm:static-varref)]
+			   [else
+			    (convert-global make-vm:global-varref)])])
+		    (let ([ref (maker #f (zodiac:varref-var ast) ast)])
+		      (if tail-pos
+			  (leaf (tail-pos ref))
+			  (leaf ref))))]
+		 
+		 ;;-----------------------------------------------------------------
+		 ;; CONSTANTS
+		 ;;
+		 [(zodiac:quote-form? ast)
+		  (let* ([const (zodiac:quote-form-expr ast)]
+			 [stx (or (zodiac:zodiac-stx ast) (zodiac:zodiac-stx const))]
+			 [vm ((if (vm:literal-constant? const) 
+				  (lambda (n)
+				    (make-vm:immediate stx n))
+				  (lambda (n)
+				    (make-vm:build-constant stx n)))
+			      const)])
+		    (if tail-pos
+			(leaf (tail-pos vm))
+			(leaf vm)))]
+		 
+		 ;;-----------------------------------------------------------------
+		 ;; MODULE
+		 ;;
+		 ;;  If we get here, this is the module construction/registration
+		 ;;
+		 [(zodiac:module-form? ast)
+		  (let ([vm (make-vm:module-create
+			     (zodiac:zodiac-stx ast)
+			     ;; constant reprsenting the module form:
+			     (car (convert (zodiac:module-form-body ast) #f list #f #f #t))
+			     (varref:module-invoke-id (module-info-invoke (get-annotation ast))))])
+		    (if tail-pos
+			(leaf (tail-pos vm))
+			(leaf vm)))]
+
+		 [else 
+		  (compiler:internal-error 
+		   ast 
+		   (format "vm-phase: form not supported ~a" ast))]))])
+	  
+	  (lambda (ast multi? leaf tail-pos tail?)
+	    (set! new-locals empty-set)
+	    ;; l->r evaluation necessary for convert to get called before new-locals
+	    ;; is evaluated
+	    (values ((if (zodiac:module-form? ast)
+			 (let ([info (get-annotation ast)])
+			   (if (eq? 'constructor (module-info-part info))
+			       make-vm:sequence
+			       (lambda (stx vals)
+				 (make-vm:module-body
+				  stx vals
+				  (module-info-invoke info)
+				  (eq? 'syntax-body (module-info-part info))))))
+			 make-vm:sequence)
+		     (zodiac:zodiac-stx ast)
+		     (convert (if (and (zodiac:module-form? ast)
+				       (not (eq? 'constructor (module-info-part (get-annotation ast)))))
+				  (zodiac:module-form-body ast)
+				  ast)
+			      multi? (or leaf list) tail-pos tail? (not tail?)))
+		    new-locals)))))))
diff --git a/collects/compiler/private/vmscheme.ss b/collects/compiler/private/vmscheme.ss
new file mode 100644
index 0000000000..7428f42d04
--- /dev/null
+++ b/collects/compiler/private/vmscheme.ss
@@ -0,0 +1,207 @@
+;; VM-Scheme
+;; (c) 1996-1997 Sebastian Good
+;; (c) 1997-2001 PLT
+
+;; Mostly structure definitions for VM AST nodes.
+
+(module vmscheme mzscheme
+  
+  (require (lib "unitsig.ss")
+	   (lib "list.ss")
+	   (lib "etc.ss"))
+
+  (require (lib "zodiac-sig.ss" "syntax"))
+
+  (require "sig.ss")
+  (require "../sig.ss")
+
+  (provide vmscheme@)
+  (define vmscheme@
+    (unit/sig compiler:vmstructs^
+      (import compiler:library^
+	      compiler:cstructs^
+	      (zodiac : zodiac^)
+	      compiler:zlayer^
+	      compiler:driver^)
+
+      ;; Block statements
+      (define-struct (vm:sequence zodiac:zodiac) (vals))
+      (define-struct (vm:if zodiac:zodiac) (test then else))
+      (define-struct (vm:module-body zodiac:zodiac) (vals invoke syntax?))
+
+      ;; Tail position statements
+      (define-struct (vm:void zodiac:zodiac) (val))
+      (define-struct (vm:return zodiac:zodiac) (val))
+      (define-struct (vm:tail-apply zodiac:zodiac) (closure argc prim))
+      (define-struct (vm:tail-call zodiac:zodiac) (label closure set-env?))
+      (define-struct (vm:continue zodiac:zodiac) ())
+
+      ;; non-tail imperative statements
+      (define-struct (vm:set! zodiac:zodiac) (vars val mode))
+      (define-struct (vm:generic-args zodiac:zodiac) (closure tail? prim vals))
+      (define-struct (vm:register-args zodiac:zodiac) (vars vals))
+      (define-struct (vm:args zodiac:zodiac) (type vals))
+      (define-struct (vm:begin0-mark! zodiac:zodiac) (var val))
+      (define-struct (vm:begin0-setup! zodiac:zodiac) (var))
+      (define-struct (vm:syntax! zodiac:zodiac) (vars val in-mod?))
+
+      ;; r-values (1 step computations)
+      (define-struct (vm:alloc zodiac:zodiac) (type))
+      (define-struct (vm:build-constant zodiac:zodiac) (text))
+      (define-struct (vm:make-closure zodiac:zodiac) (closure))
+      (define-struct (vm:make-procedure-closure vm:make-closure)
+	(vehicle min-arity max-arity name empty? method?))
+      (define-struct (vm:make-case-procedure-closure vm:make-closure)
+	(vehicle num-cases case-arities name empty? method?))
+      (define-struct (vm:apply zodiac:zodiac) 
+	(closure argc known? multi? prim simple-tail-prim?))
+      (define-struct (vm:macro-apply zodiac:zodiac) 
+	(name primitive args tail? bool?))
+      (define-struct (vm:call zodiac:zodiac) (label closure))
+      (define-struct (vm:begin0-extract zodiac:zodiac) (var))
+      (define-struct (vm:wcm-mark! zodiac:zodiac) (key val))
+      (define-struct (vm:wcm-push! zodiac:zodiac) (var))
+      (define-struct (vm:wcm-pop! zodiac:zodiac) (var))
+      (define-struct (vm:wcm-remember! zodiac:zodiac) (var val))
+      (define-struct (vm:wcm-extract zodiac:zodiac) (var))
+      (define-struct (vm:check-global zodiac:zodiac) (var))
+      (define-struct (vm:module-create zodiac:zodiac) (shape id))
+
+      ;; a-values
+      (define-struct (vm:global-varref zodiac:zodiac) (var))
+      (define-struct (vm:bucket zodiac:zodiac) (var))
+      (define-struct (vm:per-load-statics-table zodiac:zodiac) ())
+      (define-struct (vm:per-invoke-statics-table zodiac:zodiac) ())
+      (define-struct (vm:cast zodiac:zodiac) (val rep)) ; last resort
+
+      ;; l-values (locations in memory)
+      (define-struct (vm:local-varref zodiac:zodiac) (var binding))
+      (define-struct (vm:static-varref zodiac:zodiac) (var))
+      (define-struct (vm:static-varref-from-lift vm:static-varref) (lambda))
+      (define-struct (vm:per-load-static-varref vm:static-varref) ())
+      (define-struct (vm:per-invoke-static-varref vm:static-varref) ())
+      (define-struct (vm:per-load-static-varref-from-lift vm:per-load-static-varref) (lambda))
+      (define-struct (vm:per-invoke-static-varref-from-lift vm:per-invoke-static-varref) (lambda))
+      (define-struct (vm:primitive-varref zodiac:zodiac) (var))
+      (define-struct (vm:symbol-varref zodiac:zodiac) (var))
+      (define-struct (vm:inexact-varref zodiac:zodiac) (var))
+      (define-struct (vm:struct-ref zodiac:zodiac) (field var))
+      (define-struct (vm:deref zodiac:zodiac) (var))
+      (define-struct (vm:ref zodiac:zodiac) (var))
+
+      ;; immediate values
+      (define-struct (vm:immediate zodiac:zodiac) (text))
+
+      ;; defines a structure type
+      ;; all structures may be indexed by number as well.
+      (define-struct vm:struct-type (fields))
+
+      (define vm:box-struct-type (make-vm:struct-type '(box)))
+
+      ;; argument types
+      (define arg-type:register 'arg-type:register)
+      (define arg-type:arg 'arg-type:arg)
+      (define arg-type:tail-arg 'arg-type:tail-arg)
+
+      ;; set!-target types
+      (define target-type:global 'target-type:global)
+      (define target-type:lexical 'target-type:lexical)
+      (define target-type:static target-type:lexical)
+
+      ;; this is the class of statements that make control leave the block
+      (define vm:control-return?
+	(one-of vm:return? vm:tail-apply? vm:tail-call? vm:continue?))
+
+      ;; Defines fixnumness in the VM Scheme.  
+      ;; may change under different implementations; and will certainly
+      ;; need to change as things get unwrapped...
+      (define vm:fixnum?
+	(lambda (n)
+	  (and (exact? n) (integer? n) (< n (expt 2 30)) (> n (- (expt 2 30))))))
+
+      ;; This function defines whether a constant must be built or not.
+      ;; This functions answers #t to constants that may just appear 
+      ;; as constants in VM Scheme.
+      (define vm:literal-constant?
+	(let ([p? (one-of (all-of number? vm:fixnum?)
+			  null?
+			  boolean?
+			  char?
+			  void?
+			  undefined?)])
+	  (lambda (i)
+	    (p? (syntax-e (zodiac:zodiac-stx i)))))))))
+
+#|
+
+(define vm:vm->sexp
+  (lambda (ast)
+    (cond
+     [(vm:sequence? ast) `(sequence ,@(map vm:vm->sexp (vm:sequence-vals ast)))]
+     [(vm:if? ast) `(if ,(vm:vm->sexp (vm:if-test ast))
+			,(vm:vm->sexp (vm:if-then ast))
+			,(vm:vm->sexp (vm:if-else ast)))]
+     [(vm:void? ast) `(void ,(vm:vm->sexp (vm:void-val ast)))]
+     [(vm:return? ast) `(return ,(vm:vm->sexp (vm:return-val ast)))]
+     [(vm:tail-apply? ast) `(tail-apply ,(vm:vm->sexp (vm:tail-apply-closure ast))
+					(argc ,(vm:tail-apply-argc ast))
+					(prim ,(vm:tail-apply-prim ast)))]
+     [(vm:tail-call? ast) `(tail-call ,label (set-env? ,(vm:tail-call-set-env? ast)))]
+     [(vm:continue? ast) '(continue)]
+     [(vm:set!? ast) `(set! ,@(map (lambda (v)
+				     `(,(car v) ,(vm:vm->sexp (cdr v))))
+				   (vm:set!-vars ast))
+			    ,(vm:vm->sexp (vm:set!-val ast)))]
+     [(vm:generic-args? ast) 
+      `(generic-args (tail? ,(vm:generic-args-tail? ast))
+		     (prim ,(vm:generic-args-prim ast))
+		     (vals ,@(map vm:vm->sexp (vm:generic-args-vals ast))))]
+     [(vm:args? ast)
+      `(args (type ,(vm:args-type ast)) (vals ,@(map vm:vm->sexp (vm:args-vals ast))))]
+     [(vm:struct? ast)
+      (let ([super (vm:struct-super ast)])
+	`(struct ,(vm:struct-type ast)
+		 ,(if super (vm:vm->sexp (vm:struct-super ast)) #f)
+		 ,(vm:struct-fields ast)))]
+     [(vm:alloc? ast)
+      `(alloc ,(rep->sexp (vm:alloc-type ast)))]
+     
+     [(vm:build-constant? ast)
+      `(build-constant ,(zodiac:zread-object (vm:build-constant-text ast)))]
+     [(vm:make-procedure-closure? ast)
+      `(make-procedure-closure ,(vm:vm->sexp (vm:make-closure-closure ast))
+			       ,(vm:make-closure-min-arity ast)
+			       ,(vm:make-closure-max-arity ast))]
+     [(vm:apply? ast)
+      `(apply ,(vm:vm->sexp (vm:apply-closure ast))
+	      (argc ,(vm:apply-argc ast))
+	      (known? ,(vm:apply-known? ast))
+	      (multi? ,(vm:apply-multi? ast))
+	      (prim ,(vm:apply-prim ast)))]
+     [(vm:call? ast)
+      `(call ,(vm:call-label ast))]
+     [(vm:global-varref? ast)
+      `(global-varref ,(vm:global-varref-var ast))]
+     [(vm:local-varref? ast)
+      `(local-varref ,(vm:local-varref-var ast))]
+     [(vm:static-varref? ast)
+      `(static-varref ,(vm:static-varref-var ast))]
+     [(vm:primitive-varref? ast) 
+      `(primitive-varref ,(vm:primitive-varref-var ast))]
+     [(vm:struct-ref? ast)
+      `(struct-ref ,(vm:struct-ref-field ast)
+		   ,(vm:vm->sexp (vm:struct-ref-var ast)))]
+     [(vm:deref? ast)
+      `(deref ,(vm:vm->sexp (vm:deref-var ast)))]
+     [(vm:ref? ast)   
+      `(ref ,(vm:vm->sexp (vm:ref-var ast)))] 
+     [(vm:immediate? ast)
+      (let ([text (vm:immediate-text ast)])
+	`(immediate ,(cond [(number? text)
+			    `(label ,text)]
+			   [(zodiac:zread? text)
+			    (zodiac:zread-object text)]
+			   [else (error 'vm:vm->sexp "~a bad immediate text" text)])))]
+     [else
+      (error 'vm:vm->sexp "~a not supported" ast)])))
+|#
diff --git a/collects/compiler/private/winicon.ss b/collects/compiler/private/winicon.ss
new file mode 100644
index 0000000000..3ec16161fe
--- /dev/null
+++ b/collects/compiler/private/winicon.ss
@@ -0,0 +1,855 @@
+
+(module winicon mzscheme
+  (require (lib "list.ss"))
+  (provide install-icon
+	   extract-icons
+	   parse-icon
+	   build-icon)
+
+  (define (byte->integer p)
+    (read-byte p))
+  (define (word->integer p)
+    (integer-bytes->integer (read-bytes 2 p) #f #f))
+  (define (dword->integer p)
+    (integer-bytes->integer (read-bytes 4 p) #f #f))
+  
+  ;; The 0 added in the alpha position apparently means "ignore the alpha
+  ;;  and use the mask, instead"
+  (define (3/2word->integer p)
+    (integer-bytes->integer (bytes-append (read-bytes 3 p) #"\0") #f #f))
+
+  (define (integer->word i p)
+    (display (integer->integer-bytes i 2 #f #f) p))
+  (define (integer->dword i p)
+    (display (integer->integer-bytes i 4 #f #f) p))
+
+  (define (flag v)
+    (positive? (bitwise-and #x80000000 v)))
+  (define (value v)
+    (bitwise-and #x7FFFFFFF v))
+
+  (define (skip-to-image-headers-after-signature p)
+    ;; p is expected to be a file port
+    (file-position p 60)
+    (let ([pos (word->integer p)])
+      ;; pos points to IMAGE_NT_HEADERS
+      (file-position p pos)
+      (unless (= #x4550 (dword->integer p))
+	      (error "bad signature"))
+      pos))
+
+  (define (get-image-base p)
+    (let ([pos (skip-to-image-headers-after-signature p)])
+      (file-position p (+ 4
+			  20
+			  28))
+      (dword->integer p)))
+
+  (define (find-section p find-name)
+    (let ([pos (skip-to-image-headers-after-signature p)])
+      (word->integer p) ; skip machine
+      (let ([num-sections (word->integer p)]
+	    [_ (begin (dword->integer p)
+		      (dword->integer p)
+		      (dword->integer p))]
+	    [size (word->integer p)])
+	(let ([pos (+ pos
+		      4       ; Signature : DWORD
+		      20      ; FileHeader: IMAGE_FILE_HEADER
+		      size)]) ; "optional" header
+	  (let sloop ([section 0][section-pos pos])
+	    (if (= section num-sections)
+		(error 'find-section "can't find section: ~e" find-name)
+		(begin
+		  (file-position p section-pos)
+		  ;; p points to an IMAGE_SECTION_HEADER
+		  (let ([name (read-bytes 8 p)])
+		    (if (bytes=? find-name name)
+			(let ([_ (dword->integer p)]) ; skip
+			  (values (dword->integer p)  ; virtual address
+				  (dword->integer p)  ; length
+				  (dword->integer p))); file pos
+			(sloop (add1 section) (+ section-pos 40)))))))))))
+  
+  (define (find-rsrc-start p re:rsrc)
+    (let-values ([(rsrc-virtual-addr rsrc-len rsrc-pos)
+		  (find-section p #".rsrc\0\0\0")])
+      (let loop ([dir-pos 0][path ""])
+	(file-position p (+ rsrc-pos dir-pos 12))
+	(let ([num-named (word->integer p)]
+	      [num-ided (word->integer p)])
+	  (let iloop ([i 0])
+	    (if (= i (+ num-ided num-named))
+		#f
+		(let ([name-delta (dword->integer p)]
+		      [data-delta (dword->integer p)]
+		      [next (file-position p)])
+		  (or (let ([name (if (flag name-delta)
+				      (begin
+					(file-position p (+ rsrc-pos (value name-delta)))
+					(let* ([len (word->integer p)])
+					  ;; len is in unicode chars...
+					  (let ([unistr (read-bytes (* 2 len) p)])
+					    ;; Assume it fits into ASCII...
+					    (regexp-replace* "\0" 
+							     (bytes->string/latin-1 unistr)
+							     ""))))
+				      (value name-delta))])
+			;;(printf "Name: ~a~a = ~a~n" path name (+ rsrc-pos (value data-delta)))
+			(let ([full-name (format "~a~a" path name)])
+			  (if (flag data-delta)
+			      (loop (value data-delta) (string-append full-name "."))
+			      ;; Found the icon?
+			      (and (regexp-match re:rsrc full-name)
+				   ;; Yes, so read IMAGE_RESOURCE_DATA_ENTRY
+				   (begin
+				     (file-position p (+ rsrc-pos (value data-delta)))
+				     (cons
+				      (+ (dword->integer p)           ; offset (an RVA)
+					 (- rsrc-pos
+					    rsrc-virtual-addr))
+				      (dword->integer p)))))))        ; size
+		      (begin
+			(file-position p next)
+			(iloop (add1 i)))))))))))
+
+  ;; >>> Probably doesn't work <<<
+  (define (find-import-names p)
+    (let-values ([(seg-virtual-addr seg-len seg-pos)
+		  (find-section p #".idata\0\0")])
+      (let loop ([pos seg-pos])
+	;; pos points to an IMAGE_IMPORT_DESCRIPTOR;
+	;; skip first 4 fields
+	(file-position p pos)
+	(if (zero? (dword->integer p)) ; 0 is terminator
+	    null
+	    (begin
+	      (dword->integer p)
+	      (dword->integer p)
+	      ;; next field is name
+	      (let ([name-pos (+ (dword->integer p) ; RVA to nul-terminated name
+				 (- seg-pos seg-virtual-addr))])
+		(file-position p name-pos)
+		(let ([name (regexp-match "^[^\0]*" p)])
+		  (cons (cons (car name) name-pos)
+			(loop (+ pos 20))))))))))
+
+  ;; >>> Doesn't work <<<
+  (define (find-delay-loads p)
+    (let-values ([(seg-virtual-addr seg-len seg-pos)
+		  (find-section p #".text\0\0")])
+    (let ([pos (skip-to-image-headers-after-signature p)]
+	  [image-base (get-image-base p)])
+      (let ([pos (+ pos
+		    4       ; Signature : DWORD
+		    20      ; FileHeader: IMAGE_FILE_HEADER
+		    96      ; IMAGE_OPTIONAL_HEADER up to directory
+		    104)]   ; skip 13 directory entries
+	    [vdelta image-base])
+	(file-position p pos)
+	(let loop ([delay-pos (dword->integer p)])
+	  (printf "~a ~a~n" delay-pos vdelta)
+	  (file-position p (+ delay-pos vdelta))
+	  (dword->integer p) ; skip attributes
+	  (let ([name-pos (dword->integer p)])
+	    (printf "~a ~a~n" name-pos vdelta)
+	    (file-position p (+ name-pos vdelta))
+	    (let ([name (regexp-match "^[^\0]*" p)])
+	      (printf "~a~n" name))))))))
+
+  (define-struct icon (desc data))
+  ;; desc is (list width height colors 0 planes bitcount)
+  ;; data is (cons pos string)
+  
+  (define (num-colors l)
+    (let ([n (caddr l)])
+      (if (zero? n)
+          (arithmetic-shift 1 (list-ref l 5))
+          n)))
+  
+  (define (install-icon exe-file ico-file . extra-icons)
+    (let ([ico-icons (append (if ico-file 
+                                 (extract-icons ico-file)
+                                 null)
+                             extra-icons)]
+	  [exe-icons (extract-icons exe-file)])
+      (let ([p (open-output-file exe-file 'update)])
+	(dynamic-wind
+	 void
+	 (lambda ()
+	   (for-each (lambda (exe-icon)
+                       (let ([best-ico-icon
+                              ;; Find exact match?
+                              (ormap (lambda (ico-icon)
+                                       (let ([le (icon-desc exe-icon)]
+                                             [li (icon-desc ico-icon)])
+                                         (and (= (car li) (car le))
+                                              (= (cadr li) (cadr le))
+                                              (= (num-colors li) (num-colors le))
+                                              (= (bytes-length (cdr (icon-data exe-icon)))
+                                                 (bytes-length (cdr (icon-data ico-icon))))
+                                              ico-icon)))
+                                     ico-icons)])
+                         (let ([ico-icon (or best-ico-icon
+                                             ;; Look for a conversion, if we
+                                             ;; need a 16x16, 32x32, or 48x48
+                                             ;; icon
+                                             (and
+                                              (= (car (icon-desc exe-icon))
+                                                 (cadr (icon-desc exe-icon)))
+                                              (memq (car (icon-desc exe-icon))
+                                                    '(16 32 48))
+                                              (let ([biggest-colorest #f])
+                                                (for-each 
+						 (lambda (ico-icon)
+						   (let ([w (car (icon-desc ico-icon))]
+							 [exew (car (icon-desc exe-icon))])
+						     (when (and
+							    (= w
+							       (cadr (icon-desc ico-icon)))
+							    (memq w '(16 32 48))
+							    (or
+							     (not biggest-colorest)
+							     (and (= w exew)
+								  (not (= exew (car (icon-desc biggest-colorest)))))
+							     (and (= w exew)
+								  (> (num-colors (icon-desc ico-icon))
+								     (num-colors (icon-desc biggest-colorest))))
+							     (and (not (= exew (car (icon-desc biggest-colorest))))
+								  (or (> w (car (icon-desc biggest-colorest)))
+								      (> (num-colors (icon-desc ico-icon))
+									 (num-colors (icon-desc biggest-colorest)))))))
+							   (set! biggest-colorest ico-icon))))
+						 ico-icons)
+                                                (and
+                                                 biggest-colorest
+                                                 ;; Convert...
+                                                 (let* ([src-size (car (icon-desc biggest-colorest))]
+							[dest-size (car (icon-desc exe-icon))]
+							[src (parse-icon biggest-colorest)]
+							[image (list-ref src 3)]
+							[mask (list-ref src 4)]
+							[has-alpha? (<= 256 (num-colors (icon-desc biggest-colorest)))])
+						   (if (= src-size dest-size)
+						       (build-icon exe-icon
+								   (if has-alpha?
+								       image
+								       (mask->alpha image mask))
+								   mask)
+						       (let ([cvt
+							      (cond
+							       [(and (= src-size 32) (= dest-size 16))
+								(lambda (i) (48->16 (32->48 i)))]
+							       [(and (= src-size 32) (= dest-size 48)) 
+								32->48]
+							       [(and (= src-size 48) (= dest-size 16)) 
+								48->16]
+							       [(and (= src-size 48) (= dest-size 32))
+								48->32]
+							       [(and (= src-size 16) (= dest-size 32)) 
+								16->32]
+							      [(and (= src-size 16) (= dest-size 48)) 
+							       (lambda (i) (32->48 (16->32 i)))])])
+							 (let ([mask (cvt mask)])
+							   (build-icon exe-icon 
+								       (if has-alpha?
+									   image
+									   (mask->alpha (cvt image) mask))
+								       mask)))))))))])
+			   (unless ico-icon (printf "no! ~a~n" (icon-desc exe-icon)))
+                           (when ico-icon
+                             (file-position p (car (icon-data exe-icon)))
+                             (display (cdr (icon-data ico-icon)) p)))))
+		     exe-icons))
+	 (lambda () (close-output-port p))))))
+
+  ;; ------------------------------
+  ;;  Image parsing
+  ;; ------------------------------
+
+  (define (get-icons file res?)
+    (let ([p (if (input-port? file)
+		 file
+		 (open-input-file file))])
+      (dynamic-wind
+       void
+       (lambda ()
+	 (unless (= 0 (word->integer p))
+		 (error 'get-icons "~a doesn't start with 0" file))
+	 (unless (= 1 (word->integer p))
+		 (error "type isn't 1"))
+	 (let ([cnt (word->integer p)])
+	   (let ([icons (let loop ([i 0])
+			  (if (= i cnt)
+			      null
+			      (cons
+			       (make-icon
+				(list (byte->integer p)   ; w
+				      (byte->integer p)   ; h
+				      (byte->integer p)   ; colors
+				      (byte->integer p)   ; 0
+				      (word->integer p)   ; planes
+				      (word->integer p))  ; bitcount
+				(list (dword->integer p)  ; bytes
+				      ((if res?           ; where or icon id
+					   word->integer 
+					   dword->integer)
+				       p)))
+			       (loop (add1 i)))))])
+	     ;; (printf "~a~n" icons)
+	     (for-each (lambda (icon)
+			 (set-icon-data!
+			  icon
+			  (let ([size (car (icon-data icon))]
+				[where (cadr (icon-data icon))])
+			    (let ([icon-pos (if res?
+						;; last number is icon id:
+						(car (find-rsrc-start p (format "^3[.]~a[.]" where)))
+						;; last number is file position:
+						where)])
+			      (file-position p icon-pos)
+			      (cons icon-pos
+				    (read-bytes size p)))))
+                         ;; If colors, planes, and bitcount are all 0,
+                         ;;  get the info from the DIB data
+                         (let ([desc (icon-desc icon)])
+                           (when (and (zero? (list-ref desc 2))
+                                      (zero? (list-ref desc 4))
+                                      (zero? (list-ref desc 5)))
+                             (let ([bi (bitmapinfo icon)])
+                               (set-car! (list-tail desc 4)
+                                         (list-ref bi 3))
+                               (set-car! (list-tail desc 5)
+                                         (list-ref bi 4))))))
+		       icons)
+	     icons)))
+       (lambda ()
+	 (when (path-string? file)
+	       (close-input-port p))))))
+
+  (define (bitmapinfo icon)
+    (let ([p (open-input-bytes (cdr (icon-data icon)))])
+      (list (dword->integer p)    ; size == 40 in practice
+	    (dword->integer p)    ; width
+	    (dword->integer p)    ; height
+	    (word->integer p)     ; planes
+	    (word->integer p)     ; bitcount
+	    (dword->integer p)    ; compression == 0
+	    (dword->integer p)    ; size image
+	    (dword->integer p)    ; x pixels per meter == 0
+	    (dword->integer p)    ; y pixels per meter == 0
+	    (dword->integer p)    ; used == 0
+	    (dword->integer p)))) ; important == 0
+
+  ;; Assumes that bits-per-pixel is 1, 2, 4, 8, 24, or 32.
+  ;; Also assumes that (bits-per-pixel * width) is a multiple of 8.
+  (define (parse-dib icon)
+    (let* ([bi (bitmapinfo icon)]
+	   [header-size (list-ref bi 0)]
+	   [num-colors (caddr (icon-desc icon))]
+	   [w (list-ref bi 1)]
+	   [h (/ (list-ref bi 2) 2)]
+	   [bits-per-pixel (list-ref bi 4)])
+      (let ([p (open-input-bytes (cdr (icon-data icon)))])
+	;; Skip header
+	(read-bytes header-size p)
+	(let* ([read-n
+		(lambda (n read-one combine)
+		  (let loop ([i n][r null])
+		    (if (= i 0)
+			(reverse! r)
+			(loop (sub1 i)
+			      (combine (read-one p) r)))))]
+	       [read-lines 
+		(lambda (w h read-one combine)
+		  (if (zero? (modulo w 4))
+		      (read-n (* w h) read-one combine)
+		      (let loop ([h h])
+			(if (zero? h)
+			    null
+			    (append (read-n w read-one combine)
+				    (begin
+				      ;; pad line to dword:
+				      (read-n (- 4 (modulo w 4)) byte->integer cons)
+				      ;; read next line:
+				      (loop (sub1 h))))))))]
+	       [split-bits (lambda (b)
+			     (list
+			      (bitwise-and b 1)
+			      (arithmetic-shift (bitwise-and b 2) -1)
+			      (arithmetic-shift (bitwise-and b 4) -2)
+			      (arithmetic-shift (bitwise-and b 8) -3)
+			      (arithmetic-shift (bitwise-and b 16) -4)
+			      (arithmetic-shift (bitwise-and b 32) -5)
+			      (arithmetic-shift (bitwise-and b 64) -6)
+			      (arithmetic-shift (bitwise-and b 128) -7)))])
+	  (let ([main-image
+		 (cond
+                   [(= bits-per-pixel 32)
+                    ;; RGB mode:
+                    (read-n (* w h) dword->integer cons)]
+                   [(= bits-per-pixel 24)
+                    ;; RGB mode:
+                    (read-n (* w h) 3/2word->integer cons)]
+                   [else
+                    ;; Index mode:
+                    (let ([color-table (list->vector
+                                        (read-n (if (zero? num-colors)
+                                                    (arithmetic-shift 1 bits-per-pixel)
+                                                    num-colors)
+                                                dword->integer cons))]
+                          [image (read-lines (/ w (/ 8 bits-per-pixel))
+                                             h
+                                             (lambda (p)
+                                               (let ([b (byte->integer p)])
+                                                 (case bits-per-pixel
+                                                   [(1) (split-bits b)]
+                                                   [(2)
+                                                    (list
+                                                     (bitwise-and b 3)
+                                                     (arithmetic-shift (bitwise-and b 12) -2)
+                                                     (arithmetic-shift (bitwise-and b 48) -4)
+                                                     (arithmetic-shift (bitwise-and b 192) -6))]
+                                                   [(4)
+                                                    (list
+                                                     (bitwise-and b 15)
+                                                     (arithmetic-shift (bitwise-and b 240) -4))]
+                                                   [(8) (list b)])))
+                                             append)])
+                      (map (lambda (i) (vector-ref color-table i)) image))])])
+	    (let ([mask (read-lines (/ w 8)
+				    h
+				    (lambda (p) (split-bits (byte->integer p)))
+				    append)])
+	      (unless (eof-object? (read-char p))
+		 (error 'parse-dib "not extactly at end"))
+	      (list main-image mask)))))))
+
+  ;; rgb->indexed
+  ;;  The color-reduction strategy isn't great, and because it
+  ;;  depends on hash-table order, it's non-deterministic in
+  ;;  principle. But the actual hash-table implementatin is
+  ;;  deterministic, of course. Also, the re-ordering of the
+  ;;  image via the hash tables tends to produce better
+  ;;  (pseudo-random) representatives of the image for colors.
+  (define (rgb->indexed image num-colors)
+    (let ([image (map (lambda (i) (bitwise-and #xFFFFFF i)) image)] ; drop alphas, if any
+	  [table (make-vector num-colors 0)]
+	  [ht (make-hash-table 'equal)]
+	  [map-ht (make-hash-table 'equal)]
+	  [color-dist (lambda (a b)
+			(sqrt (+ (expt (- (bitwise-and #xFF a)
+					  (bitwise-and #xFF b))
+				       2)
+				 (expt (- (arithmetic-shift (bitwise-and #xFF00 a) -8)
+					  (arithmetic-shift (bitwise-and #xFF00 b) -8))
+				       2)
+				 (expt (- (arithmetic-shift (bitwise-and #xFF0000 a) -16)
+					  (arithmetic-shift (bitwise-and #xFF0000 b) -16))
+				       2))))])
+      (for-each (lambda (c)
+		  (hash-table-put! 
+		   ht 
+		   c
+		   (add1
+		    (hash-table-get ht c (lambda () 0)))))
+		image)
+      (let ([kv-sorted
+             (quicksort (hash-table-map ht cons)
+                        (lambda (a b)
+                          (< (cdr a) (cdr b))))])
+        (let ([n 0])
+          (for-each (lambda (kv)
+                      (let ([key (car kv)])
+                        (let ([n (if (< n (sub1 num-colors))
+                                     n
+                                     ;; Find closest match:
+                                     (let ([n 0])
+                                       (let loop ([i 1])
+                                         (unless (= i num-colors)
+                                           (when (< (color-dist key (vector-ref table i))
+                                                    (color-dist key (vector-ref table n)))
+                                             (set! n i))
+                                           (loop (add1 i))))
+                                       n))])
+                          (vector-set! table n key)
+                          (hash-table-put! map-ht key n))
+                        (when (< n (sub1 num-colors))
+                          (set! n (add1 n)))))
+                    kv-sorted)))
+      (values (vector->list table)
+              (map (lambda (c) (hash-table-get map-ht c)) image))))
+    
+  ;; Assumes that bits-per-pixel is 1, 2, 4, 8, or 32.
+  ;; Also assumes that (bits-per-pixel * width) is a multiple of 8.
+  (define (build-dib icon image mask)
+    (let* ([bi (bitmapinfo icon)]
+	   [header-size (list-ref bi 0)]
+	   [num-colors (caddr (icon-desc icon))]
+	   [w (list-ref bi 1)]
+	   [h (/ (list-ref bi 2) 2)]
+	   [bits-per-pixel (list-ref bi 4)])
+      (let ([orig-p (open-input-bytes (cdr (icon-data icon)))]
+	    [result-p (open-output-bytes)])
+	;; Copy header:
+	(display (read-bytes header-size orig-p) result-p)
+	(let ([get-lines (lambda (image bits-per-pixel)
+			   (map (lambda (line)
+				  ;; pad line to dword boundary
+				  (let ([line-bytes (/ (* w bits-per-pixel) 8)])
+				    (if (zero? (modulo line-bytes 4))
+					line
+					(append line 
+						(vector->list
+						 (make-vector (* (- 4 (modulo line-bytes 4)) 
+								 (/ 8 bits-per-pixel))
+							      0))))))
+				;; break out lines
+				(let loop ([l image])
+				  (if (null? l)
+				      null
+				      (cons (let loop ([l l][i 0])
+					      (if (= i w)
+						  null
+						  (cons (car l) (loop (cdr l) (add1 i)))))
+					    (loop (list-tail l w)))))))]
+	      [bits->dwords (lambda (l bpp)
+			      (let ([chunk-size (/ 32 bpp)]
+				    [1byte (lambda (l)
+					     (bitwise-ior
+					      (arithmetic-shift (list-ref l 0) 7)
+					      (arithmetic-shift (list-ref l 1) 6)
+					      (arithmetic-shift (list-ref l 2) 5)
+					      (arithmetic-shift (list-ref l 3) 4)
+					      (arithmetic-shift (list-ref l 4) 3)
+					      (arithmetic-shift (list-ref l 5) 2)
+					      (arithmetic-shift (list-ref l 6) 1)
+					      (arithmetic-shift (list-ref l 7) 0)))]
+				    [2byte (lambda (l)
+					     (bitwise-ior
+					      (arithmetic-shift (list-ref l 0) 6)
+					      (arithmetic-shift (list-ref l 1) 4)
+					      (arithmetic-shift (list-ref l 2) 2)
+					      (arithmetic-shift (list-ref l 3) 0)))]
+				    [4byte (lambda (l)
+					     (bitwise-ior
+					      (arithmetic-shift (list-ref l 0) 4)
+					      (arithmetic-shift (list-ref l 1) 0)))])
+				(let loop ([l l])
+				  (if (null? l)
+				      null
+				      (cons (case bpp
+					      [(1) (bitwise-ior
+						    (arithmetic-shift (1byte (list-tail l 0)) 0)
+						    (arithmetic-shift (1byte (list-tail l 8)) 8)
+						    (arithmetic-shift (1byte (list-tail l 16)) 16)
+						    (arithmetic-shift (1byte (list-tail l 24)) 24))]
+					      [(2) (bitwise-ior
+						    (2byte l)
+						    (arithmetic-shift (2byte (list-tail l 4)) 8)
+						    (arithmetic-shift (2byte (list-tail l 8)) 16)
+						    (arithmetic-shift (2byte (list-tail l 12)) 24))]
+					      [(4) (bitwise-ior
+						    (4byte l)
+						    (arithmetic-shift (4byte (list-tail l 2)) 8)
+						    (arithmetic-shift (4byte (list-tail l 4)) 16)
+						    (arithmetic-shift (4byte (list-tail l 6)) 24))]
+					      [(8) (bitwise-ior
+						    (car l)
+						    (arithmetic-shift (list-ref l 1) 8)
+						    (arithmetic-shift (list-ref l 2) 16)
+						    (arithmetic-shift (list-ref l 3) 24))])
+					    (loop (list-tail l chunk-size)))))))])
+	  (if (= bits-per-pixel 32)
+	      (for-each (lambda (col) (integer->dword col result-p))
+			image)
+	      (let-values ([(colors indexed-image) (rgb->indexed image (arithmetic-shift 1 bits-per-pixel))])
+  	        ;; color table
+	        (for-each (lambda (col) (integer->dword col result-p))
+			  colors)
+		(let* ([lines (get-lines indexed-image bits-per-pixel)]
+		       [dwords (apply append (map (lambda (l) (bits->dwords l bits-per-pixel)) 
+                                                 lines))])
+                  (for-each (lambda (col) (integer->dword col result-p))
+			    dwords))))
+	  (let* ([lines (get-lines mask 1)]
+		 [dwords (apply append (map (lambda (l) (bits->dwords l 1)) lines))])
+	    (for-each (lambda (col) (integer->dword col result-p))
+		      dwords))
+	  (let ([s (get-output-bytes result-p)])
+	    (unless (= (bytes-length s) (bytes-length (cdr (icon-data icon))))
+	      (error 'build-dib "bad result size ~a != ~a"
+                     (bytes-length s) (bytes-length (cdr (icon-data icon)))))
+	    s)))))
+
+  (define (parse-icon icon)
+    (let ([image (parse-dib icon)])
+      (list (car (icon-desc icon))
+	    (cadr (icon-desc icon))
+	    (let ([cols (caddr (icon-desc icon))])
+	      (if (zero? cols)
+		  (expt 2 (list-ref (icon-desc icon) 5))
+		  cols))
+	    (car image)
+	    (cadr image))))
+
+  (define (build-icon base-icon image mask)
+    (make-icon (icon-desc base-icon)
+	       (cons (car (icon-desc base-icon))
+		     (build-dib base-icon image mask))))
+
+  (define (extract-icons file)
+    (if (regexp-match #rx"[.]ico$" (if (path? file)
+				       (path->string file)
+				       file))
+	(get-icons-in-ico file)
+	(get-icons-in-exe file)))
+
+  (define (get-icons-in-ico ico-file)
+    (get-icons ico-file #f))
+
+  (define (get-icons-in-exe exe-file)
+    (let ([p (open-input-file exe-file)])
+      (dynamic-wind
+       void
+       (lambda ()
+	 (let ([pos+size (find-rsrc-start p "^14[.]")])
+	   (file-position p (car pos+size))
+	   (get-icons p #t)))
+       (lambda () (close-input-port p)))))
+
+  ;; The following is useful for bitmap->icon,
+  ;;  but it uses MrEd, and this module is used by
+  ;;  Setup PLT. Probably this code should just be
+  ;;  moved somewhere else.
+  #;
+  (begin
+    (require (lib "mred.ss" "mred")
+             (lib "class.ss"))
+    (define (bitmap%->icon bm)
+      (let* ([w (send bm get-width)]
+             [h (send bm get-height)]
+             [argb (make-bytes (* w h 4))]
+             [mdc (make-object bitmap-dc% bm)])
+        (send mdc get-argb-pixels 0 0 w h argb)
+        (send mdc set-bitmap #f)
+        ;; Get mask (inverse alpha), if any:
+        (let ([mask-argb (make-bytes (* w h 4) #o377)]
+              [mbm (send bm get-loaded-mask)])
+          (when mbm
+            (send mdc set-bitmap mbm)
+            (send mdc get-argb-pixels 0 0 w h mask-argb)
+            (send mdc set-bitmap #f))
+          (bitmap->icon w h argb mask-argb)))))
+
+  (define (bitmap->icon w h argb mask-argb)
+    (let ([o (open-output-bytes)])
+      (integer->dword 40 o) ; size
+      (integer->dword w o)  ; width
+      (integer->dword (* 2 h) o)  ; height
+      (integer->word 1 o)   ; planes
+      (integer->word 32 o)  ; bitcount
+      (integer->dword 0 o)  ; compression
+      (integer->dword 0 o)  ; size image
+      (integer->dword 0 o)  ; x pixels per meter
+      (integer->dword 0 o)  ; y pixels per meter
+      (integer->dword 0 o)  ; used
+      (integer->dword 0 o)  ; important
+      ;; Got ARGB, need BGRA
+      (let* ([flip-pixels (lambda (s)
+                            (let ([s (bytes-copy s)])
+                              (let loop ([p 0])
+                                (unless (= p (bytes-length s))
+                                  (let ([a (bytes-ref s p)]
+                                        [r (bytes-ref s (+ p 1))]
+                                        [g (bytes-ref s (+ p 2))]
+                                        [b (bytes-ref s (+ p 3))])
+                                    (bytes-set! s p b)
+                                    (bytes-set! s (+ p 1) g)
+                                    (bytes-set! s (+ p 2) r)
+                                    (bytes-set! s (+ p 3) a)
+                                    (loop (+ p 4)))))
+                              s))]
+             [rgba (flip-pixels argb)]
+             [mask-rgba (flip-pixels mask-argb)]
+             [row-size (if (zero? (modulo w 32))
+                           w
+                           (+ w (- 32 (remainder w 32))))]
+             [mask (make-bytes (* h row-size 1/8) 0)])
+        (let loop ([i (* w h 4)])
+          (unless (zero? i)
+            (let ([mr (bytes-ref mask-rgba (- i 2))]
+                  [mg (bytes-ref mask-rgba (- i 3))]
+                  [mb (bytes-ref mask-rgba (- i 4))]
+                  [a (- i 1)])
+              (let ([alpha (- 255
+                              (floor (/ (+ mr mg mb)
+                                        3)))])
+                (if (< alpha 10)
+                    ;; white mask -> zero alpha; add white pixel to mask
+                    (begin
+                      (bytes-set! rgba a 0)
+                      (let ([pos (+ (* (quotient (sub1 (/ i 4)) w) row-size)
+                                    (remainder (sub1 (/ i 4)) w))])
+                        (bytes-set! mask 
+				    (quotient pos 8)
+				    (bitwise-ior
+				     (arithmetic-shift 1 (- 7 (remainder pos 8)))
+				     (bytes-ref mask (quotient pos 8))))))
+                    ;; non-white mask -> non-zero alpha
+                    (bytes-set! rgba a alpha))))
+            (loop (- i 4))))
+        ;; Windows icons are upside-down:
+        (let ([flip (lambda (str row-width)
+                      (apply
+                       bytes-append
+                       (reverse
+                        (let loop ([pos 0])
+                          (if (= pos (bytes-length str))
+                              null
+                              (cons (subbytes str pos (+ pos row-width))
+                                    (loop (+ pos row-width))))))))])                      
+          (display (flip rgba (* w 4)) o)
+          (display (flip mask (/ row-size 8)) o))
+        (make-icon (list w h 0 0 1 32)
+                   (cons 0 (get-output-bytes o))))))
+  
+  ;; ------------------------------
+  ;;  Image conversion
+  ;; ------------------------------
+  
+  (define (mask->alpha image mask)
+    (map (lambda (i m)
+           (if (zero? m)
+               (bitwise-ior #xFF000000 i)
+               m))
+         image mask))
+  
+  (define (first-n n l)
+    (let loop ([l l][i n])
+      (if (zero? i)
+          null
+          (cons (car l) (loop (cdr l) (sub1 i))))))
+  
+  (define (16->32 l)
+    (let loop ([l l])
+      (if (null? l) 
+          null
+          (let ([l2 (let loop ([l (first-n 16 l)])
+                      (if (null? l)
+                          null
+                          (list* (car l) (car l) (loop (cdr l)))))])
+            (append l2 l2
+                    (loop (list-tail l 16)))))))
+  
+  (define (32->48 l)
+    (let loop ([l l][dup? #t])
+      (if (null? l) 
+          null
+          (let ([l2 (let loop ([l (first-n 32 l)])
+                      (if (null? l)
+                          null
+                          (list* (car l) (car l) (cadr l)
+                                 (loop (cddr l)))))])
+            (append l2
+                    (if dup? l2 null)
+                    (loop (list-tail l 32) (not dup?)))))))
+  
+  (define (48->16 l)
+    (let loop ([l l])
+      (if (null? l) 
+          null
+          (let ([l2 (let loop ([l (first-n 48 l)])
+                      (if (null? l)
+                          null
+                          (cons (car l) (loop (cdddr l)))))])
+            (append l2
+                    (loop (list-tail l 144)))))))
+  
+  (define (48->32 l)
+    (let loop ([l l][step 0])
+      (if (null? l) 
+          null
+          (let ([l2 (let loop ([l (first-n 48 l)][step 0])
+                      (if (null? l)
+                          null
+                          (if (= 1 (modulo step 3))
+                              (loop (cdr l) 2)
+                              (cons (car l) (loop (cdr l) (add1 step))))))])
+            (append (if (= 1 (modulo step 3)) null l2)
+                    (loop (list-tail l 48) (add1 step))))))))
+
+#|
+
+;; ----------------------------------------
+;; Test code
+
+(define icons (extract-icons "e:/matthew/plt/mred.exe"))
+
+(define (show-icon w h col-count image mask)
+  (let* ([f (make-object frame% (format "~a x ~a (~a) Image" w h col-count))]
+         [bm (make-object bitmap% w h)]
+         [mbm (make-object bitmap% w h)]
+         [c (instantiate canvas% (f)
+              [paint-callback (lambda (c dc)
+                                (send dc draw-bitmap bm 0 0)
+                                (send dc draw-bitmap mbm w 0))])])
+    (let ([mdc (make-object bitmap-dc% bm)]
+          [col (make-object color%)])
+      (let loop ([l image][i 0][j 0])
+        (unless (= j h)
+          (let ([v (car l)])
+            (send col set
+                  (bitwise-and v #xFF)
+                  (arithmetic-shift (bitwise-and v #xFF00) -8)
+                  (arithmetic-shift (bitwise-and v #xFF0000) -16))
+            (send mdc set-pixel i j col)
+            (if (= (add1 i) w)
+                (loop (cdr l) 0 (add1 j))
+                (loop (cdr l) (add1 i) j)))))
+      (send mdc set-bitmap mbm)
+      (let loop ([l (if (col-count . > . 256) image mask)][i 0][j 0])
+        (unless (= j h)
+          (let ([v (if (col-count . > . 256)
+                       (- 255 (arithmetic-shift (bitwise-and (car l) #xFF000000) -24))
+                       (if (zero? (car l))
+                           0
+                           255))])
+            (send col set v v v)
+            (send mdc set-pixel i j col)
+            (if (= (add1 i) w)
+                (loop (cdr l) 0 (add1 j))
+                (loop (cdr l) (add1 i) j)))))
+      
+      (send mdc set-bitmap #f))
+    (send c min-client-width (* 2 w))
+    (send c min-client-height h)
+    (send c stretchable-width #f)
+    (send c stretchable-height #f)
+    
+    (send f show #t)))
+
+(define (find-icon icons w h colors)
+  (ormap (lambda (i)
+           (let ([p (parse-icon i)])
+             (and (= w (car p))
+                  (= h (cadr p))
+                  (= colors (caddr p))
+                  i)))
+         icons))
+
+(let ([orig (find-icon icons 48 48 (expt 2 32))]
+      [target (find-icon icons 32 32 256)])
+  (apply show-icon (parse-icon orig))
+  (apply show-icon (parse-icon target))
+  (apply show-icon 
+         (parse-icon
+          (let* ([p (parse-icon orig)]
+                 [mask (48->32(list-ref p 4))]
+                 [image (mask->alpha (48->32 (list-ref p 3)) mask)])
+            (build-icon target image mask)))))
+
+;; ----------------------------------------
+;; End test code
+
+|#
diff --git a/collects/compiler/private/zlayer.ss b/collects/compiler/private/zlayer.ss
new file mode 100644
index 0000000000..8fd006653d
--- /dev/null
+++ b/collects/compiler/private/zlayer.ss
@@ -0,0 +1,249 @@
+;; Zodiac interface and library routines
+;; (c)1996-1997 Sebastian Good
+;; (c)1997-2001 PLT
+
+(module zlayer mzscheme
+  (require (lib "unitsig.ss")
+	  (lib "list.ss")
+	  (lib "etc.ss"))
+  
+  (require (lib "zodiac-sig.ss" "syntax"))
+
+  (require "../sig.ss")
+  (require "sig.ss")
+  
+  (provide zlayer@)
+  (define zlayer@
+    (unit/sig compiler:zlayer^
+      (import (compiler:option : compiler:option^)
+	      (zodiac : zodiac^)
+	      compiler:cstructs^
+	      compiler:driver^)
+
+      ;;----------------------------------------------------------------------------
+      ;; ANNOTATIONS
+      ;;
+      ;; zodiac:* AST notes are annotated using set-annotation!, and
+      ;; the annotations are extracted using get-annotation. Every
+      ;; AST node has a single annotation, but the type of the annotation
+      ;; depends on the type of the AST node.
+      
+      ;; This is the default annotation value, used before the annotation
+      ;; is set for an AST node
+      (define compiler:empty-annotation (gensym 'mzc-default-annotation))
+
+      ;; Create a new back-box for a new zodiac AST node
+      (define (make-empty-box) (zodiac:make-empty-back-box))
+
+      ;; Manipulating annotations:
+      ;; NOTE: Zodiac must be invoked before this unit
+      (define-values (get-annotation set-annotation!)
+	(let-values ([(getter setter)
+		      (zodiac:register-client 'compiler 
+					      (lambda ()
+						compiler:empty-annotation))])
+	  (values
+	   (lambda (ast)
+	     (getter (zodiac:parsed-back ast)))
+	   (lambda (ast obj)
+	     (setter (zodiac:parsed-back ast) obj)))))
+      (define (annotated? ast)
+	(not (eq? (get-annotation ast)
+		  compiler:empty-annotation)))
+      (define (remove-annotation! ast)
+	(set-annotation! ast compiler:empty-annotation))
+
+      ;;----------------------------------------------------------------------------
+      ;; Error handling
+
+      (define compiler:escape-on-error (make-parameter #f))
+
+      ;; initialize zodiac-error procedures
+      (define zodiac-error-template
+	(lambda (c s)
+	  (lambda (where fmt-spec . args)
+	    (c where 
+	       (string-append 
+		s
+		(apply format (cons fmt-spec args))))
+	    (when (compiler:escape-on-error)
+	      (error 'compiler "parsing error")))))
+      
+      (define (call-compiler:fatal-error . args)
+	(apply compiler:fatal-error args))
+      
+      (define static-error 
+	(zodiac-error-template call-compiler:fatal-error "(syntax) "))
+      (define internal-error
+	(zodiac-error-template call-compiler:fatal-error "(elaboration) "))
+      (define dynamic-error
+	(zodiac-error-template call-compiler:fatal-error "(parser dynamic) "))
+      
+
+      ;;----------------------------------------------------------------------------
+      ;; BEGIN0-FORM
+      ;;
+      ;;  maintain the illusion of a two slot begin0-form
+      
+      (define zodiac:begin0-form-first
+	(compose car zodiac:begin0-form-bodies))
+      (define zodiac:begin0-form-rest
+	(compose cadr zodiac:begin0-form-bodies))
+      (define zodiac:set-begin0-form-first!
+	(lambda (ast v)
+	  (set-car! (zodiac:begin0-form-bodies ast) v)))
+      (define zodiac:set-begin0-form-rest!
+	(lambda (ast v)
+	  (set-car! (cdr (zodiac:begin0-form-bodies ast)) v)))
+      
+      ;;----------------------------------------------------------------------------
+      ;; SPECIAL CONSTANTS
+      ;;
+      ;; some constants we don't know how to write, like #<void>
+      ;;
+
+      (define undefined (letrec ([x x]) x))
+
+      (define (undefined? x) (eq? x undefined))
+
+      (define self_modidx (let ()
+			    (define-struct self_modidx ())
+			    (make-self_modidx)))
+
+      (define zodiac:make-special-constant
+	;; make-quote, make-constant
+	(lambda (text)
+	  (let ([stx (case text
+		       [(void) (datum->syntax-object #f (void) #f)]
+		       [(null) (datum->syntax-object #f null)]
+		       [(undefined) (datum->syntax-object #f undefined)]
+		       [(self_modidx) (datum->syntax-object #f self_modidx)]
+		       [else (compiler:internal-error 'make-special-constant "bad type")])])
+	    (zodiac:make-quote-form 
+	     stx (make-empty-box)
+	     (zodiac:make-zread stx)))))
+      
+      ;;-----------------------------------------------------------------------------
+      ;; BINDING->LEXICAL-VARREF
+      ;;
+      ;; creates a zodiac:lexical-varref from a zodiac:binding
+      ;;
+      
+      (define zodiac:binding->lexical-varref
+	(lambda (ast)
+	  (let ([v (zodiac:make-lexical-varref (zodiac:zodiac-stx ast)
+					       (make-empty-box)
+					       (zodiac:binding-var ast)
+					       ast)])
+	    (set-annotation! v (varref:empty-attributes))
+	    v)))
+
+      ;;----------------------------------------------------------------------------
+      ;; POSITION REPORTING
+      
+      (define main-source-file (make-parameter #f))
+      
+      (define zodiac:print-start!
+	(lambda (port ast)
+	  (let ([bad (lambda () (fprintf port " [?,?]: "))])
+	    (if (and ast (zodiac:zodiac? ast))
+		(let* ([start (zodiac:zodiac-start ast)]
+		       [good (lambda ()
+			       (fprintf port " ~a[~a,~a]: "
+					(if (equal? (main-source-file) (zodiac:location-file start))
+					    ""
+					    (format "~s " (zodiac:location-file start)))
+					(zodiac:location-line start)
+					(zodiac:location-column start)))])
+		  (good))
+		(bad)))))
+
+      ;;----------------------------------------------------------------------
+      ;; Debugging: AST to annotated S-expression
+      (define zodiac->sexp/annotate
+	(lambda (ast)
+	  (zodiac->sexp ast)))
+      
+      (define zodiac->sexp
+	(lambda (ast)
+
+	  (cond 
+	   [(zodiac:quote-form? ast) 
+	    (syntax-object->datum (zodiac:zodiac-stx ast))]
+
+	   [(zodiac:binding? ast)
+	    (zodiac:binding-var ast)]
+
+	   [(zodiac:varref? ast)
+	    (zodiac:varref-var ast)]
+	   
+	   ;; compound sexps
+	   [(zodiac:define-values-form? ast)
+	    `(define-values ,(map zodiac->sexp (zodiac:define-values-form-vars ast))
+	       ,(zodiac->sexp/annotate (zodiac:define-values-form-val ast)))]
+	   
+	   [(zodiac:app? ast)
+	    `(,(zodiac->sexp/annotate (zodiac:app-fun ast))
+	      ,@(map zodiac->sexp/annotate (zodiac:app-args ast)))]
+	   
+	   [(zodiac:set!-form? ast)
+	    `(set! ,(zodiac->sexp (zodiac:set!-form-var ast))
+		   ,(zodiac->sexp/annotate (zodiac:set!-form-val ast)))]
+	   
+	   [(zodiac:case-lambda-form? ast)
+	    `(case-lambda
+	      ,@(map
+		 (lambda (args body)
+		   `(,(let ([vars (zodiac:arglist-vars args)])
+			(cond
+			 [(zodiac:sym-arglist? args) (zodiac->sexp (car vars))]
+			 [(zodiac:list-arglist? args) (map zodiac->sexp vars)]
+			 [(zodiac:ilist-arglist? args) (let loop ([args vars])
+							 (if (null? (cdr args))
+							     (zodiac->sexp (car args))
+							     (cons (zodiac->sexp (car args))
+								   (loop (cdr args)))))]))
+		     ,(zodiac->sexp/annotate body)))
+		 (zodiac:case-lambda-form-args ast)
+		 (zodiac:case-lambda-form-bodies ast)))]
+
+	   [(zodiac:begin-form? ast)
+	    `(begin ,@(map zodiac->sexp/annotate (zodiac:begin-form-bodies ast)))]
+
+	   [(zodiac:begin0-form? ast)
+	    `(begin0 ,@(map zodiac->sexp/annotate (zodiac:begin0-form-bodies ast)))]
+
+	   [(zodiac:let-values-form? ast)
+	    `(let-values
+		 ,(map list
+		       (map (lambda (l) (map zodiac->sexp l)) (zodiac:let-values-form-vars ast))
+		       (map zodiac->sexp/annotate (zodiac:let-values-form-vals ast)))
+	       ,(zodiac->sexp/annotate (zodiac:let-values-form-body ast)))]
+	   
+	   [(zodiac:letrec-values-form? ast)
+	    `(letrec-values
+		 ,(map list
+		       (map (lambda (l) (map zodiac->sexp l)) (zodiac:letrec-values-form-vars ast))
+		       (map zodiac->sexp/annotate (zodiac:letrec-values-form-vals ast)))
+	       ,(zodiac->sexp/annotate (zodiac:letrec-values-form-body ast)))]
+
+	   [(zodiac:if-form? ast)
+	    `(if ,(zodiac->sexp/annotate (zodiac:if-form-test ast))
+		 ,(zodiac->sexp/annotate (zodiac:if-form-then ast))
+		 ,(zodiac->sexp/annotate (zodiac:if-form-else ast)))]
+	   
+	   [(zodiac:with-continuation-mark-form? ast)
+	    `(with-continuation-mark 
+	      ,(zodiac->sexp/annotate (zodiac:with-continuation-mark-form-key ast))
+	      ,(zodiac->sexp/annotate (zodiac:with-continuation-mark-form-val ast))
+	      ,(zodiac->sexp/annotate (zodiac:with-continuation-mark-form-body ast)))]
+
+	   [(zodiac:require/provide-form? ast)
+	    `(require/provide ...)]
+
+	   [(zodiac:module-form? ast)
+	    `(module ... ,(zodiac->sexp/annotate (zodiac:module-form-body ast)))]
+
+	   [else
+	    (error 'zodiac->sexp/annotate "unsupported ~s" ast)]))))))
+
diff --git a/collects/compiler/sig.ss b/collects/compiler/sig.ss
new file mode 100644
index 0000000000..b351979c1c
--- /dev/null
+++ b/collects/compiler/sig.ss
@@ -0,0 +1,106 @@
+
+(module sig mzscheme
+
+  (require (lib "unitsig.ss"))
+
+  (provide compiler:option^
+	   compiler^
+	   compiler:inner^
+	   compiler:linker^)
+
+  ;; Compiler options
+  (define-signature compiler:option^
+     (verbose ; default = #f
+   
+      setup-prefix ; string to embed in public names;
+                   ; used mainly for compiling extensions
+                   ;  with the collection name so that 
+                   ;  cross-extension conflicts are less
+                   ;  likely in architectures that expose
+                   ;  the public names of loaded extensions
+                   ; default = ""
+   
+      clean-intermediate-files ; #t => keep intermediate .c/.o files
+                               ; default = #f
+   
+      compile-subcollections   ; #t => use 'compile-subcollections
+                               ;  from infor for collection compiling
+                               ; default = #t
+   
+      compile-for-embedded  ; #f => make objects to be linked
+                            ; directly with MzScheme, not dynamically
+                            ; loaded; default = #f
+   
+      max-inline-size      ; max size of inlined procedures
+   
+      disable-interrupts   ; #t => UNSAFE: turn off breaking, stack
+                           ; overflow, and thread switching;
+                           ; default = #f
+      unsafe               ; #t => UNSAFE: omit some type checks
+                           ; default = #f
+      fixnum-arithmetic    ; #t => UNSAFE: don't check for overflow or
+                           ; underflow for fixnum arithmetic;
+                           ; default = #f
+   
+      propagate-constants  ; default = #t
+      assume-primitives    ; #t => car = #%car; default = #f
+      stupid               ; allow obvious non-syntactic errors;
+                           ;  e.g.: ((lambda () 0) 1 2 3)
+   
+      vehicles             ; Controls how closures are compiled:
+   			;  'vehicles:automatic,
+                           ;  'vehicles:functions,
+                           ;  'vechicles:units, or
+                           ;  'vehicles:monolithic.
+                           ; default = 'vehicles:automatic
+      vehicles:monoliths   ; Size for 'vehicles:monolithic
+      seed                 ; Randomizer seed for 'vehicles:monolithic
+   
+      max-exprs-per-top-level-set ; Number of top-level Scheme expressions
+   			       ; crammed into one C function; default = 25
+   
+      unpack-environments  ; default = #t
+   		        ; Maybe #f helps for register-poor architectures?
+   
+      debug ; #t => creates debug.txt debugging file
+      test  ; #t => ignores top-level expressions with syntax errors
+      ))
+
+  ;; Compiler procedures
+  (define-signature compiler^
+    (compile-extensions
+     compile-extensions-to-c
+     compile-c-extensions
+
+     compile-extension-parts
+     compile-extension-parts-to-c
+     compile-c-extension-parts
+
+     link-extension-parts
+     glue-extension-parts
+
+     compile-zos
+
+     compile-collection-extension
+     compile-collection-zos
+
+     compile-directory-extension
+     compile-directory-zos
+ 
+     current-compiler-dynamic-require-wrapper
+     compile-notify-handler))
+
+  ;; Low-level extension compiler interface
+  (define-signature compiler:inner^
+    (compile-extension
+     compile-extension-to-c
+     compile-c-extension
+     compile-extension-part
+     compile-extension-part-to-c
+     compile-c-extension-part
+     eval-compile-prefix))
+  
+  ;; Low-level multi-file extension linker interface
+  (define-signature compiler:linker^
+    (link-extension
+     glue-extension)))
diff --git a/collects/compiler/src2src.ss b/collects/compiler/src2src.ss
new file mode 100644
index 0000000000..f3c32cf189
--- /dev/null
+++ b/collects/compiler/src2src.ss
@@ -0,0 +1,1839 @@
+
+;; Implements a source-to-source optimizer
+
+;; The src-to-src transformation currently drops
+;;  properties, which is bad. The 'mzc-cffi,
+;;  'method-arity-error, and 'inferred-name properties are
+;;  specially preserved for `lambda' expressions.
+
+(module src2src mzscheme
+  (require (lib "class.ss")
+	   (lib "kerncase.ss" "syntax")
+	   (lib "primitives.ss" "syntax")
+	   (lib "etc.ss")
+	   (lib "list.ss"))
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; Optimizer
+  ;; classes representing syntax with methods for optimization steps
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  
+  ;; Maximum number of times to inline while processing a call site
+  (define max-fuel 0)
+  (define fuel (make-parameter max-fuel))
+
+  (define foldable-prims '(void
+			   + - * / arithmetic-shift
+			   < <= = > >=
+			   number? positive? negative? zero?
+			   real? complex?
+			   string-ref))
+
+  (define effectless-prims '(list list* cons vector))
+
+  ;; The following primitives either invoke functions, or
+  ;;  install functions that can be used later.
+  (define (non-valueable-prims) (procedure-calling-prims))
+
+  (define recert-insp (current-code-inspector))
+
+  (define (keep-mzc-property stx-out stx)
+    (let ([v (syntax-property stx 'mzc-cffi)]
+	  [v2 (syntax-property stx 'method-arity-error)]
+	  [v3 (syntax-property stx 'inferred-name)])
+      (let ([stx-out2 (if v
+			  (syntax-property stx-out 'mzc-cffi v)
+			  stx-out)])
+	(let ([stx-out3 (if v2
+			    (syntax-property stx-out2 'method-arity-error v2)
+			    stx-out2)])
+	  (if v3
+	      (syntax-property stx-out3 'inferred-name v3)
+	      stx-out3)))))
+  
+  (define-struct context (need indef))
+  ;; need = #f => don't need  the value
+  ;; need = 'bool => need bool only
+  ;; need = 'all => need exact result
+
+  ;; indef = list of binding%s
+
+  (define (need-all ctx)
+    (if (eq? 'all (context-need ctx))
+	ctx
+	(make-context 'all (context-indef ctx))))
+  (define (need-none ctx)
+    (if (eq? 'none (context-need ctx))
+	ctx
+	(make-context 'none (context-indef ctx))))
+  (define (need-bool ctx)
+    (make-context 'bool (context-indef ctx)))
+
+  (define-struct accessor (make-struct-type-expr position))
+  (define-struct mutator (make-struct-type-expr position))
+  (define-struct ctor (make-struct-type-expr))
+  
+  (define exp%
+    (class object%
+      
+      (init-field src-stx)
+      (if (not (syntax? src-stx))
+          (begin
+            (printf "~a~n" src-stx)
+            (error 'stx)))
+      (init-field [cert-stxes (list src-stx)])
+      (field (known-value #f))
+      
+      ;; resets known-value computation, use counts, etc.
+      (define/public (reset-varflags)
+        (set! known-value #f)
+        (for-each (lambda (e) (send e reset-varflags)) (sub-exprs)))
+      
+      ;; accumulates known-value mappings, use counts on bindings, etc.;
+      ;; assumes varflags are reset
+      (define/public (set-known-values)
+        (for-each (lambda (e) (send e set-known-values)) (nonbind-sub-exprs)))
+
+      ;; sets `mutable?' flags; set-known-values does that, too,
+      ;; but this one only sets mutable flags
+      (define/public (set-mutability)
+        (for-each (lambda (e) (send e set-mutability)) (nonbind-sub-exprs)))
+
+      ;; for each reference of a binding in the exp, drop one use
+      (define/public (drop-uses)
+        (for-each (lambda (e) (send e drop-uses)) (nonbind-sub-exprs)))
+
+      ;; any side-effects might be in this expression?
+      ;; (return #t if unsure)
+      (define/public (no-side-effect?)
+        (andmap (lambda (e) (send e no-side-effect?))
+                (nonbind-sub-exprs)))
+
+      ;; arity is a number or 'unknown
+      (define/public (get-result-arity) 'unknown)
+
+      ;; gets all subexpressions, including binding%s for lambda, etc.
+      (define/public (sub-exprs) (append (bind-sub-exprs) (nonbind-sub-exprs)))
+      ;; just the binding%s
+      (define/public (bind-sub-exprs) null)
+      ;; all subexpressions that aren't binding%s
+      (define/public (nonbind-sub-exprs) null)
+
+      ;; some default implementations map over nonbind-sub-exprs, 
+      ;; the install the results with this method
+      (define/public (set-nonbind-sub-exprs x) (void))
+
+      ;; valueable means that evaluating the expression can't access
+      ;;  a variable before it is initialized or mutate a
+      ;;  variable. It's used, for example, on the RHSs of a letrec
+      ;;  to determine known bindings.
+      (define/public (valueable?)
+        (andmap (lambda (x) (send x valueable?)) (nonbind-sub-exprs)))
+      
+      ;; ok to duplicate or move the expression?
+      ;; (return #f if unsure)
+      (define/public (can-dup/move?) #f)
+      
+      ;; known value is an exp%; usually only binding% objects
+      ;; get known-value settings
+      (define/public (set-known-value x) (set! known-value x))
+
+      ;; finds the most-specific exp% whose value is the
+      ;; same this this expression's value
+      (define/public (get-value) (or known-value this))
+
+      ;; helper:
+      (define/private (subexp-map! f)
+        (set-nonbind-sub-exprs (map f (nonbind-sub-exprs)))
+        this)
+
+      ;; main optimization method:
+      (define/public (simplify ctx)
+        (subexp-map! (lambda (x) 
+                       (send x simplify (need-all ctx)))))
+	
+      (define/public (escape)
+        (subexp-map! (lambda (x) (send x escape))))
+
+      (define/public (stack-allocate)
+        (subexp-map! (lambda (x) (send x stack-allocate))))
+      
+      ;; not an optimizations, but exposes info (epsecially to mzc)
+      (define/public (reorganize)
+        (subexp-map! (lambda (x) (send x reorganize))))
+      ;; reverses reorganize
+      (define/public (deorganize)
+        (subexp-map! (lambda (x)
+                       (send x deorganize))))
+
+      ;; substitution of lexical refs for global variables
+      (define/public (global->local env)
+        (subexp-map! (lambda (x)
+                       (send x global->local env))))
+      
+      ;; substitution of lexical refs for either lex or global vars
+      (define/public (substitute env)
+        (subexp-map! (lambda (x)
+                       (send x substitute env))))
+
+      ;; creates a copy, used for inling; don't try to preserve
+      ;;  analysis, because we'll just re-compute it
+      (define/public (clone env)
+        (error 'clone "unimplemented: ~a" this))
+
+      ;; gets stx object, usually for src info
+      (define/public (get-stx) src-stx)
+
+      ;; convert back to a syntax object
+      (define/public (sexpr) 
+	(recertify src-stx))
+
+      ;; adds certifications back to result of sexp, when needed
+      (define/public (recertify stx)
+	(let loop ([cert-stxes cert-stxes][stx stx])
+	  (cond
+	   [(null? cert-stxes) stx]
+	   [else (loop (cdr cert-stxes)
+		       (syntax-recertify stx 
+					 (car cert-stxes)
+					 recert-insp 
+					 #f))])))
+
+      ;; returns cert stxes
+      (define/public (get-cert-stxes)
+	cert-stxes)
+      
+      ;; merges cert info from another expression
+      (define/public (merge-certs exp)
+	(set! cert-stxes 
+	      (append (filter (lambda (i) (not (memq i cert-stxes)))
+			      (send exp get-cert-stxes))
+		      cert-stxes)))
+      
+      ;; list of body exprs (avoids redundant `begin', just for
+      ;; readability)
+      (define/public (body-sexpr) (list (sexpr)))
+
+      (super-instantiate ())))
+
+  (define (get-sexpr o) (send o sexpr))
+  (define (get-body-sexpr o) (send o body-sexpr))
+
+  (define-struct bucket (mutated? inited-before-use?))
+
+  (define (global-bucket table stx)
+    (let ([l (hash-table-get table (syntax-e stx) (lambda () null))])
+      (let ([s (ormap (lambda (b)
+			(and (module-identifier=? stx (car b))
+			     (cdr b)))
+		      l)])
+	(if s
+	    s
+	    (let ([s (make-bucket #f #f)])
+	      (hash-table-put! table (syntax-e stx) (cons (cons stx s) l))
+	      s)))))
+
+  (define-struct tables (global-ht et-global-ht))
+
+  (define global%
+    (class exp% 
+      (init-field trans? tables needs-top?)
+      (super-instantiate ())
+      (inherit-field src-stx) ;; The identifier
+      (inherit-field cert-stxes) ;; The identifier
+      
+      (define mbind #f)
+      (define bucket (global-bucket ((if trans? tables-et-global-ht tables-global-ht) tables) src-stx))
+      (define/private (get-mbind!)
+        (unless mbind
+          (set! mbind ((if trans?
+                           identifier-transformer-binding 
+                           identifier-binding)
+                       src-stx))))
+      (define/public (orig-name)
+        (get-mbind!)
+        (if (pair? mbind)
+            (cadr mbind)
+            (syntax-e src-stx)))
+
+      (define/public (is-kernel?)
+        (get-mbind!)
+        (and (pair? mbind)
+             (eq? (car mbind) '#%kernel)))
+
+      (define/public (is-trans?) trans?)
+
+      (define/public (is-mutated?) (bucket-mutated? bucket))
+
+      (define/override (no-side-effect?)
+        ;; If not built in, could raise exn
+	(is-kernel?))
+
+      (define/override (get-result-arity) 1)
+
+      (define/override (valueable?) (or (bucket-inited-before-use? bucket)
+                                        (is-kernel?)))
+
+      (define/override (can-dup/move?) (valueable?))
+
+      (define/override (clone env) (make-object global% trans? tables needs-top? src-stx cert-stxes))
+
+      (define/override (global->local env)
+        (or (ormap (lambda (e)
+                     (and (module-identifier=? (car e) src-stx)
+                          (make-object ref% (cdr e) src-stx cert-stxes)))
+                   env)
+            this))
+
+      (inherit recertify)
+      (define/override (sexpr)
+	(recertify 
+	 (if needs-top?
+	     (with-syntax ([stx src-stx])
+	       (syntax (#%top . stx)))
+	     src-stx)))
+      
+      (define/public (set-mutated) (set-bucket-mutated?! bucket #t))
+      (define/public (set-inited) (set-bucket-inited-before-use?! bucket #t))))
+
+  (define binding% 
+    (class exp% 
+      (init-field always-inited?)
+      (super-instantiate ())
+      (inherit-field src-stx cert-stxes)
+      (define value #f)
+      (define used 0)
+      (define mutated? #f)
+      (define inited? always-inited?)
+      (define escape #f)
+      
+      (define/public (is-used?) (positive? used))
+      (define/public (is-mutated?) mutated?)
+      (define/public (is-inited?) inited?)
+      (define/public (get-use-count) used)
+
+      (define/public (set-mutated) (set! mutated? #t))
+      (define/public (set-inited) (set! inited? #t))
+      (define/public (set-value v) (set! value v))
+
+      (define/public (escapes?) escape)
+      (define/public (set-escapes x) (set! escape #t))
+      
+      (define/public (clone-binder env) 
+        (make-object binding% 
+          always-inited?
+          (datum->syntax-object
+           #f
+           (gensym (syntax-e src-stx))
+           src-stx
+	   cert-stxes)))
+
+
+      (define/override (reset-varflags)
+        (set! used 0)
+        (set! mutated? #f)
+        (set! inited? always-inited?))
+      (define/override (set-known-values)
+        (set! used (add1 used))
+        (unless inited?
+          (set! mutated? #t)))
+
+      (define/override (valueable?) (and inited? (not mutated?)))
+
+      (define/override (drop-uses) (set! used (sub1 used)))
+
+      (define/override (get-value) 
+        (and (not mutated?)
+             value
+             (send value get-value)))
+      
+      (inherit recertify)
+      (define/override (sexpr)
+        ;; `(==lexical== ,name ,used ,mutated? ,inited? ,(get-value))
+        (recertify src-stx)
+        )
+      (define/public (orig-name)
+        (syntax-e src-stx))))
+
+  (define ref% 
+    (class exp% 
+      (init-field binding)
+      (super-instantiate ())
+      (inherit-field src-stx) ;; The identifier
+      
+      
+      (define/public (is-used?) (send binding is-used?))
+      (define/public (is-mutated?) (send binding is-mutated?))
+      (define/public (is-inited?) (send binding is-inited?))
+      
+      (define/public (get-use-count) (send binding get-use-count))
+
+      (define/public (set-mutated) (send binding set-mutated))
+      (define/public (set-inited) (send binding set-inited))
+      (define/public (set-value v) (send binding set-value v))
+
+      (define/override (set-known-values) (send binding set-known-values))
+
+      (define/override (valueable?) (send binding valueable?))
+      (define/override (can-dup/move?) (valueable?))
+
+      (define/override (drop-uses) (send binding drop-uses))
+
+      (define/override (get-result-arity) 1)
+
+      (define/override (get-value) (send binding get-value))
+
+      (define/override (escape) 
+        (send binding set-escape))
+      
+      (define/override (simplify ctx)
+        (if (context-need ctx)
+            (let ([v (get-value)])
+              (if (and v (send v can-dup/move?))
+                  (begin
+                    (drop-uses)
+                    (send v simplify ctx))
+                  this))
+            (begin
+              (drop-uses)
+              (make-object void% src-stx))))
+
+      (define/override (clone env) (lookup-clone binding this env))
+      (define/override (substitute env) (lookup-clone binding this env))
+
+      (inherit recertify)
+      (define/override (sexpr) 
+        (let ([x (send binding sexpr)])
+	  (recertify (datum->syntax-object
+		      x
+		      (syntax-e x)
+		      src-stx))))
+
+      (define/public (get-binding) binding)
+      (define/public (orig-name) (send binding orig-name))))
+      
+
+  (define begin% 
+    (class exp%
+      (init-field subs)
+      (super-instantiate ())
+      (inherit-field src-stx cert-stxes)
+      (inherit merge-certs)
+      
+      (define/override (nonbind-sub-exprs) subs)
+      (define/override (set-nonbind-sub-exprs s) (set! subs s))
+
+      (define/override (get-result-arity)
+        (if (null? subs)
+            'unknown
+            (let loop ([subs subs])
+              (if (null? (cdr subs))
+                  (send (car subs) get-result-arity)
+                  (loop (cdr subs))))))
+      
+      (define/override (simplify ctx)
+        (set! subs
+              (let loop ([subs subs])
+                (cond
+                  [(null? subs) null]
+                  [(null? (cdr subs))
+                   (list (send (car subs) simplify ctx))]
+                  [else
+                   (let ([r (send (car subs) simplify (need-none ctx))]
+                         [rest (loop (cdr subs))])
+                     (cond
+                       [(send r no-side-effect?)
+                        (send r drop-uses)
+                        rest]
+                       [(is-a? r begin%)
+			(merge-certs r)
+                        (append (send r nonbind-sub-exprs)
+                                rest)]
+                       [else (cons r rest)]))])))
+        (if (and (pair? subs)
+                 (null? (cdr subs)))
+            (let ([v (car subs)])
+	      (send v merge-certs this)
+	      v)
+            this))
+
+      (define/override (clone env)
+        (make-object begin% 
+          (map (lambda (x) (send x clone env)) 
+               subs)
+          src-stx
+	  cert-stxes))
+
+      (inherit recertify)
+      (define/override (sexpr)
+	(with-syntax ([(body ...) (body-sexpr)])
+	  (syntax/loc src-stx (begin body ...))))
+
+      (define/override (body-sexpr)
+	(map (lambda (e) (recertify (get-sexpr e))) subs))))
+  
+  (define top-def% 
+    (class exp% 
+      (init-field formname varnames expr tables)
+      (super-instantiate ())
+      (inherit-field src-stx cert-stxes)
+      (define globals #f)
+      
+      (define/override (nonbind-sub-exprs) (list expr))
+      (define/override (set-nonbind-sub-exprs s) (set! expr (car s)))
+
+      (define/override (get-result-arity) 1)
+
+      (define/override (no-side-effect?) #f)
+      (define/override (valueable?) #f)
+      
+      (define/override (clone env) (make-object top-def% 
+                                     formname
+                                     varnames 
+                                     (send expr clone env)
+                                     tables
+                                     src-stx
+				     cert-stxes))
+
+      (inherit recertify)
+      (define/override (sexpr)
+        (with-syntax ([formname formname]
+                      [(varname ...) varnames]
+                      [rhs (get-sexpr expr)])
+	  (recertify
+	   (syntax/loc src-stx (formname (varname ...) rhs)))))
+
+      (define/public (get-vars) varnames)
+      (define/public (get-rhs) expr)
+
+      ;; Like get-vars, but return global% objects, instead.
+      ;; Useful because the global% object has the global variable bucket info.
+      (define/public (get-globals)
+        (unless globals
+          (set! globals
+                (map (lambda (v)
+                       (make-object global% #f tables #f v))
+                     varnames)))
+        globals)))
+
+  (define variable-def% 
+    (class top-def% 
+      (init varnames expr tables stx)
+      
+      (super-instantiate ((quote-syntax define-values) varnames expr tables stx))))
+
+  (define syntax-def% 
+    (class top-def% 
+      (init varnames expr tables stx)
+      (super-instantiate ((quote-syntax define-syntaxes) varnames expr tables stx))))
+
+  (define for-syntax-def% 
+    (class top-def% 
+      (init varnames expr tables stx)
+      (super-instantiate ((quote-syntax define-values-for-syntax) varnames expr tables stx))))
+
+  (define (install-values vars expr)
+    (when (= 1 (length vars))
+      (send (car vars) set-value expr)))
+
+  (define constant% 
+    (class exp% 
+      (init-field val)
+      (super-instantiate ())
+      (inherit-field src-stx cert-stxes)
+      
+      (define/public (get-const-val) val)
+
+      (define/override (get-value) this)
+      
+      (define/override (valueable?) #t)
+
+      (define/override (can-dup/move?)
+        (or (number? val)
+            (boolean? val)
+            (char? val)
+            (symbol? val)
+            (void? val)))
+
+      (define/override (get-result-arity) 1)
+
+      (define/override (simplify ctx)
+        (cond
+          [(eq? 'bool (context-need ctx))
+           (if (boolean? val)
+               this
+               (make-object constant% #t src-stx))]
+          [(context-need ctx)
+           (cond
+             [(eq? val (void))
+              (make-object void% src-stx)]
+             [else this])]
+          [else (make-object void% src-stx)]))
+      
+      (define/override (clone env) (make-object constant% val src-stx cert-stxes))
+      
+      (inherit recertify)
+      (define/override (sexpr)
+	(let ([vstx (datum->syntax-object (quote-syntax here) val src-stx)])
+	  (cond
+	   [(or (number? val)
+		(string? val)
+		(boolean? val)
+		(char? val))
+	    vstx]
+	   [(syntax? val)
+	    (with-syntax ([vstx vstx])
+	      (recertify
+	       (syntax (quote-syntax vstx))))]
+	    [else
+	     (with-syntax ([vstx vstx])
+	       (syntax (quote vstx)))])))))
+
+  (define void%
+    (class constant% 
+      (init stx)
+      (super-instantiate ((void) stx))
+      (inherit-field src-stx cert-stxes)
+
+      (define/override (sexpr) (quote-syntax (void)))
+
+      (define/override (simplify ctx)
+        (if (eq? 'bool (context-need ctx))
+            (make-object constant% #t src-stx)
+            this))
+
+      (define/override (clone env) (make-object void% src-stx cert-stxes))))
+
+
+  (define app%
+    (class exp% 
+      (init-field rator rands tables)
+      (super-instantiate ())
+      (inherit-field src-stx
+		     cert-stxes)
+      (inherit merge-certs)
+
+      (define known-single-result? #f)
+
+      (inherit set-known-value)
+      
+      (define/private (known-single-result v)
+        (set! known-single-result? #t)
+        (set-known-value v)
+        v)
+
+        
+      (define/override (nonbind-sub-exprs) (cons rator rands))
+      (define/override (set-nonbind-sub-exprs s) 
+        (set! rator (car s))
+        (set! rands (cdr s)))
+
+      (define/override (no-side-effect?)
+        ;; Note: get-result-arity assumes #t result => single value
+        ;;
+        ;; Some prims are known to be side-effect-free (including no errors)
+        ;; get-result-arity assumes 1 when this returns #t
+        (or known-single-result?
+            (and (rator . is-a? . global%)
+                 (send rator is-kernel?)
+                 (memq (send rator orig-name) effectless-prims)
+                 (andmap (lambda (rand) (send rand no-side-effect?))
+                         rands))))
+
+      (define/override (valueable?)
+        (and (rator . is-a? . global%)
+             (send rator is-kernel?)
+             (not (memq (send rator orig-name)
+                        (non-valueable-prims)))
+             (super valueable?)))
+
+      (define/override (get-result-arity)
+        (if (or known-single-result? (no-side-effect?))
+            1
+            'unknown))
+
+      (define/override (escape)
+        (send rator escape)
+        (cond
+          ((bound-identifier=? #'vector-ref (send rator get-stx)) (void))
+          ((and (bound-identifier=? #'vector-set! (send rator get-stx))
+                (not (null? rands)))
+           (map (lambda (x) (send x escape)) (cdr rands)))
+          (else
+           (map (lambda (x) (send x escape)) rands))))
+
+      (define/override (simplify ctx)
+        (super simplify ctx)
+        (cond
+          ;; ((lambda (a ...) ...) v ...) => (let ([a v] ...) ...)
+          [(and (is-a? rator lambda%)
+                (send rator can-inline?))
+	   (if (send rator arg-body-exists? (length rands))
+	       (begin
+		 (send rator drop-other-uses (length rands))
+		 (let-values ([(vars body) (send rator arg-vars-and-body (length rands))])
+		   (for-each (lambda (var rand)
+			       (install-values (list var) rand))
+			     vars rands)
+		   (let ([let-form (make-object let%
+						(map list vars)
+						rands
+						body
+						src-stx
+						cert-stxes)])
+		     (send let-form merge-certs this)
+		     (send let-form merge-certs rator)
+		     (send let-form simplify ctx))))
+	       (begin
+		 (unless (send rator arg-count-ok? (length rands))
+		   (warning "immediate procedure called with wrong number of arguments"
+			    this))
+		 this))]
+          
+          ;; constant folding
+          [(and (is-a? rator global%)
+                (memq (send rator orig-name) foldable-prims)
+                (send rator is-kernel?)
+                (andmap (lambda (x) (is-a? x constant%)) rands))
+           (if (eq? (send rator orig-name) 'void)
+               (make-object void% src-stx)
+               (let ([vals (map (lambda (x) (send x get-const-val)) rands)]
+                     [f (dynamic-require 'mzscheme (send rator orig-name))])
+                 (with-handlers ([exn:fail? (lambda (x) 
+					      (fprintf (current-error-port)
+						       "constant calculation error: ~a~n"
+						       (exn-message x))
+					      this)])
+                   (known-single-result
+                    (send (make-object constant% (apply f vals) src-stx)
+                          simplify ctx)))))]
+          
+          ;; (+ x 1) => (add1 x)
+          [(and (is-a? rator global%)
+                (send rator is-kernel?)
+                (eq? (send rator orig-name) '+)
+                (= 2 (length rands))
+                (or (and (is-a? (car rands) constant%)
+                         (eq? 1 (send (car rands) get-const-val)))
+                    (and (is-a? (cadr rands) constant%)
+                         (eq? 1 (send (cadr rands) get-const-val)))))
+           (make-object app% 
+             (make-object global% (send rator is-trans?) tables #f (quote-syntax add1))
+             (list
+              (if (and (is-a? (car rands) constant%)
+                       (eq? 1 (send (car rands) get-const-val)))
+                  (cadr rands)
+                  (car rands)))
+             tables
+             src-stx
+	     cert-stxes)]
+          ;; (- x 1) => (sub1 x)
+          [(and (is-a? rator global%)
+                (send rator is-kernel?)
+                (eq? (send rator orig-name) '-)
+                (= 2 (length rands))
+                (and (is-a? (cadr rands) constant%)
+                     (eq? 1 (send (cadr rands) get-const-val))))
+           (make-object app% 
+             (make-object global%  (send rator is-trans?) tables #f (quote-syntax sub1))
+             (list (car rands))
+             tables
+             src-stx
+	     cert-stxes)]
+          
+          ;; (car x) where x is known to be a list construction
+          [(and (is-a? rator global%)
+                (send rator is-kernel?)
+                (let-values ([(pos len) (case (send rator orig-name) 
+                                          [(car) (values 0 1)]
+                                          [(cadr) (values 1 1)]
+                                          [(caddr) (values 2 1)]
+                                          [(cadddr) (values 3 1)]
+                                          [(list-ref) (values (and (= 2 (length rands))
+                                                                   (let ([v (send (cadr rands) get-value)])
+                                                                     (and (v . is-a? . constant%)
+                                                                          (send v get-const-val))))
+                                                              2)]
+                                          [else (values #f #f)])])
+                  (and (number? pos)
+                       (= len (length rands))
+                       (and ((car rands) . is-a? . ref%)
+                            (let ([val (send (car rands) get-value)])
+                              (and (val . is-a? . app%)
+                                   (send val get-list-ref pos)))))))
+           =>
+           (lambda (val)
+             (send (car rands) drop-uses)
+             (known-single-result val))]
+          
+          ;; (memv x '(c ...)) in a boolean context => (if (eq[v]? x 'c) ...)
+          ;; relevant to the output of `case'
+          [(and (eq? (context-need ctx) 'bool) 
+                (is-a? rator global%)
+                (send rator is-kernel?)
+                (eq? (send rator orig-name) 'memv)
+                (= 2 (length rands))
+                (is-a? (car rands) ref%)
+                (is-a? (cadr rands) constant%)
+                (list? (send (cadr rands) get-const-val)))
+           (let ([xformed
+                  (let ([l (send (cadr rands) get-const-val)]
+                        [l-stx (send (cadr rands) get-stx)]
+                        [false (make-object constant% #f (datum->syntax-object #f #f))]
+                        [true (make-object constant% #t (datum->syntax-object #f #t))])
+                    (if (null? l)
+                        false
+                        (let loop ([l l])
+                          (let ([test
+                                 (make-object app%
+                                   (make-object global%
+                                     (send rator is-trans?)
+                                     tables
+                                     #f
+                                     (let ([a (car l)])
+                                       (if (or (symbol? a)
+                                               (and (number? a)
+                                                    (exact? a)
+                                                    (integer? a)
+                                                    ;; fixnums:
+                                                    (<= (- (expt 2 29))
+                                                        a
+                                                        (expt 2 29))))
+                                           (quote-syntax eq?)
+                                           (quote-syntax eqv?))))
+                                   (list
+                                    (car rands)
+                                    (make-object constant% 
+                                      (car l)
+                                      l-stx))
+                                   tables
+                                   src-stx
+				   cert-stxes)])
+                            (cond
+                              [(null? (cdr l)) test]
+                              [else (let ([rest (loop (cdr l))])
+                                      ;; increment use count:
+                                      (send (car rands) set-known-values)
+                                      (make-object if%
+                                        test
+                                        true
+                                        rest
+                                        src-stx
+					cert-stxes))])))))])
+	     (send xformed merge-certs this)
+             (send xformed simplify ctx))]
+          
+          ;; (values e) where e has result arity 1
+          [(and (is-a? rator global%)
+                (send rator is-kernel?)
+                (eq? 'values (send rator orig-name))
+                (= 1 (length rands))
+                (equal? 1 (send (car rands) get-result-arity)))
+	   (send (car rands) merge-certs this)
+           (known-single-result (car rands))]
+          
+          ;; Check arity of other calls to primitives
+          [(and (is-a? rator global%)
+                (send rator is-kernel?))
+	   (let ([f (dynamic-require 'mzscheme (send rator orig-name))])
+	     (cond
+	      [(not (procedure? f))
+	       (warning "call of non-procedure" this)]
+	      [(not (procedure-arity-includes? f (length rands)))
+	       (warning "primitive called with wrong number of arguments" this)]))
+           this]
+
+          ;; inlining
+          [(and #f ;; disabled!
+		(> (fuel) 0)
+                (or (is-a? rator ref%) (is-a? rator global%))
+                (is-a? (send rator get-value) lambda%)
+                (not (send (send rator get-value) get-simplifying-body)))
+           (let ([f (send (send rator get-value) clone null)])
+             (send rator drop-uses)
+             (set! rator f)
+             (send f set-known-values)
+             ;; Now we have ((lambda ...) ...). Go again.
+             (fuel (sub1 (fuel)))
+             (if (= (fuel) (sub1 max-fuel))
+                 (begin0
+                   (simplify ctx)
+                   (fuel max-fuel))
+                 (simplify ctx)))]
+
+          ;; Check arity of a call to a known (non-primitive) function
+          [(and (or (is-a? rator ref%) (is-a? rator global%))
+                (is-a? (send rator get-value) lambda%))
+           (let ([f (send rator get-value)])
+	     (unless (send f arg-count-ok? (length rands))
+	       (warning "procedure called with wrong number of arguments"
+			this))
+	     this)]
+          
+          [else this]))
+      
+      (define/override (clone env) (make-object app%
+                                     (send rator clone env)
+                                     (map (lambda (rand)
+                                            (send rand clone env))
+                                          rands)
+                                     tables
+                                     src-stx
+				     cert-stxes))
+
+      (inherit recertify)
+      (define/override (sexpr)
+	(recertify
+	 (keep-mzc-property
+	  (with-syntax ([rator (get-sexpr rator)]
+			[(rand ...) (map get-sexpr rands)])
+	    (syntax/loc src-stx (rator rand ...)))
+	  src-stx)))
+
+      ;; Checks whether the expression is an app of `values'
+      ;; to a particular set of bindings.
+      (define/public (is-values-of? args)
+        (and (rator . is-a? . global%)
+             (send rator is-kernel?)
+             (eq? (send rator orig-name) 'values)
+             (= (length rands) (length args))
+             (andmap
+              (lambda (rand arg)
+                (and (rand . is-a? . ref%)
+                     (eq? arg (send rand get-binding))))
+              rands args)))
+
+      ;; If app constructs a list and the nth element can be
+      ;;  safely extracted, then extract it.
+      (define/public (get-list-ref n)
+        (and (rator . is-a? . global%)
+             (send rator is-kernel?)
+             (eq? 'list (send rator orig-name))
+             ((length rands) . > . n)
+             (let ([i (list-ref rands n)])
+               (if (send i can-dup/move?)
+                   i
+                   #f))))))
+
+  (define lambda% 
+    (class exp% 
+      (init-field varss normal?s bodys)
+      (super-instantiate ())
+      (inherit-field src-stx cert-stxes)
+      (define simplifying-body #f)
+      
+      
+      (inherit drop-uses)
+      
+      
+      (define/private (multarity-ize l)
+        (if (null? (cdr l))
+            (car l)
+            (cons (car l)
+                  (multarity-ize (cdr l)))))
+
+      (define/public (get-simplifying-body) simplifying-body)
+      
+      (define/public (multi?) (or (null? bodys)
+                                  (pair? (cdr bodys))))
+      
+      (define/public (arg-body-exists? n)
+        (ormap (lambda (vs n?) (and n? (= n (length vs))))
+               varss normal?s))
+      (define/public (arg-count-ok? n)
+        (ormap (lambda (vs n?) (or (and n? (= n (length vs)))
+				   (and (not n?) (n . >= . (sub1 (length vs))))))
+               varss normal?s))
+      (define/public (arg-vars-and-body n)
+        (let loop ([varss varss][normal?s normal?s][bodys bodys])
+          (if (and (car normal?s)
+                   (= (length (car varss)) n))
+              (values (car varss) (car bodys))
+              (loop (cdr varss) (cdr normal?s) (cdr bodys)))))
+      
+      (define/public (drop-other-uses n)
+        (let loop ([n n][varss varss][normal?s normal?s][bodys bodys])
+          (unless (null? varss)
+            (let ([n (if (and (car normal?s)
+                              (= (length (car varss)) n))
+                         -1
+                         (begin
+                           (send (car bodys) drop-uses)
+                           n))])
+              (loop n (cdr varss) (cdr normal?s) (cdr bodys))))))
+      
+      (define/public (can-inline?)
+        (not (syntax-property src-stx 'mzc-cffi)))
+      
+      (define/override (bind-sub-exprs) (apply append varss))
+      (define/override (nonbind-sub-exprs) bodys)
+      (define/override (set-nonbind-sub-exprs s) (set! bodys s))
+      
+      (define/override (no-side-effect?) #t)
+      (define/override (get-result-arity) 1)
+      
+      (define/override (valueable?) #t)
+	
+      (define/override (simplify ctx)
+        (if (eq? 'bool (context-need ctx))
+            (begin
+              (drop-uses)
+              (make-object constant% #t src-stx))
+            (begin
+              (set! simplifying-body #t)
+              (begin0
+                (super simplify ctx)
+                (set! simplifying-body #f)))))
+      
+      (define/override (clone env)
+        (let ([varss+bodys
+               (let loop ([varss varss][bodys bodys])
+                 (if (null? varss)
+                     null
+                     (let* ([vars (car varss)]
+                            [new-vars (map (lambda (v) (send v clone-binder env))
+                                           vars)])
+                       (cons
+                        (cons new-vars
+                              (send (car bodys)
+                                    clone (append (map cons vars new-vars)
+                                                  env)))
+                        (loop (cdr varss) (cdr bodys))))))])
+          (make-object lambda%
+            (map car varss+bodys)
+            normal?s
+            (map cdr varss+bodys)
+            src-stx
+	    cert-stxes)))
+
+      (inherit recertify)
+      (define/override (sexpr)
+        (with-syntax ([(vars ...)
+                       (map (lambda (vars normal?)
+                              (let ([vs (map get-sexpr vars)])
+                                (if normal?
+                                    vs
+                                    (multarity-ize vs))))
+                            varss normal?s)]
+                      [(body ...)
+                       (map (lambda (body)
+                              (get-body-sexpr body))
+                            bodys)])
+	  (recertify
+	   (keep-mzc-property
+	    (if (multi?)
+		(syntax/loc src-stx
+		  (case-lambda
+		   [vars . body] ...))
+		(with-syntax ([body (car (syntax->list (syntax (body ...))))])
+		  (syntax/loc src-stx
+		    (lambda vars ... . body))))
+	    src-stx))))))
+
+  (define local% 
+    (class exp% 
+      (init-field form varss rhss body)
+      (super-instantiate ())
+      (inherit-field src-stx cert-stxes)
+      (inherit merge-certs)
+      
+      (define/public (get-rhss) rhss)
+      (define/public (get-varss) varss)
+      (define/public (get-body) body)
+
+      (define/override (bind-sub-exprs) (apply append varss))
+      (define/override (nonbind-sub-exprs) (cons body rhss))
+      (define/override (set-nonbind-sub-exprs s) 
+        (set! body (car s))
+        (set! rhss (cdr s)))
+
+      (define/override (get-result-arity) (send body get-result-arity))
+      
+      (define/override (simplify ctx)
+        (set! rhss (map (lambda (rhs vars) 
+                          (send rhs simplify 
+                                (make-context 'all
+                                              (append vars (context-indef ctx)))))
+                        rhss varss))
+        (set! body (send body simplify ctx))
+        
+        ;; Drop unused constant bindings
+        (set!-values (varss rhss)
+                     (let loop ([varss varss][rhss rhss])
+                       (cond
+                         [(null? varss) (values null null)]
+                         [else (let-values ([(rest-vss rest-rhss)
+                                             (loop (cdr varss) (cdr rhss))])
+                                 (if (and (andmap (lambda (var) (not (send var is-used?)))
+                                                  (car varss))
+                                          (equal? (send (car rhss) get-result-arity)
+                                                  (length (car varss)))
+                                          (send (car rhss) no-side-effect?))
+                                     (begin
+                                       (send (car rhss) drop-uses)
+                                       (values rest-vss rest-rhss))
+                                     (values (cons (car varss) rest-vss)
+                                             (cons (car rhss) rest-rhss))))])))
+        
+        (cond
+          ;; (let-values ([(x) e]) (if e ... ...))
+          ;;  is a pattern created by `or'
+          [(and (is-a? body if%)
+                (let ([t (send body get-if-test)])
+                  (and (is-a? t binding%)
+                       (= 1 (length varss))
+                       (= 1 (length (car varss)))
+                       (eq? (caar varss) t)
+                       (= 1 (send t get-use-count)))))
+           (make-object if%
+             (car rhss)
+             (send body get-if-then)
+             (send body get-if-else)
+             src-stx
+	     cert-stxes)]
+          [(null? varss)
+	   (send body merge-certs this)
+           (send body simplify ctx)]
+          ;; (let-values [(x) y] ...) whether y is inited, and
+          ;;  neither x nor y is mutated => replace x by y
+          [(and (andmap (lambda (vars) (= 1 (length vars))) varss)
+                (send (caar varss) valueable?)
+                (andmap (lambda (rhs) (and (or (rhs . is-a? . ref%)
+                                               (rhs . is-a? . global%))
+                                           (send rhs valueable?)))
+                        rhss))
+	   (send body merge-certs this)
+           (send body substitute
+                 (map (lambda (vars rhs) (cons (car vars) 
+                                               (if (rhs . is-a? . ref%)
+                                                   (send rhs get-binding)
+                                                   rhs)))
+                      varss rhss))]
+          
+          [else
+           this]))
+
+      (define/override (clone env)
+        (let* ([new-varss
+                (map (lambda (vs)
+                       (map (lambda (v) (send v clone-binder env))
+                            vs))
+                     varss)]
+               [body-env (append
+                          (map cons
+                               (apply append varss)
+                               (apply append new-varss))
+                          env)]
+               [letrec? (eq? form 'letrec-values)])
+          (make-object (if letrec? letrec% let%)
+            new-varss
+            (map (lambda (rhs) 
+                   (send rhs clone (if letrec? body-env env)))
+                 rhss)
+            (send body clone body-env)
+            src-stx
+	    cert-stxes)))
+
+      (define/override (get-value) (send body get-value))
+	
+      (inherit recertify)
+      (define/override (sexpr)
+        (with-syntax ([form form]
+                      [(vars ...)
+                       (map (lambda (vars)
+                              (map get-sexpr vars))
+                            varss)]
+                      [(rhs ...)
+                       (map get-sexpr rhss)]
+                      [(body ...) (get-body-sexpr body)])
+	  (recertify
+	   (syntax/loc src-stx
+	     (form ([vars rhs] ...) 
+		   body ...)))))))
+    
+  (define let%
+    (class local% 
+      (init -varss -rhss -body -stx -cert-stxes)
+      (inherit get-varss get-rhss get-body)
+      
+      (define/override (set-known-values)
+        (for-each (lambda (vars rhs) (install-values vars rhs))
+                  (get-varss) (get-rhss))
+        (super set-known-values))
+      
+      (super-instantiate ((quote-syntax let-values) -varss -rhss -body -stx -cert-stxes))))
+
+  (define letrec%
+    (class local% 
+      (init -varss -rhss -body -stx -cert-stxes) 
+      (inherit get-varss get-rhss)
+      
+      (define/override (set-known-values)
+        (let loop ([varss (get-varss)][rhss (get-rhss)])
+          (unless (null? varss)
+            (when (send (car rhss) valueable?)
+              (for-each (lambda (var) (send var set-inited))
+                        (car varss))
+              (loop (cdr varss) (cdr rhss)))))
+        (for-each install-values (get-varss) (get-rhss))
+        (super set-known-values))
+
+      (super-instantiate ((quote-syntax letrec-values) -varss -rhss -body -stx -cert-stxes))))
+
+  (define set!%
+    (class exp% 
+      (init-field var val)
+      (super-instantiate ())
+      (inherit-field src-stx cert-stxes)
+      
+      (define/override (nonbind-sub-exprs) (list var val))
+      (define/override (set-nonbind-sub-exprs s) 
+        (set! var (car s))
+        (set! val (cadr s)))
+
+      (define/override (no-side-effect?) #f)
+      (define/override (valueable?) #f)
+      (define/override (get-result-arity) 1)
+	
+      (define/override (set-known-values)
+        (send var set-mutated)
+        (send var set-known-values) ; increments use
+        (send val set-known-values))
+	
+      (define/override (set-mutability)
+        (send var set-mutated)
+	(super set-mutability))
+	
+      (define/override (clone env)
+        (make-object set!% 
+          (send var clone env)
+          (send val clone env)
+          src-stx
+	  cert-stxes))
+
+      (inherit recertify)
+      (define/override (sexpr)
+	(with-syntax ([var (get-sexpr var)]
+		      [val (get-sexpr val)])
+	  (recertify
+	   (syntax/loc src-stx
+	     (set! var val)))))))
+
+  (define if%
+    (class exp% 
+      (init-field test then else)
+      (super-instantiate ())
+      (inherit-field src-stx cert-stxes)
+      
+      (define/public (get-if-test) test)
+      (define/public (get-if-then) then)
+      (define/public (get-if-else) else)
+
+      (define/override (nonbind-sub-exprs) (list test then else))
+      (define/override (set-nonbind-sub-exprs s)
+        (set! test (car s))
+        (set! then (cadr s))
+        (set! else (caddr s)))
+	
+      (define/override (get-result-arity)
+        (let ([t (send then get-result-arity)]
+              [e (send else get-result-arity)])
+          (if (equal? t e)
+              t
+              'unknown)))
+      
+      (define/override (simplify ctx)
+        (set! test (send test simplify (need-bool ctx)))
+        (set! then (send then simplify ctx))
+        (set! else (send else simplify ctx))
+
+        ;; (if xvar xvar y) when need bool
+        ;;   => (if xvar #t y)
+        (when (and (eq? 'bool (context-need ctx))
+                   (is-a? test binding%)
+                   (eq? test then))
+          (send then drop-uses)
+          (set! then (make-object constant% #t src-stx)))
+        (when (and (eq? 'bool (context-need ctx))
+                   (eq? test else)
+                   (is-a? test binding%))
+          (send else drop-uses)
+          (set! else (make-object constant% #f src-stx)))
+        
+        
+        (cond
+          ;; Constant switch
+          [(is-a? test constant%)
+           (if (eq? (send test get-const-val) #f)
+               (begin
+                 (send test drop-uses)
+                 (send then drop-uses)
+                 else)
+               (begin
+                 (send test drop-uses)
+                 (send else drop-uses)
+                 then))]
+          
+          ;; (if (if x y #f) a (void))
+          ;;    => (if x (if y a (void)) (void))
+          [(and (is-a? test if%)
+                (is-a? else void%)
+                (let ([c (send test get-if-else)])
+                  (and (is-a? c constant%)
+                       (eq? #f (send c get-const-val)))))
+           (send
+            (make-object if%
+              (send test get-if-test)
+              (make-object if%
+                (send test get-if-then)
+                then
+                (make-object void% src-stx)
+                src-stx
+		cert-stxes)
+              (make-object void% src-stx)
+              src-stx
+	      cert-stxes)
+            simplify ctx)]
+          
+          [else this]))
+
+      (define/override (clone env) 
+        (make-object if%
+          (send test clone env)
+          (send then clone env)
+          (send else clone env)
+          src-stx
+	  cert-stxes))
+      
+      (inherit recertify)
+      (define/override (sexpr)
+        (with-syntax ([test (get-sexpr test)]
+                      [then (get-sexpr then)])
+	  (recertify
+	   (if (else . is-a? . void%)
+	       (syntax/loc src-stx
+		 (if test then))
+	       (with-syntax ([else (get-sexpr else)])
+		 (syntax/loc src-stx
+		   (if test then else)))))))))
+
+  (define begin0%
+    (class exp% 
+      (init-field first rest)
+      (super-instantiate ())
+      (inherit-field src-stx cert-stxes)
+      
+      (define/override (nonbind-sub-exprs) (list first rest))
+      (define/override (set-nonbind-sub-exprs s)
+        (set! first (car s))
+        (set! rest (cadr s)))
+	
+      (define/override (get-result-arity) (send first get-result-arity))
+
+      (define/override (simplify ctx)
+        (set! first (send first simplify ctx))
+        (set! rest (send rest simplify (need-none ctx)))
+        (if (send rest no-side-effect?)
+            (begin
+              (send rest drop-uses)
+	      (send first merge-certs this)
+              first)
+            this))
+	
+      (define/override (clone env) 
+        (make-object begin0%
+          (send first clone env)
+          (send rest clone env)
+	  src-stx
+	  cert-stxes))
+	
+      (inherit recertify)
+      (define/override (sexpr)
+	(with-syntax ([first (get-sexpr first)]
+		      [(rest ...) (get-body-sexpr rest)])
+	  (recertify
+	   (syntax/loc src-stx
+	     (begin0 first rest ...)))))))
+
+  (define wcm%
+    (class exp% 
+      (init-field key val body)
+      (super-instantiate ())
+      (inherit-field src-stx cert-stxes)
+
+      (define/override (nonbind-sub-exprs) (list key val body))
+      (define/override (set-nonbind-sub-exprs s)
+        (set! key (car s))
+        (set! val (cadr s))
+        (set! body (caddr s)))
+
+      (define/override (get-result-arity) (send body get-result-arity))
+	
+      (define/override (clone env) 
+        (make-object wcm%
+          (send key clone env)
+          (send val clone env)
+          (send body clone env)
+	  src-stx
+	  cert-stxes))
+
+      (inherit recertify)
+      (define/override (sexpr)
+        (with-syntax ([key (get-sexpr key)]
+                      [val (get-sexpr val)]
+                      [body (get-sexpr body)])
+	  (recertify
+	   (syntax/loc src-stx
+	     (with-continuation-mark key val body)))))))
+
+  (define module%
+    (class exp% 
+      (init-field body et-body name init-req req-prov tables)
+      (super-instantiate ())
+      (inherit-field src-stx)
+      
+      (define/override (reset-varflags)
+        (for-each (lambda (e) (send e reset-varflags)) body)
+        (for-each (lambda (e) (send e reset-varflags)) et-body))
+      (define/override (set-known-values)
+        ;; Assumes varflags are reset
+        (for-each (lambda (e) (send e set-known-values)) (nonbind-sub-exprs)))
+
+      (define/override (drop-uses)
+        ;; Assumes varflags are reset
+        (for-each (lambda (e) (send e drop-uses)) (nonbind-sub-exprs)))
+	
+      (define/override (no-side-effect?) #f)
+      (define/override (valueable?) #f)
+
+      (define/override (get-result-arity) 'unknown)
+
+      (define/override (sub-exprs) (append (append et-body body)))
+      (define/override (bind-sub-exprs) null)
+      (define/override (nonbind-sub-exprs) (sub-exprs))
+      (define/override (set-nonbind-sub-exprs l)
+        (let-values ([(etb b)
+                      (let loop ([l l][etb et-body][accum null])
+                        (cond
+                          [(null? etb)
+                           (values (reverse! accum) l)]
+                          [else (loop (cdr l) (cdr etb) (cons (car l)
+                                                              accum))]))])
+          (set! body body)
+          (set! et-body etb)))
+      
+      ;; expose known bindings by converting a sequence of top-level
+      ;;  expressions into a letrec:
+      ;;   (define-values (a ...) body) ...
+      ;;   => (define-values (a ... ...) 
+      ;;          (letrec-values ([(a ...) body] ...) (values a ... ...)))
+      (define/override (reorganize)
+        (let ([-body (map (lambda (x) (send x reorganize)) body)]
+              [-et-body (map (lambda (x) (send x reorganize)) et-body)])
+          (let loop ([l -body][defs null])
+            (cond
+              [(and (pair? l) 
+                    ((car l) . is-a? . variable-def%)
+                    (not (ormap (lambda (v) (send v is-mutated?))
+                                (send (car l) get-globals)))
+                    (send (send (car l) get-rhs) valueable?))
+               (for-each (lambda (g) (send g set-inited))
+                         (send (car l) get-globals))
+               (loop (cdr l)
+                     (cons (car l) defs))]
+              [else
+               (if (null? defs)
+                   (void) ; no reorganization
+                   (let* ([defs (reverse defs)]
+                          [varss
+                           (map (lambda (def) (send def get-vars)) defs)]
+                          [rhss
+                           (map (lambda (def) (send def get-rhs)) defs)]
+                          [lex-varss (map (lambda (vars)
+                                            (map (lambda (var)
+                                                   (make-object binding%
+                                                     #t
+                                                     (datum->syntax-object
+                                                      #f
+                                                      (syntax-e var)
+                                                      var)))
+                                                 vars))
+                                          varss)]
+                          [vars (apply append varss)]
+                          [lex-vars (apply append lex-varss)]
+                          [env (map cons vars lex-vars)])
+                     (set! -body
+                           (cons
+                            (make-object variable-def%
+                              vars
+                              (make-object letrec%
+                                lex-varss
+                                (map (lambda (rhs)
+                                       (send rhs global->local env))
+                                     rhss)
+                                (make-object app%
+                                  (make-object global%
+                                    #f
+                                    tables
+                                    #f
+                                    (quote-syntax values))
+                                  (map (lambda (var lex-var)
+                                         (make-object ref% lex-var var))
+                                       vars
+                                       lex-vars)
+                                  tables 
+                                  (send (car defs) get-stx))
+                                (send (car defs) get-stx)
+				(send (car defs) get-cert-stxes))
+                              tables
+                              (send (car defs) get-stx))
+                            l))))])
+            (set! body -body)
+            (set! et-body -et-body)))
+        this)
+
+      (define/override (deorganize)
+        ;; Check for
+        ;;   (define-values (a ... ...) 
+        ;;       (letrec-values ([(a ...) body] ...) (values a ... ...)))
+        ;;   => (define-values (a ...) body) ...
+        (when (and (pair? body)
+                   (let ([first (car body)])
+                     (and (first . is-a? . variable-def%)
+                          (let ([rhs (send first get-rhs)])
+                            (and (rhs . is-a? . letrec%)
+                                 (let ([lbody (send rhs get-body)]
+                                       [lvarss (send rhs get-varss)])
+                                   (and (lbody . is-a? . app%)
+                                        (send lbody is-values-of? 
+                                              (apply append lvarss)))))))))
+          (let ([vars (send (car body) get-vars)]
+                [bindingss (send (send (car body) get-rhs) get-varss)]
+                [bodys (send (send (car body) get-rhs) get-rhss)])
+            ;; split vars into varss:
+            (let ([varss (let loop ([bindingss bindingss][vars vars])
+                           (if (null? bindingss)
+                               null
+                               (let loop2 ([bindings (car bindingss)][vars vars][accum null])
+                                 (if (null? bindings)
+                                     (cons (reverse! accum)
+                                           (loop (cdr bindingss) vars))
+                                     (loop2 (cdr bindings) (cdr vars) (cons (car vars) accum))))))]
+                  [bindings (apply append bindingss)])
+              (let ([env (map cons bindings 
+                              (map (lambda (var) 
+                                     (make-object global% #f tables #f var)) 
+                                   vars))])
+                (set! body
+                      (append
+                       (map (lambda (vars body)
+                              (make-object variable-def%
+                                vars
+                                (send body substitute env)
+                                tables
+                                src-stx))
+                            varss bodys)
+                       (cdr body)))))))
+        (super deorganize))
+
+      (inherit recertify)
+      (define/override (sexpr)
+	(with-syntax ([name name]
+		      [init-req init-req]
+		      [(body ...) (map get-sexpr body)]
+		      [(et-body ...) (map get-sexpr et-body)]
+		      [(req-prov ...) (map get-sexpr req-prov)])
+	  (recertify
+	   (syntax/loc src-stx
+	     (module name init-req
+	       (#%plain-module-begin
+		req-prov ...
+		body ...
+		et-body ...))))))
+      (define/override (body-sexpr)
+	(list (sexpr)))))
+
+  ;; requires and provides should really be ignored:
+  (define require/provide%
+    (class exp% 
+
+      (define/override (valueable?) #f)
+      (define/override (no-side-effect?) #f)
+      (super-instantiate ())))
+  
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; Warning reporting
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (define (print-warning msg exp)
+    (let ([stx (send exp get-stx)])
+      (when (syntax-source stx)
+	(fprintf (current-output-port) "~a:" (syntax-source stx))
+	(cond
+	 [(syntax-column stx)
+	  (fprintf (current-output-port) "~a:~a:" 
+		   (syntax-line stx)
+		   (syntax-column stx))]
+	 [(syntax-position stx)
+	  (fprintf (current-output-port) ":~a:" 
+		   (syntax-position stx))])
+	(fprintf (current-output-port) " "))
+      (fprintf (current-output-port) 
+	       "~a: ~e~n"
+	       msg
+	       (syntax-object->datum (send exp sexpr)))))
+
+  (define (warning msg exp)
+    ; (print-warning msg exp)
+    (void))
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; Parser
+  ;; converts a syntax object to an exp%
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (define (parse-args env args)
+    (let-values ([(norm? ids)
+		  (syntax-case args ()
+		    [id
+		     (identifier? (syntax id))
+		     (values #f (list (syntax id)))]
+		    [(id ...)
+		     (values #t (syntax->list args))]
+		    [_else (values #f
+				   (let loop ([args args])
+				     (syntax-case args ()
+				       [id (identifier? args) (list args)]
+				       [(id . rest)
+					(cons (syntax id) (loop (syntax rest)))])))])])
+      (let ([bindings (map (lambda (id) (make-object binding% #t id)) ids)])
+	(values
+	 (append (map cons ids bindings) env)
+	 bindings
+	 norm?))))
+
+  (define (parse-let % rec? stx env loop)
+    (syntax-case stx ()
+      [(_ ([vars rhs] ...) . body)
+       (let* ([varses (syntax->list (syntax (vars ...)))]
+	      [rhses (syntax->list (syntax (rhs ...)))]
+	      [var-objses (map (lambda (vars)
+				 (map (lambda (var)
+					(make-object binding% (not rec?) var))
+				      (syntax->list vars)))
+			       varses)]
+	      [body-env (append
+			 (apply
+			  append
+			  (map (lambda (var-objs vars)
+				 (map cons
+				      (syntax->list vars)
+				      var-objs))
+			       var-objses
+			       varses))
+			 env)])
+	 (make-object %
+           var-objses
+           (map (lambda (rhs)
+                  (loop rhs (if rec? body-env env)))
+                rhses)
+           (loop (syntax (begin . body)) body-env)
+           stx
+	   (list stx)))]))
+
+  (define (stx-bound-assq ssym l)
+    (ormap (lambda (p)
+	     (and (bound-identifier=? ssym (car p))
+		  p))
+	   l))
+
+  (define (lookup-clone binding var env)
+    (let ([s (assq binding env)])
+      (if s
+	  (let ([b (cdr s)])
+	    (if (b . is-a? . binding%)
+		(make-object ref% b (send var get-stx) (send var get-cert-stxes))
+		;; it's a global%:
+		b))
+	  var)))
+
+  (define (make-parse top?)
+    (lambda (stx env trans? in-module? tables)
+      (kernel-syntax-case stx trans?
+	[id
+	 (identifier? stx)
+	 (let ([a (stx-bound-assq stx env)])
+	   (if a
+	       (make-object ref% (cdr a) stx)
+	       (make-object global% trans? tables #f stx)))]
+
+	[(#%top . id)
+	 (make-object global% trans? tables #t (syntax id))]
+	
+	[(#%datum . val)
+	 (make-object constant% (syntax-object->datum (syntax val)) stx)]
+
+	[(define-values names rhs)
+	 (make-object variable-def% 
+           (syntax->list (syntax names))
+           (parse (syntax rhs) env #f in-module? tables)
+           tables
+           stx)]
+	
+	[(define-syntaxes names rhs)
+	 (make-object syntax-def% 
+           (syntax->list (syntax names))
+           (parse (syntax rhs) env #t in-module? tables)
+           tables
+           stx)]
+	
+	[(define-values-for-syntax names rhs)
+	 (make-object for-syntax-def% 
+           (syntax->list (syntax names))
+           (parse (syntax rhs) env #t in-module? tables)
+           tables
+           stx)]
+	
+	[(begin . exprs)
+	 (make-object begin%
+           (map (lambda (e) ((if top? parse-top parse) e env trans? in-module? tables))
+                (syntax->list (syntax exprs)))
+           stx)]
+
+	[(begin0 expr . exprs)
+	 (make-object begin0%
+           (parse (syntax expr) env trans? in-module? tables)
+           (parse (syntax (begin . exprs)) env trans? in-module? tables)
+           stx)]
+
+	[(quote expr)
+	 (make-object constant% (syntax-object->datum (syntax expr)) stx)]
+
+	[(quote-syntax expr)
+	 (make-object constant% (syntax expr) stx)]
+
+	[(lambda args . body)
+	 (let-values ([(env args norm?) (parse-args env (syntax args))])
+	   (make-object lambda%
+             (list args)
+             (list norm?)
+             (list (parse (syntax (begin . body)) env trans? in-module? tables))
+             stx))]
+
+	[(case-lambda [args . body] ...)
+	 (let-values ([(envs argses norm?s)
+		       (let ([es+as+n?s
+			      (map
+			       (lambda (args)
+				 (let-values ([(env args norm?) (parse-args env args)])
+				   (cons env (cons args norm?))))
+			       (syntax->list (syntax (args ...))))])
+			 (values
+			  (map car es+as+n?s)
+			  (map cadr es+as+n?s)
+			  (map cddr es+as+n?s)))])
+	   (make-object lambda%
+             argses
+             norm?s
+             (map (lambda (env body)
+                    (with-syntax ([body body])
+                      (parse (syntax (begin . body)) env trans? in-module? tables)))
+                  envs
+                  (syntax->list (syntax (body ...))))
+             stx))]
+	
+	[(let-values . _)
+	 (parse-let let% #f stx env
+		    (lambda (b env) (parse b env trans? in-module? tables)))]
+	[(letrec-values . _)
+	 (parse-let letrec% #t stx env
+		    (lambda (b env) (parse b env trans? in-module? tables)))]
+
+	[(set! var rhs)
+	 (make-object set!% 
+           (parse (syntax var) env trans? in-module? tables)
+           (parse (syntax rhs) env trans? in-module? tables)
+           stx)]
+
+	[(if test then . else)
+	 (make-object if%
+           (parse (syntax test) env trans? in-module? tables)
+           (parse (syntax then) env trans? in-module? tables)
+           (if (null? (syntax-e (syntax else)))
+               (parse (quote-syntax (#%app void)) env trans? in-module? tables)
+               (parse (car (syntax-e (syntax else))) env trans? in-module? tables))
+           stx)]
+	
+	[(with-continuation-mark k v body)
+	 (make-object wcm% 
+           (parse (syntax k) env trans? in-module? tables)
+           (parse (syntax v) env trans? in-module? tables)
+           (parse (syntax body) env trans? in-module? tables)
+           stx)]
+	
+	[(#%app)
+	 (make-object constant% null stx)]
+	
+	[(#%app func . args)
+	 (make-object app% 
+           (parse (syntax func) env trans? in-module? tables)
+           (map (lambda (v) (parse v env trans? in-module? tables)) (syntax->list (syntax args)))
+           tables
+           stx)]
+
+	[(module name init-require (#%plain-module-begin . body))
+	 (let* ([body (map (lambda (x)
+			     (parse x env #f #t tables))
+			   (syntax->list (syntax body)))]
+		[et-body
+		 (filter (lambda (x) (or (x . is-a? . syntax-def%)
+					 (x . is-a? . for-syntax-def%)))
+			 body)]
+		[rt-body
+		 (filter (lambda (x) (not (or (x . is-a? . syntax-def%)
+					      (x . is-a? . for-syntax-def%)
+					      (x . is-a? . require/provide%))))
+			 body)]
+		[req-prov
+		 (filter (lambda (x) (x . is-a? . require/provide%))
+			 body)])
+	   (make-object module%
+             rt-body
+             et-body
+             (syntax name)
+             (syntax init-require)
+             req-prov
+             tables stx))]
+        
+	[(require . i) (make-object require/provide% stx)]
+	[(require-for-syntax . i) (make-object require/provide% stx)]
+	[(require-for-template . i) (make-object require/provide% stx)]
+	[(provide i ...) (make-object require/provide% stx)]
+
+	[else (error 'parse "unknown expression: ~a" (syntax-object->datum stx))])))
+
+  (define parse (make-parse #f))
+  (define parse-top (make-parse #t))
+
+  (define (create-tables)
+    (make-tables (make-hash-table) (make-hash-table)))
+
+  
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; Optimizer
+  ;; the driver function
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (define optimize 
+    (opt-lambda (e [for-mzc? #f])
+      (let ([p (parse-top e null #f #f (create-tables))])
+	(send p set-mutability)
+	(send p reorganize)
+	(send p set-known-values)
+	(let ([p (send p simplify (make-context 'all null))])
+	  (let ([v (get-sexpr (if for-mzc?
+				  p
+				  (send p deorganize)))])
+	    v)))))
+	
+  (provide optimize))
diff --git a/collects/compiler/start.ss b/collects/compiler/start.ss
new file mode 100644
index 0000000000..ad67e4bdf0
--- /dev/null
+++ b/collects/compiler/start.ss
@@ -0,0 +1,535 @@
+;; Starts up the compiler according to command-line flags.
+;; (c) 1997-2001 PLT
+
+;; Scheme->C compilation is the only mode really handled
+;;  by the code in this collection. Other modes are handled
+;;  by other collections, such as MzLib and dynext.
+;; If you are interested Scheme->C part of mzc, look in
+;;  driver.ss, which is the `main' file for the compiler.
+
+;; Different compilation modes are driven by dynamically
+;;  linking in appropriate libraries. This is handled
+;;  by compiler.ss.
+
+;; See doc.txt for information about the Scheme-level interface
+;;  provided by this collection.
+
+(module start mzscheme
+
+  ;; On error, exit with 1 status code
+  (error-escape-handler (lambda () (exit 1)))
+
+  (error-print-width 512)
+
+  (require (prefix compiler:option: "option.ss"))
+  (require "compiler.ss")
+
+  ;; Read argv array for arguments and input file name
+  (require (lib "cmdline.ss")
+	   (lib "list.ss")
+	   (lib "file.ss" "dynext")
+	   (lib "compile.ss" "dynext")
+	   (lib "link.ss" "dynext")
+	   (lib "pack.ss" "setup")
+	   (lib "getinfo.ss" "setup"))
+
+  (define dest-dir (make-parameter #f))
+  (define auto-dest-dir (make-parameter #f))
+
+  (define ld-output (make-parameter #f))
+
+  (define exe-output (make-parameter #f))
+  (define exe-embedded-flags (make-parameter '("-mvq-")))
+  (define exe-embedded-libraries (make-parameter null))
+  (define exe-aux (make-parameter null))
+
+  (define module-mode (make-parameter #f))
+
+  (define default-plt-name "archive")
+
+  (define plt-output (make-parameter #f))
+  (define plt-name (make-parameter default-plt-name))
+  (define plt-files-replace (make-parameter #f))
+  (define plt-files-plt-relative? (make-parameter #f))
+  (define plt-files-plt-home-relative? (make-parameter #f))
+  (define plt-setup-collections (make-parameter null))
+  (define plt-include-compiled (make-parameter #f))
+
+  (define use-3m (make-parameter #f))
+
+  (define (extract-suffix appender)
+    (bytes->string/latin-1
+     (subbytes
+      (path->bytes (appender (bytes->path #"x")))
+      1)))
+
+
+  ;; Returns (values mode files prefixes)
+  ;;  where mode is 'compile, 'link, or 'zo
+  (define (parse-options argv)
+    (parse-command-line
+     "mzc"
+     argv
+     `([help-labels
+	"-------------------------------- mode flags ---------------------------------"]
+       [once-any
+	[("-e" "--extension")
+	 ,(lambda (f) 'compile)
+	 (,(format "Output ~a file(s) from Scheme source(s) (default)" (extract-suffix append-extension-suffix)))]
+	[("-c" "--c-source")
+	 ,(lambda (f) 'compile-c)
+	 (,(format "Output ~a file(s) from Scheme source(s)" (extract-suffix append-c-suffix)))]
+	[("-o" "--object")
+	 ,(lambda (f) 'compile-o)
+	 (,(format "Output ~a/~a from Scheme source(s) for a multi-file extension" 
+		   (extract-suffix append-object-suffix)
+		   (extract-suffix append-constant-pool-suffix)))]
+	[("-l" "--link-extension")
+	 ,(lambda (f) 'link)
+	 (,(format "Link multiple ~a and ~a files into a ~a file"
+		   (extract-suffix append-object-suffix)
+		   (extract-suffix append-constant-pool-suffix)
+		   (extract-suffix append-extension-suffix)))]
+	[("-g" "--link-glue")
+	 ,(lambda (f) 'link-glue)
+	 (,(format "Create the ~a glue for --link-extension, but do not link"
+		   (extract-suffix append-object-suffix)))]
+	[("-z" "--zo")
+	 ,(lambda (f) 'zo)
+	 (,(format "Output ~a file(s) from Scheme source(s)" (extract-suffix append-zo-suffix)))]
+	[("-k" "--make")
+	 ,(lambda (f) 'make-zo)
+	 ("Like --zo, but uses .dep, recurs for imports, implies --auto-dir")]
+	[("--collection-extension")
+	 ,(lambda (f) 'collection-extension)
+	 ("Compile specified collection to extension")]
+	[("--collection-zos")
+	 ,(lambda (f) 'collection-zos)
+	 (,(format "Compile specified collection to ~a files" (extract-suffix append-zo-suffix)))]
+	[("--cc")
+	 ,(lambda (f) 'cc)
+	 (,(format "Compile arbitrary file(s) for an extension: ~a -> ~a" 
+		   (extract-suffix append-c-suffix)
+		   (extract-suffix append-object-suffix)))]
+	[("--ld")
+	 ,(lambda (f name) (ld-output name) 'ld)
+	 (,(format "Link arbitrary file(s) to create <extension>: ~a -> ~a" 
+		   (extract-suffix append-object-suffix)
+		   (extract-suffix append-extension-suffix))
+	  "extension")]
+	[("--exe")
+	 ,(lambda (f name) (exe-output name) 'exe)
+	 (,(format "Embed module in MzScheme to create <exe>")
+	  "exe")]
+	[("--gui-exe")
+	 ,(lambda (f name) (exe-output name) 'gui-exe)
+	 (,(format "Embed module in MrEd to create <exe>")
+	  "exe")]
+	[("--collection-plt")
+	 ,(lambda (f name) (plt-output name) 'plt-collect)
+	 (,(format "Create .plt <archive> containing collections")
+	  "archive")]
+	[("--plt")
+	 ,(lambda (f name) (plt-output name) 'plt)
+	 (,(format "Create .plt <archive> containing relative files/dirs")
+	  "archive")]]
+       [once-each
+	[("-m" "--module")
+	 ,(lambda (f) (module-mode #t))
+	 ("Skip eval of top-level syntax, etc. for -e/-c/-o/-z")]
+	[("--3m")
+	 ,(lambda (f) (use-3m #t))
+	 ("Compile/link for 3m, with -e/-c/-o/etc.")]
+	[("--embedded")
+	 ,(lambda (f) (compiler:option:compile-for-embedded #t))
+	 ("Compile for embedded run-time engine, with -c/-o/-g")]
+	[("-p" "--prefix") 
+	 ,(lambda (f v) v)
+	 ("Add elaboration-time prefix file for -e/-c/-o/-z" "file")]
+	[("-n" "--name") 
+	 ,(lambda (f name) (compiler:option:setup-prefix name))
+	 ("Use <name> as extra part of public low-level names" "name")]]
+       [once-any
+	[("-d" "--destination") 
+	 ,(lambda (f d)
+	    (unless (directory-exists? d)
+	      (error 'mzc "the destination directory does not exist: ~s" d))
+	    (dest-dir d))
+	 ("Output -e/-c/-o/-l/-g/-z file(s) to <dir>" "dir")]
+	[("--auto-dir")
+	 ,(lambda (f)
+	    (auto-dest-dir #t))
+	 (,(format "Output -z to \"compiled\", -e to ~s"
+		   (path->string
+		    (build-path "compiled" "native" (system-library-subpath)))))]]
+
+       [help-labels
+	"------------------- compiler/linker configuration flags ---------------------"]
+       [once-each
+	[("--tool") 
+	 ,(lambda (f v) 
+	    (let ([v (string->symbol v)])
+	      (use-standard-compiler v)
+	      (use-standard-linker v)))
+	 (,(format "Use pre-defined <tool> as C compiler/linker:~a" 
+		   (apply string-append
+			  (apply append
+				 (map (lambda (t)
+					(list " " (symbol->string t)))
+				      (get-standard-compilers)))))
+	  "tool")]
+	[("--compiler") 
+	 ,(lambda (f v) (current-extension-compiler v))
+	 ("Use <compiler-path> as C compiler" "compiler-path")]]
+       [multi
+	[("++ccf") 
+	 ,(lambda (f v) (current-extension-compiler-flags
+			 (append (current-extension-compiler-flags)
+				 (list v))))
+	 ("Add C compiler flag" "flag")]
+	[("--ccf") 
+	 ,(lambda (f v) (current-extension-compiler-flags
+			 (remove v (current-extension-compiler-flags))))
+	 ("Remove C compiler flag" "flag")]
+	[("--ccf-clear") 
+	 ,(lambda (f) (current-extension-compiler-flags null))
+	 ("Clear C compiler flags")]
+	[("--ccf-show") 
+	 ,(lambda (f) 
+	    (printf "C compiler flags: ~s~n" (expand-for-link-variant
+					      (current-extension-compiler-flags))))
+	 ("Show C compiler flags")]]
+       [once-each
+	[("--linker") 
+	 ,(lambda (f v) (current-extension-linker v))
+	 ("Use <linker-path> as C linker" "linker-path")]]
+       [multi
+	[("++ldf") 
+	 ,(lambda (f v) (current-extension-linker-flags
+			 (append (current-extension-linker-flags)
+				 (list v))))
+	 ("Add C linker flag" "flag")]
+	[("--ldf") 
+	 ,(lambda (f v) (current-extension-linker-flags
+			 (remove v (current-extension-linker-flags))))
+	 ("Remove C linker flag" "flag")]
+	[("--ldf-clear") 
+	 ,(lambda (f) (current-extension-linker-flags null))
+	 ("Clear C linker flags")]
+	[("--ldf-show") 
+	 ,(lambda (f) 
+	    (printf "C linker flags: ~s~n" (expand-for-link-variant
+					    (current-extension-linker-flags))))
+	 ("Show C linker flags")]
+	[("++ldl") 
+	 ,(lambda (f v) (current-standard-link-libraries
+			 (append (current-standard-link-libraries)
+				 (list v))))
+	 ("Add C linker library" "lib")]
+	[("--ldl-show") 
+	 ,(lambda (f) 
+	    (printf "C linker libraries: ~s~n" (expand-for-link-variant
+						(current-standard-link-libraries))))
+	 ("Show C linker libraries")]]
+       [help-labels
+	"--------------------- executable configuration flags ------------------------"]
+       [once-each
+	[("--ico")
+	 ,(lambda (f i) (exe-aux
+			 (cons (cons 'ico i)
+			       (exe-aux))))
+	 ("Windows icon for --[gui-]exe executable" ".ico-file")]
+	[("--icns")
+	 ,(lambda (f i) (exe-aux
+			 (cons (cons 'icns i)
+			       (exe-aux))))
+	 ("Mac OS X icon for --[gui-]exe executable" ".icns-file")]]
+       [multi
+	[("++lib")
+	 ,(lambda (f l c) (exe-embedded-libraries
+			   (append (exe-embedded-libraries)
+				   (list (list l c)))))
+	 ("Embed <lib> from <collect> in --[gui-]exe executable" "lib" "collect")]
+	[("++exf") 
+	 ,(lambda (f v) (exe-embedded-flags
+			 (append (exe-embedded-flags)
+				 (list v))))
+	 ("Add flag to embed in --[gui-]exe executable" "flag")]
+	[("--exf") 
+	 ,(lambda (f v) (exe-embedded-flags
+			 (remove v (exe-embedded-flags))))
+	 ("Remove flag to embed in --[gui-]exe executable" "flag")]
+	[("--exf-clear") 
+	 ,(lambda (f) (exe-embedded-flags null))
+	 ("Clear flags to embed in --[gui-]exe executable")]
+	[("--exf-show") 
+	 ,(lambda (f) 
+	    (printf "Flags to embed: ~s~n" (exe-embedded-flags)))
+	 ("Show flag to embed in --[gui-]exe executable")]]
+       [help-labels
+	"----------------------------- .plt archive flags ----------------------------"]
+       [once-each
+	[("--plt-name")
+	 ,(lambda (f n) (plt-name n))
+	 ("Set the printed <name> describing the archive" "name")]
+	[("--replace")
+	 ,(lambda (f) (plt-files-replace #t))
+	 ("Files in archive replace existing files when unpacked")]
+	[("--at-plt")
+	 ,(lambda (f) (plt-files-plt-relative? #t))
+	 ("Files/dirs in archive are relative to PLT add-ons directory")]
+	[("--all-users")
+	 ,(lambda (f) (plt-files-plt-home-relative? #t))
+	 ("Files/dirs in archive are relative to PLT installation directory")]
+	[("--include-compiled")
+	 ,(lambda (f) (plt-include-compiled #t))
+	 ("Include \"compiled\" subdirectories in the archive")]]
+       [multi
+	[("++setup")
+	 ,(lambda (f c) (plt-setup-collections
+			 (append (plt-setup-collections)
+				 (list c))))
+	 ("Setup <collect> after the archive is unpacked" "collect")]]
+       [help-labels
+	"----------------------- compiler optimization flags -------------------------"]
+
+       [once-each
+	[("--no-prop")
+	 ,(lambda (f) (compiler:option:propagate-constants #f))
+	 ("Don't propagate constants")]
+	[("--inline")
+	 ,(lambda (f d) (compiler:option:max-inline-size 
+			 (with-handlers ([void
+					  (lambda (x)
+					    (error 'mzc "bad size for --inline: ~a" d))])
+			   (let ([v (string->number d)])
+			     (unless (and (not (negative? v)) (exact? v) (real? v))
+			       (error 'bad))
+			     v))))
+	 ("Set the maximum inlining size" "size")]
+	[("--prim")
+	 ,(lambda (f) (compiler:option:assume-primitives #t))
+	 ("Assume primitive bindings at top-level")]
+	[("--stupid")
+	 ,(lambda (f) (compiler:option:stupid #t))
+	 ("Compile despite obvious non-syntactic errors")]
+	[("--unsafe-disable-interrupts")
+	 ,(lambda (f) (compiler:option:disable-interrupts #t))
+	 ("Ignore threads, breaks, and stack overflow")]
+	[("--unsafe-skip-tests")
+	 ,(lambda (f) (compiler:option:unsafe #t))
+	 ("Skip run-time tests for some primitive operations")]
+	[("--unsafe-fixnum-arithmetic")
+	 ,(lambda (f) (compiler:option:fixnum-arithmetic #t))
+	 ("Assume fixnum arithmetic yields a fixnum")]]
+       [help-labels
+	"-------------------------- miscellaneous flags ------------------------------"]
+       [once-each
+	[("-v") 
+	 ,(lambda (f) (compiler:option:verbose #t))
+	 ("Verbose mode")]
+	[("--save-temps")
+	 ,(lambda (f) (compiler:option:clean-intermediate-files #f))
+	 ("Keep intermediate files")]
+	[("--debug")
+	 ,(lambda (f) (compiler:option:debug #t))
+	 ("Write debugging output to dump.txt")]])
+     (lambda (accum file . files)
+       (let ([mode (let ([l (filter symbol? accum)])
+		     (if (null? l)
+			 'compile
+			 (car l)))])
+	 (values 
+	  mode
+	  (cons file files)
+	  (let ([prefixes (filter string? accum)])
+	    (unless (memq mode '(compile compile-c compile-o zo))
+	      (unless (null? prefixes)
+		(error 'mzc "prefix files are not useful in ~a mode" mode)))
+	    (if (module-mode)
+		(begin
+		  (when (compiler:option:assume-primitives)
+		    (error 'mzc "--prim is not useful with -m or --module"))
+		  (unless (null? prefixes)
+		    (error 'mzc "prefix files not allowed with -m or --module"))
+		  #f)
+		`(begin
+		   ,(if (compiler:option:assume-primitives) '(require mzscheme) '(void))
+		   (require (lib "cffi.ss" "compiler"))
+		   (require-for-syntax mzscheme)
+		   ,@(map (lambda (s) `(load ,s)) prefixes)
+		   (void)))))))
+     (list "file/directory/collection" "file/directory/sub-collection")))
+
+  (printf "MzScheme compiler (mzc) version ~a, Copyright (c) 2005 PLT Scheme, Inc.~n"
+	  (version))
+
+  (define-values (mode source-files prefix)
+    (parse-options (current-command-line-arguments)))
+
+  (when (auto-dest-dir)
+    (unless (memq mode '(zo compile))
+      (error 'mzc "--auto-dir works only with -z, --zo, -e, or --extension (or default mode)")))
+
+  (define (never-embedded action)
+    (when (compiler:option:compile-for-embedded)
+      (error 'mzc "cannot ~a an extension for an embedded MzScheme" action)))
+  
+  (when (use-3m)
+    (link-variant '3m)
+    (compile-variant '3m))
+  
+  (case mode
+    [(compile)
+     (never-embedded "compile")
+     ((compile-extensions prefix) source-files (if (auto-dest-dir)
+						   'auto
+						   (dest-dir)))]
+    [(compile-c)
+     ((compile-extensions-to-c prefix) source-files (dest-dir))]
+    [(compile-o)
+     ((compile-extension-parts prefix) source-files (dest-dir))]
+    [(link)
+     (never-embedded "link")
+     (link-extension-parts source-files (or (dest-dir) (current-directory)))]
+    [(link-glue)
+     (glue-extension-parts source-files (or (dest-dir) (current-directory)))]
+    [(zo)
+     ((compile-zos prefix) source-files (if (auto-dest-dir)
+					    'auto
+					    (dest-dir)))]
+    [(make-zo)
+     (let ([n (make-namespace)]
+	   [mc (dynamic-require '(lib "cm.ss")
+				'managed-compile-zo)]
+	   [cnh (dynamic-require '(lib "cm.ss")
+				 'manager-compile-notify-handler)]
+	   [did-one? #f])
+       (parameterize ([current-namespace n]
+		      [cnh (lambda (p)
+			     (set! did-one? #t)
+			     (printf "  making ~s~n" (path->string p)))])
+	   (map (lambda (file)
+		  (set! did-one? #f)
+		  (let ([name (extract-base-filename/ss file 'mzc)])
+		    (printf "\"~a\":~n" file)
+		    (mc file)
+		    (let ([dest (append-zo-suffix 
+				 (let-values ([(base name dir?) (split-path name)])
+				   (build-path (if (symbol? base) 'same base)
+					       "compiled" name)))])
+		      (printf " [~a \"~a\"]~n"
+			      (if did-one?
+				  "output to"
+				  "already up-to-date at")
+			      dest))))
+		source-files)))]
+    [(collection-extension)
+     (apply compile-collection-extension source-files)]
+    [(collection-zos)
+     (apply compile-collection-zos source-files)]
+    [(cc)
+     (for-each
+      (lambda (file)
+	(let* ([base (extract-base-filename/c file 'mzc)]
+	       [dest (append-object-suffix 
+		      (let-values ([(base name dir?) (split-path base)])
+			(build-path (or (dest-dir) 'same) name)))])
+	  (printf "\"~a\":~n" file)
+	  (compile-extension (not (compiler:option:verbose))
+			     file
+			     dest
+			     null)
+	  (printf " [output to \"~a\"]~n" dest)))
+      source-files)]
+    [(ld)
+     (extract-base-filename/ext (ld-output) 'mzc)
+     ;; (for-each (lambda (file) (extract-base-filename/o file 'mzc)) source-files)
+     (let ([dest (if (dest-dir)
+		     (build-path (dest-dir) (ld-output))
+		     (ld-output))])
+       (printf "~a:~n" (let ([s (apply string-append
+				       (map (lambda (n) (format " \"~a\"" n)) source-files))])
+			 (substring s 1 (string-length s))))
+       (link-extension (not (compiler:option:verbose))
+		       source-files
+		       dest)
+       (printf " [output to \"~a\"]~n" dest))]
+    [(exe gui-exe)
+     (unless (= 1 (length source-files))
+       (error 'mzc "expected a single module source file to embed; given: ~e"
+	      source-files))
+     (let ([dest ((dynamic-require '(lib "embed.ss" "compiler" "private") 
+				   'mzc:embedding-executable-add-suffix)
+		  (exe-output)
+		  (eq? mode 'gui-exe))])
+       ((dynamic-require '(lib "embed.ss" "compiler" "private") 
+			 'mzc:make-embedding-executable)
+	dest
+	(eq? mode 'gui-exe) 
+	(compiler:option:verbose)
+	(cons
+	 `(#%mzc: (file ,(car source-files)))
+	 (map (lambda (l)
+		`(#t (lib ,@l)))
+	      (exe-embedded-libraries)))
+	null
+	`(require ,(string->symbol
+		    (format
+		     "#%mzc:~a"
+		     (let-values ([(base name dir?) (split-path (car source-files))])
+		       (path->bytes (path-replace-suffix name #""))))))
+	(let ([flags (exe-embedded-flags)])
+	  (if (eq? mode 'gui-exe) 
+	      (cons "-Z" flags)
+	      flags))
+	(exe-aux))
+       (printf " [output to \"~a\"]~n" dest))]
+    [(plt)
+     (for-each (lambda (fd)
+		 (unless (relative-path? fd)
+		   (error
+		    'mzc
+		    "file/directory is not relative to the current directory: \"~a\""
+		    fd)))
+	       source-files)
+     (pack (plt-output) (plt-name)
+	   source-files
+	   (map list (plt-setup-collections))
+	   std-filter #t 
+	   (if (plt-files-replace)
+	       'file-replace
+	       'file)
+	   #f
+	   (or (plt-files-plt-relative?)
+	       (plt-files-plt-home-relative?))
+	   ;; Get current version of mzscheme for require:
+	   (let ([i (get-info '("mzscheme"))])
+	     (let ([v (and i (i 'version (lambda () #f)))])
+	       (list (list '("mzscheme") v))))
+	   null
+	   (plt-files-plt-home-relative?))
+     (printf " [output to \"~a\"]~n" (plt-output))]
+    [(plt-collect)
+     (pack-collections
+      (plt-output)
+      (if (eq? default-plt-name (plt-name))
+	  #f
+	  (plt-name))
+      (map (lambda (sf)
+	     (let loop ([sf sf])
+	       (let ([m (regexp-match "^([^/]*)/(.*)$" sf)])
+		 (if m
+		     (cons (cadr m) (loop (caddr m)))
+		     (list sf)))))
+	   source-files)
+      (plt-files-replace)
+      (map list (plt-setup-collections))
+      (if (plt-include-compiled)
+	  (lambda (path)
+	    (or (regexp-match #rx"compiled$" path)
+		(std-filter path)))
+	  std-filter)
+      (plt-files-plt-home-relative?))
+     (printf " [output to \"~a\"]~n" (plt-output))]
+    [else (printf "bad mode: ~a~n" mode)]))
diff --git a/collects/cvs-time-stamp/doc.txt b/collects/cvs-time-stamp/doc.txt
new file mode 100644
index 0000000000..287456e20b
--- /dev/null
+++ b/collects/cvs-time-stamp/doc.txt
@@ -0,0 +1,6 @@
+This collection is used only for the repository.  It is not included
+in normal releases.  (It's existence indicates a checked out tree.)
+
+The stamp.ss module provides one definition: `stamp' that is bound to
+a string representing the current day.  The time-stamp.ss file is a
+tool, used by drscheme to set the version based on the time stamp.
diff --git a/collects/cvs-time-stamp/info.ss b/collects/cvs-time-stamp/info.ss
new file mode 100644
index 0000000000..2ed09ccb82
--- /dev/null
+++ b/collects/cvs-time-stamp/info.ss
@@ -0,0 +1,5 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Repository Time Stamp")
+  (define doc.txt "doc.txt")
+  (define tools (list "time-stamp.ss"))
+  (define tool-names (list "Repository Time Stamp")))
diff --git a/collects/cvs-time-stamp/stamp.ss b/collects/cvs-time-stamp/stamp.ss
new file mode 100644
index 0000000000..9402952707
--- /dev/null
+++ b/collects/cvs-time-stamp/stamp.ss
@@ -0,0 +1 @@
+(module stamp mzscheme (provide stamp) (define stamp "24may2005"))
diff --git a/collects/cvs-time-stamp/time-stamp.ss b/collects/cvs-time-stamp/time-stamp.ss
new file mode 100644
index 0000000000..7f1b1c75de
--- /dev/null
+++ b/collects/cvs-time-stamp/time-stamp.ss
@@ -0,0 +1,18 @@
+
+(module time-stamp mzscheme
+  (require (lib "tool.ss" "drscheme")
+           (lib "unitsig.ss")
+           (lib "framework.ss" "framework"))
+  
+  (require "stamp.ss")
+  
+  (provide tool@)
+  
+  (require "stamp.ss")
+  
+  (define tool@
+    (unit/sig drscheme:tool-exports^
+      (import drscheme:tool^)
+      (define (phase1) (void))
+      (define (phase2) (void))
+      (version:add-spec '-cvs stamp))))
\ No newline at end of file
diff --git a/collects/defaults/README b/collects/defaults/README
new file mode 100644
index 0000000000..f28575d035
--- /dev/null
+++ b/collects/defaults/README
@@ -0,0 +1,2 @@
+This directory hold defaults for the DrScheme preferences. Search in
+Help Desk for "site-specific" for more information.
diff --git a/collects/drscheme/acks.ss b/collects/drscheme/acks.ss
new file mode 100644
index 0000000000..6759cbaa23
--- /dev/null
+++ b/collects/drscheme/acks.ss
@@ -0,0 +1,61 @@
+(module acks mzscheme
+  (provide get-general-acks
+           get-translating-acks
+           get-authors)
+  
+  (define (get-authors)
+    (string-append
+     "DrScheme was written by "
+     "John Clements, "
+     "Matthias Felleisen, "
+     "Robby Findler, "
+     "Paul Graunke, "
+     "Matthew Flatt, "
+     "Shriram Krishnamurthi, "
+     "and "
+     "Paul Steckler."))
+  
+  (define (get-general-acks)
+    (string-append
+     "Thanks to "
+     "Ian Barland, "
+     "Eli Barzilay, "
+     "Gann Bierner, "
+     "Richard Cobbe, "
+     "Moy Easwaran, "
+     "Kathi Fisler, "
+     "Cormac Flanagan, "
+     "Sebastian Good, "
+     "Kathy Gray, "
+     "Bruce Hauman, "
+     "Mark Krentel, "
+     "Mario Latendresse, "
+     "Scott Owens, "
+     "Jamie Raymond, "
+     "Paul Schlie, "
+     "Dorai Sitaram, "
+     "Mike Sperber, "
+     "Francisco Solsona, "
+     "Neil W. Van Dyke, "
+     "Anton van Straaten, "
+     "Stephanie Weirich, "
+     "Noel Welsh, "
+     "and "
+     "Adam Wick "
+     "for contributions of prototypes, libraries, testing, and criticism of PLT documentation."))
+
+  (define (get-translating-acks)
+    (string-append
+     "Thanks to "
+     "Ian Barland, "
+     "Biep Durieux, "
+     "Tim Hanson, "
+     "Chihiro Kuraya, "
+     "Philippe Meunier, "
+     "Jens Axel Søgaard, "
+     "Francisco Solsona, "
+     "Reini Urban, "
+     "and "
+     "Paolo Zoppetti "
+     "for their help translating DrScheme's GUI to other languages.")))
+  
diff --git a/collects/drscheme/arrow.ss b/collects/drscheme/arrow.ss
new file mode 100644
index 0000000000..2ea699401c
--- /dev/null
+++ b/collects/drscheme/arrow.ss
@@ -0,0 +1,195 @@
+
+(module arrow mzscheme
+  (require (lib "class.ss")
+           (lib "list.ss")
+           (lib "math.ss")
+	   (lib "mred.ss" "mred"))
+  
+  (provide draw-arrow)
+    
+  (define largest 16383)
+  (define smallest -16383)
+  
+  (define arrow-head-angle (/ pi 8))
+  (define cos-arrow-head-angle (cos arrow-head-angle))
+  (define sin-arrow-head-angle (sin arrow-head-angle))
+  
+  (define arrow-head-size 8)
+  (define arrow-head-size-cos-arrow-head-angle (* arrow-head-size cos-arrow-head-angle))
+  (define arrow-head-size-sin-arrow-head-angle (* arrow-head-size sin-arrow-head-angle))
+  
+  (define arrow-root-radius 2.5)
+  (define arrow-root-diameter (* 2 arrow-root-radius))
+  
+  ; If alpha is the angle between the x axis and the Start->End vector:
+  ;
+  ; p2-x = end-x + arrow-head-size * cos(alpha + pi - arrow-head-angle)
+  ;      = end-x - arrow-head-size * cos(alpha - arrow-head-angle)
+  ;      = end-x - arrow-head-size * (cos(alpha) * cos(arrow-head-angle) + sin(alpha) * sin(arrow-head-angle))
+  ;      = end-x - arrow-head-size-cos-arrow-head-angle * cos-alpha - arrow-head-size-sin-arrow-head-angle * sin-alpha
+  ;      = end-x - arrow-head-size-cos-arrow-head-angle-cos-alpha - arrow-head-size-sin-arrow-head-angle-sin-alpha
+  ;
+  ; p2-y = end-y + arrow-head-size * sin(alpha + pi - arrow-head-angle)
+  ;      = end-y - arrow-head-size * sin(alpha - arrow-head-angle)
+  ;      = end-y - arrow-head-size * (sin(alpha) * cos(arrow-head-angle) - cos(alpha) * sin(arrow-head-angle))
+  ;      = end-y - arrow-head-size-cos-arrow-head-angle * sin-alpha + arrow-head-size-sin-arrow-head-angle * cos-alpha
+  ;      = end-y - arrow-head-size-cos-arrow-head-angle-sin-alpha + arrow-head-size-sin-arrow-head-angle-cos-alpha
+  ;
+  ; p3-x = end-x + arrow-head-size * cos(alpha + pi + arrow-head-angle)
+  ;      = end-x - arrow-head-size * cos(alpha + arrow-head-angle)
+  ;      = end-x - arrow-head-size * (cos(alpha) * cos(arrow-head-angle) - sin(alpha) * sin(arrow-head-angle))
+  ;      = end-x - arrow-head-size-cos-arrow-head-angle * cos-alpha + arrow-head-size-sin-arrow-head-angle * sin-alpha
+  ;      = end-x - arrow-head-size-cos-arrow-head-angle-cos-alpha + arrow-head-size-sin-arrow-head-angle-sin-alpha
+  ;
+  ; p3-y = end-y + arrow-head-size * sin(alpha + pi + arrow-head-angle)
+  ;      = end-y - arrow-head-size * sin(alpha + arrow-head-angle)
+  ;      = end-y - arrow-head-size * (sin(alpha) * cos(arrow-head-angle) + cos(alpha) * sin(arrow-head-angle))
+  ;      = end-y - arrow-head-size-cos-arrow-head-angle * sin-alpha - arrow-head-size-sin-arrow-head-angle * cos-alpha
+  ;      = end-y - arrow-head-size-cos-arrow-head-angle-sin-alpha - arrow-head-size-sin-arrow-head-angle-cos-alpha
+  
+  ; dc<%> real real real real real real -> void
+  ; draw one arrow
+  ; The reason of the "-0.5" in the definition of start-x and end-x in the let
+  ; right below is because, well, after numerous experiments done under carefully
+  ; controlled conditions by a team of independent experts, it was thought to
+  ; be The Right Thing for the arrows to be drawn correctly, maybe.
+  (define (draw-arrow dc uncropped-pre-start-x uncropped-pre-start-y uncropped-pre-end-x uncropped-pre-end-y dx dy)
+    (let ([uncropped-start-x (+ uncropped-pre-start-x dx -0.5)]
+          [uncropped-start-y (+ uncropped-pre-start-y dy)]
+          [uncropped-end-x (+ uncropped-pre-end-x dx -0.5)]
+          [uncropped-end-y (+ uncropped-pre-end-y dy)]
+          [old-smoothed (send dc get-smoothing)])
+      (let*-values ([(start-x start-y) (crop-to uncropped-start-x uncropped-start-y uncropped-end-x uncropped-end-y)]
+                    [(end-x end-y) (crop-to uncropped-end-x uncropped-end-y uncropped-start-x uncropped-start-y)])
+        (send dc set-smoothing 'aligned)
+        (send dc draw-line start-x start-y end-x end-y)
+        (when (and (< smallest start-x largest)
+                   (< smallest end-x largest))
+          (send dc draw-ellipse 
+                (- start-x arrow-root-radius) (- start-y arrow-root-radius)
+                arrow-root-diameter arrow-root-diameter))
+        (when (and (< smallest end-x largest)
+                   (< smallest end-y largest))
+          (unless (and (= start-x end-x) (= start-y end-y))
+            (let* ([offset-x (- end-x start-x)]
+                   [offset-y (- end-y start-y)]
+                   [arrow-length (sqrt (+ (* offset-x offset-x) (* offset-y offset-y)))]
+                   [cos-alpha (/ offset-x arrow-length)]
+                   [sin-alpha (/ offset-y arrow-length)]
+                   [arrow-head-size-cos-arrow-head-angle-cos-alpha (* arrow-head-size-cos-arrow-head-angle cos-alpha)]
+                   [arrow-head-size-cos-arrow-head-angle-sin-alpha (* arrow-head-size-cos-arrow-head-angle sin-alpha)]
+                   [arrow-head-size-sin-arrow-head-angle-cos-alpha (* arrow-head-size-sin-arrow-head-angle cos-alpha)]
+                   [arrow-head-size-sin-arrow-head-angle-sin-alpha (* arrow-head-size-sin-arrow-head-angle sin-alpha)]
+                   ; pt1 is the tip of the arrow, pt2 is the first point going clockwise from pt1
+                   [pt1 (make-object point% end-x end-y)]
+                   [pt2 (make-object point%
+                          (- end-x arrow-head-size-cos-arrow-head-angle-cos-alpha arrow-head-size-sin-arrow-head-angle-sin-alpha)
+                          (+ end-y (- arrow-head-size-cos-arrow-head-angle-sin-alpha) arrow-head-size-sin-arrow-head-angle-cos-alpha))]
+                   [pt3 (make-object point%
+                          (+ end-x (- arrow-head-size-cos-arrow-head-angle-cos-alpha) arrow-head-size-sin-arrow-head-angle-sin-alpha)
+                          (- end-y arrow-head-size-cos-arrow-head-angle-sin-alpha arrow-head-size-sin-arrow-head-angle-cos-alpha))])
+              (send dc draw-polygon (list pt1 pt2 pt3)))))
+        (send dc set-smoothing old-smoothed))))
+  
+  ;; crop-to : number number number number -> (values number number)
+  ;; returns x,y if they are in the range defined by largest and smallest
+  ;; otherwise returns the coordinates on the line from x,y to ox,oy
+  ;; that are closest to x,y and are in the range specified by
+  ;; largest and smallest
+  (define (crop-to x y ox oy)
+    (cond
+      [(and (< smallest x largest) (< smallest y largest))
+       (values x y)]
+      [else
+       (let* ([xy-pr (cons x y)]
+              [left-i (find-intersection x y ox oy smallest smallest smallest largest)]
+              [top-i (find-intersection x y ox oy smallest smallest largest smallest)]
+              [right-i (find-intersection x y ox oy largest smallest largest largest)]
+              [bottom-i (find-intersection x y ox oy smallest largest largest largest)]
+              [d-top (and top-i (dist top-i xy-pr))]
+              [d-bottom (and bottom-i (dist bottom-i xy-pr))]
+              [d-left (and left-i (dist left-i xy-pr))]
+              [d-right (and right-i (dist right-i xy-pr))])
+         (cond
+           [(smallest? d-top d-bottom d-left d-right)
+            (values (car top-i) (cdr top-i))]
+           [(smallest? d-bottom d-top d-left d-right)
+            (values (car bottom-i) (cdr bottom-i))]
+           [(smallest? d-left d-top d-bottom d-right)
+            (values (car left-i) (cdr left-i))]
+           [(smallest? d-right d-top d-bottom d-left)
+            (values (car right-i) (cdr right-i))]
+           [else 
+            ;; uh oh... if this case happens, that's bad news...
+            (values x y)]))]))
+  
+  ;; smallest? : (union #f number)^4 -> boolean
+  ;; returns #t if can is less and o1, o2, and o3
+  ;; if can is #f, return #f. If o1, o2, or o3 is #f, assume that can is smaller than them
+  (define (smallest? can o1 o2 o3)
+    (and can
+         (andmap (λ (x) (< can x))
+                 (filter (λ (x) x)
+                         (list o1 o2 o3)))))
+          
+  
+  ;; inside? : (union #f (cons number number)) -> (union #f (cons number number))
+  ;; returns the original pair if the coordinates are between smallest and largest
+  ;; and returns #f if the pair is #f or the coordinates are outside.
+  (define (inside? pr)
+    (and pr
+         (let ([x (car pr)]
+               [y (cdr pr)])
+           (if (and (< smallest x largest)
+                    (< smallest y largest))
+               pr
+               #f))))
+  
+  ;; find-intersection : (number^2)^2 -> (union (cons number number) #f)
+  ;; finds the intersection between the lines specified by
+  ;; (x1,y1) -> (x2,y2) and (x3,y3) -> (x4,y4)
+  (define (find-intersection x1 y1 x2 y2 x3 y3 x4 y4)
+    (cond
+      [(and (= x1 x2) (= x3 x4))
+       #f]
+      [(and (= x1 x2) (not (= x3 x4)))
+       (let* ([m2 (/ (- y3 y4) (- x3 x4))]
+              [b2 (- y3 (* m2 x3))])
+         (cons x1
+               (+ (* m2 x1) b2)))]
+      [(and (not (= x1 x2)) (= x3 x4))
+       (let* ([m1 (/ (- y1 y2) (- x1 x2))]
+              [b1 (- y1 (* m1 x1))])
+         (cons x3
+               (+ (* m1 x3) b1)))]
+      [(and (not (= x1 x2)) (not (= x3 x4)))
+       (let* ([m1 (/ (- y1 y2) (- x1 x2))]
+              [b1 (- y1 (* m1 x1))]
+              [m2 (/ (- y3 y4) (- x3 x4))]
+              [b2 (- y3 (* m2 x3))])
+         (if (= m1 m2)
+             #f
+             (let* ([x (/ (- b1 b2) (- m2 m1))]
+                    [y (+ (* m1 x) b1)])
+               (cons x y))))]))
+  
+  ;; dist : (cons number number) (cons number number) -> number
+  (define (dist p1 p2)
+    (sqrt (+ (sqr (- (car p1) (car p2)))
+             (sqr (- (cdr p1) (cdr p2))))))
+  
+  ;; localled defined test code.... :(
+  ;; use module language to run tests
+  (define (tests)
+    (and (equal? (find-intersection 0 1 0 10 0 2 0 20) #f)
+         (equal? (find-intersection 0 1 0 10 0 0 10 10) (cons 0 0))
+         (equal? (find-intersection 0 0 10 10 0 1 0 10) (cons 0 0))
+         (equal? (find-intersection 0 0 3 3 2 2 4 4) #f)
+         (equal? (find-intersection -3 3 3 -3 -3 -3 3 3) (cons 0 0))
+         (equal? (smallest? 3 1 2 3) #f)
+         (equal? (smallest? 0 1 2 3) #t)
+         (equal? (smallest? 1 0 2 3) #f)
+         (equal? (smallest? 1 0 #f 4) #f)
+         (equal? (smallest? 1 #f #f 4) #t)
+         (equal? (smallest? 1 #f #f #f) #t)
+         (equal? (dist (cons 1 1) (cons 4 5)) 5))))
diff --git a/collects/drscheme/default-code-style.ss b/collects/drscheme/default-code-style.ss
new file mode 100644
index 0000000000..b4ea007e2d
--- /dev/null
+++ b/collects/drscheme/default-code-style.ss
@@ -0,0 +1,27 @@
+(module default-code-style mzscheme
+  (provide color-default-code-styles
+           bw-default-code-styles
+           code-style-color
+           code-style-slant?
+           code-style-bold?
+           code-style-underline?)
+  
+  (define-struct code-style (color slant? bold? underline?))
+  ;; code-style = (make-code-style (union (list number number number) string) bolean boolean)
+  
+  ;; bw-default-code-styles : (listof (list symbol code-style
+  (define bw-default-code-styles
+    (list (list 'lexically-bound-variable (make-code-style "black" #f #f #t))
+          (list 'lexically-bound-syntax (make-code-style "black" #f #f #t))
+          (list 'imported-variable (make-code-style "black" #f #f #t))
+          (list 'imported-syntax (make-code-style "black" #f #f #t))
+          (list 'unbound-variable (make-code-style "black" #t #f #f))
+          (list 'constant (make-code-style '(51 135 39) #f #f #f))))
+  
+  ;; color-default-code-styles : (listof (list symbol code-style))
+  (define color-default-code-styles
+    (list (list 'keyword (make-code-style '(40 25 15) #f #f #f))
+          (list 'unbound-variable (make-code-style "red" #f #f #f))
+          (list 'bound-variable (make-code-style "navy" #f #f #f))
+          (list 'primitive (make-code-style "navy" #f #f #f))
+          (list 'constant (make-code-style '(51 135 39) #f #f #f)))))
diff --git a/collects/drscheme/doc.icns b/collects/drscheme/doc.icns
new file mode 100644
index 0000000000..7d726a4974
Binary files /dev/null and b/collects/drscheme/doc.icns differ
diff --git a/collects/drscheme/drscheme.creator b/collects/drscheme/drscheme.creator
new file mode 100644
index 0000000000..8e31ad43ae
--- /dev/null
+++ b/collects/drscheme/drscheme.creator
@@ -0,0 +1,2 @@
+DrSc
+(This code is registered with Apple.)
diff --git a/collects/drscheme/drscheme.filetypes b/collects/drscheme/drscheme.filetypes
new file mode 100644
index 0000000000..c833614f95
--- /dev/null
+++ b/collects/drscheme/drscheme.filetypes
@@ -0,0 +1,20 @@
+((("CFBundleTypeName"
+   "Scheme Source")
+  ("CFBundleTypeIconFile"
+   "doc")
+  ("CFBundleTypeRole"
+   "Editor")
+  ("CFBundleTypeOSTypes"
+   (array "TEXT" "WXME"))
+  ("CFBundleTypeExtensions"
+   (array "scm" "ss")))
+ (("CFBundleTypeName"
+   "Package")
+  ("CFBundleTypeIconFile"
+   "pltdoc")
+  ("CFBundleTypeRole"
+   "Viewer")
+  ("CFBundleTypeOSTypes"
+   (array "PLT_" "WXME"))
+  ("CFBundleTypeExtensions"
+   (array "plt"))))
diff --git a/collects/drscheme/drscheme.ss b/collects/drscheme/drscheme.ss
new file mode 100644
index 0000000000..71b252cb54
--- /dev/null
+++ b/collects/drscheme/drscheme.ss
@@ -0,0 +1,46 @@
+(module drscheme mzscheme
+  (require "private/key.ss")
+  
+  (define debugging? (getenv "PLTDRDEBUG"))
+  
+  (define install-cm? (and (not debugging?)
+                           (getenv "PLTDRCM")))
+  
+  (define cm-trace? (or (equal? (getenv "PLTDRCM") "trace")
+                        (equal? (getenv "PLTDRDEBUG") "trace")))
+  
+  (when debugging?
+    (printf "PLTDRDEBUG: installing CM to load/create errortrace zos\n")
+    (let-values ([(zo-compile
+                   make-compilation-manager-load/use-compiled-handler
+                   manager-trace-handler)
+                  (parameterize ([current-namespace (make-namespace)])
+                    (values
+                     (dynamic-require '(lib "zo-compile.ss" "errortrace") 'zo-compile)
+                     (dynamic-require '(lib "cm.ss") 'make-compilation-manager-load/use-compiled-handler)
+                     (dynamic-require '(lib "cm.ss") 'manager-trace-handler)))])
+      (current-compile zo-compile)
+      (use-compiled-file-paths (list (build-path "compiled" "errortrace")))
+      (current-load/use-compiled (make-compilation-manager-load/use-compiled-handler))
+      (error-display-handler (dynamic-require '(lib "errortrace-lib.ss" "errortrace")
+                                              'errortrace-error-display-handler))
+      (when cm-trace?
+        (printf "PLTDRDEBUG: enabling CM tracing\n")
+        (manager-trace-handler
+         (λ (x) (display "1: ") (display x) (newline))))))
+  
+  (when install-cm?
+    (printf "PLTDRCM: installing compilation manager\n")
+    (let-values ([(make-compilation-manager-load/use-compiled-handler
+                   manager-trace-handler)
+                  (parameterize ([current-namespace (make-namespace)])
+                    (values
+                     (dynamic-require '(lib "cm.ss") 'make-compilation-manager-load/use-compiled-handler)
+                     (dynamic-require '(lib "cm.ss") 'manager-trace-handler)))])
+      (current-load/use-compiled (make-compilation-manager-load/use-compiled-handler))
+      (when cm-trace?
+        (printf "PLTDRCM: enabling CM tracing\n")
+        (manager-trace-handler
+         (λ (x) (display "1: ") (display x) (newline))))))
+
+  (dynamic-require '(lib "drscheme-normal.ss" "drscheme" "private") #f))
diff --git a/collects/drscheme/info.ss b/collects/drscheme/info.ss
new file mode 100644
index 0000000000..b4bafc9e14
--- /dev/null
+++ b/collects/drscheme/info.ss
@@ -0,0 +1,8 @@
+(module info (lib "infotab.ss" "setup")
+  ;; added a comment, in windows ...
+  (define name "DrScheme")
+  (define tools (list "syncheck.ss"))
+  (define tool-names (list "Check Syntax"))
+  (define mred-launcher-names     (list "DrScheme"))
+  (define mred-launcher-libraries (list "drscheme.ss"))
+  (define mred-launcher-flags     (list (list "-ZmvqL" "drscheme.ss" "drscheme"))))
diff --git a/collects/drscheme/installer.ss b/collects/drscheme/installer.ss
new file mode 100644
index 0000000000..51bb297334
--- /dev/null
+++ b/collects/drscheme/installer.ss
@@ -0,0 +1,21 @@
+(module installer mzscheme
+  (require (lib "file.ss")
+           (lib "etc.ss")
+           (lib "launcher.ss" "launcher"))
+  (provide installer)
+  
+  (define (installer plthome)
+    (do-installation)
+    (set! do-installation void))
+  
+  (define (do-installation)
+    (for-each install-variation (available-mred-variants)))
+  
+  (define (install-variation variant)
+    (parameterize ([current-launcher-variant variant])
+      (make-mred-launcher
+       (list "-ZmvqL" "drscheme.ss" "drscheme")
+       (mred-program-launcher-path "DrScheme")
+       (cons
+        `(exe-name . "DrScheme")
+        (build-aux-from-path (build-path (collection-path "drscheme") "drscheme")))))))
\ No newline at end of file
diff --git a/collects/drscheme/pltdoc.icns b/collects/drscheme/pltdoc.icns
new file mode 100644
index 0000000000..c90a814c94
Binary files /dev/null and b/collects/drscheme/pltdoc.icns differ
diff --git a/collects/drscheme/private/app.ss b/collects/drscheme/private/app.ss
new file mode 100644
index 0000000000..2a56dfaf36
--- /dev/null
+++ b/collects/drscheme/private/app.ss
@@ -0,0 +1,830 @@
+
+(module app mzscheme
+  (require (lib "string-constant.ss" "string-constants")
+           (lib "unitsig.ss")
+	   (lib "class.ss")
+	   (lib "mred.ss" "mred")
+           (lib "external.ss" "browser")
+           "drsig.ss"
+           "../acks.ss"
+           (lib "framework.ss" "framework")
+           (lib "file.ss")
+           (lib "check-gui.ss" "version"))
+  
+  (provide app@)
+  (define app@
+    (unit/sig drscheme:app^
+      (import [drscheme:unit : drscheme:unit^]
+              [drscheme:frame : drscheme:frame^]
+              [drscheme:language-configuration : drscheme:language-configuration/internal^]
+              [help-desk : drscheme:help-desk^]
+              [drscheme:tools : drscheme:tools^])
+
+      (define about-frame%
+        (class (drscheme:frame:basics-mixin (frame:standard-menus-mixin frame:basic%))
+          (init-field main-text)
+          (define/private (edit-menu:do const)
+            (send main-text do-edit-operation const))
+            [define/override file-menu:create-revert? (λ () #f)]
+            [define/override file-menu:create-save? (λ () #f)]
+            [define/override file-menu:create-save-as? (λ () #f)]
+            [define/override file-menu:between-close-and-quit (λ (x) (void))]
+            [define/override edit-menu:between-redo-and-cut (λ (x) (void))]
+            [define/override edit-menu:between-select-all-and-find (λ (x) (void))]
+            [define/override edit-menu:copy-callback (λ (menu evt) (edit-menu:do 'copy))]
+            [define/override edit-menu:select-all-callback (λ (menu evt) (edit-menu:do 'select-all))]
+            [define/override edit-menu:create-find? (λ () #f)]
+          (super-new
+            (label (string-constant about-drscheme-frame-title)))))
+      
+      ;; check-new-version : -> void
+      (define (check-new-version)
+        (let ([this-version (version)]
+              [last-version (preferences:get 'drscheme:last-version)]
+              [last-language (preferences:get 'drscheme:last-language)])
+          (when (or (not last-version)
+                    (not last-language)
+                    (not (equal? last-version this-version))
+                    (not (equal? last-language (this-language))))
+            (preferences:set 'drscheme:last-version this-version)
+            (preferences:set 'drscheme:last-language (this-language))
+            (show-wizard))))
+
+      ;; show-welcome-dialog : -> void
+      (define (show-v200-welcome-dialog)
+        (let ([new-settings (drscheme:language-configuration:language-dialog
+                             #t
+                             (preferences:get
+                              drscheme:language-configuration:settings-preferences-symbol)
+                             #f)])
+          (when new-settings
+            (preferences:set
+             drscheme:language-configuration:settings-preferences-symbol
+             new-settings))))
+      
+      
+      
+      
+;                                           
+;                                           
+;                                           
+;             ;                           ; 
+;                                         ; 
+;                                         ; 
+;  ;   ;   ;  ;   ;;;;;;  ;;;   ; ;;  ;;; ; 
+;  ;   ;   ;  ;       ;  ;   ;  ;;   ;   ;; 
+;   ; ; ; ;   ;      ;       ;  ;    ;    ; 
+;   ; ; ; ;   ;     ;     ;;;;  ;    ;    ; 
+;   ; ; ; ;   ;    ;     ;   ;  ;    ;    ; 
+;    ;   ;    ;   ;      ;   ;  ;    ;   ;; 
+;    ;   ;    ;   ;;;;;;  ;;;;; ;     ;;; ; 
+;                                           
+;                                           
+;                                           
+
+      
+      (define (show-wizard)
+        (define wizard-image-bitmap
+          (make-object bitmap% (build-path (collection-path "icons") "wizard-image.jpg")))
+        
+        (define bkg-color (make-object color% 0 0 0))
+        (define stupid-internal-define-syntax1
+          (let ([bdc (make-object bitmap-dc% wizard-image-bitmap)])
+            (send bdc get-pixel 0 0 bkg-color)
+            (send bdc set-bitmap #f)))
+        
+        (define bkg-brush (send the-brush-list find-or-create-brush bkg-color 'solid))
+        (define bkg-pen (send the-pen-list find-or-create-pen bkg-color 1 'solid))
+      
+        (define wizard-image-canvas%
+          (class canvas%
+            (inherit get-dc get-client-size)
+            (define/override (on-paint)
+              (let ([dc (get-dc)])
+                (let-values ([(w h) (get-client-size)])
+                  (send dc set-pen bkg-pen)
+                  (send dc set-brush bkg-brush)
+                  (send dc draw-rectangle 0 0 w h)
+                  (send dc draw-bitmap
+                        wizard-image-bitmap
+                        0
+                        (- h (send wizard-image-bitmap get-height))))))
+            
+            (super-new)
+            (inherit stretchable-width min-width min-height)
+            (stretchable-width #f)
+            (min-width (send wizard-image-bitmap get-width))
+            (min-height (send wizard-image-bitmap get-height))))  
+        
+        (define dlg (instantiate dialog% ()
+                      (label (string-constant welcome-to-drscheme))))
+        (define hp (make-object horizontal-panel% dlg))
+        (define c (make-object wizard-image-canvas% hp))
+        (define vp (make-object vertical-panel% hp))
+        (define sp (make-object panel:single% vp))
+        (define bp (instantiate horizontal-panel% ()
+                     (parent vp)
+                     (stretchable-height #f)
+                     (alignment '(right center))))
+        
+        
+        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+        ;;                                                        ;;
+        ;;                    State Machine                       ;;
+        ;;                                                        ;;
+        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+        
+        
+        ;; type state = (union 'natural-language 'check-updates 'programming-language)
+        ;; state : state
+        (define state 'natural-language)
+        
+        ;; set-state : state -> void
+        ;; moves the state to `new-state'
+        (define (set-state new-state)
+          (set! state new-state)
+          (cond
+            [(first-state?) (send back-button enable #f)]
+            [else (send back-button enable #t)])
+          (cond
+            [(last-state?) (send next-button set-label
+				 (string-constant wizard-finish))]
+            [else (send next-button set-label (string-constant wizard-next))])
+          (case state
+            [(natural-language) (send sp active-child natural-language-state-panel)]
+            [(check-updates) (send sp active-child check-updates-state-panel)]
+            [(programming-language) (send sp active-child programming-language-state-panel)]))
+        
+        ;; next-state : -> void
+        (define (next-state)
+          (case state
+            [(natural-language)
+             (when (okay-to-leave-nl-state?)
+               (set-state 'check-updates))]
+            [(check-updates)
+             (set-state 'programming-language)]
+            [(programming-language)
+             (cond
+               [(get-selected-language)
+                (send dlg show #f)]
+               [else
+                (message-box (string-constant drscheme)
+                             (string-constant please-select-a-language))])]))
+        
+        ;; prev-state : -> void
+        ;; pre: state != 'natural-language
+        (define (prev-state)
+          (case state
+            [(programming-language) (set-state 'check-updates)]
+            [(check-updates) (set-state 'natural-language)]
+            [else (error 'next-state "no next state from: ~s" state)]))
+        
+        ;; first-state?, last-state? : -> boolean
+        (define (first-state?) (eq? state 'natural-language))
+        (define (last-state?) (eq? state 'programming-language))
+        
+        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+        ;;                                                        ;;
+        ;;                 State 1 GUI                            ;;
+        ;;                                                        ;;
+        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+        
+        
+        (define natural-language-state-panel (make-object vertical-panel% sp))
+        
+        (define nl-space-above (make-object horizontal-panel% natural-language-state-panel))
+        
+        (define nl-welcome-panel (instantiate horizontal-panel% ()
+                                   (parent natural-language-state-panel)
+                                   (stretchable-height #f)
+                                   (alignment '(center center))))
+        
+        (define nl-welcome-msg (instantiate message%  ()
+                                 (label (string-constant welcome-to-drscheme))
+                                 (parent nl-welcome-panel)
+				 (font (send the-font-list find-or-create-font 24 'default 'normal 'normal #f))))
+        (define nl-lang-msg (instantiate message%  ()
+                                 (label (format (string-constant version/language)
+                                                (version)
+                                                (this-language)))
+                                 (parent natural-language-state-panel)))
+        
+        (define nl-radio-box
+          (instantiate radio-box% ()
+            (label #f)
+            (choices (string-constants interact-with-drscheme-in-language))
+            (parent natural-language-state-panel)
+            (callback (λ (x y) (void)))))
+        
+        (define stupid-internal-define-syntax3
+	  (let loop ([languages (all-languages)]
+                     [n 0])
+            (cond
+              [(null? languages) (void)]
+              [else (let ([language (car languages)])
+		      (if (eq? (this-language) language)
+			  (send nl-radio-box set-selection n)
+                          (loop (cdr languages) (+ n 1))))])))
+
+        (define nl-space-below (make-object horizontal-panel% natural-language-state-panel))
+        
+        ;; okay-to-leave-nl-state? : -> boolean
+        ;; returns #t if next is okay to proceed, #f if not.
+        (define (okay-to-leave-nl-state?)
+          (let loop ([languages (all-languages)]
+                     [n 0])
+            (cond
+              [(null? languages) (error 'wizard "lost language.2")]
+              [else (let ([language (car languages)])
+                      (if (= n (send nl-radio-box get-selection))
+                          (if (eq? (this-language) language)
+                              #t
+                              (begin (switch-language-to dlg language) 
+                                     #f))
+                          (loop (cdr languages) (+ n 1))))])))
+        
+        
+        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+        ;;                                                        ;;
+        ;;                     State 2 GUI                        ;;
+        ;;                                                        ;;
+        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+        
+        (define check-updates-state-panel (instantiate vertical-panel% ()
+                                            (parent sp)
+                                            (alignment '(center center))))
+        (define check-updates-msgs-panel (instantiate vertical-panel% ()
+                                           (parent check-updates-state-panel)
+                                           (stretchable-width #f)
+                                           (stretchable-height #f)
+                                           (alignment '(left center))))
+
+        ;; note that `cu-message' is bound to the last message% object,
+        ;; but it is not used anyway.
+        (define cu-message
+          (let ([add (λ (str)
+                       (instantiate message% ()
+                         (label str)
+                         (parent check-updates-msgs-panel)))])
+            (let loop ([message (format (string-constant vc-wizard-check-note))])
+              (cond [(regexp-match #rx"^(.+?)\n(.+)$" message) =>
+                     (λ (m) (add (cadr m)) (loop (caddr m)))]
+                    [else (add message)]))))
+
+        (define cu-space
+          (instantiate horizontal-panel% ()
+            (parent check-updates-state-panel)
+            (min-height 20)
+            (stretchable-height #f)))
+
+        (define cu-button
+          (instantiate button% ()
+            (label (string-constant vc-wizard-check-button))
+            (parent check-updates-state-panel)
+            (callback (λ (x y) (check-version dlg)))))
+        
+        
+        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+        ;;                                                        ;;
+        ;;                     State 3 GUI                        ;;
+        ;;                                                        ;;
+        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+        
+        (define programming-language-state-panel (instantiate vertical-panel% ()
+                                                   (parent sp)
+                                                   (alignment '(center center))))
+        (define pl-main-panel (instantiate vertical-panel% ()
+                                (parent programming-language-state-panel)
+                                (stretchable-width #t)
+                                (stretchable-height #t)))
+        (define pl-choose-language-message
+          (instantiate message% ()
+            (parent pl-main-panel)
+            (label (string-constant please-select-a-language))))
+        (define language-config-panel (make-object vertical-panel% pl-main-panel))
+        (define language-config-button-panel (instantiate horizontal-panel% ()
+                                               (parent pl-main-panel)
+                                               (stretchable-height #f)))
+                                               
+        (define-values (get-selected-language get-selected-language-settings)
+          (drscheme:language-configuration:fill-language-dialog
+           language-config-panel
+           language-config-button-panel
+           (preferences:get
+            drscheme:language-configuration:settings-preferences-symbol)
+           dlg))
+        
+        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+        ;;                                                        ;;
+        ;;                         GO                             ;;
+        ;;                                                        ;;
+        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+        
+        (define back-button (instantiate button% ()
+                              (label (string-constant wizard-back))
+                              (parent bp)
+                              (callback (λ (x y) (prev-state)))))
+        (define next-button (instantiate button% ()
+                              (label (if (< (string-length (string-constant wizard-next))
+					    (string-length (string-constant wizard-finish)))
+					 (string-constant wizard-finish)
+					 (string-constant wizard-next)))
+                              (parent bp)
+                              (style '(border))
+                              (callback (λ (x y) (next-state)))))
+        (send next-button focus)
+        
+        (set-state 'natural-language)
+        
+        (send dlg center 'both)
+        (send dlg show #t)
+        
+        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+        ;;                                                        ;;
+        ;;              Put in Wizard Choices                     ;;
+        ;;                                                        ;;
+        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+        (preferences:set
+         (drscheme:language-configuration:get-settings-preferences-symbol)
+         (drscheme:language-configuration:make-language-settings
+          (get-selected-language)
+          (get-selected-language-settings))))
+
+      
+;                                                                   
+;                                                                   
+;                                                                   
+;   ;                  ;                                            
+;                                                                   
+;                          ;               ;                        
+;   ;   ; ;;;  ;     ; ;  ;;;;   ;;;      ;;;;   ;;;;   ;    ;  ; ;;
+;   ;   ;;   ;  ;   ;  ;   ;    ;   ;      ;    ;    ;  ;    ;  ;;  
+;   ;   ;    ;  ;   ;  ;   ;    ;   ;      ;    ;    ;  ;    ;  ;   
+;   ;   ;    ;  ;   ;  ;   ;    ;;;;;      ;    ;    ;  ;    ;  ;   
+;   ;   ;    ;   ; ;   ;   ;    ;          ;    ;    ;  ;    ;  ;   
+;   ;   ;    ;   ; ;   ;   ;    ;          ;    ;    ;  ;   ;;  ;   
+;   ;   ;    ;    ;    ;    ;;   ;;;;       ;;   ;;;;    ;;; ;  ;   
+;                                                                   
+;                                                                   
+;                                                                   
+
+      
+      
+      (define (same-widths items)
+        (let ([max-width (apply max (map (λ (x) (send x get-width)) items))])
+          (for-each (λ (x) (send x min-width max-width)) items)))
+      
+      (define (same-heights items)
+        (let ([max-height (apply max (map (λ (x) (send x get-height)) items))])
+          (for-each (λ (x) (send x min-height max-height)) items)))
+      
+      (define wrap-edit% 
+        (class text:hide-caret/selection%
+          (inherit begin-edit-sequence end-edit-sequence
+                   get-max-width find-snip position-location)
+          (define/augment (on-set-size-constraint)
+            (begin-edit-sequence)
+            (let ([snip (find-snip 1 'after-or-none)])
+              (when (is-a? snip editor-snip%)
+                (send (send snip get-editor) begin-edit-sequence)))
+            (inner (void) on-set-size-constraint))
+          (define/augment (after-set-size-constraint)
+            (inner (void) after-set-size-constraint)
+            (let ([width (get-max-width)]
+                  [snip (find-snip 1 'after-or-none)])
+              (when (is-a? snip editor-snip%)
+                (let ([b (box 0)])
+                  (position-location 1 b #f #f #t)
+                  (let ([new-width (- width 4 (unbox b))])
+                    (when (> new-width 0)
+                      (send snip resize new-width
+                            17) ; smallest random number
+                      (send snip set-max-height 'none))))
+                (send (send snip get-editor) end-edit-sequence)))
+            (end-edit-sequence))
+          (super-new)))
+      
+      (define (get-plt-bitmap)
+        (make-object bitmap%
+          (build-path (collection-path "icons")
+                      (if (< (get-display-depth) 8)
+                          "pltbw.gif"
+                          "PLT-206.png"))))
+      
+      (define (make-release-notes-button button-panel)
+        (make-object button% (string-constant release-notes) button-panel
+          (λ (a b)
+            (help-desk:goto-release-notes))))
+      
+      (define tour-frame%
+        (class (drscheme:frame:basics-mixin (frame:standard-menus-mixin frame:basic%))
+          (define/override (edit-menu:create-undo?) #f)
+          (define/override (edit-menu:create-redo?) #f)
+          (define/override (edit-menu:create-cut?) #f)
+          (define/override (edit-menu:create-copy?) #f)
+          (define/override (edit-menu:create-paste?) #f)
+          (define/override (edit-menu:create-clear?) #f)
+          (define/override (edit-menu:create-select-all?) #f)
+          (define/override (edit-menu:between-select-all-and-find x) (void))
+          (define/override (edit-menu:between-find-and-preferences x) (void))
+          (define/override (edit-menu:between-redo-and-cut x) (void))
+          (define/override (file-menu:between-print-and-close x) (void))
+          (super-new)))
+      
+      (define (invite-tour)
+        (let* ([f (make-object tour-frame% (format (string-constant welcome-to-something) 
+                                                   (string-constant drscheme)))]
+               [panel (send f get-area-container)]
+               [top-hp (make-object horizontal-panel% panel)]
+               [bottom-vp (make-object vertical-panel% panel)]
+               [left-vp (make-object vertical-panel% top-hp)]
+               [plt-bitmap (get-plt-bitmap)]
+               [plt-icon (make-object message% (if (send plt-bitmap ok?)
+                                                   plt-bitmap
+                                                   "[plt]")
+                           left-vp)]
+               [outer-button-panel (make-object vertical-panel% top-hp)]
+               [top-button-panel (make-object vertical-panel% outer-button-panel)]
+               [bottom-button-panel (make-object vertical-panel% outer-button-panel)]
+               [tour-button (make-object button% (string-constant take-a-tour) 
+                              top-button-panel
+                              (λ (x y)
+                                (help-desk:goto-tour))
+                              '(border))]
+               [release-notes-button (make-release-notes-button top-button-panel)]
+               [close-button (make-object button% (string-constant close) bottom-button-panel
+                               (λ x
+                                 (send f close)))]
+               [messages-panel (make-object vertical-panel% left-vp)]
+               
+               [this-version (version)]
+               [last-version (preferences:get 'drscheme:last-version)]
+               [last-language (preferences:get 'drscheme:last-language)]
+               [welcome-to-drs-msg (make-object message% (string-constant welcome-to-drscheme) messages-panel)]
+               [this-version-message (make-object message%
+                                       (format (string-constant version/language)
+                                               this-version 
+                                               (this-language))
+                                       messages-panel)]
+               [last-version-message
+                (let ([msg (cond
+                             [(and last-version
+                                   last-language
+                                   (not (equal? this-version last-version))
+                                   (not (equal? (this-language) last-language)))
+                              (format (string-constant parenthetical-last-version/language)
+                                      last-version last-language)]
+                             [(and last-language
+                                   (not (equal? (this-language) last-language)))
+                              (format (string-constant parenthetical-last-language)
+                                      last-language)]
+                             [(and last-version
+                                   (not (equal? this-version last-version)))
+                              (format (string-constant parenthetical-last-version)
+                                      last-version)]
+                             [else #f])])
+                  (and msg (make-object message% msg messages-panel)))])
+          (for-each (λ (native-lang-string language)
+                      (unless (equal? (this-language) language)
+                        (instantiate button% ()
+                          (label native-lang-string)
+                          (parent bottom-vp)
+                          (stretchable-width #t)
+                          (callback (λ (x1 x2) (switch-language-to f language))))))
+                    (string-constants is-this-your-native-language)
+                    (all-languages))
+          (send bottom-vp stretchable-height #f)
+          (send messages-panel stretchable-height #f)
+          (send bottom-button-panel stretchable-height #f)
+          (send top-button-panel set-alignment 'center 'center)
+          (send bottom-button-panel set-alignment 'center 'center)
+          (send messages-panel set-alignment 'center 'center)
+          
+          (send f reflow-container)
+          (same-heights (list bottom-button-panel messages-panel))
+          (same-widths (list tour-button release-notes-button close-button))
+          
+          (send tour-button focus)
+          (send f show #t)))
+      
+
+      
+      
+;                                                              
+;                                                              
+;                                                              
+;          ;                                     ;             
+;          ;                                     ;             
+;          ;                       ;             ;             
+;    ;;;   ; ;;;    ;;;;   ;    ; ;;;;       ;;; ;  ; ;;  ;;;; 
+;   ;   ;  ;;   ;  ;    ;  ;    ;  ;        ;   ;;  ;;   ;     
+;       ;  ;    ;  ;    ;  ;    ;  ;        ;    ;  ;    ;     
+;    ;;;;  ;    ;  ;    ;  ;    ;  ;        ;    ;  ;     ;;;  
+;   ;   ;  ;    ;  ;    ;  ;    ;  ;        ;    ;  ;        ; 
+;   ;   ;  ;;   ;  ;    ;  ;   ;;  ;        ;   ;;  ;        ; 
+;    ;;;;; ; ;;;    ;;;;    ;;; ;   ;;       ;;; ;  ;    ;;;;  
+;                                                              
+;                                                              
+;                                                              
+
+      
+      (define (about-drscheme)
+        (let* ([e (make-object wrap-edit%)]
+               [main-text (make-object wrap-edit%)]
+               [plt-bitmap (get-plt-bitmap)]
+               [plt-icon (if (send plt-bitmap ok?)
+                             (make-object image-snip% plt-bitmap)
+                             (let ([i (make-object string-snip%)]
+                                   [label "[lambda]"])
+                               (send i insert label (string-length label) 0)
+                               i))]
+               [editor-snip (make-object editor-snip% e #f)]
+               [f (make-object about-frame% main-text)]
+               [main-panel (send f get-area-container)]
+               [editor-canvas (make-object editor-canvas% main-panel)]
+               [button-panel (make-object horizontal-panel% main-panel)]
+               [top (make-object style-delta% 'change-alignment 'top)]
+               [d-usual (make-object style-delta% 'change-family 'decorative)]
+               [d-dr (make-object style-delta%)]
+               [d-http (make-object style-delta%)]
+               
+               [insert/clickback
+                (λ (str clickback)
+                  (send e change-style d-http)
+                  (let* ([before (send e get-start-position)]
+                         [_ (send e insert str)]
+                         [after (send e get-start-position)])
+                    (send e set-clickback before after 
+                          (λ (a b c) (clickback))
+                          d-http))
+                  (send e change-style d-usual))]
+               
+               [insert-url/external-browser
+                (λ (str url)
+                  (insert/clickback str (λ () (send-url url))))])
+          
+          (send* d-http 
+            (copy d-usual)
+            (set-delta-foreground "BLUE")
+            (set-delta 'change-underline #t))
+          (send* d-usual 
+            (set-delta-foreground "BLACK")
+            (set-delta 'change-underline #f))
+          
+          (send* d-dr (copy d-usual) (set-delta 'change-bold))
+          (send d-usual set-weight-on 'normal)
+          (send* editor-canvas
+            (set-editor main-text)
+            (stretchable-width #t)
+            (stretchable-height #t))
+          
+          (if (send plt-bitmap ok?)
+              (send* editor-canvas
+                (min-width (floor (+ (* 5/2 (send plt-bitmap get-width)) 50)))
+                (min-height (+ (send plt-bitmap get-height) 50)))
+              (send* editor-canvas
+                (min-width 500)
+                (min-height 400)))
+          
+          (send* e 
+            (change-style d-dr)
+            (insert (format (string-constant welcome-to-drscheme-version/language) 
+                            (version:version)
+                            (this-language)))
+            (change-style d-usual))
+          
+          (send e insert " by ")
+          
+          (insert-url/external-browser "PLT" "http://www.plt-scheme.org/")
+          
+          (send* e
+            (insert ".")
+            (insert #\newline)
+            (insert (get-authors))
+            (insert #\newline)
+            (insert "For licensing information see "))
+          
+          (insert/clickback "our software license" (λ () (help-desk:goto-plt-license)))
+          
+          (send* e
+            (insert ".")
+            (insert #\newline)
+            (insert #\newline)
+            (insert "Based on:")
+            (insert #\newline)
+            (insert "  ")
+            (insert (banner)))
+          
+          (when (or (eq? (system-type) 'macos)
+                    (eq? (system-type) 'macosx))
+            (send* e
+              (insert "  The A List (c) 1997-2001 Kyle Hammond")
+              (insert #\newline)))
+          
+          (let ([tools (drscheme:tools:get-successful-tools)])
+            (unless (null? tools)
+              (send* e
+                (insert #\newline)
+                (insert "Installed tools:")
+                (insert #\newline))
+              (for-each
+               (λ (successful-tool)
+                 (let ([name (or (drscheme:tools:successful-tool-name successful-tool)
+                                 (format "~s" (drscheme:tools:successful-tool-spec successful-tool)))]
+                       [bm (drscheme:tools:successful-tool-bitmap successful-tool)]
+                       [url (drscheme:tools:successful-tool-url successful-tool)])
+                   (send e insert "  ")
+                   (when bm
+                     (send* e
+                       (insert (make-object image-snip% bm))
+                       (insert #\space)))
+                   (cond
+                     [url
+                      (insert-url/external-browser name url)]
+                     [else
+                      (send e insert name)])
+                   (send e insert #\newline)))
+               tools)))
+          
+          (send e insert "\n")
+          (send e insert (get-translating-acks))
+          
+          (let* ([tour-button (make-object button% (string-constant take-a-tour) button-panel
+                                (λ (x y)
+                                  (help-desk:goto-tour)))]
+                 [release-notes-button (make-release-notes-button button-panel)])
+            (same-widths (list tour-button release-notes-button))
+            (send tour-button focus))
+          (send button-panel stretchable-height #f)
+          (send button-panel set-alignment 'center 'center)
+          
+          (send* e
+            (auto-wrap #t)
+            (set-autowrap-bitmap #f))
+          (send* main-text 
+            (set-autowrap-bitmap #f)
+            (auto-wrap #t)
+            (insert plt-icon)
+            (insert editor-snip)
+            (change-style top 0 2)
+            (hide-caret #t))
+          
+          (send f reflow-container)
+          
+          (send* main-text
+            (set-position 1)
+            (scroll-to-position 0)
+            (lock #t))
+          
+          (send* e
+            (set-position 0)
+            (scroll-to-position 0)
+            (lock #t))
+          
+          (send f show #t)
+          f))
+
+      
+
+;                                       
+;                                       
+;                                       
+;                ;   ;   ;              
+;                    ;                  
+;           ;        ;       ;          
+;   ;    ; ;;;;  ;   ;   ;  ;;;; ;     ;
+;   ;    ;  ;    ;   ;   ;   ;    ;   ; 
+;   ;    ;  ;    ;   ;   ;   ;    ;   ; 
+;   ;    ;  ;    ;   ;   ;   ;     ;  ; 
+;   ;    ;  ;    ;   ;   ;   ;     ; ;  
+;   ;   ;;  ;    ;   ;   ;   ;      ;;  
+;    ;;; ;   ;;  ;   ;   ;    ;;    ;   
+;                                   ;   
+;                                   ;   
+;                                  ;    
+
+      
+      ;; switch-language-to : (is-a?/c top-level-window<%>) symbol -> void
+      ;; doesn't return if the language changes
+      (define (switch-language-to parent other-language)
+        (define-values (other-are-you-sure other-cancel other-accept-and-quit)
+          (let loop ([languages (all-languages)]
+                     [are-you-sures (string-constants are-you-sure-you-want-to-switch-languages)]
+                     [cancels (string-constants cancel)]
+                     [accept-and-quits (if (eq? (system-type) 'windows)
+                                           (string-constants accept-and-exit)
+                                           (string-constants accept-and-quit))])
+            (cond
+              [(null? languages) (error 'app.ss ".1")]
+              [(equal? other-language (car languages))
+               (values (car are-you-sures)
+                       (car cancels)
+                       (car accept-and-quits))]
+              [else (loop (cdr languages)
+                          (cdr are-you-sures)
+                          (cdr cancels)
+                          (cdr accept-and-quits))])))
+        (define dialog (make-object dialog% (string-constant drscheme) parent 400))
+        (define (make-section are-you-sure cancel-label quit-label)
+          (define text (make-object text:hide-caret/selection%))
+          (define ec (instantiate editor-canvas% ()
+                       (parent dialog)
+                       (editor text)
+                       (style '(no-hscroll))))
+          (define bp (instantiate horizontal-panel% ()
+                       (parent dialog)
+                       (alignment '(right center))))
+          (define-values (quit cancel)
+            (gui-utils:ok/cancel-buttons
+             bp
+             (λ (x y)
+               (set! cancelled? #f)
+               (send dialog show #f))
+             (λ (x y)
+               (send dialog show #f))
+             quit-label
+             cancel-label))
+          (send ec set-line-count 3)
+          (send text auto-wrap #t)
+          (send text set-autowrap-bitmap #f)
+          (send text insert are-you-sure)
+          (send text set-position 0 0))
+        (define cancelled? #t)
+        
+        (make-section other-are-you-sure
+                      other-cancel
+                      other-accept-and-quit)
+        
+        (make-section (string-constant are-you-sure-you-want-to-switch-languages)
+                      (string-constant cancel)
+                      (if (eq? (system-type) 'windows)
+                          (string-constant accept-and-exit)
+                          (string-constant accept-and-quit)))
+        
+        (send dialog show #t)
+        
+        (unless cancelled?
+          (let ([set-language? #t])
+            (exit:insert-on-callback 
+             (λ ()
+               (when set-language?
+                 (set-language-pref other-language))))
+            (exit:exit)
+            (set! set-language? #f))))
+      
+      (define (add-important-urls-to-help-menu help-menu additional)
+        (let* ([important-urls
+                (instantiate menu% ()
+                  (parent help-menu)
+                  (label (string-constant web-materials)))]
+               [tool-urls-menu
+                (instantiate menu% ()
+                  (parent help-menu)
+                  (label (string-constant tool-web-sites)))]
+               [add
+                (λ (name url . parent)
+                  (instantiate menu-item% ()
+                    (label name)
+                    (parent (if (null? parent) important-urls (car parent)))
+                    (callback
+                     (λ (x y)
+                       (send-url url)))))])
+          (add (string-constant drscheme-homepage) "http://www.drscheme.org/")
+          (add (string-constant plt-homepage) "http://www.plt-scheme.org/")
+          (add (string-constant teachscheme!-homepage) "http://www.teach-scheme.org/")
+          (add (string-constant how-to-design-programs) "http://www.htdp.org/")
+          (add (string-constant how-to-use-scheme) "http://www.htus.org/")
+          
+          (for-each (λ (tool)
+                      (cond ((drscheme:tools:successful-tool-url tool) =>
+                             (λ (url)
+                               (add (drscheme:tools:successful-tool-name tool) url tool-urls-menu)))))
+                    (drscheme:tools:get-successful-tools))
+          
+          (let loop ([additional additional])
+            (cond
+              [(pair? additional)
+               (let ([x (car additional)])
+                 (when (and (pair? x)
+                            (pair? (cdr x))
+                            (null? (cddr x))
+                            (string? (car x))
+                            (string? (cadr x)))
+                   (add (car x) (cadr x))))
+               (loop (cdr additional))]
+              [else (void)]))))
+
+      (define (add-language-items-to-help-menu help-menu)
+        (let ([added-any? #f])
+          (for-each (λ (native-lang-string language)
+                      (unless (equal? (this-language) language)
+                        (unless added-any?
+                          (make-object separator-menu-item% help-menu)
+                          (set! added-any? #t))
+                        (instantiate menu-item% ()
+                          (label native-lang-string)
+                          (parent help-menu)
+                          (callback (λ (x1 x2) (switch-language-to #f language))))))
+                    (string-constants interact-with-drscheme-in-language)
+                    (all-languages)))))))
diff --git a/collects/drscheme/private/bindings-browser.ss b/collects/drscheme/private/bindings-browser.ss
new file mode 100644
index 0000000000..e87c3636db
--- /dev/null
+++ b/collects/drscheme/private/bindings-browser.ss
@@ -0,0 +1,305 @@
+#|
+
+CODE COPIED (with permission ...) from syntax-browser.ss
+desperately seeking abstraction.
+
+Marshalling (and hence the 'read' method of the snipclass omitted for fast prototyping
+                 
+|#
+
+(module bindings-browser mzscheme
+  (require (lib "pretty.ss")
+           (lib "list.ss")
+           (lib "class.ss")
+           (lib "mred.ss" "mred")
+           (lib "match.ss")
+           (lib "string.ss")
+           (lib "marks.ss" "stepper" "private")
+           (lib "contract.ss"))
+  
+  (provide render-bindings/snip)
+
+  (define (render-bindings/snip stx) (make-object bindings-snip% stx))
+  
+  (define bindings-snipclass%
+    (class snip-class%
+      
+      ; not overriding read
+      (super-instantiate ())))
+  
+  (define bindings-snipclass (make-object bindings-snipclass%))
+  (send bindings-snipclass set-version 1)
+  (send bindings-snipclass set-classname "drscheme:bindings-snipclass%")
+  (send (get-the-snip-class-list) add bindings-snipclass)
+  
+  (define bindings-snip%
+    (class editor-snip%
+      (init-field bindings)
+      
+      (unless ((flat-contract-predicate (listof (list/c syntax? any/c))) bindings)
+        (error 'bindings-snip% "expected bindings association list, given ~v" bindings))
+      
+      (define/public (get-bindings) bindings)
+      
+      (define/override (copy) (make-object bindings-snip% bindings))
+      (define/override (write stream)
+        (error 'bindings-snip "'write' not implemented for bindings-snip"))
+      
+      (define output-text (make-object text%))
+      (define output-port (make-text-port output-text))
+      
+      (define/private (make-modern text)
+        (send text change-style
+              (make-object style-delta% 'change-family 'modern)
+              0
+              (send text last-position)))
+      
+      (begin (parameterize ([current-output-port output-port]
+                            [pretty-print-columns 30])
+               (for-each
+                (λ (binding-pair)
+                  (let* ([stx (car binding-pair)]
+                         [value (cadr binding-pair)])
+                    ; this totally destroys the 'output-port' abstraction.  I don't know
+                    ; how to enrich the notion of an output-port to get 'bold'ing to 
+                    ; work otherwise...
+                    (let* ([before (send output-text last-position)])
+                      (pretty-print (syntax-object->datum stx))
+                      (let* ([post-newline (send output-text last-position)])
+                        (send output-text delete post-newline) ; delete the trailing \n. yuck!
+                        (send output-text insert " ")
+                        (send output-text change-style 
+                              (make-object style-delta% 'change-bold)
+                              before (- post-newline 1)))
+                      (pretty-print value))))
+                bindings))
+             (send output-text delete (send output-text last-position))  ; delete final trailing \n
+             (make-modern output-text))
+    
+      (define outer-t (make-object text%))
+      
+      (super-new
+       (editor outer-t)
+       (with-border? #f)
+       (left-margin 3)
+       (top-margin 0)
+       (right-margin 0)
+       (bottom-margin 0)
+       (left-inset 1)
+       (top-inset 0)
+       (right-inset 0)
+       (bottom-inset 0))
+      
+      (define inner-t (make-object text%))
+      (define inner-es (instantiate editor-snip% ()
+                         (editor inner-t)
+                         (with-border? #f)
+                         (left-margin 0)
+                         (top-margin 0)
+                         (right-margin 0)
+                         (bottom-margin 0)
+                         (left-inset 0)
+                         (top-inset 0)
+                         (right-inset 0)
+                         (bottom-inset 0)))
+      
+      (define details-shown? #t)
+      
+      (inherit show-border set-tight-text-fit)
+      (define/private (hide-details)
+        (when details-shown?
+          (send outer-t lock #f)
+          (show-border #f)
+          (set-tight-text-fit #t)
+          (send outer-t release-snip inner-es)
+          (send outer-t delete (send outer-t last-position))
+          (send outer-t lock #t)
+          (set! details-shown? #f)))
+      
+      (define/private (show-details)
+        (unless details-shown?
+          (send outer-t lock #f)
+          (show-border #t)
+          (set-tight-text-fit #f)
+          (send outer-t insert #\newline
+                (send outer-t last-position)
+                (send outer-t last-position))
+          (send outer-t insert inner-es
+                (send outer-t last-position)
+                (send outer-t last-position))
+          (send outer-t lock #t)
+          (set! details-shown? #t)))
+      
+      (send outer-t insert (make-object turn-snip% 
+                             (λ () (hide-details))
+                             (λ () (show-details))))
+      (send outer-t insert (format "bindings\n"))
+      (send outer-t insert inner-es)
+      (make-modern outer-t)
+      
+      (send inner-t insert (instantiate editor-snip% ()
+                             (editor output-text)
+                             (with-border? #f)
+                             (left-margin 0)
+                             (top-margin 0)
+                             (right-margin 0)
+                             (bottom-margin 0)
+                             (left-inset 0)
+                             (top-inset 0)
+                             (right-inset 0)
+                             (bottom-inset 0)))
+      (send inner-t change-style (make-object style-delta% 'change-alignment 'top) 0 2)
+
+      (send output-text hide-caret #t)
+      (send inner-t hide-caret #t)
+      (send outer-t hide-caret #t)
+      (send output-text lock #t)
+      (send inner-t lock #t)
+      (send outer-t lock #t)
+      
+      (hide-details)
+      
+      (inherit set-snipclass)
+      (set-snipclass bindings-snipclass)))
+  
+  (define black-style-delta (make-object style-delta% 'change-normal-color))
+  (define green-style-delta (make-object style-delta%))
+  (send green-style-delta set-delta-foreground "forest green")
+
+  (define turn-snip%
+    (class snip%
+      
+      (init-field on-up on-down)
+      
+      ;; state : (union 'up 'down 'up-click 'down-click))
+      (init-field [state 'up])
+      
+      (define/override (copy)
+        (instantiate turn-snip% ()
+          (on-up on-up)
+          (on-down on-down)
+          (state state)))
+      
+      (define/override (draw dc x y left top right bottom dx dy draw-caret)
+        (let ([bitmap (case state
+                        [(up) up-bitmap]
+                        [(down) down-bitmap]
+                        [(up-click) up-click-bitmap]
+                        [(down-click) down-click-bitmap])])
+          (cond
+            [(send bitmap ok?)
+             (send dc draw-bitmap bitmap x y)]
+            [(send dc draw-rectangle x y 10 10)
+             (send dc drawline x y 10 10)])))
+             
+
+      (define/override (get-extent dc x y w h descent space lspace rspace)
+        (set-box/f! descent 0)
+        (set-box/f! space 0)
+        (set-box/f! lspace 0)
+        (set-box/f! rspace 0)
+        (set-box/f! w arrow-snip-width)
+        (set-box/f! h arrow-snip-height))
+      
+      (define/override (on-event dc x y editorx editory evt)
+        (let ([snip-evt-x (- (send evt get-x) x)]
+              [snip-evt-y (- (send evt get-y) y)])
+          (cond
+            [(send evt button-down? 'left)
+             (set-state (case state
+                          [(up) 'up-click]
+                          [(down) 'down-click]
+                          [else 'down-click]))]
+            [(and (send evt button-up? 'left)
+                  (<= 0 snip-evt-x arrow-snip-width)
+                  (<= 0 snip-evt-y arrow-snip-height))
+             (set-state (case state
+                          [(up up-click) 
+                           (on-down)
+                           'down]
+                          [(down down-click)
+                           (on-up)
+                           'up]
+                          [else 'down]))]
+            [(send evt button-up? 'left)
+             (set-state (case state
+                          [(up up-click) 'up]
+                          [(down down-click) 'down]
+                          [else 'up]))]
+            [(and (send evt get-left-down)
+                  (send evt dragging?)
+                  (<= 0 snip-evt-x arrow-snip-width)
+                  (<= 0 snip-evt-y arrow-snip-height))
+             (set-state (case state
+                          [(up up-click) 'up-click]
+                          [(down down-click) 'down-click]
+                          [else 'up-click]))]
+            [(and (send evt get-left-down)
+                  (send evt dragging?))
+             (set-state (case state
+                          [(up up-click) 'up]
+                          [(down down-click) 'down]
+                          [else 'up-click]))]
+            [else
+             (super on-event dc x y editorx editory evt)])))
+
+      (inherit get-admin)
+      (define/private (set-state new-state)
+        (unless (eq? state new-state)
+          (set! state new-state)
+          (let ([admin (get-admin)])
+            (when admin
+              (send admin needs-update this 0 0 arrow-snip-width arrow-snip-height)))))
+      
+      (define/override (adjust-cursor dc x y editorx editory event) arrow-snip-cursor)
+      
+      (super-instantiate ())
+      
+      (inherit get-flags set-flags)
+      (set-flags (cons 'handles-events (get-flags)))))
+  
+  (define (set-box/f! b v) (when (box? b) (set-box! b v)))
+  
+  (define down-bitmap (make-object bitmap% (build-path (collection-path "icons") "turn-down.png")))
+  (define up-bitmap (make-object bitmap% (build-path (collection-path "icons") "turn-up.png")))
+  (define down-click-bitmap (make-object bitmap% (build-path (collection-path "icons") "turn-down-click.png")))
+  (define up-click-bitmap (make-object bitmap% (build-path (collection-path "icons") "turn-up-click.png")))
+  (define arrow-snip-height
+    (max 10
+         (send up-bitmap get-height)
+         (send down-bitmap get-height)
+         (send up-click-bitmap get-height)
+         (send down-click-bitmap get-height)))
+  (define arrow-snip-width
+    (max 10
+         (send up-bitmap get-width)
+         (send down-bitmap get-width)
+         (send up-click-bitmap get-width)
+         (send down-click-bitmap get-width)))
+  (define arrow-snip-cursor (make-object cursor% 'arrow))
+  
+  ;; make-text-port : text -> port
+  ;; builds a port from a text object.  
+  (define (make-text-port text)
+    (make-output-port #f
+                      always-evt
+                      (λ (s start end flush?) 
+                        (send text insert (substring s start end)
+                              (send text last-position)
+                              (send text last-position))
+                        (- end start))
+                      void)))
+
+; one trivial test case:
+;
+;(require bindings-browser)
+;
+;(let ([es (render-bindings/snip `((,#`a 3) (,#`b 4) (,#`c (1 3 4))))])
+;  (define f (make-object frame% "frame" #f 850 500))
+;  (define mb (make-object menu-bar% f))
+;  (define edit-menu (make-object menu% "Edit" mb))
+;  (define t (make-object text%))
+;  (define ec (make-object editor-canvas% f t))
+;  (append-editor-operation-menu-items edit-menu)
+;  (send t insert es)
+;  (send f show #t))
\ No newline at end of file
diff --git a/collects/drscheme/private/debug.ss b/collects/drscheme/private/debug.ss
new file mode 100644
index 0000000000..5669f94f84
--- /dev/null
+++ b/collects/drscheme/private/debug.ss
@@ -0,0 +1,1867 @@
+#|
+
+profile todo:
+  - use origin fields
+  - sort out various ways of clearing out the profiling information
+
+|#
+
+(module debug mzscheme
+  (require (lib "unitsig.ss")
+           (lib "stacktrace.ss" "errortrace")
+           (lib "class.ss")
+           (lib "list.ss")
+           (lib "etc.ss")
+           (lib "file.ss")
+           "drsig.ss"
+           (lib "framework.ss" "framework")
+           (lib "mred.ss" "mred")
+           (lib "string-constant.ss" "string-constants")
+           (lib "bday.ss" "framework" "private")
+	   "bindings-browser.ss")
+
+  (define orig (current-output-port))
+  
+  (provide debug@)
+  (define debug@
+    (unit/sig drscheme:debug^
+      (import [drscheme:rep : drscheme:rep^]
+              [drscheme:frame : drscheme:frame^]
+              [drscheme:unit : drscheme:unit^]
+              [drscheme:language : drscheme:language^]
+              [drscheme:language-configuration : drscheme:language-configuration/internal^]
+              [drscheme:init : drscheme:init^])
+
+      (define (oprintf . args) (apply fprintf orig args))
+      
+
+                                                        
+;;                             ;                        
+ ;                                                      
+ ;                                                      
+ ;;;;  ;;  ;;   ;;; ;        ;;;     ;;;    ;;;  ; ;;;  
+ ;   ;  ;   ;  ;   ;           ;    ;   ;  ;   ;  ;;  ; 
+ ;   ;  ;   ;  ;   ;           ;    ;      ;   ;  ;   ; 
+ ;   ;  ;   ;  ;   ;           ;    ;      ;   ;  ;   ; 
+ ;   ;  ;   ;  ;   ;           ;    ;   ;  ;   ;  ;   ; 
+; ;;;    ;;; ;  ;;;;         ;;;;;   ;;;    ;;;  ;;;  ;;
+                   ;                                    
+                   ;                                    
+                ;;;                                     
+
+      ;; type debug-source = (union symbol (instanceof editor<%>))
+      
+      ;; original-output-port : output-port
+      ;; for debugging -- be sure to print to here, not the current output port
+      (define original-output-port (current-output-port))
+      
+      ;; cm-key : symbol
+      ;; the key used to put information on the continuation
+      (define cm-key (gensym 'drscheme-debug-continuation-mark-key))
+
+      (define (get-cm-key) cm-key)
+
+      ;; error-delta : (instanceof style-delta%)
+      (define error-delta (make-object style-delta% 'change-style 'slant))
+      (send error-delta set-delta-foreground (make-object color% 255 0 0))
+      
+      ;; error-color : (instanceof color%)
+      (define error-color (make-object color% "PINK"))
+      
+      (define clickable-image-snip%
+        (class image-snip%
+          (init-rest args)
+          (inherit get-flags set-flags get-admin get-extent)
+          
+          (define callback void)
+          (define/public (set-callback cb) (set! callback cb))
+          (define/public (get-callback) callback)
+          
+          (define grabbed? #f)
+          (define clicked? #f)
+          (define mouse-x #f)
+          (define mouse-y #f)
+          
+          (define/override (draw dc x y left top right bottom dx dy draw-caret)
+            (super draw dc x y left top right bottom dx dy draw-caret)
+            (when clicked?
+              (let ([brush (send dc get-brush)]
+                    [pen (send dc get-pen)])
+                (let-values ([(w h) (get-w/h dc)])
+                  (send dc set-brush (send the-brush-list find-or-create-brush "black" 'hilite))
+                  (send dc set-pen (send the-pen-list find-or-create-pen "white" 1 'transparent))
+                  (send dc draw-rectangle x y w h)
+                  (send dc set-pen pen)
+                  (send dc set-brush brush)))))
+
+          (define/override (on-event dc x y editorx editory evt)
+            (cond
+              [(send evt button-down? 'left)
+               (set! grabbed? #t)
+               (set! clicked? #t)
+               (set! mouse-x x)
+               (invalidate dc)]
+              [(send evt leaving?)
+               (set! clicked? #f)
+               (set! mouse-x #f)
+               (set! mouse-y #f)
+               (invalidate dc)]
+              [(send evt button-up? 'left)
+               (when clicked?
+                 (callback))
+               (set! grabbed? #f)
+               (set! clicked? #f)
+               (invalidate dc)]))
+          
+          (define/private (invalidate dc)
+            (let ([admin (get-admin)])
+              (when admin
+                (let-values ([(w h) (get-w/h dc)])
+                  (send admin needs-update this 0 0 w h)))))
+          
+          (define/private (get-w/h dc)
+            (let ([wb (box 0)]
+                  [hb (box 0)])
+              ;; know that the snip is the same size everywhere, 
+              ;; so just use (0,0) for its position
+              (get-extent dc 0 0 wb hb #f #f #f #f)
+              (values (unbox wb)
+                      (unbox hb))))
+          
+          (apply super-make-object args)
+          (set-flags (cons 'handles-events (get-flags)))))
+      
+      ;; make-note% : string -> (union class #f)
+      (define (make-note% filename)
+        (let ([bitmap (make-object bitmap% 
+                        (build-path (collection-path "icons") filename))])
+          (and (send bitmap ok?)
+               (letrec ([note%
+                         (class clickable-image-snip%
+                           (inherit get-callback)
+                           (define/public (get-image-name) filename)
+                           (define/override (copy) 
+                             (let ([n (new note%)])
+                               (send n set-callback (get-callback))
+                               n))
+                           (super-make-object bitmap))])
+                 note%))))
+      
+      (define bug-note% (make-note% "bug09.gif"))
+      (define mf-note% (make-note% "mf.gif"))
+      (define file-note% (make-note% "file.gif"))
+      
+      ;; display-stats : (syntax -> syntax)
+      ;; count the number of syntax expressions & number of with-continuation-marks in an 
+      ;; expanded expression ... except that it counts keywords, too.
+      ;; returns its argument.
+      ;(define (display-stats stx)
+      ;  (let ([exps 0]
+      ;        [wcms 0])
+      ;    (let loop ([stx stx])
+      ;      (kernel-syntax-case stx ()
+      ;        [(#%with-continuation-mark key mark body)
+      ;         (set! wcms (+ wcms 1))
+      ;         (loop #`body)]
+      ;        [(subexps ...)
+      ;         (set! exps (+ exps 1))
+      ;         (for-each loop (syntax->list stx))]
+      ;        [exp
+      ;         (set! exps (+ exps 1))]))
+      ;    (fprintf (current-error-port) "exps: ~v\nwcms: ~v\n" exps wcms))
+      ;  stx)
+      
+      ;; make-debug-eval-handler : (sexp -> value) -> sexp -> value
+      ;; adds debugging information to `sexp' and calls `oe'
+      (define (make-debug-eval-handler oe)
+        (let ([debug-tool-eval-handler
+               (λ (orig-exp)
+                 (if (compiled-expression? (if (syntax? orig-exp)  
+                                               (syntax-e orig-exp)  
+                                               orig-exp))
+                     (oe orig-exp)
+                     (let loop ([exp (if (syntax? orig-exp)
+                                         orig-exp
+                                         (namespace-syntax-introduce
+                                          (datum->syntax-object #f orig-exp)))])
+                       (let ([top-e (expand-syntax-to-top-form exp)]) 
+                         (syntax-case top-e (begin) 
+                           [(begin expr ...)
+                            ;; Found a `begin', so expand/eval each contained 
+                            ;; expression one at a time 
+                            (let i-loop ([exprs (syntax->list #'(expr ...))]
+                                         [last-one (list (void))])
+                              (cond
+                                [(null? exprs) (apply values last-one)]
+                                [else (i-loop (cdr exprs)
+                                              (call-with-values
+                                               (λ () (loop (car exprs)))
+                                               list))]))]
+                           [_else 
+                            ;; Not `begin', so proceed with normal expand and eval 
+                            (let* ([annotated (annotate-top (expand-syntax top-e) #f)])
+                              (oe annotated))])))))])
+	  debug-tool-eval-handler))
+      
+      ;; make-debug-error-display-handler/text  : (-> (union #f (is-a?/c text%)))
+      ;;                                              ((listof (list text% number number)) -> void)
+      ;;                                              (string (union TST exn) -> void)
+      ;;                                             -> string (union TST exn)
+      ;;                                             -> void
+      (define (make-debug-error-display-handler/text get-rep highlight-errors orig-error-display-handler)
+        (define (debug-error-display-handler msg exn)
+          (let ([rep (get-rep)])
+            (cond
+              [rep
+               (show-error-and-highlight 
+                msg 
+                exn
+                (λ (srcs-to-display cms)
+                  (parameterize ([current-eventspace drscheme:init:system-eventspace])
+                    (queue-callback
+                     (λ ()
+                       ;; need to make sure that the user's eventspace is still the same
+                       ;; and still running here?
+                       (highlight-errors rep srcs-to-display cms))))))]
+              [else 
+               (orig-error-display-handler msg exn)])))
+        debug-error-display-handler)
+      
+      (define (show-error-and-highlight msg exn highlight-errors)
+        (let* ([cms (and (exn? exn) 
+                         (continuation-mark-set? (exn-continuation-marks exn))
+                         (continuation-mark-set->list 
+                          (exn-continuation-marks exn)
+                          cm-key))])
+          (when (and cms
+                     (pair? cms))
+            (let ([note% (if (mf-bday?) mf-note% bug-note%)])
+              (when note%
+                (let ([note (new note%)])
+                  (send note set-callback (λ () (show-backtrace-window msg cms)))
+                  (write-special note (current-error-port))
+                  (display #\space (current-error-port))))))
+          
+          (let ([srcs-to-display (find-src-to-display exn cms)])
+            (for-each (λ (src-to-display)
+                        (let ([src (srcloc-source src-to-display)])
+                          (when (and (path? src) file-note%)
+                            (let ([note (new file-note%)])
+                              (send note set-callback 
+                                    (λ () (open-and-highlight-in-file src-to-display)))
+                              (write-special note (current-error-port))
+                              (display #\space (current-error-port))
+                              (display (path->string (find-relative-path (current-directory) src))
+                                       (current-error-port))
+                              (let ([line (srcloc-line src-to-display)]
+                                    [col (srcloc-column src-to-display)])
+                                (when (and (number? line) 
+                                           (number? col))
+                                  (fprintf (current-error-port) ":~a:~a" line col)))
+                              (display ": " (current-error-port))))))
+                      srcs-to-display)
+            
+            (display msg (current-error-port))
+            (when (exn:fail:syntax? exn)
+              (show-syntax-error-context (current-error-port) exn))
+            (newline (current-error-port))
+            
+            ;; need to flush here so that error annotations inserted in next line
+            ;; don't get erased if this output were to happen after the insertion
+            (flush-output (current-error-port))
+            
+            (highlight-errors srcs-to-display
+                              (and cms
+                                   (filter 
+                                    (λ (x)
+                                      (and (pair? x)
+                                           (is-a? (car x) text:basic<%>)
+                                           (pair? (cdr x))
+                                           (number? (cadr x))
+                                           (number? (cddr x))))
+                                    cms))))))
+      
+      (define (show-syntax-error-context port exn)
+        (let ([error-text-style-delta (make-object style-delta%)])
+          (send error-text-style-delta set-delta-foreground (make-object color% 200 0 0))
+          (write-special (make-object string-snip% " in:") (current-error-port))
+          (for-each (λ (expr)
+                      (let ([snp (make-object string-snip%
+                                   (format "~s" (syntax-object->datum expr)))])
+                        (display " " (current-error-port))
+                        (send snp set-style
+                              (send the-style-list find-or-create-style
+                                    (send snp get-style)
+                                    error-text-style-delta))
+                        (write-special snp (current-error-port))))
+                    (exn:fail:syntax-exprs exn))))
+      
+      ;; make-debug-error-display-handler : (string (union TST exn) -> void) -> string (union TST exn) -> void
+      ;; adds in the bug icon, if there are contexts to display
+      (define (make-debug-error-display-handler orig-error-display-handler)
+        (make-debug-error-display-handler/text
+         (λ ()
+           (let ([rep (drscheme:rep:current-rep)])
+             (and (is-a? rep drscheme:rep:text<%>)
+                  (eq? (send rep get-err-port) (current-error-port))
+                  rep)))
+         (λ (rep errs arrows) (send rep highlight-errors errs arrows))
+         orig-error-display-handler))
+
+      ;; find-src-to-display : exn (union #f (listof (list* <src> number number)))
+      ;;                    -> (listof srclocs)
+      ;; finds the source location to display, choosing between
+      ;; the stack trace and the exception record.
+      ;; returns #f if the source isn't a string.
+      (define (find-src-to-display exn cms)
+	(cond
+	  [(exn:srclocs? exn)
+           ((exn:srclocs-accessor exn) exn)]
+          [(pair? cms)
+           (let ([fst (car cms)])
+             (list (make-srcloc (car fst)
+                                #f
+                                #f
+                                (cadr fst)
+                                (cddr fst))))]
+          [else '()]))
+
+      ;; insert/clickback : (instanceof text%) (union string (instanceof snip%)) (-> void)
+      ;; inserts `note' and a space at the end of `rep'
+      ;; also sets a clickback on the inserted `note' (but not the space).
+      (define (insert/clickback rep note clickback)
+	(let ([before (send rep last-position)])
+	  (send rep insert (if (string? note)
+			       note
+			       (send note copy))
+		before before)
+	  (let ([after (send rep last-position)])
+	    (send rep insert #\space after after)
+	    (send rep set-clickback before after
+		  (λ (txt start end)
+		    (clickback))))))
+
+      ;; with-mark : mark-stx syntax (any? -> syntax) -> syntax
+      ;; a member of stacktrace-imports^
+      ;; guarantees that the continuation marks associated with cm-key are
+      ;; members of the debug-source type, after unwrapped with st-mark-source
+      (define (with-mark src-stx expr)
+        (let ([source (cond
+                        [(path? (syntax-source src-stx))
+                         (syntax-source src-stx)]
+                        [(is-a? (syntax-source src-stx) editor<%>)
+                         (syntax-source src-stx)]
+                        [else #f])]
+              [position (or (syntax-position src-stx) 0)]
+              [span (or (syntax-span src-stx) 0)])
+          (if source
+              (with-syntax ([expr expr]
+                            [mark (list* source position span)]
+                            [cm-key cm-key])
+                (syntax
+                 (with-continuation-mark 'cm-key
+                   'mark
+                   expr)))
+              expr)))
+    
+      ;; current-backtrace-window : (union #f (instanceof frame:basic<%>))
+      ;; the currently visible backtrace window, or #f, if none
+      (define current-backtrace-window #f)
+
+      ;; reset-backtrace-window : -> void
+      ;; effect: updates current-backtrace-window
+      ;; closes the current backtrace window and creates a new (unshown) one
+      (define (reset-backtrace-window)
+        (when current-backtrace-window
+          (send current-backtrace-window close)
+          (set! current-backtrace-window #f))
+        
+        (set! current-backtrace-window 
+              (make-object backtrace-frame%
+                (string-constant backtrace-window-title)
+                #f
+                (preferences:get 'drscheme:backtrace-window-width)
+                (preferences:get 'drscheme:backtrace-window-height)
+                (preferences:get 'drscheme:backtrace-window-x)
+                (preferences:get 'drscheme:backtrace-window-y))))
+
+      ;; hide-backtrace-window : -> void
+      (define (hide-backtrace-window)
+        (when current-backtrace-window
+          (send current-backtrace-window close)
+          (set! current-backtrace-window #f)))
+      
+      ;; backtrace-frame% : (extends frame:basic<%>)
+      (define backtrace-frame%
+        (class (drscheme:frame:basics-mixin (frame:standard-menus-mixin frame:basic%))
+          (define/override (on-size x y)
+            (preferences:set 'drscheme:backtrace-window-width x)
+            (preferences:set 'drscheme:backtrace-window-height y)
+            (super on-size x y))
+          (define/override (on-move x y)
+            (preferences:set 'drscheme:backtrace-window-x x)
+            (preferences:set 'drscheme:backtrace-window-y y)
+            (super on-move x y))
+          (define/override (edit-menu:between-find-and-preferences edit-menu) (void))
+          (define/override (edit-menu:between-select-all-and-find edit-menu) (void))
+          (define/override (file-menu:between-save-as-and-print file-menu) (void))
+          (define/augment (on-close) 
+            (set! current-backtrace-window #f)
+            (inner (void) on-close))
+          (super-new)))
+            
+      ;; show-backtrace-window : string
+      ;;                         (listof mark?)
+      ;;                         -> 
+      ;;                         void
+      (define (show-backtrace-window error-text dis)
+        (reset-backtrace-window)
+        (letrec ([text (make-object (text:wide-snip-mixin text:hide-caret/selection%))]
+                 [mf-bday-note (when (mf-bday?)
+                                 (instantiate message% ()
+                                   (label (string-constant happy-birthday-matthias))
+                                   (parent (send current-backtrace-window get-area-container))))]
+                 [ec (make-object canvas:wide-snip% 
+                       (send current-backtrace-window get-area-container)
+                       text)]
+                 [di-vec (list->vector dis)]
+                 [index 0]
+                 [how-many-at-once 15]
+                 [show-next-dis
+                  (λ ()
+                    (let ([start-pos (send text get-start-position)]
+                          [end-pos (send text get-end-position)])
+                      (send text begin-edit-sequence)
+                      (send text set-position (send text last-position))
+                      (let loop ([n index])
+                        (cond
+                          [(and (< n (vector-length di-vec))
+                                (< n (+ index how-many-at-once)))
+                           (show-frame ec text (vector-ref di-vec n))
+                           (loop (+ n 1))]
+                          [else
+                           (set! index n)]))
+                      
+                      ;; add 'more frames' link
+                      (when (< index (vector-length di-vec))
+                        (let ([end-of-current (send text last-position)])
+                          (send text insert #\newline)
+                          (let ([hyper-start (send text last-position)])
+                            (send text insert 
+                                  (let* ([num-left
+                                          (- (vector-length di-vec)
+                                             index)]
+                                         [num-to-show
+                                          (min how-many-at-once
+                                               num-left)])
+                                    (if (= num-left 1)
+                                        (string-constant last-stack-frame)
+                                        (format (if (num-left . <= . num-to-show)
+                                                    (string-constant last-stack-frames)
+                                                    (string-constant next-stack-frames))
+                                                num-to-show))))
+                            (let ([hyper-end (send text last-position)])
+                              (send text change-style (gui-utils:get-clickback-delta)
+                                    hyper-start hyper-end)
+                              (send text set-clickback
+                                    hyper-start hyper-end
+                                    (λ x
+                                      (send text begin-edit-sequence)
+                                      (send text lock #f)
+                                      (send text delete end-of-current (send text last-position))
+                                      (show-next-dis)
+                                      (send text set-position 
+                                            (send text last-position)
+                                            (send text last-position))
+                                      (send text lock #t)
+                                      (send text end-edit-sequence)))
+                              
+                              (send text insert #\newline)
+                              (send text set-paragraph-alignment (send text last-paragraph) 'center)))))
+                      
+                      (send text set-position start-pos end-pos)
+                      (send text end-edit-sequence)))])
+          (send current-backtrace-window set-alignment 'center 'center)
+          (send current-backtrace-window reflow-container)
+          (send text auto-wrap #t)
+          (send text set-autowrap-bitmap #f)
+          (send text insert error-text)
+          (send text insert "\n\n")
+          (send text change-style error-delta 0 (- (send text last-position) 1))
+          (show-next-dis)
+          (send text set-position 0 0)
+          (send text lock #t)
+          (send text hide-caret #t)
+          (send current-backtrace-window show #t)))
+      
+      ;; show-frame : (instanceof editor-canvas%)
+      ;;              (instanceof text%) 
+      ;;              st-mark?
+      ;;              -> 
+      ;;              void 
+      ;; shows one frame of the continuation
+      (define (show-frame editor-canvas text di)
+        (let* ([debug-source (car di)]
+               [start (cadr di)]
+               [span (cddr di)]
+               [fn (get-filename debug-source)]
+               [start-pos (send text last-position)])
+          
+          ;; make hyper link to the file
+          (send text insert (format "~a: ~a-~a" fn start (+ start span)))
+          (let ([end-pos (send text last-position)])
+            (send text insert " ")
+            (send text change-style (gui-utils:get-clickback-delta) start-pos end-pos)
+            (send text set-clickback
+                  start-pos end-pos
+                  (λ x
+                    (open-and-highlight-in-file (make-srcloc debug-source #f #f start span)))))
+          
+          ;; make bindings hier-list
+          (let ([bindings (st-mark-bindings di)])
+            (when (not (null? bindings))
+              (send text insert (render-bindings/snip bindings))))
+          (send text insert #\newline)
+          
+          (insert-context editor-canvas text debug-source start span)
+          (send text insert #\newline)))
+      
+      ;; insert-context : (instanceof editor-canvas%)
+      ;;                  (instanceof text%)
+      ;;                  debug-info
+      ;;                  number
+      ;;                  -> 
+      ;;                  void
+      (define (insert-context editor-canvas text file start span)
+        (let-values ([(from-text close-text)
+                      (cond
+                        [(symbol? file)
+                         ;; can this case happen?
+                         (let ([text (new text:basic%)])
+                           (if (send text load-file (symbol->string file))
+			       (values text 
+				       (λ () (send text on-close)))
+			       (values #f (λ () (void)))))]
+                        [(path? file)
+                         (let ([text (new text:basic%)])
+                           (if (send text load-file file)
+			       (values text 
+				       (λ () (send text on-close)))
+			       (values #f (λ () (void)))))]
+                        [(is-a? file editor<%>)
+                         (values file void)]
+                        [else (error 'insert-context "unknown file spec ~e" file)])])
+	  (when from-text
+	    (let* ([finish (+ start span)]
+		   [context-text (copy/highlight-text from-text start finish)])
+	      (send context-text lock #t)
+	      (send context-text hide-caret #t)
+	      (send text insert "  ")
+	      (let ([snip (make-object editor-snip% context-text)])
+		(send editor-canvas add-wide-snip snip)
+		(send text insert snip))
+	      (send text insert #\newline))
+	    (close-text))))
+
+      ;; copy/highlight-text : text number number -> text
+      ;; copies the range from `start' to `finish', including the entire paragraph at
+      ;; each end and highlights the characters corresponding the original range,
+      ;; in the resulting text
+      (define (copy/highlight-text from-text start finish)
+        (let* ([to-text (new text:standard-style-list%)]
+               [para-start-pos (send from-text paragraph-start-position 
+                                     (send from-text position-paragraph start))]
+               [para-end-pos (send from-text paragraph-end-position
+                                   (send from-text position-paragraph 
+                                         finish))]
+               [from-start (- start para-start-pos)]
+               [from-end (+ from-start (- finish start))])
+          (send from-text split-snip para-start-pos)
+          (send from-text split-snip para-end-pos)
+          (let loop ([snip (send from-text find-snip para-start-pos 'after-or-none)])
+            (when (and snip
+                       (< (send from-text get-snip-position snip) para-end-pos))
+              (send to-text insert (send snip copy))
+              (loop (send snip next))))
+          (send to-text highlight-range (- from-start 1) from-end error-color #f #f 'high)
+          to-text))
+      
+      ;; get-filename : debug-source -> string
+      (define (get-filename file)
+        (cond
+          [(symbol? file) (symbol->string file)]
+          [(path? file) (path->string file)]
+          [(is-a? file editor<%>)
+           (get-filename-from-editor file)]))
+      
+      ;; get-filename-from-editor : (is-a?/c editor<%>) -> string
+      (define (get-filename-from-editor editor)
+        (let* ([untitled (string-constant unknown-debug-frame)]
+               [canvas (send editor get-canvas)]
+               [frame (and canvas (send canvas get-top-level-window))])
+          (if (is-a? frame drscheme:unit:frame%)
+              (let ([filename (send (send frame get-definitions-text) get-filename)])
+                (cond
+                  [(and filename (eq? editor (send frame get-interactions-text)))
+                   (format (string-constant files-interactions) filename)]
+                  [(eq? editor (send frame get-interactions-text))
+                   (string-constant current-interactions)]
+                  [filename filename]
+                  [else (string-constant current-definitions)]))
+              (or (send editor get-filename) 
+                  untitled))))
+
+      ;; open-and-highlight-in-file : srcloc -> void
+      (define (open-and-highlight-in-file srcloc)
+        (let* ([debug-source (srcloc-source srcloc)]
+               [position (srcloc-position srcloc)]
+               [span (srcloc-span srcloc)]
+               [frame (cond
+                        [(path? debug-source) (handler:edit-file debug-source)]
+                        [(is-a? debug-source editor<%>)
+                         (let ([canvas (send debug-source get-canvas)])
+                           (and canvas
+                                (send canvas get-top-level-window)))])]
+               [editor (cond
+                         [(path? debug-source)
+                          (cond
+                            [(and frame (is-a? frame drscheme:unit:frame%))
+                             (send frame get-definitions-text)]
+                            [(and frame (is-a? frame frame:editor<%>))
+                             (send frame get-editor)]
+                            [else #f])]
+                         [(is-a? debug-source editor<%>) debug-source])]
+               [rep (and (is-a? frame drscheme:unit:frame%)
+                         (send frame get-interactions-text))])
+          (when frame
+            (send frame show #t))
+          (when (and rep editor)
+            (cond
+              [(is-a? editor text:basic<%>)
+               (send rep highlight-error editor position (+ position span))]))))
+
+      
+ 
+;                                                                                      
+;                                                                                      
+;                                                                                      
+;                                                                                      
+;                                                                                      
+;   ;                  ;                                                               
+;  ;;;;   ;;;    ;;;  ;;;;       ;;;    ;;;   ;     ;  ;;;   ; ;  ;;;     ;; ;    ;;;  
+;   ;    ;   ;  ;      ;        ;   ;  ;   ;   ;   ;  ;   ;  ;;  ;   ;   ;  ;;   ;   ; 
+;   ;   ;    ;  ;;     ;       ;      ;     ;  ;   ; ;    ;  ;       ;  ;    ;  ;    ; 
+;   ;   ;;;;;;   ;;    ;       ;      ;     ;   ; ;  ;;;;;;  ;    ;;;;  ;    ;  ;;;;;; 
+;   ;   ;          ;   ;       ;      ;     ;   ; ;  ;       ;   ;   ;  ;    ;  ;      
+;   ;    ;         ;   ;        ;   ;  ;   ;     ;    ;      ;   ;   ;   ;  ;;   ;     
+;    ;;   ;;;;  ;;;     ;;       ;;;    ;;;      ;     ;;;;  ;    ;;;;;   ;; ;    ;;;; 
+;                                                                            ;         
+;                                                                       ;    ;         
+;                                                                        ;;;;          
+
+      
+      (define test-coverage-enabled (make-parameter #f))
+
+      (define current-test-coverage-info (make-thread-cell #f))
+
+      (define (initialize-test-coverage-point key expr)
+        (unless (thread-cell-ref current-test-coverage-info)
+          (let ([rep (drscheme:rep:current-rep)])
+            (when rep
+              (let ([ht (make-hash-table)])
+                (thread-cell-set! current-test-coverage-info ht)
+                (send rep set-test-coverage-info ht)))))
+        (let ([ht (thread-cell-ref current-test-coverage-info)])
+          (when ht ;; if rep isn't around, we don't do test coverage...
+                   ;; this can happen when check syntax expands, for example
+            (hash-table-put! ht key (list #f expr)))))
+  
+      (define (test-covered key)
+        (let ([ht (thread-cell-ref current-test-coverage-info)])
+          (when ht ;; as in the `when' test in `initialize-test-coverage-point'
+            (let ([v (hash-table-get ht key)])
+              (set-car! v #t)))))
+      
+      (define test-coverage-interactions-text<%>
+        (interface ()
+          set-test-coverage-info
+          get-test-coverage-info))
+      
+      (define test-coverage-frame<%>
+        (interface ()
+          show-test-coverage-annotations ;; hash-table (union #f style) (union #f style) boolean -> void
+          get-test-coverage-info-visible?
+          ask-about-clearing-test-coverage?))
+      
+      (define test-coverage-interactions-text-mixin
+        (mixin (drscheme:rep:text<%> text:basic<%>) (test-coverage-interactions-text<%>)
+          (inherit get-context)
+          (field [test-coverage-info #f]
+                 [test-coverage-on-style #f]
+                 [test-coverage-off-style #f]
+                 [ask-about-reset? #f])
+          (define/public set-test-coverage-info
+            (opt-lambda (ht [on-style #f] [off-style #f] [ask? #t])
+              (set! test-coverage-info ht)
+              (set! test-coverage-on-style on-style)
+              (set! test-coverage-off-style off-style)
+              (set! ask-about-reset? ask?)))
+          (define/public (get-test-coverage-info) test-coverage-info)
+          
+          (inherit get-top-level-window)
+          (define/augment (after-many-evals)
+            (when test-coverage-info
+              (send (get-context) show-test-coverage-annotations 
+                    test-coverage-info
+                    test-coverage-on-style
+                    test-coverage-off-style
+                    ask-about-reset?))
+            (inner (void) after-many-evals))
+          
+          (super-new)))
+      
+      (define test-coverage-definitions-text-mixin
+        (mixin ((class->interface text%) drscheme:unit:definitions-text<%>) ()
+          (inherit get-canvas get-tab)
+          
+          (define/private (clear-test-coverage?)
+            (if (preferences:get 'drscheme:test-coverage-ask-about-clearing?)
+                (let ([msg-box-result
+                       (message-box/custom
+                        (string-constant drscheme)
+                        (string-constant test-coverage-clear?)
+                        (string-constant yes)
+                        (string-constant no)
+                        (string-constant test-coverage-clear-and-do-not-ask-again)
+                        (send (get-canvas) get-top-level-window)
+                        '(default=1)
+                        2)])
+                  (case msg-box-result
+                    [(1) #t]
+                    [(2) #f]
+                    [(3)
+                     (preferences:set 'drscheme:test-coverage-ask-about-clearing? #f)
+                     #t]))
+                #t))
+          
+          (define/private (clear-test-coverage)
+            (let ([tab (get-tab)])
+              (when (send tab get-test-coverage-info-visible?)
+                (send tab clear-test-coverage-display)
+                (let ([it (send tab get-ints)])
+                  (when (is-a? it test-coverage-interactions-text<%>)
+                    (send it set-test-coverage-info #f))))))
+          
+          (define/private (can-clear-coverage?)
+            (let ([tab (get-tab)])
+              (or (not (send tab get-test-coverage-info-visible?))
+                  (not (send tab ask-about-clearing-test-coverage?))
+                  (clear-test-coverage?))))
+            
+          (define/augment (can-insert? x y)
+            (and (inner #t can-insert? x y)
+                 (can-clear-coverage?)))
+          
+          (define/augment (can-delete? x y)
+            (and (inner #t can-delete? x y)
+                 (can-clear-coverage?)))
+          
+          (define/augment (after-insert x y)
+            (inner (void) after-insert x y)
+            (clear-test-coverage))
+          
+          (define/augment (after-delete x y)
+            (inner (void) after-delete x y)
+            (clear-test-coverage))
+          
+          (super-new)))
+      
+      (define test-covered-style-delta (make-object style-delta%))
+      (send test-covered-style-delta set-delta-foreground "forest green")
+      
+      (define test-not-covered-style-delta (make-object style-delta%))
+      (send test-not-covered-style-delta set-delta-foreground "firebrick")
+      
+      (define erase-test-coverage-style-delta (make-object style-delta% 'change-normal-color))
+      
+      (define test-coverage-tab-mixin
+        (mixin (drscheme:rep:context<%>) (test-coverage-frame<%>)
+          
+          (field [internal-clear-test-coverage-display #f])
+          
+          (define/public (clear-test-coverage-display)
+            (when internal-clear-test-coverage-display
+              (internal-clear-test-coverage-display)
+              (set! internal-clear-test-coverage-display #f)))
+      
+          (field [ask-about-reset? #t])
+          (define/public (ask-about-clearing-test-coverage?) ask-about-reset?)
+          
+          (define/public (get-test-coverage-info-visible?)
+            (not (not internal-clear-test-coverage-display)))
+          
+          (define/public (show-test-coverage-annotations ht on-style off-style ask?)
+            (set! ask-about-reset? ask?)
+            (let* ([edit-sequence-ht (make-hash-table)]
+                   [locked-ht (make-hash-table)]
+                   [actions-ht (make-hash-table 'equal)]
+                   [on/syntaxes (hash-table-map ht (λ (_ pr) pr))]
+
+                   ;; can-annotate : (listof (list boolean syntax))
+                   ;; boolean is #t => code was run
+                   ;;            #f => code was not run
+                   ;; remove those that cannot be annotated
+                   [can-annotate
+                    (filter (λ (pr)
+                              (let ([stx (cadr pr)])
+                                (and (syntax? stx)
+                                     (let ([src (syntax-source stx)]
+                                           [pos (syntax-position stx)]
+                                           [span (syntax-span stx)])
+                                       (and (is-a? src text:basic<%>)
+                                            pos
+                                            span)))))
+                            on/syntaxes)]
+                   
+                   ;; filtered : (listof (list boolean syntax))
+                   ;; remove redundant expressions
+                   [filtered
+                    (let (;; actions-ht : (list src number number) -> (list boolean syntax)
+                          [actions-ht (make-hash-table 'equal)])
+                      (for-each
+                       (λ (pr)
+                         (let* ([stx (cadr pr)]
+                                [on? (car pr)]
+                                [key (list (syntax-source stx)
+                                           (syntax-position stx)
+                                           (syntax-span stx))]
+                                [old (hash-table-get actions-ht key (λ () 'nothing))])
+                           (cond
+                             [(eq? old 'nothing) (hash-table-put! actions-ht key (list on? stx))]
+                             [(car old) ;; recorded as executed
+                              (void)]
+                             [(not (car old)) ;; recorded as unexected
+                              (when on?
+                                (hash-table-put! actions-ht key (list #t stx)))])))
+                       can-annotate)
+                      (hash-table-map actions-ht (λ (k v) v)))])
+              
+              ;; if everything is covered *and* no coloring has been done, do no coloring.
+              (unless (and (andmap car filtered)
+                           (not (get-test-coverage-info-visible?)))
+                (let (;; sorted : (listof (list boolean syntax))
+                      ;; sorting predicate:
+                      ;;  x < y if
+                      ;;    x's span is bigger than y's (ie, do larger expressions first)
+                      ;;    unless x and y are the same source location.
+                      ;;    in that case, color red first and then green
+                      [sorted
+                       (quicksort
+                        filtered
+                        (λ (x y)
+                          (let* ([x-stx (cadr x)]
+                                 [y-stx (cadr y)]
+                                 [x-pos (syntax-position x-stx)]
+                                 [y-pos (syntax-position y-stx)]
+                                 [x-span (syntax-span x-stx)]
+                                 [y-span (syntax-span y-stx)]
+                                 [x-on (car x)]
+                                 [y-on (car y)])
+                            (cond
+                              [(and (= x-pos y-pos)
+                                    (= x-span x-span))
+                               (or y-on
+                                   (not x-on))]
+                              [else (>= x-span y-span)]))))])
+                  
+                  ;; turn on edit-sequences in all editors to be touched by new annotations
+                  ;; also fill in the edit-sequence-ht
+                  (for-each
+                   (λ (pr)
+                     (let ([src (syntax-source (cadr pr))])
+                       (hash-table-get 
+                        edit-sequence-ht
+                        src
+                        (λ ()
+                          (hash-table-put! edit-sequence-ht src #f)
+                          (send src begin-edit-sequence #f)
+                          (when (send src is-locked?)
+                            (hash-table-put! locked-ht src #t)
+                            (send src lock #f))))))
+                   sorted)
+                  
+                  ;; clear out old annotations (and thaw colorers)
+                  (when internal-clear-test-coverage-display
+                    (internal-clear-test-coverage-display)
+                    (set! internal-clear-test-coverage-display #f))
+                  
+                  ;; freeze the colorers (possibly re-freeze them)
+                  (hash-table-for-each
+                   edit-sequence-ht
+                   (λ (src _)
+                     (send src freeze-colorer)))
+                  
+                  ;; set new annotations
+                  (for-each
+                   (λ (pr)
+                     (let ([stx (cadr pr)]
+                           [on? (car pr)])
+                       (when (syntax? stx)
+                         (let* ([src (syntax-source stx)]
+                                [pos (syntax-position stx)]
+                                [span (syntax-span stx)])
+                           (send src change-style
+                                 (if on?
+                                     (or on-style test-covered-style-delta)
+                                     (or off-style test-not-covered-style-delta))
+                                 (- pos 1)
+                                 (+ (- pos 1) span)
+                                 #f)))))
+                   sorted)
+                  
+                  ;; relock editors
+                  (hash-table-for-each 
+                   locked-ht
+                   (λ (txt _) (send txt lock #t)))
+                  
+                  ;; end edit sequences
+                  (hash-table-for-each 
+                   edit-sequence-ht
+                   (λ (txt _) (send txt end-edit-sequence)))
+                  
+                  ;; save thunk to reset these new annotations
+                  (set! internal-clear-test-coverage-display
+                        (λ ()
+                          (hash-table-for-each
+                           edit-sequence-ht
+                           (λ (txt _) 
+                             (send txt begin-edit-sequence #f)))
+                          (hash-table-for-each
+                           edit-sequence-ht
+                           (λ (txt _) 
+                             (let ([locked? (send txt is-locked?)])
+                               (when locked? (send txt lock #f))
+                               (send txt change-style 
+                                     erase-test-coverage-style-delta
+                                     0
+                                     (send txt last-position)
+                                     #f)
+                               (when locked? (send txt lock #t)))))
+                          (hash-table-for-each
+                           edit-sequence-ht
+                           (λ (txt _) 
+                             (let ([locked? (send txt is-locked?)])
+                               (when locked? (send txt lock #f))
+                               (send txt thaw-colorer)
+                               (when locked? (send txt lock #t)))
+                             (send txt end-edit-sequence)))))))))
+
+          (define/augment (clear-annotations)
+            (inner (void) clear-annotations)
+            (clear-test-coverage-display))
+          
+          (super-new)))
+ 
+      
+      
+      
+                                                               
+                        ;;;    ;    ;;;      ;                 
+                       ;              ;                        
+                       ;              ;                        
+; ;;;   ; ;;;   ;;;   ;;;;;  ;;;      ;    ;;;   ; ;;;    ;;; ;
+ ;   ;   ;     ;   ;   ;       ;      ;      ;    ;;  ;  ;   ; 
+ ;   ;   ;     ;   ;   ;       ;      ;      ;    ;   ;  ;   ; 
+ ;   ;   ;     ;   ;   ;       ;      ;      ;    ;   ;  ;   ; 
+ ;   ;   ;     ;   ;   ;       ;      ;      ;    ;   ;  ;   ; 
+ ;;;;   ;;;;    ;;;   ;;;;   ;;;;;  ;;;;;; ;;;;; ;;;  ;;  ;;;; 
+ ;                                                           ; 
+ ;                                                           ; 
+;;;                                                       ;;;  
+
+      
+      (define profile-key (gensym))
+
+      ;; prof-info =
+      ;; (make-prof-info
+      ;;    boolean ;; protect against nested calls
+      ;;    number[number of calls]
+      ;;    number[time spent in all calls]
+      ;;   (union #f symbol) 
+      ;;   expression)
+      (define-struct prof-info (nest num time name expr))
+
+      ;; copy-prof-info : prof-info -> prof-info
+      (define (copy-prof-info prof-info)
+        (make-prof-info (prof-info-nest prof-info)
+                        (prof-info-num prof-info)
+                        (prof-info-time prof-info)
+                        (prof-info-name prof-info)
+                        (prof-info-expr prof-info)))
+
+      ;; any-info? : prof-info -> boolean
+      (define (any-info? prof-info)
+        (or (not (zero? (prof-info-num prof-info)))
+            (not (zero? (prof-info-time prof-info)))))
+     
+      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;; profiling runtime support
+
+      ;; parameter
+      ;; imported into errortrace
+      (define profiling-enabled (make-parameter #f))
+
+      ;; holds a hash-table for the profiling information
+      (define current-profile-info (make-thread-cell #f))
+      
+      
+      ;; initialize-profile-point : sym syntax syntax -> void
+      ;; called during compilation to register this point as
+      ;; a profile point. 
+      ;; =user=
+      ;; imported into errortrace
+      (define (initialize-profile-point key name expr)
+	(unless (thread-cell-ref current-profile-info)
+          (let ([rep (drscheme:rep:current-rep)])
+            (when rep
+              (let ([ht (make-hash-table)])
+                (thread-cell-set! current-profile-info ht)
+                (send (send rep get-context) add-profile-info ht)))))
+        (let ([profile-info (thread-cell-ref current-profile-info)])
+          (hash-table-put! profile-info
+                           key 
+                           (make-prof-info #f 0 0 (and (syntax? name) (syntax-e name)) expr)))
+        (void))
+  
+      ;; register-profile-start : sym -> (union #f number)
+      ;; =user=
+      ;; imported into errortrace
+      (define (register-profile-start key)
+	(let ([info (hash-table-get (thread-cell-ref current-profile-info) key)])
+          (set-prof-info-num! info (+ (prof-info-num info) 1))
+          (if (prof-info-nest info)
+              #f
+              (begin
+                (set-prof-info-nest! info #t)
+                (current-process-milliseconds)))))
+      
+      ;; register-profile-done : sym (union #f number) -> void
+      ;; =user=
+      ;; imported into errortrace
+      (define (register-profile-done key start)
+        (when start
+	  (let ([info (hash-table-get (thread-cell-ref current-profile-info) key)])
+	    (set-prof-info-nest! info #f)
+	    (set-prof-info-time! info
+                                 (+ (- (current-process-milliseconds) start)
+                                    (prof-info-time info)))))
+        (void))
+
+      ;; get-color-value : number number -> (is-a?/c color%)
+      ;; returns the profiling color
+      ;; for `val' if `max-val' is the largest
+      ;; of any profiling amount.
+      (define (get-color-value val max-val)
+        (let* ([color-min (preferences:get 'drscheme:profile:low-color)]
+               [color-max (preferences:get 'drscheme:profile:high-color)]
+               [adjust
+                (case (preferences:get 'drscheme:profile:scale)
+                  [(sqrt) sqrt]
+                  [(square) (λ (x) (* x x))]
+                  [(linear) (λ (x) x)])]
+               [factor (adjust (if (zero? max-val) 0 (/ val max-val)))]
+               [get-rgb-value
+                (λ (sel)
+                  (let ([small (sel color-min)]
+                        [big (sel color-max)])
+                    (inexact->exact (floor (+ (* factor (- big small)) small)))))])
+          (make-object color% 
+            (get-rgb-value (λ (x) (send x red)))
+            (get-rgb-value (λ (x) (send x green)))
+            (get-rgb-value (λ (x) (send x blue))))))
+      
+      ;; extract-maximum : (listof prof-info) -> number
+      ;; gets the maximum value of the currently preferred profiling info.
+      (define (extract-maximum infos)
+        (let ([max-value 0]
+              [sel (if (eq? (preferences:get 'drscheme:profile-how-to-count) 'time)
+                       prof-info-time
+                       prof-info-num)])
+          (for-each
+           (λ (val)
+             (set! max-value (max max-value (sel val))))
+           infos)
+          max-value))
+      
+      ;; extract-total-time : (listof prof-info) -> number
+      (define (extract-total-time infos)
+        (let ([sum 0])
+          (for-each
+           (λ (val) (set! sum (+ sum (prof-info-time val))))
+           infos)
+          sum))
+      
+      ;; profile-definitions-mixin : mixin
+      (define profile-definitions-text-mixin
+        (mixin ((class->interface text%) drscheme:unit:definitions-text<%>) ()
+          (inherit get-canvas get-tab)
+          
+          (define/augment (can-insert? x y)
+            (and (inner #t can-insert? x y)
+                 (can-reset-profile?)))
+          
+          (define/augment (can-delete? x y)
+            (and (inner #t can-delete? x y)
+                 (can-reset-profile?)))
+          
+          (define/augment (on-insert x y)
+            (inner (void) on-insert x y)
+            (do-reset-profile))
+          
+          (define/augment (on-delete x y)
+            (inner (void) on-delete x y)
+            (do-reset-profile))
+          
+          (define/private (can-reset-profile?)
+            (let ([canvas (get-canvas)])
+              (or (not canvas)
+                  (let ([frame (send canvas get-top-level-window)])
+                    (or (not (send frame get-profile-info-visible?))
+                        (eq? (message-box (string-constant drscheme)
+                                          (string-constant profiling-clear?)
+                                          frame
+                                          '(yes-no))
+                             'yes))))))
+
+          (define/private (do-reset-profile)
+            (send (get-tab) reset-profile))
+
+          (super-new)))
+
+      (define profile-interactions-tab<%>
+        (interface ()
+          add-profile-info))
+        
+      (define-local-member-name 
+        
+        ;; tab methods
+        reset-profile  ;; erases profile display & information
+        hide-profile  ;; hides profiling info, but it is still here to be shown again
+        show-profile  ;; shows the profile info, if there is any to show
+        refresh-profile ;; shows current info in profile window
+        get-profile-info-text
+        can-show-profile?
+        get-sort-mode ;; indicates if the results are currently shown sorted by time, or not
+        set-sort-mode ;; updates the sort mode flag (only called by the gui control callback)
+        
+        ;; frame methods
+        hide-profile-gui
+        show-profile-gui
+        
+        ;; frame and tab methods
+        get-profile-info-visible?
+            ; on frame, indicates if the gui stuff shows up currently
+            ; on tab, indicates if the user has asked for the gui to show up.
+        )
+      
+      (define profile-tab-mixin
+        (mixin (drscheme:unit:tab<%>) (profile-interactions-tab<%>)
+          (define profile-info-visible? #f)
+          (define/public (get-profile-info-visible?) profile-info-visible?)
+          
+          (define sort-mode (preferences:get 'drscheme:profile-how-to-count))
+          (define/public (get-sort-mode) sort-mode)
+          (define/public (set-sort-mode mode) (set! sort-mode mode))
+          
+          (inherit get-frame is-current-tab?)
+          ;; profile-info : (listof hashtable[symbol -o> prof-info])
+          (define profile-info '())
+          (define/public (add-profile-info ht) (set! profile-info (cons ht profile-info)))
+
+          (define/public (show-profile)
+            (unless profile-info-visible?
+              (set! profile-info-visible? #t)
+              (send (get-frame) show-profile-gui)))
+          
+          (define/public (hide-profile)
+            (when profile-info-visible?
+              (set! profile-info-visible? #f)
+              (send profile-info-text clear-profile-display)
+              (when (is-current-tab?)
+                (send (get-frame) hide-profile-gui))))
+          
+          (define/public (reset-profile)
+            (hide-profile)
+            (set! profile-info '()))
+          
+          (define/public (refresh-profile) 
+            (send profile-info-text refresh-profile profile-info))
+          
+          ;; can-show-profile? : -> boolean
+          ;; indicates if there is any profiling information to be shown.
+          (define/public (can-show-profile?)
+            (let/ec esc-k
+              (for-each
+               (λ (ht)
+                 (hash-table-for-each
+                  ht
+                  (λ (key v)
+                    (when (any-info? v)
+                      (esc-k #t)))))
+               profile-info)
+              #f))
+          
+          (define profile-info-text (new profile-text% (tab this)))
+          (define/public (get-profile-info-text) profile-info-text)
+          
+          (define/augment (clear-annotations)
+            (inner (void) clear-annotations)
+            (reset-profile))
+          
+          (super-new)))
+      
+      ;; profile-unit-frame-mixin : mixin
+      ;; adds profiling to the unit frame
+      (define profile-unit-frame-mixin
+        (mixin (drscheme:unit:frame<%> drscheme:frame:<%>) ()
+
+          (inherit get-interactions-text get-current-tab)
+          
+          ;; update-shown : -> void
+          ;; updates the state of the profile item's show menu
+          (define/override (update-shown)
+            (super update-shown)
+            (send show-profile-menu-item set-label
+                  (if profile-info-visible?
+                      (string-constant profiling-hide-profile)
+                      (string-constant profiling-show-profile))))
+          
+          ;; add-show-menu-items : menu -> void
+          ;; adds the show profile menu item
+          (define/override (add-show-menu-items show-menu)
+            (super add-show-menu-items show-menu)
+            (set! show-profile-menu-item 
+                  (instantiate menu:can-restore-menu-item% ()
+                    (label (string-constant profiling-hide-profile))
+                    (parent show-menu)
+                    (callback
+                     (λ (x y)
+                       (show-profile-menu-callback))))))
+          
+          (define show-profile-menu-item #f)
+	  (define profile-gui-constructed? #f)
+
+          ;; get-profile-info-visible? : -> boolean
+          ;; returns #t when the profiling information is visible in the frame.
+          (define/public (get-profile-info-visible?) profile-info-visible?)
+          
+          (field [profile-info-outer-panel #f])
+          (define/override (make-root-area-container % parent)
+            (set! profile-info-outer-panel
+                  (super make-root-area-container
+                   vertical-panel%
+                   parent))
+            (make-object % profile-info-outer-panel))
+          
+          (define/private (show-profile-menu-callback)
+            (cond
+              [profile-info-visible?
+               (send (get-current-tab) hide-profile)]
+              [(send (get-current-tab) can-show-profile?)
+               (send (get-current-tab) show-profile)
+               (send (get-current-tab) refresh-profile)]
+              [else
+               (message-box (string-constant drscheme)
+                            (string-constant profiling-no-information-available))]))
+          
+          (define/public (hide-profile-gui)
+            (when profile-gui-constructed?
+              (when profile-info-visible?
+                (send profile-info-outer-panel change-children
+                      (λ (l)
+                        (remq profile-info-panel l)))
+                (set! profile-info-visible? #f)
+                (update-shown))))
+          
+          (define/public (show-profile-gui)
+            (unless profile-info-visible?
+              (construct-profile-gui)
+              (send profile-info-outer-panel change-children
+                    (λ (l)
+                      (append (remq profile-info-panel l)
+                              (list profile-info-panel))))
+              (set! profile-info-visible? #t)
+              (send profile-info-editor-canvas set-editor (send (get-current-tab) get-profile-info-text))
+              (send (get-current-tab) refresh-profile)
+              (update-shown)))
+          
+          (field (profile-info-visible? #f))
+          
+          (define/augment (on-tab-change from-tab to-tab)
+            (inner (void) on-tab-change from-tab to-tab)
+            (cond
+              [(and (not profile-info-visible?)
+                    (send to-tab get-profile-info-visible?))
+               (show-profile-gui)]
+              [(and profile-info-visible?
+                    (not (send to-tab get-profile-info-visible?)))
+               (hide-profile-gui)])
+            (when profile-choice
+              (send profile-choice set-selection
+                    (profile-mode->selection
+                     (send to-tab get-sort-mode))))
+            (when profile-info-editor-canvas
+              (send profile-info-editor-canvas set-editor 
+                    (and (send to-tab can-show-profile?)
+                         (send to-tab get-profile-info-text)))))
+          
+          (super-new)
+          
+	  (define profile-info-panel #f)
+          (define profile-info-editor-canvas #f)
+          (define profile-choice #f)
+          
+	  (inherit begin-container-sequence end-container-sequence)
+	  (define/private (construct-profile-gui)
+	    (unless profile-gui-constructed?
+	      (set! profile-gui-constructed? #t)
+	      (begin-container-sequence)
+	      (let ()
+		(define _2
+		  (set! profile-info-panel (instantiate horizontal-panel% ()
+					     (parent profile-info-outer-panel)
+					     (stretchable-height #f))))
+		(define profile-left-side (instantiate vertical-panel% (profile-info-panel)))
+		(define _3
+                  (set! profile-info-editor-canvas (new canvas:basic% 
+                                                        (parent profile-info-panel)
+                                                        (editor (send (get-current-tab) get-profile-info-text)))))
+		(define profile-message (instantiate message% ()
+					  (label (string-constant profiling))
+					  (parent profile-left-side)))
+		(define _4
+                  (set! profile-choice (instantiate radio-box% ()
+					 (label #f)
+					 (parent profile-left-side)
+					 (callback
+					  (λ (x y)
+                                            (let ([mode (profile-selection->mode (send profile-choice get-selection))])
+                                              (preferences:set 'drscheme:profile-how-to-count mode)
+                                              (send (get-current-tab) set-sort-mode mode)
+                                              (send (get-current-tab) refresh-profile))))
+					 (choices (list (string-constant profiling-time)
+							(string-constant profiling-number))))))
+		(define _1
+		  (send profile-choice set-selection
+			(case (preferences:get 'drscheme:profile-how-to-count)
+			  [(time) 0]
+			  [(count) 1])))
+		(define update-profile-button
+		  (instantiate button% ()
+		    (label (string-constant profiling-update))
+		    (parent profile-left-side)
+		    (callback
+		     (λ (x y)
+		       (send (get-current-tab) refresh-profile)))))
+		(define hide-profile-button 
+		  (instantiate button% ()
+		    (label (string-constant profiling-hide-profile))
+		    (parent profile-left-side)
+		    (callback
+		     (λ (x y)
+		       (send (get-current-tab) hide-profile)))))
+		(send profile-choice set-selection 
+                      (profile-mode->selection (preferences:get 'drscheme:profile-how-to-count)))
+		
+		(send profile-left-side stretchable-width #f)
+		
+		(let ([wid (max (send update-profile-button get-width)
+				(send hide-profile-button get-width)
+				(send profile-choice get-width)
+				(send profile-message get-width))])
+		  (send update-profile-button min-width wid)
+		  (send hide-profile-button min-width wid)
+		  (send profile-choice min-width wid))
+		(send profile-left-side set-alignment 'left 'center)
+		
+		;; hide profiling info initially, but reflow the container
+		;; so that the invisible children get the right size.
+		(send this reflow-container)
+		(send profile-info-outer-panel change-children
+		      (λ (l)
+			(remq profile-info-panel l))))
+	      (end-container-sequence)))))
+      
+      (define (profile-selection->mode sel)
+        (case sel
+          [(0) 'time]
+          [(1) 'count]))
+      
+      (define (profile-mode->selection mode)
+        (case mode
+          [(time) 0]
+          [(count) 1]))
+      
+      ;; profile-text% : extends text:basic%
+      ;; this class keeps track of a single thread's
+      ;; profiling information. these methods are not
+      ;; to be called directly, but only by the frame class, since
+      ;; they do not completely implement the abstraction for the
+      ;; GUI. They only manage the profiling information reported
+      ;; in the bottom window
+      (define profile-text% 
+        (class text:basic%
+          (init-field tab)
+
+          ;; clear-profile-display : -> void
+          ;; clears out the GUI showing the profile results
+          (define/public (clear-profile-display)
+            (begin-edit-sequence)
+            (let ([locked? (is-locked?)])
+              (lock #f)
+              (clear-old-results)
+              (erase)
+              (lock locked?)
+              (end-edit-sequence)))
+          
+          (inherit lock is-locked?
+                   get-canvas hide-caret get-snip-location
+                   begin-edit-sequence end-edit-sequence 
+                   erase insert)
+
+          ;; clear-old-results : -> void
+          ;; removes the profile highlighting
+          (field [clear-old-results void])
+
+          ;; refresh-profile : (listof hashtable[...]) -> void
+          ;; does the work to erase any existing profile info
+          ;; and make new profiling info.
+          (define/public (refresh-profile profile-info)
+            (begin-edit-sequence)
+            (lock #f)
+            (erase)
+            (clear-old-results)
+            (let* (;; must copy them here in case the program is still running
+                   ;; and thus updating them.
+                   [infos '()]
+                   [_ (let loop ([profile-info profile-info])
+                        (cond
+                          [(null? profile-info) (void)]
+                          [else 
+                           (let ([ht (car profile-info)])
+                             (hash-table-for-each
+                              ht
+                              (λ (key val)
+                                (when (any-info? val)
+                                  (set! infos (cons (copy-prof-info val) infos))))))
+                           (loop (cdr profile-info))]))]
+
+                   ;; each editor that gets some highlighting is put
+                   ;; into this table and an edit sequence is begun for it.
+                   ;; after all ranges are updated, the edit sequences are all closed.
+                   [in-edit-sequence (make-hash-table)]
+                   [clear-highlight void]
+                   [max-value (extract-maximum infos)]
+                   [total-time (extract-total-time infos)]
+                   [show-highlight
+                    (λ (info)
+                      (let* ([expr (prof-info-expr info)]
+                             [src (syntax-source expr)]
+                             [pos (syntax-position expr)]
+                             [span (syntax-span expr)])
+                        (when (and src
+                                   (is-a? src text:basic<%>)
+                                   (number? pos)
+                                   (number? span))
+                          (unless (hash-table-get in-edit-sequence src (λ () #f))
+                            (hash-table-put! in-edit-sequence src #t)
+                            (send src begin-edit-sequence))
+                          (let* ([color (get-color-value 
+                                         (if (eq? (preferences:get 'drscheme:profile-how-to-count) 'time)
+                                             (prof-info-time info)
+                                             (prof-info-num info))
+                                         max-value)]
+                                 [clr (send src highlight-range (- pos 1) (+ pos span -1) color)])
+                            (let ([old-thnk clear-highlight])
+                              (set! clear-highlight
+                                    (λ ()
+                                      (clr)
+                                      (old-thnk))))))))]
+                   [smaller-range?
+                    (λ (x y)
+                      (let ([x-span (syntax-span (prof-info-expr x))]
+                            [y-span (syntax-span (prof-info-expr y))])
+                        (if (and x-span y-span)
+                            (< x-span y-span)
+                            #f)))]
+                   
+                   [show-line
+                    (λ (info newline? highlight-line?)
+                      (let* ([expr (prof-info-expr info)]
+                             [expr-src (syntax-source expr)]
+                             [count (prof-info-num info)]
+                             [time (prof-info-time info)]
+                             [name (prof-info-name info)])
+                        (when newline? (send src-loc-editor insert "\n"))
+                        (when highlight-line? (small-blank-line src-loc-editor))
+                        (let ([before (send src-loc-editor last-position)])
+                          (insert-profile-src-loc src-loc-editor expr name)
+                          (let ([after (send src-loc-editor last-position)])
+                            (cond
+                              [(string? expr-src)
+                               (send src-loc-editor change-style (gui-utils:get-clickback-delta) before after)
+                               (let ([after (send src-loc-editor last-position)])
+                                 (send src-loc-editor set-clickback 
+                                       before after 
+                                       (λ (text start end)
+                                         (open-file-and-goto-position expr-src (syntax-position expr)))))]
+                              [(is-a? expr-src editor:basic<%>)
+                               (send src-loc-editor change-style (gui-utils:get-clickback-delta) before after)
+                               (send src-loc-editor set-clickback
+                                     before after
+                                     (λ (text start end)
+                                       (let ([window (send expr-src get-top-level-window)]
+                                             [pos (syntax-position expr)])
+                                         (when window (send window show #t))
+                                         (when pos (send expr-src set-position (- pos 1)))
+                                         (send expr-src set-caret-owner #f 'global))))]
+                              [else (void)])))
+                        
+                        (when newline? (send percentage-editor insert "\n"))
+                        (when highlight-line? (small-blank-line percentage-editor))
+                        (send percentage-editor insert (format-percentage 
+                                                        (if (= total-time 0)
+                                                            1
+                                                            (/ time total-time))))
+                        (send percentage-editor set-paragraph-alignment
+                              (send percentage-editor last-paragraph)
+                              'right)
+                        
+                        (when newline? (send time-editor insert "\n"))
+                        (when highlight-line? (small-blank-line time-editor))
+                        (send time-editor insert (format "~a" time))
+                        (send time-editor set-paragraph-alignment (send time-editor last-paragraph) 'right)
+                        
+                        (when newline? (send count-editor insert "\n")) 
+                        (when highlight-line? (small-blank-line count-editor))
+                        (send count-editor insert (format "~a" count))
+                        (send count-editor set-paragraph-alignment (send count-editor last-paragraph) 'right)))]
+                   
+                   [bigger-value?
+                    (λ (x y)
+                      (let ([sel (if (eq? 'count (preferences:get 'drscheme:profile-how-to-count))
+                                     prof-info-num
+                                     prof-info-time)])
+                        (> (sel x) (sel y))))]
+                   
+                   [cleanup-editor
+                    (λ (ed)
+                      (let* ([ed-admin (send ed get-admin)]
+                             [snip (send ed-admin get-snip)]
+                             [bl (box 0)]
+                             [br (box 0)])
+                        (get-snip-location snip bl #f #f)
+                        (get-snip-location snip br #f #t)
+                        (let ([w (+ (- (unbox br) (unbox bl)) 4)])
+                          (send ed set-max-width w)
+                          (send ed set-min-width w)))
+                      (send ed hide-caret #t)
+                      (send ed lock #t))]
+                   
+                   [top-infos (top 100 (quicksort infos bigger-value?))])
+              (for-each show-highlight top-infos)
+              (initialize-editors)
+              (let loop ([infos top-infos]
+                         [newline? #f]
+                         [highlight-counter 0])
+                (cond
+                  [(null? infos) (void)]
+                  [else 
+                   (show-line (car infos) newline? (and newline? (zero? highlight-counter)))
+                   (loop (cdr infos) #t (modulo (+ highlight-counter 1) 2))]))
+              (cleanup-editor count-editor)
+              (cleanup-editor time-editor)
+              (cleanup-editor percentage-editor)
+              (cleanup-editor src-loc-editor)
+              
+              (hash-table-for-each
+               in-edit-sequence
+               (λ (key val)
+                 (send key end-edit-sequence)))
+              (set! clear-old-results 
+                    (λ ()
+                      (hash-table-for-each
+                       in-edit-sequence
+                       (λ (key val) (send key begin-edit-sequence)))
+                      (clear-highlight)
+                      (hash-table-for-each
+                       in-edit-sequence
+                       (λ (key val) (send key end-edit-sequence)))
+                      (set! clear-old-results void))))
+            (lock #t)
+            (end-edit-sequence)
+            (let ([canvas (get-canvas)])
+              (when canvas
+                (send canvas scroll-to 0 0 1 1 #t 'start))))
+          
+          ;; top : number (listof X) -> (listof X)
+          ;; extracts the first `n' elements from a list.
+          (define/private (top n lst)
+            (let loop ([n n]
+                       [lst lst])
+              (cond
+                [(null? lst) null]
+                [(= 0 n) null]
+                [else (cons (car lst) (loop (- n 1) (cdr lst)))])))
+
+          (field (src-loc-editor #f)
+                 (percentage-editor #f)
+                 (time-editor #f)
+                 (count-editor #f))
+          (define/private (clear-editors)
+            (set! src-loc-editor #f)
+            (set! percentage-editor #f)
+            (set! time-editor #f)
+            (set! count-editor #f))
+          (define/private (initialize-editors)
+            (set! src-loc-editor (instantiate text% ()))
+            (set! percentage-editor (instantiate text% ()))
+            (set! time-editor (instantiate text% ()))
+            (set! count-editor (instantiate text% ()))
+            (send src-loc-editor set-styles-sticky #f)            
+            (send percentage-editor set-styles-sticky #f)
+            (send time-editor set-styles-sticky #f)
+            (send count-editor set-styles-sticky #f)
+            (insert (instantiate editor-snip% (percentage-editor)))
+            (insert (instantiate editor-snip% (time-editor)))
+            (insert (instantiate editor-snip% (count-editor)))
+            (insert (instantiate editor-snip% (src-loc-editor)))
+            (insert-title (string-constant profiling-col-function) src-loc-editor)
+            (insert-title (string-constant profiling-col-time-in-msec) time-editor)
+            (insert-title (string-constant profiling-col-percent-time) percentage-editor)
+            (insert-title (string-constant profiling-col-calls) count-editor))
+          
+          (define/private (insert-title str txt)
+            (send txt insert str)
+            (send txt insert "\n")
+            (send txt change-style bold-delta 0 (- (send txt last-position) 1))
+            (send txt set-paragraph-alignment 0 'center))
+          
+          (super-new)
+          (hide-caret #t)))
+      
+      ;; format-percentage : number[0 <= n <= 1] -> string
+      ;; formats the number as a percentage string with trailing zeros,
+      ;; to 3 decimal places.
+      (define (format-percentage n)
+        (let* ([number-of-places 3]
+               [whole-part (floor (* n 100))]
+               [decimal-part (- (* n 100) whole-part)]
+               [truncated/moved-decimal-part (floor (* (expt 10 number-of-places) decimal-part))]
+               [pad
+                (λ (str)
+                  (if ((string-length str) . < . number-of-places)
+                      (string-append (make-string (- number-of-places (string-length str)) #\0) 
+                                     str)
+                      str))])
+          (string-append (format "~a" whole-part)
+                         "."
+                         (pad (format "~a" truncated/moved-decimal-part)))))
+
+      (define (small-blank-line txt)
+        (let ([before (send txt last-position)])
+          (send txt insert "\n")
+          (let ([after (send txt last-position)])
+            (send txt change-style small-font-style before after))))
+      
+      (define small-font-style (make-object style-delta% 'change-size 6))
+      
+      ;; bold-delta : style-delta
+      (define bold-delta (make-object style-delta% 'change-bold))
+      
+      ;; insert-profile-src-loc : syntax name -> string
+      (define (insert-profile-src-loc editor stx name)
+        (cond
+          [name
+           (let ([before (send editor last-position)])
+             (send editor insert (format "~a" name)))]
+          [else
+           (let* ([src (syntax-source stx)]
+                  [filename 
+                   (cond
+                     [(string? src) src]
+                     [(is-a? src editor<%>) (get-filename-from-editor src)]
+                     [else (string-constant profiling-unknown-src)])]
+                  [col (syntax-column stx)]
+                  [line (syntax-line stx)]
+                  [pos (syntax-position stx)]
+                  [span (syntax-span stx)]
+                  [src
+                   (cond
+                     [(and col line)
+                      (format "~a: ~a.~a" filename line col)]
+                     [pos
+                      (format "~a: ~a" filename pos)]
+                     [else 
+                      filename])])
+             (send editor insert src))]))
+      
+      ;; open-file-and-goto-position : string (union #f number) -> void
+      (define (open-file-and-goto-position filename pos)
+        (let ([frame (handler:edit-file filename)])
+          (when (and frame
+                     pos
+                     (is-a? frame drscheme:unit:frame%))
+            (let ([defs (send frame get-definitions-text)])
+              (send defs set-position (- pos 1))))))
+      
+      ;; get-src-filename : tst -> (union #f string)
+      (define (get-src-filename src)
+        (cond
+          [(string? src) src]
+          [(is-a? src text%)
+           (send src get-filename)]
+          [else #f]))
+      
+      ;; get-src-loc : syntax -> string
+      (define (get-src-loc expr)
+        (cond
+          [(and (number? (syntax-line expr))
+                (number? (syntax-column expr))
+                (number? (syntax-span expr)))
+           (format " ~a.~a [~a]" 
+                   (syntax-line expr) 
+                   (syntax-column expr)
+                   (syntax-span expr))]
+          [(and (number? (syntax-position expr))
+                (number? (syntax-span expr)))
+           (format " ~a-~a" 
+                   (syntax-position expr)
+                   (syntax-span expr))]
+          [else ""]))
+      
+      (define (add-prefs-panel)
+        (preferences:add-panel
+         (string-constant profiling)
+         (λ (s-parent)
+           (letrec ([parent (make-object vertical-panel% s-parent)]
+                    [msg (make-object message% 
+                           (string-constant profiling-color-config) 
+                           parent)]
+                    [hp (make-object horizontal-pane% parent)]
+                    [low (make-object button% (string-constant profiling-low-color) hp 
+                           (λ (x y) (color-callback #t)))]
+                    [color-bar (make-object color-bar% hp)]
+                    [high (make-object button% (string-constant profiling-high-color) hp
+                            (λ (x y) (color-callback #f)))]
+                    
+                    [scale (instantiate radio-box% ()
+                             (label (string-constant profiling-scale))
+                             (parent parent)
+                             (callback (λ (x y) (scale-callback)))
+                             (choices
+                              (list (string-constant profiling-sqrt)
+                                    (string-constant profiling-linear)
+                                    (string-constant profiling-square))))]
+                    
+                    [color-callback
+                     (λ (low?)
+                       (let ([color (get-color-from-user 
+                                     (if low?
+                                         (string-constant profiling-choose-low-color)
+                                         (string-constant profiling-choose-high-color))
+                                     #f
+                                     (preferences:get
+                                      (if low?
+                                          'drscheme:profile:low-color
+                                          'drscheme:profile:high-color)))])
+                         (when color
+                           (preferences:set 
+                            (if low? 'drscheme:profile:low-color 'drscheme:profile:high-color)
+                            color))))]
+                    [scale-callback
+                     (λ ()
+                       (preferences:set 
+                        'drscheme:profile:scale
+                        (case (send scale get-selection)
+                          [(0) 'sqrt]
+                          [(1) 'linear]
+                          [(2) 'square])))])
+             (preferences:add-callback
+              'drscheme:profile:scale
+              (λ (p v)
+                (send scale set-selection
+                      (case v
+                        [(sqrt) 0]
+                        [(linear) 1]
+                        [(square) 2]))))
+             (send parent set-alignment 'left 'center)
+             (send hp stretchable-height #f)
+             parent))))
+      
+      (define color-bar%
+        (class canvas%
+          (inherit get-client-size get-dc)
+          (field [pen (make-object pen% "black" 1 'solid)]
+                 [in-on-paint? #f])
+          (define/override (on-paint)
+            (set! in-on-paint? #t)
+            (let* ([dc (get-dc)]
+                   [dummy-pen (send dc get-pen)])
+              (let-values ([(w h) (get-client-size)])
+                (let loop ([n 0])
+                  (when (n . <= . w)
+                    (send pen set-color (get-color-value n w))
+                    (send dc set-pen pen)
+                    (send dc draw-line n 0 n h)
+                    (send dc set-pen dummy-pen)
+                    (loop (+ n 1))))
+                (let-values ([(tw th ta td) (send dc get-text-extent 
+                                              (string-constant profiling-example-text))])
+                  (send dc draw-text
+                        (string-constant profiling-example-text)
+                        (floor (- (/ w 2) (/ tw 2)))
+                        (floor (- (/ h 2) (/ th 2)))))))
+            (set! in-on-paint? #f))
+          
+          ;; queue callbacks here so that the preferences
+          ;; values are actually set by the time on-paint
+          ;; is called.
+          (preferences:add-callback
+           'drscheme:profile:scale
+           (λ (p v)
+             (unless in-on-paint?
+               (queue-callback
+                (λ ()
+                  (on-paint))))))
+          (preferences:add-callback
+           'drscheme:profile:low-color
+           (λ (p v)
+             (unless in-on-paint?
+               (queue-callback
+                (λ ()
+                  (on-paint))))))
+          (preferences:add-callback
+           'drscheme:profile:high-color
+           (λ (p v)
+             (unless in-on-paint?
+               (queue-callback
+                (λ ()
+                  (on-paint))))))
+
+          (super-instantiate ())))
+      
+                                                                      
+                                                                      
+                                     ;                                
+                                     ;                                
+  ;;;   ; ;;;  ; ;;;   ;;;   ; ;;;  ;;;;;  ; ;;;  ;;;;    ;;;    ;;;  
+ ;   ;   ;      ;     ;   ;   ;      ;      ;         ;  ;   ;  ;   ; 
+ ;;;;;   ;      ;     ;   ;   ;      ;      ;      ;;;;  ;      ;;;;; 
+ ;       ;      ;     ;   ;   ;      ;      ;     ;   ;  ;      ;     
+ ;   ;   ;      ;     ;   ;   ;      ;   ;  ;     ;   ;  ;   ;  ;   ; 
+  ;;;   ;;;;   ;;;;    ;;;   ;;;;     ;;;  ;;;;    ;;; ;  ;;;    ;;;  
+                                                                      
+                                                                      
+                                                                      
+      (define-values/invoke-unit/sig stacktrace^ stacktrace@ #f stacktrace-imports^))))
diff --git a/collects/drscheme/private/drscheme-normal.ss b/collects/drscheme/private/drscheme-normal.ss
new file mode 100644
index 0000000000..565867dea9
--- /dev/null
+++ b/collects/drscheme/private/drscheme-normal.ss
@@ -0,0 +1,269 @@
+
+(module drscheme-normal mzscheme
+  (require (lib "mred.ss" "mred")
+	   (lib "class.ss")
+           (lib "bday.ss" "framework" "private"))
+  
+  ;; this used to be done by mred, but
+  ;; since drscheme uses the -Z flag now,
+  ;; we have to do it explicitly.
+  (current-load text-editor-load-handler)
+  
+  (define-values (texas-independence-day? halloween?)
+    (let* ([date (seconds->date (current-seconds))]
+           [month (date-month date)]
+           [day (date-day date)])
+      (values (and (= 3 month) (= 2 day))
+              (and (= 10 month) (= 31 day)))))
+  
+  (define high-color? ((get-display-depth) . > . 8))
+  (define special-state #f)
+  (define normal-bitmap #f)
+  (define (get-normal-bitmap)
+    (unless normal-bitmap
+      (set! normal-bitmap  (make-object bitmap% (build-path (collection-path "icons") "PLT-206.png"))))
+    normal-bitmap)
+  
+  (define-struct magic-image (string filename bitmap)) 
+  
+  (define (magic-img str img)
+    (make-magic-image (list->string (reverse (string->list str))) img #f))
+  
+  ;; magic strings and their associated images. Any string in this list that's a prefix of any other
+  ;; is not going to be reachable; you could change that by removing the (set! key-codes null) line
+  ;; where the match occurs
+  (define magic-images
+    (list 
+     (magic-img "larval" "PLT-206-larval.png")
+     (magic-img "mars" "PLT-206-mars.jpg")))
+  
+  (define (load-magic-images)
+    (get-normal-bitmap)
+    (for-each 
+     (λ (magic-image)
+       (unless (magic-image-bitmap magic-image)
+         (set-magic-image-bitmap! 
+          magic-image 
+          (make-object bitmap% (build-path (collection-path "icons") (magic-image-filename magic-image))))))
+     magic-images))
+  
+  (define longest-magic-string (apply max (map (λ (s) (string-length (magic-image-string s))) magic-images)))
+  
+  (define key-codes null)
+  (define key-codes-len 0)
+  
+  (define (add-key-code new-code)
+    (unless (eq? 'release new-code)
+      (set! key-codes
+            (let loop ([n longest-magic-string]
+                       [l (cons new-code key-codes)])
+              (cond
+                [(zero? n) null]
+                [(null? l) null]
+                [else (cons (car l) (loop (- n 1) (cdr l)))])))))
+
+  (let ([set-splash-bitmap (dynamic-require '(lib "splash.ss" "framework") 'set-splash-bitmap)])
+    ((dynamic-require '(lib "splash.ss" "framework") 'set-splash-char-observer)
+     (λ (evt)
+       (add-key-code (send evt get-key-code))
+       
+       ;; as soon as something is typed, load the bitmaps
+       (load-magic-images)
+       
+       (when (andmap char? key-codes)
+         (let ((s (apply string key-codes)))
+           (cond 
+             [(ormap (λ (m)
+                       (if (string=? s (magic-image-string m))
+                           m
+                           #f)) magic-images)
+              => 
+              (λ (match)
+                (set! key-codes null)
+                (set-splash-bitmap
+                 (if (and special-state (string=? special-state (magic-image-string match)))
+                     (begin
+                       (set! special-state #f)
+                       (get-normal-bitmap))
+                     (begin
+                       (set! special-state (magic-image-string match))
+                       (magic-image-bitmap match)))))]
+             [else (void)]))))))
+  
+  (when (eb-bday?)
+    (let ()
+      (define main-size 260)
+      (define pi (atan 0 -1))
+      
+      (define eli (make-object bitmap% (build-path (collection-path "icons") "eli-purple.jpg")))
+      (define bitmap (make-object bitmap% main-size main-size))
+      (define bdc (make-object bitmap-dc% bitmap))
+      
+      (define outer-color (send the-color-database find-color "darkorange"))
+      (define inner-color (send the-color-database find-color "green"))
+      (define omega-str "λ (x) (x x)) (λ (x) (x x))) ((")
+      (define hebrew-str "�ין סופיות �ין סופיות ")
+      
+      (define (draw-letter dc cx cy angle radius letter color)
+        (let ([x (+ cx (* (cos angle) radius))]
+              [y (- cy (* (sin angle) radius))])
+          (send bdc set-text-foreground color)
+          (send dc draw-text letter x y #f 0 (- angle (/ pi 2)))))
+      
+      (define (draw-single-loop str dc offset cx cy radius font-size color)
+        (send dc set-font (send the-font-list find-or-create-font font-size 'modern))
+        (let loop ([i (string-length str)])
+          (unless (zero? i)
+            (draw-letter dc 
+                         cx 
+                         cy 
+                         (normalize-angle
+                          (+ (- (* 2 pi) (* (* 2 pi) (/ (- i 1) (string-length str))))
+                             (/ pi 2)
+                             offset))
+                         radius
+                         (string (string-ref str (- i 1)))
+                         color)
+            (loop (- i 1)))))
+      
+      (define (normalize-angle angle)
+        (cond
+          [(<= 0 angle (* 2 pi)) angle]
+          [(< angle 0) (normalize-angle (+ angle (* 2 pi)))]
+          [else (normalize-angle (- angle (* 2 pi)))]))
+      
+      (define splash-canvas ((dynamic-require '(lib "splash.ss" "framework") 'get-splash-canvas)))
+      (define (draw-single-step dc offset)
+        (send bdc draw-bitmap eli 0 0)
+        (draw-single-loop omega-str bdc offset (/ main-size 2) (/ main-size 2) 120 32 outer-color)
+        (draw-single-loop hebrew-str bdc (+ (- (* 2 pi) offset) (* 2 pi)) (/ main-size 2) (/ main-size 2) 70 20 inner-color)
+        (send splash-canvas on-paint))
+      
+      (define gc-b 
+        (with-handlers ([exn:fail? (lambda (x)
+                                     (printf "~s\n" (exn-message x))
+                                     #f)])
+          (let ([b (make-object bitmap% (build-path (collection-path "icons") "recycle.gif"))])
+            (cond
+              [(send b ok?)
+               (let ([gbdc (make-object bitmap-dc% b)]
+                     [ebdc (make-object bitmap-dc% eli)]
+                     [color1 (make-object color%)]
+                     [color2 (make-object color%)]
+                     [avg (lambda (x y) (floor (* (/ x 255) y)))]
+                     [ox (floor (- (/ main-size 2) (/ (send b get-width) 2)))]
+                     [oy (floor (- (/ main-size 2) (/ (send b get-height) 2)))])
+                 (let loop ([i (send b get-width)])
+                   (unless (zero? i)
+                     (let loop ([j (send b get-height)])
+                       (unless (zero? j)
+                         (let ([x (- i 1)]
+                               [y (- j 1)])
+                           (send gbdc get-pixel x y color1)
+                           (send ebdc get-pixel (+ x ox) (+ y oy) color2)
+                           (send color1 set 
+                                 (avg (send color1 red) (send color2 red))
+                                 (avg (send color1 green) (send color2 green))
+                                 (avg (send color1 blue) (send color2 blue)))
+                           (send gbdc set-pixel x y color1)
+                           (loop (- j 1)))))
+                     (loop (- i 1))))
+                 (send gbdc set-bitmap #f)
+                 (send ebdc set-bitmap #f)
+                 b)]
+              [else #f]))))
+
+      
+      (define (eli-paint dc)
+        (send dc draw-bitmap bitmap 0 0))
+      (define (eli-event evt)
+        (cond
+          [(send evt leaving?)
+           ((dynamic-require '(lib "splash.ss" "framework") 'set-splash-paint-callback) orig-paint)
+           (when gc-b
+             (unregister-collecting-blit splash-canvas))
+           (send splash-canvas refresh)
+           (when draw-thread
+             (kill-thread draw-thread)
+             (set! draw-thread #f))]
+          [(send evt entering?)
+           ((dynamic-require '(lib "splash.ss" "framework") 'set-splash-paint-callback) eli-paint)
+           (when gc-b
+             (register-collecting-blit splash-canvas 
+                                       (floor (- (/ main-size 2)
+                                                 (/ (send gc-b get-width) 2)))
+                                       (floor (- (/ main-size 2)
+                                                 (/ (send gc-b get-height) 2)))
+                                       (send gc-b get-width)
+                                       (send gc-b get-height)
+                                       gc-b gc-b))
+           (send splash-canvas refresh)
+           (unless draw-thread
+             (start-thread))]))
+      
+      (define splash-eventspace ((dynamic-require '(lib "splash.ss" "framework") 'get-splash-eventspace)))
+      (define draw-next-state
+        (let ([o 0])
+          (lambda ()
+            (let ([s (make-semaphore 0)])
+              (parameterize ([current-eventspace splash-eventspace])
+                (queue-callback 
+                 (λ () 
+                   (draw-single-step bdc o)
+                   (semaphore-post s))))
+              (semaphore-wait s))
+            (let ([next (- o (/ pi 60))])
+              (set! o (if (< next 0)
+                          (+ next (* 2 pi))
+                          next))))))
+      
+      (define draw-thread #f)
+      (define (start-thread)        
+        (set! draw-thread
+              (thread
+               (λ ()
+                 (let loop ()
+                   (draw-next-state)
+                   (sleep .01)
+                   (loop))))))
+      (define orig-paint ((dynamic-require '(lib "splash.ss" "framework") 'get-splash-paint-callback)))
+      
+      (draw-next-state)
+      ((dynamic-require '(lib "splash.ss" "framework") 'set-splash-event-callback) eli-event)
+      (send splash-canvas refresh)))
+  
+  ((dynamic-require '(lib "splash.ss" "framework") 'start-splash)
+   (build-path (collection-path "icons") 
+               (cond
+                 [texas-independence-day?
+                  "texas-plt-bw.gif"]
+                 [(and halloween? high-color?)
+                  "PLT-pumpkin.png"]
+                 [high-color? "PLT-206.png"]
+                 [(= (get-display-depth) 1)
+                  "pltbw.gif"]
+                 [else
+                  "plt-flat.gif"]))
+   "DrScheme"
+   99)
+  
+  (when (getenv "PLTDRBREAK")
+    (printf "PLTDRBREAK: creating break frame\n")
+    (let ([to-break (eventspace-handler-thread (current-eventspace))])
+      (parameterize ([current-eventspace (make-eventspace)])
+        (let* ([f (new frame% (label "Break DrScheme"))]
+               [b (new button% 
+                       (label "Break Main Thread")
+                       (callback
+                        (λ (x y)
+                          (break-thread to-break)))
+                       (parent f))]
+               [b (new button% 
+                       (label "Break All Threads")
+                       (callback
+                        (λ (x y)
+                          ((dynamic-require '(lib "key.ss" "drscheme" "private") 'break-threads))))
+                       (parent f))])
+          (send f show #t)))))
+  
+  (dynamic-require '(lib "start.ss" "drscheme" "private") #f))
diff --git a/collects/drscheme/private/drsig.ss b/collects/drscheme/private/drsig.ss
new file mode 100644
index 0000000000..4565f604f5
--- /dev/null
+++ b/collects/drscheme/private/drsig.ss
@@ -0,0 +1,271 @@
+
+(module drsig mzscheme
+  (require (lib "unitsig.ss"))
+  
+  (provide drscheme:eval^
+           drscheme:debug^
+           drscheme:module-language^
+           drscheme:get-collection^
+           drscheme:main^
+           drscheme:init^
+           drscheme:language-configuration^
+           drscheme:language-configuration/internal^
+           drscheme:tools^
+           drscheme:get/extend^
+           drscheme:unit^
+           drscheme:frame^
+           drscheme:program^
+           drscheme:text^
+           drscheme:rep^
+           drscheme:app^
+           drscheme:draw-arrow^
+           drscheme:help-desk^
+           drscheme:language^
+           drscheme:teachpack^
+           drscheme:multi-file-search^
+           drscheme:module-overview^
+           drscheme:font^
+           drscheme:modes^
+           drscheme:tool-exports^
+           drscheme:tool^
+	   drscheme^)
+
+  (define-signature drscheme:modes^
+    (add-mode
+     get-modes
+     add-initial-modes
+     (struct mode (name surrogate repl-submit matches-language) 
+             -setters
+             (- make-mode))))
+  
+  (define-signature drscheme:font^
+    (setup-preferences))
+  
+  (define-signature drscheme:debug^
+    (make-debug-error-display-handler
+     make-debug-error-display-handler/text
+     make-debug-eval-handler
+     hide-backtrace-window
+     
+     profile-definitions-text-mixin
+     profile-tab-mixin
+     profile-unit-frame-mixin
+     profiling-enabled
+
+     test-coverage-enabled
+     test-coverage-interactions-text-mixin
+     test-coverage-definitions-text-mixin
+     test-coverage-tab-mixin
+     
+     add-prefs-panel
+     
+     show-error-and-highlight
+     open-and-highlight-in-file
+     show-backtrace-window
+     get-cm-key))
+  
+  (define-signature drscheme:module-language^
+    (add-module-language
+     module-language<%>
+     module-language-put-file-mixin))
+  
+  (define-signature drscheme:get-collection^
+    (get-file/collection))
+  
+  (define-signature drscheme:main^ ())
+  
+  (define-signature drscheme:init^
+    (original-output-port
+     original-error-port
+     original-error-display-handler
+     primitive-eval
+     primitive-load
+     error-display-handler-message-box-title
+     system-custodian
+     system-eventspace
+     system-namespace
+     first-dir))
+  
+  (define-signature drscheme:language-configuration^
+    (add-language
+     (struct language-settings (language settings) -setters)
+     get-settings-preferences-symbol
+     language-dialog
+     fill-language-dialog))
+  
+  (define-signature drscheme:language-configuration/internal^
+    (add-info-specified-languages
+     get-default-language-settings
+     (open drscheme:language-configuration^)
+     get-languages
+     settings-preferences-symbol
+
+     add-built-in-languages
+     
+     ;; for the language dialog
+     add-new-teachpack
+     clear-all-teachpacks))
+  
+  (define-signature drscheme:tools^
+    ((struct successful-tool (spec bitmap name url))
+     get-successful-tools
+     only-in-phase
+     load/invoke-all-tools))
+
+  (define-signature drscheme:get/extend^
+    (extend-tab
+     extend-interactions-text
+     extend-definitions-text
+     extend-interactions-canvas
+     extend-definitions-canvas
+     extend-unit-frame
+     get-tab
+     get-interactions-text
+     get-definitions-text
+     get-interactions-canvas
+     get-definitions-canvas
+     get-unit-frame))
+    
+  (define-signature drscheme:unit^
+    (tab%
+     tab<%>
+     frame% 
+     frame<%>
+     definitions-canvas%
+     get-definitions-text%
+     definitions-text<%>
+     interactions-canvas%
+     open-drscheme-window
+     find-symbol
+     get-program-editor-mixin
+     add-to-program-editor-mixin))
+  
+  (define-signature drscheme:frame^
+    (<%>
+     mixin
+     basics-mixin
+     basics<%>
+     create-root-menubar))
+  
+  (define-signature drscheme:program^
+    (frame%))
+
+  (define-signature drscheme:eval^
+    (expand-program
+     expand-program/multiple
+     traverse-program/multiple
+     build-user-eventspace/custodian
+     set-basic-parameters
+     get-snip-classes))
+  
+  (define-signature drscheme:text^
+    (text<%>
+     text%))
+  
+  (define-signature drscheme:setup^ 
+    (do-setup))
+  
+  (define-signature drscheme:rep^
+    (drs-bindings-keymap-mixin
+     current-rep
+     current-language-settings
+     current-value-port
+     get-drs-bindings-keymap
+     text%
+     text<%>
+     context<%>))
+  
+  (define-signature drscheme:app^
+    (check-new-version
+     about-drscheme
+     invite-tour
+     add-language-items-to-help-menu
+     add-important-urls-to-help-menu
+     switch-language-to))
+  
+  (define-signature drscheme:draw-arrow^
+    (draw-arrow))
+  
+  (define-signature drscheme:help-desk^
+    (goto-help
+     goto-tour
+     goto-release-notes
+     goto-plt-license
+     help-desk
+     get-docs
+     open-url))
+  
+  (define-signature drscheme:language^
+    (get-default-mixin
+     extend-language-interface
+     get-language-extensions
+     
+     create-module-based-launcher
+     create-module-based-stand-alone-executable
+
+     create-executable-gui
+     put-executable
+     
+     ;(struct loc (source position line column span) -setters)
+
+     (struct text/pos (text start end) -setters)
+     (struct simple-settings (case-sensitive 
+                              printing-style 
+                              fraction-style
+                              show-sharing
+                              insert-newlines
+                              annotations)
+             -setters)
+     simple-settings->vector
+
+     simple-module-based-language-config-panel
+     
+     add-snip-value
+     
+     language<%>
+     module-based-language<%>
+     simple-module-based-language<%>
+     simple-module-based-language%
+     simple-module-based-language->module-based-language-mixin
+     module-based-language->language-mixin))
+
+  (define-signature drscheme:teachpack^
+    (install-teachpacks
+     marshall-teachpack-cache
+     unmarshall-teachpack-cache
+     launcher-init-code
+     launcher-modules-to-embed
+     new-teachpack-cache
+     teachpack-cache?
+     teachpack-cache-filenames
+     teachpack-cache-require-specs
+     set-teachpack-cache-filenames!))
+
+  (define-signature drscheme:multi-file-search^
+    (multi-file-search))
+  
+  (define-signature drscheme:module-overview^
+    (module-overview
+     make-module-overview-pasteboard
+     fill-pasteboard))
+
+  (define-signature drscheme:tool-exports^
+    (phase1 
+     phase2))
+  
+  (define-signature drscheme:tool^
+    ((unit drscheme:debug : drscheme:debug^)
+     (unit drscheme:unit : drscheme:unit^)
+     (unit drscheme:rep : drscheme:rep^)
+     (unit drscheme:frame : drscheme:frame^)
+     (unit drscheme:get/extend : drscheme:get/extend^)
+     (unit drscheme:language-configuration : drscheme:language-configuration^)
+     (unit drscheme:language : drscheme:language^)
+     (unit drscheme:help-desk : drscheme:help-desk^)
+     (unit drscheme:eval : drscheme:eval^)
+     (unit drscheme:teachpack : drscheme:teachpack^)
+     (unit drscheme:modes : drscheme:modes^)))
+
+  (define-signature drscheme^
+    ((unit drscheme:teachpack : drscheme:teachpack^)
+     (unit drscheme:language-configuration : drscheme:language-configuration/internal^))))
diff --git a/collects/drscheme/private/eval.ss b/collects/drscheme/private/eval.ss
new file mode 100644
index 0000000000..f81971274f
--- /dev/null
+++ b/collects/drscheme/private/eval.ss
@@ -0,0 +1,218 @@
+
+(module eval mzscheme
+  (require (lib "mred.ss" "mred")
+           (lib "unitsig.ss")
+           (lib "class.ss")
+	   (lib "toplevel.ss" "syntax")
+           "drsig.ss"
+           (lib "framework.ss" "framework"))
+  
+  ;; to ensure this guy is loaded (and the snipclass installed) in the drscheme namespace & eventspace
+  (require (lib "cache-image-snip.ss" "mrlib"))
+
+  (define op (current-output-port))
+  (define (oprintf . args) (apply fprintf op args))
+  
+  (provide eval@)
+  (define eval@
+    (unit/sig drscheme:eval^
+      (import [drscheme:language-configuration : drscheme:language-configuration/internal^]
+              [drscheme:rep : drscheme:rep^]
+              [drscheme:init : drscheme:init^]
+              [drscheme:language : drscheme:language^]
+              [drscheme:teachpack : drscheme:teachpack^])
+      
+      (define (traverse-program/multiple language-settings
+                                         init
+                                         kill-termination)
+        (let-values ([(eventspace custodian teachpack-cache) 
+                      (build-user-eventspace/custodian
+                       language-settings
+                       init
+                       kill-termination)])
+          (let ([language (drscheme:language-configuration:language-settings-language
+                           language-settings)]
+                [settings (drscheme:language-configuration:language-settings-settings
+                           language-settings)])
+            (λ (input iter complete-program?)
+              (let-values ([(port src)
+                            (cond
+                              [(input-port? input) (values input #f)]
+                              [else (values
+                                     (let ([p (open-input-text-editor
+                                               (drscheme:language:text/pos-text input)
+                                               (drscheme:language:text/pos-start input)
+                                               (drscheme:language:text/pos-end input))])
+                                       (port-count-lines! p)
+                                       p)
+                                     (drscheme:language:text/pos-text input))])])
+                (parameterize ([current-eventspace eventspace])
+                  (queue-callback
+                   (λ ()
+                     (let ([read-thnk 
+                            (if complete-program?
+                                (send language front-end/complete-program port settings teachpack-cache)
+                                (send language front-end/interaction port settings teachpack-cache))])
+                       (let loop ()
+                         (let ([in (read-thnk)])
+                           (cond
+                             [(eof-object? in)
+                              (iter in (λ () (void)))]
+                             [else
+                              (iter in (λ () (loop)))]))))))))))))
+      
+      (define (expand-program/multiple language-settings
+                                       eval-compile-time-part? 
+                                       init
+                                       kill-termination)
+        (let ([res (traverse-program/multiple language-settings init kill-termination)])
+          (λ (input iter complete-program?)
+            (let ([expanding-iter
+                   (λ (rd cont)
+                     (cond
+                       [(eof-object? rd) (iter rd cont)]
+                       [eval-compile-time-part? 
+                        (iter (expand-top-level-with-compile-time-evals rd) cont)]
+                       [else (iter (expand rd) cont)]))])
+              (res input 
+                   expanding-iter
+                   complete-program?)))))
+      
+      (define (expand-program input
+                              language-settings
+                              eval-compile-time-part? 
+                              init
+                              kill-termination
+                              iter)
+        ((expand-program/multiple 
+          language-settings
+          eval-compile-time-part? 
+          init
+          kill-termination)
+         input
+         iter
+         #t))
+         
+      
+      (define (build-user-eventspace/custodian language-settings init kill-termination)
+        (let* ([user-custodian (make-custodian)]
+               [user-teachpack-cache (preferences:get 'drscheme:teachpacks)]
+	       [eventspace (parameterize ([current-custodian user-custodian])
+			     (make-eventspace))]
+               [language (drscheme:language-configuration:language-settings-language
+                          language-settings)]
+               [settings (drscheme:language-configuration:language-settings-settings
+                          language-settings)]
+               [eventspace-main-thread #f]
+               [run-in-eventspace
+                (λ (thnk)
+                  (parameterize ([current-eventspace eventspace])
+                    (let ([sema (make-semaphore 0)]
+                          [ans #f])
+                      (queue-callback
+                       (λ ()
+                         (let/ec k
+                           (parameterize ([error-escape-handler
+                                           (let ([drscheme-expand-program-error-escape-handler
+                                                  (λ () (k (void)))])
+                                             drscheme-expand-program-error-escape-handler)])
+                             (set! ans (thnk))))
+                         (semaphore-post sema)))
+                      (semaphore-wait sema)
+                      ans)))]
+               [drs-snip-classes (get-snip-classes)])
+          (run-in-eventspace
+           (λ ()
+             (current-custodian user-custodian)
+             (set-basic-parameters drs-snip-classes)
+             (drscheme:rep:current-language-settings language-settings)))
+          (send language on-execute settings run-in-eventspace)
+          (run-in-eventspace
+           (λ ()
+             (set! eventspace-main-thread (current-thread))
+             (drscheme:teachpack:install-teachpacks user-teachpack-cache)
+             (init)
+             (break-enabled #t)))
+          (thread
+           (λ ()
+             (thread-wait eventspace-main-thread)
+             (kill-termination)))
+          (values eventspace user-custodian user-teachpack-cache)))
+      
+      ;; get-snip-classes : -> (listof snipclass)
+      ;; returns a list of the snip classes in the current eventspace
+      (define (get-snip-classes)
+        (let loop ([n (send (get-the-snip-class-list) number)])
+          (if (zero? n)
+              null
+              (cons (send (get-the-snip-class-list) nth (- n 1))
+                    (loop (- n 1))))))
+      
+      ;; set-basic-parameters : (listof (is-a/c? snipclass%)) -> void
+      ;; sets the parameters that are shared between the repl's initialization
+      ;; and expand-program
+      (define (set-basic-parameters snip-classes)
+        (for-each (λ (snip-class) (send (get-the-snip-class-list) add snip-class))
+                  snip-classes)
+        
+        (current-thread-group (make-thread-group))        
+        (current-command-line-arguments #())
+        (read-curly-brace-as-paren #t)
+        (read-square-bracket-as-paren #t)
+        (error-print-width 250)
+        (current-ps-setup (make-object ps-setup%))
+
+        (let ([user-custodian (current-custodian)])
+          (exit-handler (λ (arg) ; =User=
+                          (custodian-shutdown-all user-custodian))))
+        (current-namespace (make-namespace 'empty))
+        (for-each (λ (x) (namespace-attach-module drscheme:init:system-namespace x))
+                  to-be-copied-module-names))
+      
+      ;; these module specs are copied over to each new user's namespace 
+      (define to-be-copied-module-specs
+        (list 'mzscheme
+              '(lib "foreign.ss")
+              '(lib "mred.ss" "mred")
+              '(lib "cache-image-snip.ss" "mrlib")))
+      
+      ;; ensure that they are all here.
+      (for-each (λ (x) (dynamic-require x #f)) to-be-copied-module-specs)
+      ;; get the names of those modules.
+      (define to-be-copied-module-names
+        (let ([get-name
+               (λ (spec)
+                 (if (symbol? spec)
+                     spec
+                     ((current-module-name-resolver) spec #f #f)))])
+          (map get-name to-be-copied-module-specs)))
+      
+      ;; build-input-port : string[file-exists?] -> (values input any)
+      ;; constructs an input port for the load handler. Also
+      ;; returns a value representing the source of code read from the file.
+      ;; if the file's first lines begins with #!, skips the first chars of the file.
+      (define (build-input-port filename)
+        (let* ([p (open-input-file filename)]
+               [chars (list (read-char p)
+                            (read-char p)
+                            (read-char p)
+                            (read-char p))])
+          (close-input-port p)
+          (cond
+            [(equal? chars (string->list "WXME"))
+             (let ([text (make-object text%)])
+               (send text load-file filename)
+               (let ([port (open-input-text-editor text)])
+                 (port-count-lines! port)
+                 (when (and ((send text last-position) . >= . 2)
+                            (char=? #\# (send text get-character 0))
+                            (char=? #\! (send text get-character 1)))
+                   (read-line port))
+                 (values port text)))]
+            [else
+             (let ([port (open-input-file filename)])
+               (port-count-lines! port)
+               (when (and (equal? #\# (car chars))
+                          (equal? #\! (cadr chars)))
+                 (read-line port))
+               (values port filename))]))))))
diff --git a/collects/drscheme/private/font.ss b/collects/drscheme/private/font.ss
new file mode 100644
index 0000000000..99c2f1b2d4
--- /dev/null
+++ b/collects/drscheme/private/font.ss
@@ -0,0 +1,186 @@
+(module font mzscheme
+  (require (lib "unitsig.ss")
+           (lib "class.ss")
+           "drsig.ss"
+           (lib "mred.ss" "mred")
+           (lib "framework.ss" "framework")
+           (lib "string-constant.ss" "string-constants"))
+  
+  (define sc-smoothing-label (string-constant font-smoothing-label))
+  (define sc-smoothing-none (string-constant font-smoothing-none))
+  (define sc-smoothing-some (string-constant font-smoothing-some))
+  (define sc-smoothing-all (string-constant font-smoothing-all))
+  (define sc-smoothing-default (string-constant font-smoothing-default))
+  
+  (provide font@)
+  
+  (define font@
+    (unit/sig drscheme:font^
+      (import [drscheme:language-configuration : drscheme:language-configuration/internal^])
+      
+      (define (setup-preferences)
+        (preferences:add-panel
+         (list (string-constant font-prefs-panel-title))
+         (λ (panel)
+           (let* ([main (make-object vertical-panel% panel)]
+		  [min-size 1]
+		  [max-size 72]
+                  [options-panel (make-object horizontal-panel% main)]
+		  [size-panel (new group-box-panel%
+				   (parent options-panel)
+				   (label (string-constant font-size)))]
+                  [adjust-font-size
+                   (λ (f)
+                     (preferences:set
+                      'framework:standard-style-list:font-size
+                      (f (preferences:get
+                          'framework:standard-style-list:font-size))))]
+                  [size-slider
+		   (new slider%
+			(label #f)
+			(min-value min-size)
+			(max-value max-size)
+			(parent size-panel)
+			(callback
+			 (λ (size evt)
+                           (adjust-font-size
+                            (λ (old-size)
+                              (send size get-value)))))
+			(init-value
+			 (preferences:get 'framework:standard-style-list:font-size)))]
+		  [size-hp (new horizontal-pane% (parent size-panel))]
+                  [mk-size-button
+                   (λ (label chng)
+                     (new button%
+                          (parent size-hp)
+                          (stretchable-width #t)
+                          (callback
+                           (λ (x y)
+                             (adjust-font-size
+                              (λ (old-size)
+                                (min max-size (max min-size (chng old-size)))))))
+                          (label label)))]
+                  [size-sub1 (mk-size-button "-1" sub1)]
+                  [size-sub1 (mk-size-button "+1" add1)]
+                  
+                  [choice-panel (new vertical-panel% (parent options-panel))]
+                  [font-name-control
+                   (case (system-type)
+                     [(windows macos macosx)
+                      (let* ([choice
+                              (new choice%
+                                   (label (string-constant font-name))
+                                   (choices (get-face-list 'mono))
+                                   (parent choice-panel)
+                                   (stretchable-width #t)
+                                   (callback
+                                    (λ (font-name evt)
+                                      (preferences:set 
+                                       'framework:standard-style-list:font-name
+                                       (send font-name get-string-selection)))))]
+                             [font-name (preferences:get 'framework:standard-style-list:font-name)])
+                        (preferences:add-callback
+                         'framework:standard-style-list:font-name
+                         (λ (p v)
+                           (when (send choice find-string v)
+                             (send choice set-string-selection v))))
+                        (when (send choice find-string font-name)
+                          (send choice set-string-selection font-name))
+                        choice)]
+                     [(unix)
+                      (make-object button%
+                        (string-constant set-font)
+                        choice-panel
+                        (λ xxx
+                          (let* ([faces (get-face-list 'mono)]
+                                 [init-choices
+                                  (let ([init (preferences:get 'framework:standard-style-list:font-name)])
+                                    (let loop ([faces faces]
+                                               [num 0])
+                                      (cond
+                                        [(null? faces) null]
+                                        [else
+                                         (let ([face (car faces)])
+                                           (if (equal? init face)
+                                               (list num)
+                                               (loop (cdr faces)
+                                                     (+ num 1))))])))]
+                                 [choice (get-choices-from-user
+                                          (string-constant select-font-name)
+                                          (string-constant select-font-name)
+                                          (get-face-list 'mono)
+                                          #f
+                                          init-choices)])
+                            (when choice
+                              (preferences:set 
+                               'framework:standard-style-list:font-name 
+                               (list-ref (get-face-list 'mono) (car choice)))))))]
+                     [else (error 'font-name-control "unknown system type: ~s~n" (system-type))])]
+                  [smoothing-contol
+                   (new choice%
+                        (label sc-smoothing-label)
+                        (choices (list sc-smoothing-none
+                                       sc-smoothing-some
+                                       sc-smoothing-all
+                                       sc-smoothing-default))
+                        (parent choice-panel)
+                        (stretchable-width #t)
+                        (selection (case (preferences:get 'framework:standard-style-list:smoothing)
+                                     [(unsmoothed) 0]
+                                     [(partly-smoothed) 1]
+                                     [(smoothed) 2]
+                                     [(default) 3]))
+                        (callback (λ (x y) 
+                                    (preferences:set 
+                                     'framework:standard-style-list:smoothing
+                                     (case (send x get-selection)
+                                       [(0) 'unsmoothed]
+                                       [(1) 'partly-smoothed]
+                                       [(2) 'smoothed]
+                                       [(3) 'default])))))]
+                  
+                  [text (make-object (editor:standard-style-list-mixin text%))]
+                  [ex-panel (make-object horizontal-panel% main)]
+                  [msg (make-object message% (string-constant example-text) ex-panel)]
+                  [canvas (make-object canvas:color% main text)]
+                  [update-text
+                   (λ (setting)
+                     (send text begin-edit-sequence)
+                     (send text lock #f)
+                     (send text erase)
+                     (send text insert 
+                           (format
+                            ";; howmany : list-of-numbers -> number~
+                           \n;; to determine how many numbers are in `a-lon'~
+                           \n(define (howmany a-lon)~
+                           \n  (cond~
+                           \n    [(empty? a-lon) 0]~
+                           \n    [else (+ 1 (howmany (rest a-lon)))]))~
+                           \n~
+                           \n;; examples as tests~
+                           \n(howmany empty)~
+                           \n\"should be\"~
+                           \n0~
+                           \n~
+                           \n(howmany (cons 1 (cons 2 (cons 3 empty))))~
+                           \n\"should be\"~
+                           \n3"))
+                     (send text set-position 0 0)
+                     (send text lock #t)
+                     (send text end-edit-sequence))])
+             
+             (preferences:add-callback
+              'framework:standard-style-list:font-size
+              (λ (p v) (send size-slider set-value v)))
+             (preferences:add-callback
+              drscheme:language-configuration:settings-preferences-symbol
+              (λ (p v)
+                (update-text v)))
+             (update-text (preferences:get drscheme:language-configuration:settings-preferences-symbol))
+             (send ex-panel set-alignment 'left 'center)
+             (send ex-panel stretchable-height #f)
+             (send canvas allow-tab-exit #t)
+             (send options-panel stretchable-height #f)
+             (send options-panel set-alignment 'center 'top)
+             (send text lock #t)
+             main)))))))
\ No newline at end of file
diff --git a/collects/drscheme/private/frame.ss b/collects/drscheme/private/frame.ss
new file mode 100644
index 0000000000..ee0cf44427
--- /dev/null
+++ b/collects/drscheme/private/frame.ss
@@ -0,0 +1,512 @@
+
+(module frame mzscheme
+  (require (lib "name-message.ss" "mrlib")
+           (lib "string-constant.ss" "string-constants")
+           (lib "unitsig.ss")
+           (lib "class.ss")
+           (lib "string.ss")
+           (lib "list.ss")
+           "drsig.ss"
+           (lib "check-gui.ss" "version")
+           (lib "mred.ss" "mred")
+           (lib "framework.ss" "framework")
+           (lib "url.ss" "net")
+           (lib "head.ss" "net")
+           (lib "plt-installer.ss" "setup")
+           (lib "bug-report.ss" "help")
+           (prefix mzlib:file: (lib "file.ss")) (lib "file.ss")
+           (prefix mzlib:list: (lib "list.ss")))
+  
+  (provide frame@)
+  (define frame@
+    (unit/sig drscheme:frame^
+      (import [drscheme:unit : drscheme:unit^]
+              [drscheme:app : drscheme:app^]
+              [help : drscheme:help-desk^]
+              [drscheme:multi-file-search : drscheme:multi-file-search^]
+              [drscheme:init : drscheme:init^])
+      
+      (rename [-mixin mixin])
+      
+      (define basics<%> (interface (frame:standard-menus<%>)))
+      
+      (define basics-mixin
+        (mixin (frame:standard-menus<%>) (basics<%>)
+          (inherit get-edit-target-window get-edit-target-object get-menu-bar)
+          [define/private get-menu-bindings
+            (λ ()
+              (let ([name-ht (make-hash-table)])
+                (let loop ([menu-container (get-menu-bar)])
+                  (for-each
+                   (λ (item)
+                     (when (is-a? item selectable-menu-item<%>)
+                       (let ([short-cut (send item get-shortcut)])
+                         (when short-cut
+                           (let ([keyname
+                                  (string->symbol
+                                   (keymap:canonicalize-keybinding-string
+                                    (string-append
+                                     (case (system-type)
+                                       [(windows) "c:"]
+                                       [(macosx macos) "d:"]
+                                       [(unix)
+                                        (case (send item get-x-shortcut-prefix)
+                                          [(meta) "m:"]
+                                          [(alt) "a:"]
+                                          [(ctl) "c:"]
+                                          [(ctl-m) "c:m;"])]
+                                       [else ""])
+                                     (case short-cut
+                                       [(#\;) "semicolon"]
+                                       [(#\:) "colon"]
+                                       [(#\space) "space"]
+                                       [else (string short-cut)]))))])
+                             (hash-table-put! name-ht keyname (send item get-plain-label))))))
+                     (when (is-a? item menu-item-container<%>)
+                       (loop item)))
+                   (send menu-container get-items)))
+                name-ht))]
+          
+          [define/private copy-hash-table
+            (λ (ht)
+              (let ([res (make-hash-table)])
+                (hash-table-for-each
+                 ht
+                 (λ (x y) (hash-table-put! res x y)))
+                res))]
+          [define/private can-show-keybindings?
+            (λ ()
+              (let ([edit-object (get-edit-target-object)])
+                (and edit-object
+                     (is-a? edit-object editor<%>)
+                     (let ([keymap (send edit-object get-keymap)])
+                       (is-a? keymap keymap:aug-keymap<%>)))))]
+          
+          [define/private show-keybindings
+            (λ ()
+              (if (can-show-keybindings?)
+                  (let ([edit-object (get-edit-target-object)])
+                    (let ([keymap (send edit-object get-keymap)])
+                      (let*-values ([(menu-names) (get-menu-bindings)])
+                        (let* ([table (send keymap get-map-function-table)]
+                               [bindings (hash-table-map table list)]
+                               [w/menus 
+                                (append (hash-table-map menu-names list)
+                                        (filter (λ (binding) (not (bound-by-menu? binding menu-names)))
+                                                bindings))]
+                               [structured-list
+                                (mzlib:list:quicksort
+                                 w/menus
+                                 (λ (x y) (string-ci<=? (cadr x) (cadr y))))])
+                          (show-keybindings-to-user structured-list this)))))
+                  (bell)))]
+          
+          (define/private (bound-by-menu? binding menu-table)
+            (ormap (λ (constituent)
+                     (hash-table-get menu-table (string->symbol constituent) (λ () #f)))
+                   (regexp-split #rx";" (symbol->string (car binding)))))
+          
+          (define/override (help-menu:before-about help-menu)
+            (make-help-desk-menu-item help-menu)
+            '(make-object menu-item%
+               (format (string-constant welcome-to-something)
+                       (string-constant drscheme))
+               help-menu
+               (λ (item evt)
+                 (drscheme:app:invite-tour))))
+          
+          (define/override (help-menu:about-callback item evt) (drscheme:app:about-drscheme))
+          (define/override (help-menu:about-string) (string-constant about-drscheme))
+          (define/override (help-menu:create-about?) #t)
+          
+          (define/public (get-additional-important-urls) '())
+          (define/override (help-menu:after-about menu)
+            (instantiate menu-item% ()
+              (label (string-constant help-menu-check-for-updates))
+              (parent menu)
+              (callback (λ (item evt) (check-version this))))
+            (drscheme:app:add-important-urls-to-help-menu
+             menu 
+             (get-additional-important-urls))
+            (new menu-item%
+                 (label (string-constant bug-report-submit-menu-item))
+                 (parent menu)
+                 (callback
+                  (λ (x y)
+                    (help-desk:report-bug))))
+            
+            (drscheme:app:add-language-items-to-help-menu menu))
+          
+          (define/override (file-menu:open-callback item evt) (handler:open-file))
+          (define/override (file-menu:new-string) (string-constant new-menu-item))
+          (define/override (file-menu:open-string) (string-constant open-menu-item))
+
+          (define/override (file-menu:between-open-and-revert file-menu) 
+            (make-object menu-item% 
+              (string-constant install-plt-file-menu-item...)
+              file-menu
+              (λ (item evt)
+                (install-plt-file this)))
+            (super file-menu:between-open-and-revert file-menu))
+          
+          (define/override (file-menu:between-print-and-close menu)
+            (super file-menu:between-print-and-close menu)
+            (instantiate menu-item% ()
+              (label (string-constant mfs-multi-file-search-menu-item))
+              (parent menu)
+              (callback
+               (λ (_1 _2)
+                 (drscheme:multi-file-search:multi-file-search))))
+            (new separator-menu-item% (parent menu)))
+          
+          (define/override (edit-menu:between-find-and-preferences menu)
+            (make-object separator-menu-item% menu)
+            (let ([keybindings-on-demand
+                   (λ (menu-item)
+                     (let ([last-edit-object (get-edit-target-window)])
+                       (send menu-item enable (can-show-keybindings?))))])
+              (instantiate menu% ()
+                (label (string-constant keybindings-menu-item))
+                (parent menu)
+                (demand-callback
+                 (λ (keybindings-menu)
+                   (for-each (λ (old) (send old delete)) 
+                             (send keybindings-menu get-items))
+                   (new menu-item%
+                        (parent keybindings-menu)
+                        (label (string-constant keybindings-show-active))
+                        (callback (λ (x y) (show-keybindings)))
+                        (help-string (string-constant keybindings-info))
+                        (demand-callback keybindings-on-demand))
+                   (new menu-item%
+                        (parent keybindings-menu)
+                        (label (string-constant keybindings-add-user-defined-keybindings))
+                        (callback
+                         (λ (x y) 
+                           (let ([filename (finder:get-file #f
+                                                            (string-constant keybindings-choose-user-defined-file)
+                                                            #f "" this)])
+                             (when filename
+                               (add-keybindings-file filename))))))
+                   (let ([ud (preferences:get 'drscheme:user-defined-keybindings)])
+                     (unless (null? ud)
+                       (new separator-menu-item% (parent keybindings-menu))
+                       (for-each (λ (path)
+                                   (new menu-item%
+                                        (label (format (string-constant keybindings-menu-remove)
+                                                       (path->string path)))
+                                        (parent keybindings-menu)
+                                        (callback
+                                         (λ (x y) (remove-keybindings-file path)))))
+                                 ud)))))))
+            (unless (current-eventspace-has-standard-menus?)
+              (make-object separator-menu-item% menu)))
+          
+          (super-new)))
+
+      (define (add-keybindings-file path)
+        (with-handlers ([exn? (λ (x)
+                                (message-box (string-constant drscheme)
+                                             (exn-message x)))])
+          (keymap:add-user-keybindings-file path)
+          (preferences:set 'drscheme:user-defined-keybindings
+                           (cons path
+                                 (preferences:get 'drscheme:user-defined-keybindings)))))
+      (define (remove-keybindings-file path)
+        (keymap:remove-user-keybindings-file path)
+        (preferences:set
+         'drscheme:user-defined-keybindings
+         (remq path
+               (preferences:get 'drscheme:user-defined-keybindings))))
+      
+      ;; install-plt-file : (union #f dialog% frame%) -> void
+      ;; asks the user for a .plt file, either from the web or from
+      ;; a file on the disk and installs it.
+      (define (install-plt-file parent)
+        (define dialog
+          (instantiate dialog% ()
+            (parent parent)
+            (alignment '(left center))
+            (label (string-constant install-plt-file-dialog-title))))
+        (define tab-panel
+          (instantiate tab-panel% ()
+            (parent dialog)
+            (callback (λ (x y) (update-panels)))
+            (choices (list (string-constant install-plt-web-tab)
+                           (string-constant install-plt-file-tab)))))
+        (define outer-swapping-panel (instantiate horizontal-panel% ()
+                                       (parent tab-panel)
+                                       (stretchable-height #f)))
+        (define spacing-panel (instantiate horizontal-panel% ()
+                                (stretchable-width #f)
+                                (parent outer-swapping-panel)
+                                (min-width 20)))
+        (define swapping-panel (instantiate panel:single% ()
+                                 (parent outer-swapping-panel)
+                                 (alignment '(left center))
+                                 (stretchable-width #t)
+                                 (stretchable-height #f)))
+        (define file-panel (instantiate horizontal-panel% ()
+                             (parent swapping-panel)
+                             (stretchable-width #t)
+                             (stretchable-height #f)))
+        (define url-panel (instantiate horizontal-panel% ()
+                            (parent swapping-panel)
+                            (stretchable-height #f)))
+        (define button-panel (instantiate horizontal-panel% ()
+                               (parent dialog)
+                               (stretchable-height #f)
+                               (alignment '(right center))))
+        (define file-text-field (instantiate text-field% ()
+                                  (parent file-panel)
+                                  (callback void)
+                                  (min-width 300)
+                                  (stretchable-width #t)
+                                  (label (string-constant install-plt-filename))))
+        (define file-button (instantiate button% ()
+                              (parent file-panel)
+                              (label (string-constant browse...))
+                              (callback (λ (x y) (browse)))))
+        (define url-text-field (instantiate text-field% ()
+                                 (parent url-panel)
+                                 (label (string-constant install-plt-url))
+                                 (min-width 300)
+                                 (stretchable-width #t)
+                                 (callback void)))
+        
+        (define-values (ok-button cancel-button)
+          (gui-utils:ok/cancel-buttons
+           button-panel
+           (λ (x y)
+             (set! cancel? #f)
+             (send dialog show #f))
+           (λ (x y)
+             (send dialog show #f))))
+        
+        ;; browse : -> void
+        ;; gets the name of a file from the user and
+        ;; updates file-text-field
+        (define (browse)
+          (let ([filename (get-file #f dialog)])
+            (when filename
+              (send file-text-field set-value (path->string filename)))))
+        
+        ;; from-web? : -> boolean
+        ;; returns #t if the user has selected a web address
+        (define (from-web?)
+          (zero? (send tab-panel get-selection)))
+        
+        (define cancel? #t)
+        
+        (define (update-panels)
+          (send swapping-panel active-child
+                (if (from-web?)
+                    url-panel
+                    file-panel)))
+        
+        (update-panels)
+        (send dialog show #t)
+        
+        (cond
+          [cancel? (void)]
+          [(from-web?)
+           (install-plt-from-url (send url-text-field get-value) parent)]
+          [else 
+           (parameterize ([error-display-handler drscheme:init:original-error-display-handler])
+             (run-installer (string->path (send file-text-field get-value))))]))
+
+      ;; install-plt-from-url : string (union #f dialog%) -> void
+      ;; downloads and installs a .plt file from the given url
+      (define (install-plt-from-url s-url parent)
+        (with-handlers ([(λ (x) #f)
+                         (λ (exn)
+                           (message-box (string-constant drscheme)
+                                        (if (exn? exn)
+                                            (format "~a" (exn-message exn))
+                                            (format "~s" exn))))])
+          (let* ([url (string->url s-url)]
+                 [tmp-filename (make-temporary-file "tmp~a.plt")]
+                 [port (get-impure-port url)]
+                 [header (purify-port port)]
+                 [size (let* ([content-header (extract-field "content-length" header)]
+                              [m (and content-header
+                                      (regexp-match "[0-9]+" content-header))])
+                         (and m (string->number (car m))))]
+                 [d (make-object dialog% (string-constant downloading) parent)] 
+                 [message (make-object message% (string-constant downloading-file...) d)] 
+                 [gauge (if size 
+                            (make-object gauge% #f 100 d) 
+                            #f)] 
+                 [exn #f] 
+                 ; Semaphores to avoid race conditions: 
+                 [wait-to-start (make-semaphore 0)] 
+                 [wait-to-break (make-semaphore 0)] 
+                 ; Thread to perform the download: 
+                 [t (thread 
+                     (λ () 
+                       (semaphore-wait wait-to-start) 
+                       (with-handlers ([exn:fail?
+                                        (λ (x) 
+                                          (set! exn x))] 
+                                       [exn:break? ; throw away break exceptions 
+                                        void])
+                         (semaphore-post wait-to-break) 
+                         (with-output-to-file tmp-filename 
+                           (λ () 
+                             (let loop ([total 0]) 
+                               (when gauge 
+                                 (send gauge set-value  
+                                       (inexact->exact 
+                                        (floor (* 100 (/ total size)))))) 
+                               (let ([s (read-string 1024 port)]) 
+                                 (unless (eof-object? s) 
+                                   (unless (eof-object? s) 
+                                     (display s) 
+                                     (loop (+ total (string-length s))))))))
+                           'binary 'truncate))
+                       (send d show #f)))]) 
+            (send d center) 
+            (make-object button% (string-constant &stop)
+			 d
+			 (λ (b e) 
+			   (semaphore-wait wait-to-break) 
+			   (set! tmp-filename #f) 
+			   (send d show #f) 
+			   (break-thread t))) 
+            ; Let thread run only after the dialog is shown 
+            (queue-callback (λ () (semaphore-post wait-to-start))) 
+            (send d show #t) 
+            (when exn (raise exn))
+            (parameterize ([error-display-handler drscheme:init:original-error-display-handler])
+              (run-installer tmp-filename
+                             (λ ()
+                               (delete-file tmp-filename)))))))
+      
+      
+      (define keybindings-dialog%
+        (class dialog%
+          (override on-size)
+          [define on-size
+            (lambda (w h)
+              (preferences:set 'drscheme:keybindings-window-size (cons w h))
+              (super on-size w h))]
+          (super-instantiate ())))
+      
+      (define (show-keybindings-to-user bindings frame)
+        (letrec ([f (instantiate keybindings-dialog% ()
+                      (label (string-constant keybindings-frame-title))
+                      (parent frame)
+                      (width (car (preferences:get 'drscheme:keybindings-window-size)))
+                      (height (cdr (preferences:get 'drscheme:keybindings-window-size)))
+                      (style '(resize-border)))]
+                 [bp (make-object horizontal-panel% f)]
+                 [b-name (make-object button% (string-constant keybindings-sort-by-name)
+                           bp (λ x (update-bindings #f)))]
+                 [b-key (make-object button% (string-constant keybindings-sort-by-key)
+                          bp (λ x (update-bindings #t)))]
+                 [lb
+                  (make-object list-box% #f null f void)]
+                 [bp2 (make-object horizontal-panel% f)]
+                 [cancel (make-object button% (string-constant close)
+                           bp2 (λ x (send f show #f)))]
+                 [space (make-object grow-box-spacer-pane% bp2)]
+                 [update-bindings
+                  (λ (by-key?)
+                    (let ([format-binding/name
+                           (λ (b) (format "~a (~a)" (cadr b) (car b)))]
+                          [format-binding/key
+                           (λ (b) (format "~a (~a)" (car b) (cadr b)))]
+                          [predicate/key
+                           (λ (a b) (string-ci<=? (format "~a" (car a))
+                                                       (format "~a" (car b))))]
+                          [predicate/name
+                           (λ (a b) (string-ci<=? (cadr a) (cadr b)))])
+                      (send lb set
+                            (if by-key?
+                                (map format-binding/key (mzlib:list:quicksort bindings predicate/key))
+                                (map format-binding/name (mzlib:list:quicksort bindings predicate/name))))))])
+          (send bp stretchable-height #f)
+          (send bp set-alignment 'center 'center)
+          (send bp2 stretchable-height #f)
+          (send bp2 set-alignment 'right 'center)
+          (update-bindings #f)
+          (send f show #t)))
+      
+      (define <%>
+        (interface (frame:editor<%> basics<%> frame:text-info<%>)
+          get-show-menu
+          update-shown
+          add-show-menu-items))
+      
+      (define -mixin
+        (mixin (frame:editor<%> frame:text-info<%> basics<%>) (<%>)
+          (inherit get-editor get-menu% get-menu-bar)
+          (define show-menu #f)
+          (define/public get-show-menu (λ () show-menu))
+          (define/public update-shown (λ () (void)))
+          (define/public (add-show-menu-items show-menu) (void))
+          (super-new)
+          (set! show-menu (make-object (get-menu%) (string-constant view-menu-label)
+                            (get-menu-bar)))
+          (add-show-menu-items show-menu)))
+      
+      
+      (define (create-root-menubar)
+        (let* ([mb (new menu-bar% (parent 'root))]
+               [file-menu (new menu% 
+                               (label (string-constant file-menu))
+                               (parent mb))]
+               [help-menu (new menu% 
+                               (label (string-constant help-menu))
+                               (parent mb))])
+          (new menu-item%
+               (label (string-constant new-menu-item))
+               (parent file-menu)
+               (shortcut #\n)
+               (callback
+                (λ (x y)
+                  (handler:edit-file #f)
+                  #t)))
+	  (new menu-item%
+               (label (string-constant open-menu-item))
+               (parent file-menu)
+               (shortcut #\o)
+               (callback
+                (λ (x y)
+                  (handler:open-file)
+                  #t)))
+          (new menu%
+               (label (string-constant open-recent-menu-item))
+               (parent file-menu)
+               (demand-callback
+                (λ (menu)
+                  (handler:install-recent-items menu))))
+	  (instantiate menu-item% ()
+            (label (string-constant mfs-multi-file-search-menu-item))
+            (parent file-menu)
+            (callback
+             (λ (_1 _2)
+               (drscheme:multi-file-search:multi-file-search))))
+          (unless (current-eventspace-has-standard-menus?)
+	    (new separator-menu-item% (parent file-menu))
+	    (new menu-item%
+                 (label (string-constant quit-menu-item-others))
+                 (parent file-menu)
+                 (shortcut #\q)
+                 (callback
+                  (λ (x y)
+                    (when (exit:user-oks-exit)
+                      (exit:exit))
+                    #t))))
+          (make-help-desk-menu-item help-menu)))
+      
+      (define (make-help-desk-menu-item help-menu)
+        (make-object menu-item%
+          (string-constant help-desk)
+          help-menu
+          (λ (item evt)
+            (help:help-desk)
+            #t)))
+      
+      
+      )))
diff --git a/collects/drscheme/private/get-extend.ss b/collects/drscheme/private/get-extend.ss
new file mode 100644
index 0000000000..36ddd14a9b
--- /dev/null
+++ b/collects/drscheme/private/get-extend.ss
@@ -0,0 +1,90 @@
+
+(module get-extend mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "class.ss")
+           "drsig.ss"
+	   (lib "mred.ss" "mred")
+           (lib "etc.ss"))
+  
+  (provide get-extend@)
+  
+  (define get-extend@
+    (unit/sig drscheme:get/extend^
+
+      (import [drscheme:unit : drscheme:unit^]
+	      [drscheme:frame : drscheme:frame^]
+	      [drscheme:rep : drscheme:rep^]
+              [drscheme:debug : drscheme:debug^])
+      
+      (define make-extender
+        (λ (get-base% name)
+          (let ([extensions (λ (x) x)]
+                [built-yet? #f]
+                [built #f]
+                [verify
+                 (λ (f)
+                   (λ (%)
+                     (let ([new% (f %)])
+                       (if (and (class? new%)
+                                (subclass? new% %))
+                           new%
+                           (error 'extend-% "expected output of extension to create a subclass of its input, got: ~a"
+                                  new%)))))])
+            (values
+             (rec add-extender
+               (case-lambda
+                [(extension) (add-extender extension #t)]
+                [(extension before?)
+                 (when built-yet?
+                   (error 'extender "cannot build a new extension of ~a after initialization"
+                          name))
+                 (set! extensions 
+                       (if before?
+                           (compose (verify extension) extensions)
+                           (compose extensions (verify extension))))]))
+             (λ ()
+               (unless built-yet?
+                 (set! built-yet? #t)
+                 (set! built (extensions (get-base%))))
+               built)))))
+      
+      (define (get-base-tab%)
+        (drscheme:debug:test-coverage-tab-mixin
+         (drscheme:debug:profile-tab-mixin
+          drscheme:unit:tab%)))
+      
+      (define-values (extend-tab get-tab) (make-extender get-base-tab% 'tab%))
+
+      (define (get-base-interactions-canvas%)
+        drscheme:unit:interactions-canvas%)
+      
+      (define-values (extend-interactions-canvas get-interactions-canvas)
+        (make-extender get-base-interactions-canvas% 'interactions-canvas%))
+
+      (define (get-base-definitions-canvas%)
+        drscheme:unit:definitions-canvas%)
+      
+      (define-values (extend-definitions-canvas get-definitions-canvas)
+        (make-extender get-base-definitions-canvas% 'definitions-canvas%))  
+      
+      (define (get-base-unit-frame%) 
+        (drscheme:debug:profile-unit-frame-mixin
+         drscheme:unit:frame%))
+
+      (define-values (extend-unit-frame get-unit-frame)
+        (make-extender get-base-unit-frame% 'drscheme:unit:frame))
+      
+      (define (get-base-interactions-text%)
+        (drscheme:debug:test-coverage-interactions-text-mixin
+         drscheme:rep:text%))
+
+      (define-values (extend-interactions-text get-interactions-text)
+        (make-extender get-base-interactions-text% 'interactions-text%))
+
+      (define (get-base-definitions-text%)
+        (drscheme:debug:test-coverage-definitions-text-mixin
+         (drscheme:debug:profile-definitions-text-mixin
+          (drscheme:unit:get-definitions-text%))))
+
+      (define-values (extend-definitions-text get-definitions-text)
+        (make-extender get-base-definitions-text% 'definitions-text%)))))
diff --git a/collects/drscheme/private/help-desk.ss b/collects/drscheme/private/help-desk.ss
new file mode 100644
index 0000000000..d42219fffc
--- /dev/null
+++ b/collects/drscheme/private/help-desk.ss
@@ -0,0 +1,190 @@
+
+(module help-desk mzscheme
+  (require (lib "unitsig.ss")
+           (lib "string-constant.ss" "string-constants")
+           (lib "mred.ss" "mred")
+           (lib "external.ss" "browser")
+           (lib "help-desk.ss" "help")
+           (lib "framework.ss" "framework")
+           (lib "class.ss")
+           (lib "list.ss")
+           "drsig.ss")
+  
+  (provide help-desk@)
+  
+  (define help-desk@
+    (unit/sig drscheme:help-desk^
+      (import [drscheme:frame : drscheme:frame^]
+              [drscheme:language-configuration : drscheme:language-configuration/internal^]
+              [drscheme:teachpack : drscheme:teachpack^])
+      
+      ;; : -> string
+      (define (get-computer-language-info)
+        (let* ([language/settings (preferences:get 
+                                   drscheme:language-configuration:settings-preferences-symbol)]
+               [language (drscheme:language-configuration:language-settings-language
+                          language/settings)]
+               [settings (drscheme:language-configuration:language-settings-settings
+                          language/settings)])
+          (format
+           "~s"
+           (list
+            (send language get-language-position)
+            (send language marshall-settings settings)))))
+      
+      ;; get-docs : (listof (cons path[short-dir-name] string[doc full name]))
+      (define (get-docs) 
+        (let ([dirs (find-doc-names)])
+          (map (λ (pr)
+                 (let-values ([(base name dir?) (split-path (car pr))])
+                   (cons name (cdr pr))))
+               dirs)))
+      
+      (define (get-teachpack-filenames)
+        (format "~s"
+                (drscheme:teachpack:teachpack-cache-filenames
+                 (preferences:get 'drscheme:teachpacks))))
+      
+      (set-bug-report-info! "Computer Language" get-computer-language-info)
+      (set-bug-report-info! "Teachpack filenames" get-teachpack-filenames)
+      
+      (define drscheme-help-desk-mixin
+        (mixin (help-desk-frame<%> frame:standard-menus<%>) ()
+          (define/override (file-menu:create-open-recent?) #t)
+          
+          (define/override (file-menu:new-callback x y)
+            (handler:edit-file #f)
+            #t)
+          (define/override (file-menu:between-save-as-and-print menu)
+            (new separator-menu-item% (parent menu)))
+          
+          (define current-language 
+            (preferences:get drscheme:language-configuration:settings-preferences-symbol))
+          (define/public (set-current-language cl)
+            (set! current-language cl))
+          
+          (define/override (order-manuals x)
+            (send (drscheme:language-configuration:language-settings-language current-language)
+                  order-manuals
+                  x))
+          (define/override (get-language-name)
+            (send (drscheme:language-configuration:language-settings-language current-language)
+                  get-language-name))
+          
+          (define/override (file-menu:between-new-and-open file-menu)
+            (instantiate menu:can-restore-menu-item% ()
+              (label (string-constant plt:hd:new-help-desk))
+              (parent file-menu)
+              (callback (λ (x y) (new-help-desk))))
+            (super file-menu:between-new-and-open file-menu))
+          
+          (super-new)
+          
+          (inherit get-menu-bar)
+          (inherit-field choices-panel)
+          (letrec ([language-menu (new menu% 
+                                       (parent (get-menu-bar))
+                                       (label (string-constant language-menu-name)))]
+                   [change-language-callback
+                    (λ ()
+                      (let ([new-settings (drscheme:language-configuration:language-dialog
+                                           #f
+                                           current-language
+                                           this 
+                                           #t)])
+                        (when new-settings
+                          (set! current-language new-settings)
+                          (send lang-message set-msg (get-language-name))
+                          (preferences:set
+                           drscheme:language-configuration:settings-preferences-symbol
+                           new-settings))))]
+                   [lang-message
+                    (new lang-message% 
+                         (button-release (λ () (change-language-callback)))
+                         (parent choices-panel)
+                         (font normal-control-font))]
+                   [language-item (new menu-item%
+                                       (label (string-constant choose-language-menu-item-label))
+                                       (parent language-menu)
+                                       (shortcut #\l)
+                                       (callback
+                                        (λ (x y)
+                                          (change-language-callback))))])
+            (frame:reorder-menus this)
+            (send lang-message set-msg (get-language-name))
+            
+            ;; move the grow box spacer pane to the end
+            (send choices-panel change-children
+                  (λ (l)
+                    (append
+                     (filter (λ (x) (not (is-a? x grow-box-spacer-pane%))) l)
+                     (list (car (filter (λ (x) (is-a? x grow-box-spacer-pane%)) l)))))))))
+      
+      (define lang-message%
+        (class canvas%
+          (init-field button-release font)
+          (define/override (on-event evt)
+            (when (send evt button-up?)
+              (button-release)))
+          (field [msg ""])
+          (define/public (set-msg l) (set! msg l) (on-paint))
+          (inherit get-dc get-client-size)
+          (define/override (on-paint)
+            (let ([dc (get-dc)]
+                  [dots "..."])
+              (let-values ([(tw th _1 _2) (send dc get-text-extent msg)]
+                           [(dw dh _3 _4) (send dc get-text-extent dots)]
+                           [(cw ch) (get-client-size)])
+                (send dc set-brush (send the-brush-list find-or-create-brush (get-panel-background) 'panel))
+                (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent))
+                (send dc set-font font)
+                (send dc draw-rectangle 0 0 cw ch)
+                (cond
+                  [(tw . <= . cw)
+                   (send dc draw-text msg 0 (- (/ ch 2) (/ th 2)))]
+                  [(cw . <= . dw)  ;; just give up if there's not enough room to draw the dots
+                   (void)]
+                  [else
+                   (send dc set-clipping-rect 0 0 (- cw dw 2) ch)
+                   (send dc draw-text msg 0 (- (/ ch 2) (/ th 2)))
+                   (send dc set-clipping-region #f)
+                   (send dc draw-text dots (- cw dw) (- (/ ch 2) (/ th 2)))]))))
+          (super-new)))
+      
+      (define (goto-help manual link) (goto-manual-link manual link))
+      (define (goto-tour) (goto-hd-location 'hd-tour))
+      (define (goto-release-notes) (goto-hd-location 'release-notes))
+      (define (goto-plt-license) (goto-hd-location 'plt-license))
+
+      (define help-desk
+        (case-lambda
+          [() (show-help-desk)]
+          [(key) (help-desk key #f)]
+          [(key lucky?) (help-desk key lucky? 'keyword+index)]
+          [(key lucky? type) (help-desk key lucky? type 'contains)]
+          [(key lucky? type mode) (help-desk key lucky? type mode #f)]
+          [(key lucky? type mode language)
+           (let ([frame (or (find-help-desk-frame)
+                            (new-help-desk))])
+             (when language 
+               (send frame set-current-language language))
+             (search-for-docs/in-frame
+              frame
+              key
+              (case type
+                [(keyword) "keyword"]
+                [(keyword+index) "keyword-index"]
+                [(keyword+index+text) "keyword-index-text"]
+                [else (error 'drscheme:help-desk:help-desk "unknown type argument: ~s" type)])
+              (case mode
+                [(exact) "exact-match"]
+                [(contains) "containing-match"]
+                [(regexp) "regexp-match"]
+                [else (error 'drscheme:help-desk:help-desk "unknown mode argument: ~s" mode)])
+              lucky?
+              (map car (get-docs))))]))
+      
+      ;; open-url : string -> void
+      (define (open-url x) (send-url x))
+      
+      (add-help-desk-mixin drscheme-help-desk-mixin))))
\ No newline at end of file
diff --git a/collects/drscheme/private/info.ss b/collects/drscheme/private/info.ss
new file mode 100644
index 0000000000..9bc1fd32e3
--- /dev/null
+++ b/collects/drscheme/private/info.ss
@@ -0,0 +1,5 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "DrScheme private"))
+
+
+  
diff --git a/collects/drscheme/private/init.ss b/collects/drscheme/private/init.ss
new file mode 100644
index 0000000000..339a1944c4
--- /dev/null
+++ b/collects/drscheme/private/init.ss
@@ -0,0 +1,56 @@
+
+(module init mzscheme
+  (require (lib "string-constant.ss" "string-constants")
+           (lib "unitsig.ss")
+           "drsig.ss"
+           (lib "list.ss")
+	   (lib "mred.ss" "mred"))
+  
+  (provide init@)
+  
+  (define init@
+    (unit/sig drscheme:init^
+      (import)
+      
+      (define original-output-port (current-output-port))
+      (define original-error-port (current-error-port))
+      
+      (define primitive-eval (current-eval))
+      (define primitive-load (current-load))
+      
+      (define system-custodian (current-custodian))
+      (define system-eventspace (current-eventspace))
+      (define system-thread (current-thread))
+      (define system-namespace (current-namespace))
+      (define first-dir (current-directory))
+      
+      (define original-error-display-handler (error-display-handler))
+      
+      (define error-display-handler-message-box-title
+        (make-parameter (string-constant drscheme-internal-error)))
+      
+      ;; override error-display-handler to duplicate the error
+      ;; message in both the standard place (as defined by the
+      ;; current error-display-handler) and in a message box
+      ;; identifying the error as a drscheme internal error.
+      (error-display-handler
+       (λ (msg exn)
+         
+         ;; this  may raise an exception if the port is gone.
+         (with-handlers ([exn:fail? (λ (x) (void))])
+           (original-error-display-handler msg exn))
+         
+         (let ([title (error-display-handler-message-box-title)])
+           (let ([text (let ([p (open-output-string)])
+                         (parameterize ([current-error-port p]
+                                        [current-output-port p])
+                           (original-error-display-handler msg exn))
+                         (get-output-string p))])
+             
+             (if (eq? (current-eventspace) system-eventspace)
+                 (message-box title text #f '(stop ok))
+                 (parameterize ([current-eventspace system-eventspace]
+                                [current-custodian system-custodian])
+                   (queue-callback
+                    (λ ()
+                      (message-box title text #f '(stop ok)))))))))))))
diff --git a/collects/drscheme/private/key.ss b/collects/drscheme/private/key.ss
new file mode 100644
index 0000000000..2aedf9a5c9
--- /dev/null
+++ b/collects/drscheme/private/key.ss
@@ -0,0 +1,19 @@
+(module key mzscheme
+  (provide break-threads)
+  (define super-cust (current-custodian))
+  (define first-child (make-custodian))
+  (current-custodian first-child)
+  
+  
+  (define (break-threads)
+    (parameterize ([current-custodian super-cust])
+      (thread
+       (λ ()
+         (let loop ([super-cust super-cust]
+                    [current-cust first-child])
+           (for-each (λ (man)
+                       (when (thread? man)
+                         (break-thread man))
+                       (when (custodian? man)
+                         (loop current-cust man)))
+                     (custodian-managed-list current-cust super-cust))))))))
diff --git a/collects/drscheme/private/label-frame-mred.ss b/collects/drscheme/private/label-frame-mred.ss
new file mode 100644
index 0000000000..e97b0da122
--- /dev/null
+++ b/collects/drscheme/private/label-frame-mred.ss
@@ -0,0 +1,28 @@
+(module label-frame-mred mzscheme
+  (require (lib "mred.ss" "mred")
+           (lib "class.ss"))
+  (provide (all-from-except (lib "mred.ss" "mred") frame%)
+           (rename registering-frame% frame%)
+           lookup-frame-name)
+
+  (define (lookup-frame-name frame)
+    (semaphore-wait label-sema)
+    (begin0
+      (hash-table-get label-ht frame (λ () #f))
+      (semaphore-post label-sema)))
+  
+  (define label-sema (make-semaphore 1))
+  (define label-ht (make-hash-table 'weak))
+  
+  (define registering-frame%
+    (class frame%
+      (define/override (set-label x)
+        (semaphore-wait label-sema)
+        (hash-table-put! label-ht this x)
+        (semaphore-post label-sema)
+        (super set-label x))
+      (inherit get-label)
+      (super-instantiate ())
+      (semaphore-wait label-sema)
+      (hash-table-put! label-ht this (get-label))
+      (semaphore-post label-sema))))
diff --git a/collects/drscheme/private/language-configuration.ss b/collects/drscheme/private/language-configuration.ss
new file mode 100644
index 0000000000..69146ecf8e
--- /dev/null
+++ b/collects/drscheme/private/language-configuration.ss
@@ -0,0 +1,1331 @@
+
+(module language-configuration mzscheme
+  (require (lib "unitsig.ss")
+           (lib "hierlist.ss" "hierlist")
+           (lib "class.ss")
+	   (lib "contract.ss")
+           "drsig.ss"
+           (lib "string-constant.ss" "string-constants")
+	   (lib "mred.ss" "mred")
+           (lib "framework.ss" "framework")
+           (lib "list.ss")
+           (lib "etc.ss")
+           (lib "file.ss")
+           (lib "pconvert.ss")
+           (lib "getinfo.ss" "setup")
+           (lib "toplevel.ss" "syntax"))
+  
+  (define original-output (current-output-port))
+  (define (printfo . args) (apply fprintf original-output args))
+  
+  (provide language-configuration@)
+  
+  (define language-configuration@
+    (unit/sig drscheme:language-configuration/internal^
+      (import [drscheme:unit : drscheme:unit^]
+              [drscheme:rep : drscheme:rep^]
+              [drscheme:teachpack : drscheme:teachpack^]
+              [drscheme:init : drscheme:init^]
+              [drscheme:language : drscheme:language^]
+              [drscheme:app : drscheme:app^]
+              [drscheme:tools : drscheme:tools^]
+              [drscheme:help-desk : drscheme:help-desk^])
+      
+      ;; settings-preferences-symbol : symbol
+      ;; the preferences key for the language settings.
+      ;; depends on the version number, so people can use multiple versions
+      ;; of drscheme and maintain separate language settings for each
+      ;; of them.
+      (define settings-preferences-symbol 
+        (string->symbol (format "drscheme:~a-settings" (version:version))))
+      
+      ;; get-settings-preferences-symbol : -> symbol
+      (define (get-settings-preferences-symbol) settings-preferences-symbol)
+
+      ;; default-language-position : (listof string)
+      ;; if a language is registered with this position, it is
+      ;; considered the default language
+      (define default-language-position
+        (list (string-constant teaching-languages)
+              (string-constant how-to-design-programs)
+              (string-constant beginning-student)))
+
+      ;; languages : (listof (instanceof language<%>))
+      ;; all of the languages supported in DrScheme
+      (define languages null)
+
+      ;; add-language : (instanceof language%) -> void
+      ;; only allows addition on phase2
+      ;; effect: updates `languages'
+      (define add-language
+        (opt-lambda (language [front? #f])
+          
+          (drscheme:tools:only-in-phase 'drscheme:language:add-language 'phase2)
+          (for-each
+           (λ (i<%>)
+             (unless (is-a? language i<%>)
+               (error 'drscheme:language:add-language "expected language ~e to implement ~e, forgot to use drscheme:language:get-default-mixin ?" language i<%>)))
+           (drscheme:language:get-language-extensions))
+          
+          (set! languages 
+                (if front? 
+                    (cons language languages)
+                    (append languages (list language))))))
+      
+      ;; get-languages : -> (listof languages)
+      (define (get-languages) 
+        (drscheme:tools:only-in-phase
+         'drscheme:language-configuration:get-languages
+         'init-complete)
+        languages)
+      
+      ;; get-default-language-settings : -> language-settings
+      ;; uses `default-language-position' to find the default language.
+      ;; if that language is not available, just takes the first language.
+      ;; if there are no languages defined yet, signal an error -- drscheme is in trouble.
+      (define (get-default-language-settings)
+	(when (null? languages)
+	  (error 'get-default-language-settings "no languages registered!"))
+	(let ([lang (or (ormap (λ (x)
+				 (and (equal? (send x get-language-position)
+					      default-language-position)
+				      x))
+			       (get-languages))
+			(first (get-languages)))])
+	  (make-language-settings lang (send lang default-settings))))
+
+      ;; type language-settings = (make-language-settings (instanceof language<%>) settings)
+      (define-struct language-settings (language settings))
+       
+ 
+;                                                                                                      
+;                                                                                                      
+;                                                                                                      
+;   ;                                                                ;   ;          ;                  
+;   ;                                                                ;              ;                  
+;   ;                                                                ;              ;                  
+;   ;   ;;;    ; ;;     ;; ;   ;   ;   ;;;     ;; ;    ;;;        ;; ;   ;   ;;;    ;    ;;;     ;; ;  
+;   ;  ;   ;   ;;  ;   ;  ;;   ;   ;  ;   ;   ;  ;;   ;   ;      ;  ;;   ;  ;   ;   ;   ;   ;   ;  ;;  
+;   ;      ;   ;   ;  ;    ;   ;   ;      ;  ;    ;  ;    ;     ;    ;   ;      ;   ;  ;     ; ;    ;  
+;   ;   ;;;;   ;   ;  ;    ;   ;   ;   ;;;;  ;    ;  ;;;;;;     ;    ;   ;   ;;;;   ;  ;     ; ;    ;  
+;   ;  ;   ;   ;   ;  ;    ;   ;   ;  ;   ;  ;    ;  ;          ;    ;   ;  ;   ;   ;  ;     ; ;    ;  
+;   ;  ;   ;   ;   ;   ;  ;;   ;  ;;  ;   ;   ;  ;;   ;          ;  ;;   ;  ;   ;   ;   ;   ;   ;  ;;  
+;   ;   ;;;;;  ;   ;    ;; ;    ;; ;   ;;;;;   ;; ;    ;;;;       ;; ;   ;   ;;;;;  ;    ;;;     ;; ;  
+;                          ;                      ;                                                 ;  
+;                     ;    ;                 ;    ;                                            ;    ;  
+;                      ;;;;                   ;;;;                                              ;;;;   
+
+      
+      ;; language-dialog : (boolean language-setting -> language-setting)
+      ;;                   (boolean language-setting (union #f (instanceof top-level-window%))
+      ;;                    -> language-setting)
+      ;; allows the user to configure their language. The input language-setting is used
+      ;; as the defaults in the dialog and the output language setting is the user's choice
+      ;; todo: when button is clicked, ensure language is selected
+      (define language-dialog
+        (opt-lambda (show-welcome? language-settings-to-show [parent #f] [manuals? #f])
+          (define ret-dialog%
+            (class dialog%
+              (define/override (on-subwindow-char receiver evt)
+                (case (send evt get-key-code)
+                  [(escape) (cancel-callback)]
+                  [(#\return numpad-enter) (ok-callback)]
+                  [else (super on-subwindow-char receiver evt)]))
+              (super-instantiate ())))
+          
+	  (define dialog (instantiate ret-dialog% ()
+                           (label (if show-welcome?
+                                    (string-constant welcome-to-drscheme)
+                                    (string-constant language-dialog-title)))
+                           (parent parent)
+                           (style '(resize-border))))
+          (define welcome-before-panel (instantiate horizontal-panel% ()
+                                         (parent dialog)
+                                         (stretchable-height #f)))
+          (define language-dialog-meat-panel (make-object vertical-panel% dialog))
+
+          (define welcome-after-panel (instantiate vertical-panel% () 
+                                        (parent dialog)
+                                        (stretchable-height #f)))
+          
+          (define button-panel (instantiate horizontal-panel% ()
+                                 (parent dialog)
+                                 (stretchable-height #f)))
+          
+          (define-values (get-selected-language get-selected-language-settings)
+            (fill-language-dialog language-dialog-meat-panel 
+                                  button-panel 
+                                  language-settings-to-show 
+                                  #f
+                                  manuals?))
+          
+          ;; cancelled? : boolean
+          ;; flag that indicates if the dialog was cancelled.
+          (define cancelled? #t)
+          
+	  ;; ok-callback : -> void
+          (define (ok-callback)
+            (cond
+              [(get-selected-language)
+               (set! cancelled? #f)
+               (send dialog show #f)]
+              [else
+               (message-box (string-constant drscheme)
+                            (string-constant please-select-a-language))]))
+          
+          ;; cancel-callback : -> void
+	  (define (cancel-callback)
+            (send dialog show #f))
+
+          (define show-details-label (string-constant show-details-button-label))
+          (define hide-details-label (string-constant hide-details-button-label))
+          
+          (define button-gap (make-object horizontal-panel% button-panel))
+	  (define-values (ok-button cancel-button)
+            (gui-utils:ok/cancel-buttons
+             button-panel
+             (λ (x y) (ok-callback))
+             (λ (x y) (cancel-callback))))
+          (define grow-box-spacer (make-object grow-box-spacer-pane% button-panel))
+          
+          (when show-welcome?
+            (add-welcome dialog welcome-before-panel welcome-after-panel))
+
+          (send dialog stretchable-width #f)
+          (send dialog stretchable-height #t)
+
+          (unless parent
+            (send dialog center 'both))
+          (send dialog show #t)
+          (if cancelled?
+              language-settings-to-show
+              (make-language-settings
+               (get-selected-language)
+               (get-selected-language-settings)))))
+      
+      ;; fill-language-dialog :    (vertical-panel panel language-setting -> language-setting)
+      ;;                           (union dialog #f)
+      ;;                        -> (-> (union #f language<%>)) (-> settings[corresponding to fst thnk result])
+      ;; allows the user to configure their language. The input language-setting is used
+      ;; as the defaults in the dialog and the output language setting is the user's choice
+      ;; if re-center is a dialog, when the show details button is clicked, the dialog is recenterd.
+      (define fill-language-dialog
+        (opt-lambda (parent show-details-parent language-settings-to-show [re-center #f] [manuals? #f])
+
+	  (define language-to-show (language-settings-language language-settings-to-show))
+	  (define settings-to-show (language-settings-settings language-settings-to-show))
+          
+          ;; hier-list items that implement this interface correspond to
+	  ;; actual language selections
+	  (define hieritem-language<%>
+	    (interface (hierarchical-list-item<%>)
+	      selected))
+
+	  (define selectable-hierlist%
+            (class hierarchical-list%
+              (init parent)
+
+              (inherit get-selected)
+              (define/override (on-char evt)
+                (let ([code (send evt get-key-code)])
+                  (cond
+                    [(eq? code 'up) (select-next sub1 (λ (v) (- (vector-length v) 1)))]
+                    [(eq? code 'down) (select-next add1 (λ (v) 0))]
+                    [else (super on-char evt)])))
+              
+              (inherit get-items)
+              
+              ;; select-next : (int -> int) (vector -> int)
+              ;; finds the next leaf after the selected child,
+              ;; using `inc' and `start' to control the direction of the traversal.
+              (define/private (select-next inc start)
+                (let ([fst-selected (get-selected)])
+                  (when fst-selected
+                    (let loop ([item fst-selected])
+		      (when item
+			(let* ([parent (send item get-parent)]
+			       [siblings (list->vector 
+                                          (if parent
+                                              (send parent get-items)
+                                              (get-items)))])
+			  (let sibling-loop ([index (inc (find-index item siblings))])
+			    (cond
+			      [(and (<= 0 index)
+				    (< index (vector-length siblings)))
+			       (let ([sibling (vector-ref siblings index)])
+				 (cond
+				   [(find-first-leaf sibling inc start)
+				    =>
+				    (λ (child)
+				      (send fst-selected select #f)
+				      (send child select #t)
+				      (open-parents child)
+                                      (make-visible child))]
+				   [else (sibling-loop (inc index))]))]
+			      [else (loop parent)]))))))))
+              
+              ;; find-first-leaf : item (int -> int) (vec -> int)
+              ;; finds the first child, using `inc' and `start' to control
+              ;; the traversal over the children.
+              (define/private (find-first-leaf item inc start)
+                (let loop ([item item])
+                  (cond
+                    [(is-a? item hierarchical-list-compound-item<%>)
+                     (let ([children (list->vector (send item get-items))])
+                       (let child-loop ([i (start children)])
+                         (cond
+                           [(and (<= 0 i) (< i (vector-length children)))
+                            (or (loop (vector-ref children i))
+                                (child-loop (inc i)))]
+                           [else #f])))]
+                    [(send item get-allow-selection?)
+                     item]
+                    [else #f])))
+
+              ;; find-index : tst (vectorof tst) -> int
+              ;; returns the index of `item' in `vec'
+              (define/private (find-index item vec)
+                (let loop ([i 0])
+                  (cond
+                    [(< i (vector-length vec))
+                     (if (eq? (vector-ref vec i) item)
+                         i
+                         (loop (+ i 1)))]
+                    [else (error 'find-index "didn't find ~e in ~e" item vec)])))
+
+              ;; open-parents : item -> void
+              ;; selects the item and opens all of its parents.
+              (define/private (open-parents item)
+                (let loop ([item (send item get-parent)])
+                  (when item
+                    (send item open)
+                    (loop (send item get-parent)))))
+
+              (define/private (make-visible item)
+                (let loop ([item item])
+                  (let ([parent (send item get-parent)])
+                    (if parent
+                      (loop parent)
+                      (send item scroll-to))))
+                (send item scroll-to))
+
+              (define/override (on-select i)
+                (cond
+		  [(and i (is-a? i hieritem-language<%>))
+		   (send i selected)]
+                  [else
+		   (nothing-selected)]))
+              (define/override (on-click i)
+                (when (and i (is-a? i hierarchical-list-compound-item<%>))
+                  (send i toggle-open/closed)))
+              (super-instantiate (parent))))
+
+          (define outermost-panel (make-object horizontal-panel% parent))
+          (define languages-hier-list (make-object selectable-hierlist% outermost-panel))
+          (define details-outer-panel (make-object vertical-panel% outermost-panel))
+          (define details/manual-parent-panel (make-object vertical-panel% details-outer-panel))
+	  (define details-panel (make-object panel:single% details/manual-parent-panel))
+          (define manual-ordering-panel (new vertical-panel% (parent details/manual-parent-panel)))
+          
+          (define manual-ordering-text (new panel-background-text%))
+          (define manual-ordering-canvas (new panel-background-editor-canvas% 
+                                              (parent manual-ordering-panel)
+                                              (editor manual-ordering-text)
+                                              (style '(no-hscroll))
+                                              (min-width 300)))
+          
+          (define one-line-summary-message (instantiate message% ()
+                                             (parent parent)
+                                             (label "")
+                                             (stretchable-width #t)))
+          
+	  (define no-details-panel (make-object vertical-panel% details-panel))
+
+          (define languages-table (make-hash-table))
+          (define languages (get-languages))
+
+	  ;; selected-language : (union (instanceof language<%>) #f)
+	  ;; invariant: selected-language and get/set-selected-language-settings
+	  ;;            match the user's selection in the languages-hier-list.
+	  ;;            or #f if the user is not selecting a language.
+	  (define selected-language #f)
+	  ;; get/set-selected-language-settings (union #f (-> settings))
+	  (define get/set-selected-language-settings #f)
+
+	  ;; language-mixin : (implements language<%>) (implements area-container<%>) get/set ->
+          ;;                  ((implements hierlist<%>) -> (implements hierlist<%>))
+	  ;; a mixin that responds to language selections and updates the details-panel
+	  (define (language-mixin language language-details-panel get/set-settings)
+            (λ (%)
+              (class* % (hieritem-language<%>)
+                (init-rest args)
+                (public selected)
+                (define (selected)
+                  (send details-panel active-child language-details-panel)
+                  (send one-line-summary-message set-label (send language get-one-line-summary))
+                  (send revert-to-defaults-button enable #t)
+                  (update-manual-ordering-text language)
+                  (set! get/set-selected-language-settings get/set-settings)
+		  (set! selected-language language))
+                (apply super-make-object args))))
+
+	  ;; nothing-selected : -> void
+	  ;; updates the GUI and selected-language and get/set-selected-language-settings
+	  ;; for when no language is selected.
+	  (define (nothing-selected)
+            (send revert-to-defaults-button enable #f)
+	    (send details-panel active-child no-details-panel)
+            (send one-line-summary-message set-label "")
+	    (set! get/set-selected-language-settings #f)
+	    (set! selected-language #f))
+
+          ;; update-manual-ordering-text : -> void
+          ;; updates the manual ordering text with the order the manuals are searched for this language
+          (define (update-manual-ordering-text language)
+            (send manual-ordering-text begin-edit-sequence)
+            (send manual-ordering-text lock #f)
+            (send manual-ordering-text erase)
+            (send manual-ordering-text insert (string-constant plt:hd:manual-search-ordering))
+            (send manual-ordering-text insert "\n\n")
+            (send manual-ordering-text change-style 
+                  (make-object style-delta% 'change-bold)
+                  0
+                  (- (send manual-ordering-text last-position) 2))
+            (let ([docs (drscheme:help-desk:get-docs)]
+                  [manual-name-style-delta
+                   (make-object style-delta%)])
+              (let-values ([(ordered-bytes doc.txt?)
+                            (send language order-manuals (map path->bytes (map car docs)))])
+                (let loop ([ordered (map bytes->path ordered-bytes)]
+                           [n 1])
+                  (cond
+                    [(null? ordered) 
+                     (when doc.txt?
+                       (insert-single "doc.txt files" n))]
+                    [else 
+                     (let* ([ent (car ordered)]
+                            [full-name (assoc ent docs)])
+                       (cond
+                         [full-name
+                          (insert-single (cdr full-name) n)
+                          (loop (cdr ordered) (+ n 1))]
+                         [else
+                          (loop (cdr ordered) n)]))]))))
+            (send manual-ordering-text change-style
+                  (make-object style-delta% 'change-family 'system)
+                  0
+                  (send manual-ordering-text last-position))
+            (send manual-ordering-text set-position 0)
+            (send manual-ordering-text lock #t)
+            (send manual-ordering-text end-edit-sequence))
+
+          (define manual-number-style-delta (make-object style-delta%))
+          (define stupid-internal-define-syntax1
+            (send manual-number-style-delta set-delta-foreground "darkblue"))
+          
+          (define (insert-single name n)
+            (let ([n-sp (send manual-ordering-text last-position)])
+              (send manual-ordering-text insert (number->string n))
+              (let ([n-ep (send manual-ordering-text last-position)])
+                (send manual-ordering-text insert ") ")
+                (send manual-ordering-text insert name)
+                (send manual-ordering-text insert "\n")
+                
+                (send manual-ordering-text change-style
+                      manual-number-style-delta
+                      n-sp
+                      (+ n-ep 1)))))
+          
+          ;; add-language-to-dialog : (instanceof language<%>) -> void
+	  ;; adds the language to the dialog
+	  ;; opens all of the turn-down tags
+          ;; when `language' matches language-to-show, update the settings
+          ;;   panel to match language-to-show, otherwise set to defaults.
+          (define (add-language-to-dialog language)
+            (let ([positions (send language get-language-position)]
+                  [numbers (send language get-language-numbers)])
+              (unless (and (list? positions)
+                           (list? numbers)
+                           (pair? positions)
+                           (pair? numbers)
+                           (andmap number? numbers)
+                           (andmap string? positions)
+                           (= (length positions) (length numbers))
+                           ((length numbers) . >= . 2))
+                (error 'drscheme:language
+                       "languages position and numbers must be lists of strings and numbers, respectively, must have the same length,  and must each contain at least two elements, got: ~e ~e"
+                       positions numbers))
+              
+              #|
+              
+              inline the first level of the tree into just items in the hierlist
+              keep track of the starting (see call to sort method below) by
+              adding a second field to the second level of the tree that indicates
+              what the sorting number is for its level above (in the second-number mixin)
+              
+              |#
+              
+              (let add-sub-language ([ht languages-table]
+                                     [hier-list languages-hier-list]
+                                     [positions positions]
+                                     [numbers numbers]
+                                     [first? #t]
+                                     [second-number #f]) ;; only non-#f during the second iteration in which case it is the first iterations number
+                (cond
+                  [(null? (cdr positions))
+                   (let-values ([(language-details-panel get/set-settings)
+                                 (make-details-panel language)])
+                     (let* ([position (car positions)]
+                            [number (car numbers)]
+                            [mixin (compose
+                                    number-mixin
+                                    (language-mixin language language-details-panel get/set-settings))]
+                            [item
+                             (send hier-list new-item
+                                   (if second-number
+                                       (compose second-number-mixin mixin)
+                                       mixin))]
+                            [text (send item get-editor)]
+                            [delta (send language get-style-delta)])
+                       (send item set-number number)
+                       (when second-number
+                         (send item set-second-number second-number))
+                       (send text insert position)
+                       (when delta
+                         (cond
+                           [(list? delta)
+                            (for-each (λ (x)
+                                        (send text change-style 
+                                              (car x)
+                                              (cadr x)
+                                              (caddr x)))
+                                      delta)]
+                           [(is-a? delta style-delta%)
+                            (send text change-style 
+                                  (send language get-style-delta)
+                                  0
+                                  (send text last-position))])))
+                     (cond
+                       [(equal? (send language-to-show get-language-position)
+                                (send language get-language-position))
+                        (get/set-settings settings-to-show)]
+                       [else
+                        (get/set-settings (send language default-settings))]))]
+                  [else (let* ([position (car positions)]
+                               [number (car numbers)]
+                               [sub-ht/sub-hier-list
+                                (hash-table-get
+                                 ht
+                                 (string->symbol position)
+                                 (λ ()
+                                   (if first?
+                                       (let* ([item (send hier-list new-item number-mixin)]
+                                              [x (list (make-hash-table) hier-list item)])
+                                         (hash-table-put! ht (string->symbol position) x)
+                                         (send item set-number number)
+                                         (send item set-allow-selection #f)
+                                         (let* ([editor (send item get-editor)]
+                                                [pos (send editor last-position)])
+                                           (send editor insert "\n")
+                                           (send editor insert position)
+                                           (send editor change-style small-size-delta pos (+ pos 1))
+                                           (send editor change-style section-style-delta 
+                                                 (+ pos 1) (send editor last-position)))
+                                         x)
+                                       (let* ([new-list (send hier-list new-list 
+                                                              (if second-number
+                                                                  (compose second-number-mixin number-mixin)
+                                                                  number-mixin))]
+                                              [x (list (make-hash-table) new-list #f)])
+                                         (send new-list set-number number)
+                                         (when second-number
+                                           (send new-list set-second-number second-number))
+                                         (send new-list set-allow-selection #f)
+                                         (send new-list open)
+                                         (send (send new-list get-editor) insert position)
+                                         (hash-table-put! ht (string->symbol position) x)
+                                         x))))])
+                          (cond
+                            [first? 
+                             (unless (= number (send (caddr sub-ht/sub-hier-list) get-number))
+                               (error 'add-language "language ~s; expected number for ~e to be ~e, got ~e"
+                                      (send language get-language-name)
+                                      position
+                                      (send (caddr sub-ht/sub-hier-list) get-number)
+                                      number))]
+                            [else
+                             (unless (= number (send (cadr sub-ht/sub-hier-list) get-number))
+                               (error 'add-language "language ~s; expected number for ~e to be ~e, got ~e"
+                                      (send language get-language-name)
+                                      position
+                                      (send (cadr sub-ht/sub-hier-list) get-number)
+                                      number))])
+                          (add-sub-language (car sub-ht/sub-hier-list)
+                                            (cadr sub-ht/sub-hier-list)
+                                            (cdr positions)
+                                            (cdr numbers)
+                                            #f
+                                            (if first? number #f)))]))))
+
+          (define number<%>
+            (interface ()
+              get-number
+              set-number))
+          
+          (define second-number<%>
+            (interface ()
+              get-second-number
+              set-second-number))
+          
+          ;; number-mixin : (extends object%) -> (extends object%)
+          ;; adds the get/set-number methods to this class
+          (define (number-mixin %)
+            (class* % (number<%>)
+              (field (number 0))
+              (define/public (get-number) number)
+              (define/public (set-number _number) (set! number _number))
+              (super-instantiate ())))
+
+          ;; second-number-mixin : (extends object%) -> (extends object%)
+          ;; adds the get/set-number methods to this class
+          (define (second-number-mixin %)
+            (class* % (second-number<%>)
+              (field (second-number 0))
+              (define/public (get-second-number) second-number)
+              (define/public (set-second-number _second-number) (set! second-number _second-number))
+              (super-instantiate ())))
+              
+          ;; make-details-panel : ((instanceof language<%>) -> (values panel (case-> (-> settings) (settings -> void))))
+	  ;; adds a details panel for `language', using
+	  ;; the language's default settings, unless this is
+	  ;; the to-show language.
+	  (define (make-details-panel language)
+	    (let ([panel (instantiate vertical-panel% ()
+                           (parent details-panel)
+                           (stretchable-width #f)
+                           (stretchable-height #f))])
+	      (values
+	       panel
+	       (send language config-panel panel))))
+
+	  ;; close-all-languages : -> void
+	  ;; closes all of the tabs in the language hier-list.
+	  (define (close-all-languages)
+	    (define (close-children list)
+	      (for-each close-this-one (send list get-items)))
+	    (define (close-this-one item)
+	      (cond
+		[(is-a? item hierarchical-list-compound-item<%>)
+		 (send item close)
+		 (close-children item)]
+		[else (void)]))
+	    (close-children languages-hier-list))
+
+	  ;; open-current-language : -> void
+	  ;; opens the tabs that lead to the current language
+	  ;; and selects the current language
+	  (define (open-current-language)
+	    (let loop ([hi languages-hier-list]
+                       
+                       ;; skip the first position, since it is flattened into the dialog
+		       [first-pos (cadr (send language-to-show get-language-position))]
+		       [position (cddr (send language-to-show get-language-position))])
+		 (let ([child
+			;; know that this `car' is okay by construction of the dialog
+			(car 
+			 (filter (λ (x)
+				   (equal? (send (send x get-editor) get-text)
+					   first-pos))
+				 (send hi get-items)))])
+		   (cond
+		     [(null? position)
+		      (send child select #t)]
+		     [else
+		      (send child open)
+		      (loop child (car position) (cdr position))]))))
+
+          ;; docs-callback : -> void
+          (define (docs-callback)
+            (void))
+          
+          ;; details-shown? : boolean
+          ;; indicates if the details are currently visible in the dialog
+          (define details-shown? (not (send language-to-show default-settings? settings-to-show)))
+
+          ;; details-callback : -> void
+          ;; flips the details-shown? flag and resets the GUI
+          (define (details-callback)
+            (set! details-shown? (not details-shown?))
+            (when re-center
+              (send re-center begin-container-sequence))
+            (update-show/hide-details)
+            (when re-center
+              (send re-center center 'both)
+              (send re-center end-container-sequence)))
+          
+          ;; show/hide-details : -> void
+          ;; udpates the GUI based on the details-shown? flag
+          (define (update-show/hide-details)
+            (send details-button set-label 
+                  (if details-shown? hide-details-label show-details-label))
+            (send parent begin-container-sequence)
+            (send revert-to-defaults-outer-panel change-children
+                  (λ (l)
+                    (if details-shown? (list revert-to-defaults-button) null)))
+            (send details-outer-panel change-children
+                  (λ (l)
+                    (if details-shown? (list details/manual-parent-panel) null)))
+            (send parent end-container-sequence))
+
+          ;; revert-to-defaults-callback : -> void
+          (define (revert-to-defaults-callback)
+            (when selected-language
+              (get/set-selected-language-settings 
+               (send selected-language default-settings))))
+
+          (define show-details-label (string-constant show-details-button-label))
+          (define hide-details-label (string-constant hide-details-button-label))
+          (define details-button (make-object button% 
+                                   (if (show-details-label . system-font-space->= . hide-details-label)
+                                       show-details-label
+                                       hide-details-label)
+                                   show-details-parent
+                                   (λ (x y)
+                                     (details-callback))))
+          
+          (define revert-to-defaults-outer-panel (make-object horizontal-panel% show-details-parent))
+          (define revert-to-defaults-button (make-object button% 
+                                              (string-constant revert-to-language-defaults)
+                                              revert-to-defaults-outer-panel
+                                              (λ (_1 _2)
+                                                (revert-to-defaults-callback))))
+
+          (send revert-to-defaults-outer-panel stretchable-width #f)
+          (send revert-to-defaults-outer-panel stretchable-height #f)
+          (send outermost-panel set-alignment 'center 'center)
+
+          (update-show/hide-details)
+
+          (for-each add-language-to-dialog languages)
+          (send languages-hier-list sort 
+                (λ (x y)
+                  (cond
+                    [(and (x . is-a? . second-number<%>)
+                          (y . is-a? . second-number<%>))
+                     (cond
+                       [(= (send x get-second-number)
+                           (send y get-second-number))
+                        (< (send x get-number) (send y get-number))]
+                       [else
+                        (< (send x get-second-number)
+                           (send y get-second-number))])]
+                    [(and (x . is-a? . number<%>)
+                          (y . is-a? . second-number<%>))
+                     (cond
+                       [(= (send x get-number)
+                           (send y get-second-number))
+                        #t]
+                       [else
+                        (< (send x get-number)
+                           (send y get-second-number))])]
+                    [(and (x . is-a? . second-number<%>)
+                          (y . is-a? . number<%>))
+                     (cond
+                       [(= (send x get-second-number)
+                           (send y get-number))
+                        #f]
+                       [else (< (send x get-second-number)
+                                (send y get-number))])]
+                    [(and (x . is-a? . number<%>)
+                          (y . is-a? . number<%>))
+                     (< (send x get-number) (send y get-number))]
+                    [else #f])))
+
+          ;; remove the newline at the front of the first inlined category
+          (send (send (car (send languages-hier-list get-items)) get-editor) delete 0 1)
+          
+          (cond
+            [manuals? 
+             (unless details-shown?
+               (details-callback))
+             (send show-details-parent change-children
+                   (λ (l)
+                     (remq revert-to-defaults-outer-panel
+                           (remq details-button l))))
+             (send details/manual-parent-panel change-children 
+                   (λ (l)
+                     (list manual-ordering-panel)))]
+            [else 
+             (send details-outer-panel stretchable-width #f)
+             (send details/manual-parent-panel change-children 
+                   (λ (l)
+                     (list details-panel)))])
+          
+          (send manual-ordering-text hide-caret #t)
+          (send manual-ordering-text auto-wrap #t)
+          (send manual-ordering-text lock #t)
+          
+	  (send languages-hier-list stretchable-width #t)
+	  (send languages-hier-list stretchable-height #t)
+	  (send parent reflow-container)
+          (close-all-languages)
+	  (open-current-language)
+          (send languages-hier-list min-client-width (text-width (send languages-hier-list get-editor)))
+	  (send languages-hier-list min-client-height (text-height (send languages-hier-list get-editor)))
+          (when get/set-selected-language-settings
+            (get/set-selected-language-settings settings-to-show))
+          (send languages-hier-list focus)
+          (values
+           (λ () selected-language)
+           (λ () 
+             (and get/set-selected-language-settings
+                  (get/set-selected-language-settings))))))
+
+      (define panel-background-editor-canvas% 
+        (class editor-canvas%
+          (inherit get-dc get-client-size)
+          (define/override (on-paint)
+            (let-values ([(cw ch) (get-client-size)])
+              (let* ([dc (get-dc)]
+                     [old-pen (send dc get-pen)]
+                     [old-brush (send dc get-brush)])
+                (send dc set-brush (send the-brush-list find-or-create-brush (get-panel-background) 'panel))
+                (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent))
+                (send dc draw-rectangle 0 0 cw ch)
+                (send dc set-pen old-pen)
+                (send dc set-brush old-brush)))
+            (super on-paint))
+          (super-new)))
+      
+      (define panel-background-text% 
+        (class text%
+          (define/override (on-paint before? dc left top right bottom dx dy draw-caret)
+            (when before?
+              (let ([old-pen (send dc get-pen)]
+                    [old-brush (send dc get-brush)])
+                (send dc set-brush (send the-brush-list find-or-create-brush (get-panel-background) 'panel))
+                (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent))
+                (send dc draw-rectangle (+ dx left) (+ dy top) (- right left) (- bottom top))
+                (send dc set-pen old-pen)
+                (send dc set-brush old-brush)))
+            (super on-paint before? dc left top right bottom dx dy draw-caret))
+          (super-new)))
+      
+      (define section-style-delta (make-object style-delta% 'change-bold))
+      (send section-style-delta set-delta-foreground "medium blue")
+      (define small-size-delta (make-object style-delta% 'change-size 9))
+      
+      (define (add-welcome dialog welcome-before-panel welcome-after-panel)
+        (let* ([outer-pb%
+                (class pasteboard%
+                  (define/override (can-interactive-move? evt)
+                    #f)
+                  (super-instantiate ()))]
+               [outer-pb (make-object outer-pb%)]
+               [bitmap 
+                (make-object bitmap%
+                  (build-path (collection-path "icons") 
+                              "plt-small-shield.gif"))]
+               [image-snip
+                (make-object image-snip% 
+                  (build-path (collection-path "icons") 
+                              "plt-small-shield.gif"))]
+               [before-text (make-object text%)]
+               [before-snip (make-object editor-snip% before-text #f)]
+               [before-ec%
+                (class editor-canvas% 
+                  (inherit get-client-size)
+                  (define/private (update-size)
+                    (let-values ([(cw ch) (get-client-size)])
+                      (unless (or (zero? cw)
+                                  (zero? ch))
+                        (let ([image-l-box (box 0)]
+                              [image-r-box (box 0)])
+                          (send before-text get-snip-location image-snip image-l-box #f #f)
+                          (send before-text get-snip-location image-snip image-r-box #f #t)
+                          (let* ([image-w (send bitmap get-width)]
+                                 [before-snip-space (- cw image-w)]
+                                 [before-snip-w (- before-snip-space
+                                                   5 5 ;; space before and after inside snip 
+                                                   2   ;; space at end of outer editor
+                                                   1   ;; space at beginning of outer editor
+                                                   1   ;; space between image and snip
+                                                   -5  ;; unknown space
+                                                   )])
+                            (send before-text set-max-width (max 0 before-snip-w)))))))
+                  (define/override (on-superwindow-show shown?)
+                    (update-size)
+                    (super on-superwindow-show shown?))
+                  (define/override (on-size w h)
+                    (update-size)
+                    (super on-size w h))
+                  (super-instantiate ()))]
+               [before-ec (instantiate before-ec% ()
+                            (parent welcome-before-panel)
+                            (editor outer-pb)
+                            (stretchable-height #f)
+                            (style '(no-vscroll no-hscroll)))]
+               [first-line-style-delta (make-object style-delta% 'change-bold)])
+          (send first-line-style-delta set-delta-foreground (make-object color% 150 0 150))
+          (send before-ec min-width 550)
+
+          (let-values ([(cw ch) (send before-ec get-client-size)]
+                       [(w h) (send before-ec get-size)])
+            (send before-ec min-height 
+                  (+ (send bitmap get-height) 
+                     8  ;; pasteboards apparently want some space here....
+                     (- h ch))))
+
+          (send outer-pb insert image-snip)
+          (send outer-pb insert before-snip)
+          (send outer-pb move image-snip 0 0)
+          (send outer-pb move before-snip (send bitmap get-width) 0)
+          (send outer-pb set-selection-visible #f)
+          (send outer-pb lock #t)
+
+          ;(send before-snip set-align-top-line #t)
+          (send before-text insert 
+                (format (string-constant welcome-to-drscheme-version/language)
+                        (version:version)
+                        (this-language)))
+          (send before-text insert #\newline)
+          (send before-text insert (string-constant introduction-to-language-dialog))
+          (send before-text change-style 
+                first-line-style-delta
+                0
+                (send before-text paragraph-end-position 0))
+          (send before-text auto-wrap #t)
+
+          (send before-text lock #t)
+          (send before-text hide-caret #t)
+
+          (for-each (λ (native-lang-string language)
+                      (unless (equal? (this-language) language)
+                        (instantiate button% ()
+                          (label native-lang-string)
+                          (parent welcome-after-panel)
+                          (stretchable-width #t)
+                          (callback (λ (x1 x2) (drscheme:app:switch-language-to dialog language))))))
+                    (string-constants is-this-your-native-language)
+                    (all-languages))))
+
+      ;; system-font-space->= : string string -> boolean
+      ;; determines which string is wider, when drawn in the system font
+      (define (x . system-font-space->= . y)
+        (let ([bdc (make-object bitmap-dc%)])
+          (send bdc set-bitmap (make-object bitmap% 1 1 #t))
+          (send bdc set-font (send the-font-list find-or-create-font
+                                   12 'system 'normal 'normal))
+          (let-values ([(wx _1 _2 _3) (send bdc get-text-extent x)]
+                       [(wy _4 _5 _6) (send bdc get-text-extent y)])
+            (wx . >= . wy))))
+
+      ;; text-width : (isntanceof text%) -> exact-integer
+      ;; calculates the width of widest line in the
+      ;; editor. This only makes sense if auto-wrap
+      ;; is turned off. Otherwise, you could just use
+      ;; the admin's width.
+      (define (text-width text)
+	(let loop ([n (+ (send text last-line) 1)]
+		   [current-max-width 0])
+	  (cond
+	    [(zero? n)
+	     (+
+	      10 ;; this should be some magic small constant (hopefully less than 10 on all platforms)
+	      (floor (inexact->exact current-max-width)))]
+	    [else (let* ([line-number (- n 1)]
+			 [box (box 0.0)]
+			 [eol-pos (send text line-end-position line-number)]
+			 [eol-snip (send text find-snip eol-pos 'before)])
+		    (when eol-snip
+		      (send text get-snip-location eol-snip box #f #t))
+		    (loop (- n 1)
+			  (max current-max-width (unbox box))))])))
+      
+      ;; text-height : (is-a?/c text% -> exact-integer
+      (define (text-height text)
+        (let ([y-box (box 0)])
+          (send text position-location 
+                (send text last-position)
+                #f
+                y-box
+                #f
+                #f
+                #t)
+          (+ 10 ;; upper bound on some platform specific space I don't know how to get.
+             (floor (inexact->exact (unbox y-box))))))
+
+      (define teachpack-directory 
+        (let ([lib-dir (build-path 
+                        (collection-path "mzlib")
+                        'up 'up "teachpack")])
+          (if (directory-exists? lib-dir)
+              lib-dir
+              #f)))
+
+      
+                                                                      
+                            ;;                          ;;            
+  ;                          ;                           ;            
+  ;                          ;                           ;            
+ ;;;;;   ;;;   ;;;;    ;;;   ; ;;  ; ;;;   ;;;;    ;;;   ;  ;;   ;;;  
+  ;     ;   ;      ;  ;   ;  ;;  ;  ;   ;      ;  ;   ;  ; ;    ;   ; 
+  ;     ;;;;;   ;;;;  ;      ;   ;  ;   ;   ;;;;  ;      ;;      ;;;  
+  ;     ;      ;   ;  ;      ;   ;  ;   ;  ;   ;  ;      ; ;        ; 
+  ;   ; ;   ;  ;   ;  ;   ;  ;   ;  ;   ;  ;   ;  ;   ;  ;  ;   ;   ; 
+   ;;;   ;;;    ;;; ;  ;;;  ;;; ;;; ;;;;    ;;; ;  ;;;  ;;   ;;  ;;;  
+                                    ;                                 
+                                    ;                                 
+                                   ;;;                                
+
+      
+      ;; add-new-teachpack : (instanceof frame%) -> boolean
+      ;; querys the user for the name of a teachpack and adds it to the
+      ;; current teachpacks. Uses the argument as the parent to the dialog
+      ;; the result indicates if the teachpacks changed #t if they did and #f if not
+      (define (add-new-teachpack frame)
+        (let ([lib-file
+               (begin
+                 (parameterize ([finder:dialog-parent-parameter frame])
+                   (finder:get-file 
+                    teachpack-directory
+                    (string-constant select-a-teachpack)
+                    ".*\\.(ss|scm)$")))])
+          (if lib-file
+              (let* ([interactions-text (send frame get-interactions-text)]
+                     [tp-cache (send interactions-text get-user-teachpack-cache)]
+                     [tp-filenames (drscheme:teachpack:teachpack-cache-filenames tp-cache)]
+                     [new-item (normalize-path lib-file)])
+                (cond
+                  [(member (normal-case-path new-item) (map normal-case-path tp-filenames))
+                   (message-box (string-constant drscheme-teachpack-message-title)
+                                (format (string-constant already-added-teachpack)
+                                        new-item)
+                                frame)]
+                  [else
+                   (let ([new-teachpacks 
+                          (drscheme:teachpack:new-teachpack-cache
+                           (append tp-filenames (list new-item)))])
+                     (send interactions-text set-user-teachpack-cache new-teachpacks)
+                     (preferences:set 'drscheme:teachpacks new-teachpacks))])
+                (set! teachpack-directory (path-only lib-file))
+                #t)
+              #f)))
+      
+      ;; clear-all-teachpacks : -> boolean
+      ;; clears all of the teachpack settings
+      ;; the result indicates if the teachpacks changed #t if they did and #f if not
+      (define (clear-all-teachpacks)
+        (let ([old (preferences:get 'drscheme:teachpacks)])
+          (cond
+            [(null? (drscheme:teachpack:teachpack-cache-filenames old))
+             #f]
+            [else
+             (drscheme:teachpack:set-teachpack-cache-filenames! old null)
+             (preferences:set 'drscheme:teachpacks old)
+             #t])))
+
+   ;             ;;;                             
+                ;                                
+                ;                                
+ ;;;   ; ;;;   ;;;;;   ;;;           ;;;    ;;;  
+   ;    ;;  ;   ;     ;   ;         ;   ;  ;   ; 
+   ;    ;   ;   ;     ;   ;          ;;;    ;;;  
+   ;    ;   ;   ;     ;   ;             ;      ; 
+   ;    ;   ;   ;     ;   ;         ;   ;  ;   ; 
+ ;;;;; ;;;  ;; ;;;;    ;;;    ;      ;;;    ;;;  
+                                                 
+                                                 
+                                                 
+
+                                                               
+ ;;;                                                           
+   ;                                                           
+   ;                                                           
+   ;    ;;;;  ; ;;;    ;;; ;;;  ;;  ;;;;    ;;; ;  ;;;    ;;;  
+   ;        ;  ;;  ;  ;   ;  ;   ;      ;  ;   ;  ;   ;  ;   ; 
+   ;     ;;;;  ;   ;  ;   ;  ;   ;   ;;;;  ;   ;  ;;;;;   ;;;  
+   ;    ;   ;  ;   ;  ;   ;  ;   ;  ;   ;  ;   ;  ;          ; 
+   ;    ;   ;  ;   ;  ;   ;  ;   ;  ;   ;  ;   ;  ;   ;  ;   ; 
+ ;;;;;;  ;;; ;;;;  ;;  ;;;;   ;;; ;  ;;; ;  ;;;;   ;;;    ;;;  
+                          ;                    ;               
+                          ;                    ;               
+                       ;;;                  ;;;                
+
+      
+      (define (add-info-specified-languages)
+        (for-each add-info-specified-language (find-relevant-directories '(drscheme-language-positions))))
+      
+      (define (add-info-specified-language directory)
+        (let ([info-proc (get-info/full directory)])
+          (when info-proc
+            (let* ([lang-positions (info-proc 'drscheme-language-positions (λ () null))]
+                   [lang-modules (info-proc 'drscheme-language-modules (λ () null))]
+                   [numberss (info-proc 'drscheme-language-numbers 
+                                        (λ ()
+                                          (map (λ (lang-position)
+                                                 (map (λ (x) 0) lang-position))
+                                               lang-positions)))]
+                   [summaries (info-proc 'drscheme-language-one-line-summaries 
+                                         (λ ()
+                                           (map (λ (lang-position) "")
+                                                lang-positions)))]
+                   [urls      (info-proc 'drscheme-language-urls 
+                                         (λ ()
+                                           (map (λ (lang-position) "")
+                                                lang-positions)))]
+                   [reader-specs
+                    (info-proc 'drscheme-language-readers
+                               (λ ()
+                                 (map (λ (lang-position) #f)
+                                      lang-positions)))])
+              (cond
+                [(and (list? lang-positions)
+                      (andmap (λ (lang-position numbers)
+                                (and (list? lang-position)
+                                     (pair? lang-position)
+                                     (andmap string? lang-position)
+                                     (list? numbers)
+                                     (andmap number? numbers)
+                                     (= (length numbers)
+                                        (length lang-position))))
+                              lang-positions
+                              numberss)
+                      (list? lang-modules)
+                      (andmap (λ (x)
+                                (and (list? x)
+                                     (andmap string? x)))
+                              lang-modules)
+                      (list? summaries)
+                      (andmap string? summaries)
+
+                      (list? urls)
+                      (andmap string? urls)
+                      
+                      (list? reader-specs)
+                      (andmap (λ (x)
+				;; approximation (no good test, really)
+				;; since it depends on the value of a mz
+				;; parameter to interpret the module spec
+                                (or (eq? x #f) (symbol? x) (pair? x)))
+                              reader-specs)
+                      
+                      (= (length lang-positions)
+                         (length lang-modules)
+                         (length summaries)
+                         (length urls)
+                         (length reader-specs)))
+                 (for-each
+                  (λ (lang-module lang-position lang-numbers one-line-summary url reader-spec)
+                    (let ([%
+                           ((drscheme:language:get-default-mixin)
+                            (drscheme:language:module-based-language->language-mixin
+                             (drscheme:language:simple-module-based-language->module-based-language-mixin
+                              drscheme:language:simple-module-based-language%)))]
+                          [reader
+                           (if reader-spec
+                               (with-handlers ([exn:fail?
+                                                (λ (x)
+                                                  (message-box (string-constant drscheme)
+                                                               (if (exn? x)
+                                                                   (exn-message x)
+                                                                   (format "uncaught exception: ~s" x)))
+                                                  read-syntax/namespace-introduce)])
+                                 (contract
+                                  (opt-> (any/c)
+                                         (port? (list/c (and/c number? integer? exact? (>=/c 0))
+                                                        (and/c number? integer? exact? (>=/c 0))
+                                                        (and/c number? integer? exact? (>=/c 0))))
+                                         (union syntax? eof-object?))
+                                  (dynamic-require reader-spec 'read-syntax)
+                                  (string->symbol (format "~s" lang-position))
+                                  'drscheme))
+                               read-syntax/namespace-introduce)])
+                      (add-language (instantiate % ()
+                                      (module `(lib ,@lang-module))
+                                      (language-position lang-position)
+                                      (language-numbers lang-numbers)
+                                      (one-line-summary one-line-summary)
+                                      (language-url url)
+                                      (reader reader)))))
+                  lang-modules
+                  lang-positions
+                  numberss
+                  summaries
+                  urls
+                  reader-specs)]
+                [else
+                 (message-box
+		  (string-constant drscheme)
+		  (format
+		   "The drscheme-language-position, drscheme-language-modules, drscheme-language-numbers, and drscheme-language-readers specifications aren't correct. Expected (listof (cons string (listof string))), (listof (listof string)), (listof (listof number)), (listof string), (listof string), and (listof module-spec) respectively, where the lengths of the outer lists are the same. Got ~e, ~e, ~e, ~e, ~e, and ~e"
+		  lang-positions
+		  lang-modules
+		  numberss
+		  summaries
+                  urls
+		  reader-specs))])))))
+
+      (define read-syntax/namespace-introduce
+        (opt-lambda (source-name-v [input-port (current-input-port)])
+          (let ([v (read-syntax source-name-v input-port)])
+            (if (syntax? v)
+                (namespace-syntax-introduce v)
+                v))))
+      
+
+                                                        
+;;               ;    ;;;                    ;          
+ ;                      ;     ;                         
+ ;                      ;     ;                         
+ ;;;;  ;;  ;;  ;;;      ;    ;;;;;         ;;;   ; ;;;  
+ ;   ;  ;   ;    ;      ;     ;              ;    ;;  ; 
+ ;   ;  ;   ;    ;      ;     ;              ;    ;   ; 
+ ;   ;  ;   ;    ;      ;     ;              ;    ;   ; 
+ ;   ;  ;   ;    ;      ;     ;   ;          ;    ;   ; 
+; ;;;    ;;; ; ;;;;;  ;;;;;;   ;;;         ;;;;; ;;;  ;;
+                                                        
+                                                        
+                                                        
+
+                                                               
+ ;;;                                                           
+   ;                                                           
+   ;                                                           
+   ;    ;;;;  ; ;;;    ;;; ;;;  ;;  ;;;;    ;;; ;  ;;;    ;;;  
+   ;        ;  ;;  ;  ;   ;  ;   ;      ;  ;   ;  ;   ;  ;   ; 
+   ;     ;;;;  ;   ;  ;   ;  ;   ;   ;;;;  ;   ;  ;;;;;   ;;;  
+   ;    ;   ;  ;   ;  ;   ;  ;   ;  ;   ;  ;   ;  ;          ; 
+   ;    ;   ;  ;   ;  ;   ;  ;   ;  ;   ;  ;   ;  ;   ;  ;   ; 
+ ;;;;;;  ;;; ;;;;  ;;  ;;;;   ;;; ;  ;;; ;  ;;;;   ;;;    ;;;  
+                          ;                    ;               
+                          ;                    ;               
+                       ;;;                  ;;;                
+
+
+      
+      ;; add-expand-to-front-end : mixin
+      ;; overrides front-end to make the language a language that expands its arguments
+      (define (add-expand-to-front-end %)
+        (class %
+          (define/override (front-end/complete-program input settings teachpack-cache)
+            (wrap-front-end (super front-end/complete-program input settings teachpack-cache)))
+          (define/override (front-end/interaction input settings teachpack-cache)
+            (wrap-front-end (super front-end/interaction input settings teachpack-cache)))
+          (define/private (wrap-front-end thnk)
+            (λ ()
+              (let ([res (thnk)])
+                (cond
+                  [(syntax? res) (with-syntax ([res res]
+                                               [expand-syntax-top-level-with-compile-time-evals
+                                                expand-syntax-top-level-with-compile-time-evals])
+                                   #'(expand-syntax-top-level-with-compile-time-evals
+                                      (quote-syntax res)))]
+                  [(eof-object? res) res]
+                  [else `(expand ',res)]))))
+          (super-instantiate ())))
+
+      (define (r5rs-mixin %)
+        (class %
+          (define/override (on-execute setting run-in-user-thread)
+            (super on-execute setting run-in-user-thread)
+            (run-in-user-thread
+             (λ ()
+               (read-square-bracket-as-paren #f)
+               (read-curly-brace-as-paren #f)
+               (print-vector-length #f))))
+          (define/override (default-settings) 
+            (drscheme:language:make-simple-settings #f 'write 'mixed-fraction-e #f #t 'debug))
+          (define/override (order-manuals x)
+            (values 
+             (list #"r5rs" #"drscheme" #"tour" #"help")
+             #f))
+          (super-new)))
+      
+      ;; add-built-in-languages : -> void
+      (define (add-built-in-languages)
+        (let* ([extras-mixin
+                (λ (mred-launcher? one-line-summary)
+                  (λ (%)
+                    (class %
+                      (define/override (get-one-line-summary) one-line-summary)
+                      (define/override (use-namespace-require/copy?) #t)
+                      
+                      (inherit get-module get-transformer-module get-init-code)
+                      (define/override (create-executable setting parent program-filename teachpacks)
+                        (let ([executable-fn
+			       (drscheme:language:put-executable
+				parent
+				program-filename
+				mred-launcher?
+				#t
+				(if mred-launcher?
+				    (string-constant save-a-mred-launcher)
+				    (string-constant save-a-mzscheme-launcher)))])
+                          (when executable-fn
+                            (drscheme:language:create-module-based-launcher
+                             program-filename
+                             executable-fn
+                             (get-module)
+                             (get-transformer-module)
+                             (get-init-code setting teachpacks)
+                             mred-launcher?
+                             (use-namespace-require/copy?)))))
+                      (super-instantiate ()))))]
+               [make-simple
+                (λ (module position numbers mred-launcher? one-line-summary extra-mixin)
+                  (let ([%
+                         (extra-mixin
+                          ((extras-mixin mred-launcher? one-line-summary)
+                           ((drscheme:language:get-default-mixin)
+                            (drscheme:language:module-based-language->language-mixin
+                             (drscheme:language:simple-module-based-language->module-based-language-mixin
+                              drscheme:language:simple-module-based-language%)))))])
+                    (instantiate % ()
+                      (module module)
+                      (language-position position)
+                      (language-numbers numbers))))])
+          (add-language
+           (make-simple '(lib "plt-mzscheme.ss" "lang") 
+                        (list (string-constant professional-languages)
+                              (string-constant plt)
+                              (string-constant mzscheme-w/debug))
+                        (list -1000 -10 1)
+                        #f
+                        (string-constant mzscheme-one-line-summary)
+                        (λ (x) x)))
+          (add-language
+           (make-simple '(lib "plt-mred.ss" "lang")
+                        (list (string-constant professional-languages)
+                              (string-constant plt)
+                              (string-constant mred-w/debug))
+                        (list -1000 -10 2)
+                        #t
+                        (string-constant mred-one-line-summary)
+                        (λ (x) x)))
+          (add-language
+           (make-simple '(lib "plt-pretty-big.ss" "lang")
+                        (list (string-constant professional-languages)
+                              (string-constant plt)
+                              (string-constant pretty-big-scheme))
+                        (list -1000 -10 3)
+                        #t
+                        (string-constant pretty-big-scheme-one-line-summary)
+                        (λ (x) x)))
+          (add-language
+           (make-simple '(lib "plt-mzscheme.ss" "lang")
+                        (list (string-constant professional-languages)
+                              (string-constant plt)
+                              (string-constant expander))
+                        (list -1000 -10 4)
+                        #t
+                        (string-constant expander-one-line-summary)
+                        add-expand-to-front-end))
+          (add-language
+           (make-simple '(lib "r5rs.ss" "lang")
+                        (list (string-constant professional-languages)
+                              (string-constant r5rs-lang-name))
+                        (list -1000 -1000)
+                        #f
+                        (string-constant r5rs-one-line-summary)
+                        r5rs-mixin)))))))
diff --git a/collects/drscheme/private/language.ss b/collects/drscheme/private/language.ss
new file mode 100644
index 0000000000..9f19af7796
--- /dev/null
+++ b/collects/drscheme/private/language.ss
@@ -0,0 +1,1032 @@
+;; WARNING: printf is rebound in this module to always use the 
+;;          original stdin/stdout of drscheme, instead of the 
+;;          user's io ports, to aid any debugging printouts.
+;;          (esp. useful when debugging the users's io)
+
+(module language mzscheme
+  (require "drsig.ss"
+           (lib "string-constant.ss" "string-constants")
+           (lib "pconvert.ss")
+           (lib "pretty.ss")
+           (lib "etc.ss")
+	   (lib "unitsig.ss")
+	   (lib "struct.ss")
+           (lib "class.ss")
+           (lib "file.ss")
+           (lib "list.ss")
+           (lib "embed.ss" "compiler")
+           (lib "launcher.ss" "launcher")
+	   (lib "mred.ss" "mred")
+	   (lib "framework.ss" "framework")
+           (lib "syntax-browser.ss" "mrlib"))
+
+  (provide language@)
+
+  (define language@
+    (unit/sig drscheme:language^
+      (import [drscheme:debug : drscheme:debug^]
+              [drscheme:teachpack : drscheme:teachpack^]
+              [drscheme:tools : drscheme:tools^]
+              [drscheme:help-desk : drscheme:help-desk^])
+      
+      (define original-output-port (current-output-port))
+      (define (printf . args) (apply fprintf original-output-port args)) 
+      
+      (define-struct text/pos (text start end))
+      ;; text/pos = (make-text/pos (instanceof text% number number))
+      ;; this represents a portion of a text to be processed.
+      
+      (define language<%>
+	(interface ()
+	  marshall-settings
+          unmarshall-settings
+          default-settings
+	  default-settings?
+          
+          order-manuals
+          
+          front-end/complete-program
+          front-end/interaction
+	  config-panel
+	  on-execute
+          render-value/format
+          render-value
+          
+          create-executable
+          
+          get-language-position
+          get-language-name
+          get-style-delta
+          get-language-numbers
+          get-one-line-summary
+          get-language-url
+          get-comment-character))
+      
+      (define module-based-language<%>
+	(interface ()
+	  marshall-settings
+          unmarshall-settings
+          default-settings
+	  default-settings?
+
+          get-module
+          get-transformer-module
+          use-namespace-require/copy?
+	  config-panel
+
+          get-reader
+	  
+          on-execute
+          get-init-code
+          use-mred-launcher
+          
+          render-value/format
+          render-value
+          
+          get-language-position 
+          get-language-numbers
+          get-one-line-summary
+          get-language-url))
+      
+      (define simple-module-based-language<%>
+	(interface ()
+          get-module
+          get-language-position
+          get-language-numbers
+          get-one-line-summary
+          get-language-url
+          get-reader))
+      
+      
+                                          
+          ;                  ;;;          
+                               ;          
+                               ;          
+  ;;;   ;;;   ;;; ;  ; ;;;     ;     ;;;  
+ ;   ;    ;    ; ; ;  ;   ;    ;    ;   ; 
+  ;;;     ;    ; ; ;  ;   ;    ;    ;;;;; 
+     ;    ;    ; ; ;  ;   ;    ;    ;     
+ ;   ;    ;    ; ; ;  ;   ;    ;    ;   ; 
+  ;;;   ;;;;; ;; ; ;; ;;;;   ;;;;;;  ;;;  
+                      ;                   
+                      ;                   
+                     ;;;                  
+
+      
+      (define simple-module-based-language%
+        (class* object% (simple-module-based-language<%>)
+          (init-field module
+                      language-position
+                      (language-numbers (map (λ (x) 0) language-position))
+                      (one-line-summary "")
+                      (language-url #f)
+                      (documentation-reference #f)
+                      (reader (λ (src port)
+				(let ([v (parameterize ([read-accept-reader #t])
+					   (read-syntax src port))])
+                                  (if (eof-object? v)
+				      v
+				      (namespace-syntax-introduce v))))))
+          (define/public (get-module) module)
+	  (define/public (get-language-position) language-position)
+          (define/public (get-language-numbers) language-numbers)
+          (define/public (get-one-line-summary) one-line-summary)
+          (define/public (get-language-url) language-url)
+	  (define/public (get-reader) reader)
+          (super-instantiate ())))
+      
+
+                                                                                                  
+                                ;;         ;;;                 ;;                              ;; 
+                                 ;           ;                  ;                               ; 
+         ;                       ;           ;                  ;                               ; 
+          ;   ;;; ;    ;;;    ;;;; ;;  ;;    ;     ;;;          ;;;;   ;;;;    ;;;    ;;;    ;;;; 
+           ;   ; ; ;  ;   ;  ;   ;  ;   ;    ;    ;   ;         ;   ;      ;  ;   ;  ;   ;  ;   ; 
+ ;;;;;      ;  ; ; ;  ;   ;  ;   ;  ;   ;    ;    ;;;;;  ;;;;;  ;   ;   ;;;;   ;;;   ;;;;;  ;   ; 
+           ;   ; ; ;  ;   ;  ;   ;  ;   ;    ;    ;             ;   ;  ;   ;      ;  ;      ;   ; 
+          ;    ; ; ;  ;   ;  ;   ;  ;   ;    ;    ;   ;         ;   ;  ;   ;  ;   ;  ;   ;  ;   ; 
+         ;    ;; ; ;;  ;;;    ;;; ;  ;;; ; ;;;;;;  ;;;         ; ;;;    ;;; ;  ;;;    ;;;    ;;; ;
+                                                                                                  
+                                                                                                  
+                                                                                                  
+      
+      ;; simple-module-based-language->module-based-language : module-based-language<%>
+      ;; transforms a simple-module-based-language into a module-based-language<%>
+      (define simple-module-based-language->module-based-language-mixin
+	(mixin (simple-module-based-language<%>) (module-based-language<%>)
+	  (define/public (get-transformer-module) 'mzscheme)
+          (define/public (use-namespace-require/copy?) #f)
+          (define/public (use-mred-launcher) #t)
+          
+          (inherit get-module)
+          (define/public (marshall-settings settings)
+	    (simple-settings->vector settings))
+          (define/public (unmarshall-settings printable)
+            (and (vector? printable)
+                 (= (vector-length printable)
+                    (procedure-arity make-simple-settings))
+                 (boolean? (vector-ref printable 0))
+                 (memq (vector-ref printable 1) '(constructor quasiquote write current-print))
+                 (memq (vector-ref printable 2) 
+                       '(mixed-fraction 
+                         mixed-fraction-e
+                         repeating-decimal 
+                         repeating-decimal-e))
+                 (boolean? (vector-ref printable 3))
+                 (boolean? (vector-ref printable 4))
+                 (memq (vector-ref printable 5) '(none debug debug/profile test-coverage))
+                 (apply make-simple-settings (vector->list printable))))
+          (define/public (default-settings) 
+            (make-simple-settings #t 'write 'mixed-fraction-e #f #t 'debug))
+          (define/public (default-settings? x)
+	    (equal? (simple-settings->vector x)
+		    (simple-settings->vector (default-settings))))
+          (define/public (config-panel parent)
+	    (simple-module-based-language-config-panel parent))
+	  
+          (define/public (on-execute setting run-in-user-thread)
+	    (initialize-simple-module-based-language setting run-in-user-thread))
+          (define/public (get-init-code setting teachpacks)
+            (simple-module-based-language-get-init-code setting teachpacks))
+          
+          (define/public (render-value/format value settings port width)
+            (simple-module-based-language-render-value/format value settings port width))
+          (define/public (render-value value settings port)
+            (simple-module-based-language-render-value/format value settings port 'infinity))
+	  (super-instantiate ())))
+
+      ;; settings for a simple module based language
+      (define-struct simple-settings (case-sensitive 
+                                      printing-style
+                                      fraction-style
+                                      show-sharing
+                                      insert-newlines
+                                      annotations))
+      ;;  case-sensitive  : boolean
+      ;;  printing-style  : (union 'write 'constructor 'quasiquote 'current-print)
+      ;;  fraction-style  : (union 'mixed-fraction 'mixed-fraction-e 'repeating-decimal 'repeating-decimal-e)
+      ;;  show-sharing    : boolean
+      ;;  insert-newlines : boolean
+      ;;  annotations     : (union 'none 'debug 'debug/profile 'test-coverage)
+      (define simple-settings->vector (make-->vector simple-settings))
+
+      ;; simple-module-based-language-config-panel : parent -> (case-> (-> settings) (settings -> void))
+      (define (simple-module-based-language-config-panel _parent)
+	(letrec ([parent (instantiate vertical-panel% ()
+                           (parent _parent)
+                           (alignment '(center center)))]
+                 
+                 [input-panel (instantiate group-box-panel% ()
+                                (label (string-constant input-syntax))
+                                (parent parent)
+                                (alignment '(left center)))]
+                 
+                 [dynamic-panel (instantiate group-box-panel% ()
+                                  (label (string-constant dynamic-properties))
+                                  (parent parent)
+                                  (alignment '(left center)))]
+                 
+                 [output-panel (instantiate group-box-panel% ()
+                                 (label (string-constant output-syntax))
+                                 (parent parent)
+                                 (alignment '(left center)))]
+                 
+                 [case-sensitive (make-object check-box%
+                                   (string-constant case-sensitive-label)
+                                   input-panel
+                                   void)]
+                 [debugging (instantiate radio-box% ()
+                              (label #f)
+                              (choices 
+                               (list (string-constant no-debugging-or-profiling)
+                                     (string-constant debugging)
+                                     (string-constant debugging-and-profiling)
+                                     (string-constant test-coverage)))
+                              (parent dynamic-panel)
+                              (callback void))]
+                 [output-style (make-object radio-box%
+                                 (string-constant output-style-label)
+                                 (list (string-constant constructor-printing-style)
+                                       (string-constant quasiquote-printing-style)
+                                       (string-constant write-printing-style)
+                                       (string-constant print-printing-style))
+                                 output-panel
+                                 (λ (rb evt)
+                                   (let ([on? (not (= (send rb get-selection) 3))])
+                                     (send fraction-style enable on?)
+                                     (send show-sharing enable on?)
+                                     (send insert-newlines enable on?))))]
+                 [fraction-style
+                  (make-object check-box% (string-constant decimal-notation-for-rationals)
+                    output-panel
+                    void)]
+                 [show-sharing (make-object check-box%
+                                 (string-constant sharing-printing-label)
+                                 output-panel
+                                 void)]
+                 [insert-newlines (make-object check-box%
+                                    (string-constant use-pretty-printer-label)
+                                    output-panel
+                                    void)])
+          
+	  (case-lambda
+            [()
+             (make-simple-settings
+              (send case-sensitive get-value)
+              (case (send output-style get-selection)
+                [(0) 'constructor]
+                [(1) 'quasiquote]
+                [(2) 'write]
+                [(3) 'current-print])
+              (if (send fraction-style get-value)
+                  'repeating-decimal-e
+                  'mixed-fraction-e)
+              (send show-sharing get-value)
+              (send insert-newlines get-value)
+              (case (send debugging get-selection)
+                [(0) 'none]
+                [(1) 'debug]
+                [(2) 'debug/profile]
+                [(3) 'test-coverage]))]
+            [(settings)
+             (send case-sensitive set-value (simple-settings-case-sensitive settings))
+             (send output-style set-selection
+                   (case (simple-settings-printing-style settings)
+                     [(constructor) 0]
+                     [(quasiquote) 1]
+                     [(write) 2]
+                     [(current-print) 3]))
+             (let ([on? (not (eq? 'current-print (simple-settings-printing-style settings)))])
+               (send fraction-style enable on?)
+               (send show-sharing enable on?)
+               (send insert-newlines enable on?))
+             (send fraction-style set-value (eq? (simple-settings-fraction-style settings)
+                                                 'repeating-decimal-e))
+             (send show-sharing set-value (simple-settings-show-sharing settings))
+             (send insert-newlines set-value (simple-settings-insert-newlines settings))
+             (send debugging set-selection
+                   (case (simple-settings-annotations settings)
+                     [(none) 0]
+                     [(debug) 1]
+                     [(debug/profile) 2]
+                     [(test-coverage) 3]))])))
+
+      ;; simple-module-based-language-render-value/format : TST settings port (union #f (snip% -> void)) (union 'infinity number) -> void
+      (define (simple-module-based-language-render-value/format value settings port width)
+        (if (eq? (simple-settings-printing-style settings) 'current-print)
+            (parameterize ([current-output-port port])
+              ((current-print) value))
+            (let ([converted-value
+                   (simple-module-based-language-convert-value value settings)]
+                  [use-number-snip?
+                   (λ (x)
+                     (and (number? x)
+                          (exact? x)
+                          (real? x)
+                          (not (integer? x))))])
+              (parameterize ([pretty-print-columns width]
+                             [pretty-print-size-hook
+                              (λ (value display? port)
+                                (cond
+                                  [(is-a? value snip%) 1]
+                                  [(use-number-snip? value) 1]
+                                  [(syntax? value) 1]
+                                  [(to-snip-value? value) 1]
+                                  [else #f]))]
+                             [pretty-print-print-hook
+                              (λ (value display? port)
+                                (cond
+                                  [(is-a? value snip%)
+                                   (write-special value port)
+                                   1]
+                                  [(use-number-snip? value)
+                                   (write-special
+                                    (case (simple-settings-fraction-style settings)
+                                      [(mixed-fraction) 
+                                       (number-snip:make-fraction-snip value #f)]
+                                      [(mixed-fraction-e)
+                                       (number-snip:make-fraction-snip value #t)]
+                                      [(repeating-decimal)
+                                       (number-snip:make-repeating-decimal-snip value #f)]
+                                      [(repeating-decimal-e)
+                                       (number-snip:make-repeating-decimal-snip value #t)])
+                                    port)
+                                   1]
+                                  [(syntax? value)
+                                   (write-special (render-syntax/snip value))]
+                                  [else (write-special (value->snip value))]))]
+                             [print-graph
+                              ;; only turn on print-graph when using `write' printing 
+                              ;; style because the sharing is being taken care of
+                              ;; by the print-convert sexp construction when using
+                              ;; other printing styles.
+                              (and (eq? (simple-settings-printing-style settings) 'write)
+                                   (simple-settings-show-sharing settings))])
+                (cond
+                  [(simple-settings-insert-newlines settings)
+                   (if (number? width)
+                       (parameterize ([pretty-print-columns width])
+                         (pretty-print converted-value port))
+                       (pretty-print converted-value port))]
+                  [else
+                   (parameterize ([pretty-print-columns 'infinity])
+                     (pretty-print converted-value port))
+                   (newline port)])))))
+      
+      ;; drscheme-inspector : inspector
+      (define drscheme-inspector (current-inspector))
+      
+      ;; simple-module-based-language-convert-value : TST settings -> TST
+      (define (simple-module-based-language-convert-value value settings)
+        (case (simple-settings-printing-style settings)
+          [(write) value]
+          [(current-print) value]
+          [(constructor)
+           (parameterize ([constructor-style-printing #t]
+                          [show-sharing (simple-settings-show-sharing settings)]
+			  [current-print-convert-hook leave-snips-alone-hook])
+             (print-convert value))]
+          [(quasiquote)
+           (parameterize ([constructor-style-printing #f]
+                          [show-sharing (simple-settings-show-sharing settings)]
+			  [current-print-convert-hook leave-snips-alone-hook])
+             (print-convert value))]))
+      
+      ;; leave-snips-alone-hook : any? (any? -> printable) any? -> printable
+      (define (leave-snips-alone-hook expr basic-convert sub-convert)
+	(if (is-a? expr snip%)
+	    expr
+	    (basic-convert expr)))
+
+      ;; initialize-simple-module-based-language : setting ((-> void) -> void)
+      (define (initialize-simple-module-based-language setting run-in-user-thread)
+        (run-in-user-thread
+         (λ ()
+           (let ([annotations (simple-settings-annotations setting)])
+             (when (memq annotations '(debug debug/profile test-coverage))
+               (current-eval 
+                (drscheme:debug:make-debug-eval-handler
+                 (current-eval)))
+               (error-display-handler 
+                (drscheme:debug:make-debug-error-display-handler
+                 (error-display-handler))))
+             (drscheme:debug:profiling-enabled (eq? annotations 'debug/profile))
+             (drscheme:debug:test-coverage-enabled (eq? annotations 'test-coverage)))
+           (current-inspector (make-inspector))
+           (read-case-sensitive (simple-settings-case-sensitive setting)))))
+      
+      ;; simple-module-based-language-get-init-code : setting teachpack-cache -> sexp[module]
+      (define (simple-module-based-language-get-init-code setting teachpack-cache)
+        `(module mod-name mzscheme
+           (require (lib "pconvert.ss")
+                    (lib "pretty.ss"))
+           
+           (provide init-code)
+           
+           (define (executable-error-value->string-handler val size)
+             (let ([o (open-output-string)])
+               (render-value val o)
+               (let ([s (get-output-string o)])
+                 (if ((string-length s) . <= . size)
+                     s
+                     (string-append
+                      (substring s 0 (- size 3))
+                      "...")))))
+           
+           (define (render-value value port)
+             (parameterize ([pretty-print-columns 'infinity])
+               (pretty-print (convert-value value) port)))
+           
+           (define (convert-value value)
+             ,(case (simple-settings-printing-style setting)
+                [(write) `value]
+                [(current-print) `value]
+                [(constructor)
+                 `(parameterize ([constructor-style-printing #t]
+                                 [show-sharing ,(simple-settings-show-sharing setting)])
+                    (print-convert value))]
+                [(quasiquote)
+                 `(parameterize ([constructor-style-printing #f]
+                                 [show-sharing ,(simple-settings-show-sharing setting)])
+                    (print-convert value))]))
+           
+           ,(if (memq (simple-settings-annotations setting) '(debug debug/profile test-coverage))
+                `(require (lib "errortrace.ss" "errortrace"))
+                `(void))
+
+           (define (init-code)
+             ,(drscheme:teachpack:launcher-init-code teachpack-cache)
+             (current-inspector (make-inspector))
+             (error-value->string-handler executable-error-value->string-handler)
+             (read-case-sensitive ,(simple-settings-case-sensitive setting)))))
+      
+
+
+                                                                      
+               ;;;                                                    
+                 ;                                                    
+         ;       ;                                                    
+          ;      ;    ;;;;  ; ;;;    ;;; ;;;  ;;  ;;;;    ;;; ;  ;;;  
+           ;     ;        ;  ;;  ;  ;   ;  ;   ;      ;  ;   ;  ;   ; 
+ ;;;;;      ;    ;     ;;;;  ;   ;  ;   ;  ;   ;   ;;;;  ;   ;  ;;;;; 
+           ;     ;    ;   ;  ;   ;  ;   ;  ;   ;  ;   ;  ;   ;  ;     
+          ;      ;    ;   ;  ;   ;  ;   ;  ;   ;  ;   ;  ;   ;  ;   ; 
+         ;     ;;;;;;  ;;; ;;;;  ;;  ;;;;   ;;; ;  ;;; ;  ;;;;   ;;;  
+                                        ;                    ;        
+                                        ;                    ;        
+                                     ;;;                  ;;;         
+
+      
+      
+      ;; module-based-language->language : module-based-language -> language<%>
+      ;; given a module-based-language, implements a language
+      (define module-based-language->language-mixin
+	(mixin (module-based-language<%>) (language<%>)
+	  (inherit get-module get-transformer-module use-namespace-require/copy?
+                   get-init-code use-mred-launcher get-reader)
+
+          (define/public (get-comment-character) (values ";  " #\;))
+          (define/public (order-manuals x) (values x #t))
+          
+          (inherit get-language-position)
+          (define/public (get-language-name)
+            (let ([pos (get-language-position)])
+              (if (null? pos)
+                  "<<unknown>>"
+                  (car (last-pair pos)))))
+          (define/public (get-style-delta) #f)
+	  (define/override (on-execute setting run-in-user-thread)
+	    (super on-execute setting run-in-user-thread)
+            (initialize-module-based-language (use-namespace-require/copy?)
+                                              (get-module)
+                                              (get-transformer-module)
+                                              run-in-user-thread))
+          (define/public (front-end/complete-program port settings teachpack-cache)
+            (module-based-language-front-end port (get-reader)))
+          (define/public (front-end/interaction port settings teachpack-cache)
+            (module-based-language-front-end port (get-reader)))
+          (define/public (create-executable setting parent program-filename teachpacks)
+            (create-module-based-language-executable parent 
+                                                     program-filename
+                                                     (get-module)
+                                                     (get-transformer-module)
+                                                     (get-init-code setting teachpacks)
+                                                     (use-mred-launcher)
+                                                     (use-namespace-require/copy?)))
+          (super-instantiate ())))
+
+      ;; create-module-based-language-executable :  
+      ;; (is-a?/c area-container<%>) string module-spec module-spec sexp (union boolean? 'ask) boolean?
+      ;;  -> void
+      (define (create-module-based-language-executable parent
+                                                       program-filename
+                                                       module-language-spec
+                                                       transformer-module-language-spec
+                                                       init-code
+                                                       mred-launcher
+                                                       use-copy?)
+        (let ([executable-specs (create-executable-gui parent
+                                                       program-filename
+                                                       #t 
+						       (if (boolean? mred-launcher)
+							   (if mred-launcher
+							       'mred
+							       'mzscheme)
+							   #t))])
+          (when executable-specs
+            (let* ([type (car executable-specs)]
+                   [base (cadr executable-specs)]
+                   [executable-filename (caddr executable-specs)]
+                   [create-executable
+                    (if (eq? type 'launcher)
+                        create-module-based-launcher 
+                        create-module-based-stand-alone-executable)])
+              (create-executable
+               program-filename
+               executable-filename 
+               module-language-spec
+               transformer-module-language-spec
+               init-code
+               (if (boolean? mred-launcher)
+                   mred-launcher
+                   (eq? base 'mred))
+               use-copy?)))))
+      
+      
+      ;; create-executeable-gui : (union #f (is-a?/c top-level-area-container<%>))
+      ;;                          (union #f string?)
+      ;;                          (union #t 'launcher 'stand-alone)
+      ;;                          (union #t 'mzscheme 'mred)
+      ;;                       -> (union #f (list (union 'no-show 'launcher 'stand-alone)
+      ;;                                          (union 'no-show 'mzscheme 'mred)
+      ;;                                          string[filename]))
+      (define (create-executable-gui parent program-filename show-type show-base)
+        (define dlg (make-object dialog% (string-constant create-executable-title) parent))
+        (define filename-panel (make-object horizontal-panel% dlg))
+        (define filename-text-field (instantiate text-field% ()
+                                      (label (string-constant filename))
+                                      (parent filename-panel)
+                                      (init-value (path->string (default-executable-filename program-filename #t)))
+                                      (min-width 400)
+                                      (callback void)))
+        (define filename-browse-button (instantiate button% ()
+                                         (label (string-constant browse...))
+                                         (parent filename-panel)
+                                         (callback
+                                          (λ (x y) (browse-callback)))))
+        (define type/base/help-panel (instantiate horizontal-panel% ()
+                                       (parent dlg)
+                                       (alignment '(center center))))
+        (define type/base-panel (instantiate vertical-panel% ()
+                                  (parent type/base/help-panel)
+                                  (stretchable-width #f)))
+        (define type-panel (make-object horizontal-panel% type/base-panel))
+        (define type-rb (and (boolean? show-type)
+                             (instantiate radio-box% ()
+                               (label (string-constant executable-type))
+                               (choices (list (string-constant launcher)
+                                              (string-constant stand-alone)))
+                               (parent type-panel)
+                               (callback void))))
+        (define base-panel (make-object horizontal-panel% type/base-panel))
+        (define base-rb (and (boolean? show-base)
+                             (instantiate radio-box% ()
+                               (label (string-constant executable-base))
+                               (choices (list "MzScheme" "MrEd"))
+                               (parent base-panel)
+                               (callback void))))
+        
+        (define help-button (make-object button% 
+                              (string-constant help)
+                              type/base/help-panel
+                              (λ (x y)
+                                (drscheme:help-desk:goto-help "drscheme" "Executables"))))
+
+        (define button-panel (instantiate horizontal-panel% ()
+                               (parent dlg)
+                               (alignment '(right center))))
+        
+        (define-values (ok-button cancel-button)
+          (gui-utils:ok/cancel-buttons
+           button-panel
+           (λ (x y)
+             (cond
+               [(filename-ok?)
+                (set! cancelled? #f)
+                (send dlg show #f)]
+               [else (message-box (string-constant drscheme)
+                                  (string-constant please-choose-an-executable-filename)
+                                  dlg)]))
+           (λ (x y) (send dlg show #f))
+           (string-constant create)
+           (string-constant cancel)))
+
+        (define (browse-callback)
+          (let ([ftf (send filename-text-field get-value)])
+            (let-values ([(base name _) 
+                          (if (path-string? ftf)
+                              (split-path ftf)
+                              (values (current-directory) "" #f))])
+              (let* ([mzscheme? (currently-mzscheme-binary?)]
+                     [launcher? (currently-launcher?)]
+                     [filename 
+                      (put-executable/defaults
+                       dlg
+                       base
+                       name
+                       (not mzscheme?)
+                       launcher?
+                       (if launcher?
+                           (if mzscheme?
+                               (string-constant save-a-mzscheme-launcher)
+                               (string-constant save-a-mred-launcher))
+                           (if mzscheme?
+                               (string-constant save-a-mzscheme-stand-alone-executable)
+                               (string-constant save-a-mred-stand-alone-executable))))])
+                (when filename
+                  (send filename-text-field set-value filename))))))
+        
+        (define (currently-mzscheme-binary?)
+          (cond
+            [base-rb
+             (= 0 (send base-rb get-selection))]
+            [else (eq? show-base 'mzscheme)]))
+          
+        (define (currently-launcher?)
+          (cond
+            [type-rb
+             (= 0 (send type-rb get-selection))]
+            [else (eq? show-type 'launcher)]))
+        
+        (define (filename-ok?)
+          (let ([filename-str (send filename-text-field get-value)]
+                [launcher-is-dir?
+                 (cond
+                   [(currently-mzscheme-binary?)
+                    (mzscheme-launcher-is-directory?)]
+                   [else
+                    (mred-launcher-is-directory?)])])
+            (cond
+              [(string=? "" filename-str) #f]
+              [(or (directory-exists? filename-str)
+                   (file-exists? filename-str))
+               (ask-user-can-clobber? filename-str)]
+              [else #t])))
+           
+        ;; ask-user-can-clobber-directory? : (is-a?/c top-level-window<%>) string -> boolean
+        (define (ask-user-can-clobber? filename)
+          (message-box (string-constant drscheme)
+                       (format (string-constant are-you-sure-delete?) filename)
+                       dlg
+                       '(yes-no)))
+            
+        (define cancelled? #t)
+        
+        (send dlg show #t)
+        (cond
+          [cancelled? #f]
+          [else
+           (list
+            (if type-rb
+                (case (send type-rb get-selection)
+                  [(0) 'launcher]
+                  [(1) 'stand-alone])
+                'no-show)
+            (if base-rb
+                (case (send base-rb get-selection)
+                  [(0) 'mzscheme]
+                  [(1) 'mred])
+                'no-show)
+            (send filename-text-field get-value))]))
+
+      ;; put-executable : parent string boolean boolean -> (union false? string)
+      ;; invokes the put-file dialog with arguments specific to building executables
+      (define (put-executable parent program-filename launcher? mred? title)
+        (let-values ([(base name dir) (split-path program-filename)])
+          (let ([default-name (default-executable-filename name mred?)])
+            (put-executable/defaults
+             parent
+             base
+             default-name
+             launcher?
+             mred? 
+             title))))
+      
+      ;; put-executable/defaults : parent string string boolean boolean -> (union false? string)
+      (define (put-executable/defaults parent default-dir default-name launcher? mred? title)
+        (let-values ([(extension style filters)
+                      (if launcher?
+                          (if mred?
+                              (mred-launcher-put-file-extension+style+filters)
+                              (mzscheme-launcher-put-file-extension+style+filters))
+                          (embedding-executable-put-file-extension+style+filters mred?))])
+          (let* ([dir? (if launcher?
+                           (if mred?
+                               (mred-launcher-is-directory?)
+                               (mzscheme-launcher-is-directory?))
+                           (embedding-executable-is-directory? mred?))]
+                 [users-name
+                  (if dir?
+                      (get-directory title
+                                     parent
+                                     default-dir
+                                     style)
+                      (put-file title
+                                parent
+                                default-dir
+                                default-name
+                                extension
+                                style
+                                filters))])
+            (and users-name
+                 (users-name-ok? dir? parent users-name)
+                 (or (not dir?)
+                     (gui-utils:get-choice
+                      (format (string-constant warning-directory-will-be-replaced)
+                              users-name)
+                      (string-constant yes)
+                      (string-constant no)
+                      (string-constant drscheme)
+                      #f
+                      parent))
+                 users-name))))
+      
+      ;; users-name-ok? : boolean? (union #f frame% dialog%) string -> boolean
+      ;; returns #t if the string is an acceptable name for
+      ;; a saved executable, and #f otherwise.
+      (define (users-name-ok? dir? parent name)
+        (case (system-type)
+          [(macosx) 
+           (cond
+             [(not dir?) #t] ;; non dir executables are shell scripts and all names are okay
+             [(regexp-match #rx#".app$" (path->bytes name)) #t]
+             [else
+              (message-box (string-constant drscheme)
+                           (format
+                            (string-constant macosx-executables-must-end-with-app)
+                            name)
+                           parent)
+              #f])]
+          [(windows) 
+           (cond
+             [(regexp-match #rx#".exe$" (path->bytes name)) #t]
+             [else
+              (message-box (string-constant drscheme)
+                           (format (string-constant windows-executables-must-end-with-exe)
+                                   name)
+                           parent)
+              #f])]
+          [else #t]))
+      
+      ;; default-executable-filename : path -> path
+      (define (default-executable-filename program-filename mred?)
+        (let* ([ext (filename-extension program-filename)]
+               [program-bytename (path->bytes program-filename)]
+               ;; ext-less : bytes
+               [ext-less (if ext
+                             (subbytes program-bytename
+                                       0
+                                       (- (bytes-length program-bytename)
+                                          (bytes-length ext)
+                                          1 ;; sub1 for the period in the extension
+                                          ))
+                             program-bytename)])
+          (bytes->path
+           (case (system-type)
+             [(windows) (bytes-append ext-less #".exe")]
+             [(macosx) (if mred?
+                           (bytes-append ext-less #".app")
+                           ext-less)]
+             [else ext-less]))))
+      
+      ;; create-module-based-stand-alone-executable : ... -> void (see docs)
+      (define (create-module-based-stand-alone-executable program-filename 
+                                                          executable-filename
+                                                          module-language-spec
+                                                          transformer-module-language-spec
+                                                          init-code
+                                                          gui?
+                                                          use-copy?)
+        
+        (with-handlers ([(λ (x) #f) ;exn:fail?
+                         (λ (x)
+                           (message-box 
+                            (string-constant drscheme)
+                            (format "~a" (exn-message x)))
+                           (void))])
+          (define init-code-tmp-filename (make-temporary-file "drs-standalone-exectable-init~a"))
+          (define bootstrap-tmp-filename (make-temporary-file "drs-standalone-exectable-bootstrap~a"))
+          (let ([init-code-mod-name
+                 (let-values ([(base name dir?) 
+                               (split-path init-code-tmp-filename)])
+                   (string->symbol (path->string name)))])
+          
+            (call-with-output-file bootstrap-tmp-filename
+              (λ (port)
+                (write `(let () ;; cannot use begin, since it gets flattened to top-level (and re-compiled!)
+                          (,(if use-copy? 'namespace-require/copy 'namespace-require) ',module-language-spec)
+                          (namespace-transformer-require ',transformer-module-language-spec)
+                          ((dynamic-require ',init-code-mod-name 'init-code)))
+                       port))
+              'truncate
+              'text)
+            
+            (let ([new-init-code 
+                   (list*
+                    (car init-code)
+                    init-code-mod-name
+                    (cddr init-code))])
+              (call-with-output-file init-code-tmp-filename
+                (λ (port)
+                  (write new-init-code port))
+                'truncate 'text)))
+          
+          (let* ([pre-to-be-embedded-module-specs0
+                  (if (equal? module-language-spec transformer-module-language-spec)
+                      (list module-language-spec)
+                      (list module-language-spec
+                            transformer-module-language-spec))]
+                 [pre-to-be-embedded-module-specs1
+                  (if gui?
+                      (cons '(lib "mred.ss" "mred")
+                            pre-to-be-embedded-module-specs0)
+                      pre-to-be-embedded-module-specs0)]
+                 [pre-to-be-embedded-module-specs2
+                  (cons `(file ,(path->string init-code-tmp-filename))
+                        pre-to-be-embedded-module-specs1)]
+                 [pre-to-be-embedded-module-specs3
+                  (append (drscheme:teachpack:launcher-modules-to-embed
+                           (preferences:get 'drscheme:teachpacks))
+                          pre-to-be-embedded-module-specs2)]
+                 [pre-to-be-embedded-module-specs4
+                  (filter (λ (x) (not (eq? x 'mzscheme)))
+                          pre-to-be-embedded-module-specs3)]
+                 [to-be-embedded-module-specs
+                  (map (λ (x) (list #f x))
+                       pre-to-be-embedded-module-specs4)])
+
+            (make-embedding-executable 
+             executable-filename
+             gui?
+             #f ;; verbose?
+             to-be-embedded-module-specs
+             (list 
+              bootstrap-tmp-filename
+              program-filename)
+             #f
+             (if gui?
+                 (list "-mvqZ")
+                 (list "-mvq"))))
+          (delete-file init-code-tmp-filename)
+          (delete-file bootstrap-tmp-filename)
+          (void)))
+
+      (define (condense-scheme-code-string s)
+        (let ([i (open-input-string s)]
+              [o (open-output-string)])
+          (let loop ()
+            (let ([c (read-char i)])
+              (unless (eof-object? c)
+                (let ([next (λ ()
+                              (display c o)
+                              (loop))])
+                  (case c
+                    [(#\space)
+                     (if (char=? #\( (peek-char i))
+                         (loop)
+                         (next))]
+                    [(#\))
+                     (if (eq? #\space (peek-char i))
+                         (begin
+                           (display #\) o)
+                           (read-char i)
+                           (loop))
+                         (next))]
+                    [(#\\)
+                     (begin
+                       (display #\\ o)
+                       (display (read-char i) o)
+                       (loop))]
+                    [(#\" #\|)
+                     (display c o)
+                     (let loop ()
+                       (let ([v (read-char i)])
+                         (cond
+                           [(eq? v c) (next)]
+                           [(eq? v #\\)
+                            (display v o)
+                            (display (read-char i) o)
+                            (loop)]
+                           [else (display v o)
+                                 (loop)])))]
+                    [else (next)])))))
+          (get-output-string o)))
+      
+      (define (create-module-based-launcher program-filename 
+                                            executable-filename
+                                            module-language-spec
+                                            transformer-module-language-spec
+                                            init-code
+                                            gui?
+                                            use-copy?)
+
+        (with-handlers ([(λ (x) #f) ;exn:fail?
+                         (λ (x)
+                           (message-box 
+                            (string-constant drscheme)
+                            (format "~a" (exn-message x)))
+                           (void))])
+          
+          ((if gui? make-mred-launcher make-mzscheme-launcher)
+           (list
+            "-qmvt"
+            (path->string
+             (build-path (collection-path "drscheme" "private") 
+                         "launcher-bootstrap.ss"))
+            "--"
+            (condense-scheme-code-string (format "~s" init-code))
+            (path->string program-filename)
+            (format "~s" module-language-spec)
+            (format "~s" transformer-module-language-spec)
+            (format "~s" use-copy?)
+            (format "~s" (if gui?  
+                             (list 'mzscheme '(lib "mred.ss" "mred"))
+                             (list 'mzscheme))))
+           (path->string executable-filename))))
+      
+      ;; initialize-module-based-language : boolean module-spec module-spec ((-> void) -> void)
+      (define (initialize-module-based-language use-copy?
+                                                module-spec
+                                                transformer-module-spec
+                                                run-in-user-thread)
+        (run-in-user-thread
+         (λ ()
+           (with-handlers ([(λ (x) #t)
+                            (λ (x)
+                              (display (exn-message x))
+                              (newline))])
+	     (if use-copy?
+		 (namespace-require/copy module-spec)
+		 (namespace-require module-spec))
+	     (namespace-transformer-require transformer-module-spec)))))
+
+      ;; module-based-language-front-end : (port reader -> (-> (union sexp syntax eof)))
+      ;; type reader = type-spec-of-read-syntax (see mz manual for details)
+      (define (module-based-language-front-end port reader)
+        (λ () 
+          (reader (object-name port) port)))
+      
+      
+      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;
+      ;;  snip/value extensions
+      ;;
+      
+      (define to-snips null)
+      (define-struct to-snip (predicate? >value))
+      (define (add-snip-value predicate constructor)
+        (set! to-snips (cons (make-to-snip predicate constructor) to-snips)))
+      
+      (define (value->snip v)
+        (ormap (λ (to-snip) (and ((to-snip-predicate? to-snip) v)
+                                      ((to-snip->value to-snip) v)))
+               to-snips))
+      (define (to-snip-value? v)
+        (ormap (λ (to-snip) ((to-snip-predicate? to-snip) v)) to-snips))
+      
+      
+
+                                                                      
+                                             ;                        
+                ;                                                     
+                ;                                                     
+  ;;;  ;;; ;;; ;;;;;   ;;;  ; ;;;    ;;;   ;;;     ;;;  ; ;;;    ;;;  
+ ;   ;   ; ;    ;     ;   ;  ;;  ;  ;   ;    ;    ;   ;  ;;  ;  ;   ; 
+ ;;;;;    ;     ;     ;;;;;  ;   ;   ;;;     ;    ;   ;  ;   ;   ;;;  
+ ;       ; ;    ;     ;      ;   ;      ;    ;    ;   ;  ;   ;      ; 
+ ;   ;  ;   ;   ;   ; ;   ;  ;   ;  ;   ;    ;    ;   ;  ;   ;  ;   ; 
+  ;;;  ;;   ;;   ;;;   ;;;  ;;;  ;;  ;;;   ;;;;;   ;;;  ;;;  ;;  ;;;  
+                                                                      
+                                                                      
+
+      (define language-extensions null)
+      (define (get-language-extensions) 
+        (drscheme:tools:only-in-phase
+         'drscheme:language:get-default-mixin
+         'phase2)
+        language-extensions)
+
+      (define (default-mixin x) x)
+      (define (get-default-mixin)
+        (drscheme:tools:only-in-phase
+         'drscheme:language:get-default-mixin
+         'phase2)
+        default-mixin)
+      
+      (define (extend-language-interface extension<%> default-impl)
+        (drscheme:tools:only-in-phase
+         'drscheme:language:extend-language-interface
+         'phase1)
+        (set! default-mixin (compose default-impl default-mixin))
+        (set! language-extensions (cons extension<%> language-extensions))))))
+
diff --git a/collects/drscheme/private/launcher-bootstrap.ss b/collects/drscheme/private/launcher-bootstrap.ss
new file mode 100644
index 0000000000..f83a980078
--- /dev/null
+++ b/collects/drscheme/private/launcher-bootstrap.ss
@@ -0,0 +1,51 @@
+(module launcher-bootstrap mzscheme
+  (require (lib "string.ss")
+           (lib "file.ss"))
+  
+  (define argv (current-command-line-arguments))
+  ;; skip first six
+  (define program-argv (list->vector (cddr (cddddr (vector->list argv)))))
+  
+  (define init-code (read-from-string (vector-ref argv 0)))
+  (define program-filename (vector-ref argv 1))
+  (define language-module-spec (read-from-string (vector-ref argv 2)))
+  (define transformer-module-spec (read-from-string (vector-ref argv 3)))
+  (define use-require/copy? (read-from-string (vector-ref argv 4)))
+  (define to-be-copied-module-specs (read-from-string (vector-ref argv 5)))
+  
+  (define to-be-copied-module-names
+        (let ([get-name
+               (λ (spec)
+                 (if (symbol? spec)
+                     spec
+                     ((current-module-name-resolver) spec #f #f)))])
+          (map get-name to-be-copied-module-specs)))
+  
+  (define init-code-tmp-filename (make-temporary-file "drs-launcher-init~a"))
+  (define-values (_1 init-code-mod-name _2) (split-path init-code-tmp-filename))
+
+  (set-car! (cdr init-code) (string->symbol (path->string init-code-mod-name)))
+
+  (call-with-output-file init-code-tmp-filename
+    (λ (port)
+      (write init-code port))
+    'truncate 'text)
+  
+  (define init-code-proc (dynamic-require init-code-tmp-filename 'init-code))
+  
+  (define original-namespace (current-namespace))
+  (current-namespace (make-namespace 'empty))
+  (for-each (λ (x) (namespace-attach-module original-namespace x))
+            to-be-copied-module-names)
+  (namespace-set-variable-value! 'argv program-argv)
+  (current-command-line-arguments program-argv)
+  ((if use-require/copy? namespace-require/copy namespace-require)
+   language-module-spec)
+  (namespace-transformer-require transformer-module-spec)
+
+  (init-code-proc)
+
+  ;; safe to do this earlier?
+  (delete-file init-code-tmp-filename)
+
+  (load program-filename))
\ No newline at end of file
diff --git a/collects/drscheme/private/link.ss b/collects/drscheme/private/link.ss
new file mode 100644
index 0000000000..229f9d450c
--- /dev/null
+++ b/collects/drscheme/private/link.ss
@@ -0,0 +1,68 @@
+(module link mzscheme
+  (require "modes.ss"
+           "font.ss"
+           "eval.ss"
+           "module-overview.ss"
+           "multi-file-search.ss"
+           "debug.ss"
+           "module-language.ss"
+           "teachpack.ss"
+	   "tools.ss"
+           (lib "unitsig.ss")
+	   "language.ss"
+           "language-configuration.ss"
+           "drsig.ss"
+	   "init.ss"
+           "text.ss"
+           "app.ss"
+           "main.ss"
+           "rep.ss"
+           "frame.ss"
+           "unit.ss"
+           "get-extend.ss"
+           "help-desk.ss")
+  (provide drscheme@)
+  
+  (define drscheme@
+    (compound-unit/sig
+      (import)
+      (link [init : drscheme:init^ (init@)]
+            [tools : drscheme:tools^ 
+                   (tools@ frame unit rep get/extend language
+                           (language-configuration : drscheme:language-configuration^)
+                           help-desk init debug eval teachpack modes)]
+            [modes : drscheme:modes^ (modes@)]
+            [text : drscheme:text^ (text@)]
+            [teachpack : drscheme:teachpack^ (teachpack@)]
+            [eval : drscheme:eval^ (eval@ language-configuration rep init language teachpack)]
+            [frame : drscheme:frame^ (frame@ unit app help-desk multi-file-search init)]
+            [rep : drscheme:rep^
+                 (rep@ init language-configuration language app 
+                     frame unit text help-desk teachpack debug eval)]
+            [language : drscheme:language^ (language@ debug teachpack tools help-desk)]
+            [module-overview : drscheme:module-overview^ 
+                             (module-overview@ frame eval language-configuration language)]
+            [unit : drscheme:unit^ 
+                  (unit@ help-desk app frame text rep language-configuration language
+                       get/extend teachpack module-overview tools eval init
+                       module-language modes)]
+            [debug : drscheme:debug^
+                   (debug@ rep frame unit language language-configuration init)]
+            [multi-file-search : drscheme:multi-file-search^ (multi-file-search@ frame unit)]
+            [get/extend : drscheme:get/extend^ (get-extend@ unit frame rep debug)]
+            [language-configuration : drscheme:language-configuration/internal^ 
+                                    (language-configuration@ unit rep teachpack
+                                                           init language app
+                                                           tools help-desk)]
+            [font : drscheme:font^ (font@ language-configuration)]
+            [module-language : drscheme:module-language^ 
+                             (module-language@ language-configuration language unit rep)]
+            [help-desk : drscheme:help-desk^ (help-desk@ frame language-configuration teachpack)]
+	    [app : drscheme:app^ (app@ unit frame language-configuration help-desk tools)]
+            [main : () (main@ 
+                        app unit get/extend language-configuration language teachpack
+                        module-language tools debug frame font
+                        modes)])
+      (export
+       (unit teachpack drscheme:teachpack)
+       (unit language-configuration drscheme:language-configuration)))))
diff --git a/collects/drscheme/private/main.ss b/collects/drscheme/private/main.ss
new file mode 100644
index 0000000000..2c8d72a2ec
--- /dev/null
+++ b/collects/drscheme/private/main.ss
@@ -0,0 +1,391 @@
+
+(module main mzscheme
+  (require (lib "string-constant.ss" "string-constants")
+           (lib "unitsig.ss")
+           "drsig.ss"
+	   (lib "mred.ss" "mred")
+           (lib "framework.ss" "framework")
+           (lib "unitsig.ss")
+           (lib "class.ss")
+           (prefix pretty-print: (lib "pretty.ss"))
+           (prefix print-convert: (lib "pconvert.ss"))
+	   (lib "include.ss")
+           (lib "list.ss")
+           (lib "file.ss")
+           (lib "external.ss" "browser")
+           (lib "plt-installer.ss" "setup"))
+  
+  (provide main@)
+  (define argv (current-command-line-arguments))
+  
+  (define main@
+    (unit/sig ()
+      (import [drscheme:app : drscheme:app^]
+              [drscheme:unit : drscheme:unit^]
+              [drscheme:get/extend : drscheme:get/extend^]
+              [drscheme:language-configuration : drscheme:language-configuration/internal^]
+	      [drscheme:language : drscheme:language^]
+              [drscheme:teachpack : drscheme:teachpack^]
+              [drscheme:module-language : drscheme:module-language^]
+              [drscheme:tools : drscheme:tools^]
+              [drscheme:debug : drscheme:debug^]
+              [drscheme:frame : drscheme:frame^]
+              [drscheme:font : drscheme:font^]
+              [drscheme:modes : drscheme:modes^])
+
+      (application-file-handler
+       (let ([default (application-file-handler)])
+         (λ (name)
+           (if (null? (get-top-level-windows))
+               (handler:edit-file name)
+               (default name)))))
+      
+      (application-quit-handler
+       (let ([default (application-quit-handler)])
+         (λ ()
+           (if (null? (get-top-level-windows))
+               (when (exit:user-oks-exit)
+                 (exit:exit))
+               (default)))))
+      
+      (application-about-handler
+       (λ ()
+         (drscheme:app:about-drscheme)))
+
+      (drscheme:modes:add-initial-modes)
+      
+      (namespace-set-variable-value! 'help-desk:frame-mixin drscheme:frame:basics-mixin)
+      
+      (finder:default-filters (list* '("Scheme (.scm)" "*.scm")
+                                     '("Scheme (.ss)" "*.ss")
+                                     (finder:default-filters)))
+      (application:current-app-name (string-constant drscheme))
+      
+      (preferences:set-default 'drscheme:show-interactions-on-execute #t boolean?)
+      (preferences:set-default 'drscheme:open-in-tabs #f boolean?)
+      (preferences:set-default 'drscheme:toolbar-shown #t boolean?)
+      (preferences:set-default 'drscheme:user-defined-keybindings '() (λ (x) (and (list? x) (andmap path? x))))
+      (preferences:set-un/marshall 
+       'drscheme:user-defined-keybindings
+       (λ (in) (map path->bytes in))
+       (λ (ex) (if (and (list? ex)
+                             (andmap bytes? ex))
+                        (map bytes->path ex)
+                        '())))
+      
+      (let ([number-between-zero-and-one?
+             (λ (x) (and (number? x) (<= 0 x 1)))])
+        (preferences:set-default 'drscheme:unit-window-size-percentage 
+                                 1/2 
+                                 number-between-zero-and-one?)
+        (preferences:set-default 'drscheme:module-browser-size-percentage
+                                 1/5
+                                 number-between-zero-and-one?))
+      (preferences:set-default 'drscheme:module-browser:name-length 1 
+                               (λ (x) (memq x '(0 1 2))))
+      
+      (let ([frame-width 600]
+            [frame-height 650]
+            [window-trimming-upper-bound-width 20]
+            [window-trimming-upper-bound-height 50])
+        (let-values ([(w h) (get-display-size)])
+          (set! frame-width (min frame-width (- w window-trimming-upper-bound-width)))
+          (set! frame-height (min frame-height (- h window-trimming-upper-bound-height))))
+        (preferences:set-default 'drscheme:unit-window-width frame-width number?)
+        (preferences:set-default 'drscheme:unit-window-height frame-height number?))
+      
+      (preferences:set-default 'drscheme:backtrace-window-width 400 number?)
+      (preferences:set-default 'drscheme:backtrace-window-height 300 number?)
+      (preferences:set-default 'drscheme:backtrace-window-x 0 number?)
+      (preferences:set-default 'drscheme:backtrace-window-y 0 number?)
+
+      (preferences:set-default 'drscheme:profile-how-to-count 'time
+                               (λ (x)
+                                 (memq x '(time count))))
+      (preferences:set-default 'drscheme:profile:low-color
+                               (make-object color% 150 255 150)
+                               (λ (x) (is-a? x color%)))
+      (preferences:set-default 'drscheme:profile:high-color
+                               (make-object color% 255 150 150)
+                               (λ (x) (is-a? x color%)))
+      (preferences:set-default 'drscheme:profile:scale
+                               'linear
+                               (λ (x) (memq x '(sqrt linear square))))
+
+      (preferences:set-default 'drscheme:test-coverage-ask-about-clearing? #t boolean?)
+
+      ;; size is in editor positions
+      (preferences:set-default 'drscheme:repl-buffer-size 
+                               '(#t . 1000)
+                               (λ (x)
+                                 (and (pair? x)
+                                      (boolean? (car x))
+                                      (integer? (cdr x))
+                                      (<= 1 (cdr x) 10000))))
+      
+      (let ([marshall-color 
+             (λ (c)
+               (list (send c red) (send c green) (send c blue)))]
+            [unmarshall-color
+             (λ (l)
+               (if (and (list? l) 
+                        (= 3 (length l))
+                        (andmap (λ (x) (and number? (<= 0 x 255)))
+                                l))
+                   (make-object color% (car l) (cadr l) (caddr l))
+                   (make-object color% 0 0 0)))])
+        (preferences:set-un/marshall 
+         'drscheme:profile:low-color
+         marshall-color
+         unmarshall-color)
+        (preferences:set-un/marshall 
+         'drscheme:profile:high-color
+         marshall-color
+         unmarshall-color))
+      
+      (preferences:set-default 
+       'drscheme:keybindings-window-size
+       (cons 200 400)
+       (λ (x) (and (pair? x)
+                        (number? (car x))
+                        (number? (cdr x)))))
+      
+      (preferences:set-default
+       'drscheme:execute-warning-once
+       #f
+       (λ (x)
+         (or (eq? x #t)
+             (not x))))
+      
+      (preferences:set-default
+       'drscheme:teachpacks
+       (drscheme:teachpack:new-teachpack-cache) 
+       drscheme:teachpack:teachpack-cache?)
+      (preferences:set-un/marshall
+       'drscheme:teachpacks
+       drscheme:teachpack:marshall-teachpack-cache
+       drscheme:teachpack:unmarshall-teachpack-cache)
+      
+      (drscheme:font:setup-preferences)
+      (color-prefs:add-background-preferences-panel)
+      (scheme:add-preferences-panel)
+      (scheme:add-coloring-preferences-panel)
+      (preferences:add-editor-checkbox-panel)
+      (preferences:add-warnings-checkbox-panel)
+      (preferences:add-scheme-checkbox-panel)
+      
+      (let ([make-check-box
+             (λ (pref-sym string parent)
+               (let ([q (make-object check-box%
+                          string
+                          parent
+                          (λ (checkbox evt)
+                            (preferences:set 
+                             pref-sym 
+                             (send checkbox get-value))))])
+                 (preferences:add-callback pref-sym (λ (p v) (send q set-value v)))
+                 (send q set-value (preferences:get pref-sym))))])
+        (preferences:add-to-editor-checkbox-panel
+         (λ (editor-panel)
+           (make-check-box 'drscheme:open-in-tabs 
+                           (string-constant open-files-in-tabs)
+                           editor-panel)
+           (make-check-box 'drscheme:show-interactions-on-execute 
+                           (string-constant show-interactions-on-execute)
+                           editor-panel)
+
+           ;; come back to this one.
+           #;
+           (letrec ([hp (new horizontal-panel% 
+                             (parent editor-panel)
+                             (alignment '(left top))
+                             (stretchable-height #f))]
+                    [cb (new check-box%
+                             (label (string-constant limit-interactions-size))
+                             (parent hp)
+                             (callback (λ (cb v) (cb-callback))))]
+                    [sl (new slider% 
+                             (label #f)
+                             (parent hp)
+                             (min-value 1)
+                             (max-value 10000)
+                             (callback
+                              (λ (sl _) (sl-callback))))]
+                    [cb-callback
+                     (λ ()
+                       (preferences:set 'drscheme:repl-buffer-size
+                                        (cons (send cb get-value)
+                                              (cdr (preferences:get 'drscheme:repl-buffer-size)))))]
+                    [sl-callback
+                     (λ ()
+                       (preferences:set 'drscheme:repl-buffer-size
+                                        (cons (car (preferences:get 'drscheme:repl-buffer-size))
+                                              (send sl get-value))))]
+                    [update-controls
+                     (λ (v)
+                       (let ([on? (car v)])
+                         (send sl enable on?)
+                         (send cb set-value on?)
+                         (send sl set-value (cdr v))))])
+             (preferences:add-callback 'drscheme:repl-buffer-size (λ (p v) (update-controls v)))
+             (update-controls (preferences:get 'drscheme:repl-buffer-size)))))
+        
+        (preferences:add-to-warnings-checkbox-panel
+         (λ (warnings-panel)
+           (make-check-box 'drscheme:execute-warning-once 
+                           (string-constant only-warn-once)
+                           warnings-panel)
+           (make-check-box 'drscheme:test-coverage-ask-about-clearing?
+                           (string-constant test-coverage-ask?)
+                           warnings-panel))))
+      (drscheme:debug:add-prefs-panel)
+      (install-help-browser-preference-panel)
+
+      (handler:current-create-new-window
+       (let ([drscheme-current-create-new-window
+	      (λ (filename)
+		(drscheme:unit:open-drscheme-window filename))])
+	 drscheme-current-create-new-window))
+
+      ;; add a handler to open .plt files.
+      (handler:insert-format-handler 
+       "PLT Files"
+       (λ (filename)
+         (and (equal? "plt" (filename-extension filename))
+              (gui-utils:get-choice 
+               (format (string-constant install-plt-file) filename)
+               (string-constant install-plt-file/yes)
+               (string-constant install-plt-file/no))))
+       (λ (filename)
+         (run-installer filename)
+	 #f))
+      
+      (drscheme:tools:load/invoke-all-tools
+       (λ ()
+         (void))
+       (λ ()
+         (drscheme:language-configuration:add-built-in-languages)
+         (drscheme:module-language:add-module-language)
+         (drscheme:language-configuration:add-info-specified-languages)))
+      
+      ;; no more extension after this point
+      (drscheme:get/extend:get-interactions-canvas)
+      (drscheme:get/extend:get-definitions-canvas)
+      (drscheme:get/extend:get-unit-frame)
+      (drscheme:get/extend:get-interactions-text)
+      (drscheme:get/extend:get-definitions-text)
+      (drscheme:language-configuration:get-languages)
+      
+      ;; this default can only be set *after* the
+      ;; languages have all be registered by tools
+      (preferences:set-default
+       drscheme:language-configuration:settings-preferences-symbol
+       (drscheme:language-configuration:get-default-language-settings)
+       drscheme:language-configuration:language-settings?)
+      
+      ;; if the unmarshaller returns #f, that will fail the
+      ;; test for this preference, reverting back to the default.
+      ;; In that case, the default is specified in the pref.ss file
+      ;; of the default collection and may not be the default
+      ;; specified below.
+      (preferences:set-un/marshall
+       drscheme:language-configuration:settings-preferences-symbol
+       (λ (x)
+	 (let ([lang (drscheme:language-configuration:language-settings-language x)]
+	       [settings (drscheme:language-configuration:language-settings-settings x)])
+	   (list (send lang get-language-position)
+		 (send lang marshall-settings settings))))
+       (λ (x)
+	 (and (list? x)
+	      (= 2 (length x))
+	      (let* ([lang-position (first x)]
+		     [marshalled-settings (second x)]
+		     [lang (ormap
+			    (λ (x)
+			      (and (equal? lang-position
+					   (send x get-language-position))
+				   x))
+			    (drscheme:language-configuration:get-languages))])
+		(and lang
+		     (let ([settings (send lang unmarshall-settings marshalled-settings)])
+		       (drscheme:language-configuration:make-language-settings
+			lang
+			(or settings (send lang default-settings)))))))))
+      
+      (let ([drs-handler-recent-items-super%
+             (class (drscheme:frame:basics-mixin
+                     (frame:standard-menus-mixin
+                      frame:basic%))
+               (define/override (edit-menu:between-select-all-and-find menu)
+                 (void))
+               (super-new))])
+      (handler:set-recent-items-frame-superclass drs-handler-recent-items-super%))
+      
+      ;;
+      ;; Show expanded language dialog when version changes
+      ;; 
+      (preferences:set-default 'drscheme:last-version #f (λ (x) (or (string? x) (not x))))
+      (preferences:set-default 'drscheme:last-language #f (λ (x) (or (symbol? x) (not x))))
+
+      (cond
+        [(current-eventspace-has-menu-root?)
+         (drscheme:frame:create-root-menubar)
+         (preferences:set 'framework:exit-when-no-frames #f)]
+        [else
+         (preferences:set 'framework:exit-when-no-frames #t)])
+      
+      
+      (drscheme:app:check-new-version)
+      
+      ;;
+      ;; Check for any files lost last time.
+      ;; Ignore the framework's empty frames test, since
+      ;;   the autosave information window may appear and then
+      ;;   go away (leaving no frames temporarily) but we are
+      ;;   not going to be exiting yet.
+      (autosave:restore-autosave-files/gui)
+     
+      ;; install user's keybindings
+      (for-each keymap:add-user-keybindings-file (preferences:get 'drscheme:user-defined-keybindings))
+      
+      ;; the initial window doesn't set the 
+      ;; unit object's state correctly, yet.
+      (define (make-basic)
+	(let* ([frame (drscheme:unit:open-drscheme-window)]
+	       [interactions-edit (send frame get-interactions-text)]
+	       [definitions-edit (send frame get-interactions-text)]
+	       [filename (send definitions-edit get-filename)])
+	  (unless filename
+	    (send frame update-shown)
+	    (send (send frame get-interactions-canvas) focus))
+          (send frame show #t)))
+      
+      (define (remove-duplicates files)
+        (let loop ([files files])
+          (cond
+            [(null? files) null]
+            [else (if (member (car files) (cdr files))
+                      (loop (cdr files))
+                      (cons (car files) (loop (cdr files))))])))
+      
+      (let* ([files-to-open (reverse (vector->list argv))]
+             [normalized/filtered
+              (let loop ([files files-to-open])
+                (cond
+                  [(null? files) null]
+                  [else (let ([file (car files)])
+                          (if (file-exists? file)
+                              (cons (normalize-path file) (loop (cdr files)))
+                              (begin
+                                (message-box
+                                 (string-constant drscheme)
+                                 (format (string-constant cannot-open-because-dne) file))
+                                (loop (cdr files)))))]))]
+             [no-dups (remove-duplicates normalized/filtered)]
+	     [frames
+	      (map (λ (f) (handler:edit-file
+				f
+				(λ () (drscheme:unit:open-drscheme-window f))))
+		   no-dups)])
+	(when (null? (filter (λ (x) x) frames))
+	  (make-basic))))))
diff --git a/collects/drscheme/private/modes.ss b/collects/drscheme/private/modes.ss
new file mode 100644
index 0000000000..3229d5ff1e
--- /dev/null
+++ b/collects/drscheme/private/modes.ss
@@ -0,0 +1,42 @@
+(module modes mzscheme
+  (require (lib "unitsig.ss")
+           (lib "string-constant.ss" "string-constants")
+           (lib "class.ss")
+           (lib "framework.ss" "framework")
+           "drsig.ss")
+  
+  (provide modes@)
+  
+  (define modes@
+    (unit/sig drscheme:modes^
+      (import)
+      
+      (define-struct mode (name surrogate repl-submit matches-language))
+      (define modes (list))
+      
+      (define (get-modes) modes)
+      
+      (define (add-mode name surrogate repl-submit matches-language)
+        (let ([new-mode (make-mode name 
+                                   surrogate
+                                   repl-submit
+                                   matches-language)])
+          (set! modes (cons new-mode modes))
+          new-mode))
+      
+      (define (add-initial-modes)
+        
+        ;; must be added first, to make it last in mode list,
+        ;; since predicate matches everything
+        (add-mode 
+         (string-constant scheme-mode)
+         (new scheme:text-mode%)
+         (λ (text prompt-position) (scheme:text-balanced? text prompt-position))
+         (λ (l) #t))
+        
+        (add-mode 
+         (string-constant text-mode)
+         #f
+         (λ (text prompt-position) #t)
+         (λ (l) 
+           (and l (ormap (λ (x) (regexp-match #rx"Algol" x)) l))))))))
diff --git a/collects/drscheme/private/module-language.ss b/collects/drscheme/private/module-language.ss
new file mode 100644
index 0000000000..68d3f84cbf
--- /dev/null
+++ b/collects/drscheme/private/module-language.ss
@@ -0,0 +1,538 @@
+
+(module module-language mzscheme
+  (provide module-language@)
+  (require (lib "unitsig.ss")
+           (lib "class.ss")
+           (lib "list.ss")
+           (lib "mred.ss" "mred")
+           (lib "embed.ss" "compiler")
+           (lib "launcher.ss" "launcher")
+           (lib "framework.ss" "framework")
+           (lib "string-constant.ss" "string-constants")
+           "drsig.ss"
+           (lib "contract.ss"))
+  
+  (define op (current-output-port))
+  (define (oprintf . args) (apply fprintf op args))
+  
+  (define module-language@
+    (unit/sig drscheme:module-language^
+      (import [drscheme:language-configuration : drscheme:language-configuration/internal^]
+              [drscheme:language : drscheme:language^]
+              [drscheme:unit : drscheme:unit^]
+              [drscheme:rep : drscheme:rep^])
+
+      (define module-language<%> 
+        (interface ()
+          ))
+      
+      ;; add-module-language : -> void
+      ;; adds the special module-only language to drscheme
+      (define (add-module-language)
+        (define module-language%
+          (module-mixin
+           ((drscheme:language:get-default-mixin)
+            (drscheme:language:module-based-language->language-mixin
+             (drscheme:language:simple-module-based-language->module-based-language-mixin
+              drscheme:language:simple-module-based-language%)))))
+        (drscheme:language-configuration:add-language
+         (instantiate module-language% ())))
+      
+      ;; collection-paths : (listof (union 'default string))
+      ;; command-line-args : (vectorof string)
+      (define-struct (module-language-settings drscheme:language:simple-settings)
+                     (collection-paths command-line-args))
+      
+      ;; module-mixin : (implements drscheme:language:language<%>)
+      ;;             -> (implements drscheme:language:language<%>)
+      (define (module-mixin %)
+        (class* % (module-language<%>)
+          (define/override (use-namespace-require/copy?) #t)
+          (field [iteration-number 0])
+          
+          ;; config-panel : as in super class
+          ;; uses drscheme:language:simple-module-based-language-config-panel
+          ;; and adds a collection paths configuration to it.
+          (define/override (config-panel parent)
+            (module-language-config-panel parent))
+          
+          (define/override (default-settings)
+            (let ([super-defaults (super default-settings)])
+              (apply make-module-language-settings
+                     (append
+                      (vector->list (drscheme:language:simple-settings->vector super-defaults))
+                      (list '(default)
+                            #())))))
+          
+          ;; default-settings? : -> boolean
+          (define/override (default-settings? settings)
+            (and (super default-settings? settings)
+                 (and (equal? (module-language-settings-collection-paths settings)
+                              '(default))
+                      (eq? (module-language-settings-command-line-args settings)
+                           #()))))
+          
+          (define/override (marshall-settings settings)
+            (let ([super-marshalled (super marshall-settings settings)])
+              (list super-marshalled
+                    (module-language-settings-collection-paths settings)
+                    (module-language-settings-command-line-args settings))))
+          
+          (define/override (unmarshall-settings marshalled)
+            (and (pair? marshalled)
+                 (pair? (cdr marshalled))
+                 (pair? (cddr marshalled))
+                 (null? (cdddr marshalled))
+                 (list? (cadr marshalled))
+                 (vector? (caddr marshalled))
+                 (andmap string? (vector->list (caddr marshalled)))
+                 (andmap (λ (x) (or (string? x) (symbol? x)))
+                         (cadr marshalled))
+                 (let ([super (super unmarshall-settings (car marshalled))])
+                   (and super
+                        (apply make-module-language-settings
+                               (append 
+                                (vector->list (drscheme:language:simple-settings->vector super))
+                                (list (cadr marshalled)
+                                      (caddr marshalled))))))))
+          
+          (define/override (on-execute settings run-in-user-thread)
+            (set! iteration-number 0)
+            (super on-execute settings run-in-user-thread)
+            (run-in-user-thread
+             (λ ()
+               (current-command-line-arguments (module-language-settings-command-line-args settings))
+               (let ([default (current-library-collection-paths)])
+                 (current-library-collection-paths
+                  (apply 
+                   append
+                   (map (λ (x) (if (symbol? x)
+                                        default
+                                        (list x)))
+                        (module-language-settings-collection-paths settings))))))))
+
+          (define/override (get-one-line-summary)
+            (string-constant module-language-one-line-summary))
+          
+          (define/override (get-style-delta) module-language-style-delta)
+          
+          (define/override (front-end/complete-program port settings teachpack-cache)
+            (let ([super-thunk (super front-end/complete-program port settings teachpack-cache)]
+                  [filename (get-filename port)]
+                  [module-name #f])
+              (λ ()
+                (set! iteration-number (+ iteration-number 1))
+                (let ([super-result (super-thunk)])
+                  (cond
+                    [(= iteration-number 1)
+                     (if (eof-object? super-result)
+                         (raise-syntax-error
+                          'module-language
+                          "the definitions window must contain a module")
+                         (let-values ([(name new-module)
+                                       (transform-module
+                                        filename
+                                        (expand super-result)
+                                        super-result)])
+                           (set! module-name name)
+                           new-module))]
+                    [(= 2 iteration-number)
+                     (if (eof-object? super-result)
+                         (with-syntax ([name 
+                                        ;; "clearing out" the module-name in this fashion ensures
+                                        ;; that check syntax doesn't think the original module name
+                                        ;; is being used in this require (so it doesn't get turned
+                                        ;; red)
+                                        (datum->syntax-object #'here (syntax-object->datum module-name))])
+                           (syntax (require name)))
+                         (raise-syntax-error
+                          'module-language
+                          "there can only be one expression in the definitions window"
+                          super-result))]
+                    [(= 3 iteration-number)
+                     (with-syntax ([name 
+                                        ;; "clearing out" the module-name in this fashion ensures
+                                        ;; that check syntax doesn't think the original module name
+                                        ;; is being used in this require (so it doesn't get turned
+                                        ;; red)
+                                        (datum->syntax-object #'here (syntax-object->datum module-name))])
+                       (syntax (current-namespace (module->namespace 'name))))]
+                    [else eof])))))
+          
+          ;; printer settings are just ignored here.
+          (define/override (create-executable setting parent program-filename teachpacks)
+            (let* ([executable-specs (drscheme:language:create-executable-gui
+                                      parent 
+                                      program-filename
+                                      #t
+                                      #t)])
+              (when executable-specs
+                (let ([stand-alone? (eq? 'stand-alone (car executable-specs))]
+                      [gui? (eq? 'mred (cadr executable-specs))]
+                      [executable-filename (caddr executable-specs)])
+                  (with-handlers ([(λ (x) #f) ;exn:fail?
+                                   (λ (x)
+                                     (message-box
+                                      (string-constant drscheme)
+                                      (if (exn? x)
+                                          (format "~a" (exn-message x))
+                                          (format "uncaught exception: ~s" x))))])
+                    (if stand-alone?
+                        (let ([short-program-name (let-values ([(base name dir) (split-path program-filename)])
+                                                    (cond
+                                                      [(regexp-match #rx#"(.*)\\...." (path->bytes name))
+                                                       =>
+                                                       cadr]
+                                                      [(regexp-match #rx#"(.*)\\..." (path->bytes name))
+                                                       =>
+                                                       cadr]
+                                                      [(regexp-match #rx#"(.*)\\.." (path->bytes name))
+                                                       =>
+                                                       cadr]
+                                                      [else (path->bytes name)]))])
+                          (make-embedding-executable
+                           executable-filename
+                           gui?
+                           #f ;; verbose?
+                           (list (list #f program-filename))
+                           null
+                           null
+                           (list (if gui? "-Zmvqe-" "-mvqe-")
+                                 (format "~s" `(require ,(string->symbol (bytes->string/latin-1 short-program-name)))))))
+                        (let ([make-launcher (if gui? make-mred-launcher make-mzscheme-launcher)])
+                          (make-launcher (list "-mvqt-" (path->string program-filename))
+                                         executable-filename))))))))
+          
+          (super-instantiate ()
+            (module '(lib "plt-mred.ss" "lang"))
+            (language-position (list (string-constant professional-languages) "(module ...)"))
+            (language-numbers (list -1000 1000)))))
+      
+      ;; module-language-config-panel : panel -> (case-> (-> settings) (settings -> void))
+      (define (module-language-config-panel parent)
+        (define new-parent 
+          (instantiate vertical-panel% ()
+            (parent parent)
+            (alignment '(center center))
+            (stretchable-height #f)
+            (stretchable-width #f)))
+        (define simple-case-lambda (drscheme:language:simple-module-based-language-config-panel new-parent))
+        (define cp-panel (instantiate group-box-panel% ()
+                           (parent new-parent)
+                           (label (string-constant ml-cp-collection-paths))))
+        
+        (define args-panel (instantiate group-box-panel% ()
+                             (parent new-parent)
+                             (label (string-constant ml-command-line-arguments))))
+        (define args-text-box (new text-field%
+                                   (parent args-panel)
+                                   (label #f)
+                                   (init-value "#()")
+                                   (callback void)))
+        
+        ;; data associated with each item in listbox : boolean
+        ;; indicates if the entry is the default paths.
+        (define lb (instantiate list-box% ()
+                     (parent cp-panel)
+                     (choices '("a" "b" "c"))
+                     (label #f)
+                     (callback (λ (x y) (update-buttons)))))
+        (define button-panel (instantiate horizontal-panel% ()
+                               (parent cp-panel)
+                               (alignment '(center center))
+                               (stretchable-height #f)))
+        (define add-button (make-object button% (string-constant ml-cp-add) button-panel
+                             (λ (x y) (add-callback))))
+        (define add-default-button (make-object button% (string-constant ml-cp-add-default) button-panel
+                                     (λ (x y) (add-default-callback))))
+        (define remove-button (make-object button% (string-constant ml-cp-remove) button-panel
+                                (λ (x y) (remove-callback))))
+        (define raise-button (make-object button% (string-constant ml-cp-raise) button-panel
+                               (λ (x y) (raise-callback))))
+        (define lower-button (make-object button% (string-constant ml-cp-lower) button-panel
+                               (λ (x y) (lower-callback))))
+        
+        (define (update-buttons)
+          (let ([lb-selection (send lb get-selection)]
+                [lb-tot (send lb get-number)])
+            (send remove-button enable lb-selection)
+            (send raise-button enable 
+                  (and lb-selection
+                       (not (= lb-selection 0))))
+            (send lower-button enable 
+                  (and lb-selection
+                       (not (= lb-selection (- lb-tot 1)))))))
+                
+        (define (add-callback)
+          (let ([dir (get-directory
+                      (string-constant ml-cp-choose-a-collection-path)
+                      (send parent get-top-level-window))])
+            (when dir
+              (send lb append dir #f)
+              (update-buttons))))
+        
+        (define (add-default-callback)
+          (cond
+            [(has-default?)
+             (message-box (string-constant drscheme)
+                          (string-constant ml-cp-default-already-present)
+                          (send parent get-top-level-window))]
+            [else
+             (send lb append (string-constant ml-cp-default-collection-path) #t)
+             (update-buttons)]))
+        
+        ;; has-default? : -> boolean
+        ;; returns #t if the `default' entry has already been added
+        (define (has-default?)
+          (let loop ([n (send lb get-number)])
+            (cond
+              [(= n 0) #f]
+              [(send lb get-data (- n 1)) #t]
+              [else (loop (- n 1))])))
+        
+        (define (remove-callback)
+          (let ([to-delete (send lb get-selection)])
+            (send lb delete to-delete)
+            (unless (zero? (send lb get-number))
+              (send lb set-selection (min to-delete
+                                          (- (send lb get-number) 1))))
+            (update-buttons)))
+        
+        (define (lower-callback)
+          (let* ([sel (send lb get-selection)]
+                 [vec (get-lb-vector)]
+                 [below (vector-ref vec (+ sel 1))])
+            (vector-set! vec (+ sel 1) (vector-ref vec sel))
+            (vector-set! vec sel below)
+            (set-lb-vector vec)
+            (send lb set-selection (+ sel 1))
+            (update-buttons)))
+        
+        (define (raise-callback) 
+          (let* ([sel (send lb get-selection)]
+                 [vec (get-lb-vector)]
+                 [above (vector-ref vec (- sel 1))])
+            (vector-set! vec (- sel 1) (vector-ref vec sel))
+            (vector-set! vec sel above)
+            (set-lb-vector vec)
+            (send lb set-selection (- sel 1))
+            (update-buttons)))
+        
+        (define (get-lb-vector)
+          (list->vector
+           (let loop ([n 0])
+             (cond
+               [(= n (send lb get-number)) null]
+               [else (cons (cons (send lb get-string n)
+                                 (send lb get-data n))
+                           (loop (+ n 1)))]))))
+        
+        (define (set-lb-vector vec)
+          (send lb clear)
+          (let loop ([n 0])
+            (cond
+              [(= n (vector-length vec)) (void)]
+              [else (send lb append (car (vector-ref vec n)))
+                    (send lb set-data n (cdr (vector-ref vec n)))
+                    (loop (+ n 1))])))
+        
+        (define (get-collection-paths)
+          (let loop ([n 0])
+            (cond
+              [(= n (send lb get-number)) null]
+              [else
+               (let ([data (send lb get-data n)])
+                 (cons (if data
+                           'default
+                           (send lb get-string n))
+                       (loop (+ n 1))))])))
+        
+        (define (install-collection-paths paths)
+          (send lb clear)
+          (for-each (λ (cp)
+                      (if (symbol? cp)
+                          (send lb append
+                                (string-constant ml-cp-default-collection-path)
+                                #t)
+                          (send lb append cp #f)))
+                    paths))
+        
+        (define (get-command-line-args)
+          (let ([str (send args-text-box get-value)])
+            (let ([read-res (parameterize ([read-accept-graph #f])
+                              (with-handlers ([exn:fail:read? (λ (x) #())])
+                                (read (open-input-string str))))])
+              (cond
+                [(and (vector? read-res)
+                      (andmap string? (vector->list read-res)))
+                 read-res]
+                [else #()]))))
+        
+        (define (install-command-line-args vec)
+          (send args-text-box set-value 
+                (parameterize ([print-vector-length #f])
+                  (format "~s" vec))))
+        
+        (send lb set '())
+        (update-buttons)
+        
+        (case-lambda
+          [() 
+           (let ([simple-settings (simple-case-lambda)])
+             (apply make-module-language-settings
+                    (append
+                     (vector->list (drscheme:language:simple-settings->vector simple-settings))
+                     (list (get-collection-paths)
+                           (get-command-line-args)))))]
+          [(settings) 
+           (simple-case-lambda settings)
+           (install-collection-paths (module-language-settings-collection-paths settings))
+           (install-command-line-args (module-language-settings-command-line-args settings))
+           (update-buttons)]))
+      
+      ;; module-language-style-delta : (instanceof style-delta%)
+      (define module-language-style-delta (make-object style-delta% 'change-family 'modern))
+      
+      ;; transform-module-to-export-everything : (union #f string) syntax syntax -> syntax
+      ;; in addition to exporting everything, the result module's name
+      ;; is the fully expanded name, with a directory prefix, 
+      ;; if the file has been saved
+      (define (transform-module filename stx unexpanded-stx)
+        (syntax-case stx (module #%plain-module-begin)
+          [(module name lang (#%plain-module-begin bodies ...))
+           (let ([v-name (syntax name)])
+             (when filename
+               (check-filename-matches filename
+                                       (syntax-object->datum (syntax name)) 
+                                       unexpanded-stx))
+             (values v-name stx))]
+          [else
+           (raise-syntax-error 'module-language
+                               "only module expressions are allowed"
+                               unexpanded-stx)]))
+
+      ;; get-filename : port -> (union string #f)
+      ;; extracts the file the definitions window is being saved in, if any.
+      (define (get-filename port)
+        (let ([source #;(port-source port)
+                      #f])
+          (cond
+            [(is-a? source text%)
+             (let ([canvas (send source get-canvas)])
+               (and canvas
+                    (let ([frame (send canvas get-top-level-window)])
+                      (and (is-a? frame drscheme:unit:frame%)
+                           (let* ([b (box #f)]
+                                  [filename (send (send frame get-definitions-text)
+                                                  get-filename
+                                                  b)])
+                             (if (unbox b)
+                                 #f
+                                 filename))))))]
+            [(string? source) source]
+            [else #f])))
+      
+      ;; check-filename-matches : string datum syntax -> void
+      (define re:check-filename-matches (regexp "^(.*)\\.[^.]*$"))
+      (define (check-filename-matches filename datum unexpanded-stx)
+        (unless (symbol? datum)
+          (raise-syntax-error 'module-language "unexpected object in name position of module" 
+                              unexpanded-stx))
+        (let-values ([(base name dir?) (split-path filename)])
+          (let* ([m (regexp-match re:check-filename-matches name)]
+                 [matches?
+                  (if m
+                      (equal? (string->symbol (cadr m)) datum)
+                      (equal? (string->symbol name) datum))])
+            (unless matches?
+              (raise-syntax-error
+               'module-language
+               (format "module name doesn't match saved filename, ~s and ~e"
+                       datum
+                       filename)
+               unexpanded-stx)))))
+
+      (define module-language-put-file-mixin
+        (mixin (text:basic<%>) ()
+          (inherit get-text last-position get-character get-top-level-window)
+          (define/override (put-file directory default-name)
+            (let ([tlw (get-top-level-window)])
+              (if (and tlw 
+                       (is-a? tlw drscheme:unit:frame<%>))
+                  (let* ([definitions-text (send tlw get-definitions-text)]
+                         [module-language? 
+                          (is-a? (drscheme:language-configuration:language-settings-language
+                                  (send definitions-text get-next-settings))
+                                 module-language<%>)]
+                         [module-default-filename
+                          (and module-language? (get-module-filename))])
+                    (super put-file directory module-default-filename))
+                  (super put-file directory default-name))))
+      
+          ;; returns the name after "(module " suffixed with .scm
+          ;; in the beginning of the editor
+          ;; or #f if the beginning doesn't match "(module "
+          (define/contract get-module-filename
+            (-> (union false/c string?))
+            (λ ()
+              (let ([open-paren (skip-whitespace 0)])
+                (or (match-paren open-paren "(")
+                    (match-paren open-paren "[")
+                    (match-paren open-paren "{")))))
+          
+          (define/contract match-paren
+            (number? string? . -> . (union false/c string?))
+            (λ (open-paren paren)
+              (and (matches open-paren paren)
+                   (let ([module (skip-whitespace (+ open-paren 1))])
+                     (and (matches module "module")
+                          (let* ([end-module (+ module (string-length "module"))]
+                                 [filename-start (skip-whitespace end-module)]
+                                 [filename-end (skip-to-whitespace filename-start)])
+                            (and (not (= filename-start end-module))
+                                 (string-append (get-text filename-start filename-end)
+                                                ".scm"))))))))
+          
+
+          (define/contract matches
+            (number? string? . -> . boolean?)
+            (λ (start string)
+              (let ([last-pos (last-position)])
+                (let loop ([i 0])
+                  (cond
+                    [(and (i . < . (string-length string))
+                          ((+ i start) . < . last-pos))
+                     (and (char=? (string-ref string i)
+                                  (get-character (+ i start)))
+                          (loop (+ i 1)))]
+                    [(= i (string-length string)) #t]
+                    [else #f])))))
+          
+          (define/contract skip-whitespace
+            (number? . -> . number?)
+            (λ (start) 
+              (let ([last-pos (last-position)])
+                (let loop ([pos start])
+                  (cond
+                    [(pos . >= . last-pos) last-pos]
+                    [else 
+                     (let ([char (get-character pos)])
+                       (cond
+                         [(char-whitespace? char)
+                          (loop (+ pos 1))]
+                         [else pos]))])))))
+
+          (define/contract skip-to-whitespace
+            (number? . -> . number?)
+            (λ (start) 
+              (let ([last-pos (last-position)])
+                (let loop ([pos start])
+                  (cond
+                    [(pos . >= . last-pos)
+                     last-pos]
+                    [(char-whitespace? (get-character pos))
+                     pos]
+                    [else
+                     (loop (+ pos 1))])))))
+          
+          (super-instantiate ()))))))
\ No newline at end of file
diff --git a/collects/drscheme/private/module-overview.ss b/collects/drscheme/private/module-overview.ss
new file mode 100644
index 0000000000..52e25e822c
--- /dev/null
+++ b/collects/drscheme/private/module-overview.ss
@@ -0,0 +1,970 @@
+
+(module module-overview mzscheme
+  (require (lib "mred.ss" "mred")
+           (lib "class.ss")
+	   (lib "list.ss")
+           (lib "string.ss")
+           (lib "moddep.ss" "syntax")
+           (lib "toplevel.ss" "syntax")
+           (lib "framework.ss" "framework")
+           (lib "string-constant.ss" "string-constants")
+           (lib "graph.ss" "mrlib")
+           "drsig.ss"
+           (lib "unitsig.ss")
+           (lib "unit.ss")
+           (lib "async-channel.ss"))
+  
+  (provide module-overview@)
+  (define module-overview@
+    (unit/sig drscheme:module-overview^
+      (import [drscheme:frame : drscheme:frame^]
+              [drscheme:eval : drscheme:eval^]
+              [drscheme:language-configuration : drscheme:language-configuration/internal^]
+              [drscheme:language : drscheme:language^])
+      
+      (define filename-constant (string-constant module-browser-filename-format))
+      (define font-size-gauge-label (string-constant module-browser-font-size-gauge-label))
+      (define progress-label (string-constant module-browser-progress-label))
+      (define adding-file (string-constant module-browser-adding-file))
+      (define laying-out-graph-label (string-constant module-browser-laying-out-graph-label))
+      (define open-file-format (string-constant module-browser-open-file-format))
+      (define lib-paths-checkbox-constant (string-constant module-browser-show-lib-paths))
+      
+      (define unknown-module-name "? unknown module name")
+      
+      (preferences:set-default 'drscheme:module-overview:label-font-size 12 number?)
+      (preferences:set-default 'drscheme:module-overview:window-height 500 number?)
+      (preferences:set-default 'drscheme:module-overview:window-width 500 number?)
+      (preferences:set-default 'drscheme:module-browser:show-lib-paths? #f boolean?)
+      
+      (define (set-box/f b v) (when (box? b) (set-box! b v)))
+      
+      (define (module-overview parent)
+        (let ([filename (get-file #f parent)])
+          (when filename
+            (module-overview/file filename parent))))
+
+      (define (find-label-font size)
+        (send the-font-list find-or-create-font size 'decorative 'normal 'normal #f))
+      
+      (define module-overview-pasteboard<%>
+        (interface ()
+          set-label-font-size
+          get-label-font-size
+          show-lib-paths
+          set-name-length
+          get-name-length))
+      
+      (define boxed-word-snip<%>
+        (interface ()
+          get-filename
+          get-word
+          get-lines
+          get-lib-children
+          add-lib-child))
+      
+      (define-struct req (filename lib?))
+      ;; type req = (make-req string[filename] boolean)
+      
+      ;; make-module-overview-pasteboard : boolean
+      ;;                                   ((union #f snip) -> void)
+      ;;                                -> (union string pasteboard)
+      ;; string as result indicates an error message
+      ;; pasteboard as result is the pasteboard to show
+      (define (make-module-overview-pasteboard vertical? mouse-currently-over)
+        
+        (define level-ht (make-hash-table))
+
+        ;; snip-table : hash-table[sym -o> snip]
+        (define snip-table (make-hash-table 'equal))
+        (define label-font (find-label-font (preferences:get 'drscheme:module-overview:label-font-size)))
+        (define text-color (make-object color% "blue"))
+        
+        (define dark-syntax-pen (send the-pen-list find-or-create-pen "darkorchid" 1 'solid))
+        (define dark-syntax-brush (send the-brush-list find-or-create-brush "darkorchid" 'solid))
+        (define light-syntax-pen (send the-pen-list find-or-create-pen "plum" 1 'solid))
+        (define light-syntax-brush (send the-brush-list find-or-create-brush "plum" 'solid))
+
+        (define dark-template-pen (send the-pen-list find-or-create-pen "seagreen" 1 'solid))
+        (define dark-template-brush (send the-brush-list find-or-create-brush "seagreen" 'solid))
+        (define light-template-pen (send the-pen-list find-or-create-pen "springgreen" 1 'solid))
+        (define light-template-brush (send the-brush-list find-or-create-brush "springgreen" 'solid))
+        
+        (define dark-pen (send the-pen-list find-or-create-pen "blue" 1 'solid))
+        (define dark-brush (send the-brush-list find-or-create-brush "blue" 'solid))
+        (define light-pen (send the-pen-list find-or-create-pen "light blue" 1 'solid))
+        (define light-brush (send the-brush-list find-or-create-brush "light blue" 'solid))
+        
+        (define (module-overview-pasteboard-mixin %)
+          (class* % (module-overview-pasteboard<%>)
+            
+            (inherit get-snip-location
+                     begin-edit-sequence
+                     end-edit-sequence
+                     insert
+                     move-to
+                     find-first-snip
+                     dc-location-to-editor-location
+                     find-snip
+                     get-canvas)
+          
+            (define name-length 'long)
+            (define/public (set-name-length nl)
+              (unless (eq? name-length nl)
+                (set! name-length nl)
+                (re-add-snips)
+                (render-snips)))
+            (define/public (get-name-length) name-length)
+            
+            (field [max-lines #f])
+            
+            ;; controls if the snips should be moved
+            ;; around when the font size is changed.
+            ;; set to #f if the user ever moves a
+            ;; snip themselves.
+            (define dont-move-snips #f)
+            
+            (field (label-font-size (preferences:get 'drscheme:module-overview:label-font-size)))
+            (define/public (get-label-font-size) label-font-size)
+            (define/private (get-snip-hspace) (if vertical?
+                                                  2
+                                                  (* 2 label-font-size)))
+            (define/private (get-snip-vspace) (if vertical?
+                                                  30
+                                                  2))
+            (define snip-height #f)
+            
+            (define font-label-size-callback-running? #f)
+            (define new-font-size #f)
+            (define/public (set-label-font-size size-to-set)
+              (set! new-font-size size-to-set)
+              (unless font-label-size-callback-running?
+                (set! font-label-size-callback-running? #t)
+                (queue-callback
+                 (λ ()
+                   (set! label-font-size new-font-size)
+                   (preferences:set 'drscheme:module-overview:label-font-size 
+                                    new-font-size)
+                   (set! label-font (find-label-font label-font-size))
+                   (begin-edit-sequence)
+                   (let loop ([snip (find-first-snip)])
+                     (when snip
+                       (let ([admin (send snip get-admin)])
+                         (when admin
+                           (send admin resized snip #t)))
+                       (loop (send snip next))))
+                   (unless dont-move-snips
+                     (render-snips))
+                   (end-edit-sequence)
+                   (set! new-font-size #f)
+                   (set! font-label-size-callback-running? #f))
+                 #f)))
+            
+            (define/public (begin-adding-connections)
+              (when max-lines
+                (error 'begin-adding-connections "already in begin-adding-connections/end-adding-connections sequence"))
+              (set! max-lines 0)
+              (begin-edit-sequence)
+              (let loop ()
+                (let ([s (find-first-snip)])
+                  (when s
+                    (send s release-from-owner)
+                    (loop))))
+              (set! level-ht (make-hash-table))
+              (set! snip-table (make-hash-table 'equal)))
+
+            (define/public (end-adding-connections)
+              (unless max-lines
+                (error 'end-adding-connections "not in begin-adding-connections/end-adding-connections sequence"))
+              
+              (unless (zero? max-lines)
+                (let loop ([snip (find-first-snip)])
+                  (when snip
+                    (when (is-a? snip word-snip/lines%)
+                      (send snip normalize-lines max-lines))
+                    (loop (send snip next)))))
+              
+              
+              (set! max-lines #f)
+              
+              (unless (preferences:get 'drscheme:module-browser:show-lib-paths?)
+                (remove-lib-linked))
+              
+              (render-snips)
+              (end-edit-sequence))
+              
+            ;; add-connection : string string boolean symbol -> void
+            ;; name-original and name-require and the identifiers for those paths and
+            ;; original-filename? and require-filename? are booleans indicating if the names
+            ;; are filenames.
+            (define/public (add-connection name-original name-require lib-path? require-type)
+              (unless max-lines
+                (error 'add-connection "not in begin-adding-connections/end-adding-connections sequence"))
+              (let* ([original-filename? (file-exists? name-original)]
+                     [require-filename? (file-exists? name-require)]
+                     [original-snip (find/create-snip name-original original-filename?)]
+                     [require-snip (find/create-snip name-require require-filename?)]
+                     [original-level (send original-snip get-level)]
+                     [require-level (send require-snip get-level)])
+                (case require-type 
+                  [(require)
+                   (add-links original-snip require-snip
+                              dark-pen light-pen
+                              dark-brush light-brush)]
+                  [(require-for-syntax)
+                   (add-links original-snip require-snip 
+                              dark-syntax-pen light-syntax-pen
+                              dark-syntax-brush light-syntax-brush)]
+                  [(require-for-template)
+                   (add-links original-snip require-snip
+                              dark-template-pen light-template-pen
+                              dark-template-brush light-template-brush)])
+                (when lib-path?
+                  (send original-snip add-lib-child require-snip))
+                (if (send original-snip get-level)
+                    (fix-snip-level require-snip (+ original-level 1))
+                    (fix-snip-level original-snip 0))))
+            
+            ;; fix-snip-level : snip number -> void
+            ;; moves the snip (and any children) to at least `new-level'
+            ;; doesn't move them if they are already past that level
+            (define/private (fix-snip-level snip new-min-level)
+              (let loop ([snip snip]
+                         [new-min-level new-min-level])
+                (let ([current-level (send snip get-level)])
+                  (when (or (not current-level)
+                            (new-min-level . > . current-level))
+                    (send snip set-level new-min-level)
+                    (for-each
+                     (λ (child) (loop child (+ new-min-level 1)))
+                     (send snip get-children))))))
+            
+            ;; find/create-snip : (union path string) boolean? -> word-snip/lines
+            ;; finds the snip with this key, or creates a new
+            ;; ones. For the same key, always returns the same snip.
+            ;; uses snip-table as a cache for this purpose.
+            (define/private (find/create-snip name is-filename?)
+              (hash-table-get
+               snip-table
+               name
+               (λ () 
+                 (let* ([snip (instantiate word-snip/lines% ()
+                                (lines (if is-filename? (count-lines name) #f))
+                                (word (let-values ([(_1 name _2) (split-path name)])
+                                        (path->string name)))
+                                (pb this)
+                                (filename (if is-filename? name #f)))])
+                   (insert snip)
+                   (hash-table-put! snip-table name snip)
+                   snip))))
+            
+            ;; count-lines : string[filename] -> (union #f number)
+            ;; effect: updates max-lines
+            (define/private (count-lines filename)
+              (let ([lines
+                     (call-with-input-file filename
+                       (λ (port)
+                         (let loop ([n 0])
+                           (let ([l (read-line port)])
+                             (if (eof-object? l)
+                                 n
+                                 (loop (+ n 1))))))
+                       'text)])
+                (set! max-lines (max lines max-lines))
+                lines))
+            
+            ;; get-snip-width : snip -> number
+            ;; exracts the width of a snip
+            (define/private (get-snip-width snip)
+              (let ([lb (box 0)]
+                    [rb (box 0)])
+                (get-snip-location snip lb #f #f)
+                (get-snip-location snip rb #f #t)
+                (- (unbox rb)
+                   (unbox lb))))
+            
+            ;; get-snip-height : snip -> number
+            ;; exracts the width of a snip
+            (define/private (get-snip-height snip)
+              (let ([tb (box 0)]
+                    [bb (box 0)])
+                (get-snip-location snip #f tb #f)
+                (get-snip-location snip #f bb #t)
+                (- (unbox bb)
+                   (unbox tb))))
+            
+            (field [lib-paths-on? (preferences:get 'drscheme:module-browser:show-lib-paths?)])
+            (define/public (show-lib-paths on?)
+              (unless (eq? on? lib-paths-on?)
+                (set! lib-paths-on? on?)
+                (begin-edit-sequence)
+                (re-add-snips)
+                (render-snips)
+                (end-edit-sequence)))
+            
+            (define/private (re-add-snips)
+              (begin-edit-sequence)
+              (remove-currrently-inserted)
+              (if lib-paths-on?
+                  (add-all)
+                  (remove-lib-linked))
+              (end-edit-sequence))
+            
+            (define/private (remove-lib-linked)
+              (remove-currrently-inserted)
+              (for-each
+               (λ (snip)
+                 (insert snip)
+                 (let loop ([snip snip])
+                   (for-each
+                    (λ (child)
+                      (unless (memq child (send snip get-lib-children))
+                        (insert child)
+                        (loop child)))
+                    (send snip get-children))))
+               (get-top-most-snips)))
+                
+            (define/private (remove-currrently-inserted)
+              (let loop ()
+                (let ([snip (find-first-snip)])
+                  (when snip
+                    (send snip release-from-owner)
+                    (loop)))))
+            
+            (define/private (add-all)
+              (let ([ht (make-hash-table)])
+                (for-each
+                 (λ (snip)
+                   (let loop ([snip snip])
+                     (unless (hash-table-get ht snip (λ () #f))
+                       (hash-table-put! ht snip #t)
+                       (insert snip)
+                       (for-each loop (send snip get-children)))))
+                 (get-top-most-snips))))
+
+            (define/private (get-top-most-snips) (hash-table-get level-ht 0 (λ () null)))
+              
+            ;; render-snips : -> void
+            (define/public (render-snips)
+              (begin-edit-sequence)
+              (let ([max-minor 0])
+                
+                ;; major-dim is the dimension that new levels extend along
+                ;; minor-dim is the dimension that snips inside a level extend along
+                
+                (hash-table-for-each
+                 level-ht
+                 (λ (n v)
+                   (set! max-minor (max max-minor (apply + (map (if vertical?
+                                                                    (λ (x) (get-snip-width x))
+                                                                    (λ (x) (get-snip-height x)))
+                                                                v))))))
+                
+                (let ([levels (quicksort (hash-table-map level-ht list)
+                                         (λ (x y) (<= (car x) (car y))))])
+                  (let loop ([levels levels]
+                             [major-dim 0])
+                    (cond
+                      [(null? levels) (void)]
+                      [else
+                       (let* ([level (car levels)]
+                              [n (car level)]
+                              [this-level-snips (cadr level)]
+                              [this-minor (apply + (map (if vertical? 
+                                                            (λ (x) (get-snip-width x))
+                                                            (λ (x) (get-snip-height x)))
+                                                        this-level-snips))]
+                              [this-major (apply max (map (if vertical? 
+                                                              (λ (x) (get-snip-height x))
+                                                              (λ (x) (get-snip-width x)))
+                                                          this-level-snips))])
+                         (let loop ([snips this-level-snips]
+                                    [minor-dim (/ (- max-minor this-minor) 2)])
+                           (unless (null? snips)
+                             (let* ([snip (car snips)]
+                                    [new-major-coord
+                                     (+ major-dim
+                                        (floor
+                                         (- (/ this-major 2) 
+                                            (/ (if vertical? 
+                                                   (get-snip-height snip)
+                                                   (get-snip-width snip))
+                                               2))))])
+                               (if vertical?
+                                   (move-to snip minor-dim new-major-coord)
+                                   (move-to snip new-major-coord minor-dim))
+                               (loop (cdr snips)
+                                     (+ minor-dim
+                                        (if vertical?
+                                            (get-snip-hspace)
+                                            (get-snip-vspace))
+                                        (if vertical?
+                                            (get-snip-width snip)
+                                            (get-snip-height snip)))))))
+                         (loop (cdr levels)
+                               (+ major-dim 
+                                  (if vertical? 
+                                      (get-snip-vspace)
+                                      (get-snip-hspace))
+                                  this-major)))]))))
+              (end-edit-sequence))
+            
+            (define/override (on-mouse-over-snips snips)
+              (mouse-currently-over snips))
+            
+            (define/override (on-double-click snip event)
+              (cond
+                [(is-a? snip boxed-word-snip<%>) 
+                 (let ([fn (send snip get-filename)])
+                   (when fn
+                     (handler:edit-file fn)))]
+                [else (super on-double-click snip event)]))
+              
+            (define/override (on-event evt)
+              (cond
+                [(send evt button-down? 'right)
+                 (let ([ex (send evt get-x)]
+                       [ey (send evt get-y)])
+                   (let-values ([(x y) (dc-location-to-editor-location ex ey)])
+                     (let ([snip (find-snip x y)]
+                           [canvas (get-canvas)])
+                       (let ([right-button-menu (make-object popup-menu%)])
+                         (when (and snip
+                                    (is-a? snip boxed-word-snip<%>)
+                                    canvas
+                                    (send snip get-filename))
+                           (instantiate menu-item% ()
+                             (label 
+                              (trim-string
+                               (format open-file-format
+                                       (path->string (send snip get-filename)))
+                               200))
+                             (parent right-button-menu)
+                             (callback
+                              (λ (x y)
+                                (handler:edit-file
+                                 (send snip get-filename))))))
+                         (instantiate menu-item% ()
+                           (label (string-constant module-browser-open-all))
+                           (parent right-button-menu)
+                           (callback
+                            (λ (x y)
+                              (let loop ([snip (find-first-snip)])
+                                (when snip
+                                  (when (is-a? snip boxed-word-snip<%>)
+                                    (let ([filename (send snip get-filename)])
+                                      (handler:edit-file filename)))
+                                  (loop (send snip next)))))))
+                         (send canvas popup-menu
+                               right-button-menu
+                               (+ (send evt get-x) 1)
+                               (+ (send evt get-y) 1))))))]
+                [else (super on-event evt)]))
+            
+            (super-instantiate ())))
+        
+        (define (trim-string str len)
+          (cond
+            [(<= (string-length str) len) str]
+            [else (substring str (- (string-length str) len) (string-length str))]))
+        
+        (define (level-mixin %)
+          (class %
+            (field (level #f))
+            (define/public (get-level) level)
+            (define/public (set-level _l) 
+              (when level
+                (hash-table-put! level-ht level
+                                 (remq this (hash-table-get level-ht level))))
+              (set! level _l)
+              (hash-table-put! level-ht level 
+                               (cons this (hash-table-get level-ht level (λ () null)))))
+            
+            (super-instantiate ())))
+        
+        (define (boxed-word-snip-mixin %)
+          (class* % (boxed-word-snip<%>)
+            (init-field word
+                        filename
+                        lines
+                        pb)
+            
+            (field [lib-children null])
+            (define/public (get-lib-children) lib-children)
+            (define/public (add-lib-child child)
+              (unless (memq child lib-children)
+                (set! lib-children (cons child lib-children))))
+            
+            (define/public (get-filename) filename)
+            (define/public (get-word) word)
+            (define/public (get-lines) lines)
+            
+            (field (lines-brush #f))
+            (define/public (normalize-lines n)
+              (if lines
+                  (let* ([grey (inexact->exact (floor (- 255 (* 255 (sqrt (/ lines n))))))])
+                    (set! lines-brush (send the-brush-list find-or-create-brush
+                                            (make-object color% grey grey grey)
+                                            'solid)))
+                  (set! lines-brush (send the-brush-list find-or-create-brush
+                                          "salmon"
+                                          'solid))))
+            
+            (field (snip-width 0)
+                   (snip-height 0))
+            
+            (define/override (get-extent dc x y wb hb descent space lspace rspace)
+              (cond
+                [(equal? (name->label) "")
+                 (set! snip-width 15)
+                 (set! snip-height 15)]
+                [else
+                 (let-values ([(w h a d) (send dc get-text-extent (name->label) label-font)])
+                   (set! snip-width (+ w 4))
+                   (set! snip-height (+ h 4)))])
+              (set-box/f wb snip-width)
+              (set-box/f hb snip-height)
+              (set-box/f descent 0)
+              (set-box/f space 0)
+              (set-box/f lspace 0)
+              (set-box/f rspace 0))
+            
+            (define/override (draw dc x y left top right bottom dx dy draw-caret)
+              (let ([old-font (send dc get-font)]
+                    [old-text-foreground (send dc get-text-foreground)]
+                    [old-brush (send dc get-brush)])
+                (send dc set-font label-font)
+                (when lines-brush
+                  (send dc set-brush lines-brush))
+                (when (and (or (<= left x right)
+                               (<= left (+ x snip-width) right))
+                           (or (<= top y bottom)
+                               (<= top (+ y snip-height) bottom)))
+                  (send dc draw-rectangle x y snip-width snip-height)
+                  (send dc set-text-foreground text-color)
+                  (send dc draw-text (name->label) (+ x 2) (+ y 2)))
+                (send dc set-brush old-brush)
+                (send dc set-text-foreground old-text-foreground)
+                (send dc set-font old-font)))
+                          
+            ;; name->label : path -> string
+            ;; constructs a label for the little boxes in terms
+            ;; of the filename.
+            
+            (define last-name #f)
+            (define last-size #f)
+            
+            (define/private (name->label)
+              (let ([this-size (send pb get-name-length)])
+                (cond
+                  [(eq? this-size last-size) last-name]
+                  [else
+                   (set! last-size this-size)
+                   (set! last-name
+                         (case last-size
+                           [(short)
+                            (if (string=? word "")
+                                ""
+                                (string (string-ref word 0)))]
+                           [(medium)
+                            (let ([m (regexp-match #rx"^(.*)\\.[^.]*$" word)])
+                              (let ([short-name (if m (cadr m) word)])
+                                (if (string=? short-name "")
+                                    ""
+                                    (let ([ms (regexp-match* #rx"-[^-]*" short-name)])
+                                      (cond
+                                        [(null? ms)
+                                         (substring short-name 0 (min 2 (string-length short-name)))]
+                                        [else
+                                         (apply string-append
+                                                (cons (substring short-name 0 1)
+                                                      (map (λ (x) (substring x 1 2))
+                                                           ms)))])))))]
+                           [(long) word]))
+                   last-name])))
+
+            (super-new)))
+        
+        (define word-snip/lines% (level-mixin (boxed-word-snip-mixin (graph-snip-mixin snip%))))
+        
+        (define draw-lines-pasteboard% (module-overview-pasteboard-mixin
+                                        (graph-pasteboard-mixin
+                                         pasteboard:basic%)))
+        (make-object draw-lines-pasteboard%))
+      
+      
+;                                                                                    
+;                                                                                    
+;                                                                                    
+;                                                                                    
+;                                                                                    
+;                                                                                    
+;   ; ;;    ; ;   ;;;     ;;;    ;;;    ;;;    ;;;       ; ;;    ; ;   ;;;     ;; ;  
+;   ;;  ;   ;;   ;   ;   ;   ;  ;   ;  ;      ;          ;;  ;   ;;   ;   ;   ;  ;;  
+;   ;    ;  ;   ;     ; ;      ;    ;  ;;     ;;         ;    ;  ;   ;     ; ;    ;  
+;   ;    ;  ;   ;     ; ;      ;;;;;;   ;;     ;;        ;    ;  ;   ;     ; ;    ;  
+;   ;    ;  ;   ;     ; ;      ;          ;      ;       ;    ;  ;   ;     ; ;    ;  
+;   ;;  ;   ;    ;   ;   ;   ;  ;         ;      ;       ;;  ;   ;    ;   ;   ;  ;;  
+;   ; ;;    ;     ;;;     ;;;    ;;;;  ;;;    ;;;        ; ;;    ;     ;;;     ;; ;  
+;   ;                                                    ;                        ;  
+;   ;                                                    ;                   ;    ;  
+;   ;                                                    ;                    ;;;;   
+
+
+      (define process-program-unit
+        (unit 
+          (import progress-channel
+                  connection-channel)
+          (export add-connections)
+        
+          (define visited-hash-table (make-hash-table 'equal))
+          
+          ;; add-connections : (union syntax string[filename]) -> (union #f string)
+          ;; recursively adds a connections from this file and
+          ;; all files it requires
+          ;; returns a string error message if there was an error compiling
+          ;; the program
+          (define (add-connections filename/stx)
+            (cond
+              [(string? filename/stx)
+               (add-filename-connections filename/stx)]
+              [(syntax? filename/stx)
+               (add-syntax-connections filename/stx)]))
+          
+          ;; add-syntax-connections : syntax -> void
+          (define (add-syntax-connections stx)
+            (let ([module-codes (map compile (expand-syntax-top-level-with-compile-time-evals/flatten stx))])
+              (for-each
+               (λ (module-code)
+                 (when (compiled-module-expression? module-code)
+                   (let* ([name (extract-module-name stx)]
+                          [base 
+                           (build-module-filename
+                            (if (regexp-match #rx"^," name)
+                                (substring name 1 (string-length name))
+                                (build-path (current-load-relative-directory) name)))])
+                     (add-module-code-connections base module-code))))
+               module-codes)))
+          
+          (define (build-module-filename str)
+            (let ([try (λ (ext)
+                         (let ([tst (bytes->path (bytes-append (path->bytes str) ext))])
+                           (and (file-exists? tst)
+                                tst)))])
+              (or (try #".ss")
+                  (try #".scm")
+                  (try #"")
+                  str)))
+              
+          ;; add-filename-connections : string -> void
+          (define (add-filename-connections filename)
+            (add-module-code-connections filename (get-module-code filename)))
+          
+          (define (add-module-code-connections module-name module-code)
+            (unless (hash-table-get visited-hash-table module-name (λ () #f))
+              (async-channel-put progress-channel (format adding-file module-name))
+              (hash-table-put! visited-hash-table module-name #t)
+              (let-values ([(imports fs-imports ft-imports) (module-compiled-imports module-code)])
+                (let ([requires (extract-filenames imports module-name)]
+                      [syntax-requires (extract-filenames fs-imports module-name)]
+                      [template-requires (extract-filenames ft-imports module-name)])
+                  (for-each (λ (require)
+                              (add-connection module-name
+                                              (req-filename require)
+                                              (req-lib? require)
+                                              'require)
+                              (add-filename-connections (req-filename require)))
+                            requires)
+                  (for-each (λ (syntax-require)
+                              (add-connection module-name 
+                                              (req-filename syntax-require)
+                                              (req-lib? syntax-require)
+                                              'require-for-syntax)
+                              (add-filename-connections (req-filename syntax-require)))
+                            syntax-requires)
+                  (for-each (λ (require)
+                              (add-connection module-name
+                                              (req-filename require)
+                                              (req-lib? require)
+                                              'require-for-template)
+                              (add-filename-connections (req-filename require)))
+                            template-requires)))))
+
+          ;; add-connection : string string boolean symbol -> void
+          ;; name-original and name-require and the identifiers for those paths and
+          ;; original-filename? and require-filename? are booleans indicating if the names
+          ;; are filenames.
+          (define (add-connection name-original name-require is-lib? require-type)
+            (async-channel-put connection-channel (list name-original 
+                                                        name-require  
+                                                        is-lib?
+                                                        require-type)))
+          
+          (define (extract-module-name stx)
+            (syntax-case stx ()
+              [(module m-name rest ...)
+               (and (eq? (syntax-e (syntax module)) 'module)
+                    (identifier? (syntax m-name)))
+               (format "~a" (syntax-object->datum (syntax m-name)))]
+              [else unknown-module-name]))
+          
+          ;; extract-filenames : (listof (union symbol module-path-index)) string[module-name] ->
+          ;;                     (listof req)
+          (define (extract-filenames direct-requires base)
+            (let loop ([direct-requires direct-requires])
+              (cond
+                [(null? direct-requires) null]
+                [else (let ([dr (car direct-requires)])
+                        (if (module-path-index? dr)
+                            (cons (make-req (simplify-path (expand-path (resolve-module-path-index dr base)))
+                                            (is-lib? dr))
+                                  (loop (cdr direct-requires)))
+                            (loop (cdr direct-requires))))])))
+          
+          (define (is-lib? dr)
+            (and (module-path-index? dr)
+                 (let-values ([(a b) (module-path-index-split dr)])
+                   (and (pair? a)
+                        (eq? 'lib (car a))))))))
+
+      
+;                                                                
+;                                                                
+;                                                                
+;    ;;;                                      ;;;;   ;     ;  ;  
+;   ;                                        ;    ;  ;     ;  ;  
+;   ;                                       ;        ;     ;  ;  
+;  ;;;;  ; ;  ;;;    ; ;;  ;;     ;;;       ;        ;     ;  ;  
+;   ;    ;;  ;   ;   ;;  ;;  ;   ;   ;      ;        ;     ;  ;  
+;   ;    ;       ;   ;   ;   ;  ;    ;      ;        ;     ;  ;  
+;   ;    ;    ;;;;   ;   ;   ;  ;;;;;;      ;     ;  ;     ;  ;  
+;   ;    ;   ;   ;   ;   ;   ;  ;           ;     ;  ;     ;  ;  
+;   ;    ;   ;   ;   ;   ;   ;   ;           ;    ;  ;     ;  ;  
+;   ;    ;    ;;;;;  ;   ;   ;    ;;;;        ;;;;;   ;;;;;   ;  
+;                                                                
+;                                                                
+;                                                                
+
+      
+      (define (module-overview/file filename parent)
+        (define progress-frame (parameterize ([current-eventspace (make-eventspace)])
+                                 (instantiate frame% ()
+                                   (parent parent)
+                                   (label progress-label)
+                                   (width 600))))
+        (define progress-message (instantiate message% ()
+                                   (label "")
+                                   (stretchable-width #t)
+                                   (parent progress-frame)))
+        
+        (define thd 
+          (thread
+           (λ ()
+             (sleep 3)
+             (send progress-frame show #t))))
+        
+        (define text/pos 
+          (let ([t (make-object text%)])
+            (send t load-file filename)
+            (drscheme:language:make-text/pos
+             t
+             0
+             (send t last-position))))
+        
+        (define update-label void)
+        
+        (define (show-status str)
+          (send progress-message set-label str))
+        
+        (define pasteboard (make-module-overview-pasteboard 
+                            #f
+                            (λ (x) (update-label x))))
+        
+        (let ([success? (fill-pasteboard pasteboard text/pos show-status void)])
+          (kill-thread thd)
+          (send progress-frame show #f)
+          (when success?
+            (let ()
+              (define frame (instantiate overview-frame% ()
+                              (label (string-constant module-browser))
+                              (width (preferences:get 'drscheme:module-overview:window-width))
+                              (height (preferences:get 'drscheme:module-overview:window-height))
+                              (alignment '(left center))))
+              (define vp (instantiate vertical-panel% ()
+                           (parent (send frame get-area-container))
+                           (alignment '(left center))))
+              (define root-message (instantiate message% ()
+                                     (label 
+                                      (format (string-constant module-browser-root-filename)
+                                              filename))
+                                     (parent vp)
+                                     (stretchable-width #t)))
+              (define label-message (instantiate message% ()
+                                      (label "")
+                                      (parent vp)
+                                      (stretchable-width #t)))
+              (define font-size-gauge
+                (instantiate slider% ()
+                  (label font-size-gauge-label)
+                  (min-value 1)
+                  (max-value 72)
+                  (init-value (preferences:get 'drscheme:module-overview:label-font-size))
+                  (parent vp)
+                  (callback
+                   (λ (x y)
+                     (send pasteboard set-label-font-size (send font-size-gauge get-value))))))
+              (define lib-paths-checkbox
+                (instantiate check-box% ()
+                  (label lib-paths-checkbox-constant)
+                  (parent vp)
+                  (callback
+                   (λ (x y)
+                     (send pasteboard show-lib-paths (send lib-paths-checkbox get-value))))))
+              
+              (define ec (make-object canvas:basic% vp pasteboard))
+              
+              (send lib-paths-checkbox set-value (preferences:get 'drscheme:module-browser:show-lib-paths?))
+              (set! update-label
+                    (λ (s)
+                      (if (and s (not (null? s)))
+                          (let* ([currently-over (car s)]
+                                 [fn (send currently-over get-filename)]
+                                 [lines (send currently-over get-lines)])
+                            (when (and fn lines)
+                              (send label-message set-label
+                                    (format filename-constant fn lines))))
+                          (send label-message set-label ""))))
+              
+              ;; shouldn't be necessary here -- need to find callback on editor
+              (send pasteboard render-snips)
+              
+              (send frame show #t)))))
+      
+      (define (fill-pasteboard pasteboard text/pos show-status send-user-thread/eventspace)
+        (define progress-channel (make-async-channel))
+        (define connection-channel (make-async-channel))
+        
+        (define-values/invoke-unit (add-connections) process-program-unit #f progress-channel connection-channel)
+        
+        ;; =user thread=
+        (define (iter sexp continue)
+          (cond
+            [(eof-object? sexp) 
+             (custodian-shutdown-all user-custodian)]
+            [else
+             (add-connections sexp)
+             (continue)]))
+        (define init-complete (make-semaphore 0))
+        
+        (define user-custodian #f)
+        (define user-thread #f)
+        (define error-str #f)
+        
+        (define init-dir
+          (let* ([bx (box #f)]
+                 [filename (send (drscheme:language:text/pos-text text/pos) get-filename bx)])
+            (if (and filename
+                     (not (unbox bx)))
+                (let-values ([(base name dir) (split-path filename)])
+                  base)
+                (current-directory))))
+        
+        (define (init)
+          (set! user-custodian (current-custodian))
+          (set! user-thread (current-thread))
+          (moddep-current-open-input-file
+           (λ (filename)
+             (let* ([p (open-input-file filename)]
+                    [wxme? (regexp-match-peek #rx#"^WXME" p)])
+               (if wxme?
+                   (let ([t (new text%)])
+                     (close-input-port p)
+                     (send t load-file filename)
+                     (let ([prt (open-input-text-editor t)])
+                       (port-count-lines! prt)
+                       prt))
+                   p))))
+          (current-load-relative-directory init-dir)
+          (current-directory init-dir)
+          (error-display-handler 
+           (λ (str exn)
+             (set! error-str str)
+             (custodian-shutdown-all user-custodian)))
+          (semaphore-post init-complete))
+        (define (kill-termination) (void))
+        (define complete-program? #t)
+        
+        (define stupid-internal-define-syntax1
+          ((drscheme:eval:traverse-program/multiple
+            (preferences:get (drscheme:language-configuration:get-settings-preferences-symbol))
+            init
+            kill-termination)
+           text/pos
+           iter
+           complete-program?))
+        
+        (semaphore-wait init-complete)
+        (send-user-thread/eventspace user-thread user-custodian)
+        
+        ;; this thread puts a "cap" on the end of the connection-channel
+        ;; so that we know when we've gotten to the end.
+        ;; this ensures that we can completely flush out the
+        ;; connection-channel.
+        (thread
+         (λ ()
+           (sync (thread-dead-evt user-thread))
+           (async-channel-put connection-channel 'done)))
+        
+        (send pasteboard begin-adding-connections)
+        (let ([evt
+               (choice-evt
+                (handle-evt progress-channel (λ (x) (cons 'progress x)))
+                (handle-evt connection-channel (λ (x) (cons 'connect x))))])
+          (let loop ()
+            (let* ([evt-value (yield evt)]
+                   [key (car evt-value)]
+                   [val (cdr evt-value)])
+              (case key
+                [(progress) 
+                 (show-status val)
+                 (loop)]
+                [(connect)
+                 (unless (eq? val 'done)
+                   (let ([name-original (first val)]
+                         [name-require (second val)]
+                         [lib-path? (third val)]
+                         [require-type (fourth val)])
+                     (send pasteboard add-connection name-original name-require lib-path? require-type))
+                   (loop))]))))
+        (send pasteboard end-adding-connections)
+        
+        (custodian-shutdown-all user-custodian)
+        
+        (cond
+          [error-str
+           (message-box 
+            (string-constant module-browser)
+            (format (string-constant module-browser-error-expanding)
+                    error-str))
+           #f]
+          [else
+           #t]))
+      
+      (define overview-frame%
+        (class (drscheme:frame:basics-mixin
+                frame:standard-menus%)
+          (define/override (edit-menu:between-select-all-and-find menu) (void))
+          (define/override (edit-menu:between-redo-and-cut menu) (void))
+          (define/override (edit-menu:between-find-and-preferences menu) (void))
+          
+          (define/override (edit-menu:create-cut?) #f)
+          (define/override (edit-menu:create-copy?) #f)
+          (define/override (edit-menu:create-paste?) #f)
+          (define/override (edit-menu:create-clear?) #f)
+          (define/override (edit-menu:create-select-all?) #f)
+          
+          (define/override (on-size w h)
+            (preferences:set 'drscheme:module-overview:window-width w)
+            (preferences:set 'drscheme:module-overview:window-height h)
+            (super on-size w h))
+          (super-instantiate ()))))))
diff --git a/collects/drscheme/private/multi-file-search.ss b/collects/drscheme/private/multi-file-search.ss
new file mode 100644
index 0000000000..48171a700f
--- /dev/null
+++ b/collects/drscheme/private/multi-file-search.ss
@@ -0,0 +1,708 @@
+
+(module multi-file-search mzscheme
+  (require (lib "framework.ss" "framework")
+           (lib "class.ss")
+           (lib "unitsig.ss")
+           (lib "mred.ss" "mred")
+           (lib "file.ss")
+           (lib "thread.ss")
+           (lib "async-channel.ss")
+           (lib "string-constant.ss" "string-constants")
+           "drsig.ss")
+  
+  (provide multi-file-search@)
+  
+  (define multi-file-search@
+    (unit/sig drscheme:multi-file-search^
+      (import [drscheme:frame : drscheme:frame^]
+              [drscheme:unit : drscheme:unit^])
+      
+      ;; multi-file-search : -> void
+      ;; opens a dialog to configure the search and initiates the search
+      (define (multi-file-search)
+        (let ([search-info  (configure-search)])
+          (when search-info
+            (open-search-window search-info))))
+      
+      ;; searcher = (string (string int int int -> void) -> void)
+      ;; this performs a single search.
+      ;; the first argument is the filename to be searched
+      ;; the second argument is called for each match.
+      ;;     the arguments are: line-string line-number col-number match-length
+      
+      
+      ;; search-type = (make-search-type string make-searcher (listof (cons string boolean)))
+      ;; the param strings are the labels for checkboxes
+      ;; the param booleans are the default values for the checkboxes
+      ;; these are the available searches
+      (define-struct search-type (label make-searcher params))
+      
+      ;; search-info = (make-search-info string boolean (union #f regexp) search-type)
+      (define-struct search-info (dir recur? filter searcher))
+      
+      ;; search-types : (listof search-type)
+      (define search-types
+        (list (make-search-type
+               (string-constant mfs-string-match/graphics)
+               (λ (info search-string) (exact-match-searcher info search-string))
+               (list (cons (string-constant mfs-case-sensitive-label) #f)))
+              (make-search-type
+               (string-constant mfs-regexp-match/no-graphics)
+               (λ (info search-string) (regexp-match-searcher info search-string))
+               (list))))
+      
+      ;; search-entry = (make-search-entry string number number number)
+      (define-struct search-entry (filename line-string line-number col-number match-length))
+      
+      ;; preferences initialization
+      (preferences:set-default 'drscheme:multi-file-search:recur? #t boolean?)
+      (preferences:set-default 'drscheme:multi-file-search:filter? #t boolean?)
+      (preferences:set-default 'drscheme:multi-file-search:filter-string "\\.(ss|scm)$" string?)
+      (preferences:set-default 'drscheme:multi-file-search:search-string "" string?)
+      (preferences:set-default 'drscheme:multi-file-search:search-type
+                               1
+                               (λ (x) 
+                                 (and (number? x)
+                                      (exact? x)
+                                      (integer? x)
+                                      (<= 0 x)
+                                      (< x (length search-types)))))
+      
+      ;; drscheme:mult-file-search:search-check-boxes : (listof (listof boolean))
+      (preferences:set-default 'drscheme:multi-file-search:search-check-boxes 
+                               (map (λ (x) (map cdr (search-type-params x)))
+                                    search-types)
+                               (λ (x) 
+                                 (and (list? x)
+                                      (andmap (λ (x)
+                                                (and (list? x)
+                                                     (andmap boolean? x)))
+                                              x))))
+      
+      (preferences:set-default 'drscheme:multi-file-search:percentages
+                               '(1/3 2/3)
+                               (λ (x) (and (list? x)
+                                                (= 2 (length x))
+                                                (= 1 (apply + x)))))
+      
+      (preferences:set-default 'drscheme:multi-file-search:frame-size '(300 . 400) 
+                               (λ (x) (and (pair? x)
+                                                (number? (car x))
+                                                (number? (cdr x)))))
+      (preferences:set-default 'drscheme:multi-file-search:directory (car (filesystem-root-list)) path?)
+      (preferences:set-un/marshall 
+       'drscheme:multi-file-search:directory
+       (λ (v) (path->string v))
+       (λ (p) (if (path-string? p)
+                       (string->path p)
+                       (car (filesystem-root-list)))))
+      
+      
+      ;; open-search-window : search-info -> void
+      ;; thread: eventspace main thread
+      ;; opens a window and creates the thread that does the search
+      (define (open-search-window search-info)
+        (define frame (make-object search-size-frame% (string-constant mfs-drscheme-multi-file-search)))
+        (define panel (make-object saved-vertical-resizable% (send frame get-area-container)))
+        (define button-panel (make-object horizontal-panel% (send frame get-area-container)))
+        (define open-button (make-object button% (string-constant mfs-open-file) button-panel
+                              (λ (x y) (open-file-callback))))
+        (define stop-button (make-object button% (string-constant mfs-stop-search) button-panel
+                              (λ (x y) (stop-callback))))
+        (define grow-box-pane (make-object grow-box-spacer-pane% button-panel))
+        
+        (define zoom-text (make-object scheme:text%))
+        (define results-text (make-object results-text% zoom-text))
+        (define results-ec (instantiate searching-canvas% ()
+                             (parent panel)
+                             (editor results-text)
+                             (frame frame)))
+        (define zoom-ec (instantiate searching-canvas% ()
+                          (parent panel)
+                          (editor zoom-text)
+                          (frame frame)))
+        
+        (define (open-file-callback)
+          (send results-text open-file))
+        
+	;; sometimes, breaking the other thread puts
+	;; the break message in the channel behind
+	;; many many requests. Rather than show those,
+	;; we use the `broken?' flag as a shortcut.
+	(define broken? #f)
+        (define (stop-callback)
+          (break-thread search-thd)
+	  (set! broken? #t)
+          (send stop-button enable #f))
+        
+        ;; channel : async-channel[(union 'done search-entry)]
+        (define channel (make-async-channel 100))
+        (define search-thd (thread (λ () (do-search search-info channel))))
+        
+        (send frame set-text-to-search results-text) ;; just to initialize it to something.
+        (send results-text lock #t)
+        (send frame reflow-container)
+        (send panel set-percentages (preferences:get 'drscheme:multi-file-search:percentages))
+        (send button-panel set-alignment 'right 'center)
+        (send button-panel stretchable-height #f)
+        (send frame show #t)
+        
+        (let loop ()
+          (let ([match (yield channel)])
+            (yield)
+            (cond
+              [(eq? match 'done)
+               (send results-text search-complete)
+               (send stop-button enable #f)]
+              [(or broken? (eq? match 'break))
+               (send results-text search-interrupted)]
+              [else
+               (send results-text add-match
+                     (search-info-dir search-info)
+                     (search-entry-filename match)
+                     (search-entry-line-string match)
+                     (search-entry-line-number match)
+                     (search-entry-col-number match)
+                     (search-entry-match-length match))
+               (loop)]))))
+      
+      (define results-super-text% 
+        (text:hide-caret/selection-mixin
+         (text:basic-mixin 
+          (editor:standard-style-list-mixin 
+           (editor:basic-mixin
+            text%)))))
+      
+      ;; results-text% : derived from text%
+      ;; init args: zoom-text
+      ;;   zoom-text : (instance-of text%)
+      ;; public-methods:
+      ;;   add-match : string string int int int int -> void
+      ;;      adds a match to the text
+      ;;   search-interrupted : -> void
+      ;;      inserts a message saying "search interrupted".
+      ;;      search-complete is not expected to be called if this method is called.
+      ;;   search-complete : -> void
+      ;;      inserts a message saying "no matches found" if none were reported
+      (define results-text%
+        (class results-super-text%
+          (init-field zoom-text)
+          (inherit insert last-paragraph erase
+                   paragraph-start-position paragraph-end-position
+                   last-position change-style
+                   set-clickback set-position
+                   end-edit-sequence begin-edit-sequence
+                   lock)
+          
+          [define filename-delta (make-object style-delta% 'change-bold)]
+          [define match-delta (let ([d (make-object style-delta%)])
+                                (send d set-delta-foreground
+				      (make-object color%
+					0
+					160
+					0))
+                                d)]
+          [define hilite-line-delta (make-object style-delta% 'change-style 'italic)]
+          [define unhilite-line-delta (make-object style-delta% 'change-style 'normal)]
+          [define widest-filename #f]
+          [define/private indent-all-lines
+            ;; indent-all-lines : number -> void
+            ;; inserts `offset' spaces to the beginning of each line,
+            ;; except the last one. Must be at least one such line in the text.
+            (λ (offset)
+              (let ([spaces (make-string offset #\space)])
+                (let loop ([para (- (last-paragraph) 1)])
+                  (let ([para-start (paragraph-start-position para)])
+                    (insert spaces para-start para-start)
+                    (change-style filename-delta para-start (+ para-start offset)))
+                  (unless (zero? para)
+                    (loop (- para 1))))))]
+          
+          ;; match-shown? : boolean
+          ;; indicates if a match has ever been shown.
+          ;; if not, need to clean out the "searching" message
+          ;; and show a match. Done in `add-match'
+          [define match-shown? #f]
+          
+          ;; current-file : (union #f string)
+          ;; the name of the currently viewed file, if one if viewed.
+          ;; line-in-current-file and col-in-current-file are linked
+          [define current-file #f]
+          [define line-in-current-file #f]
+          [define col-in-current-file #f]
+          
+          [define old-line #f]
+          [define/private hilite-line
+            (λ (line)
+              (begin-edit-sequence)
+              (lock #f)
+              (when old-line
+                (change-style unhilite-line-delta
+                              (paragraph-start-position old-line)
+                              (paragraph-end-position old-line)))
+              (when line
+                (change-style hilite-line-delta
+                              (paragraph-start-position line)
+                              (paragraph-end-position line)))
+              (set! old-line line)
+              (lock #t)
+              (end-edit-sequence))]
+          
+          [define/public (open-file)
+            (when current-file
+              (let ([f (handler:edit-file current-file)])
+                (when (and f
+                           (is-a? f drscheme:unit:frame<%>))
+                  (let* ([t (send f get-definitions-text)]
+                         [pos (+ (send t paragraph-start-position line-in-current-file)
+                                 col-in-current-file)])
+                    (send t set-position pos)))))]
+          
+          [define/public add-match
+            (λ (base-filename full-filename line-string line-number col-number match-length)
+              (lock #f)
+              (let* ([new-line-position (last-position)]
+                     [short-filename 
+                      (path->string
+                       (find-relative-path 
+                        (normalize-path base-filename)
+                        (normalize-path full-filename)))]
+                     [this-match-number (last-paragraph)]
+                     [len (string-length short-filename)]
+                     [insertion-start #f]
+                     [show-this-match
+                      (λ ()
+                        (set! match-shown? #t)
+                        (set! current-file full-filename)
+                        (set! line-in-current-file line-number)
+                        (set! col-in-current-file col-number)
+                        (set-position new-line-position new-line-position)
+                        (send zoom-text begin-edit-sequence)
+                        (send zoom-text lock #f)
+                        (send zoom-text load-file/gui-error full-filename)
+                        (send zoom-text set-position (send zoom-text paragraph-start-position line-number))
+                        (let ([start (+ (send zoom-text paragraph-start-position line-number)
+                                        col-number)])
+                          (send zoom-text change-style match-delta start (+ start match-length)))
+                        (send zoom-text lock #t)
+                        (send zoom-text set-caret-owner #f 'global)
+                        (hilite-line this-match-number)
+                        (send zoom-text end-edit-sequence))])
+                (unless match-shown?
+                  (erase))
+                (unless widest-filename
+                  (set! widest-filename len))
+                (if (<= len widest-filename)
+                    (begin
+                      (set! insertion-start (last-position))
+                      (insert (make-string (- widest-filename len) #\space) 
+                              (last-position) (last-position)))
+                    (begin
+                      (indent-all-lines (- len widest-filename))
+                      (set! insertion-start (last-position))
+                      (set! widest-filename len)))
+                (let ([filename-start (last-position)])
+                  (insert short-filename (last-position) (last-position))
+                  (insert ": " (last-position) (last-position))
+                  (change-style filename-delta insertion-start (last-position))
+                  (let ([line-start (last-position)])
+                    (insert line-string (last-position) (last-position))
+                    (change-style match-delta
+                                  (+ line-start col-number)
+                                  (+ line-start col-number match-length)))
+                  (set-clickback filename-start (last-position)
+                                 (λ (_1 _2 _3)
+                                   (show-this-match)))
+                  (insert #\newline (last-position) (last-position))
+                  
+                  (unless match-shown?
+                    (show-this-match))))
+              (lock #t))]
+          
+          (define/public (search-interrupted)
+            (lock #f)
+            (insert #\newline (last-position) (last-position))
+            (insert (string-constant mfs-search-interrupted) (last-position) (last-position))
+            (lock #t))
+          
+          (define/public (search-complete)
+            (unless match-shown?
+              (lock #f)
+              (insert #\newline (last-position) (last-position))
+              (insert (string-constant mfs-no-matches-found) (last-position) (last-position))
+              (lock #t)))
+          
+          (inherit get-style-list set-style-list set-styles-sticky)
+          (super-instantiate ())
+          (send zoom-text lock #t)
+          (set-styles-sticky #f)
+          (insert (string-constant mfs-searching...))))
+      
+      ;; collaborates with search-size-frame%
+      (define searching-canvas%
+        (class canvas:basic%
+          (init-field frame)
+          (inherit get-editor)
+          (define/override (on-focus on?)
+            (when on?
+              (send frame set-text-to-search (get-editor)))
+            (super on-focus on?))
+          (super-instantiate ())))
+      
+      ;; thread: eventspace main thread
+      (define search-size-frame%
+        (class (drscheme:frame:basics-mixin 
+                (frame:searchable-mixin
+                 frame:standard-menus%))
+          (init-field name)
+          
+          (field [text-to-search #f])
+          (define/public (set-text-to-search text) (set! text-to-search text))
+          (define/override (get-text-to-search) text-to-search)
+          
+          (define/override (on-size w h)
+            (preferences:set 'drscheme:multi-file-search:frame-size (cons w h))
+            (super on-size w h))
+          (let ([size (preferences:get 'drscheme:multi-file-search:frame-size)])
+            (super-instantiate ()
+              (label name)
+              (width (car size))
+              (height (cdr size))))))
+      
+      
+      ;; this vertical-resizable class just remembers the percentage between the
+      ;; two panels
+      ;; thread: eventspace main thread
+      (define saved-vertical-resizable%
+        (class panel:vertical-dragable%
+          (inherit get-percentages)
+          (define/augment (after-percentage-change)
+            (let ([ps (get-percentages)])
+              (when (= (length ps) 2)
+                (preferences:set 'drscheme:multi-file-search:percentages ps)))
+            (inner (void) after-percentage-change))
+          (super-instantiate ())))
+      
+      ;; configure-search : -> (union #f search-info)
+      ;; thread: eventspace main thread
+      ;; configures the search
+      (define (configure-search)
+        (define dialog (make-object dialog% (string-constant mfs-configure-search)
+                         #f 500 #f #f #f '(resize-border)))
+        (define outer-files-panel (make-object vertical-panel% dialog '(border)))
+        (define outer-method-panel (make-object vertical-panel% dialog '(border)))
+        (define button-panel (make-object horizontal-panel% dialog))
+        (define files-label (make-object message% (string-constant mfs-files-section) outer-files-panel))
+        (define files-inset-outer-panel (make-object horizontal-panel% outer-files-panel))
+        (define files-inset-panel (make-object horizontal-panel% files-inset-outer-panel))
+        (define files-panel (make-object vertical-panel% files-inset-outer-panel))
+        (define method-label (make-object message% (string-constant mfs-search-section) outer-method-panel))
+        (define method-inset-outer-panel (make-object horizontal-panel% outer-method-panel))
+        (define method-inset-panel (make-object horizontal-panel% method-inset-outer-panel))
+        (define method-panel (make-object vertical-panel% method-inset-outer-panel))
+        
+        (define dir-panel (make-object horizontal-panel% files-panel))
+        (define dir-field (make-object text-field% (string-constant mfs-dir) dir-panel
+                            (λ (x y) (dir-field-callback))))
+        (define dir-button (make-object button% (string-constant browse...) dir-panel 
+                             (λ (x y) (dir-button-callback))))
+        
+        (define recur-check-box (make-object check-box% (string-constant mfs-recur-over-subdirectories) files-panel
+                                  (λ (x y) (recur-check-box-callback))))
+        
+        (define filter-panel (make-object horizontal-panel% files-panel))
+        (define filter-check-box (make-object check-box% (string-constant mfs-regexp-filename-filter) filter-panel
+                                   (λ (x y) (filter-check-box-callback))))
+        (define filter-text-field (make-object text-field% #f filter-panel 
+                                    (λ (x y) (filter-text-field-callback))))
+        
+        (define methods-choice (make-object choice% #f (map search-type-label search-types) method-panel 
+                                 (λ (x y) (methods-choice-callback))))
+        (define search-text-field (make-object text-field% (string-constant mfs-search-string) method-panel
+                                    (λ (x y) (search-text-field-callback))))
+        (define active-method-panel (make-object panel:single% method-panel))
+        (define methods-check-boxess
+          (let ([pref (preferences:get 'drscheme:multi-file-search:search-check-boxes)])
+            (map
+             (λ (search-type prefs-settings)
+               (let ([p (make-object vertical-panel% active-method-panel)]
+                     [params (search-type-params search-type)])
+                 (send p set-alignment 'left 'center)
+                 (map (λ (flag-pair prefs-setting)
+                        (let ([cb (make-object check-box% 
+                                    (car flag-pair)
+                                    p
+                                    (λ (evt chk) (method-callback chk)))])
+                          (send cb set-value prefs-setting)
+                          cb))
+                      params
+                      (if (= (length params) (length prefs-settings))
+                          prefs-settings
+                          (map (λ (x) #f) params)))))
+             search-types
+             (if (= (length search-types) (length pref))
+                 pref
+                 (map (λ (x) '()) search-types)))))
+        (define-values (ok-button cancel-button)
+          (gui-utils:ok/cancel-buttons
+           button-panel
+           (λ (x y) (ok-button-callback))
+           (λ (x y) (cancel-button-callback))))
+        (define spacer (make-object grow-box-spacer-pane% button-panel))
+        
+        ;; initialized to a searcher during the ok button callback
+        ;; so the user can be informed of an error before the dialog
+        ;; closes.
+        (define searcher #f)
+        
+        ;; initialized to a regexp if the user wants to filter filenames,
+        ;; during the ok-button-callback, so errors can be signalled.
+        (define filter #f)
+        
+        ;; title for message box that signals error messages
+        (define message-box-title (string-constant mfs-drscheme-multi-file-search))
+        
+        (define (ok-button-callback)
+          (cond
+            [(with-handlers ([exn:fail:filesystem?
+                              (λ (x) #f)])
+               (directory-exists? (send dir-field get-value)))
+             (let ([_searcher
+                    ((search-type-make-searcher (list-ref search-types (send methods-choice get-selection)))
+                     (map (λ (cb) (send cb get-value))
+                          (send (send active-method-panel active-child) get-children))
+                     (send search-text-field get-value))])
+               (if (string? _searcher)
+                   (message-box message-box-title _searcher dialog)
+                   (let ([regexp (with-handlers ([(λ (x) #t)
+                                                  (λ (exn)
+						    (format "~a" (exn-message exn)))])
+                                   (and (send filter-check-box get-value)
+                                        (regexp (send filter-text-field get-value))))])
+                     (if (string? regexp)
+                         (message-box message-box-title regexp dialog)
+                         (begin (set! searcher _searcher)
+                                (set! filter regexp)
+                                (set! ok? #t)
+                                (send dialog show #f))))))]
+            [else
+             (message-box message-box-title
+                          (format (string-constant mfs-not-a-dir) (send dir-field get-value))
+                          dialog)]))
+        (define (cancel-button-callback)
+          (send dialog show #f))
+        
+        (define (method-callback chk)
+          (preferences:set
+           'drscheme:multi-file-search:search-check-boxes
+           (let loop ([methods-check-boxess methods-check-boxess])
+             (cond
+               [(null? methods-check-boxess) null]
+               [else
+                (let loop ([methods-check-boxes (car methods-check-boxess)])
+                  (cond
+                    [(null? methods-check-boxes) null]
+                    [else (cons (send (car methods-check-boxes) get-value)
+                                (loop (cdr methods-check-boxes)))]))]))))
+        
+        (define (dir-field-callback)
+          (let ([df (send dir-field get-value)])
+            (when (path-string? df)
+              (preferences:set 'drscheme:multi-file-search:directory (string->path df)))))
+        
+        (define (filter-check-box-callback) 
+          (preferences:set 'drscheme:multi-file-search:filter? (send filter-check-box get-value))
+          (send filter-text-field enable (send filter-check-box get-value)))
+        (define (filter-text-field-callback)
+          (preferences:set 'drscheme:multi-file-search:filter-string (send filter-text-field get-value)))
+        
+        (define (recur-check-box-callback)
+          (preferences:set 'drscheme:multi-file-search:recur? (send recur-check-box get-value)))
+        (define (methods-choice-callback)
+          (preferences:set 'drscheme:multi-file-search:search-type (send methods-choice get-selection)) 
+          (send active-method-panel active-child
+                (list-ref (send active-method-panel get-children)
+                          (send methods-choice get-selection))))
+        (define (search-text-field-callback)
+          (preferences:set 'drscheme:multi-file-search:search-string (send search-text-field get-value)))
+        (define (dir-button-callback) 
+          (let ([d (get-directory)])
+            (when (and d
+                       (directory-exists? d))
+              (preferences:set 'drscheme:multi-file-search:directory d)
+              (send dir-field set-value (path->string d)))))
+        
+        (define (get-files)
+          (let ([dir (string->path (send dir-field get-value))])
+            (and (directory-exists? dir)
+                 (if (send recur-check-box get-value)
+                     (build-recursive-file-list dir filter)
+                     (build-flat-file-list dir filter)))))
+        
+        (define ok? #f)
+        
+        (send button-panel set-alignment 'right 'center)
+        (send dir-panel stretchable-height #f)
+        (send outer-files-panel stretchable-height #f)
+        (send outer-files-panel set-alignment 'left 'center)
+        (send files-inset-panel min-width 20)
+        (send files-inset-panel stretchable-width #f)
+        (send files-panel set-alignment 'left 'center)
+        
+        (send recur-check-box set-value (preferences:get 'drscheme:multi-file-search:recur?))
+        (send filter-check-box set-value (preferences:get 'drscheme:multi-file-search:filter?))
+        (send search-text-field set-value (preferences:get 'drscheme:multi-file-search:search-string))
+        (send filter-text-field set-value (preferences:get 'drscheme:multi-file-search:filter-string))
+        (send dir-field set-value (path->string (preferences:get 'drscheme:multi-file-search:directory)))
+        
+        (send outer-method-panel stretchable-height #f)
+        (send outer-method-panel set-alignment 'left 'center)
+        (send method-inset-panel min-width 20)
+        (send method-inset-panel stretchable-width #f)
+        (send method-panel set-alignment 'left 'center)
+        (send filter-panel stretchable-height #f)
+        
+        (send search-text-field focus)
+        (send dialog show #t)
+        
+        (and
+         ok?
+         (make-search-info
+          (send dir-field get-value)
+          (send recur-check-box get-value)
+          (and (send filter-check-box get-value)
+               (regexp (send filter-text-field get-value)))
+          searcher)))
+      
+      
+      ;; do-search : search-info text -> void
+      ;; thread: searching thread
+      ;; called in a new thread that may be broken (to indicate a stop)
+      (define (do-search search-info channel)
+        (let* ([dir (search-info-dir search-info)]
+               [filter (search-info-filter search-info)]
+               [searcher (search-info-searcher search-info)]
+               [get-filenames (if (search-info-recur? search-info)
+                                  (build-recursive-file-list dir filter)
+                                  (build-flat-file-list dir filter))])
+          (with-handlers ([exn:break? (λ (x) (async-channel-put channel 'break))])
+            (let loop ()
+              (let ([filename (get-filenames)])
+                (when filename
+                  (searcher filename
+                            (λ (line-string line-number col-number match-length)
+                              (async-channel-put
+                               channel
+                               (make-search-entry
+                                filename
+                                line-string
+                                line-number
+                                col-number
+                                match-length))))
+                  (loop))))
+            (async-channel-put channel 'done))))
+      
+      ;; build-recursive-file-list : string (union regexp #f) -> (-> (union string #f))
+      ;; thread: search thread
+      (define (build-recursive-file-list dir filter)
+        (letrec ([touched (make-hash-table 'equal)]
+                 [next-thunk (λ () (process-dir dir (λ () #f)))]
+                 [process-dir
+                  ; string[dirname] (listof string[filename]) -> (listof string[filename])
+                  (λ (dir k)
+                    (let* ([key (normalize-path dir)]
+                           [traversed? (hash-table-get touched key (λ () #f))])
+                      (if traversed? 
+                          (k)
+                          (begin
+                            (hash-table-put! touched key #t)
+                            (process-dir-contents 
+                             (map (λ (x) (build-path dir x))
+                                  (directory-list dir))
+                             k)))))]
+                 [process-dir-contents
+                  ; string[dirname] (listof string[filename]) -> (listof string[filename])
+                  (λ (contents k)
+                    (cond
+                      [(null? contents) 
+                       (k)]
+                      [else 
+                       (let ([file/dir (car contents)])
+                         (cond
+                           [(and (file-exists? file/dir)
+                                 (or (not filter)
+                                     (regexp-match filter (path->string file/dir))))
+                            (set! next-thunk
+                                  (λ ()
+                                    (process-dir-contents (cdr contents) k)))
+                            file/dir]
+                           [(directory-exists? file/dir)
+                            (process-dir-contents 
+                             (cdr contents)
+                             (λ ()
+                               (process-dir file/dir k)))]
+                           [else 
+                            (process-dir-contents (cdr contents) k)]))]))])
+          (λ () (next-thunk))))
+      
+      ;; build-flat-file-list : (union #f regexp) string -> (-> (union string #f))
+      ;; thread: searching thread
+      (define (build-flat-file-list dir filter)
+        (let ([contents (map (λ (x) (build-path dir x)) (directory-list dir))])
+          (λ ()
+            (let loop ()
+              (cond
+                [(null? contents)
+                 #f]
+                [(and filter (regexp-match filter (car contents)))
+                 (begin0
+                   (car contents)
+                   (set! contents (cdr contents)))]
+                [else
+                 (set! contents (cdr contents))
+                 (loop)])))))
+      
+      ;; exact-match-searcher : make-searcher
+      (define (exact-match-searcher params key)        ;; thread: main eventspace thread
+        (let ([case-sensitive? (car params)])
+          (λ (filename add-entry)                 ;; thread: searching thread
+            (let ([text (make-object text:basic%)])
+              (send text load-file filename)
+              (let loop ([pos 0])
+                (let ([found (send text find-string key 'forward pos 'eof #t case-sensitive?)])
+                  (when found
+                    (let* ([para (send text position-paragraph found)]
+                           [para-start (send text paragraph-start-position para)]
+                           [line-string (send text get-text para-start
+                                              (send text paragraph-end-position para))]
+                           [line-number para]
+                           [col-number (- found para-start)]
+                           [match-length (string-length key)])
+                      (add-entry line-string line-number col-number match-length)
+                      (loop (+ found 1))))))))))
+      
+      ;; regexp-match-searcher : make-searcher
+      ;; thread: searching thread
+      (define (regexp-match-searcher parmas key)       ;; thread: main eventspace thread
+        (let ([re:key (with-handlers ([(λ (x) #t)
+                                       (λ (exn)
+                                         (format "~a" (exn-message exn)))])
+                        (regexp key))])
+          (if (string? re:key)
+              re:key
+              (λ (filename add-entry)             ;; thread: searching thread
+                (call-with-input-file filename
+                  (λ (port)
+                    (let loop ([line-number 0])
+                      (let ([line (read-line port)])
+                        (cond
+                          [(eof-object? line) (void)]
+                          [else
+                           (let ([match (regexp-match-positions re:key line)])
+                             (when match
+                               (let ([pos (car match)])
+                                 (add-entry line line-number 
+                                            (car pos)
+                                            (- (cdr pos) (car pos))))))
+                           (loop (+ line-number 1))]))))
+                  'text))))))))
diff --git a/collects/drscheme/private/number-snip.ss b/collects/drscheme/private/number-snip.ss
new file mode 100644
index 0000000000..ad65fda3d6
--- /dev/null
+++ b/collects/drscheme/private/number-snip.ss
@@ -0,0 +1,17 @@
+#|
+
+This file is only here for backwards compatibility reasons.
+Old, saved number snips expect to find this file to be 
+load-able in mred.
+
+|#
+
+(module number-snip mzscheme
+  (require (lib "mred.ss" "mred")
+	   (lib "class.ss")
+           (lib "framework.ss" "framework"))
+  
+  (provide snip-class)
+  (define snip-class (make-object number-snip:snip-class%))
+  (send snip-class set-classname (format "~s" `(lib "number-snip.ss" "drscheme" "private")))
+  (send (get-the-snip-class-list) add snip-class))
diff --git a/collects/drscheme/private/rep.ss b/collects/drscheme/private/rep.ss
new file mode 100644
index 0000000000..4c8467653b
--- /dev/null
+++ b/collects/drscheme/private/rep.ss
@@ -0,0 +1,1655 @@
+#|
+
+TODO
+- should a GC should happen on each execution? (or perhaps better, each kill?)
+- front-end methods have new signature
+
+
+|#
+; =Kernel= means in DrScheme's thread and parameterization
+; 
+; =User= means the user's thread and parameterization
+; 
+; =Handler= means in the handler thread of some eventspace; it must
+;  be combined with either =Kernel= or =User=
+
+;; WARNING: printf is rebound in this module to always use the 
+;;          original stdin/stdout of drscheme, instead of the 
+;;          user's io ports, to aid any debugging printouts.
+;;          (esp. useful when debugging the users's io)
+(module rep mzscheme
+  (require (lib "unitsig.ss")
+           (lib "class.ss")
+           (lib "file.ss")
+           (lib "pretty.ss")
+           (lib "etc.ss")
+           (lib "list.ss")
+           (lib "port.ss")
+           "drsig.ss"
+           (lib "string-constant.ss" "string-constants")
+	   (lib "mred.ss" "mred")
+           (lib "framework.ss" "framework")
+	   (lib "external.ss" "browser")
+           (lib "default-lexer.ss" "syntax-color"))
+  
+  (provide rep@)
+  
+  (define rep@
+    (unit/sig drscheme:rep^
+      (import (drscheme:init : drscheme:init^)
+              (drscheme:language-configuration : drscheme:language-configuration/internal^)
+	      (drscheme:language : drscheme:language^)
+              (drscheme:app : drscheme:app^)
+              (drscheme:frame : drscheme:frame^)
+              (drscheme:unit : drscheme:unit^)
+              (drscheme:text : drscheme:text^)
+              (drscheme:help-desk : drscheme:help-desk^)
+              (drscheme:teachpack : drscheme:teachpack^)
+              (drscheme:debug : drscheme:debug^)
+              [drscheme:eval : drscheme:eval^])
+      
+      (rename [-text% text%]
+              [-text<%> text<%>])
+
+      (define -text<%>
+        (interface ()
+          reset-highlighting
+          highlight-errors
+          highlight-errors/exn
+          
+          get-user-custodian
+          get-user-eventspace
+          get-user-thread
+          get-user-namespace
+          get-user-teachpack-cache
+          set-user-teachpack-cache
+          
+          kill-evaluation
+          
+          display-results
+          
+          run-in-evaluation-thread
+          after-many-evals
+          
+          shutdown
+          
+          get-error-ranges
+          reset-error-ranges
+          
+          reset-console
+          
+          copy-prev-previous-expr
+          copy-next-previous-expr
+          copy-previous-expr
+          
+          
+          initialize-console
+          
+          reset-pretty-print-width
+          
+          get-prompt
+          insert-prompt
+          get-context))
+      
+      (define context<%>
+        (interface ()
+          ensure-rep-shown   ;; (interactions-text -> void)
+	  ;; make the rep visible in the frame
+
+          needs-execution?   ;; (-> boolean)
+	  ;; ask if things have changed that would mean the repl is out
+	  ;; of sync with the program being executed in it.
+          
+          enable-evaluation  ;; (-> void)
+	  ;; make the context enable all methods of evaluation
+	  ;; (disable buttons, menus, etc)
+
+          disable-evaluation ;; (-> void)
+	  ;; make the context enable all methods of evaluation
+	  ;; (disable buttons, menus, etc)
+          
+          set-breakables ;; (union thread #f) (union custodian #f) -> void
+          ;; the context might initiate breaks or kills to
+          ;; the thread passed to this function
+
+          get-breakables ;; -> (values (union thread #f) (union custodian #f))
+          ;; returns the last values passed to set-breakables.
+
+          reset-offer-kill ;; (-> void)
+          ;; the next time the break button is pushed, it will only
+          ;; break. (if the break button is clicked twice without
+          ;; this method being called in between, it will offer to
+          ;; kill the user's program)
+
+          update-running        ;; (boolean -> void)
+	  ;; a callback to indicate that the repl may have changed its running state
+          ;; use the repls' get-in-evaluation? method to find out what the current state is.
+          
+          clear-annotations  ;; (-> void)
+	  ;; clear any error highlighting context
+          
+          get-directory      ;; (-> (union #f string[existing directory]))
+	  ;; returns the directory that should be the default for
+	  ;; the `current-directory' and `current-load-relative-directory'
+	  ;; parameters in the repl.
+	  ))
+      
+      (define sized-snip<%>
+	(interface ((class->interface snip%))
+	  ;; get-character-width : -> number
+	  ;; returns the number of characters wide the snip is,
+	  ;; for use in pretty printing the snip.
+	  get-character-width))
+
+      ;; current-language-settings : (parameter language-setting)
+      ;; set to the current language and its setting on the user's thread.
+      (define current-language-settings (make-parameter #f))
+      
+      ;; current-rep : (parameter (union #f (instanceof rep:text%)))
+      ;; the repl that controls the evaluation in this thread.
+      (define current-rep (make-parameter #f))
+
+      ;; a port that accepts values for printing in the repl
+      (define current-value-port (make-parameter #f))
+
+      ;; an error escape continuation that the user program can't
+      ;; change; DrScheme sets it, we use a parameter instead of an
+      ;; object field so that there's no non-weak pointer to the
+      ;; continuation from DrScheme.
+      (define current-error-escape-k (make-parameter void))
+            
+      ;; drscheme-error-display-handler : (string (union #f exn) -> void
+      ;; =User=
+      ;; the timing is a little tricky here. 
+      ;; the file icon must appear before the error message in the text, so that happens first.
+      ;; the highlight must be set after the error message, because inserting into the text resets
+      ;;     the highlighting.
+      (define (drscheme-error-display-handler msg exn)
+        (display msg (current-error-port))
+        (newline (current-error-port))
+        (flush-output (current-error-port))
+        (let ([rep (current-rep)])
+          (when (and (is-a? rep -text<%>)
+                     (eq? (current-error-port) (send rep get-err-port)))
+            (parameterize ([current-eventspace drscheme:init:system-eventspace])
+              (queue-callback
+               (λ ()
+                 (send rep highlight-errors/exn exn)))))))
+      
+      ;; drscheme-error-value->string-handler : TST number -> string
+      (define (drscheme-error-value->string-handler x n)
+        (let ([port (open-output-string)])
+          
+          ;; using a string port here means no snips allowed,
+          ;; even though this string may eventually end up
+          ;; displayed in a place where snips are allowed.
+          (print x port)
+          
+          (let* ([long-string (get-output-string port)])
+            (close-output-port port)
+            (if (<= (string-length long-string) n)
+                long-string
+                (let ([short-string (substring long-string 0 n)]
+                      [trim 3])
+                  (unless (n . <= . trim)
+                    (let loop ([i trim])
+                      (unless (i . <= . 0)
+                        (string-set! short-string (- n i) #\.)
+                        (loop (sub1 i)))))
+                  short-string)))))
+
+      (define drs-bindings-keymap (make-object keymap:aug-keymap%))
+      
+      (send drs-bindings-keymap add-function
+            "search-help-desk"
+            (λ (obj evt)
+              (cond
+                [(is-a? obj text%)
+                 (let* ([start (send obj get-start-position)]
+                        [end (send obj get-end-position)]
+                        [str (if (= start end)
+                                 (drscheme:unit:find-symbol obj start)
+                                 (send obj get-text start end))])
+                   (if (equal? "" str)
+                       (drscheme:help-desk:help-desk)
+                       (let ([language (let ([canvas (send obj get-canvas)])
+                                         (and canvas
+                                              (let ([tlw (send canvas get-top-level-window)])
+                                                (and (is-a? tlw drscheme:unit:frame<%>)
+                                                     (send (send tlw get-definitions-text)
+                                                           get-next-settings)))))])
+                         (drscheme:help-desk:help-desk str #f 'keyword+index 'contains language))))]
+                [else                   
+                 (drscheme:help-desk:help-desk)])))
+      (let ([with-drs-frame
+             (λ (obj f)
+               (when (is-a? obj editor<%>)
+                 (let ([canvas (send obj get-canvas)])
+                   (when canvas
+                     (let ([frame (send canvas get-top-level-window)])
+                       (when (is-a? frame drscheme:unit:frame%)
+                         (f frame)))))))])
+      
+        (send drs-bindings-keymap add-function
+              "execute"
+              (λ (obj evt)
+                (with-drs-frame
+                 obj
+                 (λ (frame)
+                   (send frame execute-callback)))))
+        
+        (send drs-bindings-keymap add-function
+              "toggle-focus-between-definitions-and-interactions"
+              (λ (obj evt)
+                (with-drs-frame 
+                 obj
+                 (λ (frame)
+                   (cond
+                     [(send (send frame get-definitions-canvas) has-focus?)
+                      (send (send frame get-interactions-canvas) focus)]
+                     [else
+                      (send (send frame get-definitions-canvas) focus)])))))
+        (send drs-bindings-keymap add-function
+              "next-tab"
+              (λ (obj evt)
+                (with-drs-frame 
+                 obj
+                 (λ (frame) (send frame next-tab)))))
+        (send drs-bindings-keymap add-function
+              "prev-tab"
+              (λ (obj evt)
+                (with-drs-frame 
+                 obj
+                 (λ (frame) (send frame prev-tab))))))
+      
+      (send drs-bindings-keymap map-function "c:x;o" "toggle-focus-between-definitions-and-interactions")
+      (send drs-bindings-keymap map-function "c:tab" "toggle-focus-between-definitions-and-interactions")
+      (send drs-bindings-keymap map-function "c:shift:tab" "toggle-focus-between-definitions-and-interactions")
+      (send drs-bindings-keymap map-function "f5" "execute")
+      (send drs-bindings-keymap map-function "f1" "search-help-desk")
+      (send drs-bindings-keymap map-function "c:tab" "next-tab")
+      (send drs-bindings-keymap map-function "c:s:tab" "prev-tab")
+      (send drs-bindings-keymap map-function "d:s:right" "next-tab")
+      (send drs-bindings-keymap map-function "d:s:left" "prev-tab")
+      (send drs-bindings-keymap map-function "c:pagedown" "next-tab")
+      (send drs-bindings-keymap map-function "c:pageup" "prev-tab")
+      
+      (define (get-drs-bindings-keymap) drs-bindings-keymap)
+
+      ;; drs-bindings-keymap-mixin :
+      ;;   ((implements editor:keymap<%>) -> (implements editor:keymap<%>))
+      ;;   for any x that is an instance of the resulting class,
+      ;;     (is-a? (send (send x get-canvas) get-top-level-frame) drscheme:unit:frame%)
+      (define drs-bindings-keymap-mixin
+	(mixin (editor:keymap<%>) (editor:keymap<%>)
+	  (define/override (get-keymaps)
+	    (cons drs-bindings-keymap (super get-keymaps)))
+	  (super-instantiate ())))
+      
+      ;; Max length of output queue (user's thread blocks if the
+      ;; queue is full):
+      (define output-limit-size 2000)
+      
+      (define (printf . args) (apply fprintf drscheme:init:original-output-port args))
+      
+      (define setup-scheme-interaction-mode-keymap
+        (λ (keymap)
+          (send keymap add-function "put-previous-sexp"
+                (λ (text event) 
+                  (send text copy-prev-previous-expr)))
+          (send keymap add-function "put-next-sexp"
+                (λ (text event) 
+                  (send text copy-next-previous-expr)))
+          
+          (keymap:send-map-function-meta keymap "p" "put-previous-sexp")
+          (keymap:send-map-function-meta keymap "n" "put-next-sexp")))
+      
+      (define scheme-interaction-mode-keymap (make-object keymap:aug-keymap%))
+      (setup-scheme-interaction-mode-keymap scheme-interaction-mode-keymap)
+      
+      (define drs-font-delta (make-object style-delta% 'change-family 'decorative))
+      
+      (define output-delta (make-object style-delta%)) ; used to be 'change-weight 'bold
+      (define result-delta (make-object style-delta%)) ; used to be 'change-weight 'bold
+      (define error-delta (make-object style-delta%
+                            'change-style
+                            'slant))
+      (send error-delta set-delta-foreground (make-object color% 255 0 0))
+      (send result-delta set-delta-foreground (make-object color% 0 0 175))
+      (send output-delta set-delta-foreground (make-object color% 150 0 150))
+      
+      (define error-text-style-delta (make-object style-delta%))
+      (send error-text-style-delta set-delta-foreground (make-object color% 200 0 0))
+
+      (define grey-delta (make-object style-delta%))
+      (send grey-delta set-delta-foreground "GREY")
+      
+      (define welcome-delta (make-object style-delta% 'change-family 'decorative))
+      (define click-delta (gui-utils:get-clickback-delta))
+      (define red-delta (make-object style-delta%))
+      (define dark-green-delta (make-object style-delta%))
+      (send* red-delta
+        (copy welcome-delta)
+        (set-delta-foreground "RED"))  
+      (send* dark-green-delta
+        (copy welcome-delta)
+        (set-delta-foreground "dark green"))
+      (define warning-style-delta (make-object style-delta% 'change-bold))
+      (send* warning-style-delta
+        (set-delta-foreground "BLACK")
+        (set-delta-background "YELLOW"))
+      
+      ;; is-default-settings? : language-settings -> boolean
+      ;; determines if the settings in `language-settings'
+      ;; correspond to the default settings of the language.
+      (define (is-default-settings? language-settings)
+        (send (drscheme:language-configuration:language-settings-language language-settings)
+              default-settings?
+              (drscheme:language-configuration:language-settings-settings language-settings)))
+
+      (define (extract-language-name language-settings)
+        (send (drscheme:language-configuration:language-settings-language language-settings)
+              get-language-name))
+      (define (extract-language-style-delta language-settings)
+        (send (drscheme:language-configuration:language-settings-language language-settings)
+              get-style-delta))
+      (define (extract-language-url language-settings)
+        (send (drscheme:language-configuration:language-settings-language language-settings)
+              get-language-url))
+
+      (define-struct sexp (left right prompt))
+      
+      (define console-max-save-previous-exprs 30)
+      (let* ([list-of? (λ (p?)
+                         (λ (l)
+                           (and (list? l)
+                                (andmap p? l))))]
+             [snip/string? (λ (s) (or (is-a? s snip%) (string? s)))]
+             [list-of-snip/strings? (list-of? snip/string?)]
+             [list-of-lists-of-snip/strings? (list-of? list-of-snip/strings?)])
+        (preferences:set-default
+         'drscheme:console-previous-exprs
+         null
+         list-of-lists-of-snip/strings?))
+      (let ([marshall 
+             (λ (lls)
+               (map (λ (ls)
+                      (map (λ (s)
+                             (cond
+                               [(is-a? s string-snip%)
+                                (send s get-text 0 (send s get-count))]
+                               [(string? s) s]
+                               [else "'non-string-snip"]))
+                           ls))
+                    lls))]
+            [unmarshall (λ (x) x)])
+        (preferences:set-un/marshall
+         'drscheme:console-previous-exprs
+         marshall unmarshall))
+      
+      (define error-color (make-object color% "PINK"))
+      (define color? ((get-display-depth) . > . 8))
+            
+      ;; instances of this interface provide a context for a rep:text%
+      ;; its connection to its graphical environment (ie frame) for
+      ;; error display and status infromation is all mediated
+      ;; through an instance of this interface.
+            
+      (define file-icon
+        (let ([bitmap
+               (make-object bitmap%
+                 (build-path (collection-path "icons") "file.gif"))])
+          (if (send bitmap ok?)
+              (make-object image-snip% bitmap)
+              (make-object string-snip% "[open file]"))))
+      (define docs-icon
+        (let ([bitmap
+               (make-object bitmap%
+                 (build-path (collection-path "icons") "book.gif"))])
+          (if (send bitmap ok?)
+              (make-object image-snip% bitmap)
+              (make-object string-snip% "[open file]"))))
+      (define mf-icon 
+        (let ([bitmap
+               (make-object bitmap%
+                 (build-path (collection-path "icons") "mf.gif"))])
+          (if (send bitmap ok?)
+              (make-object image-snip% bitmap)
+              (make-object string-snip% "[mf]"))))
+      (define bug-icon 
+        (let ([bitmap
+               (make-object bitmap%
+                 (build-path (collection-path "icons") "bug09.gif"))])
+          (if (send bitmap ok?)
+              (make-object image-snip% bitmap)
+              (make-object string-snip% "[err]"))))
+      
+      (define (no-user-evaluation-message frame)
+        (message-box
+         (string-constant evaluation-terminated)
+         (format (string-constant evaluation-terminated-explanation))
+         frame))
+      
+      ;; insert/delta : (instanceof text%) (union snip string) (listof style-delta%) *-> (values number number)
+      ;; inserts the string/stnip into the text at the end and changes the
+      ;; style of the newly inserted text based on the style deltas.
+      (define (insert/delta text s . deltas)
+        (let ([before (send text last-position)])
+          (send text insert s before before #f)
+          (let ([after (send text last-position)])
+            (for-each (λ (delta)
+                        (when (is-a? delta style-delta%)
+                          (send text change-style delta before after)))
+                      deltas)
+            (values before after))))
+
+      (define text-mixin
+        (mixin ((class->interface text%)
+                text:ports<%>
+                editor:file<%>
+                scheme:text<%>
+                color:text<%>
+                text:ports<%>)
+          (-text<%>)
+          (init-field context)
+          (inherit auto-wrap
+                   begin-edit-sequence
+                   change-style
+                   clear-box-input-port
+                   clear-undos
+                   clear-input-port
+                   clear-output-ports
+                   delete
+                   delete/io
+                   end-edit-sequence
+                   erase
+                   find-snip
+                   find-string
+                   freeze-colorer
+                   get-active-canvas
+                   get-admin
+                   get-can-close-parent
+                   get-canvases
+                   get-character
+                   get-end-position
+                   get-err-port
+                   get-extent
+                   get-focus-snip
+                   get-in-port
+                   get-in-box-port
+                   get-insertion-point
+                   get-out-port
+                   get-snip-position
+                   get-start-position
+                   get-style-list
+                   get-text
+                   get-top-level-window
+                   get-unread-start-point
+                   get-value-port
+                   in-edit-sequence?
+                   insert
+                   insert-between
+                   invalidate-bitmap-cache
+                   is-frozen?
+                   is-locked?
+                   last-position
+                   line-location
+                   lock
+                   paragraph-start-position
+                   position-line
+                   position-paragraph
+                   release-snip
+                   reset-input-box
+                   reset-region
+                   run-after-edit-sequence
+                   scroll-to-position
+                   send-eof-to-in-port 
+                   set-allow-edits
+                   set-caret-owner
+                   set-clickback
+                   set-insertion-point
+                   set-position
+                   set-styles-sticky
+                   set-unread-start-point
+                   split-snip
+                   thaw-colorer)
+    
+          (define definitions-text 'not-yet-set-definitions-text)
+          (define/public (set-definitions-text dt) (set! definitions-text dt))
+          
+          (unless (is-a? context context<%>)
+            (error 'drscheme:rep:text% 
+                   "expected an object that implements drscheme:rep:context<%> as initialization argument, got: ~e"
+                   context))
+          
+          (define/public (get-context) context)
+          
+          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+          ;;;					       ;;;
+          ;;;            User -> Kernel                ;;;
+          ;;;					       ;;;
+          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+          
+          ;; =User= (probably doesn't matter)
+          (define/private queue-system-callback
+            (opt-lambda (ut thunk [always? #f])
+              (parameterize ([current-eventspace drscheme:init:system-eventspace])
+                (queue-callback 
+                 (λ ()
+                   (when (or always? (eq? ut (get-user-thread)))
+                     (thunk)))
+                 #f))))
+          
+          ;; =User=
+          (define/private queue-system-callback/sync
+            (λ (ut thunk)
+              (let ([s (make-semaphore 0)])
+                (queue-system-callback 
+                 ut 
+                 (λ ()
+                   (when (eq? ut (get-user-thread))
+                     (thunk))
+                   (semaphore-post s))
+                 #t)
+                (semaphore-wait s))))
+          
+          ;; display-results : (listof TST) -> void
+          ;; prints each element of anss that is not void as values in the REPL.
+          (define/public (display-results anss) ; =User=, =Handler=, =Breaks=
+            (for-each 
+             (λ (v)
+               (unless (void? v)
+                 (let* ([ls (current-language-settings)]
+                        [lang (drscheme:language-configuration:language-settings-language ls)]
+                        [settings (drscheme:language-configuration:language-settings-settings ls)])
+                   (send lang render-value/format
+                         v
+                         settings
+                         (get-value-port)
+			 (get-repl-char-width)))))
+             anss))
+
+        ;; get-repl-char-width : -> (and/c exact? integer?)
+        ;; returns the width of the repl in characters, or 80 if the
+        ;; answer cannot be found.
+        (define/private (get-repl-char-width)
+          (let ([admin (get-admin)]
+                [standard (send (get-style-list) find-named-style "Standard")])
+            (if (and admin standard)
+                (let ([bw (box 0)])
+                  (send admin get-view #f #f bw #f)
+                  (let* ([dc (send admin get-dc)]
+                         [standard-font (send standard get-font)]
+                         [old-font (send dc get-font)])
+                    (send dc set-font standard-font)
+                    (let* ([char-width (send dc get-char-width)]
+                           [answer (inexact->exact (floor (/ (unbox bw) char-width)))])
+                      (send dc set-font old-font)
+                      answer)))
+                80)))
+          
+          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+          ;;;                                            ;;;
+          ;;;            Error Highlighting              ;;;
+          ;;;                                            ;;;
+          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+          
+          ;; error-ranges : (union false? (cons (list file number number) (listof (list file number number))))
+          (define error-ranges #f)
+          ;; error-arrows : (union #f (listof (cons editor<%> number)))
+          (define error-arrows #f)
+          (define/public (get-error-ranges) error-ranges)
+          (define internal-reset-callback void)
+          (define internal-reset-error-arrows-callback void)
+          (define/public (reset-error-ranges) 
+            (internal-reset-callback)
+            (internal-reset-error-arrows-callback))
+
+          ;; highlight-error : file number number -> void
+          (define/public (highlight-error file start end)
+            (highlight-errors (list (make-srcloc file #f #f start (- end start))) #f))
+          
+          ;; highlight-errors/exn : exn -> void
+          ;; highlights all of the errors associated with the exn (incl. arrows)
+          (define/public (highlight-errors/exn exn)
+            (let ([locs (cond
+                          [(exn:srclocs? exn)
+                           ((exn:srclocs-accessor exn) exn)]
+                          [else '()])])
+              (highlight-errors locs #f)))
+          
+          ;; =Kernel= =handler=
+          ;; highlight-errors :    (listof srcloc)
+          ;;                       (union #f (listof (list (is-a?/c text:basic<%>) number number)))
+          ;;                    -> (void)
+          (define/public (highlight-errors raw-locs error-arrows)
+            (let ([locs (filter (λ (loc) (and (is-a? (srcloc-source loc) text:basic<%>)
+                                              (number? (srcloc-position loc))
+                                              (number? (srcloc-span loc))))
+                                raw-locs)])
+              (reset-highlighting)
+              
+              (set! error-ranges locs)
+              
+              (let ([defs               
+                     (let ([f (get-top-level-window)])
+                       (and f
+                            (is-a? f drscheme:unit:frame<%>)
+                            (send f get-definitions-text)))])
+                
+                (for-each (λ (loc) (send (srcloc-source loc) begin-edit-sequence)) locs)
+                
+                (when color?
+                  (let ([resets
+                         (map (λ (loc)
+                                (let* ([file (srcloc-source loc)]
+                                       [start (- (srcloc-position loc) 1)]
+                                       [span (srcloc-span loc)]
+                                       [finish (+ start span)])
+                                  (send file highlight-range start finish error-color #f #f 'high)))
+                              locs)])
+                    
+                    (when (and defs error-arrows)
+                      (let ([filtered-arrows
+                             (remove-duplicate-error-arrows
+                              (filter
+                               (λ (arr)
+                                 (embedded-in? (car arr) defs))
+                               error-arrows))])
+                        (send defs set-error-arrows filtered-arrows)))
+                    
+                    (set! internal-reset-callback
+                          (λ ()
+                            (set! error-ranges #f)
+                            (when defs
+                              (send defs set-error-arrows #f))
+                            (set! internal-reset-callback void)
+                            (for-each (λ (x) (x)) resets)))))
+                
+                (let* ([first-loc (and (pair? locs) (car locs))]
+                       [first-file (and first-loc (srcloc-source first-loc))]
+                       [first-start (and first-loc (- (srcloc-position first-loc) 1))]
+                       [first-span (and first-loc (srcloc-span first-loc))])
+                  
+                  (when first-loc
+                    (let ([first-finish (+ first-start first-span)])
+                      (when (eq? first-file defs) ;; only move set the cursor in the defs window
+                        (send first-file set-position first-start first-start))
+                      (send first-file scroll-to-position first-start #f first-finish)))
+                  
+                  (for-each (λ (loc) (send (srcloc-source loc) end-edit-sequence)) locs)
+                  
+                  (when first-loc
+                    (send first-file set-caret-owner (get-focus-snip) 'global))))))
+          
+          (define/public (reset-highlighting)
+            (reset-error-ranges))
+          
+          ;; remove-duplicate-error-arrows : (listof X) -> (listof X)
+          ;; duplicate arrows point from and to the same place -- only
+          ;; need one arrow for each pair of locations they point to.
+          (define/private (remove-duplicate-error-arrows error-arrows)
+            (let ([ht (make-hash-table 'equal)])
+              (let loop ([arrs error-arrows]
+                         [n 0])
+                (unless (null? arrs)
+                  (hash-table-put! ht (car arrs) n)
+                  (loop (cdr arrs) (+ n 1))))
+              (let* ([unsorted (hash-table-map ht list)]
+                     [sorted (quicksort unsorted (λ (x y) (<= (cadr x) (cadr y))))]
+                     [arrs (map car sorted)])
+                arrs)))
+                    
+          (define/private (embedded-in? txt-inner txt-outer)
+            (let loop ([txt-inner txt-inner])
+              (cond
+                [(eq? txt-inner txt-outer) #t]
+                [else (let ([admin (send txt-inner get-admin)])
+                        (and (is-a? admin editor-snip-editor-admin<%>)
+                             (loop (send (send (send admin get-snip) get-admin) get-editor))))])))
+                    
+          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+          ;;
+          ;;  specialization
+          ;;
+          
+          (define/override (after-io-insertion) (send context ensure-rep-shown this))
+          
+          (define/augment (after-insert start len)
+            (inner (void) after-insert start len)
+            (cond
+              [(in-edit-sequence?) (set! had-an-insert? (cons start len))]
+              [else (update-after-insert)]))
+          
+          (define had-an-insert? #f)
+          
+          (define/augment (on-edit-sequence)
+            (set! had-an-insert? #f))
+          
+          (define/augment (after-edit-sequence)
+            (when had-an-insert?
+              (update-after-insert (car had-an-insert?) (cdr had-an-insert?))))
+          
+          (define/private (update-after-insert start len)
+            (unless inserting-prompt?
+              (reset-highlighting))
+            (when (and prompt-position (< start prompt-position))
+              
+              ;; trim extra space, according to preferences
+              #;
+              (let* ([start (get-repl-header-end)]
+                     [end (get-insertion-point)]
+                     [space (- end start)]
+                     [pref (preferences:get 'drscheme:repl-buffer-size)])
+                (when (car pref)
+                  (let ([max-space (* 1000 (cdr pref))])
+                    (when (space . > . max-space)
+                      (let ([to-delete-end (+ start (- space max-space))])
+                        (delete/io start to-delete-end))))))
+              
+              (set! prompt-position (get-unread-start-point))
+              (reset-region prompt-position 'end)))
+          
+          (define/augment after-delete
+            (lambda (x y)
+              (unless inserting-prompt?
+                (reset-highlighting))
+              (inner (void) after-delete x y)))
+          
+          (define/override get-keymaps
+            (λ ()
+              (cons scheme-interaction-mode-keymap (super get-keymaps))))
+          
+          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+          ;;;                                            ;;;
+          ;;;                Evaluation                  ;;;
+          ;;;                                            ;;;
+          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+          
+          (define/public (eval-busy?)
+            (not (and (get-user-thread)
+                      (thread-running? (get-user-thread)))))
+          
+          (field (user-language-settings #f)
+                 (user-teachpack-cache (preferences:get 'drscheme:teachpacks))
+                 (user-custodian #f)
+                 (user-eventspace-box (make-weak-box #f))
+                 (user-namespace-box (make-weak-box #f))
+                 (user-thread-box (make-weak-box #f))
+                 (user-break-parameterization #f))
+
+          (define/public (get-user-language-settings) user-language-settings)
+          (define/public (get-user-custodian) user-custodian)
+          (define/public (get-user-teachpack-cache) user-teachpack-cache)
+          (define/public (set-user-teachpack-cache tpc) (set! user-teachpack-cache tpc))
+          (define/public (get-user-eventspace) (weak-box-value user-eventspace-box))
+          (define/public (get-user-thread) (weak-box-value user-thread-box))
+          (define/public (get-user-namespace) (weak-box-value user-namespace-box))
+          (define/public (get-user-break-parameterization) user-break-parameterization)
+          
+          (field (in-evaluation? #f) ; a heursitic for making the Break button send a break
+                 (should-collect-garbage? #f)
+                 (ask-about-kill? #f))
+          (define/public (get-in-evaluation?) in-evaluation?)
+          
+          (define/private (insert-warning)
+            (begin-edit-sequence)
+            (insert-between "\n")
+            (let ([start (get-unread-start-point)])
+              (insert-between
+               (string-constant interactions-out-of-sync))
+              (let ([end (get-unread-start-point)])
+                (change-style warning-style-delta start end)))
+            (end-edit-sequence))
+          
+          (field (already-warned? #f))
+          
+          (define/private (cleanup)
+            (set! in-evaluation? #f)
+            (update-running #f)
+            (unless (and (get-user-thread) (thread-running? (get-user-thread)))
+              (lock #t)
+              (unless shutting-down?
+                (no-user-evaluation-message
+                 (let ([canvas (get-active-canvas)])
+                   (and canvas
+                        (send canvas get-top-level-window)))))))
+          (field (need-interaction-cleanup? #f))
+          
+          (define/private (cleanup-interaction) ; =Kernel=, =Handler=
+            (set! need-interaction-cleanup? #f)
+            (begin-edit-sequence)
+            (set-caret-owner #f 'display)
+            (cleanup)
+            (end-edit-sequence)
+            (send context set-breakables #f #f)
+            (send context enable-evaluation))
+          
+          (inherit backward-containing-sexp)
+          
+          (define/augment (submit-to-port? key) 
+            (and prompt-position
+                 (only-whitespace-after-insertion-point)
+                 (submit-predicate this prompt-position)))
+          
+          (define/private (only-whitespace-after-insertion-point)
+            (let ([start (get-start-position)]
+                  [end (get-end-position)])
+              (and (= start end)
+                   (let loop ([pos start])
+                     (cond
+                       [(= pos (last-position)) #t]
+                       [else (and (char-whitespace? (get-character pos))
+                                  (loop (+ pos 1)))])))))
+          
+          (define/augment (on-submit)
+            (inner (void) on-submit)
+            ;; the -2 drops the last newline from history (why -2 and not -1?!)
+            (save-interaction-in-history prompt-position (- (last-position) 2))
+            (freeze-colorer)
+            
+            (let* ([needs-execution? (send context needs-execution?)])
+              (when (if (preferences:get 'drscheme:execute-warning-once)
+                        (and (not already-warned?)
+                             needs-execution?)
+                        needs-execution?)
+                (set! already-warned? #t)
+                (insert-warning)))
+            
+            ;; put two eofs in the port; one to terminate a potentially incomplete sexp
+            ;; (or a non-self-terminating one, like a number) and the other to ensure that
+            ;; an eof really does come thru the calls to `read'. 
+            ;; the cleanup thunk clears out the extra eof, if one is still there after evaluation
+            (send-eof-to-in-port)
+            (send-eof-to-in-port)
+            (set! prompt-position #f)
+            (evaluate-from-port
+             (get-in-port) 
+             #f
+             (λ ()
+               (clear-input-port))))
+          
+          ;; prompt-position : (union #f integer)
+          ;; the position just after the last prompt
+          (field (prompt-position #f))
+          (define inserting-prompt? #f)
+          (define/public (get-prompt) "> ")
+          (define/public (insert-prompt)
+            (set! inserting-prompt? #t)
+            (begin-edit-sequence)
+            (reset-input-box)
+            (let* ([pmt (get-prompt)]
+                   [prompt-space (string-length pmt)])
+              
+              ;; insert the prompt, possibly inserting a newline first
+              (let* ([usp (get-unread-start-point)]
+                     [usp-para (position-paragraph usp)]
+                     [usp-para-start (paragraph-start-position usp-para)])
+                (unless (equal? usp usp-para-start)
+                  (insert-between "\n")
+                  (set! prompt-space (+ prompt-space 1)))
+                (insert-between pmt))
+              
+              (let ([sp (get-unread-start-point)])
+                (set! prompt-position sp)
+                (reset-region sp 'end)
+                (when (is-frozen?) (thaw-colorer))))
+            (end-edit-sequence)
+            (set! inserting-prompt? #f))
+          
+          (field [submit-predicate (λ (text prompt-position) #t)])
+          (define/public (set-submit-predicate p)
+            (set! submit-predicate p))
+          
+          (define/public (evaluate-from-port port complete-program? cleanup) ; =Kernel=, =Handler=
+              (send context disable-evaluation)
+              (send context reset-offer-kill)
+              (send context set-breakables (get-user-thread) (get-user-custodian))
+              (reset-pretty-print-width)
+              (when should-collect-garbage?
+                (set! should-collect-garbage? #f)
+                (collect-garbage))
+              (set! in-evaluation? #t)
+              (update-running #t)
+              (set! need-interaction-cleanup? #t)
+              
+            (run-in-evaluation-thread
+             (λ () ; =User=, =Handler=, =No-Breaks=
+               (let* ([settings (current-language-settings)]
+                      [lang (drscheme:language-configuration:language-settings-language settings)]
+                      [settings (drscheme:language-configuration:language-settings-settings settings)]
+                      [get-sexp/syntax/eof 
+                       (if complete-program?
+                           (send lang front-end/complete-program port settings user-teachpack-cache)
+                           (send lang front-end/interaction port settings user-teachpack-cache))])
+                 
+                 ; Evaluate the user's expression. We're careful to turn on
+                 ;   breaks as we go in and turn them off as we go out.
+                 ;   (Actually, we adjust breaks however the user wanted it.)
+                 ; A continuation hop might take us out of this instance of
+                 ;   evaluation and into another one, which is fine.
+                 
+                 (let/ec k
+                   (let ([saved-error-escape-k (current-error-escape-k)]
+                         [cleanup? #f])
+                     (dynamic-wind
+                      (λ ()
+                        (set! cleanup? #f)
+                        (current-error-escape-k (λ () 
+                                                  (set! cleanup? #t)
+                                                  (k (void)))))
+                      (λ () 
+                        (let loop ()
+                          (let ([sexp/syntax/eof (get-sexp/syntax/eof)])
+                            (unless (eof-object? sexp/syntax/eof)
+                              (call-with-values
+                               (λ ()
+                                 (call-with-break-parameterization
+                                  (get-user-break-parameterization)
+                                  (λ ()
+                                    (eval-syntax sexp/syntax/eof))))
+                               (λ x (display-results x)))
+                              (loop))))
+                        (set! cleanup? #t))
+                      (λ () 
+                        (current-error-escape-k saved-error-escape-k)
+                        (when cleanup?
+                          (set! in-evaluation? #f)
+                          (update-running #f)
+                          (cleanup)
+                          (flush-output (get-value-port))
+                          (queue-system-callback/sync
+                           (get-user-thread)
+                           (λ () ; =Kernel=, =Handler= 
+                             (after-many-evals)
+                             (cleanup-interaction)
+                             (insert-prompt))))))))))))
+          
+          (define/pubment (after-many-evals) (inner (void) after-many-evals))
+          
+          (define/private shutdown-user-custodian ; =Kernel=, =Handler=
+            ; Use this procedure to shutdown when in the middle of other cleanup
+            ;  operations, such as when the user clicks "Execute".
+            ; Don't use it to kill a thread where other, external cleanup
+            ;  actions must occur (e.g., the exit handler for the user's
+            ;  thread). In that case, shut down user-custodian directly.
+            (λ ()
+              (when user-custodian
+                (custodian-shutdown-all user-custodian))
+	      (set! user-custodian #f)
+              (set! user-thread-box (make-weak-box #f))))
+          
+          (define/public (kill-evaluation) ; =Kernel=, =Handler=
+            (when user-custodian
+              (custodian-shutdown-all user-custodian))
+	    (set! user-custodian #f))
+          
+          (field (user-break-enabled #t))
+          
+          (field (eval-thread-thunks null)
+                 (eval-thread-state-sema 'not-yet-state-sema)
+                 (eval-thread-queue-sema 'not-yet-thread-sema)
+                 
+                 (cleanup-sucessful 'not-yet-cleanup-sucessful)
+                 (cleanup-semaphore 'not-yet-cleanup-semaphore)
+                 (thread-grace 'not-yet-thread-grace)
+                 (thread-killed 'not-yet-thread-killed))
+          (define/private (initialize-killed-thread) ; =Kernel=
+            (when (thread? thread-killed)
+              (kill-thread thread-killed))
+            (set! thread-killed
+                  (thread
+                   (λ () ; =Kernel=
+                     (let ([ut (get-user-thread)])
+                       (thread-wait ut)
+                       (queue-system-callback
+                        ut
+                        (λ () ; =Kernel=, =Handler=
+                          (if need-interaction-cleanup?
+                              (cleanup-interaction)
+                              (cleanup)))))))))
+          
+          (define/private protect-user-evaluation ; =User=, =Handler=, =No-Breaks=
+            (λ (thunk cleanup)
+              
+              ;; We only run cleanup if thunk finishes normally or tries to
+              ;; error-escape. Otherwise, it must be a continuation jump
+              ;; into a different call to protect-user-evaluation.
+              
+              ;; `thunk' is responsible for ensuring that breaks are off when
+              ;; it returns or jumps out.
+              
+              (set! in-evaluation? #t)
+              (update-running #t)
+              
+              (let/ec k
+                (let ([saved-error-escape-k (current-error-escape-k)]
+                      [cleanup? #f])
+                  (dynamic-wind
+                   (λ ()
+                     (set! cleanup? #f)
+                     (current-error-escape-k (λ () 
+					       (set! cleanup? #t)
+					       (k (void)))))
+		  (λ () 
+                     (thunk) 
+                     ; Breaks must be off!
+                     (set! cleanup? #t))
+                   (λ () 
+                     (current-error-escape-k saved-error-escape-k)
+                     (when cleanup?
+                       (set! in-evaluation? #f)
+                       (update-running #f)
+                       (cleanup))))))))
+          
+          (define/public (run-in-evaluation-thread thunk) ; =Kernel=
+            (semaphore-wait eval-thread-state-sema)
+            (set! eval-thread-thunks (append eval-thread-thunks (list thunk)))
+            (semaphore-post eval-thread-state-sema)
+            (semaphore-post eval-thread-queue-sema))
+          
+          (define/private init-evaluation-thread ; =Kernel=
+            (λ ()
+              (let ([default (preferences:get drscheme:language-configuration:settings-preferences-symbol)]
+                    [frame (get-top-level-window)])
+                (if frame
+                    (let ([defs (send frame get-definitions-text)])
+                      (set! user-language-settings (send defs get-next-settings)))
+                    (set! user-language-settings default)))
+              
+              (set! user-custodian (make-custodian))
+	      ; (custodian-limit-memory user-custodian 10000000 user-custodian)
+              (set! user-eventspace-box (make-weak-box
+					 (parameterize ([current-custodian user-custodian])
+					   (make-eventspace))))
+              (set! user-break-parameterization (parameterize-break 
+                                                 #t 
+                                                 (current-break-parameterization)))
+              (set! user-break-enabled #t)
+              (set! eval-thread-thunks null)
+              (set! eval-thread-state-sema (make-semaphore 1))
+              (set! eval-thread-queue-sema (make-semaphore 0))
+              
+              (let* ([init-thread-complete (make-semaphore 0)]
+                     [goahead (make-semaphore)]
+                     [queue-user/wait
+                      (λ (thnk)
+                        (let ([wait (make-semaphore 0)])
+                          (parameterize ([current-eventspace (get-user-eventspace)])
+                            (queue-callback
+                             (λ ()
+                               (thnk)
+                               (semaphore-post wait))))
+                          (semaphore-wait wait)))])
+                
+                ; setup standard parameters
+                (let ([snip-classes
+                       ; the snip-classes in the DrScheme eventspace's snip-class-list
+                       (drscheme:eval:get-snip-classes)])
+                  (queue-user/wait
+                   (λ () ; =User=, =No-Breaks=
+                     ; No user code has been evaluated yet, so we're in the clear...
+                     (break-enabled #f)
+                     (set! user-thread-box (make-weak-box (current-thread)))
+                     (initialize-parameters snip-classes))))
+                
+                ;; disable breaks until an evaluation actually occurs
+                (send context set-breakables #f #f)
+                
+                ;; initialize the language
+                (send (drscheme:language-configuration:language-settings-language user-language-settings)
+                      on-execute
+                      (drscheme:language-configuration:language-settings-settings user-language-settings)
+                      queue-user/wait)
+                
+                ;; installs the teachpacks
+                ;; must happen after language is initialized.
+                (queue-user/wait
+                 (λ () ; =User=, =No-Breaks=
+                   (drscheme:teachpack:install-teachpacks 
+                    user-teachpack-cache)))
+                
+                (parameterize ([current-eventspace (get-user-eventspace)])
+                  (queue-callback
+                   (λ ()
+                     (let ([drscheme-error-escape-handler
+                            (λ ()
+			      ((current-error-escape-k)))])
+                       (error-escape-handler drscheme-error-escape-handler))
+                     
+                     (set! in-evaluation? #f)
+                     (update-running #f)
+		     (send context set-breakables #f #f)
+                     
+                     ;; let init-thread procedure return,
+                     ;; now that parameters are set
+                     (semaphore-post init-thread-complete)
+                     
+                     ; We're about to start running user code.
+                     
+                     ; Pause to let killed-thread get initialized
+                     (semaphore-wait goahead)
+                     
+                     (let loop () ; =User=, =Handler=, =No-Breaks=
+                       ; Wait for something to do
+                       (unless (semaphore-try-wait? eval-thread-queue-sema)
+                         ; User event callbacks run here; we turn on
+                         ;  breaks in the dispatch handler.
+                         (yield eval-thread-queue-sema))
+                       ; About to eval something
+                       (semaphore-wait eval-thread-state-sema)
+                       (let ([thunk (car eval-thread-thunks)])
+                         (set! eval-thread-thunks (cdr eval-thread-thunks))
+                         (semaphore-post eval-thread-state-sema)
+                         ; This thunk evals the user's expressions with appropriate
+                         ;   protections.
+                         (thunk))
+                       (loop)))))
+                (semaphore-wait init-thread-complete)
+                ; Start killed-thread
+                (initialize-killed-thread)
+                ; Let user expressions go...
+                (semaphore-post goahead))))
+          
+          (field (shutting-down? #f))
+
+          (define/override (allow-close-with-no-filename?) #t)
+          (define/augment (can-close?)
+            (and (cond
+                   [in-evaluation?
+                    (equal? (message-box/custom
+                             (string-constant drscheme)
+                             (string-constant program-is-still-running)
+                             (string-constant close-anyway)
+                             (string-constant cancel)
+                             #f
+                             (or (get-top-level-window) (get-can-close-parent))
+                             '(default=1 caution)
+                             2)
+                            1)]
+                   [(let ([user-eventspace (get-user-eventspace)])
+                      (and user-eventspace
+                           (parameterize ([current-eventspace user-eventspace])
+                             (not (null? (get-top-level-windows))))))
+                    (equal? (message-box/custom
+                             (string-constant drscheme)
+                             (string-constant program-has-open-windows)
+                             (string-constant close-anyway)
+                             (string-constant cancel)
+                             #f
+                             (or (get-top-level-window) (get-can-close-parent))
+                             '(default=1 caution)
+                             2)
+                            1)]
+                   [else #t])
+                 (inner #t can-close?)))
+          
+          (define/augment (on-close)
+            (shutdown)
+            (preferences:set 'drscheme:console-previous-exprs 
+                             (trim-previous-exprs
+                              (append 
+                               (preferences:get 'drscheme:console-previous-exprs)
+                               local-previous-exprs)))
+            (inner (void) on-close))
+          
+          (define/public (shutdown) ; =Kernel=, =Handler=
+            (set! shutting-down? #t)
+            (when (thread? thread-killed)
+              (kill-thread thread-killed)
+              (set! thread-killed #f))
+            (shutdown-user-custodian))
+          
+          (define/private update-running ; =User=, =Handler=, =No-Breaks=
+            (λ (bool)
+              (queue-system-callback
+               (get-user-thread)
+               (λ ()
+                 (send context update-running bool)))))
+          
+          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+          ;;;                                          ;;;
+          ;;;                Execution                 ;;;
+          ;;;                                          ;;;
+          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+          
+          ;; initialize-paramters : (listof snip-class%) -> void
+          (define/private initialize-parameters ; =User=
+            (λ (snip-classes)
+              
+              (current-language-settings user-language-settings)
+              (error-value->string-handler drscheme-error-value->string-handler)
+              (error-print-source-location #f)
+              (error-display-handler drscheme-error-display-handler)
+              (current-load-relative-directory #f)
+              (current-custodian user-custodian)
+              (current-load text-editor-load-handler)
+              
+              (drscheme:eval:set-basic-parameters snip-classes)
+              (current-rep this)
+              (let ([dir (or (send context get-directory)
+                           drscheme:init:first-dir)])
+                (current-directory dir)
+                (current-load-relative-directory dir))
+              
+              (set! user-namespace-box (make-weak-box (current-namespace)))
+              
+              (current-output-port (get-out-port))
+              (current-error-port (get-err-port))
+              (current-value-port (get-value-port))
+              (current-input-port (get-in-box-port))
+              ;(current-input-port (make-input-port #f (λ (bytes) eof) #f void))
+              (break-enabled #t)
+              (let* ([primitive-dispatch-handler (event-dispatch-handler)])
+                (event-dispatch-handler
+                 (rec drscheme-event-dispatch-handler ; <= a name for #<...> printout
+                   (λ (eventspace) ; =User=, =Handler=
+                     ; Breaking is enabled if the user turned on breaks and
+                     ;  is in a `yield'. If we get a break, that's ok, because
+                     ;  the kernel never queues an event in the user's eventspace.
+                     (cond
+                       [(eq? eventspace (get-user-eventspace))
+                        ; =User=, =Handler=, =No-Breaks=
+                        
+                        (let* ([ub? (eq? user-break-enabled 'user)]
+                               [break-ok? (if ub?
+                                              (break-enabled)
+                                              user-break-enabled)])
+                          (break-enabled #f)
+                          
+                          ; We must distinguish between "top-level" events and
+                          ;  those within `yield' in the user's program.
+                          
+                          (cond
+                            [(not in-evaluation?)
+                             (send context reset-offer-kill)
+                             (send context set-breakables (get-user-thread) (get-user-custodian))
+                             
+                             (protect-user-evaluation
+                              ; Run the dispatch:
+                              (λ () ; =User=, =Handler=, =No-Breaks=
+                                ; This procedure is responsible for adjusting breaks to
+                                ;  match the user's expectations:
+                                (dynamic-wind
+                                 (λ () 
+                                   (break-enabled break-ok?)
+                                   (unless ub?
+                                     (set! user-break-enabled 'user)))
+                                   (λ ()
+                                     (primitive-dispatch-handler eventspace))
+                                   (λ ()
+                                     (unless ub?
+                                       (set! user-break-enabled (break-enabled)))
+                                     (break-enabled #f))))
+                              ; Cleanup after dispatch
+                              (λ ()
+                                ;; in principle, the line below might cause
+                                ;; a "race conditions" in the GUI. That is, there might
+                                ;; be many little events that the user won't quite
+                                ;; be able to break.
+                                (send context set-breakables #f #f)))
+                             
+                             ; Restore break:
+                             (when ub?
+                               (break-enabled break-ok?))]
+                            [else
+                             ; Nested dispatch; don't adjust interface, and restore break:
+                             (break-enabled break-ok?)
+                             (primitive-dispatch-handler eventspace)]))]
+                       [else 
+                        ; =User=, =Non-Handler=, =No-Breaks=
+                        (primitive-dispatch-handler eventspace)])))))))
+          
+          (define/public (reset-console)
+            (when (thread? thread-killed)
+              (kill-thread thread-killed))
+            (send context clear-annotations)
+            (drscheme:debug:hide-backtrace-window)
+            (shutdown-user-custodian)
+            (clear-input-port)
+            (clear-box-input-port)
+            (clear-output-ports)
+            (set-allow-edits #t)
+            (set! should-collect-garbage? #t)
+            
+            ;; in case the last evaluation thread was killed, clean up some state.
+            (lock #f)
+            (set! in-evaluation? #f)
+            (update-running #f)
+            
+            ;; clear out repl first before doing any work.
+            (begin-edit-sequence)
+            (freeze-colorer)
+            (reset-input-box)
+            (delete (paragraph-start-position 1) (last-position))
+            (end-edit-sequence)
+            
+            ;; must init-evaluation-thread before determining
+            ;; the language's name, since this updates user-language-settings
+            (init-evaluation-thread)
+            
+            (begin-edit-sequence)
+            (set-position (last-position) (last-position))
+            
+            (set! setting-up-repl? #t)
+            (insert/delta this (string-append (string-constant language) ": ") welcome-delta)
+            (let-values (((before after)
+                          (insert/delta
+                           this
+                           (extract-language-name user-language-settings)
+                           dark-green-delta
+                           (extract-language-style-delta user-language-settings)))
+                         ((url) (extract-language-url user-language-settings)))
+              (when url
+                (set-clickback before after (λ args (send-url url))
+                               click-delta)))
+            (unless (is-default-settings? user-language-settings)
+              (insert/delta this (string-append " " (string-constant custom)) dark-green-delta))
+            (insert/delta this (format ".~n") welcome-delta)
+            
+            (for-each
+             (λ (fn)
+               (insert/delta this
+                             (string-append (string-constant teachpack) ": ")
+                             welcome-delta)
+               (insert/delta this fn dark-green-delta)
+               (insert/delta this (format ".~n") welcome-delta))
+             (map path->string 
+                  (drscheme:teachpack:teachpack-cache-filenames 
+                   user-teachpack-cache)))
+            (set! setting-up-repl? #f)
+            
+            (set! already-warned? #f)
+            (reset-region (last-position) (last-position))
+            (set-unread-start-point (last-position))
+            (set-insertion-point (last-position))
+            (set-allow-edits #f)
+            (set! repl-header-end #f)
+            (end-edit-sequence))
+          
+          (define/public (initialize-console)
+            (begin-edit-sequence)
+            (freeze-colorer)
+            (set! setting-up-repl? #t)
+            (insert/delta this (string-append (string-constant welcome-to) " ") welcome-delta)
+            (let-values ([(before after)
+                          (insert/delta this (string-constant drscheme) click-delta drs-font-delta)])
+              (insert/delta this (format (string-append ", " (string-constant version) " ~a.~n") (version:version))
+                            welcome-delta)
+              (set-clickback before after 
+                             (λ args (drscheme:app:about-drscheme))
+                             click-delta))
+            (set! setting-up-repl? #f)
+            (thaw-colorer)
+            (send context disable-evaluation)
+            (reset-console)
+            (insert-prompt)
+            (send context enable-evaluation)
+            (end-edit-sequence)
+            (clear-undos))
+          
+          ;; avoid calling paragraph-start-position very often.
+          (define repl-header-end #f)
+          (define/private (get-repl-header-end)
+            (if repl-header-end
+                repl-header-end
+                (begin (set! repl-header-end (paragraph-start-position 2))
+                       repl-header-end)))
+                    
+          (define setting-up-repl? #f)
+          (define/augment (can-change-style? start len)
+            (and (inner #t can-change-style? start len)
+                 (or setting-up-repl?
+                     (start . >= . (get-repl-header-end)))))
+          
+          (define/private (last-str l)
+            (if (null? (cdr l))
+                (car l)
+                (last-str (cdr l))))
+          
+          (field (previous-expr-pos -1))
+          
+          (define/public (copy-previous-expr)
+            (when prompt-position
+              (let ([snip/strings (list-ref (get-previous-exprs) previous-expr-pos)])
+                (begin-edit-sequence)
+                (delete prompt-position (last-position) #f)
+                (for-each (λ (snip/string)
+                            (insert (if (is-a? snip/string snip%)
+                                        (send snip/string copy)
+                                        snip/string)
+                                    prompt-position))
+                          snip/strings)
+                (set-position (last-position))
+                (end-edit-sequence))))
+          
+          (define/public copy-next-previous-expr
+            (λ ()
+              (let ([previous-exprs (get-previous-exprs)])
+                (unless (null? previous-exprs)
+                  (set! previous-expr-pos
+                        (if (< (add1 previous-expr-pos) (length previous-exprs))
+                            (add1 previous-expr-pos)
+                            0))
+                  (copy-previous-expr)))))
+          (define/public copy-prev-previous-expr
+            (λ ()
+              (let ([previous-exprs (get-previous-exprs)])
+                (unless (null? previous-exprs)
+                  (set! previous-expr-pos
+                        (if (previous-expr-pos . <= . 0)
+                            (sub1 (length previous-exprs))
+                            (sub1 previous-expr-pos)))
+                  (copy-previous-expr)))))
+          
+          ;; private fields
+          (define global-previous-exprs (preferences:get 'drscheme:console-previous-exprs))
+          (define local-previous-exprs null)
+          (define/private (get-previous-exprs)
+            (append global-previous-exprs local-previous-exprs))
+          (define/private (add-to-previous-exprs snips)
+            (let* ([new-previous-exprs 
+                    (let* ([trimmed-previous-exprs (trim-previous-exprs local-previous-exprs)])
+                      (let loop ([l trimmed-previous-exprs])
+                        (if (null? l)
+                            (list snips)
+                            (cons (car l) (loop (cdr l))))))])
+              (set! local-previous-exprs new-previous-exprs)))
+          
+          (define/private (trim-previous-exprs lst)
+            (if ((length lst). >= .  console-max-save-previous-exprs)
+                (cdr lst)
+                lst))
+          
+          (define/private (save-interaction-in-history start end)
+            (split-snip start)
+            (split-snip end)
+            (let ([snips
+                   (let loop ([snip (find-snip start 'after-or-none)]
+                              [snips null])
+                     (cond
+                       [(not snip) snips]
+                       [((get-snip-position snip) . <= . end)
+                        (loop (send snip next)
+                              (cons (send snip copy) snips))]
+                       [else snips]))])
+              (set! previous-expr-pos -1)
+              (add-to-previous-exprs snips)))
+          
+          (define/public (reset-pretty-print-width)
+            (let* ([standard (send (get-style-list) find-named-style "Standard")])
+              (when standard
+                (let* ([admin (get-admin)]
+                       [width
+                        (let ([bw (box 0)]
+                              [b2 (box 0)])
+                          (send admin get-view b2 b2 bw b2)
+                          (unbox bw))]
+                       [dc (send admin get-dc)]
+                       [new-font (send standard get-font)]
+                       [old-font (send dc get-font)])
+                  (send dc set-font new-font)
+                  (let* ([char-width (send dc get-char-width)]
+                         [min-columns 50]
+                         [new-columns (max min-columns 
+                                           (floor (/ width char-width)))])
+                    (send dc set-font old-font)
+                    (pretty-print-columns new-columns))))))
+          
+          (super-new)
+          (auto-wrap #t)
+          (set-styles-sticky #f)))
+      
+      (define input-delta (make-object style-delta%))
+      (send input-delta set-delta-foreground (make-object color% 0 150 0))
+          
+      ;; insert-error-in-text : (is-a?/c text%)
+      ;;                        (union #f (is-a?/c drscheme:rep:text<%>))
+      ;;                        string?
+      ;;                        exn?
+      ;;                        (union false? (and/c string? directory-exists?))
+      ;;                        ->
+      ;;                        void?
+      (define (insert-error-in-text text interactions-text msg exn user-dir)
+        (insert-error-in-text/highlight-errors
+         text
+         (λ (l) (send interactions-text highlight-errors l))
+         msg
+         exn
+         user-dir))
+      
+      ;; insert-error-in-text/highlight-errors : (is-a?/c text%)
+      ;;                                         ((listof (list text% number number)) -> void)
+      ;;                                         string?
+      ;;                                         exn?
+      ;;                                         (union false? (and/c string? directory-exists?))
+      ;;                                         ->
+      ;;                                         void?
+      (define (insert-error-in-text/highlight-errors text highlight-errors msg exn user-dir)
+        (let ([locked? (send text is-locked?)]
+              [insert-file-name/icon
+               ;; insert-file-name/icon : string number number number number -> void
+               (λ (source-name start span row col)
+                 (let* ([range-spec
+                         (cond
+                           [(and row col)
+                            (format ":~a:~a" row col)]
+                           [start
+                            (format "::~a" start)]
+                           [else ""])])
+                   (cond
+                     [(file-exists? source-name)
+                      (let* ([normalized-name (normalize-path source-name)]
+                             [short-name (if user-dir
+                                             (find-relative-path user-dir normalized-name)
+                                             source-name)])
+                        (let-values ([(icon-start icon-end) (insert/delta text (send file-icon copy))]
+                                     [(space-start space-end) (insert/delta text " ")]
+                                     [(name-start name-end) (insert/delta text short-name)]
+                                     [(range-start range-end) (insert/delta text range-spec)]
+                                     [(colon-start colon-ent) (insert/delta text ": ")])
+                          (when (number? start)
+                            (send text set-clickback icon-start range-end
+                                  (λ (_1 _2 _3)
+                                    (open-file-and-highlight normalized-name
+                                                             (- start 1) 
+                                                             (if span
+                                                                 (+ start -1 span)
+                                                                 start)))))))]
+                     [else
+                      (insert/delta text source-name)
+                      (insert/delta text range-spec)
+                      (insert/delta text ": ")])))])
+          (send text begin-edit-sequence)
+          (send text lock #f)
+          (cond
+            [(exn:fail:syntax? exn)
+             (for-each
+              (λ (expr)
+                (let ([src (and (syntax? expr) (syntax-source expr))]
+                      [pos (and (syntax? expr) (syntax-position expr))]
+                      [span (and (syntax? expr) (syntax-span expr))]
+                      [col (and (syntax? expr) (syntax-column expr))]
+                      [line (and (syntax? expr) (syntax-line expr))])
+                  (when (and (string? src)
+                             (number? pos)
+                             (number? span)
+                             (number? line)
+                             (number? col))
+                    (insert-file-name/icon src pos span line col))
+                  (insert/delta text (format "~a" (exn-message exn)) error-delta)
+                  (when (syntax? expr)
+                    (insert/delta text " in: ")
+                    (insert/delta text (format "~s" (syntax-object->datum expr)) error-text-style-delta))
+                  (insert/delta text "\n")
+                  (when (and (is-a? src text:basic%)
+                             (number? pos)
+                             (number? span))
+                    (highlight-errors (list (list src (- pos 1) (+ pos -1 span)))))))
+              (exn:fail:syntax-exprs exn))]
+            [(exn:fail:read? exn)
+             '(let ([src (exn:read-source exn)]
+                    [pos (exn:read-position exn)]
+                    [span (exn:read-span exn)]
+                    [line (exn:read-line exn)]
+                    [col (exn:read-column exn)])
+                (when (and (string? src)
+                           (number? pos)
+                           (number? span)
+                           (number? line)
+                           (number? col))
+                  (insert-file-name/icon src pos span line col))
+                (insert/delta text (format "~a" (exn-message exn)) error-delta)
+                (insert/delta text "\n")
+                (when (and (is-a? src text:basic%)
+                           (number? pos)
+                           (number? span))
+                  (highlight-errors (list (list src (- pos 1) (+ pos -1 span))))))]
+            [(exn? exn)
+             (insert/delta text (format "~a" (exn-message exn)) error-delta)
+             (insert/delta text "\n")]
+            [else
+             (insert/delta text "uncaught exception: " error-delta)
+             (insert/delta text (format "~s" exn) error-delta)
+             (insert/delta text "\n")])
+          (send text lock locked?)
+          (send text end-edit-sequence)))
+
+
+      ;; open-file-and-highlight : string (union number #f) (union number #f)
+      ;; =Kernel, =Handler=
+      ;; opens the file named by filename. If position is #f,
+      ;; doesn't highlight anything. If position is a number and other-position
+      ;; is #f, highlights the range from position to the end of sexp.
+      ;; if other-position is a number, highlights from position to 
+      ;; other position.
+      (define (open-file-and-highlight filename position other-position)
+        (let ([file (handler:edit-file filename)])
+          (when (and (is-a? file drscheme:unit:frame%)
+                     position)
+            (if other-position
+                (send (send file get-interactions-text)
+                      highlight-error
+                      (send file get-definitions-text)
+                      position
+                      other-position)
+                (send (send file get-interactions-text)
+                      highlight-error/forward-sexp
+                      (send file get-definitions-text)
+                      position)))))
+      
+
+                           
+      (define -text% 
+        (drs-bindings-keymap-mixin
+         (text-mixin 
+          (text:ports-mixin
+           (scheme:text-mixin
+            (color:text-mixin
+             (text:info-mixin
+              (editor:info-mixin
+               (text:searching-mixin
+                (text:nbsp->space-mixin
+                 (mode:host-text-mixin
+                  (text:foreground-color-mixin
+                   text:clever-file-format%)))))))))))))))
diff --git a/collects/drscheme/private/start.ss b/collects/drscheme/private/start.ss
new file mode 100644
index 0000000000..ff936d439c
--- /dev/null
+++ b/collects/drscheme/private/start.ss
@@ -0,0 +1,12 @@
+
+(module start mzscheme
+  (require "link.ss"
+	   "drsig.ss"
+	   (lib "class.ss")
+	   (lib "unitsig.ss")
+           (lib "framework.ss" "framework")
+	   (lib "splash.ss" "framework"))
+  
+  (shutdown-splash)
+  (define-values/invoke-unit/sig drscheme^ drscheme@)
+  (close-splash))
diff --git a/collects/drscheme/private/syncheck-debug.ss b/collects/drscheme/private/syncheck-debug.ss
new file mode 100644
index 0000000000..240bc2519c
--- /dev/null
+++ b/collects/drscheme/private/syncheck-debug.ss
@@ -0,0 +1,164 @@
+(module syncheck-debug mzscheme
+  (require (lib "pretty.ss")
+           (lib "list.ss")
+           (lib "class.ss")
+           (lib "mred.ss" "mred"))
+  
+  (provide debug-origin)  ;; : syntax [syntax] -> void
+                          ;; creates a frame for examining the 
+                          ;; origin and source fields of an expanded sexp
+                          ;; also the 'bound-in-source syntax property
+  
+  (define debug-origin
+    (case-lambda 
+     [(original-object) (debug-origin original-object (expand original-object))]
+     [(original-object expanded-object)
+      (define-values (expanded-datum stx-ht) (syntax-object->datum/ht expanded-object))
+      
+      (define output-text (make-object text%))
+      (define output-port (make-text-port output-text))
+      (define info-text (make-object text%))
+      (define info-port (make-text-port info-text))
+      
+      ;; assume that there aren't any eq? sub structures, only eq? flat stuff (symbols, etc)
+      ;; this is guaranteed by syntax-object->datum/ht
+      (define range-start-ht (make-hash-table))
+      (define range-ht (make-hash-table))
+      (define original-output-port (current-output-port))
+      (define (range-pretty-print-pre-hook x v)
+        (hash-table-put! range-start-ht x (send output-text last-position)))
+      (define (range-pretty-print-post-hook x v)
+        (hash-table-put! range-ht x 
+                         (cons
+                          (cons
+                           (hash-table-get range-start-ht x)
+                           (send output-text last-position))
+                          (hash-table-get range-ht x (λ () null)))))
+      
+      (define (make-modern text)
+        (send text change-style
+              (make-object style-delta% 'change-family 'modern)
+              0
+              (send text last-position)))
+      
+      (define dummy
+        (begin (pretty-print (syntax-object->datum original-object) output-port)
+               (newline output-port)
+               (parameterize ([current-output-port output-port]
+                              [pretty-print-pre-print-hook range-pretty-print-pre-hook]
+                              [pretty-print-post-print-hook range-pretty-print-post-hook]
+                              [pretty-print-columns 30])
+                 (pretty-print expanded-datum))
+               (make-modern output-text)))
+      
+      (define ranges 
+        (quicksort 
+         (apply append (hash-table-map range-ht (λ (k vs) (map (λ (v) (cons k v)) vs))))
+         (λ (x y)
+           (<= (- (car (cdr x)) (cdr (cdr x)))
+               (- (car (cdr y)) (cdr (cdr y)))))))
+      
+      (define (show-info stx)
+        (fprintf info-port "datum: ~s\nsource: ~a\nposition: ~s\noffset: ~s\noriginal: ~s\nbound-in-source: ~s\n\n"
+                 (syntax-object->datum stx)
+                 (syntax-source stx)
+                 (syntax-position stx)
+                 (syntax-span stx)
+                 (syntax-original? stx)
+                 (syntax-property stx 'bound-in-source))
+        (let loop ([origin (syntax-property stx 'origin)])
+          (cond
+            [(pair? origin)
+             (loop (car origin))
+             (loop (cdr origin))]
+            [(syntax? origin)
+             (display "  " info-port)
+             (display origin info-port)
+             (newline info-port)
+             (fprintf info-port
+                      "  original? ~a\n  datum:\n  ~a\n\n"
+                      (and (syntax? origin) (syntax-original? origin))
+                      (and (syntax? origin) (syntax-object->datum origin)))]
+            [else (void)])))
+      
+      (for-each
+       (λ (range)
+         (let* ([obj (car range)]
+                [stx (hash-table-get stx-ht obj)]
+                [start (cadr range)]
+                [end (cddr range)])
+           (when (syntax? stx)
+             (send output-text set-clickback start end 
+                   (λ _ 
+                     (send info-text begin-edit-sequence)
+                     (send info-text erase)
+                     (show-info stx)
+                     (make-modern info-text)
+                     (send info-text end-edit-sequence))))))
+       ranges)
+      
+      (newline output-port)
+      (newline output-port)
+      (let ([before (send output-text last-position)])
+        (display "all" output-port)
+        (send output-text set-clickback
+              before
+              (send output-text last-position)
+              (λ _
+                (send info-text begin-edit-sequence)
+                (send info-text erase)
+                (for-each (λ (rng)
+                            (let ([stx (hash-table-get stx-ht (car rng))])
+                              (when (syntax? stx)
+                                (show-info stx))))
+                          ranges)
+                (make-modern info-text)
+                (send info-text end-edit-sequence))))
+      
+      (let ()
+        (define f (make-object frame% "Syntax 'origin Browser" #f 600 300))
+        (define p (make-object horizontal-panel% f))
+        (make-object editor-canvas% p output-text)
+        (make-object editor-canvas% p info-text)
+        (send f show #t))]))
+  
+  ;; build-ht : stx -> hash-table
+  ;; the resulting hash-table maps from the each sub-object's to it's syntax.
+  (define (syntax-object->datum/ht stx)
+    (let ([ht (make-hash-table)])
+      (values (let loop ([stx stx])
+                (let ([obj (syntax-e stx)])
+                  (cond
+                    [(list? obj) 
+                     (let ([res (map loop obj)])
+                       (hash-table-put! ht res stx)
+                       res)]
+                    [(pair? obj) 
+                     (let ([res (cons (loop (car obj))
+                                      (loop (cdr obj)))])
+                       (hash-table-put! ht res stx)
+                       res)]
+                    [(vector? obj) 
+                     (let ([res (list->vector (map loop (vector->list obj)))])
+                       (hash-table-put! ht res stx)
+                       res)]
+                    [else 
+                     (let ([res (syntax-object->datum stx)])
+                       (hash-table-put! ht res stx)
+                       res)])))
+              ht)))
+  
+  ;; make-text-port : text -> port
+  ;; builds a port from a text object.  
+  (define (make-text-port text)
+    (let-values ([(in out) (make-pipe)])
+      (thread
+       (λ ()
+         (let loop ()
+           (let ([c (read-char in)])
+             (unless (eof-object? c)
+               (send text insert (string c)
+                     (send text last-position)
+                     (send text last-position))
+               (loop))))))
+      out)))
diff --git a/collects/drscheme/private/teachpack.ss b/collects/drscheme/private/teachpack.ss
new file mode 100644
index 0000000000..f9d606b967
--- /dev/null
+++ b/collects/drscheme/private/teachpack.ss
@@ -0,0 +1,169 @@
+
+(module teachpack mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "list.ss")
+           (lib "file.ss")
+           (lib "etc.ss")
+	   (lib "framework.ss" "framework")
+	   (lib "mred.ss" "mred")
+	   (lib "string-constant.ss" "string-constants")
+           "drsig.ss")
+
+  (provide teachpack@)
+
+  (define o (current-output-port))
+  (define (oprintf . args) (apply fprintf o args))
+  
+  (define teachpack@
+    (unit/sig drscheme:teachpack^
+      (import)
+
+      ;; type teachpack-cache = (make-teachpack-cache (listof cache-entry))
+      ;; the timestamp indicates the last time this teachpack was loaded
+      (define-struct teachpack-cache (tps))
+      
+      ;; type cache-entry = (make-cache-entry path)
+      (define-struct cache-entry (filename))
+      
+      (define (cache-entry-require-spec cache-entry)
+        (cache-entry-filename cache-entry))
+      
+      ;; new-teachpack-cache : -> teachpack-cache
+      (define new-teachpack-cache
+        (opt-lambda ([filenames '[]])
+          (make-teachpack-cache (map make-cache-entry filenames))))
+      
+      ;; set-teachpack-cache-filenames! : teachpack-cache (listof string) -> void
+      ;; this shouldn't remove all of the #fs.
+      (define (set-teachpack-cache-filenames! teachpack-cache filenames)
+        (set-teachpack-cache-tps!
+         teachpack-cache
+         (map (λ (filename) (make-cache-entry filename))
+              filenames)))
+      
+      ;; install-teachpacks : teachpack-cache -> void
+      ;; =User=
+      ;; installs the loaded teachpacks
+      ;; updates the cache, removing those teachpacks that failed to run
+      ;; requires that none of the cache-entries have #fs in them.
+      (define (install-teachpacks cache)
+        (for-each install-teachpack (teachpack-cache-tps cache))
+        (set-teachpack-cache-tps!
+         cache
+         (filter cache-entry-filename (teachpack-cache-tps cache))))
+      
+      ;; install-teachpack : cache-entry -> void
+      ;; =User=
+      ;; updates the cache-entry's filename to #f if the teachpack fails
+      ;; to run properly
+      (define (install-teachpack cache-entry)
+        (let ([filename (cache-entry-filename cache-entry)])
+          (with-handlers ([exn:fail?
+                           (λ (exn)
+                             (set-cache-entry-filename! cache-entry #f)
+                             (show-teachpack-error filename exn))])
+            (verify-no-new-exports filename)
+            (namespace-require (cache-entry-require-spec cache-entry)))))
+
+      ;; verify-no-new-exports : string -> void
+      ;; ensures that the teachpack wouldn't override any thing in the user's namespace
+      (define (verify-no-new-exports filename)
+        (let ([exports (extract-provided-variables-from-module filename)]
+              [ns-contents (namespace-mapped-symbols)]
+              [ht (make-hash-table)])
+          (for-each (λ (ns-sym) (hash-table-put! ht ns-sym #t)) ns-contents)
+          (for-each (λ (expt)
+                      (when (hash-table-get ht expt (λ () #f))
+                        (error 'teachpack "export of ~a from ~s conflicts with already existing definitions"
+                               expt filename)))
+                    exports)))
+      
+      ;; extract-provided-variables-from-module : string -> (listof symbol)
+      (define (extract-provided-variables-from-module filename)
+        (let* ([module-stx 
+                (parameterize ([current-namespace (make-namespace)])
+                  (let-values ([(base name dir?) (split-path filename)])
+                    (parameterize [(current-load-relative-directory base)
+                                   (current-directory base)]
+                      (expand 
+                       (parameterize [(read-case-sensitive #f)
+                                      (read-square-bracket-as-paren #t)
+                                      (read-curly-brace-as-paren #t)
+                                      (read-accept-box #t)
+                                      (read-accept-compiled #t)
+                                      (read-accept-bar-quote #t)
+                                      (read-accept-graph #t)
+                                      (read-decimal-as-inexact #t)
+                                      (read-accept-dot #t)
+                                      (read-accept-quasiquote #t)]
+                         (call-with-input-file filename 
+                           (λ (port) (read-syntax filename port))))))))]
+               [var-prop (get-exported-names (syntax-property module-stx 'module-variable-provides))]
+               [mac-prop (get-exported-names (syntax-property module-stx 'module-syntax-provides))])
+          (append var-prop mac-prop)))
+      
+      ;; get-exported-names : module-variable-provides / module-syntax-provides info (see mz manual) -> (listof symbol)
+      (define (get-exported-names names)
+        (if names
+            (map (λ (x)
+                   (cond
+                     [(symbol? x) x]
+                     [(symbol? (cdr x)) (car x)]
+                     [else (cadr x)]))
+                 names)
+            '()))
+        
+      ;; marshall-teachpack-cache : teachpack-cache -> writable
+      (define (marshall-teachpack-cache cache)
+        (map (λ (x) (path->bytes (cache-entry-filename x))) (teachpack-cache-tps cache)))
+      
+      ;; unmarshall-teachpack-cache : writable -> teachpack-cache
+      (define (unmarshall-teachpack-cache lof)
+        (make-teachpack-cache
+         (if (and (list? lof)
+                  (andmap bytes? lof))
+             (map (λ (x) (make-cache-entry (bytes->path x))) lof)
+             null)))
+      
+      ;; teachpack-cache-filenames : teachpack-cache -> (listof string)
+      (define (teachpack-cache-filenames cache)
+        (map cache-entry-filename (teachpack-cache-tps cache)))
+
+      ;; teachpack-cache-filenames : teachpack-cache -> (listof string)
+      (define (teachpack-cache-require-specs cache)
+        (map (λ (x) (cache-entry-require-spec x))
+             (teachpack-cache-tps cache)))
+      
+      ;; launcher-init-code : teachpack-cache -> sexp
+      ;; constructs code to be put in  a module that loads the teachpacks.
+      ;; used with launchers
+      (define (launcher-init-code cache)
+        `(begin
+           (void)
+           ,@(map (λ (ce)
+                    (let ([req-spec (cache-entry-require-spec ce)])
+                      (if (path? req-spec)
+                          `(namespace-require (bytes->path ,(path->bytes req-spec)))
+                          `(namespace-require ',req-spec))))
+                  (teachpack-cache-tps cache))))
+      
+      ;; launcher-modules-to-embed : teachpack-cache -> (listof module-spec)
+      ;; the modules to embed in a stand-alone executable.
+      (define (launcher-modules-to-embed cache)
+        (map (λ (ce) (cache-entry-require-spec ce))
+             (teachpack-cache-tps cache)))
+
+      ;; show-teachpack-error : string TST -> void
+      ;; shows an error message for a bad teachpack.
+      (define (show-teachpack-error tp-filename exn)
+        (message-box 
+         (string-constant teachpack-error-label)
+         (string-append
+          (format (string-constant teachpack-didnt-load)
+                  tp-filename)
+          (string #\newline)
+          
+          ;; should check for error trace and use that here (somehow)
+          (if (exn? exn)
+              (format "~a" (exn-message exn))
+              (format "uncaught exception: ~s" exn))))))))
diff --git a/collects/drscheme/private/text.ss b/collects/drscheme/private/text.ss
new file mode 100644
index 0000000000..cd8571bd7a
--- /dev/null
+++ b/collects/drscheme/private/text.ss
@@ -0,0 +1,38 @@
+
+(module text mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "class.ss")
+           "drsig.ss"
+           (lib "framework.ss" "framework"))
+  
+  (provide text@)
+  
+  (define text@
+    (unit/sig drscheme:text^
+      (import)
+      (define text<%>
+        (interface (scheme:text<%>)
+          printing-on
+          printing-off
+          is-printing?))
+      
+      (define text%
+        (class* scheme:text% (text<%>)
+          (define printing? #f)
+          (define/public (is-printing?) printing?)
+          (define/public (printing-on) (set! printing? #t))
+          (define/public (printing-off) (set! printing? #f))
+          ;      (rename [super-on-paint on-paint])
+          ;      (inherit get-filename)
+          ;      (override
+          ;	[on-paint
+          ;	 (λ (before? dc left top right bottom dx dy draw-caret)
+          ;	   (super-on-paint before? dc left top right bottom dx dy draw-caret)
+          ;	   (let ([str (string-append
+          ;			(mzlib:date:date->string (seconds->date (current-seconds)))
+          ;			" "
+          ;			(if (string? (get-filename))
+          ;			    (get-filename)
+          ;			    "Untitled"))])
+          ;	      (send dc draw-text str dx dy)))])
+          (super-new))))))
diff --git a/collects/drscheme/private/tool-contract-language.ss b/collects/drscheme/private/tool-contract-language.ss
new file mode 100644
index 0000000000..e36bdf73f7
--- /dev/null
+++ b/collects/drscheme/private/tool-contract-language.ss
@@ -0,0 +1,135 @@
+(module tool-contract-language mzscheme
+  (provide (rename -#%module-begin #%module-begin)
+           (all-from-except mzscheme #%module-begin))
+  
+  (require (lib "contract.ss"))
+  (require-for-syntax (lib "list.ss"))
+
+  (define-syntax (-#%module-begin stx)
+    
+    (define-struct ctc-binding (var arg))
+    (define-struct def-binding (var arg))
+    
+    (define (process-case case-stx)
+      (syntax-case case-stx (define)
+        [(define name expr)
+         (identifier? (syntax name))
+         (make-def-binding (syntax name) (syntax expr))]
+        [(name type type-names strs ...)
+         (and (identifier? (syntax name))
+              (not (string? (syntax-object->datum (syntax type))))
+              (andmap (λ (x) (string? (syntax-object->datum x))) (syntax->list (syntax (strs ...)))))
+         (make-ctc-binding (syntax name) (syntax type))]
+        [else (raise-syntax-error 'tool-contract-language.ss "unknown case" stx case-stx)]))
+              
+    
+    (syntax-case stx ()
+      [(_ cases ...)
+       (let* ([pcases (map process-case (syntax->list (syntax (cases ...))))]
+              [def-cases (filter def-binding? pcases)]
+              [ctc-cases (filter ctc-binding? pcases)])
+         (with-syntax ([(ctc-name ...) (map ctc-binding-var ctc-cases)]
+                       [(ctc ...) (map ctc-binding-arg ctc-cases)]
+                       [(def-name ...) (map def-binding-var def-cases)]
+                       [(def-exp ...) (map def-binding-arg def-cases)]
+                       [wrap-tool-inputs (datum->syntax-object stx 'wrap-tool-inputs #'here)])
+           (syntax/loc stx
+             (#%module-begin
+              (provide wrap-tool-inputs)
+              (define-syntax wrap-tool-inputs
+                (λ (in-stx)
+                  (syntax-case in-stx ()
+                    [(_ body tool-name)
+                     (let ([f (λ (in-obj) 
+                                (datum->syntax-object 
+                                 in-stx
+                                 (syntax-object->datum in-obj)
+                                 in-obj))])
+                       (with-syntax ([(in-type (... ...)) (map f (syntax->list (syntax (ctc ...))))]
+                                     [(in-name (... ...)) (map f (syntax->list (syntax (ctc-name ...))))]
+                                     [(in-def-name (... ...)) (map f (syntax->list (syntax (def-name ...))))]
+                                     [(in-def-exp (... ...)) (map f (syntax->list (syntax (def-exp ...))))])
+                         (syntax/loc in-stx
+                           (let ([in-def-name in-def-exp] (... ...))
+                             (let ([in-name (contract (let ([in-name in-type]) in-name)
+                                                      in-name
+                                                      'drscheme
+                                                      tool-name
+                                                      (quote-syntax in-name))] (... ...))
+                               body)))))])))))))]
+      [(_ (name type type-names strs ...) ...)
+       (begin
+         (for-each
+          (λ (str-stx)
+            (when (string? (syntax-object->datum str-stx))
+              (raise-syntax-error 'tool-contract-language.ss "expected type name specification"
+                                  stx
+                                  str-stx)))
+          (syntax->list (syntax (type-names ...))))
+         (for-each
+          (λ (name)
+            (unless (identifier? name)
+              (raise-syntax-error 'tool-contract-language.ss "expected identifier" stx name)))
+          (syntax->list (syntax (name ...))))
+         (for-each
+          (λ (str)
+            (unless (string? (syntax-object->datum str))
+              (raise-syntax-error 'tool-contract-language.ss "expected docs string" stx str)))
+          (apply append (map syntax->list (syntax->list (syntax ((strs ...) ...)))))))]))
+  
+  (define-syntax (-#%module-begin2 stx)
+    (syntax-case stx ()
+      [(_ (name type type-names strs ...) ...)
+       (and (andmap identifier? (syntax->list (syntax (name ...))))
+            (andmap (λ (x) (not (string? (syntax-object->datum x))))
+                    (syntax->list (syntax (type-names ...))))
+            (andmap (λ (x) (string? (syntax-object->datum x)))
+                    (apply append (map syntax->list (syntax->list (syntax ((strs ...) ...)))))))
+       (with-syntax ([wrap-tool-inputs (datum->syntax-object stx 'wrap-tool-inputs #'here)])
+         (syntax/loc stx
+          (#%module-begin
+           (provide wrap-tool-inputs)
+           (define-syntax wrap-tool-inputs
+             (λ (in-stx)
+               (syntax-case in-stx ()
+                 [(_ body tool-name)
+                  (with-syntax ([(in-type (... ...))
+                                 (map (λ (in-type-obj) 
+                                        (datum->syntax-object 
+                                         in-stx
+                                         (syntax-object->datum in-type-obj)
+                                         in-type-obj))
+                                      (syntax->list (syntax (type ...))))]
+                                [(in-name (... ...))
+                                 (map (λ (in-name-obj) 
+                                        (datum->syntax-object 
+                                         in-stx 
+                                         (syntax-object->datum in-name-obj)
+                                         in-name-obj))
+                                      (syntax->list (syntax (name ...))))])
+                    (syntax/loc in-stx
+                     (let ([in-name (contract (let ([in-name in-type]) in-name)
+                                              in-name
+                                              'drscheme
+                                              tool-name
+                                              (quote-syntax in-name))] (... ...))
+                       body)))]))))))]
+      [(_ (name type type-names strs ...) ...)
+       (begin
+         (for-each
+          (λ (str-stx)
+            (when (string? (syntax-object->datum str-stx))
+              (raise-syntax-error 'tool-contract-language.ss "expected type name specification"
+                                  stx
+                                  str-stx)))
+          (syntax->list (syntax (type-names ...))))
+         (for-each
+          (λ (name)
+            (unless (identifier? name)
+              (raise-syntax-error 'tool-contract-language.ss "expected identifier" stx name)))
+          (syntax->list (syntax (name ...))))
+         (for-each
+          (λ (str)
+            (unless (string? (syntax-object->datum str))
+              (raise-syntax-error 'tool-contract-language.ss "expected docs string" stx str)))
+          (apply append (map syntax->list (syntax->list (syntax ((strs ...) ...)))))))])))
diff --git a/collects/drscheme/private/tool-contracts.ss b/collects/drscheme/private/tool-contracts.ss
new file mode 100644
index 0000000000..72266384f0
--- /dev/null
+++ b/collects/drscheme/private/tool-contracts.ss
@@ -0,0 +1,1339 @@
+
+(module tool-contracts "tool-contract-language.ss"
+
+;                           
+;                           
+;                           
+;                        ;  
+;                        ;  
+;                        ;  
+;    ;;;  ;     ; ;;;    ;  
+;   ;   ;  ;   ; ;   ;   ;  
+;  ;    ;  ;   ;     ;   ;  
+;  ;;;;;;   ; ;   ;;;;   ;  
+;  ;        ; ;  ;   ;   ;  
+;   ;        ;   ;   ;   ;  
+;    ;;;;    ;    ;;;;;  ;  
+;                           
+;                           
+;                           
+  
+  
+  (drscheme:eval:set-basic-parameters
+   ((listof (is-a?/c snip-class%)) . -> . void?)
+   (snipclasses)
+   "sets the parameters that are shared between the repl's"
+   "initialization and \\iscmprocedure{drscheme:eval:build-user-eventspace/custodian}"
+   ""
+   "Specifically, it sets these parameters:"
+   "\\begin{itemize}"
+   "\\item \\rawscm{current-namespace} has been set to a newly"
+   "  created empty namespace. This namespace has the following modules "
+   "  copied (with \\MzLink{mz:namespace-utilities}{\\rawscm{namespace-attach-module}})"
+   "  from DrScheme's original namespace:"
+   "  \\begin{itemize}"
+   "  \\item \\rawscm{'mzscheme}"
+   "  \\item \\rawscm{'(lib \"mred.ss\" \"mred\")}"
+   "  \\end{itemize}"
+   ""
+   "\\item"
+   "  \\MzLink{mz:p:read-curly-brace-as-paren}{\\rawscm{read-curly-brace-as-paren}}"
+   "  is \\rawscm{\\#t},"
+   "\\item"
+   "  \\MzLink{mz:p:read-square-bracket-as-paren}{\\rawscm{read-square-bracket-as-paren}}"
+   "  is \\rawscm{\\#t},"
+   "\\item "
+   "  \\MzLink{mz:p:error-print-width}{\\rawscm{error-print-width}} is set to 250."
+   "\\item"
+   "@flink current-ps-setup"
+   "is set to a newly created"
+   "@link ps-setup"
+   "object."
+   "\\item The \\MzLink{mz:p:exit-handler}{\\rawscm{exit-handler}} is set to"
+   "a parameter that kills the user's custodian."
+   "\\item The snip-class-list, returned by"
+   "@flink get-the-snip-class-list"
+   "is initialized with all of the snipclasses in DrScheme's eventspace's snip-class-list."
+   ""
+   "\\end{itemize}")
+  
+  (drscheme:eval:get-snip-classes
+   (-> (listof (is-a?/c snip-class%)))
+   ()
+   "Returns a list of all of the snipclasses in the current eventspace")
+  
+  (drscheme:eval:expand-program
+   ((union port? drscheme:language:text/pos?)
+    drscheme:language-configuration:language-settings?
+    boolean?
+    (-> void?)
+    (-> void?)
+    ((union eof-object? syntax? (cons/c string? any/c))
+     (-> any)
+     . -> .
+     any)
+    . -> .
+    void?)
+   (input language-settings eval-compile-time-part? init kill-termination iter)
+   
+   "Use this function to expand the contents of the definitions"
+   "window for use with external program processing tools."
+   ""
+   "This function uses"
+   "@flink drscheme:eval:build-user-eventspace/custodian"
+   "to build the user's environment."
+   "The arguments \\var{language-settings}, \\var{init}, and"
+   "\\var{kill-termination} are passed to"
+   "@flink drscheme:eval:build-user-eventspace/custodian %"
+   "."
+   ""
+   "The \\var{input} argument specifies the source of the program."
+   ""
+   "The \\var{eval-compile-time-part?} argument indicates if"
+   "\\Mzhyperref{\rawscm{expand}}{mz:expansion}"
+   "is called or if"
+   "\\scheme|expand-top-level-with-compile-time-evals|"
+   "is called when the program is expanded."
+   "Roughly speaking, if your tool will evaluate each expression"
+   "itself by calling"
+   "\\Mzhyperref{\\rawscm{eval}}{mz:evalload}"
+   "then pass \\scheme{#f}. Otherwise, if your tool"
+   "just processes the expanded program, be sure to pass"
+   "\\scheme{#t}."
+   ""
+   "This function calls"
+   "@ilink drscheme:language:language front-end/complete-program"
+   "to expand the program."
+   ""
+   "The first argument to \\var{iter} is the expanded program"
+   "(represented as syntax) or eof."
+   "The \\var{iter} argument is called for each expression in the"
+   "expanded program and once more with eof, unless an error is"
+   "raised during expansion."
+   "It is called from the user's thread."
+   "If an exception is raised during expansion of the"
+   "user's program, \\var{iter} is not called."
+   "Consider setting the exception-handler during \\var{init} to"
+   "handle this situation."
+   ""
+   "The second argument to \\var{iter} is a thunk that"
+   "continues expanding the rest of the contents of the"
+   "definitions window. If the first argument to \\var{iter} was"
+   "eof, this argument is just the primitive"
+   "\\rawscm{void}."
+   ""
+   "See also"
+   "@flink drscheme:eval:expand-program/multiple %"
+   ".")
+  
+  (drscheme:eval:traverse-program/multiple
+   (drscheme:language-configuration:language-settings?
+    (-> void?)
+    (-> void?)
+    . -> .
+    ((union port? drscheme:language:text/pos?)
+     ((union eof-object? syntax? (cons/c string? any/c))
+      (-> any)
+      . -> .
+      any)
+     boolean?
+     . -> .
+     void?))
+   (language-settings init kill-termination)
+   
+   "This function is similar to"
+   "@flink drscheme:eval:expand-program/multiple"
+   "The only difference is that it does not"
+   "expand the program in the editor; instead"
+   "the processing function can decide how to"
+   "expand the program.")
+  
+  (drscheme:eval:expand-program/multiple
+   (drscheme:language-configuration:language-settings?
+    boolean?
+    (-> void?)
+    (-> void?)
+    . -> .
+    ((union port? drscheme:language:text/pos?)
+     ((union eof-object? syntax? (cons/c string? any/c))
+      (-> any)
+      . -> .
+      any)
+     boolean?
+     . -> .
+     void?))
+   (language-settings eval-compile-time-part? init kill-termination)
+   
+   "This function is just like"
+   "@flink drscheme:eval:expand-program"
+   "except that it is curried and the second application"
+   "can be used multiple times."
+   "Use this function if you want to initialize the user's"
+   "thread (and namespace, etc) once but have program text"
+   "that comes from multiple sources."
+   ""
+   "The extra boolean argument to the result function"
+   "determines if"
+   "@ilink drscheme:language:language front-end/complete-program"
+   "or"
+   "@ilink drscheme:language:language front-end/interaction"
+   "is called.")
+  
+  (drscheme:eval:build-user-eventspace/custodian
+   ((drscheme:language-configuration:language-settings?
+     (-> void?)
+     (-> void?))
+    . ->* .
+    (eventspace? custodian?))
+   (language-settings init kill-termination)
+   
+   "This function creates a custodian and an eventspace (on the"
+   "new custodian) to expand the user's program. It does not"
+   "kill this custodian, but it can safely be shutdown (with"
+   "\\MzLink{mz:custodians}{custodian-shutdown-all}) after the"
+   "expansion is finished."
+   ""
+   "It initializes the"
+   "user's eventspace's main thread with several parameters:"
+   "\\begin{itemize}"
+   "\\item \\rawscm{current-custodian} is set to a new custodian."
+   "\\item"
+   "In addition, it calls"
+   "@flink drscheme:eval:set-basic-parameters %"
+   "."
+   "\\end{itemize}"
+   ""
+   "The \\var{language-settings} argument is the current"
+   "language and its settings. See"
+   "@flink drscheme:language-configuration:make-language-settings"
+   "for details on that structure."
+   ""
+   "If the program is associated with a DrScheme"
+   "frame, get the frame's language settings from the"
+   "@ilink drscheme:unit:definitions-text get-next-settings"
+   "method of "
+   "@ilink drscheme:unit:definitions-text %"
+   ".  Also, the most recently chosen language in"
+   "the language dialog is saved via the framework's"
+   "preferences. Apply"
+   "@flink preferences:get"
+   "to"
+   "@flink drscheme:language-configuration:get-settings-preferences-symbol"
+   "for that \\var{language-settings}."
+   ""
+   "The \\var{init} argument is called after the user's parameters"
+   "are all set, but before the program is run. It is called on"
+   "the user's thread. The"
+   "\\MzLink{mz:p:current-directory}{current-directory} and"
+   "\\MzLink{mz:p:current-load-relative-directory}{current-load-relative-directory}"
+   "parameters are not set, so if there are appropriate directories,"
+   "the \\var{init} argument is a good place to set them."
+   ""
+   "The \\var{kill-termination} argument is called when the main thread of"
+   "the eventspace terminates, no matter if the custodian was"
+   "shutdown, or the thread was killed. This procedure is also"
+   "called when the thread terminates normally. This procedure is"
+   "called from a new, dedicated thread ({\\it i. e.}, not the thread"
+   "created to do the expansion, nor the thread that"
+   "\\rawscm{drscheme:eval:build-user-eventspace/custodian} was called from.)")
+  
+  
+
+;                                         
+;                                         
+;                                         
+;       ;          ;                      
+;       ;          ;                      
+;       ;          ;                      
+;    ;; ;    ;;;   ; ;;    ;   ;    ;; ;  
+;   ;  ;;   ;   ;  ;;  ;   ;   ;   ;  ;;  
+;  ;    ;  ;    ;  ;    ;  ;   ;  ;    ;  
+;  ;    ;  ;;;;;;  ;    ;  ;   ;  ;    ;  
+;  ;    ;  ;       ;    ;  ;   ;  ;    ;  
+;   ;  ;;   ;      ;;  ;   ;  ;;   ;  ;;  
+;    ;; ;    ;;;;  ; ;;     ;; ;    ;; ;  
+;                                      ;  
+;                                 ;    ;  
+;                                  ;;;;   
+  
+  (drscheme:debug:show-error-and-highlight
+   (string? 
+    (union any/c exn?) 
+    (-> (listof srcloc?) (union false/c (listof (list/c (is-a?/c text%) number? number?))) any)
+    . -> . 
+    any)
+   (msg exn highlight-errors)
+   "The first two arguments are the same as the arguments to the error-display-handler. "
+   "This function prints the error message to the current-error-port, like the default error-display-handler "
+   "and also calls \\var{highlight-errors} to do error highlighting. It is be passed the stack trace "
+   "for the error message."
+   ""
+   "This function should be called on the same thread/eventspace where the error happened.")
+  
+  (drscheme:debug:make-debug-error-display-handler
+   ((string? (union any/c exn?) . -> . any)
+    . -> .
+    (string? (union any/c exn?) . -> . any))
+   
+   (oedh)
+   
+   "This function implements an error-display-handler in terms"
+   "of another error-display-handler."
+   ""
+   "This function is designed to work in conjunction with"
+   "@flink drscheme:debug:make-debug-eval-handler %"
+   "."
+   ""
+   "See also MzScheme's"
+   "MzLink{mz:p:error-display-handler}{error-display-handler}"
+   "parameter."
+   ""
+   "If the current-error-port is the definitions window in"
+   "drscheme, this error handler inserts some debugging"
+   "annotations, calls \\var{oedh}, and then highlights the"
+   "source location of the runtime error.")
+  
+  (drscheme:debug:make-debug-eval-handler
+   ((any/c . -> . any/c)
+    . -> .
+    (any/c . -> . any/c))
+   
+   (odeh)
+   
+   "This function implements an eval-handler in terms of another"
+   "eval-handler."
+   ""
+   "This function is designed to work in conjunction with"
+   "@flink drscheme:debug:make-debug-error-display-handler %"
+   "."
+   ""
+   "See also MzScheme's MzLink{mz:p:eval-handler}{eval-handler}"
+   "parameter. "
+   ""
+   "The resulting eval-handler expands and annotates the input"
+   "expression and then passes it to the input eval-handler,"
+   "unless the input expression is already compiled, in which"
+   "case it just hands it directly to the input eval-handler.")
+  
+  (drscheme:debug:hide-backtrace-window
+   (-> void?)
+   ()
+   "Hides the backtrace window.")
+  
+  
+  (drscheme:debug:profiling-enabled
+   (case-> (boolean? . -> . void?)
+           (-> boolean?))
+   ((enabled?) ())
+   "A parameter that controls if profiling information is recorded."
+   ""
+   "Defaults to \\scm{\\#f}."
+   ""
+   "Only applies if"
+   "@flink drscheme:debug:make-debug-eval-handler"
+   "has been added to the eval handler.")
+  
+  (drscheme:debug:add-prefs-panel
+   (-> void?)
+   ()
+   "Adds the profiling preferences panel.")
+  
+  (drscheme:debug:open-and-highlight-in-file
+   (srcloc? . -> . void?)
+   (debug-info)
+   "This function opens a DrScheme to display"
+   "\\var{debug-info}. The first element in"
+   "the cons indicates where the file is"
+   "and the two number indicate a range of"
+   "text to show."
+   ""
+   "See also"
+   "@flink drscheme:debug:get-cm-key %"
+   ".")
+  
+  (drscheme:debug:show-backtrace-window
+   (string?
+    (listof any/c)
+    . -> .
+    void?)
+   (error-message dis)
+   "Shows the backtrace window you get when clicking on the bug in"
+   "DrScheme's REPL."
+   ""
+   "The \\var{error-message} argument is the text of the error,"
+   "\\var{dis} is the debug information, extracted from the"
+   "continuation mark in the exception record, using"
+   "@flink drscheme:debug:get-cm-key %"
+   ".")
+  
+  (drscheme:debug:get-cm-key
+   (-> any)
+   ()
+   "Returns a key used with \\scheme|contination-mark-set->list|."
+   "The contination mark set attached to an exception record"
+   "for the user's program may use this mark. If it does,"
+   "each mark on the continuation is the same type as"
+   "the input to"
+   "@flink drscheme:debug:open-and-highlight-in-file %"
+   ".")
+
+;                           
+;                           
+;                           
+;                   ;       
+;                           
+;                       ;   
+;   ;   ;   ; ;;    ;  ;;;; 
+;   ;   ;   ;;  ;   ;   ;   
+;   ;   ;   ;   ;   ;   ;   
+;   ;   ;   ;   ;   ;   ;   
+;   ;   ;   ;   ;   ;   ;   
+;   ;  ;;   ;   ;   ;   ;   
+;    ;; ;   ;   ;   ;    ;; 
+;                           
+;                           
+;                           
+  
+  
+  (drscheme:unit:get-program-editor-mixin
+   (-> ((subclass?/c text%) . -> . (subclass?/c text%)))
+   ()
+   "Returns a mixin that must be mixed in to any"
+   "\\iscmclass{text} object that might contain"
+   "program text (and thus can be in the source"
+   "field of some syntax object)."
+   ""
+   "See also"
+   "@flink drscheme:unit:add-to-program-editor-mixin %"
+   ".")
+  
+  (drscheme:unit:add-to-program-editor-mixin
+   (((subclass?/c text%) . -> . (subclass?/c text%)) . -> . void?)
+   (mixin)
+   "\\phase{1}"
+   ""
+   "Adds \\var{mixin} to the result of"
+   "@flink drscheme:unit:get-program-editor-mixin %"
+   ".")
+  
+  (drscheme:unit:open-drscheme-window
+   (case->
+    (-> (is-a?/c drscheme:unit:frame%))
+    ((union string? false/c) . -> . (is-a?/c drscheme:unit:frame%)))
+   (() (filename))
+   
+   "Opens a drscheme frame that displays \\var{filename},"
+   "or nothing if \\var{filename} is \\rawscm{\\#f} or not supplied.")
+
+  
+  
+  ;                                            
+  ;                                            
+  ;                                            
+  ;                           ;                
+  ;                           ;                
+  ;                           ;                
+  ;   ; ;;  ;;     ;;;     ;; ;    ;;;    ;;;  
+  ;   ;;  ;;  ;   ;   ;   ;  ;;   ;   ;  ;     
+  ;   ;   ;   ;  ;     ; ;    ;  ;    ;  ;;    
+  ;   ;   ;   ;  ;     ; ;    ;  ;;;;;;   ;;   
+  ;   ;   ;   ;  ;     ; ;    ;  ;          ;  
+  ;   ;   ;   ;   ;   ;   ;  ;;   ;         ;  
+  ;   ;   ;   ;    ;;;     ;; ;    ;;;;  ;;;   
+  ;                                            
+  ;                                            
+  ;                                            
+  
+  
+  (drscheme:modes:add-mode
+   (string?
+    (union false/c (is-a?/c mode:surrogate-text<%>))
+    ((is-a?/c drscheme:rep:text%) number? . -> . boolean?)
+    ((union false/c (listof string?)) . -> . boolean?)
+    . -> .
+    drscheme:modes:mode?)
+   (name surrogate repl-submit matches-language)
+   "Adds a mode to DrScheme. Returns a mode value"
+   "that identifies the mode."
+   ""
+   "The first argument, \\var{name}, is the name"
+   "of the mode, used in DrScheme's GUI to allow"
+   "the user to select this mode."
+   ""
+   "The \\var{surrogate} argument is set to the"
+   "definitions text and the interactions text"
+   "(via the"
+   "@ilink mode:host-text set-surrogate"
+   "method) whenever this mode is enabled."
+   ""
+   "The \\var{repl-submit} procedure is called"
+   "whenever the user types a return in the interactions"
+   "window. It is passed the interactions editor"
+   "and the position where the last prompt occurs."
+   "If it "
+   "returns \\scheme|#t|, the text after the last"
+   "prompt is treated as a program fragment and"
+   "evaluated, according to the language settings."
+   "If it returns \\scheme|#f|, the text is"
+   "assumed to be an incomplete program fragment, and"
+   "the keystroke is not treated specially."
+   ""
+   "The \\var{matches-language} predicate is called whenever"
+   "the language changes. If it returns \\scheme|#t|"
+   "this mode is installed. It is passed the list of strings"
+   "that correspond to the names of the language in the"
+   "language dialog."
+   ""
+   "Modes are tested in the opposite order that they are"
+   "added. That is, the last mode to be added gets tested"
+   "first when the filename changes or when the language"
+   "changes."
+   ""
+   "See also"
+   "@flink drscheme:modes:get-modes %"
+   ".")
+  
+  (drscheme:modes:mode?
+   (any/c . -> . boolean?)
+   (val)
+   "Determines if \\var{val} is a mode.")
+  
+  (drscheme:modes:get-modes
+   (-> (listof drscheme:modes:mode?))
+   ()
+   "Returns all of the modes currently added to DrScheme."
+   ""
+   "See also"
+   "@flink drscheme:modes:add-mode %"
+   ".")
+  
+  (drscheme:modes:mode-name
+   (drscheme:modes:mode? . -> . string?)
+   (mode)
+   "Extracts the name of the mode."
+   ""
+   "See also"
+   "@flink drscheme:modes:add-mode %"
+   ".")
+  
+  (drscheme:modes:mode-surrogate
+   (drscheme:modes:mode? . -> . (union false/c (is-a?/c mode:surrogate-text<%>)))
+   (mode)
+   "Extracts the surrogate of the mode."
+   ""
+   "See also"
+   "@flink drscheme:modes:add-mode %"
+   ".")
+  
+  (drscheme:modes:mode-repl-submit
+   (drscheme:modes:mode? . -> . any)
+   (mode)
+   "Extracts the repl submission predicate of the mode."
+   ""
+   "See also"
+   "@flink drscheme:modes:add-mode %"
+   ".")
+  
+  (drscheme:modes:mode-matches-language
+   (drscheme:modes:mode? . -> . ((union false/c (listof string?)) . -> . boolean?))
+   (mode)
+   "Extracts the language matching predicate of the mode."
+   ""
+   "See also"
+   "@flink drscheme:modes:add-mode %"
+   ".")
+  
+
+;                      
+;                      
+;                      
+;                      
+;                      
+;                      
+;   ; ;   ;;;   ; ;;   
+;   ;;   ;   ;  ;;  ;  
+;   ;   ;    ;  ;    ; 
+;   ;   ;;;;;;  ;    ; 
+;   ;   ;       ;    ; 
+;   ;    ;      ;;  ;  
+;   ;     ;;;;  ; ;;   
+;               ;      
+;               ;      
+;               ;      
+  
+  (drscheme:rep:get-drs-bindings-keymap
+   (-> (is-a?/c keymap%))
+   ()
+   "Returns a keymap that bindings various DrScheme-specific"
+   "keybindings. This keymap is used in the definitions"
+   "and interactions window."
+   ""
+   "Defaultly binds C-x;o to a function that switches"
+   "the focus between the definitions and interactions"
+   "windows. Also binds f5 to Execute and f1 to Help Desk.")
+  
+  (drscheme:rep:current-rep
+   (-> (union false/c (is-a?/c drscheme:rep:text%)))
+   ()
+   
+   "This is a parameter whose value should not be set by tools."
+   "It is initialized to the repl that controls this evaluation"
+   "in the user's thread."
+   ""
+   "It only returns \\scheme|#f| if the program not running"
+   "in the context of a repl (eg, the test suite window).")
+  
+  (drscheme:rep:current-value-port
+   (-> (union false/c port?))
+   ()
+   "This is a parameter whose value is a port that"
+   "prints in the REPL in blue. It is used to print"
+   "the values of toplevel expressions in the REPL."
+   ""
+   "It is only initialized on the user's thread")
+  
+
+;                                                                        
+;                                                                        
+;                                                                        
+;                          ;                                          ;  
+;                          ;                                          ;  
+;                  ;      ;                   ;                       ;  
+;    ;; ;    ;;;  ;;;;    ;     ;;;  ;     ; ;;;;   ;;;   ; ;;     ;; ;  
+;   ;  ;;   ;   ;  ;      ;    ;   ;  ;   ;   ;    ;   ;  ;;  ;   ;  ;;  
+;  ;    ;  ;    ;  ;      ;   ;    ;   ; ;    ;   ;    ;  ;   ;  ;    ;  
+;  ;    ;  ;;;;;;  ;     ;    ;;;;;;    ;     ;   ;;;;;;  ;   ;  ;    ;  
+;  ;    ;  ;       ;     ;    ;        ; ;    ;   ;       ;   ;  ;    ;  
+;   ;  ;;   ;      ;     ;     ;      ;   ;   ;    ;      ;   ;   ;  ;;  
+;    ;; ;    ;;;;   ;;  ;       ;;;; ;     ;   ;;   ;;;;  ;   ;    ;; ;  
+;       ;               ;                                                
+;  ;    ;               ;                                                
+;   ;;;;                                                                 
+  
+  
+  (drscheme:get/extend:extend-tab
+   (case->
+    ((make-mixin-contract drscheme:unit:tab%) . -> . void?)
+    ((make-mixin-contract drscheme:unit:tab%) boolean? . -> . void?))
+   ((mixin) (mixin before?))
+   
+   "This class implements the tabs in drscheme. One is created for each tab"
+   "in a frame (each frame always has at least one tab, even if the tab bar is not shown)"
+   ""
+   "The argument, \\var{before}, controls if the mixin is applied before or"
+   "after already installed mixins."
+   "If unsupplied, this is the same as supplying \\rawscm{\\#t}.")
+  
+  (drscheme:get/extend:extend-interactions-text
+   (case->
+    ((make-mixin-contract drscheme:rep:text<%>) . -> . void?)
+    ((make-mixin-contract drscheme:rep:text<%>) boolean? . -> . void?))
+   ((mixin) (mixin before?))
+   
+   "This text is used in the bottom window of drscheme frames."
+   ""
+   "The argument, \\var{before}, controls if the mixin is applied before or"
+   "after already installed mixins."
+   "If unsupplied, this is the same as supplying \\rawscm{\\#t}.")
+  
+  (drscheme:get/extend:get-interactions-text
+   (-> (implementation?/c drscheme:rep:text<%>))
+   ()
+   
+   "Once this function is called, "
+   "@flink drscheme:get/extend:extend-interactions-text "
+   "raises an error, disallowing any more extensions.")
+  
+  (drscheme:get/extend:extend-definitions-text
+   (case->
+    ((make-mixin-contract drscheme:unit:definitions-text<%>) . -> . void?)
+    ((make-mixin-contract drscheme:unit:definitions-text<%>) boolean? . -> . void?))
+   ((mixin) (mixin before?))
+   
+   "This text is used in the top window of drscheme frames."
+   ""
+   "The argument, \\var{before}, controls if the mixin is applied before or"
+   "after already installed mixins."
+   "If unsupplied, this is the same as supplying \\rawscm{\\#f}.")
+  
+  (drscheme:get/extend:get-definitions-text
+   (-> (implementation?/c drscheme:unit:definitions-text<%>))
+   ()
+   
+   "Once this function is called, "
+   "@flink drscheme:get/extend:extend-definitions-text "
+   "raises an error, disallowing any more extensions.")
+  
+  (drscheme:get/extend:extend-interactions-canvas
+   (case->
+    ((make-mixin-contract drscheme:unit:interactions-canvas%) . -> . void?)
+    ((make-mixin-contract drscheme:unit:interactions-canvas%) boolean? . -> . void?))
+   ((mixin) (mixin before?))
+   
+   "This canvas is used in the bottom window of drscheme frames."
+   ""
+   "The argument, \\var{before}, controls if the mixin is applied before or"
+   "after already installed mixins."
+   "If unsupplied, this is the same as supplying \\rawscm{\\#f}.")
+  
+  (drscheme:get/extend:get-interactions-canvas
+   (-> (subclass?/c drscheme:unit:interactions-canvas%))
+   ()
+   
+   "Once this function is called, "
+   "@flink drscheme:get/extend:extend-interactions-canvas"
+   "raises an error, disallowing any more extensions.")
+  
+  (drscheme:get/extend:extend-definitions-canvas
+   (case->
+    ((make-mixin-contract drscheme:unit:definitions-canvas%) . -> . void?)
+    ((make-mixin-contract drscheme:unit:definitions-canvas%) boolean? . -> . void?))
+   ((mixin) (mixin before?))
+   
+   "This canvas is used in the top window of drscheme frames."
+   
+   "The argument, \\var{before}, controls if the mixin is applied before or"
+   "after already installed mixins."
+   "If unsupplied, this is the same as supplying \\rawscm{\\#f}.")
+  
+  (drscheme:get/extend:get-definitions-canvas
+   (-> (subclass?/c drscheme:unit:definitions-canvas%))
+   ()
+   
+   "Once this function is called, "
+   "@flink drscheme:get/extend:extend-definitions-canvas"
+   "raises an error, disallowing any more extensions.")
+  
+  (drscheme:get/extend:extend-unit-frame
+   (case->
+    ((make-mixin-contract drscheme:unit:frame%) . -> . void?)
+    ((make-mixin-contract drscheme:unit:frame%) boolean? . -> . void?))
+   ((mixin) (mixin before?))
+   
+   "This is the frame that implements the main drscheme window."
+   ""
+   "The argument, \\var{before}, controls if the mixin is applied before or"
+   "after already installed mixins."
+   "If unsupplied, this is the same as supplying \\rawscm{\\#f}.")
+  
+  (drscheme:get/extend:get-unit-frame
+   (-> (subclass?/c drscheme:unit:frame%))
+   ()
+   
+   "Once this function is called, "
+   "@flink drscheme:get/extend:extend-unit-frame"
+   "raises an error, disallowing any more extensions.")
+  
+  
+;                                                           
+;                                                           
+;                                                           
+;   ;                                                       
+;   ;                                                       
+;   ;                                                       
+;   ;   ;;;    ; ;;     ;; ;   ;   ;   ;;;     ;; ;    ;;;  
+;   ;  ;   ;   ;;  ;   ;  ;;   ;   ;  ;   ;   ;  ;;   ;   ; 
+;   ;      ;   ;   ;  ;    ;   ;   ;      ;  ;    ;  ;    ; 
+;   ;   ;;;;   ;   ;  ;    ;   ;   ;   ;;;;  ;    ;  ;;;;;; 
+;   ;  ;   ;   ;   ;  ;    ;   ;   ;  ;   ;  ;    ;  ;      
+;   ;  ;   ;   ;   ;   ;  ;;   ;  ;;  ;   ;   ;  ;;   ;     
+;   ;   ;;;;;  ;   ;    ;; ;    ;; ;   ;;;;;   ;; ;    ;;;; 
+;                          ;                      ;         
+;                     ;    ;                 ;    ;         
+;                      ;;;;                   ;;;;          
+;                                                                                       
+;                                                                                       
+;                                                                                       
+;                           ;;; ;                                    ;                  
+;                          ;                                                            
+;                          ;                                    ;                       
+;    ;;;    ;;;    ; ;;   ;;;;  ;    ;; ;   ;   ;   ; ;  ;;;   ;;;;  ;    ;;;    ; ;;   
+;   ;   ;  ;   ;   ;;  ;   ;    ;   ;  ;;   ;   ;   ;;  ;   ;   ;    ;   ;   ;   ;;  ;  
+;  ;      ;     ;  ;   ;   ;    ;  ;    ;   ;   ;   ;       ;   ;    ;  ;     ;  ;   ;  
+;  ;      ;     ;  ;   ;   ;    ;  ;    ;   ;   ;   ;    ;;;;   ;    ;  ;     ;  ;   ;  
+;  ;      ;     ;  ;   ;   ;    ;  ;    ;   ;   ;   ;   ;   ;   ;    ;  ;     ;  ;   ;  
+;   ;   ;  ;   ;   ;   ;   ;    ;   ;  ;;   ;  ;;   ;   ;   ;   ;    ;   ;   ;   ;   ;  
+;    ;;;    ;;;    ;   ;   ;    ;    ;; ;    ;; ;   ;    ;;;;;   ;;  ;    ;;;    ;   ;  
+;                                       ;                                               
+;                                  ;    ;                                               
+;                                   ;;;;                                                
+
+  (drscheme:language-configuration:add-language
+   ((and/c (is-a?/c drscheme:language:language<%>) language-object)
+    . -> . void?)
+   (language)
+   
+   "\\phase{2}"
+   ""
+   "Adds \\var{language} to the languages offerend by DrScheme.")
+  
+  (drscheme:language-configuration:get-settings-preferences-symbol
+   (-> symbol?)
+   ()
+   "Returns the symbol that is used to store the user's language"
+   "settings. Use as an argument to either"
+   "@flink preferences:get"
+   "or"
+   "@flink preferences:set %"
+   ".")
+  
+  (drscheme:language-configuration:make-language-settings
+   ((union (is-a?/c drscheme:language:language<%>) language-object)
+    any/c
+    . -> .
+    drscheme:language-configuration:language-settings?)
+   (language settings)
+   
+   "This is the constructor for a record consisting of two"
+   "elements, a language and its settings. "
+   ""
+   "The settings is a language-specific record that holds a"
+   "value describing a parameterization of the language."
+   ""
+   "It has two selectors,"
+   "@flink drscheme:language-configuration:language-settings-language"
+   "and "
+   "@flink drscheme:language-configuration:language-settings-settings %"
+   ", and a predicate,"
+   "@flink drscheme:language-configuration:language-settings?")
+  
+  (drscheme:language-configuration:language-settings-settings
+   (drscheme:language-configuration:language-settings?
+    . -> .
+    any/c)
+   (ls)
+   "Extracts the settings field of a language-settings.")
+  
+  (drscheme:language-configuration:language-settings-language
+   (drscheme:language-configuration:language-settings?
+    . -> .
+    (union (is-a?/c drscheme:language:language<%>) language-object))
+   (ls)
+   
+   "Extracts the language field of a language-settings.")
+  
+  (drscheme:language-configuration:language-settings?
+   (any/c . -> . boolean?)
+   (val)
+   
+   "Determines if the argument is a langauge-settings or not.")
+  
+  (drscheme:language-configuration:language-dialog
+   (opt->
+    (boolean? drscheme:language-configuration:language-settings?)
+    ((union false/c (is-a?/c top-level-window<%>))
+     boolean?)
+    drscheme:language-configuration:language-settings?)
+   ((show-welcome? language-settings-to-show)
+    ((parent #t)
+     (manuals? #f)))
+   "Opens the language configuration dialog."
+   "See also"
+   "@flink drscheme:language-configuration:fill-language-dialog %"
+   "."
+   ""
+   "The \\var{show-welcome?} argument determines if"
+   "if a ``Welcome to DrScheme'' message and some"
+   "natural language buttons are shown."
+   ""
+   "The \\var{language-settings-to-show} argument"
+   "must be some default language settings that the dialog"
+   "is initialized to."
+   "If unsure of a default, the currently set language"
+   "in the user's preferences can be obtained via:"
+   "\\begin{schemedisplay}"
+   "(preferences:get (drscheme:language-configuration:get-settings-preferences-symbol))"
+   "\\end{schemedisplay}"
+   ""
+   "The \\var{parent} argument is used as the parent"
+   "to the dialog."
+   ""
+   "The \\var{manuals?} argument is passed to"
+   "@flink drscheme:language-configuration:fill-language-dialog %"
+   ".")
+  
+  (drscheme:language-configuration:fill-language-dialog
+   (opt->
+    ((is-a?/c vertical-panel%)
+     (is-a?/c area-container<%>)
+     drscheme:language-configuration:language-settings?)
+    ((union false/c (is-a?/c top-level-window<%>))
+     boolean?)
+    drscheme:language-configuration:language-settings?)
+   ((panel button-panel language-setting)
+    ((re-center #f)
+     (manuals? #f)))
+   "This procedure accepts two parent panels and"
+   "fills them with the contents of the language dialog."
+   "It is used to include language configuration controls"
+   "in some larger context in another dialog."
+   ""
+   "The \\var{panel} argument is the main panel where the"
+   "language controls will be placed."
+   "The function adds buttons to the \\var{button-panel}"
+   "to revert a language to its default settings and to"
+   "show the details of a language."
+   ""
+   "The \\var{language-setting} is the default"
+   "language to show in the dialog."
+   
+   "The \\var{re-center} argument is used when the \\gui{Show Details}"
+   "button is clicked. If that argument is a \\iscmintf{top-level-window},"
+   "the \\gui{Show Details} callback will recenter the window each time"
+   "it is clicked. Otherwise, the argument is not used."
+   ""
+   "If \\var{manuals?} is \\scheme{#f} the usual language dialog (as seen"
+   "in the start up drscheme window and from the Choose Language dialog"
+   "created when drscheme is started up) is shown. If it isn't, the dialog"
+   "does not have the details and on the right-hand side shows the manual"
+   "ordering for the chosen language. This is used in Help Desk.")
+
+;                                                           
+;                                                           
+;                                                           
+;   ;                                                       
+;   ;                                                       
+;   ;                                                       
+;   ;   ;;;    ; ;;     ;; ;   ;   ;   ;;;     ;; ;    ;;;  
+;   ;  ;   ;   ;;  ;   ;  ;;   ;   ;  ;   ;   ;  ;;   ;   ; 
+;   ;      ;   ;   ;  ;    ;   ;   ;      ;  ;    ;  ;    ; 
+;   ;   ;;;;   ;   ;  ;    ;   ;   ;   ;;;;  ;    ;  ;;;;;; 
+;   ;  ;   ;   ;   ;  ;    ;   ;   ;  ;   ;  ;    ;  ;      
+;   ;  ;   ;   ;   ;   ;  ;;   ;  ;;  ;   ;   ;  ;;   ;     
+;   ;   ;;;;;  ;   ;    ;; ;    ;; ;   ;;;;;   ;; ;    ;;;; 
+;                          ;                      ;         
+;                     ;    ;                 ;    ;         
+;                      ;;;;                   ;;;;          
+  
+  
+  (drscheme:language:add-snip-value
+   (-> (-> any/c boolean?)
+       (-> any/c (is-a?/c snip%))
+       void?)
+   (test-value convert-value)
+   "Registers a handler to convert values into snips as they are printed in the REPL."
+   ""
+   "The \\var{test-snip} argument is called to determine if this handler can convert the value"
+   "and the \\var{convert-value} argument is called to build a snip."
+   "Both functions are called on the user's thread and with the user's settings.")
+  
+  (drscheme:language:extend-language-interface
+   (interface?
+    ((implementation?/c drscheme:language:language<%>) . ->d . (λ (%) (subclass?/c %)))
+    . -> .
+    void?)
+   (interface default-implementation)
+   
+   "\\phase{1}"
+   ""
+   "Each language added passed to"
+   "@flink drscheme:language-configuration:add-language"
+   "must implement \\var{interface}. "
+   ""
+   "The \\var{default-implementation} is a mixin"
+   "that provides a default implementation of "
+   "\\var{interface}. Languages that are unaware of"
+   "the specifics of \\var{extension} use"
+   "\\var{default-implementation} via"
+   "@flink drscheme:language:get-default-mixin %"
+   ".")
+  
+  (drscheme:language:get-default-mixin
+   (-> ((implementation?/c drscheme:language:language<%>) . ->d . (λ (%) (subclass?/c %))))
+   ()
+   
+   "\\phase{2}"
+   ""
+   "The result of this function is the composite of all of the "
+   "\\var{default-implementation} arguments passed"
+   "to"
+   "@flink drscheme:language:extend-language-interface %"
+   ".")
+  
+  (drscheme:language:get-language-extensions
+   (-> (listof interface?))
+   ()
+   "\\phase{2}"
+   ""
+   "Returns a list of the interfaces passed to"
+   "@flink drscheme:language:extend-language-interface %"
+   ".")
+  
+  (drscheme:language:put-executable
+   ((is-a?/c top-level-window<%>) string? boolean? boolean? string? . -> . (union false/c string?))
+   (parent program-filename mred? launcher? title)
+   "Calls the MrEd primitive"
+   "@flink put-file"
+   "with arguments appropriate for creating an executable"
+   "from the file \\var{program-filename}. "
+   ""
+   "The arguments \\var{mred?} and \\var{launcher?} indicate"
+   "what type of executable this should be (and the dialog"
+   "may be slightly different on some platforms, depending"
+   "on these arguments)."
+   ""
+   "The \\var{title} argument is used as the title to the primitive"
+   "@flink put-file"
+   "or"
+   "@flink get-directory"
+   "primitive.")
+  
+  (drscheme:language:create-executable-gui
+   ((union false/c (is-a?/c top-level-window<%>))
+    (union false/c string?)
+    (union (λ (x) (eq? x #t)) (symbols 'launcher 'standalone))
+    (union (λ (x) (eq? x #t)) (symbols 'mzscheme 'mred))
+    . -> .
+    (union false/c
+           (list/c (symbols 'no-show 'launcher 'stand-alone)
+                   (symbols 'no-show 'mred 'mzscheme)
+                   string?)))
+   (parent program-name show-type? show-base?)
+   "Opens a dialog to prompt the user about their choice of executable."
+   "If \\var{show-type?} is \\scm{\\#t}, the user is prompted about"
+   "a choice of executable: stand-alone, or launcher. If \\var{show-base?}"
+   "is \\scm{\\#t}, the user is prompted about a choice of base"
+   "binary: mzscheme or mred."
+   ""
+   "The \\var{program-name} argument is used to construct the default"
+   "executable name in a platform-specific manner."
+   ""
+   "The \\var{parent} argument is used for the parent of the dialog."
+   ""
+   "The result of this function is \\scm{\\#f} if the user cancel's"
+   "the dialog and a list of three items indicating what options"
+   "they chose. If either \\var{show-type?} or \\var{show-base?}"
+   "was \\scm{\\#f}, the corresponding result will be \\scm{'no-show},"
+   "otherwise it will indicate the user's choice.")
+  
+  (drscheme:language:create-module-based-stand-alone-executable 
+   (string? string? any/c any/c any/c boolean? boolean?
+            . -> .
+            void?)
+   (program-filename
+    executable-filename
+    module-language-spec
+    transformer-module-language-spec
+    init-code
+    gui?
+    use-copy?)
+   
+   "This procedure creates a stand-alone executable in the file"
+   "\\var{executable-filename} that runs the program"
+   "\\var{program-filename}. "
+   ""
+   "The arguments"
+   "\\var{module-language-spec} and"
+   "\\var{transformer-module-language-spec} specify the "
+   "settings of the initial namespace, both the transformer"
+   "portion and the regular portion. "
+   ""
+   "The \\var{init-code} argument is an s-expression representing"
+   "the code for a module. This module is expected to provide"
+   "the identifer \\rawscm{init-code}, bound to a procedure of no"
+   "arguments. That module is required and the \\scm{init-code}"
+   "procedure is executed to initialize language-specific"
+   "settings before the code in \\var{program-filename} runs."
+   ""
+   "The \\var{gui?} argument indicates if a MrEd or MzScheme"
+   "stand-alone executable is created."
+   ""
+   "The \\var{use-copy?} argument indicates if the initial"
+   "namespace should be populated with"
+   "\\rawscm{namespace-require/copy} or"
+   "\\rawscm{namespace-require}. ")
+  
+  (drscheme:language:create-module-based-launcher
+   (string? string? any/c any/c any/c boolean? boolean?
+            . -> .
+            void?)
+   (program-filename
+    executable-filename
+    module-language-spec
+    transformer-module-language-spec
+    init-code
+    gui?
+    use-copy?)
+   
+   "This procedure is identical to "
+   "@flink drscheme:language:create-module-based-stand-alone-executable %"
+   ", except that it creates a launcher instead of a"
+   "stand-alone executable.")
+  
+  (drscheme:language:text/pos-text
+   (drscheme:language:text/pos? . -> . (is-a?/c text%))
+   (text/pos)
+   
+   "Selects the \\iscmclass{text} from a text/pos.")
+  
+  (drscheme:language:text/pos-start
+   (drscheme:language:text/pos? . -> . number?)
+   (text/pos)
+   
+   "Selects the starting position from a text/pos.")
+  
+  (drscheme:language:text/pos-end
+   (drscheme:language:text/pos? . -> . number?)
+   (text/pos)
+   
+   "Selects the ending position from a text/pos.")
+  
+  (drscheme:language:text/pos?
+   (any/c . -> . boolean?)
+   (val)
+   
+   "Returns \\rawscm{\\#t} if \\var{val} is a text/pos, and \\rawscm{\\#f}"
+   "otherwise.")
+  
+  (drscheme:language:make-text/pos
+   ((is-a?/c text%) number? number?
+    . -> .
+    drscheme:language:text/pos?)
+   (text start end)
+   
+   "Constructs a text/pos.")
+  
+  (drscheme:language:simple-settings-case-sensitive 
+   (drscheme:language:simple-settings? . -> . boolean?)
+   (simple-settings)
+   
+   "Extracts the case-sensitive setting from a simple-settings.")
+  
+  (drscheme:language:simple-settings-printing-style
+   (drscheme:language:simple-settings?
+    . -> .
+    (symbols 'constructor 'quasiquote 'write 'current-print))
+   (simple-settings)
+   
+   "Extracts the printing-style setting from a simple-settings.")
+  
+  (drscheme:language:simple-settings-fraction-style
+   (drscheme:language:simple-settings?
+    . -> .
+    (symbols 'mixed-fraction
+             'mixed-fraction-e
+             'repeating-decimal
+             'repeating-decimal-e))
+   (simple-settings)
+   
+   "Extracts the fraction-style setting from a simple-settings.")
+  
+  (drscheme:language:simple-settings-show-sharing
+   (drscheme:language:simple-settings?
+    . -> .
+    boolean?)
+   (simple-settings)
+   
+   "Extracts the show-sharing setting from a simple-settings.")
+  
+  (drscheme:language:simple-settings-insert-newlines
+   (drscheme:language:simple-settings?
+    . -> .
+    boolean?)
+   (simple-settings)
+   
+   "Extracts the insert-newline setting from a simple-settings.")
+  
+  (drscheme:language:simple-settings-annotations
+   (drscheme:language:simple-settings?
+    . -> .
+    (symbols 'none 'debug 'debug/profile 'test-coverage))
+   (simple-settings)
+   
+   "Extracts the debugging setting from a simple-settings.")
+  
+  (drscheme:language:simple-settings?
+   (any/c . -> . boolean?)
+   (val)
+   
+   "Determines if \\var{val} is a simple-settings.")
+  
+  (drscheme:language:make-simple-settings
+   (boolean?
+    (symbols 'constructor 'quasiquote 'write 'current-print)
+    (symbols 'mixed-fraction 'mixed-fraction-e 'repeating-decimal 'repeating-decimal-e)
+    boolean?
+    boolean?
+    (symbols 'none 'debug 'debug/profile 'test-coverage)
+    . -> .
+    drscheme:language:simple-settings?)
+   (case-sensitive
+    printing-style
+    fraction-style
+    show-sharing
+    insert-newlines
+    debugging)
+   
+   "Constructs a simple settings.")
+  
+  (drscheme:language:simple-settings->vector
+   (drscheme:language:simple-settings? . -> . vector?)
+   (simple-settings)
+   
+   "Constructs a vector whose first index is the symbol"
+   "\\rawscm{'struct:simple-settings}"
+   "and the other elements are the fields of \\var{simple-settings}.")
+  
+  
+  ;                                                                   
+  ;                                                                   
+  ;                                                                   
+  ;   ;              ;                       ;                 ;      
+  ;   ;              ;                       ;                 ;      
+  ;   ;              ;                       ;                 ;      
+  ;   ; ;;     ;;;   ;   ; ;;             ;; ;    ;;;    ;;;   ;   ;  
+  ;   ;;  ;   ;   ;  ;   ;;  ;           ;  ;;   ;   ;  ;      ;  ;   
+  ;   ;   ;  ;    ;  ;   ;    ;         ;    ;  ;    ;  ;;     ; ;    
+  ;   ;   ;  ;;;;;;  ;   ;    ;  ;;;;;; ;    ;  ;;;;;;   ;;    ;;;    
+  ;   ;   ;  ;       ;   ;    ;         ;    ;  ;          ;   ;  ;   
+  ;   ;   ;   ;      ;   ;;  ;           ;  ;;   ;         ;   ;   ;  
+  ;   ;   ;    ;;;;  ;   ; ;;             ;; ;    ;;;;  ;;;    ;    ; 
+  ;                      ;                                            
+  ;                      ;                                            
+  ;                      ;                                            
+  
+  (drscheme:help-desk:open-url
+   (string? . -> . void?)
+   (url)
+   
+   "Opens \\var{url} in a new help desk window.")
+  
+  (drscheme:help-desk:help-desk
+   (case->
+    (-> void?)
+    (string? boolean? (symbols 'keyword 'keyword+index 'all) (symbols 'exact 'contains 'regexp)
+             . -> .
+             void?)
+    (string? boolean? (symbols 'keyword 'keyword+index 'all) . -> . void?)
+    (string? boolean? . -> . void?))
+   (()
+    (key lucky? type mode)
+    (key lucky? type)
+    (key lucky?))
+   
+   "This function opens a help desk window, or brings an already open help"
+   "desk window to the front. If an argument is specified, that key is"
+   "searched for."
+   ""
+   "If no arguments are supplied, this function"
+   "opens a help-desk window to the starting page, or just brings a"
+   "help-desk window to the front (without changing what page it is"
+   "viewing)."
+   ""
+   "If any arguments are supplied, this function"
+   "opens a help-desk window and searches for \\var{key}, according to "
+   "\\var{lucky?}, \\var{type}, and \\var{mode}."
+   "If the second, third, fourth, and/or fifth arguments are omitted, "
+   "they default to \rawscm{\\#t} \\rawscm{'keyword+index} and \\rawscm{'exact},"
+   "and \\rawscm{'all} respectively.")
+  
+  ;                                                                  
+  ;                                                                  
+  ;                                                                  
+  ;                             ;                             ;      
+  ;                             ;                             ;      
+  ;   ;                         ;                             ;      
+  ;  ;;;;   ;;;   ;;;     ;;;   ; ;;    ; ;;    ;;;     ;;;   ;   ;  
+  ;   ;    ;   ; ;   ;   ;   ;  ;;  ;   ;;  ;  ;   ;   ;   ;  ;  ;   
+  ;   ;   ;    ;     ;  ;       ;   ;   ;    ;     ;  ;       ; ;    
+  ;   ;   ;;;;;;  ;;;;  ;       ;   ;   ;    ;  ;;;;  ;       ;;;    
+  ;   ;   ;      ;   ;  ;       ;   ;   ;    ; ;   ;  ;       ;  ;   
+  ;   ;    ;     ;   ;   ;   ;  ;   ;   ;;  ;  ;   ;   ;   ;  ;   ;  
+  ;    ;;   ;;;;  ;;;;;   ;;;   ;   ;   ; ;;    ;;;;;   ;;;   ;    ; 
+  ;                                     ;                            
+  ;                                     ;                            
+  ;                                     ;                            
+  
+  (drscheme:teachpack:install-teachpacks
+   (drscheme:teachpack:teachpack-cache? . -> . void?)
+   (teachpack-cache)
+   "Installs the teachpack cache in the current namespace."
+   "Passing \\scheme{'drscheme:teachpacks} to"
+   "@flink preferences:get"
+   "returns the user's currently selected TeachPacks.")
+  
+  (drscheme:teachpack:teachpack-cache?
+   (any/c . -> . boolean?)
+   (val)
+   "Determines if \\var{val} is a teachpack"
+   "cache or not.")
+  
+  (drscheme:teachpack:teachpack-cache-filenames
+   (drscheme:teachpack:teachpack-cache? . -> . (listof path?))
+   (teachpack-cache)
+   "Returns the list of filenames for the teachpacks"
+   "in \\var{teachpack-cache}."
+   ""
+   "See also"
+   "@flink drscheme:teachpack:install-teachpacks %"
+   ".")
+  
+  
+  ;                                                     
+  ;                                                     
+  ;                                                     
+  ;   ;                                      ;       ;  
+  ;   ;                                      ;          
+  ;   ;                                      ;          
+  ;   ;   ;;;    ; ;;     ;; ;        ;;;    ; ;;    ;  
+  ;   ;  ;   ;   ;;  ;   ;  ;;       ;   ;   ;;  ;   ;  
+  ;   ;      ;   ;   ;  ;    ;      ;     ;  ;    ;  ;  
+  ;   ;   ;;;;   ;   ;  ;    ;      ;     ;  ;    ;  ;  
+  ;   ;  ;   ;   ;   ;  ;    ;      ;     ;  ;    ;  ;  
+  ;   ;  ;   ;   ;   ;   ;  ;;       ;   ;   ;;  ;   ;  
+  ;   ;   ;;;;;  ;   ;    ;; ;        ;;;    ; ;;    ;  
+  ;                          ;                       ;  
+  ;                     ;    ;                       ;  
+  ;                      ;;;;                      ;;   
+  
+  
+  (define language-object
+    
+    (object-contract
+     (config-panel ((is-a?/c area-container<%>)
+                    . -> .
+                    (case-> (any/c . -> . void?) (-> any/c))))
+     (create-executable (any/c
+                         (union (is-a?/c dialog%) (is-a?/c frame%))
+                         string?
+                         drscheme:teachpack:teachpack-cache?
+                         . -> .
+                         void?))
+     (default-settings (-> any/c))
+     (default-settings? (any/c . -> . boolean?))
+     (order-manuals ((listof bytes?) . -> . (values (listof bytes?) boolean?)))
+     (front-end/complete-program (input-port?
+                                  any/c
+                                  drscheme:teachpack:teachpack-cache?
+                                  . -> .
+                                  (-> any/c)))
+     (front-end/interaction (input-port?
+                             any/c
+                             drscheme:teachpack:teachpack-cache?
+                             . -> .
+                             (-> any/c)))
+     (get-language-name (-> string?))
+     (get-language-numbers (-> (cons/c number? (listof number?))))
+     (get-language-position (-> (cons/c string? (listof string?))))
+     (get-language-url (-> (union false/c string?)))
+     (get-one-line-summary (-> string?))
+     (get-comment-character (-> (values string? char?)))
+     (get-style-delta (-> (union false/c
+                                 (is-a?/c style-delta%)
+                                 (listof (list/c (is-a?/c style-delta%) number? number?)))))
+     (marshall-settings (any/c . -> . printable/c))
+     (on-execute (any/c ((-> any) . -> . any) . -> . any))
+     (render-value (any/c 
+                    any/c
+                    output-port?
+                    . -> .
+                    void?))
+     (render-value/format (any/c 
+                           any/c
+                           output-port?
+                           number?
+                           . -> .
+                           any))
+     (unmarshall-settings (printable/c . -> . any)))
+    #;
+    (is-a?/c drscheme:language:language<%>)))
diff --git a/collects/drscheme/private/tools.ss b/collects/drscheme/private/tools.ss
new file mode 100644
index 0000000000..5e9c7a78b9
--- /dev/null
+++ b/collects/drscheme/private/tools.ss
@@ -0,0 +1,368 @@
+
+(module tools mzscheme
+  (require (lib "unitsig.ss")
+           (lib "getinfo.ss" "setup")
+           (lib "mred.ss" "mred")
+           (lib "class.ss")
+           (lib "list.ss")
+           "drsig.ss"
+           (lib "contract.ss")
+           "tool-contracts.ss"
+           (lib "framework.ss" "framework")
+           (lib "string-constant.ss" "string-constants"))
+  
+  (provide tools@)  
+
+  (define tools@
+    (unit/sig drscheme:tools^
+      (import [drscheme:frame : drscheme:frame^]
+              [drscheme:unit : drscheme:unit^]
+              [drscheme:rep : drscheme:rep^]
+              [drscheme:get/extend : drscheme:get/extend^]
+              [drscheme:language : drscheme:language^]
+              [drscheme:language-configuration : drscheme:language-configuration^]
+	      [drscheme:help-desk : drscheme:help-desk^]
+              [drscheme:init : drscheme:init^]
+	      [drscheme:debug : drscheme:debug^]
+              [drscheme:eval : drscheme:eval^]
+              [drscheme:teachpack : drscheme:teachpack^]
+              [drscheme:modes : drscheme:modes^])
+      
+      ;; successful-tool = (make-successful-tool module-spec 
+      ;;                                         (union #f (instanceof bitmap%))
+      ;;                                         (union #f string)
+      ;;                                         (union #f string))
+      (define-struct successful-tool (spec bitmap name url))
+      
+      ;; successful-tools : (listof successful-tool)
+      (define successful-tools null)
+
+      ;; get-successful-tools : -> (listof successful-tool)
+      (define (get-successful-tools) successful-tools)
+
+      ;; successfully-loaded-tool = 
+      ;; (make-successfully-loaded-tool 
+      ;;    module-spec (union #f (instanceof bitmap%)) (union #f string) (union #f string)
+      ;;    (-> void) (-> void))
+      (define-struct successfully-loaded-tool (spec bitmap name url phase1 phase2))
+                     
+      ;; successfully-loaded-tools : (listof successfully-loaded-tool)
+      ;; this list contains the tools that successfully were loaded
+      ;; it is updated in load/invoke-tool. 
+      (define successfully-loaded-tools null)
+
+      ;; load/invoke-all-tools : -> void
+      (define (load/invoke-all-tools phase1-extras phase2-extras)
+        (set! current-phase 'loading-tools)
+        (load/invoke-all-tools/collections
+         (all-tool-directories)
+         phase1-extras
+         phase2-extras))
+
+
+      (define (all-tool-directories)
+        (find-relevant-directories '(tools tool-icons tool-names tool-urls)))
+      
+      ;; loads the the tools in each directory
+      ;; unless PLTNOTOOLS is set, in which case it
+      ;; just runs the phases. If PLTONLYTOOL is set,
+      ;; it only loads tools in those collections
+      (define (load/invoke-all-tools/collections directories phase1-extras phase2-extras)
+        (cond
+          [(getenv "PLTNOTOOLS") (printf "PLTNOTOOLS: skipping tools\n")]
+          [else
+           (let ([onlys (getenv "PLTONLYTOOL")])
+             (if onlys
+                 (let* ([allowed (let ([exp (read (open-input-string onlys))])
+                                   (cond 
+                                     [(symbol? exp) (list exp)]
+                                     [(pair? exp) exp]
+                                     [else '()]))]
+                        [filtered (filter (lambda (x) 
+                                            (let-values ([(base name dir) (split-path x)])
+                                              (memq (string->symbol (path->string name))
+                                                    allowed)))
+                                          directories)])
+                   (printf "PLTONLYTOOL: only loading ~s\n" filtered)
+                   (for-each load/invoke-tools filtered))
+                 (for-each load/invoke-tools directories)))])
+        (run-phases phase1-extras phase2-extras))
+
+      
+                                                                             
+ ;;;                     ;;       ;   ;                        ;;            
+   ;                      ;      ;                              ;            
+   ;                      ;      ;                              ;            
+   ;     ;;;   ;;;;    ;;;;     ;   ;;;   ; ;;;  ;;; ;;;  ;;;   ;  ;;   ;;;  
+   ;    ;   ;      ;  ;   ;     ;     ;    ;;  ;  ;   ;  ;   ;  ; ;    ;   ; 
+   ;    ;   ;   ;;;;  ;   ;    ;      ;    ;   ;  ;   ;  ;   ;  ;;     ;;;;; 
+   ;    ;   ;  ;   ;  ;   ;    ;      ;    ;   ;   ; ;   ;   ;  ; ;    ;     
+   ;    ;   ;  ;   ;  ;   ;   ;       ;    ;   ;   ;;;   ;   ;  ;  ;   ;   ; 
+ ;;;;;;  ;;;    ;;; ;  ;;; ;  ;     ;;;;; ;;;  ;;   ;     ;;;  ;;   ;;  ;;;  
+                             ;                                               
+                                                                             
+                                                                             
+
+      
+      ;; load/invoke-tools : string[collection-name] -> void
+      ;; loads each tool in a collection
+      (define (load/invoke-tools coll-dir)
+        (let ([table (with-handlers ([(lambda (x) #f) ; exn:fail? 
+                                      (lambda (x)
+                                        (show-error
+                                         (format (string-constant error-getting-info-tool)
+                                                 coll-dir)
+                                         x)
+                                        #f)])
+                       (get-info/full coll-dir))])
+          (when table
+            (let* ([tools (table 'tools (lambda () null))]
+                   [tool-icons (table 'tool-icons (lambda () (map (lambda (x) #f) tools)))]
+                   [tool-names (table 'tool-names (lambda () (map (lambda (x) #f) tools)))]
+                   [tool-urls (table 'tool-urls (lambda () (map (lambda (x) #f) tools)))])
+              (unless (= (length tools) (length tool-icons))
+                (message-box (string-constant drscheme)
+                             (format (string-constant tool-tool-icons-same-length)
+                                     coll-dir tools tool-icons)
+                             #f
+                             '(ok stop))
+                (set! tool-icons (map (lambda (x) #f) tools)))
+              (unless (= (length tools) (length tool-names))
+                (message-box (string-constant drscheme)
+                             (format (string-constant tool-tool-names-same-length)
+                                     coll-dir tools tool-names)
+                             #f
+                             '(ok stop))
+                (set! tool-names (map (lambda (x) #f) tools)))
+              (unless (= (length tools) (length tool-urls))
+                (message-box (string-constant drscheme)
+                             (format (string-constant tool-tool-urls-same-length)
+                                     coll-dir tools tool-urls)
+                             #f
+                             '(ok stop))
+                (set! tool-urls (map (lambda (x) #f) tools)))
+              (for-each (load/invoke-tool coll-dir) tools tool-icons tool-names tool-urls)))))
+      
+      ;; load/invoke-tool :    path[directory-of-collection] 
+      ;;                    -> (listof string[sub-collection-name]) 
+      ;;                       (union #f (cons string[filename] (listof string[collection-name])))
+      ;;                       (union #f string)
+      ;;                       (union #f string)
+      ;;                    -> void
+      ;; `coll' is a collection to load the tool from
+      ;; `in-path' is the `coll'-relative collection-path spec for the tool module file
+      ;; `icon-spec' is the collection-path spec for the tool's icon, if there is one.
+      ;; `name' is the name of the tool (only used in about box)
+      (define (load/invoke-tool coll-dir)
+        (lambda (in-path icon-spec name tool-url)
+          (let* ([icon-path 
+                  (cond
+                    [(string? icon-spec)
+                     (build-path coll-dir icon-spec)]
+                    [(and (list? icon-spec)
+                          (andmap string? icon-spec))
+                     (build-path (apply collection-path (cdr icon-spec)) (car icon-spec))]
+                    [else #f])]
+                 [tool-bitmap
+                  (and icon-path
+                       (install-tool-bitmap name icon-path))])
+            (let/ec k
+              (unless (or (string? in-path)
+                          (and (list? in-path)
+                               (not (null? in-path))
+                               (andmap string? in-path)))
+                (message-box (string-constant drscheme)
+                             (format (string-constant invalid-tool-spec)
+                                     coll-dir in-path)
+                             #f
+                             '(ok stop))
+                (k (void)))
+              (let* ([tool-path
+                      (if (string? in-path) 
+                          (build-path coll-dir in-path)
+                          (apply build-path coll-dir (append (cdr in-path) (list (car in-path)))))]
+                     [unit 
+                       (with-handlers ([exn:fail? 
+                                        (lambda (x)
+                                          (show-error
+                                           (format (string-constant error-invoking-tool-title)
+                                                   coll-dir in-path)
+                                           x)
+                                          (k (void)))])
+                         (dynamic-require tool-path 'tool@))])
+                (with-handlers ([exn:fail? 
+                                 (lambda (x)
+                                   (show-error 
+                                    (format (string-constant error-invoking-tool-title)
+                                            coll-dir in-path)
+                                    x))])
+                  (let-values ([(phase1-thunk phase2-thunk) 
+                                (invoke-tool unit (string->symbol (or name (path->string coll-dir))))])
+                    (set! successfully-loaded-tools 
+                          (cons (make-successfully-loaded-tool
+                                 tool-path
+                                 tool-bitmap
+                                 name
+                                 tool-url 
+                                 phase1-thunk
+                                 phase2-thunk)
+                                successfully-loaded-tools)))))))))
+
+      ;; invoke-tool : unit/sig string -> (values (-> void) (-> void))
+      ;; invokes the tools and returns the two phase thunks.
+      (define (invoke-tool unit tool-name)
+	(wrap-tool-inputs 
+         (let ()
+           (define-values/invoke-unit/sig drscheme:tool-exports^ unit #f drscheme:tool^)
+           (values phase1 phase2))
+         tool-name))
+
+      ;; show-error : string (union exn TST) -> void
+      (define (show-error title x)
+        (parameterize ([drscheme:init:error-display-handler-message-box-title
+                        title])
+          ((error-display-handler)
+           (if (exn? x)
+               (format "~a" (exn-message x))
+               (format "uncaught exception: ~s" x))
+           x)))
+
+
+      ;; install-tool-bitmap : string path -> bitmap
+      ;; adds the tool's bitmap to the splash screen
+      (define (install-tool-bitmap name bitmap-path)
+        (let/ec k
+          (let ([bitmap
+                 (with-handlers ([exn:fail:filesystem? (lambda (x) (k (void)))])
+                   (make-object bitmap% bitmap-path 'unknown/mask))])
+            (unless (and (is-a? bitmap bitmap%)
+                         (send bitmap ok?))
+              (k #f))
+            (let ([splash-eventspace ((dynamic-require '(lib "splash.ss" "framework") 'get-splash-eventspace))]
+                  [splash-bitmap ((dynamic-require '(lib "splash.ss" "framework") 'get-splash-bitmap))]
+                  [splash-canvas ((dynamic-require '(lib "splash.ss" "framework") 'get-splash-canvas))])
+              
+              (unless (and (eventspace? splash-eventspace)
+                           (is-a? splash-bitmap bitmap%)
+                           (send splash-bitmap ok?)
+                           (is-a? splash-canvas canvas%))
+                (k (void)))
+              
+                (parameterize ([current-eventspace splash-eventspace])
+                  (queue-callback
+                   (lambda ()
+                     (let ([bdc (make-object bitmap-dc%)]
+                           [translated-tool-bitmap-y (max 0 (- (send splash-bitmap get-height) tool-bitmap-y tool-bitmap-size))])
+                       
+                       ;; truncate/expand the bitmap, if necessary
+                       (unless (and (= tool-bitmap-size (send bitmap get-width))
+                                    (= tool-bitmap-size (send bitmap get-height)))
+                         (let ([new-b (make-object bitmap% tool-bitmap-size tool-bitmap-size #f)])
+                           (send bdc set-bitmap new-b)
+                           (send bdc clear)
+                           (send bdc draw-bitmap-section splash-bitmap 
+                                 0 0 
+                                 tool-bitmap-x translated-tool-bitmap-y
+                                 tool-bitmap-size tool-bitmap-size)
+                           (send bdc draw-bitmap bitmap 
+                                 (max 0 (- (/ tool-bitmap-size 2)
+                                           (/ (send bitmap get-width) 2)))
+                                 (max 0 (- (/ tool-bitmap-size 2)
+                                           (/ (send bitmap get-height) 2)))
+				 'solid
+				 (make-object color% "black")
+				 (send bitmap get-loaded-mask))
+                           (send bdc set-bitmap #f)
+                           (set! bitmap new-b)))
+                       
+                       ((dynamic-require '(lib "splash.ss" "framework") 'add-splash-icon)
+                        bitmap tool-bitmap-x translated-tool-bitmap-y)
+                       (set! tool-bitmap-x (+ tool-bitmap-x tool-bitmap-size tool-bitmap-gap))
+                       (when ((+ tool-bitmap-x tool-bitmap-gap tool-bitmap-size) . > . (send splash-bitmap get-width))
+                         (set! tool-bitmap-y (+ tool-bitmap-y tool-bitmap-size tool-bitmap-gap))
+                         (set! tool-bitmap-x tool-bitmap-gap))
+                       (when ((+ tool-bitmap-y tool-bitmap-gap tool-bitmap-size) . > . (send splash-bitmap get-width))
+                         (set! tool-bitmap-y tool-bitmap-gap)))))))
+            bitmap)))
+      
+      (define tool-bitmap-gap 3)
+      (define tool-bitmap-x tool-bitmap-gap)
+      (define tool-bitmap-y tool-bitmap-gap)
+      (define tool-bitmap-size 32)
+
+      
+                                                                      
+       ;;                             ;                          ;;;  
+        ;                           ;;;            ;;;          ;   ; 
+        ;                             ;           ;  ;          ;   ; 
+; ;;;   ; ;;   ;;;;    ;;;    ;;;     ;           ;             ;   ; 
+ ;   ;  ;;  ;      ;  ;   ;  ;   ;    ;            ;   ;           ;  
+ ;   ;  ;   ;   ;;;;   ;;;   ;;;;;    ;           ;;; ;           ;   
+ ;   ;  ;   ;  ;   ;      ;  ;        ;          ;   ;           ;    
+ ;   ;  ;   ;  ;   ;  ;   ;  ;   ;    ;          ;   ;;         ;   ; 
+ ;;;;  ;;; ;;;  ;;; ;  ;;;    ;;;   ;;;;;         ;;;  ;        ;;;;; 
+ ;                                                                    
+ ;                                                                    
+;;;                                                                   
+
+
+      ;; run-phases : -> void
+      (define (run-phases phase1-extras phase2-extras)
+        (let* ([after-phase1 (run-one-phase 'phase1
+                                            (string-constant tool-error-phase1)
+                                            successfully-loaded-tool-phase1
+                                            successfully-loaded-tools
+                                            phase1-extras)]
+               [after-phase2 (run-one-phase 'phase2
+                                            (string-constant tool-error-phase2)
+                                            successfully-loaded-tool-phase2
+                                            after-phase1
+                                            phase2-extras)])
+          (set! current-phase 'init-complete)
+          (set! successful-tools
+                (map (lambda (x) (make-successful-tool
+                                  (successfully-loaded-tool-spec x)
+                                  (successfully-loaded-tool-bitmap x)
+                                  (successfully-loaded-tool-name x)
+                                  (successfully-loaded-tool-url x)))
+                     after-phase2))))
+      
+      ;; run-one-phase : string 
+      ;;                 (successfully-loaded-tool -> (-> void))
+      ;;                 (listof successfully-loaded-tool)
+      ;;                 (-> void)
+      ;;              -> (listof successfully-loaded-tool)
+      ;; filters out the tools that raise exceptions during the phase.
+      ;; extras is the thunk for DrScheme init stuff on this phase.
+      (define (run-one-phase _the-phase err-fmt selector tools extras)
+        (set! current-phase _the-phase)
+        (extras)
+        (let loop ([tools tools])
+          (cond
+            [(null? tools) null]
+            [else 
+             (let ([tool (car tools)])
+               (let ([phase-thunk (selector tool)])
+                 (with-handlers ([exn:fail?
+                                  (lambda (exn) 
+                                    (show-error
+                                     (format err-fmt 
+                                             (successfully-loaded-tool-spec tool)
+                                             (successfully-loaded-tool-name tool))
+                                     exn)
+                                    (loop (cdr tools)))])
+                   (phase-thunk)
+                   (cons tool (loop (cdr tools))))))])))
+      
+      ;; current-phase : (union #f 'loading-tools 'phase1 'phase2 'init-complete)
+      (define current-phase #f)
+      (define (get-current-phase) current-phase)
+      
+      ;; only-in-phase : sym (union #f 'loading-tools 'phase1 'phase2 'init-complete) ... -> void
+      ;; raises an error unless one of `phases' is the current phase
+      (define (only-in-phase func . phases)
+        (unless (memq current-phase phases)
+          (error func "can only be called in phase: ~a"
+                 (apply string-append 
+                        (map (lambda (x) (format "~e " x))
+                             (filter (lambda (x) x) phases)))))))))
diff --git a/collects/drscheme/private/unit.ss b/collects/drscheme/private/unit.ss
new file mode 100644
index 0000000000..0bac236046
--- /dev/null
+++ b/collects/drscheme/private/unit.ss
@@ -0,0 +1,2983 @@
+#|
+
+closing:
+  warning messages don't have frame as parent.....
+
+tab panels new behavior:
+  - save all tabs (pr 6689?)
+
+tab panels todo:
+  - changing tabs needs to update all kinds of things, based on new context<%> interface setup
+  - need to update running when switching tabs ...
+  
+module browser threading seems wrong.
+
+|#
+
+(module unit mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "class.ss")
+           (lib "file.ss")
+           (lib "etc.ss")
+           (lib "list.ss")
+           (lib "string-constant.ss" "string-constants")
+	   (lib "framework.ss" "framework")
+           (lib "name-message.ss" "mrlib")
+           (lib "bitmap-label.ss" "mrlib")
+           
+           "drsig.ss"
+           
+           (prefix drscheme:arrow: "../arrow.ss")
+           
+           (lib "mred.ss" "mred")
+           (prefix mred: (lib "mred.ss" "mred"))
+
+           (prefix mzlib:file: (lib "file.ss"))
+           (prefix mzlib:date: (lib "date.ss")))
+
+  (provide unit@)
+  
+  (define module-browser-progress-constant (string-constant module-browser-progress))
+  (define status-compiling-definitions (string-constant module-browser-compiling-defns))
+  (define show-lib-paths (string-constant module-browser-show-lib-paths/short))
+  (define refresh (string-constant module-browser-refresh))
+  
+  (define unit@
+    (unit/sig drscheme:unit^
+      (import [help-desk : drscheme:help-desk^]
+              [drscheme:app : drscheme:app^]
+              [drscheme:frame : drscheme:frame^]
+              [drscheme:text : drscheme:text^]
+              [drscheme:rep : drscheme:rep^]
+              [drscheme:language-configuration : drscheme:language-configuration/internal^]
+              [drscheme:language : drscheme:language^]
+              [drscheme:get/extend : drscheme:get/extend^]
+              [drscheme:teachpack : drscheme:teachpack^]
+              [drscheme:module-overview : drscheme:module-overview^]
+              [drscheme:tools : drscheme:tools^]
+              [drscheme:eval : drscheme:eval^]
+              [drscheme:init : drscheme:init^]
+              [drscheme:module-language : drscheme:module-language^]
+              [drscheme:modes : drscheme:modes^])
+      
+      (rename [-frame% frame%]
+              [-frame<%> frame<%>])
+    
+      (define-local-member-name
+        get-visible-defs
+        set-visible-defs
+        get-i
+        set-i)
+      (define tab<%>
+        (interface (drscheme:rep:context<%>)
+          get-frame
+          get-defs
+          get-ints
+          get-visible-defs
+          set-visible-defs
+          set-visible-ints
+          get-i
+          set-i
+          break-callback
+          is-current-tab?
+          get-enabled
+          on-close
+          can-close?))
+
+      (define definitions-text<%> 
+        (interface ()
+          get-tab
+          change-mode-to-match))
+      
+      (keymap:add-to-right-button-menu
+       (let ([old (keymap:add-to-right-button-menu)])
+         (λ (menu text event)
+           (old menu text event)
+           (when (and (is-a? text text%)
+                      (or (is-a? text (get-definitions-text%))
+                          (is-a? text drscheme:rep:text%))
+                      (is-a? event mouse-event%))
+             (let* ([end (send text get-end-position)]
+                    [start (send text get-start-position)])
+               (unless (= 0 (send text last-position))
+                 (let ([str (if (= end start)
+                                (find-symbol
+                                 text
+                                 (call-with-values
+                                  (λ ()
+                                    (send text dc-location-to-editor-location
+                                          (send event get-x)
+                                          (send event get-y)))
+                                  (λ (x y)
+                                    (send text find-position x y))))
+                                (send text get-text start end))]
+                       [language
+                        (let ([canvas (send text get-canvas)])
+                          (and canvas
+                               (let ([tlw (send canvas get-top-level-window)])
+                                 (and (is-a? tlw -frame<%>)
+                                      (send (send tlw get-definitions-text)
+                                            get-next-settings)))))])
+                   (unless (string=? str "")
+                     (make-object separator-menu-item% menu)
+                     (make-object menu-item%
+                       (format (string-constant search-help-desk-for) 
+                               (shorten-str 
+                                str 
+                                (- 200 (string-length (string-constant search-help-desk-for)))))
+                       menu
+                       (λ x (help-desk:help-desk str #f 'keyword+index 'contains language)))
+                     (make-object menu-item%
+                       (format (string-constant exact-lucky-search-help-desk-for) 
+                               (shorten-str 
+                                str 
+                                (- 200 (string-length (string-constant exact-lucky-search-help-desk-for)))))
+                       menu
+                       (λ x (help-desk:help-desk str #t 'keyword+index 'exact language)))
+		     (void)))))))))
+      
+      ;; find-symbol : number -> string
+      ;; finds the symbol around the position `pos' (approx)
+      (define (find-symbol text pos)
+        (let* ([before
+                (let loop ([i (- pos 1)]
+                           [chars null])
+                  (if (< i 0)
+                      chars
+                      (let ([char (send text get-character i)])
+                        (if (non-letter? char)
+                            chars
+                            (loop (- i 1)
+                                  (cons char chars))))))]
+               [after
+                (let loop ([i pos])
+                  (if (< i (send text last-position))
+                      (let ([char (send text get-character i)])
+                        (if (non-letter? char)
+                            null
+                            (cons char (loop (+ i 1)))))
+                      null))])
+          (apply string (append before after))))
+      
+      ;; non-letter? : char -> boolean
+      ;; returns #t if the character belongs in a symbol (approx) and #f it is
+      ;; a divider between symbols (approx)
+      (define (non-letter? x)
+        (or (char-whitespace? x)
+            (memq x '(#\` #\' #\, #\; #\"
+                       #\{ #\( #\[ #\] #\) #\}))))      
+      (define (shorten-str str len)
+        (if ((string-length str) . <= . len)
+            str
+            (substring str 0 len)))
+      
+
+      ;                                                                                              
+      ;                                                                                              
+      ;                                                                                              
+      ;    ;;;                         ;                           ;   ;          ;                  
+      ;   ;                                                        ;              ;                  
+      ;   ;                       ;                                ;              ;                  
+      ;  ;;;;  ; ;  ;;;     ;;;  ;;;;  ;    ;;;    ; ;;         ;; ;   ;   ;;;    ;    ;;;     ;; ;  
+      ;   ;    ;;  ;   ;   ;   ;  ;    ;   ;   ;   ;;  ;       ;  ;;   ;  ;   ;   ;   ;   ;   ;  ;;  
+      ;   ;    ;       ;  ;       ;    ;  ;     ;  ;   ;      ;    ;   ;      ;   ;  ;     ; ;    ;  
+      ;   ;    ;    ;;;;  ;       ;    ;  ;     ;  ;   ;      ;    ;   ;   ;;;;   ;  ;     ; ;    ;  
+      ;   ;    ;   ;   ;  ;       ;    ;  ;     ;  ;   ;      ;    ;   ;  ;   ;   ;  ;     ; ;    ;  
+      ;   ;    ;   ;   ;   ;   ;  ;    ;   ;   ;   ;   ;       ;  ;;   ;  ;   ;   ;   ;   ;   ;  ;;  
+      ;   ;    ;    ;;;;;   ;;;    ;;  ;    ;;;    ;   ;        ;; ;   ;   ;;;;;  ;    ;;;     ;; ;  
+      ;                                                                                           ;  
+      ;                                                                                      ;    ;  
+      ;                                                                                       ;;;;   
+      
+      (define (get-fraction-from-user parent)
+        (let* ([dlg (make-object dialog% (string-constant enter-fraction))]
+               [hp (make-object horizontal-panel% dlg)]
+               [_1 (make-object message% (string-constant whole-part) hp)]
+               [whole (make-object text-field% #f hp void)]
+               [vp (make-object vertical-panel% hp)]
+               [hp2 (make-object horizontal-panel% vp)]
+               [num (make-object text-field% #f hp2 void)]
+               [num-m (make-object message% (string-constant numerator) hp2)]
+               [hp3 (make-object horizontal-panel% vp)]
+               [den (make-object text-field% #f hp3 void)]
+               [den-m (make-object message% (string-constant denominator) hp3)]
+               [bp (make-object horizontal-panel% dlg)]
+               [ok? #f]
+               [validate-number
+                (λ ()
+                  (let ([num-s (string->number (send num get-value))]
+                        [den-s (string->number (send den get-value))]
+                        [whole-s (if (string=? (send whole get-value) "")
+                                     0
+                                     (string->number (send whole get-value)))])
+                    (if (and num-s den-s whole-s)
+                        (let ([ans (+ whole-s (/ num-s den-s))])
+                          (if (and (exact? ans)
+                                   (real? ans)
+                                   (not (integer? ans)))
+                              ans
+                              #f))
+                        #f)))]
+               [ok-callback
+                (λ () 
+                  (cond
+                    [(validate-number)
+                     (set! ok? #t)
+                     (send dlg show #f)]
+                    [else 
+                     (message-box
+                      (string-constant drscheme)
+                      (string-constant invalid-number)
+                      dlg)]))]
+               [cancel-callback 
+                (λ () (send dlg show #f))])
+          (let-values ([(ok cancel) 
+                        (gui-utils:ok/cancel-buttons
+                         bp
+                         (λ (x y) (ok-callback))
+                         (λ (x y) (cancel-callback)))])
+            (let ([mw (max (send den-m get-width) (send num-m get-width))])
+              (send den-m min-width mw)
+              (send num-m min-width mw))
+            (send bp set-alignment 'right 'center)
+            (send dlg show #t)
+            (and ok? (validate-number)))))
+      
+      (define (basename fn)
+        (if fn
+            (let* ([file-name (mzlib:file:file-name-from-path fn)]
+                   [ext (mzlib:file:filename-extension file-name)])
+              (if ext
+                  (substring file-name 0 (- (string-length file-name)
+                                            (string-length ext)
+                                            1))
+                  file-name))
+            #f))
+      
+      ;; create-executable : (instanceof drscheme:unit:frame<%>) -> void
+      (define (create-executable frame)
+        (let* ([definitions-text (send frame get-definitions-text)]
+               [program-filename (send definitions-text get-filename)])
+          (cond
+            [(not program-filename)
+             (message-box (string-constant create-executable-title)
+                          (string-constant must-save-before-executable)
+                          frame)]
+            [else
+             (when (or (not (send definitions-text is-modified?))
+                       (gui-utils:get-choice
+                        (string-constant definitions-not-saved)
+                        (string-constant yes)
+                        (string-constant no)
+                        (string-constant drscheme)
+                        #f
+                        frame))
+               (let ([settings (send definitions-text get-next-settings)])
+                 (send (drscheme:language-configuration:language-settings-language settings)
+                       create-executable
+                       (drscheme:language-configuration:language-settings-settings settings)
+                       frame
+                       program-filename
+                       (send (send frame get-interactions-text) get-user-teachpack-cache))))])))
+      
+      (define make-execute-bitmap 
+        (bitmap-label-maker (string-constant execute-button-label) 
+                            (build-path (collection-path "icons") "run.png")))
+      (define make-save-bitmap 
+        (bitmap-label-maker (string-constant save-button-label) 
+                            (build-path (collection-path "icons") "save.png")))
+      (define make-break-bitmap 
+        (bitmap-label-maker (string-constant break-button-label) 
+                            (build-path (collection-path "icons") "break.png")))
+      
+      (define-values (get-program-editor-mixin add-to-program-editor-mixin)
+        (let* ([program-editor-mixin
+                (mixin (editor:basic<%> (class->interface text%)) () 
+                  (init-rest args) 
+                  (inherit get-top-level-window) 
+                  
+                  (define/private (reset-highlighting) 
+                    (let ([f (get-top-level-window)]) 
+                      (when (and f 
+                                 (is-a? f -frame<%>)) 
+                        (let ([interactions-text (send f get-interactions-text)]) 
+                          (when (object? interactions-text) 
+                            (send interactions-text reset-highlighting)))))) 
+                  
+                  (define/augment (after-insert x y) 
+                    (reset-highlighting) 
+                    (inner (void) after-insert x y)) 
+                  
+                  (define/augment (after-delete x y) 
+                    (reset-highlighting) 
+                    (inner (void) after-delete x y)) 
+                  
+                  (apply super-make-object args))]
+               [get-program-editor-mixin
+                (λ ()
+                  (drscheme:tools:only-in-phase 'drscheme:unit:get-program-editor-mixin 'phase2 'init-complete)
+                  program-editor-mixin)]
+               [add-to-program-editor-mixin
+                (λ (mixin)
+                  (drscheme:tools:only-in-phase 'drscheme:unit:add-to-program-editor-mixin 'phase1)
+                  (set! program-editor-mixin (compose mixin program-editor-mixin)))])
+          (values get-program-editor-mixin
+                  add-to-program-editor-mixin)))
+      
+      
+      ;; this sends a message to it's frame when it gets the focus
+      (define make-searchable-canvas%
+        (λ (%)
+          (class %
+            (inherit get-top-level-window)
+            (define/override (on-focus on?)
+              (when on?
+                (send (get-top-level-window) make-searchable this))
+              (super on-focus on?))
+            (super-new))))
+      
+      (define interactions-canvas% 
+        (class (make-searchable-canvas%
+                (canvas:info-mixin
+                 (canvas:wide-snip-mixin
+                  (canvas:info-mixin
+                   canvas:color%))))
+          (init [style '()])
+          (super-new (style (cons 'auto-hscroll style)))))
+
+      
+      (define definitions-canvas%
+        (class (make-searchable-canvas% (canvas:delegate-mixin (canvas:info-mixin canvas:color%)))
+          (init [style '()])
+          (super-new (style (cons 'auto-hscroll style)))))
+      
+;                                                                                                  
+;                                                                                                  
+;                                                                                                  
+;       ;           ;;;            ;        ;                                                      
+;       ;          ;    ;                                                                          
+;       ;          ;                   ;                                   ;                   ;   
+;    ;; ;    ;;;  ;;;;;;;  ; ;;    ;  ;;;;  ;    ;;;    ; ;;     ;;;      ;;;;   ;;;  ;     ; ;;;; 
+;   ;  ;;   ;   ;  ;    ;  ;;  ;   ;   ;    ;   ;   ;   ;;  ;   ;          ;    ;   ;  ;   ;   ;   
+;  ;    ;  ;    ;  ;    ;  ;   ;   ;   ;    ;  ;     ;  ;   ;   ;;         ;   ;    ;   ; ;    ;   
+;  ;    ;  ;;;;;;  ;    ;  ;   ;   ;   ;    ;  ;     ;  ;   ;    ;;        ;   ;;;;;;    ;     ;   
+;  ;    ;  ;       ;    ;  ;   ;   ;   ;    ;  ;     ;  ;   ;      ;       ;   ;        ; ;    ;   
+;   ;  ;;   ;      ;    ;  ;   ;   ;   ;    ;   ;   ;   ;   ;      ;       ;    ;      ;   ;   ;   
+;    ;; ;    ;;;;  ;    ;  ;   ;   ;    ;;  ;    ;;;    ;   ;   ;;;         ;;   ;;;; ;     ;   ;; 
+;                                                                                                  
+;                                                                                                  
+;                                                                                                  
+
+
+      (define get-definitions-text%
+        (let ([definitions-text% #f])
+          (λ ()
+            (drscheme:tools:only-in-phase 'phase2 'init-complete)
+            (unless definitions-text%
+              (set! definitions-text% (make-definitions-text%)))
+            definitions-text%)))
+      
+      (define (make-definitions-text%)
+        (let ([definitions-super%
+               ((get-program-editor-mixin)
+                (drscheme:module-language:module-language-put-file-mixin
+                 (scheme:text-mixin
+                  (color:text-mixin
+                   (drscheme:rep:drs-bindings-keymap-mixin
+                    (mode:host-text-mixin
+                     (text:delegate-mixin
+                      (text:nbsp->space-mixin
+                       (text:foreground-color-mixin
+                        text:info%)))))))))])
+          (class* definitions-super% (definitions-text<%>)
+            (inherit get-top-level-window)
+            
+            (define interactions-text #f)
+            (define/public (set-interactions-text it)
+              (set! interactions-text it))
+              
+            (define tab #f)
+            (define/public (get-tab) tab)
+            (define/public (set-tab t) (set! tab t))
+            
+            (inherit get-surrogate set-surrogate)
+            (define/public (set-current-mode mode)
+              (let ([surrogate (drscheme:modes:mode-surrogate mode)])
+                (set-surrogate surrogate)
+                (when interactions-text
+                  (send interactions-text set-surrogate surrogate)
+                  (send interactions-text set-submit-predicate
+                        (drscheme:modes:mode-repl-submit mode)))))
+
+            (define/public (is-current-mode? mode)
+              (let ([surrogate (drscheme:modes:mode-surrogate mode)])
+                (eq? surrogate (get-surrogate))))
+            
+            (define/public (change-mode-to-match)
+              (let* ([language-settings (get-next-settings)]
+                     [language-name (and language-settings
+                                         (send (drscheme:language-configuration:language-settings-language
+                                                language-settings)
+                                               get-language-position))])
+                (let loop ([modes (drscheme:modes:get-modes)])
+                  (cond
+                    [(null? modes) (error 'change-mode-to-match-filename
+                                          "didn't find a matching mode")]
+                    [else (let ([mode (car modes)])
+                            (if ((drscheme:modes:mode-matches-language mode) language-name)
+                                (unless (is-current-mode? mode)
+                                  (set-current-mode mode))
+                                (loop (cdr modes))))]))))
+            
+            (define/augment (after-save-file success?)
+              (when success?
+                (let ([filename (get-filename)])
+                  (when filename
+                    ;; if a filesystem error happens, just give up
+                    ;; on setting the file creator and type.
+                    (with-handlers ([exn:fail:filesystem? void])
+                      (let-values ([(creator type) (file-creator-and-type filename)])
+                        (file-creator-and-type filename #"DrSc" type))))))
+              (inner (void) after-save-file success?))
+              
+            (inherit is-modified? run-after-edit-sequence)
+            (define/override (set-modified mod?)
+              (super set-modified mod?)
+              (run-after-edit-sequence
+               (λ ()
+                 (let ([f (get-top-level-window)])
+                   (when (and f
+                              (is-a? f -frame<%>))
+                     (send f update-save-button))))))
+            (define/override set-filename
+              (case-lambda
+                [(fn) (set-filename fn #f)]
+                [(fn tmp?)
+                 (super set-filename fn tmp?)
+                 (let ([f (get-top-level-window)])
+                   (when (and f
+                              (is-a? f -frame<%>))
+                     (send f update-save-message)))]))
+            
+            (field
+             [needs-execution-state #f]
+             [already-warned-state #f]
+             [execute-settings (preferences:get drscheme:language-configuration:settings-preferences-symbol)]
+             [next-settings execute-settings])
+            
+            (define/pubment (get-next-settings) next-settings)
+            (define/pubment (set-next-settings _next-settings)
+              (set! next-settings _next-settings)
+              (change-mode-to-match))
+            
+            (define/public (needs-execution?)
+              (or needs-execution-state
+                  (not (equal? execute-settings next-settings))))
+            
+            (define/pubment (teachpack-changed)
+              (set! needs-execution-state #t))
+            (define/pubment (just-executed)
+              (set! execute-settings next-settings)
+              (set! needs-execution-state #f)
+              (set! already-warned-state #f))
+            (define/pubment (already-warned?)
+              already-warned-state)
+            (define/pubment (already-warned)
+              (set! already-warned-state #t))
+            (define/augment (after-insert x y)
+              (set! needs-execution-state #t)
+              (inner (void) after-insert x y))
+            (define/augment (after-delete x y)
+              (set! needs-execution-state #t)
+              (inner (void) after-delete x y))
+            
+            (inherit get-filename)
+            (field
+             [tmp-date-string #f])
+            
+            (inherit get-filename/untitled-name)
+            (define/private (get-date-string)
+              (string-append
+               (mzlib:date:date->string (seconds->date (current-seconds)))
+               " "
+               (get-filename/untitled-name)))
+            
+            (define/override (on-paint before dc left top right bottom dx dy draw-caret)
+              (when (and before
+                         (or (is-a? dc post-script-dc%)
+                             (is-a? dc printer-dc%)))
+                (set! tmp-date-string (get-date-string))
+                (let-values ([(w h d s) (send dc get-text-extent tmp-date-string)])
+                  (send (current-ps-setup) set-editor-margin 0 (inexact->exact (ceiling h)))))
+              (super on-paint before dc left top right bottom dx dy draw-caret)
+              (when (and (not before)
+                         (or (is-a? dc post-script-dc%)
+                             (is-a? dc printer-dc%)))
+                (send dc draw-text (get-date-string) 0 0)
+                (void))
+              
+              ;; draw the arrows
+              (when before
+                (when error-arrows
+                  (let ([old-pen (send dc get-pen)])
+                    (send dc set-pen (send the-pen-list find-or-create-pen "red" 1 'solid))
+                    (let loop ([pts error-arrows])
+                      (cond
+                        [(null? pts) (void)]
+                        [(null? (cdr pts)) (void)]
+                        [else (let ([pt1 (car pts)]
+                                    [pt2 (cadr pts)])
+                                (draw-arrow dc dx dy pt1 pt2)
+                                (loop (cdr pts)))]))
+                    (send dc set-pen old-pen)))))
+            
+            (define/private (draw-arrow dc dx dy pt1 pt2)
+              (let-values ([(x1 y1) (find-poss (car pt1) (cadr pt1) (+ (cadr pt1) 1))]
+                           [(x2 y2) (find-poss (car pt2) (cadr pt2) (+ (cadr pt2) 1))])
+                (drscheme:arrow:draw-arrow dc x1 y1 x2 y2 dx dy)))
+            
+            (inherit dc-location-to-editor-location)
+            (define/private (find-poss text left-pos right-pos)
+              (let ([xlb (box 0)]
+                    [ylb (box 0)]
+                    [xrb (box 0)]
+                    [yrb (box 0)])
+                (send text position-location left-pos xlb ylb #t)
+                (send text position-location right-pos xrb yrb #f)
+                (let*-values ([(xl-off yl-off) (send text editor-location-to-dc-location (unbox xlb) (unbox ylb))]
+                              [(xl yl) (dc-location-to-editor-location xl-off yl-off)]
+                              [(xr-off yr-off) (send text editor-location-to-dc-location (unbox xrb) (unbox yrb))]
+                              [(xr yr) (dc-location-to-editor-location xr-off yr-off)])
+                  (values (/ (+ xl xr) 2)
+                          (/ (+ yl yr) 2)))))
+
+            (inherit invalidate-bitmap-cache)
+            (define/public (set-error-arrows arrows)
+              (set! error-arrows arrows)
+              (invalidate-bitmap-cache))
+            
+            (field [error-arrows #f])
+            
+            (super-new))))
+      
+      
+                                                       
+   ;      ;           ;; ;                             
+  ;       ;          ;                                 
+  ;       ;          ;                                 
+ ;    ;;; ;   ;;;   ;;;  ;   ; ;;;    ;;;              
+ ;   ;   ;;  ;   ;   ;   ;   ;;   ;  ;   ;             
+ ;   ;    ;  ;   ;   ;   ;   ;    ;  ;   ;             
+ ;   ;    ;  ;;;;;   ;   ;   ;    ;  ;;;;;             
+ ;   ;    ;  ;       ;   ;   ;    ;  ;                 
+ ;   ;   ;;  ;       ;   ;   ;    ;  ;                 
+  ;   ;;; ;   ;;;;   ;   ;   ;    ;   ;;;;  ;   ;   ;  
+  ;                                                    
+   ;                                                   
+                                                       
+
+      
+      ;; get-pos : text mouse-event% -> (union #f number)
+      (define (get-pos text event)
+        (let*-values ([(event-x event-y)
+                       (values (send event get-x)
+                               (send event get-y))]
+                      [(x y) (send text dc-location-to-editor-location
+                                   event-x 
+                                   event-y)])
+          (let* ([on-it? (box #f)]
+                 [pos (send text find-position x y #f on-it?)])
+            (and (unbox on-it?)
+                 pos))))                                                 
+      
+      (let ([old (keymap:add-to-right-button-menu)])
+        (keymap:add-to-right-button-menu
+         (λ (menu editor event)
+           (when (is-a? editor text%)
+             (let* ([current-pos (get-pos editor event)]
+                    [current-word (and current-pos (get-current-word editor current-pos))]
+                    [defn (and current-word
+                               (ormap (λ (defn) (and (string=? current-word (defn-name defn))
+                                                          defn))
+                                      (get-definitions #f editor)))])
+               (when defn
+                 (new separator-menu-item% (parent menu))
+                 (new menu-item%
+                   (parent menu)
+                   (label (format (string-constant jump-to-defn) (defn-name defn)))
+                   (callback (λ (x y)
+                               (send editor set-position (defn-start-pos defn))))))))
+           (old menu editor event))))
+
+      ;; get-current-word : editor number -> string
+      ;; returns the string that is being clicked on
+      (define (get-current-word editor pos)
+        (let* ([search
+                (λ (dir offset)
+                  (let loop ([pos pos])
+                    (cond
+                      [(or (= pos 0) 
+                           (= pos (send editor last-position)))
+                       pos]
+                      [(memq (send editor get-character pos) '(#\space #\return #\newline #\( #\) #\[ #\] #\tab))
+                       (offset pos)]
+                      [else (loop (dir pos))])))]
+               [before (search sub1 add1)]
+               [after (search add1 (λ (x) x))])
+          (send editor get-text before after)))
+        
+      (define func-defs-canvas%
+        (class name-message%
+	  (init-field frame)
+	  
+          (unless (is-a? frame -frame<%>)
+            (error 'func-defs-canvas "frame is not a drscheme:unit:frame<%>"))
+          
+          (define sort-by-name? #f)
+          (define sorting-name (string-constant sort-by-name))
+          (define/private (change-sorting-order)
+            (set! sort-by-name? (not sort-by-name?))
+            (set! sorting-name (if sort-by-name?
+                                   (string-constant sort-by-position) 
+                                   (string-constant sort-by-name))))
+          
+          (define/override (fill-popup menu reset)
+	    (let* ([text (send frame get-definitions-text)]
+                   [unsorted-defns (get-definitions (not sort-by-name?) text)]
+                   [defns (if sort-by-name?
+                              (quicksort 
+                               unsorted-defns
+                               (λ (x y) (string-ci<=? (defn-name x) (defn-name y))))
+                              unsorted-defns)])
+              (make-object menu:can-restore-menu-item% sorting-name
+                menu
+                (λ (x y)
+                  (change-sorting-order)))
+              (make-object separator-menu-item% menu)
+              (if (null? defns)
+                  (send (make-object menu:can-restore-menu-item%
+                          (string-constant no-definitions-found)
+                          menu
+                          void)
+                        enable #f)
+                  (let loop ([defns defns])
+                    (unless (null? defns)
+                      (let* ([defn (car defns)]
+                             [checked? 
+                              (let ([t-start (send text get-start-position)]
+                                    [t-end (send text get-end-position)]
+                                    [d-start (defn-start-pos defn)]
+                                    [d-end (defn-end-pos defn)])
+                                (or (<= t-start d-start t-end)
+                                    (<= t-start d-end t-end)
+                                    (<= d-start t-start t-end d-end)))]
+                             [item
+                              (make-object (if checked?
+                                               menu:can-restore-checkable-menu-item%
+                                               menu:can-restore-menu-item%)
+                                (gui-utils:trim-string (defn-name defn) 200)
+                                menu
+                                (λ (x y)
+                                  (reset)
+                                  (send text set-position (defn-start-pos defn) (defn-start-pos defn))
+                                  (let ([canvas (send text get-canvas)])
+                                    (when canvas
+                                      (send canvas focus)))))])
+                        (when checked?
+                          (send item check #t))
+                        (loop (cdr defns))))))))
+          
+          (super-new (label "(define ...)"))))
+
+      ;; defn = (make-defn number string number number)
+      (define-struct defn (indent name start-pos end-pos))
+      (define tag-string "(define")
+
+      ;; get-definitions : boolean text -> (listof defn)
+      (define (get-definitions indent? text)
+        (let* ([min-indent 0]
+               [defs (let loop ([pos 0])
+                       (let ([defn-pos (send text find-string tag-string 'forward pos 'eof #t #f)])
+                         (cond
+                           [(not defn-pos) null]
+                           [(in-semicolon-comment? text defn-pos)
+                            (loop (+ defn-pos (string-length tag-string)))]
+                           [else
+                            (let ([indent (get-defn-indent text defn-pos)]
+                                  [name (get-defn-name text (+ defn-pos (string-length tag-string)))])
+                              (set! min-indent (min indent min-indent))
+                              (cons (make-defn indent name defn-pos defn-pos)
+                                    (loop (+ defn-pos (string-length tag-string)))))])))])
+          
+          ;; update end-pos's based on the start pos of the next defn
+          (unless (null? defs)
+            (let loop ([first (car defs)]
+                       [defs (cdr defs)])
+              (cond
+                [(null? defs) 
+                 (set-defn-end-pos! first (send text last-position))]
+                [else (set-defn-end-pos! first (max (- (defn-start-pos (car defs)) 1)
+                                                    (defn-start-pos first)))
+                      (loop (car defs) (cdr defs))])))
+          
+          (when indent?
+            (for-each (λ (defn)
+                        (set-defn-name! defn
+                                        (string-append
+                                         (apply string
+                                                (vector->list
+                                                 (make-vector 
+                                                  (- (defn-indent defn) min-indent) #\space)))
+                                         (defn-name defn))))
+                      defs))
+          defs))
+
+      ;; in-semicolon-comment: text number -> boolean
+      ;; returns #t if `define-start-pos' is in a semicolon comment and #f otherwise
+      (define (in-semicolon-comment? text define-start-pos)
+        (let* ([para (send text position-paragraph define-start-pos)]
+               [start (send text paragraph-start-position para)])
+          (let loop ([pos start])
+            (cond
+              [(pos . >= . define-start-pos) #f]
+              [(char=? #\; (send text get-character pos)) #t]
+              [else (loop (+ pos 1))]))))
+      
+      ;; get-defn-indent : text number -> number
+      ;; returns the amount to indent a particular definition
+      (define (get-defn-indent text pos)
+        (let* ([para (send text position-paragraph pos)]
+               [para-start (send text paragraph-start-position para #t)])
+          (let loop ([c-pos para-start]
+                     [offset 0])
+            (if (< c-pos pos)
+                (let ([char (send text get-character c-pos)])
+                  (cond
+                    [(char=? char #\tab)
+                     (loop (+ c-pos 1) (+ offset (- 8 (modulo offset 8))))]
+                    [else
+                     (loop (+ c-pos 1) (+ offset 1))]))
+                offset))))
+      
+      ;; skip-to-whitespace/paren : text number -> number
+      ;; skips to the next parenthesis or whitespace after `pos', returns that position.
+      (define (skip-to-whitespace/paren text pos)
+        (let loop ([pos pos])
+          (if (>= pos (send text last-position))
+              (send text last-position)
+              (let ([char (send text get-character pos)])
+                (cond
+                  [(or (char=? #\) char)
+                       (char=? #\( char)
+                       (char=? #\] char)
+                       (char=? #\[ char)
+                       (char-whitespace? char))
+                   pos]
+                  [else (loop (+ pos 1))])))))
+      
+      ;; skip-whitespace/paren : text number -> number
+      ;; skips past any parenthesis or whitespace
+      (define (skip-whitespace/paren text pos)
+        (let loop ([pos pos])
+          (if (>= pos (send text last-position))
+              (send text last-position)
+              (let ([char (send text get-character pos)])
+                (cond
+                  [(or (char=? #\) char)
+                       (char=? #\( char)
+                       (char=? #\] char)
+                       (char=? #\[ char)
+                       (char-whitespace? char))
+                   (loop (+ pos 1))]
+                  [else pos])))))
+      
+      ;; get-defn-name : text number -> string
+      ;; returns the name of the definition starting at `define-pos'
+      (define (get-defn-name text define-pos)
+        (if (>= define-pos (send text last-position))
+            (string-constant end-of-buffer-define)
+            (let* ([start-pos (skip-whitespace/paren text (skip-to-whitespace/paren text define-pos))]
+                   [end-pos (skip-to-whitespace/paren text start-pos)])
+              (send text get-text start-pos end-pos))))
+      
+      (define (set-box/f! b v) (when (box? b) (set-box! b v)))
+      
+
+                                    
+                                    
+                                    
+   ;;                               
+  ;                                 
+  ;                                 
+ ;;;  ; ;;  ;;;   ; ;;; ;;     ;;;  
+  ;   ;;   ;   ;  ;;  ;;  ;   ;   ; 
+  ;   ;        ;  ;   ;   ;   ;   ; 
+  ;   ;     ;;;;  ;   ;   ;   ;;;;; 
+  ;   ;    ;   ;  ;   ;   ;   ;     
+  ;   ;    ;   ;  ;   ;   ;   ;     
+  ;   ;     ;;;;; ;   ;   ;    ;;;; 
+                                    
+                                    
+                                    
+      (define vertical-dragable/def-int%
+        (class panel:vertical-dragable%
+          (init-field unit-frame)
+          (inherit get-percentages)
+          (define/augment (after-percentage-change)
+            (let ([percentages (get-percentages)])
+              (when (and (= 1
+                            (length (send unit-frame get-definitions-canvases))
+                            (length (send unit-frame get-interactions-canvases)))
+                         (= 2 (length percentages)))
+                (preferences:set 'drscheme:unit-window-size-percentage (car percentages))))
+            (inner (void) after-percentage-change))
+          (super-new)))
+      
+      (define super-frame%
+        (drscheme:frame:mixin
+         (drscheme:frame:basics-mixin 
+          (frame:searchable-text-mixin 
+           (frame:searchable-mixin
+            (frame:text-info-mixin 
+             (frame:delegate-mixin
+              (frame:status-line-mixin
+               (frame:info-mixin
+                (frame:text-mixin
+                 (frame:open-here-mixin
+                  (frame:editor-mixin
+                   (frame:standard-menus-mixin
+                    (frame:register-group-mixin
+                     (frame:basic-mixin
+                      frame%)))))))))))))))
+      
+      (define tab%
+        (class* object% (drscheme:rep:context<%> tab<%>)
+          (init-field frame
+                      defs
+                      i)
+          (define enabled? #t)
+          (field [ints #f]
+                 [visible-defs #f]
+                 [visible-ints #f])
+          
+          ;; only called to initialize this tab.
+          ;; the interactions editor should be invariant.
+          (define/public (set-ints i) (set! ints i)) 
+          
+          (define/public-final (get-frame) frame)
+          (define/public-final (get-defs) defs)
+          (define/public-final (get-ints) ints)
+          (define/public-final (get-visible-defs) visible-defs)
+          (define/public-final (set-visible-defs vd) (set! visible-defs vd))
+          (define/public-final (get-visible-ints) visible-ints)
+          (define/public-final (set-visible-ints vi) (set! visible-ints vi))
+          (define/public-final (get-i) i)
+          (define/public-final (set-i _i) (set! i _i))
+          (define/public (disable-evaluation)
+            (set! enabled? #f)
+            (send defs lock #t)
+            (send ints lock #t)
+            (send frame disable-evaluation-in-tab this))
+          (define/public (enable-evaluation)
+            (set! enabled? #t)
+            (send defs lock #f)
+            (send ints lock #f)
+            (send frame enable-evaluation-in-tab this))
+          (define/public (get-enabled) enabled?)
+        
+          (define/public (get-directory)
+            (let ([filename (send defs get-filename)])
+              (if (and (path? filename)
+                       (file-exists? filename))
+                  (let-values ([(base _1 _2) (split-path (mzlib:file:normalize-path filename))])
+                    base)
+                  #f)))
+          (define/public (needs-execution?)
+            (send defs needs-execution?))
+          
+          (define/pubment (can-close?)
+            (and (send defs can-close?)
+                 (send ints can-close?)
+                 (inner #t can-close?)))
+          (define/pubment (on-close)
+            (send defs on-close)
+            (send ints on-close)
+            (inner (void) on-close))
+          
+          ;; this should really do something local to the tab, but
+          ;; for now it doesn't.
+          (define/public (ensure-rep-shown rep) 
+            (send frame ensure-rep-shown rep))
+          
+          (field [thread-to-break-box (make-weak-box #f)]
+                 [custodian-to-kill-box (make-weak-box #f)]
+                 [offer-kill? #f])
+          
+          ;; break-callback : -> void
+          (define/public (break-callback)
+            (cond
+              [(or (not (weak-box-value thread-to-break-box))
+                   (not (weak-box-value custodian-to-kill-box)))
+               (bell)]
+              [offer-kill? 
+               (if (user-wants-kill?)
+                   (let ([thd (weak-box-value thread-to-break-box)])
+                     (when thd
+                       (break-thread thd)))
+                   (let ([cust (weak-box-value custodian-to-kill-box)])
+                     (when cust
+                       (custodian-shutdown-all cust))))]
+              [else
+               (let ([thd (weak-box-value thread-to-break-box)])
+                 (when thd
+                   (break-thread thd)))
+               ;; only offer a kill the next time if 
+               ;; something got broken.
+               (set! offer-kill? #t)]))
+          
+          ;; user-wants-kill? : -> boolean
+          ;; handles events, so be sure to check state
+          ;; after calling to avoid race conditions.
+          (define/private (user-wants-kill?)
+            (gui-utils:get-choice
+             (string-constant kill-evaluation?)
+             (string-constant just-break)
+             (string-constant kill)
+             (string-constant kill?)
+             'diallow-close
+             frame))
+          
+          ;; reset-offer-kill
+          (define/public (reset-offer-kill)
+            (set! offer-kill? #f))
+          
+          ;; get-breakables : -> (union #f thread) (union #f cust) -> void
+          (define/public (get-breakables)
+            (values (weak-box-value thread-to-break-box) (weak-box-value custodian-to-kill-box)))
+          
+          ;; set-breakables : (union #f thread) (union #f cust) -> void
+          (define/public (set-breakables thd cust)
+            (set! thread-to-break-box (make-weak-box thd))
+            (set! custodian-to-kill-box (make-weak-box cust)))
+          
+          (define/pubment (clear-annotations)
+            (inner (void) clear-annotations)
+            (send ints reset-highlighting))
+          
+          (define/public (update-running b?) (send frame update-running b?))
+          
+          (define/public-final (is-current-tab?) (eq? this (send frame get-current-tab)))
+          
+          (super-new)))
+      
+      ;; should only be called by the tab% object
+      (define-local-member-name 
+        disable-evaluation-in-tab
+        enable-evaluation-in-tab)
+      
+      (define -frame<%>
+        (interface (drscheme:frame:<%> frame:searchable-text<%> frame:delegate<%> frame:open-here<%>)
+          get-special-menu
+          get-interactions-text
+          get-definitions-text
+          get-interactions-canvas
+          get-definitions-canvas
+          get-button-panel
+          execute-callback
+          get-current-tab
+          open-in-new-tab
+          on-tab-change
+          enable-evaluation
+          disable-evaluation
+          get-definitions/interactions-panel-parent))
+      
+      (define frame-mixin
+        (mixin (drscheme:frame:<%> frame:searchable-text<%> frame:delegate<%> frame:open-here<%>)
+          (-frame<%>)
+          (init filename)
+          (inherit set-label-prefix get-show-menu
+                   get-menu%
+                   get-area-container
+                   update-info
+                   get-file-menu
+                   file-menu:get-close-item
+                   file-menu:get-open-item
+                   file-menu:get-new-item
+                   file-menu:get-save-item
+                   file-menu:get-save-as-item
+                   file-menu:get-revert-item
+                   file-menu:get-print-item)
+
+          ;; logging : (union #f string[directory-name])
+          (field [logging #f]
+                 [definitions-log-counter 0]  ;; number
+                 [interactions-log-counter 0] ;; number
+                 [logging-parent-panel #f]    ;; panel (unitialized short time only)
+                 [logging-panel #f]           ;; panel (unitialized short time only)
+                 [logging-menu-item #f])      ;; menu-item (unitialized short time only)
+          ;; log-definitions : -> void
+          (define/private (log-definitions)
+            (when logging
+              (set! definitions-log-counter (+ definitions-log-counter 1))
+              (send definitions-text save-file 
+                    (build-path logging (format "~a-definitions" (pad-two definitions-log-counter)))
+                    'copy)))
+          
+          ;; log-ineractions : -> void
+          (define/private (log-interactions)
+            (when logging
+              (set! interactions-log-counter (+ interactions-log-counter 1))
+              (send interactions-text save-file 
+                    (build-path logging (format "~a-interactions" (pad-two interactions-log-counter)))
+                    'copy)))
+          
+          ;; pad-two : number -> string
+          ;; pads a number to two digits?
+          (define/private (pad-two n)
+            (cond
+              [(<= 0 n 9) (format "0~a" n)]
+              [else (format "~a" n)]))
+          
+          ;; start-logging : -> void
+          ;; turns on the logging and shows the logging gui
+          (define/private (start-logging)
+            (let ([log-directory (mred:get-directory
+                                  (string-constant please-choose-a-log-directory)
+                                  this)])
+              (when (and log-directory
+                         (ensure-empty log-directory))
+                (send logging-menu-item set-label (string-constant stop-logging))
+                (set! logging log-directory)
+                (set! definitions-log-counter 0)
+                (set! interactions-log-counter 0)
+                (build-logging-panel)
+                (log-definitions))))
+          
+          ;; stop-logging : -> void
+          ;; turns off the logging procedure
+          (define/private (stop-logging)
+            (log-interactions)
+            (send logging-menu-item set-label (string-constant log-definitions-and-interactions))
+            (set! logging #f)
+            (send logging-panel change-children (λ (l) null)))
+          
+          ;; build-logging-panel : -> void
+          ;; builds the contents of the logging panel
+          (define/private (build-logging-panel)
+            (define hp (make-object horizontal-panel% logging-panel '(border)))
+            (make-object message% (string-constant logging-to) hp)
+            (send (make-object message% (path->string logging) hp) stretchable-width #t)
+            (make-object button% (string-constant stop-logging) hp (λ (x y) (stop-logging))))
+          
+          ;; remove-logging-pref-callback : -> void
+          ;; removes the callback that shows and hides the logging panel
+          (field [remove-logging-pref-callback
+                  (preferences:add-callback
+                   'framework:show-status-line
+                   (λ (p v)
+                     (when (is-a? logging-parent-panel panel%)
+                       (send logging-parent-panel change-children
+                             (λ (l)
+                               (if v 
+                                   (list logging-panel)
+                                   null))))))])
+          
+          ;; ensure-empty : string[directory] -> boolean
+          ;; if the log-directory is empty, just return #t
+          ;; if not, ask the user about emptying it. 
+          ;;   if they say yes, try to empty it.
+          ;;     if that fails, report the error and return #f.
+          ;;     if it succeeds, return #t.
+          ;;   if they say no, return #f.
+          (define/private (ensure-empty log-directory)
+            (let ([dir-list (directory-list log-directory)])
+              (or (null? dir-list)
+                  (let ([query (message-box 
+                                (string-constant drscheme)
+                                (format (string-constant erase-log-directory-contents) log-directory)
+                                this
+                                '(yes-no))])
+                    (cond
+                      [(eq? query 'no) 
+                       #f]
+                      [(eq? query 'yes)
+                       (with-handlers ([exn:fail:filesystem?
+                                        (λ (exn)
+                                          (message-box 
+                                           (string-constant drscheme)
+                                           (format (string-constant error-erasing-log-directory)
+                                                   (if (exn? exn)
+                                                       (format "~a" (exn-message exn))
+                                                       (format "~s" exn)))
+                                           this)
+                                          #f)])
+                         (for-each (λ (file) (delete-file (build-path log-directory file)))
+                                   dir-list)
+                         #t)])))))
+
+          (define/override (make-root-area-container cls parent)
+            (let* ([outer-panel (super make-root-area-container module-browser-dragable-panel% parent)]
+                   [saved-p (preferences:get 'drscheme:module-browser-size-percentage)]
+                   [_module-browser-panel (new vertical-panel%
+                                            (parent outer-panel)
+                                            (alignment '(left center))
+                                            (stretchable-width #f))]
+                   [louter-panel (make-object vertical-panel% outer-panel)]
+                   [root (make-object cls louter-panel)])
+              (set! module-browser-panel _module-browser-panel)
+              (set! module-browser-parent-panel outer-panel)
+              (send outer-panel change-children (λ (l) (remq module-browser-panel l)))
+              (preferences:set 'drscheme:module-browser-size-percentage saved-p)
+              (set! logging-parent-panel (new horizontal-panel%
+                                           (parent louter-panel)
+                                           (stretchable-height #f)))
+              (set! logging-panel (make-object horizontal-panel% logging-parent-panel))
+              (unless (preferences:get 'framework:show-status-line)
+                (send logging-parent-panel change-children (λ (l) null)))
+              root))
+
+          (inherit show-info hide-info is-info-hidden?)
+          (field [toolbar-shown? (preferences:get 'drscheme:toolbar-shown)]
+                 [toolbar-menu-item #f])
+          
+          (define/override (on-toolbar-button-click) 
+            (toggle-toolbar-visiblity))
+          
+          (define/private (toggle-toolbar-visiblity)
+            (set! toolbar-shown? (not toolbar-shown?))
+            (preferences:set 'drscheme:toolbar-shown toolbar-shown?)
+            (update-toolbar-visiblity))
+
+          (define/private (update-toolbar-visiblity)
+            (cond
+              [toolbar-shown?
+               (show-info)
+               (send top-outer-panel change-children (λ (l) (list top-panel)))
+               (send toolbar-menu-item set-label (string-constant hide-toolbar))]
+              [else
+               (hide-info)
+               (send top-outer-panel change-children (λ (l) '()))
+               (send toolbar-menu-item set-label (string-constant show-toolbar))])
+            (update-defs/ints-resize-corner))
+          
+          (field [remove-show-status-line-callback
+                  (preferences:add-callback
+                   'framework:show-status-line
+                   (λ (p v)
+                     (update-defs/ints-resize-corner/pref v)))])
+          
+          (define/private (update-defs/ints-resize-corner)
+            (update-defs/ints-resize-corner/pref (preferences:get 'framework:show-status-line)))
+          
+          (define/private (update-defs/ints-resize-corner/pref si-pref)
+            (let ([bottom-material? (and toolbar-shown? si-pref)])
+              (let loop ([cs definitions-canvases])
+                (cond
+                  [(null? cs) (void)]
+                  [(null? (cdr cs))
+                   (send (car cs) set-resize-corner (and (not bottom-material?)
+                                                         (not interactions-shown?)))]
+                  [else
+                   (send (car cs) set-resize-corner #f)
+                   (loop (cdr cs))]))
+              (let loop ([cs interactions-canvases])
+                (cond
+                  [(null? cs) (void)]
+                  [(null? (cdr cs))
+                   (send (car cs) set-resize-corner (and (not bottom-material?) 
+                                                         interactions-shown?))]
+                  [else
+                   (send (car cs) set-resize-corner #f)
+                   (loop (cdr cs))]))))
+          
+          [define definitions-item #f]
+          [define interactions-item #f]
+          [define name-message #f]
+          [define save-button #f]
+          [define save-init-shown? #f]
+          
+          [define/private set-save-init-shown? (λ (x) (set! save-init-shown? x))]
+          
+          [define canvas-show-mode #f]
+          [define allow-split? #f]
+          [define forced-quit? #f]
+          [define search-canvas #f]
+          
+          (define/public (make-searchable canvas)
+            (update-info)
+            (set! search-canvas canvas))
+          (define/override (get-text-to-search)
+            (if search-canvas
+                (send search-canvas get-editor)
+                (get-editor)))
+          
+          (define was-locked? #f)
+          
+          (define/public-final (disable-evaluation-in-tab tab)
+            (when (eq? tab current-tab)
+              (disable-evaluation)))
+          
+          (define/pubment (disable-evaluation)
+            (when execute-menu-item
+              (send execute-menu-item enable #f))
+            (send execute-button enable #f)
+            (send file-menu:create-new-tab-item enable #f)
+            (inner (void) disable-evaluation))
+          
+          (define/public-final (enable-evaluation-in-tab tab)
+            (when (eq? tab current-tab)
+              (enable-evaluation)))
+          
+          (define/pubment (enable-evaluation)
+            (when execute-menu-item
+              (send execute-menu-item enable #t))
+            (send execute-button enable #t)
+            (send file-menu:create-new-tab-item enable #t)
+            (inner (void) enable-evaluation))
+          
+          (inherit set-label)
+          (inherit modified)
+          (define/public (update-save-button)
+            (let ([mod? (send definitions-text is-modified?)])
+              (modified mod?)
+              (if save-button
+                  (unless (eq? mod? (send save-button is-shown?))
+                    (send save-button show mod?))
+                  (set! save-init-shown? mod?))))
+
+          ;; update-save-message : (union #f string) -> void
+          ;; sets the save message. If input is #f, uses the frame's
+          ;; title.
+          (define/public (update-save-message)
+            (when name-message
+              (let ([filename (send definitions-text get-filename)])
+                (send name-message set-message 
+                      (if filename #t #f)
+                      (send definitions-text get-filename/untitled-name))))
+            (update-tabs-labels))
+          
+          (define/private (update-tabs-labels)
+            (for-each
+             (λ (tab)
+               (let* ([label (get-defs-tab-label (send tab get-defs))])
+                 (unless (equal? label (send tabs-panel get-item-label (send tab get-i)))
+                   (send tabs-panel set-item-label (send tab get-i) label))))
+             tabs)
+            (send tabs-panel set-selection (send current-tab get-i))
+            (send (send tabs-panel get-parent)
+                  change-children
+                  (λ (l)
+                    (cond
+                      [(= (send tabs-panel get-number) 1)
+                       (remq tabs-panel l)]
+                      [else
+                       (if (memq tabs-panel l)
+                           l
+                           (cons tabs-panel l))]))))
+          
+          (define/private (get-defs-tab-label defs)
+            (let ([fn (send defs get-filename)])
+              (if fn
+                  (get-tab-label-from-filename fn)
+                  (send defs get-filename/untitled-name))))
+          (define/private (get-tab-label-from-filename fn)
+            (let-values ([(base name dir?) (split-path fn)])
+              (path->string name)))
+            
+          [define/override get-canvas% (λ () (drscheme:get/extend:get-definitions-canvas))]
+          
+          (define/public (update-running running?)
+            (send running-message set-label 
+                  (if running?
+                      (string-constant running)
+                      (string-constant not-running))))
+          (define/public (ensure-defs-shown)
+            (unless definitions-shown?
+              (toggle-show/hide-definitions)
+              (update-shown)))
+          (define/public (ensure-rep-shown rep)
+            (unless (eq? rep interactions-text)
+              (let loop ([tabs tabs])
+                (unless (null? tabs)
+                  (let ([tab (car tabs)])
+                    (if (eq? (send tab get-ints) rep)
+                        (change-to-tab tab)
+                        (loop (cdr tabs)))))))
+            (unless interactions-shown?
+              (toggle-show/hide-interactions)
+              (update-shown)))
+          (define/public (ensure-rep-hidden)
+            (when interactions-shown?
+              (toggle-show/hide-interactions)
+              (update-shown)))
+          
+          (override get-editor%)
+          [define get-editor% (λ () (drscheme:get/extend:get-definitions-text))]
+          (define/public (still-untouched?)
+            (and (= (send definitions-text last-position) 0)
+                 (not (send definitions-text is-modified?))
+                 (not (send definitions-text get-filename))
+                 (let* ([prompt (send interactions-text get-prompt)]
+                        [first-prompt-para
+                         (let loop ([n 0])
+                           (cond
+                             [(n . <= . (send interactions-text last-paragraph))
+                              (if (string=?
+                                   (send interactions-text get-text 
+                                         (send interactions-text paragraph-start-position n)
+                                         (+ (send interactions-text paragraph-start-position n)
+                                            (string-length prompt)))
+                                   prompt)
+                                  n
+                                  (loop (+ n 1)))]
+                             [else #f]))])
+                   (and first-prompt-para
+                        (= first-prompt-para (send interactions-text last-paragraph))
+                        (equal? 
+                         (send interactions-text get-text
+                               (send interactions-text paragraph-start-position first-prompt-para)
+                               (send interactions-text paragraph-end-position first-prompt-para))
+                         (send interactions-text get-prompt))))))
+          (define/public (change-to-file name)
+            (cond
+              [(and name (file-exists? name))
+               (ensure-rep-hidden)
+	       (send definitions-text begin-edit-sequence)
+               (send definitions-text load-file/gui-error name)
+	       (send definitions-text end-edit-sequence)]
+              [name
+               (send definitions-text set-filename name)]
+              [else (send definitions-text clear)])
+            (send definitions-canvas focus))
+
+          (define execute-menu-item #f)
+          (define file-menu:print-transcript-item #f)
+          (define file-menu:create-new-tab-item #f)
+          
+          (define/override (file-menu:between-new-and-open file-menu)
+            (set! file-menu:create-new-tab-item
+                  (new menu:can-restore-menu-item%
+                       (label (string-constant new-tab))
+                       (shortcut #\=)
+                       (parent file-menu)
+                       (callback
+                        (λ (x y)
+                          (create-new-tab))))))
+          [define/override file-menu:between-open-and-revert
+            (lambda (file-menu)
+              (super file-menu:between-open-and-revert file-menu)
+              (make-object separator-menu-item% file-menu))]
+          (define close-tab-menu-item #f)
+          (define/override (file-menu:between-close-and-quit file-menu)
+            (set! close-tab-menu-item
+                  (new (get-menu-item%)
+                       (label (string-constant close-tab))
+                       (demand-callback
+                        (λ (item)
+                          (send item enable (1 . < . (send tabs-panel get-number)))))
+                       (parent file-menu)
+                       (callback
+                        (λ (x y)
+                          (close-current-tab)))))
+            (super file-menu:between-close-and-quit file-menu))
+          
+          [define/override file-menu:save-string (λ () (string-constant save-definitions))]
+          [define/override file-menu:save-as-string (λ () (string-constant save-definitions-as))]
+          [define/override file-menu:between-save-as-and-print
+            (λ (file-menu)
+              (let ([sub-menu (make-object menu% (string-constant save-other) file-menu)])
+                (make-object menu:can-restore-menu-item%
+                  (string-constant save-definitions-as-text)
+                  sub-menu
+                  (λ (_1 _2)
+                    (let ([filename (send definitions-text put-file #f #f)])
+                      (when filename
+                        (send definitions-text save-file/gui-error filename 'text)))))
+                (make-object menu:can-restore-menu-item%
+                  (string-constant save-interactions)
+                  sub-menu
+                  (λ (_1 _2) 
+                    (send interactions-text save-file/gui-error)))
+                (make-object menu:can-restore-menu-item%
+                  (string-constant save-interactions-as)
+                  sub-menu
+                  (λ (_1 _2)
+                    (let ([filename (send interactions-text put-file #f #f)])
+                      (when filename
+                        (send interactions-text save-file/gui-error filename 'standard)))))
+                (make-object menu:can-restore-menu-item%
+                  (string-constant save-interactions-as-text)
+                  sub-menu
+                  (λ (_1 _2)
+                    (let ([filename (send interactions-text put-file #f #f)])
+                      (when filename
+                        (send interactions-text save-file/gui-error filename 'text)))))
+                (make-object separator-menu-item% file-menu)
+                (set! logging-menu-item
+                      (make-object menu:can-restore-menu-item%
+                        (string-constant log-definitions-and-interactions)
+                        file-menu
+                        (λ (x y)
+                          (if logging
+                              (stop-logging)
+                              (start-logging)))))
+                (make-object separator-menu-item% file-menu)))]
+          
+          [define/override file-menu:print-string (λ () (string-constant print-definitions))]
+          (define/override (file-menu:between-print-and-close file-menu)
+            (set! file-menu:print-transcript-item
+                  (make-object menu:can-restore-menu-item%
+                    (string-constant print-interactions)
+                    file-menu
+                    (λ (_1 _2)
+                      (send interactions-text print
+                            #t 
+                            #t
+                            (preferences:get 'framework:print-output-mode)))))
+            (super file-menu:between-print-and-close file-menu))
+          
+          (define/override (edit-menu:between-find-and-preferences edit-menu)
+            (super edit-menu:between-find-and-preferences edit-menu)
+            (add-modes-submenu edit-menu))
+                    
+          
+;                                            
+;                                            
+;                                            
+;                           ;                
+;                           ;                
+;                           ;                
+;   ; ;;  ;;     ;;;     ;; ;    ;;;    ;;;  
+;   ;;  ;;  ;   ;   ;   ;  ;;   ;   ;  ;     
+;   ;   ;   ;  ;     ; ;    ;  ;    ;  ;;    
+;   ;   ;   ;  ;     ; ;    ;  ;;;;;;   ;;   
+;   ;   ;   ;  ;     ; ;    ;  ;          ;  
+;   ;   ;   ;   ;   ;   ;  ;;   ;         ;  
+;   ;   ;   ;    ;;;     ;; ;    ;;;;  ;;;   
+;                                            
+;                                            
+;                                            
+
+          
+          (define/private (add-modes-submenu edit-menu)
+            (new menu%
+                 (parent edit-menu)
+                 (label (string-constant mode-submenu-label))
+                 (demand-callback
+                  (λ (menu)
+                    (for-each (λ (item) (send item delete))
+                              (send menu get-items))
+                    (for-each (λ (mode) 
+                                (let* ([item
+                                        (new checkable-menu-item%
+                                             (label (drscheme:modes:mode-name mode))
+                                             (parent menu)
+                                             (callback 
+                                              (λ (_1 _2) (send definitions-text set-current-mode mode))))])
+                                  (when (send definitions-text is-current-mode? mode)
+                                    (send item check #t))))
+                              (drscheme:modes:get-modes))))))
+          
+          
+
+          
+;                                                                                         
+;                                                                                         
+;                                                                                         
+;                  ;   ;           ;                  ;   ;                               
+;                  ;               ;                  ;   ;                               
+;                  ;       ;      ;                   ;   ;                               
+;    ;;;   ; ;;    ;   ;  ;;;;    ;     ;;;    ;;;    ;   ;   ;;;    ; ;;     ;;;    ;;;  
+;   ;      ;;  ;   ;   ;   ;      ;    ;   ;  ;   ;   ;   ;  ;   ;   ;;  ;   ;      ;   ; 
+;   ;;     ;    ;  ;   ;   ;      ;   ;      ;     ;  ;   ;      ;   ;    ;  ;;    ;    ; 
+;    ;;    ;    ;  ;   ;   ;     ;    ;      ;     ;  ;   ;   ;;;;   ;    ;   ;;   ;;;;;; 
+;      ;   ;    ;  ;   ;   ;     ;    ;      ;     ;  ;   ;  ;   ;   ;    ;     ;  ;      
+;      ;   ;;  ;   ;   ;   ;     ;     ;   ;  ;   ;   ;   ;  ;   ;   ;;  ;      ;   ;     
+;   ;;;    ; ;;    ;   ;    ;;  ;       ;;;    ;;;    ;   ;   ;;;;;  ; ;;    ;;;     ;;;; 
+;          ;                    ;                                    ;                    
+;          ;                    ;                                    ;                    
+;          ;                                                         ;                    
+
+          
+          (inherit get-edit-target-window)
+          (define/private (split)
+            (let* ([canvas-to-be-split (get-edit-target-window)]
+                   [update
+                    (λ (set-canvases! canvases canvas% text)
+                      (let-values ([(ox oy ow oh cursor-y)
+                                    (get-visible-region canvas-to-be-split)])
+                        (let ([orig-percentages (send resizable-panel get-percentages)]
+                              [orig-canvases (send resizable-panel get-children)]
+                              [new-canvas (new canvas% 
+                                            (parent resizable-panel)
+                                            (editor text)
+                                            (style '()))])
+                          
+                          (set-canvases!
+                           (let loop ([canvases canvases])
+                             (cond
+                               [(null? canvases) (error 'split "couldn't split; didn't find canvas")]
+                               [else
+                                (let ([canvas (car canvases)])
+                                  (if (eq? canvas canvas-to-be-split)
+                                      (list* new-canvas
+                                             canvas
+                                             (cdr canvases))
+                                      (cons canvas (loop (cdr canvases)))))])))
+                          
+                          (update-shown)
+                          
+                          ;; with-handlers prevents bad calls to set-percentages
+                          ;; might still leave GUI in bad state, however.
+                          (with-handlers ([exn:fail? (λ (x) (void))])
+                            (send resizable-panel set-percentages
+                                  (let loop ([canvases orig-canvases]
+                                             [percentages orig-percentages])
+                                    (cond
+                                      [(null? canvases)
+                                       (error 'split "couldn't split; didn't find canvas")]
+                                      [(null? percentages)
+                                       (error 'split "wrong number of percentages: ~s ~s"
+                                              orig-percentages
+                                              (send resizable-panel get-children))]
+                                      [else (let ([canvas (car canvases)])
+                                              (if (eq? canvas-to-be-split canvas)
+                                                  (list* (/ (car percentages) 2)
+                                                         (/ (car percentages) 2)
+                                                         (cdr percentages))
+                                                  (cons
+                                                   (car percentages)
+                                                   (loop (cdr canvases)
+                                                         (cdr percentages)))))]))))
+                          
+                          (set-visible-region new-canvas ox oy ow oh cursor-y)
+                          (set-visible-region canvas-to-be-split ox oy ow oh cursor-y)
+                          
+                          (send new-canvas focus))))])
+              (cond
+                [(memq canvas-to-be-split definitions-canvases)
+                 (update (λ (x) (set! definitions-canvases x))
+                         definitions-canvases
+                         (drscheme:get/extend:get-definitions-canvas)
+                         definitions-text)]
+                [(memq canvas-to-be-split interactions-canvases)
+                 (update (λ (x) (set! interactions-canvases x))
+                         interactions-canvases
+                         (drscheme:get/extend:get-interactions-canvas)
+                         interactions-text)]
+                [else (bell)])))
+          
+          ;; split-demand : menu-item -> void
+          ;; enables the menu-item if splitting is allowed, disables otherwise
+          (define/private (split-demand item)
+            (let ([canvas-to-be-split (get-edit-target-window)])
+              (send item enable
+                    (or (memq canvas-to-be-split definitions-canvases)
+                        (memq canvas-to-be-split interactions-canvases))))) 
+          
+          ;; collapse-demand : menu-item -> void
+          ;; enables the menu-item if collapsing is allowed, disables otherwise
+          (define/private (collapse-demand item)
+            (let ([canvas-to-be-split (get-edit-target-window)])
+              (cond
+                [(memq canvas-to-be-split definitions-canvases)
+                 (send item enable (2 . <= . (length definitions-canvases)))]
+                [(memq canvas-to-be-split interactions-canvases)
+                 (send item enable (2 . <= . (length interactions-canvases)))]
+                [else
+                 (send item enable #f)])))
+          
+          ;; get-visible-region : editor-canvas -> number number number number (union #f number)
+          ;; calculates the visible region of the editor in this editor-canvas, returning
+          ;; four numbers for the x, y, width and height of the visible region
+          ;; also, the last two booleans indiciate if the beginning and the end
+          ;; of the selection was visible before the split, respectively.
+          (define/private (get-visible-region canvas)
+            (send canvas call-as-primary-owner
+                  (λ ()
+                    (let* ([text (send canvas get-editor)]
+                           [admin (send text get-admin)]
+                           [start (send text get-start-position)]
+                           [end (send text get-end-position)])
+                      (let-values ([(x y w h) (get-visible-area admin)])
+                        (let ([ysb (box 0)])
+                          (send text position-location (send text get-start-position) #f ysb)
+                          (values x y w h
+                                  (and (= start end)
+                                       (<= y (unbox ysb) (+ y h))
+                                       (unbox ysb)))))))))
+          
+          ;; set-visible-region : editor-canvas number number number number (union #f number) -> void
+          ;; sets the visible region of the text displayed by the editor canvas
+          ;; to be the middle of the region (vertically) specified by x, y, w, and h.
+          ;; if start-visible? and/or end-visible? are true, some special handling
+          ;; is done to try to keep the start and end visible, with precendence
+          ;; given to start if both are #t.
+          (define/private (set-visible-region canvas x y w h cursor-y)
+            (send canvas call-as-primary-owner
+                  (λ ()
+                    (let* ([text (send canvas get-editor)]
+                           [admin (send text get-admin)]
+                           [nwb (box 0)]
+                           [nhb (box 0)])
+                      (send admin get-view #f #f nwb nhb)
+                      (let* ([nw (unbox nwb)]
+                             [nh (unbox nhb)]
+                             
+                             [nx x]
+                             [raw-y (- (+ y (/ h 2)) (/ nh 2))]
+                             [ny (if (and cursor-y 
+                                          (not (<= raw-y cursor-y (+ raw-y nh))))
+                                     (- cursor-y (/ nh 2))
+                                     raw-y)])
+                        (send canvas scroll-to nx ny nw nh #t)
+                        (void))))))
+          
+          ;; get-visible-area : admin -> number number number number
+          ;; returns the visible area for this admin
+          (define/private (get-visible-area admin)
+            (let ([bx (box 0)]
+                  [by (box 0)]
+                  [bw (box 0)]
+                  [bh (box 0)])
+              (send admin get-view bx by bw bh)
+              (values (unbox bx)
+                      (unbox by)
+                      (unbox bw)
+                      (unbox bh))))
+          
+          (define/private (collapse)
+            (let* ([target (get-edit-target-window)]
+                   [handle-collapse
+                    (λ (get-canvases set-canvases!)
+                      (if (= 1 (length (get-canvases)))
+                          (bell)
+                          (let* ([old-percentages (send resizable-panel get-percentages)]
+                                 [soon-to-be-bigger-canvas #f]
+                                 [percentages
+                                  (if (eq? (car (get-canvases)) target)
+                                      (begin
+                                        (set! soon-to-be-bigger-canvas (cadr (get-canvases)))
+                                        (cons (+ (car old-percentages)
+                                                 (cadr old-percentages))
+                                              (cddr old-percentages)))
+                                      (let loop ([canvases (cdr (get-canvases))]
+                                                 [prev-canvas (car (get-canvases))]
+                                                 [percentages (cdr old-percentages)]
+                                                 [prev-percentage (car old-percentages)])
+                                        (cond
+                                          [(null? canvases)
+                                           (error 'collapse "internal error.1")]
+                                          [(null? percentages)
+                                           (error 'collapse "internal error.2")]
+                                          [else
+                                           (if (eq? (car canvases) target)
+                                               (begin
+                                                 (set! soon-to-be-bigger-canvas prev-canvas)
+                                                 (cons (+ (car percentages)
+                                                          prev-percentage)
+                                                       (cdr percentages)))
+                                               (cons prev-percentage
+                                                     (loop (cdr canvases)
+                                                           (car canvases)
+                                                           (cdr percentages)
+                                                           (car percentages))))])))])
+                            (unless soon-to-be-bigger-canvas
+                              (error 'collapse "internal error.3"))
+                            (set-canvases! (remq target (get-canvases)))
+                            (update-shown)
+                            
+                            (let ([target-admin 
+                                   (send target call-as-primary-owner
+                                         (λ ()
+                                           (send (send target get-editor) get-admin)))]
+                                  [to-be-bigger-admin 
+                                   (send soon-to-be-bigger-canvas call-as-primary-owner
+                                         (λ ()
+                                           (send (send soon-to-be-bigger-canvas get-editor) get-admin)))])
+                              (let-values ([(bx by bw bh) (get-visible-area target-admin)])
+                                
+                                ;; this line makes the soon-to-be-bigger-canvas bigger
+                                ;; if it fails, we're out of luck, but at least we don't crash.
+                                (with-handlers ([exn:fail? (λ (x) (void))])
+                                  (send resizable-panel set-percentages percentages))
+                                
+                                (let-values ([(ax ay aw ah) (get-visible-area to-be-bigger-admin)])
+                                  (send soon-to-be-bigger-canvas scroll-to
+                                        bx
+                                        (- by (/ (- ah bh) 2))
+                                        aw
+                                        ah
+                                        #t))))
+                            
+                            (send soon-to-be-bigger-canvas focus))))])
+              (cond
+                [(memq target definitions-canvases)
+                 (handle-collapse
+                  (λ () definitions-canvases)
+                  (λ (c) (set! definitions-canvases c)))]
+                [(memq target interactions-canvases)
+                 (handle-collapse
+                  (λ () interactions-canvases)
+                  (λ (c) (set! interactions-canvases c)))]
+                [else (bell)])))
+          
+
+;                                                                          
+;                                                                          
+;                                                                          
+;          ;                                                               
+;          ;                                                               
+;          ;                                                               
+;    ;;;   ; ;;     ;;;   ;   ;   ;      ; ;;  ;;     ;;;   ; ;;    ;   ;  
+;   ;      ;;  ;   ;   ;  ;   ;   ;      ;;  ;;  ;   ;   ;  ;;  ;   ;   ;  
+;   ;;     ;   ;  ;     ;  ; ; ; ;       ;   ;   ;  ;    ;  ;   ;   ;   ;  
+;    ;;    ;   ;  ;     ;  ; ; ; ;       ;   ;   ;  ;;;;;;  ;   ;   ;   ;  
+;      ;   ;   ;  ;     ;  ; ; ; ;       ;   ;   ;  ;       ;   ;   ;   ;  
+;      ;   ;   ;   ;   ;    ;   ;        ;   ;   ;   ;      ;   ;   ;  ;;  
+;   ;;;    ;   ;    ;;;     ;   ;        ;   ;   ;    ;;;;  ;   ;    ;; ;  
+;                                                                          
+;                                                                          
+;                                                                          
+
+          
+          (define interactions-shown? #t)
+          (define definitions-shown? #t)
+          
+          (define/private (toggle-show/hide-definitions)
+            (set! definitions-shown? (not definitions-shown?))
+            (unless definitions-shown?
+              (set! interactions-shown? #t)))
+          (define/private (toggle-show/hide-interactions)
+            (set! interactions-shown? (not interactions-shown?))
+            (unless  interactions-shown?
+              (set! definitions-shown? #t)))
+          
+          (define/override (update-shown)
+	    (super update-shown)
+	    
+	    (let ([new-children
+		   (foldl
+		    (λ (shown? children sofar)
+		      (if shown?
+			  (append children sofar)
+			  sofar))
+		    null
+		    (list interactions-shown?
+			  definitions-shown?)
+		    (list interactions-canvases
+			  definitions-canvases))]
+		  [p (preferences:get 'drscheme:unit-window-size-percentage)])
+	      
+              (update-defs/ints-resize-corner)
+              
+	      (send definitions-item set-label 
+		    (if definitions-shown?
+			(string-constant hide-definitions-menu-item-label)
+			(string-constant show-definitions-menu-item-label)))
+	      (send interactions-item set-label 
+		    (if interactions-shown?
+			(string-constant hide-interactions-menu-item-label)
+			(string-constant show-interactions-menu-item-label)))
+	      
+	      (send resizable-panel begin-container-sequence)
+	      
+	      ;; this might change the unit-window-size-percentage, so save/restore it
+	      (send resizable-panel change-children (λ (l) new-children))
+	      
+	      (preferences:set 'drscheme:unit-window-size-percentage p)
+	      
+	      ;; restore preferred interactions/definitions sizes
+	      (when (and (= 1 (length definitions-canvases))
+			 (= 1 (length interactions-canvases))
+			 (= 2 (length new-children)))
+		(with-handlers ([exn:fail? (λ (x) (void))])
+		  (send resizable-panel set-percentages
+			(list p (- 1 p))))))
+	    
+	    (send resizable-panel end-container-sequence)
+	    
+	    (when (ormap (λ (child)
+			   (and (is-a? child editor-canvas%)
+				(not (send child has-focus?))))
+			 (send resizable-panel get-children))
+	      (let loop ([children (send resizable-panel get-children)])
+		(cond
+		  [(null? children) (void)]
+		  [else (let ([child (car children)])
+			  (if (is-a? child editor-canvas%)
+			      (send child focus)
+			      (loop (cdr children))))])))
+	    
+	    
+	    (for-each
+	     (λ (get-item)
+	       (let ([item (get-item)])
+		 (when item
+		   (send item enable definitions-shown?))))
+	     (list (λ () (file-menu:get-revert-item))
+		   (λ () (file-menu:get-save-item))
+		   (λ () (file-menu:get-save-as-item))
+					;(λ () (file-menu:save-as-text-item)) ; Save As Text...
+		   (λ () (file-menu:get-print-item))))
+	    (send file-menu:print-transcript-item enable interactions-shown?))
+          
+          (define/augment (can-close?)
+            (and (andmap (lambda (tab)
+                           (or (eq? tab current-tab)
+                               (and (send (send tab get-defs) can-close?)
+                                    (send (send tab get-ints) can-close?))))
+                         tabs)
+                 (send interactions-text can-close?)
+                 (inner #t can-close?)))
+          (define/augment (on-close)
+            (inner (void) on-close)
+            (for-each (lambda (tab)
+                        (unless (eq? tab current-tab)
+                          (send (send tab get-defs) on-close)
+                          (send (send tab get-ints) on-close)))
+                      tabs)
+            (when (eq? this newest-frame)
+              (set! newest-frame #f))
+            (when logging
+              (stop-logging))
+            (remove-logging-pref-callback)
+            (remove-show-status-line-callback)
+            (send interactions-text on-close))
+          
+          ;; execute-callback : -> void
+          ;; uses the state of the button to determine if an execution is
+          ;; already running. This function is called from many places, not
+          ;; just the execute button.
+          (define/public (execute-callback)
+            (when (send execute-button is-enabled?)
+              (check-if-save-file-up-to-date)
+              (when (preferences:get 'drscheme:show-interactions-on-execute)
+                (ensure-rep-shown interactions-text))
+              (when logging
+                (log-definitions)
+                (log-interactions))
+              (send definitions-text just-executed)
+              (send interactions-canvas focus)
+              (send interactions-text reset-console)
+              (send interactions-text clear-undos)
+              (let ([start (if (and ((send definitions-text last-position) . >= . 2)
+                                    (char=? (send definitions-text get-character 0) #\#)
+                                    (char=? (send definitions-text get-character 1) #\!))
+                               (send definitions-text paragraph-start-position 1)
+                               0)])
+                (send definitions-text split-snip start)
+                (let ([prt (open-input-text-editor definitions-text start)])
+                  (port-count-lines! prt)
+                  (send interactions-text evaluate-from-port
+                        prt
+                        #t
+                        (λ ()
+                          (send interactions-text clear-undos)))))))
+          
+          (inherit revert save)
+          (define/private (check-if-save-file-up-to-date)
+            (when (send definitions-text save-file-out-of-date?)
+              (let ([user-choice 
+                     (message-box/custom
+                      (string-constant drscheme)
+                      (string-constant definitions-modified)
+                      (string-constant ignore)
+                      (string-constant revert)
+                      #f
+                      this
+                      '(caution no-default number-order)
+                      1)])
+                (case user-choice
+                  [(1) (void)]
+                  [(2) (revert)]))))
+          
+          (inherit get-menu-bar get-focus-object get-edit-target-object)
+          (define language-menu 'uninited-language-menu)
+          
+          (define/override on-size
+            (lambda (w h)
+              (preferences:set 'drscheme:unit-window-width w)
+              (preferences:set 'drscheme:unit-window-height h)
+              (super on-size w h)))
+          
+          (define/override (get-editor) definitions-text)
+          (define/override (get-canvas)
+	    (initialize-definitions-canvas)
+	    definitions-canvas)
+          (define/private (initialize-definitions-canvas)
+            (unless definitions-canvas
+              (set! definitions-canvas
+                    (new (drscheme:get/extend:get-definitions-canvas)
+                         (parent resizable-panel)
+                         (editor definitions-text)))))
+          
+          (define/override (get-delegated-text) definitions-text)
+          (define/override (get-open-here-editor) definitions-text)
+          
+          ;; wire the definitions text to the interactions text and initialize it.
+          (define/private (init-definitions-text tab)
+            (let ([defs (send tab get-defs)]
+                  [ints (send tab get-ints)])
+              (send defs set-interactions-text ints)
+              (send defs set-tab tab)
+              (send ints set-definitions-text defs)
+              (send defs change-mode-to-match)))
+
+
+;                              
+;                              
+;                @@            
+;    @            @            
+;   @@@@@   $@$:  @-@$   :@@+@ 
+;    @        -@  @+ *$  @$ -@ 
+;    @     -$@$@  @   @  :@@$- 
+;    @     $*  @  @   @     *@ 
+;    @: :$ @- *@  @  +$  @  :@ 
+;    :@@$- -$$-@@@@+@$   $+@@: 
+;                              
+;                              
+;                              
+;                              
+
+          (define/public (get-current-tab) current-tab)
+          
+          ;; create-new-tab : -> void
+          ;; creates a new tab and updates the GUI for that new tab
+          (define/private create-new-tab
+            (opt-lambda ([filename #f])
+              (let* ([defs (new (drscheme:get/extend:get-definitions-text))]
+                     [tab-count (length tabs)]
+                     [new-tab (new (drscheme:get/extend:get-tab) (defs defs) (i tab-count) (frame this))]
+                     [ints (make-object (drscheme:get/extend:get-interactions-text) new-tab)])
+                (send new-tab set-ints ints)
+                (set! tabs (append tabs (list new-tab)))
+                (send tabs-panel append (if filename
+                                            (get-tab-label-from-filename filename)
+                                            (get-defs-tab-label defs)))
+                (init-definitions-text new-tab)
+                (when filename (send defs load-file filename))
+                (change-to-nth-tab (- (send tabs-panel get-number) 1))
+                (send ints initialize-console)
+                (send tabs-panel set-selection (- (send tabs-panel get-number) 1))
+                (set! newest-frame this)
+                (update-menu-bindings))))
+          
+          ;; change-to-tab : tab -> void
+          ;; updates current-tab, definitions-text, and interactactions-text
+          ;; to be the nth tab. Also updates the GUI to show the new tab
+          (define/private (change-to-tab tab)
+            (let ([old-delegate (send definitions-text get-delegate)]
+                  [old-tab current-tab])
+              (save-visible-tab-regions)
+              (set! current-tab tab)
+              (set! definitions-text (send current-tab get-defs))
+              (set! interactions-text (send current-tab get-ints))
+              
+              (for-each (λ (defs-canvas) (send defs-canvas set-editor definitions-text))
+                        definitions-canvases)
+              (for-each (λ (ints-canvas) (send ints-canvas set-editor interactions-text))
+                        interactions-canvases)
+
+              (restore-visible-tab-regions)
+              (update-save-message)
+              (update-save-button)
+              
+              (send definitions-text update-frame-filename)
+              (send definitions-text set-delegate old-delegate)
+              (on-tab-change old-tab current-tab)))
+          
+          (define/pubment (on-tab-change from-tab to-tab)
+            (let ([old-enabled (send from-tab get-enabled)]
+                  [new-enabled (send to-tab get-enabled)])
+              (unless (eq? old-enabled new-enabled)
+                (if new-enabled
+                    (enable-evaluation)
+                    (disable-evaluation))))
+            
+            (let ([from-defs (send from-tab get-defs)]
+                  [to-defs (send to-tab get-defs)])
+              (let ([delegate (send from-defs get-delegate)])
+                (send from-defs set-delegate #f)
+                (send to-defs set-delegate delegate)))
+            
+            (inner (void) on-tab-change from-tab to-tab))
+          
+          (define/public (next-tab) (change-to-delta-tab +1))
+          (define/public (prev-tab) (change-to-delta-tab -1))
+          
+          (define/private (change-to-delta-tab dt)
+            (change-to-nth-tab (modulo (+ (send current-tab get-i) dt) (length tabs))))
+          
+          (define/private (close-current-tab)
+            (cond
+              [(null? tabs) (void)]
+              [(null? (cdr tabs)) (void)]
+              [else
+               (let loop ([l-tabs tabs])
+                 (cond
+                   [(null? l-tabs) (error 'close-current-tab "uh oh.3")]
+                   [else
+                    (let ([tab (car l-tabs)])
+                      (if (eq? tab current-tab)
+                          (when (close-tab tab)
+                            (for-each (lambda (t) (send t set-i (- (send t get-i) 1)))
+                                      (cdr l-tabs))
+                            (set! tabs (remq tab tabs))
+                            (send tabs-panel delete (send tab get-i))
+                            (update-menu-bindings) 
+                            (change-to-tab (cond
+                                             [(< (send tab get-i) (length tabs))
+                                              (list-ref tabs (send tab get-i))]
+                                             [else (car (last-pair tabs))])))
+                          (loop (cdr l-tabs))))]))]))
+          
+          (define/private (close-tab tab)
+            (cond
+              [(send tab can-close?)
+               (send tab on-close)
+               #t]
+              [else #f]))
+          
+          (define/public (open-in-new-tab filename)
+            (create-new-tab filename))
+          
+          (define/private (change-to-nth-tab n)
+            (unless (< n (length tabs))
+              (error 'change-to-nth-tab "number too big ~s" n))
+            (change-to-tab (list-ref tabs n)))
+          
+          (define/private (save-visible-tab-regions)
+            (define (get-visible-regions txt)
+              (map (λ (canvas) (get-visible-region txt canvas))
+                   (send txt get-canvases)))
+            (define (get-visible-region txt canvas)
+              (let ([xb (box 0)]
+                    [yb (box 0)]
+                    [wb (box 0)]
+                    [hb (box 0)])
+                (send canvas call-as-primary-owner
+                      (λ ()
+                        (let ([admin (send txt get-admin)])
+                          (when admin
+                            (send admin get-view xb yb wb hb)))))
+                (list (unbox xb) (unbox yb) (unbox wb) (unbox hb))))
+            (send current-tab set-visible-ints (get-visible-regions interactions-text))
+            (send current-tab set-visible-defs (get-visible-regions definitions-text)))
+                
+          (define/private (restore-visible-tab-regions)
+            (define (set-visible-regions txt regions)
+              (when regions
+                (let ([canvases (send txt get-canvases)])
+                  (when (= (length canvases) (length regions))
+                    (for-each (λ (c r) (set-visible-region txt c r)) canvases regions)))))
+            (define (set-visible-region txt canvas region)
+              (send canvas scroll-to 
+                    (first region)
+                    (second region)
+                    (third region)
+                    (fourth region)
+                    #t))
+            (set-visible-regions interactions-text (send current-tab get-visible-ints))
+            (set-visible-regions definitions-text (send current-tab get-visible-defs)))
+
+          (define/private (pathname-equal? p1 p2)
+            (with-handlers ([exn:fail:filesystem? (λ (x) #f)])
+              (string=? (path->string (normalize-path p1))
+                        (path->string (normalize-path p2)))))
+          (define/override (make-visible filename)
+            (let loop ([tabs tabs])
+              (unless (null? tabs)
+                (let* ([tab (car tabs)]
+                       [tab-filename (send (send tab get-defs) get-filename)])
+                  (if (and tab-filename
+                           (pathname-equal? filename tab-filename))
+                      (change-to-tab tab)
+                      (loop (cdr tabs)))))))
+          
+          (define/override (editing-this-file? filename)
+            (ormap (λ (tab)
+                     (let ([fn (send (send tab get-defs) get-filename)])
+                       (and fn
+                            (pathname-equal? fn filename))))
+                   tabs))
+          
+          (define/override (get-menu-item%)
+            (class (super get-menu-item%)
+              (inherit get-label get-plain-label)
+              (define/override (restore-keybinding)
+                (cond
+                  [(equal? (get-plain-label) (string-constant close))
+                   (update-close-menu-item-shortcut this)]
+                  [(equal? (get-plain-label) (string-constant close-tab))
+                   (update-close-tab-menu-item-shortcut this)]
+                  [else (super restore-keybinding)]))
+              (super-new)))
+                
+          (define/private (update-menu-bindings)
+            (when (preferences:get 'framework:menu-bindings)
+              (when close-tab-menu-item
+                (update-close-tab-menu-item-shortcut close-tab-menu-item))
+              (update-close-menu-item-shortcut (file-menu:get-close-item))))
+          
+          (define/private (update-close-tab-menu-item-shortcut item)
+            (let ([just-one? (and (pair? tabs) (null? (cdr tabs)))])
+              (send item set-shortcut (if just-one? #f #\w))))
+          (define/private (update-close-menu-item-shortcut item)
+            (let ([just-one? (and (pair? tabs) (null? (cdr tabs)))])
+              (send item set-shortcut (if just-one? #\w #f))))
+
+          
+          ;;
+          ;; end tabs
+          ;;
+          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+          
+          (define/public (get-definitions-text) definitions-text)
+          (define/public (get-interactions-text) interactions-text)
+          
+          (define/private (update-teachpack-menu)
+            (define user-teachpack-cache (send (get-interactions-text) get-user-teachpack-cache))
+            (for-each (λ (item) (send item delete)) teachpack-items)
+            (set! teachpack-items
+                  (map (λ (name)
+                         (make-object menu:can-restore-menu-item%
+                           (format (string-constant clear-teachpack) 
+                                   (mzlib:file:file-name-from-path name))
+                           language-menu
+                           (λ (item evt)
+                             (let ([new-teachpacks 
+                                    (drscheme:teachpack:new-teachpack-cache
+                                     (remove
+                                      name
+                                      (drscheme:teachpack:teachpack-cache-filenames
+                                       user-teachpack-cache)))])
+                               (send (get-interactions-text) set-user-teachpack-cache new-teachpacks)
+                               (preferences:set 'drscheme:teachpacks new-teachpacks)
+                               (send (get-definitions-text) teachpack-changed)))))
+                       (drscheme:teachpack:teachpack-cache-filenames
+                        user-teachpack-cache))))
+          
+          (define/public (get-definitions/interactions-panel-parent)
+            (get-area-container))
+          
+          (inherit delegated-text-shown? hide-delegated-text show-delegated-text)
+          (define/override (add-show-menu-items show-menu)
+            (super add-show-menu-items show-menu)
+            (set! definitions-item
+                  (make-object menu:can-restore-menu-item%
+                    (string-constant hide-definitions-menu-item-label)
+                    (get-show-menu)
+                    (λ (_1 _2) 
+                      (toggle-show/hide-definitions)
+                      (update-shown))
+                    #\d
+                    (string-constant definitions-menu-item-help-string)))
+            (set! interactions-item
+                  (make-object menu:can-restore-menu-item%
+                    (string-constant show-interactions-menu-item-label)
+                    (get-show-menu)
+                    (λ (_1 _2) 
+                      (toggle-show/hide-interactions)
+                      (update-shown))
+                    #\e
+                    (string-constant interactions-menu-item-help-string)))
+            
+            (new menu:can-restore-menu-item%
+              (shortcut #\u)
+              (label 
+               (if (delegated-text-shown?)
+                   (string-constant hide-overview)
+                   (string-constant show-overview)))
+              (parent (get-show-menu))
+              (callback
+               (λ (menu evt)
+                 (if (delegated-text-shown?)
+                     (begin
+                       (send menu set-label (string-constant show-overview))
+                       (preferences:set 'framework:show-delegate? #f)
+                       (hide-delegated-text))
+                     (begin
+                       (send menu set-label (string-constant hide-overview))
+                       (preferences:set 'framework:show-delegate? #t)
+                       (show-delegated-text))))))
+            
+            (set! module-browser-menu-item
+                  (new menu:can-restore-menu-item%
+                    (label (if module-browser-shown?
+                               (string-constant hide-module-browser)
+                               (string-constant show-module-browser)))
+                    (parent (get-show-menu))
+                    (callback
+                     (λ (menu evt)
+                       (if module-browser-shown?
+                           (hide-module-browser)
+                           (show-module-browser))))))
+            
+            (set! toolbar-menu-item
+                  (new menu-item%
+                       (label (string-constant show-toolbar))
+                       (parent show-menu)
+                       (callback
+                        (λ (x y)
+                          (toggle-toolbar-visiblity))))))
+
+          
+;                                                                                                       
+;                                                                                                       
+;                                                                                                       
+;                           ;           ;              ;                                                
+;                           ;           ;              ;                                                
+;                           ;           ;              ;                                                
+;   ; ;;  ;;     ;;;     ;; ;   ;   ;   ;    ;;;       ; ;;    ; ;   ;;;   ;   ;   ;   ;;;    ;;;   ; ; 
+;   ;;  ;;  ;   ;   ;   ;  ;;   ;   ;   ;   ;   ;      ;;  ;   ;;   ;   ;  ;   ;   ;  ;      ;   ;  ;;  
+;   ;   ;   ;  ;     ; ;    ;   ;   ;   ;  ;    ;      ;    ;  ;   ;     ;  ; ; ; ;   ;;    ;    ;  ;   
+;   ;   ;   ;  ;     ; ;    ;   ;   ;   ;  ;;;;;;      ;    ;  ;   ;     ;  ; ; ; ;    ;;   ;;;;;;  ;   
+;   ;   ;   ;  ;     ; ;    ;   ;   ;   ;  ;           ;    ;  ;   ;     ;  ; ; ; ;      ;  ;       ;   
+;   ;   ;   ;   ;   ;   ;  ;;   ;  ;;   ;   ;          ;;  ;   ;    ;   ;    ;   ;       ;   ;      ;   
+;   ;   ;   ;    ;;;     ;; ;    ;; ;   ;    ;;;;      ; ;;    ;     ;;;     ;   ;    ;;;     ;;;;  ;   
+;                                                                                                       
+;                                                                                                       
+;                                                                                                       
+
+          
+          (field [module-browser-shown? #f]
+                 [module-browser-parent-panel #f]
+                 [module-browser-panel #f]
+                 [module-browser-ec #f]
+                 [module-browser-button #f]
+                 [module-browser-lib-path-check-box #f]
+                 [module-browser-name-length-choice #f]
+                 [module-browser-pb #f]
+                 [module-browser-menu-item 'module-browser-menu-item-unset])
+
+          (inherit open-status-line close-status-line update-status-line)
+          
+          (define/private (show-module-browser)
+            (when module-browser-panel
+              (when (can-browse-language?)
+                (set! module-browser-shown? #t)
+                (send module-browser-menu-item set-label (string-constant hide-module-browser))
+                (update-module-browser-pane))))
+          
+          (define/private (hide-module-browser)
+            (when module-browser-panel
+              (set! module-browser-shown? #f)
+              (send module-browser-menu-item set-label (string-constant show-module-browser))
+              (close-status-line 'plt:module-browser:mouse-over)
+              (send module-browser-parent-panel change-children
+                    (λ (l)
+                      (remq module-browser-panel l)))))
+          
+          (define/private (can-browse-language?)
+            (let* ([lang/config (preferences:get (drscheme:language-configuration:get-settings-preferences-symbol))]
+                   [lang (drscheme:language-configuration:language-settings-language lang/config)]
+                   [strs (send lang get-language-position)]
+                   [can-browse?
+                    (or (regexp-match #rx"module" (car (last-pair strs)))
+                        (ormap (λ (x) (regexp-match #rx"PLT" x))
+                               strs))])
+              (unless can-browse?
+                (message-box (string-constant drscheme)
+                             (string-constant module-browser-only-in-plt-and-module-langs)))
+              can-browse?))
+                  
+          
+          (define/private (update-module-browser-pane)
+            (open-status-line 'plt:module-browser:mouse-over)
+            (send module-browser-panel begin-container-sequence)
+            (unless module-browser-ec 
+              (set! module-browser-pb 
+                    (drscheme:module-overview:make-module-overview-pasteboard
+                     #t
+                     (λ (x) (mouse-currently-over x))))
+              (set! module-browser-ec (make-object editor-canvas%
+                                        module-browser-panel
+                                        module-browser-pb))
+              (set! module-browser-lib-path-check-box
+                    (new check-box%
+                      (parent module-browser-panel)
+                      (label show-lib-paths)
+                      (value (preferences:get 'drscheme:module-browser:show-lib-paths?))
+                      (callback 
+                       (λ (x y) 
+                         (let ([val (send module-browser-lib-path-check-box get-value)])
+                           (preferences:set 'drscheme:module-browser:show-lib-paths? val)
+                           (send module-browser-pb show-lib-paths val))))))
+              
+              (set! module-browser-name-length-choice
+                    (new choice%
+                         (parent module-browser-panel)
+                         (label (string-constant module-browser-name-length))
+                         (choices (list (string-constant module-browser-name-short)
+                                        (string-constant module-browser-name-medium)
+                                        (string-constant module-browser-name-long)))
+                         (selection (preferences:get 'drscheme:module-browser:name-length))
+                         (callback
+                          (λ (x y)
+                            (let ([selection (send module-browser-name-length-choice get-selection)])
+                              (preferences:set 'drscheme:module-browser:name-length selection)
+                              (update-module-browser-name-length selection))))))
+              (update-module-browser-name-length 
+               (preferences:get 'drscheme:module-browser:name-length))
+              
+              (set! module-browser-button 
+                    (new button%
+                      (parent module-browser-panel)
+                      (label refresh)
+                      (callback (λ (x y) (update-module-browser-pane)))
+                      (stretchable-width #t))))
+            
+            (let ([p (preferences:get 'drscheme:module-browser-size-percentage)])
+              (send module-browser-parent-panel change-children
+                    (λ (l)
+                      (cons module-browser-panel
+                            (remq module-browser-panel l))))
+              (with-handlers ([exn:fail? void])
+                (send module-browser-parent-panel set-percentages (list p (- 1 p))))
+              (send module-browser-parent-panel end-container-sequence)
+              (calculate-module-browser)))
+          
+          (define/private (update-module-browser-name-length i)
+            (send module-browser-pb set-name-length 
+                  (case i
+                    [(0) 'short]
+                    [(1) 'medium]
+                    [(2) 'long])))
+            
+          (define/private (mouse-currently-over snips)
+            (if (null? snips)
+                (update-status-line 'plt:module-browser:mouse-over #f)
+                (let* ([snip (car snips)]
+                       [lines (send snip get-lines)]
+                       [name (or (send snip get-filename)
+                                 (send snip get-word))]
+                       [str (if lines
+                                (format (string-constant module-browser-filename-format) name lines)
+                                name)])
+                  (update-status-line 'plt:module-browser:mouse-over str))))
+            
+          (define/private (calculate-module-browser)
+            (let ([mod-tab current-tab])
+              (let-values ([(old-break-thread old-custodian) (send mod-tab get-breakables)])
+                (open-status-line 'plt:module-browser)
+                (update-status-line 'plt:module-browser status-compiling-definitions)
+                (send module-browser-button enable #f)
+                (send module-browser-lib-path-check-box enable #f)
+                (send module-browser-name-length-choice enable #f)
+                (disable-evaluation-in-tab current-tab)
+                (drscheme:module-overview:fill-pasteboard 
+                 module-browser-pb
+                 (drscheme:language:make-text/pos
+                  definitions-text
+                  0
+                  (send definitions-text last-position))
+                 (λ (str) (update-status-line 
+                           'plt:module-browser 
+                           (format module-browser-progress-constant str)))
+                 (λ (user-thread user-custodian)
+                   (send mod-tab set-breakables user-thread user-custodian)))
+                (send mod-tab set-breakables old-break-thread old-custodian)
+                (send mod-tab enable-evaluation)
+                (send module-browser-button enable #t)
+                (send module-browser-lib-path-check-box enable #t)
+                (send module-browser-name-length-choice enable #t)
+                (close-status-line 'plt:module-browser))))
+          
+          ;; set-directory : text -> void
+          ;; sets the current-directory and current-load-relative-directory
+          ;; based on the file saved in the definitions-text
+          (define/private (set-directory definitions-text)
+            (let* ([tmp-b (box #f)]
+                   [fn (send definitions-text get-filename tmp-b)])
+              (unless (unbox tmp-b)
+                (when fn
+                  (let-values ([(base name dir?) (split-path fn)])
+                    (current-directory base)
+                    (current-load-relative-directory base))))))
+          
+
+;                                            
+;                                            
+;                                            
+;                                            
+;                                            
+;                                            
+;   ; ;;  ;;     ;;;   ; ;;    ;   ;    ;;;  
+;   ;;  ;;  ;   ;   ;  ;;  ;   ;   ;   ;     
+;   ;   ;   ;  ;    ;  ;   ;   ;   ;   ;;    
+;   ;   ;   ;  ;;;;;;  ;   ;   ;   ;    ;;   
+;   ;   ;   ;  ;       ;   ;   ;   ;      ;  
+;   ;   ;   ;   ;      ;   ;   ;  ;;      ;  
+;   ;   ;   ;    ;;;;  ;   ;    ;; ;   ;;;   
+;                                            
+;                                            
+;                                            
+
+          (define special-menu 'special-menu-not-yet-init)
+          (define/public (get-special-menu) special-menu)
+
+          
+          (define/private (initialize-menus)
+            (let* ([mb (get-menu-bar)]
+                   [language-menu-on-demand
+                    (λ (menu-item)
+                      (update-teachpack-menu))]
+                   [_ (set! language-menu (make-object (get-menu%) 
+                                            (string-constant language-menu-name)
+                                            mb
+                                            #f
+                                            language-menu-on-demand))]
+                   [scheme-menu (make-object (get-menu%) (string-constant scheme-menu-name) mb)]
+                   [send-method
+                    (λ (method)
+                      (λ (_1 _2)
+                        (let ([text (get-focus-object)])
+                          (when (is-a? text scheme:text<%>)
+                            (method text)))))])
+              
+              (make-object menu:can-restore-menu-item%
+                (string-constant choose-language-menu-item-label)
+                language-menu
+                (λ (_1 _2)
+                  (let ([new-settings (drscheme:language-configuration:language-dialog
+                                       #f
+                                       (send definitions-text get-next-settings)
+                                       this)])
+                    (when new-settings
+                      (send definitions-text set-next-settings new-settings)
+                      (preferences:set
+                       drscheme:language-configuration:settings-preferences-symbol
+                       new-settings))))
+                #\l)
+              (make-object separator-menu-item% language-menu)
+              (make-object menu:can-restore-menu-item%
+                (string-constant add-teachpack-menu-item-label)
+                language-menu
+                (λ (_1 _2)
+                  (when (drscheme:language-configuration:add-new-teachpack this)
+                    (send (get-definitions-text) teachpack-changed))))
+              (let ([clear-all-on-demand
+                     (λ (menu-item)
+                       (send menu-item enable
+                             (not (null? (drscheme:teachpack:teachpack-cache-filenames
+                                          (preferences:get 'drscheme:teachpacks))))))])
+                (make-object menu:can-restore-menu-item% 
+                  (string-constant clear-all-teachpacks-menu-item-label)
+                  language-menu
+                  (λ (_1 _2) 
+                    (when (drscheme:language-configuration:clear-all-teachpacks)
+                      (send (get-definitions-text) teachpack-changed)))
+                  #f
+                  #f
+                  clear-all-on-demand))
+              
+              (set! execute-menu-item
+                    (make-object menu:can-restore-menu-item%
+                      (string-constant execute-menu-item-label)
+                      scheme-menu
+                      (λ (_1 _2) (execute-callback))
+                      #\t
+                      (string-constant execute-menu-item-help-string)))
+              (make-object menu:can-restore-menu-item%
+                (string-constant break-menu-item-label)
+                scheme-menu
+                (λ (_1 _2) (send current-tab break-callback))
+                #\b
+                (string-constant break-menu-item-help-string))
+              (make-object menu:can-restore-menu-item%
+                (string-constant kill-menu-item-label)
+                scheme-menu
+                (λ (_1 _2) (send interactions-text kill-evaluation))
+                #\k
+                (string-constant kill-menu-item-help-string))
+              (new menu:can-restore-menu-item%
+                   (label (string-constant clear-error-highlight-menu-item-label))
+                   (parent scheme-menu)
+                   (callback
+                    (λ (_1 _2) 
+                      (let ([ints (send (get-current-tab) get-ints)])
+                        (send ints reset-error-ranges))))
+                   (help-string (string-constant clear-error-highlight-item-help-string))
+                   (demand-callback
+                    (λ (item)
+                      (let ([ints (send (get-current-tab) get-ints)])
+                        (send item enable (send ints get-error-ranges))))))
+              (make-object separator-menu-item% scheme-menu)
+              (make-object menu:can-restore-menu-item%
+                (string-constant create-executable-menu-item-label)
+                scheme-menu
+                (λ (x y) (create-executable this)))
+              (make-object menu:can-restore-menu-item%
+                (string-constant module-browser...)
+                scheme-menu
+                (λ (x y) (drscheme:module-overview:module-overview this)))
+              (make-object separator-menu-item% scheme-menu)
+              (make-object menu:can-restore-menu-item%
+                (string-constant reindent-menu-item-label)
+                scheme-menu
+                (send-method (λ (x) (send x tabify-selection))))
+              (make-object menu:can-restore-menu-item%
+                (string-constant reindent-all-menu-item-label)
+                scheme-menu
+                (send-method (λ (x) (send x tabify-all)))
+                #\i)
+              (make-object menu:can-restore-menu-item%
+                (string-constant box-comment-out-menu-item-label)
+                scheme-menu
+                (send-method (λ (x) (send x box-comment-out-selection))))
+              (make-object menu:can-restore-menu-item%
+                (string-constant semicolon-comment-out-menu-item-label)
+                scheme-menu
+                (send-method (λ (x) (send x comment-out-selection))))
+              (make-object menu:can-restore-menu-item%
+                (string-constant uncomment-menu-item-label)
+                scheme-menu
+                (λ (x y)
+                  (let ([text (get-focus-object)])
+                    (when (is-a? text text%)
+                      (let ([admin (send text get-admin)])
+                        (cond
+                          [(is-a? admin editor-snip-editor-admin<%>)
+                           (let ([es (send admin get-snip)])
+                             (cond
+                               [(is-a? es comment-box:snip%)
+                                (let ([es-admin (send es get-admin)])
+                                  (when es-admin
+                                    (let ([ed (send es-admin get-editor)])
+                                      (when (is-a? ed scheme:text<%>)
+                                        (send ed uncomment-box/selection)))))]
+                               [else (send text uncomment-selection)]))]
+                          [else (send text uncomment-selection)]))))))
+            
+              (set! special-menu
+                    (make-object (get-menu%) (string-constant special-menu) mb))
+
+              (let ([has-editor-on-demand
+                     (λ (menu-item)
+                       (let ([edit (get-edit-target-object)])
+                         (send menu-item enable (and edit (is-a? edit editor<%>)))))]
+                    [callback
+                     (λ (menu evt)
+                       (let ([edit (get-edit-target-object)])
+                         (when (and edit
+                                    (is-a? edit editor<%>))
+                           (let ([number (get-fraction-from-user this)])
+                             (when number
+                               (send edit insert
+                                     (number-snip:make-fraction-snip number #f)))))
+                         #t))]
+                    [insert-lambda
+                     (λ ()
+                       (let ([edit (get-edit-target-object)])
+                         (when (and edit
+                                    (is-a? edit editor<%>))
+                           (send edit insert "\u03BB")))
+                       #t)]
+                    [insert-large-semicolon-letters
+                     (λ ()
+                       (let ([edit (get-edit-target-object)])
+                         (when edit
+                           (let ([str (get-text-from-user (string-constant large-semicolon-letters)
+                                                          (string-constant text-to-insert)
+                                                          this)])
+                             (when (and str
+                                        (not (equal? str "")))
+                               (let ()
+                                 (define language-settings (send definitions-text get-next-settings))
+                                 (define-values (comment-prefix comment-character)
+                                   (if language-settings
+                                       (send (drscheme:language-configuration:language-settings-language
+                                              language-settings)
+                                             get-comment-character)
+                                       (values ";" #\;)))
+                                 (define bdc (make-object bitmap-dc% (make-object bitmap% 1 1 #t)))
+                                 (define the-font (send (send (editor:get-standard-style-list)
+                                                              find-named-style
+                                                              "Standard")
+                                                        get-font))
+                                 (define-values (tw th td ta) (send bdc get-text-extent str the-font))
+                                 (define tmp-color (make-object color%))
+                                 
+                                 
+                                 (define chars #f)
+                                 (define (compute-chars)
+                                   (unless chars
+                                     (let* ([bdc (make-object bitmap-dc% (make-object bitmap% 20 20 #t))]
+                                            [index-char
+                                             (lambda (s)
+                                               (send bdc clear)
+                                               (let-values ([(w h a d) (send bdc get-text-extent s)])
+                                                 (send bdc draw-text s 0 0)
+                                                 (let loop ([x w])
+                                                   (if (zero? x)
+                                                       0
+                                                       (+ (let loop ([y h])
+                                                            (if (zero? y)
+                                                                0
+                                                                (begin
+                                                                  (send bdc get-pixel (- x 1) (- y 1) tmp-color)
+                                                                  (+ (if (= (send tmp-color red) 255) 0 1)
+                                                                     (loop (- y 1))))))
+                                                          (loop (- x 1)))))))])
+                                       (send bdc set-font the-font)
+                                       (let* ([all-chars '(#\@ #\# #\+ #\- #\: #\$ #\& #\* #\space)]
+                                              [prs 
+                                               (quicksort
+                                                (map (lambda (c) (cons c (index-char (string c))))
+                                                     all-chars)
+                                                (lambda (x y) (> (cdr x) (cdr y))))]
+                                              [biggest (cdr (car prs))]
+                                              [smallest (cdr (car (last-pair prs)))]
+                                              [normalized
+                                               (map (lambda (x)
+                                                      (cons (car x)
+                                                            (- 255 (floor (* (/ (- (cdr x) smallest)
+                                                                                (- biggest smallest))
+                                                                             255)))))
+                                                    prs)])
+                                         (set! chars normalized)))))
+                                 (define (get-char x y)
+                                   (send bdc get-pixel x y tmp-color)
+                                   (let ([red (send tmp-color red)])
+                                     (or (ormap (lambda (pr)
+                                                  (if (<= red (cdr pr))
+                                                      (car pr)
+                                                      #f))
+                                                chars)
+                                         #\space)))
+                                 (define bitmap
+                                   (make-object bitmap% 
+                                     (inexact->exact tw)
+                                     (inexact->exact th) 
+                                     #f))
+                                 
+                                 (define (fetch-line y)
+                                   (let loop ([x (send bitmap get-width)]
+                                              [chars null])
+                                     (cond
+                                       [(zero? x) (apply string chars)]
+                                       [else (loop (- x 1) (cons (get-char (- x 1) y) chars))])))
+                                 
+                                 (compute-chars)
+                                 
+                                 (send bdc set-bitmap bitmap)
+                                 (send bdc clear)
+                                 (send bdc set-font the-font)
+                                 (send bdc draw-text str 0 0)
+                                 
+                                 (send edit begin-edit-sequence)
+                                 (let ([start (send edit get-start-position)]
+                                       [end (send edit get-end-position)])
+                                   (send edit delete start end)
+                                   (send edit insert "\n" start start)
+                                   (let loop ([y (send bitmap get-height)])
+                                     (unless (zero? y)
+                                       (send edit insert (fetch-line (- y 1)) start start)
+                                       (send edit insert comment-prefix start start)
+                                       (send edit insert "\n" start start)
+                                       (loop (- y 1)))))
+                                 (send edit end-edit-sequence)))))))]
+                    [c% (get-menu-item%)])
+                (frame:add-snip-menu-items special-menu c%)
+                
+                (make-object c% (string-constant insert-fraction-menu-item-label)
+                  special-menu callback 
+                  #f #f
+                  has-editor-on-demand)
+                (make-object c% (string-constant insert-large-letters...)
+                  special-menu
+                  (λ (x y) (insert-large-semicolon-letters))
+                  #f #f
+                  has-editor-on-demand)
+                (make-object c% (string-constant insert-lambda)
+                  special-menu
+                  (λ (x y) (insert-lambda))
+                  #\\
+                  #f
+                  has-editor-on-demand))
+
+              (make-object separator-menu-item% (get-show-menu))
+              
+              (new menu:can-restore-menu-item%
+                   (shortcut (if (eq? (system-type) 'macosx) #f #\m))
+                   (label (string-constant split-menu-item-label))
+                   (parent (get-show-menu))
+                   (callback (λ (x y) (split)))
+                   (demand-callback (λ (item) (split-demand item))))
+              (new menu:can-restore-menu-item% 
+                   (shortcut #\r)
+                   (label (string-constant collapse-menu-item-label))
+                   (parent (get-show-menu))
+                   (callback (λ (x y) (collapse)))
+                   (demand-callback (λ (item) (collapse-demand item))))
+              
+              (frame:reorder-menus this)))
+
+;                          
+;                          
+;                          
+;                          
+;   ++-@@-   -+@+- +++: :++
+;   +@@-+@  -@-:-@--@-   -@
+;   :@:  @: @+   ++ @::@::@
+;   :@   @: @@@@@@@ +--@--*
+;   :@   @: @-      -@+*+@:
+;   -@: :@- +@:::+@ :@@:@@ 
+;   @@@ +@@: +@@@+:  ++ ++ 
+;                          
+;                          
+;                          
+
+          (define definitions-text (new (drscheme:get/extend:get-definitions-text)))
+                    
+          ;; tabs : (listof tab)
+          (define tabs (list (new (drscheme:get/extend:get-tab)
+                                  (defs definitions-text)
+                                  (frame this)
+                                  (i 0))))
+          
+          ;; current-tab : tab
+          ;; corresponds to the tabs-panel's active button.
+          (define current-tab (car tabs))
+          
+          (define interactions-text (new (drscheme:get/extend:get-interactions-text) 
+                                         (context (car tabs))))
+          (send (car tabs) set-ints interactions-text)
+          
+          (init-definitions-text (car tabs))
+          
+          (super-new
+            (filename filename)
+            (style '(toolbar-button))
+            (width (preferences:get 'drscheme:unit-window-width))
+            (height (preferences:get 'drscheme:unit-window-height)))
+          
+          (initialize-menus)
+
+          
+;                                                                               
+;                                                                               
+;                                                                               
+;                                 ;       ;                                     
+;                                 ;       ;                                     
+;                                 ;       ;                                 ;   
+;   ; ;;    ;;;    ; ;;     ;;;   ;       ;   ;;;   ;     ;  ;;;    ;   ;  ;;;; 
+;   ;;  ;  ;   ;   ;;  ;   ;   ;  ;       ;  ;   ;  ;     ; ;   ;   ;   ;   ;   
+;   ;    ;     ;   ;   ;  ;    ;  ;       ;      ;   ;   ; ;     ;  ;   ;   ;   
+;   ;    ;  ;;;;   ;   ;  ;;;;;;  ;       ;   ;;;;   ;   ; ;     ;  ;   ;   ;   
+;   ;    ; ;   ;   ;   ;  ;       ;       ;  ;   ;    ; ;  ;     ;  ;   ;   ;   
+;   ;;  ;  ;   ;   ;   ;   ;      ;       ;  ;   ;    ; ;   ;   ;   ;  ;;   ;   
+;   ; ;;    ;;;;;  ;   ;    ;;;;  ;       ;   ;;;;;    ;     ;;;     ;; ;    ;; 
+;   ;                                                  ;                        
+;   ;                                                  ;                        
+;   ;                                                 ;                         
+
+          
+          ;; most contain only top-panel (or nothing)
+          (define top-outer-panel (new horizontal-pane% 
+                                       (parent (get-area-container))
+                                       (stretchable-height #f)))
+          
+          [define top-panel (make-object horizontal-panel% top-outer-panel)]
+          [define name-panel (new vertical-pane%
+                               (parent top-panel)
+			       (alignment '(left center))
+                               (stretchable-width #f)
+                               (stretchable-height #f))]
+          (define panel-with-tabs (new vertical-panel%
+                                       (parent (get-definitions/interactions-panel-parent))))
+          (define tabs-panel (new tab-panel% 
+                                  (font small-control-font)
+                                  (parent panel-with-tabs)
+                                  (stretchable-height #f)
+                                  (style '(deleted no-border))
+                                  (choices '("first name"))
+                                  (callback (λ (x y)
+                                              (let ([sel (send tabs-panel get-selection)])
+                                                (when sel
+                                                  (change-to-nth-tab sel)))))))
+          [define resizable-panel (new vertical-dragable/def-int%
+                                    (unit-frame this)
+                                    (parent panel-with-tabs))]
+          
+          [define definitions-canvas #f]
+          (initialize-definitions-canvas)
+          [define definitions-canvases (list definitions-canvas)]
+          [define interactions-canvas (new (drscheme:get/extend:get-interactions-canvas)
+                                           (parent resizable-panel)
+                                           (editor interactions-text))]
+          [define interactions-canvases (list interactions-canvas)]
+          
+
+          (define/public (get-definitions-canvases) 
+            ;; before definition, just return null
+            (if (pair? definitions-canvases)
+                definitions-canvases
+                null))
+          (define/public (get-interactions-canvases)
+            ;; before definition, just return null
+            (if (pair? interactions-canvases)
+                interactions-canvases
+                null))
+          
+          (public get-definitions-canvas get-interactions-canvas)
+          [define get-definitions-canvas (λ () definitions-canvas)]
+          [define get-interactions-canvas (λ () interactions-canvas)]
+          
+          (set! save-button
+                (make-object button% 
+                  (make-save-bitmap this)
+                  top-panel
+                  (λ args
+                    (when definitions-text
+                      (save)
+                      (send definitions-canvas focus)))))
+          
+          (set! name-message (new drs-name-message% [parent name-panel]))
+          [define teachpack-items null]
+          [define break-button (void)]
+          [define execute-button (void)]
+          [define button-panel (make-object horizontal-panel% top-panel)]
+          [define/public get-execute-button (λ () execute-button)]
+          [define/public get-break-button (λ () break-button)]
+          [define/public get-button-panel (λ () button-panel)]
+          
+          (inherit get-info-panel)
+          (define running-message
+            (make-object message% (string-constant not-running) (get-info-panel)))
+
+          
+          [define func-defs-canvas (new func-defs-canvas% 
+                                        (parent name-panel)
+                                        (frame this))]
+          
+          (set! execute-button
+                (make-object button%
+                  (make-execute-bitmap this)
+                  button-panel
+                  (λ (button evt) (execute-callback))))
+          (set! break-button
+                (make-object button%
+                  (make-break-bitmap this) 
+                  button-panel
+                  (λ (x y)
+		    (send current-tab break-callback))))
+          
+          (send button-panel stretchable-height #f)
+          (send button-panel stretchable-width #f) 
+          
+          (send top-panel change-children
+                (λ (l)
+                  (list name-panel save-button
+                        (make-object vertical-panel% top-panel) ;; spacer
+                        button-panel)))
+          
+          (send top-panel stretchable-height #f)
+          (inherit get-label)
+          (let ([m (send definitions-canvas get-editor)])
+            (set-save-init-shown?
+             (and m (send m is-modified?))))
+
+	  (update-save-message)
+          (update-save-button)
+          
+	  (cond
+            [filename
+             (set! definitions-shown? #t)
+             (set! interactions-shown? #f)]
+            [else
+             (set! definitions-shown? #t)
+             (set! interactions-shown? #t)])
+          
+          (update-shown)
+
+          (when (= 2 (length (send resizable-panel get-children)))
+            (send resizable-panel set-percentages
+                  (let ([p (preferences:get 'drscheme:unit-window-size-percentage)])
+                    (list p (- 1 p)))))
+          
+          (set-label-prefix (string-constant drscheme))
+          (update-toolbar-visiblity)
+          (set! newest-frame this)
+          (send definitions-canvas focus)))
+      
+      (define -frame% (frame-mixin super-frame%))
+
+      (define module-browser-dragable-panel%
+        (class panel:horizontal-dragable%
+          (inherit get-percentages)
+          (define/augment (after-percentage-change)
+            (let ([percentages (get-percentages)])
+              (when (and (pair? percentages)
+                         (pair? (cdr percentages))
+                         (null? (cddr percentages)))
+                (preferences:set 'drscheme:module-browser-size-percentage
+                                 (car percentages))))
+            (inner (void) after-percentage-change))
+          (super-new)))
+      
+      (define drs-name-message%
+        (class name-message%
+          (define/override (on-choose-directory dir)
+            (let ([file (finder:get-file dir)])
+              (when file
+                (handler:edit-file file))))
+          (super-new)))
+      
+      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;
+      ;; lambda-snipclass is for backwards compatibility
+      ;;
+      (define lambda-snipclass
+        (make-object (class snip-class% ()
+                       (define/override (read p) (make-object string-snip% "λ"))
+                       (super-new))))
+      (send lambda-snipclass set-version 1)
+      (send lambda-snipclass set-classname "drscheme:lambda-snip%")
+      (send (get-the-snip-class-list) add lambda-snipclass)
+      
+      (define newest-frame 'nothing-yet)
+      
+      (define open-drscheme-window
+        (case-lambda
+         [() (open-drscheme-window #f)]
+         [(name)
+          (cond
+            [(and newest-frame
+                  name
+                  (not (eq? newest-frame 'nothing-yet)) 
+                  (send newest-frame still-untouched?))
+             (send newest-frame change-to-file name)
+             (send newest-frame show #t)
+             (begin0 newest-frame
+                     (set! newest-frame #f))]
+            [(and name ;; only open a tab if we have a filename
+                  (preferences:get 'drscheme:open-in-tabs))
+             (let ([fr (let loop ([frs (cons (send (group:get-the-frame-group) get-active-frame)
+                                             (send (group:get-the-frame-group) get-frames))])
+                         (cond
+                           [(null? frs) #f]
+                           [else (let ([fr (car frs)])
+                                   (or (and (is-a? fr -frame<%>)
+                                            fr)
+                                       (loop (cdr frs))))]))])
+               (if fr
+                   (begin (send fr open-in-new-tab name)
+                          (send fr show #t)
+                          fr)
+                   (create-new-drscheme-frame name)))]
+            [else
+             (create-new-drscheme-frame name)])]))
+      
+      (define (create-new-drscheme-frame filename)
+        (let* ([drs-frame% (drscheme:get/extend:get-unit-frame)]
+               [frame (new drs-frame% (filename filename))])
+          (send (send frame get-interactions-text) initialize-console)
+          (send frame show #t)
+          frame))
+      
+      (handler:insert-format-handler 
+       "Units"
+       (λ (filename) #t)
+       open-drscheme-window))))
diff --git a/collects/drscheme/syncheck.ss b/collects/drscheme/syncheck.ss
new file mode 100644
index 0000000000..0f0989019d
--- /dev/null
+++ b/collects/drscheme/syncheck.ss
@@ -0,0 +1,2181 @@
+#|
+
+Check Syntax separates two classes of identifiers,
+those bound in this file and those bound by require,
+and uses identifier-binding and identifier-transformer-binding
+to distinguish them. 
+
+Variables come from 'origin, 'disappeared-use, and 'disappeared-binding 
+syntax properties, as well as from variable references and binding (letrec-values,
+let-values, define-values) in the fully expanded text.
+
+Variables inside #%top (not inside a module) are treated specially. 
+If the namespace has a binding for them, they are colored bound color.
+If the namespace does not, they are colored the unbound color.
+
+|#
+
+(module syncheck mzscheme
+  (require (lib "string-constant.ss" "string-constants")
+           (lib "unitsig.ss")
+           (lib "tool.ss" "drscheme")
+           (lib "class.ss")
+           (lib "list.ss")
+           (lib "toplevel.ss" "syntax")
+           (lib "boundmap.ss" "syntax")
+           (lib "bitmap-label.ss" "mrlib")
+           (prefix drscheme:arrow: (lib "arrow.ss" "drscheme"))
+           (prefix fw: (lib "framework.ss" "framework"))
+           (lib "mred.ss" "mred"))
+  (provide tool@)
+
+  (define o (current-output-port))
+  
+  (define status-init (string-constant cs-status-init))
+  (define status-coloring-program (string-constant cs-status-coloring-program))
+  (define status-eval-compile-time (string-constant cs-status-eval-compile-time))
+  (define status-expanding-expression (string-constant cs-status-expanding-expression))
+    
+  (define jump-to-next-bound-occurrence (string-constant cs-jump-to-next-bound-occurrence))
+  (define jump-to-binding (string-constant cs-jump-to-binding))
+  (define jump-to-definition (string-constant cs-jump-to-definition))
+  
+  (define-local-member-name
+    syncheck:init-arrows
+    syncheck:clear-arrows
+    syncheck:add-menu
+    syncheck:add-arrow
+    syncheck:add-tail-arrow
+    syncheck:add-mouse-over-status
+    syncheck:add-jump-to-definition
+    syncheck:sort-bindings-table
+    syncheck:get-bindings-table
+    syncheck:jump-to-next-bound-occurrence
+    syncheck:jump-to-binding-occurrence
+    syncheck:jump-to-definition
+    
+    syncheck:clear-highlighting
+    syncheck:button-callback
+    syncheck:add-to-cleanup-texts
+    syncheck:error-report-visible?
+    syncheck:clear-error-message
+    
+    hide-error-report
+    get-error-report-text
+    get-error-report-visible?)
+  
+  (define tool@
+    (unit/sig drscheme:tool-exports^
+      (import drscheme:tool^)
+
+      (define (phase1) 
+        (drscheme:unit:add-to-program-editor-mixin clearing-text-mixin))
+      (define (phase2) (void))
+
+      (define (printf . args) (apply fprintf o args))
+
+
+                     
+                     
+                      ;;;  ;;; ;;; ;;;;; 
+                     ;   ;  ;   ;    ;   
+                     ;   ;  ;   ;    ;   
+                     ;      ;   ;    ;   
+                     ;  ;;  ;   ;    ;   
+                     ;   ;  ;   ;    ;   
+                     ;   ;  ;; ;;    ;   
+                      ;;;    ;;;   ;;;;; 
+                     
+            
+      ;; used for quicker debugging of the preference panel
+      '(define test-preference-panel
+         (λ (name f)
+           (let ([frame (make-object frame% name)])
+             (f frame)
+             (send frame show #t))))
+      
+      (define-struct graphic (pos* locs->thunks draw-fn click-fn))
+      
+      (define-struct arrow (start-x start-y end-x end-y))
+      (define-struct (var-arrow arrow)
+                     (start-text start-pos-left start-pos-right
+                      end-text end-pos-left end-pos-right))
+      (define-struct (tail-arrow arrow) (from-text from-pos to-text to-pos))
+      
+      ;; id : symbol  --  the nominal-source-id from identifier-binding
+      ;; filename : path
+      (define-struct def-link (id filename) (make-inspector))
+      
+      (define tacked-var-brush (send the-brush-list find-or-create-brush "BLUE" 'solid))
+      (define var-pen (send the-pen-list find-or-create-pen "BLUE" 1 'solid))
+      (define tail-pen (send the-pen-list find-or-create-pen "orchid" 1 'solid))
+      (define tacked-tail-brush (send the-brush-list find-or-create-brush "orchid" 'solid))
+      (define untacked-brush (send the-brush-list find-or-create-brush "WHITE" 'solid))
+      
+      (define syncheck-text<%>
+        (interface ()
+          syncheck:init-arrows
+          syncheck:clear-arrows
+          syncheck:add-menu
+          syncheck:add-arrow
+          syncheck:add-tail-arrow
+          syncheck:add-mouse-over-status
+          syncheck:add-jump-to-definition
+          syncheck:sort-bindings-table
+          syncheck:get-bindings-table
+          syncheck:jump-to-next-bound-occurrence
+          syncheck:jump-to-binding-occurrence
+          syncheck:jump-to-definition))
+      
+      ;; clearing-text-mixin : (mixin text%)
+      ;; overrides methods that make sure the arrows go away appropriately.
+      ;; adds a begin/end-edit-sequence to the insertion and deletion
+      ;;  to ensure that the on-change method isn't called until after
+      ;;  the arrows are cleared.
+      (define clearing-text-mixin
+        (mixin ((class->interface text%)) ()
+          
+          (inherit begin-edit-sequence end-edit-sequence)
+          (define/augment (on-delete start len)
+            (begin-edit-sequence)
+            (inner (void) on-delete start len))
+          (define/augment (after-delete start len)
+            (inner (void) after-delete start len)
+            (clean-up)
+            (end-edit-sequence))
+          
+          (define/augment (on-insert start len)
+            (begin-edit-sequence)
+            (inner (void) on-insert start len))
+          (define/augment (after-insert start len)
+            (inner (void) after-insert start len)
+            (clean-up)
+            (end-edit-sequence))
+
+          (define/private (clean-up)
+            (let ([st (find-syncheck-text this)])
+              (when (and st
+                         (is-a? st drscheme:unit:definitions-text<%>))
+                (let ([tab (send st get-tab)])
+                  (send tab syncheck:clear-error-message)
+                  (send tab syncheck:clear-highlighting)))))
+          
+	  (super-new)))
+      
+      (define make-graphics-text%
+        (λ (super%)
+          (let* ([cursor-arrow (make-object cursor% 'arrow)])
+            (class* super% (syncheck-text<%>)
+              (inherit set-cursor get-admin invalidate-bitmap-cache set-position
+                       position-location
+                       get-canvas last-position dc-location-to-editor-location
+                       find-position begin-edit-sequence end-edit-sequence)
+              
+              
+              ;; arrow-vectors : 
+              ;; (union 
+              ;;  #f
+              ;;  (hash-table
+              ;;    (text%
+              ;;     . -o> .
+              ;;    (vector (listof (union (cons (union #f sym) (menu -> void))
+              ;;                           def-link
+              ;;                           tail-link
+              ;;                           arrow
+              ;;                           string))))))
+              (define arrow-vectors #f)
+              
+              
+              ;; bindings-table : hash-table[(list text number number) -o> (listof (list text number number))]
+              ;; this is a private field
+              (define bindings-table (make-hash-table 'equal))
+              
+              ;; add-to-bindings-table : text number number text number number -> boolean
+              ;; results indicates if the binding was added to the table. It is added, unless
+              ;;  1) it is already there, or
+              ;;  2) it is a link to itself
+              (define/private (add-to-bindings-table start-text start-left start-right
+                                                    end-text end-left end-right)
+                (cond
+                  [(and (object=? start-text end-text)
+                        (= start-left end-left)
+                        (= start-right end-right))
+                   #f]
+                  [else
+                   (let* ([key (list start-text start-left start-right)]
+                          [priors (hash-table-get bindings-table key (λ () '()))]
+                          [new (list end-text end-left end-right)])
+                     (cond
+                       [(member new priors)
+                        #f]
+                       [else
+                        (hash-table-put! bindings-table key (cons new priors))
+                        #t]))]))
+              
+              ;; for use in the automatic test suite
+              (define/public (syncheck:get-bindings-table) bindings-table)
+              
+              (define/public (syncheck:sort-bindings-table)
+                
+                ;; compare-bindings : (list text number number) (list text number number) -> boolean
+                (define (compare-bindings l1 l2)
+                  (let ([start-text (first l1)]
+                        [start-left (second l1)]
+                        [end-text (first l2)]
+                        [end-left (second l2)])
+                    (let-values ([(sx sy) (find-dc-location start-text start-left)]
+                                 [(ex ey) (find-dc-location end-text end-left)])
+                      (cond
+                        [(= sy ey) (< sx ex)]
+                        [else (< sy ey)]))))
+                
+                ;; find-dc-location : text number -> (values number number)
+                (define (find-dc-location text pos)
+                  (let ([bx (box 0)]
+                        [by (box 0)])
+                    (send text position-location pos bx by)
+                    (send text editor-location-to-dc-location (unbox bx) (unbox by))))
+                
+                (hash-table-for-each
+                 bindings-table
+                 (λ (k v)
+                   (hash-table-put! bindings-table k (quicksort v compare-bindings)))))
+                    
+              (define tacked-hash-table (make-hash-table))
+              (define cursor-location #f)
+              (define cursor-text #f)
+              (define/private (find-poss text left-pos right-pos)
+                (let ([xlb (box 0)]
+                      [ylb (box 0)]
+                      [xrb (box 0)]
+                      [yrb (box 0)])
+                  (send text position-location left-pos xlb ylb #t)
+                  (send text position-location right-pos xrb yrb #f)
+                  (let*-values ([(xl-off yl-off) (send text editor-location-to-dc-location (unbox xlb) (unbox ylb))]
+                                [(xl yl) (dc-location-to-editor-location xl-off yl-off)]
+                                [(xr-off yr-off) (send text editor-location-to-dc-location (unbox xrb) (unbox yrb))]
+                                [(xr yr) (dc-location-to-editor-location xr-off yr-off)])
+                    (values (/ (+ xl xr) 2)
+                            (/ (+ yl yr) 2)))))
+              
+              ;; find-char-box : text number number -> (values number number number number)
+              ;; returns the bounding box (left, top, right, bottom) for the text range.
+              ;; only works right if the text is on a single line.
+              (define/private (find-char-box text left-pos right-pos)
+                (let ([xlb (box 0)]
+                      [ylb (box 0)]
+                      [xrb (box 0)]
+                      [yrb (box 0)])
+                  (send text position-location left-pos xlb ylb #t)
+                  (send text position-location right-pos xrb yrb #f)
+                  (let*-values ([(xl-off yl-off) (send text editor-location-to-dc-location (unbox xlb) (unbox ylb))]
+                                [(xl yl) (dc-location-to-editor-location xl-off yl-off)]
+                                [(xr-off yr-off) (send text editor-location-to-dc-location (unbox xrb) (unbox yrb))]
+                                [(xr yr) (dc-location-to-editor-location xr-off yr-off)])
+                    (values 
+                     xl
+                     yl
+                     xr 
+                     yr))))
+              
+              (define/private (update-arrow-poss arrow)
+                (cond
+                  [(var-arrow? arrow) (update-var-arrow-poss arrow)]
+                  [(tail-arrow? arrow) (update-tail-arrow-poss arrow)]))
+              
+              (define/private (update-var-arrow-poss arrow)
+                (let-values ([(start-x start-y) (find-poss 
+                                                 (var-arrow-start-text arrow)
+                                                 (var-arrow-start-pos-left arrow)
+                                                 (var-arrow-start-pos-right arrow))]
+                             [(end-x end-y) (find-poss 
+                                             (var-arrow-end-text arrow)
+                                             (var-arrow-end-pos-left arrow)
+                                             (var-arrow-end-pos-right arrow))])
+                  (set-arrow-start-x! arrow start-x)
+                  (set-arrow-start-y! arrow start-y)
+                  (set-arrow-end-x! arrow end-x)
+                  (set-arrow-end-y! arrow end-y)))
+              
+              (define/private (update-tail-arrow-poss arrow)
+                (let-values ([(start-x start-y) (find-poss 
+                                                 (tail-arrow-from-text arrow)
+                                                 (tail-arrow-from-pos arrow)
+                                                 (+ (tail-arrow-from-pos arrow) 1))]
+                             [(end-x end-y) (find-poss 
+                                             (tail-arrow-to-text arrow)
+                                             (tail-arrow-to-pos arrow)
+                                             (+ (tail-arrow-to-pos arrow) 1))])
+                  (set-arrow-start-x! arrow start-x)
+                  (set-arrow-start-y! arrow start-y)
+                  (set-arrow-end-x! arrow end-x)
+                  (set-arrow-end-y! arrow end-y)))
+              
+              ;; syncheck:init-arrows : -> void
+              (define/public (syncheck:init-arrows)
+                (set! tacked-hash-table (make-hash-table))
+                (set! arrow-vectors (make-hash-table))
+                (set! bindings-table (make-hash-table 'equal))
+                (let ([f (get-top-level-window)])
+                  (when f
+                    (send f open-status-line 'drscheme:check-syntax:mouse-over))))
+              
+              ;; syncheck:clear-arrows : -> void
+              (define/public (syncheck:clear-arrows)
+                (when (or arrow-vectors cursor-location cursor-text)
+                  (let ([any-tacked? #f])
+                    (when tacked-hash-table
+                      (let/ec k
+                        (hash-table-for-each
+                         tacked-hash-table
+                         (λ (key val)
+                           (set! any-tacked? #t)
+                           (k (void))))))
+                    (set! tacked-hash-table #f)
+                    (set! arrow-vectors #f)
+                    (set! cursor-location #f)
+                    (set! cursor-text #f)
+                    (when any-tacked?
+                      (invalidate-bitmap-cache))
+                    (let ([f (get-top-level-window)])
+                      (when f
+                        (send f close-status-line 'drscheme:check-syntax:mouse-over))))))
+              (define/public (syncheck:add-menu text start-pos end-pos key make-menu)
+                (when (and (<= 0 start-pos end-pos (last-position)))
+                  (add-to-range/key text start-pos end-pos make-menu key #t)))
+              
+              ;; syncheck:add-arrow : symbol text number number text number number -> void
+              ;; pre: start-editor, end-editor are embedded in `this' (or are `this')
+              (define/public (syncheck:add-arrow start-text start-pos-left start-pos-right
+                                                 end-text end-pos-left end-pos-right)
+                (let* ([arrow (make-var-arrow #f #f #f #f
+                                              start-text start-pos-left start-pos-right
+                                              end-text end-pos-left end-pos-right)])
+                  (when (add-to-bindings-table
+                         start-text start-pos-left start-pos-right
+                         end-text end-pos-left end-pos-right)
+                    (add-to-range/key start-text start-pos-left start-pos-right arrow #f #f)
+                    (add-to-range/key end-text end-pos-left end-pos-right arrow #f #f))))
+              
+              ;; syncheck:add-tail-arrow : text number text number -> void
+              (define/public (syncheck:add-tail-arrow from-text from-pos to-text to-pos)
+                (let ([tail-arrow (make-tail-arrow #f #f #f #f to-text to-pos from-text from-pos)])
+                  (add-to-range/key from-text from-pos (+ from-pos 1) tail-arrow #f #f)
+                  (add-to-range/key from-text to-pos (+ to-pos 1) tail-arrow #f #f)))
+              
+              ;; syncheck:add-jump-to-definition : text start end id filename -> void
+              (define/public (syncheck:add-jump-to-definition text start end id filename)
+                (add-to-range/key text start end (make-def-link id filename) #f #f))
+              
+              ;; syncheck:add-mouse-over-status : text pos-left pos-right string -> void
+              (define/public (syncheck:add-mouse-over-status text pos-left pos-right str)
+                (add-to-range/key text pos-left pos-right str #f #f))
+
+              ;; add-to-range/key : text number number any any boolean -> void
+              ;; adds `key' to the range `start' - `end' in the editor
+              ;; If use-key? is #t, it adds `to-add' with the key, and does not
+              ;; replace a value with that key already there.
+              ;; If use-key? is #f, it adds `to-add' without a key.
+              ;; pre: arrow-vectors is not #f
+              (define/private (add-to-range/key text start end to-add key use-key?)
+                (let ([arrow-vector (hash-table-get 
+                                     arrow-vectors
+                                     text 
+                                     (λ ()
+                                       (let ([new-vec 
+                                              (make-vector
+                                               (add1 (send text last-position))
+                                               null)])
+                                         (hash-table-put! 
+                                          arrow-vectors 
+                                          text
+                                          new-vec)
+                                         new-vec)))])
+                  (let loop ([p start])
+                    (when (<= p end)
+                      (let ([r (vector-ref arrow-vector p)])
+                        (cond
+                          [use-key?
+                           (unless (ormap (λ (x) 
+                                            (and (pair? x) 
+                                                 (car x)
+                                                 (eq? (car x) key)))
+                                          r)
+                             (vector-set! arrow-vector p (cons (cons key to-add) r)))]
+                          [else
+                           (vector-set! arrow-vector p (cons to-add r))]))
+                      (loop (add1 p))))))
+
+              (inherit get-top-level-window)
+
+              (define/augment (on-change)
+                (inner (void) on-change)
+                (when arrow-vectors
+                  (flush-arrow-coordinates-cache)
+                  (let ([any-tacked? #f])
+                    (when tacked-hash-table
+                      (let/ec k
+                        (hash-table-for-each
+                         tacked-hash-table
+                         (λ (key val)
+                           (set! any-tacked? #t)
+                           (k (void))))))
+                    (when any-tacked?
+                      (invalidate-bitmap-cache)))))
+              
+              ;; flush-arrow-coordinates-cache : -> void
+              ;; pre-condition: arrow-vector is not #f.
+              (define/private (flush-arrow-coordinates-cache)
+                (hash-table-for-each
+                 arrow-vectors
+                 (λ (text arrow-vector)
+                   (let loop ([n (vector-length arrow-vector)])
+                     (unless (zero? n)
+                       (let ([eles (vector-ref arrow-vector (- n 1))])
+                         (for-each (λ (ele)
+                                     (cond
+                                       [(arrow? ele)
+                                        (set-arrow-start-x! ele #f)
+                                        (set-arrow-start-y! ele #f)
+                                        (set-arrow-end-x! ele #f)
+                                        (set-arrow-end-y! ele #f)]))
+                                   eles))
+                       (loop (- n 1)))))))
+              
+              (define/override (on-paint before dc left top right bottom dx dy draw-caret)
+                (super on-paint before dc left top right bottom dx dy draw-caret)
+                (when (and arrow-vectors (not before))
+                  (let ([draw-arrow2
+                         (λ (arrow)
+                           (unless (arrow-start-x arrow)
+                             (update-arrow-poss arrow))
+                           (let ([start-x (arrow-start-x arrow)]
+                                 [start-y (arrow-start-y arrow)]
+                                 [end-x   (arrow-end-x arrow)]
+                                 [end-y   (arrow-end-y arrow)])
+                             (unless (and (= start-x end-x)
+                                          (= start-y end-y))
+                               (drscheme:arrow:draw-arrow dc start-x start-y end-x end-y dx dy))))]
+                        [old-brush (send dc get-brush)]
+                        [old-pen   (send dc get-pen)])
+                    (hash-table-for-each tacked-hash-table
+                                         (λ (arrow v) 
+                                           (when v 
+                                             (cond
+                                               [(var-arrow? arrow)
+                                                (send dc set-pen var-pen)
+                                                (send dc set-brush tacked-var-brush)]
+                                               [(tail-arrow? arrow)
+                                                (send dc set-pen tail-pen)
+                                                (send dc set-brush tacked-tail-brush)])
+                                             (draw-arrow2 arrow))))
+                    (when (and cursor-location
+                               cursor-text)
+                      (let* ([arrow-vector (hash-table-get arrow-vectors cursor-text (λ () #f))])
+                        (when arrow-vector
+                          (let ([eles (vector-ref arrow-vector cursor-location)])
+                            (for-each (λ (ele) 
+                                        (cond
+                                          [(var-arrow? ele)
+                                           (send dc set-pen var-pen)
+                                           (send dc set-brush untacked-brush)
+                                           (draw-arrow2 ele)]
+                                          [(tail-arrow? ele)
+                                           (send dc set-pen tail-pen)
+                                           (send dc set-brush untacked-brush)
+                                           (for-each-tail-arrows draw-arrow2 ele)]))
+                                      eles)))))
+                    (send dc set-brush old-brush)
+                    (send dc set-pen old-pen))))
+              
+              ;; for-each-tail-arrows : (tail-arrow -> void) tail-arrow -> void
+              (define/private (for-each-tail-arrows f tail-arrow)
+                ;; call-f-ht ensures that `f' is only called once per arrow
+                (define call-f-ht (make-hash-table))
+
+                (define (for-each-tail-arrows/to/from tail-arrow-pos tail-arrow-text
+                                                      tail-arrow-other-pos tail-arrow-other-text)
+
+                  ;; traversal-ht ensures that we don't loop in the arrow traversal.
+                  (let ([traversal-ht (make-hash-table)])
+                    (let loop ([tail-arrow tail-arrow])
+                      (unless (hash-table-get traversal-ht tail-arrow (λ () #f))
+                        (hash-table-put! traversal-ht tail-arrow #t)
+                        (unless (hash-table-get call-f-ht tail-arrow (λ () #f))
+                          (hash-table-put! call-f-ht tail-arrow #t)
+                          (f tail-arrow))
+                        (let* ([next-pos (tail-arrow-pos tail-arrow)]
+                               [next-text (tail-arrow-text tail-arrow)]
+                               [arrow-vector (hash-table-get arrow-vectors next-text (λ () #f))])
+                          (when arrow-vector
+                            (let ([eles (vector-ref arrow-vector next-pos)])
+                              (for-each (λ (ele) 
+                                          (cond
+                                            [(tail-arrow? ele)
+                                             (let ([other-pos (tail-arrow-other-pos ele)]
+                                                   [other-text (tail-arrow-other-text ele)])
+                                               (when (and (= other-pos next-pos)
+                                                          (eq? other-text next-text))
+                                                 (loop ele)))]))
+                                        eles))))))))
+                
+                (for-each-tail-arrows/to/from tail-arrow-to-pos tail-arrow-to-text
+                                              tail-arrow-from-pos tail-arrow-from-text)
+                (for-each-tail-arrows/to/from tail-arrow-from-pos tail-arrow-from-text
+                                              tail-arrow-to-pos tail-arrow-to-text))
+              
+              ;; get-pos/text : event -> (values (union #f text%) (union number #f))
+              ;; returns two #fs to indicate the event doesn't correspond to
+              ;; a position in an editor, or returns the innermost text
+              ;; and position in that text where the event is.
+              (define/private (get-pos/text event)
+                (let ([event-x (send event get-x)]
+                      [event-y (send event get-y)]
+                      [on-it? (box #f)])
+                  (let loop ([editor this])
+                    (let-values ([(x y) (send editor dc-location-to-editor-location event-x event-y)])
+                      (cond
+                        [(is-a? editor text%)
+                         (let ([pos (send editor find-position x y #f on-it?)])
+                           (cond
+                             [(not (unbox on-it?)) (values #f #f)]
+                             [else
+                              (let ([snip (send editor find-snip pos 'after-or-none)])
+                                (if (and snip
+                                         (is-a? snip editor-snip%))
+                                    (loop (send snip get-editor))
+                                    (values pos editor)))]))]
+                        [(is-a? editor pasteboard%)
+                         (let ([snip (send editor find-snip x y)])
+                           (if (and snip
+                                    (is-a? snip editor-snip%))
+                               (loop (send snip get-editor))
+                               (values #f #f)))]
+                        [else (values #f #f)])))))
+              
+            (define/override (on-event event)
+              (if arrow-vectors
+                  (cond
+                    [(send event leaving?)
+                     (when (and cursor-location cursor-text)
+                       (set! cursor-location #f)
+                       (set! cursor-text #f)
+                       (let ([f (get-top-level-window)])
+                         (when f
+                           (send f update-status-line 'drscheme:check-syntax:mouse-over #f)))
+                       (invalidate-bitmap-cache))
+                     (super on-event event)]
+                    [(or (send event moving?)
+                         (send event entering?))
+                     (let-values ([(pos text) (get-pos/text event)])
+                       (cond
+                         [(and pos text)
+                          (unless (and (equal? pos cursor-location)
+                                       (eq? cursor-text text))
+                            (set! cursor-location pos)
+                            (set! cursor-text text)
+                            
+                            (let* ([arrow-vector (hash-table-get arrow-vectors cursor-text (λ () #f))]
+                                   [eles (and arrow-vector (vector-ref arrow-vector cursor-location))])
+                              (when eles
+                                (let ([has-txt? #f])
+                                  (for-each (λ (ele)
+                                              (cond
+                                                [(string? ele)
+                                                 (set! has-txt? #t)
+                                                 (let ([f (get-top-level-window)])
+                                                   (when f
+                                                     (send f update-status-line 
+                                                           'drscheme:check-syntax:mouse-over 
+                                                           ele)))]))
+                                            eles)
+                                  (unless has-txt?
+                                    (let ([f (get-top-level-window)])
+                                      (when f
+                                        (send f update-status-line 'drscheme:check-syntax:mouse-over #f))))))
+                              
+                              (when eles
+                                (for-each (λ (ele)
+                                            (cond
+                                              [(arrow? ele)
+                                               (update-arrow-poss ele)]))
+                                          eles)
+                                (invalidate-bitmap-cache))))]
+                         [else
+                          (let ([f (get-top-level-window)])
+                            (when f
+                              (send f update-status-line 'drscheme:check-syntax:mouse-over #f)))
+                          (when (or cursor-location cursor-text)
+                            (set! cursor-location #f)
+                            (set! cursor-text #f)
+                            (invalidate-bitmap-cache))]))
+                     (super on-event event)]
+                    [(send event button-down? 'right)
+                     (let-values ([(pos text) (get-pos/text event)])
+                       (if (and pos text)
+                           (let ([arrow-vector (hash-table-get arrow-vectors text (λ () #f))])
+                             (when arrow-vector
+                               (let ([vec-ents (vector-ref arrow-vector pos)])
+                                 (cond
+                                   [(null? vec-ents)
+                                    (super on-event event)]
+                                   [else
+                                    (let* ([menu (make-object popup-menu% #f)]
+                                           [arrows (filter arrow? vec-ents)]
+                                           [def-links (filter def-link? vec-ents)]
+                                           [var-arrows (filter var-arrow? arrows)]
+                                           [add-menus (map cdr (filter cons? vec-ents))])
+                                      (unless (null? arrows)
+                                        (make-object menu-item%
+                                          (string-constant cs-tack/untack-arrow)
+                                          menu
+                                          (λ (item evt) (tack/untack-callback arrows))))
+                                      (unless (null? def-links)
+                                        (let ([def-link (car def-links)])
+                                          (make-object menu-item%
+                                            jump-to-definition
+                                            menu
+                                            (λ (item evt)
+                                              (jump-to-definition-callback def-link)))))
+                                      (unless (null? var-arrows)
+                                        (make-object menu-item%
+                                          jump-to-next-bound-occurrence
+                                          menu
+                                          (λ (item evt) (jump-to-next-callback pos text arrows)))
+                                        (make-object menu-item%
+                                          jump-to-binding
+                                          menu
+                                          (λ (item evt) (jump-to-binding-callback arrows))))
+                                      (for-each (λ (f) (f menu)) add-menus)
+                                      (send (get-canvas) popup-menu menu
+                                            (+ 1 (inexact->exact (floor (send event get-x))))
+                                            (+ 1 (inexact->exact (floor (send event get-y))))))]))))
+                           (super on-event event)))]
+                    [else (super on-event event)])
+                  (super on-event event)))
+
+              ;; tack/untack-callback : (listof arrow) -> void
+              ;; callback for the tack/untack menu item
+              (define/private (tack/untack-callback arrows)
+                (let ([arrow-tacked?
+                       (λ (arrow)
+                         (hash-table-get
+                          tacked-hash-table
+                          arrow
+                          (λ () #f)))]
+                      [untack-arrows? #f])
+                  (for-each 
+                   (λ (arrow)
+                     (cond
+                       [(var-arrow? arrow)
+                        (set! untack-arrows? (or untack-arrows? (arrow-tacked? arrow)))]
+                       [(tail-arrow? arrow)
+                        (for-each-tail-arrows
+                         (λ (arrow) (set! untack-arrows? (or untack-arrows? (arrow-tacked? arrow))))
+                         arrow)]))
+                   arrows)
+                  (for-each 
+                   (λ (arrow)
+                     (cond
+                       [(var-arrow? arrow)
+                        (hash-table-put! tacked-hash-table arrow (not untack-arrows?))]
+                       [(tail-arrow? arrow)
+                        (for-each-tail-arrows
+                         (λ (arrow) 
+                           (hash-table-put! tacked-hash-table arrow (not untack-arrows?)))
+                         arrow)]))
+                   arrows))
+                (invalidate-bitmap-cache))
+              
+              ;; syncheck:jump-to-binding-occurrence : text -> void
+              ;; jumps to the next occurrence, based on the insertion point
+              (define/public (syncheck:jump-to-next-bound-occurrence text)
+                (jump-to-binding/bound-helper 
+                 text 
+                 (λ (pos text vec-ents)
+                   (jump-to-next-callback pos text vec-ents))))
+              
+              ;; syncheck:jump-to-binding-occurrence : text -> void
+              (define/public (syncheck:jump-to-binding-occurrence text)
+                (jump-to-binding/bound-helper 
+                 text 
+                 (λ (pos text vec-ents)
+                   (jump-to-binding-callback vec-ents))))
+              
+              (define/private (jump-to-binding/bound-helper text do-jump)
+                (let ([pos (send text get-start-position)])
+                  (when arrow-vectors
+                    (let ([arrow-vector (hash-table-get arrow-vectors text (λ () #f))])
+                      (when arrow-vector
+                        (let ([vec-ents (filter var-arrow? (vector-ref arrow-vector pos))])
+                          (unless (null? vec-ents)
+                            (do-jump pos text vec-ents))))))))
+              
+              ;; jump-to-next-callback : (listof arrow) -> void
+              ;; callback for the jump popup menu item
+              (define/private (jump-to-next-callback pos txt input-arrows)
+                (unless (null? input-arrows)
+                  (let* ([arrow-key (car input-arrows)]
+                         [orig-arrows (hash-table-get bindings-table
+                                                      (list (var-arrow-start-text arrow-key)
+                                                            (var-arrow-start-pos-left arrow-key)
+                                                            (var-arrow-start-pos-right arrow-key))
+                                                      (λ () '()))])
+                    (cond
+                      [(null? orig-arrows) (void)]
+                      [(null? (cdr orig-arrows)) (jump-to (car orig-arrows))]
+                      [else
+                       (let loop ([arrows orig-arrows])
+                         (cond
+                           [(null? arrows) (jump-to (car orig-arrows))]
+                           [else (let ([arrow (car arrows)])
+                                   (cond
+                                     [(and (object=? txt (first arrow))
+                                           (<= (second arrow) pos (third arrow)))
+                                      (jump-to (if (null? (cdr arrows))
+                                                   (car orig-arrows)
+                                                   (cadr arrows)))]
+                                     [else (loop (cdr arrows))]))]))]))))
+              
+              ;; jump-to : (list text number number) -> void
+              (define/private (jump-to to-arrow)
+                (let ([end-text (first to-arrow)]
+                      [end-pos-left (second to-arrow)]
+                      [end-pos-right (third to-arrow)])
+                  (send end-text set-position end-pos-left end-pos-right)
+                  (send end-text set-caret-owner #f 'global)))
+              
+              ;; jump-to-binding-callback : (listof arrow) -> void
+              ;; callback for the jump popup menu item
+              (define/private (jump-to-binding-callback arrows)
+                (unless (null? arrows)
+                  (let* ([arrow (car arrows)]
+                         [start-text (var-arrow-start-text arrow)]
+                         [start-pos-left (var-arrow-start-pos-left arrow)]
+                         [start-pos-right (var-arrow-start-pos-right arrow)])
+                    (send start-text set-position start-pos-left start-pos-right)
+                    (send start-text set-caret-owner #f 'global))))
+
+              ;; syncheck:jump-to-definition : text -> void
+              (define/public (syncheck:jump-to-definition text)
+                (let ([pos (send text get-start-position)])
+                  (when arrow-vectors
+                    (let ([arrow-vector (hash-table-get arrow-vectors text (λ () #f))])
+                      (when arrow-vector
+                        (let ([vec-ents (filter def-link? (vector-ref arrow-vector pos))])
+                          (unless (null? vec-ents)
+                            (jump-to-definition-callback (car vec-ents)))))))))
+              
+              (define/private (jump-to-definition-callback def-link)
+                (let* ([filename (def-link-filename def-link)]
+                       [id-from-def (def-link-id def-link)]
+                       [frame (fw:handler:edit-file filename)])
+                  (when (is-a? frame syncheck-frame<%>)
+                    (send frame syncheck:button-callback id-from-def))))
+              
+              (super-new)))))
+      
+      (define syncheck-bitmap
+        (bitmap-label-maker
+         (string-constant check-syntax)
+         (build-path (collection-path "icons") "syncheck.png")))
+      
+      (define syncheck-frame<%>
+        (interface ()
+          syncheck:button-callback
+          syncheck:error-report-visible?))
+      
+      (define tab-mixin
+
+        (mixin (drscheme:unit:tab<%>) ()
+          (inherit is-current-tab? get-defs get-frame)
+          
+          (define report-error-text (new (fw:text:ports-mixin fw:scheme:text%)))
+          (define error-report-visible? #f)
+          (send report-error-text auto-wrap #t)
+          (send report-error-text set-autowrap-bitmap #f)
+          (send report-error-text lock #t)
+          
+          (define/public (get-error-report-text) report-error-text)
+          (define/public (get-error-report-visible?) error-report-visible?)
+          (define/public (turn-on-error-report) (set! error-report-visible? #t))
+          (define/augment (clear-annotations)
+            (inner (void) clear-annotations)
+            (syncheck:clear-error-message)
+            (syncheck:clear-highlighting))
+          
+          (define/public (syncheck:clear-error-message)
+            (set! error-report-visible? #f)
+            (send report-error-text clear-output-ports)
+            (send report-error-text lock #f)
+            (send report-error-text delete/io 0 (send report-error-text last-position))
+            (send report-error-text lock #t)
+            (when (is-current-tab?)
+              (send (get-frame) hide-error-report)))
+          
+          (define cleanup-texts '())
+          (define/public (syncheck:clear-highlighting)
+            (let* ([definitions (get-defs)]
+                   [locked? (send definitions is-locked?)])
+              (send definitions begin-edit-sequence #f)
+              (send definitions lock #f)
+              (send definitions syncheck:clear-arrows)
+              (for-each (λ (text) 
+                          (send text thaw-colorer))
+                        cleanup-texts)
+              (set! cleanup-texts '())
+              (send definitions lock locked?)
+              (send definitions end-edit-sequence)))
+        
+          (define/augment (can-close?)
+	    (and (send report-error-text can-close?)
+                 (inner #t can-close?)))
+          
+          (define/augment (on-close)
+	    (send report-error-text on-close)
+	    (inner (void) on-close))
+          
+          ;; syncheck:add-to-cleanup-texts : (is-a?/c text%) -> void
+          (define/public (syncheck:add-to-cleanup-texts txt)
+            (unless (memq txt cleanup-texts)
+              (send txt freeze-colorer)
+              (set! cleanup-texts (cons txt cleanup-texts))))
+          
+          (super-new)))
+      
+      (define unit-frame-mixin
+        (mixin (drscheme:unit:frame<%>) (syncheck-frame<%>)
+          
+          (inherit get-button-panel 
+                   get-definitions-canvas 
+                   get-definitions-text
+                   get-interactions-text
+                   get-current-tab)
+          
+          (define/augment (on-tab-change old-tab new-tab)
+            (inner (void) on-tab-change old-tab new-tab)
+            (if (send new-tab get-error-report-visible?)
+                (show-error-report)
+                (hide-error-report))
+            (send report-error-canvas set-editor (send new-tab get-error-report-text)))
+          
+          (define/augment (enable-evaluation)
+            (send check-syntax-button enable #t)
+            (inner (void) enable-evaluation))
+          
+          (define/augment (disable-evaluation)
+            (send check-syntax-button enable #f)
+            (inner (void) disable-evaluation))
+          
+          (define report-error-parent-panel 'uninitialized-report-error-parent-panel)
+          (define report-error-panel 'uninitialized-report-error-panel)
+          (define report-error-canvas 'uninitialized-report-error-editor-canvas)
+          (define/override (get-definitions/interactions-panel-parent)
+            (set! report-error-parent-panel
+                  (make-object vertical-panel%
+                    (super get-definitions/interactions-panel-parent)))
+            (set! report-error-panel (instantiate horizontal-panel% ()
+                                       (parent report-error-parent-panel)
+                                       (stretchable-height #f)
+                                       (alignment '(center center))
+                                       (style '(border))))
+            (send report-error-parent-panel change-children (λ (l) null))
+            (let ([message-panel (instantiate vertical-panel% ()
+                                   (parent report-error-panel)
+                                   (stretchable-width #f)
+                                   (stretchable-height #f)
+                                   (alignment '(left center)))])
+              (make-object message% (string-constant check-syntax) message-panel)
+              (make-object message% (string-constant cs-error-message) message-panel))
+            (set! report-error-canvas (new editor-canvas% 
+                                           (parent report-error-panel)
+                                           (editor (send (get-current-tab) get-error-report-text))
+                                           (line-count 3)
+                                           (style '(no-hscroll))))
+            (instantiate button% () 
+              (label (string-constant hide))
+              (parent report-error-panel)
+              (callback (λ (x y) (hide-error-report)))
+              (stretchable-height #t))
+            (make-object vertical-panel% report-error-parent-panel))
+          
+          (define/public-final (syncheck:error-report-visible?)
+            (and (is-a? report-error-parent-panel area-container<%>)
+                 (member report-error-panel (send report-error-parent-panel get-children))))
+          
+          (define/public (hide-error-report) 
+            (when (syncheck:error-report-visible?)
+              (send report-error-parent-panel change-children
+                    (λ (l) (remq report-error-panel l)))))
+          
+          (define/private (show-error-report)
+            (unless (syncheck:error-report-visible?)
+              (send report-error-parent-panel change-children
+                    (λ (l) (cons report-error-panel l)))))
+          
+          (define rest-panel 'uninitialized-root)
+          (define super-root 'uninitialized-super-root)
+          (define/override (make-root-area-container % parent)
+            (let* ([s-root (super make-root-area-container
+                            vertical-panel%
+                            parent)]
+                   [r-root (make-object % s-root)])
+              (set! super-root s-root)
+              (set! rest-panel r-root)
+              r-root))
+
+          (inherit open-status-line close-status-line update-status-line)
+          ;; syncheck:button-callback : (case-> (-> void) ((union #f syntax) -> void)
+          ;; this is the only function that has any code running on the user's thread
+          (define/public syncheck:button-callback
+            (case-lambda
+              [() (syncheck:button-callback #f)]
+              [(jump-to-id)
+               (when (send check-syntax-button is-enabled?)
+                 (open-status-line 'drscheme:check-syntax)
+                 (update-status-line 'drscheme:check-syntax status-init)
+                 (let-values ([(expanded-expression expansion-completed) (make-traversal)])
+                   (let* ([definitions-text (get-definitions-text)]
+                          [drs-eventspace (current-eventspace)]
+                          [the-tab (get-current-tab)])
+                     (let-values ([(old-break-thread old-custodian) (send the-tab get-breakables)])
+                       (let* ([user-namespace #f]
+                              [user-directory #f]
+                              [user-custodian #f]
+                              [normal-termination? #f]
+                              [cleanup
+                               (λ () ; =drs=
+                                 (send the-tab set-breakables old-break-thread old-custodian)
+                                 (send the-tab enable-evaluation)
+                                 (send definitions-text end-edit-sequence)
+                                 (close-status-line 'drscheme:check-syntax))]
+                              [kill-termination
+                               (λ ()
+                                 (unless normal-termination?
+                                   (parameterize ([current-eventspace drs-eventspace])
+                                     (queue-callback
+                                      (λ ()
+                                        (send the-tab syncheck:clear-highlighting)
+                                        (cleanup)
+                                        (custodian-shutdown-all user-custodian))))))]
+                              [error-display-semaphore (make-semaphore 0)]
+                              [uncaught-exception-raised
+                               (λ () ;; =user=
+                                 (set! normal-termination? #t)
+                                 (parameterize ([current-eventspace drs-eventspace])
+                                   (queue-callback
+                                    (λ () ;;  =drs=
+                                      (yield error-display-semaphore) ;; let error display go first
+                                      (send the-tab syncheck:clear-highlighting)
+                                      (cleanup)
+                                      (custodian-shutdown-all user-custodian)))))]
+                              [error-port (send (send the-tab get-error-report-text) get-err-port)]
+                              [init-proc
+                               (λ () ; =user=
+                                 (send the-tab set-breakables (current-thread) (current-custodian))
+                                 (set-directory definitions-text)
+                                 (error-display-handler 
+                                  (λ (msg exn) ;; =user=
+                                    (parameterize ([current-eventspace drs-eventspace])
+                                      (queue-callback
+                                       (λ () ;; =drs=
+                                         (send the-tab turn-on-error-report)
+                                         (when (eq? (get-current-tab) the-tab)
+                                           (show-error-report)))))
+                                    
+                                    (parameterize ([current-error-port error-port])
+                                      (drscheme:debug:show-error-and-highlight 
+                                       msg exn 
+                                       (λ (src-to-display cms) ;; =user=
+                                         (parameterize ([current-eventspace drs-eventspace])
+                                           (queue-callback
+                                            (λ () ;; =drs=
+                                              (send (send the-tab get-ints) highlight-errors src-to-display cms)))))))
+                                    
+                                    (semaphore-post error-display-semaphore)))
+                                 
+                                 (error-print-source-location #f) ; need to build code to render error first
+                                 (current-exception-handler
+                                  (let ([oh (current-exception-handler)])
+                                    (λ (exn)
+                                      (uncaught-exception-raised)
+                                      (oh exn))))
+                                 (update-status-line 'drscheme:check-syntax status-expanding-expression)
+                                 (set! user-custodian (current-custodian))
+                                 (set! user-directory (current-directory)) ;; set by set-directory above
+                                 (set! user-namespace (current-namespace)))])
+                         (send the-tab disable-evaluation) ;; this locks the editor, so must be outside.
+                         (send definitions-text begin-edit-sequence #f)
+                         (with-lock/edit-sequence
+                          definitions-text
+                          (λ ()
+                            (send the-tab clear-annotations)
+                            (send the-tab reset-offer-kill)
+                            (send (send the-tab get-defs) syncheck:init-arrows)
+                            
+                            (drscheme:eval:expand-program
+                             (drscheme:language:make-text/pos definitions-text
+                                                              0
+                                                              (send definitions-text last-position))
+                             (send definitions-text get-next-settings)
+                             #t
+                             init-proc
+                             kill-termination
+                             (λ (sexp loop) ; =user=
+                               (cond
+                                 [(eof-object? sexp)
+                                  (set! normal-termination? #t)
+                                  (parameterize ([current-eventspace drs-eventspace])
+                                    (queue-callback
+                                     (λ () ; =drs=
+                                       (with-lock/edit-sequence
+                                        definitions-text
+                                        (λ ()
+                                          (expansion-completed user-namespace user-directory)
+                                          (send definitions-text syncheck:sort-bindings-table)))
+                                       (cleanup)
+                                       (custodian-shutdown-all user-custodian))))]
+                                 [else
+                                  (update-status-line 'drscheme:check-syntax status-eval-compile-time)
+                                  (eval-compile-time-part-of-top-level sexp)
+                                  (parameterize ([current-eventspace drs-eventspace])
+                                    (queue-callback
+                                     (λ () ; =drs=
+                                       (with-lock/edit-sequence
+                                        definitions-text
+                                        (λ ()
+                                          (open-status-line 'drscheme:check-syntax)
+                                          (update-status-line 'drscheme:check-syntax status-coloring-program)
+                                          (expanded-expression user-namespace user-directory sexp jump-to-id)
+                                          (close-status-line 'drscheme:check-syntax))))))
+                                  (update-status-line 'drscheme:check-syntax status-expanding-expression)
+                                  (loop)]))))))))))]))
+
+          ;; set-directory : text -> void
+          ;; sets the current-directory and current-load-relative-directory
+          ;; based on the file saved in the definitions-text
+          (define/private (set-directory definitions-text)
+            (let* ([tmp-b (box #f)]
+                   [fn (send definitions-text get-filename tmp-b)])
+              (unless (unbox tmp-b)
+                (when fn
+                  (let-values ([(base name dir?) (split-path fn)])
+                    (current-directory base)
+                    (current-load-relative-directory base))))))
+          
+          ;; with-lock/edit-sequence : text (-> void) -> void
+          ;; sets and restores some state of the definitions text
+          ;; so that edits to the definitions text work out.
+          (define/private (with-lock/edit-sequence definitions-text thnk)
+            (let* ([locked? (send definitions-text is-locked?)])
+              (send definitions-text begin-edit-sequence)
+              (send definitions-text lock #f)
+              (thnk)
+              (send definitions-text end-edit-sequence)
+              (send definitions-text lock locked?)))
+          
+          (super-new)
+          
+          (define check-syntax-button
+            (new button%
+                 (label (syncheck-bitmap this))
+                 (parent (get-button-panel))
+                 (callback (λ (button evt) (syncheck:button-callback)))))
+          (define/public (syncheck:get-button) check-syntax-button)
+          (send (get-button-panel) change-children
+                (λ (l)
+                  (cons check-syntax-button
+                        (remove check-syntax-button l))))))
+      
+      (define report-error-style (make-object style-delta% 'change-style 'slant))
+      (send report-error-style set-delta-foreground "red")
+      
+      (define (add-check-syntax-key-bindings keymap)
+        (send keymap add-function
+              "check syntax"
+              (λ (obj evt)
+                (when (is-a? obj editor<%>)
+                  (let ([canvas (send obj get-canvas)])
+                    (when canvas
+                      (let ([frame (send canvas get-top-level-window)])
+                        (when (is-a? frame syncheck-frame<%>)
+                          (send frame syncheck:button-callback))))))))
+        
+        (let ([jump-callback
+               (λ (send-msg)
+                 (λ (obj evt)
+                   (when (is-a? obj text%)
+                     (let ([canvas (send obj get-canvas)])
+                       (when canvas
+                         (let ([frame (send canvas get-top-level-window)])
+                           (when (is-a? frame syncheck-frame<%>)
+                             (let ([defs (send frame get-definitions-text)])
+                               (when (is-a? defs syncheck-text<%>)
+                                 (send-msg defs obj))))))))))])
+          (send keymap add-function
+                "jump to binding occurrence"
+                (jump-callback (λ (defs obj) (send defs syncheck:jump-to-binding-occurrence obj))))
+          (send keymap add-function
+                "jump to next bound occurrence"
+                (jump-callback (λ (defs obj) (send defs syncheck:jump-to-next-bound-occurrence obj))))
+          (send keymap add-function
+                "jump to definition (in other file)"
+                (jump-callback (λ (defs obj) (send defs syncheck:jump-to-definition obj)))))
+        
+        (send keymap map-function "f6" "check syntax")
+        (send keymap map-function "c:c;c:c" "check syntax")
+        (send keymap map-function "c:x;b" "jump to binding occurrence")
+        (send keymap map-function "c:x;n" "jump to next bound occurrence")
+        (send keymap map-function "c:x;d" "jump to definition (in other file)"))
+
+      (define lexically-bound-variable-style-pref 'drscheme:check-syntax:lexically-bound-identifier)
+      (define imported-variable-style-pref 'drscheme:check-syntax:imported-identifier)
+      
+      (define lexically-bound-variable-style-name (symbol->string lexically-bound-variable-style-pref))
+      (define imported-variable-style-name (symbol->string imported-variable-style-pref))
+
+      (define error-style-name (fw:scheme:short-sym->style-name 'error))
+      ;(define constant-style-name (fw:scheme:short-sym->style-name 'constant))
+      
+      (define (syncheck-add-to-preferences-panel parent)
+        (fw:color-prefs:build-color-selection-panel parent
+                                                    lexically-bound-variable-style-pref
+                                                    lexically-bound-variable-style-name
+                                                    (string-constant cs-lexical-variable))
+        (fw:color-prefs:build-color-selection-panel parent
+                                                    imported-variable-style-pref
+                                                    imported-variable-style-name
+                                                    (string-constant cs-imported-variable)))
+      
+      (fw:color-prefs:register-color-pref lexically-bound-variable-style-pref
+                                          lexically-bound-variable-style-name
+                                          (make-object color% 81 112 203))
+      (fw:color-prefs:register-color-pref imported-variable-style-pref
+                                          imported-variable-style-name
+                                          (make-object color% 68 0 203))
+
+
+                                          
+                                          
+
+;                                                                                                             
+;                                                                                                             
+;                                                                                                             
+;                                                                                                   ;         
+;                                                                                                   ;         
+;                         ;                       ;                                                 ;         
+;    ;;;  ;     ; ; ;;   ;;;;  ;;;   ;     ;     ;;;;  ; ;  ;;;   ;     ;  ;;;   ; ;   ;;;   ;;;    ;    ;;;  
+;   ;     ;     ; ;;  ;   ;   ;   ;   ;   ;       ;    ;;  ;   ;   ;   ;  ;   ;  ;;   ;     ;   ;   ;   ;     
+;   ;;     ;   ;  ;   ;   ;       ;    ; ;        ;    ;       ;   ;   ; ;    ;  ;    ;;        ;   ;   ;;    
+;    ;;    ;   ;  ;   ;   ;    ;;;;     ;         ;    ;    ;;;;    ; ;  ;;;;;;  ;     ;;    ;;;;   ;    ;;   
+;      ;    ; ;   ;   ;   ;   ;   ;    ; ;        ;    ;   ;   ;    ; ;  ;       ;       ;  ;   ;   ;      ;  
+;      ;    ; ;   ;   ;   ;   ;   ;   ;   ;       ;    ;   ;   ;     ;    ;      ;       ;  ;   ;   ;      ;  
+;   ;;;      ;    ;   ;    ;;  ;;;;; ;     ;       ;;  ;    ;;;;;    ;     ;;;;  ;    ;;;    ;;;;;  ;   ;;;   
+;            ;                                                                                                
+;            ;                                                                                                
+;           ;                                                                                                 
+                                                       
+                                                                      
+
+      ;; make-traversal : -> (values (namespace syntax (union #f syntax) -> void)
+      ;;                             (namespace string[directory] -> void))
+      ;; returns a pair of functions that close over some state that
+      ;; represents the top-level of a single program. The first value
+      ;; is called once for each top-level expression and the second
+      ;; value is called once, after all expansion is complete.
+      (define (make-traversal)
+        (let* ([tl-binders (make-id-set)]
+               [tl-varrefs (make-id-set)]
+               [tl-high-varrefs (make-id-set)]
+               [tl-tops (make-id-set)]
+               [tl-requires (make-hash-table 'equal)]
+               [tl-require-for-syntaxes (make-hash-table 'equal)]
+               [expanded-expression
+                (λ (user-namespace user-directory sexp jump-to-id)
+                  (parameterize ([current-load-relative-directory user-directory])
+                    (let ([is-module? (syntax-case sexp (module)
+                                        [(module . rest) #t]
+                                        [else #f])])
+                      (cond
+                        [is-module?
+                         (let ([binders (make-id-set)]
+                               [varrefs (make-id-set)]
+                               [high-varrefs (make-id-set)]
+                               [tops (make-id-set)]
+                               [requires (make-hash-table 'equal)]
+                               [require-for-syntaxes (make-hash-table 'equal)])
+                           (annotate-basic sexp user-namespace user-directory jump-to-id
+                                           binders varrefs high-varrefs tops
+                                           requires require-for-syntaxes) 
+                           (annotate-variables user-namespace
+                                               user-directory
+                                               binders
+                                               varrefs
+                                               high-varrefs
+                                               tops
+                                               requires
+                                               require-for-syntaxes))]
+                        [else
+                         (annotate-basic sexp user-namespace user-directory jump-to-id
+                                         tl-binders tl-varrefs tl-high-varrefs tl-tops 
+                                         tl-requires tl-require-for-syntaxes)]))))]
+               [expansion-completed
+                (λ (user-namespace user-directory)
+                  (parameterize ([current-load-relative-directory user-directory])
+                    (annotate-variables user-namespace
+                                        user-directory
+                                        tl-binders
+                                        tl-varrefs
+                                        tl-high-varrefs
+                                        tl-tops
+                                        tl-requires
+                                        tl-require-for-syntaxes)))])
+          (values expanded-expression expansion-completed)))
+      
+      
+      ;; type req/tag = (make-req/tag syntax sexp boolean)
+      (define-struct req/tag (req-stx req-sexp used?))
+      
+      ;; annotate-basic : syntax 
+      ;;                  namespace
+      ;;                  string[directory]
+      ;;                  syntax[id]
+      ;;                  id-set (four of them)
+      ;;                  hash-table[require-spec -> syntax] (two of them)
+      ;;               -> void
+      (define (annotate-basic sexp user-namespace user-directory jump-to-id
+                              binders low-varrefs high-varrefs tops
+                              requires require-for-syntaxes)
+        (let ([tail-ht (make-hash-table)]
+              [maybe-jump
+               (λ (vars)
+                 (when jump-to-id
+                   (for-each (λ (id)
+                               (let ([binding (identifier-binding id)])
+                                 (when (pair? binding)
+                                   (let ([nominal-source-id (list-ref binding 3)])
+                                     (when (eq? nominal-source-id jump-to-id)
+                                       (jump-to id))))))
+                             (syntax->list vars))))])
+                 
+          (let level-loop ([sexp sexp]
+                           [high-level? #f])
+            (let* ([loop (λ (sexp) (level-loop sexp high-level?))]
+                   [varrefs (if high-level? high-varrefs low-varrefs)]
+                   [collect-general-info
+                    (λ (stx)
+                      (add-origins stx varrefs)
+                      (add-disappeared-bindings stx binders varrefs)
+                      (add-disappeared-uses stx varrefs))])
+              (collect-general-info sexp)
+              (syntax-case* sexp (lambda case-lambda if begin begin0 let-values letrec-values set!
+                                   quote quote-syntax with-continuation-mark 
+                                   #%app #%datum #%top #%plain-module-begin
+                                   define-values define-syntaxes module
+                                   require require-for-syntax provide)
+                (if high-level? module-transformer-identifier=? module-identifier=?)
+                [(lambda args bodies ...)
+                 (begin
+                   (annotate-raw-keyword sexp varrefs)
+                   (annotate-tail-position/last sexp (syntax->list (syntax (bodies ...))) tail-ht)
+                   (add-binders (syntax args) binders)
+                   (for-each loop (syntax->list (syntax (bodies ...)))))]
+                [(case-lambda [argss bodiess ...]...)
+                 (begin
+                   (annotate-raw-keyword sexp varrefs)
+                   (for-each (λ (bodies/stx) (annotate-tail-position/last sexp 
+                                                                               (syntax->list bodies/stx)
+                                                                               tail-ht))
+                             (syntax->list (syntax ((bodiess ...) ...))))
+                   (for-each
+                    (λ (args bodies)
+                      (add-binders args binders)
+                      (for-each loop (syntax->list bodies)))
+                    (syntax->list (syntax (argss ...)))
+                    (syntax->list (syntax ((bodiess ...) ...)))))]
+                [(if test then else)
+                 (begin
+                   (annotate-raw-keyword sexp varrefs)
+                   (annotate-tail-position sexp (syntax then) tail-ht)
+                   (annotate-tail-position sexp (syntax else) tail-ht)
+                   (loop (syntax test))
+                   (loop (syntax else))
+                   (loop (syntax then)))]
+                [(if test then)
+                 (begin
+                   (annotate-raw-keyword sexp varrefs)
+                   (annotate-tail-position sexp (syntax then) tail-ht)
+                   (loop (syntax test))
+                   (loop (syntax then)))]
+                [(begin bodies ...)
+                 (begin
+                   (annotate-raw-keyword sexp varrefs)
+                   (annotate-tail-position/last sexp (syntax->list (syntax (bodies ...))) tail-ht)
+                   (for-each loop (syntax->list (syntax (bodies ...)))))]
+                
+                ;; treat a single body expression specially, since this has
+                ;; different tail behavior.
+                [(begin0 body)
+                 (begin
+                   (annotate-raw-keyword sexp varrefs)
+                   (annotate-tail-position sexp (syntax body) tail-ht)
+                   (loop (syntax body)))]
+                
+                [(begin0 bodies ...)
+                 (begin
+                   (annotate-raw-keyword sexp varrefs)
+                   (for-each loop (syntax->list (syntax (bodies ...)))))]
+                
+                [(let-values (bindings ...) bs ...)
+                 (begin
+                   (annotate-raw-keyword sexp varrefs)
+                   (for-each collect-general-info (syntax->list (syntax (bindings ...))))
+                   (annotate-tail-position/last sexp (syntax->list (syntax (bs ...))) tail-ht)
+                   (with-syntax ([(((xss ...) es) ...) (syntax (bindings ...))])
+                     (for-each (λ (x) (add-binders x binders))
+                               (syntax->list (syntax ((xss ...) ...))))
+                     (for-each loop (syntax->list (syntax (es ...))))
+                     (for-each loop (syntax->list (syntax (bs ...))))))]
+                [(letrec-values (bindings ...) bs ...)
+                 (begin
+                   (annotate-raw-keyword sexp varrefs)
+                   (for-each collect-general-info (syntax->list (syntax (bindings ...))))
+                   (annotate-tail-position/last sexp (syntax->list (syntax (bs ...))) tail-ht)
+                   (with-syntax ([(((xss ...) es) ...) (syntax (bindings ...))])
+                     (for-each (λ (x) (add-binders x binders))
+                               (syntax->list (syntax ((xss ...) ...))))
+                     (for-each loop (syntax->list (syntax (es ...))))
+                     (for-each loop (syntax->list (syntax (bs ...))))))]
+                [(set! var e)
+                 (begin
+                   (annotate-raw-keyword sexp varrefs)
+                   
+                   ;; tops are used here because a binding free use of a set!'d variable
+                   ;; is treated just the same as (#%top . x).
+                   (if (identifier-binding (syntax var))
+                       (add-id (if high-level? high-varrefs varrefs) (syntax var))
+                       (add-id tops (syntax var)))
+                   
+                   (loop (syntax e)))]
+                [(quote datum)
+                 ;(color-internal-structure (syntax datum) constant-style-name)
+                 (annotate-raw-keyword sexp varrefs)]
+                [(quote-syntax datum)
+                 ;(color-internal-structure (syntax datum) constant-style-name)
+                 (annotate-raw-keyword sexp varrefs)]
+                [(with-continuation-mark a b c)
+                 (begin
+                   (annotate-raw-keyword sexp varrefs)
+                   (annotate-tail-position sexp (syntax c) tail-ht)
+                   (loop (syntax a))
+                   (loop (syntax b))
+                   (loop (syntax c)))]
+                [(#%app pieces ...)
+                 (begin
+                   (annotate-raw-keyword sexp varrefs)
+                   (for-each loop (syntax->list (syntax (pieces ...)))))]
+                [(#%datum . datum)
+                   ;(color-internal-structure (syntax datum) constant-style-name)
+                   (annotate-raw-keyword sexp varrefs)]
+                [(#%top . var)
+                 (begin
+                   (annotate-raw-keyword sexp varrefs)
+                   (when (syntax-original? (syntax var))
+                     (add-id tops (syntax var))))]
+                [(define-values vars b)
+                 (begin
+                   (annotate-raw-keyword sexp varrefs)
+                   (add-binders (syntax vars) binders)
+                   (maybe-jump (syntax vars))
+                   (loop (syntax b)))]
+                [(define-syntaxes names exp)
+                 (begin
+                   (annotate-raw-keyword sexp varrefs)
+                   (add-binders (syntax names) binders)
+                   (maybe-jump (syntax names))
+                   (level-loop (syntax exp) #t))]
+                [(module m-name lang (#%plain-module-begin bodies ...))
+                 (begin
+                   (annotate-raw-keyword sexp varrefs)
+                   ((annotate-require-open user-namespace user-directory) (syntax lang))
+                   (hash-table-put! requires 
+                                    (syntax-object->datum (syntax lang))
+                                    (cons (syntax lang)
+                                          (hash-table-get requires 
+                                                          (syntax-object->datum (syntax lang))
+                                                          (λ () '()))))
+                   (for-each loop (syntax->list (syntax (bodies ...)))))]
+                
+                ; top level or module top level only:
+                [(require require-specs ...)
+                 (let ([new-specs (map trim-require-prefix
+                                       (syntax->list (syntax (require-specs ...))))])
+                   (annotate-raw-keyword sexp varrefs)
+                   (for-each (annotate-require-open user-namespace user-directory) new-specs)
+                   (for-each (add-require-spec requires)
+                             new-specs
+                             (syntax->list (syntax (require-specs ...)))))]
+                [(require-for-syntax require-specs ...)
+                 (let ([new-specs (map trim-require-prefix (syntax->list (syntax (require-specs ...))))])
+                   (annotate-raw-keyword sexp varrefs)
+                   (for-each (annotate-require-open user-namespace user-directory) new-specs)
+                   (for-each (add-require-spec require-for-syntaxes)
+                             new-specs
+                             (syntax->list (syntax (require-specs ...)))))]
+                
+                ; module top level only:
+                [(provide provide-specs ...)
+                 (let ([provided-varss (map extract-provided-vars
+                                            (syntax->list (syntax (provide-specs ...))))])
+                   (annotate-raw-keyword sexp varrefs)
+                   (for-each (λ (provided-vars)
+                               (for-each
+                                (λ (provided-var)
+                                  (add-id varrefs provided-var))
+                                provided-vars))
+                             provided-varss))]
+                [id
+                 (identifier? (syntax id))
+                 (when (syntax-original? sexp)
+                   (add-id varrefs sexp))]
+                [_
+                 (begin
+                   '(printf "unknown stx: ~e (datum: ~e) (source: ~e)~n"
+                            sexp
+                            (and (syntax? sexp)
+                                 (syntax-object->datum sexp))
+                            (and (syntax? sexp)
+                                 (syntax-source sexp)))
+                   (void))])))
+          (add-tail-ht-links tail-ht)))
+
+      ;; add-disappeared-bindings : syntax id-set -> void
+      (define (add-disappeared-bindings stx binders disappaeared-uses)
+        (let ([prop (syntax-property stx 'disappeared-binding)])
+          (when prop
+            (let loop ([prop prop])
+              (cond
+                [(pair? prop)
+                 (loop (car prop))
+                 (loop (cdr prop))]
+                [(identifier? prop)
+                 (add-origins prop disappaeared-uses)
+                 (add-id binders prop)])))))
+      
+      ;; add-disappeared-uses : syntax id-set -> void
+      (define (add-disappeared-uses stx id-set)
+        (let ([prop (syntax-property stx 'disappeared-use)])
+          (when prop
+            (let loop ([prop prop])
+              (cond
+                [(pair? prop)
+                 (loop (car prop))
+                 (loop (cdr prop))]
+                [(identifier? prop)
+                 (add-id id-set prop)])))))
+      
+      ;; add-require-spec : hash-table[sexp[require-spec] -o> (listof syntax)]
+      ;;                 -> sexp[require-spec]
+      ;;                    syntax
+      ;;                 -> void
+      (define (add-require-spec require-ht)
+        (λ (raw-spec syntax)
+          (when (syntax-original? syntax)
+            (hash-table-put! require-ht
+                             (syntax-object->datum raw-spec)
+                             (cons syntax
+                                   (hash-table-get require-ht
+                                                   (syntax-object->datum raw-spec)
+                                                   (λ () '())))))))
+      
+      ;; annotate-unused-require : syntax -> void
+      (define (annotate-unused-require req/tag)
+        (unless (req/tag-used? req/tag)
+          (color (req/tag-req-stx req/tag) error-style-name)))
+
+      ;; annotate-variables : namespace directory string id-set[four of them] (listof syntax) (listof syntax) -> void
+      ;; colors in and draws arrows for variables, according to their classifications
+      ;; in the various id-sets
+      (define (annotate-variables user-namespace
+                                  user-directory
+                                  binders
+                                  varrefs
+                                  high-varrefs
+                                  tops
+                                  requires
+                                  require-for-syntaxes)
+        
+        (let ([unused-requires (make-hash-table 'equal)]
+              [unused-require-for-syntaxes (make-hash-table 'equal)]
+              [id-sets (list binders varrefs high-varrefs tops)])
+          (hash-table-for-each requires (λ (k v) (hash-table-put! unused-requires k #t)))
+          (hash-table-for-each require-for-syntaxes (λ (k v) (hash-table-put! unused-require-for-syntaxes k #t)))
+          
+          (for-each (λ (vars) 
+                      (for-each (λ (var)
+                                  (when (syntax-original? var)
+                                    (color-variable var identifier-binding)
+                                    (make-rename-menu var id-sets)))
+                                vars))
+                    (get-idss binders))
+          
+          (for-each (λ (vars) (for-each 
+                                    (λ (var)
+                                      (color-variable var identifier-binding)
+                                      (connect-identifier var
+                                                          binders
+                                                          unused-requires
+                                                          requires
+                                                          identifier-binding
+                                                          id-sets
+                                                          user-namespace 
+                                                          user-directory))
+                                    vars))
+                    (get-idss varrefs))
+          
+          (for-each (λ (vars) (for-each 
+                                    (λ (var)
+                                      (color-variable var identifier-transformer-binding)
+                                      (connect-identifier var
+                                                          binders 
+                                                          unused-require-for-syntaxes
+                                                          require-for-syntaxes
+                                                          identifier-transformer-binding
+                                                          id-sets
+                                                          user-namespace 
+                                                          user-directory))
+                                    vars))
+                    (get-idss high-varrefs))
+          
+          (for-each 
+           (λ (vars) 
+             (for-each
+              (λ (var) 
+                (color/connect-top user-namespace user-directory binders var id-sets))
+              vars))
+           (get-idss tops))
+          
+          (color-unused require-for-syntaxes unused-require-for-syntaxes)
+          (color-unused requires unused-requires)))
+      
+      ;; color-unused : hash-table[sexp -o> syntax] hash-table[sexp -o> #f] -> void
+      (define (color-unused requires unused)
+        (hash-table-for-each
+         unused
+         (λ (k v)
+           (for-each (λ (stx) (color stx error-style-name))
+                     (hash-table-get requires k)))))
+      
+      ;; connect-identifier : syntax
+      ;;                      id-set 
+      ;;                      (union #f hash-table)
+      ;;                      (union #f hash-table)
+      ;;                      (union identifier-binding identifier-transformer-binding)
+      ;;                      (listof id-set)
+      ;;                      namespace
+      ;;                      directory
+      ;;                   -> void
+      ;; adds arrows and rename menus for binders/bindings
+      (define (connect-identifier var all-binders unused requires get-binding id-sets user-namespace user-directory)
+        (connect-identifier/arrow var all-binders unused requires get-binding user-namespace user-directory)
+        (when (get-ids all-binders var)
+          (make-rename-menu var id-sets)))
+      
+      ;; connect-identifier/arrow : syntax
+      ;;                            id-set 
+      ;;                            (union #f hash-table)
+      ;;                            (union #f hash-table)
+      ;;                            (union identifier-binding identifier-transformer-binding)
+      ;;                         -> void
+      ;; adds the arrows that correspond to binders/bindings
+      (define (connect-identifier/arrow var all-binders unused requires get-binding user-namespace user-directory)
+        (let ([binders (get-ids all-binders var)])
+          (when binders
+            (for-each (λ (x)
+                        (when (syntax-original? x)
+                          (connect-syntaxes x var)))
+                      binders))
+          
+          (when (and unused requires)
+            (let ([req-path/pr (get-module-req-path (get-binding var))])
+              (when req-path/pr
+                (let* ([req-path (car req-path/pr)]
+                       [id (cdr req-path/pr)]
+                       [req-stxes (hash-table-get requires req-path (λ () #f))])
+                  (when req-stxes
+                    (hash-table-remove! unused req-path)
+                    (for-each (λ (req-stx) 
+                                (when id
+                                  (add-jump-to-definition
+                                   var
+                                   id
+                                   (get-require-filename req-path user-namespace user-directory)))
+                                (add-mouse-over var (format (string-constant cs-mouse-over-import)
+                                                            (syntax-e var)
+                                                            req-path))
+                                (connect-syntaxes req-stx var))
+                              req-stxes))))))))
+          
+      ;; get-module-req-path : binding -> (union #f (cons require-sexp sym))
+      ;; argument is the result of identifier-binding or identifier-transformer-binding
+      (define (get-module-req-path binding)
+        (and (pair? binding)
+             (let ([mod-path (list-ref binding 2)])
+               (cond
+                 [(module-path-index? mod-path)
+                  (let-values ([(base offset) (module-path-index-split mod-path)])
+                    (cons base (list-ref binding 3)))]
+                 [(symbol? mod-path)
+                  (cons mod-path #f)]))))
+      
+      ;; color/connect-top : namespace directory id-set syntax -> void
+      (define (color/connect-top user-namespace user-directory binders var id-sets)
+        (let ([top-bound?
+               (or (get-ids binders var)
+                   (parameterize ([current-namespace user-namespace])
+                     (namespace-variable-value (syntax-e var) #t (λ () #f))))])
+          (if top-bound?
+              (color var lexically-bound-variable-style-name)
+              (color var error-style-name))
+          (connect-identifier var binders #f #f identifier-binding id-sets user-namespace user-directory)))
+      
+      ;; color-variable : syntax (union identifier-binding identifier-transformer-binding) -> void
+      (define (color-variable var get-binding)
+        (let* ([b (get-binding var)]
+               [lexical? 
+                (or (not b)
+                    (eq? b 'lexical)
+                    (and (pair? b)
+                         (let ([path (caddr b)])
+                           (and (module-path-index? path)
+                                (let-values ([(a b) (module-path-index-split path)])
+                                  (and (not a)
+                                       (not b)))))))])
+          (cond
+            [lexical? (color var lexically-bound-variable-style-name)]
+            [(pair? b) (color var imported-variable-style-name)])))
+      
+      ;; add-var : hash-table -> syntax -> void
+      ;; adds the variable to the hash table.
+      (define (add-var ht)
+        (λ (var)
+          (let* ([key (syntax-e var)]
+                 [prev (hash-table-get ht key (λ () null))])
+            (hash-table-put! ht key (cons var prev)))))
+
+      ;; connect-syntaxes : syntax[original] syntax[original] -> void
+      ;; adds an arrow from `from' to `to', unless they have the same source loc. 
+      (define (connect-syntaxes from to)
+        (let* ([from-source (syntax-source from)]
+	       [to-source (syntax-source to)])
+          (when (and (is-a? from-source text%)
+                     (is-a? to-source text%))
+            (let ([to-syncheck-text (find-syncheck-text to-source)]
+                  [from-syncheck-text (find-syncheck-text from-source)])
+              (when (and to-syncheck-text
+                         from-syncheck-text
+                         (eq? to-syncheck-text from-syncheck-text))
+                (let ([pos-from (syntax-position from)]
+                      [span-from (syntax-span from)]
+                      [pos-to (syntax-position to)]
+                      [span-to (syntax-span to)])
+                  (when (and pos-from span-from pos-to span-to)
+                        (let* ([from-pos-left (- (syntax-position from) 1)]
+                               [from-pos-right (+ from-pos-left (syntax-span from))]
+                               [to-pos-left (- (syntax-position to) 1)]
+                               [to-pos-right (+ to-pos-left (syntax-span to))])
+                          (unless (= from-pos-left to-pos-left)
+                            (send from-syncheck-text syncheck:add-arrow
+                                  from-source from-pos-left from-pos-right
+                                  to-source to-pos-left to-pos-right))))))))))
+      
+      ;; add-mouse-over : syntax[original] string -> void
+      ;; registers the range in the editor so that a mouse over
+      ;; this area shows up in the status line.
+      (define (add-mouse-over stx str)
+        (let* ([source (syntax-source stx)])
+	  (when (is-a? source text%)
+            (let ([syncheck-text (find-syncheck-text source)])
+              (when (and syncheck-text
+                         (syntax-position stx)
+                         (syntax-span stx))
+                (let* ([pos-left (- (syntax-position stx) 1)]
+                       [pos-right (+ pos-left (syntax-span stx))])
+                  (send syncheck-text syncheck:add-mouse-over-status
+                        source pos-left pos-right str)))))))
+      
+      ;; add-jump-to-definition : syntax symbol path -> void
+      ;; registers the range in the editor so that a mouse over
+      ;; this area shows up in the status line.
+      (define (add-jump-to-definition stx id filename)
+        (let ([source (syntax-source stx)])
+          (when (is-a? source text%)
+            (let ([syncheck-text (find-syncheck-text source)])
+              (when (and syncheck-text
+                         (syntax-position stx)
+                         (syntax-span stx))
+                (let* ([pos-left (- (syntax-position stx) 1)]
+                       [pos-right (+ pos-left (syntax-span stx))])
+                  (send syncheck-text syncheck:add-jump-to-definition
+                        source
+                        pos-left
+                        pos-right
+                        id
+                        filename)))))))
+      
+      ;; find-syncheck-text : text% -> (union #f (is-a?/c syncheck-text<%>))
+      (define (find-syncheck-text text)
+        (let loop ([text text])
+          (cond
+            [(is-a? text syncheck-text<%>) text]
+            [else 
+             (let ([admin (send text get-admin)])
+               (and (is-a? admin editor-snip-editor-admin<%>)
+                    (let* ([enclosing-editor-snip (send admin get-snip)]
+                           [editor-snip-admin (send enclosing-editor-snip get-admin)]
+                           [enclosing-editor (send editor-snip-admin get-editor)])
+                      (loop enclosing-editor))))])))
+ 
+      ;; annotate-tail-position/last : (listof syntax) -> void
+      (define (annotate-tail-position/last orig-stx stxs tail-ht)
+        (unless (null? stxs)
+          (annotate-tail-position orig-stx (car (last-pair stxs)) tail-ht)))
+      
+      ;; annotate-tail-position : syntax -> void
+      ;; colors the parens (if any) around the argument
+      ;; to indicate this is a tail call.
+      (define (annotate-tail-position orig-stx tail-stx tail-ht)
+        (hash-table-put!
+         tail-ht 
+         orig-stx 
+         (cons
+          tail-stx
+          (hash-table-get 
+           tail-ht
+           orig-stx
+           (λ () null)))))
+
+      ;; annotate-require-open : namespace string -> (stx -> void)
+      ;; relies on current-module-name-resolver, which in turn depends on
+      ;; current-directory and current-namespace
+      (define (annotate-require-open user-namespace user-directory)
+	(λ (require-spec)
+	  (when (syntax-original? require-spec)
+	    (let ([source (syntax-source require-spec)])
+	      (when (and (is-a? source text%)
+			 (syntax-position require-spec)
+			 (syntax-span require-spec))
+                (let ([syncheck-text (find-syncheck-text source)])
+                  (when syncheck-text
+                    (let* ([start (- (syntax-position require-spec) 1)]
+                           [end (+ start (syntax-span require-spec))]
+                           [file (get-require-filename (syntax-object->datum require-spec)
+                                                       user-namespace
+                                                       user-directory)])
+                      (when file
+                        (send syncheck-text syncheck:add-menu
+                              source
+                              start end 
+                              #f
+                              (make-require-open-menu file)))))))))))
+      
+      ;; get-require-filename : sexp namespace string[directory] -> filename
+      ;; finds the filename corresponding to the require in stx
+      (define (get-require-filename datum user-namespace user-directory)
+        (let* ([sym 
+                (and (not (symbol? datum))
+                     (parameterize ([current-namespace user-namespace]
+                                    [current-directory user-directory]
+                                    [current-load-relative-directory user-directory])
+                       ((current-module-name-resolver) datum #f #f)))])
+          (and (symbol? sym)
+               (module-name-sym->filename sym))))
+      
+      ;; make-require-open-menu : path -> menu -> void
+      (define (make-require-open-menu file)
+        (λ (menu)
+          (let-values ([(base name dir?) (split-path file)])
+            (instantiate menu-item% ()
+              (label (format (string-constant cs-open-file) (path->string name)))
+              (parent menu)
+              (callback (λ (x y) (fw:handler:edit-file file))))
+            (void))))
+      
+      ;; possible-suffixes : (listof string)
+      ;; these are the suffixes that are checked for the reverse 
+      ;; module-path mapping.
+      (define possible-suffixes '(".ss" ".scm" ""))
+      
+      ;; module-name-sym->filename : symbol -> (union #f string)
+      (define (module-name-sym->filename sym)
+        (let ([str (symbol->string sym)])
+          (and ((string-length str) . > . 1)
+               (char=? (string-ref str 0) #\,)
+               (let ([fn (substring str 1 (string-length str))])
+                 (ormap (λ (x)
+                          (let ([test (string->path (string-append fn x))])
+                            (and (file-exists? test)
+                                 test)))
+                        possible-suffixes)))))
+
+      ;; add-origins : sexp id-set -> void
+      (define (add-origins sexp id-set)
+        (let ([origin (syntax-property sexp 'origin)])
+          (when origin
+            (let loop ([ct origin])
+              (cond
+                [(pair? ct) 
+                 (loop (car ct))
+                 (loop (cdr ct))]
+                [(syntax? ct) 
+                 (when (syntax-original? ct)
+                   (add-id id-set ct))]
+                [else (void)])))))
+      
+      ;; extract-provided-vars : syntax -> (listof syntax[identifier])
+      (define (extract-provided-vars stx)
+        (syntax-case stx (rename struct all-from all-from-except)
+          [identifier
+           (identifier? (syntax identifier))
+           (list (syntax identifier))]
+          
+          [(rename local-identifier export-identifier) 
+           (list (syntax local-identifier))]
+          
+          ;; why do I even see this?!?
+          [(struct struct-identifier (field-identifier ...))
+           null]
+          
+          [(all-from module-name) null] 
+          [(all-from-except module-name identifer ...)
+           null]
+          [_ 
+           null]))
+          
+      
+       ;; trim-require-prefix : syntax -> syntax
+      (define (trim-require-prefix require-spec)
+        (let loop ([stx require-spec])
+          (syntax-case stx (prefix all-except rename)
+            [(prefix identifier module-name) (loop (syntax module-name))]
+            [(all-except module-name identifer ...)
+             (loop (syntax module-name))]
+            [(rename module-name local-identifer exported-identifer)
+             (loop (syntax module-name))]
+            [_ stx])))
+      
+      ;; add-binders : syntax id-set -> void
+      ;; transforms an argument list into a bunch of symbols/symbols
+      ;; and puts them into the id-set
+      ;; effect: colors the identifiers
+      (define (add-binders stx id-set)
+        (let loop ([stx stx])
+          (let ([e (if (syntax? stx) (syntax-e stx) stx)])
+            (cond
+              [(cons? e)
+               (let ([fst (car e)]
+                     [rst (cdr e)])
+                 (if (syntax? fst)
+                     (begin
+                       (add-id id-set fst)
+                       (loop rst))
+                     (loop rst)))]
+              [(null? e) (void)]
+              [else 
+               (when (syntax-original? stx)
+                 (add-id id-set stx))]))))
+      
+      ;; annotate-raw-keyword : syntax id-map -> void
+      ;; annotates keywords when they were never expanded. eg.
+      ;; if someone just types `(λ (x) x)' it has no 'origin
+      ;; field, but there still are keywords.
+      (define (annotate-raw-keyword stx id-map)
+        (unless (syntax-property stx 'origin)
+          (let ([lst (syntax-e stx)])
+            (when (pair? lst)
+              (let ([f-stx (car lst)])
+                (when (and (syntax-original? f-stx)
+                           (identifier? f-stx))
+                  (add-id id-map f-stx)))))))
+            
+      ;; color-internal-structure : syntax str -> void
+      (define (color-internal-structure stx style-name)
+        (let ([ht (make-hash-table)]) 
+          ;; ht : stx -o> true
+          ;; indicates if we've seen this syntax object before
+          
+          (let loop ([stx stx]
+                     [datum (syntax-object->datum stx)])
+	    (unless (hash-table-get ht datum (λ () #f))
+	      (hash-table-put! ht datum #t)
+              (cond
+	       [(pair? stx) 
+		(loop (car stx) (car datum))
+		(loop (cdr stx) (cdr datum))]
+	       [(syntax? stx)
+                (when (syntax-original? stx)
+                  (color stx style-name))
+                (let ([stx-e (syntax-e stx)]) 
+                  (cond
+		   [(cons? stx-e)
+		    (loop (car stx-e) (car datum))
+		    (loop (cdr stx-e) (cdr datum))]
+		   [(null? stx-e)
+		    (void)]
+		   [(vector? stx-e)
+		    (for-each loop
+			      (vector->list stx-e)
+			      (vector->list datum))]
+		   [(box? stx-e)
+		    (loop (unbox stx-e) (unbox datum))]
+		   [else (void)]))])))))
+
+      ;; jump-to : syntax -> void
+      (define (jump-to stx)
+        (let ([src (syntax-source stx)]
+              [pos (syntax-position stx)]
+              [span (syntax-span stx)])
+          (when (and (is-a? src text%)
+                     pos
+                     span)
+            (send src set-position (- pos 1) (+ pos span -1)))))
+      
+      ;; color : syntax[original] str -> void
+      ;; colors the syntax with style-name's style
+      (define (color stx style-name)
+        (let ([source (syntax-source stx)])
+          (when (is-a? source text%)
+            (let ([pos (- (syntax-position stx) 1)]
+                  [span (syntax-span stx)])
+              (color-range source pos (+ pos span) style-name)))))
+      
+      ;; color-range : text start finish style-name 
+      ;; colors a range in the text based on `style-name'
+      (define (color-range source start finish style-name)
+        (let ([style (send (send source get-style-list)
+                           find-named-style
+                           style-name)])
+          (add-to-cleanup-texts source)
+          (send source change-style style start finish #f)))
+
+      ;; hash-table[syntax -o> (listof syntax)] -> void
+      (define (add-tail-ht-links tail-ht)
+        (hash-table-for-each
+         tail-ht
+         (λ (stx-from stx-tos)
+           (for-each (λ (stx-to) (add-tail-ht-link stx-from stx-to))
+                     stx-tos))))
+      
+      ;; add-tail-ht-link : syntax syntax -> void
+      (define (add-tail-ht-link from-stx to-stx)
+        (let* ([to-src (syntax-source to-stx)]
+               [from-src (syntax-source from-stx)]
+               [to-outermost-src (and (is-a? to-src editor<%>)
+                                      (find-outermost-editor to-src))]
+               [from-outermost-src (and (is-a? from-src editor<%>)
+                                        (find-outermost-editor from-src))])
+          (when (and (is-a? to-outermost-src syncheck-text<%>)
+                     (eq? from-outermost-src to-outermost-src))
+            (let ([from-pos (syntax-position from-stx)]
+                  [to-pos (syntax-position to-stx)])
+              (when (and from-pos to-pos)
+                (send to-outermost-src syncheck:add-tail-arrow
+                      from-src (- from-pos 1)
+                      to-src (- to-pos 1)))))))
+      
+      ;; add-to-cleanup-texts : (is-a?/c editor<%>) -> void
+      (define (add-to-cleanup-texts ed)
+        (let ([ed (find-outermost-editor ed)])
+          (when (is-a? ed drscheme:unit:definitions-text<%>)
+            (let ([tab (send ed get-tab)])
+              (send tab syncheck:add-to-cleanup-texts ed)))))
+      
+      (define (find-outermost-editor ed)
+        (let loop ([ed ed])
+          (let ([admin (send ed get-admin)])
+            (if (is-a? admin editor-snip-editor-admin<%>)
+                (let* ([enclosing-snip (send admin get-snip)]
+                       [enclosing-snip-admin (send enclosing-snip get-admin)])
+                  (loop (send enclosing-snip-admin get-editor)))
+                ed))))
+      
+      ;; make-rename-menu : stx[original] (listof id-set) -> void
+      (define (make-rename-menu stx id-sets)
+        (let ([source (syntax-source stx)])
+          (when (is-a? source text%)
+            (let ([syncheck-text (find-syncheck-text source)])
+              (when syncheck-text
+                (let* ([name-to-offer (format "~a" (syntax-object->datum stx))]
+                       [start (- (syntax-position stx) 1)]
+                       [fin (+ start (syntax-span stx))])
+                  (send syncheck-text syncheck:add-menu
+                        source start fin (syntax-e stx)
+                        (λ (menu)
+                          (instantiate menu-item% ()
+                            (parent menu)
+                            (label (format (string-constant cs-rename-var) name-to-offer))
+                            (callback
+                             (λ (x y)
+                               (let ([frame-parent (find-menu-parent menu)])
+                                 (rename-callback name-to-offer
+                                                  stx
+                                                  id-sets
+                                                  frame-parent)))))))))))))
+      
+      ;; find-parent : menu-item-container<%> -> (union #f (is-a?/c top-level-window<%>)
+      (define (find-menu-parent menu)
+        (let loop ([menu menu])
+          (cond
+            [(is-a? menu menu-bar%) (send menu get-frame)]
+            [(is-a? menu popup-menu%)
+             (let ([target (send menu get-popup-target)])
+               (cond
+                 [(is-a? target editor<%>) 
+                  (let ([canvas (send target get-canvas)])
+                    (and canvas
+                         (send canvas get-top-level-window)))]
+                 [(is-a? target window<%>) 
+                  (send target get-top-level-window)]
+                 [else #f]))]
+            [(is-a? menu menu-item<%>) (loop (send menu get-parent))]
+            [else #f])))
+
+      ;; rename-callback : string syntax[original] (listof id-set) (union #f (is-a?/c top-level-window<%>)) -> void
+      ;; callback for the rename popup menu item
+      (define (rename-callback name-to-offer stx id-sets parent)
+        (let ([new-sym 
+               (fw:keymap:call/text-keymap-initializer
+                (λ ()
+                  (get-text-from-user
+                   (string-constant cs-rename-id)
+                   (format (string-constant cs-rename-var-to) name-to-offer)
+                   parent
+                   name-to-offer)))])
+          (when new-sym
+            (let* ([to-be-renamed 
+                    (remove-duplicates
+                     (quicksort 
+                      (apply 
+                       append
+                       (map (λ (id-set) (or (get-ids id-set stx) '()))
+                            id-sets))
+                      (λ (x y) 
+                        ((syntax-position x) . >= . (syntax-position y)))))]
+                   [do-renaming?
+                    (or (not (name-duplication? to-be-renamed id-sets new-sym))
+                        (equal?
+                         (message-box/custom
+                          (string-constant check-syntax)
+                          (format (string-constant cs-name-duplication-error) 
+                                  new-sym)
+                          (string-constant cs-rename-anyway)
+                          (string-constant cancel)
+                          #f
+                          parent
+                          '(stop default=2))
+                         1))])
+              (when do-renaming?
+                (unless (null? to-be-renamed)
+                  (let ([first-one-source (syntax-source (car to-be-renamed))])
+                    (when (is-a? first-one-source text%)
+                      (send first-one-source begin-edit-sequence)
+                      (for-each (λ (stx) 
+                                  (let ([source (syntax-source stx)])
+                                    (when (is-a? source text%)
+                                      (let* ([start (- (syntax-position stx) 1)]
+                                             [end (+ start (syntax-span stx))])
+                                        (send source delete start end #f)
+                                        (send source insert new-sym start start #f)))))
+                                to-be-renamed)
+                      (send first-one-source invalidate-bitmap-cache)
+                      (send first-one-source end-edit-sequence)))))))))
+      
+      ;; name-duplication? : (listof syntax) (listof id-set) symbol -> boolean
+      ;; returns #t if the name chosen would be the same as another name in this scope.
+      (define (name-duplication? to-be-renamed id-sets new-str)
+        (let ([new-ids (map (λ (id) (datum->syntax-object id (string->symbol new-str)))
+                            to-be-renamed)])
+          (ormap (λ (id-set)
+                   (ormap (λ (new-id) (get-ids id-set new-id)) 
+                          new-ids))
+                 id-sets)))
+               
+      ;; remove-duplicates : (listof syntax[original]) -> (listof syntax[original])
+      ;; removes duplicates, based on the source locations of the identifiers
+      (define (remove-duplicates ids)
+        (cond
+          [(null? ids) null]
+          [else (let loop ([fst (car ids)]
+                           [rst (cdr ids)])
+                  (cond
+                    [(null? rst) (list fst)]
+                    [else (if (and (eq? (syntax-source fst)
+                                        (syntax-source (car rst)))
+                                   (= (syntax-position fst)
+                                      (syntax-position (car rst))))
+                              (loop fst (cdr rst))
+                              (cons fst (loop (car rst) (cdr rst))))]))]))
+      
+      
+;                                            
+;                                            
+;                                            
+;   ;       ;                                
+;           ;                                
+;           ;                     ;          
+;   ;    ;; ;        ;;;    ;;;  ;;;;   ;;;  
+;   ;   ;  ;;       ;      ;   ;  ;    ;     
+;   ;  ;    ;       ;;    ;    ;  ;    ;;    
+;   ;  ;    ;        ;;   ;;;;;;  ;     ;;   
+;   ;  ;    ;          ;  ;       ;       ;  
+;   ;   ;  ;;          ;   ;      ;       ;  
+;   ;    ;; ;       ;;;     ;;;;   ;;  ;;;   
+;                                            
+;                                            
+;                                            
+
+      ;; make-id-set : -> id-set
+      (define (make-id-set) (make-module-identifier-mapping))
+      
+      ;; add-id : id-set identifier -> void
+      (define (add-id mapping id)
+        (let ([old (module-identifier-mapping-get mapping id (λ () '()))])
+          (module-identifier-mapping-put! mapping id (cons id old))))
+      
+      ;; get-idss : id-set -> (listof (listof identifier))
+      (define (get-idss mapping)
+        (module-identifier-mapping-map mapping (λ (x y) y)))
+      
+      ;; get-ids : id-set identifier -> (union (listof identifier) #f)
+      (define (get-ids mapping var)
+        (module-identifier-mapping-get mapping var (λ () #f)))
+      
+      ;; for-each-ids : id-set ((listof identifier) -> void) -> void
+      (define (for-each-ids mapping f)
+        (module-identifier-mapping-for-each mapping (λ (x y) (f y))))
+
+      
+      ;                                                 
+      ;                                                 
+      ;                                                 
+      ;  ;    ;    ; ;                                  
+      ;  ;    ;    ;                                    
+      ;  ;   ; ;   ;                                    
+      ;   ;  ; ;  ;  ;   ; ;   ;;;       ;   ;   ; ;;   
+      ;   ;  ; ;  ;  ;   ;;   ;   ;      ;   ;   ;;  ;  
+      ;   ; ;   ; ;  ;   ;   ;    ;      ;   ;   ;    ; 
+      ;   ; ;   ; ;  ;   ;   ;;;;;;      ;   ;   ;    ; 
+      ;   ; ;   ; ;  ;   ;   ;           ;   ;   ;    ; 
+      ;    ;     ;   ;   ;    ;          ;  ;;   ;;  ;  
+      ;    ;     ;   ;   ;     ;;;;       ;; ;   ; ;;   
+      ;                                          ;      
+      ;                                          ;      
+      ;                                          ;      
+
+      
+      (add-check-syntax-key-bindings (drscheme:rep:get-drs-bindings-keymap))
+      (fw:color-prefs:add-to-preferences-panel (string-constant check-syntax)
+                                               syncheck-add-to-preferences-panel)
+      (drscheme:get/extend:extend-definitions-text make-graphics-text%)
+      (drscheme:get/extend:extend-unit-frame unit-frame-mixin #f)
+      (drscheme:get/extend:extend-tab tab-mixin))))
diff --git a/collects/drscheme/tool.ss b/collects/drscheme/tool.ss
new file mode 100644
index 0000000000..7fd1b8188c
--- /dev/null
+++ b/collects/drscheme/tool.ss
@@ -0,0 +1,4 @@
+(module tool mzscheme
+  (require "private/drsig.ss")
+  (provide drscheme:tool^
+           drscheme:tool-exports^))
diff --git a/collects/dynext/compile-sig.ss b/collects/dynext/compile-sig.ss
new file mode 100644
index 0000000000..3c4745eb9e
--- /dev/null
+++ b/collects/dynext/compile-sig.ss
@@ -0,0 +1,18 @@
+
+(module compile-sig mzscheme
+  (require (lib "unitsig.ss"))
+
+  (provide dynext:compile^)
+  
+  (define-signature dynext:compile^
+    (compile-extension
+     current-extension-compiler 
+     current-extension-compiler-flags
+     current-make-compile-include-strings
+     current-make-compile-input-strings
+     current-make-compile-output-strings
+     use-standard-compiler
+     get-standard-compilers
+     compile-variant
+     expand-for-compile-variant)))
+
diff --git a/collects/dynext/compile-unit.ss b/collects/dynext/compile-unit.ss
new file mode 100644
index 0000000000..1e9979a2fa
--- /dev/null
+++ b/collects/dynext/compile-unit.ss
@@ -0,0 +1,252 @@
+
+(module compile-unit mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "include.ss")
+	   (lib "process.ss")
+	   (lib "sendevent.ss")
+	   "private/dirs.ss")
+
+  (require "compile-sig.ss")
+
+  (provide dynext:compile@)
+
+  (define dynext:compile@
+    (unit/sig dynext:compile^ 
+      (import)
+      
+      (define (get-unix-compile)
+	(or (getenv "MZSCHEME_DYNEXT_COMPILER")
+	    (find-executable-path "gcc" #f)
+	    (find-executable-path "cc" #f)))
+      
+      (define (get-windows-compile)
+	(or (find-executable-path "cl.exe" #f)
+	    (find-executable-path "gcc.exe" #f)
+	    (find-executable-path "bcc32.exe" #f)))
+      
+      (define current-extension-compiler 
+	(make-parameter 
+	 (case (system-type) 
+	   [(unix macosx) (get-unix-compile)]
+	   [(windows) (get-windows-compile)]
+	   [else #f])
+	 (lambda (v)
+	   (when v 
+	     (if (path-string? v)
+		 (unless (and (file-exists? v)
+			      (memq 'execute (file-or-directory-permissions v)))
+		   (error 'current-extension-compiler 
+			  "compiler not found or not executable: ~s" v))
+		 (raise-type-error 'current-extension-compiler "path, valid-path string, or #f" v)))
+	   v)))
+
+      (define win-gcc?
+	(let ([c (current-extension-compiler)])
+	  (and c (regexp-match #"gcc.exe$" (path->bytes c)))))
+      (define win-borland?
+	(let ([c (current-extension-compiler)])
+	  (and c (regexp-match #"bcc32.exe$" (path->bytes c)))))
+      (define unix-cc?
+	(let ([c (current-extension-compiler)])
+	  (and c (regexp-match #"[^g]cc$" (path->bytes c)))))
+
+      (define gcc-compile-flags (append '("-c" "-O2" "-fPIC")
+					(case (string->symbol (path->string (system-library-subpath #f)))
+					  [(parisc-hpux) '("-D_HPUX_SOURCE")]
+					  [(ppc-macosx) '("-fno-common" "-DOS_X" )]
+					  [(ppc-darwin) '("-fno-common" "-DOS_X" "-DXONX" )]
+					  [else null])))
+      (define unix-compile-flags (case (string->symbol (path->string (system-library-subpath #f)))
+				   [(parisc-hpux) '("-c" "-O2" "-Aa" "-D_HPUX_SOURCE" "+z" "+e")]
+				   [else gcc-compile-flags]))
+      (define msvc-compile-flags '("/c" "/MT" "/O2"))
+
+      (define current-extension-compiler-flags
+	(make-parameter
+	 (case (system-type)
+	   [(unix macosx) (if unix-cc?
+			      unix-compile-flags
+			      gcc-compile-flags)]
+	   [(windows) (if (or win-gcc? win-borland?)
+			  gcc-compile-flags
+			  msvc-compile-flags)]
+	   [(macos) '()])
+	 (lambda (l)
+	   (unless (and (list? l) (andmap (lambda (s) (or (path-string? s)
+							  (and (procedure? s) (procedure-arity-includes? s 0))))
+					  l))
+	     (raise-type-error 'current-extension-compiler-flags "list of paths/strings and thunks" l))
+	   l)))
+
+      (define compile-variant (make-parameter 
+			       'normal
+			       (lambda (s)
+				 (unless (memq s '(normal 3m))
+				   (raise-type-error 'compile-variant "'normal or '3m" s))
+				 s)))
+
+      (define (add-variant-flags l)
+	(append l (list (lambda ()
+			  (if (eq? '3m (compile-variant))
+			      '("-DMZ_PRECISE_GC")
+			      null)))))
+
+      (define (expand-for-compile-variant l)
+	(apply append (map (lambda (s) (if (path-string? s) (list s) (s))) l)))
+
+      (define current-make-extra-extension-compiler-flags
+	(make-parameter
+	 (lambda () (case (compile-variant)
+		      [(3m) '("-DMZ_PRECISE_GC")]
+		      [else null]))
+	 (lambda (p)
+	   (unless (and (procedure? p) (procedure-arity-includes? p 0))
+	     (raise-type-error 'current-make-extra-extension-compiler-flags "procedure (arity 0)" p))
+	   p)))
+      
+      (define (path-string->string s)
+	(if (string? s) s (path->string s)))
+
+      (define unix-compile-include-strings (lambda (s) 
+					     (list (string-append "-I" (path-string->string s)))))
+      (define msvc-compile-include-strings (lambda (s) 
+					     (list (string-append "/I" (path-string->string s)))))
+
+      (define current-make-compile-include-strings
+	(make-parameter
+	 (case (system-type)
+	   [(unix macosx) unix-compile-include-strings]
+	   [(windows) (if (or win-gcc? win-borland?)
+			  unix-compile-include-strings
+			  msvc-compile-include-strings)]
+	   [(macos) unix-compile-include-strings])
+	 (lambda (p)
+	   (unless (procedure-arity-includes? p 1)
+	     (raise-type-error 'current-make-compile-include-strings "procedure of arity 1" p))
+	   p)))
+      
+      (define current-make-compile-input-strings
+	(make-parameter
+	 (lambda (s) (list (path-string->string s)))
+	 (lambda (p)
+	   (unless (procedure-arity-includes? p 1)
+	     (raise-type-error 'current-make-compile-input-strings "procedure of arity 1" p))
+	   p)))
+      
+      (define unix-compile-output-strings (lambda (s) (list "-o" (path-string->string s))))
+      (define msvc-compile-output-strings (lambda (s) (list (string-append "/Fo" (path-string->string s)))))
+
+      (define current-make-compile-output-strings
+	(make-parameter
+	 (case (system-type)
+	   [(unix macosx) unix-compile-output-strings]
+	   [(windows) (if (or win-gcc? win-borland?)
+			  unix-compile-output-strings
+			  msvc-compile-output-strings)]
+	   [(macos) unix-compile-output-strings])
+	 (lambda (p)
+	   (unless (procedure-arity-includes? p 1)
+	     (raise-type-error 'current-make-compile-output-strings "procedure of arity 1" p))
+	   p)))
+      
+      (define (get-standard-compilers)
+	(case (system-type)
+	  [(unix macosx) '(gcc cc)]
+	  [(windows) '(gcc msvc borland)]
+	  [(macos) '(cw)]))
+
+      (define (use-standard-compiler name)
+	(define (bad-name name)
+	  (error 'use-standard-compiler "unknown compiler: ~a" name))
+	(case (system-type)
+	  [(unix macosx) 
+	   (case name
+	     [(cc gcc) (let* ([n (if (eq? name 'gcc) "gcc" "cc")]
+			      [f (find-executable-path n n)])
+			 (unless f
+			   (error 'use-standard-linker "cannot find ~a" n))
+			 (current-extension-compiler f))
+	      (current-extension-compiler-flags (add-variant-flags
+						 (if (eq? name 'gcc)
+						     gcc-compile-flags
+						     unix-compile-flags)))
+	      (current-make-compile-include-strings unix-compile-include-strings)
+	      (current-make-compile-input-strings (lambda (s) (list (path-string->string s))))
+	      (current-make-compile-output-strings unix-compile-output-strings)]
+	     [else (bad-name name)])]
+	  [(windows) 
+	   (case name
+	     [(gcc) (let ([f (find-executable-path "gcc.exe" #f)])
+		      (unless f
+			(error 'use-standard-linker "cannot find gcc.exe"))
+		      (current-extension-compiler f))
+	      (current-extension-compiler-flags (add-variant-flags gcc-compile-flags))
+	      (current-make-compile-include-strings unix-compile-include-strings)
+	      (current-make-compile-input-strings (lambda (s) (list (path-string->string s))))
+	      (current-make-compile-output-strings unix-compile-output-strings)]
+	     [(borland) (let ([f (find-executable-path "bcc32.exe" #f)])
+			  (unless f
+			    (error 'use-standard-linker "cannot find bcc32.exe"))
+			  (current-extension-compiler f))
+	      (current-extension-compiler-flags (add-variant-flags gcc-compile-flags))
+	      (current-make-compile-include-strings unix-compile-include-strings)
+	      (current-make-compile-input-strings (lambda (s) (list (path-string->string s))))
+	      (current-make-compile-output-strings unix-compile-output-strings)]
+	     [(msvc) (let ([f (find-executable-path "cl.exe" #f)])
+		       (unless f
+			 (error 'use-standard-linker "cannot find MSVC's cl.exe"))
+		       (current-extension-compiler f))
+	      (current-extension-compiler-flags (add-variant-flags msvc-compile-flags))
+	      (current-make-compile-include-strings msvc-compile-include-strings)
+	      (current-make-compile-input-strings (lambda (s) (list (path-string->string s))))
+	      (current-make-compile-output-strings msvc-compile-output-strings)]
+	     [else (bad-name name)])]
+	  [(macos) 
+	   (case name
+	     [(cw) (current-extension-compiler #f)
+	      (current-extension-compiler-flags (add-variant-flags unix-compile-flags))
+	      (current-make-compile-include-strings unix-compile-include-strings)
+	      (current-make-compile-input-strings (lambda (s) (list (path-string->string s))))
+	      (current-make-compile-output-strings unix-compile-output-strings)]
+	     [else (bad-name name)])]))
+      
+      (define-values (my-process* stdio-compile)
+	(let-values ([(p* do-stdio) (include (build-path "private" "stdio.ss"))])
+	  (values
+	   p*
+	   (lambda (start-process quiet?)
+	     (do-stdio start-process quiet? (lambda (s) (error 'compile-extension "~a" s)))))))
+      
+      (define unix/windows-compile
+	(lambda (quiet? in out includes)
+	  (let ([c (current-extension-compiler)])
+	    (if c
+		(stdio-compile (lambda (quiet?) 
+				 (let ([command (append 
+						 (list c)
+						 (expand-for-compile-variant
+						  (current-extension-compiler-flags))
+						 (apply append 
+							(map 
+							 (lambda (s) 
+							   ((current-make-compile-include-strings) s)) 
+							 includes))
+						 ((current-make-compile-include-strings) include-dir)
+						 ((current-make-compile-input-strings) in)
+						 ((current-make-compile-output-strings) out))])
+				   (unless quiet? 
+				     (printf "compile-extension: ~a~n" command))
+				   (apply my-process* command)))
+			       quiet?)
+		(error 'compile-extension "can't find an installed C compiler")))))
+      
+      (include (build-path "private" "macinc.ss"))
+      
+      (define (macos-compile quiet? input-file output-file includes)
+	(macos-make 'compile-extension "extension-project" "lib" quiet? 
+		    (list input-file) output-file includes))
+      
+      (define compile-extension
+	(case (system-type)
+	  [(unix windows macosx) unix/windows-compile]
+	  [(macos) macos-compile])))))
diff --git a/collects/dynext/compile.ss b/collects/dynext/compile.ss
new file mode 100644
index 0000000000..8854a62755
--- /dev/null
+++ b/collects/dynext/compile.ss
@@ -0,0 +1,12 @@
+
+(module compile mzscheme
+  (require (lib "unitsig.ss"))
+
+  (require "compile-sig.ss")
+  (require "compile-unit.ss")
+
+  (define-values/invoke-unit/sig dynext:compile^
+    dynext:compile@)
+
+  (provide-signature-elements dynext:compile^))
+
diff --git a/collects/dynext/doc.txt b/collects/dynext/doc.txt
new file mode 100644
index 0000000000..6ae7455813
--- /dev/null
+++ b/collects/dynext/doc.txt
@@ -0,0 +1,187 @@
+
+The _dynext_ collection provides three libraries --- compile.ss,
+link.ss, and file.ss --- for communicating with a platform-specific C
+compiler and linker.
+
+_compile.ss_
+------------
+
+> (compile-extension quiet? input-file output-file includes)
+   quiet? - Boolean indicating whether command should be echoed to stdout
+   input-file - A C source path/string
+   output-file - A compiled object path/string
+   includes - A list of include directory paths/strings; MzScheme's
+              include is added automatically.
+
+Compilation is controlled by a number of parameters for Windows
+and Unix:
+
+>  current-extension-compiler - compiler executable path/string or
+    #f. The default is set by searching for an executable using the
+    PATH environment variable. Under windows, the search looks for
+    cl.exe, then gcc.exe, then bcc32.exe (Borland). Under Unix, it
+    checks the MZSCHEME_DYNEXT_COMPILER environment variable, then
+    looks for gcc, then cc. #f indicates that no compiler could be
+    found.
+
+>  current-extension-compiler-flags - list of paths/strings and thunks
+    (see `expand-for-compile-variant' below) for strings passed to the
+    compiler as flags. Under Windows, the default is (list "/c" "/O2"
+    3m-flag-thunk) for cl.exe and (list "-c" "-O2" 3m-flag-thunk) for
+    gcc.exe and bcc32.exe, where 3m-flag-thunk returns (list
+    "-DMZ_PRECISE_GC") for the '3m variant and null for any other
+    variant; under Unix, (list "-c" "-O2" 3m-flag-thunk).
+
+>  current-make-compile-include-strings - procedure that takes an
+    include directory path/string and returns a list of strings for
+    the command line.  Windows: "dir" -> (list "/Idir") for cl.exe,
+    (list "-Idir") for gcc.exe and bcc32.exe; Unix: "dir" -> (list
+    "-Idir")
+
+>  current-make-compile-input-strings - procedure that takes an
+    input file path/string and returns a list of strings for the
+    command line.  The default is `list'.
+
+>  current-make-compile-output-strings - procedure that takes an
+    output file path/string and returns a list of strings for the
+    command line.  Windows: "file" -> (list "/Fofile") for cl.exe,
+    (list "-o" "file") for gcc.exe and bcc32.exe; Unix: "file" ->
+    (list "-o" "file")
+
+>  compile-variant - a symbol, either 'normal or '3m, that indicates the
+    target for compilation.
+
+Helper functions:
+
+> (use-standard-compiler name) sets the above parameters for a
+    particular known compiler. The acceptable names are 
+    platforms-specific:
+      Unix: 'cc or 'gcc
+      Windows: 'gcc, 'msvc, or 'borland
+      MacOS: 'cw
+
+> (get-standard-compilers) returns a list of standard compiler
+    names for the current platform.
+
+> (expand-for-compile-variant l) takes a list of paths/strings and
+    thunks and returns a list of strings. Each thunk in the input list
+    is applied to get a list of strings that is inlined in the
+    corresponding position in the output list. This expansion enables
+    occasional parameterization of flag lists, etc., depending on the
+    current compile variant.
+
+Under MacOS, none of these options are used. The compiler always
+uses CodeWarrior if it can be found and the compilation options
+cannot be changed.
+
+The unit/sig form defined by _compiler.ss_ (signature in
+_compiles.ss_) requires no imports.
+
+_link.ss_
+---------
+
+> (link-extension quiet? input-files output-file)
+   quiet? - Boolean indicating whether command should be echoed to stdout
+   input-files - A list of compiled object filename paths/strings
+   output-file - An extension filename path/string
+
+   For Windows, a special linking sequence is initiated if the
+   linker's name is ld.exe (for gcc).
+
+Linking parameters:
+
+>  current-extension-linker - linker executable path/string or #f. 
+     The default is set by searching for an executable using the PATH
+     environment variable. Under Windows, it looks for cl.exe, then
+     ld.exe (gcc), then ilink32.exe (Borland). Under Unix it checks
+     the MZSCHEME_DYNEXT_LINKER environment variable, then, except
+     AIX, it looks for ld. Under AIX, it looks for cc. #f indicates
+     that no linker could be found.
+
+>  current-extension-linker-flags - list of paths/strings and thunks
+     (see `expand-for-link-variant' below). Under Windows, default is
+     (list "/LD") for cl.exe, (list "--dll") for ld.exe, (list "/Tpd"
+     "/c") for ilink32.exe.  Under Unix, the default varies greatly
+     among platforms.
+
+>  current-make-link-input-strings - procedure that takes an
+     input file path/string and returns a list of strings for the
+     command line.  The default is `list'.
+
+>  current-make-link-output-strings - procedure that takes an output
+     file path/string and returns a list of strings for the command
+     line.  Windows: "file" -> (list "/Fefile") for cl.exe, something
+     like (list "-e" "_dll_entry@12" "-o" "file") for ld.exe,
+     something complex for ilink32.exe; Unix: "file" -> (list "-o"
+     "file")
+
+>  current-standard-link-libraries - a list of paths/strings and thunks
+     (see `expand-for-link-variant' below) for file paths to be linked
+     with all supplied files.  For most platforms, the default is
+        (list (build-path (collection-path "mzscheme" "lib") 
+                          (system-library-subpath)
+                          mzdyn-thunk))
+     where mzdyn-thunk produces (list "mzdyn.o") for the 'normal
+     variant and (list "mzdyn3m.o") for the '3m variant (also see
+     `current-use-mzdyn').
+
+>  current-use-mzdyn - whether the default standard link libraries
+      include the mzdyn library.  Defaults to #t.
+
+>  link-variant - a symbol, either 'normal or '3m, that indicates the
+    target for linking.
+
+Helper functions:
+
+>  (use-standard-linker name) sets the above parameters for a
+     particular known linker. The acceptable names are
+     platforms-specific, the same as for use-standard-compiler.
+
+> (expand-for-link-variant l) is the same as
+    `expand-for-compile-variant' (see above).
+
+Under MacOS, none of these options are used. The linker always uses
+CodeWarrior if it can be found and the linking options cannot be
+changed.
+
+The unit/sig form defined by _linkr.ss_ (signature in _links.ss_)
+requires no imports.
+
+_file.ss_
+---------
+
+> (append-zo-suffix s) - appends the .zo file suffix to the
+  path/string s, returning a path.
+
+> (append-object-suffix s) - appends the platform-standard compiled
+   object file suffix to the path/string s, returning a path.
+
+> (append-c-suffix s) - appends the platform-standard C source
+   file suffix to the path/string s, returning a path.
+
+> (append-constant-pool-suffix s) - appends the constant pool file
+   suffix (.kp) to the path/string s, returning a path.
+
+> (append-extension-suffix s) - appends the platform-standard dynamic
+   extension file suffix to the path/string s, returning a path.
+
+> (extract-base-filename/ss s program) - strips the Scheme file suffix
+   from the path/string s and returns a stripped path. If s is not a
+   Scheme file name and `program' is a symbol, and error is signalled.
+   If s is not a Scheme file and `program' is #f, #f is returned. The
+   `program' argument is optional and defaults to #f.
+
+> (extract-base-filename/c s program) - same as
+   extract-base-filename/ss, but for C source files.
+
+> (extract-base-filename/kp s program) - same as
+   extract-base-filename/ss, but for constant pool files.
+
+> (extract-base-filename/o s program) - same as
+   extract-base-filename/ss, but for compiled object files.
+
+> (extract-base-filename/ext s program) - same as
+   extract-base-filename/ss, but for extension files.
+
+The unit/sig defined by _filer.ss_ (signature in _files.ss_) requires
+no imports.
diff --git a/collects/dynext/dynext-sig.ss b/collects/dynext/dynext-sig.ss
new file mode 100644
index 0000000000..a5e4784fc9
--- /dev/null
+++ b/collects/dynext/dynext-sig.ss
@@ -0,0 +1,8 @@
+
+(module dynext-sig mzscheme
+
+  (require "compile-sig.ss" "link-sig.ss" "file-sig.ss")
+
+  (provide (all-from "compile-sig.ss")
+	  (all-from "link-sig.ss")
+	  (all-from "file-sig.ss")))
diff --git a/collects/dynext/dynext-unit.ss b/collects/dynext/dynext-unit.ss
new file mode 100644
index 0000000000..6a7d9f8a01
--- /dev/null
+++ b/collects/dynext/dynext-unit.ss
@@ -0,0 +1,8 @@
+
+(module dynext-unit mzscheme
+
+  (require "compile-unit.ss" "link-unit.ss" "file-unit.ss")
+
+  (provide (all-from "compile-unit.ss")
+	  (all-from "link-unit.ss")
+	  (all-from "file-unit.ss")))
diff --git a/collects/dynext/dynext.ss b/collects/dynext/dynext.ss
new file mode 100644
index 0000000000..71ece24c4d
--- /dev/null
+++ b/collects/dynext/dynext.ss
@@ -0,0 +1,8 @@
+
+(module dynext mzscheme
+
+  (require "compile.ss" "link.ss" "file.ss")
+
+  (provide (all-from "compile.ss")
+	  (all-from "link.ss")
+	  (all-from "file.ss")))
diff --git a/collects/dynext/extension-project b/collects/dynext/extension-project
new file mode 100644
index 0000000000..7aa312b63b
Binary files /dev/null and b/collects/dynext/extension-project differ
diff --git a/collects/dynext/file-sig.ss b/collects/dynext/file-sig.ss
new file mode 100644
index 0000000000..bcf6cd71e3
--- /dev/null
+++ b/collects/dynext/file-sig.ss
@@ -0,0 +1,18 @@
+
+(module file-sig mzscheme
+  (require (lib "unitsig.ss"))
+
+  (provide dynext:file^)
+  
+  (define-signature dynext:file^
+    (append-zo-suffix
+     append-c-suffix
+     append-constant-pool-suffix
+     append-object-suffix
+     append-extension-suffix
+
+     extract-base-filename/ss
+     extract-base-filename/c
+     extract-base-filename/kp
+     extract-base-filename/o
+     extract-base-filename/ext)))
diff --git a/collects/dynext/file-unit.ss b/collects/dynext/file-unit.ss
new file mode 100644
index 0000000000..a9926803d9
--- /dev/null
+++ b/collects/dynext/file-unit.ss
@@ -0,0 +1,86 @@
+
+(module file-unit mzscheme
+  (require (lib "unitsig.ss"))
+  (require (lib "include.ss"))
+
+  (require "file-sig.ss")
+
+  (provide dynext:file@)
+
+  (define dynext:file@
+    (unit/sig dynext:file^
+      (import)
+
+      (define (append-zo-suffix s)
+	(path-replace-suffix s #".zo"))
+
+      (define (append-c-suffix s)
+	(path-replace-suffix s #".c"))
+
+      (define (append-constant-pool-suffix s)
+	(path-replace-suffix s #".kp"))
+
+      (define (append-object-suffix s)
+	(path-replace-suffix
+	 s
+	 (case (system-type)
+	   [(unix beos macos macosx) #".o"]
+	   [(windows) #".obj"])))
+
+      (define (append-extension-suffix s)
+	(path-replace-suffix
+	 s
+	 (case (system-type)
+	   [(unix beos) #".so"]
+	   [(macos macosx) #".dylib"]
+	   [(windows) #".dll"])))
+
+      (define (extract-suffix appender)
+	(subbytes
+	 (path->bytes (appender (bytes->path #"x")))
+	 1))
+
+      (define-values (extract-base-filename/ss
+		      extract-base-filename/c
+		      extract-base-filename/kp
+		      extract-base-filename/o
+		      extract-base-filename/ext)
+	(let ([mk
+	       (lambda (who pat kind simple)
+		 (let ([rx (byte-regexp 
+			    (string->bytes/latin-1 (format "^(.*)\\.(~a)$" pat)))])
+		   (letrec ([extract-base-filename
+			     (case-lambda
+			      [(s p)
+			       (unless (path-string? s)
+				 (raise-type-error who "path or valid-path string" s))
+			       (let ([m (regexp-match rx (path->bytes (if (path? s)
+									  s
+									  (string->path s))))])
+				 (cond
+				  [m (bytes->path (cadr m))]
+				  [p (error p "not a ~a filename (doesn't end with ~a): ~a" kind simple s)]
+				  [else #f]))]
+			      [(s) (extract-base-filename s #f)])])
+		     extract-base-filename)))])
+	  (values
+	   (mk 'extract-base-filename/ss 
+	       #"[sS][sS]|[sS][cC][mM]" "Scheme" ".ss or .scm")
+	   (mk 'extract-base-filename/c
+	       #"[cC]|[cC][cC]|[cC][xX][xX]|[cC][pP][pP]|[cC][+][+]" "C" ".c, .cc, .cxx, .cpp, or .c++")
+	   (mk 'extract-base-filename/kp
+	       #"[kK][pP]" "constant pool" ".kp")
+	   (mk 'extract-base-filename/o
+	       (case (system-type)
+		 [(unix beos macos macosx) #"[oO]"]
+		 [(windows) #"[oO][bB][jJ]"])
+	       "compiled object"
+	       (extract-suffix append-object-suffix))
+	   (mk 'extract-base-filename/ext
+	       (case (system-type)
+		 [(unix beos) #"[sS][oO]"]
+		 [(macos macosx) #"[dD][yY][lL][iI][bB]"]
+		 [(windows) #"[dD][lL][lL]"])
+	       "MzScheme extension"
+	       (extract-suffix append-extension-suffix))))))))
+
diff --git a/collects/dynext/file.ss b/collects/dynext/file.ss
new file mode 100644
index 0000000000..9d8987851c
--- /dev/null
+++ b/collects/dynext/file.ss
@@ -0,0 +1,11 @@
+
+(module file mzscheme
+  (require (lib "unitsig.ss"))
+
+  (require "file-sig.ss")
+  (require "file-unit.ss")
+
+  (define-values/invoke-unit/sig dynext:file^
+    dynext:file@)
+
+  (provide-signature-elements dynext:file^))
diff --git a/collects/dynext/filename-version.ss b/collects/dynext/filename-version.ss
new file mode 100644
index 0000000000..c10d11aa5f
--- /dev/null
+++ b/collects/dynext/filename-version.ss
@@ -0,0 +1,20 @@
+(module filename-version mzscheme
+
+  ;; this module provides the string that should replace xxxxxxx's in file names
+
+  (provide filename-version-part)
+  (define filename-version-part
+    (cond [(regexp-match #rx"^([0-9]+(?:p[0-9])?)(?:[.]([0-9]+))?$"
+                         (version))
+           => (lambda (m)
+                (let ([major (cadr m)] [minor (or (caddr m) #"")])
+                  (string-append major "_"
+                                 (make-string (- (string-length "xxxxxxx")
+                                                 1
+                                                 (string-length major)
+                                                 (string-length minor))
+                                              #\0)
+                                 minor)))]
+          [else (error 'filename-version-part
+                       "unexpected version string: ~s"
+                       (version))])))
diff --git a/collects/dynext/info.ss b/collects/dynext/info.ss
new file mode 100644
index 0000000000..5abfb3b384
--- /dev/null
+++ b/collects/dynext/info.ss
@@ -0,0 +1,5 @@
+
+(module info (lib "infotab.ss" "setup")
+  (define doc.txt "doc.txt")
+  (define name "Dynext"))
+
diff --git a/collects/dynext/link-sig.ss b/collects/dynext/link-sig.ss
new file mode 100644
index 0000000000..7d67a58008
--- /dev/null
+++ b/collects/dynext/link-sig.ss
@@ -0,0 +1,17 @@
+
+(module link-sig mzscheme
+  (require (lib "unitsig.ss"))
+
+  (provide dynext:link^)
+
+  (define-signature dynext:link^
+    (link-extension
+     current-extension-linker
+     current-extension-linker-flags
+     current-make-link-input-strings
+     current-make-link-output-strings
+     current-standard-link-libraries
+     current-use-mzdyn
+     use-standard-linker
+     link-variant
+     expand-for-link-variant)))
diff --git a/collects/dynext/link-unit.ss b/collects/dynext/link-unit.ss
new file mode 100644
index 0000000000..20d8cfd1f0
--- /dev/null
+++ b/collects/dynext/link-unit.ss
@@ -0,0 +1,392 @@
+
+(module link-unit mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "include.ss")
+	   (lib "process.ss")
+	   (lib "sendevent.ss")
+	   "private/dirs.ss"
+           "filename-version.ss")
+
+  (require "link-sig.ss")
+
+  (provide dynext:link@)
+
+  (define dynext:link@
+    (unit/sig dynext:link^
+      (import)
+
+      (define (path-string->string s)
+	(if (string? s) s (path->string s)))
+
+      ;; ---- Find a linker for this platform --------------------
+
+      (define (get-windows-linker)
+	(or (find-executable-path "cl.exe" #f)
+	    (find-executable-path "ld.exe" #f)
+	    (find-executable-path "ilink32.exe" #f)))
+
+      (define (get-unix-linker)
+	(or (getenv "MZSCHEME_DYNEXT_LINKER")
+	    (let ([s (case (string->symbol (path->string (system-library-subpath #f)))
+		       [(rs6k-aix ppc-macosx ppc-darwin) "cc"]
+		       [else "ld"])])
+	      (find-executable-path s s))))
+      
+      ;; See doc.txt:
+      (define current-extension-linker 
+	(make-parameter 
+	 (case (system-type) 
+	   [(unix macosx) (get-unix-linker)]
+	   [(windows) (get-windows-linker)]
+	   [else #f])
+	 (lambda (v)
+	   (when v 
+	     (if (path-string? v)
+		 (unless (and (file-exists? v)
+			      (memq 'execute (file-or-directory-permissions v)))
+		   (error 'current-extension-linker 
+			  "linker not found or not executable: ~s" v))
+		 (raise-type-error 'current-extension-linker "path, valid-path string, or #f" v)))
+	   v)))
+
+      ;; Helpers to tell us about the selected linker in Windows:
+      
+      (define (still-win-gcc?)
+	(and (eq? 'windows (system-type))
+	     (let ([c (current-extension-linker)])
+	       (and c (regexp-match #"ld.exe$" (path-string->string c))))))
+      (define (still-win-borland?)
+	(and (eq? 'windows (system-type))
+	     (let ([c (current-extension-linker)])
+	       (and c (regexp-match #"ilink32.exe$" (path-string->string c))))))
+
+      (define win-gcc? (still-win-gcc?))
+      (define win-borland? (still-win-borland?))
+      
+      ;; ---- The right flags for this platform+linker --------------------
+      
+      ;; We need 
+      ;;   1) the basic flags
+      ;;   2) a way to wrap inputs on the command line
+      ;;   3) a way to wrap the output on the command line
+      ;;   4) needed base libraries and objects
+
+      (define link-variant (make-parameter 
+			    'normal
+			    (lambda (s)
+			      (unless (memq s '(normal 3m))
+				(raise-type-error 'link-variant "'normal or '3m" s))
+			      s)))
+
+      (define (wrap-3m s)
+	(lambda ()
+	  (list (format s (if (eq? '3m (link-variant)) "3m" "")))))
+
+      (define (drop-3m s)
+	(lambda ()
+	  (if (eq? '3m (link-variant))
+	      null
+	      (list s))))
+
+      (define (expand-for-link-variant l)
+	(apply append (map (lambda (s) (if (path-string? s) (list (path-string->string s)) (s))) l)))
+
+      (define current-use-mzdyn (make-parameter #t))
+      (define (mzdyn-maybe s)
+        (lambda ()
+          (if (current-use-mzdyn) (s) null)))
+
+      (define (get-unix-link-flags)
+	(case (string->symbol (path->string (system-library-subpath #f)))
+	  [(sparc-solaris i386-solaris) (list "-G")]
+	  [(sparc-sunos4) (list "-Bdynamic")]
+	  [(i386-freebsd-2.x) (list "-Bshareable")]
+	  [(rs6k-aix) (list "-bM:SRE"
+			    "-brtl"
+			    (lambda () 
+			      (map (lambda (mz-exp)
+				     (format "-bI:~a/~a" include-dir mz-exp))
+				   ((wrap-3m "mzscheme~a.exp"))))
+			    (format "-bE:~a/ext.exp" include-dir)
+			    "-bnoentry")]
+	  [(parisc-hpux) (list "-b")]
+	  [(ppc-macosx ppc-darwin) (list "-bundle" "-flat_namespace" "-undefined" "suppress")]
+	  [else (list "-shared")]))
+
+      (define msvc-linker-flags (list "/LD"))
+      (define win-gcc-linker-flags (list "--dll"))
+      (define borland-linker-flags (list "/Tpd" "/c"))
+      
+      ;; See doc.txt:
+      (define current-extension-linker-flags
+	(make-parameter
+	 (case (system-type)
+	   [(unix macosx) (get-unix-link-flags)]
+	   [(windows) (cond
+		       [win-gcc? win-gcc-linker-flags]
+		       [win-borland? borland-linker-flags]
+		       [else msvc-linker-flags])]
+	   [(macos) null])
+	 (lambda (l)
+	   (unless (and (list? l) (andmap string? l))
+	     (raise-type-error 'current-extension-linker-flags "list of strings" l))
+	   l)))
+
+      ;; See doc.txt:
+      (define current-make-link-input-strings
+	(make-parameter
+	 (lambda (s) (list (path-string->string s)))
+	 (lambda (p)
+	   (unless (procedure-arity-includes? p 1)
+	     (raise-type-error 'current-make-link-input-strings "procedure of arity 1" p))
+	   p)))
+            
+      (define win-gcc-link-output-strings (lambda (s) (list "--base-file"
+							    (path->string (make-win-gcc-temp "base"))
+							    "-e" "_dll_entry@12" 
+							    "-o" (path-string->string s))))
+      (define msvc-link-output-strings (lambda (s) (list (string-append "/Fe" (path-string->string s)))))
+      (define borland-link-output-strings (lambda (s) (list* "," (path-string->string s)
+                                                             "," "," "c0d32.obj" "cw32.lib" "import32.lib"
+                                                             (if (current-use-mzdyn)
+                                                               (list "," (path->string
+                                                                          (build-path std-library-dir 
+                                                                                      "bcc" 
+                                                                                      "mzdynb.def")))
+                                                               null))))
+      
+      ;; See doc.txt:
+      (define current-make-link-output-strings
+	(make-parameter
+	 (case (system-type)
+	   [(unix macosx) (lambda (s) (list "-o" (path-string->string s)))]
+	   [(windows) (cond
+		       [win-gcc? win-gcc-link-output-strings]
+		       [win-borland? borland-link-output-strings]
+		       [else msvc-link-output-strings])]
+	   [(macos) (lambda (s) (list "-o" (path-string->string s)))])
+	 (lambda (p)
+	   (unless (procedure-arity-includes? p 1)
+	     (raise-type-error 'current-make-link-output-strings "procedure of arity 1" p))
+	   p)))
+
+      (define (make-win-link-libraries win-gcc? win-borland?)
+	(let* ([file (lambda (f)
+		       (path->string
+			(build-path std-library-dir 
+				    (cond
+                                     [win-gcc? "gcc"]
+                                     [win-borland? "bcc"]
+                                     [else "msvc"])
+				    f)))]
+               [filethunk (lambda (f)
+                            (lambda ()
+			      (map file (f))))]
+	       [wrap-xxxxxxx
+                (lambda (f)
+                  (lambda ()
+                    (map (lambda (s)
+                           (if (file-exists?
+                                (file (format s filename-version-part)))
+                             (file (format s filename-version-part))
+                             (file (format s "xxxxxxx"))))
+                         (f))))])
+	  (cond
+	   [win-gcc? (list (wrap-xxxxxxx (wrap-3m "libmzsch~a~~a.lib"))
+			   (wrap-xxxxxxx (drop-3m "libmzgc~a.lib"))
+			   (mzdyn-maybe (filethunk (wrap-3m "mzdyn~a.exp")))
+			   (mzdyn-maybe (filethunk (wrap-3m "mzdyn~a.o")))
+			   (file "init.o")
+			   (file "fixup.o"))]
+	   [win-borland? (map file (if (current-use-mzdyn)
+                                     (list "mzdynb.obj")
+                                     null))]
+	   [else (list (wrap-xxxxxxx (wrap-3m "libmzsch~a~~a.lib"))
+		       (wrap-xxxxxxx (drop-3m "libmzgc~a.lib"))
+		       (mzdyn-maybe (filethunk (wrap-3m "mzdyn~a.exp")))
+		       (mzdyn-maybe (filethunk (wrap-3m "mzdyn~a.obj"))))])))
+
+      (define (get-unix/macos-link-libraries)
+	(list (lambda ()
+		(if (current-use-mzdyn)
+                  (map (lambda (mz.o)
+                         (path->string (build-path std-library-dir mz.o)))
+                       ((wrap-3m "mzdyn~a.o")))
+                  null))))
+
+      ;; See doc.txt:
+      (define current-standard-link-libraries
+	(make-parameter
+	 (case (system-type)
+	   [(unix macos macosx) (get-unix/macos-link-libraries)]
+	   [(windows) (make-win-link-libraries win-gcc? win-borland?)])
+	 (lambda (l)
+	   (unless (and (list? l) 
+			(andmap (lambda (s) (or (path-string? s)
+						(and (procedure? s) (procedure-arity-includes? s 0))))
+				l))
+	     (raise-type-error 'current-stand-link-libraries "list of paths/strings and thunks" l))
+	   l)))
+      
+      ;; ---- Function to install standard linker parameters --------------------
+
+      ;; see doc.txt
+      (define (use-standard-linker name)
+	(define (bad-name name)
+	  (error 'use-standard-linker "unknown linker: ~a" name))
+	(case (system-type)
+	  [(unix macosx) 
+	   (case name
+	     [(cc gcc) (current-extension-linker (get-unix-linker))
+	      (current-extension-linker-flags (get-unix-link-flags))
+	      (current-make-link-input-strings (lambda (s) (list (path-string->string s))))
+	      (current-make-link-output-strings (lambda (s) (list "-o" (path-string->string s))))
+	      (current-standard-link-libraries (get-unix/macos-link-libraries))]
+	     [else (bad-name name)])]
+	  [(windows)
+	   (case name
+	     [(gcc) (let ([f (find-executable-path "ld.exe" #f)])
+		      (unless f
+			(error 'use-standard-linker "cannot find gcc's ld.exe"))
+		      (current-extension-linker f)
+		      (current-extension-linker-flags win-gcc-linker-flags)
+		      (current-make-link-input-strings (lambda (s) (list (path-string->string s))))
+		      (current-make-link-output-strings win-gcc-link-output-strings)
+		      (current-standard-link-libraries (make-win-link-libraries #t #f)))]
+	     [(borland) (let ([f (find-executable-path "ilink32.exe" #f)])
+			  (unless f
+			    (error 'use-standard-linker "cannot find ilink32.exe"))
+			  (current-extension-linker f)
+			  (current-extension-linker-flags borland-linker-flags)
+			  (current-make-link-input-strings (lambda (s) (list (path-string->string s))))
+			  (current-make-link-output-strings borland-link-output-strings)
+			  (current-standard-link-libraries (make-win-link-libraries #f #t)))]
+	     [(msvc) (let ([f (find-executable-path "cl.exe" #f)])
+		       (unless f
+			 (error 'use-standard-linker "cannot find MSVC's cl.exe"))
+		       (current-extension-linker f)
+		       (current-extension-linker-flags msvc-linker-flags)
+		       (current-make-link-input-strings (lambda (s) (list (path-string->string s))))
+		       (current-make-link-output-strings msvc-link-output-strings)
+		       (current-standard-link-libraries (make-win-link-libraries #f #f)))]
+	     [else (bad-name name)])]
+	  [(macos)
+	   (case name
+	     [(cw) (current-extension-linker #f)
+	      (current-extension-linker-flags null)
+	      (current-make-link-input-strings (lambda (s) (list (path-string->string s))))
+	      (current-make-link-output-strings (lambda (s) (list "-o" (path-string->string s))))
+	      (current-standard-link-libraries (get-unix/macos-link-libraries))]
+	     [else (bad-name name)])]))
+
+      ;; ---- The link driver for each platform --------------------
+
+      (define unix/windows-link
+	(lambda (quiet? in out)
+	  (let ([c (current-extension-linker)])
+	    (if c
+		(let* ([output-strings
+			((current-make-link-output-strings) out)]
+		       [libs (expand-for-link-variant (current-standard-link-libraries))]
+		       [command 
+			(append 
+			 (list c)
+			 (expand-for-link-variant (current-extension-linker-flags))
+			 (apply append (map (lambda (s) ((current-make-link-input-strings) s))
+					    in))
+			 libs
+			 output-strings)])
+		  (unless quiet? 
+		    (printf "link-extension: ~a~n" command))
+		  (stdio-link (lambda (quiet?)
+				(apply my-process* command))
+			      quiet?)
+
+		  ;; Stange Cygwin system for relocatable DLLs: we run dlltool twice and
+		  ;;  ld three times total
+		  (when (still-win-gcc?)
+		    (let ([dlltool (find-executable-path "dlltool.exe" "dlltool.exe")]
+			  ;; Find base-file name we already made up:
+			  [basefile (let ([m (member "--base-file" output-strings)])
+				      (and m (cadr m)))]
+			  ;; Make new exp file name:
+			  [expfile (make-win-gcc-temp "exp")])
+		      (when (and dlltool basefile)
+			(let* ([dll-command
+				;; Generate DLL link information
+				`("--dllname" ,out 
+				  ,@(if (current-use-mzdyn)
+                                      `("--def" ,(path->string (build-path std-library-dir "gcc" "mzdyn.def")))
+                                      `())
+				  "--base-file" ,basefile
+				  "--output-exp" ,(path->string expfile))]
+			       ;; Command to link with new .exp, re-create .base:
+			       [command1
+				(map (lambda (s)
+				       (if (regexp-match "[.]exp$" s)
+					   (path->string expfile)
+					   s))
+				     command)]
+			       ;; Command to link with new .exp file, no .base needed:
+			       [command2
+				(let loop ([l command1])
+				  (cond
+				   [(null? l) null]
+				   [(string=? (car l) "--base-file")
+				    (cddr l)]
+				   [else (cons (car l) (loop (cdr l)))]))])
+			  (unless quiet?
+			    (printf "link-extension, dlltool phase: ~a~n" 
+				    (cons dlltool dll-command)))
+			  (stdio-link (lambda (quiet?) 
+					(apply my-process* dlltool dll-command))
+				      quiet?)
+			  (unless quiet?
+			    (printf "link-extension, re-link phase: ~a~n" 
+				    command1))
+			  (stdio-link (lambda (quiet?) 
+					(apply my-process* command1))
+				      quiet?)
+			  (unless quiet?
+			    (printf "link-extension, re-dlltool phase: ~a~n" 
+				    (cons dlltool dll-command)))
+			  (stdio-link (lambda (quiet?)
+					(apply my-process* dlltool dll-command))
+				      quiet?)
+			  (unless quiet?
+			    (printf "link-extension, last re-link phase: ~a~n" 
+				    command2))
+			  (stdio-link (lambda (quiet?)
+					(apply my-process* command2))
+				      quiet?)
+			  (delete-file basefile)
+			  (delete-file expfile))))))
+		(error 'link-extension "can't find an installed linker")))))
+      
+      (define (macos-link quiet? input-files output-file)
+	(macos-make 'link-extension "linking-project" "so" quiet? 
+		    input-files output-file null))
+      
+      (define link-extension
+	(case (system-type)
+	  [(unix windows macosx) unix/windows-link]
+	  [(macos) macos-link]))
+
+      ;; ---- some helpers:
+      
+      (define-values (my-process* stdio-link)
+	(let-values ([(p* do-stdio) (include (build-path "private" "stdio.ss"))])
+	  (values
+	   p*
+	   (lambda (start-process quiet?)
+	     (do-stdio start-process quiet? (lambda (s) (error 'link-extension "~a" s)))))))
+      
+      (define (make-win-gcc-temp suffix)
+	(let ([d (find-system-path 'temp-dir)])
+	  (let loop ([n 1])
+	    (let ([f (build-path d (format "tmp~a.~a" n suffix))])
+	      (if (file-exists? f)
+		  (loop (add1 n))
+		  f)))))
+
+      (include (build-path "private" "macinc.ss")))))
diff --git a/collects/dynext/link.ss b/collects/dynext/link.ss
new file mode 100644
index 0000000000..b8d42ba28e
--- /dev/null
+++ b/collects/dynext/link.ss
@@ -0,0 +1,11 @@
+
+(module link mzscheme
+  (require (lib "unitsig.ss"))
+
+  (require "link-sig.ss")
+  (require "link-unit.ss")
+
+  (define-values/invoke-unit/sig dynext:link^
+    dynext:link@)
+
+  (provide-signature-elements dynext:link^))
diff --git a/collects/dynext/linking-project b/collects/dynext/linking-project
new file mode 100644
index 0000000000..96a816c03b
Binary files /dev/null and b/collects/dynext/linking-project differ
diff --git a/collects/dynext/private/dirs.ss b/collects/dynext/private/dirs.ss
new file mode 100644
index 0000000000..a0b1ef3093
--- /dev/null
+++ b/collects/dynext/private/dirs.ss
@@ -0,0 +1,25 @@
+
+(module dirs mzscheme
+  (require (lib "plthome.ss" "setup"))
+
+  (define (find-dir name)
+    (if plthome
+	(build-path plthome name)
+	;; Try one up from each collection path:
+	(let loop ([l (current-library-collection-paths)])
+	  (if (null? l) 
+	      ;; Make up a wrong answer:
+	      (format "plt~a" name)
+	      (let ([p (build-path (car l) 'up name)])
+		(if (directory-exists? p)
+		    p
+		    (loop (cdr l))))))))
+
+  (define include-dir (find-dir "include"))
+  (define std-library-dir (find-dir "lib"))
+
+  (provide include-dir std-library-dir))
+
+
+  
+      
diff --git a/collects/dynext/private/macinc.ss b/collects/dynext/private/macinc.ss
new file mode 100644
index 0000000000..43e49b6694
--- /dev/null
+++ b/collects/dynext/private/macinc.ss
@@ -0,0 +1,64 @@
+  (define (cw-event . args)
+    (apply send-event "CWIE" args))
+  (define (cw . args)
+    (apply cw-event "MMPR" args))
+
+  (define (ping-cw?)
+    (with-handlers ([void (lambda (x) #f)])
+      (cw "GDoc")
+      #t))
+  
+ (define (macos-make name base-project tmp-suffix quiet? input-files output-file includes)
+    (define src-files (map path->complete-path input-files))
+    (define dest-file (path->complete-path output-file))
+    (define proj-dir (build-path (collection-path "dynext")))
+    (define tmp-proj (build-path proj-dir "building-extension"))
+    (define ext-out (build-path proj-dir (format "extension.~a" tmp-suffix)))
+    (define debug-out (string-append ext-out ".xSYM"))
+    (define data-out (string-append tmp-proj " Data"))
+    (define (delete f)
+      (cond
+        [(file-exists? f) (delete-file f)]
+        [(directory-exists? f) (map (lambda (i) (delete (build-path f i))) 
+                                    (directory-list f))
+                               (delete-directory f)]
+        [else (void)]))
+    
+    (when (string=? (system-library-subpath) "68k-mac")
+      (error name "not supported for 68k-mac"))
+    
+    (delete dest-file)
+    (delete tmp-proj)
+    (unless (copy-file (build-path proj-dir base-project) 
+                       tmp-proj)
+         (error name "couldn't create the CodeWarrior project"))
+    
+    (with-handlers ([void (lambda (exn)
+                             (error name "~a" (exn-message exn)))])
+     (let ([started? (ping-cw?)])
+      (unless started?
+        ; Start CW
+        (system "CWIE")
+        (unless (ping-cw?)
+          (sleep 1) ; wait a second...
+          (unless (ping-cw?)
+            (error name "couldn't start CodeWarrior; try starting CW, then leave it open while compiling"))))
+	    ; Open the project
+        (cw-event "aevt" "odoc" `#(file ,tmp-proj))
+        (cw "SDfP" `#(file ,tmp-proj))
+        (cw "AddF" (map (lambda (f) `#(file ,f)) src-files))
+        (cw "Make")
+    	; Clean up
+    	(cw "ClsP")
+    	(unless started?
+          (cw-event "aevt" "quit")
+          (let loop () (sleep 1) (when (ping-cw?) (loop))))))
+          
+    (delete tmp-proj)
+    (delete debug-out)
+    (delete data-out)
+
+    (unless (rename-file-or-directory ext-out dest-file)
+      (unless (copy-file ext-out dest-file)
+      (error name "couldn't move output to destination: ~a" 
+      	     output-file))))
\ No newline at end of file
diff --git a/collects/dynext/private/stdio.ss b/collects/dynext/private/stdio.ss
new file mode 100644
index 0000000000..02277ff576
--- /dev/null
+++ b/collects/dynext/private/stdio.ss
@@ -0,0 +1,50 @@
+
+(values
+ (if (member (system-library-subpath) '("rs6k-aix" "parisc-hpux"))
+     (letrec ([pseudo-process* 
+	       (lambda (c . args)
+		 (if (null? args)
+		     (let ([r (process* "/usr/bin/csh" "-t")])
+		       (display c (cadr r))
+		       (newline (cadr r))
+		       r)
+		     (apply pseudo-process* (string-append c " " (car args)) (cdr args))))])
+	     pseudo-process*)
+     process*)
+ 
+ (lambda (start-process quiet? error)
+   (let* ([l (start-process quiet?)]
+	  [in (car l)]
+	  [out (cadr l)]
+	  [in-error (cadddr l)]
+	  [control (cadddr (cdr l))]
+
+	  [collect-output (box "")]
+	  
+	  [make-collector
+	   (lambda (in dest box)
+	     (thread (lambda () 
+		       (let loop ()
+			 (let ([t (read-line in 'any)])
+			   (unless (eof-object? t)
+			     (unless quiet? (fprintf (dest) "~a~n" t))
+			     (set-box! box (string-append (unbox box) 
+							  (string #\newline) t))
+			     (loop)))))))]
+	  [in-thread (make-collector in current-output-port collect-output)]
+	  [in-error-thread (make-collector in-error current-error-port collect-output)])
+
+     (close-output-port out)
+
+     (control 'wait)
+
+     (thread-wait in-thread)
+     (thread-wait in-error-thread)
+
+     (close-input-port in)
+     (close-input-port in-error)
+
+     (unless (eq? (control 'status) 'done-ok)
+       (error (if quiet?
+		  (unbox collect-output)
+		  "command failed"))))))
diff --git a/collects/embedded-gui/doc.txt b/collects/embedded-gui/doc.txt
new file mode 100644
index 0000000000..d7a1b05dee
--- /dev/null
+++ b/collects/embedded-gui/doc.txt
@@ -0,0 +1,386 @@
+[][][][][][][][][][][][][][][][][][][][][][][][][][][][][][]
+
+                     _embedded_gui.ss_
+
+[][][][][][][][][][][][][][][][][][][][][][][][][][][][][][]
+
+The embedded gui collection provides a class hierarchy for
+creating graphical boxes within mred's editors with geometry
+managment that mirrors that of vertical-panel% and
+horizontal-panel%
+
+============================================================
+
+The _aligned-pasteboard%_ class is derived from pasteboard%
+It implements alignment-parent<%> and acts as the top of an
+alignment<%> tree.
+
+============================================================
+
+_alignment<%> is derived from dllist<%> and requires the
+following additional methods.
+
+> (send an-alignment get-parent) -> (is-a?/c alignment-parent<%>)
+
+The parent of the alignment in the tree.
+
+> (send an-alignment set-min-sizes) -> void
+
+Tells the alignment that its sizes should be calculated
+      
+> (send an-alignment align x-offset y-offset width height) -> void
+  x-offset : nonnegative?
+  y-offset : nonnegative?
+  width : nonnegative?
+  height : nonnegative?
+      
+Tells the alignment to align its children on the pasteboard
+in the given rectangle defined by a width, height and a top
+left corner point given as offsets into the pasteboards top
+left corner.
+
+> (send an-alignment get-min-width) -> nonnegative?
+
+The minimum width this alignment must be
+      
+> (send an-alignment get-min-height) -> nonnegative?
+
+The minimum height this alignment must be
+      
+> (send an-alignment stretchable-width value) -> void
+  value : boolean?
+
+Sets the property of stretchability in the x dimension
+
+> (send an-alignment stretchable-width) -> boolean?
+
+True if the alignment can be stretched in the x dimension
+      
+> (send an-alignment stretchable-height value) -> void
+  value : boolean?
+
+Sets the property of stretchability in the y dimension
+
+> (send an-alignment stretchable-height) -> boolean?
+
+True if the alignment can be stretched in the y dimension
+      
+> (send an-alignment show/hide show?) -> void
+  show? : boolean?
+  
+Tells the alignment to show or hide its children
+      
+> (send an-alignment show show?) -> void
+  show? : boolean?
+
+Tells the alignment that its show state is the given value
+and it should show or hide its children accordingly.
+
+============================================================
+
+_alignment-parent<%>_s implement the following methods.
+
+> (send an-alignment-parent get-pasteboard) -> (is-a?/c pasteboard%)
+
+The pasteboard that this alignment is being displayed to
+      
+> (send an-alignment-parent add-child) -> void
+  child : (is-a?/c alignment<%>)
+  after : (union (is-a?/c alignment<%>) false?) = false
+
+Add the given alignment as a child after the existing child
+      
+> (send an-alignment-parent delete-child child) -> void
+  child : (is-a?/c alignment<%>)
+
+Deletes a child from the the alignments
+      
+> (send an-alignment-parent is-shown?) -> boolean?
+
+True if the alignment is being shown (accounting for its parent being shown)
+
+============================================================
+
+The _stretchable-snip<%>_ interface must be implemented
+by any snip class who's objects will be stretchable when
+inserted into an aligned-pasteboard<%> within a
+snip-wrapper%.
+
+> (send a-stretchable-snip get-aligned-min-width) -> nonnegative?
+
+The minimum width that the snip can be resized to
+
+> (send a-stretchable-snip get-aligned-min-height) -> nonnegative?
+
+The minimum height that the snip can be resized to
+
+> (send a-stretchable-snip stretchable-width) -> boolean?
+
+Whether or not the snip can be stretched in the X dimension
+
+> (send a-stretchable-snip stretchable-height) -> boolean?
+
+Whether or not the snip can be stretched in the Y dimension
+
+============================================================
+
+_dllist<%>_ is an interface which makes a class a
+doublly-linked list and requires the following methods
+
+> (send a-dlllist next) -> (is-a?/c dllist<%>)
+
+The next item in the list
+
+> (send a-dllist next new-next) -> void
+  new-next : (is-a?/c dllist<%>)
+
+Set the next field to be the given dllist
+
+> (send a-dllist prev) -> (is-a?/c dllist<%>)
+
+The previous item in the list
+
+> (send a-dllist prev new-prev) -> void
+  new-prev : (is-a?/c dllist<%>)
+
+Set the previous field to be the given dllist
+
+> (send a-dllist for-each f) -> void
+  f : ((is-a?/c dllist<%>) . -> . void)
+
+Applies f to every element of the dllist
+
+> (send a-dllist map-to-list f) -> (listof any?)
+  f : ((is-a?/c dllist<%>) . -> . any?)
+
+A Scheme list of the results of applying f to every element
+of the dllist.
+
+============================================================
+
+_vertical-alignment%_ and _horizontal-alignment%_ are
+geometry managment classes of the embedded-gui toolkit. They
+implement alignment<%> and alignment-parent<%> and are
+instantiated as follows
+
+> (new vertical-alignment% (parent _) [(show? _)] [(after _)])
+  parent : (is-a?/c alignment-parent<%>)
+  show? : boolean? = true
+  after : (union (is-a?/c alignment<%>) false?) = false
+
+Inserts a new vertical alignment into the parent optionally
+after a given alignment also in the parent. The alignment
+can be initially shown or hidden.
+
+============================================================
+
+_snip-wrapper%_ is an alignment<%> that introduces a snip
+into the alignment tree. snip%s are not instantiated with
+a parent nor do they implement alignment<%>. snip-wrapper%
+is an adapter for snip%s.
+
+> (new snip-wrapper% (parent _) (snip _))
+  parent : (is-a?/c alignment-parent<%>)
+  snip : (is-a?/c snip%)
+
+============================================================
+
+_text-button-snip%_, button-snip%, and toggle-button-snip%
+are three derivative snip% classes that act like buttons
+when inserted into an editor.
+
+Note: In order to allow the buttons to be pushed the editor
+in which they appear must forward clicks to them properly.
+(see click-forwarding-editor-mixin)
+
+> (new text-button-snip% (label _) (callback _))
+  label : string?
+  callback : ((is-a?/c text-button-snip%) (is-a?/c event%) . -> . void)
+
+> (new button-snip% (images _) (callback _))
+  images : (pair string? string?)
+  callback : ((is-a?/c button-snip%) (is-a?/c event%) . -> . void)
+
+The images argument is a pair filenames to be load as the
+button image. The car of the pair is the normal button and the
+cdr of the pair is the depressed button image.
+
+> (new toggle-button-snip% (images-off _) (images-on _) (turn-off _) (turn-on _) [(state _)])
+  images-off : (pair string string)
+  images-on : (pair string string)
+  turn-on : ((is-a?/c toggle-button-snip%) (is-a?/c event%) . -> . void)
+  turn-off : ((is-a?/c toggle-button-snip%) (is-a?/c event%) . -> . void)
+  state : (symbols 'on 'off) = 'on
+
+Like button-snip but given two pairs of images, images-on
+and images-off, and two callback, turn-on and turn-off. The
+initial can be passed as an argument but is by default on.
+
+============================================================
+
+_embedded-button%_, _embedded-text-button%_, and
+_embedded-toggle-button%_ are button classes derived from
+snip-wrapper% that wrap their corresponding snip% derivative
+buttons from above. The embedded buttons implement
+alignment<%> and take an addition parent init argument.
+
+============================================================
+
+The _embedded-message%_ is a label with no IO.
+
+> (new embedded-message% (parent _) (label _))
+  parent : (is-a?/c alignment-parent<%>)
+  label : string?
+
+============================================================
+
+_fixed-width-label-snip_ makes it easy to align GUI elements
+that are labeled with arbitrary strings.
+fixed-width-label-snip is an abstract snip% class that takes
+a list of strings, labels, and returns a snip% class. The
+returned class may be instantiated with a string, label,
+argument matching any of the strings in the list. The
+resultant object is a snip% displaying label with a width as
+wide as is required to display the longest string in labels.
+
+============================================================
+
+_vline%_ and _hline%_ are two graphical elements of the
+alignment<%> hierarchy that display a vertical or horizontal
+line across the region they are inserted into. They implement
+alingment<%>.
+
+> (new vline% (parent _))
+  parent : (is-a?/c alignment-parent<%>)
+
+============================================================
+
+_stretchable-editor-snip-mixin_ gives an editor snip the
+_stretchable-snip<%>_ interface allowing it to be stretched
+to fit it's alignment-parent<%>'s alloted width. Stretchable
+snips are useful as the snip of a snip-wrapper%.
+
+_stretchable-editor-snip%_ is (stretcable-editor-snip-mixin editor-snip%)
+
+> (new stretchable-editor-snip% [(stretchable-width _)] [(stretchable-height _)])
+  stretchable-width : boolean? = true
+  stretchable-height : boolean? = true
+
+============================================================
+
+_tabbable-text<%>_ is an interface for tabbing between
+text%s. It requires the following methods.
+
+> (send a-tabbable-text set-caret-owner) -> void
+
+Takes the caret into the tabbable-text<%>
+
+> (send a-tabbable-text set-ahead) -> void
+
+The thunk to execute when tabbing ahead
+
+> (send a-tabbable-text set-back) -> void
+
+The thunk to execute when tabbing back
+
+============================================================
+
+_tabbable-text-mixin_ gives a text% the tabbable-text<%>
+interface and gives it keybindings to tab ahead and back.
+
+============================================================
+
+The _set-tabbing_ function sets the tabbing order of
+tabbable-text<%>s by setting each text's set-ahead and
+set-back thunks to point to it's neighbor in the argument
+list.
+
+> (set-tabbing a-text ...)
+  a-text : (is-a?/c tabbable-text<%>)
+
+============================================================
+
+The _grey-editor-snip-mixin_ and _grey-editor-mixin_ give an
+editor-snip% and editor% a colored background indicating they
+are disabled. The editor is not disabled by the mixin however,
+and must be locked separately.
+
+============================================================
+
+The _single-line-text-mixin_ restricts a text to one line by
+overriding its keybidings to do nothing on enter.
+
+============================================================
+
+The _cue-text-mixin_ gives a text% an instantiation argument
+of a string that is displayed in the text% initially in grey.
+This text dissappears when the text gets focus. This is
+useful for labeling texts without needing to take up space.
+
+_cue-text%_ is (cue-text-mixin text%)
+
+> (new cue-text% [(cue-text _)])
+  cue-text : string? = ""
+  color : string = "gray"
+  behavior : (listof (symbols 'on-focus 'on-char)) = '(on-focus)
+
+============================================================
+
+The following functions are useful for working with snips
+
+> (snip-width snip) -> number?
+  snip : (is-a?/c snip%)
+
+The width of a snip in the parent pasteboard
+    
+> (snip-height snip)
+  snip : (is-a?/c snip%)
+
+The height of a snip in the parent pasteboard
+  
+> (snip-min-width snip)
+  snip : (is-a?/c snip%)
+
+The minimum width of the snip
+  
+> (snip-min-height snip)
+  snip : (is-a?/c snip%)
+
+The minimum height of the snip
+  
+> (snip-parent snip)
+  snip : (is-a?/c snip%)
+
+The pasteboard that contains the snip
+  
+> (fold-snip f init-acc snip) -> any?
+  f : ((is-a?/c snip%) any? . -> . any?)
+  init-acc : any?
+  snip : (is-a?/c snip%)
+
+The application of f on all snips from snip to the end in a
+foldl foldr mannor
+  
+> (for-each-snip f first-snip init-lists ...) -> void
+  f : ((is-a?/c snip%) . -> . void)
+  first-snip : (is-a?/c snip%)
+  init-lists : (listof any?)
+
+Applies the function to all the snips
+  
+> (map-snip f first-snip init-lists ...) -> (listof any?)
+  f : ((is-a?/c snip%) . -> . any?)
+  first-snip : (is-a?/c snip%)
+  init-lists : (listof any?)
+
+A list of f applied to each snip
+  
+> (stretchable-width? snip) -> boolean?
+  snip : (is-a?/c snip%)
+
+True if the snip can be resized in the x dimention
+  
+> (stretchable-height? snip) -> boolean?
+  snip : (is-a?/c snip%)
+
+True if the snip can be resized in the y dimention
diff --git a/collects/embedded-gui/embedded-gui.ss b/collects/embedded-gui/embedded-gui.ss
new file mode 100644
index 0000000000..5eab56a1a2
--- /dev/null
+++ b/collects/embedded-gui/embedded-gui.ss
@@ -0,0 +1,31 @@
+(module embedded-gui mzscheme
+  
+  (define-syntax (require/provide stx)
+    (syntax-case stx ()
+      [(_ filename ...)
+      #'(begin (require filename ...)
+               (provide (all-from filename) ...))]))
+  
+  (require/provide
+   "private/interface.ss"
+   
+   "private/aligned-pasteboard.ss"
+   "private/verthoriz-alignment.ss"
+   "private/grid-alignment.ss"
+   "private/snip-wrapper.ss"
+   
+   "private/on-show-editor.ss"
+   
+   "private/button-snip.ss"
+   "private/embedded-message.ss"
+   "private/fixed-width-label-snip.ss"
+   "private/lines.ss"
+   
+   "private/stretchable-editor-snip.ss"
+   "private/tabbable-text.ss"
+   "private/grey-editor.ss"
+   "private/single-line-text.ss"
+   "private/cue-text.ss"
+   
+   "private/snip-lib.ss")
+  )
diff --git a/collects/embedded-gui/info.ss b/collects/embedded-gui/info.ss
new file mode 100644
index 0000000000..39cdc37907
--- /dev/null
+++ b/collects/embedded-gui/info.ss
@@ -0,0 +1,5 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Embedded GUI")
+  (define doc.txt "doc.txt"))
+
+
diff --git a/collects/embedded-gui/private/aligned-pasteboard.ss b/collects/embedded-gui/private/aligned-pasteboard.ss
new file mode 100644
index 0000000000..3e5a3c0bc3
--- /dev/null
+++ b/collects/embedded-gui/private/aligned-pasteboard.ss
@@ -0,0 +1,135 @@
+#| Note: It might be a good idea to override insert with an error so that people don't
+   insert or delete from the pasteboard without using the alignment<%>. Then the alignments
+   could go through a different interface for inserting the snips that would call
+   super-insert.
+|#
+
+(module aligned-pasteboard mzscheme
+  
+  (provide aligned-pasteboard%)
+  
+  (require
+   (lib "class.ss")
+   (lib "mred.ss" "mred")
+   (lib "etc.ss")
+   (lib "click-forwarding-editor.ss" "mrlib")
+   "on-show-pasteboard.ss"
+   "really-resized-pasteboard.ss"
+   "interface.ss"
+   "locked-pasteboard.ss"
+   "suppress-modify-editor.ss"
+   "on-show-editor.ss")
+  
+  (define aligned-pasteboard%
+    (class* (click-forwarding-editor-mixin
+             (suppress-modify-editor-mixin
+              (locked-pasteboard-mixin
+               (really-resized-pasteboard-mixin pasteboard%))))
+      (alignment-parent<%> on-show-editor<%>)
+      
+      (inherit begin-edit-sequence end-edit-sequence
+               get-max-view-size refresh-delayed?)
+      
+      (field
+       [alignment false]
+       [lock-alignment-depth 0]
+       [needs-alignment? false])
+      
+      ;;;;;;;;;;
+      ;; insert/delete
+      
+      (rename-super [super-insert insert] [super-release-snip release-snip])
+      (define/override (insert . args) (void))
+      (define/override (release-snip snip) (void))
+      
+      #;((is-a?/c snip%) . -> . void)
+      ;; The insert that can be called from snip-wrappers to install a snip in the pasteboard
+      (define/public (insert-aligned-snip snip)
+        #;(lock-alignment true)
+        (super-insert snip)
+        #;(realign)
+        #;(lock-alignment false))
+      
+      #;((is-a?/c snip%) . -> . void)
+      ;; The release-snip that can be called from snip-wrappers to clear a snip
+      (define/public (release-aligned-snip snip)
+        #;(lock-alignment true)
+        (super-release-snip snip)
+        #;(realign)
+        #;(lock-alignment false))
+      
+      ;;;;;;;;;;
+      ;; alignment-parent<%>
+      
+      #;(-> (is-a?/c pasteboard%))
+      ;; The pasteboard that this alignment is being displayed to
+      (define/public (get-pasteboard) this)
+      
+      #;(((is-a?/c alignment<%>)) ((union (is-a?/c alignment<%>) false?)) . opt-> . void?)
+      ;; Add the given alignment as a child before the existing child
+      (define/public add-child
+        (opt-lambda (child (after #f))
+          (if alignment
+              (error 'add-child "There may be only one alignment<%> of a pasteboard")
+              (set! alignment child))))
+      
+      #;((is-a?/c alignment<%>) . -> . void?)
+      ;; Deletes a child from the the alignments
+      (define/public (delete-child child)
+        (if alignment
+            (if (eq? child alignment)
+                (set! alignment false)
+                (error 'delete-child "Child not found"))
+            (error 'delete-child "No children")))
+      
+      #;(-> (listof (is-a?/c alignment<%>)))
+      ;; A list of the children of this alignment parent
+      (define/public (get-children) (list alignment))
+            
+      #;(-> boolean?)
+      ;; True if the alignment is being shown (accounting for its parent being shown)
+      ;; NOTE: Pasteboards are always shown and have no show/hide state.
+      (define/public (is-shown?) true)
+      
+      #;((is-a?/c snip%) . -> . void?)
+      ;; Called when a snip in the pasteboard changes its size
+      ;; Overriden because the layout will change when a snip gets bigger.
+      (define/override (really-resized snip)
+        (super really-resized snip)
+        (realign))
+      
+      #;(-> void)
+      ;; Called when the pasteboard is first shown.
+      ;; Overriden because I need to know when the snips have their size to lay them out.
+      (define/public (on-show)
+        (realign))
+      
+      #;(boolean? . -> . void?)
+      ;; Locks the pasteboard so that all alignment requests are delayed until after it's done.
+      ;; STATUS: I can still observe inserts of the interactions when I paste an interactions box.
+      ;; I need to figure out why these edit-sequences are not hiding them.
+      (define/public (lock-alignment lock?)
+        (set! lock-alignment-depth ((if lock? add1 sub1) lock-alignment-depth))
+        (case lock-alignment-depth
+          [(0) (when needs-alignment? (realign))
+               (unless lock? (end-edit-sequence))]
+          [(1) (when lock? (begin-edit-sequence))]
+          [else (void)]))
+      
+      #;(-> void?)
+      ;; Realigns the snips in the pasteboard according to the alignment tree.
+      (define/public (realign)
+        (if (zero? lock-alignment-depth)
+            (fluid-let ([lock-alignment-depth (add1 lock-alignment-depth)])
+              (begin-edit-sequence)
+              (send alignment set-min-sizes)
+              (let ([width (send alignment get-min-width)]
+                    [height (send alignment get-min-height)])
+                (unless (or (zero? width) (zero? height))
+                  (send alignment align 0 0 width height)
+                  (set! needs-alignment? false)))
+              (end-edit-sequence))
+            (set! needs-alignment? true)))
+      
+      (super-new)))
+  )
diff --git a/collects/embedded-gui/private/alignment-helpers.ss b/collects/embedded-gui/private/alignment-helpers.ss
new file mode 100644
index 0000000000..85b8b0db96
--- /dev/null
+++ b/collects/embedded-gui/private/alignment-helpers.ss
@@ -0,0 +1,74 @@
+(module alignment-helpers mzscheme
+  
+  (require
+   (lib "list.ss")
+   (lib "class.ss")
+   (lib "mred.ss" "mred")
+   (lib "contract.ss")
+   
+   "interface.ss"
+   "snip-lib.ss")
+  
+  (provide/contract
+   (vacuous-max (() (listof number?) . ->* . (number?)))
+   (child-height ((union (is-a?/c alignment<%>) (is-a?/c snip%)) . -> . number?))
+   (child-width ((union (is-a?/c alignment<%>) (is-a?/c snip%)) . -> . number?))
+   (insert-before (any/c (listof any/c) any/c . -> . (listof any/c)))
+   (insert-after (any/c (listof any/c) any/c . -> . (listof any/c))))
+  
+  (define (vacuous-max . n)
+    (if (empty? n)
+        0
+        (apply max n)))
+  
+  #|
+  (equal? (vacuous-max 5 2) 5)
+  (equal? (vacuous-max) 0)
+  (equal? (vacuous-max -2 6) 6)
+  (equal? (vacuous-max -3 -5) -3)
+  (equal? (vacuous-max -2 0) 0)
+  |#
+  
+  (define (child-height item)
+    (cond
+      [(is-a? item snip%) (snip-min-height item)]
+      [(is-a? item alignment<%>) (send item get-min-height)]))
+  
+  (define (child-width item)
+    (cond
+      [(is-a? item snip%) (snip-min-width item)]
+      [(is-a? item alignment<%>) (send item get-min-width)]))
+  
+  (define ((insert how) item alist reference)
+    (cond
+      [(empty? alist) (error 'insert "Could not find item in list")]
+      [(cons? alist)
+       (if (equal? (first alist) reference)
+           (how item (first alist) (rest alist))
+           (cons (first alist)
+                 ((insert how) item (rest alist) reference)))]))
+  
+  (define insert-before
+    (insert (lambda (item the-first the-rest)
+              (cons item
+                    (cons the-first the-rest)))))
+  
+  (define insert-after
+    (insert (lambda (item the-first the-rest)
+              (cons the-first
+                    (cons item the-rest)))))
+  #|
+  (equal? (insert-before 1 '(3 4 2 5) 2)
+          '(3 4 1 2 5))
+  (equal? (insert-before 1 '(1) 1)
+          '(1 1))
+  (equal? (insert-before 0 '(5 -5 6 -5) -5)
+          '(5 0 -5 6 -5))
+  (equal? (insert-after 1 '(3 4 2 5) 2)
+          '(3 4 2 1 5))
+  (equal? (insert-after 1 '(1) 1)
+          '(1 1))
+  (equal? (insert-after 0 '(5 -5 6 -5) -5)
+          '(5 -5 0 6 -5))
+  |#
+  )
\ No newline at end of file
diff --git a/collects/embedded-gui/private/alignment.ss b/collects/embedded-gui/private/alignment.ss
new file mode 100644
index 0000000000..7d265aaad2
--- /dev/null
+++ b/collects/embedded-gui/private/alignment.ss
@@ -0,0 +1,150 @@
+#|
+This code computes the sizes for the rectangles in the space using the on dimention
+off dimention method of referencing sizes. This means for example instead of saying
+width we say off dimention for vertical alignment. Inorder to consume and return
+the values in terms of width and height manipulation had to be done. I chose to create
+a struct abs-rect (abstract rectangle) and have code map horizontal and vertical rect
+stucts on to them. This code is a bit long but more readable than the other two options
+I came up with.
+  1) define all functions to be letrec bound functions inside align. align then take
+     accessors for the rect struct. The caller of align swaps the order of ondimention
+     and off dimention accessors for vertical or horizontal code. This method does not
+     allow the use of the readable, short, consis pattern matching code. As some of the
+     matching code is easily removed this may be a good option but a large letrec
+     is harder to write tests for.
+  2) define a pattern matcher syntax that will match the struct rect but swap the fields
+     based on wich on is the on or off dimention. This would have been shorter but much
+     more confusing.
+The current implementation requires align to map over the rects and allocate new stucts
+for each one on both passing into and returning from stretch-to-fit; This is not a bottle
+neck and it is the most readable solution.
+|#
+
+(module alignment mzscheme
+  
+  (require
+   (lib "match.ss")
+   (lib "contract.ss")
+   (lib "etc.ss")
+   (lib "list.ss"))
+  
+  (define-struct rect (x y) (make-inspector))
+  (define-struct abs-rect (ondim offdim) (make-inspector))
+  (define-struct dim (pos size stretchable?) (make-inspector))
+  
+  (define (nonnegative? n)
+    (and (number? n)
+         (or (positive? n)
+             (zero? n))))
+  
+  (provide/contract
+   (struct rect ((x dim?) (y dim?)))
+   (struct abs-rect ((ondim dim?) (offdim dim?)))
+   (struct dim ((pos nonnegative?) (size nonnegative?) (stretchable? boolean?)))
+   (align ((symbols 'horizontal 'vertical)
+           nonnegative? nonnegative? (listof rect?)
+           . -> . (listof rect?))))
+  
+  ;; align the rectangles within the given space
+  (define (align type width height rects)
+    (cond
+      [(symbol=? type 'horizontal)
+       (map abs->horiz (stretch-to-fit width height (map horiz->abs rects)))]
+      [(symbol=? type 'vertical)
+       (map abs->vert (stretch-to-fit height width (map vert->abs rects)))]))
+  
+  #;(abs-rect? . -> . rect?)
+  ;; convert an abstract rect to a horizontal rect
+  (define abs->horiz
+    (match-lambda
+      [($ abs-rect ondim offdim)
+       (make-rect ondim offdim)]))
+  
+  #;(abs-rect? . -> . rect?)
+  ;; convert an abstract rect to a vertical rect
+  (define abs->vert
+    (match-lambda
+      [($ abs-rect ondim offdim)
+       (make-rect offdim ondim)]))
+  
+  #;(rect? . -> . abs-rect?)
+  ;; convert a horizontal rect to an abstract rect
+  (define horiz->abs
+    (match-lambda
+      [($ rect x y)
+       (make-abs-rect x y)]))
+  
+  #;(rect? . -> . abs-rect?)
+  ;; convert a vertical rect to an abstract rect
+  (define vert->abs
+    (match-lambda
+      [($ rect x y)
+       (make-abs-rect y x)]))
+  
+  #;(positive? positive? (listof abs-rect?) . -> . (listof abs-rect?))
+  ;; stretch the rectangles to fit with the given space
+  (define (stretch-to-fit onsize offsize rects)
+    (let-values ([(total-unstretchable-size stretchable-sizes)
+                  (get-onsizes rects)])
+      (let-values ([(extra-div extra-mod)
+                    (get-extra/rect
+                     (- onsize total-unstretchable-size)
+                     (quicksort stretchable-sizes >))])
+        (allocate-evenly/position extra-div extra-mod offsize rects))))
+  
+  #;(((listof rect?)) . ->* . (nonnegative? (listof nonnegative?)))
+  ;; gets the unstretchable total size and a list of the stretchable sizes
+  (define (get-onsizes init-rects)
+    (let loop ([extra 0]
+               [stretchables empty]
+               [rects init-rects])
+      (match rects
+        [() (values extra stretchables)]
+        [(($ abs-rect ($ dim _ onsize #f) _) rest-rects ...)
+         (loop (+ onsize extra) stretchables rest-rects)]
+        [(($ abs-rect ($ dim _ onsize #t) _) rest-rects ...)
+         (loop extra (cons onsize stretchables) rest-rects)])))
+  
+  #;((nonnegative? (listof nonnegative?)) . ->* . (nonnegative? nonnegative?))
+  ;; get the space that each stretchable snip will have
+  (define (get-extra/rect init-extra init-sizes)
+    (let loop ([sizes init-sizes]
+               [extra init-extra]
+               [count (length init-sizes)])
+      (cond
+        [(empty? sizes) (values 0 0)]
+        [else
+         (let ([extra/rect (quotient (floor extra) count)]
+               [onsize (first sizes)])
+           (if (> onsize extra/rect)
+               (loop (rest sizes) (- extra onsize) (sub1 count))
+               (values extra/rect (modulo (floor extra) count))))])))
+  
+  #;((cons/p nonnegative? nonnegative?) positive? (listof abs-rect?) . -> . (listof abs->rect?))
+  ;; allocate the extra per rectangle to the stretchable rects and move them to their positions
+  (define (allocate-evenly/position extra-div extra-mod offsize init-rects)
+    (let ([mod (waner extra-mod)])
+      (let loop ([rects init-rects]
+                 [onpos 0])
+        (match rects
+          [() empty]
+          [(($ abs-rect ($ dim _ min-onsize onstretch?)
+               ($ dim _ min-offsize offstretch?)) rest-rects ...)
+           (let ([onsize (if (and onstretch?
+                                  (< min-onsize extra-div))
+                             (+ extra-div (mod)) min-onsize)]
+                 [offsize (if offstretch? offsize min-offsize)])
+             (cons (make-abs-rect (make-dim onpos onsize onstretch?)
+                                  (make-dim 0 offsize offstretch?))
+                   (loop rest-rects (+ onpos onsize))))]))))
+  
+  #;(natural-number? . -> . (-> (union 1 0)))
+  ;; makes a thunk that returns 1 for it's first n applications, zero otherwise
+  (define (waner n)
+    (lambda ()
+      (if (zero? n)
+          0
+          (begin
+            (set! n (sub1 n))
+            1))))
+  )
\ No newline at end of file
diff --git a/collects/embedded-gui/private/button-snip.ss b/collects/embedded-gui/private/button-snip.ss
new file mode 100644
index 0000000000..ac8f345fd5
--- /dev/null
+++ b/collects/embedded-gui/private/button-snip.ss
@@ -0,0 +1,198 @@
+#| Rewrite these to use snip-wrapper% automatically |#
+
+(module button-snip mzscheme
+  
+  (require
+   (lib "mred.ss" "mred")
+   (lib "class.ss")
+   (lib "etc.ss")
+   "snip-wrapper.ss")
+  
+  (provide
+   text-button-snip%
+   button-snip%
+   toggle-button-snip%
+   embedded-button%
+   embedded-text-button%
+   embedded-toggle-button%)
+  
+  (define embedded-button%
+    (class snip-wrapper%
+      (init images callback)
+      (super-new
+       (snip (new button-snip%
+                  (images images)
+                  (callback callback))))))
+  
+  (define embedded-text-button%
+    (class snip-wrapper%
+      (init label callback)
+      (super-new
+       (snip (new text-button-snip%
+                  (label label)
+                  (callback callback))))))
+  
+  (define embedded-toggle-button%
+    (class snip-wrapper%
+      (init images-off images-on turn-off turn-on (state 'on))
+      (field [btn (new toggle-button-snip%
+                       (images-off images-off)
+                       (images-on images-on)
+                       (turn-off turn-off)
+                       (turn-on turn-on)
+                       (state state))])
+      ;; Provide the original toggle-button-snip% interface
+      (define/public (set-state x) (send btn set-state x))
+      (super-new (snip btn))))
+  
+  ;; a snip of a button that can be pushed to invoke a given callback
+  (define button-snip%
+    (class image-snip%
+      (inherit load-file)
+      (init images)
+      (init-field callback)
+      (field
+       [got-click? false]
+       [inside? false]
+       [image (car images)]
+       [depressed (cdr images)])
+      
+      ;; (string? . -> . void?)
+      ;; set the image to be displayed on the button when it is not clicked
+      (define/public (set-images i)
+        (set! image (car i))
+        (set! depressed (cdr i))
+        (load-file image))
+      
+      ;; Should I be calling super-on-event?
+      (define/override (on-event dc x y editorx editory event)
+        (case (send event get-event-type)
+          [(left-down)
+           (set! got-click? true)
+           (set! inside? true)
+           (load-file depressed)]
+          [(left-up)
+           (load-file image)
+           (when (and got-click? inside?)
+             (callback this event))
+           (set! got-click? false)
+           (set! inside? false)]
+          [(enter)
+           (set! inside? true)
+           (when got-click?
+             (load-file depressed))]
+          [(leave)
+           (set! inside? false)
+           (when got-click?
+             (load-file image))]
+          [else (void)]))
+      
+      (super-new)
+      (load-file image)))
+  
+  ;; a textual button of the same type
+  (define text-button-snip%
+    (class string-snip%
+      (init label)
+      (init-field callback)
+      (field
+       [got-click? false]
+       [inside? false])
+
+      (define/override (on-event dc x y editorx editory event)
+        (case (send event get-event-type)
+          [(left-down)
+           (set! got-click? true)
+           (set! inside? true)]
+          [(left-up)
+           (when (and got-click? inside?)
+             (callback this event))
+           (set! got-click? false)
+           (set! inside? false)]
+          [(enter)
+           (set! inside? true)]
+          [(leave)
+           (set! inside? false)]
+          [else (void)]))
+      
+      (super-make-object label)
+      (inherit set-style)
+      (set-style control-style)))
+  
+  ;; a toggle button that displays different images
+  (define toggle-button-snip%
+    (class button-snip%
+      (inherit set-images)
+      (init-field images-off images-on turn-off turn-on (state 'on))
+      
+      ;; Emulates clicking the button to a certain state
+      (define/public (turn astate)
+        (case astate
+          [(off) (set-state 'off)
+                 (turn-on this #f)]
+          [(on) (set-state 'on)
+                (turn-off this #f)]))
+      
+      (define/public (set-state value)
+        (case value
+          [(off) (set-images images-off)
+                 (set! state 'off)]
+          [(on) (set-images images-on)
+                (set! state 'on)]))
+      
+      (super-new
+       (images (case state
+                 [(on) images-on]
+                 [(off) images-off]))
+       (callback
+        (lambda (b e)
+          ;; NOTE: I lose the event right here, but turn can't require it.
+          ;; Since it's public.
+          (case state
+            [(on) (turn 'off)]
+            [(off) (turn 'on)]))))))
+  
+  ;;;;;;;;;;
+  ;; tests
+  #|
+  (require
+   (lib "locked-pasteboard.ss" "mrlib" "private" "aligned-pasteboard")
+   (lib "click-forwarding-editor.ss" "mrlib"))
+  
+  (define (test)
+    (define f (new frame% (label "test") (width 200) (height 200)))
+    (define e (new (locked-pasteboard-mixin
+                    (click-forwarding-editor-mixin pasteboard%))))
+    (define c (new editor-canvas% (editor e) (parent f)))
+    (define b (new button-snip%
+                   (images (cons (build-path (collection-path "icons") "turn-up.gif")
+                                 (build-path (collection-path "icons") "turn-up-click.gif")))
+                   (callback
+                    (lambda (b e)
+                      (message-box "Test" "Horray!")))))
+    (send e insert b)
+    (send f show #t))
+  
+  (define (test2)
+    (define f (new frame% (label "test") (width 200) (height 200)))
+    (define e (new (locked-pasteboard-mixin
+                    (click-forwarding-editor-mixin pasteboard%))))
+    (define c (new editor-canvas% (editor e) (parent f)))
+    (define t (new text%))
+    (define es (new editor-snip% (editor t)))
+    (define b (new toggle-button-snip%
+                   (images-on (cons (build-path (collection-path "icons") "turn-up.gif")
+                                  (build-path (collection-path "icons") "turn-up-click.gif")))
+                   (images-off (cons (build-path (collection-path "icons") "turn-down.gif")
+                                  (build-path (collection-path "icons") "turn-down-click.gif")))
+                   (turn-on
+                    (lambda (b e)
+                      (send* t (erase) (insert "Up"))))
+                   (turn-off
+                    (lambda (b e)
+                      (send* t (erase) (insert "Down"))))))
+    (send e insert es 50 0)
+    (send e insert b)
+    (send f show #t))
+  |#
+)
diff --git a/collects/embedded-gui/private/cue-text.ss b/collects/embedded-gui/private/cue-text.ss
new file mode 100644
index 0000000000..a8f874354f
--- /dev/null
+++ b/collects/embedded-gui/private/cue-text.ss
@@ -0,0 +1,68 @@
+#| This module provides a text that has the an init argument of a string
+   that is displayed in the text initially. This text acts as a cue or a
+   label for that text and goes away when it is typed into.
+|#
+#| TODO: Adjust read methods like get-text and write-to-file so that if the
+   cue text is still in the editor when they are called the result is that
+   the text appears empty.
+|#
+(module cue-text mzscheme
+  
+  (require
+   (lib "class.ss")
+   (lib "mred.ss" "mred")
+   (lib "etc.ss")
+   (lib "framework.ss" "framework"))
+  
+  (provide cue-text-mixin
+           cue-text%)
+  
+  (define cue-text-mixin
+    (mixin ((class->interface text%)) ()
+      (inherit insert change-style erase)
+      (init [cue-text ""]
+            [color "gray"])
+      (init-field
+       [behavior '(on-focus)])
+      (field [first-focus? true])
+      
+      #;(-> void)
+      ;; Clears the cue-text if it's still there.
+      (define (clear-cue-text)
+        (when first-focus?
+          (set! first-focus? false)
+          (erase)))
+      
+      #;(boolean? . -> . void)
+      ;; Called when this text% gains or loses focus
+      (define/override (on-focus on?)
+        (when (and on? (member 'on-focus behavior))
+          (clear-cue-text))
+        (super on-focus on?))
+      
+      #;((is-a?/c keyevent%) . -> . void)
+      ;; Called when the keyboard is used with focus in this text
+      (define/override (on-local-char akeyevent)
+        (when (member 'on-char behavior)
+          (clear-cue-text))
+        (super on-local-char akeyevent))
+      
+      ;; Insert the cue text into the text% on instantiation
+      (super-new)
+      (let ([grey-text (new style-delta%)])
+        (send grey-text set-delta-foreground color)
+        (change-style grey-text 'start 'end #f))
+      (insert cue-text)))
+  
+  (define cue-text% (cue-text-mixin text%))
+  
+  #|
+  (define f (new frame% (label "f") (width 400) (height 400)))
+  (define e (new text%))
+  (define c (new editor-canvas% (editor e) (parent f)))
+  (define t (new cue-text% (cue-text "Hello, World!")))
+  (define s (new editor-snip% (editor t)))
+  (send e insert s)
+  (send f show #t)
+  |#
+  )
\ No newline at end of file
diff --git a/collects/embedded-gui/private/dllist.ss b/collects/embedded-gui/private/dllist.ss
new file mode 100644
index 0000000000..75fe98d515
--- /dev/null
+++ b/collects/embedded-gui/private/dllist.ss
@@ -0,0 +1,52 @@
+(module dllist mzscheme
+  
+  (require
+   (lib "class.ss")
+   (lib "list.ss")
+   (lib "etc.ss")
+   (lib "framework.ss" "framework")
+   "interface.ss")
+  
+  (provide dllist-mixin dllist% head% tail%)
+  
+  (define dllist-mixin
+    (mixin () (dllist<%>)
+      (field [nextf #f] [prevf #f])
+      (define/public next
+        (case-lambda
+          [(n) (set! nextf n)]
+          [() nextf]))
+      (define/public prev
+        (case-lambda
+          [(p) (set! prevf p)]
+          [() prevf]))
+      (define/public (for-each f . lol)
+        (apply f this (map first lol))
+        (send/apply nextf for-each f (map rest lol)))
+      (define/public (map-to-list f)
+        (cons (f this) (send nextf map-to-list f)))
+      (super-new)))
+  
+  (define dllist% (dllist-mixin object%))
+  
+  (define head%
+    (class* dllist% (dllist<%>)
+      (inherit next)
+      (define/override prev
+        (opt-lambda ((p #f))
+          (error 'prev "Head has no prev")))
+      (define/override (for-each f . lol)
+        (send/apply (next) for-each f lol))
+      (define/override (map-to-list f)
+        (send (next) map-to-list f))
+      (super-new)))
+  
+  (define tail%
+    (class* dllist% (dllist<%>)
+      (define/override next
+        (opt-lambda ((n #f))
+          (error 'next "Tail has no next")))
+      (define/override (for-each f . lol) (void))
+      (define/override (map-to-list f) empty)
+      (super-new)))
+  )
diff --git a/collects/embedded-gui/private/embedded-message.ss b/collects/embedded-gui/private/embedded-message.ss
new file mode 100644
index 0000000000..7da56c0e53
--- /dev/null
+++ b/collects/embedded-gui/private/embedded-message.ss
@@ -0,0 +1,19 @@
+(module embedded-message mzscheme
+  
+  (require
+   (lib "mred.ss" "mred")
+   (lib "class.ss")
+   "snip-wrapper.ss")
+  
+  (provide embedded-message%)
+
+  (define embedded-message%
+    (class snip-wrapper%
+      
+      (init label)
+      
+      (super-new
+       (snip (let ([s (make-object string-snip% label)])
+	       (send s set-style control-style)
+	       s)))))
+  )
\ No newline at end of file
diff --git a/collects/embedded-gui/private/fixed-width-label-snip.ss b/collects/embedded-gui/private/fixed-width-label-snip.ss
new file mode 100644
index 0000000000..14fd0be942
--- /dev/null
+++ b/collects/embedded-gui/private/fixed-width-label-snip.ss
@@ -0,0 +1,129 @@
+(module fixed-width-label-snip mzscheme
+  
+  (require
+   (lib "class.ss")
+   (lib "list.ss")
+   (lib "mred.ss" "mred"))
+  
+  (provide fixed-width-label-snip)
+  
+  (define (fixed-width-label-snip labels)
+    (define label-snip%
+      (class snip%
+        (inherit set-snipclass)
+        (init-field
+         label
+         (with-border? #f)
+         (left-margin 5)
+         (right-margin 5)
+         (top-margin 5)
+         (bottom-margin 5)
+         (left-inset 1)
+         (top-inset 1)
+         (right-inset 1)
+         (bottom-inset 1))
+        
+        (field [font normal-control-font])
+        
+        (unless (member label labels)
+          (error 'fixed-width-label-snip
+                 "Instantiation of label-snip expected one of ~s. Given ~s"
+                 labels
+                 label))
+        
+        (define (get-string-width dc string)
+          (let-values ([(width height baseline vspace)
+                        (send dc get-text-extent string font)])
+            width))
+        
+        (define (get-string-height dc string)
+          (let-values ([(width height baseline vspace)
+                        (send dc get-text-extent string font)])
+            height))
+        
+        (define (get-max-string-width dc strings)
+          (foldl
+           (lambda (str max-width)
+             (max (get-string-width dc str) max-width))
+           (get-string-width dc (first strings))
+           (rest strings)))
+        
+        (define (get-max-string-height dc strings)
+          (foldl
+           (lambda (str max-height)
+             (max (get-string-height dc str) max-height))
+           (get-string-height dc (first strings))
+           (rest strings)))
+        
+        (define/override (get-extent dc x y w h descent space lspace rspace)
+          (let ([width (get-max-string-width dc labels)]
+                [height (get-max-string-height dc labels)])
+            (when w (set-box! w (+ left-margin width right-margin)))
+            (when h (set-box! h (+ top-margin height bottom-margin)))))
+        
+        (define/override (draw dc x y left top right bottom dx dy draw-caret)
+          (super draw dc x y left top right bottom dx dy draw-caret)
+          (let ([max-width (get-max-string-width dc labels)]
+                [width (get-string-width dc label)]
+                [max-height (get-max-string-height dc labels)])
+            (let ([f (send dc get-font)])
+              (send dc set-font font)
+              (send dc draw-text label
+                    (+ left-margin x (- max-width width))
+                    (+ y top-margin))
+              (send dc set-font f))
+            (when with-border?
+              (let ((w (+ left-margin max-width right-margin))
+                    (h (+ top-margin max-height bottom-margin)))
+                (send dc draw-lines 
+                      (list (make-object point% left-inset top-inset)
+                            (make-object point% left-inset (- h bottom-inset))
+                            (make-object point% (- w right-inset) (- h bottom-inset))
+                            (make-object point% (- w right-inset) top-inset)
+                            (make-object point% left-inset top-inset))
+                    x 
+                    y)))))
+        
+        ;(define/override (copy)
+        ;  (super copy))
+        
+        (define/override (resize w h) #f)
+        
+        ;; write ((is-a?/c editor-stream-out%) . -> . void?)
+        ;; write the snip out to the stream
+        (define/override (write f)
+          (send f put label))
+        
+        (super-new)
+        (set-snipclass (new label-snip-class%))))
+    
+    (define label-snip-class%
+      (class snip-class%
+        ;; read ((is-a?/c editor-stream-in%) . -> . snip%)
+        ;; read a snip from the stream
+        (define/override (read f)
+          (new label-snip% (label (send f get-string))))
+        (super-new)))
+    
+    (let ([lsc (new label-snip-class%)])
+      (send lsc set-classname "...")
+      (send lsc set-version 1)
+      (send (get-the-snip-class-list) add lsc))
+    
+    label-snip%)
+
+  ;;;;;;;;;;
+  ;; tests
+  
+  ;(define mylabels (list "Call" "Expected" "Actual"))
+  ;(define label% (fixed-width-label-snip mylabels))
+  ;(define align? #t)
+  ;(define f (new frame% (label "test") (width 175) (height 175)))
+  ;(define e (new pasteboard%))
+  ;(define c (new editor-canvas% (editor e) (parent f)))
+  ;(for-each
+  ; (lambda (s)
+  ;   (send e insert (new label% (label s))))
+  ; '("Expected"))
+  ;(send f show #t)
+  )
diff --git a/collects/embedded-gui/private/grey-editor.ss b/collects/embedded-gui/private/grey-editor.ss
new file mode 100644
index 0000000000..64c0120918
--- /dev/null
+++ b/collects/embedded-gui/private/grey-editor.ss
@@ -0,0 +1,54 @@
+(module grey-editor mzscheme
+  
+  (provide grey-editor-snip-mixin grey-editor-mixin)
+  
+  (require
+   (lib "mred.ss" "mred")
+   (lib "class.ss")
+   (lib "framework.ss" "framework"))
+  
+  (define *disable-color* (make-object color% 235 235 255))
+  
+  (define grey-editor-snip-mixin
+    (mixin ((class->interface editor-snip%)) ()
+      (inherit get-admin get-inset)
+      (define/override (draw dc x y left top right bottom dx dy draw-caret)
+        (let ([old-pen (send dc get-pen)]
+              [old-brush (send dc get-brush)]
+              [admin (get-admin)]
+              [left-inset (box 0)]
+              [top-inset (box 0)]
+              [right-inset (box 0)]
+              [bottom-inset (box 0)]
+              [xb (box 0)]
+              [yb (box 0)]
+              [wb (box 0)]
+              [hb (box 0)])
+          (when admin
+            (send admin get-view xb yb wb hb this)
+            (get-inset left-inset top-inset right-inset bottom-inset)
+            (send dc set-pen (send the-pen-list find-or-create-pen *disable-color* 1 'solid))
+            (send dc set-brush (send the-brush-list find-or-create-brush *disable-color* 'solid))
+            (send dc draw-rectangle
+                  (+ x (unbox xb) (unbox left-inset))
+                  (+ y (unbox yb) (unbox top-inset))
+                  (max 0 (- (unbox wb) (+ (unbox left-inset) (unbox right-inset))))
+                  (max 0 (- (unbox hb) (+ (unbox top-inset) (unbox bottom-inset)))))
+            (send dc set-pen old-pen)
+            (send dc set-brush old-brush)))
+        (super draw dc x y left top right bottom dx dy draw-caret))
+      (super-new)))
+  
+  (define grey-editor-mixin
+    (mixin (editor<%>) ()
+      (define/override (on-paint before? dc left top right bottom dx dy draw-caret)
+        (when before?
+          (let ([old-pen (send dc get-pen)]
+                [old-brush (send dc get-brush)])
+            (send dc set-pen (send the-pen-list find-or-create-pen *disable-color* 1 'solid))
+            (send dc set-brush (send the-brush-list find-or-create-brush *disable-color* 'solid))
+            (send dc draw-rectangle (+ left dx) (+ top dy) (+ right dx) (+ bottom dy))
+            (send dc set-pen old-pen)
+            (send dc set-brush old-brush)))
+        (super on-paint before? dc left top right bottom dx dy draw-caret))
+      (super-new))))
diff --git a/collects/embedded-gui/private/grid-alignment.ss b/collects/embedded-gui/private/grid-alignment.ss
new file mode 100644
index 0000000000..44a77bfd1b
--- /dev/null
+++ b/collects/embedded-gui/private/grid-alignment.ss
@@ -0,0 +1,142 @@
+#| Not yet functional |#
+
+(module grid-alignment mzscheme
+  (define grid-alignment #f)
+  (provide grid-alignment))
+
+#;(module grid-alignment mzscheme
+  
+  (require
+   (lib "class.ss")
+   (lib "mred.ss" "mred")
+   (lib "etc.ss")
+   (lib "list.ss")
+   (lib "match.ss")
+   (prefix a: "alignment.ss")
+   (lib "click-forwarding-editor.ss" "mrlib")
+   
+   "on-show-pasteboard.ss"
+   "really-resized-pasteboard.ss"
+   "interface.ss"
+   "snip-lib.ss"
+   "alignment-helpers.ss")
+  
+  (provide grid-alignment%)
+  
+  ;; totally broken and not up to date with last revision
+  (define grid-alignment%
+    (class* object% (#;alignment<%>)
+      (init-field
+       columns
+       (parent false))
+      (field
+       [pasteboard false]
+       [rows empty]
+       [row-heights 0]
+       [column-widths 0]
+       [show? true])
+      
+      ;; need base class for this method
+      (define (show/hide-child child show?)
+        (if (is-a? child alignment<%>)
+            (send child show show?)
+            (if show?
+                (send pasteboard insert child)
+                (send pasteboard release-snip child))))
+      
+      (define/public (add row)
+        (set! rows (append rows (list row)))
+        (unless (= (vector-length row) columns)
+          (error 'add "Invalid number of rows"))
+        (send pasteboard lock-alignment true)
+        (let loop ([column 0])
+          (unless (>= column columns)
+            (let ([child (vector-ref row column)])
+              (cond
+                [(is-a? child snip%)
+                 (when show?
+                   (send pasteboard insert child false))]
+                [(is-a? child alignment<%>)
+                 (send child set-pasteboard pasteboard)])
+              (loop (add1 column)))))
+        (send pasteboard lock-alignment false))
+      
+      (define/public (set-min-sizes)
+        
+        (set! column-widths
+              (map
+               (lambda (column)
+                 (apply vacuous-max
+                        (map (lambda (row)
+                               (child-width
+                                (vector-ref row column)))
+                             rows)))
+               (build-list columns identity)))
+        
+        (set! row-heights
+              (map
+               (lambda (row)
+                 (apply vacuous-max
+                        (map (lambda (column)
+                               (child-height
+                                (vector-ref row column)))
+                             (build-list columns identity))))
+               rows)))
+      
+      ;; STATUS: This function currently doesn't stretch snips.
+      (define/public (align x-offset y-offset width height)
+          (define (align-row row init-x y)
+            (let xloop ([x init-x]
+                        [column 0]
+                        [widths column-widths])
+              (unless (or (>= column columns) (empty? widths))
+                (move-child (vector-ref row column) pasteboard x y)
+                (xloop (+ x (first widths))
+                       (add1 column)
+                       (rest widths)))))
+          (when show?
+            (let yloop ([y y-offset]
+                        [the-rows rows]
+                        [heights row-heights])
+              (unless (or (empty? the-rows) (empty? heights))
+                (align-row (first the-rows) x-offset y)
+                (yloop (+ y (first heights))
+                       (rest the-rows)
+                       (rest heights))))))
+      
+      (define/public (get-min-width)
+        (if show?
+            (apply + column-widths)
+            0))
+      (define/public (get-min-height)
+        (if show?
+            (apply + row-heights)
+            0))
+      
+      (define/public (show bool)
+        (define (show/hide-row row)
+          (let loop ([column 0])
+            (unless (>= column columns)
+              (let ([child (vector-ref row column)])
+                (show/hide-child child bool)
+                (loop (add1 column))))))
+        (unless (boolean=? bool show?)
+          (set! show? bool)
+          (send pasteboard lock-alignment true)
+          (for-each show/hide-row rows)
+          (send pasteboard lock-alignment false)))
+      
+      (define/public (stretchable-width?) false)
+      (define/public (stretchable-height?) false)
+      (define/public (set-pasteboard pb) (set! pasteboard pb))
+      
+      (super-new)
+      (when parent (send parent add this))))
+  
+  (define (move-child child pasteboard x y)
+    (cond
+      [(is-a? child snip%)
+       (send pasteboard move-to child x y)]
+      [(is-a? child alignment<%>)
+       (send child align x y)]))
+  )
diff --git a/collects/embedded-gui/private/interface.ss b/collects/embedded-gui/private/interface.ss
new file mode 100644
index 0000000000..9dbf52d3d1
--- /dev/null
+++ b/collects/embedded-gui/private/interface.ss
@@ -0,0 +1,105 @@
+(module interface mzscheme
+  
+  (require (lib "class.ss"))
+  
+  (provide stretchable-snip<%>
+           alignment<%>
+           alignment-parent<%>
+           dllist<%>)
+  
+  (define dllist<%>
+    (interface ()
+      next
+      prev
+      for-each
+      map-to-list))
+  
+  (define alignment<%>
+    (interface (dllist<%>)
+      
+      #;(-> alignment-parent<%>)
+      ;; The parent of this alignment
+      get-parent
+      
+      #;(-> void?)
+      ;; Tells the alignment that its sizes should be calculated
+      set-min-sizes
+      
+      #;(nonnegative? nonnegative? nonnegative? nonnegative? . -> . void?)
+      ;; Tells the alignment to align its children on the pasteboard in the given rectangle
+      align
+      
+      #;(-> nonnegative?)
+      ;; The minimum width this alignment must be
+      get-min-width
+      
+      #;(-> nonnegative?)
+      ;; The minimum height this alignment must be
+      get-min-height
+      
+      #;(case-> (-> boolean?) (boolean? . -> . void?))
+      ;; True if the alignment can be stretched in the x dimension
+      stretchable-width
+      
+      #;(case-> (-> boolean?) (boolean? . -> . void?))
+      ;; True if the alignment can be stretched in the y dimension
+      stretchable-height
+      
+      #;(boolean? . -> . void)
+      ;; Tells the alignment to show or hide its children
+      show/hide
+      
+      #;(boolean? . -> . void)
+      ;; Tells the alignment that its show state is the given value
+      ;; and it should show or hide its children accordingly.
+      show
+      ))
+  
+  (define alignment-parent<%>
+    (interface ()
+      #;(-> (is-a?/c pasteboard%))
+      ;; The pasteboard that this alignment is being displayed to
+      get-pasteboard
+      
+      #;(((is-a?/c alignment<%>)) ((union (is-a?/c alignment<%>) false?)) . opt-> . void?)
+      ;; Add the given alignment as a child before the existing child
+      add-child
+      
+      #;((is-a?/c alignment<%>) . -> . void?)
+      ;; Deletes a child from the the alignments
+      delete-child
+      
+      #;(-> boolean?)
+      ;; True if the alignment is being shown (accounting for its parent being shown)
+      is-shown?
+      ))
+  
+  #| the interface that must be implemented by a class to be inserted into an
+     aligned-pasteboard<%> and be stretched and shrunk according to the geometry managment.
+  
+     note: any snip may be insert... those
+     that do not implement stretchable-snip<%> will simply not be stretched.
+  |#
+  (define stretchable-snip<%>
+    (interface ()
+      #;(positive? positive? . ->  . void?)
+      ;; called by the parent editor to stretch the snip to an specific size
+      stretch
+      
+      #;(-> positive?)
+      ;; get the minimum width of the snip
+      get-aligned-min-width
+      
+      #;(-> positive?)
+      ;; get the minmum height of the snip
+      get-aligned-min-height
+      
+      #;(case-> (boolean . -> . void?) (-> boolean?))
+      ;; get or set the stretchablity of the pasteboards width
+      stretchable-width
+      
+      #;(case-> (boolean . -> . void?) (-> boolean?))
+      ;; get or set the stretchablity of the pasteboards height
+      stretchable-height
+      ))
+  )
\ No newline at end of file
diff --git a/collects/embedded-gui/private/lines.ss b/collects/embedded-gui/private/lines.ss
new file mode 100644
index 0000000000..a7e82cf6d5
--- /dev/null
+++ b/collects/embedded-gui/private/lines.ss
@@ -0,0 +1,152 @@
+(module lines mzscheme
+  
+  (require
+   (lib "class.ss")
+   (lib "etc.ss")
+   (lib "mred.ss" "mred")
+   "snip-wrapper.ss"
+   "interface.ss")
+  
+  (provide hline% vline%)
+  
+  (define hline%
+    (class snip-wrapper%
+      (super-new
+       (snip (new hline-snip%)))))
+  
+  (define vline%
+    (class snip-wrapper%
+      (super-new
+       (snip (new vline-snip%)))))
+  
+  (define (make-line-snip draw-line stretch-w stretch-h)
+    (letrec ([c (class* snip% (stretchable-snip<%>)
+               
+               (field
+                [width 0]
+                [height 0])
+               
+               ;;;;;;;;;;
+               ;; snip%
+               
+               #;(((is-a?/c dc<%>)
+                   number?
+                   number?)
+                  ((union nonnegative? false/c)
+                   (union nonnegative? false/c)
+                   (union nonnegative? false/c)
+                   (union nonnegative? false/c)
+                   (union nonnegative? false/c)
+                   (union nonnegative? false/c))
+                  . opt-> .
+                  void?)
+               (define/override (get-extent dc x y w h descent space lspace rspace)
+                 (super get-extent dc x y w h descent space lspace rspace)
+                 (when w (set-box! w width))
+                 (when h (set-box! h height)))
+               
+               #;((is-a?/c dc<%>)
+                  number?
+                  number?
+                  number?
+                  number?
+                  number?
+                  number?
+                  number?
+                  number?
+                  (symbols no-caret show-inactive-caret show-caret))
+               (define/override (draw dc x y left top right bottom dx dy draw-caret)
+                 (super draw dc x y left top right bottom dx dy draw-caret)
+                 (draw-line dc x y width height)
+                 (void))
+               
+               ;;;;;;;;;;
+               ;; stretchable-snip<%>
+               
+               #;(positive? positive? . ->  . void?)
+               ;; called by the parent editor to stretch the snip to an specific size
+               (define/public (stretch w h)
+                 (set! width w)
+                 (set! height h))
+               
+               #;(-> positive?)
+               ;; get the minimum width of the snip
+               ;; NOTE: Lines need a margin so they're not overwritten
+               (define/public (get-aligned-min-width) 8)
+               
+               #;(-> positive?)
+               ;; get the minmum height of the snip
+               ;; NOTE: Lines need a margin so they're not overwritten
+               (define/public (get-aligned-min-height) 8)
+               
+               #;(case-> (boolean . -> . void?) (-> boolean?))
+               ;; get or set the stretchablity of the pasteboards width
+               (define/public stretchable-width
+                 (case-lambda
+                   [(v) (error 'stretchable-width "Cannot set stretchable-width of a line-snip%")]
+                   [() stretch-w]))
+               
+               #;(case-> (boolean . -> . void?) (-> boolean?))
+               ;; get or set the stretchablity of the pasteboards height
+               (define/public stretchable-height
+                 (case-lambda
+                   [(v) (error 'stretchable-height "Cannot set stretchable-height of a line-snip%")]
+                   [() stretch-h]))
+               
+               (super-new)
+               (inherit set-snipclass)
+               (set-snipclass sc))]
+          [sc (new
+               (class snip-class%
+                 (define/override (read f)
+                   (new c))
+                 (super-new)))])
+      (send sc set-classname "make-line-snip")
+      (send sc set-version 1)
+      (send (get-the-snip-class-list) add sc)
+      c))
+                
+  
+  (define hline-snip%
+     (make-line-snip
+      (lambda (dc x y width height)
+        (send dc draw-line x (+ y (/ height 2)) (+ x width) (+ y (/ height 2))))
+      true
+      false))
+    
+  (define vline-snip%
+     (make-line-snip
+      (lambda (dc x y width height)
+        (send dc draw-line (+ x (/ width 2)) y (+ x (/ width 2))  (+ y height)))
+      false
+      true))
+  
+  #|
+  (require
+   "verthoriz-alignment.ss"
+   "aligned-pasteboard.ss"
+   "snip-wrapper.ss")
+  
+  (define f (new frame% (label "f") (height 500) (width 500)))
+  (send f show true)
+  (define p (new aligned-pasteboard%))
+  (define c (new editor-canvas% (editor p) (parent f)))
+  (define a1 (new vertical-alignment% (parent p)))
+  (define a2 (new horizontal-alignment% (parent a1)))
+  (new hline% (parent a1))
+  (define a3 (new horizontal-alignment% (parent a1)))
+  
+  (new snip-wrapper%
+       (snip (make-object string-snip% "One"))
+       (parent a2))
+  (new snip-wrapper%
+       (snip (make-object string-snip% "Two"))
+       (parent a2))
+  (new snip-wrapper%
+       (snip (make-object string-snip% "Three"))
+       (parent a3))
+  (new snip-wrapper%
+       (snip (make-object string-snip% "Three"))
+       (parent a3))
+  |#
+  )
\ No newline at end of file
diff --git a/collects/embedded-gui/private/locked-pasteboard.ss b/collects/embedded-gui/private/locked-pasteboard.ss
new file mode 100644
index 0000000000..9c1110403d
--- /dev/null
+++ b/collects/embedded-gui/private/locked-pasteboard.ss
@@ -0,0 +1,31 @@
+;; This module provides a mixin that locks a pasteboard to all mouse interaction. This
+;; means that there is no interactive dragging, no keyboard deletion, no handles drawn
+;; at the corners of the snips for dragging, and anything else that must be added.
+
+(module locked-pasteboard mzscheme
+  
+  (require
+   (lib "class.ss")
+   (lib "mred.ss" "mred")
+   (lib "etc.ss")
+   (lib "contract.ss")
+   (lib "framework.ss" "framework"))
+  
+  (provide/contract
+   (locked-pasteboard-mixin mixin-contract))
+  
+  ;; mixin to remove interactive movement of snips from pasteboards
+  ;; STATUS: Look into and make sure I don't need to deal with the following.
+  ;;           interactive-adjust-mouse, interactive-adjust-move, on-default-event
+  ;;           interactive-adjust-resize
+  (define locked-pasteboard-mixin
+    (mixin ((class->interface pasteboard%)) ()
+      (define/override (on-default-event event) (void))
+      ;; The rest of the methods I believe to be redundant but
+      ;; are overriden anyway for consistancy.
+      (define/augment-final (can-interactive-move? event) false)
+      (define/augment-final (can-interactive-resize? snip) false)
+      (define/override (get-dragable) false)
+      (define/override (get-selection-visible) false)
+      (super-new)))
+  )
\ No newline at end of file
diff --git a/collects/embedded-gui/private/on-show-editor.ss b/collects/embedded-gui/private/on-show-editor.ss
new file mode 100644
index 0000000000..08b867c6fe
--- /dev/null
+++ b/collects/embedded-gui/private/on-show-editor.ss
@@ -0,0 +1,34 @@
+(module on-show-editor mzscheme
+  (define (writeln x) (write x) (newline))
+  (require
+   (lib "class.ss")
+   (lib "etc.ss")
+   (lib "mred.ss" "mred")
+   (lib "framework.ss" "framework")
+   "snip-lib.ss")
+  
+  (provide
+   on-show-editor<%>
+   on-show-editor-canvas-mixin
+   on-show-editor-snip-mixin)
+  
+  (define on-show-editor<%>
+    (interface ()
+      #;(-> void)
+      ;; Called when the editor is shown.
+      on-show))
+  
+  (define on-show-editor-snip-mixin
+    (mixin ((class->interface editor-snip%)) ()
+      (super-new)))
+  
+  (define on-show-editor-canvas-mixin
+    (mixin ((class->interface editor-canvas%)) ()
+      (inherit get-editor)
+      #;(number? number? . -> . void)
+      ;; called when the canvas's parent size changes
+      (define/override (on-size width height)
+        (super on-size width height)
+        (send (get-editor) on-show))
+      (super-new)))
+  )
diff --git a/collects/embedded-gui/private/on-show-pasteboard.ss b/collects/embedded-gui/private/on-show-pasteboard.ss
new file mode 100644
index 0000000000..19d074c3c7
--- /dev/null
+++ b/collects/embedded-gui/private/on-show-pasteboard.ss
@@ -0,0 +1,50 @@
+(module on-show-pasteboard mzscheme
+  
+  (require
+   (lib "class.ss")
+   (lib "etc.ss")
+   (lib "mred.ss" "mred"))
+  
+  (provide
+   on-show-pasteboard%
+   on-show-pasteboard-mixin)
+  
+  (define (on-show-pasteboard-mixin super%)
+    (class super%
+      (field [shown? false])
+      #|
+      (define/override (refresh x y w h d-c)
+        (super refresh x y (max w 0) (max h 0) d-c)
+        (unless shown?
+          (set! shown? true)
+          (on-show)))
+      |#
+      #|
+      (define/override (get-extent w h)
+        (super get-extent w h)
+        (unless shown?
+          (set! shown? true)
+          (on-show)))
+      |#
+      (define/public (showing?) shown?)
+      (define/public (on-show) (void))
+      (super-new)))
+  
+  (define on-show-pasteboard%
+    (on-show-pasteboard-mixin
+     pasteboard%))
+  
+  #|
+  (define f (new frame% (label "f") (width 400) (height 400)))
+  (send f show true)
+  (define e (new pasteboard%))
+  (define c (new editor-canvas% (editor e) (parent f)))
+  (define pb (new on-show-pasteboard%))
+  (define es (new editor-snip% (editor pb)))
+  (not (send pb showing?))
+  (send e insert es)
+  (send pb showing?)
+  (send e remove es)
+  (not (send pb showing?))
+  |#
+  )
diff --git a/collects/embedded-gui/private/program-editor.ss b/collects/embedded-gui/private/program-editor.ss
new file mode 100644
index 0000000000..c2c118dc0e
--- /dev/null
+++ b/collects/embedded-gui/private/program-editor.ss
@@ -0,0 +1,88 @@
+#|
+
+This file contains a mixin that should be used my any embedded editor that contains
+code. What is does is tells the drscheme frame that the program has changed and
+drscheme can appropriately reset highlighting and display the "save" button. There
+is a facility of drscheme to do this but to my knowledge it is not working properly.
+
+|#
+
+#|NOTES:
+
+This code is copied from the test suite tool and the test suite tool should be
+rewritten to use this copy of the program. This is not a trivial change since the
+alert-of-modify method in test-suite is currently clearing the test cases to reset
+them.
+
+This code can be replaced by drscheme:unit:program-editor-mixin when I figure out how
+to make the results of the test case boxes be reset when (and only when) highlighting
+is being reset.
+|#
+
+(module program-editor mzscheme
+  
+  (require
+   (lib "mred.ss" "mred")
+   (lib "etc.ss")
+   (lib "class.ss")
+   (lib "framework.ss" "framework")
+   "snip-lib.ss")
+  
+  (provide program-editor-mixin
+           program-editor%)
+  
+  (define (program-editor-mixin %)
+    (class %
+      (inherit get-admin begin-edit-sequence end-edit-sequence)
+      (define (get-frame)
+        ;; gets the top most editor in the tree of snips and editors
+        (define (editor-root ed)
+          (let ([parent (editor-parent ed)])
+            (cond
+              [(is-a? parent area<%>) parent]
+              [(is-a? parent snip%)
+               (editor-root (snip-parent parent))]
+              [else false])))
+        
+        ;; gets the canvas or snip that the pasteboard is displayed in
+        ;; status: what if there is more than one canvas?
+        (define (editor-parent ed)
+          (let ([admin (send ed get-admin)])
+            (cond
+              [(is-a? admin editor-snip-editor-admin<%>)
+               (send admin get-snip)]
+              [(is-a? admin editor-admin%)
+               (send ed get-canvas)]
+              [else false])))
+        
+        (let ([er (editor-root this)])
+          (if er
+              (send er get-top-level-window)
+              false)))
+      
+      (define (alert-of-modify)
+        (let ([frame (get-frame)])
+          (when frame
+            (send (send frame get-interactions-text) reset-highlighting)
+            (send* (send frame get-definitions-text)
+              (set-modified true)))))
+      
+      ;(define/override (on-insert start len)
+      ;  (begin-edit-sequence)
+      ;  (super on-insert start len)
+      ;  (end-edit-sequence))
+      
+      (define/override (after-insert start len)
+        (alert-of-modify)
+        ;(begin-edit-sequence)
+        (super after-insert start len)
+        ;(end-edit-sequence)
+        )
+      (define/override (after-delete start len)
+        (alert-of-modify)
+        (super after-delete start len))
+      (super-new)))
+  
+  (define program-editor%
+    (program-editor-mixin color:text%))
+  )
diff --git a/collects/embedded-gui/private/really-resized-pasteboard.ss b/collects/embedded-gui/private/really-resized-pasteboard.ss
new file mode 100644
index 0000000000..408c8fd30d
--- /dev/null
+++ b/collects/embedded-gui/private/really-resized-pasteboard.ss
@@ -0,0 +1,85 @@
+#|
+
+This module provides a really-resized pasteboard that calls the really-resized
+method when a snip in the editor is really resized, not when pasteboard says
+it's resized. This file was written because sometimes I need to override resized
+to adjust my editors layout however the resized method of the pasteboard is
+invoked whenever editor snips get focus, lose focus, get text typed into them,
+get text deteleted from them, etc.
+
+|#
+
+(module really-resized-pasteboard mzscheme
+  
+  (require
+   (lib "etc.ss")
+   (lib "class.ss")
+   (lib "mred.ss" "mred"))
+  
+  (provide
+   really-resized-pasteboard-mixin
+   really-resized-pasteboard%)
+  
+  (define (really-resized-pasteboard-mixin super%)
+    (class super%
+      (inherit refresh-delayed? get-snip-location)
+      (field [snip-cache (make-hash-table)]
+             [ignore-resizing? false])
+      
+      ;; Called whenever a snip within the editor is resized, just like the
+      ;; resized method but excludes suchs events as when and editor-snip gets
+      ;; focus.
+      (define/public (really-resized snip) (void))
+      
+      #|
+      snip : snip% object 
+      redraw-now? : boolean
+      |#
+      (define/override (resized snip redraw-now?)
+        (super resized snip redraw-now?)
+        (unless ignore-resizing?
+          (let ([size (snip-size snip)])
+            ;; The snip is getting remove from hash table in  a way I
+            ;; am not antisipating. I need to find it and then I can
+            ;; remove this error catcher.
+            (unless (equal? size (with-handlers ([exn? (lambda x 0)])
+                                   (hash-table-get snip-cache snip)))
+              (hash-table-put! snip-cache snip size)
+              (really-resized snip)))))
+      
+      #|
+      snip : snip% object 
+      before : snip% object or #f 
+      x : real number 
+      y : real number
+      |#
+      (define/augment (after-insert snip before x y)
+        (hash-table-put! snip-cache snip (snip-size snip))
+        (inner (void) after-insert snip before x y))
+      
+      #|
+      snip : snip% object
+      |#
+      (define/augment (after-delete snip)
+        (hash-table-remove! snip-cache snip)
+        (inner (void) after-delete snip))
+      
+      #;((is-a?/c snip%) . -> . (cons/p natural-number? natural-number?))
+      ;; The width and height of the given snip in this pasteboard.
+      (define (snip-size snip)
+        (let ([top (box 0)]
+              [bottom (box 0)]
+              [left (box 0)]
+              [right (box 0)])
+          (fluid-let ([ignore-resizing? true])
+            (get-snip-location snip left top false)
+            (get-snip-location snip right bottom true))
+          (cons (- (unbox right) (unbox left))
+                (- (unbox bottom) (unbox top)))))
+      
+      (super-new)))
+  
+  (define really-resized-pasteboard%
+    (really-resized-pasteboard-mixin
+     pasteboard%))
+  )
diff --git a/collects/embedded-gui/private/single-line-text.ss b/collects/embedded-gui/private/single-line-text.ss
new file mode 100644
index 0000000000..a15d939db7
--- /dev/null
+++ b/collects/embedded-gui/private/single-line-text.ss
@@ -0,0 +1,28 @@
+(module single-line-text mzscheme
+  
+  (require
+   (lib "mred.ss" "mred")
+   (lib "framework.ss" "framework")
+   (lib "class.ss"))
+  
+  (provide single-line-text-mixin)
+  
+  (define single-line-text-mixin
+    (mixin (editor:keymap<%>) ()
+      #;(-> (listof keymap%))
+      ;; the list of keymaps associated with this text
+      (define/override (get-keymaps)
+        (let ([keymap (make-object keymap%)])
+          (send keymap add-function "do nothing" void)
+          (send keymap map-function ":enter" "do nothing")
+          (cons keymap (super get-keymaps))))
+      (super-new)))
+  
+  #|
+  (define f (new frame% (label "f")))
+  (define e (new text%))
+  (define c (new editor-canvas% (editor e) (parent f)))
+  (send e insert (new editor-snip% (editor (new (single-line-text-mixin scheme:text%)))))
+  (send f show #t)
+  |#
+  )
diff --git a/collects/embedded-gui/private/snip-lib.ss b/collects/embedded-gui/private/snip-lib.ss
new file mode 100644
index 0000000000..f6cc573d8b
--- /dev/null
+++ b/collects/embedded-gui/private/snip-lib.ss
@@ -0,0 +1,119 @@
+#| WARNING: DUPLICATED FILE |#
+
+(module snip-lib mzscheme
+  
+  (require
+   (lib "class.ss")
+   (lib "etc.ss")
+   (lib "mred.ss" "mred")
+   (lib "list.ss")
+   (lib "contract.ss")
+   "interface.ss")
+  
+  ;; a snip
+  (define snip? (is-a?/c snip%))
+  ;; a snip to act as the varying argument to a recursive functions
+  (define linked-snip? (union snip? false/c))
+  ;; a function to act on snips being mapped
+  (define snip-visitor? any/c #;((snip?) (listof any/c) . ->* . (void)))
+  ;; the rest of the lists passed to a snip mapping function
+  (define rest-lists? (listof (listof any/c)))
+  ;; a class that contains a snip
+  (define editor? (is-a?/c editor<%>))
+  
+  (provide/contract
+   (snip-width (snip? . -> . number?))
+   (snip-height (snip? . -> . number?))
+   (snip-min-width (snip? . -> . number?))
+   (snip-min-height (snip? . -> . number?))
+   (snip-parent (snip? . -> . (union editor? false/c)))
+   (fold-snip ((snip? any/c . -> . any/c) any/c linked-snip? . -> . any/c))
+   (for-each-snip any/c #;((snip-visitor? linked-snip?) rest-lists? . ->* . (void)))
+   (map-snip any/c #;((snip-visitor? linked-snip?) rest-lists? . ->* . ((listof any/c))))
+   (stretchable-width? (snip? . -> . boolean?))
+   (stretchable-height? (snip? . -> . boolean?)))
+  
+  ;; the width of a snip in the parent pasteboard
+  (define (snip-width snip)
+    (let ([left (box 0)]
+          [right (box 0)]
+          [pasteboard (snip-parent snip)])
+      (send pasteboard get-snip-location snip left (box 0) false)
+      (send pasteboard get-snip-location snip right (box 0) true)
+      (- (unbox right) (unbox left))))
+    
+  ;; the height of a snip in the parent pasteboard
+  (define (snip-height snip)
+    (let ([top (box 0)]
+          [bottom (box 0)]
+          [pasteboard (snip-parent snip)])
+      (send pasteboard get-snip-location snip (box 0) top false)
+      (send pasteboard get-snip-location snip (box 0) bottom true)
+      (- (unbox bottom) (unbox top))))
+  
+  ;; the minimum width of the snip
+  (define (snip-min-width snip)
+    (cond
+      [(is-a? snip stretchable-snip<%>)
+       (send snip get-aligned-min-width)]
+      [else (snip-width snip)]))
+  
+  ;; the minimum height of the snip
+  (define (snip-min-height snip)
+    (cond
+      [(is-a? snip stretchable-snip<%>)
+       (send snip get-aligned-min-height)]
+      [else (snip-height snip)]))
+  
+  ;; the pasteboard that contains the snip
+  (define (snip-parent snip)
+    (let ([admin (send snip get-admin)])
+      (if admin
+          (send admin get-editor)
+          false)))
+  
+  ;; the application of f on all snips from snip to the end in a foldl foldr mannor
+  (define (fold-snip f init-acc snip)
+    (let loop ([snip snip]
+               [acc init-acc])
+      (cond
+        [(is-a? snip snip%)
+         (loop (send snip next) (f snip acc))]
+        [else acc])))
+  
+  ;; applies the function to all the snips
+  (define (for-each-snip f first-snip . init-lists)
+    (let loop ([snip first-snip]
+               [lists init-lists])
+      (cond
+        [(is-a? snip snip%)
+         (apply f (cons snip (map first lists)))
+         (loop (send snip next)
+               (map rest lists))]
+        [else (void)])))
+  
+  ;; a list of f applied to each snip
+  (define (map-snip f first-snip . init-lists)
+    (let loop ([snip first-snip]
+               [lists init-lists])
+      (cond
+        [(is-a? snip snip%)
+         (cons (apply f (cons snip (map first lists)))
+               (loop (send snip next)
+                     (map rest lists)))]
+        [else empty])))
+  
+  ;; true if the snip can be resized in the x dimention
+  (define (stretchable-width? snip)
+    (cond
+      [(is-a? snip stretchable-snip<%>)
+       (send snip stretchable-width)]
+      [else false]))
+  
+  ;; true if the snip can be resized in the y dimention
+  (define (stretchable-height? snip)
+    (cond
+      [(is-a? snip stretchable-snip<%>)
+       (send snip stretchable-height)]
+      [else false]))
+  )
diff --git a/collects/embedded-gui/private/snip-wrapper.ss b/collects/embedded-gui/private/snip-wrapper.ss
new file mode 100644
index 0000000000..28a90c98fa
--- /dev/null
+++ b/collects/embedded-gui/private/snip-wrapper.ss
@@ -0,0 +1,95 @@
+(module snip-wrapper mzscheme
+  
+  (require
+   (lib "etc.ss")
+   (lib "class.ss")
+   (lib "mred.ss" "mred")
+   "interface.ss"
+   (prefix sl: "snip-lib.ss")
+   "dllist.ss")
+  
+  (provide control-style
+	   snip-wrapper%)
+
+  (define control-style
+    (let ([delta (make-object style-delta%)])
+      (send delta set-family 'system)
+      (send delta set-delta 'change-size (send normal-control-font get-point-size))
+      (send the-style-list find-or-create-style 
+	    (send the-style-list basic-style)
+	    delta)))
+    
+  (define snip-wrapper%
+    (class* dllist% (alignment<%>)
+      (init-field parent snip)
+      (field [pasteboard (send parent get-pasteboard)]
+             [show? true]
+             [snip-is-inserted? false]
+             [min-width 0]
+             [min-height 0])
+      
+      ;;;;;;;;;;
+      ;; alignment<%>
+      
+      #;(-> alignment-parent<%>)
+      ;; The parent of this alignment
+      (define/public (get-parent) parent)
+      
+      #;(-> void?)
+      ;; Tells the alignment that its sizes should be calculated
+      (define/public (set-min-sizes)
+        (if snip-is-inserted?
+            (begin (set! min-width (sl:snip-min-width snip))
+                   (set! min-height (sl:snip-min-height snip)))
+            (begin (set! min-width 0)
+                   (set! min-height 0))))
+      
+      #;(nonnegative? nonnegative? nonnegative? nonnegative? . -> . void?)
+      ;; Tells the alignment to align its children on the pasteboard in the given rectangle
+      (define/public (align x y w h)
+        (send pasteboard move-to snip x y)
+        (when (is-a? snip stretchable-snip<%>)
+          (send snip stretch w h)))
+      
+      #;(-> nonnegative?)
+      ;; The minimum width this alignment must be.
+      (define/public (get-min-width) min-width)
+      
+      #;(-> nonnegative?)
+      ;; The minimum height this alignment must be.
+      (define/public (get-min-height) min-height)
+      
+      #;(case-> (-> boolean?) (boolean? . -> . void?))
+      ;; True if the alignment can be stretched in the x dimension
+      (define/public (stretchable-width)
+        (sl:stretchable-width? snip))
+      
+      #;(case-> (-> boolean?) (boolean? . -> . void?))
+      ;; True if the alignment can be stretched in the y dimension
+      (define/public (stretchable-height)
+        (sl:stretchable-height? snip))
+      
+      #;(boolean? . -> . void?)
+      ;; Tells the alignment that its show state is the given value
+      ;; and it should show or hide its children accordingly.
+      (define/public (show bool)
+        (set! show? bool)
+        (show/hide show?))
+      
+      #;(boolean? . -> . void)
+      ;; Tells the alignment to show or hide its children
+      (define/public (show/hide bool)
+        (send pasteboard lock-alignment true)
+        (unless (boolean=? bool snip-is-inserted?)
+          (if bool
+              (begin (send pasteboard insert-aligned-snip snip)
+                     (set! snip-is-inserted? true))
+              (begin (send pasteboard release-aligned-snip snip)
+                     (set! snip-is-inserted? false))))
+        (send pasteboard realign)
+        (send pasteboard lock-alignment false))
+      
+      (super-new)
+      (send parent add-child this)
+      (show/hide (and show? (send parent is-shown?)))))
+  )
\ No newline at end of file
diff --git a/collects/embedded-gui/private/stretchable-editor-snip.ss b/collects/embedded-gui/private/stretchable-editor-snip.ss
new file mode 100644
index 0000000000..313077fde3
--- /dev/null
+++ b/collects/embedded-gui/private/stretchable-editor-snip.ss
@@ -0,0 +1,116 @@
+(module stretchable-editor-snip mzscheme
+  
+  (provide
+   stretchable-editor-snip%
+   stretchable-editor-snip-mixin)
+  
+  (require
+   (lib "class.ss")
+   (lib "mred.ss" "mred")
+   (lib "etc.ss")
+   
+   "interface.ss")
+  
+  (define (stretchable-editor-snip-mixin super%)
+    (class* super% (stretchable-snip<%>)
+      
+      (init
+       (stretchable-width true)
+       (stretchable-height true))
+      
+      (field
+       (aligned-min-width 0)
+       (aligned-min-height 0)
+       (stretchable-width-field stretchable-width)
+       (stretchable-height-field stretchable-height))
+      
+      (public (stretchable-width-method stretchable-width)
+              (stretchable-height-method stretchable-height))
+      
+      ;; stretchable-width (case-> (Boolean . -> . (void)) (-> Boolean))
+      ;; get or set the stretchablity of the pasteboards width
+      (define stretchable-width-method
+        (case-lambda
+          [(value) (set! stretchable-width-field value)]
+          [() stretchable-width-field]))
+      
+      ;; stretchable-height (case-> (Boolean . -> .(void)) (-> Boolean))
+      ;; get or set the stretchablity of the pasteboards height
+      (define stretchable-height-method
+        (case-lambda
+          [(value) (set! stretchable-height-field value)]
+          [() stretchable-height-field]))
+      
+      (define/public (get-aligned-min-width) aligned-min-width)
+      (define/public (get-aligned-min-height) aligned-min-height)
+      
+      (inherit get-margin get-editor get-admin)
+      (define/override (resize w h)
+        (set! aligned-min-width w)
+        (set! aligned-min-height h)
+        (super-resize w h))
+        
+      (define/public (stretch w h)
+        (super-resize w h))
+      
+      (define/override (get-extent dc x y w h descent space lspace rspace)
+        (super get-extent dc x y w h descent space lspace rspace)
+        (when (is-a? (get-editor) text%)
+          (set-box! w (sub1 (unbox w))))
+        (go))
+      
+      (define/override (set-min-width w)
+        ;; account for margin !!!!!!
+        (send (get-editor) set-min-width w))
+      
+      (define/override (set-min-height h)
+        ;; account for margin !!!!!!
+        (send (get-editor) set-min-height h))
+      
+      ;; NOTE: Can I make this not public? I don't think it
+      ;; should be but it's been a while since I wrote this class.
+      (define/public (super-resize w h)
+        (let ((top (box 0))
+              (bot (box 0))
+              (lef (box 0))
+              (rit (box 0)))
+          (get-margin top bot lef rit)
+          (let ((w (max (- w (unbox lef) (unbox rit)) 0))
+                (h (max (- h (unbox top) (unbox bot)) 0))
+                (e (get-editor))
+                (a (get-admin)))
+            ;; subtracting 1 from W seems to make it act more like the editor-snip
+            ;; because the C code has a hack to sub1 to make it look better. I am not
+            ;; sure if this change here is sound and works for every part of this
+            ;; class.
+            (if (> w aligned-min-width)
+                (super set-min-width w)
+                (super set-min-width 'none))
+            (if (> h aligned-min-height)
+                (super set-min-height h)
+                (super set-min-height 'none))
+            (when a (send a resized this #t)))))
+      
+      ;; call this from within get extent and use the values it produces by subtracting the
+      ;; margin instead of calling the editors get-extent and adding the margin.
+      (define (go)
+        (let ([w (box 0)]
+              [h (box 0)]
+              (top (box 0))
+              (bot (box 0))
+              (lef (box 0))
+              (rit (box 0)))
+          (get-margin top bot lef rit)
+          (send (get-editor) get-extent w h)
+          (set! aligned-min-width (+ (unbox w) (unbox lef) (unbox rit)))
+          (set! aligned-min-height (+ (unbox h) (unbox top) (unbox rit)))))
+            
+      (super-new)
+      (inherit get-min-width get-min-height)
+      (set-min-width (get-min-width))
+      (set-min-height (get-min-height))))
+  
+  (define stretchable-editor-snip%
+    (stretchable-editor-snip-mixin
+     editor-snip%))
+  )
diff --git a/collects/embedded-gui/private/suppress-modify-editor.ss b/collects/embedded-gui/private/suppress-modify-editor.ss
new file mode 100644
index 0000000000..d7d3d4c6c2
--- /dev/null
+++ b/collects/embedded-gui/private/suppress-modify-editor.ss
@@ -0,0 +1,28 @@
+(module suppress-modify-editor mzscheme
+  
+  (require
+   (lib "etc.ss")
+   (lib "class.ss")
+   (lib "mred.ss" "mred"))
+  
+  (provide suppress-modify-editor-mixin)
+      
+  ;; Ignore the modification of the pasteboard that is used for layout
+  ;; Allow nested editors to percollate modify messages up through 
+  (define (suppress-modify-editor-mixin %)
+    (class %
+      (inherit set-modified)
+      #;(define/override (after-delete snip)
+        (super after-delete snip)
+        (set-modified false))
+      #;(define/override (after-insert snip before x y)
+        (super after-insert snip before x y)
+        (set-modified false))
+      #;(define/override (after-move-to snip x y dragging?)
+        (super after-move-to snip x y dragging?)
+        (set-modified false))
+      #;(define/override (after-resize snip w h resized?)
+        (super after-resize snip w h resized?)
+        (set-modified false))
+      (super-new)))
+  )
diff --git a/collects/embedded-gui/private/tabbable-text.ss b/collects/embedded-gui/private/tabbable-text.ss
new file mode 100644
index 0000000000..90b2fba106
--- /dev/null
+++ b/collects/embedded-gui/private/tabbable-text.ss
@@ -0,0 +1,65 @@
+
+(module tabbable-text mzscheme
+  
+  (require
+   (lib "class.ss")
+   (lib "list.ss")
+   (lib "etc.ss")
+   (lib "framework.ss" "framework")
+   (lib "mred.ss" "mred")
+   (lib "contract.ss"))
+  
+  (define tabbable-text<%>
+    (interface ()
+      #;(-> void)
+      ;; Takes the caret into this text
+      
+      set-caret-owner
+      #;((-> void) . -> . void)
+      ;; The thunk to execute when tabbing ahead
+      set-ahead
+      
+      #;((-> void) . -> . void)
+      ;; The thunk to execute when tabbing back
+      set-back))
+  
+  (provide/contract
+   (tabbable-text<%> interface?)
+   (tabbable-text-mixin mixin-contract)
+   (set-tabbing (() (listof (is-a?/c tabbable-text<%>)) . ->* . (void?))))
+  
+  (define tabbable-text-mixin
+    (mixin (editor:keymap<%>) (tabbable-text<%>)
+      
+      (init-field
+       [ahead void]
+       [back void])
+      
+      #;(-> (listof keymap%))
+      ;; the list of keymaps associated with this text
+      (define/override (get-keymaps)
+        (let ([keymap (make-object keymap%)])
+          (send keymap add-function "tab-ahead"
+                (lambda (ignored event) (ahead)))
+          (send keymap map-function ":tab" "tab-ahead")
+          (send keymap add-function "tab-back"
+                (lambda (ignored event) (back)))
+          (send keymap map-function "s:tab" "tab-back")
+          (cons keymap (super get-keymaps))))
+      
+      (define/public (set-ahead t) (set! ahead t))
+      (define/public (set-back t) (set! back t))
+      
+      (super-new)))
+  
+  ;; sets the tabbing of all of the texts in the order of the list
+  (define (set-tabbing . l)
+    (cond
+      [(or (empty? l) (empty? (rest l))) (void)]
+      [else
+       (send (first l) set-ahead
+             (lambda () (send (second l) set-caret-owner false 'global)))
+       (send (second l) set-back
+             (lambda () (send (first l) set-caret-owner false 'global)))
+       (apply set-tabbing (rest l))]))
+  )
diff --git a/collects/embedded-gui/private/tests/alignment-test.ss b/collects/embedded-gui/private/tests/alignment-test.ss
new file mode 100644
index 0000000000..a3c7f2a776
--- /dev/null
+++ b/collects/embedded-gui/private/tests/alignment-test.ss
@@ -0,0 +1,31 @@
+(require
+ (lib "class.ss")
+ (lib "etc.ss")
+ (lib "mred.ss" "mred")
+ "../verthoriz-alignment.ss"
+ "../lines.ss"
+ "../aligned-pasteboard.ss"
+ "../snip-wrapper.ss")
+
+(require "../snip-lib.ss")
+
+(define f (new frame% (label "f") (height 500) (width 500)))
+(send f show true)
+(define p (new aligned-pasteboard%))
+(define c (new editor-canvas% (editor p) (parent f)))
+(define a1 (new vertical-alignment% (parent p)))
+(define a2 (new horizontal-alignment% (parent a1)))
+(define a3 (new horizontal-alignment% (parent a1)))
+
+(new snip-wrapper%
+     (snip (make-object string-snip% "One"))
+     (parent a2))
+(new snip-wrapper%
+     (snip (make-object string-snip% "Two"))
+     (parent a2))
+(new snip-wrapper%
+     (snip (make-object string-snip% "Three"))
+     (parent a3))
+(new snip-wrapper%
+     (snip (make-object string-snip% "Three"))
+     (parent a3))
diff --git a/collects/embedded-gui/private/tests/not-stetching.ss b/collects/embedded-gui/private/tests/not-stetching.ss
new file mode 100644
index 0000000000..5d2e744177
--- /dev/null
+++ b/collects/embedded-gui/private/tests/not-stetching.ss
@@ -0,0 +1,31 @@
+(module not-stetching mzscheme
+  
+  (require
+   (lib "debug.ss" "mike-lib")
+   (lib "class.ss")
+   (lib "etc.ss")
+   (lib "mred.ss" "mred")
+   (lib "aligned-pasteboard.ss" "embedded-gui")
+   (lib "stretchable-editor-snip.ss" "embedded-gui")
+   (lib "verthoriz-alignment.ss" "embedded-gui"))
+  
+  (define traced-ses%
+    #;(override/trace stretchable-editor-snip%
+                    (stretch
+                     get-aligned-min-width
+                     get-aligned-min-height
+                     stretchable-width
+                     stretchable-height)))
+  
+  (define f (new frame% (label "f") (width 400) (height 400)))
+  (define e (new text%))
+  (define c (new editor-canvas% (parent f) (editor e)))
+  (define main (new aligned-pasteboard%))
+  (define j (new editor-snip% (editor main)))
+  (define line (new horizontal-alignment% (parent main)))
+  (define ses (new traced-ses% (editor (new text%))))
+  (send line add ses)
+  (send main add (make-object string-snip% "super duper very long snip"))
+  (send e insert j)
+  (send f show true)
+  )
diff --git a/collects/embedded-gui/private/tests/only-one-child.ss b/collects/embedded-gui/private/tests/only-one-child.ss
new file mode 100644
index 0000000000..cb4734975b
--- /dev/null
+++ b/collects/embedded-gui/private/tests/only-one-child.ss
@@ -0,0 +1,54 @@
+(require
+ (lib "mred.ss" "mred")
+ (lib "class.ss")
+ (lib "etc.ss")
+ (lib "list.ss")
+ (lib "match.ss")
+ (prefix a: "../alignment.ss")
+ "../alignment-helpers.ss"
+ "../dllist.ss"
+ (lib "click-forwarding-editor.ss" "mrlib")
+ "../on-show-pasteboard.ss"
+ "../really-resized-pasteboard.ss"
+ "../interface.ss"
+ "../locked-pasteboard.ss"
+ "../suppress-modify-editor.ss")
+
+;;;;;;;;;;
+;; alignment
+
+(define (vert/horiz-alignment type)
+  (class* dllist% ()
+    
+    (init-field [parent #f])
+    
+    (field
+     [head (new head%)]
+     [tail (new tail%)])
+    
+    (send head next tail)
+    (send tail prev head)
+    
+    #;(((is-a?/c alignment<%>)) ((union (is-a?/c alignment<%>) false?)) . opt-> . void?)
+    ;; Add the given alignment as a child before the existing child
+    (define/public add-child
+      (opt-lambda (child (after #f))
+        (define (link p item n)
+          (send p next child)
+          (send child prev p)
+          (send n prev child)
+          (send child next n))
+        (if after
+            (link after child (send after next))
+            (link (send tail prev) child tail))))
+    
+    (super-new)
+    (when parent (send parent add-child this))))
+
+(define vertical-alignment% (vert/horiz-alignment 'vertical))
+(define horizontal-alignment% (vert/horiz-alignment 'horizontal))
+
+(let* ([interactions (new vertical-alignment% (parent (new vertical-alignment%)))])
+  (new horizontal-alignment% (parent interactions))
+  (new horizontal-alignment% (parent interactions))
+  `(equal? ,(length (send interactions map-to-list (lambda (x) x))) 2))
diff --git a/collects/embedded-gui/private/tests/peer-stretchables.ss b/collects/embedded-gui/private/tests/peer-stretchables.ss
new file mode 100644
index 0000000000..b76524b7eb
--- /dev/null
+++ b/collects/embedded-gui/private/tests/peer-stretchables.ss
@@ -0,0 +1,25 @@
+(require
+ (lib "class.ss")
+ (lib "etc.ss")
+ (lib "mred.ss" "mred")
+ "../stretchable-editor-snip.ss"
+ "../verthoriz-alignment.ss"
+ "../aligned-pasteboard.ss")
+
+(define f (new frame% (label "f") (width 400) (height 400)))
+(define e (new text%))
+(define c (new editor-canvas% (parent f) (editor e)))
+(define main (new aligned-pasteboard%))
+(define horiz (new vertical-alignment% (parent main)))
+(define es (new editor-snip% (editor main)))
+(define ses1 (new stretchable-editor-snip% (editor (new text%))))
+(define ses2 (new stretchable-editor-snip% (editor (new text%))))
+(send* horiz (add ses1) (add ses2))
+(send e insert es)
+(send f show true)
+
+(let ([e (send ses2 get-editor)]
+      [ses1-mw (send ses1 get-min-width)])
+  (send e insert "sdflsdfnsknbskdlf")
+  (send e erase)
+  (equal? ses1-mw (send ses1 get-min-width)))
\ No newline at end of file
diff --git a/collects/embedded-gui/private/tests/stretching-in-alignment.ss b/collects/embedded-gui/private/tests/stretching-in-alignment.ss
new file mode 100644
index 0000000000..1921ee90c7
--- /dev/null
+++ b/collects/embedded-gui/private/tests/stretching-in-alignment.ss
@@ -0,0 +1,30 @@
+(module stretching-in-alignment mzscheme
+    
+  (require
+   (lib "mred.ss" "mred")
+   (lib "etc.ss")
+   (lib "class.ss")
+   (lib "interface.ss" "mrlib" "private" "aligned-pasteboard")
+   (lib "debug.ss" "mike-lib")
+   (lib "list.ss")
+   (lib "match.ss")
+   (prefix a: "alignment.ss")
+   (lib "click-forwarding-editor.ss" "mrlib")
+   (lib "snip-lib.ss" "mrlib" "private" "aligned-pasteboard")
+   (lib "aligned-pasteboard.ss" "embedded-gui")
+   (lib "stretchable-editor-snip.ss" "embedded-gui"))
+  
+  (define f (new frame% (label "f") (width 400) (height 400)))
+  (define e (new text%))
+  (define c (new editor-canvas% (editor e) (parent f)))
+  (define pb (new aligned-pasteboard%))
+  (define es (new editor-snip% (editor pb)))
+  (define ses (new (stretchable-editor-snip-mixin editor-snip%)
+                   (editor (new text%))))
+  (send* pb
+    (add (new (stretchable-editor-snip-mixin editor-snip%)
+              (editor (new text%))))
+    (add (make-object string-snip% "This snip is very long")))
+  (send e insert es)
+  (send f show true)
+  )
\ No newline at end of file
diff --git a/collects/embedded-gui/private/tests/target-not-object.ss b/collects/embedded-gui/private/tests/target-not-object.ss
new file mode 100644
index 0000000000..665cf10393
--- /dev/null
+++ b/collects/embedded-gui/private/tests/target-not-object.ss
@@ -0,0 +1,8 @@
+(require
+ (lib "class.ss")
+ (lib "embedded-gui.ss" "embedded-gui"))
+
+(let* ([pb (new aligned-pasteboard%)]
+       [interactions (new vertical-alignment% (parent pb))])
+  (send interactions map-to-list (lambda (x) x))
+  #t)
diff --git a/collects/embedded-gui/private/tests/test-alignment.ss b/collects/embedded-gui/private/tests/test-alignment.ss
new file mode 100644
index 0000000000..0ba2d8ddab
--- /dev/null
+++ b/collects/embedded-gui/private/tests/test-alignment.ss
@@ -0,0 +1,276 @@
+(require
+ (lib "etc.ss")
+ (lib "list.ss")
+ (lib "match.ss")
+ "../alignment.ss"
+ "test-macro.ss")
+
+;;los-equal? ((listof rect?) (listof rect?) . -> . boolean?)
+;;tests the equality of the list of structures
+(define (los-equal? a b)
+  (equal?
+   (map rect->list a)
+   (map rect->list b)))
+
+;;rect->list (rect? . -> . vector?)
+;;a vector of the fields in the rect
+(define rect->list
+  (match-lambda
+    [($ rect ($ dim x width stretchable-width?) ($ dim y height stretchable-height?))
+     (list x width stretchable-width? y height stretchable-height?)]))
+
+;;empty pasteboard
+(test
+ los-equal?
+ (align 'vertical 100 100 empty)
+ empty)
+
+;;empty pasteboard
+(test
+ los-equal?
+ (align 'horizontal 100 100 empty)
+ empty)
+
+;;one unstretchable snip
+(test
+ los-equal?
+ (align 'vertical
+        100 100
+        (list (make-rect (make-dim 0 10 false)
+                         (make-dim 0 10 false))))
+ (list (make-rect (make-dim 0 10 false)
+                  (make-dim 0 10 false))))
+
+(test
+ los-equal?
+ (align 'horizontal
+        100 100
+        (list (make-rect (make-dim 0 10 false)
+                         (make-dim 0 10 false))))
+ (list (make-rect (make-dim 0 10 false)
+                  (make-dim 0 10 false))))
+
+;;one stretchable snip
+(test
+ los-equal?
+ (align 'vertical
+        100 100
+        (list (make-rect (make-dim 0 10 true)
+                         (make-dim 0 10 true))))
+ (list (make-rect (make-dim 0 100 true)
+                  (make-dim 0 100 true))))
+
+;;two stretchable snips
+(test
+ los-equal?
+ (align 'vertical
+        10
+        10
+        (list
+         (make-rect (make-dim 0 0 true)
+                    (make-dim 0 0 true))
+         (make-rect (make-dim 0 0 true)
+                    (make-dim 0 0 true))))
+ (list
+  (make-rect (make-dim 0 10 true)
+             (make-dim 0 5 true))
+  (make-rect (make-dim 0 10 true)
+             (make-dim 5 5 true))))
+
+;;three stretchable, one too big
+(test
+ los-equal?
+ (align 'vertical
+        50 100
+        (list (make-rect (make-dim 0 0 true)
+                         (make-dim 0 50 true))
+              (make-rect (make-dim 0 0 true)
+                         (make-dim 0 0 true))
+              (make-rect (make-dim 0 0 true)
+                         (make-dim 0 0 true))))
+ (list (make-rect (make-dim 0 50 true)
+                  (make-dim 0 50 true))
+       (make-rect (make-dim 0 50 true)
+                  (make-dim 50 25 true))
+       (make-rect (make-dim 0 50 true)
+                  (make-dim 75 25 true))))
+
+;;three stetchable, one too big, and an unstetchable
+(test
+ los-equal?
+ (align 'vertical
+        50 100
+        (list (make-rect (make-dim 0 0 true)
+                         (make-dim 0 50 true))
+              (make-rect (make-dim 0 0 true)
+                         (make-dim 0 0 true))
+              (make-rect (make-dim 0 0 true)
+                         (make-dim 0 0 true))
+              (make-rect (make-dim 0 50 false)
+                         (make-dim 0 10 false))))
+ (list (make-rect (make-dim 0 50 true)
+                  (make-dim 0 50 true))
+       (make-rect (make-dim 0 50 true)
+                  (make-dim 50 20 true))
+       (make-rect (make-dim 0 50 true)
+                  (make-dim 70 20 true))
+       (make-rect (make-dim 0 50 false)
+                  (make-dim 90 10 false))))
+
+;;failure from test-suite frame
+;;wrong answer given was (list (make-rect 0 0 335.0 10 #t))
+(test
+ los-equal?
+ (align 'vertical
+        335.0
+        563.0
+        (list
+         (make-rect (make-dim 0 10.0 #t)
+                    (make-dim 0 10.0 #t))))
+ (list (make-rect (make-dim 0 335.0 true)
+                  (make-dim 0 563.0 true))))
+
+;;sort of like the previous failed test but with a nonsizable snip
+(test
+ los-equal?
+ (align 'vertical
+        563.0
+        335.0
+        (list
+         (make-rect (make-dim 0 10.0 #t)
+                    (make-dim 0 10.0 #t))
+         (make-rect (make-dim 0 10.0 false)
+                    (make-dim 0 10.0 false))))
+ (list (make-rect (make-dim 0 563.0 true)
+                  (make-dim 0 325.0 true))
+       (make-rect (make-dim 0 10.0 false)
+                  (make-dim 325.0 10.0 false))))
+
+;;something that requires a little modulo in division
+(test
+ los-equal?
+ (align 'vertical
+        10
+        10
+        (list
+         (make-rect (make-dim 0 0 true)
+                    (make-dim 0 0 true))
+         (make-rect (make-dim 0 0 true)
+                    (make-dim 0 0 true))
+         (make-rect (make-dim 0 0 true)
+                    (make-dim 0 0 true))))
+ (list (make-rect (make-dim 0 10 true)
+                  (make-dim 0 4 true))
+       (make-rect (make-dim 0 10 true)
+                  (make-dim 4 3 true))
+       (make-rect (make-dim 0 10 true)
+                  (make-dim 7 3 true))))
+
+;; 1 snip only stretches in off dimention
+(test
+ los-equal?
+ (align 'vertical
+        100
+        400
+        (list
+         (make-rect (make-dim 0 10 true)
+                    (make-dim 0 30 false))))
+ (list (make-rect (make-dim 0 100 true)
+                  (make-dim 0 30 false))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; The following examples of usage were taken from the test-suite tool and turned into test cases ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(test
+ los-equal?
+ (align 'vertical 563.0 335.0 (list))
+ empty)
+
+(test
+ los-equal?
+ (align 'vertical 563.0 335.0
+        (list (make-rect (make-dim 0 241 #t) (make-dim 0 114 #f))))
+ (list (make-rect (make-dim 0 563.0 #t) (make-dim 0 114 #f))))
+
+(test
+ los-equal?
+ (align 'vertical 551.0 102.0
+        (list (make-rect (make-dim 0 34 #t) (make-dim 0 47 #t))
+              (make-rect (make-dim 0 231 #t) (make-dim 0 57 #t))))
+ (list (make-rect (make-dim 0 551.0 #t) (make-dim 0 47 #t))
+       (make-rect (make-dim 0 551.0 #t) (make-dim 47 57 #t))))
+
+(test
+ los-equal?
+ (align 'vertical 539.0 35.0
+        (list (make-rect (make-dim 0 24 #f) (make-dim 0 13 #f))
+              (make-rect (make-dim 0 11 #f) (make-dim 0 24 #f))))
+ (list (make-rect (make-dim 0 24 #f) (make-dim 0 13 #f))
+       (make-rect (make-dim 0 11 #f) (make-dim 13 24 #f))))
+
+(test
+ los-equal?
+ (align 'horizontal 539.0 45.0
+        (list (make-rect (make-dim 0 65 #t) (make-dim 0 47 #t))
+              (make-rect (make-dim 0 48 #t) (make-dim 0 47 #t))
+              (make-rect (make-dim 0 63 #t) (make-dim 0 47 #t))
+              (make-rect (make-dim 0 45 #f) (make-dim 0 44 #f))))
+ (list
+  (make-rect (make-dim 0 165.0 true) (make-dim 0 45.0 true))
+  (make-rect (make-dim 165.0 165.0 true) (make-dim 0 45.0 true))
+  (make-rect (make-dim 330.0 164.0 true) (make-dim 0 45.0 true))
+  (make-rect (make-dim 494.0 45 false) (make-dim 0 44 false))))
+
+(test
+ los-equal?
+ (align 'vertical 153.0 33.0
+        (list (make-rect (make-dim 0 55 #f) (make-dim 0 13 #f))
+              (make-rect (make-dim 0 11 #f) (make-dim 0 24 #f))))
+ (list
+  (make-rect (make-dim 0 55 false) (make-dim 0 13 false))
+  (make-rect (make-dim 0 11 false) (make-dim 13 24 false))))
+
+(test
+ los-equal?
+ (align 'vertical 153.0 33.0
+        (list (make-rect (make-dim 0 38 #f) (make-dim 0 13 #f))
+              (make-rect (make-dim 0 11 #f) (make-dim 0 24 #f))))
+ (list
+  (make-rect (make-dim 0 38 false) (make-dim 0 13 false))
+  (make-rect (make-dim 0 11 false) (make-dim 13 24 false))))
+
+(test
+ los-equal?
+ (align 'vertical 152.0 33.0
+        (list (make-rect (make-dim 0 26 #f) (make-dim 0 13 #f))
+              (make-rect (make-dim 0 53 #f) (make-dim 0 24 #f))))
+ (list
+  (make-rect (make-dim 0 26 false) (make-dim 0 13 false))
+  (make-rect (make-dim 0 53 false) (make-dim 13 24 false))))
+
+(test
+ los-equal?
+ (align 'vertical 0 0 empty)
+ empty)
+
+(test
+ los-equal?
+ (align 'vertical 4 0 empty)
+ empty)
+
+(test
+ los-equal?
+ (align 'vertical 0 3 empty)
+ empty)
+
+(test
+ los-equal?
+ (align 'horizontal 35 1 empty)
+ empty)
+
+(test
+ los-equal?
+ (align 'horizontal 0 0
+        (list (make-rect (make-dim 0 4 #f) (make-dim 0 5 #f))))
+ (list (make-rect (make-dim 0 4 #f) (make-dim 0 5 #f))))
\ No newline at end of file
diff --git a/collects/embedded-gui/private/tests/test-case-box.ss b/collects/embedded-gui/private/tests/test-case-box.ss
new file mode 100644
index 0000000000..c5b9c156d9
--- /dev/null
+++ b/collects/embedded-gui/private/tests/test-case-box.ss
@@ -0,0 +1,175 @@
+(require
+ (lib "class.ss")
+ (lib "list.ss")
+ (lib "mred.ss" "mred")
+ (lib "unitsig.ss")
+ (lib "tool.ss" "drscheme")
+ (lib "etc.ss")
+ (lib "match.ss")
+ (lib "framework.ss" "framework")
+ (lib "readerr.ss" "syntax")
+ (lib "string-constant.ss" "string-constants")
+ (lib "embedded-gui.ss" "embedded-gui")
+ (lib "string-constant.ss" "string-constants"))
+
+(define test-case:program-editor% text%)
+
+(define test-case-box%
+  (class editor-snip%
+    (inherit get-admin)
+          
+          (init-field
+           [enabled? true]
+           [actual-show? true]
+           [collapsed? false]
+           [to-test (new test-case:program-editor%)]
+           [expected (new test-case:program-editor%)])
+          
+          (field
+           [actual (new actual-text%)]
+           [result (new result-snip%
+                        (status (if enabled?
+                                    'unknown
+                                    'disabled)))])
+    
+
+          (define (show-actual show?)
+            (set! actual-show? show?)
+            (send show-actual-button set-state
+                  (boolean->show-actual-btn-state show?))
+            (send actual-pane show show?))
+          
+          (define (collapse bool)
+            (set! collapsed? bool)
+            (send collapse-button set-state
+                  (boolean->collapse-btn-state bool))
+            (send pb lock-alignment true)
+            (send left show (not bool))
+            (send right show (not bool))
+            (send pb lock-alignment false))
+            
+          (define (boolean->collapse-btn-state bool)
+            (if bool 'on 'off))
+          
+          (define (boolean->show-actual-btn-state bool)
+            (if bool 'off 'on))
+          
+          (field
+           [pb (new aligned-pasteboard%)]
+           [main (new horizontal-alignment% (parent pb))]
+           [left (new vertical-alignment%
+                      (parent main)
+                      (show? (not collapsed?)))]
+           [right (new vertical-alignment%
+                       (parent main)
+                       (show? (not collapsed?)))]
+           [button-pane (new vertical-alignment% (parent main))]
+           [to-test-pane (new vertical-alignment% (parent left))]
+           [expected-pane (new vertical-alignment% (parent right))]
+           [actual-pane (new vertical-alignment%
+                             (parent right)
+                             (show? actual-show?))]
+           [collapse-button
+            (new turn-button-snip%
+                 (state (boolean->collapse-btn-state collapsed?))
+                 (turn-off
+                  (lambda (b e) (collapse true)))
+                 (turn-on
+                  (lambda (b e) (collapse false))))]
+           [show-actual-button
+            (new turn-button-snip%
+                 (state (boolean->show-actual-btn-state actual-show?))
+                 (turn-off
+                  (lambda (b e) (show-actual false)))
+                 (turn-on
+                  (lambda (b e) (show-actual true))))])
+    
+    (super-new (editor pb))
+          
+          (define (labeled-field alignment label text)
+            ;; I string-append here to give space after the label
+            ;; They look a lot better without something right after them.
+            (new snip-wrapper%
+                 (snip (make-object string-snip% (string-append label "     ")))
+                 (parent alignment))
+            (new snip-wrapper%
+                 (snip (new stretchable-editor-snip%
+                            (editor text)
+                            (stretchable-height false)))
+                 (parent alignment)))
+          
+          (labeled-field to-test-pane (string-constant test-case-to-test) to-test)
+          (labeled-field expected-pane (string-constant test-case-expected) expected)
+          
+          (new snip-wrapper%
+               (snip (make-object string-snip% (string-constant test-case-actual)))
+               (parent actual-pane))
+          (new snip-wrapper%
+               (snip (new (grey-editor-snip-mixin stretchable-editor-snip%)
+                          (editor actual)
+                          (stretchable-height false)))
+               (parent actual-pane))
+          
+          (new snip-wrapper%
+               (snip result)
+               (parent button-pane))
+          ;; NOTE: When you add the collapse feature, be sure that
+          ;; error-reporting on collapsed test-cases highlight the
+          ;; test-case. (PR6955)
+          (new snip-wrapper%
+               (snip collapse-button)
+               (parent button-pane))
+          (new snip-wrapper%
+               (snip show-actual-button)
+               (parent button-pane))
+    ))
+  
+  #;((-> void?) (-> void?) (symbols 'up 'down) . -> . snip%)
+  ;; a snip which acts as a toggle button for rolling a window up and down
+  (define turn-button-snip%
+    (class toggle-button-snip%
+      (super-new
+       (images-off (cons (icon "turn-down.png") (icon "turn-down-click.png")))
+       (images-on (cons (icon "turn-up.png") (icon "turn-up-click.png"))))))
+  
+  ;; a snip which will display a pass/fail result
+  (define result-snip%
+    (class image-snip%
+      (inherit load-file)
+      (init-field [status 'unknown])
+      ;; ((symbols 'pass 'fail 'unknown 'disabled) . -> . void?)
+      ;; updates the image with the icon representing one of three results
+      (define/public (update value)
+        (load-file
+         (test-icon
+          (case value
+            [(pass) "small-check-mark.jpeg"]
+            [(fail) "small-cross.jpeg"]
+            [(unknown) "small-empty.gif"]
+            [(disabled) "small-no.gif"]))))
+      
+      (super-new)
+      (update status)))
+      
+  
+  (define (icon str)
+    (build-path (collection-path "icons") str))
+  
+  (define (test-icon str)
+    (build-path (collection-path "test-suite") "private" "icons" str))
+  
+  ;; a locked text hightlighted to show that it is inactive
+  (define actual-text%
+    (class (grey-editor-mixin
+            (text:hide-caret/selection-mixin scheme:text%))
+      (inherit hide-caret lock)
+      (super-new)
+      (hide-caret true)
+      (lock true)))
+  
+(define f (new frame% (label "f") (width 400) (height 400)))
+(define e (new text%))
+(define c (new editor-canvas% (parent f) (editor e)))
+(define t (new test-case-box%))
+(send f show #t)
+(send e insert t)
\ No newline at end of file
diff --git a/collects/embedded-gui/private/tests/test-macro.ss b/collects/embedded-gui/private/tests/test-macro.ss
new file mode 100644
index 0000000000..a03f5cf213
--- /dev/null
+++ b/collects/embedded-gui/private/tests/test-macro.ss
@@ -0,0 +1,18 @@
+(module test-macro mzscheme
+  
+  (require (lib "etc.ss"))
+  
+  (provide test)
+  
+  ;; test: (lambda (a?) ((a? a? . -> . boolean?) a? a? . -> . (void))
+  ;; tests to see if the expression is true and prints and error if it's not
+  (define-syntax test
+    (syntax-rules (identity)
+      ((_ test actual expected)
+       (let ([result
+              (with-handlers
+                  ([exn? identity])
+                actual)])
+         (and (not (exn? result))
+              (test result expected))))))
+  )
\ No newline at end of file
diff --git a/collects/embedded-gui/private/tests/test-show-feature-for-test-case.ss b/collects/embedded-gui/private/tests/test-show-feature-for-test-case.ss
new file mode 100644
index 0000000000..e2f8334d39
--- /dev/null
+++ b/collects/embedded-gui/private/tests/test-show-feature-for-test-case.ss
@@ -0,0 +1,72 @@
+(require
+ (lib "class.ss")
+ (lib "mred.ss" "mred")
+ "../aligned-pasteboard.ss"
+ "../verthoriz-alignment.ss"
+ "../snip-wrapper.ss"
+ "../stretchable-editor-snip.ss")
+
+(define actual-show? #f)
+(define collapsed? #t)
+(define actual (new text%))
+(define to-test (new text%))
+(define expected (new text%))
+
+(define pb (new aligned-pasteboard%))
+(define main (new horizontal-alignment% (parent pb)))
+(define left (new vertical-alignment%
+                  (parent main)
+                  (show? (not collapsed?))))
+(define right (new vertical-alignment%
+                       (parent main)
+                       (show? (not collapsed?))))
+(define button-pane (new vertical-alignment% (parent main)))
+(define to-test-pane (new vertical-alignment% (parent left)))
+(define expected-pane (new vertical-alignment% (parent right)))
+(define actual-pane (new vertical-alignment%
+                         (parent right)
+                         (show? actual-show?)))
+
+(define f (new frame% (label "f") (width 400) (height 500)))
+(send f show #t)
+(define e (new text%))
+(define c (new editor-canvas% (editor e) (parent f)))
+(define es (new editor-snip% (editor pb)))
+
+(define (show-actual show?)
+  (set! actual-show? show?)
+  (send actual-pane show actual-show?))
+
+(define (collapse bool)
+  (set! collapsed? bool)
+  (send left show (not collapsed?))
+  (send right show (not collapsed?)))
+
+(send e insert es)
+
+(define (labeled-field alignment label text)
+  ;; I string-append here to give space after the label
+  ;; They look a lot better without something right after them.
+  (new snip-wrapper%
+       (snip (make-object string-snip% (string-append label "     ")))
+       (parent alignment))
+  (new snip-wrapper%
+       (snip (new stretchable-editor-snip%
+                  (editor text)
+                  (stretchable-height #f)))
+       (parent alignment)))
+          
+(send pb lock-alignment #t)
+(labeled-field to-test-pane "Test" to-test)
+(labeled-field expected-pane "Expected" expected)
+(new snip-wrapper%
+     (snip (make-object string-snip% "Actual"))
+     (parent actual-pane))
+(new snip-wrapper%
+     (snip (new stretchable-editor-snip%
+                (editor actual)
+                (stretchable-height #f)))
+     (parent actual-pane))
+(send pb lock-alignment #f)
+;(collapse #t)
+;(collapse #f)
\ No newline at end of file
diff --git a/collects/embedded-gui/private/tests/test-show-feature.ss b/collects/embedded-gui/private/tests/test-show-feature.ss
new file mode 100644
index 0000000000..3d84bebc32
--- /dev/null
+++ b/collects/embedded-gui/private/tests/test-show-feature.ss
@@ -0,0 +1,261 @@
+#| This tests to make sure show works. It's not a correct test because
+   it's been abandoned and was reduced to wont-shrink.ss This is still
+   a good file for sandboxing show stuff though.
+|#
+
+(require
+ (lib "class.ss")
+ (lib "mred.ss" "mred")
+ (lib "etc.ss")
+ (lib "list.ss")
+ (lib "match.ss")
+ (prefix a: "../alignment.ss")
+   
+ "../snip-lib.ss"
+ "../interface.ss"
+ "../alignment-helpers.ss"
+ (lib "click-forwarding-editor.ss" "mrlib")
+ "../on-show-pasteboard.ss"
+ "../really-resized-pasteboard.ss"
+ "../interface.ss"
+ "../snip-lib.ss"
+ "../locked-pasteboard.ss"
+ "../verthoriz-alignment.ss"
+ "../suppress-modify-editor.ss")
+  
+(require (lib "print-debug.ss" "mike-lib"))
+  
+(define aligned-pasteboard%
+  (class (click-forwarding-editor-mixin
+          (on-show-pasteboard-mixin
+           (suppress-modify-editor-mixin
+            (locked-pasteboard-mixin
+             (really-resized-pasteboard-mixin pasteboard%)))))
+    
+    (inherit begin-edit-sequence end-edit-sequence
+             get-max-view-size refresh-delayed?)
+    (init align)
+    (field
+     [alignment (new (case align
+                       [(horizontal) horizontal-alignment%]
+                       [(vertical) vertical-alignment%]))]
+     [lock-alignment? false]
+     [needs-alignment? false])
+    
+    (define/public (get-alignment) alignment)
+    
+    #|
+     snip : snip% object
+     before : snip% object or #f
+     x : real number
+     y : real number
+    |#
+    (rename [super-after-insert after-insert])
+    (define/override (after-insert snip before x y)
+      (super-after-insert snip before x y)
+      (realign))
+    
+    #|
+      snip : snip% object
+    |#
+    (rename [super-after-delete after-delete])
+    (define/override (after-delete snip)
+      (super-after-delete snip)
+      (realign))
+    
+    #|
+      snip : snip% object
+    |#
+    (rename [super-really-resized really-resized])
+    (define/override (really-resized snip)
+      (super-really-resized snip)
+      (realign))
+    
+    (rename [super-on-show on-show])
+    (define/override (on-show)
+      (realign)
+      (super-on-show))
+    
+    (define/public (lock-alignment lock?)
+      (set! lock-alignment? lock?)
+      (when (and needs-alignment? (not lock-alignment?))
+        (realign))
+      (if lock?
+          (begin-edit-sequence)
+          (end-edit-sequence)))
+    
+    (define/public (realign)
+      (if lock-alignment?
+          (set! needs-alignment? true)
+          (fluid-let ([lock-alignment? true])
+            (send alignment set-min-sizes)
+            (let ([width (send alignment get-min-width)]
+                  [height (send alignment get-min-height)])
+              (unless (or (zero? width) (zero? height))
+                (send alignment align 0 0 width height)
+                (set! needs-alignment? false))))))
+    
+    (super-new)
+    (send alignment set-pasteboard this)))
+  
+(define (vert/horiz-alignment type)
+  (class* object% (alignment<%>)
+    
+    (init-field
+     [parent false]
+     [show? true])
+    
+    (field
+     [pasteboard false]
+     [children empty]
+     [min-width 0]
+     [min-height 0])
+      
+    ;; STATUS: This function (through lock-alignment false) invokes a call
+    ;; to realign of the pasteboard even when this alignement has show? = false
+    ;; so the call is not needed.
+    (define/public (add child)
+      (set! children (append children (list child)))
+      (send pasteboard lock-alignment true)
+      (cond
+        [(is-a? child snip%)
+         (when (get-show?)
+           (send pasteboard insert child false))]
+        [(is-a? child alignment<%>)
+         (send child set-pasteboard pasteboard)])
+      (send pasteboard lock-alignment false))
+    
+    (define/public (get-min-width)
+      (if (get-show?) min-width 0))
+    (define/public (get-min-height)
+      (if (get-show?) min-height 0))
+    (define/public (set-pasteboard pb) (set! pasteboard pb))
+    (define/public (stretchable-width?) true)
+    (define/public (stretchable-height?) true)
+    
+    #;(boolean? . -> . void?)
+    ;; Shows or hides the alignment
+    (define/public (show bool)
+      (set! show? bool)
+      (when (parent-show?)
+        (send pasteboard lock-alignment true)
+        (show/hide-snips show?)
+        (send pasteboard lock-alignment false)))
+    
+    #;(boolean? . -> . void?)
+    ;; Inserts or deletes all the snips in the tree.
+    (define/public (show/hide-snips bool)
+      (when (boolean=? show? bool)
+        (for-each (show/hide-child bool) children)))
+    
+    (define ((show/hide-child show?) child)
+      (if (is-a? child alignment<%>)
+          (send child show/hide-snips show?)
+          (if show?
+              (send pasteboard insert child)
+              (send pasteboard release-snip child))))
+    
+    (define/public (get-show?)
+      (and show? (parent-show?)))
+    
+    (define (parent-show?)
+      (if (and parent (is-a? parent alignment<%>))
+          (send parent get-show?)
+          true))
+    
+    (define/public (align x-offset y-offset width height)
+      
+      (define move/resize
+        (match-lambda*
+          [(child ($ a:rect
+                     ($ a:dim x w stretchable-width?)
+                     ($ a:dim y h stretchable-height?)))
+           (let ([global-x (+ x x-offset)]
+                 [global-y (+ y y-offset)])
+             (cond
+               [(is-a? child snip%)
+                (send pasteboard move-to child global-x global-y)
+                (when (or stretchable-width? stretchable-height?)
+                      (send child stretch w h))]
+               [(is-a? child alignment<%>)
+                (send child align global-x global-y w h)]))]))
+      
+      (when (and (get-show?) (not (empty? children)))
+        (for-each move/resize
+                  children
+                  (a:align type width height
+                           (map build-rect children)))))
+    
+    (define/public (set-min-sizes)
+      (when show?
+        (for-each
+         (lambda (child)
+           (when (is-a? child alignment<%>)
+             (send child set-min-sizes)))
+         children)
+        (let-values ([(x-accum y-accum)
+                      (if (symbol=? type 'vertical)
+                          (values vacuous-max +)
+                          (values + vacuous-max))])
+          (set! min-width
+                (apply x-accum
+                       (map child-width
+                            children)))
+          (set! min-height
+                (apply y-accum
+                       (map child-height
+                            children))))))
+    
+    (super-new)
+    ;; NOTE: Try to figure out how it's getting a nonalignment<%> parent
+    (when (and parent (is-a? parent alignment<%>))
+      (send parent add this))))
+
+(define vertical-alignment% (vert/horiz-alignment 'vertical))
+(define horizontal-alignment% (vert/horiz-alignment 'horizontal))
+
+;; build-rect ((is-a?/c snip%) . -> . rect?)
+;; makes a new default rect out of a snip
+(define (build-rect item)
+  (cond
+    [(is-a? item snip%)
+     (a:make-rect
+      (a:make-dim 0 (snip-min-width item) (stretchable-width? item))
+      (a:make-dim 0 (snip-min-height item) (stretchable-height? item)))]
+    [(is-a? item alignment<%>)
+     (a:make-rect
+      (a:make-dim 0 (send item get-min-width) (send item stretchable-width?))
+      (a:make-dim 0 (send item get-min-height) (send item stretchable-height?)))]))
+
+;;;;;;;;;;
+;; main
+
+(define f (new frame% (label "f") (width 400) (height 400)))
+(define e (new text%))
+(define c (new editor-canvas% (parent f) (editor e)))
+(define ap (new aligned-pasteboard% (align 'horizontal)))
+(define es (new editor-snip% (editor ap)))
+(define a1 (send ap get-alignment))
+
+(define a2 (new vertical-alignment% (parent a1)))
+(define a3 (new vertical-alignment% (parent a1)))
+(define a4 (new vertical-alignment% (parent a3)))
+(define a5 (new vertical-alignment% (parent a3) (show? #f)))
+
+(send a2 add (make-object string-snip% "a2"))
+(send a4 add (make-object string-snip% "a4"))
+(send a5 add (make-object string-snip% "a5"))
+
+;; this next line blows up but should not
+#;(send a5 show #t)
+  
+(send f show #t)
+(send e insert es)
+
+(let ([a (send a1 get-min-height)])
+  (send a5 show #t)
+  (let ([b (send a1 get-min-height)])
+    (send a5 show #f)
+    (let ([c (send a1 get-min-height)])
+      (values (equal? a c)
+              (equal? a (/ b 2))))))
\ No newline at end of file
diff --git a/collects/embedded-gui/private/tests/unaligned-childless-redux.ss b/collects/embedded-gui/private/tests/unaligned-childless-redux.ss
new file mode 100644
index 0000000000..7db231f77f
--- /dev/null
+++ b/collects/embedded-gui/private/tests/unaligned-childless-redux.ss
@@ -0,0 +1,20 @@
+(require (lib "aligned-pasteboard.ss" "embedded-gui")
+         (lib "debug.ss" "mike-lib"))
+
+(define f (new frame% (label "f") (width 100) (height 100)))
+(define e (new text%))
+(define c (new editor-canvas% (parent f) (editor e)))
+(define main (new aligned-pasteboard%))
+(define j (new editor-snip% (editor main)))
+(define line (new horizontal-alignment% (parent main)))
+(send e insert j)
+(zero? (send line get-min-width))
+(send line add (make-object string-snip% "foo"))
+(send line add (make-object string-snip% "foo"))
+(send f show #t)
+;; If the following test case is delayed it's true.
+;; is this a problem? It could be if this attempt
+;; to read the min-width when aligning. However, this
+;; program prints out foofoo like it should and doesn't
+;; overlap them so maybe we're okay.
+(not (zero? (send line get-min-width)))
diff --git a/collects/embedded-gui/private/verthoriz-alignment.ss b/collects/embedded-gui/private/verthoriz-alignment.ss
new file mode 100644
index 0000000000..cd7f1e9488
--- /dev/null
+++ b/collects/embedded-gui/private/verthoriz-alignment.ss
@@ -0,0 +1,175 @@
+(module verthoriz-alignment mzscheme
+  
+  (require
+   (lib "class.ss")
+   (lib "etc.ss")
+   (lib "list.ss")
+   (lib "match.ss")
+   (prefix a: "alignment.ss")
+   "interface.ss"
+   "alignment-helpers.ss"
+   "dllist.ss")
+   
+  (provide
+   horizontal-alignment%
+   vertical-alignment%)
+  
+  ;;;;;;;;;;
+  ;; alignment
+    
+  (define (vert/horiz-alignment type)
+    (class* dllist% (alignment<%> alignment-parent<%>)
+      
+      (init-field parent [show? true] [after #f])
+      (init [stretchable-width true]
+            [stretchable-height true])
+      
+      (field
+       [pasteboard (send parent get-pasteboard)]
+       [min-width 0]
+       [min-height 0]
+       [stretchable-width? stretchable-width]
+       [stretchable-height? stretchable-height])
+      
+      (field
+       [head (new head%)]
+       [tail (new tail%)])
+      
+      (send head next tail)
+      (send tail prev head)
+      
+      ;;;;;;;;;;
+      ;; alignment<%>
+      
+      #;(-> alignment-parent<%>)
+      ;; The parent of this alignment
+      (define/public (get-parent) parent)
+      
+      #;(-> void?)
+      ;; Tells the alignment that its sizes should be calculated
+      (define/public (set-min-sizes)
+        (when show?
+          (send head for-each
+                (lambda (child)
+                  (send child set-min-sizes)))
+          (let-values ([(x-accum y-accum)
+                        (if (symbol=? type 'vertical)
+                            (values vacuous-max +)
+                            (values + vacuous-max))])
+            (set! min-width
+                  (apply x-accum
+                         (send head map-to-list
+                               (lambda (c) (send c get-min-width)))))
+            (set! min-height
+                  (apply y-accum
+                         (send head map-to-list
+                               (lambda (c) (send c get-min-height))))))))
+      
+      #;(nonnegative? nonnegative? nonnegative? nonnegative? . -> . void?)
+      ;; Tells the alignment to align its children on the pasteboard in the given rectangle
+      (define/public (align x-offset y-offset width height)
+          
+          (define move/resize
+            (match-lambda*
+              [(child ($ a:rect ($ a:dim x w _) ($ a:dim y h _)))
+               (send child align (+ x x-offset) (+ y y-offset) w h)]))
+          
+          (when (is-shown?)
+            (send head for-each
+                  move/resize
+                  (a:align type width height
+                           (send head map-to-list build-rect)))))
+      
+      #;(-> nonnegative?)
+      ;; The minimum width this alignment must be
+      (define/public (get-min-width)
+        (if (is-shown?) min-width 0))
+      
+      #;(-> nonnegative?)
+      ;; The minimum height this alignment must be
+      (define/public (get-min-height)
+        (if (is-shown?) min-height 0))
+      
+      #;(case-> (-> boolean?) (boolean? . -> . void?))
+      ;; True if the alignment can be stretched in the x dimension
+      (public [stretchable-width-method stretchable-width])
+      (define stretchable-width-method
+        (case-lambda
+          [() stretchable-width?]
+          [(value) (set! stretchable-width? value)]))
+      
+      #;(case-> (-> boolean?) (boolean? . -> . void?))
+      ;; True if the alignment can be stretched in the y dimension
+      (public [stretchable-height-method stretchable-height])
+      (define stretchable-height-method
+        (case-lambda
+          [() stretchable-height?]
+          [(value) (set! stretchable-height? value)]))
+      
+      #;(boolean? . -> . void)
+      ;; Tells the alignment to show or hide its children
+      (define/public (show/hide bool)
+        (when show? (show/hide-children bool)))
+      
+      #;(boolean? . -> . void)
+      ;; Tells the alignment that its show state is the given value
+      ;; and it should show or hide its children accordingly.
+      (define/public (show bool)
+        (set! show? bool)
+        (when (send parent is-shown?)
+          (show/hide-children bool)))
+      
+      #;(-> (is-a?/c pasteboard%))
+      ;; The pasteboard that this alignment is being displayed to
+      (define/public (get-pasteboard) pasteboard)
+      
+      #;(((is-a?/c alignment<%>)) ((union (is-a?/c alignment<%>) false?)) . opt-> . void?)
+      ;; Add the given alignment as a child before the existing child
+      (define/public add-child
+        (opt-lambda (child (after #f))
+          (define (link p item n)
+            (send p next child)
+            (send child prev p)
+            (send n prev child)
+            (send child next n))
+          (if after
+              (link after child (send after next))
+              (link (send tail prev) child tail))))
+      
+      #;((is-a?/c alignment<%>) . -> . void?)
+      ;; Deletes a child from the the alignments
+      (define/public (delete-child child)
+        (send child show/hide false)
+        (let ([p (send child prev)]
+              [n (send child next)])
+          (send p next n)
+          (send n prev p)))
+      
+      #;(-> boolean?)
+      ;; True if the alignment is being shown (accounting for its parent being shown)
+      (define/public (is-shown?)
+        (and show? (send parent is-shown?)))
+      
+      ;;;;;;;;;;
+      ;; helpers
+      
+      #;(boolean? . -> . void?)
+      ;; Shows or hides the children
+      (define/private (show/hide-children bool)
+        (send pasteboard lock-alignment true)
+        (send head for-each (lambda (c) (send c show/hide bool)))
+        (send pasteboard lock-alignment false))
+      
+      (super-new)
+      (send parent add-child this after)))
+  
+  (define vertical-alignment% (vert/horiz-alignment 'vertical))
+  (define horizontal-alignment% (vert/horiz-alignment 'horizontal))
+  
+  #;((is-a?/c alignment%) . -> . rect?)
+  ;; makes a new default rect out of an alignment
+  (define (build-rect item)
+    (a:make-rect
+     (a:make-dim 0 (max 0 (send item get-min-width)) (send item stretchable-width))
+     (a:make-dim 0 (max 0 (send item get-min-height)) (send item stretchable-height))))
+  )
diff --git a/collects/eopl/datatype.ss b/collects/eopl/datatype.ss
new file mode 100644
index 0000000000..6e7d2f6071
--- /dev/null
+++ b/collects/eopl/datatype.ss
@@ -0,0 +1,338 @@
+
+;; NOTE: datatypes are currently transparent, for the sake of EoPL's
+;; use of `equal?'
+
+(module datatype mzscheme
+
+  (require-for-syntax "private/utils.ss")
+
+  (define-syntax define-datatype
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ name pred-name 
+	    (variant-name (field-name field-pred) ...) 
+	    ...)
+	 (let ([variant-names (syntax->list (syntax (variant-name ...)))])
+	   ;; More syntax checks...
+	   (unless (identifier? (syntax name))
+	     (raise-syntax-error #f
+				 "expected an identifier for the datatype name"
+				 stx (syntax name)))
+	   (unless (identifier? (syntax pred-name))
+	     (raise-syntax-error #f
+				 "expected an identifier for the predicate name"
+				 stx (syntax pred-name)))
+	   (for-each (lambda (vt fields)
+		       (unless (identifier? vt)
+			 (raise-syntax-error 
+			  'cases 
+			  "expected an identifier for the variant name"
+			  stx vt))
+		       (for-each (lambda (field)
+				   (unless (identifier? field)
+				     (raise-syntax-error 
+				      'cases 
+				      "expected an identifier for the field name"
+				      stx field)))
+				 (syntax->list fields)))
+		     variant-names
+		     (syntax->list (syntax ((field-name ...) ...))))
+	   ;; Count the fields for each variant:
+	   (with-syntax ([(variant-field-count ...) 
+			  (map (lambda (n) 
+				 (datum->syntax-object (quote-syntax here) n #f))
+			       (map length
+				    (map
+				     syntax->list
+				     (syntax->list 
+				      (syntax ((field-name ...) ...))))))]
+                         [(variant? ...)
+                          (map (lambda (vn)
+                                 (datum->syntax-object
+                                  vn
+                                  (string->uninterned-symbol
+                                   (format "~a?" (syntax-e vn)))))
+                               variant-names)]
+                         [(variant-accessor ...)
+                          (map (lambda (vn)
+                                 (datum->syntax-object
+                                  vn
+                                  (string->uninterned-symbol
+                                   (format "~a-accessor" (syntax-e vn)))))
+                               variant-names)]
+                         [(variant-mutator ...)
+                          (generate-temporaries variant-names)]
+                         [(make-variant ...)
+                          (generate-temporaries variant-names)]
+                         [(struct:variant ...)
+                          (generate-temporaries variant-names)]
+                         [(make-variant-name ...)
+                          (map (lambda (vn)
+                                 (datum->syntax-object
+                                  vn
+                                  (string->symbol
+                                   (format "make-~a" (syntax-e vn)))))
+                               variant-names)])
+	     (syntax
+	      (begin
+		(define-syntax name 
+		  ;; Note: we're back to the transformer environment, here.
+		  ;; Also, this isn't a transformer function, so any direct
+		  ;;  use of the name will trigger a syntax error. The name
+		  ;;  can be found by `syntax-local-value', though.
+		  (let ([cert (syntax-local-certifier)])
+		    (make-dt (cert (syntax pred-name))
+			     (list
+			      (make-vt (cert (syntax variant-name))
+				       (cert (syntax variant?))
+				       (cert (syntax variant-accessor))
+				       variant-field-count)
+			      ...))))
+		;; Bind the predicate and selector functions:
+		(define-values (pred-name
+				variant-name ...
+                                variant? ...
+                                variant-accessor ...)
+		  ;; Create a new structure for the datatype (using the
+		  ;; datatype name in `struct', so it prints nicely).
+		  (let-values ([(struct:x make-x x? acc mut)
+				(make-struct-type 'name #f 0 0 #f null (make-inspector))])
+                    (let-values ([(struct:variant make-variant variant? 
+                                                  variant-accessor variant-mutator)
+                                  (make-struct-type 'variant-name struct:x variant-field-count 0
+                                                    #f null (make-inspector))]
+                                 ...)
+                      ;; User-available functions:
+                      (values
+                       x? ;; The datatype predicate
+                       ;; Create the constructor functions:
+                       (let ([vname (quote variant-name)])
+                         (let ([variant-name 
+                                (lambda (field-name ...)
+                                  (unless (field-pred field-name)
+                                    (error vname
+                                           "bad value for ~a field: ~e"
+                                           (quote field-name)
+                                           field-name))
+                                  ...
+                                  (make-variant field-name ...))])
+                           variant-name))
+                       ...
+                       variant? ...
+                       variant-accessor ...))))
+                (define-values (make-variant-name ...) (values variant-name ...))))))]
+        [(_ name pred-name variant ...)
+         ;; Must be a bad variant...
+         (for-each (lambda (variant)
+                     (syntax-case variant ()
+                       [(variant-name field ...)
+                        (let ([name (syntax variant-name)])
+                          (unless (identifier? name)
+                            (raise-syntax-error
+                             #f
+                             "expected an identifier for the variant name"
+                             stx
+                             name))
+                          ;; Must be a bad field:
+                          (for-each (lambda (field)
+                                      (syntax-case field ()
+                                        [(field-name field-pred)
+                                         (let ([name (syntax field-name)])
+                                           (unless (identifier? name)
+                                             (raise-syntax-error
+                                              #f
+                                              "expected an identifier for the field name"
+                                              stx
+                                              name)))]
+                                        [_else
+                                         (raise-syntax-error
+                                          #f
+                                          "expected a field name followed by a predicate expression, all in parentheses"
+                                          stx
+                                          field)]))
+                                    (syntax->list (syntax (field ...)))))]
+                       [_else
+                        (raise-syntax-error
+                         #f
+                         "expected a variant name followed by a sequence of field declarations, all in parentheses"
+                         stx
+                         variant)]))
+                   (syntax->list (syntax (variant ...))))]
+        [(_ name)
+         (raise-syntax-error
+          #f
+          "missing predicate name and variant clauses"
+          stx)])))
+  
+  (define-syntax cases
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ datatype expr 
+	    clause
+	    ...)
+	 ;; Get datatype information:
+	 (let ([dt (and (identifier? (syntax datatype))
+                        (syntax-local-value (syntax datatype) (lambda () #f)))])
+	   (unless (dt? dt)
+	     (raise-syntax-error 
+	      'cases 
+	      "not a datatype name" 
+	      stx
+	      (syntax datatype)))
+	   
+	   ;; Parse clauses:
+	   (let-values ([(vts field-idss bodys else-body)
+			 (let loop ([clauses (syntax->list (syntax (clause ...)))][saw-cases null])
+			   (cond
+			    [(null? clauses)
+			     (values null null null #f)]
+			    [else
+			     (let ([clause (car clauses)])
+			       (syntax-case clause (else)
+				 [(variant (field-id ...) body0 body1 ...)
+				  (let* ([variant (syntax variant)]
+					 [vt
+					  (ormap (lambda (dtv) 
+						   (let ([vt-name (vt-name-stx dtv)])
+						     (and (module-identifier=? variant vt-name)
+							  dtv)))
+						 (dt-variants dt))]
+                                         [orig-variant (and vt (vt-name-stx vt))])
+				    (unless orig-variant
+				      (raise-syntax-error 
+				       #f
+				       (format "not a variant of `~a'"
+					       (syntax-object->datum (syntax datatype)))
+				       stx
+				       variant))
+
+				    (let ([field-ids (syntax->list (syntax (field-id ...)))])
+				      (for-each (lambda (fid)
+						  (unless (identifier? fid)
+						    (raise-syntax-error
+						     #f
+						     "expected an identifier for a field"
+						     stx
+						     fid)))
+						field-ids)
+				      (let ([dtv (variant-assq variant (dt-variants dt))])
+					(unless (= (length field-ids)
+						   (vt-field-count dtv))
+					  (raise-syntax-error
+					   #f
+					   (format
+					    "variant case `~a' for `~a' has wrong field count (expected ~a, found ~a)"
+					    (syntax-object->datum variant)
+					    (syntax-object->datum (syntax datatype))
+					    (vt-field-count dtv)
+					    (length field-ids))
+					   stx
+					   clause)))
+
+				      ;; Check for duplicate local field ids:
+				      (let ([dup (check-duplicate-identifier field-ids)])
+					(when dup
+					  (raise-syntax-error
+					   #f
+					   "duplicate field identifier"
+					   stx
+					   dup)))
+
+				      ;; Check for redundant case:
+				      (when (memq orig-variant saw-cases)
+					(raise-syntax-error
+					 #f
+					 "duplicate case"
+					 stx
+					 clause))
+				    
+				      ;; This clause is ok:
+				      (let-values ([(vts idss bodys else)
+						    (loop (cdr clauses) (cons orig-variant saw-cases))])
+					(values (cons vt vts)
+						(cons field-ids idss)
+						(cons (syntax (begin body0 body1 ...)) bodys)
+						else))))]
+				 [(else body0 body1 ...)
+				  (begin
+				    (unless (null? (cdr clauses))
+				      (raise-syntax-error
+				       #f
+				       "else clause must be last"
+				       stx
+				       clause))
+				    (values null null null (syntax (begin body0 body1 ...))))]
+				 [_else (raise-syntax-error
+					 #f
+					 "bad clause"
+					 stx
+					 clause)]))]))])
+             
+             ;; Missing any variants?
+             (unless (or else-body
+                         (= (length vts) (length (dt-variants dt))))
+               (let* ([here (map vt-name-stx vts)]
+                      [missing (let loop ([l (dt-variants dt)])
+                                (cond
+                                  [(null? l) ""]
+                                  [(ormap (lambda (i) (module-identifier=? (vt-name-stx (car l)) i)) here)
+                                   (loop (cdr l))]
+                                  [else
+                                   (format " ~a~a" 
+                                           (syntax-e (vt-name-stx (car l)))
+                                           (loop (cdr l)))]))])
+                 (raise-syntax-error
+                  #f
+                  (format "missing cases for the following variants:~a" missing)
+                  stx)))
+	     
+	     ;; Create the result:
+	     (with-syntax ([pred (dt-pred-stx dt)]
+			   [(variant? ...) (map vt-predicate-stx vts)]
+			   [((field-extraction ...) ...) 
+                            (map (lambda (vt)
+                                   (with-syntax ([accessor (vt-accessor-stx vt)])
+                                     (let loop ([n 0])
+                                       (if (= n (vt-field-count vt))
+                                           null
+                                           (cons (with-syntax ([n n])
+                                                   (syntax (accessor v n)))
+                                                 (loop (add1 n)))))))
+                                 vts)]
+			   [((field-id ...) ...) field-idss]
+			   [(body ...) bodys]
+			   [else-body (or else-body
+					  (syntax 
+					   (error 'cases "no variant case matched")))])
+	       (syntax
+		(let ([v expr])
+		  (if (not (pred v))
+		      (error 'cases "not a ~a: ~s" 
+			     (quote datatype) v)
+                      (cond
+                        [(variant? v)
+                         (let ([field-id field-extraction] ...)
+                           body)]
+                        ...
+                        [else else-body])))))))])))
+     
+  (define-syntax provide-datatype
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ datatype)
+	 (let ([dt (syntax-local-value (syntax datatype) (lambda () #f))])
+	   (unless (dt? dt)
+	     (raise-syntax-error
+	      #f
+	      "not a datatype name" 
+	      stx
+	      (syntax datatype)))
+	   (with-syntax ([pred (dt-pred-stx dt)]
+			 [(orig-variant ...) 
+			  (map vt-name-stx (dt-variants dt))])
+	     (syntax
+	      (provide datatype
+		       pred
+		       orig-variant ...))))])))
+
+  (provide define-datatype cases provide-datatype))
diff --git a/collects/eopl/doc.txt b/collects/eopl/doc.txt
new file mode 100644
index 0000000000..3c6b8d9880
--- /dev/null
+++ b/collects/eopl/doc.txt
@@ -0,0 +1,122 @@
+
+The _Essentials of Programming Languages_ (a.k.a _EoPL_) language in
+DrScheme provides all of the functions of R5RS, plus the forms and
+procedures described below. It is intended for use with the textbook
+
+  Essentials of Programming Languages, Second Edition
+  Friedman, Wand, and Haynes
+  MIT Press, 2001
+
+Differences from the book:
+
+ * Datatypes must be defined before they are used in `cases'
+   expressions. This constraint enables better and earlier error
+   reporting.
+
+   Some examples in the book's code (or at least the code dstributed
+   for the book) must be changed by moving datatype definitions
+   earlier.
+
+ * The sllgen: functions have been changed to syntactic forms. This
+   change is also related to better error reporting. 
+  
+   All examples in the book work work with the sllgen: forms.
+
+----------------------------------------
+
+> (define-datatype id predicate-id (variant-id (field-id predicate-expr) ...) ...)
+
+  Defines the datatype `id' and a function `predicate-id' that returns
+  #t for instances of the datatype, and #f for any other value.
+
+  Each `variant-id' is defined as a constructor function that creates
+  an instance of the datatype; the constructor takes as many arguments
+  as the variant's `field-id's, and each argument is checked by
+  applying the function produced by the variant's `predicate-expr'.
+
+  When constructor-based printing is used in DrScheme, variant
+  instances are printed with a `make-' prefix before the variant name.
+  Thus, in addition to `variant-id', `make-variant-id' is also defined
+  for each `variant-id' (to the same constructor as `variant-id').
+
+> (cases datatype-id expr (variant-id (field-id ...) result-expr ...) ...)
+> (cases datatype-id expr (variant-id (field-id ...) result-expr ...) ... (else result-expr ...))
+
+  Branches on the datatype instance produced by `expr', which must be
+  an instance of the specified `datatype-id' (previously defined with
+  `define-datatype').
+
+> sllgen:make-string-scanner
+> sllgen:make-string-parser
+> sllgen:make-stream-parser
+> sllgen:make-define-datatypes
+> sllgen:show-define-datatypes
+> sllgen:list-define-datatypes
+
+  Defined in the EoPL textbook's Appendix A. However, the DrScheme
+  versions are syntactic forms, instead of procedures, and the
+  arguments must be either quoted literal tables or identifiers that
+  are defined (at the top level) to quoted literal tables.
+
+> sllgen:make-rep-loop
+
+  Defined in the EoPL textbook's Appendix A (and still a function).
+
+> eopl:error
+
+  As in the book.
+
+> eopl:printf
+> eopl:pretty-print
+
+  Same as MzScheme's `printf' and `pretty-print'.
+
+> list-of
+> always?
+
+  As in the book.
+
+> empty 
+
+  The empty list.
+
+> (time expr)
+
+  Evaluates `expr', and prints timing information before returning the
+  result.
+
+> (collect-garbage)
+
+  Performs a garbage collection (useful for repeatable timings).
+
+> (trace id ...)
+> (untrace id ...)
+
+  For debugging: `trace' redefines each `id' at the top level (bound
+  to a procedure) so that it prints arguments on entry and results on
+  exit. `untrace' reverses the action of `trace' for the given `id's.
+
+  Tracing a function causes tail-calls in the original function to
+  become non-tail calls.
+
+> (provide provide-spec ...)
+
+  Useful only with a module that uses _(lib "eopl.ss" "eopl")_ as a
+  language: exports identifiers from the module. See the MzScheme
+  manual for information on `provided-spec'.
+
+> eopl:error-stop
+
+  Defined only in the top-level namespace (i.e., not in a module);
+  mutate this varable to install an exception-handling
+  thunk. Typically, the handler thunk escapes through a continuation.
+
+  The "eopl.ss" module sets this variable to #f in the current
+  namespace when it executes.
+
+> (install-eopl-exception-handler)
+
+  Sets MzScheme's exception handler to one that checks
+  `eopl:error-stop'.
+
+  The "eopl.ss" module calls this function when it executes.
diff --git a/collects/eopl/eopl-small.gif b/collects/eopl/eopl-small.gif
new file mode 100644
index 0000000000..0338fb3c98
Binary files /dev/null and b/collects/eopl/eopl-small.gif differ
diff --git a/collects/eopl/eopl-tool.ss b/collects/eopl/eopl-tool.ss
new file mode 100644
index 0000000000..4fb8761573
--- /dev/null
+++ b/collects/eopl/eopl-tool.ss
@@ -0,0 +1,59 @@
+
+#|
+
+The EoPL language can almost be specified via info.ss fields, but
+on-execute needs to install the EoPL exception handler as its 
+last action. (The module body can't do that, because a `with-handlers'
+wraps the load of the module.)
+
+|#
+
+(module eopl-tool mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "class.ss")
+	   (lib "tool.ss" "drscheme")
+           (lib "string-constant.ss" "string-constants"))
+  
+  (provide tool@)
+
+  (define tool@
+    (unit/sig drscheme:tool-exports^
+      (import drscheme:tool^)
+
+      (define language-base%
+	(class* object% (drscheme:language:simple-module-based-language<%>)
+	  (define/public (get-language-numbers)
+	    '(-500 -400))
+	  (define/public (get-language-position)
+	    (list (string-constant teaching-languages)
+                  "Essentials of Programming Languages (2nd ed.)"))
+	  (define/public (get-module)
+	    '(lib "eopl.ss" "eopl"))
+	  (define/public (get-one-line-summary)
+	    "Based on the Friedman, Wand, and Haynes text")
+          (define/public (get-language-url)
+	    "http://www.cs.indiana.edu/eopl/")
+	  (define/public (get-reader)
+	    (lambda (src port)
+              (let ([v (read-syntax src port)])
+                (if (eof-object? v)
+                  v
+                  (namespace-syntax-introduce v)))))
+	  (super-instantiate ())))
+
+      (define language%
+	(class (drscheme:language:module-based-language->language-mixin
+		(drscheme:language:simple-module-based-language->module-based-language-mixin
+		 language-base%))
+	  (define/override (use-namespace-require/copy?) #t)
+	  (define/override (on-execute settings run-in-user-thread)
+	    (super on-execute settings run-in-user-thread)
+	    (run-in-user-thread
+	     (lambda ()
+	       ((namespace-variable-value 'install-eopl-exception-handler)))))
+	  (super-instantiate ())))
+
+      (define (phase1) (void))
+      (define (phase2)
+	(drscheme:language-configuration:add-language 
+	 (make-object ((drscheme:language:get-default-mixin) language%)))))))
diff --git a/collects/eopl/eopl.ss b/collects/eopl/eopl.ss
new file mode 100644
index 0000000000..966a648852
--- /dev/null
+++ b/collects/eopl/eopl.ss
@@ -0,0 +1,196 @@
+(module eopl mzscheme
+  (require "datatype.ss"
+	   "private/sllgen.ss"
+	   (lib "trace.ss")
+	   (lib "pretty.ss"))
+  (require-for-syntax "private/slldef.ss")
+
+  (provide define-datatype
+	   cases)
+
+  ;; Special def that saves a quoted value at compile time in case
+  ;; it's needed for `sllgen:make-define-datatypes':
+  (define-syntax (eopl-define stx)
+    (syntax-case stx (quote)
+      [(_ name (quote def))
+       (identifier? (syntax name))
+       (begin
+	 (hash-table-put! sllgen-def
+			  (syntax-e (syntax name))
+			  (syntax def))
+	 (syntax/loc stx (define name (quote def))))]
+      [(_ . rest)
+       (syntax/loc stx (define . rest))]))
+
+  (provide (rename eopl-define define))
+
+  (provide (all-from "private/sllgen.ss"))
+
+  (provide (rename error eopl:error)
+	   (rename printf eopl:printf)
+	   (rename pretty-print eopl:pretty-print))
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  ;; Ugly: 
+  ;;
+  ;;   1) `eopl:error-stop' has to be a top-level binding to be
+  ;;      mutated by client programs --- actually, the test harness ---
+  ;;      for exception handling.
+  ;;   2) Exception jumps by the test harness are performed through
+  ;;      call/cc, not call/ec.
+  ;;
+  ;; Solution: use `namespace-variable-value', and create an escape
+  ;; continuation for each nested continuation.
+
+  (define esc-cont-mark-key (gensym))
+  (define detect-tail-key (gensym))
+  (define recovering-from-error (make-parameter #f))
+  (define (mk-k k ek)
+    (lambda args 
+      (apply (if (recovering-from-error) ek k) args)))
+
+  (define (eopl:call-with-current-continuation f)
+    (unless (and (procedure? f)
+		 (procedure-arity-includes? f 1))
+      ;; let call/cc report the error:
+      (call/cc f))
+    (let/cc k
+      (let ([v (gensym)]
+	    [orig-marks (continuation-mark-set->list
+			 (continuation-marks k)
+			 detect-tail-key)])
+	(with-continuation-mark detect-tail-key v
+	  (let ([new-marks (continuation-mark-set->list
+			    (current-continuation-marks)
+			    detect-tail-key)])
+	    (if (or (null? orig-marks)
+		    (and (pair? (cdr new-marks))
+			 (eq? (car orig-marks) (cadr new-marks))))
+		;; Old mark surived => not tail wrt old call.
+		;; Create an escape continuation to use for
+		;; error escapes. Of course, we rely on the fact
+		;; that continuation marks are not visible to EoPL
+		;; programs.
+		(let/ec ek
+		  (with-continuation-mark esc-cont-mark-key ek
+		    (with-continuation-mark detect-tail-key (gensym)
+		      (f (mk-k k ek)))))
+		;; Old mark replaced => tail wrt old call.
+		;; To preserve tail semantics for all but the first call
+		;; reuse `mark' instead of creating a new escape continuation:
+		(let ([mark (car (continuation-mark-set->list
+				  (continuation-marks k)
+				  esc-cont-mark-key))])
+		  (f (mk-k k mark)))))))))
+  
+  (namespace-set-variable-value! 'eopl:error-stop #f #t)
+  (define (install-eopl-exception-handler)
+    (current-exception-handler 
+     (let ([eh (current-exception-handler)]
+	   [orig-namespace (current-namespace)])
+       (lambda (x)
+	 (let ([v (with-handlers ([void (lambda (x) #f)])
+		    (parameterize ([current-namespace orig-namespace])
+		      (namespace-variable-value 'eopl:error-stop)))])
+	   (if v
+	       (parameterize ([recovering-from-error #t])
+		 (v))
+	       (eh x)))))))
+  
+  (provide install-eopl-exception-handler)
+  
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (provide always? list-of)
+
+  (define always?
+    (lambda (x) #t))
+  
+  (define list-of
+    (lambda (pred . l)
+      (let ((all-preds (cons pred l)))
+	(lambda (obj)
+	  (let loop ((obj obj) (preds '()))
+	    (or 
+	     ;; if list is empty, preds should be, too
+	     (and (null? obj) (null? preds))
+	     (if (null? preds)
+		 ;; if preds is empty, but list isn't, then recycle
+		 (loop obj all-preds)
+		 ;; otherwise check and element and recur.
+		 (and (pair? obj)
+		      ((car preds) (car obj))
+		      (loop (cdr obj) (cdr preds))))))))))
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (define empty null)
+
+  (provide time            ;; useful to compare implementations
+	   collect-garbage ;; useful with `time'
+	   empty           ;; for constructor-based printing
+	   trace untrace   ;; debugging
+           require module  ;; we allow full use of modules
+	   provide)        ;; in case someone wants to use a module
+
+  ;; Unfortunately, most of the rest is cut-and-pasted from R5RS:
+
+  ;; values
+  (provide car cdr caar cadr cdar cddr
+	   caaar caadr cadar caddr cdaar cdadr cddar cdddr
+	   caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
+	   cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
+	   map = < > <= >= max min + - * / 
+	   abs gcd lcm exp log sin cos tan not eq?
+	   (rename eopl:call-with-current-continuation call-with-current-continuation)
+	   make-string
+	   symbol->string string->symbol make-rectangular 
+	   exact->inexact inexact->exact number->string string->number 
+	   rationalize output-port? current-input-port current-output-port current-error-port 
+	   open-input-file open-output-file close-input-port close-output-port
+	   with-output-to-file transcript-on transcript-off flush-output
+	   string-length string-ci<=? string-ci>=? string-append 
+	   string->list list->string string-fill! 
+	   vector-length vector->list list->vector vector-fill!
+	   char-alphabetic? char-numeric? char-whitespace? 
+	   char-upper-case? char-lower-case? char->integer integer->char char-downcase
+	   call-with-output-file call-with-input-file with-input-from-file
+	   apply for-each symbol? pair? cons set-car! set-cdr! null? list? list length append reverse
+	   list-tail list-ref memq memv member assq assv assoc procedure?
+	   number? complex? real? rational? integer? exact? inexact? zero?
+	   positive?  negative? odd? even? 
+	   quotient remainder modulo floor ceiling truncate round 
+	   numerator denominator asin acos atan sqrt
+	   expt make-polar real-part imag-part angle magnitude input-port?
+	   read read-char peek-char eof-object?
+	   char-ready? write display newline write-char load 
+	   string? string string-ref string-set! string=? substring string-copy
+	   string-ci=? string<? string>? string<=? string>=? string-ci<? string-ci>?
+	   vector? make-vector vector vector-ref vector-set! 
+	   char? char=? char<? char>? char<=? char>=? 
+	   char-ci=? char-ci<? char-ci>? char-ci<=? char-ci>=? 
+	   char-upcase boolean? eqv? equal? force
+	   call-with-values values eval port? scheme-report-environment null-environment 
+	   interaction-environment dynamic-wind)
+
+  ;; syntax
+  (provide quasiquote unquote unquote-splicing 
+	   if let and or cond case delay do
+	   letrec let* begin lambda quote set!
+	   define-syntax
+
+	   ;; We have to include the following MzScheme-isms to do anything,
+	   ;; but they're not legal R5RS names, anyway.
+	   #%app #%datum #%top 
+	   (rename synrule-in-stx-module-begin #%module-begin))
+
+  (define-syntax synrule-in-stx-module-begin
+    (lambda (stx)
+      (datum->syntax-object
+       (quote-syntax here)
+       (list* (quote-syntax #%plain-module-begin)
+	      (quote-syntax 
+	       (require-for-syntax (rename mzscheme syntax-rules syntax-rules)))
+	      (cdr (syntax-e stx)))
+       stx))))
diff --git a/collects/eopl/info.ss b/collects/eopl/info.ss
new file mode 100644
index 0000000000..c7903d2474
--- /dev/null
+++ b/collects/eopl/info.ss
@@ -0,0 +1,10 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "EoPL")
+  (define doc.txt "doc.txt")
+  (define tools (list "eopl-tool.ss"))
+  (define tool-icons (list "eopl-small.gif"))
+  (define tool-names (list "Essentials of Programming Languages"))
+  (define tool-urls (list "http://www.cs.indiana.edu/eopl/")))
+
+
+
diff --git a/collects/eopl/private/info.ss b/collects/eopl/private/info.ss
new file mode 100644
index 0000000000..7c4212071c
--- /dev/null
+++ b/collects/eopl/private/info.ss
@@ -0,0 +1,2 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "EoPL private"))
diff --git a/collects/eopl/private/sllboth.ss b/collects/eopl/private/sllboth.ss
new file mode 100644
index 0000000000..af96244f27
--- /dev/null
+++ b/collects/eopl/private/sllboth.ss
@@ -0,0 +1,71 @@
+
+(module sllboth mzscheme
+
+  ;; This is stuff that lives at both table-consruction time and
+  ;; table-use time. That's ok because the data is all built on
+  ;; S-expression.
+
+  (provide sllgen:action-preference-list
+	   sllgen:action?
+	   sllgen:make-tester-regexp
+	   sllgen:make-or-regexp
+	   sllgen:make-arbno-regexp
+	   sllgen:make-concat-regexp
+	   sllgen:tester-regexp? 
+	   sllgen:or-regexp?
+	   sllgen:arbno-regexp?
+	   sllgen:concat-regexp?
+	   sllgen:tester-symbol-list
+	   sllgen:make-char-tester
+	   sllgen:tester?)
+
+  (define sllgen:action-preference-list
+    '(string make-string symbol make-symbol number make-number skip))
+
+  (define sllgen:action?
+    (lambda (action)
+      (and
+       (pair? action)
+       (member (car action) sllgen:action-preference-list)
+       (symbol? (cdr action))))) 
+
+  (define sllgen:make-tester-regexp (lambda (x) x))
+  (define sllgen:make-or-regexp (lambda (res) (cons 'or res)))
+  (define sllgen:make-arbno-regexp (lambda (re) (list 'arbno re)))
+  (define sllgen:make-concat-regexp (lambda (rs) (cons 'concat rs)))
+
+  (define sllgen:tester-regexp? 
+    (lambda (x) 
+      (and (sllgen:tester? x) (lambda (f) (f x)))))
+
+  (define sllgen:or-regexp?
+    (lambda (x)
+      (and (eq? (car x) 'or)
+	   (lambda (f) (f (cdr x))))))
+
+  (define sllgen:arbno-regexp?
+    (lambda (x)
+      (and (eq? (car x) 'arbno)
+	   (lambda (f) (f (cadr x))))))
+
+  (define sllgen:concat-regexp?
+    (lambda (x)
+      (and (eq? (car x) 'concat)
+	   (lambda (f) (f (cdr x))))))
+
+  (define sllgen:tester-symbol-list '(letter digit any whitespace))
+
+  (define sllgen:make-char-tester 
+    (lambda (char) 
+      (and (or (char? char)
+	       (error 'scanner-generation "illegal character ~s" char))
+	   char)))
+
+  (define sllgen:tester?
+    (lambda (v)
+      (or (char? v)
+	  (member v sllgen:tester-symbol-list)
+	  (and (pair? v)
+	       (eq? (car v) 'not)
+	       (pair? (cdr v))
+	       (char? (cadr v)))))))
\ No newline at end of file
diff --git a/collects/eopl/private/slldef.ss b/collects/eopl/private/slldef.ss
new file mode 100644
index 0000000000..85e4164051
--- /dev/null
+++ b/collects/eopl/private/slldef.ss
@@ -0,0 +1,4 @@
+(module slldef mzscheme
+  ;; A compile-time table shared by eopl and sllgen:
+  (define sllgen-def (make-hash-table))
+  (provide sllgen-def))
diff --git a/collects/eopl/private/sllgen.ss b/collects/eopl/private/sllgen.ss
new file mode 100644
index 0000000000..8fff178abc
--- /dev/null
+++ b/collects/eopl/private/sllgen.ss
@@ -0,0 +1,2089 @@
+;;; sllgen -- Scheme LL(1) parser generator
+
+;; In this version, most of the sllgen: names are syntactic forms
+;; instead of procedures. The compilation versus execution phases have
+;; been split, so that the grammar table, etc. is parsed at compile
+;; time.
+
+(module sllgen mzscheme
+  (require (lib "pretty.ss")
+	   "../datatype.ss"
+	   "sllboth.ss"
+	   (lib "etc.ss"))
+
+  (require-for-syntax "sllboth.ss"
+		      "slldef.ss")
+
+  (provide sllgen:make-string-scanner
+	   sllgen:make-string-parser
+	   sllgen:make-stream-parser
+	   sllgen:make-rep-loop
+	   sllgen:make-define-datatypes
+	   sllgen:show-define-datatypes
+	   sllgen:list-define-datatypes)
+
+  '(let ((time-stamp "Time-stamp: <2000-09-25 11:48:47 wand>"))
+     (display (string-append
+	       "sllgen.scm "
+	       (substring time-stamp 13 29)
+	       (string #\newline))))
+ 
+ (define sllgen:make-rep-loop
+   (lambda (prompt eval-fn stream-parser)
+    (lambda ()
+      (display prompt) (flush-output)
+      (let loop
+        ((ast-stream (stream-parser (sllgen:stdin-char-stream))))
+        (sllgen:stream-get! ast-stream
+          (lambda (tree stream)
+            (write (eval-fn tree))
+            (newline)
+            (display prompt) (flush-output)
+            (loop stream))
+          (lambda () #t))))))
+
+  ;; ****************************************************************        
+
+  ;; Table of contents:
+
+  ;; top.s                     top-level entries
+  ;; parser-gen.scm            organization of parser generator
+  ;; syntax.s                  concrete syntax for grammars, etc.
+  ;; eliminate-arbno.s         replaces (ARBNO lhs) items with new productions
+  ;; first-and-follow.s        calculate first and follow sets
+  ;; gen-table.s               take list of productions, first and
+  ;;                           follow tables, and generate parsing table
+  ;; check-table.s             take a parse table and check for conflicts
+  ;; scan.s                    scanner using streams
+  ;; parse.s                   run the generated parser
+  ;; error handling
+  ;; tests
+
+  ;; ****************************************************************
+
+  ;; Mon Sep 25 11:48:13 2000 added scanner outcomes symbol, number,
+  ;; string to replace make-symbol, make-number, and make-string.
+
+  ;; Wed Apr 12 14:15:24 2000 version intended to be R5RS-compliant,
+  ;; based on suggestions by Will Clinger.
+
+  ;; ****************************************************************
+
+  ;; be sure to load compatibility files!!
+
+  ;; ****************************************************************
+
+  ;; top.s
+
+  ;; user-level entry points
+
+  (define-syntax-set (sllgen:make-string-scanner
+		      sllgen:make-string-parser
+		      sllgen:make-stream-parser
+		      sllgen:make-define-datatypes
+		      sllgen:show-define-datatypes
+		      sllgen:list-define-datatypes)
+
+    ;; Gets a table: maybe immediate, maybe from a top-level definition
+    (define (get-table srcstx t what)
+      (let ([def (and (identifier? t)
+		      (hash-table-get sllgen-def (syntax-e t) (lambda () #f)))])
+	(if def
+	    (syntax-object->datum def)
+	    (syntax-case t (quote)
+	      [(quote v)
+	       (syntax-object->datum (syntax v))]
+	      [_else
+	       (raise-syntax-error #f 
+				   (format "bad ~a specification" what)
+				   srcstx
+				   t)]))))
+
+    (define (make-one maker)
+      (lambda (stx)
+	(syntax-case stx ()
+	  [(_ scanner-spec grammar)
+	   (maker
+	    (get-table stx (syntax scanner-spec) "scanner")
+	    (get-table stx (syntax grammar) "grammar")
+	    stx)])))
+
+    (define sllgen:make-string-parser-maker
+      (lambda (scanner-spec grammar srcstx)
+	(with-syntax ((parser-maker (sllgen:make-parser-maker grammar srcstx))
+		      (scanner-maker (sllgen:make-scanner-maker
+				      (append
+				       (sllgen:grammar->string-literal-scanner-spec
+					grammar)
+				       scanner-spec))))
+	  (syntax (make-string-parser parser-maker scanner-maker)))))
+
+    (define sllgen:make-string-parser/proc (make-one sllgen:make-string-parser-maker))
+
+    (define sllgen:make-stream-parser-maker
+      (lambda (scanner-spec grammar srcstx)
+	(with-syntax ((parser-maker (sllgen:make-parser-maker grammar srcstx))
+		      (scanner-maker (sllgen:make-scanner-maker
+				      (append
+				       (sllgen:grammar->string-literal-scanner-spec
+					grammar)
+				       scanner-spec))))
+	  (syntax (make-stream-parser parser-maker scanner-maker)))))
+
+    (define sllgen:make-stream-parser/proc (make-one sllgen:make-stream-parser-maker))
+
+    (define sllgen:make-stream-scanner-maker
+      (lambda (scanner-spec grammar srcstx)
+	(sllgen:make-scanner-maker
+	 (append
+	  (sllgen:grammar->string-literal-scanner-spec
+	   grammar)
+	  scanner-spec))))
+
+    (define sllgen:make-stream-scanner/proc (make-one sllgen:make-stream-scanner-maker))
+
+    (define sllgen:make-string-scanner-maker
+      (lambda (scanner-spec grammar srcstx)
+	(with-syntax ((scanner-maker (sllgen:make-stream-scanner-maker scanner-spec grammar srcstx)))
+	  (syntax (let ([scanner scanner-maker])
+		    (lambda (string)
+		      (sllgen:stream->list
+		       (scanner (sllgen:string->stream string)))))))))
+
+    (define sllgen:make-string-scanner/proc (make-one sllgen:make-string-scanner-maker))
+
+    (define sllgen:make-define-datatypes-maker
+      (lambda (scanner-spec grammar srcstx)
+	(with-syntax ((datatype-definitions
+		       (datum->syntax-object
+			srcstx
+			(sllgen:build-define-datatype-definitions scanner-spec grammar)
+			srcstx)))
+	  (syntax (begin . datatype-definitions)))))
+
+    (define sllgen:make-define-datatypes/proc (make-one sllgen:make-define-datatypes-maker))
+
+    (define sllgen:show-define-datatypes-maker
+      (lambda (scanner-spec grammar srcstx)
+	(with-syntax ((datatype-definitions
+		       (sllgen:build-define-datatype-definitions scanner-spec grammar)))
+	  (syntax (begin
+		    (for-each
+		     pretty-print 
+		     'datatype-definitions))))))
+
+    (define sllgen:show-define-datatypes/proc (make-one sllgen:show-define-datatypes-maker))
+
+    (define sllgen:list-define-datatypes-maker
+      (lambda (scanner-spec grammar srcstx)
+	(with-syntax ((datatype-definitions
+		       (sllgen:build-define-datatype-definitions scanner-spec grammar)))
+	  (syntax 'datatype-definitions))))
+
+    (define sllgen:list-define-datatypes/proc (make-one sllgen:list-define-datatypes-maker))
+
+    ;; ****************************************************************
+    ;; ****************************************************************
+
+    ;; parser-gen.scm 
+
+    ;; Steps in parser generation:
+
+    ;; 1.  Eliminate arbno's by making new nonterms with goto's and
+    ;; emit-list's. 
+
+    ;; 2.  Factor productions with common prefixes (not in this version).
+
+    ;; 3.  Compute first and follow sets
+
+    ;; 4.  Compute prediction table & generate actions
+
+    ;; ****************************************************************
+
+    ;; parser = token-stream * ((tree * token * token-stream) -> ans) -> ans
+    ;; token-stream should be terminated by end-marker token.
+
+    (define (qq-ize table srcstx)
+      (list 'quasiquote 
+	    (map (lambda (prod)
+		   (cons (car prod)
+			 (map (lambda (case)
+				(cons (car case)
+				      (map (lambda (act)
+					     (if (eq? (car act) 'reduce)
+						 (list 'reduce
+						       (list 'unquote 
+							     (datum->syntax-object
+							      srcstx
+							      (cadr act))))
+						 act))
+					   (cdr case))))
+			      (cdr prod))))
+		 table)))
+
+    (define sllgen:make-parser-maker            
+      (lambda (grammar srcstx)
+	(sllgen:grammar-check-syntax grammar)
+	(sllgen:initialize-non-terminal-table! grammar)
+	(sllgen:arbno-initialize-table!)
+	(let ((parse-table (sllgen:build-parse-table grammar))
+	      (start-symbol (sllgen:grammar->start-symbol grammar)))
+	  (with-syntax ([parse-table (qq-ize parse-table srcstx)]
+			[start-symbol start-symbol])
+	    (syntax
+	     (lambda (token-stream k)       ; k : (tree * token * token-stream) -> ans
+	       (sllgen:find-production 'start-symbol parse-table 
+				       '() '() token-stream k)))))))
+    
+
+    (define the-table 'ignored)
+
+    (define sllgen:build-parse-table
+      (lambda (grammar)
+	(let* ((g (sllgen:eliminate-arbnos-from-productions grammar))
+	       (first-table (sllgen:first-table g))
+	       (follow-table (sllgen:follow-table
+			      (sllgen:grammar->start-symbol grammar)
+			      g
+			      first-table))
+	       (table
+		(sllgen:productions->parsing-table g first-table
+						   follow-table)))
+					;       (sllgen:pretty-print first-table)
+					;       (sllgen:pretty-print follow-table)
+					;        (sllgen:pretty-print table)
+	  (set! the-table table)
+	  (sllgen:check-table table)
+	  table)))
+
+
+    ;; ****************************************************************
+
+    ;; syntax.s :  concrete syntax for grammars, etc.
+
+    ;; ****************************************************************
+
+    ;; Concrete Syntax for grammars
+
+    ;; <Grammar> ::= (<production> ...)  ;; nonterm of first prod is
+    ;;                                      start symbol.
+    ;; <production> ::= (lhs rhs action)
+    ;;
+    ;; lhs ::= symbol                    ;; a symbol that appears in a
+    ;;                                      lhs is a non-term, all others
+    ;;                                      are terminals
+    ;; rhs ::= (rhs-item ...)
+    ;;
+    ;; rhs-item ::= string | symbol | (ARBNO . rhs) | (SEPARATED-LIST nt token)
+    ;;      
+    ;; action ::= symbol | EMIT-LIST | (GOTO lhs)
+    ;; EMIT-LIST and (GOTO lhs) are not allowed in user input.
+
+    ;; ****************************************************************
+
+    ;; Auxiliaries for dealing with syntax of grammars
+
+    ;; need to define sllgen:grammar-check-syntax
+
+    (define sllgen:check
+      (lambda (test format . args)
+	(lambda (obj)
+	  (or (test obj)
+	      (apply error
+		     `(parser-generation ,format . ,args))))))
+
+    (define sllgen:grammar-check-syntax
+      (lambda (grammar)
+	((sllgen:list-of sllgen:production-check-syntax)
+	 grammar)))
+
+    (define sllgen:production-check-syntax
+      (lambda (production)
+	((sllgen:tuple-of
+	  (sllgen:check symbol? "lhs of production not a symbol: ~s"
+			production)
+	  (sllgen:rhs-check-syntax production)
+	  (sllgen:check symbol?
+			"action of production not a symbol: ~s"
+			production))
+	 production)))
+
+    (define sllgen:rhs-check-syntax
+      (lambda (production)
+	(sllgen:list-of 
+	 (sllgen:rhs-item-check-syntax production))))
+
+    (define sllgen:rhs-item-check-syntax
+      (lambda (production)
+	(lambda (rhs-item)
+	  ((sllgen:check
+	    (sllgen:either
+	     string?
+	     symbol?
+	     (sllgen:pair-of
+	      (lambda (v) (eqv? v 'arbno))
+	      (sllgen:rhs-check-syntax production))
+	     sllgen:really-separated-list?
+	     )
+	    "illegal rhs item ~s in production ~s"
+	    rhs-item production)
+	   rhs-item))))
+
+    (define sllgen:really-separated-list?
+      (lambda (rhs-item)
+	(and (pair? rhs-item)
+	     (eq? (car rhs-item) 'separated-list)
+	     (> (length rhs-item) 2)
+	     (sllgen:rhs-check-syntax (cdr rhs-item))
+	     (let
+					; ((last-item (car (last-pair rhs-item))))
+		 ((last-item (sllgen:last rhs-item)))
+	       (or (symbol? last-item) (string? last-item))))))
+
+    (define sllgen:pair-of
+      (lambda (pred1 pred2)
+	(lambda (obj)
+	  (and (pair? obj)
+	       (pred1 (car obj))
+	       (pred2 (cdr obj))))))
+
+    (define sllgen:list-of
+      (lambda (pred)
+	(lambda (obj)
+	  (or (null? obj)
+	      (and (pair? obj)
+		   (pred (car obj))
+		   ((sllgen:list-of pred) (cdr obj)))))))
+
+    (define sllgen:tuple-of
+      (lambda preds
+	(lambda (obj)
+	  (let loop ((preds preds) (obj obj))
+	    (if (null? preds)
+		(null? obj)
+		(and (pair? obj)
+		     ((car preds) (car obj))
+		     (loop (cdr preds) (cdr obj))))))))
+
+    (define sllgen:either
+      (lambda preds
+	(lambda (obj)
+	  (let loop ((preds preds))
+	    (cond
+	     ((null? preds) #f)
+	     (((car preds) obj) #t)
+	     (else (loop (cdr preds))))))))
+
+
+    (define sllgen:grammar->productions 
+      (lambda (gram) gram))                 ; nothing else now, but this
+                                        ; might change
+
+    (define sllgen:grammar->start-symbol
+      (lambda (gram)
+	(sllgen:production->lhs
+	 (car 
+	  (sllgen:grammar->productions gram)))))
+
+    (define sllgen:make-production
+      (lambda (lhs rhs action)
+	(list lhs rhs action)))
+
+    (define sllgen:production->lhs car)
+    (define sllgen:production->rhs cadr)
+    (define sllgen:production->action caddr)
+
+    (define sllgen:productions->non-terminals
+      (lambda (productions)
+	(map sllgen:production->lhs productions)))
+
+    (define sllgen:arbno?
+      (lambda (rhs-item)
+	(and (pair? rhs-item)
+	     (eq? (car rhs-item) 'arbno))))
+
+    (define sllgen:arbno->rhs cdr)
+
+    (define sllgen:separated-list?
+      (lambda (rhs-item)
+	(and (pair? rhs-item)
+	     (eq? (car rhs-item) 'separated-list)
+	     (> (length rhs-item) 2))))
+
+    ;; (separated-list rhs-item ... separator)
+
+    (define sllgen:separated-list->nonterm cadr)
+
+    (define sllgen:separated-list->separator 
+      (lambda (item)
+	(let loop ((items (cdr item)))
+	  (cond
+	   ((null? (cdr items)) (car items))
+	   (else (loop (cdr items)))))))
+
+    (define sllgen:separated-list->rhs
+      (lambda (item)
+	(let loop ((items (cdr item)))
+	  (cond
+	   ((null? (cdr items)) '())
+	   (else (cons (car items) (loop (cdr items))))))))
+    
+    (define sllgen:goto-action
+      (lambda (lhs) (list 'goto lhs)))
+
+    (define sllgen:emit-list-action
+      (lambda () '(emit-list)))
+
+    (define sllgen:grammar->string-literals ; apply this after arbnos have
+                                        ; been eliminated.
+      (lambda (grammar)
+	(apply append
+	       (map 
+		(lambda (production)
+		  (sllgen:rhs->string-literals
+		   (sllgen:production->rhs production)))
+		grammar))))
+
+    (define sllgen:rhs->string-literals
+      (lambda (rhs)
+	(let loop ((rhs rhs))
+	  (cond
+	   ((null? rhs) '())
+	   ((string? (car rhs)) (cons (car rhs) (loop (cdr rhs))))
+	   ((pair? (car rhs)) (append (loop (cdar rhs)) (loop (cdr rhs))))
+	   (else (loop (cdr rhs)))))))
+
+    (define sllgen:grammar->string-literal-scanner-spec
+      (lambda (grammar)
+	(let ((class (sllgen:gensym 'literal-string)))
+	  (map
+	   (lambda (string) (list class (list string) 'make-string))
+	   (sllgen:grammar->string-literals grammar)))))
+
+    ;; ****************************************************************
+
+    ;; updatable associative tables
+
+    ;; table ::= ((symbol . list) ...)
+
+
+    (define sllgen:make-initial-table       ; makes table with all entries
+                                        ; initialized to empty
+      (lambda (symbols)
+	(map list symbols)))
+
+    (define sllgen:add-value-to-table!
+      (lambda (table key value)
+	(let ((pair (assq key table)))
+	  (if (member value (cdr pair))
+	      #f
+	      (begin
+		(set-cdr! pair (cons value (cdr pair)))
+		#t)))))
+
+    (define sllgen:table-lookup
+      (lambda (table key)
+	(cdr (assq key table))))
+
+    (define sllgen:uniq
+      (lambda (l)
+	(if (null? l) '()
+	    (let ((z (sllgen:uniq (cdr l))))
+	      (if (member (car l) z)
+		  z
+		  (cons (car l) z))))))
+
+    (define sllgen:union
+      (lambda (s1 s2)                       ; s1 and s2 already unique
+	(if (null? s1) s2
+	    (if (member (car s1) s2)
+		(sllgen:union (cdr s1) s2)
+		(cons (car s1) (sllgen:union (cdr s1) s2))))))
+    
+    ;; this is only called with '(), so the eqv? is ok.
+    (define sllgen:rember
+      (lambda (a s)
+	(cond 
+	 ((null? s) s)
+	 ((eqv? a (car s)) (cdr s))
+	 (else (cons (car s) (sllgen:rember a (cdr s)))))))
+
+
+    (define sllgen:gensym
+      (let ((n 0))
+	(lambda (s)
+	  (set! n (+ n 1))
+	  (let ((s (if (string? s) s (symbol->string s))))
+	    (string->symbol
+	     (string-append s (number->string n)))))))
+
+
+    ;; ****************************************************************
+
+    ;; a table for keeping the arity of the generated nonterminals for
+    ;; arbno. 
+
+    (define sllgen:arbno-table '())
+
+    (define sllgen:arbno-initialize-table!
+      (lambda ()
+	(set! sllgen:arbno-table '())))
+
+    (define sllgen:arbno-add-entry!
+      (lambda (sym val)
+	(set! sllgen:arbno-table
+	      (cons (cons sym val) sllgen:arbno-table))))
+
+    (define sllgen:arbno-assv
+      (lambda (ref)
+	(assv ref sllgen:arbno-table)))
+
+    (define sllgen:non-terminal-table '())
+
+    (define sllgen:initialize-non-terminal-table!
+      (lambda (productions)
+	(set! sllgen:non-terminal-table '())
+	(for-each
+	 (lambda (prod)
+	   (sllgen:non-terminal-add!
+	    (sllgen:production->lhs prod)))
+	 productions)))
+
+    (define sllgen:non-terminal-add!
+      (lambda (sym)
+	(if (not (memv sym sllgen:non-terminal-table))
+	    (set! sllgen:non-terminal-table
+		  (cons sym sllgen:non-terminal-table)))))
+
+    (define sllgen:non-terminal?
+      (lambda (sym)
+	(memv sym sllgen:non-terminal-table)))
+
+    ;; ****************************************************************
+
+    ;; eliminate-arbno.s
+
+    ;; replaces (ARBNO lhs) items with new productions
+
+    (define sllgen:eliminate-arbnos-from-rhs
+      (lambda (rhs k)
+	;; returns to its continuation the new rhs and the list of
+	;; new productions
+	(cond
+	 ((null? rhs)
+	  (k rhs '()))
+	 ((sllgen:arbno? (car rhs))
+	  (let ((new-nonterm (sllgen:gensym
+			      (if (symbol? (cadar rhs)) (cadar rhs) 'arbno)))
+		(local-rhs (sllgen:arbno->rhs (car rhs))))
+	    (sllgen:arbno-add-entry!
+	     new-nonterm
+	     (sllgen:rhs-data-length local-rhs))
+	    (sllgen:eliminate-arbnos-from-rhs
+	     (cdr rhs)
+	     (lambda (new-rhs new-prods)
+	       (sllgen:eliminate-arbnos-from-rhs
+		local-rhs
+		(lambda (new-local-rhs new-local-prods)
+		  (k
+		   (cons new-nonterm new-rhs)  
+		   (cons
+		    (sllgen:make-production
+		     new-nonterm '() (sllgen:emit-list-action))
+		    (cons
+		     (sllgen:make-production
+		      new-nonterm
+		      new-local-rhs
+		      (sllgen:goto-action new-nonterm))
+		     (append new-local-prods new-prods))))))))))
+	 ((sllgen:separated-list? (car rhs))
+	  ;; A -> ((sep-list B1 B2 ... C) ...)
+	  (let* ((local-rhs (sllgen:separated-list->rhs (car rhs)))
+		 (separator (sllgen:separated-list->separator (car rhs)))
+		 (seed (if (symbol? local-rhs) local-rhs 'seplist))
+		 (new-nonterm1 (sllgen:gensym seed))
+		 (new-nonterm2 (sllgen:gensym seed))
+		 (new-nonterm3 (sllgen:gensym seed)))
+	    (sllgen:arbno-add-entry!
+	     new-nonterm1
+	     (sllgen:rhs-data-length local-rhs))
+	    (sllgen:eliminate-arbnos-from-rhs
+	     (cdr rhs)
+	     (lambda (new-rhs new-prods)
+	       (sllgen:eliminate-arbnos-from-rhs
+		local-rhs
+		(lambda (new-local-rhs new-local-prods)
+		  (k
+		   (cons new-nonterm1 new-rhs) ; A -> (g1 ...)
+		   (append
+		    (list
+		     (sllgen:make-production  ; g1  -> e
+		      new-nonterm1 '()
+		      (sllgen:emit-list-action)) 
+		     (sllgen:make-production  ; g1 -> B1 B2 (goto g3)
+		      new-nonterm1 
+		      new-local-rhs
+		      (sllgen:goto-action new-nonterm3))
+		     (sllgen:make-production ; g2 -> B1 B2 (goto g3).
+		      new-nonterm2 
+		      new-local-rhs
+		      (sllgen:goto-action new-nonterm3)) 
+		     (sllgen:make-production     ; g3 -> e (emit-list)
+		      new-nonterm3
+		      '() (sllgen:emit-list-action)) 
+		     (sllgen:make-production ; g3 -> C (goto g2)
+		      new-nonterm3
+		      (list separator)
+		      (sllgen:goto-action new-nonterm2)))
+		    new-local-prods
+		    new-prods))))))))
+	 (else
+	  (sllgen:eliminate-arbnos-from-rhs (cdr rhs)
+					    (lambda (new-rhs new-prods)
+					      (k (cons (car rhs) new-rhs)
+						 new-prods)))))))
+
+    (define sllgen:eliminate-arbnos-from-production
+      (lambda (production)
+	;; returns list of productions
+	(sllgen:eliminate-arbnos-from-rhs
+	 (sllgen:production->rhs production)
+	 (lambda (new-rhs new-prods)
+	   (let ((new-production
+		  (sllgen:make-production 
+		   (sllgen:production->lhs production)
+		   new-rhs
+		   (sllgen:production->action production))))
+	     (cons new-production
+		   (sllgen:eliminate-arbnos-from-productions new-prods)))))))
+    
+    (define sllgen:eliminate-arbnos-from-productions
+      (lambda (productions)
+	(let loop ((productions productions))
+	  (if (null? productions)
+	      '()
+	      (append
+	       (sllgen:eliminate-arbnos-from-production (car productions))
+	       (loop (cdr productions)))))))
+    
+    (define sllgen:rhs-data-length
+      (lambda (rhs)
+	(let ((report-error
+	       (lambda (rhs-item msg)
+		 (error 'parser-generation
+			"illegal item ~s (~a) in rhs ~s"
+			rhs-item msg rhs))))
+	  (letrec
+	      ((loop
+		(lambda (rhs)
+		  ;; (eopl:printf "~s~%" rhs)
+		  (if (null? rhs) 0
+		      (let ((rhs-item (car rhs))
+			    (rest (cdr rhs)))
+			(cond
+			 ((and
+			   (symbol? rhs-item)
+			   (sllgen:non-terminal? rhs-item))
+					;                    (eopl:printf "found nonterminal~%")
+			  (+ 1 (loop rest)))
+			 ((symbol? rhs-item)
+					;                    (eopl:printf "found terminal~%")
+			  (+ 1 (loop rest)))
+			 ((sllgen:arbno? rhs-item)
+					;                    (eopl:printf "found arbno~%")
+			  (+
+			   (loop (sllgen:arbno->rhs rhs-item))
+			   (loop rest)))
+			 ((sllgen:separated-list? rhs-item)
+					;                     (eopl:printf "found seplist~%")
+			  (+
+			   (loop (sllgen:separated-list->rhs rhs-item))
+			   (loop rest)))
+			 ((string? rhs-item)
+					;                     (eopl:printf "found string~%")
+			  (loop rest))
+			 (else
+					;                      (eopl:printf "found error~%")
+			  (report-error rhs-item "unrecognized item"))))))))
+	    (loop rhs)))))
+
+    ;; ****************************************************************
+
+    ;; first-and-follow.s
+
+    ;; calculate first and follow sets
+
+    ;; base conditions:
+
+    ;; A -> a ...   => a in first(A)
+    ;; A -> ()      => nil in first(A)
+
+    ;; closure conditions:
+
+    ;; A -> (B1 ... Bk c ...) & nil in first(B1)...first(Bk) => c in first(A)
+    ;; A -> (B1 ... Bk C ...) & nil in first(B1)...first(Bk) & c in first(C) =>
+    ;;                                                         c in first(A) 
+    ;; A -> (B1 ... Bk) & nil in first(B1)...first(Bk) => nil in first(A)
+
+    (define sllgen:first-table
+      (lambda (productions)
+	(let* ((non-terminals
+		(sllgen:uniq (map sllgen:production->lhs productions)))
+	       (table (sllgen:make-initial-table non-terminals)))
+	  (letrec
+	      ((loop 
+		;; initialize with the base conditions and return the
+		;; productions to be considered for the closure
+		(lambda (productions)
+		  (cond
+		   ((null? productions) '())
+		   ((null? (sllgen:production->rhs (car productions)))
+		    ;; A -> ()      => nil in first(A)
+		    (sllgen:add-value-to-table! table 
+						(sllgen:production->lhs (car productions))
+						'())
+		    (loop (cdr productions)))
+		   ((member (car
+			     (sllgen:production->rhs
+			      (car productions)))
+			    non-terminals)
+		    ;; this one is for the closure
+		    (cons (car productions)
+			  (loop (cdr productions))))
+		   (else
+		    ;; this one must start with a terminal symbol
+		    (sllgen:add-value-to-table! table
+						(sllgen:production->lhs (car productions))
+						(car
+						 (sllgen:production->rhs
+						  (car productions)))))))))
+	    (let ((closure-productions (loop productions)))
+	      (sllgen:iterate-over-first-table table productions
+					       non-terminals)))))) 
+
+
+    (define sllgen:iterate-over-first-table
+      (lambda (table productions non-terminals)
+	(let* ((changed? '**uninitialized**)
+	       (add-value!
+		(lambda (key value)
+		  (let ((not-there?
+			 (sllgen:add-value-to-table! table key value)))
+		    (set! changed? (or changed? not-there?)))))
+	       (first (lambda (key) (sllgen:table-lookup table key))))
+	  (letrec
+	      ((rhs-loop
+		(lambda (lhs rhs)
+		  ;; assume everything in the rhs up to this point has () in
+		  ;; its first set
+		  (cond
+		   ((null? rhs)
+		    ;; A -> (B1 ... Bk) & nil in first(B1)...first(Bk) =>
+		    ;; nil in first(A) 
+		    (add-value! lhs '()))
+		   ;; A -> (B1 ... Bk C ...) & nil in first(B1)...first(Bk)
+		   ((member (car rhs) non-terminals)
+		    (for-each 
+		     (lambda (sym)
+		       (if (not (null? sym))
+			   ;; & c in first(C) => c in first(A) 
+			   (add-value! lhs sym)
+			   ;; e in first(C) -- continue to search down rhs
+			   (rhs-loop lhs (cdr rhs))))
+		     (first (car rhs))))
+		   (else
+		    ;; A -> (B1 ... Bk c ...) & nil in
+		    ;; first(B1)...first(Bk) => c in first(A) 
+		    (add-value! lhs (car rhs))))))
+	       (main-loop
+		(lambda ()
+		  (set! changed? #f)
+		  (for-each
+		   (lambda (production)
+		     (rhs-loop 
+		      (sllgen:production->lhs production)
+		      (sllgen:production->rhs production)))
+		   productions)
+		  (if changed?
+		      (main-loop)
+		      table))))
+	    (main-loop)))))
+
+    (define sllgen:first-of-list
+      (lambda (first-table non-terminals items)
+	(let ((get-nonterminal
+	       (lambda (item) 
+		 (cond
+		  ((member item non-terminals) item)
+		  ((symbol? item) #f)
+		  ((string? item) #f)
+		  ((eq? (car item) 'goto) (cadr item))
+		  (else #f)))))
+	  (letrec
+	      ((loop (lambda (items)
+		       (cond
+			((null? items) '(()))                 ; ans = {e}
+			((get-nonterminal (car items)) =>
+			 (lambda (nonterminal)
+			   (let ((these
+				  (sllgen:table-lookup first-table nonterminal)))
+			     (if (member '() these)
+				 (let ((others (loop (cdr items))))
+				   (let inner ((these these))
+				     (cond
+				      ((null? these) others)
+				      ((null? (car these))
+				       (inner (cdr these)))
+				      ((member (car these) others)
+				       (inner (cdr these)))
+				      (else
+				       (cons (car these)
+					     (inner (cdr these)))))))
+				 these))))
+			(else (list (car items)))))))
+	    (loop items)))))
+
+    (define sllgen:follow-table
+      (lambda (start-symbol productions first-table)
+	(let* ((non-terminals
+		(sllgen:uniq (map sllgen:production->lhs productions)))
+	       (table (sllgen:make-initial-table non-terminals))
+	       (changed? '**uninitialized**)
+	       (sllgen:add-value!
+		(lambda (key value)
+		  (let ((not-there?
+			 (sllgen:add-value-to-table! table key value)))
+		    (set! changed? (or changed? not-there?)))))
+	       ;; closure-rules ::= ((a b) ...) means follow(a) \subset
+	       ;; follow(b)
+	       (closure-rules '())
+	       (get-nonterminal
+		(lambda (item) 
+		  (cond
+		   ((member item non-terminals) item)
+		   (else #f)))))
+	  (sllgen:add-value! start-symbol 'end-marker)
+	  (letrec
+	      ((init-loop
+		;; loops through productions once, adding starting values
+		;; to follow-table and other productions to closure-rules
+		(lambda (productions)
+		  (if (null? productions)
+		      #t
+		      (let* ((production (car productions))
+			     (lhs (sllgen:production->lhs production))
+			     (rhs (sllgen:production->rhs production))
+			     (action (sllgen:production->action production)))
+			(rhs-loop
+			 lhs
+			 (append rhs ;; add back the goto as a nonterminal 
+				 (if (and (pair? action) (eq? (car action) 'goto))
+				     (list (cadr action))
+				     '())))
+			(init-loop (cdr productions))))))
+	       (rhs-loop
+		(lambda (lhs rhs)
+		  ;; (eopl:printf "rhs-loop lhs=~s rhs=~s~%" lhs rhs)
+		  (cond
+		   ((null? rhs) #t)
+		   ((get-nonterminal (car rhs)) =>
+		    (lambda (nonterminal)
+		      ;; we've found a nonterminal.  What's it followed by?
+		      (let* ((rest (cdr rhs))
+			     (first-of-rest
+			      (sllgen:first-of-list
+			       first-table non-terminals rest)))
+			(for-each 
+			 (lambda (sym)
+			   (if (not (null? sym))
+			       ;; A -> (... B C ...) => first(C...) \subset follow(B)
+			       (sllgen:add-value! nonterminal sym)
+			       ;; A -> (... B C ...) & e \in first(C ...) =>
+			       ;; follow(A) \subset follow (B)
+			       (begin
+				 (set! closure-rules
+				       (cons (list lhs nonterminal)
+					     closure-rules))
+				 ;; (eopl:printf "~s~%" (list lhs nonterminal))
+				 )))
+			 first-of-rest))
+		      ;; now keep looking
+		      (rhs-loop lhs (cdr rhs))))
+		   (else
+		    ;; this one's not a non-terminal.  Keep looking.
+		    (rhs-loop lhs (cdr rhs))))))
+	       (closure-loop
+		(lambda ()
+		  (set! changed? #f)
+		  (for-each
+		   (lambda (rule)
+		     (let ((a (car rule))
+			   (b (cadr rule)))
+		       ;; follow(a) \subset follow(b)
+		       (for-each
+			(lambda (sym)
+			  (sllgen:add-value! b sym))
+			(sllgen:table-lookup table a))))
+		   closure-rules)
+		  (if changed?
+		      (closure-loop)
+		      table))))
+	    (init-loop productions)
+					;       (sllgen:pretty-print closure-rules)
+	    (closure-loop)))))
+    
+
+    ;; ****************************************************************
+
+    ;; gen-table.s
+
+    ;; gen-table.s  take list of productions, first and follow tables,
+    ;; and generate parsing table
+
+    ;; table ::= ((non-terminal (list-of-items action ...)....) ...)
+
+    ;; the list of items is the first(rhs) for each production (or
+    ;; follow(lhs) if the production is empty.  We should probably check
+    ;; to see that these are non-intersecting, but we probably won't on
+    ;; this pass.
+
+    ;; First thing to do: collect all the productions for a given
+    ;; non-terminal.  This gives data structure of the form
+
+    ;; ((lhs production ...) ...)
+
+    ;; We'll do this using updatable tables.
+
+    (define sllgen:group-productions
+      (lambda (productions)
+	(let* ((non-terminals
+		(sllgen:uniq (map sllgen:production->lhs productions)))
+	       (table (sllgen:make-initial-table non-terminals)))
+	  (for-each
+	   (lambda (production)
+	     (let 
+		 ((lhs (sllgen:production->lhs production)))
+	       (sllgen:add-value-to-table! table lhs production)))
+	   productions)
+	  table)))
+
+    ;; this one uses the list structure of tables.  [Watch out]
+
+    (define sllgen:productions->parsing-table
+      (lambda (productions first-table follow-table)
+	(let ((non-terminals
+	       (sllgen:uniq (map sllgen:production->lhs productions)))
+	      (table (sllgen:group-productions productions)))
+	  (map 
+	   (lambda (table-entry)
+	     (sllgen:make-parse-table-non-terminal-entry
+	      (car table-entry)
+	      (map
+	       (lambda (production)
+		 (sllgen:make-parse-table-production-entry
+		  production non-terminals first-table follow-table))
+	       (cdr table-entry))))
+	   table))))
+
+    (define sllgen:make-parse-table-non-terminal-entry
+      (lambda (lhs entries)
+	(cons lhs entries)))
+
+    (define sllgen:make-parse-table-production-entry
+      (lambda (production non-terminals first-table follow-table)
+	(let* ((rhs (sllgen:production->rhs production))
+	       (first-of-rhs (sllgen:first-of-list
+			      first-table non-terminals
+			      (sllgen:production->rhs production)))
+	       (steering-items
+		(if (member '() first-of-rhs)
+		    (sllgen:union
+		     (sllgen:table-lookup
+		      follow-table
+		      (sllgen:production->lhs production))
+		     (sllgen:rember '() first-of-rhs))
+		    first-of-rhs)))
+	  (cons steering-items
+		(sllgen:make-parse-table-rhs-entry
+		 non-terminals
+		 (sllgen:production->rhs production)
+		 (sllgen:production->action production))))))
+
+    (define sllgen:make-parse-table-rhs-entry
+      (lambda (non-terminals rhs action)
+	(let loop ((rhs rhs))
+	  (cond
+	   ((null? rhs) 
+	    ;; at end -- emit reduce action or emit-list action
+	    (if (symbol? action)
+		;; symbols become "reduce",
+		;; (emit-list) and (goto nt) stay the same
+		(list (list 'reduce action))
+		(list action)))
+	   ((sllgen:arbno-assv (car rhs)) =>
+	    (lambda (pair)                 ; (cdr pair) is the count for
+                                        ; the arbno 
+	      (cons
+	       (list 'arbno (car rhs) (cdr pair))
+	       (loop (cdr rhs)))))
+	   ((member (car rhs) non-terminals)
+	    (cons (list 'non-term (car rhs))
+		  (loop (cdr rhs))))
+	   ((symbol? (car rhs))
+	    (cons (list 'term (car rhs))
+		  (loop (cdr rhs))))
+	   ((string? (car rhs))
+	    (cons (list 'string (car rhs))
+		  (loop (cdr rhs))))
+	   (else
+	    (error 'parser-generation
+		   "unknown rhs entry ~s"
+		   (car rhs)))))))
+
+    ;; ****************************************************************
+    
+    ;; check-table.s
+
+    ;; take a parse table and check for conflicts
+
+    ;; table ::= ((non-terminal (list-of-items action ...)....) ...)
+
+    (define sllgen:check-table
+      (lambda (table)
+	(for-each sllgen:check-productions table)))
+
+    (define sllgen:check-productions
+      (lambda (non-terminal-entry)
+	(let ((non-terminal (car non-terminal-entry))
+	      (productions (cdr non-terminal-entry)))
+	  ;; see if the list-of-items are pairwise disjoint
+	  (let loop ((productions productions))
+	    (if (null? productions)
+		#t                            ; no more to check
+		(let ((this-production (car productions))
+		      (other-productions (cdr productions)))
+		  ;; check this production
+		  (for-each
+		   (lambda (class)
+		     (let inner ((others other-productions))
+		       (cond
+			((null? others) #t)
+			;; memq changed to member Tue Nov 16 14:26:32
+			;; 1999, since class could be a string.
+			((member class (car (car others)))
+			 (error 'parser-generation
+				"grammar not LL(1): shift conflict detected for class ~s in nonterminal ~s:~%~s~%~s~%"
+				class non-terminal this-production (car others)))
+			(else (inner (cdr others))))))
+		   (car this-production))
+		  ;; and check the others
+		  (loop other-productions)))))))
+    
+  
+  ;; ****************************************************************        
+
+  ;; scan.scm
+
+  ;; Scanner based on regexps and longest-match property
+
+  ;; new version using proper lookahead in sllgen:scanner-inner-loop
+  ;; Tue Dec 01 11:42:53 1998
+
+  ;; External syntax of scanner:
+
+  ;; scanner ::= (init-state ...)
+  ;; init-state ::= (classname (regexp ...) action-opcode)
+  ;; regexp = etester | (or regexp ...) | (arbno regexp) 
+  ;;        | (concat regexp ...)
+  ;; etester ::= string | LETTER | DIGIT | WHITESPACE | ANY | (NOT char)
+
+  ;; top level stream transducer:
+
+  (define sllgen:make-scanner-maker
+    (lambda (init-states)
+      (with-syntax ((start-states (sllgen:parse-scanner-spec init-states)))
+	(syntax
+	 (lambda (input-stream)
+	   (sllgen:scanner-outer-loop 'start-states input-stream))))))
+
+  ;; Conversion of external to internal rep
+
+  (define sllgen:parse-scanner-spec
+    (lambda (init-states)
+      (map sllgen:parse-init-state init-states)))
+
+  (define sllgen:parse-init-state
+    (lambda (init-state)
+      (sllgen:check-syntax-init-state init-state)
+      (let ((classname (car init-state))
+	    (regexps (cadr init-state))
+	    (opcode (caddr init-state)))
+	(sllgen:make-local-state
+	 (map sllgen:parse-regexp regexps)
+	 (cons opcode classname)))))
+
+  (define sllgen:check-syntax-init-state
+    (lambda (v)
+      (or
+       (and
+        (list? v) 
+        (= (length v) 3) 
+        (symbol? (car v))
+        (list? (cadr v))
+        (symbol? (caddr v))
+        (member (caddr v) sllgen:action-preference-list))
+       (error 'scanner-generation "bad scanner item ~s" v))))
+
+  (define sllgen:parse-regexp
+    (lambda (regexp)
+      (cond
+       ((char? regexp) (sllgen:make-tester-regexp regexp))
+       ((string? regexp) (sllgen:string->regexp regexp))
+       ((symbol? regexp) (sllgen:symbol->regexp regexp))
+       ((and (pair? regexp) (symbol? (car regexp)))
+	(case (car regexp)
+	  ((or)
+	   (sllgen:make-or-regexp (map sllgen:parse-regexp (cdr regexp))))
+	  ((concat)
+	   (sllgen:make-concat-regexp (map sllgen:parse-regexp (cdr regexp))))
+	  ((arbno)
+	   (and
+            (or (pair? (cdr regexp))
+		(error 'scanner-generation "bad regexp ~s" regexp))
+            (sllgen:make-arbno-regexp (sllgen:parse-regexp (cadr regexp)))))
+	  ((not) (and
+                  (or (and (pair? (cdr regexp))
+			   (char? (cadr regexp)))
+		      (error 'sllgen:parse-regexp "bad regexp ~s" regexp))
+                  (sllgen:make-tester-regexp regexp)))
+	  (else (error 'scanner-generation "bad regexp ~s" regexp))))
+       (else (error 'scanner-generation "bad regexp ~s" regexp)))))
+  
+  (define sllgen:string->regexp
+    (lambda (string)
+      (sllgen:make-concat-regexp
+       (map sllgen:make-tester-regexp
+	    (map sllgen:make-char-tester (string->list string))))))
+
+  (define sllgen:symbol->regexp
+    (lambda (sym)
+      (if (member sym sllgen:tester-symbol-list)
+	  (sllgen:make-tester-regexp sym)
+	  (error 'scanner-generation "unknown tester ~s" sym))))
+
+  ;; localstate = regexp* x action
+  
+  (define sllgen:make-local-state 
+    (lambda (regexps action)
+      (append regexps (list action))))
+
+  ;; regexps 
+  ;; regexp = tester | (or regexp ...) | (arbno regexp) 
+  ;;        | (concat regexp ...)
+
+
+					; (define-datatype regexp
+					;   (tester-regexp sllgen:tester?)
+					;   (or-regexp (list-of regexp?))
+					;   (arbno-regexp regexp?)
+					;   (concat-regexp (list-of regexp?)))
+
+  ;; (sllgen:select-variant obj selector1 receiver1 ... [err-thunk])
+
+  (define sllgen:select-variant
+    (lambda (obj . alts)
+      (let loop ((alts alts))
+	(cond
+	 ((null? alts)
+	  (error 'sllgen:select-variant
+		 "internal error: nothing matched ~a" obj))
+	 ((null? (cdr alts)) ((car alts)))
+	 (((car alts) obj) => (lambda (f) (f (cadr alts))))
+	 (else (loop (cddr alts)))))))
+
+
+  (define sllgen:unparse-regexp                  ; deals with regexps or actions
+    (lambda (regexp)
+      (if (sllgen:action? regexp)
+	  regexp
+	  (sllgen:select-variant regexp
+				 sllgen:tester-regexp?
+				 (lambda (tester) tester)
+				 sllgen:arbno-regexp?
+				 (lambda (regexp)
+				   (list 'arbno (sllgen:unparse-regexp regexp)))
+				 sllgen:concat-regexp?
+				 (lambda (regexps)
+				   (cons 'concat (map sllgen:unparse-regexp regexps)))
+				 sllgen:or-regexp?
+				 (lambda (regexps)
+				   (cons 'or (map sllgen:unparse-regexp regexps)))))))
+
+  ;; testers
+  ;; tester ::= char | LETTER | DIGIT | ANY | WHITESPACE | (NOT char)
+
+  ;; ****************************************************************        
+
+  ;; go through a grammar and generate the appropriate define-datatypes.
+
+  ;; define-datatype syntax is:
+  ;;(define-datatype Type-name Predicate-name
+  ;;  (Variant-name (Field-name Predicate-exp) ...) ...)
+
+
+  (define sllgen:build-define-datatype-definitions
+    (lambda (scanner-spec grammar)
+      (let* ((scanner-datatypes-alist
+	      (sllgen:make-scanner-datatypes-alist scanner-spec))
+	     (non-terminals
+	      (sllgen:uniq (map sllgen:production->lhs
+				(sllgen:grammar->productions grammar))))
+	     (datatype-table (sllgen:make-initial-table non-terminals)))
+	;; for each production, add an entry to the table.  Each entry is
+	;; (prod-name . datatype-list)
+	(for-each
+	 (lambda (production)
+	   (sllgen:add-value-to-table! datatype-table
+				       (sllgen:production->lhs production)
+				       (cons
+					(sllgen:production->action production)
+					(sllgen:make-rhs-datatype-list 
+					 (sllgen:production->rhs production)
+					 non-terminals
+					 scanner-datatypes-alist))))
+	 (sllgen:grammar->productions grammar))
+	;; now generate the list of datatypes for each table entry
+	(map
+	 (lambda (non-terminal)
+	   (sllgen:make-datatype-definition non-terminal
+					    (sllgen:table-lookup datatype-table non-terminal)))
+	 non-terminals))))
+
+
+  (define sllgen:make-scanner-datatypes-alist
+    (lambda (init-states)
+      (let
+	  ((opcode-type-alist
+	    '((make-symbol . symbol?)
+	      (symbol . symbol?)
+	      (make-string . string?)
+	      (string . string?)
+	      (make-number . number?)
+	      (number . number?))))
+	(let loop ((init-states init-states))
+	  (if (null? init-states) '()
+	      (let ((init-state  (car init-states))
+		    (init-states (cdr init-states)))
+		(let ((class (car init-state))
+		      (type-pair (assq (sllgen:last init-state) opcode-type-alist)))
+		  (if (not type-pair)
+		      (loop init-states)
+		      (cons (cons class (cdr type-pair)) 
+			    (loop init-states))))))))))
+
+  (define sllgen:last
+    (lambda (x)
+      (and
+       (or (pair? x)
+	   (error 'sllgen:last "can't take last of non-pair ~s" x))
+       (if (null? (cdr x))
+	   (car x)
+	   (sllgen:last (cdr x))))))
+
+  ;; rhs ::= (rhs-item ...)
+  ;;
+  ;; rhs-item ::= string | symbol | (ARBNO . rhs) | (SEPARATED-LIST rhs
+  ;;                                                         token)  
+
+  (define sllgen:make-rhs-datatype-list
+    (lambda (rhs non-terminals scanner-datatypes-alist)
+      (let ((report-error
+	     (lambda (rhs-item msg)
+	       (error 'defining-datatypes
+		      "illegal item ~s (~a) in rhs ~s"
+		      rhs-item msg rhs))))
+	(let loop ((rhs rhs))
+	  (if (null? rhs) '()
+	      (let ((rhs-item (car rhs))
+		    (rest (cdr rhs)))
+		(cond
+		 ((and (symbol? rhs-item) (member rhs-item non-terminals))
+		  ;; this is a non-terminal
+		  (cons (sllgen:non-terminal->tester-name rhs-item)
+			(loop rest)))
+		 ((symbol? rhs-item)
+		  ;; this must be a terminal symbol
+		  (let ((type (assq rhs-item scanner-datatypes-alist)))
+		    (if type
+			(cons (cdr type) (loop rest))
+			(report-error rhs-item "unknown symbol"))))
+		 ((sllgen:arbno? rhs-item)
+		  (append
+		   (map 
+		    (lambda (x) (list 'list-of x))
+		    (loop (sllgen:arbno->rhs rhs-item)))
+		   (loop rest)))
+		 ((sllgen:separated-list? rhs-item)
+		  (append
+		   (map 
+		    (lambda (x) (list 'list-of x))
+		    (loop (sllgen:separated-list->rhs rhs-item)))
+		   (loop rest)))
+		 ((string? rhs-item)
+		  (loop rest))
+		 (else (report-error rhs-item "unrecognized item")))))))))
+
+  (define sllgen:non-terminal->tester-name
+    (lambda (x)
+      (string->symbol (string-append (symbol->string x) "?"))))
+  
+  ;; variants are now the same as constructors
+  (define sllgen:variant->constructor-name
+    (lambda (x) x))
+
+
+  (define sllgen:make-datatype-definition
+    (lambda (non-terminal entries)
+      (let ((tester-name
+	     (sllgen:non-terminal->tester-name non-terminal))
+	    (entries 
+	     ;; reverse gets the entries in the same order as the productions
+	     (map sllgen:make-variant (reverse entries))))
+	`(define-datatype ,non-terminal ,tester-name . ,entries))))
+
+  (define sllgen:make-variant
+    (lambda (entry)
+      `(,(car entry)
+	. ,(map
+	    (lambda (pred)
+	      (list (sllgen:gensym (car entry)) pred))
+	    (cdr entry)))))
+  )
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (define (make-stream-parser parser scanner)
+    (lambda (char-stream)
+      (let ((stream
+	     (sllgen:stream-add-sentinel-via-thunk
+	      (scanner char-stream)
+	      (lambda ()
+		(sllgen:make-token 'end-marker #f
+				   (sllgen:char-stream->location char-stream))))))
+	(let loop ((stream stream))
+	  (lambda (fn eos)
+	    ((parser stream
+		     (lambda (tree token token-stream)
+		       (sllgen:make-stream 'tag1
+					   tree
+					   (lambda (fn eos)   ; prevent evaluation for now
+					     ((loop 
+					       ;; push the lookahead token back on the
+					       ;; stream iff it's there.
+					       (if (null? token)
+						   token-stream
+						   (sllgen:make-stream 'tag2 token token-stream)))
+					      fn eos)))))
+	     fn eos))))))
+
+  (define (make-string-parser parser scanner)
+    (lambda (string)
+      (let* ((char-stream (sllgen:string->stream string))
+	     (token-stream (scanner char-stream))
+	     (last-line (sllgen:char-stream->location char-stream)))
+	(parser 
+	 (sllgen:stream-add-sentinel-via-thunk
+	  token-stream
+	  (lambda ()
+	    (sllgen:make-token 'end-marker #f
+			       (sllgen:char-stream->location char-stream))))
+	 (lambda (tree token token-stream)
+	   (if (null? token)
+	       (sllgen:stream-get! token-stream
+				   (lambda (tok1 str1)
+				     (set! token tok1)
+				     (set! token-stream str1))
+				   (lambda ()
+				     (error 'sllgen:string-parser
+					    "internal error: shouldn't run off end of stream with sentinels"))))
+	   (if (eq? (sllgen:token->class token) 'end-marker)
+	       tree
+	       (error 'parsing
+		      "at line ~s: symbols left over: ~s ~s etc..."
+		      (sllgen:token->location token)
+		      (sllgen:token->class token)
+		      (sllgen:token->data token))))))))
+  
+
+  (define sllgen:apply-tester
+    (lambda (tester ch)
+      (cond
+       ((char? tester) (char=? tester ch))
+       ((symbol? tester)
+        (case tester
+          ((whitespace) (char-whitespace? ch))
+          ((letter) (char-alphabetic? ch))
+          ((digit) (char-numeric? ch))
+          ((any) #t)                    ; ELSE is not really a tester
+          (else (error 'sllgen:apply-tester
+		       "internal error: unknown tester ~s" tester))))
+       ((eq? (car tester) 'not)
+	(not (char=? (cadr tester) ch)))
+       (else (error 'sllgen:apply-tester
+		    "internal error: unknown tester ~s"
+		    tester)))))
+
+
+  ;; actions
+  ;; action        ::= (action-opcode . classname)
+  ;; action-opcode :: = skip | symbol | number | string
+
+  ;; make-symbol, make-number, and make-string are supported
+  ;; alternates, but are deprecated.
+
+  ;; the classname becomes the the name of token.
+
+  ;; if multiple actions are possible, do the one that appears here
+  ;; first.  make-string is first, so literal strings trump identifiers.
+
+  (define sllgen:find-preferred-action
+    (lambda (action-opcodes)
+      (let loop ((preferences sllgen:action-preference-list))
+	(cond
+	 ((null? preferences)
+	  (error 'scanning "no known actions in ~s"
+		 action-opcodes))
+	 ((member (car preferences) action-opcodes)
+	  (car preferences))
+	 (else (loop (cdr preferences)))))))
+
+  (define sllgen:is-all-skip?
+    (lambda (actions)
+      (let ((opcode  (sllgen:find-preferred-action (map car actions))))
+	(eq? opcode 'skip))))
+
+  (define sllgen:cook-token
+    (lambda (buffer actions loc)
+      (let* ((opcode (sllgen:find-preferred-action (map car actions)))
+	     (classname (cdr (assq opcode actions))))
+	(case opcode
+	  ((skip) (error 'sllgen:cook-token
+			 "internal error: skip should have been handled earlier ~s"
+			 actions))
+	  ((make-symbol symbol) 
+	   (sllgen:make-token classname
+			      (string->symbol (list->string (reverse buffer)))
+			      loc))
+	  ((make-number number)
+	   (sllgen:make-token classname
+			      (string->number (list->string (reverse buffer)))
+			      loc))
+	  ((make-string string)
+	   (sllgen:make-token classname
+			      (list->string (reverse buffer))
+			      loc))
+	  (else
+	   (error 'scanning
+		  "unknown opcode selected from action list ~s"
+		  actions))))))
+  
+					; (define sllgen:cook-token
+					;   (lambda (buffer actions loc)
+					;     (let* ((opcode (sllgen:find-preferred-action (map car actions)))
+					;            ;; (classname (cdr (assq opcode actions)))
+					;            )
+					;       (case opcode
+					;         ((skip) (sllgen:error 'sllgen:cook-token
+					;                   "~%Internal error: skip should have been handled earlier ~s"
+					;                   actions))
+					;         ((make-symbol identifier) 
+					;          (sllgen:make-token 'identifier
+					;            (string->symbol (list->string (reverse buffer)))
+					;            loc))
+					;         ((make-number number)
+					;          (sllgen:make-token 'number
+					;            (string->number (list->string (reverse buffer)))
+					;            loc))
+					;         ((make-string string)
+					;          (sllgen:make-token 'string
+					;            (list->string (reverse buffer))
+					;            loc))
+					;         (else
+					;           (sllgen:error 'scanning
+					;             "~%Unknown opcode selected from action list ~s"
+					;             actions))))))
+
+
+  ;; k = (actions * newstates * char * stream) -> val
+  (define sllgen:scanner-inner-loop
+    (lambda (local-states stream k)            
+      (let ((actions '())
+	    (newstates '())
+	    (char '())
+	    (eos-found? #f))              ; do we need to return this too?
+					;(eopl:printf "initializing sllgen:scanner-inner-loop~%")
+	(let loop ((local-states local-states)) ; local-states
+					;         '(begin
+					;            (eopl:printf "sllgen:scanner-inner-loop char = ~s actions=~s local-states =~%"
+					;              char actions)
+					;            (for-each
+					;              (lambda (local-state)
+					;                (sllgen:pretty-print (map sllgen:unparse-regexp local-state)))
+					;              local-states)
+					;            (eopl:printf "newstates = ~%")
+					;            (for-each
+					;              (lambda (local-state)
+					;                (sllgen:pretty-print (map sllgen:unparse-regexp local-state)))
+					;              newstates))
+	  (if (null? local-states)
+	      ;; no more states to consider
+	      (begin
+					;             '(eopl:printf
+					;               "sllgen:scanner-inner-loop returning with actions = ~s char = ~s newstates = ~%"
+					;               actions char)
+					;             '(for-each
+					;               (lambda (local-state)
+					;                 (sllgen:pretty-print (map sllgen:unparse-regexp local-state)))
+					;               newstates)
+		(k actions newstates char stream))
+	      (let ((state        (car local-states)))
+					;           (eopl:printf "first state:~%")
+					;           (sllgen:pretty-print state)
+		(cond
+		 ((sllgen:action? (car state))    ; state should never be null
+		  ;; recommend accepting what's in the buffer
+		  (set! actions (cons (car state) actions))
+		  (loop (cdr local-states)))
+		 ((sllgen:tester-regexp? (car state))
+		  =>
+		  (sllgen:xapply
+		   (lambda (tester)
+		     ;; get a character if one hasn't been gotten and we
+		     ;; haven't discovered eos.
+		     (if (and (null? char) (not eos-found?))
+			 (sllgen:char-stream-get! stream
+						  (lambda (ch1)
+						    '(eopl:printf "read character ~s~%" ch1)
+						    (set! char ch1))
+						  (lambda ()
+						    (set! eos-found? #t))))
+		     '(eopl:printf "applying tester ~s to ~s~%" tester char)
+		     (if (and (not (null? char))
+			      (sllgen:apply-tester tester char))
+			 ;; passed the test -- shift is possible
+			 (set! newstates (cons (cdr state) newstates)))
+		     ;; either way, continue with the other local-states
+		     (loop (cdr local-states)))))
+		 ((sllgen:or-regexp? (car state))
+		  =>
+		  (sllgen:xapply
+		   (lambda (alternatives)
+		     ;; its ((or alts) regexps action)
+		     (loop (append
+			    (map (lambda (alt) (cons alt (cdr state)))
+				 alternatives)
+			    (cdr local-states))))))
+		 ((sllgen:arbno-regexp? (car state))
+		  =>
+		  (sllgen:xapply
+		   (lambda (regexp1)
+		     ;; it's ((arbno regexp1) regexps action)
+		     ;; so its either (regexps action) or
+		     ;; (regexp1 (arbno regexp1) regexps action)
+		     (loop
+		      (append
+                       (list 
+			(cdr state)    ; 0 occurrences
+			(cons regexp1 state) ; >= 1 occurrences
+			)
+                       (cdr local-states))))))
+		 ((sllgen:concat-regexp? (car state))
+		  =>
+		  (sllgen:xapply
+		   (lambda (sequents)
+		     ;; (printf "processing concat: sequents = ~s~%" sequents)
+		     (loop
+		      (cons 
+                       (append sequents (cdr state))
+                       (cdr local-states)))))))))))))
+
+  (define sllgen:xapply (lambda (x) (lambda (y) (y x))))
+
+  (define sllgen:scanner-outer-loop
+    (lambda (start-states input-stream)   ; -> (token stream), same as before
+      (let 
+	  ((states start-states)            ; list of local-states
+	   (buffer '())                     ; characters accumulated so far
+	   (success-buffer '())             ; characters for the last
+                                        ; candidate token (a sublist
+                                        ; of buffer)
+	   (actions '())                    ; actions we might perform on succ-buff
+	   (stream input-stream)
+	   )
+	(letrec
+	    ((process-stream                
+	      (lambda ()
+		(sllgen:scanner-inner-loop states stream
+					   (lambda (new-actions new-states char new-stream)
+					     (if (not (null? new-actions))
+						 ;; ok, the current buffer is a candidate token
+						 (begin
+						   (set! success-buffer buffer)
+						   ;; (printf "success-buffer =~s~%" success-buffer)
+						   (set! actions new-actions))
+						 ;; otherwise leave success-buffer and actions alone
+						 )
+					     (if (null? new-states)
+						 ;; we are definitely at the end of this token
+						 (process-buffer char new-stream)
+						 ;; there might be more -- absorb another character and
+						 ;; consider what to do next.
+						 (begin
+						   (set! buffer (cons char buffer))
+						   (set! stream  new-stream)
+						   (set! states new-states)
+						   (process-stream)))))))
+	     (process-buffer                ; can't absorb any more chars,
+                                        ; better make do with what we have.
+	      (lambda (char new-stream)
+		;; first, push the lookahead character back on the
+		;; stream.
+		(if (not (null? char))
+		    (sllgen:char-stream-push-back! char new-stream))
+		(set! stream new-stream)
+		(if (null? buffer)
+		    ;; any characters in the buffer?  If not, the stream
+		    ;; must have been empty, so return the empty stream.
+		    sllgen:empty-stream
+		    ;; otherwise, push back any unused characters into the stream
+		    (begin
+		      (let push-back-loop ()
+			(if (eq? buffer success-buffer)
+			    ;; this really is reference equality.
+			    #t
+			    (begin
+			      ;; (eopl:printf "pushing back ~s~%" (car buff))
+			      (sllgen:char-stream-push-back! (car buffer) stream)
+			      (set! buffer (cdr buffer))
+			      (push-back-loop))))
+		      ;; next, look at actions. 
+		      (cond
+		       ((null? actions)
+			;; no actions possible?  Must be a mistake
+			(error 'scanning
+			       "no actions found for ~s" (reverse buffer)))
+		       ((sllgen:is-all-skip? actions)
+			;; If only action is SKIP, 
+			;; then discard buffer and start again. 
+			(set! buffer '())
+			(set! success-buffer '())
+			(set! states start-states) ;!
+			(process-stream))
+		       ;;    Otherwise, perform action on the success-buffer
+		       ;;    and create a token stream.
+		       (else
+			(let ((token
+			       (sllgen:cook-token
+				success-buffer
+				actions
+				(sllgen:char-stream->location stream))))
+			  (sllgen:make-stream 'tag5
+					      token
+					      (lambda (fcn eos-fcn)
+						((sllgen:scanner-outer-loop start-states stream)
+						 fcn eos-fcn)))))))))))
+	  ;; start by trying to absorb a character
+	  (process-stream)))))
+
+  ;; Watch out for examples like:
+  ;; ("a" | "b" | "c" | "abcdef")  matched against "abc" should produce
+  ;; 3 tokens before reaching eos.
+
+  ;; tokens
+
+					; (define-record token (symbol? (lambda (v) #t)))
+
+  (define sllgen:make-token list)
+  (define sllgen:token->class car)
+  (define sllgen:token->data cadr)
+  (define sllgen:token->location caddr)
+
+  ;; streams
+
+  ;; (sllgen:stream-get! (sllgen:make-stream tag char stream) fcn eos-fcn) = (fcn char stream)
+
+  ;; this is banged, because doing it on some streams may cause a side-effect. 
+  (define sllgen:stream-get!
+    (lambda (str fcn eos-fcn) 
+      (str fcn eos-fcn)))
+
+  (define sllgen:empty-stream
+    (lambda (fcn eos-fcn)
+      (eos-fcn)))
+
+  (define sllgen:make-stream
+    (lambda (tag char stream)
+					;(eopl:printf "sllgen:make-stream: building stream at ~s with ~s~%" tag char)
+      (lambda (fcn eos-fcn)
+					;(eopl:printf "sllgen:make-stream: emitting ~s~%" char)
+	(fcn char stream))))
+
+  (define sllgen:list->stream
+    (lambda (l)
+      (if (null? l) sllgen:empty-stream
+	  (sllgen:make-stream 'sllgen:list->stream (car l) (sllgen:list->stream (cdr l))))))
+
+					; ;; brute force for now.
+					; (define sllgen:string->stream
+					;   (lambda (string) (sllgen:list->stream (string->list string))))
+
+					; ;; this one has state:
+					; (define sllgen:stdin-char-stream
+					;   (lambda (fcn eos-fcn)
+					;     (let ((char (read-char)))
+					;       (if (eof-object? char)           
+					;         (eos-fcn)
+					;         (fcn char sllgen:stdin-char-stream)))))
+
+  (define sllgen:stream->list
+    (lambda (stream)
+      (sllgen:stream-get! stream
+			  (lambda (val stream)
+			    (cons val (sllgen:stream->list stream)))
+			  (lambda () '()))))
+
+  (define sllgen:constant-stream
+    (lambda (val)
+      (lambda (fn eos)
+	(fn val (sllgen:constant-stream val)))))
+
+  ;; takes a stream and produces another stream that produces the
+  ;; sentinel instead of an end-of-stream
+  (define sllgen:stream-add-sentinel
+    (lambda (stream sentinel)
+      (lambda (fn eos)                    ; here's what to do on a get
+	(sllgen:stream-get! stream 
+			    (lambda (val str)
+			      (fn val (sllgen:stream-add-sentinel str sentinel)))
+			    (lambda ()
+			      (fn sentinel (sllgen:constant-stream sentinel)))))))
+  
+  (define sllgen:stream-add-sentinel-via-thunk
+    (lambda (stream sentinel-fcn)
+      (lambda (fn eos)                    ; here's what to do on a get
+	(sllgen:stream-get! stream 
+			    (lambda (val str)
+			      (fn val (sllgen:stream-add-sentinel-via-thunk str sentinel-fcn)))
+			    (lambda ()                    
+			      ;; when the stream runs out, try this
+			      (let ((sentinel (sentinel-fcn)))
+					;            (eopl:printf "~s~%" sentinel)
+				(fn sentinel (sllgen:constant-stream sentinel))))))))
+
+					; no longer used
+					; (define sllgen:stream-get
+					;   (lambda (stream fcn)
+					;     (sllgen:stream-get! stream fcn
+					;       (lambda ()
+					;         (sllgen:error 'sllgen:stream-get
+					;           "internal error: old streams aren't supposed to produce eos")))))
+  
+
+  ;; ****************************************************************
+
+  ;; imperative character streams Tue Apr 11 12:09:32 2000
+
+  ;; interface:
+
+  ;; sllgen:string->stream  : string -> charstream
+  ;; sllgen:stdin-char-stream : () -> charstream
+
+  ;; sllgen:char-stream-get! : !charstream * (char -> ans) * (() -> ans)
+  ;;                             -> ans
+  ;;                           [modifies charstream]
+  ;; sllgen:char-stream-push-back! : char * !charstream -> ()
+  ;; sllgen:char-stream->location : charstream -> location
+
+  ;; for the moment, a location is a line number
+
+  ;; we have two kinds of streams-- those built by string->stream and
+  ;; those built by stdin-char-stream.  We'll use a little OO here.
+
+  ;; represent by a vector
+
+  ;; [get-fn ; push-back-fn ; location ; other stuff]
+
+  (define sllgen:char-stream-get!
+    (lambda (cstr sk th)
+      ((vector-ref cstr 0) cstr sk th)))
+
+  (define sllgen:char-stream-push-back!
+    (lambda (ch cstr)
+      ((vector-ref cstr 1) ch cstr)))
+
+  (define sllgen:char-stream->location
+    (lambda (cstr)
+      (vector-ref cstr 2)))
+
+  (define sllgen:set-location!
+    (lambda (vec val)
+      (vector-set! vec 2 val)))
+
+  ;; for a string-built stream, the other stuff consists of an index
+  ;; into the string  for the next unread character, and a string.
+
+  (define sllgen:string->stream
+    (lambda (string)
+      (let ((len (string-length string)))
+	(vector
+	 ;; the get! function
+	 (lambda (vec sk th)
+	   (let ((index (vector-ref vec 3)))
+	     (if (>= index len)
+		 (th)
+		 (begin
+		   (vector-set! vec 3 (+ 1 index))
+		   (let ((ch (string-ref (vector-ref vec 4) index)))
+		     (sllgen:set-location! vec
+					   (sllgen:increment-location ch
+								      (sllgen:char-stream->location vec)))
+		     (sk ch))))))
+	 ;; the push-back function
+	 (lambda (ch vec)
+	   (sllgen:set-location! vec
+				 (sllgen:decrement-location ch
+							    (sllgen:char-stream->location vec)))
+	   (vector-set! vec 3 (- (vector-ref vec 3) 1)))
+	 ;; the location is initially 1
+	 1
+	 ;; the index is initially 0
+	 0
+	 string                          ;; the string
+	 ))))
+
+
+  ;; for stdin-char-stream, we have
+  ;; [get-fn ; push-back-fn ; location ; push-back stack]
+
+  (define sllgen:stdin-char-stream        ; this must be a thunk to reset the
+                                        ;  line number
+    (lambda ()
+      (vector
+       ;; the get! fcn
+       (lambda (vec sk th)
+	 (let ((read-back-stack (vector-ref vec 3)))
+	   (if (null? read-back-stack)
+	       (let ((char (read-char)))
+		 (if (eof-object? char)
+		     (th)
+		     (begin
+		       (sllgen:set-location! vec
+					     (sllgen:increment-location char
+									(sllgen:char-stream->location vec)))
+		       (sk char))))
+	       (let ((char (car read-back-stack)))
+		 (sllgen:set-location! vec
+				       (sllgen:increment-location char
+								  (sllgen:char-stream->location vec)))
+		 (vector-set! vec 3 (cdr read-back-stack))
+		 (sk char)))))
+       ;; the push back
+       (lambda (ch vec)
+	 (sllgen:set-location! vec
+			       (sllgen:decrement-location ch
+							  (sllgen:char-stream->location vec)))
+	 (vector-set! vec 3 (cons ch (vector-ref vec 3))))
+       0                                 ; location is initially 0 to
+                                        ;  swallow the initial newline
+       '()                               ; push-back is initially empty
+       )))
+
+  (define sllgen:char-stream->list
+    (lambda (cstr)
+      (let loop ()
+	(sllgen:char-stream-get! cstr
+				 (lambda (ch) (cons ch (loop)))
+				 (lambda () '())))))
+
+  (define sllgen:char-stream->list2
+    (lambda (cstr)
+      (let loop ()
+	(sllgen:char-stream-get! cstr
+				 (lambda (ch)
+				   (cons
+				    (cons ch (sllgen:char-stream->location cstr))
+				    (loop)))
+				 (lambda () '())))))
+
+
+  (define sllgen:increment-location
+    (lambda (ch n)
+      (if (eqv? ch #\newline) (+ 1 n) n)))
+
+  (define sllgen:decrement-location
+    (lambda (ch n)
+      (if (eqv? ch #\newline) (- n 1) n)))
+
+  ;; see tests.s for examples.
+
+  ;; ****************************************************************        
+
+  ;; parse.s
+
+  ;; parse.s -- run the generated parser
+
+  ;; parsing table is of following form:
+
+  ;; table ::= ((non-terminal alternative ...) ...)
+  ;; alternative ::= (list-of-items action ...) 
+  ;; action ::= (TERM symbol) | (NON-TERM symbol) | (GOTO symbol) 
+  ;;            | (EMIT-LIST) | (REDUCE symbol)
+
+  ;; The token register can either contain an token or '() -- the latter
+  ;; signifying an empty buffer, to be filled when necessary.
+
+					; (define-record sllgen:parser-result (tree token stream))
+
+					; k = (lambda (tree token stream) ...)
+					; token may be a token or nil.
+  (define sllgen:find-production
+    (lambda (non-terminal parser buf token stream k)
+      (if (null? token)
+	  (sllgen:stream-get! stream
+			      (lambda (next-token next-stream)
+					;        '(eopl:printf "find-production: filling token buffer with ~s~%" token)
+				(set! token next-token)
+				(set! stream next-stream))
+			      (lambda ()
+				(error 'sllgen:find-production
+				       "internal error: shouldn't run off end of stream"))))
+					;    '(eopl:printf "sllgen:find-production: nonterminal = ~s token = ~s~%"
+					;       non-terminal token)
+      (let loop
+	  ((alternatives (cdr (assq non-terminal parser))))
+	(cond
+	 ((null? alternatives)
+	  (error 'parsing
+		 "at line ~s: nonterminal <~s> can't begin with ~s ~s"
+		 (sllgen:token->location token)
+		 non-terminal
+		 (sllgen:token->class token)
+		 (sllgen:token->data token)))
+	 ((member (sllgen:token->class token) (car (car alternatives)))
+					;         '(eopl:printf "sllgen:find-production: using ~s~%~%"
+					;            (cdr (car alternatives)))
+	  (sllgen:apply-actions non-terminal (cdr (car alternatives))
+				parser buf token stream k))
+	 ((and (string? (sllgen:token->data token))
+	       (member (sllgen:token->data token) (car (car alternatives))))
+	  (sllgen:apply-actions non-terminal (cdr (car alternatives))
+				parser buf token stream k))
+	 (else (loop (cdr alternatives)))))))
+
+  (define sllgen:apply-actions
+    (lambda (lhs action-list parser buf token stream k)
+      (let loop ((actions action-list)
+		 (buf buf)
+		 (token token)
+		 (stream stream))
+	(let ((fill-token!                ; fill-token! is a macro in mzscheme
+	       (lambda ()
+		 (if (null? token)
+		     (sllgen:stream-get! stream
+					 (lambda (next-token next-stream)
+					   (set! token next-token)
+					   (set! stream next-stream))
+					 (lambda ()
+					   (error 'sllgen:apply-actions
+						  "internal error: shouldn't run off end of stream"
+						  ))))))
+	      (report-error
+	       (lambda (target)
+		 (error 'parsing
+			"at line ~s: looking for ~s, found ~s ~s in production~%~s"
+			(sllgen:token->location token)
+			target
+			(sllgen:token->class token)
+			(sllgen:token->data token)
+			action-list))))
+	  (let ((action      (car actions))
+		(next-action (cdr actions)))
+					;         (eopl:printf "actions = ~s~%token = ~s buf = ~s~%~%" actions token buf)
+	    (case (car action)
+	      ((term)
+	       (fill-token!)
+	       (let ((class (cadr action)))
+		 (if (eq? (sllgen:token->class token) class)
+		     ;; ok, this matches, proceed, but don't get next token --
+		     ;; after all, this might be the last one.
+		     (loop next-action 
+			   (cons (sllgen:token->data token) buf)
+			   '()                  ; token register is now empty
+			   stream)
+		     ;; nope, fail.
+		     (report-error class))))
+	      ((string)
+	       (let ((the-string (cadr action)))
+		 (fill-token!)
+		 (if (and
+		      (not (eq? (sllgen:token->class token) 'end-marker))
+		      (string? (sllgen:token->data token))
+		      (string=? (sllgen:token->data token) the-string))
+		     (loop next-action buf '() stream)
+		     ;; nope, fail.
+		     (report-error the-string))))
+	      ((non-term)
+	       (let ((non-terminal (cadr action)))
+		 (sllgen:find-production non-terminal parser
+					 '() token stream
+					 (lambda (tree token stream)
+					   (loop next-action (cons tree buf) token stream)))))
+	      ((arbno)
+	       (let ((non-terminal (cadr action))
+		     (count       (caddr action)))
+		 (sllgen:find-production non-terminal parser
+					 '() token stream
+					 (lambda (trees token stream)
+					   (loop next-action
+						 (sllgen:unzip-buffer trees count buf)
+						 token stream)))))
+
+	      ((goto)
+	       (let ((non-terminal (cadr action)))
+		 (sllgen:find-production non-terminal parser buf token
+					 stream k)))
+	      ((emit-list)
+	       (k buf token stream))
+	      ((reduce)
+	       (let ((opcode (cadr action)))
+		 (k
+                                        ;               (apply (make-record-from-name opcode)
+                                        ;                      (reverse buf))
+		  (sllgen:apply-reduction lhs opcode (reverse buf))
+		  token
+		  stream)))
+	      (else
+	       (error 'sllgen:apply-actions
+		      "internal error: unknown instruction ~s"
+		      action))))))))
+
+  (define sllgen:unzip-buffer
+    (lambda (trees n buf)
+      (let ((ans (let consloop ((n n))
+		   (if (zero? n) buf (cons '() (consloop (- n 1)))))))
+	(let loop ((trees trees)
+		   (ptr ans)
+		   (ctr n))
+					;     (eopl:printf "ctr = ~s trees = ~s~%" ctr trees)
+	  (cond
+	   ((null? trees) ans)
+	   ((zero? ctr) (loop trees ans n))
+	   (else
+	    (set-car! ptr (cons (car trees) (car ptr)))
+	    (loop (cdr trees) (cdr ptr) (- ctr 1))))))))
+  
+  (define sllgen:apply-reduction
+    (lambda (lhs opcode args)
+      (apply (eval opcode (interaction-environment))
+	     args)))
+  )
diff --git a/collects/eopl/private/utils.ss b/collects/eopl/private/utils.ss
new file mode 100644
index 0000000000..f8f097b9ed
--- /dev/null
+++ b/collects/eopl/private/utils.ss
@@ -0,0 +1,18 @@
+
+(module utils mzscheme
+
+  ;; Generative structure definitions:
+  (define-struct dt (pred-stx variants))
+  (define-struct vt (name-stx predicate-stx accessor-stx field-count))
+  
+  ;; Helper function:
+  (define (variant-assq name-stx variants)
+    (let loop ([l variants])
+      (if (module-identifier=? name-stx 
+			       (vt-name-stx (car l)))
+	  (car l)
+	  (loop (cdr l)))))
+  
+  (provide (struct dt (pred-stx variants))
+	   (struct vt (name-stx predicate-stx accessor-stx field-count))
+	   variant-assq))
diff --git a/collects/errortrace/doc.txt b/collects/errortrace/doc.txt
new file mode 100644
index 0000000000..8b479266b9
--- /dev/null
+++ b/collects/errortrace/doc.txt
@@ -0,0 +1,315 @@
+
+ [index entries: _debug_ _debugger_ _debugging_
+                 _profile_ _profiler_ _profiling_
+                 _coverage_ ]
+
+_Errortrace_ is a stack-trace-on-exceptions/profiler/coverage tool for
+ MzScheme.  Errortrace is not a complete debugger, and a real debugger
+ in DrScheme is expected soon; meanwhile, using errortrace might be
+ better than nothing.
+
+Quick instructions
+------------------
+
+  0) Throw away .zo versions of your source
+
+  1) Prefix your program with
+      (require (lib "errortrace.ss" "errortrace"))
+     or start MzScheme with the -M flag:
+      mzscheme -M errortrace
+
+  2) When an exception occurs, the exception handler
+     prints something like a stack trace, most recent
+     contexts first
+
+The errortrace module is odd; don't import it into another
+module. Instead, the errortrace module is meant to be invoked from the
+top-level, so that it can install an evaluation handler, exception
+handler, etc.
+
+To reuse parts of the code of errortrace, import
+_errortrace-lib.ss_. It contains all of the names here but
+does not set the compilation handler or the error display handler.
+
+Exception Information
+---------------------
+
+Invoking the errortrace.ss module sets the compilation handler to
+instrument Scheme source code. It also sets the error display handler
+to report source information for an exception, and it sets the
+`use-compiled-file-paths' parameter to trigger the use of
+errortrace-specific .zo files.
+
+ NOTE: errortrace has no effect on code loaded as compiled byte code
+ (i.e., from a .zo file) or native code (i.e., from a .dll or .so
+ file). But use the "--mode errortrace" flag to Setup PLT to create
+ .zo files with errortrace information.
+
+Errortrace's instrumentation can be explicitly disabled via the
+`instrumenting-enabled' boolean parameter. Instrumentation is on by
+default. The `instrumenting-enabled' parameter affects only the way
+that source code is compiled, not the way that exception information
+is reported.
+
+> (instrumenting-enabled) - returns #t if error tracing instrumentation is
+  enabled, #f otherwise
+> (instrumenting-enabled on?) - enables/disables error tracing
+  instrumentation
+
+The instrumentation for storing exception information slows most
+programs by a factor of 2 or 3.
+
+Do not load errortrace before writing .zo files. Errortrace
+instruments S-expressions with unprintable values; this works fine if
+the instrumented S-expression is passed to the default eval handler,
+but neither the S-expression nor its byte-code form can be marshalled
+to a string.
+
+The `print-error-trace' procedure takes a port and exception and
+prints the errortrace-collected debugging information contained in the
+exception. It is used by the exception handler installed by
+errortrace.
+
+> (print-error-trace output-port exn) - prints the errortrace
+  information in `exn' to `output-port'.
+
+The `error-context-display-depth' parameter controls how much context
+errortrace's exception handler displays. The default value is 10000.
+
+> (error-context-display-depth) - returns the current context display
+  depth
+> (error-context-display-depth d) - sets the context display depth to
+  `d'
+
+Profiling
+---------
+
+Errortrace's profiling instrumentation is off by default. Enable
+profiling instrumentation with the `profiling-enabled' boolean
+parameter (but setting `instrumentation-enabled' to #f also disables
+profiling):
+
+> (profiling-enabled) - returns #t if profiling instrumentation is
+  enabled, #f otherwise
+> (profiling-enabled on?) - enables/disables profiling instrumentation
+
+> (profiling-record-enabled) - returns #t if profiling info is
+  recorded for instrumented code, #f otherwise; the default is #t
+> (profiling-record-enabled on?) - enables/disables the recording of
+  profiling info (independent of whether newly evaluated code is
+  instrumented)
+
+Profiling records:
+
+ * the number of times a procedure was called.
+
+ * the number of milliseconds consumed by the procedure's body across
+   all calls (including the time consumed by any nested non-tail call
+   within the procedure, but not including time consumed by a
+   tail-call from the procedure).
+
+ * an inferred name for the procedure.
+
+ * the procedure's source in the form of a syntax object (which might,
+   in turn, provide a source location file and position).
+
+ * optionally, information about the procedure call path (something
+   like the stack trace) for every call to the procedure. Path
+   information is collected when the `profile-paths-enabled' boolean
+   parameter is #t; the default is #f, but setting the parameter to #t
+   immediately affects all procedure instrumented for profiling
+   information:
+
+>   (profile-paths-enabled) - returns #t if profiling collects path
+    information, #f otherwise
+>   (profile-paths-enabled on?) - enables/disables collecting path
+    information for profiling
+
+Profiling information is accumulated in a hash table. If a procedure
+is redefined, new profiling information is accumulated for the new
+version of the procedure, but the old information is also preserved.
+
+To retrieve all profiling information accumulated so far, call
+`get-profile-results':
+
+> (get-profile-results) - returns a list of lists that contain:
+
+  * the number of times the procedure was called;
+
+  * the number of milliseconds of process time consumed by the
+    procedure;
+
+  * the inferred name or #f of the procedure;
+
+  * the syntax source of the procedure; and
+
+  * a list of call paths, recorded while `profile-paths-enabled' is
+    set to #t. Each call path is a list containing two-element lists;
+    each two-element list contains the calling proceure's name or
+    source expression and the calling procedure's source file or #f.
+
+Depending of the source program, profiling usually induces a factor of
+2 to 4 slowdown (in addition to any slowdown from the exception
+information instrumentation).
+
+> (output-profile-results paths? sort-time?)
+
+Gets the current profile results and displays them. It optionally
+shows paths information (if it is recorded) and sorts by either time
+or call counts.
+
+Coverage
+--------
+
+Errortrace can track expression execution that is useful for checking
+test coverage (i.e., simple expression coverage). Enable coverage
+checking with the `execute-counts-enabled' boolean parameter (but
+setting `instrumentation-enabled' to #f also disables execute
+counting):
+
+> (execute-counts-enabled) - returns #t if execute-counting
+  instrumentation is enabled, #f otherwise
+> (execute-counts-enabled on?) - enables/disables execute-counting
+  instrumentation
+
+> (get-execute-counts) - returns a list of pairs, one for each
+  instrucmented expression. The first element of the pair is a syntax
+  object (usually containing source location information) for the
+  original expression, and the second element of the pair is the
+  number of times that the expression has been evaluated.
+
+> (annotate-executed-file filename-path) - writes the named file to
+  the current output port, inserting an additional line between each
+  source line to reflect execution counts (as reported by
+  `get-execute-counts'). An expression underlined with "^" has been
+  executed 0 times; an expression underlined with "." has been
+  executed 1 time; and an expression underlined with "," has been
+  executed multiple times.
+
+_Re-using errortrace handlers_
+-----------------------------------
+
+The _errortrace-lib.ss_ module exports all of the exports of
+"errortrace.ss", plus a few more. It does not install any handlers.
+
+The addition exports are as follows:
+
+> (errortrace-compile-handler stx immediate-eval?) - compiles `stx'
+  using the compilation handler that was active when the
+  "errortrace-lib.ss" module was executed, but first instruments the
+  code for errortrace information. The code is instrumented only if
+  the namespace is the same as when the module was executed. This
+  procedure is suitable for use as a compilation handler.
+
+> (errortrace-error-display-handler string exn) - displays information
+  about the exception; this procedure is suitable for use as an error
+  display handler.
+
+> (errortrace-annotate stx) - macro-expands and instruments the given
+  top-level form. If the form is a module named `errortrace-key', no
+  instrumentation is applied. This annotation function is used by
+  `errortrace-compile-handler'.
+
+> (annotate-top stx) - like `errortrace-annotate', but without the
+  special case for `errortrace-key'. Also, if `stx' is a module
+  declaration, it is not enriched with imports to explicitly load
+  errortrace run-time support.
+
+
+_Re-using errortrace stack tracing_
+-----------------------------------
+
+The errortrace collection also includes a _stacktrace.ss_ library.
+It exports the _stacktrace@_ unit and it import signature
+_stacktrace-imports^_, and its export signature _stacktrace^_.
+
+The export signature contains these names:
+
+> annotate : syntax boolean -> syntax
+> annotate-top : syntax boolean -> syntax
+> make-st-mark : syntax -> syntax
+> st-mark-source : st-mark -> any
+> st-mark-bindings : st-mark -> (listof (list syntax any))
+
+The first two functions annotate expressions with errortrace
+information.  The `annotate-top' function should be called with a
+top-level expression, and `annotate' should be called with a nested
+expression (e.g., by `profile-point'). The boolean argument indicates
+whether the expression is a transformer expression (#t) or a normal
+expression (#f).
+
+The `st-mark-source' and `st-mark-bindings' functions extract
+information from a particular kind of value. The value must
+be created by `make-st-mark'. `st-mark-source' extracts
+the value originally provided to the expresion-maker, and
+`st-mark-bindings' returns local binding information (if available).
+
+The import signature contains these names:
+
+> with-mark : syntax syntax -> syntax
+
+  This procedure is called by `annotate' and `annotate-top'
+  to wrap expressions with `with-continuation-mark'. The
+  first argument is the source expression and the second
+  argument is the expression to be wrapped.
+
+> test-coverage-enabled : (parameter boolean)
+
+  This parameter determines if the test coverage annotation
+  is inserted into the code. This parameter controls how
+  compilation happens -- it does not affect the dynamic
+  behavior of the already compiled code. If the parameter is
+  set, calls to test-covered are inserted into the code (and
+  initialize-test-coverage-point is called during
+  compilation). If not, no calls to test-covered are inserted.
+
+> test-covered : symbol -> void
+
+  During execution of the program, this is called for each
+  point with the key for that program point that was passed
+  to initialize-test-coverage-point.
+
+> initialize-test-coverage-point : symbol syntax -> void
+
+  During compilation of the program, this function is called
+  with each sub-expression of the program. The first
+  argument is a special key used to identify this program
+  point. The second argument is the syntax of this program
+  point. 
+
+> profile-key : symbol
+
+  only used for profiling paths
+
+> profiling-enabled  : -> boolean
+
+  determines if profiling information is currently collected
+  (affects the behavior of compiling the code -- does not
+  affect running code). If this always returns #f, 
+  the other profiling functions are never called.
+
+> initialize-profile-point : symbol (union #f syntax[symbol]) syntax -> void
+
+  called as the program is compiled for each profiling point
+  that might be encountered during the program's
+  execution. The first argument is a key identifying this
+  code. The second argument is the inferred name at this
+  point and the final argument is the syntax of this expression.
+
+> register-profile-start : symbol -> (union #f number)
+ 
+  Called when some profiled code is about to be executed. If
+  the result is a number, it is expected to be the current
+  number of milliseconds. The symbol is a key that is unique
+  to this fragment of code -- it is the same symbol passed
+  to initialize-profile-point for this code fragment.
+			      
+> register-profile-done : symbol (union #f number) -> void
+
+  This function is called when some profiled code is
+  finished executing. The 
+
+  Note that register-profile-start and register-profile-done
+  can be called in a nested manner; in this case, the result
+  of register-profile-point should be #f.
+
diff --git a/collects/errortrace/errortrace-key-syntax.ss b/collects/errortrace/errortrace-key-syntax.ss
new file mode 100644
index 0000000000..658380434e
--- /dev/null
+++ b/collects/errortrace/errortrace-key-syntax.ss
@@ -0,0 +1,7 @@
+(module errortrace-key-syntax mzscheme
+  (require (lib "errortrace-key.ss" "errortrace"))
+  (require-for-syntax (lib "errortrace-key.ss"  "errortrace"))
+  (define errortrace-key-syntax #'errortrace-key)
+  (provide errortrace-key-syntax))
+
+
diff --git a/collects/errortrace/errortrace-key.ss b/collects/errortrace/errortrace-key.ss
new file mode 100644
index 0000000000..7abfa29f15
--- /dev/null
+++ b/collects/errortrace/errortrace-key.ss
@@ -0,0 +1,5 @@
+(module errortrace-key mzscheme
+  (define errortrace-key (gensym 'key))
+  
+  (provide errortrace-key))
+
diff --git a/collects/errortrace/errortrace-lib.ss b/collects/errortrace/errortrace-lib.ss
new file mode 100644
index 0000000000..76b99331cf
--- /dev/null
+++ b/collects/errortrace/errortrace-lib.ss
@@ -0,0 +1,323 @@
+
+;; Poor man's stack-trace-on-exceptions/profiler.
+;; See doc.txt for information.
+
+(module errortrace-lib mzscheme
+  (require "stacktrace.ss"
+	   "errortrace-key.ss"
+           (lib "list.ss") 
+           (lib "unitsig.ss"))
+
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; Test coverage run-time support
+  (define test-coverage-enabled (make-parameter #f))
+  
+  (define test-coverage-info (make-hash-table))
+  
+  (define (initialize-test-coverage-point key expr)
+    (hash-table-put! test-coverage-info key (list #f expr)))
+  
+  (define (test-covered key)
+    (let ([v (hash-table-get test-coverage-info key)])
+      (set-car! v #t)))
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; Profiling run-time support
+
+  (define profile-thread #f)
+  (define profile-key (gensym))
+  
+  (define profiling-enabled (make-parameter #f))
+  (define profiling-record-enabled (make-parameter #t))
+  (define profile-paths-enabled (make-parameter #f))
+  
+  (define profile-info (make-hash-table))
+
+  (define (initialize-profile-point key name expr)
+    (hash-table-put! profile-info key (list (box #f) 0 0 (and name (syntax-e name)) expr null)))
+  
+  (define (register-profile-start key)
+    (and (profiling-record-enabled)
+	 (let ([v (hash-table-get profile-info key)])
+	   (let ([b (car v)]
+		 [v (cdr v)])
+	     (set-car! v (add1 (car v)))
+	     (when (profile-paths-enabled)
+	       (let ([v (cdddr v)])
+		 (set-car! v (cons (current-continuation-marks profile-key) (car v)))))
+	     (if (unbox b)
+		 #f
+		 (begin
+		   (set-box! b #t)
+		   (current-process-milliseconds)))))))
+  
+  (define (register-profile-done key start)
+    (when start
+      (let ([v (hash-table-get profile-info key)])
+	(let ([b (car v)]
+	      [v (cddr v)])
+	  (set-box! b #f)
+	  (let ([v (cddr (hash-table-get profile-info key))])
+	    (set-car! v (+ (- (current-process-milliseconds) start) (car v))))))))
+  
+  (define (get-profile-results)
+    (hash-table-map profile-info (lambda (key val)
+                                   (let ([count (cadr val)]
+                                         [time (caddr val)]
+                                         [name (cadddr val)]
+                                         [expr (cadddr (cdr val))]
+                                         [cmss (cadddr (cddr val))])
+                                     (list count time name expr
+                                           (map
+                                            (lambda (cms)
+                                              (map (lambda (k)
+                                                     (let ([v (cdr (hash-table-get profile-info k))])
+                                                       (list (caddr v) (cadddr v))))
+                                                   cms))
+                                            cmss))))))
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; Stacktrace instrumenter
+
+  (define dynamic-errortrace-key
+    (dynamic-require '(lib "errortrace-key-syntax.ss" "errortrace") 
+		     'errortrace-key-syntax))
+
+  ;; with-mark : stx stx -> stx
+  (define (with-mark mark expr)
+    (with-syntax ([expr expr]
+		  [loc (make-st-mark mark)]
+		  [et-key dynamic-errortrace-key])
+      (execute-point
+       mark
+       (syntax
+	(with-continuation-mark
+	    et-key
+	    loc
+	  expr)))))
+
+  (define-values/invoke-unit/sig stacktrace^ stacktrace@ #f stacktrace-imports^)
+
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; Execute counts
+
+  (define execute-info (make-hash-table))
+  
+  (define execute-counts-enabled (make-parameter #f))
+
+  (define (register-executed-once key)
+    (let ([i (hash-table-get execute-info key)])
+      (set-cdr! i (add1 (cdr i)))))
+
+  (define (execute-point mark expr)
+    (if (execute-counts-enabled)
+	(let ([key (gensym)])
+	  (hash-table-put! execute-info key (cons mark 0))
+	  (with-syntax ([key (datum->syntax-object #f key (quote-syntax here))]
+			[expr expr]
+			[register-executed-once register-executed-once]) ; <--- 3D !
+	    (syntax
+	     (begin
+	       (register-executed-once 'key)
+	       expr))))
+	expr))
+
+  (define (get-execute-counts)
+    (hash-table-map execute-info (lambda (k v) v)))
+
+  (define (annotate-executed-file name)
+    (let ([name (path->complete-path name (current-directory))])
+      (let ([here (filter (lambda (s)
+			    (and (equal? name (syntax-source (car s)))
+				 (syntax-position (car s))))
+			  (get-execute-counts))])
+	(let ([sorted (quicksort here (lambda (a b)
+					(let ([ap (syntax-position (car a))]
+					      [bp (syntax-position (car b))])
+					  (or (< ap bp) ; earlier first
+					      (and (= ap bp)
+						   (let ([as (syntax-span (car a))]
+							 [bs (syntax-span (car b))])
+						     (or (> as bs) ; wider first at same pos
+							 (and (= as bs)
+							      ; less called for same region last
+							      (> (cdr a) (cdr b))))))))))]
+	      [pic (make-string (file-size name) #\space)])
+	  ;; fill out picture:
+	  (for-each (lambda (s)
+		      (let ([pos (sub1 (syntax-position (car s)))]
+			    [span (syntax-span (car s))]
+			    [key (let ([c (cdr s)])
+				   (cond
+				    [(zero? c) #\^]
+				    [(= c 1) #\.]
+				    [else #\,]))])
+			(let loop ([p pos])
+			  (unless (= p (+ pos span))
+			    (string-set! pic p key)
+			    (loop (add1 p))))))
+		    sorted)
+	  ;; Write annotated file
+	  (with-input-from-file name
+	    (lambda ()
+	      (let loop ()
+		(let ([pos (file-position (current-input-port))]
+		      [line (read-line (current-input-port) 'any)])
+		  (unless (eof-object? line)
+		    (printf "~a~n" line)
+		    (let ([w (string-length line)])
+		      ;; Blank out leading spaces in pic:
+		      (let loop ([i 0])
+			(cond
+			 [(and (< i w)
+			       (char-whitespace? (string-ref line i)))
+			  (string-set! pic (+ pos i) (string-ref line i))
+			  (loop (add1 i))]))
+		      (printf "~a~n" (substring pic pos (+ pos w))))
+		    (loop))))))))))
+
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; Eval handler, exception handler
+
+  (define instrumenting-enabled (make-parameter #t))
+  (define error-context-display-depth (make-parameter 10000 (lambda (x) (and (integer? x) x))))
+  
+  ;; port exn -> void
+  ;; effect: prints out the context surrounding the exception
+  (define (print-error-trace p x)
+    (let loop ([n (error-context-display-depth)]
+               [l (map st-mark-source
+		       (continuation-mark-set->list (exn-continuation-marks x) 
+						    errortrace-key))])
+      (cond
+        [(or (zero? n) (null? l)) (void)]
+        [(pair? l)
+	 (let* ([stx (car l)]
+		[source (syntax-source stx)]
+		[file (cond
+		       [(string? source) source]
+		       [(path? source)
+			(path->string source)]
+		       [(not source)
+			#f]
+		       [else
+			(format "~a" source)])]
+		[line (syntax-line stx)]
+		[col (syntax-column stx)]
+		[pos (syntax-position stx)])
+	   (fprintf p "~a~a: ~e~n" 
+		    (or file "[unknown source]")
+		    (cond
+		     [line (format ":~a:~a" line col)]
+		     [pos (format "::~a" pos)]
+		     [else ""])
+		    (syntax-object->datum stx))
+	   (loop (- n 1) (cdr l)))])))
+
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; Profile printer
+
+  (define (output-profile-results paths? sort-time?)
+    (profiling-enabled #f)
+    (error-print-width 50)
+    (printf "Sorting profile data...~n")
+    (let* ([sel (if sort-time? cadr car)]
+	   [counts (quicksort (filter (lambda (c) (positive? (car c))) (get-profile-results))
+			      (lambda (a b) (< (sel a) (sel b))))]
+	   [total 0])
+      (for-each
+       (lambda (c)
+	 (set! total (+ total (sel c)))
+	 (printf "====================================================================~n")
+	 (printf "time = ~a : no. = ~a : ~e in ~s~n" (cadr c) (car c) (caddr c) (cadddr c))
+	 ;; print call paths
+	 (when paths?
+	   (for-each
+	    (lambda (cms)
+	      (unless (null? cms)
+		(printf "  VIA ~e" (caar cms))
+		(for-each
+		 (lambda (cm)
+		   (printf " <- ~e" (car cm)))
+		 (cdr cms))
+		(printf "~n")))
+	    (cadddr (cdr c)))))
+       counts)
+      (printf "Total samples: ~a~n" total)))
+
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (define errortrace-annotate
+    (lambda (top-e)
+      (define (normal e)
+	(let ([ex (expand-syntax e)])
+	  (annotate-top ex #f)))
+      (syntax-case top-e (begin module)
+	[(module name . reste)
+	 (if (eq? (syntax-e #'name) 'errortrace-key)
+	     top-e
+	     (let ([top-e (expand-syntax top-e)])
+	       (syntax-case top-e (module #%plain-module-begin)
+		 [(module name init-import (#%plain-module-begin body ...))
+		  (normal
+		   #`(module name init-import 
+		       (#%plain-module-begin 
+			#,((make-syntax-introducer)
+			   #'(require (lib "errortrace-key.ss" "errortrace")))
+			#,((make-syntax-introducer)
+			   #'(require-for-syntax (lib "errortrace-key.ss" "errortrace")))
+			body ...)))])))]
+	[_else
+	 (normal top-e)])))
+
+  (define errortrace-compile-handler
+    (let ([orig (current-compile)]
+          [ns (current-namespace)])
+      (lambda (e immediate-eval?)
+	(orig
+	 (if (and (instrumenting-enabled)
+		  (eq? ns (current-namespace))
+		  (not (compiled-expression? (if (syntax? e)
+						 (syntax-e e)
+						 e))))
+	     (let ([e2 (errortrace-annotate
+			(if (syntax? e)
+			    e
+			    (namespace-syntax-introduce
+			     (datum->syntax-object #f e))))])
+	       e2)
+	     e)
+	 immediate-eval?))))
+
+  (define errortrace-error-display-handler
+    (let ([orig (error-display-handler)])
+      (lambda (msg exn)
+        (if (exn? exn)
+            (let ([p (open-output-string)])
+              (display (exn-message exn) p)
+              (newline p)
+              (print-error-trace p exn)
+              (orig (get-output-string p) exn))
+            (orig msg exn)))))
+  
+  (provide errortrace-compile-handler
+           errortrace-error-display-handler
+	   errortrace-annotate
+           
+           print-error-trace 
+	   error-context-display-depth 
+	   
+	   instrumenting-enabled 
+
+	   profiling-enabled
+	   profiling-record-enabled
+	   profile-paths-enabled 
+	   get-profile-results
+	   output-profile-results
+
+	   execute-counts-enabled
+	   get-execute-counts
+	   annotate-executed-file
+           
+           annotate-top))
+ 
diff --git a/collects/errortrace/errortrace.ss b/collects/errortrace/errortrace.ss
new file mode 100644
index 0000000000..ea23f8ff5f
--- /dev/null
+++ b/collects/errortrace/errortrace.ss
@@ -0,0 +1,26 @@
+
+;; Poor man's stack-trace-on-exceptions/profiler.
+;; See doc.txt for information.
+
+(module errortrace mzscheme
+  (require "errortrace-lib.ss")
+  
+  (provide print-error-trace 
+	   error-context-display-depth 
+	   
+	   instrumenting-enabled 
+
+	   profiling-enabled
+	   profiling-record-enabled
+	   profile-paths-enabled 
+	   get-profile-results
+	   output-profile-results
+
+	   execute-counts-enabled
+	   get-execute-counts
+	   annotate-executed-file)
+  
+  (current-compile errortrace-compile-handler)
+  (error-display-handler errortrace-error-display-handler)
+  (use-compiled-file-paths (cons (build-path "compiled" "errortrace")
+				 (use-compiled-file-paths))))
diff --git a/collects/errortrace/info.ss b/collects/errortrace/info.ss
new file mode 100644
index 0000000000..0ff2a6d45c
--- /dev/null
+++ b/collects/errortrace/info.ss
@@ -0,0 +1,9 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Errortrace")
+  (define doc.txt "doc.txt")
+  (define blurb
+    (list
+     "Errortrace is a Poor Man's stack-trace-on-exceptions/profiler for "
+     "MzScheme. Errortrace is not a complete debugger, and a real debugger "
+     "in DrScheme is imminent; meanwhile, using errortrace might be better "
+     "than nothing.")))
diff --git a/collects/errortrace/stacktrace.ss b/collects/errortrace/stacktrace.ss
new file mode 100644
index 0000000000..c962294db9
--- /dev/null
+++ b/collects/errortrace/stacktrace.ss
@@ -0,0 +1,526 @@
+
+(module stacktrace mzscheme
+  (require (lib "unitsig.ss")
+           (lib "kerncase.ss" "syntax")
+           (lib "stx.ss" "syntax"))
+  
+  (provide stacktrace@ stacktrace^ stacktrace-imports^)
+  
+  (define-signature stacktrace-imports^ (with-mark
+                                         
+                                         test-coverage-enabled
+                                         test-covered
+                                         initialize-test-coverage-point
+                                         
+                                         profile-key
+                                         profiling-enabled
+                                         initialize-profile-point
+                                         register-profile-start
+                                         register-profile-done))
+  (define-signature stacktrace^ (annotate-top 
+				 annotate  
+                                 make-st-mark
+                                 st-mark-source
+				 st-mark-bindings))
+  
+  (define o (current-output-port))
+  (define (oprintf . args) (apply fprintf o args))
+  
+  (define stacktrace@
+    (unit/sig stacktrace^
+      (import stacktrace-imports^)
+
+      (define (short-version v depth)
+	(cond
+	 [(identifier? v) (syntax-e v)]
+	 [(null? v) null]
+	 [(vector? v) (if (zero? depth)
+			  #(....)
+			  (list->vector
+			   (short-version (vector->list v) (sub1 depth))))]
+	 [(box? v) (if (zero? depth)
+		       #&(....)
+		       (box (short-version (unbox v) (sub1 depth))))]
+	 [(pair? v) 
+          (cond
+            [(zero? depth) '(....)]
+            [(memq (syntax-e (car v)) '(#%datum #%app #%top))
+             (short-version (cdr v) depth)]
+            [else
+             (cons (short-version (car v) (sub1 depth))
+                   (short-version (cdr v) (sub1 depth)))])]
+	 [(syntax? v) (short-version (syntax-e v) depth)]
+	 [else v]))
+
+      (define (make-st-mark stx)
+        (unless (syntax? stx)
+          (error 'make-st-mark "expected syntax object as argument, got ~e" stx))
+        #`(quote (#,(short-version stx 10)
+                    #,(let ([s (let ([source (syntax-source stx)])
+                                 (cond
+                                   [(string? source) source]
+                                   [(path? source) (path->string source)]
+                                   [(not source) #f]
+                                   [else (format "~a" source)]))])
+                        (and s
+                             (string->symbol s)))
+                    #,(syntax-line stx)
+                    #,(syntax-column stx)
+                    #,(syntax-position stx)
+                    #,(syntax-span stx))))
+      (define (st-mark-source src) (datum->syntax-object
+				    #f
+				    (car src)
+				    (cdr src)
+				    #f))
+				    
+      (define (st-mark-bindings x) null)
+
+      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;; Test case coverage instrumenter
+
+      ;; The next procedure is called by `annotate' and `annotate-top' to wrap
+      ;; expressions with test suite coverage information.  Returning the
+      ;; first argument means no tests coverage information is collected.
+      
+      ;; test-coverage-point : syntax syntax -> syntax
+      ;; sets a test coverage point for a single expression
+      (define (test-coverage-point body expr)
+        (if (test-coverage-enabled)
+            (let ([key (gensym 'test-coverage-point)])
+              (initialize-test-coverage-point key expr)
+              (with-syntax ([key (datum->syntax-object #f key (quote-syntax here))]
+                            [body body]
+                            [test-covered test-covered])
+                (syntax
+                 (begin
+                   (test-covered 'key)
+                   body))))
+            body))
+      
+      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;; Profiling instrumenter
+
+      ;; profile-point : (syntax[list of exprs] symbol-or-#f syntax boolean -> syntax[list of exprs])
+
+      ;; This procedure is called by `annotate' and `annotate-top' to wrap
+      ;; expressions with profile collecting information.  Returning the
+      ;; first argument means no profiling information is collected.
+
+      ;; The second argument is the point's inferred name, if any, the third
+      ;; argument is the source expression, and the fourth argument is #t for
+      ;; a transformer expression and #f for a normal expression.
+
+      (define (profile-point bodies name expr trans?)
+	(let ([key (gensym 'profile-point)])
+	  (initialize-profile-point key name expr)
+	  (with-syntax ([key (datum->syntax-object #f key (quote-syntax here))]
+			[start (datum->syntax-object #f (gensym) (quote-syntax here))]
+			[profile-key (datum->syntax-object #f profile-key (quote-syntax here))]
+			[register-profile-start register-profile-start]
+			[register-profile-done register-profile-done])
+	    (with-syntax ([rest 
+			   (insert-at-tail*
+			    (syntax (register-profile-done 'key start))
+			    bodies
+			    trans?)])
+	      (syntax
+	       (let ([start (register-profile-start 'key)])
+		 (with-continuation-mark 'profile-key 'key
+		   (begin . rest))))))))
+      
+      (define (insert-at-tail* e exprs trans?)
+	(let ([new
+	       (rebuild exprs
+			(let loop ([exprs exprs])
+			  (if (stx-null? (stx-cdr exprs))
+			      (list (cons (stx-car exprs)
+					  (insert-at-tail e (stx-car exprs) trans?)))
+			      (loop (stx-cdr exprs)))))])
+	  (if (syntax? exprs)
+	      (certify exprs new)
+	      new)))
+	  
+      (define (insert-at-tail se sexpr trans?)
+        (with-syntax ([expr sexpr]
+                      [e se])
+          (kernel-syntax-case sexpr trans?
+	    ;; negligible time to eval
+	    [id
+	     (identifier? sexpr)
+	     (syntax (begin e expr))]
+	    [(quote _) (syntax (begin e expr))]
+	    [(quote-syntax _) (syntax (begin e expr))]
+	    [(#%datum . d) (syntax (begin e expr))]
+	    [(#%top . d) (syntax (begin e expr))]
+	    
+	    ;; No tail effect, and we want to account for the time
+	    [(lambda . _) (syntax (begin0 expr e))]
+	    [(case-lambda . _) (syntax (begin0 expr e))]
+	    [(set! . _) (syntax (begin0 expr e))]
+
+	    [(let-values bindings . body)
+	     (insert-at-tail* se sexpr trans?)]
+	    [(letrec-values bindings . body)
+	     (insert-at-tail* se sexpr trans?)]
+	    
+	    [(begin . _)
+	     (insert-at-tail* se sexpr trans?)]
+	    [(with-continuation-mark . _)
+	     (insert-at-tail* se sexpr trans?)]
+	    
+	    [(begin0 body ...)
+	     (certify sexpr (syntax (begin0 body ... e)))]
+	    
+	    [(if test then)
+	     (certify
+	      sexpr
+	      (append-rebuild
+	       (rebuild sexpr (list (cons #'then (insert-at-tail se (syntax then) trans?))))
+	       #'(begin e (void))))]
+	    [(if test then else)
+	     ;; WARNING: e inserted twice!
+	     (certify
+	      sexpr
+	      (rebuild sexpr (list
+			      (cons #'then (insert-at-tail se (syntax then) trans?))
+			      (cons #'else (insert-at-tail se (syntax else) trans?)))))]
+	    
+	    [(#%app . rest)
+	     (if (stx-null? (syntax rest))
+		 ;; null constant
+		 (syntax (begin e expr))
+		 ;; application; exploit guaranteed left-to-right evaluation
+		 (insert-at-tail* se sexpr trans?))]
+	    
+	    [_else
+	     (error 'errortrace
+		    "unrecognized (non-top-level) expression form: ~e"
+		    (syntax-object->datum sexpr))])))
+      
+      (define (profile-annotate-lambda name expr clause bodys-stx trans?)
+	(let* ([bodys (stx->list bodys-stx)]
+	       [bodyl (map (lambda (e) (annotate e trans?))
+			   bodys)])
+	  (rebuild clause 
+		   (if (profiling-enabled)
+		       (let ([prof-expr (profile-point bodyl name expr trans?)])
+			 ;; Tell rebuild to replace first expressions with (void),
+			 ;; and replace the last expression with prof-expr:
+			 (let loop ([bodys bodys])
+			   (if (null? (cdr bodys))
+			       (list (cons (car bodys) prof-expr))
+			       (cons (cons (car bodys) #'(void))
+				     (loop (cdr bodys))))))
+		       ;; Map 1-to-1:
+		       (map cons bodys bodyl)))))
+      
+      (define (keep-lambda-properties orig new)
+        (let ([p (syntax-property orig 'method-arity-error)]
+	      [p2 (syntax-property orig 'inferred-name)])
+          (let ([new (if p
+			 (syntax-property new 'method-arity-error p)
+			 new)])
+	    (if p2
+		(syntax-property new 'inferred-name p2)
+		new))))
+      
+      (define (annotate-let expr trans? varss-stx rhss-stx bodys-stx)
+        (let ([varss (syntax->list varss-stx)]
+              [rhss (syntax->list rhss-stx)]
+              [bodys (syntax->list bodys-stx)])
+	  (let ([rhsl (map
+		       (lambda (vars rhs)
+			    (annotate-named
+			     (syntax-case vars ()
+			       [(id)
+				(syntax id)]
+			       [_else #f])
+			     rhs
+			     trans?))
+			  varss 
+			  rhss)]
+		[bodyl (map
+			(lambda (body)
+			  (annotate body trans?))
+			bodys)])
+	    (rebuild expr (append (map cons bodys bodyl)
+				  (map cons rhss rhsl))))))
+      
+      (define (annotate-seq expr bodys-stx annotate trans?)
+        (let* ([bodys (syntax->list bodys-stx)]
+	       [bodyl (map (lambda (b)
+			     (annotate b trans?))
+			   bodys)])
+	  (rebuild expr (map cons bodys bodyl))))
+
+      (define orig-inspector (current-inspector))
+
+      (define (certify orig new)
+	(syntax-recertify new orig orig-inspector #f))
+
+      (define (rebuild expr replacements)
+	(let loop ([expr expr]
+		   [same-k (lambda () expr)]
+		   [diff-k (lambda (x) x)])
+	  (let ([a (assq expr replacements)])
+	    (if a
+		(diff-k (cdr a))
+		(cond
+		 [(pair? expr) (loop (car expr)
+				     (lambda ()
+				       (loop (cdr expr)
+					     same-k
+					     (lambda (y)
+					       (diff-k (cons (car expr) y)))))
+				     (lambda (x)
+				       (loop (cdr expr)
+					     (lambda ()
+					       (diff-k (cons x (cdr expr))))
+					     (lambda (y)
+					       (diff-k (cons x y))))))]
+		 [(vector? expr) 
+		  (loop (vector->list expr)
+			same-k
+			(lambda (x) (diff-k (list->vector x))))]
+		 [(box? expr) (loop (unbox expr)
+				    same-k
+				    (lambda (x)
+				      (diff-k (box x))))]
+		 [(syntax? expr) (if (identifier? expr)
+				     (same-k)
+				     (loop (syntax-e expr)
+					   same-k
+					   (lambda (x)
+					     (diff-k
+					      (datum->syntax-object
+					       expr
+					       x
+					       expr)))))]
+		 [else (same-k)])))))
+
+      (define (append-rebuild expr end)
+	(cond
+	 [(syntax? expr)
+	  (datum->syntax-object expr (append-rebuild (syntax-e expr) end) expr)]
+	 [(pair? expr)
+	  (cons (car expr) (append-rebuild (cdr expr) end))]
+	 [(null? expr)
+	  (list end)]
+	 [else
+	  (error 'append-rebuild "shouldn't get here")]))
+
+      (define (one-name names-stx)
+	(let ([l (syntax->list names-stx)])
+	  (and (pair? l)
+	       (null? (cdr l))
+	       (car l))))
+
+      (define (make-annotate top? name)
+        (lambda (expr trans?)
+	  (test-coverage-point 
+	   (kernel-syntax-case expr trans?
+	     [_
+	      (identifier? expr)
+	      (let ([b ((if trans? identifier-binding identifier-transformer-binding) expr)])
+		(cond
+		 [(eq? 'lexical b)
+		  ;; lexical variable - no error possile
+		  expr]
+		 [(and (pair? b) (eq? '#%kernel (car b)))
+		  ;; built-in - no error possible
+		  expr]
+		 [else
+		  ;; might be undefined/uninitialized
+		  (with-mark expr expr)]))]
+	     
+	     [(#%top . id)
+	      ;; might be undefined/uninitialized
+	      (with-mark expr expr)]
+	     [(#%datum . _)
+	      ;; no error possible
+	      expr]
+	     
+	     ;; Can't put annotation on the outside
+	     [(define-values names rhs)
+	      top?
+	      (let ([marked (with-mark expr
+				       (annotate-named
+					(one-name #'names)
+					(syntax rhs)
+					trans?))])
+		(certify
+		 expr
+		 (rebuild expr (list (cons #'rhs marked)))))]
+	     [(begin . exprs)
+	      top?
+	      (certify
+	       expr
+	       (annotate-seq expr
+			     (syntax exprs)
+			     annotate-top trans?))]
+	     [(define-syntaxes (name ...) rhs)
+	      top?
+	      (let ([marked (with-mark expr
+				       (annotate-named
+					(one-name #'(name ...))
+					(syntax rhs)
+					#t))])
+		(certify
+		 expr
+		 (rebuild expr (list (cons #'rhs marked)))))]
+
+	     [(define-values-for-syntax (name ...) rhs)
+	      top?
+	      (let ([marked (with-mark expr
+				       (annotate-named
+					(one-name (syntax (name ...)))
+					(syntax rhs)
+					#t))])
+		(certify
+		 expr
+		 (rebuild expr (list (cons #'rhs marked)))))]
+	     
+	     ;; Just wrap body expressions
+	     [(module name init-import (#%plain-module-begin body ...))
+	      top?
+	      (let ([bodys (syntax->list (syntax (body ...)))])
+		(let ([bodyl (map (lambda (b)
+				    (annotate-top b trans?))
+				  bodys)])
+		  (certify
+		   expr
+		   (rebuild expr (map cons bodys bodyl)))))]
+	     
+	     ;; No way to wrap
+	     [(require i ...) expr]
+	     [(require-for-syntax i ...) expr]
+	     [(require-for-template i ...) expr]
+	     ;; No error possible (and no way to wrap)
+	     [(provide i ...) expr]
+	     
+	     ;; No error possible
+	     [(quote _)
+	      expr]
+	     [(quote-syntax _)
+	      expr]
+	     
+	     ;; Wrap body, also a profile point
+	     [(lambda args . body)
+	      (certify
+	       expr
+	       (keep-lambda-properties
+		expr
+		(profile-annotate-lambda name expr expr (syntax body) 
+					 trans?)))]
+	     [(case-lambda clause ...)
+	      (with-syntax ([([args . body] ...)
+			     (syntax (clause ...))])
+		(let* ([clauses (syntax->list (syntax (clause ...)))]
+		       [clausel
+			(map
+			 (lambda (body clause) (profile-annotate-lambda name expr clause body trans?))
+			 (syntax->list (syntax (body ...)))
+			 clauses)])
+		  (certify
+		   expr
+		   (keep-lambda-properties
+		    expr
+		    (rebuild expr (map cons clauses clausel))))))]
+	     
+	     ;; Wrap RHSs and body
+	     [(let-values ([vars rhs] ...) . body)
+	      (with-mark expr 
+			 (certify
+			  expr
+			  (annotate-let expr trans?
+					(syntax (vars ...))
+					(syntax (rhs ...))
+					(syntax body))))]
+	     [(letrec-values ([vars rhs] ...) . body)
+	      (with-mark expr 
+			 (certify
+			  expr
+			  (annotate-let expr trans?
+					(syntax (vars ...))
+					(syntax (rhs ...))
+					(syntax body))))]
+	     
+	     ;; Wrap RHS
+	     [(set! var rhs)
+	      (let ([new-rhs (annotate-named 
+			      (syntax var)
+			      (syntax rhs)
+			      trans?)])
+		;; set! might fail on undefined variable, or too many values:
+		(with-mark expr 
+			   (certify
+			    expr
+			    (rebuild expr (list (cons #'rhs new-rhs))))))]
+	     
+	     ;; Wrap subexpressions only
+	     [(begin . body)
+	      (with-mark expr
+			 (certify
+			  expr
+			  (annotate-seq expr (syntax body) 
+					annotate trans?)))]
+	     [(begin0 . body)
+	      (with-mark expr
+			 (certify
+			  expr
+			  (annotate-seq expr (syntax body) 
+					annotate trans?)))]
+	     [(if tst thn els)
+	      (let ([w-tst (annotate (syntax tst) trans?)]
+		    [w-thn (annotate (syntax thn) trans?)]
+		    [w-els (annotate (syntax els) trans?)])
+		(with-mark expr
+			   (certify
+			    expr
+			    (rebuild expr (list (cons #'tst w-tst)
+						(cons #'thn w-thn)
+						(cons #'els w-els))))))]
+	     [(if tst thn)
+	      (let ([w-tst (annotate (syntax tst) trans?)]
+		    [w-thn (annotate (syntax thn) trans?)])
+		(with-mark expr
+			   (certify
+			    expr
+			    (rebuild expr (list (cons #'tst w-tst)
+						(cons #'thn w-thn))))))]
+	     [(with-continuation-mark . body)
+	      (with-mark expr
+			 (certify
+			  expr
+			  (annotate-seq expr (syntax body) 
+					annotate trans?)))]
+
+	     ;; Wrap whole application, plus subexpressions
+	     [(#%app . body)
+	      (cond
+	       [(stx-null? (syntax body))
+		;; It's a null:
+		expr]
+	       [(syntax-case* expr (#%app void) (if trans? module-transformer-identifier=? module-identifier=?)
+		  [(#%app void) #t]
+		  [_else #f])
+		;; It's (void):
+		expr]
+	       [else
+		(with-mark expr
+			   (certify
+			    expr
+			    (annotate-seq expr (syntax body) 
+					  annotate trans?)))])]
+
+	     [_else
+	      (error 'errortrace
+		     "unrecognized expression form~a: ~e"
+		     (if top? " at top-level" "")
+		     (syntax-object->datum expr))])
+	   expr)))
+      
+      (define annotate (make-annotate #f #f))
+      (define annotate-top (make-annotate #t #f))
+      (define annotate-named (lambda (name expr trans?) ((make-annotate #t name) expr trans?))))))
diff --git a/collects/errortrace/zo-compile.ss b/collects/errortrace/zo-compile.ss
new file mode 100644
index 0000000000..0ef5cf4997
--- /dev/null
+++ b/collects/errortrace/zo-compile.ss
@@ -0,0 +1,15 @@
+
+(module zo-compile mzscheme
+  (require "errortrace-lib.ss")
+  
+  (provide zo-compile)
+
+  (define zo-compile
+    (let ([orig (current-compile)])
+      (lambda (stx immediate-eval?)
+	(if (null? (use-compiled-file-paths))
+	    (orig stx immediate-eval?)
+	    (orig (errortrace-annotate stx) immediate-eval?))))))
+
+
+
diff --git a/collects/ffi/crypt.ss b/collects/ffi/crypt.ss
new file mode 100644
index 0000000000..7614a0c067
--- /dev/null
+++ b/collects/ffi/crypt.ss
@@ -0,0 +1,65 @@
+(module crypt mzscheme
+
+(require (lib "foreign.ss")) (unsafe!)
+
+(define libcrypt (ffi-lib "libcrypt"))
+
+(provide crypt)
+(define crypt
+  (get-ffi-obj "crypt" libcrypt (_fun _string _string -> _bytes)))
+
+(define set-key*
+  (get-ffi-obj "setkey" libcrypt (_fun _bytes -> _void)))
+(define encrypt*
+  (get-ffi-obj "encrypt" libcrypt (_fun _bytes _bool -> _void)))
+
+;; see the encrypt(3) man page for the following
+
+(define (*crypt str key flag)
+  (set-key* key)
+  (let ([str (string8->keystring str)])
+    (encrypt* str flag)
+    (keystring->string8 str)))
+
+(provide encrypt decrypt)
+(define (encrypt str key) (*crypt (string->bytes/utf-8 str) key #f))
+(define (decrypt str key) (bytes->string/utf-8 (*crypt str key #t)))
+
+(define (string8->keystring str)
+  (let* ([len (bytes-length str)]
+         [str (cond
+               [(> len 8) (subbytes str 0 8)]
+               [(< len 8) (bytes-append str (make-bytes (- 8 len) 32))]
+               [else str])]
+         [bin (apply string-append
+                     (map (lambda (x)
+                            (let* ([bin (format "~b" x)]
+                                   [len (string-length bin)])
+                              (if (< (string-length bin) 8)
+                                (string-append (make-string (- 8 len) #\0) bin)
+                                bin)))
+                          (bytes->list str)))])
+    (list->bytes
+     (map (lambda (x)
+            (case x
+              [(#\0) 0] [(#\1) 1]
+              [else (error 'string8->keystring "something bad happened")]))
+          (string->list bin)))))
+
+(define (keystring->string8 bin)
+  (unless (= 64 (bytes-length bin))
+    (error 'keystring->string8 "bad input size: ~s" bin))
+  (let ([bin (apply string (map (lambda (x)
+                                  (case x
+                                    [(0) #\0] [(1) #\1]
+                                    [else (error 'keystring->string8
+                                                 "something bad happened")]))
+                                (bytes->list bin)))])
+    (apply bytes
+           (let loop ([n (- 64 8)] [r '()])
+             (if (< n 0)
+               r
+               (loop (- n 8) (cons (string->number (substring bin n (+ n 8)) 2)
+                                   r)))))))
+
+)
diff --git a/collects/ffi/esd.ss b/collects/ffi/esd.ss
new file mode 100644
index 0000000000..c991a236f8
--- /dev/null
+++ b/collects/ffi/esd.ss
@@ -0,0 +1,80 @@
+(module esd mzscheme
+
+(require (lib "foreign.ss")) (unsafe!)
+
+(define libesd (ffi-lib "libesd"))
+
+;; Use this type to properly close the esd channel
+(define-struct esd (num))
+(define _esd
+  (make-ctype _int esd-num
+    (lambda (e)
+      (if (and (integer? e) (<= 0 e))
+        (let ([new (make-esd e)])
+          (register-finalizer new esd-close)
+          new)
+        (error '_esd "expecting an integer >=0, got: ~e" e)))))
+
+;; Use this type to free collected samples
+(define-struct sample (num))
+(define _sample
+  (make-ctype _int sample-num
+    (lambda (s)
+      (if (and (integer? s) (<= 0 s))
+        (let ([new (make-sample s)])
+          (register-finalizer
+           new
+           (lambda (x)
+             (esd-sample-free x)))
+          new)
+        (error '_sample "expecting an integer >=0, got: ~e" s)))))
+;; similar but no finalizer
+(define _sample* (make-ctype _int sample-num make-sample))
+
+(provide esd-open-sound)
+(define esd-open-sound ; -> esd
+  (let ([f (get-ffi-obj "esd_open_sound" libesd (_fun _string -> _esd))])
+    (lambda host? (f (and (pair? host?) (car host?))))))
+
+(define (with-default ffi)
+  (lambda args
+    (if (and (pair? args) (esd? (car args)))
+      (apply ffi args)
+      (apply ffi (default-esd) args))))
+
+(define (c-name x)
+  (regexp-replaces x '((#rx"-" "_") (#rx"[*?]$" ""))))
+
+(define-syntax defesd
+  (syntax-rules (: _esd)
+    [(_ name : [_esd] type ...)
+     (define name
+       (with-default
+        (get-ffi-obj (c-name 'name) libesd (_fun _esd type ...))))]
+    [(_ name : type ...)
+     (define name
+       (get-ffi-obj (c-name 'name) libesd (_fun type ...)))]))
+
+(define-syntax defesd*
+  (syntax-rules ()
+    [(_ name x ...) (begin (provide name) (defesd name x ...))]))
+
+(defesd  esd-close        : [_esd] -> _int)
+(defesd* esd-send-auth    : [_esd] -> _int)
+(defesd* esd-lock         : [_esd] -> _int)
+(defesd* esd-unlock       : [_esd] -> _int)
+(defesd* esd-standby      : [_esd] -> _int)
+(defesd* esd-resume       : [_esd] -> _int)
+(defesd* esd-get-latency  : [_esd] -> _int)
+(defesd* esd-play-file : (prefix : _string) _file (fallback? : _bool) -> _int)
+(defesd* esd-file-cache   : [_esd] (prefix : _string) _file -> _sample)
+(defesd* esd-sample-getid : [_esd] _string -> _sample*)
+(defesd  esd-sample-free  : [_esd] _sample -> _int)
+(defesd* esd-sample-play  : [_esd] _sample -> _int)
+(defesd* esd-sample-loop  : [_esd] _sample -> _int)
+(defesd* esd-sample-stop  : [_esd] _sample -> _int)
+(defesd* esd-sample-kill  : [_esd] _sample -> _int)
+(provide default-esd)
+(define default-esd (make-parameter (esd-open-sound) esd?))
+
+)
diff --git a/collects/ffi/examples/crypt.ss b/collects/ffi/examples/crypt.ss
new file mode 100755
index 0000000000..a134b887c7
--- /dev/null
+++ b/collects/ffi/examples/crypt.ss
@@ -0,0 +1,20 @@
+#!/bin/sh
+#|
+exec mzscheme -r "$0" "$@"
+|#
+
+(require (lib "crypt.ss" "ffi"))
+
+(define passwd "foo")
+(define salt "xz")
+(printf ">>> crypt(~s,~s) = ~s\n" passwd salt (crypt passwd salt))
+
+;; md5-based version
+(set! salt "$1$somesalt$")
+(printf ">>> crypt(~s,~s) = ~s\n" passwd salt (crypt passwd salt))
+
+(newline)
+(define foo "foo bar")
+(define key (string->bytes/utf-8 "my key"))
+(printf ">>> ~s --encrypt--> ~s --decrypt--> ~s\n"
+        foo (encrypt foo key) (decrypt (encrypt foo key) key))
diff --git a/collects/ffi/examples/esd.ss b/collects/ffi/examples/esd.ss
new file mode 100755
index 0000000000..65777524b5
--- /dev/null
+++ b/collects/ffi/examples/esd.ss
@@ -0,0 +1,32 @@
+#!/bin/sh
+#|
+exec mzscheme -r "$0" "$@"
+|#
+
+(require (lib "esd.ss" "ffi"))
+
+(printf "default = ~s\n" (default-esd))
+(printf "latency = ~s\n" (esd-get-latency))
+(printf "standby -> ~s\n" (esd-standby))
+(sleep 1)
+(printf "resume  -> ~s\n" (esd-resume))
+
+(printf "Normal play...\n")
+(esd-play-file "esd.ss" "~/stuff/sounds/Eeeooop.wav" #t)
+(sleep 1)
+
+(printf "Sample play...\n")
+(let ((sample-id (esd-file-cache "foooo" "~/stuff/sounds/Eeeooop.wav")))
+  (printf ">>> sample = ~s\n" sample-id)
+  (printf ">>> getid -> ~s\n"
+          (esd-sample-getid "foooo:/home/eli/stuff/sounds/Eeeooop.wav"))
+  (printf "playing...\n")
+  (esd-sample-play sample-id)
+  (sleep 1)
+  (printf "looping...\n")
+  (esd-sample-loop sample-id)
+  (sleep 3)
+  (printf "enough!\n")
+  (esd-sample-stop sample-id)
+  (sleep 1)
+  (printf "bye.\n"))
diff --git a/collects/ffi/examples/magick.ss b/collects/ffi/examples/magick.ss
new file mode 100755
index 0000000000..1deb975082
--- /dev/null
+++ b/collects/ffi/examples/magick.ss
@@ -0,0 +1,317 @@
+#!/bin/sh
+#|
+exec mzscheme -rg "$0" "$@"
+|#
+
+(require (lib "magick.ss" "ffi"))
+
+(define-syntax (test stx)
+  (syntax-case stx ()
+    [(_ (func arg ...))
+     (with-syntax ([(tmp ...) (generate-temporaries #'(arg ...))])
+       #'(let ([tmp arg] ...)
+           (printf ">>> ~s~s\n" 'func `(,tmp ...))
+           (let ([r (func tmp ...)])
+             (printf "      -> ~s\n" r)
+             r)))]))
+
+;; (test (MagickGetPackageName))
+;; (test (MagickGetCopyright))
+;; (test (MagickGetVersion))
+;; (test (MagickGetReleaseDate))
+;; (test (MagickGetQuantumDepth))
+;; (test (MagickQueryConfigureOptions "CO*"))
+;; (test (MagickQueryFonts "Cou*"))
+;; (test (MagickQueryFormats "J*"))
+;; (test (MagickGetHomeURL))
+
+;; (define w (test (NewMagickWand)))
+;; (test (MagickGetImageFilename w))
+;; (test (MagickReadImage w "~/html/images/eli.jpg"))
+
+(define w (test (MagickReadImage "~/html/images/eli.jpg")))
+;; (test (MagickGetImageFilename w))
+
+;; (test (MagickGetImageFilename w))
+;; (test (MagickGetImageFormat w))
+;; (test (MagickGetImageCompression w))
+;; (test (MagickGetImageDispose w))
+;; (test (MagickGetImageType w))
+;; (test (MagickGetImageInterlaceScheme w))
+;; (test (MagickGetImageIndex w))
+;; (test (MagickGetImageSize w))
+;; (test (MagickGetImageSignature w))
+;; (test (MagickBlurImage w 2.0 1.0))
+;; ;; (test (MagickReadImage w "~/html/images/eeli.jpg"))
+;; ;; (test (MagickGetException w))
+;; (test (MagickSwirlImage w 90.0))
+;; (test (MagickWaveImage w 4.0 40.0))
+;; (test (MagickCharcoalImage w 5.0 0.7))
+;; (test (MagickGetImageCompose w))
+;; (test (MagickGetImageColorspace w))
+;; (test (MagickCommentImage w "This is my test image"))
+;; (test (MagickWriteImage w "~/tmp/x.jpg"))
+;; (test (MagickDisplayImage w #f))
+;; (test (MagickDescribeImage w))
+;; (test (MagickGetImageWidth w))
+;; (test (MagickGetImageHeight w))
+;; (test (MagickGetImageChannelDepth w 'RedChannel))
+;; (test (MagickGetImageExtrema w))
+;; (test (MagickGetImageChannelExtrema w 'RedChannel))
+;; (test (MagickGetImageChannelMean w 'RedChannel))
+;; (test (MagickGetImageColors w))
+;; (test (MagickGetImageDelay w))
+;; (test (MagickSetImageDelay w 20))
+;; (test (MagickGetImageDelay w))
+;; (test (MagickGetImageDepth w))
+;; (test (MagickSetImageDepth w 2))
+;; (test (MagickGetImageDepth w))
+;; (test (MagickGetImageIterations w))
+;; (test (MagickSetImageIterations w 4))
+;; (test (MagickGetImageIterations w))
+;; (test (MagickGetSamplingFactors w))
+;; (test (MagickSetSamplingFactors w '(2.0 1.0 0.5)))
+;; (test (MagickGetSamplingFactors w))
+;; (test (MagickGetImageRenderingIntent w))
+;; (test (MagickSetImageRenderingIntent w 'SaturationIntent))
+;; (test (MagickGetImageRenderingIntent w))
+;; (test (MagickGetImageUnits w))
+;; (test (MagickSetImageUnits w 'PixelsPerInchResolution))
+;; (test (MagickGetImageUnits w))
+;; (test (MagickGetImageVirtualPixelMethod w))
+;; (test (MagickSetImageVirtualPixelMethod w 'EdgeVirtualPixelMethod))
+;; (test (MagickGetImageVirtualPixelMethod w))
+;; (test (MagickGetImageWhitePoint w))
+;; (test (MagickSetImageWhitePoint w 3.0 4.0))
+;; (test (MagickGetImageWhitePoint w))
+;; (test (MagickGetImageResolution w))
+;; (test (MagickSetImageResolution w 33.0 33.0))
+;; (test (MagickGetImageResolution w))
+;; (test (MagickGetSize w))
+;; (test (MagickSetSize w 20 20))
+;; (test (MagickGetSize w))
+;; (test (MagickGetImageProfile w "ICC"))
+
+;; (test (MagickAdaptiveThresholdImage w 2 2 0))
+;; (test (MagickAddNoiseImage w 'LaplacianNoise))
+;; (test (MagickEmbossImage w 1.0 0.5))
+;; (test (MagickEvaluateImage w 'MaxEvaluateOperator 30768.0))
+;; (test (MagickEvaluateImage w 'MinEvaluateOperator 34768.0))
+;; (test (MagickEvaluateImageChannel w 'RedChannel 'MaxEvaluateOperator 28768.0))
+;; (test (MagickEvaluateImageChannel w 'RedChannel 'MinEvaluateOperator 36768.0))
+;; (test (MagickGetImageGamma w))
+;; (test (MagickGammaImage w 0.5))
+;; (test (MagickSetImageGamma w 0.5))
+;; (test (MagickGetImageGamma w))
+;; (test (MagickGaussianBlurImage w 5.0 2.0))
+;; (test (MagickGaussianBlurImageChannel w 'RedChannel 1.0 0.1))
+;; (test (MagickGetImageRedPrimary w))
+;; (test (MagickSetImageRedPrimary w 20.0 20.0))
+;; (test (MagickGetImageRedPrimary w))
+;; (test (MagickTransformImage w "120x120+10+10" "100x100+0+0"))
+;; (test (MagickThresholdImage w 32768.0))
+;; (test (MagickThresholdImageChannel w 'RedChannel 32768.0))
+;; (test (MagickSpreadImage w 2.0))
+;; (test (MagickOilPaintImage w 3.0))
+;; (test (MagickSpliceImage w 100 100 50 50))
+;; (test (MagickSolarizeImage w 2.0))
+;; (test (MagickShaveImage w 20 50))
+;; (test (MagickSharpenImage w 10.0 9.0))
+;; (test (MagickPosterizeImage w 2 #t))
+;; (test (MagickContrastImage w 20))
+;; (test (MagickEdgeImage w 5.0))
+;; (test (MagickImplodeImage w 0.5))
+
+;; (test (MagickConvolveImage
+;;        w '(( 0.0 -1.0  0.0) ; sharpen
+;;            (-1.0  5.0 -1.0)
+;;            ( 0.0 -1.0  0.0))))
+;; (test (MagickConvolveImage ; sharpen++
+;;        w '((-1.0 -1.0 -1.0)
+;;            (-1.0  9.0 -1.0)
+;;            (-1.0 -1.0 -1.0))))
+;; (test (MagickConvolveImage ; blur
+;;        w '(( 1.0  1.0  1.0)
+;;            ( 1.0  1.0  1.0)
+;;            ( 1.0  1.0  1.0))))
+;; (test (MagickConvolveImage ; edge enhance
+;;        w '(( 0.0  0.0  0.0)
+;;            (-1.0  1.0  0.0)
+;;            ( 0.0  0.0  0.0))))
+;; (test (MagickConvolveImage ; edge enhance++
+;;        w '((-1.0  0.0  1.0)
+;;            (-1.0  0.0  1.0)
+;;            (-1.0  0.0  1.0))))
+;; (test (MagickConvolveImage ; edge detect
+;;        w '(( 0.0  1.0  0.0)
+;;            ( 1.0 -4.0  1.0)
+;;            ( 0.0  1.0  0.0))))
+;; (test (MagickConvolveImage ; emboss
+;;        w '((-2.0 -1.0  0.0)
+;;            (-1.0  1.0  1.0)
+;;            ( 0.0  1.0  2.0))))
+;; (test (MagickConvolveImageChannel
+;;        w 'RedChannel '((1.0 0.0  0.0 0.0 1.0)
+;;                        (0.0 0.0  0.0 0.0 0.0)
+;;                        (0.0 0.0 -1.0 0.0 0.0)
+;;                        (0.0 0.0  0.0 0.0 0.0)
+;;                        (1.0 0.0  0.0 0.0 1.0))))
+
+;; (define pixels (test (MagickGetImagePixels w 0 0 40 40 "RGB" 'ShortPixel)))
+;; (test (MagickSetImagePixels
+;;        w 0 0 "RGB" 'ShortPixel
+;;        (let ([pixels (map (lambda (x) (append x x))
+;;                           pixels)])
+;;          (append pixels
+;;                  (map (lambda (row)
+;;                         (map (lambda (pixel)
+;;                                (list (cadr pixel) (caddr pixel) (car pixel))
+;;                                ;; (map (lambda (v) (- 65535 v)) pixel)
+;;                                )
+;;                              row))
+;;                       pixels)))))
+
+;; (test (MagickLabelImage w "FOO"))
+;; (test (MagickLevelImage w 20000.0 1.0 45535.0))
+;; (test (MagickMedianFilterImage w 2.0))
+;; (test (MagickModulateImage w 100.0 100.0 40.0))
+;; (test (MagickMotionBlurImage w 10.0 10.0 60.0))
+;; (test (MagickNegateImage w #f))
+;; (test (MagickNegateImageChannel w 'GreenChannel #f))
+;; (test (MagickNormalizeImage w))
+;; (test (MagickRaiseImage w 10 10 20 20 #f))
+
+;; (MagickMinifyImage w) (MagickMinifyImage w) (MagickMinifyImage w)
+;; (test (MagickResampleImage w 576.0 576.0 'UndefinedFilter 1.0))
+;; (test (MagickResampleImage w 576.0 576.0 'BoxFilter 1.0))
+;; (test (MagickResampleImage w 576.0 576.0 'TriangleFilter 1.0))
+;; (test (MagickResampleImage w 576.0 576.0 'HermiteFilter 1.0))
+;; (test (MagickResampleImage w 576.0 576.0 'HanningFilter 1.0))
+;; (test (MagickResampleImage w 576.0 576.0 'HammingFilter 1.0))
+;; (test (MagickResampleImage w 576.0 576.0 'BlackmanFilter 1.0))
+;; (test (MagickResampleImage w 576.0 576.0 'GaussianFilter 1.0))
+;; (test (MagickResampleImage w 576.0 576.0 'QuadraticFilter 1.0))
+;; (test (MagickResampleImage w 576.0 576.0 'CubicFilter 1.0))
+;; (test (MagickResampleImage w 576.0 576.0 'CatromFilter 1.0))
+;; (test (MagickResampleImage w 576.0 576.0 'MitchellFilter 1.0))
+;; (test (MagickResampleImage w 576.0 576.0 'LanczosFilter 1.0))
+;; (test (MagickResampleImage w 576.0 576.0 'BesselFilter 1.0))
+;; (test (MagickResampleImage w 576.0 576.0 'SincFilter 1.0))
+
+;; (test (MagickOpaqueImage w "black" "yellow" 20000.0))
+;; (test (MagickColorFloodfillImage w "yellow" 20000.0 "black" 0 0))
+;; (test (MagickColorFloodfillImage w "yellow" 20000.0 #f 0 0))
+;; (test (MagickColorFloodfillImage w '(65535 0 0) 20000.0 "black" 0 0))
+;; (test (MagickColorFloodfillImage w '(65535 0 0 32737) 20000.0 "black" 0 0))
+
+;; (test (MagickTransparentImage w "black" 16384 20000.0))
+;; (test (MagickWriteImage w "~/tmp/x.png"))
+
+;; (test (MagickResetIterator w))
+;; (test (MagickGetImageProfile w "ICC"))
+;; (test (MagickSetImageProfile w "ICC" "foo"))
+;; (test (MagickGetImageProfile w "ICC"))
+
+;; (test (MagickGetImageBackgroundColor w))
+
+;; (test (MagickDisplayImage w))
+
+;; (for-each
+;;  (lambda (p) (MagickDisplayImage (test (MagickPreviewImages w p))))
+;;  '(UndefinedPreview RotatePreview ShearPreview RollPreview HuePreview
+;;    SaturationPreview BrightnessPreview GammaPreview SpiffPreview DullPreview
+;;    GrayscalePreview QuantizePreview DespecklePreview ReduceNoisePreview
+;;    AddNoisePreview SharpenPreview BlurPreview ThresholdPreview
+;;    EdgeDetectPreview SpreadPreview SolarizePreview ShadePreview RaisePreview
+;;    SegmentPreview SwirlPreview ImplodePreview WavePreview OilPaintPreview
+;;    CharcoalDrawingPreview JPEGPreview))
+
+;; (test (MagickDisplayImage
+;;        (MagickFxImageChannel w 'AllChannels "(p[-4,-4].r+p[4,4].g)/2")))
+
+;; (test (MagickMagnifyImage w))
+;; (let ([ww (CloneMagickWand w)])
+;;   (test (MagickMinifyImage ww))
+;;   (test (MagickMinifyImage ww))
+;;   (test (MagickMinifyImage ww))
+;;   (test (MagickDisplayImage (MagickTextureImage w ww))))
+
+;; (test (MagickChopImage w 100 100 10 10))
+;; (test (MagickCropImage w 100 100 10 10))
+;; (test (MagickDisplayImage w))
+
+;; (define w1 (test (CloneMagickWand w)))
+;; (test (MagickBlurImage w1 1.0 0.18))
+;; (define t (cadr (test (MagickCompareImageChannels
+;;                        w w1 'RedChannels 'MeanSquaredErrorMetric))))
+;; (test (MagickDisplayImage t))
+
+;; (test (MagickReadImage w "~/html/images/EliRegina.jpg"))
+;; (define morph (test (MagickMorphImages w 20)))
+;; (test (MagickWriteImage morph "~/tmp/x.gif"))
+;; (MagickAnimateImages morph)
+
+;; (let ([x (test (MagickWriteImageBlob w))])
+;;   (with-output-to-file "~/tmp/x" (lambda () (display x)) 'truncate)
+;;   (let ([ww (NewMagickWand)])
+;;     (test (MagickReadImageBlob ww x))
+;;     (MagickDisplayImage ww)))
+
+;; (define w (test (NewMagickWand)))
+;; (test (MagickReadImage w "~/html/images/spinlambda.gif"))
+;; (test (MagickDisplayImage (test (MagickAppendImages w #f))))
+;; (test (MagickDisplayImage (MagickAverageImages w)))
+;; (test (MagickDisplayImage (test (MagickDeconstructImages w))))
+;; (MagickAnimateImages w)
+
+;; (let ([y (NewPixelWand "yellow")]
+;;       [c (test (PixelGetQuantumColor "yellow"))]
+;;       [r (NewPixelWand "red")]
+;;       [rgb (lambda (p)
+;;              (map (lambda (f) (f p))
+;;                   (list PixelGetRedQuantum
+;;                         PixelGetGreenQuantum
+;;                         PixelGetBlueQuantum)))])
+;;   (printf ">>> y = ~s\n" (rgb y))
+;;   (printf ">>> r1 = ~s\n" (rgb r))
+;;   (PixelSetQuantumColor r c)
+;;   (printf ">>> r2 = ~s\n" (rgb r)))
+
+;; (define i (test (NewPixelRegionIterator w 0 0 10 10)))
+;; (test (PixelSetIteratorRow i 5))
+;; (test (map PixelGetRedQuantum (PixelGetNextRow i)))
+;; (test (map PixelGetRedQuantum (PixelGetNextRow i)))
+;; (test (map PixelGetRedQuantum (PixelGetNextRow i)))
+
+(define d (test (NewDrawingWand)))
+;; (test (DrawGetTextEncoding d))
+;; (test (MagickQueryFonts "Cou*"))
+(test (DrawSetFont d "Courier-Bold"))
+(test (DrawGetFont d))
+(test (DrawSetFontSize d 96.0))
+(test (DrawSetFontStretch d 'UltraCondensedStretch))
+(test (DrawSetFontStyle d 'ObliqueStyle))
+(test (DrawSetFontWeight d 24))
+(test (DrawSetGravity d 'CenterGravity))
+(test (DrawGetStrokeDashArray d))
+(test (DrawSetStrokeDashArray d '(20.0 20.0)))
+(test (DrawGetStrokeDashArray d))
+(test (DrawSetStrokeColor d "red"))
+(test (DrawSetStrokeAntialias d #t))
+(test (DrawSetStrokeWidth d 5.0))
+(test (DrawSetStrokeLineCap d 'RoundCap))
+(test (DrawSetStrokeOpacity d 0.5))
+;; (test (DrawLine d 0.0 0.0 200.0 200.0))
+(define line '((10.0 10.0) (100.0 100.0) (100.0 10.0) (50.0 20.0)))
+;; (test (DrawPolyline d line))
+;; (test (DrawPolygon d line))
+;; (test (DrawBezier d line))
+;; (test (DrawLine d  0.0 0.0 100.0 100.0))
+;; (test (DrawLine d  5.0 0.0 105.0 100.0))
+;; (test (DrawLine d 10.0 0.0 110.0 100.0))
+(test (DrawAffine d '(0.0 1.0 1.0 0.5 0.0 0.0)))
+(test (DrawAnnotation d 0.0 0.0 "FOO"))
+;; (test (DrawArc d 0.0 0.0 100.0 100.0 0.0 270.0))
+;; (test (DrawCircle d 50.0 50.0 50.0 0.0))
+(test (MagickDrawImage w d))
+(test (MagickDisplayImage w))
diff --git a/collects/ffi/examples/sndfile.ss b/collects/ffi/examples/sndfile.ss
new file mode 100755
index 0000000000..98460546d5
--- /dev/null
+++ b/collects/ffi/examples/sndfile.ss
@@ -0,0 +1,34 @@
+#!/bin/sh
+#|
+exec mzscheme -r "$0" "$@"
+|#
+
+(require (lib "sndfile.ss" "ffi"))
+
+;; (require (lib "swindle.ss" "swindle"))
+
+(define (add-half x y)
+  (/ (+ x (* y 0.5)) 1.5))
+
+(define (repeated-list x n)
+  (let loop ([n n] [r '()])
+    (if (zero? n) r (loop (sub1 n) (cons x r)))))
+
+(let-values ([(data meta) (read-sound* "x.wav")])
+  (printf ">>> data-length: ~s\n>>> meta: ~s\n" (length data) meta)
+  (let* ([data data #;
+               (list-of (list (add-half (1st x) (1st y))
+                              (add-half (2nd x) (2nd y)))
+                 (x <- data
+                  and
+                  y <- (append (repeated-list (list 0.0 0.0) 11025) data)
+                  and
+                  i <- 0.1 0.12 ..))])
+    (printf "writing to y.wav\n")
+    (write-sound* "y.wav"
+                  ;data
+                  ;(append data (reverse data))
+                  (append data (reverse (map reverse data)))
+                  `((artist "Eli") (comment "Comment") (title "Title")
+                    (date "1/1/1999") (software "mzscheme")
+                    ,@meta))))
diff --git a/collects/ffi/examples/tcl.ss b/collects/ffi/examples/tcl.ss
new file mode 100755
index 0000000000..9861b61b0f
--- /dev/null
+++ b/collects/ffi/examples/tcl.ss
@@ -0,0 +1,26 @@
+#!/bin/sh
+#|
+exec mzscheme -r "$0" "$@"
+|#
+
+(require (lib "tcl.ss" "ffi"))
+
+(define (tcldemo . strs)
+  (for-each (lambda (s)
+              (printf "> ~a\n" s)
+              (with-handlers ([void (lambda (e)
+                                      (display (if (exn? e) (exn-message e) e)
+                                               (current-error-port))
+                                      (newline (current-error-port)))])
+                (printf "~a\n" (eval-tcl s))))
+            strs))
+
+(tcldemo "puts 123"
+         "puts $a"
+         "set a {this is some stupid string}"
+         "set b [list a a]"
+         "set c {[list $a $a]}"
+         "puts \"a = \\\"$a\\\"\""
+         "puts \"b = \\\"$b\\\"\""
+         "puts \"c = \\\"$c\\\"\""
+         "puts \"even better... \\\"[expr $c]\\\"\"")
diff --git a/collects/ffi/examples/xmmsctrl.ss b/collects/ffi/examples/xmmsctrl.ss
new file mode 100755
index 0000000000..260958b2d6
--- /dev/null
+++ b/collects/ffi/examples/xmmsctrl.ss
@@ -0,0 +1,56 @@
+#!/bin/sh
+#|
+exec mzscheme -r "$0" "$@"
+|#
+
+(require (prefix xmms- (lib "xmmsctrl.ss" "ffi")))
+
+(printf "version: ~s\n" (xmms-get-version))
+(printf "skin: ~s\n" (xmms-get-skin))
+(printf "volume: ~s\n" (xmms-get-volume))
+(printf "balance: ~s\n" (xmms-get-balance))
+(printf "number of tracks: ~s\n" (xmms-get-playlist-length))
+(printf "Track #10 file  = ~s\n" (xmms-get-playlist-file 10))
+(printf "Track #10 title = ~s\n" (xmms-get-playlist-title 10))
+(printf "Track #10 time  = ~s\n" (xmms-get-playlist-time 10))
+
+;; (define all-files
+;;   (let loop ((i (sub1 (xmms-get-playlist-length))) (files '()))
+;;     (if (< i 0)
+;;       files (loop (sub1 i) (cons (xmms-get-playlist-file i) files)))))
+;; (printf "Number of files: ~s\n" (length all-files))
+;; (sleep 1)
+;; (xmms-playlist (list (car all-files) (caddr all-files) (cadddr all-files)) #f)
+;; (sleep 1)
+;; (xmms-playlist all-files #f)
+;; (sleep 1)
+;; (xmms-stop)
+
+;; (let ([eq (xmms-get-eq)])
+;;   (xmms-set-eq (list 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0))
+;;   (sleep 1)
+;;   (xmms-set-eq eq)
+;;   (sleep 1))
+
+(xmms-set-playlist-pos 10)
+(printf "playing? -> ~s\n" (xmms-is-playing?))
+(xmms-play)
+
+(define t
+  (thread (lambda ()
+            (let loop ()
+              (printf ">>> ~s\n" (xmms-get-output-time)) (sleep .1) (loop)))))
+(define (back-sec)
+  (let ([t (- (xmms-get-output-time) 1000)])
+    (printf "Jumping to ~s\n" t)
+    (xmms-jump-to-time t)))
+(sleep 3) (back-sec) (sleep 3) (back-sec) (sleep 3) (back-sec) (sleep 3)
+(kill-thread t)
+
+(printf "playing? -> ~s\n" (xmms-is-playing?))
+(printf "pos -> ~s\n" (xmms-get-playlist-pos))
+(printf "info -> ~s\n" (xmms-get-info))
+(xmms-playlist-next)
+(sleep 1)
+(printf "pos -> ~s\n" (xmms-get-playlist-pos))
+(xmms-stop)
diff --git a/collects/ffi/examples/xosd.ss b/collects/ffi/examples/xosd.ss
new file mode 100755
index 0000000000..961904056f
--- /dev/null
+++ b/collects/ffi/examples/xosd.ss
@@ -0,0 +1,76 @@
+#!/bin/sh
+#|
+exec mzscheme -r "$0" "$@"
+|#
+
+(require (lib "xosd.ss" "ffi"))
+
+(define x (xosd-create))
+
+;; (xost-set-bar-length x 12)
+(xosd-set-pos            x 'middle)
+(xosd-set-align          x 'center)
+(xosd-set-shadow-offset  x 7)
+(xosd-set-outline-offset x 2)
+(xosd-set-colour         x "yellow")
+(xosd-set-shadow-colour  x "black")
+(xosd-set-outline-colour x "blue")
+(xosd-set-font           x "-adobe-courier-bold-r-*-*-34-*-*-*-*-*-*-*")
+
+(printf ">>> xosd=~s, lines=~s, colour=~s\n"
+        x (xosd-get-number-lines x) (xosd-get-colour x))
+
+(xosd-display-string x "Xosd Test")
+
+;; this doesn't work for some reason
+;; (xosd-set-timeout x 1)
+;; (xosd-wait-until-no-display x)
+
+(sleep 2)
+(xosd-set-timeout x 0)
+
+(let loop ([n 10])
+  (unless (zero? n)
+    (xosd-show x)
+    (sleep .05)
+    (xosd-hide x)
+    (sleep .05)
+    (loop (sub1 n))))
+
+(let ([f (lambda (disp)
+           (let loop ([n 100])
+             (when (> n 0) (disp x n) (sleep .1) (loop (- n 5)))))])
+  (xosd-set-bar-length x 10)
+  (f xosd-display-percentage)
+  (sleep 1)
+  (xosd-set-bar-length x 20)
+  (f xosd-display-slider)
+  (xosd-hide x)
+  (sleep 1)
+  (xosd-display-string x "FOO")
+  (f (lambda (x n)
+       (xosd-hide x) (xosd-set-vertical-offset x n) (xosd-show x)))
+  (f (lambda (x n)
+       (xosd-hide x) (xosd-set-vertical-offset x (- 100 n)) (xosd-show x)))
+  (f (lambda (x n)
+       (xosd-hide x) (xosd-set-vertical-offset x n) (xosd-show x)))
+  (f (lambda (x n)
+       (xosd-hide x) (xosd-set-vertical-offset x (- 100 n)) (xosd-show x))))
+(xosd-hide x)
+(sleep 1)
+
+(set! x (xosd-create 4))
+(xosd-set-pos   x 'middle)
+(xosd-set-align x 'center)
+(xosd-set-font  x "-adobe-courier-bold-r-*-*-25-*-*-*-*-*-*-*")
+(xosd-set-shadow-offset  x 7)
+(xosd-set-outline-offset x 2)
+(xosd-display-string x "This is the first line" 0)
+(xosd-display-string x "and the second line" 1)
+(xosd-display-string x "the third one" 2)
+(xosd-display-string x "and finally the fourth line" 3)
+(sleep 2) (xosd-scroll x 1)
+(sleep 1) (xosd-scroll x 1)
+(sleep 1) (xosd-scroll x 1)
+(sleep 1) (xosd-scroll x 1)
+(sleep 1)
diff --git a/collects/ffi/info.ss b/collects/ffi/info.ss
new file mode 100644
index 0000000000..975197508a
--- /dev/null
+++ b/collects/ffi/info.ss
@@ -0,0 +1,4 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Foreign Function Interfaces")
+  (define blurb
+    '("A few foreign interfaces to various libraries.")))
diff --git a/collects/ffi/magick.ss b/collects/ffi/magick.ss
new file mode 100644
index 0000000000..2a39dcea4a
--- /dev/null
+++ b/collects/ffi/magick.ss
@@ -0,0 +1,2805 @@
+(module magick mzscheme
+
+(require (lib "foreign.ss")) (unsafe!)
+
+(define libwand (ffi-lib "libWand" "6.0.1"))
+
+;; ===== Main Objects =========================================================
+
+(define-syntax defmagick-pointer-type
+  (syntax-rules ()
+    [(_ _name destructor s->c)
+     (define-cpointer-type _name #f s->c
+       (lambda (ptr)
+         (if ptr
+           (begin (register-finalizer ptr destructor) ptr)
+           (error '_name "got a NULL pointer"))))]
+    [(_ _name destructor) (defmagick-pointer-type _name destructor #f)]))
+
+(defmagick-pointer-type _MagickWand DestroyMagickWand)
+(defmagick-pointer-type _DrawingWand DestroyDrawingWand)
+(defmagick-pointer-type _Image DestroyImage)
+(defmagick-pointer-type _DrawInfo DestroyDrawInfo)
+(defmagick-pointer-type _PixelWand DestroyPixelWand
+  ;; This can be implicitly built when given a color name
+  (lambda (x)
+    (let loop ([x x])
+      (cond [(string? x) (loop (NewPixelWand x))]
+            [(list?   x) (loop (NewPixelWand x))]
+            [else x])))) ; can use NULL as a pixel wand (see floodfill)
+
+;; Use a struct for this because we want to keep the associated image width
+(define-struct PixelIterator (ptr width))
+(define _PixelIterator
+  (make-ctype _pointer PixelIterator-ptr
+    (lambda (ptr)
+      (if ptr
+        (let ([new (make-PixelIterator ptr #f)]) ; width set by makers
+          (register-finalizer new DestroyPixelIterator)
+          new)
+        (error '_PixelIterator "got a NULL pointer")))))
+
+;; ===== Utilities ============================================================
+
+(define (raise-wand-exception w)
+  ((cond [(MagickWand?    w) MagickGetException       ]
+         [(PixelWand?     w) PixelGetException        ]
+         [(PixelIterator? w) PixelIteratorGetException]
+         [(DrawingWand?   w) DrawGetException         ]
+         [else (error 'raise-wand-exception "got an unknown value: ~e" w)])
+   w)
+  (error 'wand-exception "an undefined error occured with ~e" w))
+
+(define-fun-syntax _status
+  (syntax-id-rules (_status)
+    [_status (type: _bool
+              1st-arg: 1st
+              post: (r => (unless r (raise-wand-exception 1st))))]))
+
+(define-syntax defmagick
+  (syntax-rules (:)
+    [(_ id : x ...) (define id (get-ffi-obj 'id libwand (_fun x ...)))]))
+
+(define-syntax defmagick*
+  (syntax-rules ()
+    [(_ name x ...) (begin (defmagick name x ...) (provide name))]))
+
+;; Used to convert (small) square matrices (lists of lists) to a memory block.
+(define (_sqmatrix-of type)
+  (make-ctype _pointer
+    (lambda (m)
+      (let ([len (and (list? m) (length m))])
+        (unless (and len (< 0 len)
+                     (andmap (lambda (x) (and (list? x) (= len (length x))))
+                             m))
+          (error '_sqmatrix "expecting a rectangular matrix"))
+        (let ([block (malloc (* len len) type)])
+          (let loop ([n 0] [xs (apply append m)])
+            (unless (null? xs)
+              (ptr-set! block type n (car xs))
+              (loop (add1 n) (cdr xs))))
+          block)))
+    (lambda (x) (error '_sqmatrix "can be used only for ffi inputs"))))
+
+;; This is a hack.  What is needed is to be able to define a type that is a
+;; struct of two doubles that translates to a list of two values.
+(define _Points
+  (make-ctype _pointer
+    (lambda (l)
+      (unless (and (list? l)
+                   (andmap (lambda (x) (and (list? x) (= 2 (length x)))) l))
+        (error '_Points "expecting a list of two-element lists, got ~e" l))
+      (list->cblock (apply append l) _double*))
+    (lambda (x)
+      (error '_Points "cannot be used as an output type"))))
+
+;; Hack for the same reason as above.
+(define _AffineMatrix
+  (make-ctype _pointer
+    (lambda (l)
+      (unless (and (list? l) (= 6 (length l)))
+        (error '_Points "expecting a list of six numbers, got ~e" l))
+      (list->cblock l _double*))
+    (lambda (x) (cblock->list x _double* 6))))
+
+;; Utilities for MagickGetImagePixels/MagickSetImagePixels
+
+(define (StorageType->type storage-type)
+  (case storage-type
+    [(UndefinedPixel) (error 'StorageType->type "got an UndefinedPixel")]
+    [(CharPixel)    _byte]
+    [(ShortPixel)   _word]
+    [(IntegerPixel) _uint]
+    [(LongPixel)    _ulong]
+    [(FloatPixel)   _float]
+    [(DoublePixel)  _double*]))
+
+;; Gets a list and a number, and returns a list of lists of length n
+;; (destructive).
+(define (n-split! l n)
+  (let ([r '()])
+    (let loop ([i 0] [l (reverse! l)])
+      (unless (null? l)
+        (when (zero? i) (set! r (cons '() r)))
+        (let ([next (cdr l)])
+          (set-cdr! l (car r))
+          (set-car! r l)
+          (loop (modulo (add1 i) n) next))))
+    r))
+
+;; _Quantum is something that the library tells us how big it is
+(define _Quantum
+  (let* ([q ((get-ffi-obj "MagickGetQuantumDepth" libwand
+                          (_fun _pointer -> _string))
+             #f)]
+         [err (lambda ()
+                (error 'libwand
+                       "MagickGetQuantumDepth returned a bad value: ~s" q))])
+    (cond [(and (string? q) (regexp-match #rx"^Q([0-9]+)$" q))
+           => (lambda (m)
+                (case (string->number (cadr m))
+                  [( 8) _uint8] [(16) _uint16] [(32) _uint32]
+                  [else (err)]))]
+          [else (err)])))
+
+;; Used twice (PixelGetIndex/PixelSetIndex).
+(define _IndexPacket _Quantum)
+
+(define _MagickSizeType _uint64)
+
+;; This type only needs to be created for PixelGetQuantumColor results.
+;; (Could also define it as a macro for (_list ? _Quantum 4).)
+(define-struct PixelPacket (ptr))
+(define _PixelPacket
+  (make-ctype _pointer PixelPacket-ptr make-PixelPacket))
+(define (NewPixelPacket)
+  (make-PixelPacket (malloc _Quantum 4)))
+
+;; ===== Enumeration Types ====================================================
+
+(define _MagickExceptionType
+  (_enum '(UndefinedException
+           WarningException = 300
+           ResourceLimitWarning = 300
+           TypeWarning = 305
+           OptionWarning = 310
+           DelegateWarning = 315
+           MissingDelegateWarning = 320
+           CorruptImageWarning = 325
+           FileOpenWarning = 330
+           BlobWarning = 335
+           StreamWarning = 340
+           CacheWarning = 345
+           CoderWarning = 350
+           ModuleWarning = 355
+           DrawWarning = 360
+           ImageWarning = 365
+           WandWarning = 370
+           XServerWarning = 380
+           MonitorWarning = 385
+           RegistryWarning = 390
+           ConfigureWarning = 395
+           ErrorException = 400
+           ResourceLimitError = 400
+           TypeError = 405
+           OptionError = 410
+           DelegateError = 415
+           MissingDelegateError = 420
+           CorruptImageError = 425
+           FileOpenError = 430
+           BlobError = 435
+           StreamError = 440
+           CacheError = 445
+           CoderError = 450
+           ModuleError = 455
+           DrawError = 460
+           ImageError = 465
+           WandError = 470
+           XServerError = 480
+           MonitorError = 485
+           RegistryError = 490
+           ConfigureError = 495
+           FatalErrorException = 700
+           ResourceLimitFatalError = 700
+           TypeFatalError = 705
+           OptionFatalError = 710
+           DelegateFatalError = 715
+           MissingDelegateFatalError = 720
+           CorruptImageFatalError = 725
+           FileOpenFatalError = 730
+           BlobFatalError = 735
+           StreamFatalError = 740
+           CacheFatalError = 745
+           CoderFatalError = 750
+           ModuleFatalError = 755
+           DrawFatalError = 760
+           ImageFatalError = 765
+           WandFatalError = 770
+           XServerFatalError = 780
+           MonitorFatalError = 785
+           RegistryFatalError = 790
+           ConfigureFatalError = 795
+           )))
+
+(define _CompositeOperator
+  (_enum '(UndefinedCompositeOp
+           NoCompositeOp
+           AddCompositeOp
+           AtopCompositeOp
+           BlendCompositeOp
+           BumpmapCompositeOp
+           ClearCompositeOp
+           ColorBurnCompositeOp
+           ColorDodgeCompositeOp
+           ColorizeCompositeOp
+           CopyBlackCompositeOp
+           CopyBlueCompositeOp
+           CopyCompositeOp
+           CopyCyanCompositeOp
+           CopyGreenCompositeOp
+           CopyMagentaCompositeOp
+           CopyOpacityCompositeOp
+           CopyRedCompositeOp
+           CopyYellowCompositeOp
+           DarkenCompositeOp
+           DstAtopCompositeOp
+           DstCompositeOp
+           DstInCompositeOp
+           DstOutCompositeOp
+           DstOverCompositeOp
+           DifferenceCompositeOp
+           DisplaceCompositeOp
+           DissolveCompositeOp
+           ExclusionCompositeOp
+           HardLightCompositeOp
+           HueCompositeOp
+           InCompositeOp
+           LightenCompositeOp
+           LuminizeCompositeOp
+           MinusCompositeOp
+           ModulateCompositeOp
+           MultiplyCompositeOp
+           OutCompositeOp
+           OverCompositeOp
+           OverlayCompositeOp
+           PlusCompositeOp
+           ReplaceCompositeOp
+           SaturateCompositeOp
+           ScreenCompositeOp
+           SoftLightCompositeOp
+           SrcAtopCompositeOp
+           SrcCompositeOp
+           SrcInCompositeOp
+           SrcOutCompositeOp
+           SrcOverCompositeOp
+           SubtractCompositeOp
+           ThresholdCompositeOp
+           XorCompositeOp
+           )))
+
+(define _ColorspaceType
+  (_enum '(UndefinedColorspace
+           RGBColorspace
+           GRAYColorspace
+           TransparentColorspace
+           OHTAColorspace
+           LABColorspace
+           XYZColorspace
+           YCbCrColorspace
+           YCCColorspace
+           YIQColorspace
+           YPbPrColorspace
+           YUVColorspace
+           CMYKColorspace
+           sRGBColorspace
+           HSBColorspace
+           HSLColorspace
+           HWBColorspace
+           )))
+
+(define _CompressionType
+  (_enum '(UndefinedCompression
+           NoCompression
+           BZipCompression
+           FaxCompression
+           Group4Compression
+           JPEGCompression
+           LosslessJPEGCompression
+           LZWCompression
+           RLECompression
+           ZipCompression
+           )))
+
+(define _DisposeType
+  (_enum '(UnrecognizedDispose
+           UndefinedDispose = 0
+           NoneDispose = 1
+           BackgroundDispose = 2
+           PreviousDispose = 3
+           )))
+
+(define _ImageType
+  (_enum '(UndefinedType
+           BilevelType
+           GrayscaleType
+           GrayscaleMatteType
+           PaletteType
+           PaletteMatteType
+           TrueColorType
+           TrueColorMatteType
+           ColorSeparationType
+           ColorSeparationMatteType
+           OptimizeType
+           )))
+
+(define _InterlaceType
+  (_enum '(UndefinedInterlace
+           NoInterlace
+           LineInterlace
+           PlaneInterlace
+           PartitionInterlace
+           )))
+
+(define _ChannelType
+  (_bitmask '(UndefinedChannel = #x0000
+              RedChannel = #x0001
+              CyanChannel = #x0001
+              GreenChannel = #x0002
+              MagentaChannel = #x0002
+              BlueChannel = #x0004
+              YellowChannel = #x0004
+              AlphaChannel = #x0008
+              OpacityChannel = #x0008
+              MatteChannel = #x0008 ; deprecated
+              BlackChannel = #x0020
+              IndexChannel = #x0020
+              AllChannels = #x7fffffff
+              )))
+
+(define _MetricType
+  (_enum '(UndefinedMetric
+           MeanAbsoluteErrorMetric
+           MeanSquaredErrorMetric
+           PeakAbsoluteErrorMetric
+           PeakSignalToNoiseRatioMetric
+           RootMeanSquaredErrorMetric
+           )))
+
+(define _NoiseType
+  (_enum '(UndefinedNoise
+           UniformNoise
+           GaussianNoise
+           MultiplicativeGaussianNoise
+           ImpulseNoise
+           LaplacianNoise
+           PoissonNoise
+           )))
+
+(define _MagickEvaluateOperator
+  (_enum '(UndefinedEvaluateOperator
+           AddEvaluateOperator
+           AndEvaluateOperator
+           DivideEvaluateOperator
+           LeftShiftEvaluateOperator
+           MaxEvaluateOperator
+           MinEvaluateOperator
+           MultiplyEvaluateOperator
+           OrEvaluateOperator
+           RightShiftEvaluateOperator
+           SetEvaluateOperator
+           SubtractEvaluateOperator
+           XorEvaluateOperator
+           )))
+
+(define _ResourceType
+  (_enum '(UndefinedResource
+           AreaResource
+           DiskResource
+           FileResource
+           MapResource
+           MemoryResource
+           )))
+
+(define _StorageType
+  (_enum '(UndefinedPixel
+           CharPixel
+           ShortPixel
+           IntegerPixel
+           LongPixel
+           FloatPixel
+           DoublePixel
+           )))
+
+(define _RenderingIntent
+  (_enum '(UndefinedIntent
+           SaturationIntent
+           PerceptualIntent
+           AbsoluteIntent
+           RelativeIntent
+           )))
+
+(define _ResolutionType
+  (_enum '(UndefinedResolution
+           PixelsPerInchResolution
+           PixelsPerCentimeterResolution
+           )))
+
+(define _VirtualPixelMethod
+  (_enum '(UndefinedVirtualPixelMethod
+           ConstantVirtualPixelMethod
+           EdgeVirtualPixelMethod
+           MirrorVirtualPixelMethod
+           TileVirtualPixelMethod
+           )))
+
+(define _PreviewType
+  (_enum '(UndefinedPreview
+           RotatePreview
+           ShearPreview
+           RollPreview
+           HuePreview
+           SaturationPreview
+           BrightnessPreview
+           GammaPreview
+           SpiffPreview
+           DullPreview
+           GrayscalePreview
+           QuantizePreview
+           DespecklePreview
+           ReduceNoisePreview
+           AddNoisePreview
+           SharpenPreview
+           BlurPreview
+           ThresholdPreview
+           EdgeDetectPreview
+           SpreadPreview
+           SolarizePreview
+           ShadePreview
+           RaisePreview
+           SegmentPreview
+           SwirlPreview
+           ImplodePreview
+           WavePreview
+           OilPaintPreview
+           CharcoalDrawingPreview
+           JPEGPreview
+           )))
+
+(define _FilterTypes
+  (_enum '(UndefinedFilter
+           PointFilter
+           BoxFilter
+           TriangleFilter
+           HermiteFilter
+           HanningFilter
+           HammingFilter
+           BlackmanFilter
+           GaussianFilter
+           QuadraticFilter
+           CubicFilter
+           CatromFilter
+           MitchellFilter
+           LanczosFilter
+           BesselFilter
+           SincFilter
+           )))
+
+(define _MontageMode
+  (_enum '(UndefinedMode
+           FrameMode
+           UnframeMode
+           ConcatenateMode
+           )))
+
+(define _StretchType
+  (_enum '(UndefinedStretch
+           NormalStretch
+           UltraCondensedStretch
+           ExtraCondensedStretch
+           CondensedStretch
+           SemiCondensedStretch
+           SemiExpandedStretch
+           ExpandedStretch
+           ExtraExpandedStretch
+           UltraExpandedStretch
+           AnyStretch
+           )))
+
+(define _StyleType
+  (_enum '(UndefinedStyle
+           NormalStyle
+           ItalicStyle
+           ObliqueStyle
+           AnyStyle
+           )))
+
+(define _GravityType
+  (_enum '(UndefinedGravity
+           ForgetGravity = 0
+           NorthWestGravity = 1
+           NorthGravity = 2
+           NorthEastGravity = 3
+           WestGravity = 4
+           CenterGravity = 5
+           EastGravity = 6
+           SouthWestGravity = 7
+           SouthGravity = 8
+           SouthEastGravity = 9
+           StaticGravity = 10
+           )))
+
+(define _ClipPathUnits
+  (_enum '(UndefinedPathUnits
+           UserSpace
+           UserSpaceOnUse
+           ObjectBoundingBox
+           )))
+
+(define _DecorationType
+  (_enum '(UndefinedDecoration
+           NoDecoration
+           UnderlineDecoration
+           OverlineDecoration
+           LineThroughDecoration
+           )))
+
+(define _FillRule
+  (_enum '(UndefinedRule
+           EvenOddRule
+           NonZeroRule
+           )))
+
+(define _LineCap
+  (_enum '(UndefinedCap
+           ButtCap
+           RoundCap
+           SquareCap
+           )))
+
+(define _LineJoin
+  (_enum '(UndefinedJoin
+           MiterJoin
+           RoundJoin
+           BevelJoin
+           )))
+
+(define _PaintMethod
+  (_enum '(UndefinedMethod
+           PointMethod
+           ReplaceMethod
+           FloodfillMethod
+           FillToBorderMethod
+           ResetMethod
+           )))
+
+;; ===== MagickWand API =======================================================
+
+;; MagickGetException returns the severity, reason, and description of any
+;; error that occurs when using other methods in this API (as an exception).
+(defmagick* MagickGetException :
+  _MagickWand (severity : (_ptr o _MagickExceptionType)) -> (message : _string)
+  -> (unless (eq? severity 'UndefinedException)
+       (error 'MagickWand "(~a) ~a" severity message)))
+
+;; DestroyMagickWand deallocates memory associated with an MagickWand.
+;; Intended for internal use only, must be defined after the above.
+(defmagick DestroyMagickWand :
+  _MagickWand -> _void)
+
+;; CloneMagickWand makes an exact copy of the specified wand.
+(defmagick* CloneMagickWand :
+  _MagickWand -> _MagickWand)
+
+;; GetImageFromMagickWand returns the current image from the magick wand.
+(defmagick* GetImageFromMagickWand :
+  _MagickWand -> _Image)
+
+;; MagickAdaptiveThresholdImage selects an individual threshold for each pixel
+;; based on the range of intensity values in its local neighborhood.  This
+;; allows for thresholding of an image whose global intensity histogram doesn't
+;; contain distinctive peaks.
+(defmagick* MagickAdaptiveThresholdImage :
+  _MagickWand (width : _ulong) (height : _ulong) (offset : _long) -> _status)
+
+;; MagickAddImage adds the specified images at the current image location.
+(defmagick* MagickAddImage :
+  _MagickWand (insert-wand : _MagickWand) -> _status)
+
+;; MagickAddNoiseImage adds random noise to the image.
+(defmagick* MagickAddNoiseImage :
+  _MagickWand _NoiseType -> _status)
+
+;; MagickAffineTransformImage transforms an image as dictated by the affine
+;; matrix of the drawing wand.
+(defmagick* MagickAffineTransformImage :
+  _MagickWand _DrawingWand -> _status)
+
+;; MagickAnimateImages animates an image or image sequence.
+(defmagick* MagickAnimateImages :
+  (w . server) ::
+  (w : _MagickWand) (_string = (and (pair? server) (car server))) -> _status)
+
+;; MagickAnnotateImage annotates an image with text.
+(defmagick* MagickAnnotateImage :
+  _MagickWand _DrawingWand
+  (x : _double*) (y : _double*) (angle : _double*) (text : _string)
+  -> _status)
+
+;; MagickAppendImages append a set of images.
+(defmagick* MagickAppendImages :
+  _MagickWand (top-to-bottom? : _bool) -> _MagickWand)
+
+;; MagickAverageImages average a set of images.
+(defmagick* MagickAverageImages :
+  _MagickWand -> _MagickWand)
+
+;; MagickBlackThresholdImage is like MagickThresholdImage but forces all pixels
+;; below the threshold into black while leaving all pixels above the threshold
+;; unchanged.
+(defmagick* MagickBlackThresholdImage :
+  _MagickWand _PixelWand -> _status)
+
+;; MagickBlurImage blurs an image.  We convolve the image with a gaussian
+;; operator of the given radius and standard deviation (sigma).  For reasonable
+;; results, the radius should be larger than sigma.  Use a radius of 0 and
+;; MagickBlurImage selects a suitable radius for you.
+(defmagick* MagickBlurImage :
+  _MagickWand (radius : _double*) (sigma : _double*) -> _status)
+
+;; MagickBlurImageChannel blurs one or more image channels.  We convolve the
+;; image cnannel with a gaussian operator of the given radius and standard
+;; deviation (sigma).  For reasonable results, the radius should be larger than
+;; sigma.  Use a radius of 0 and MagickBlurImageChannel selects a suitable
+;; radius for you.
+(defmagick* MagickBlurImageChannel :
+  _MagickWand _ChannelType (radius : _double*) (sigma : _double*) -> _status)
+
+;; MagickBorderImage surrounds the image with a border of the color defined by
+;; the bordercolor pixel wand.
+(defmagick* MagickBorderImage :
+  _MagickWand (border : _PixelWand) (width : _ulong) (height : _ulong)
+  -> _status)
+
+;; MagickCharcoalImage simulates a charcoal drawing.
+(defmagick* MagickCharcoalImage :
+  _MagickWand (radius : _double*) (sigma : _double*) -> _status)
+
+;; MagickChopImage removes a region of an image and collapses the image to
+;; occupy the removed portion.
+(defmagick* MagickChopImage :
+  _MagickWand (width : _ulong) (height : _ulong) (x : _long) (y : _long)
+  -> _status)
+
+;; MagickClipImage clips along the first path from the 8BIM profile, if
+;; present.
+(defmagick* MagickClipImage :
+  _MagickWand -> _status)
+
+;; MagickClipPathImage clips along the named paths from the 8BIM profile, if
+;; present.  Later operations take effect inside the path.  Id may be a number
+;; if preceded with #, to work on a numbered path, e.g., "#1" to use the first
+;; path.  If inside? is non-zero, later operations take effect inside clipping
+;; path.  Otherwise later operations take effect outside clipping path.
+(defmagick* MagickClipPathImage :
+  _MagickWand (name : _string) (inside? : _bool) -> _status)
+
+;; MagickCoalesceImages composites a set of images while respecting any page
+;; offsets and disposal methods.  GIF, MIFF, and MNG animation sequences
+;; typically start with an image background and each subsequent image varies in
+;; size and offset.  MagickCoalesceImages returns a new sequence where each
+;; image in the sequence is the same size as the first and composited with the
+;; next image in the sequence.
+(defmagick* MagickCoalesceImages :
+  _MagickWand -> _MagickWand)
+
+;; MagickColorFloodfillImage changes the color value of any pixel that matches
+;; target and is an immediate neighbor.  If the method FillToBorderMethod is
+;; specified, the color value is changed for any neighbor pixel that does not
+;; match the bordercolor member of image.
+(defmagick* MagickColorFloodfillImage :
+  _MagickWand (fill : _PixelWand) (fuzz : _double*) (border : _PixelWand)
+  (x : _long) (y : _long)
+  -> _status)
+
+;; MagickColorizeImage blends the fill color with each pixel in the image.
+(defmagick* MagickColorizeImage :
+  _MagickWand (colorize : _PixelWand) (opacity : _PixelWand) -> _status)
+
+;; MagickCombineImages combines one or more images into a single image.  The
+;; grayscale value of the pixels of each image in the sequence is assigned in
+;; order to the specified hannels of the combined image.  The typical ordering
+;; would be image 1 => Red, 2 => Green, 3 => Blue, etc.
+(defmagick* MagickCombineImages :
+  _MagickWand _ChannelType -> _MagickWand)
+
+;; MagickCommentImage adds a comment to your image.
+(defmagick* MagickCommentImage :
+  _MagickWand (comment : _string) -> _status)
+
+;; MagickCompareImageChannels compares one or more image channels and returns
+;; the specified distortion metric.
+(defmagick* MagickCompareImageChannels :
+  _MagickWand (reference : _MagickWand)
+  _ChannelType _MetricType (distortion : (_ptr o _double*))
+  -> (comp : _MagickWand)
+  -> (list distortion comp))
+
+;; MagickCompositeImage composite one image onto another at the specified
+;; offset.
+(defmagick* MagickCompositeImage :
+  _MagickWand (composite : _MagickWand) _CompositeOperator
+  (x-offset : _long) (y-offset : _long)
+  -> _status)
+
+;; MagickContrastImage enhances the intensity differences between the lighter
+;; and darker elements of the image.  Set sharpen? to a value other than 0 to
+;; increase the image contrast otherwise the contrast is reduced.
+(defmagick* MagickContrastImage :
+  _MagickWand (sharpen? : _bool) -> _status)
+
+;; MagickConvolveImage applies a custom convolution kernel to the image.
+(defmagick* MagickConvolveImage :
+  (w kernel) ::
+  (w : _MagickWand)
+  (_ulong = (length kernel)) (kernel : (_sqmatrix-of _double*))
+  -> _status)
+
+;; MagickConvolveImageChannel applies a custom convolution kernel to one or
+;; more image channels.
+(defmagick* MagickConvolveImageChannel :
+  (w channels kernel) ::
+  (w : _MagickWand) (channels : _ChannelType)
+  (_ulong = (length kernel)) (kernel : (_sqmatrix-of _double*))
+  -> _status)
+
+;; MagickCropImage extracts a region of the image.
+(defmagick* MagickCropImage :
+  _MagickWand (width : _ulong) (height : _ulong) (x : _long) (y : _long)
+  -> _status)
+
+;; MagickCycleColormapImage displaces an image's colormap by a given number of
+;; positions.  If you cycle the colormap a number of times you can produce a
+;; psychodelic effect.
+(defmagick* MagickCycleColormapImage :
+  _MagickWand (displace : _long) -> _status)
+
+;; MagickDeconstructImages compares each image with the next in a sequence and
+;; returns the maximum bounding region of any pixel differences it discovers.
+(defmagick* MagickDeconstructImages :
+  _MagickWand -> _MagickWand)
+
+;; MagickDescribeImage describes an image by printing its attributes to the
+;; file.  Attributes include the image width, height, size, and others.
+(defmagick* MagickDescribeImage :
+  _MagickWand -> _string)
+
+;; MagickDespeckleImage reduces the speckle noise in an image while perserving
+;; the edges of the original image.
+(defmagick* MagickDespeckleImage :
+  _MagickWand -> _status)
+
+;; MagickDisplayImage displays an image.
+(defmagick* MagickDisplayImage :
+  (w . server) ::
+  (w : _MagickWand) (_string = (and (pair? server) (car server))) -> _status)
+
+;; MagickDisplayImages displays an image or image sequence.
+(defmagick* MagickDisplayImages :
+  (w . server) ::
+  (w : _MagickWand) (_string = (and (pair? server) (car server))) -> _status)
+
+;; MagickDrawImage draw an image the specified number of degrees.
+(defmagick* MagickDrawImage :
+  _MagickWand _DrawingWand -> _status)
+
+;; MagickEdgeImage enhance edges within the image with a convolution filter of
+;; the given radius.  Use a radius of 0 and MagickEdgeImage selects a
+;; suitable radius for you.
+(defmagick* MagickEdgeImage :
+  _MagickWand (radius : _double*) -> _status)
+
+;; MagickEmbossImage returns a grayscale image with a three-dimensional effect.
+;; We convolve the image with a Gaussian operator of the given radius and
+;; standard deviation (sigma).  For reasonable results, radius should be larger
+;; than sigma.  Use a radius of 0 and MagickEmbossImage selects a suitable
+;; radius for you.
+(defmagick* MagickEmbossImage :
+  _MagickWand (radius : _double*) (sigma : _double*) -> _status)
+
+;; MagickEnhanceImage applies a digital filter that improves the quality of a
+;; noisy image.
+(defmagick* MagickEnhanceImage :
+  _MagickWand -> _status)
+
+;; MagickEqualizeImage equalizes the image histogram.
+(defmagick* MagickEqualizeImage :
+  _MagickWand -> _status)
+
+;; Use MagickEvaluateImage to apply an arithmetic, relational, or logical
+;; operator to an image.  These operations can be used to lighten or darken an
+;; image, to increase or decrease contrast in an image, or to produce the
+;; "negative" of an image.
+(defmagick* MagickEvaluateImage :
+  _MagickWand _MagickEvaluateOperator (const : _double*) -> _status)
+
+;; Use MagickEvaluateImageChannel to apply an arithmetic, relational, or
+;; logical operator to an image.  These operations can be used to lighten or
+;; darken an image, to increase or decrease contrast in an image, or to produce
+;; the "negative" of an image.
+(defmagick* MagickEvaluateImageChannel :
+  _MagickWand _ChannelType _MagickEvaluateOperator (const : _double*)
+  -> _status)
+
+;; MagickFlattenImages merges a sequence of images.  This is useful for
+;; combining Photoshop layers into a single image.
+(defmagick* MagickFlattenImages :
+  _MagickWand -> _MagickWand)
+
+;; MagickFlipImage creates a vertical mirror image by reflecting the pixels
+;; around the central x-axis.
+(defmagick* MagickFlipImage :
+  _MagickWand -> _status)
+
+;; MagickFlopImage creates a horizontal mirror image by reflecting the pixels
+;; around the central y-axis.
+(defmagick* MagickFlopImage :
+  _MagickWand -> _status)
+
+;; MagickFrameImage adds a simulated three-dimensional border around the image.
+;; The width and height specify the border width of the vertical and horizontal
+;; sides of the frame.  The inner and outer bevels indicate the width of the
+;; inner and outer shadows of the frame.
+(defmagick* MagickFrameImage :
+  _MagickWand (matte : _PixelWand)
+  (width : _ulong) (height : _ulong)
+  (inner-bevel : _long) (outer-bevel : _long)
+  -> _status)
+
+;; MagickFxImage evaluate expression for each pixel in the image.
+(defmagick* MagickFxImage :
+  _MagickWand (expr : _string) -> _MagickWand)
+
+;; MagickFxImageChannel evaluate expression for each pixel in the specified
+;; channel.
+(defmagick* MagickFxImageChannel :
+  _MagickWand _ChannelType (expr : _string) -> _MagickWand)
+
+;; Use MagickGammaImage to gamma-correct an image.  The same image viewed on
+;; different devices will have perceptual differences in the way the image's
+;; intensities are represented on the screen.  Specify individual gamma levels
+;; for the red, green, and blue channels, or adjust all three with the gamma
+;; parameter.  Values typically range from 0.8 to 2.3.  You can also reduce the
+;; influence of a particular channel with a gamma value of 0.
+(defmagick* MagickGammaImage :
+  _MagickWand (gamma : _double*) -> _status)
+
+;; Use MagickGammaImageChannel to gamma-correct a particular image channel.
+;; The same image viewed on different devices will have perceptual differences
+;; in the way the image's intensities are represented on the screen.  Specify
+;; individual gamma levels for the red, green, and blue channels, or adjust all
+;; three with the gamma parameter.  Values typically range from 0.8 to 2.3.
+(defmagick* MagickGammaImageChannel :
+  _MagickWand _ChannelType (gamma : _double*) -> _status)
+
+;; MagickGaussianBlurImage blurs an image.  We convolve the image with a
+;; Gaussian operator of the given radius and standard deviation (sigma).  For
+;; reasonable results, the radius should be larger than sigma.  Use a radius of
+;; 0 and MagickGaussianBlurImage selects a suitable radius for you.
+(defmagick* MagickGaussianBlurImage :
+  _MagickWand (radius : _double*) (sigma : _double*) -> _status)
+
+;; MagickGaussianBlurImageChannel blurs one or more image channels.  We
+;; convolve the image cnannel with a Gaussian operator of the given radius and
+;; standard deviation (sigma).  For reasonable results, the radius should be
+;; larger than sigma.  Use a radius of 0 and MagickGaussianBlurImageChannel
+;; selects a suitable radius for you.
+(defmagick* MagickGaussianBlurImageChannel :
+  _MagickWand _ChannelType (radius : _double*) (sigma : _double*) -> _status)
+
+;; MagickGetCopyright returns the ImageMagick API copyright as a string.
+(defmagick* MagickGetCopyright :
+  -> _string)
+
+;; MagickGetFilename returns the filename associated with an image sequence.
+(defmagick* MagickGetFilename :
+  _MagickWand -> _file)
+
+;; MagickGetHomeURL returns the ImageMagick home URL.
+(defmagick* MagickGetHomeURL :
+  -> _string)
+
+;; MagickGetImage gets the image at the current image index.
+(defmagick* MagickGetImage :
+  _MagickWand -> _MagickWand)
+
+;; MagickGetImageBackgroundColor returns the image background color.
+(defmagick* MagickGetImageBackgroundColor :
+  _MagickWand (c : _PixelWand = (NewPixelWand)) -> _status -> c)
+
+;; MagickGetImageBluePrimary returns the chromaticy blue primary point for the
+;; image.
+(defmagick* MagickGetImageBluePrimary :
+  _MagickWand (x : (_ptr o _double*)) (y : (_ptr o _double*)) -> _status
+  -> (list x y))
+
+;; MagickGetImageBorderColor returns the image border color.
+(defmagick* MagickGetImageBorderColor :
+  _MagickWand (c : _PixelWand = (NewPixelWand)) -> _status -> c)
+
+;; MagickGetImageChannelDepth gets the depth for a particular image channel.
+(defmagick* MagickGetImageChannelDepth :
+  _MagickWand _ChannelType -> _ulong)
+
+;; MagickGetImageChannelExtrema gets the extrema for one or more image
+;; channels.
+(defmagick* MagickGetImageChannelExtrema :
+  _MagickWand _ChannelType (min : (_ptr o _ulong)) (max : (_ptr o _ulong))
+  -> _status
+  -> (list min max))
+
+;; MagickGetImageChannelMean gets the mean and standard deviation of one or
+;; more image channels.
+(defmagick* MagickGetImageChannelMean :
+  _MagickWand _ChannelType
+  (mean : (_ptr o _double*)) (standard-deviation : (_ptr o _double*))
+  -> _status
+  -> (list mean standard-deviation))
+
+;; MagickGetImageColormapColor returns the color of the specified colormap
+;; index.
+(defmagick* MagickGetImageColormapColor :
+  _MagickWand (colormap-index : _ulong) (c : _PixelWand = (NewPixelWand))
+  -> _status -> c)
+
+;; MagickGetImageColors gets the number of unique colors in the image.
+(defmagick* MagickGetImageColors :
+  _MagickWand -> _ulong)
+
+;; MagickGetImageColorspace gets the image colorspace.
+(defmagick* MagickGetImageColorspace :
+  _MagickWand -> _ColorspaceType)
+
+;; MagickGetImageCompose returns the composite operator associated with the
+;; image.
+(defmagick* MagickGetImageCompose :
+  _MagickWand -> _CompositeOperator)
+
+;; MagickGetImageCompression gets the image compression.
+(defmagick* MagickGetImageCompression :
+  _MagickWand -> _CompressionType)
+
+;; MagickGetImageCompressionQuality gets the image compression quality.
+(defmagick* MagickGetImageCompressionQuality :
+  _MagickWand -> _ulong)
+
+;; MagickGetImageDelay gets the image delay.
+(defmagick* MagickGetImageDelay :
+  _MagickWand -> _ulong)
+
+;; MagickGetImageDepth gets the image depth.
+(defmagick* MagickGetImageDepth :
+  _MagickWand -> _ulong)
+
+;; MagickGetImageDispose gets the image disposal method.
+(defmagick* MagickGetImageDispose :
+  _MagickWand -> _DisposeType)
+
+;; MagickGetImageExtrema gets the extrema for the image.
+(defmagick* MagickGetImageExtrema :
+  _MagickWand (min : (_ptr o _ulong)) (max : (_ptr o _ulong)) -> _status
+  -> (list min max))
+
+;; MagickGetImageFilename returns the filename of a particular image in a
+;; sequence.
+(defmagick* MagickGetImageFilename :
+  _MagickWand -> _string)
+
+;; MagickGetImageFormat returns the format of a particular image in a sequence.
+(defmagick* MagickGetImageFormat :
+  _MagickWand -> _string)
+
+;; MagickGetImageGamma gets the image gamma.
+(defmagick* MagickGetImageGamma :
+  _MagickWand -> _double*)
+
+;; MagickGetImageGreenPrimary returns the chromaticy green primary point.
+(defmagick* MagickGetImageGreenPrimary :
+  _MagickWand (x : (_ptr o _double*)) (y : (_ptr o _double*)) -> _status
+  -> (list x y))
+
+;; MagickGetImageHeight returns the image height.
+(defmagick* MagickGetImageHeight :
+  _MagickWand -> _ulong)
+
+;; MagickGetImageHistogram returns the image histogram as an array of PixelWand
+;; wands.
+(defmagick* MagickGetImageHistogram :
+  _MagickWand (len : (_ptr o _ulong)) -> (_list o _PixelWand len))
+
+;; MagickGetImageIndex returns the index of the current image.
+(defmagick* MagickGetImageIndex :
+  _MagickWand -> _long)
+
+;; MagickGetImageInterlaceScheme gets the image interlace scheme.
+(defmagick* MagickGetImageInterlaceScheme :
+  _MagickWand -> _InterlaceType)
+
+;; MagickGetImageIterations gets the image iterations.
+(defmagick* MagickGetImageIterations :
+  _MagickWand -> _ulong)
+
+;; MagickGetImageMatteColor returns the image matte color.
+(defmagick* MagickGetImageMatteColor :
+  _MagickWand (c : _PixelWand = (NewPixelWand)) -> _status -> c)
+
+;; MagickGetImagePixels extracts pixel data from an image and returns it to
+;; you.  The method returns False on success otherwise True if an error is
+;; encountered.  The data is returned as char, short int, int, long, float, or
+;; double in the order specified by map.  Suppose you want to extract the first
+;; scanline of a 640x480 image as character data in red-green-blue order:
+;;     (MagickGetImagePixels wand 0 0 640 1 "RGB" 'CharPixel)
+;; `map' is a string that reflects the expected ordering of the pixel array.
+;; It can be any combination or order of R = red, G = green, B = blue,
+;; A = alpha (0 is transparent), O = opacity (0 is opaque), C = cyan,
+;; Y = yellow, M = magenta, K = black, I = intensity (for grayscale), P = pad.
+;; Note: the scheme interface uses a list of rows, each a list of values for
+;; each element in the map.
+(defmagick* MagickGetImagePixels :
+  _MagickWand (x : _long) (y : _long) (width : _ulong) (height : _ulong)
+  (map : _string) (storage-type : _StorageType)
+  ;; create the block, remember size and type
+  (size  : _?       = (* width height (string-length map)))
+  (type  : _?       = (StorageType->type storage-type))
+  (block : _pointer = (malloc size type))
+  -> _status
+  -> (let loop ([n (sub1 size)] [r '()])
+       (if (< n 0)
+         (n-split! (n-split! r (string-length map)) width)
+         (loop (sub1 n) (cons (ptr-ref block type n) r)))))
+
+;; MagickGetImageProfile returns the named image profile.
+(defmagick* MagickGetImageProfile :
+  _MagickWand (profile-name : _string) (len : (_ptr o _ulong))
+  -> (_bytes o len))
+
+;; MagickGetImageRedPrimary returns the chromaticy red primary point.
+(defmagick* MagickGetImageRedPrimary :
+  _MagickWand (x : (_ptr o _double*)) (y : (_ptr o _double*)) -> _status
+  -> (list x y))
+
+;; MagickGetImageRenderingIntent gets the image rendering intent.
+(defmagick* MagickGetImageRenderingIntent :
+  _MagickWand -> _RenderingIntent)
+
+;; MagickGetImageSignature generates an SHA-256 message digest for the image
+;; pixel stream.
+(defmagick* MagickGetImageSignature :
+  _MagickWand -> _string)
+
+;; MagickGetImageSize returns the image size.
+(defmagick* MagickGetImageSize :
+  _MagickWand -> _MagickSizeType)
+
+;; MagickGetImageType gets the image type.
+(defmagick* MagickGetImageType :
+  _MagickWand -> _ImageType)
+
+;; MagickGetImageUnits gets the image units of resolution.
+(defmagick* MagickGetImageUnits :
+  _MagickWand -> _ResolutionType)
+
+;; MagickGetImageVirtualPixelMethod returns the virtual pixel method for the
+;; sepcified image.
+(defmagick* MagickGetImageVirtualPixelMethod :
+  _MagickWand -> _VirtualPixelMethod)
+
+;; MagickGetImageWhitePoint returns the chromaticy white point.
+(defmagick* MagickGetImageWhitePoint :
+  _MagickWand (x : (_ptr o _double*)) (y : (_ptr o _double*)) -> _status
+  -> (list x y))
+
+;; MagickGetImageWidth returns the image width.
+(defmagick* MagickGetImageWidth :
+  _MagickWand -> _ulong)
+
+;; MagickGetImageResolution gets the image X & Y resolution.
+(defmagick* MagickGetImageResolution :
+  _MagickWand (res-x : (_ptr o _double*)) (res-y : (_ptr o _double*))
+  -> _status
+  -> (list res-x res-y))
+
+;; MagickGetNumberImages returns the number of images associated with a magick
+;; wand.
+(defmagick* MagickGetNumberImages :
+  _MagickWand -> _ulong)
+
+;; MagickGetPackageName returns the ImageMagick package name.
+(defmagick* MagickGetPackageName :
+  -> _string)
+
+;; MagickGetQuantumDepth returns the ImageMagick quantum depth.
+(defmagick* MagickGetQuantumDepth :
+  (q : (_ptr o _ulong)) -> _string -> q)
+
+;; MagickGetReleaseDate returns the ImageMagick release date.
+(defmagick* MagickGetReleaseDate :
+  -> _string)
+
+;; MagickGetResourceLimit returns the the specified resource in megabytes.
+(defmagick* MagickGetResourceLimit :
+  _ResourceType -> _ulong)
+
+;; MagickGetSamplingFactors gets the horizontal and vertical sampling factor.
+(defmagick* MagickGetSamplingFactors :
+  _MagickWand (len : (_ptr o _ulong)) -> (_list o _double* len))
+
+;; MagickGetSize returns the size associated with the magick wand.
+(defmagick* MagickGetSize :
+  _MagickWand (width : (_ptr o _ulong)) (height : (_ptr o _ulong)) -> _status
+  -> (list width height))
+
+;; MagickGetVersion returns the ImageMagick API version as a string and as a
+;; number.
+(defmagick* MagickGetVersion :
+  (v : (_ptr o _ulong)) -> (s : _string) -> (list v s))
+
+;; MagickHasNextImage returns True if the wand has more images when traversing
+;; the list in the forward direction
+(defmagick* MagickHasNextImage :
+  _MagickWand -> _bool)
+
+;; MagickHasPreviousImage returns True if the wand has more images when
+;; traversing the list in the reverse direction
+(defmagick* MagickHasPreviousImage :
+  _MagickWand -> _bool)
+
+;; MagickImplodeImage creates a new image that is a copy of an existing one
+;; with the image pixels "implode" by the specified percentage.
+(defmagick* MagickImplodeImage :
+  _MagickWand (amount : _double*) -> _status)
+
+;; MagickLabelImage adds a label to your image.
+(defmagick* MagickLabelImage :
+  _MagickWand (label : _string) -> _status)
+
+;; MagickLevelImage adjusts the levels of an image by scaling the colors
+;; falling between specified white and black points to the full available
+;; quantum range.  The parameters provided represent the black, mid, and white
+;; points.  The black point specifies the darkest color in the image.  Colors
+;; darker than the black point are set to zero.  Mid point specifies a gamma
+;; correction to apply to the image.  White point specifies the lightest color
+;; in the image.  Colors brighter than the white point are set to the maximum
+;; quantum value.
+(defmagick* MagickLevelImage :
+  _MagickWand
+  (black-point : _double*) (gamma : _double*) (white-point : _double*)
+  -> _status)
+
+;; MagickLevelImageChannel adjusts the levels of the specified channel of the
+;; reference image by scaling the colors falling between specified white and
+;; black points to the full available quantum range.  The parameters provided
+;; represent the black, mid, and white points.  The black point specifies the
+;; darkest color in the image.  Colors darker than the black point are set to
+;; zero.  Mid point specifies a gamma correction to apply to the image.  White
+;; point specifies the lightest color in the image.  Colors brighter than the
+;; white point are set to the maximum quantum value.
+(defmagick* MagickLevelImageChannel :
+  _MagickWand _ChannelType
+  (black-point : _double*) (gamma : _double*) (white-point : _double*)
+  -> _status)
+
+;; MagickMagnifyImage is a convenience method that scales an image
+;; proportionally to twice its original size.
+(defmagick* MagickMagnifyImage :
+  _MagickWand -> _status)
+
+;; MagickMapImage replaces the colors of an image with the closest color from a
+;; reference image.
+(defmagick* MagickMapImage :
+  _MagickWand (mapping : _MagickWand) (dither? : _bool) -> _status)
+
+;; MagickMatteFloodfillImage changes the transparency value of any pixel that
+;; matches target and is an immediate neighbor.  If the method
+;; FillToBorderMethod is specified, the transparency value is changed for any
+;; neighbor pixel that does not match the bordercolor member of image.
+(defmagick* MagickMatteFloodfillImage :
+  _MagickWand
+  (opacity : _Quantum) (fuzz : _double*) (border : _PixelWand)
+  (x : _long) (y : _long)
+  -> _status)
+
+;; MagickMedianFilterImage applies a digital filter that improves the quality
+;; of a noisy image.  Each pixel is replaced by the median in a set of
+;; neighboring pixels as defined by radius.
+(defmagick* MagickMedianFilterImage :
+  _MagickWand (radius : _double*) -> _status)
+
+;; MagickMinifyImage is a convenience method that scales an image
+;; proportionally to one-half its original size
+(defmagick* MagickMinifyImage :
+  _MagickWand -> _status)
+
+;; MagickModulateImage lets you control the brightness, saturation, and hue of
+;; an image.
+(defmagick* MagickModulateImage :
+  _MagickWand (brightness : _double*) (saturation : _double*) (hue : _double*)
+  -> _status)
+
+;; Use MagickMontageImage to create a composite image by combining several
+;; separate images.  The images are tiled on the composite image with the name
+;; of the image optionally appearing just below the individual tile.
+(defmagick* MagickMontageImage :
+  _MagickWand _DrawingWand
+  (tile-geometry : _string) (thumbnail-geometry : _string)
+  _MontageMode (frame-geometry : _string) -> _MagickWand)
+
+;; MagickMorphImages method morphs a set of images.  Both the image pixels and
+;; size are linearly interpolated to give the appearance of a meta-morphosis
+;; from one image to the next.
+(defmagick* MagickMorphImages :
+  _MagickWand (num-of-frames : _ulong) -> _MagickWand)
+
+;; MagickMosaicImages inlays an image sequence to form a single coherent
+;; picture.  It returns a wand with each image in the sequence composited at
+;; the location defined by the page offset of the image.
+(defmagick* MagickMosaicImages :
+  _MagickWand -> _MagickWand)
+
+;; MagickMotionBlurImage simulates motion blur.  We convolve the image with a
+;; Gaussian operator of the given radius and standard deviation (sigma).  For
+;; reasonable results, radius should be larger than sigma.  Use a radius of 0
+;; and MagickMotionBlurImage selects a suitable radius for you.  Angle gives
+;; the angle of the blurring motion.
+(defmagick* MagickMotionBlurImage :
+  _MagickWand (radius : _double*) (sigma : _double*) (angle : _double*)
+  -> _status)
+
+;; MagickNegateImage negates the colors in the reference image.  The Grayscale
+;; option means that only grayscale values within the image are negated.
+(defmagick* MagickNegateImage :
+  _MagickWand (gray? : _bool) -> _status)
+
+;; MagickNegateImageChannel negates the colors in the specified channel of the
+;; reference image.  The Grayscale option means that only grayscale values
+;; within the image are negated.  You can also reduce the influence of a
+;; particular channel with a gamma value of 0.
+(defmagick* MagickNegateImageChannel :
+  _MagickWand _ChannelType (gray? : _bool) -> _status)
+
+;; MagickNextImage associates the next image in the image list with a magick
+;; wand.
+(defmagick* MagickNextImage :
+  _MagickWand -> _status)
+
+;; MagickNormalizeImage enhances the contrast of a color image by adjusting the
+;; pixels color to span the entire range of colors available
+(defmagick* MagickNormalizeImage :
+  _MagickWand -> _status)
+
+;; MagickOilPaintImage applies a special effect filter that simulates an oil
+;; painting.  Each pixel is replaced by the most frequent color occurring in a
+;; circular region defined by radius.
+(defmagick* MagickOilPaintImage :
+  _MagickWand _double* -> _status)
+
+;; MagickOpaqueImage changes any pixel that matches color with the color
+;; defined by fill.
+(defmagick* MagickOpaqueImage :
+  _MagickWand (target : _PixelWand) (fill : _PixelWand) (fuzz : _double*)
+  -> _status)
+
+;; MagickPingImage is like MagickReadImage except the only valid information
+;; returned is the image width, height, size, and format.  It is designed to
+;; efficiently obtain this information from a file without reading the entire
+;; image sequence into memory.
+(defmagick* MagickPingImage :
+  _MagickWand _file -> _status)
+
+;; MagickPosterizeImage reduces the image to a limited number of color level.
+(defmagick* MagickPosterizeImage :
+  _MagickWand (levels : _ulong) (dither? : _bool) -> _status)
+
+;; MagickPreviewImages tiles 9 thumbnails of the specified image with an image
+;; processing operation applied at varying strengths.  This is helpful to
+;; quickly pin-point an appropriate parameter for an image processing
+;; operation.
+(defmagick* MagickPreviewImages :
+  _MagickWand _PreviewType -> _MagickWand)
+
+;; MagickPreviousImage assocates the previous image in an image list with the
+;; magick wand.
+(defmagick* MagickPreviousImage :
+  _MagickWand -> _status)
+
+;; Use MagickProfileImage to add or remove a ICC, IPTC, or generic profile from
+;; an image.  If the profile is #f (NULL), it is removed from the image
+;; otherwise added.  Use a name of '*' and a profile of NULL to remove all
+;; profiles from the image.
+(defmagick* MagickProfileImage :
+  _MagickWand (profile-name : _string)
+  (profile : _bytes) (_ulong = (string-length profile))
+  -> _status)
+
+;; MagickQuantizeImage analyzes the colors within a reference image and chooses
+;; a fixed number of colors to represent the image.  The goal of the algorithm
+;; is to minimize the color difference between the input and output image while
+;; minimizing the processing time.
+(defmagick* MagickQuantizeImage :
+  _MagickWand (num-colors : _ulong) _ColorspaceType (tree-depth : _ulong)
+  (dither? : _bool) (measure-error? : _bool)
+  -> _status)
+
+;; MagickQuantizeImages analyzes the colors within a sequence of images and
+;; chooses a fixed number of colors to represent the image.  The goal of the
+;; algorithm is to minimize the color difference between the input and output
+;; image while minimizing the processing time.
+(defmagick* MagickQuantizeImages :
+  _MagickWand
+  (num-colors : _ulong) _ColorspaceType (tree-depth : _ulong)
+  (dither? : _bool) (measure-error? : _bool)
+  -> _status)
+
+;; MagickQueryConfigureOptions returns any configure options that match the
+;; specified pattern (e.g. "*" for all).  Options include NAME, VERSION,
+;; LIB_VERSION, etc.
+(defmagick* MagickQueryConfigureOptions :
+  (pattern : _string) (len : (_ptr o _ulong)) -> (_list o _string len))
+
+;; MagickQueryFontMetrics returns a 7 element list representing the following
+;; font metrics: char-width, char-height, ascender, descender, text-width,
+;; text-height, max-horizontal-advance.
+(defmagick* MagickQueryFontMetrics :
+  _MagickWand _DrawingWand (text : _string) -> (_list o _double* 7))
+
+;; MagickQueryFonts returns any font that match the specified pattern (e.g. "*"
+;; for all).
+(defmagick* MagickQueryFonts :
+  (pattern : _string) (len : (_ptr o _ulong)) -> (_list o _string len))
+
+;; MagickQueryFormats returns any image formats that match the specified
+;; pattern (e.g. "*" for all).
+(defmagick* MagickQueryFormats :
+  (pattern : _string) (len : (_ptr o _ulong)) -> (_list o _string len))
+
+;; MagickRadialBlurImage radial blurs an image.
+(defmagick* MagickRadialBlurImage :
+  _MagickWand (angle : _double*) -> _status)
+
+;; MagickRaiseImage creates a simulated three-dimensional button-like effect by
+;; lightening and darkening the edges of the image.  Members width and height
+;; of raise_info define the width of the vertical and horizontal edge of the
+;; effect.
+(defmagick* MagickRaiseImage :
+  _MagickWand
+  (width : _ulong) (height : _ulong) (x : _long) (y : _long) (raise? : _bool)
+  -> _status)
+
+;; MagickReadImage reads an image or image sequence.
+;; Extended: the wand argument is optional -- will be made and returned if not
+;; given.
+(defmagick* MagickReadImage :
+  (arg . args) ::
+  (w : _MagickWand = (if (null? args) (NewMagickWand) arg))
+  (_file = (if (null? args) arg (car args)))
+  -> _status
+  -> (if (null? args) w))
+
+;; MagickReadImageBlob reads an image or image sequence from a blob.
+(defmagick* MagickReadImageBlob :
+  _MagickWand (blob : _bytes) (_ulong = (string-length blob)) -> _status)
+
+;; MagickReadImageFile reads an image or image sequence from an open file
+;; descriptor.
+(defmagick* MagickReadImageFile :
+  _MagickWand (FILE* : _pointer) -> _status)
+
+;; MagickReduceNoiseImage smooths the contours of an image while still
+;; preserving edge information.  The algorithm works by replacing each pixel
+;; with its neighbor closest in value.  A neighbor is defined by radius.  Use a
+;; radius of 0 and MagickReduceNoiseImage selects a suitable radius for you.
+(defmagick* MagickReduceNoiseImage :
+  _MagickWand (radius : _double*) -> _status)
+
+;; MagickRelinquishMemory relinquishes memory resources returned by such
+;; methods as MagickDescribeImage, MagickGetException, etc.
+;; Looks like this is not needed with a GC (tried it with the result of
+;; MagickDescribeImage many times, got an error).
+;; (defmagick* MagickRelinquishMemory :
+;;   _pointer -> _status)
+
+;; MagickRemoveImage removes an image from the image list.
+(defmagick* MagickRemoveImage :
+  _MagickWand -> _status)
+
+;; MagickRemoveImageProfile removes the named image profile and returns it.
+(defmagick* MagickRemoveImageProfile :
+  _MagickWand (profile-name : _string) (len : (_ptr o _ulong))
+  -> (_bytes o len))
+
+;; MagickResampleImage resample image to desired resolution.  Most of the
+;; filters are FIR (finite impulse response), however, Bessel, Gaussian, and
+;; Sinc are IIR (infinite impulse response).  Bessel and Sinc are windowed
+;; (brought down to zero) with the Blackman filter.
+(defmagick* MagickResampleImage :
+  _MagickWand
+  (x-res : _double*) (y-res : _double*) _FilterTypes (blur-factor : _double*)
+  -> _status)
+
+;; MagickResetIterator resets the wand iterator.  Use it in conjunction with
+;; MagickNextImage to iterate over all the images in a wand container.
+(defmagick* MagickResetIterator :
+  _MagickWand -> _void)
+
+;; MagickResizeImage scales an image to the desired dimensions with some
+;; filter.  Most of the filters are FIR (finite impulse response), however,
+;; Bessel, Gaussian, and Sinc are IIR (infinite impulse response).  Bessel and
+;; Sinc are windowed (brought down to zero) with the Blackman filter.
+(defmagick* MagickResizeImage :
+  _MagickWand
+  (width : _ulong) (height : _ulong) _FilterTypes (blur-factor : _double*)
+  -> _status)
+
+;; MagickRollImage offsets an image as defined by x_offset and y_offset.
+(defmagick* MagickRollImage :
+  _MagickWand (x-offset : _long) (y-offset : _long) -> _status)
+
+;; MagickRotateImage rotates an image the specified number of degrees.  Empty
+;; triangles left over from rotating the image are filled with the background
+;; color.
+(defmagick* MagickRotateImage :
+  _MagickWand (background : _PixelWand) (degrees : _double*) -> _status)
+
+;; MagickSampleImage scales an image to the desired dimensions with pixel
+;; sampling.  Unlike other scaling methods, this method does not introduce any
+;; additional color into the scaled image.
+(defmagick* MagickSampleImage :
+  _MagickWand (width : _ulong) (height : _ulong) -> _status)
+
+;; MagickScaleImage scales the size of an image to the given dimensions.
+(defmagick* MagickScaleImage :
+  _MagickWand (width : _ulong) (height : _ulong) -> _status)
+
+;; MagickSeparateImageChannel separates a channel from the image and returns a
+;; grayscale image.  A channel is a particular color component of each pixel in
+;; the image.
+(defmagick* MagickSeparateImageChannel :
+  _MagickWand _ChannelType -> _status)
+
+;; MagickSetFilename sets the filename before you read or write an image file.
+(defmagick* MagickSetFilename :
+  _MagickWand _file -> _status)
+
+;; MagickSetImage replaces the last image returned by MagickSetImageIndex,
+;; MagickNextImage, MagickPreviousImage with the images from the specified
+;; wand.
+(defmagick* MagickSetImage :
+  _MagickWand (set-wand : _MagickWand) -> _status)
+
+;; MagickSetImageBackgroundColor sets the image background color.
+(defmagick* MagickSetImageBackgroundColor :
+  _MagickWand (background : _PixelWand) -> _status)
+
+;; MagickSetImageBluePrimary sets the image chromaticity blue primary point.
+(defmagick* MagickSetImageBluePrimary :
+  _MagickWand (x : _double*) (y : _double*) -> _status)
+
+;; MagickSetImageBorderColor sets the image border color.
+(defmagick* MagickSetImageBorderColor :
+  _MagickWand (border-color : _PixelWand) -> _status)
+
+;; MagickSetImageChannelDepth sets the depth of a particular image channel.
+(defmagick* MagickSetImageChannelDepth :
+  _MagickWand _ChannelType (depth : _ulong) -> _status)
+
+;; MagickSetImageColormapColor sets the color of the specified colormap index.
+(defmagick* MagickSetImageColormapColor :
+  _MagickWand (index : _ulong) _PixelWand -> _status)
+
+;; MagickSetImageColorspace sets the image colorspace.
+(defmagick* MagickSetImageColorspace :
+  _MagickWand _ColorspaceType -> _status)
+
+;; MagickSetImageCompose sets the image composite operator, useful for
+;; specifying how to composite the image thumbnail when using the
+;; MagickMontageImage method.
+(defmagick* MagickSetImageCompose :
+  _MagickWand _CompositeOperator -> _status)
+
+;; MagickSetImageCompression sets the image compression.
+(defmagick* MagickSetImageCompression :
+  _MagickWand _CompressionType -> _status)
+
+;; MagickSetImageCompressionQuality sets the image compression quality.
+(defmagick* MagickSetImageCompressionQuality :
+  _MagickWand (quality : _ulong) -> _status)
+
+;; MagickSetImageDelay sets the image delay.
+(defmagick* MagickSetImageDelay :
+  _MagickWand (delay : _ulong) -> _status)
+
+;; MagickSetImageDepth sets the image depth.
+(defmagick* MagickSetImageDepth :
+  _MagickWand (depth : _ulong) -> _status)
+
+;; MagickSetImageDispose sets the image disposal method.
+(defmagick* MagickSetImageDispose :
+  _MagickWand _DisposeType -> _status)
+
+;; MagickSetImageFilename sets the filename of a particular image in a
+;; sequence.
+(defmagick* MagickSetImageFilename :
+  _MagickWand _file -> _status)
+
+;; MagickSetImageGamma sets the image gamma.
+(defmagick* MagickSetImageGamma :
+  _MagickWand (gamma : _double*) -> _status)
+
+;; MagickSetImageGreenPrimary sets the image chromaticity green primary point.
+(defmagick* MagickSetImageGreenPrimary :
+  _MagickWand (y : _double*) (x : _double*) -> _status)
+
+;; MagickSetImageIndex replaces the last image returned by MagickSetImageIndex,
+;; MagickNextImage, MagickPreviousImage with the images from the specified
+;; wand.
+(defmagick* MagickSetImageIndex :
+  _MagickWand (index : _long) -> _status)
+
+;; MagickSetImageInterlaceScheme sets the image interlace scheme.
+(defmagick* MagickSetImageInterlaceScheme :
+  _MagickWand _InterlaceType -> _status)
+
+;; MagickSetImageIterations sets the image iterations.
+(defmagick* MagickSetImageIterations :
+  _MagickWand (iterations : _ulong) -> _status)
+
+;; MagickSetImageMatteColor sets the image matte color.
+(defmagick* MagickSetImageMatteColor :
+  _MagickWand (matte : _PixelWand) -> _status)
+
+;; MagickSetImageOption associates one or options with a particular image
+;; format (e.g. (MagickSetImageOption wand "jpeg" "perserve" "yes")).
+(defmagick* MagickSetImageOption :
+  _MagickWand (format : _string) (key : _string) (value : _string) -> _status)
+
+;; MagickSetImagePixels accepts pixel data and stores it in the image at the
+;; location you specify.  The method returns False on success otherwise True if
+;; an error is encountered.  The pixel data can be either char, short int, int,
+;; long, float, or double in the order specified by map.  Suppose your want
+;; want to upload the first scanline of a 640x480 image from character data in
+;; red-green-blue order:
+;;     (MagickSetImagePixels wand 0 0 640 1 "RGB" 'CharPixel pixels)
+;; `map' is a string that reflects the expected ordering of the pixel array.
+;; It can be any combination or order of R = red, G = green, B = blue,
+;; A = alpha (0 is transparent), O = opacity (0 is opaque), C = cyan,
+;; Y = yellow, M = magenta, K = black, I = intensity (for grayscale), P = pad.
+;; Note: the scheme interface uses a list of rows, each a list of values for
+;; each element in the map.  Also, the map here should not have the type
+;; character as in the MagickWand API (it is a documentation bug), and there is
+;; no need for width and height too.
+(defmagick* MagickSetImagePixels :
+  (w x y map storage-type matrix) ::
+  (w : _MagickWand) (x : _long) (y : _long)
+  (width : _ulong = (length (car matrix))) (height : _ulong = (length matrix))
+  (map : _string) (storage-type : _StorageType)
+  (_pointer = (let* ([size   (* width height (string-length map))]
+                     [type   (StorageType->type storage-type)]
+                     [block  (malloc size type)])
+                (let loop ([m matrix] [n 0])
+                  (cond [(null? m) n]
+                        [(pair? m) (loop (cdr m) (loop (car m) n))]
+                        [else (ptr-set! block type n m) (add1 n)]))
+                block))
+  -> _status)
+
+;; MagickSetImageProfile adds a named profile to the magick wand.  If a profile
+;; with the same name already exists, it is replaced.  This method differs from
+;; the MagickProfileImage method in that it does not apply any CMS color
+;; profiles.
+(defmagick* MagickSetImageProfile :
+  _MagickWand (profile-name : _string)
+  (profile : _bytes) (_ulong = (string-length profile))
+  -> _status)
+
+;; MagickSetImageRedPrimary sets the image chromaticity red primary point.
+(defmagick* MagickSetImageRedPrimary :
+  _MagickWand (x : _double*) (y : _double*) -> _status)
+
+;; MagickSetImageRenderingIntent sets the image rendering intent.
+(defmagick* MagickSetImageRenderingIntent :
+  _MagickWand _RenderingIntent -> _status)
+
+;; MagickSetImageResolution sets the image resolution.
+(defmagick* MagickSetImageResolution :
+  _MagickWand (res-x : _double*) (res-y : _double*) -> _status)
+
+;; MagickSetImageScene sets the image scene.
+(defmagick* MagickSetImageScene :
+  _MagickWand (schene-number : _ulong) -> _status)
+
+;; MagickSetImageType sets the image type.
+(defmagick* MagickSetImageType :
+  _MagickWand _ImageType -> _status)
+
+;; MagickSetImageUnits sets the image units of resolution.
+(defmagick* MagickSetImageUnits :
+  _MagickWand _ResolutionType -> _status)
+
+;; MagickSetImageVirtualPixelMethod sets the image virtual pixel method.
+(defmagick* MagickSetImageVirtualPixelMethod :
+  _MagickWand _VirtualPixelMethod -> _status)
+
+;; MagickSetImageWhitePoint sets the image chromaticity white point.
+(defmagick* MagickSetImageWhitePoint :
+  _MagickWand (x : _double*) (y : _double*) -> _status)
+
+;; MagickSetInterlaceScheme sets the image compression.
+(defmagick* MagickSetInterlaceScheme :
+  _MagickWand _InterlaceType -> _status)
+
+;; MagickSetPassphrase sets the passphrase.
+(defmagick* MagickSetPassphrase :
+  _MagickWand (passphrase : _string) -> _status)
+
+;; MagickSetResourceLimit sets the limit for a particular resource in
+;; megabytes.
+(defmagick* MagickSetResourceLimit :
+  _ResourceType (limit : _ulong) -> _status)
+
+;; MagickSetSamplingFactors sets the image sampling factors.
+(defmagick* MagickSetSamplingFactors :
+  (w factors) ::
+  (w : _MagickWand) (_ulong = (length factors)) (factors : (_list i _double*))
+  -> _status)
+
+;; MagickSetSize sets the size of the magick wand.  Set it before you read a
+;; raw image format such as RGB, GRAY, or CMYK.
+(defmagick* MagickSetSize :
+  _MagickWand (width : _ulong) (height : _ulong) -> _status)
+
+;; MagickSharpenImage sharpens an image.  We convolve the image with a Gaussian
+;; operator of the given radius and standard deviation (sigma).  For reasonable
+;; results, the radius should be larger than sigma.  Use a radius of 0 and
+;; SharpenImage selects a suitable radius for you.
+(defmagick* MagickSharpenImage :
+  _MagickWand (radius : _double*) (sigma : _double*) -> _status)
+
+;; MagickSharpenImageChannel sharpens one or more image channels.  We convolve
+;; the image cnannel with a gaussian operator of the given radius and standard
+;; deviation (sigma).  For reasonable results, the radius should be larger than
+;; sigma.  Use a radius of 0 and GaussinSharpenImageChannel selects a suitable
+;; radius for you.
+(defmagick* MagickSharpenImageChannel :
+  _MagickWand _ChannelType (radius : _double*) (sigma : _double*) -> _status)
+
+;; MagickShaveImage shaves pixels from the image edges.  It allocates the
+;; memory necessary for the new Image structure and returns a pointer to the
+;; new image.
+(defmagick* MagickShaveImage :
+  _MagickWand (width : _ulong) (height : _ulong) -> _status)
+
+;; MagickShearImage slides one edge of an image along the X or Y axis, creating
+;; a parallelogram.  An X direction shear slides an edge along the X axis,
+;; while a Y direction shear slides an edge along the Y axis.  The amount of
+;; the shear is controlled by a shear angle.  For X direction shears, x_shear
+;; is measured relative to the Y axis, and similarly, for Y direction shears
+;; y_shear is measured relative to the X axis.  Empty triangles left over from
+;; shearing the image are filled with the background color.
+(defmagick* MagickShearImage :
+  _MagickWand (background : _PixelWand)
+  (x-shear : _double*) (y-shear : _double*)
+  -> _status)
+
+;; MagickSolarizeImage applies a special effect to the image, similar to the
+;; effect achieved in a photo darkroom by selectively exposing areas of photo
+;; sensitive paper to light.  Threshold ranges from 0 to MaxRGB and is a
+;; measure of the extent of the solarization.
+(defmagick* MagickSolarizeImage :
+  _MagickWand (threshold : _double*) -> _status)
+
+;; MagickSpliceImage splices a solid color into the image.
+(defmagick* MagickSpliceImage :
+  _MagickWand (width : _ulong) (height : _ulong) (x : _long) (y : _long)
+  -> _status)
+
+;; MagickSpreadImage is a special effects method that randomly displaces each
+;; pixel in a block defined by the radius parameter.
+(defmagick* MagickSpreadImage :
+  _MagickWand (radius : _double*) -> _status)
+
+;; Use MagickSteganoImage to hide a digital watermark within the image.
+;; Recover the hidden watermark later to prove that the authenticity of an
+;; image.  Offset defines the start position within the image to hide the
+;; watermark.
+(defmagick* MagickSteganoImage :
+  _MagickWand (watermark : _MagickWand) (offset : _long) -> _MagickWand)
+
+;; MagickStereoImage composites two images and produces a single image that is
+;; the composite of a left and right image of a stereo pair.
+(defmagick* MagickStereoImage :
+  _MagickWand (offset : _MagickWand) -> _MagickWand)
+
+;; MagickStripImage strips an image of all profiles and comments.
+(defmagick* MagickStripImage :
+  _MagickWand -> _status)
+
+;; MagickSwirlImage swirls the pixels about the center of the image, where
+;; degrees indicates the sweep of the arc through which each pixel is moved.
+;; You get a more dramatic effect as the degrees move from 1 to 360.
+(defmagick* MagickSwirlImage :
+  _MagickWand (degrees : _double*) -> _status)
+
+;; MagickTextureImage repeatedly tiles the texture image across and down the
+;; image canvas.
+(defmagick* MagickTextureImage :
+  _MagickWand (texture : _MagickWand) -> _MagickWand)
+
+;; MagickThresholdImage changes the value of individual pixels based on the
+;; intensity of each pixel compared to threshold.  The result is a
+;; high-contrast, two color image.
+(defmagick* MagickThresholdImage :
+  _MagickWand _double* -> _status)
+
+;; MagickThresholdImageChannel changes the value of individual pixel component
+;; based on the intensity of each pixel compared to threshold.  The result is a
+;; high-contrast, two color image.
+(defmagick* MagickThresholdImageChannel :
+  _MagickWand _ChannelType (threshold : _double*) -> _status)
+
+;; MagickTintImage applies a color vector to each pixel in the image.  The
+;; length of the vector is 0 for black and white and at its maximum for the
+;; midtones.  The vector weighting function is
+;; f(x)=(1-(4.0*((x-0.5)*(x-0.5)))).
+(defmagick* MagickTintImage :
+  _MagickWand (tint : _PixelWand) (opacity : _PixelWand) -> _status)
+
+;; MagickTransformImage is a convenience method that behaves like
+;; MagickResizeImage or MagickCropImage but accepts scaling and/or cropping
+;; information as a region geometry specification.  If the operation fails, the
+;; original image handle is returned.
+(defmagick* MagickTransformImage :
+  _MagickWand (crop-geometry : _string) (image-geometry : _string)
+  -> _MagickWand)
+
+;; MagickTransparentImage changes any pixel that matches color with the color
+;; defined by fill.
+(defmagick* MagickTransparentImage :
+  _MagickWand (target : _PixelWand) (opacity : _Quantum) (fuzz : _double*)
+  -> _status)
+
+;; MagickTrimImage remove edges that are the background color from the image.
+(defmagick* MagickTrimImage :
+  _MagickWand (fuzz : _double*) -> _status)
+
+;; MagickUnsharpMaskImage sharpens an image.  We convolve the image with a
+;; Gaussian operator of the given radius and standard deviation (sigma).  For
+;; reasonable results, radius should be larger than sigma.  Use a radius of 0
+;; and UnsharpMaskImage selects a suitable radius for you.
+(defmagick* MagickUnsharpMaskImage :
+  _MagickWand (radius : _double*) (sigma : _double*)
+  (amount-precentage : _double*) (threshold : _double*)
+  -> _status)
+
+;; MagickWaveImage creates a "ripple" effect in the image by shifting the
+;; pixels vertically along a sine wave whose amplitude and wavelength is
+;; specified by the given parameters.
+(defmagick* MagickWaveImage :
+  _MagickWand (amplitude : _double*) (wave-length : _double*) -> _status)
+
+;; MagickWhiteThresholdImage is like ThresholdImage but forces all pixels above
+;; the threshold into white while leaving all pixels below the threshold
+;; unchanged.
+(defmagick* MagickWhiteThresholdImage :
+  _MagickWand _PixelWand -> _status)
+
+;; MagickWriteImage writes an image.
+(defmagick* MagickWriteImage :
+  _MagickWand _file -> _status)
+
+;; MagickGetImageBlob implements direct to memory image formats.  It returns
+;; the image as a blob and its length.  The magick member of the Image
+;; structure determines the format of the returned blob (GIF, JPEG, PNG, etc.)
+(defmagick* MagickGetImageBlob :
+  _MagickWand (len : (_ptr o _ulong)) -> (_bytes o len))
+
+;; MagickWriteImageFile writes an image to an open file descriptor.
+(defmagick* MagickWriteImageFile :
+  _MagickWand (FILE* : _pointer) -> _status)
+
+;; MagickWriteImages writes an image or image sequence.
+(defmagick* MagickWriteImages :
+  _MagickWand _file (adjoin? : _bool) -> _status)
+
+;; NewMagickWand returns a wand required for all other methods in the API.
+(defmagick* NewMagickWand :
+  -> _MagickWand)
+
+;; ===== PixelIterator API ====================================================
+
+;; DestroyPixelIterator deallocates resources associated with a PixelIterator.
+(defmagick DestroyPixelIterator :
+  _PixelIterator -> _void)
+
+;; NewPixelIterator returns a new pixel iterator.
+(defmagick* NewPixelIterator :
+  (w : _MagickWand) -> (pi : _PixelIterator)
+  -> (begin (set-PixelIterator-width! pi (MagickGetImageWidth w)) pi))
+
+;; NewPixelRegionIterator returns a new pixel iterator.
+(defmagick* NewPixelRegionIterator :
+  _MagickWand (x : _long) (y : _long) (width : _ulong) (height : _ulong)
+  -> (pi : _PixelIterator)
+  -> (begin (set-PixelIterator-width! pi width) pi))
+
+;; PixelIteratorGetException returns the severity, reason, and description of
+;; any error that occurs when using other methods in this API.
+(defmagick* PixelIteratorGetException :
+  _PixelIterator (severity : (_ptr o _MagickExceptionType))
+  -> (message : _string)
+  -> (unless (eq? severity 'UndefinedException)
+       (error 'PixelIterator "(~a) ~a" severity message)))
+
+;; PixelGetNextRow returns the next row from the pixel iterator.
+(defmagick* PixelGetNextRow :
+  (pi : _PixelIterator) -> (_list o _PixelWand (PixelIterator-width pi)))
+
+;; PixelResetIterator resets the pixel iterator.  Use it in conjunction with
+;; PixelGetNextPixel to iterate over all the pixels in a pixel container.
+(defmagick* PixelResetIterator :
+  _PixelIterator -> _void)
+
+;; PixelSetIteratorRow set the pixel iterator row.
+(defmagick* PixelSetIteratorRow :
+  (pi : _PixelIterator) (row : _long) -> _status)
+
+;; PixelSyncIterator syncs the pixel iterator.
+(defmagick* PixelSyncIterator :
+  _PixelIterator -> _status)
+
+;; ===== PixelWand API ========================================================
+
+;; PixelGetException returns the severity, reason, and description of any error
+;; that occurs when using other methods in this API (as an exception).
+(defmagick* PixelGetException :
+  _MagickWand (severity : (_ptr o _MagickExceptionType)) -> (message : _string)
+  -> (unless (eq? severity 'UndefinedException)
+       (error 'PixelWand "(~a) ~a" severity message)))
+
+;; DestroyPixelWand deallocates resources associated with a PixelWand.
+;; Intended for internal use only, must be defined after the above.
+(defmagick DestroyPixelWand :
+  _PixelWand -> _void)
+
+;; DestroyPixelWands deallocates resources associated with an array of
+;; pixel wands.
+;; * There is no need for this
+
+;; NewPixelWand returns a new pixel wand.
+;; Extended: can get a color name to use for the new pixel wand, or an RGB list
+;; (integers or floats determine the method to use for setting the values), or
+;; a CMYK list.  (See also the _PixelWand type definition).
+(defmagick* NewPixelWand :
+  init-color ::
+  -> (p : _PixelWand)
+  -> (let ([color (and (pair? init-color) (car init-color))])
+       (define (err) (error 'NewPixelWand "bad initial color: ~e" color))
+       (cond [(null? init-color)]
+             [(string? color) (PixelSetColor p color)]
+             [(list? color)
+              (let ([len (length color)]
+                    [ints? (andmap integer? color)]
+                    [flts? (andmap inexact? color)])
+                (if (or ints? flts?)
+                  (let ([len (if flts? (- len) len)])
+                    (case len
+                      [(3)  (PixelSetRedQuantum     p (car color))
+                            (PixelSetGreenQuantum   p (cadr color))
+                            (PixelSetBlueQuantum    p (caddr color))]
+                      [(-3) (PixelSetRed            p (car color))
+                            (PixelSetGreen          p (cadr color))
+                            (PixelSetBlue           p (caddr color))]
+                      [(4)  (PixelSetCyanQuantum    p (car color))
+                            (PixelSetMagentaQuantum p (cadr color))
+                            (PixelSetYellowQuantum  p (caddr color))
+                            (PixelSetBlackQuantum   p (cadddr color))]
+                      [(-4) (PixelSetCyan           p (car color))
+                            (PixelSetMagenta        p (cadr color))
+                            (PixelSetYellow         p (caddr color))
+                            (PixelSetBlack          p (cadddr color))]
+                      [else (err)]))
+                  (err)))]
+             [else (err)])
+            p))
+
+;; NewPixelWands returns an array of pixel wands.
+;; * There is no need for this
+
+;; PixelGetBlack returns the normalized black color of the pixel wand.
+(defmagick* PixelGetBlack :
+  _PixelWand -> _double*)
+
+;; PixelGetBlackQuantum returns the black color of the pixel wand.  The color
+;; is in the range of [0..MaxRGB].
+(defmagick* PixelGetBlackQuantum :
+  _PixelWand -> _Quantum)
+
+;; PixelGetBlue returns the normalized blue color of the pixel wand.
+(defmagick* PixelGetBlue :
+  _PixelWand -> _double*)
+
+;; PixelGetBlueQuantum returns the blue color of the pixel wand.  The color is
+;; in the range of [0..MaxRGB].
+(defmagick* PixelGetBlueQuantum :
+  _PixelWand -> _Quantum)
+
+;; PixelGetColorAsString gets the color of the pixel wand.
+(defmagick* PixelGetColorAsString :
+  _PixelWand -> _string)
+
+;; PixelGetColorCount returns the color count associated with this color.
+(defmagick* PixelGetColorCount :
+  _PixelWand -> _ulong)
+
+;; PixelGetCyan returns the normalized cyan color of the pixel wand.
+(defmagick* PixelGetCyan :
+  _PixelWand -> _double*)
+
+;; PixelGetCyanQuantum returns the cyan color of the pixel wand.  The color is
+;; in the range of [0..MaxRGB].
+(defmagick* PixelGetCyanQuantum :
+  _PixelWand -> _Quantum)
+
+;; PixelGetGreen returns the normalized green color of the pixel wand.
+(defmagick* PixelGetGreen :
+  _PixelWand -> _double*)
+
+;; PixelGetGreenQuantum returns the green color of the pixel wand.  The color
+;; is in the range of [0..MaxRGB].
+(defmagick* PixelGetGreenQuantum :
+  _PixelWand -> _Quantum)
+
+;; PixelGetIndex returns the colormap index from the pixel wand.
+(defmagick* PixelGetIndex :
+  _PixelWand -> _IndexPacket)
+
+;; PixelGetMagenta returns the normalized magenta color of the pixel wand.
+(defmagick* PixelGetMagenta :
+  _PixelWand -> _double*)
+
+;; PixelGetMagentaQuantum returns the magenta color of the pixel wand.  The
+;; color is in the range of [0..MaxRGB].
+(defmagick* PixelGetMagentaQuantum :
+  _PixelWand -> _Quantum)
+
+;; PixelGetOpacity returns the normalized opacity color of the pixel wand.
+(defmagick* PixelGetOpacity :
+  _PixelWand -> _double*)
+
+;; PixelGetOpacityQuantum returns the opacity color of the pixel wand.  The
+;; color is in the range of [0..MaxRGB].
+(defmagick* PixelGetOpacityQuantum :
+  _PixelWand -> _Quantum)
+
+;; PixelGetQuantumColor gets the color of the pixel wand.
+(defmagick* PixelGetQuantumColor :
+  _PixelWand (color : _PixelPacket = (NewPixelPacket)) -> _void
+  -> color)
+
+;; PixelGetRed returns the normalized red color of the pixel wand.
+(defmagick* PixelGetRed :
+  _PixelWand -> _double*)
+
+;; PixelGetRedQuantum returns the red color of the pixel wand.  The color is in
+;; the range of [0..MaxRGB].
+(defmagick* PixelGetRedQuantum :
+  _PixelWand -> _Quantum)
+
+;; PixelGetYellow returns the normalized yellow color of the pixel wand.
+(defmagick* PixelGetYellow :
+  _PixelWand -> _double*)
+
+;; PixelGetYellowQuantum returns the yellow color of the pixel wand.  The color
+;; is in the range of [0..MaxRGB].
+(defmagick* PixelGetYellowQuantum :
+  _PixelWand -> _Quantum)
+
+;; PixelSetBlack sets the normalized black color of the pixel wand.
+(defmagick* PixelSetBlack :
+  _PixelWand (black : _double*) -> _void)
+
+;; PixelSetBlackQuantum sets the black color of the pixel wand.  The color must
+;; be in the range of [0..MaxRGB].
+(defmagick* PixelSetBlackQuantum :
+  _PixelWand (black : _Quantum) -> _void)
+
+;; PixelSetBlue sets the normalized blue color of the pixel wand.
+(defmagick* PixelSetBlue :
+  _PixelWand (blue : _double*) -> _void)
+
+;; PixelSetBlueQuantum sets the blue color of the pixel wand.  The color must
+;; be in the range of [0..MaxRGB].
+(defmagick* PixelSetBlueQuantum :
+  _PixelWand (blue : _Quantum) -> _void)
+
+;; PixelSetColor sets the color of the pixel wand with a string (e.g. "blue",
+;; "#0000ff", "rgb(0,0,255)", "cmyk(100,100,100,10)", etc.).
+(defmagick* PixelSetColor :
+  _PixelWand (color : _string) -> _status)
+
+;; PixelSetColorCount sets the color count of the pixel wand.
+(defmagick* PixelSetColorCount :
+  _PixelWand (count : _ulong) -> _void)
+
+;; PixelSetCyan sets the normalized cyan color of the pixel wand.
+(defmagick* PixelSetCyan :
+  _PixelWand (cyan : _double*) -> _void)
+
+;; PixelSetCyanQuantum sets the cyan color of the pixel wand.  The color must
+;; be in the range of [0..MaxRGB].
+(defmagick* PixelSetCyanQuantum :
+  _PixelWand (cyan : _Quantum) -> _void)
+
+;; PixelSetGreen sets the normalized green color of the pixel wand.
+(defmagick* PixelSetGreen :
+  _PixelWand (green : _double*) -> _void)
+
+;; PixelSetGreenQuantum sets the green color of the pixel wand.  The color must
+;; be in the range of [0..MaxRGB].
+(defmagick* PixelSetGreenQuantum :
+  _PixelWand (green : _Quantum) -> _void)
+
+;; PixelSetIndex sets the colormap index of the pixel wand.
+(defmagick* PixelSetIndex :
+  _PixelWand _IndexPacket -> _void)
+
+;; PixelSetMagenta sets the normalized magenta color of the pixel wand.
+(defmagick* PixelSetMagenta :
+  _PixelWand (magenta : _double*) -> _void)
+
+;; PixelSetMagentaQuantum sets the magenta color of the pixel wand.  The color
+;; must be in the range of [0..MaxRGB].
+(defmagick* PixelSetMagentaQuantum :
+  _PixelWand (magenta : _Quantum) -> _void)
+
+;; PixelSetOpacity sets the normalized opacity color of the pixel wand.
+(defmagick* PixelSetOpacity :
+  _PixelWand (opacity : _double*) -> _void)
+
+;; PixelSetOpacityQuantum sets the opacity color of the pixel wand.  The color
+;; must be in the range of [0..MaxRGB].
+(defmagick* PixelSetOpacityQuantum :
+  _PixelWand (opacity : _Quantum) -> _void)
+
+;; PixelSetQuantumColor sets the color of the pixel wand.
+(defmagick* PixelSetQuantumColor :
+  _PixelWand _PixelPacket -> _void)
+
+;; PixelSetRed sets the normalized red color of the pixel wand.
+(defmagick* PixelSetRed :
+  _PixelWand (red : _double*) -> _void)
+
+;; PixelSetRedQuantum sets the red color of the pixel wand.  The color must be
+;; in the range of [0..MaxRGB].
+(defmagick* PixelSetRedQuantum :
+  _PixelWand (red : _Quantum) -> _void)
+
+;; PixelSetYellow sets the normalized yellow color of the pixel wand.
+(defmagick* PixelSetYellow :
+  _PixelWand (yellow : _double*) -> _void)
+
+;; PixelSetYellowQuantum sets the yellow color of the pixel wand.  The color
+;; must be in the range of [0..MaxRGB].
+(defmagick* PixelSetYellowQuantum :
+  _PixelWand (yellow : _Quantum) -> _void)
+
+;; ===== DrawingWand API ======================================================
+
+;; DrawGetException returns the severity, reason, and description of any error
+;; that occurs when using other methods in this API.
+(defmagick* DrawGetException :
+  _DrawingWand (severity : (_ptr o _MagickExceptionType))
+  -> (message : _string)
+  -> (unless (eq? severity 'UndefinedException)
+       (error 'DrawingWand "(~a) ~a" severity message)))
+
+;; DestroyDrawingWand frees all resources associated with the drawing wand.
+;; Once the drawing wand has been freed, it should not be used any further
+;; unless it re-allocated.
+(defmagick DestroyDrawingWand :
+  _DrawingWand -> _void)
+
+;; DrawAnnotation draws text on the image.
+(defmagick* DrawAnnotation :
+  _DrawingWand (x : _double*) (y : _double*) (text : _string) -> _void)
+
+;; DrawAffine adjusts the current affine transformation matrix with the
+;; specified affine transformation matrix.  Note that the current affine
+;; transform is adjusted rather than replaced.
+(defmagick* DrawAffine :
+  _DrawingWand _AffineMatrix -> _void)
+
+;; DrawAllocateWand allocates an initial drawing wand which is an opaque handle
+;; required by the remaining drawing methods.
+(defmagick* DrawAllocateWand :
+  _DrawInfo _Image -> _DrawingWand)
+
+;; DrawArc draws an arc falling within a specified bounding rectangle on the
+;; image.
+(defmagick* DrawArc :
+  _DrawingWand
+  (x1 : _double*) (y1 : _double*) (x2 : _double*) (y2 : _double*)
+  (deg1 : _double*) (deg2 : _double*)
+  -> _void)
+
+;; DrawBezier draws a bezier curve through a set of points on the image.
+(defmagick* DrawBezier :
+  (d points) ::
+  (d : _DrawingWand) (_ulong = (length points)) (points : _Points) -> _void)
+
+;; DrawCircle draws a circle on the image.
+(defmagick* DrawCircle :
+  _DrawingWand
+  (x : _double*) (y : _double*)
+  (perimeter-x : _double*) (perimeter-y : _double*)
+  -> _void)
+
+;; DrawGetClipPath obtains the current clipping path ID.  The value returned
+;; must be deallocated by the user when it is no longer needed.
+(defmagick* DrawGetClipPath :
+  _DrawingWand -> _string)
+
+;; DrawSetClipPath associates a named clipping path with the image.  Only the
+;; areas drawn on by the clipping path will be modified as long as it remains
+;; in effect.
+(defmagick* DrawSetClipPath :
+  _DrawingWand (clip_path : _string) -> _void)
+
+;; DrawGetClipRule returns the current polygon fill rule to be used by the
+;; clipping path.
+(defmagick* DrawGetClipRule :
+  _DrawingWand -> _FillRule)
+
+;; DrawSetClipRule set the polygon fill rule to be used by the clipping path.
+(defmagick* DrawSetClipRule :
+  _DrawingWand _FillRule -> _void)
+
+;; DrawGetClipUnits returns the interpretation of clip path units.
+(defmagick* DrawGetClipUnits :
+  _DrawingWand -> _ClipPathUnits)
+
+;; DrawSetClipUnits sets the interpretation of clip path units.
+(defmagick* DrawSetClipUnits :
+  _DrawingWand _ClipPathUnits -> _void)
+
+;; DrawColor draws color on image using the current fill color, starting at
+;; specified position, and using specified paint method.  The available paint
+;; methods are:
+;;   PointMethod: Recolors the target pixel
+;;   ReplaceMethod: Recolor any pixel that matches the target pixel.
+;;   FloodfillMethod: Recolors target pixels and matching neighbors.
+;;   FillToBorderMethod: Recolor target pixels and neighbors not matching
+;;     border color.
+;;   ResetMethod: Recolor all pixels.
+(defmagick* DrawColor :
+  _DrawingWand (x : _double*) (y : _double*) _PaintMethod -> _void)
+
+;; DrawComment adds a comment to a vector output stream.
+(defmagick* DrawComment :
+  _DrawingWand (comment : _string) -> _void)
+
+;; DrawEllipse draws an ellipse on the image.
+(defmagick* DrawEllipse :
+  _DrawingWand
+  (x : _double*) (y : _double*)
+  (radius-x : _double*) (radius-y : _double*)
+  (start-deg : _double*) (end-deg : _double*)
+  -> _void)
+
+;; DrawGetFillColor returns the fill color used for drawing filled objects.
+(defmagick* DrawGetFillColor :
+  _DrawingWand (c : _PixelWand = (NewPixelWand)) -> _void -> c)
+
+;; DrawSetFillColor sets the fill color to be used for drawing filled objects.
+(defmagick* DrawSetFillColor :
+  _DrawingWand _PixelWand -> _void)
+
+;; DrawSetFillPatternURL sets the URL to use as a fill pattern for filling
+;; objects.  Only local URLs ("#identifier") are supported at this time.  These
+;; local URLs are normally created by defining a named fill pattern with
+;; DrawPushPattern/DrawPopPattern.
+(defmagick* DrawSetFillPatternURL :
+  _DrawingWand (fill-url : _string) -> _void)
+
+;; DrawGetFillOpacity returns the opacity used when drawing using the fill
+;; color or fill texture.  Fully opaque is 1.0.
+(defmagick* DrawGetFillOpacity :
+  _DrawingWand -> _double*)
+
+;; DrawSetFillOpacity sets the opacity to use when drawing using the fill color
+;; or fill texture.  Fully opaque is 1.0.
+(defmagick* DrawSetFillOpacity :
+  _DrawingWand (fill-opacity : _double*) -> _void)
+
+;; DrawGetFillRule returns the fill rule used while drawing polygons.
+(defmagick* DrawGetFillRule :
+  _DrawingWand -> _FillRule)
+
+;; DrawSetFillRule sets the fill rule to use while drawing polygons.
+(defmagick* DrawSetFillRule :
+  _DrawingWand _FillRule -> _void)
+
+;; DrawGetFont returns a null-terminaged string specifying the font used when
+;; annotating with text.
+(defmagick* DrawGetFont :
+  _DrawingWand -> _string)
+
+;; DrawSetFont sets the fully-sepecified font to use when annotating with text.
+(defmagick* DrawSetFont :
+  _DrawingWand (font-name : _string) -> _void)
+
+;; DrawGetFontFamily returns the font family to use when annotating with text.
+(defmagick* DrawGetFontFamily :
+  _DrawingWand -> _string)
+
+;; DrawSetFontFamily sets the font family to use when annotating with text.
+(defmagick* DrawSetFontFamily :
+  _DrawingWand (font-family : _string) -> _void)
+
+;; DrawGetFontSize returns the font pointsize used when annotating with text.
+(defmagick* DrawGetFontSize :
+  _DrawingWand -> _double*)
+
+;; DrawSetFontSize sets the font pointsize to use when annotating with text.
+(defmagick* DrawSetFontSize :
+  _DrawingWand (pointsize : _double*) -> _void)
+
+;; DrawGetFontStretch returns the font stretch used when annotating with text.
+(defmagick* DrawGetFontStretch :
+  _DrawingWand -> _StretchType)
+
+;; DrawSetFontStretch sets the font stretch to use when annotating with text.
+;; The AnyStretch enumeration acts as a wild-card "don't care" option.
+(defmagick* DrawSetFontStretch :
+  _DrawingWand _StretchType -> _void)
+
+;; DrawGetFontStyle returns the font style used when annotating with text.
+(defmagick* DrawGetFontStyle :
+  _DrawingWand -> _StyleType)
+
+;; DrawSetFontStyle sets the font style to use when annotating with text.  The
+;; AnyStyle enumeration acts as a wild-card "don't care" option.
+(defmagick* DrawSetFontStyle :
+  _DrawingWand _StyleType -> _void)
+
+;; DrawGetFontWeight returns the font weight used when annotating with text.
+(defmagick* DrawGetFontWeight :
+  _DrawingWand -> _ulong)
+
+;; DrawSetFontWeight sets the font weight to use when annotating with text.
+(defmagick* DrawSetFontWeight :
+  _DrawingWand (font-weight : _ulong) -> _void)
+
+;; DrawGetGravity returns the text placement gravity used when annotating with
+;; text.
+(defmagick* DrawGetGravity :
+  _DrawingWand -> _GravityType)
+
+;; DrawSetGravity sets the text placement gravity to use when annotating with
+;; text.
+(defmagick* DrawSetGravity :
+  _DrawingWand _GravityType -> _void)
+
+;; DrawComposite composites an image onto the current image, using the
+;; specified composition operator, specified position, and at the specified
+;; size.
+(defmagick* DrawComposite :
+  _DrawingWand _CompositeOperator
+  (x : _double*) (y : _double*) (width : _double*) (height : _double*) _Image
+  -> _void)
+
+;; DrawLine draws a line on the image using the current stroke color, stroke
+;; opacity, and stroke width.
+(defmagick* DrawLine :
+  _DrawingWand (x1 : _double*) (y1 : _double*) (x2 : _double*) (y2 : _double*)
+  -> _void)
+
+;; DrawMatte paints on the image's opacity channel in order to set effected
+;; pixels to transparent.  The available paint methods are:
+;;   PointMethod: Select the target pixel
+;;   ReplaceMethod: Select any pixel that matches the target pixel.
+;;   FloodfillMethod: Select the target pixel and matching neighbors.
+;;   FillToBorderMethod: Select the target pixel and neighbors not matching
+;;     border color.
+;;   ResetMethod: Select all pixels.
+(defmagick* DrawMatte :
+  _DrawingWand (x : _double*) (y : _double*) _PaintMethod -> _void)
+
+;; DrawPathClose adds a path element to the current path which closes the
+;; current subpath by drawing a straight line from the current point to the
+;; current subpath's most recent starting point (usually, the most recent
+;; moveto point).
+(defmagick* DrawPathClose :
+  _DrawingWand -> _void)
+
+;; DrawPathCurveToAbsolute draws a cubic Bezier curve from the current point to
+;; (x,y) using (x1,y1) as the control point at the beginning of the curve and
+;; (x2,y2) as the control point at the end of the curve using absolute
+;; coordinates.  At the end of the command, the new current point becomes the
+;; final (x,y) coordinate pair used in the polybezier.
+(defmagick* DrawPathCurveToAbsolute :
+  _DrawingWand
+  (x1 : _double*) (y1 : _double*) (x2 : _double*) (y2 : _double*)
+  (x : _double*) (y : _double*)
+  -> _void)
+
+;; DrawPathCurveToRelative draws a cubic Bezier curve from the current point to
+;; (x,y) using (x1,y1) as the control point at the beginning of the curve and
+;; (x2,y2) as the control point at the end of the curve using relative
+;; coordinates.  At the end of the command, the new current point becomes the
+;; final (x,y) coordinate pair used in the polybezier.
+(defmagick* DrawPathCurveToRelative :
+  _DrawingWand
+  (x1 : _double*) (y1 : _double*) (x2 : _double*) (y2 : _double*)
+  (x : _double*) (y : _double*)
+  -> _void)
+
+;; DrawPathCurveToQuadraticBezierAbsolute draws a quadratic Bezier curve from
+;; the current point to (x,y) using (x1,y1) as the control point using absolute
+;; coordinates.  At the end of the command, the new current point becomes the
+;; final (x,y) coordinate pair used in the polybezier.
+(defmagick* DrawPathCurveToQuadraticBezierAbsolute :
+  _DrawingWand (x1 : _double*) (y1 : _double*) (x : _double*) (y : _double*)
+  -> _void)
+
+;; DrawPathCurveToQuadraticBezierRelative draws a quadratic Bezier curve from
+;; the current point to (x,y) using (x1,y1) as the control point using relative
+;; coordinates.  At the end of the command, the new current point becomes the
+;; final (x,y) coordinate pair used in the polybezier.
+(defmagick* DrawPathCurveToQuadraticBezierRelative :
+  _DrawingWand (x1 : _double*) (y1 : _double*) (x : _double*) (y : _double*)
+  -> _void)
+
+;; DrawPathCurveToQuadraticBezierSmoothAbsolute draws a quadratic Bezier curve
+;; (using absolute coordinates) from the current point to (x,y).  The control
+;; point is assumed to be the reflection of the control point on the previous
+;; command relative to the current point.  (If there is no previous command or
+;; if the previous command was not a DrawPathCurveToQuadraticBezierAbsolute,
+;; DrawPathCurveToQuadraticBezierRelative,
+;; DrawPathCurveToQuadraticBezierSmoothAbsolut or
+;; DrawPathCurveToQuadraticBezierSmoothRelative, assume the control point is
+;; coincident with the current point.).  At the end of the command, the new
+;; current point becomes the final (x,y) coordinate pair used in the
+;; polybezier.
+(defmagick* DrawPathCurveToQuadraticBezierSmoothAbsolute :
+  _DrawingWand (x : _double*) (y : _double*) -> _void)
+
+;; DrawPathCurveToQuadraticBezierSmoothAbsolute draws a quadratic Bezier curve
+;; (using relative coordinates) from the current point to (x,y).  The control
+;; point is assumed to be the reflection of the control point on the previous
+;; command relative to the current point.  (If there is no previous command or
+;; if the previous command was not a DrawPathCurveToQuadraticBezierAbsolute,
+;; DrawPathCurveToQuadraticBezierRelative,
+;; DrawPathCurveToQuadraticBezierSmoothAbsolut or
+;; DrawPathCurveToQuadraticBezierSmoothRelative, assume the control point is
+;; coincident with the current point.).  At the end of the command, the new
+;; current point becomes the final (x,y) coordinate pair used in the
+;; polybezier.
+(defmagick* DrawPathCurveToQuadraticBezierSmoothRelative :
+  _DrawingWand (x : _double*) (y : _double*) -> _void)
+
+;; DrawPathCurveToSmoothAbsolute draws a cubic Bezier curve from the current
+;; point to (x,y) using absolute coordinates.  The first control point is
+;; assumed to be the reflection of the second control point on the previous
+;; command relative to the current point.  (If there is no previous command or
+;; if the previous command was not an DrawPathCurveToAbsolute,
+;; DrawPathCurveToRelative, DrawPathCurveToSmoothAbsolute or
+;; DrawPathCurveToSmoothRelative, assume the first control point is coincident
+;; with the current point.)  (x2,y2) is the second control point (i.e., the
+;; control point at the end of the curve).  At the end of the command, the new
+;; current point becomes the final (x,y) coordinate pair used in the
+;; polybezier.
+(defmagick* DrawPathCurveToSmoothAbsolute :
+  _DrawingWand (x2 : _double*) (y2 : _double*) (x : _double*) (y : _double*)
+  -> _void)
+
+;; DrawPathCurveToSmoothRelative draws a cubic Bezier curve from the current
+;; point to (x,y) using relative coordinates.  The first control point is
+;; assumed to be the reflection of the second control point on the previous
+;; command relative to the current point.  (If there is no previous command or
+;; if the previous command was not an DrawPathCurveToAbsolute,
+;; DrawPathCurveToRelative, DrawPathCurveToSmoothAbsolute or
+;; DrawPathCurveToSmoothRelative, assume the first control point is coincident
+;; with the current point.)  (x2,y2) is the second control point (i.e., the
+;; control point at the end of the curve).  At the end of the command, the new
+;; current point becomes the final (x,y) coordinate pair used in the
+;; polybezier.
+(defmagick* DrawPathCurveToSmoothRelative :
+  _DrawingWand (x2 : _double*) (y2 : _double*) (x : _double*) (y : _double*)
+  -> _void)
+
+;; DrawPathEllipticArcAbsolute draws an elliptical arc from the current point
+;; to (x, y) using absolute coordinates.  The size and orientation of the
+;; ellipse are defined by two radii (rx, ry) and an xAxisRotation, which
+;; indicates how the ellipse as a whole is rotated relative to the current
+;; coordinate system.  The center (cx, cy) of the ellipse is calculated
+;; automatically to satisfy the constraints imposed by the other parameters.
+;; largeArcFlag and sweepFlag contribute to the automatic calculations and help
+;; determine how the arc is drawn.  If largeArcFlag is true then draw the
+;; larger of the available arcs.  If sweepFlag is true, then draw the arc
+;; matching a clock-wise rotation.
+(defmagick* DrawPathEllipticArcAbsolute :
+  _DrawingWand (rx : _double*) (ry : _double*)
+  (x-axis-rotation : _double*) (large-arc-flag? : _bool) (sweep-flag? : _bool)
+  (x : _double*) (y : _double*)
+  -> _void)
+
+;; DrawPathEllipticArcRelative draws an elliptical arc from the current point
+;; to (x, y) using relative coordinates.  The size and orientation of the
+;; ellipse are defined by two radii (rx, ry) and an xAxisRotation, which
+;; indicates how the ellipse as a whole is rotated relative to the current
+;; coordinate system.  The center (cx, cy) of the ellipse is calculated
+;; automatically to satisfy the constraints imposed by the other parameters.
+;; largeArcFlag and sweepFlag contribute to the automatic calculations and help
+;; determine how the arc is drawn.  If largeArcFlag is true then draw the
+;; larger of the available arcs.  If sweepFlag is true, then draw the arc
+;; matching a clock-wise rotation.
+(defmagick* DrawPathEllipticArcRelative :
+  _DrawingWand (rx : _double*) (ry : _double*)
+  (x-axis-rotation : _double*) (large-arc-flag? : _bool) (sweep-flag? : _bool)
+  (x : _double*) (y : _double*)
+  -> _void)
+
+;; DrawPathFinish terminates the current path.
+(defmagick* DrawPathFinish :
+  _DrawingWand -> _void)
+
+;; DrawPathLineToAbsolute draws a line path from the current point to the given
+;; coordinate using absolute coordinates.  The coordinate then becomes the new
+;; current point.
+(defmagick* DrawPathLineToAbsolute :
+  _DrawingWand (x : _double*) (y : _double*) -> _void)
+
+;; DrawPathLineToRelative draws a line path from the current point to the given
+;; coordinate using relative coordinates.  The coordinate then becomes the new
+;; current point.
+(defmagick* DrawPathLineToRelative :
+  _DrawingWand (x : _double*) (y : _double*) -> _void)
+
+;; DrawPathLineToHorizontalAbsolute draws a horizontal line path from the
+;; current point to the target point using absolute coordinates.  The target
+;; point then becomes the new current point.
+(defmagick* DrawPathLineToHorizontalAbsolute :
+  _DrawingWand (x : _double*) -> _void)
+
+;; DrawPathLineToHorizontalRelative draws a horizontal line path from the
+;; current point to the target point using relative coordinates.  The target
+;; point then becomes the new current point.
+(defmagick* DrawPathLineToHorizontalRelative :
+  _DrawingWand (x : _double*) -> _void)
+
+;; DrawPathLineToVerticalAbsolute draws a vertical line path from the current
+;; point to the target point using absolute coordinates.  The target point then
+;; becomes the new current point.
+(defmagick* DrawPathLineToVerticalAbsolute :
+  _DrawingWand (y : _double*) -> _void)
+
+;; DrawPathLineToVerticalRelative draws a vertical line path from the current
+;; point to the target point using relative coordinates.  The target point then
+;; becomes the new current point.
+(defmagick* DrawPathLineToVerticalRelative :
+  _DrawingWand (y : _double*) -> _void)
+
+;; DrawPathMoveToAbsolute starts a new sub-path at the given coordinate using
+;; absolute coordinates.  The current point then becomes the specified
+;; coordinate.
+(defmagick* DrawPathMoveToAbsolute :
+  _DrawingWand (x : _double*) (y : _double*) -> _void)
+
+;; DrawPathMoveToRelative starts a new sub-path at the given coordinate using
+;; relative coordinates.  The current point then becomes the specified
+;; coordinate.
+(defmagick* DrawPathMoveToRelative :
+  _DrawingWand (x : _double*) (y : _double*) -> _void)
+
+;; DrawPathStart declares the start of a path drawing list which is terminated
+;; by a matching DrawPathFinish command.  All other DrawPath commands must be
+;; enclosed between a DrawPathStart and a DrawPathFinish command.  This is
+;; because path drawing commands are subordinate commands and they do not
+;; function by themselves.
+(defmagick* DrawPathStart :
+  _DrawingWand -> _void)
+
+;; PeekDrawingWand returns the current drawing wand.
+(defmagick* PeekDrawingWand :
+  _DrawingWand -> _DrawInfo)
+
+;; DrawPoint draws a point using the current stroke color and stroke thickness
+;; at the specified coordinates.
+(defmagick* DrawPoint :
+  _DrawingWand (x : _double*) (y : _double*) -> _void)
+
+;; DrawPolygon draws a polygon using the current stroke, stroke width, and fill
+;; color or texture, using the specified array of coordinates.
+(defmagick* DrawPolygon :
+  (d points) ::
+  (d : _DrawingWand) (_ulong = (length points)) (points : _Points) -> _void)
+
+;; DrawPolyline draws a polyline using the current stroke, stroke width, and
+;; fill color or texture, using the specified array of coordinates.
+(defmagick* DrawPolyline :
+  (d points) ::
+  (d : _DrawingWand) (_ulong = (length points)) (points : _Points) -> _void)
+
+;; DrawPopClipPath terminates a clip path definition.
+(defmagick* DrawPopClipPath :
+  _DrawingWand -> _void)
+
+;; DrawPopDefs terminates a definition list.
+(defmagick* DrawPopDefs :
+  _DrawingWand -> _void)
+
+;; PopDrawingWand destroys the current drawing wand and returns to the
+;; previously pushed drawing wand.  Multiple drawing wands may exist.  It is an
+;; error to attempt to pop more drawing wands than have been pushed, and it is
+;; proper form to pop all drawing wands which have been pushed.
+(defmagick* PopDrawingWand :
+  _DrawingWand -> _void)
+
+;; DrawPopPattern terminates a pattern definition.
+(defmagick* DrawPopPattern :
+  _DrawingWand -> _void)
+
+;; DrawPushClipPath starts a clip path definition which is comprized of any
+;; number of drawing commands and terminated by a DrawPopClipPath command.
+(defmagick* DrawPushClipPath :
+  _DrawingWand (clip-path-id : _string) -> _void)
+
+;; DrawPushDefs indicates that commands up to a terminating DrawPopDefs command
+;; create named elements (e.g. clip-paths, textures, etc.) which may safely be
+;; processed earlier for the sake of efficiency.
+(defmagick* DrawPushDefs :
+  _DrawingWand -> _void)
+
+;; PushDrawingWand clones the current drawing wand to create a new
+;; drawing wand.  The original drawing drawing wand(s) may be returned to by
+;; invoking PopDrawingWand.  The drawing wands are stored on a drawing wand
+;; stack.  For every Pop there must have already been an equivalent Push.
+(defmagick* PushDrawingWand :
+  _DrawingWand -> _void)
+
+;; DrawPushPattern indicates that subsequent commands up to a DrawPopPattern
+;; command comprise the definition of a named pattern.  The pattern space is
+;; assigned top left corner coordinates, a width and height, and becomes its
+;; own drawing space.  Anything which can be drawn may be used in a pattern
+;; definition.  Named patterns may be used as stroke or brush definitions.
+(defmagick* DrawPushPattern :
+  _DrawingWand (pattern-id : _string)
+  (x : _double*) (y : _double*) (width : _double*) (height : _double*)
+  -> _void)
+
+;; DrawRectangle draws a rectangle given two coordinates and using the current
+;; stroke, stroke width, and fill settings.
+(defmagick* DrawRectangle :
+  _DrawingWand (x1 : _double*) (y1 : _double*) (x2 : _double*) (y2 : _double*)
+  -> _void)
+
+;; DrawRender renders all preceding drawing commands onto the image.
+(defmagick* DrawRender :
+  _DrawingWand -> _status)
+
+;; DrawRotate applies the specified rotation to the current coordinate space.
+(defmagick* DrawRotate :
+  _DrawingWand (degrees : _double*) -> _void)
+
+;; DrawRoundRectangle draws a rounted rectangle given two coordinates, x & y
+;; corner radiuses and using the current stroke, stroke width, and fill
+;; settings.
+(defmagick* DrawRoundRectangle :
+  _DrawingWand
+  (x1 : _double*) (y1 : _double*) (x2 : _double*) (y2 : _double*)
+  (rx : _double*) (ry : _double*)
+  -> _void)
+
+;; DrawScale adjusts the scaling factor to apply in the horizontal and vertical
+;; directions to the current coordinate space.
+(defmagick* DrawScale :
+  _DrawingWand (horizontal-scale : _double*) (vertical-scale : _double*)
+  -> _void)
+
+;; DrawSkewX skews the current coordinate system in the horizontal direction.
+(defmagick* DrawSkewX :
+  _DrawingWand (degrees : _double*) -> _void)
+
+;; DrawSkewY skews the current coordinate system in the vertical direction.
+(defmagick* DrawSkewY :
+  _DrawingWand (degrees : _double*) -> _void)
+
+;; DrawGetStrokeColor returns the color used for stroking object outlines.
+(defmagick* DrawGetStrokeColor :
+  _DrawingWand (c : _PixelWand = (NewPixelWand)) -> _void -> c)
+
+;; DrawSetStrokeColor sets the color used for stroking object outlines.
+(defmagick* DrawSetStrokeColor :
+  _DrawingWand _PixelWand -> _void)
+
+;; DrawSetStrokePatternURL sets the pattern used for stroking object outlines.
+(defmagick* DrawSetStrokePatternURL :
+  _DrawingWand (stroke-url : _string) -> _void)
+
+;; DrawGetStrokeAntialias returns the current stroke antialias setting.
+;; Stroked outlines are antialiased by default.  When antialiasing is disabled
+;; stroked pixels are thresholded to determine if the stroke color or
+;; underlying canvas color should be used.
+(defmagick* DrawGetStrokeAntialias :
+  _DrawingWand -> _bool)
+
+;; DrawSetStrokeAntialias controls whether stroked outlines are antialiased.
+;; Stroked outlines are antialiased by default.  When antialiasing is disabled
+;; stroked pixels are thresholded to determine if the stroke color or
+;; underlying canvas color should be used.
+(defmagick* DrawSetStrokeAntialias :
+  _DrawingWand (stroke-antialias? : _bool) -> _void)
+
+;; DrawGetStrokeDashArray returns an array representing the pattern of dashes
+;; and gaps used to stroke paths (see DrawSetStrokeDashArray).
+(defmagick* DrawGetStrokeDashArray :
+  _DrawingWand (len : (_ptr o _ulong)) -> (_list o _double* len))
+
+;; DrawSetStrokeDashArray specifies the pattern of dashes and gaps used to
+;; stroke paths.  The strokeDashArray represents an array of numbers that
+;; specify the lengths of alternating dashes and gaps in pixels.  If an odd
+;; number of values is provided, then the list of values is repeated to yield
+;; an even number of values.  To remove an existing dash array, pass a zero
+;; number_elements argument and null dash_array.  A typical strokeDashArray_
+;; array might contain the members 5 3 2.
+(defmagick* DrawSetStrokeDashArray :
+  (d dash-list) ::
+  ;; the function seem to always expect a 0.0-terminated vector
+  (dash-list : _? = (append dash-list '(0.0)))
+  (d : _DrawingWand)
+  (_ulong = (length dash-list)) (dash-list : (_list i _double*))
+  -> _void)
+
+;; DrawGetStrokeDashOffset returns the offset into the dash pattern to start
+;; the dash.
+(defmagick* DrawGetStrokeDashOffset :
+  _DrawingWand -> _double*)
+
+;; DrawSetStrokeDashOffset specifies the offset into the dash pattern to start
+;; the dash.
+(defmagick* DrawSetStrokeDashOffset :
+  _DrawingWand (dash-offset : _double*) -> _void)
+
+;; DrawGetStrokeLineCap returns the shape to be used at the end of open
+;; subpaths when they are stroked.  Values of LineCap are UndefinedCap,
+;; ButtCap, RoundCap, and SquareCap.
+(defmagick* DrawGetStrokeLineCap :
+  _DrawingWand -> _LineCap)
+
+;; DrawSetStrokeLineCap specifies the shape to be used at the end of open
+;; subpaths when they are stroked.  Values of LineCap are UndefinedCap,
+;; ButtCap, RoundCap, and SquareCap.
+(defmagick* DrawSetStrokeLineCap :
+  _DrawingWand _LineCap -> _void)
+
+;; DrawGetStrokeLineJoin returns the shape to be used at the corners of paths
+;; (or other vector shapes) when they are stroked.  Values of LineJoin are
+;; UndefinedJoin, MiterJoin, RoundJoin, and BevelJoin.
+(defmagick* DrawGetStrokeLineJoin :
+  _DrawingWand -> _LineJoin)
+
+;; DrawSetStrokeLineJoin specifies the shape to be used at the corners of paths
+;; (or other vector shapes) when they are stroked.  Values of LineJoin are
+;; UndefinedJoin, MiterJoin, RoundJoin, and BevelJoin.
+(defmagick* DrawSetStrokeLineJoin :
+  _DrawingWand _LineJoin -> _void)
+
+;; DrawGetStrokeMiterLimit returns the miter limit.  When two line segments
+;; meet at a sharp angle and miter joins have been specified for 'lineJoin', it
+;; is possible for the miter to extend far beyond the thickness of the line
+;; stroking the path.  The miterLimit' imposes a limit on the ratio of the
+;; miter length to the 'lineWidth'.
+(defmagick* DrawGetStrokeMiterLimit :
+  _DrawingWand -> _ulong)
+
+;; DrawSetStrokeMiterLimit specifies the miter limit.  When two line segments
+;; meet at a sharp angle and miter joins have been specified for 'lineJoin', it
+;; is possible for the miter to extend far beyond the thickness of the line
+;; stroking the path.  The miterLimit' imposes a limit on the ratio of the
+;; miter length to the 'lineWidth'.
+(defmagick* DrawSetStrokeMiterLimit :
+  _DrawingWand (miterlimit : _ulong) -> _void)
+
+;; DrawGetStrokeOpacity returns the opacity of stroked object outlines.
+(defmagick* DrawGetStrokeOpacity :
+  _DrawingWand -> _double*)
+
+;; DrawSetStrokeOpacity specifies the opacity of stroked object outlines.
+(defmagick* DrawSetStrokeOpacity :
+  _DrawingWand (stroke-opacity : _double*) -> _void)
+
+;; DrawGetStrokeWidth returns the width of the stroke used to draw object
+;; outlines.
+(defmagick* DrawGetStrokeWidth :
+  _DrawingWand -> _double*)
+
+;; DrawSetStrokeWidth sets the width of the stroke used to draw object
+;; outlines.
+(defmagick* DrawSetStrokeWidth :
+  _DrawingWand (stroke-width : _double*) -> _void)
+
+;; DrawGetTextAntialias returns the current text antialias setting, which
+;; determines whether text is antialiased.  Text is antialiased by default.
+(defmagick* DrawGetTextAntialias :
+  _DrawingWand -> _bool)
+
+;; DrawSetTextAntialias controls whether text is antialiased.  Text is
+;; antialiased by default.
+(defmagick* DrawSetTextAntialias :
+  _DrawingWand (text-antialias? : _bool) -> _void)
+
+;; DrawGetTextDecoration returns the decoration applied when annotating with
+;; text.
+(defmagick* DrawGetTextDecoration :
+  _DrawingWand -> _DecorationType)
+
+;; DrawSetTextDecoration specifies a decoration to be applied when annotating
+;; with text.
+(defmagick* DrawSetTextDecoration :
+  _DrawingWand _DecorationType -> _void)
+
+;; DrawGetTextEncoding returns a null-terminated string which specifies the
+;; code set used for text annotations.
+(defmagick* DrawGetTextEncoding :
+  _DrawingWand -> _string)
+
+;; DrawSetTextEncoding specifies specifies the code set to use for text
+;; annotations.  The only character encoding which may be specified at this
+;; time is "UTF-8" for representing Unicode as a sequence of bytes.  Specify an
+;; empty string to set text encoding to the system's default.  Successful text
+;; annotation using Unicode may require fonts designed to support Unicode.
+(defmagick* DrawSetTextEncoding :
+  _DrawingWand (encoding : _string) -> _void)
+
+;; DrawGetTextUnderColor returns the color of a background rectangle to place
+;; under text annotations.
+(defmagick* DrawGetTextUnderColor :
+  _DrawingWand (c : _PixelWand = (NewPixelWand)) -> _void -> c)
+
+;; DrawSetTextUnderColor specifies the color of a background rectangle to place
+;; under text annotations.
+(defmagick* DrawSetTextUnderColor :
+  _DrawingWand _PixelWand -> _void)
+
+;; DrawTranslate applies a translation to the current coordinate system which
+;; moves the coordinate system origin to the specified coordinate.
+(defmagick* DrawTranslate :
+  _DrawingWand (x : _double*) (y : _double*) -> _void)
+
+;; DrawSetViewbox sets the overall canvas size to be recorded with the drawing
+;; vector data.  Usually this will be specified using the same size as the
+;; canvas image.  When the vector data is saved to SVG or MVG formats, the
+;; viewbox is use to specify the size of the canvas image that a viewer will
+;; render the vector data on.
+(defmagick* DrawSetViewbox :
+  _DrawingWand (x1 : _ulong) (y1 : _ulong) (x2 : _ulong) (y2 : _ulong)
+  -> _void)
+
+;; NewDrawingWand returns a draw wand required for all other methods in the
+;; API.
+(defmagick* NewDrawingWand :
+  -> _DrawingWand)
+
+;; ===== Misc APIs ============================================================
+
+;; These are not part of the Wand API, but they are used by it so we need
+;; destructor functions when collecting them.
+
+;; DestroyImage dereferences an image, deallocating memory associated with the
+;; image if the reference count becomes zero.
+(defmagick DestroyImage :
+  _Image -> _void)
+
+(defmagick DestroyDrawInfo :
+  _DrawInfo -> _void)
+
+)
diff --git a/collects/ffi/sndfile.ss b/collects/ffi/sndfile.ss
new file mode 100644
index 0000000000..06deefb6fe
--- /dev/null
+++ b/collects/ffi/sndfile.ss
@@ -0,0 +1,346 @@
+(module sndfile mzscheme
+
+(require (lib "foreign.ss")) (unsafe!)
+
+(define libsndfile (ffi-lib "libsndfile"))
+
+;; ==================== Types etc ====================
+
+;; This is the scheme represtenatation of the soundfile that is handeled by
+;; libsndfile.
+
+;; In libsndfile the sndfile object is represenetd as a pointer when
+;; translating scheme->c the struct will just return the pointer when
+;; translating from c->scheme, ie. creating the object in scheme it will be
+;; wraped by an object finilazer that uses the libsndfile fuction sf_close that
+;; return a 0 upon sucsessfull termination or an error.
+(define-struct sndfile (ptr info))
+(define _sndfile
+  (make-ctype _pointer sndfile-ptr
+    (lambda (p)
+      (if p
+        (make-sndfile p #f)
+        (error '_sndfile "got a NULL pointer (bad info?)")))))
+
+;; sf_count_t is a count type that depends on the operating system however it
+;; seems to be a long int for all teh supported ones so in this scase we just
+;; define it as two ints.
+(define _sf-count-t _int64)
+
+(define _sf-mode
+  (_bitmask '(sfm-read  = #x10
+              sfm-write = #x20
+              sfm-rdwrt = #x30)))
+
+(define str-types '(title copyright software artist comment date))
+(define _sf-str-type (_enum (cons "dummy" str-types))) ; begins from 1
+
+(define _sf-format
+  (let ([majors ; Major formats
+         '((wav       #x010000)   ; Microsoft WAV format (little endian)
+           (aiff      #x020000)   ; Apple/SGI AIFF format (big endian)
+           (au        #x030000)   ; Sun/NeXT AU format (big endian)
+           (raw       #x040000)   ; RAW PCM data
+           (paf       #x050000)   ; Ensoniq PARIS file format
+           (svx       #x060000)   ; Amiga IFF / SVX8 / SV16 format
+           (nist      #x070000)   ; Sphere NIST format
+           (voc       #x080000)   ; VOC files
+           (ircam     #x0A0000)   ; Berkeley/IRCAM/CARL
+           (w64       #x0B0000)   ; Sonic Foundry's 64 bit RIFF/WAV
+           (mat4      #x0C0000)   ; Matlab (tm) V4.2 / GNU Octave 2.0
+           (mat5      #x0D0000)   ; Matlab (tm) V5.0 / GNU Octave 2.1
+           (pvf       #x0E0000)   ; Portable Voice Format
+           (xi        #x0F0000)   ; Fasttracker 2 Extended Instrument
+           (htk       #x100000)   ; HMM Tool Kit format
+           (sds       #x110000)   ; Midi Sample Dump Standard
+           (avr       #x120000)   ; Audio Visual Research
+           (wavex     #x130000)   ; MS WAVE with WAVEFORMATEX
+           )]
+        [subtypes ; Subtypes from here on
+         '((pcm-s8    #x0001)     ; Signed 8 bit data
+           (pcm-16    #x0002)     ; Signed 16 bit data
+           (pcm-24    #x0003)     ; Signed 24 bit data
+           (pcm-32    #x0004)     ; Signed 32 bit data
+           (pcm-u8    #x0005)     ; Unsigned 8 bit data (WAV and RAW only)
+           (float     #x0006)     ; 32 bit float data
+           (double    #x0007)     ; 64 bit float data
+           (ulaw      #x0010)     ; U-Law encoded
+           (alaw      #x0011)     ; A-Law encoded
+           (ima-adpcm #x0012)     ; IMA ADPCM
+           (ms-adpcm  #x0013)     ; Microsoft ADPCM
+           (gsm610    #x0020)     ; GSM 6.10 encoding
+           (vox-adpcm #x0021)     ; OKI / Dialogix ADPCM
+           (g721-32   #x0030)     ; 32kbs G721 ADPCM encoding
+           (g723-24   #x0031)     ; 24kbs G723 ADPCM encoding
+           (g723-40   #x0032)     ; 40kbs G723 ADPCM encoding
+           (dwvw-12   #x0040)     ; 12 bit Delta Width Variable Word encoding
+           (dwvw-16   #x0041)     ; 16 bit Delta Width Variable Word encoding
+           (dwvw-24   #x0042)     ; 24 bit Delta Width Variable Word encoding
+           (dwvw-n    #x0043)     ; N bit Delta Width Variable Word encoding
+           (dpcm-8    #x0050)     ; 8 bit differential PCM (XI only)
+           (dpcm-16   #x0051)     ; 16 bit differential PCM (XI only)
+           )]
+        [endians ; Endian-ness options
+         '((file      #x00000000) ; Default file endian-ness
+           (little    #x10000000) ; Force little endian-ness
+           (big       #x20000000) ; Force big endian-ness
+           (cpu       #x30000000) ; Force CPU endian-ness
+           )]
+        [submask  #x0000FFFF]
+        [typemask #x0FFF0000]
+        [endmask  #x30000000])
+    (define (rev-find n l)
+      (let loop ([l l])
+        (cond [(null? l) #f]
+              [(eq? n (cadar l)) (caar l)]
+              [else (loop (cdr l))])))
+    (make-ctype _int
+      (lambda (syms)
+        (let ([major #f] [subtype #f] [endian #f])
+          (for-each
+           (lambda (sym)
+             (cond [(assq sym majors) =>
+                    (lambda (x)
+                      (if major
+                        (error 'sf-format "got two major modes: ~s" syms)
+                        (set! major (cadr x))))]
+                   [(assq sym subtypes) =>
+                    (lambda (x)
+                      (if subtype
+                        (error 'sf-format "got two subtype modes: ~s" syms)
+                        (set! subtype (cadr x))))]
+                   [(assq sym endians) =>
+                    (lambda (x)
+                      (if endian
+                        (error 'sf-format "got two endian modes: ~s" syms)
+                        (set! endian (cadr x))))]
+                   [else (error 'sf-format "got a bad symbol: ~s" sym)]))
+           (if (list? syms) syms (list syms)))
+          (bitwise-ior (or major 0) (or subtype 0) (or endian 0))))
+      (lambda (n)
+        (let ([subtype (rev-find (bitwise-and n submask)  subtypes)]
+              [major   (rev-find (bitwise-and n typemask) majors)]
+              [endian  (rev-find (bitwise-and n endmask)  endians)])
+          (unless subtype
+            (error 'sf-format "got a bad number from C for subtype: ~x"
+                   (bitwise-and n submask)))
+          (unless major
+            (error 'sf-format "got a bad number from C for major: ~x"
+                   (bitwise-and n typemask)))
+          (unless endian
+            (error 'sf-format "got a bad number from C for endian: ~x"
+                   (bitwise-and n endmask)))
+          (list major subtype endian))))))
+
+(define-cstruct _sf-info
+  ((frames     _sf-count-t)
+   (samplerate _int)
+   (channels   _int)
+   (format     _sf-format)
+   (sections   _int)
+   (seekable   _bool)))
+
+;; ==================== Utilities ====================
+
+(define-syntax defsndfile
+  (syntax-rules (:)
+    [(_ name : type ...)
+     (define name
+       (get-ffi-obj (regexp-replaces 'name '((#rx"-" "_")))
+                    libsndfile (_fun type ...)))]))
+
+(define (n-split! l n)
+  (let ([r '()])
+    (let loop ([i 0] [l (reverse! l)])
+      (unless (null? l)
+        (when (zero? i) (set! r (cons '() r)))
+        (let ([next (cdr l)])
+          (set-cdr! l (car r))
+          (set-car! r l)
+          (loop (modulo (add1 i) n) next))))
+    r))
+
+;; ==================== sndfile API ====================
+
+(defsndfile sf-close : _sndfile -> _int)
+
+(defsndfile sf-open : (path mode . info) ::
+  (path : _file)
+  (mode : _sf-mode)
+  (info : _sf-info-pointer
+        = (if (pair? info) (car info) (make-sf-info 0 0 0 '() 0 #f)))
+  -> (sf : _sndfile)
+  -> (begin (set-sndfile-info! sf info) sf))
+
+(defsndfile sf-format-check  : _sf-info-pointer -> _bool)
+
+(defsndfile sf-readf-short   : _sndfile _pointer _sf-count-t -> _sf-count-t)
+(defsndfile sf-readf-int     : _sndfile _pointer _sf-count-t -> _sf-count-t)
+(defsndfile sf-readf-double  : _sndfile _pointer _sf-count-t -> _sf-count-t)
+
+(defsndfile sf-writef-short  : _sndfile _pointer _sf-count-t -> _sf-count-t)
+(defsndfile sf-writef-int    : _sndfile _pointer _sf-count-t -> _sf-count-t)
+(defsndfile sf-writef-double : _sndfile _pointer _sf-count-t -> _sf-count-t)
+
+(defsndfile sf-get-string    : _sndfile _sf-str-type -> _string)
+(defsndfile sf-set-string    : _sndfile _sf-str-type _string -> _bool)
+
+;; ==================== Utilities for the Scheme interface ====================
+
+(define (get-strings sndfile)
+  (let loop ([sts str-types] [r '()])
+    (cond [(null? sts) (reverse! r)]
+          [(sf-get-string sndfile (car sts)) =>
+           (lambda (x)
+             (loop (cdr sts) (cons (list (car sts) (string-copy x)) r)))]
+          [else (loop (cdr sts) r)])))
+
+(define (set-strings sndfile meta)
+  (for-each (lambda (st)
+              (cond [(assq st meta) =>
+                     (lambda (x) (sf-set-string sndfile st (cadr x)))]))
+            str-types))
+
+(define (read-sound-internal file meta?)
+  (let* ([sndfile  (sf-open file 'sfm-read)]
+         [strings  (and meta? (get-strings sndfile))]
+         [info     (sndfile-info sndfile)]
+         [frames   (sf-info-frames info)]
+         [channels (sf-info-channels info)]
+         [stype    (case (sample-type)
+                     [(short) _int16] [(int) _int] [(float) _double*])]
+         [readf    (case (sample-type)
+                     [(short) sf-readf-short]
+                     [(int) sf-readf-int]
+                     [(float) sf-readf-double])]
+         [cblock   (malloc (* frames channels) stype)]
+         [num-read (readf sndfile cblock frames)]
+         [data     (cblock->list cblock stype (* num-read channels))]
+         [data     (if (> channels 1) (n-split! data channels) data)])
+    (unless (= frames num-read)
+      (error 'read-sound-internal
+             "wanted ~s frames, but got ~s" frames num-read))
+    (begin0 (if meta?
+              (values data `((frames     ,frames)
+                             (samplerate ,(sf-info-samplerate info))
+                             (channels   ,channels)
+                             (format     ,(sf-info-format     info))
+                             (sections   ,(sf-info-sections   info))
+                             ,@strings))
+              data)
+      (sf-close sndfile))))
+
+(define (frame-list->cblock data frames channels type)
+  (cond
+   [(null? data) #f]
+   [(and (= 1 channels) (not (pair? (car data)))) (list->cblock data type)]
+   [else
+    (let ([test (lambda (x)
+                  (and (list? x) (= channels (length x)) (andmap number? x)))])
+      (unless (andmap test data)
+        (error 'frame-list->cblock "got a bad frame: ~e"
+               (ormap (lambda (x) (and (not (test x)) x)) data))))
+    (let ([cblock (malloc (* channels frames) type)]
+          [i 0])
+      (let loop ([d data])
+        (cond [(number? d) (ptr-set! cblock type i d) (set! i (add1 i))]
+              [(pair? d) (loop (car d)) (loop (cdr d))]))
+      cblock)]))
+
+(define (write-sound-internal file data meta)
+  (let* ([frames     (length data)]
+         [channels   (if (or (null? data) (not (pair? (car data))))
+                       1 ; 1-channel if no data, or data is not made of lists
+                       (length (car data)))]
+         [stype      (case (sample-type)
+                       [(short) _int16] [(int) _int] [(float) _double*])]
+         [writef     (case (sample-type)
+                       [(short) sf-writef-short]
+                       [(int) sf-writef-int]
+                       [(float) sf-writef-double])]
+         [cblock     (frame-list->cblock data frames channels stype)]
+         [format     (cond [(assq 'format meta) => cadr]
+                           [else (guess-format file)])]
+         [samplerate (cond [(assq 'samplerate meta) => cadr]
+                           [else (default-samplerate)])]
+         [info       (make-sf-info frames samplerate channels format 1 #f)]
+         [_          (unless (sf-format-check info)
+                       (error 'write-sound-internal "bad format: ~s" format))]
+         [sndfile    (sf-open file 'sfm-write info)]
+         [_          (set-strings sndfile meta)]
+         [num-write  (writef sndfile cblock frames)])
+    (unless (= frames num-write)
+      (error 'write-sound-internal
+             "wanted to write ~s frames, but wrote only ~s" frames num-write))
+    (sf-close sndfile)
+    (void)))
+
+(define file-format-table
+  '((#rx"\\.aiff?" (aiff  pcm-16  file))
+    (#rx"\\.wave?" (wav   pcm-16  file))
+    (#rx"\\.au"    (au    pcm-16  file))
+    (#rx"\\.snd"   (au    pcm-16  file))
+    (#rx"\\.svx"   (svx   pcm-16  file))
+    (#rx"\\.paf"   (paf   pcm-16  big))
+    (#rx"\\.fap"   (paf   pcm-16  little))
+    (#rx"\\.nist"  (nist  pcm-16  little))
+    (#rx"\\.ircam" (ircam pcm-16  little))
+    (#rx"\\.sf"    (ircam pcm-16  little))
+    (#rx"\\.voc"   (voc   pcm-16  file))
+    (#rx"\\.w64"   (w64   pcm-16  file))
+    (#rx"\\.raw"   (raw   pcm-16  cpu))
+    (#rx"\\.mat4"  (mat4  pcm-16  little))
+    (#rx"\\.mat5"  (mat5  pcm-16  little))
+    (#rx"\\.mat"   (mat4  pcm-16  little))
+    (#rx"\\.pvf"   (pvf   pcm-16  file))
+    (#rx"\\.sds"   (sds   pcm-16  file))
+    (#rx"\\.xi"    (xi    dpcm-16 file))))
+(define (guess-format filename)
+  (let loop ([xs file-format-table])
+    (cond [(null? xs) (default-file-format)]
+          [(regexp-match (caar xs) filename) (cadar xs)]
+          [else (loop (cdr xs))])))
+
+;; ==================== Exposed Scheme interface ====================
+
+;; types of samples we handle: 'short, 'int, or 'float
+(provide sample-type)
+(define sample-type
+  (make-parameter
+   'float (lambda (x)
+            (if (memq x '(short int float))
+              x (error 'sample-type "bad type: ~s" x)))))
+
+;; TODO: add a parameter that will determine if you get a list, vector or
+;; srfi/4-like thing.  possibly also determine if a list/vector gets automatic
+;; treatment of 1-channel - not converting it into a list of singleton lists.
+
+(provide default-samplerate)
+(define default-samplerate
+  (make-parameter
+   11025 (lambda (x)
+           (if (and (integer? x) (positive? x))
+             x (error 'default-samplerate "bad samplerate: ~s" x)))))
+
+(provide default-file-format)
+(define default-file-format ; no guard, but should be good for _sf-format
+  (make-parameter '(wav pcm-16 file)))
+
+(provide read-sound)
+(define (read-sound file)
+  (read-sound-internal file #f))
+
+(provide read-sound*)
+(define (read-sound* file)
+  (read-sound-internal file #t))
+
+(provide write-sound)
+(define (write-sound file data)
+  (write-sound-internal file data '()))
+
+;; meta is used only for samplerate & format
+(provide write-sound*)
+(define (write-sound* file data meta)
+  (write-sound-internal file data meta))
+
+)
diff --git a/collects/ffi/tcl.ss b/collects/ffi/tcl.ss
new file mode 100644
index 0000000000..ce49d3462c
--- /dev/null
+++ b/collects/ffi/tcl.ss
@@ -0,0 +1,51 @@
+(module tcl mzscheme
+
+(require (lib "foreign.ss")) (unsafe!)
+
+(define libtcl (ffi-lib "libtcl"))
+
+(provide current-interp create-interp eval-tcl)
+
+(define current-interp
+  (make-parameter
+   #f (lambda (x)
+        (if (and x (cpointer? x))
+          x
+          (error 'tcl:current-interp
+                 "expecting a non-void C pointer, got ~s" x)))))
+
+;; This creates _interp as a type to be used for functions that return an
+;; interpreter that should be destroyed with delete-interp.
+(define _interp
+  (make-ctype _pointer #f ; no op when going to C
+    (lambda (interp)
+      (when interp (register-finalizer interp delete-interp))
+      interp)))
+
+;; This is for arguments that always use the value of current-interp
+(define-fun-syntax _interp*
+  (syntax-id-rules ()
+    [_ (type: _interp expr: (current-interp))]))
+
+(define create-interp
+  (get-ffi-obj "Tcl_CreateInterp" libtcl (_fun -> _interp)))
+(define delete-interp
+  (let ([f (get-ffi-obj "Tcl_DeleteInterp" libtcl (_fun _interp -> _void))])
+    (lambda (i) (f i))))
+
+(current-interp (create-interp))
+
+(define get-string-result
+  (get-ffi-obj "Tcl_GetStringResult" libtcl (_fun _interp -> _string)))
+
+(define _tclret
+  (make-ctype (_enum '(ok error return break continue))
+    (lambda (x) (error "tclret is only for return values"))
+    (lambda (x)
+      (when (eq? x 'error) (error 'tcl (get-string-result (current-interp))))
+      x)))
+
+(define eval-tcl
+  (get-ffi-obj "Tcl_Eval" libtcl (_fun _interp* (expr : _string) -> _tclret)))
+
+)
diff --git a/collects/ffi/xmmsctrl.ss b/collects/ffi/xmmsctrl.ss
new file mode 100644
index 0000000000..154342890a
--- /dev/null
+++ b/collects/ffi/xmmsctrl.ss
@@ -0,0 +1,111 @@
+(module xmmsctrl mzscheme
+
+(require (lib "foreign.ss")) (unsafe!)
+
+(define libxmms (ffi-lib "libxmms"))
+
+(provide session)
+(define session
+  (make-parameter
+   0 (lambda (x)
+       (if (integer? x)
+          x
+          (error 'xmms-session "expecting an integer, got ~s" x)))))
+
+;; used for playlist position values
+(define _pos _int)
+
+;; number of equalizer bands
+(define eq-bands 10)
+
+;; used for getting the default session from the session parameter
+(define-fun-syntax _session
+  (syntax-id-rules (_session)
+    [_session (type: _int pre: (session))]))
+
+(define-syntax defxmms
+  (syntax-rules (:)
+    [(_ name : x ...)
+     (begin
+       (provide name)
+       (define name
+         (get-ffi-obj
+          (regexp-replaces
+           'name '((#rx"-" "_") (#rx"[?]$" "") (#rx"^" "xmms_remote_")))
+          libxmms (_fun x ...))))]))
+
+(defxmms playlist : (files enqueue?) ::
+                    _session
+                    (files : (_list i _string))
+                    (_int = (length files))
+                    (enqueue? : _bool)
+                    -> _void)
+(defxmms get-version : _session -> _int)
+;; The second argument is a GList (see glib/glist.h) which requires structs,
+;; but the playlist function is sufficient (looks like this is for glib code).
+;; (defxmms playlist-add : _session "GList * list" -> _void)
+(defxmms playlist-delete : _session _pos -> _void)
+(defxmms play  : _session -> _void)
+(defxmms pause : _session -> _void)
+(defxmms stop  : _session -> _void)
+(defxmms is-playing? : _session -> _bool)
+(defxmms is-paused?  : _session -> _bool)
+(defxmms get-playlist-pos : _session -> _pos)
+(defxmms set-playlist-pos : _session _pos -> _void)
+(defxmms get-playlist-length : _session -> _pos)
+(defxmms playlist-clear : _session -> _void)
+(defxmms get-output-time : _session -> _int)
+(defxmms jump-to-time : _session _int -> _void)
+(defxmms get-volume      : _session (l : (_ptr o _int)) (r : (_ptr o _int))
+                           -> _void -> (list l r))
+(defxmms get-main-volume : _session -> _int)
+(defxmms get-balance     : _session -> _int)
+(defxmms set-volume      : _session (l : _int) (r : _int) -> _void)
+(defxmms set-main-volume : _session _int -> _void)
+(defxmms set-balance     : _session _int -> _void)
+(defxmms get-skin : _session -> _file)
+(defxmms set-skin : _session _file -> _void)
+(defxmms get-playlist-file  : _session _pos -> _string)
+(defxmms get-playlist-title : _session _pos -> _string)
+(defxmms get-playlist-time  : _session _pos -> _int)
+(defxmms get-info : _session
+                    (rate : (_ptr o _int))
+                    (freq : (_ptr o _int))
+                    (nch  : (_ptr o _int))
+                    -> _void -> (list rate freq nch))
+(defxmms main-win-toggle : _session (show? : _bool) -> _void)
+(defxmms pl-win-toggle   : _session (show? : _bool) -> _void)
+(defxmms eq-win-toggle   : _session (show? : _bool) -> _void)
+(defxmms is-main-win?    : _session -> _bool)
+(defxmms is-pl-win?      : _session -> _bool)
+(defxmms is-eq-win?      : _session -> _bool)
+(defxmms show-prefs-box : _session -> _void)
+(defxmms toggle-aot : _session (ontop? : _bool) -> _void)
+(defxmms eject : _session -> _void)
+(defxmms playlist-prev : _session -> _void)
+(defxmms playlist-next : _session -> _void)
+(defxmms playlist-add-url-string : _session _string -> _void)
+(defxmms is-running? : _session -> _bool)
+(defxmms toggle-repeat  : _session -> _void)
+(defxmms toggle-shuffle : _session -> _void)
+(defxmms is-repeat?     : _session -> _bool)
+(defxmms is-shuffle?    : _session -> _bool)
+(defxmms get-eq : _session
+                  (preamp : (_ptr o _float))
+                  (bands : (_ptr o _pointer))
+                  -> _void
+                  -> (cons preamp (cblock->list bands _float eq-bands)))
+(defxmms get-eq-preamp : _session -> _float)
+(defxmms get-eq-band : _session (band : _int) -> _float)
+(defxmms set-eq : (l) ::
+                  _session
+                  (preamp : _float = (car l))
+                  (bands : (_list i _float) = (cdr l))
+                  -> _void)
+(defxmms set-eq-preamp : _session (preamp : _float) -> _void)
+(defxmms set-eq-band   : _session (band : _int) _float -> _void)
+(defxmms quit : _session -> _void)
+(defxmms play-pause : _session -> _void)
+(defxmms playlist-ins-url-string : _session _string _pos -> _void)
+
+)
diff --git a/collects/ffi/xosd.ss b/collects/ffi/xosd.ss
new file mode 100644
index 0000000000..423449d49d
--- /dev/null
+++ b/collects/ffi/xosd.ss
@@ -0,0 +1,106 @@
+(module xosd mzscheme
+
+(require (lib "foreign.ss")) (unsafe!)
+
+(define libxosd (ffi-lib "libxosd"))
+
+;; Use this type to properly destroy an xosd object
+(define _xosd (make-ctype (_cpointer "xosd") #f
+                (lambda (p)
+                  (if p
+                    (register-finalizer p xosd-destroy)
+                    (error '_xosd "got a NULL pointer"))
+                  p)))
+
+(define-syntax defxosd
+  (syntax-rules (:)
+    [(_ name : type ...)
+     (define name
+       (get-ffi-obj (regexp-replaces 'name '((#rx"-" "_") (#rx"[*?]$" "")))
+                    libxosd (_fun type ...)))]))
+
+(define-syntax defxosd*
+  (syntax-rules ()
+    [(_ name x ...) (begin (provide name) (defxosd name x ...))]))
+
+(define _status
+  (make-ctype _int #f
+    (lambda (x)
+      (if (eq? -1 x)
+        (error 'xosd "~a"
+               (or (get-ffi-obj "xosd_error" libxosd _string)
+                   "unknown xosd error"))
+        x))))
+
+(define _sbool
+  (make-ctype _status #f
+    (lambda (x)
+      (case x [(1) #t] [(0) #f] [else (error "bad boolean value: ~e" x)]))))
+
+;; ===== Initializing =========================================================
+
+(defxosd* xosd-create : ; [num-lines = 1] -> xosd-obj
+  args :: (num-lines : _int = (if (pair? args) (car args) 1)) -> _xosd)
+(defxosd xosd-destroy : _xosd -> _int)
+
+(defxosd* xosd-is-onscreen? : _xosd -> _sbool)
+
+;; ===== Displaying & Hiding ==================================================
+
+(defxosd xosd-show* : _xosd -> _status)
+(provide xosd-show)
+(define (xosd-show xosd) (unless (xosd-is-onscreen? xosd) (xosd-show* xosd)))
+(defxosd xosd-hide* : _xosd -> _status)
+(provide xosd-hide)
+(define (xosd-hide xosd) (when   (xosd-is-onscreen? xosd) (xosd-hide* xosd)))
+
+(defxosd* xosd-set-timeout : _xosd _int -> _status)
+(defxosd* xosd-wait-until-no-display : _xosd -> _status)
+
+;; ===== Attributed ===========================================================
+
+(define _xosd-pos (_enum '(top bottom middle)))
+(define _xosd-align (_enum '(left center right)))
+
+(defxosd* xosd-set-pos               : _xosd _xosd-pos   -> _status)
+(defxosd* xosd-set-align             : _xosd _xosd-align -> _status)
+(defxosd* xosd-set-horizontal-offset : _xosd _int        -> _status)
+(defxosd* xosd-set-vertical-offset   : _xosd _int        -> _status)
+(defxosd* xosd-set-shadow-offset     : _xosd _int        -> _status)
+(defxosd* xosd-set-outline-offset    : _xosd _int        -> _status)
+(defxosd* xosd-set-colour            : _xosd _string     -> _status)
+(defxosd* xosd-set-shadow-colour     : _xosd _string     -> _status)
+(defxosd* xosd-set-outline-colour    : _xosd _string     -> _status)
+(defxosd* xosd-set-font              : _xosd _string     -> _status)
+
+(defxosd* xosd-get-colour :
+  _xosd (r : (_ptr o _int)) (g : (_ptr o _int)) (b : (_ptr o _int)) -> _status
+  -> (list r g b))
+(defxosd* xosd-get-number-lines : _xosd -> _status)
+
+;; ===== Content ==============================================================
+
+(define _xosd-command (_enum '(percentage string printf slider)))
+
+(define disp-int*
+  (get-ffi-obj "xosd_display" libxosd
+               (_fun _xosd _int _xosd-command _int -> _status)))
+(define disp-string*
+  (get-ffi-obj "xosd_display" libxosd
+               (_fun _xosd _int _xosd-command _string -> _status)))
+
+(provide xosd-display-percentage xosd-display-string xosd-display-slider)
+;; xosd-obj percent [line-num] -> int
+(define (xosd-display-percentage xosd percent . line)
+  (disp-int* xosd (if (pair? line) (car line) 0) 'percentage percent))
+;; xosd-obj string [line-num] -> int
+(define (xosd-display-string xosd str . line)
+  (disp-string* xosd (if (pair? line) (car line) 0) 'string str))
+;; xosd-obj percent [line-num] -> int
+(define (xosd-display-slider xosd int . line)
+  (disp-int* xosd (if (pair? line) (car line) 0) 'slider int))
+
+(defxosd* xosd-set-bar-length : _xosd _int -> _status)
+(defxosd* xosd-scroll : _xosd _int -> _status)
+
+)
diff --git a/collects/finish-install/doc.txt b/collects/finish-install/doc.txt
new file mode 100644
index 0000000000..bddb92c72f
--- /dev/null
+++ b/collects/finish-install/doc.txt
@@ -0,0 +1,7 @@
+
+Finish Install is for Mac OS X.
+
+The launcher (which does not embed a path to the original executable) runs the
+"install" script in the same directory as the launcher.  The collection itself
+is used only to create the launcher, which does not depend on the collection so
+it is not included in the distribution.
diff --git a/collects/finish-install/finish-install.creator b/collects/finish-install/finish-install.creator
new file mode 100644
index 0000000000..264248dc63
--- /dev/null
+++ b/collects/finish-install/finish-install.creator
@@ -0,0 +1 @@
+#Fn#
diff --git a/collects/finish-install/finish-install.icns b/collects/finish-install/finish-install.icns
new file mode 100644
index 0000000000..2d5b11f881
Binary files /dev/null and b/collects/finish-install/finish-install.icns differ
diff --git a/collects/finish-install/finish-install.ss b/collects/finish-install/finish-install.ss
new file mode 100644
index 0000000000..4e92a49b46
--- /dev/null
+++ b/collects/finish-install/finish-install.ss
@@ -0,0 +1 @@
+;; This file is never used
diff --git a/collects/finish-install/info.ss b/collects/finish-install/info.ss
new file mode 100644
index 0000000000..a2e8c0ae5b
--- /dev/null
+++ b/collects/finish-install/info.ss
@@ -0,0 +1,6 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Finish Install")
+  (define compile-omit-files '("finish-install.ss" "make.ss"))
+  (define doc.txt "doc.txt"))
+
+
diff --git a/collects/finish-install/make.ss b/collects/finish-install/make.ss
new file mode 100755
index 0000000000..26abf35435
--- /dev/null
+++ b/collects/finish-install/make.ss
@@ -0,0 +1,21 @@
+#!/bin/sh
+#|
+exec mzscheme -mvt "$0" "$@"
+|#
+
+(module make mzscheme
+  (require (lib "launcher.ss" "launcher"))
+
+  (define tiny-program
+    '(begin [use-compiled-file-paths '()]
+            (current-directory (build-path (collection-path "mzlib") 'up 'up))
+            (load "install")
+            (main '("install" "-i"))))
+  (make-mred-launcher
+   `("-mvq" "-e" ,(format "~s" tiny-program))
+   (mred-program-launcher-path "Finish Install")
+   (cons
+    '(forget-exe? . #t)
+    (build-aux-from-path (build-path
+                          (collection-path "finish-install")
+                          "finish-install")))))
diff --git a/collects/framework/collapsed-snipclass.ss b/collects/framework/collapsed-snipclass.ss
new file mode 100644
index 0000000000..4029fd7212
--- /dev/null
+++ b/collects/framework/collapsed-snipclass.ss
@@ -0,0 +1,29 @@
+(module collapsed-snipclass mzscheme
+  (require (lib "mred.ss" "mred")
+           (lib "class.ss")
+           "private/collapsed-snipclass-helpers.ss")
+  
+  (provide snip-class)
+
+  (define simple-sexp-snip%
+    (class* snip% (readable-snip<%>)
+      (init-field left-bracket right-bracket saved-snips)
+      (define/public (read-special file line col pos)
+        (let ([text (make-object text%)])
+          (for-each
+           (λ (s) (send text insert (send s copy)
+                             (send text last-position)
+                             (send text last-position)))
+           saved-snips)
+	  (datum->syntax-object
+	   #f
+	   (read (open-input-text-editor text))
+	   (list file line col pos 1))))
+      (super-instantiate ())))
+  
+  (define sexp-snipclass% (make-sexp-snipclass% simple-sexp-snip%))
+  
+  (define snip-class (make-object sexp-snipclass%))
+  (send snip-class set-classname (format "~s" '(lib "collapsed-snipclass.ss" "framework")))
+  (send snip-class set-version 0)
+  (send (get-the-snip-class-list) add snip-class))
diff --git a/collects/framework/comment-snip.ss b/collects/framework/comment-snip.ss
new file mode 100644
index 0000000000..d0f71cde14
--- /dev/null
+++ b/collects/framework/comment-snip.ss
@@ -0,0 +1,5 @@
+
+(module comment-snip mzscheme
+  (require (lib "framework.ss" "framework"))
+  
+  (provide (rename comment-box:snipclass snip-class)))
diff --git a/collects/framework/decorated-editor-snip.ss b/collects/framework/decorated-editor-snip.ss
new file mode 100644
index 0000000000..61e8864a1f
--- /dev/null
+++ b/collects/framework/decorated-editor-snip.ss
@@ -0,0 +1,214 @@
+
+(module decorated-editor-snip mzscheme
+  (provide decorated-editor-snip%
+           decorated-editor-snipclass%
+           decorated-editor-snip-mixin)
+
+  (require (lib "class.ss")
+           (lib "mred.ss" "mred"))
+  
+  (define (decorated-editor-snip-mixin super%)
+    (class super%
+      
+      ;; get-corner-bitmap : -> (union #f (is-a?/c bitmap%))
+      ;; returns the bitmap to be shown in the top right corner.
+      (define/public (get-corner-bitmap) #f)
+      
+      ;; get-color : -> (union string (is-a?/c color%))
+      (define/public (get-color) "black")
+      
+      ;; get-menu : -> (union #f (is-a?/c popup-menu%))
+      ;; returns the popup menu that should appear
+      ;; when clicking in the top part of the snip.
+      (define/public (get-menu) #f)
+
+      ;; get-position : -> (union 'top-right 'left-top)
+      ;; returns the location of the image and the clickable
+      ;; region. 'top-right indicates top portion is clickable
+      ;; and icon on right. 'left-top means left portion is
+      ;; clickable and icon on top.
+      (define/public (get-position) 'top-right)
+      
+      [define/private (get-pen) (send the-pen-list find-or-create-pen (get-color) 1 'solid)]
+      [define/private (get-brush) (send the-brush-list find-or-create-brush "BLACK" 'transparent)]      
+      
+      (inherit get-admin)
+      (define/override (on-event dc x y editorx editory evt)
+        (cond
+          [(send evt get-right-down)
+           (let ([sx (- (send evt get-x) x)]
+                 [sy (- (send evt get-y) y)]
+                 [bil (box 0)]
+                 [bit (box 0)]
+                 [bir (box 0)]
+                 [bib (box 0)]
+                 [bw (box 0)]
+                 [bh (box 0)]
+                 [bml (box 0)]
+                 [bmt (box 0)]
+                 [bmr (box 0)]
+                 [bmb (box 0)]
+                 [menu (get-menu)])
+             (get-extent dc x y bw bh #f #f #f #f)
+             (get-inset bil bit bir bib)
+             (get-margin bml bmt bmr bmb)
+             (let ([in-range
+                    (case (get-position)
+                      [(top-right)
+                       (and (<= 0 sx (unbox bw))
+                            (<= 0 sy (unbox bmt)))]
+                      [(left-top)
+                       (and (<= 0 sx (unbox bml))
+                            (<= 0 sy (unbox bh)))]
+                      [else #f])])
+               (cond
+                 [(and menu in-range)
+                  (let ([admin (get-admin)])
+                    (when admin
+                      (send admin popup-menu menu this (+ sx 1) (+ sy 1))))]
+                  [else (super on-event dc x y editorx editory evt)])))]
+          [else
+           (super on-event dc x y editorx editory evt)]))
+      
+      (inherit get-extent get-inset)
+      (define/override (draw dc x y left top right bottom dx dy draw-caret)
+        (let ([bm (get-corner-bitmap)]
+              [bil (box 0)]
+              [bit (box 0)]
+              [bir (box 0)]
+              [bib (box 0)]
+              [bw (box 0)]
+              [bh (box 0)]
+              [bml (box 0)]
+              [bmt (box 0)]
+              [bmr (box 0)]
+              [bmb (box 0)])
+          (get-extent dc x y bw bh #f #f #f #f)
+          (get-inset bil bit bir bib)
+          (get-margin bml bmt bmr bmb)
+          (super draw dc x y left top right bottom dx dy draw-caret)
+          (let* ([old-pen (send dc get-pen)]
+                 [old-brush (send dc get-brush)])
+            
+            (send dc set-pen (send the-pen-list find-or-create-pen "white" 1 'transparent))
+            (send dc set-brush (send the-brush-list find-or-create-brush "white" 'solid))
+            (case (get-position)
+              [(top-right)
+               (send dc draw-rectangle 
+                     (+ x (unbox bml))
+                     (+ y (unbox bit))
+                     (max 0 (- (unbox bw) (unbox bml) (unbox bmr)))
+                     (- (unbox bmt) (unbox bit)))]
+              [(left-top)
+               (send dc draw-rectangle 
+                     (+ x (unbox bil))
+                     (+ y (unbox bmt))
+                     (- (unbox bml) (unbox bil))
+                     (max 0 (- (unbox bh) (unbox bmt) (unbox bmb))))])
+            
+            (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
+            (send dc set-brush (send the-brush-list find-or-create-brush "black" 'solid))
+
+            (when bm
+              (let ([bm-w (send bm get-width)]
+                    [bm-h (send bm get-height)])
+                (case (get-position)
+                  [(top-right)
+                   (send dc draw-bitmap
+                         bm
+                         (+ x (max 0
+                                   (- (unbox bw)
+                                      (unbox bmr)
+                                      bm-w)))
+                         ;; leave two pixels above and two below (see super-instantiate below)
+                         (+ y (unbox bit) 2))]
+                  [(left-top)
+                   (send dc draw-bitmap
+                         bm
+                         ;; leave two pixels left and two right (see super-instantiate below)
+                         (+ x (unbox bil) 2)
+                         (+ y (unbox bmt)))])))
+            
+            (send dc set-pen (get-pen))
+            (send dc set-brush (get-brush))
+            (send dc draw-rectangle
+                  (+ x (unbox bil))
+                  (+ y (unbox bit))
+                  (max 0 (- (unbox bw) (unbox bil) (unbox bir)))
+                  (max 0 (- (unbox bh) (unbox bit) (unbox bib))))
+            
+            (send dc set-pen old-pen)
+            (send dc set-brush old-brush))))
+      
+      (inherit set-min-width set-min-height get-margin)
+      (define/public (reset-min-sizes)
+        (let ([bm (get-corner-bitmap)])
+          (when bm
+            (case (get-position)
+              [(top-right)
+               (set-min-width (+ 4 (send bm get-width)))]
+              [(left-top)
+               (set-min-height (+ 4 (send bm get-height)))]))))
+      
+      (let ([top-margin 
+             (case (get-position)
+               [(top-right)
+                (+ 4 
+                   (let ([bm (get-corner-bitmap)])
+                     (if bm
+                         (send bm get-height)
+                         0)))]
+               [else 4])]
+            [left-margin
+             (case (get-position)
+               [(left-top)
+                (+ 4
+                   (let ([bm (get-corner-bitmap)])
+                     (if bm
+                         (send bm get-width)
+                         0)))]
+               [else 4])])
+        (super-new
+          (with-border? #f)
+          (top-margin top-margin)
+          (left-margin left-margin)))
+      
+      (reset-min-sizes)))
+  
+  (define decorated-editor-snip%
+    (class (decorated-editor-snip-mixin editor-snip%)
+      (inherit get-editor get-style)
+      
+      ;; make-snip : -> this%
+      ;; returns an instance of this class. used in the copy method
+      (define/public (make-snip) (make-object decorated-editor-snip%))
+      
+      ;; make-editor : -> editor<%>
+      ;; returns the editor to be used in this snip.
+      (define/public (make-editor) (make-object text%))
+      
+      (define/override write
+        (λ (stream-out)
+          (send (get-editor) write-to-file stream-out 0 'eof)))
+
+      (define/override (copy)
+        (let ([snip (make-snip)])
+          (send snip set-editor (send (get-editor) copy-self))
+          (send snip set-style (get-style))
+          snip))
+      
+        (super-new
+          (editor (make-editor)))))
+  
+  (define decorated-editor-snipclass%
+    (class snip-class%
+      
+      ;; make-snip : stream-in -> (is-a?/c snip%)
+      ;; returns an unfilled version of the snip
+      (define/public (make-snip stream-in) (make-object decorated-editor-snip%))
+      
+      (define/override (read stream-in)
+        (let ([snip (make-snip stream-in)])
+          (send (send snip get-editor) read-from-file stream-in #f)
+          snip))
+      (super-instantiate ()))))
\ No newline at end of file
diff --git a/collects/framework/doc.txt b/collects/framework/doc.txt
new file mode 100644
index 0000000000..8f65c12840
--- /dev/null
+++ b/collects/framework/doc.txt
@@ -0,0 +1,68 @@
+
+_Framework Extras_
+
+_hierlist-editor-snip.ss_ defines two classes:
+
+--------------------------------------------------
+
+> decorated-editor-snip%, derived from editor-snip%
+   
+This class operated just like a regular editor snip, except
+that it has a color and an icon in the top right hand corner.
+
+Overridable methods:
+
+Each of these methods must be overridden in a derived class
+to specify this class's behavior.
+
+>  make-snip :: (send a-des make-snip) - returns an instance
+     of one of these snips. Defaults to returning an
+     instance of decorated-editor-snip%. Override this when
+     deriving a new class from decorated-editor-snip%.
+
+>  make-editor :: (send a-des make-editor) - returns the 
+     editor to be used in the snip. Defaultly returns an
+     instance of text%.
+
+>  get-color :: (send a-des get-color) - returns a color%
+     object or a string in the color-database%
+     that is used for the border of the snip. Defaults to
+     return "black".
+
+> get-corner-bitmap :: (send a-des get-corner-bitmap) -
+     returns the bitmap to be used in the corner of the
+     snip, or #f. Defaults to returning #f.
+
+> get-menu :: (send a-des get-menu) - returns the menu to be
+     used when someone clicks on the top portion of the
+     snip, or #f (in which case there is no menu). Defaults
+     to return #f.
+
+Overridden methods:
+
+>  write : writes the editor's contents to the file.
+
+>  copy : uses the `make-snip' method to copy the
+          snip. Creates a copy of the editor in the snip using
+          the `copy-self' method and sets the style of the
+          copy to be the style of the original.
+
+>  on-event : handles the popup menu 
+
+>  draw : draws the icon
+
+--------------------------------------------------
+
+> decorated-editor-snipclass%, derived from snip-class%
+
+Overridable method:
+
+>  make-snip :: (send a-desc make-snip stream-in) - returns
+   an instance of the snip to be created by this snipclass.
+
+Overridden method:
+
+>  write : This method matches decorated-editor-snip%'s
+           `write' method. It first calls `make-snip' to
+           create the snip and then reads the editor from
+           the stream.
diff --git a/collects/framework/framework-sig.ss b/collects/framework/framework-sig.ss
new file mode 100644
index 0000000000..1ddb27a8ad
--- /dev/null
+++ b/collects/framework/framework-sig.ss
@@ -0,0 +1,63 @@
+(module framework-sig mzscheme
+  (require (lib "unitsig.ss")
+	   "private/sig.ss")
+
+  (provide framework^ framework-class^)
+
+  (define-signature framework-class^
+    ([unit application : framework:application-class^]
+     [unit version : framework:version-class^]
+     [unit color-model : framework:color-model-class^]
+     [unit exn : framework:exn-class^]
+     [unit exit : framework:exit-class^]
+     [unit preferences : framework:preferences-class^]
+     [unit number-snip : framework:number-snip-class^]
+     [unit autosave : framework:autosave-class^]
+     [unit handler : framework:handler-class^] 
+     [unit keymap : framework:keymap-class^]
+     [unit path-utils : framework:path-utils-class^]
+     [unit icon : framework:icon-class^]
+     [unit editor : framework:editor-class^]
+     [unit pasteboard : framework:pasteboard-class^]
+     [unit text : framework:text-class^]
+     [unit finder : framework:finder-class^]
+     [unit group : framework:group-class^]
+     [unit canvas : framework:canvas-class^]
+     [unit panel : framework:panel-class^]
+     [unit menu : framework:menu-class^]
+     [unit frame : framework:frame-class^]
+     [unit color : framework:color-class^]
+     [unit color-prefs : framework:color-prefs-class^]
+     [unit scheme : framework:scheme-class^]
+     [unit comment-box : framework:comment-box-class^]
+     (unit mode : framework:mode-class^)
+     [unit main : framework:main-class^]))
+
+  (define-signature framework^
+    ([unit application : framework:application^]
+     [unit version : framework:version^]
+     [unit color-model : framework:color-model^]
+     [unit exn : framework:exn^]
+     [unit exit : framework:exit^]
+     [unit preferences : framework:preferences^]
+     [unit number-snip : framework:number-snip^]
+     [unit autosave : framework:autosave^]
+     [unit handler : framework:handler^] 
+     [unit keymap : framework:keymap^]
+     [unit path-utils : framework:path-utils^]
+     [unit icon : framework:icon^]
+     [unit editor : framework:editor^]
+     [unit pasteboard : framework:pasteboard^]
+     [unit text : framework:text^]
+     [unit finder : framework:finder^]
+     [unit group : framework:group^]
+     [unit canvas : framework:canvas^]
+     [unit panel : framework:panel^]
+     [unit menu : framework:menu^]
+     [unit frame : framework:frame^]
+     [unit color : framework:color^]
+     [unit color-prefs : framework:color-prefs^]
+     [unit scheme : framework:scheme^]
+     [unit comment-box : framework:comment-box^]
+     (unit mode : framework:mode^)
+     [unit main : framework:main^])))
diff --git a/collects/framework/framework-unit.ss b/collects/framework/framework-unit.ss
new file mode 100644
index 0000000000..f19caa06a0
--- /dev/null
+++ b/collects/framework/framework-unit.ss
@@ -0,0 +1,110 @@
+
+(module framework-unit mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "mred-sig.ss" "mred"))
+
+  (require "framework-sig.ss"
+	   "private/sig.ss"
+           "private/number-snip.ss"
+           "private/comment-box.ss"
+           "private/application.ss"
+	   "private/version.ss"
+	   "private/color-model.ss"
+	   "private/exn.ss"
+	   "private/exit.ss"
+	   "private/menu.ss"
+	   "private/preferences.ss"
+	   "private/autosave.ss"
+           "private/color.ss"
+           "private/color-prefs.ss"
+	   "private/handler.ss" 
+	   "private/keymap.ss"
+	   "private/path-utils.ss"
+	   "private/icon.ss"
+	   "private/editor.ss"
+	   "private/pasteboard.ss"
+	   "private/text.ss"
+	   "private/finder.ss"
+	   "private/group.ss"
+	   "private/canvas.ss"
+	   "private/panel.ss"
+	   "private/frame.ss"
+	   "private/scheme.ss"
+	   "private/main.ss"
+           "private/mode.ss")
+
+  (provide framework@)
+
+  (define framework@
+    (compound-unit/sig
+      (import [mred : mred^])
+      (link [application : framework:application^ (application@)]
+	    [version : framework:version^ (version@)]
+	    [color-model : framework:color-model^ (color-model@ )]
+	    [exn : framework:exn^ (exn@)]
+	    [mode : framework:mode^ (mode@)]
+            [exit : framework:exit^ (exit@ mred preferences)]
+	    [menu : framework:menu^ (menu@ mred preferences)]
+	    [preferences : framework:preferences^ (preferences@ mred exn exit panel frame)]
+            [number-snip : framework:number-snip^ (number-snip@ mred preferences)]
+	    [autosave : framework:autosave^ (autosave@ mred exit preferences frame
+                                                     scheme editor text finder group)]
+	    [path-utils : framework:path-utils^ (path-utils@)]
+	    [icon : framework:icon^ (icon@ mred)]
+
+	    [keymap : framework:keymap^
+		    (keymap@ mred preferences finder handler frame editor)]
+	    [editor : framework:editor^
+		    (editor@ mred autosave finder path-utils keymap icon
+			     preferences text pasteboard frame handler)]
+	    [pasteboard : framework:pasteboard^ (pasteboard@ mred editor)]
+	    [text : framework:text^
+		  (text@ mred icon editor preferences keymap 
+                         color-model frame scheme number-snip)]
+            [color : framework:color^ (color@ preferences icon mode text color-prefs scheme)]
+            [color-prefs : framework:color-prefs^ (color-prefs@ preferences editor panel canvas)]
+            [comment-box : framework:comment-box^
+                         (comment-box@ text scheme keymap)]
+	    [finder : framework:finder^ (finder@ mred preferences keymap)]
+	    [group : framework:group^ 
+                   (group@ mred application frame preferences text canvas menu)]
+	    [canvas : framework:canvas^ (canvas@ mred preferences frame text)]
+	    [panel : framework:panel^ (panel@ icon mred)]
+	    [frame : framework:frame^ 
+		   (frame@ mred group preferences icon handler application panel
+                           finder keymap text pasteboard editor canvas menu scheme exit
+                           comment-box)]
+	    [handler : framework:handler^
+		     (handler@ mred finder group text preferences frame)]
+
+	    [scheme : framework:scheme^ 
+		    (scheme@ mred preferences 
+                           icon keymap text editor frame comment-box mode color color-prefs)]
+	    [main : framework:main^ (main@ mred preferences exit group handler editor color-prefs scheme)])
+      (export (unit number-snip)
+              (unit menu)
+              (unit application)
+              (unit version)
+              (unit color-model)
+              (unit exn)
+              (unit exit)
+              (unit preferences)
+              (unit autosave)
+              (unit handler) 
+              (unit keymap)
+              (unit path-utils)
+              (unit icon)
+              (unit editor)
+              (unit pasteboard)
+              (unit text)
+              (unit color)
+              (unit color-prefs)
+              (unit comment-box)
+              (unit finder)
+              (unit group)
+              (unit canvas)
+              (unit panel)
+              (unit frame)
+              (unit scheme)
+              (unit mode)
+              (unit main)))))
diff --git a/collects/framework/framework.ss b/collects/framework/framework.ss
new file mode 100644
index 0000000000..c042d5ac23
--- /dev/null
+++ b/collects/framework/framework.ss
@@ -0,0 +1,1522 @@
+
+(module framework mzscheme
+  (require (lib "unitsig.ss")
+           (lib "mred.ss" "mred")
+           (lib "mred-sig.ss" "mred")
+           (lib "class.ss")
+           
+           "test.ss"
+           "gui-utils.ss"
+           "decorated-editor-snip.ss"
+           
+           "framework-unit.ss"
+           "framework-sig.ss"
+           
+           (lib "contract.ss"))
+  
+  (provide-signature-elements framework-class^)
+
+  (provide (all-from "test.ss")
+           (all-from "gui-utils.ss")
+           (all-from "decorated-editor-snip.ss"))
+
+  (provide exn:struct:unknown-preference
+           exn:struct:exn)
+
+  (define-syntax (provide/contract/docs stx)
+    (syntax-case stx ()
+      [(_ (name contract docs ...) ...)
+       (syntax (provide/contract (name contract) ...))]))
+
+  (define-values/invoke-unit/sig 
+   framework^ 
+   framework@ 
+   #f
+   mred^)
+  
+  (provide/contract/docs
+   
+   (number-snip:make-repeating-decimal-snip
+    (number? boolean? . -> . (is-a?/c snip%))
+    (num show-prefix?)
+    
+    "Makes a number snip that shows the decimal expansion for \\var{number}"
+    "The boolean indicates if a {\\tt \\#e} prefix appears"
+    "on the number."
+    ""
+    "See also"
+    "@flink number-snip:make-fraction-snip %"
+    ".")
+   (number-snip:make-fraction-snip
+    (number? boolean? . -> . (is-a?/c snip%))
+    (num show-prefix-in-decimal-view?)
+    
+    "Makes a number snip that shows a fractional view of \\var{number}."
+    "The boolean indicates if a {\\tt \\#e} prefix appears"
+    "on the number, when shown in the decimal state."
+    ""
+    "See also"
+    "@flink number-snip:make-repeating-decimal-snip %"
+    ".")   
+   (version:add-spec
+    (any/c any/c . -> . void?)
+    (spec revision)
+    "These two values are appended to the version string. \\rawscm{write} is"
+    "used to transform them to strings. For example:"
+    ""
+    "\\rawscm{(version:add-spec 's 1)}"
+    ""
+    "in version 205 will make the version string be \\rawscm{\"205s1\"}. The"
+    "symbols \\rawscm{'f} and \\rawscm{'d} are used internally for framework and"
+    "drscheme revisions.")
+   (version:version
+    (-> string?)
+    ()
+    "This function returns a string describing the version of this"
+    "application. See also "
+    "@flink version:add-spec %"
+    ".")
+
+   (exn:make-exn
+    (string? continuation-mark-set? . -> . exn?)
+    (message continuation-marks)
+    "Creates a framework exception.")
+   (exn:exn?
+    (any/c . -> . boolean?)
+    (exn)
+    "Tests if a value is a framework exception.")
+   (exn:make-unknown-preference 
+    (string? continuation-mark-set? . -> . exn:unknown-preference?)
+    (message continuation-marks)
+    "Creates an unknown preference exception.")
+   (exn:unknown-preference? 
+    (any/c . -> . boolean?)
+    (exn)
+    "Determines if a value is an unknown preference exn.")
+
+   (application:current-app-name
+    (case-> (-> string?)
+            (string? . -> . void?))
+    (() (name))
+    "This is a parameter specifying the name of the current application. It"
+    "is used in the help menu (see \\iscmclass{frame:standard-menus}) and in"
+    "frame titles (see \\iscmclass{frame:editor})."
+    ""
+    "The first case in the case-lambda returns"
+    "the current name, and"
+    "the second case in the case-lambda sets"
+    "the name of the application to \\var{name}.")
+
+   (preferences:get
+    (symbol? . -> . any/c)
+    (symbol)
+    "See also"
+    "@flink preferences:set-default %"
+    "."
+    ""
+    "\\rawscm{preferences:get} returns the value for the preference"
+    "\\var{symbol}. It raises"
+    "\\scmindex{exn:unknown-preference}\\rawscm{exn:unknown-preference}"
+    "if the preference's default has not been set.")
+   (preferences:set
+    (symbol? any/c . -> . void?)
+    (symbol value)
+    "See also"
+    "@flink preferences:set-default %"
+    "."
+    ""
+    "\\rawscm{preferences:set-preference} sets the preference"
+    "\\var{symbol} to \\var{value}. This should be called when the"
+    "users requests a change to a preference."
+    ""
+    "It raises"
+    "\\scmindex{exn:unknown-preference}\\rawscm{exn:unknown-preference}"
+    "if the preference's default has not been set.")
+   (preferences:add-callback
+    (opt-> (symbol? (symbol? any/c . -> . any/c))
+           (boolean?)
+           (-> void?))
+    ((p f)
+     ((weak? #f)))
+    "This function adds a callback which is called with a symbol naming a"
+    "preference and it's value, when the preference changes."
+    "\\rawscm{preferences:add-callback} returns a thunk, which when"
+    "invoked, removes the callback from this preference."
+    ""
+    "If \\var{weak?} is true, the preferences system will only hold on to"
+    "the callback weakly."
+    ""
+    "The callbacks will be called in the order in which they were added."
+    ""
+    "If you are adding a callback for a preference that requires"
+    "marshalling and unmarshalling, you must set the marshalling and"
+    "unmarshalling functions by calling"
+    "\\iscmprocedure{preferences:set-un/marshall} before adding a callback."
+    ""
+    "This function raises"
+    "\\scmindex{exn:unknown-preference}\\rawscm{exn:unknown-preference}"
+    "if the preference has not been set.")
+   (preferences:set-default
+    (symbol? any/c (any/c . -> . any) . -> . void?)
+    (symbol value test)
+    "This function must be called every time your application starts up, before any call to"
+    "@flink preferences:get %"
+    ", "
+    "@flink preferences:set"
+    "(for any given preference)."
+    ""
+    "If you use"
+    "@flink preferences:set-un/marshall %"
+    ", you must call this function before calling it."
+    ""
+    "This sets the default value of the preference \\var{symbol} to"
+    "\\var{value}. If the user has chosen a different setting,"
+    "the user's setting"
+    "will take precedence over the default value."
+    ""
+    "The last argument, \\var{test} is used as a safeguard. That function is"
+    "called to determine if a preference read in from a file is a valid"
+    "preference. If \\var{test} returns \\rawscm{\\#t}, then the preference is"
+    "treated as valid. If \\var{test} returns \\rawscm{\\#f} then the default is"
+    "used.")
+   (preferences:set-un/marshall
+    (symbol? (any/c . -> . printable/c) (printable/c . -> . any/c) . -> . void?)
+    (symbol marshall unmarshall)
+    "\\rawscm{preference:set-un/marshall} is used to specify marshalling and"
+    "unmarshalling functions for the preference"
+    "\\var{symbol}. \\var{marshall} will be called when the users saves their"
+    "preferences to turn the preference value for \\var{symbol} into a"
+    "printable value. \\var{unmarshall} will be called when the user's"
+    "preferences are read from the file to transform the printable value"
+    "into it's internal representation. If \\rawscm{preference:set-un/marshall}"
+    "is never called for a particular preference, the values of that"
+    "preference are assumed to be printable."
+    ""
+    "If the unmarshalling function returns a value that does not meet the"
+    "guard passed to "
+    "@flink preferences:set-default"
+    "for this preference, the default value is used."
+    ""
+    "The \\var{marshall} function might be called with any value returned"
+    "from \\scheme{read} and it must not raise an error (although it"
+    "can return arbitrary results if it gets bad input). This might"
+    "happen when the preferences file becomes corrupted, or is edited"
+    "by hand."
+    ""
+    "\\rawscm{preference:set-un/marshall} must be called before calling"
+    "@flink preferences:get %"
+    ", "
+    "@flink preferences:set %"
+    ".")
+   (preferences:save
+    (-> boolean?)
+    ()
+    "\\rawscm{(preferences:save-user-preferences)} saves the user's preferences to disk,"
+    "potentially marshalling some of the preferences."
+    ""
+    "Returns \\scm{\\#f} if saving the preferences fails and \\scm{\\#t} otherwise.")
+   (preferences:silent-save
+    (-> boolean?)
+    ()
+    "Same as"
+    "@flink preferences:save"
+    "except that it does not put display a message if it fails.")
+   (preferences:restore-defaults
+    (-> void?)
+    ()
+    "\\rawscm{(preferences:restore-defaults)} restores the users's configuration to the"
+    "default preferences.")
+
+   (preferences:add-panel
+    ((union string? (cons/c string? (listof string?)))
+     ((is-a?/c area-container-window<%>) 
+      . ->d .
+      (λ (parent)
+        (let ([children (map (λ (x) x) (send parent get-children))])
+          (λ (child)
+            (and (is-a? child area-container-window<%>)
+                 (andmap eq?
+                         (append children (list child))
+                         (send parent get-children)))))))
+     . -> .
+     void?)
+    (labels f)
+   "\\rawscm{preferences:add-preference-panel} adds the result of"
+   "\\var{f} with name \\var{labels} to the preferences dialog"
+   "box."
+   ""
+   "The labels determine where this preference panel is placed"
+   "in the dialog. If the list is just one string, the"
+   "preferences panel is placed at the top level of the dialog."
+   "If there are more strings, a hierarchy of nested panels is"
+   "created and the new panel is added at the end."
+   "If multiple calls to \\rawscm{preferences:add-preference-panel}"
+   "pass the same prefix of strings, those panels are placed in the"
+   "same children."
+   ""
+   "When the preference dialog is opened for the first"
+   "time, the function \\var{f} is called with a panel, and"
+   "\\var{f} is expected to add a new child panel to it and add"
+   "whatever preferences configuration controls it wants to that"
+   "panel. Then, \\var{f}'s should return the panel it added.")
+
+   (preferences:add-editor-checkbox-panel
+    (-> void?)
+    ()
+    "Adds a preferences panel for configuring options"
+    "related to editing.")
+   (preferences:add-warnings-checkbox-panel
+    (-> void?)
+    ()
+    "Adds a preferences panel for configuring"
+    "options relating to warnings")
+   (preferences:add-scheme-checkbox-panel
+    (-> void?)
+    ()
+    "Adds a preferences panel for configuring"
+    "options related to Scheme.")
+   
+   (preferences:add-to-warnings-checkbox-panel
+    (((is-a?/c vertical-panel%) . -> . void?) . -> . void?)
+    (proc)
+    "Saves \\var{proc} until the preferences panel is"
+    "created, when it is called with the Misc. panel to"
+    "add new children to the panel.")
+   
+   (preferences:add-to-scheme-checkbox-panel
+    (((is-a?/c vertical-panel%) . -> . void?) . -> . void?)
+    (proc)
+    "Saves \\var{proc} until the preferences panel is "
+    "created, when it is called with the Scheme "
+    "preferences panel to "
+    "add new children to the panel.")
+   
+   (preferences:add-to-editor-checkbox-panel
+    (((is-a?/c vertical-panel%) . -> . void?) . -> . void?)
+    (proc)
+    "Saves \\var{proc} until the preferences panel is "
+    "created, when it is called with the Echeme "
+    "preferences panel to "
+    "add new children to the panel.")
+
+   (preferences:add-font-panel
+    (-> void?)
+    ()
+    "Adds a font selection preferences panel to the preferences dialog.")
+   (preferences:show-dialog
+    (-> void?)
+    ()
+    "Shows the preferences dialog.")
+   (preferences:hide-dialog
+    (-> void?)
+    ()
+    "Hides the preferences dialog.")
+   (preferences:add-on-close-dialog-callback
+    ((-> void?) . -> . void?)
+    (cb)
+    "Registers \\var{cb}. Next time the"
+    "user clicks the OK button the preferences"
+    "dialog, all of the \\var{cb} functions"
+    "are called, assuming that each of the callbacks"
+    "passed to"
+    "@flink preferences:add-can-close-dialog-callback"
+    "succeed.")
+   (preferences:add-can-close-dialog-callback
+    ((-> boolean?) . -> . void?)
+    (cb)
+    "Registers \\var{cb}. Next time the"
+    "user clicks the OK button the preferences"
+    "dialog, all of the \\var{cb} functions"
+    "are called. If any of them return \\scm{\\#f},"
+    "the dialog is not closed."
+    ""
+    "See also"
+    "@flink preferences:add-on-close-dialog-callback %"
+    ".")
+
+   (autosave:register
+    ((and/c (is-a?/c autosave:autosavable<%>)
+            (is-a?/c editor<%>))
+     . -> . 
+     void?)
+    (obj)
+    "Adds \\var{obj} to the list of objects to be autosaved. When it is time"
+    "to autosave, the \\rawscm{do-autosave} method of the object is"
+    "called. This method is responsible for performing the autosave."
+    ""
+    "There is no need to"
+    "de-register an object because the autosaver keeps a ``weak'' pointer"
+    "to the object; i.e., the autosaver does not keep an object from"
+    "garbage collection.")
+   
+   (autosave:restore-autosave-files/gui
+    (-> void?)
+    ()
+    "Opens a GUI to ask the user about recovering any autosave files"
+    "left around from crashes and things."
+    ""
+    "This function doesn't return until the user has finished"
+    "restoring the autosave files. (It uses yield to handle events"
+    "however).")
+
+   (exit:exiting? 
+    (-> boolean?)
+    ()
+    "Returns \\rawscm{\\#t} to indicate that an exit"
+    "operation is taking place. Does not indicate that the"
+    "app will actually exit, since the user may cancel"
+    "the exit."
+    ""
+    "See also"
+    "@flink exit:insert-on-callback"
+    "and"
+    "@flink exit:insert-can?-callback %"
+    ".")
+   (exit:set-exiting
+    (boolean? . -> . void?)
+    (exiting?)
+    "Sets a flag that affects the result of"
+    "@flink exit:exiting? %"
+    ".")
+   (exit:insert-on-callback
+    ((-> void?) . -> . (-> void?))
+    (callback)
+    "Adds a callback to be called when exiting. This callback must not"
+    "fail. If a callback should stop an exit from happening, use"
+    "@flink exit:insert-can?-callback %"
+    ".")
+   (exit:insert-can?-callback
+    ((-> boolean?) . -> . (-> void?))
+    (callback)
+    "Use this function to add a callback that determines if an attempted"
+    "exit can proceed. This callback should not clean up any state, since"
+    "another callback may veto the exit. Use"
+    "@flink exit:insert-on-callback"
+    "for callbacks that clean up state.")
+   (exit:can-exit?
+    (-> boolean?)
+    ()
+    "Calls the ``can-callbacks'' and returns their results."
+    "See"
+    "@flink exit:insert-can?-callback"
+    "for more information.")
+   (exit:on-exit
+    (-> void?)
+    ()
+    "Calls the ``on-callbacks''. See"
+    "@flink exit:insert-on-callback"
+    "for more information.")
+   (exit:exit
+    (-> any)
+    ()
+    "\\rawscm{exit:exit} performs four actions:"
+    "\\begin{itemize}"
+    "\\item sets the result of the"
+    "@flink exit:exiting?"
+    "function to \\rawscm{\\#t}."
+    "\\item invokes the exit-callbacks, with "
+    "@flink exit:can-exit? %"
+    "If none of the ``can?'' callbacks return \\rawscm{\\#f}, "
+    "\\item"
+    "invokes"
+    "@flink exit:on-exit %"
+    "and then "
+    "\\item"
+    "queues a callback that calls"
+    "\\rawscm{exit} (a mzscheme procedure)"
+    "and (if \\rawscm{exit} returns) sets the"
+    "result of"
+    "@flink exit:exiting?"
+    "back to \\rawscm{\\#t}."
+    "\\end{itemize}")
+   (exit:user-oks-exit
+    (-> boolean?)
+    ()
+    "Opens a dialog that queries the user"
+    "about exiting. Returns the user's decision.")
+   
+   
+   (path-utils:generate-autosave-name
+    (string? . -> . string?)
+    (filename)
+    "Generates a name for an autosave file from \\var{filename}.")
+   (path-utils:generate-backup-name
+    (path? . -> . path?)
+    (filename)
+    "Generates a name for an backup file from \\var{filename}.")
+   (finder:dialog-parent-parameter
+    any/c
+    ()
+    "This is a parameter (see "
+    "\\Mzhyperref{parameters}{mz:parameters} for information about parameters)"
+    "which determines the parent of the dialogs created by"
+    "@flink finder:get-file %"
+    ", "
+    "@flink finder:put-file %"
+    ","
+    "@flink finder:common-get-file %"
+    ","
+    "@flink finder:common-put-file %"
+    ","
+    "@flink finder:common-get-file-list %"
+    ","
+    "@flink finder:std-get-file %"
+    ", and"
+    "@flink finder:std-put-file %"
+    ".")
+   (finder:default-extension
+    (case-> (-> string?)
+            (string? . -> . void?))
+    (() (extension))
+    "This parameter controls the default extension for the framework's "
+    "@flink finder:put-file"
+    "dialog. Its value gets passed as the"
+    "\\var{default-extension} argument to"
+    "@flink put-file %"
+    "."
+    ""
+    "Its default value is \\rawscm{\"\"}.")
+   (finder:default-filters
+    (case->
+     ((listof (list/c string? string?)) . -> . void?)
+     (-> (listof (list/c string? string?))))
+    ((filters) ())
+    "This parameter controls the default extension for the framework's "
+    "@flink finder:put-file"
+    "dialog. Its value gets passed as the"
+    "\\var{default-filters} argument to"
+    "@flink put-file %"
+    "."
+    ""
+    "Its default value is \\rawscm{'((\"Any\" \"*.*\"))}.")
+
+   (finder:common-put-file
+    (opt->
+     ()
+     (string?
+      (union false/c path?)
+      boolean?
+      string?
+      (union false/c byte-regexp?)
+      string?
+      (union (is-a?/c top-level-window<%>) false/c))
+     (union false/c path?))
+    (()
+     ((name "Untitled")
+      (directory #f)
+      (replace? #f)
+      (prompt "Select File")
+      (filter #f)
+      (filter-msg "That filename does not have the right form.")
+      (parent (finder:dialog-parent-parameter))))
+    "This procedure queries the user for a single filename, using a"
+    "platform-independent dialog box. Consider using"
+    "@flink finder:put-file "
+    "instead of this function."
+    ""
+    "See section \\ref{selecting-a-filename} for more information.")
+   (finder:common-get-file
+    (opt->
+     ()
+     ((union path? false/c)
+      string?
+      (union byte-regexp? false/c)
+      string?
+      (union false/c (is-a?/c top-level-window<%>)))
+     (union path? false/c))
+    (()
+     ((directory #f)
+      (prompt "Select File")
+      (filter #f)
+      (filter-msg "That filename does not have the right form.")
+      (parent #f)))
+    "This procedure queries the user for a single filename, using a"
+    "platform-independent dialog box. Consider using"
+    "@flink finder:get-file "
+    "instead of this function."
+    ""
+    "See section \\ref{selecting-a-filename} for more information.")
+   (finder:std-put-file
+    (opt->
+     ()
+     (string?
+      (union false/c path?)
+      boolean?
+      string?
+      (union false/c byte-regexp?)
+      string?
+      (union (is-a?/c top-level-window<%>) false/c))
+     (union false/c path?))
+    (()
+     ((name "Untitled")
+      (directory #f)
+      (replace? #f)
+      (prompt "Select File")
+      (filter #f)
+      (filter-msg "That filename does not have the right form.")
+      (parent (finder:dialog-parent-parameter))))
+    "This procedure queries the user for a single filename, using a"
+    "platform-dependent dialog box. Consider using"
+    "@flink finder:put-file "
+    "instead of this function."
+    ""
+    "See section \\ref{selecting-a-filename} for more information.")
+   (finder:std-get-file
+    (opt->
+     ()
+     ((union path? false/c)
+      string?
+      (union byte-regexp? false/c)
+      string?
+      (union false/c (is-a?/c top-level-window<%>)))
+     (union path? false/c))
+    (()
+     ((directory #f)
+      (prompt "Select File")
+      (filter #f)
+      (filter-msg "That filename does not have the right form.")
+      (parent #f)))
+    "This procedure queries the user for a single filename, using a"
+    "platform-dependent dialog box. Consider using"
+    "@flink finder:get-file "
+    "instead of this function."
+    ""
+    "See section \\ref{selecting-a-filename} for more information.")
+   (finder:put-file
+    (opt->
+     ()
+     (string?
+      (union false/c path?)
+      boolean?
+      string?
+      (union false/c byte-regexp?)
+      string?
+      (union (is-a?/c top-level-window<%>) false/c))
+     (union false/c path?))
+    (()
+     ((name "Untitled")
+      (directory #f)
+      (replace? #f)
+      (prompt "Select File")
+      (filter #f)
+      (filter-msg "That filename does not have the right form.")
+      (parent (finder:dialog-parent-parameter))))
+    "Queries the user for a filename."
+    ""
+    "If the result of \\rawscm{(%"
+    "@flink preferences:get"
+    "'framework:file-dialogs)}"
+    "is \\rawscm{'std} this calls "
+    "@flink finder:std-put-file %"
+    ", and if it is \\rawscm{'common}, "
+    "@flink finder:common-put-file"
+    "is called.")
+   (finder:get-file
+    (opt->
+     ()
+     ((union path? false/c)
+      string?
+      (union byte-regexp? string? false/c)
+      string?
+      (union false/c (is-a?/c top-level-window<%>)))
+     (union path? false/c))
+    (()
+     ((directory #f)
+      (prompt "Select File")
+      (filter #f)
+      (filter-msg "That filename does not have the right form.")
+      (parent #f)))    
+    "Queries the user for a filename."
+    ""
+    "If the result of \\rawscm{(%"
+    "@flink preferences:get"
+    "'framework:file-dialogs)}"
+    "is \\rawscm{'std} this calls "
+    "@flink finder:std-get-file %"
+    ", and if it is \\rawscm{'common}, "
+    "@flink finder:common-get-file"
+    "is called.")
+   (finder:common-get-file-list
+    (opt->
+     ()
+     ((union false/c path?)
+      string?
+      (union false/c byte-regexp?)
+      string?
+      (union false/c (is-a?/c top-level-window<%>)))
+     (union (listof path?) false/c))
+    (()
+     ((directory #f)
+      (prompt "Select File")
+      (filter #f)
+      (filter-msg "That filename does not have the right form.")
+      (parent #f)))
+    "This procedure queries the user for a list of filenames, using a"
+    "platform-independent dialog box."
+    ""
+    "See section \\ref{selecting-a-filename} for more information.")
+
+   (frame:setup-size-pref
+    (symbol? number? number? . -> . void)
+    (size-pref-sym width height)
+    "Initializes a preference for the"
+    "@mixin-link frame:size-pref"
+    "mixin."
+    ""
+    "The first argument should be the preferences symbol, and the second an third"
+    "should be the default width and height, respectively.")
+   (frame:add-snip-menu-items
+    ((is-a?/c menu%) (subclass?/c menu-item%) . -> . void?)
+    (menu menu-item%)
+    "Inserts three menu items into \\var{menu},"
+    "one that inserts a text box, one that inserts a"
+    "pasteboard box, and one that inserts an image"
+    "into the currently focused editor (if there is one)."
+    "Uses \\var{menu-item\\%} as the class for"
+    "the menu items.")
+   
+   (frame:reorder-menus
+    ((is-a?/c frame%) . -> . void?)
+    (frame)
+    "Re-orders the menus in a frame. It moves the ``File'' and ``Edit'' menus to"
+    "the front of the menubar and moves the ``Windows'' and ``Help'' menus"
+    "to the end of the menubar."
+    ""
+    "This is useful in conjunction with the "
+    "frame classes. After instantiating the class and adding ones own menus,"
+    "the menus will be mis-ordered. This function fixes them up.")
+   (group:get-the-frame-group
+    (-> (is-a?/c group:%))
+    ()
+    "This returns the frame group.")
+   
+   (handler:handler?
+    (any/c . -> . boolean?)
+    (obj)
+    "This predicate determines if its input is a handler")
+   (handler:handler-name
+    (handler:handler? . -> . string?)
+    (handler)
+    "Extracts the name from a handler.")
+   (handler:handler-extension
+    (handler:handler? . -> . (union (path? . -> . boolean?) (listof string?)))
+    (handler)
+    "Extracts the extension from a handler.")
+   (handler:handler-handler
+    (handler:handler? . -> . (path? . -> . (is-a?/c frame:editor<%>)))
+    (handler)
+    "Extracs the handler's handling function")
+   (handler:insert-format-handler
+    (string?
+     (union string? (listof string?) (path? . -> . boolean?))
+     (path? . -> . (union false/c (is-a?/c frame:editor<%>)))
+     . -> .
+     void?)
+    (name pred handler)
+    "This function inserts a format handler."
+    ""
+    "The string, \\var{name} names the format handler for use with"
+    "@flink handler:find-named-format-handler %"
+    ". If \\var{pred} is a string, it is matched with the extension of a filename by"
+    "@flink handler:find-format-handler %"
+    ". If \\var{pred} is a list of strings, they are each matched with the extension of a filename by"
+    "@flink handler:find-format-handler %"
+    ". If it is a function, the filename is applied to the function and the"
+    "functions result determines if this is the handler to use.")
+   (handler:find-named-format-handler
+    (string? . -> . (path? . -> . (is-a?/c frame:editor<%>)))
+    (name)
+    "This function selects a format handler. See also"
+    "@flink handler:insert-format-handler %"
+    "."
+    ""
+    "It finds a handler based on \\var{name}.")
+   (handler:find-format-handler
+    (path? . -> . (path? . -> . (is-a?/c frame:editor<%>)))
+    (filename)
+    "This function selects a format handler. See also"
+    "@flink handler:insert-format-handler %"
+    "."
+    ""
+    "It finds a handler based on \\var{filename}.")
+
+   (handler:edit-file
+    (opt->
+     ((union path? false/c))
+     ((-> (is-a?/c frame:editor<%>)))
+     (union false/c (is-a?/c frame:editor<%>)))
+    ((filename)
+     ((make-default (λ () ((handler:current-create-new-window) filename)))))
+    "This function creates a frame or re-uses an existing frame to edit a file. "
+    ""
+    "If the preference \\scheme{'framework:open-here} is set to \\scheme{#t},"
+    "and (send ("
+    "@flink group:get-the-frame-group %"
+    ") "
+    "@link group: get-open-here-frame %"
+    ") returns a frame, the "
+    "@ilink frame:open-here open-here "
+    "method of that frame is used to load"
+    "the file in the existing frame."
+    ""
+    "Otherwise, it invokes the appropriate format"
+    "handler to open the file (see"
+    "@flink handler:insert-format-handler %"
+    ")."
+    ""
+    "\\begin{itemize}"
+    "\\item If \\var{filename} is a string, this function checks the result of"
+    "@flink group:get-the-frame-group"
+    "to see if the \\var{filename} is already open by a frame in the"
+    "group. "
+    "\\begin{itemize}"
+    "\\item If so, it returns the frame. "
+    "\\item If not, this function calls "
+    "@flink handler:find-format-handler"
+    "with \\var{filename}. "
+    "\\begin{itemize}"
+    "\\item"
+    "If a handler is found, it is applied to"
+    "\\var{filename} and it's result is the final result. "
+    "\\item"
+    "If not, \\var{make-default} is used."
+    "\\end{itemize}"
+    "\\end{itemize}"
+    "\\item"
+    "If \\var{filename} is \\rawscm{\\#f}, \\var{make-default} is used."
+    "\\end{itemize}")
+
+   (handler:current-create-new-window
+    (case->
+     (((union false/c path?) . -> . (is-a?/c frame%)) . -> . void)
+     (-> ((union false/c string?) . -> . (is-a?/c frame%))))
+    ((new-window-handler) ())
+    "This is a parameter that controls how the framework"
+    "creates new application windows."
+    ""
+    "The default setting is this:"
+    "\\begin{schemedisplay}"
+    "(λ (filename)"
+    "  (let ([frame (make-object frame:text-info-file% filename)])"
+    "    (send frame show #t)"
+    "    frame))"
+    "\\end{schemedisplay}")
+
+   (handler:open-file
+    (-> (union false/c (is-a?/c frame:basic<%>)))
+    ()
+    "This function queries the user for a filename and opens the file for"
+    "editing. It uses "
+    "@flink handler:edit-file"
+    "to open the file, once the user has chosen it."
+    ""
+    "Calls"
+    "@flink finder:get-file"
+    "and"
+    "@flink handler:edit-file %"
+    ".")
+   
+   (handler:install-recent-items
+    ((is-a?/c menu%) . -> . void?)
+    (menu)
+    "This function deletes all of the items in the given menu and"
+    "adds one menu item for each recently opened file. These menu"
+    "items, when selected, call"
+    "@flink handler:edit-file"
+    "with the filename of the recently opened file."
+    ""
+    "The menu's size is limited to 10.")
+   
+   (handler:set-recent-items-frame-superclass
+    ((implementation?/c frame:standard-menus<%>) . -> . void?)
+    (frame)
+    "Sets the superclass for the recently opened files frame."
+    "It must be derived from"
+    "@ilink frame:standard-menus %"
+    ".")
+
+   (handler:add-to-recent
+    (path? . -> . void?)
+    (filename)
+    "Adds a filename to the list of recently opened files.")
+
+   (handler:set-recent-position
+    (string? number? number? . -> . void?)
+    (filename start end)
+    "Sets the selection of the recently opened file to"
+    "\\var{start} and \\var{end}.")
+   
+   (handler:size-recently-opened-files
+    (number? . -> . void?)
+    (num)
+    "Sizes the 'framework:recently-opened-files/pos preference"
+    "list length to \\var{num}.")
+
+   (icon:get-paren-highlight-bitmap
+    (-> (is-a?/c bitmap%))
+    ()
+    "This returns the parenthesis highlight "
+    "@link bitmap %"
+    ". It is only used on black and white screens.")
+   (icon:get-eof-bitmap
+    (-> (is-a?/c bitmap%))
+    ()
+    "This returns the"
+    "@link bitmap %"
+    "used for the clickable ``eof'' icon from"
+    "@ilink text:ports %"
+    ".")
+   (icon:get-autowrap-bitmap
+    (-> (is-a?/c bitmap%))
+    ()
+    "This returns the autowrap's "
+    "@link bitmap %"
+    "."
+    ""
+    "The bitmap may not respond \\scm{\\#t} to the"
+    "@link bitmap ok?"
+    "method.")
+   (icon:get-lock-bitmap 
+    (-> (is-a?/c bitmap%))
+    ()
+    "This returns the lock's "
+    "@link bitmap %"
+    "."
+    ""
+    "The bitmap may not respond \\scm{\\#t} to the"
+    "@link bitmap ok?"
+    "method.")
+   (icon:get-unlock-bitmap
+    (-> (is-a?/c bitmap%))
+    ()
+    "This returns the reset unlocked"
+    "@link bitmap %"
+    "."
+    ""
+    "The bitmap may not respond \\scm{\\#t} to the"
+    "@link bitmap ok?"
+    "method."
+    "")
+   (icon:get-anchor-bitmap
+    (-> (is-a?/c bitmap%))
+    ()
+    "This returns the anchor's "
+    "@link bitmap %"
+    "."
+    ""
+    "The bitmap may not respond \\scm{\\#t} to the"
+    "@link bitmap ok?"
+    "method.")
+   (icon:get-left/right-cursor
+    (-> (is-a?/c cursor%))
+    ()
+    "This function returns a "
+    "@link cursor"
+    "object that indicates left/right sizing is possible,"
+    "for use with columns inside a window."
+    ""
+    "The cursor may not respond \\scm{\\#t} to the"
+    "@link cursor ok?"
+    "method.")
+   (icon:get-up/down-cursor
+    (-> (is-a?/c cursor%))
+    ()
+    "This function returns a "
+    "@link cursor"
+    "object that indicates up/down sizing is possible,"
+    "for use with columns inside a window."
+    ""
+    "The cursor may not respond \\scm{\\#t} to the"
+    "@link cursor ok?"
+    "method.")
+   (icon:get-gc-on-bitmap
+    (-> (is-a?/c bitmap%))
+    ()
+    "This returns a bitmap to be displayed in an"
+    "@ilink frame:info"
+    "frame when garbage collection is taking place."
+    ""
+    "The bitmap may not respond \\scm{\\#t} to the"
+    "@link bitmap ok?"
+    "method.")
+   (icon:get-gc-off-bitmap
+    (-> (is-a?/c bitmap%))
+    ()
+    "This returns a bitmap to be displayed in an"
+    "@ilink frame:info"
+    "frame when garbage collection is {\\em not\\/} taking place."
+    ""
+    "The bitmap may not respond \\scm{\\#t} to the"
+    "@link bitmap ok?"
+    "method.")
+
+   (keymap:remove-user-keybindings-file
+    (-> path? any)
+    (user-keybindings-path)
+    "Removes the keymap previously added by"
+    "@flink keymap:add-user-keybindings-file %"
+    ".")
+   (keymap:add-user-keybindings-file
+    (-> path? any)
+    (user-keybindings-path)
+    "Chains the keymap defined by \\var{user-keybindings-path} to "
+    "the global keymap, returned by "
+    "@flink keymap:get-global %"
+    ".")
+   (keymap:add-to-right-button-menu
+    (case->
+     (((is-a?/c popup-menu%) (is-a?/c editor<%>) (is-a?/c event%) . -> . void?) . -> . void?)
+     (-> ((is-a?/c popup-menu%) (is-a?/c editor<%>) (is-a?/c event%) . -> . void?)))
+    ((func) ())
+    "When the keymap that "
+    "@flink keymap:get-global"
+    "returns is installed into an editor, this parameter's value"
+    "is used for right button clicks. "
+    ""
+    "Before calling this procedure, the "
+    "function"
+    "@flink append-editor-operation-menu-items"
+    "is called."
+    ""
+    "See also"
+    "@flink keymap:add-to-right-button-menu/before %"
+    ".")
+
+   (keymap:add-to-right-button-menu/before
+    (case->
+     (((is-a?/c popup-menu%) (is-a?/c editor<%>) (is-a?/c event%) . -> . void?)
+      . -> .
+      void?)
+     (-> ((is-a?/c popup-menu%) (is-a?/c editor<%>) (is-a?/c event%) . -> . void?)))
+    ((func) ())
+    "When the keymap that "
+    "@flink keymap:get-global"
+    "returns is installed into an editor, this function is called"
+    "for right button clicks. "
+    ""
+    "After calling this procedure, the "
+    "function"
+    "@flink append-editor-operation-menu-items"
+    "is called."
+    ""
+    "See also"
+    "@flink keymap:add-to-right-button-menu %"
+    ".")
+
+   (keymap:call/text-keymap-initializer
+    ((-> any/c) . -> . any/c)
+    (thunk-proc)
+    "Thus function parameterizes the call to \\var{thunk-proc} by"
+    " setting the keymap-initialization procedure (see"
+    "%"
+    "@flink current-text-keymap-initializer  %"
+    "%"
+    ") to install the framework's standard text bindings.")
+
+   (keymap:canonicalize-keybinding-string
+    (string? . -> . string?)
+    (keybinding-string)
+    "Returns a string that denotes the same keybindings as the input"
+    "string, except that it is in canonical form; two canonical keybinding"
+    "strings can be compared with \\rawscm{string=?}.")
+
+   (keymap:get-editor
+    (-> (is-a?/c keymap%))
+    ()
+    "This returns a keymap for handling standard editing operations.  It"
+    "binds these keys:"
+    "\\begin{itemize}"
+    "\\item {\\bf z}: undo"
+    "\\item {\\bf y}: redo"
+    "\\item {\\bf x}: cut"
+    "\\item {\\bf c}: copy"
+    "\\item {\\bf v}: paste"
+    "\\item {\\bf a}: select all"
+    "\\end{itemize}"
+    "where each key is prefixed with the menu-shortcut key, based on the"
+    "platform. Under unix, the shortcut is scm{\"a:\"}; under windows the"
+    "shortcut key is \\rawscm{\"c:\"} and under MacOS, the shortcut key is"
+    "\\rawscm{\"d:\"}.")
+
+   (keymap:get-file
+    (-> (is-a?/c keymap%))
+    ()
+    "This returns a keymap for handling file operations.")
+
+   (keymap:get-global
+    (-> (is-a?/c keymap%))
+    ()
+    "This returns a keymap for general operations. See"
+    "@flink keymap:setup-global"
+    "for a list of the bindings this keymap contains.")
+
+   (keymap:get-search
+    (-> (is-a?/c keymap%))
+    ()
+    "This returns a keymap for searching operations")
+
+   (keymap:make-meta-prefix-list
+    (string? . -> . (listof string?))
+    (key)
+    "This prefixes a key with all of the different meta prefixes and"
+    "returns a list of the prefixed strings."
+    ""
+    "takes a keymap, a base key specification, and a function name; it"
+    "prefixes the base key with all ``meta'' combination prefixes, and"
+    "installs the new combinations into the keymap. For example,"
+    "\\rawscm{(\\iscmprocedure{keymap:send-map-function-meta} \\var{keymap} \"a\""
+    "\\var{func})} maps all of ``m:a'' and ``ESC;a'' to"
+    "\\var{func}.")
+
+   (keymap:send-map-function-meta
+    ((is-a?/c keymap%) string? string? . -> . void?)
+    (keymap key func)
+    "\\index{Meta}"
+    "Most keyboard and mouse mappings are inserted into a keymap by calling"
+    "the keymap's \\rawscm{map-function} method. However, ``meta'' combinations"
+    "require special attention. The ``m:'' prefix recognized by"
+    "\\rawscm{map-function} applies only to the Meta key that exists on"
+    "some keyboards. By convention, however, ``meta'' combinations can also be"
+    "accessed by using ``ESC'' as a prefix."
+    ""
+    "This procedure binds all of the key-bindings obtained by prefixing"
+    "\\var{key} with a meta-prefix to \\var{func} in \\var{keymap}.")
+
+   (keymap:setup-editor
+    ((is-a?/c keymap%) . -> . void?)
+    (keymap)
+    "This sets up the input keymap with the bindings described in "
+    "@flink keymap:get-editor %"
+    ".")
+
+   (keymap:setup-file
+    ((is-a?/c keymap%) . -> . void?)
+    (keymap)
+    "This extends a "
+    "@link keymap"
+    "with the bindings for files.")
+
+   (keymap:setup-global
+    ((is-a?/c keymap%) . -> . void?)
+    (keymap)
+    "This extends a "
+    "@link keymap"
+    "with the general bindings."
+    ""
+    "This function extends a \\iscmclass{keymap} with the following functions:"
+    "\\begin{itemize}"
+    "\\CloseLines"
+    "\\item \\mapdesc{ring-bell}{any} --- Rings the bell (using \\iscmprocedure{bell}) and"
+    "removes the search panel from the frame, if there."
+    "\\item \\mapdesc{save-file}{key} --- Saves the buffer. If the buffer has "
+    "no name, then \\scmfirst{finder:put-file} is invoked."
+    "\\item \\mapdesc{save-file-as}{key} --- Calls \\scmfirst{finder:put-file} to save"
+    "the buffer."
+    "\\item \\mapdesc{load-file}{key} --- Invokes \\scmfirst{finder:open-file}."
+    "\\item \\mapdesc{find-string}{key} --- Opens the search buffer at the bottom"
+    "of the frame, unless it is already open, in which case it searches for the"
+    "text in the search buffer."
+    "\\item \\mapdesc{find-string-reverse}{key} --- Same a ``find-string'', but in"
+    "the reverse direction."
+    "\\item \\mapdesc{find-string-replace}{key} --- Opens a replace string dialog"
+    "box. "
+    "\\item \\mapdesc{toggle-anchor}{key} --- Turns selection-anchoring on or off."
+    "\\item \\mapdesc{center-view-on-line}{key} --- Centers the buffer in its"
+    "display using the currently selected line."
+    "\\item \\mapdesc{collapse-space}{key} --- Collapses all non-return whitespace"
+    "around the caret into a single space."
+    "\\item \\mapdesc{remove-space}{key} --- Removes all non-return whitespace"
+    "around the caret."
+    "\\item \\mapdesc{collapse-newline}{key} --- Collapses all empty lines"
+    "around the caret into a single empty line. If there is only"
+    "one empty line, it is removed."
+    "\\item \\mapdesc{open-line}{key} --- Inserts a new line."
+    "\\item \\mapdesc{transpose-chars}{key} --- Transposes the characters before"
+    "and after the caret and moves forward one position."
+    "\\item \\mapdesc{transpose-words}{key} --- Transposes words before"
+    "and after the caret and moves forward one word."
+    "\\item \\mapdesc{capitalize-word}{key} --- Changes the first character"
+    "of the next word to a capital letter and moves to the end of the"
+    "word."
+    "\\item \\mapdesc{upcase-word}{key} --- Changes all characters"
+    "of the next word to capital letters and moves to the end of the"
+    "word."
+    "\\item \\mapdesc{downcase-word}{key} --- Changes all characters"
+    "of the next word to lowercase letters and moves to the end of the"
+    "word."
+    "\\item \\mapdesc{kill-word}{key} --- Kills the next word."
+    "\\item \\mapdesc{backward-kill-word}{key} --- Kills the previous word."
+    "\\item \\mapdesc{goto-line}{any} --- Queries the user for a line number and moves"
+    "the caret there."
+    "\\item \\mapdesc{goto-position}{any}  --- Queries the user for a position number "
+    "and moves the caret there."
+    "\\item \\mapdesc{copy-clipboard}{mouse} --- Copies the current selection to the"
+    "clipboard."
+    "\\item \\mapdesc{cut-clipboard}{mouse} --- Cuts the current selection to the"
+    "clipboard."
+    "\\item \\mapdesc{paste-clipboard}{mouse} --- Patses the clipboard to the current"
+    "selection."
+    "\\item \\mapdesc{copy-click-region}{mouse} --- Copies the region between the"
+    "caret and the input mouse event."
+    "\\item \\mapdesc{cut-click-region}{mouse} --- Cuts the  region between the"
+    "caret and the input mouse event."
+    "\\item \\mapdesc{paste-click-region}{mouse} --- Pastes the clipboard into the"
+    "position of the input mouse event."
+    "\\item \\mapdesc{select-click-word}{mouse} --- Selects the word under the"
+    "input mouse event."
+    "\\item \\mapdesc{select-click-line}{mouse} --- Selects the line under the"
+    "input mouse event."
+    "\\item \\mapdesc{start-macro}{key} -- Starts building a keyboard macro"
+    "\\item \\mapdesc{end-macro}{key} --- Stops building a keyboard macro"
+    "\\item \\mapdesc{do-macro}{key} --- Executes the last keyboard macro"
+    "\\item \\mapdesc{toggle-overwrite}{key} --- Toggles overwriting mode"
+    "\\end{itemize}"
+    ""
+    "These functions are bound to the following keys (C = control, S ="
+    "shift, A = alt, M = ``meta'', D = command):"
+    "\\begin{itemize}"
+    "\\CloseLines"
+    "\\item C-g : ``ring-bell''"
+    "\\item M-C-g : ``ring-bell''"
+    "\\item C-c C-g : ``ring-bell''"
+    "\\item C-x C-g : ``ring-bell''"
+    "\\item C-p : ``previous-line''"
+    "\\item S-C-p : ``select-previous-line''"
+    "\\item C-n : ``next-line''"
+    "\\item S-C-n : ``select-next-line''"
+    "\\item C-e : ``end-of-line''"
+    "\\item S-C-e : ``select-to-end-of-line''"
+    "\\item D-RIGHT : ``end-of-line''"
+    "\\item S-D-RIGHT : ``select-to-end-of-line''"
+    "\\item M-RIGHT : ``end-of-line''"
+    "\\item S-M-RIGHT : ``select-to-end-of-line''"
+    "\\item C-a : ``beginning-of-line''"
+    "\\item S-C-a : ``select-to-beginning-of-line''"
+    "\\item D-LEFT : ``beginning-of-line''"
+    "\\item D-S-LEFT : ``select-to-beginning-of-line''"
+    "\\item M-LEFT : ``beginning-of-line''"
+    "\\item M-S-LEFT : ``select-to-beginning-of-line''"
+    "\\item C-h : ``delete-previous-character''"
+    "\\item C-d : ``delete-next-character''"
+    "\\item C-f : ``forward-character''"
+    "\\item S-C-f : ``select-forward-character''"
+    "\\item C-b : ``backward-character''"
+    "\\item S-C-b : ``select-backward-character''"
+    "\\item M-f : ``forward-word''"
+    "\\item S-M-f : ``select-forward-word''"
+    "\\item A-RIGHT : ``forward-word''"
+    "\\item A-S-RIGHT : ``forward-select-word''"
+    "\\item M-b : ``backward-word''"
+    "\\item S-M-b : ``select-backward-word''"
+    "\\item A-LEFT : ``backward-word''"
+    "\\item A-S-LEFT : ``backward-select-word''"
+    "\\item M-d : ``kill-word''"
+    "\\item M-DELETE : ``backward-kill-word''"
+    "\\item M-c : ``capitalize-word''"
+    "\\item M-u : ``upcase-word''"
+    "\\item M-l : ``downcase-word''"
+    "\\item M-$<$ : ``beginning-of-file''"
+    "\\item S-M-$<$ : ``select-to-beginning-of-file''"
+    "\\item M-$>$ : ``end-of-file''"
+    "\\item S-M-$>$ : ``select-to-end-of-file''"
+    "\\item C-v : ``next-page''"
+    "\\item S-C-v : ``select-next-page''"
+    "\\item M-v : ``previous-page''"
+    "\\item S-M-v : ``select-previous-page''"
+    "\\item C-l : ``center-view-on-line''"
+    "\\item C-k : ``delete-to-end-of-line''"
+    "\\item C-y : ``paste-clipboard'' (Except Windows)"
+    "\\item A-v : ``paste-clipboard''"
+    "\\item D-v : ``paste-clipboard''"
+    "\\item C-\\_ : ``undo''"
+    "\\item C-x u : ``undo''"
+    "\\item C-+ : ``redo''"
+    "\\item C-w : ``cut-clipboard''"
+    "\\item M-w : ``copy-clipboard''"
+    "\\item C-x C-s : ``save-file''"
+    "\\item C-x C-w : ``save-file-as''"
+    "\\item C-x C-f : ``load-file''"
+    "\\item C-s : ``find-string''"
+    "\\item C-r : ``find-string-reverse''"
+    "\\item M-\\% : ``find-string-replace''"
+    "\\item SPACE : ``collapse-space''"
+    "\\item M-{\\Backslash} : ``remove-space''"
+    "\\item C-x C-o : ``collapse-newline''"
+    "\\item C-o : ``open-line''"
+    "\\item C-t : ``transpose-chars''"
+    "\\item M-t : ``transpose-words''"
+    "\\item C-SPACE : ``toggle-anchor''"
+    "\\item M-g : ``goto-line''"
+    "\\item M-p : ``goto-position''"
+    "\\item LEFTBUTTONTRIPLE : ``select-click-line''"
+    "\\item LEFTBUTTONDOUBLE : ``select-click-word''"
+    "\\item RIGHTBUTTON : ``copy-click-region''"
+    "\\item RIGHTBUTTONDOUBLE : ``cut-click-region''"
+    "\\item MIDDLEBUTTON : ``paste-click-region''"
+    "\\item C-RIGHTBUTTON : ``copy-clipboard''"
+    "\\item INSERT : ``toggle-overwrite''"
+    "\\item M-o : ``toggle-overwrite''"
+    "\\end{itemize}")
+
+   (keymap:setup-search
+    ((is-a?/c keymap%) . -> . void?)
+    (keymap)
+    "This extends a "
+    "@link keymap"
+    "with the bindings for searching.")
+
+   (keymap:set-chained-keymaps
+    ((is-a?/c keymap:aug-keymap<%>)
+     (listof (is-a?/c keymap%))
+     . -> .
+     void?)
+    (keymap children-keymaps)
+    "Sets \\var{keymap}'s chained keymaps to \\var{children-keymaps},"
+    "unchaining any keymaps that are currently chained to \\var{keymap}.")
+   
+   (keymap:remove-chained-keymap
+    ((is-a?/c editor<%>)
+     (is-a?/c keymap:aug-keymap<%>)
+     . -> . 
+     void?)
+    (editor keymap)
+    "Removes \\var{keymap} from the keymaps chained to \\var{editor}."
+    "Also (indirectly) removes all keymaps chained to \\var{keymap} from \\var{editor},"
+    "since they are removed when unchaining \\var{keymap} itself."
+    ""
+    "Each of the keymaps chained to \\var{editor} must be an"
+    "@ilink keymap:aug-keymap"
+    "and \\var{keymap} cannot be the result of"
+    "\\begin{schemedisplay}"
+    "(send editor get-keymap)"
+    "\\end{schemedisplay}"
+    "That is, \\var{keymap} must be chained to some keymap attached"
+    "to the editor.")
+    
+   (scheme:text-balanced?
+    (opt->
+     ((is-a?/c text%))
+     (number? (union false/c number?))
+     boolean?)
+   ((text)
+    ((start 0) (end #f)))
+   "Determines if the range in the editor from \\var{start} to \\var{end} in \\var{text}"
+   "is a matched set of parenthesis. If \\var{end} is \\scheme{#f}, it"
+   "defaults to the last position of the \\var{text}."
+   ""
+   "The implementation of this function creates a port with"
+   "@flink open-input-text-editor"
+   "and then uses `read' to parse the range of the buffer.")
+   
+   (scheme:add-preferences-panel
+     (-> void?)
+     ()
+     "Adds a tabbing preferences panel to the preferences dialog.")
+
+    (scheme:get-keymap
+     (-> (is-a?/c keymap%))
+     ()
+     "Returns a keymap with binding suitable for Scheme.")
+
+    (scheme:add-coloring-preferences-panel
+     (-> any)
+     ()
+     "Installs the ``Scheme'' preferences panel in the ``Syntax Coloring''"
+     "section.")
+    
+    (scheme:get-color-prefs-table
+     (-> (listof (list/c symbol? (is-a?/c color%))))
+     ()
+     "Returns a table mapping from symbols (naming the categories that"
+     "the online colorer uses for Scheme mode coloring) to their"
+     "colors."
+     ""
+     "These symbols are suitable for input to"
+     "@flink scheme:short-sym->pref-name"
+     "and"
+     "@flink scheme:short-sym->style-name %"
+     ".")
+    
+    (scheme:short-sym->pref-name
+     (symbol? . -> . symbol?)
+     (short-sym)
+     "Builds the symbol naming the preference from one of the symbols"
+     "in the table returned by"
+     "@flink scheme:get-color-prefs-table %"
+     ".")
+    
+    (scheme:short-sym->style-name
+     (symbol? . -> . string?)
+     (short-sym)
+     "Builds the symbol naming the editor style from one of the symbols"
+     "in the table returned by"
+     "@flink scheme:get-color-prefs-table %"
+     ". This style is a named style in the style list"
+     "returned by"
+     "@flink editor:get-standard-style-list %"
+     ".")
+    
+    (editor:set-default-font-color
+     (-> (is-a?/c color%) void?)
+     (color)
+     "Sets the color of the style named"
+     "@flink editor:get-default-color-style-name %"
+     ".")
+    (editor:get-default-color-style-name
+     (-> string?)
+     ()
+     "The name of the style (in the list returned by "
+     "@flink editor:get-standard-style-list %"
+     ") that holds the default color.")
+    (editor:set-standard-style-list-delta 
+     (string? (is-a?/c style-delta%) . -> . void?)
+     (name delta)
+     "Finds (or creates) the style named by \\var{name} in"
+     "the result of "
+     "@flink editor:get-standard-style-list"
+     "and sets its delta to \\var{delta}."
+     ""
+     "If the style named by \\var{name} is already in"
+     "the style list, it must be a delta style.")
+    
+    (editor:set-standard-style-list-pref-callbacks
+     (-> any)
+     ()
+     "Installs the font preference callbacks that"
+     "update the style list returned by"
+     "@flink editor:get-standard-style-list"
+     "based on the font preference symbols.")
+    
+    (editor:get-standard-style-list
+     (-> (is-a?/c style-list%))
+     ()
+     "Returns a style list that is used for all instances of \\iscmintf{editor:standard-style-list}.")
+
+    (scheme:get-wordbreak-map
+     (-> (is-a?/c editor-wordbreak-map%))
+     ()
+     "This method returns a"
+     "@link editor-wordbreak-map"
+     "that is suitable for Scheme.")
+
+    (scheme:init-wordbreak-map
+     ((is-a?/c keymap%) . -> . void?)
+     (key)
+     "Initializes the workdbreak map for \\var{keymap}.")
+
+    (scheme:setup-keymap
+     ((is-a?/c keymap%) . -> . void?)
+     (keymap)
+     "Initializes \\var{keymap} with Scheme-mode keybindings.")
+
+    (color-model:rgb->xyz
+     (number? number? number? . -> . color-model:xyz?)
+     (r g b)
+     "Converts a color represented as a red-green-blue tuple (each value"
+     "from 0 to 255) into an XYZ tuple. This describes a point in the"
+     "CIE XYZ color space.")
+
+    (color-model:rgb-color-distance
+     (number? number? number? number? number? number? . -> . number?)
+     (red-a green-a blue-a red-b green-b blue-b)
+     "This calculates a distance between two colors. The smaller the"
+     "distance, the closer the colors should appear to the human eye. A"
+     "distance of 10 is reasonably close that it could be called the same"
+     "color."
+     ""
+     "This function is not symmetric in red, green, and blue, so it is"
+     "important to pass red, green, and blue components of the colors in the"
+     "the proper order. The first three arguments are red, green and blue"
+     "for the first color, respectively, and the second three arguments are"
+     "red green and blue for the second color, respectively.")
+
+    (color-model:xyz->rgb
+     (number? number? number? . -> . (list/c number? number? number?))
+     (x y z)
+     "Converts an XYZ-tuple (in the CIE XYZ colorspace) into a list of"
+     "values representing an RGB-tuple.")
+
+    (color-model:xyz?
+     (any/c . -> . boolean?)
+     (val)
+     "Determines if \\var{val} an xyz color record.")
+
+    (color-model:xyz-x
+     (color-model:xyz? . -> . number?)
+     (xyz)
+     "Extracts the x component of \\var{xyz}.")
+    (color-model:xyz-y
+     (color-model:xyz? . -> . number?)
+     (xyz)
+     "Extracts the y component of \\var{xyz}.")
+    (color-model:xyz-z
+     (color-model:xyz? . -> . number?)
+     (xyz)
+     "Extracts the z component of \\var{xyz}.")
+    
+    (color-prefs:register-color-pref 
+     (symbol? string? (is-a?/c color%) . -> . void?)
+     (pref-name style-name color)
+     "This function registers a color preference and initializes the"
+     "style list returned from"
+     "@flink editor:get-standard-style-list %"
+     ". In particular, it calls "
+     "@flink preferences:set-default "
+     "and "
+     "@flink preferences:set-un/marshall "
+     "to install the pref for \\var{pref-name}, using"
+     "\\var{color} as the default color. The preference"
+     "is bound to a \\iscmclass{style-delta}, and initially the \\iscmclass{style-delta}"
+     "changes the foreground color to \\var{color}."
+     "Then, it calls "
+     "@flink editor:set-standard-style-list-delta"
+     "passing the \\var{style-name} and the current value"
+     "of the preference \\var{pref-name}."
+     ""
+     "Finally, it adds calls"
+     "@flink preferences:add-callback "
+     "to set a callback for \\var{pref-name} that"
+     "updates the style list when the preference changes.")
+      
+    (color-prefs:add-background-preferences-panel
+     (-> void?)
+     ()
+     "Adds a preferences panel that configures the background"
+     "color for"
+     "@mixin-link editor:basic-mixin %"
+     ".")
+    (color-prefs:add-to-preferences-panel
+     (string? ((is-a?/c vertical-panel%) . -> . void?) . -> . void?)
+     (name func)
+     "Calls \\var{func} with the subpanel of the preferences coloring panel that"
+     "corresponds to \\var{name}.")
+    
+    (color-prefs:build-color-selection-panel
+     ((is-a?/c area-container<%>) symbol? string? string? . -> . void?)
+     (parent pref-sym style-name example-text)
+     "Builds a panel with a number of controls for configuring"
+     "a font: the color and check boxes for bold, italic, and underline."
+     "The \\var{parent} argument specifies where the panel will be"
+     "placed. The \\var{pref-sym} should be a preference (suitable for"
+     "use with"
+     "@flink preferences:get "
+     "and"
+     "@flink preferences:set %"
+     "). The \\var{style-name} specifies the name of a style in the"
+     "style list returned from"
+     "@flink editor:get-standard-style-list"
+     "and \\var{example-text} is shown in the panel so users can see"
+     "the results of their configuration.")
+
+    (color-prefs:marshall-style
+     (-> (is-a?/c style-delta%) printable/c)
+     (style-delta)
+     "Builds a printed representation for a style-delta.")
+    
+    (color-prefs:unmarshall-style
+     (-> printable/c (union false/c (is-a?/c style-delta%)))
+     (marshalled-style-delta)
+     "Builds a style delta from its printed representation."
+     "Returns \\scheme|#f| if the printed form cannot be parsed.")
+    
+    ))
diff --git a/collects/framework/gui-utils.ss b/collects/framework/gui-utils.ss
new file mode 100644
index 0000000000..e8e058c380
--- /dev/null
+++ b/collects/framework/gui-utils.ss
@@ -0,0 +1,489 @@
+
+(module gui-utils mzscheme
+  (require (lib "class.ss")
+	   (lib "mred.ss" "mred")
+           (lib "etc.ss")
+           (lib "contract.ss")
+           (lib "string-constant.ss" "string-constants"))
+  
+  (define-syntax (provide/contract/docs stx)
+    (syntax-case stx ()
+      [(_ (name contract docs ...) ...)
+       (syntax (provide/contract (name contract) ...))]))
+  
+  (provide/contract/docs
+   
+   (gui-utils:trim-string
+    (string?
+     (and/c number? positive?)
+     . ->d .
+     (λ (str size)
+       (and/c string?
+	      (λ (str)
+		((string-length str) . <= . size)))))
+    (str size)
+    "Constructs a string whose size is less"
+    "than \\var{size} by trimming the \\var{str}"
+    "and inserting an ellispses into it.")
+
+   (gui-utils:cancel-on-right?
+    (-> boolean?)
+    ()
+    "Returns \\scheme{#t} if cancel should be on the right-hand side (or below)"
+    "in a dialog and \\scheme{#f} otherwise."
+    ""
+    "See also"
+    "@flink gui-utils:ok/cancel-buttons %"
+    ".")
+   (gui-utils:ok/cancel-buttons
+    (opt->*
+     ((is-a?/c area-container<%>)
+      ((is-a?/c button%) (is-a?/c event%) . -> . any)
+      ((is-a?/c button%) (is-a?/c event%) . -> . any))
+     (string?
+      string?)
+     ((is-a?/c button%)
+      (is-a?/c button%)))
+    ((parent
+      confirm-callback
+      cancel-callback)
+     ((confirm-label (string-constant ok))
+      (cancel-label (string-constant cancel))))
+    "Adds an Ok and a cancel button to a panel, changing the order"
+    "to suit the platform. Under \\MacOSBoth{} and unix, the confirmation action"
+    "is on the right (or bottom) and under Windows, the canceling action is on the"
+    "right (or bottom)."
+    "The confirmation action button has the \\scheme|'(border)| style."
+    "The buttons are also sized to be the same width."
+    ""
+    "The first result is be the OK button and the second is"
+    "the cancel button."
+    ""
+    "See also"
+    "@flink gui-utils:cancel-on-right? %"
+    ".")
+   
+   (gui-utils:next-untitled-name
+    (-> string?)
+    ()
+    "Returns a name for the next opened untitled frame. The first"
+    "name is ``Untitled'', the second is ``Untitled 2'',"
+    "the third is ``Untitled 3'', and so forth.")
+   (gui-utils:cursor-delay
+    (case->
+     (-> real?)
+     (real? . -> . void?))
+    (() (new-delay))
+    "This function is {\\em not\\/} a parameter."
+    "Instead, the state is just stored in the closure."
+    ""
+    "The first case in the case lambda"
+    "returns the current delay in seconds before a watch cursor is shown,"
+    "when either \\iscmprocedure{gui-utils:local-busy-cursor} or"
+    "\\iscmprocedure{gui-utils:show-busy-cursor} is called."
+
+    "The second case in the case lambda"
+    "Sets the delay, in seconds, before a watch cursor is shown, when"
+    "either \\iscmprocedure{gui-utils:local-busy-cursor} or"
+    "\\iscmprocedure{gui-utils:show-busy-cursor} is called.")
+   (gui-utils:show-busy-cursor
+    (opt->
+     ((-> any/c))
+     (integer?)
+     any/c)
+    ((thunk)
+     ((delay (gui-utils:cursor-delay))))
+    "Evaluates \\rawscm{(\\var{thunk})} with a watch cursor. The argument"
+    "\\var{delay} specifies the amount of time before the watch cursor is"
+    "opened. Use \\iscmprocedure{gui-utils:cursor-delay} to set this value"
+    "to all calls."
+    ""
+    "This function returns the result of \\var{thunk}.")
+   (gui-utils:delay-action
+    (real?
+     (-> void?)
+     (-> void?)
+     . -> .
+     void?)
+    (delay-time open close)
+    "Use this function to delay an action for some period of time. It also"
+    "supports cancelling the action before the time period elapses. For"
+    "example, if you want to display a watch cursor, but you only want it"
+    "to appear after 2 seconds and the action may or may not take more than"
+    "two seconds, use this pattern:"
+    ""
+    "\\begin{schemedisplay}"
+    "(let ([close-down"
+    "       (gui-utils:delay-action"
+    "        2"
+    "        (λ () .. init watch cursor ...)"
+    "        (λ () .. close watch cursor ...))])"
+    "  ;; .. do action ..."
+    "  (close-down))"
+    "\\end{schemedisplay}"
+    ""
+    "Creates a thread that waits \\var{delay-time}. After \\var{delay-time}"
+    "has elapsed, if the result thunk has {\\em not} been called, call"
+    "\\var{open}. Then, when the result thunk is called, call"
+    "\\var{close}. The function \\var{close} will only be called if"
+    "\\var{open} has been called.")
+
+   (gui-utils:local-busy-cursor
+    (opt->
+     ((is-a?/c window<%>)
+      (-> any/c))
+     (integer?)
+     any/c)
+    ((window thunk)
+     ((delay (gui-utils:cursor-delay))))
+    "Evaluates \\rawscm{(\\var{thunk})} with a watch cursor in \\var{window}. If"
+    "\\var{window} is \\rawscm{\\#f}, the watch cursor is turned on globally. The"
+    "argument \\var{delay} specifies the amount of time before the watch"
+    "cursor is opened. Use "
+    "@flink gui-utils:cursor-delay "
+    "to set this value for all uses of this function."
+    ""
+    "The result of this function is the result of \\var{thunk}.")
+
+   (gui-utils:unsaved-warning
+    (opt->
+     (string?
+      string?)
+     (boolean?
+      (union false/c
+	     (is-a?/c frame%)
+	     (is-a?/c dialog%)))
+     (symbols 'continue 'save 'cancel))
+    ((filename action)
+     ((can-save-now? #f)
+      (parent #f)))
+
+    "This displays a dialog that warns the user of a unsaved file."
+    ""
+    "The string, \\var{action}, indicates what action is about to"
+    "take place, without saving. For example, if the application"
+    "is about to close a file, a good action is \\rawscm{\"Close"
+    "Anyway\"}. The result symbol indicates the user's choice. If"
+    "\\var{can-save-now?} is \\rawscm{\\#f}, this function does not"
+    "give the user the ``Save'' option and thus will not return"
+    "\\rawscm{'save}.")
+
+   (gui-utils:get-choice
+    (opt->
+     (string?
+      string?
+      string?)
+     (string?
+      any/c
+      (union false/c (is-a?/c frame%) (is-a?/c dialog%))
+      (symbols 'app 'caution 'stop))
+     any/c)
+    ((message true-choice false-choice)
+     ((title (string-constant warning))
+      (default-result 'disallow-close)
+      (paren #f)
+      (style 'app)))
+
+    "Opens a dialog that presents a binary choice to the user. The user is forced"
+    "to choose between these two options, ie cancelling or closing the dialog"
+    "opens a message box asking the user to actually choose one of the two options."
+    ""
+    "The dialog will contain the string \\var{message} and two buttons,"
+    "labeled with the \\var{true-choice} and the \\var{false-choice}.  If the"
+    "user clicks on \\var{true-choice} \\rawscm{\\#t} is returned. If the user"
+    "clicks on \\var{false-choice}, \\rawscm{\\#f} is returned."
+    ""
+    "The argument \\var{default-result} determines how closing the window is"
+    "treated. If the argument is \\rawscm{'disallow-close}, closing the window"
+    "is not allowed. If it is anything else, that value is returned when"
+    "the user closes the window."
+    ""
+    "If "
+    "@flink gui-utils:cancel-on-right?"
+    "returns \\scheme|#t|, the false choice is on the right."
+    "Otherwise, the true choice is on the right."
+    ""
+    "The \\var{style} parameter is (eventually) passed to"
+    "@link message"
+    "as an icon in the dialog.")
+
+   (gui-utils:get-clicked-clickback-delta
+    (-> (is-a?/c style-delta%))
+    ()
+    "This delta is designed for use with"
+    "@link text set-clickback %"
+    ". Use it as one of the \\iscmclass{style-delta} argument to"
+    "@link text set-clickback %"
+    "."
+    ""
+    "See also"
+    "@flink gui-utils:get-clickback-delta %"
+    ".")
+
+   (gui-utils:get-clickback-delta
+    (-> (is-a?/c style-delta%))
+    ()
+    "This delta is designed for use with"
+    "@link text set-clickback %"
+    ". Use the result of this function as the style"
+    "for the region"
+    "text where the clickback is set." 
+    ""
+    "See also"
+    "@flink gui-utils:get-clicked-clickback-delta %"
+    "."))
+
+  (define (trim-string str size)
+    (let ([str-size (string-length str)])
+      (cond
+	[(<= str-size size)
+	 str]
+	[else
+	 (let* ([between "..."]
+		[pre-length (- (quotient size 2)
+			       (quotient (string-length between) 2))]
+		[post-length (- size
+				pre-length
+				(string-length between))])
+	   (cond
+	     [(or (<= pre-length 0)
+		  (<= post-length 0))
+	      (substring str 0 size)]
+	     [else
+	      (string-append
+	       (substring str 0 pre-length)
+	       between
+	       (substring str
+			  (- str-size post-length)
+			  str-size))]))])))
+  
+  ;; selected-text-color : color
+  (define selected-text-color (send the-color-database find-color "black"))
+
+  ;; unselected-text-color : color
+  (define unselected-text-color (case (system-type)
+                                  [(macosx) (make-object color% 75 75 75)]
+                                  [else (send the-color-database find-color "black")]))
+
+  ;; selected-brush : brush
+  (define selected-brush (send the-brush-list find-or-create-brush "WHITE" 'solid))
+
+  ;; unselected-brush : brush
+  (define unselected-brush (send the-brush-list find-or-create-brush (get-panel-background) 'solid))
+
+  ;; button-down/over-brush : brush
+  (define button-down/over-brush 
+    (case (system-type)
+      [(macosx) (send the-brush-list find-or-create-brush
+                      "light blue"
+                      'solid)]
+      [else
+       (send the-brush-list find-or-create-brush
+             (make-object color% 225 225 255)
+             'solid)]))
+
+  
+  ;; name-box-pen : pen
+  ;; this pen draws the lines around each individual item
+  (define name-box-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
+
+  ;; background-brush : brush
+  ;; this brush is set when drawing the background for the control
+  (define background-brush 
+    (case (system-type)
+      [(macosx) (send the-brush-list find-or-create-brush (get-panel-background) 'panel)]
+      [else (send the-brush-list find-or-create-brush "white" 'solid)]))
+  
+  ;; background-pen : pen
+  ;; this pen is set when drawing the background for the control
+  (define background-pen (send the-pen-list find-or-create-pen "black" 1 'transparent))
+    
+  ;; label-font : font
+  (define label-font (send the-font-list find-or-create-font
+                           (if (eq? (system-type) 'windows) 10 12)
+                           'system 'normal
+                           (if (eq? (system-type) 'macosx) 'bold 'normal)
+                           #f))
+
+  ;; name-gap : number
+  ;; the space between each name
+  (define name-gap 4)
+  
+  ;; hang-over : number
+  ;; the amount of space a single entry "slants" over
+  (define hang-over 8)
+  
+  ;; top-space : number
+  ;; the gap at the top of the canvas, above all the choices
+  (define top-space 4)
+  
+  ;; bottom-space : number
+  ;; the extra space below the words
+  (define bottom-space 2)
+  
+  ;; end choices-canvas%
+  
+  (define (cancel-on-right?) (eq? (system-type) 'windows))
+  
+  (define ok/cancel-buttons
+    (opt-lambda (parent 
+                 confirm-callback
+                 cancel-callback 
+                 [confirm-str (string-constant ok)]
+                 [cancel-str (string-constant cancel)])
+      (let ([confirm (λ ()
+                       (instantiate button% ()
+                         (parent parent)
+                         (callback confirm-callback)
+                         (label confirm-str)
+                         (style '(border))))]
+            [cancel (λ ()
+                      (instantiate button% ()
+                        (parent parent)
+                        (callback cancel-callback)
+                        (label cancel-str)))])
+        (let-values ([(b1 b2)
+                      (cond
+                        [(cancel-on-right?)
+                         (values (confirm) (cancel))]
+                        [else
+                         (values (cancel) (confirm))])])
+          (let ([w (max (send b1 get-width)
+                        (send b2 get-width))])
+            (send b1 min-width w)
+            (send b2 min-width w)
+	    (if (cancel-on-right?)
+		(values b1 b2)
+		(values b2 b1)))))))
+
+  
+  (define clickback-delta (make-object style-delta% 'change-underline #t))
+  (send clickback-delta set-delta-foreground "BLUE")
+  (define (get-clickback-delta) clickback-delta)
+  (define clicked-clickback-delta (make-object style-delta%))
+  (send clicked-clickback-delta set-delta-background "BLACK")
+  (define (get-clicked-clickback-delta) clicked-clickback-delta)
+  
+  (define next-untitled-name
+    (let ([n 1])
+      (λ ()
+        (begin0
+          (cond
+            [(= n 1) (string-constant untitled)]
+            [else (format (string-constant untitled-n) n)])
+          (set! n (+ n 1))))))
+  
+  (define cursor-delay
+    (let ([x 0.25])
+      (case-lambda
+        [() x]
+        [(v) (set! x v) x])))
+  
+  (define show-busy-cursor
+    (opt-lambda (thunk [delay (cursor-delay)])
+      (local-busy-cursor #f thunk delay)))
+  
+  (define delay-action
+    (λ (delay-time open close)
+      (let ([semaphore (make-semaphore 1)]
+            [open? #f]
+            [skip-it? #f])
+        (thread 
+         (λ ()
+           (sleep delay-time)
+           (semaphore-wait semaphore)
+           (unless skip-it?
+             (set! open? #t)
+             (open))
+           (semaphore-post semaphore)))
+        (λ ()
+          (semaphore-wait semaphore)
+          (set! skip-it? #t)
+          (when open?
+            (close))
+          (semaphore-post semaphore)))))
+  
+  (define local-busy-cursor
+    (let ([watch (make-object cursor% 'watch)])
+      (case-lambda
+        [(win thunk) (local-busy-cursor win thunk (cursor-delay))]
+        [(win thunk delay)
+         (let* ([old-cursor #f]
+                [cursor-off void])
+           (dynamic-wind
+            (λ ()
+              (set! cursor-off
+                    (delay-action
+                     delay
+                     (λ ()
+                       (if win
+                           (begin (set! old-cursor (send win get-cursor))
+                                  (send win set-cursor watch))
+                           (begin-busy-cursor)))
+                     (λ ()
+                       (if win
+                           (send win set-cursor old-cursor)
+                           (end-busy-cursor))))))
+            (λ () (thunk))
+            (λ () (cursor-off))))])))
+  
+  (define unsaved-warning
+    (opt-lambda (filename action-anyway (can-save-now? #f) (parent #f))
+      (let ([mb-res (message-box/custom 
+                     (string-constant warning)
+                     (format (string-constant file-is-not-saved) filename)
+                     (string-constant save)
+                     (string-constant cancel)
+                     action-anyway
+                     parent
+                     (if can-save-now?
+                         '(default=1 caution)
+                         '(default=2 caution))
+                     2)])
+        (case mb-res
+          [(1) 'save]
+          [(2) 'cancel]
+          [(3) 'continue]))))
+  
+  (define get-choice
+    (opt-lambda (message 
+                 true-choice
+                 false-choice 
+                 (title (string-constant warning))
+                 (default-result 'disallow-close)
+                 (parent #f)
+                 (style 'app))
+      (let ([mb-res (message-box/custom
+                     title
+                     message
+                     true-choice
+                     false-choice
+                     #f
+                     parent
+                     (case default-result
+                       [(disallow-close) 
+                        (if (eq? style 'app)
+                            `(default=1 disallow-close)
+                            `(default=1 disallow-close ,style))]
+                       [else (if (eq? style 'app)
+                                 `(default=1)
+                                 `(default=1 ,style))])
+                     default-result)])
+        (case mb-res
+          [(1) #t]
+          [(2) #f]
+          [else mb-res]))))
+  
+  ;; manual renaming
+  (define gui-utils:trim-string trim-string)
+  (define gui-utils:next-untitled-name next-untitled-name)
+  (define gui-utils:show-busy-cursor show-busy-cursor)
+  (define gui-utils:delay-action delay-action)
+  (define gui-utils:local-busy-cursor local-busy-cursor)
+  (define gui-utils:unsaved-warning unsaved-warning)
+  (define gui-utils:get-choice get-choice)
+  (define gui-utils:get-clicked-clickback-delta get-clicked-clickback-delta)
+  (define gui-utils:get-clickback-delta get-clickback-delta)
+  (define gui-utils:ok/cancel-buttons ok/cancel-buttons)
+  (define gui-utils:cancel-on-right? cancel-on-right?)
+  (define gui-utils:cursor-delay cursor-delay))
diff --git a/collects/framework/info.ss b/collects/framework/info.ss
new file mode 100644
index 0000000000..58291b91a7
--- /dev/null
+++ b/collects/framework/info.ss
@@ -0,0 +1,4 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Framework")
+  (define doc.txt "doc.txt"))
+
diff --git a/collects/framework/keybinding-lang.ss b/collects/framework/keybinding-lang.ss
new file mode 100644
index 0000000000..52492b3292
--- /dev/null
+++ b/collects/framework/keybinding-lang.ss
@@ -0,0 +1,66 @@
+(module keybinding-lang mzscheme
+  (require (lib "mred.ss" "mred")
+           (lib "string-constant.ss" "string-constants")
+           (lib "framework.ss" "framework")
+           (lib "class.ss"))
+  
+  (provide (rename kl-module-begin #%module-begin)
+           (all-from-except mzscheme #%module-begin)
+           (all-from (lib "framework.ss" "framework"))
+           (all-from (lib "mred.ss" "mred"))
+           (all-from (lib "class.ss")))
+  
+  (define-syntax (kl-module-begin stx)
+    (syntax-case stx ()
+      [(mb a ...) 
+       (with-syntax ([#%keymap (datum->syntax-object (syntax mb) '#%keymap)]
+                     [#%keybinding (datum->syntax-object (syntax mb) '#%keybinding)]
+                     [keybinding (datum->syntax-object (syntax mb) 'keybinding)])
+         (syntax (#%plain-module-begin 
+                  (define #%keymap (make-object keymap:aug-keymap%))
+                  (provide #%keymap)
+                  (define (#%keybinding key proc src line col pos)
+                    (unless (string? key)
+                      (error 'keybinding "expected string as first argument, got ~e (other arg ~e)" key proc))
+                    (unless (and (procedure? proc)
+                                 (procedure-arity-includes? proc 2))
+                      (error 'keybinding "expected procedure of two arguments as second argument, got ~e (other arg ~e)"
+                             proc
+                             key))
+                    (let ([name (if (and line col)
+                                    (format "~a:~a.~a" src line col)
+                                    (format "~a:~a" src pos))])
+                      (send #%keymap add-function name 
+                            (λ (x y)
+                              (let ([end-edit-sequence
+                                     (λ ()
+                                       (when (is-a? x editor<%>)
+                                         (let loop ()
+                                           (when (send x in-edit-sequence?)
+                                             (send x end-edit-sequence)
+                                             (loop)))))])
+                              (with-handlers ([exn:fail? 
+                                               (λ (x)
+                                                 (end-edit-sequence)
+                                                 (message-box (string-constant drscheme)
+                                                              (format (string-constant user-defined-keybinding-error) 
+                                                                      name
+                                                                      (exn-message x))))])
+                                (proc x y)
+                                (when (is-a? x editor<%>)
+                                  (when (send x in-edit-sequence?)
+                                    (end-edit-sequence)
+                                    (message-box (string-constant drscheme)
+                                                 (format (string-constant user-defined-keybinding-error) 
+                                                                      name
+                                                                      "Editor left in edit-sequence"))))))))
+                      (send #%keymap map-function key name)))
+                  (define-syntax (keybinding stx)
+                    (syntax-case stx ()
+                      [(_ key val)
+                       (with-syntax ([src (syntax-source stx)]
+                                     [line (syntax-line stx)]
+                                     [col (syntax-column stx)]
+                                     [pos (syntax-position stx)])
+                         (syntax (#%keybinding key val 'src 'line 'col 'pos)))]))
+                  a ...)))])))
diff --git a/collects/framework/private/application.ss b/collects/framework/private/application.ss
new file mode 100644
index 0000000000..da32f122fc
--- /dev/null
+++ b/collects/framework/private/application.ss
@@ -0,0 +1,18 @@
+(module application mzscheme
+  (require (lib "unitsig.ss")
+	   "sig.ss"
+	   (lib "mred-sig.ss" "mred"))
+
+  (provide application@)
+
+  (define application@
+    (unit/sig framework:application^
+      (import)
+
+      (define current-app-name (make-parameter
+				"MrEd"
+				(λ (x)
+				  (unless (string? x)
+				    (error 'current-app-name
+					   "the app name must be a string"))
+				  x))))))
\ No newline at end of file
diff --git a/collects/framework/private/autosave.ss b/collects/framework/private/autosave.ss
new file mode 100644
index 0000000000..01513a1382
--- /dev/null
+++ b/collects/framework/private/autosave.ss
@@ -0,0 +1,319 @@
+
+(module autosave mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "class.ss")
+           (lib "file.ss")
+	   "sig.ss"
+	   "../gui-utils.ss"
+	   (lib "mred-sig.ss" "mred")
+           (lib "mred.ss" "mred") ;; remove this!
+           (lib "list.ss")
+           (lib "string-constant.ss" "string-constants"))
+
+  (provide autosave@)
+  
+  (define autosave@
+    (unit/sig framework:autosave^
+      (import mred^
+	      [exit : framework:exit^]
+	      [preferences : framework:preferences^]
+              [frame : framework:frame^]
+              [scheme : framework:scheme^]
+              [editor : framework:editor^]
+              [text : framework:text^]
+              [finder : framework:finder^]
+              [group : framework:group^])
+      
+      (define autosavable<%>
+	(interface ()
+	  do-autosave))
+
+      (define objects null)
+      
+      (define autosave-toc-filename
+        (build-path (find-system-path 'pref-dir)
+                    (case (system-type)
+                      [(unix) ".plt-autosave-toc"]
+                      [else "PLT-autosave-toc"])))
+      
+      (define autosave-toc-save-filename
+        (build-path (find-system-path 'pref-dir)
+                    (case (system-type)
+                      [(unix) ".plt-autosave-toc-save"]
+                      [else "PLT-autosave-toc-save"])))
+
+      (define autosave-timer%
+	(class timer%
+	  (inherit start)
+          (field [last-name-mapping #f])
+	  (define/override (notify)
+            (when (preferences:get 'framework:autosaving-on?)
+              (let-values ([(new-objects new-name-mapping) (rebuild-object-list)])
+                (set! objects new-objects)
+                (unless (equal? last-name-mapping new-name-mapping)
+                  (set! last-name-mapping new-name-mapping)
+                  (when (file-exists? autosave-toc-save-filename)
+                    (delete-file autosave-toc-save-filename))
+                  (when (file-exists? autosave-toc-filename)
+                    (copy-file autosave-toc-filename autosave-toc-save-filename))
+                  (call-with-output-file autosave-toc-filename
+                    (λ (port)
+                      (write new-name-mapping port))
+                    'truncate
+                    'text))))
+            (let ([seconds (preferences:get 'framework:autosave-delay)])
+              (start (* 1000 seconds) #t)))
+          (super-new)
+          (let ([seconds (preferences:get 'framework:autosave-delay)])
+            (start (* 1000 seconds) #t))))
+
+      ;; rebuild-object-list : -> (values (listof (weak-box (is-a?/c editor<%>)))
+      ;;                                  (listof (list (union #f string[filename]) string[filename]))
+      (define (rebuild-object-list)
+        (let loop ([orig-objects objects]
+                   [name-mapping null]
+                   [new-objects null])
+          (if (null? orig-objects)
+              (values new-objects name-mapping)
+              (let* ([object-wb (car orig-objects)]
+                     [object (weak-box-value object-wb)])
+                (if object
+                    (let* ([new-filename (send object do-autosave)]
+                           [tmp-box (box #f)]
+                           [filename (send object get-filename tmp-box)])
+                      (loop (cdr orig-objects)
+                            (if new-filename
+                                (cons (list (and (not (unbox tmp-box)) filename)
+                                            new-filename)
+                                      name-mapping)
+                                name-mapping)
+                            (cons object-wb new-objects)))
+                    (loop (cdr orig-objects)
+                          name-mapping
+                          new-objects))))))
+      
+      (define timer #f)
+
+      (define (register b)
+        (unless timer
+          (set! timer (make-object autosave-timer%)))
+        (set! objects
+              (let loop ([objects objects])
+                (cond
+                  [(null? objects) (list (make-weak-box b))]
+                  [else (let ([weak-box (car objects)])
+                          (if (weak-box-value weak-box)
+                              (cons weak-box (loop (cdr objects)))
+                              (loop (cdr objects))))]))))
+      
+      ;; restore-autosave-files/gui : -> (union #f (is-a?/c top-level-window<%>))
+      ;; opens a frame that lists the autosave files that have changed.
+      (define (restore-autosave-files/gui)
+
+        ;; main : -> void
+        ;; start everything going
+        (define (main)
+          (when (file-exists? autosave-toc-filename)
+	    ;; Load table from file, and check that the file was not corrupted
+            (let* ([table (let ([v (with-handlers ([exn:fail? (λ (x) null)])
+				     (call-with-input-file autosave-toc-filename read))]
+				[path? (λ (x)
+					 (and (string? x)
+					      (absolute-path? x)))])
+			    (if (and (list? v)
+				     (andmap (λ (i)
+					       (and (list? i) 
+						    (= 2 (length i))
+						    (or (not (car i))
+							(path? (car i)))
+						    (path? (cadr i))))
+					     v))
+				v
+				null))]
+                   ;; assume that the autosave file was deleted due to the file being saved
+                   [filtered-table
+                    (filter (λ (x) (file-exists? (cadr x))) table)])
+              (unless (null? filtered-table)
+                (let* ([f (new final-frame%
+                               (label (string-constant recover-autosave-files-frame-title)))]
+                       [t (new text% (auto-wrap #t))]
+                       [ec (new editor-canvas%
+                             (parent (send f get-area-container))
+                             (editor t)
+                             (line-count 2)
+                             (style '(no-hscroll)))]
+                       [hp (make-object horizontal-panel% (send f get-area-container))]
+                       [vp (make-object vertical-panel% hp)])
+		  (send vp set-alignment 'right 'center)
+                  (make-object grow-box-spacer-pane% hp)
+                  (send t insert (string-constant autosave-explanation))
+                  (send t hide-caret #t)
+                  (send t set-position 0 0)
+                  (send t lock #t)
+                  
+                  (for-each (add-table-line vp f) filtered-table)
+		  (make-object button%
+		    (string-constant autosave-done)
+		    vp
+		    (λ (x y)
+		      (when (send f can-close?)
+			(send f on-close)
+			(send f show #f))))
+                  (send f show #t)
+                  (yield done-semaphore)
+                  (void))))))
+        
+        (define done-semaphore (make-semaphore 0))
+        
+        (define final-frame%
+          (class frame:basic%
+            (define/augment (can-close?) #t)
+            (define/augment (on-close)
+              (inner (void) on-close)
+              (send (group:get-the-frame-group)
+                    remove-frame
+                    this)
+              (semaphore-post done-semaphore))
+            (super-new)))
+        
+        ;; add-table-line : (is-a? area-container<%>)  (union #f (is-a?/c top-level-window<%>))
+        ;;               -> (list (union #f string[filename]) string[filename-file-exists?])
+        ;;               -> void
+        ;; adds in a line to the overview table showing this pair of files.
+        (define (add-table-line area-container parent)
+          (λ (table-entry)
+            (letrec ([orig-file (car table-entry)]
+		     [backup-file (cadr table-entry)]
+		     [hp (new horizontal-panel%
+			   (parent area-container)
+			   (style '(border))
+			   (stretchable-height #f))]
+		     [vp (new vertical-panel%
+			   (parent hp))]
+		     [msg1-panel (new horizontal-panel%
+				   (parent vp))]
+		     [msg1-label (new message%
+				   (parent msg1-panel)
+				   (label (string-constant autosave-original-label:)))]
+		     [msg1 (new message%
+			     (label (or orig-file (string-constant autosave-unknown-filename)))
+			     (stretchable-width #t)
+			     (parent msg1-panel))]
+		     [msg2-panel (new horizontal-panel%
+				   (parent vp))]
+		     [msg2-label (new message%
+				   (parent msg2-panel)
+				   (label (string-constant autosave-autosave-label:)))]
+		     [msg2 (new message%
+			     (label backup-file)
+			     (stretchable-width #t)
+			     (parent msg2-panel))]
+		     [details
+		      (make-object button% (string-constant autosave-details) hp
+				   (λ (x y)
+				     (show-files table-entry)))]
+		     [delete
+		      (make-object button%
+			(string-constant autosave-delete-button)
+			hp
+			(λ (delete y)
+			  (when (delete-autosave table-entry)
+			    (disable-line)
+			    (send msg2 set-label (string-constant autosave-deleted)))))]
+		     [recover
+		      (make-object button%
+			(string-constant autosave-recover)
+			hp
+			(λ (recover y)
+			  (let ([filename-result (recover-file parent table-entry)])
+			    (when filename-result
+			      (disable-line)
+			      (send msg2 set-label (string-constant autosave-recovered!))
+			      (send msg1 set-label filename-result)))))]
+		     [disable-line
+		      (λ ()
+			(send recover enable #f)
+			(send details enable #f)
+			(send delete enable #f))])
+              (let ([w (max (send msg1-label get-width) (send msg2-label get-width))])
+                (send msg1-label min-width w)
+                (send msg2-label min-width w))
+              (void))))
+        
+	;; delete-autosave : (list (union #f string[filename]) string[filename]) -> boolean
+	;; result indicates if delete occurred
+	(define (delete-autosave table-entry)
+	  (let ([autosave-file (cadr table-entry)])
+	    (and (gui-utils:get-choice
+		  (format (string-constant are-you-sure-delete?)
+			  autosave-file)
+		  (string-constant autosave-delete-title)
+		  (string-constant cancel)
+		  (string-constant warning)
+		  #f)
+		 (with-handlers ([exn:fail?
+				  (λ (exn)
+				    (message-box
+				     (string-constant warning)
+				     (format (string-constant autosave-error-deleting)
+					     autosave-file
+					     (if (exn? exn)
+						 (format "~a" (exn-message exn))
+						 (format "~s" exn))))
+				    #f)])
+		   (delete-file autosave-file)
+		   #t))))
+
+        ;; show-files : (list (union #f string[filename]) string) -> void
+        (define (show-files table-entry)
+          (let ([file1 (car table-entry)]
+                [file2 (cadr table-entry)])
+            (define frame (make-object show-files-frame% 
+                            (if file1
+                                (string-constant autosave-compare-files)
+                                (string-constant autosave-show-autosave))
+                            #f
+                            (if file1 600 300)
+                            600))
+            (define hp (new horizontal-panel%
+                         (parent (send frame get-area-container))))
+            (when file1
+              (add-file-viewer file1 hp (string-constant autosave-original-label)))
+            (add-file-viewer file2 hp (string-constant autosave-autosave-label))
+            (send frame show #t)))
+        
+        ;; add-file-viewer : string[filename] -> void
+        (define (add-file-viewer filename parent label)
+          (define vp (make-object vertical-panel% parent))
+          (define t (make-object show-files-text%))
+          (define msg1 (make-object message% label vp))
+          (define msg2 (make-object message% filename vp))
+          (define ec (make-object editor-canvas% vp t))
+          (send t load-file filename)
+          (send t hide-caret #t)
+          (send t lock #t))
+        
+        (define show-files-frame% frame:basic%)
+        (define show-files-text% text:keymap%)
+        
+        (main))
+        
+      ;; recover-file : (union #f (is-a?/c toplevel-window<%>)) 
+      ;;                (list (union #f string[filename]) string)
+      ;;             -> (union #f string)
+      (define (recover-file parent table-entry)
+        (let ([orig-name (or (car table-entry)
+                             (parameterize ([finder:dialog-parent-parameter parent])
+                               (finder:put-file #f #f #f
+						(string-constant autosave-restore-to-where?))))])
+          (and orig-name
+               (let ([autosave-name (cadr table-entry)])
+                 (let ([tmp-name (and (file-exists? orig-name)
+                                      (make-temporary-file "autosave-repair~a" orig-name))])
+                   (when (file-exists? orig-name)
+                     (delete-file orig-name))
+                   (copy-file autosave-name orig-name)
+                   (delete-file autosave-name)
+                   (when tmp-name
+                     (delete-file tmp-name))
+                   orig-name))))))))
diff --git a/collects/framework/private/bday.ss b/collects/framework/private/bday.ss
new file mode 100644
index 0000000000..bfccac3f2e
--- /dev/null
+++ b/collects/framework/private/bday.ss
@@ -0,0 +1,6 @@
+(module bday mzscheme (require (lib "encode-decode.ss" "framework" "private"))
+  (decode ad91410ec2201045af32cb6141d2aa8bba50cf0265aa44010368e2eda50
+          2516b57a6ac3e2ff9bc9980928eda025ebdbb6b4560fcc0a5128f03981ac2b90492393040458
+          3b604f8812e140151899870a0de5915f83e5ffb9bf764232f98a50328ac02dcc
+          1abc18db3f1046364d0b1374f6f17ba6e72ad9aeb784b9adb6656bdda4ed4fec7fdbf38
+          59dba935b16f63fd822597ddcceeda8d2df604))
diff --git a/collects/framework/private/canvas.ss b/collects/framework/private/canvas.ss
new file mode 100644
index 0000000000..63800e7677
--- /dev/null
+++ b/collects/framework/private/canvas.ss
@@ -0,0 +1,185 @@
+(module canvas mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "class.ss")
+	   "sig.ss"
+	   (lib "mred-sig.ss" "mred"))
+
+  (provide canvas@)
+
+  (define canvas@
+    (unit/sig framework:canvas^
+      (import mred^
+	      [preferences : framework:preferences^]
+	      [frame : framework:frame^]
+              [text : framework:text^])
+      
+      (rename [-color% color%])
+      
+      (define basic<%> (interface ((class->interface editor-canvas%))))
+      (define basic-mixin
+	(mixin ((class->interface editor-canvas%)) (basic<%>)
+          (super-new)))
+      
+      (define color<%> (interface (basic<%>)))
+      
+      (define color-mixin
+        (mixin (basic<%>) (color<%>)
+          (define callback (λ (p v) (set-canvas-background v)))
+          (super-new)
+          (inherit set-canvas-background)
+          (set-canvas-background (preferences:get 'framework:basic-canvas-background))
+          (preferences:add-callback 'framework:basic-canvas-background callback #t)))
+      
+      (define delegate<%> (interface (basic<%>)))
+
+      (define delegate-mixin
+        (mixin (basic<%>) (delegate<%>)
+          (inherit get-top-level-window)
+          (define/override (on-superwindow-show shown?)
+            (send (send (get-top-level-window) get-delegatee) set-start/end-para #f #f)
+            (super on-superwindow-show shown?))
+          (super-instantiate ())))
+      
+      (define info<%> (interface (basic<%>)))
+      ;; (basic<%> -> (class (is-a? (send this get-top-level-window) frame:info<%>)))
+      (define info-mixin 
+	(mixin (basic<%>) (info<%>)
+	  (inherit has-focus? get-top-level-window)
+	  (define/override (on-focus on?)
+            (super on-focus on?)
+            (send (get-top-level-window) set-info-canvas (and on? this))
+            (when on?
+              (send (get-top-level-window) update-info)))
+          (define/override (set-editor m)
+            (super set-editor m)
+            (let ([tlw (get-top-level-window)])
+              (when (eq? this (send tlw get-info-canvas))
+                (send tlw update-info))))
+          
+          (super-new)
+
+          (unless (is-a? (get-top-level-window) frame:info<%>)
+            (error 'canvas:text-info-mixin
+                   "expected to be placed into a frame or dialog implementing frame:info<%>, got: ~e" 
+                   (get-top-level-window)))
+
+          (when (has-focus?)
+            (send (get-top-level-window) update-info))))
+
+      (define wide-snip<%> (interface (basic<%>)
+			     recalc-snips
+			     add-wide-snip
+			     add-tall-snip))
+
+      (define wide-snip-mixin
+	(mixin (basic<%>) (wide-snip<%>)
+	  (inherit get-editor)
+          (define/private ((update-snip-size width?) s)
+            (let* ([width (box 0)]
+                   [height (box 0)]
+                   [leftm (box 0)]
+                   [rightm (box 0)]
+                   [topm (box 0)]
+                   [bottomm (box 0)]
+                   [left-edge-box (box 0)]
+                   [top-edge-box (box 0)]
+                   [snip-media (send s get-editor)]
+                   [edit (get-editor)]        
+                   [get-width
+                    (let ([bl (box 0)]
+                          [br (box 0)])
+                      (λ (s)
+                        (send edit get-snip-location s bl #f #f)
+                        (send edit get-snip-location s br #f #t)
+                        (- (unbox br) (unbox bl))))]
+                   [calc-after-width
+                    (λ (s)
+                      (+ 4 ;; this is compensate for an autowrapping bug
+                         (let loop ([s s])
+                           (cond
+                             [(not s) 0]
+                             [(member 'hard-newline (send s get-flags)) (get-width s)]
+                             [(member 'newline (send s get-flags)) (get-width s)]
+                             [else
+                              (+ (get-width s)
+                                 2 ;; for the caret
+                                 (loop (send s next)))]))))])
+              (when edit
+                (send edit
+                      run-after-edit-sequence
+                      (λ ()
+                        (let ([admin (send edit get-admin)])
+                          (send admin get-view #f #f width height)
+                          (send s get-margin leftm topm rightm bottomm)
+                          
+                          
+                          ;; when the width is to be maximized and there is a
+                          ;; newline just behind the snip, we know that the left
+                          ;; edge is zero. Special case for efficiency in the 
+                          ;; console printer
+                          (let ([fallback
+                                 (λ ()
+                                   (send edit get-snip-location s left-edge-box top-edge-box))])
+                            (cond
+                              [(not width?) (fallback)]
+                              [(let ([prev (send s previous)])
+                                 (and prev
+                                      (member 'hard-newline (send prev get-flags))))
+                               (set-box! left-edge-box 0)]
+                              [else (fallback)]))
+                          
+                          (if width?
+                              (let* ([after-width (calc-after-width (send s next))]
+                                     [snip-width (max 0 (- (unbox width)
+                                                           (unbox left-edge-box)
+                                                           (unbox leftm)
+                                                           (unbox rightm)
+                                                           after-width
+                                                           ;; this two is the space that 
+                                                           ;; the caret needs at the right of
+                                                           ;; a buffer.
+                                                           2))])
+                                (send* s 
+                                  (set-min-width snip-width)
+                                  (set-max-width snip-width))
+                                (when snip-media
+                                  (send snip-media set-max-width
+                                        (if (send snip-media auto-wrap)
+                                            snip-width
+                                            0))))
+                              (let ([snip-height (max 0 (- (unbox height)
+                                                           (unbox top-edge-box)
+                                                           (unbox topm)
+                                                           (unbox bottomm)))])
+                                (send* s 
+                                  (set-min-height snip-height)
+                                  (set-max-height snip-height))))))))))
+	  (define/public (recalc-snips)
+            (let ([editor (get-editor)])
+              (unless (is-a? editor text:wide-snip<%>)
+                (error 'recalc-snips "expected a text:wide-snip<%> editor, instead ~e" editor))
+              (when (eq? (send editor get-canvas) this)
+                (for-each (update-snip-size #t) (send editor get-wide-snips))
+                (for-each (update-snip-size #f) (send editor get-tall-snips)))))
+	  (define/public (add-wide-snip snip)
+            (let ([editor (get-editor)])
+              (unless (is-a? editor text:wide-snip<%>)
+                (error 'add-wide-snip "expected to have a text:wide-snip<%> editor, instead ~e" editor))
+              (send editor add-wide-snip snip))
+            ((update-snip-size #t) snip))
+          (define/public (add-tall-snip snip)
+            (let ([editor (get-editor)])
+              (unless (is-a? editor text:wide-snip<%>)
+                (error 'add-wide-snip "expected to have a text:wide-snip<%> editor, instead ~e" editor))
+              (send editor add-tall-snip snip))
+            ((update-snip-size #f) snip))
+	  (define/override (on-size width height)
+            (recalc-snips)
+            (super on-size width height))
+          (super-new)))
+
+      (define basic% (basic-mixin editor-canvas%))
+      (define -color% (color-mixin basic%))
+      (define info% (info-mixin basic%))
+      (define delegate% (delegate-mixin basic%))
+      (define wide-snip% (wide-snip-mixin basic%)))))
diff --git a/collects/framework/private/collapsed-snipclass-helpers.ss b/collects/framework/private/collapsed-snipclass-helpers.ss
new file mode 100644
index 0000000000..75e6d1842c
--- /dev/null
+++ b/collects/framework/private/collapsed-snipclass-helpers.ss
@@ -0,0 +1,27 @@
+(module collapsed-snipclass-helpers mzscheme
+  (require (lib "mred.ss" "mred")
+           (lib "class.ss"))
+  
+  (provide make-sexp-snipclass%)
+  
+  (define (make-sexp-snipclass% sexp-snip%)
+    (class snip-class%
+      (define/override (read in)
+        (let* ([left-bracket (integer->char (bytes-ref (send in get-bytes) 0))]
+               [right-bracket (integer->char (bytes-ref (send in get-bytes) 0))]
+               [snip-count (send in get-exact)]
+               [saved-snips
+                (let loop ([n snip-count])
+                  (cond
+                    [(zero? n) null]
+                    [else
+                     (let* ([classname (bytes->string/utf-8 (send in get-bytes))]
+                            [snipclass (send (get-the-snip-class-list) find classname)])
+                       (cons (send snipclass read in)
+                             (loop (- n 1))))]))])
+          (instantiate sexp-snip% ()
+            (left-bracket left-bracket)
+            (right-bracket right-bracket)
+            (saved-snips saved-snips))))
+      (super-instantiate ()))))
+  
\ No newline at end of file
diff --git a/collects/framework/private/color-model.ss b/collects/framework/private/color-model.ss
new file mode 100644
index 0000000000..df0d4ddd12
--- /dev/null
+++ b/collects/framework/private/color-model.ss
@@ -0,0 +1,273 @@
+(module color-model mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "class.ss")
+	   "sig.ss"
+	   (lib "mred-sig.ss" "mred")
+	   (lib "list.ss"))
+
+  (provide color-model@)
+
+  (define color-model@
+    (unit/sig framework:color-model^
+      (import)
+
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;;                                 ;;;
+  ;;;           matrix ops            ;;;
+  ;;;                                 ;;;
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      
+      ;; matrix inversion using cramer's rule
+
+      ;; submatrix : (list-of (list-of num)) int int -> (list-of (list-of num))
+      ;; submatrix "crosses out" row i and column j from the matrix, returning a new one
+      
+      (define (submatrix source i j)
+	(let row-loop ([row 0])
+	  (cond 
+	   [(eq? row (length source)) null]
+	   [(eq? row i) (row-loop (+ row 1))]
+	   [else
+	    (cons 
+	     (let col-loop ([col 0])
+	       (cond 
+		[(eq? col (length (car source))) null]
+		[(eq? col j) (col-loop (+ col 1))]
+		[else
+		 (cons (list-ref (list-ref source row) col)
+		       (col-loop (+ col 1)))]))
+	     (row-loop (+ row 1)))])))
+      
+      ;;(equal? (submatrix test-matrix 1 2)
+      ;;        '((1 2 6) (7 8 4)))
+      
+      ;; det : (list-of (list-of num)) -> num
+      
+      (define (det matrix)
+	(if (null? matrix)
+	    1
+	    (let loop ([row 0] [sign 1])
+	      (if (= row (length matrix))
+		  0
+		  (+ (* sign
+			(list-ref (list-ref matrix row) 0)
+			(det (submatrix matrix row 0)))
+		     (loop (+ row 1) (- sign)))))))
+      
+      ;;(define square-test-matrix '((3 20 3) (37 0 8) (2 1 4)))
+      
+      ;;(= (det square-test-matrix) -2553)
+      
+      ;; invert : (list-of (list-of num)) -> (list-of (list-of num))
+      
+      (define (matrix-invert matrix)
+	(let-values ([(width height) (matrix-dimension matrix)])
+	  (when (not (= width height))
+	    (error 'invert "matrix is not square: ~s" matrix))
+	  (let ([delta-inv (/ 1 (det matrix))])
+	    (let row-loop ([row 0] [sign 1])
+	      (if (= row (length matrix))
+		  null
+		  (cons 
+		   (let col-loop ([col 0] [sign sign])
+		     (if (= col (length (car matrix)))
+			 null
+			 (cons (* delta-inv
+				  sign
+				  (det (submatrix matrix col row)))
+			       (col-loop (+ col 1) (- sign)))))
+		   (row-loop (+ row 1) (- sign))))))))
+      
+      ;;(equal? (matrix-invert square-test-matrix)
+      ;;        '((8/2553 77/2553 -160/2553) (44/851 -2/851 -29/851) (-1/69 -1/69 20/69)))
+      
+      ;; matrix-dimension : (list-of (list-of num)) -> (values num num)  
+      ;; takes a matrix, returns width and height
+      
+      (define (matrix-dimension matrix)
+	(when (not (pair? matrix))
+	  (error 'matrix-dimension "matrix argument is not a list: ~s" matrix))
+	(let ([height (length matrix)])
+	  (when (= height 0)
+	    (error 'matrix-dimension "matrix argument is empty: ~s" matrix))
+	  (when (not (pair? (car matrix)))
+	    (error 'matrix-dimension "matrix row is not a list: ~s" (car matrix)))
+	  (let ([width (length (car matrix))])
+	    (when (= width 0)
+	      (error 'matrix-dimension "matrix argument has width 0: ~s" matrix))
+	    (let loop ([rows matrix])
+	      (if (null? rows)
+		  (values width height)
+		  (begin
+		    (when (not (pair? (car rows)))
+		      (error 'matrix-dimension "row is not a list: ~s" (car rows)))
+		    (when (not (= width (length (car rows))))
+		      (error 'matrix-dimension "rows have different widths: ~s and ~s" width (length (car rows))))
+		    (loop (cdr rows))))))))
+      
+      ;; transpose : (list-of (list-of num)) -> (list-of (list-of num))
+      (define (transpose vector) (apply map list vector))
+      
+      
+      ;; test code
+      ;;(equal? (transpose '((3 2 1) (9 8 7))) '((3 9) (2 8) (1 7)))
+      
+      ;; inner-product : (list-of num) (list-of num) -> num
+      (define (inner-product a b)
+	(foldl + 0 (map * a b)))
+      
+      ;; test code
+      ;; (= (inner-product '(4 1 3) '(0 3 4)) 15)
+      
+      ;; matrix-multiply: (list-of (list-of num)) (list-of (list-of num)) -> (list-of (list-of num))
+      ;; multiplies the two matrices.
+      (define (matrix-multiply a b)
+	(let-values ([(width-a height-a) (matrix-dimension a)]
+		     [(width-b height-b) (matrix-dimension b)])
+	  (when (not (= width-a height-b))
+	    (error 'matrix-multiply "matrix dimensions do not match for multiplication"))
+	  (let ([b-t (transpose b)])
+	    (map (λ (row)
+		   (map (λ (col)
+			  (inner-product row col))
+			b-t))
+		 a))))
+
+      ;; test code
+      ;; (equal? (matrix-multiply '((1 2 3 4) (9 8 3 2)) '((0) (2) (0) (3)))
+      ;;         '((16) (22)))
+      
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;;                                 ;;;
+  ;;;           color model           ;;;
+  ;;;                                 ;;;
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+      ;; ITU reccommendation phosphors:
+      
+      ;;    red green blue
+      ;;x   0.64 0.29 0.15
+      ;;y   0.33 0.60 0.06
+      ;;
+      ;; white point: 
+      ;; c : x-w = 0.313, y-w = 0.329, big-y-w = 100.0
+      
+      (define x-r 0.64)
+      (define y-r 0.33)
+      (define x-g 0.29)
+      (define y-g 0.60)
+      (define x-b 0.15)
+      (define y-b 0.06)
+      
+      (define z-r (- 1 x-r y-r))
+      (define z-g (- 1 x-g y-g))
+      (define z-b (- 1 x-b y-b))
+      
+      (define x-w 0.313)
+      (define y-w 0.329)
+      (define big-y-w 100.0)
+      
+      (define-struct xyz (x y z))
+      
+      (define (xy-big-y->xyz x y big-y)
+	(let ([sigma (/ big-y y)])
+	  (make-xyz
+	   (* x sigma)
+	   (* y sigma)
+	   (* (- 1 x y) sigma))))
+      
+      (define xyz-white (xy-big-y->xyz x-w y-w big-y-w))
+      
+      ;;`((,(xyz-x xyz-white) ,x-r ,x-g ,x-b)
+      ;;  (,(xyz-y xyz-white) ,y-r ,y-g ,y-b)
+      ;;  (,(xyz-z xyz-white) ,z-r ,z-g ,z-b))
+      
+      ;; sigmas were calculated by soving a set of linear equations based upon ntsc standard phosphors
+
+      (define pre-matrix `((,x-r ,x-g ,x-b)
+			   (,y-r ,y-g ,y-b)
+			   (,z-r ,z-g ,z-b)))
+      
+      (define-values (sigma-r sigma-g sigma-b)
+	(let* ([inversion 
+		(matrix-invert pre-matrix)]
+	       [sigmas
+		(matrix-multiply inversion `((,(xyz-x xyz-white))
+					     (,(xyz-y xyz-white))
+					     (,(xyz-z xyz-white))))])
+	  (apply values (car (transpose sigmas)))))
+      
+      ;; (printf "should be equal to xyz-white: ~n~a~n"
+      ;;    (matrix-multiply pre-matrix `((,sigma-r) (,sigma-g) (,sigma-b))))
+      
+      (define rgb->xyz-matrix
+	(map (λ (row)
+	       (map (λ (row-elt scalar) (* row-elt scalar 1/255)) row `(,sigma-r ,sigma-g ,sigma-b)))
+	     pre-matrix))
+      
+      (define xyz->rgb-matrix
+	(matrix-invert rgb->xyz-matrix))
+      
+      ;;(printf "should be identity: ~n~a~n" (matrix-multiply rgb->xyz-matrix xyz->rgb-matrix))
+      
+      (define (rgb->xyz r g b)
+	(apply make-xyz (car (transpose (matrix-multiply rgb->xyz-matrix (transpose `((,r ,g ,b))))))))
+      
+      ;;(print-struct #t)
+      ;; (printf "should be xyz-white: ~n~a~n" (rgb->xyz 255 255 255))
+      
+      (define (xyz->rgb x y z)
+	(car (transpose (matrix-multiply xyz->rgb-matrix (transpose `((,x ,y ,z)))))))
+
+      ;;l* = 116(y/big-y-n)^1/3 - 16, y/big-y-n > 0.01
+      ;;u* = 13 l*(u-p - u-p-n)
+      ;;v* = 13 l*(v-p - v-p-n)
+      ;;
+      ;;u-p = (4x)/(x+15y+3z)   v-p = (9y)/(x+15y+3z)
+      ;;u-p-n = (same but with -n) v-p-n = (same but with -n)
+      
+      ;; the following transformation is undefined if the y component
+      ;; is zero.  So if it is, we bump it up a little.
+      
+      (define (xyz-tweak xyz)
+	(let* ([y (xyz-y xyz)])
+	  (make-xyz (xyz-x xyz) (if (< y 0.01) 0.01 y) (xyz-z xyz))))
+      
+      (define-struct luv (l u v))
+      
+      (define (xyz-denom xyz)
+	(+ (xyz-x xyz) (* 15 (xyz-y xyz)) (* 3 (xyz-z xyz))))
+      
+      (define (xyz-u-p xyz)
+	(/ (* 4 (xyz-x xyz)) (xyz-denom xyz)))
+      
+      (define (xyz-v-p xyz)
+	(/ (* 9 (xyz-y xyz)) (xyz-denom xyz)))
+      
+      (define (xyz->luv xyz)
+	(let ([xyz (xyz-tweak xyz)])
+	  (let* ([l (- (* 116 (expt (/ (xyz-y xyz) (xyz-y xyz-white))
+				    1/3))
+		       16)]
+		 [u-p (xyz-u-p xyz)]
+		 [u-p-white (xyz-u-p xyz-white)]
+		 [v-p (xyz-v-p xyz)]
+		 [v-p-white (xyz-v-p xyz-white)])
+	    (make-luv l (* 13 l (- u-p u-p-white)) (* 13 l (- v-p v-p-white))))))
+      
+      (define (luv-distance a b)
+	(expt (+ (expt (- (luv-l a) (luv-l b)) 2)
+		 (expt (- (luv-u a) (luv-u b)) 2)
+		 (expt (- (luv-v a) (luv-v b)) 2))
+	      1/2))
+      
+      (define (rgb-color-distance r-a g-a b-a r-b g-b b-b)
+	(let* ([luv-a (xyz->luv (rgb->xyz r-a g-a b-a))]
+	       [luv-b (xyz->luv (rgb->xyz r-b g-b b-b))])
+	  (luv-distance luv-a luv-b)))
+      
+      ;;(rgb-color-distance 0 0 0 0 0 0)
+      ;; (print-struct #t)
+      ;; (xyz->luv (make-xyz 95.0 100.0 141.0))
+      ;; (xyz->luv (make-xyz 60.0 80.0 20.0))
+      )))
\ No newline at end of file
diff --git a/collects/framework/private/color-prefs.ss b/collects/framework/private/color-prefs.ss
new file mode 100644
index 0000000000..82525d2c3b
--- /dev/null
+++ b/collects/framework/private/color-prefs.ss
@@ -0,0 +1,303 @@
+
+(module color-prefs mzscheme
+  (require (lib "class.ss")
+           (lib "unitsig.ss")
+           (lib "etc.ss")
+           (lib "mred.ss" "mred")
+           (lib "string-constant.ss" "string-constants")
+           "sig.ss")
+ 
+  (provide color-prefs@)
+  
+  (define sc-choose-color (string-constant syntax-coloring-choose-color))
+  
+  (define color-prefs@
+    (unit/sig framework:color-prefs^
+      (import [preferences : framework:preferences^]
+              [editor : framework:editor^]
+              [panel : framework:panel^]
+              [canvas : framework:canvas^])
+      
+      (define standard-style-list-text% (editor:standard-style-list-mixin text%))
+      
+      ;; build-color-selection-panel : (is-a?/c area-container<%>) symbol string string -> void
+      ;; constructs a panel containg controls to configure the preferences panel.
+      ;; BUG: style changes don't update the check boxes.
+      (define build-color-selection-panel
+        (opt-lambda (parent 
+                     pref-sym
+                     style-name
+                     example-text
+                     [update-style-delta
+                      (λ (func)
+                        (let ([delta (preferences:get pref-sym)])
+                          (func delta)
+                          (preferences:set pref-sym delta)))])
+          (define hp (new horizontal-panel% 
+                          (parent parent)
+                          (style '(border))
+                          (stretchable-height #f)))
+          (define e (new (class standard-style-list-text%
+                           (inherit change-style get-style-list)
+                           (define/augment (after-insert pos offset)
+                             (inner (void) after-insert pos offset)
+                             (let ([style (send (get-style-list)
+                                                find-named-style
+                                                style-name)])
+                               (change-style style pos (+ pos offset) #f)))
+                           (super-new))))
+          (define c (new canvas:color%
+                         (parent hp)
+                         (editor e)
+                         (style '(hide-hscroll
+                                  hide-vscroll))))
+          
+          (define (make-check name on off)
+            (let* ([c (λ (check command)
+                        (if (send check get-value)
+                            (update-style-delta on)
+                            (update-style-delta off)))]
+                   [check (make-object check-box% name hp c)])
+              check))
+          
+          (define slant-check
+            (make-check (string-constant cs-italic)
+                        (λ (delta)
+                          (send delta set-style-on 'slant)
+                          (send delta set-style-off 'base))
+                        (λ (delta)
+                          (send delta set-style-on 'base)
+                          (send delta set-style-off 'slant))))
+          (define bold-check
+            (make-check (string-constant cs-bold)
+                        (λ (delta)
+                          (send delta set-weight-on 'bold)
+                          (send delta set-weight-off 'base))
+                        (λ (delta)
+                          (send delta set-weight-on 'base)
+                          (send delta set-weight-off 'bold))))
+          (define underline-check
+            (make-check (string-constant cs-underline)
+                        (λ (delta)
+                          (send delta set-underlined-on #t)
+                          (send delta set-underlined-off #f))
+                        (λ (delta)
+                          (send delta set-underlined-off #t)
+                          (send delta set-underlined-on #f))))
+          (define color-button
+            (and (>= (get-display-depth) 8)
+                 (make-object button%
+                   (string-constant cs-change-color)
+                   hp
+                   (λ (color-button evt)
+                     (let* ([add (send (preferences:get pref-sym) get-foreground-add)]
+                            [color (make-object color%
+                                     (send add get-r)
+                                     (send add get-g)
+                                     (send add get-b))]
+                            [users-choice
+                             (get-color-from-user
+                              (format sc-choose-color example-text)
+                              (send color-button get-top-level-window)
+                              color)])
+                       (when users-choice
+                         (update-style-delta
+                          (λ (delta)
+                            (send delta set-delta-foreground users-choice)))))))))
+          (define style (send (send e get-style-list) find-named-style style-name))
+          
+          (send c set-line-count 1)
+          (send c allow-tab-exit #t)
+          
+          (send e insert example-text)
+          (send e set-position 0)
+          
+          (send slant-check set-value (eq? (send style get-style) 'slant))
+          (send bold-check set-value (eq? (send style get-weight) 'bold))
+          (send underline-check set-value (send style get-underlined))))
+      
+      (define (add/mult-set m v)
+        (send m set (car v) (cadr v) (caddr v)))
+      
+      (define (add/mult-get m)
+        (let ([b1 (box 0)]
+              [b2 (box 0)]
+              [b3 (box 0)])
+          (send m get b1 b2 b3)
+          (map unbox (list b1 b2 b3))))
+      
+      (define style-delta-get/set
+        (list (cons (λ (x) (send x get-alignment-off))
+                    (λ (x v) (send x set-alignment-off v)))
+              (cons (λ (x) (send x get-alignment-on))
+                    (λ (x v) (send x set-alignment-on v)))
+              (cons (λ (x) (add/mult-get (send x get-background-add)))
+                    (λ (x v) (add/mult-set (send x get-background-add) v)))
+              (cons (λ (x) (add/mult-get (send x get-background-mult)))
+                    (λ (x v) (add/mult-set (send x get-background-mult) v)))
+              (cons (λ (x) (send x get-face))
+                    (λ (x v) (send x set-face v)))
+              (cons (λ (x) (send x get-family))
+                    (λ (x v) (send x set-family v)))
+              (cons (λ (x) (add/mult-get (send x get-foreground-add)))
+                    (λ (x v) (add/mult-set (send x get-foreground-add) v)))
+              (cons (λ (x) (add/mult-get (send x get-foreground-mult)))
+                    (λ (x v) (add/mult-set (send x get-foreground-mult) v)))
+              (cons (λ (x) (send x get-size-add))
+                    (λ (x v) (send x set-size-add v)))
+              (cons (λ (x) (send x get-size-mult))
+                    (λ (x v) (send x set-size-mult v)))
+              (cons (λ (x) (send x get-style-off))
+                    (λ (x v) (send x set-style-off v)))
+              (cons (λ (x) (send x get-style-on))
+                    (λ (x v) (send x set-style-on v)))
+              (cons (λ (x) (send x get-underlined-off))
+                    (λ (x v) (send x set-underlined-off v)))
+              (cons (λ (x) (send x get-underlined-on))
+                    (λ (x v) (send x set-underlined-on v)))
+              (cons (λ (x) (send x get-weight-off))
+                    (λ (x v) (send x set-weight-off v)))
+              (cons (λ (x) (send x get-weight-on))
+                    (λ (x v) (send x set-weight-on v)))))
+      
+      (define (marshall-style style)
+        (map (λ (fs) ((car fs) style)) style-delta-get/set))
+      
+      (define (unmarshall-style info)
+        (let ([style (make-object style-delta%)])
+          (for-each (λ (fs v) ((cdr fs) style v)) style-delta-get/set info)
+          style))
+      
+      (define (make-style-delta color bold? underline? italic?)
+        (let ((sd (make-object style-delta%)))
+          (send sd set-delta-foreground color)
+          (cond
+            (bold?
+             (send sd set-weight-on 'bold)
+             (send sd set-weight-off 'base))
+            (else
+             (send sd set-weight-on 'base)
+             (send sd set-weight-off 'bold)))
+          (send sd set-underlined-on underline?)
+          (send sd set-underlined-off (not underline?))
+          (cond
+            (italic?
+             (send sd set-style-on 'italic)
+             (send sd set-style-off 'base))
+            (else
+             (send sd set-style-on 'base)
+             (send sd set-style-off 'italic)))
+          sd))
+      
+      (define (add-background-preferences-panel)
+        (preferences:add-panel
+         (list (string-constant preferences-colors)
+               (string-constant background-color))
+         (λ (parent)
+           (let ([vp (new vertical-panel% (parent parent))])
+             (add-solid-color-config (string-constant background-color)
+                                     vp
+                                     'framework:basic-canvas-background)
+             (add-solid-color-config (string-constant paren-match-color)
+                                     vp
+                                     'framework:paren-match-color)
+             (build-text-foreground-selection-panel vp
+                                                    'framework:default-text-color
+                                                    (editor:get-default-color-style-name)
+                                                    (string-constant default-text-color))))))
+      
+      (define (build-text-foreground-selection-panel parent pref-sym style-name example-text)
+        (define hp (new horizontal-panel% 
+                        (parent parent)
+                        (style '(border))
+                        (stretchable-height #f)))
+        (define e (new (class standard-style-list-text%
+                         (inherit change-style get-style-list)
+                         (define/augment (after-insert pos offset)
+                           (inner (void) after-insert pos offset)
+                           (let ([style (send (get-style-list)
+                                              find-named-style
+                                              style-name)])
+                             (change-style style pos (+ pos offset) #f)))
+                         (super-new))))
+        (define c (new canvas:color%
+                       (parent hp)
+                       (editor e)
+                       (style '(hide-hscroll
+                                hide-vscroll))))
+        (define color-button
+          (and (>= (get-display-depth) 8)
+               (make-object button%
+                 (string-constant cs-change-color)
+                 hp
+                 (λ (color-button evt)
+                   (let ([users-choice
+                          (get-color-from-user
+                           (format sc-choose-color example-text)
+                           (send color-button get-top-level-window)
+                           (preferences:get pref-sym))])
+                     (when users-choice
+                       (preferences:set pref-sym users-choice)))))))
+        (define style (send (send e get-style-list) find-named-style style-name))
+        
+        (send c set-line-count 1)
+        (send c allow-tab-exit #t)
+        
+        (send e insert example-text)
+        (send e set-position 0))
+      
+      (define (add-solid-color-config label parent pref-id)
+        (letrec ([panel (new vertical-panel% (parent parent) (stretchable-height #f))]
+                 [hp (new horizontal-panel% (parent panel) (stretchable-height #f))]
+                 [msg (new message% (parent hp) (label label))]
+                 [canvas
+                  (new canvas%
+                       (parent hp)
+                       (paint-callback
+                        (λ (c dc)
+                          (draw (preferences:get pref-id)))))]
+                 [draw
+                  (λ (clr)
+                    (let ([dc (send canvas get-dc)])
+                      (let-values ([(w h) (send canvas get-client-size)])
+                        (send dc set-brush (send the-brush-list find-or-create-brush clr 'solid))
+                        (send dc set-pen (send the-pen-list find-or-create-pen clr 1 'solid))
+                        (send dc draw-rectangle 0 0 w h))))]
+                 [button
+                  (new button% 
+                       (label (string-constant cs-change-color))
+                       (parent hp)
+                       (callback
+                        (λ (x y)
+                          (let ([color (get-color-from-user
+                                        (string-constant choose-a-background-color)
+                                        (send hp get-top-level-window)
+                                        (preferences:get pref-id))])
+                            (when color
+                              (preferences:set pref-id color))))))])
+          (preferences:add-callback
+           pref-id
+           (λ (p v) (draw v)))
+          panel))
+      
+      ;; add-to-preferences-panel : string (vertical-panel -> void) -> void
+      (define (add-to-preferences-panel panel-name func)
+        (preferences:add-panel
+         (list (string-constant preferences-colors) panel-name)
+         (λ (parent)
+           (let ([panel (new vertical-panel% (parent parent))])
+             (func panel)
+             panel))))
+      
+      ;; see docs
+      (define (register-color-pref pref-name style-name color)
+        (let ([sd (new style-delta%)])
+          (send sd set-delta-foreground color)
+          (preferences:set-default pref-name sd (λ (x) (is-a? x style-delta%))))
+        (preferences:set-un/marshall pref-name marshall-style unmarshall-style)
+        (preferences:add-callback pref-name
+                                  (λ (sym v)
+                                    (editor:set-standard-style-list-delta style-name v)))
+        (editor:set-standard-style-list-delta style-name (preferences:get pref-name))))))
+
+
diff --git a/collects/framework/private/color.ss b/collects/framework/private/color.ss
new file mode 100644
index 0000000000..cc0df1b960
--- /dev/null
+++ b/collects/framework/private/color.ss
@@ -0,0 +1,728 @@
+(module color mzscheme
+  (require (lib "class.ss")
+           (lib "etc.ss")
+           (lib "unitsig.ss")
+	   (lib "thread.ss")
+           (lib "mred.ss" "mred")
+           (lib "token-tree.ss" "syntax-color")
+           (lib "paren-tree.ss" "syntax-color")
+           (lib "default-lexer.ss" "syntax-color")
+           "sig.ss")
+           
+  
+  (provide color@)
+    
+  (define (should-color-type? type)
+    (not (memq type '(white-space no-color))))
+  
+  (define color@
+    (unit/sig framework:color^
+      (import [preferences : framework:preferences^]
+              [icon : framework:icon^]
+              [mode : framework:mode^]
+              [text : framework:text^]
+              [color-prefs : framework:color-prefs^]
+              [scheme : framework:scheme^])
+        
+      (rename [-text<%> text<%>]
+              [-text% text%]
+              [-text-mode<%> text-mode<%>])
+      
+      (define -text<%>
+        (interface (text:basic<%>)
+          start-colorer
+          stop-colorer
+          force-stop-colorer
+          
+          is-frozen?
+          freeze-colorer
+          thaw-colorer
+
+          reset-region
+          update-region-end
+          
+          skip-whitespace
+          backward-match
+          backward-containing-sexp
+          forward-match
+          insert-close-paren
+	  classify-position))
+
+      (define text-mixin
+        (mixin (text:basic<%>) (-text<%>)
+
+          ;; For profiling
+          (define timer #f)
+          
+          ;; ---------------------- Coloring modes ----------------------------
+          
+          ;; The tokenizer is stopped.  This is used by the surrogate to enter
+          ;; a mode with no coloring or paren matching.
+          (define stopped? #t)
+
+          ;; The tokenizer is stopped and prevented from starting.  This is 
+          ;; an internal call for debugging.
+          (define force-stop? #f)
+
+          ;; color-callback has been suspended because the text% became locked
+          ;; and should be requeued when the text% is unlocked.
+          (define restart-callback #f)
+
+          ;; Some other tool wants to take over coloring the buffer, so the 
+          ;; colorer shouldn't color anything.
+          (define frozen? #f)
+          ;; true iff the colorer must recolor from scratch when the freeze
+          ;; is over.
+          (define force-recolor-after-freeze #f)
+          
+          ;; ---------------------- Lexing state ------------------------------
+          
+          ;; The tree of valid tokens, starting at start-pos
+          (define tokens (new token-tree%))
+          
+          ;; If the tree is completed
+          (define up-to-date? #t)
+          (define/public (get-up-to-date?) up-to-date?)
+          
+          ;; The tree of tokens that have been invalidated by an edit
+          ;; but might still be valid.
+          (define invalid-tokens (new token-tree%))
+          
+          ;; The position right before the invalid-tokens tree
+          (define invalid-tokens-start +inf.0)
+          
+          ;; The position right before the next token to be read
+          (define current-pos start-pos)
+          
+          ;; The lexer
+          (define get-token #f)
+                              
+          ;; ---------------------- Parenethesis matching ----------------------
+          
+          ;; The pairs of matching parens
+          (define pairs '())
+          (define parens (new paren-tree% (matches pairs)))
+          
+          
+          ;; ---------------------- Interactions state ------------------------
+          ;; The positions right before and right after the area to be tokenized
+          (define start-pos 0)
+          (define end-pos 'end)
+          
+          (inherit last-position)
+          
+          ;; See docs
+          (define/public (reset-region start end)
+            (unless (and (= start start-pos) (eqv? end end-pos))
+              (unless (<= 0 start (last-position))
+                (raise-mismatch-error 'reset-region
+                                      "start position not inside editor: "
+                                      start))
+              (unless (or (eq? 'end end) (<= 0 end (last-position)))
+                (raise-mismatch-error 'reset-region
+                                      "end position not inside editor: "
+                                      end))
+              (unless (or (eq? 'end end) (<= start end))
+                (raise-mismatch-error 'reset-region
+                                      "end position before start position: "
+                                      (list end start)))
+              (set! start-pos start)
+              (set! end-pos end)
+              (reset-tokens)
+              (do-insert/delete start 0)))
+
+          (define/public (get-region) (values start-pos end-pos))
+          
+          ;; Modify the end of the region.
+          (define/public (update-region-end end)
+            (set! end-pos end))
+          
+          ;; ---------------------- Preferences -------------------------------
+          (define should-color? #t)
+          (define token-sym->style #f)
+                    
+          ;; ---------------------- Multi-threading ---------------------------
+          ;; A list of thunks that color the buffer
+          (define colors null)
+          ;; The coroutine object for tokenizing the buffer
+          (define tok-cor #f)
+          ;; The editor revision when tok-cor was created
+          (define rev #f)
+          
+          
+          (inherit change-style begin-edit-sequence end-edit-sequence highlight-range
+                   get-style-list in-edit-sequence? get-start-position get-end-position
+                   local-edit-sequence? get-styles-fixed has-focus?
+                   get-fixed-style)
+
+          (define/private (reset-tokens)
+            (send tokens reset-tree)
+            (send invalid-tokens reset-tree)
+            (set! invalid-tokens-start +inf.0)
+            (set! up-to-date? #t)
+            (set! restart-callback #f)
+            (set! force-recolor-after-freeze #f)
+            (set! parens (new paren-tree% (matches pairs)))
+            (set! current-pos start-pos)
+            (set! colors null)
+            (when tok-cor
+              (coroutine-kill tok-cor))
+            (set! tok-cor #f)
+            (set! rev #f))
+          
+          ;; Actually color the buffer.
+          (define/private (color)
+            (unless (null? colors)
+              ((car colors))
+              (set! colors (cdr colors))
+              (color)))
+          
+          ;; Discard extra tokens at the first of invalid-tokens
+          (define/private (sync-invalid)
+            (when (and (not (send invalid-tokens is-empty?))
+                       (< invalid-tokens-start current-pos))
+              (send invalid-tokens search-min!)
+              (let ((length (send invalid-tokens get-root-length)))
+                (send invalid-tokens remove-root!)
+                (set! invalid-tokens-start (+ invalid-tokens-start length)))
+              (sync-invalid)))
+          
+          (define/private (re-tokenize in in-start-pos enable-suspend)
+            (let-values ([(lexeme type data new-token-start new-token-end) 
+                          (get-token in)])
+	      (unless (eq? 'eof type)
+                (enable-suspend #f)
+                #;(printf "~a at ~a to ~a~n" lexeme (+ in-start-pos (sub1 new-token-start))
+                        (+ in-start-pos (sub1 new-token-end)))
+		(let ((len (- new-token-end new-token-start)))
+		  (set! current-pos (+ len current-pos))
+		  (sync-invalid)
+		  (when (and should-color? (should-color-type? type) (not frozen?))
+		    (set! colors
+			  (cons
+			   (let* ([style-name (token-sym->style type)]
+                                  (color (send (get-style-list) find-named-style style-name))
+                                  (sp (+ in-start-pos (sub1 new-token-start)))
+                                  (ep (+ in-start-pos (sub1 new-token-end))))
+			     (λ ()
+                               (change-style color sp ep #f)))
+			   colors)))
+                  ; Using the non-spec version takes 3 times as long as the spec
+                  ; version.  In other words, the new greatly outweighs the tree
+                  ; operations.
+		  ;(insert-last! tokens (new token-tree% (length len) (data type)))
+                  (insert-last-spec! tokens len type)
+		  (send parens add-token data len)
+		  (cond
+		   ((and (not (send invalid-tokens is-empty?))
+			 (= invalid-tokens-start current-pos))
+		    (send invalid-tokens search-max!)
+		    (send parens merge-tree
+			  (send invalid-tokens get-root-end-position))
+		    (insert-last! tokens invalid-tokens)
+		    (set! invalid-tokens-start +inf.0)
+                    (enable-suspend #t))
+		   (else
+		    (enable-suspend #t)
+		    (re-tokenize in in-start-pos enable-suspend)))))))
+          
+          (define/private (do-insert/delete edit-start-pos change-length)
+            (unless (or stopped? force-stop?)
+              (unless up-to-date?
+                (sync-invalid))
+              (cond
+                (up-to-date?
+                 (let-values 
+                     (((orig-token-start orig-token-end valid-tree invalid-tree)
+                       (send tokens split (- edit-start-pos start-pos))))
+                   (send parens split-tree orig-token-start)
+                   (set! invalid-tokens invalid-tree)
+                   (set! tokens valid-tree)
+                   (set! invalid-tokens-start
+                         (if (send invalid-tokens is-empty?)
+                             +inf.0
+                             (+ start-pos orig-token-end change-length)))
+                   (set! current-pos (+ start-pos orig-token-start))
+                   (set! up-to-date? #f)
+                   (queue-callback (λ () (colorer-callback)) #f)))
+                ((>= edit-start-pos invalid-tokens-start)
+                 (let-values (((tok-start tok-end valid-tree invalid-tree)
+                               (send invalid-tokens split (- edit-start-pos start-pos))))
+                   (set! invalid-tokens invalid-tree)
+                   (set! invalid-tokens-start
+                         (+ invalid-tokens-start tok-end change-length))))
+                ((> edit-start-pos current-pos)
+                 (set! invalid-tokens-start (+ change-length invalid-tokens-start)))
+                (else
+                 (let-values (((tok-start tok-end valid-tree invalid-tree)
+                               (send tokens split (- edit-start-pos start-pos))))
+                   (send parens truncate tok-start)
+                   (set! tokens valid-tree)
+                   (set! invalid-tokens-start (+ change-length invalid-tokens-start))
+                   (set! current-pos (+ start-pos tok-start)))))))
+
+          (inherit is-locked? get-revision-number)
+          
+          (define/private (colorer-driver)
+            (unless up-to-date?
+              #;(printf "revision ~a~n" (get-revision-number))
+              (unless (and tok-cor (= rev (get-revision-number)))
+                (when tok-cor
+                  (coroutine-kill tok-cor))
+                #;(printf "new coroutine~n")
+                (set! tok-cor
+                      (coroutine
+                       (λ (enable-suspend)
+                         (parameterize ((port-count-lines-enabled #t))
+                           (re-tokenize (open-input-text-editor this current-pos end-pos 
+                                                                (λ (x) #f))
+                                        current-pos
+                                        enable-suspend)))))
+                (set! rev (get-revision-number)))
+              (with-handlers ((exn:fail?
+                               (λ (exn)
+                                 (parameterize ((print-struct #t))
+                                   ((error-display-handler) 
+                                    (format "exception in colorer thread: ~s" exn)
+                                    exn))
+                                 (set! tok-cor #f))))
+                #;(printf "begin lexing~n")
+                (when (coroutine-run 10 tok-cor)
+                  (set! up-to-date? #t)))
+              #;(printf "end lexing~n")
+              #;(printf "begin coloring~n")
+              ;; This edit sequence needs to happen even when colors is null
+              ;; for the paren highlighter.
+              (begin-edit-sequence #f #f)
+              (color)
+              (end-edit-sequence)
+              #;(printf "end coloring~n")))
+          
+          (define/private (colorer-callback)
+            (cond
+              ((is-locked?)
+               (set! restart-callback #t))
+              (else
+               (unless (in-edit-sequence?)
+                 (colorer-driver))
+               (unless up-to-date?
+                 (queue-callback (λ () (colorer-callback)) #f)))))
+                    
+          ;; Must not be called when the editor is locked
+          (define/private (finish-now)
+            (unless stopped?
+              (let loop ()
+                (unless up-to-date?
+                  (colorer-driver)
+                  (loop)))))
+
+          ;; See docs
+          (define/public (start-colorer token-sym->style- get-token- pairs-)
+            (unless force-stop?
+              (set! stopped? #f)
+              (reset-tokens)
+              (set! should-color? (preferences:get 'framework:coloring-active))
+              (set! token-sym->style token-sym->style-)
+              (set! get-token get-token-)
+              (set! pairs pairs-)
+              (set! parens (new paren-tree% (matches pairs)))
+	      ;; (set! timer (current-milliseconds))
+              (do-insert/delete start-pos 0)))
+            
+          ;; See docs
+          (define/public stop-colorer
+            (opt-lambda ((clear-colors #t))
+              (set! stopped? #t)
+              (when (and clear-colors (not frozen?))
+                (begin-edit-sequence #f #f)
+                (change-style (get-fixed-style) start-pos end-pos #f)
+                (end-edit-sequence))
+              (match-parens #t)
+              (reset-tokens)
+              (set! pairs null)
+              (set! token-sym->style #f)
+              (set! get-token #f)))
+          
+          (define/public (is-frozen?) frozen?)
+          
+          ;; See docs
+          (define/public (freeze-colorer)
+            (when (is-locked?)
+              (error 'freeze-colorer "called on a locked color:text<%>."))
+            (unless frozen?
+              (finish-now)
+              (set! frozen? #t)))
+          
+          ;; See docs
+          (define/public thaw-colorer
+            (opt-lambda ((recolor? #t)
+                         (retokenize? #f))
+              (when frozen?
+                (set! frozen? #f)
+                (cond
+                  (stopped?
+                   (stop-colorer))
+                  ((or force-recolor-after-freeze recolor?)
+                   (cond
+                     (retokenize?
+                      (let ((tn token-sym->style)
+                            (gt get-token)
+                            (p pairs))
+                        (stop-colorer (not should-color?))
+                        (start-colorer tn gt p)))
+                     (else
+                      (begin-edit-sequence #f #f)
+                      (finish-now)
+                      (send tokens for-each
+                            (λ (start len type)
+                              (when (and should-color? (should-color-type? type))
+                                (let ((color (send (get-style-list) find-named-style
+                                                   (token-sym->style type)))
+                                      (sp (+ start-pos start))
+                                      (ep (+ start-pos (+ start len))))
+                                  (change-style color sp ep #f)))))
+                      (end-edit-sequence))))))))
+                                
+                      
+          (define/private (toggle-color on?)
+            (cond
+              ((and frozen? (not (equal? on? should-color?)))
+               (set! should-color? on?)
+               (set! force-recolor-after-freeze #t))
+              ((and (not should-color?) on?)
+               (set! should-color? on?)
+               (reset-tokens)
+               (do-insert/delete start-pos 0))
+              ((and should-color? (not on?))
+               (set! should-color? on?)
+               (begin-edit-sequence #f #f)
+               (change-style (get-fixed-style) start-pos end-pos #f)
+               (end-edit-sequence))))
+
+          ;; see docs
+          (define/public (force-stop-colorer stop?)
+            (set! force-stop? stop?)
+            (when stop?
+              (stop-colorer)))
+          
+          
+          ;; ----------------------- Match parentheses ----------------------------
+          
+          (define clear-old-locations void)
+          
+          (define mismatch-color (make-object color% "PINK"))
+          (define/private (get-match-color) (preferences:get 'framework:paren-match-color))
+          
+          (define/private (highlight start end caret-pos error?)
+            (let ([off (highlight-range (+ start-pos start) (+ start-pos end)
+                                        (if error? mismatch-color (get-match-color))
+                                        (and (send (icon:get-paren-highlight-bitmap)
+                                                   ok?)
+                                             (icon:get-paren-highlight-bitmap))
+                                        (= caret-pos (+ start-pos start)))])
+              (set! clear-old-locations
+                    (let ([old clear-old-locations])
+                      (λ ()
+                        (old)
+                        (off))))))
+          
+          (define in-match-parens? #f)
+          
+          ;; the forward matcher signaled an error because not enough of the
+          ;; tree has been built.
+          (define/private (f-match-false-error start end error)
+            (and error (<= (+ start-pos error) current-pos) (not up-to-date?)))
+          
+            
+          ;; If there is no match because the buffer isn't lexed far enough yet,
+          ;; this will do nothing, but the edit sequence for changing the colors 
+          ;; will trigger a callback that will call this to try and match again.
+          ;; This edit sequence is used even if the coloring is disabled in
+          ;; the preferences, although nothing is actually colored during it.
+          ;; This leads to the nice behavior that we don't have to block to
+          ;; highlight parens, and the parens will be highlighted as soon as
+          ;; possible.
+          (define/private match-parens
+            (opt-lambda ([just-clear? #f])
+              ;;(printf "(match-parens ~a)~n" just-clear?)
+              (when (and (not in-match-parens?)
+                         ;; Trying to match open parens while the
+                         ;; background thread is going slows it down.
+                         ;; The random number slows down how often it
+                         ;; tries.
+                         (or just-clear? up-to-date? (= 0 (random 5))))
+                (set! in-match-parens? #t)
+                (begin-edit-sequence #f #f)
+                (clear-old-locations)
+                (set! clear-old-locations void)
+                (when (and (preferences:get 'framework:highlight-parens)
+                           (not just-clear?))
+                  (let* ((here (get-start-position)))
+                    (when (= here (get-end-position))
+                      (let-values (((start-f end-f error-f)
+                                    (send parens match-forward (- here start-pos))))
+                        (when (and (not (f-match-false-error start-f end-f error-f))
+                                   start-f end-f)
+                          (highlight start-f end-f here error-f)))
+                      (let-values  (((start-b end-b error-b)
+                                     (send parens match-backward (- here start-pos))))
+                        (when (and start-b end-b)
+                          (highlight start-b end-b here error-b))))))
+                (end-edit-sequence)
+                (set! in-match-parens? #f))))
+                    
+          ;; See docs
+          (define/public (forward-match position cutoff)
+            (do-forward-match position cutoff #t))
+          
+          (define/private (do-forward-match position cutoff skip-whitespace?)
+            (let ((position 
+                   (if skip-whitespace? 
+                       (skip-whitespace position 'forward #t)
+                       position)))
+              (let-values (((start end error)
+                            (send parens match-forward (- position start-pos))))
+                (cond
+                  ((f-match-false-error start end error)
+                   (colorer-driver)
+                   (do-forward-match position cutoff #f))
+                  ((and start end (not error))
+                   (let ((match-pos (+ start-pos end)))
+                     (cond
+                       ((<= match-pos cutoff) match-pos)
+                       (else #f))))
+                  ((and start end error) #f)
+                  (else
+                   (let-values (((tok-start tok-end)
+                                 (begin
+                                   (tokenize-to-pos position)
+                                   (send tokens search! (- position start-pos))
+                                   (values (send tokens get-root-start-position)
+                                           (send tokens get-root-end-position)))))
+                     (cond
+                       ((or (send parens is-close-pos? tok-start)
+                            (= (+ start-pos tok-end) position))
+                        #f)
+                       (else
+                        (+ start-pos tok-end)))))))))
+          
+                    
+          ;; See docs
+          (define/public (backward-match position cutoff)
+            (let ((x (internal-backward-match position cutoff)))
+              (cond
+                ((eq? x 'open) #f)
+                (else x))))
+          
+          (define/private (internal-backward-match position cutoff)
+            (when stopped?
+              (error 'backward-match "called on a color:text<%> whose colorer is stopped."))
+            (let ((position (skip-whitespace position 'backward #t)))
+              (let-values (((start end error)
+                            (send parens match-backward (- position start-pos))))
+                (cond
+                  ((and start end (not error))
+                   (let ((match-pos (+ start-pos start)))
+                     (cond
+                       ((>= match-pos cutoff) match-pos)
+                       (else #f))))
+                  ((and start end error) #f)
+                  (else
+                   (let-values (((tok-start tok-end)
+                                 (begin
+                                   (send tokens search!
+                                         (if (> position start-pos)
+                                             (- position start-pos 1)
+                                             0))
+                                   (values (send tokens get-root-start-position)
+                                           (send tokens get-root-end-position)))))
+                     (cond
+                       ((or (send parens is-open-pos? tok-start)
+                            (= (+ start-pos tok-start) position))
+                        'open)
+                       (else
+                        (+ start-pos tok-start)))))))))
+
+          ;; See docs
+          (define/public (backward-containing-sexp position cutoff)
+            (when stopped?
+              (error 'backward-containing-sexp "called on a color:text<%> whose colorer is stopped."))
+            (let loop ((cur-pos position))
+              (let ((p (internal-backward-match cur-pos cutoff)))
+                (cond
+                  ((eq? 'open p) cur-pos)
+                  ((not p) #f)
+                  (else (loop p))))))
+
+	  ;; Determines whether a position is a 'comment, 'string, etc.
+	  (define/public (classify-position position)
+            (when stopped?
+              (error 'classify-position "called on a color:text<%> whose colorer is stopped."))
+	    (tokenize-to-pos position)
+	    (send tokens search! (- position start-pos))
+	    (send tokens get-root-data))
+            
+          (define/private (tokenize-to-pos position)
+            (when (and (not up-to-date?) (<= current-pos position))
+              (colorer-driver)
+              (tokenize-to-pos position)))
+                    
+          ;; See docs
+          (define/public (skip-whitespace position direction comments?)
+            (when stopped?
+              (error 'skip-whitespace "called on a color:text<%> whose colorer is stopped."))
+            (cond
+              ((and (eq? direction 'forward)
+                    (>= position (if (eq? 'end end-pos) (last-position) end-pos)))
+               position)
+              ((and (eq? direction 'backward) (<= position start-pos))
+               position)
+              (else
+               (tokenize-to-pos position)
+               (send tokens search! (- (if (eq? direction 'backward) (sub1 position) position)
+                                       start-pos))
+                 (cond
+                   ((or (eq? 'white-space (send tokens get-root-data))
+                        (and comments? (eq? 'comment (send tokens get-root-data))))
+                    (skip-whitespace (+ start-pos
+                                        (if (eq? direction 'forward)
+                                            (send tokens get-root-end-position)
+                                            (send tokens get-root-start-position)))
+                                     direction
+                                     comments?))
+                   (else position)))))
+          
+          (define/private (get-close-paren pos closers)
+            (cond
+              ((null? closers) #f)
+              (else
+               (let* ((c (car closers))
+                      (l (string-length c)))
+                 (insert c pos)
+                 (let ((m (backward-match (+ l pos) start-pos)))
+                   (cond
+                     ((and m
+                           (send parens is-open-pos? (- m start-pos))
+                           (send parens is-close-pos? (- pos start-pos)))
+                      (delete pos (+ l pos))
+                      c)
+                     (else
+                      (delete pos (+ l pos))
+                      (get-close-paren pos (cdr closers)))))))))
+          
+          (inherit insert delete flash-on on-default-char)
+          ;; See docs
+          (define/public (insert-close-paren pos char flash? fixup?)
+            (let ((closer
+                   (begin
+                     (begin-edit-sequence #f #f)
+                     (get-close-paren pos (if fixup? (map symbol->string (map cadr pairs)) null)))))
+              (end-edit-sequence)
+              (let ((insert-str (if closer closer (string char))))
+                (for-each (lambda (c)
+                            (on-default-char (new key-event% (key-code c))))
+                          (string->list insert-str))
+                (when flash?
+                  (unless stopped?
+                    (let ((to-pos (backward-match (+ (string-length insert-str) pos) 0)))
+                      (when (and to-pos
+                                 (send parens is-open-pos? (- to-pos start-pos))
+                                 (send parens is-close-pos? (- pos start-pos)))
+                        (flash-on to-pos (+ 1 to-pos)))))))))
+          
+          (define/public (debug-printout)
+            (let* ((x null)
+                   (f (λ (a b c) (set! x (cons (list a b c) x)))))
+              (send tokens for-each f)
+              (printf "tokens: ~e~n" (reverse x))
+              (set! x null)
+              (send invalid-tokens for-each f)
+              (printf "invalid-tokens: ~e~n" (reverse x))
+              (printf "start-pos: ~a current-pos: ~a invalid-tokens-start ~a~n"
+                      start-pos current-pos invalid-tokens-start)
+              (printf "parens: ~e~n" (car (send parens test)))))
+          
+          ;; ------------------------- Callbacks to Override ----------------------
+          
+          (define/override (lock x)
+            ;;(printf "(lock ~a)~n" x)
+            (super lock x)
+            (when (and restart-callback (not x))
+              (set! restart-callback #f)
+              (queue-callback (λ () (colorer-callback)))))
+          
+          
+          (define/override (on-focus on?)
+            ;;(printf "(on-focus ~a)~n" on?)
+            (super on-focus on?)
+            (match-parens (not on?)))
+                    
+          (define/augment (after-edit-sequence)
+            ;;(printf "(after-edit-sequence)~n")
+            (when (has-focus?)
+              (match-parens))
+            (inner (void) after-edit-sequence))
+          
+          (define/augment (after-set-position)
+            ;;(printf "(after-set-position)~n")
+            (unless (local-edit-sequence?)
+              (when (has-focus?)
+                (match-parens)))
+            (inner (void) after-set-position))
+          
+          (define/augment (after-change-style a b)
+            ;;(printf "(after-change-style)~n")
+            (unless (get-styles-fixed)
+              (unless (local-edit-sequence?)
+                (when (has-focus?)
+                  (match-parens))))
+            (inner (void) after-change-style a b))
+          
+          (define/augment (on-set-size-constraint)
+            ;;(printf "(on-set-size-constraint)~n")
+            (unless (local-edit-sequence?)
+              (when (has-focus?)
+                (match-parens)))
+            (inner (void) on-set-size-constraint))
+          
+          (define/augment (after-insert edit-start-pos change-length)
+            ;;(printf "(after-insert ~a ~a)~n" edit-start-pos change-length)
+            (do-insert/delete edit-start-pos change-length)
+            (inner (void) after-insert edit-start-pos change-length))
+          
+          (define/augment (after-delete edit-start-pos change-length)
+            ;;(printf "(after-delete ~a ~a)~n" edit-start-pos change-length)
+            (do-insert/delete edit-start-pos (- change-length))
+            (inner (void) after-delete edit-start-pos change-length))
+                    
+          (super-new)
+          
+          ;; need pref-callback to be in a private field
+          ;; so that the editor hangs on to the callback
+          ;; when the editor goes away, so does the callback
+          (define (pref-callback k v) (toggle-color v))
+          (preferences:add-callback 'framework:coloring-active pref-callback #t)))
+      
+      (define -text% (text-mixin text:keymap%))
+              
+      (define -text-mode<%> (interface ()))
+      
+      (define text-mode-mixin
+        (mixin (mode:surrogate-text<%>) (-text-mode<%>)
+          ;; The arguments here are only used to be passed to start-colorer.  Refer to its
+          ;; documentation.
+          (init-field (get-token default-lexer) 
+                      (token-sym->style (λ (x) "Standard"))
+                      (matches null))
+          
+          (define/override (on-disable-surrogate text)
+            (super on-disable-surrogate text)
+            (send text stop-colorer))
+          
+          (define/override (on-enable-surrogate text)
+            (super on-enable-surrogate text)
+            (send text start-colorer token-sym->style get-token matches))
+          
+          (super-new)))
+  
+      (define text-mode% (text-mode-mixin mode:surrogate-text%)))))
diff --git a/collects/framework/private/comment-box.ss b/collects/framework/private/comment-box.ss
new file mode 100644
index 0000000000..47fbeadebf
--- /dev/null
+++ b/collects/framework/private/comment-box.ss
@@ -0,0 +1,130 @@
+
+(module comment-box mzscheme
+  (require (lib "class.ss")
+           (lib "etc.ss")
+	   (lib "mred.ss" "mred")
+           (lib "unitsig.ss")
+           "sig.ss"
+           "../decorated-editor-snip.ss"
+           (lib "include-bitmap.ss" "mrlib")
+           (lib "string-constant.ss" "string-constants"))
+  
+  (provide comment-box@)
+  
+  (define comment-box@
+    (unit/sig framework:comment-box^
+      (import [text : framework:text^]
+              [scheme : framework:scheme^]
+              [keymap : framework:keymap^])
+      
+      (rename [-snip% snip%]
+	      [-text% text%])
+
+      (define snipclass%
+        (class decorated-editor-snipclass%
+          (define/override (make-snip stream-in) (instantiate -snip% ()))
+          (super-instantiate ())))
+      
+      (define snipclass (make-object snipclass%))
+      (send snipclass set-version 1)
+      (send snipclass set-classname (format "~s" '(lib "comment-snip.ss" "framework")))
+      (send (get-the-snip-class-list) add snipclass)
+      
+      (define bm (include-bitmap (lib "semicolon.gif" "icons")))
+      
+      (define (editor-keymap-mixin %)
+        (class %
+          (define/override (get-keymaps)
+            (cons (keymap:get-file) (super get-keymaps)))
+          (super-instantiate ())))
+      
+      (define scheme+copy-self% #f)
+      (define (get-scheme+copy-self%)
+        (unless scheme+copy-self%
+          (set! scheme+copy-self%
+                (class scheme:text%
+                  (inherit copy-self-to)
+                  (define/override (copy-self)
+                    (let ([ed (new scheme+copy-self%)])
+                      (copy-self-to ed)
+                      ed))
+                  (super-new))))
+        scheme+copy-self%)
+      
+      (define -snip%
+        (class* decorated-editor-snip% (readable-snip<%>)
+          (inherit get-editor get-style)
+          
+          (define/override (make-editor) (new (get-scheme+copy-self%)))
+          (define/override (make-snip) (make-object -snip%))
+          (define/override (get-corner-bitmap) bm)
+          (define/override (get-position) 'left-top)
+          
+          (define/override get-text
+	    (opt-lambda (offset num [flattened? #t])
+	      (let* ([super-res (super get-text offset num flattened?)]
+		     [replaced (string-append "; " (regexp-replace* "\n" super-res "\n; "))])
+		(if (char=? #\newline (string-ref replaced (- (string-length replaced) 1)))
+		    replaced
+		    (string-append replaced "\n")))))
+                              
+          
+          (define/override (get-menu)
+            (let ([menu (make-object popup-menu%)])
+              (make-object menu-item% 
+                (string-constant convert-to-semicolon-comment)
+                menu
+                (λ (x y)
+                  (let ([to-ed (find-containing-editor)])
+                    (when to-ed
+                      (let ([this-pos (find-this-position)])
+                        (when this-pos
+                          (let ([from-ed (get-editor)])
+                            (send to-ed begin-edit-sequence)
+                            (send from-ed begin-edit-sequence)
+                            (copy-contents-with-semicolons-to-position to-ed from-ed (+ this-pos 1))
+                            (send to-ed delete this-pos (+ this-pos 1))
+                            (send to-ed end-edit-sequence)
+                            (send from-ed end-edit-sequence))))))))
+              menu))
+          
+          (inherit get-admin)
+          ;; find-containing-editor : -> (union #f editor)
+          (define/private (find-containing-editor)
+            (let ([admin (get-admin)])
+              (and admin
+                   (send admin get-editor))))
+          
+          ;; find-this-position : -> (union #f number)
+          (define/private (find-this-position)
+            (let ([ed (find-containing-editor)])
+              (and ed
+                   (send ed get-snip-position this))))
+          
+          ;; copy-contents-with-semicolons-to-position : (is-a? text%) number -> void
+          (define/private (copy-contents-with-semicolons-to-position to-ed from-ed pos)
+            (let loop ([snip (find-last-snip from-ed)])
+              (cond
+                [snip 
+                 (when (or (memq 'hard-newline (send snip get-flags))
+                           (memq 'newline (send snip get-flags)))
+                   (send to-ed insert "; " pos))
+                 (send to-ed insert (send snip copy) pos)
+                 (loop (send snip previous))]
+                [else 
+                 (send to-ed insert "; " pos)])))
+          
+          ;; find-last-snip : editor -> snip
+          ;; returns the last snip in the editor
+          (define/private (find-last-snip ed)
+            (let loop ([snip (send ed find-first-snip)]
+                       [acc (send ed find-first-snip)])
+              (cond
+                [snip (loop (send snip next) snip)]
+                [else acc])))
+          
+          (define/public (read-special source line column position)
+            (raise (make-special-comment "comment")))
+          (super-instantiate ())
+          (inherit set-snipclass)
+          (set-snipclass snipclass))))))
\ No newline at end of file
diff --git a/collects/framework/private/editor.ss b/collects/framework/private/editor.ss
new file mode 100644
index 0000000000..281d1966d0
--- /dev/null
+++ b/collects/framework/private/editor.ss
@@ -0,0 +1,603 @@
+
+(module editor mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "class.ss")
+           (lib "string-constant.ss" "string-constants")
+	   "sig.ss"
+	   "../gui-utils.ss"
+           (lib "etc.ss")
+	   (lib "mred-sig.ss" "mred")
+	   (lib "file.ss"))
+
+  (provide editor@)
+
+  (define editor@
+    (unit/sig framework:editor^
+      (import mred^
+	      [autosave : framework:autosave^]
+	      [finder : framework:finder^]
+	      [path-utils : framework:path-utils^]
+	      [keymap : framework:keymap^]
+	      [icon : framework:icon^]
+	      [preferences : framework:preferences^]
+	      [text : framework:text^]
+	      [pasteboard : framework:pasteboard^]
+	      [frame : framework:frame^]
+              [handler : framework:handler^])
+
+      (rename [-keymap<%> keymap<%>])
+
+      ;; renaming, for editor-mixin where get-file is shadowed by a method.
+      (define mred:get-file get-file) 
+
+      (define basic<%>
+	(interface (editor<%>)
+	  has-focus?
+	  local-edit-sequence?
+	  run-after-edit-sequence
+	  get-top-level-window
+	  save-file-out-of-date?
+          save-file/gui-error
+          load-file/gui-error
+          on-close
+          can-close?
+          close
+          get-filename/untitled-name))
+
+      (define basic-mixin
+	(mixin (editor<%>) (basic<%>)
+	  
+          (define/pubment (can-close?) (inner #t can-close?))
+          (define/pubment (on-close) (inner (void) on-close))
+          (define/public (close) (if (can-close?)
+                                     (begin (on-close) #t)
+                                     #f))
+          
+          ;; get-filename/untitled-name : -> string
+          ;; returns a string representing the visible name for this file,
+          ;; or "Untitled <n>" for some n.
+          (define untitled-name #f)
+          (define/public (get-filename/untitled-name)
+            (let ([filename (get-filename)])
+              (if filename
+                  (path->string filename)
+                  (begin
+                    (unless untitled-name
+                      (set! untitled-name (gui-utils:next-untitled-name)))
+                    untitled-name))))
+          
+	  (inherit get-filename save-file)
+	  (define/public save-file/gui-error
+	    (opt-lambda ([input-filename #f]
+			 [fmt 'same]
+			 [show-errors? #t])
+              (let ([filename (if (or (not input-filename)
+				      (equal? input-filename ""))
+				  (let ([internal-filename (get-filename)])
+				    (if (or (not internal-filename)
+					    (equal? internal-filename ""))
+					(put-file #f #f)
+					internal-filename))
+				  input-filename)])
+                (with-handlers ([exn:fail?
+                                 (λ (exn)
+                                   (message-box
+                                    (string-constant error-saving)
+                                    (string-append
+                                     (format (string-constant error-saving-file/name) 
+                                             filename)
+                                     "\n\n"
+				     (format-error-message exn))
+                                    #f
+                                    '(stop ok))
+                                   #f)])
+                  (when filename
+                    (save-file filename fmt #f))
+                  #t))))
+          
+          (inherit load-file)
+          (define/public load-file/gui-error
+            (opt-lambda ([input-filename #f]
+                         [fmt 'guess]
+                         [show-errors? #t])
+	      (let ([filename (if (or (not input-filename)
+                                      (equal? input-filename ""))
+                                  (let ([internal-filename (get-filename)])
+                                    (if (or (not internal-filename)
+                                            (equal? internal-filename ""))
+                                        (get-file #f)
+                                        internal-filename))
+                                  input-filename)])
+                (with-handlers ([exn:fail?
+                                 (λ (exn)
+                                   (message-box 
+                                    (string-constant error-loading)
+				    (string-append
+				     (format (string-constant error-loading-file/name)
+					     filename)
+				     "\n\n"
+				     (format-error-message exn))
+                                    #f
+                                    '(stop ok))
+                                   #f)])
+                  (load-file input-filename fmt show-errors?)
+                  #t))))
+	  
+	  (define/private (format-error-message exn)
+	    (let ([sp (open-output-string)])
+	      (parameterize ([current-output-port sp])
+		((error-display-handler)
+		 (if (exn? exn)
+		     (format "~a" (exn-message exn))
+		     (format "uncaught exn: ~s" exn))
+		 exn))
+	      (get-output-string sp)))
+
+	  (inherit refresh-delayed? 
+		   get-canvas
+		   get-max-width get-admin)
+	  
+	  (define/augment (can-save-file? filename format)
+            (and (if (equal? filename (get-filename))
+                     (if (save-file-out-of-date?)
+                         (gui-utils:get-choice 
+                          (string-constant file-has-been-modified)
+                          (string-constant overwrite-file-button-label)
+                          (string-constant cancel)
+                          (string-constant warning)
+                          #f
+                          (get-top-level-window))
+                         #t)
+                     #t)
+                 (inner #t can-save-file? filename format)))
+	  
+	  (define last-saved-file-time #f)
+	  
+	  (define/augment (after-save-file success?)
+            ;; update recently opened file names
+            (let* ([temp-b (box #f)]
+                   [filename (get-filename temp-b)])
+              (unless (unbox temp-b)
+                (when filename
+                  (handler:add-to-recent filename))))
+            
+            ;; update last-saved-file-time
+            (when success?
+              (let ([filename (get-filename)])
+                (set! last-saved-file-time
+                      (and filename
+                           (file-exists? filename)
+                           (file-or-directory-modify-seconds filename)))))
+            
+            (inner (void) after-save-file success?))
+	  
+	  (define/augment (after-load-file success?)
+            (when success?
+              (let ([filename (get-filename)])
+                (set! last-saved-file-time
+                      (and filename
+                           (file-exists? filename)
+                           (file-or-directory-modify-seconds filename)))))
+            (inner (void) after-load-file success?))
+	  (define/public (save-file-out-of-date?)
+            (and last-saved-file-time
+                 (let ([fn (get-filename)])
+                   (and fn
+                        (file-exists? fn)
+                        (let ([ms (file-or-directory-modify-seconds fn)])
+                          (< last-saved-file-time ms))))))
+	  
+	  (define has-focus #f)
+	  (define/override (on-focus x)
+            (set! has-focus x)
+            (super on-focus x))
+	  (define/public (has-focus?) has-focus)
+	  
+	  (define/public (get-top-level-window)
+            (let loop ([text this])
+              (let ([editor-admin (send text get-admin)])
+                (cond
+                  [(is-a? editor-admin editor-snip-editor-admin<%>)
+                   (let* ([snip (send editor-admin get-snip)]
+                          [snip-admin (send snip get-admin)])
+                     (loop (send snip-admin get-editor)))]
+                  [(send text get-canvas) 
+                   => 
+                   (λ (canvas)
+                     (send canvas get-top-level-window))]
+                  [else #f]))))
+	  
+	  [define edit-sequence-queue null]
+	  [define edit-sequence-ht (make-hash-table)]
+	  [define in-local-edit-sequence? #f]
+	  [define/public local-edit-sequence? (λ () in-local-edit-sequence?)]
+	  [define/public run-after-edit-sequence
+	    (case-lambda 
+	     [(t) (run-after-edit-sequence t #f)]
+	     [(t sym)
+	      (unless (and (procedure? t)
+			   (= 0 (procedure-arity t)))
+		(error 'editor:basic::run-after-edit-sequence
+		       "expected procedure of arity zero, got: ~s~n" t))
+	      (unless (or (symbol? sym) (not sym))
+		(error 'editor:basic::run-after-edit-sequence
+		       "expected second argument to be a symbol or #f, got: ~s~n"
+		       sym))
+	      (if (refresh-delayed?)
+		  (if in-local-edit-sequence?
+		      (cond
+			[(symbol? sym)
+			 (hash-table-put! edit-sequence-ht sym t)]
+			[else (set! edit-sequence-queue
+				    (cons t edit-sequence-queue))])
+		      (let ([snip-admin (get-admin)])
+			(cond
+			  [(not snip-admin)
+			   (t)] ;; refresh-delayed? is always #t when there is no admin.
+			  [(is-a? snip-admin editor-snip-editor-admin<%>)
+			   (send (send (send (send snip-admin get-snip) get-admin) get-editor)
+				 run-after-edit-sequence t sym)]
+			  [else
+			   '(message-box "run-after-edit-sequence error"
+                                         (format "refresh-delayed? is #t but snip admin, ~s, is not an editor-snip-editor-admin<%>"
+                                                 snip-admin))
+			   '(t)
+                           (void)])))
+		  (t))
+	      (void)])]
+	  [define/public extend-edit-sequence-queue
+	    (λ (l ht)
+	      (hash-table-for-each ht (λ (k t)
+					(hash-table-put! 
+					 edit-sequence-ht
+					 k t)))
+	      (set! edit-sequence-queue (append l edit-sequence-queue)))]
+	  (define/augment (on-edit-sequence)
+            (set! in-local-edit-sequence? #t)
+            (inner (void) on-edit-sequence))
+	  (define/augment (after-edit-sequence)
+            (set! in-local-edit-sequence? #f)
+            (let ([queue edit-sequence-queue]
+                  [ht edit-sequence-ht]
+                  [find-enclosing-editor
+                   (λ (editor)
+                     (let ([admin (send editor get-admin)])
+                       (cond
+                         [(is-a? admin editor-snip-editor-admin<%>)
+                          (send (send (send admin get-snip) get-admin) get-editor)]
+                         [else #f])))])
+              (set! edit-sequence-queue null)
+              (set! edit-sequence-ht (make-hash-table))
+              (let loop ([editor (find-enclosing-editor this)])
+                (cond
+                  [(and editor 
+                        (is-a? editor basic<%>)
+                        (not (send editor local-edit-sequence?)))
+                   (loop (find-enclosing-editor editor))]
+                  [(and editor
+                        (is-a? editor basic<%>))
+                   (send editor extend-edit-sequence-queue queue ht)]
+                  [else
+                   (hash-table-for-each ht (λ (k t) (t)))
+                   (for-each (λ (t) (t)) queue)])))
+            (inner (void) after-edit-sequence))
+	  
+	  [define/override on-new-box
+	    (λ (type)
+	      (cond
+		[(eq? type 'text) (make-object editor-snip% (make-object text:basic%))]
+		[else (make-object editor-snip% (make-object pasteboard:basic%))]))]
+	  
+	  
+	  (define/override (get-file d)
+            (parameterize ([finder:dialog-parent-parameter
+                            (get-top-level-window)])
+              (finder:get-file d)))
+	  (define/override (put-file d f)
+            (parameterize ([finder:dialog-parent-parameter
+                            (get-top-level-window)])
+              (finder:put-file f d)))
+	  
+	  
+	  (super-instantiate ())))
+
+      (define standard-style-list (new style-list%))
+      (define (get-standard-style-list) standard-style-list)
+      
+      (define default-color-style-name "framework:default-color")
+      (define (get-default-color-style-name) default-color-style-name)
+      
+      (let ([delta (make-object style-delta% 'change-normal)])
+        (send delta set-delta 'change-family 'modern)
+        (let ([style (send standard-style-list find-named-style "Standard")])
+          (if style
+              (send style set-delta delta)
+              (send standard-style-list new-named-style "Standard"
+                    (send standard-style-list find-or-create-style
+                          (send standard-style-list find-named-style "Basic")
+                          delta)))))
+        
+      (let ([delta (make-object style-delta%)]
+	    [style (send standard-style-list find-named-style default-color-style-name)])
+	(if style
+	    (send style set-delta delta)
+	    (send standard-style-list new-named-style default-color-style-name
+		  (send standard-style-list find-or-create-style
+			(send standard-style-list find-named-style "Standard")
+			delta))))
+      
+      (define (set-default-font-color color)
+        (let* ([scheme-standard (send standard-style-list find-named-style default-color-style-name)]
+               [scheme-delta (make-object style-delta%)])
+          (send scheme-standard get-delta scheme-delta)
+          (send scheme-delta set-delta-foreground color)
+          (send scheme-standard set-delta scheme-delta)))
+      
+      (define (set-font-size size)
+        (update-standard-style
+         (λ (scheme-delta)
+           (send scheme-delta set-size-mult 0)
+           (send scheme-delta set-size-add size))))
+      
+      (define (set-font-name name)
+        (update-standard-style
+         (λ (scheme-delta)
+           (send scheme-delta set-delta-face name)
+           (send scheme-delta set-family 'modern))))
+      
+      (define (set-font-smoothing sym)
+        (update-standard-style
+         (λ (scheme-delta)
+           (send scheme-delta set-smoothing-on sym))))
+      
+      (define (update-standard-style cng-delta)
+        (let* ([scheme-standard (send standard-style-list find-named-style "Standard")]
+               [scheme-delta (make-object style-delta%)])
+          (send scheme-standard get-delta scheme-delta)
+          (cng-delta scheme-delta)
+          (send scheme-standard set-delta scheme-delta)))
+      
+      (define standard-style-list<%>
+        (interface (editor<%>)
+          ))
+      
+      (define standard-style-list-mixin
+        (mixin (editor<%>) (standard-style-list<%>)
+          (super-instantiate ())
+          (inherit set-style-list set-load-overwrites-styles)
+          (set-style-list standard-style-list)
+	  (set-load-overwrites-styles #f)))
+          
+      (define (set-standard-style-list-pref-callbacks)
+        (set-font-size (preferences:get 'framework:standard-style-list:font-size))
+        (set-font-name (preferences:get 'framework:standard-style-list:font-name))
+        (set-font-smoothing (preferences:get 'framework:standard-style-list:smoothing))
+        (preferences:add-callback 'framework:standard-style-list:font-size (λ (p v) (set-font-size v)))
+        (preferences:add-callback 'framework:standard-style-list:font-name (λ (p v) (set-font-name v)))
+        (preferences:add-callback 'framework:standard-style-list:smoothing (λ (p v) (set-font-smoothing v)))
+        
+        (unless (member (preferences:get 'framework:standard-style-list:font-name) (get-face-list 'mono))
+          (preferences:set 'framework:standard-style-list:font-name (get-family-builtin-face 'modern))))
+      
+      ;; set-standard-style-list-delta : string (is-a?/c style-delta<%>) -> void
+      (define (set-standard-style-list-delta name delta)
+        (let* ([style-list (get-standard-style-list)]
+               [style (send style-list find-named-style name)])
+          (if style
+              (send style set-delta delta)
+              (send style-list new-named-style name
+                    (send style-list find-or-create-style
+                          (send style-list find-named-style "Standard")
+                          delta)))
+          (void)))
+      
+      (define -keymap<%> (interface (basic<%>) get-keymaps))
+      (define keymap-mixin
+	(mixin (basic<%>) (-keymap<%>)
+	  [define/public get-keymaps
+            (λ ()
+              (list (keymap:get-global)))]
+	  (inherit set-keymap)
+
+          (super-instantiate ())
+          (let ([keymap (make-object keymap:aug-keymap%)])
+            (set-keymap keymap)
+            (for-each (λ (k) (send keymap chain-to-keymap k #f))
+                      (get-keymaps)))))
+
+      (define autowrap<%> (interface (basic<%>)))
+      (define autowrap-mixin
+	(mixin (basic<%>) (autowrap<%>)
+	  (inherit auto-wrap)
+          (super-instantiate ())
+          (auto-wrap 
+           (preferences:get
+            'framework:auto-set-wrap?))))
+      
+      (define file<%> 
+        (interface (-keymap<%>)
+          get-can-close-parent
+          update-frame-filename
+          allow-close-with-no-filename?))
+      
+      (define file-mixin
+        (mixin (-keymap<%>) (file<%>)
+          (inherit get-filename lock get-style-list 
+                   is-modified? set-modified 
+                   get-top-level-window)
+
+          (inherit get-canvases get-filename/untitled-name)
+          (define/public (update-frame-filename)
+            (let* ([filename (get-filename)]
+                   [name (if filename
+                             (path->string (file-name-from-path (normalize-path filename)))
+                             (get-filename/untitled-name))])
+              (for-each (λ (canvas)
+                          (let ([tlw (send canvas get-top-level-window)])
+                            (when (and (is-a? tlw frame:editor<%>)
+                                       (eq? this (send tlw get-editor)))
+                              (send tlw set-label name))))
+                        (get-canvases))))
+          
+          (define/override set-filename
+	    (case-lambda
+	     [(name) (set-filename name #f)]
+	     [(name temp?)
+	      (super set-filename name temp?)
+	      (unless temp?
+		(update-frame-filename))]))
+
+          (inherit save-file)
+          (define/public (allow-close-with-no-filename?) #f)
+          (define/augment (can-close?)
+            (let* ([user-allowed-or-not-modified
+                    (or (not (is-modified?))
+                        (and (not (get-filename))
+                             (allow-close-with-no-filename?))
+                        (case (gui-utils:unsaved-warning
+                               (get-filename/untitled-name)
+                               (string-constant close-anyway)
+                               #t
+                               (or (get-top-level-window)
+                                   (get-can-close-parent)))
+                          [(continue) #t]
+                          [(save) (save-file)]
+                          [else #f]))])
+              (and user-allowed-or-not-modified
+                   (inner #t can-close?))))
+          
+          (define/public (get-can-close-parent) #f)
+          
+          (define/override (get-keymaps)
+            (cons (keymap:get-file) (super get-keymaps)))
+          (super-new)))
+      
+      (define backup-autosave<%>
+	(interface (basic<%>)
+	  backup?
+	  autosave?
+	  do-autosave
+	  remove-autosave))
+
+      (define backup-autosave-mixin
+	(mixin (basic<%>) (backup-autosave<%> autosave:autosavable<%>)
+	  (inherit is-modified? get-filename save-file)
+	  [define auto-saved-name #f]
+          [define auto-save-out-of-date? #t]
+          [define auto-save-error? #f]
+          (define/private (file-old? filename)
+            (if (and filename
+                     (file-exists? filename))
+                (let ([modified-seconds (file-or-directory-modify-seconds filename)]
+                      [old-seconds (- (current-seconds) (* 7 24 60 60))])
+                  (< modified-seconds old-seconds))
+                #t))
+          (define/public (backup?) (preferences:get 'framework:backup-files?))
+          (define/augment (on-save-file name format)
+            (set! auto-save-error? #f)
+            (when (and (backup?)
+                       (not (eq? format 'copy))
+                       (file-exists? name))
+              (let ([back-name (path-utils:generate-backup-name name)])
+                (when (or (not (file-exists? back-name))
+                          (file-old? back-name))
+                  (when (file-exists? back-name)
+                    (delete-file back-name))
+                  (with-handlers ([(λ (x) #t) void])
+                    (copy-file name back-name)))))
+            (inner (void) on-save-file name format))
+          (define/augment (on-close)
+            (remove-autosave)
+            (set! do-autosave? #f)
+            (inner (void) on-close))
+          (define/augment (on-change)
+            (set! auto-save-out-of-date? #t)
+            (inner (void) on-change))
+          (define/override (set-modified modified?)
+            (when auto-saved-name
+              (if modified?
+                  (set! auto-save-out-of-date? #t)
+                  (remove-autosave)))
+            (super set-modified modified?))
+          
+          [define do-autosave? #t]
+	  (define/public (autosave?) do-autosave?)
+
+          (define/public (do-autosave)
+            (cond
+              [(and (autosave?)
+                    (not auto-save-error?)
+                    (is-modified?)
+                    (or (not auto-saved-name)
+                        auto-save-out-of-date?))
+               (let* ([orig-name (get-filename)]
+                      [old-auto-name auto-saved-name]
+                      [auto-name (path-utils:generate-autosave-name orig-name)]
+		      [orig-format (and (is-a? this text%)
+					(send this get-file-format))])
+		 (when (is-a? this text%)
+		   (send this set-file-format 'standard))
+                 (with-handlers ([exn:fail?
+                                  (λ (exn)
+                                    (show-autosave-error exn orig-name)
+                                    (set! auto-save-error? #t)
+				    (when (is-a? this text%)
+				      (send this set-file-format orig-format))
+                                    #f)])
+                   (save-file auto-name 'copy #f)
+		   (when (is-a? this text%)
+		     (send this set-file-format orig-format))
+                   (when old-auto-name
+                     (delete-file old-auto-name))
+                   (set! auto-saved-name auto-name)
+                   (set! auto-save-out-of-date? #f)
+                   auto-name))]
+              [else auto-saved-name]))
+
+	  ;; show-autosave-error : any (union #f string) -> void
+	  ;; opens a message box displaying the exn and the filename
+	  ;; to the user.
+	  (define/private (show-autosave-error exn orig-name)
+	    (message-box 
+	     (string-constant warning)
+	     (string-append
+	      (format (string-constant error-autosaving)
+		      (or orig-name (string-constant untitled)))
+	      "\n"
+	      (string-constant autosaving-turned-off)
+	      "\n\n"
+	      (if (exn? exn)
+		  (format "~a" (exn-message exn))
+		  (format "~s" exn)))
+	     #f
+	     '(caution ok)))
+	  
+          (define/public (remove-autosave)
+            (when auto-saved-name
+              (when (file-exists? auto-saved-name)
+                (delete-file auto-saved-name))
+              (set! auto-saved-name #f)))
+	  (super-instantiate ())
+          (autosave:register this)))
+
+      (define info<%> (interface (basic<%>)))
+      (define info-mixin
+	(mixin (basic<%>) (info<%>)
+	  (inherit get-top-level-window run-after-edit-sequence)
+	  (define callback-running? #f)
+          (define/override (lock x)
+            (super lock x)
+            (run-after-edit-sequence
+             (rec send-frame-update-lock-icon
+               (λ ()
+                 (unless callback-running?
+                   (set! callback-running? #t)
+                   (queue-callback
+                    (λ ()
+                      (let ([frame (get-top-level-window)])
+                        (when (is-a? frame frame:info<%>)
+                          (send frame lock-status-changed)))
+                      (set! callback-running? #f))
+                    #f))))
+             'framework:update-lock-icon))
+          (super-instantiate ()))))))
diff --git a/collects/framework/private/encode-decode.ss b/collects/framework/private/encode-decode.ss
new file mode 100644
index 0000000000..90dfd87972
--- /dev/null
+++ b/collects/framework/private/encode-decode.ss
@@ -0,0 +1,91 @@
+(module encode-decode mzscheme
+  (require (lib "deflate.ss")
+           (lib "match.ss"))
+  (require-for-syntax (lib "inflate.ss")
+                      (lib "string.ss"))
+  
+  (provide encode-sexp
+           decode
+           encode-module)
+  
+  (define (encode-module in-filename out-filename)
+    (call-with-input-file in-filename
+      (λ (port)
+        (let ([mod (read port)])
+          (unless (eof-object? (read port))
+            (error 'encode-module "found an extra expression"))
+          (match mod 
+            [`(module ,m mzscheme ,@(bodies ...))
+             (call-with-output-file out-filename
+               (λ (oport)
+                 (write `(module ,m mzscheme
+                           (require (lib "encode-decode.ss" "framework" "private"))
+                           (decode ,(encode-sexp `(begin ,@bodies))))
+                        oport))
+               'truncate 'text)]
+            [else (error 'encode-module "cannot parse module")])))))
+  
+  (define (encode-sexp sexp)
+    (define (str->sym string)
+      (string->symbol
+       (apply 
+        string-append
+        (map
+         (λ (x) 
+           (to-hex x))
+         (bytes->list string)))))
+    
+    (define (to-hex n)
+      (let ([digit->hex
+             (λ (d)
+               (cond
+                 [(<= d 9) d]
+                 [else (integer->char (+ d -10 (char->integer #\a)))]))])
+        (cond
+          [(< n 16) (format "0~a" (digit->hex n))]
+          [else (format "~a~a" 
+                        (digit->hex (quotient n 16))
+                        (digit->hex (modulo n 16)))])))
+    
+    (let ([in (open-input-string (format "~s" sexp))]
+          [out (open-output-bytes)])
+      (deflate in out)
+      (str->sym (get-output-bytes out))))
+  
+  (define-syntax (decode stx)
+    (syntax-case stx ()
+      [(_ arg ...)
+       (andmap identifier? (syntax->list (syntax (arg ...))))
+       (let ()
+         (define (decode-sexp str)
+           (let* ([loc 
+                   (let loop ([chars (string->list str)])
+                     (cond
+                       [(null? chars) '()]
+                       [(null? (cdr chars)) (error 'to-sexp "missing digit somewhere")]
+                       [else (let ([fst (to-digit (car chars))]
+                                   [snd (to-digit (cadr chars))])
+                               (cons
+                                (+ (* fst 16) snd)
+                                (loop (cddr chars))))]))])
+             (let-values ([(p-in p-out) (make-pipe)])
+               (inflate (open-input-bytes (apply bytes loc)) p-out)
+               (read p-in))))
+         
+         (define (to-digit char)
+           (cond
+             [(char<=? #\0 char #\9) 
+              (- (char->integer char)
+                 (char->integer #\0))]
+             [(char<=? #\a char #\f) 
+              (+ 10 (- (char->integer char)
+                       (char->integer #\a)))]))
+
+         (datum->syntax-object
+          stx
+          (decode-sexp 
+           (apply 
+            string-append
+            (map (λ (x) (symbol->string (syntax-e x)))
+                 (syntax->list (syntax (arg ...))))))
+          stx))])))
\ No newline at end of file
diff --git a/collects/framework/private/exit.ss b/collects/framework/private/exit.ss
new file mode 100644
index 0000000000..db3efe340c
--- /dev/null
+++ b/collects/framework/private/exit.ss
@@ -0,0 +1,75 @@
+(module exit mzscheme
+  (require (lib "unitsig.ss")
+           (lib "string-constant.ss" "string-constants")
+	   (lib "class.ss")
+	   "sig.ss"
+	   "../gui-utils.ss"
+	   (lib "mred-sig.ss" "mred")
+	   (lib "file.ss")
+           (lib "etc.ss"))
+
+  (provide exit@)
+
+  (define exit@
+    (unit/sig framework:exit^
+      (import mred^
+	      [preferences : framework:preferences^])
+      (rename (-exit exit))
+      
+      (define can?-callbacks '())
+      (define on-callbacks '())
+      
+      (define insert-can?-callback
+	(λ (cb)
+	  (set! can?-callbacks (cons cb can?-callbacks))
+	  (λ ()
+	    (set! can?-callbacks
+		  (let loop ([cb-list can?-callbacks])
+		    (cond
+		     [(null? cb-list) ()]
+		     [(eq? cb (car cb-list)) (cdr cb-list)]
+		     [else (cons (car cb-list) (loop (cdr cb-list)))]))))))
+
+      (define insert-on-callback
+	(λ (cb)
+	  (set! on-callbacks (cons cb on-callbacks))
+	  (λ ()
+	    (set! on-callbacks
+		  (let loop ([cb-list on-callbacks])
+		    (cond
+		     [(null? cb-list) ()]
+		     [(eq? cb (car cb-list)) (cdr cb-list)]
+		     [else (cons (car cb-list) (loop (cdr cb-list)))]))))))
+      
+      (define is-exiting? #f)
+      (define (set-exiting b) (set! is-exiting? b))
+      (define (exiting?) is-exiting?)
+      
+      (define (can-exit?) (andmap (λ (cb) (cb)) can?-callbacks))
+      (define (on-exit) (for-each (λ (cb) (cb)) on-callbacks))
+
+      (define (user-oks-exit)
+	(if (preferences:get 'framework:verify-exit)
+	    (gui-utils:get-choice
+	     (if (eq? (system-type) 'windows)
+		 (string-constant are-you-sure-exit)
+		 (string-constant are-you-sure-quit))
+	     (if (eq? (system-type) 'windows)
+		 (string-constant exit)
+		 (string-constant quit))
+	     (string-constant cancel)
+	     (string-constant warning)
+	     #f)
+	    #t))
+
+      (define (-exit)
+        (set! is-exiting? #t)
+        (cond
+          [(can-exit?)
+           (on-exit)
+           (queue-callback 
+            (λ () 
+              (exit)
+              (set! is-exiting? #f)))]
+          [else
+           (set! is-exiting? #f)])))))
diff --git a/collects/framework/private/exn.ss b/collects/framework/private/exn.ss
new file mode 100644
index 0000000000..ce7215cb5f
--- /dev/null
+++ b/collects/framework/private/exn.ss
@@ -0,0 +1,18 @@
+(module exn mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "class.ss")
+	   "sig.ss"
+	   (lib "mred-sig.ss" "mred"))
+
+  (provide exn@)
+
+  (define exn@
+    (unit/sig framework:exn^
+      (import)
+
+      (rename [struct:-exn struct:exn]
+	      [make--exn make-exn]
+	      [-exn? exn?])
+
+      (define-struct (-exn exn) ())
+      (define-struct (unknown-preference exn) ()))))
diff --git a/collects/framework/private/finder.ss b/collects/framework/private/finder.ss
new file mode 100644
index 0000000000..b6645dfd00
--- /dev/null
+++ b/collects/framework/private/finder.ss
@@ -0,0 +1,750 @@
+
+(module finder mzscheme
+  (require (lib "string-constant.ss" "string-constants")
+           (lib "unitsig.ss")
+	   "sig.ss"
+	   "../gui-utils.ss"
+           (lib "class.ss")
+	   (lib "mred-sig.ss" "mred")
+	   (lib "string.ss")
+	   (lib "list.ss")
+	   (lib "file.ss")
+	   (lib "etc.ss"))
+
+  (provide finder@)
+
+  (define finder@
+    (unit/sig framework:finder^
+      (import mred^
+              [preferences : framework:preferences^]
+	      [keymap : framework:keymap^])
+
+      (rename [-put-file put-file]
+	      [-get-file get-file])
+      
+      (define dialog-parent-parameter (make-parameter #f))
+
+      (define filter-match?
+	(λ (filter name msg)
+	  (let-values ([(base name dir?) (split-path name)])
+	    (if (regexp-match-exact? filter (path->bytes name))
+		#t
+		(begin
+		  (message-box (string-constant error) msg)
+		  #f)))))
+      
+      (define (set-last-directory dir) (preferences:set 'framework:last-directory dir))
+      (define (get-last-directory) (preferences:get 'framework:last-directory))
+      
+      (define make-relative
+	(λ (s) s))
+      
+      (define build-updir
+	(λ (dir)
+	  (let-values ([(base _1 _2) (split-path dir)])
+	    (or base dir))))
+
+      (define default-filters (make-parameter '(("Any" "*.*"))))
+      (define default-extension (make-parameter ""))
+
+      ; the finder-dialog% class controls the user interface for dialogs
+      
+      (define finder-dialog%
+	(class dialog% 
+          (init parent-win)
+          (init-field save-mode?)
+          (init-field replace-ok?)
+          (init-field multi-mode?)
+          (init-field result-box)
+          (init start-dir)
+          (init start-name)
+          (init prompt)
+          (init-field file-filter)
+          (init-field file-filter-msg)
+	  
+          (inherit center show)
+          
+	  (define default-width 500)
+          (define default-height 400)
+          (define dirs #f)
+          (define current-dir #f)
+	  
+	  (define/private set-listbox-directory ; sets directory in listbox 
+            (λ (dir) ; dir is normalized
+              (when (directory-exists? dir)
+                (gui-utils:show-busy-cursor
+                 (λ ()
+                   (set! current-dir dir)
+                   (set-last-directory dir)
+                   (let-values 
+                       ([(dir-list menu-list)
+                         (let loop ([this-dir dir]
+                                    [dir-list null]
+                                    [menu-list null])
+                           (let-values ([(base-dir in-dir dir?) (split-path this-dir)])
+                             (when (eq? (system-type) 'windows)
+                               (string-lowercase! in-dir))
+                             (let* ([dir-list (cons this-dir dir-list)]
+                                    [menu-list (cons (path->string in-dir) menu-list)])
+                               (if base-dir
+                                   (loop base-dir dir-list menu-list)
+                                   ; No more
+                                   (values dir-list menu-list)))))])
+                     (set! dirs (reverse dir-list))
+                     (send dir-choice clear)
+                     (let loop ([choices (reverse menu-list)])
+                       (unless (null? choices)
+                         (send dir-choice append (car choices))
+                         (loop (cdr choices))))
+                     (send dir-choice set-selection 0))
+                   
+                   (send name-list clear)
+                   (send name-list set
+                         (quicksort
+                          (let ([no-periods? 
+                                 (not (preferences:get
+                                       'framework:show-periods-in-dirlist))])
+                            (let loop ([l (directory-list dir)])
+                              (if (null? l)
+                                  null
+                                  (let ([s (car l)]
+                                        [rest (loop (cdr l))])
+                                    (cond
+                                      [(and no-periods?
+                                            (let ([str (path->string s)])
+                                              (<= 1 (string-length str))
+                                              (char=? (string-ref str 0) #\.)))
+                                       rest]
+                                      [(directory-exists? (build-path dir s))
+                                       (cons (path->string s) rest)]
+                                      [(or (not file-filter)
+                                           (regexp-match-exact? file-filter (path->string s)))
+                                       (cons (path->string s)
+                                             rest)]
+                                      [else rest])))))
+                          string<?))
+                   (send name-list set-selection-and-edit 0))))))
+          
+          (define/private set-edit
+            (λ ()
+              (let* ([file (send name-list get-string-selection)])
+                (send directory-field set-value
+                      (path->string
+                       (if file
+                           (build-path current-dir file)
+                           current-dir))))))
+	  
+	  [define/public do-period-in/exclusion
+            (λ (check-box event)
+              (preferences:set
+               'framework:show-periods-in-dirlist
+               (send check-box get-value))
+              (set-listbox-directory current-dir))]
+          
+          [define/public do-dir
+            (λ (choice event)
+              (let ([which (send choice get-selection)])
+                (if (< which (length dirs))
+                    (set-listbox-directory (list-ref dirs which)))))]
+          
+          [define/public do-name-list
+            (λ (list-box evt)
+              (if (eq? (send evt get-event-type) 'list-box-dclick)
+                  (let ([dir (send directory-field get-value)])
+                    (if (directory-exists? dir)
+                        (set-listbox-directory (normal-case-path (normalize-path dir)))
+                        (if multi-mode?
+                            (do-add)
+                            (do-ok))))
+                  (when (send list-box get-string-selection)
+                    (set-edit))))]
+          
+          [define/public do-result-list
+            (λ () #f)]
+          
+          [define/public do-ok
+            (λ args
+              
+              (if multi-mode?
+                  
+                  (let loop ([n (sub1 (send result-list get-number))]
+                             [result null])
+                    (if (< n 0)
+                        (begin
+                          (set-box! result-box result)
+                          (show #f))
+                        (loop (sub1 n) 
+                              (cons (send result-list get-string n)
+                                    result))))
+                  ; not multi-mode
+                  
+                  (let ([name (send name-list get-string-selection)]
+                        [non-empty? (> (send name-list get-number) 0)])
+                    
+                    (cond
+                      
+                      [(and save-mode? 
+                            non-empty?
+                            (not (string? name))) 'nothing-selected]
+                      
+                      [(and save-mode? 
+                            non-empty?
+                            (string=? name ""))
+                       (let ([file (send directory-field get-value)])
+                         (if (directory-exists? file)
+                             (set-listbox-directory (normal-case-path (normalize-path file)))
+                             (message-box 
+                              (string-constant error)
+                              (string-constant must-specify-a-filename))))]
+                      
+                      [(and save-mode? 
+                            non-empty?
+                            file-filter 
+                            (not (regexp-match-exact? file-filter name)))
+                       (message-box (string-constant error) file-filter-msg)]
+                      
+                      [else
+                       
+                       ; if dir in edit box, go to that dir
+                       
+                       (let ([dir-name (send directory-field get-value)])
+                         
+                         (if (directory-exists? dir-name)
+                             (set-listbox-directory (normal-case-path (normalize-path dir-name)))
+                             
+                             ; otherwise, try to return absolute path
+                             
+                             (let* ([relative-name (make-relative name)]
+                                    [file-in-edit (file-exists? dir-name)]
+                                    [file (if (or file-in-edit
+                                                  (not relative-name)
+                                                  save-mode?)
+                                              dir-name
+                                              (build-path current-dir relative-name))])
+                               
+                               ; trying to open a file that doesn't exist
+                               
+                               (if (and (not save-mode?) (not file-in-edit))
+                                   (message-box 
+                                    (string-constant error)
+                                    (format (string-constant file-does-not-exist) dir-name))
+                                   
+                                   ; saving a file, which may exist, or
+                                   ; opening an existing file
+                                   
+                                   (if (or (not save-mode?)
+                                           (not (file-exists? file))
+                                           replace-ok?
+                                           (eq? (message-box 
+                                                 (string-constant warning)
+                                                 (format
+                                                  (string-constant ask-because-file-exists)
+                                                  file)
+                                                 #f
+                                                 '(yes-no))
+                                                'yes))
+                                       (let ([normal-path
+                                              (with-handlers 
+                                                  ([(λ (_) #t)
+                                                    (λ (_)
+                                                      (message-box
+                                                       (string-constant warning)
+                                                       (format
+                                                        (string-constant dne-or-cycle)
+                                                        file))
+                                                      #f)])
+                                                (normal-case-path
+                                                 (normalize-path file)))])
+                                         (when normal-path 
+                                           (set-box! result-box normal-path)
+                                           (show #f))))))))]))))]
+          
+          [define/public add-one
+            (λ (name)
+              (unless (or (directory-exists? name)
+                          (send result-list find-string name))
+                (send result-list append
+                      (normal-case-path (normalize-path name)))))]
+          
+          [define/public do-add
+            (λ ()
+              (let ([name (send name-list get-string-selection)])
+                (if (string? name)
+                    (let ([name (build-path current-dir
+                                            (make-relative name))])
+                      (add-one name)))))]
+          
+          [define/public do-add-all
+            (λ ()
+              (let loop ([n 0])
+                (when (< n (send name-list get-number))
+                  (let ([name (send name-list get-string n)])
+                    (let ([name (build-path current-dir
+                                            (make-relative name))])
+                      (add-one name)
+                      (loop (add1 n)))))))]
+          
+          [define/public do-remove
+            (λ ()
+              (let loop ([n 0])
+                (if (< n (send result-list get-number))
+                    (if (send result-list is-selected? n)
+                        (begin
+                          (send result-list delete n)
+                          (loop n))
+                        (loop (add1 n))))))]
+          
+          [define/public do-cancel
+            (λ ()
+              (set-box! result-box #f)
+              (show #f))]
+	  
+	  (define/augment on-close (λ () #f))
+	  
+          (super-new (label (if save-mode? 
+                                (string-constant put-file)
+                                (string-constant get-file)))
+                     (parent parent-win)
+                     (width default-width)
+                     (height default-height)
+                     (style '(resize-border)))
+	  
+          [define main-panel (make-object vertical-panel% this)]
+          
+          [define top-panel (make-object horizontal-panel% main-panel)]
+          
+          (make-object message% prompt top-panel)
+          
+          [define dir-choice (make-object choice% #f null top-panel
+                               (λ (choice event) (do-dir choice event)))]
+          
+          [define middle-panel (make-object horizontal-panel% main-panel)]
+          [define left-middle-panel (make-object vertical-panel% middle-panel)]
+          [define right-middle-panel (when multi-mode? 
+                                       (make-object vertical-panel% middle-panel))]
+          
+          [define name-list%
+            
+            (class list-box%
+              
+              (inherit 
+                get-string-selection
+                get-string
+                get-selection
+                get-number
+                get-first-visible-item
+                number-of-visible-items
+                set-first-visible-item
+                set-selection)
+              
+              (define/override (on-subwindow-char _ key)
+                (let ([code (send key get-key-code)]
+                      [num-items (get-number)]
+                      [curr-pos (get-selection)])
+                  (cond 
+                    [(or (equal? code 'numpad-return)
+                         (equal? code #\return))
+                     (if multi-mode?
+                         (do-add)
+                         (do-ok))]
+                    
+                    ; look for letter at beginning of a filename
+                    [(char? code)
+                     (let ([next-matching
+                            (let loop ([pos (add1 curr-pos)])
+                              (cond
+                                [(>= pos num-items) #f]
+                                [else
+                                 (let ([first-char (string-ref (get-string pos) 0)])
+                                   (if (char-ci=? code first-char)
+                                       pos
+                                       (loop (add1 pos))))]))])
+                       (if next-matching
+                           (set-selection-and-edit next-matching)
+                           
+                           ;; didn't find anything forward; start again at front of list
+                           (let loop ([pos 0]
+                                      [last-before 0])
+                             (cond
+                               [(<= pos num-items)
+                                (let ([first-char (string-ref (get-string pos) 0)])
+                                  (cond
+                                    [(char-ci=? code first-char)
+                                     (set-selection-and-edit pos)]
+                                    [(char-ci<=? first-char code)
+                                     (loop (+ pos 1)
+                                           pos)]
+                                    [else
+                                     (set-selection-and-edit last-before)]))]
+                               [else (set-selection-and-edit last-before)]))))]
+                    
+                    ; movement keys
+                    [(and (eq? code 'up) 
+                          (> curr-pos 0))
+                     (set-selection-and-edit (sub1 curr-pos))]
+                    
+                    [(and (eq? code 'down)
+                          (< curr-pos (sub1 num-items)))
+                     (let* ([num-vis (number-of-visible-items)] 
+                            [curr-first (get-first-visible-item)]
+                            [new-curr-pos (add1 curr-pos)]
+                            [new-first (if (< new-curr-pos (+ curr-first num-vis))
+                                           curr-first ; no scroll needed
+                                           (add1 curr-first))])
+                       (set-first-visible-item new-first)
+                       (set-selection-and-edit new-curr-pos))]
+                    
+                    [(and (eq? code 'prior)
+                          (> curr-pos 0))
+                     (let* ([num-vis (number-of-visible-items)]
+                            [new-first (- (get-first-visible-item) num-vis)])
+                       (set-first-visible-item (max new-first 0))
+                       (set-selection-and-edit (max 0 (- curr-pos num-vis))))]
+                    
+                    [(and (eq? code 'next)
+                          (< curr-pos (sub1 num-items)))
+                     (let* ([num-vis (number-of-visible-items)]
+                            [new-first (+ (get-first-visible-item) num-vis)])
+                       (set-first-visible-item
+                        (min new-first (- (get-number) num-vis)))
+                       (set-selection-and-edit 
+                        (min (sub1 num-items) (+ curr-pos num-vis))))]
+                    
+                    [else #f])))
+              
+              [define/public set-selection-and-edit
+                 (λ (pos)
+                   (when (> (get-number) 0)
+                     (let* ([first-item (get-first-visible-item)]
+                            [last-item (sub1 (+ (number-of-visible-items) 
+                                                first-item))])
+                       (if (or (< pos first-item) (> pos last-item))
+                           (set-first-visible-item pos))
+                       (set-selection pos)))
+                   (set-edit))]
+              [define/public on-default-action
+                (λ ()
+                  (when (> (get-number) 0)
+                    (let* ([which (get-string-selection)]
+                           [dir (build-path current-dir
+                                            (make-relative which))])
+                      (if (directory-exists? dir)
+                          (set-listbox-directory (normal-case-path
+                                                  (normalize-path dir)))
+                          (if multi-mode?
+                              (do-add)
+                              (do-ok))))))]
+              
+              (super-new))]
+          
+          [define name-list (make-object name-list%
+                              #f null left-middle-panel (λ (x y) (do-name-list x y))
+                              '(single))]
+          
+          [define save-panel (when save-mode? (make-object horizontal-panel% main-panel))]
+          
+          [define directory-panel (make-object horizontal-panel% main-panel)]
+          
+          [define dot-panel (when (eq? 'unix (system-type))
+                              (make-object horizontal-panel% main-panel))]
+          
+          [define bottom-panel (make-object horizontal-panel% main-panel)]
+          
+          [define directory-field
+            (keymap:call/text-keymap-initializer
+             (λ ()
+               (make-object text-field%
+                 (string-constant full-pathname)
+                 directory-panel
+                 (λ (txt evt)
+                   (when (eq? (send evt get-event-type) 'text-field-enter)
+                     (let ([dir (send directory-field get-value)])
+                       (if (directory-exists? dir)
+                           (set-listbox-directory (normal-case-path
+                                                   (normalize-path dir)))
+                           (if multi-mode?
+                               (do-add)
+                               (do-ok)))))))))]
+          
+          [define result-list
+            (when multi-mode?
+              (make-object list-box%
+                #f
+                null
+                right-middle-panel
+                (λ (x y) (do-result-list))
+                '(multiple)))]
+          [define add-panel 
+            (when multi-mode? 
+              (make-object horizontal-panel% left-middle-panel))]
+          
+          [define remove-panel 
+            (when multi-mode? 
+              (make-object horizontal-panel% right-middle-panel))]
+          
+          [define/private do-updir
+            (λ () 
+              (set-listbox-directory (build-updir current-dir))
+              (set-focus-to-name-list))]
+          
+          [define/private set-focus-to-name-list
+            (λ ()
+              (send name-list focus))]
+	  
+          
+          (when (eq? (system-type) 'unix)
+            (let ([dot-cb
+                   (make-object check-box%
+                     (string-constant show-dot-files)
+                     dot-panel
+                     (λ (x y) (do-period-in/exclusion x y)))])
+              (send dot-panel stretchable-height #f)
+              (send dot-cb set-value 
+                    (preferences:get 'framework:show-periods-in-dirlist))))
+          
+          (send directory-panel stretchable-height #f)
+          
+          (when multi-mode?
+            (send add-panel stretchable-height #f)
+            (send remove-panel stretchable-height #f)
+            (send result-list stretchable-width #t))
+          
+          (make-object button% 
+            (string-constant up-directory-button-label)
+            top-panel
+            (λ (button evt) (do-updir)))
+          
+          (send dir-choice stretchable-width #t)
+          (send name-list stretchable-width #t)
+          (send top-panel stretchable-height #f)
+          (send bottom-panel stretchable-height #f)
+          
+          (when save-mode?
+            (send save-panel stretchable-height #f))
+	  
+	  [define add-button (when multi-mode?
+                               (make-object horizontal-panel% add-panel)
+                               (make-object button%
+                                 (string-constant add-button-label)
+                                 add-panel
+                                 (λ (x y) (do-add))))]
+          [define add-all-button (when multi-mode?
+                                   (begin0
+                                     (make-object button%
+                                       (string-constant add-all-button-label)
+                                       add-panel 
+                                       (λ (x y) (do-add-all)))
+                                     (make-object horizontal-panel% add-panel)))]
+          [define remove-button (when multi-mode?
+                                  (make-object horizontal-panel% remove-panel)
+                                  (begin0
+                                    (make-object button% 
+                                      (string-constant remove-button-label)
+                                      remove-panel
+                                      (λ (x y) (do-remove)))
+                                    (make-object horizontal-panel% remove-panel)))]
+          (make-object vertical-panel% bottom-panel) 
+          [define ok-button
+            (make-object button% (string-constant ok) bottom-panel 
+              (λ (x y) (do-ok))
+              (if multi-mode? '() '(border)))]
+          [define cancel-button (make-object button% 
+                                  (string-constant cancel)
+                                  bottom-panel
+                                  (λ (x y) (do-cancel)))]
+          (make-object grow-box-spacer-pane% bottom-panel)
+          
+          (cond
+            [(and start-dir
+                  (directory-exists? start-dir))
+             (set-listbox-directory (normal-case-path
+                                     (normalize-path start-dir)))]
+            [(get-last-directory)
+             =>
+             (λ (dir)
+               (set-listbox-directory dir))]
+            [else (set-listbox-directory (current-directory))])
+          
+          (send ok-button min-width (send cancel-button get-width))
+          
+          (center 'both)
+          
+          (show #t)))
+      
+      ; make-common takes a dialog-maker
+      ; used to make one dialog object per session, now created each time
+      (define make-common
+	(λ (make-dialog)
+	  (λ args
+	    (let ([result-box (box #f)])
+	      (apply make-dialog result-box args)
+	      (unbox result-box)))))
+      
+					; the common versions of these functions have their visual
+					; interfaces under Scheme control
+      
+      (define common-put-file
+	(make-common
+	 (opt-lambda (result-box 
+		      [name #f]
+		      [in-directory #f]
+		      [replace? #f]
+		      [prompt (string-constant select-file)]
+		      [filter #f]
+		      [filter-msg (string-constant file-wrong-form)]
+		      [parent-win (dialog-parent-parameter)])
+	   (let* ([directory (if (and (not in-directory)
+				      (string? name))
+				 (path-only name)
+				 in-directory)]
+		  [saved-directory (get-last-directory)]
+		  [name (or (and (string? name)
+				 (file-name-from-path name))
+			    name)])
+             (new finder-dialog% 
+                  (parent-win parent-win)
+                  (save-mode? #t)
+                  (replace-ok? replace?)
+                  (multi-mode? #f)
+                  (result-box result-box )
+                  (start-dir directory)
+                  (start-name name)
+                  (prompt prompt)
+                  (file-filter filter)
+                  (file-filter-msg filter-msg))
+	     (when in-directory (set-last-directory saved-directory))))))
+      
+      (define common-get-file
+	(make-common
+	 (opt-lambda
+	     (result-box 
+	      [directory #f]
+	      [prompt (string-constant select-file)]
+	      [filter #f]
+	      [filter-msg (string-constant file-wrong-form)]
+	      [parent-win (dialog-parent-parameter)])
+	   (let ([saved-directory (get-last-directory)])
+             (new finder-dialog% 
+                  (parent-win parent-win)
+                  (save-mode? #f)
+                  (replace-ok? #f)
+                  (multi-mode? #f)
+                  (result-box result-box)
+                  (start-dir directory)
+                  (start-name #f)
+                  (prompt prompt)
+                  (file-filter filter)
+                  (file-filter-msg filter-msg))
+	     (when directory (set-last-directory saved-directory))))))
+      
+      (define common-get-file-list
+	(make-common
+	 (opt-lambda (result-box 
+		      [directory #f]
+		      [prompt (string-constant select-files)]
+		      [filter #f]
+		      [filter-msg (string-constant file-wrong-form)]
+		      [parent-win (dialog-parent-parameter)])
+      	   (new finder-dialog% 
+                (parent-win parent-win)
+                (save-mode? #f)
+                (replace-ok? #f)
+                (multi-mode? #t)
+                (result-box result-box)
+                (start-dir directory)
+                (start-name #f)
+                (prompt prompt)
+                (file-filter filter)
+                (file-filter-msg filter-msg)))))
+      
+      ; the std- and common- forms both have opt-lambda's, with the same
+      ; list of args.  Should the opt-lambda's be placed in the dispatching function?
+      
+      (define std-put-file
+	(opt-lambda ([name #f]
+		     [directory #f]
+		     [replace? #f]
+		     [prompt (string-constant select-file)]
+		     [filter #f]
+		     [filter-msg (string-constant file-wrong-form)]
+		     [parent-win (dialog-parent-parameter)])
+	  (let* ([directory (if (and (not directory)
+				     (string? name))
+				(path-only name)
+				directory)]
+		 [name (or (and (string? name)
+				(file-name-from-path name))
+			   name)]
+		 [f (put-file 
+		     prompt 
+		     parent-win
+		     directory 
+		     name
+		     (default-extension)
+		     '()
+		     (default-filters))])
+
+	    (if (or (not f)
+		    (and filter 
+			 (not (filter-match? filter 
+					     f
+					     filter-msg))))
+		#f
+		(let* ([f (normal-case-path (normalize-path f))]
+		       [dir (path-only f)]
+		       [name (file-name-from-path f)])
+		  (cond
+		   [(not (and (path-string? dir) (directory-exists? dir)))
+		    (message-box (string-constant error)
+                                 (string-constant dir-dne))
+		    #f]
+		   [(or (not name) (equal? name ""))
+		    (message-box (string-constant error)
+                                 (string-constant empty-filename))
+		    #f]
+		   [else f]))))))
+      
+      (define std-get-file
+	(opt-lambda ([directory #f]
+		     [prompt (string-constant select-file)]
+		     [filter #f]
+		     [filter-msg (string-constant file-wrong-form)]
+		     [parent-win (dialog-parent-parameter)])
+	  (let ([f (get-file
+		    prompt 
+		    parent-win
+		    directory)])
+
+	    (if f
+		(if (or (not filter) (filter-match? filter f filter-msg))
+		    (let ([f (normalize-path f)])
+		      (cond
+		       [(directory-exists? f)
+			(message-box (string-constant error)
+                                     (string-constant that-is-dir-name))
+			#f]
+		       [(not (file-exists? f))
+			(message-box (string-constant error) 
+                                     (string-constant file-dne))
+			#f]
+		       [else f]))
+		    #f)
+		#f))))
+      
+					; external interfaces to file functions
+      
+      (define -put-file
+	(λ args
+	  (let ([actual-fun 
+		 (case (preferences:get 'framework:file-dialogs)
+		   [(std) std-put-file]
+		   [(common) common-put-file])])
+	    (apply actual-fun args))))
+      
+      (define -get-file
+	(λ args
+	  (let ([actual-fun
+		 (case (preferences:get 'framework:file-dialogs)
+		   [(std) std-get-file]
+		   [(common) common-get-file])])
+	    (apply actual-fun args)))))))
diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss
new file mode 100644
index 0000000000..28652af25a
--- /dev/null
+++ b/collects/framework/private/frame.ss
@@ -0,0 +1,2319 @@
+
+(module frame mzscheme
+  (require (lib "string-constant.ss" "string-constants")
+           (lib "unitsig.ss")
+	   (lib "class.ss")
+	   (lib "include.ss")
+	   "sig.ss"
+	   "../gui-utils.ss"
+           "bday.ss"
+	   (lib "mred-sig.ss" "mred")
+	   (lib "list.ss")
+	   (lib "file.ss")
+	   (lib "etc.ss"))
+  
+  (provide frame@)
+  
+  (define frame@
+    (unit/sig framework:frame^
+      (import mred^
+              [group : framework:group^]
+              [preferences : framework:preferences^]
+              [icon : framework:icon^]
+              [handler : framework:handler^]
+              [application : framework:application^]
+              [panel : framework:panel^]
+              [finder : framework:finder^]
+              [keymap : framework:keymap^]
+              [text : framework:text^]
+              [pasteboard : framework:pasteboard^]
+              [editor : framework:editor^]
+              [canvas : framework:canvas^]
+              [menu : framework:menu^]
+              [scheme : framework:scheme^]
+              [exit : framework:exit^]
+              [comment-box : framework:comment-box^])
+      
+      (rename [-editor<%> editor<%>]
+              [-pasteboard% pasteboard%]
+              [-text% text%])
+
+      (define (reorder-menus frame)
+        (let* ([items (send (send frame get-menu-bar) get-items)]
+               [move-to-back
+                (λ (name items)
+                  (let loop ([items items]
+                             [back null])
+                    (cond
+                      [(null? items) back]
+                      [else (let ([item (car items)])
+                              (if (string=? (send item get-plain-label) name)
+                                  (loop (cdr items)
+                                        (cons item back))
+                                  (cons item (loop (cdr items) back))))])))]
+               [move-to-front
+                (λ (name items)
+                  (reverse (move-to-back name (reverse items))))]
+               [re-ordered
+                (move-to-front
+                 (string-constant file-menu)
+                 (move-to-front
+                  (string-constant edit-menu)
+                  (move-to-back
+                   (string-constant help-menu)
+                   (move-to-back
+                    (string-constant windows-menu)
+                    items))))])
+          (for-each (λ (item) (send item delete)) items)
+          (for-each (λ (item) (send item restore)) re-ordered)))
+      
+      (define (add-snip-menu-items edit-menu c%)
+        (let* ([get-edit-target-object
+                (λ ()
+                  (let ([menu-bar
+                         (let loop ([p (send edit-menu get-parent)])
+                           (cond
+                             [(is-a? p menu-bar%)
+                              p]
+                             [(is-a? p menu%)
+                              (loop (send p get-parent))]
+                             [else #f]))])
+                    (and menu-bar
+                         (let ([frame (send menu-bar get-frame)])
+                           (send frame get-edit-target-object)))))]
+               [edit-menu:do 
+                (λ (const)
+                  (λ (menu evt)
+                    (let ([edit (get-edit-target-object)])
+                      (when (and edit
+                                 (is-a? edit editor<%>))
+                        (send edit do-edit-operation const)))
+                    #t))]
+               [on-demand
+                (λ (menu-item)
+                  (let ([edit (get-edit-target-object)])
+                    (send menu-item enable (and edit (is-a? edit editor<%>)))))]
+               [insert-comment-box
+                 (λ ()
+                   (let ([text (get-edit-target-object)])
+                     (when text
+                       (let ([snip (make-object comment-box:snip%)])
+                         (send text insert snip)
+                         (send text set-caret-owner snip 'global)))))])
+          
+          (make-object c% (string-constant insert-comment-box-menu-item-label)
+            edit-menu 
+            (λ (x y) (insert-comment-box))
+            #f #f
+            on-demand)
+          (make-object c% (string-constant insert-image-item)
+            edit-menu (edit-menu:do 'insert-image) #f #f on-demand)
+          (void)))
+      
+      (define frame-width 600)
+      (define frame-height 650)
+      (let ([window-trimming-upper-bound-width 20]
+            [window-trimming-upper-bound-height 50])
+        (let-values ([(w h) (get-display-size)])
+          (set! frame-width (min frame-width (- w window-trimming-upper-bound-width)))
+          (set! frame-height (min frame-height (- h window-trimming-upper-bound-height)))))
+      
+      (define basic<%> (interface ((class->interface frame%))
+                         get-area-container%
+                         get-area-container
+                         get-menu-bar%
+                         make-root-area-container
+                         close
+                         editing-this-file?
+                         get-filename
+                         make-visible))
+      (define basic-mixin
+        (mixin ((class->interface frame%)) (basic<%>)
+        
+          (define/override (show on?)
+            (if on?
+                (send (group:get-the-frame-group) insert-frame this)
+                (send (group:get-the-frame-group) remove-frame this))
+            (super show on?))
+          
+          (define/override (can-exit?)
+            (and (exit:user-oks-exit)
+                 (begin
+                   (exit:set-exiting #t)
+                   (let ([res (exit:can-exit?)])
+                     (unless res
+                       (exit:set-exiting #f))
+                     res))))
+          (define/override (on-exit) 
+            (exit:on-exit)
+            (queue-callback
+             (λ ()
+               (exit)
+               (exit:set-exiting #f))))
+                    
+          (define/public (make-visible filename) (void))
+          (define/public get-filename
+             (case-lambda
+              [() (get-filename #f)]
+              [(b) #f]))
+
+          (define/public (editing-this-file? filename) #f)
+
+	  (define/override (on-superwindow-show shown?)
+	    (send (group:get-the-frame-group) frame-shown/hidden this)
+	    (super on-superwindow-show shown?))
+         
+          (define after-init? #f)
+          
+          (define/override on-drop-file
+            (λ (filename)
+              (handler:edit-file filename)))
+          
+          ;; added call to set label here to hopefully work around a problem in mac mred
+          (inherit set-label change-children)
+          (define/override after-new-child
+            (λ (child)
+              (when after-init?
+                (change-children (λ (l) (remq child l)))
+                (error 'frame:basic-mixin
+                       "do not add children directly to a frame:basic (unless using make-root-area-container); use the get-area-container method instead"
+                       ))))
+          
+          (define/public get-area-container% (λ () vertical-panel%))
+          (define/public get-menu-bar% (λ () menu-bar%))
+          (define/public make-root-area-container
+            (λ (% parent)
+              (make-object % parent)))
+          
+          (inherit can-close? on-close)
+          (define/public close
+           (λ ()
+             (when (can-close?)
+               (on-close)
+               (show #f))))
+          
+          (inherit accept-drop-files)
+
+	  (super-new)
+
+          (accept-drop-files #t)
+            
+	  (let ([mb (make-object (get-menu-bar%) this)])
+	    (when (or (eq? (system-type) 'macos)
+		      (eq? (system-type) 'macosx))
+	      (make-object menu:can-restore-underscore-menu% (string-constant windows-menu-label)
+			   mb)))
+          
+          (reorder-menus this)
+	  
+          [define panel (make-root-area-container (get-area-container%) this)]
+          (define/public (get-area-container) panel)
+          (set! after-init? #t)))
+      
+      (define size-pref<%>
+        (interface (basic<%>)))
+      
+      (define size-pref-mixin
+        (mixin (basic<%>) (size-pref<%>)
+          (init-field size-preferences-key)
+          (define/override (on-size w h)
+            (preferences:set size-preferences-key (list w h)))
+          (let ([lst (preferences:get size-preferences-key)])
+            (super-new [width (car lst)] [height (cadr lst)]))))
+
+      (define (setup-size-pref size-preferences-key w h)
+        (preferences:set-default size-preferences-key 
+                                 (list w h)
+                                 (λ (x)
+                                   (and (pair? x)
+                                        (pair? (cdr x))
+                                        (null? (cddr x))
+                                        (number? (car x))
+                                        (number? (cadr x))))))
+      
+      (define register-group<%> (interface ()))
+      (define register-group-mixin
+        (mixin (basic<%>) (register-group<%>)
+          
+          (define/augment (can-close?)
+            (let ([number-of-frames 
+                   (length (send (group:get-the-frame-group)
+                                 get-frames))])
+              (and (inner #t can-close?)
+                   (or (not (preferences:get 'framework:exit-when-no-frames))
+                       (exit:exiting?)
+                       (not (= 1 number-of-frames))
+                       (exit:user-oks-exit)))))
+          (define/augment (on-close)
+            (send (group:get-the-frame-group)
+                  remove-frame
+                  this)
+            (inner (void) on-close)
+            (when (preferences:get 'framework:exit-when-no-frames)
+              (unless (exit:exiting?)
+                (when (null? (send (group:get-the-frame-group) get-frames))
+                  (exit:exit)))))
+          
+          (define/override (on-activate on?)
+            (super on-activate on?)
+            (when on?
+              (send (group:get-the-frame-group) set-active-frame this)))
+          
+          (super-new)
+          (send (group:get-the-frame-group) insert-frame this)))
+      
+      (define locked-message (string-constant read-only))
+      (define unlocked-message (string-constant read/write))
+      
+      (define lock-canvas%
+        (class canvas%
+          (field [locked? #f])
+          (define/public (set-locked l)
+            (set! locked? l)
+            (on-paint))
+          (inherit get-client-size get-dc)
+          (define/override (on-paint)
+            (let* ([dc (get-dc)]
+                   [draw
+                    (λ (str bg-color bg-style line-color line-style)
+                      (send dc set-font normal-control-font)
+                      (let-values ([(w h) (get-client-size)]
+                                   [(tw th ta td) (send dc get-text-extent str)])
+                        (send dc set-pen (send the-pen-list find-or-create-pen line-color 1 line-style))
+                        (send dc set-brush (send the-brush-list find-or-create-brush bg-color bg-style))
+                        (send dc draw-rectangle 0 0 w h)
+                        (send dc draw-text str
+                              (- (/ w 2) (/ tw 2))
+                              (- (/ h 2) (/ th 2)))))])
+              (if locked?
+                  (draw locked-message "yellow" 'solid "black" 'solid)
+                  (draw unlocked-message (get-panel-background) 'transparent (get-panel-background) 'transparent))))
+          (inherit get-parent min-width min-height stretchable-width stretchable-height)
+
+	  (super-new [style '(transparent)])
+
+          (let ([dc (get-dc)])
+            (send dc set-font normal-control-font)
+            (let-values ([(w1 h1 _1 _2) (send dc get-text-extent locked-message)]
+                         [(w2 h2 _3 _4) (send dc get-text-extent unlocked-message)])
+              (stretchable-width #f)
+              (stretchable-height #t)
+              (min-width (inexact->exact (floor (max w1 w2))))
+              (min-height (inexact->exact (floor (+ 4 (max h1 h2)))))))))
+
+      (define status-line<%>
+        (interface (basic<%>)
+          open-status-line
+          close-status-line
+          update-status-line))
+      
+      ;; status-line : (make-status-line symbol number)
+      (define-struct status-line (id count))
+      
+      ;; status-line-msg : (make-status-line-msg (is-a?/c message%) (union symbol #f))
+      (define-struct status-line-msg (message id))
+      
+      (define status-line-mixin
+        (mixin (basic<%>) (status-line<%>)
+          (field [status-line-container-panel #f]
+                 
+                 ;; status-lines : (listof status-line)
+                 [status-lines null]
+
+                 ;; status-line-msgs : (listof status-line-msg)
+                 [status-line-msgs null])
+          (define/override (make-root-area-container % parent)
+            (let* ([s-root (super make-root-area-container vertical-panel% parent)]
+                   [r-root (make-object % s-root)])
+              (set! status-line-container-panel
+                    (instantiate vertical-panel% ()
+                      (parent s-root)
+                      (stretchable-height #f)))
+              r-root))
+          (define/public (open-status-line id)
+            (do-main-thread
+             (λ ()
+               (when status-line-container-panel
+                 (set! status-lines
+                       (let loop ([status-lines status-lines])
+                         (cond
+                           [(null? status-lines)
+                            (list (make-status-line id 1))]
+                           [else (let ([status-line (car status-lines)])
+                                   (if (eq? id (status-line-id status-line))
+                                       (cons (make-status-line id (+ (status-line-count status-line) 1))
+                                             (cdr status-lines))
+                                       (cons status-line (loop (cdr status-lines)))))])))))))
+          
+          (define/public (close-status-line id)
+            (do-main-thread
+             (λ ()
+               (when status-line-container-panel
+                 
+                 ;; decrement counter in for status line, or remove it if
+                 ;; counter goes to zero.
+                 (set! status-lines
+                       (let loop ([status-lines status-lines])
+                         (cond
+                           [(null? status-lines) (error 'close-status-line "status line not open ~e" id)]
+                           [else (let* ([status-line (car status-lines)]
+                                        [this-line? (eq? (status-line-id status-line) id)])
+                                   (cond
+                                     [(and this-line? (= 1 (status-line-count status-line)))
+                                      (cdr status-lines)]
+                                     [this-line?
+                                      (cons (make-status-line id (- (status-line-count status-line) 1))
+                                            (cdr status-lines))]
+                                     [else (cons status-line (loop (cdr status-lines)))]))])))
+                 
+                 ;; make sure that there are only as many messages as different status lines, in total
+                 (let ([status-line-msg (find-status-line-msg id)])
+                   (when status-line-msg
+                     (send (status-line-msg-message status-line-msg) set-label "")
+                     (set-status-line-msg-id! status-line-msg #f)))
+                 (let* ([msgs-that-can-be-removed (filter (λ (x) (not (status-line-msg-id x))) status-line-msgs)]
+                        [max-to-include (length status-lines)]
+                        [msgs-to-remove
+                         (let loop ([n max-to-include]
+                                    [l msgs-that-can-be-removed])
+                           (cond
+                             [(null? l) l]
+                             [(zero? n) l]
+                             [else (loop (- n 1) (cdr l))]))])
+                   (send status-line-container-panel
+                         change-children
+                         (λ (old-children)
+                           (foldl (λ (status-line-msg l)
+                                    (remq (status-line-msg-message status-line-msg) l))
+                                  old-children
+                                  msgs-to-remove)))
+                   (set! status-line-msgs
+                         (let loop ([l msgs-to-remove]
+                                    [status-line-msgs status-line-msgs])
+                           (cond
+                             [(null? l) status-line-msgs]
+                             [else (loop (cdr l)
+                                         (remq (car l) status-line-msgs))]))))))))
+
+          ;; update-status-line : symbol (union #f string)
+          (define/public (update-status-line id msg-txt)
+            (do-main-thread
+             (λ ()
+               (unless (open-status-line? id)
+                 (error 'update-status-line "unknown id ~e, other arg ~e" id msg-txt))
+               (if msg-txt
+                   (cond
+                     [(find-status-line-msg id)
+                      =>
+                      (λ (existing-status-line-msg)
+                        (let ([msg (status-line-msg-message existing-status-line-msg)])
+                          (unless (equal? (send msg get-label) msg-txt)
+                            (send msg set-label msg-txt))))]
+                     [(find-available-status-line-msg)
+                      =>
+                      (λ (available-status-line-msg)
+                        (send (status-line-msg-message available-status-line-msg) set-label msg-txt)
+                        (set-status-line-msg-id! available-status-line-msg id))]
+                     [else
+                      (set! status-line-msgs
+                            (cons (make-new-status-line-msg id msg-txt)
+                                  status-line-msgs))])
+                   (let ([status-line-msg (find-status-line-msg id)])
+                     (when status-line-msg
+                       (send (status-line-msg-message status-line-msg) set-label "")
+                       (set-status-line-msg-id! status-line-msg #f)))))))
+          
+          ;; open-status-line? : symbol -> boolean
+          (define/private (open-status-line? id)
+            (let loop ([status-lines status-lines])
+              (cond
+                [(null? status-lines) #f]
+                [else
+                 (let ([status-line (car status-lines)])
+                   (or (eq? (status-line-id status-line) id)
+                       (loop (cdr status-lines))))])))
+
+          ;; find-available-status-line-msg : -> (union #f status-line-msg)
+          (define/private (find-available-status-line-msg)
+            (let loop ([status-line-msgs status-line-msgs])
+              (cond
+                [(null? status-line-msgs) #f]
+                [else (let ([status-line-msg (car status-line-msgs)])
+                        (if (status-line-msg-id status-line-msg)
+                            (loop (cdr status-line-msgs))
+                            status-line-msg))])))
+
+          ;; find-status-line-msg : symbol -> (union #f status-line-msg)
+          (define/private (find-status-line-msg id)
+            (let loop ([status-line-msgs status-line-msgs])
+              (cond
+                [(null? status-line-msgs) #f]
+                [else (let ([status-line-msg (car status-line-msgs)])
+                        (if (eq? id (status-line-msg-id status-line-msg))
+                            status-line-msg
+                            (loop (cdr status-line-msgs))))])))
+          
+          ;; make-new-status-line-msg : symbol string -> status-line-msg
+          (define/private (make-new-status-line-msg id msg-txt)
+            (make-status-line-msg
+             (instantiate message% ()
+               (parent status-line-container-panel)
+               (stretchable-width #t)
+               (label msg-txt))
+             id))
+                    
+          (field [eventspace-main-thread (current-thread)]) ;; replace by using new primitive in 203.5 called eventspace-main-thread
+          (inherit get-eventspace)
+          (define/private (do-main-thread t)
+            (if (eq? (current-thread) eventspace-main-thread)
+                (t)
+                (parameterize ([current-eventspace (get-eventspace)])
+                  ;; need high priority callbacks to ensure ordering wrt other callbacks
+                  (queue-callback t #t))))
+          
+	  (super-instantiate ())))
+      
+      (define info<%> (interface (basic<%>)
+                        determine-width
+                        lock-status-changed
+                        update-info
+                        set-info-canvas
+                        get-info-canvas
+                        get-info-editor
+                        get-info-panel
+                        show-info
+                        hide-info
+                        is-info-hidden?))
+      
+      (define magic-space 25)
+
+      (define info-mixin
+        (mixin (basic<%>) (info<%>)
+          [define rest-panel 'uninitialized-root]
+          [define super-root 'uninitialized-super-root]
+          (define/override (make-root-area-container % parent)
+            (let* ([s-root (super make-root-area-container
+                                  vertical-panel%
+                                  parent)]
+                   [r-root (make-object % s-root)])
+              (set! super-root s-root)
+              (set! rest-panel r-root)
+              r-root))
+          
+          [define info-canvas #f]
+          (public get-info-canvas set-info-canvas get-info-editor)
+          [define get-info-canvas
+           (λ ()
+             info-canvas)]
+          [define set-info-canvas
+           (λ (c)
+             (set! info-canvas c))]
+          [define get-info-editor
+           (λ ()
+             (and info-canvas
+                  (send info-canvas get-editor)))]
+          
+          (public determine-width)
+          [define determine-width
+            (λ (string canvas edit)
+              (send edit set-autowrap-bitmap #f)
+              (send canvas call-as-primary-owner
+                    (λ ()
+                      (let ([lb (box 0)]
+                            [rb (box 0)])
+                        (send edit erase)
+                        (send edit insert string)
+                        (send edit position-location 
+                              (send edit last-position)
+                              rb)
+                        (send edit position-location 0 lb)
+                        (send canvas min-width 
+                              (+ magic-space (- (inexact->exact (floor (unbox rb)))
+                                                (inexact->exact (floor (unbox lb))))))))))]
+          
+          [define outer-info-panel 'top-info-panel-uninitialized]
+          
+          ;; this flag is specific to this frame
+          ;; the true state of the info panel is
+          ;; the combination of this flag and the 
+          ;; the 'framework:show-status-line preference
+          ;; as shown in update-info-visibility
+          (define info-hidden? #f)
+          (define/public (hide-info)
+            (set! info-hidden? #t)
+            (update-info-visibility (preferences:get 'framework:show-status-line)))
+          (define/public (show-info)
+            (set! info-hidden? #f)
+            (update-info-visibility (preferences:get 'framework:show-status-line)))
+          (define/public (is-info-hidden?) info-hidden?)
+          (define/private (update-info-visibility pref-value)
+            (cond
+              [(or info-hidden? (not pref-value))
+               (send super-root change-children
+                     (λ (l)
+                       (if (memq outer-info-panel l)
+                           (begin (unregister-collecting-blit gc-canvas)
+                                  (list rest-panel))
+                           l)))]
+              [else
+               (send super-root change-children
+                     (λ (l)
+                       (if (memq outer-info-panel l)
+                           l
+                           (begin
+                             (register-gc-blit)
+                             (list rest-panel outer-info-panel)))))]))
+          
+          [define close-panel-callback
+            (preferences:add-callback
+             'framework:show-status-line
+             (λ (p v)
+               (update-info-visibility v)))]
+          (define memory-cleanup void) ;; only for checkouts and nightly build users; used with memory-text
+
+          (define/augment (on-close)
+            (unregister-collecting-blit gc-canvas)
+            (close-panel-callback)
+            (memory-cleanup)
+            (inner (void) on-close))
+          
+          (define icon-currently-locked? 'uninit)
+          (define/public (lock-status-changed)
+            (let ([info-edit (get-info-editor)])
+              (cond
+                [(not (object? lock-canvas))
+                 (void)]
+                [(is-a? info-edit editor:file<%>)
+                 (unless (send lock-canvas is-shown?)
+                   (send lock-canvas show #t))
+                 (let ([locked-now? (not (send info-edit get-read-write?))])
+                   (unless (eq? locked-now? icon-currently-locked?)
+                     (set! icon-currently-locked? locked-now?)
+                     (when (object? lock-canvas)
+                       (send lock-canvas set-locked locked-now?))))]
+                [else
+                 (when (send lock-canvas is-shown?)
+                   (send lock-canvas show #f))])))
+          
+          (public update-info)
+          [define update-info
+            (λ ()
+              (lock-status-changed))]
+          
+	  (super-new)
+          (set! outer-info-panel (make-object horizontal-panel% super-root))
+          (send outer-info-panel stretchable-height #f)
+          
+          [define info-panel (make-object horizontal-panel% outer-info-panel)]
+          (make-object grow-box-spacer-pane% outer-info-panel)
+          (public get-info-panel)
+          [define get-info-panel
+            (λ ()
+              info-panel)]
+          (public update-memory-text)
+          [define update-memory-text
+            (λ ()
+              (when show-memory-text?
+                (send memory-text begin-edit-sequence)
+                (send memory-text lock #f)
+                (send memory-text erase)
+                (send memory-text insert (format-number (current-memory-use)))
+                (send memory-text lock #t)
+                (send memory-text end-edit-sequence)))]
+          
+          (define/private (format-number n)
+            (let loop ([n n])
+              (cond
+                [(<= n 1000) (number->string n)]
+                [else
+                 (string-append 
+                  (loop (quotient n 1000))
+                  ","
+                  (pad-to-3 (modulo n 1000)))])))
+
+          (define/private (pad-to-3 n)
+            (cond
+              [(<= n 9) (format "00~a" n)]
+              [(<= n 99) (format "0~a" n)]
+              [else (number->string n)]))
+          
+            ; only for checkouts and nightly build users
+          (when show-memory-text?
+            (let* ([panel (make-object horizontal-panel% (get-info-panel) '(border))]
+                   [button (make-object button% (string-constant collect-button-label) panel 
+                             (λ x
+                               (collect-garbage)
+                               (update-memory-text)))]
+                   [ec (make-object editor-canvas% panel memory-text '(no-hscroll no-vscroll))])
+              (determine-width "0,000,000,000" ec memory-text)
+              (update-memory-text)
+              (set! memory-cleanup
+                    (λ ()
+                      (send ec set-editor #f)))
+              (send panel stretchable-width #f)))
+
+          [define lock-canvas (make-object lock-canvas% (get-info-panel))]
+          [define gc-canvas (make-object bday-click-canvas% (get-info-panel) '(border))]
+          (define/private (register-gc-blit)
+            (let ([onb (icon:get-gc-on-bitmap)]
+                  [offb (icon:get-gc-off-bitmap)])
+              (when (and (send onb ok?)
+                         (send offb ok?))
+                (register-collecting-blit gc-canvas 
+                                          0 0
+                                          (send onb get-width)
+                                          (send onb get-height)
+                                          onb offb))))
+          
+          (unless (preferences:get 'framework:show-status-line)
+            (send super-root change-children
+                  (λ (l)
+                    (list rest-panel))))
+          (register-gc-blit)
+            
+          (let* ([gcb (icon:get-gc-on-bitmap)]
+                 [gc-width (if (send gcb ok?)
+                               (send gcb get-width)
+                               10)]
+                 [gc-height (if (send gcb ok?)
+                                (send gcb get-height)
+                                10)])
+            (send* gc-canvas
+              (min-client-width (max (send gc-canvas min-width) gc-width))
+              (min-client-height (max (send gc-canvas min-height) gc-height))
+              (stretchable-width #f)
+              (stretchable-height #f)))
+          (send* (get-info-panel) 
+            (set-alignment 'right 'center)
+            (stretchable-height #f)
+            (spacing 3)
+            (border 3))))
+      
+      (define text-info<%> (interface (info<%>)
+                             set-macro-recording
+                             overwrite-status-changed
+                             anchor-status-changed
+                             editor-position-changed))
+      (define text-info-mixin
+        (mixin (info<%>) (text-info<%>)
+          (inherit get-info-editor)
+          [define remove-first
+            (preferences:add-callback
+             'framework:col-offsets
+             (λ (p v)
+               (editor-position-changed-offset/numbers
+                v
+                (preferences:get 'framework:display-line-numbers))
+               #t))]
+          [define remove-second
+            (preferences:add-callback
+             'framework:display-line-numbers
+             (λ (p v)
+               (editor-position-changed-offset/numbers
+                (preferences:get 'framework:col-offsets)
+                v)
+               #t))]
+          (define/augment (on-close)
+            (remove-first)
+            (remove-second)
+            (inner (void) on-close))
+          [define last-start #f]
+          [define last-end #f]
+          [define last-params #f]
+          (define/private (editor-position-changed-offset/numbers offset? line-numbers?)
+            (let* ([edit (get-info-editor)]
+                   [make-one
+                    (λ (pos)
+                      (let* ([line (send edit position-paragraph pos)]
+                             [col (find-col edit line pos)])
+                        (if line-numbers?
+                            (format "~a:~a"
+                                    (add1 line)
+                                    (if offset?
+                                        (add1 col)
+                                        col))
+                            (format "~a" pos))))])
+              (cond
+                [(not (object? position-canvas))
+                 (void)]
+                [edit
+                 (unless (send position-canvas is-shown?)
+                   (send position-canvas show #t))
+                 (let ([start (send edit get-start-position)]
+                       [end (send edit get-end-position)])
+                   (unless (and last-start
+                                (equal? last-params (list offset? line-numbers?))
+                                (= last-start start)
+                                (= last-end end))
+                     (set! last-params (list offset? line-numbers?))
+                     (set! last-start start)
+                     (set! last-end end)
+                     (when (object? position-edit)
+                       (send* position-edit
+                         (lock #f)
+                         (erase)
+                         (insert 
+                          (if (= start end)
+                              (make-one start)
+                              (string-append (make-one start)
+                                             "-"
+                                             (make-one end))))
+                         (lock #t)))))]
+                [else
+                 (when (send position-canvas is-shown?)
+                   (send position-canvas show #f))])))
+          
+          ;; find-col : text number number -> number
+          ;; given a line number and a position, finds the
+          ;; column number for that position
+          (define/private (find-col text line pos)
+            (let ([line-start (send text paragraph-start-position line)])
+              (if (= line-start pos)
+                  0
+                  (let loop ([col 0]
+                             [snip (send text find-snip line-start 'after-or-none)])
+                    (cond
+                      [(and snip (is-a? snip tab-snip%))
+                       ;; assume cursor isn't in the middle of the tab snip
+                       ;; and that there is no tab array
+                       (let ([twb (box 0)])
+                         (send text get-tabs #f twb #f)
+                         (let ([tw (floor (inexact->exact (unbox twb)))])
+                           (loop (+ col (- tw (modulo col tw)))
+                                 (send snip next))))]
+                      [snip 
+                       (let ([snip-position (send text get-snip-position snip)]
+                             [snip-length (send snip get-count)])
+                         (if (<= snip-position pos (+ snip-position snip-length))
+                             (+ col (- pos snip-position))
+                             (loop (+ col snip-length)
+                                   (send snip next))))]
+                      [else
+                       col])))))
+                  
+
+          [define anchor-last-state? #f]
+          [define overwrite-last-state? #f]
+          
+          (field (macro-recording? #f))
+          (define/private (update-macro-recording-icon)
+            (unless (eq? (send macro-recording-message is-shown?)
+                         macro-recording?)
+              (send macro-recording-message show macro-recording?)))
+          (define/public (set-macro-recording on?)
+            (set! macro-recording? on?)
+            (update-macro-recording-icon))
+
+          (define/public (anchor-status-changed)
+            (let ([info-edit (get-info-editor)]
+                  [failed
+                   (λ ()
+                     (unless (eq? anchor-last-state? #f)
+                       (set! anchor-last-state? #f)
+                       (send anchor-message show #f)))])
+              (cond
+                [info-edit
+                 (let ([anchor-now? (send info-edit get-anchor)])
+                   (unless (eq? anchor-now? anchor-last-state?)
+                     (cond
+                       [(object? anchor-message)
+                        (send anchor-message
+                              show
+                              anchor-now?)
+                        (set! anchor-last-state? anchor-now?)]
+                       [else (failed)])))]
+                [else
+                 (failed)])))
+          (define/public (editor-position-changed)
+            (editor-position-changed-offset/numbers
+             (preferences:get 'framework:col-offsets)
+             (preferences:get 'framework:display-line-numbers)))
+            [define/public overwrite-status-changed
+             (λ ()
+               (let ([info-edit (get-info-editor)]
+                     [failed
+                      (λ ()
+                        (set! overwrite-last-state? #f)
+                        (send overwrite-message show #f))])
+                 (cond
+                   [info-edit
+                    (let ([overwrite-now? (send info-edit get-overwrite-mode)])
+                      (unless (eq? overwrite-now? overwrite-last-state?)
+                        (cond
+                          [(object? overwrite-message)
+                           (send overwrite-message
+                                 show
+                                 overwrite-now?)
+                           (set! overwrite-last-state? overwrite-now?)]
+                          [else
+                           (failed)])))]
+                   [else
+                    (failed)])))]
+          (define/override (update-info)
+            (super update-info)
+            (update-macro-recording-icon)
+            (overwrite-status-changed)
+            (anchor-status-changed)
+            (editor-position-changed))
+	  (super-new)
+          
+          (inherit get-info-panel)
+          
+          [define anchor-message
+            (make-object message%
+              (let ([b (icon:get-anchor-bitmap)])
+                (if (and #f (send b ok?))
+                    b
+                    (string-constant auto-extend-selection)))
+              (get-info-panel))]
+          [define overwrite-message 
+           (make-object message%
+             (string-constant overwrite)
+             (get-info-panel))]
+          [define position-canvas (make-object editor-canvas% (get-info-panel) #f '(no-hscroll no-vscroll))]
+          [define position-edit (make-object text%)]
+          
+          
+          (define macro-recording-message
+            (instantiate message% ()
+              (label "c-x;(")
+              (parent (get-info-panel))))
+          
+          (inherit determine-width)
+          (let ([move-front
+                 (λ (x l)
+                   (cons x (remq x l)))])
+            (send (get-info-panel) change-children
+                  (λ (l)
+                    (move-front
+                     macro-recording-message
+                     (move-front
+                      anchor-message
+                      (move-front
+                       overwrite-message
+                       (move-front
+                        position-canvas
+                        l)))))))
+          (send macro-recording-message show #f)
+          (send anchor-message show #f)
+          (send overwrite-message show #f)
+          (send* position-canvas
+            (set-line-count 1)
+            (set-editor position-edit)
+            (stretchable-width #f)
+            (stretchable-height #f))
+          (determine-width "0000:000-0000:000"
+                           position-canvas
+                           position-edit)
+          (editor-position-changed)
+          (send position-edit hide-caret #t)
+          (send position-edit lock #t)))
+      
+      (define pasteboard-info<%> (interface (info<%>)))
+      (define pasteboard-info-mixin
+        (mixin (basic<%>) (pasteboard-info<%>)
+          (super-instantiate ())))
+      
+      (include "standard-menus.ss")
+      
+      (define -editor<%> (interface (standard-menus<%>)
+                           get-entire-label
+                           get-label-prefix
+                           set-label-prefix
+                           
+                           get-canvas%
+                           get-canvas<%>
+                           get-editor%
+                           get-editor<%>
+                           
+                           make-editor
+                           revert
+                           save
+                           save-as
+                           get-canvas
+                           get-editor))
+      
+      (define editor-mixin
+        (mixin (standard-menus<%>) (-editor<%>)
+          (init (filename #f))
+
+          (inherit get-area-container get-client-size 
+                   show get-edit-target-window get-edit-target-object)
+          
+          (define/override get-filename
+            (case-lambda
+             [() (get-filename #f)]
+             [(b)
+              (let ([e (get-editor)])
+                (and e (send e get-filename b)))]))
+          
+          (define/override (editing-this-file? filename)
+            (let ([path-equal?
+                   (λ (x y)
+                     (equal? (normal-case-path (normalize-path x))
+                             (normal-case-path (normalize-path y))))])
+              (let ([this-fn (get-filename)])
+                (and this-fn
+                     (path-equal? filename (get-filename))))))
+          
+          (define/augment (on-close)
+            (send (get-editor) on-close)
+            (inner (void) on-close))
+          
+          (define/augment (can-close?)
+            (and (send (get-editor) can-close?)
+                 (inner #t can-close?)))
+          
+          [define label ""]
+          [define label-prefix (application:current-app-name)]
+          (define/private (do-label)
+            (super set-label (gui-utils:trim-string (get-entire-label) 200))
+            (send (group:get-the-frame-group) frame-label-changed this))
+          
+          (public get-entire-label get-label-prefix set-label-prefix)
+          [define get-entire-label
+            (λ ()
+              (cond
+                [(string=? "" label)
+                 label-prefix]
+                [(string=? "" label-prefix)
+                 label]
+                [else 
+                 (string-append label " - " label-prefix)]))]
+          [define get-label-prefix (λ () label-prefix)]
+          [define set-label-prefix
+           (λ (s)
+             (when (and (string? s)
+                        (not (string=? s label-prefix)))
+               (set! label-prefix s)
+               (do-label)))]
+          [define/override get-label (λ () label)]
+          [define/override set-label
+            (λ (t)
+              (when (and (string? t)
+                         (not (string=? t label)))
+                (set! label t)
+                (do-label)))]
+
+          (define/public (get-canvas%) editor-canvas%)
+          (define/public (get-canvas<%>) (class->interface editor-canvas%))
+          (define/public (make-canvas)
+            (let ([% (get-canvas%)]
+                  [<%> (get-canvas<%>)])
+              (unless (implementation? % <%>)
+                (error 'frame:editor%
+                       "result of get-canvas% method must match ~e interface; got: ~e"
+                       <%> %))
+              (instantiate % () (parent (get-area-container)))))
+          (define/public (get-editor%)
+	    (error 'editor-frame% "abstract method: no editor% class specified"))
+          (define/public (get-editor<%>)
+	    editor:basic<%>)
+          (define/public (make-editor)
+	    (let ([% (get-editor%)]
+		  [<%> (get-editor<%>)])
+	      (unless (implementation? % <%>)
+		(error 'frame:editor%
+		       "result of get-editor% method must match ~e interface; got: ~e"
+		       <%> %))
+	      (make-object %)))
+          
+          (define/public save
+            (opt-lambda ([format 'same])
+              (let* ([ed (get-editor)]
+                     [filename (send ed get-filename)])
+                (if filename
+                    (send ed save-file/gui-error filename format)
+                    (save-as format)))))
+          
+          (define/public save-as
+            (opt-lambda ([format 'same])
+              (let* ([editor (get-editor)]
+                     [name (send editor get-filename)])
+                (let-values ([(base name)
+                              (if name 
+                                  (let-values ([(base name dir?) (split-path name)])
+                                    (values base name))
+                                  (values #f #f))])
+                  (let ([file (send editor put-file base name)])
+                    (if file
+                        (send editor save-file/gui-error file format)
+                        #f))))))
+          
+          (define/private (basename str)
+            (let-values ([(base name dir?) (split-path str)])
+              base))
+          
+          (inherit get-checkable-menu-item% get-menu-item%)
+          
+          (define/override (file-menu:revert-on-demand item)
+            (send item enable (not (send (get-editor) is-locked?))))
+
+          (define/override file-menu:revert-callback 
+            (λ (item control)
+              (let* ([edit (get-editor)]
+                     [b (box #f)]
+                     [filename (send edit get-filename b)])
+                (if (or (not filename) 
+                        (unbox b))
+                    (bell)
+                    (when (gui-utils:get-choice
+                           (string-constant are-you-sure-revert)
+                           (string-constant yes)
+                           (string-constant no)
+                           (string-constant are-you-sure-revert-title)
+                           #f
+                           this)
+                      (revert))))
+              #t))
+          
+          (define/public (revert)
+            (let* ([edit (get-editor)]
+                   [b (box #f)]
+                   [filename (send edit get-filename b)])
+              (when (and filename
+                         (not (unbox b)))
+                (let ([start
+                       (if (is-a? edit text%)
+                           (send edit get-start-position)
+                           #f)])
+                  (send edit begin-edit-sequence)
+                  (let ([status (send edit load-file/gui-error
+                                      filename
+                                      'same
+                                      #f)])
+                    (if status
+                        (begin
+                          (when (is-a? edit text%)
+                            (send edit set-position start start))
+                          (send edit end-edit-sequence))
+                        (send edit end-edit-sequence)))))))
+          
+          (define/override file-menu:create-revert? (λ () #t))
+          (define/override file-menu:save-callback
+            (λ (item control)
+              (save)
+              #t))
+          
+          (define/override file-menu:create-save? (λ () #t))
+          (define/override file-menu:save-as-callback (λ (item control) (save-as) #t))
+          (define/override file-menu:create-save-as? (λ () #t))
+          (define/override file-menu:print-callback (λ (item control)
+                                             (send (get-editor) print
+                                                   #t
+                                                   #t
+                                                   (preferences:get 'framework:print-output-mode))
+                                             #t))
+          (define/override file-menu:create-print? (λ () #t))
+          
+          (define/override edit-menu:between-select-all-and-find
+           (λ (edit-menu)
+             (let* ([c% (get-checkable-menu-item%)]
+                    [on-demand
+                     (λ (menu-item)
+                       (let ([edit (get-edit-target-object)])
+                         (if (and edit (is-a? edit editor<%>))
+                             (begin
+                               (send menu-item enable #t)
+                               (send menu-item check (send edit auto-wrap)))
+                             (begin 
+                               (send menu-item check #f)
+                               (send menu-item enable #f)))))]
+                    [callback
+                     (λ (item event)
+                       (let ([edit (get-edit-target-object)])
+                         (when (and edit
+                                    (is-a? edit editor<%>))
+                           (let ([new-pref (not (send edit auto-wrap))])
+                             (preferences:set 'framework:auto-set-wrap? new-pref)
+                             (send edit auto-wrap new-pref)))))])
+               (make-object c% (string-constant wrap-text-item)
+                 edit-menu callback #f #f on-demand))
+             
+             (make-object separator-menu-item% edit-menu)))
+          
+          (define/override help-menu:about-callback 
+            (λ (menu evt) 
+              (message-box (application:current-app-name)
+                           (format (string-constant welcome-to-something)
+                                   (application:current-app-name))
+                           #f
+                           '(ok app))))
+          (define/override help-menu:about-string (λ () (application:current-app-name)))
+          (define/override help-menu:create-about? (λ () #t))
+          
+	  (super-new (label (get-entire-label)))
+          
+          (define canvas #f)
+          (define editor #f)
+          (public get-canvas get-editor)
+          (define get-canvas 
+            (λ () 
+              (unless canvas
+                (set! canvas (make-canvas))
+                (send canvas set-editor (get-editor)))
+              canvas))
+          (define get-editor 
+            (λ () 
+              (unless editor
+                (set! editor (make-editor))
+                (send (get-canvas) set-editor editor))
+              editor))
+
+	  (cond
+	    [(and filename (file-exists? filename))
+	     (let ([ed (get-editor)])
+	       (send ed begin-edit-sequence)
+	       (send ed load-file/gui-error filename 'guess)
+	       (send ed end-edit-sequence))]
+	    [filename
+	     (send (get-editor) set-filename filename)]
+	    [else (void)])
+
+          (let ([ed-fn (send (get-editor) get-filename)])
+            (set! label (or (and ed-fn 
+                                 (path->string (file-name-from-path ed-fn)))
+                            (send (get-editor) get-filename/untitled-name))))
+          (do-label)
+          (let ([canvas (get-canvas)])
+            (when (is-a? canvas editor-canvas%)
+              ;; when get-canvas is overridden,
+              ;; it might not yet be implemented
+              (send canvas focus)))))
+      
+      (define open-here<%>
+        (interface (-editor<%>)
+          get-open-here-editor
+	  open-here))
+      
+      (define open-here-mixin
+        (mixin (-editor<%>) (open-here<%>)
+
+          (define/override (file-menu:new-on-demand item)
+            (super file-menu:new-on-demand item)
+            (send item set-label (if (preferences:get 'framework:open-here?)
+                                     (string-constant new-...-menu-item)
+                                     (string-constant new-menu-item))))
+          
+          (define/override (file-menu:new-callback item event)
+            (cond
+              [(preferences:get 'framework:open-here?)
+               (let ([clear-current (ask-about-new-here)])
+                 (cond
+                   [(eq? clear-current 'cancel) (void)]
+                   [clear-current
+                    (let* ([editor (get-editor)]
+                           [canceled? (cancel-due-to-unsaved-changes editor)])
+                      (unless canceled?
+                        (send editor begin-edit-sequence)
+                        (send editor lock #f)
+                        (send editor set-filename #f)
+                        (send editor erase)
+                        (send editor set-modified #f)
+                        (send editor clear-undos)
+                        (send editor end-edit-sequence)))]
+                   [else ((handler:current-create-new-window) #f)]))]
+              [else ((handler:current-create-new-window) #f)]))
+
+          ;; cancel-due-to-unsaved-changes : -> boolean
+          ;; returns #t if the action should be cancelled
+          (define/private (cancel-due-to-unsaved-changes editor)
+            (and (send editor is-modified?)
+                 (let ([save (gui-utils:unsaved-warning
+                              (or (send editor get-filename) (get-label))
+                              (string-constant clear-anyway)
+                              #t
+                              this)])
+                   (case save
+                     [(continue) #f]
+                     [(save) (not (send editor save-file/gui-error))]
+                     [(cancel) #t]))))
+          
+          ;; ask-about-new-here : -> (union 'cancel boolean?)
+          ;; prompts the user about creating a new window
+          ;; or "reusing" the current one.
+          (define/private (ask-about-new-here)
+            (gui-utils:get-choice
+             (string-constant create-new-window-or-clear-current)
+             (string-constant clear-current)
+             (string-constant new-window)
+             (string-constant warning)
+             'cancel
+             this))
+ 
+          (define/override (file-menu:open-on-demand item)
+            (super file-menu:open-on-demand item)
+            (send item set-label (if (preferences:get 'framework:open-here?)
+                                     (string-constant open-here-menu-item)
+                                     (string-constant open-menu-item))))
+          
+	  (define/augment (on-close)
+	    (let ([group (group:get-the-frame-group)])
+	      (when (eq? this (send group get-open-here-frame))
+		(send group set-open-here-frame #f)))
+	    (inner (void) on-close))
+
+          (define/override (on-activate on?)
+            (super on-activate on?)
+            (when on?
+              (send (group:get-the-frame-group) set-open-here-frame this)))
+          
+          (inherit get-editor)
+          (define/public (get-open-here-editor) (get-editor))
+          (define/public (open-here filename)
+            (let* ([editor (get-open-here-editor)]
+                   [okay-to-switch? (user-okays-switch? editor)])
+              (when okay-to-switch?
+                (when (is-a? editor text%)
+                  (let* ([b (box #f)]
+                         [filename (send editor get-filename b)])
+                    (unless (unbox b)
+                      (when filename
+                        (handler:set-recent-position 
+                         filename 
+                         (send editor get-start-position)
+                         (send editor get-end-position))))))
+                (send editor begin-edit-sequence)
+                (send editor lock #f)
+                (send editor load-file/gui-error filename)
+                (send editor end-edit-sequence)
+		(void))))
+          
+          (inherit get-label)
+          (define/private (user-okays-switch? ed)
+            (or (not (send ed is-modified?))
+                (let ([answer
+                       (gui-utils:unsaved-warning 
+                        (or (send ed get-filename) (get-label))
+                        (string-constant switch-anyway)
+                        #t)])
+                  (case answer
+                    [(continue)
+                     #t]
+                    [(save) 
+                     (send ed save-file/gui-error)]
+                    [(cancel)
+                     #f]))))
+            
+	  (super-new)))
+
+      (define text<%> (interface (-editor<%>)))
+      (define text-mixin
+        (mixin (-editor<%>) (text<%>)
+          (define/override (get-editor<%>) (class->interface text%))
+          (define/override (get-editor%) text:keymap%)
+          (super-new)))
+      
+      (define pasteboard<%> (interface (-editor<%>)))
+      (define pasteboard-mixin
+        (mixin (-editor<%>) (pasteboard<%>)
+          [define/override get-editor<%> (λ () (class->interface pasteboard%))]
+          [define/override get-editor% (λ () pasteboard:keymap%)]
+          (super-new)))
+      
+      (define delegate<%>
+        (interface (status-line<%> text<%>)
+          get-delegated-text
+          delegated-text-shown?
+          hide-delegated-text
+          show-delegated-text
+          delegate-moved))
+      
+      (define delegatee-editor-canvas%
+        (class editor-canvas%
+          (init-field delegate-frame)
+          (inherit get-editor get-dc)
+          
+          (define/override (on-event evt)
+            (super on-event evt)
+            (when delegate-frame
+              (let ([text (get-editor)])
+                (when (is-a? text text%)
+                  (cond
+                    [(send evt button-down?)
+                     (let-values ([(editor-x editor-y)
+                                   (send text dc-location-to-editor-location 
+                                         (send evt get-x)
+                                         (send evt get-y))])
+                       (send delegate-frame click-in-overview 
+                             (send text find-position editor-x editor-y)))]
+                    [(or (send evt entering?)
+                         (send evt moving?))
+                     (let-values ([(editor-x editor-y)
+                                   (send text dc-location-to-editor-location 
+                                         (send evt get-x)
+                                         (send evt get-y))])
+                       (let* ([b (box #f)]
+                              [pos (send text find-position editor-x editor-y #f b)])
+                         (cond
+                           [(unbox b)
+                            (let* ([para (send text position-paragraph pos)]
+                                   [start-pos (send text paragraph-start-position para)]
+                                   [end-pos (send text paragraph-end-position para)])
+                              (send delegate-frame update-status-line 'plt:delegate
+                                    (send text get-text start-pos end-pos)))]
+                           [else
+                            (send delegate-frame update-status-line 'plt:delegate #f)])))]
+                    [(send evt leaving?)
+                     (send delegate-frame update-status-line 'plt:delegate #f)])))))
+          (super-instantiate ())))
+      
+      (define delegatee-text<%>
+        (interface ()
+          set-start/end-para))
+      
+      (define delegatee-text%
+        (class* text:basic% (delegatee-text<%>)
+          (inherit get-admin)
+          (define start-para #f)
+          (define end-para #f)
+          (define view-x-b (box 0))
+          (define view-width-b (box 0))
+          (inherit paragraph-start-position paragraph-end-position 
+                   position-location invalidate-bitmap-cache scroll-to-position
+                   get-visible-position-range position-paragraph
+                   last-position)
+
+          (define/override (on-new-string-snip)
+            (instantiate text:1-pixel-string-snip% ()))
+          
+          (define/override (on-new-tab-snip)
+            (instantiate text:1-pixel-tab-snip% ()))
+          
+          ;; set-start/end-para : (union (#f #f -> void) (number number -> void))
+          (define/public (set-start/end-para _start-para _end-para)
+            (unless (and (equal? _start-para start-para)
+                         (equal? _end-para end-para))
+              (let ([old-start-para start-para]
+                    [old-end-para end-para])
+                (cond
+                  [else
+                   (set! start-para _start-para)
+                   (set! end-para _end-para)])
+                
+                (when (and start-para end-para)
+                  
+                  (let-values ([(v-start v-end) (let ([bs (box 0)]
+                                                      [bf (box 0)])
+                                                  (get-visible-position-range bs bf)
+                                                  (values (unbox bs)
+                                                          (unbox bf)))])
+                    (let ([v-start-para (position-paragraph v-start)]
+                          [v-end-para (position-paragraph v-end)])
+                      (cond
+                        [(v-start-para . >= . start-para)
+                         (scroll-to-position (paragraph-start-position start-para))]
+                        [(v-end-para . <= . end-para)
+                         (scroll-to-position (paragraph-end-position end-para))]
+                        [else (void)]))))
+                
+                (when (and old-start-para old-end-para)
+                  (let-values ([(x y w h) (get-rectangle old-start-para old-end-para)])
+                    (when x
+                      (invalidate-bitmap-cache x y w h))))
+                (when (and start-para end-para)
+                  (let-values ([(x y w h) (get-rectangle start-para end-para)])
+                    (when x
+                      (invalidate-bitmap-cache x y w h)))))))
+
+          (define/override (on-paint before? dc left top right bottom dx dy draw-caret)
+            (super on-paint before? dc left top right bottom dx dy draw-caret)
+            (when (and before?
+                       start-para
+                       end-para)
+              (let ([old-pen (send dc get-pen)]
+                    [old-brush (send dc get-brush)])
+                (send dc set-pen
+                      (send the-pen-list find-or-create-pen "light blue" 1 'solid))
+                (send dc set-brush
+                      (send the-brush-list find-or-create-brush "light blue" 'solid))
+                (let-values ([(x y w h) (get-rectangle start-para end-para)])
+                  (when x
+                    (send dc draw-rectangle 
+                          (+ dx x)
+                          (+ dy y)
+                          w
+                          h)))
+                (send dc set-pen old-pen)
+                (send dc set-brush old-brush))))
+          
+          
+          ;; get-rectangle : number number -> 
+          ;;                (values (union #f number) (union #f number) (union #f number) (union #f number))
+          ;; computes the rectangle corresponding the input paragraphs
+          (define/private (get-rectangle start-para end-para)
+            (let ([start (get-line-y start-para #t)]
+                  [end (get-line-y end-para #f)]
+                  [admin (get-admin)])
+              (cond
+                [(not admin)
+                 (values #f #f #f #f)]
+                [(= 0 (last-position))
+                 (values #f #f #f #f)]
+                [else
+                 (send admin get-view view-x-b #f view-width-b #f)
+                 (send admin get-view view-x-b #f view-width-b #f)
+                 (values (unbox view-x-b)
+                         start
+                         (unbox view-width-b)
+                         (- end start))])))
+
+          (define/private (get-line-y para top?)
+            (let ([pos (paragraph-start-position para)]
+                  [b (box 0)])
+              (position-location pos #f b top? #f #t)
+              (unbox b)))
+	  (super-new)
+
+	  (inherit set-cursor)
+	  (set-cursor (make-object cursor% 'arrow))
+
+          (inherit set-line-spacing)
+          (set-line-spacing 0)))
+      
+      (define delegate-mixin
+        (mixin (status-line<%> text<%>) (delegate<%>)
+
+          (define/public (get-delegated-text) (get-editor))
+
+          [define rest-panel 'uninitialized-root]
+          [define super-root 'uninitialized-super-root]
+          [define/override make-root-area-container
+            (λ (% parent)
+              (let* ([s-root (super make-root-area-container
+                              horizontal-panel%
+                              parent)]
+                     [r-root (make-object % s-root)])
+                (set! super-root s-root)
+                (set! rest-panel r-root)
+                r-root))]
+
+	  (define/override (get-editor<%>)
+            text:delegate<%>)
+
+          (define/override (get-editor%)
+            (text:delegate-mixin (super get-editor%)))
+
+          (field (shown? (preferences:get 'framework:show-delegate?)))
+          (define/public (delegated-text-shown?) 
+            shown?)
+
+          (inherit close-status-line open-status-line)
+          (define/public (hide-delegated-text)
+            (close-status-line 'plt:delegate)
+            (set! shown? #f)
+            (send (get-delegated-text) set-delegate #f)
+            (send super-root change-children
+                  (λ (l) (list rest-panel))))
+          (define/public (show-delegated-text)
+            (open-status-line 'plt:delegate)
+            (set! shown? #t)
+            (send (get-delegated-text) set-delegate delegatee)
+            (send super-root change-children
+                  (λ (l) (list rest-panel delegate-ec))))
+
+          (define/public (click-in-overview pos)
+            (when shown?
+              (let* ([d-text (get-delegated-text)]
+                     [d-canvas (send d-text get-canvas)]
+                     [bx (box 0)]
+                     [by (box 0)])
+                (let-values ([(cw ch) (send d-canvas get-client-size)])
+                  (send d-text position-location pos bx by)
+                  (send d-canvas focus)
+                  (send d-canvas scroll-to 
+                        (- (unbox bx) (/ cw 2))
+                        (- (unbox by) (/ ch 2))
+                        cw
+                        ch
+                        #t)))))
+          
+          (define/public (delegate-moved)
+            (let ([startb (box 0)]
+                  [endb (box 0)]
+                  [delegate-text (get-delegated-text)])
+              (send delegate-text get-visible-position-range startb endb #f)
+              (send delegatee set-start/end-para
+                    (send delegate-text position-paragraph (unbox startb)) 
+                    (send delegate-text position-paragraph (unbox endb)))))
+
+          (define/public (get-delegatee) delegatee)
+
+	  (super-instantiate ())
+          
+          (define delegatee (instantiate delegatee-text% ()))
+          (define delegate-ec (instantiate delegatee-editor-canvas% ()
+                                (editor delegatee)
+                                (parent super-root)
+                                (delegate-frame this)
+                                (min-width 150)
+                                (stretchable-width #f)))
+          (inherit get-editor)
+          (if (preferences:get 'framework:show-delegate?)
+              (begin
+                (open-status-line 'plt:delegate)
+                (send (get-delegated-text) set-delegate delegatee)
+                (send super-root change-children
+                      (λ (l) (list rest-panel delegate-ec))))
+              (begin
+                (send (get-delegated-text) set-delegate #f)
+                (send super-root change-children (λ (l) (list rest-panel)))))))
+              
+      
+      (define (search-dialog frame)
+        (init-find/replace-edits)
+        (keymap:call/text-keymap-initializer
+         (λ ()
+           (let* ([to-be-searched-text (send frame get-text-to-search)]
+                  [to-be-searched-canvas (send to-be-searched-text get-canvas)]
+                  
+                  [allow-replace? (not (send to-be-searched-text is-locked?))]
+                  
+                  [dialog (make-object dialog% 
+                            (if allow-replace?
+                                (string-constant find-and-replace)
+                                (string-constant find))
+                            frame)]
+                  
+                  [copy-text
+                   (λ (from to)
+                     (send to erase)
+                     (let loop ([snip (send from find-first-snip)])
+                       (when snip
+                         (send to insert (send snip copy))
+                         (loop (send snip next)))))]
+                  
+                  [text-keymap/editor%
+                   (class text:keymap%
+                     (define/override (get-keymaps)
+                       (if (preferences:get 'framework:menu-bindings)
+                           (append (list (keymap:get-editor))
+                                   (super get-keymaps))
+                           (append (super get-keymaps)
+                                   (list (keymap:get-editor)))))
+                     (inherit set-styles-fixed)
+                     (super-new)
+                     (set-styles-fixed #t))]
+                  
+                  
+                  [find-panel (make-object horizontal-panel% dialog)]
+                  [find-message (make-object message% (string-constant find) find-panel)]
+                  [f-text (make-object text-keymap/editor%)]
+                  [find-canvas (make-object editor-canvas% find-panel f-text
+                                 '(hide-hscroll hide-vscroll))]
+                  
+                  [replace-panel (make-object horizontal-panel% dialog)]
+                  [replace-message (make-object message% (string-constant replace) replace-panel)]
+                  [r-text (make-object text-keymap/editor%)]
+                  [replace-canvas (make-object editor-canvas% replace-panel r-text
+                                    '(hide-hscroll hide-vscroll))]
+                  
+                  [button-panel (make-object horizontal-panel% dialog)]
+                  
+                  [update-texts
+                   (λ ()
+                     (send find-edit stop-searching)
+                     (copy-text f-text find-edit)
+                     (send find-edit start-searching)
+                     (copy-text r-text replace-edit))]
+                  
+                  [find-button (make-object button% (string-constant find) button-panel 
+                                 (λ x
+                                   (update-texts)
+                                   (send frame search-again))
+                                 '(border))]
+                  [replace-button (make-object button% (string-constant replace) button-panel
+                                    (λ x
+                                      (update-texts)
+                                      (send frame replace)))]
+                  [replace-and-find-button (make-object button% (string-constant replace&find-again)
+                                             button-panel
+                                             (λ x
+                                               (update-texts)
+                                               (send frame replace&search)))]
+                  [replace-to-end-button
+                   (make-object button% (string-constant replace-to-end) button-panel
+                     (λ x
+                       (update-texts)
+                       (send frame replace-all)))]
+                  
+                  [dock-button (make-object button%
+                                 (string-constant dock)
+                                 button-panel
+                                 (λ (btn evt)
+                                   (update-texts)
+                                   (preferences:set 'framework:search-using-dialog? #f)
+                                   (send frame unhide-search)))]
+                  
+                  [close
+                   (λ ()
+                     (when to-be-searched-canvas
+                       (send to-be-searched-canvas force-display-focus #f))
+                     (send dialog show #f))]
+                  
+                  [close-button (make-object button% (string-constant close) button-panel
+                                  (λ (x y)
+                                    (close)))]
+
+                  [remove-pref-callback
+                   (preferences:add-callback 
+                    'framework:search-using-dialog?
+                    (λ (p v)
+                      (unless v
+                        (close))))])
+             
+             (unless allow-replace?
+               (send button-panel change-children
+                     (λ (l)
+                       (remq
+                        replace-button
+                        (remq
+                         replace-and-find-button
+                         (remq 
+                          replace-to-end-button
+                          l)))))
+               (send dialog change-children
+                     (λ (l)
+                       (remq replace-panel l))))
+
+             (copy-text find-edit f-text)
+             (copy-text replace-edit r-text)
+             (send find-canvas min-width 400)
+             (send find-canvas set-line-count 2)
+             (send find-canvas stretchable-height #f)
+             (send find-canvas allow-tab-exit #t)
+             (send replace-canvas min-width 400)
+             (send replace-canvas set-line-count 2)
+             (send replace-canvas stretchable-height #f)
+             (send replace-canvas allow-tab-exit #t)
+             (let ([msg-width (max (send find-message get-width)
+                                   (send replace-message get-width))])
+               (send find-message min-width msg-width)
+               (send replace-message min-width msg-width))
+             (send find-canvas focus)
+             (send f-text set-position 0 (send f-text last-position))
+             (send button-panel set-alignment 'right 'center)
+             (send dialog center 'both)
+             (when to-be-searched-canvas
+               (send to-be-searched-canvas force-display-focus #t))
+             (send dialog show #t)
+             (remove-pref-callback)))))
+      
+      (define searchable<%> (interface (basic<%>)
+                              get-text-to-search
+                              hide-search
+                              unhide-search
+                              set-search-direction
+                              replace&search
+                              replace-all
+                              replace
+                              can-replace?
+                              toggle-search-focus
+                              move-to-search-or-search
+                              move-to-search-or-reverse-search
+                              search-again))
+      (define search-anchor 0)
+      (define searching-direction 'forward)
+      (define (set-searching-direction x) 
+        (unless (or (eq? x 'forward)
+                    (eq? x 'backward))
+          (error 'set-searching-direction "expected ~e or ~e, got ~e" 'forward 'backward x))
+        (set! searching-direction x))
+      
+      (define old-search-highlight void)
+      (define clear-search-highlight
+        (λ ()
+          (begin (old-search-highlight)
+                 (set! old-search-highlight void))))
+      (define reset-search-anchor
+        (let ([color (make-object color% "BLUE")])
+          (λ (edit)
+            (old-search-highlight)
+            (let ([position 
+                   (if (eq? 'forward searching-direction)
+                       (send edit get-end-position)
+                       (send edit get-start-position))])
+              (set! search-anchor position)
+              
+              ;; don't draw the anchor
+              '(set! old-search-highlight
+                     (send edit highlight-range position position color #f))))))
+      
+      (define find-string-embedded
+        (opt-lambda (edit
+                     str
+                     [direction 'forward]
+                     [start 'start]
+                     [end 'eof]
+                     [get-start #t]
+                     [case-sensitive? #t]
+                     [pop-out? #f])
+          (unless (member direction '(forward backward))
+            (error 'find-string-embedded
+                   "expected ~e or ~e as first argument, got: ~e" 'forward 'backward direction))
+          (let/ec k
+            (let* ([start (if (eq? start 'start) 
+                              (send edit get-start-position)
+                              start)]
+                   [end (if (eq? 'eof end)
+                            (if (eq? direction 'forward)
+                                (send edit last-position)
+                                0)
+                            end)]
+                   [flat (send edit find-string str direction
+                               start end get-start
+                               case-sensitive?)]
+                   [pop-out
+                    (λ ()
+                      (let ([admin (send edit get-admin)])
+                        (if (is-a? admin editor-snip-editor-admin<%>)
+                            (let* ([snip (send admin get-snip)]
+                                   [edit-above (send (send snip get-admin) get-editor)]
+                                   [pos (send edit-above get-snip-position snip)]
+                                   [pop-out-pos (if (eq? direction 'forward) (add1 pos) pos)])
+                              (find-string-embedded
+                               edit-above
+                               str
+                               direction 
+                               pop-out-pos
+                               (if (eq? direction 'forward) 'eof 0)
+                               get-start
+                               case-sensitive?
+                               pop-out?))
+                            (values edit #f))))])
+              (let loop ([current-snip (send edit find-snip start
+                                             (if (eq? direction 'forward)
+                                                 'after-or-none
+                                                 'before-or-none))])
+                (let ([next-loop
+                       (λ ()
+                         (if (eq? direction 'forward)
+                             (loop (send current-snip next))
+                             (loop (send current-snip previous))))])
+                  (cond
+                    [(or (not current-snip)
+                         (and flat
+                              (let* ([start (send edit get-snip-position current-snip)]
+                                     [end (+ start (send current-snip get-count))])
+                                (if (eq? direction 'forward)
+                                    (and (<= start flat)
+                                         (< flat end))
+                                    (and (< start flat)
+                                         (<= flat end))))))
+                     (if (and (not flat) pop-out?)
+                         (pop-out)
+                         (values edit flat))]
+                    [(is-a? current-snip editor-snip%)
+                     (let-values ([(embedded embedded-pos)
+                                   (let ([media (send current-snip get-editor)])
+                                     (if (and media
+                                              (is-a? media text%))
+                                         (begin
+                                           (find-string-embedded 
+                                            media 
+                                            str
+                                            direction
+                                            (if (eq? 'forward direction)
+                                                0
+                                                (send media last-position))
+                                            'eof
+                                            get-start case-sensitive?))
+                                         (values #f #f)))])
+                       (if (not embedded-pos)
+                           (next-loop)
+                           (values embedded embedded-pos)))]
+                    [else (next-loop)])))))))
+      
+      (define searching-frame #f)
+      (define (set-searching-frame frame)
+        (set! searching-frame frame))
+      
+      (define find-text%
+        (class text:keymap%
+          (inherit get-text)
+          (define/private (get-searching-edit)
+            (and searching-frame
+                 (send searching-frame get-text-to-search)))
+          (define/public search
+            (opt-lambda ([reset-search-anchor? #t] [beep? #t] [wrap? #t])
+              (when searching-frame
+                (let* ([string (get-text)]
+                       [top-searching-edit (get-searching-edit)]
+                       
+                       [searching-edit (let ([focus-snip (send top-searching-edit get-focus-snip)])
+                                         (if focus-snip
+                                             (send focus-snip get-editor)
+                                             top-searching-edit))]
+                       
+                       [not-found
+                        (λ (found-edit skip-beep?)
+                          (send found-edit set-position search-anchor)
+                          (when (and beep?
+                                     (not skip-beep?))
+                            (bell))
+                          #f)]
+                       [found
+                        (λ (edit first-pos)
+                          (let ([last-pos ((if (eq? searching-direction 'forward) + -)
+                                           first-pos (string-length string))])
+                            (send* edit 
+                              (set-caret-owner #f 'display)
+                              (set-position
+                               (min first-pos last-pos)
+                               (max first-pos last-pos)
+                               #f #t 'local))
+                            #t))])
+                  (if (string=? string "")
+                      (not-found top-searching-edit #t)
+                      (begin
+                        (when reset-search-anchor?
+                          (reset-search-anchor searching-edit))
+                        (let-values ([(found-edit first-pos)
+                                      (find-string-embedded
+                                       searching-edit
+                                       string
+                                       searching-direction
+                                       search-anchor
+                                       'eof #t #t #t)])
+                          (cond
+                            [(not first-pos)
+                             (if wrap?
+                                 (let-values ([(found-edit pos)
+                                               (find-string-embedded
+                                                top-searching-edit
+                                                string 
+                                                searching-direction
+                                                (if (eq? 'forward searching-direction)
+                                                    0
+                                                    (send searching-edit last-position)))])
+                                   (if (not pos)
+                                       (not-found found-edit #f)
+                                       (found found-edit pos)))
+                                 (not-found found-edit #f))]
+                            [else
+                             (found found-edit first-pos)]))))))))
+          (field
+           [dont-search #f])
+          (define/public (stop-searching)
+            (set! dont-search #t))
+          (define/public (start-searching)
+            (set! dont-search #f))
+          
+          (define/override (on-focus on?)
+            (when on?
+              (let ([edit (get-searching-edit)])
+                (when edit
+                  (reset-search-anchor (get-searching-edit)))))
+            (super on-focus on?))
+          (define/augment (after-insert x y)
+            (unless dont-search
+              (search #f))
+            (inner (void) after-insert x y))
+          (define/augment (after-delete x y)
+            (unless dont-search
+              (search #f))
+            (inner (void) after-delete x y))
+          (super-new)
+          (inherit set-styles-fixed)
+          (set-styles-fixed #t)))
+      
+      (define replace-text%
+        (class text:keymap%
+          (inherit set-styles-fixed)
+          (super-instantiate ())
+          (set-styles-fixed #t)))
+      
+      (define find-edit #f)
+      (define replace-edit #f)
+      
+      (define searchable-canvas% 
+        (class editor-canvas% 
+          (inherit get-top-level-window set-line-count)
+          (define/override (on-focus x)
+            (when x
+              (set-searching-frame (get-top-level-window)))
+            (super on-focus x))
+          (super-new (style '(hide-hscroll hide-vscroll)))
+          (set-line-count 2)))
+      
+      (define (init-find/replace-edits)
+        (unless find-edit
+          (set! find-edit (make-object find-text%))
+          (set! replace-edit (make-object replace-text%))
+          (for-each (λ (keymap)
+                      (send keymap chain-to-keymap
+                            (keymap:get-search)
+                            #t))
+                    (list (send find-edit get-keymap)
+                          (send replace-edit get-keymap)))))
+      
+      (define searchable-mixin
+        (mixin (standard-menus<%>) (searchable<%>)
+          (init-find/replace-edits)
+          (define super-root 'unitiaialized-super-root)
+          (define/override edit-menu:find-callback (λ (menu evt) (move-to-search-or-search) #t))
+          (define/override edit-menu:create-find? (λ () #t))
+          (define/override edit-menu:find-again-callback (λ (menu evt) (search-again) #t))
+          (define/override edit-menu:create-find-again? (λ () #t))
+          (define/override edit-menu:replace-and-find-again-callback (λ (menu evt) (replace&search) #t))
+          (define/override edit-menu:replace-and-find-again-on-demand
+            (λ (item) (send item enable (can-replace?))))
+          (define/override edit-menu:create-replace-and-find-again? (λ () #t))
+          (define/override make-root-area-container
+            (λ (% parent)
+              (let* ([s-root (super make-root-area-container
+                              vertical-panel%
+                              parent)]
+                     [root (make-object % s-root)])
+                (set! super-root s-root)
+                root)))
+
+          (define/override (on-activate on?)
+            (unless hidden?
+              (if on?
+                  (reset-search-anchor (get-text-to-search))
+                  (clear-search-highlight)))
+            (super on-activate on?))
+          
+          (define/public (get-text-to-search)
+	    (error 'get-text-to-search "abstract method in searchable-mixin"))
+          (define/public hide-search
+            (opt-lambda ([startup? #f])
+	      (when search-gui-built?
+		(send super-root change-children
+		      (λ (l)
+			(remove search-panel l))))
+              (clear-search-highlight)
+              (unless startup?
+                (let ([canvas (send (get-text-to-search) get-canvas)])
+                  (when canvas
+                    (send canvas force-display-focus #f)
+                    (send canvas focus))))
+              (set! hidden? #t)))
+          
+          (define/public (unhide-search)
+            (when (and hidden?
+                       (not (preferences:get 'framework:search-using-dialog?)))
+              (set! hidden? #f)
+
+	      (build-search-gui-in-frame)
+
+              (let ([canvas (send (get-text-to-search) get-canvas)])
+                (when canvas
+                  (send canvas force-display-focus #t)))
+              (show/hide-replace (send (get-text-to-search) is-locked?))
+              (send search-panel focus)
+              (send find-edit set-position 0 (send find-edit last-position))
+              (unless (memq search-panel (send super-root get-children))
+		(send super-root add-child search-panel))
+              (reset-search-anchor (get-text-to-search))))
+
+          (define/private (undock)
+            (preferences:set 'framework:search-using-dialog? #t)
+            (hide-search)
+            (search-dialog this))
+
+	  ;; pre-condition : search-gui-built? is #t
+          (define/private (show/hide-replace hide?)
+            (cond
+              [hide?
+               (send replace-canvas-panel change-children
+                     (λ (l) null))
+               (send replace-button-panel change-children (λ (l) null))
+               (send middle-middle-panel change-children (λ (l) null))]
+              [else
+               (send replace-canvas-panel change-children
+                     (λ (l) (list replace-canvas)))
+               (send replace-button-panel change-children
+                     (λ (l) (list replace-button)))
+               (send middle-middle-panel change-children
+                     (λ (l) (list replace&search-button
+                                       replace-all-button)))]))
+
+          (define remove-callback
+            (preferences:add-callback
+             'framework:search-using-dialog?
+             (λ (p v)
+               (when p
+                 (hide-search)))))
+          (define/augment (on-close)
+            (remove-callback)
+            (let ([close-canvas
+                   (λ (canvas edit)
+                     (send canvas set-editor #f))])
+              (when search-gui-built?
+                (close-canvas find-canvas find-edit)
+                (close-canvas replace-canvas replace-edit)))
+            (when (eq? this searching-frame)
+              (set-searching-frame #f))
+            (inner (void) on-close))
+          (public set-search-direction can-replace? replace&search replace-all replace
+                  toggle-search-focus move-to-search-or-search move-to-search-or-reverse-search
+                  search-again)
+          (define set-search-direction 
+            (λ (x) 
+              (set-searching-direction x)
+	      (when dir-radio
+		(send dir-radio set-selection (if (eq? x 'forward) 0 1)))))
+          (define can-replace?
+            (λ ()
+              (let ([tx (get-text-to-search)])
+                (and
+                 tx
+                 (not (= 0 (send replace-edit last-position)))
+                 (string=?
+                  (send tx get-text
+                        (send tx get-start-position)
+                        (send tx get-end-position))
+                  (send find-edit get-text 0 (send find-edit last-position)))))))
+          (define replace&search
+            (λ ()
+              (let ([text (get-text-to-search)])
+                (send text begin-edit-sequence)
+                (when (replace)
+                  (search-again))
+                (send text end-edit-sequence))))
+          (define (replace-all)
+            (let* ([replacee-edit (get-text-to-search)]
+                   [embeded-replacee-edit (find-embedded-focus-editor replacee-edit)]
+                   [pos (if (eq? searching-direction 'forward)
+                            (send embeded-replacee-edit get-start-position)
+                            (send embeded-replacee-edit get-end-position))]
+                   [done? (if (eq? 'forward searching-direction)
+                              (λ (x) (>= x (send replacee-edit last-position)))
+                              (λ (x) (<= x 0)))])
+              (send replacee-edit begin-edit-sequence)
+              (when (search-again)
+                (send embeded-replacee-edit set-position pos)
+                (let loop ()
+                  (when (send find-edit search #t #f #f)
+                    (replace)
+                    (loop))))
+              (send replacee-edit end-edit-sequence)))
+          (define (replace)
+            (let* ([search-text (send find-edit get-text)]
+                   [replacee-edit (find-embedded-focus-editor (get-text-to-search))]
+                   [replacee-start (send replacee-edit get-start-position)]
+                   [new-text (send replace-edit get-text)]
+                   [replacee (send replacee-edit get-text
+                                   replacee-start
+                                   (send replacee-edit get-end-position))])
+              (if (string=? replacee search-text)
+                  (begin (send replacee-edit insert new-text)
+                         (send replacee-edit set-position
+                               replacee-start
+                               (+ replacee-start (string-length new-text)))
+                         #t)
+                  #f)))
+
+          (define/private (find-embedded-focus-editor editor)
+            (let loop ([editor editor])
+              (let ([s (send editor get-focus-snip)])
+                (cond
+                  [(and s (is-a? s editor-snip%))
+                   (let ([next-ed (send s get-editor)])
+                     (if next-ed 
+                         (loop next-ed)
+                         editor))]
+                  [else editor]))))
+          
+          (define (toggle-search-focus)
+            (when find-canvas
+              (set-searching-frame this)
+              (unhide-search)
+              (send (cond
+                      [(send find-canvas has-focus?)
+                       replace-canvas]
+                      [(send replace-canvas has-focus?)
+                       (send (get-text-to-search) get-canvas)]
+                      [else
+                       find-canvas])
+                    focus)))
+          (define move-to-search-or-search
+            (λ ()
+              (set-searching-frame this)
+              (unhide-search)
+              (cond
+                [(preferences:get 'framework:search-using-dialog?)
+                 (search-dialog this)]
+                [else
+		 (if (or (send find-canvas has-focus?)
+			 (send replace-canvas has-focus?))
+		     (search-again 'forward)
+		     (send find-canvas focus))])))
+          (define move-to-search-or-reverse-search
+            (λ ()
+              (set-searching-frame this)
+              (unhide-search)
+              (cond
+                [(preferences:get 'framework:search-using-dialog?)
+                 (search-again 'backward)
+                 (set-searching-direction 'forward)]
+                [else
+		 (if (or (send find-canvas has-focus?)
+                         (send replace-canvas has-focus?))
+                     (search-again 'backward)
+                     (send find-canvas focus))])))
+          (define search-again
+            (opt-lambda ([direction searching-direction] [beep? #t])
+              (set-searching-frame this)
+              (unhide-search)
+              (set-search-direction direction)
+              (send find-edit search #t beep?)))
+          
+	  (define search-panel #f)
+	  (define search-gui-built? #f)
+          (define dir-radio #f)
+	  (define replace-canvas-panel #f)
+          (define find-canvas #f)
+	  (define replace-canvas #f)
+	  (define hidden? #t)
+	  (define replace-button-panel #f)
+	  (define middle-middle-panel #f)
+	  (define replace-button #f)
+	  (define replace&search-button #f)
+	  (define replace-all-button #f)
+	  
+	  (inherit begin-container-sequence end-container-sequence)
+	  (define/private (build-search-gui-in-frame)
+	    (unless search-gui-built?
+	      (set! search-gui-built? #t)
+	      (begin-container-sequence)
+	      (let ()
+		(define _0 (set! search-panel (make-object horizontal-panel% super-root '(border))))
+		(define left-panel (make-object vertical-panel% search-panel))
+		(define _1 (set! find-canvas (make-object searchable-canvas% left-panel)))
+		(define _2
+		  (set! replace-canvas-panel (instantiate vertical-panel% ()
+					       (parent left-panel)
+					       (stretchable-width #t)
+					       (stretchable-height #f))))
+		(define _3
+		  (set! replace-canvas (make-object searchable-canvas% replace-canvas-panel)))
+		
+		(define middle-left-panel (make-object vertical-pane% search-panel))
+		(define _4
+		  (set! middle-middle-panel (make-object vertical-pane% search-panel)))
+		(define middle-right-panel (make-object vertical-pane% search-panel))
+		
+		(define search-button (make-object button% 
+					(string-constant find)
+					middle-left-panel
+					(λ args (search-again))))
+		
+		(define _5
+		  (set! replace-button-panel
+			(instantiate vertical-panel% ()
+			  (parent middle-left-panel)
+			  (stretchable-width #f)
+			  (stretchable-height #f))))
+		
+		(define _6
+		  (set! replace-button (make-object button% (string-constant replace)
+						    replace-button-panel
+						    (λ x (replace)))))
+		
+		(define _7
+		  (set! replace&search-button (make-object button% 
+						(string-constant replace&find-again)
+						middle-middle-panel
+						(λ x (replace&search)))))
+		
+		(define _8
+		  (set! replace-all-button (make-object button% 
+					     (string-constant replace-to-end)
+					     middle-middle-panel
+					     (λ x (replace-all)))))
+		(define _9
+		  (set! dir-radio (make-object radio-box%
+				    #f
+				    (list (string-constant forward)
+					  (string-constant backward))
+				    middle-right-panel
+				    (λ (dir-radio evt)
+				      (let ([forward (if (= (send dir-radio get-selection) 0)
+							 'forward
+							 'backward)])
+					(set-search-direction forward)
+					(reset-search-anchor (get-text-to-search)))))))
+
+		(define hide/undock-pane (make-object horizontal-panel% middle-right-panel))
+		(define hide-button (make-object button% (string-constant hide)
+						 hide/undock-pane
+						 (λ args (hide-search))))
+		(define undock-button (make-object button% (string-constant undock)
+						   hide/undock-pane
+						   (λ args (undock))))
+		(let ([align
+		       (λ (x y)
+			 (let ([m (max (send x get-width)
+				       (send y get-width))])
+			   (send x min-width m)
+			   (send y min-width m)))])
+		  (align search-button replace-button)
+		  (align replace&search-button replace-all-button))
+		(for-each (λ (x) (send x set-alignment 'center 'center))
+			  (list middle-left-panel middle-middle-panel))
+		(for-each (λ (x) (send x stretchable-height #f))
+			  (list search-panel middle-left-panel middle-middle-panel middle-right-panel))
+		(for-each (λ (x) (send x stretchable-width #f))
+			  (list middle-left-panel middle-middle-panel middle-right-panel))
+		(send find-canvas set-editor find-edit)
+		(send find-canvas stretchable-height #t)
+		(send replace-canvas set-editor replace-edit))
+	      (end-container-sequence)))
+
+	  (super-instantiate ())
+
+	  (hide-search #t)))
+      
+      (define searchable-text<%> (interface (searchable<%> text<%>)))
+      
+      (define searchable-text-mixin
+        (mixin (text<%> searchable<%>) (searchable-text<%>)
+          (inherit get-editor)
+          (define/override (get-text-to-search)
+	    (get-editor))
+          (define/override (get-editor<%>) text:searching<%>)
+          (define/override (get-editor%) text:searching%)
+          (super-instantiate ())))
+      
+      (define memory-text% (class text% (super-new)))
+      (define memory-text (make-object memory-text%))
+      (send memory-text hide-caret #t)
+      (define show-memory-text?
+        (or (with-handlers ([exn:fail:filesystem?
+                             (λ (x) #f)])
+              (directory-exists? (collection-path "repos-time-stamp")))
+            (let ([fw (collection-path "framework")])
+              (with-handlers ([exn:fail:filesystem?
+                               (λ (x) #f)])
+                (or (directory-exists? (build-path fw ".svn"))
+                    (directory-exists? (build-path fw "CVS")))))))
+      
+      (define bday-click-canvas%
+        (class canvas%
+          (define/override (on-event evt)
+            (cond
+              [(and (mrf-bday?)
+                    (send evt button-up?))
+               (message-box (string-constant drscheme)
+                            (string-constant happy-birthday-matthew))]
+              [else (super on-event evt)]))
+          (super-instantiate ())))
+      
+      (define basic% (register-group-mixin (basic-mixin frame%)))
+      (define size-pref% (size-pref-mixin basic%))
+      (define info% (info-mixin basic%))
+      (define text-info% (text-info-mixin info%))
+      (define pasteboard-info% (pasteboard-info-mixin text-info%))
+      (define status-line% (status-line-mixin text-info%))
+      (define standard-menus% (standard-menus-mixin status-line%))
+      (define editor% (editor-mixin standard-menus%))
+      (define open-here% (open-here-mixin editor%))
+      
+      (define -text% (text-mixin open-here%))
+      (define searchable% (searchable-text-mixin (searchable-mixin -text%)))
+      (define delegate% (delegate-mixin searchable%))
+      
+      (define -pasteboard% (pasteboard-mixin open-here%)))))
diff --git a/collects/framework/private/gen-standard-menus.ss b/collects/framework/private/gen-standard-menus.ss
new file mode 100644
index 0000000000..dad38028df
--- /dev/null
+++ b/collects/framework/private/gen-standard-menus.ss
@@ -0,0 +1,186 @@
+
+(module gen-standard-menus mzscheme
+  (require (lib "pretty.ss"))
+  (require (lib "list.ss"))
+  (require "standard-menus-items.ss")
+  
+  ;; build-before-super-item-clause : an-item -> (listof clause)
+  (define build-before-super-item-clause
+    (λ (item)
+      (list
+       `[define/public ,(an-item->callback-name item) ,(an-item-proc item)]
+       `(define/public (,(an-item->get-item-name item))
+          ,(an-item->item-name item))
+       `(define/public (,(an-item->string-name item))
+          ,(an-item-menu-string item))
+       `(define/public (,(an-item->help-string-name item))
+          ,(an-item-help-string item))
+       `(define/public ,(an-item->on-demand-name item) ,(an-item-on-demand item))
+       `(define/public (,(an-item->create-menu-item-name item))
+          ,(an-item-create item)))))
+  
+  ;; build-before-super-clause : ((X -> sym) (X sexp) -> X -> (listof clause))
+  (define build-before-super-clause
+    (λ (->name -procedure)
+      (λ (obj)
+        (list `(define/public ,(->name obj)
+                 ,(case (-procedure obj)
+                    [(nothing) '(λ (menu) (void))]
+                    [(separator) '(λ (menu) (make-object separator-menu-item% menu))]
+                    [(nothing-with-standard-menus)
+                     '(λ (menu) 
+                        (unless (current-eventspace-has-standard-menus?)
+                          (make-object separator-menu-item% menu)))]
+                    [else (error 'gen-standard-menus "unknown between sym: ~e" (-procedure obj))]))))))
+  
+  ;; build-before-super-between-clause : between -> (listof clause)
+  (define build-before-super-between-clause
+    (build-before-super-clause
+     between->name
+     between-procedure))
+  
+  ;; build-before-super-before/after-clause : before/after -> (listof clause)
+  (define build-before-super-before/after-clause
+    (build-before-super-clause
+     before/after->name
+     before/after-procedure))
+  
+  ;; build-after-super-item-clause : an-item -> (list clause)
+  (define (build-after-super-item-clause item)
+    (let* ([callback-name (an-item->callback-name item)]
+           [create-menu-item-name (an-item->create-menu-item-name item)]
+           [callback-name-string (symbol->string callback-name)]
+           [key (an-item-key item)])
+      (list `(define
+               ,(an-item->item-name item)
+               (and (,create-menu-item-name)
+                    ,(if (a-submenu-item? item)
+                         `(instantiate (get-menu%) ()
+                           (label (,(an-item->string-name item)))
+                           (parent ,(menu-item-menu-name item))
+                           (help-string (,(an-item->help-string-name item)))
+                           (demand-callback (λ (menu-item) (,(an-item->on-demand-name item) menu-item))))
+                         `(instantiate (get-menu-item%) ()
+                           (label (,(an-item->string-name item)))
+                           (parent ,(menu-item-menu-name item))
+                           (callback (let ([,callback-name (λ (item evt) (,callback-name item evt))])
+                                       ,callback-name))
+                           (shortcut ,key)
+                           (help-string (,(an-item->help-string-name item)))
+                           (demand-callback (λ (menu-item) (,(an-item->on-demand-name item) menu-item))))))))))
+  
+  ;; build-after-super-clause : ((X -> symbol) -> X -> (listof clause))
+  (define build-after-super-clause
+    (λ (->name)
+      (λ (between/after)
+        (list 
+         `(,(->name between/after)
+           (,(menu-name->get-menu-name between/after)))))))
+  
+  ;; build-after-super-between-clause : between -> (listof clause)
+  (define build-after-super-between-clause (build-after-super-clause between->name))
+  ;; build-after-super-before/after-clause : before/after -> (listof clause)
+  (define build-after-super-before/after-clause (build-after-super-clause before/after->name))
+  
+  ;; build-after-super-generic-clause : generic -> (listof clause)
+  (define (build-after-super-generic-clause x) 
+    (cond
+      [(generic-private-field? x)
+       (list `(define
+                ,(generic-name x)
+                ,(generic-initializer x)))]
+      [(generic-override? x)
+       (list)]
+      [(generic-augment? x)
+       (list)]
+      [(generic-method? x)
+       null]))
+
+  ;; build-before-super-generic-clause : generic -> (listof clause)
+  (define (build-before-super-generic-clause generic)
+    (cond
+      [(generic-private-field? generic)
+       null]
+      [(generic-override? generic)
+       (list `(define/override ,(generic-name generic)
+                ,(generic-initializer generic)))]
+      [(generic-augment? generic)
+       (list `(define/augment ,(generic-name generic)
+                ,(generic-initializer generic)))]
+      [(generic-method? generic)
+       (list `(define/public ,(generic-name generic)
+                ,(generic-initializer generic)))]))
+  
+  
+  (define standard-menus.ss-filename (build-path (collection-path "framework" "private") "standard-menus.ss"))
+  (printf "writing to ~a~n" standard-menus.ss-filename)  
+  
+  (call-with-output-file standard-menus.ss-filename
+    (λ (port)
+      (pretty-print
+       `(define standard-menus<%>
+          (interface (basic<%>)
+            ,@(apply append (map
+                             (λ (x)
+                               (cond
+                                 [(an-item? x) 
+                                  (list 
+                                   (an-item->callback-name x)
+                                   (an-item->get-item-name x)
+                                   (an-item->string-name x)
+                                   (an-item->help-string-name x)
+                                   (an-item->on-demand-name x)
+                                   (an-item->create-menu-item-name x))]
+                                 [(between? x) (list (between->name x))]
+                                 [(or (after? x) (before? x))
+                                  (list (before/after->name x))]
+                                 [(generic? x) 
+                                  (if (generic-method? x)
+                                      (list (generic-name x))
+                                      null)])) 
+                             items))))
+       port)
+      
+      (newline port)
+      
+      (pretty-print
+       `(define standard-menus-mixin
+	  (mixin (basic<%>) (standard-menus<%>)
+	    (inherit on-menu-char on-traverse-char)
+	    
+	    (define remove-prefs-callback
+	      (preferences:add-callback
+	       'framework:menu-bindings
+	       (λ (p v)
+		 (let loop ([menu (get-menu-bar)])
+		   (when (is-a? menu menu:can-restore<%>)
+		     (if v
+			 (send menu restore-keybinding)
+			 (send menu set-shortcut #f)))
+		   (when (is-a? menu menu:can-restore-underscore<%>)
+		     (if v
+			 (send menu restore-underscores)
+			 (send menu erase-underscores)))
+		   (when (is-a? menu menu-item-container<%>)
+		     (for-each loop (send menu get-items)))))))
+	    
+	    (inherit get-menu-bar show can-close? get-edit-target-object)
+	    ,@(apply append (map (λ (x)
+				   (cond
+				     [(between? x) (build-before-super-between-clause x)]
+				     [(or (after? x) (before? x)) (build-before-super-before/after-clause x)]
+				     [(an-item? x) (build-before-super-item-clause x)]
+				     [(generic? x) (build-before-super-generic-clause x)]))
+				 items))
+	    (super-instantiate ())
+	    ,@(apply append (map (λ (x)
+				   (cond
+				     [(between? x) (build-after-super-between-clause x)]
+				     [(an-item? x) (build-after-super-item-clause x)]
+				     [(or (after? x) (before? x)) (build-after-super-before/after-clause x)]
+				     [(generic? x) (build-after-super-generic-clause x)]))
+				 items))
+	    (reorder-menus this)))
+       port))
+    'text
+    'truncate))
diff --git a/collects/framework/private/group.ss b/collects/framework/private/group.ss
new file mode 100644
index 0000000000..b734c8e1a7
--- /dev/null
+++ b/collects/framework/private/group.ss
@@ -0,0 +1,326 @@
+
+(module group mzscheme
+  (require (lib "string-constant.ss" "string-constants")
+           (lib "unitsig.ss")
+           (lib "class.ss")
+           "sig.ss"
+	   "../gui-utils.ss"
+           (lib "mred-sig.ss" "mred")
+           (lib "list.ss")
+           (lib "file.ss"))
+  
+  (provide group@)
+  
+  (define group@
+    (unit/sig framework:group^
+      (import mred^
+              [application : framework:application^]
+              [frame : framework:frame^]
+              [preferences : framework:preferences^]
+              [text : framework:text^]
+              [canvas : framework:canvas^]
+              [menu : framework:menu^])
+      
+      (define-struct frame (frame id))
+      
+      (define mdi-parent #f)
+      
+      (define %
+        (class object%
+          
+          [define active-frame #f]
+          [define most-recent-window-box (make-weak-box #f)]
+          [define frame-counter 0]
+          [define frames null]
+          [define todo-to-new-frames void]
+
+          [define windows-menus null]
+          
+          ;; get-windows-menu : (is-a?/c frame%) -> (union false? (is-a?/c menu%))
+          (define/private (get-windows-menu frame)
+            (let ([menu-bar (send frame get-menu-bar)])
+              (and menu-bar
+                   (let ([menus (send menu-bar get-items)])
+                     (ormap (λ (x)
+                              (if (string=? (string-constant windows-menu)
+                                            (send x get-plain-label))
+                                  x
+                                  #f))
+                            menus)))))
+          (define/private (insert-windows-menu frame)
+            (let ([menu (get-windows-menu frame)])
+              (when menu
+                (set! windows-menus (cons menu windows-menus)))))
+          (define/private (remove-windows-menu frame)
+            (let ([menu (get-windows-menu frame)])
+              
+              (when menu
+                ;; to help the (conservative) gc.
+                (for-each (λ (i) (send i delete)) (send menu get-items))
+                
+                (set! windows-menus
+                      (remove
+                       menu
+                       windows-menus
+                       eq?)))))
+          
+          (define/private (update-windows-menus)
+            (let* ([windows (length windows-menus)]
+                   [default-name (string-constant untitled)]
+                   [get-name 
+                    (λ (frame)
+                      (let ([label (send frame get-label)])
+                        (if (string=? label "")
+                            (if (method-in-interface? 'get-entire-label (object-interface frame))
+                                (let ([label (send frame get-entire-label)])
+                                  (if (string=? label "")
+                                      default-name
+                                      label))
+                                default-name)
+                            label)))]
+                   [sorted/visible-frames
+                    (quicksort
+                     (filter (λ (x) (send (frame-frame x) is-shown?)) frames)
+                     (λ (f1 f2)
+                       (string-ci<=? (get-name (frame-frame f1))
+                                     (get-name (frame-frame f2)))))])
+              (for-each
+               (λ (menu)
+                 (for-each (λ (item) (send item delete)) (send menu get-items))
+                 (instantiate menu:can-restore-menu-item% ()
+                   (label (string-constant bring-frame-to-front...))
+                   (parent menu)
+                   (callback (λ (x y) (choose-a-frame (send (send menu get-parent) get-frame))))
+                   (shortcut #\j))
+                 (instantiate menu:can-restore-menu-item% ()
+                   (label (string-constant most-recent-window))
+                   (parent menu)
+                   (callback (λ (x y) (most-recent-window-to-front)))
+                   (shortcut #\'))
+                 (make-object separator-menu-item% menu)
+                 (for-each
+                  (λ (frame)
+                    (let ([frame (frame-frame frame)])
+                      (make-object menu-item% 
+                        (regexp-replace*
+                         "&"
+                         (gui-utils:trim-string (get-name frame) 200)
+                         "&&")
+                        menu
+                        (λ (_1 _2)
+                          (send frame show #t)))))
+                  sorted/visible-frames))
+               windows-menus)))
+
+          ;; most-recent-window-to-front : -> void?
+          ;; brings the most recent window to the front
+          (define/private (most-recent-window-to-front)
+            (let ([most-recent-window (weak-box-value most-recent-window-box)])
+              (when most-recent-window
+                (send most-recent-window show #t))))                              
+
+          (define/private (update-close-menu-item-state)
+            (let* ([set-close-menu-item-state! 
+                    (λ (frame state)
+                      (when (is-a? frame frame:standard-menus<%>)
+                        (let ([close-menu-item (send frame file-menu:get-close-menu)])
+                          (when close-menu-item
+                            (send close-menu-item enable state)))))])
+              (if (eq? (length frames) 1)
+                  (set-close-menu-item-state! (car frames) #f)
+                  (for-each (λ (a-frame)
+                              (set-close-menu-item-state! a-frame #t))
+                            frames))))
+          
+          (field [open-here-frame #f])
+          (define/public (set-open-here-frame fr) (set! open-here-frame fr))
+          (define/public (get-open-here-frame)
+	    (cond
+	      [open-here-frame open-here-frame]
+	      [else
+	       (let ([candidates
+		      (filter (λ (x) (is-a? (frame-frame x) frame:open-here<%>))
+			      frames)])
+		 (if (null? candidates)
+		     #f
+		     (frame-frame (car candidates))))]))
+          
+          (public get-mdi-parent frame-label-changed for-each-frame
+                  get-active-frame set-active-frame insert-frame
+                  remove-frame clear on-close-all can-close-all? locate-file get-frames
+                  frame-shown/hidden)
+          [define get-mdi-parent
+            (λ ()
+              (when (and (eq? (system-type) 'windows)
+                         (preferences:get 'framework:windows-mdi)
+                         (not mdi-parent))
+                (set! mdi-parent (make-object frame% (application:current-app-name)
+                                   #f #f #f #f #f
+                                   '(mdi-parent)))
+                (send mdi-parent show #t))
+              mdi-parent)]
+          
+          (define (get-frames) (map frame-frame frames))
+          
+          [define frame-label-changed
+            (λ (frame)
+              (when (memq frame (map frame-frame frames))
+                (update-windows-menus)))]
+          
+          [define frame-shown/hidden
+            (λ (frame)
+              (when (memq frame (map frame-frame frames))
+                (update-windows-menus)))]
+          
+          [define for-each-frame
+            (λ (f)
+              (for-each (λ (x) (f (frame-frame x))) frames)
+              (set! todo-to-new-frames
+                    (let ([old todo-to-new-frames])
+                      (λ (frame) (old frame) (f frame)))))]
+          (define (get-active-frame)
+            (cond
+              [active-frame active-frame]
+              [(null? frames) #f]
+              [else (frame-frame (car frames))]))
+          (define (set-active-frame f)
+            (when (and active-frame
+                       (not (eq? active-frame f)))
+              (set! most-recent-window-box (make-weak-box active-frame)))
+            (set! active-frame f))
+          [define insert-frame
+            (λ (new-frame)
+              (unless (memf (λ (fr) (eq? (frame-frame fr) new-frame))
+                            frames)
+                (set! frame-counter (add1 frame-counter))
+                (let ([new-frames (cons (make-frame new-frame frame-counter)
+                                        frames)])
+                  (set! frames new-frames)
+                  (update-close-menu-item-state)
+                  (insert-windows-menu new-frame)
+                  (update-windows-menus))
+                (todo-to-new-frames new-frame)))]
+          
+          [define remove-frame
+            (λ (f)
+              (when (eq? f active-frame)
+                (set! active-frame #f))
+              (let ([new-frames
+                     (remove
+                      f frames
+                      (λ (f fr) (eq? f (frame-frame fr))))])
+                (set! frames new-frames)
+                (update-close-menu-item-state)
+                (remove-windows-menu f)
+                (update-windows-menus)))]
+          [define clear
+            (λ ()
+              (set! frames null)
+              #t)]
+          [define on-close-all
+            (λ ()
+              (for-each (λ (f)
+                          (let ([frame (frame-frame f)])
+                            (send frame on-close) 
+                            (send frame show #f)))
+                        frames))]
+          [define can-close-all?
+            (λ ()
+              (andmap (λ (f)
+                        (let ([frame (frame-frame f)])
+                          (send frame can-close?)))
+                      frames))]
+          [define locate-file
+            (λ (name)
+              (let* ([normalized
+                      ;; allow for the possiblity of filenames that are urls
+                      (with-handlers ([(λ (x) #t)
+                                       (λ (x) name)])
+                        (normal-case-path
+                         (normalize-path name)))]
+                     [test-frame
+                      (λ (frame)
+                        (and (is-a? frame frame:basic<%>)
+                             (send frame editing-this-file? normalized)))])
+                (let loop ([frames frames])
+                  (cond
+                    [(null? frames) #f]
+                    [else
+                     (let* ([frame (frame-frame (car frames))])
+                       (if (test-frame frame)
+                           frame
+                           (loop (cdr frames))))]))))]
+          
+          (super-instantiate ())))
+      
+      (define (choose-a-frame parent)
+        (letrec-values ([(sorted-frames)
+                         (quicksort
+                          (send (get-the-frame-group) get-frames)
+                          (λ (x y) (string-ci<=? (send x get-label) (send y get-label))))]
+                        [(d) (make-object dialog% (string-constant bring-frame-to-front) parent 400 600)]
+                        [(lb) (instantiate list-box% () 
+                              (label #f)
+                              (choices (map (λ (x) (gui-utils:trim-string (send x get-label) 200)) sorted-frames))
+                              (callback (λ (x y) (listbox-callback y)))
+                              (parent d))]
+                        [(t) (instantiate text:hide-caret/selection% ())]
+                        [(ec) (instantiate canvas:basic% ()
+                              (parent d)
+                              (stretchable-height #f))]
+                        [(bp) (instantiate horizontal-panel% ()
+                              (parent d)
+                              (stretchable-height #f)
+                              (alignment '(right center)))]
+                        [(cancelled?) #t]
+                        [(listbox-callback)
+                         (λ (evt)
+                           (case (send evt get-event-type)
+                             [(list-box)
+                              
+                              (send ok enable (pair? (send lb get-selections)))
+                              
+                              (let ([full-name
+                                     (let ([sels (send lb get-selections)])
+                                       (and (pair? sels)
+                                            (let ([fr (list-ref sorted-frames (car sels))])
+                                              (and (is-a? fr frame:basic%)
+                                                   (send fr get-filename)))))])
+                                (send t begin-edit-sequence)
+                                (send t erase)
+                                (when full-name
+                                  (send t insert full-name))
+                                (send t end-edit-sequence))]
+                             [(list-box-dclick)
+                              (set! cancelled? #f)
+                              (send d show #f)]))]
+                        [(ok cancel)
+                         (gui-utils:ok/cancel-buttons
+                          bp
+                          (λ (x y)
+                            (set! cancelled? #f)
+                            (send d show #f))
+                          (λ (x y)
+                            (send d show #f)))])
+          (send ec set-line-count 3)
+          (send ec set-editor t)
+          (send t auto-wrap #t)
+          (let ([fr (car sorted-frames)])
+            (when (and (is-a? fr frame:basic<%>)
+                       (send fr get-filename))
+              (send t insert (send (car sorted-frames) get-filename)))
+            (send lb set-selection 0))
+          (send d show #t)
+          (unless cancelled?
+            (let ([sels (send lb get-selections)])
+              (unless (null? sels)
+                (send (list-ref sorted-frames (car sels)) show #t))))))
+      
+      
+      (define (internal-get-the-frame-group)
+        (let ([the-frame-group (make-object %)])
+          (set! internal-get-the-frame-group (λ () the-frame-group))
+          (internal-get-the-frame-group)))
+      
+      (define (get-the-frame-group)
+        (internal-get-the-frame-group)))))
diff --git a/collects/framework/private/handler.ss b/collects/framework/private/handler.ss
new file mode 100644
index 0000000000..0e4d171105
--- /dev/null
+++ b/collects/framework/private/handler.ss
@@ -0,0 +1,393 @@
+
+(module handler mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "class.ss")
+           (lib "list.ss")
+           (lib "hierlist.ss" "hierlist")
+	   "sig.ss"
+	   "../gui-utils.ss"
+	   (lib "mred-sig.ss" "mred")
+	   (lib "file.ss")
+           (lib "string-constant.ss" "string-constants"))
+
+  (provide handler@)
+
+  (define handler@
+    (unit/sig framework:handler^
+      (import mred^
+	      [finder : framework:finder^]
+	      [group : framework:group^]
+	      [text : framework:text^]
+	      [preferences : framework:preferences^]
+	      [frame : framework:frame^])
+      
+      (define-struct handler (name extension handler))
+
+      (define format-handlers '())
+
+      (define make-insert-handler
+	(letrec ([string-list?
+		  (λ (l)
+		    (cond
+		     [(null? l) #t]
+		     [(not (pair? l)) #f]
+		     [else
+		      (and (string? (car l))
+			   (string-list? (cdr l)))]))])
+	  (λ (who name extension handler)
+	    (cond
+	     [(not (string? name))
+	      (error who "name was not a string")]
+	     [(and (not (procedure? extension))
+		   (not (string? extension))
+		   (not (string-list? extension)))
+	      (error who
+		     "extension was not a string, list of strings, or a predicate")]
+	     [(not (procedure? handler))
+	      (error who "handler was not a function")]
+	     [else (make-handler name
+				 (if (string? extension)
+                                     (list extension)
+                                     extension)
+				 handler)]))))
+      
+      (define insert-format-handler
+	(λ args
+	  (set! format-handlers 
+		(cons (apply make-insert-handler 'insert-format-handler args)
+		      format-handlers))))
+
+      (define find-handler
+	(λ (name handlers)
+	  (let/ec exit
+	    (let ([extension (if (string? name)
+				 (or (filename-extension name)
+				     "")
+				 "")])
+	      (for-each
+	       (λ (handler)
+		 (let ([ext (handler-extension handler)])
+		   (when (or (and (procedure? ext)
+				  (ext name))
+			     (and (pair? ext)
+				  (ormap (λ (ext) (string=? ext extension))
+					 ext)))
+		     (exit (handler-handler handler)))))
+	       handlers)
+	      #f))))
+      
+      (define find-format-handler
+	(λ (name)
+	  (find-handler name format-handlers)))
+
+					; Finding format & mode handlers by name
+      (define find-named-handler
+	(λ (name handlers)
+	  (let loop ([l handlers])
+	    (cond
+	     [(null? l) #f]
+	     [(string-ci=? (handler-name (car l)) name)
+	      (handler-handler (car l))]
+	     [else (loop (cdr l))]))))
+      
+      (define find-named-format-handler
+	(λ (name)
+	  (find-named-handler name format-handlers)))
+
+					; Open a file for editing
+      (define current-create-new-window
+	(make-parameter
+	 (λ (filename)
+	   (let ([frame (make-object frame:text% filename)])
+	     (send frame show #t)
+	     frame))))
+
+      (define edit-file
+	(case-lambda
+	 [(filename) (edit-file
+		      filename
+		      (λ ()
+			((current-create-new-window) filename)))]
+	 [(filename make-default)
+	  (with-handlers ([(λ (x) #f) ;exn:fail?
+			   (λ (exn)
+			     (message-box
+			      (string-constant error-loading)
+			      (string-append
+			       (format (string-constant error-loading-file/name)
+				       (or filename
+					   (string-constant unknown-filename)))
+			       "\n\n"
+			       (if (exn? exn)
+				   (format "~a" (exn-message exn))
+				   (format "~s" exn))))
+			     #f)])
+            (gui-utils:show-busy-cursor
+	     (λ ()
+	       (if filename
+		   (let ([already-open (send (group:get-the-frame-group)
+					     locate-file
+					     filename)])
+                     (cond
+		       [already-open
+			(send already-open make-visible filename)
+                        (send already-open show #t)
+			already-open]
+		       [(and (preferences:get 'framework:open-here?)
+			     (send (group:get-the-frame-group) get-open-here-frame))
+			=>
+			(λ (fr)
+			  (add-to-recent filename)
+			  (send fr open-here filename)
+			  (send fr show #t)
+			  fr)]
+		       [else
+			(let ([handler
+			       (if (path? filename)
+				   (find-format-handler filename)
+				   #f)])
+			  (add-to-recent filename)
+			  (if handler
+			      (handler filename)
+			      (make-default)))]))
+		   (make-default)))))]))
+      
+      ;; type recent-list-item = (list/p string? number? number?)
+      
+      ;; add-to-recent : path -> void
+      (define (add-to-recent filename)
+        (let* ([old-list (preferences:get 'framework:recently-opened-files/pos)]
+               [old-ents (filter (λ (x) (string=? (path->string (car x))
+                                                       (path->string filename))) 
+                                 old-list)]
+               [old-ent (if (null? old-ents)
+                            #f
+                            (car old-ents))]
+               [new-ent (list filename 
+                              (if old-ent (cadr old-ent) 0)
+                              (if old-ent (caddr old-ent) 0))]
+               [added-in (cons new-ent (remove new-ent old-list compare-recent-list-items))]
+               [new-recent (size-down added-in (preferences:get 'framework:recent-max-count))])
+          (preferences:set 'framework:recently-opened-files/pos new-recent)))
+      
+      ;; compare-recent-list-items : recent-list-item recent-list-item -> boolean
+      (define (compare-recent-list-items l1 l2)
+        (string=? (path->string (car l1))
+                  (path->string (car l2))))
+
+      ;; size-down : (listof X) -> (listof X)[< recent-max-count]
+      ;; takes a list of stuff and returns the
+      ;; front of the list, up to `recent-max-count' items
+      (define (size-down new-recent n)
+        (let loop ([n n]
+                   [new-recent new-recent])
+          (cond
+            [(zero? n) null]
+            [(null? new-recent) null]
+            [else
+             (cons (car new-recent)
+                   (loop (- n 1)
+                         (cdr new-recent)))])))
+      
+      ;; size-recently-opened-files : number -> void
+      ;; sets the recently-opened-files/pos preference
+      ;; to a size limited by `n'
+      (define (size-recently-opened-files n)
+         (preferences:set
+          'framework:recently-opened-files/pos
+          (size-down (preferences:get 'framework:recently-opened-files/pos)
+                     n)))       
+      
+      ;; set-recent-position : string number number -> void
+      ;; updates the recent menu preferences 
+      ;; with the positions `start' and `end'
+      (define (set-recent-position filename start end)
+        (let ([recent-items
+               (filter (λ (x) (string=? (path->string (car x))
+                                             (path->string filename)))
+                       (preferences:get 'framework:recently-opened-files/pos))])
+          (unless (null? recent-items)
+            (let ([recent-item (car recent-items)])
+              (set-car! (cdr recent-item) start)
+              (set-car! (cddr recent-item) end)))))
+        
+      ;; install-recent-items : (is-a?/c menu%) -> void?
+      (define (install-recent-items menu)
+        (let ([recently-opened-files
+               (preferences:get
+                'framework:recently-opened-files/pos)])
+          (for-each (λ (item) (send item delete))
+                    (send menu get-items))
+          
+          (instantiate menu-item% ()
+            (parent menu)
+            (label (string-constant show-recent-items-window-menu-item))
+            (callback (λ (x y) (show-recent-items-window))))
+          
+          (instantiate separator-menu-item% ()
+            (parent menu))
+
+          (for-each (λ (recent-list-item) 
+                      (let ([filename (car recent-list-item)])
+                        (instantiate menu-item% ()
+                          (parent menu)
+                          (label (gui-utils:trim-string  
+                                  (regexp-replace*
+                                   "&"
+                                   (path->string filename)
+                                   "&&")
+                                  200))
+                          (callback (λ (x y) (open-recent-list-item recent-list-item))))))
+                    recently-opened-files)))
+
+      ;; open-recent-list-item : recent-list-item -> void
+      (define (open-recent-list-item recent-list-item)
+        (let* ([filename (car recent-list-item)]
+               [start (cadr recent-list-item)]
+               [end (caddr recent-list-item)])
+          (cond
+            [(file-exists? filename)
+             (let ([fr (edit-file filename)])
+               (when (is-a? fr frame:open-here<%>)
+                 (let ([ed (send fr get-open-here-editor)])
+                   (when (equal? (send ed get-filename) filename)
+                     (send ed set-position start end)))))]
+            [else
+             (message-box (string-constant error)
+                          (format (string-constant cannot-open-because-dne)
+                                  filename))])))
+      
+      ;; show-recent-items-window : -> void
+      (define (show-recent-items-window)
+        (unless recent-items-window
+          (set! recent-items-window (make-recent-items-window)))
+        (send recent-items-window show #t))
+      
+      ;; make-recent-items-window : -> frame
+      (define (make-recent-items-window)
+        (make-object (get-recent-items-window%)
+          (string-constant show-recent-items-window-label)
+          #f
+          (preferences:get 'framework:recent-items-window-w) 
+          (preferences:get 'framework:recent-items-window-h)))
+
+      ;; recent-items-window : (union #f (is-a?/c frame%))
+      (define recent-items-window #f)
+
+      (define recent-items-hierarchical-list%
+        (class hierarchical-list%
+          (define/override (on-double-select item)
+            (send item open-item))
+          (super-instantiate ())))
+      
+      (define recent-items-super% (frame:standard-menus-mixin frame:basic%))
+
+      (define (set-recent-items-frame-superclass super%)
+        (set! recent-items-super% super%))
+      
+      (define (get-recent-items-window%)
+        (class recent-items-super%
+
+          ;; remove extraneous separators
+          (define/override (file-menu:between-print-and-close menu) (void))
+          (define/override (edit-menu:between-find-and-preferences menu) (void))
+          
+          (define/override (on-size w h)
+            (preferences:set 'framework:recent-items-window-w w)
+            (preferences:set 'framework:recent-items-window-h h))
+
+          ;; refresh-hl : (listof recent-list-item) -> void
+          (define/private (refresh-hl recent-list-items)
+            (let ([ed (send hl get-editor)])
+              (send ed begin-edit-sequence)
+              (for-each (λ (item) (send hl delete-item item)) (send hl get-items))
+              (for-each (λ (item) (add-recent-item item))
+                        (if (eq? (preferences:get 'framework:recently-opened-sort-by) 'name)
+                            (quicksort recent-list-items
+                                       (λ (x y) (string<=? (path->string (car x))
+                                                                (path->string (car y)))))
+                            recent-list-items))
+              (send ed end-edit-sequence)))
+          
+          (define/private (add-recent-item recent-list-item)
+            (let ([item (send hl new-item (make-hierlist-item-mixin recent-list-item))])
+              (send (send item get-editor) insert (path->string (car recent-list-item)))))
+
+          (field [remove-prefs-callback
+                  (preferences:add-callback
+                   'framework:recently-opened-files/pos
+                   (λ (p v)
+                     (refresh-hl v)))])
+          
+          (define/augment (on-close)
+            (inner (void) on-close)
+            (remove-prefs-callback)
+            (set! recent-items-window #f))
+          
+          (super-new)
+          
+          (inherit get-area-container)
+          (field [bp (make-object horizontal-panel% (get-area-container))]
+                 [hl (make-object recent-items-hierarchical-list% (get-area-container) '())]
+                 [sort-by-name-button
+                  (make-object button% 
+                    (string-constant recent-items-sort-by-name) 
+                    bp
+                    (λ (x y) (set-sort-by 'name)))]
+                 [sort-by-age-button
+                  (make-object button% 
+                    (string-constant recent-items-sort-by-age) 
+                    bp
+                    (λ (x y) (set-sort-by 'age)))])
+          
+          (send bp stretchable-height #f)
+          (send sort-by-name-button stretchable-width #t)
+          (send sort-by-age-button stretchable-width #t)
+          
+          (define/private (set-sort-by flag)
+            (preferences:set 'framework:recently-opened-sort-by flag)
+            (case flag
+              [(name) 
+               (send sort-by-age-button enable #t)
+               (send sort-by-name-button enable #f)]
+              [(age) 
+               (send sort-by-age-button enable #f)
+               (send sort-by-name-button enable #t)])
+            (refresh-hl (preferences:get 'framework:recently-opened-files/pos)))
+
+          (set-sort-by (preferences:get 'framework:recently-opened-sort-by))))
+
+      ;; make-hierlist-item-mixin : recent-item -> mixin(arg to new-item method of hierlist)
+      (define (make-hierlist-item-mixin recent-item)
+        (λ (%)
+          (class %
+            (define/public (open-item)
+              (open-recent-list-item recent-item))
+            (super-instantiate ()))))
+      
+      (define *open-directory* ; object to remember last directory
+	(new (class object%
+               (field [the-dir #f])
+               [define/public get (λ () the-dir)]
+               [define/public set-from-file!
+                 (λ (file) 
+                   (set! the-dir (path-only file)))]
+               [define/public set-to-default
+                 (λ ()
+                   (set! the-dir (current-directory)))]
+               (set-to-default)
+               (super-new))))
+
+      (define open-file
+	(λ ()
+	  (let ([file 
+		 (parameterize ([finder:dialog-parent-parameter
+				 (and (preferences:get 'framework:open-here?)
+                                      (get-top-level-focus-window))])
+		   (finder:get-file
+		    (send *open-directory* get)))])
+	    (when file
+	      (send *open-directory*
+		    set-from-file! file))
+	    (and file
+		 (edit-file file))))))))
diff --git a/collects/framework/private/icon.ss b/collects/framework/private/icon.ss
new file mode 100644
index 0000000000..e61d24b442
--- /dev/null
+++ b/collects/framework/private/icon.ss
@@ -0,0 +1,76 @@
+(module icon mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "class.ss")
+           (lib "include-bitmap.ss" "mrlib")
+	   "bday.ss"
+           "sig.ss"
+	   (lib "mred-sig.ss" "mred"))
+  
+  (provide icon@)
+  
+  (define icon@
+    (unit/sig framework:icon^
+      (import mred^)
+
+      (define eof-bitmap (delay (include-bitmap (lib "eof.gif" "icons"))))
+      (define (get-eof-bitmap) (force eof-bitmap))
+      
+      (define anchor-bitmap (delay (include-bitmap (lib "anchor.gif" "icons"))))
+      (define (get-anchor-bitmap) (force anchor-bitmap))
+      
+      (define lock-bitmap (delay (include-bitmap (lib "lock.gif" "icons"))))
+      (define (get-lock-bitmap) (force lock-bitmap))
+      (define unlock-bitmap (delay (include-bitmap (lib "unlock.gif" "icons"))))
+      (define (get-unlock-bitmap) (force unlock-bitmap))
+      
+      (define autowrap-bitmap (delay (include-bitmap (lib "return.xbm" "icons"))))
+      (define (get-autowrap-bitmap) (force autowrap-bitmap))
+      (define paren-highlight-bitmap (delay (include-bitmap (lib "paren.xbm" "icons"))))
+      (define (get-paren-highlight-bitmap) (force paren-highlight-bitmap))
+      
+      (define-syntax (make-get-cursor stx)
+        (syntax-case stx ()
+          [(_ name mask fallback)
+           (syntax
+            (let ([ans (delay 
+                         (let* ([msk-b (include-bitmap (lib mask "icons"))]
+                                [csr-b (include-bitmap (lib name "icons"))])
+                           (if (and (send msk-b ok?)
+                                    (send csr-b ok?))
+                               (let ([csr (make-object cursor% msk-b csr-b 7 7)])
+                                 (if (send csr ok?)
+                                     csr
+                                     (make-object cursor% fallback)))
+                               (make-object cursor% fallback))))])
+              (λ ()
+                (force ans))))]))
+      
+      (define get-up/down-cursor (make-get-cursor "up-down-cursor.xbm" "up-down-mask.xbm" 'size-n/s))
+      (define get-left/right-cursor (make-get-cursor "left-right-cursor.xbm" "left-right-mask.xbm" 'size-e/w))
+      
+      (define mrf-on-bitmap (delay (include-bitmap (lib "mrf.jpg" "icons"))))
+      (define gc-on-bitmap (delay (include-bitmap (lib "recycle.gif" "icons"))))
+      
+      (define (make-off-bitmap onb)
+        (let* ([bitmap (make-object bitmap%
+                         (send onb get-width)
+                         (send onb get-height))]
+               [bdc (make-object bitmap-dc% bitmap)])
+          (send bdc clear)
+          (send bdc set-bitmap #f)
+          bitmap))
+      
+      (define mrf-off-bitmap (delay (make-off-bitmap (force mrf-on-bitmap))))
+      (define gc-off-bitmap (delay (make-off-bitmap (force gc-on-bitmap))))
+      
+      (define (get-gc-on-bitmap)
+        (force
+         (if (mrf-bday?)
+             mrf-on-bitmap
+             gc-on-bitmap)))
+      
+      (define (get-gc-off-bitmap)
+        (force
+         (if (mrf-bday?)
+             mrf-off-bitmap
+             gc-off-bitmap))))))
diff --git a/collects/framework/private/info.ss b/collects/framework/private/info.ss
new file mode 100644
index 0000000000..1837a58f6a
--- /dev/null
+++ b/collects/framework/private/info.ss
@@ -0,0 +1,3 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Framework private")
+  (define compile-omit-files '("standard-menus.ss")))
diff --git a/collects/framework/private/keymap.ss b/collects/framework/private/keymap.ss
new file mode 100644
index 0000000000..34634d609f
--- /dev/null
+++ b/collects/framework/private/keymap.ss
@@ -0,0 +1,1325 @@
+
+(module keymap mzscheme
+  (require (lib "string-constant.ss" "string-constants")
+           (lib "unitsig.ss")
+	   (lib "class.ss")
+	   (lib "list.ss")
+	   (lib "mred-sig.ss" "mred")
+           (lib "match.ss")
+           "sig.ss")
+  
+  (provide keymap@)
+  
+  (define keymap@ 
+    (unit/sig framework:keymap^
+      (import mred^
+	      [preferences : framework:preferences^]
+	      [finder : framework:finder^]
+	      [handler : framework:handler^]
+	      [frame : framework:frame^]
+              [editor : framework:editor^])
+      
+      (rename [-get-file get-file])
+
+      (define user-keybindings-files (make-hash-table 'equal))
+      
+      (define (add-user-keybindings-file path)
+        (hash-table-get 
+         user-keybindings-files
+         path
+         (λ ()
+           (let ([sexp (and (file-exists? path)
+                            (call-with-input-file path read))])
+             (match sexp
+               [`(module ,name (lib "keybinding-lang.ss" "framework") ,@(x ...)) 
+                 (let ([km (dynamic-require path '#%keymap)])
+                   (hash-table-put! user-keybindings-files path km)
+                   (send global chain-to-keymap km #t))]
+               [else (error 'add-user-keybindings-file 
+                            (string-constant user-defined-keybinding-malformed-file)
+                            (path->string path))])))))
+      
+      (define (remove-user-keybindings-file path)
+        (let/ec k
+          (let ([km (hash-table-get user-keybindings-files path (λ () (k (void))))])
+            (send global remove-chained-keymap km)
+            (hash-table-remove! user-keybindings-files path))))
+      
+      (define (remove-chained-keymap ed keymap-to-remove)
+        (let ([ed-keymap (send ed get-keymap)])
+          (when (eq? keymap-to-remove ed-keymap)
+            (error 'keymap:remove-keymap "cannot remove initial keymap from editor"))
+          (let p-loop ([parent-keymap ed-keymap])
+            (unless (is-a? parent-keymap aug-keymap<%>)
+              (error 'keymap:remove-keymap
+                     "found a keymap that is not a keymap:aug-keymap<%> ~e" 
+                     parent-keymap))
+            (let c-loop ([child-keymaps (send parent-keymap get-chained-keymaps)])
+              (cond
+                [(null? child-keymaps) null]
+                [else
+                 (let ([child-keymap (car child-keymaps)])
+                   (cond
+                     [(eq? child-keymap keymap-to-remove)
+                      (send parent-keymap remove-chained-keymap child-keymap)
+                      (c-loop (cdr child-keymaps))]
+                     [else 
+                      (p-loop child-keymap)
+                      (c-loop (cdr child-keymaps))]))])))))
+      
+      (define (set-chained-keymaps parent-keymap children-keymaps)
+        (for-each (λ (orig-sub) (send parent-keymap remove-chained-keymap))
+                  (send parent-keymap get-chained-keymaps))
+        (for-each (λ (new-sub) (send parent-keymap chain-to-keymap new-sub #f))
+                  children-keymaps))
+        
+      (define aug-keymap<%> (interface ((class->interface keymap%))
+			      get-chained-keymaps
+			      get-map-function-table
+			      get-map-function-table/ht))
+      
+      (define aug-keymap-mixin
+	(mixin ((class->interface keymap%)) (aug-keymap<%>)
+          (define chained-keymaps null)
+	  (define/public (get-chained-keymaps) chained-keymaps)
+	  
+	  (define/override (chain-to-keymap keymap prefix?)
+            (super chain-to-keymap keymap prefix?)
+            (set! chained-keymaps
+                  (if prefix?
+                      (cons keymap chained-keymaps)
+                      (append chained-keymaps (list keymap)))))
+	  
+          (define/override (remove-chained-keymap keymap)
+            (super remove-chained-keymap keymap)
+            (set! chained-keymaps (remq keymap chained-keymaps)))
+          
+	  (define function-table (make-hash-table))
+          (define/public (get-function-table) function-table)
+	  (define/override (map-function keyname fname)
+            (super map-function (canonicalize-keybinding-string keyname) fname)
+            (hash-table-put! function-table (string->symbol keyname) fname))
+	  
+	  (define/public (get-map-function-table)
+            (get-map-function-table/ht (make-hash-table)))
+          
+          (define/public (get-map-function-table/ht table)
+            (hash-table-for-each
+             function-table
+             (λ (keyname fname)
+               (unless (hash-table-get table keyname (λ () #f))
+                 (hash-table-put! table keyname fname))))
+            (for-each
+             (λ (chained-keymap)
+               (when (is-a? chained-keymap aug-keymap<%>)
+                 (send chained-keymap get-map-function-table/ht table)))
+             chained-keymaps)
+            table)
+          
+          (super-new)))
+      
+      (define aug-keymap% (aug-keymap-mixin keymap%))
+      
+      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;;;;;;                                                     ;;;;;;;;
+      ;;;;;;;           canonicalize-keybinding-string            ;;;;;;;;
+      ;;;;;;;                                                     ;;;;;;;;
+      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      
+      ;; canonicalize-keybinding-string : string -> string
+      ;; The result can be used with string=? to determine
+      ;; if two key bindings refer to the same key.
+      ;; Assumes a well-formed keystring.
+      (define (canonicalize-keybinding-string str)
+	(let* ([chars (map char-downcase (string->list str))]
+	       [separated-keys
+		(map
+		 canonicalize-single-keybinding-string
+		 (split-out #\; chars))])
+	  (join-strings ";" separated-keys)))
+      
+      ;; join-strings : string (listof string) -> string
+      ;; concatenates strs with sep between each of them
+      (define (join-strings sep strs)
+	(if (null? strs)
+	    ""
+	    (apply
+	     string-append
+	     (cons
+	      (car strs)
+	      (let loop ([sepd-strs (cdr strs)])
+		(cond
+                  [(null? sepd-strs) null]
+                  [else (list*
+                         sep
+                         (car sepd-strs)
+                         (loop (cdr sepd-strs)))]))))))
+      
+      ;; canonicalize-single-keybinding-string : (listof char) -> string
+      (define (canonicalize-single-keybinding-string chars)
+	(let* ([neg? (char=? (car chars) #\:)]
+	       [mods/key (split-out #\: (if neg? (cdr chars) chars))]
+	       [mods
+		(let loop ([mods mods/key])
+		  (cond
+                    [(null? mods) null]
+                    [(null? (cdr mods)) null]
+                    [else (cons (car mods) (loop (cdr mods)))]))]
+	       [key (apply string (car (last-pair mods/key)))]
+               [canon-key
+                (cond
+                  [(string=? key "enter") "return"]
+                  [(string=? key "del") "delete"]
+                  [(string=? key "ins") "insert"]
+                  [else key])]
+	       [shift (if neg? #f 'd/c)]
+	       [control (if neg? #f 'd/c)]
+	       [alt (if neg? #f 'd/c)]
+	       [meta (if neg? #f 'd/c)]
+	       [command (if neg? #f 'd/c)]
+               
+	       [do-key
+		(λ (char val)
+		  (cond
+                    [(eq? val #t) (string char)]
+                    [(eq? val #f) (string #\~ char)]
+                    [(eq? val 'd/c) #f]))])
+          
+	  (for-each (λ (mod)
+		      (let ([val (not (char=? (car mod) #\~))])
+			(case (if (char=? (car mod) #\~)
+				  (cadr mod)
+				  (car mod))
+			  [(#\s) (set! shift val)]
+			  [(#\c) (set! control val)]
+			  [(#\a) (set! alt val)]
+			  [(#\d) (set! command val)]
+			  [(#\m) (set! meta val)])))
+		    mods)
+          
+	  (join-strings ":"
+			(filter
+			 (λ (x) x)
+			 (list
+			  (do-key #\a alt)
+			  (do-key #\c control)
+			  (do-key #\d command)
+			  (do-key #\m meta)
+			  (do-key #\s shift)
+			  canon-key)))))
+      
+      ;; split-out : char (listof char) -> (listof (listof char))
+      ;; splits a list of characters at its first argument
+      ;; if the last character is the same as the first character,
+      ;; it is not split into an empty list, but returned.
+      (define (split-out split-char chars)
+	(let loop ([chars chars]
+		   [this-split null]
+		   [all-split null])
+	  (cond
+            [(null? chars)
+             (reverse (cons (reverse this-split) all-split))]
+            [else (let ([char (car chars)])
+                    (cond
+                      [(char=? split-char char)
+                       (if (null? (cdr chars))
+                           (loop null
+                                 (cons char this-split)
+                                 all-split)
+                           (loop (cdr chars)
+                                 null
+                                 (cons (reverse this-split) all-split)))]
+                      [else
+                       (loop (cdr chars)
+                             (cons char this-split)
+                             all-split)]))])))
+      
+      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;;;;;;                                                     ;;;;;;;;
+      ;;;;;;;         end canonicalize-keybinding-string          ;;;;;;;;
+      ;;;;;;;                                                     ;;;;;;;;
+      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      
+      (define (make-meta-prefix-list key)
+	(let ([defaults
+		(list (string-append "m:" key)
+		      (string-append "ESC;" key))])
+	  (if (eq? (system-type) 'macosx)
+	      (cons (string-append "a:" key)
+		    defaults)
+	      defaults)))
+      
+      (define send-map-function-meta
+	(λ (keymap key func)
+	  (for-each (λ (key) (send keymap map-function key func))
+		    (make-meta-prefix-list key))))
+      
+      (define add-to-right-button-menu (make-parameter void))
+      (define add-to-right-button-menu/before (make-parameter void))
+      
+      (define setup-global
+        ; Define some useful keyboard functions
+	(let* ([ring-bell
+		(λ (edit event)
+		  (bell))]
+	       
+	       [mouse-popup-menu 
+		(λ (edit event)
+		  (when (send event button-down?)
+		    (let ([a (send edit get-admin)])
+		      (when a
+			(let ([m (make-object popup-menu%)])
+                          
+                          ((add-to-right-button-menu/before) m edit event)
+                          
+			  (append-editor-operation-menu-items m)
+			  (for-each
+			   (λ (i)
+			     (when (is-a? i selectable-menu-item<%>)
+			       (send i set-shortcut #f)))
+			   (send m get-items))
+                          
+			  ((add-to-right-button-menu) m edit event)
+                          
+			  (let-values ([(x y) (send edit
+						    dc-location-to-editor-location
+						    (send event get-x)
+						    (send event get-y))])
+			    (send a popup-menu m (+ x 1) (+ y 1))))))))]
+               
+	       [toggle-anchor
+		(λ (edit event)
+		  (send edit set-anchor
+			(not (send edit get-anchor))))]
+	       [center-view-on-line
+		(λ (edit event)
+		  (let ([new-mid-line (send edit position-line
+					    (send edit get-start-position))]
+			[bt (box 0)]
+			[bb (box 0)])
+		    (send edit get-visible-line-range bt bb #f)
+		    (let* ([half (sub1 (quotient (- (unbox bb) (unbox bt)) 2))]
+			   [last-pos (send edit position-line (send edit last-position))]
+			   [top-pos (send edit line-start-position 
+					  (max (min (- new-mid-line half) last-pos) 0))]
+			   [bottom-pos (send edit line-start-position 
+					     (max 0
+						  (min (+ new-mid-line half)
+						       last-pos)))])
+		      (send edit scroll-to-position 
+			    top-pos
+			    #f
+			    bottom-pos)))
+		  #t)]
+
+	       [make-insert-brace-pair
+		(λ (open-brace close-brace)
+		  (λ (edit event)
+		    (send edit begin-edit-sequence)
+                    (let ([selection-start (send edit get-start-position)])
+                      (send edit set-position (send edit get-end-position))
+                      (send edit insert close-brace)
+                      (send edit set-position selection-start)
+                      (send edit insert open-brace))
+		    (send edit end-edit-sequence)))]
+               
+               [insert-lambda-template
+                (λ (edit event)
+                  (send edit begin-edit-sequence)
+                  (let ([selection-start (send edit get-start-position)])
+                    (send edit set-position (send edit get-end-position))
+                    (send edit insert ")")
+                    (send edit set-position selection-start)
+                    (send edit insert ") ")
+                    (send edit set-position selection-start)
+                    (send edit insert "(λ ("))
+                  (send edit end-edit-sequence))]
+
+	       [collapse-variable-space
+                ;; As per emacs: collapse tabs & spaces around the point,
+                ;; perhaps leaving a single space.
+                ;; drscheme bonus: if at end-of-line, collapse into the next line.
+		(λ (leave-one? edit event)
+		  (letrec ([last-pos  (send edit last-position)]
+		           [sel-start (send edit get-start-position)]
+			   [sel-end   (send edit get-end-position)]
+                           [collapsible? (λ (c) (and (char-whitespace? c)
+                                                          (not (char=? #\newline c))))]
+			   [find-noncollapsible
+                            ; Return index of next non-collapsible char,
+                            ; starting at pos in direction dir.
+                            ; NB returns -1 or last-pos, if examining
+                            ; initial/final whitespace
+                            ; (or, when initial pos is outside of [0,last-pos).)
+			    (λ (pos dir)
+			      (let loop ([pos pos])
+                                (cond [(<  pos 0) -1]
+                                      [(>= pos last-pos) last-pos]
+                                      [(collapsible? (send edit get-character pos))
+                                       (loop (+ pos dir))]
+                                      [else pos])))])
+                    (when (= sel-start sel-end) ; Only when no selection:
+                      (let* ([start (add1 (find-noncollapsible (sub1 sel-start) -1))]
+                             [end-heeding-eol (find-noncollapsible sel-start +1)]
+                             ; This is the end of the range, were we to always heed newlines.
+                             
+                             ; Special case: if we're sitting at EOL,
+                             ; and we're not affecting much else,
+                             ; then delete that EOL and collapse spaces
+                             ; at the start of next line, too:
+                             [end (if (and (<= (- end-heeding-eol start)
+                                               (if leave-one? 1 0))
+                                           (char=? #\newline (send edit get-character end-heeding-eol))
+                                           ; If you wish to avoid deleting an newline at EOF, do so here.
+                                           )
+                                      (find-noncollapsible (add1 end-heeding-eol) +1)
+                                      end-heeding-eol)]
+                             [making-no-difference?
+                              ; Don't introduce edits into undo-chain, if no effect.
+                              (if leave-one?
+                                  (and (= (- end start) 1)
+                                       (char=? #\space (send edit get-character start)))
+                                  (= (- end start) 0))])
+                        (unless making-no-difference?
+                          (send edit begin-edit-sequence)
+                          (send edit set-position end) ; Even after delete, caret will be at "end".
+                          (send edit delete start end)
+                          (when leave-one? (send edit insert #\space start))
+                          (send edit end-edit-sequence))))))]
+	       
+	       [collapse-space
+		(λ (edit event)
+		  (collapse-variable-space #t edit event))]
+	       
+	       [remove-space
+		(λ (edit event)
+		  (collapse-variable-space #f edit event))]
+	       
+	       [collapse-newline
+		(λ (edit event)
+		  (letrec ([find-nonwhite
+			    (λ (pos d offset)
+			      (let/ec escape
+				(let ([max (if (> offset 0)
+					       (send edit last-position)
+					       0)])
+				  (let loop ([pos pos])
+				    (if (= pos max)
+					(escape pos)
+					(let ([c (send edit get-character (+ pos offset))])
+					  (cond
+                                            [(char=? #\newline c)
+                                             (loop (+ pos d))
+                                             (escape pos)]
+                                            [(char-whitespace? c) 
+                                             (loop (+ pos d))]
+                                            [else pos])))))))])
+		    (let ([sel-start (send edit get-start-position)]
+			  [sel-end (send edit get-end-position)])
+		      (when (= sel-start sel-end)
+			(let* ([pos-line (send edit position-line sel-start #f)]
+			       [pos-line-start (send edit line-start-position pos-line)]
+			       [pos-line-end (send edit line-end-position pos-line)]
+			       
+			       [whiteline?
+				(let loop ([pos pos-line-start])
+				  (if (>= pos pos-line-end)
+				      #t
+				      (and (char-whitespace? (send edit get-character pos))
+					   (loop (add1 pos)))))]
+			       
+			       [start (find-nonwhite pos-line-start -1 -1)]
+			       [end (find-nonwhite pos-line-end 1 0)]
+			       
+			       [start-line 
+				(send edit position-line start #f)]
+			       [start-line-start
+				(send edit line-start-position start-line)]
+			       [end-line
+				(send edit position-line end #f)]
+			       [end-line-start
+				(send edit line-start-position (add1 end-line))])
+			  (cond
+                            [(and whiteline?
+                                  (= start-line pos-line)
+                                  (= end-line pos-line))
+                             ; Special case: just delete this line
+                             (send edit delete pos-line-start (add1 pos-line-end))]
+                            [(and whiteline? (< start-line pos-line))
+                             ; Can delete before & after
+                             (send* edit 
+                               (begin-edit-sequence)
+                               (delete (add1 pos-line-end) end-line-start)
+                               (delete start-line-start pos-line-start)
+                               (end-edit-sequence))]
+                            [else
+                             ; Only delete after
+                             (send edit delete (add1 pos-line-end) 
+                                   end-line-start)]))))))]
+	       
+	       [open-line
+		(λ (edit event)
+		  (let ([sel-start (send edit get-start-position)]
+			[sel-end (send edit get-end-position)])
+		    (if (= sel-start sel-end)
+			(send* edit 
+                          (insert #\newline)
+                          (set-position sel-start)))))]
+	       
+	       [transpose-chars
+		(λ (edit event)
+		  (let ([sel-start (send edit get-start-position)]
+			[sel-end (send edit get-end-position)])
+		    (when (and (= sel-start sel-end)
+			       (not (= sel-start 0)))
+		      
+		      (let ([sel-start
+			     (if (= sel-start
+				    (send edit line-end-position
+					  (send edit position-line sel-start)))
+				 (sub1 sel-start)
+				 sel-start)])
+			(let ([s (send edit get-text
+				       sel-start (add1 sel-start))])
+			  (send* edit
+                            (begin-edit-sequence)
+                            (delete sel-start (add1 sel-start))
+                            (insert s (- sel-start 1))
+                            (set-position (add1 sel-start))
+                            (end-edit-sequence)))))))]
+	       
+	       [transpose-words
+		(λ (edit event)
+		  (let ([sel-start (send edit get-start-position)]
+			[sel-end (send edit get-end-position)])
+		    (when (= sel-start sel-end)
+		      (let ([word-1-start (box sel-start)])
+			(send edit find-wordbreak word-1-start #f 'caret)
+			(let ([word-1-end (box (unbox word-1-start))])
+			  (send edit find-wordbreak #f word-1-end 'caret)
+			  (let ([word-2-end (box (unbox word-1-end))])
+			    (send edit find-wordbreak #f word-2-end 'caret)
+			    (let ([word-2-start (box (unbox word-2-end))])
+			      (send edit find-wordbreak word-2-start #f 'caret)
+			      (let ([text-1 (send edit get-text
+						  (unbox word-1-start)
+						  (unbox word-1-end))]
+				    [text-2 (send edit get-text
+						  (unbox word-2-start)
+						  (unbox word-2-end))])
+				(send* edit
+                                  (begin-edit-sequence)
+                                  (insert text-1 
+                                          (unbox word-2-start)
+                                          (unbox word-2-end))
+                                  (insert text-2 
+                                          (unbox word-1-start)
+                                          (unbox word-1-end))
+                                  (set-position (unbox word-2-end))
+                                  (end-edit-sequence))))))))))]
+	       
+	       [capitalize-it
+		(λ (edit char-case1 char-case2)
+		  (let ([sel-start (send edit get-start-position)]
+			[sel-end (send edit get-end-position)]
+			[real-end (send edit last-position)])
+		    (when (= sel-start sel-end)
+		      (let ([word-end (let ([b (box sel-start)])
+					(send edit find-wordbreak #f b 'caret)
+					(min real-end (unbox b)))])
+			(send edit begin-edit-sequence)
+			(let loop ([pos sel-start]
+				   [char-case char-case1])
+			  (when (< pos word-end)
+			    (let ([c (send edit get-character pos)])
+			      (cond
+                                [(char-alphabetic? c)
+                                 (send edit insert 
+                                       (list->string
+                                        (list (char-case c)))
+                                       pos (add1 pos))
+                                 (loop (add1 pos) char-case2)]
+                                [else 
+                                 (loop (add1 pos) char-case)]))))
+			(send* edit 
+                          (end-edit-sequence)
+                          (set-position word-end))))))]
+	       
+	       [capitalize-word
+		(λ (edit event)
+		  (capitalize-it edit char-upcase char-downcase))]
+	       [upcase-word
+		(λ (edit event)
+		  (capitalize-it edit char-upcase char-upcase))]
+	       [downcase-word
+		(λ (edit event)
+		  (capitalize-it edit char-downcase char-downcase))]
+	       
+	       [kill-word
+		(λ (edit event)
+		  (let ([sel-start (send edit get-start-position)]
+			[sel-end (send edit get-end-position)])
+		    (let ([end-box (box sel-end)])
+		      (send edit find-wordbreak #f end-box 'caret)
+		      (send edit kill 0 sel-start (unbox end-box)))))]
+	       
+	       [backward-kill-word
+		(λ (edit event)
+		  (let ([sel-start (send edit get-start-position)]
+			[sel-end (send edit get-end-position)])
+		    (let ([start-box (box sel-start)])
+		      (send edit find-wordbreak start-box #f 'caret)
+		      (send edit kill 0 (unbox start-box) sel-end))))]
+	       
+	       [region-click
+		(λ (edit event f)
+		  (when (and (send event button-down?)
+			     (is-a? edit text%))
+		    (let ([x-box (box (send event get-x))]
+			  [y-box (box (send event get-y))]
+			  [eol-box (box #f)])
+		      (send edit global-to-local x-box y-box)
+		      (let ([click-pos (send edit find-position 
+					     (unbox x-box)
+					     (unbox y-box)
+					     eol-box)]
+			    [start-pos (send edit get-start-position)]
+			    [end-pos (send edit get-end-position)])
+			(let ([eol (unbox eol-box)])
+			  (if (< start-pos click-pos)
+			      (f click-pos eol start-pos click-pos)
+			      (f click-pos eol click-pos end-pos)))))))]
+	       [copy-click-region
+		(λ (edit event)
+		  (region-click edit event
+				(λ (click eol start end)
+				  (send edit flash-on start end)
+				  (send edit copy #f 0 start end))))]
+	       [cut-click-region
+		(λ (edit event)
+		  (region-click edit event
+				(λ (click eol start end)
+				  (send edit cut #f 0 start end))))]
+	       [paste-click-region
+		(λ (edit event)
+		  (region-click edit event
+				(λ (click eol start end)
+				  (send edit set-position click)
+				  (send edit paste-x-selection 0 click))))]
+	       
+	       [mouse-copy-clipboard
+		(λ (edit event)
+		  (send edit copy #f (send event get-time-stamp)))]
+	       
+	       [mouse-paste-clipboard
+		(λ (edit event)
+		  (send edit paste (send event get-time-stamp)))]
+	       
+	       [mouse-cut-clipboard
+		(λ (edit event)
+		  (send edit cut #f (send event get-time-stamp)))]
+	       
+	       [select-click-word
+		(λ (edit event)
+		  (region-click edit event
+				(λ (click eol start end)
+				  (let ([start-box (box click)]
+					[end-box (box click)])
+				    (send edit find-wordbreak 
+					  start-box
+					  end-box
+					  'selection)
+				    (send edit set-position
+					  (unbox start-box)
+					  (unbox end-box))))))]
+	       [select-click-line
+		(λ (edit event)
+		  (region-click edit event
+				(λ (click eol start end)
+				  (let* ([line (send edit position-line 
+						     click eol)]
+					 [start (send edit line-start-position
+						      line #f)]
+					 [end (send edit line-end-position
+						    line #f)])
+				    (send edit set-position start end)))))]
+	       
+	       [goto-line
+		(λ (edit event)
+		  (let ([num-str
+			 (call/text-keymap-initializer
+			  (λ ()
+			    (get-text-from-user
+                             (string-constant goto-line)
+                             (string-constant goto-line))))])
+		    (when (string? num-str)
+		      (let ([line-num (inexact->exact (string->number num-str))])
+			(cond
+                          [(and (number? line-num)
+                                (= line-num (floor line-num))
+                                (<= 1 line-num (+ (send edit last-paragraph) 1)))
+                           (let ([pos (send edit paragraph-start-position 
+                                            (sub1 line-num))])
+                             (send edit set-position pos))]
+                          [else
+                           (message-box
+                            (string-constant goto-line)
+                            (format 
+                             (string-constant goto-line-invalid-number)
+                             num-str
+                             (+ (send edit last-line) 1)))]))))
+                  
+		  #t)]
+	       [goto-position
+		(λ (edit event)
+		  (let ([num-str
+			 (call/text-keymap-initializer
+			  (λ ()
+			    (get-text-from-user 
+                             (string-constant goto-position)
+                             (string-constant goto-position))))])
+		    (if (string? num-str)
+			(let ([pos (string->number num-str)])
+			  (when pos
+                            (send edit set-position (sub1 pos))))))
+		  #t)]
+	       [repeater
+		(λ (n edit)
+		  (let* ([km (send edit get-keymap)]
+			 [done
+			  (λ ()
+			    (send km set-break-sequence-callback void)
+			    (send km remove-grab-key-function))])
+		    (send km set-grab-key-function
+			  (λ (name local-km edit event)
+			    (if name
+				(begin
+				  (done)
+				  (dynamic-wind
+				   (λ ()
+				     (send edit begin-edit-sequence))
+				   (λ ()
+				     (let loop ([n n])
+				       (unless (zero? n)
+					 (send local-km call-function name edit event)
+					 (loop (sub1 n)))))
+				   (λ ()
+				     (send edit end-edit-sequence))))
+				(let ([k (send event get-key-code)])
+				  (if (and (char? k) (char<=? #\0 k #\9))
+				      (set! n (+ (* n 10) (- (char->integer k)
+							     (char->integer #\0))))
+				      (begin
+					(done)
+					(dynamic-wind
+					 (λ ()
+					   (send edit begin-edit-sequence))
+					 (λ ()
+					   (let loop ([n n])
+					     (unless (zero? n)
+					       (send edit on-char event)
+					       (loop (sub1 n)))))
+					 (λ ()
+					   (send edit end-edit-sequence)))))))			       
+			    #t))
+		    (send km set-break-sequence-callback done)
+		    #t))]
+	       [make-make-repeater
+		(λ (n)
+		  (λ (edit event)
+		    (repeater n edit)))]
+	       [current-macro '()] 
+	       [building-macro #f] [build-macro-km #f] [build-protect? #f]
+               [show/hide-keyboard-macro-icon
+                (λ (edit on?)
+                  (when (is-a? edit editor:basic<%>)
+                    (let ([frame (send edit get-top-level-window)])
+                      (when (is-a? frame frame:text-info<%>)
+                        (send frame set-macro-recording on?)
+                        (send frame update-shown)))))]
+               
+	       [do-macro
+		(λ (edit event)
+                  ; If c:x;e during record, copy the old macro
+		  (when building-macro
+		    (set! building-macro (append (reverse current-macro) 
+						 (cdr building-macro))))
+		  (let ([bm building-macro]
+			[km (send edit get-keymap)])
+		    (dynamic-wind
+		     (λ ()
+		       (set! building-macro #f)
+		       (send edit begin-edit-sequence))
+		     (λ ()
+		       (let/ec escape
+			 (for-each
+			  (λ (f)
+			    (let ([name (car f)]
+				  [event (cdr f)])
+			      (if name
+				  (unless (send km call-function name edit event #t)
+				    (escape #t))
+				  (send edit on-char event))))
+			  current-macro)))
+		     (λ ()
+		       (send edit end-edit-sequence)
+		       (set! building-macro bm))))
+		  #t)]
+	       [start-macro
+		(λ (edit event)
+		  (if building-macro
+		      (send build-macro-km break-sequence)
+		      (letrec ([km (send edit get-keymap)]
+			       [done
+				(λ ()
+				  (if build-protect?
+				      (send km set-break-sequence-callback done)
+				      (begin
+					(set! building-macro #f)
+                                        (show/hide-keyboard-macro-icon edit #f)
+					(send km set-break-sequence-callback void)
+					(send km remove-grab-key-function))))])
+			(set! building-macro '())
+                        (show/hide-keyboard-macro-icon edit #t)
+			(set! build-macro-km km)
+			(send km set-grab-key-function
+			      (λ (name local-km edit event)
+				(dynamic-wind
+				 (λ ()
+				   (set! build-protect? #t))
+				 (λ ()
+				   (if name
+				       (send local-km call-function name edit event)
+				       (send edit on-default-char event)))
+				 (λ ()
+				   (set! build-protect? #f)))
+				(when building-macro
+				  (set! building-macro 
+					(cons (cons name event)
+					      building-macro)))
+				#t))
+			(send km set-break-sequence-callback done)))
+		  #t)]
+	       [end-macro
+		(λ (edit event)
+		  (when building-macro
+		    (set! current-macro (reverse building-macro))
+		    (set! build-protect? #f)		    
+		    (send build-macro-km break-sequence))
+		  #t)]
+	       [delete-key
+		(λ (edit event)
+		  (let ([kmap (send edit get-keymap)])
+		    (send kmap call-function
+			  (if (preferences:get 'framework:delete-forward?)
+			      "delete-next-character"
+			      "delete-previous-character")
+			  edit event #t)))]
+               
+	       [toggle-overwrite
+		(λ (edit event)
+		  (send edit set-overwrite-mode
+			(not (send edit get-overwrite-mode))))]
+               
+               [down-into-embedded-editor
+                (λ (text event)
+                  (let ([start (send text get-start-position)]
+                        [end (send text get-end-position)])
+                    (when (= start end)
+                      (let* ([bx (box 0)]
+                             [after-snip (send text find-snip start 'after-or-none bx)])
+                        (cond
+                          [(and (= (unbox bx) start)
+                                after-snip
+                                (is-a? after-snip editor-snip%))
+                           (let ([embedded-editor (send after-snip get-editor)])
+                             (when (is-a? embedded-editor text%)
+                               (send embedded-editor set-position 0))
+                             (send embedded-editor set-caret-owner #f 'global))]
+                          [else
+                           (let ([before-snip (send text find-snip start 'before-or-none bx)])
+                             (when (and (= (+ (unbox bx) 1) start)
+                                        before-snip
+                                        (is-a? before-snip editor-snip%))
+                              (let ([embedded-editor (send before-snip get-editor)])
+                                (when (is-a? embedded-editor text%)
+                                  (send embedded-editor set-position
+                                        (send embedded-editor last-position)))
+                                (send embedded-editor set-caret-owner #f 'global))))]))))
+                  #t)]
+                             
+               [forward-to-next-embedded-editor
+                (λ (text event)
+                  (let ([start-pos (send text get-start-position)]
+                        [end-pos (send text get-end-position)])
+                    (when (= start-pos end-pos)
+                      (let loop ([snip (send text find-snip start-pos 'after-or-none)])
+                        (cond
+                          [(not snip) (void)]
+                          [(is-a? snip editor-snip%)
+                           (send text set-position (send text get-snip-position snip))]
+                          [else (loop (send snip next))]))))
+                  #t)]
+               
+               [back-to-prev-embedded-editor
+                (λ (text event)
+                  (let ([start-pos (send text get-start-position)]
+                        [end-pos (send text get-end-position)])
+                    (when (= start-pos end-pos)
+                      (let loop ([snip (send text find-snip start-pos 'before-or-none)])
+                        (cond
+                          [(not snip) (void)]
+                          [(is-a? snip editor-snip%)
+                           (send text set-position (+ (send text get-snip-position snip) 1))]
+                          [else (loop (send snip previous))]))))
+                  #t)]
+               
+               [up-out-of-embedded-editor
+		(λ (text event)
+                  (let ([start (send text get-start-position)]
+                        [end (send text get-end-position)])
+                    (when (= start end)
+                      (let ([editor-admin (send text get-admin)])
+                        (when (is-a? editor-admin editor-snip-editor-admin<%>)
+                          (let* ([snip (send editor-admin get-snip)]
+                                 [snip-admin (send snip get-admin)])
+                            (when snip-admin
+                              (let ([editor (send snip-admin get-editor)])
+                                (when (is-a? editor text%)
+                                  (let ([new-pos (send editor get-snip-position snip)])
+                                    (send editor set-position new-pos new-pos))
+                                  (send editor set-caret-owner #f 'display)))))))))
+		  #t)]
+               
+               [make-read-only
+                (λ (text event)
+                  (send text lock #t)
+                  #t)])
+               
+	  (λ (kmap)
+	    (let* ([map (λ (key func) 
+			  (send kmap map-function key func))]
+		   [map-meta (λ (key func)
+			       (send-map-function-meta kmap key func))]
+		   [add (λ (name func)
+			  (send kmap add-function name func))]
+		   [add-m (λ (name func)
+			    (send kmap add-function name func))])
+              
+              ; Map names to keyboard functions
+
+	      (add "down-into-embedded-editor" down-into-embedded-editor)
+              (add "up-out-of-embedded-editor" up-out-of-embedded-editor)
+              (add "forward-to-next-embedded-editor" forward-to-next-embedded-editor)
+              (add "back-to-prev-embedded-editor" back-to-prev-embedded-editor)
+
+	      (add "toggle-overwrite" toggle-overwrite)
+	      
+	      (add "exit" (λ (edit event)
+			    (let ([frame (send edit get-frame)])
+			      (if (and frame
+				       (is-a? frame frame:standard-menus<%>))
+				  (send frame file-menu:quit)
+				  (bell)))))
+	      
+	      (add "ring-bell" ring-bell)
+	      
+	      (add "insert-()-pair" (make-insert-brace-pair "(" ")"))
+	      (add "insert-[]-pair" (make-insert-brace-pair "[" "]"))
+	      (add "insert-{}-pair" (make-insert-brace-pair "{" "}"))
+	      (add "insert-\"\"-pair" (make-insert-brace-pair "\"" "\""))
+	      (add "insert-||-pair" (make-insert-brace-pair "|" "|"))
+              (add "insert-lambda-template" insert-lambda-template)
+	     
+	      (add "toggle-anchor" toggle-anchor)
+	      (add "center-view-on-line" center-view-on-line)
+	      (add "collapse-space" collapse-space)
+	      (add "remove-space" remove-space)
+	      (add "collapse-newline" collapse-newline)
+	      (add "open-line" open-line)
+	      (add "transpose-chars" transpose-chars)
+	      (add "transpose-words" transpose-words)
+	      (add "capitalize-word" capitalize-word)
+	      (add "upcase-word" upcase-word)
+	      (add "downcase-word" downcase-word)
+	      (add "kill-word" kill-word)
+	      (add "backward-kill-word" backward-kill-word)
+	      
+	      (let loop ([n 9])
+		(unless (negative? n)
+		  (let ([s (number->string n)])
+		    (add (string-append "command-repeat-" s)
+			 (make-make-repeater n))
+		    (loop (sub1 n)))))
+	      
+	      (add "keyboard-macro-run-saved" do-macro)
+	      (add "keyboard-macro-start-record" start-macro)
+	      (add "keyboard-macro-end-record" end-macro)
+	      
+	      (add-m "copy-clipboard" mouse-copy-clipboard)
+	      (add-m "cut-clipboard" mouse-cut-clipboard)
+	      (add-m "paste-clipboard" mouse-paste-clipboard)
+	      (add-m "copy-click-region" copy-click-region)
+	      (add-m "cut-click-region" cut-click-region)
+	      (add-m "paste-click-region" paste-click-region)
+	      (add-m "select-click-word" select-click-word)
+	      (add-m "select-click-line" select-click-line)
+	      
+	      (add "goto-line" goto-line)
+	      (add "goto-position" goto-position)
+	      
+	      (add "delete-key" delete-key)
+              
+	      (add "mouse-popup-menu" mouse-popup-menu)
+
+	      (add "make-read-only" make-read-only)
+              
+              ; Map keys to functions
+              
+              (map-meta "c:down" "down-into-embedded-editor")
+              (map "a:c:down" "down-into-embedded-editor")
+              (map-meta "c:up" "up-out-of-embedded-editor")
+              (map "a:c:up" "up-out-of-embedded-editor")
+              (map-meta "c:right" "forward-to-next-embedded-editor")
+              (map "a:c:right" "forward-to-next-embedded-editor")
+              (map-meta "c:left" "back-to-prev-embedded-editor")
+              (map "a:c:left" "back-to-prev-embedded-editor")
+              
+	      (map "c:g" "ring-bell")
+	      (map-meta "c:g" "ring-bell")
+	      (map "c:x;c:g" "ring-bell")
+	      (map "c:c;c:g" "ring-bell")
+	      
+	      (map-meta "(" "insert-()-pair")
+	      (map-meta "[" "insert-[]-pair")
+	      (map-meta "{" "insert-{}-pair")
+	      (map-meta "\"" "insert-\"\"-pair")
+	      (map-meta "|" "insert-||-pair")
+	      (map-meta "s:l" "insert-lambda-template")
+
+	      (map "c:p" "previous-line")
+	      (map "up" "previous-line")
+	      (map "s:c:p" "select-up")
+	      (map "s:up" "select-up")
+	      
+	      (map "c:n" "next-line")
+	      (map "down" "next-line")
+	      (map "s:c:n" "select-down")
+	      (map "s:down" "select-down")
+	      
+	      (map "c:e" "end-of-line")
+	      (map "d:right" "end-of-line")
+	      (map "m:right" "end-of-line")
+	      (map "end" "end-of-line")
+	      (map "m:s:right" "select-to-end-of-line")
+	      (map "s:end" "select-to-end-of-line")
+	      (map "s:c:e" "select-to-end-of-line")
+	      
+	      (map "c:a" "beginning-of-line")
+	      (map "d:left" "beginning-of-line")
+	      (map "m:left" "beginning-of-line")
+	      (map "home" "beginning-of-line")
+	      (map "m:s:left" "select-to-beginning-of-line")
+	      (map "s:home" "select-to-beginning-of-line")
+	      (map "s:c:a" "select-to-beginning-of-line")
+	      
+	      (map "c:f" "forward-character")
+	      (map "right" "forward-character")
+	      (map "s:c:f" "forward-select")
+	      (map "s:right" "forward-select")
+	      
+	      (map "c:b" "backward-character")
+	      (map "left" "backward-character")
+	      (map "s:c:b" "backward-select")
+	      (map "s:left" "backward-select")
+	      
+	      (map-meta "f" "forward-word")
+	      (map "a:right" "forward-word")
+	      (map "c:right" "forward-word")
+	      (map-meta "s:f" "forward-select-word")
+	      (map "a:s:right" "forward-select-word")
+	      (map "c:s:right" "forward-select-word")
+	      
+	      (map-meta "b" "backward-word")
+	      (map "a:left" "backward-word")
+	      
+	      (map "c:left" "backward-word")
+	      (map-meta "s:b" "backward-select-word")
+	      (map "a:s:left" "backward-select-word")
+	      (map "c:s:left" "backward-select-word")
+	      
+	      (map-meta "<" "beginning-of-file")
+	      (map "d:up" "beginning-of-file")
+	      (map "c:home" "beginning-of-file")
+	      (map "s:c:home" "select-to-beginning-of-file")
+	      (map "s:d:up" "select-to-beginning-of-file")
+	      
+	      (map-meta ">" "end-of-file")
+	      (map "d:down" "end-of-file")
+	      (map "c:end" "end-of-file")
+	      (map "s:c:end" "select-to-end-of-file")
+	      (map "s:d:down" "select-to-end-of-file")
+	      
+	      (map "c:v" "next-page")
+	      (map "a:down" "next-page")
+	      (map "pagedown" "next-page")
+	      (map "c:down" "next-page")
+	      (map "s:c:v" "select-page-down")
+	      (map "a:s:down" "select-page-down")
+	      (map "s:pagedown" "select-page-down")
+	      (map "s:c:down" "select-page-down")
+	      
+	      (map-meta "v" "previous-page")
+	      (map "a:up" "previous-page")
+	      (map "pageup" "previous-page")
+	      (map "c:up" "previous-page")
+	      (map-meta "s:v" "select-page-up")
+	      (map "s:a:up" "select-page-up")
+	      (map "s:pageup" "select-page-up")
+	      (map "s:c:up" "select-page-up")
+	      
+	      (map "c:h" "delete-previous-character")
+	      (map "c:d" "delete-next-character")
+	      (map "del" "delete-key")
+	      
+	      (map-meta "d" "kill-word")
+	      (map-meta "del" "backward-kill-word")
+	      (map-meta "c" "capitalize-word")
+	      (map-meta "u" "upcase-word")
+	      (map-meta "l" "downcase-word")
+	      
+	      (map "c:l" "center-view-on-line")
+	      
+	      (map "c:k" "delete-to-end-of-line")
+	      (map "c:y" "paste-clipboard")
+	      (map-meta "y" "paste-next")
+	      (map "a:v" "paste-clipboard")
+	      (map "d:v" "paste-clipboard")
+	      (map "c:_" "undo")
+	      (map "c:/" "undo")
+	      (map (format "~a" (integer->char 31)) "undo") ; for Windows - strange
+	      (map "c:+" "redo")
+	      (map "a:z" "undo")
+	      (map "d:z" "undo")
+	      (map "c:x;u" "undo")
+	      (map "c:w" "cut-clipboard")
+	      (map "a:x" "cut-clipboard")
+	      (map "d:x" "cut-clipboard")
+	      (map-meta "w" "copy-clipboard")
+	      (map "a:c" "copy-clipboard")
+	      (map "d:c" "copy-clipboard")
+	      
+	      (map "s:delete" "cut-clipboard")
+	      (map "c:insert" "copy-clipboard")
+	      (map "s:insert" "paste-clipboard")
+              
+	      (map-meta "space" "collapse-space")
+              ;(map-meta "\\" "remove-space") ; Conflicts with european keyboards.
+	      (map "c:x;c:o" "collapse-newline")
+	      (map "c:o" "open-line")
+	      (map "c:t" "transpose-chars")
+	      (map-meta "t" "transpose-words")
+	      
+	      (map "c:space" "toggle-anchor")
+	      
+	      (map "insert" "toggle-overwrite")
+	      (map-meta "o" "toggle-overwrite")
+	      
+	      (map-meta "g" "goto-line")
+	      (map-meta "p" "goto-position")
+	      
+	      (map "c:u" "command-repeat-0")
+	      (let loop ([n 9])
+		(unless (negative? n)
+		  (let ([s (number->string n)])
+		    (map-meta s (string-append "command-repeat-" s))
+		    (loop (sub1 n)))))
+	      
+	      (map "c:x;e" "keyboard-macro-run-saved")
+	      (map "c:x;(" "keyboard-macro-start-record")
+	      (map "c:x;)" "keyboard-macro-end-record")
+	      
+	      (map "leftbuttontriple" "select-click-line")
+	      (map "leftbuttondouble" "select-click-word")
+	      
+	      ;; the "roller ball" mice map clicking the ball to button 2.
+	      (unless (eq? (system-type) 'windows)
+		(map "middlebutton" "paste-click-region"))
+              
+	      (map ":rightbuttonseq" "mouse-popup-menu")
+              
+              (map "c:c;c:r" "make-read-only")
+              ))))
+      
+      (define setup-search
+	(let* ([send-frame
+		(λ (invoke-method)
+		  (λ (edit event)
+		    (let ([frame
+			   (cond
+                             [(is-a? edit editor<%>)
+                              (let ([canvas (send edit get-active-canvas)])
+                                (and canvas
+                                     (send canvas get-top-level-window)))]
+                             [(is-a? edit area<%>)
+                              (send edit get-top-level-window)]
+                             [else #f])])
+		      (if frame
+			  (invoke-method frame)
+			  (bell)))
+		    #t))])
+	  (λ (kmap)
+	    (let* ([map (λ (key func) 
+			  (send kmap map-function key func))]
+		   [map-meta (λ (key func)
+			       (send-map-function-meta kmap key func))]
+		   [add (λ (name func)
+			  (send kmap add-function name func))]
+		   [add-m (λ (name func)
+			    (send kmap add-function name func))])
+	      
+	      (add "move-to-search-or-search" 
+		   (send-frame (λ (f) (send f move-to-search-or-search)))) ;; key 1
+	      (add "move-to-search-or-reverse-search" 
+		   (send-frame (λ (f) (send f move-to-search-or-reverse-search)))) ;; key 1b, backwards
+	      (add "find-string-again" 
+		   (send-frame (λ (f) (send f search-again)))) ;; key 2
+	      (add "toggle-search-focus" 
+		   (send-frame (λ (f) (send f toggle-search-focus)))) ;; key 3
+	      (add "hide-search" 
+		   (send-frame (λ (f) (send f hide-search)))) ;; key 4
+	      
+	      (case (system-type)
+		[(unix)
+		 (map "c:s" "move-to-search-or-search")
+		 (map-meta "%" "move-to-search-or-search")
+		 (map "c:r" "move-to-search-or-reverse-search")
+		 (map "f3" "find-string-again")
+		 (map "c:i" "toggle-search-focus")
+		 (map "c:g" "hide-search")]
+		[(windows)
+		 (map "c:r" "move-to-search-or-reverse-search")
+		 (map "f3" "find-string-again")
+		 (map "c:g" "find-string-again")	     
+                 
+		 ;; covered by menu
+                 ;(map "c:f" "move-to-search-or-search")
+                 
+		 (map "c:i" "toggle-search-focus")]
+		[(macos macosx)
+		 (map "c:s" "move-to-search-or-search")
+		 (map "c:g" "hide-search")
+                 
+		 ;; covered by menu
+                 ;(map "d:f" "move-to-search-or-search")
+                 
+		 (map "c:r" "move-to-search-or-reverse-search")
+		 (map "d:g" "find-string-again")
+		 (map "c:i" "toggle-search-focus")])))))
+      
+      (define setup-file
+	(let* ([get-outer-editor ;; : text% -> text%
+                ;; returns the outermost editor, if this editor is nested in an editor snip.
+                (λ (edit)
+                  (let loop ([edit edit])
+                    (let ([admin (send edit get-admin)])
+                      (cond
+                        [(is-a? admin editor-snip-editor-admin<%>)
+                         (loop (send (send (send admin get-snip) get-admin) get-editor))]
+                        [else edit]))))]
+               [save-file-as
+		(λ (this-edit event)
+                  (let ([edit (get-outer-editor this-edit)])
+                    (parameterize ([finder:dialog-parent-parameter 
+                                    (and (is-a? edit editor:basic<%>)
+                                         (send edit get-top-level-window))])
+                      (let ([file (finder:put-file)])
+                        (when file
+                          (send edit save-file/gui-error file)))))
+                  #t)]
+	       [save-file
+		(λ (this-edit event)
+                  (let ([edit (get-outer-editor this-edit)])
+                    (if (send edit get-filename)
+                        (send edit save-file/gui-error)
+                        (save-file-as edit event)))
+		  #t)]
+	       [load-file
+		(λ (edit event)
+		  (handler:open-file)
+		  #t)])
+	  (λ (kmap)
+	    (let* ([map (λ (key func) 
+			  (send kmap map-function key func))]
+		   [map-meta (λ (key func)
+			       (send-map-function-meta kmap key func))]
+		   [add (λ (name func)
+			  (send kmap add-function name func))]
+		   [add-m (λ (name func)
+			    (send kmap add-function name func))])
+	      
+	      (add "save-file" save-file)
+	      (add "save-file-as" save-file-as)
+	      (add "load-file" load-file)
+	      
+	      (map "c:x;c:s" "save-file")
+	      (map "d:s" "save-file")
+	      (map "c:x;c:w" "save-file-as")
+	      (map "c:x;c:f" "load-file")))))
+      
+      (define (setup-editor kmap)
+	(let ([add/map
+	       (λ (func op key)
+		 (send kmap add-function
+		       func
+		       (λ (editor evt)
+			 (send editor do-edit-operation op)))
+		 (send kmap map-function
+		       (string-append
+			(case (system-type)
+			  [(macosx macos) "d:"]
+			  [(windows) "c:"]
+			  [(unix) "a:"]
+			  [else (error 'keymap.ss "unknown platform: ~s" (system-type))])
+			key)
+		       func))])
+	  (add/map "editor-undo" 'undo "z")
+	  (add/map "editor-redo" 'redo "y")
+	  (add/map "editor-cut" 'cut "x")
+	  (add/map "editor-copy" 'copy "c")
+	  (add/map "editor-paste" 'paste "v")
+	  (add/map "editor-select-all" 'select-all "a")))
+      
+      (define (generic-setup keymap)
+	(add-editor-keymap-functions keymap)
+	(add-pasteboard-keymap-functions keymap)
+	(add-text-keymap-functions keymap))
+      
+      (define global (make-object aug-keymap%))
+      (define global-main (make-object aug-keymap%))
+      (send global chain-to-keymap global-main #t)
+      (setup-global global-main)
+      (generic-setup global-main)
+      (define (get-global) global)
+      
+      (define file (make-object aug-keymap%))
+      (setup-file file)
+      (generic-setup file)
+      (define (-get-file) file)
+      
+      (define search (make-object aug-keymap%))
+      (generic-setup search)
+      (setup-search search)
+      (define (get-search) search)
+      
+      (define editor (make-object aug-keymap%))
+      (setup-editor editor)
+      (define (get-editor) editor)
+      
+      (define (call/text-keymap-initializer thunk)
+	(let ([ctki (current-text-keymap-initializer)])
+	  (parameterize ([current-text-keymap-initializer
+			  (λ (keymap)
+			    (send keymap chain-to-keymap global #t)
+			    (ctki keymap))])
+	    (thunk)))))))
diff --git a/collects/framework/private/main.ss b/collects/framework/private/main.ss
new file mode 100644
index 0000000000..ef397ec647
--- /dev/null
+++ b/collects/framework/private/main.ss
@@ -0,0 +1,295 @@
+(module main mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "class.ss")
+	   "sig.ss"
+	   "../gui-utils.ss"
+           (lib "string-constant.ss" "string-constants")
+	   (lib "mred-sig.ss" "mred"))
+  
+  (provide main@)
+
+  (define main@
+    (unit/sig framework:main^
+      (import mred^
+	      [preferences : framework:preferences^]
+	      [exit : framework:exit^]
+	      [group : framework:group^]
+              [handler : framework:handler^]
+              [editor : framework:editor^]
+              [color-prefs : framework:color-prefs^]
+              [scheme : framework:scheme^])
+      
+      (application-preferences-handler (λ () (preferences:show-dialog)))
+      
+      (preferences:set-default 'framework:basic-canvas-background
+                               (send the-color-database find-color "white")
+                               (λ (x) (is-a? x color%)))
+      (preferences:set-un/marshall 
+       'framework:basic-canvas-background
+       (λ (clr) (list (send clr red) (send clr green) (send clr blue)))
+       (λ (lst) (and (pair? lst)
+                          (pair? (cdr lst))
+                          (pair? (cddr lst))
+                          (null? (cdddr lst))
+                          (make-object color% (car lst) (cadr lst) (caddr lst)))))
+      
+      (preferences:set-default 'framework:special-option-key #f boolean?)
+      (preferences:add-callback 'framework:special-option-key (λ (p v) (special-option-key v)))
+      (special-option-key (preferences:get 'framework:special-option-key))
+      
+      (preferences:set-default 'framework:fraction-snip-style 'mixed (λ (x) (memq x '(mixed improper))))
+      
+      (preferences:set-default 'framework:standard-style-list:font-name
+                               (get-family-builtin-face 'modern)
+                               string?)
+      
+      (preferences:set-default
+       'framework:standard-style-list:font-size
+       (let* ([txt (make-object text%)]
+              [stl (send txt get-style-list)]
+              [bcs (send stl basic-style)])
+         (send bcs get-size))
+       (λ (x) (and (number? x) (exact? x) (integer? x) (positive? x))))
+      
+      (preferences:set-default
+       'framework:standard-style-list:smoothing
+       'default
+       (λ (x) 
+         (memq x '(unsmoothed partly-smoothed smoothed default))))
+      
+      (editor:set-standard-style-list-pref-callbacks)
+      
+      (preferences:set-default 'framework:paren-match-color
+                               (let ([gray-level
+                                      ;; old gray-level 192
+                                      (if (eq? (system-type) 'windows)
+                                          (* 3/4 256)
+                                          (- (* 7/8 256) 1))])
+                                 (make-object color% gray-level gray-level gray-level))
+                               (λ (x) (is-a? x color%)))
+      
+      (preferences:set-un/marshall
+       'framework:paren-match-color
+       (λ (c) (list (send c red) (send c green) (send c blue)))
+       (λ (l) (make-object color% (car l) (cadr l) (caddr l))))
+      
+      (preferences:set-default 'framework:recently-opened-files/pos 
+                               null 
+                               (λ (x) (and (list? x) 
+                                                (andmap
+                                                 (λ (x) 
+                                                   (and (list? x)
+                                                        (= 3 (length x))
+                                                        (path? (car x))
+                                                        (number? (cadr x))
+                                                        (number? (caddr x))))
+                                                 x))))
+      
+      (preferences:set-un/marshall
+       'framework:recently-opened-files/pos
+       (λ (l) (map (λ (ele) (cons (path->bytes (car ele)) (cdr ele))) l))
+       (λ (l) 
+         (let/ec k
+           (unless (list? l)
+             (k '()))
+           (map (λ (x)
+                  (unless (and (list? x)
+                               (= 3 (length x))
+                               (bytes? (car x))
+                               (number? (cadr x))
+                               (number? (caddr x)))
+                    (k '()))
+                  (cons (bytes->path (car x)) (cdr x)))
+                l))))
+      
+      (preferences:set-default 'framework:last-directory 
+                               (find-system-path 'doc-dir) 
+                               (λ (x) (or (not x) path-string?)))
+      
+      (preferences:set-un/marshall 'framework:last-directory 
+                                   (λ (x) (and (path? x) (path->bytes x)))
+                                   (λ (x)
+                                     (and (bytes? x)
+                                          (bytes->path x))))
+
+      (preferences:set-default 'framework:recent-max-count 
+                               50 
+                               (λ (x) (and (number? x)
+                                                (x . > . 0) 
+                                                (integer? x))))
+      (preferences:add-callback
+       'framework:recent-max-count
+       (λ (p v)
+         (handler:size-recently-opened-files v)))
+      
+      (preferences:set-default 'framework:last-url-string "" string?)
+      (preferences:set-default 'framework:recently-opened-sort-by 'age 
+                               (λ (x) (or (eq? x 'age) (eq? x 'name))))
+      (preferences:set-default 'framework:recent-items-window-w 400 number?)
+      (preferences:set-default 'framework:recent-items-window-h 600 number?)
+      (preferences:set-default 'framework:open-here? #f boolean?)
+      (preferences:set-default 'framework:show-delegate? #f boolean?)
+      (preferences:set-default 'framework:search-using-dialog? #t boolean?)
+      (preferences:set-default 'framework:windows-mdi #f boolean?)
+      (preferences:set-default 'framework:menu-bindings #t boolean?)
+      (preferences:set-default 'framework:verify-change-format #f boolean?)
+      (preferences:set-default 'framework:auto-set-wrap? #t boolean?)
+      (preferences:set-default 'framework:display-line-numbers #t boolean?)
+      (preferences:set-default 'framework:show-status-line #t boolean?)
+      (preferences:set-default 'framework:col-offsets #f boolean?)
+      
+      (preferences:set-default
+       'framework:print-output-mode
+       'standard
+       (λ (x) (or (eq? x 'standard) (eq? x 'postscript))))
+      
+      (preferences:set-default 'framework:highlight-parens #t boolean?)
+      (preferences:set-default 'framework:fixup-parens #t boolean?)
+      (preferences:set-default 'framework:paren-match #t boolean?)
+      (let ([hash-table (make-hash-table)])
+	(for-each (λ (x) 
+                    (hash-table-put! hash-table x 'define))
+                  '())
+	(for-each (λ (x) 
+		    (hash-table-put! hash-table x 'begin))
+		  '(case-lambda
+                     match-lambda match-lambda*
+                     cond
+                     delay
+                     unit compound-unit compound-unit/sig
+                     public private override
+                     inherit sequence))
+	(for-each (λ (x) 
+		    (hash-table-put! hash-table x 'lambda))
+		  '(
+		    cases
+                       instantiate super-instantiate
+                     syntax/loc quasisyntax/loc
+                     
+                     
+                     λ lambda let let* letrec recur
+                     letrec-values
+                     with-syntax
+		     with-continuation-mark
+                     module
+		     match match-let match-let* match-letrec
+                     let/cc let/ec letcc catch
+                     let-syntax letrec-syntax fluid-let-syntax letrec-syntaxes+values
+                     
+                     kernel-syntax-case
+                     syntax-case syntax-case* syntax-rules
+                     let-signature fluid-let
+                     let-struct let-macro let-values let*-values
+                     case when unless 
+                     let-enumerate
+                     class class* class-asi class-asi* class*/names
+                     class100 class100* class100-asi class100-asi* class100*/names
+                     rec
+                     make-object mixin
+                     define-some do opt-lambda
+		     send* with-method
+                     define-record
+                     local catch shared
+                     unit/sig unit/lang
+                     with-handlers
+                     interface
+                     parameterize
+                     call-with-input-file call-with-input-file* with-input-from-file
+                     with-input-from-port call-with-output-file
+                     with-output-to-file with-output-to-port))
+	(preferences:set-default 
+         'framework:tabify
+         (list hash-table #rx"^begin" #rx"^def" #f)
+         (λ (x)
+           (and (list? x)
+                (= (length x) 4)
+                (hash-table? (car x))
+                (andmap (λ (x) (or (regexp? x) (not x))) (cdr x)))))
+	(preferences:set-un/marshall
+	 'framework:tabify 
+	 (λ (t) (cons (hash-table-map (car t) list)
+                           (cdr t)))
+	 (λ (l) 
+           (and (list? l)
+                (= (length l) 4)
+                (andmap (λ (x) (or (regexp? x) (not x)))
+                        (cdr l))
+                (andmap (λ (x) (and (list? x)
+                                         (= 2 (length x))
+                                         (andmap symbol? x)))
+                        (car l))
+                (let ([h (make-hash-table)])
+                  (for-each (λ (x) (apply hash-table-put! h x)) (car l))
+                  (cons h (cdr l)))))))
+      
+      
+      (preferences:set-default 'framework:autosave-delay 300 number?)
+      (preferences:set-default 'framework:autosaving-on? #t boolean?)
+      (preferences:set-default 'framework:backup-files? #t boolean?)
+      (preferences:set-default 'framework:verify-exit #t boolean?)
+      (preferences:set-default 'framework:delete-forward? 
+			       (not (eq? (system-type) 'unix))
+			       boolean?)
+      (preferences:set-default 'framework:show-periods-in-dirlist #f boolean?)
+      (preferences:set-default
+       'framework:file-dialogs
+       'std
+       (λ (x)
+	 (or (eq? x 'common)
+	     (eq? x 'std))))
+      
+      ;; scheme prefs
+      
+      (for-each (λ (line)
+                  (let ([sym (car line)]
+                        [color (cadr line)])
+                    (color-prefs:register-color-pref (scheme:short-sym->pref-name sym)
+                                                     (scheme:short-sym->style-name sym)
+                                                     color)))
+                (scheme:get-color-prefs-table))
+      (preferences:set-default 'framework:coloring-active #t boolean?)
+
+      (preferences:set-default 'framework:default-text-color 
+                               (send the-color-database find-color "Black")
+                               (λ (x) (is-a? x color%)))
+      
+      (preferences:set-un/marshall 'framework:default-text-color 
+                                   (λ (c) (list (send c red) (send c green) (send c blue)))
+                                   (λ (lst) 
+                                     (make-object color% (car lst) (cadr lst) (caddr lst))))
+      (preferences:add-callback 'framework:default-text-color
+                                (λ (p v)
+                                  (editor:set-default-font-color v)))
+      
+      ;; groups
+      
+      (preferences:set-default 'framework:exit-when-no-frames #t boolean?)
+
+      (exit:insert-can?-callback
+       (λ ()
+         (send (group:get-the-frame-group) can-close-all?)))    
+      
+      (exit:insert-on-callback
+       (λ ()
+         (send (group:get-the-frame-group) on-close-all)
+         (preferences:silent-save) ;; the prefs may have changed as a result of closing the windows...
+         ))
+      
+      (exit:insert-can?-callback 
+       (λ ()
+         (or (preferences:save)
+             (exit-anyway?))))
+      
+      (define (exit-anyway?)
+        (gui-utils:get-choice
+         (string-constant still-locked-exit-anyway?)
+         (string-constant yes)
+         (string-constant no)
+         (string-constant drscheme)))
+
+      ;; reset these -- they are only for the test suite.
+      ;; they do not need to be set across starting up and shutting down
+      ;; the application.
+      ;(preferences:set 'framework:file-dialogs 'std)
+      
+      (void))))
diff --git a/collects/framework/private/menu.ss b/collects/framework/private/menu.ss
new file mode 100644
index 0000000000..c890e4fbd0
--- /dev/null
+++ b/collects/framework/private/menu.ss
@@ -0,0 +1,52 @@
+(module menu mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "class.ss")
+	   "sig.ss"
+	   (lib "mred-sig.ss" "mred"))
+  
+  (provide menu@)
+  
+  (define menu@
+    (unit/sig framework:menu^
+      (import mred^
+              [preferences : framework:preferences^])
+      
+      (define can-restore<%>
+        (interface (selectable-menu-item<%>)
+          restore-keybinding))
+      
+      (define can-restore-mixin
+        (mixin (selectable-menu-item<%>) (can-restore<%>)
+          (inherit set-shortcut get-shortcut)
+          (define saved-shortcut 'not-yet)
+          (define/public (restore-keybinding)
+            (unless (eq? saved-shortcut 'not-yet)
+              (set-shortcut saved-shortcut)))
+          
+          (super-new)
+          (set! saved-shortcut (get-shortcut))
+          (unless (preferences:get 'framework:menu-bindings)
+            (set-shortcut #f))))
+      
+      (define can-restore-underscore<%>
+        (interface (labelled-menu-item<%>)
+          erase-underscores
+          restore-underscores))
+      
+      (define can-restore-underscore-mixin
+        (mixin (labelled-menu-item<%>) (can-restore-underscore<%>)
+          (inherit get-label get-plain-label set-label)
+          (define/public (erase-underscores)
+            (set-label (get-plain-label)))
+          (define/public (restore-underscores)
+            (unless (eq? saved-label 'not-yet-saved-label)
+              (set-label saved-label)))
+          (define saved-label 'not-yet-saved-label)
+          (super-new)
+          (set! saved-label (get-label))
+          (unless (preferences:get 'framework:menu-bindings)
+            (erase-underscores))))
+      
+      (define can-restore-menu-item% (can-restore-mixin menu-item%))
+      (define can-restore-checkable-menu-item% (can-restore-mixin checkable-menu-item%))
+      (define can-restore-underscore-menu% (can-restore-underscore-mixin menu%)))))
diff --git a/collects/framework/private/mode.ss b/collects/framework/private/mode.ss
new file mode 100644
index 0000000000..90adb9068a
--- /dev/null
+++ b/collects/framework/private/mode.ss
@@ -0,0 +1,54 @@
+(module mode mzscheme
+  (require (lib "surrogate.ss")
+           (lib "unitsig.ss")
+	   (lib "class.ss")
+           "sig.ss")
+  
+  (provide mode@)
+  
+  (define mode@
+    (unit/sig framework:mode^
+      (import)
+      
+      (define-values (host-text-mixin host-text<%> surrogate-text% surrogate-text<%>)
+        (surrogate
+         (augment (void) on-change ())
+         (override on-char (event))
+         (override on-default-char (event))
+         (override on-default-event (event))
+         (augment (void) on-display-size ())
+         (augment (void) on-edit-sequence ())
+         (override on-event (event))
+         (override on-focus (on?))
+         (augment (void) on-load-file (filename format))
+         (override on-local-char (event))
+         (override on-local-event (event))
+         (override on-new-box (type))
+         (override on-new-image-snip (filename kind relative-path? inline?))
+         (override on-paint (before? dc left top right bottom dx dy draw-caret))
+         (augment (void) on-save-file (filename format))
+         (augment (void) on-snip-modified (snip modified?))
+         
+         (augment (void) on-change-style (start len))
+         (augment (void) on-delete (start len))
+         (augment (void) on-insert (start len))
+         (override on-new-string-snip ())
+         (override on-new-tab-snip ())
+         (augment (void) on-set-size-constraint ())
+         
+         (augment (void) after-change-style (start len))
+         (augment (void) after-delete (start len))
+         (augment (void) after-insert (start len))
+         (augment (void) after-set-position ())
+         (augment (void) after-set-size-constraint ())
+         (augment (void) after-edit-sequence ())
+         (augment (void) after-load-file (success?))
+         (augment (void) after-save-file (success?))
+         
+         (augment #t can-change-style? (start len))
+         (augment #t can-delete? (start len))
+         (augment #t can-insert? (start len))
+         (augment #t can-set-size-constraint? ())
+         (override can-do-edit-operation? (op) (op recursive?))
+         (augment #t can-load-file? (filename format))
+         (augment #t can-save-file? (filename format)))))))
diff --git a/collects/framework/private/number-snip.ss b/collects/framework/private/number-snip.ss
new file mode 100644
index 0000000000..9f606e033e
--- /dev/null
+++ b/collects/framework/private/number-snip.ss
@@ -0,0 +1,516 @@
+
+(module number-snip mzscheme
+  (require (lib "unitsig.ss")
+           "sig.ss"
+	   (lib "mred-sig.ss" "mred")
+	   (lib "class.ss")
+           (lib "string-constant.ss" "string-constants"))
+  
+  (provide number-snip@)
+  
+  (define number-snip@
+    (unit/sig framework:number-snip^
+      (import mred^
+              [preferences : framework:preferences^])
+      (rename [-snip-class% snip-class%])
+      
+      ;; make-repeating-decimal-snip : number boolean -> snip
+      (define (make-repeating-decimal-snip number e-prefix?)
+        (instantiate number-snip% ()
+          [number number]
+          [decimal-prefix (if e-prefix? "#e" "")]))
+      
+      ;; make-fraction-snip : number boolean -> snip
+      (define (make-fraction-snip number e-prefix?)
+        (let ([n (instantiate number-snip% ()
+                   [number number]
+                   [decimal-prefix (if e-prefix? "#e" "")])])
+          (send n set-fraction-view (preferences:get 'framework:fraction-snip-style))
+          n))
+      
+      (define (set-box/f! b v) (when (box? b) (set-box! b v)))
+      (define bw? (< (get-display-depth) 3))
+      
+      (define -snip-class%
+        (class snip-class%
+          (define/override (read f)
+            (let* ([number (string->number (bytes->string/utf-8 (send f get-bytes)))]
+                   [decimal-prefix (bytes->string/utf-8 (send f get-bytes))]
+                   [fraction-bytes (send f get-bytes)]
+                   [expansions (string->number (bytes->string/utf-8 (send f get-bytes)))]
+                   [fraction-view
+                    (cond
+                      [(equal? #"#t" fraction-bytes) 'decimal]
+                      [(equal? #"#f" fraction-bytes) 
+                       (preferences:get 'framework:fraction-snip-style)]
+                      [(equal? #"mixed" fraction-bytes) 'mixed]
+                      [(equal? #"decimal" fraction-bytes) 'decimal]
+                      [(equal? #"improper" fraction-bytes) 'improper])]
+                   [snip
+                    (instantiate number-snip% ()
+                      [number number]
+                      [decimal-prefix decimal-prefix])])
+              (send snip iterate (max 0 (- expansions 1))) ;; one iteration is automatic
+              (send snip set-fraction-view fraction-view)
+              snip))
+          (super-new)))
+      
+      (define number-snipclass (new -snip-class%))
+      (send number-snipclass set-version 3)
+      (send number-snipclass set-classname "drscheme:number")
+      (send (get-the-snip-class-list) add number-snipclass)
+      
+      (define arrow-cursor (make-object cursor% 'arrow))
+      
+      ;; cut-off : number
+      ;; indicates how many digits to fetch for each click
+      (define cut-off 25)
+      
+      (define number-snip%
+        (class* snip% (readable-snip<%>)
+          ;; number : number
+          ;; this is the number to show
+          (init-field number)
+          (define/public (get-number) number)
+          
+          ;; decimal-prefix : string
+          ;; this prefix is shown on the string when it is viewed in
+          ;; the decimal view
+          (init-field [decimal-prefix ""])
+          
+          ;; fraction-view : (union 'decimal 'mixed 'improper)
+          ;; this field holds the current view state
+          (field [fraction-view 'decimal])
+          
+          ;; these fields are for the drawing code for decimal printing
+          (field 
+           ;; clickable-portion : (union #f string)
+           [clickable-portion #f]
+           ;; unbarred-portion : string
+           [unbarred-portion ""]
+           ;; barred-portion : (union #f string)
+           [barred-portion #f])
+          
+          (field
+           ;; wholes/frac : string
+           ;; the whole-number portion of the number as a fraction
+           [wholes/frac
+            (cond
+              [(= (floor number) 0) ""]
+              [(= (ceiling number) 0) "-"]
+              [(< number 0)
+               (number->string (ceiling number))]
+              [else
+               (number->string (floor number))])])
+          
+          (field
+           ;; wholes/dec : string
+           ;; the whole-number portion of decimal expansion
+           [wholes/dec
+            (cond
+              [(= (floor number) 0) "0"]
+              [(= (ceiling number) 0) "-0"]
+              [(< number 0)
+               (number->string (ceiling number))]
+              [else
+               (number->string (floor number))])])
+          
+          ;; these fields are for the fractional printing view
+          (field
+           ;; nums : string
+           ;; the numerator of the mixed fraction, as a string
+           [nums (number->string (numerator (- (abs number) (floor (abs number)))))]
+           
+           ;; improper-nums : string
+           ;; the numerator of the improper fraction, as a string
+           [improper-nums (number->string (numerator (abs number)))]
+           
+           ;; mixed-prefix : string
+           ;; a prefix on the front of the mixed number (indicates if negative)
+           [improper-prefix (if (number . < . 0) "-" "")]
+           
+           ;; dens : string
+           ;; the denominator, as a string
+           [dens (number->string (denominator (- (abs number) (floor (abs number)))))])
+          
+          ;; these fields are for the decimal expansion calculation code
+          (field
+           [init-num (* 10 (numerator (- (abs number) (floor (abs number)))))]
+           [den (denominator (- (abs number) (floor (abs number))))])
+          
+          ;; ht : number -o> (cons digit number)
+          ;; this maps from divisors of the denominator to
+          ;; digit and new divisor pairs. Use this
+          ;; to read off the decimal expansion.
+          (field
+           [ht (make-hash-table 'equal)]
+           [expansions 0])
+          
+          ;; this field holds the state of the current computation
+          ;; of the numbers digits. If it is a number, it corresponds
+          ;; to the next starting divisor in the iteration.
+          ;; if it is #f, it means that the string of digits is
+          ;; fully computed.
+          (field [state init-num])
+          
+          ;; repeat : (union 'unk number #f)
+          ;; this field correlates with `state'. If `state' is a number,
+          ;; this field is 'unk. Otherwise, this is either a number of #f.
+          ;; #f indicates no repeat.
+          ;; a number indiates a repeat starting at `number' in `ht'.
+          (field [repeat 'unk])
+          
+          ;; set-fraction-view : (union 'mixed 'improper 'decimal) -> void
+          ;; sets the view based on the input
+          (define/public (set-fraction-view b)
+            (set! fraction-view b)
+            (let ([admin (get-admin)])
+              (when admin
+                (send admin resized this #t))))
+          
+          ;; get-fraction-view : -> (union 'mixed 'improper 'decimal)
+          ;; returns the current fraction view settings
+          (define/public (get-fraction-view) fraction-view)
+          
+          ;; iterate : number -> void
+          ;; computes the next sequence of digits (`n' times)
+          ;; and update the strings for GUI drawing
+          (define/public (iterate n)
+            (let loop ([n n])
+              (unless (zero? n)
+                (expand-number)
+                (loop (- n 1))))
+            (update-drawing-fields))
+          
+          (inherit get-admin)
+          
+          ;; iterate/reflow : -> void
+          ;; iterates the fraction and tells the administrator to redraw the numbers
+          (define/private (iterate/reflow)
+            (iterate 1)
+            (let ([admin (get-admin)])
+              (when admin
+                (send admin resized this #t))))
+          
+          ;; one-step-division : number -> number number
+          ;; given a numerator and denominator,
+          ;; returns a digits and a new numerator to consider
+          (define/private (one-step-division num)
+            (cond
+              [(num . < . den) (values 0 (* 10 num))]
+              [else
+               (let ([qu (quotient num den)])
+                 (values qu (* 10 (- num (* qu den)))))]))
+          
+          ;; expand-number : -> void
+          ;; iterates until the numbers decimal expansion is completely computed,
+          ;; or the number's decimal expansion terminates.
+          (define/public (expand-number)
+            (when state
+              (set! expansions (+ expansions 1))
+              (let loop ([num state]
+                         [counter cut-off])
+                (cond
+                  [(hash-table-bound? ht num)
+                   (set! state #f)
+                   (set! repeat num)]
+                  [(zero? counter) 
+                   (set! state num)]
+                  [else
+                   (let-values ([(dig next-num) (one-step-division num)])
+                     (if (zero? next-num)
+                         (begin
+                           (hash-table-put! ht num (cons dig #t))
+                           (set! state #f)
+                           (set! repeat #f))
+                         (begin
+                           (hash-table-put! ht num (cons dig next-num))
+                           (loop next-num (- counter 1)))))]))))
+          
+          ;; update-drawing-fields : -> void
+          (define/public (update-drawing-fields)
+            (cond
+              [(number? state) 
+               (set! unbarred-portion
+                     (string-append
+                      decimal-prefix
+                      wholes/dec
+                      "."
+                      (apply string-append (map number->string (extract-non-cycle)))))
+               (set! barred-portion #f)
+               (set! clickable-portion "...")]
+              [(number? repeat)
+               (set! unbarred-portion
+                     (string-append
+                      decimal-prefix
+                      wholes/dec
+                      "."
+                      (apply string-append 
+                             (map number->string (extract-non-cycle)))))
+               (set! barred-portion (apply string-append (map number->string (extract-cycle))))
+               (set! clickable-portion #f)]
+              [else
+               (set! unbarred-portion
+                     (string-append
+                      decimal-prefix
+                      wholes/dec
+                      "."
+                      (apply string-append
+                             (map number->string (extract-non-cycle)))))
+               (set! barred-portion #f)
+               (set! clickable-portion #f)]))
+          
+          ;; extract-cycle : -> (listof digit)
+          ;; pre: (number? repeat)
+          (define/private (extract-cycle)
+            (let ([pr (hash-table-get ht repeat)])
+              (cons (car pr)
+                    (extract-helper (cdr pr)))))
+          
+          ;; extract-non-cycle : -> (listof digit)
+          (define/private (extract-non-cycle) (extract-helper init-num))
+          
+          (define/private (extract-helper start)
+            (let loop ([ind start])
+              (cond
+                [(equal? ind repeat) null]
+                [else
+                 (let* ([iter (hash-table-get ht ind)]
+                        [dig (car iter)]
+                        [next-num (cdr iter)])
+                   (cons dig
+                         (if (hash-table-bound? ht next-num)
+                             (loop next-num)
+                             null)))])))
+          
+          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+          ;;                                                                  ;;
+          ;;                       snip infrastructure                        ;;
+          ;;                                                                  ;;
+          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+          
+          
+          (define/public (read-special file line col pos)
+	    number)
+          
+          (define/override get-text
+            (case-lambda
+              [(offset num) (get-text offset num #f)]
+              [(offset num flattened?) 
+               (case fraction-view
+                 [(mixed)
+                  (cond
+                    [(string=? wholes/frac "")
+                     (string-append nums "/" dens)]
+                    [(string=? wholes/frac "-")
+                     (string-append wholes/frac nums "/" dens)]
+                    [else
+                     (string-append wholes/frac " " nums "/" dens)])]
+                 [(decimal)
+                  (string-append 
+                   unbarred-portion
+                   (or barred-portion "")
+                   (or clickable-portion ""))]
+                 [(improper) (string-append 
+                              improper-prefix
+                              improper-nums
+                              "/"
+                              dens)])]))
+          
+          (define/override (write f)
+            (send f put (string->bytes/utf-8 (number->string number)))
+            (send f put (string->bytes/utf-8 decimal-prefix))
+            (send f put (string->bytes/utf-8 (format "~a" fraction-view)))
+            (send f put (string->bytes/utf-8 (number->string expansions))))
+          
+          (define/override (copy)
+            (let ([snip (instantiate number-snip% ()
+                          [number number]
+                          [decimal-prefix decimal-prefix])])
+              (send snip iterate (max 0 (- expansions 1))) ;; one iteration is automatic
+              (send snip set-fraction-view fraction-view)
+              snip))
+          
+          (inherit get-style)
+          
+          (define/override (get-extent dc x y wb hb descent space lspace rspace)
+            (case fraction-view
+              [(decimal)
+               (get-decimal-extent dc x y wb hb descent space lspace rspace)]
+              [(mixed)
+               (get-mixed-fraction-extent dc x y wb hb descent space lspace rspace)]
+              [(improper)
+               (get-improper-fraction-extent dc x y wb hb descent space lspace rspace)]))
+          
+          (define/private (get-improper-fraction-extent dc x y w h descent space lspace rspace)
+            (let* ([style (get-style)]
+                   [th (send style get-text-height dc)]
+                   [old-font (send dc get-font)])
+              (send dc set-font (send style get-font))
+              (let-values ([(nw nh na nd) (send dc get-text-extent improper-nums)]
+                           [(dw dh da dd) (send dc get-text-extent dens)]
+                           [(ww wh wa wd) (send dc get-text-extent improper-prefix)])
+                (set-box/f! h (+ nh dh 1))
+                (set-box/f! w (+ ww (max nw dw)))
+                (set-box/f! descent (+ wd (/ dh 2)))
+                (set-box/f! space  (+ wa (/ nh 2)))
+                (set-box/f! lspace 0)
+                (set-box/f! rspace 0))))
+          
+          (define/private (get-mixed-fraction-extent dc x y w h descent space lspace rspace)
+            (let* ([style (get-style)]
+                   [th (send style get-text-height dc)]
+                   [old-font (send dc get-font)])
+              (send dc set-font (send style get-font))
+              (let-values ([(nw nh na nd) (send dc get-text-extent nums)]
+                           [(dw dh da dd) (send dc get-text-extent dens)]
+                           [(ww wh wa wd) (send dc get-text-extent wholes/frac)])
+                (set-box/f! h (+ nh dh 1))
+                (set-box/f! w (+ ww (max nw dw)))
+                (set-box/f! descent (+ wd (/ dh 2)))
+                (set-box/f! space  (+ wa (/ nh 2)))
+                (set-box/f! lspace 0)
+                (set-box/f! rspace 0))))
+          
+          (define/private (get-decimal-extent dc x y wb hb descent space lspace rspace)
+            (let ([font (send (get-style) get-font)])
+              (let-values ([(w1 h1 d1 a1) (get-text-extent/f dc unbarred-portion font)]
+                           [(w2 h2 d2 a2) (get-text-extent/f dc barred-portion font)]
+                           [(w3 h3 d3 a3) (get-text-extent/f dc clickable-portion font)])
+                (set-box/f! wb (+ w1 w2 w3))
+                (set-box/f! hb (if barred-portion 
+                                   (+ h1 2)
+                                   h1))
+                (set-box/f! descent d1)
+                (set-box/f! space (if barred-portion
+                                      (+ a1 2)
+                                      a1))
+                (set-box/f! lspace 0)
+                (set-box/f! rspace 0))))
+          
+          (define/private (get-text-extent/f dc str font)
+            (if str
+                (let-values ([(w h d a) (send dc get-text-extent str font)])
+                  (values w h d a))
+                (values 0 0 0 0)))
+          
+          (define/override (draw dc x y left top right bottom dx dy draw-caret?)
+            (case fraction-view
+              [(mixed) (draw-mixed-fraction dc x y)]
+              [(improper) (draw-improper-fraction dc x y)]
+              [(decimal) (draw-decimals dc x y)]))
+          
+          (define/private (draw-improper-fraction dc x y)
+            (let-values ([(nw nh na nd) (send dc get-text-extent improper-nums)]
+                         [(dw dh da dd) (send dc get-text-extent dens)]
+                         [(ww wh wa wd) (send dc get-text-extent improper-prefix)])
+              (let ([frac-w (max nw dw)])
+                (send dc draw-text improper-nums (+ x ww (- frac-w nw)) y)
+                (send dc draw-text dens (+ x ww (- (/ dw 2)) (/ frac-w 2)) (+ y nh 1))
+                (send dc draw-text improper-prefix x (+ y (/ nh 2)))
+                (send dc draw-line
+                      (+ x ww) (+ y dh)
+                      (+ x ww (max nw dw) -1) (+ y dh)))))
+          
+          (define/private (draw-mixed-fraction dc x y)
+            (let-values ([(nw nh na nd) (send dc get-text-extent nums)]
+                         [(dw dh da dd) (send dc get-text-extent dens)]
+                         [(ww wh wa wd) (send dc get-text-extent wholes/frac)])
+              (let ([frac-w (max nw dw)])
+                (send dc draw-text nums (+ x ww (- frac-w nw)) y)
+                (send dc draw-text dens (+ x ww (- (/ dw 2)) (/ frac-w 2)) (+ y nh 1))
+                (send dc draw-text wholes/frac x (+ y (/ nh 2)))
+                (send dc draw-line
+                      (+ x ww) (+ y dh)
+                      (+ x ww (max nw dw) -1) (+ y dh)))))
+          
+          (define/private (draw-decimals dc x y)
+            (define (draw-digits digits x)
+              (if digits
+                  (let-values ([(w h a d) (send dc get-text-extent digits)])
+                    (send dc draw-text digits x (if barred-portion (+ y 2) y))
+                    (+ x w))
+                  x))
+            (let* ([unbarred-end (draw-digits unbarred-portion x)]
+                   [barred-end (draw-digits barred-portion unbarred-end)]
+                   [clickable-end (draw-digits clickable-portion barred-end)])
+              (when barred-portion
+                (send dc draw-line unbarred-end y (- barred-end 1) y))))
+          
+          (define/override (adjust-cursor dc x y editorx editory evt)
+            (let ([sx (- (send evt get-x) x)]
+                  [sy (- (send evt get-y) y)])
+              (if (in-clickable-portion? dc sx sy)
+                  arrow-cursor
+                  #f)))
+          
+          (define/override (on-event dc x y editor-x editor-y evt)
+            (let ([sx (- (send evt get-x) x)]
+                  [sy (- (send evt get-y) y)])
+              (cond
+                [(send evt button-down? 'right)
+                 (let ([admin (get-admin)])
+                   (when admin
+                     (let ([popup-menu (make-right-clickable-menu)])
+                       (send admin popup-menu popup-menu this (+ sx 1) (+ sy 1)))))]
+                [(send evt button-up? 'left)
+                 (when (in-clickable-portion? dc sx sy)
+                   (iterate/reflow))]
+                [else (void)])))
+          
+          (define/private (make-right-clickable-menu)
+            (let* ([menu (make-object popup-menu%)]
+                   [decimal-item
+                    (make-object checkable-menu-item% 
+                      (string-constant show-decimal-expansion)
+                      menu
+                      (λ (x y) (set-fraction-view 'decimal)))]
+                   [mixed-fraction-item
+                    (make-object checkable-menu-item% 
+                      (string-constant show-mixed-fraction-view)
+                      menu
+                      (λ (x y) 
+                        (set-fraction-view 'mixed)
+                        (preferences:set 'framework:fraction-snip-style 'mixed)))]
+                   [improper-fraction-item
+                    (make-object checkable-menu-item% 
+                      (string-constant show-improper-fraction-view)
+                      menu
+                      (λ (x y) 
+                        (set-fraction-view 'improper)
+                        (preferences:set 'framework:fraction-snip-style 'improper)))])
+              
+              (case fraction-view
+                [(decimal) (send decimal-item check #t)]
+                [(mixed) (send mixed-fraction-item check #t)]
+                [(improper) (send improper-fraction-item check #t)])
+              
+              (when (and (eq? fraction-view 'decimal)
+                         clickable-portion)
+                (make-object menu-item% 
+                  (string-constant show-more-decimal-places)
+                  menu
+                  (λ (x y)
+                    (iterate/reflow))))
+              menu))
+          
+          (define/private (in-clickable-portion? dc sx sy)
+            (and clickable-portion
+                 (let ([font (send (get-style) get-font)])
+                   (let-values ([(w1 h1 d1 a1) (get-text-extent/f dc unbarred-portion font)]
+                                [(w2 h2 d2 a2) (get-text-extent/f dc barred-portion font)]
+                                [(w3 h3 d3 a3) (get-text-extent/f dc clickable-portion font)])
+                     (and (<= (+ w1 w2) sx (+ w1 w2 w3))
+                          (<= 0 sy h3))))))
+          
+          (super-instantiate ())
+          (inherit set-snipclass set-flags get-flags)
+          (set-flags (cons 'handles-events (get-flags)))
+          (set-snipclass number-snipclass)
+          (iterate 1))) ;; calc first digits
+      
+      ;; hash-table-bound? : hash-table TST -> boolean
+      (define (hash-table-bound? ht key)
+        (let/ec k
+          (hash-table-get ht key (λ () (k #f)))
+          #t)))))
\ No newline at end of file
diff --git a/collects/framework/private/panel.ss b/collects/framework/private/panel.ss
new file mode 100644
index 0000000000..968fd42c75
--- /dev/null
+++ b/collects/framework/private/panel.ss
@@ -0,0 +1,436 @@
+
+(module panel mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "class.ss")
+	   "sig.ss"
+	   (lib "mred-sig.ss" "mred")
+	   (lib "list.ss")
+	   (lib "etc.ss"))
+  
+  (provide panel@)
+  
+  (define panel@
+    (unit/sig framework:panel^
+      (import [icon : framework:icon^]
+              mred^)
+      
+      
+      (define (list-set! _list _i ele)
+        (let loop ([lst _list]
+                   [i _i])
+          (cond
+            [(null? lst) (error 'list-set! "index too large for list, args: ~e ~e ~e"
+                                _list _i ele)]
+            [(zero? i) (set-car! lst ele)]
+            [else (loop (cdr lst) (- i 1))])))
+      
+      (define single<%> (interface (area-container<%>) active-child))
+      (define single-mixin
+        (mixin (area-container<%>) (single<%>)
+          (inherit get-alignment change-children)
+          (define/override (after-new-child c)
+	    (unless (is-a? c window<%>)
+
+	      ;; would like to remove the child here, waiting on a PR submitted
+	      ;; about change-children during after-new-child
+	      (change-children
+	       (λ (l)
+		 (remq c l)))
+
+	      (error 'single-mixin::after-new-child
+		     "all children must implement window<%>, got ~e"
+		     c))
+	    (if current-active-child
+		(send c show #f)
+		(set! current-active-child c)))
+          [define/override (container-size l)
+	    (if (null? l)
+		(values 0 0)
+		(values (apply max (map car l)) (apply max (map cadr l))))]
+          [define/override (place-children l width height)
+	    (let-values ([(h-align-spec v-align-spec) (get-alignment)])
+	      (let ([align
+		     (λ (total-size spec item-size)
+		       (floor
+			(case spec
+			  [(center) (- (/ total-size 2) (/ item-size 2))]
+			  [(left top) 0]
+			  [(right bottom) (- total-size item-size)]
+			  [else (error 'place-children
+				       "alignment spec is unknown ~a~n" spec)])))])
+		(map (λ (l) 
+		       (let*-values ([(min-width min-height v-stretch? h-stretch?)
+				      (apply values l)]
+				     [(x this-width)
+				      (if h-stretch?
+					  (values 0 width)
+					  (values (align width h-align-spec min-width)
+						  min-width))]
+				     [(y this-height)
+				      (if v-stretch?
+					  (values 0 height)
+					  (values (align height v-align-spec min-height)
+						  min-height))])
+			 (list x y this-width this-height)))
+		     l)))]
+          
+          (inherit get-children begin-container-sequence end-container-sequence)
+          [define current-active-child #f]
+          (define/public active-child
+            (case-lambda
+             [() current-active-child]
+             [(x) 
+              (unless (memq x (get-children))
+                (error 'active-child "got a panel that is not a child: ~e" x))
+              (unless (eq? x current-active-child)
+                (begin-container-sequence)
+                (for-each (λ (x) (send x show #f))
+                          (get-children))
+                (set! current-active-child x)
+                (send current-active-child show #t)
+                (end-container-sequence))]))
+          (super-instantiate ())))
+      
+      (define single-window<%> (interface (single<%> window<%>)))
+      (define single-window-mixin
+        (mixin (single<%> window<%>) (single-window<%>)
+          (inherit get-client-size get-size)
+          [define/override container-size
+            (λ (l)
+              (let-values ([(super-width super-height) (super container-size l)]
+                           [(client-width client-height) (get-client-size)]
+                           [(window-width window-height) (get-size)]
+                           [(calc-size)
+                            (λ (super client window)
+                              (+ super (max 0 (- window client))))])
+                
+                (values
+                 (calc-size super-width client-width window-width)
+                 (calc-size super-height client-height window-height))))]
+          (super-new)))
+      
+      (define multi-view<%>
+        (interface (area-container<%>)
+          split-vertically
+          split-horizontally
+          collapse))
+      
+      (define multi-view-mixin
+        (mixin (area-container<%>) (multi-view<%>) 
+          (init-field parent editor)
+          (public get-editor-canvas% get-vertical% get-horizontal%)
+          [define get-editor-canvas%
+            (λ ()
+              editor-canvas%)]
+          [define get-vertical%
+            (λ ()
+              vertical-panel%)]
+          [define get-horizontal%
+            (λ ()
+              horizontal-panel%)]
+          
+          (define/private (split p%)
+            (let ([canvas (send (send parent get-top-level-window) get-edit-target-window)]
+                  [ec% (get-editor-canvas%)])
+              (when (and canvas
+                         (is-a? canvas ec%)
+                         (eq? (send canvas get-editor) editor))
+                (let ([p (send canvas get-parent)])
+                  (send p change-children (λ (x) null))
+                  (let ([pc (make-object p% p)])
+                    (send (make-object ec% (make-object vertical-panel% pc) editor) focus)
+                    (make-object ec% (make-object vertical-panel% pc) editor))))))
+          [define/public split-vertically
+            (λ ()
+              (split (get-vertical%)))]
+          [define/public split-horizontally
+            (λ ()
+              (split (get-horizontal%)))]
+          
+          (define/public (collapse)
+            (let ([canvas (send (send parent get-top-level-window) get-edit-target-window)]
+                  [ec% (get-editor-canvas%)])
+              (when (and canvas
+                         (is-a? canvas ec%)
+                         (eq? (send canvas get-editor) editor))
+                (let ([p (send canvas get-parent)])
+                  (if (eq? p this)
+                      (bell)
+                      (let* ([sp (send p get-parent)]
+                             [p-to-remain (send sp get-parent)])
+                        (send p-to-remain change-children (λ (x) null))
+                        (send (make-object ec% p-to-remain editor) focus)))))))
+          
+          
+          (super-instantiate () (parent parent))
+          (make-object (get-editor-canvas%) this editor)))
+      
+      (define single% (single-window-mixin (single-mixin panel%)))
+      (define single-pane% (single-mixin pane%))
+      (define multi-view% (multi-view-mixin vertical-panel%))
+      
+      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      
+      ;; type gap = (make-gap number area<%> percentage number area<%> percentage)
+      (define-struct gap (before before-dim before-percentage after after-dim after-percentage))
+
+      ;; type percentage : (make-percentage number)
+      (define-struct percentage (%))
+      
+      (define dragable<%>
+        (interface (window<%> area-container<%>)
+          after-percentage-change
+          set-percentages
+          get-percentages
+          get-vertical?))
+      
+      (define vertical-dragable<%>
+        (interface (dragable<%>)))
+      
+      (define horizontal-dragable<%>
+        (interface (dragable<%>)))
+
+      (define dragable-mixin
+ 	(mixin (window<%> area-container<%>) (dragable<%>)
+          (init parent)
+ 
+	  (define/public (get-vertical?)
+            (error 'get-vertical "abstract method"))
+          (define/private (min-extent child) 
+            (let-values ([(w h) (send child get-graphical-min-size)])
+              (if (get-vertical?)
+                  (max (send child min-height) h)
+                  (max (send child min-width) w))))
+          (define/private (event-get-dim evt)
+            (if (get-vertical?)
+                (send evt get-y)
+                (send evt get-x)))
+          (define/private (get-gap-cursor)
+            (if (get-vertical?)
+                (icon:get-up/down-cursor)
+                (icon:get-left/right-cursor)))
+          
+          (inherit get-client-size container-flow-modified)
+           
+ 	  (init-field [bar-thickness 5])
+           
+ 	  ;; percentages : (listof percentage)
+ 	  (define percentages null)
+ 
+ 	  ;; get-percentages : -> (listof number)
+ 	  (define/public (get-percentages)
+ 	    (map percentage-% percentages))
+ 
+ 	  (define/public (set-percentages ps)
+ 	    (unless (and (list? ps)
+ 			 (andmap number? ps)
+ 			 (= 1 (apply + ps))
+ 			 (andmap positive? ps))
+ 	      (error 'set-percentages 
+ 		     "expected a list of numbers that are all positive and sum to 1, got: ~e"
+ 		     ps))
+ 	    (unless (= (length ps) (length (get-children)))
+ 	      (error 'set-percentages 
+ 		     "expected a list of numbers whose length is the number of children: ~a, got ~e"
+ 		     (length (get-children))
+ 		     ps))
+ 	    (set! percentages (map make-percentage ps))
+ 	    (container-flow-modified))
+ 
+ 	  (define/pubment (after-percentage-change) (inner (void) after-percentage-change))
+           
+ 	  (define/private (get-available-extent)
+ 	    (let-values ([(width height) (get-client-size)])
+ 	      (- (if (get-vertical?) height width)
+ 		 (* bar-thickness (- (length (get-children)) 1)))))
+ 
+ 	  (inherit get-children)
+           
+ 	  (define/private (update-percentages)
+ 	    (let ([len-children (length (get-children))])
+ 	      (unless (= len-children (length percentages))
+ 		(let ([rat (/ 1 len-children)])
+ 		  (set! percentages (build-list len-children (λ (i) (make-percentage rat)))))
+ 		(after-percentage-change))))
+           
+ 	  (define/override (after-new-child child)
+ 	    (update-percentages))
+           
+ 	  (define resizing-dim #f)
+ 	  (define resizing-gap #f)
+          
+ 	  (inherit set-cursor)
+ 	  (define/override (on-subwindow-event receiver evt)
+ 	    (if (eq? receiver this)
+ 		(let ([gap
+ 		       (ormap (λ (gap) 
+ 				(and (<= (gap-before-dim gap) 
+ 					 (event-get-dim evt)
+ 					 (gap-after-dim gap))
+ 				     gap))
+ 			      cursor-gaps)])
+ 		  (set-cursor (and (or gap
+ 				       resizing-dim)
+				   (let ([c (get-gap-cursor)])
+				     (and (send c ok?)
+					  c))))
+ 		  (cond
+ 		   [(and gap (send evt button-down? 'left))
+ 		    (set! resizing-dim (event-get-dim evt))
+ 		    (set! resizing-gap gap)]
+ 		   [(and resizing-dim (send evt button-up?))
+ 		    (set! resizing-dim #f)
+ 		    (set! resizing-gap #f)]
+ 		   [(and resizing-dim (send evt moving?))
+ 		    (let-values ([(width height) (get-client-size)])
+ 		      (let* ([before (gap-before resizing-gap)]
+ 			     [before-percentage (gap-before-percentage resizing-gap)]
+ 			     [after (gap-after resizing-gap)]
+ 			     [after-percentage (gap-after-percentage resizing-gap)]
+ 			     [available-extent (get-available-extent)]
+ 			     [change-in-percentage (/ (- resizing-dim (event-get-dim evt)) available-extent)]
+ 			     [new-before (- (percentage-% before-percentage) change-in-percentage)]
+ 			     [new-after (+ (percentage-% after-percentage) change-in-percentage)])
+ 			(when (and ((* new-before available-extent) . > . (min-extent before))
+ 				   ((* new-after available-extent) . > . (min-extent after)))
+ 			  (set-percentage-%! before-percentage new-before)
+ 			  (set-percentage-%! after-percentage new-after)
+ 			  (after-percentage-change)
+ 			  (set! resizing-dim (event-get-dim evt))
+ 			  (container-flow-modified))))]
+ 		   [else (super on-subwindow-event receiver evt)]))
+		(begin
+		  (set-cursor #f)
+		  (super on-subwindow-event receiver evt))))
+
+ 	  (define cursor-gaps null)
+
+ 	  (define/override (place-children _infos width height)
+ 	    (set! cursor-gaps null)
+ 	    (update-percentages)
+ 	    (cond
+ 	     [(null? _infos) null]
+ 	     [(null? (cdr _infos)) (list (list 0 0 width height))]
+ 	     [else
+ 	      (let ([available-extent (get-available-extent)]
+ 		    [show-error
+ 		     (λ (n)
+ 		       (error 'panel.ss::dragable-panel "internal error.~a" n))])
+ 		(let loop ([percentages percentages]
+ 			   [children (get-children)]
+ 			   [infos _infos]
+ 			   [dim 0])
+ 		  (cond
+ 		   [(null? percentages)
+ 		    (unless (null? infos) (show-error 1))
+ 		    (unless (null? children) (show-error 2))
+ 		    null]
+ 		   [(null? (cdr percentages))
+ 		    (when (null? infos) (show-error 3))
+ 		    (when (null? children) (show-error 4))
+ 		    (unless (null? (cdr infos)) (show-error 5))
+ 		    (unless (null? (cdr children)) (show-error 6))
+ 		    (if (get-vertical?)
+ 			(list (list 0 dim width (- height dim)))
+ 			(list (list dim 0 (- width dim) height)))]
+ 		   [else
+ 		    (when (null? infos) (show-error 7))
+ 		    (when (null? children) (show-error 8))
+ 		    (when (null? (cdr infos)) (show-error 9))
+ 		    (when (null? (cdr children)) (show-error 10))
+ 		    (let* ([info (car infos)]
+ 			   [percentage (car percentages)]
+ 			   [this-space (floor (* (percentage-% percentage) available-extent))])
+ 		      (set! cursor-gaps (cons (make-gap (car children)
+ 							(+ dim this-space)
+ 							percentage
+ 							(cadr children)
+ 							(+ dim this-space bar-thickness)
+ 							(cadr percentages))
+ 					      cursor-gaps))
+ 		      (cons (if (get-vertical?)
+ 				(list 0 dim width this-space)
+ 				(list dim 0 this-space height))
+ 			    (loop (cdr percentages)
+ 				  (cdr children)
+ 				  (cdr infos)
+ 				  (+ dim this-space bar-thickness))))])))]))
+
+          (define/override (container-size children-info)
+            (update-percentages)
+            (let loop ([percentages percentages]
+                       [children-info children-info]
+                       [major-size 0]
+                       [minor-size 0])
+              (cond
+                [(null? children-info)
+                 (if (get-vertical?)
+                     (values (ceiling minor-size) (ceiling major-size))
+                     (values (ceiling major-size) (ceiling minor-size)))]
+                [(null? percentages)
+                 (error 'panel.ss::dragable-panel "internal error.12")]
+                [else
+                 (let ([child-info (car children-info)]
+                       [percentage (car percentages)])
+                   (let-values ([(child-major major-stretch? child-minor minor-stretch?)
+                                 (if (get-vertical?)
+                                     (values (list-ref child-info 1)
+                                             (list-ref child-info 3)
+                                             (list-ref child-info 0)
+                                             (list-ref child-info 2))
+                                     (values (list-ref child-info 0)
+                                             (list-ref child-info 2)
+                                             (list-ref child-info 1)
+                                             (list-ref child-info 3)))])
+                     (loop (cdr percentages)
+                           (cdr children-info)
+                           (max (/ child-major (percentage-% percentage)) major-size)
+                           (max child-minor minor-size))))])))
+          
+          (super-instantiate (parent))))
+      
+      (define three-bar-pen-bar-width 8)
+      
+      (define three-bar-canvas%
+        (class canvas%
+          (inherit get-dc get-client-size)
+          (define/override (on-paint)
+            (let ([dc (get-dc)])
+              (let-values ([(w h) (get-client-size)])
+                (let ([sx (floor (- (/ w 2) (/ three-bar-pen-bar-width 2)))])
+                  (send dc set-brush (send the-brush-list find-or-create-brush (get-panel-background) 'panel))
+                  (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent))
+                  (send dc draw-rectangle 0 0 w h)
+                  
+                  (send dc set-pen (send the-pen-list find-or-create-pen  "black" 1 'solid))
+                  (send dc draw-line sx 1 (+ sx three-bar-pen-bar-width) 1)
+                  (send dc draw-line sx 4 (+ sx three-bar-pen-bar-width) 4)
+                  (send dc draw-line sx 7 (+ sx three-bar-pen-bar-width) 7)
+                  
+                  (send dc set-pen (send the-pen-list find-or-create-pen  "gray" 1 'solid))
+                  (send dc draw-line sx 2 (+ sx three-bar-pen-bar-width) 2)
+                  (send dc draw-line sx 5 (+ sx three-bar-pen-bar-width) 5)
+                  (send dc draw-line sx 8 (+ sx three-bar-pen-bar-width) 8)))))
+          
+          (super-instantiate ())
+          (inherit stretchable-height min-height)
+          (stretchable-height #f)
+          (min-height 10)))
+      
+ 
+      (define vertical-dragable-mixin
+        (mixin (dragable<%>) (vertical-dragable<%>)
+          (define/override (get-vertical?) #t)
+          (super-instantiate ())))
+      
+      (define horizontal-dragable-mixin
+        (mixin (dragable<%>) (vertical-dragable<%>)
+          (define/override (get-vertical?) #f)
+          (super-instantiate ())))
+        
+       (define vertical-dragable% (vertical-dragable-mixin (dragable-mixin vertical-panel%)))
+ 
+       (define horizontal-dragable% (horizontal-dragable-mixin (dragable-mixin horizontal-panel%))))))
+
diff --git a/collects/framework/private/pasteboard.ss b/collects/framework/private/pasteboard.ss
new file mode 100644
index 0000000000..e9fdb5d1b1
--- /dev/null
+++ b/collects/framework/private/pasteboard.ss
@@ -0,0 +1,20 @@
+(module pasteboard mzscheme
+  (require (lib "unitsig.ss")
+	   "sig.ss"
+	   (lib "mred-sig.ss" "mred"))
+
+  (provide pasteboard@)
+
+  (define pasteboard@
+    (unit/sig framework:pasteboard^
+      (import mred^
+	      [editor : framework:editor^])
+
+      (rename [-keymap% keymap%])
+
+      (define basic% (editor:basic-mixin pasteboard%))
+      (define standard-style-list% (editor:standard-style-list-mixin basic%))
+      (define -keymap% (editor:keymap-mixin standard-style-list%))
+      (define file% (editor:file-mixin -keymap%))
+      (define backup-autosave% (editor:backup-autosave-mixin file%))
+      (define info% (editor:info-mixin backup-autosave%)))))
diff --git a/collects/framework/private/path-utils.ss b/collects/framework/private/path-utils.ss
new file mode 100644
index 0000000000..aef071191d
--- /dev/null
+++ b/collects/framework/private/path-utils.ss
@@ -0,0 +1,62 @@
+(module path-utils mzscheme
+  (require (lib "unitsig.ss")
+	   "sig.ss"
+	   (lib "mred-sig.ss" "mred"))
+  
+  (provide path-utils@)
+  
+  (define path-utils@
+    (unit/sig framework:path-utils^
+      (import)
+      
+      (define (generate-autosave-name name)
+        (let-values ([(base name dir?)
+                      (if name
+                          (split-path name)
+                          (values (find-system-path 'doc-dir)
+                                  (bytes->path #"mredauto")
+                                  #f))])
+          (let* ([base (if (path? base)
+                           base
+                           (current-directory))]
+                 [path (if (relative-path? base)
+                           (build-path (current-directory) base)
+                           base)])
+            (let loop ([n 1])
+              (let* ([numb (string->bytes/utf-8 (number->string n))]
+                     [new-name
+                      (build-path path
+                                  (if (eq? (system-type) 'windows)
+                                      (bytes->path
+                                       (bytes-append (regexp-replace #rx#"\\..*$" 
+                                                                     (path->bytes name)
+                                                                     #"")
+                                                     #"."
+                                                     numb))
+                                      (bytes->path
+                                       (bytes-append #"#"
+                                                     (path->bytes name)
+                                                     #"#"
+                                                     numb
+                                                     #"#"))))])
+                (if (file-exists? new-name)
+                    (loop (add1 n))
+                    new-name))))))
+      
+      (define (generate-backup-name full-name)
+        (let-values ([(pre-base name dir?) (split-path full-name)])
+          (let ([base (if (path? pre-base)
+                          pre-base
+                          (current-directory))])
+            (let ([name-bytes (path->bytes name)])
+              (cond
+                [(and (eq? (system-type) 'windows)
+                      (regexp-match #rx#"(.*)\\.[^.]*" name-bytes))
+                 =>
+                 (λ (m)
+                   (build-path base (bytes->path (bytes-append (cadr m) #".bak"))))]
+                [(eq? (system-type) 'windows)
+                 (build-path base (bytes->path (bytes-append name-bytes #".bak")))]
+                [else
+                 (build-path base (bytes->path (bytes-append name-bytes #"~")))]))))))))
+
diff --git a/collects/framework/private/preferences.ss b/collects/framework/private/preferences.ss
new file mode 100644
index 0000000000..47fe251fed
--- /dev/null
+++ b/collects/framework/private/preferences.ss
@@ -0,0 +1,921 @@
+#|
+
+save needs contracts
+
+showing the dialog needs preferences.
+
+There are four attributes for each preference (technically, "read from 
+disk" is global, but we can just think of it happening to each one 
+independently, but simultaneously):
+
+  - read from disk, or not
+  - default set, or not
+  - marshalling function set, or not
+  - initialization still okay, or not
+
+the state transitions / contracts are:
+
+  get(true, true, _, _) -> (true, true, _, false)
+  get(false, _, _, _) -> error not yet read from disk
+  get(_, false, _, _) -> error default not yet set
+
+  set is just like get.
+
+  set-default(true, false, true, true) -> set-default(true, true, _, true)
+  set-default(false, _, _, _) -> error not yet read from disk
+  set-default(_, true, _, _) -> error default already set
+  set-default(_, _, _, false) -> initialization not okay anymore  /* cannot happen, I think */
+
+  set-un/marshall(true, true, false, true) -> (true, true, true, true)
+  .. otherwise error
+
+  read(false, _, _, true) -> (true, _, _, true)
+  read(true, _, _, _) -> error, already read from disk
+  read(_, _, _, false) -> initialization phase over /* cannot happen */
+
+  for all syms: 
+   prefs-snapshot(true, _, _, _) -> (true, _, _, false) 
+
+for the last one, need a global "no more initialization can happen" flag.
+
+|#
+
+(module preferences mzscheme
+  (require (lib "string-constant.ss" "string-constants")
+           (lib "unitsig.ss")
+	   (lib "class.ss")
+           (lib "file.ss")
+	   (lib "etc.ss")
+           "sig.ss"
+           "../gui-utils.ss"
+	   (lib "mred-sig.ss" "mred")
+	   (lib "pretty.ss")
+	   (lib "list.ss"))
+  
+  (provide preferences@)
+  (define preferences@
+    (unit/sig framework:preferences^
+      (import mred^
+              [exn : framework:exn^]
+              [exit : framework:exit^]
+              [panel : framework:panel^]
+              [frame : framework:frame^])
+
+      (rename [-read read])
+      
+      (define main-preferences-symbol 'plt:framework-prefs)
+      
+      ;; preferences : hash-table[sym -o> any]
+      ;; the current values of the preferences
+      (define preferences (make-hash-table))
+      
+      ;; marshalled : hash-table[sym -o> any]
+      ;; the values of the preferences, as read in from the disk
+      ;; each symbol will only be mapped in one of the preferences
+      ;; hash-table and this hash-table, but not both.
+      (define marshalled (make-hash-table))
+      
+      ;; marshall-unmarshall : sym -o> un/marshall
+      (define marshall-unmarshall (make-hash-table))
+      
+      ;; callbacks : sym -o> (listof (sym TST -> boolean))
+      (define callbacks (make-hash-table))
+      
+      ;; defaults : hash-table[sym -o> default]
+      (define defaults (make-hash-table))
+      
+      ;; these four functions determine the state of a preference
+      (define (pref-read?) read?)
+      (define (pref-un/marshall-set? pref) (hash-table-bound? marshall-unmarshall pref))
+      (define (pref-default-set? pref) (hash-table-bound? defaults pref))
+      (define (pref-can-init? pref) 
+        (and (not snapshot-grabbed?)
+             (not (hash-table-bound? preferences pref))))
+      
+      ;; type un/marshall = (make-un/marshall (any -> prinable) (printable -> any))
+      (define-struct un/marshall (marshall unmarshall))
+      
+      ;; type pref = (make-pref any)
+      (define-struct pref (value))
+      
+      ;; type default  = (make-default any (any -> bool))
+      (define-struct default (value checker))
+
+      ;; pref-callback : (make-pref-callback (union (weak-box (sym tst -> void)) (sym tst -> void)))
+      ;; this is used as a wrapped to deal with the problem that different procedures might be eq?.
+      (define-struct pref-callback (cb))
+
+      ;; get : symbol -> any
+      ;; return the current value of the preference `p'
+      ;; exported
+      (define (get p)
+        (cond
+          [(and (pref-read?)
+                (pref-default-set? p))
+           (hash-table-get preferences
+                           p
+                           (λ ()
+                             (cond
+                               [(hash-table-bound? marshalled p)
+                                (hash-table-put! preferences p (unmarshall p (hash-table-get marshalled p)))
+                                (hash-table-remove! marshalled p)]
+                               [else
+                                (let* ([def (hash-table-get defaults p)]
+                                       [def-val (default-value def)])
+                                  (hash-table-put! preferences p def-val))])
+                             (hash-table-get preferences p)))]
+          [(not (pref-read?))
+           (error
+            'preferences:get
+            "tried to get a preference but the disk preferences have not been read yet ~e"
+            p)]
+          [(not (pref-default-set? p))
+           (raise-unknown-preference-error
+            'preferences:get
+            "tried to get a preference but no default set for ~e"
+            p)]))
+          
+      ;; set : symbol any -> void
+      ;; updates the preference
+      ;; exported
+      (define (set p value)
+        (cond
+          [(and (pref-read?)
+                (pref-default-set? p))
+           (let ([default (hash-table-get defaults p)])
+             (unless ((default-checker default) value)
+               (error 'preferences:set
+                      "tried to set preference ~e to ~e but it does not meet test from preferences:set-default"
+                      p value))
+             (check-callbacks p value)
+             (hash-table-remove! marshalled p)
+             (hash-table-put! preferences p value))]
+          [(not (pref-read?))
+           (error
+            'preferences:set
+            "tried to get a preference but the disk preferences have not been read yet ~e"
+            p)]
+          [(not (pref-default-set? p))
+           (raise-unknown-preference-error
+            'preferences:set "tried to set the preference ~e to ~e, but no default is set"
+            p
+            value)]))
+
+      (define (raise-unknown-preference-error sym fmt . args)
+        (raise (exn:make-unknown-preference
+                (string->immutable-string (string-append (format "~a: " sym) (apply format fmt args)))
+                (current-continuation-marks))))
+      
+      ;; unmarshall : symbol marshalled -> any
+      ;; unmarshalls a preference read from the disk
+      (define (unmarshall p data)
+        (let/ec k
+          (let* ([unmarshall-fn (un/marshall-unmarshall
+                                 (hash-table-get marshall-unmarshall
+                                                 p
+                                                 (λ () (k data))))]
+                 [default (hash-table-get defaults p)]
+                 [result (unmarshall-fn data)])
+            (if ((default-checker default) result)
+                result
+                (default-value default)))))
+
+      ;; add-callback : sym (-> void) -> void
+      (define add-callback 
+        (opt-lambda (p callback [weak? #f])
+          (let ([new-cb (make-pref-callback (if weak?
+                                                (make-weak-box callback)
+                                                callback))])
+            (hash-table-put! callbacks
+                             p 
+                             (append 
+                              (hash-table-get callbacks p (λ () null))
+                              (list new-cb)))
+            (λ ()
+              (hash-table-put!
+               callbacks
+               p
+               (let loop ([callbacks (hash-table-get callbacks p (λ () null))])
+                 (cond
+                   [(null? callbacks) null]
+                   [else 
+                    (let ([callback (car callbacks)])
+                      (cond
+                        [(eq? callback new-cb)
+                         (loop (cdr callbacks))]
+                        [else
+                         (cons (car callbacks) (loop (cdr callbacks)))]))])))))))
+      
+      ;; check-callbacks : sym val -> void
+      (define (check-callbacks p value)
+        (let ([new-callbacks
+               (let loop ([callbacks (hash-table-get callbacks p (λ () null))])
+                 (cond
+                   [(null? callbacks) null]
+                   [else 
+                    (let* ([callback (car callbacks)]
+                           [cb (pref-callback-cb callback)])
+                      (cond
+                        [(weak-box? cb)
+                         (let ([v (weak-box-value cb)])
+                           (if v
+                               (begin 
+                                 (v p value)
+                                 (cons callback (loop (cdr callbacks))))
+                               (loop (cdr callbacks))))]
+                        [else
+                         (cb p value)
+                         (cons callback (loop (cdr callbacks)))]))]))])
+          (if (null? new-callbacks)
+              (hash-table-remove! callbacks p)
+              (hash-table-put! callbacks p new-callbacks))))
+      
+      (define (set-un/marshall p marshall unmarshall)
+        (cond
+          [(and (pref-read?)
+                (pref-default-set? p)
+                (not (pref-un/marshall-set? p))
+                (pref-can-init? p))
+           (hash-table-put! marshall-unmarshall p (make-un/marshall marshall unmarshall))]
+          [(not (pref-read?))
+           (error 'preferences:set-un/marshall
+                  "preferences not yet read from disk for ~e" 
+                  p)]
+          [(not (pref-default-set? p))
+           (error 'preferences:set-un/marshall
+                  "must call set-default for ~s before calling set-un/marshall for ~s"
+                  p p)]
+          [(pref-un/marshall-set? p)
+           (error 'preferences:set-un/marshall
+                  "already set un/marshall for ~e" 
+                  p)]
+          [(not (pref-can-init? p))
+           (error 'preferences:set-un/marshall "the preference ~e cannot be configured any more" p)]))
+      
+      (define (hash-table-bound? ht s)
+        (let/ec k
+          (hash-table-get ht s (λ () (k #f)))
+          #t))
+      
+      (define restore-defaults
+        (λ ()
+          (hash-table-for-each
+           defaults
+           (λ (p v) (set p v)))))
+      
+      ;; set-default : (sym TST (TST -> boolean) -> void
+      (define (set-default p default-value checker)
+        (cond
+          [(and (pref-read?)
+                (not (pref-default-set? p))
+                (pref-can-init? p))
+           (let ([default-okay? (checker default-value)])
+             (unless default-okay?
+               (error 'set-default "~s: checker (~s) returns ~s for ~s, expected #t~n"
+                      p checker default-okay? default-value))
+             (hash-table-put! defaults p (make-default default-value checker)))]
+          [(not (pref-can-init? p))
+           (error 'preferences:set-default
+                  "tried to call set-default for preference ~e but it cannot be configured any more"
+                  p)]
+          [(not (pref-read?))
+           (error 'preferences:set-default
+                  "preferences not yet read from disk for ~e" p)]
+          [(pref-default-set? p)
+           (error 'preferences:set-default
+                  "preferences default already set for ~e" p)]
+          [(not (pref-can-init? p))
+           (error 'preferences:set-default
+                  "can no longer set the default for ~e" p)]))
+      
+      (define (save) (raw-save #f))
+      (define (silent-save) (raw-save #f))
+      
+      ;; raw-save : boolean -> boolean
+      ;; input determines if there is a dialog box showing the errors (and other msgs)
+      ;; and result indicates if there was an error
+      (define (raw-save silent?)
+        (with-handlers ([exn:fail?
+                         (λ (exn)
+                           (unless silent?
+                             (message-box
+                              (string-constant preferences)
+                              (format (string-constant error-saving-preferences)
+                                      (exn-message exn))))
+                           #f)])
+          (let ([syms (list main-preferences-symbol)]
+                [vals (list (append (hash-table-map preferences marshall-pref)
+                                    (hash-table-map marshalled list)))]
+                [res #t])
+            (put-preferences
+             syms vals
+             (λ (filename)
+               (unless silent?
+                 (let* ([d (make-object dialog% (string-constant preferences))]
+                        [m (make-object message% (string-constant waiting-for-pref-lock) d)])
+                   (thread
+                    (λ ()
+                      (sleep 2)
+                      (send d show #f)))
+                   (send d show #t)
+                   (put-preferences 
+                    syms vals
+                    (λ (filename)
+                      (set! res #f)
+                      (message-box
+                       (string-constant preferences)
+                       (format (string-constant pref-lock-not-gone) filename))))))))
+            res)))
+      
+      ;; marshall-pref : symbol any -> (list symbol printable)
+      (define (marshall-pref p value)
+        (let/ec k
+          (let* ([marshaller
+                  (un/marshall-marshall
+                   (hash-table-get marshall-unmarshall p
+                                   (λ () (k (list p value)))))]
+                 [marshalled (marshaller value)])
+            (list p marshalled))))
+
+      (define (read-err input msg)
+        (message-box 
+         (string-constant preferences)
+         (let* ([max-len 150]
+                [s1 (format "~s" input)]
+                [ell "..."]
+                [s2 (if (<= (string-length s1) max-len)
+                        s1
+                        (string-append
+                         (substring s1 0 (- max-len
+                                            (string-length ell)))
+                         ell))])
+           (string-append
+            (string-constant error-reading-preferences)
+            "\n"
+            msg
+            "\n"
+            s2))))
+      
+      ;; read : -> void
+      (define (-read) 
+        (cond
+          [(not (pref-read?))
+           (set! read? #t)
+           (let/ec k
+             (let ([sexp (get-preference main-preferences-symbol (λ () (k (void))))])
+               (when (andmap (lambda (x)
+                               (and (pair? x)
+                                    (symbol? (car x))
+                                    (pair? (cdr x))
+                                    (null? (cddr x))))
+                             sexp)
+                 (for-each (lambda (pr)
+                             (let ([sym (car pr)]
+                                   [pref (cadr pr)])
+                               (hash-table-put! marshalled sym pref)))
+                           sexp))))]
+          [(pref-read?)
+           (error 'preferences:read "preferences already read from disk")]))
+      
+      (define read? #f)
+      
+      (define snapshot-grabbed? #f)
+      (define (get-prefs-snapshot)
+        (cond
+          [(pref-read?)
+           (set! snapshot-grabbed? #t)
+           (hash-table-map preferences cons)]
+          [(not (pref-read?))
+           (error 'get-prefs-snapshot
+                  "cannot grab snapshot until preferences have been read from disk")]))
+      
+      (define (restore-prefs-snapshot snapshot)
+        (for-each (lambda (lst) (set (car lst) (cdr lst)))
+                  snapshot))
+      
+
+
+ 
+                                          
+    ;;    ;           ;;;                 
+     ;                  ;                 
+     ;                  ;                 
+  ;;;;  ;;;    ;;;;     ;     ;;;    ;;; ;
+ ;   ;    ;        ;    ;    ;   ;  ;   ; 
+ ;   ;    ;     ;;;;    ;    ;   ;  ;   ; 
+ ;   ;    ;    ;   ;    ;    ;   ;  ;   ; 
+ ;   ;    ;    ;   ;    ;    ;   ;  ;   ; 
+  ;;; ; ;;;;;   ;;; ; ;;;;;;  ;;;    ;;;; 
+                                        ; 
+                                        ; 
+                                     ;;;  
+      
+      
+      ;; ppanel-tree = 
+      ;;  (union (make-ppanel-leaf string (union #f panel) (panel -> panel))
+      ;;         (make-ppanel-interior string (union #f panel) (listof panel-tree)))
+      (define-struct ppanel (name panel))
+      (define-struct (ppanel-leaf ppanel) (maker))
+      (define-struct (ppanel-interior ppanel) (children))
+      
+      ;; ppanels : (listof ppanel-tree)
+      (define ppanels null)
+      
+      (define preferences-dialog #f)
+      
+      (define (add-panel title make-panel)
+        (when preferences-dialog
+          (error 'add-panel "preferences dialog already open, cannot add new panels"))
+        (let ([titles (if (string? title)
+                          (list title)
+                          title)])
+          (add-to-existing-children
+           titles 
+           make-panel
+           (λ (new-subtree) (set! ppanels (cons new-subtree ppanels))))))
+      
+      ;; add-to-existing-children : (listof string) (panel -> panel) (ppanel -> void)
+      ;; adds the child specified by the path in-titles to the tree.
+      (define (add-to-existing-children in-titles make-panel banger)
+        (let loop ([children ppanels]
+                   [title (car in-titles)]
+                   [titles (cdr in-titles)]
+                   [banger banger])
+          (cond
+            [(null? children)
+             (banger (build-new-subtree (cons title titles) make-panel))]
+            [else
+             (let ([child (car children)])
+               (if (string=? (ppanel-name child) title)
+                   (cond
+                     [(null? titles) 
+                      (error 'add-child "child already exists with this path: ~e" in-titles)]
+                     [(ppanel-leaf? child)
+                      (error 'add-child "new child's path conflicts with existing path: ~e" in-titles)]
+                     [else
+                      (loop
+                       (ppanel-interior-children child)
+                       (car titles)
+                       (cdr titles)
+                       (λ (x)
+                         (set-ppanel-interior-children! 
+                          (cons
+                           x
+                           (ppanel-interior-children child)))))])
+                   (loop 
+                    (cdr children)
+                    title
+                    titles
+                    (λ (x)
+                      (set-cdr! children
+                                (cons x (cdr children)))))))])))
+      
+      ;; build-new-subtree : (cons string (listof string)) (panel -> panel) -> ppanel
+      (define (build-new-subtree titles make-panel)
+        (let loop ([title (car titles)]
+                   [titles (cdr titles)])
+          (cond
+            [(null? titles) (make-ppanel-leaf title #f make-panel)]
+            [else
+             (make-ppanel-interior 
+              title
+              #f
+              (list (loop (car titles) (cdr titles))))])))
+           
+      
+      (define (hide-dialog)
+	(when preferences-dialog
+	  (send preferences-dialog show #f)))
+      
+      (define (show-dialog)
+	(save)
+	(if preferences-dialog
+	    (send preferences-dialog show #t)
+	    (set! preferences-dialog
+		  (make-preferences-dialog))))
+
+      (define (add-can-close-dialog-callback cb)
+	(set! can-close-dialog-callbacks
+	      (cons cb can-close-dialog-callbacks)))
+
+      (define (add-on-close-dialog-callback cb)
+	(set! on-close-dialog-callbacks
+	      (cons cb on-close-dialog-callbacks)))
+
+      (define on-close-dialog-callbacks null)
+
+      (define can-close-dialog-callbacks null)
+      
+      (define (make-preferences-dialog)
+        (letrec ([stashed-prefs (get-prefs-snapshot)]
+		 [frame-stashed-prefs%
+		  (class frame:basic%
+                    (define/override (show on?)
+                      (when on?
+                        (set! stashed-prefs (get-prefs-snapshot)))
+		      (super show on?))
+		    (super-new))]
+                 [frame 
+                  (make-object frame-stashed-prefs%
+                    (string-constant preferences))]
+                 [build-ppanel-tree
+                  (λ (ppanel tab-panel single-panel)
+                    (send tab-panel append (ppanel-name ppanel))
+                    (cond
+                      [(ppanel-leaf? ppanel) 
+                       ((ppanel-leaf-maker ppanel) single-panel)]
+                      [(ppanel-interior? ppanel)
+                       (let-values ([(tab-panel single-panel) (make-tab/single-panel single-panel #t)])
+                         (for-each
+                          (λ (ppanel) (build-ppanel-tree ppanel tab-panel single-panel))
+                          (ppanel-interior-children ppanel)))]))]
+                 [make-tab/single-panel 
+                  (λ (parent inset?)
+                    (letrec ([spacer (and inset?
+                                          (instantiate vertical-panel% ()
+                                            (parent parent)
+                                            (border 10)))]
+                             [tab-panel (instantiate tab-panel% ()
+                                          (choices null)
+                                          (parent (if inset? spacer parent))
+                                          (callback (λ (_1 _2) 
+                                                      (tab-panel-callback
+                                                       single-panel
+                                                       tab-panel))))]
+                             [single-panel (instantiate panel:single% ()
+                                             (parent tab-panel))])
+                      (values tab-panel single-panel)))]
+                 [tab-panel-callback
+                  (λ (single-panel tab-panel)
+                    (send single-panel active-child
+                          (list-ref (send single-panel get-children)
+                                    (send tab-panel get-selection))))]
+                 [panel (make-object vertical-panel% (send frame get-area-container))]
+                 [_ (let-values ([(tab-panel single-panel) (make-tab/single-panel panel #f)])
+                      (for-each
+                       (λ (ppanel)
+                         (build-ppanel-tree ppanel tab-panel single-panel))
+                       ppanels)
+                      (let ([single-panel-children (send single-panel get-children)])
+                        (unless (null? single-panel-children)
+                          (send single-panel active-child (car single-panel-children))
+                          (send tab-panel set-selection 0)))
+                      (send tab-panel focus))]
+                 [bottom-panel (make-object horizontal-panel% panel)]
+                 [ok-callback (λ args
+                                (when (andmap (λ (f) (f))
+                                              can-close-dialog-callbacks)
+                                  (for-each
+                                   (λ (f) (f))
+                                   on-close-dialog-callbacks)
+                                  (save)
+                                  (hide-dialog)))]
+                 [cancel-callback (λ (_1 _2)
+                                    (hide-dialog)
+                                    (restore-prefs-snapshot stashed-prefs))])
+          (gui-utils:ok/cancel-buttons
+           bottom-panel
+           ok-callback
+           cancel-callback)
+          (make-object grow-box-spacer-pane% bottom-panel)
+          (send* bottom-panel
+            (stretchable-height #f)
+            (set-alignment 'right 'center))
+          (send frame show #t)
+          frame))
+      
+      (define (add-to-scheme-checkbox-panel f)
+        (set! scheme-panel-procs 
+              (let ([old scheme-panel-procs])
+                (λ (parent) (old parent) (f parent)))))
+      
+      (define (add-to-editor-checkbox-panel f)
+        (set! editor-panel-procs 
+              (let ([old editor-panel-procs])
+                (λ (parent) (old parent) (f parent)))))
+      
+      (define (add-to-warnings-checkbox-panel f)
+        (set! warnings-panel-procs 
+              (let ([old warnings-panel-procs])
+                (λ (parent) (old parent) (f parent)))))
+
+      (define scheme-panel-procs void)
+      (define editor-panel-procs void)
+      (define warnings-panel-procs void)
+      
+      (define (add-checkbox-panel label proc)
+        (add-panel
+         label
+         (λ (parent)
+           (let* ([main (make-object vertical-panel% parent)])
+             (send main set-alignment 'left 'center)
+             (proc main)
+             main))))
+      
+      ;; make-check : panel symbol string (boolean -> any) (any -> boolean)
+      ;; adds a check box preference to `main'.
+      (define (make-check main pref title bool->pref pref->bool)
+        (let* ([callback
+                (λ (check-box _)
+                  (set pref (bool->pref (send check-box get-value))))]
+               [pref-value (get pref)]
+               [initial-value (pref->bool pref-value)]
+               [c (make-object check-box% title main callback)])
+          (send c set-value initial-value)
+          (add-callback pref
+                        (λ (p v)
+                          (send c set-value (pref->bool v))))))
+
+      (define (make-recent-items-slider parent)
+        (let ([slider (instantiate slider% ()
+                        (parent parent)
+                        (label (string-constant number-of-open-recent-items))
+                        (min-value 1)
+                        (max-value 100)
+                        (init-value (get 'framework:recent-max-count))
+                        (callback (λ (slider y)
+                                    (set 'framework:recent-max-count
+                                         (send slider get-value)))))])
+          (add-callback
+           'framework:recent-max-count
+           (λ (p v)
+             (send slider set-value v)))))
+      
+      (define (add-scheme-checkbox-panel)
+        (letrec ([add-scheme-checkbox-panel
+                  (λ ()
+                    (set! add-scheme-checkbox-panel void)
+                    (add-checkbox-panel
+                     (list 
+                      (string-constant editor-prefs-panel-label) 
+                      (string-constant scheme-prefs-panel-label))
+                     (λ (scheme-panel)
+                       (make-check scheme-panel
+                                   'framework:highlight-parens
+                                   (string-constant highlight-parens)
+                                   values values)
+                       (make-check scheme-panel
+                                   'framework:fixup-parens
+                                   (string-constant fixup-parens)
+                                   values values)
+                       (make-check scheme-panel
+                                   'framework:paren-match
+                                   (string-constant flash-paren-match)
+                                   values values)
+                       (scheme-panel-procs scheme-panel))))])
+          (add-scheme-checkbox-panel)))
+      
+      (define (add-editor-checkbox-panel)
+        (letrec ([add-editor-checkbox-panel
+                  (λ ()
+                    (set! add-editor-checkbox-panel void)
+                    (add-checkbox-panel 
+                     (list (string-constant editor-prefs-panel-label) 
+                           (string-constant general-prefs-panel-label))
+                     (λ (editor-panel)
+                       (make-recent-items-slider editor-panel)
+                       (make-check editor-panel
+                                   'framework:autosaving-on? 
+                                   (string-constant auto-save-files)
+                                   values values)
+                       (make-check editor-panel  'framework:backup-files? (string-constant backup-files) values values)
+                       (make-check editor-panel  'framework:delete-forward? (string-constant map-delete-to-backspace)
+                                   not not)
+                       (make-check editor-panel 'framework:show-status-line (string-constant show-status-line) values values)
+                       (make-check editor-panel 'framework:col-offsets (string-constant count-columns-from-one) values values)
+                       (make-check editor-panel 
+                                   'framework:display-line-numbers
+                                   (string-constant display-line-numbers)
+                                   values values)
+                       
+                       (make-check editor-panel 
+                                   'framework:auto-set-wrap?
+                                   (string-constant wrap-words-in-editor-buffers)
+                                   values values)
+                       (make-check editor-panel 
+                                   'framework:search-using-dialog?
+                                   (string-constant separate-dialog-for-searching)
+                                   values values)
+                       (make-check editor-panel 
+                                   'framework:open-here?
+                                   (string-constant reuse-existing-frames)
+                                   values values)
+                       (make-check editor-panel 
+                                   'framework:menu-bindings
+                                   (string-constant enable-keybindings-in-menus)
+                                   values values)
+                       (make-check editor-panel 
+                                   'framework:coloring-active
+                                   (string-constant online-coloring-active)
+                                   values values)
+                       (when (memq (system-type) '(macos macosx))
+                         (make-check editor-panel 
+                                     'framework:special-option-key
+                                     (string-constant option-as-meta)
+                                     values values))
+                       (unless (eq? (system-type) 'unix) 
+                         (make-check editor-panel 
+                                     'framework:print-output-mode 
+                                     (string-constant automatically-to-ps)
+                                     (λ (b) 
+                                       (if b 'postscript 'standard))
+                                     (λ (n) (eq? 'postscript n))))
+                       (editor-panel-procs editor-panel))))])
+          (add-editor-checkbox-panel)))
+
+      (define (add-warnings-checkbox-panel)
+        (letrec ([add-warnings-checkbox-panel
+                  (λ ()
+                    (set! add-warnings-checkbox-panel void)
+                    (add-checkbox-panel
+                     (string-constant warnings-prefs-panel-label)
+                     (λ (warnings-panel)
+                       (make-check warnings-panel 
+                                   'framework:verify-change-format 
+                                   (string-constant ask-before-changing-format)
+                                   values values)
+                       (make-check warnings-panel 
+                                   'framework:verify-exit
+                                   (string-constant verify-exit)
+                                   values values)
+                       
+                       (warnings-panel-procs warnings-panel))))])
+          (add-warnings-checkbox-panel)))
+                  
+      (define (local-add-font-panel)
+        (let* ([font-families-name/const
+                (list (list "Default" 'default)
+                      (list "Decorative" 'decorative)
+                      (list "Modern" 'modern)
+                      (list "Roman" 'roman)
+                      (list "Script" 'script)
+                      (list "Swiss" 'swiss))]
+               
+               [font-families (map car font-families-name/const)]
+               
+               [font-size-entry "defaultFontSize"]
+               [font-default-string "Default Value"]
+               [font-default-size (case (system-type)
+                                    [(windows) 10]
+                                    [(macosx) 13]
+                                    [else 12])]
+               [font-section "mred"]
+               [build-font-entry (λ (x) (string-append "Screen" x "__"))]
+               [font-file (find-graphical-system-path 'setup-file)]
+               [build-font-preference-symbol
+                (λ (family)
+                  (string->symbol (string-append "framework:" family)))]
+               
+               [set-default
+                (λ (build-font-entry default pred)
+                  (λ (family)
+                    (let ([name (build-font-preference-symbol family)]
+                          [font-entry (build-font-entry family)])
+                      (set-default name
+                                   default
+                                   (cond
+                                     [(string? default) string?]
+                                     [(number? default) number?]
+                                     [else (error 'internal-error.set-default "unrecognized default: ~a~n" default)]))
+                      (add-callback 
+                       name 
+                       (λ (p new-value)
+                         (write-resource 
+                          font-section
+                          font-entry
+                          (if (and (string? new-value)
+                                   (string=? font-default-string new-value))
+                              ""
+                              new-value)
+                          font-file))))))])
+          
+          (for-each (set-default build-font-entry font-default-string string?)
+                    font-families)
+          ((set-default (λ (x) x)
+                        font-default-size
+                        number?)
+           font-size-entry)
+          (add-panel
+           (string-constant default-fonts)
+           (λ (parent)
+             (letrec ([font-size-pref-sym (build-font-preference-symbol font-size-entry)]
+                      [ex-string (string-constant font-example-string)]
+                      [main (make-object vertical-panel% parent)]
+                      [fonts (cons font-default-string (get-face-list))]
+                      [make-family-panel
+                       (λ (name)
+                         (let* ([pref-sym (build-font-preference-symbol name)]
+                                [family-const-pair (assoc name font-families-name/const)]
+                                
+                                [edit (make-object text%)]
+                                [_ (send edit insert ex-string)]
+                                [set-edit-font
+                                 (λ (size)
+                                   (let ([delta (make-object style-delta% 'change-size size)]
+                                         [face (get pref-sym)])
+                                     (if (and (string=? face font-default-string)
+                                              family-const-pair)
+                                         (send delta set-family (cadr family-const-pair))
+                                         (send delta set-delta-face (get pref-sym)))
+                                     
+                                     (send edit change-style delta 0 (send edit last-position))))]
+                                
+                                [horiz (make-object horizontal-panel% main '(border))]
+                                [label (make-object message% name horiz)]
+                                
+                                [message (make-object message%
+                                           (let ([b (box "")])
+                                             (if (and (get-resource 
+                                                       font-section 
+                                                       (build-font-entry name)
+                                                       b)
+                                                      (not (string=? (unbox b) 
+                                                                     "")))
+                                                 (unbox b)
+                                                 font-default-string)) 
+                                           horiz)]
+                                [button 
+                                 (make-object button%
+                                   (string-constant change-font-button-label)
+                                   horiz
+                                   (λ (button evt)
+                                     (let ([new-value
+                                            (get-choices-from-user
+                                             (string-constant fonts)
+                                             (format (string-constant choose-a-new-font)
+                                                     name)
+                                             fonts)])
+                                       (when new-value
+                                         (set pref-sym (list-ref fonts (car new-value))) 
+                                         (set-edit-font (get font-size-pref-sym))))))]
+                                [canvas (make-object editor-canvas% horiz
+                                          edit
+                                          (list 'hide-hscroll
+                                                'hide-vscroll))])
+                           (set-edit-font (get font-size-pref-sym))
+                           (add-callback
+                            pref-sym
+                            (λ (p new-value)
+                              (send horiz change-children
+                                    (λ (l)
+                                      (let ([new-message (make-object message%
+                                                           new-value
+                                                           horiz)])
+                                        (set! message new-message)
+                                        (update-message-sizes font-message-get-widths 
+                                                              font-message-user-min-sizes)
+                                        (list label 
+                                              new-message
+                                              button
+                                              canvas))))))
+                           (send canvas set-line-count 1)
+                           (vector set-edit-font
+                                   (λ () (send message get-width))
+                                   (λ (width) (send message min-width width))
+                                   (λ () (send label get-width))
+                                   (λ (width) (send label min-width width)))))]
+                      [set-edit-fonts/messages (map make-family-panel font-families)]
+                      [collect (λ (n) (map (λ (x) (vector-ref x n))
+                                                set-edit-fonts/messages))]
+                      [set-edit-fonts (collect 0)]
+                      [font-message-get-widths (collect 1)]
+                      [font-message-user-min-sizes (collect 2)]
+                      [category-message-get-widths (collect 3)]
+                      [category-message-user-min-sizes (collect 4)]
+                      [update-message-sizes
+                       (λ (gets sets)
+                         (let ([width (foldl (λ (x l) (max l (x))) 0 gets)])
+                           (for-each (λ (set) (set width)) sets)))]
+                      [size-panel (make-object horizontal-panel% main '(border))]
+                      [initial-font-size
+                       (let ([b (box 0)])
+                         (if (get-resource font-section 
+                                           font-size-entry
+                                           b)
+                             (unbox b)
+                             font-default-size))]
+                      [size-slider
+                       (make-object slider%
+                         (string-constant font-size-slider-label)
+                         1 127
+                         size-panel
+                         (λ (slider evt)
+                           (set font-size-pref-sym (send slider get-value)))
+                         initial-font-size)])
+               (update-message-sizes font-message-get-widths font-message-user-min-sizes)
+               (update-message-sizes category-message-get-widths category-message-user-min-sizes)
+               (add-callback
+                font-size-pref-sym
+                (λ (p value)
+                  (for-each (λ (f) (f value)) set-edit-fonts)
+                  (unless (= value (send size-slider get-value))
+                    (send size-slider set-value value))
+                  #t))
+               (for-each (λ (f) (f initial-font-size)) set-edit-fonts)
+               (make-object message% (string-constant restart-to-see-font-changes) main)
+               main))))
+        (set! local-add-font-panel void))
+      
+      (define (add-font-panel) (local-add-font-panel))
+      
+      (-read))))
diff --git a/collects/framework/private/scheme.ss b/collects/framework/private/scheme.ss
new file mode 100644
index 0000000000..05d2919213
--- /dev/null
+++ b/collects/framework/private/scheme.ss
@@ -0,0 +1,1290 @@
+;; originally by Dan Grossman
+;; 6/30/95
+
+(module scheme mzscheme
+  (require "collapsed-snipclass-helpers.ss"
+           (lib "string-constant.ss" "string-constants")
+           (lib "unitsig.ss")
+	   (lib "class.ss")
+	   "sig.ss"
+	   (lib "mred-sig.ss" "mred")
+           (lib "mred.ss" "mred")
+	   (lib "list.ss")
+	   (lib "thread.ss")
+           (lib "etc.ss")
+           (lib "surrogate.ss")
+           (lib "scheme-lexer.ss" "syntax-color"))
+  
+  (provide scheme@)
+
+  (define (scheme-paren:get-paren-pairs)
+    '(("(" . ")")
+      ("[" . "]")
+      ("{" . "}")))
+  
+  
+  (define scheme@
+    (unit/sig framework:scheme^
+      (import mred^
+              [preferences : framework:preferences^]
+              [icon : framework:icon^]
+              [keymap : framework:keymap^]
+              [text : framework:text^]
+              [editor : framework:editor^]
+              [frame : framework:frame^]
+              [comment-box : framework:comment-box^]
+              [mode : framework:mode^]
+              [color : framework:color^]
+              [color-prefs : framework:color-prefs^])
+      
+      (rename [-text-mode<%> text-mode<%>]
+              [-text<%> text<%>]
+              [-text% text%])
+      
+      (define text-balanced? 
+        (opt-lambda (text [start 0] [in-end #f])
+          (let* ([end (or in-end (send text last-position))]
+                 [port (open-input-text-editor text start end)])
+            (with-handlers ([exn:fail:read:eof? (λ (x) #f)]
+                            [exn:fail:read? (λ (x) #t)])
+              (let loop ()
+                (let ([s (read port)])
+                  (or (eof-object? s)
+                      (loop))))))))
+      
+      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;                                                                  ;;
+      ;;                           Sexp Snip                              ;;
+      ;;                                                                  ;;
+      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+      (define (set-box/f! b v) (when (box? b) (set-box! b v)))
+
+      (define sexp-snip<%>
+        (interface ()
+          get-saved-snips))
+
+      (define sexp-snip%
+        (class* snip% (sexp-snip<%> readable-snip<%>)
+          (init-field left-bracket right-bracket saved-snips)
+          (define/public (get-saved-snips) saved-snips)
+          (field [sizing-text (format "~a   ~a" left-bracket right-bracket)])
+
+          (define/public (read-special file line col pos)
+            (let ([text (make-object text:basic%)])
+              (for-each
+               (λ (s) (send text insert (send s copy)
+                                 (send text last-position)
+                                 (send text last-position)))
+               saved-snips)
+	      (datum->syntax-object
+	       #f
+	       (read (open-input-text-editor text))
+	       (list file line col pos 1))))
+          
+          (define/override get-text
+            (opt-lambda (offset num [flattened? #f])
+              (if flattened?
+                  (apply string-append
+                         (map (λ (snip)
+                                (send snip get-text 0 (send snip get-count) flattened?))
+                              saved-snips))
+                  (super get-text offset num flattened?))))
+              
+          (define/override (copy)
+            (instantiate sexp-snip% ()
+              (left-bracket left-bracket)
+              (right-bracket right-bracket)
+              (saved-snips saved-snips)))
+          
+          (define/override (write stream-out)
+            (send stream-out put (bytes (char->integer left-bracket)))
+            (send stream-out put (bytes (char->integer right-bracket)))
+            (send stream-out put (length saved-snips))
+            (let loop ([snips saved-snips])
+              (cond
+                [(null? snips) (void)]
+                [else
+                 (let* ([snip (car snips)]
+                        [snipclass (send snip get-snipclass)])
+                   (send stream-out put (string->bytes/utf-8 (send snipclass get-classname)))
+                   (send snip write stream-out))
+                 (loop (cdr snips))])))
+          
+          (define/override (draw dc x y left top right bottom dx dy draw-caret)
+            (send dc draw-text sizing-text x y)
+            (let-values ([(lpw lph lpa lpd) (send dc get-text-extent (string left-bracket))]
+                         [(rpw rph rpa rpd) (send dc get-text-extent (string right-bracket))]
+                         [(sw sh sa sd) (send dc get-text-extent sizing-text)])
+              (let* ([dtw (- sw lpw rpw)]
+                     [dot-start (+ x lpw)]
+                     [dt1x (+ dot-start (* dtw 1/5))]
+                     [dt2x (+ dot-start (* dtw 1/2))]
+                     [dt3x (+ dot-start (* dtw 4/5))]
+                     [dty (+ y (/ sh 2))])
+                (send dc draw-rectangle dt1x dty 2 2)
+                (send dc draw-rectangle dt2x dty 2 2)
+                (send dc draw-rectangle dt3x dty 2 2))))
+
+          (inherit get-style)
+          (define/override (get-extent dc x y wb hb descentb spaceb lspaceb rspaceb)
+            (let-values ([(w h d a) (send dc get-text-extent sizing-text (send (get-style) get-font))])
+              (set-box/f! wb w)
+              (set-box/f! hb h)
+              (set-box/f! descentb d)
+              (set-box/f! spaceb a)
+              (set-box/f! lspaceb 0)
+              (set-box/f! rspaceb 0)))
+          (super-instantiate ())
+          (inherit set-snipclass)
+          (set-snipclass lib-snip-class)))
+
+      (define sexp-snipclass% (make-sexp-snipclass% sexp-snip%))
+      
+      ;; old snips (from old versions of drscheme) use this snipclass
+      (define lib-snip-class (make-object sexp-snipclass%))
+      (send lib-snip-class set-classname (format "~s" '(lib "collapsed-snipclass.ss" "framework")))
+      (send lib-snip-class set-version 0)
+      (send (get-the-snip-class-list) add lib-snip-class)
+
+      ;; new snips use this snipclass
+      (define old-snip-class (make-object sexp-snipclass%))
+      (send old-snip-class set-classname "drscheme:sexp-snip")
+      (send old-snip-class set-version 0)
+      (send (get-the-snip-class-list) add old-snip-class)
+
+      (keymap:add-to-right-button-menu
+       (let ([old (keymap:add-to-right-button-menu)])
+         (λ (menu text event)
+           (old menu text event)
+           (split/collapse-text menu text event)
+	   (void))))
+      
+      ;; split/collapse-text : (instanceof menu%) (instanceof editor<%>) (instanceof mouse-event%) -> void
+      (define (split/collapse-text menu text event)
+        (when (is-a? text -text<%>)
+          (let* ([on-it-box (box #f)]
+                 [click-pos 
+                  (call-with-values
+                   (λ ()
+                     (send text dc-location-to-editor-location
+                           (send event get-x)
+                           (send event get-y)))
+                   (λ (x y)
+                     (send text find-position x y #f on-it-box)))]
+                 [snip (send text find-snip click-pos 'after)]
+                 [char (send text get-character click-pos)]
+                 [left? (memq char '(#\( #\{ #\[))]
+                 [right? (memq char '(#\) #\} #\]))])
+            (cond
+              [(and snip (is-a? snip sexp-snip<%>))
+               (make-expand-item text snip menu)]
+              [(not (unbox on-it-box))
+               ;; clicking in nowhere land, just ignore
+               (void)]
+              [(or left? right?)
+               ;; clicking on left or right paren
+               (let* ([pos (if left?
+                               click-pos
+                               (+ click-pos 1))]
+                      [other-pos (if left?
+                                     (send text get-forward-sexp pos)
+                                     (send text get-backward-sexp pos))])
+                 (when other-pos
+                   (let ([left-pos (min pos other-pos)]
+                         [right-pos (max pos other-pos)])
+                     (make-collapse-item text left-pos right-pos menu))))]
+              [else 
+               ;; clicking on some other text -> collapse containing sexp
+               (let ([up-sexp (send text find-up-sexp click-pos)])
+                 (when up-sexp 
+                   (let ([fwd (send text get-forward-sexp up-sexp)])
+                     (make-collapse-item text up-sexp fwd menu))))]))))
+      
+      ;; make-expand-item : (instanceof text%) (instanceof sexp-snip<%>) (instanceof menu%) -> void
+      (define (make-expand-item text snip menu)
+        (instantiate separator-menu-item% ()
+          (parent menu))
+        (instantiate menu-item% ()
+          (parent menu)
+          (label (string-constant expand-sexp))
+          (callback (λ (item evt) (expand-from text snip)))))
+      
+      ;; expand-from : (instanceof text%) (instanceof sexp-snip<%>) -> void
+      (define (expand-from text snip)
+        (let ([snips (send snip get-saved-snips)])
+          (send text begin-edit-sequence)
+          (let ([pos (send text get-snip-position snip)])
+            (send text delete pos (+ pos 1))
+            (let loop ([snips (reverse snips)])
+              (cond
+                [(null? snips) (void)]
+                [else (send text insert (car snips) pos pos)
+                      (loop (cdr snips))])))
+          (send text end-edit-sequence)))
+
+      ;; make-collapse-item : (instanceof text%) number number (instanceof menu%) -> void
+      ;; adds a collapse menu item to the menu
+      (define (make-collapse-item text left-pos right-pos menu)
+        (instantiate separator-menu-item% ()
+          (parent menu))
+        (instantiate menu-item% ()
+          (parent menu)
+          (label (string-constant collapse-sexp))
+          (callback (λ (item evt)
+                      (collapse-from text left-pos right-pos)))))
+      
+      (define (collapse-from text left-pos right-pos)
+        (let ([left-bracket (send text get-character left-pos)]
+              [right-bracket (send text get-character (- right-pos 1))])
+          (send text begin-edit-sequence)
+          (send text split-snip left-pos)
+          (send text split-snip right-pos)
+          (let ([snips (let loop ([snip (send text find-snip left-pos 'after)])
+                         (cond
+                           [(not snip) null]
+                           [((send text get-snip-position snip) . >= . right-pos)
+                            null]
+                           [else (cons (send snip copy) (loop (send snip next)))]))])
+            (send text delete left-pos right-pos)
+            (send text insert (instantiate sexp-snip% () 
+                                (left-bracket left-bracket)
+                                (right-bracket right-bracket)
+                                (saved-snips snips))
+                  left-pos left-pos)
+            (send text end-edit-sequence))))
+      
+
+                                                                             
+              ;;                                                             
+               ;                                   ;                    ;    
+               ;                                   ;                    ;    
+  ;;;    ;;;   ; ;;    ;;;  ;;; ;    ;;;          ;;;;;   ;;;  ;;; ;;; ;;;;; 
+ ;   ;  ;   ;  ;;  ;  ;   ;  ; ; ;  ;   ;    ;     ;     ;   ;   ; ;    ;    
+  ;;;   ;      ;   ;  ;;;;;  ; ; ;  ;;;;;          ;     ;;;;;    ;     ;    
+     ;  ;      ;   ;  ;      ; ; ;  ;              ;     ;       ; ;    ;    
+ ;   ;  ;   ;  ;   ;  ;   ;  ; ; ;  ;   ;          ;   ; ;   ;  ;   ;   ;   ;
+  ;;;    ;;;  ;;; ;;;  ;;;  ;; ; ;;  ;;;     ;      ;;;   ;;;  ;;   ;;   ;;; 
+                                                                             
+ 
+      (define color-prefs-table
+        (let ([constant-green (make-object color% 41 128 38)]
+              [symbol-blue (make-object color% 38 38 128)])
+        `((symbol ,symbol-blue ,(string-constant scheme-mode-color-symbol))
+          (keyword ,symbol-blue ,(string-constant scheme-mode-color-keyword))
+          (comment ,(make-object color% 194 116 31) ,(string-constant scheme-mode-color-comment))
+          (string ,constant-green ,(string-constant scheme-mode-color-string))
+          (constant ,constant-green ,(string-constant scheme-mode-color-constant))
+          (parenthesis ,(make-object color% "brown") ,(string-constant scheme-mode-color-parenthesis))
+          (error ,(make-object color% "red") ,(string-constant scheme-mode-color-error))
+          (other ,(make-object color% "black") ,(string-constant scheme-mode-color-other)))))
+      (define (get-color-prefs-table) color-prefs-table)
+      
+      (define (short-sym->pref-name sym) (string->symbol (short-sym->style-name sym)))
+      (define sn-hash (make-hash-table))
+      (define (short-sym->style-name sym)
+	(hash-table-get sn-hash sym
+			(λ ()
+			  (let ([s (format "framework:syntax-coloring:scheme:~a" sym)])
+			    (hash-table-put! sn-hash sym s)
+			    s))))
+      
+      (define (add-coloring-preferences-panel)
+        (color-prefs:add-to-preferences-panel
+         "Scheme"
+         (λ (parent)
+           (for-each
+            (λ (line)
+              (let ([sym (car line)])
+                (color-prefs:build-color-selection-panel 
+                 parent
+                 (short-sym->pref-name sym)
+                 (short-sym->style-name sym)
+                 (format "~a" sym))))
+            color-prefs-table))))
+      
+      (define-struct string/pos (string pos))
+      
+      (define -text<%>
+        (interface (text:basic<%> mode:host-text<%> color:text<%>)
+          get-limit
+          balance-parens
+          tabify-on-return?
+          tabify
+          tabify-selection
+          tabify-all
+          insert-return
+          box-comment-out-selection
+          comment-out-selection
+          uncomment-selection
+          get-forward-sexp
+          remove-sexp
+          forward-sexp
+          flash-forward-sexp
+          get-backward-sexp
+          flash-backward-sexp
+          backward-sexp
+          find-up-sexp
+          up-sexp
+          find-down-sexp
+          down-sexp
+          remove-parens-forward
+          
+          select-forward-sexp
+          select-backward-sexp
+          select-up-sexp
+          select-down-sexp
+          transpose-sexp
+          mark-matching-parenthesis
+          get-tab-size
+          set-tab-size))
+      
+      (define init-wordbreak-map
+        (λ (map)
+          (let ([v (send map get-map #\-)])
+            (send map set-map 
+                  #\-
+                  '(line)))))
+      (define wordbreak-map (make-object editor-wordbreak-map%))
+      (define (get-wordbreak-map) wordbreak-map)
+      (init-wordbreak-map wordbreak-map)
+      
+      (define matching-parenthesis-style 
+        (let ([matching-parenthesis-delta (make-object style-delta% 'change-bold)]
+              [style-list (editor:get-standard-style-list)])
+          (send matching-parenthesis-delta set-delta-foreground "forest green")
+          (send style-list new-named-style "Matching Parenthesis Style"
+                (send style-list find-or-create-style
+                      (send style-list find-named-style "Standard")
+                      matching-parenthesis-delta))
+          (send style-list find-named-style "Matching Parenthesis Style")))
+
+      (define text-mixin
+        (mixin (text:basic<%> mode:host-text<%> color:text<%>) (-text<%>)
+          (inherit begin-edit-sequence
+                   delete
+                   end-edit-sequence
+                   local-edit-sequence?
+                   find-string
+                   get-character
+                   get-keymap
+                   get-text
+                   get-start-position
+                   get-style-list
+                   get-end-position
+                   flash-on
+                   insert
+                   kill
+                   last-position
+                   paragraph-start-position
+                   paragraph-end-position
+                   position-paragraph
+                   set-keymap
+                   set-load-overwrites-styles
+                   set-position
+                   set-wordbreak-map
+                   set-tabs
+                   set-style-list
+                   set-styles-fixed
+                   change-style
+                   get-snip-position
+                   backward-match
+                   backward-containing-sexp
+                   forward-match
+                   skip-whitespace
+                   insert-close-paren
+		   classify-position)
+          
+          (inherit get-styles-fixed)
+          (inherit has-focus? find-snip split-snip)
+          
+          (public get-limit balance-parens tabify-on-return? tabify tabify-selection
+                  tabify-all insert-return calc-last-para 
+                  box-comment-out-selection comment-out-selection uncomment-selection
+                  get-forward-sexp remove-sexp forward-sexp flash-forward-sexp get-backward-sexp
+                  flash-backward-sexp backward-sexp find-up-sexp up-sexp find-down-sexp down-sexp
+                  remove-parens-forward)
+          (define (get-limit pos) 0)
+          
+          (define (balance-parens key-event)
+            (insert-close-paren (get-start-position) 
+                                (send key-event get-key-code)
+                                (preferences:get 'framework:paren-match)
+                                (preferences:get 'framework:fixup-parens)))
+          
+          (define (tabify-on-return?) #t)
+          (define tabify    
+            (opt-lambda ([pos (get-start-position)])
+              (let* ([last-pos (last-position)]
+                     [para (position-paragraph pos)]
+		     [is-tabbable? (and (> para 0)
+					(not (memq (classify-position (sub1 (paragraph-start-position para)))
+						   '(comment string error))))]
+                     [okay (and is-tabbable? (> para 0))]
+                     [end (if okay (paragraph-start-position para) 0)]
+                     [limit (get-limit pos)]
+		     ;; "contains" is the start of the initial sub-S-exp
+		     ;;  in the S-exp that contains "pos". If pos is outside
+		     ;;  all S-exps, this will be the start of the initial
+		     ;;  S-exp
+                     [contains 
+                      (if okay
+                          (backward-containing-sexp end limit)
+                          #f)]
+                     [contain-para (and contains
+                                        (position-paragraph contains))]
+		     ;; "last" is the start of the S-exp just before "pos"
+                     [last 
+                      (if contains
+                          (backward-match end limit)
+                          #f)]
+                     [last-para (and last
+                                     (position-paragraph last))])
+                (letrec	
+                    ([find-offset
+                      (λ (pos)
+                        (let loop ([p pos][o 0])
+                          (let ([c (get-character p)])
+                            (cond
+                              [(char=? c #\tab)
+                               (loop (add1 p) (+ o (- 8 (modulo o 8))))]
+                              [(char=? c #\newline)
+                               (cons o p)]
+                              [(char-whitespace? c)
+                               (loop (add1 p) (add1 o))]
+                              [else
+                               (cons o p)]))))]
+                     [visual-offset
+                      (λ (pos)
+                        (let loop ([p (sub1 pos)])
+                          (if (= p -1)
+                              0
+                              (let ([c (get-character p)])
+                                (cond
+                                  [(char=? c #\null) 0]
+                                  [(char=? c #\tab)
+                                   (let ([o (loop (sub1 p))])
+                                     (+ o (- 8 (modulo o 8))))]
+                                  [(char=? c #\newline) 0]
+                                  [else (add1 (loop (sub1 p)))])))))]
+                     [do-indent
+                      (λ (amt)
+                        (let* ([pos-start end]
+                               [curr-offset (find-offset pos-start)])
+                          (unless (= amt (car curr-offset))
+                            (delete pos-start (cdr curr-offset))
+                            (insert
+                             (make-string amt #\space)
+                             pos-start))))]
+                     [get-proc
+                      (λ ()
+			(let ([id-end (forward-match contains (last-position))])
+			  (if (and id-end (> id-end contains))
+			      (let* ([text (get-text contains id-end)])
+                                (or (get-keyword-type text)
+                                    'other)))))]
+                     [procedure-indent
+                      (λ ()
+                        (case (get-proc)
+                          [(define) 1]
+                          [(begin) 1]
+                          [(lambda) 3]
+                          [else 0]))]
+                     [special-check
+                      (λ ()
+                        (let* ([proc-name (get-proc)])
+                          (or (eq? proc-name 'define)
+                              (eq? proc-name 'lambda))))]
+                     [indent-first-arg
+                      (λ (start)
+                        (car (find-offset start)))])
+                  (when (and okay
+                             (not (char=? (get-character (sub1 end))
+                                          #\newline)))
+                    (insert #\newline (paragraph-start-position para)))
+                  (cond
+		    [(not is-tabbable?) (void)]
+                    [(let ([real-start (cdr (find-offset end))]) 
+                       (and (<= (+ 3 real-start) (last-position))
+                            (string=? ";;;"
+                                      (get-text real-start
+                                                (+ 2 real-start)))))
+                     (void)]
+                    [(= para 0) (do-indent 0)]
+                    [(not contains)
+		     ;; Something went wrong matching. Should we get here?
+                     (do-indent 0)]
+                    [(not last) 
+		     ;; We can't find a match backward from pos,
+		     ;;  but we seem to be inside an S-exp, so 
+		     ;;  go "up" an S-exp, and move forward past
+		     ;;  the associated paren
+                     (let ([enclosing (find-up-sexp pos)])
+                       (do-indent (if enclosing
+                                      (+ (visual-offset enclosing) 1)
+                                      0)))]
+                    [(= contains last)
+		     ;; There's only one S-expr in the S-expr
+		     ;;  containing "pos"
+                     (do-indent (+ (visual-offset contains)
+                                   (procedure-indent)))]
+                    [(special-check)
+		     ;; In case of "define", etc., ignore the position of last 
+		     ;;  and just indent under the "define"
+                     (do-indent (add1 (visual-offset contains)))]
+                    [(= contain-para last-para)
+		     ;; So far, the S-exp containing "pos" was all on
+		     ;;  one line (possibly not counting the opening paren),
+		     ;;  so indent to follow the first S-exp's end
+                     (let ([name-length (let ([id-end (forward-match contains (last-position))])
+					  (if id-end
+					      (- id-end contains)
+					      0))])
+                       (do-indent (+ (visual-offset contains)
+                                     name-length
+                                     (indent-first-arg (+ contains 
+                                                          name-length)))))]
+                    [else
+		     ;; No particular special case, so indent to match first 
+		     ;; S-expr that start on the previous line
+		     (let loop ([last last][last-para last-para])
+		       (let* ([next-to-last (backward-match last limit)]
+			      [next-to-last-para (and next-to-last
+						      (position-paragraph next-to-last))])
+			 (if (equal? last-para next-to-last-para)
+			     (loop next-to-last next-to-last-para)
+			     (do-indent (visual-offset last)))))])))))
+          
+          (define tabify-selection
+            (opt-lambda ([start-pos (get-start-position)]
+                         [end-pos (get-end-position)])
+              (let ([first-para (position-paragraph start-pos)]
+                    [end-para (position-paragraph end-pos)])
+                (with-handlers ([exn:break?
+                                 (λ (x) #t)])
+                  (dynamic-wind
+                   (λ () 
+                     (when (< first-para end-para)
+                       (begin-busy-cursor))
+                     (begin-edit-sequence))
+                   (λ ()
+                     (let loop ([para first-para])
+                       (when (<= para end-para)
+                         (tabify (paragraph-start-position para))
+			 (parameterize-break #t (void))
+                         (loop (add1 para))))
+                     (when (and (>= (position-paragraph start-pos) end-para)
+                                (<= (skip-whitespace (get-start-position) 'backward #f)
+                                    (paragraph-start-position first-para)))
+                       (set-position 
+                        (let loop ([new-pos (get-start-position)])
+                          (if (let ([next (get-character new-pos)])
+                                (and (char-whitespace? next)
+                                     (not (char=? next #\newline))))
+                              (loop (add1 new-pos))
+                              new-pos)))))
+                   (λ ()
+                     (end-edit-sequence)
+                     (when (< first-para end-para)
+                       (end-busy-cursor))))))))
+          
+          (define (tabify-all) (tabify-selection 0 (last-position)))
+          (define (insert-return)
+            (if (tabify-on-return?)
+                (begin 
+                  (begin-edit-sequence)
+                  (insert #\newline)
+                  (tabify (get-start-position))
+                  (set-position 
+                   (let loop ([new-pos (get-start-position)])
+                     (if (let ([next (get-character new-pos)])
+                           (and (char-whitespace? next)
+                                (not (char=? next #\newline))))
+                         (loop (add1 new-pos))
+                         new-pos)))
+                  (end-edit-sequence))
+                (insert #\newline)))
+          
+          (define (calc-last-para last-pos)
+            (let ([last-para (position-paragraph last-pos #t)])
+              (if (and (> last-pos 0)
+                       (> last-para 0))
+                  (begin (split-snip last-pos)
+                         (let ([snip (find-snip last-pos 'before)])
+                           (if (member 'hard-newline (send snip get-flags))
+                               (- last-para 1)
+                               last-para)))
+                  last-para)))
+          
+          (define comment-out-selection 
+            (opt-lambda ([start-pos (get-start-position)] 
+                         [end-pos (get-end-position)]) 
+              (begin-edit-sequence) 
+              (let ([first-pos-is-first-para-pos? 
+                     (= (paragraph-start-position (position-paragraph start-pos)) 
+                        start-pos)]) 
+                (let* ([first-para (position-paragraph start-pos)] 
+                       [last-para (calc-last-para end-pos)]) 
+                  (let para-loop ([curr-para first-para]) 
+                    (if (<= curr-para last-para) 
+                        (let ([first-on-para (paragraph-start-position curr-para)]) 
+                          (insert #\; first-on-para) 
+                          (para-loop (add1 curr-para)))))) 
+                (when first-pos-is-first-para-pos? 
+                  (set-position 
+                   (paragraph-start-position (position-paragraph (get-start-position))) 
+                   (get-end-position)))) 
+              (end-edit-sequence) 
+              #t)) 
+          
+          (define box-comment-out-selection
+            (opt-lambda ([_start-pos 'start]
+                         [_end-pos 'end])
+	      (let ([start-pos (if (eq? _start-pos 'start)
+				   (get-start-position)
+				   _start-pos)]
+		    [end-pos (if (eq? _end-pos 'end)
+				 (get-end-position)
+				 _end-pos)])
+		(begin-edit-sequence)
+		(split-snip start-pos)
+		(split-snip end-pos)
+		(let* ([cb (instantiate comment-box:snip% ())]
+		       [text (send cb get-editor)])
+		  (let loop ([snip (find-snip start-pos 'after-or-none)])
+		    (cond
+		      [(not snip) (void)]
+		      [((get-snip-position snip) . >= . end-pos) (void)]
+		      [else
+		       (send text insert (send snip copy)
+			     (send text last-position)
+			     (send text last-position))
+		       (loop (send snip next))]))
+		  (delete start-pos end-pos)
+		  (insert cb start-pos)
+		  (set-position start-pos start-pos))
+		(end-edit-sequence)
+		#t)))
+          
+          ;; uncomment-box/selection : -> void
+          ;; uncomments a comment box, if the focus is inside one.
+          ;; otherwise, calls uncomment selection to uncomment
+          ;; something else.
+          (inherit get-focus-snip)
+          (define/public (uncomment-box/selection)
+            (begin-edit-sequence)
+            (let ([focus-snip (get-focus-snip)])
+              (cond
+                [(not focus-snip) (uncomment-selection)]
+                [(is-a? focus-snip comment-box:snip%) 
+                 (extract-contents 
+                  (get-snip-position focus-snip)
+                  focus-snip)]
+                [else (uncomment-selection)]))
+            (end-edit-sequence)
+            #t)
+          
+          (define uncomment-selection
+            (opt-lambda ([start-pos (get-start-position)]
+                         [end-pos (get-end-position)])
+              (let ([snip-before (find-snip start-pos 'before-or-none)]
+                    [snip-after (find-snip start-pos 'after-or-none)])
+                
+                (begin-edit-sequence)
+                (cond
+                  [(and (= start-pos end-pos)
+                        snip-before
+                        (is-a? snip-before comment-box:snip%))
+                   (extract-contents start-pos snip-before)]
+                  [(and (= start-pos end-pos)
+                        snip-after
+                        (is-a? snip-after comment-box:snip%))
+                   (extract-contents start-pos snip-after)]
+                  [(and (= (+ start-pos 1) end-pos)
+                        snip-after
+                        (is-a? snip-after comment-box:snip%))
+                   (extract-contents start-pos snip-after)]
+                  [else
+                   (let* ([last-pos (last-position)]
+                          [first-para (position-paragraph start-pos)]
+                          [last-para (calc-last-para end-pos)])
+                     (let para-loop ([curr-para first-para])
+                       (when (<= curr-para last-para)
+                         (let ([first-on-para
+                                (skip-whitespace  (paragraph-start-position curr-para)
+                                                  'forward
+                                                  #f)])
+                           (split-snip first-on-para)
+                           (when (and (< first-on-para last-pos)
+                                      (char=? #\; (get-character first-on-para))
+                                      (is-a? (find-snip first-on-para 'after-or-none) string-snip%))
+                             (delete first-on-para (+ first-on-para 1)))
+                           (para-loop (add1 curr-para))))))])
+                (end-edit-sequence))
+              #t))
+          
+          ;; extract-contents : number (is-a?/c comment-box:snip%) -> void
+          ;; copies the contents of the comment-box-snip out of the snip
+          ;; and into this editor as `pos'. Deletes the comment box snip
+          (define/private (extract-contents pos snip)
+            (let ([editor (send snip get-editor)])
+              (let loop ([snip (send editor find-snip (send editor last-position) 'before-or-none)])
+                (cond
+                  [snip
+                   (insert (send snip copy) pos)
+                   (loop (send snip previous))]
+                  [else (void)]))
+              (let ([snip-pos (get-snip-position snip)])
+                (delete snip-pos (+ snip-pos 1)))
+              (set-position pos pos)))
+          
+          [define get-forward-sexp
+            (λ (start-pos)
+              (forward-match start-pos (last-position)))]
+          [define remove-sexp
+            (λ (start-pos)
+              (let ([end-pos (get-forward-sexp start-pos)])
+                (if end-pos 
+                    (kill 0 start-pos end-pos)
+                    (bell)))
+              #t)]
+          [define forward-sexp
+            (λ (start-pos)
+              (let ([end-pos (get-forward-sexp start-pos)])
+                (if end-pos 
+                    (set-position end-pos)
+                    (bell))
+                #t))]
+          [define flash-forward-sexp
+            (λ (start-pos)
+              (let ([end-pos (get-forward-sexp start-pos)])
+                (if end-pos 
+                    (flash-on end-pos (add1 end-pos))
+                    (bell)) 
+                #t))]	    
+          [define get-backward-sexp
+            (λ (start-pos)
+              (let* ([limit (get-limit start-pos)]
+                     [end-pos
+                      (backward-match start-pos limit)]
+                     [min-pos
+                      (backward-containing-sexp start-pos limit)]
+                     [ans
+                      (if (and end-pos 
+                               (or (not min-pos)
+                                   (>= end-pos min-pos)))
+                          end-pos
+                          #f)])
+                ans))]
+          [define flash-backward-sexp
+            (λ (start-pos)
+              (let ([end-pos (get-backward-sexp start-pos)])
+                (if end-pos
+                    (flash-on end-pos (add1 end-pos))
+                    (bell))
+                #t))]
+          [define backward-sexp
+            (λ (start-pos)
+              (let ([end-pos (get-backward-sexp start-pos)])
+                (if end-pos
+                    (set-position end-pos)
+                    (bell))
+                #t))]
+          [define find-up-sexp
+            (λ (start-pos)
+              (let* ([limit-pos (get-limit start-pos)]
+		     [exp-pos
+                      (backward-containing-sexp start-pos limit-pos)])
+                
+                (if (and exp-pos (> exp-pos limit-pos))
+		    (let* ([in-start-pos (skip-whitespace exp-pos 'backward #t)]
+			   [paren-pos
+			    (λ (paren-pair)
+			      (find-string
+			       (car paren-pair)
+			       'backward
+			       in-start-pos
+			       limit-pos))])
+		      (let ([poss (let loop ([parens (scheme-paren:get-paren-pairs)])
+				    (cond
+				     [(null? parens) null]
+				     [else 
+				      (let ([pos (paren-pos (car parens))])
+					(if pos
+					    (cons pos (loop (cdr parens)))
+					    (loop (cdr parens))))]))])
+			(if (null? poss) ;; all finds failed
+			    #f
+			    (- (apply max poss) 1)))) ;; subtract one to move outside the paren
+                    #f)))]
+          [define up-sexp
+            (λ (start-pos)
+              (let ([exp-pos (find-up-sexp start-pos)])
+                (if exp-pos
+                    (set-position exp-pos)
+                    (bell))
+                #t))]
+          [define find-down-sexp
+            (λ (start-pos)
+              (let ([last (last-position)])
+                (let loop ([pos start-pos])
+                  (let ([next-pos (forward-match pos last)])
+                    (if (and next-pos (> next-pos pos))
+                        (let ([back-pos
+                               (backward-containing-sexp (sub1 next-pos) pos)])
+                          (if (and back-pos
+                                   (> back-pos pos))
+                              back-pos
+                              (loop next-pos)))
+                        #f)))))]
+          [define down-sexp
+            (λ (start-pos)
+              (let ([pos (find-down-sexp start-pos)])
+                (if pos
+                    (set-position pos)
+                    (bell))
+                #t))]
+          [define remove-parens-forward
+            (λ (start-pos)
+              (let* ([pos (skip-whitespace start-pos 'forward #f)]
+                     [first-char (get-character pos)]
+                     [paren? (or (char=? first-char #\( )
+                                 (char=? first-char #\[ ))]
+                     [closer (if paren? 
+                                 (forward-match pos (last-position)))])
+                (if (and paren? closer)
+                    (begin (begin-edit-sequence)
+                           (delete pos (add1 pos))
+                           (delete (-  closer 2) (- closer 1))
+                           (end-edit-sequence))
+                    (bell))
+                #t))]
+          
+          (define/private (select-text f forward?)
+            (let* ([start-pos (get-start-position)]
+                   [end-pos (get-end-position)])
+              (let-values ([(new-start new-end)
+                            (if forward?
+                                (values start-pos (f end-pos))
+                                (values (f start-pos) end-pos))])
+                (if (and new-start new-end) 
+                    (set-position new-start new-end)
+                    (bell))
+                #t)))
+          (public select-forward-sexp select-backward-sexp select-up-sexp select-down-sexp
+                  transpose-sexp mark-matching-parenthesis)
+          
+          [define select-forward-sexp (λ () (select-text (λ (x) (get-forward-sexp x)) #t))]
+          [define select-backward-sexp (λ () (select-text (λ (x) (get-backward-sexp x)) #f))]
+          [define select-up-sexp (λ () (select-text (λ (x) (find-up-sexp x)) #f))]
+          [define select-down-sexp (λ () (select-text (λ (x) (find-down-sexp x)) #t))]
+          
+	  (inherit get-fixed-style)
+          (define (mark-matching-parenthesis pos)
+            (let ([open-parens (map car (scheme-paren:get-paren-pairs))]
+                  [close-parens (map cdr (scheme-paren:get-paren-pairs))])
+              (when (member (string (get-character pos)) open-parens)
+                (let ([end (get-forward-sexp pos)])
+                  (when (and end
+                             (member (string (get-character (- end 1))) close-parens))
+                    (let ([start-style (send (find-snip pos 'after) get-style)]
+                          [end-style (send (find-snip end 'before) get-style)])
+                      (cond
+                        [(and (eq? matching-parenthesis-style start-style)
+                              (eq? matching-parenthesis-style end-style))
+                         (let ([fixed-style (get-fixed-style)])
+                           (change-style fixed-style pos (+ pos 1))
+                           (change-style fixed-style (- end 1) end))]
+                        [else
+                         (change-style matching-parenthesis-style pos (+ pos 1))
+                         (change-style matching-parenthesis-style (- end 1) end)])))))))
+          
+          [define transpose-sexp
+            (λ (pos)
+              (let ([start-1 (get-backward-sexp pos)])
+                (if (not start-1)
+                    (bell)
+                    (let ([end-1 (get-forward-sexp start-1)])
+                      (if (not end-1)
+                          (bell)
+                          (let ([end-2 (get-forward-sexp end-1)])
+                            (if (not end-2)
+                                (bell)
+                                (let ([start-2 (get-backward-sexp end-2)])
+                                  (if (or (not start-2)
+                                          (< start-2 end-1))
+                                      (bell)
+                                      (let ([text-1 
+                                             (get-text start-1 end-1)]
+                                            [text-2 
+                                             (get-text start-2 end-2)])
+                                        (begin-edit-sequence)
+                                        (insert text-1 start-2 end-2)
+                                        (insert text-2 start-1 end-1)
+                                        (set-position end-2)
+                                        (end-edit-sequence)))))))))))]
+          [define tab-size 8]
+          (public get-tab-size set-tab-size)
+          [define get-tab-size (λ () tab-size)]
+          [define set-tab-size (λ (s) (set! tab-size s))]
+                    
+          (super-instantiate ())))
+
+      (define -text-mode<%>
+        (interface ()
+          ))
+      
+      (define text-mode-mixin
+        (mixin (color:text-mode<%> mode:surrogate-text<%>) (-text-mode<%>)
+
+          (define/override (on-disable-surrogate text)
+            (keymap:remove-chained-keymap text keymap)
+            (super on-disable-surrogate text))
+          
+          (define/override (on-enable-surrogate text)
+	    (send text begin-edit-sequence)
+	    (super on-enable-surrogate text)
+	    (send (send text get-keymap) chain-to-keymap keymap #t)
+            
+            ;; I don't know about these editor flag settings.
+            ;; maybe they belong in drscheme?
+            (send text set-load-overwrites-styles #f)
+            (send text set-wordbreak-map wordbreak-map)
+	    (let ([bw (box 0)]
+		  [bu (box #f)]
+		  [tab-size (send text get-tab-size)])
+	      (unless (and (null? (send text get-tabs #f bw bu))
+			   (= tab-size (unbox bw))
+			   (not (unbox bu)))
+                	(send text set-tabs null (send text get-tab-size) #f)))
+            (send text set-styles-fixed #t)
+	    (send text end-edit-sequence))
+          
+          (super-new (get-token scheme-lexer-wrapper)
+                     (token-sym->style short-sym->style-name)
+                     (matches '((|(| |)|)
+                                (|[| |]|)
+                                (|{| |}|))))))
+      
+      (define (scheme-lexer-wrapper in)
+        (let-values (((lexeme type paren start end) (scheme-lexer in)))
+          (cond
+            ((and (eq? type 'symbol)
+                  (get-keyword-type lexeme))
+             (values lexeme 'keyword paren start end))
+            (else
+             (values lexeme type paren start end)))))
+      
+      ;; get-keyword-type : string -> (union #f 'lambda 'define 'begin)
+      (define (get-keyword-type text)
+        (let* ([pref (preferences:get 'framework:tabify)]
+               [ht (car pref)]
+               [beg-reg (cadr pref)]
+               [def-reg (caddr pref)]
+               [lam-reg (cadddr pref)])
+          (hash-table-get 
+           ht
+           (string->symbol text)
+           (λ () 
+             (cond
+               [(and beg-reg (regexp-match beg-reg text)) 'begin]
+               [(and def-reg (regexp-match def-reg text)) 'define]
+               [(and lam-reg (regexp-match lam-reg text)) 'lambda]
+               [else #f])))))
+      
+      (define set-mode-mixin
+        (mixin (-text<%> mode:host-text<%>) ()
+	  (super-new)
+	  (inherit set-surrogate)
+	  (set-surrogate (new text-mode%))))
+
+      (define -text% (set-mode-mixin
+		      (text-mixin
+		       (mode:host-text-mixin
+			color:text%))))
+
+      (define text-mode% (text-mode-mixin color:text-mode%))
+    
+                                                                                           
+              ;;                                 ;;                                        
+               ;                                  ;                                        
+               ;                                  ;                                        
+  ;;;    ;;;   ; ;;    ;;;  ;;; ;    ;;;          ;  ;;   ;;;  ;;; ;;;;;; ;   ;;;;  ; ;;;  
+ ;   ;  ;   ;  ;;  ;  ;   ;  ; ; ;  ;   ;         ; ;    ;   ;  ;   ;  ; ; ;      ;  ;   ; 
+  ;;;   ;      ;   ;  ;;;;;  ; ; ;  ;;;;;         ;;     ;;;;;  ;   ;  ; ; ;   ;;;;  ;   ; 
+     ;  ;      ;   ;  ;      ; ; ;  ;             ; ;    ;       ; ;   ; ; ;  ;   ;  ;   ; 
+ ;   ;  ;   ;  ;   ;  ;   ;  ; ; ;  ;   ;         ;  ;   ;   ;   ;;;   ; ; ;  ;   ;  ;   ; 
+  ;;;    ;;;  ;;; ;;;  ;;;  ;; ; ;;  ;;;         ;;   ;;  ;;;     ;   ;; ; ;;  ;;; ; ;;;;  
+                                                                  ;                  ;     
+                                                                  ;                  ;     
+                                                                ;;                  ;;;    
+      (define setup-keymap
+        (λ (keymap)
+          
+          (let ([add-pos-function
+                 (λ (name call-method)
+                   (send keymap add-function name
+                         (λ (edit event)
+                           (call-method
+                            edit
+                            (send edit get-start-position)))))])
+            (add-pos-function "remove-sexp" (λ (e p) (send e remove-sexp p)))
+            (add-pos-function "forward-sexp" (λ (e p) (send e forward-sexp p)))
+            (add-pos-function "backward-sexp" (λ (e p) (send e backward-sexp p)))
+            (add-pos-function "up-sexp" (λ (e p) (send e up-sexp p)))
+            (add-pos-function "down-sexp" (λ (e p) (send e down-sexp p)))
+            (add-pos-function "flash-backward-sexp" (λ (e p) (send e flash-backward-sexp p)))
+            (add-pos-function "flash-forward-sexp" (λ (e p) (send e flash-forward-sexp p)))
+            (add-pos-function "remove-parens-forward" (λ (e p) (send e remove-parens-forward p)))
+            (add-pos-function "transpose-sexp" (λ (e p) (send e transpose-sexp p)))
+            (add-pos-function "mark-matching-parenthesis"
+                              (λ (e p) (send e mark-matching-parenthesis p))))
+          
+          (let ([add-edit-function
+                 (λ (name call-method)
+                   (send keymap add-function name
+                         (λ (edit event)
+                           (call-method edit))))])
+            (add-edit-function "select-forward-sexp" 
+                               (λ (x) (send x select-forward-sexp)))
+            (add-edit-function "select-backward-sexp"  
+                               (λ (x) (send x select-backward-sexp)))
+            (add-edit-function "select-down-sexp"  
+                               (λ (x) (send x select-down-sexp)))
+            (add-edit-function "select-up-sexp"  
+                               (λ (x) (send x select-up-sexp)))
+            (add-edit-function "tabify-at-caret"  
+                               (λ (x) (send x tabify-selection)))
+            (add-edit-function "do-return"  
+                               (λ (x) 
+                                 (send x insert-return)))
+            (add-edit-function "comment-out"  
+                               (λ (x) (send x comment-out-selection)))
+            (add-edit-function "box-comment-out"  
+                               (λ (x) (send x box-comment-out-selection)))
+            (add-edit-function "uncomment"  
+                               (λ (x) (send x uncomment-selection))))
+          
+          (send keymap add-function "balance-parens"
+                (λ (edit event)
+                  (send edit balance-parens event)))
+          
+          (send keymap map-function "TAB" "tabify-at-caret")
+          
+          (send keymap map-function "return" "do-return")
+          (send keymap map-function "s:return" "do-return")
+          (send keymap map-function "s:c:return" "do-return")
+          (send keymap map-function "a:return" "do-return")
+          (send keymap map-function "s:a:return" "do-return")
+          (send keymap map-function "c:a:return" "do-return")
+          (send keymap map-function "c:s:a:return" "do-return")
+          (send keymap map-function "c:return" "do-return")
+          (send keymap map-function "d:return" "do-return")
+          
+          (send keymap map-function ")" "balance-parens")
+          (send keymap map-function "]" "balance-parens")
+          (send keymap map-function "}" "balance-parens")
+          
+          (let ([map-meta
+                 (λ (key func)
+                   (keymap:send-map-function-meta keymap key func))]
+                [map
+                 (λ (key func)
+                   (send keymap map-function key func))])
+            
+            (map-meta "up" "up-sexp")
+            (map-meta "c:u" "up-sexp")
+            (map "a:up" "up-sexp")
+            (map-meta "s:up" "select-up-sexp")
+            (map "a:s:up" "select-up-sexp")
+            (map-meta "s:c:u" "select-up-sexp")
+            
+            (map-meta "down" "down-sexp")
+            (map "a:down" "down-sexp")
+            (map-meta "s:down" "select-down-sexp")
+            (map "a:s:down" "select-down-sexp")
+            (map-meta "s:c:down" "select-down-sexp")
+            
+            (map-meta "right" "forward-sexp")
+            (map "a:right" "forward-sexp")
+            (map-meta "s:right" "select-forward-sexp")
+            (map "a:s:right" "select-forward-sexp")
+            
+            (map-meta "left" "backward-sexp")
+            (map "a:left" "backward-sexp")
+            (map-meta "s:left" "select-backward-sexp")
+            (map "a:s:left" "select-backward-sexp")
+            
+            (map-meta "return" "do-return")
+            (map-meta "s:return" "do-return")
+            (map-meta "s:c:return" "do-return")
+            (map-meta "a:return" "do-return")
+            (map-meta "s:a:return" "do-return")
+            (map-meta "c:a:return" "do-return")
+            (map-meta "c:s:a:return" "do-return")
+            (map-meta "c:return" "do-return")
+            
+            (map-meta "c:semicolon" "comment-out")
+            (map-meta "c:=" "uncomment")
+            (map-meta "c:k" "remove-sexp")
+            
+            (map-meta "c:f" "forward-sexp")
+            (map-meta "s:c:f" "select-forward-sexp")
+            
+            (map-meta "c:b" "backward-sexp")
+            (map-meta "s:c:b" "select-backward-sexp")
+            
+            (map-meta "c:p" "flash-backward-sexp")
+            (map-meta "s:c:n" "flash-forward-sexp")
+            
+            (map-meta "c:space" "select-forward-sexp")
+            (map-meta "c:t" "transpose-sexp")
+            
+            ;(map-meta "c:m" "mark-matching-parenthesis")
+            ; this keybinding doesn't interact with the paren colorer
+            )
+          (send keymap map-function "c:c;c:b" "remove-parens-forward")))
+      
+      (define keymap (make-object keymap:aug-keymap%))
+      (setup-keymap keymap)
+      (define (get-keymap) keymap)
+      
+                                                                             
+                        ;;;                                            ;;;   
+                       ;                                                 ;   
+                       ;                                                 ;   
+; ;;;   ; ;;;   ;;;   ;;;;;   ;;;         ; ;;;   ;;;;  ; ;;;    ;;;     ;   
+ ;   ;   ;     ;   ;   ;     ;   ;         ;   ;      ;  ;;  ;  ;   ;    ;   
+ ;   ;   ;     ;;;;;   ;      ;;;          ;   ;   ;;;;  ;   ;  ;;;;;    ;   
+ ;   ;   ;     ;       ;         ;         ;   ;  ;   ;  ;   ;  ;        ;   
+ ;   ;   ;     ;   ;   ;     ;   ;         ;   ;  ;   ;  ;   ;  ;   ;    ;   
+ ;;;;   ;;;;    ;;;   ;;;;    ;;;          ;;;;    ;;; ;;;;  ;;  ;;;   ;;;;;;
+ ;                                         ;                                 
+ ;                                         ;                                 
+;;;                                       ;;;                                
+
+      
+      (define (add-preferences-panel)
+        (preferences:add-panel
+         (list (string-constant editor-prefs-panel-label) 
+               (string-constant indenting-prefs-panel-label))
+         (λ (p)
+           (define get-keywords
+             (λ (hash-table)
+               (letrec ([all-keywords (hash-table-map hash-table list)]
+                        [pick-out (λ (wanted in out)
+                                    (cond
+                                      [(null? in) (quicksort out string<=?)]
+                                      [else (if (eq? wanted (cadr (car in))) 
+                                                (pick-out wanted (cdr in) (cons (symbol->string (car (car in))) out))
+                                                (pick-out wanted (cdr in) out))]))])
+                 (values  (pick-out 'begin all-keywords null)
+                          (pick-out 'define all-keywords null)
+                          (pick-out 'lambda all-keywords null)))))
+           (define-values (begin-keywords define-keywords lambda-keywords)
+             (get-keywords (car (preferences:get 'framework:tabify))))
+           (define add-button-callback
+             (λ (keyword-type keyword-symbol list-box)
+               (λ (button command)
+                 (let ([new-one
+                        (keymap:call/text-keymap-initializer
+                         (λ ()
+                           (get-text-from-user
+                            (format (string-constant enter-new-keyword) keyword-type)
+                            (format (string-constant x-keyword) keyword-type))))])
+                   (when new-one
+                     (let ([parsed (with-handlers ((exn:fail:read? (λ (x) #f)))
+                                     (read (open-input-string new-one)))])
+                       (cond
+                         [(and (symbol? parsed)
+                               (hash-table-get (car (preferences:get 'framework:tabify))
+                                               parsed
+                                               (λ () #f)))
+                          (message-box (string-constant error)
+                                       (format (string-constant already-used-keyword) parsed))]
+                         [(symbol? parsed)
+                          (let ([ht (car (preferences:get 'framework:tabify))])
+                            (hash-table-put! ht parsed keyword-symbol)
+                            (update-list-boxes ht))]
+                         [else (message-box 
+                                (string-constant error)
+                                (format (string-constant expected-a-symbol) new-one))])))))))
+           (define delete-callback
+             (λ (list-box)
+               (λ (button command)
+                 (let* ([selections (send list-box get-selections)]
+                        [symbols (map (λ (x) (string->symbol (send list-box get-string x))) selections)])
+                   (for-each (λ (x) (send list-box delete x)) (reverse selections))
+                   (let ([ht (car (preferences:get 'framework:tabify))])
+                     (for-each (λ (x) (hash-table-remove! ht x)) symbols))))))
+           (define main-panel (make-object horizontal-panel% p))
+           (define make-column
+             (λ (string symbol keywords bang-regexp)
+               (let* ([vert (make-object vertical-panel% main-panel)]
+                      [_ (make-object message% (format (string-constant x-like-keywords) string) vert)]
+                      [box (make-object list-box% #f keywords vert void '(multiple))]
+                      [button-panel (make-object horizontal-panel% vert)]
+                      [text (new text-field% 
+                                 (label (string-constant indenting-prefs-extra-regexp))
+                                 (callback (λ (tf evt) 
+                                             (let ([str (send tf get-value)])
+                                               (cond
+                                                 [(equal? str "") 
+                                                  (bang-regexp #f)]
+                                                 [else
+                                                  (with-handlers ([exn:fail?
+                                                                   (λ (x)
+                                                                     (color-yellow (send tf get-editor)))])
+                                                    (bang-regexp (regexp str))
+                                                    (clear-color (send tf get-editor)))]))))
+                                 (parent vert))]
+                      [add-button (make-object button% (string-constant add-keyword)
+                                    button-panel (add-button-callback string symbol box))]
+                      [delete-button (make-object button% (string-constant remove-keyword)
+                                       button-panel (delete-callback box))])
+                 (send* button-panel 
+                   (set-alignment 'center 'center)
+                   (stretchable-height #f))
+                 (send add-button min-width (send delete-button get-width))
+                 (values box text))))
+           (define (color-yellow text)
+             (let ([sd (make-object style-delta%)])
+               (send sd set-delta-background "yellow")
+               (send text change-style sd 0 (send text last-position))))
+           (define (clear-color text)
+             (let ([sd (make-object style-delta%)])
+               (send sd set-delta-background "white")
+               (send text change-style sd 0 (send text last-position))))
+           (define-values (begin-list-box begin-regexp-text) 
+             (make-column "Begin"
+                          'begin
+                          begin-keywords
+                          (λ (x) (set-car! (cdr (preferences:get 'framework:tabify)) x))))
+           (define-values (define-list-box define-regexp-text) 
+             (make-column "Define" 
+                          'define 
+                          define-keywords
+                          (λ (x) (set-car! (cddr (preferences:get 'framework:tabify)) x))))
+           (define-values (lambda-list-box lambda-regexp-text)
+             (make-column "Lambda"
+                          'lambda
+                          lambda-keywords
+                          (λ (x) (set-car! (cdddr (preferences:get 'framework:tabify)) x))))
+           (define update-list-boxes
+             (λ (hash-table)
+               (let-values ([(begin-keywords define-keywords lambda-keywords) (get-keywords hash-table)]
+                            [(reset) (λ (list-box keywords)
+                                       (send list-box clear)
+                                       (for-each (λ (x) (send list-box append x)) keywords))])
+                 (reset begin-list-box begin-keywords)
+                 (reset define-list-box define-keywords)
+                 (reset lambda-list-box lambda-keywords)
+                 #t)))
+           (define update-gui
+             (λ (pref)
+               (update-list-boxes (car pref))
+               (send begin-regexp-text set-value (or (object-name (cadr pref)) ""))
+               (send define-regexp-text set-value (or (object-name (caddr pref)) ""))
+               (send lambda-regexp-text set-value (or (object-name (cadddr pref)) ""))))
+           (preferences:add-callback 'framework:tabify (λ (p v) (update-gui v)))
+           main-panel))))))
diff --git a/collects/framework/private/sig.ss b/collects/framework/private/sig.ss
new file mode 100644
index 0000000000..26a2b51420
--- /dev/null
+++ b/collects/framework/private/sig.ss
@@ -0,0 +1,596 @@
+
+(module sig mzscheme
+  (require (lib "unitsig.ss"))
+
+  (provide framework:menu^
+	   framework:menu-class^
+	   framework:menu-fun^
+	   framework:version^
+	   framework:version-class^
+	   framework:version-fun^
+	   framework:panel^
+	   framework:panel-class^
+	   framework:panel-fun^
+	   framework:exn^
+	   framework:exn-class^
+	   framework:exn-fun^
+	   framework:application^
+	   framework:application-class^
+	   framework:application-fun^
+	   framework:preferences^
+	   framework:preferences-class^
+	   framework:preferences-fun^
+	   framework:autosave^
+	   framework:autosave-class^
+	   framework:autosave-fun^
+	   framework:exit^
+	   framework:exit-class^
+	   framework:exit-fun^
+	   framework:path-utils^
+	   framework:path-utils-class^
+	   framework:path-utils-fun^
+	   framework:finder^
+	   framework:finder-class^
+	   framework:finder-fun^
+	   framework:editor^
+	   framework:editor-class^
+	   framework:editor-fun^
+	   framework:pasteboard^
+	   framework:pasteboard-class^
+	   framework:pasteboard-fun^
+	   framework:text^
+	   framework:text-class^
+	   framework:text-fun^
+	   framework:canvas^
+	   framework:canvas-class^
+	   framework:canvas-fun^
+	   framework:frame^
+	   framework:frame-class^
+	   framework:frame-fun^
+	   framework:group^
+	   framework:group-class^
+	   framework:group-fun^
+	   framework:handler^
+	   framework:handler-class^
+	   framework:handler-fun^
+	   framework:icon^
+	   framework:icon-class^
+	   framework:icon-fun^
+	   framework:keymap^
+	   framework:keymap-class^
+	   framework:keymap-fun^
+           framework:color^
+           framework:color-class^
+           framework:color-fun^
+           framework:color-prefs^
+           framework:color-prefs-class^
+           framework:color-prefs-fun^
+	   framework:scheme^
+	   framework:scheme-class^
+	   framework:scheme-fun^
+	   framework:main^
+	   framework:main-class^
+	   framework:main-fun^
+	   framework:mode^
+           framework:mode-class^
+           framework:mode-fun^
+           framework:color-model^
+	   framework:color-model-class^
+	   framework:color-model-fun^
+           framework:comment-box-fun^
+           framework:comment-box-class^
+           framework:comment-box^
+           framework:number-snip^
+           framework:number-snip-fun^
+           framework:number-snip-class^)
+           
+  (define-signature framework:number-snip-fun^ 
+    (make-repeating-decimal-snip
+     make-fraction-snip))
+  (define-signature framework:number-snip-class^ 
+    (snip-class%))
+  (define-signature framework:number-snip^
+    ((open framework:number-snip-fun^)
+     (open framework:number-snip-class^)))
+  
+  (define-signature framework:comment-box-fun^
+    ())
+  (define-signature framework:comment-box-class^
+    (snipclass snip%))
+  (define-signature framework:comment-box^
+    ((open framework:comment-box-fun^)
+     (open framework:comment-box-class^)))
+  
+  (define-signature framework:menu-class^
+    (can-restore<%>
+     can-restore-mixin
+     can-restore-underscore<%>
+     can-restore-underscore-mixin
+     can-restore-menu-item%
+     can-restore-checkable-menu-item%
+     can-restore-underscore-menu%))
+  (define-signature framework:menu-fun^
+    ())
+  (define-signature framework:menu^
+    ((open framework:menu-class^)
+     (open framework:menu-fun^)))
+
+  (define-signature framework:version-class^
+    ())
+  (define-signature framework:version-fun^
+    (add-spec
+     version))
+  (define-signature framework:version^
+    ((open framework:version-class^)
+     (open framework:version-fun^)))
+
+  (define-signature framework:panel-class^
+    (single-mixin
+     single<%>
+
+     single-window<%>
+     single-window-mixin
+
+     ;;multi-view-mixin
+     ;;multi-view<%>
+
+     
+     single%
+     single-pane%
+     ;;multi-view%
+
+     dragable<%>
+     dragable-mixin
+
+     vertical-dragable<%>
+     vertical-dragable-mixin
+     vertical-dragable%
+
+     horizontal-dragable<%>
+     horizontal-dragable-mixin
+     horizontal-dragable%))
+  (define-signature framework:panel-fun^
+    ())
+  (define-signature framework:panel^
+    ((open framework:panel-class^)
+     (open framework:panel-fun^)))
+
+  (define-signature framework:exn-class^
+    ())
+  (define-signature framework:exn-fun^
+    ((struct exn ())
+     (struct unknown-preference ())))
+  (define-signature framework:exn^
+    ((open framework:exn-class^)
+     (open framework:exn-fun^)))
+
+  (define-signature framework:application-class^
+    ())
+  (define-signature framework:application-fun^
+    (current-app-name))
+  (define-signature framework:application^
+    ((open framework:application-class^)
+     (open framework:application-fun^)))
+
+  (define-signature framework:preferences-class^
+    ())
+  (define-signature framework:preferences-fun^
+    (get
+     add-callback
+     set
+     set-default
+     set-un/marshall
+
+     save
+     silent-save
+     restore-defaults
+     
+     add-panel
+     add-font-panel
+
+     add-editor-checkbox-panel
+     add-warnings-checkbox-panel
+     add-scheme-checkbox-panel
+
+     add-to-editor-checkbox-panel
+     add-to-warnings-checkbox-panel
+     add-to-scheme-checkbox-panel
+     
+     add-on-close-dialog-callback
+     add-can-close-dialog-callback
+
+     show-dialog
+     hide-dialog))
+  (define-signature framework:preferences^
+    ((open framework:preferences-class^)
+     (open framework:preferences-fun^)))
+
+  (define-signature framework:autosave-class^
+    (autosavable<%>))
+  (define-signature framework:autosave-fun^
+    (register
+     restore-autosave-files/gui))
+  (define-signature framework:autosave^
+    ((open framework:autosave-class^)
+     (open framework:autosave-fun^)))
+
+  (define-signature framework:exit-class^
+    ())
+  (define-signature framework:exit-fun^
+    (set-exiting
+     exiting?
+     user-oks-exit
+     insert-on-callback
+     insert-can?-callback
+     can-exit?
+     on-exit
+     exit))
+  (define-signature framework:exit^
+    ((open framework:exit-class^)
+     (open framework:exit-fun^)))
+
+  (define-signature framework:path-utils-class^
+    ())
+  (define-signature framework:path-utils-fun^
+    (generate-autosave-name 
+     generate-backup-name))
+  (define-signature framework:path-utils^
+    ((open framework:path-utils-class^)
+     (open framework:path-utils-fun^)))
+
+  (define-signature framework:finder-class^
+    ())
+  (define-signature framework:finder-fun^
+    (dialog-parent-parameter
+     default-extension
+     default-filters
+     common-put-file 
+     common-get-file 
+     std-put-file 
+     std-get-file 
+     common-get-file-list
+     get-file
+     put-file))
+  (define-signature framework:finder^
+    ((open framework:finder-class^)
+     (open framework:finder-fun^)))
+
+  (define-signature framework:editor-class^
+    (basic<%>
+     standard-style-list<%>
+     keymap<%>
+     autowrap<%>
+     info<%>
+     file<%>
+     backup-autosave<%>
+     basic-mixin
+     standard-style-list-mixin
+     keymap-mixin
+     autowrap-mixin
+     info-mixin
+     file-mixin
+     backup-autosave-mixin))
+  (define-signature framework:editor-fun^
+    (get-standard-style-list
+     set-standard-style-list-pref-callbacks
+     set-standard-style-list-delta
+     set-default-font-color
+     get-default-color-style-name))
+  (define-signature framework:editor^
+    ((open framework:editor-class^)
+     (open framework:editor-fun^)))
+
+  (define-signature framework:pasteboard-class^
+    (basic%
+     standard-style-list%
+     keymap%
+     file%
+     backup-autosave%
+     info%))
+  (define-signature framework:pasteboard-fun^
+    ())
+  (define-signature framework:pasteboard^
+    ((open framework:pasteboard-class^)
+     (open framework:pasteboard-fun^)))
+
+  (define-signature framework:text-class^
+    (basic<%>
+     foreground-color<%>
+     hide-caret/selection<%>
+     nbsp->space<%>
+     delegate<%>
+     wide-snip<%>
+     searching<%>
+     return<%>
+     info<%>
+     file<%>
+     clever-file-format<%>
+     ports<%>
+     input-box<%>
+     
+     basic% 
+     hide-caret/selection%
+     nbsp->space%
+     1-pixel-string-snip%
+     1-pixel-tab-snip%
+     delegate%
+     wide-snip%
+     standard-style-list%
+     keymap%
+     return%
+     autowrap%
+     file%
+     clever-file-format%
+     backup-autosave%
+     searching%
+     info%
+     input-box%
+     
+     basic-mixin
+     foreground-color-mixin
+     hide-caret/selection-mixin
+     nbsp->space-mixin
+     wide-snip-mixin
+     delegate-mixin
+     searching-mixin
+     return-mixin
+     info-mixin
+     file-mixin
+     clever-file-format-mixin
+     ports-mixin
+     input-box-mixin))
+  (define-signature framework:text-fun^
+    ())
+  (define-signature framework:text^
+    ((open framework:text-class^)
+     (open framework:text-fun^)))
+
+  (define-signature framework:canvas-class^
+    (basic<%>
+     color<%>
+     delegate<%>
+     info<%>
+     wide-snip<%>
+     
+     basic%
+     color%
+     info%
+     delegate%
+     wide-snip%
+
+     basic-mixin
+     color-mixin
+     delegate-mixin
+     info-mixin
+     wide-snip-mixin))
+  (define-signature framework:canvas-fun^
+    ())
+  (define-signature framework:canvas^
+    ((open framework:canvas-class^)
+     (open framework:canvas-fun^)))
+
+  (define-signature framework:frame-class^
+    (basic<%>
+     size-pref<%>
+     register-group<%>
+     status-line<%>
+     standard-menus<%>
+     editor<%>
+     open-here<%>
+     text<%>
+     pasteboard<%>
+     delegate<%>
+     searchable<%>
+     searchable-text<%>
+     info<%>
+     text-info<%>
+     pasteboard-info<%>
+     
+     basic%
+     size-pref%
+     status-line%
+     info%
+     text-info%
+     pasteboard-info%
+     standard-menus%
+     editor%
+     open-here%
+     text%
+     searchable%
+     delegate%
+     pasteboard%
+     
+     basic-mixin
+     size-pref-mixin
+     register-group-mixin
+     status-line-mixin
+     standard-menus-mixin
+     editor-mixin
+     open-here-mixin
+     text-mixin
+     pasteboard-mixin
+     delegate-mixin
+     searchable-mixin
+     searchable-text-mixin
+     info-mixin
+     text-info-mixin
+     pasteboard-info-mixin))
+  (define-signature framework:frame-fun^
+    (reorder-menus
+     add-snip-menu-items
+     setup-size-pref))
+  (define-signature framework:frame^
+    ((open framework:frame-class^)
+     (open framework:frame-fun^)))
+
+  (define-signature framework:group-class^
+    (%))
+  (define-signature framework:group-fun^
+    (get-the-frame-group))
+  (define-signature framework:group^
+    ((open framework:group-class^)
+     (open framework:group-fun^)))
+
+  (define-signature framework:handler-class^
+    ())
+  (define-signature framework:handler-fun^
+    (handler? 
+     handler-name 
+     handler-extension
+     handler-handler
+     insert-format-handler
+     find-format-handler 
+     find-named-format-handler 
+     current-create-new-window
+     edit-file
+     open-file
+     install-recent-items
+     add-to-recent
+     set-recent-position
+     set-recent-items-frame-superclass
+     size-recently-opened-files))
+  (define-signature framework:handler^
+    ((open framework:handler-class^)
+     (open framework:handler-fun^)))
+
+  (define-signature framework:icon-class^
+    ())
+  (define-signature framework:icon-fun^
+    (get-paren-highlight-bitmap
+     get-autowrap-bitmap
+     get-eof-bitmap
+     
+     get-lock-bitmap
+     get-unlock-bitmap
+     get-anchor-bitmap
+
+     get-left/right-cursor
+     get-up/down-cursor
+     
+     get-gc-on-bitmap
+     get-gc-off-bitmap))
+  (define-signature framework:icon^
+    ((open framework:icon-class^)
+     (open framework:icon-fun^)))
+
+  (define-signature framework:keymap-class^
+    (aug-keymap%
+     aug-keymap<%>
+     aug-keymap-mixin))
+  (define-signature framework:keymap-fun^
+    (send-map-function-meta
+     make-meta-prefix-list
+
+     canonicalize-keybinding-string
+
+     add-to-right-button-menu
+     add-to-right-button-menu/before
+
+     setup-global
+     setup-search
+     setup-file
+     setup-editor
+
+     get-global
+     get-search
+     get-file
+     get-editor
+
+     set-chained-keymaps
+     remove-chained-keymap
+     
+     call/text-keymap-initializer
+     
+     add-user-keybindings-file
+     remove-user-keybindings-file))
+  (define-signature framework:keymap^
+    ((open framework:keymap-class^)
+     (open framework:keymap-fun^)))
+
+  (define-signature framework:color-class^
+    (text<%>
+     text-mixin
+     text%
+
+     text-mode<%>
+     text-mode-mixin
+     text-mode%))
+  (define-signature framework:color-fun^
+    ())
+  (define-signature framework:color^
+    ((open framework:color-class^)
+     (open framework:color-fun^)))
+  
+  (define-signature framework:color-prefs-class^
+    ())
+  (define-signature framework:color-prefs-fun^
+    (register-color-pref
+     add-to-preferences-panel
+     build-color-selection-panel
+     add-background-preferences-panel
+     marshall-style
+     unmarshall-style))
+  (define-signature framework:color-prefs^
+    ((open framework:color-prefs-class^)
+     (open framework:color-prefs-fun^)))
+  
+  
+  (define-signature framework:scheme-class^
+    (text<%>
+     text-mixin
+     text%
+     
+     text-mode<%>
+     text-mode-mixin
+     text-mode%
+     
+     set-mode-mixin
+
+     sexp-snip%
+     sexp-snip<%>))
+  (define-signature framework:scheme-fun^
+    (get-wordbreak-map
+     init-wordbreak-map
+     get-keymap
+     setup-keymap
+     add-preferences-panel
+     add-coloring-preferences-panel
+     
+     get-color-prefs-table
+     short-sym->pref-name
+     short-sym->style-name
+     
+     text-balanced?))
+  (define-signature framework:scheme^
+    ((open framework:scheme-class^)
+     (open framework:scheme-fun^)))
+
+  (define-signature framework:main-class^ ())
+  (define-signature framework:main-fun^ ())
+  (define-signature framework:main^
+    ((open framework:main-class^)
+     (open framework:main-fun^)))
+
+  (define-signature framework:mode-class^ 
+    (host-text-mixin
+     host-text<%>
+     surrogate-text%
+     surrogate-text<%>))
+  (define-signature framework:mode-fun^ ())
+  (define-signature framework:mode^
+    ((open framework:mode-class^)
+     (open framework:mode-fun^)))
+
+  (define-signature framework:color-model-class^
+    ())
+  (define-signature framework:color-model-fun^
+    (xyz?
+     xyz-x
+     xyz-y
+     xyz-z
+     rgb-color-distance
+     rgb->xyz
+     xyz->rgb))
+  (define-signature framework:color-model^
+    ((open framework:color-model-class^)
+     (open framework:color-model-fun^))))
diff --git a/collects/framework/private/standard-menus-items.ss b/collects/framework/private/standard-menus-items.ss
new file mode 100644
index 0000000000..9046544b0e
--- /dev/null
+++ b/collects/framework/private/standard-menus-items.ss
@@ -0,0 +1,385 @@
+(module standard-menus-items mzscheme
+
+  (provide
+   (struct generic (name initializer))
+   
+   (struct generic/docs (documentation))
+   
+   (struct generic-override ())
+   (struct generic-augment ())
+   (struct generic-method ())
+   (struct generic-private-field ())
+   
+   (struct menu-item (menu-name))
+   menu-name->get-menu-name ;; : menu-item -> symbol
+   
+   (struct before/after (name procedure))
+   (struct before ())
+   (struct after ())
+   
+   (struct between (before after procedure))
+   
+   (struct an-item (item-name help-string proc key menu-string on-demand create))
+   (struct a-submenu-item ()) 
+   
+   ;; an-item -> symbol
+   ;; calcualates the names of various identifiers associated with the item.
+   an-item->callback-name
+   an-item->create-menu-item-name
+   an-item->get-item-name
+   an-item->item-name
+   an-item->on-demand-name
+   an-item->string-name
+   an-item->help-string-name
+   
+   before/after->name
+   between->name
+   
+   items)
+  
+  (define-struct generic (name initializer))
+  (define-struct (generic/docs generic) (documentation))
+  (define-struct (generic-override generic/docs) ())
+  (define-struct (generic-augment generic/docs) ())
+  (define-struct (generic-method generic/docs) ())
+  (define-struct (generic-private-field generic) ())
+  
+  (define-struct menu-item (menu-name))
+  (define (menu-name->get-menu-name menu-item)
+    (string->symbol
+     (format "get-~a" (menu-item-menu-name menu-item))))
+  
+  (define-struct (before/after menu-item) (name procedure))
+  (define-struct (before before/after) ())
+  (define-struct (after before/after) ())
+  (define (before/after->name before/after)
+    (string->symbol (format "~a:~a-~a"
+                            (menu-item-menu-name before/after)
+                            (if (before? before/after)
+                                "before"
+                                "after")
+                            (before/after-name before/after))))
+  
+  (define-struct (between menu-item) (before after procedure))
+  (define (between->name between)
+    (string->symbol (format "~a:between-~a-and-~a"
+                            (menu-item-menu-name between)
+                            (between-before between)
+                            (between-after between))))
+  
+  (define-struct (an-item menu-item)
+                 (item-name
+                  help-string
+                  proc
+                  key
+                  menu-string
+                  on-demand
+                  create))
+  (define-struct (a-submenu-item an-item) ())
+  
+  (define (an-item->callback-name item)
+    (string->symbol
+     (format "~a:~a-callback" (menu-item-menu-name item) (an-item-item-name item))))
+  (define (an-item->create-menu-item-name item)
+    (string->symbol
+     (format "~a:create-~a?" (menu-item-menu-name item) (an-item-item-name item))))
+  (define (an-item->get-item-name item)
+    (string->symbol
+     (format "~a:get-~a-item" (menu-item-menu-name item) (an-item-item-name item))))
+  (define (an-item->item-name item)
+    (string->symbol
+     (format "~a:~a-item" (menu-item-menu-name item) (an-item-item-name item))))
+  (define (an-item->on-demand-name item)
+    (string->symbol
+     (format "~a:~a-on-demand" (menu-item-menu-name item) (an-item-item-name item))))
+  (define (an-item->string-name item)
+    (string->symbol
+     (format "~a:~a-string" (menu-item-menu-name item) (an-item-item-name item))))
+  (define (an-item->help-string-name item)
+    (string->symbol
+     (format "~a:~a-help-string" (menu-item-menu-name item) (an-item-item-name item))))
+  
+  (define (edit-menu:do const)
+    `(λ (menu evt)
+       (let ([edit (get-edit-target-object)])
+         (when (and edit
+                    (is-a? edit editor<%>))
+           (send edit do-edit-operation ',const)))
+       #t))
+  
+  (define (edit-menu:can-do-on-demand const)
+    `(λ (item)
+       (let* ([editor (get-edit-target-object)]
+              [enable?
+               (and editor
+                    (is-a? editor editor<%>)
+                    (send editor can-do-edit-operation? ',const))])
+         (send item enable enable?))))
+  
+  (define edit-menu:edit-target-on-demand
+    `(λ (item)
+       (send item enable
+             (let ([target (get-edit-target-object)])
+               (and target (is-a? target editor<%>))))))
+  
+  (define on-demand-do-nothing '(λ (menu-item) (void)))
+
+  (define items
+    (list (make-generic-augment
+           'on-close
+           '(lambda ()
+              (remove-prefs-callback)
+              (inner (void) on-close))
+           '("@return : void"
+             "Removes the preferences callbacks for the menu items"))
+          (make-generic-method 
+           'get-menu% '(λ () menu:can-restore-underscore-menu%)
+           '("The result of this method is used as the class"
+             "for creating the result of these methods:"
+             "@ilink frame:standard-menus get-file-menu %"
+             ", "
+             "@ilink frame:standard-menus get-edit-menu %"
+             ", "
+             "@ilink frame:standard-menus get-help-menu %"
+             ". "
+             ""
+             "@return : (derived-from \\iscmclass{menu:can-restore-underscore-menu})"
+             ""
+             "defaultly returns"
+             "@link menu"))
+          (make-generic-method 
+           'get-menu-item% '(λ () menu:can-restore-menu-item%)
+           '("The result of this method is used as the class for creating"
+             "the menu items in this frame (see "
+             "@link frame:standard-menus"
+             "for a list)."
+             ""
+             "@return : (derived-from \\iscmclass{menu-item})"
+             ""
+             "defaultly returns"
+             "@link menu:can-restore-menu-item %"
+             "."))
+          (make-generic-method 
+           'get-checkable-menu-item% '(λ () menu:can-restore-checkable-menu-item%)
+           '("The result of this method is used as the class for creating"
+             "checkable menu items in this class (see "
+             "@link frame:standard-menus"
+             "for a list)."
+             ""
+             "@return : (derived-from \\iscmclass{checkable-menu-item})"
+             ""
+             "defaultly returns"
+             "@link menu:can-restore-checkable-menu-item %"
+             "."))
+          
+          (make-generic-method 
+           'get-file-menu
+           '(λ () file-menu)
+           '("Returns the file menu"
+             "See also"
+             "@ilink frame:standard-menus get-menu\\%"
+             ""
+             "@return : (instance (derived-from \\iscmclass{menu}))"))
+          (make-generic-private-field 
+           'file-menu
+           '(make-object (get-menu%)
+              (string-constant file-menu-label)
+              (get-menu-bar)))
+          (make-generic-method
+           'get-edit-menu
+           '(λ () edit-menu)
+           
+           '("Returns the edit menu"
+             "See also"
+             "@ilink frame:standard-menus get-menu\\%"
+             ""
+             "@return : (instance (derived-from \\iscmclass{menu}))"))
+          (make-generic-private-field 
+           'edit-menu
+           '(make-object (get-menu%) (string-constant edit-menu-label) (get-menu-bar)))
+          (make-generic-method
+           'get-help-menu
+           '(λ () help-menu)
+           
+           '("Returns the help menu"
+             "See also"
+             "@ilink frame:standard-menus get-menu\\%"
+             ""
+             "@return : (instance (derived-from \\iscmclass{menu}))"))
+          (make-generic-private-field
+           'help-menu
+           '(make-object (get-menu%) (string-constant help-menu-label) (get-menu-bar)))
+          
+          (make-an-item 'file-menu 'new 
+                        '(string-constant new-info)
+                        '(λ (item control) (handler:edit-file #f) #t)
+                        #\n 
+                        '(string-constant new-menu-item)
+                        on-demand-do-nothing
+                        #t)
+          (make-between 'file-menu 'new 'open 'nothing)
+          (make-an-item 'file-menu 'open '(string-constant open-info)
+                        '(λ (item control) (handler:open-file) #t)
+                        #\o 
+                        '(string-constant open-menu-item)
+                        on-demand-do-nothing
+                        #t)
+          (make-a-submenu-item 'file-menu 'open-recent 
+                               '(string-constant open-recent-info)
+                               '(λ (x y) (void))
+                               #f
+                               '(string-constant open-recent-menu-item)
+                               '(λ (menu)
+                                  (handler:install-recent-items menu))
+                               #t)
+          (make-between 'file-menu 'open 'revert 'nothing)
+          (make-an-item 'file-menu 'revert 
+                        '(string-constant revert-info)
+                        '(λ (item control) (void))
+                        #f 
+                        '(string-constant revert-menu-item)
+                        on-demand-do-nothing
+                        #f)
+          (make-between 'file-menu 'revert 'save 'nothing)
+          (make-an-item 'file-menu 'save
+                        '(string-constant save-info)
+                        '(λ (item control) (void))
+                        #\s 
+                        '(string-constant save-menu-item)
+                        on-demand-do-nothing
+                        #f)
+          (make-an-item 'file-menu 'save-as
+                        '(string-constant save-as-info)
+                        '(λ (item control) (void))
+                        #f 
+                        '(string-constant save-as-menu-item)
+                        on-demand-do-nothing
+                        #f)
+          (make-between 'file-menu 'save-as 'print 'nothing)
+          (make-an-item 'file-menu 'print
+                        '(string-constant print-info)
+                        '(λ (item control) (void))
+                        #\p 
+                        '(string-constant print-menu-item)
+                        on-demand-do-nothing
+                        #f)
+          (make-between 'file-menu 'print 'close 'separator)
+          (make-an-item 'file-menu 'close
+                        '(string-constant close-info)
+                        '(λ (item control) (when (can-close?) (on-close) (show #f)) #t)
+                        #\w
+                        '(string-constant close-menu-item)
+                        on-demand-do-nothing
+                        #t)
+          (make-between 'file-menu 'close 'quit 'nothing)
+          (make-an-item 'file-menu 'quit
+                        '(string-constant quit-info)
+                        '(λ (item control) 
+                           (when (exit:user-oks-exit)
+                             (exit:exit)))
+                        #\q
+                        '(if (eq? (system-type) 'windows) 
+                             (string-constant quit-menu-item-windows)
+                             (string-constant quit-menu-item-others))
+                        on-demand-do-nothing
+                        '(not (current-eventspace-has-standard-menus?)))
+          (make-after 'file-menu 'quit 'nothing)
+          
+          (make-an-item 'edit-menu 'undo 
+                        '(string-constant undo-info)
+                        (edit-menu:do  'undo)
+                        #\z 
+                        '(string-constant undo-menu-item)
+                        (edit-menu:can-do-on-demand 'undo)
+                        #t)
+          (make-an-item 'edit-menu 'redo 
+                        '(string-constant redo-info)
+                        (edit-menu:do 'redo)
+                        #\y 
+                        '(string-constant redo-menu-item)
+                        (edit-menu:can-do-on-demand 'redo)
+                        #t)
+          (make-between 'edit-menu 'redo 'cut 'separator)
+          (make-an-item 'edit-menu 'cut '(string-constant cut-info)
+                        (edit-menu:do 'cut)
+                        #\x 
+                        '(string-constant cut-menu-item)
+                        (edit-menu:can-do-on-demand 'cut)
+                        #t)
+          (make-between 'edit-menu 'cut 'copy 'nothing)
+          (make-an-item 'edit-menu 'copy 
+                        '(string-constant copy-info)
+                        (edit-menu:do 'copy)
+                        #\c 
+                        '(string-constant copy-menu-item)
+                        (edit-menu:can-do-on-demand 'copy)
+                        #t)
+          (make-between 'edit-menu 'copy 'paste 'nothing)
+          (make-an-item 'edit-menu 'paste 
+                        '(string-constant paste-info)
+                        (edit-menu:do 'paste)
+                        #\v 
+                        '(string-constant paste-menu-item)
+                        (edit-menu:can-do-on-demand 'paste)
+                        #t)
+          (make-between 'edit-menu 'paste 'clear 'nothing)
+          (make-an-item 'edit-menu 'clear 
+                        '(string-constant clear-info)
+                        (edit-menu:do 'clear)
+                        #f
+                        '(if (eq? (system-type) 'windows)
+                             (string-constant clear-menu-item-windows)
+                             (string-constant clear-menu-item-windows))
+                        (edit-menu:can-do-on-demand 'clear)
+                        #t)
+          (make-between 'edit-menu 'clear 'select-all 'nothing)
+          (make-an-item 'edit-menu 'select-all
+                        '(string-constant select-all-info)
+                        (edit-menu:do 'select-all)
+                        #\a 
+                        '(string-constant select-all-menu-item)
+                        (edit-menu:can-do-on-demand 'select-all)
+                        #t)
+          (make-between 'edit-menu 'select-all 'find 'separator)
+
+          (make-an-item 'edit-menu 'find  
+                        '(string-constant find-info)
+                        '(λ (item control) (void))
+                        #\f 
+                        '(string-constant find-menu-item)
+                        edit-menu:edit-target-on-demand
+                        #f)
+          (make-an-item 'edit-menu 'find-again 
+                        '(string-constant find-again-info)
+                        '(λ (item control) (void))
+                        #\g 
+                        '(string-constant find-again-menu-item)
+                        edit-menu:edit-target-on-demand
+                        #f)
+          (make-an-item 'edit-menu 'replace-and-find-again 
+                        '(string-constant replace-and-find-again-info)
+                        '(λ (item control) (void))
+                        '(if (eq? (system-type) 'macosx) #f #\h)
+                        '(string-constant replace-and-find-again-menu-item)
+                        edit-menu:edit-target-on-demand
+                        #f)
+          
+          (make-between 'edit-menu 'find 'preferences 'nothing-with-standard-menus)
+          (make-an-item 'edit-menu 'preferences 
+                        '(string-constant preferences-info)
+                        '(λ (item control) (preferences:show-dialog) #t)
+                        #\; 
+                        '(string-constant preferences-menu-item)
+                        on-demand-do-nothing
+                        '(not (current-eventspace-has-standard-menus?)))
+          (make-after 'edit-menu 'preferences 'nothing)
+          
+          (make-before 'help-menu 'about 'nothing)
+          (make-an-item 'help-menu 'about 
+                        '(string-constant about-info)
+                        '(λ (item control) (void))
+                        #f
+                        '(string-constant about-menu-item)
+                        on-demand-do-nothing
+                        #f)
+          (make-after 'help-menu 'about 'nothing))))
diff --git a/collects/framework/private/standard-menus.ss b/collects/framework/private/standard-menus.ss
new file mode 100644
index 0000000000..547237a196
--- /dev/null
+++ b/collects/framework/private/standard-menus.ss
@@ -0,0 +1,826 @@
+(define standard-menus<%>
+  (interface
+    (basic<%>)
+    get-menu%
+    get-menu-item%
+    get-checkable-menu-item%
+    get-file-menu
+    get-edit-menu
+    get-help-menu
+    file-menu:new-callback
+    file-menu:get-new-item
+    file-menu:new-string
+    file-menu:new-help-string
+    file-menu:new-on-demand
+    file-menu:create-new?
+    file-menu:between-new-and-open
+    file-menu:open-callback
+    file-menu:get-open-item
+    file-menu:open-string
+    file-menu:open-help-string
+    file-menu:open-on-demand
+    file-menu:create-open?
+    file-menu:open-recent-callback
+    file-menu:get-open-recent-item
+    file-menu:open-recent-string
+    file-menu:open-recent-help-string
+    file-menu:open-recent-on-demand
+    file-menu:create-open-recent?
+    file-menu:between-open-and-revert
+    file-menu:revert-callback
+    file-menu:get-revert-item
+    file-menu:revert-string
+    file-menu:revert-help-string
+    file-menu:revert-on-demand
+    file-menu:create-revert?
+    file-menu:between-revert-and-save
+    file-menu:save-callback
+    file-menu:get-save-item
+    file-menu:save-string
+    file-menu:save-help-string
+    file-menu:save-on-demand
+    file-menu:create-save?
+    file-menu:save-as-callback
+    file-menu:get-save-as-item
+    file-menu:save-as-string
+    file-menu:save-as-help-string
+    file-menu:save-as-on-demand
+    file-menu:create-save-as?
+    file-menu:between-save-as-and-print
+    file-menu:print-callback
+    file-menu:get-print-item
+    file-menu:print-string
+    file-menu:print-help-string
+    file-menu:print-on-demand
+    file-menu:create-print?
+    file-menu:between-print-and-close
+    file-menu:close-callback
+    file-menu:get-close-item
+    file-menu:close-string
+    file-menu:close-help-string
+    file-menu:close-on-demand
+    file-menu:create-close?
+    file-menu:between-close-and-quit
+    file-menu:quit-callback
+    file-menu:get-quit-item
+    file-menu:quit-string
+    file-menu:quit-help-string
+    file-menu:quit-on-demand
+    file-menu:create-quit?
+    file-menu:after-quit
+    edit-menu:undo-callback
+    edit-menu:get-undo-item
+    edit-menu:undo-string
+    edit-menu:undo-help-string
+    edit-menu:undo-on-demand
+    edit-menu:create-undo?
+    edit-menu:redo-callback
+    edit-menu:get-redo-item
+    edit-menu:redo-string
+    edit-menu:redo-help-string
+    edit-menu:redo-on-demand
+    edit-menu:create-redo?
+    edit-menu:between-redo-and-cut
+    edit-menu:cut-callback
+    edit-menu:get-cut-item
+    edit-menu:cut-string
+    edit-menu:cut-help-string
+    edit-menu:cut-on-demand
+    edit-menu:create-cut?
+    edit-menu:between-cut-and-copy
+    edit-menu:copy-callback
+    edit-menu:get-copy-item
+    edit-menu:copy-string
+    edit-menu:copy-help-string
+    edit-menu:copy-on-demand
+    edit-menu:create-copy?
+    edit-menu:between-copy-and-paste
+    edit-menu:paste-callback
+    edit-menu:get-paste-item
+    edit-menu:paste-string
+    edit-menu:paste-help-string
+    edit-menu:paste-on-demand
+    edit-menu:create-paste?
+    edit-menu:between-paste-and-clear
+    edit-menu:clear-callback
+    edit-menu:get-clear-item
+    edit-menu:clear-string
+    edit-menu:clear-help-string
+    edit-menu:clear-on-demand
+    edit-menu:create-clear?
+    edit-menu:between-clear-and-select-all
+    edit-menu:select-all-callback
+    edit-menu:get-select-all-item
+    edit-menu:select-all-string
+    edit-menu:select-all-help-string
+    edit-menu:select-all-on-demand
+    edit-menu:create-select-all?
+    edit-menu:between-select-all-and-find
+    edit-menu:find-callback
+    edit-menu:get-find-item
+    edit-menu:find-string
+    edit-menu:find-help-string
+    edit-menu:find-on-demand
+    edit-menu:create-find?
+    edit-menu:find-again-callback
+    edit-menu:get-find-again-item
+    edit-menu:find-again-string
+    edit-menu:find-again-help-string
+    edit-menu:find-again-on-demand
+    edit-menu:create-find-again?
+    edit-menu:replace-and-find-again-callback
+    edit-menu:get-replace-and-find-again-item
+    edit-menu:replace-and-find-again-string
+    edit-menu:replace-and-find-again-help-string
+    edit-menu:replace-and-find-again-on-demand
+    edit-menu:create-replace-and-find-again?
+    edit-menu:between-find-and-preferences
+    edit-menu:preferences-callback
+    edit-menu:get-preferences-item
+    edit-menu:preferences-string
+    edit-menu:preferences-help-string
+    edit-menu:preferences-on-demand
+    edit-menu:create-preferences?
+    edit-menu:after-preferences
+    help-menu:before-about
+    help-menu:about-callback
+    help-menu:get-about-item
+    help-menu:about-string
+    help-menu:about-help-string
+    help-menu:about-on-demand
+    help-menu:create-about?
+    help-menu:after-about))
+
+(define standard-menus-mixin
+  (mixin
+   (basic<%>)
+   (standard-menus<%>)
+   (inherit on-menu-char on-traverse-char)
+   (define remove-prefs-callback
+     (preferences:add-callback
+       'framework:menu-bindings
+       (λ
+        (p v)
+        (let loop ((menu (get-menu-bar)))
+          (when (is-a? menu menu:can-restore<%>)
+            (if v (send menu restore-keybinding) (send menu set-shortcut #f)))
+          (when (is-a? menu menu:can-restore-underscore<%>)
+            (if v
+              (send menu restore-underscores)
+              (send menu erase-underscores)))
+          (when (is-a? menu menu-item-container<%>)
+            (for-each loop (send menu get-items)))))))
+   (inherit get-menu-bar show can-close? get-edit-target-object)
+   (define/augment
+     on-close
+     (lambda () (remove-prefs-callback) (inner (void) on-close)))
+   (define/public get-menu% (λ () menu:can-restore-underscore-menu%))
+   (define/public get-menu-item% (λ () menu:can-restore-menu-item%))
+   (define/public
+     get-checkable-menu-item%
+     (λ () menu:can-restore-checkable-menu-item%))
+   (define/public get-file-menu (λ () file-menu))
+   (define/public get-edit-menu (λ () edit-menu))
+   (define/public get-help-menu (λ () help-menu))
+   (define/public
+     file-menu:new-callback
+     (λ (item control) (handler:edit-file #f) #t))
+   (define/public (file-menu:get-new-item) file-menu:new-item)
+   (define/public (file-menu:new-string) (string-constant new-menu-item))
+   (define/public (file-menu:new-help-string) (string-constant new-info))
+   (define/public file-menu:new-on-demand (λ (menu-item) (void)))
+   (define/public (file-menu:create-new?) #t)
+   (define/public file-menu:between-new-and-open (λ (menu) (void)))
+   (define/public
+     file-menu:open-callback
+     (λ (item control) (handler:open-file) #t))
+   (define/public (file-menu:get-open-item) file-menu:open-item)
+   (define/public (file-menu:open-string) (string-constant open-menu-item))
+   (define/public (file-menu:open-help-string) (string-constant open-info))
+   (define/public file-menu:open-on-demand (λ (menu-item) (void)))
+   (define/public (file-menu:create-open?) #t)
+   (define/public file-menu:open-recent-callback (λ (x y) (void)))
+   (define/public (file-menu:get-open-recent-item) file-menu:open-recent-item)
+   (define/public
+     (file-menu:open-recent-string)
+     (string-constant open-recent-menu-item))
+   (define/public
+     (file-menu:open-recent-help-string)
+     (string-constant open-recent-info))
+   (define/public
+     file-menu:open-recent-on-demand
+     (λ (menu) (handler:install-recent-items menu)))
+   (define/public (file-menu:create-open-recent?) #t)
+   (define/public file-menu:between-open-and-revert (λ (menu) (void)))
+   (define/public file-menu:revert-callback (λ (item control) (void)))
+   (define/public (file-menu:get-revert-item) file-menu:revert-item)
+   (define/public (file-menu:revert-string) (string-constant revert-menu-item))
+   (define/public (file-menu:revert-help-string) (string-constant revert-info))
+   (define/public file-menu:revert-on-demand (λ (menu-item) (void)))
+   (define/public (file-menu:create-revert?) #f)
+   (define/public file-menu:between-revert-and-save (λ (menu) (void)))
+   (define/public file-menu:save-callback (λ (item control) (void)))
+   (define/public (file-menu:get-save-item) file-menu:save-item)
+   (define/public (file-menu:save-string) (string-constant save-menu-item))
+   (define/public (file-menu:save-help-string) (string-constant save-info))
+   (define/public file-menu:save-on-demand (λ (menu-item) (void)))
+   (define/public (file-menu:create-save?) #f)
+   (define/public file-menu:save-as-callback (λ (item control) (void)))
+   (define/public (file-menu:get-save-as-item) file-menu:save-as-item)
+   (define/public
+     (file-menu:save-as-string)
+     (string-constant save-as-menu-item))
+   (define/public
+     (file-menu:save-as-help-string)
+     (string-constant save-as-info))
+   (define/public file-menu:save-as-on-demand (λ (menu-item) (void)))
+   (define/public (file-menu:create-save-as?) #f)
+   (define/public file-menu:between-save-as-and-print (λ (menu) (void)))
+   (define/public file-menu:print-callback (λ (item control) (void)))
+   (define/public (file-menu:get-print-item) file-menu:print-item)
+   (define/public (file-menu:print-string) (string-constant print-menu-item))
+   (define/public (file-menu:print-help-string) (string-constant print-info))
+   (define/public file-menu:print-on-demand (λ (menu-item) (void)))
+   (define/public (file-menu:create-print?) #f)
+   (define/public
+     file-menu:between-print-and-close
+     (λ (menu) (make-object separator-menu-item% menu)))
+   (define/public
+     file-menu:close-callback
+     (λ (item control) (when (can-close?) (on-close) (show #f)) #t))
+   (define/public (file-menu:get-close-item) file-menu:close-item)
+   (define/public (file-menu:close-string) (string-constant close-menu-item))
+   (define/public (file-menu:close-help-string) (string-constant close-info))
+   (define/public file-menu:close-on-demand (λ (menu-item) (void)))
+   (define/public (file-menu:create-close?) #t)
+   (define/public file-menu:between-close-and-quit (λ (menu) (void)))
+   (define/public
+     file-menu:quit-callback
+     (λ (item control) (when (exit:user-oks-exit) (exit:exit))))
+   (define/public (file-menu:get-quit-item) file-menu:quit-item)
+   (define/public
+     (file-menu:quit-string)
+     (if (eq? (system-type) 'windows)
+       (string-constant quit-menu-item-windows)
+       (string-constant quit-menu-item-others)))
+   (define/public (file-menu:quit-help-string) (string-constant quit-info))
+   (define/public file-menu:quit-on-demand (λ (menu-item) (void)))
+   (define/public
+     (file-menu:create-quit?)
+     (not (current-eventspace-has-standard-menus?)))
+   (define/public file-menu:after-quit (λ (menu) (void)))
+   (define/public
+     edit-menu:undo-callback
+     (λ
+      (menu evt)
+      (let ((edit (get-edit-target-object)))
+        (when (and edit (is-a? edit editor<%>))
+          (send edit do-edit-operation 'undo)))
+      #t))
+   (define/public (edit-menu:get-undo-item) edit-menu:undo-item)
+   (define/public (edit-menu:undo-string) (string-constant undo-menu-item))
+   (define/public (edit-menu:undo-help-string) (string-constant undo-info))
+   (define/public
+     edit-menu:undo-on-demand
+     (λ
+      (item)
+      (let* ((editor (get-edit-target-object))
+             (enable?
+               (and editor
+                    (is-a? editor editor<%>)
+                    (send editor can-do-edit-operation? 'undo))))
+        (send item enable enable?))))
+   (define/public (edit-menu:create-undo?) #t)
+   (define/public
+     edit-menu:redo-callback
+     (λ
+      (menu evt)
+      (let ((edit (get-edit-target-object)))
+        (when (and edit (is-a? edit editor<%>))
+          (send edit do-edit-operation 'redo)))
+      #t))
+   (define/public (edit-menu:get-redo-item) edit-menu:redo-item)
+   (define/public (edit-menu:redo-string) (string-constant redo-menu-item))
+   (define/public (edit-menu:redo-help-string) (string-constant redo-info))
+   (define/public
+     edit-menu:redo-on-demand
+     (λ
+      (item)
+      (let* ((editor (get-edit-target-object))
+             (enable?
+               (and editor
+                    (is-a? editor editor<%>)
+                    (send editor can-do-edit-operation? 'redo))))
+        (send item enable enable?))))
+   (define/public (edit-menu:create-redo?) #t)
+   (define/public
+     edit-menu:between-redo-and-cut
+     (λ (menu) (make-object separator-menu-item% menu)))
+   (define/public
+     edit-menu:cut-callback
+     (λ
+      (menu evt)
+      (let ((edit (get-edit-target-object)))
+        (when (and edit (is-a? edit editor<%>))
+          (send edit do-edit-operation 'cut)))
+      #t))
+   (define/public (edit-menu:get-cut-item) edit-menu:cut-item)
+   (define/public (edit-menu:cut-string) (string-constant cut-menu-item))
+   (define/public (edit-menu:cut-help-string) (string-constant cut-info))
+   (define/public
+     edit-menu:cut-on-demand
+     (λ
+      (item)
+      (let* ((editor (get-edit-target-object))
+             (enable?
+               (and editor
+                    (is-a? editor editor<%>)
+                    (send editor can-do-edit-operation? 'cut))))
+        (send item enable enable?))))
+   (define/public (edit-menu:create-cut?) #t)
+   (define/public edit-menu:between-cut-and-copy (λ (menu) (void)))
+   (define/public
+     edit-menu:copy-callback
+     (λ
+      (menu evt)
+      (let ((edit (get-edit-target-object)))
+        (when (and edit (is-a? edit editor<%>))
+          (send edit do-edit-operation 'copy)))
+      #t))
+   (define/public (edit-menu:get-copy-item) edit-menu:copy-item)
+   (define/public (edit-menu:copy-string) (string-constant copy-menu-item))
+   (define/public (edit-menu:copy-help-string) (string-constant copy-info))
+   (define/public
+     edit-menu:copy-on-demand
+     (λ
+      (item)
+      (let* ((editor (get-edit-target-object))
+             (enable?
+               (and editor
+                    (is-a? editor editor<%>)
+                    (send editor can-do-edit-operation? 'copy))))
+        (send item enable enable?))))
+   (define/public (edit-menu:create-copy?) #t)
+   (define/public edit-menu:between-copy-and-paste (λ (menu) (void)))
+   (define/public
+     edit-menu:paste-callback
+     (λ
+      (menu evt)
+      (let ((edit (get-edit-target-object)))
+        (when (and edit (is-a? edit editor<%>))
+          (send edit do-edit-operation 'paste)))
+      #t))
+   (define/public (edit-menu:get-paste-item) edit-menu:paste-item)
+   (define/public (edit-menu:paste-string) (string-constant paste-menu-item))
+   (define/public (edit-menu:paste-help-string) (string-constant paste-info))
+   (define/public
+     edit-menu:paste-on-demand
+     (λ
+      (item)
+      (let* ((editor (get-edit-target-object))
+             (enable?
+               (and editor
+                    (is-a? editor editor<%>)
+                    (send editor can-do-edit-operation? 'paste))))
+        (send item enable enable?))))
+   (define/public (edit-menu:create-paste?) #t)
+   (define/public edit-menu:between-paste-and-clear (λ (menu) (void)))
+   (define/public
+     edit-menu:clear-callback
+     (λ
+      (menu evt)
+      (let ((edit (get-edit-target-object)))
+        (when (and edit (is-a? edit editor<%>))
+          (send edit do-edit-operation 'clear)))
+      #t))
+   (define/public (edit-menu:get-clear-item) edit-menu:clear-item)
+   (define/public
+     (edit-menu:clear-string)
+     (if (eq? (system-type) 'windows)
+       (string-constant clear-menu-item-windows)
+       (string-constant clear-menu-item-windows)))
+   (define/public (edit-menu:clear-help-string) (string-constant clear-info))
+   (define/public
+     edit-menu:clear-on-demand
+     (λ
+      (item)
+      (let* ((editor (get-edit-target-object))
+             (enable?
+               (and editor
+                    (is-a? editor editor<%>)
+                    (send editor can-do-edit-operation? 'clear))))
+        (send item enable enable?))))
+   (define/public (edit-menu:create-clear?) #t)
+   (define/public edit-menu:between-clear-and-select-all (λ (menu) (void)))
+   (define/public
+     edit-menu:select-all-callback
+     (λ
+      (menu evt)
+      (let ((edit (get-edit-target-object)))
+        (when (and edit (is-a? edit editor<%>))
+          (send edit do-edit-operation 'select-all)))
+      #t))
+   (define/public (edit-menu:get-select-all-item) edit-menu:select-all-item)
+   (define/public
+     (edit-menu:select-all-string)
+     (string-constant select-all-menu-item))
+   (define/public
+     (edit-menu:select-all-help-string)
+     (string-constant select-all-info))
+   (define/public
+     edit-menu:select-all-on-demand
+     (λ
+      (item)
+      (let* ((editor (get-edit-target-object))
+             (enable?
+               (and editor
+                    (is-a? editor editor<%>)
+                    (send editor can-do-edit-operation? 'select-all))))
+        (send item enable enable?))))
+   (define/public (edit-menu:create-select-all?) #t)
+   (define/public
+     edit-menu:between-select-all-and-find
+     (λ (menu) (make-object separator-menu-item% menu)))
+   (define/public edit-menu:find-callback (λ (item control) (void)))
+   (define/public (edit-menu:get-find-item) edit-menu:find-item)
+   (define/public (edit-menu:find-string) (string-constant find-menu-item))
+   (define/public (edit-menu:find-help-string) (string-constant find-info))
+   (define/public
+     edit-menu:find-on-demand
+     (λ
+      (item)
+      (send item enable
+        (let
+         ((target (get-edit-target-object)))
+         (and target (is-a? target editor<%>))))))
+   (define/public (edit-menu:create-find?) #f)
+   (define/public edit-menu:find-again-callback (λ (item control) (void)))
+   (define/public (edit-menu:get-find-again-item) edit-menu:find-again-item)
+   (define/public
+     (edit-menu:find-again-string)
+     (string-constant find-again-menu-item))
+   (define/public
+     (edit-menu:find-again-help-string)
+     (string-constant find-again-info))
+   (define/public
+     edit-menu:find-again-on-demand
+     (λ
+      (item)
+      (send item enable
+        (let
+         ((target (get-edit-target-object)))
+         (and target (is-a? target editor<%>))))))
+   (define/public (edit-menu:create-find-again?) #f)
+   (define/public
+     edit-menu:replace-and-find-again-callback
+     (λ (item control) (void)))
+   (define/public
+     (edit-menu:get-replace-and-find-again-item)
+     edit-menu:replace-and-find-again-item)
+   (define/public
+     (edit-menu:replace-and-find-again-string)
+     (string-constant replace-and-find-again-menu-item))
+   (define/public
+     (edit-menu:replace-and-find-again-help-string)
+     (string-constant replace-and-find-again-info))
+   (define/public
+     edit-menu:replace-and-find-again-on-demand
+     (λ
+      (item)
+      (send item enable
+        (let
+         ((target (get-edit-target-object)))
+         (and target (is-a? target editor<%>))))))
+   (define/public (edit-menu:create-replace-and-find-again?) #f)
+   (define/public
+     edit-menu:between-find-and-preferences
+     (λ
+      (menu)
+      (unless (current-eventspace-has-standard-menus?)
+        (make-object separator-menu-item% menu))))
+   (define/public
+     edit-menu:preferences-callback
+     (λ (item control) (preferences:show-dialog) #t))
+   (define/public (edit-menu:get-preferences-item) edit-menu:preferences-item)
+   (define/public
+     (edit-menu:preferences-string)
+     (string-constant preferences-menu-item))
+   (define/public
+     (edit-menu:preferences-help-string)
+     (string-constant preferences-info))
+   (define/public edit-menu:preferences-on-demand (λ (menu-item) (void)))
+   (define/public
+     (edit-menu:create-preferences?)
+     (not (current-eventspace-has-standard-menus?)))
+   (define/public edit-menu:after-preferences (λ (menu) (void)))
+   (define/public help-menu:before-about (λ (menu) (void)))
+   (define/public help-menu:about-callback (λ (item control) (void)))
+   (define/public (help-menu:get-about-item) help-menu:about-item)
+   (define/public (help-menu:about-string) (string-constant about-menu-item))
+   (define/public (help-menu:about-help-string) (string-constant about-info))
+   (define/public help-menu:about-on-demand (λ (menu-item) (void)))
+   (define/public (help-menu:create-about?) #f)
+   (define/public help-menu:after-about (λ (menu) (void)))
+   (super-instantiate ())
+   (define file-menu
+     (make-object (get-menu%)
+       (string-constant file-menu-label)
+       (get-menu-bar)))
+   (define edit-menu
+     (make-object (get-menu%)
+       (string-constant edit-menu-label)
+       (get-menu-bar)))
+   (define help-menu
+     (make-object (get-menu%)
+       (string-constant help-menu-label)
+       (get-menu-bar)))
+   (define file-menu:new-item
+     (and (file-menu:create-new?)
+          (instantiate (get-menu-item%) ()
+            (label (file-menu:new-string))
+            (parent file-menu)
+            (callback
+             (let ((file-menu:new-callback
+                     (λ (item evt) (file-menu:new-callback item evt))))
+               file-menu:new-callback))
+            (shortcut #\n)
+            (help-string (file-menu:new-help-string))
+            (demand-callback
+             (λ (menu-item) (file-menu:new-on-demand menu-item))))))
+   (file-menu:between-new-and-open (get-file-menu))
+   (define file-menu:open-item
+     (and (file-menu:create-open?)
+          (instantiate (get-menu-item%) ()
+            (label (file-menu:open-string))
+            (parent file-menu)
+            (callback
+             (let ((file-menu:open-callback
+                     (λ (item evt) (file-menu:open-callback item evt))))
+               file-menu:open-callback))
+            (shortcut #\o)
+            (help-string (file-menu:open-help-string))
+            (demand-callback
+             (λ (menu-item) (file-menu:open-on-demand menu-item))))))
+   (define file-menu:open-recent-item
+     (and (file-menu:create-open-recent?)
+          (instantiate (get-menu%) ()
+            (label (file-menu:open-recent-string))
+            (parent file-menu)
+            (help-string (file-menu:open-recent-help-string))
+            (demand-callback
+             (λ (menu-item) (file-menu:open-recent-on-demand menu-item))))))
+   (file-menu:between-open-and-revert (get-file-menu))
+   (define file-menu:revert-item
+     (and (file-menu:create-revert?)
+          (instantiate (get-menu-item%) ()
+            (label (file-menu:revert-string))
+            (parent file-menu)
+            (callback
+             (let ((file-menu:revert-callback
+                     (λ (item evt) (file-menu:revert-callback item evt))))
+               file-menu:revert-callback))
+            (shortcut #f)
+            (help-string (file-menu:revert-help-string))
+            (demand-callback
+             (λ (menu-item) (file-menu:revert-on-demand menu-item))))))
+   (file-menu:between-revert-and-save (get-file-menu))
+   (define file-menu:save-item
+     (and (file-menu:create-save?)
+          (instantiate (get-menu-item%) ()
+            (label (file-menu:save-string))
+            (parent file-menu)
+            (callback
+             (let ((file-menu:save-callback
+                     (λ (item evt) (file-menu:save-callback item evt))))
+               file-menu:save-callback))
+            (shortcut #\s)
+            (help-string (file-menu:save-help-string))
+            (demand-callback
+             (λ (menu-item) (file-menu:save-on-demand menu-item))))))
+   (define file-menu:save-as-item
+     (and (file-menu:create-save-as?)
+          (instantiate (get-menu-item%) ()
+            (label (file-menu:save-as-string))
+            (parent file-menu)
+            (callback
+             (let ((file-menu:save-as-callback
+                     (λ (item evt) (file-menu:save-as-callback item evt))))
+               file-menu:save-as-callback))
+            (shortcut #f)
+            (help-string (file-menu:save-as-help-string))
+            (demand-callback
+             (λ (menu-item) (file-menu:save-as-on-demand menu-item))))))
+   (file-menu:between-save-as-and-print (get-file-menu))
+   (define file-menu:print-item
+     (and (file-menu:create-print?)
+          (instantiate (get-menu-item%) ()
+            (label (file-menu:print-string))
+            (parent file-menu)
+            (callback
+             (let ((file-menu:print-callback
+                     (λ (item evt) (file-menu:print-callback item evt))))
+               file-menu:print-callback))
+            (shortcut #\p)
+            (help-string (file-menu:print-help-string))
+            (demand-callback
+             (λ (menu-item) (file-menu:print-on-demand menu-item))))))
+   (file-menu:between-print-and-close (get-file-menu))
+   (define file-menu:close-item
+     (and (file-menu:create-close?)
+          (instantiate (get-menu-item%) ()
+            (label (file-menu:close-string))
+            (parent file-menu)
+            (callback
+             (let ((file-menu:close-callback
+                     (λ (item evt) (file-menu:close-callback item evt))))
+               file-menu:close-callback))
+            (shortcut #\w)
+            (help-string (file-menu:close-help-string))
+            (demand-callback
+             (λ (menu-item) (file-menu:close-on-demand menu-item))))))
+   (file-menu:between-close-and-quit (get-file-menu))
+   (define file-menu:quit-item
+     (and (file-menu:create-quit?)
+          (instantiate (get-menu-item%) ()
+            (label (file-menu:quit-string))
+            (parent file-menu)
+            (callback
+             (let ((file-menu:quit-callback
+                     (λ (item evt) (file-menu:quit-callback item evt))))
+               file-menu:quit-callback))
+            (shortcut #\q)
+            (help-string (file-menu:quit-help-string))
+            (demand-callback
+             (λ (menu-item) (file-menu:quit-on-demand menu-item))))))
+   (file-menu:after-quit (get-file-menu))
+   (define edit-menu:undo-item
+     (and (edit-menu:create-undo?)
+          (instantiate (get-menu-item%) ()
+            (label (edit-menu:undo-string))
+            (parent edit-menu)
+            (callback
+             (let ((edit-menu:undo-callback
+                     (λ (item evt) (edit-menu:undo-callback item evt))))
+               edit-menu:undo-callback))
+            (shortcut #\z)
+            (help-string (edit-menu:undo-help-string))
+            (demand-callback
+             (λ (menu-item) (edit-menu:undo-on-demand menu-item))))))
+   (define edit-menu:redo-item
+     (and (edit-menu:create-redo?)
+          (instantiate (get-menu-item%) ()
+            (label (edit-menu:redo-string))
+            (parent edit-menu)
+            (callback
+             (let ((edit-menu:redo-callback
+                     (λ (item evt) (edit-menu:redo-callback item evt))))
+               edit-menu:redo-callback))
+            (shortcut #\y)
+            (help-string (edit-menu:redo-help-string))
+            (demand-callback
+             (λ (menu-item) (edit-menu:redo-on-demand menu-item))))))
+   (edit-menu:between-redo-and-cut (get-edit-menu))
+   (define edit-menu:cut-item
+     (and (edit-menu:create-cut?)
+          (instantiate (get-menu-item%) ()
+            (label (edit-menu:cut-string))
+            (parent edit-menu)
+            (callback
+             (let ((edit-menu:cut-callback
+                     (λ (item evt) (edit-menu:cut-callback item evt))))
+               edit-menu:cut-callback))
+            (shortcut #\x)
+            (help-string (edit-menu:cut-help-string))
+            (demand-callback
+             (λ (menu-item) (edit-menu:cut-on-demand menu-item))))))
+   (edit-menu:between-cut-and-copy (get-edit-menu))
+   (define edit-menu:copy-item
+     (and (edit-menu:create-copy?)
+          (instantiate (get-menu-item%) ()
+            (label (edit-menu:copy-string))
+            (parent edit-menu)
+            (callback
+             (let ((edit-menu:copy-callback
+                     (λ (item evt) (edit-menu:copy-callback item evt))))
+               edit-menu:copy-callback))
+            (shortcut #\c)
+            (help-string (edit-menu:copy-help-string))
+            (demand-callback
+             (λ (menu-item) (edit-menu:copy-on-demand menu-item))))))
+   (edit-menu:between-copy-and-paste (get-edit-menu))
+   (define edit-menu:paste-item
+     (and (edit-menu:create-paste?)
+          (instantiate (get-menu-item%) ()
+            (label (edit-menu:paste-string))
+            (parent edit-menu)
+            (callback
+             (let ((edit-menu:paste-callback
+                     (λ (item evt) (edit-menu:paste-callback item evt))))
+               edit-menu:paste-callback))
+            (shortcut #\v)
+            (help-string (edit-menu:paste-help-string))
+            (demand-callback
+             (λ (menu-item) (edit-menu:paste-on-demand menu-item))))))
+   (edit-menu:between-paste-and-clear (get-edit-menu))
+   (define edit-menu:clear-item
+     (and (edit-menu:create-clear?)
+          (instantiate (get-menu-item%) ()
+            (label (edit-menu:clear-string))
+            (parent edit-menu)
+            (callback
+             (let ((edit-menu:clear-callback
+                     (λ (item evt) (edit-menu:clear-callback item evt))))
+               edit-menu:clear-callback))
+            (shortcut #f)
+            (help-string (edit-menu:clear-help-string))
+            (demand-callback
+             (λ (menu-item) (edit-menu:clear-on-demand menu-item))))))
+   (edit-menu:between-clear-and-select-all (get-edit-menu))
+   (define edit-menu:select-all-item
+     (and (edit-menu:create-select-all?)
+          (instantiate (get-menu-item%) ()
+            (label (edit-menu:select-all-string))
+            (parent edit-menu)
+            (callback
+             (let ((edit-menu:select-all-callback
+                     (λ (item evt) (edit-menu:select-all-callback item evt))))
+               edit-menu:select-all-callback))
+            (shortcut #\a)
+            (help-string (edit-menu:select-all-help-string))
+            (demand-callback
+             (λ (menu-item) (edit-menu:select-all-on-demand menu-item))))))
+   (edit-menu:between-select-all-and-find (get-edit-menu))
+   (define edit-menu:find-item
+     (and (edit-menu:create-find?)
+          (instantiate (get-menu-item%) ()
+            (label (edit-menu:find-string))
+            (parent edit-menu)
+            (callback
+             (let ((edit-menu:find-callback
+                     (λ (item evt) (edit-menu:find-callback item evt))))
+               edit-menu:find-callback))
+            (shortcut #\f)
+            (help-string (edit-menu:find-help-string))
+            (demand-callback
+             (λ (menu-item) (edit-menu:find-on-demand menu-item))))))
+   (define edit-menu:find-again-item
+     (and (edit-menu:create-find-again?)
+          (instantiate (get-menu-item%) ()
+            (label (edit-menu:find-again-string))
+            (parent edit-menu)
+            (callback
+             (let ((edit-menu:find-again-callback
+                     (λ (item evt) (edit-menu:find-again-callback item evt))))
+               edit-menu:find-again-callback))
+            (shortcut #\g)
+            (help-string (edit-menu:find-again-help-string))
+            (demand-callback
+             (λ (menu-item) (edit-menu:find-again-on-demand menu-item))))))
+   (define edit-menu:replace-and-find-again-item
+     (and (edit-menu:create-replace-and-find-again?)
+          (instantiate (get-menu-item%) ()
+            (label (edit-menu:replace-and-find-again-string))
+            (parent edit-menu)
+            (callback
+             (let ((edit-menu:replace-and-find-again-callback
+                     (λ
+                      (item evt)
+                      (edit-menu:replace-and-find-again-callback item evt))))
+               edit-menu:replace-and-find-again-callback))
+            (shortcut (if (eq? (system-type) 'macosx) #f #\h))
+            (help-string (edit-menu:replace-and-find-again-help-string))
+            (demand-callback
+             (λ
+              (menu-item)
+              (edit-menu:replace-and-find-again-on-demand menu-item))))))
+   (edit-menu:between-find-and-preferences (get-edit-menu))
+   (define edit-menu:preferences-item
+     (and (edit-menu:create-preferences?)
+          (instantiate (get-menu-item%) ()
+            (label (edit-menu:preferences-string))
+            (parent edit-menu)
+            (callback
+             (let ((edit-menu:preferences-callback
+                     (λ (item evt) (edit-menu:preferences-callback item evt))))
+               edit-menu:preferences-callback))
+            (shortcut #\;)
+            (help-string (edit-menu:preferences-help-string))
+            (demand-callback
+             (λ (menu-item) (edit-menu:preferences-on-demand menu-item))))))
+   (edit-menu:after-preferences (get-edit-menu))
+   (help-menu:before-about (get-help-menu))
+   (define help-menu:about-item
+     (and (help-menu:create-about?)
+          (instantiate (get-menu-item%) ()
+            (label (help-menu:about-string))
+            (parent help-menu)
+            (callback
+             (let ((help-menu:about-callback
+                     (λ (item evt) (help-menu:about-callback item evt))))
+               help-menu:about-callback))
+            (shortcut #f)
+            (help-string (help-menu:about-help-string))
+            (demand-callback
+             (λ (menu-item) (help-menu:about-on-demand menu-item))))))
+   (help-menu:after-about (get-help-menu))
+   (reorder-menus this)))
diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss
new file mode 100644
index 0000000000..bd81969913
--- /dev/null
+++ b/collects/framework/private/text.ss
@@ -0,0 +1,1944 @@
+#|
+
+WARNING: printf is rebound in the body of the unit to always
+         print to the original output port.
+
+|#
+
+(module text mzscheme
+  (require (lib "string-constant.ss" "string-constants")
+           (lib "unitsig.ss")
+	   (lib "class.ss")
+           (lib "match.ss")
+	   "sig.ss"
+	   "../gui-utils.ss"
+	   (lib "mred-sig.ss" "mred")
+           (lib "interactive-value-port.ss" "mrlib")
+	   (lib "list.ss")
+	   (lib "etc.ss"))
+  (provide text@)
+
+  (define text@
+    (unit/sig framework:text^
+      (import mred^
+              [icon : framework:icon^]
+              [editor : framework:editor^]
+              [preferences : framework:preferences^]
+              [keymap : framework:keymap^]
+              [color-model : framework:color-model^]
+              [frame : framework:frame^]
+              [scheme : framework:scheme^]
+              [number-snip : framework:number-snip^])
+      
+      (rename [-keymap% keymap%])
+      
+      (define original-output-port (current-output-port))
+      (define (printf . args) 
+        (apply fprintf original-output-port args)
+        (void))
+      
+      (define-struct range (start end b/w-bitmap color caret-space?))
+      (define-struct rectangle (left top right bottom b/w-bitmap color))
+      
+      ;; wx: `default-wrapping?', add as the initial value for auto-wrap bitmap,
+      ;; unless matthew makes it primitive
+      
+      (define basic<%>
+        (interface (editor:basic<%> (class->interface text%))
+          highlight-range
+          get-highlighted-ranges
+          get-styles-fixed
+          get-fixed-style
+          set-styles-fixed
+          move/copy-to-edit
+          initial-autowrap-bitmap))
+      
+      (define basic-mixin
+        (mixin (editor:basic<%> (class->interface text%)) (basic<%>)
+          (inherit get-canvases get-admin split-snip get-snip-position
+                   begin-edit-sequence end-edit-sequence
+                   set-autowrap-bitmap
+                   delete find-snip invalidate-bitmap-cache
+                   set-file-format get-file-format
+                   get-style-list is-modified? change-style set-modified
+                   position-location get-extent)
+          
+          (define highlight-pen #f)
+          (define highlight-brush #f)
+
+          (define range-rectangles null)
+          (define ranges null)
+          
+          (define/public-final (get-highlighted-ranges) ranges)
+          (define/public (get-fixed-style)
+            (send (get-style-list) find-named-style "Standard"))
+          
+          (define/private (invalidate-rectangles rectangles)
+            (let ([b1 (box 0)]
+                  [b2 (box 0)]
+                  [b3 (box 0)]
+                  [b4 (box 0)]
+                  [canvases (get-canvases)])
+              (let-values ([(min-left max-right)
+                            (cond
+                              [(null? canvases)
+                               (let ([admin (get-admin)])
+                                 (if admin
+                                     (begin
+                                       (send admin get-view b1 b2 b3 b4)
+                                       (let* ([this-left (unbox b1)]
+                                              [this-width (unbox b3)]
+                                              [this-right (+ this-left this-width)])
+                                         (values this-left
+                                                 this-right)))
+                                     (values #f #f)))]
+                              [else 
+                               (let loop ([left #f]
+                                          [right #f]
+                                          [canvases canvases])
+                                 (cond
+                                   [(null? canvases)
+                                    (values left right)]
+                                   [else
+                                    (let-values ([(this-left this-right)
+                                                  (send (car canvases)
+                                                        call-as-primary-owner
+                                                        (λ ()
+                                                          (send (get-admin) get-view b1 b2 b3 b4)
+                                                          (let* ([this-left (unbox b1)]
+                                                                 [this-width (unbox b3)]
+                                                                 [this-right (+ this-left this-width)])
+                                                            (values this-left
+                                                                    this-right))))])
+                                      (if (and left right)
+                                          (loop (min this-left left)
+                                                (max this-right right)
+                                                (cdr canvases))
+                                          (loop this-left
+                                                this-right
+                                                (cdr canvases))))]))])])
+                (when (and min-left max-right)
+                  (let loop ([left #f]
+                             [top #f]
+                             [right #f]
+                             [bottom #f]
+                             [rectangles rectangles])
+                    (cond
+                      [(null? rectangles)
+                       (when left
+                         (let ([width (- right left)]
+                               [height (- bottom top)])
+                           (when (and (> width 0)
+                                      (> height 0))
+                             (invalidate-bitmap-cache left top width height))))]
+                      [else (let* ([r (car rectangles)]
+                                   
+                                   [rleft (rectangle-left r)]
+                                   [rright (rectangle-right r)]
+                                   [rtop (rectangle-top r)]
+                                   [rbottom (rectangle-bottom r)]
+                                   
+                                   [this-left (if (number? rleft)
+                                                  rleft
+                                                  min-left)]
+                                   [this-right (if (number? rright)
+                                                   rright
+                                                   max-right)]
+                                   [this-bottom rbottom]
+                                   [this-top rtop])
+                              (if (and left top right bottom)
+                                  (loop (min this-left left)
+                                        (min this-top top)
+                                        (max this-right right)
+                                        (max this-bottom bottom)
+                                        (cdr rectangles))
+                                  (loop this-left 
+                                        this-top
+                                        this-right
+                                        this-bottom
+                                        (cdr rectangles))))]))))))
+          
+          (define/private (recompute-range-rectangles)
+            (let* ([b1 (box 0)]
+                   [b2 (box 0)]
+                   [new-rectangles
+                    (λ (range)
+                      (let* ([start (range-start range)]
+                             [end (range-end range)]
+                             [b/w-bitmap (range-b/w-bitmap range)]
+                             [color (range-color range)]
+                             [caret-space? (range-caret-space? range)]
+                             [start-eol? #f]
+                             [end-eol? (if (= start end)
+                                           start-eol?
+                                           #t)])
+                        (let-values ([(start-x top-start-y)
+                                      (begin 
+                                        (position-location start b1 b2 #t start-eol? #t)
+                                        (values (if caret-space?
+                                                    (+ 1 (unbox b1))
+                                                    (unbox b1))
+                                                (unbox b2)))]
+                                     [(end-x top-end-y)
+                                      (begin (position-location end b1 b2 #t end-eol? #t)
+                                             (values (unbox b1) (unbox b2)))]
+                                     [(bottom-start-y)
+                                      (begin (position-location start b1 b2 #f start-eol? #t)
+                                             (unbox b2))]
+                                     [(bottom-end-y)
+                                      (begin (position-location end b1 b2 #f end-eol? #t)
+                                             (unbox b2))])
+                          (cond
+                            [(= top-start-y top-end-y)
+                             (list 
+                              (make-rectangle start-x
+                                              top-start-y
+                                              (if (= end-x start-x)
+                                                  (+ end-x 1)
+                                                  end-x)
+                                              bottom-start-y
+                                              b/w-bitmap 
+                                              color))]
+                            [else
+                             (list
+                              (make-rectangle start-x
+                                              top-start-y
+                                              'right-edge
+                                              bottom-start-y
+                                              b/w-bitmap
+                                              color)
+                              (make-rectangle 'left-edge
+                                              bottom-start-y
+                                              'max-width
+                                              top-end-y
+                                              b/w-bitmap
+                                              color)
+                              (make-rectangle 'left-edge
+                                              top-end-y
+                                              end-x
+                                              bottom-end-y
+                                              b/w-bitmap
+                                              color))]))))]
+                   [old-rectangles range-rectangles])
+              
+              (set! range-rectangles 
+                    (foldl (λ (x l) (append (new-rectangles x) l))
+                           null ranges))))
+          
+          (define/public highlight-range
+            (opt-lambda (start end color [bitmap #f] [caret-space? #f] [priority 'low])
+              (unless (let ([exact-pos-int?
+                             (λ (x) (and (integer? x) (exact? x) (x . >= . 0)))])
+                        (and (exact-pos-int? start)
+                             (exact-pos-int? end)))
+                (error 'highlight-range "expected first two arguments to be non-negative exact integers, got: ~e ~e"
+                       start end))
+              (unless (or (eq? priority 'high) (eq? priority 'low))
+                (error 'highlight-range "expected last argument to be either 'high or 'low, got: ~e"
+                       priority))
+              (let ([l (make-range start end bitmap color caret-space?)])
+                (invalidate-rectangles range-rectangles)
+                (set! ranges (if (eq? priority 'high) (cons l ranges) (append ranges (list l))))
+                (recompute-range-rectangles)
+                (invalidate-rectangles range-rectangles)
+                (λ ()
+                  (let ([old-rectangles range-rectangles])
+                    (set! ranges
+                          (let loop ([r ranges])
+                            (cond
+                              [(null? r) r]
+                              [else (if (eq? (car r) l)
+                                        (cdr r)
+                                        (cons (car r) (loop (cdr r))))])))
+                    (recompute-range-rectangles)                    
+                    (invalidate-rectangles old-rectangles))))))
+          (define/override (on-paint before dc left-margin top-margin right-margin bottom-margin dx dy draw-caret)
+            (super on-paint before dc left-margin top-margin right-margin bottom-margin dx dy draw-caret)
+            (recompute-range-rectangles)
+            (let ([b1 (box 0)]
+                  [b2 (box 0)]
+                  [b3 (box 0)]
+                  [b4 (box 0)])
+              (for-each
+               (λ (rectangle)
+                 (let-values ([(view-x view-y view-width view-height)
+                               (begin 
+                                 (send (get-admin) get-view b1 b2 b3 b4)
+                                 (values (unbox b1)
+                                         (unbox b2)
+                                         (unbox b3)
+                                         (unbox b4)))])
+                   (let* ([old-pen (send dc get-pen)]
+                          [old-brush (send dc get-brush)]
+                          [b/w-bitmap (rectangle-b/w-bitmap rectangle)]
+                          [color (let* ([rc (rectangle-color rectangle)]
+                                        [tmpc (make-object color% 0 0 0)])
+                                   (if rc
+                                       (begin (send dc try-color rc tmpc)
+                                              (if (<= (color-model:rgb-color-distance
+                                                       (send rc red)
+                                                       (send rc green)
+                                                       (send rc blue)
+                                                       (send tmpc red)
+                                                       (send tmpc green)
+                                                       (send tmpc blue))
+                                                      18)
+                                                  rc
+                                                  #f))
+                                       rc))]
+                          [first-number (λ (x y) (if (number? x) x y))]
+                          [left (max left-margin (first-number (rectangle-left rectangle) view-x))]
+                          [top (max top-margin (rectangle-top rectangle))]
+                          [right (min right-margin
+                                      (first-number 
+                                       (rectangle-right rectangle)
+                                       (+ view-x view-width)))]
+                          [bottom (min bottom-margin (rectangle-bottom rectangle))]
+                          [width (max 0 (- right left))]
+                          [height (max 0 (- bottom top))])
+                     (let/ec k
+                       (cond
+                         [(and before color)
+                          (send dc set-pen (send the-pen-list find-or-create-pen color 0 'solid))
+                          (send dc set-brush (send the-brush-list find-or-create-brush color 'solid))]
+                         [(and (not before) (not color) b/w-bitmap)
+                          (unless highlight-pen
+                            (set! highlight-pen (make-object pen% "BLACK" 0 'solid)))
+                          (unless highlight-brush
+                            (set! highlight-brush (make-object brush% "black" 'solid)))
+                          (send highlight-pen set-stipple b/w-bitmap)
+                          (send highlight-brush set-stipple b/w-bitmap)
+                          (send dc set-pen highlight-pen)
+                          (send dc set-brush highlight-brush)]
+                         [else (k (void))])
+                       (send dc draw-rectangle (+ left dx) (+ top dy) width height)
+                       (send dc set-pen old-pen)
+                       (send dc set-brush old-brush)))))
+               range-rectangles)))
+          
+          (define styles-fixed? #f)
+          (public get-styles-fixed set-styles-fixed)
+          (define (get-styles-fixed) styles-fixed?)
+          (define (set-styles-fixed b) (set! styles-fixed? b))
+          
+          (define/augment (on-insert start len)
+            (begin-edit-sequence)
+            (inner (void) on-insert start len))
+          (define/augment (after-insert start len)
+            (when styles-fixed?
+              (change-style (get-fixed-style) start (+ start len) #f))
+            (inner (void) after-insert start len)
+            (end-edit-sequence))
+          
+          (public move/copy-to-edit)
+          (define (move/copy-to-edit dest-edit start end dest-position)
+            (split-snip start)
+            (split-snip end)
+            (let loop ([snip (find-snip end 'before)])
+              (cond
+                [(or (not snip) (< (get-snip-position snip) start))
+                 (void)]
+                [else
+                 (let ([prev (send snip previous)]
+                       [released/copied (if (send snip release-from-owner)
+                                            snip
+                                            (let* ([copy (send snip copy)]
+                                                   [snip-start (get-snip-position snip)]
+                                                   [snip-end (+ snip-start (send snip get-count))])
+                                              (delete snip-start snip-end)
+                                              snip))])
+                   (send dest-edit insert released/copied dest-position dest-position)
+                   (loop prev))])))
+          
+          (public initial-autowrap-bitmap)
+          (define (initial-autowrap-bitmap) (icon:get-autowrap-bitmap))
+          
+          (super-instantiate ())
+          (set-autowrap-bitmap (initial-autowrap-bitmap))))
+      
+      (define foreground-color<%>
+        (interface (basic<%> editor:standard-style-list<%>)
+          ))
+          
+      (define foreground-color-mixin
+        (mixin (basic<%> editor:standard-style-list<%>) (foreground-color<%>)
+          (inherit begin-edit-sequence end-edit-sequence change-style get-style-list)
+	  (define/override (get-fixed-style)
+            (send (editor:get-standard-style-list)
+		  find-named-style
+		  (editor:get-default-color-style-name)))
+          (super-new)))
+      
+      (define hide-caret/selection<%> (interface (basic<%>)))
+      (define hide-caret/selection-mixin
+        (mixin (basic<%>) (hide-caret/selection<%>)
+          (inherit get-start-position get-end-position hide-caret)
+          (define/augment (after-set-position)
+            (hide-caret (= (get-start-position) (get-end-position)))
+	    (inner (void) after-set-position))
+          (super-instantiate ())))
+
+      (define nbsp->space<%> (interface ((class->interface text%))))
+      (define nbsp->space-mixin
+        (mixin ((class->interface text%)) (nbsp->space<%>)
+          (field [rewriting #f])
+          (inherit begin-edit-sequence end-edit-sequence delete insert get-character)
+          (define/augment (on-insert start len)
+            (inner (void) on-insert start len)
+            (begin-edit-sequence))
+	  (inherit find-string)
+          (define/augment (after-insert start len)
+            (unless rewriting
+              (set! rewriting #t)
+	      (let ([str (string (integer->char 160))]
+		    [last-pos (+ start len)])
+		(let loop ([pos start])
+		  (when (< pos last-pos)
+		    (let ([next-pos (find-string str 'forward pos last-pos)])
+		      (when next-pos
+			(delete next-pos (+ next-pos 1) #f)
+			(insert " " next-pos next-pos #f)
+			(loop (+ next-pos 1)))))))
+	      (set! rewriting #f))
+            (end-edit-sequence)
+            (inner (void) after-insert start len))
+          (super-instantiate ())))
+      
+      (define searching<%> (interface (editor:keymap<%> basic<%>)))
+      (define searching-mixin
+        (mixin (editor:keymap<%> basic<%>) (searching<%>)
+          (define/override (get-keymaps)
+            (cons (keymap:get-search) (super get-keymaps)))
+          (super-instantiate ())))
+      
+      (define return<%> (interface ((class->interface text%))))
+      (define return-mixin
+        (mixin ((class->interface text%)) (return<%>) 
+          (init-field return)
+          (define/override (on-local-char key)
+            (let ([cr-code #\return]
+                  [lf-code #\newline]
+                  [code (send key get-key-code)])
+              (or (and (char? code)
+                       (or (char=? lf-code code)
+                           (char=? cr-code code))
+                       (return))
+                  (super on-local-char key))))
+          (super-new)))
+      
+      (define wide-snip<%>
+        (interface (basic<%>)
+          add-wide-snip
+          add-tall-snip))
+      
+      (define wide-snip-mixin
+        (mixin (basic<%>) (wide-snip<%>)
+          (define wide-snips '())
+          (define tall-snips '())
+          (define/public (add-wide-snip s) (set! wide-snips (cons s wide-snips)))
+          (define/public (get-wide-snips) wide-snips)
+          (define/public (add-tall-snip s) (set! tall-snips (cons s tall-snips)))
+          (define/public (get-tall-snips) tall-snips)
+          (super-new)))
+      
+      (define delegate<%> (interface (basic<%>) 
+                            get-delegate
+			    set-delegate))
+
+      (define small-version-of-snip%
+        (class snip%
+          (init-field big-snip)
+          (define width 0)
+          (define height 0)
+          (define/override (get-extent dc x y wb hb db sb lb rb)
+            (set/f! db 0)
+            (set/f! sb 0)
+            (set/f! lb 0)
+            (set/f! rb 0)
+            (let ([bwb (box 0)]
+                  [bhb (box 0)])
+              (send big-snip get-extent dc x y bwb bhb #f #f #f #f)
+              (let* ([cw (send dc get-char-width)]
+                     [ch (send dc get-char-height)]
+                     [w (floor (/ (unbox bwb) cw))]
+                     [h (floor (/ (unbox bhb) ch))])
+                (set/f! wb w)
+                (set/f! hb h)
+                (set! width w)
+                (set! height h))))
+              
+          (define/override (draw dc x y left top right bottom dx dy draw-caret)
+            (send dc draw-rectangle x y width height))
+          (define/override (copy) (instantiate small-version-of-snip% () (big-snip big-snip)))
+          (super-instantiate ())))
+          
+      (define 1-pixel-string-snip%
+        (class string-snip%
+          (init-rest args)
+          (inherit get-text get-count set-count get-flags)
+          (define/override (split position first second)
+            (let* ([str (get-text 0 (get-count))]
+                   [new-second (make-object 1-pixel-string-snip%
+                                 (substring str position (string-length str)))])
+              (set-box! first this)
+              (set-box! second new-second)
+              (set-count position)
+              (void)))
+          (define/override (copy)
+            (let ([cpy (make-object 1-pixel-string-snip%
+                         (get-text 0 (get-count)))])
+              (send cpy set-flags (get-flags))))
+          (define/override (get-extent dc x y wb hb db sb lb rb)
+            (cond
+              [(memq 'invisible (get-flags))
+               (set/f! wb 0)]
+              [else
+               (set/f! wb (get-count))])
+            (set/f! hb 1)
+            (set/f! db 0)
+            (set/f! sb 0)
+            (set/f! lb 0)
+            (set/f! rb 0))
+          
+	  (define cache-function #f)
+
+          (define/override (insert s len pos)
+            (set! cache-function #f)
+            (super insert s len pos))
+
+	  ;; for-each/sections : string -> dc number number -> void
+          (define/private (for-each/sections str)
+            (let loop ([n (string-length str)]
+                       [len 0]
+                       [blank? #t])
+              (cond
+                [(zero? n)
+                 (if blank?
+		     (λ (dc x y) (void))
+		     (λ (dc x y)
+                       (send dc draw-line (+ x n) y (+ x n (- len 1)) y)))]
+                [else
+                 (let ([white? (char-whitespace? (string-ref str (- n 1)))])
+                   (cond
+                     [(eq? white? blank?)
+                      (loop (- n 1) (+ len 1) blank?)]
+                     [else
+		      (let ([res (loop (- n 1) 1 (not blank?))])
+			(if blank?
+			    res
+			    (λ (dc x y)
+			      (send dc draw-line (+ x n) y (+ x n (- len 1)) y)
+			      (res dc x y))))]))])))
+          
+          (define/override (draw dc x y left top right bottom dx dy draw-caret)
+            (let ([str (get-text 0 (get-count))])
+	      (unless cache-function
+		(set! cache-function (for-each/sections str)))
+              (when (<= top y bottom)
+		(cache-function dc x y))))
+          (apply super-make-object args)))
+      
+      (define 1-pixel-tab-snip%
+        (class tab-snip%
+          (init-rest args)
+          (inherit get-text get-count set-count get-flags)
+          (define/override (split position first second)
+            (let* ([str (get-text 0 (get-count))]
+                   [new-second (make-object 1-pixel-string-snip%
+                                 (substring str position (string-length str)))])
+              (set-box! first this)
+              (set-box! second new-second)
+              (set-count position)
+              (void)))
+          (define/override (copy)
+            (let ([cpy (make-object 1-pixel-tab-snip%)])
+              (send cpy set-flags (get-flags))))
+          
+          (inherit get-admin)
+          (define/override (get-extent dc x y wb hb db sb lb rb)
+            (set/f! wb 0)
+            (let ([admin (get-admin)])
+              (when admin
+                (let ([ed (send admin get-editor)])
+                  (when (is-a? ed text%)
+                    (let ([len-b (box 0)]
+                          [tab-width-b (box 0)]
+                          [in-units-b (box #f)])
+                      (send ed get-tabs len-b tab-width-b in-units-b)
+                      (when (and (or (equal? (unbox len-b) 0)
+                                     (equal? (unbox len-b) null))
+                                 (not (unbox in-units-b)))
+                        (let ([tabspace (unbox tab-width-b)])
+                          (set/f! wb (tabspace . - . (x . modulo . tabspace))))))))))
+            
+            (set/f! hb 0)
+            (set/f! db 0)
+            (set/f! sb 0)
+            (set/f! lb 0)
+            (set/f! rb 0))
+          
+          (define/override (draw dc x y left top right bottom dx dy draw-caret)
+            (void))
+          (apply super-make-object args)))
+
+      (define (set/f! b n)
+        (when (box? b)
+          (set-box! b n)))
+
+      (define delegate-mixin
+        (mixin (basic<%>) (delegate<%>) 
+          (inherit split-snip find-snip get-snip-position
+                   find-first-snip get-style-list set-tabs)
+          
+          (define linked-snips #f)
+          
+          (define/private (copy snip)
+            (let ([new-snip
+                   (cond
+                     [(is-a? snip tab-snip%)
+                      (let ([new-snip (make-object 1-pixel-tab-snip%)])
+                        (send new-snip insert (string #\tab) 1)
+                        new-snip)]
+                     [(is-a? snip string-snip%)
+                      (make-object 1-pixel-string-snip%
+                        (send snip get-text 0 (send snip get-count)))]
+                     [else 
+                      (let ([new-snip
+                             (instantiate small-version-of-snip% ()
+                               (big-snip snip))])
+                        (hash-table-put! linked-snips snip new-snip)
+                        new-snip)])])
+              (send new-snip set-flags (send snip get-flags))
+              (send new-snip set-style (send snip get-style))
+              new-snip))
+
+          (define delegate #f)
+          (inherit get-highlighted-ranges)
+          (define/public-final (get-delegate) delegate)
+          (define/public-final (set-delegate _d)
+            (set! delegate _d)
+            (set! linked-snips (if _d
+                                   (make-hash-table)
+                                   #f))
+            (refresh-delegate))
+          
+          (define/private (refresh-delegate)
+            (when delegate
+              (send delegate begin-edit-sequence)
+              (send delegate lock #f)
+              (when (is-a? this scheme:text<%>)
+                (send delegate set-tabs null (send this get-tab-size) #f))
+              (send delegate hide-caret #t)
+              (send delegate erase)
+              (send delegate set-style-list (get-style-list))
+              (let loop ([snip (find-first-snip)])
+                (when snip
+                  (let ([copy-of-snip (copy snip)])
+                    (send delegate insert
+                          copy-of-snip
+                          (send delegate last-position)
+                          (send delegate last-position))
+                    (loop (send snip next)))))
+              (for-each
+               (λ (range)
+                 (send delegate highlight-range 
+                       (range-start range)
+                       (range-end range)
+                       (range-color range)
+                       (range-b/w-bitmap range)
+                       (range-caret-space? range)
+                       'high))
+               (reverse (get-highlighted-ranges)))
+              (send delegate lock #t)
+              (send delegate end-edit-sequence)))
+          
+          (define/override highlight-range
+            (opt-lambda (start end color [bitmap #f] [caret-space? #f] [priority 'low])
+              (let ([res (super highlight-range start end color bitmap caret-space? priority)])
+                (if delegate
+                    (let ([delegate-res (send delegate highlight-range 
+                                              start end color bitmap caret-space? priority)]) 
+                      (λ ()
+                        (res)
+                        (delegate-res)))
+                    res))))
+          
+          (inherit get-canvases get-active-canvas has-focus?)
+          (define/override (on-paint before? dc left top right bottom dx dy draw-caret?)
+            (super on-paint before? dc left top right bottom dx dy draw-caret?)
+            (unless before?
+              (let ([active-canvas (get-active-canvas)])
+                (when active-canvas
+                  (send (send active-canvas get-top-level-window) delegate-moved)))))
+
+          (define/augment (on-edit-sequence)
+            (when delegate
+              (send delegate begin-edit-sequence))
+            (inner (void) on-edit-sequence))
+          
+          (define/augment (after-edit-sequence)
+            (when delegate
+              (send delegate end-edit-sequence))
+            (inner (void) after-edit-sequence))
+
+          (define/override (resized snip redraw-now?)
+            (super resized snip redraw-now?)
+            (when (and delegate
+                       linked-snips
+                       (not (is-a? snip string-snip%)))
+              (let ([delegate-copy (hash-table-get linked-snips snip (λ () #f))])
+                (when delegate-copy
+                  (send delegate resized delegate-copy redraw-now?)))))
+          
+          (define/augment (after-insert start len)
+            (when delegate
+              (send delegate begin-edit-sequence)
+              (send delegate lock #f)
+              (split-snip start)
+              (split-snip (+ start len))
+              (let loop ([snip (find-snip (+ start len) 'before)])
+                (when snip
+                  (unless ((get-snip-position snip) . < . start)
+                    (send delegate insert (copy snip) start start)
+                    (loop (send snip previous)))))
+              (send delegate lock #t)
+              (send delegate end-edit-sequence))
+            (inner (void) after-insert start len))
+          
+          (define/augment (after-delete start len)
+            (when delegate
+              (send delegate lock #f)
+              (send delegate begin-edit-sequence)
+              (send delegate delete start (+ start len))
+              (send delegate end-edit-sequence)
+              (send delegate lock #t))
+            (inner (void) after-delete start len))
+          
+          (define/augment (after-change-style start len)
+            (when delegate
+              (send delegate begin-edit-sequence)
+              (send delegate lock #f)
+              (split-snip start)
+              (let* ([snip (find-snip start 'after)]
+                     [style (send snip get-style)]
+                     [other-style 
+                      '(send (send delegate get-style-list) find-or-create-style
+                             style delegate-style-delta)])
+                (send delegate change-style style start (+ start len)))
+              (send delegate lock #f)
+              (send delegate end-edit-sequence))
+            (inner (void) after-change-style start len))
+          
+          (define filename #f)
+          (define format #f)
+          (define/augment (on-load-file _filename _format)
+            (set! filename _filename)
+            (set! format _format)
+            (inner (void) on-load-file _filename _format))
+          (define/augment (after-load-file success?)
+            (when success?
+              (refresh-delegate))
+            (inner (void) after-load-file success?))
+          (super-instantiate ())))
+    
+      (define info<%> (interface (basic<%>)))
+      
+      (define info-mixin
+        (mixin (editor:keymap<%> basic<%>) (info<%>)
+          (inherit get-start-position get-end-position get-canvas
+                   run-after-edit-sequence)
+          (define/private (enqueue-for-frame call-method tag)
+            (run-after-edit-sequence
+             (rec from-enqueue-for-frame
+               (λ ()
+                 (call-with-frame call-method)))
+             tag))
+          
+          ;; call-with-frame : ((is-a?/c frame:text-info<%>) -> void) -> void
+          ;; calls the argument thunk with the frame showing this editor.
+          (define/private (call-with-frame call-method)
+            (let ([canvas (get-canvas)])
+              (when canvas
+                (let ([frame (send canvas get-top-level-window)])
+                  (when (is-a? frame frame:text-info<%>)
+                    (call-method frame))))))
+          
+          (define/override (set-anchor x)
+            (super set-anchor x)
+            (enqueue-for-frame 
+             (λ (x) (send x anchor-status-changed))
+             'framework:anchor-status-changed))
+          (define/override (set-overwrite-mode x)
+            (super set-overwrite-mode x)
+            (enqueue-for-frame
+             (λ (x) (send x overwrite-status-changed))
+             'framework:overwrite-status-changed))
+          (define/augment (after-set-position)
+            (maybe-queue-editor-position-update)
+            (inner (void) after-set-position))
+          
+          ;; maybe-queue-editor-position-update : -> void
+          ;; updates the editor-position in the frame,
+          ;; but delays it until the next low-priority event occurs.
+          (define callback-running? #f)
+          (define/private (maybe-queue-editor-position-update)
+            (enqueue-for-frame 
+             (λ (frame) 
+               (unless callback-running?
+                 (set! callback-running? #t)
+                 (queue-callback
+                  (λ ()
+                    (send frame editor-position-changed)
+                    (set! callback-running? #f))
+                  #f)))
+             'framework:info-frame:update-editor-position))
+          
+          (define/augment (after-insert start len)
+            (maybe-queue-editor-position-update)
+            (inner (void) after-insert start len))
+          (define/augment (after-delete start len)
+            (maybe-queue-editor-position-update)
+            (inner (void) after-delete start len))
+          (super-new)))
+      
+      (define clever-file-format<%> (interface ((class->interface text%))))
+      
+      (define clever-file-format-mixin
+        (mixin ((class->interface text%)) (clever-file-format<%>)
+          (inherit get-file-format set-file-format find-first-snip)
+          (define/private (all-string-snips)
+            (let loop ([s (find-first-snip)])
+              (cond
+                [(not s) #t]
+                [(is-a? s string-snip%)
+                 (loop (send s next))]
+                [else #f])))
+          (define/augment (on-save-file name format)
+            (let ([all-strings? (all-string-snips)])
+              (cond
+                [(and all-strings?
+                      (eq? format 'same)
+                      (eq? 'standard (get-file-format))
+                      (or (not (preferences:get 'framework:verify-change-format))
+                          (gui-utils:get-choice
+                           (string-constant save-as-plain-text) 
+                           (string-constant yes)
+                           (string-constant no))))
+                 (set-file-format 'text)]
+                [(and (not all-strings?)
+                      (eq? format 'same)
+                      (eq? 'text (get-file-format))
+                      (or (not (preferences:get 'framework:verify-change-format))
+                          (gui-utils:get-choice
+                           (string-constant save-in-drs-format)
+                           (string-constant yes)
+                           (string-constant no))))
+                 (set-file-format 'standard)]
+                [else (void)]))
+            (inner (void) on-save-file name format))
+          (super-instantiate ())))
+      
+      
+      (define file<%>
+        (interface (editor:file<%> basic<%>)
+          get-read-write?))
+      
+      (define file-mixin
+        (mixin (editor:file<%> basic<%>) (file<%>)
+          (inherit get-filename)
+          (define read-write? #t)
+          (define/public (get-read-write?) read-write?)
+          (define/private (check-lock)
+            (let* ([filename (get-filename)]
+                   [can-edit? (if (and filename
+                                       (file-exists? filename))
+                                  (and (member 'write (file-or-directory-permissions filename)) 
+                                       #t)
+                                  #t)])
+              (set! read-write? can-edit?)))
+          
+          (define/augment (can-insert? x y)
+            (and read-write? (inner #t can-insert? x y)))
+          (define/augment (can-delete? x y) 
+            (and read-write? (inner #t can-delete? x y)))
+          
+          (define/augment (after-save-file success)
+            (when success
+              (check-lock))
+            (inner (void) after-save-file success))
+	   
+          (define/augment (after-load-file sucessful?)
+            (when sucessful?
+              (check-lock))
+            (inner (void) after-load-file sucessful?))
+          (super-new)))
+
+      
+      (define ports<%>
+        (interface ()
+          delete/io
+          get-insertion-point 
+          set-insertion-point
+          get-unread-start-point
+          set-unread-start-point
+          set-allow-edits
+          get-allow-edits
+          insert-between
+          submit-to-port?
+          on-submit
+          send-eof-to-in-port
+          send-eof-to-box-in-port
+          reset-input-box
+          clear-output-ports
+          clear-input-port
+          clear-box-input-port
+          get-out-style-delta
+          get-err-style-delta
+          get-value-style-delta
+          get-in-port
+          get-in-box-port
+          get-out-port
+          get-err-port
+          get-value-port
+          after-io-insertion
+          get-box-input-editor-snip%
+          get-box-input-text%))
+      
+      (define-struct peeker (bytes skip-count pe resp-chan nack polling?) (make-inspector))
+      (define-struct committer (kr commit-peeker-evt done-evt resp-chan resp-nack))
+      
+      (define msec-timeout 500)
+      (define output-buffer-full 4096)
+      
+      (define-local-member-name 
+        new-box-input
+        box-input-not-used-anymore
+        set-port-text)
+      
+      (define (set-box/f! b v) (when (box? b) (set-box! b v)))
+      
+      (define eof-snip%
+        (class image-snip%
+          (init-field port-text)
+          (define/override (get-extent dc x y w h descent space lspace rspace)
+            (super get-extent dc x y w h descent space lspace rspace)
+            (set-box/f! descent 7)) ;; depends on actual bitmap used ...
+          
+          (define/override (on-event dc x y editorx editory event)
+            (when (send event button-up? 'left)
+              (send port-text send-eof-to-box-in-port)))
+          (super-make-object (icon:get-eof-bitmap))
+          (inherit set-flags get-flags)
+          (set-flags (list* 'handles-events 'hard-newline (get-flags)))))
+      
+      (define ports-mixin
+        (mixin (wide-snip<%>) (ports<%>)
+          (inherit begin-edit-sequence
+                   change-style
+                   delete
+                   end-edit-sequence
+                   find-snip
+                   insert
+                   get-canvas
+                   get-start-position
+                   get-end-position
+                   get-snip-position
+                   get-style-list
+                   is-locked?
+                   last-position
+                   lock
+                   paragraph-start-position
+                   position-paragraph
+                   release-snip
+                   set-caret-owner
+                   split-snip)
+          
+          ;; private field
+          (define eventspace (current-eventspace))
+          
+          ;; insertion-point : number
+          ;; the place where the output ports insert data
+          ;; only updated in `eventspace' (above)'s main thread
+          (define insertion-point 0)
+          
+          ;; unread-start-points : number
+          ;; from this position to the end of the buffer is the
+          ;;      users editing that has not been committed to the
+          ;;      port.
+          ;; only updated in `eventspace' (above)'s main thread
+          (define unread-start-point 0)
+          
+          ;; box-input : (union #f (is-a?/c editor-snip%))
+          ;; the snip where the user's input is typed for the box input port
+          (define box-input #f)
+          (define eof-button (new eof-snip% (port-text this)))
+          
+          ;; allow-edits? : boolean
+          ;; when this flag is set, only insert/delete after the
+          ;; insertion-point are allowed.
+          (define allow-edits? #f)
+          
+          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+          ;;
+          ;;  public interface
+          ;;
+          
+          ;; insert-between : string/snp -> void
+          ;; inserts something between the insertion point and the unread region
+          (define/public-final (insert-between str/snp)
+            (insert str/snp unread-start-point unread-start-point)
+            (set! unread-start-point (+ unread-start-point 
+                                        (cond
+                                          [(string? str/snp) (string-length str/snp)]
+                                          [(is-a? str/snp snip%)
+                                           (send str/snp get-count)]))))
+                                           
+          
+          (define/public-final (get-insertion-point) insertion-point)
+          (define/public-final (set-insertion-point ip) (set! insertion-point ip))
+          (define/public-final (get-unread-start-point)
+            unread-start-point)
+          (define/public-final (set-unread-start-point u) 
+            (unless (<= u (last-position))
+              (error 'set-unread-start-point "~e is too large, last-position is ~e"
+                     unread-start-point 
+                     (last-position)))
+            (set! unread-start-point u))
+          
+          (define/public-final (set-allow-edits allow?) (set! allow-edits? allow?))
+          (define/public-final (get-allow-edits) allow-edits?)
+          
+          (define/public-final (send-eof-to-in-port) 
+            (channel-put read-chan (cons eof (position->line-col-pos unread-start-point))))
+          (define/public-final (send-eof-to-box-in-port) 
+            (channel-put box-read-chan (cons eof (position->line-col-pos unread-start-point))))
+          (define/public-final (clear-input-port) (channel-put clear-input-chan (void)))
+          (define/public-final (clear-box-input-port) (channel-put box-clear-input-chan (void)))
+          (define/public-final (clear-output-ports) 
+            (channel-put clear-output-chan (void))
+            (init-output-ports))
+          
+          ;; delete/io: number number -> void
+          (define/public-final (delete/io start end)
+            (unless (<= start end insertion-point)
+              (error 'delete/io "expected start (~a) <= end (~a) <= insertion-point (~a)"
+                     start end insertion-point))
+              
+            (let ([dist (- end start)])
+                (set! insertion-point (- insertion-point dist))
+                (set! unread-start-point (- unread-start-point dist)))
+              
+            (let ([before-allowed? allow-edits?])
+              (set! allow-edits? #t)
+              (delete start end #f)
+              (set! allow-edits? before-allowed?)))
+                
+          (define/public-final (get-in-port)
+            (unless in-port (error 'get-in-port "not ready"))
+            in-port)
+          (define/public-final (get-in-box-port)
+            (unless in-port (error 'get-in-box-port "not ready"))
+            in-box-port)
+          (define/public-final (get-out-port)
+            (unless out-port (error 'get-out-port "not ready"))
+            out-port)
+          (define/public-final (get-err-port)
+            (unless err-port (error 'get-err-port "not ready"))
+            err-port)
+          (define/public-final (get-value-port)
+            (unless value-port (error 'get-value-port "not ready"))
+            value-port)
+
+          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+          ;;
+          ;;  specialization interface
+          ;;
+          
+          (define/pubment (submit-to-port? key) (inner #t submit-to-port? key))
+          (define/pubment (on-submit) (inner (void) on-submit))
+          (define/public (get-out-style-delta) 
+            (let ([out-sd (make-object style-delta% 'change-nothing)])
+              (send out-sd set-delta-foreground (make-object color% 150 0 150))
+              out-sd))
+          (define/public (get-err-style-delta)
+            (let ([err-sd (make-object style-delta% 'change-italic)])
+              (send err-sd set-delta-foreground (make-object color% 255 0 0))
+              err-sd))
+          (define/public (get-value-style-delta)
+            (let ([value-sd (make-object style-delta% 'change-nothing)])
+              (send value-sd set-delta-foreground (make-object color% 0 0 175))
+              value-sd))
+
+          (define/public (get-box-input-editor-snip%) editor-snip%)
+          (define/public (get-box-input-text%) input-box%)
+          
+          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+          ;;
+          ;;  editor integration
+          ;;
+          
+          (define/augment (can-insert? start len)
+            (and (or allow-edits? 
+                     (start . >= . unread-start-point))
+                 (inner #t can-insert? start len)))
+          
+          (define/augment (can-delete? start len)
+            (and (or allow-edits?
+                     (start . >= . unread-start-point))
+                 (inner #t can-delete? start len)))
+          
+          (define/override (on-local-char key)
+            (let ([start (get-start-position)]
+                  [end (get-end-position)]
+                  [code (send key get-key-code)])
+              (cond
+                [(not (or (eq? code 'numpad-enter)
+                          (equal? code #\return)
+                          (equal? code #\newline)))
+                 (super on-local-char key)]
+                [(and (insertion-point . <= . start)
+                      (= start end)
+                      (submit-to-port? key))
+                 (insert "\n")
+                 (for-each/snips-chars
+                  unread-start-point
+                  (last-position)
+                  (λ (s/c line-col-pos) 
+                    (cond
+                      [(is-a? s/c snip%)
+                       (channel-put read-chan (cons s/c line-col-pos))]
+                      [(char? s/c)
+                       (for-each (λ (b) (channel-put read-chan (cons b line-col-pos)))
+                                 (bytes->list (string->bytes/utf-8 (string s/c))))])))
+                 (set! unread-start-point (last-position))
+                 (set! insertion-point (last-position))
+                 (on-submit)]
+                [else
+                 (super on-local-char key)])))
+          
+          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+          ;;
+          ;; box input port management
+          ;;
+          
+          (define/public-final (reset-input-box) 
+            (when box-input
+              (let ([l? (is-locked?)]
+                    [old-allow-edits? allow-edits?])
+                (lock #f)
+                (set! allow-edits? #t)
+                (send box-input release-from-owner)
+                (send eof-button release-from-owner)
+                (set! unread-start-point (- unread-start-point 2))
+                (set! allow-edits? old-allow-edits?)
+                (lock l?))
+              (set! box-input #f)))
+          
+          (define/private (on-box-peek)
+            (unless box-input
+              (let* ([ed (new (get-box-input-text%))]
+                     [es (new (get-box-input-editor-snip%) 
+                              (editor ed))]
+                     [locked? (is-locked?)])
+                (send ed set-port-text this)
+                (lock #f)
+                (unless (= unread-start-point (paragraph-start-position (position-paragraph unread-start-point)))
+                  (insert-between "\n"))
+                (insert-between es)
+                (insert-between eof-button)
+                (send (get-canvas) add-wide-snip es)
+                (set! box-input es)
+                (set-caret-owner es 'display)
+                (lock locked?))))
+          
+          (define/public (new-box-input ed)
+            (when (eq? ed (send box-input get-editor)) ;; just in case things get out of sync.
+              (let ([locked? (is-locked?)])
+                (begin-edit-sequence)
+                (lock #f)
+                
+                (let ([old-insertion-point insertion-point])
+                  (let loop ([snip (send (send box-input get-editor) find-first-snip)])
+                    (when snip
+                      (let ([next (send snip next)])
+                        (send snip release-from-owner)
+                        (do-insertion
+                         (list (cons (cond
+                                       [(is-a? snip string-snip%)
+                                        (send snip get-text 0 (send snip get-count))]
+                                       [else snip])
+                                     (make-object style-delta%))))
+                        (loop next))))
+                  
+                  ;; this is copied code ...
+                  (for-each/snips-chars
+                   old-insertion-point
+                   insertion-point
+                   (λ (s/c line-col-pos) 
+                     (cond
+                       [(is-a? s/c snip%)
+                        (channel-put box-read-chan (cons s/c line-col-pos))]
+                       [(char? s/c)
+                        (for-each (λ (b) (channel-put box-read-chan (cons b line-col-pos)))
+                                  (bytes->list (string->bytes/utf-8 (string s/c))))]))))
+                
+                (lock locked?)
+                (end-edit-sequence))))
+          
+          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+          ;;
+          ;; output port syncronization code
+          ;;
+          
+          ;; flush-chan : (channel (evt void))
+          ;; signals that the buffer-thread should flush pending output
+          ;; the evt inside is waited on to indicate the flush has occurred
+          (define flush-chan (make-channel))
+          
+          ;; clear-output-chan : (channel void)
+          (define clear-output-chan (make-channel))
+          
+          ;; write-chan : (channel (cons (union snip bytes) style))
+          ;; send output to the editor
+          (define write-chan (make-channel))
+          
+          ;; readers-chan : (channel (list (channel (union byte snip))
+          ;;                               (channel ...)))
+          (define readers-chan (make-channel))
+          
+          ;; queue-insertion : (listof (cons (union string snip) style)) evt -> void
+          ;; txt is in the reverse order of the things to be inserted.
+          ;; the evt is waited on when the text has actually been inserted
+          ;; thread: any thread, except the eventspace main thread
+          (define/private (queue-insertion txts signal)
+            (parameterize ([current-eventspace eventspace])
+              (queue-callback
+               (λ ()
+                 (do-insertion txts)
+                 (sync signal)))))
+          
+          ;; do-insertion : (listof (cons (union string snip) style-delta)) -> void
+          ;; thread: eventspace main thread
+          (define/private (do-insertion txts)
+            (let ([locked? (is-locked?)])
+              (begin-edit-sequence)
+              (lock #f)
+              (set! allow-edits? #t)
+              (let loop ([txts txts])
+                (cond
+                  [(null? txts) (void)]
+                  [else 
+                   (let* ([fst (car txts)]
+                          [str/snp (car fst)]
+                          [style (cdr fst)])
+                     
+                     (let ([inserted-count
+                            (if (is-a? str/snp snip%)
+                                (send str/snp get-count)
+                                (string-length str/snp))]
+                           [old-insertion-point insertion-point])
+                       (set! insertion-point (+ insertion-point inserted-count))
+                       (set! unread-start-point (+ unread-start-point inserted-count))
+                       
+                       (insert (if (is-a? str/snp snip%)
+                                   (send str/snp copy)
+                                   str/snp)
+                               old-insertion-point
+                               old-insertion-point
+                               #f)
+                       
+                       ;; the idea here is that if you made a string snip, you
+                       ;; could have made a string and gotten the style, so you
+                       ;; must intend to have your own style.
+                       (unless (is-a? str/snp string-snip%)
+                         (change-style style old-insertion-point insertion-point))))
+                   (loop (cdr txts))]))
+              (set! allow-edits? #f)
+              (lock locked?)
+              (end-edit-sequence)
+              (unless (null? txts)
+                (after-io-insertion))))
+          
+          (define/public (after-io-insertion) (void))
+          
+          (define output-buffer-thread
+            (let ([converter (bytes-open-converter "UTF-8-permissive" "UTF-8")])
+              (thread
+               (λ ()
+                 (let loop (;; text-to-insert : (queue (cons (union snip bytes) style))
+                            [text-to-insert (empty-queue)]
+                            [last-flush (current-inexact-milliseconds)])
+                   
+                   (sync
+                    (if (queue-empty? text-to-insert)
+                        never-evt
+                        (handle-evt
+                         (alarm-evt (+ last-flush msec-timeout))
+                         (λ (_)
+                           (let-values ([(viable-bytes remaining-queue) (split-queue converter text-to-insert)])
+                             (queue-insertion viable-bytes always-evt)
+                             (loop remaining-queue (current-inexact-milliseconds))))))
+                    (handle-evt
+                     flush-chan
+                     (λ (return-evt)
+                       (let-values ([(viable-bytes remaining-queue) (split-queue converter text-to-insert)])
+                         (queue-insertion viable-bytes return-evt)
+                         (loop remaining-queue (current-inexact-milliseconds)))))
+                    (handle-evt
+                     clear-output-chan
+                     (λ (_)
+                       (loop (empty-queue) (current-inexact-milliseconds))))
+                    (handle-evt
+                     write-chan
+                     (λ (pr)
+                       (let ([new-text-to-insert (enqueue pr text-to-insert)])
+                         (cond
+                           [((queue-size text-to-insert) . < . output-buffer-full)
+                            (loop new-text-to-insert last-flush)]
+                           [else
+                            (let ([chan (make-channel)])
+                              (let-values ([(viable-bytes remaining-queue) 
+                                            (split-queue converter new-text-to-insert)])
+                                (queue-insertion viable-bytes (channel-put-evt chan (void)))
+                                (channel-get chan)
+                                (loop remaining-queue (current-inexact-milliseconds))))]))))))))))
+          
+          (field [in-port-args #f]
+                 [out-port #f]
+                 [err-port #f]
+                 [value-port #f])
+          
+          (define/private (init-output-ports)
+            
+            ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+            ;;
+            ;;  the following must be able to run
+            ;;  in any thread (even concurrently)
+            ;;
+            (define (make-write-bytes-proc style)
+              (λ (to-write start end block/buffer? enable-breaks?)
+                (cond
+		 [(= start end) (flush-proc)]
+		 [(eq? (current-thread) (eventspace-handler-thread eventspace))
+		  (error 'write-bytes-proc "cannot write to port on eventspace main thread")]
+		 [else
+                  (channel-put write-chan (cons (subbytes to-write start end) style))])
+                (- end start)))
+            
+            (define (flush-proc)
+              (cond
+                [(eq? (current-thread) (eventspace-handler-thread eventspace))
+                 (error 'flush-proc "cannot flush port on eventspace main thread")]
+                [else
+                 (sync
+                  (nack-guard-evt
+                   (λ (fail-channel)
+                     (let* ([return-channel (make-channel)]
+                            [return-evt
+                             (choice-evt
+                              fail-channel
+                              (channel-put-evt return-channel (void)))])
+                       (channel-put flush-chan return-evt)
+                       return-channel))))]))
+            
+            (define (out-close-proc)
+              (void))
+            
+            (define (make-write-special-proc style)
+              (λ (special can-buffer? enable-breaks?)
+                (cond
+                  [(eq? (current-thread) (eventspace-handler-thread eventspace))
+                   (error 'write-bytes-proc "cannot write to port on eventspace main thread")]
+                  [else
+                   (channel-put write-chan (cons special style))])
+                #t))
+            
+            (let* ([add-standard
+                    (λ (sd)
+                      (let* ([style-list (get-style-list)] 
+                             [std (send style-list find-named-style "Standard")])
+                        (if std
+                            (send style-list find-or-create-style std sd)
+                            (let ([basic (send style-list find-named-style "Basic")])
+                              (send style-list find-or-create-style basic sd)))))]
+                   [out-style (add-standard (get-out-style-delta))]
+                   [err-style (add-standard (get-err-style-delta))]
+                   [value-style (add-standard (get-value-style-delta))])
+              (set! out-port (make-output-port #f
+                                               always-evt
+                                               (make-write-bytes-proc out-style)
+                                               out-close-proc
+                                               (make-write-special-proc out-style)))
+              (set! err-port (make-output-port #f 
+                                               always-evt
+                                               (make-write-bytes-proc err-style)
+                                               out-close-proc
+                                               (make-write-special-proc err-style)))
+              (set! value-port (make-output-port #f
+                                                 always-evt
+                                                 (make-write-bytes-proc value-style)
+                                                 out-close-proc
+                                                 (make-write-special-proc value-style)))
+              (let ([install-handlers
+                     (λ (port)
+                       (set-interactive-print-handler port)
+                       (set-interactive-write-handler port)
+                       (set-interactive-display-handler port))])
+                (install-handlers out-port)
+                (install-handlers err-port)
+                (install-handlers value-port))))
+
+          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+          ;;
+          ;;  helpers
+          ;;
+
+          ;; type line-col-pos = (list (union #f fixnum) (union #f fixnum) (union #f fixnum)))
+
+          ;; position->line-col-pos : number -> (list number number number)
+          (define/private (position->line-col-pos pos)
+            (let* ([para (position-paragraph pos)]
+                   [para-start (paragraph-start-position para)])
+              (list (+ para 1)
+                    (- pos para-start)
+                    (+ pos 1))))
+          
+          ;; for-each/snips-chars : number number ((union char snip) line-col-pos -> void) -> void
+          (define/private (for-each/snips-chars start end func)
+            (split-snip start)
+            (split-snip end)
+            (let loop ([snip (find-snip start 'after-or-none)])
+              (cond
+                [(not snip) (void)]
+                [(< (get-snip-position snip) end)
+                 (let ([line-col-pos (position->line-col-pos (get-snip-position snip))])
+                   (cond
+                     [(is-a? snip string-snip%)
+                      (let ([str (send snip get-text 0 (send snip get-count))])
+                        (let loop ([i 0])
+                          (when (< i (string-length str))
+                            (func (string-ref str i)
+                                  (list (car line-col-pos)
+                                        (+ i (cadr line-col-pos))
+                                        (+ i (caddr line-col-pos))))
+                            (loop (+ i 1)))))
+                      (loop (send snip next))]
+                     [else
+                      (func (send snip copy) line-col-pos)
+                      (loop (send snip next))]))]
+                [else (void)])))
+
+                
+          ;; split-queue : converter (queue (cons (union snip bytes) style) 
+          ;;            -> (values (listof (queue (cons (union snip bytes) style)) queue)
+          ;; this function must only be called on the output-buffer-thread
+          ;; extracts the viable bytes (and other stuff) from the front of the queue
+          ;; and returns them as strings (and other stuff).
+          (define/private (split-queue converter q)
+            (let ([lst (queue->list q)])
+              (let loop ([lst lst]
+                         [acc null])
+                (if (null? lst)
+                    (values (reverse acc)
+                            (empty-queue))
+                    (let-values ([(front rest) (peel lst)])
+                      (cond
+                        [(not front) (values (reverse acc)
+                                             (empty-queue))]
+                        [(bytes? (car front))
+                         (let ([the-bytes (car front)]
+                               [key (cdr front)])
+                           (if (null? rest)
+                               (let-values ([(converted-bytes src-read-k termination)
+                                             (bytes-convert converter the-bytes)])
+                                 (if (eq? termination 'aborts)
+                                     (values (reverse (cons (cons (bytes->string/utf-8 converted-bytes) key) acc))
+                                             (enqueue 
+                                              (cons (subbytes the-bytes
+                                                              (- (bytes-length the-bytes) src-read-k) 
+                                                              (bytes-length the-bytes))
+                                                    key)
+                                              (empty-queue)))
+                                     (values (reverse (cons (cons (bytes->string/utf-8 converted-bytes) key) acc))
+                                             (empty-queue))))
+                               (let-values ([(converted-bytes src-read-k termination)
+                                             (bytes-convert converter the-bytes)]
+                                            [(more-bytes more-termination) (bytes-convert-end converter)])
+                                 (loop rest
+                                       (cons (cons (bytes->string/utf-8 (bytes-append converted-bytes more-bytes))
+                                                   key)
+                                             acc)))))]
+                        [else (loop rest
+                                    (cons front acc))]))))))
+          
+          ;; peel : (cons (cons (union snip bytes) X) (listof (cons (union snip bytes) X))
+          ;;     -> (values (cons (union snip bytes) X) (listof (cons (union snip bytes) X)
+          ;; finds the first segment of bytes with the same style and combines them,
+          ;; otherwise a lot like (define (peel x) (values (car x) (cdr x)))
+          (define/private (peel lst)
+            (let loop ([lst lst]
+                       [acc #f]
+                       [key #f])
+              (cond
+                [(null? lst) (values (cons acc key) null)]
+                [else 
+                 (let* ([fst (car lst)]
+                        [fst-key (cdr fst)]
+                        [fst-val (car fst)])
+                   (cond
+                     [(and (not key) (bytes? fst-val))
+                      (loop (cdr lst)
+                            fst-val
+                            fst-key)]
+                     [(and key (bytes? fst-val) (eq? key fst-key))
+                      (loop (cdr lst)
+                            (bytes-append acc fst-val)
+                            key)]
+                     [(not key)
+                      (values fst (cdr lst))]
+                     [else (if acc
+                               (values (cons acc key) lst)
+                               (values fst (cdr lst)))]))])))
+          
+          (super-new)
+          (init-output-ports)
+          (define-values (in-port read-chan clear-input-chan)
+            (start-text-input-port this #f))
+          (define-values (in-box-port box-read-chan box-clear-input-chan) 
+            (start-text-input-port this (lambda () (on-box-peek))))))
+
+      (define input-box<%>
+        (interface ((class->interface text%))
+          ))
+      
+      (define input-box-mixin
+        (mixin ((class->interface text%)) (input-box<%>)
+          (inherit erase lock)
+          
+          (define port-text #f)
+          (define/public (set-port-text pt) (set! port-text pt))
+          
+          (define in-use? #t)
+          (define/public (box-input-not-used-anymore)
+            (lock #t)
+            (set! in-use? #f))
+          
+          (define/override (on-default-char kevt)
+            (super on-default-char kevt)
+            (when in-use?
+              (case (send kevt get-key-code)
+                [(numpad-enter #\return)
+                 (send port-text new-box-input this)]
+                [else (void)])))
+          
+          (super-new)))
+      
+      (define (start-text-input-port source on-peek)
+
+        ;; eventspace at the time this function was called. used for peek callbacks
+        (define eventspace (current-eventspace))
+        
+        ;; read-chan : (channel (cons (union byte snip eof) line-col-pos))
+        ;; send input from the editor
+        (define read-chan (make-channel))
+        
+        ;; clear-input-chan : (channel void)
+        (define clear-input-chan (make-channel))
+        
+        ;; progress-event-chan : (channel (cons (channel event) nack-evt)))
+        (define progress-event-chan (make-channel))
+        
+        ;; peek-chan : (channel peeker)
+        (define peek-chan (make-channel))
+        
+        ;; commit-chan : (channel committer)
+        (define commit-chan (make-channel))
+        
+        ;; position-chan : (channel (cons (channel void) (channel line-col-pos)))
+        (define position-chan (make-channel))
+        
+        (define input-buffer-thread
+          (thread
+           (λ ()
+             
+             ;; these vars are like arguments to the loop function
+             ;; they are only set right before loop is called.
+             ;; This is done to avoid passing the same arguments
+             ;; over and over to loop.
+             (define peeker-sema (make-semaphore 0))
+             (define peeker-evt (semaphore-peek-evt peeker-sema))
+             (define bytes-peeked 0)
+             (define response-evts '())
+             (define peekers '())     ;; waiting for a peek
+             (define committers '())  ;; waiting for a commit
+             (define positioners '()) ;; waiting for a position
+             (define data (empty-queue)) ;; (queue (cons (union byte snip eof) line-col-pos))
+             (define position #f)
+             
+             ;; loop : -> alpha
+             ;; the main loop for this thread
+             (define (loop)
+               (let-values ([(not-ready-peekers new-peek-response-evts)
+                             (separate peekers service-waiter)]
+                            [(potential-commits new-commit-response-evts) 
+                             (separate 
+                              committers
+                              (service-committer data peeker-evt))])
+                 (when (and on-peek
+                            (not (null? not-ready-peekers)))
+                   (parameterize ([current-eventspace eventspace])
+                     (queue-callback on-peek)))
+                 (set! peekers not-ready-peekers)
+                 (set! committers potential-commits)
+                 (set! response-evts 
+                       (append response-evts
+                               new-peek-response-evts
+                               new-commit-response-evts))
+                 (sync
+                  (handle-evt
+                   position-chan
+                   (λ (pr)
+                     (let ([nack-chan (car pr)]
+                           [resp-chan (cdr pr)])
+                       (set! positioners (cons pr positioners))
+                       (loop))))
+                  (if position
+                      (apply choice-evt (map service-positioner positioners))
+                      never-evt)
+                  (handle-evt
+                   read-chan
+                   (λ (ent)
+                     (set! data (enqueue ent data))
+                     (unless position
+                       (set! position (cdr ent)))
+                     (loop)))
+                  (handle-evt
+                   clear-input-chan
+                   (λ (_)
+                     (semaphore-post peeker-sema)
+                     (set! peeker-sema (make-semaphore 0))
+                     (set! peeker-evt (semaphore-peek-evt peeker-sema))
+                     (set! data (empty-queue))
+                     (set! position #f)
+                     (loop)))
+                  (handle-evt
+                   progress-event-chan
+                   (λ (return-pr)
+                     (let ([return-chan (car return-pr)]
+                           [return-nack (cdr return-pr)])
+                       (set! response-evts
+                             (cons (choice-evt
+                                    return-nack
+                                    (channel-put-evt return-chan peeker-evt))
+                                   response-evts))
+                       (loop))))
+                  (handle-evt
+                   peek-chan
+                   (λ (peeker)
+                     (set! peekers (cons peeker peekers))
+                     (loop)))
+                  (handle-evt
+                   commit-chan
+                   (λ (committer)
+                     (set! committers (cons committer committers))
+                     (loop)))
+                  (apply 
+                   choice-evt
+                   (map
+                    (λ (a-committer)
+                      (match a-committer
+                        [($ committer 
+                            kr
+                            commit-peeker-evt
+                            done-evt
+                            resp-chan
+                            resp-nack)
+                         (choice-evt
+                          (handle-evt 
+                           commit-peeker-evt
+                           (λ (_)
+                             ;; this committer will be thrown out in next iteration
+                             (loop)))
+                          (handle-evt
+                           done-evt
+                           (λ (v)
+                             (let ([nth-pos (cdr (peek-n data (- kr 1)))])
+                               (set! position
+                                     (list (car nth-pos)
+                                           (+ 1 (cadr nth-pos))
+                                           (+ 1 (caddr nth-pos)))))
+                             (set! data (dequeue-n data kr))
+                             (semaphore-post peeker-sema)
+                             (set! peeker-sema (make-semaphore 0))
+                             (set! peeker-evt (semaphore-peek-evt peeker-sema))
+                             (set! committers (remq a-committer committers))
+                             (set! response-evts
+                                   (cons 
+                                    (choice-evt
+                                     resp-nack
+                                     (channel-put-evt resp-chan #t))
+                                    response-evts))
+                             (loop))))]))
+                    committers))
+                  (apply choice-evt 
+                         (map (λ (resp-evt)
+                                (handle-evt
+                                 resp-evt
+                                 (λ (_)
+                                   (set! response-evts (remq resp-evt response-evts))
+                                   (loop))))
+                              response-evts)))))
+             
+             ;; service-positioner : (cons (channel void) (channel line-col-pos)) -> evt
+             (define (service-positioner pr)
+               (let ([nack-evt (car pr)]
+                     [resp-evt (cdr pr)])
+                 (handle-evt
+                  (choice-evt nack-evt 
+                              (channel-put-evt resp-evt position))
+                  (let ([sent-position position])
+                    (λ (_)
+                      (set! positioners (remq pr positioners))
+                      (loop))))))
+             
+             ;; service-committer : queue evt -> committer -> (union #f evt)
+             ;; if the committer can be dumped, return an evt that
+             ;; does the dumping. otherwise, return #f
+             (define ((service-committer data peeker-evt) a-committer)
+               (match a-committer
+                 [($ committer
+                     kr commit-peeker-evt
+                     done-evt resp-chan resp-nack)
+                  (let ([size (queue-size data)])
+                    (cond
+                      [(not (eq? peeker-evt commit-peeker-evt))
+                       (choice-evt
+                        resp-nack
+                        (channel-put-evt resp-chan #f))]
+                      [(< size kr)
+                       (choice-evt
+                        resp-nack
+                        (channel-put-evt resp-chan 'commit-failure))]
+                      [else  ;; commit succeeds
+                       #f]))]))
+             
+             ;; service-waiter : peeker -> (union #f evt)
+             ;; if the peeker can be serviced, build an event to service it
+             ;; otherwise return #f
+             (define (service-waiter a-peeker)
+               (match a-peeker
+                 [($ peeker bytes skip-count pe resp-chan nack-evt polling?)
+                  (cond
+                    [(and pe (not (eq? pe peeker-evt)))
+                     (choice-evt (channel-put-evt resp-chan #f)
+                                 nack-evt)]
+                    [((queue-size data) . > . skip-count)
+                     (let ([nth (car (peek-n data skip-count))])
+                       (choice-evt
+                        nack-evt
+                        (cond
+                          [(byte? nth)
+                           (bytes-set! bytes 0 nth)
+                           (channel-put-evt resp-chan 1)]
+                          [(eof-object? nth)
+                           (channel-put-evt resp-chan nth)]
+                          [else
+                           (channel-put-evt 
+                            resp-chan
+                            (λ (src line col pos)
+                              (if (is-a? nth readable-snip<%>)
+                                  (send nth read-special src line col pos)
+                                  nth)))])))]
+                    [polling? 
+                     (choice-evt
+                      nack-evt
+                      (channel-put-evt resp-chan 0))]
+                    [else
+                     #f])]))
+             
+             ;; separate (listof X) (X -> (union #f Y)) -> (values (listof X) (listof Y))
+             ;; separates `eles' into two lists -- those that `f' returns #f for
+             ;; and then the results of calling `f' for those where `f' doesn't return #f
+             (define (separate eles f)
+               (let loop ([eles eles]
+                          [transformed '()]
+                          [left-alone '()])
+                 (cond
+                   [(null? eles) (values left-alone transformed)]
+                   [else (let* ([ele (car eles)]
+                                [maybe (f ele)])
+                           (if maybe
+                               (loop (cdr eles)
+                                     (cons maybe transformed)
+                                     left-alone)
+                               (loop (cdr eles)
+                                     transformed
+                                     (cons ele left-alone))))])))
+             
+             ;;; start things going
+             (loop))))
+        
+        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+        ;;
+        ;;  the following must be able to run
+        ;;  in any thread (even concurrently)
+        ;;
+        (define (read-bytes-proc bstr)
+          (let* ([progress-evt (progress-evt-proc)]
+                 [v (peek-proc bstr 0 progress-evt)])
+            (cond
+              [(sync/timeout 0 progress-evt)
+               0]
+              [else 
+               (wrap-evt 
+                v 
+                (λ (v) 
+                  (if (and (number? v) (zero? v))
+                      0
+                      (if (commit-proc (if (number? v) v 1)
+                                       progress-evt
+                                       always-evt)
+                          v
+                          0))))])))
+        
+        (define (peek-proc bstr skip-count progress-evt)
+          (poll-guard-evt
+           (lambda (polling?)
+             (if polling?
+                 (let ([answer 
+                        (sync
+                         (nack-guard-evt
+                          (λ (nack)
+                            (let ([chan (make-channel)])
+                              (channel-put peek-chan (make-peeker bstr skip-count progress-evt chan nack #t))
+                              chan))))])
+                   (wrap-evt always-evt (λ (_) answer)))
+                 (nack-guard-evt
+                  (λ (nack)
+                    (let ([chan (make-channel)])
+                      (channel-put peek-chan (make-peeker bstr skip-count progress-evt chan nack #f))
+                      chan)))))))
+        
+        (define (progress-evt-proc)
+          (sync
+           (nack-guard-evt
+            (λ (nack)
+              (let ([chan (make-channel)])
+                (channel-put progress-event-chan (cons chan nack))
+                chan)))))
+        
+        (define (commit-proc kr progress-evt done-evt)
+          (sync
+           (nack-guard-evt
+            (λ (nack)
+              (let ([chan (make-channel)])
+                (channel-put commit-chan (make-committer kr progress-evt done-evt chan nack))
+                chan)))))
+        
+        (define (close-proc) (void))
+        
+        (define (position-proc)
+          (let ([chan (make-channel)])
+            (apply 
+             values
+             (sync
+              (nack-guard-evt
+               (λ (fail)
+                 (channel-put position-chan (cons fail chan))
+                 chan))))))
+        (let ([p (make-input-port source
+                                  read-bytes-proc
+                                  peek-proc
+                                  close-proc
+                                  progress-evt-proc
+                                  commit-proc
+                                  position-proc)])
+          (port-count-lines! p)
+          (values p read-chan clear-input-chan)))
+      
+
+      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;
+      ;; queues
+      ;;
+      (define-struct queue (front back count))
+      (define (empty-queue) (make-queue '() '() 0))
+      (define (enqueue e q) (make-queue 
+                             (cons e (queue-front q))
+                             (queue-back q)
+                             (+ (queue-count q) 1)))
+      (define (queue-first q)
+        (flip-around q)
+        (let ([back (queue-back q)])
+          (if (null? back)
+              (error 'queue-first "empty queue")
+              (car back))))
+      (define (queue-rest q)
+        (flip-around q)
+        (let ([back (queue-back q)])
+          (if (null? back)
+              (error 'queue-rest "empty queue")
+              (make-queue (queue-front q)
+                          (cdr back)
+                          (- (queue-count q) 1)))))
+      (define (flip-around q)
+        (when (null? (queue-back q))
+          (set-queue-back! q (reverse (queue-front q)))
+          (set-queue-front! q '())))
+      
+      (define (queue-empty? q) (zero? (queue-count q)))
+      (define (queue-size q) (queue-count q))
+      
+      ;; queue->list : (queue x) -> (listof x)
+      ;; returns the elements in the order that successive deq's would have
+      (define (queue->list q) 
+        (let ([ans (append (queue-back q) (reverse (queue-front q)))])
+          (set-queue-back! q ans)
+          (set-queue-front! q '())
+          ans))
+      
+      ;; dequeue-n : queue number -> queue
+      (define (dequeue-n queue n)
+        (let loop ([q queue]
+                   [n n])
+          (cond
+            [(zero? n) q]
+            [(queue-empty? q) (error 'dequeue-n "not enough!")]
+            [else (loop (queue-rest q) (- n 1))])))
+      
+      ;; peek-n : queue number -> queue
+      (define (peek-n queue init-n)
+        (let loop ([q queue]
+                   [n init-n])
+          (cond
+            [(zero? n) 
+             (when (queue-empty? q)
+               (error 'peek-n "not enough; asked for ~a but only ~a available" 
+                      init-n 
+                      (queue-size queue)))
+             (queue-first q)]
+            [else 
+             (when (queue-empty? q)
+               (error 'dequeue-n "not enough!"))
+             (loop (queue-rest q) (- n 1))])))
+      
+      ;;
+      ;;  end queue abstraction
+      ;;
+      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      
+      (define basic% (basic-mixin (editor:basic-mixin text%)))
+      (define hide-caret/selection% (hide-caret/selection-mixin basic%))
+      (define nbsp->space% (nbsp->space-mixin basic%))
+      (define delegate% (delegate-mixin basic%))
+      (define wide-snip% (wide-snip-mixin basic%))
+      (define standard-style-list% (editor:standard-style-list-mixin wide-snip%))
+      (define input-box% (input-box-mixin standard-style-list%))
+      (define -keymap% (editor:keymap-mixin standard-style-list%))
+      (define return% (return-mixin -keymap%))
+      (define autowrap% (editor:autowrap-mixin -keymap%))
+      (define file% (file-mixin (editor:file-mixin autowrap%)))
+      (define clever-file-format% (clever-file-format-mixin file%))
+      (define backup-autosave% (editor:backup-autosave-mixin clever-file-format%))
+      (define searching% (searching-mixin backup-autosave%))
+      (define info% (info-mixin (editor:info-mixin searching%))))))
diff --git a/collects/framework/private/version.ss b/collects/framework/private/version.ss
new file mode 100644
index 0000000000..f0bdcb2dd2
--- /dev/null
+++ b/collects/framework/private/version.ss
@@ -0,0 +1,30 @@
+(module version mzscheme
+  (require (lib "unitsig.ss")
+	   "sig.ss"
+	   (lib "mred-sig.ss" "mred")
+	   (lib "string.ss")
+	   (lib "list.ss"))
+
+  (provide version@)
+
+  (define version@
+    (unit/sig framework:version^
+      (import)
+      (rename [-version version])
+
+      (define specs null)
+
+      (define -version
+	(λ ()
+	  (foldr
+	   (λ (entry sofar)
+	     (let ([sep (first entry)]
+		   [num (second entry)])
+	       (string-append sofar sep num)))
+	   (version)
+	   specs)))
+
+      (define add-spec
+	(λ (sep num)
+	  (set! specs (cons (list (expr->string sep) (format "~a" num))
+			    specs)))))))
diff --git a/collects/framework/splash.ss b/collects/framework/splash.ss
new file mode 100644
index 0000000000..1adf976bc0
--- /dev/null
+++ b/collects/framework/splash.ss
@@ -0,0 +1,253 @@
+
+(module splash mzscheme
+  (require (lib "class.ss")
+           (lib "file.ss")
+           (lib "mred.ss" "mred"))
+  
+  (provide get-splash-bitmap
+           set-splash-bitmap
+           get-splash-canvas
+           get-splash-eventspace
+           start-splash 
+           shutdown-splash
+           close-splash
+           add-splash-icon
+           set-splash-char-observer
+           set-splash-paint-callback
+           get-splash-paint-callback
+           set-splash-event-callback)
+  
+  (define splash-filename #f)
+  (define splash-bitmap #f)
+  (define splash-eventspace (make-eventspace))
+  
+  (define (get-splash-bitmap) splash-bitmap)
+  (define (set-splash-bitmap bm) 
+    (set! splash-bitmap bm)
+    (send splash-canvas on-paint))
+  (define (get-splash-canvas) splash-canvas)
+  (define (get-splash-eventspace) splash-eventspace)
+
+  (define (set-splash-paint-callback pc) (set! splash-paint-callback pc))
+  (define (get-splash-paint-callback) splash-paint-callback)
+  (define (set-splash-event-callback ec) (set! splash-event-callback ec))
+  
+  (define (splash-paint-callback dc) 
+    (if splash-bitmap
+        (send dc draw-bitmap splash-bitmap 0 0)
+        (send dc clear))
+    (for-each (λ (icon)
+                (send dc draw-bitmap
+                      (icon-bm icon)
+                      (icon-x icon)
+                      (icon-y icon)
+                      'solid
+                      (make-object color% "black")
+                      (send (icon-bm icon) get-loaded-mask)))
+              icons))
+  (define (splash-event-callback evt) (void))
+  
+  (define char-observer void)
+  (define (set-splash-char-observer proc)
+    (set! char-observer proc))
+  
+  (define-struct icon (bm x y))
+  (define icons null)
+  (define (add-splash-icon bm x y)
+    (set! icons (cons (make-icon bm x y) icons))
+    (send splash-canvas on-paint))
+  
+  (define (start-splash _splash-filename _splash-title width-default)
+    (set! splash-title _splash-title)
+    (set! splash-filename _splash-filename)
+    (set! splash-max-width (max 1 (splash-get-preference (get-splash-width-preference-name) width-default)))
+    (send gauge set-range splash-max-width)
+    (send splash-frame set-label splash-title)
+    (let/ec k
+      (define (no-splash)
+        (set! splash-bitmap #f)
+        (set! splash-canvas #f)
+        (set! splash-eventspace #f)
+        (k (void)))
+      
+      (unless splash-filename
+        (no-splash))
+      (unless (file-exists? splash-filename)
+        (fprintf (current-error-port) "WARNING: bitmap path ~s not found~n" splash-filename)
+        (no-splash))
+      
+      (set! splash-bitmap (make-object bitmap% splash-filename))
+      (unless (send splash-bitmap ok?)
+        (fprintf (current-error-port) "WARNING: bad bitmap ~s~n" splash-filename)
+        (no-splash))
+      
+      (send splash-canvas min-width (send splash-bitmap get-width))
+      (send splash-canvas min-height (send splash-bitmap get-height))
+      (send splash-frame center 'both)
+      (send splash-frame show #t)
+      (flush-display) (yield) (sleep)
+      (flush-display) (yield) (sleep)))
+  
+  (define splash-title "no title")
+  
+  (define splash-current-width 0)
+  
+  (define (get-splash-width-preference-name) 
+    (string->symbol (format "plt:~a-splash-max-width" splash-title)))
+  (define splash-max-width 1)
+  
+  (define (close-splash)
+    (unless (= splash-max-width splash-current-width)
+      (splash-set-preference (get-splash-width-preference-name) (max 1 splash-current-width)))
+    (set! quit-on-close? #f)
+    (when splash-frame
+      (send splash-frame show #f)))
+  
+  (define (shutdown-splash)
+    (set! splash-load-handler (λ (old-load f expected) (old-load f expected))))
+   
+  (define funny?
+    (let ([date (seconds->date (current-seconds))])
+      (and (with-handlers ([exn:fail:filesystem? (λ (x) #f)])
+	     (collection-path "icons")
+	     #t)
+	     (= (date-day date) 25)
+	     (= (date-month date) 12))))
+  
+   (define (splash-load-handler old-load f expected)
+     (let ([finalf (splitup-path f)])
+       (set! splash-current-width (+ splash-current-width 1))
+       (when (<= splash-current-width splash-max-width)
+         (send gauge set-value splash-current-width))
+       (old-load f expected)))
+  
+  (let-values ([(make-compilation-manager-load/use-compiled-handler
+                 manager-trace-handler)
+                (if (or (getenv "PLTDRCM")
+                        (getenv "PLTDRDEBUG"))
+                    (parameterize ([current-namespace (make-namespace)])
+                      (values
+                       (dynamic-require '(lib "cm.ss") 'make-compilation-manager-load/use-compiled-handler)
+                       (dynamic-require '(lib "cm.ss") 'manager-trace-handler)))
+                    (values #f #f))])
+    
+    (current-load
+     (let ([old-load (current-load)])
+       (λ (f expected)
+         (splash-load-handler old-load f expected))))
+    
+    (when (and make-compilation-manager-load/use-compiled-handler
+               manager-trace-handler)
+      (printf "PLTDRCM/PLTDRDEBUG: reinstalling CM load handler after setting splash load handler\n")
+      (current-load/use-compiled (make-compilation-manager-load/use-compiled-handler))
+      (when (or (equal? (getenv "PLTDRCM") "trace")
+                (equal? (getenv "PLTDRDEBUG") "trace"))
+        (printf "PLTDRCM/PLTDRDEBUG: reinstalling CM trace handler after setting splash load handler\n")
+        (manager-trace-handler
+         (λ (x) (display "2: ") (display x) (newline))))))
+  
+  (define funny-gauge%
+    (class canvas% 
+      (inherit get-dc min-width min-height stretchable-width stretchable-height)
+      (field
+       [funny-value 0]
+       [funny-bitmap
+	(make-object bitmap% (build-path (collection-path "icons") "touch.bmp"))]
+       [max-value 1])
+
+      [define/public set-range (λ (r) (set! max-value r))]
+      [define/public set-value
+        (λ (new-value)
+          (let* ([before-x
+                  (floor (* (send funny-bitmap get-width) (/ funny-value max-value)))]
+                 [after-x
+                  (ceiling (* (send funny-bitmap get-width) (/ new-value max-value)))]
+                 [width (- after-x before-x)])
+            (send (get-dc) draw-line
+                  (+ before-x 2) 0
+                  (+ width 2) 0)
+            (send (get-dc) draw-line
+                  (+ before-x 2) (+ (send funny-bitmap get-height) 4)
+                  (+ width 2) (+ (send funny-bitmap get-height) 4))
+            (send (get-dc) draw-bitmap-section funny-bitmap
+                  (+ 2 before-x) 2
+                  before-x 0
+                  width (send funny-bitmap get-height)))
+          (set! funny-value new-value))]
+
+      [define/override (on-paint)
+        (let ([dc (get-dc)])
+          (send dc clear)
+          (send dc draw-rectangle 0 0
+                (+ (send funny-bitmap get-width) 4)
+                (+ (send funny-bitmap get-height) 4))
+          (send dc draw-bitmap-section funny-bitmap
+                2 2 0 0
+                (* (send funny-bitmap get-width) (/ funny-value max-value))
+                (send funny-bitmap get-height)))]
+
+      (super-instantiate ())
+      (min-width (+ (send funny-bitmap get-width) 4))
+      (min-height (+ (send funny-bitmap get-height) 4))
+      (stretchable-width #f)
+      (stretchable-height #f)))
+  
+  (define (splash-get-preference name default)
+    (get-preference
+     name
+     (λ ()
+       default)))
+  (define (splash-set-preference name value)
+    (put-preferences (list name) (list value)))
+  
+  (define (splitup-path f)
+    (let*-values ([(absf) (if (relative-path? f)
+                              (build-path (current-directory) f)
+                              f)]
+                  [(base name _1) (split-path absf)])
+      
+      (if base
+          (let-values ([(base2 name2 _2) (split-path base)])
+            (if base2
+                (let-values ([(base3 name3 _2) (split-path base2)])
+                  (build-path name3 name2 name))
+                (build-path name2 name)))
+          name)))
+  
+  (define quit-on-close? #t)
+  
+  (define splash-frame%
+    (class frame%
+      (define/augment (on-close)
+        (when quit-on-close?
+          (exit)))
+      (super-new)))
+  
+  (define splash-canvas%
+    (class canvas%
+      (inherit get-dc)
+      (define/override (on-char evt) (char-observer evt))
+      (define/override (on-paint) (splash-paint-callback (get-dc)))
+      (define/override (on-event evt) (splash-event-callback evt))
+      (super-new)))
+  
+  (define splash-frame
+    (parameterize ([current-eventspace splash-eventspace])
+      (instantiate splash-frame% ()
+        (label splash-title)
+        (style '(no-resize-border)))))
+  (send splash-frame set-alignment 'center 'center)
+  
+  (define panel (make-object vertical-pane% splash-frame))
+  (define splash-canvas (make-object splash-canvas% panel))
+  (define h-panel (make-object horizontal-pane% panel))
+  (define gauge
+    (if funny?
+        (make-object funny-gauge% h-panel)
+        (make-object gauge% #f splash-max-width h-panel '(horizontal))))
+  (send panel stretchable-width #f)
+  (send panel stretchable-height #f)
+  (send h-panel set-alignment 'center 'top)
+  (send splash-canvas focus)
+  (send splash-canvas stretchable-width #f)
+  (send splash-canvas stretchable-height #f))
diff --git a/collects/framework/test.ss b/collects/framework/test.ss
new file mode 100644
index 0000000000..8c564e3531
--- /dev/null
+++ b/collects/framework/test.ss
@@ -0,0 +1,1037 @@
+
+(module test mzscheme
+  (require (lib "mred.ss" "mred")
+           (lib "class.ss")
+           (lib "etc.ss")
+           (lib "contract.ss"))
+  
+  (define-syntax (provide/contract/docs stx)
+    (syntax-case stx ()
+      [(_ (name contract docs ...) ...)
+       (syntax (provide/contract (name contract) ...))]))
+  
+  (provide/contract/docs
+   (test:number-pending-actions
+    (-> number?)
+    ()
+    "Returns the number of pending events (those that haven't completed yet)")
+
+   (test:run-interval
+    (case->
+     (number? . -> . void?)
+     (-> number?))
+    ((msec) ())
+    "See also"
+    "\\hyperref{Actions and completeness}{Actions and completeness, section~}{}{fw:actions-completeness}."
+    "The first case in the case-lambda sets"
+    "the run interval to \\var{msec} milliseconds and the second"
+    "returns the current setting.")
+
+   (test:reraise-error
+    (-> void?)
+    ()
+    "See also"
+    "\\hyperref{Errors}{Errors, section~}{}{fw:test:errors}.")
+
+   (test:run-one
+    ((-> void?) . -> . void?)
+    (f)
+    "Runs the function \\var{f} as if it was a simulated event. See also"
+    "\\hyperref{the test section}{section ~}{}{fw:test}.")
+
+   (test:current-get-eventspaces
+    (case->
+     ((-> (listof eventspace?)) . -> . void?)
+     (-> (-> (listof eventspace?))))
+    ((func) ())
+
+    "This parameter that specifies which "
+    "\\hyperref{eventspaces}{eventspace (see section~}{)}{eventspaceinfo}"
+    "are considered when finding the frontmost frame."
+
+    "The first case"
+    "sets the parameter to \\var{func}. The procedure \\var{func} will be"
+    "invoked with no arguments to determine the eventspaces to consider"
+    "when finding the frontmost frame for simulated user events."
+
+    "The second case"
+    "returns the current value of the parameter. This will be a procedure"
+    "which, when invoked, returns a list of eventspaces.")
+   (test:close-top-level-window
+    ((is-a?/c top-level-window<%>) . -> . void?)
+    (tlw)
+    "Use this function to simulate clicking on the close box of a frame."
+    "Closes \\var{tlw} with this expression:"
+    ""
+    "\\begin{schemedisplay}"
+    "(when (send tlw can-close?)"
+    "  (send tlw on-close)"
+    "  (send tlw show #f))"
+    "\\end{schemedisplay}")
+
+   (test:top-level-focus-window-has?
+    (((is-a?/c area<%>) . -> . boolean?) . -> . boolean?)
+    (test)
+    "Calls \\var{test} for each child of the top-level-focus-frame"
+    "and returns \\scheme|#t| if \\var{test} ever does, otherwise"
+    "returns \\scheme|#f|. If there"
+    "is no top-level-focus-window, returns \\scheme|#f|.")
+
+   ;; ((frame-has? p) f) =
+   ;;    f is a frame and it has a child (in it or a subpanel) that responds #t to p
+   (test:button-push
+    ((union (λ (str)
+              (and (string? str)
+                   (test:top-level-focus-window-has?
+                    (λ (c)
+                      (and (is-a? c button%)
+                           (string=? (send c get-label) str)
+                           (send c is-enabled?)
+                           (send c is-shown?))))))
+	    
+            (and/c (is-a?/c button%)
+		   (λ (btn)
+		     (and (send btn is-enabled?)
+			  (send btn is-shown?)))
+		   (λ (btn)
+		     (test:top-level-focus-window-has?
+		      (λ (c) (eq? c btn))))))
+     . -> .
+     void?)
+    (button)
+    "Simulates pushing \\var{button}.  If a string is supplied, the"
+    "primitive searches for a button labelled with that string in the"
+    "active frame. Otherwise, it pushes the button argument.")
+
+   (test:set-radio-box!
+    ((union string? (is-a?/c radio-box%)) (union string? number?) . -> . void?)
+    (radio-box state)
+    "Sets the radio-box to \\var{state}. If \\var{state} is a"
+    "string, this function finds the choice with that label and"
+    "if it is a number, it uses the number as an index into the"
+    "state. If the number is out of range or if the label isn't"
+    "in the radio box, an exception is raised."
+    ""
+    "If \\var{radio-box} is a string, this function searches for a"
+    "\\iscmclass{radio-box} with a label matching that string,"
+    "otherwise it uses \\var{radio-box} itself.")
+
+   (test:set-radio-box-item!
+    (string? . -> . void?)
+    (entry)
+    "Finds a \\iscmclass{radio-box} that has a label \\var{entry}"
+    "and sets the radio-box to \\var{entry}.")
+   (test:set-check-box!
+    ((union string? (is-a?/c check-box%)) boolean? . -> . void?)
+    (check-box state)
+    "Clears the \\iscmclass{check-box} item if \\var{state} is \\rawscm{\\#f}, and sets it"
+    "otherwise."
+    ""
+    "If \\var{check-box} is a string,"
+    "this function searches for a \\iscmclass{check-box} with a label matching that string,"
+    "otherwise it uses \\var{check-box} itself.")
+
+   (test:set-choice!
+    ((union string? (is-a?/c choice%)) string? . -> . void?)
+    (choice str)
+    "Selects \\var{choice}'s item \\var{str}. If \\var{choice} is a string,"
+    "this function searches for a \\iscmclass{choice} with a label matching"
+    "that string, otherwise it uses \\var{choice} itself.")
+
+   (test:keystroke
+    (opt->
+     ((union char? symbol?))
+     ((listof (symbols 'alt 'control 'meta 'shift 'noalt 'nocontrol 'nometea 'noshift)))
+     void?)
+    ((key)
+     ((modifier-list null)))
+    "This function simulates a user pressing a key. The argument, \\var{key},"
+    "is just like the argument to the"
+    "@link key-event get-key-code"
+    "method of the"
+    "@link key-event"
+    "class. "
+    ""
+    "{\\it Note:}"
+    "To send the ``Enter'' key, use \\verb|#\return|,"
+    "not \\verb|#\newline|."
+    ""
+    "The \\rawscm{'shift} or \\rawscm{'noshift} modifier is implicitly set from \\var{key},"
+    "but is overridden by the argument list. The \\rawscm{'shift} modifier is"
+    "set for any capitol alpha-numeric letters and any of the following characters:"
+    "\\begin{schemedisplay}"
+    "#\\? #\\: #\\~ #\\\\ #\\|"
+    "#\\< #\\> #\\{ #\\} #\\[ #\\] #\\( #\\)"
+    "#\\! #\\@ #\\# #\\$ #\\% #\\^ #\\& #\\* #\\_ #\\+"
+    "\\end{schemedisplay}"
+    ""
+    "If conflicting modifiers are provided, the ones later in the list are used.")
+
+   (test:menu-select
+    (string? string? . -> . void?)
+    (menu item)
+    "Selects the menu-item named \\var{item} in the menu named \\var{menu}."
+    ""
+    "{\\it Note:}"
+    "The string for the menu item does not include its keyboard equivalent."
+    "For example, to select ``New'' from the ``File'' menu, "
+    "use ``New'', not ``New Ctrl+m n''.")
+
+   (test:mouse-click
+    (opt->
+     ((symbols 'left 'middle 'right)
+      (and/c exact? integer?)
+      (and/c exact? integer?))
+     ((listof (symbols 'alt 'control 'meta 'shift 'noalt 'nocontrol 'nometa 'noshift)))
+     void?)
+    ((button x y)
+     ((modifiers null)))
+    "Simulates a mouse click at the coordinate: $(x,y)$ in the currently"
+    "focused \\iscmintf{window}, assuming that it supports the "
+    "@ilink canvas on-event"
+    "method."
+    "Use"
+    "@flink test:button-push"
+    "to click on a button."
+    ""
+    "On the Macintosh, \\rawscm{'right} corresponds to holding down the command"
+    "modifier key while clicking and \\rawscm{'middle} cannot be generated."
+    ""
+    "Under Windows, \\rawscm{'middle} can only be generated if the user has a"
+    "three button mouse."
+    ""
+    "The modifiers later in the list \\var{modifiers} take precedence over"
+    "ones that appear earlier.")
+
+   (test:new-window 
+    ((is-a?/c window<%>) . -> . void?)
+    (window)
+    "Moves the keyboard focus to a new window within the currently active"
+    "frame.  Unfortunately, neither this function nor any other function in"
+    "the test engine can cause the focus to move from the top-most (active)"
+    "frame. "))
+
+  (define (test:top-level-focus-window-has? pred)
+    (let ([tlw (get-top-level-focus-window)])
+      (and tlw
+	   (let loop ([tlw tlw])
+	     (or (pred tlw)
+		 (and (is-a? tlw area-container<%>)
+		      (ormap loop (send tlw get-children))))))))
+
+  (define initial-run-interval 0)  ;; milliseconds
+
+  ;;
+  ;; The minimum time an action is allowed to run before returning from
+  ;; mred:test:action.  Controls the rate at which actions are started, 
+  ;; and gives some slack time for real events to complete (eg, update).
+  ;; Make-parameter doesn't do what we need across threads.
+  ;; Probably don't need semaphores here (set! is atomic).
+  ;; Units are in milliseconds (as in mred:timer%).
+  ;;
+  
+  (define run-interval
+    (let ([tag  'test:run-interval]
+	  [msec  initial-run-interval])
+      (case-lambda
+        [()   msec]
+	[(x)  (if (and (integer? x) (exact? x) (<= 0 x))
+		  (set! msec x)
+		  (error tag "expects exact, non-negative integer, given: ~e" x))])))
+  
+  ;;
+  ;; How we get into the handler thread, and put fake actions 
+  ;; on the real event queue.
+  ;;
+  
+  (define install-timer
+    (λ (msec thunk)
+      (let ([timer (instantiate timer% ()
+                     [notify-callback (λ () (thunk))])])
+        (send timer start msec #t))))
+  
+  ;;
+  ;; Simple accounting of actions and errors.
+  ;;
+  ;; Keep number of unfinished actions.  An error in the buffer
+  ;; (caught but not-yet-reraised) counts as an unfinished action.
+  ;; (but kept in the-error, not count).
+  ;;
+  ;; Keep buffer of one error, and reraise at first opportunity.
+  ;; Keep just first error, any others are thrown on the floor.
+  ;; Reraising the error flushes the buffer.
+  ;; Store exn in box, so can correctly catch (raise #f).
+  ;; 
+  ;; These values are set in handler thread and read in main thread,
+  ;; so certainly need semaphores here.
+  ;;
+  
+  (define-values (begin-action  end-action  end-action-with-error
+		  get-exn-box   is-exn?     num-actions)
+    (let 
+	([sem    (make-semaphore 1)]
+	 [count      0]     ;; number unfinished actions.
+	 [the-error  #f])   ;; boxed exn struct, or else #f.
+      (letrec
+	  ([begin-action
+	    (λ ()
+	      (semaphore-wait sem)
+	      (set! count (add1 count))
+	      (semaphore-post sem))]
+	   
+	   [end-action
+	    (λ ()
+	      (semaphore-wait sem)
+	      (set! count (sub1 count))
+	      (semaphore-post sem))]
+	   
+	   [end-action-with-error
+	    (λ (exn)
+	      (semaphore-wait sem)
+	      (set! count (sub1 count))
+	      (unless the-error
+		(set! the-error (box exn)))
+	      (semaphore-post sem))]
+	   
+	   [get-exn-box
+	    (λ ()
+	      (semaphore-wait sem)
+	      (let ([ans  the-error])
+		(set! the-error #f)
+		(semaphore-post sem)
+		ans))]
+	   
+	   [is-exn?
+	    (λ ()
+	      (semaphore-wait sem)
+	      (let ([ans  (if the-error #t #f)])
+		(semaphore-post sem)
+		ans))]
+ 
+	   [num-actions
+	    (λ ()
+	      (semaphore-wait sem)
+	      (let ([ans  (+ count (if the-error 1 0))])
+		(semaphore-post sem)
+		ans))])
+	
+	(values  begin-action  end-action  end-action-with-error
+		 get-exn-box   is-exn?     num-actions))))
+  
+  ;; Functions to export, always in main thread.
+  
+  (define number-pending-actions num-actions)
+  
+  (define reraise-error
+    (λ ()
+      (let ([exn-box  (get-exn-box)])
+	(if exn-box (raise (unbox exn-box)) (void)))))
+  
+  ;;
+  ;; Start running thunk in handler thread.
+  ;; Don't return until run-interval expires, and thunk finishes, 
+  ;; raises error, or yields (ie, at event boundary).
+  ;; Reraise error (if exists) even from previous action.
+  ;; Note: never more than one timer (of ours) on real event queue.
+  ;; 
+  
+  (define run-one
+    (let ([yield-semaphore (make-semaphore 0)]
+	  [thread-semaphore (make-semaphore 0)])
+      (thread
+       (rec loop
+	    (λ ()
+	      (semaphore-wait thread-semaphore)
+	      (sleep)
+	      (semaphore-post yield-semaphore)
+	      (loop))))
+      (λ (thunk)
+	(let ([sem (make-semaphore 0)])
+	  (letrec ([start
+                    (λ () ;; eventspace main thread
+                      
+                      ;; guarantee (probably) that some events are handled
+                      (semaphore-post thread-semaphore) 
+                      (yield yield-semaphore)
+                      
+                      (install-timer (run-interval) return)
+                      (unless (is-exn?)
+                        (begin-action)
+                        (parameterize ([current-exception-handler
+                                        (λ (exn)
+                                          (end-action-with-error exn)
+                                          ((error-escape-handler)))])
+                          (thunk))
+                        (end-action)))]
+                   
+                   [return (λ () (semaphore-post sem))])
+	    
+	    (install-timer 0 start)
+	    (semaphore-wait sem)
+	    (reraise-error))))))
+  
+  ;; new, queue-callback based run-one
+  '(define run-one
+    (let ([yield-semaphore (make-semaphore 0)]
+	  [thread-semaphore (make-semaphore 0)])
+      (thread
+       (rec loop
+         (λ ()
+           (semaphore-wait thread-semaphore)
+           (sleep)
+           (semaphore-post yield-semaphore)
+           (loop))))
+      (λ (thunk)
+        (let ([done (make-semaphore 0)])
+          (queue-callback
+           (λ ()
+             
+             ;; guarantee (probably) that some events are handled
+             (semaphore-post thread-semaphore) 
+             (yield yield-semaphore)
+                      
+             (queue-callback (λ () (semaphore-post done)))
+             (unless (is-exn?)
+               (begin-action)
+               (parameterize ([current-exception-handler
+                               (λ (exn)
+                                 (end-action-with-error exn)
+                                 ((error-escape-handler)))])
+                 (thunk))
+               (end-action))))
+          (semaphore-wait done)))))
+  
+  (define current-get-eventspaces
+    (make-parameter (λ () (list (current-eventspace)))))
+
+  (define (get-active-frame)
+    (ormap (λ (eventspace)
+	     (parameterize ([current-eventspace eventspace])
+	       (get-top-level-focus-window)))
+	   ((current-get-eventspaces))))
+
+  (define (get-focused-window)
+    (let ([f (get-active-frame)])
+      (and f
+	   (send f get-focus-window))))
+
+  (define time-stamp current-milliseconds)
+  
+  ;;
+  ;; Return list of window's ancestors from root down to window
+  ;; (including window).  Used for on-subwindow-char and on-subwindow-event.
+  ;; get-parent returns #f for no parent.
+  ;; If stop-at-top-level-window? is #t, then the ancestors up to the
+  ;; first top-level-window are returned.
+  ;;
+
+  (define ancestor-list
+    (λ (window stop-at-top-level-window?)
+      (let loop ([w window] [l null])
+	(if (or (not w)
+		(and stop-at-top-level-window?
+		     (is-a? w top-level-window<%>)))
+	    l
+	    (loop (send w get-parent) (cons w l))))))
+  
+  ;;
+  ;; Returns #t if window is in active-frame, else #f.
+  ;; get-parent returns () for no parent.
+  ;;
+  
+  (define in-active-frame?
+    (λ (window)
+      (let ([frame  (get-active-frame)])
+	(let loop ([window  window])
+	  (cond [(null? window)      #f]
+		[(eq? window frame)  #t]
+		[else  (loop (send window get-parent))])))))
+  
+  ;;
+  ;; Verify modifier list.
+  ;; l, valid : lists of symbols.
+  ;; returns first item in l *not* in valid, or else #f.
+  ;;
+  
+  (define verify-list
+    (λ (l  valid)
+      (cond [(null? l)  #f]
+	    [(member (car l) valid)  (verify-list (cdr l) valid)]
+	    [else  (car l)])))
+  
+  (define verify-item 
+    (λ (item valid)
+      (verify-list (list item) valid)))
+    
+;;;
+;;; find-object obj-class b-desc 
+;;; returns an object belonging to obj-class, where b-desc
+;;; is either an object, or a string
+;;;
+
+  (define object-tag 'test:find-object)
+
+  ;; find-object : class (union string (object -> boolean)) -> object
+  (define (find-object obj-class b-desc)
+    (λ ()
+      (cond
+	[(or (string? b-desc)
+             (procedure? b-desc))
+	 (let* ([active-frame (get-active-frame)]
+		[_ (unless active-frame
+		     (error object-tag
+                            "could not find object: ~a, no active frame" 
+                            b-desc))]
+                [child-matches?
+                 (λ (child)
+                   (cond
+                     [(string? b-desc)
+                      (equal? (send child get-label) b-desc)]
+                     [(procedure? b-desc)
+                      (b-desc child)]))]
+		[found
+		 (let loop ([panel active-frame])
+		   (ormap (λ (child)
+			    (cond
+			      [(and (is-a? child obj-class)
+				    (child-matches? child))
+			       child]
+			      [(is-a? child area-container-window<%>) 
+                               (and (send child is-shown?)
+                                    (loop child))]
+                              [(is-a? child area-container<%>) 
+                               (loop child)]
+			      [else #f]))
+			  (send panel get-children)))])
+	   (or found
+	       (error object-tag 
+                      "no object of class ~a named ~e in active frame"
+                      obj-class
+                      b-desc)))]
+	[(is-a? b-desc obj-class) b-desc]
+	[else (error 
+	       object-tag
+	       "expected either a string or an object of class ~a as input, received: ~a"
+	       obj-class b-desc)])))
+
+
+;;; functions specific to various user input
+
+;;; CONTROL functions, to be specialized for individual controls 
+
+  (define control-action
+    (λ (error-tag event-sym find-ctrl update-control)
+      (run-one
+       (λ ()
+	 (let ([event (make-object control-event% event-sym)]
+	       [ctrl (find-ctrl)])
+	   (cond
+	     [(not (send ctrl is-shown?))
+	      (error error-tag "control ~e is not shown (label ~e)" ctrl (send ctrl get-label))]
+	     [(not (send ctrl is-enabled?))
+	      (error error-tag "control ~e is not enabled (label ~e)" ctrl (send ctrl get-label))]
+	     [(not (in-active-frame? ctrl))
+	      (error error-tag "control ~e is not in active frame (label ~e)" ctrl (send ctrl get-label))]
+	     [else
+	      (update-control ctrl)
+	      (send ctrl command event)
+	      (void)]))))))	     
+
+  ;;
+  ;; BUTTON
+  ;;
+
+  (define (button-push button)
+    (control-action
+     'test:button-push
+     'button
+     (find-object button% button)
+     void))
+
+;; 
+;; CHECK-BOX 
+;;
+
+  (define (set-check-box! in-cb state) 
+    (control-action
+     'test:set-check-box!
+     'check-box 
+     (find-object check-box% in-cb)
+     (λ (cb) (send cb set-value state))))
+  
+;; 
+;; RADIO-BOX 
+;;
+
+  (define (build-labels radio-box)
+    (string-append
+     (format "~s" (send radio-box get-item-label 0))
+     (let loop ([n (- (send radio-box get-number) 1)])
+       (cond
+	[(zero? n) ""]
+	[else (string-append " "
+			     (format "~s"
+				     (send radio-box get-item-label
+					   (- (send radio-box get-number)
+					      n)))
+			     (loop (- n 1)))]))))
+
+  (define (set-radio-box! in-cb state) 
+    (control-action
+     'test:set-radio-box!
+     'radio-box 
+     (find-object radio-box% in-cb)
+     (λ (rb) 
+       (cond
+	[(string? state) 
+	 (let ([total (send rb get-number)])
+	   (let loop ([n total])
+	     (cond
+	       [(zero? n) (error 'test:set-radio-box!
+				 "did not find ~e as a label for ~e; labels: ~a"
+				 state in-cb
+				 (build-labels in-cb))]
+	       [else (let ([i (- total n)])
+		       (if (or (string=? state (send rb get-item-label i))
+			       (string=? state (send rb get-item-plain-label i)))
+			   (if (send rb is-enabled? i)
+			       (send rb set-selection i)
+			       (error 'test:set-radio-box!
+				      "label ~e is disabled"
+				      state))
+			   (loop (- n 1))))])))]
+	[(number? state)
+	 (unless (send rb is-enabled? state)
+	   (error 'test:set-radio-box! "item ~a is not enabled~n" state))
+	 (send rb set-selection state)]
+	[else (error 'test:set-radio-box!
+		     "expected a string or a number as second arg, got: ~e (other arg: ~e)"
+		     state in-cb)]))))
+
+  ;; set-radio-box-item! : string -> void
+  (define (set-radio-box-item! state) 
+    (control-action
+     'test:set-check-box-state!
+     'radio-box
+     (find-object radio-box% (entry-matches state))
+     (λ (rb) 
+       (let ([total (send rb get-number)])
+         (let loop ([n total])
+           (cond
+             [(zero? n) (error 'test:set-radio-box-item! "internal error")]
+             [else (let ([i (- total n)])
+                     (if (or (string=? state (send rb get-item-label i))
+                             (string=? state (send rb get-item-plain-label i)))
+                         (if (send rb is-enabled? i)
+                             (send rb set-selection i)
+                             (error 'test:set-radio-box!
+                                    "label ~e is disabled"
+                                    state))
+                         (loop (- n 1))))]))))))
+  
+  ;; entry-matches : string -> radio-box -> boolean
+  (define (entry-matches name)
+    (λ (rb)
+      (let loop ([n (send rb get-number)])
+        (and (not (zero? n))
+             (or (equal? name (send rb get-item-label (- n 1)))
+                 (equal? name (send rb get-item-plain-label (- n 1)))
+                 (loop (- n 1)))))))
+  
+;;; CHOICE 
+
+; set-choice! : ((instance in-choice%) (union string number) -> void)
+  (define (set-choice! in-choice str)
+    (control-action
+     'test:set-choice!
+     'choice
+     (find-object choice% in-choice)
+     (λ (choice)
+       (cond
+	 [(number? str) (send choice set-selection str)]
+	 [(string? str) (send choice set-string-selection str)]
+	 [else (error 'test:set-choice!
+		      "expected a string or a number as second arg, got: ~e (other arg: ~e)"
+		      str in-choice)]))))
+  ;;
+  ;; KEYSTROKES 
+  ;;
+  ;; Give ancestors (from root down) option of handling key event
+  ;; with on-subwindow-char.  If none want it, then send to focused window
+  ;; with (send <window> on-char <wx:key-event>).
+  ;;
+  ;; key: char or integer.
+  ;; optional modifiers: 'alt, 'control, 'meta, 'shift, 
+  ;;   'noalt, 'nocontrol, 'nometa, 'noshift.
+  ;;
+  ;; Window must be shown, in active frame, and either the window has
+  ;; on-char, or else some ancestor must grab key with on-subwindow-char.
+  ;;
+  
+  (define key-tag 'test:keystroke)
+  (define legal-keystroke-modifiers
+    (list 'alt 'control 'meta 'shift
+          'noalt 'nocontrol 'nometa 'noshift))
+
+  (define valid-key-symbols
+    (list 'start 'cancel 'clear 'shift 'control 'menu 'pause 'capital
+	  'prior 'next 'end 'home 'left 'up 'right 'down 'select 'print
+	  'execute 'snapshot 'insert 'help 'numpad0 'numpad1 'numpad2
+	  'numpad3 'numpad4 'numpad5 'numpad6 'numpad7 'numpad8 'numpad9
+	  'multiply 'add 'separator 'subtract 'decimal 'divide 'f1 'f2 'f3
+	  'f4 'f5 'f6 'f7 'f8 'f9 'f10 'f11 'f12 'f13 'f14 'f15 'f16 'f17
+	  'f18 'f19 'f20 'f21 'f22 'f23 'f24 'numlock 'scroll))
+
+  (define keystroke
+    (case-lambda
+     [(key) (keystroke key null)]
+     [(key modifier-list)
+      (cond
+	[(not (or (char? key) (memq key valid-key-symbols)))
+	 (error key-tag "expects char or valid key symbol, given: ~e" key)]
+	[(not (list? modifier-list))
+	 (error key-tag "expected a list as second argument, got: ~e" modifier-list)]
+	[(verify-list  modifier-list  legal-keystroke-modifiers)
+	 => (λ (mod) (error key-tag "unknown key modifier: ~e" mod))]
+	[else
+	 (run-one
+	  (λ ()
+	    (let ([window (get-focused-window)])
+	      (cond
+		[(not window)
+		 (error key-tag "no focused window")]
+		[(not (send window is-shown?))
+		 (error key-tag "focused window is not shown")]
+		[(not (send window is-enabled?))
+		 (error key-tag "focused window is not enabled")]
+		[(not (in-active-frame? window))
+		 (error key-tag "focused window is not in active frame")]
+		[else
+		 (let ([event (make-key-event key window modifier-list)])
+		   (send-key-event window event)
+		   (void))]))))])]))
+  
+  ;; delay test for on-char until all ancestors decline on-subwindow-char.
+  (define (send-key-event window event)
+    (let loop ([l (ancestor-list window #t)])
+      (cond [(null? l)
+	     (cond
+	      [(method-in-interface? 'on-char (object-interface window))
+	       (send window on-char event)]
+	      [(is-a? window text-field%)
+	       (send (send window get-editor) on-char event)]
+	      [else 
+	       (error
+		key-tag
+		"focused window is not a text-field% and does not have on-char")])]
+	    [(send (car l) on-subwindow-char window event) #f]
+	    [else (loop (cdr l))])))
+  
+  ;; Make full key-event% object.
+  ;; Shift is determined implicitly from key-code.
+  ;; Alt, Meta, Control come from modifier-list.
+  ;; get-alt-down, etc are #f unless explicitly set to #t.
+  ;; WILL WANT TO ADD SET-POSITION WHEN THAT GETS IMPLEMENTED.
+  
+  (define make-key-event
+    (λ (key window modifier-list)
+      (let ([event (make-object key-event%)])
+	(send event set-key-code key)
+	(send event set-time-stamp (time-stamp))
+	(set-key-modifiers event key modifier-list)
+	event)))
+  
+  (define set-key-modifiers
+    (λ (event key modifier-list)
+      (when (shifted? key) (send event set-shift-down #t))
+      (let loop ([l  modifier-list])
+	(unless (null? l)
+	  (let ([mod  (car l)])
+	    (cond
+	      [(eq? mod 'alt)        (send event set-alt-down     #t)]
+	      [(eq? mod 'control)    (send event set-control-down #t)]
+	      [(eq? mod 'meta)       (send event set-meta-down    #t)]
+	      [(eq? mod 'shift)      (send event set-shift-down   #t)]
+	      [(eq? mod 'noalt)      (send event set-alt-down     #f)]
+	      [(eq? mod 'nocontrol)  (send event set-control-down #f)]
+	      [(eq? mod 'nometa)     (send event set-meta-down    #f)]
+	      [(eq? mod 'noshift)    (send event set-shift-down   #f)]
+	      [else  (error key-tag "unknown key modifier: ~e" mod)])
+	    (loop (cdr l)))))))
+  
+  (define shifted?
+    (let* ([shifted-keys '(#\? #\: #\~ #\\ #\|
+			   #\< #\> #\{ #\} #\[ #\] #\( #\)
+			   #\! #\@ #\# #\$ #\% #\^ #\& #\* #\_ #\+
+			   #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M 
+			   #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z)])
+      (λ (key)
+	(memq shifted-keys shifted-keys))))
+    
+  ;;
+  ;; MENU ITEMS 
+  ;;
+  ;; Select menu item with: 
+  ;;   (send <frame> command <menu-item-id>)
+  ;; menu, item: strings
+  ;;
+  ;; DOESN'T HANDLE MENU CHECKBOXES YET.
+  ;;
+  
+  (define menu-tag 'test:menu-select)
+  
+  (define menu-select
+    (λ (menu-name . item-names)
+      (cond
+	[(not (string? menu-name))
+	 (error menu-tag "expects string, given: ~e" menu-name)]
+	[(not (andmap string? item-names))
+	 (error menu-tag "expects strings, given: ~e" item-names)]
+	[else
+	 (run-one
+	  (λ ()
+	    (let* ([frame (get-active-frame)]
+		   [item (get-menu-item frame (cons menu-name item-names))]
+		   [evt (make-object control-event% 'menu)])
+	      (send evt set-time-stamp (current-milliseconds))
+	      (send item command evt))))])))
+
+  (define get-menu-item
+    (λ (frame item-names)
+      (cond
+	[(not frame)
+	 (error menu-tag "no active frame")]
+	[(not (method-in-interface? 'get-menu-bar (object-interface frame)))
+	 (error menu-tag "active frame does not have menu bar")]
+	[else
+	 (let ([menu-bar  (send frame get-menu-bar)])
+	   (unless menu-bar
+	     (error menu-tag "active frame does not have menu bar"))
+	   (let* ([items (send menu-bar get-items)])
+	     (let loop ([items items]
+			[this-name (car item-names)]
+			[wanted-names (cdr item-names)])
+	       (cond
+                 [(null? items)
+                  (error 'menu-select "didn't find a menu: ~e, entire list: ~e" this-name item-names)]
+                 [else (let ([i (car items)])
+                         (cond
+                           [(not (is-a? i labelled-menu-item<%>))
+                            (loop (cdr items)
+                                  this-name
+                                  wanted-names)]
+                           [(string=? this-name (send i get-plain-label))
+                            (cond
+                              [(and (null? wanted-names)
+                                    (not (is-a? i menu-item-container<%>)))
+                               i]
+                              [(and (not (null? wanted-names))
+                                    (is-a? i menu-item-container<%>))
+                               (loop (send i get-items)
+                                     (car wanted-names)
+                                     (cdr wanted-names))]
+                              [else
+                               (error menu-tag "no menu matching ~e" item-names)])]
+                           [else
+                            (loop (cdr items)
+                                  this-name
+                                  wanted-names)]))]))))])))
+  
+  
+  ;;
+  ;; SIMPLE MOUSE EVENTS
+  ;;
+  ;; Simple left-click mouse in current canvas.
+  ;; Sends 3 mouse-events to canvas: motion, down, up.
+  ;;
+  ;; Give ancestors (from root down) option of handling mouse event
+  ;; with pre-on-event.  If none want it, then send to focused window
+  ;; with on-event.
+  ;;
+  ;; NEED TO EXPAND: DRAGGING, DOUBLE-CLICK, MOVING TO OTHER CANVASES,
+  ;; MODIFIER KEYS (SHIFT, META, CONTROL, ALT).
+  ;; 
+  
+  (define mouse-tag 'test:mouse-action)
+  (define legal-mouse-buttons (list 'left 'middle 'right))
+  (define legal-mouse-modifiers
+    (list 'alt 'control 'meta 'shift 'noalt 'nocontrol 'nometa 'noshift))
+  
+  (define mouse-click
+    (case-lambda
+     [(button x y) (mouse-click button x y null)]
+     [(button x y modifier-list)
+      (cond 
+	[(verify-item button legal-mouse-buttons)
+	 => (λ (button)
+	      (error mouse-tag "unknown mouse button: ~e" button))]
+	[(not (real? x))
+	 (error mouse-tag "expected real, given: ~e" x)]
+	[(not (real? y))
+	 (error mouse-tag "expected real, given: ~e" y)]
+	[(verify-list modifier-list legal-mouse-modifiers)
+	 => (λ (mod) 
+	      (error mouse-tag "unknown mouse modifier: ~e" mod))]
+	[else
+	 (run-one
+	  (λ ()
+	    (let ([window  (get-focused-window)])
+	      (cond 
+		[(not window)
+		 (error mouse-tag "no focused window")]
+		[(not (send window is-shown?))
+		 (error mouse-tag "focused window is not shown")]
+		[(not (send window is-enabled?))
+		 (error mouse-tag "focused window is not enabled")]
+		[(not (in-active-frame? window))
+		 (error mouse-tag "focused window is not in active frame")]
+		[else
+		 (let ([motion  (make-mouse-event 'motion x y modifier-list)]
+		       [down    (make-mouse-event (list button 'down) x y modifier-list)]
+		       [up      (make-mouse-event (list button 'up) x y modifier-list)])
+		   (send-mouse-event window motion)
+		   (send-mouse-event window down)
+		   (send-mouse-event window up)
+		   (void))]))))])]))
+	 
+    
+  ;; NEED TO MOVE THE CHECK FOR 'ON-EVENT TO HERE.
+  
+  (define send-mouse-event
+    (λ (window event)
+      (let loop ([l  (ancestor-list window #t)])
+	(cond
+	  [(null? l)
+	   (if (method-in-interface? 'on-event (object-interface window))
+	       (send window on-event event)
+	       (error mouse-tag "focused window does not have on-event"))]
+	  [(send (car l) on-subwindow-event window event)  #f]
+	  [else  (loop (cdr l))]))))
+  
+  ;;
+  ;; Make mouse event.
+  ;;
+  
+  (define make-mouse-event
+    (λ (type x y modifier-list)
+      (let ([event (make-object mouse-event% (mouse-type-const type))])
+	(when (and (pair? type) (not (eq? (cadr type) 'up)))
+	  (set-mouse-modifiers event (list (car type))))
+	(set-mouse-modifiers event modifier-list)
+	(send event set-x x)
+	(send event set-y y)
+	(send event set-time-stamp (time-stamp))
+	event)))
+  
+  (define set-mouse-modifiers
+    (λ (event modifier-list)
+      (unless (null? modifier-list)
+	(let ([mod  (car modifier-list)])
+	  (cond
+	    [(eq? mod 'alt)        (send event set-alt-down     #t)]
+	    [(eq? mod 'control)    (send event set-control-down #t)]
+	    [(eq? mod 'meta)       (send event set-meta-down    #t)]
+	    [(eq? mod 'shift)      (send event set-shift-down   #t)]
+	    [(eq? mod 'left)       (send event set-left-down    #t)]
+	    [(eq? mod 'middle)     (send event set-middle-down  #t)]
+	    [(eq? mod 'right)      (send event set-right-down   #t)]
+	    [(eq? mod 'noalt)      (send event set-alt-down     #f)]
+	    [(eq? mod 'nocontrol)  (send event set-control-down #f)]
+	    [(eq? mod 'nometa)     (send event set-meta-down    #f)]
+	    [(eq? mod 'noshift)    (send event set-shift-down   #f)]
+	    [else  (error mouse-tag "unknown mouse modifier: ~e" mod)]))
+	(set-mouse-modifiers event (cdr modifier-list)))))
+      
+  (define mouse-type-const
+    (λ (type)
+      (cond
+	[(symbol? type)
+	 (cond
+	   [(eq? type 'motion)  'motion]
+	   [(eq? type 'enter)   'enter]
+	   [(eq? type 'leave)   'leave]
+	   [else  (bad-mouse-type type)])]
+	[(and (pair? type) (pair? (cdr type)))
+	 (let ([button (car type)] [action (cadr type)])
+	   (cond
+	     [(eq? button 'left)
+	      (cond 
+		[(eq? action 'down)    'left-down]
+		[(eq? action 'up)      'left-up]
+		[(eq? action 'dclick)  'left-dclick]
+		[else  (bad-mouse-type type)])]
+	     [(eq? button 'middle)
+	      (cond
+		[(eq? action 'down)    'middle-down]
+		[(eq? action 'up)      'middle-up]
+		[(eq? action 'dclick)  'middle-dclick]
+		[else  (bad-mouse-type type)])]
+	     [(eq? button 'right)
+	      (cond
+		[(eq? action 'down)    'right-down]
+		[(eq? action 'up)      'right-up]
+		[(eq? action 'dclick)  'right-dclick]
+		[else  (bad-mouse-type type)])]
+	     [else  (bad-mouse-type type)]))]
+	[else  (bad-mouse-type type)])))
+  
+  (define bad-mouse-type
+    (λ (type)
+      (error mouse-tag "unknown mouse event type: ~e" type)))
+  
+  ;;
+  ;; Move mouse to new window.
+  ;; Implement with three events:
+  ;; leave old window, show top-level frame, enter new window, focus.
+  ;;
+  ;; NEED TO CLEAN UP ACTIONS FOR MOVING TO NEW FRAME.
+  ;;
+  
+  (define new-window
+    (let ([tag  'test:new-window])
+      (λ (new-window)
+	(cond
+	  [(not (is-a? new-window window<%>))
+	   (error tag "new-window is not a window<%>")]
+	  [else
+	   (run-one
+	    (λ ()
+	      (let
+		  ([old-window  (get-focused-window)]
+		   [leave   (make-object mouse-event% 'leave)]
+		   [enter   (make-object mouse-event% 'enter)]
+		   [root    (car (ancestor-list new-window #t))])
+		(send leave  set-x 0)   (send leave  set-y 0)
+		(send enter  set-x 0)   (send enter  set-y 0)
+		
+		;; SOME KLUDGES HERE TO WORK AROUND TEXT% PROBLEMS.
+		
+		(when (and old-window (method-in-interface? 'on-event (object-interface old-window)))
+		  (send-mouse-event old-window leave))
+		(send root show #t)
+		(when (method-in-interface? 'on-event (object-interface new-window))
+		  (send-mouse-event new-window enter))
+		(send new-window focus)
+		(void))))]))))
+
+  (define (close-top-level-window tlw)
+    (when (send tlw can-close?)
+      (send tlw on-close)
+      (send tlw show #f)))
+  
+  ;; manual renaming
+  (define test:run-interval run-interval)
+  (define test:number-pending-actions number-pending-actions)
+  (define test:reraise-error reraise-error)
+  (define test:run-one run-one)
+  (define test:current-get-eventspaces current-get-eventspaces)
+  (define test:close-top-level-window close-top-level-window)
+  (define test:button-push button-push)
+  (define test:set-radio-box! set-radio-box!)
+  (define test:set-radio-box-item! set-radio-box-item!)
+  (define test:set-check-box! set-check-box!)
+  (define test:set-choice! set-choice!)
+  (define test:keystroke keystroke)
+  (define test:menu-select menu-select)
+  (define test:mouse-click mouse-click)
+  (define test:new-window new-window))
diff --git a/collects/frtime/README b/collects/frtime/README
new file mode 100644
index 0000000000..fa1280d7c0
--- /dev/null
+++ b/collects/frtime/README
@@ -0,0 +1,67 @@
+
+This directory contains the source code for FrTime.
+
+To run the animation/GUI demos, simply set the language level to
+FrTime, open the corresponding file, and Execute.  See the demo source
+code for more information.
+
+orbit-mouse.ss : A collection of balls that move in circles around
+the mouse pointer.
+
+piston.ss : Simulation of a piston/cylinder.
+
+rotation.ss : Balls moving in circles.
+
+delay-mouse.ss : A trail of balls following the mouse.
+
+ball-on-string.ss : A ball chasing the mouse.
+
+pong.ss : A simple pong/air-hockey game.  The left paddle moves with
+numeric keypad; the right paddle moves with the mouse.  The 'r' key
+resets the score.
+
+net-pong-*.ss : A networked version of the pong/air-hockey game.
+Currently known to work under Linux.  To play, open the client on one
+machine and the server on another.  Execute both (and require if
+necessary, depending on language level).  Evaluate (self) on each.
+Results will be something like:
+
+[client]
+> (self)
+#3(tid 128.148.38.2:1180 main)
+
+and
+[server]
+> (self)
+#3(tid 128.148.33.71:1178 main)
+
+Now tell each machine about the other:
+[client]
+> (set-cell! server (make-tid '128.148.33.71 1178 'frtime-heart))
+
+[server]
+> (set-cell! client (make-tid '128.148.38.2 1180 'frtime-heart))
+
+Note the differences between the #3(tid ...) output and the (make-tid ...)
+commands---there is no colon (:) between the host and port, and main becomes
+'frtime-heart.
+
+After setting the cells, complete the connection by clicking the left
+mouse button in both animation windows.  The player running the server
+can reset the score by pressing 'r'.
+
+pizza.ss : A simple "pizza ordering" user interface based on an HtDP
+exercise.
+
+calculator.ss : A simple calculator interface, also based on an HtDP
+exercise except that the result updates continuously as the arguments
+and operator change.
+
+Robb Cutler's Examples
+
+analog-clock.ss : An animated real-time clock.  A slider adjusts the radius
+of the face.  Click and drag to move the face around.
+
+growing-points.ss : A field of points that grow as the mouse approaches.
+
+needles.ss : A field of needles that point at the mouse.
diff --git a/collects/frtime/animation.ss b/collects/frtime/animation.ss
new file mode 100644
index 0000000000..44c2081cf4
--- /dev/null
+++ b/collects/frtime/animation.ss
@@ -0,0 +1,297 @@
+(module animation (lib "frtime.ss" "frtime")
+  
+  (require (all-except "graphics.ss" make-posn posn-x posn-y make-rgb)
+           (lifted "graphics.ss" posn-x posn-y make-posn make-rgb)
+           (all-except (lib "match.ss") match)
+           (lib "class.ss")
+           (lib "list.ss" "frtime")
+           (lib "etc.ss" "frtime")
+           (lib "math.ss" "frtime"))
+  
+  (open-graphics)
+  
+  (define fresh-anim
+    (let ([first #t])
+      (opt-lambda ([x 400] [y 400] [title "Animation - DrScheme"])
+        (if first
+            (set! first #f)
+            (begin
+              (set! window
+                    (open-viewport title x y))
+              
+              (set! pixmap
+                    (open-pixmap "" x y))
+              
+              (set! mouse-pos
+                    (hold ((viewport-mouse-events window)
+                           . ==> . 
+                           (lambda (ev) (make-posn
+                                         (send ev get-x)
+                                         (send ev get-y))))
+                          (query-mouse-posn window)))
+              
+              (set! key-strokes ((viewport-key-events window) . ==> . sixkey-value))
+              
+              (set! left-clicks ((viewport-mouse-events window) . =#> . (lambda (ev) (send ev button-down? 'left))))
+              (set! middle-clicks ((viewport-mouse-events window) . =#> . (lambda (ev) (send ev button-down? 'middle))))
+              (set! right-clicks ((viewport-mouse-events window) . =#> . (lambda (ev) (send ev button-down? 'right)))))))))
+    
+  (define window
+    (open-viewport "Animation - DrScheme" 400 400))
+  
+  (define pixmap
+    (open-pixmap "" 400 400))
+  
+  (define mouse-pos
+    (hold ((viewport-mouse-events window)
+           . =#=> . 
+           (lambda (ev) (if (send ev moving?)
+                            (make-posn
+                             (send ev get-x)
+                             (send ev get-y))
+                            nothing)))
+          (query-mouse-posn window)))
+  
+  (define filtered-keys (viewport-key-events window))
+  (define shift-down (hold (filtered-keys . ==> . sixkey-shift)))
+  (define control-down (hold (filtered-keys . ==> . sixkey-control)))
+  (define meta-down (hold (filtered-keys . ==> . sixkey-meta)))
+  (define alt-down (hold (filtered-keys . ==> . sixkey-alt)))
+  (define key-strokes ((viewport-key-events window) . ==> . sixkey-value))
+  (define left-clicks ((viewport-mouse-events window) . =#> . (lambda (ev) (send ev button-down? 'left))))
+  (define middle-clicks ((viewport-mouse-events window) . =#> . (lambda (ev) (send ev button-down? 'middle))))
+  (define right-clicks ((viewport-mouse-events window) . =#> . (lambda (ev) (send ev button-down? 'right))))
+  (define left-releases ((viewport-mouse-events window) . =#> . (lambda (ev) (send ev button-up? 'left))))
+  (define middle-releases ((viewport-mouse-events window) . =#> . (lambda (ev) (send ev button-up? 'middle))))
+  (define right-releases ((viewport-mouse-events window) . =#> . (lambda (ev) (send ev button-up? 'right))))
+  
+  (define-struct ring (center radius color))
+  (define-struct solid-ellipse (ul w h color))
+  (define-struct graph-string (pos text color))
+  (define-struct line (p1 p2 color))
+  (define-struct rect (ul w h color))
+  (define-struct rrect (ur w h color))
+  (define-struct curve (xmin xmax ymin ymax fn))
+  (define-struct polygon (posn-list posn color))
+  
+  (define (make-circle center r color)
+    (make-solid-ellipse (make-posn (- (posn-x center) r)
+                                   (- (posn-y center) r))
+                                   (* 2 r) (* 2 r) color))
+  
+  (define l (new-cell empty))
+  
+  (define (display-shapes x)
+    (set-cell! l x))
+  
+  (define (top-level-draw-list a-los)
+    ((clear-viewport pixmap))
+    (draw-list a-los)
+    (copy-viewport pixmap window))
+  
+  (define (draw-list a-los)
+    (for-each
+     (match-lambda
+       [(? undefined?) (void)]
+       [($ ring center radius color)
+        ((draw-ellipse pixmap)
+         (make-posn (- (posn-x center) radius)
+                    (- (posn-y center) radius))
+         (* 2 radius)
+         (* 2 radius)
+         color)]
+       [($ solid-ellipse ul w h color)
+        ((draw-solid-ellipse pixmap) ul w h color)]
+       [($ graph-string pos text color) ((draw-string pixmap) pos text color)]
+       [($ line p1 p2 color) ((draw-line pixmap) p1 p2 color)]
+       [($ rect ul w h color)
+        (cond
+          [(and (>= w 0) (>= h 0)) ((draw-solid-rectangle pixmap) ul w h color)]
+          [(>= h 0) ((draw-solid-rectangle pixmap) (make-posn (+ (posn-x ul) w) (posn-y ul)) (- w) h color)]
+          [(>= w 0) ((draw-solid-rectangle pixmap) (make-posn (posn-x ul) (+ (posn-y ul) h)) w (- h) color)]
+          [else ((draw-solid-rectangle pixmap) (make-posn (+ (posn-x ul) w) (+ (posn-y ul) h)) (- w) (- h) color)])]
+       [($ polygon pts offset color) ((draw-solid-polygon pixmap) pts offset color)]
+       [(? list? x) (draw-list x)]
+       [(? void?) (void)])
+     a-los))
+  
+  (define d (lift #t top-level-draw-list l))
+  
+  (define-struct graph-color (fn xmin xmax ymin ymax))
+  
+  (define (draw-graph-color pm gc)
+    (let ([dp (draw-pixel pm)])
+      (match gc
+        [($ graph-color fn xmin xmax ymin ymax)
+         (let ([xincr (/ (- xmax xmin) 300)]
+               [yincr (/ (- ymax ymin) 300)])
+           (let loop ([i 50] [y ymin])
+             (let loop ([j 50] [x xmin])
+               (dp (make-posn j i) (fn x y))
+               (when (< j 350)
+                 (loop (add1 j) (+ x xincr))))
+             (when (< i 350)
+               (loop (add1 i) (+ y yincr)))))])))
+  
+  (define (valid-posn? v)
+    (and (posn? v) (number? (posn-x v)) (number? (posn-y v))))
+  
+  (define seconds~ (/ time-b 1000.0))
+  
+  (define (key sym)
+    (key-strokes
+     . =#> .
+     (lambda (x) (eq? x (value-now sym)))))
+  
+  (define (draw vp pm posl)
+    ((clear-viewport pm))
+    (for-each (lambda (elt)
+                 (cond
+                   [(graph-color? elt) (draw-graph-color pm elt)]
+                   [(string? elt) ((draw-string pm) (make-posn 8 20) elt)]
+                   [(valid-posn? elt) ((draw-solid-ellipse pm)
+                                       (make-posn (- (posn-x elt) 10)
+                                                  (- (posn-y elt) 10))
+                                       20 20
+                                       (make-rgb 0 .6 .6))]
+                   [(and (cons? elt)
+                         (valid-posn? (first elt))
+                         (valid-posn? (rest elt))) ((draw-line pm)
+                                                    (first elt)
+                                                    (rest elt)
+                                                    "black")]
+                   [else (void)])) posl)
+    (copy-viewport pm vp))
+
+  #|
+  (define foldl
+    (case-lambda
+      [(f i l) (if (cons? l)
+                   (foldl f (f (first l) i) (rest l))
+                   i)]))
+  |#
+  
+  (define (drop n l)
+    (if (empty? l)
+        empty
+        (if (<= n 0)
+            l
+            (drop (sub1 n) (rest l)))))
+  
+  (define (inc-max n)
+    (lambda (x) (if (>= x n)
+                    n
+                    (add1 x))))
+  
+  (define (dec-min n)
+    (lambda (x) (if (<= x n)
+                    n
+                    (sub1 x))))
+  
+  (define (fix-rgb r g b)
+    (let ([fix (lambda (n) (min 1 (max 0 n)))])
+      (apply make-rgb (map fix (list r g b)))))
+
+  (define range-control
+    (opt-lambda (up down limit [init 0])
+      (accum-b
+       (merge-e (up   . -=> . (inc-max limit))
+                (down . -=> . (dec-min 0)))
+       init)))
+  
+  (define (keyboard-control up down limit)
+    (accum-b
+     (key-strokes
+      . =#=> .
+      (match-lambda
+        [(? (lambda (x) (eq? x up))) (inc-max limit)]
+        [(? (lambda (x) (eq? x down))) (dec-min 0)]
+        [_ nothing]))
+     0))
+  
+  (define-struct wave-state (hz offset))
+  
+  (define (wave hz)
+    (let* ([state (collect-b
+                   (snapshot-e (changes hz) time-b)
+                   (make-wave-state (value-now hz) 0)
+                   (lambda (new-freq+time old-state)
+                     (match new-freq+time
+                       [(h1 t)
+                        (match old-state
+                          [($ wave-state h0 o0)
+                           (make-wave-state
+                            h1
+                            (+ o0 (* .002 pi t (- h0 h1))))])])))])
+      (+ (lift #f wave-state-offset state)
+         (* time-b pi (lift #f wave-state-hz state) .002))))
+  
+  (define (current-and-last-value signal)
+    (let ([init (value-now signal)])
+      (collect-b (changes signal)
+                 (list init init)
+                 (lambda (new-value previous-two)
+                   (list new-value (first previous-two))))))
+  
+  (define (last-value signal)
+    (second (current-and-last-value signal)))
+  
+;   (define (last-value signal)
+;    (let ([init (value-now signal)])
+;      (rest
+;       (collect-b (changes signal)
+;                  (cons init init)
+;                  (lambda (new old-pair)
+;                    (cons new (first old-pair)))))))
+                 
+  (define (posn+ . args)
+    (make-posn (apply + (map posn-x args))
+               (apply + (map posn-y args))))
+  
+  (define (posn- . args)
+    (make-posn (apply - (map posn-x args))
+               (apply - (map posn-y args))))
+  
+  (define (posn/ p s)
+    (make-posn (/ (posn-x p) s)
+               (/ (posn-y p) s)))
+  
+  (define (posn* p s)
+    (make-posn (* (posn-x p) s)
+               (* (posn-y p) s)))
+  
+  (define (posn-dot p1 p2)
+    (+ (* (posn-x p1) (posn-x p2))
+       (* (posn-y p1) (posn-y p2))))
+  
+  (define (posn-len p)
+    (sqrt (+ (sqr (posn-x p)) (sqr (posn-y p)))))
+  
+  (define (normalize p)
+    (posn/ p (posn-len p)))
+  
+  (define (current-mouse-pos)
+    (value-now mouse-pos))
+  
+  (define (clip x lo hi)
+    (if (< x lo)
+        lo
+        (if (> x hi)
+            hi
+            x)))
+  
+  (define (posn-diff p1 p2)
+    (sqrt (+ (sqr (- (posn-x p1) (posn-x p2)))
+             (sqr (- (posn-y p1) (posn-y p2))))))
+
+  (define (posn-derivative p)
+    (make-posn (derivative (posn-x p)) (derivative (posn-y p))))
+  
+  (define (posn-integral p)
+    (make-posn (integral (posn-x p)) (integral (posn-y p))))
+  
+  (provide
+   (all-defined-except pixmap window draw-list l d make-circle make-ring make-solid-ellipse
+                       make-rect make-line make-polygon make-graph-string make-wave-state wave-state-hz wave-state-offset)
+   (lifted make-circle make-ring make-solid-ellipse make-rect make-line make-polygon make-graph-string)
+   (all-from "graphics.ss")))
diff --git a/collects/frtime/base-gm.ss b/collects/frtime/base-gm.ss
new file mode 100644
index 0000000000..b1b9e59d3a
--- /dev/null
+++ b/collects/frtime/base-gm.ss
@@ -0,0 +1,213 @@
+(module base-gm mzscheme
+  (require (lib "list.ss")
+	   (lib  "etc.ss"))
+  
+  (provide cons-to-end
+	   assoc-get
+	   debug
+	   make-debug
+	   to-string
+	   member-eq?	   
+	   string->char
+	   last
+	   member-str?
+	   quicksort-vector!
+	   for
+	   for-vector
+	   but-last
+	   halt
+	   prog1
+	   struct->list
+           for-list
+
+	   make-hash
+	   hash-get
+	   hash-put!
+	   hash-remove!
+	   hash-map
+	   hash-for-each
+	   hash-mem?
+
+	   (all-from (lib "list.ss"))
+	   (all-from (lib "etc.ss")))
+  
+  (define-syntax prog1
+    (syntax-rules
+	() 
+      {(prog1 arg1 args ...)
+       (let ((v arg1))
+	 args ...
+	 v)}))
+  
+  (define-syntax halt
+    (syntax-rules
+	()
+      [(halt arg ...)
+       (begin
+	 (debug "There was a problem with " arg ...)
+	 (error "Error."))]))  
+  
+;;;(define (halt . args)
+;;;  (apply error
+;;;	 (list (string-append
+;;;		"Error: "
+;;;		(foldl string-append "" (reverse (map to-string args)))))))
+  
+  (define (but-last ls)
+    (cond
+     ((empty? ls) (error "incorrect list to butlast"))
+     ((empty? (rest ls)) empty)
+     (else (cons (first ls) (but-last (rest ls))))))
+  
+  (define-syntax for
+    (syntax-rules
+	()
+      [(for x start stop body ...)
+       (let ((x start))
+	 (letrec ((loop
+		   (lambda ()
+		     (if (> x stop)
+			 'done
+			 (begin
+			   body ...
+			   (set! x (+ x 1))
+			   (loop))))))
+	   (loop)))]))
+  
+  (define-syntax for-vector
+    (syntax-rules
+	(with)
+      [(for-vector v with x body ...)
+       (for x 0 (- (vector-length v) 1)
+	    body ...)]))
+
+  (define-syntax for-list
+    (syntax-rules
+     (with)
+     [(for-list ls with x body ...)
+      (let ((x 'dummy))
+        (letrec ((loop
+                  (lambda (param)
+                    (if (empty? param)
+                        'done
+                        (begin
+                          (set! x (car param))
+                          body ...
+                          (loop (rest param)))))))
+          (loop ls)))]))
+
+  (define (quicksort-vector! v less-than)
+    (let ([count (vector-length v)])
+      (let loop ([min 0][max count])
+	(if (< min (sub1 max))
+	    (let ([pval (vector-ref v min)])
+	      (let pivot-loop ([pivot min]
+			       [pos (add1 min)])
+		(if (< pos max)
+		    (let ([cval (vector-ref v pos)])
+		      (if (less-than cval pval)
+			  (begin
+			    (vector-set! v pos (vector-ref v pivot))
+			    (vector-set! v pivot cval)
+			    (pivot-loop (add1 pivot) (add1 pos)))
+			  (pivot-loop pivot (add1 pos))))
+		    (if (= min pivot)
+			(loop (add1 pivot) max)
+			(begin
+			  (loop min pivot)
+			  (loop pivot max)))))))))
+    v)
+  
+  
+  
+  
+  
+  (define (member-str? s ls)
+    (cond
+     ((empty? ls) false)
+     ((string=? s (first ls)) true)
+     (else (member-str? s (rest ls)))))
+  
+  (define (last ls)
+    (cond
+     ((empty? ls) (error "took a last but it was emptry"))
+     ((empty? (rest ls)) (first ls))
+     (else (last (rest ls)))))
+  
+  (define (string->char s)
+    (first (string->list s)))
+  
+  (define (member-eq? x ls)
+    (not (empty? (filter (lambda (y) (eq? x y)) ls))))
+  
+  (define (to-string arg . fns)
+    (let loop ((arg arg))
+      (cond
+       ((not arg) "#f")
+       ((void? arg) "#<void>")
+       ((eq? arg #t) "#t")
+       ((char? arg) (list->string (list arg)))
+       ((string? arg) arg)
+       ((symbol? arg) (symbol->string arg))
+       ((number? arg) (number->string arg))
+       ((vector? arg) (loop (vector->list arg)))
+       ((empty? arg) "empty")
+       ((list? arg) (string-append
+		     "("
+		     (loop (first arg))
+		     (foldr string-append "" 
+			    (map (lambda (x)
+				   (string-append " "
+						  (loop x))) (rest arg)))
+		     ")"))
+       ((cons? arg) (string-append
+		     "("
+		     (loop (first arg))
+		     " . "
+		     (loop (rest arg))
+		     ")"))
+       
+       (true (let loop ((cur fns))
+	       (if (empty? cur) (halt "to-string: " arg)
+		   (or ((first cur) arg) 
+		       (loop (rest cur)))))))))
+    
+
+  (define (debug . args)
+    (for-each display args)
+    (newline))
+
+  (define (make-debug . fns)
+    (lambda args (for-each (lambda (x) (display (apply to-string (cons x fns)))
+				   (display " ")) args)
+	    (newline)))
+
+  (define (assoc-get label ls)
+    (cond
+     ((empty? ls) (error (string-append "failed to find " (to-string label))))
+     ((eq? label (first (first ls)))
+      (first ls))
+     (else (assoc-get label (rest ls)))))
+  
+  (define (cons-to-end a ls)
+    (cond
+     ((empty? ls) (cons a ls))
+     (else (cons (first ls)
+		 (cons-to-end a (rest ls))))))
+  
+  (define (struct->list itm)
+    (cond [(struct? itm) (map struct->list (vector->list (struct->vector itm)))]
+	  [(list? itm)   (map struct->list itm)]
+	  [else itm]))
+
+  (define (struct-name s) (vector-ref (struct->vector s) 0))
+
+  
+  (define make-hash make-hash-table)
+  (define hash-get hash-table-get)
+  (define hash-put! hash-table-put!)
+  (define hash-remove! hash-table-remove!)
+  (define hash-map hash-table-map)
+  (define hash-for-each hash-table-for-each)
+  (define (hash-mem? hash item) (hash-get hash item (lambda () false)))
+)
\ No newline at end of file
diff --git a/collects/frtime/clock.png b/collects/frtime/clock.png
new file mode 100644
index 0000000000..96c583338c
Binary files /dev/null and b/collects/frtime/clock.png differ
diff --git a/collects/frtime/date.ss b/collects/frtime/date.ss
new file mode 100644
index 0000000000..ad2cb22734
--- /dev/null
+++ b/collects/frtime/date.ss
@@ -0,0 +1,392 @@
+
+(module date mzscheme
+
+  (require (lib "list.ss")
+           (rename "frtime.ss" frtime:provide provide))
+
+  (frtime:provide
+   (lifted date->string
+           date-display-format
+           find-seconds
+           
+           date->julian/scalinger
+           julian/scalinger->string))
+
+
+  ;; Support for Julian calendar added by Shriram;
+  ;; current version only works until 2099 CE Gregorian
+
+  #|
+
+  (define-primitive seconds->date (num -> structure:date))
+  (define-primitive current-seconds (-> num))
+  (define-primitive date-second (structure:date -> num))
+  (define-primitive date-minute (structure:date -> num))
+  (define-primitive date-hour (structure:date -> num))
+  (define-primitive date-day (structure:date -> num))
+  (define-primitive date-month (structure:date -> num))
+  (define-primitive date-year (structure:date -> num))
+  (define-primitive date-week-day (structure:date -> num))
+  (define-primitive date-year-day (structure:date -> num))
+  (define-primitive date-dst? (structure:date -> bool))
+  (define-primitive make-date (num num num num num num num num bool ->
+				   structure:date))
+  (define-primitive expr->string (a -> string))
+  (define-primitive foldl (case->
+			   ((a z -> z) z (listof a) -> z)
+			   ((a b z -> z) z (listof a) (listof b) -> z)
+			   ((a b c z -> z) z (listof a) (listof b) (listof c) -> z)
+			   (((arglistof x) ->* z) z (listof (arglistof x)) ->* z)))
+  (define-primitive foldr (case->
+			   ((a z -> z) z (listof a) -> z)
+			   ((a b z -> z) z (listof a) (listof b) -> z)
+			   ((a b c z -> z) z (listof a) (listof b) (listof c) -> z)
+			   (((arglistof x) ->* z) z (listof (arglistof x)) ->* z)))
+
+  |#
+
+  (define legal-formats
+    (list 'american 'chinese 'german 'indian 'irish 'julian 'iso-8601 'rfc2822))
+
+  (define date-display-format 
+    (make-parameter 'american
+		    (lambda (s)
+		      (unless (memq s legal-formats)
+			(raise-type-error 'date-display-format
+					  (format "symbol in ~a" legal-formats)
+					  s))
+		      s)))
+
+  (define month/number->string
+    (lambda (x)
+      (case x
+	[(12) "December"] [(1) "January"]  [(2) "February"]
+	[(3) "March"]     [(4) "April"]    [(5) "May"]
+	[(6) "June"]      [(7) "July"]     [(8) "August"]
+	[(9) "September"] [(10) "October"] [(11) "November"]
+	[else ""])))
+  
+  (define day/number->string
+    (lambda (x)
+      (case x
+	[(0) "Sunday"]
+	[(1) "Monday"]
+	[(2) "Tuesday"]
+	[(3) "Wednesday"]
+	[(4) "Thursday"]
+	[(5) "Friday"]
+	[(6) "Saturday"]
+	[else ""])))
+
+  (define date->string
+    (case-lambda 
+     [(date) (date->string date #f)]
+     [(date time?)
+      (let* ((add-zero (lambda (n) (if (< n 10)
+				       (string-append "0" (number->string n))
+				       (number->string n))))
+	     (year (number->string (date-year date)))
+	     (num-month (number->string (date-month date)))
+	     (week-day (day/number->string (date-week-day date)))
+	     (week-day-num (date-week-day date))
+	     (month (month/number->string (date-month date)))
+	     (day (number->string (date-day date)))
+	     (day-th (if (<= 11 (date-day date) 13)
+			 "th"
+			 (case (modulo (date-day date) 10)
+			   [(1) "st"]
+			   [(2) "nd"]
+			   [(3) "rd"]
+			   [(0 4 5 6 7 8 9) "th"])))
+	     (hour (date-hour date))
+	     (am-pm (if (>= hour 12) "pm" "am"))
+	     (hour24 (add-zero hour))
+	     (hour12 (number->string 
+		      (cond
+		       [(zero? hour) 12]
+		       [(> hour 12) (- hour 12)]
+		       [else hour])))
+	     (minute (add-zero (date-minute date)))
+	     (second (add-zero (date-second date))))
+	(let-values
+	    ([(day time)
+	      (case (date-display-format)
+		[(american) 
+		 (values (list week-day ", " month " " day day-th ", " year)
+			 (list " " hour12 ":" minute ":" second am-pm))]
+		[(chinese)
+		 (values
+		  (list year "/" num-month "/" day
+			" libai" (case (date-week-day date)
+				   [(0) "tian"]
+				   [(1) "yi"]
+				   [(2) "er"]
+				   [(3) "san"]
+				   [(4) "si"]
+				   [(5) "wu"]
+				   [(6) "liu"]
+				   [else ""]))
+		  (list " " hour24 ":" minute ":" second))]
+		[(indian) 
+		 (values (list day "-" num-month "-" year)
+			 (list " " hour12 ":" minute ":" second am-pm))]
+		[(german) 
+		 (values (list day ". " 
+                                (case (date-month date)
+                                  [(1) "Januar"]
+                                  [(2) "Februar"]
+                                  [(3) "M\344rz"]
+                                  [(4) "April"]
+                                  [(5) "Mai"]
+                                  [(6) "Juni"]
+                                  [(7) "Juli"]
+                                  [(8) "August"]
+                                  [(9) "September"]
+                                  [(10) "Oktober"]
+                                  [(11) "November"]
+                                  [(12) "Dezember"]
+                                  [else ""])
+                                " " year)
+			 (list ", " hour24 "." minute))]
+		[(irish) 
+		 (values (list week-day ", " day day-th " " month " " year)
+			 (list ", " hour12 ":" minute am-pm))]
+		[(julian)
+		 (values (list (julian/scalinger->string
+				(date->julian/scalinger date)))
+			 (list ", " hour24 ":" minute ":" second))]
+		[(iso-8601)
+		 (values
+		  (list year "-" (add-zero (date-month date)) "-" (add-zero (date-day date)))
+		  (list " " hour24 ":" minute ":" second))]
+		[(rfc2822)
+		 (values
+		  (list (substring week-day 0 3) ", " day " " (substring month 0 3) " " year)
+		  (list* " " hour24 ":" minute ":" second " "
+			 (let* ([delta (date-time-zone-offset date)]
+				[hours (quotient delta 3600)]
+				[minutes (modulo (quotient delta 60) 60)])
+			   (list
+			    (if (negative? delta) "-" "")
+			    (add-zero (abs hours))
+			    (add-zero minutes)))))]
+		[else (error 'date->string "unknown date-display-format: ~s"
+			     (date-display-format))])])
+	  (apply string-append (if time?
+				   (append day time)
+				   day))))]))
+  
+  (define leap-year?
+    (lambda (year)
+      (or (= 0 (modulo year 400))
+	  (and (= 0 (modulo year 4))
+	       (not (= 0 (modulo year 100)))))))
+
+  ;; it's not clear what months mean in this context -- use days
+  (define-struct date-offset (second minute hour day year))
+
+  (define date-
+    (lambda (date1 date2)
+      (let* ((second (- (date-second date1) (date-second date2)))
+	     (minute (+ (- (date-minute date1) (date-minute date2))
+			(if (< second 0) -1 0)))
+	     (hour (+ (- (date-hour date1) (date-hour date2))
+		      (if (< minute 0) -1 0)
+		      (cond [(equal? (date-dst? date1) (date-dst? date2)) 0]
+			    [(date-dst? date1) -1]
+			    [(date-dst? date2) 1])))
+	     (day (+ (- (date-year-day date1) (date-year-day date2))
+		     (if (< hour 0) -1 0)))
+	     (year (+ (- (date-year date1) (date-year date2))
+		      (if (< day 0) -1 0)))
+	     (fixup (lambda (s x) (if (< s 0) (+ s x) s))))
+	(make-date-offset (fixup second 60)
+			  (fixup minute 60)
+			  (fixup hour 24)
+			  (fixup day (if (leap-year? (date-year date1)) 366 365))
+			  year))))
+
+
+  (define date-offset->string
+    (let ((first car)
+	  (second cadr))
+      (case-lambda 
+       [(date) (date-offset->string date #f)]
+       [(date seconds?)
+	(let* ((fields (list (list (date-offset-year date) "year")
+			     (list (date-offset-day date) "day")
+			     (list (date-offset-hour date) "hour")
+			     (list (date-offset-minute date) "minute")
+			     (list (if seconds? (date-offset-second date) 0) "second")))
+	       (non-zero-fields (foldl (lambda (x l)
+					 (if (= 0 (first x))
+					     l
+					     (cons x l)))
+				       null
+				       fields))
+	       (one-entry (lambda (b)
+			    (string-append
+			     (number->string (first b))
+			     " "
+			     (second b)
+			     (if (= 1 (first b)) "" "s")))))
+	  (cond
+	   [(null? non-zero-fields) ""]
+	   [(null? (cdr non-zero-fields)) (one-entry (car non-zero-fields))]
+	   [else (foldl (lambda (b string)
+			  (cond
+			   [(= 0 (first b)) string]
+			   [(string=? string "")
+			    (string-append "and "
+					   (one-entry b)
+					   string)]
+			   [else (string-append (one-entry b) ", " string)]))
+			""
+			non-zero-fields)]))])))
+
+  (define days-per-month
+    (lambda (year month)
+      (cond
+       [(and (= month 2) (leap-year? year)) 29]
+       [(= month 2) 28]
+       [(<= month 7) (+ 30 (modulo month 2))]
+       [else (+ 30 (- 1 (modulo month 2)))])))
+
+  (define find-extreme-date-seconds
+    (lambda (start offset)
+      (let/ec found
+	(letrec ([find-between
+		  (lambda (lo hi)
+		    (let ([mid (floor (/ (+ lo hi) 2))])
+		      (if (or (and (positive? offset) (= lo mid))
+			      (and (negative? offset) (= hi mid)))
+			  (found lo)
+			  (let ([mid-ok?
+				 (with-handlers ([exn:fail? (lambda (exn) #f)])
+				   (seconds->date mid)
+				   #t)])
+			    (if mid-ok?
+				(find-between mid hi)
+				(find-between lo mid))))))])
+	  (let loop ([lo start][offset offset])
+	    (let ([hi (+ lo offset)])
+	      (with-handlers ([exn:fail? 
+			       (lambda (exn) 
+					; failed - must be between lo & hi
+				 (find-between lo hi))])
+		(seconds->date hi))
+					; succeeded; double offset again
+	      (loop hi (* 2 offset))))))))
+
+  (define get-min-seconds
+    (let ([d (delay (find-extreme-date-seconds (current-seconds) -1))])
+      (lambda ()
+	(force d))))
+  (define get-max-seconds
+    (let ([d (delay (find-extreme-date-seconds (current-seconds) 1))])
+      (lambda ()
+	(force d))))
+
+  (define find-seconds
+    (lambda (sec min hour day month year)
+      (let ([signal-error
+	     (lambda (msg)
+	       (error 'find-secs (string-append 
+				  msg 
+				  " (inputs: ~a ~a ~a ~a ~a ~a)")
+		      sec min hour day month year))])
+	(let loop ([below-secs (get-min-seconds)]
+		   [secs (floor (/ (+ (get-min-seconds) (get-max-seconds)) 2))]
+		   [above-secs (get-max-seconds)])
+	  (let* ([date (seconds->date secs)]
+		 [compare
+		  (let loop ([inputs (list year month day 
+					   hour min sec)]
+			     [tests (list (date-year date)
+					  (date-month date)
+					  (date-day date)
+					  (date-hour date)
+					  (date-minute date)
+					  (date-second date))])
+		    (cond
+		     [(null? inputs) 'equal]
+		     [else (let ([input (car inputs)]
+				 [test (car tests)])
+			     (if (= input test)
+				 (loop (cdr inputs) (cdr tests))
+				 (if (<= input test)
+				     'input-smaller
+				     'test-smaller)))]))])
+					; (printf "~a ~a ~a~n" compare secs (date->string date))
+	    (cond
+	     [(eq? compare 'equal) secs]
+	     [(or (= secs below-secs) (= secs above-secs))
+	      (signal-error "non-existent date")]
+	     [(eq? compare 'input-smaller) 
+	      (loop below-secs (floor (/ (+ secs below-secs) 2)) secs)]
+	     [(eq? compare 'test-smaller) 
+	      (loop secs (floor (/ (+ above-secs secs) 2)) above-secs)]))))))
+
+  ;; date->julian/scalinger :
+  ;; date -> number [julian-day]
+
+  ;; Note: This code is correct until 2099 CE Gregorian
+
+  (define (date->julian/scalinger date)
+    (let ((day (date-day date))
+	  (month (date-month date))
+	  (year (date-year date)))
+      (let ((year (+ 4712 year)))
+	(let ((year (if (< month 3) (sub1 year) year)))
+	  (let ((cycle-number (quotient year 4))
+		(cycle-position (remainder year 4)))
+	    (let ((base-day (+ (* 1461 cycle-number) (* 365 cycle-position))))
+	      (let ((month-day-number (case month
+					((3) 0)
+					((4) 31)
+					((5) 61)
+					((6) 92)
+					((7) 122)
+					((8) 153)
+					((9) 184)
+					((10) 214)
+					((11) 245)
+					((12) 275)
+					((1) 306)
+					((2) 337))))
+		(let ((total-days (+ base-day month-day-number day)))
+		  (let ((total-days/march-adjustment (+ total-days 59)))
+		    (let ((gregorian-adjustment (cond
+						 ((< year 1700) 11)
+						 ((< year 1800) 12)
+						 (else 13))))
+		      (let ((final-date (- total-days/march-adjustment
+					   gregorian-adjustment)))
+			final-date)))))))))))
+
+  ;; julian/scalinger->string :
+  ;; number [julian-day] -> string [julian-day-format]
+
+  (define (julian/scalinger->string julian-day)
+    (apply string-append
+	   (cons "JD "
+		 (reverse
+		  (let loop ((reversed-digits (map number->string
+						   (let loop ((jd julian-day))
+						     (if (zero? jd) null
+							 (cons (remainder jd 10)
+							       (loop (quotient jd 10))))))))
+		    (cond
+		     ((or (null? reversed-digits)
+			  (null? (cdr reversed-digits))
+			  (null? (cdr (cdr reversed-digits))))
+		      (list (apply string-append reversed-digits)))
+		     (else (cons (apply string-append
+					(list " "
+					      (caddr reversed-digits)
+					      (cadr reversed-digits)
+					      (car reversed-digits)))
+				 (loop (cdr (cdr (cdr reversed-digits))))))))))))
+
+  )
+
diff --git a/collects/frtime/demos/analog-clock.ss b/collects/frtime/demos/analog-clock.ss
new file mode 100644
index 0000000000..af58c91b71
--- /dev/null
+++ b/collects/frtime/demos/analog-clock.ss
@@ -0,0 +1,133 @@
+;; Analog Clock
+;; Written by Robb Cutler
+;; July, 2004
+;;
+;; Demonstrates animation of an analog clock using the FrTime language.
+
+
+;; Require the animation library, the gui library, and the library
+;; containing the build-list function.
+(require (lib "animation.ss" "frtime")
+         (lib "gui.ss" "frtime"))
+
+(define clock-radius (make-slider "Clock Size" 40 200 100))
+
+;; distance : number number number number -> number
+;; Returns the distance between (x1, y1) and (x2, y2).
+(define (distance x1 y1 x2 y2)
+  (sqrt (+ (sqr (- x1 x2)) (sqr (- y1 y2)))))
+
+(define clicks-in-clock
+  (left-clicks . =#> . (lambda (_)
+                         (snapshot (mouse-pos clock-center clock-radius)
+                                   (<= (distance (posn-x mouse-pos)
+                                                 (posn-y mouse-pos)
+                                                 (posn-x clock-center)
+                                                 (posn-y clock-center))
+                                       clock-radius)))))
+                         
+(define offset
+  (hold
+   (clicks-in-clock . -=> . (value-now (posn- mouse-pos clock-center)))))
+                                             
+;; Define follow-mouse which is true when the center of the clock
+;; should be at the mouse cursor; false when it is at the last 
+;; click position. Clicking the left button of the mouse
+;; toggles this value.
+(define follow-mouse?
+  (hold (merge-e
+         clicks-in-clock
+         (left-releases . -=> . false))))
+
+;; Define the position of the center and the radius of the clock.
+(define clock-center
+  (rec p
+    (inf-delay
+     (until (make-posn 200 200)
+            (let ([p1 (posn- mouse-pos offset)])
+              (if follow-mouse?
+                  p1
+                  p))))))
+
+;; Define the length of the hands in terms of the radius of the clock.
+(define second-hand-length (- clock-radius 5))
+(define minute-hand-length (- clock-radius 5))
+(define hour-hand-length (* .60 clock-radius))
+
+;; Define the position of the numbers of on the clock face
+;; in terms of the radius of the clock.  Because text is positioned using
+;; the lower right corner of the text box (rather than using the center
+;; of the text box), the numbers are drawn on a circle offset 
+;; slightly from the clock face.
+(define number-position (- clock-radius 10))
+(define number-offset-x -4)
+(define number-offset-y 4)
+
+;; Define the time-dependent variables.
+(define the-date (seconds->date seconds))
+(define the-hour (date-hour the-date))
+(define the-minute (date-minute the-date))
+(define the-second (date-second the-date))
+
+;; create-posn : posn number number number -> posn
+;; Creates a position that is of length radius from the given center
+;; The angle from the center is based on value/slots percent clockwise
+;; around the center from 12 o'clock.  For example, given value of 35
+;; and slots of 60, the position would be at 7 o'clock.
+(define (create-posn center radius slots value)
+  (make-posn (+ (posn-x center)
+                (* radius (cos (+ (* 3 (/ pi 2)) 
+                                  (* value (/ (* 2 pi) slots))))))
+             (+ (posn-y center)
+                (* radius (sin (+ (* 3 (/ pi 2)) 
+                                  (* value (/ (* 2 pi) slots))))))))
+
+;; create-number : number -> graph-string
+;; Creates the n-th number for the clock face where n is 0-11.
+(define (create-number n)
+  (make-graph-string (create-posn 
+                      (make-posn (+ (posn-x clock-center) number-offset-x)
+                                 (+ (posn-y clock-center) number-offset-y))
+                      number-position 12 (+ n 1))
+                     (number->string (+ n 1))
+                     "black"))
+
+;; The clock face is a blue circle and a the numbers around its edge.
+(define clock-face
+  (list (make-circle clock-center clock-radius (if follow-mouse?
+                                                   "lightblue"
+                                                   "white"))
+        (make-circle clock-center (/ clock-radius 20) "black")
+        (make-ring clock-center clock-radius "blue")
+        (build-list 12 create-number)))
+
+;; Define the hour hand of the clock.
+;; The hour hand is based on the the-hour and the-minute in order to
+;; make it move smoothly around the clock.
+(define hour-hand
+  (make-line clock-center
+             (create-posn clock-center
+                          hour-hand-length 12
+                          (+ the-hour (/ the-minute 60)))
+             "black"))
+
+;; Define the minute hand of the clock.
+(define minute-hand   
+  (make-line clock-center
+             (create-posn clock-center
+                          minute-hand-length 60 the-minute)
+             "black"))
+
+;; Define the second hand of the clock.
+(define second-hand
+  (make-line clock-center
+             (create-posn clock-center
+                          second-hand-length 60 the-second)
+             "red"))
+
+;; Define the clock as the face and the three hands.
+(define analog-clock 
+  (list clock-face hour-hand minute-hand second-hand))
+
+;; Draw the clock!
+(display-shapes analog-clock)
diff --git a/collects/frtime/demos/ball-on-string.ss b/collects/frtime/demos/ball-on-string.ss
new file mode 100644
index 0000000000..a6190b5aac
--- /dev/null
+++ b/collects/frtime/demos/ball-on-string.ss
@@ -0,0 +1,11 @@
+(require (lib "animation.ss" "frtime"))
+
+(define-values (pos vel)
+ (letrec ([pos (posn-integral vel)]
+          [vel (posn/ (posn- mouse-pos (inf-delay pos)) 400.0)])
+   (values pos vel)))
+
+(display-shapes
+ (list
+  (make-line mouse-pos pos "gray")
+  (make-circle pos (+ 10 (/ 400 (+ 40.0 (posn-diff mouse-pos pos)))) "blue")))
diff --git a/collects/frtime/demos/calculator.ss b/collects/frtime/demos/calculator.ss
new file mode 100644
index 0000000000..64c1c56d34
--- /dev/null
+++ b/collects/frtime/demos/calculator.ss
@@ -0,0 +1,21 @@
+(require (lib "gui.ss" "frtime"))
+
+(define op-names (list "+" "-" "*" "/"))
+(define ops (list + - * /))
+
+(define (str->num s)
+  (cond
+    [(string->number s)]
+    [else 0]))
+
+(define x
+  (str->num (make-text "First number:")))
+
+(define op
+  (make-choice "Op:" op-names))
+
+(define y
+  (str->num (make-text "Second number:")))
+
+(make-message
+ (format "Result = ~a" ((list-ref ops op) x y)))
diff --git a/collects/frtime/demos/circles.ss b/collects/frtime/demos/circles.ss
new file mode 100644
index 0000000000..26740f918b
--- /dev/null
+++ b/collects/frtime/demos/circles.ss
@@ -0,0 +1,23 @@
+(require (lib "animation.ss" "frtime")
+         (lib "etc.ss" "frtime")
+         (lib "gui.scm" "frtime"))
+
+(define radius (make-slider "Radius" 100 200 150))
+(define speed (* .02 (make-slider "Speed" 0 10 5)))
+(define n (make-slider "Num circles" 1 10 6))
+(define ratio (add1 (* .2 (make-slider "Ratio" 1 5 2))))
+
+(define phase (wave speed))
+(define center (make-posn 200 200))
+
+(display-shapes
+ (build-list
+  n
+  (lambda (i)
+    (make-ring
+     (posn+ center
+            (posn*
+             (make-posn (cos phase) (sin phase))
+             (* radius (- 1 (expt ratio (- i))))))
+     (/ radius (expt ratio i))
+     "gray"))))
diff --git a/collects/frtime/demos/delay-mouse.ss b/collects/frtime/demos/delay-mouse.ss
new file mode 100644
index 0000000000..9478ac296d
--- /dev/null
+++ b/collects/frtime/demos/delay-mouse.ss
@@ -0,0 +1,12 @@
+(require (lib "animation.ss" "frtime"))
+
+; the mouse position delayed
+(display-shapes
+ (let* ([n 4]
+        [n-1 (sub1 n)])
+   (build-list
+    n
+    (lambda (i)
+      (make-circle (delay-by mouse-pos (* 200 (- n-1 i)))
+                   (+ 7 i)
+                   (make-rgb (/ (- n-1 i) n) (/ (- n-1 i) n) 1.0))))))
diff --git a/collects/frtime/demos/growing-points.ss b/collects/frtime/demos/growing-points.ss
new file mode 100644
index 0000000000..ef849991ea
--- /dev/null
+++ b/collects/frtime/demos/growing-points.ss
@@ -0,0 +1,51 @@
+;; GrowingPoints
+;; Written by Robb Cutler
+;; July, 2004
+;;
+;; Demonstrates a grid of points that grow as the mouse cursor
+;; approaches them. Uses the FrTime language.
+
+
+;; Require the animation library, the gui library, and the library
+;; containing the build-list function.
+(require (lib "animation.ss" "frtime")
+         (lib "gui.ss" "frtime")
+         (lib "etc.ss" "frtime"))
+
+;; distance : number number number number -> number
+;; Returns the distance between (x1, y1) and (x2, y2).
+(define (distance x1 y1 x2 y2)
+  (sqrt (+ (sqr (- x1 x2)) (sqr (- y1 y2)))))
+
+;; How many growing points on one side of the grid of growing points.
+(define GRID-SIZE 8)
+
+;; The distance between the centers of two adjacent growing points.
+(define grid-resolution (make-slider "Resolution" 2 30 20))
+
+;; The maximum size a growing point can grow.
+(define max-point-size (make-slider "Max Point Size" 2 30 20))
+
+;; create-growing-point : number -> line
+;; Define one growing point.  A point's size is such that it
+;; is larger as its distance to the position of the mouse
+;; cursor decreases. num is the needle's row-major
+;; location on the grid (from 0 to GRID-SIZE^2-1).
+(define (create-growing-point num)
+  (let* ([row (quotient num GRID-SIZE)]
+         [col (remainder num GRID-SIZE)]
+         [x (+ (* row grid-resolution) 25)]
+         [y (+ (* col grid-resolution) 25)]
+         [d (distance x y (posn-x mouse-pos) (posn-y mouse-pos))]
+         [pt-size (if (< d (- max-point-size 2))
+                      (- max-point-size d)
+                      2)])
+    (make-circle (make-posn x y)
+                 pt-size
+                 (make-rgb (/ pt-size max-point-size) 0 0))))
+
+;; Define a list of growing points.
+(define growing-points (build-list (sqr GRID-SIZE) create-growing-point))
+
+;; Draw the growing points!
+(display-shapes growing-points)
\ No newline at end of file
diff --git a/collects/frtime/demos/mouse.ss b/collects/frtime/demos/mouse.ss
new file mode 100644
index 0000000000..0b870befe0
--- /dev/null
+++ b/collects/frtime/demos/mouse.ss
@@ -0,0 +1,10 @@
+(require (lib "animation.ss" "frtime"))
+
+(display-shapes
+ (list
+  (make-circle mouse-pos 10 "blue")
+  (make-graph-string (make-posn 20 20)
+                     (format "(~a, ~a)"
+                             (posn-x mouse-pos)
+                             (posn-y mouse-pos))
+                     "black")))
\ No newline at end of file
diff --git a/collects/frtime/demos/needles.ss b/collects/frtime/demos/needles.ss
new file mode 100644
index 0000000000..7fc3ab7d13
--- /dev/null
+++ b/collects/frtime/demos/needles.ss
@@ -0,0 +1,57 @@
+;; Needles
+;; Written by Robb Cutler
+;; July, 2004
+;;
+;; Demonstrates a grid of animated needles that follow the mouse cursor
+;; using the FrTime language.
+
+
+;; Require the animation library and the library
+;; containing the build-list function.
+(require (lib "animation.ss" "frtime")
+         (lib "etc.ss" "frtime"))
+
+;; How many needles on one side of the grid of needles
+(define GRID-SIZE 8)
+
+;; The length of a needle in pixels
+(define NEEDLE-LENGTH 10)
+
+;; The distance between the centers of two adjacent needles
+(define SPACING 25)
+
+;; A useful constant.
+(define PI 3.1415626535)
+
+(define (distance x1 y1 x2 y2)
+  (sqrt (+ (sqr (- x1 x2)) (sqr (- y1 y2)))))
+
+;; create-needle : number -> line
+;; Define one needle.  A needle's orientation is such that it
+;; lies on a line between the center of the needle and the 
+;; position of mouse cursor. num is the needle's row-major
+;; location on the grid (from 0 to GRID-SIZE^2-1).
+(define (create-needle num)
+  (let* ([row (quotient num GRID-SIZE)]
+         [col (remainder num GRID-SIZE)]
+         [x (+ (* row SPACING) SPACING)]
+         [y (+ (* col SPACING) SPACING)]
+         [delta-x (- (posn-x mouse-pos) x)]
+         [delta-y (- (posn-y mouse-pos) y)]
+         [theta1 (atan (/ delta-y (exact->inexact delta-x)))]
+         [theta2 (- theta1 PI)]
+         [x1-pos (+ x (* NEEDLE-LENGTH (cos theta1)))]
+         [y1-pos (+ y (* NEEDLE-LENGTH (sin theta1)))]
+         [x2-pos (+ x (* NEEDLE-LENGTH (cos theta2)))]
+         [y2-pos (+ y (* NEEDLE-LENGTH (sin theta2)))]
+         [color-density (min 1 (/ (distance x1-pos y1-pos (posn-x mouse-pos) (posn-y mouse-pos)) 150.0))]
+         )
+    (make-line (make-posn x1-pos y1-pos)
+               (make-posn x2-pos y2-pos)
+               (make-rgb (- 1 color-density) 0 0))))
+
+;; Define a list of needles
+(define needles (build-list (sqr GRID-SIZE) create-needle))
+
+;; Draw the needles!
+(display-shapes needles)
\ No newline at end of file
diff --git a/collects/frtime/demos/net-pong-client.ss b/collects/frtime/demos/net-pong-client.ss
new file mode 100644
index 0000000000..1dd55e3937
--- /dev/null
+++ b/collects/frtime/demos/net-pong-client.ss
@@ -0,0 +1,27 @@
+(require (lib "animation.ss" "frtime")
+         (lib "erl.ss" "frtime"))
+
+(define server (new-cell (make-tid 1178 'frtime-heart)))
+
+(define pos1
+  (let* ([paddle-radius 20]
+         [paddle1-pos (make-posn (clip (posn-x mouse-pos) 30 170) (clip (posn-y mouse-pos) 30 370))]
+         [_ (bind 'paddle1-pos ((changes paddle1-pos) . ==> . (lambda (p) (list (posn-x p) (posn-y p)))))]
+         [pong (switch (left-clicks
+                        . ==> .
+                        (lambda (_)
+                          (hold (remote-reg (value-now server) 'pong)
+                                (list 300 300 100 100 0 0))))
+                       (list 300 300 100 100 0 0))]
+         [paddle2-pos (make-posn (first pong) (second pong))]
+         [pos1 (make-posn (third pong) (fourth pong))]
+         [p1-score (list-ref pong 4)]
+         [p2-score (list-ref pong 5)])
+    (display-shapes
+     (list (make-circle pos1 10 "blue")
+           (make-circle paddle1-pos paddle-radius "black")
+           (make-circle paddle2-pos paddle-radius "black")
+           (make-graph-string (make-posn 30 30) (number->string p2-score) "black")
+           (make-graph-string (make-posn 350 30) (number->string p1-score) "black")
+           (make-line (make-posn 0 150) (make-posn 0 250) "red")
+           (make-line (make-posn 399 150) (make-posn 399 250) "red")))))
diff --git a/collects/frtime/demos/net-pong-server.ss b/collects/frtime/demos/net-pong-server.ss
new file mode 100644
index 0000000000..ea15f52c60
--- /dev/null
+++ b/collects/frtime/demos/net-pong-server.ss
@@ -0,0 +1,80 @@
+(require
+ (lib "animation.ss" "frtime")
+ (lib "erl.ss" "frtime")
+ (all-except (lib "match.ss") match))
+
+(define client (new-cell (make-tid 1179 'frtime-heart)))
+
+(define pos1
+  (let ([paddle-radius 20]
+        [neg-x (lambda (v) (make-posn (- (posn-x v)) (posn-y v)))]
+        [neg-y (lambda (v) (make-posn (posn-x v) (- (posn-y v))))]
+        [paddle2-pos (make-posn (clip (posn-x mouse-pos) 230 370) (clip (posn-y mouse-pos) 30 370))]
+        [paddle1-pos (switch (left-clicks . ==> .
+                                          (lambda (_)
+                                            (hold ((remote-reg
+                                                    (value-now client)
+                                                    'paddle1-pos)
+                                                   . ==> .
+                                                   (lambda (l) (make-posn (first l) (second l))))
+                                                  (make-posn 30 200))))
+                             (make-posn 30 200))]
+        [collide (match-lambda
+                   [(_ mp p)
+                    (let ([u (normalize (posn- mp p))])
+                      (lambda (v)
+                        (posn- v (posn* u (* 2 (posn-dot v u))))))])])
+    (letrec ([pos1 (switch
+                    ((merge-e
+                      (when-e (> (posn-x pos1) 500))
+                      (when-e (< (posn-x pos1) -100))
+                      (when-e (> (posn-y pos1) 500))
+                      (when-e (< (posn-y pos1) -100))) . ==> . (lambda (dummy) (posn+ (make-posn 100 100) (posn-integral vel1))))
+                    (posn+ (make-posn 100 100) (posn-integral vel1)))]
+             [vel1 (accum-b
+                    (merge-e
+                     ((merge-e
+                       (when-e (> (posn-x pos1) 390))
+                       (when-e (< (posn-x pos1) 10))) . -=> . neg-x)
+                     ((merge-e
+                       (when-e (> (posn-y pos1) 390))
+                       (when-e (< (posn-y pos1) 10))) . -=> . neg-y)
+                     ((merge-e
+                       (snapshot-e (when-e (< (posn-diff pos1 paddle1-pos)
+                                              (+ 10 paddle-radius))) paddle1-pos pos1)
+                       (snapshot-e (when-e (< (posn-diff pos1 paddle2-pos)
+                                              (+ 10 paddle-radius))) paddle2-pos pos1))
+                      . ==> . collide))
+                    (make-posn .29 .23))])
+      (let ([p1-score (accum-b
+                       (merge-e
+                        ((key #\r) . -=> . (lambda (x) 0))
+                        ((snapshot-e (when-e (< (posn-x pos1) 10)) (posn-y pos1))
+                         . =#=> .
+                         (match-lambda
+                           [(_ y) (if (and (> y 150) (< y 250))
+                                      add1
+                                      nothing)])))
+                       0)]
+            [p2-score (accum-b
+                       (merge-e
+                        ((key #\r) . -=> . (lambda (x) 0))
+                        ((snapshot-e (when-e (> (posn-x pos1) 390)) (posn-y pos1))
+                         . =#=> .
+                         (match-lambda
+                           [(_ y) (if (and (> y 150) (< y 250))
+                                      add1
+                                      nothing)])))
+                       0)])
+        (display-shapes
+         (list (make-circle pos1 10 "blue")
+               (make-circle paddle1-pos paddle-radius "black")
+               (make-circle paddle2-pos paddle-radius "black")
+               (make-graph-string (make-posn 30 30) (number->string p2-score) "black")
+               (make-graph-string (make-posn 350 30) (number->string p1-score) "black")
+               (make-graph-string (make-posn 120 30) (number->string (posn-len vel1)) "black")
+               (make-line (make-posn 0 150) (make-posn 0 250) "red")
+               (make-line (make-posn 399 150) (make-posn 399 250) "red")))
+        (bind 'pong (changes (list (posn-x paddle2-pos) (posn-y paddle2-pos)
+                                   (posn-x pos1) (posn-y pos1)
+                                   p1-score p2-score)))))))
diff --git a/collects/frtime/demos/orbit-mouse.ss b/collects/frtime/demos/orbit-mouse.ss
new file mode 100644
index 0000000000..86391446b6
--- /dev/null
+++ b/collects/frtime/demos/orbit-mouse.ss
@@ -0,0 +1,22 @@
+(require (lib "animation.ss" "frtime")
+         (lib "gui.ss" "frtime"))
+
+(define radius 25)
+(define speed (* .1 (make-slider "Speed" -15 15 6)))
+(define phase (wave speed))
+(define n (make-slider "# Balls" 1 6 3))
+(define r (/ (make-slider "Red%"   0 100 0) 100.0))
+(define g (/ (make-slider "Green%" 0 100 0) 100.0))
+(define b (/ (make-slider "Blue%"  0 100 0) 100.0))
+
+(display-shapes
+ (build-list
+  n
+  (lambda (i)
+    (let ([t (+ (/ (* 2 pi i) n) phase)])
+      (make-circle
+       (posn+ mouse-pos
+              (make-posn
+               (* radius (cos t))
+               (* radius (sin t))))
+       5 (make-rgb r g b))))))
diff --git a/collects/frtime/demos/piston.ss b/collects/frtime/demos/piston.ss
new file mode 100644
index 0000000000..57fb8aa5ee
--- /dev/null
+++ b/collects/frtime/demos/piston.ss
@@ -0,0 +1,61 @@
+(require
+ (lib "animation.ss" "frtime")
+ (lib "gui.ss" "frtime")
+ (lib "math.ss" "frtime"))
+
+(define radius (make-slider "Radius" 30 50 30))
+(define crank (make-slider "Crank length" 150 200 150))
+
+(display-shapes
+ (let* ([x-center 300]
+        [y-center 200]
+        [cylinder-width (* 2 radius)]
+        [hatch-frac 0.6]
+        [piston-height (make-slider "Piston height" 20 40 20)]
+        [piston-width 12]
+        [gap (/ cylinder-width 6)]
+        [speed (* .02 (make-slider "Speed" -75 75 25))]
+        [phase (wave speed)]
+        [x1 (* radius (cos phase))]
+        [y1 (* radius (sin phase))]
+        [x0 (+ x1 (sqrt (- (sqr crank) (sqr y1))))])
+   (list
+    ; wheel
+    (make-ring (make-posn x-center y-center) radius "black")
+    ; crank
+    (make-line (make-posn (- x-center x1) (+ y-center y1))
+               (make-posn (- x-center x0) y-center)
+               "black")
+    ; gas in cylinder
+    (make-rect (make-posn (- x-center crank radius gap piston-width)
+                          (- y-center (/ piston-height 2)))
+               (- (+ radius gap crank 6) x0)
+               piston-height
+               (let ([c (/ x1 30)])
+                 (fix-rgb 1
+                          (- .8 (* .3 c))
+                          (- .8 (* .3 c)))))
+    ; piston head
+    (make-rect (make-posn (- x-center x0 piston-width)
+                          (- y-center (/ piston-height 2)))
+               piston-width piston-height "black")
+    ; blue ball
+    (make-circle (make-posn (- x-center x1) (+ y-center y1)) 5 "blue")
+    ; cross on wheel
+    (make-line (make-posn (- x-center (* hatch-frac x1)) (+ y-center (* hatch-frac y1)))
+               (make-posn (+ x-center (* hatch-frac x1)) (- y-center (* hatch-frac y1))) "black")
+    (make-line (make-posn (- x-center (* hatch-frac y1)) (- y-center (* hatch-frac x1)))
+               (make-posn (+ x-center (* hatch-frac y1)) (+ y-center (* hatch-frac x1))) "black")
+    ; cylinder outline
+    (make-line (make-posn (- x-center radius crank piston-width gap)
+                          (- y-center (/ piston-height 2) 1))
+               (make-posn (+ (- x-center radius crank piston-width) cylinder-width)
+                          (- y-center (/ piston-height 2) 1)) "black")
+    (make-line (make-posn (- x-center radius crank piston-width gap)
+                          (+ y-center (/ piston-height 2)))
+               (make-posn (+ (- x-center radius crank piston-width) cylinder-width)
+                          (+ y-center (/ piston-height 2))) "black")
+    (make-line (make-posn (- x-center radius crank piston-width gap 1)
+                          (- y-center (/ piston-height 2) 1))
+               (make-posn (- x-center radius crank piston-width gap 1)
+                          (+ y-center (/ piston-height 2))) "black"))))
diff --git a/collects/frtime/demos/pizza.ss b/collects/frtime/demos/pizza.ss
new file mode 100644
index 0000000000..d2952a9a56
--- /dev/null
+++ b/collects/frtime/demos/pizza.ss
@@ -0,0 +1,24 @@
+(require (lib "gui.ss" "frtime"))
+
+(define kinds (list "New York" "Chicago" "California" "Hawaii"))
+(define sizes (list "small" "medium" "large" "Texas"))
+
+(define customer
+  (make-text "Customer name:"))
+
+(define kind
+  (make-choice "Kind:" kinds))
+
+(define size
+  (make-choice "Size:" sizes))
+
+(define button-event
+  (make-button "Confirm"))
+
+(make-message
+ (hold (button-event
+        . -=> .
+        (snapshot (customer kind size)
+          (string-append customer " ordered a "
+                         (list-ref sizes size) " "
+                         (list-ref kinds kind) " pizza.")))))
diff --git a/collects/frtime/demos/pong.ss b/collects/frtime/demos/pong.ss
new file mode 100644
index 0000000000..f43ebd59c3
Binary files /dev/null and b/collects/frtime/demos/pong.ss differ
diff --git a/collects/frtime/demos/push-pull-ball.ss b/collects/frtime/demos/push-pull-ball.ss
new file mode 100644
index 0000000000..5ba03aad0a
--- /dev/null
+++ b/collects/frtime/demos/push-pull-ball.ss
@@ -0,0 +1,29 @@
+(module push-pull-ball (lib "frtime.ss" "frtime")
+  
+  (require (lib "etc.ss" "frtime")
+           (lib "animation.ss" "frtime"))
+  
+  (define radius (new-cell 20))
+  
+  (define pos1
+    (rec pos
+      (until (make-posn 200 200)
+             (if (> (posn-diff pos mouse-pos) radius)
+                 (posn+ pos
+                        (posn* (normalize (posn- mouse-pos pos))
+                               (- (posn-diff pos mouse-pos) (sub1 radius))))
+                 pos))))
+
+  (define pos2
+    (rec pos
+      (until (make-posn 100 100)
+             (if (< (posn-diff pos pos1) (* 2 radius))
+                 (posn+ pos
+                        (posn* (normalize (posn- pos1 pos))
+                               (- (posn-diff pos pos1) (add1 (* 2 radius)))))
+                 pos))))
+
+  (display-shapes
+   (list
+    (make-circle pos1 radius "blue")
+    (make-circle pos2 radius "blue"))))
diff --git a/collects/frtime/demos/rotation.ss b/collects/frtime/demos/rotation.ss
new file mode 100644
index 0000000000..f79cdccd99
--- /dev/null
+++ b/collects/frtime/demos/rotation.ss
@@ -0,0 +1,46 @@
+(require
+ (lib "animation.ss" "frtime")
+ (lib "gui.ss" "frtime"))
+
+(define radius (make-slider "Radius" 50 150 100))
+(define speed (* .01 (make-slider "Speed" -75 75 50)))
+(define phase (wave speed))
+(define x (cos phase))
+(define y (sin phase))
+(define green (+ .75 (* .25 x)))
+(define blue (+ .75 (* .25 y)))
+
+(define ring1?
+  (make-check-box "Show x-y ring?"))
+
+(define center?
+  (make-check-box "Show center of x-y ring?"))
+
+(define ring2?
+  (make-check-box "Show pt-center ring?"))
+
+(define (cvt z)
+  (+ 200 (* radius z)))
+
+(define shapes
+  (list
+   (when ring2? (make-ring (make-posn (cvt (/ x 4))
+                                      (cvt (/ y 4)))
+                           (* radius .75) "gray"))
+   (when center? (make-circle (make-posn (cvt (- (/ x 2)))
+                                         (cvt (- (/ y 2))))
+                              (/ radius 12) "gray"))
+   (when ring1? (make-ring (make-posn (cvt (- (/ x 2)))
+                                      (cvt (- (/ y 2))))
+                           (/ radius 2) "gray"))
+   (make-ring (make-posn 200 200) radius "gray")
+   (make-line (make-posn (cvt -1.2) 200) (make-posn (cvt 1.2) 200) "gray")
+   (make-line (make-posn 200 (cvt -1.2)) (make-posn 200 (cvt 1.2)) "gray")
+   (make-circle (make-posn (cvt x) (cvt y)) (/ radius 10)
+                (make-rgb 0 green blue))
+   (make-circle (make-posn 200 (cvt (- y))) (/ radius 10)
+                (make-rgb 0 0.75 (- 1.5 blue)))
+   (make-circle (make-posn (cvt (- x)) 200) (/ radius 10)
+                (make-rgb 0 (- 1.5 green) 0.75))))
+
+(display-shapes shapes)
diff --git a/collects/frtime/demos/spreadsheet/data-synthesis.ss b/collects/frtime/demos/spreadsheet/data-synthesis.ss
new file mode 100644
index 0000000000..f5c69e8e63
--- /dev/null
+++ b/collects/frtime/demos/spreadsheet/data-synthesis.ss
@@ -0,0 +1,72 @@
+(module data-synthesis (lib "frtime.ss" "frtime")
+
+(require "distributions.ss"
+         (lib "math.ss")
+         )
+
+;; num list -> num
+; INPUT: Many numbers DATA
+; OUTPUT: That DATA's sample mean (a.k.a mean, average)
+(define (sample-mean data)
+  (let ([n (length data)]
+        [sum-y (apply + data)])
+    (/ sum-y n)))
+
+;;num list -> num
+; INPUT: List of numbers DATA
+; OUTPUT: The sample variance of DATA
+(define (sample-variance data)
+  (let* ([n (length data)]
+         [sm (sample-mean data)]
+         [d2 (map (lambda (x)
+                    (sqr (- x sm)))
+                  data)])
+    (/ (apply + d2) 
+           (- n 1))))
+
+
+;; NOTE:
+;;  The sample-mean and sample-variance of set of data are unbiased
+;;  and efficient estimators of the mean and variance of the probability
+;;  distribution that produced that data.  Therefore, our best fitting
+;;  normal distribution to that data is a normal distribution having
+;;  mean equal to the sample mean and variance equal to the sample-variance.
+
+(define (fit-normal-distribution data)
+  (make-normal-distribution (sample-mean data)
+                            (sqrt (sample-variance data))))
+
+(define (fit-uniform-distribution data)
+  (let ([mean (sample-mean data)]
+        [variance (sample-variance data)])
+;    (print (format "theta1: ~a" (- mean
+;                                  (sqrt (* 3 variance)))))
+;    (print (format "theta2: ~a" (+  mean
+;                                   (sqrt (* 3 variance)))))
+    (make-uniform-distribution (- mean
+                                  (sqrt (* 3 variance)))
+                               (+  mean
+                                   (sqrt (* 3 variance))))))
+
+; My Gamma work is screwy. See distributions.ss
+;(define (fit-gamma-distribution data)
+;  (let ([mean (sample-mean data)]
+;        [variance (sample-variance data)])
+;    (make-gamma-distribution (/ (sqr mean)
+;                                variance)
+;                             (/ variance mean))))
+
+(define (fit-exponential-distribution data)
+  (make-exponential-distribution (sample-mean data)))
+
+(define (synthesize-random-data dist size)
+            (if (zero? size)
+                '()
+                (cons ((distribution-rand dist))
+                      (synthesize-random-data dist (sub1 size)))))
+        
+
+
+(provide (all-defined))
+  
+  )
\ No newline at end of file
diff --git a/collects/frtime/demos/spreadsheet/distributions.ss b/collects/frtime/demos/spreadsheet/distributions.ss
new file mode 100644
index 0000000000..c4b98ecead
--- /dev/null
+++ b/collects/frtime/demos/spreadsheet/distributions.ss
@@ -0,0 +1,433 @@
+(module distributions mzscheme
+  
+  (require (lib "math.ss")
+           )
+  
+  (define RANDOM-GRAIN (sub1 (expt 2 31)))  
+  
+  ;;  A distribution has a:
+  ;;    bool continuous?          : Is this distribution continuous? (#t if yes, #f if discrete)
+  ;;    (num -> num) density-f    : Probability density function f(y)= p(y)
+  ;;    num mean                  : mean of distribution
+  ;;    num variance              : variance of distribution
+  ;;                 I need to think about this next one:
+  ;;    (num -> num)? mgf         : moment generating function.  Forgive the acronym.
+  (define-struct distribution (continuous? 
+                               d-func 
+                               mean 
+                               variance 
+                               rand
+                               ))
+  
+  (define (print-distribution dist)
+    (print (format "continuous?: ~a, mean: ~a, variance: ~a"
+                   (distribution-continuous? dist)
+                   (distribution-mean dist)
+                   (distribution-variance dist))))
+  
+  (define (ln n)
+    (/ (log n)
+       (log e)))
+  
+  
+  (define fac
+    (lambda (n)
+      (if (zero? n)
+          1
+          (* n (fac (- n 1))))))
+  
+  (define choose
+    (lambda (a b)
+      (/ (fac a)
+         (* (fac b)
+            (fac (- a b))))))
+  
+  (define myround
+    (lambda (n)
+      (- n
+         (- n (round n)))))
+  
+  
+  
+  ;; Ultimately, mgf might be a struct, with make-uniform-mgf, make-normal-mgf, etc.
+  ;; be special constructors for that particular struct.  For now, I'll leave
+  ;; this as the actual formula
+  (define (make-uniform-mgf theta1 theta2)
+    (lambda (t)
+      (/ (- (exp (* t theta2))
+            (exp (* t theta1)))
+         (* t
+            (- theta2 theta1)))))
+  (define (make-normal-mgf mu sigma)
+    (lambda (t)
+      (exp (+ (* mu t)
+              (/ (* (sqr t) (sqr sigma))
+                 2)))))
+  
+  ;;Do I need these? Dammit!
+  (define (make-exponential-mgf bete)
+    'dummy)
+  (define (make-binomial-mgf n p)
+    'dummy)
+  
+  
+  
+  
+  
+  (define (make-uniform-distribution theta1 theta2)
+    (make-distribution #t
+                       (lambda (y)
+                         ;;is it appropriate to limit the domains of the 
+                         ;; probability functions with conditionals like
+                         ;; this?
+                         (if (or (< y theta1)
+                                 (< theta2 y))
+                             0
+                             (/ (- theta2 theta1))))
+                       (/ (+ theta1 theta2)
+                          2)
+                       (/ (sqr (- theta2 theta1))
+                          12)
+                       (lambda ()
+                         (uniform-random theta1 theta2))
+                       ))
+  
+  (define (make-normal-distribution mu sigma)
+    (make-distribution #t
+                       (lambda (y)
+                         (* (/ (* sigma (sqrt (* 2 pi))))
+                            (exp (- (* (/ (* 2 (sqr sigma)))
+                                       (sqr (- y mu)))))))
+                       mu
+                       (sqr sigma)
+                       (lambda ()
+                         (normal-random mu sigma))
+                       ))
+  
+  (define (make-exponential-distribution beta)
+    ;;Can I asser here that beta > 0??
+    (make-distribution #t
+                       (lambda (y)
+                         (if (< 0 y)
+                             (* (/ beta)
+                                (exp (/ (- y)
+                                        beta)))
+                             0))
+                       beta
+                       (sqr beta)
+                       (lambda ()
+                         (exponential-random beta))
+                       ))
+  
+  ;; FUCK! The Gamma function is a big integral, equal to factorial if the
+  ;; argument is an integer, but otherwise...crap on a stick!
+  
+  ; (define (make-gamma-distribution alpha beta)
+  ;  (make-distribution #t
+  ;                    (lambda (y)
+  
+  
+  (define (make-binomial-distribution n p)
+    (make-distribution #f
+                       (lambda (y)
+                         ;;should assert whole-number-ness here or something
+                         (* (choose n y)
+                            (expt p y)
+                            (expt (- 1 p)
+                                  (- n y))))
+                       (* n p)
+                       (* n p (- 1 p))
+                       (lambda ()
+                         (binomial-random n p))
+                       ))
+;  
+;  (define (make-gamma-distribution alpha beta)
+;    (make-distribution #f
+;                       (lambda (y)
+;                         (if (<= y 0)
+;                             0
+;                             (* (expt y (sub1 alpha))
+;                                (exp (/ (- y) beta))
+;                                (/ (* (exp (gammln alpha))
+;                                      (expt beta alpha))))))
+;                       (* alpha beta)
+;                       (* alpha beta beta)
+;                       (lambda () 
+;                         (gamma-random alpha beta))))
+  
+  
+  
+  
+  
+  (define (uniform-random theta1 theta2)
+    (+ theta1 (* (/ (- theta2 theta1) (sub1 RANDOM-GRAIN)) (random RANDOM-GRAIN))))
+  
+  (define (open-uniform-random theta1 theta2)
+    (+ theta1 (* (/ (- theta2 theta1) RANDOM-GRAIN) (add1 (random (sub1 RANDOM-GRAIN))))))
+  
+  
+  
+  
+  ;; Although it might be the root of all evil, and make no sense in this context,
+  ;; I'm going to use the Marsaglia Polar Method here with the flip-flopping
+  ;; indicator switch because it's HOT. 
+  (define r 0)
+  (define ind 1)
+  
+  (define (ranf)
+    (open-uniform-random 0 1))
+  
+  (define (standard-normal-random-guts)
+    (let* ([x1 (- (* 2 (ranf)) 1)]
+           [x2 (- (* 2 (ranf)) 1)]
+           [w  (+ (* x1 x1) (* x2 x2))])
+      (if (> w 1)
+          (standard-normal-random-guts)
+          (let ([w2 (sqrt (/ (* (ln w) -2) w))])
+            (set! r (* x2 w2))
+            (* x1 w2)))))
+  
+  (define (standard-normal-random)
+    (set! ind (- ind))
+    (if (> ind 0)
+        (standard-normal-random-guts)
+        r))
+  
+  (define (normal-random mu sigma)
+    (+ (* sigma (standard-normal-random)) mu))
+  
+  (define (exponential-random beta)
+    (let ([rand (/ (add1 (random (sub1 RANDOM-GRAIN))) RANDOM-GRAIN)])
+      (* (- (ln rand)) beta)))
+  
+  
+  
+  ;(define (testrand args make-dist rand target n m)
+  ;  (/ (let loopa ([t 0])
+  ;       (if (> t target)
+  ;           0
+  ;           (+ (let loop ([i m])
+  ;                (if (> 0 i)
+  ;                    0
+  ;                    (+ (if (= (apply rand
+  ;                                     (cons n
+  ;                                           args))
+  ;                              t)
+  ;                           1
+  ;                           0)
+  ;                       (loop (sub1 i)))))
+  ;(loopa (add1 t)))))
+  ;((distribution-density-f (apply make-dist args)) target)
+  ;))
+  
+  
+  ;;;pronlems if alpha is a non-integer
+  ;(define (standard-gamma-random-guts alpha)
+  ;  (let ([v1 (ranf RANDOM-GRAIN)]
+  ;        [v2 (- (* 2 (ranf RANDOM-GRAIN)) 1)])
+  ;    (if (> (+ (* v1 v1) (* v2 v2)) 1)
+  ;        (standard-gamma-random-guts alpha)
+  ;        (let*
+  ;            ([y (/ v2 v1)]
+  ;             [am (- alpha 1)]
+  ;             [s (sqrt (+ (* 2 am) 1))]
+  ;             [x (+ (* s y) am)])
+  ;          (if (<= x 0)
+  ;              (standard-gamma-random-guts alpha)
+  ;              (if (> (ranf)
+  ;                     (* (+ 1 (* y y))
+  ;                        (exp (- (* am
+  ;                                   (ln (/ x am)))
+  ;                                (* s y)))))
+  ;                  (standard-gamma-random-guts alpha)
+  ;                  x))))))
+  ;
+  ;;;problems if alpha is a non-integer, I think
+  ;(define (standard-gamma-random alpha)
+  ;  (cond [(< alpha 1) (error "Bad alpha value for standard-gamma-random")]
+  ;        [(< alpha 6) (let loop ([x 1] [i 0])
+  ;                       (if (> i alpha)
+  ;                           (- (ln x))
+  ;                           (loop (* x (ranf)) (add1 i))))] ; the random number here
+  ;        ; might have to be over the
+  ;        ; whole number line.
+  ;        [else (standard-gamma-random-guts alpha)]))
+  ;
+  ;
+  ;;;problems if alpha is a non-integer
+  ;(define (gamma-random alpha beta)
+  ;  (* beta (standard-gamma-random alpha)))
+  
+  ;; PROBLEMS with GAMMA RANDOM:
+  ;; (1) The random gamma number generator should only take positive integers as
+  ;;     argument according to the spec in Numerical Recipes.  However, according to
+  ;;     Mathematical Statistics and Applications, the alpha parameter of a gamma function
+  ;;     may not always be an integer.
+  ;; (2) Using the code for the random number generator above seems to produce data with mean of
+  ;;     ((alpha + 1) * beta), and variance of ((alpha + 1) * beta ^ 2).  I don't know what
+  ;;     is wrong with the code, but I hesitated to just throwing in something subtracting 1 from
+  ;;     alpha before running calculations because that seems unsound.
+  
+  
+  (define (gammln xx)
+    ;Returns the value ln[(xx)] for xx > 0.
+    (let* ([ser 1.000000000190015]
+           [cof1 76.18009172947146]
+           [cof2 -86.50532032941677]
+           [cof3 24.01409824083091]
+           [cof4 -1.231739572450155]
+           [cof5 0.001208650973866179]
+           [cof6 -0.000005395239384953]
+           [x xx]
+           [y xx]
+           [tmp (- (+ x 5.5)
+                   (* (+ x 0.5)
+                      (ln (+ x 5.5))))]
+           [ser2 (+ ser
+                    (/ cof1 (+ y 1))
+                    (/ cof2 (+ y 2))
+                    (/ cof3 (+ y 3))
+                    (/ cof4 (+ y 4))
+                    (/ cof5 (+ y 5))
+                    (/ cof6 (+ y 6)))])
+      (+ (- tmp)
+         (ln (* 2.5066282746310005
+                (/ ser2
+                   x))))))
+  
+  
+  
+  ;;more sketchy mutative stuff recommended by Numerical Recipes to optimize this craziness.
+  (define pg 0)
+  (define poldm -1.0)
+  (define psq -1)
+  (define palxm -1)
+  
+  
+  (define (poisson-random xm)
+    (if (> 12 xm)
+        (begin
+          (unless (= xm poldm)
+            (set! poldm xm)
+            (set! pg (exp (- xm))))
+          (let loop ([em 0] [t (ranf)])
+            (if (> t pg)
+                (loop (add1 em) (* t (ranf)))
+                em)))
+        (begin
+          (unless (= xm poldm)
+            (set! poldm xm)
+            (set! psq (sqrt (* 2.0 xm)))
+            (set! palxm (ln xm))
+            (set! pg (- (* xm palxm) (gammln (+ xm 1)))))
+          (poisson-random-guts xm))))
+  
+  (define (poisson-random-guts xm)
+    (let loop ([y (tan (* (ranf) pi))])
+      (let ([em (+ (* psq y)
+                   xm)])
+        (if (< em 0)
+            (loop (tan (* (ranf) pi)))
+            (let* ([fem (floor em)]
+                   [t (* 0.9
+                         (+ 1.0 (* y y))
+                         (exp (- (* fem palxm)
+                                 (gammln (+ fem 1))
+                                 pg)))])
+              (if (> (ranf) t)
+                  (loop (tan (* pi (ranf))))
+                  fem))))))
+  
+  
+  
+  
+  ;;These are mutating variables that are meant to store computed values to speed up sampling
+  (define bnold -1)
+  (define bpold -1)
+  (define boldg -1)
+  
+  (define (binomial-random n pp)
+    ;Returns as a floating-point number an integer value that is a random deviate drawn from
+    ;a binomial distribution of n trials each of probability pp, using ran1(idum) as a source of
+    ;uniform random deviates.  
+    (let* ([p (if (<= pp 0.5)
+                  pp
+                  (- 1 pp))]
+           [am (* n p)])
+      (if (< n 25)
+          (let loop ([bnl 0] [j 1])
+            (if (<= n j)
+                (if (= p pp)
+                    bnl
+                    (- n bnl))
+                (if (< (ranf) p)
+                    (loop (add1 bnl) (add1 j))
+                    (loop bnl (add1 j)))))
+          (if (< am 1)
+              (let ([g (exp (- am))])
+                (let loop ([t 1] [j 0])
+                  (if (not (<= j n))
+                      (if (= p pp)
+                          n
+                          0)
+                      (let ([t2 (* t (ranf))])
+                        (if (< t g)
+                            (if (< t g)
+                                (if (= p pp)
+                                    j
+                                    (- n j))
+                                (loop t2 (add1 j))))))))
+              
+              (begin
+                (unless (= n bnold)
+                  (set! boldg (gammln (+ n 1)))
+                  (set! bnold n))
+                (let* ([en n]
+                       [pc (- 1 p)]
+                       [plog (ln p)]              ; If sampling is too slow
+                       [pclog (ln pc)]            ; I can gain speed by storing some of these
+                       [sq (sqrt (* 2 am pc))]    ; in mutating, out of function variables
+                       )
+                  (let loop ([angle (* pi (ranf))])
+                    (let* ([y (tan angle)]
+                           [em (+ (* sq y) am)])
+                      (if (or (< em 0) (>= em (+ en 1)))
+                          (loop (* pi (ranf)))
+                          (let ([fem (floor em)]
+                                [t (* 1.2 
+                                      sq  
+                                      (+ (* y y) 1)
+                                      (exp (+ boldg
+                                              (- (gammln (+ em 1)))
+                                              (- (gammln (+ en (- em) 1)))
+                                              (* em plog)
+                                              (* (- en em) pclog))))])
+                            (if (> (ranf) t)
+                                (loop (* pi (ranf)))
+                                (if (= p pp)
+                                    em
+                                    (- n em)))))))))))))
+  
+  
+  
+  (provide (all-defined))
+  )
+
+;(let loop ([x (round (binomial-random 100000 10 .4))])
+;  (loop (round (binomial-random 100000 10 .4))))
+
+
+
+
+;(define (accumulate-mean sampler-event) 
+;  (collect-e sampler-event
+;             (cons 777777 0)  ;;;The number 7777777 never gets used
+;             (lambda (datum mean-count)
+;               (let ([new-count (add1 (cdr mean-count))])
+;                 (cons (+ (/ datum new-count)
+;                          (* (/ (cdr mean-count)
+;                                new-count)
+;                             (car mean-count)))
+;                       new-count)))))
+
+;(accumulate-mean ((changes milliseconds) . ==> . (lambda (_) (normal-random 1000000 5 30))))
diff --git a/collects/frtime/demos/spreadsheet/preprocessor2.ss b/collects/frtime/demos/spreadsheet/preprocessor2.ss
new file mode 100644
index 0000000000..93404b76e5
--- /dev/null
+++ b/collects/frtime/demos/spreadsheet/preprocessor2.ss
@@ -0,0 +1,553 @@
+(module preprocessor2 mzscheme
+  
+  (require (lib "string.ss")
+           (lib "etc.ss")
+           )
+  
+  (define (drop l n)
+    (if (zero? n)
+        l
+        (drop (cdr l) (sub1 n))))
+  
+  (define (caddddr lst)
+    (car (cdr (cdr (cdr (cdr lst))))))
+  
+  (define (first lst)
+    (car lst))
+  
+  (define (take l n)
+    (if (zero? n)
+        '()
+        (cons (car l)
+              (take (cdr l)
+                    (sub1 n)))))
+  
+  ;; ('a -> bool) * 'a list -> (#f or num)
+  (define position-of-first-satisfied-in-list
+    (lambda (pred l)
+      (let loop ((i 0) (l l))
+        (if (null? l) #f
+            (if (pred (car l)) i
+                (loop (+ i 1) (cdr l)))))))
+  
+  (define position-of-object-in-list
+    (lambda (o l)
+      (position-of-first-satisfied-in-list (lambda (x)
+                                             (eqv? o x))
+                                           l)))
+  
+  (define capitals
+    '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z))
+  
+  (define lower-case
+    (let loop ([i 97])
+      (if (<= i 122)
+          (cons (integer->char i)
+                (loop (add1 i)))
+          '())))
+  
+  (define digits
+    '(#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\0))
+  
+  (define (contains? i lst)
+    (and (not (null? lst))
+         (or (equal? i (car lst))
+             (contains? i (cdr lst)))))
+  
+  (define (capital? char)
+    (contains? char capitals))
+  (define (lower-case? char)
+    (contains? char lower-case))
+  (define (digit? char)
+    (contains? char digits))
+  (define (letter? char)
+    (or (capital? char)
+        (lower-case? char)))
+  
+  (define-struct cell-reference (row1 ; num
+                                 row2 ; num 
+                                 row-absolute? ; bool
+                                 col1 ; num
+                                 col2 ; num 
+                                 col-absolute? ; bool
+                                 ))
+  
+  (define (capital->col-num char)
+    (- (char->integer char)
+       65))
+  
+  (define (lower-case->col-num char)
+    (- (char->integer char)
+       97))      
+  
+  #;(define (letter->col-num char)
+      (if (capital? char)
+          (capital->row-num char)
+          (lower-case->row-num char)))
+  
+  (define (digit->row-num char)
+    (- (char->integer char)
+       48))
+  
+  #;(define (letter-list->col-num llst)
+      (let loop ([num -1]
+                 [lst llst])
+        (cond [(null? lst)
+               num]
+              [(capital? (car lst))
+               (loop (+ (* (add1 num) 26)
+                        (capital->row-num (car lst)))
+                     (cdr lst))]
+              [(lower-case? (car lst))
+               (loop (+ (* (add1 num) 26)
+                        (lower-case->col-num (car lst)))
+                     (cdr lst))])))
+  
+  (define (digit-list->row-num nlist)
+    (let loop ([num 0]
+               [lst nlist])
+      (cond [(null? lst)
+             num]
+            [(digit? (car lst))
+             (loop (+  (* num 10)
+                       (digit->row-num (car lst)))
+                   (cdr lst))])))
+  
+  (define NOT-A-CELL-REFERENCE #f)
+  
+  ;; char list -> cell-reference
+  (define (parse-ref char-list)
+    (let loop ([lst char-list]
+               [reading-col-section #t]
+               [row1 #f]
+               [row2 #f]
+               [row-absolute? #f]
+               [col1 #f]
+               [col2 #f]
+               [col-absolute? #f])
+      (cond [(null? lst)
+             (if (and row1 row2 col1 col2 (not reading-col-section))
+                 (make-cell-reference row1 row2 row-absolute? col1 col2 col-absolute?)
+                 NOT-A-CELL-REFERENCE)]
+            [reading-col-section
+             (cond [(equal? (car lst)
+                            #\$)
+                    (if (or col1 col-absolute?) ;; then already hit first $, so this must refer to numbers
+                        (loop lst #f row1 row2 row-absolute? col1 col2 col-absolute?)
+                        (loop (cdr lst)
+                              #t
+                              row1 row2 row-absolute?
+                              col1 col2
+                              #t))]
+                   [(letter? (car lst))
+                    (let ([next (position-of-first-satisfied-in-list 
+                                 (lambda (o)
+                                   (or (equal? o #\$)
+                                       (equal? o #\:)
+                                       (digit? o)))
+                                 lst)])
+                      (if col1
+                          (if next
+                              (if (equal? 'invalid
+                                          (letter-list->col-num (take lst
+                                                                      next)))
+                                  NOT-A-CELL-REFERENCE
+                                  (loop (drop lst next)
+                                        #t ; should get switched in next iteration
+                                        row1 row2 row-absolute? 
+                                        col1 
+                                        (letter-list->col-num (take lst
+                                                                    next)) 
+                                        col-absolute?))
+                              NOT-A-CELL-REFERENCE
+                              )
+                          (if next
+                              (if (equal? 'invalid
+                                          (letter-list->col-num (take lst
+                                                                      next)))
+                                  NOT-A-CELL-REFERENCE
+                                  (loop (drop lst
+                                              next)
+                                        #t
+                                        row1 row2 row-absolute?
+                                        (letter-list->col-num (take lst
+                                                                    next))
+                                        (letter-list->col-num (take lst next))
+                                        col-absolute?))
+                              NOT-A-CELL-REFERENCE
+                              )))]
+                   [(equal? (car lst) #\:)
+                    (if col1
+                        (loop (cdr lst) #t row1 row2 row-absolute? col1 col2 col-absolute?)
+                        NOT-A-CELL-REFERENCE)]
+                   [(digit? (car lst))
+                    (loop lst #f row1 row2 row-absolute? col1 col2 col-absolute?)]
+                   [else NOT-A-CELL-REFERENCE])]
+            [else ; reading NUMBER/ROW section section
+             (cond [(equal? (car lst)
+                            #\$)
+                    (loop (cdr lst) #f row1 row2 #t col1 col2 col-absolute? ;!!
+                          )]
+                   [(digit? (car lst))
+                    (let ([next (position-of-first-satisfied-in-list
+                                 (lambda (o)
+                                   (not (digit? o)))
+                                 lst)])
+                      (if row1
+                          (if next
+                              NOT-A-CELL-REFERENCE
+                              (loop '()
+                                    #f
+                                    row1 
+                                    (digit-list->row-num lst)
+                                    row-absolute?
+                                    col1 col2 col-absolute?))
+                          (if next
+                              (loop (drop lst next)
+                                    #f
+                                    (digit-list->row-num (take lst next))
+                                    (digit-list->row-num (take lst next))
+                                    row-absolute?
+                                    col1 col2 col-absolute?)
+                              (loop '()
+                                    #f
+                                    (digit-list->row-num lst)
+                                    (digit-list->row-num lst)
+                                    row-absolute?
+                                    col1 col2 col-absolute?))))]
+                   [(equal? (car lst)
+                            #\:)
+                    (loop (cdr lst) #t
+                          row1 row2 row-absolute?
+                          col1 col2 col-absolute?)]
+                   [else
+                    NOT-A-CELL-REFERENCE])])))
+  
+  ;
+  ;(define pt1 '(#\a #\b #\1 #\2))
+  ;(define pt1- (make-cell-reference 12 12 #f 27 27 #f))
+  ;(define pt2 '(#\$ #\a #\b #\4))
+  ;(define pt2- (make-cell-reference 4 4 #f 27 27 #t))
+  ;(define pt3 '(#\a #\$ #\4))
+  ;(define pt3- (make-cell-reference 4 4 #t 0 0 #f))
+  ;(define pt4 '(#\a #\: #\e #\5))
+  ;(define pt4- (make-cell-reference 5 5 #f 0 4 #f))
+  ;(define pt5 '(#\z #\1 #\: #\8))
+  ;(define pt5- (make-cell-reference 1 8 #f 25 25 #f))
+  ;(define pt6 '(#\$ #\a #\: #\d #\1))
+  ;(define pt6- (make-cell-reference 1 1 #f 0 3 #t))
+  ;(define pt7 '(#\$ #\a #\$ #\0))
+  ;(define pt7- (make-cell-reference 0 0 #t 0 0 #t))
+  ;
+  ;(define (equal-cell-refs? c1 c2)
+  ;  (and (equal? (cell-reference-row1 c1)
+  ;               (cell-reference-row1 c2))
+  ;       (equal? (cell-reference-row2 c1)
+  ;               (cell-reference-row2 c2))
+  ;       (equal? (cell-reference-row-absolute? c1)
+  ;               (cell-reference-row-absolute? c2))
+  ;       (equal? (cell-reference-col1 c1)
+  ;               (cell-reference-col1 c2))
+  ;       (equal? (cell-reference-col2 c1)
+  ;               (cell-reference-col2 c2))
+  ;       (equal? (cell-reference-col-absolute? c1)
+  ;               (cell-reference-col-absolute? c2))))
+  ;
+  ;(equal-cell-refs? (parse-ref pt1) pt1-)
+  ;(equal-cell-refs? (parse-ref pt2) pt2-)
+  ;(equal-cell-refs? (parse-ref pt3) pt3-)
+  ;(equal-cell-refs? (parse-ref pt4) pt4-)
+  ;(equal-cell-refs? (parse-ref pt5) pt5-)
+  ;(equal-cell-refs? (parse-ref pt6) pt6-)
+  ;(equal-cell-refs? (parse-ref pt7) pt7-)
+  
+  
+  (define mapped-symbols
+    '(+
+      length
+      =
+      if
+      quote
+      *
+      seconds
+      add1
+      map))  
+  
+  
+  ;process: sexp symbol symbol symbol symbol num num -> sexp
+  ;INPUT: An expression EXPR, the name of lookup procedures LOOKUP, LOOKUP-ROW, LOOKUP-COL, LOOKUP-MATRIX and the current row and column
+  ; for the cell being processed, ROW and COL.
+  ;OUTPUT: blah blah blah
+  (define (process expr lookup lookup-row lookup-col lookup-matrix row col)
+    (define (cell-ref->sexp cref c-row c-col)
+      ;; cell-reference * num * num -> sexp
+      (let ([ref-row1 (cell-reference-row1 cref)]
+            [ref-col1 (cell-reference-col1 cref)]
+            [ref-row2 (cell-reference-row2 cref)]
+            [ref-col2 (cell-reference-col2 cref)]
+            [row-ref-expr (lambda (n)
+                            (if (cell-reference-row-absolute? cref)
+                                n
+                                (list '+ 'row (- n c-row))))]
+            [col-ref-expr (lambda (n)
+                            (if (cell-reference-col-absolute? cref)
+                                n
+                                (list '+ 'col (- n c-col))))])
+        (if (not (= ref-row1 ref-row2))
+            (if (not (= ref-col1 ref-col2))
+                (list lookup-matrix 
+                      (row-ref-expr ref-row1)
+                      (row-ref-expr ref-row2)
+                      (col-ref-expr ref-col1)
+                      (col-ref-expr ref-col2))
+                (list lookup-col 
+                      (row-ref-expr ref-row1)
+                      (row-ref-expr ref-row2)
+                      (col-ref-expr ref-col1)))
+            (if (not (= ref-col1 ref-col2))
+                (list lookup-row
+                      (row-ref-expr ref-row1)
+                      (col-ref-expr ref-col1)
+                      (col-ref-expr ref-col2))
+                (list lookup
+                      (row-ref-expr ref-row1)
+                      (col-ref-expr ref-col1))))))
+    ;; end of cell reference handling
+    (cond [(symbol? expr)
+           (let ([parsed (parse-ref (string->list (symbol->string expr)))])
+             (cond [parsed (cell-ref->sexp parsed row col)]
+                   [else ;; currently allowing all symbols.
+                    expr]))]
+          [(list? expr)
+           (if (and (not (null? expr))
+                    (equal? 'quote (car expr)))
+               expr
+               (map (lambda (sexp)
+                      (process sexp lookup lookup-row lookup-col lookup-matrix row col))
+                    expr))]
+          [else expr]))
+  
+  
+  
+  
+  ;(define t1 "a:zz$1")
+  ;(define t2 "length")
+  ;(define t3 "(+ 3 4)")
+  ;(define t4 "(+ 2 a3)")
+  ;(define t5 "(if (= 3 (length A1)) (a2 $A3) 'dont-see)")
+  ;(define t6 "(ZD941 A:d3:40)")
+  ;
+  ;(define p (lambda (e)
+  ;            (process (read (open-input-string e)) 'lookup 'lookup-row 'lookup-col 'lookup-matrix 1 1)))
+  ;t1 (p t1)
+  ;t2 (p t2)
+  ;t3 (p t3)
+  ;t4 (p t4)
+  ;t5 (p t5)
+  ;t6 (p t6)
+  
+  
+  ;;  ISSUES:
+  ;;     - When going from cell-references to symbols, be careful about LETTERS referring to COLUMNS
+  ;;       and NUMBERS referring to ROWS.  Some procedures are still BROKEN because of this.
+  ;;     
+  ;;     - Now a lookup expression has more information about what sort of region it is looking up
+  ;;       (singleton, row, column, matrix).  Use this when converting from lookup expressions to
+  ;;       cell references.
+  ;;
+  ;;     - Now that lookup expressions contain all the information contained within cell references,
+  ;;       the intermediate step between expressions and cell references is UNNECESSARY.  I should
+  ;;       have procedure's LOOKUP-EXPR->SYMBOL that take care of everything for the UNPROCESSOR.
+  ;;
+  (define (letter-list->col-num llst)
+    (let ([col-num (let loop ([num -1]
+                              [lst llst])
+                     (cond [(null? lst)
+                            num]
+                           [(capital? (car lst))
+                            (loop (+ (* (add1 num) 26)
+                                     (capital->col-num (car lst)))
+                                  (cdr lst))]
+                           [(lower-case? (car lst))
+                            (loop (+ (* (add1 num) 26)
+                                     (lower-case->col-num (car lst)))
+                                  (cdr lst))]))])
+      (if (>= col-num 702)
+          'invalid
+          col-num)))
+  
+  ; num -> char list
+  (define (col-num->letter-list n)
+    (let loop ([num n]
+               [lst '()])
+      (cond [(= -1 num)
+             lst]
+            [else (loop (sub1 (quotient num 26))
+                        (cons (integer->char (+ 97 (remainder num 26)))
+                              lst))])))
+  
+  ; num -> char list
+  (define (row-num->digit-list n)
+    (define help 
+      (lambda (n)
+        (let ([r (remainder n 10)]
+              [q (quotient n 10)])
+          (if (zero? q)
+              (list (integer->char (+ 48 n)))
+              (cons (integer->char (+ 48 r))
+                    (help q))))))
+    (reverse (help n)))
+  
+  
+  
+  (define (lookup-expr->symbol expr local-row local-col)
+    (let* ([row-expr (cadr expr)]
+           [col-expr (caddr expr)]
+           [row-chars (cond [(number? row-expr)
+                             (cons #\$
+                                   (row-num->digit-list row-expr))]
+                            [(list? row-expr)
+                             (row-num->digit-list (+ local-row
+                                                     (caddr row-expr)))])]
+           [col-chars (cond [(number? col-expr)
+                             (cons #\$
+                                   (col-num->letter-list col-expr))]
+                            [(list? col-expr)
+                             (col-num->letter-list (+ local-col
+                                                      (caddr col-expr)))])])
+      
+      (string->symbol (list->string (append col-chars
+                                            row-chars)))))
+  
+  (define (lookup-row-expr->symbol expr local-row local-col)
+    (let* ([row-expr (cadr expr)]
+           [col1-expr (caddr expr)]
+           [col2-expr (cadddr expr)]
+           [row-chars (cond [(number? row-expr)
+                             (cons #\$
+                                   (row-num->digit-list row-expr))]
+                            [(list? row-expr)
+                             (row-num->digit-list (+ local-row
+                                                     (caddr row-expr)))])]
+           [col1-chars (cond [(number? col1-expr)
+                              (cons #\$
+                                    (col-num->letter-list col1-expr))]
+                             [(list? col1-expr)
+                              (col-num->letter-list (+ local-col
+                                                       (caddr col1-expr)))])]
+           [col2-chars (cons #\:
+                             (cond [(number? col2-expr)
+                                    (col-num->letter-list col2-expr)]
+                                   [(list? col2-expr)
+                                    (col-num->letter-list (+ local-col
+                                                             (caddr col2-expr)))]))])
+      (string->symbol (list->string (append col1-chars
+                                            col2-chars
+                                            row-chars)))))
+  
+  (define (lookup-col-expr->symbol expr local-row local-col)
+    (let* ([row1-expr (cadr expr)]
+           [row2-expr (caddr expr)]
+           [col-expr (cadddr expr)]
+           [row1-chars (cond [(number? row1-expr)
+                              (cons #\$
+                                    (row-num->digit-list row1-expr))]
+                             [(list? row1-expr)
+                              (row-num->digit-list (+ local-row
+                                                      (caddr row1-expr)))])]
+           [row2-chars (cons #\:
+                             (cond [(number? row2-expr)
+                                    (row-num->digit-list row2-expr)]
+                                   [(list? row2-expr)
+                                    (row-num->digit-list (+ local-row
+                                                            (caddr row2-expr)))]))]
+           [col-chars (cond [(number? col-expr)
+                             (cons #\$
+                                   (col-num->letter-list col-expr))]
+                            [(list? col-expr)
+                             (col-num->letter-list (+ local-col
+                                                      (caddr col-expr)))])])
+      
+      (string->symbol (list->string (append col-chars
+                                            row1-chars
+                                            row2-chars)))))
+  
+  (define (lookup-matrix-expr->symbol expr local-row local-col)
+    (let* ([row1-expr (cadr expr)]
+           [row2-expr (caddr expr)]
+           [col1-expr (cadddr expr)]
+           [col2-expr (caddddr expr)]
+           [row1-chars (cond [(number? row1-expr)
+                              (cons #\$
+                                    (row-num->digit-list row1-expr))]
+                             [(list? row1-expr)
+                              (row-num->digit-list (+ local-row
+                                                      (caddr row1-expr)))])]
+           [row2-chars (cons #\:
+                             (cond [(number? row2-expr)
+                                    (row-num->digit-list row2-expr)]
+                                   [(list? row2-expr)
+                                    (row-num->digit-list (+ local-row
+                                                            (caddr row2-expr)))]))]
+           [col1-chars (cond [(number? col1-expr)
+                              (cons #\$
+                                    (col-num->letter-list col1-expr))]
+                             [(list? col1-expr)
+                              (col-num->letter-list (+ local-col
+                                                       (caddr col1-expr)))])]
+           [col2-chars (cons #\:
+                             (cond [(number? col2-expr)
+                                    (col-num->letter-list col2-expr)]
+                                   [(list? col2-expr)
+                                    (col-num->letter-list (+ local-col
+                                                             (caddr col2-expr)))]))])
+      (string->symbol (list->string (append col1-chars
+                                            col2-chars
+                                            row1-chars
+                                            row2-chars)))))
+  
+  
+  
+  ; sexp * symbol * symbol *symbol *symbol num * num -> sexp
+  (define (unprocess expr lookup lookup-row lookup-col lookup-matrix local-row local-col)
+    (cond [(list? expr)
+           (cond [(null? expr)
+                  '()]
+                 [(equal? (first expr) lookup)
+                  (lookup-expr->symbol expr local-row local-col)]
+                 [(equal? (first expr) lookup-row)
+                  (lookup-row-expr->symbol expr local-row local-col)]
+                 [(equal? (first expr) lookup-col)
+                  (lookup-col-expr->symbol expr local-row local-col)]
+                 [(equal? (first expr) lookup-matrix)
+                  (lookup-matrix-expr->symbol expr local-row local-col)]
+                 [(equal? (first expr) 'quote)
+                  expr]
+                 [else
+                  (map (lambda (e)
+                         (unprocess e lookup lookup-row lookup-col
+                                    lookup-matrix local-row local-col))
+                       expr)])]
+          [else
+           expr]))
+  ;               
+  ;(define te1
+  ;  '((lookup 3 4) 
+  ;    '(lookup 3 4) 
+  ;    (1 2 (lookup 0 0)) 
+  ;    (lookup-matrix (+ row 0) (+ row 5) (+ col 2) (+ col 5))
+  ;    (lookup-row 5 (+ col 1) (+ col 20))
+  ;    (lookup-col 3  39 (+ col 0))))
+  ;
+  ;(unprocess te1 
+  ;           'lookup
+  ;           'lookup-row
+  ;           'lookup-col
+  ;           'lookup-matrix
+  ;           1
+  ;           1)
+  
+  
+  (provide process unprocess)
+  
+  )
\ No newline at end of file
diff --git a/collects/frtime/demos/spreadsheet/quotes.ss b/collects/frtime/demos/spreadsheet/quotes.ss
new file mode 100644
index 0000000000..6f56e30ece
--- /dev/null
+++ b/collects/frtime/demos/spreadsheet/quotes.ss
@@ -0,0 +1,75 @@
+(module quotes mzscheme
+  (require (lib "url.ss" "net"))
+  (require (lib "list.ss"))
+  
+  (provide no-quote? stock-quote no-quote-reason)
+  
+  (define-struct no-quote (company reason))
+  
+  #| ----------------------------------------------------------------------------
+  Stock and Fund Quotes
+  ---------------------
+  
+  procedures: 
+  stock-quote : String -> Number 
+  
+  exceptions: 
+  no-quote : (structure:no-quote String Symbol)
+  
+  The goal is to send a request to some quote server, 
+  read the page line by line, and identify the quote. 
+  
+  -----------------------------------------------------
+  
+  First: where the information comes from and 
+  how to indentify it within the page: 
+  - the current source is Yahoo's page
+  - we look for a table cell that looks like
+  this: <td nowrap><b>DIGIT*.DIGITDIGIT</b></td>
+  |#   
+  
+  ; String[format: String[company name]]
+  (define SOURCE "http://finance.yahoo.com/q?s=~a&d=v1")
+  
+  ; String -> (union (list String String) #f)
+  (define (find x)
+    (regexp-match "<b>([0-9\\.]*)</b></big></td>" x))
+  
+  ; String -> Number
+  (define (stock-quote company)
+    (let* ([URL (string->url (format SOURCE company))]
+           [PG  (call/input-url URL get-pure-port read-a-page)]
+	   ; [_ (printf "~s~n" PG)] ; for debugging
+           [LN  (filter find PG)]
+           [QT  (if (pair? LN)
+                    (cadr (find (car LN)))
+                    (raise (make-no-quote company 'find)))])
+      (cond
+        [(string->number QT)]
+        [else (raise (make-no-quote company 'no-number))])))
+  
+  
+  ;; Iport -> (listof String)
+  ;; reading a page as a list of lines
+  (define (read-a-page ip)
+    (letrec ([reader (lambda ()
+                       (let ([next (read-line)])
+                         (cond
+                           [(eof-object? next) '()]
+                           [else (cons next (reader))])))])
+      (parameterize ([current-input-port ip])
+        (reader))))
+  
+  #| TESTS:
+  
+  (map stock-quote '(; companies 
+                     "BAC" "DELL" "IBM" 
+                     ; funds 
+                     "PRSCX" "NAESX" "FRBAX"))
+  
+  (with-handlers ([no-quote? (lambda (x) (eq? (no-quote-reason x) 'find))])
+    (stock-quote "XXX"))
+  
+  |#
+  
+  )
diff --git a/collects/frtime/demos/spreadsheet/spread.ss b/collects/frtime/demos/spreadsheet/spread.ss
new file mode 100644
index 0000000000..b9f21d4b44
--- /dev/null
+++ b/collects/frtime/demos/spreadsheet/spread.ss
@@ -0,0 +1,633 @@
+(module spread (lib "frtime-big.ss" "frtime")
+  
+  (require (lib "class.ss")
+           (all-except (lib "mred.ss" "mred") send-event)
+           "preprocessor2.ss"
+           (lifted "ss-funcs.ss" inflate-data)
+           "quotes.ss"
+           (as-is:unchecked (lib "match.ss") match-lambda)
+           (lib "framework.ss" "framework")
+           (as-is:unchecked (lib "string.ss") expr->string)
+           (as-is:unchecked (lib "etc.ss") build-vector)
+           (lifted mzscheme regexp-match)
+           (as-is:unchecked mzscheme make-hash-table hash-table-put! hash-table-get
+                            hash-table-remove! let*-values vector-set! make-string
+                            exn? eof-object?
+                            open-input-file open-output-file read write hash-table-map
+                            file-exists? delete-file open-input-string eof
+                            flush-output close-output-port dynamic-require))
+  ;;
+  ;; TO DO:
+  ;; 
+  ;; rewrite cleanly
+  ;; case-insensitive and relative identifier expansion with ranges
+  ;; select multiple cells
+  ;; fill row or column
+  ;; copy and paste formula
+  ;; disable text field when selection empty
+  ;; allow resizing of columns
+  
+  ;; KNOWN BUGS:
+  ;; when loading file, expression text field does not update
+  
+  (define stock-price
+    (opt-lambda (name-string [seconds-between 1200])
+      (lift-strict (lambda (name _) (stock-quote name)) name-string (quotient seconds seconds-between))))
+  
+  (define-syntax for
+    (syntax-rules (=)
+      [(_ (var = init) condn delta proc ...)
+       (let loop ([var init])
+         (when condn
+           proc ...
+           (loop (delta var))))]))
+  
+  (set-cell! raise-exceptions #t)
+  
+  (define-struct ss-loc (row col))
+  
+  (define (ss-format val)
+    (if (or (and (signal? val)
+                 (undefined? (signal-value val)))
+            (and (not (signal? val))
+                 (undefined? val)))
+        ""
+        (format "~a" (signal-value val))))
+  
+  (define (@e r c)
+    (ss-get-cell-value/force r c))
+  
+  (define (@c r0 r1 c)
+    (build-list (add1 (abs (- r1 r0)))
+                (lambda (i)
+                  (@e (+ i (min r1 r0)) c))))
+  
+  (define (@r r c0 c1)
+    (build-list (add1 (abs (- c1 c0)))
+                (lambda (i)
+                  (@e r (+ i (min c1 c0))))))
+  
+  (define (@m r0 r1 c0 c1)
+    (build-list (add1 (abs (- c1 c0)))
+                (lambda (i)
+                  (@c r0 r1 (+ i (min c1 c0))))))
+  
+  (define frame
+    (instantiate frame% ("Spreadsheet") (width 600) (height 400)))
+  
+  (define menu-bar
+    (instantiate menu-bar% (frame)))
+  
+  (define file-menu
+    (instantiate menu% ("File" menu-bar)))
+  
+  (define open-item
+    (instantiate menu-item%
+      ("Open..."
+       file-menu
+       (lambda (_ event) 
+         (cond
+           [(finder:get-file)
+            =>
+            (lambda (filename)
+              (let ([p (open-input-file filename)])
+                (for (i = 0) (< i cols) add1
+                     (vector-set! vec i (make-hash-table))
+                     (for-each (lambda (elt) #;(printf "adding ~a ~a ~a~n" (first elt) i (second elt))
+                                 (ss-set-cell-processed-expr! (first elt) i (process (second elt) '@e '@r '@c '@m (first elt) i))) (read p))))
+              (send canvas refresh))])))
+      (shortcut #\O)))
+  
+  (define save-item
+    (instantiate menu-item%
+      ("Save as..."
+       file-menu
+       (lambda (_ event)
+         (cond
+           [(finder:put-file)
+            =>
+            (lambda (filename)
+              (when (file-exists? filename)
+                (delete-file filename))
+              (let ([p (open-output-file filename)])
+                (for (i = 0) (i . < . cols) add1
+                     (let ([v (hash-table-map (vector-ref vec i) (lambda (row cell) (list row (ss-cell-expr cell))))])
+                       #;(printf "~a~n" v)
+                       (write v p)))
+                (flush-output p)
+                (close-output-port p)))])))
+      (shortcut #\S)))
+  
+  (define edit-menu
+    (instantiate menu% ("Edit" menu-bar)))
+  
+  (define text-field
+    (instantiate text-field%
+      ("Formula:"
+       frame
+       (lambda (this control-event)
+         (case (send control-event get-event-type)
+           [(text-field-enter) (send canvas new-expression (send this get-value))])))))
+  
+  (define value-field
+    (instantiate text-field%
+      ("Value:" frame void)))
+  (send value-field enable #f)
+  
+  (define rows 1000)
+  (define cols 100)
+  
+  (define vec
+    (build-vector
+     cols
+     (lambda (_) (make-hash-table))))
+  
+  (define-struct ss-cell (expr value updater))
+  
+  (define (ss-get-cell-text row col)
+    (cond
+      [(hash-table-get (vector-ref vec col) row (lambda () #f))
+       => (lambda (cell)
+            (let ([expr (unprocess (ss-cell-expr cell) '@e '@r '@c '@m row col)])
+              (if (eq? expr 'undefined)
+                  ""
+                  (expr->string expr))))]
+      [else ""]))
+  
+  (define (ss-get-cell-value row col)
+    (cond
+      [(hash-table-get (vector-ref vec col) row (lambda () #f))
+       => ss-cell-value]
+      [else undefined]))
+  
+  (define (fresh-ss-cell row col)
+    (let* ([value (new-cell)]
+           [ret (make-ss-cell
+                 'undefined value
+                 (proc->signal
+                  (lambda () (send canvas draw-cell row col))
+                  value))])
+      (hash-table-put! (vector-ref vec col) row ret)
+      ret))
+  
+  (define (ss-get-cell-value/force row col)
+    (ss-cell-value (hash-table-get (vector-ref vec col) row (lambda () (fresh-ss-cell row col)))))
+  
+  (define (text->processed-expr txt row col)
+    (let* ([expr
+            (with-handlers
+                ([exn? (lambda (exn)
+                         (message-box
+                          "Error"
+                          (format "The expression you entered is invalid:~n~a"
+                                  (exn-message exn))
+                          frame
+                          '(ok stop))
+                         eof)])
+              (read (open-input-string txt)))])
+      (if (eof-object? expr)
+          'undefined
+          (process expr '@e '@r '@c '@m row col))))
+  
+  ;; should not (and does not) remove when cells are emptied
+  ;; should not reset when expression is the same
+  (define (ss-set-cell-processed-expr! row col processed-expr)
+    (let* ([cell
+            (hash-table-get
+             (vector-ref vec col) row
+             (lambda ()
+               (fresh-ss-cell row col)))])
+      (when (not (equal? (ss-cell-expr cell) processed-expr))
+        (set-ss-cell-expr! cell processed-expr)
+        (set-cell! (ss-cell-value cell)
+                   (with-handlers
+                       ([exn? (lambda (exn)
+                                (message-box
+                                 "Error"
+                                 (format "The following error occurred while evaluating a formula:~n~a"
+                                         (exn-message exn))
+                                 frame
+                                 '(ok stop))
+                                "#<Error>")])
+                     (eval `(let ([row ,row]
+                                  [col ,col])
+                              ,processed-expr))))
+        (synchronize)
+        (send canvas draw-cell row col))
+      (send canvas focus)))
+  
+  (define chars-per-cell 14)
+  
+  (define (take-upto n lst)
+    (if (and (positive? n)
+             (cons? lst))
+        (cons (first lst) (take-upto (sub1 n) (rest lst)))
+        empty))
+  
+  (define (history-e n b)
+    (collect-e (changes b) (list (value-now b)) (lambda (ev acc) (take-upto n (cons ev acc)))))
+  
+  (define (clip lo x hi)
+    (max lo (min x hi)))
+  
+  (define (between x y z)
+    (or (<= x y z)
+        (<= z y x)))
+  
+  (define ss-canvas%
+    (class canvas%
+      (super-instantiate ())
+      
+      (inherit
+        refresh
+        get-dc
+        get-scroll-pos
+        get-client-size
+        set-scroll-range
+        set-scroll-page
+        init-manual-scrollbars)
+      
+      (override
+        set-scroll-pos
+        on-event
+        on-paint
+        on-scroll
+        on-size
+        on-char)
+      
+      (field
+       [can-refresh? #t]
+       [offscreen-dc (new bitmap-dc% (bitmap (make-object bitmap% 1280 1024 #f)))]
+       
+       [char-width (inexact->exact (send offscreen-dc get-char-width))]
+       [cell-width (* chars-per-cell char-width)]
+       [cell-height (+ 2 (inexact->exact (send offscreen-dc get-char-height)))]
+       
+       [left-margin (* 5 char-width)]
+       [top-margin cell-height]
+       
+       [canvas-width-rcvr (event-receiver)]
+       [canvas-height-rcvr (event-receiver)]
+       [h-scroll-rcvr (event-receiver)]
+       [v-scroll-rcvr (event-receiver)]
+       [mouse-x-rcvr (event-receiver)]
+       [mouse-y-rcvr (event-receiver)]
+       [left-clicks (event-receiver)]
+       [left-releases (event-receiver)]
+       [key-events (event-receiver)]
+       
+       [canvas-width~ (hold canvas-width-rcvr)]
+       [canvas-height~ (hold canvas-height-rcvr)]
+       
+       [mouse-x~ (hold mouse-x-rcvr 0)]
+       [mouse-y~ (hold mouse-y-rcvr 0)]
+       
+       [left-button-down~ (hold (merge-e (left-clicks   . -=> . #t)
+                                         (left-releases . -=> . #f))
+                                #f)]
+       
+       [h-chars-per-page~ (quotient (- canvas-width~ left-margin) char-width)]
+       [v-cells-per-page~ (quotient (- canvas-height~ top-margin) cell-height)]
+       [h-scroll-range~ (max 0 (- (* cols chars-per-cell) h-chars-per-page~))]
+       [v-scroll-range~ (max 0 (- rows v-cells-per-page~))]
+       
+       [h-scroll-pos~ (hold h-scroll-rcvr 0)]
+       [v-scroll-pos~ (hold v-scroll-rcvr 0)]
+       [h-scroll-cells~ (quotient h-scroll-pos~ chars-per-cell)]
+       [h-scroll-offset~ (* char-width (remainder h-scroll-pos~ chars-per-cell))]
+       [v-scroll-cells~ v-scroll-pos~]
+       
+       [mouse-row~ (y->row mouse-y~)]
+       [mouse-col~ (x->col mouse-x~)]
+       
+       [first-vis-row~ (y->row (add1 top-margin))]
+       [last-vis-row~ (y->row (sub1 canvas-height~))]
+       [first-vis-col~ (x->col (add1 left-margin))]
+       [last-vis-col~ (x->col (sub1 canvas-width~))]
+       
+       [start-sel-row~
+        (accum-b
+         (merge-e
+          (left-clicks . -=> . (lambda (_) (value-now mouse-row~)))
+          (key-events  . ==> . (lambda (key)
+                                 (lambda (prev)
+                                   (case (send key get-key-code)
+                                     [(up) (max 0 (sub1 prev))]
+                                     [(down) (min (sub1 rows) (add1 prev))]
+                                     [else prev])))))
+         0)]
+       [start-sel-col~
+        (accum-b
+         (merge-e
+          (left-clicks . -=> . (lambda (_) (value-now mouse-col~)))
+          (key-events  . ==> . (lambda (key)
+                                 (lambda (prev)
+                                   (case (send key get-key-code)
+                                     [(left) (max 0 (sub1 prev))]
+                                     [(right) (min (sub1 cols) (add1 prev))]
+                                     [else prev])))))
+         0)]
+       
+       [cur-sel-row~
+        (hold (merge-e
+               (changes start-sel-row~)
+               ((changes start-sel-col~) . -=> . (value-now start-sel-row~))
+               ((changes mouse-row~) . =#> . (lambda (_)
+                                               left-button-down~))) 0)]
+       [cur-sel-col~
+        (hold (merge-e
+               (changes start-sel-col~)
+               ((changes start-sel-row~) . -=> . (value-now start-sel-col~))
+               ((changes mouse-col~) . =#> . (lambda (_)
+                                               left-button-down~))) 0)]
+       
+       [scrollbar-updater
+        (list
+         (lift #t (lambda (pg) (set-scroll-page 'horizontal (clip 1 (- pg chars-per-cell -1) 10000))) h-chars-per-page~)
+         (lift #t (lambda (pg) (set-scroll-page 'vertical (clip 1 (sub1 pg) 10000))) v-cells-per-page~)
+         (lift #t (lambda (rng) (set-scroll-range 'horizontal (clip 1 rng 10000))) h-scroll-range~)
+         (lift #t (lambda (rng) (set-scroll-range 'vertical (clip 1 rng 10000))) v-scroll-range~))]
+       
+       [scroller ((merge-e (changes h-scroll-pos~)
+                           (changes v-scroll-pos~)) . -=> . (refresh))]
+       
+       [v-auto-scroller (merge-e
+                         ((while-e (and left-button-down~
+                                        (>= cur-sel-row~ last-vis-row~)
+                                        (< cur-sel-row~ (sub1 rows))
+                                        (not (= cur-sel-row~ start-sel-row~))) 50)
+                          . -=> . (set-scroll-pos 'vertical (add1 (value-now v-scroll-pos~))))
+                         ((while-e (and left-button-down~
+                                        (<= cur-sel-row~ first-vis-row~)
+                                        (> cur-sel-row~ 0)
+                                        (not (= cur-sel-row~ start-sel-row~))) 50)
+                          . -=> . (set-scroll-pos 'vertical (sub1 (value-now v-scroll-pos~))))
+                         (key-events
+                          . ==> .
+                          (lambda (ev)
+                            (case (send ev get-key-code)
+                              [(prior) (set-scroll-pos 'vertical (max 0 (- (value-now v-scroll-pos~) (value-now v-cells-per-page~))))]
+                              [(next) (set-scroll-pos 'vertical (min (value-now v-scroll-range~)
+                                                                     (+ (value-now v-scroll-pos~) (value-now v-cells-per-page~))))]))))]
+       
+       [h-auto-scroller (merge-e
+                         ((while-e (and left-button-down~
+                                        (>= cur-sel-col~ last-vis-col~)
+                                        (< h-scroll-pos~ h-scroll-range~)) 50)
+                          . -=> . (set-scroll-pos 'horizontal (+ 3 (value-now h-scroll-pos~))))
+                         ((while-e (and left-button-down~
+                                        (<= cur-sel-col~ first-vis-col~)
+                                        (> h-scroll-pos~ 0)) 50)
+                          . -=> . (set-scroll-pos 'horizontal (+ -3 (value-now h-scroll-pos~)))))]
+       
+       [highlighter (merge-e
+                     ((history-e 2 (list mouse-row~ mouse-col~))
+                      . ==> .
+                      (lambda (lst)
+                        (for-each
+                         (lambda (p)
+                           (draw-cell (first p) (second p)))
+                         lst)))
+                     ((history-e 2 (list start-sel-row~ start-sel-col~ cur-sel-row~ cur-sel-col~))
+                      . ==> .
+                      (match-lambda
+                        [((r01 c01 rf1 cf1) (r00 c00 rf0 cf0))
+                         (cond
+                           [(and (= r01 rf1) (= c01 cf1))
+                            ; fresh selection: clear old selection, redraw new cell
+                            (draw-cell-block r00 rf0 c00 cf0)
+                            (draw-cell r01 c01)]
+                           [else
+                            ; extended selection, so r00 = r01 and c00 = c01
+                            (draw-cell-block rf0 rf1 (min c00 cf0 cf1) (max c00 cf0 cf1))
+                            (draw-cell-block (min r00 rf0 rf1) (max r00 rf0 rf1) cf0 cf1)
+                            (draw-cell-block rf0 rf1 cf0 cf1)])])))]
+       
+       [focuser ((key-events . =#> . (lambda (ev) (eq? #\return (send ev get-key-code))))
+                 . -=> . (send text-field focus))]
+       
+       [text-field-switcher (lift #t (lambda (row col)
+                                       (unless (or (negative? row)
+                                                   (negative? col))
+                                         (send text-field set-value (ss-get-cell-text row col))))
+                                  start-sel-row~ start-sel-col~)]
+       
+       [light-steel-blue (make-object color% "LightSteelBlue")]
+       [lavender (make-object color% "Lavender")]
+       [white (make-object color% "White")]
+       [line-pen (make-object pen% (make-object color% "DimGray") 1 'solid)]
+       [light-gray (make-object color% "LightGray")]
+       [trans-pen (make-object pen%)]
+       [default-font (send offscreen-dc get-font)]
+       [label-font (make-object font% 11 'roman 'normal 'bold)]
+       [gray-brush (make-object brush% light-gray 'solid)]
+       [highlight-brush (make-object brush% lavender 'solid)]
+       [selected-brush (make-object brush% light-steel-blue 'solid)]
+       [clear-brush (make-object brush% white 'solid)])
+      
+      (send trans-pen set-style 'transparent)
+      
+      (define (set-scroll-pos which pos)
+        (super set-scroll-pos which pos)
+        (send-event
+         (case which
+           [(horizontal) h-scroll-rcvr]
+           [(vertical) v-scroll-rcvr]) pos))
+      
+      (define/private (x->col x)
+        (if (> x left-margin)
+            (+ h-scroll-cells~ (quotient (+ (- x left-margin) h-scroll-offset~) cell-width))
+            -1))
+      
+      (define/private (y->row y)
+        (if (> y top-margin)
+            (+ v-scroll-cells~ (quotient (- y top-margin) cell-height))
+            -1))
+      
+      (define/private (row->y-top row)
+        (snapshot/sync (v-scroll-cells~)
+                       (+ (* cell-height (- row v-scroll-cells~))
+                          top-margin)))
+      
+      (define/private (col->x-left col)
+        (snapshot/sync (h-scroll-cells~ h-scroll-offset~)
+                       (+ (* (- col h-scroll-cells~) cell-width)
+                          (- h-scroll-offset~)
+                          left-margin)))
+      
+      #;(define foo (lift #t printf "~a ~a ~a ~a~n" cur-sel-row~ cur-sel-col~ start-sel-row~ start-sel-col~))
+      
+      (define/public (draw-cell-block r0 rf c0 cf)
+        (let ([r0 (min r0 rf)]
+              [rf (max r0 rf)]
+              [c0 (min c0 cf)]
+              [cf (max c0 cf)])
+          (for (i = r0) (i . <= . rf) add1
+               (for (j = c0) (j . <= . cf) add1
+                    (draw-cell-offscreen i j)))
+          (let ([x0 (col->x-left c0)]
+                [y0 (row->y-top r0)]
+                [xf (col->x-left (add1 cf))]
+                [yf (row->y-top (add1 rf))])
+            (send (get-dc)
+                  draw-bitmap-section (send offscreen-dc get-bitmap)
+                  x0 y0 x0 y0 (- xf x0) (- yf y0)))))
+      
+      (define/public (draw-cell-block-offscreen r0 rf c0 cf)
+        (let ([r0 (min r0 rf)]
+              [rf (max r0 rf)]
+              [c0 (min c0 cf)]
+              [cf (max c0 cf)])
+          (for (i = r0) (i . <= . rf) add1
+               (for (j = c0) (j . <= . cf) add1
+                    (draw-cell-offscreen i j)))))
+      
+      (define/public (new-expression text)
+        (snapshot/sync (cur-sel-row~ cur-sel-col~ start-sel-row~ start-sel-col~)
+                       (let ([r0 (min cur-sel-row~ start-sel-row~)]
+                             [r1 (max cur-sel-row~ start-sel-row~)]
+                             [c0 (min cur-sel-col~ start-sel-col~)]
+                             [c1 (max cur-sel-col~ start-sel-col~)]
+                             [processed-expr (text->processed-expr text start-sel-row~ start-sel-col~)])
+                         (for (row = r0) (row . <= . r1) add1
+                              (for (col = c0) (col . <= . c1) add1
+                                   (ss-set-cell-processed-expr! row col processed-expr))))
+                       (send canvas focus)))
+      
+      (define (draw-cell-offscreen row col)
+        (snapshot/sync (first-vis-row~
+                        last-vis-row~
+                        first-vis-col~ last-vis-col~
+                        mouse-row~ mouse-col~
+                        start-sel-row~ start-sel-col~
+                        cur-sel-row~ cur-sel-col~)
+                       (let ([x (col->x-left col)]
+                             [y (row->y-top row)])
+                         (when (and (< -1 row rows)
+                                    (< -1 col cols))
+                           (let ([text (ss-format (ss-get-cell-value row col))])
+                             (when (and (= row start-sel-row~)
+                                        (= col start-sel-col~))
+                               (send value-field set-value text))
+                             (when (and (<= first-vis-row~ row last-vis-row~)
+                                        (<= first-vis-col~ col last-vis-col~))
+                               (send offscreen-dc set-clipping-rect
+                                     (max x (+ left-margin 1)) y cell-width cell-height)
+                               (send offscreen-dc set-brush
+                                     (cond
+                                       [(and (between start-sel-row~ row cur-sel-row~)
+                                             (between start-sel-col~ col cur-sel-col~)) selected-brush]
+                                       [(and (= row mouse-row~)
+                                             (= col mouse-col~)) highlight-brush]
+                                       [else clear-brush]))
+                               (send offscreen-dc draw-rectangle x y (+ cell-width 1) (+ cell-height 1))
+                               (send offscreen-dc draw-text text
+                                     (- (+ x cell-width) 2
+                                        (let-values ([(width height descent space)
+                                                      (send offscreen-dc get-text-extent text #f #f 0)])
+                                          width))
+                                     (+ y 1) #f 0 0)
+                               (send offscreen-dc set-clipping-region #f)))))))
+      
+      (define/public (draw-cell row col)
+        (draw-cell-offscreen row col)
+        (let ([x (col->x-left col)]
+              [y (row->y-top row)])
+          (send (get-dc)
+                draw-bitmap-section (send offscreen-dc get-bitmap)
+                x y x y cell-width cell-height)))
+      
+      (define (get-text-width dc text)
+        (let-values ([(width height descent space)
+                      (send dc get-text-extent text #f #f 0)])
+          width))
+      
+      (define (num->char n)
+        (integer->char (+ n (char->integer #\A))))
+      
+      (define (column->string col)
+        (list->string
+         (if (< col 26)
+             (list (num->char col))
+             (list (num->char (sub1 (quotient col 26)))
+                   (num->char (remainder col 26))))))
+      
+      (define (on-char event)
+        (send-event key-events event)
+        (synchronize))
+      
+      (define (on-scroll scroll-event)
+        (case (send scroll-event get-direction)
+          [(vertical) (send-event v-scroll-rcvr (send scroll-event get-position))]
+          [(horizontal) (send-event h-scroll-rcvr (send scroll-event get-position))])
+        (synchronize))
+      
+      (define (on-event event)
+        (case (send event get-event-type)
+          [(enter motion)
+           (send-event mouse-x-rcvr (send event get-x))
+           (send-event mouse-y-rcvr (send event get-y))]
+          [(leave)
+           (send-event mouse-x-rcvr -1)
+           (send-event mouse-y-rcvr -1)]
+          [(left-down) (send-event left-clicks #t)]
+          [(left-up) (send-event left-releases #t)])
+        (synchronize))
+      
+      (define (on-size width height)
+        (let-values ([(width height) (get-client-size)])
+          (send-event canvas-width-rcvr width)
+          (send-event canvas-height-rcvr height)
+          (synchronize)))
+      
+      (define (on-paint)
+        (snapshot/sync (canvas-width~
+                        canvas-height~
+                        first-vis-row~ last-vis-row~
+                        first-vis-col~ last-vis-col~
+                        h-scroll-cells~ h-scroll-offset~ v-scroll-cells~)
+                       (let ([dc offscreen-dc])
+                         (send dc set-clipping-region #f)
+                         (send dc clear)
+                         ;(send dc set-pen line-pen)
+                         ;(send dc set-brush highlight-brush)
+                         (send dc set-pen trans-pen)
+                         (send dc set-brush gray-brush)
+                         (send dc draw-rectangle 0 0 left-margin canvas-height~)
+                         (send dc draw-rectangle 0 0 canvas-width~ top-margin)
+                         (send dc set-pen line-pen)
+                         (send dc draw-line 0 0 0 canvas-height~)
+                         (send dc draw-line 0 0 canvas-width~ 0)
+                         (send dc set-brush clear-brush)
+                         (send dc set-font label-font)
+                         ;; draw horizontal rules and row labels
+                         (for (row = first-vis-row~) (row . <= . (min last-vis-row~ (sub1 rows))) add1
+                              (let ([y (row->y-top row)]
+                                    [text (number->string row)])
+                                (send dc draw-line 0 y canvas-width~ y)
+                                (send dc draw-text text (- left-margin (get-text-width dc text) 2) (add1 y) #f 0 0)))
+                         ;; draw vertical rules and column labels
+                         (send dc draw-line left-margin 0 left-margin canvas-height~)
+                         (send dc set-clipping-rect (+ left-margin 1) 0 (- canvas-width~ left-margin 1) canvas-height~)
+                         (for (col = first-vis-col~) (col . <= . (min last-vis-col~ (sub1 cols))) add1
+                              (let ([x (col->x-left col)]
+                                    [text (column->string col)])
+                                (send dc draw-text text (+ x (quotient (- cell-width (get-text-width dc text)) 2)) 0 #f 0 0)
+                                (send dc draw-line x 0 x canvas-height~)))
+                         (send dc set-font default-font)
+                         (draw-cell-block-offscreen first-vis-row~ last-vis-row~ first-vis-col~ last-vis-col~)
+                         (send (get-dc) draw-bitmap-section (send dc get-bitmap) 0 0 0 0 canvas-width~ canvas-height~))))
+      
+      (let-values ([(width height) (get-client-size)])
+        (send-event canvas-width-rcvr width)
+        (send-event canvas-height-rcvr height))
+      (synchronize)
+      (init-manual-scrollbars 1 1 1 1 0 0)
+      (send offscreen-dc set-pen line-pen)
+      (send offscreen-dc set-brush highlight-brush)))
+  
+  (define canvas
+    (instantiate ss-canvas% (frame) (style (list 'hscroll 'vscroll 'no-autoclear))))
+  
+  (send frame show #t)
+  (send canvas focus))
\ No newline at end of file
diff --git a/collects/frtime/demos/spreadsheet/ss-funcs.ss b/collects/frtime/demos/spreadsheet/ss-funcs.ss
new file mode 100644
index 0000000000..a52cd2634b
--- /dev/null
+++ b/collects/frtime/demos/spreadsheet/ss-funcs.ss
@@ -0,0 +1,106 @@
+(module ss-funcs mzscheme
+
+(require "data-synthesis.ss"
+         "distributions.ss"
+         (rename (lib "frtime.ss" "frtime") undefined? undefined?)
+         )
+
+;;filter: ('a -> bool) * 'a list -> 'a list
+(define (filter pred lst)
+  (cond [(null? lst) '()]
+        [(pred (car lst))
+         (cons (car lst)
+               (filter pred (cdr lst)))]
+        [else (filter pred (cdr lst))]))
+
+;; count : ('a -> bool) * 'a list -> num
+(define (count pred lst)
+  (cond [(null? lst) 0]
+        [(pred (car lst))
+         (+ 1 (count pred (cdr lst)))]
+        [else (count pred (cdr lst))])) 
+
+;;(num U undefined) list -> num list
+(define (filter-out-undefined lst)
+  (filter (lambda (o)
+            (not (undefined? o)))
+          lst))
+
+; list -> num
+(define (count-undefineds lst)
+  (count undefined? lst))
+
+(define (name->dist-fit-func name)
+  (cond [(equal? name 'uniform)
+         fit-uniform-distribution]
+        [(equal? name 'normal)
+         fit-normal-distribution]
+        [(equal? name 'exponential)
+         fit-exponential-distribution]
+;        [(equal? name 'gamma)
+;         fit-gamma-distribution]  Gamme distribution is messed up.  See distributions.ss
+        [else (raise (format "~a not an allowable distribution name"))]))
+
+;;('a -> bool) * 'a list * 'a list -> 'a list
+(define (replace pred lst filler)
+  (cond [(null? lst)
+         '()]
+        [(not (pred (car lst)))
+         (cons (car lst)
+               (replace pred
+                        (cdr lst)
+                        filler))]
+        [(null? filler)
+         (raise "not enough filler to complete replace function")]
+        [(pred (car lst))
+         (cons (car filler)
+               (replace pred
+                        (cdr lst)
+                        (cdr filler)))]))
+
+;;('a -> bool) * 'a list * (-> 'a) -> 'a list
+(define (replace-from-generator pred lst gen)
+  (cond [(null? lst)
+         '()]
+        [(not (pred (car lst)))
+         (cons (car lst)
+               (replace-from-generator pred
+                                       (cdr lst)
+                                       gen))]
+        [(pred (car lst))
+         (cons (gen)
+               (replace-from-generator pred
+                                       (cdr lst)
+                                       gen))]))
+
+;; symbol * (num U undefined) list -> num list
+(define (inflate-data dist-name data)
+  (replace-from-generator undefined?
+                          data
+                          (distribution-rand ((name->dist-fit-func dist-name) 
+                                              (filter-out-undefined data)))))
+;
+;(define ndata (synthesize-random-data (make-uniform-distribution 0 100)
+;                                      10000))
+;(define holy-data 
+;  (let loop ([c 2] [lst ndata])
+;    (cond [(null? lst) '()]
+;          [(zero? c) (cons undefined
+;                           (loop 3
+;                                 (cdr lst)))]
+;          [else (cons (car lst)
+;                      (loop (sub1 c)
+;                            (cdr lst)))])))
+;(define unholy-data (inflate-data 'uniform holy-data))
+;
+;;"Source Mean: 0"
+;"Data Mean:" (sample-mean ndata)
+;"Holy-Data Mean:" (sample-mean (filter-out-undefined holy-data))
+;"Unholy-Data Mean:" (sample-mean unholy-data)
+;;"Source Variance: 1"
+;"Data Variance:" (sample-variance ndata)
+;"Holy-Data Variance:" (sample-variance (filter-out-undefined holy-data))
+;"Unholy-Data Variance:" (sample-variance unholy-data)
+
+(provide inflate-data)
+)
\ No newline at end of file
diff --git a/collects/frtime/demos/ufo.ss b/collects/frtime/demos/ufo.ss
new file mode 100644
index 0000000000..c8b3380a6e
--- /dev/null
+++ b/collects/frtime/demos/ufo.ss
@@ -0,0 +1,22 @@
+(require (lib "animation.ss" "frtime"))
+
+(define ufo-x
+  (+ 200 ; center of window
+     (integral ; integrate over time
+      (* .04 ; scale speed to appropriate # of pixels/ms
+         (- 3 ; start off stationary
+            ; use left and right arrows to accelerate
+            ; (up to 3 in either direction)
+            (range-control (key 'left) (key 'right) 6 3))))))
+(define ufo-y ; bob up and down 5 pixels around center of window
+  (+ 200 (* 5 (sin (/ milliseconds 200)))))
+(define ufo-bright ; flash light and dark
+  (/ (add1 (cos (/ milliseconds 100))) 3))
+(define ufo-color
+  (make-rgb ufo-bright ufo-bright ufo-bright))
+
+(display-shapes
+ (list
+  (make-circle (make-posn ufo-x ufo-y) 10 ufo-color)
+  (make-rect (make-posn (- ufo-x 20) (- ufo-y 2))
+             40 4 ufo-color)))
diff --git a/collects/frtime/doc.txt b/collects/frtime/doc.txt
new file mode 100644
index 0000000000..7336ea421b
--- /dev/null
+++ b/collects/frtime/doc.txt
@@ -0,0 +1,255 @@
+_The Father Time Language (FrTime)_
+
+The `frtime' collection contains the implementation of FrTime, a
+language that supports declarative construction of reactive systems
+through signals, or time-varying values.  Signals are classified as
+either behaviors, which have a value at any point in (conceptually
+continuous) time, or events, which are streams of discrete
+occurrences.  Unlike (for example) boxes, the time-varying nature of
+signals propagates automatically to expressions in which they are
+used.
+
+To interact with FrTime, set the language level to FrTime.  You can
+also make FrTime the language for a module:
+
+(module <module-name> (lib "frtime.ss" "frtime")
+   <module-body>)
+
+For the animation library and demo programs, set the language level
+to (module ...), open the file, and execute.  The demos are perhaps
+the best way to learn about FrTime.
+
+Note that FrTime is experimental, and various aspects of it may change
+significantly, though we will try our best to maintain backwards
+compatibility.
+
+_Primitive Signals_
+
+> seconds : behavior[num]
+
+  This behavior updates approximately every second with the value of
+  (current-seconds).
+
+> milliseconds : behavior[num]
+
+  This behavior updates approximately every 20 milliseconds with the
+  value of (current-milliseconds).  Future versions of FrTime will
+  provide an interface through which the programmer can create timers
+  with arbitrary update frequencies.
+
+_Creating New Signals_
+
+> (new-cell [behavior]) -> cell (a special behavior)
+
+  The returned cell can be used as a behavior; initially its value is
+  determined by the optional behavior given to the constructor
+  (default is <undefined>).  For example, (new-cell seconds) behaves
+  like _seconds_.
+
+> (set-cell! cell behavior) -> void
+
+  This procedure changes the value of the cell to that of the new
+  behavior.
+
+> (event-receiver) -> event-rcvr (a special event source)
+
+  The returned value can be used as an event source.  Specifically, it
+  emits an event occurrence whenever it is used as the first argument
+  to the following procedure:
+
+> (send-event event-rcvr any) -> void
+
+  Emits the second argument as an occurrence on the given event source.
+
+_Signal Processors_
+
+> (value-now behavior[a]) -> a
+
+  This procedure projects the current value of the given behavior.
+
+> (delay-by behavior[a] behavior[num]) -> behavior[a]
+
+  This procedure delays the given behavior by the given number of
+  milliseconds (which need not be constant).
+
+> (integral behavior[num] {behavior[num] = 20}) -> behavior[num]
+
+  Computes a numeric approximation of the integral of the first
+  argument with respect to time, at a minimum rate given by the second
+  argument (interpreted in milliseconds).  This procedure will probably
+  be rewritten soon.
+
+> (derivative behavior[num]) -> behavior[num]
+
+  Computes a numeric approximation of the derivative of the first
+  argument with respect to time.  This procedure needs to be
+  rewritten.
+
+> (map-e proc event) -> event
+> (event . ==> . proc) -> event
+
+  Returns an event source isomorphic to the given one, except that
+  each occurrence is the result of applying the given procedure to the
+  input event occurrence.
+
+> (filter-e pred event) -> event
+> (event . =#> . pred) -> event
+
+  Returns a filtered version of the given event source.  Only
+  occurrences that satisfy the given predicate survive.
+
+> (merge-e event ...) -> event
+
+  Merges all of the input event sources into a single event source.
+
+> (once-e event) -> event
+
+  Returns an event source that carries only the first occurrence of the
+  argument event source.  (The rest are filtered out.)
+
+> (changes behavior) -> event
+
+  Returns an event source which occurs each time the argument behavior
+  changes.  The value of the occurrence is the behavior's new value.
+
+> (hold event [init]) -> behavior
+
+  Constructs a behavior from a given initial value (defaults to
+  <undefined>) and an event source.  The value of the behavior is the
+  value of the most recent event occurrence.
+
+> (switch behavior event[behavior]) -> behavior
+
+  Returns a behavior that "switches" each time the argument event
+  occurs.
+
+> (accum-e event[a -> a] a) -> event[a]
+
+  Constructs an event source by accumulating changes (carried by the
+  given event source) over an initial value.
+
+> (accum-b event[a -> a] a) -> behavior[a]
+
+  Combines functionality of accum-e and hold to construct a behavior.
+  (accum-b ev init) = (hold init (accum-e ev init)).
+
+> (collect-e event[a] b (a b -> b)) -> event[b]
+
+  Like accum-e, except the transformer function is fixed and is applied
+  to the current accumulator and the event occurrence.
+
+> (collect-b event[a] b (a b -> b)) -> behavior[b]
+
+  collect-b : collect-e :: accum-b : accum-e
+
+> (when-e behavior) -> event
+
+  The returned event source carries an occurrence each time the argument
+  behavior changes from false to true (non-false).
+  
+> (<proc> behavior ...) -> behavior
+
+  FrTime provides "lifted" versions of most of MzScheme.  This means
+  that these procedures may be applied to behaviors, and the result
+  automatically recomputes whenever any of the arguments changes.
+
+_Special Syntax for FrTime_
+
+> (if boolean-behavior then-expr else-expr) SYNTAX
+
+  FrTime permits the use of behaviors in conditional statements.  By
+  definition, if the condition is <undefined>, then the result is also
+  <undefined>.  Otherwise, the expression reflects the branch
+  currently selected by the condition.  FrTime also provides 'cond',
+  'and', 'or', and 'case'.
+
+> (snapshot (var ...) expr) SYNTAX
+
+  This projects the current values of the named variables within the
+  given expression.
+
+> (require (lifted module-spec proc-name ...) ...) SYNTAX
+> (require (lifted:nonstrict module-spec proc-name ...) ...) SYNTAX
+> (require (as-is module-spec proc-name ...) ...) SYNTAX
+> (require (as-is:unchecked module-spec proc-name ...) ...) SYNTAX
+
+FrTime provides several new 'require' forms, which can be used to
+import optionally modified definitions from existing libraries.  The
+'lifted' form takes a module specification and names of any number of
+primitive procedures.  The imported versions of the primitives can be
+applied to behaviors.  The 'lifted:nonstrict' form is similar, except
+that, when given <undefined> arguments, FrTime will still perform the
+application, instead of simply forcing the output value to be
+<undefined>.
+
+The 'as-is' forms do not lift imported procedures, so these should not
+generally be used with signals.  The 'unchecked' version permits
+application to signals, while the plain 'as-is' always reports an
+error if the user attempts to apply to a signal.
+
+_Graphical Demo Programs_
+
+To run the following animation/GUI demos, simply set the language
+level to FrTime, open the corresponding file, and Execute.  See the
+demo source code for more information.
+
+orbit-mouse.ss : A collection of balls that move in circles around
+the mouse pointer.
+
+piston.ss : Simulation of a piston/cylinder.
+
+rotation.ss : Balls moving in circles.
+
+delay-mouse.ss : A trail of balls following the mouse.
+
+ball-on-string.ss : A ball chasing the mouse.
+
+pong.ss : A simple pong/air-hockey game.  The left paddle moves with
+numeric keypad; the right paddle moves with the mouse.  The 'r' key
+resets the score.
+
+net-pong-*.ss : A networked version of the pong/air-hockey game.
+Currently known to work under Linux.  To play, open the client on one
+machine and the server on another.  Execute both (and require if
+necessary, depending on language level).  Evaluate (self) on each.
+Results will be something like:
+
+[client]
+> (self)
+#3(tid 128.148.38.2:1180 main)
+
+and
+[server]
+> (self)
+#3(tid 128.148.33.71:1178 main)
+
+Now tell each machine about the other:
+[client]
+> (set-cell! server (make-tid '128.148.33.71 1178 'frtime-heart))
+
+[server]
+> (set-cell! client (make-tid '128.148.38.2 1180 'frtime-heart))
+
+Note the differences between the #3(tid ...) output and the (make-tid ...)
+commands---there is no colon (:) between the host and port, and main becomes
+'frtime-heart.
+
+After setting the cells, complete the connection by clicking the left
+mouse button in both animation windows.  The player running the server
+can reset the score by pressing 'r'.
+
+pizza.ss : A simple "pizza ordering" user interface based on an HtDP
+exercise.
+
+calculator.ss : A simple calculator interface, also based on an HtDP
+exercise except that the result updates continuously as the arguments
+and operator change.
+
+Robb Cutler's Examples
+
+analog-clock.ss : An animated real-time clock.  A slider adjusts the radius
+of the face.  Click and drag to move the face around.
+
+growing-points.ss : A field of points that grow as the mouse approaches.
+
+needles.ss : A field of needles that point at the mouse.
diff --git a/collects/frtime/dv.ss b/collects/frtime/dv.ss
new file mode 100644
index 0000000000..043cdc7ea8
--- /dev/null
+++ b/collects/frtime/dv.ss
@@ -0,0 +1,100 @@
+; -*- Scheme -*-
+
+; Shriram Krishnamurthi (shriram@cs.rice.edu)
+; Tue Jul 25 23:20:45 EDT 1995
+
+; (define-structure (dv:vector length size contents))
+
+(module dv mzscheme 
+
+  (provide dv:make dv:make-w/-init dv:length dv:contents dv:append
+           dv:remove-last dv:legitimate-index dv:ref dv:set!)
+  
+  (define dv:vector?
+    (lambda (obj)
+      (if (vector? obj)
+          (if (= (vector-length obj) 4)
+              (eq? (vector-ref obj 0) 'dv:vector)
+              #f)
+          #f)))
+  (define dv:vector-length
+    (lambda (obj) (vector-ref obj 1)))
+  (define dv:vector-size
+    (lambda (obj) (vector-ref obj 2)))
+  (define dv:vector-contents
+    (lambda (obj) (vector-ref obj 3)))
+  (define dv:set-vector-length!
+    (lambda (obj newval) (vector-set! obj 1 newval)))
+  (define dv:set-vector-size!
+    (lambda (obj newval) (vector-set! obj 2 newval)))
+  (define dv:set-vector-contents!
+    (lambda (obj newval) (vector-set! obj 3 newval)))
+  (define dv:make-vector
+    (lambda (length size contents)
+      ((lambda () (vector 'dv:vector length size contents)))))
+  
+  (define dv:make
+    (let* ((default-initial-size 8)
+           (default-initial-vector (make-vector default-initial-size)))
+      (lambda arg
+        (cond
+          ((null? arg)
+           (dv:make-vector 0 default-initial-size default-initial-vector))
+          ((= 1 (length arg))
+           (let ((l (car arg)))
+             (dv:make-vector 0 l (make-vector l))))
+          (else
+           (error 'dv:make "wrong number of arguments"))))))
+  
+  (define dv:make-w/-init
+    (lambda values
+      (let ((l (length values)))
+        (dv:make-vector l l (list->vector values)))))
+  
+  (define dv:append
+    (lambda (dv item)
+      (let ((length   (dv:vector-length dv))
+            (size     (dv:vector-size dv))
+            (contents (dv:vector-contents dv)))
+        (if (< length size)
+            (begin
+              (vector-set! contents length item)
+              (dv:set-vector-length! dv (+ length 1)))
+            (begin
+              (let ((new-vector (make-vector (* size 2))))
+                (let loop
+		  ((i 0))
+                  (when (< i size)
+                    (vector-set! new-vector i (vector-ref contents i))
+                    (loop (+ i 1))))
+                (dv:set-vector-contents! dv new-vector)
+                (dv:set-vector-size! dv (* size 2))
+                (dv:append dv item)))))))
+  
+  (define dv:remove-last
+    (lambda (dv) 
+      (dv:set-vector-length! dv (- (dv:vector-length dv) 1))
+      (vector-set! (dv:vector-contents dv) (dv:vector-length dv) 0)))
+  
+  
+  (define dv:legitimate-index
+    (lambda (dv index)
+      (< index (dv:vector-length dv))))
+  
+  (define dv:ref
+    (lambda (dv index)
+      (if (dv:legitimate-index dv index)
+          (vector-ref (dv:vector-contents dv) index)
+          (error 'dv:ref "index too large"))))
+  
+  (define dv:set!
+    (lambda (dv index value)
+      (if (dv:legitimate-index dv index)
+          (vector-set! (dv:vector-contents dv) index value)
+          (error 'dv:set! "index too large"))))
+  
+  (define dv:contents dv:vector-contents)
+  
+  (define dv:length dv:vector-length)
+  )
+  
diff --git a/collects/frtime/erl.ss b/collects/frtime/erl.ss
new file mode 100644
index 0000000000..fe972ced32
--- /dev/null
+++ b/collects/frtime/erl.ss
@@ -0,0 +1,386 @@
+(module erl mzscheme
+  
+  (require (lib "list.ss")
+           (lib "thread.ss")
+           (lib "etc.ss")
+           (lib "dns.ss" "net")
+           "mymatch.ss")
+  
+  (define (with-semaphore s thunk)
+    (semaphore-wait s)
+    (let ([result (thunk)])
+      (semaphore-post s)
+      result))
+    
+  (define free-cons-cells
+    (box empty))
+  
+  (define alloc-sem (make-semaphore 1))
+  
+  (define (mcons a d)
+    (with-semaphore
+     alloc-sem
+     (lambda ()
+       (let ([start (unbox free-cons-cells)])
+         (if (empty? start)
+             (cons a d)
+             (begin
+               (set-box! free-cons-cells (rest start))
+               (set-car! start a)
+               (set-cdr! start d)
+               start))))))
+  
+  (define (release c)
+    (set-cdr! c (unbox free-cons-cells))
+    (set-box! free-cons-cells c))
+
+#|  
+  (define mcons cons)
+  (define release void)
+|#
+  
+  ; for thread ids, port is the TCP port number (not to be confused with MzScheme ports)
+  (define-values (listener port)
+    ; find first free port after 1178
+    (let loop ([port 1178])
+      (with-handlers
+          ([exn:fail:network? (lambda (_) (loop (add1 port)))])
+        (values (tcp-listen port) port))))
+  
+  (define ip-address
+    (let*-values
+        ([(sub-proc in-p dummy1 dummy2) (subprocess #f #f #f "/bin/hostname" "-i")]
+         [(ip-address) (read in-p)])
+      (subprocess-wait sub-proc)
+      (if (eof-object? ip-address)
+          '127.0.0.1
+          ip-address)))
+  
+  (define my-ip:port
+    (string->symbol (format "~a:~a" ip-address port)))
+  
+  (define dns
+    (dns-find-nameserver))
+  
+  (define ip-regexp
+    (regexp "[0-9][0-9]?[0-9]?\\.[0-9][0-9]?[0-9]?\\.[0-9][0-9]?[0-9]?\\.[0-9][0-9]?[0-9]?"))
+  
+  ; a tid is a (vector 'tid symbol(ip:port) symbol(local-id))
+  
+  (define make-tid
+    (case-lambda
+      [(thr) (vector 'tid my-ip:port thr)]
+      [(port thr) (vector 'tid (string->symbol (format "~a:~a" ip-address port)) thr)]
+      [(host port thr) (vector 'tid
+                               (string->symbol
+                                (format
+                                 "~a:~a"
+                                 (if (regexp-match ip-regexp (symbol->string host))
+                                     host
+                                     (string->symbol (dns-get-address dns (symbol->string host))))
+                                 port))
+                               thr)]))
+  
+  (define (tid-ip tid)
+    (vector-ref tid 1))
+  
+  (define (tid-lid tid)
+    (vector-ref tid 2))
+  
+  (define (tid? x)
+    (and (vector? x)
+         (= (vector-length x) 3)
+         (eq? (vector-ref x 0) 'tid)
+         (symbol? (vector-ref x 1))
+         (symbol? (vector-ref x 2))))
+  
+  ; We need a mapping from MzScheme's tids to our tids (just for `self')
+  ; and a mapping from symbols to mailboxes (for local threads).
+  ; A special thread is responsible for all communication with external threads.
+  ; All processes spawned on a node have same ip-address.
+  
+  (define tids
+    (make-hash-table 'weak))
+  
+  (define mailboxes
+    (make-hash-table))
+  
+  (define-struct mailbox (old-head old-last head tail sem-count sem-space lock-enqueue))
+  
+  (define (try-extract m l)
+    (let loop ([prev l] [cur (rest l)])
+      (if (empty? (rest cur))
+          match-fail
+          (let ([v (m (first cur))])
+            (if (eq? v match-fail)
+                (loop cur (rest cur))
+                (begin
+                  (set-rest! prev (rest cur))
+                  (release cur)
+                  v))))))
+  
+  (define (receive-help timeout timeout-thunk matcher)
+    (if (and timeout (negative? timeout))
+        (timeout-thunk)
+        (let* ([start-time (current-milliseconds)]
+               [mb (hash-table-get mailboxes (tid-lid (self)))]
+               [val (try-extract matcher (mailbox-old-head mb))])
+          (if (eq? val match-fail)
+              (let loop ()
+                (let* ([elapsed (- (current-milliseconds) start-time)]
+                       [wait-time (cond
+                                    [(not timeout) false]
+                                    [(> elapsed timeout) 0]
+                                    [else (/ (- timeout elapsed) 1000.0)])]
+                       [val (sync/timeout wait-time (mailbox-sem-count mb))])
+                  (if val
+                      (let* ([oldhead (mailbox-head mb)]
+                             [msg (first oldhead)]
+                             [val (begin
+                                    (set-mailbox-head! mb (rest oldhead))
+                                    (release oldhead)
+                                    (semaphore-post (mailbox-sem-space mb))
+                                    (matcher msg))])
+                        (if (eq? val match-fail)
+                            (let ([new-last (mcons empty empty)]
+                                  [old-last (mailbox-old-last mb)])
+                              (set-first! old-last msg)
+                              (set-rest! old-last new-last)
+                              (set-mailbox-old-last! mb new-last)
+                              (loop))
+                            (val)))
+                      (timeout-thunk))))
+              (val)))))
+  
+  (define-syntax receive
+    (syntax-rules (after)
+      [(_ (after timeout to-expr ...) (pat expr ...) ...)
+       (let* ([matcher (match-lambda (pat (lambda () expr ...)) ...)]
+              [timeout-thunk (lambda () to-expr ...)])
+         (receive-help timeout timeout-thunk matcher))]
+      [(_ clause ...) (receive (after false (void)) clause ...)]))
+  
+  ; must ensure name not already taken
+  (define (spawn/name-help thunk name)
+    (if (hash-table-get mailboxes name (lambda () #f))
+        #f
+        (let ([new-tid (make-tid name)]
+              [parent-tid (self)])
+          (thread
+           (lambda ()
+             (hash-table-put! tids (current-thread) new-tid)
+             (hash-table-put! mailboxes name (new-mailbox))
+             (! parent-tid new-tid)
+             (thunk)))
+          (receive [(? (lambda (m) (equal? m new-tid))) new-tid]))))
+  
+  (define last-thread 1)
+  
+  (define next-thread
+    (let ([lock (make-semaphore 1)])
+      (lambda ()
+        (with-semaphore
+         lock
+         (lambda ()
+           (begin0
+             last-thread
+             (set! last-thread (add1 last-thread))))))))
+  
+  (define-syntax spawn
+    (syntax-rules ()
+      [(_ expr ...) (spawn/name-help (lambda () expr ...)
+                                     (string->symbol
+                                      (string-append "thread" (number->string (next-thread)))))]))
+  
+  (define-syntax spawn/name
+    (syntax-rules ()
+      [(_ name expr ...) (spawn/name-help (lambda () expr ...) name)]))
+  
+  (define (new-mailbox)
+    (let* ([sentinel (mcons empty empty)]
+           [old-sentinel (mcons empty empty)]
+           [old-head (mcons empty old-sentinel)])
+      (make-mailbox old-head
+                    old-sentinel
+                    sentinel
+                    sentinel
+                    (make-semaphore)
+                    (make-semaphore 1000)
+                    (make-semaphore 1))))
+  
+  (define main (make-tid 'main))
+  (hash-table-put! tids (current-thread) main)
+  (hash-table-put! mailboxes (tid-lid main) (new-mailbox))
+  
+  (define forward-mailbox (new-mailbox))
+  
+  (define (split-string-at str c)
+    (let loop ([i 0])
+      (if (char=? (string-ref str i) c)
+          (values (substring str 0 i) (substring str (add1 i)))
+          (loop (add1 i)))))
+
+  (define (report-exn exn)
+    (fprintf (current-error-port) "erl.ss: ~a (~a)~n" exn (exn-message exn)))
+  
+  ; forwarder for remote communication
+  (thread
+   (lambda ()
+     (let* ([in-ports (make-hash-table)] ; set of input ports
+            [out-ports (make-hash-table)] ; symbol(ip:port) -> output port
+            [mk-wait-set (lambda () (apply choice-evt
+                                           (hash-table-map in-ports (lambda (key val) key))))]
+            [try-connect (lambda (ip:port)
+                           (with-handlers ([exn? (lambda (exn) (report-exn exn) false)])
+                             (let*-values ([(ip-str port-str) (split-string-at
+                                                               (symbol->string ip:port)
+                                                               #\:)]
+                                           [(in-p out-p)
+                                            (tcp-connect ip-str (string->number port-str))])
+                               (hash-table-put! in-ports in-p ip:port)
+                               (hash-table-put! out-ports ip:port out-p)
+                               (write (list my-ip:port) out-p)
+                               out-p)))])
+       (let loop ([wait-set (mk-wait-set)])
+         ;(printf "have connections to ~a~n" (hash-table-map in-ports (lambda (k v) k)))
+         (let ([val (sync (mailbox-sem-count forward-mailbox)
+                                          listener wait-set)])
+           (cond
+             [(tcp-listener? val)
+              (with-handlers ([exn? (lambda (exn) (loop wait-set))])
+                (let*-values ([(in-p out-p) (tcp-accept listener)]
+                              [(remote-ip:port) (first (read in-p))])
+                  (hash-table-put! out-ports remote-ip:port out-p)
+                  (hash-table-put! in-ports in-p remote-ip:port))
+                (loop (mk-wait-set)))]
+             [(input-port? val)
+              (match (with-handlers ([exn? (lambda (exn) (report-exn exn) eof)])
+                       (read val))
+                [(lid msg)
+                 ; forward to local mailbox
+                 (let ([mb (hash-table-get mailboxes lid (lambda () false))])
+                   (when mb (send-msg mb msg)))
+                 (loop wait-set)]
+                [(? eof-object?)
+                 ; close input port, remove from hash table
+                 (close-input-port val)
+                 (hash-table-remove! in-ports val)
+                 (loop (mk-wait-set))])]
+             [else ; val was the mailbox semaphore
+              (match (first (mailbox-head forward-mailbox))
+                ;['quit (void)]
+                [(#('tid ip:port lid) msg)
+                 (let inner ([out-p (hash-table-get
+                                     out-ports ip:port
+                                     (lambda ()
+                                       (begin0
+                                         (try-connect ip:port)
+                                         (set! wait-set (mk-wait-set)))))])
+                   (when out-p
+                     ; need to deal with closed ports here too
+                     (with-handlers ([exn:fail?
+                                      (lambda (_)
+                                        (hash-table-remove! out-ports ip:port)
+                                        (let ([res (try-connect ip:port)])
+                                          (set! wait-set (mk-wait-set))
+                                          (inner res)))])
+                       (write (list lid msg) out-p))))
+                 (set-mailbox-head! forward-mailbox (rest (mailbox-head forward-mailbox)))
+                 (semaphore-post (mailbox-sem-space forward-mailbox))
+                 (loop wait-set)])]))))))
+  
+  #|
+  (define (stop-network)
+    (when network-up?
+      (send-msg forward-mailbox 'quit)
+      (set! network-up? #f)))
+  |#
+  
+  (define (local? tid)
+    (symbol=? (tid-ip tid) my-ip:port))
+  
+  (define (! tid msg)
+    (if (local? tid)
+        (let ([mb (hash-table-get mailboxes (tid-lid tid) (lambda () false))])
+          (when mb
+            (send-msg mb msg)))
+        (send-msg forward-mailbox (list tid msg)))) ; forward via special thread
+  
+  (define (send-msg mbox msg)
+    (with-semaphore
+     (mailbox-lock-enqueue mbox)
+     (lambda ()
+       (let ([newtail (mcons empty empty)]
+             [oldtail (mailbox-tail mbox)])
+         (set-first! oldtail msg)
+         (set-rest! oldtail newtail)
+         (set-mailbox-tail! mbox newtail)
+         (semaphore-wait (mailbox-sem-space mbox))
+         (semaphore-post (mailbox-sem-count mbox))))))
+  
+  (define (self)
+    (hash-table-get tids (current-thread)
+                    ; allows thread not created by spawn to receive messages
+                    (lambda ()
+                      (let* ([name (string->symbol
+                                    (string-append "thread" (number->string (next-thread))))]
+                             [new-tid (make-tid name)])
+                        (hash-table-put! tids (current-thread) new-tid)
+                        (hash-table-put! mailboxes name (new-mailbox))
+                        new-tid))))
+  
+  (define (!! msg)
+    (let ([mb (hash-table-get mailboxes (tid-lid (self)) (lambda () false))])
+      (if mb
+          (let ([new-last (mcons empty empty)]
+                [old-last (mailbox-old-last mb)])
+            (set-first! old-last msg)
+            (set-rest! old-last new-last)
+            (set-mailbox-old-last! mb new-last)))))
+  
+  (define (mybox)
+    (hash-table-get mailboxes (self)))
+  
+  (provide
+   ;   mailboxes
+   ;   mybox
+   ;   (struct mailbox (old-head old-last channel))
+   ; allocations
+   ; free-cons-cells
+   ; my-ip:port
+   make-tid
+   tid?
+   spawn
+   spawn/name
+   !
+   !!
+   receive
+   self))
+
+#|
+(require erl)
+
+(define (send-loop n)
+  (let ([me (self)])
+    (let loop ([i 0])
+      (if (>= i n)
+          void
+          (begin
+            (! me true)
+            (loop (+ i 1)))))))
+
+(define (send-loop2 n)
+  (let loop ([i 0])
+    (if (>= i n)
+        void
+        (begin
+          (!! true)
+          (loop (+ i 1))))))
+
+(define (flush-queue)
+  (let recur ()
+    (receive [after 0 void]
+             [_ (recur)])))
+
+(define (mybox) (hash-table-get mailboxes (self)))
+|#
\ No newline at end of file
diff --git a/collects/frtime/etc.ss b/collects/frtime/etc.ss
new file mode 100644
index 0000000000..5750875372
--- /dev/null
+++ b/collects/frtime/etc.ss
@@ -0,0 +1,500 @@
+
+(module etc (lib "frtime.ss" "frtime")
+  (require (lib "spidey.ss")
+           (lib "plthome.ss" "setup"))
+  (require-for-syntax (lib "kerncase.ss" "syntax")
+		      (lib "stx.ss" "syntax")
+		      (lib "name.ss" "syntax")
+		      (lib "context.ss" "syntax")
+		      (lib "plthome.ss" "setup")
+		      (lib "stxset.ss" "mzlib" "private"))
+
+  (provide true false
+	   boolean=? symbol=?
+	   identity
+	   compose
+	   
+	   ;build-string
+	   ;build-vector
+	   build-list
+	   
+	   loop-until
+	   
+           opt-lambda
+           
+	   local
+	   recur
+	   rec
+	   evcase
+	   nor
+	   nand
+	   let+
+
+	   namespace-defined?
+	   this-expression-source-directory
+	   define-syntax-set
+           
+           hash-table)
+  
+  (define true #t)
+  (define false #f)
+  
+  (define identity (polymorphic (lambda (x) x)))
+  
+  (define compose
+    (polymorphic
+     (case-lambda 
+      [(f) (if (procedure? f) f (raise-type-error 'compose "procedure" f))]
+      [(f g)
+       (let ([f (compose f)]
+             [g (compose g)])
+         (if (eqv? 1 (procedure-arity f)) ; optimize: don't use call-w-values
+             (if (eqv? 1 (procedure-arity g)) ; optimize: single arity everywhere
+                 (lambda (x) (f (g x)))
+                 (lambda args (f (apply g args))))
+             (if (eqv? 1 (procedure-arity g)) ; optimize: single input
+                 (lambda (a)
+                   (call-with-values
+                    (lambda () (g a))
+                    f))
+                 (lambda args
+                   (call-with-values
+                    (lambda () (apply g args))
+                    f)))))]
+      [(f . more)
+       (let ([m (apply compose more)])
+         (compose f m))])))
+  
+
+#|
+  (define  build-string
+    (lambda  (n  fcn)
+      (unless  (and (integer? n) (exact? n) (>= n 0))
+        (error  'build-string  "~s must be an exact integer >= 0"  n))
+      (unless  (procedure? fcn)
+        (error  'build-string  "~s must be a procedure"  fcn))
+      (let  ((str  (make-string n)))
+        (let  loop  ((i  0))
+          (if (= i n)  
+              str
+              (begin
+                (string-set!  str  i  (fcn i))
+                (loop  (add1 i))))))))
+  
+|#
+  ;; (build-vector n f) returns a vector 0..n-1 where the ith element is (f i).
+  ;; The eval order is guaranteed to be: 0, 1, 2, ..., n-1.
+  ;; eg: (build-vector 4 (lambda (i) i)) ==> #4(0 1 2 3)
+  
+#|
+  (define build-vector
+    (polymorphic
+     (lambda (n fcn)
+       (unless (and (integer? n) (exact? n) (>= n 0))
+         (error 'build-vector "~s must be an exact integer >= 0" n))
+       (unless (procedure? fcn)
+         (error 'build-vector  "~s must be a procedure" fcn))
+       (let ((vec (make-vector n)))
+         (let loop ((i 0))
+           (if (= i n) vec
+               (begin
+                 (vector-set! vec i (fcn i))
+                 (loop (add1 i)))))))))
+  |#
+  (define  build-list
+    (polymorphic
+     (lambda  (n  fcn)
+       (unless  (and (integer? n) (exact? n) (>= n 0))
+         (error  'build-list  "~s must be an exact integer >= 0"  n))
+       (unless  (procedure? fcn)
+         (error  'build-list  "~s must be a procedure"  fcn))
+       (let loop ([i (sub1 n)]  [p '()])
+         (if  (>= i 0)
+              (loop (sub1 i) (cons (fcn i) p))
+              p)))))
+
+  (define loop-until
+    (polymorphic
+     (lambda (start done? next body)
+       (let loop ([i start])
+         (unless (done? i)
+           (body i)
+           (loop (next i)))))))
+  
+  (define boolean=?
+    (lambda (x y)
+      (unless (and (boolean? x)
+                   (boolean? y))
+        (raise-type-error 'boolean=? 
+                          "boolean"
+                          (if (boolean? x) y x)))
+      (eq? x y)))
+  
+  (define (symbol=? x y)
+    (unless (and (symbol? x)
+		 (symbol? y))
+      (raise-type-error 'symbol=? "symbol"
+			(if (symbol? x) y x)))
+    (eq? x y))
+
+ (define-syntax opt-lambda 
+   (lambda (stx)
+     (with-syntax ([name (or (syntax-local-infer-name stx)
+			     (quote-syntax opt-lambda-proc))])
+       (syntax-case stx ()
+	 [(_ args body1 body ...)
+	  (let ([clauses (let loop ([pre-args null]
+				    [args (syntax args)]
+				    [needs-default? #f])
+			   (syntax-case args ()
+			     [id
+			      (identifier? (syntax id))
+			      (with-syntax ([(pre-arg ...) pre-args])
+				(syntax ([(pre-arg ... . id)
+					  body1 body ...])))]
+                             [()
+			      (with-syntax ([(pre-arg ...) pre-args])
+				(syntax ([(pre-arg ...)
+					  body1 body ...])))]
+			     [(id . rest)
+			      (identifier? (syntax id))
+			      (begin
+				(when needs-default?
+				  (raise-syntax-error
+				   #f
+				   "default value missing"
+				   stx
+				   (syntax id)))
+				(loop (append pre-args (list (syntax id)))
+				      (syntax rest)
+				      #f))]
+			     [([id default] . rest)
+			      (identifier? (syntax id))
+                              (with-syntax ([rest (loop (append pre-args (list (syntax id)))
+                                                        (syntax rest)
+                                                        #t)]
+                                            [(pre-arg ...) pre-args])
+                                (syntax ([(pre-arg ...) (name pre-arg ... default)]
+                                         . rest)))]
+			     [(bad . rest)
+			      (raise-syntax-error
+			       #f
+			       "not an identifier or identifier with default"
+			       stx
+			       (syntax bad))]
+			     [else
+			      (raise-syntax-error
+			       #f
+			       "bad identifier sequence"
+			       stx
+			       (syntax args))]))])
+            (with-syntax ([clauses clauses])
+              (syntax/loc stx
+                          (letrec ([name
+                                    (case-lambda
+                                     . clauses)])
+                            name))))]))))
+ 
+ (define-syntax local 
+   (lambda (stx)
+     (syntax-case stx ()
+       [(_ (defn ...) body1 body ...)
+	(let ([defs (let ([expand-context (generate-expand-context)])
+		      (let loop ([defns (syntax->list (syntax (defn ...)))])
+			(apply
+			 append
+			 (map
+			  (lambda (defn)
+			    (let ([d (local-expand
+				      defn
+				      expand-context
+				      (kernel-form-identifier-list 
+				       (quote-syntax here)))]
+				  [check-ids (lambda (ids)
+					       (for-each
+						(lambda (id)
+						  (unless (identifier? id)
+						    (raise-syntax-error
+						     #f
+						     "not an identifier for definition"
+						     stx
+						     id)))
+						ids))])
+			      (syntax-case d (define-values define-syntaxes begin)
+				[(begin defn ...)
+				 (loop (syntax->list (syntax (defn ...))))]
+				[(define-values (id ...) body)
+				 (begin
+				   (check-ids (syntax->list (syntax (id ...))))
+				   (list d))]
+				[(define-values . rest)
+				 (raise-syntax-error
+				  #f
+				  "ill-formed definition"
+				  stx
+				  d)]
+				[(define-syntaxes (id ...) body)
+				 (begin
+				   (check-ids (syntax->list (syntax (id ...))))
+				   (list d))]
+				[(define-syntaxes . rest)
+				 (raise-syntax-error
+				  #f
+				  "ill-formed definition"
+				  stx
+				  d)]
+				[_else
+				 (raise-syntax-error
+				  #f
+				  "not a definition"
+				  stx
+				  defn)])))
+			  defns))))])
+	  (let ([ids (apply append
+			    (map
+			     (lambda (d)
+			       (syntax-case d ()
+				 [(_ ids . __)
+				  (syntax->list (syntax ids))]))
+			     defs))])
+	    (let ([dup (check-duplicate-identifier ids)])
+	      (when dup
+		(raise-syntax-error
+		 #f
+		 "duplicate identifier"
+		 stx
+		 dup)))
+	    (with-syntax ([(def ...) defs])
+	      (syntax/loc
+	       stx
+	       (let ()
+		 def ...
+		 (let ()
+		   body1
+		   body ...))))))]
+       [(_ x body1 body ...)
+	(raise-syntax-error
+	 #f
+	 "not a definition sequence"
+	 stx
+	 (syntax x))])))
+
+ ;; recur is another name for 'let' in a named let
+ (define-syntax recur 
+   (lambda (stx)
+     (syntax-case stx ()
+       [(_ . rest)
+	(syntax/loc stx (let . rest))])))
+
+ ;; define a recursive value
+ (define-syntax rec
+   (lambda (stx)
+     (syntax-case stx ()
+       [(_ name expr)
+	(begin
+	  (unless (identifier? (syntax name))
+	    (raise-syntax-error
+	     #f
+	     "not an identifier"
+	     stx
+	     (syntax name)))
+	  (syntax/loc stx
+	      (letrec ([name expr])
+		name)))])))
+
+ (define-syntax evcase 
+   (lambda (stx)
+     (syntax-case stx ()
+       [(_ val [test body ...] ...)
+	(let ([tests (syntax->list (syntax (test ...)))])
+	  (with-syntax ([(a-test ...)
+			 (map
+			  (lambda (t)
+			    (syntax-case t (else)
+			      [else (syntax #t)]
+			      [_else (with-syntax ([t t])
+				       (syntax (eqv? evcase-v t)))]))
+			  tests)])
+	    ;; Make sure else is last:
+	    (unless (null? tests)
+	      (let loop ([tests tests])
+		(unless (null? (cdr tests))
+		  (when (and (identifier? (car tests))
+			     (module-identifier=? (quote-syntax else) (car tests)))
+		    (raise-syntax-error
+		     #f
+		     "else is not in last clause"
+		     stx
+		     (car tests)))
+		  (loop (cdr tests)))))
+	    (syntax/loc stx
+	      (let ([evcase-v val])
+		(cond
+		 [a-test
+		  (begin body ...)]
+		 ...)))))]
+       [(_ val something ...)
+	;; Provide a good error message:
+	(for-each
+	 (lambda (s)
+	   (syntax-case s ()
+	     [(t a ...)
+	      (raise-syntax-error
+	       #f
+	       "invalid clause"
+	       stx
+	       s)]))
+	 (syntax->list (syntax (something ...))))])))
+       
+ (define-syntax nor
+   (lambda (stx)
+     (syntax-case stx ()
+       [(_ expr ...)
+	(syntax/loc stx (not (or expr ...)))])))
+ 
+ (define-syntax nand
+   (lambda (stx)
+     (syntax-case stx ()
+       [(_ expr ...)
+	(syntax/loc stx (not (and expr ...)))])))
+
+ (define-syntax let+
+   (lambda (stx)
+     (syntax-case stx ()
+       [(_ [clause ...] body1 body ...)
+	(let ([clauses (syntax->list (syntax (clause ...)))]
+	      [bad (lambda (c n)
+		     (raise-syntax-error
+		      #f
+		      (format "illegal use of ~a for a clause" n)
+		      stx
+		      c))]
+	      [var? (lambda (x)
+		      (or (identifier? x)
+			  (let ([l (syntax->list x)])
+			    (and l
+				 (pair? l)
+				 (eq? (syntax-e (car l)) 'values)
+				 (andmap identifier? (cdr l))))))]
+	      [normal-var (lambda (x)
+			    (if (identifier? x)
+				(list x)
+				(cdr (syntax-e x))))])
+	  ;; syntax checks
+	  (for-each
+	   (lambda (clause)
+	     (syntax-case* clause (val rec vals recs _) (lambda (a b) 
+							  (eq? (syntax-e b) 
+							       (syntax-e a)))
+	       [(val var expr)
+		(var? (syntax var))
+		'ok]
+	       [(rec var expr)
+		(var? (syntax var))
+		'ok]
+	       [(vals (var expr) ...)
+		(andmap var? (syntax->list (syntax (var ...))))
+		'ok]
+	       [(recs (var expr) ...)
+		(andmap var? (syntax->list (syntax (var ...))))
+		'ok]
+	       [(_ expr0 expr ...)
+		'ok]
+	       [(val . __) (bad clause "val")]
+	       [(rec . __) (bad clause "rec")]
+	       [(vals . __) (bad clause "vals")]
+	       [(recs . __) (bad clause "recs")]
+	       [(_ . __) (bad clause "_")]
+	       [_else (raise-syntax-error #f "bad clause" stx clause)]))
+	   clauses)
+	  ;; result
+	(let loop ([clauses clauses])
+	  (if (null? clauses)
+	      (syntax (let () body1 body ...))
+	      (with-syntax ([rest (loop (cdr clauses))])
+		(syntax-case* (car clauses) (val rec vals recs _)  (lambda (a b) 
+								     (eq? (syntax-e b) 
+									  (syntax-e a)))
+		  [(val var expr)
+		   (with-syntax ([vars (normal-var (syntax var))])
+		     (syntax (let-values ([vars expr]) rest)))]
+		  [(rec var expr)
+		   (with-syntax ([vars (normal-var (syntax var))])
+		     (syntax (letrec-values ([vars expr]) rest)))]
+		  [(vals (var expr) ...)
+		   (with-syntax ([(vars ...) (map normal-var (syntax->list (syntax (var ...))))])
+		     (syntax (let-values ([vars expr] ...) rest)))]
+		  [(recs (var expr) ...)
+		   (with-syntax ([(vars ...) (map normal-var (syntax->list (syntax (var ...))))])
+		     (syntax (letrec-values ([vars expr] ...) rest)))]
+		  [(_ expr0 expr ...)
+		   (syntax (begin expr0 expr ... rest))])))))])))
+
+ (define ns-undefined (gensym))
+
+ (define (namespace-defined? n)
+   (unless (symbol? n)
+     (raise-type-error 'namespace-defined? "symbol" n))
+   (not (eq? (namespace-variable-value n #t (lambda () ns-undefined)) ns-undefined)))
+
+ (define-syntax (this-expression-source-directory stx)
+   (syntax-case stx ()
+     [(_)
+      (let* ([source (syntax-source stx)]
+	     [local (lambda ()
+		      (or (current-load-relative-directory)
+			  (current-directory)))]
+	     [dir (plthome-ify
+                   (or (and source (string? source) (file-exists? source)
+                            (let-values ([(base file dir?) (split-path source)])
+                              (and (string? base)
+                                   (path->complete-path
+                                    base
+                                    (or (current-load-relative-directory)
+                                        (current-directory))))))
+                       (local)))])
+        (if (and (pair? dir) (eq? 'plthome (car dir)))
+          (with-syntax ([d dir])
+            (syntax (un-plthome-ify 'd)))
+          (datum->syntax-object (quote-syntax here) dir stx)))]))
+
+ ;; This is a macro-generating macro that wants to expand
+ ;; expressions used in the generated macro. So it's weird,
+ ;; and we put much of the work in a helper macro,
+ ;; `finish-syntax-set'.
+ (define-syntax (define-syntax-set stx)
+   (syntax-case stx ()
+     [(_ (id ...) defn ...)
+      (let ([ids (syntax->list (syntax (id ...)))])
+	;; Check ids ------------------------------
+	(for-each (lambda (id)
+		    (unless (identifier? id)
+		      (raise-syntax-error
+		       #f
+		       "not an identifier or two identifier in parentheses"
+		       stx
+		       id)))
+		  ids)
+	(let ([dup (check-duplicate-identifier ids)])
+	  (when dup
+	    (raise-syntax-error
+	     #f
+	     "duplicate identifier"
+	     stx
+	     dup)))
+
+	;; We'd like to check the `defns', but that requires
+	;; and expansion in a different phase. So we move
+	;; into that phase using `finish-syntax-set':
+	(with-syntax ([orig-stx stx])
+	  (syntax/loc stx
+	    (define-syntaxes (id ...)
+	      (finish-syntax-set orig-stx)))))]))
+  
+  (define-syntax (hash-table stx)
+    (syntax-case stx ()
+      [(_ (key value) ...)
+       (syntax/loc stx
+         (let ([ht (make-hash-table)])
+           (hash-table-put! ht key value) ...
+           ht))])))
diff --git a/collects/frtime/frp.ss b/collects/frtime/frp.ss
new file mode 100644
index 0000000000..4807e5dea2
--- /dev/null
+++ b/collects/frtime/frp.ss
@@ -0,0 +1,1517 @@
+; Ideas:
+;  make smart 'if'
+;  tag impure and imperative signals (pure vs. stateful vs. effectful)
+;  use weak boxes in internal queue
+;  have manager initialize signals
+;  
+;
+; To do:
+; QUESTION: should cond change to skip undefined conditions?
+; make switchable events
+; split delay into consumer and producer
+; deal with multiple values (?)
+; handle structs, vectors (done?)
+; localized exception-handling mechanism
+; precise depths even when switching, proper treatment of cycles
+; revisit cons, vector [, structs]
+;
+; generalize and improve notion of time
+;  (e.g., combine seconds & milliseconds,
+;  give user general "timer : number -> signal (event?)"
+;  'loose' timers that don't exactly measure real time
+;   (e.g., during garbage-collection)
+; completely restructure:
+;  eliminate alarms, give processes timeouts
+;  make special constructor signals (?)
+;   (have tried and achieved unencouraging results)
+;  separate signal and event structures (?)
+;    - could make event a substructure of signal,
+;      but this could be problematic for letrec
+;    - better option seems to be explicit tag
+; partial-order based evaluation:
+;  - add a 'depth' field to signal structure (DONE)
+;  - make 'register' responsible for maintaining consistency
+;  - 'switch' can result in cycle, in which case consistent
+;    depths cannot be assigned
+;  - should perhaps tag delay, integral nodes
+; selective evaluation (?)
+; consider adding placeholders again, this time as part
+;   of the FRP system
+;   (probably not necessary, since signals can serve
+;    in this role)
+; consider whether any other syntax should be translated
+;   (e.g. 'begin')
+; consider 'strict structure'
+;
+; Done:
+; mutual dependencies between signals (sort of ...)
+; fix delay bug
+; allow delay to take a time signal (sort of ...)
+; events:
+;   use signal structs where value is tail of stream
+;   interface with other libraries (e.g. graphics), other threads
+;   hold : event * val -> signal
+;   changes : signal -> event
+;   map-e : event[a] * (a -> b) -> event[b]
+;   merge-e : event[a1] * event[a2] * ... -> event[a1 U a2 U ...]
+;   filter-e : event[a] * (a -> bool) -> event[a]
+;   accum : event[a] * b * (a -> b -> b) -> event[b]
+; modify graphics library to send messages for events
+; signal manager's priority queue should
+;   - maintain weak boxes
+;   - check stale flag before enqueuing for update
+; delete dead weak references
+; fix letrec-b macro to use switch
+; - allow fn signals
+; eliminate letrec-b, make appropriate letrec macro
+;  ('undefined' value) (probably)
+; rewrite lift
+; - provide specialized lift for 0-3 (?) arguments
+; fix subtle concurrency issue between
+;  signal creation outside manager thread
+;  and activities of manager, particularly
+;  involving registration/deregistration
+;  (solution: send reg/unreg requests to manager if necessary)
+; make separate library for graphics
+;
+; need to get rid of #%app macro, explicitly lift procedures, usually
+; bottom-strictly
+;
+; remove #%app, lambda, and define macros; lift all
+;   primitives, redefine higher-order procedures
+;   macro to automate definition of lifted primitives
+;   make signals directly applicable
+; flip arguments in event-handling combinators (done)
+;
+
+(module frp mzscheme
+  
+  (require (lib "list.ss")
+           (lib "etc.ss")
+           (lib "class.ss")
+           (all-except (lib "mred.ss" "mred") send-event)
+           (lib "string.ss")
+           "erl.ss"
+           (lib "match.ss")
+           "heap.ss")
+  
+  (require-for-syntax (lib "list.ss"))
+
+  (define frtime-version "0.3b -- Tue Nov 9 13:39:45 2004")
+  (define frtime-inspector (make-inspector))
+  (print-struct #t)
+
+  (define snap? (make-parameter #f))
+  
+  ; also models events, where 'value' is all the events that
+  ; haven't yet occurred (more specifically, an event-cons cell whose
+  ; tail is *undefined*)
+  (define-values (struct:signal
+                  make-signal
+                  signal?
+                  signal-value
+                  signal-dependents
+                  signal-stale?
+                  signal-thunk
+                  signal-depth
+                  signal-continuation-marks
+                  signal-guards
+                  set-signal-value!
+                  set-signal-dependents!
+                  set-signal-stale?!
+                  set-signal-thunk!
+                  set-signal-depth!
+                  set-signal-continuation-marks!
+                  set-signal-guards)
+    (let-values ([(desc make-signal signal? acc mut)
+                  (make-struct-type
+                   'signal #f 7 0 #f null frtime-inspector
+                   (lambda (fn . args)
+                     (unregister #f fn) ; clear out stale dependencies from previous apps
+                     (let* ([cur-fn (value-now fn)]
+                            [cur-app (safe-eval (apply cur-fn args))]
+                            [ccm (current-continuation-marks)]
+                            [ret (proc->signal void fn cur-app)]
+                            [thunk (lambda ()
+                                     (when (not (eq? cur-fn (value-now fn)))
+                                       (unregister ret cur-app)
+                                       (set! cur-fn (value-now fn))
+                                       (set! cur-app (safe-eval (apply cur-fn args)))
+                                       (when (signal? cur-app)
+                                         (set-signal-continuation-marks! cur-app ccm))
+                                       (register ret cur-app))
+                                     (value-now cur-app))])
+                       (set-signal-thunk! ret thunk)
+                       ; may need to change for multiple values
+                       (set-signal-value! ret (thunk))
+                       ret)))]
+                 [(field-name-symbols) (list 'value 'dependents 'stale? 'thunk 'depth 'continuation-marks 'guards)])
+      (apply values
+             desc
+             make-signal
+             signal?
+             (append
+              (build-list (length field-name-symbols)
+                          (lambda (i) (make-struct-field-accessor acc i (list-ref field-name-symbols i))))
+              (build-list (length field-name-symbols)
+                          (lambda (i) (make-struct-field-mutator mut i (list-ref field-name-symbols i))))))))
+  
+  (define-struct guard (signal trans))
+  (define-struct non-scheduled (signal))
+  
+  (define current-guards
+    (make-parameter empty))
+  
+  (define-struct multiple (values))
+  
+  (define-struct event-cons (head tail))
+  (define econs make-event-cons)
+  (define efirst event-cons-head)
+  (define erest event-cons-tail)
+  (define econs? event-cons?)
+  (define set-efirst! set-event-cons-head!)
+  (define set-erest! set-event-cons-tail!)
+  
+  (define (event? v)
+    (and (signal? v)
+         (if (undefined? (signal-value v))
+             undefined
+             (event-cons? (signal-value v)))))
+
+  (define (event-receiver? v)
+    (and (event? v)
+         (procedure-arity-includes? (signal-thunk v) 1)))
+  
+  (define (behavior? v)
+    (and (signal? v) (not (event-cons? (signal-value v)))))
+  
+  (define (safe-signal-depth v)
+    (cond
+      [(signal? v) (signal-depth v)]
+      [(non-scheduled? v) (signal-depth (non-scheduled-signal v))]
+      [0]))
+  
+  (define (proc->signal thunk . producers)
+    (let* ([guard-sigs (map guard-signal (current-guards))]
+           [all-dependees (append guard-sigs producers)]
+           [sig (make-signal
+                 undefined empty #f thunk
+                 (add1 (apply max 0 (map safe-signal-depth
+                                         all-dependees)))
+                 (current-continuation-marks)
+                 (current-guards))])
+      (when (cons? producers)
+        (register sig producers))
+      (when (cons? guard-sigs)
+        (register (make-non-scheduled sig) guard-sigs))
+      (set-signal-value! sig (safe-eval (thunk)))
+      sig))
+  
+  (define errortrace-key 'drscheme-debug-continuation-mark-key)
+  
+  (define (install-errortrace-key key)
+    (set! key key))
+  
+  ; messages for signal manager; we now ensure that
+  ; only the manager manipulates the dependency graph
+  (define-struct reg (inf sup ret))
+  (define-struct unreg (inf sup))
+  
+  ; an external event; contains a list of pairs
+  ; (recip val), where val is passed to recip's thunk
+  (define-struct external-event (recip-val-pairs))
+
+  ; update the given signal at the given time
+  (define-struct alarm (time signal))
+  
+  (define (frp:if-helper test then-thunk else-thunk undef-thunk)
+    (let* ([if-fun (let ([true-guards (cons (make-guard test identity) (current-guards))]
+                         [false-guards (cons (make-guard test not) (current-guards))]
+                         [undef-guards (cons (make-guard test undefined?) (current-guards))])
+                     (lambda (b)
+                       (cond
+                         [(undefined? b) (parameterize ([current-guards undef-guards])
+                                           (undef-thunk))]
+                         [b (parameterize ([current-guards true-guards])
+                              (then-thunk))]
+                         [else (parameterize ([current-guards false-guards])
+                                 (else-thunk))])))])
+      (switch
+       ((changes test) . ==> .
+                       if-fun)
+       (if-fun (value-now test)))))
+  
+  (define (weakly-cache thunk)
+    (let ([cache (make-weak-box #f)])
+      (lambda ()
+        (cond
+          [(weak-box-value cache)]
+          [else (let ([result (thunk)])
+                  (set! cache (make-weak-box result))
+                  result)]))))
+  
+  (define-syntax frp:if
+    (syntax-rules ()
+      [(_ test-exp then-exp)
+       (frp:if test-exp then-exp (void))]
+      [(_ test-exp then-exp else-exp)
+       (frp:if test-exp then-exp else-exp undefined)]
+      [(_ test-exp then-exp else-exp undef-exp)
+       (let ([v test-exp])
+         (cond
+           [(behavior? v) (frp:if-helper v (lambda () then-exp) (lambda () else-exp) (lambda () undef-exp))]
+           [(undefined? v) undef-exp]
+           [v then-exp]
+           [else else-exp]))]))
+  
+  ; value-now : signal[a] -> a
+  (define (value-now val)
+    (if (signal? val)
+        (signal-value val)
+        val))
+  
+  ; no multiple value support
+  (define (value-now/copy val)
+    (if (signal? val)
+        (let ([v1 (signal-value val)])
+          (if (vector? v1)
+              (build-vector (vector-length v1) (lambda (i) (vector-ref v1 i)))
+              v1))
+        val))
+            
+  
+  ;   (define value-now/copy
+  ;     (frp:lambda (val)
+  ;       (match val
+  ;         [($ signal value _ _ _) (cond
+  ;                                     [(cons? value)
+  ;                                      (cons (first value) (rest value))]
+  ;                                     [(posn? value)
+  ;                                      (make-posn (posn-x value) (posn-y value))]
+  ;                                     [else value])]
+  ;         [_ val])))
+  
+  ; *** will have to change significantly to support depth-guided recomputation ***
+  ; Basically, I'll have to check that I'm not introducing a cycle.
+  ; If there is no cycle, then I simply ensure that inf's depth is at least one more than
+  ; sup's.  If this requires an increase to inf's depth, then I need to propagate the
+  ; new depth to inf's dependents.  Since there are no cycles, this step is guaranteed to
+  ; terminate.  When checking for cycles, I should of course stop when I detect a pre-existing
+  ; cycle.
+  ; If there is a cycle, then 'inf' has (and retains) a lower depth than 'sup' (?), which
+  ; indicates the cycle.  Importantly, 'propagate' uses the external message queue whenever
+  ; a dependency crosses an inversion of depth.
+  (define (fix-depths inf sup)
+    (let help ([inf inf] [sup sup] [mem empty])
+      (if (memq sup mem)
+          (send-event exceptions (list (make-exn:fail "delay-less cycle in dataflow graph" (signal-continuation-marks sup))
+                                       sup))
+          (when (<= (safe-signal-depth inf)
+                    (safe-signal-depth sup))
+            (set-signal-depth! inf (add1 (safe-signal-depth sup)))
+            (for-each
+             (lambda (dep) (help dep inf (cons sup mem)))
+             (foldl (lambda (wb acc)
+                      (match (weak-box-value wb)
+                        [(and sig (? signal?)) (cons sig acc)]
+                        [(and (? non-scheduled?) (= non-scheduled-signal sig)) (cons sig acc)]
+                        [_ acc]))
+                    empty (signal-dependents inf)))))))
+  
+  (define (register inf sup)
+    (if (eq? (self) man)
+        (match sup
+          [(and (? signal?)
+                (= signal-dependents dependents))
+           (set-signal-dependents!
+            sup
+            (cons (make-weak-box inf) dependents))
+           (fix-depths inf sup)]
+          [(? list?) (for-each (lambda (sup1) (register inf sup1)) sup)]
+          [_ (void)])
+        (begin
+          (! man (make-reg inf sup (self)))
+          (receive [(? man?) (void)])))
+    inf)
+    
+  (define (unregister inf sup)
+    (if (eq? (self) man)
+        (match sup
+          [(and (? signal?)
+                (= signal-dependents dependents))
+           (set-signal-dependents!
+            sup
+            (filter (lambda (a)
+                      (let ([v (weak-box-value a)])
+                        (nor (eq? v inf)
+                             (eq? v #f))))
+                    dependents))]
+          [_ (void)])
+        (! man (make-unreg inf sup))))
+  
+  (define-values (undefined undefined?)
+    (let-values ([(desc make-undefined undefined? acc mut)
+                  (make-struct-type
+                   'undefined #f 0 0 #f null frtime-inspector
+                   (lambda (fn . args) fn))])
+      (values (make-undefined) undefined?)))
+#|
+  (define undefined
+    (string->uninterned-symbol "<undefined>"))
+  (define (undefined? x)
+    (eq? x undefined))
+|#  
+  (define-syntax safe-eval
+    (syntax-rules ()
+      [(_ expr ...)
+       (with-continuation-mark
+        'frtime 'safe-eval
+        (with-handlers ([exn:fail?
+                         (lambda (exn)
+                           (cond
+                             #;[(and (exn:fail? exn)
+                                   (undefined? (exn:application-value exn)))]
+                             [(man?) (iq-enqueue (list exceptions (list exn 'unknown)))]
+                             [else (thread (lambda () (fprintf (current-error-port) "exception caught outside frtime engine~n") (raise exn)))])
+                           undefined)])
+          expr ...))]))
+  
+  ; could use special treatment for constructors
+  ; to avoid making lots of garbage (?)
+  (define create-strict-thunk
+    (case-lambda
+      [(fn) fn]
+      [(fn arg1) (lambda ()
+                   (let ([a1 (value-now arg1)])
+                     (if (undefined? a1)
+                         undefined
+                         (fn a1))))]
+      [(fn arg1 arg2) (lambda ()
+                        (let ([a1 (value-now arg1)]
+                              [a2 (value-now arg2)])
+                          (if (or (undefined? a1)
+                                  (undefined? a2))
+                              undefined
+                              (fn a1 a2))))]
+      [(fn arg1 arg2 arg3) (lambda ()
+                             (let ([a1 (value-now arg1)]
+                                   [a2 (value-now arg2)]
+                                   [a3 (value-now arg3)])
+                               (if (or (undefined? a1)
+                                       (undefined? a2)
+                                       (undefined? a3))
+                                   undefined
+                                   (fn a1 a2 a3))))]
+      [(fn . args) (lambda ()
+                     (let ([as (map value-now args)])
+                       (if (ormap undefined? as)
+                           undefined
+                           (apply fn as))))]))
+  
+  (define create-thunk
+    (case-lambda
+      [(fn) fn]
+      [(fn arg1) (lambda () (fn (value-now arg1)))]
+      [(fn arg1 arg2) (lambda () (fn (value-now arg1) (value-now arg2)))]
+      [(fn arg1 arg2 arg3) (lambda () (fn (value-now arg1)
+                                          (value-now arg2)
+                                          (value-now arg3)))]
+      [(fn . args) (lambda () (apply fn (map value-now args)))]))
+
+  (define (lift strict? fn . args)
+    (if (snap?) ;; maybe fix later to handle undefined-strictness
+        (apply fn (map value-now args))
+        (with-continuation-mark
+            'frtime 'lift-active
+          (if (ormap behavior? args)
+              (apply
+               proc->signal
+               (apply (if strict? create-strict-thunk create-thunk) fn args)
+               args)
+              (if (and strict? (ormap undefined? args))
+                  undefined
+                  (apply fn args))))))
+  
+  (define (last)
+    (let ([prev #f])
+      (lambda (v)
+        (let ([ret (if prev prev v)])
+          (set! prev v)
+          ret))))
+  
+  (define (extract k evs)
+    (if (cons? evs)
+        (let ([ev (first evs)])
+          (if (or (eq? ev undefined) (undefined? (erest ev)))
+              (extract k (rest evs))
+              (begin
+                (let ([val (efirst (erest ev))])
+                  (set-first! evs (erest ev))
+                  (k val)))))))
+  
+  ; until : behavior behavior -> behavior
+  (define (b1 . until . b2)
+    (proc->signal
+     (lambda () (if (undefined? (value-now b2))
+                    (value-now b1)
+                    (value-now b2)))
+     ; deps
+     b1 b2))
+  
+  (define (fix-streams streams args)
+    (if (empty? streams)
+        empty
+        (cons
+         (if (undefined? (first streams))
+             (let ([stream (signal-value (first args))])
+               stream
+               #;(if (undefined? stream)
+                   stream
+                   (if (equal? stream (econs undefined undefined))
+                       stream
+                       (econs undefined stream))))
+             (first streams))
+         (fix-streams (rest streams) (rest args)))))
+  
+  (define (general-event-processor proc . args)
+    ; proc : (lambda (emit suspend first-evt) ...)
+    (let* ([out (econs undefined undefined)]
+           [esc #f]
+           [emit (lambda (val)
+                   (set-erest! out (econs val undefined))
+                   (set! out (erest out))
+                   val)]
+           [streams (map signal-value args)])
+      (letrec ([suspend (lambda ()
+                          (call/cc
+                           (lambda (k)
+                             (set! proc-k k)
+                             (esc (void)))))]
+               [proc-k (lambda (evt) (proc emit suspend evt) (set! proc-k #f))])
+        (let ([thunk (lambda ()
+                        (when (ormap undefined? streams)
+                          ;(fprintf (current-error-port) "had an undefined stream~n")
+                          (set! streams (fix-streams streams args)))
+                        (let loop ()
+                          (extract (lambda (the-event)
+                                     (when proc-k
+                                       (call/cc
+                                        (lambda (k)
+                                          (set! esc k)
+                                          (proc-k the-event)))) (loop))
+                                   streams))
+                        (set! streams (map signal-value args))
+                        out)])
+          (apply proc->signal thunk args)))))
+  
+  (define (event-processor proc . args)
+    (let* ([out (econs undefined undefined)]
+           [proc/emit (proc
+                       (lambda (val)
+                         (set-erest! out (econs val undefined))
+                         (set! out (erest out))
+                         val))]
+           [streams (map signal-value args)]
+           [thunk (lambda ()
+                    (when (ormap undefined? streams)
+                      ;(fprintf (current-error-port) "had an undefined stream~n")
+                      (set! streams (fix-streams streams args)))
+                    (let loop ()
+                      (extract (lambda (the-event) (proc/emit the-event) (loop))
+                               streams))
+                    (set! streams (map signal-value args))
+                    out)])
+      (apply proc->signal thunk args)))
+
+  (define (event-producer2 proc . deps)
+    (let* ([out (econs undefined undefined)]
+           [proc/emit (proc
+                       (lambda (val)
+                         (set-erest! out (econs val undefined))
+                         (set! out (erest out))
+                         val))])
+      (apply proc->signal (lambda the-args (apply proc/emit the-args) out) deps)))
+    
+  #;(define-syntax (event-processor stx)
+    (syntax-case stx ()
+      [(src-event-processor proc args)
+       (with-syntax ([emit (datum->syntax-object (syntax src-event-processor) 'emit)]
+                     [the-event (datum->syntax-object
+                                 (syntax src-event-processor) 'the-event)])
+         (syntax (let* ([out (econs undefined undefined)]
+                        [emit (lambda (val)
+                                (set-erest! out (econs val undefined))
+                                (set! out (erest out)))]
+                        [streams (map signal-value args)]
+                        [thunk (lambda ()
+                                 (when (ormap undefined? streams)
+                                   (fprintf (current-error-port) "had an undefined stream~n")
+                                   (set! streams (fix-streams streams args)))
+                                 (let loop ()
+                                   (extract (lambda (the-event) proc (loop))
+                                            streams))
+                                 (set! streams (map signal-value args))
+                                 out)])
+                   (apply proc->signal thunk args))))]))
+  
+  (define-syntax (event-producer stx)
+    (syntax-case stx ()
+      [(src-event-producer expr dep ...)
+       (with-syntax ([emit (datum->syntax-object (syntax src-event-producer) 'emit)]
+                     [the-args (datum->syntax-object
+                                (syntax src-event-producer) 'the-args)])
+         (syntax (let* ([out (econs undefined undefined)]
+                        [emit (lambda (val)
+                                (set-erest! out (econs val undefined))
+                                (set! out (erest out)))])
+                   (proc->signal (lambda the-args expr out) dep ...))))]))
+  
+  ; switch : event[behavior] behavior -> behavior
+  (define switch
+    (opt-lambda (e [init undefined])
+      (let ([e-b (hold e init)])
+        (rec ret
+          (proc->signal
+           (case-lambda
+             [()
+              (when (not (eq? init (signal-value e-b)))
+                (unregister ret init)
+                (set! init (value-now e-b))
+                (register ret init)
+                (set-signal-depth! ret (max (signal-depth ret)
+                                            (add1 (safe-signal-depth init)))))
+              (if (signal? init)
+                  (signal-value init)
+                  init)]
+             [(msg) e])
+           e-b init)))))
+  
+  ; event ... -> event
+  (define (merge-e . args)
+    (apply event-processor
+           (lambda (emit)
+             (lambda (the-event)
+               (emit the-event)))
+           args))
+  
+  (define (once-e e)
+    (let ([b true])
+      (rec ret (event-processor
+                (lambda (emit)
+                  (lambda (the-event)
+                    (when b
+                      (set! b false)
+                      (unregister ret e)
+                      (emit the-event))))
+                e))))
+  
+  ; behavior[a] -> event[a]
+  (define (changes b)
+    (event-producer2
+     (lambda (emit)
+       (lambda the-args
+         (emit (value-now/copy b))))
+     b))
+  
+  (define (event-forwarder sym evt f+l)
+    (event-processor
+     (lambda (emit)
+       (lambda (the-event)
+         (for-each (lambda (tid) (! tid (list 'remote-evt sym the-event))) (rest f+l))))
+     evt))
+  
+  ; event-receiver : () -> event
+  (define (event-receiver)
+    (event-producer2
+     (lambda (emit)
+       (lambda the-args
+         (when (cons? the-args)
+           (emit (first the-args)))))))
+  
+  ; when-e : behavior[bool] -> event
+  (define (when-e b)
+    (let* ([last (value-now b)])
+      (event-producer2
+       (lambda (emit)
+         (lambda the-args
+           (let ([current (value-now b)])
+             (when (and (not last) current)
+               (emit current))
+             (set! last current))))
+       b)))
+  
+  ; while-e : behavior[bool] behavior[number] -> event
+  (define (while-e b interval)
+    (rec ret (event-producer2
+              (lambda (emit)
+                (lambda the-args
+                  (cond
+                    [(value-now b) =>
+                                   (lambda (v)
+                                     (emit v)
+                                     (schedule-alarm (+ (value-now interval) (current-milliseconds)) ret))])))
+              b)))
+  
+  ; ==> : event[a] (a -> b) -> event[b]
+  (define (e . ==> . f)
+    (event-processor
+     (lambda (emit)
+       (lambda (the-event)
+         (emit ((value-now f) the-event))))
+     e))
+  
+  #|
+  (define (e . =>! . f)
+    (event-processor
+     ((value-now f) the-event)
+     (list e)))
+  |#
+  
+  ; -=> : event[a] b -> event[b]
+  (define-syntax -=>
+    (syntax-rules ()
+      [(_ e k-e) (==> e (lambda (_) k-e))]))
+  
+  ; =#> : event[a] (a -> bool) -> event[a]
+  (define (e . =#> . p)
+    (event-processor
+     (lambda (emit)
+       (lambda (the-event)
+         (when (value-now (p the-event))
+           (emit the-event))))
+     e))
+  
+  (define nothing (void));(string->uninterned-symbol "nothing"))
+  
+  (define (nothing? v) (eq? v nothing))
+
+  ; =#=> : event[a] (a -> b U nothing) -> event[b]
+  (define (e . =#=> . f)
+    (event-processor
+     (lambda (emit)
+       (lambda (the-event)
+         (let ([x (f the-event)])
+           (unless (or (nothing? x) (undefined? x))
+             (emit x)))))
+     e))
+  
+  (define (map-e f e)
+    (==> e f))
+  (define (filter-e p e)
+    (=#> e p))
+  (define (filter-map-e f e)
+    (=#=> e f))
+  
+  ; event[a] b (a b -> b) -> event[b]
+  (define (collect-e e init trans)
+    (event-processor
+     (lambda (emit)
+       (lambda (the-event)
+         (let ([ret (trans the-event init)])
+           (set! init ret)
+           (emit ret))))
+     e))
+  
+  ; event[(a -> a)] a -> event[a]
+  (define (accum-e e init)
+    (event-processor
+     (lambda (emit)
+       (lambda (the-event)
+         (let ([ret (the-event init)])
+           (set! init ret)
+           (emit ret))))
+     e))
+  
+  ; event[a] b (a b -> b) -> behavior[b]
+  (define (collect-b ev init trans)
+    (hold (collect-e ev init trans) init))
+  
+  ; event[(a -> a)] a -> behavior[a]
+  (define (accum-b ev init)
+    (hold (accum-e ev init) init))
+  
+  ; hold : a event[a] -> behavior[a]
+  (define hold 
+    (opt-lambda (e [init undefined])
+      (proc->signal
+       (let ([b true])
+         (lambda ()
+           (if b
+               (begin (set! b false) init)
+               (efirst (signal-value e)))))
+       e)))
+  
+  ; event[a] signal[b]* -> event[(list a b*)]
+  (define (snapshot-e e . bs)
+    (event-processor
+     (lambda (emit)
+       (lambda (the-event)
+         (emit (cons the-event (map value-now bs)))))
+     e))
+
+  (define (snapshot/apply fn . args)
+    (apply fn (map value-now args)))
+  
+  ; (a b* -> c) event[a] signal[b]* -> event[c]
+  (define (snapshot-map-e fn ev . bs)
+    (event-processor
+     (lambda (emit)
+       (lambda (the-event)
+         (emit (apply fn the-event (map value-now bs)))))
+     ev))
+
+  (define-syntax (event-loop-help stx)
+    (syntax-case stx ()
+      [(_ ([name expr] ...)
+          [e => body] ...)
+       (with-syntax ([args #'(name ...)])
+         #'(accum-e
+            (merge-e
+             (e . ==> . (lambda (v)
+                          (lambda (state)
+                            (apply
+                             (lambda args (body v))
+                             state)))) ...)
+            (list expr ...)))]))
+  
+  (define-syntax (event-loop stx)
+    
+    (define (add-arrow clause)
+      (syntax-case clause (=>)
+        [(e => body) #'(e => body)]
+        [(e body) #'(e => (lambda (_) body))]))
+    
+    (syntax-case stx ()
+      [(_ ([name expr] ...)
+          clause ...)
+       (with-syntax ([(new-clause ...)
+                      (map add-arrow (syntax->list #'(clause ...)))])
+         #'(event-loop-help
+            ([name expr] ...)
+            new-clause ...)
+         )]))
+
+  (define update
+    (case-lambda
+      [(b) (update0 b)]
+      [(b a) (update1 b a)]))
+  
+  (define-values (iq-enqueue iq-dequeue iq-empty?)
+    (let* ([depth
+            (lambda (msg)
+              (if (signal? msg) 
+                  (signal-depth msg)
+                  (signal-depth (first msg))))]
+           [heap (make-heap
+                 (lambda (b1 b2) (< (depth b1) (depth b2)))
+                 eq?)])
+      (values
+       (lambda (b) (heap-insert heap b))
+       (lambda () (heap-pop heap))
+       (lambda () (heap-empty? heap)))))
+  
+  ; *** will have to change ... ***
+  (define (propagate b)
+    (let ([empty-boxes 0]
+          [dependents (signal-dependents b)]
+          [depth (signal-depth b)])
+      (for-each
+       (lambda (wb)
+         (match (weak-box-value wb)
+           [(and dep (? signal?) (= signal-stale? #f))
+            (set-signal-stale?! dep #t)
+            ; If I'm crossing a "back" edge (one potentially causing a cycle),
+            ; then I send a message.  Otherwise, I add to the internal
+            ; priority queue.
+            (if (< depth (signal-depth dep))
+                (iq-enqueue dep)
+                (! man dep))]
+           [_
+            (set! empty-boxes (add1 empty-boxes))]))
+       dependents)
+      (when (> empty-boxes 9)
+        (set-signal-dependents!
+         b
+         (filter weak-box-value dependents)))))
+  
+  (define (update0 b)
+    (match b
+      [(and (? signal?)
+            (= signal-value value)
+            (= signal-thunk thunk)
+            (= signal-guards guards))
+       (set-signal-stale?! b #f)
+       (let ([new-value (parameterize ([current-guards guards])
+                          (thunk))])
+         ; consider modifying this test in order to support, e.g., mutable structs
+         (when (or (vector? new-value) (not (equal? value new-value)))
+           (set-signal-value! b new-value)
+           (propagate b)))]
+      [_ (void)]))
+  
+  (define (update1 b a)
+    (match b
+      [(and (? signal?)
+            (= signal-value value)
+            (= signal-thunk thunk))
+       (set-signal-stale?! b #f)
+       (let ([new-value (thunk a)])
+         ; consider modifying this test in order to support, e.g., mutable structs
+         (when (not (equal? value new-value))
+           (set-signal-value! b new-value)
+           (propagate b)))]
+      [_ (void)]))
+  
+  (define (undef b)
+    (match b
+      [(and (? signal?)
+            (= signal-value value))
+       (set-signal-stale?! b #f)
+       (when (not (undefined? value))
+         (set-signal-value! b undefined)
+         (propagate b))]
+      [_ (void)]))
+  
+  (define named-dependents (make-hash-table))
+  
+  (define (bind sym evt)
+    (! man (list 'bind sym evt))
+    evt)
+  
+  (define (remote-reg tid sym)
+    (hash-table-get named-dependents sym
+                    (lambda ()
+                      (let ([ret (event-receiver)])
+                        (hash-table-put! named-dependents sym ret)
+                        (! tid (list 'remote-reg man sym))
+                        ret))))
+  
+  (define-values (alarms-enqueue alarms-dequeue-beh alarms-peak-ms alarms-empty?)
+    (let ([heap (make-heap (lambda (a b) (< (first a) (first b))) eq?)])
+      (values (lambda (ms beh) (heap-insert heap (list ms (make-weak-box beh))))
+              (lambda () (match (heap-pop heap) [(_ beh) (weak-box-value beh)]))
+              (lambda () (match (heap-peak heap) [(ms _) ms]))
+              (lambda () (heap-empty? heap)))))
+  
+  (define exceptions
+    (event-receiver))
+  
+  (define notifier
+    (event-producer2
+     (lambda (emit)
+       (lambda the-args
+         (when (cons? the-args)
+           (let ([arg (first the-args)])
+             (! (first arg) ((second arg)))))))))
+  (set-signal-depth! notifier +inf.0)
+
+  ;; the manager of all signals and event streams
+  (define man
+    (spawn/name
+     'frtime-heart
+     (let ([named-providers (make-hash-table)]
+           [cur-beh #f])
+       (let outer ()
+         (with-handlers ([exn:fail?
+                          (lambda (exn)
+                            (when (and cur-beh
+                                       (andmap (lambda (g) ((guard-trans g) (value-now (guard-signal g))))
+                                               (signal-guards cur-beh)))
+                              #;(when (empty? (continuation-mark-set->list (exn-continuation-marks exn) 'frtime))
+                                  (set-exn-continuation-marks! exn (signal-continuation-marks cur-beh)))
+                              (iq-enqueue (list exceptions (list exn cur-beh)))
+                              (when (behavior? cur-beh)
+                                (undef cur-beh)))
+                            (outer))])
+           (let inner ()
+             
+             ;; process external messages until there is an internal update
+             ;; or an expired alarm
+             (let loop ()
+               (receive [after (cond
+                                 [(not (iq-empty?)) 0]
+                                 [(not (alarms-empty?)) (- (alarms-peak-ms)
+                                                           (current-milliseconds))]
+                                 [else #f])
+                               (void)]
+                 [(? signal? b)
+                  (iq-enqueue b)
+                  (loop)]
+                 [($ external-event recip-val-pairs)
+                  (for-each iq-enqueue recip-val-pairs)
+                  (loop)]
+                 [($ alarm ms beh)
+                  (schedule-alarm ms beh)
+                  (loop)]
+                 [($ reg inf sup ret)
+                  (register inf sup)
+                  (! ret man)
+                  (loop)]
+                 [($ unreg inf sup)
+                  (unregister inf sup)
+                  (loop)]
+                 [('bind sym evt)
+                  (let ([forwarder+listeners (cons #f empty)])
+                    (set-car! forwarder+listeners
+                              (event-forwarder sym evt forwarder+listeners))
+                    (hash-table-put! named-providers sym forwarder+listeners))
+                  (loop)]
+                 [('remote-reg tid sym)
+                  (let ([f+l (hash-table-get named-providers sym)])
+                    (when (not (member tid (rest f+l)))
+                      (set-rest! f+l (cons tid (rest f+l)))))
+                  (loop)]
+                 [('remote-evt sym val)
+                  (iq-enqueue (list (hash-table-get named-dependents sym (lambda () dummy)) val))
+                  (loop)]
+                 [msg
+                  (fprintf (current-error-port)
+                           "frtime engine: msg not understood: ~a~n"
+                           msg)
+                  (loop)]))
+             
+             ;; enqueue expired timers for execution
+             (let loop ()
+               (unless (or (alarms-empty?)
+                           (< (current-milliseconds)
+                              (alarms-peak-ms)))
+                 (let ([beh (alarms-dequeue-beh)])
+                   (when (and beh (not (signal-stale? beh)))
+                     (set-signal-stale?! beh #t)
+                     (iq-enqueue beh)))
+                 (loop)))
+
+             ;; process internal updates
+             (let loop ()
+               (unless (iq-empty?)
+                 (match (iq-dequeue)
+                   [(b val)
+                    (set! cur-beh b)
+                    (update1 b val)
+                    (set! cur-beh #f)]
+                   [b
+                    (set! cur-beh b)
+                    (update0 b)
+                    (set! cur-beh #f)])
+                 (loop)))
+             
+             (inner)))))))
+
+  (define man?
+    (opt-lambda ([v (self)])
+      (eq? v man)))
+
+  (define dummy
+    (proc->signal void))
+  
+  (define (silly)
+    (letrec ([res (proc->signal
+                   (let ([x 0]
+                         [init (current-milliseconds)])
+                     (lambda ()
+                       (if (< x 400000)
+                           (begin
+                             (set! x (+ x 1)))
+                           (begin
+                             (printf "time = ~a~n" (- (current-milliseconds) init))
+                             (set-signal-dependents! res empty)))
+                       x)))])
+      (set-signal-dependents! res (cons (make-weak-box res) empty))
+      (! man res)
+      res))
+  
+  (define (simple-b fn)
+    (let ([ret (proc->signal void)])
+      (set-signal-thunk! ret (fn ret))
+      (set-signal-value! ret ((signal-thunk ret)))
+      ret))
+  
+  (define (send-event rcvr val)
+    (! man (make-external-event (list (list rcvr val)))))
+
+  (define (send-synchronous-event rcvr val)
+    (when (man?)
+      (error 'send-synchronous-event "already in frtime engine (would deadlock)"))
+    (! man (make-external-event (list (list rcvr val) (list notifier (list (self) (lambda () man))))))
+    (receive [(? man?) (void)]))
+
+  (define (send-synchronous-events rcvr-val-pairs)
+    (when (man?)
+      (error 'send-synchronous-events "already in frtime engine (would deadlock)"))
+    (unless (ormap list? rcvr-val-pairs) (error "not list"))
+    (unless (ormap signal? (map first rcvr-val-pairs)) (error "not signals"))
+    (! man (make-external-event (cons (list notifier (list (self) (lambda () man))) rcvr-val-pairs)))
+    (receive [(? man?) (void)]))
+
+  (define (sync/read . signals)
+    (if (man?)
+        (apply values (map value-now signals))
+        (begin
+          (! man (make-external-event (list (list notifier (list (self) (lambda () (map value-now signals)))))))
+          (receive [x (apply values x)]))))
+  
+  (define (schedule-alarm ms beh)
+    (when (> ms 1073741824)
+      (set! ms (- ms 2147483647)))
+    (if (eq? (self) man)
+        (alarms-enqueue ms beh)
+        (! man (make-alarm ms beh))))
+  
+  (define-syntax snapshot/sync
+    (syntax-rules ()
+      [(_ (id ...) expr ...)
+       (let-values ([(id ...) (sync/read id ...)])
+         expr ...)]))
+  
+  (define-syntax snapshot
+    (syntax-rules ()
+      [(_ (id ...) expr ...)
+       (let ([id (value-now id)] ...)
+         expr ...)]))
+  
+  (define-syntax snapshot-all
+    (syntax-rules ()
+      [(_ expr ...)
+       (parameterize ([snap? #t])
+         expr ...)]))
+  
+  (define-syntax frp:send
+    (syntax-rules ()
+      [(_ obj meth arg ...)
+       (if (snap?)
+           (send obj meth (value-now arg) ...)
+           (send obj meth arg ...))]))
+  
+  (define (magic dtime thunk)
+    (let* ([last-time (current-milliseconds)]
+           [ret (let ([myself #f])
+                  (event-producer
+                   (let ([now (current-milliseconds)])
+                     (snapshot (dtime)
+                       (when (cons? the-args)
+                         (set! myself (first the-args)))
+                       (when (and dtime (>= now (+ last-time dtime)))
+                         (emit (thunk))
+                         (set! last-time now))
+                       (when dtime
+                         (schedule-alarm (+ last-time dtime) myself))))
+                   dtime))])
+      (send-event ret ret)
+      ret))
+                   
+  (define (make-time-b ms)
+    (let ([ret (proc->signal void)])
+      (set-signal-thunk! ret
+                         (lambda ()
+                           (let ([t (current-milliseconds)])
+                             (schedule-alarm (+ ms t) ret)
+                             t)))
+      (set-signal-value! ret ((signal-thunk ret)))
+      ret))
+  
+  (define never-e
+    (changes #f))
+  
+  (define milliseconds (make-time-b 10))
+  (define time-b milliseconds)
+
+  (define seconds
+    (let ([ret (proc->signal void)])
+      (set-signal-thunk! ret
+                           (lambda ()
+                             (let ([s (current-seconds)]
+                                   [t (current-milliseconds)])
+                               (schedule-alarm (* 1000 (add1 (floor (/ t 1000)))) ret)
+                               s)))
+      (set-signal-value! ret ((signal-thunk ret)))
+      ret))
+  
+  ; general efficiency fix for delay
+  ; signal[a] signal[num] -> signal[a]
+  (define (delay-by beh ms-b)
+    (letrec ([last (cons (cons (if (zero? (value-now ms-b))
+                                   (value-now beh)
+                                   undefined)
+                               (current-milliseconds))
+                         empty)]
+             [head last]
+             [producer (proc->signal
+                        (lambda ()
+                          (let* ([now (current-milliseconds)]
+                                 [ms (value-now ms-b)])
+                            (let loop ()
+                              (if (or (empty? (rest head))
+                                      (< now (+ ms (cdadr head))))
+                                  (caar head)
+                                  (begin
+                                    consumer ;; just to prevent GC
+                                    (set! head (rest head))
+                                    (loop)))))))]
+             [consumer (proc->signal
+                        (lambda ()
+                          (let* ([now (current-milliseconds)]
+                                 [new (value-now/copy beh)]
+                                 [ms (value-now ms-b)])
+                            (when (not (equal? new (caar last)))
+                              (set-rest! last (cons (cons new now)
+                                                    empty))
+                              (set! last (rest last))
+                            (schedule-alarm (+ now ms) producer))))
+                        beh ms-b)])
+      producer))
+  
+  (define (inf-delay beh)
+    (delay-by beh 0))
+  
+  ; fix to take arbitrary monotonically increasing number
+  ; (instead of milliseconds)
+  ; integral : signal[num] signal[num] -> signal[num]
+  (define integral
+    (opt-lambda (b [ms-b 10])
+      (letrec ([accum 0]
+               [last-time (current-milliseconds)]
+               [last-val (value-now b)]
+               [last-alarm 0]
+               [producer (proc->signal (lambda ()
+                                         consumer ;; just to prevent GC
+                                         accum))]
+               [consumer (proc->signal void b ms-b)])
+        (set-signal-thunk!
+         consumer
+         (lambda ()
+           (let ([now (current-milliseconds)])
+             (if (> now (+ last-time 10))
+                 (begin
+                   (when (not (number? last-val))
+                     (set! last-val 0))
+                   (set! accum (+ accum
+                                  (* last-val
+                                     (- now last-time))))
+                   (set! last-time now)
+                   (set! last-val (value-now b))
+                   (when (value-now ms-b)
+                     (schedule-alarm (+ last-time (value-now ms-b))
+                                     consumer)))
+                 (when (or (>= now last-alarm)
+                           (and (< now 0)
+                                (>= last-alarm 0)))
+                   (set! last-alarm (+ now 20))
+                   (schedule-alarm last-alarm consumer)))
+             (schedule-alarm now producer))))
+        ((signal-thunk consumer))
+        producer)))
+  
+  ; fix for accuracy
+  ; derivative : signal[num] -> signal[num]
+  (define (derivative b)
+    (let* ([last-value (value-now b)]
+           [last-time (current-milliseconds)]
+           [thunk (lambda ()
+                    (let* ([new-value (value-now b)]
+                           [new-time (current-milliseconds)]
+                           [result (if (or (= new-value last-value)
+                                           (= new-time last-time)
+                                           (> new-time
+                                              (+ 500 last-time))
+                                           (not (number? last-value))
+                                           (not (number? new-value)))
+                                       0
+                                       (/ (- new-value last-value)
+                                          (- new-time last-time)))])
+                      (set! last-value new-value)
+                      (set! last-time new-time)
+                      result))])
+      (proc->signal thunk b)))
+  
+  ; new-cell : behavior[a] -> behavior[a] (cell)
+  (define new-cell
+    (opt-lambda ([init undefined])
+      (switch (event-receiver) init)))
+    
+  ; set-cell! : cell[a] a -> void
+  (define (set-cell! ref beh)
+    (! man (make-external-event (list (list ((signal-thunk ref) #t) beh)))))
+
+  (define (synchronize)
+    (when (man?)
+      (error 'synchronize "already in frtime engine (would deadlock)"))
+    (! man (make-external-event (list (list notifier (list (self) (lambda () man))))))
+    (receive [(? man?) (void)]))
+  
+  (define (curried-apply fn)
+    (lambda (lis) (apply fn lis)))
+  
+  (define-syntax frp:app
+    (syntax-rules ()
+      [(_ fn arg ...) (lift fn arg ...)]))
+  
+  (define-syntax frp:letrec
+    (syntax-rules ()
+      [(_ ([id val] ...) expr ...)
+       (let ([id (new-cell)] ...)
+         (let ([tmp val])
+           (if (signal? tmp)
+               (set-cell! id tmp)
+               (set! id tmp)))
+         ...
+         expr ...)]))
+  
+  (define-syntax frp:match
+    (syntax-rules ()
+      [(_ expr clause ...) (lift #t (match-lambda clause ...) expr)]))
+  
+  (define (geometric)
+    (- (log (/ (random 2147483647) 2147483647.0))))
+  
+  (define (make-geometric mean)
+    (simple-b (lambda (ret)
+                (let ([cur 0])
+                  (lambda ()
+                    (! man (make-alarm (+ (current-milliseconds)
+                                          (inexact->exact (ceiling (* mean (geometric)))))
+                                       ret))
+                    (set! cur (- 1 cur))
+                    cur)))))
+  
+  (define (make-constant ms)
+    (simple-b (lambda (ret)
+                (let ([cur 0])
+                  (lambda ()
+                    (! man (make-alarm (+ (current-milliseconds) ms)
+                                       ret))
+                    (set! cur (- 1 cur))
+                    cur)))))
+  
+  (define drs-eventspace #f)
+  
+  (define (set-eventspace evspc)
+    (set! drs-eventspace evspc))
+  
+  (define raise-exceptions (new-cell #t))
+  (define exception-raiser
+    (exceptions . ==> . (lambda (p) (when (value-now raise-exceptions)
+                                      (thread
+                                       (lambda () (raise (car p))))))))
+  
+  (define value-snip-copy%
+    (class string-snip%
+      (init-field current parent)
+      (inherit get-admin)
+      (define/public (set-current c)
+        (parameterize ([current-eventspace drs-eventspace])
+          (queue-callback
+           (lambda ()
+             (set! current c)
+             (let ([admin (get-admin)])
+               (when admin
+                 (send admin needs-update this 0 0 2000 100)))))))
+      (define/override (draw dc x y left top right bottom dx dy draw-caret)
+        (send current draw dc x y left top right bottom dx dy draw-caret))
+      (super-instantiate (" "))))
+  
+  (define (make-snip bhvr)
+    (make-object string-snip%
+      (let ([tmp (cond
+                   [(behavior? bhvr) (value-now bhvr)]
+                   [(event? bhvr) (signal-value bhvr)]
+                   [else bhvr])])
+        (cond
+          [(econs? tmp) (format "#<event (last: ~a)>" (efirst tmp))]
+          [(undefined? tmp) "<undefined>"]
+          [else (expr->string tmp)]))))
+  
+  (define value-snip%
+    (class string-snip%
+      (init-field bhvr)
+      (field [copies empty]
+             [loc-bhvr (proc->signal (lambda () (update)) bhvr)]
+             [current (make-snip bhvr)])
+      
+      (define/override (copy)
+        (let ([ret (make-object value-snip-copy% current this)])
+          (set! copies (cons ret copies))
+          ret))
+      
+      (define/public (update)
+        (set! current (make-snip bhvr))
+        (for-each (lambda (copy) (send copy set-current current)) copies))
+      
+      (super-instantiate (" "))))
+  
+  (define (render beh as-snip?)
+    (cond
+      [as-snip? (watch beh)]
+      [(undefined? (value-now beh)) "<undefined>"]
+      [(behavior? beh) (format "#<behavior (~a)>" (value-now beh))]
+      [(event? beh) (format "#<event (last: ~a)>" (efirst (signal-value beh)))]
+      [else beh]))
+    
+  (define (watch beh)
+    (cond
+      [(undefined? beh)
+       (make-object string-snip% "<undefined>")]
+      [(signal? beh) (make-object value-snip% beh)]
+      [else beh]))
+  
+  (define (find pred lst)
+    (cond
+     [(empty? lst) #f]
+     [(pred (first lst)) (first lst)]
+     [else (find pred (rest lst))]))
+
+  (define-syntax (frp:provide stx)
+    (syntax-case stx ()
+      [(_ . clauses)
+       (foldl
+        (lambda (c prev)
+          (syntax-case prev ()
+            [(begin clause ...)
+             (syntax-case c (lifted lifted:nonstrict)
+               [(lifted . ids)
+                (with-syntax ([(fun-name ...) (syntax ids)]
+                              [(tmp-name ...)
+                               (map (lambda (id)
+                                      (datum->syntax-object stx (syntax-object->datum id)))
+                                    (generate-temporaries (syntax ids)))])
+                  (syntax
+                   (begin
+                     clause ...
+                     (define (tmp-name . args)
+                        (apply lift true fun-name args))
+                     ...
+                     (provide (rename tmp-name fun-name) ...))))]
+               [(lifted:nonstrict . ids)
+                (with-syntax ([(fun-name ...) (syntax ids)]
+                              [(tmp-name ...)
+                               (map (lambda (id)
+                                      (datum->syntax-object stx (syntax-object->datum id)))
+                                    (generate-temporaries (syntax ids)))])
+                  (syntax
+                   (begin
+                     clause ...
+                     (define (tmp-name . args)
+                        (apply lift false fun-name args))
+                     ...
+                     (provide (rename tmp-name fun-name) ...))))]
+               [provide-spec
+                (syntax (begin clause ... (provide provide-spec)))])]))
+        (syntax (begin))
+        (syntax->list (syntax clauses)))]))  
+
+  (define (ensure-no-signal-args val name)
+    (if (procedure? val)
+        (lambda args
+          (cond
+            [(find signal? args)
+             =>
+             (lambda (v)
+               (raise-type-error name "not time-varying"
+                                 (if (event? v)
+                                     (format "#<event (last: ~a)>" (efirst (signal-value v)))
+                                     (format "#<behavior: ~a>" (signal-value v)))))]
+            [else (apply val args)]))))
+  
+  (define-syntax (frp:require stx)
+    (define (generate-temporaries/loc st ids)
+      (map (lambda (id)
+             (datum->syntax-object stx (syntax-object->datum id)))
+           (generate-temporaries ids)))
+    (syntax-case stx ()
+      [(_ . clauses)
+       (foldl
+        (lambda (c prev)
+          (syntax-case prev ()
+            [(begin clause ...)
+             (syntax-case c (lifted lifted:nonstrict as-is:unchecked as-is frlibs)
+               [(lifted:nonstrict module . ids)
+                (with-syntax ([(fun-name ...) #'ids]
+                              [(tmp-name ...) (generate-temporaries/loc stx #'ids)])
+                  #'(begin
+                      clause ...
+                      (require (rename module tmp-name fun-name) ...)
+                      (define (fun-name . args)
+                        (apply lift false tmp-name args))
+                      ...))]
+               [(lifted module . ids)
+                (with-syntax ([(fun-name ...) (syntax ids)]
+                              [(tmp-name ...) (generate-temporaries/loc stx #'ids)])
+                  #'(begin
+                      clause ...
+                      (require (rename module tmp-name fun-name) ...)
+                      (define (fun-name . args)
+                        (apply lift true tmp-name args))
+                      ...))]
+               [(as-is:unchecked module id ...)
+                (syntax (begin clause ... (require (rename module id id) ...)))]
+               [(as-is module . ids)
+                (with-syntax ([(fun-name ...) (syntax ids)]
+                              [(tmp-name ...) (generate-temporaries/loc stx #'ids)])
+                  #'(begin
+                      clause ...
+                      (require (rename module tmp-name fun-name) ...)
+                      (define fun-name (ensure-no-signal-args tmp-name 'fun-name))
+                      ...))]
+               [(frlibs str ...)
+                #'(begin
+                    clause ...
+                    (require (lib str "frtime") ...))]
+               [require-spec
+                #'(begin clause ... (require require-spec))])]))
+        #'(begin)
+        (syntax->list #'clauses))]))
+  
+  (define undefined?/lifted (lambda (arg) (lift false undefined? arg)))
+  (define frp:pair? (lambda (arg) (lift true pair? arg)))
+  (define frp:null? (lambda (arg) (lift true null? arg)))
+  (define frp:cons (lambda (a d) (lift false cons a d)))
+  (define frp:car (lambda (arg) (lift true car arg)))
+  (define frp:cdr (lambda (arg) (lift true cdr arg)))
+  
+#|
+  (define (frp:cons a d)
+    (if (or (behavior? a)
+            (behavior? d))
+        (proc->signal (let ([c (cons a d)])
+                        (lambda () c)) a d)
+        (cons a d)))
+  
+  (define (frp:car c)
+    (if (behavior? c)
+        (car (signal-value c))
+        (car c)))
+  
+  (define (frp:cdr c)
+    (if (behavior? c)
+        (cdr (signal-value c))
+        (cdr c)))
+|#  
+  (provide module
+           #%app
+           #%top
+           #%datum
+           #%plain-module-begin
+           #%module-begin
+           null
+           (rename frp:if if)
+           (rename frp:require require)
+           (rename frp:provide provide)
+           (rename frp:letrec letrec)
+           (rename frp:match match)
+           (rename frp:cons cons)
+           (rename frp:pair? pair?)
+           (rename frp:null? null?)
+           (rename frp:car car)
+           (rename frp:cdr cdr)
+           (rename undefined?/lifted undefined?)
+           (all-defined-except frp:if
+                               frp:require
+                               frp:provide
+                               frp:letrec
+                               frp:match
+                               frp:cons
+                               frp:pair?
+                               frp:null?
+                               frp:car
+                               frp:cdr
+                               undefined?
+                               undefined?/lifted)))
diff --git a/collects/frtime/frtime-big.ss b/collects/frtime/frtime-big.ss
new file mode 100644
index 0000000000..d9250c2288
--- /dev/null
+++ b/collects/frtime/frtime-big.ss
@@ -0,0 +1,9 @@
+(module frtime-big (lib "frtime.ss" "frtime")
+  
+  (require (frlibs "list.ss" "etc.ss" "math.ss" "date.ss"))
+  
+  (provide (all-from (lib "frtime.ss" "frtime"))
+           (all-from (lib "list.ss" "frtime"))
+           (all-from (lib "etc.ss" "frtime"))
+           (all-from (lib "math.ss" "frtime"))
+           (all-from (lib "date.ss" "frtime"))))
diff --git a/collects/frtime/frtime-tool.ss b/collects/frtime/frtime-tool.ss
new file mode 100644
index 0000000000..fc13adb10e
--- /dev/null
+++ b/collects/frtime/frtime-tool.ss
@@ -0,0 +1,116 @@
+
+(module frtime-tool mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "class.ss")
+           (lib "mred.ss" "mred")
+           (lib "etc.ss")
+           (lib "list.ss")
+	   (lib "tool.ss" "drscheme")
+           (lib "string-constant.ss" "string-constants"))
+  
+  (provide tool@)
+
+  (define tool@
+    (unit/sig drscheme:tool-exports^
+      (import drscheme:tool^)
+
+      (define basic-frtime-language%
+	(class* object% (drscheme:language:simple-module-based-language<%>)
+	  (define/public (get-language-numbers)
+	    '(1000 -400 1))
+	  (define/public (get-language-position)
+	    (list (string-constant experimental-languages) "FrTime" "Minimal"))
+	  (define/public (get-module)
+	    '(lib "frtime.ss" "frtime"))
+	  (define/public (get-one-line-summary)
+	    "FrTime without libraries")
+          (define/public (get-language-url) #f)
+	  (define/public (get-reader)
+	    (lambda (name port offsets)
+	      (let ([v (read-syntax name port offsets)])
+		(if (eof-object? v)
+		    v
+		    (namespace-syntax-introduce v)))))
+	  (super-instantiate ())))
+
+      (define big-frtime-language%
+	(class* object% (drscheme:language:simple-module-based-language<%>)
+	  (define/public (get-language-numbers)
+	    '(1000 -400 0))
+	  (define/public (get-language-position)
+	    (list (string-constant experimental-languages) "FrTime" "Standard"))
+	  (define/public (get-module)
+	    '(lib "frtime-big.ss" "frtime"))
+	  (define/public (get-one-line-summary)
+	    "Standard FrTime (includes common libraries)")
+          (define/public (get-language-url) #f)
+	  (define/public (get-reader)
+	    (lambda (name port)
+	      (let ([v (read-syntax name port)])
+		(if (eof-object? v)
+		    v
+		    (namespace-syntax-introduce v)))))
+	  (super-instantiate ())))
+
+      (define (weak-member obj lis)
+        (let ([cmp (lambda (v) (eq? v obj))])
+          (let loop ([lis lis])
+            (and (cons? lis)
+                 (or
+                  (cond
+                    [(weak-box-value (first lis)) => cmp]
+                    [else false])
+                  (loop (rest lis)))))))
+            
+      (define (watch watch-list value)
+        (foldl
+         (lambda (wb acc)
+           (cond
+             [(weak-box-value wb)
+              => (lambda (f) (f acc #t))]
+             [else acc]))
+         value
+         watch-list))
+      
+      (define (make-frtime-language base)
+	(class (drscheme:language:module-based-language->language-mixin
+		(drscheme:language:simple-module-based-language->module-based-language-mixin
+		 base))
+          (field (watch-list empty))
+          (inherit get-language-position)
+          (define/override (get-language-name)
+            (let* ([pos (get-language-position)]
+                   [last-part (first (last-pair pos))])
+              (if (equal? last-part "Standard")
+                  "FrTime"
+                  (string-append "FrTime: " last-part))))
+          (define/override (on-execute settings run-in-user-thread)
+            (let ([drs-eventspace (current-eventspace)])
+              (super on-execute settings run-in-user-thread)
+              (run-in-user-thread
+               (lambda ()
+                 (let ([new-watch (namespace-variable-value 'render)]
+                       [set-evspc (namespace-variable-value 'set-eventspace)])
+                   (set-evspc drs-eventspace)
+                   (set! watch-list
+                         ((if (weak-member new-watch watch-list)
+                              identity
+                              (lambda (r) (cons (make-weak-box new-watch) r)))
+                          (filter weak-box-value watch-list))))))))
+
+          (override render-value/format render-value)
+          (define (render-value/format value settings port width)
+            (super render-value/format (watch watch-list value)
+                                       settings port width))
+          (define (render-value value settings port)
+            (super render-value (watch watch-list value)
+                                settings port))
+	  (define/override (use-namespace-require/copy?) #t)
+	  (super-instantiate ())))
+
+      (define (phase1) (void))
+      (define (phase2)
+	(drscheme:language-configuration:add-language 
+	 (make-object ((drscheme:language:get-default-mixin) (make-frtime-language basic-frtime-language%))))
+        (drscheme:language-configuration:add-language 
+	 (make-object ((drscheme:language:get-default-mixin) (make-frtime-language big-frtime-language%))))))))
diff --git a/collects/frtime/frtime.ss b/collects/frtime/frtime.ss
new file mode 100644
index 0000000000..e91de6d6c0
--- /dev/null
+++ b/collects/frtime/frtime.ss
@@ -0,0 +1,410 @@
+(module frtime (lib "frp.ss" "frtime")
+
+  (require (all-except mzscheme
+                       module
+                       #%app
+                       #%top
+                       #%datum
+                       #%plain-module-begin
+                       #%module-begin
+                       if
+                       require
+                       provide
+                       letrec
+                       match
+                       cons car cdr pair? null? null
+			caar cdar cadr cddr caddr cdddr cadddr cddddr
+                       ;undefined?
+                       and
+                       or
+                       cond when unless
+                       map ormap andmap assoc member)
+           (rename mzscheme mz:cons cons)
+           ;(rename mzscheme mz:and and)
+           ;(rename mzscheme mz:or or)
+           ;(lib "list.ss")
+           (lib "contract.ss")
+           (rename "erl.ss" tid? tid?))
+  
+  (define-syntax cond
+    (syntax-rules (else =>)
+      [(_ [else result1 result2 ...])
+       (begin result1 result2 ...)]
+      [(_ [test => result])
+       (let ([temp test])
+         (if temp (result temp)))]
+      [(_ [test => result] clause1 clause2 ...)
+       (let ([temp test])
+         (if temp
+             (result temp)
+             (cond clause1 clause2 ...)
+             (cond clause1 clause2 ...)))]
+      [(_ [test]) test]
+      [(_ [test] clause1 clause2 ...)
+       (let ((temp test))
+         (if temp
+             temp
+             (cond clause1 clause2 ...)
+             (cond clause1 clause2 ...)))]
+      [(_ [test result1 result2 ...])
+       (if test (begin result1 result2 ...))]
+      [(_ [test result1 result2 ...]
+          clause1 clause2 ...)
+       (if test
+           (begin result1 result2 ...)
+           (cond clause1 clause2 ...)
+           (cond clause1 clause2 ...))]))
+  
+  (define-syntax and
+    (syntax-rules ()
+      [(_) #t]
+      [(_ exp) exp]
+      [(_ exp exps ...) (if exp
+                            (and exps ...)
+                            #f)]))
+  
+  (define-syntax or
+    (syntax-rules ()
+      [(_) #f]
+      [(_ exp) exp]
+      [(_ exp exps ...) (let ([v exp])
+                          (if v
+                              v
+                              (or exps ...)
+                              (or-undef exps ...)))]))
+
+  (define-syntax or-undef
+    (syntax-rules ()
+      [(_) undefined]
+      [(_ exp) (let ([v exp]) (if v v undefined))]
+      [(_ exp exps ...) (let ([v exp])
+                          (if v
+                              v
+                              (or-undef exps ...)
+                              (or-undef exps ...)))]))
+
+  (define-syntax when
+    (syntax-rules ()
+      [(_ test body ...) (if test (begin body ...))]))
+
+  (define-syntax unless
+    (syntax-rules ()
+      [(_ test body ...) (if (not test) (begin body ...))]))
+  
+  (define (ormap proc lst)
+    (and (pair? lst)
+         (or (proc (car lst)) (ormap proc (cdr lst)))))
+  
+  (define (andmap proc lst)
+    (or (null? lst)
+        (and (proc (car lst)) (andmap proc (cdr lst)))))
+  
+  (define (caar v)
+    (car (car v)))
+  
+  (define (cdar v)
+    (cdr (car v)))
+  
+  (define (cadr v)
+    (car (cdr v)))
+  
+  (define (cddr v)
+    (cdr (cdr v)))
+  
+  (define (caddr v)
+    (car (cddr v)))
+  
+  (define (cdddr v)
+    (cdr (cddr v)))
+  
+  (define (cadddr v)
+    (car (cdddr v)))
+  
+  (define (cddddr v)
+    (cdr (cdddr v)))
+  
+;  (define list
+;    (case-lambda
+;      [() null]
+;      [(a . d) (cons a (apply list d))]))
+  
+  (define-syntax frtime:case
+    (syntax-rules ()
+      [(_ exp clause ...)
+       (let ([v exp])
+         (vcase v clause ...))]))
+  
+  (define-syntax vcase
+    (syntax-rules (else)
+      [(_ v [else exp ...])
+       (begin exp ...)]
+      [(_ v [dl exp ...])
+       (if (lift #t memv v (quote dl))
+           (begin exp ...))]
+      [(_ v [dl exp ...] clause ...)
+       (if (lift #t memv v (quote dl))
+           (begin exp ...)
+           (vcase v clause ...))]))
+  
+  (define map
+    (case-lambda
+      [(f l) (if (pair? l)
+                 (cons (f (car l)) (map f (cdr l)))
+                 null)]
+      [(f l1 l2) (if (and (pair? l1) (pair? l2))
+                     (cons (f (car l1) (car l2)) (map f (cdr l1) (cdr l2)))
+                     null)]
+      [(f l . ls) (if (and (pair? l) (andmap pair? ls))
+                      (cons (lift #f apply f (car l) (map car ls)) (lift #f apply map f (cdr l) (map cdr ls)))
+                      null)]))
+
+  ; TO DO: assoc member [vectors] structs
+  ; first cut: could be made more efficient by creating
+  ; a dedicated signal to update each element of the vector
+  (define (frtime:vector2 . args)
+    (if (ormap behavior? args)
+        (let* ([n (length args)]
+               [v1 (make-vector n)]
+               [v2 (make-vector n)])
+          (apply
+           proc->signal
+           (lambda ()
+             (let ([tmp v2])
+               (set! v2 v1)
+               (set! v1 tmp))
+             (let loop ([i 0] [args args])
+               (when (< i n)
+                 (vector-set! v1 i (value-now (car args)))
+                 (loop (add1 i) (cdr args))))
+             v1)
+           args))
+        (apply vector args)))
+
+  (define (frtime:vector . args)
+    (if (ormap behavior? args)
+        (let* ([n (length args)]
+               [vec (make-vector n)]
+               [arg-behs 
+                ; initialize the vector
+                (let loop ([i 0] [args args] [ret null])
+                  (if (< i n)
+                      (loop (add1 i)
+                            (cdr args)
+                            (mz:cons
+                             (let ([arg (car args)])
+                               (proc->signal
+                                (lambda ()
+                                  (let ([v (value-now arg)])
+                                    (vector-set! vec i v)
+                                    v))
+                                arg))
+                             ret))
+                      ret))])
+          (apply proc->signal (lambda () arg-behs vec) arg-behs))
+        (apply vector args)))
+
+  (define ((behaviorof pred) x)
+    (let ([v (value-now x)])
+      (or (undefined? v)
+          (pred v))))
+
+  (define (lift-strict . args)
+    (apply lift #t args))
+  
+  ;; Imported from mzscheme:
+  (provide (lifted + - * / = eq? equal? eqv? < > <= >= list? add1 cos sin tan symbol->string symbol?
+                   number->string exp expt even? odd? list-ref string-append eval
+                   sub1 sqrt not number? string? zero? min max modulo
+                   string->number void? rational? char? char-upcase char-ci>=? char-ci<=?
+                   string>=? char-upper-case? char-alphabetic?
+                   string<? string-ci=? string-locale-ci>?
+                   string-locale-ci<? string-locale-ci=? atan asin acos exact? magnitude imag-part
+                   real-part numerator abs log lcm gcd arithmetic-shift integer-sqrt make-rectangular
+                   complex? char>? char<? char=?
+                   char-numeric? date-time-zone-offset list->string substring string->list
+                   string-ci<? string-ci>=? string<=? string-ci<=? string>? string-locale<? string=?
+                   string-length string-ref
+                   floor angle round
+                   ceiling real? date-hour vector-ref procedure? procedure-arity
+                   rationalize date-year-day date-week-day date? date-dst? date-year date-month date-day
+                   date-minute date-second make-date char-downcase char>=? char<=? char->integer integer->char boolean?
+                   integer? quotient remainder positive? negative? inexact->exact exact->inexact
+                   make-polar denominator truncate bitwise-not bitwise-xor bitwise-and bitwise-ior inexact?
+                   char-whitespace? assq assv memq memv list-tail reverse append length seconds->date
+                   expand syntax-object->datum exn-message continuation-mark-set->list exn-continuation-marks
+                   exn:fail?
+                   )
+           (rename frtime:case case)
+           (rename frtime:vector vector)
+           (rename frtime:vector2 vector2)
+           (rename eq? mzscheme:eq?)
+           make-exn:fail
+           make-namespace namespace? namespace-symbol->identifier namespace-variable-value
+           namespace-set-variable-value! namespace-undefine-variable! namespace-mapped-symbols
+           parameterize current-seconds current-milliseconds current-inexact-milliseconds
+           call-with-values make-parameter
+           null gensym collect-garbage
+           error define-struct set! printf fprintf current-error-port for-each void
+           procedure-arity-includes? raise-type-error raise thread
+           current-continuation-marks
+           raise-mismatch-error require-for-syntax define-syntax syntax-rules syntax-case
+           set-eventspace
+	   install-errortrace-key
+           (lifted:nonstrict apply format list list*)
+           general-event-processor
+           lambda
+           case-lambda
+           define-values
+           define
+           let
+           let-values
+           let*
+	   let*-values
+           begin
+           begin0
+           quote
+           quasiquote
+           unquote
+           values
+           syntax
+           let/ec
+           with-handlers
+           delay
+           force
+           random
+           sleep
+           )
+
+  ;; Defined in frp.ss:
+  (provide module
+           #%app
+           #%top
+           #%datum
+           #%plain-module-begin
+           #%module-begin
+           render
+           require
+           provide
+           letrec
+           undefined
+           undefined?
+           if
+           lift
+           match
+           time-b
+           seconds
+           milliseconds
+           exceptions
+           cons
+           pair?
+           null?
+           car
+           cdr
+           signal-value
+           signal?
+           behavior?
+           event?
+           event-receiver?
+           frtime-version
+           raise-exceptions
+           synchronize
+           frp:send
+           snapshot
+           snapshot-all
+           snapshot/sync
+           snapshot/apply
+           )
+           
+
+ ; (define (behavior? v) (not (event? v)))
+
+  ;; Defined in this module:
+  (provide when unless behaviorof -=> nothing nothing?
+           cond and or andmap ormap map lift-strict never-e
+           caar cadr cdar cddr caddr cdddr cadddr cddddr
+           magic value-nowable?)
+
+  ; returns true on values that can be passed to value-now
+  ; (e.g. behaviors or constants)
+  ; note difference from behavior?, which returns true only
+  ; on values that may actually change and should be monitored
+  ; for change
+  (define (value-nowable? v)
+    #t)
+    ;(not (and (signal? v) (event-cons? (signal-value v)))))
+
+  (provide/contract
+   [proc->signal (((-> any/c))
+                  any/c
+                  . ->* . (signal?))]
+
+   [value-now (value-nowable? . -> . any)]
+
+   [until (value-nowable? value-nowable? . -> . behavior?)]
+
+   [switch ((event?) (value-nowable?) . opt-> . signal?)]
+
+   [merge-e (() (listof event?) . ->* . (event?))]
+
+   [once-e (event? . -> . event?)]
+
+   [changes (value-nowable? . -> . event?)]
+
+   [event-receiver (-> event?)]
+
+   [when-e (value-nowable? . -> . event?)]
+
+   [while-e (value-nowable? value-nowable? . -> . event?)]
+
+   [==> (event? (any/c . -> . any) . -> . event?)]
+
+   [=#> (event? (any/c . -> . any) . -> . event?)]
+
+   [=#=> (event? (any/c . -> . (union any/c nothing?)) . -> . event?)]
+
+   [map-e ((any/c . -> . any) event? . -> . event?)]
+   
+   [filter-e ((any/c . -> . any) event? . -> . event?)]
+
+   [filter-map-e ((any/c . -> . (union any/c nothing?)) event? . -> . event?)]
+
+   [collect-e (event? any/c (any/c any/c . -> . any) . -> . event?)]
+
+   [collect-b (event? any/c (any/c any/c . -> . any) . -> . behavior?)]
+
+   [accum-e (event? any/c . -> . event?)]
+   
+   [accum-b (event? any/c . -> . behavior?)]
+
+   [send-event (event-receiver? any/c . -> . void?)]
+
+   [send-synchronous-event (event-receiver? any/c . -> . void?)]
+
+   [send-synchronous-events (list? . -> . void?)]
+
+   [hold ((event?) (value-nowable?) . opt-> . behavior?)]
+
+   [new-cell (() (any/c) . opt-> . (union behavior? event?))]
+
+   [set-cell! ((union behavior? event?) any/c . -> . void?)]
+
+   [snapshot-e ((event?) any/c . ->* . (event?))]
+
+   [snapshot-map-e ((procedure? event?)
+                    any/c     ;; the behaviors
+                    . ->* . 
+                    (event?))]
+
+   [derivative (value-nowable? . -> . behavior?)]
+
+   [integral ((value-nowable?) (value-nowable?) . opt-> . behavior?)]
+
+   [delay-by (value-nowable? value-nowable? . -> . signal?)]
+   
+   [inf-delay (value-nowable? . -> . behavior?)]
+   
+   [bind (symbol? event? . -> . event?)]
+   
+   [remote-reg (tid? symbol? . -> . event?)]
+
+   ))
diff --git a/collects/frtime/graphics-posn-less-unit.ss b/collects/frtime/graphics-posn-less-unit.ss
new file mode 100644
index 0000000000..bf648b62c0
--- /dev/null
+++ b/collects/frtime/graphics-posn-less-unit.ss
@@ -0,0 +1,1125 @@
+; graphics.ss
+; Simple graphics routines for MrEd
+; Originally written by Johnathan Franklin
+;
+; modified by Gregory Cooper to support FrTime
+
+(module graphics-posn-less-unit mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "mred-sig.ss" "mred")
+	   (lib "class.ss")
+	   (lib "class100.ss")
+	   (lib "etc.ss")
+           "erl.ss"
+           (rename "frp.ss" event-receiver event-receiver)
+           (rename "frp.ss" frp-man man)
+           (rename "frp.ss" send-event send-event)
+	   "graphics-sig.ss")
+  (provide graphics-posn-less@)
+
+(define graphics-posn-less@
+
+(unit/sig graphics:posn-less^
+  (import (mred : mred^)
+          graphics:posn^)
+  
+  (define send/proc
+    (lambda (class method . args)
+      (send-generic class (make-generic mred:dc<%> method) . args)))
+
+  (define send/proc2
+    (lambda (class method . args)
+      (send-generic class (make-generic sixlib-canvas% method) . args)))
+  
+  (define-struct viewport (label canvas))
+  (define-struct sixmouse (x y left? middle? right?))
+  (define-struct sixkey (value shift control meta alt))
+  (define graphics-flag #f)
+  (define global-viewport-list '())
+  (define global-color-vector (make-vector 300 #f))
+  (define global-pen-vector (make-vector 300 #f))
+  (define global-brush-vector (make-vector 300 #f))
+  (define default-font (make-object mred:font% 12 'roman 'normal 'normal))
+  (define black-color (make-object mred:color% "BLACK"))
+
+  (define sixlib-canvas%
+    (class100-asi mred:canvas% 
+      (inherit get-parent
+	       min-client-width min-client-height
+	       stretchable-width stretchable-height)
+      (private-field
+        [current-mouse-pos (make-posn 0 0)]
+        [mouse-listener #f]
+        [key-listener #f])
+      (private
+        [reset-size
+	 (lambda ()
+           (min-client-width width)
+           (min-client-height height)
+           (stretchable-width #f)
+           (stretchable-height #f)
+           (set! bitmap (make-object mred:bitmap% width height))
+           (unless (send bitmap ok?)
+             (error "cannot allocate viewport"))
+           (send buffer-dc set-bitmap bitmap)
+           (send buffer-dc set-brush (send dc get-brush))
+           (send buffer-dc set-pen (send dc get-pen))
+           (let ([f (send dc get-font)])
+             (when f
+               (send buffer-dc set-font f)))
+           (send buffer-dc clear)
+           (send dc clear))])
+      
+      (private-field ; were public
+        viewport
+	[height 0]
+	[width 0]
+	[label 0]
+	[current-pen 'uninitialized-pen]
+	[current-brush 'uninitialized-brush]
+	[bitmap 'uninitalized-bitmap]
+	[dc 'uninitialized-dc]
+	[buffer-dc 'uninitialized-buffer-dc])
+      
+      (public
+        [get-mouse-listener (lambda () mouse-listener)]
+        [get-key-listener (lambda () key-listener)]
+        [set-mouse-listener (lambda (ml) (set! mouse-listener ml))]
+        [set-key-listener (lambda (kl) (set! key-listener kl))]
+        [get-posn (lambda () current-mouse-pos)]
+        [get-viewport (lambda () viewport)]
+	[set-viewport (lambda (x) (set! viewport x))]
+	[get-sixlib-height (lambda () height)]
+	[get-sixlib-width (lambda () width)]
+	[get-current-pen (lambda () current-pen)]
+	[get-current-brush (lambda () current-brush)]
+	[get-bitmap (lambda () bitmap)]
+	[get-sixlib-dc (lambda () dc)]
+	[get-buffer-dc (lambda () buffer-dc)]
+	[remember-pen (lambda (pen) (set! current-pen pen))]
+	[remember-brush (lambda (brush) (set! current-brush brush))])
+
+      (override
+       [on-paint
+	(lambda ()
+	  (let ([bm (send buffer-dc get-bitmap)])
+	    (send dc draw-bitmap bm 0 0)))]
+       
+       [on-event 
+	(lambda (mouse-event)
+          (set! current-mouse-pos (make-posn (send mouse-event get-x)
+                                             (send mouse-event get-y)))
+          (send-event mouse-listener mouse-event))]
+#|
+	  (let* ([x (send mouse-event get-x)]
+		 [y (send mouse-event get-y)]
+		 [left? (send mouse-event button-down? 'left)]
+		 [middle? (send mouse-event button-down? 'middle)]
+		 [right? (send mouse-event button-down? 'right)]
+		 [sixm (make-sixmouse x y left? middle? right?)])
+            (set! current-mouse-pos (make-posn x y))
+            (if mouse-listener
+                (send-event mouse-listener sixm))))]
+|#       
+       [on-char
+	(lambda (key-event)
+          (if key-listener
+              (send-event
+               key-listener
+               (make-sixkey
+                (send key-event get-key-code)
+                (send key-event get-shift-down)
+                (send key-event get-control-down)
+                (send key-event get-meta-down)
+                (send key-event get-alt-down)))))])
+
+      (public
+	[set-dc (lambda (new-dc) (set! dc new-dc))]
+	[set-buffer-dc (lambda (new-buffer-dc) (set! buffer-dc
+						     new-buffer-dc))]
+	
+	[set-geometry
+	 (lambda (new-width new-height)
+	   (set! height new-height)
+	   (set! width new-width)
+	   (reset-size))]
+	[set-height (lambda (new-height) 
+		      (set! height new-height)
+		      (reset-size))]
+	[set-width (lambda (new-width) 
+		     (set! width new-width)
+		     (reset-size))])))
+  
+  (define open-frames-timer (make-object mred:timer%))
+
+  (define sixlib-frame%
+    (class mred:frame%
+      (field [canvas #f])
+      (define/public (set-canvas x) (set! canvas x))
+      (define/augment (on-close)
+	(close-viewport (send canvas get-viewport))
+	(inner (void) on-close))
+      (super-instantiate ())))
+  
+  (define (query-mouse-posn viewport)
+    (send (viewport-canvas viewport) get-posn))
+  
+  (define repaint
+    (lambda (viewport)
+      (send (viewport-canvas viewport) on-paint)))
+  
+  (define viewport-mouse-events
+    (lambda (viewport)
+      (send (viewport-canvas viewport) get-mouse-listener)))
+
+  (define viewport-key-events
+    (lambda (viewport)
+      (send (viewport-canvas viewport) get-key-listener)))
+  
+  (define viewport-dc 
+    (lambda (viewport)
+      (send (viewport-canvas viewport) get-sixlib-dc)))
+  
+  (define viewport-buffer-dc
+    (lambda (viewport)
+      (send (viewport-canvas viewport) get-buffer-dc)))
+
+  (define viewport-bitmap
+    (lambda (viewport)
+      (send (viewport-canvas viewport) get-bitmap)))
+  
+  (define viewport-frame
+    (lambda (viewport)
+      (send (send (viewport-canvas viewport) get-parent) get-parent)))
+  
+  (define viewport-height
+    (lambda (viewport)
+      (send (viewport-canvas viewport) get-sixlib-height)))
+  
+  (define viewport-width
+    (lambda (viewport)
+      (send (viewport-canvas viewport) get-sixlib-width)))
+  
+  (define clear-viewport
+    (lambda (viewport)
+      (let* ([vdc (viewport-dc viewport)]
+	     [vbdc (viewport-buffer-dc viewport)])
+	(lambda ()
+	  (send vdc clear)
+	  (send vbdc clear)))))
+
+
+  
+  (define draw-viewport
+    (lambda (viewport)
+      (let* ([dc (viewport-dc viewport)]
+	     [buffer-dc (viewport-buffer-dc viewport)]
+	     [w (viewport-width viewport)]
+	     [h (viewport-height viewport)])
+	(rec draw-viewport/color
+	     (case-lambda
+	      [(color)
+	       (let ([new-pen (send mred:the-pen-list find-or-create-pen color 1 'solid)]
+		     [new-brush (send mred:the-brush-list find-or-create-brush color 'solid)]
+		     [old-pen (send dc get-pen)]
+		     [old-brush (send dc get-brush)])
+		 (send dc set-pen new-pen)
+		 (send dc set-brush new-brush)
+		 (send buffer-dc set-pen new-pen)
+		 (send buffer-dc set-brush new-brush)
+		 (send dc draw-rectangle 0 0 w h)
+		 (send buffer-dc draw-rectangle 0 0 w h)
+		 (send dc set-pen old-pen)
+		 (send buffer-dc set-pen old-pen)
+		 (send dc set-brush old-brush)
+		 (send buffer-dc set-brush old-brush))]
+	      [() (draw-viewport/color (make-rgb 0 0 0))])))))
+  
+  (define flip-viewport
+    (lambda (viewport)
+      (let* ([dc (viewport-dc viewport)]
+	     [dc2 (viewport-buffer-dc viewport)]
+	     [w (viewport-width viewport)]
+	     [h (viewport-height viewport)])
+	(lambda ()
+	  (let ([pen (send dc get-pen)]
+		[pen2 (send dc2 get-pen)]
+		[brush (send dc get-brush)]
+		[brush2 (send dc2 get-brush)])
+	    (send dc set-pen xor-pen)
+	    (send dc2 set-pen xor-pen)
+	    (send dc set-brush xor-brush)
+	    (send dc2 set-brush xor-brush)
+	    (send dc draw-rectangle 0 0 w h)
+	    (send dc2 draw-rectangle 0 0 w h)
+	    (send dc set-pen pen)
+	    (send dc2 set-pen pen2)
+	    (send dc set-brush brush)
+	    (send dc2 set-brush brush2))))))
+  
+  (define close-viewport
+    (lambda (viewport)
+      (set! global-viewport-list 
+	    (let loop ([l global-viewport-list])
+	      (cond
+		[(null? l) '()]
+		[(eq? (car l) viewport) (cdr l)]
+		[else (cons (car l) (loop (cdr l)))])))
+      (send (viewport-frame viewport) show #f)
+      (send (viewport-canvas viewport) show #f)
+      (when (null? global-viewport-list)
+	(send open-frames-timer stop))))
+  
+  (define open-graphics
+    (lambda ()
+      (set! graphics-flag #t)))
+  
+  (define close-graphics 
+    (lambda ()
+      (map close-viewport global-viewport-list)
+      (set! graphics-flag #f)
+      (set! global-viewport-list '())
+      (send open-frames-timer stop)))
+  
+  (define graphics-open? (lambda () graphics-flag))
+  
+  (define make-rgb
+    (lambda (red green blue)
+      (when (or (< red 0.) (< blue 0.) (< green 0.)
+		(> red 1.) (> blue 1.) (> green 1.))
+	(error 'make-rgb
+	       "all color indices should be in [0.0, 1.0]; provided ~s"
+	       (list red green blue)))
+      (let* ([convert (lambda (num) (inexact->exact (round (* 255 num))))]
+	     [nred (convert red)]
+	     [ngreen (convert green)]
+	     [nblue (convert blue)])
+	(make-object mred:color% nred ngreen nblue))))
+  
+  (define make-color make-rgb)
+  
+  (define (rgb-red rgb) (/ (send rgb red) 255))
+  (define (rgb-blue rgb) (/ (send rgb blue) 255))
+  (define (rgb-green rgb) (/ (send rgb green) 255))
+  
+  (define rgb? (lambda (object) (is-a? object mred:color%)))
+  (define (color? x)
+    (or (rgb? x)
+	(not (not (send mred:the-color-database find-color x)))))
+  
+  (define change-color
+    (lambda (index color)
+      (vector-set! global-color-vector index color)
+      (vector-set! global-pen-vector index (get-pen color))
+      (vector-set! global-brush-vector index (get-brush color))))
+  
+  (define (get-color index)
+    (cond
+      [(is-a? index mred:color%) index]
+      [(string? index) (make-object mred:color% index)]
+      [else (vector-ref global-color-vector index)]))
+  
+  (define get-pen
+    (lambda (index)
+      (cond
+	[(is-a? index mred:pen%) index]
+	[(or (string? index) (is-a? index mred:color%))
+	 (send mred:the-pen-list find-or-create-pen index 1 'solid)]
+	[else (vector-ref global-pen-vector index)])))
+  
+  (define get-brush
+    (lambda (index)
+      (cond
+	[(is-a? index mred:brush%) index]
+	[(or (string? index) (is-a? index mred:color%))
+	 (send mred:the-brush-list find-or-create-brush index 'solid)]
+	[else (vector-ref global-brush-vector index)])))
+  
+  (define pen? (lambda (object) (is-a? object mred:pen%)))
+  (define brush? (lambda (object) (is-a? object mred:brush%)))
+  
+  (define display-color-vector
+    (lambda ()
+      (do
+	  ([index 0 (+ index 1)])
+	((eq? index 100))
+	(display (list (/ (rgb-red (get-color index)) 255)
+                       (/ (rgb-green (get-color index)) 255)
+                       (/ (rgb-blue (get-color index)) 255))))))
+  
+  (define make-font
+    (lambda (name)
+      (cond
+	[(eq? name 'large-deco)
+	 (make-object mred:font% 40 'decorative 'normal 'normal)]
+	[(eq? name 'small-roman)
+	 (make-object mred:font% 12 'roman 'normal 'normal)]
+	[(eq? name 'medium-roman)
+	 (make-object mred:font% 24 'roman 'normal 'normal)]
+	[(eq? name 'large-roman)
+	 (make-object mred:font% 32 'roman 'normal 'normal)]
+	[else "no such font ~a; only 'large-deco, 'small-roman, 'medium-roman, and 'large-roman"
+	      name])))
+  
+  (define custom-roman
+    (lambda (size)
+      (make-object mred:font%
+		   size 'roman 'normal 'normal)))
+  
+  (define custom-deco
+    (lambda (size)
+      (make-object mred:font% size 'decorative 'normal 'normal)))
+  
+  (define set-viewport-pen
+    (lambda (viewport pen)
+      (send (viewport-canvas viewport) remember-pen pen)
+      (let ([pen (get-pen pen)])
+	(send (viewport-dc viewport) set-pen pen)
+	(send (viewport-buffer-dc viewport) set-pen pen))))
+  
+  (define set-viewport-brush
+    (lambda (viewport brush)
+      (send (viewport-canvas viewport) remember-brush brush)
+      (let ([brush (get-brush brush)])
+	(send (viewport-dc viewport) set-brush brush)
+	(send (viewport-buffer-dc viewport) set-brush brush))))
+  
+  (define set-text-foreground
+    (lambda (viewport color)
+      (let ([color (get-color color)])
+	(send (viewport-dc viewport) set-text-foreground color)
+	(send (viewport-buffer-dc viewport) set-text-foreground color))))
+  
+  (define set-text-background
+    (lambda (viewport color)
+      (let ([color (get-color color)])
+	(send (viewport-dc viewport) set-text-background color)
+	(send (viewport-buffer-dc viewport) set-text-background color))))
+  
+  (define set-viewport-font
+    (lambda (viewport font)
+      (send (viewport-dc viewport) set-font font)
+      (send (viewport-buffer-dc viewport) set-font font)))
+  
+  (define set-viewport-background
+    (lambda (viewport color)
+      (send (viewport-dc viewport) set-background color)
+      (send (viewport-buffer-dc viewport) set-background color)))
+  
+  (define set-viewport-logical-function
+    (lambda (viewport logical-function)
+      (send (viewport-dc viewport) set-logical-function logical-function)
+      (send (viewport-buffer-dc viewport) set-logical-function
+	    logical-function)))
+
+  (define white (make-rgb 1 1 1))
+  (define black (make-rgb 0 0 0))
+  (define red (make-rgb 1 0 0))
+  (define green (make-rgb 0 1 0))
+  (define blue (make-rgb 0 0 1))
+  (define white-pen (get-pen white))
+  (define black-pen (get-pen black))
+  (define red-pen (get-pen red))
+  (define blue-pen (get-pen blue))
+  (define green-pen (get-pen green))
+  (define white-brush (get-brush white))
+  (define black-brush (get-brush black))
+  (define red-brush (get-brush red))
+  (define green-brush (get-brush green))
+  (define blue-brush (get-brush blue))
+  
+  (define invisi-pen (send mred:the-pen-list find-or-create-pen "WHITE" 0 'transparent))
+  (define invisi-brush (send mred:the-brush-list find-or-create-brush "WHITE" 'transparent))
+  
+  (define xor-pen (send mred:the-pen-list find-or-create-pen "BLACK" 1 'xor))
+  (define xor-brush (send mred:the-brush-list find-or-create-brush "BLACK" 'xor))
+  
+  (define draw-it (lambda (draw flip clear) (draw)))
+  (define flip-it (lambda (draw flip clear) (flip)))
+  (define clear-it (lambda (draw flip clear) (clear)))
+  
+  (define make-draw-proc
+    (lambda (get-pen-name set-pen-name 
+	     get-current-pen-name set-viewport-pen white-pen)
+      (lambda (viewport) 
+	(let* ([vdc (viewport-dc viewport)]
+	       [vbdc (viewport-buffer-dc viewport)])
+	  (lambda (color go)
+	    (let ([orig (and color
+			     (begin0
+			      (send/proc2 (viewport-canvas viewport) 
+					  get-current-pen-name)
+			      (set-viewport-pen viewport (get-color color))))])
+	      (go (lambda (draw)
+		    (let ([pen (send vdc get-pen)]
+			  [brush (send vdc get-brush)])
+		      (send vdc set-brush xor-brush)
+		      (send vbdc set-brush xor-brush)
+		      (send vdc set-pen xor-pen)
+		      (send vbdc set-pen xor-pen)
+		      (draw)
+		      (send vdc set-brush brush)
+		      (send vbdc set-brush brush)
+		      (send vdc set-pen pen)
+		      (send vbdc set-pen pen)))
+		  (lambda (draw)
+		    (let ([pen (send/proc vdc get-pen-name)])
+		      (send/proc vdc set-pen-name white-pen)
+		      (send/proc vbdc set-pen-name white-pen)
+		      (draw)
+		      (send/proc vdc set-pen-name pen)
+		      (send/proc vbdc set-pen-name pen))))
+	      (when orig
+	        (set-viewport-pen viewport orig))))))))
+  
+  (define make-do-line
+    (lambda (go)
+      (let ([f (make-draw-proc 'get-pen 'set-pen 
+			       'get-current-pen set-viewport-pen white-pen)])
+	(lambda (viewport)
+	  (let ([f (f viewport)])
+	    (letrec ([the-function
+		      (case-lambda
+		       [(posn1 posn2) (the-function posn1 posn2 #f)]
+		       [(posn1 posn2 color)
+			(f color
+			   (lambda (flip clear)
+			     (let* ([x1 (posn-x posn1)]
+				    [y1 (posn-y posn1)]
+				    [x2 (posn-x posn2)]
+				    [y2 (posn-y posn2)]
+				    [draw (lambda ()
+					    (send (viewport-dc viewport) 
+						  draw-line 
+						  x1 y1 x2 y2)
+					    (send (viewport-buffer-dc viewport)
+						  draw-line
+						  x1 y1 x2 y2))])
+			       (go draw
+				   (lambda () (flip draw))
+				   (lambda () (clear draw))))))])])
+	      the-function))))))
+  
+  (define draw-line (make-do-line draw-it))
+  (define (clear-line viewport)
+    (let ([f ((make-do-line clear-it) viewport)])
+      (rec clear-line-viewport
+	   (lambda (p1 p2)
+	     (f p1 p2)))))
+  (define (flip-line viewport)
+    (let ([f ((make-do-line flip-it) viewport)])
+      (rec flip-line-viewport
+	   (lambda (p1 p2)
+	     (f p1 p2)))))
+  
+  (define (draw/clear/flip ivar)
+    (lambda (init-dc viewport p width height)
+      (let ([dc (viewport-dc viewport)]
+	    [buffer-dc (viewport-buffer-dc viewport)])
+	(init-dc dc)
+	(init-dc buffer-dc)
+	(send/proc dc ivar (posn-x p) (posn-y p) width height)
+	(send/proc buffer-dc ivar (posn-x p) (posn-y p) width height))))
+  
+  (define draw/clear/flip-rectangle (draw/clear/flip 'draw-rectangle))
+  (define draw/clear/flip-ellipse (draw/clear/flip 'draw-ellipse))
+  
+  (define (draw-rectangle viewport)
+    (check-viewport 'draw-rectangle viewport)
+    (rec draw-rectangle-viewport
+	 (case-lambda 
+	  [(p width height) (draw-rectangle-viewport p width height (make-rgb 0 0 0))]
+	  [(p width height color)
+	   (check 'draw-rectangle
+		  posn? p "posn"
+		  number? width "number"
+		  number? height "number"
+		  (orp color? number?) color "color or index")
+	   (draw/clear/flip-rectangle
+	    (lambda (dc)
+	      (send dc set-pen (send mred:the-pen-list find-or-create-pen (get-color color) 1 'solid))
+	      (send dc set-brush (send mred:the-brush-list find-or-create-brush "BLACK" 'transparent)))
+	    viewport p width height)])))
+    
+  (define (draw-solid-rectangle viewport)
+    (check-viewport 'draw-solid-rectangle viewport)
+    (rec draw-solid-rectangle-viewport
+	 (case-lambda 
+	  [(p width height) (draw-solid-rectangle-viewport p width height (make-rgb 0 0 0))]
+	  [(p width height color)
+	   (check 'draw-solid-rectangle
+		  posn? p "posn"
+		  number? width "number"
+		  number? height "number"
+		  (orp color? number?) color "color or index")
+	   (draw/clear/flip-rectangle
+	    (lambda (dc)
+	      (send dc set-pen (send mred:the-pen-list find-or-create-pen (get-color color) 1 'solid))
+	      (send dc set-brush (send mred:the-brush-list find-or-create-brush (get-color color) 'solid)))
+	    viewport p width height)])))
+  
+  (define (flip-rectangle viewport)
+    (check-viewport 'flip-rectangle viewport)
+    (rec flip-rectangle-viewport
+	 (case-lambda 
+	  [(p width height) (flip-rectangle-viewport p width height (make-rgb 0 0 0))]
+	  [(p width height color)
+	   (check 'flip-rectangle
+		  posn? p "posn"
+		  number? width "number"
+		  number? height "number"
+		  (orp color? number?) color "color or index")
+	   (draw/clear/flip-rectangle
+	    (lambda (dc)
+	      (send dc set-pen (send mred:the-pen-list find-or-create-pen (get-color color) 1 'xor))
+	      (send dc set-brush (send mred:the-brush-list find-or-create-brush "BLACK" 'transparent)))
+	    viewport p width height)])))
+  
+  (define (flip-solid-rectangle viewport)
+    (check-viewport 'flip-solid-rectangle viewport)
+    (rec flip-solid-rectangle-viewport
+	 (case-lambda 
+	  [(p width height) (flip-solid-rectangle-viewport p width height (make-rgb 0 0 0))]
+	  [(p width height color)
+	   (check 'flip-solid-rectangle
+		  posn? p "posn"
+		  number? width "number"
+		  number? height "number"
+		  (orp color? number?) color "color or index")
+	   (draw/clear/flip-rectangle
+	    (lambda (dc)
+	      (send dc set-pen (send mred:the-pen-list find-or-create-pen "BLACK" 1 'transparent))
+	      (send dc set-brush (send mred:the-brush-list find-or-create-brush (get-color color) 'xor)))
+	    viewport p width height)])))
+
+  (define (draw-ellipse viewport)
+    (check-viewport 'draw-ellipse viewport)
+    (rec draw-ellipse-viewport
+	 (case-lambda 
+	  [(p width height) (draw-ellipse-viewport p width height (make-rgb 0 0 0))]
+	  [(p width height color)
+	   (check 'draw-ellipse
+		  posn? p "posn"
+		  number? width "number"
+		  number? height "number"
+		  (orp color? number?) color "color or index")
+	   (draw/clear/flip-ellipse
+	    (lambda (dc)
+	      (send dc set-pen (send mred:the-pen-list find-or-create-pen (get-color color) 1 'solid))
+	      (send dc set-brush (send mred:the-brush-list find-or-create-brush "BLACK" 'transparent)))
+	    viewport p width height)])))
+  
+  (define (draw-solid-ellipse viewport)
+    (check-viewport 'draw-solid-ellipse viewport)
+    (rec draw-solid-ellipse-viewport
+	 (case-lambda 
+	  [(p width height) (draw-solid-ellipse-viewport p width height (make-rgb 0 0 0))]
+	  [(p width height color)
+	   (check 'draw-solid-ellipse
+		  posn? p "posn"
+		  number? width "number"
+		  number? height "number"
+		  (orp color? number?) color "color or index")
+	   (draw/clear/flip-ellipse
+	    (lambda (dc)
+	      (send dc set-pen (send mred:the-pen-list find-or-create-pen (get-color color) 1 'solid))
+	      (send dc set-brush (send mred:the-brush-list find-or-create-brush (get-color color) 'solid)))
+	    viewport p width height)])))
+  
+  (define (flip-ellipse viewport)
+    (check-viewport 'flip-ellipse viewport)
+    (rec flip-ellipse-viewport
+	 (case-lambda 
+	  [(p width height) (flip-ellipse-viewport p width height (make-rgb 0 0 0))]
+	  [(p width height color)
+	   (check 'flip-ellipse
+		  posn? p "posn"
+		  number? width "number"
+		  number? height "number"
+		  (orp color? number?) color "color or index")
+	   (draw/clear/flip-ellipse
+	    (lambda (dc)
+	      (send dc set-pen (send mred:the-pen-list find-or-create-pen (get-color color) 1 'xor))
+	      (send dc set-brush (send mred:the-brush-list find-or-create-brush "BLACK" 'transparent)))
+	    viewport p width height)])))
+  
+  (define (flip-solid-ellipse viewport)
+    (check-viewport 'flip-solid-rectangle viewport)
+    (rec flip-solid-ellipse-viewport
+	 (case-lambda 
+	  [(p width height) (flip-solid-ellipse-viewport p width height (make-rgb 0 0 0))]
+	  [(p width height color)
+	   (check 'flip-solid-ellipse
+		  posn? p "posn"
+		  number? width "number"
+		  number? height "number"
+		  (orp color? number?) color "color or index")
+	   (draw/clear/flip-ellipse
+	    (lambda (dc)
+	      (send dc set-pen (send mred:the-pen-list find-or-create-pen "BLACK" 1 'transparent))
+	      (send dc set-brush (send mred:the-brush-list find-or-create-brush (get-color color) 'xor)))
+	    viewport p width height)])))
+  
+  (define (clear-rectangle viewport)
+    (check-viewport 'clear-rectangle viewport)
+    (rec clear-rectangle-viewport
+	 (lambda (p width height)
+	   (check 'clear-rectangle
+		  posn? p "posn"
+		  number? width "number"
+		  number? height "number")
+	   (draw/clear/flip-rectangle
+	    (lambda (dc)
+	      (send dc set-pen (send mred:the-pen-list find-or-create-pen "WHITE" 1 'solid))
+	      (send dc set-brush (send mred:the-brush-list find-or-create-brush "BLACK" 'transparent)))
+	    viewport p width height))))
+  
+  (define (clear-solid-rectangle viewport)
+    (check-viewport 'clear-solid-rectangle viewport)
+    (rec clear-solid-rectangle-viewport
+	 (lambda (p width height)
+	   (check 'clear-solid-rectangle
+		  posn? p "posn"
+		  number? width "number"
+		  number? height "number")
+	   (draw/clear/flip-rectangle
+	    (lambda (dc)
+	      (send dc set-pen (send mred:the-pen-list find-or-create-pen "WHITE" 1 'solid))
+	      (send dc set-brush (send mred:the-brush-list find-or-create-brush "WHITE" 'solid)))
+	    viewport p width height))))
+  
+  (define (clear-ellipse viewport)
+    (check-viewport 'clear-ellipse viewport)
+    (rec clear-ellipse-viewport
+	 (lambda (p width height)
+	   (check 'clear-ellipse
+		  posn? p "posn"
+		  number? width "number"
+		  number? height "number")
+	   (draw/clear/flip-ellipse
+	    (lambda (dc)
+	      (send dc set-pen (send mred:the-pen-list find-or-create-pen "WHITE" 1 'solid))
+	      (send dc set-brush (send mred:the-brush-list find-or-create-brush "BLACK" 'transparent)))
+	    viewport p width height))))
+  
+  (define (clear-solid-ellipse viewport)
+    (check-viewport 'clear-solid-ellipse viewport)
+    (rec clear-solid-ellipse-viewport
+	 (lambda (p width height)
+	   (check 'clear-solid-ellipse
+		  posn? p "posn"
+		  number? width "number"
+		  number? height "number")
+	   (draw/clear/flip-ellipse
+	    (lambda (dc)
+	      (send dc set-pen (send mred:the-pen-list find-or-create-pen "WHITE" 1 'solid))
+	      (send dc set-brush (send mred:the-brush-list find-or-create-brush "WHITE" 'solid)))
+	    viewport p width height))))
+
+  (define make-do-pointlist
+    (lambda (go name get-pen-name set-pen-name
+		get-current-pen-name set-viewport-pen white-pen
+		get-brush-name set-brush-name invisi-brush)
+      (let ([f (make-draw-proc get-pen-name set-pen-name 
+			       get-current-pen-name set-viewport-pen white-pen)])
+	(lambda (viewport)
+	  (let ([f (f viewport)]
+		[vdc (viewport-dc viewport)]
+		[vbdc (viewport-buffer-dc viewport)])
+	    (letrec ([the-function
+		      (case-lambda
+		       [(posns offset) (the-function posns offset #f)]
+		       [(posns offset color)
+			(f color
+			   (lambda (flip clear)
+			     (let* ([points (map (lambda (p)
+						   (make-object mred:point% (posn-x p) (posn-y p)))
+						 posns)]
+				    [x (posn-x offset)]
+				    [y (posn-y offset)]
+				    [orig (send/proc vdc get-brush-name)]
+				    [draw (lambda ()
+					    (send/proc vdc set-brush-name
+						       invisi-brush)
+					    (send/proc vbdc set-brush-name
+						       invisi-brush)
+					    (send/proc 
+					     (viewport-dc viewport) name
+					     points x y)
+					    (send/proc 
+					     (viewport-buffer-dc viewport) name
+					     points x y)
+					    (send/proc vdc set-brush-name orig)
+					    (send/proc vbdc set-brush-name
+						       orig))])
+			       (go draw
+				   (lambda () (flip draw))
+				   (lambda () (clear draw))))))])])
+	      the-function))))))
+  
+  (define make-do-polygon
+    (lambda (go)
+      (make-do-pointlist go 'draw-polygon 'get-pen 'set-pen 
+			 'get-current-pen set-viewport-pen white-pen
+			 'get-brush 'set-brush invisi-brush)))
+  
+  (define make-do-solid-polygon
+    (lambda (go)
+      (make-do-pointlist go 'draw-polygon 'get-brush 'set-brush  
+			 'get-current-brush set-viewport-brush white-brush
+			 'get-pen 'set-pen invisi-pen)))
+  
+  (define draw-polygon (make-do-polygon draw-it))
+  (define (clear-polygon viewport)
+    (let ([f ((make-do-polygon clear-it) viewport)])
+      (rec clear-polygon-viewport
+	   (lambda (posns offset)
+	     (f posns offset)))))
+  (define (flip-polygon viewport)
+    (let ([f ((make-do-polygon flip-it) viewport)])
+      (rec flip-polygon-viewport
+	   (lambda (posns offset)
+	     (f posns offset)))))
+  
+  (define draw-solid-polygon (make-do-solid-polygon draw-it))
+  (define (clear-solid-polygon viewport)
+    (let ([f ((make-do-solid-polygon clear-it) viewport)])
+      (rec clear-solid-polygon-viewport
+	   (lambda (posns offset)
+	     (f posns offset)))))
+  (define (flip-solid-polygon viewport)
+    (let ([f ((make-do-solid-polygon flip-it) viewport)])
+      (rec flip-solid-polygon-viewport
+	   (lambda (posns offset)
+	     (f posns offset)))))
+  
+  (define make-do-pixel
+    (lambda (go)
+      (let ([f (make-draw-proc 'get-pen 'set-pen  
+			       'get-current-pen set-viewport-pen white-pen)])
+	(lambda (viewport)
+	  (let ([f (f viewport)])
+	    (letrec ([the-function
+		      (case-lambda
+		       [(posn) (the-function posn #f)]
+		       [(posn color)
+			(f color
+			   (lambda (flip clear)
+			     (let* ([x (posn-x posn)]
+				    [y (posn-y posn)]
+				    [draw (lambda ()
+					    (send 
+					     (viewport-dc viewport) draw-point
+					     x y)
+					    (send 
+					     (viewport-buffer-dc viewport)
+					     draw-point 
+					     x y))])
+			       (go draw 
+				   (lambda () (flip draw)) 
+				   (lambda () (clear draw))))))])])
+	      the-function))))))
+  
+  (define draw-pixel (make-do-pixel draw-it))
+  (define (clear-pixel viewport)
+    (let ([f ((make-do-pixel clear-it) viewport)])
+      (rec clear-pixel-viewport
+	   (lambda (posns offset)
+	     (f posns offset)))))
+  (define (flip-pixel viewport)
+    (let ([f ((make-do-pixel flip-it) viewport)])
+      (rec flip-pixel-viewport
+	   (lambda (posns offset)
+	     (f posns offset)))))
+  
+  (define string-functions
+    (lambda (string-op)
+      (letrec ([outer-function
+		(case-lambda
+		 [(viewport) (outer-function viewport default-font)]
+		 [(viewport font)
+		  (letrec ([the-function
+			    (case-lambda
+			     [(posn text) (the-function posn text #f)]
+			     [(posn text color)
+			      (let*-values ([(dc) (viewport-dc viewport)]
+					    [(x) (posn-x posn)]
+					    [(w h d a) (send dc get-text-extent "X" font)]
+					    [(y) (- (posn-y posn) (- h d))]
+					    [(buffer) (viewport-buffer-dc viewport)]
+					    [(string-create)
+					     (lambda ()
+					       (send dc draw-text text x y)
+					       (send buffer draw-text text x y))])
+				(cond
+				  [(eq? string-op 'draw)
+				   (when color
+				     (set-text-foreground viewport color))
+				   (set-viewport-font viewport font)
+				   (send dc draw-text text x y)
+				   (send buffer draw-text text x y)]
+				  [(eq? string-op 'flip)
+				   (when color
+				     (set-text-foreground viewport color))
+				   (set-viewport-font viewport font)
+				   (string-create)]
+				  [(eq? string-op 'clear)
+				   (set-text-foreground viewport white)
+				   (set-viewport-font viewport font)
+				   (string-create)
+				   (set-text-foreground viewport black)]))])])
+		    the-function)])])
+	outer-function)))
+  
+  (define draw-string (string-functions 'draw))
+  (define (clear-string viewport)
+    (let ([f ((string-functions 'clear) viewport)])
+      (rec clear-string-viewport
+	   (lambda (posns offset)
+	     (f posns offset)))))
+  (define (flip-string viewport)
+    (let ([f ((string-functions 'flip) viewport)])
+      (rec flip-string-viewport
+	   (lambda (posns offset)
+	     (f posns offset)))))
+  
+  (define get-string-size
+    (case-lambda
+     [(viewport) (get-string-size viewport default-font)]
+     [(viewport font)
+      (lambda (text)
+	(let-values ([(w h d a) (send (viewport-dc viewport) get-text-extent text font)])
+	  (list w h)))]))
+  
+  (define get-color-pixel 
+    (lambda (viewport)
+      (lambda (posn)
+	(let ([c (make-object mred:color%)]
+	      [x (posn-x posn)]
+	      [y (posn-y posn)])
+	  (unless (send (viewport-buffer-dc viewport) get-pixel x y c)
+	    (error 'get-color-pixel "specified point is out-of-range"))
+	  c))))
+  
+  (define get-pixel 
+    (lambda (viewport)
+      (lambda (posn)
+	(let ([c (make-object mred:color%)]
+	      [x (posn-x posn)]
+	      [y (posn-y posn)])
+	  (unless (send (viewport-buffer-dc viewport) get-pixel x y c)
+	    (error 'get-pixel "specified point is out-of-range"))
+	  (if (or (< (send c blue) 255)
+		  (< (send c red) 255)
+		  (< (send c green) 255))
+	      1
+	      0)))))
+  
+  (define (test-pixel viewport)
+    (lambda (color)
+      (let ([c (make-object mred:color%)])
+	(send (viewport-buffer-dc viewport) try-color color c)
+	c)))
+
+  (define draw-pixmap-posn
+    (opt-lambda (filename [type 'unknown/mask])
+      (check 'draw-pixmap-posn
+	     (andp string? file-exists?) filename "filename"
+	     (lambda (x) (memq x '(gif xbm xpm bmp pict unknown unknown/mask gif/mask))) type "file type symbol")
+      (let* ([bitmap (make-object mred:bitmap% filename type)])
+	(lambda (viewport)
+	  (check 'draw-pixmap-posn
+		 viewport? viewport "viewport")
+	  (opt-lambda (posn [color #f])
+	    (check 'draw-pixmap-posn
+		   posn? posn "posn"
+		   (orp not color?) color (format "color or ~e" #f))
+	    (when color
+	      (set-viewport-pen viewport (get-color color)))
+	    (let ([x (posn-x posn)]
+		  [y (posn-y posn)])
+	      (send (viewport-dc viewport) draw-bitmap bitmap x y 'solid black-color (send bitmap get-loaded-mask))
+	      (send (viewport-buffer-dc viewport) draw-bitmap bitmap x y 'solid black-color (send bitmap get-loaded-mask))))))))
+  
+  (define draw-pixmap
+    (lambda (viewport)
+      (check 'draw-pixmap
+	     viewport? viewport "viewport")
+      (opt-lambda (filename p [color #f])
+	(check 'draw-pixmap
+	       (andp string? file-exists?) filename "filename"
+	       posn? p "posn"
+	       (orp not color?) color (format "color or ~e" #f))
+	(((draw-pixmap-posn filename 'unknown) viewport) p color))))
+  
+  (define copy-viewport 
+    (lambda (source target)
+      (check 'copy-viewport
+	     viewport? source "viewport"
+	     viewport? target "viewport")
+      (let* ([source-bitmap (viewport-bitmap source)]
+	     [target-dc (viewport-dc target)]
+	     [target-buffer-dc (viewport-buffer-dc target)])
+	(send target-dc draw-bitmap source-bitmap 0 0)
+	(send target-buffer-dc draw-bitmap source-bitmap 0 0))))
+
+  (define save-pixmap
+    (lambda (viewport)
+      (check 'save-pixmap
+	     viewport? viewport "viewport")
+      (opt-lambda (filename [kind 'xpm])
+	(check 'save-pixmap
+	       (andp string? (orp relative-path? absolute-path?)) filename "filename"
+	       (lambda (x) (memq x '(xpm xbm bmp pict))) kind "file type symbol")
+	(let ([bm (viewport-bitmap viewport)])
+	  (send bm save-file filename kind)))))
+
+  (define sixlib-eventspace #f)
+  
+  (define make-open-viewport
+    (lambda (name show?)
+      (unless sixlib-eventspace
+	(set! sixlib-eventspace 
+	      (parameterize ([current-exception-handler
+			      (lambda (x)
+				((error-display-handler)
+				 (format "internal error in graphics library: ~a"
+					 (if (exn? x)
+					     (exn-message x)
+					     (format "~e" x))))
+				((error-escape-handler)))])
+		(mred:make-eventspace))))
+      (letrec ([open-viewport
+		(case-lambda
+		 [(label point) 
+		  (cond
+		    [(posn? point) (open-viewport label (posn-x point) (posn-y point))]
+		    [(and (list? point) (= (length point) 2))
+		     (open-viewport label (car point) (cadr point))]
+		    [else (error name "bad argument ~s" point)])]
+		 [(label width height)
+		  (cond
+		    [graphics-flag
+		     (let*
+			 ([frame
+			   (parameterize ([mred:current-eventspace sixlib-eventspace])
+			     (make-object sixlib-frame%
+                               label #f width height))]
+			  [panel (make-object mred:vertical-panel% frame)]
+			  [canvas (make-object sixlib-canvas% panel)]
+			  [_ (begin
+			       (send canvas min-height height)
+			       (send canvas min-width width))]
+			  [dc (send canvas get-dc)]
+			  [buffer-dc (make-object mred:bitmap-dc%)]
+			  [viewport (make-viewport label canvas)]
+                          [ml (event-receiver)]
+                          [kl (event-receiver)])
+		       (send panel set-alignment 'center 'center)
+		       (send frame set-canvas canvas)
+		       (send canvas set-viewport viewport)
+		       (send canvas set-dc dc)
+		       (send canvas set-buffer-dc buffer-dc)
+		       (send canvas set-geometry width height)
+                       (send canvas set-mouse-listener ml)
+                       (send canvas set-key-listener kl)
+		       (when show? 
+			 (send frame show #t)
+			 (send canvas focus))
+		       (set-text-foreground viewport black)
+		       (set-text-background viewport white)
+		       (set-viewport-background viewport white)
+		       (set-viewport-pen viewport black-pen)
+		       (set-viewport-brush viewport black-brush)
+		       ((clear-viewport viewport))
+		       (when (null? global-viewport-list)
+			 (send open-frames-timer start 100000000))
+		       (set! global-viewport-list (cons viewport global-viewport-list))
+		       viewport)]
+		    [else (error "graphics not open")])])])
+	open-viewport)))
+  
+  (define open-viewport (make-open-viewport 'open-viewport #t))
+  (define open-pixmap (make-open-viewport 'open-pixmap #f))
+  
+  (define (default-display-is-color?) (mred:is-color-display?))
+  
+  (define position-display
+    (lambda (viewport counter)
+      (cond
+	[(equal? counter 0) '()]
+	[else (begin 
+		(display (query-mouse-posn viewport))
+		(position-display viewport (- counter 1)))])))
+  
+  
+  (define create-cmap
+    (lambda ()
+      (do ([index 0 (+ 1 index)])
+	((> index 20))
+	(let* ([r (* 0.05 index)]
+	       [b (- 1 r)]
+	       [g (- 1 r)])
+	  (change-color index (make-rgb r g b))))))
+  
+  (define viewport->snip
+    (lambda (viewport)
+      (let ([orig-bitmap (send (viewport-canvas viewport) get-bitmap)]
+	    [orig-dc (viewport-buffer-dc viewport)])
+	(let* ([h (send orig-bitmap get-height)]
+	       [w (send orig-bitmap get-width)]
+	       [new-bitmap (make-object mred:bitmap% w h)]
+	       [tmp-mem-dc (make-object mred:bitmap-dc%)])
+	  (send tmp-mem-dc set-bitmap new-bitmap)
+	  (send tmp-mem-dc draw-bitmap (send orig-dc get-bitmap) 0 0)
+	  (send tmp-mem-dc set-bitmap #f)
+	  (let ([snip (make-object mred:image-snip%)])
+	    (send snip set-bitmap new-bitmap)
+	    snip)))))
+  
+  (create-cmap)
+
+
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;;                                                             ;;;
+  ;;;                        ERROR CHECKING                       ;;;
+  ;;;                                                             ;;;
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+  ;; check-viewport : symbol TST -> void
+  (define (check-viewport f-name obj)
+    (unless (viewport? obj)
+      (error f-name "expected viewport as first argument, got ~e" obj)))
+
+  ;; (define-type arg/pred/name-list (list* (TST -> bool) TST string arg/pred/name-list))
+  ;; check : (symbol arg/pred/name-list *-> void)
+  (define (check f-name . in-args)
+    (let loop ([args in-args]
+	       [n 0])
+      (cond
+       [(null? args) (void)]
+       [else (let ([pred? (car args)]
+		   [val (cadr args)]
+		   [name (caddr args)])
+	       (unless (pred? val)
+		 (error f-name "expected ~a as arg ~a, got: ~e, all args: ~a"
+			name n val
+			(let loop ([args in-args])
+			  (cond
+			   [(null? args) ""]
+			   [else (string-append (format "~e" (cadr args))
+						" "
+						(loop (cdddr args)))]))))
+	       (loop (cdddr args)
+		     (+ n 1)))])))
+
+  (define (orp . preds)
+    (lambda (TST)
+      (ormap (lambda (p) (p TST)) preds)))
+
+  (define (andp . preds)
+    (lambda (TST)
+      (andmap (lambda (p) (p TST)) preds)))
+  )
+))
diff --git a/collects/frtime/graphics-sig.ss b/collects/frtime/graphics-sig.ss
new file mode 100644
index 0000000000..86d293c9b9
--- /dev/null
+++ b/collects/frtime/graphics-sig.ss
@@ -0,0 +1,71 @@
+(module graphics-sig mzscheme
+  (require (lib "unitsig.ss"))
+
+  (provide graphics^ graphics:posn-less^ graphics:posn^)
+
+  (define-signature graphics:posn^
+    (make-posn posn? posn-x posn-y set-posn-x! set-posn-y!))
+
+  (define-signature graphics:posn-less^
+    (viewport?
+
+     sixkey-value sixkey-shift sixkey-control sixkey-meta sixkey-alt
+     
+     sixmouse-x sixmouse-y sixmouse-left? sixmouse-middle? sixmouse-right?
+     sixmouse?
+     make-sixmouse
+     
+     open-graphics 
+     close-graphics 
+     graphics-open?
+     
+     make-rgb
+     rgb-blue rgb-red rgb-green
+     change-color 
+     rgb?
+     
+     open-viewport 
+     open-pixmap
+     close-viewport    
+     
+     query-mouse-posn
+
+     viewport-mouse-events
+     viewport-key-events
+     
+     clear-viewport draw-viewport flip-viewport
+     
+     draw-line clear-line flip-line 
+     draw-pixel clear-pixel flip-pixel 
+     get-pixel get-color-pixel test-pixel
+     
+     draw-rectangle clear-rectangle flip-rectangle 
+     draw-ellipse clear-ellipse flip-ellipse 
+     draw-polygon clear-polygon flip-polygon 
+     draw-solid-rectangle clear-solid-rectangle flip-solid-rectangle 
+     draw-solid-ellipse clear-solid-ellipse flip-solid-ellipse 
+     draw-solid-polygon clear-solid-polygon flip-solid-polygon 
+     
+     get-string-size
+     
+     draw-string clear-string flip-string 
+     
+     draw-pixmap-posn
+     draw-pixmap
+     save-pixmap
+     
+     copy-viewport 
+     
+     default-display-is-color?
+     
+     viewport->snip
+     
+     viewport-dc viewport-buffer-dc))
+  
+  (define-signature graphics^
+    ((open graphics:posn-less^)
+     (open graphics:posn^)))
+)
+
+
+
diff --git a/collects/frtime/graphics-unit.ss b/collects/frtime/graphics-unit.ss
new file mode 100644
index 0000000000..6cc4f13a70
--- /dev/null
+++ b/collects/frtime/graphics-unit.ss
@@ -0,0 +1,16 @@
+(module graphics-unit mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "mred-sig.ss" "mred")
+	   "graphics-sig.ss"
+	   "graphics-posn-less-unit.ss")
+  (provide graphics@)
+
+  (define graphics@
+    (compound-unit/sig
+      (import [mred : mred^])
+      (link [p : graphics:posn^ 
+	       ((unit/sig graphics:posn^ (import) (define-struct posn (x y))))]
+	    [g : graphics:posn-less^ (graphics-posn-less@ mred p)])
+      (export
+       (open p)
+       (open g)))))
\ No newline at end of file
diff --git a/collects/frtime/graphics.ss b/collects/frtime/graphics.ss
new file mode 100644
index 0000000000..4fb4c885d5
--- /dev/null
+++ b/collects/frtime/graphics.ss
@@ -0,0 +1,9 @@
+(module graphics mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "mred-sig.ss" "mred")
+	   (lib "mred.ss" "mred")
+	   "graphics-sig.ss"
+	   "graphics-unit.ss")
+  (provide-signature-elements graphics^)
+
+  (define-values/invoke-unit/sig graphics^ graphics@ #f mred^))
\ No newline at end of file
diff --git a/collects/frtime/gui.ss b/collects/frtime/gui.ss
new file mode 100644
index 0000000000..70cd5ae281
--- /dev/null
+++ b/collects/frtime/gui.ss
@@ -0,0 +1,242 @@
+(module gui (lib "frtime.ss" "frtime")
+  (require
+   (all-except (lib "etc.ss") rec)
+   (lib "list.ss")
+   (lib "class.ss")
+   (all-except (lib "mred.ss" "mred") send-event))
+  
+  (define reactive-control<%>
+    (interface (control<%>)
+      get-event))
+  
+  (define (insert-in-list list position new-element)
+    (let loop ((list list) (position position))
+      (cond
+        ((zero? position)
+         (cons new-element list))
+        ((null? list)
+         '())
+        (else
+         (cons (car list) (loop (cdr list) (sub1 position)))))))
+  
+  (define (reactive-control-mixin super)
+    (class* super (reactive-control<%>)
+;    (mixin (control<%>) (reactive-control<%>)
+      (define event (event-receiver))
+      (define/public (get-event) event)
+      (define/public (extract-value)
+        (error 'extract-value "abstract method"))
+      (super-instantiate ()
+        (callback
+         (lambda (self control-event)
+           (send-event event
+                       (list self
+                             control-event
+                             (extract-value))))))))
+  
+  (define reactive-slider%
+    (class (reactive-control-mixin slider%)
+      (inherit get-value)
+      (define/override (extract-value)
+        (get-value))
+      (super-instantiate ())))
+  
+  (define (make-control-behavior reactive-control)
+    (hold ((send reactive-control get-event) . ==> . third)
+          (send reactive-control extract-value)))
+  
+  ;(define (get-button-event reactive-button)
+  ;  ((send reactive-button get-event) . -=> . #t))
+  
+  (define reactive-slider-1d% reactive-slider%)
+  
+  (define make-slider-1d-behavior make-control-behavior)
+  
+;   (define reactive-slider-2d%
+;     (class (reactive-control-mixin slider-2d%)
+;       (inherit get-values)
+;       (define/override (extract-value)
+;         (call-with-values (lambda () (get-values))
+;                           cons))
+;       (super-instantiate ())))
+;   
+;   (define (make-slider-2d-behavior reactive-slider)
+;     (hold ((send reactive-slider get-event) . ==> . third)
+;           (call-with-values
+;            (lambda () (send reactive-slider get-values))
+;            cons)))
+;   
+; 
+ 
+  
+  (define reactive-button%
+    (class (reactive-control-mixin button%)
+      (define/override (extract-value)
+        'button-press)
+      (super-instantiate ())))
+  
+  (define reactive-check-box%
+    (class (reactive-control-mixin check-box%)
+      (inherit get-value)
+      (define/override (extract-value)
+        (get-value))
+      (super-instantiate ())))
+  
+  (define reactive-list-box%
+    (class (reactive-control-mixin list-box%)
+      (inherit get-selections)
+      (define/override (extract-value)
+        (get-selections))
+      (super-instantiate ())))
+  
+  (define reactive-choice%
+    (class (reactive-control-mixin choice%)
+      (inherit get-selection)
+      (define/override (extract-value)
+        (get-selection))
+      (super-instantiate ())))
+  
+  (define reactive-text-field%
+    (class (reactive-control-mixin text-field%)
+      (inherit get-value)
+      (define/override (extract-value)
+        (get-value))
+      (super-instantiate ())))
+  
+  (define view<%>
+    (interface ()
+      set-value))
+  
+  (define reactive-view<%>
+    (interface ()
+      set-behavior))
+  
+  (define (reactive-view-mixin super)
+    (class* super (reactive-view<%>)
+;    (mixin (view<%>) (reactive-view<%>)
+      (init-field
+       [cell (new-cell undefined)]
+       [updater #f])
+      
+      (super-instantiate ())
+      
+      (define/public (set-behavior beh)
+        (unless updater
+          (set! updater
+                (proc->signal
+                 (lambda ()
+                   (send this set-value (value-now cell))
+                   (value-now cell))
+                 cell)))
+        (set-cell! cell beh))))
+;   (define (drive-view-thread view event)
+;     (let ((view-box (make-weak-box view)))
+;       (set! view (void))
+;       (dynamic-disable-break
+;        (lambda ()
+;          (thread
+;           (lambda ()
+;             (let/ec k
+;               (with-handlers ((exn:break? k))
+;                 (run-callback event
+;                               (lambda (value)
+;                                 (cond
+;                                   ((weak-box-value view-box)
+;                                    => (lambda (view)
+;                                         (send view set-value value)))
+;                                   (else (k 'fick-dich-ins-knie)))))))))))))
+; 
+
+  (define reactive-gauge%
+    (reactive-view-mixin
+     (class* gauge% (view<%>)
+       (override set-value)
+       (inherit show is-shown?)
+       (define (set-value val)
+         (if (undefined? val)
+             (when (is-shown?)
+               (show #f))
+             (begin
+               (unless (is-shown?)
+                 (show #t))
+               (super set-value val))))
+       (super-instantiate ()))))
+  
+  (define reactive-message%
+    (reactive-view-mixin
+     (class* message% (view<%>)
+       (inherit set-label)
+       (define/public (set-value label)
+         (if (undefined? label)
+             (set-label "")
+             (set-label label)))
+       (super-instantiate ()))))
+  
+  (define frame (instantiate frame% () (label "GUI") (height 150) (width 200)))
+  (send frame show #t)
+  
+  (define-struct gui-item (builder))
+  
+  (define (create-gui-item builder)
+    (let ([C false])
+      (make-gui-item
+       (lambda (p)
+         (cond
+           [(and p C)
+            (error 'create-window "item added to window twice")]
+           [(and p (not C)) (set! C (builder p)) C]
+           [(and (not p) C) C]
+           [(and (not p) (not C))
+            (error 'gui "gui-items must be added to window before use (see create-window)")])))))
+  
+  (define (make-button str)
+    (send (instantiate reactive-button% () (label str) (parent frame)) get-event))
+  
+  (define (make-message str~)
+    (send (instantiate reactive-message% ()
+            (label (if (undefined? (value-now str~))
+                       ""
+                       (value-now str~)))
+            (parent frame)
+            (stretchable-height #t)
+            (stretchable-width #t))
+          set-behavior
+          str~))
+  
+  (define (make-gauge rng val~)
+    (send (instantiate reactive-gauge% ()
+            (label "")
+            (range rng)
+            (parent frame)
+            (stretchable-width #t))
+          set-behavior
+          val~))
+  
+  (define (make-text str)
+    (make-control-behavior (instantiate reactive-text-field% () (label str) (init-value "") (parent frame))))
+  
+  (define (make-choice str los)
+    (make-control-behavior (instantiate reactive-choice% () (choices los) (parent frame) (label str))))
+
+  (define (make-slider str min max init)
+    (make-control-behavior (instantiate reactive-slider-1d% () (label str)
+                             (min-value min) (max-value max) (parent frame)
+                             (init-value init)
+                             ;(style (list 'plain 'horizontal))
+                             )))
+  
+  (define make-check-box
+    (opt-lambda (str [val #f])
+      (make-control-behavior (instantiate reactive-check-box% ()
+                               (label str) (parent frame) (value val)))))
+  
+  (define fresh-window
+    (let ([first #t])
+      (lambda ()
+        (if first
+            (set! first #f)
+            (begin
+              (set! frame (instantiate frame% () (label "GUI") (height 150) (width 200)))
+              (send frame show #t))))))
+  
+  (provide (all-defined)))
diff --git a/collects/frtime/heap.ss b/collects/frtime/heap.ss
new file mode 100644
index 0000000000..a64ea1fced
--- /dev/null
+++ b/collects/frtime/heap.ss
@@ -0,0 +1,161 @@
+(module heap mzscheme
+  
+  (require (lib "etc.ss")
+	   "base-gm.ss"
+	   "dv.ss")
+  
+  
+  (provide make-heap heap-empty? heap-size heap-insert heap-pop
+	   heap-peak heap-remove heap-find
+	   heap-contains heap-resort heap-tostring)
+  
+  
+  
+  
+  (define-struct t (sorter equality data))
+  
+  ;; sorter: elements which have the most trueness according to 
+  ;; the sorter pop out first
+  (define (make-heap sorter equality)
+    (let ((data (dv:make 5)))
+      (dv:append data 0)
+      (make-t sorter equality data)))
+  
+  (define (heap-size heap)
+    (- (dv:length (t-data heap)) 1))
+  
+  (define (heap-empty? heap)
+    (= (heap-size heap) 0))
+
+  (define (heap-last heap)
+    (- (dv:length (t-data heap)) 1))
+  
+  (define (heap-parent i) 
+    (floor (/ i 2)))
+  
+  (define (heap-left i) (* i 2))
+  
+  (define (heap-right i) (+ 1 (* i 2)))
+  
+  (define (heap-has-right heap i) 
+    (<= (heap-right i) (heap-last heap)))
+  
+  (define (heap-has-left heap i)
+    (<= (heap-left i) (heap-last heap)))
+  
+  (define (heap-insert heap item)
+    (let* ((sorter (t-sorter heap))
+	   (data (t-data heap)))
+      (dv:append data item)
+      (let ((d (let loop ((prev (heap-last heap))
+			  (current (heap-parent (heap-last heap))))
+		 
+		 (cond ((= current 0) prev)
+		       ((sorter item (dv:ref data current)) 
+			(dv:set! data prev (dv:ref data current))
+			(loop current (heap-parent current)))
+		       (#t prev)))))
+	(dv:set! data d item))))
+  
+  (define (heap-peak heap)
+    (if (= (heap-size heap) 0) (error "heap-peak: empty")
+	(dv:ref (t-data heap) 1)))
+
+  (define (heap-pop heap)
+    (if (= (heap-size heap) 0) (error "heap-pop: empty")
+	(begin0 (dv:ref (t-data heap) 1)
+                (heap-remove-pos heap 1))))
+  
+  (define (heap-remove-pos heap pos)
+    (let* ((data (t-data heap))
+	   (sorter (t-sorter heap)))
+      
+      (cond ((= 0 (heap-size heap)) (error "heap: removing from empty"))
+	    ((= pos (heap-last heap)) (dv:remove-last data))
+	    (#t (let ((item (dv:ref data (heap-last heap))))
+		  (dv:remove-last data)
+		  (let loop ((current pos))
+		    
+		    (dv:set! data current item)
+		    (let* ((left (heap-left current))
+			   (right (heap-right current))
+			   (best-1 (if (and (heap-has-left heap current)
+					    (sorter (dv:ref data left) item)) 
+				       left current))
+			   
+			   (best-2 (if (and (heap-has-right heap current)
+					    (sorter (dv:ref data right)
+						    (dv:ref data best-1)))
+				       right best-1)))
+		      
+		      (if (not (= best-2 current))
+			  (begin (dv:set! data current (dv:ref data best-2))
+				 (loop best-2))))))))))
+  
+  ;; return false if the object is not found
+  (define (heap-remove heap item)
+    (let ((pos (heap-find heap item)))
+      (if (not pos) false
+	  (begin (heap-remove-pos heap pos) true))))
+
+  (define (heap-contains heap item)
+    (if (heap-find heap item) true false))
+
+  (define (heap-find heap item)
+    (let ((data (t-data heap))
+	  (equality (t-equality heap))
+	  (sorter (t-sorter heap)))
+      (let loop ((current 1))
+	(let ((current-item (dv:ref data current)))
+	  (cond ((equality item current-item) current)
+		((sorter item current-item) #f)
+		(#t (or (and (heap-has-left heap current)
+			     (not (sorter item (dv:ref data (heap-left current))))
+			     (loop (heap-left current)))
+			(and (heap-has-right heap current)
+			     (not (sorter item (dv:ref data (heap-right current))))
+			     (loop (heap-right current))))))))))
+  
+  (define (heap-resort heap item)
+    (heap-remove heap item)
+    (heap-insert heap item))
+
+  (define (heap-tostring heap . fns)
+    (let* ((data (t-data heap))
+	   (data-list (let loop ((i 1))
+			(if (> i (heap-last heap)) empty
+			    (cons (dv:ref data i) (loop (+ i 1)))))))
+      
+    (string-append "heap: sz " (number->string (heap-size heap)) ", "
+		   (apply to-string (cons data-list fns)))))
+  
+  (define (test)
+    (define f (make-heap > eq?))
+    (define d (t-data f))
+    (heap-insert f 99)
+    (debug "A " d) 
+    (heap-remove-pos f 1)
+    (debug "B " d)
+    (for-each (lambda (x) (heap-insert f x)) '(1 2 3 4 5 6 7 8 9 10 11 12 13 14))
+    (debug "C " d)
+    (heap-remove f 10) (debug " " d)
+    (heap-remove f 5) (debug " " d)
+    (heap-remove f 8) (debug " " d)
+    (heap-remove f 13) (debug " " d)
+    (debug (heap-contains f 11))
+    (debug (heap-contains f 123))
+    (heap-pop f)
+    (heap-pop f)
+    (heap-pop f)
+    (heap-pop f) (debug " " d)
+    (debug (heap-contains f 11))
+    (debug (heap-contains f 4))
+    (debug (heap-tostring f))
+    (heap-remove f 2)
+    (debug (heap-tostring f))
+    (heap-remove f 3)
+    (debug (heap-tostring f))
+    )
+
+  )
+
diff --git a/collects/frtime/info.ss b/collects/frtime/info.ss
new file mode 100644
index 0000000000..8fb31543bf
--- /dev/null
+++ b/collects/frtime/info.ss
@@ -0,0 +1,8 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "frtime")
+  (define doc.txt "doc.txt")
+  
+  (define tools (list "frtime-tool.ss"))
+  (define tool-icons (list '("clock.png" "frtime")))
+  (define tool-names (list "FrTime Languages")))
+
diff --git a/collects/frtime/list.ss b/collects/frtime/list.ss
new file mode 100644
index 0000000000..77188b12db
--- /dev/null
+++ b/collects/frtime/list.ss
@@ -0,0 +1,155 @@
+(module list (lib "frtime.ss" "frtime")
+  
+  (require (lifted (lib "list.ss") quicksort mergesort
+                   fifth sixth seventh eighth
+                   last-pair empty? cons?)
+           (rename (lib "list.ss") empty empty))
+
+  (define first car)
+  (define rest cdr)
+  (define second cadr)
+  (define third caddr)
+  (define fourth cadddr)
+  
+  (define remove
+    (letrec ([rm (case-lambda 
+                   [(item list) (rm item list equal?)]
+                   [(item list equal?)
+                    (let loop ([list list])
+                      (cond
+                        [(null? list) ()]
+                        [(equal? item (car list)) (cdr list)]
+                        [else (cons (car list)
+                                    (loop (cdr list)))]))])])
+      rm))
+  
+  (define remq
+    (lambda (item list)
+      (remove item list eq?)))
+  
+  (define remv
+    (lambda (item list)
+      (remove item list eqv?)))
+  
+  (define remove*
+    (case-lambda
+      [(l r equal?)
+       (cond 
+         [(null? r) null]
+         [else (let ([first-r (car r)])
+                 (let loop ([l-rest l])
+                   (cond 
+                     [(null? l-rest) (cons first-r (remove* l (cdr r) equal?))]
+                     [(equal? (car l-rest) first-r) (remove* l (cdr r) equal?)]
+                     [else (loop (cdr l-rest))])))])]
+      [(l r) (remove* l r equal?)]))
+  
+  (define remq*
+    (lambda (l r)
+      (remove* l r eq?)))
+  
+  (define remv*
+    (lambda (l r)
+      (remove* l r eqv?)))
+  
+  (define mapadd
+    (lambda (f l last)
+      (letrec ((helper
+                (lambda (l)
+                  (cond
+                    [(null? l) (list last)]
+                    [else (cons (f (car l)) (helper (cdr l)))]))))
+        (helper l))))
+  
+  (define foldl
+    (letrec ((fold-one
+              (lambda (f init l)
+                (letrec ((helper
+                          (lambda (init l)
+                            (cond
+                              [(null? l) init]
+                              [else (helper (f (car l) init) (cdr l))]))))
+                  (helper init l))))
+             (fold-n
+              (lambda (f init  l)
+                (cond
+                  [(ormap null? l)
+                   (if (andmap null? l) 
+                       init
+                       (error 'foldl "received non-equal length input lists"))]
+                  [else (fold-n
+                         f
+                         (apply f (mapadd car l init))
+                         (map cdr l))]))))
+      (case-lambda
+        [(f init l) (fold-one f init l)]
+        [(f init l . ls) (fold-n f init (cons l ls))])))
+  
+  (define foldr
+    (letrec ((fold-one
+              (lambda (f init l)
+                (letrec ((helper
+                          (lambda (init l)
+                            (cond
+                              [(null? l) init]
+                              [else (f (car l) (helper init (cdr l)))]))))
+                  (helper init l))))
+             (fold-n
+              (lambda (f init l)
+                (cond
+                  [(ormap null? l)
+                   (if (andmap null? l)
+                       init
+                       (error 'foldr "received non-equal length input lists"))]
+                  [else (apply f
+                               (mapadd car l
+                                       (fold-n f init (map cdr l))))]))))
+      (case-lambda
+        [(f init l) (fold-one f init l)]
+        [(f init l . ls) (fold-n f init (cons l ls))])))
+  
+  (define make-find
+    (lambda (name whole-list?)
+       (lambda (f list)
+         (unless (and (procedure? f)
+                      (procedure-arity-includes? f 1))
+           (raise-type-error name "procedure (arity 1)" f))
+         (let loop ([l list])
+           (cond
+             [(null? l) #f]
+             [(not (pair? l)) 
+              (raise (make-exn:fail
+                      (format "~a: second argument must be a (proper) list; given ~e" name list)
+                      (current-continuation-marks)))]
+             [else (let ([a (car l)])
+                     (if whole-list?
+                         (if (f a)
+                             l
+                             (loop (cdr l)))
+                         (if (pair? a)
+                             (if (f (car a))
+                                 a
+                                 (loop (cdr l)))
+                             (raise-mismatch-error
+                              name
+                              "found a non-pair in the list: "
+                              a))))])))))
+
+  (define assf
+    (let ([a (make-find 'assf #f)])
+       (lambda (f l)
+         (a f l))))
+  
+  (define memf
+    (let ([a (make-find 'memf #t)])
+       (lambda (f l)
+         (a f l))))
+
+  
+  (define (filter f l)
+    (cond
+      [(empty? l) empty]
+      [(f (first l)) (cons (first l) (filter f (rest l)))]
+      [else (filter f (rest l))]))
+  
+  (provide (all-defined) empty))
\ No newline at end of file
diff --git a/collects/frtime/math.ss b/collects/frtime/math.ss
new file mode 100644
index 0000000000..3ddc9e2533
--- /dev/null
+++ b/collects/frtime/math.ss
@@ -0,0 +1,50 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; math.ss: some extra math routines
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(module math (lib "frtime.ss" "frtime")
+  (provide e 
+	  pi 
+	  sqr
+	  sgn conjugate
+	  sinh cosh)
+
+  (define (sqr z) (* z z))
+  
+  ;; circular constants and aliases
+  (define e (exp 1.0)) 
+  (define pi (atan 0 -1))
+  
+  ;; sgn function 
+  (define sgn
+    (lambda (x)
+      (if (exact? x)
+	  (cond
+	   ((< x 0) -1)
+	   ((> x 0)  1)
+	   (else 0))
+	  (cond
+	   ((< x 0.0) -1.0)
+	   ((> x 0.0)  1.0)
+	   (else 0.0)))))
+  
+  ;; complex conjugate
+  (define conjugate
+    (lambda (z)
+      (make-rectangular 
+       (real-part z)
+       (- (imag-part z)))))
+  
+  ;; real hyperbolic functions
+  (define sinh 
+    (lambda (x)
+      (/
+       (- (exp x) (exp (- x)))
+       2.0)))
+  
+  (define cosh
+    (lambda (x)
+      (/
+       (+ (exp x) (exp (- x)))
+       2.0))))
diff --git a/collects/frtime/mymatch.ss b/collects/frtime/mymatch.ss
new file mode 100644
index 0000000000..071ca8d90c
--- /dev/null
+++ b/collects/frtime/mymatch.ss
@@ -0,0 +1,319 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Pattern Matching Syntactic Extensions for Scheme
+;;
+;; Specialized for MzScheme; works with define-struct
+;;
+;; Report bugs to wright@research.nj.nec.com.  The most recent version of
+;; this software can be obtained by anonymous FTP from ftp.nj.nec.com
+;; in file pub/wright/match.tar.Z.  Be sure to set "type binary" when
+;; transferring this file.
+;;
+;; Written by Andrew K. Wright, 1993 (wright@research.nj.nec.com).
+;; Adapted from code originally written by Bruce F. Duba, 1991.
+;;
+;; This software is in the public domain.  Feel free to copy,
+;; distribute, and modify this software as desired.  No warranties
+;; nor guarantees of any kind apply.  Please return any improvements
+;; or bug fixes to wright@research.nj.nec.com so that they may be included
+;; in future releases.
+;;
+;; This macro package extends Scheme with several new expression forms.
+;; Following is a brief summary of the new forms.  See the associated
+;; LaTeX documentation for a full description of their functionality.
+;;
+;;
+;;         match expressions:
+;;
+;; exp ::= ...
+;;       | (match exp clause ...)
+;;       | (match-lambda clause ...)
+;;       | (match-lambda* clause ...)
+;;       | (match-let ((pat exp) ...) body)
+;;       | (match-let* ((pat exp) ...) body)
+;;       | (match-letrec ((pat exp) ...) body)
+;;       | (match-define pat exp)
+;;
+;; clause ::= (pat body) | (pat => exp)
+;;
+;;         patterns:                       matches:
+;;
+;; pat ::= identifier                      anything, and binds identifier
+;;       | _                               anything
+;;       | ()                              the empty list
+;;       | #t                              #t
+;;       | #f                              #f
+;;       | string                          a string
+;;       | number                          a number
+;;       | character                       a character
+;;       | 'sexp                           an s-expression
+;;       | 'symbol                         a symbol (special case of s-expr)
+;;       | (pat_1 ... pat_n)               list of n elements
+;;       | (pat_1 ... pat_n . pat_{n+1})   list of n or more
+;;       | (pat_1 ... pat_n pat_n+1 ooo)   list of n or more, each element
+;;                                           of remainder must match pat_n+1
+;;       | #(pat_1 ... pat_n)              vector of n elements
+;;       | #(pat_1 ... pat_n pat_n+1 ooo)  vector of n or more, each element
+;;                                           of remainder must match pat_n+1
+;;       | #&pat                           box
+;;       | ($ struct-name pat_1 ... pat_n) a structure
+;;       | (and pat_1 ... pat_n)           if all of pat_1 thru pat_n match
+;;       | (or pat_1 ... pat_n)            if any of pat_1 thru pat_n match
+;;       | (not pat_1 ... pat_n)           if all pat_1 thru pat_n don't match
+;;       | (? predicate pat_1 ... pat_n)   if predicate true and all of
+;;                                           pat_1 thru pat_n match
+;;       | (set! identifier)               anything, and binds setter
+;;       | (get! identifier)               anything, and binds getter
+;;       | `qp                             a quasi-pattern
+;;
+;; ooo ::= ...                             zero or more
+;;       | ___                             zero or more
+;;       | ..k                             k or more
+;;       | __k                             k or more
+;;
+;;         quasi-patterns:                 matches:
+;;
+;; qp  ::= ()                              the empty list
+;;       | #t                              #t
+;;       | #f                              #f
+;;       | string                          a string
+;;       | number                          a number
+;;       | character                       a character
+;;       | identifier                      a symbol
+;;       | (qp_1 ... qp_n)                 list of n elements
+;;       | (qp_1 ... qp_n . qp_{n+1})      list of n or more
+;;       | (qp_1 ... qp_n qp_n+1 ooo)      list of n or more, each element
+;;                                           of remainder must match qp_n+1
+;;       | #(qp_1 ... qp_n)                vector of n elements
+;;       | #(qp_1 ... qp_n qp_n+1 ooo)     vector of n or more, each element
+;;                                           of remainder must match qp_n+1
+;;       | #&qp                            box
+;;       | ,pat                            a pattern
+;;       | ,@pat                           a pattern
+;;
+;; The names (quote, quasiquote, unquote, unquote-splicing, ?, _, $,
+;; and, or, not, set!, get!, ..., ___) cannot be used as pattern variables.
+;;
+;; End of user visible/modifiable stuff.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(module mymatch mzscheme
+  (require-for-syntax "private/mkmatch.ss"
+		      (lib "stx.ss" "syntax")
+		      (lib "struct.ss" "syntax"))
+
+  (provide
+   match-fail
+   match
+   match-lambda
+   match-lambda*
+   match-letrec
+   match-let
+   match-let*
+   match-define)
+
+ (define match:version "Version 1.10mz, Feb 5, 1996")
+
+ (define-struct (exn:misc:match exn) (value))
+
+  (define match-fail (gensym 'match-fail))
+  
+  (define match:error
+   (case-lambda
+     ((val) match-fail)
+;      (raise
+;       (make-exn:misc:match
+;         (format "match: no matching clause for ~e" val)
+;         (current-continuation-marks)
+;         val)))
+     ((val expr) match-fail)))
+;      (raise
+;       (make-exn:misc:match
+;         (format "match: no matching clause for ~e: ~s" val expr)
+;         (current-continuation-marks)
+;         val)))))
+
+ (define-syntax parse-pattern
+   ;; NOT A MACRO: this is a macro utility function
+   (lambda (p)
+     (let parse-pattern ([p p])
+       (define (r l) (map parse-pattern (syntax->list l)))
+       (define (i v) (match:syntax-err p (format "illegal use of ~a" v)))
+       (syntax-case* p (_ quote $ ? and or not set! get! quasiquote ... ___) module-or-top-identifier=?
+	 [_ '_]
+	 [(quote x) `(quote ,(syntax-object->datum (syntax x)))]
+	 [(quote . _) (i "quote")]
+	 [($ struct p ...)
+	  (let ([name (syntax struct)])
+	    (unless (identifier? name)
+	      (i "$; not followed by an identifier"))
+	    (let ([info (syntax-local-value name (lambda () #f))])
+	      (unless (struct-declaration-info? info)
+		(i (format "$; `~a' is not the name of a structure type"
+			   (syntax-e name))))
+	      (let ([pred (caddr info)]
+		    [sel (reverse
+			  (let loop ([l (list-ref info 3)])
+			    (if (or (null? l) (not (car l)))
+				null
+				(cons (car l) (loop (cdr l))))))])
+		(unless (= (length sel)
+			   (length (syntax->list (syntax (p ...)))))
+		  (i (format "$; wrong number of fields for `~a'"
+			     (syntax-e name))))
+		`($ ,(cons pred sel) ,@(r (syntax (p ...)))))))]
+	 [($ . _) (i "$")]
+	 [(and p ...)
+	  `(and ,@(r (syntax (p ...))))]
+	 [(and . _) (i "and")]
+	 [(or p ...)
+	  `(or ,@(r (syntax (p ...))))]
+	 [(or . _) (i "or")]
+	 [(not p ...)
+	  `(not ,@(r (syntax (p ...))))]
+	 [(not . _) (i "not")]
+	 [(? pred p ...)
+	  `(? ,(syntax pred) ,@(r (syntax (p ...))))]
+	 [(? . _) (i "?")]
+	 [(set! i)
+	  `(set! ,(syntax i))]
+	 [(set! . _) (i "set!")]
+	 [(get! i)
+	  `(get! ,(syntax i))]
+	 [(get! . _) (i "get!")]
+	 [(quasiquote q)
+	  `(,'quasiquote ,(:ucall parse-quasipattern (syntax q)))]
+	 [(quasiquote . _) (i "quasiquote")]
+	 [(p (... ...))
+	  `(,(parse-pattern (syntax p)) ...)]
+	 [(p ___)
+	  `(,(parse-pattern (syntax p)) ___)]
+	 [(p ..k)
+	  (and (identifier? (syntax ..k))
+	       (let ([s (symbol->string (syntax-e (syntax ..k)))])
+		 (regexp-match re:..k s)))
+	  `(,(parse-pattern (syntax p)) ,(syntax-e (syntax ..k)))]
+	 [(p . rest)
+	  (identifier? (syntax i))
+	  (cons (parse-pattern (syntax p)) (parse-pattern (syntax rest)))]
+	 [i (identifier? (syntax i)) (syntax i)]
+	 [_else
+	  (let ([s (syntax-e p)])
+	    (cond
+	     [(vector? s) (list->vector (map parse-pattern (vector->list s)))]
+	     [(box? s) (box (parse-pattern (unbox s)))]
+	     [else s]))]))))
+
+ (define-syntax parse-quasipattern
+   ;; NOT A MACRO: this is a macro utility function
+   (lambda (p)
+     (define (i v) (match:syntax-err p (format "illegal use of ~a" v)))
+     (let parse-quasipattern ([p p])
+       (syntax-case p (unquote unquote-splicing ...)
+	 [(unquote x) `(,'unquote ,(:ucall parse-pattern (syntax x)))]
+	 [(unquote . _) (i "unquote")]
+	 [(unquote-splicing x) `(,'unquote-splicing ,(:ucall parse-pattern (syntax x)))]
+	 [(unquote-splicing . _) (i "unquote-splicing")]
+	 [(p (... ...))
+	  `(,(parse-quasipattern (syntax p)) ...)]
+	 [(p ..k)
+	  (and (identifier? (syntax ..k))
+	       (let ([s (symbol->string (syntax-e (syntax ..k)))])
+		 (regexp-match re:..k s)))
+	  `(,(parse-quasipattern (syntax p)) ,(syntax-e (syntax ..k)))]
+	 [(i . rest)
+	  (identifier? (syntax i))
+	  (cons (syntax-object->datum (syntax i)) (parse-quasipattern (syntax rest)))]
+         [(qp . rest)
+	  (cons (parse-quasipattern (syntax qp)) (parse-quasipattern (syntax rest)))]
+	 [_else
+	  (let ([s (syntax-e p)])
+	    (cond
+	     [(vector? s) (list->vector (map parse-quasipattern (vector->list s)))]
+	     [(box? s) (box (parse-quasipattern (unbox s)))]
+	     [else s]))]))))
+
+ 
+
+
+
+ (define-syntax match
+   (lambda (stx)
+     (syntax-case stx ()
+       [(_ exp clause ...)
+	(with-syntax ([body
+		       (datum->syntax-object
+			(quote-syntax here)
+			(genmatch
+			 (quote-syntax mv)
+			 (map
+			  (lambda (c)
+			    (syntax-case c (=>)
+			      [(p (=> i) e e1 ...)
+			       `(,(:ucall parse-pattern (syntax p))
+				 (=> ,(syntax i))
+				 ,@(syntax->list (syntax (e e1 ...))))]
+			      [(p e e1 ...)
+			       `(,(:ucall parse-pattern (syntax p))
+				 ,@(syntax->list (syntax (e e1 ...))))]
+			      [_else
+			       (match:syntax-err
+				c
+				"bad match clause")]))
+			  (syntax->list (syntax (clause ...))))
+			 stx)
+			stx)])
+	  (syntax/loc stx
+	    (let ([mv exp])
+	      body)))])))
+
+ (define-syntax match-lambda
+   (lambda (stx)
+     (syntax-case stx ()
+       [(_ clause ...)
+	(syntax/loc stx (lambda (x) (match x clause ...)))])))
+
+ (define-syntax match-lambda*
+   (lambda (stx)
+     (syntax-case stx ()
+       [(_ clause ...)
+	(syntax/loc stx (lambda x (match x clause ...)))])))
+
+ (define-syntax match-let*
+   (lambda (stx)
+     (syntax-case stx ()
+       [(_ () body1 body ...)
+	(syntax/loc stx (begin body1 body ...))]
+       [(_ ([pat1 exp1] [pat exp] ...) body1 body ...)
+	(syntax/loc stx (match exp1 
+			  [pat1 (match-let* ([pat exp] ...) 
+					    body1 body ...)]))])))
+ (define-syntax match-let
+   (lambda (stx)
+     (syntax-case stx ()
+       [(_ ([pat exp] ...) body1 body ...)	
+	(syntax/loc stx (match-let* ([(pat ...) (list exp ...)]) 
+				    body1 body ...))])))
+
+ (define-syntax match-letrec
+   (lambda (stx)
+     (syntax-case stx ()
+       [(_ ([pat exp] ...) body1 body ...)
+	(datum->syntax-object
+	 (quote-syntax here)
+	 (genletrec 
+	  (map (lambda (p) (:ucall parse-pattern p)) (syntax->list (syntax (pat ...))))
+	  (syntax->list (syntax (exp ...)))
+	  (syntax->list (syntax (body1 body ...)))
+	  stx)
+	 stx)])))
+
+ (define-syntax match-define
+   (lambda (stx)
+     (syntax-case stx ()
+       [(_ pat exp)
+	(datum->syntax-object
+	 (quote-syntax here)
+	 (gendefine (:ucall parse-pattern (syntax pat))
+		    (syntax exp)
+		    stx)
+	 stx)]))))
diff --git a/collects/frtime/private/mkmatch.ss b/collects/frtime/private/mkmatch.ss
new file mode 100644
index 0000000000..c8ab83e80d
--- /dev/null
+++ b/collects/frtime/private/mkmatch.ss
@@ -0,0 +1,1138 @@
+
+;; Utilities for match
+
+(module mkmatch mzscheme
+  (provide genmatch genletrec gendefine pattern-var? match:syntax-err re:..k :ucall)
+
+ (define re:..k (regexp "[.][.][0-9]+"))
+
+ (define match:disjoint-predicates
+   (cons
+    'null
+    '(pair? symbol? boolean? number? string? char? procedure? vector? box?)))
+
+ (define match:syntax-err (lambda (obj msg . detail)
+			    (apply
+			     raise-syntax-error
+			     'match
+			     msg
+			     obj
+			     detail)))
+  (define genmatch
+    (lambda (x clauses match-expr)
+      (let* ((length>= (gensym))
+	     (eb-errf (error-maker match-expr))
+	     (blist (car eb-errf))
+	     (plist
+	      (map
+	       (lambda (c)
+		 (let* ((x (bound (validate-pattern (car c)) match-expr))
+			(p (car x))
+			(bv (cadr x))
+			(bindings (caddr x))
+			(code (gensym))
+			(fail
+			 (and (pair? (cdr c))
+			      (pair? (cadr c))
+			      (eq? (caadr c) '=>)
+			      (identifier? (cadadr c))
+			      (pair? (cdadr c))
+			      (null? (cddadr c))
+			      (pair? (cddr c))
+			      (cadadr c)))
+			(bv2 (if fail (cons fail bv) bv))
+			(body (if fail (cddr c) (cdr c))))
+		   (set! blist
+			 (cons
+			  `(,code (lambda ,bv2 ,@body))
+			  (append bindings blist)))
+		   (list p code bv (and fail (gensym)) #f)))
+	       clauses))
+	     (code
+	      (gen x '() plist (cdr eb-errf) length>= (gensym))))
+	(unreachable plist match-expr)
+	(inline-let
+	 `(let ((,length>=
+		 (lambda (n) (lambda (l) (>= (length l) n))))
+		,@blist)
+	    ,code)))))
+
+  (define genletrec
+    (lambda (pat exp body match-expr)
+      (let* ((length>= (gensym))
+	     (eb-errf (error-maker match-expr))
+	     (x (bound (validate-pattern pat) match-expr))
+	     (p (car x))
+	     (bv (cadr x))
+	     (bindings (caddr x))
+	     (code (gensym))
+	     (plist (list (list p code bv #f #f)))
+	     (x (gensym))
+	     (m (gen x '() plist (cdr eb-errf) length>= (gensym)))
+	     (gs (map (lambda (_) (gensym)) bv)))
+	(unreachable plist match-expr)
+	`(letrec ((,length>=
+		   (lambda (n) (lambda (l) (>= (length l) n))))
+		  ,@(map (lambda (v) `(,v #f)) bv)
+		  (,x (list ,@exp))
+		  (,code
+		   (lambda ,gs
+		     ,@(map (lambda (v g) `(set! ,v ,g)) bv gs)
+		     ,@body))
+		  ,@bindings
+		  ,@(car eb-errf))
+	   ,m))))
+
+  (define gendefine
+    (lambda (pat exp match-expr)
+      (let* ((length>= (gensym))
+	     (eb-errf (error-maker match-expr))
+	     (x (bound (validate-pattern pat) match-expr))
+	     (p (car x))
+	     (bv (cadr x))
+	     (bindings (caddr x))
+	     (code (gensym))
+	     (plist (list (list p code bv #f #f)))
+	     (x (gensym))
+	     (m (gen x '() plist (cdr eb-errf) length>= (gensym)))
+	     (gs (map (lambda (_) (gensym)) bv)))
+	(unreachable plist match-expr)
+	`(begin
+	   ,@(map (lambda (v) `(define ,v #f)) bv)
+	   ,(inline-let
+	     `(let ((,length>=
+		     (lambda (n) (lambda (l) (>= (length l) n))))
+		    (,x ,exp)
+		    (,code
+		     (lambda ,gs
+		       ,@(map (lambda (v g) `(set! ,v ,g)) bv gs)
+		       (cond (#f #f))))
+		    ,@bindings
+		    ,@(car eb-errf))
+		,m))))))
+
+  (define pattern-var?
+    (lambda (x)
+      (and (identifier? x)
+	   (not (dot-dot-k? x)))))
+
+  (define dot-dot-k?
+    (lambda (s)
+      (and (symbol? s)
+	   (if (memq s '(... ___))
+	       0
+	       (let* ((s (symbol->string s)) (n (string-length s)))
+		 (and (<= 3 n)
+		      (memq (string-ref s 0) '(#\. #\_))
+		      (memq (string-ref s 1) '(#\. #\_))
+		      (andmap
+		       char-numeric?
+		       (string->list (substring s 2 n)))
+		      (string->number (substring s 2 n))))))))
+
+  (define error-maker
+    (lambda (match-expr)
+      (cons
+       '()
+       (lambda (x) `(match:error ,x)))))
+
+  (define unreachable
+    (lambda (plist match-expr)
+      (for-each
+       (lambda (x)
+	 (if (not (car (cddddr x)))
+	     (fprintf
+	      (current-error-port)
+	      "Warning: unreachable pattern ~e in ~e~n"
+	      ;; This (s->d (d->s _)) pattern is used in case
+	      ;;  the value is a mixture of syntax and non-syntax
+	      (syntax-object->datum (datum->syntax-object #f (car x)))
+	      (syntax-object->datum (datum->syntax-object #f match-expr)))))
+       plist)))
+  
+  (define validate-pattern
+    (lambda (pattern)
+      (letrec ((simple?
+		(lambda (x)
+		  (or (string? x)
+		      (boolean? x)
+		      (char? x)
+		      (number? x)
+		      (null? x))))
+	       (ordinary
+		(lambda (p)
+		  (let ((g204
+			 (lambda (x y)
+			   (cons (ordinary x) (ordinary y)))))
+		    (if (simple? p)
+			((lambda (p) p) p)
+			(if (equal? p '_)
+			    ((lambda () '_))
+			    (if (pattern-var? p)
+				((lambda (p) p) p)
+				(if (pair? p)
+				    (if (equal? (car p) 'quasiquote)
+					(if (and (pair? (cdr p))
+						 (null? (cddr p)))
+					    ((lambda (p) (quasi p)) (cadr p))
+					    (g204 (car p) (cdr p)))
+					(if (equal? (car p) 'quote)
+					    (if (and (pair? (cdr p))
+						     (null? (cddr p)))
+						((lambda (p) p) p)
+						(g204 (car p) (cdr p)))
+					    (if (equal? (car p) '?)
+						(if (and (pair? (cdr p))
+							 (list? (cddr p)))
+						    ((lambda (pred ps)
+						       `(?
+							 ,pred
+							 ,@(map ordinary ps)))
+						     (cadr p)
+						     (cddr p))
+						    (g204 (car p) (cdr p)))
+						(if (equal? (car p) 'and)
+						    (if (and (list? (cdr p))
+							     (pair? (cdr p)))
+							((lambda (ps)
+							   `(and ,@(map ordinary ps)))
+							 (cdr p))
+							(g204 (car p) (cdr p)))
+						    (if (equal? (car p) 'or)
+							(if (and (list? (cdr p))
+								 (pair? (cdr p)))
+							    ((lambda (ps)
+							       `(or ,@(map
+								       ordinary
+								       ps)))
+							     (cdr p))
+							    (g204 (car p) (cdr p)))
+							(if (equal? (car p) 'not)
+							    (if (and (list? (cdr p))
+								     (pair? (cdr p)))
+								((lambda (ps)
+								   `(not
+								     ,@(map ordinary ps)))
+								 (cdr p))
+								(g204 (car p) (cdr p)))
+							    (if (equal? (car p) '$)
+								(if (and (pair? (cdr p))
+									 '(symbol? (cadr p)) ; skip this test - not a symbol anymore
+									 (list? (cddr p)))
+								    ((lambda (r ps)
+								       `($
+									 ,r
+									 ,@(map
+									    ordinary
+									    ps)))
+								     (cadr p)
+								     (cddr p))
+								    (g204 (car p) (cdr p)))
+								(if (equal? (car p) 'set!)
+								    (if (and (pair? (cdr p))
+									     (pattern-var?
+									      (cadr p))
+									     (null?
+									      (cddr p)))
+									((lambda (p) p) p)
+									(g204
+									 (car p)
+									 (cdr p)))
+								    (if (equal?
+									 (car p)
+									 'get!)
+									(if (and (pair?
+										  (cdr p))
+										 (pattern-var?
+										  (cadr p))
+										 (null?
+										  (cddr p)))
+									    ((lambda (p) p) p)
+									    (g204
+									     (car p)
+									     (cdr p)))
+									(if (equal?
+									     (car p)
+									     'unquote)
+									    (g204
+									     (car p)
+									     (cdr p))
+									    (if (equal?
+										 (car p)
+										 'unquote-splicing)
+										(g204
+										 (car p)
+										 (cdr p))
+										(if (and (pair?
+											  (cdr p))
+											 (dot-dot-k?
+											  (cadr
+											   p))
+											 (null?
+											  (cddr
+											   p)))
+										    ((lambda (p ddk)
+										       `(,(ordinary
+											   p)
+											 ,ddk))
+										     (car p)
+										     (cadr p))
+										    (g204
+										     (car p)
+										     (cdr
+										      p))))))))))))))
+				    (if (vector? p)
+					((lambda (p)
+					   (let* ((pl (vector->list p))
+						  (rpl (reverse pl)))
+					     (apply
+					      vector
+					      (if (and (not (null? rpl))
+						       (dot-dot-k? (car rpl)))
+						  (reverse
+                                                   (cons
+                                                    (car rpl)
+                                                    (map ordinary (cdr rpl))))
+						  (map ordinary pl)))))
+					 p)
+					(if (box? p)
+					    ((lambda (p)
+					       (box (ordinary (unbox p))))
+					     p)
+					    ((lambda ()
+					       (match:syntax-err
+                                                pattern
+                                                "syntax error in pattern"))))))))))))
+	       (quasi
+		(lambda (p)
+		  (let ((g193
+			 (lambda (x y) (cons (quasi x) (quasi y)))))
+		    (if (simple? p)
+			p
+			(if (symbol? p)
+			    `',p
+			    (if (pair? p)
+				(if (equal? (car p) 'unquote)
+				    (if (and (pair? (cdr p))
+					     (null? (cddr p)))
+                                        ((lambda (p) (ordinary p)) (cadr p))
+                                        (g193 (car p) (cdr p)))
+				    (if (and (pair? (car p))
+					     (equal?
+					      (caar p)
+					      'unquote-splicing)
+					     (pair? (cdar p))
+					     (null? (cddar p)))
+                                        (if (null? (cdr p))
+					    ((lambda (p) (ordinary p)) (cadar p))
+					    ((lambda (p y)
+					       (append (ordlist p) (quasi y)))
+					     (cadar p)
+					     (cdr p)))
+                                        (if (and (pair? (cdr p))
+                                                 (dot-dot-k? (cadr p))
+                                                 (null? (cddr p)))
+					    ((lambda (p ddk) `(,(quasi p) ,ddk))
+					     (car p)
+					     (cadr p))
+					    (g193 (car p) (cdr p)))))
+				(if (vector? p)
+				    ((lambda (p)
+				       (let* ((pl (vector->list p))
+					      (rpl (reverse pl)))
+					 (apply
+					  vector
+					  (if (dot-dot-k? (car rpl))
+                                              (reverse
+					       (cons
+						(car rpl)
+						(map quasi (cdr rpl))))
+                                              (map ordinary pl)))))
+				     p)
+				    (if (box? p)
+                                        ((lambda (p) (box (quasi (unbox p))))
+                                         p)
+                                        ((lambda ()
+                                           (match:syntax-err
+					    pattern
+					    "syntax error in pattern")))))))))))
+	       (ordlist
+		(lambda (p)
+		  (cond
+		   ((null? p) '())
+		   ((pair? p)
+		    (cons (ordinary (car p)) (ordlist (cdr p))))
+		   (else
+		    (match:syntax-err
+		     pattern
+		     "invalid use of unquote-splicing in pattern"))))))
+	(ordinary pattern))))
+
+  (define bound
+    (lambda (pattern match-expr)
+      (letrec ((pred-bodies '())
+	       (bound
+		(lambda (p a k)
+		  (cond
+		   ((eq? '_ p) (k p a))
+		   ((identifier? p)
+		    (let ([dup (check-duplicate-identifier (cons p a))])
+		      (if dup
+			  (match:syntax-err
+			   match-expr
+			   "duplicate variable in pattern"
+			   dup)))
+		    (k p (cons p a)))
+		   ((and (pair? p) (eq? 'quote (car p))) (k p a))
+		   ((and (pair? p) (eq? '? (car p)))
+		    (cond
+		     ((not (null? (cddr p)))
+		      (bound `(and (? ,(cadr p)) ,@(cddr p)) a k))
+		     ((or (not (identifier? (cadr p))) (memq (cadr p) a))
+		      (let ((g (gensym)))
+			(set! pred-bodies
+			      (cons `(,g ,(cadr p)) pred-bodies))
+			(k `(? ,g) a)))
+		     (else (k p a))))
+		   ((and (pair? p) (eq? 'and (car p)))
+		    (bound*
+		     (cdr p)
+		     a
+		     (lambda (p a) (k `(and ,@p) a))))
+		   ((and (pair? p) (eq? 'or (car p)))
+		    (bound
+		     (cadr p)
+		     a
+		     (lambda (first-p first-a)
+		       (let or* ((plist (cddr p))
+				 (k
+				  (lambda (plist)
+				    (k
+				     `(or ,first-p ,@plist)
+				     first-a))))
+			 (if (null? plist)
+			     (k plist)
+			     (bound
+			      (car plist)
+			      a
+			      (lambda (car-p car-a)
+				(if (not (permutation car-a first-a))
+				    (match:syntax-err
+				     pattern
+				     "variables of or-pattern differ in"))
+				(or*
+				 (cdr plist)
+				 (lambda (cdr-p)
+				   (k (cons car-p cdr-p)))))))))))
+		   ((and (pair? p) (eq? 'not (car p)))
+		    (cond
+		     ((not (null? (cddr p)))
+		      (bound `(not (or ,@(cdr p))) a k))
+		     (else
+		      (bound
+		       (cadr p)
+		       a
+		       (lambda (p2 a2)
+			 (if (not (permutation a a2))
+			     (match:syntax-err
+			      p
+			      "no variables allowed in"))
+			 (k `(not ,p2) a))))))
+		   ((and (pair? p)
+			 (pair? (cdr p))
+			 (dot-dot-k? (cadr p)))
+		    (bound
+		     (car p)
+		     a
+		     (lambda (q b)
+		       (let ((bvars (find-prefix b a)))
+			 (k
+			  `(,q
+			    ,(cadr p)
+			    ,bvars
+			    ,(gensym)
+			    ,(gensym)
+			    ,(map (lambda (_) (gensym)) bvars))
+			  b)))))
+		   ((and (pair? p) (eq? '$ (car p)))
+		    (bound*
+		     (cddr p)
+		     a
+		     (lambda (p1 a) (k `($ ,(cadr p) ,@p1) a))))
+		   ((and (pair? p) (eq? 'set! (car p)))
+		    (if (memq (cadr p) a)
+			(k p a)
+			(k p (cons (cadr p) a))))
+		   ((and (pair? p) (eq? 'get! (car p)))
+		    (if (memq (cadr p) a)
+			(k p a)
+			(k p (cons (cadr p) a))))
+		   ((pair? p)
+		    (bound
+		     (car p)
+		     a
+		     (lambda (car-p a)
+		       (bound
+			(cdr p)
+			a
+			(lambda (cdr-p a)
+			  (k (cons car-p cdr-p) a))))))
+		   ((vector? p)
+		    (boundv
+		     (vector->list p)
+		     a
+		     (lambda (pl a) (k (list->vector pl) a))))
+		   ((box? p)
+		    (bound (unbox p) a (lambda (p a) (k (box p) a))))
+		   (else (k p a)))))
+	       (boundv
+		(lambda (plist a k)
+		  (let ((g187 (lambda () (k plist a))))
+		    (if (pair? plist)
+			(if (and (pair? (cdr plist))
+				 (dot-dot-k? (cadr plist))
+				 (null? (cddr plist)))
+			    ((lambda () (bound plist a k)))
+			    (if (null? plist)
+				(g187)
+				((lambda (x y)
+				   (bound
+				    x
+				    a
+				    (lambda (car-p a)
+				      (boundv
+				       y
+				       a
+				       (lambda (cdr-p a)
+					 (k (cons car-p cdr-p) a))))))
+				 (car plist)
+				 (cdr plist))))
+			(if (null? plist)
+			    (g187)
+			    (match:syntax-err
+			     "boundv"
+			     plist))))))
+	       (bound*
+		(lambda (plist a k)
+		  (if (null? plist)
+		      (k plist a)
+		      (bound
+		       (car plist)
+		       a
+		       (lambda (car-p a)
+			 (bound*
+			  (cdr plist)
+			  a
+			  (lambda (cdr-p a)
+			    (k (cons car-p cdr-p) a))))))))
+	       (find-prefix
+		(lambda (b a)
+		  (if (eq? b a)
+		      '()
+		      (cons (car b) (find-prefix (cdr b) a)))))
+	       (permutation
+		(lambda (p1 p2)
+		  (and (= (length p1) (length p2))
+		       (andmap (lambda (x1) (memq x1 p2)) p1)))))
+	(bound
+	 pattern
+	 '()
+	 (lambda (p a) (list p (reverse a) pred-bodies))))))
+
+  (define inline-let
+    (lambda (let-exp)
+      (letrec ((occ
+		(lambda (x e)
+		  (let loop ((e e))
+		    (cond
+		     ((pair? e) (+ (loop (car e)) (loop (cdr e))))
+		     ((eq? x e) 1)
+		     (else 0)))))
+	       (subst
+		(lambda (e old new)
+		  (let loop ((e e))
+		    (cond
+		     ((pair? e) (cons (loop (car e)) (loop (cdr e))))
+		     ((eq? old e) new)
+		     (else e)))))
+	       (const?
+		(lambda (sexp)
+		  (or (symbol? sexp)
+		      (boolean? sexp)
+		      (string? sexp)
+		      (char? sexp)
+		      (number? sexp)
+		      (null? sexp)
+		      (and (pair? sexp)
+			   (eq? (car sexp) 'quote)
+			   (pair? (cdr sexp))
+			   (symbol? (cadr sexp))
+			   (null? (cddr sexp))))))
+	       (isval?
+		(lambda (sexp)
+		  (or (const? sexp)
+		      (and (pair? sexp)
+			   (memq
+			    (car sexp)
+			    '(lambda quote
+			       match-lambda
+			       match-lambda*))))))
+	       (small?
+		(lambda (sexp)
+		  (or (const? sexp)
+		      (and (pair? sexp)
+			   (eq? (car sexp) 'lambda)
+			   (pair? (cdr sexp))
+			   (pair? (cddr sexp))
+			   (const? (caddr sexp))
+			   (null? (cdddr sexp)))))))
+	(let loop ((b (cadr let-exp))
+		   (new-b '())
+		   (e (caddr let-exp)))
+	  (cond
+	   ((null? b)
+	    (if (null? new-b) e `(let ,(reverse new-b) ,e)))
+	   ((isval? (cadr (car b)))
+	    (let* ((x (caar b)) (n (occ x e)))
+	      (cond
+	       ((= 0 n) (loop (cdr b) new-b e))
+	       ((or (= 1 n) (small? (cadr (car b))))
+		(loop (cdr b) new-b (subst e x (cadr (car b)))))
+	       (else (loop (cdr b) (cons (car b) new-b) e)))))
+	   (else (loop (cdr b) (cons (car b) new-b) e)))))))
+
+  (define gen
+    (lambda (x sf plist erract length>= eta)
+      (if (null? plist)
+	  (erract x)
+	  (let* ((v '())
+		 (val (lambda (x) (cdr (assq x v))))
+		 (fail
+		  (lambda (sf)
+		    (gen x sf (cdr plist) erract length>= eta)))
+		 (success
+		  (lambda (sf)
+		    (set-car! (cddddr (car plist)) #t)
+		    (let* ((code (cadr (car plist)))
+			   (bv (caddr (car plist)))
+			   (fail-sym (cadddr (car plist))))
+		      (if fail-sym
+			  (let ((ap `(,code ,fail-sym ,@(map val bv))))
+			    `(call/ec
+			      (lambda (,fail-sym)
+				(let ((,fail-sym
+				       (lambda ()
+					 (call-with-values
+					  (lambda () ,(fail sf))
+					  ,fail-sym))))
+				  ,ap))))
+			  `(,code ,@(map val bv)))))))
+	    (let next ((p (caar plist))
+		       (e x)
+		       (sf sf)
+		       (kf fail)
+		       (ks success))
+	      (cond
+	       ((eq? '_ p) (ks sf))
+	       ((identifier? p) (set! v (cons (cons p e) v)) (ks sf))
+	       ((null? p) (emit `(null? ,e) sf kf ks))
+	       ((string? p) (emit `(equal? ,e ,p) sf kf ks))
+	       ((boolean? p) (emit `(equal? ,e ,p) sf kf ks))
+	       ((char? p) (emit `(equal? ,e ,p) sf kf ks))
+	       ((number? p) (emit `(equal? ,e ,p) sf kf ks))
+	       ((and (pair? p) (eq? 'quote (car p)))
+		(emit `(equal? ,e ,p) sf kf ks))
+	       ((and (pair? p) (eq? '? (car p)))
+		(let ((tst `(,(cadr p) ,e))) (emit tst sf kf ks)))
+	       ((and (pair? p) (eq? 'and (car p)))
+		(let loop ((p (cdr p)) (sf sf))
+		  (if (null? p)
+		      (ks sf)
+		      (next
+		       (car p)
+		       e
+		       sf
+		       kf
+		       (lambda (sf) (loop (cdr p) sf))))))
+	       ((and (pair? p) (eq? 'or (car p)))
+		(let ((or-v v))
+		  (let loop ((p (cdr p)) (sf sf))
+		    (if (null? p)
+			(kf sf)
+			(begin
+			  (set! v or-v)
+			  (next
+			   (car p)
+			   e
+			   sf
+			   (lambda (sf) (loop (cdr p) sf))
+			   ks))))))
+	       ((and (pair? p) (eq? 'not (car p)))
+		(next (cadr p) e sf ks kf))
+	       ((and (pair? p) (eq? '$ (car p)))
+		(let* ((info (cadr p))
+		       (fields (cdr p))
+		       (rlen (length fields)))
+		  (emit
+		   `(,(car info) ,e)
+		   sf
+		   kf
+		   (let rloop ((n 1))
+		     (lambda (sf)
+		       (if (= n rlen)
+			   (ks sf)
+			   (next
+			    (list-ref fields n)
+			    `(,(list-ref info n) ,e)
+			    sf
+			    kf
+			    (rloop (+ 1 n)))))))))
+	       ((and (pair? p) (eq? 'set! (car p)))
+		(set! v (cons (cons (cadr p) (setter e p)) v))
+		(ks sf))
+	       ((and (pair? p) (eq? 'get! (car p)))
+		(set! v (cons (cons (cadr p) (getter e p)) v))
+		(ks sf))
+	       ((and (pair? p) (pair? (cdr p)) (dot-dot-k? (cadr p)))
+		(emit
+		 `(list? ,e)
+		 sf
+		 kf
+		 (lambda (sf)
+		   (let* ((k (dot-dot-k? (cadr p)))
+			  (ks
+			   (lambda (sf)
+			     (let ((bound (list-ref p 2)))
+			       (cond
+				((eq? (car p) '_) (ks sf))
+				((null? bound)
+				 (let* ((ptst
+					 (next
+					  (car p)
+					  eta
+					  sf
+					  (lambda (sf) #f)
+					  (lambda (sf) #t)))
+					(tst
+					 (if (and (pair? ptst)
+						  (symbol? (car ptst))
+						  (pair? (cdr ptst))
+						  (eq? eta (cadr ptst))
+						  (null? (cddr ptst)))
+					     (car ptst)
+					     `(lambda (,eta) ,ptst))))
+				   (assm
+				    `(andmap ,tst ,e)
+				    (kf sf)
+				    (ks sf))))
+				((and (symbol? (car p))
+				      (equal? (list (car p)) bound))
+				 (next (car p) e sf kf ks))
+				(else
+				 (let* ((gloop (list-ref p 3))
+					(ge (list-ref p 4))
+					(fresh (list-ref p 5))
+					(p1
+					 (next
+					  (car p)
+					  `(car ,ge)
+					  sf
+					  kf
+					  (lambda (sf)
+					    `(,gloop
+					      (cdr ,ge)
+					      ,@(map
+						 (lambda (b f)
+						   `(cons ,(val b) ,f))
+						 bound
+						 fresh))))))
+				   (set! v
+					 (append
+					  (map
+					   cons
+					   bound
+					   (map
+					    (lambda (x) `(reverse ,x))
+					    fresh))
+					  v))
+				   `(let ,gloop
+				      ((,ge ,e)
+				       ,@(map
+					  (lambda (x) `(,x '()))
+					  fresh))
+				      (if (null? ,ge)
+					  ,(ks sf)
+					  ,p1)))))))))
+		     (case k
+		       ((0) (ks sf))
+		       ((1) (emit `(pair? ,e) sf kf ks))
+		       (else (emit `((,length>= ,k) ,e) sf kf ks)))))))
+	       ((pair? p)
+		(emit
+		 `(pair? ,e)
+		 sf
+		 kf
+		 (lambda (sf)
+		   (next
+		    (car p)
+		    (add-a e)
+		    sf
+		    kf
+		    (lambda (sf) (next (cdr p) (add-d e) sf kf ks))))))
+	       ((and (vector? p)
+		     (>= (vector-length p) 6)
+		     (dot-dot-k?
+		      (vector-ref p (- (vector-length p) 5))))
+		(let* ((vlen (- (vector-length p) 6))
+		       (k (dot-dot-k? (vector-ref p (+ vlen 1))))
+		       (minlen (+ vlen k))
+		       (bound (vector-ref p (+ vlen 2))))
+		  (emit
+		   `(vector? ,e)
+		   sf
+		   kf
+		   (lambda (sf)
+		     (assm
+		      `(>= (vector-length ,e) ,minlen)
+		      (kf sf)
+		      ((let vloop ((n 0))
+			 (lambda (sf)
+			   (cond
+			    ((not (= n vlen))
+			     (next
+			      (vector-ref p n)
+			      `(vector-ref ,e ,n)
+			      sf
+			      kf
+			      (vloop (+ 1 n))))
+			    ((eq? (vector-ref p vlen) '_) (ks sf))
+			    (else
+			     (let* ((gloop (vector-ref p (+ vlen 3)))
+				    (ind (vector-ref p (+ vlen 4)))
+				    (fresh (vector-ref p (+ vlen 5)))
+				    (p1
+				     (next
+				      (vector-ref p vlen)
+				      `(vector-ref ,e ,ind)
+				      sf
+				      kf
+				      (lambda (sf)
+					`(,gloop
+					  (- ,ind 1)
+					  ,@(map
+					     (lambda (b f)
+					       `(cons ,(val b) ,f))
+					     bound
+					     fresh))))))
+			       (set! v
+				     (append (map cons bound fresh) v))
+			       `(let ,gloop
+				  ((,ind (- (vector-length ,e) 1))
+				   ,@(map (lambda (x) `(,x '())) fresh))
+				  (if (> ,minlen ,ind)
+				      ,(ks sf)
+				      ,p1)))))))
+		       sf))))))
+	       ((vector? p)
+		(let ((vlen (vector-length p)))
+		  (emit
+		   `(vector? ,e)
+		   sf
+		   kf
+		   (lambda (sf)
+		     (emit
+		      `(equal? (vector-length ,e) ,vlen)
+		      sf
+		      kf
+		      (let vloop ((n 0))
+			(lambda (sf)
+			  (if (= n vlen)
+			      (ks sf)
+			      (next
+			       (vector-ref p n)
+			       `(vector-ref ,e ,n)
+			       sf
+			       kf
+			       (vloop (+ 1 n)))))))))))
+	       ((box? p)
+		(emit
+		 `(box? ,e)
+		 sf
+		 kf
+		 (lambda (sf) (next (unbox p) `(unbox ,e) sf kf ks))))
+	       (else
+		(display "FATAL ERROR IN PATTERN MATCHER")
+		(newline)
+		(error #f "THIS NEVER HAPPENS"))))))))
+
+  (define emit
+    (lambda (tst sf kf ks)
+      (cond
+       ((in tst sf) (ks sf))
+       ((in `(not ,tst) sf) (kf sf))
+       (else
+	(let* ((e (cadr tst))
+	       (implied
+		(cond
+		 ((eq? (car tst) 'equal?)
+		  (let ((p (caddr tst)))
+		    (cond
+		     ((string? p) `((string? ,e)))
+		     ((boolean? p) `((boolean? ,e)))
+		     ((char? p) `((char? ,e)))
+		     ((number? p) `((number? ,e)))
+		     ((and (pair? p) (eq? 'quote (car p)))
+		      `((symbol? ,e)))
+		     (else '()))))
+		 ((eq? (car tst) 'null?) `((list? ,e)))
+		 (else '())))
+	       (not-imp
+		(case (car tst)
+		  ((list?) `((not (null? ,e))))
+		  (else '())))
+	       (s (ks (cons tst (append implied sf))))
+	       (k (kf (cons `(not ,tst) (append not-imp sf)))))
+	  (assm tst k s))))))
+
+  (define assm
+    (lambda (tst f s)
+      (cond
+       ((equal? s f) s)
+       ((and (eq? s #t) (eq? f #f)) tst)
+       ((and (eq? (car tst) 'pair?)
+	     #f ;; <<<<<<<<< Change to #t if crashing is ok!
+	     (memq (car f) '(cond match:error))
+	     (guarantees s (cadr tst)))
+	s)
+       ((and (pair? s) (eq? (car s) 'if) (equal? (cadddr s) f))
+	(if (eq? (car (cadr s)) 'and)
+	    `(if (and ,tst ,@(cdr (cadr s))) ,(caddr s) ,f)
+	    `(if (and ,tst ,(cadr s)) ,(caddr s) ,f)))
+       ((and #f
+	     (pair? s)
+	     (equal? (car s) 'let)
+	     (pair? (cdr s))
+	     (pair? (cadr s))
+	     (pair? (caadr s))
+	     (pair? (cdaadr s))
+	     (pair? (car (cdaadr s)))
+	     (equal? (caar (cdaadr s)) 'lambda)
+	     (pair? (cdar (cdaadr s)))
+	     (null? (cadar (cdaadr s)))
+	     (pair? (cddar (cdaadr s)))
+	     (null? (cdddar (cdaadr s)))
+	     (null? (cdr (cdaadr s)))
+	     (null? (cdadr s))
+	     (pair? (cddr s))
+	     (null? (cdddr s))
+	     (equal? (caddar (cdaadr s)) f))
+	(let ((fail (caaadr s)) (s2 (caddr s)))
+	  `(let ((,fail (lambda () ,f))) ,(assm tst `(,fail) s2))))
+       (else `(if ,tst ,s ,f)))))
+
+  (define guarantees
+    (lambda (code x)
+      (let ((a (add-a x)) (d (add-d x)))
+	(let loop ((code code))
+	  (cond
+	   ((not (pair? code)) #f)
+	   ((memq (car code) '(cond match:error)) #t)
+	   ((or (equal? code a) (equal? code d)) #t)
+	   ((eq? (car code) 'if)
+	    (or (loop (cadr code))
+		(and (loop (caddr code)) (loop (cadddr code)))))
+	   ((eq? (car code) 'lambda) #f)
+	   ((and (eq? (car code) 'let) (symbol? (cadr code))) #f)
+	   (else (or (loop (car code)) (loop (cdr code)))))))))
+
+  (define in
+    (lambda (e l)
+      (or (member e l)
+	  (and (eq? (car e) 'list?)
+	       (or (member `(null? ,(cadr e)) l)
+		   (member `(pair? ,(cadr e)) l)))
+	  (and (eq? (car e) 'not)
+	       (let* ((srch (cadr e))
+		      (const-class (equal-test? srch)))
+		 (cond
+		  (const-class
+		   (let mem ((l l))
+		     (if (null? l)
+			 #f
+			 (let ((x (car l)))
+			   (or (and (equal? (cadr x) (cadr srch))
+				    (disjoint? x)
+				    (not (equal? const-class (car x))))
+			       (equal?
+				x
+				`(not (,const-class ,(cadr srch))))
+			       (and (equal? (cadr x) (cadr srch))
+				    (equal-test? x)
+				    (not
+				     (equal? (caddr srch) (caddr x))))
+			       (mem (cdr l)))))))
+		  ((disjoint? srch)
+		   (let mem ((l l))
+		     (if (null? l)
+			 #f
+			 (let ((x (car l)))
+			   (or (and (equal? (cadr x) (cadr srch))
+				    (disjoint? x)
+				    (not (equal? (car x) (car srch))))
+			       (mem (cdr l)))))))
+		  ((eq? (car srch) 'list?)
+		   (let mem ((l l))
+		     (if (null? l)
+			 #f
+			 (let ((x (car l)))
+			   (or (and (equal? (cadr x) (cadr srch))
+				    (disjoint? x)
+				    (not
+				     (memq
+				      (car x)
+				      '(list? pair? null?))))
+			       (mem (cdr l)))))))
+		  (else #f)))))))
+
+  (define equal-test?
+    (lambda (tst)
+      (and (eq? (car tst) 'equal?)
+	   (let ((p (caddr tst)))
+	     (cond
+	      ((string? p) 'string?)
+	      ((boolean? p) 'boolean?)
+	      ((char? p) 'char?)
+	      ((number? p) 'number?)
+	      ((and (pair? p)
+		    (pair? (cdr p))
+		    (null? (cddr p))
+		    (eq? 'quote (car p))
+		    (symbol? (cadr p)))
+	       'symbol?)
+	      (else #f))))))
+
+  (define disjoint?
+    (lambda (tst) (memq (car tst) match:disjoint-predicates)))
+
+  (define add-a
+    (lambda (a)
+      (let ((new (and (pair? a) (assq (car a) c---rs))))
+	(if new (cons (cadr new) (cdr a)) `(car ,a)))))
+
+  (define add-d
+    (lambda (a)
+      (let ((new (and (pair? a) (assq (car a) c---rs))))
+	(if new (cons (cddr new) (cdr a)) `(cdr ,a)))))
+  
+  (define c---rs
+    '((car caar . cdar)
+      (cdr cadr . cddr)
+      (caar caaar . cdaar)
+      (cadr caadr . cdadr)
+      (cdar cadar . cddar)
+      (cddr caddr . cdddr)
+      (caaar caaaar . cdaaar)
+      (caadr caaadr . cdaadr)
+      (cadar caadar . cdadar)
+      (caddr caaddr . cdaddr)
+      (cdaar cadaar . cddaar)
+      (cdadr cadadr . cddadr)
+      (cddar caddar . cdddar)
+      (cdddr cadddr . cddddr)))
+
+  (define setter
+    (lambda (e p)
+      (let ((mk-setter (lambda (s) (symbol-append 'set- s '!))))
+	(cond
+	 ((not (pair? e))
+	  (match:syntax-err p "unnested set! pattern"))
+	 ((eq? (car e) 'vector-ref)
+	  `(let ((x ,(cadr e)))
+	     (lambda (y) (vector-set! x ,(caddr e) y))))
+	 ((eq? (car e) 'unbox)
+	  `(let ((x ,(cadr e))) (lambda (y) (set-box! x y))))
+	 ((eq? (car e) 'car)
+	  `(let ((x ,(cadr e))) (lambda (y) (set-car! x y))))
+	 ((eq? (car e) 'cdr)
+	  `(let ((x ,(cadr e))) (lambda (y) (set-cdr! x y))))
+	 ((let ((a (assq (car e) get-c---rs)))
+	    (and a
+		 `(let ((x (,(cadr a) ,(cadr e))))
+		    (lambda (y) (,(mk-setter (cddr a)) x y))))))
+	 (else
+	  `(let ((x ,(cadr e)))
+	     (lambda (y) (,(mk-setter (car e)) x y))))))))
+
+  (define getter
+    (lambda (e p)
+      (cond
+       ((not (pair? e)) (match:syntax-err p "unnested get! pattern"))
+       ((eq? (car e) 'vector-ref)
+	`(let ((x ,(cadr e))) (lambda () (vector-ref x ,(caddr e)))))
+       ((eq? (car e) 'unbox)
+	`(let ((x ,(cadr e))) (lambda () (unbox x))))
+       ((eq? (car e) 'car)
+	`(let ((x ,(cadr e))) (lambda () (car x))))
+       ((eq? (car e) 'cdr)
+	`(let ((x ,(cadr e))) (lambda () (cdr x))))
+       ((let ((a (assq (car e) get-c---rs)))
+	  (and a
+	       `(let ((x (,(cadr a) ,(cadr e))))
+		  (lambda () (,(cddr a) x))))))
+       (else `(let ((x ,(cadr e))) (lambda () (,(car e) x)))))))
+
+  (define get-c---rs
+    '((caar car . car)
+      (cadr cdr . car)
+      (cdar car . cdr)
+      (cddr cdr . cdr)
+      (caaar caar . car)
+      (caadr cadr . car)
+      (cadar cdar . car)
+      (caddr cddr . car)
+      (cdaar caar . cdr)
+      (cdadr cadr . cdr)
+      (cddar cdar . cdr)
+      (cdddr cddr . cdr)
+      (caaaar caaar . car)
+      (caaadr caadr . car)
+      (caadar cadar . car)
+      (caaddr caddr . car)
+      (cadaar cdaar . car)
+      (cadadr cdadr . car)
+      (caddar cddar . car)
+      (cadddr cdddr . car)
+      (cdaaar caaar . cdr)
+      (cdaadr caadr . cdr)
+      (cdadar cadar . cdr)
+      (cdaddr caddr . cdr)
+      (cddaar cdaar . cdr)
+      (cddadr cdadr . cdr)
+      (cdddar cddar . cdr)
+      (cddddr cdddr . cdr)))
+
+  (define symbol-append
+    (lambda l
+      (string->symbol
+       (apply
+	string-append
+	(map
+	 (lambda (x)
+	   (cond
+	    ((symbol? x) (symbol->string x))
+	    ((number? x) (number->string x))
+	    (else x)))
+	 l)))))
+
+  (define rac (lambda (l) (if (null? (cdr l)) (car l) (rac (cdr l)))))
+  (define rdc
+    (lambda (l)
+      (if (null? (cdr l)) '() (cons (car l) (rdc (cdr l))))))
+
+ (define-syntax :ucall
+   (lambda (stx)
+     (syntax-case stx ()
+       [(_ name arg ...)
+	(syntax
+	 (let ([name (syntax-local-value (quote-syntax name))])
+	   (name arg ...)))]))))
diff --git a/collects/games/aces/aces.png b/collects/games/aces/aces.png
new file mode 100644
index 0000000000..64fdd04d3a
Binary files /dev/null and b/collects/games/aces/aces.png differ
diff --git a/collects/games/aces/aces.scm b/collects/games/aces/aces.scm
new file mode 100644
index 0000000000..497ae091f3
--- /dev/null
+++ b/collects/games/aces/aces.scm
@@ -0,0 +1,371 @@
+#|
+
+possible to disable dragging but still allow double-clicking?
+possible to remap single click (instead of double click)?
+
+|#
+
+(module aces mzscheme
+  
+  (require (lib "cards.ss" "games" "cards")
+           (lib "class.ss")
+           (lib "unit.ss")
+           (lib "mred.ss" "mred")
+           (lib "list.ss")
+           (lib "string-constant.ss" "string-constants")
+           "../show-help.ss")
+  
+  (provide game-unit)
+  
+  (define game-unit
+    (unit 
+      (import)
+      (export)
+      
+      (define table (make-table "Aces" 6 5))
+
+      (make-object button% (string-constant help-menu-label) table
+        (let ([show-help (show-help (list "games" "aces") "Aces Help")])
+          (lambda x
+            (show-help))))
+      
+      (define draw-pile null)
+      
+      (define card-height (send (car (make-deck)) card-height))
+      (define card-width (send (car (make-deck)) card-width))
+      (define region-height (send table table-height))
+
+      ;; space between cards in the 4 stacks
+      (define card-space 30)
+      
+      (define-struct stack (x y cards))
+      
+      (define (get-x-offset n)
+        (let* ([table-width (send table table-width)]
+               [stack-spacing 7]
+               [num-stacks 5]
+               [all-stacks-width
+                (+ (* num-stacks card-width)
+                   (* (- num-stacks 1) stack-spacing))])
+          (+ (- (/ table-width 2) (/ all-stacks-width 2))
+             (* n (+ card-width stack-spacing)))))
+      
+      (define draw-pile-region
+        (make-button-region
+         (get-x-offset 0)
+         0
+         card-width
+         region-height ; card-height
+         #f
+         #f))
+      
+      (define stacks
+        (list
+         (make-stack
+          (get-x-offset 1) 
+          0
+          null)
+         (make-stack
+          (get-x-offset 2)
+          0
+          null)
+         (make-stack
+          (get-x-offset 3) 
+          0
+          null)
+         (make-stack
+          (get-x-offset 4)
+          0
+          null)))
+
+      ;; type state = (make-state (listof cards) (listof[4] (listof cards)))
+      (define-struct state (draw-pile stacks))
+
+      ;; extract-current-state : -> state
+      (define (extract-current-state)
+        (make-state
+         (copy-list draw-pile)
+         (map (lambda (x) (copy-list (stack-cards x))) stacks)))
+      
+      (define (copy-list l) (map (lambda (x) x) l))
+      
+      ;; install-state : -> void
+      (define (install-state state)
+        (send table begin-card-sequence)
+
+        ;; erase all old snips
+        (send table remove-cards draw-pile)
+        (for-each (lambda (stack)
+                    (send table remove-cards (stack-cards stack)))
+                  stacks)
+        
+        ;; restore old state
+        (set! draw-pile (state-draw-pile state))
+        (for-each (lambda (stack cards) (set-stack-cards! stack cards))
+                  stacks
+                  (state-stacks state))
+        
+        ;; restore GUI
+        (for-each (lambda (draw-pile-card)
+                    (send table add-card draw-pile-card 0 0))
+                  draw-pile)
+        (send table move-cards-to-region draw-pile draw-pile-region)
+        (for-each (lambda (draw-pile-card)
+                    (send table card-face-down draw-pile-card)
+                    (send table card-to-front draw-pile-card))
+                  (reverse draw-pile))
+        
+        (for-each 
+         (lambda (stack)
+           (let ([num-cards (length (stack-cards stack))])
+             (send table add-cards (stack-cards stack) 0 0)
+             (send table move-cards (stack-cards stack)
+                   (stack-x stack)
+                   (stack-y stack)
+                   (lambda (i)
+                     (values 0 
+                             (* (- num-cards i 1) card-space)))))
+           (send table cards-face-up (stack-cards stack)))
+         stacks)
+        (send table end-card-sequence))
+
+      ;; undo-stack : (listof state)
+      (define undo-stack null)
+
+      ;; redo-stack : (listof state)
+      (define redo-stack null)
+      
+      ;; save-undo : -> void
+      ;; saves the current state in the undo stack
+      (define (save-undo)
+        (set! undo-stack (cons (extract-current-state) undo-stack))
+        (set! redo-stack null))
+
+      ;; do-undo : -> void
+      ;; pre: (not (null? undo-stack))
+      (define (do-undo)
+        (let ([to-install (car undo-stack)])
+          (set! redo-stack (cons (extract-current-state) redo-stack))
+          (set! undo-stack (cdr undo-stack))
+          (install-state to-install)))
+      
+      ;; do-redo : -> void
+      ;; pre: (not (null? redo-stack))
+      (define (do-redo)
+        (let ([to-install (car redo-stack)])
+          (set! undo-stack (cons (extract-current-state) undo-stack))
+          (set! redo-stack (cdr redo-stack))
+          (install-state to-install)))
+        
+      (define (position-cards stack)
+        (let ([m (length (stack-cards stack))])
+          (lambda (i)
+            (values 0
+                    (if (= m 0)
+                        0
+                        (* (- m i 1) card-space))))))
+      
+      (define (reset-game)
+        (send table remove-cards draw-pile)
+        (for-each
+         (lambda (stack) (send table remove-cards (stack-cards stack)))
+         stacks)
+      
+        (set! undo-stack null)
+        (set! redo-stack null)
+        
+        (let* ([deck (shuffle-list (make-deck) 7)]
+               [set-stack
+                (lambda (which)
+                  (set-stack-cards! (which stacks) (list (which deck))))])
+          (for-each (lambda (card) 
+                      (send card user-can-move #f)
+                      (send card user-can-flip #f))
+                    deck)
+          (set! draw-pile (cddddr deck))
+          (set-stack car)
+          (set-stack cadr)
+          (set-stack caddr)
+          (set-stack cadddr))
+        
+        (for-each
+         (lambda (stack)
+           (send table add-cards
+                 (stack-cards stack)
+                 (stack-x stack)
+                 (stack-y stack)
+                 (position-cards stack))
+           (for-each
+            (lambda (card) (send card flip))
+            (stack-cards stack)))
+         stacks)
+        
+        (send table add-cards-to-region draw-pile draw-pile-region))
+      
+      (define (move-from-deck)
+        (save-undo)
+        (unless (null? draw-pile)
+          (let ([move-one
+                 (lambda (select)
+                   (let ([stack (select stacks)]
+                         [card (select draw-pile)])
+                     (set-stack-cards! stack
+                                       (cons card (stack-cards stack)))
+                     (send table card-to-front card)
+                     (send table flip-card card)))])
+            
+            (send table begin-card-sequence)
+            (move-one car)
+            (move-one cadr)
+            (move-one caddr)
+            (move-one cadddr)
+            (send table end-card-sequence)
+
+            (let ([cards-to-move (list (car draw-pile)
+                                       (cadr draw-pile)
+                                       (caddr draw-pile)
+                                       (cadddr draw-pile))])
+              (send table move-cards cards-to-move
+                    0 0
+                    (lambda (i)
+                      (let ([stack (list-ref stacks i)])
+                        (let-values ([(dx dy) ((position-cards stack) 0)])
+                          (values (+ dx (stack-x stack))
+                                  (+ dy (stack-y stack))))))))
+            
+            (set! draw-pile (cddddr draw-pile))
+            
+            (send table move-cards-to-region draw-pile draw-pile-region))))
+      
+      (define (move-to-empty-spot card stack)
+        (save-undo)
+        (send table move-cards 
+              (list card)
+              (stack-x stack)
+              (stack-y stack)
+              (position-cards stack))
+        (remove-card-from-stacks card)
+        (set-stack-cards! 
+         stack
+         (cons card (stack-cards stack))))
+      
+      (define (remove-card card)
+        (save-undo)
+        (send table remove-card card)
+        (remove-card-from-stacks card))
+      
+      (define (remove-card-from-stacks card)
+        (let ([old-cards (map stack-cards stacks)])
+          (for-each
+           (lambda (stack)
+             (set-stack-cards! stack (remq card (stack-cards stack))))
+           stacks)
+          (for-each (lambda (stack old-cards)
+                      (unless (equal? (stack-cards stack) old-cards)
+                        (send table move-cards 
+                              (stack-cards stack)
+                              (stack-x stack)
+                              (stack-y stack)
+                              (position-cards stack))))
+                    stacks
+                    old-cards)))
+            
+      (send table set-single-click-action
+            (lambda (card)
+              (cond
+                [(send card face-down?) (move-from-deck)]
+                [else 
+                 (let ([bottom-four
+                        (let loop ([l stacks])
+                          (cond
+                            [(null? l) null]
+                            [else (let ([stack (car l)])
+                                    (if (null? (stack-cards stack))
+                                        (loop (cdr l))
+                                        (cons (car (stack-cards stack))
+                                              (loop (cdr l)))))]))])
+                   (when (memq card bottom-four)
+                     (cond
+                       [(ormap (lambda (bottom-card)
+                                 (and (eq? (send card get-suit)
+                                           (send bottom-card get-suit))
+                                      (or 
+                                       (and (not (= 1 (send card get-value)))
+                                            (= 1 (send bottom-card get-value)))
+                                       (and (not (= 1 (send card get-value)))
+                                            (< (send card get-value)
+                                               (send bottom-card get-value))))))
+                               bottom-four)
+                        (remove-card card)]
+                       [else (let loop ([stacks stacks])
+                               (cond
+                                 [(null? stacks) (void)]
+                                 [else (let ([stack (car stacks)])
+                                         (if (null? (stack-cards stack))
+                                             (move-to-empty-spot card stack)
+                                             (loop (cdr stacks))))]))])))])
+              (check-game-over)))
+      
+      (define (game-over?)
+        (and (null? draw-pile)
+             (let ([suits/false
+                    (map (lambda (x) 
+                           (let ([stack-cards (stack-cards x)])
+                             (if (null? stack-cards)
+                                 #f
+                                 (send (car stack-cards) get-suit))))
+                         stacks)])
+               
+               (if (member #f suits/false)
+                   #f
+                   (and (memq 'clubs suits/false)
+                        (memq 'diamonds suits/false)
+                        (memq 'hearts suits/false)
+                        (memq 'spades suits/false))))))
+      
+      (define (won?)
+        (and (game-over?)
+             (andmap (lambda (x) 
+                       (let ([cards (stack-cards x)])
+                         (and (not (null? cards))
+                              (null? (cdr cards))
+                              (= 1 (send (car cards) get-value)))))
+                     stacks)))
+      
+      (define (check-game-over)
+        (when (game-over?)
+          (case (message-box "Aces"
+                             (if (won?)
+                                 "Congratulations! You win! Play again?"
+                                 "Game Over. Play again?")
+                             table
+                             '(yes-no))
+            [(yes) (reset-game)]
+            [(no) (send table show #f)])))
+
+      (send table add-region draw-pile-region)
+      (reset-game)
+      
+      (define mb (or (send table get-menu-bar)
+                     (make-object menu-bar% table)))
+      (define edit-menu (instantiate menu% ()
+                          (parent mb)
+                          (label (string-constant edit-menu))))
+      (instantiate menu-item% ()
+        (label (string-constant undo-menu-item))
+        (parent edit-menu)
+        (callback (lambda (x y) (do-undo)))
+        (shortcut #\z)
+        (demand-callback
+         (lambda (item)
+           (send item enable (not (null? undo-stack))))))
+      (instantiate menu-item% ()
+        (label (string-constant redo-menu-item))
+        (parent edit-menu)
+        (callback (lambda (x y) (do-redo)))
+        (shortcut #\y)
+        (demand-callback
+         (lambda (item)
+           (send item enable (not (null? redo-stack))))))
+      
+      (send table show #t))))
\ No newline at end of file
diff --git a/collects/games/aces/doc.txt b/collects/games/aces/doc.txt
new file mode 100644
index 0000000000..e9f8803068
--- /dev/null
+++ b/collects/games/aces/doc.txt
@@ -0,0 +1,17 @@
+** To play _Aces_, run the "Games" application. **
+
+Aces is a solitare card game. The object is to remove all of the cards
+from the board, except the four Aces.
+
+Remove a card by clicking it. You may remove a card when two
+conditions are true. First, it must be at the bottom of one of the
+four stacks of cards. Second, either the ace of the same suit, or a
+higher card of the same suit must also be at the bottom of one of the
+four stacks of cards.
+
+You may also move any card from the bottom of one of the stacks to an 
+empty stack by clicking it. If there are still cards in the deck on the 
+right, you may click the deck to deal four new cards, one onto the
+bottom of each stack.
+
+Good Luck!
diff --git a/collects/games/aces/info.ss b/collects/games/aces/info.ss
new file mode 100644
index 0000000000..e886b3cfd4
--- /dev/null
+++ b/collects/games/aces/info.ss
@@ -0,0 +1,5 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Aces")
+  (define doc.txt "doc.txt")
+  (define game "aces.scm")
+  (define game-set "Card Games"))
diff --git a/collects/games/blackjack/blackjack.png b/collects/games/blackjack/blackjack.png
new file mode 100644
index 0000000000..b517f8b7b8
Binary files /dev/null and b/collects/games/blackjack/blackjack.png differ
diff --git a/collects/games/blackjack/blackjack.ss b/collects/games/blackjack/blackjack.ss
new file mode 100644
index 0000000000..fef1591ab5
--- /dev/null
+++ b/collects/games/blackjack/blackjack.ss
@@ -0,0 +1,450 @@
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;                          Blackjack
+;; 
+;; The standard rules apply. Specifics:
+;; 
+;;   1 player (not counting the dealer)
+;; 
+;;   4 decks, reshuffled after 3/4 of the cards are used
+;; 
+;;   Dealer stands on soft 17s
+;; 
+;;   Splitting allowed only on the first two cards, and only if they
+;;    are equal; 10 and the face cards are all considered equal for
+;;    splitting
+;; 
+;;   Doubling allowed on all unsplit hands, not on split hands
+;; 
+;;   No blackjacks after splitting
+;; 
+;;   No surrender
+;; 
+;;   No insurance
+;; 
+;;   No maximum under-21 hand size
+;; 
+;;   Dealer's second card is not revealed if the player busts (or
+;;     both halves of a split hand bust)
+;; 
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(module blackjack mzscheme
+  (require (lib "cards.ss" "games" "cards")
+	   (lib "mred.ss" "mred")
+	   (lib "class.ss")
+           (lib "unit.ss")
+	   (lib "list.ss"))
+  
+  (provide game-unit)
+  
+  (define game-unit
+    (unit
+      (import)
+      (export)
+      
+      ;; Number of decks to use
+      (define DECK-COUNT 4)
+      
+      ;; Region layout constants
+      (define MARGIN 10)
+      (define SUBMARGIN 10)
+      (define LABEL-H 15)
+      
+      ;; Randomize
+      (random-seed (modulo (current-milliseconds) 10000))
+      
+      ;; Reshuffle when 3/4 of the deck is used
+      (define min-deck-size (/ (* DECK-COUNT 52) 4))
+      
+      ;; Set up the table
+      (define t (make-table "Blackjack" 6 3))
+      (define status-pane (send t create-status-pane))
+      (send t add-help-button status-pane '("games" "blackjack") "Blackjack Help" #f)
+      (send t show #t)
+      (send t set-double-click-action #f)
+      (send t set-button-action 'left 'drag/one)
+      (send t set-button-action 'middle 'drag/one)
+      (send t set-button-action 'right 'drag/one)
+      
+      ;; Get table width & height
+      (define w (send t table-width))
+      (define h (send t table-height))
+      
+      ;; Build the deck
+      (define deck 
+        (let loop ([n DECK-COUNT])
+          (if (zero? n)
+              null
+              (append (make-deck) (loop (sub1 n))))))
+      
+      ;; Card width & height
+      (define cw (send (car deck) card-width))
+      (define ch (send (car deck) card-height))
+      
+      ;; Size of buttons
+      (define BUTTON-HEIGHT 16)
+      (define BUTTON-WIDTH cw)
+      
+      ;; Cards are not movable
+      (for-each
+       (lambda (card)
+         (send card user-can-move #f)
+         (send card user-can-flip #f))
+       deck)
+      
+      ;; Set up card regions
+      (define deck-region 
+        (make-region MARGIN MARGIN
+                     cw ch #f #f))
+      
+      (define discard-region 
+        (make-region (- w cw MARGIN) MARGIN
+                     cw ch #f #f))
+      
+      (define dealer-region 
+        (make-region (+ cw (* 2 MARGIN)) MARGIN
+                     (- w (* 2 cw) (* 4 MARGIN)) ch 
+                     #f #f))
+      
+      (define player-region 
+        (make-region (+ cw (* 2 MARGIN)) (- h (* 2 MARGIN) ch BUTTON-HEIGHT)
+                     (- w (* 2 cw) (* 4 MARGIN)) ch
+                     #f #f))
+      
+      ;; In case of split, we need more regions
+      (define ww (* 3/2 cw))
+      (define player-2-region 
+        (make-region MARGIN (region-y player-region)
+                     (- w ww (* 3 MARGIN)) (region-h player-region)
+                     #f #f))
+      (define player-2-wait-region 
+        (make-region (region-x player-2-region) (region-y player-2-region)
+                     ww (region-h player-2-region)
+                     #f #f))
+      (define player-1-region 
+        (make-region (- w MARGIN (region-w player-2-region)) (region-y player-2-region)
+                     (region-w player-2-region) (region-h player-2-region)
+                     #f #f))
+      (define player-1-wait-region 
+        (make-region (- (+ (region-x player-1-region) (region-w player-1-region)) ww)
+                     (region-y player-1-region)
+                     ww (region-h player-1-region)
+                     #f #f))
+      (define (make-border-region r)
+        (define hm (/ MARGIN 2))
+        (make-region (- (region-x r) hm) (- (region-y r) hm)
+                     (+ (region-w r) MARGIN) (+ (region-h r) MARGIN) 
+                     "" #f))
+      (define player-1-border (make-border-region player-1-region))
+      (define player-2-border (make-border-region player-2-region))
+      
+      ;; Player buttons
+      (define (make-button title pos)
+        (make-button-region (+ (/ (- w (* 4 BUTTON-WIDTH) (* 3 MARGIN)) 2)
+                               (* pos (+ BUTTON-WIDTH MARGIN)))
+                            (- h MARGIN BUTTON-HEIGHT)
+                            BUTTON-WIDTH BUTTON-HEIGHT
+                            title void))
+      (define hit-button (make-button "Hit" 1))
+      (define stand-button (make-button "Stand" 2))
+      (define split-button (make-button "Split" 0))
+      (define double-button (make-button "Double" 3))
+      
+      ;; Put the cards on the table
+      (send t add-cards-to-region deck deck-region)
+      
+      ;; Function to compute the normal or minimum value of a card
+      (define (min-card-value c)
+        (let ([v (send c get-value)])
+          (if (> v 10)
+              10
+              v)))
+      
+      ;; Function to compute the value of a hand, counting aces as 1 or 11
+      ;;  to get the highest total possible under 21
+      (define (best-total l)
+        (let* ([ace? (lambda (is?) (lambda (c) (eq? is? (= (send c get-value) 1))))]
+               [aces (filter (ace? #t) l)]
+               [others (filter (ace? #f) l)]
+               [base (apply + (map min-card-value others))])
+          (let loop ([l aces][base base])
+            (cond
+              [(null? l) base]
+              [(<= (+ base (* (length aces) 11)) 21)
+               (+ base (* (length aces) 11))]
+              [else (loop (cdr l) (add1 base))]))))
+      
+      ;; Function to test whether a hand is a bust
+      (define (bust? p)
+        (> (best-total p) 21))
+      
+      ;; Very simple betting...
+      (define money 100)
+      (define (update-money! d)
+        (set! money (+ money d))
+        (send t set-status (format "You have $~a. (Each bet is $2.)" money)))
+      
+      ;; Let's play!
+      (let shuffle-loop ()
+        ;; Shuffle the cards, none are discarded, yet
+        (let* ([deck (shuffle-list deck 7)]
+               [discard null]
+               [deal (lambda (n)
+                       (let deal ([n n])
+                         (if (zero? n)
+                             null
+                             (let ([c (car deck)])
+                               (set! deck (cdr deck))
+                               (cons c (deal (sub1 n)))))))])
+          ;; Put the shuffled deck in place
+          (send t move-cards-to-region deck deck-region)
+          (send t stack-cards deck)
+          ;; Loop rounds over while there's enough cards in the deck
+          (let loop ()
+            ;; All bets are $2
+            (update-money! -2)
+            ;; Deal to player
+            (let ([p (deal 2)]
+                  [p2 null] ; in case of splitting
+                  [double? #f]) ; in case of doubling (flag is needed to adjust money)
+              ;; Move the player's cards into place and show them
+              (send t move-cards-to-region p player-region)
+              (send t cards-face-up p)
+              ;; Deal to dealer
+              (let ([d (deal 2)])
+                ;; Move the dealer's cards into place and show one
+                (send t move-cards-to-region d dealer-region)
+                (send t card-face-up (car d))
+                (let* ([continue (make-semaphore)]
+                       ;; Make a button in the center to show results
+                       [make-status
+                        (lambda (title continue)
+                          (let ([r (make-button-region 
+                                    (/ (- w (* 2 cw)) 2) 
+                                    (region-y hit-button)
+                                    (* 2 cw) BUTTON-HEIGHT
+                                    title #f)])
+                            (set-region-callback! r (lambda () 
+                                                      (send t remove-region r)
+                                                      (semaphore-post continue)))
+                            r))]
+                       ;; Done with hand:
+                       [done 
+                        (lambda (title continue)
+                          (send t remove-region hit-button)
+                          (send t remove-region stand-button)
+                          (send t add-region (make-status title continue)))]
+                       ;; Compute winnings (not called for busts by the player)
+                       [finish
+                        (lambda (p blackjack?)
+                          (let ([pt (best-total p)]
+                                [dt (best-total d)]
+                                [continue (make-semaphore)])
+                            (cond
+                              [(or (> dt 21) (> pt dt))
+                               (update-money! (if blackjack? 5 (if double? 8 4)))
+                               (done (if blackjack?
+                                         "Blackjack"
+                                         "You Win")
+                                     continue)]
+                              [(> dt pt) 
+                               (done (if blackjack?
+                                         "Dealer Blackjack"
+                                         "You Lose")
+                                     continue)]
+                              [else (update-money! (if double? 4 2))
+                                    (done "Push" continue)])
+                            (yield continue)))]
+                       ;; Done with the first hand of a split
+                       [finish-split
+                        (lambda (p player-region player-wait-region player-border)
+                          (unless (bust? p)
+                            (send t move-cards-to-region p player-region)
+                            (send t add-region player-border)
+                            (finish p #f)
+                            (send t remove-region player-border)
+                            (send t move-cards-to-region p player-wait-region)))]
+                       ;; Player busts
+                       [bust (lambda ()
+                               (done "Bust" continue))]
+                       ;; Bust in one hand of a split
+                       [local-bust (lambda ()
+                                     (let ([cont (make-semaphore)])
+                                       (done "Bust" cont)
+                                       (yield cont)))]
+                       ;; Callback for the hit button; the button's callback
+                       ;;  is changed for diferent modes: normal, split part 1, or split part 2
+                       [make-hit-callback
+                        (lambda (get-p set-p! player-region bust)
+                          (lambda ()
+                            (send t remove-region double-button)
+                            (send t remove-region split-button)
+                            (set-p! (append (deal 1) (get-p)))
+                            (send t stack-cards (get-p))
+                            (send t move-cards-to-region (get-p) player-region)
+                            (send t cards-face-up (get-p))
+                            ;; Check for bust
+                            (when (bust? (get-p))
+                              (bust))))])
+                  ;; Blackjack by player or dealer?
+                  (if (or (= 21 (best-total p))
+                          (= 21 (best-total d)))
+                      (begin
+                        ;; Show the dealers cards...
+                        (send t cards-face-up d)
+                        ;; ... and compute the result
+                        (finish p #t))
+                      (begin
+                        ;; Three basic actions are allowed:
+                        (send t add-region hit-button)
+                        (send t add-region stand-button)
+                        (send t add-region double-button)
+                        ;; Set the callbacks for normal (unsplit) hands
+                        (set-region-callback! hit-button
+                                              (make-hit-callback
+                                               (lambda () p)
+                                               (lambda (v) (set! p v))
+                                               player-region
+                                               bust))
+                        (set-region-callback! stand-button
+                                              (lambda ()
+                                                (semaphore-post continue)))
+                        (set-region-callback! double-button
+                                              (lambda ()
+                                                ;; Note the double for adjusting money on a win
+                                                (set! double? #t)
+                                                ;; Double the bet
+                                                (update-money! -2)
+                                                ;; Deal one more card
+                                                ((region-callback hit-button))
+                                                ;; No more cards or actions, but if the player busted, the hit 
+                                                ;;  callback has already continued
+                                                (unless (bust? p)
+                                                  (semaphore-post continue))))
+                        ;; Split allowed?
+                        (when (= (min-card-value (car p)) (min-card-value (cadr p)))
+                          ;; Yes, we can split. If the player hits the split button,
+                          ;;  we have to split the cards, deal one more to each split
+                          ;;  half and adjust the callbacks for hit and stand.
+                          ;; (If aces are split, the round is over.)
+                          (send t add-region split-button)
+                          (set-region-callback! split-button
+                                                (lambda ()
+                                                  ;; Double our bet...
+                                                  (update-money! -2)
+                                                  ;; Split the hand
+                                                  (set! p2 (list (cadr p)))
+                                                  (set! p (list (car p)))
+                                                  ;; Move the split halves to the "waiting" area. The
+                                                  ;;  active area is reserved for hands that are being
+                                                  ;;  played
+                                                  (send t move-cards-to-region p player-1-wait-region)
+                                                  (send t move-cards-to-region p2 player-2-wait-region)
+                                                  ;; Deal one more card to each half and move them into place
+                                                  (set! p (append (deal 1) p))
+                                                  (set! p2 (append (deal 1) p2))
+                                                  (send t stack-cards p)
+                                                  (send t stack-cards p2)
+                                                  (send t move-cards-to-region p player-1-wait-region)
+                                                  (send t move-cards-to-region p2 player-2-wait-region)
+                                                  ;; Show the newly dealt cards
+                                                  (send t flip-cards (list (car p) (car p2)))
+                                                  ;; No more splits, no doubling
+                                                  (send t remove-region split-button)
+                                                  (send t remove-region double-button)
+                                                  ;;       Function called when the last split hand is done
+                                                  (let* ([close-split
+                                                          (lambda ()
+                                                            ;; Unhilite the second hand
+                                                            (send t remove-region player-2-border)
+                                                            (send t move-cards-to-region p2 player-2-wait-region)
+                                                            ;; Let the main loop finish up
+                                                            (semaphore-post continue))]
+                                                         ;; Callback to swicth from the first split hand to the second
+                                                         [switch
+                                                          (lambda ()
+                                                            ;; Unhilite the first hand
+                                                            (send t remove-region player-1-border)
+                                                            (send t move-cards-to-region p player-1-wait-region)
+                                                            ;; Hilite the second hand
+                                                            (send t move-cards-to-region p2 player-2-region)
+                                                            (send t add-region player-2-border)
+                                                            ;; Adjust callbacks to operate on the second hand
+                                                            (set-region-callback! 
+                                                             hit-button
+                                                             (make-hit-callback (lambda () p2)
+                                                                                (lambda (v) (set! p2 v))
+                                                                                player-2-region
+                                                                                (lambda ()
+                                                                                  (local-bust)
+                                                                                  (close-split))))
+                                                            (set-region-callback!
+                                                             stand-button
+                                                             close-split))])
+                                                    ;; Did we split aces?
+                                                    (if (= 1 (send (cadr p) get-value))
+                                                        ;; Split aces; no more cards
+                                                        (semaphore-post continue)
+                                                        (begin
+                                                          ;; The first of the split hands is ready to go
+                                                          (send t move-cards-to-region p player-1-region)
+                                                          ;; Hilite the first hand
+                                                          (send t add-region player-1-border)
+                                                          ;; Adjust callbacks to work on the first of a split hand
+                                                          (set-region-callback!
+                                                           hit-button
+                                                           (make-hit-callback (lambda () p)
+                                                                              (lambda (v) (set! p v))
+                                                                              player-1-region
+                                                                              (lambda ()
+                                                                                (local-bust)
+                                                                                (switch)
+                                                                                (send t add-region hit-button)
+                                                                                (send t add-region stand-button))))
+                                                          (set-region-callback! 
+                                                           stand-button
+                                                           switch)))))))
+                        ;; Wait until the player is done
+                        (yield continue)
+                        ;; No more player actions; get rid of the buttons
+                        (send t remove-region hit-button)
+                        (send t remove-region stand-button)
+                        (send t remove-region double-button)
+                        (send t remove-region split-button)
+                        ;; If all the player's hards are bust, the dealer doesn't do anything
+                        (unless (and (bust? p)
+                                     (or (null? p2)
+                                         (bust? p2)))
+                          ;; Show the dealer's starting hand
+                          (send t card-face-up (cadr d))
+                          (let loop ()
+                            ;; Hit on 16 or lower, stand on 17 and higher
+                            (when (< (best-total d) 17)
+                              ;; Hit the dealer
+                              (set! d (append (deal 1) d))
+                              (send t stack-cards d)
+                              (send t move-cards-to-region d dealer-region)
+                              (send t cards-face-up d)
+                              (loop)))
+                          (if (null? p2)
+                              ;; Finish normal game (adjusts winnings)
+                              (finish p #f)
+                              ;; Finish split game (adjusts winnings for each hand)
+                              (begin
+                                (finish-split p player-1-region player-1-wait-region player-1-border)
+                                (finish-split p2 player-2-region player-2-wait-region player-2-border))))))
+                  ;; Move all the discarded cards to the back
+                  (unless (null? discard)
+                    (send t card-to-back (car discard))
+                    (send t stack-cards discard))
+                  ;; Discard all the cards we used
+                  (set! discard (append p p2 d discard))
+                  (send t cards-face-down discard)
+                  (send t move-cards-to-region discard discard-region)
+                  ;; Go again. Check whether we should reshuffle the deck or keep going with this one
+                  (if (< (length deck) min-deck-size)
+                      (begin
+                        (send t move-cards-to-region deck discard-region)
+                        (shuffle-loop))
+                      (loop)))))))))))
\ No newline at end of file
diff --git a/collects/games/blackjack/doc.txt b/collects/games/blackjack/doc.txt
new file mode 100644
index 0000000000..a73db82d6c
--- /dev/null
+++ b/collects/games/blackjack/doc.txt
@@ -0,0 +1,27 @@
+** To play _Blackjack_, run the "Games" application. **
+
+Standard Blackjack rules, plus the following specifics:
+
+      * 1 player (not counting the dealer)
+
+      * 4 decks, reshuffled after 3/4 of the cards are used
+
+      * Dealer stands on soft 17s
+
+      * Splitting is allowed only on the first two cards, and only if
+        they are equal; 10 and the face cards are all considered equal
+        for splitting
+
+      * Doubling is allowed on all unsplit hands, not on split hands
+
+      * No blackjacks after splitting
+
+      * No surrender
+
+      * No insurance
+
+      * No maximum under-21 hand size
+
+      * Dealer's second card is not revealed if the player busts (or
+        both halves of a split hand bust)
+
diff --git a/collects/games/blackjack/info.ss b/collects/games/blackjack/info.ss
new file mode 100644
index 0000000000..bd454dfaf7
--- /dev/null
+++ b/collects/games/blackjack/info.ss
@@ -0,0 +1,5 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Blackjack")
+  (define doc.txt "doc.txt")
+  (define game "blackjack.ss")
+  (define game-set "Card Games"))
diff --git a/collects/games/cards/card-class.ss b/collects/games/cards/card-class.ss
new file mode 100644
index 0000000000..3963313a6c
--- /dev/null
+++ b/collects/games/cards/card-class.ss
@@ -0,0 +1,197 @@
+
+(module card-class mzscheme
+  (require (lib "class.ss")
+	   (lib "class100.ss")
+	   (prefix mred:(lib "mred.ss" "mred"))
+	   "snipclass.ss"
+	   "region.ss")
+
+  (provide card%)
+
+  (define prev-regions #f)
+  (define prev-region-dc #f)
+
+  (define (with-card-region dc x y width height thunk)
+    (let ([rs (if (eq? prev-region-dc dc)
+		  prev-regions
+		  (cons (make-object mred:region% dc)
+			(make-object mred:region% dc)))])
+      (set! prev-regions rs)
+      (set! prev-region-dc dc)
+      (send (car rs) set-rectangle x (add1 y) width (- height 2))
+      (send (cdr rs) set-rectangle (add1 x) y (- width 2) height)
+      (send (car rs) union (cdr rs))
+      (let ([r (send dc get-clipping-region)])
+	(when r
+	  (send (car rs) intersect r))
+	(send dc set-clipping-region (car rs))
+	(thunk)
+	(send dc set-clipping-region r))))
+
+  (define card%
+    (class100 mred:snip% (-suit-id -value -width -height -front -back -semi-front -semi-back -mk-dim-front -mk-dim-back)
+      (inherit set-snipclass set-count get-admin)
+      (private-field
+	[suit-id -suit-id]
+	[value -value]
+	[width -width]
+	[height -height]
+	[front -front]
+	[back -back]
+	[semi-front -semi-front]
+	[semi-back -semi-back]
+	[mk-dim-front -mk-dim-front]
+	[mk-dim-back -mk-dim-back]
+	[dim-front #f]
+	[dim-back #f]
+	[is-dim? #f]
+	[flipped? #f]
+	[semi-flipped? #f]
+	[can-flip? #t]
+	[can-move? #t]
+	[snap-back? #f]
+	[stay-region #f]
+	[home-reg #f])
+      (private
+	[refresh
+	 (lambda ()
+	   (let ([a (get-admin)])
+	     (when a
+	       (send a needs-update this 0 0 width height))))]
+	[check-dim
+	 (lambda ()
+	   (when is-dim?
+	     (if flipped?
+		 (unless dim-back
+		   (set! dim-back (mk-dim-back)))
+		 (unless dim-front
+		   (set! dim-front (mk-dim-front))))))])
+      (public
+	[face-down? (lambda () flipped?)]
+	[flip
+	 (lambda ()
+	   (set! flipped? (not flipped?))
+	   (refresh))]
+	[semi-flip
+	 (lambda ()
+	   (set! semi-flipped? (not semi-flipped?))
+	   (refresh))]
+	[face-up (lambda () (when flipped? (flip)))]
+	[face-down (lambda () (unless flipped? (flip)))]
+	[dim (case-lambda 
+	      [() is-dim?]
+	      [(v)
+	       (unless (eq? is-dim? (and v #t))
+		 (set! is-dim? (and v #t))
+		 (refresh))])]
+	[get-suit-id
+	 (lambda () suit-id)]
+	[get-suit
+	 (lambda ()
+	   (case suit-id
+	     [(1) 'clubs]
+	     [(2) 'diamonds]
+	     [(3) 'hearts]
+	     [(4) 'spades]
+	     [else 'unknown]))]
+	[get-value
+	 (lambda () value)]
+	[user-can-flip
+	 (case-lambda
+	  [() can-flip?]
+	  [(f) (set! can-flip? (and f #t))])]
+	[user-can-move
+	 (case-lambda
+	  [() can-move?]
+	  [(f) (set! can-move? (and f #t))])]
+	[snap-back-after-move
+	 (case-lambda
+	  [() snap-back?]
+	  [(f) (set! snap-back? (and f #t))])]
+	[stay-in-region
+	 (case-lambda
+	  [() stay-region]
+	  [(r) (set! stay-region r)])]
+	[home-region
+	 (case-lambda
+	  [() home-reg]
+	  [(r) (set! home-reg r)])]
+	[card-width (lambda () width)]
+	[card-height (lambda () height)])
+      (override
+	[resize
+	 (lambda (w h) (void))]
+	[get-extent
+	 (lambda (dc x y w h descent space lspace rspace)
+	   (map
+	    (lambda (b)
+	      (when b
+		(set-box! b 0)))
+	    (list descent space lspace rspace))
+	   (when w (set-box! w width))
+	   (when h (set-box! h height)))]
+	[draw
+	 (lambda (dc x y left top right bottom dx dy draw-caret)
+	   (check-dim)
+	   (if semi-flipped?
+	       (send dc draw-bitmap (if flipped? semi-back semi-front) (+ x (/ width 4)) y)
+	       (with-card-region
+		dc x y width height
+		(lambda ()
+		  (send dc draw-bitmap 
+			(if flipped? 
+			    (if is-dim? dim-back back)
+			    (if is-dim? dim-front front))
+			x y)))))]
+	[copy (lambda () (make-object card% suit-id value width height 
+				      front back semi-front semi-back
+				      (lambda () 
+					(unless dim-front 
+					  (set! dim-front (mk-dim-front)))
+					dim-front)
+				      (lambda () 
+					(unless dim-back 
+					  (set! dim-back (mk-dim-back)))
+					dim-back)))])
+      (private-field
+	[save-x (box 0)]
+	[save-y (box 0)])
+      (public
+	[remember-location
+	 (lambda (pb)
+	   (send pb get-snip-location this save-x save-y))]
+	[back-to-original-location
+	 (lambda (pb)
+	   (when snap-back?
+	     (send pb move-to this (unbox save-x) (unbox save-y)))
+	   (when home-reg
+	     (let ([xbox (box 0)]
+		   [ybox (box 0)])
+	       (send pb get-snip-location this xbox ybox #f)
+	       ;; Completely in the region?
+	       (let* ([l (unbox xbox)]
+		      [rl (region-x home-reg)]
+		      [r (+ l width)]
+		      [rr (+ rl (region-w home-reg))]
+		      [t (unbox ybox)]
+		      [rt (region-y home-reg)]
+		      [b (+ t height)]
+		      [rb (+ rt (region-h home-reg))])
+		 (when (or (< l rl) (> r rr)
+			   (< t rt) (> b rb))
+		   ;; Out of the region - completely or partly?
+		   (if (and (or (<= rl l rr) (<= rl r rr))
+			    (or (<= rt t rb) (<= rt b rb)))
+		       ;; Just slightly out
+		       (send pb move-to this
+			     (min (max l rl) (- rr width))
+			     (min (max t rt) (- rb height)))
+		       ;; Completely out
+		       (send pb move-to this (unbox save-x) (unbox save-y))))))))])
+      (sequence
+	(super-init)
+	(set-count 1)
+	(set-snipclass sc)
+	(flip)))))
+
+
diff --git a/collects/games/cards/cards.ss b/collects/games/cards/cards.ss
new file mode 100644
index 0000000000..f6a3d8bc5e
--- /dev/null
+++ b/collects/games/cards/cards.ss
@@ -0,0 +1,20 @@
+
+(module cards mzscheme
+  (require "main.ss"
+	   "utils.ss"
+	   "region.ss")
+
+  (provide region
+	   make-region
+	   region? region-x region-y region-w region-h 
+	   region-label region-callback region-interactive-callback
+	   set-region-callback!
+	   set-region-interactive-callback!
+	   make-button-region
+	   make-background-region
+
+	   make-deck make-card
+	   make-table
+
+	   shuffle-list))
+
diff --git a/collects/games/cards/classes.ss b/collects/games/cards/classes.ss
new file mode 100644
index 0000000000..6ba0162269
--- /dev/null
+++ b/collects/games/cards/classes.ss
@@ -0,0 +1,686 @@
+
+(module classes mzscheme
+  (require (lib "class.ss")
+	   (lib "class100.ss")
+	   (prefix mred: (lib "mred.ss" "mred"))
+	   (lib "list.ss")
+	   (lib "etc.ss")
+	   (prefix util: "utils.ss")
+	   "constants.ss"
+	   "make-cards.ss"
+	   "region.ss"
+	   (lib "string-constant.ss" "string-constants")
+	   "../show-help.ss")
+
+  (provide pasteboard%
+	   table%)
+
+  (define pasteboard%
+    (class100 mred:pasteboard% ()
+      (inherit begin-edit-sequence end-edit-sequence get-admin
+	       invalidate-bitmap-cache
+	       find-next-selected-snip find-first-snip find-snip
+	       set-before set-after
+	       add-selected is-selected? no-selected
+	       get-snip-location move-to
+	       dc-location-to-editor-location
+	       set-selection-visible)
+      (private-field
+	[select-one? #t]
+	[select-backward? #f]
+	[raise-to-front? #f]
+	[button-map '((left #f #f #t)
+		      (middle #t #f #t)
+		      (right #f #t #f))]
+
+	[do-on-double-click 'flip]
+	[do-on-single-click void]
+
+	[selecting? #f]
+	[dragging? #f]
+	[bg-click? #f]
+	[click-base #f]
+	[regions null])
+      (private
+	[get-snip-bounds
+	 (lambda (s)
+	   (let ([xbox (box 0)]
+		 [ybox (box 0)])
+	     (get-snip-location s xbox ybox #f)
+	     (let ([l (unbox xbox)]
+		   [t (unbox ybox)])
+	       (get-snip-location s xbox ybox #t)
+	       (values l t (unbox xbox) (unbox ybox)))))]
+	[for-each-selected
+	 (lambda (f)
+	   (let loop ([snip (find-next-selected-snip #f)])
+	     (when snip
+	       (f snip)
+	       (loop (find-next-selected-snip snip)))))]
+	[make-overlapping-list
+	 (lambda (s so-far behind?)
+	   (let-values ([(sl st sr sb) (get-snip-bounds s)])
+	     (let loop ([t (find-first-snip)][so-far so-far][get? (not behind?)])
+	       (cond
+		[(not t) so-far]
+		[(eq? s t) (if behind?
+			       (loop (send t next) so-far #t)
+			       so-far)]
+		[get?
+		 (let ([l (if (and (not (memq t so-far))
+				   (let-values ([(tl tt tr tb) 
+						 (get-snip-bounds t)])
+				     (and (or (<= sl tl sr)
+					      (<= sl tr sr))
+					  (or (<= st tt sb)
+					      (<= st tb sb)))))
+			      (make-overlapping-list t (cons t so-far) behind?)
+			      so-far)])
+		   (loop (send t next) l #t))]
+		[else
+		 (loop (send t next) so-far #f)]))))]
+	[get-reverse-selected-list
+	 (lambda ()
+	   (let loop ([s (find-next-selected-snip #f)][l null])
+	     (if s
+		 (loop (find-next-selected-snip s) (cons s l))
+		 l)))]
+	[shuffle
+	 (lambda (selected-list) ; cards to shuffle in back->front order
+	   (let* ([permuted-list
+		   (util:shuffle-list selected-list 7)]
+		  [get-pos
+		   (lambda (s)
+		     (let ([xb (box 0)]
+			   [yb (box 0)])
+		       (get-snip-location s xb yb)
+		       (cons (unbox xb) (unbox yb))))]
+		  [sel-loc-list (map get-pos selected-list)]
+		  [perm-loc-list (map get-pos permuted-list)])
+	     (for-each
+	      (lambda (s start-pos end-pos)
+		(let* ([sx (car start-pos)]
+		       [sy (cdr start-pos)]
+		       [ex (car end-pos)]
+		       [ey (cdr end-pos)]
+		       [steps (max 1 (floor (/ 50 (length selected-list))))])
+		  (let loop ([i 1])
+		    (unless (> i steps)
+		      (let ([x (+ sx (* (/ i steps) (- ex sx)))]
+			    [y (+ sy (* (/ i steps) (- ey sy)))])
+			(move-to s x y)
+			(mred:flush-display)
+			(loop (add1 i)))))))
+	      permuted-list perm-loc-list sel-loc-list)
+	     (let loop ([l permuted-list])
+	       (unless (null? l)
+		 (set-before (car l) #f)
+		 (loop (cdr l))))
+	     (no-selected)))]
+	[update-region 
+	 (lambda (region)
+	   (let-values ([(sx sy sw sh) (get-region-box region)])
+	     (invalidate-bitmap-cache sx sy sw sh)))])
+      (override
+	[on-paint
+	 (lambda (before? dc l t r b dx dy caret)
+	   (when before?
+	     (for-each
+	      (lambda (region)
+		(when (region-paint-callback region)
+		  (let-values ([(sx sy sw sh) (get-region-box region)])
+		    ((region-paint-callback region) dc (+ dx sx) (+ dy sy) sw sh)))
+		(when (region-label region)
+		  (let ([old-b (send dc get-brush)]
+			[old-p (send dc get-pen)])
+		    (let-values ([(sx sy sw sh) (get-region-box region)])
+		      (send dc set-brush white-brush)
+		      (send dc set-pen no-pen)
+		      (send dc draw-rectangle (+ dx sx) (+ dy sy) sw sh)
+		      (send dc set-pen dark-gray-pen)
+		      (draw-roundish-rectangle dc (+ dx sx) (+ dy sy) sw sh)
+		      (let ([text (region-label region)])
+			(if (string? text)
+			    (let ([old-f (send dc get-font)])
+			      (send dc set-font nice-font)
+			      (let-values ([(x y d a) (send dc get-text-extent text)])
+				(send dc draw-text text
+				      (+ dx sx (/ (- sw x) 2))
+				      (if (region-button? region)
+					  (+ dy sy (/ (- sh (- y d a)) 2) (- a))
+					  (+ dy sy 5))))
+			      (send dc set-font old-f))
+			    (send dc draw-bitmap text
+				  (+ dx sx (/ (- sw (send text get-width)) 2))
+				  (+ dy sy (/ (- sh (send text get-height)) 2))
+				  'solid black-color
+				  (send text get-loaded-mask))))
+		      (when (region-hilite? region)
+			(send dc set-brush hilite-brush)
+			(send dc set-pen no-pen)
+			(send dc draw-rectangle (+ dx sx 1) (+ dy sy 1) (- sw 2) (- sh 2))))
+		    (send dc set-brush old-b)
+		    (send dc set-pen old-p))))
+	      regions)))])
+      (augment
+	[after-select
+	 (lambda (s on?)
+	   (inner (void) after-select s on?)
+	   (unless (or (not on?) selecting?)
+	     (set! selecting? #t)
+	     (if select-one?
+		 (when raise-to-front?
+		   (set-before s #f))
+		 (begin
+		   (begin-edit-sequence)
+		   (let ([l (make-overlapping-list s (list s) select-backward?)])
+		     (for-each (lambda (i) (add-selected i)) l))
+		   (when raise-to-front?
+		     (let loop ([snip (find-next-selected-snip #f)][prev #f])
+		       (when snip
+			 (if prev
+			     (set-after snip prev)
+			     (set-before snip #f))
+			 (loop (find-next-selected-snip snip) snip))))
+		   (end-edit-sequence)))
+	     (set! selecting? #f)))]
+	[on-interactive-move
+	 (lambda (e)
+	   (inner (void) on-interactive-move e)
+	   (for-each (lambda (region) (set-region-decided-start?! region #f)) regions)
+	   (for-each-selected (lambda (snip) (send snip remember-location this)))
+	   (set! dragging? #t))])
+      (override
+	[interactive-adjust-move
+	 (lambda (snip xb yb)
+	   (super interactive-adjust-move snip xb yb)
+	   (let-values ([(l t r b) (get-snip-bounds snip)])
+	     (let-values ([(rl rt rw rh)
+			   (let ([r (send snip stay-in-region)])
+			     (if r
+				 (values (region-x r) (region-y r)
+					 (region-w r) (region-h r))
+				 (let ([wb (box 0)][hb (box 0)])
+				   (send (get-admin) get-view #f #f wb hb)
+				   (values 0 0 (unbox wb) (unbox hb)))))])
+	       (let ([max-x (- (+ rl rw) (- r l))]
+		     [max-y (- (+ rt rh) (- b t))])
+		 (when (< (unbox xb) rl)
+		   (set-box! xb rl))
+		 (when (> (unbox xb) max-x)
+		   (set-box! xb max-x))
+		 (when (< (unbox yb) rt)
+		   (set-box! yb rt))
+		 (when (> (unbox yb) max-y)
+		   (set-box! yb max-y))))))])
+      (augment
+	[after-interactive-move
+	 (lambda (e)
+	   (set! dragging? #f)
+	   (inner (void) after-interactive-move e)
+	   (for-each-selected (lambda (snip) (send snip back-to-original-location this)))
+	   (let ([cards (get-reverse-selected-list)])
+	     ; (no-selected)
+	     (for-each
+	      (lambda (region)
+		(when (region-hilite? region)
+		  (mred:queue-callback
+		   ; Call it outside the current edit sequence
+		   (lambda ()
+		     ((region-callback region) cards)
+		     (unhilite-region region)))))
+	      regions)))])
+      (override
+	[on-default-event
+	 (lambda (e)
+	   (let ([click (or (and (send e button-down? 'left) 'left)
+			    (and (send e button-down? 'right) 'right)
+			    (and (send e button-down? 'middle) 'middle))])
+	     (when click
+	       (let* ([actions (cdr (assoc click button-map))]
+		      [one? (list-ref actions 0)]
+		      [backward? (list-ref actions 1)]
+		      [raise? (list-ref actions 2)])
+		 (unless (and (eq? backward? select-backward?)
+			      (eq? one? select-one?)
+			      (eq? raise? raise-to-front?))
+		   (set! select-one? one?)
+		   (set! select-backward? backward?)
+		   (set! raise-to-front? raise?)
+		   (no-selected))))
+	     (let*-values ([(lx ly) (dc-location-to-editor-location 
+				     (send e get-x) 
+				     (send e get-y))]
+			   [(s) (find-snip lx ly)])
+	       ; Clicking on a "selected" card unselects others
+	       ; in this interface
+	       (when (send e button-down?)
+		 (unless (or (not click-base) (not s) (eq? s click-base))
+		   (no-selected))
+		 (set! click-base s))
+	       (when (and dragging? click-base (send click-base user-can-move))
+		 (for-each
+		  (lambda (region)
+		    (when (and (not (region-button? region))
+			       (region-callback region)
+			       (or (not (region-decided-start? region))
+				   (region-can-select? region)))
+		      (let-values ([(sx sy sw sh) (get-region-box region)])
+			(let ([in? (and (<= sx lx (+ sx sw))
+					(<= sy ly (+ sy sh)))])
+			  (unless (region-decided-start? region)
+			    (set-region-decided-start?! region #t)
+			    (set-region-can-select?! region (not in?)))
+			  (when (and (not (eq? in? (region-hilite? region)))
+				     (region-can-select? region))
+			    (set-region-hilite?! region in?)
+			    (when (region-interactive-callback region)
+			      ((region-interactive-callback region) in? (get-reverse-selected-list)))
+			    (invalidate-bitmap-cache sx sy sw sh))))))
+		  regions))
+	       ; Can't move => no raise, either
+	       (unless (or (not click-base) (send click-base user-can-move))
+		 (set! raise-to-front? #f))
+	       (let ([was-bg? bg-click?])
+		 (if (send e button-down?)
+		     (set! bg-click? (not s))
+		     (when (and bg-click? (not (send e dragging?)))
+		       (set! bg-click? #f)))
+		 (unless bg-click?
+		   (super on-default-event e))
+		 (when bg-click?
+		   ; Check for clicking on a button region:
+		   (for-each
+		    (lambda (region)
+		      (when (and (region-button? region)
+				 (region-callback region))
+			(let-values ([(sx sy sw sh) (get-region-box region)])
+			  (let ([in? (and (<= sx lx (+ sx sw))
+					  (<= sy ly (+ sy sh)))])
+			    (unless (region-decided-start? region)
+			      (set-region-decided-start?! region #t)
+			      (set-region-can-select?! region in?))
+			    (when (and (not (eq? in? (region-hilite? region)))
+				       (region-can-select? region))
+			      (set-region-hilite?! region in?)
+			      (invalidate-bitmap-cache sx sy sw sh))))))
+		    regions))
+		 (when (and was-bg? (not bg-click?))
+		   ; Callback hilighted button:
+		   (for-each
+		    (lambda (region)
+		      (when (region-button? region) 
+			(set-region-decided-start?! region #f)
+			(when (region-hilite? region)
+			  (mred:queue-callback
+			   ; Call it outside the current edit sequence
+			   (lambda ()
+			     ((region-callback region))
+			     (unhilite-region region))))))
+		    regions)))
+	       (when (and (send e button-down?)
+			  click-base
+			  (not (send click-base user-can-move)))
+		 (no-selected)))
+	     (when (and click click-base)
+	       (do-on-single-click click-base))))]
+	[on-double-click
+	 (lambda (s e)
+	   (cond
+	    [(eq? do-on-double-click 'flip)
+	     (begin-edit-sequence)
+	     (let ([l (get-reverse-selected-list)])
+	       (for-each 
+		(lambda (s) 
+		  (when (send s user-can-flip)
+		    (send s flip)))
+		l)
+	       (let loop ([l (reverse! l)])
+		 (unless (null? l)
+		   (set-before (car l) #f)
+		   (loop (cdr l)))))
+	     (no-selected)
+	     (end-edit-sequence)]
+	    [do-on-double-click
+	     (do-on-double-click s)]
+	    [else (void)]))])
+      (public
+	[get-all-list
+	 (lambda ()
+	   (let loop ([t (find-first-snip)][accum null])
+	     (cond
+	      [(not t) (reverse accum)]
+	      [else (loop (send t next) (cons t accum))])))]
+	[get-full-box
+	 (lambda ()
+	   (let ([xb (box 0)][yb (box 0)]
+			     [wb (box 0)][hb (box 0)])
+	     (send (get-admin) get-view xb yb wb hb)
+	     (values 0 0 (unbox wb) (unbox hb))))]
+	[get-region-box
+	 (lambda (region)
+	   (values (region-x region)
+		   (region-y region)
+		   (region-w region)
+		   (region-h region)))]
+	[add-region
+	 (lambda (r)
+	   (set! regions (append regions (list r)))
+	   (update-region r))]
+	[remove-region
+	 (lambda (r)
+	   (set! regions (remq r regions))
+	   (update-region r))]
+	[unhilite-region
+	 (lambda (region)
+	   (set-region-hilite?! region #f)
+	   (update-region region))]
+	[hilite-region
+	 (lambda (region)
+	   (set-region-hilite?! region #t)
+	   (update-region region))]
+	[set-double-click-action
+	 (lambda (a)
+	   (set! do-on-double-click a))]
+	[set-single-click-action
+	 (lambda (a)
+	   (set! do-on-single-click a))]
+	[set-button-action
+	 (lambda (button action)
+	   (let ([map
+		  (case action
+		    [(drag/one) (list #t #f #f)]
+		    [(drag-raise/one) (list #t #f #t)]
+		    [(drag/above) (list #f #f #f)]
+		    [(drag-raise/above) (list #f #f #t)]
+		    [(drag/below) (list #f #t #f)]
+		    [(drag-raise/below) (list #f #t #t)]
+		    [else (error 'set-button-action "unknown action: ~s" action)])])
+	     (set! button-map
+		   (cons
+		    (cons button map)
+		    (remq (assoc button button-map)
+			  button-map)))))])
+      (sequence
+	(super-init)
+	(set-selection-visible #f))))
+
+  (define table%
+    (class mred:frame%
+      (init title w h)
+      (inherit reflow-container)
+      (augment*
+	[on-close
+	 (lambda ()
+	   (exit))])
+      (public*
+	[table-width (lambda ()
+		       (reflow-container)
+		       (let-values ([(x y w h) (send pb get-full-box)])
+			 w))]
+	[table-height (lambda ()
+			(reflow-container)
+			(let-values ([(x y w h) (send pb get-full-box)])
+			  h))]
+	[begin-card-sequence
+	 (lambda ()
+	   (set! in-sequence (add1 in-sequence))
+	   (send pb begin-edit-sequence))]
+	[end-card-sequence
+	 (lambda ()
+	   (send pb end-edit-sequence)
+	   (set! in-sequence (sub1 in-sequence)))]
+	[add-card
+	 (lambda (card x y)
+	   (position-cards (list card) x y (lambda (p) (values 0 0)) add-cards-callback))]
+	[add-cards
+	 (opt-lambda (cards x y [offset (lambda (p) (values 0 0))])
+	   (position-cards cards x y offset add-cards-callback))]
+	[add-cards-to-region
+	 (lambda (cards region)
+	   (position-cards-in-region cards region add-cards-callback))]
+	[move-card
+	 (lambda (card x y)
+	   (position-cards (list card) x y (lambda (p) (values 0 0)) move-cards-callback))]
+	[move-cards
+	 (opt-lambda (cards x y  [offset (lambda (p) (values 0 0))])
+	   (position-cards cards x y offset move-cards-callback))]
+	[move-cards-to-region
+	 (lambda (cards region)
+	   (position-cards-in-region cards region (lambda (c x y) (send pb move-to c x y))))]
+	[card-location
+	 (lambda (card)
+	   (let ([x (box 0)]
+		 [y (box 0)])
+	     (unless (send pb get-snip-location card x y)
+	       (raise-mismatch-error 'card-location "card not on table: " card))
+	     (values (unbox x) (unbox y))))]
+	[all-cards
+	 (lambda ()
+	   (send pb get-all-list))]
+	[remove-card
+	 (lambda (card)
+	   (remove-cards (list card)))]
+	[remove-cards
+	 (lambda (cards)
+	   (begin-card-sequence)
+	   (for-each (lambda (c) (send pb release-snip c)) cards)
+	   (end-card-sequence))]
+	[flip-card
+	 (lambda (card)
+	   (flip-cards (list card)))]
+	[flip-cards
+	 (lambda (cards)
+	   (if (or (not animate?) (positive? in-sequence))
+	       (for-each (lambda (c) (send c flip)) cards)
+	       (let ([flip-step
+		      (lambda (go)
+			(let ([start (current-milliseconds)])
+			  (begin-card-sequence)
+			  (go)
+			  (end-card-sequence)
+			  (pause (max 0 (- (/ ANIMATION-TIME ANIMATION-STEPS)
+					   (/ (- (current-milliseconds) start) 1000))))))])
+		 (flip-step (lambda () (for-each (lambda (c) (send c semi-flip)) cards)))
+		 (flip-step (lambda () (for-each (lambda (c) (send c flip)) cards)))
+		 (flip-step (lambda () (for-each (lambda (c) (send c semi-flip)) cards))))))]
+	[card-face-up
+	 (lambda (card)
+	   (cards-face-up (list card)))]
+	[cards-face-up
+	 (lambda (cards)
+	   (flip-cards (filter (lambda (c) (send c face-down?)) cards)))]
+	[card-face-down
+	 (lambda (card)
+	   (cards-face-down (list card)))]
+	[cards-face-down
+	 (lambda (cards)
+	   (flip-cards (filter (lambda (c) (not (send c face-down?))) cards)))]
+	[card-to-front
+	 (lambda (card)
+	   (send pb set-before card #f))]
+	[card-to-back
+	 (lambda (card)
+	   (send pb set-after card #f))]
+	[stack-cards
+	 (lambda (cards)
+	   (unless (null? cards)
+	     (begin-card-sequence)
+	     (let loop ([l (cdr cards)][behind (car cards)])
+	       (unless (null? l)
+		 (send pb set-after (car l) behind)
+		 (loop (cdr l) (car l))))
+	     (end-card-sequence)))]
+	[add-region
+	 (lambda (r)
+	   (send pb add-region r))]
+	[remove-region
+	 (lambda (r)
+	   (send pb remove-region r))]
+	[hilite-region
+	 (lambda (r)
+	   (send pb hilite-region r))]
+	[unhilite-region
+	 (lambda (r)
+	   (send pb unhilite-region r))]
+	[set-button-action
+	 (lambda (button action)
+	   (send pb set-button-action button action))]
+	[set-double-click-action
+	 (lambda (a)
+	   (send pb set-double-click-action a))]
+	[set-single-click-action
+	 (lambda (a)
+	   (send pb set-single-click-action a))]
+	[pause
+	 (lambda (duration)
+	   (let ([s (make-semaphore)]
+		 [a (alarm-evt (+ (current-inexact-milliseconds)
+				  (* duration 1000)))])
+	     ;; Can't move the cards during this time:
+	     (send c enable #f)
+	     (mred:yield a)
+	     (send c enable #t)))]
+	[animated
+	 (case-lambda 
+	  [() animate?]
+	  [(on?) (set! animate? (and on? #t))])]
+	[create-status-pane
+	 (lambda ()
+	   (let ([p (make-object mred:horizontal-pane% this)])
+	     (set! msg (new mred:message% 
+			    [parent p]
+			    [label ""]
+			    [stretchable-width #t]))
+	     p))]
+	[set-status
+	 (lambda (str)
+	   (when msg
+	     (send msg set-label str)))]
+	[add-help-button
+	 (lambda (pane where title tt?)
+	   (new mred:button% 
+		(parent pane)
+		(label (string-constant help-menu-label))
+		(callback
+		 (let ([show-help (show-help where title tt?)])
+		   (lambda x
+		     (show-help))))))])
+      (begin
+	(define msg #f)
+	(define add-cards-callback
+	 (lambda (card x y)
+	   (send pb insert card #f x y)))
+        (define move-cards-callback
+	 (lambda (card x y)
+	   (send pb move-to card x y)
+	   (send card remember-location pb))))
+      (begin
+	(define animate? #t)
+	(define in-sequence 0))
+      (private*
+        [position-cards
+	 (lambda (cards x y offset set)
+	   (let ([positions (let loop ([l cards][n 0])
+			      (if (null? l)
+				  null
+				  (let-values ([(dx dy) (offset n)])
+				    (cons (cons (+ x dx) (+ y dy))
+					  (loop (cdr l) (add1 n))))))])
+	     (if (or (not animate?) (positive? in-sequence) (eq? set add-cards-callback))
+		 (begin
+		   (begin-card-sequence)
+		   (for-each (lambda (c p) (set c (car p) (cdr p))) cards positions)
+		   (end-card-sequence))
+		 (let-values ([(moving-cards
+				source-xs
+				source-ys
+				dest-xs
+				dest-ys)
+			       (let loop ([cl cards][pl positions])
+				 (if (null? cl)
+				     (values null null null null null)
+				     (let-values ([(mcl sxl syl dxl dyl) (loop (cdr cl) (cdr pl))]
+						  [(card) (car cl)]
+						  [(x y) (values (caar pl) (cdar pl))])
+				       (let ([xb (box 0)][yb (box 0)])
+					 (send pb get-snip-location card xb yb)
+					 (let ([sx (unbox xb)][sy (unbox yb)])
+					   (if (and (= x sx) (= y sy))
+					       (values mcl sxl syl dxl dyl)
+					       (values (cons card mcl)
+						       (cons sx sxl)
+						       (cons sy syl)
+						       (cons x dxl)
+						       (cons y dyl))))))))])
+		   (let ([time-scale
+			  ;; An animation speed that looks good for
+			  ;; long moves looks too slow for short
+			  ;; moves. So scale the time back by as much
+			  ;; as 50% if the max distance for all cards
+			  ;; is short.
+			  (let ([max-delta (max (apply max 0 (map (lambda (sx dx)
+								    (abs (- sx dx)))
+								  source-xs dest-xs))
+						(apply max 0 (map (lambda (sy dy)
+								    (abs (- sy dy)))
+								  source-ys dest-ys)))])
+			    (if (max-delta . < . 100)
+				(/ (+ max-delta 100) 200.0)
+				1))])
+		     (let loop ([n 1])
+		       (unless (> n ANIMATION-STEPS)
+			 (let ([start (current-milliseconds)]
+			       [scale (lambda (s d)
+					(+ s (* (/ n ANIMATION-STEPS) (- d s))))])
+			   (begin-card-sequence)
+			   (for-each
+			    (lambda (c sx sy dx dy)
+			      (set c (scale sx dx) (scale sy dy)))
+			    moving-cards
+			    source-xs source-ys
+			    dest-xs dest-ys)
+			   (end-card-sequence)
+			   (pause (max 0 (- (/ (* time-scale ANIMATION-TIME) ANIMATION-STEPS)
+					    (/ (- (current-milliseconds) start) 1000))))
+			   (loop (add1 n))))))))))]
+	[position-cards-in-region
+	 (lambda (cards r set)
+	   (let-values ([(x y w h) (send pb get-region-box r)]
+			[(len) (sub1 (length cards))]
+			[(cw ch) (values (send back get-width)
+					 (send back get-height))])
+	     (let* ([pretty (lambda (cw) (+ (* (add1 len) cw) (* len PRETTY-CARD-SEP-AMOUNT)))]
+		    [pw (pretty cw)]
+		    [ph (pretty ch)])
+	       (let-values ([(x w) (if (> w pw)
+				       (values (+ x (/ (- w pw) 2)) pw)
+				       (values x w))]
+			    [(y h) (if (> h ph)
+				       (values (+ y (/ (- h ph) 2)) ph)
+				       (values y h))])
+		 (position-cards cards x y
+				 (lambda (p)
+				   (if (zero? len)
+				       (values (/ (- w cw) 2)
+					       (/ (- h ch) 2))
+				       (values (* (- len p) (/ (- w cw) len))
+					       (* (- len p) (/ (- h ch) len)))))
+				 set)))))])
+      (super-new [label title] [style '(metal no-resize-border)])
+      (begin
+        (define c (make-object mred:editor-canvas% this #f '(no-vscroll no-hscroll)))
+	(define pb (make-object pasteboard%)))
+      (send c min-client-width (+ 10 (inexact->exact (floor (* w (send back get-width))))))
+      (send c min-client-height (+ 10 (inexact->exact (floor (* h (send back get-height))))))
+      (send c stretchable-width #f)
+      (send c stretchable-height #f)
+      (send this stretchable-width #f)
+      (send this stretchable-height #f)
+      (send c set-editor pb)))
+
+  (define (draw-roundish-rectangle dc x y w h)
+    (send dc draw-line (+ x 1) y (+ x w -2) y)
+    (send dc draw-line (+ x 1) (+ y h -1) (+ x w -2) (+ y h -1))
+    (send dc draw-line x (+ y 1) x (+ y h -2))
+    (send dc draw-line (+ x w -1) (+ y 1) (+ x w -1) (+ y h -2))))
diff --git a/collects/games/cards/constants.ss b/collects/games/cards/constants.ss
new file mode 100644
index 0000000000..1b0ade1d83
--- /dev/null
+++ b/collects/games/cards/constants.ss
@@ -0,0 +1,57 @@
+
+(module constants mzscheme
+  (require (lib "class.ss")
+	   (lib "mred.ss" "mred"))
+
+  (provide ANIMATION-STEPS
+	   ANIMATION-TIME
+
+	   PRETTY-CARD-SEP-AMOUNT
+	   
+	   white-brush
+	   hilite-brush
+	   black-pen
+	   dark-gray-pen
+	   no-pen
+	   black-color
+	   nice-font)
+  
+  (define ANIMATION-STEPS 5)
+  (define ANIMATION-TIME 0.3)
+
+  (define PRETTY-CARD-SEP-AMOUNT 5)
+
+  (define black-color
+    (make-object color% "black"))
+
+  (define white-brush
+    (send the-brush-list
+	  find-or-create-brush
+	  "white" 'solid))
+
+  (define hilite-brush
+    (send the-brush-list
+	  find-or-create-brush
+	  black-color 'hilite))
+
+  (define black-pen
+    (send the-pen-list
+	  find-or-create-pen
+	  black-color 1 'solid))
+
+  (define dark-gray-pen
+    (send the-pen-list
+	  find-or-create-pen
+	  "dark gray" 1 'solid))
+
+  (define no-pen
+    (send the-pen-list
+	  find-or-create-pen
+	  black-color 1 'transparent))
+
+  (define nice-font
+    (send the-font-list
+	  find-or-create-font
+	  12 'decorative 'normal 'bold
+	  #f 'default #t)))
+
diff --git a/collects/games/cards/doc.txt b/collects/games/cards/doc.txt
new file mode 100644
index 0000000000..6f3dbc135c
--- /dev/null
+++ b/collects/games/cards/doc.txt
@@ -0,0 +1,311 @@
+
+The _Virtual Playing Cards Library_
+-----------------------------------
+
+Load the virtual card library with
+   (require (lib "cards.ss" "games" "cards"))
+
+The _cards.ss_ module defines the following procedures:
+
+> (make-table [title-string] [w] [h]) returns a table named by
+      `title-string' that is `w' cards wide and `h' cards high. A
+      table is an frame% object, with extra methods described
+      below. The table is not intially shown; (send table show #t)
+      shows it. The arguments are optional, with the default values
+      being "Cards", 7, and 3.
+
+> (make-deck) returns a list of 52 cards, one for each suit-value 
+      combination. The cards are all face-down, sorted lowest-suit
+      then lowest-value. A card is an object, with methods described 
+      below. A card can only be on one table at a time.
+
+> (make-card front-bm back-bm-or-#f suit-id value) returns a single
+      card given a bitmap for the front, an optional bitmap for the
+      back, and arbitrary values for the card's suit and value (which
+      are returned by the card's `get-value' and `get-suit-id'
+      methods). All provided bitmaps should be 71 by 96 pixels.
+
+> (shuffle-list list n) shuffles the given `list' `n' times, returning
+      the new list. Shuffling simulates an actual shuffle: the list is
+      split into halves which are merged back together by repeatedly
+      pulling the top card off one of the halves, randomly selecting
+      one half or the other. According to some mathematical theorem, 7
+      is a large enough `n' to get a perfect shuffle.
+
+plus a structure:
+
+>  struct:region :: (struct region (x y w h label callback))
+      `x', `y', `w', `h' are coordinates on the table,
+      `label' is a string or bitmap to label the region or #f for no
+        label. When the region is added to a table, a text label is
+        drawn in 12-pixel text, and the label is centered horizontally
+        and 5 pixels down from the region's top outline. If label is
+        #f, no label or box is drawn for the region.
+      `callback' is a procedure that takes a list of cards that were
+        dragged to the region; if callback is #f, the region is not
+        active (i.e., dragging cards to the region doesn't highlight the
+        region box). The region remains hilited until the callback returns.
+     The only mutator on the structure that is available is set-region-callback!.
+     The structure created by make-region actually has extra hidden fields.
+
+>  (make-button-region x y w h label callback) - returns a region like
+     one made by make-region, but the is drawn slightly differently and
+     it reacts differently to cards and the mouse. The label is drawn
+     in the middle of the box instead of at the top, and the callback is
+     called with no arguments when the user clicks the region (instead
+     of dragging cards to the region).
+
+>  (make-background-region x y w h paint-callback) - returns a region that
+     does not respond to mouse clicks, but which has a general paint
+     callback. The `paint-callback' function is called with five
+     arguments: a drawing context, x and y offsets, and the width and
+     height (which are always `w' and `h'). The x and y offsets can be
+     different than the supplied `x' and `y' when part of the table is
+     drawn offscreen. Regions are painted in the order that they are
+     added to a table, and all regions are painted before any card.
+     The `paint-callback' procedure should not assume a particular
+     state for the drawing context (i.e.,current brush or pen), and it
+     should restore any modified drawing context state before
+     returning.
+
+Plus some extra callback procedures on regions:
+
+> (region-interactive-callback r)
+> (set-region-interactive-callback! r hilite-callback)
+  Get and set a callback procedure that is invoked when a region is
+  [un]hilited as the user drags a set of cards to the region. The
+  callback is provided two arguments: a boolean indicating whether the
+  region is hilited, and the list of cards being dragged. Like
+  region-callback, the default is #f, which indicates that the region
+  has no interactive callback (but does not affect whether the region
+  is hilited as cards are dragged). The final unhilite (when cards are
+  potentially delivered) does not trigger this callback.
+
+
+Table methods: [in addition to standard frame% methods]
+--------------
+
+> add-card :: (send t add-card card x y) - adds `card' to the table
+        with its top-left corner at (`x',`y') in table pixels.
+
+> add-cards :: (send t add-cards cards x y [offset-proc]) - adds list
+        of cards at (`x',`y'); the optional `offset-proc' procedure is
+        called with an index i (counting from 0) and should return two
+        values: `dx' and `dy'; the ith card is the placed at `x'+`dx'
+        and `y'+`dy'. The cards are added in order on top of cards
+        already one the table such that the first card in `cards' is
+        topmost.
+
+> add-cards-to-region :: (send t add-cards-to-region cards r) - adds
+        `cards' to fill the region `r', fanning them out bottom-right
+        to top-left. The region `r' does not have to be added to the
+        table.
+
+
+> remove-card :: (send t remove-card card) - removes `card' from the
+        table
+
+> remove-cards :: (send t remove-cards cards) - removes `cards' from
+        the table
+
+
+> move-card :: (send t move-card card x y)
+> move-cards :: (send t move-cards cards x y [offset-proc])
+> move-cards-to-region :: (send t move-cards-to-region cards r)
+        These are like the `add-card' methods, except that they move
+        cards already on the table. The movement of the cards is
+        animated. All of the cards are moved at once. If the cards are
+        in snap-back-after-move mode and a drag is active, snapping
+        back will use the new location.
+
+
+> flip-card :: (send t flip-card card) - flips `card' over with
+        animation.
+
+> flip-cards :: (send t flip-cards cards) - flips all `cards' over (at
+        once) with animation.
+
+> card-face-up :: (send t card-face-up card)
+> cards-face-up :: (send t cards-face-up cards)
+> card-face-down :: (send t card-face-down card)
+> cards-face-down :: (send t cards-face-down cards)
+        These are like `flip-card', but only cards that are not
+        already face up/down are flipped.
+
+> card-to-front :: (send t card-to-front card) - moves `card' in front
+        of all other cards.
+
+> card-to-back :: (send t card-to-back card) - moves `card' behind all
+        other cards.
+
+> stack-cards :: (send t stack-cards cards) - the first card in
+        `cards' is not moved; the second card is moved to follow
+        immediately behind the first one, then (send t stack-cards
+        (cdr cards)) is called. If `cards' is empty or contains only
+        one card, no action is taken.
+
+> card-location :: (send t card-location card) - returns the position
+        of the given card; an exception is raised if the card is not
+        on the table.
+
+> all-cards :: (send t all-cards) - returns a list of all cards on the
+        table in stacking order from front to back
+
+> table-width :: (send t table-width) - returns the width of the table
+        in pixels.
+
+> table-height :: (send t table-height) - returns the height of the
+        table in pixels.
+
+
+> begin-card-sequence :: (send t begin-card-sequence) - starts a
+        sequence of card or region changes that won't be animated or
+        updated until the end of the sequence.
+
+> end-card-sequence :: (send t end-card-sequence) - ends a sequence;
+        begin-/end- pairs can be nested.
+   
+
+> add-region :: (send t add-region r) - adds the region `r' to the
+        table; regions are drawn in the order that they are added to
+        the table, and when a region added later is hilighted, it can
+        obscure regions added earlier.
+
+> remove-region :: (send t remove-region r) - removes the region `r'
+        from the table.
+
+> hilite-region :: (send t hilite-region r) - manual hilite (usually
+        for animation)
+
+> unhilite-region :: (send t unhilite-region r) - manual unhilite
+        (usually for anaimation)
+
+
+> set-button-action :: (send t set-button-action which action) - sets
+        the way that a mouse click is handled. The which argument must
+        be 'left, 'middle, or 'right. The action argument must be one
+        of:
+           'drag/one - drag only the clicked-on card
+           'drag-raise/one - like drag/one, but raise the card to the
+                  top on a click
+           'drag/above - drag the card along with any card on top of the
+                  card (i.e., more towards the front and overlapping with
+                  the card). The on-top-of relation is closed transitively.
+           'drag-raise/above
+           'drag/below - drag the card along with any card underneath the
+                  card (i.e., more towards the back and overlapping with
+                  the card). The underneath relation is closed transitively.
+           'drag-raise/below
+        The initial settings are:
+           'left - 'drag-raise/above
+           'middle - 'drag/one
+           'right - 'drag/below
+
+> set-double-click-action :: (send t set-double-click-action proc) -
+        sets the procedure to be called when a card is
+        double-clicked. The procedure is called with the
+        double-clicked card. The default procedure flips the cards
+        along with its on-top-of cards, raises the cards, and reverses
+        the front-to-back order of the cards
+
+> set-single-click-action :: (send t set-single-click-action proc) -
+        sets the procedure to be called when a card is single-clicked,
+        after the button action is initiated. (If the card is
+        double-clicked, this action is inoked for the first click,
+        then the double-click action is invoked.) The default action
+        does nothing.
+
+> pause :: (send t pause n-secs) - pauses, allowing the table display
+        to be updated (unless a sequence is active), but does not let
+        the user click on the cards.
+
+> animated :: (send t animated) - returns #t is animation is on.
+> animated :: (send t animated on?) - enables/disables animation.
+
+> create-status-pane :: (send t create-status-pane) - creates a
+        pane with a status message (initially empty) and returns
+        the pane so that you can add additional controls
+> set-status :: (send t set-status str) - sets the text message
+        in the status pane
+> add-help-button :: (send t add-help-button pane coll-path str tt?) -
+        adds a "Help" button to the give pane, where clicking the
+        button opens a new window to display "doc.txt" from the given
+        collection (where `coll-path' is a list of strings to select
+        the collection). The `str' is used for the help window title.
+        If `tt?' is true, then "doc.txt" is displayed verbatim,
+        otherwise it is formatted as for `show-help' from
+        `(lib "show-help.ss" "games").
+
+
+Card methods:
+-------------
+
+> card-width :: (send c card-width) - returns the width of the card in
+       pixels.
+
+> card-height :: (send c card-height) - returns the height of the card
+       in pixels.  All cards have the same width and height.
+
+> flip :: (send c flip) - flips the card without animation. This is
+       useful for flipping a card before it is added to a table.
+
+> face-up :: (send c face-up)
+> face-down :: (send c face-down)
+       Makes the card face up/down without animation.
+
+> face-down? :: (send c face-down?) - #t if the card is currently
+       face down.
+
+> get-suit-id :: (send c get-suit-id) - normally 1, 2, 3, or 4 (see
+       `get-suit' for corresponding suit names), but the result can be
+       anything for a card created by `make-card'
+
+> get-suit :: (send c get-suit) - 'clubs, 'diamonds, 'hearts, 'spades,
+       or 'unknown, depending on whether `get-suit-id' returns 1, 2,
+       3, 4, or something else
+
+> get-value :: (send c get-value) - normally 1 (Ace), 2, ... 10, 11
+       (Jack), 12 (Queen), or 13 (King), but the result can be
+       anything for a card created by `make-card'
+   
+> user-can-flip :: (send c user-can-flip)
+> user-can-flip :: (send c user-can-flip can?)
+       Determines whether the user can flip the card interactively,
+       usually by double-clicking it. Initially #t.
+
+> user-can-move :: (send c user-can-move)
+> user-can-move :: (send c user-can-move can?)
+       Determines whether the user can move the card interactively,
+       usually by dragging it. Disabling moves has the side-effect of
+       disabling raises and double-clicks. Initially #t.
+
+> snap-back-after-move :: (send c snap-back-after-move)
+> snap-back-after-move :: (send c snap-back-after-move on?)
+       Assuming user can move the card interactively, determines
+       whether the card stays where the user dragged it or snaps back
+       to its original place. Initially #f. A region's *interactive*
+       callback can disable snap-back for a card so that the card can
+       be delivered to the region. (A region's normal callback cannot
+       release the card, because it's too late.)
+
+> stay-in-region :: (send c stay-in-region r)
+> stay-in-region :: (send c stay-in-region)
+       If `r' is a region, the user cannot move the card out of r.
+       Initially #f.
+
+> home-region :: (send c home-region r)
+> home-region :: (send c home-region)
+       If `r' is a region, the user can move the card freely within
+       the region, but it snaps back if moved completely out of the
+       region. If moved partly out of the region, the card is moved
+       enough to get completely back in. Initially #f. A region's
+       *interactive* callback can disable snap-back for a card so that
+       the card can be delivered to the region. (A region's normal
+       callback cannot release the card, because it's too late.)
+
+> dim :: (send c dim dim?)
+> dim :: (send c dim)
+       "Highlights" the card by drawing it dimmer than normal.
+
+> copy :: (send c copy) - makes a new card with the same suit and
+       value.
diff --git a/collects/games/cards/hicolor/card-0-0.png b/collects/games/cards/hicolor/card-0-0.png
new file mode 100644
index 0000000000..170a0423b8
Binary files /dev/null and b/collects/games/cards/hicolor/card-0-0.png differ
diff --git a/collects/games/cards/hicolor/card-0-1.png b/collects/games/cards/hicolor/card-0-1.png
new file mode 100644
index 0000000000..a9b584e70a
Binary files /dev/null and b/collects/games/cards/hicolor/card-0-1.png differ
diff --git a/collects/games/cards/hicolor/card-0-2.png b/collects/games/cards/hicolor/card-0-2.png
new file mode 100644
index 0000000000..ed55dd1e88
Binary files /dev/null and b/collects/games/cards/hicolor/card-0-2.png differ
diff --git a/collects/games/cards/hicolor/card-0-3.png b/collects/games/cards/hicolor/card-0-3.png
new file mode 100644
index 0000000000..d035e708dc
Binary files /dev/null and b/collects/games/cards/hicolor/card-0-3.png differ
diff --git a/collects/games/cards/hicolor/card-1-0.png b/collects/games/cards/hicolor/card-1-0.png
new file mode 100644
index 0000000000..103ac964d9
Binary files /dev/null and b/collects/games/cards/hicolor/card-1-0.png differ
diff --git a/collects/games/cards/hicolor/card-1-1.png b/collects/games/cards/hicolor/card-1-1.png
new file mode 100644
index 0000000000..ca2ea27e65
Binary files /dev/null and b/collects/games/cards/hicolor/card-1-1.png differ
diff --git a/collects/games/cards/hicolor/card-1-2.png b/collects/games/cards/hicolor/card-1-2.png
new file mode 100644
index 0000000000..2614893024
Binary files /dev/null and b/collects/games/cards/hicolor/card-1-2.png differ
diff --git a/collects/games/cards/hicolor/card-1-3.png b/collects/games/cards/hicolor/card-1-3.png
new file mode 100644
index 0000000000..b6a378d67f
Binary files /dev/null and b/collects/games/cards/hicolor/card-1-3.png differ
diff --git a/collects/games/cards/hicolor/card-10-0.png b/collects/games/cards/hicolor/card-10-0.png
new file mode 100644
index 0000000000..63867322b3
Binary files /dev/null and b/collects/games/cards/hicolor/card-10-0.png differ
diff --git a/collects/games/cards/hicolor/card-10-1.png b/collects/games/cards/hicolor/card-10-1.png
new file mode 100644
index 0000000000..23df7da92c
Binary files /dev/null and b/collects/games/cards/hicolor/card-10-1.png differ
diff --git a/collects/games/cards/hicolor/card-10-2.png b/collects/games/cards/hicolor/card-10-2.png
new file mode 100644
index 0000000000..03e2f63184
Binary files /dev/null and b/collects/games/cards/hicolor/card-10-2.png differ
diff --git a/collects/games/cards/hicolor/card-10-3.png b/collects/games/cards/hicolor/card-10-3.png
new file mode 100644
index 0000000000..36a98e0d5b
Binary files /dev/null and b/collects/games/cards/hicolor/card-10-3.png differ
diff --git a/collects/games/cards/hicolor/card-11-0.png b/collects/games/cards/hicolor/card-11-0.png
new file mode 100644
index 0000000000..3c6dc01833
Binary files /dev/null and b/collects/games/cards/hicolor/card-11-0.png differ
diff --git a/collects/games/cards/hicolor/card-11-1.png b/collects/games/cards/hicolor/card-11-1.png
new file mode 100644
index 0000000000..a7fc17e6eb
Binary files /dev/null and b/collects/games/cards/hicolor/card-11-1.png differ
diff --git a/collects/games/cards/hicolor/card-11-2.png b/collects/games/cards/hicolor/card-11-2.png
new file mode 100644
index 0000000000..1cf0f77a03
Binary files /dev/null and b/collects/games/cards/hicolor/card-11-2.png differ
diff --git a/collects/games/cards/hicolor/card-11-3.png b/collects/games/cards/hicolor/card-11-3.png
new file mode 100644
index 0000000000..1963babd7f
Binary files /dev/null and b/collects/games/cards/hicolor/card-11-3.png differ
diff --git a/collects/games/cards/hicolor/card-12-0.png b/collects/games/cards/hicolor/card-12-0.png
new file mode 100644
index 0000000000..772b8c68ab
Binary files /dev/null and b/collects/games/cards/hicolor/card-12-0.png differ
diff --git a/collects/games/cards/hicolor/card-12-1.png b/collects/games/cards/hicolor/card-12-1.png
new file mode 100644
index 0000000000..2eeb52f8f3
Binary files /dev/null and b/collects/games/cards/hicolor/card-12-1.png differ
diff --git a/collects/games/cards/hicolor/card-12-2.png b/collects/games/cards/hicolor/card-12-2.png
new file mode 100644
index 0000000000..304676016a
Binary files /dev/null and b/collects/games/cards/hicolor/card-12-2.png differ
diff --git a/collects/games/cards/hicolor/card-12-3.png b/collects/games/cards/hicolor/card-12-3.png
new file mode 100644
index 0000000000..9390ec8b62
Binary files /dev/null and b/collects/games/cards/hicolor/card-12-3.png differ
diff --git a/collects/games/cards/hicolor/card-2-0.png b/collects/games/cards/hicolor/card-2-0.png
new file mode 100644
index 0000000000..950ead8f9a
Binary files /dev/null and b/collects/games/cards/hicolor/card-2-0.png differ
diff --git a/collects/games/cards/hicolor/card-2-1.png b/collects/games/cards/hicolor/card-2-1.png
new file mode 100644
index 0000000000..f33b640b1f
Binary files /dev/null and b/collects/games/cards/hicolor/card-2-1.png differ
diff --git a/collects/games/cards/hicolor/card-2-2.png b/collects/games/cards/hicolor/card-2-2.png
new file mode 100644
index 0000000000..871b727f1a
Binary files /dev/null and b/collects/games/cards/hicolor/card-2-2.png differ
diff --git a/collects/games/cards/hicolor/card-2-3.png b/collects/games/cards/hicolor/card-2-3.png
new file mode 100644
index 0000000000..4d0147cc9a
Binary files /dev/null and b/collects/games/cards/hicolor/card-2-3.png differ
diff --git a/collects/games/cards/hicolor/card-3-0.png b/collects/games/cards/hicolor/card-3-0.png
new file mode 100644
index 0000000000..6b73ba0628
Binary files /dev/null and b/collects/games/cards/hicolor/card-3-0.png differ
diff --git a/collects/games/cards/hicolor/card-3-1.png b/collects/games/cards/hicolor/card-3-1.png
new file mode 100644
index 0000000000..de54131f6a
Binary files /dev/null and b/collects/games/cards/hicolor/card-3-1.png differ
diff --git a/collects/games/cards/hicolor/card-3-2.png b/collects/games/cards/hicolor/card-3-2.png
new file mode 100644
index 0000000000..603c23d14a
Binary files /dev/null and b/collects/games/cards/hicolor/card-3-2.png differ
diff --git a/collects/games/cards/hicolor/card-3-3.png b/collects/games/cards/hicolor/card-3-3.png
new file mode 100644
index 0000000000..3ed48fbc4b
Binary files /dev/null and b/collects/games/cards/hicolor/card-3-3.png differ
diff --git a/collects/games/cards/hicolor/card-4-0.png b/collects/games/cards/hicolor/card-4-0.png
new file mode 100644
index 0000000000..c33c9e8a78
Binary files /dev/null and b/collects/games/cards/hicolor/card-4-0.png differ
diff --git a/collects/games/cards/hicolor/card-4-1.png b/collects/games/cards/hicolor/card-4-1.png
new file mode 100644
index 0000000000..45d2fca9b4
Binary files /dev/null and b/collects/games/cards/hicolor/card-4-1.png differ
diff --git a/collects/games/cards/hicolor/card-4-2.png b/collects/games/cards/hicolor/card-4-2.png
new file mode 100644
index 0000000000..8468ae525f
Binary files /dev/null and b/collects/games/cards/hicolor/card-4-2.png differ
diff --git a/collects/games/cards/hicolor/card-4-3.png b/collects/games/cards/hicolor/card-4-3.png
new file mode 100644
index 0000000000..2340a3fbd8
Binary files /dev/null and b/collects/games/cards/hicolor/card-4-3.png differ
diff --git a/collects/games/cards/hicolor/card-5-0.png b/collects/games/cards/hicolor/card-5-0.png
new file mode 100644
index 0000000000..fa42c9fc8c
Binary files /dev/null and b/collects/games/cards/hicolor/card-5-0.png differ
diff --git a/collects/games/cards/hicolor/card-5-1.png b/collects/games/cards/hicolor/card-5-1.png
new file mode 100644
index 0000000000..ca11f7657f
Binary files /dev/null and b/collects/games/cards/hicolor/card-5-1.png differ
diff --git a/collects/games/cards/hicolor/card-5-2.png b/collects/games/cards/hicolor/card-5-2.png
new file mode 100644
index 0000000000..2ebec82033
Binary files /dev/null and b/collects/games/cards/hicolor/card-5-2.png differ
diff --git a/collects/games/cards/hicolor/card-5-3.png b/collects/games/cards/hicolor/card-5-3.png
new file mode 100644
index 0000000000..388b33f391
Binary files /dev/null and b/collects/games/cards/hicolor/card-5-3.png differ
diff --git a/collects/games/cards/hicolor/card-6-0.png b/collects/games/cards/hicolor/card-6-0.png
new file mode 100644
index 0000000000..36aff252a0
Binary files /dev/null and b/collects/games/cards/hicolor/card-6-0.png differ
diff --git a/collects/games/cards/hicolor/card-6-1.png b/collects/games/cards/hicolor/card-6-1.png
new file mode 100644
index 0000000000..0e34cc4e8f
Binary files /dev/null and b/collects/games/cards/hicolor/card-6-1.png differ
diff --git a/collects/games/cards/hicolor/card-6-2.png b/collects/games/cards/hicolor/card-6-2.png
new file mode 100644
index 0000000000..0be31dd9fc
Binary files /dev/null and b/collects/games/cards/hicolor/card-6-2.png differ
diff --git a/collects/games/cards/hicolor/card-6-3.png b/collects/games/cards/hicolor/card-6-3.png
new file mode 100644
index 0000000000..cae981bf58
Binary files /dev/null and b/collects/games/cards/hicolor/card-6-3.png differ
diff --git a/collects/games/cards/hicolor/card-7-0.png b/collects/games/cards/hicolor/card-7-0.png
new file mode 100644
index 0000000000..cd31450107
Binary files /dev/null and b/collects/games/cards/hicolor/card-7-0.png differ
diff --git a/collects/games/cards/hicolor/card-7-1.png b/collects/games/cards/hicolor/card-7-1.png
new file mode 100644
index 0000000000..f6609e4cc3
Binary files /dev/null and b/collects/games/cards/hicolor/card-7-1.png differ
diff --git a/collects/games/cards/hicolor/card-7-2.png b/collects/games/cards/hicolor/card-7-2.png
new file mode 100644
index 0000000000..2eba93f744
Binary files /dev/null and b/collects/games/cards/hicolor/card-7-2.png differ
diff --git a/collects/games/cards/hicolor/card-7-3.png b/collects/games/cards/hicolor/card-7-3.png
new file mode 100644
index 0000000000..9cc34988f9
Binary files /dev/null and b/collects/games/cards/hicolor/card-7-3.png differ
diff --git a/collects/games/cards/hicolor/card-8-0.png b/collects/games/cards/hicolor/card-8-0.png
new file mode 100644
index 0000000000..635cc23c04
Binary files /dev/null and b/collects/games/cards/hicolor/card-8-0.png differ
diff --git a/collects/games/cards/hicolor/card-8-1.png b/collects/games/cards/hicolor/card-8-1.png
new file mode 100644
index 0000000000..038cb00085
Binary files /dev/null and b/collects/games/cards/hicolor/card-8-1.png differ
diff --git a/collects/games/cards/hicolor/card-8-2.png b/collects/games/cards/hicolor/card-8-2.png
new file mode 100644
index 0000000000..43ee470c88
Binary files /dev/null and b/collects/games/cards/hicolor/card-8-2.png differ
diff --git a/collects/games/cards/hicolor/card-8-3.png b/collects/games/cards/hicolor/card-8-3.png
new file mode 100644
index 0000000000..2b44fe0ee4
Binary files /dev/null and b/collects/games/cards/hicolor/card-8-3.png differ
diff --git a/collects/games/cards/hicolor/card-9-0.png b/collects/games/cards/hicolor/card-9-0.png
new file mode 100644
index 0000000000..02b6143371
Binary files /dev/null and b/collects/games/cards/hicolor/card-9-0.png differ
diff --git a/collects/games/cards/hicolor/card-9-1.png b/collects/games/cards/hicolor/card-9-1.png
new file mode 100644
index 0000000000..ea8c8eff8e
Binary files /dev/null and b/collects/games/cards/hicolor/card-9-1.png differ
diff --git a/collects/games/cards/hicolor/card-9-2.png b/collects/games/cards/hicolor/card-9-2.png
new file mode 100644
index 0000000000..1185e15163
Binary files /dev/null and b/collects/games/cards/hicolor/card-9-2.png differ
diff --git a/collects/games/cards/hicolor/card-9-3.png b/collects/games/cards/hicolor/card-9-3.png
new file mode 100644
index 0000000000..671d1ce613
Binary files /dev/null and b/collects/games/cards/hicolor/card-9-3.png differ
diff --git a/collects/games/cards/hicolor/card-back.png b/collects/games/cards/hicolor/card-back.png
new file mode 100644
index 0000000000..af05e8ce6c
Binary files /dev/null and b/collects/games/cards/hicolor/card-back.png differ
diff --git a/collects/games/cards/info.ss b/collects/games/cards/info.ss
new file mode 100644
index 0000000000..59fb938463
--- /dev/null
+++ b/collects/games/cards/info.ss
@@ -0,0 +1,3 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Game Cards")
+  (define doc.txt "doc.txt"))
diff --git a/collects/games/cards/locolor/card-0-0.png b/collects/games/cards/locolor/card-0-0.png
new file mode 100644
index 0000000000..ca96360eb1
Binary files /dev/null and b/collects/games/cards/locolor/card-0-0.png differ
diff --git a/collects/games/cards/locolor/card-0-1.png b/collects/games/cards/locolor/card-0-1.png
new file mode 100644
index 0000000000..96d81d0806
Binary files /dev/null and b/collects/games/cards/locolor/card-0-1.png differ
diff --git a/collects/games/cards/locolor/card-0-2.png b/collects/games/cards/locolor/card-0-2.png
new file mode 100644
index 0000000000..8b8375a41b
Binary files /dev/null and b/collects/games/cards/locolor/card-0-2.png differ
diff --git a/collects/games/cards/locolor/card-0-3.png b/collects/games/cards/locolor/card-0-3.png
new file mode 100644
index 0000000000..5403e59fb1
Binary files /dev/null and b/collects/games/cards/locolor/card-0-3.png differ
diff --git a/collects/games/cards/locolor/card-1-0.png b/collects/games/cards/locolor/card-1-0.png
new file mode 100644
index 0000000000..b095ca4207
Binary files /dev/null and b/collects/games/cards/locolor/card-1-0.png differ
diff --git a/collects/games/cards/locolor/card-1-1.png b/collects/games/cards/locolor/card-1-1.png
new file mode 100644
index 0000000000..de41ad1d14
Binary files /dev/null and b/collects/games/cards/locolor/card-1-1.png differ
diff --git a/collects/games/cards/locolor/card-1-2.png b/collects/games/cards/locolor/card-1-2.png
new file mode 100644
index 0000000000..ebd3188a32
Binary files /dev/null and b/collects/games/cards/locolor/card-1-2.png differ
diff --git a/collects/games/cards/locolor/card-1-3.png b/collects/games/cards/locolor/card-1-3.png
new file mode 100644
index 0000000000..03d4d08a24
Binary files /dev/null and b/collects/games/cards/locolor/card-1-3.png differ
diff --git a/collects/games/cards/locolor/card-10-0.png b/collects/games/cards/locolor/card-10-0.png
new file mode 100644
index 0000000000..5c5ba2ca1e
Binary files /dev/null and b/collects/games/cards/locolor/card-10-0.png differ
diff --git a/collects/games/cards/locolor/card-10-1.png b/collects/games/cards/locolor/card-10-1.png
new file mode 100644
index 0000000000..ac042d41b3
Binary files /dev/null and b/collects/games/cards/locolor/card-10-1.png differ
diff --git a/collects/games/cards/locolor/card-10-2.png b/collects/games/cards/locolor/card-10-2.png
new file mode 100644
index 0000000000..91d889d878
Binary files /dev/null and b/collects/games/cards/locolor/card-10-2.png differ
diff --git a/collects/games/cards/locolor/card-10-3.png b/collects/games/cards/locolor/card-10-3.png
new file mode 100644
index 0000000000..5bb5388e76
Binary files /dev/null and b/collects/games/cards/locolor/card-10-3.png differ
diff --git a/collects/games/cards/locolor/card-11-0.png b/collects/games/cards/locolor/card-11-0.png
new file mode 100644
index 0000000000..3527d165e0
Binary files /dev/null and b/collects/games/cards/locolor/card-11-0.png differ
diff --git a/collects/games/cards/locolor/card-11-1.png b/collects/games/cards/locolor/card-11-1.png
new file mode 100644
index 0000000000..2bf80461e5
Binary files /dev/null and b/collects/games/cards/locolor/card-11-1.png differ
diff --git a/collects/games/cards/locolor/card-11-2.png b/collects/games/cards/locolor/card-11-2.png
new file mode 100644
index 0000000000..9b2ab6d8d8
Binary files /dev/null and b/collects/games/cards/locolor/card-11-2.png differ
diff --git a/collects/games/cards/locolor/card-11-3.png b/collects/games/cards/locolor/card-11-3.png
new file mode 100644
index 0000000000..3d615bcdc0
Binary files /dev/null and b/collects/games/cards/locolor/card-11-3.png differ
diff --git a/collects/games/cards/locolor/card-12-0.png b/collects/games/cards/locolor/card-12-0.png
new file mode 100644
index 0000000000..03b9157324
Binary files /dev/null and b/collects/games/cards/locolor/card-12-0.png differ
diff --git a/collects/games/cards/locolor/card-12-1.png b/collects/games/cards/locolor/card-12-1.png
new file mode 100644
index 0000000000..43ef07a220
Binary files /dev/null and b/collects/games/cards/locolor/card-12-1.png differ
diff --git a/collects/games/cards/locolor/card-12-2.png b/collects/games/cards/locolor/card-12-2.png
new file mode 100644
index 0000000000..2f5af1d584
Binary files /dev/null and b/collects/games/cards/locolor/card-12-2.png differ
diff --git a/collects/games/cards/locolor/card-12-3.png b/collects/games/cards/locolor/card-12-3.png
new file mode 100644
index 0000000000..e36334f294
Binary files /dev/null and b/collects/games/cards/locolor/card-12-3.png differ
diff --git a/collects/games/cards/locolor/card-2-0.png b/collects/games/cards/locolor/card-2-0.png
new file mode 100644
index 0000000000..c7a302db79
Binary files /dev/null and b/collects/games/cards/locolor/card-2-0.png differ
diff --git a/collects/games/cards/locolor/card-2-1.png b/collects/games/cards/locolor/card-2-1.png
new file mode 100644
index 0000000000..2843046372
Binary files /dev/null and b/collects/games/cards/locolor/card-2-1.png differ
diff --git a/collects/games/cards/locolor/card-2-2.png b/collects/games/cards/locolor/card-2-2.png
new file mode 100644
index 0000000000..4688afc91c
Binary files /dev/null and b/collects/games/cards/locolor/card-2-2.png differ
diff --git a/collects/games/cards/locolor/card-2-3.png b/collects/games/cards/locolor/card-2-3.png
new file mode 100644
index 0000000000..114ba5d8e7
Binary files /dev/null and b/collects/games/cards/locolor/card-2-3.png differ
diff --git a/collects/games/cards/locolor/card-3-0.png b/collects/games/cards/locolor/card-3-0.png
new file mode 100644
index 0000000000..dbd4fe33ae
Binary files /dev/null and b/collects/games/cards/locolor/card-3-0.png differ
diff --git a/collects/games/cards/locolor/card-3-1.png b/collects/games/cards/locolor/card-3-1.png
new file mode 100644
index 0000000000..5382b0426b
Binary files /dev/null and b/collects/games/cards/locolor/card-3-1.png differ
diff --git a/collects/games/cards/locolor/card-3-2.png b/collects/games/cards/locolor/card-3-2.png
new file mode 100644
index 0000000000..fe5ed6f77b
Binary files /dev/null and b/collects/games/cards/locolor/card-3-2.png differ
diff --git a/collects/games/cards/locolor/card-3-3.png b/collects/games/cards/locolor/card-3-3.png
new file mode 100644
index 0000000000..4ba24d8224
Binary files /dev/null and b/collects/games/cards/locolor/card-3-3.png differ
diff --git a/collects/games/cards/locolor/card-4-0.png b/collects/games/cards/locolor/card-4-0.png
new file mode 100644
index 0000000000..fa46214884
Binary files /dev/null and b/collects/games/cards/locolor/card-4-0.png differ
diff --git a/collects/games/cards/locolor/card-4-1.png b/collects/games/cards/locolor/card-4-1.png
new file mode 100644
index 0000000000..6ead57e72d
Binary files /dev/null and b/collects/games/cards/locolor/card-4-1.png differ
diff --git a/collects/games/cards/locolor/card-4-2.png b/collects/games/cards/locolor/card-4-2.png
new file mode 100644
index 0000000000..98cfd151cf
Binary files /dev/null and b/collects/games/cards/locolor/card-4-2.png differ
diff --git a/collects/games/cards/locolor/card-4-3.png b/collects/games/cards/locolor/card-4-3.png
new file mode 100644
index 0000000000..0a0928b9c9
Binary files /dev/null and b/collects/games/cards/locolor/card-4-3.png differ
diff --git a/collects/games/cards/locolor/card-5-0.png b/collects/games/cards/locolor/card-5-0.png
new file mode 100644
index 0000000000..6df5317d8d
Binary files /dev/null and b/collects/games/cards/locolor/card-5-0.png differ
diff --git a/collects/games/cards/locolor/card-5-1.png b/collects/games/cards/locolor/card-5-1.png
new file mode 100644
index 0000000000..f2f0efc30e
Binary files /dev/null and b/collects/games/cards/locolor/card-5-1.png differ
diff --git a/collects/games/cards/locolor/card-5-2.png b/collects/games/cards/locolor/card-5-2.png
new file mode 100644
index 0000000000..5cdeb81e16
Binary files /dev/null and b/collects/games/cards/locolor/card-5-2.png differ
diff --git a/collects/games/cards/locolor/card-5-3.png b/collects/games/cards/locolor/card-5-3.png
new file mode 100644
index 0000000000..facb63a6b4
Binary files /dev/null and b/collects/games/cards/locolor/card-5-3.png differ
diff --git a/collects/games/cards/locolor/card-6-0.png b/collects/games/cards/locolor/card-6-0.png
new file mode 100644
index 0000000000..422d458bc5
Binary files /dev/null and b/collects/games/cards/locolor/card-6-0.png differ
diff --git a/collects/games/cards/locolor/card-6-1.png b/collects/games/cards/locolor/card-6-1.png
new file mode 100644
index 0000000000..6a207df32a
Binary files /dev/null and b/collects/games/cards/locolor/card-6-1.png differ
diff --git a/collects/games/cards/locolor/card-6-2.png b/collects/games/cards/locolor/card-6-2.png
new file mode 100644
index 0000000000..23055414ea
Binary files /dev/null and b/collects/games/cards/locolor/card-6-2.png differ
diff --git a/collects/games/cards/locolor/card-6-3.png b/collects/games/cards/locolor/card-6-3.png
new file mode 100644
index 0000000000..9676321829
Binary files /dev/null and b/collects/games/cards/locolor/card-6-3.png differ
diff --git a/collects/games/cards/locolor/card-7-0.png b/collects/games/cards/locolor/card-7-0.png
new file mode 100644
index 0000000000..22bef31008
Binary files /dev/null and b/collects/games/cards/locolor/card-7-0.png differ
diff --git a/collects/games/cards/locolor/card-7-1.png b/collects/games/cards/locolor/card-7-1.png
new file mode 100644
index 0000000000..8a04ede3d4
Binary files /dev/null and b/collects/games/cards/locolor/card-7-1.png differ
diff --git a/collects/games/cards/locolor/card-7-2.png b/collects/games/cards/locolor/card-7-2.png
new file mode 100644
index 0000000000..36bf132fe9
Binary files /dev/null and b/collects/games/cards/locolor/card-7-2.png differ
diff --git a/collects/games/cards/locolor/card-7-3.png b/collects/games/cards/locolor/card-7-3.png
new file mode 100644
index 0000000000..3b97c46de4
Binary files /dev/null and b/collects/games/cards/locolor/card-7-3.png differ
diff --git a/collects/games/cards/locolor/card-8-0.png b/collects/games/cards/locolor/card-8-0.png
new file mode 100644
index 0000000000..52798b24bc
Binary files /dev/null and b/collects/games/cards/locolor/card-8-0.png differ
diff --git a/collects/games/cards/locolor/card-8-1.png b/collects/games/cards/locolor/card-8-1.png
new file mode 100644
index 0000000000..cb12ced8e9
Binary files /dev/null and b/collects/games/cards/locolor/card-8-1.png differ
diff --git a/collects/games/cards/locolor/card-8-2.png b/collects/games/cards/locolor/card-8-2.png
new file mode 100644
index 0000000000..4b5cc3d299
Binary files /dev/null and b/collects/games/cards/locolor/card-8-2.png differ
diff --git a/collects/games/cards/locolor/card-8-3.png b/collects/games/cards/locolor/card-8-3.png
new file mode 100644
index 0000000000..f9f136ec75
Binary files /dev/null and b/collects/games/cards/locolor/card-8-3.png differ
diff --git a/collects/games/cards/locolor/card-9-0.png b/collects/games/cards/locolor/card-9-0.png
new file mode 100644
index 0000000000..6942c12520
Binary files /dev/null and b/collects/games/cards/locolor/card-9-0.png differ
diff --git a/collects/games/cards/locolor/card-9-1.png b/collects/games/cards/locolor/card-9-1.png
new file mode 100644
index 0000000000..73e901166a
Binary files /dev/null and b/collects/games/cards/locolor/card-9-1.png differ
diff --git a/collects/games/cards/locolor/card-9-2.png b/collects/games/cards/locolor/card-9-2.png
new file mode 100644
index 0000000000..b976164f83
Binary files /dev/null and b/collects/games/cards/locolor/card-9-2.png differ
diff --git a/collects/games/cards/locolor/card-9-3.png b/collects/games/cards/locolor/card-9-3.png
new file mode 100644
index 0000000000..49fb89ed3a
Binary files /dev/null and b/collects/games/cards/locolor/card-9-3.png differ
diff --git a/collects/games/cards/locolor/card-back.png b/collects/games/cards/locolor/card-back.png
new file mode 100644
index 0000000000..0db7385157
Binary files /dev/null and b/collects/games/cards/locolor/card-back.png differ
diff --git a/collects/games/cards/main.ss b/collects/games/cards/main.ss
new file mode 100644
index 0000000000..e754cb932e
--- /dev/null
+++ b/collects/games/cards/main.ss
@@ -0,0 +1,15 @@
+
+(module main mzscheme
+  (require (lib "class.ss")
+	   (lib "etc.ss")
+	   "make-cards.ss"
+	   "classes.ss")
+
+  (provide make-table make-deck make-card)
+  
+  (define make-table
+    (opt-lambda ([title "Cards"][w 7][h 3])
+      (make-object table% title w h)))
+
+  (define (make-deck)
+    (map (lambda (l) (send l copy)) deck-of-cards)))
diff --git a/collects/games/cards/make-cards.ss b/collects/games/cards/make-cards.ss
new file mode 100644
index 0000000000..d90d735b34
--- /dev/null
+++ b/collects/games/cards/make-cards.ss
@@ -0,0 +1,98 @@
+
+(module make-cards mzscheme
+  (require (lib "class.ss")
+	   (prefix mred: (lib "mred.ss" "mred"))
+	   (prefix card-class: "card-class.ss"))
+  
+  (provide back deck-of-cards make-card)
+
+  (define (get-bitmap file)
+    (make-object mred:bitmap% file))
+
+  (define (make-semi bm-in w h)
+    (let* ([bm (make-object mred:bitmap% (floor (/ w 2)) h)]
+	   [mdc (make-object mred:bitmap-dc%)])
+      (send mdc set-bitmap bm)
+      (send mdc set-scale 0.5 1)
+      (send mdc draw-bitmap bm-in 0 0)
+      (send mdc set-bitmap #f)
+      bm))
+
+  (define (make-dim bm-in)
+    (let ([w (send bm-in get-width)]
+	  [h (send bm-in get-height)])
+      (let* ([bm (make-object mred:bitmap% w h)]
+	     [mdc (make-object mred:bitmap-dc% bm)])
+	(send mdc draw-bitmap bm-in 0 0)
+	(let* ([len (* w h 4)]
+	       [b (make-bytes len)])
+	  (send mdc get-argb-pixels 0 0 w h b)
+	  (let loop ([i 0])
+	    (unless (= i len)
+	      (bytes-set! b i (quotient (* 3 (bytes-ref b i)) 4))
+	      (loop (add1 i))))
+	  (send mdc set-argb-pixels 0 0 w h b))
+	(send mdc set-bitmap #f)
+	bm)))
+
+  (define here 
+    (let ([cp (collection-path "games" "cards")])
+      (lambda (file)
+	(build-path cp 
+		    (if ((mred:get-display-depth)  . <= . 8)
+			"locolor"
+			"hicolor")
+		    file))))
+
+  (define back (get-bitmap (here "card-back.png")))
+
+  (define semi-back 
+    (let ([w (send back get-width)]
+	  [h (send back get-height)])
+      (make-semi back w h)))
+
+  (define dim-back
+    (make-dim back))
+
+  (define deck-of-cards
+    (let* ([w (send back get-width)]
+	   [h (send back get-height)])
+      (let sloop ([suit 4])
+	(if (zero? suit)
+	    null
+	    (let vloop ([value 13])
+	      (sleep)
+	      (if (zero? value)
+		  (sloop (sub1 suit))
+		  (let ([front (get-bitmap
+				(here 
+				 (format "card-~a-~a.png"
+					 (sub1 value)
+					 (sub1 suit))))])
+		    (cons (make-object card-class:card%
+			    suit
+			    value
+			    w h
+			    front back
+			    (make-semi front w h) semi-back
+			    (lambda () (make-dim front))
+			    (lambda () dim-back))
+			  (vloop (sub1 value))))))))))
+  
+  (define (make-card front-bm back-bm suit-id value)
+    (let ([w (send back get-width)]
+	  [h (send back get-height)])
+      (make-object card-class:card%
+		   suit-id
+		   value
+		   w h
+		   front-bm (or back-bm back)
+		   (make-semi front-bm w h)
+		   (if back-bm 
+		       (make-semi back-bm w h)
+		       semi-back)
+		   (lambda () (make-dim front-bm))
+		   (lambda ()
+		     (if back-bm 
+			 (make-dim back)
+			 dim-back))))))
\ No newline at end of file
diff --git a/collects/games/cards/region.ss b/collects/games/cards/region.ss
new file mode 100644
index 0000000000..3606953dd1
--- /dev/null
+++ b/collects/games/cards/region.ss
@@ -0,0 +1,75 @@
+
+(module region mzscheme
+  (provide region
+	   struct:region make-region
+	   region? region-x region-y region-w region-h 
+	   region-label region-callback 
+	   
+	   make-button-region make-background-region
+
+	   region-interactive-callback
+	   region-paint-callback
+	   region-button? region-hilite? region-decided-start? region-can-select?
+	   set-region-hilite?! set-region-decided-start?! set-region-can-select?!
+	   set-region-callback!
+	   set-region-interactive-callback!)
+
+  (define-syntax region
+    (list-immutable #'struct:region
+		    #'make-region
+		    #'region?
+		    (list-immutable
+		     #'region-callback #'region-label 
+		     #'region-h #'region-w 
+		     #'region-y #'region-x 
+		     #f)
+		    (list-immutable #f)
+		    #t))
+
+  (define-values (struct:region make-region region? region-get region-set!)
+    (make-struct-type 'region #f 6 6 #f))
+
+  (define region-x (make-struct-field-accessor region-get 0))
+  (define region-y (make-struct-field-accessor region-get 1))
+  (define region-w (make-struct-field-accessor region-get 2))
+  (define region-h (make-struct-field-accessor region-get 3))
+  (define region-label (make-struct-field-accessor region-get 4))
+  (define region-callback (make-struct-field-accessor region-get 5))
+
+  (define set-region-callback! (make-struct-field-mutator region-set! 5))
+
+  (define region-interactive-callback (make-struct-field-accessor region-get 6))
+  (define region-paint-callback (make-struct-field-accessor region-get 7))
+  (define region-button? (make-struct-field-accessor region-get 8))
+  (define region-hilite? (make-struct-field-accessor region-get 9))
+  (define region-decided-start? (make-struct-field-accessor region-get 10))
+  (define region-can-select? (make-struct-field-accessor region-get 11))
+
+  (define set-region-interactive-callback! (make-struct-field-mutator region-set! 6))
+  (define set-region-paint-callback! (make-struct-field-mutator region-set! 7))
+  (define set-region-button?! (make-struct-field-mutator region-set! 8))
+  (define set-region-hilite?! (make-struct-field-mutator region-set! 9))
+  (define set-region-decided-start?! (make-struct-field-mutator region-set! 10))
+  (define set-region-can-select?! (make-struct-field-mutator region-set! 11))
+
+  (define create-region
+    (lambda (x y w h label callback)
+      (unless (not (or (negative? w) (negative? h)))
+	(error 'make-region "bad region size: ~a x ~a" w h))
+      (make-region x y w h label callback #f #f #f #f #f #f)))
+
+  (define make-background-region
+    (lambda (x y w h paint-callback)
+      (unless (not (or (negative? w) (negative? h)))
+	(error 'make-background-region "bad region size: ~a x ~a" w h))
+      (let ([r (make-region x y w h #f #f)])
+	(set-region-paint-callback! r paint-callback)
+	r)))
+
+  (define make-button-region
+    (lambda (x y w h label callback)
+      (unless (not (or (negative? w) (negative? h)))
+	(error 'make-button-region "bad region size: ~a x ~a" w h))
+      (let ([r (make-region x y w h label callback)])
+	(set-region-button?! r #t)
+	r))))
diff --git a/collects/games/cards/snipclass.ss b/collects/games/cards/snipclass.ss
new file mode 100644
index 0000000000..ea87de1e63
--- /dev/null
+++ b/collects/games/cards/snipclass.ss
@@ -0,0 +1,10 @@
+
+(module snipclass mzscheme
+  (require (lib "mred.ss" "mred")
+	   (lib "class.ss"))
+  (provide sc)
+
+  (define sc (make-object snip-class%))
+  (send sc set-classname "card")
+  (send (get-the-snip-class-list) add sc))
+
diff --git a/collects/games/cards/utils.ss b/collects/games/cards/utils.ss
new file mode 100644
index 0000000000..b2261c2ab4
--- /dev/null
+++ b/collects/games/cards/utils.ss
@@ -0,0 +1,26 @@
+
+(module utils mzscheme
+  (provide shuffle-list)
+
+  (define shuffle-list 
+   (lambda (l c)
+     (if (zero? c)
+	 l
+	 (let-values ([(a b)
+		       (let ([half (floor (/ (length l) 2))])
+			 (values
+			  (let loop ([l l][n half])
+			    (if (zero? n)
+				null
+				(cons (car l) (loop (cdr l) (sub1 n)))))
+			  (list-tail l half)))])
+	   (shuffle-list
+	    (let loop ([a a][b b][l null])
+	      (cond
+	       [(null? a) (append (reverse b) l)]
+	       [(null? b) (append (reverse a) l)]
+	       [(zero? (random 2))
+		(loop (cdr a) b (cons (car a) l))]
+	       [else
+		(loop a (cdr b) (cons (car b) l))]))
+	    (sub1 c)))))))
\ No newline at end of file
diff --git a/collects/games/checkers/checkers.png b/collects/games/checkers/checkers.png
new file mode 100644
index 0000000000..72b3057955
Binary files /dev/null and b/collects/games/checkers/checkers.png differ
diff --git a/collects/games/checkers/checkers.ss b/collects/games/checkers/checkers.ss
new file mode 100644
index 0000000000..8f6e555a0c
--- /dev/null
+++ b/collects/games/checkers/checkers.ss
@@ -0,0 +1,484 @@
+(module checkers mzscheme
+  (require (lib "gl-board.ss" "games" "gl-board-game")
+           (lib "class.ss")
+           (lib "math.ss")
+           (lib "mred.ss" "mred")
+           (lib "gl-vectors.ss" "sgl")
+           (prefix gl- (lib "sgl.ss" "sgl"))
+           (lib "gl.ss" "sgl")
+           (lib "array.ss" "srfi" "25")
+           (lib "unit.ss")
+           "honu-bitmaps.ss")
+  
+  (provide game-unit)
+
+  (define path (collection-path "games" "checkers"))
+  
+  (define-struct image (width height rgba))
+  
+  (define (argb->rgba argb)
+    (let* ((length (bytes-length argb))
+           (rgba (make-gl-ubyte-vector length)))
+      (let loop ((i 0))
+        (when (< i length)
+          (gl-vector-set! rgba (+ i 0) (bytes-ref argb (+ i 1)))
+          (gl-vector-set! rgba (+ i 1) (bytes-ref argb (+ i 2)))
+          (gl-vector-set! rgba (+ i 2) (bytes-ref argb (+ i 3)))
+          (gl-vector-set! rgba (+ i 3) (bytes-ref argb (+ i 0)))
+          (loop (+ i 4))))
+      rgba))
+  
+  (define (bitmap->argb bmp)
+    (let* ((width (send bmp get-width))
+           (height (send bmp get-height))
+           (argb (make-bytes (* 4 width height) 255))
+           (dc (make-object bitmap-dc% bmp)))
+      (send dc get-argb-pixels 0 0 width height argb #f)
+      (when (send bmp get-loaded-mask)
+        (send dc set-bitmap (send bmp get-loaded-mask))
+        (send dc get-argb-pixels 0 0 width height argb #t))
+      (send dc set-bitmap #f)
+      argb))
+  
+  (define (bitmap->image bmp)
+    (make-image (send bmp get-width) (send bmp get-height)
+                (argb->rgba (bitmap->argb bmp))))
+
+  (define (file->image file)
+    (bitmap->image (make-object bitmap% file)))
+  
+  (define light-square-img (file->image (build-path path "light.jpg")))
+  (define light-square-color (gl-float-vector .7216 .6471 .5176 1))
+  (define dark-square-img (file->image (build-path path "dark.jpg")))
+  (define dark-square-color (gl-float-vector .4745 .3569 .2627 1))
+  
+  (define (color-name->vector name darken?)
+    (let ([color (send the-color-database find-color name)]
+          [adj (if darken? sqr values)])
+      (unless color
+        (error 'color-name->vector "could not find ~e" name))
+      (gl-float-vector (adj (/ (send color red) 255))
+                       (adj (/ (send color green) 255))
+                       (adj (/ (send color blue) 255))
+                       1.0)))
+  
+  (define light-checker-img (bitmap->image honu-down-bitmap))
+  (define dark-checker-img (bitmap->image honu-bitmap))
+  
+  (define-struct space-info (x y light?))
+  (define-struct piece-info (x y color king?) (make-inspector))
+  (define-struct moves (list forced-jump?))
+
+  (define checkers-view@
+    (unit
+      (import move)
+      (export add-space add-piece remove-piece move-piece set-turn show)
+
+      (define (get-space-draw-fn space)
+        (let* ((list-id (get-square-dl (space-info-light? space)
+                                       (send texture-box get-value)))
+               (sx (space-info-x space))
+               (sy (space-info-y space)))
+          (lambda ()
+            (gl-push-matrix)
+            (gl-translate sx sy 0)
+            (gl-call-list list-id)
+            (gl-pop-matrix))))
+      
+      (define (add-space space)
+        (send board add-space (get-space-draw-fn space) space))
+
+      (define (get-piece-draw-fn piece glow?)
+        (let ((list-id (get-checker-dl (eq? 'red (piece-info-color piece))
+                                       (piece-info-king? piece)
+                                       (send texture-box get-value))))
+          (if glow?
+              (lambda (for-shadow?)
+                (gl-material-v 'front 'emission (gl-float-vector 0.15 0.15 0.15 1.0))
+                (gl-call-list ((if for-shadow? cdr car) list-id))
+                (gl-material-v 'front 'emission (gl-float-vector 0.0 0.0 0.0 1.0)))
+              (lambda (for-shadow?)
+                (gl-call-list ((if for-shadow? cdr car) list-id))))))
+      
+      (define add-piece
+        (case-lambda
+          ((piece) (add-piece piece #f))
+          ((piece glow?)
+           (send board add-piece (+ .5 (piece-info-x piece)) (+ .5 (piece-info-y piece)) 0.0
+                 (get-piece-draw-fn piece glow?)
+                 piece))))
+          
+      (define (move-piece from to-x to-y)
+        (remove-piece from)
+        (add-piece (make-piece-info to-x to-y (piece-info-color from) (piece-info-king? from))))
+      
+      (define (remove-piece p)
+        (send board remove-piece p))
+
+      (define (internal-move old move-to)
+        (when (piece-info? old)
+          (move old move-to)))
+
+      (define (set-turn turn moves)
+	(let* ([pieces (send board get-pieces)])
+	  (for-each (lambda (p)
+                      (send board set-piece-draw p
+                            (get-piece-draw-fn p #f))
+                      (send board enable-piece p #f))
+		    pieces)
+	  (for-each (lambda (p)
+                      (send board set-piece-draw p
+                            (get-piece-draw-fn p #t))
+                      (send board enable-piece p #t))
+                    (moves-list moves)))
+	(send msg set-label
+	      (if (null? (moves-list moves))
+		  (format "~a wins!" (if (eq? turn 'red) "Black" "Red"))
+		  (format "~a's turn~a" 
+			  (if (eq? turn 'red) "Red" "Black")
+			  (if (moves-forced-jump? moves)
+			      " - must take jump"
+			      "")))))
+      
+      (define f (new frame% (label "Checkers") (width 800) (height 600)))
+      (define board
+        (new gl-board% (parent f) (who "Checkers")
+	     (min-x 0.0) (max-x 8.0) (min-y 0.0) (max-y 8.0)
+             (lift .35)
+             (move internal-move)))
+      (define hp (new horizontal-pane% (parent f) (stretchable-height #f)))
+      (define msg
+	(new message% (label "") (parent hp) (stretchable-width #t)))
+      (define texture-box
+        (new check-box% (label "Textured") (parent hp)
+             (callback
+              (lambda (box _)
+                (for-each
+                 (lambda (s)
+                   (send board set-space-draw s
+                         (get-space-draw-fn s)))
+                 (send board get-spaces))
+                (for-each
+                 (lambda (p)
+                   (send board set-piece-draw p
+                         (get-piece-draw-fn p (send board enabled? p))))
+                 (send board get-pieces))
+                (send board refresh)))))
+      (send texture-box set-value #t)
+                
+      (define q
+        (send board with-gl-context
+          (lambda () (gl-new-quadric))))
+
+      (define-values (dark-tex light-tex dark-checker-tex light-checker-tex)
+        (send board with-gl-context
+          (lambda ()
+            (let ((x (glGenTextures 4)))
+              (values
+               (gl-vector-ref x 0)
+               (gl-vector-ref x 1)
+               (gl-vector-ref x 2)
+               (gl-vector-ref x 3))))))
+      
+      (define (init-tex tex img)
+        (send board with-gl-context
+              (lambda ()
+                (glBindTexture GL_TEXTURE_2D tex)
+                (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR)
+                (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR)
+                (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP)
+                (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP)
+                (glTexImage2D GL_TEXTURE_2D 0 GL_RGBA (image-width img) (image-height img) 0
+                              GL_RGBA GL_UNSIGNED_BYTE (image-rgba img)))))
+      
+      (init-tex light-tex light-square-img)
+      (init-tex dark-tex dark-square-img)
+      (init-tex dark-checker-tex dark-checker-img)
+      (init-tex light-checker-tex light-checker-img)
+      
+      (define (make-piece-dl color height tex shadow?)
+        (send board with-gl-context
+              (lambda ()
+                (let ((list-id (gl-gen-lists 1)))
+                  (gl-quadric-draw-style q 'fill)
+                  (gl-quadric-normals q 'smooth)
+                  (gl-new-list list-id 'compile)
+                  
+                  (when shadow?
+                    (gl-disable 'lighting))
+                  (gl-material-v 'front 'specular (gl-float-vector 1.0 1.0 1.0 1.0))
+                  (gl-material 'front 'shininess 120.0)  
+                  
+                  (gl-material-v 'front 'ambient-and-diffuse color)
+                  (gl-cylinder q .35 .35 height 25 1)
+                  (gl-push-matrix)
+                  (gl-translate 0.0 0.0 height)
+                  
+                  (when (and tex (not shadow?))
+                    (gl-enable 'texture-2d)
+                    (glBindTexture GL_TEXTURE_2D tex)
+                    (glTexEnvf GL_TEXTURE_ENV GL_TEXTURE_ENV_MODE GL_DECAL)
+                    (gl-quadric-texture q #t))
+                  
+                  (gl-disk q 0.0 .35 25 1)
+                  
+                  (when (and tex (not shadow?))
+                    (gl-quadric-texture q #f)
+                    (glTexEnvf GL_TEXTURE_ENV GL_TEXTURE_ENV_MODE GL_MODULATE)
+                    (gl-disable 'texture-2d))
+                  
+                  (gl-pop-matrix)
+                  
+                  (when shadow?
+                    (gl-enable 'lighting))
+                  (gl-end-list)
+                  list-id))))
+
+      (define (make-tex-square-dl tex)
+        (send board with-gl-context
+          (lambda ()
+            (let ((list-id (gl-gen-lists 1)))
+              (gl-new-list list-id 'compile)
+              (gl-enable 'texture-2d)
+              (glBindTexture GL_TEXTURE_2D tex)
+              (gl-material-v 'front 'ambient-and-diffuse
+                             (gl-float-vector 1 1 1 1))
+              (gl-begin 'polygon)
+              (gl-tex-coord 0.0 0.0)
+              (gl-vertex 0.0 0.0 0.0)
+              (gl-tex-coord 1.0 0.0)
+              (gl-vertex 1.0 0.0 0.0)
+              (gl-tex-coord 1.0 1.0)
+              (gl-vertex 1.0 1.0 0.0)
+              (gl-tex-coord 0.0 1.0)
+              (gl-vertex 0.0 1.0 0.0)
+              (gl-end)
+              (gl-disable 'texture-2d)
+              (gl-end-list)
+              list-id))))
+
+      (define (make-square-dl color)
+        (send board with-gl-context
+          (lambda ()
+            (let ((list-id (gl-gen-lists 1)))
+              (gl-new-list list-id 'compile)
+              (gl-material-v 'front 'ambient-and-diffuse color)
+              (gl-begin 'polygon)
+              (gl-vertex 0.0 0.0 0.0)
+              (gl-vertex 1.0 0.0 0.0)
+              (gl-vertex 1.0 1.0 0.0)
+              (gl-vertex 0.0 1.0 0.0)
+              (gl-end)
+              (gl-end-list)
+              list-id))))
+      
+      (define checkers
+        (map
+         (lambda (x)
+           (let ((color (if (car x)
+                            (color-name->vector "firebrick" #t)
+                            (gl-float-vector 0.15 0.15 0.15 1.0)))
+                 (height (if (cadr x) .4 .2))
+                 (tex (if (caddr x) (if (car x) light-checker-tex dark-checker-tex) #f)))
+             (cons x (cons (make-piece-dl color height tex #f)
+                           (make-piece-dl color height tex #t)))))
+         '((#f #f #f)
+           (#f #f #t)
+           (#f #t #f)
+           (#f #t #t)
+           (#t #f #f)
+           (#t #f #t)
+           (#t #t #f)
+           (#t #t #t))))
+      (define (get-checker-dl light? king? tex?)
+        (cdr (assoc (list light? king? tex?) checkers)))
+        
+      (define dark-square (cons (make-tex-square-dl dark-tex)
+                                (make-square-dl dark-square-color)))
+      (define light-square (cons (make-tex-square-dl light-tex)
+                                 (make-square-dl light-square-color)))
+      (define (get-square-dl light? tex?)
+        (let ((getter (if tex? car cdr)))
+          (getter (if light? light-square dark-square))))
+                         
+      (define (show)
+        (send f show #t))))
+  
+  (define checkers-model@
+    (unit
+      (import add-space add-piece remove-piece move-piece set-turn)
+      (export move)
+
+      (define turn 'red)
+      (define board (make-array (shape 0 8 0 8) #f))
+      
+      (let loop ((i 0)
+                 (j 0))
+        (cond
+          ((and (< j 8) (< i 8))
+           (cond
+             ((even? (+ i j))
+              (add-space (make-space-info j i #f))
+              (cond
+                ((< i 3)
+                 (array-set! board j i (cons 'red #f))
+                 (add-piece (make-piece-info j i 'red #f)))
+                ((> i 4)
+                 (array-set! board j i (cons 'black #f))
+                 (add-piece (make-piece-info j i 'black #f)))))
+             (else
+              (add-space (make-space-info j i #t))))
+           (loop i (add1 j)))
+          ((< i 8) (loop (add1 i) 0))))
+
+      (define (other-color c)
+        (cond
+          ((eq? c 'red) 'black)
+          (else 'red)))
+      
+      (define (single-move-ok? direction from-x from-y to-x to-y)
+        (and (= to-y (+ direction from-y))
+             (= 1 (abs (- from-x to-x)))))
+
+      (define (can-move? direction from-x from-y)
+	(and (<= 0 (+ from-y direction) 7)
+	     (or (and (<= 0 (+ from-x 1) 7)
+		      (not (array-ref board (+ from-x 1) (+ from-y direction))))
+		 (and (<= 0 (+ from-x -1) 7)
+		      (not (array-ref board (+ from-x -1) (+ from-y direction)))))))
+      
+      (define (get-jumped-piece color direction from-x from-y to-x to-y)
+        (and (= to-y (+ direction direction from-y))
+             (= 2 (abs (- from-x to-x)))
+             (let* ((jumped-x (+ from-x (/ (- to-x from-x) 2)))
+                    (jumped-y (+ from-y direction))
+                    (jumped-piece (array-ref board jumped-x jumped-y)))
+               (and jumped-piece
+                    (eq? (other-color color) (car jumped-piece))
+                    (make-piece-info jumped-x jumped-y (car jumped-piece) (cdr jumped-piece))))))
+      
+      (define (can-jump? direction from-color from-x from-y)
+        (let ((to-y (+ direction direction from-y))
+              (to-x1 (+ from-x 2))
+              (to-x2 (- from-x 2)))
+          (and (<= 0 to-y 7)
+               (or (and (<= 0 to-x1 7)
+                        (not (array-ref board to-x1 to-y))
+                        (get-jumped-piece from-color direction
+                                          from-x from-y
+                                          to-x1 to-y))
+                   (and (<= 0 to-x2)
+                        (not (array-ref board to-x2 to-y))
+                        (get-jumped-piece from-color direction
+                                          from-x from-y
+                                          to-x2 to-y))))))
+      
+
+      (define (fold-board f v)
+	(let iloop ([i 0][v v])
+	  (if (= i 8)
+	      v
+	      (let jloop ([j 0][v v])
+		(if (= j 8)
+		    (iloop (add1 i) v)
+		    (jloop (add1 j) 
+			   (if (even? (+ i j)) 
+			       (f i j v)
+			       v))))))) 
+
+      (define (get-jump-moves)
+	(let ([direction (if (eq? turn 'red) 1 -1)])
+	  (fold-board
+	   (lambda (i j l)
+	     (let ([p (array-ref board i j)])
+	       (if (and p
+			(eq? (car p) turn)
+			(or (can-jump? direction turn i j)
+			    (and (cdr p)
+				 (can-jump? (- direction) turn i j))))
+		   (cons (make-piece-info i j turn (cdr p)) l)
+		   l)))
+	   null)))
+
+      (define (get-moves)
+	(let ([jumps (get-jump-moves)])
+	  (if (pair? jumps)
+	      (make-moves jumps #t)
+	      (make-moves
+	       (let ([direction (if (eq? turn 'red) 1 -1)])
+		 (fold-board
+		  (lambda (i j l)
+		    (let ([p (array-ref board i j)])
+		      (if (and p
+			       (eq? (car p) turn)
+			       (or (can-move? direction i j)
+				   (and (cdr p)
+					(can-move? (- direction) i j))))
+			  (cons (make-piece-info i j turn (cdr p)) l)
+			  l)))
+		  null))
+	       #f))))
+
+      (define (move from to)
+        (let* ((to-x (inexact->exact (floor (gl-vector-ref to 0))))
+               (to-y (inexact->exact (floor (gl-vector-ref to 1))))
+               (from-x (piece-info-x from))
+               (from-y (piece-info-y from))
+               (from-color (piece-info-color from))
+               (from-king? (piece-info-king? from))
+               (to-king? (or from-king?
+                             (if (eq? 'red from-color)
+                                 (= to-y 7)
+                                 (= to-y 0))))
+               (direction (if (eq? turn 'red) 1 -1)))
+          (when (and (eq? turn from-color)
+                     (<= 0 to-x 7)
+                     (<= 0 to-y 7)
+                     (not (array-ref board to-x to-y)))
+            (cond
+              ((and (null? (get-jump-moves))
+		    (or (single-move-ok? direction from-x from-y to-x to-y)
+			(and from-king?
+			     (single-move-ok? (- direction) from-x from-y to-x to-y))))
+	       (move-piece from to-x to-y)
+               (set! turn (other-color from-color))
+               (array-set! board to-x to-y (cons from-color to-king?))
+               (array-set! board from-x from-y #f)
+               (when (and to-king? (not from-king?))
+                 (remove-piece (make-piece-info to-x to-y from-color from-king?))
+                 (add-piece (make-piece-info to-x to-y from-color to-king?)))
+	       (set-turn turn (get-moves)))
+              ((or (get-jumped-piece from-color direction from-x from-y to-x to-y)
+		   (and from-king?
+			(get-jumped-piece from-color (- direction) from-x from-y to-x to-y)))
+               =>
+               (lambda (j)
+                 (remove-piece j)
+                 (move-piece from to-x to-y)
+                 (array-set! board (piece-info-x j) (piece-info-y j) #f)
+                 (array-set! board from-x from-y #f)
+                 (array-set! board to-x to-y (cons from-color to-king?))
+                 (when (and to-king? (not from-king?))
+                   (remove-piece (make-piece-info to-x to-y from-color from-king?))
+                   (add-piece (make-piece-info to-x to-y from-color to-king?)))
+                 (cond
+                   ((or (can-jump? direction from-color to-x to-y)
+                        (and from-king?
+                             (can-jump? (- direction) from-color to-x to-y)))
+                    (set-turn turn (make-moves (list (make-piece-info to-x to-y from-color to-king?)) #t)))
+                   (else
+                    (set! turn (other-color from-color))
+                    (set-turn turn (get-moves))))))))))
+
+      (set-turn turn (get-moves))
+      ))
+              
+  (define game-unit
+   (compound-unit 
+     (import)
+     (link 
+      (VIEW (checkers-view@ (MODEL move)))
+      (MODEL (checkers-model@ (VIEW add-space add-piece remove-piece move-piece set-turn)))
+      (SHOW ((unit (import show) (export) (show)) (VIEW show))))
+     (export)))
+  )
diff --git a/collects/games/checkers/dark.jpg b/collects/games/checkers/dark.jpg
new file mode 100644
index 0000000000..c871229316
Binary files /dev/null and b/collects/games/checkers/dark.jpg differ
diff --git a/collects/games/checkers/honu-bitmaps.ss b/collects/games/checkers/honu-bitmaps.ss
new file mode 100644
index 0000000000..b685419618
--- /dev/null
+++ b/collects/games/checkers/honu-bitmaps.ss
@@ -0,0 +1,427 @@
+(module honu-bitmaps mzscheme
+  (require (lib "math.ss")
+           (lib "etc.ss")
+           (lib "mred.ss" "mred")
+           (lib "class.ss"))
+
+  (provide honu-bitmap honu-down-bitmap
+           honu-rotation honu-down-rotation)
+  
+  (define body-path (make-object dc-path%))
+  
+  (define (find-arc-spot x y w h end)
+    (let ([ce (cos end)]
+          [se (- (sin end))])
+      (values (+ x (* w 1/2) (* w 1/2 ce))
+              (+ y (* h 1/2) (* h 1/2 se)))))
+  
+  (define weighted-arc 
+    (opt-lambda (path x y w h start end ccw? [dx1 0.0] [dy1 0.2] [dx2 dx1] [dy2 (- dy1)])
+      (let ([sweep (let loop ([s (if ccw? (- end start) (- start end))])
+                     (if (< s 0)
+                         (loop (+ s (* 2 pi)))
+                         s))])
+        (if (> sweep pi)
+            (let ([halfway ((if ccw? + -) start (/ sweep 2))])
+              (weighted-arc path x y w h start halfway ccw? dx1 dy1 dx2 dy2)
+              (weighted-arc path x y w h halfway end ccw? dx2 (- dy2) dx1 (- dy1)))
+            (let ([p (new dc-path%)])
+              ;; Set p to be the arc for a unit circle,
+              ;;  centered on the X-axis:
+              (let* ([x0 (cos (/ sweep 2))]
+                     [y0 (sin (/ sweep 2))]
+                     [x1 (/ (- 4 x0) 3)]
+                     [y1 (/ (* (- 1 x0) (- 3 x0)) (* 3 y0))]
+                     [x2 x1]
+                     [y2 (- y1)]
+                     [x3 x0]
+                     [y3 (- y0)]
+                     [sw (/ w 2)]
+                     [sh (/ h 2)])
+                (send p move-to x0 y0)
+                (send p curve-to 
+                      (+ x1 dx1) (+ y1 dy1)
+                      (+ x2 dx2) (+ y2 dy2)
+                      x3 y3)
+                ;; Rotate to match start:
+                (send p rotate (+ (if ccw? start end) (/ sweep 2)))
+                ;; Scale to match width and height:
+                (send p scale (/ w 2) (/ h 2))
+                ;; Translate to match x and y
+                (send p translate (+ x (/ w 2)) (+ y (/ h 2)))
+                (unless ccw?
+                  (send p reverse)))
+              (send path append p))))))
+  
+  (define body-width 100)
+  (define body-height 110)
+  (define body-thickness 12)
+  (define angle-offset (* pi 1/10))
+  
+  (define big-fin-curve-top-offset 0)
+  (define big-fin-curve-bottom-offset 4)
+  (define big-fin-top-angle (* pi 3/12))
+  (define big-fin-bottom-angle (* pi 2/12))
+  (define big-fin-size 60)
+  (define big-fin-right-edge (+ body-width big-fin-size))
+  
+  (define little-fin-top-angle (- (* pi (/ 3.5 12))))
+  (define little-fin-bottom-angle (- (* pi (/ 4.5 12))))
+  (define little-fin-size 20)
+  (define little-fin-far-y (+ body-height little-fin-size))
+  
+  (define pointy-tip-offset 8)
+  
+  (define head-angle-span (* pi 1/6))
+  
+  (define head-cx (/ body-width 2))
+  (define head-cy -8)
+  
+  (define head-width 30)
+  (define head-height 40)
+  
+  (define acos-arg
+    (* (/ 2 head-width) (- (* (cos (- (/ pi 2) (/ head-angle-span 2)))
+                              (/ body-width 2)))))
+  
+  (define head-theta-start (- (acos acos-arg)))
+  (define head-theta-end (- pi head-theta-start))
+  
+  (define-values (head-attach-left-x head-attach-left-y)
+    (find-arc-spot 0 0 body-width body-height (+ (/ pi 2) (/ head-angle-span 2))))
+  (define-values (head-attach-right-x head-attach-right-y)
+    (find-arc-spot 0 0 body-width body-height (- (/ pi 2) (/ head-angle-span 2))))
+  
+  (define right-edge-of-center-line (+ (/ body-width 2) (/ body-thickness 2)))
+  (define left-edge-of-center-line (- (/ body-width 2) (/ body-thickness 2)))  
+  
+  (define-values (big-fin-top-x big-fin-top-y)
+    (find-arc-spot 0 0 body-width body-height big-fin-top-angle))
+  (define-values (big-fin-bottom-x big-fin-bottom-y)
+    (find-arc-spot 0 0 body-width body-height big-fin-bottom-angle))
+  
+  (define-values (left-little-fin-top-x left-little-fin-top-y)
+    (find-arc-spot 0 0 body-width body-height (- pi little-fin-top-angle)))
+  (define-values (left-little-fin-bottom-x left-little-fin-bottom-y)
+    (find-arc-spot 0 0 body-width body-height (- pi little-fin-bottom-angle)))
+  
+  (define-values (little-fin-top-x little-fin-top-y)
+    (find-arc-spot 0 0 body-width body-height little-fin-top-angle))
+  (define-values (little-fin-bottom-x little-fin-bottom-y)
+    (find-arc-spot 0 0 body-width body-height little-fin-bottom-angle))
+  
+  (define-values (inner-right-arc-top-x inner-right-arc-top-y)
+    (find-arc-spot 
+     body-thickness 
+     body-thickness 
+     (- body-width body-thickness body-thickness)
+     (- body-height body-thickness body-thickness)
+     (- (* pi 1/2) angle-offset)))
+  
+  (define-values (inner-right-arc-bottom-x inner-right-arc-bottom-y)
+    (find-arc-spot
+     body-thickness 
+     body-thickness 
+     (- body-width body-thickness body-thickness)
+     (- body-height body-thickness body-thickness)
+     (+ (* pi 3/2) angle-offset)))
+  
+  (define (add-big-fin-top add)
+    (let ([fin-width (- big-fin-right-edge big-fin-top-x)])
+      (add big-fin-top-x
+           big-fin-top-y
+           
+           (+ big-fin-top-x (* 1/3 fin-width))
+           big-fin-curve-top-offset
+           
+           (+ big-fin-top-x (* 2/3 fin-width))
+           big-fin-curve-top-offset
+           
+           big-fin-right-edge
+           (+ big-fin-bottom-y 10))))
+  
+  (define (add-big-fin-bottom add)
+    (let ([fin-width (- big-fin-right-edge big-fin-bottom-x)])
+      (add 
+       (+ big-fin-bottom-x fin-width)
+       (+ big-fin-bottom-y 10)
+       
+       (+ big-fin-bottom-x (* 1/3 fin-width))
+       (- (/ (+ big-fin-bottom-y big-fin-top-y) 2)
+          big-fin-curve-bottom-offset)
+       
+       (+ big-fin-bottom-x (* 1/5 fin-width))
+       (/ (+ big-fin-bottom-y big-fin-top-y) 2)
+       
+       big-fin-bottom-x
+       big-fin-bottom-y)))
+  
+  (define (add-little-fin-top add)
+    (add
+     little-fin-top-x
+     little-fin-top-y
+     
+     (+ little-fin-top-x (* (- little-fin-top-x little-fin-bottom-x) 2/3))
+     (+ little-fin-top-y (* (- little-fin-far-y little-fin-top-y) 1/3))
+     
+     (+ little-fin-top-x (* (- little-fin-top-x little-fin-bottom-x) 1/3))
+     (+ little-fin-top-y (* (- little-fin-far-y little-fin-top-y) 2/3))
+     
+     little-fin-top-x
+     little-fin-far-y))
+  
+  (define (add-little-fin-bottom add)
+    (add 
+     little-fin-top-x
+     little-fin-far-y
+     
+     (+ little-fin-top-x (* (- little-fin-bottom-x little-fin-top-x) 2/3))
+     (+ little-fin-top-y (* (- little-fin-far-y little-fin-top-y) 1/3))
+     
+     (+ little-fin-top-x (* (- little-fin-bottom-x little-fin-top-x) 2/3))
+     (+ little-fin-top-y (* (- little-fin-far-y little-fin-top-y) 1/3))
+     
+     little-fin-bottom-x 
+     little-fin-bottom-y))
+  
+  (define (add-dot path x y)
+    (let ([p (new dc-path%)])
+      (send p ellipse (- x 2) (- y 2) 4 4)
+      (send path append p)))
+  
+  (define (same-side-add x1 y1 x2 y2 x3 y3 x4 y4) 
+    (send body-path curve-to x2 y2 x3 y3 x4 y4))
+  
+  (define (same-side-add/dot x1 y1 x2 y2 x3 y3 x4 y4) 
+    (send body-path line-to x1 y1)
+    (add-dot body-path x1 y1)
+    (send body-path line-to x2 y2)
+    (add-dot body-path x2 y2)
+    (send body-path line-to x3 y3)
+    (add-dot body-path x3 y3))
+  
+  (define (opposite-side-add x1 y1 x2 y2 x3 y3 x4 y4)
+    (let ([conv (lambda (x y) (values (+ (- x) body-width) y))])
+      (let-values ([(cx1 cy1) (conv x1 y1)]
+                   [(cx2 cy2) (conv x2 y2)]
+                   [(cx3 cy3) (conv x3 y3)])
+        (send body-path curve-to cx3 cy3 cx2 cy2 cx1 cy1))))
+  
+  (define (opposite-side-add/dot x1 y1 x2 y2 x3 y3 x4 y4)
+    (let ([conv (lambda (x y) (values (+ (- x) body-width) y))])
+      (let-values ([(cx1 cy1) (conv x1 y1)]
+                   [(cx2 cy2) (conv x2 y2)]
+                   [(cx3 cy3) (conv x3 y3)])
+        (send body-path line-to cx3 cy3)
+        (add-dot body-path cx3 cy3)
+        (send body-path line-to cx2 cy2)
+        (add-dot body-path cx2 cy2)
+        (send body-path line-to cx1 cy1)
+        (add-dot body-path cx1 cy1))))
+  
+  (define side-perturb-y 0.0)
+  (define side-perturb-x -0.1)
+  
+  (weighted-arc body-path 0 0 body-width body-height big-fin-bottom-angle little-fin-top-angle #f 
+                side-perturb-x side-perturb-y)
+  (add-little-fin-top same-side-add)
+  (add-little-fin-bottom same-side-add)
+  
+  (send body-path line-to
+        little-fin-bottom-x
+        little-fin-bottom-y)
+  
+  (send body-path line-to
+        (/ body-width 2)
+        (+ body-height pointy-tip-offset))
+  
+  (send body-path line-to
+        left-little-fin-bottom-x
+        left-little-fin-bottom-y)
+  
+  (add-little-fin-bottom opposite-side-add)
+  (add-little-fin-top opposite-side-add)
+  
+  (weighted-arc body-path 0 0 body-width body-height
+                (- pi little-fin-top-angle)
+                (- pi big-fin-bottom-angle)
+                #f
+                side-perturb-x side-perturb-y)
+  
+  (add-big-fin-bottom opposite-side-add)
+  (add-big-fin-top opposite-side-add)
+  
+  (weighted-arc body-path 0 0 body-width body-height (- pi big-fin-top-angle) (+ (/ pi 2) (/ head-angle-span 2)) #f 0 0)
+  
+  
+  (weighted-arc body-path
+                (- head-cx (/ head-width 2))
+                (- head-cy (/ head-height 2))
+                head-width
+                head-height
+                head-theta-start
+                head-theta-end
+                #f 0 0 0 -0.2)
+  
+  (weighted-arc body-path 0 0 body-width body-height (- (/ pi 2) (/ head-angle-span 2)) big-fin-top-angle #f 0 0)
+  
+  (add-big-fin-top same-side-add)
+  (add-big-fin-bottom same-side-add)
+  (send body-path close)
+  
+  (define (make-right-hole-path)
+    (let ([right-hole-path (make-object dc-path%)])
+      
+      (define arc/end 
+        (opt-lambda (x y w h start end [cc? #t] [dx1 0] [dy1 0.2] [dx2 0] [dy2 -0.2])
+          (weighted-arc right-hole-path x y w h start end cc? dx1 dy1 dx2 dy2)
+          (find-arc-spot x y w h end)))
+      
+      (define-values (arc1x arc1y)
+        (arc/end body-thickness 
+                 body-thickness 
+                 (- body-width body-thickness body-thickness)
+                 (- body-height body-thickness body-thickness)
+                 (- (* pi 1/2) angle-offset)
+                 (+ (* pi 3/2) angle-offset)
+                 #f -0.2 0.2 0 -0.2))
+      
+      (define little-arc-size (* 2 (- inner-right-arc-bottom-x right-edge-of-center-line)))
+      
+      (define-values (arc2x arc2y)
+        (arc/end
+         right-edge-of-center-line
+         (- inner-right-arc-bottom-y little-arc-size)
+         little-arc-size
+         little-arc-size
+         (* 3/2 pi)
+         pi
+         #f
+         0 0 0 0))
+      
+      (let ([arc2y (- body-height arc2y)])
+        (send right-hole-path curve-to 
+              
+              (+ (/ (+ (* 2 arc1x) (* 1 arc2x)) 3) -4)
+              (/ (+ (* 2 arc1y) (* 1 arc2y)) 3)
+              
+              (+ (/ (+ (* 1 arc1x) (* 2 arc2x)) 3) -4)
+              (/ (+ (* 1 arc1y) (* 2 arc2y)) 3)
+              
+              arc2x arc2y))
+      
+      (weighted-arc right-hole-path
+                    right-edge-of-center-line
+                    inner-right-arc-top-y
+                    little-arc-size
+                    little-arc-size
+                    pi
+                    (* 1/2 pi)
+                    #f
+                    0 0 0 0)
+      
+      (send right-hole-path close)
+      
+      right-hole-path))
+  
+  (define (make-left-hole-path)
+    (let ([left-hole-path (make-right-hole-path)])
+      (send left-hole-path scale -1 1)
+      (send left-hole-path translate 
+            (+ right-edge-of-center-line left-edge-of-center-line) 0)
+      left-hole-path))
+  
+  (define right-hole-path (make-right-hole-path))
+  (define left-hole-path (make-left-hole-path))
+  
+  (define (adjust-path path)
+    (send path translate (+ (- big-fin-right-edge body-width) 1) (+ (- head-cy) (/ head-height 2) 2)))
+  
+  (adjust-path body-path)
+  (adjust-path left-hole-path)
+  (adjust-path right-hole-path)
+  
+  (define pale-red-color (make-object color% 242 183 183))
+  (define pale-blue-color (make-object color% 183 202 242))
+  (define pale-background-color (make-object color% 209 220 248))
+
+  (define bitmap-size 128)
+    
+  (define (make-honu-bitmap main-color left-color right-color rot)
+    (let ([main-bm (make-single-bitmap main-color main-color left-color right-color rot)])
+      (send main-bm set-loaded-mask (make-single-bitmap "white" "black" "black" "black" rot))
+      main-bm))
+  
+  (define (make-single-bitmap bgcolor main-color left-color right-color rot)
+    (let* ([bitmap (make-object bitmap% bitmap-size bitmap-size)]
+           [dc (make-object bitmap-dc% bitmap)]
+           [path (rotate-path body-path rot)]
+           [left-hole-path (rotate-path left-hole-path rot)]
+           [right-hole-path (rotate-path right-hole-path rot)]
+           [scale 1/2])
+      (send dc set-smoothing 'aligned)
+      (send dc set-pen "white" 1 'transparent)
+      (send dc set-brush bgcolor 'solid)
+      (send dc draw-rectangle 0 0 bitmap-size bitmap-size)
+      (send dc set-scale scale scale)
+      
+      (let-values ([(x y w h) (send path get-bounding-box)])
+        (let ([dx (- (/ (/ bitmap-size scale) 2) (/ w 2))]
+              [dy (- (/ (/ bitmap-size scale) 2) (/ h 2))])
+          (send path translate (- x) (- y))
+          (send left-hole-path translate (- x) (- y))
+          (send right-hole-path translate (- x) (- y))
+          
+          (send dc set-brush main-color 'solid)
+          (send dc set-pen main-color 1 'solid)
+          (send dc draw-path path dx dy)
+          
+          (send dc set-pen left-color 1 'solid)
+          (send dc set-brush left-color 'solid)
+          (send dc draw-path left-hole-path dx dy)
+          
+          (send dc set-brush right-color 'solid)
+          (send dc set-pen right-color 1 'solid)
+          (send dc draw-path right-hole-path dx dy)))
+      
+      (send dc set-bitmap #f)
+      bitmap))
+  
+  (define (rotate-path path rot)
+    (let ([pth (new dc-path%)])
+      (send pth append path)
+      (send pth rotate rot)
+      pth))
+  
+  (define honu-rotation (* pi 1/4))
+  (define honu-down-rotation (* pi (+ 1 1/4)))
+  
+  (define honu-bitmap (make-honu-bitmap (make-object color% 150 150 150) "red" "blue" honu-rotation))
+  (define honu-down-bitmap (make-honu-bitmap "black" "orangered" "blue" honu-down-rotation))
+#|
+  (define dx 0)
+  (define dy 0)
+  (define f (new frame% (label "")))
+  (define c (new canvas%
+                 (parent f)
+                 (paint-callback
+                  (lambda (c dc)
+                    (send dc draw-bitmap honu-bitmap dx dy)
+                    (send dc draw-line 
+                          (/ bitmap-size 2)
+                          (/ bitmap-size 2)
+                          (+ (/ bitmap-size 2) (* 100 (cos (+ (/ pi 2) honu-down-rotation))))
+                          (+ (/ bitmap-size 2) (* 100 (- (sin (+ (/ pi 2) honu-down-rotation))))))))))
+  (send c min-width bitmap-size)
+  (send c min-height bitmap-size)
+  (define b+ (new button%
+                  (label "+1")
+                  (parent f)
+                  (callback (lambda (x y) (set! dy (+ dy 1)) (send c refresh)))))
+  (define b- (new button%
+                  (label "-1")
+                  (parent f)
+                  (callback (lambda (x y) (set! dy (- dy 1)) (send c refresh)))))
+  (send f show #t)  
+|#
+  )
\ No newline at end of file
diff --git a/collects/games/checkers/info.ss b/collects/games/checkers/info.ss
new file mode 100644
index 0000000000..9bb663a2b8
--- /dev/null
+++ b/collects/games/checkers/info.ss
@@ -0,0 +1,4 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Checkers")
+  (define game "checkers.ss")
+  (define game-set "Board Games"))
diff --git a/collects/games/checkers/light.jpg b/collects/games/checkers/light.jpg
new file mode 100644
index 0000000000..52f5a5cf43
Binary files /dev/null and b/collects/games/checkers/light.jpg differ
diff --git a/collects/games/crazy8s/crazy8s.png b/collects/games/crazy8s/crazy8s.png
new file mode 100644
index 0000000000..79e98a5f57
Binary files /dev/null and b/collects/games/crazy8s/crazy8s.png differ
diff --git a/collects/games/crazy8s/crazy8s.ss b/collects/games/crazy8s/crazy8s.ss
new file mode 100644
index 0000000000..ebc4289cb2
--- /dev/null
+++ b/collects/games/crazy8s/crazy8s.ss
@@ -0,0 +1,698 @@
+
+(module crazy8s mzscheme
+  (require (lib "cards.ss" "games" "cards")
+	   (lib "mred.ss" "mred")
+	   (lib "class.ss")
+           (lib "unit.ss")
+           (lib "etc.ss")
+	   (lib "list.ss")
+           (lib "async-channel.ss")
+	   (lib "file.ss"))
+
+  ;; Player record
+  (define-struct player (r hand-r  ; region
+                         hand))    ; cards
+      
+  ;; Messages
+  (define YOUR-NAME "You")
+  (define OPPONENT-X-NAME "Opponent ~a")
+  (define OPPONENT-NAME "Opponent")
+  (define YOUR-TURN-MESSAGE "Your turn - discard a ~a or crazy 8, or else ~a")
+  (define PICK-A-SUIT "Pick a suit")
+  (define GAME-OVER-YOU-WIN "Game over - you win!")
+  (define GAME-OVER-STUCK "Game over - no one wins")
+  (define GAME-OVER "Game over - opponent wins")
+  (define NEW-GAME "New Game")
+  
+  ;; Region layout constants
+  (define MARGIN 10)
+  (define SUBMARGIN 10)
+  (define LABEL-H 15)
+  (define BUTTON-HEIGHT 18)
+  (define PASS-W 40)
+  (define NEW-GAME-W 80)
+  (define SEL-WIDTH 32)
+  (define SEL-HEIGHT 32)
+            
+  (provide game-unit)
+  
+  ;; This unit drives multiple Crazy 8 instances:
+  (define game-unit
+    (unit
+      (import)
+      (export)
+
+      ;; Configuration
+      (define opponents-count (get-preference 'crazy8s:num-opponents (lambda () 1)))
+      (define init-hand-size (get-preference 'crazy8s:hand-size (lambda () 7)))
+      (define drag-mode? (get-preference 'crazy8s:drag-mode (lambda () #f)))
+      
+      (define (start-new-game opponents-count init-hand-size drag-mode?)
+	(define orig-eventspace (current-eventspace))
+	;; Procedure for a game to use to start a sibling game
+	(define (new-game oc ihs dm?)
+	  (parameterize ([current-eventspace orig-eventspace])
+	    (queue-callback
+	     (lambda ()
+	       (start-new-game oc ihs dm?)))))
+	;; Start a new game as a child process:
+	(parameterize ([current-custodian (make-custodian)])
+	  (parameterize ([exit-handler (lambda (v)
+					 (custodian-shutdown-all (current-custodian)))])
+	    (parameterize ([current-eventspace (make-eventspace)])
+	      (queue-callback
+	       (lambda ()
+		 (invoke-unit configured-game-unit 
+			      opponents-count 
+			      init-hand-size
+                              drag-mode?
+			      new-game)))))))
+
+      ;; Start the initial child game:
+      (start-new-game opponents-count init-hand-size drag-mode?)))
+  
+  ;; This unit is for a particular Crazy 8 instance:
+  (define configured-game-unit
+    (unit
+      (import opponents-count init-hand-size drag-mode? new-game)
+      (export)
+
+      ;; Randomize
+      (random-seed (modulo (current-milliseconds) 10000))
+      
+      ;; ========== GUI ========================================
+
+      ;; Set up the table
+      (define t (make-table "Crazy 8s" 8 5.5))
+
+      ;; Add status line and buttons:
+      (define status-pane (send t create-status-pane))
+      (new button% 
+	   (parent status-pane)
+	   (label "Options...")
+	   (callback (lambda (b e) (configure-dialog))))
+      (send t add-help-button status-pane (list "games" "crazy8s") "Crazy 8s Help" #f)
+
+      ;; The "Options.." button opens a configuration dialog that
+      ;;  starts a new game:
+      (define (configure-dialog)
+	(define d (new dialog%
+		       [parent t]
+		       [label "Crazy 8 Options"]))
+        (define kinds (new radio-box%
+			   [label #f]
+			   [choices '("1 opponent, 10 cards"
+				      "1 opponent, 7 cards"
+				      "2 opponents, 7 cards"
+				      "3 opponents, 7 cards")]
+			   [parent (new group-box-panel%
+					[parent d]
+					[label "Players and Cards"])]
+			   [callback void]))
+	(define drag-mode-check
+          (new check-box%
+               [parent d]
+               [label "Drag cards instead of single-click"]
+               [callback void]))
+	(define button-panel (new horizontal-pane%
+				  [parent d]
+				  [alignment '(right center)]))
+	(new button%
+	     [label "Close"]
+	     [parent button-panel]
+	     [callback (lambda (b e)
+			 (send d show #f))])
+	(new button%
+	     [label "New Game"]
+	     [parent button-panel]
+	     [callback (lambda (b e)
+			 (let-values ([(oc ihs)
+				       (case (send kinds get-selection)
+					 [(0) (values 1 10)]
+					 [(1) (values 1 7)]
+					 [(2) (values 2 7)]
+					 [(3) (values 3 7)])]
+                                      [(dm?) (send drag-mode-check get-value)])
+			   (put-preferences
+			    '(crazy8s:num-opponents crazy8s:hand-size crazy8s:drag-mode)
+			    (list oc ihs dm?)
+			    void)
+			   (new-game oc ihs dm?)
+			   (send d show #f)))]
+	     [style '(border)])
+	(send kinds set-selection
+	      (case opponents-count
+		[(1) (if (= init-hand-size 7) 1 0)]
+		[(2) 2]
+		[(3) 3]))
+        (send drag-mode-check set-value drag-mode?)
+	(send d show #t))
+
+      ;; Show the table
+      (send t show #t)
+
+      ;; ========== Cards setup ========================================
+
+      ;; Set the default card actions:
+      (send t set-double-click-action #f)
+      (send t set-button-action 'left 'drag-raise/one)
+      (send t set-button-action 'right 'drag/above)
+      
+      ;; Get table width & height
+      (define w (send t table-width))
+      (define h (send t table-height))
+      
+      ;; Set up the cards
+      (define all-cards (shuffle-list (make-deck) 7))
+      (define deck all-cards)
+      (define discards null)
+      (for-each
+       (lambda (card)
+	 (send card user-can-flip #f))
+       deck)
+
+      ;; We'll need an 8 of each suit for substitutions later
+      (define (find-8 suit)
+	(ormap (lambda (c)
+		 (and (= 8 (send c get-value))
+		      (eq? suit (send c get-suit))
+		      (send c copy)))
+	       deck))
+      (define 8-hearts (find-8 'hearts))
+      (define 8-spades (find-8 'spades))
+      (define 8-clubs (find-8 'clubs))
+      (define 8-diamonds (find-8 'diamonds))
+      
+      ;; Function for dealing or drawing cards
+      (define (deal n)
+	(let loop ([n n][d deck])
+	  (if (zero? n)
+	      (begin
+		(set! deck d)
+		null)
+	      (cons (car d) (loop (sub1 n) (cdr d))))))
+      
+      ;; Card width & height
+      (define cw (send (car deck) card-width))
+      (define ch (send (car deck) card-height))
+      
+      ;; Make regions for deck and descard
+      (define deck-region
+	(make-region (- (/ (- w cw) 2) (/ (+ cw MARGIN) 2))
+		     (/ (- h ch) 2)
+		     cw ch
+		     #f #f))
+      (define discard-region
+	(make-region (+ (region-x deck-region) cw MARGIN)
+		     (region-y deck-region)
+		     cw ch
+		     #f #f))
+      (define discard-target-region
+	(make-region (- (region-x discard-region) (/ MARGIN 2))
+		     (- (region-y discard-region) (/ MARGIN 2))
+		     (+ cw MARGIN) (+ ch MARGIN)
+		     "" #f))
+      (when drag-mode?
+        (send t add-region discard-target-region))
+
+      ;; Put the cards on the table
+      (send t add-cards-to-region deck deck-region)      
+      
+      ;; Make regions for choosing a suit
+      (define (make-suit-region x y label card)
+	(let ([bm (make-object bitmap%
+			       (build-path (collection-path "games" "crazy8s")
+					   "images"
+					   (format "~a.png" label))
+			       'unknown/mask)])
+	  (make-button-region x y
+			      SEL-WIDTH SEL-HEIGHT
+			      bm
+			      ;; The callback for the region sends
+			      ;;  a clonable card to the game driver
+			      (lambda ()
+				(async-channel-put msg card)))))
+      (define hearts-region
+	(make-suit-region (+ (region-x discard-target-region) cw (* 2 MARGIN))
+			  (+ (region-y discard-target-region)
+			     (/ (- ch (* 2 SEL-HEIGHT) (/ MARGIN 2)) 2))
+			  "heart" 8-hearts))
+      (define spades-region
+	(make-suit-region (+ (region-x hearts-region) SEL-WIDTH (/ MARGIN 2))
+			  (region-y hearts-region)
+			  "spade" 8-spades))
+      (define clubs-region
+	(make-suit-region (region-x hearts-region)
+			  (+ (region-y hearts-region) SEL-HEIGHT (/ MARGIN 2))
+			  "club" 8-clubs))
+      (define diamonds-region
+	(make-suit-region (region-x spades-region)
+			  (region-y clubs-region)
+			  "diamond" 8-diamonds))
+
+      ;; Make the "Pass" button:
+      (define pass-button
+	(make-button-region (+ (region-x deck-region)
+			       (/ (- cw PASS-W) 2))
+			    (+ (region-y deck-region)
+			       (/ (- ch BUTTON-HEIGHT) 2))
+			    PASS-W BUTTON-HEIGHT
+			    "Pass" (lambda ()
+				     (async-channel-put msg 'pass))))
+
+      ;; Player region size
+      (define pw (/ (- w (* opponents-count MARGIN)) opponents-count))
+      (define ph (- (/ (- h ch) 2) (* 2 MARGIN)))
+      
+      ;; Define the players with their regions
+      (define (make-a-player x y w h lbl)
+	(let ([r (make-region x y w h lbl #f)])
+	  (send t add-region r)
+	  (make-player
+	   r
+	   (make-region (+ x SUBMARGIN) (+ y SUBMARGIN LABEL-H)
+			(- w (* 2 SUBMARGIN))
+			(- h (* 2 SUBMARGIN) LABEL-H)
+			#f #f)
+	   null)))
+      (define players
+	(cons
+	 ;; You
+	 (make-a-player
+	  (/ MARGIN 2) (- h ph (/ MARGIN 2))
+	  (- w MARGIN) ph
+	  YOUR-NAME)
+	 (build-list
+	  opponents-count
+	  (lambda (delta)
+	    (make-a-player
+	     (+ (* (+ pw MARGIN) delta) (/ MARGIN 2)) (/ MARGIN 2)
+	     pw ph
+	     (if (= opponents-count 1)
+		 OPPONENT-NAME
+		 (format OPPONENT-X-NAME (+ 1 delta))))))))
+      (define you (car players))
+      (define opponents (cdr players))
+
+      ;; Add the "Clean" and "Sort" buttons:
+      (define (sort-hand! card<)
+        (let ([sorted
+               (quicksort
+                (player-hand you)
+                card<)])
+          (set-player-hand! you sorted)
+          (send t stack-cards sorted)
+          (send t move-cards-to-region
+                sorted
+                (player-hand-r you))))
+      (define clean-button
+        (make-button-region (region-x (player-r you))
+                            (- (region-y (player-r you))
+                               (+ BUTTON-HEIGHT MARGIN))
+                            PASS-W BUTTON-HEIGHT
+                            "Clean" (lambda ()
+                                      (sort-hand!
+                                       (lambda (a b)
+                                         (let-values ([(ax ay) (send t card-location a)]
+                                                      [(bx by) (send t card-location b)])
+                                           (> ax bx)))))))
+      (send t add-region clean-button)
+      (define (remap v)
+        ;; So that black and red suits are interleaved
+        (case v [(2) 1][(1) 2][else v]))
+      (define (card< a b)
+	(cond
+	 [(= 8 (send a get-value))
+	  (or (not (= 8 (send b get-value)))
+	      (< (remap (send a get-suit-id))
+		 (remap (send b get-suit-id))))]
+	 [(= 8 (send b get-value))
+	  #f]
+	 [(= (send a get-suit-id)
+	     (send b get-suit-id))
+	  (< (send a get-value)
+	     (send b get-value))]
+	 [else 
+	  (< (remap (send a get-suit-id))
+	     (remap (send b get-suit-id)))]))
+      (when drag-mode?
+        (send t add-region
+              (make-button-region (+ (region-x clean-button) PASS-W MARGIN)
+                                  (region-y clean-button)
+                                  PASS-W BUTTON-HEIGHT
+                                  "Sort" (lambda ()
+                                           (sort-hand! card<)))))
+      
+      ;; ========== Game engine ========================================
+
+      ;; Callbacks communicate back to the main loop
+      (define msg (make-async-channel))
+      
+      ;; Utility: Determine whether a list of cards corresponds to a
+      ;; valid discard; return one card or #f
+      (define (get-discard-card cs)
+	(and (= 1 (length cs))
+	     (let ([c (car cs)])
+	       (and (memq c (player-hand you))
+		    (or (= (send (car discards) get-value)
+			   (send c get-value))
+			(= (send (car discards) get-suit-id)
+			   (send c get-suit-id))
+			(= (send c get-value) 8))
+		    c))))
+
+      ;; Utility: detect a stuck game
+      (define (stuck-game?)
+	(and (null? deck)
+	     (not (ormap (lambda (p)
+                           (and (pair? (player-hand p))
+                                (ormap (lambda (c)
+                                         (get-discard-card (list c)))
+                                       (player-hand p))))
+			 players))))
+      
+      ;; Auto-player strategy: Choose which valid card to discard
+      (define (pick-to-discard cards)
+	(let ([non-8s (filter (lambda (c)
+				(not (= 8 (send c get-value))))
+			      cards)])
+	  (if (null? non-8s)
+	      (car cards)
+	      (car non-8s))))
+      
+      ;; Auto-player: take a turn
+      (define (play-opponent p)
+	(let ([suit-id (send (car discards) get-suit-id)]
+	      [value (send (car discards) get-value)])
+	  ;; Which cards can we discard?
+	  (let ([matches (filter (lambda (c)
+				   (or (= suit-id (send c get-suit-id))
+				       (= value (send c get-value))
+				       (= 8 (send c get-value))))
+				 (player-hand p))])
+	    (if (null? matches)
+		;; Can't discard, so draw or pass
+		(if (pair? deck)
+		    ;; Draw
+		    (begin
+		      (send t card-to-front (car deck))
+		      (set-player-hand! p (append (deal 1) (player-hand p)))
+		      (send t move-cards-to-region (player-hand p) (player-hand-r p))
+		      (play-opponent p))
+		    ;; Pass
+		    (begin
+		      (send t hilite-region (player-r p))
+		      (send t pause 0.25)
+		      (send t unhilite-region (player-r p))
+		      #t))
+		;; Discard
+		(let ([c (pick-to-discard matches)])
+		  (set-player-hand! p (remq c (player-hand p)))
+		  (send t flip-card c)
+		  (send t card-to-front c)
+		  (send t move-cards-to-region (list c) discard-region)
+		  (send t move-cards-to-region (player-hand p) (player-hand-r p))
+		  (set! discards (cons c discards))
+		  ;; Did we just discard an 8? (And we still have cards?)
+		  (when (and (= 8 (send (car discards) get-value))
+			     (pair? (player-hand p)))
+		    ;; Pick a suit based on our hand
+		    (let ([counts (map (lambda (v)
+					 (cons v
+					       (length (filter (lambda (c)
+								 (and (= v (send c get-suit-id))
+								      (not (= 8 (send c get-value)))))
+							       (player-hand p)))))
+				       '(1 2 3 4))])
+		      (let ([suit-id
+			     ;; Sort based on counts, then pick the first one:
+			     (sub1 (caar (quicksort counts (lambda (a b) (> (cdr a) (cdr b))))))])
+			;; Find the clonable 8 for the chosen suit, and reset the discard
+			(reset-8
+			 (list-ref
+			  (list 8-clubs 8-diamonds 8-hearts 8-spades)
+			  suit-id)))))
+		  ;; Return #f if this player has just won:
+		  (pair? (player-hand p)))))))            
+      
+      ;; Utility: disables cards for "you"
+      (define (allow-cards on?)
+        (when (pair? deck)
+          (send (car deck) user-can-move (and drag-mode? on?)))
+        (for-each (lambda (c)
+                    (send c user-can-move (and drag-mode? on?)))
+                  (player-hand you))
+        (send t set-single-click-action (if (and on? (not drag-mode?))
+                                            click-card
+                                            (if drag-mode?
+                                                void
+						(lambda (x) (bell)))))
+	(when (null? deck)
+	  (if on?
+	      (send t add-region pass-button)
+	      (send t remove-region pass-button))))
+      
+      ;; Utility: replaces the top discard, which is an 8, with an 8
+      ;; of a particular suit (possibly the same).
+      (define (reset-8 got-8)
+	(unless (eq? (send (car discards) get-suit)
+		     (send got-8 get-suit))
+	  (let ([c (send got-8 copy)])
+	    (send c user-can-move #f)
+	    (send t flip-card (car discards))
+	    (send t add-cards-to-region (list c) discard-region)
+	    (send t card-to-front c)
+	    (send t remove-card (car discards))
+	    (set! discards (cons c (cdr discards)))
+	    (send t flip-card c))))
+      
+      ;; Sub-game: the user just discarded an 8, so pick a suit:
+      (define (pick-suit)
+	(allow-cards #f)
+	(send t add-region hearts-region)
+	(send t add-region spades-region)
+	(send t add-region clubs-region)
+	(send t add-region diamonds-region)
+	(send t set-status PICK-A-SUIT)
+	;; Clicking one of these regions returns a clonable 8 card:
+	(let ([got-8 (yield msg)])
+	  (reset-8 got-8))
+	(send t remove-region hearts-region)
+	(send t remove-region spades-region)
+	(send t remove-region clubs-region)
+	(send t remove-region diamonds-region)
+	(allow-cards #t))
+
+      ;; Install interactive callback for discard: accept the card
+      ;; (from the player's hand) and release it from its home:
+      (set-region-interactive-callback! 
+       discard-target-region
+       (lambda (in? cs)
+	 (let ([c (get-discard-card cs)])
+	   (when c
+	     (send c home-region (if in? #f (player-r you)))))))
+
+      ;; Install final callback for discard: perform the discard
+      (set-region-callback! 
+       discard-target-region
+       (lambda (cs)
+	 (let ([c (get-discard-card cs)])
+	   (when c
+             (you-discard c)))))
+      
+      (define (you-discard c)
+        (send c home-region #f)
+        (set! discards (cons c discards))
+        (set-player-hand! you (remq c (player-hand you)))
+        (send t card-to-front c)
+        (send t move-cards-to-region (list c) discard-region)
+        (send c user-can-move #f)
+        (async-channel-put msg 'discard))
+
+      ;; Install interactive callback for hand: accept the card
+      ;; (from the deck) and release it from its home:
+      (set-region-interactive-callback! 
+       (player-r you)
+       (lambda (in? cs)
+	 (send (car cs) home-region 
+	       (if in? (player-r you) deck-region))))
+
+      ;; Install final callback for hand: draw the card:
+      (set-region-callback! 
+       (player-r you)
+       (lambda (cs)
+	 (let ([c (car cs)])
+           (you-draw c))))
+      
+      (define (you-draw c)
+        (send t flip-card c)
+        (send c home-region (player-r you))
+        (set-player-hand! you (let loop ([l (player-hand you)])
+                                (cond
+                                  [(null? l) (list c)]
+                                  [(card< c (car l)) (cons c l)]
+                                  [else (cons (car l) (loop (cdr l)))])))
+        (deal 1)
+        (unless drag-mode?
+          (send t stack-cards (player-hand you))
+          (send t move-cards-to-region (player-hand you) (player-hand-r you)))
+        (async-channel-put msg 'draw))
+      
+      (define (click-card c)
+        (cond
+          [(memq c deck) (you-draw c)]
+          [(memq c (player-hand you)) 
+           (if (get-discard-card (list c))
+               (you-discard c)
+               (bell))]
+          [else (bell)]))
+      
+      (unless drag-mode?
+        (send t set-single-click-action click-card))
+
+      ;; Run a loop for multiple games
+      (let gloop ()
+
+	;; Card setup: Deal the cards
+	(for-each (lambda (player)
+		    (set-player-hand! player (quicksort (deal init-hand-size) card<))
+		    (send t stack-cards (player-hand player))
+		    (send t move-cards-to-region 
+			  (player-hand player)
+			  (player-hand-r player)))
+		  players)
+
+	;; Opponents's cards and deck initally can't be moved
+	(for-each
+	 (lambda (card) (send card user-can-move #f))
+	 (append
+	  (apply append
+		 (map player-hand (if drag-mode? opponents players)))
+	  deck))
+	;; Your cards stay home:
+	(for-each (lambda (c) 
+		    (send c home-region (player-r you))
+		    (send c user-can-move drag-mode?))
+		  (player-hand you))
+      
+	;; Initial discard
+	;;  If it's an eight, then shuffle and try again
+	(let loop ()
+	  (when (= 8 (send (car deck) get-value))
+	    (set! deck (shuffle-list deck 1))
+	    (send t stack-cards deck)
+	    (loop)))
+	(set! discards (deal 1))
+	(send t flip-cards discards)
+	(send t move-cards-to-region discards discard-region)
+      
+	;; Show your cards
+	(send t flip-cards (player-hand you))
+      
+	;; Run a single-game loop
+	(let loop ()
+	  ;; Ready deck and/or pass button:
+	  (when (pair? deck)
+	    (when drag-mode?
+	      (send (car deck) user-can-move #t))
+	    (send (car deck) home-region deck-region))
+	  (when (null? deck)
+	    (send t add-region pass-button))
+	  ;; Tell the player what to do:
+	  (send t set-status (format YOUR-TURN-MESSAGE
+				     (let ([v (send (car discards) get-value)]
+					   [suit (case (send (car discards) get-suit)
+						   [(hearts) "heart"]
+						   [(spades) "spade"]
+						   [(diamonds) "diamond"]
+						   [(clubs) "club"])])
+				       (if (= v 8)
+					   suit
+					   (format "~a, ~a," 
+						   suit
+						   (case v
+						     [(1) "ace"]
+						     [(11) "jack"]
+						     [(12) "queen"]
+						     [(13) "king"]
+						     [else v]))))
+				     (if (null? deck)
+					 "pass"
+					 "draw")))
+	  ;; What for something to happen:
+	  (let ([what (yield msg)])
+	    ;; Discarded a crazy 8? (And not as our last card?)
+	    (when (and (eq? what 'discard)
+		       (= 8 (send (car discards) get-value))
+		       (pair? (player-hand you)))
+	      ;; Yes, so pick suit before continuing
+	      (pick-suit))
+	    ;; What did we do?
+	    (case what
+	      [(draw)
+	       ;; Go again
+	       (loop)]
+	      [(discard pass)
+	       ;; Hide pass button...
+	       (when (null? deck)
+		 (send t remove-region pass-button))
+	       ;; ... and run opponents
+	       (send t set-status "Opponent's turn...")
+	       (unless (null? (player-hand you))
+		 (let oloop ([l opponents])
+		   (cond
+		    [(null? l) 
+		     ;; Check for a stuck game here:
+		     (unless (stuck-game?)
+		       (loop))]
+		    [else (when (play-opponent (car l))
+			    (oloop (cdr l)))])))])))
+      
+	;; Game over: disable player:
+	(allow-cards #f)
+	
+	;; Report result:
+	(send t set-status (cond
+			    [(null? (player-hand you))
+			     GAME-OVER-YOU-WIN]
+			    [(stuck-game?)
+			     GAME-OVER-STUCK]
+			    [else
+			     GAME-OVER]))
+
+	(let ([button
+	       (make-button-region 
+		(+ (region-x discard-region) cw (* 2 MARGIN))
+		(+ (region-y discard-region) (/ (- ch LABEL-H) 2))
+		NEW-GAME-W LABEL-H
+		NEW-GAME (lambda ()
+			   (async-channel-put msg 'new-game)))])
+	  (send t add-region button)
+	  (yield msg)
+	  (send t remove-region button))
+
+	(let ([all (send t all-cards)])
+	  ;; Gather up cards, with animation
+	  (let ([flip (filter
+		       (lambda (c)
+			 (not (send c face-down?)))
+		       all)])
+	    (send t flip-cards flip)
+	    (send t move-cards-to-region all deck-region))
+	  ;; Reset all cards (no animation)
+	  (send t begin-card-sequence)
+	  (send t remove-cards all)
+	  (send t add-cards-to-region all-cards deck-region)
+	  (set! deck (shuffle-list all-cards 7))
+	  (for-each (lambda (c)
+		      (unless (send c face-down?)
+			(send c flip)))
+		    deck)
+	  (send t stack-cards deck)
+	  (send t end-card-sequence))
+
+	;; Re-enable player:
+	(allow-cards #t)
+
+	(gloop)))))
+
diff --git a/collects/games/crazy8s/doc.txt b/collects/games/crazy8s/doc.txt
new file mode 100644
index 0000000000..fbe63a91ad
--- /dev/null
+++ b/collects/games/crazy8s/doc.txt
@@ -0,0 +1,24 @@
+** To play _Crazy 8s_, run the "Games" application. **
+
+Try to get rid of all you cards by matching the value or suit of the
+top card in the discard pile. In the default mode, click a card to
+discard it; you can adjust the options so that you discard by dragging
+a card from your hand to the discard pile.
+
+An 8 can be discarded at any time, and in that case, the player who
+discarded the 8 gets to pick any suit for it (hence the craziness of
+8s). When you discard an 8, a panel of buttons appears to the right of
+the discard pile, so you can pick the suit.
+
+A player can choose to draw a card instead of discarding, as long as
+cards are left in the draw pile. A player's turn continues after
+drawing, so a player can continue drawing to find something to
+discard. In the default mode, click the face-down draw pile in the
+middle of the table; you can adjust the options to that you draw by
+dragging it from the draw pile to your hand.
+
+If no cards are left in the deck, a player may pass instead of
+discarding. To pass, click the "Pass" button.
+
+The status line at the bottom of the window provides instructions as
+you go.
diff --git a/collects/games/crazy8s/images/club.png b/collects/games/crazy8s/images/club.png
new file mode 100644
index 0000000000..f9174bbf84
Binary files /dev/null and b/collects/games/crazy8s/images/club.png differ
diff --git a/collects/games/crazy8s/images/diamond.png b/collects/games/crazy8s/images/diamond.png
new file mode 100644
index 0000000000..1d55905edd
Binary files /dev/null and b/collects/games/crazy8s/images/diamond.png differ
diff --git a/collects/games/crazy8s/images/heart.png b/collects/games/crazy8s/images/heart.png
new file mode 100644
index 0000000000..dcf7880b56
Binary files /dev/null and b/collects/games/crazy8s/images/heart.png differ
diff --git a/collects/games/crazy8s/images/spade.png b/collects/games/crazy8s/images/spade.png
new file mode 100644
index 0000000000..fc4b6a366f
Binary files /dev/null and b/collects/games/crazy8s/images/spade.png differ
diff --git a/collects/games/crazy8s/info.ss b/collects/games/crazy8s/info.ss
new file mode 100644
index 0000000000..87c1fbaf0c
--- /dev/null
+++ b/collects/games/crazy8s/info.ss
@@ -0,0 +1,5 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Crazy 8s")
+  (define doc.txt "doc.txt")
+  (define game "crazy8s.ss")
+  (define game-set "Card Games"))
diff --git a/collects/games/doc.txt b/collects/games/doc.txt
new file mode 100644
index 0000000000..cc3d5c1612
--- /dev/null
+++ b/collects/games/doc.txt
@@ -0,0 +1,140 @@
+_Games_
+=======
+
+The "Games" (Unix: plt/bin/games) executable is created by "Setup PLT"
+(Unix: plt/bin/setup-plt). You can also start Games via Help Desk
+(search for "games").
+
+The Games program lets you select one of the games distributed by PLT,
+or other games installed as sub-collections of the "games" collection
+(see below).
+
+ * Aces - A solitaire card game. Click the "Help" button in Aces for
+   more details.
+
+                                              - by Robby
+
+ * Same - The object is to score points by removing dots from the
+   board. Click the "Help" button in Same for more details.
+
+                                              - by Robby
+
+ * Go Fish (against two computer players) - The children's card game
+   where you try to get rid of all you cards by forming pairs.
+
+                                              - by Matthew
+
+ * Crazy 8s : The card game where you try to get rid of all you cards
+   by matching the top card in the discard pile. Click "Help" in the
+   game for details.
+
+                                              - by Matthew
+
+ * Blackjack : Standard rules. Click "Help" in the game for specifics.
+
+                                              - by Matthew
+
+ * Rummy (against one computer player) - A simple variant of the
+   popular card game. Click "Help" in the game for details.
+
+                                              - by Matthew
+
+ * _Minesweeper_ - A simple version of the classic tile-removing game.
+
+                                              - by Matthew
+
+ * _Memory_ (matching game) - In case you have small children, too.
+
+                                              - by Matthew
+
+ * Paint by Numbers - A logic game. Click the "Help" button in Paint
+   by Numbers for more details.
+
+                                              - by Robby
+
+ * _Lights Out_ - A color-toggling game. Click the "Help" button in
+   Lights Out for more details.
+
+                                              - by Robby
+
+ * Pousse - A game similar to tic-tac-toe, but tokens are pushed
+   onto the board and can move other pieces. Click the "Help" button
+   in Pousse for more details. You can install your own player
+   programs. (This game was part of the 1998 ICFP programming
+   contest.)
+
+                                              - by Matthew
+
+ * GCalc - Not really a game, but a demonstration of "concrete
+   abstractions".  See
+     http://www.grame.fr/Research/GCalcul/Graphic_Calculus.html
+     ftp://ftp.grame.fr/pub/Documents/ICMC94LambdaCalc.pdf
+   for the theoretic details, and right-click anywhere in the game
+   for instructions.
+
+                                              - by Eli
+
+ * Checkers - A simple checkers game (with no AI player) intended
+   as a demonstration use of the gl-board-games library.
+                                             
+					      - by Scott
+
+Implementing new Games
+----------------------
+
+The game-starting console inspects the sub-collections of the "games"
+collection. If a sub-collection has an info.ss definition (see the mzc
+manual), the following fields of the collection's "info.ss" file are
+used:
+
+ * `game' [required] : used as a library name in the sub-collection to
+    load for the game; the library must export a `game-unit' unsigned
+    unit (see MzLib's `unit' form); the unit is invoked with no
+    imports to start the game.
+
+ * `name' [defauls to the collection name] : used to label the
+   game-starting button in the game console.
+
+ * `game-icon' [defaults to collection name with ".png"] : used as a
+   path to a bitmap file taht is used for the game button's label;
+   this image should be 32 x 32 and have a mask.
+
+ * `game-set' [defaults to "Other Games"] : a label used to group
+   games that declare themselves to be in the same set.
+
+To implement card games, see the documentation for the "cards"
+sub-collection of the "games" collection. Card games typically belong
+in the "Cards" game set.
+
+
+Showing Help
+------------
+
+The _show-help.ss_ library provides a `show-help' function for
+displaying a help window.
+
+> (show-help collection frame-title-str verbatim?)
+
+  Returns a thunk for showing a help window. Multiple invocations
+  of the thunk bring the same window to the foreground (until the
+  user closes the window).
+
+  The help window displays "doc.txt" from the given collection, where
+  `coll-path' is a list of strings to select the collection.
+
+  The `frame-title-str' string is used for the help window title.
+
+  If `verbatim?' is true, then "doc.txt" is displayed verbatim,
+  otherwise it is formatted as follows:
+
+   - Any line of the form "** ... **" is omitted.
+
+   - Any line that starts with "*" after whitespace is indented
+     as a bullet point.
+
+   - Any line that contains only "-"s and is as long as the previous
+     line causes the previous line to be formatted as a title.
+
+   - Other lines are pargraph-flowed to fit the window.
+
+  The `verbatim?' argument is optional, and it defaults to #f.
diff --git a/collects/games/games.icns b/collects/games/games.icns
new file mode 100644
index 0000000000..7acd6c28fd
Binary files /dev/null and b/collects/games/games.icns differ
diff --git a/collects/games/games.ico b/collects/games/games.ico
new file mode 100644
index 0000000000..c6fdb6106f
Binary files /dev/null and b/collects/games/games.ico differ
diff --git a/collects/games/games.ss b/collects/games/games.ss
new file mode 100644
index 0000000000..72f1fac634
--- /dev/null
+++ b/collects/games/games.ss
@@ -0,0 +1,114 @@
+(module games mzscheme
+  (require (lib "mred.ss" "mred")
+	   (lib "class.ss")
+           (lib "unit.ss")
+	   (lib "class100.ss")
+	   (lib "list.ss")
+           (lib "getinfo.ss" "setup")
+	   (lib "bitmap-label.ss" "mrlib")
+	   "show-help.ss")
+
+   (define game-mapping 
+     (let ([games (let ([d (collection-path "games")])
+                    (filter (lambda (f)
+                              (let ([p (build-path d f)])
+                                (and (directory-exists? p)
+                                     (with-handlers ([exn:fail? (lambda (x) #f)])
+                                       ((get-info (list (string->path "games") f)) 'game (lambda () #f))))))
+                            (directory-list d)))])
+       (map (lambda (g)
+              (let ([info (get-info `(,(string->path "games") ,g))])
+                (list (path->string g)
+                      (info 'game (lambda () "wrong.ss"))
+                      (info 'name (lambda () g))
+                      (info 'game-set (lambda () "Other Games"))
+		      (info 'game-icon (lambda () (build-path (collection-path "games" g)
+							      (format "~a.png" g)))))))
+            games)))
+               
+   (define f (new (class frame%
+		    (augment*
+		      [on-close (lambda () (exit))])
+		    (super-new))
+		  [label "PLT Games"]
+		  [style '(metal no-resize-border)]))
+   (define hp (make-object horizontal-panel% f))
+   (define main (make-object vertical-panel% hp))
+   (send f set-alignment 'left 'top)
+   (send f stretchable-width #f)
+   (send f stretchable-height #f)
+
+   (define main-horizontal-panel (make-object horizontal-panel% main))
+
+  (define (game-button p desc)
+     (let* ([collect (car desc)]
+	    [file (cadr desc)]
+	    [name (caddr desc)]
+	    [dir (with-handlers ([void (lambda (x) #f)])
+		   (collection-path "games" collect))])
+       (when dir
+	 (make-object button% 
+		      ((bitmap-label-maker name (list-ref desc 4))
+		       p)
+		      p
+		      (lambda (b e)
+			(let ([game-unit (dynamic-wind
+                                          begin-busy-cursor
+                                          (lambda () (dynamic-require (build-path dir file) 'game-unit))
+                                          end-busy-cursor)])
+                          (let ([c (make-custodian)])
+                            (parameterize ([current-custodian c])
+                              (parameterize ([current-eventspace (make-eventspace)])
+                                (queue-callback
+                                 (lambda ()
+                                   (exit-handler (lambda (v) 
+                                                   (custodian-shutdown-all c)))
+                                   (invoke-unit game-unit))))))))))))
+   
+   (let ([game-mapping (quicksort game-mapping (lambda (a b)
+						 (string<? (list-ref a 3) (list-ref b 3))))])
+     (let loop ([l game-mapping])
+       (unless (null? l)
+	 (let* ([set (list-ref (car l) 3)]
+		[p (new group-box-panel%
+			[label set]
+			[parent main-horizontal-panel])])
+	   (let xloop ([here (list (car l))]
+		       [l (cdr l)])
+	     (if (and (pair? l)
+		      (string=? set (list-ref (car l) 3)))
+		 (xloop (cons (car l) here) (cdr l))
+		 (begin
+		   (for-each (lambda (g) (game-button p g)) here)
+		   (loop l))))))))
+
+   (for-each (lambda (p)
+	       (let ([pred (lambda (x y) (<= (send x min-width) (send y min-width)))])
+		 (send p change-children (lambda (l) (quicksort l pred)))))
+	     (send main-horizontal-panel get-children))
+  
+  (send main-horizontal-panel change-children
+        (lambda (l) (quicksort l
+                               (lambda (x y) 
+				 (let ([l1 (length (send x get-children))]
+				       [l2 (length (send y get-children))])
+				   (cond
+				    [(> l1 l2) #t]
+				    [(= l1 l2) (string-ci<? (send x get-label) (send y get-label))]
+				    [else #f]))))))
+
+   (define show-games-help
+     (show-help '("games") "About PLT Games"))
+
+   (application-about-handler show-games-help)
+   (application-preferences-handler (lambda ()
+				      (message-box
+				       "Oops"
+				       "There aren't actually any preferences. This is just a test for Mac OS X"
+				       f
+				       '(ok))))
+   
+   (send f show #t))
+
+
+				     
diff --git a/collects/games/gcalc/doc.txt b/collects/games/gcalc/doc.txt
new file mode 100644
index 0000000000..538b2dac6b
--- /dev/null
+++ b/collects/games/gcalc/doc.txt
@@ -0,0 +1,78 @@
+_GCalc_ a system for visually demonstrating the Lambda Calculus.
+
+See the following for the principles:
+  http://www.grame.fr/Research/GCalcul/Graphic_Calculus.html
+  ftp://ftp.grame.fr/pub/Documents/ICMC94LambdaCalc.pdf
+
+
+The window layout
+-----------------
+
+The window is divided into three working areas, each made of cells.
+Cells hold cube objects, which can be dragged between cells (with a few
+exceptions that are listed below).  The working areas are:
+
+1. The right side is the storage area.
+   This is used for saving objects -- drag any cube to/from here.  Note
+   that cubes can be named for convenience.
+
+2. The left side is a panel of basic color cubes.
+   These cells always contain a set of basic cubes that are used as the
+   primitive building blocks all other values are made of.  They cannot
+   be overwritten.  (Note that this includes a transparent cell.)
+
+3. The center part is the working panel.
+   This is the main panel where new cubes are constructed.  The center
+   cell is similar to a storage cell, and the surrounding eight cells
+   all perform some operation on this cell.
+
+
+User Interaction
+----------------
+
+Right-click any cell except for the basic colors on the left panel, or
+hit escape or F10 for a menu of operations.  The menu also includes the
+keyboard shortcuts for these operations.
+
+
+Cube operations
+---------------
+
+There are six simple operations that are considered part of the simple
+graphic cube world.  The operations correspond to six of the operation
+cells: a left-right composition is built using the left and the right
+cells, a top-bottom using the top and the bottom, and a front-back using
+the top-left and bottom-right.  Dragging a cube to one of these cells
+will use the corresponding operator to combine it with the main cell's
+cube.  Using a right mouse click on one of these cells can be used to
+cancel dragging an object to that cell, this is not really an undo
+feature: a right-click on the right cell always splits the main cube to
+two halves and throws the right side.
+
+The colored cubes and the six basic operators make this simple domain,
+which is extended to form a Lambda-Calculus-like language by adding
+abstractions and applications.  Right-clicking on a basic cube on the
+left panel creates an abstraction which is actually a lambda expression
+except that colors are used instead of syntactic variables.  For
+example, if the main cell contains `R|G' (red-green on the left and
+right), then right-clicking the green cube on the left panel leaves us
+with `lambda G . R|G', which is visualized as `R|G' with a green circle.
+The last two operator cells are used for application of these
+abstractions: drag a function to the top-right to have it applied on the
+main cube, or to the bottom-left to have the main cube applied to it.
+As in the Lambda Calculus, all abstractions have exactly one variable,
+use currying for multiple variables.
+
+So far the result is a domain of colored cubes that can be used in the
+same way as the simple Lambda Calculus.  There is one last extension
+that goes one step further: function cubes can themselves be combined
+with other functions using the simple operations.  This results in
+a form of "spatial functions" that behave differently in different parts
+of the cube according to the construction.  For example, a left-right
+construction of two functions `f|g' operates on a given cube by applying
+`f' on its left part and `g' on its right part.  You can use the
+preferences dialog to change a few aspects of the computation.
+
+Use the "Open Example" menu entry to open a sample file that contains
+lots of useful objects (Church numerals, booleans, lists, Y-combinator,
+etc).
diff --git a/collects/games/gcalc/gcalc-examples b/collects/games/gcalc/gcalc-examples
new file mode 100644
index 0000000000..4e5afe4f57
--- /dev/null
+++ b/collects/games/gcalc/gcalc-examples
@@ -0,0 +1,9 @@
+"GCALC"
+#t
+18
+8
+#f
+#f
+#f
+(#f . #f)
+(("true" lambda (var green) (lambda (var red) (var green) #f) #f) ("cons" lambda (var green) (lambda (var red) (lambda (var blue) (apply (apply (var blue) (var green)) (var red))))) ("zero" lambda (var green) (lambda (var red) (var red) #f) #f) ("zero?" lambda (var blue) (apply (apply (var blue) (lambda (var red) (lambda (var green) (lambda (var red) (var red))))) (lambda (var green) (lambda (var red) (var green))))) ("sub1" lambda (var dk-green) (apply (apply (apply (var dk-green) (lambda (var magenta) (lambda (var blue) (apply (apply (var blue) (apply (var magenta) (lambda (var green) (lambda (var red) (var red))))) (lambda (var green) (lambda (var red) (apply (var green) (apply (apply (apply (var magenta) (lambda (var green) (lambda (var red) (var red)))) (var green)) (var red))))))))) (lambda (var blue) (apply (apply (var blue) (lambda (var green) (lambda (var red) (var red)))) (lambda (var green) (lambda (var red) (var red)))))) (lambda (var green) (lambda (var red) (var green))))) ("false" lambda (var green) (lambda (var red) (var red) #f) #f) ("car" lambda (var blue) (apply (var blue) (lambda (var green) (lambda (var red) (var green))))) ("one" lambda (var green) (lambda (var red) (apply (var green) (var red)))) ("add1" lambda (var blue) (lambda (var green) (lambda (var red) (apply (var green) (apply (apply (var blue) (var green)) (var red)))))) ("minus" lambda (var green) (lambda (var red) (apply (apply (var red) (lambda (var dk-green) (apply (apply (apply (var dk-green) (lambda (var magenta) (lambda (var blue) (apply (apply (var blue) (apply (var magenta) (lambda (var green) (lambda (var red) (var red))))) (lambda (var green) (lambda (var red) (apply (var green) (apply (apply (apply (var magenta) (lambda (var green) (lambda (var red) (var red)))) (var green)) (var red))))))))) (lambda (var blue) (apply (apply (var blue) (lambda (var green) (lambda (var red) (var red)))) (lambda (var green) (lambda (var red) (var red)))))) (lambda (var green) (lambda (var red) (var green)))))) (var green)))) ("if" lambda (var dk-gray) (lambda (var gray) (lambda (var lt-gray) (apply (apply (var dk-gray) (var gray)) (var lt-gray))))) ("cdr" lambda (var blue) (apply (var blue) (lambda (var green) (lambda (var red) (var red))))) ("two" lambda (var green) (lambda (var red) (apply (var green) (apply (apply (lambda (var green) (lambda (var red) (apply (var green) (apply (apply (lambda (var green) (lambda (var red) (var red) #f) #f) (var green)) (var red))))) (var green)) (var red))))) ("plus" lambda (var green) (lambda (var red) (apply (apply (var green) (lambda (var blue) (lambda (var green) (lambda (var red) (apply (var green) (apply (apply (var blue) (var green)) (var red))))))) (var red)))) (#f . #f) ("and" lambda (var green) (lambda (var red) (apply (apply (var green) (var red)) (var green) #t) #t) #t) ("null" lambda (var green) (lambda (var green) (lambda (var red) (var green)))) ("three" lambda (var green) (lambda (var red) (apply (var green) (apply (apply (lambda (var green) (lambda (var red) (apply (var green) (apply (apply (lambda (var green) (lambda (var red) (apply (var green) (apply (apply (lambda (var green) (lambda (var red) (var red) #f) #f) (var green)) (var red))))) (var green)) (var red))))) (var green)) (var red))))) ("times" lambda (var green) (lambda (var red) (lambda (var blue) (apply (var green) (apply (var red) (var blue)))))) (#f . #f) ("or" lambda (var green) (lambda (var red) (apply (apply (var green) (var green)) (var red)))) ("null?" lambda (var green) (apply (var green) (lambda (var green) (lambda (var red) (lambda (var green) (lambda (var red) (var red))))))) ("Y-comb" lambda (var red) (apply (var red) (apply (lambda (var green) (apply (var red) (apply (var green) (var green)))) (lambda (var green) (apply (var red) (apply (var green) (var green))))) #t) #t) (#f . #f) (#f . #f) ("id" lambda (var white) (var white) #f) ("hole" lambda (var white) transparent #t) ("slicer" \| (\| (\| (\| (lambda (var white) (var white) #f) (lambda (var white) transparent #t)) (\| (lambda (var white) (var white) #f) (lambda (var white) transparent #t))) (\| (\| (lambda (var white) (var white) #f) (lambda (var white) transparent #t)) (\| (lambda (var white) (var white) #f) (lambda (var white) transparent #t)))) (\| (\| (\| (lambda (var white) (var white) #f) (lambda (var white) transparent #t)) (\| (lambda (var white) (var white) #f) (lambda (var white) transparent #t))) (\| (\| (lambda (var white) (var white) #f) (lambda (var white) transparent #t)) (\| (lambda (var white) (var white) #f) (lambda (var white) transparent #t))))) (#f . #f) (#f . #f) ("\\x.x1" lambda (var gray) (/ (- (\| red (var gray) #f) (\| (var gray) green #f) #f) (- (\| (var gray) yellow #f) (\| blue (var gray) #f) #f) #f) #f) ("x1" / (- (\| red gray #f) (\| gray green #f) #f) (- (\| gray yellow #f) (\| blue gray #f) #f) #f) ("x2" / (- (\| green red) (\| red green)) (- (\| red green) (\| green red))) ("numtest (\\n.n(\\x.x1)trn)" lambda (var black) (apply (apply (var black) (lambda (var gray) (/ (- (\| red (var gray) #f) (\| (var gray) green #f) #f) (- (\| (var gray) yellow #f) (\| blue (var gray)))))) transparent)) (#f . #f) (#f . #f) (#f . #f) (#f . #f) (#f . #f) (#f . #f))
diff --git a/collects/games/gcalc/gcalc.png b/collects/games/gcalc/gcalc.png
new file mode 100644
index 0000000000..aae39cd023
Binary files /dev/null and b/collects/games/gcalc/gcalc.png differ
diff --git a/collects/games/gcalc/gcalc.ss b/collects/games/gcalc/gcalc.ss
new file mode 100644
index 0000000000..5eae35f920
--- /dev/null
+++ b/collects/games/gcalc/gcalc.ss
@@ -0,0 +1,1027 @@
+;;;============================================================================
+;;; GCalc
+;;;   based on http://www.grame.fr/Research/GCalcul/Graphic_Calculus.html
+;;;   implemented by Eli Barzilay: Maze is Life! (eli@barzilay.org)
+
+(module gcalc mzscheme
+  (require (lib "class.ss") (lib "mred.ss" "mred") (lib "etc.ss")
+           "../show-help.ss" (lib "unit.ss"))
+  (provide game-unit)
+
+  (define customs '())
+  (define (add-custom! name get set type desc)
+    (set! customs
+          (append! customs (list (make-custom name get set type desc)))))
+  (define-struct custom (name getter setter type description))
+  (define-syntax defcustom
+    (syntax-rules ()
+      [(_ var default type description)
+       (begin (define var default)
+              (add-custom! 'var (lambda () var) (lambda (v) (set! var v))
+                           type description))]))
+  (define game-unit
+    (unit (import) (export)
+
+;;;============================================================================
+;;; Customizations etc
+
+(defcustom EVAL-NOW    #t 'bool      "Evaluate immediately on application")
+(defcustom EVAL-DEPTH  18 '(int 100) "Evaluation depth limit")
+(defcustom DRAW-CUTOFF 8 '(int 50)  "Cutoff evaluation when smaller")
+(defcustom SPLIT-ARGS  #f 'bool      "Split arg by function body structure")
+(defcustom COLOR-OPS   #f 'bool      "Use colors as functions")
+(defcustom NOBMP-PRINT #f 'bool      "Never use bitmaps to print")
+
+(define DK-PEN (instantiate pen% ("BLACK" 1 'solid)))
+(define LT-PEN (instantiate pen% ("WHITE" 1 'solid)))
+
+(define COLORS
+  (map (lambda (c)
+         (list
+          (car c)
+          (cond [(null? (cdr c)) (instantiate pen% ("WHITE" 1 'transparent))]
+                [(eq? (car c) 'black) LT-PEN]
+                [else DK-PEN])
+          (if (null? (cdr c))
+            (instantiate brush% ("BLACK" 'transparent))
+            (instantiate brush% [(apply make-object color% (cdr c)) 'solid]))))
+       '((transparent)
+         (black         0   0   0)
+         (dk-gray      64  64  64)
+         (gray        128 128 128)
+         (lt-gray     192 192 192)
+         (white       255 255 255)
+         (dk-red      128   0   0)
+         (red         255   0   0)
+         (dk-green      0 128   0)
+         (green         0 255   0)
+         (dark-blue     0   0 128)
+         (blue          0   0 255)
+         (dk-yellow   128 128   0)
+         (yellow      255 255   0)
+         (dk-cyan       0 128 128)
+         (cyan          0 255 255)
+         (dk-magenta  128   0 128)
+         (magenta     255   0 255))))
+
+(define COLOR-CELL-ROW 2)
+(define COLOR-CELL-COL (/ (length COLORS) COLOR-CELL-ROW))
+(define OPERS-CELL-ROW 3)
+(define OPERS-CELL-COL 3)
+(define STORE-CELL-ROW 5)
+(define STORE-CELL-COL 8)
+(define GLOBAL-HEIGHT (* 7 (lcm COLOR-CELL-COL OPERS-CELL-COL STORE-CELL-COL)))
+
+(define COLOR-CELL-SIZE (/ GLOBAL-HEIGHT COLOR-CELL-COL))
+(define OPERS-CELL-SIZE (/ GLOBAL-HEIGHT OPERS-CELL-COL))
+(define STORE-CELL-SIZE (/ GLOBAL-HEIGHT STORE-CELL-COL))
+
+(define SHOW-CELL-SIZE 600)
+
+(define BG-PEN/BRUSH  (list (instantiate pen%   ["BLACK" 1 'solid])
+                            (instantiate brush% ["GRAY" 'solid])))
+(define XOR-PEN/BRUSH (list (instantiate pen%   ["BLACK" 0 'xor])
+                            (instantiate brush% ["BLACK" 'xor])))
+
+(define DOUBLE-MILISECS 250)
+
+(define CELL-BORDER 6)
+
+(define CELL-FONT (instantiate font% (10 'decorative 'normal 'normal)))
+(define SHOW-FONT (instantiate font% (32 'decorative 'normal 'normal)))
+
+(define APPLY-SIZE  0.40)
+(define ABSTR-GAP   0.1)
+(define ABSTR-SIZE  0.3)
+(define 3D-DX       0.4)
+(define 3D-DY       0.5)
+(define 3D-OFFSET   (+ CELL-BORDER 2))
+
+;;;============================================================================
+;;; Utilities
+
+(define 1st car)
+(define 2nd cadr)
+(define 3rd caddr)
+(define 4th cadddr)
+
+(define (eprintf . args)
+  (apply fprintf (current-error-port) args))
+
+(define (read-from-string str)
+  (with-handlers ([void (lambda (x) #f)])
+    (let ([obj (read (open-input-string (string-append "(" str ")")))])
+      (and (list? obj) (= 1 (length obj)) (car obj)))))
+
+(define (write-to-string obj)
+  (format "~s" obj))
+
+(define (set-pen/brush dc p/b)
+  (send dc set-pen   (1st p/b))
+  (send dc set-brush (2nd p/b)))
+
+;;;============================================================================
+;;; GCalc definition
+
+(define var-num 0)
+(define (get-next-vnum)
+  (set! var-num (add1 var-num))
+  var-num)
+(define (make-var var)
+  (list 'var var
+        ;;(get-next-vnum) - no need for this since we only use closed terms
+        ))
+(define (var-val var)
+  (2nd var))
+(define (var-expr? expr)
+  (and (pair? expr) (eq? (1st expr) 'var)))
+
+(define null-expr #f)
+(define (null-expr? expr)
+  (eq? expr null-expr))
+
+(define make-expr list)
+(define expr-op   1st)
+(define expr-1st  2nd)
+(define expr-2nd  3rd)
+
+(define (simple-expr? expr)
+  (or (not (pair? expr)) (eq? (car expr) 'var)))
+(define (composite-expr? expr . type)
+  (and (pair? expr)
+       (if (null? type)
+         (not (eq? (car expr) 'var))
+         (eq? (expr-op expr) (car type)))))
+
+(define (make-left-right expr1 expr2)
+  (make-expr '\| expr1 expr2))
+(define (make-right-left expr1 expr2)
+  (make-left-right expr2 expr1))
+(define (left-right-expr? expr)
+  (composite-expr? expr '\|))
+
+(define (make-top-bottom expr1 expr2)
+  (make-expr '- expr1 expr2))
+(define (make-bottom-top expr1 expr2)
+  (make-top-bottom expr2 expr1))
+(define (top-bottom-expr? expr)
+  (composite-expr? expr '-))
+
+(define (make-front-back expr1 expr2)
+  (make-expr '/ expr1 expr2))
+(define (make-back-front expr1 expr2)
+  (make-front-back expr2 expr1))
+(define (front-back-expr? expr)
+  (composite-expr? expr '/))
+
+(define (make-application1 expr1 expr2)
+  (make-expr 'apply expr1 expr2))
+(define (make-application2 expr1 expr2)
+  (make-expr 'apply expr2 expr1))
+(define (application-expr? expr)
+  (composite-expr? expr 'apply))
+
+(define (make-abstraction expr1 expr2)
+  (if (simple-expr? expr1)
+    (let ([var (make-var expr1)])
+      (make-expr 'lambda var (substitute var expr1 expr2)))
+    null-expr))
+(define (abstraction-expr? expr)
+  (composite-expr? expr 'lambda))
+
+(define (expr-size expr)
+  (if (composite-expr? expr)
+    (+ 1 (expr-size (expr-1st expr)) (expr-size (expr-2nd expr)))
+    1))
+
+(define (recolor-expr color expr)
+  (define (get-rgb color)
+    (cond [(or (eq? color 'transparent) (null-expr? color)) color]
+          [(symbol? color)
+           (let ([c (send (3rd (assq color COLORS)) get-color)])
+             (list (send c red) (send c green) (send c blue)))]
+          [else (vector->list color)]))
+  (define (mix rgb1 rgb2)
+    (cond [(equal? rgb1 rgb2) (list->vector rgb1)]
+          [(or (null-expr? rgb1) (null-expr? rgb2)) null-expr]
+          [(or (eq? rgb1 'transparent) (eq? rgb2 'transparent)) 'transparent]
+          [else (list->vector (map (lambda (c1 c2)
+                                     (inexact->exact (round (/ (+ c1 c2) 2))))
+                                   rgb1 rgb2))]))
+  (let ([color (get-rgb color)])
+    (let loop ([expr expr])
+      (cond [(or (var-expr? expr) (null-expr? expr)) expr]
+            [(simple-expr? expr) (mix color (get-rgb expr))]
+            [else (make-expr (expr-op expr)
+                             (loop (expr-1st expr))
+                             (loop (expr-2nd expr)))]))))
+
+(define (reduce-application expr . level)
+  (define (reduce expr level)
+    (if (and level (<= level 0))
+      expr
+      (let ([1st (let ([e (expr-1st expr)])
+                   (if (application-expr? e)
+                     (reduce-application e (and level (sub1 level)))
+                     e))]
+            [2nd (expr-2nd expr)])
+        (cond
+         [(and COLOR-OPS (simple-expr? 1st) (not (var-expr? 1st)))
+          (recolor-expr 1st 2nd)]
+         [(or (simple-expr? 1st) (application-expr? 1st)) expr]
+         [(abstraction-expr? 1st)
+          (substitute 2nd (expr-1st 1st) (expr-2nd 1st))]
+         [else
+          (let ([2nd (split-expr 2nd (expr-op 1st))])
+            (make-expr (expr-op 1st)
+                       (make-application1 (expr-1st 1st) (expr-1st 2nd))
+                       (make-application1 (expr-2nd 1st) (expr-2nd 2nd))))]))))
+  (let* ([level (if (null? level) EVAL-DEPTH (car level))]
+         [new   (reduce expr level)])
+    (if (and (application-expr? new) (not (equal? new expr))
+             (or (not level) (> level 0)))
+      (reduce-application new (and level (if (> level 0) (sub1 level) 0)))
+      new)))
+
+#; ;; No need for this now
+(define (eval-expr expr)
+  (define (eval-expr expr level)
+    (cond
+     [(zero? level) null-expr]
+     [(or (simple-expr? expr) (abstraction-expr? expr)) expr]
+     [(application-expr? expr)
+      (let ([1st (eval-expr (expr-1st expr) (sub1 level))]
+            [2nd (eval-expr (expr-2nd expr) (sub1 level))])
+        (cond
+         [(and COLOR-OPS (simple-expr? 1st) (not (var-expr? 1st)))
+          (recolor-expr 1st 2nd)]
+         [(or (simple-expr? 1st) (application-expr? 1st)) expr]
+         [(abstraction-expr? 1st)
+          (eval-expr (substitute 2nd (expr-1st 1st) (expr-2nd 1st))
+                     (sub1 level))]
+         [else
+          (let ([2nd (split-expr (eval-expr 2nd (sub1 level)) (expr-op 1st))])
+            (make-expr
+             (expr-op 1st)
+             (eval-expr (make-application (expr-1st 1st) (expr-1st 2nd))
+                        (sub1 level))
+             (eval-expr (make-application (expr-2nd 1st) (expr-2nd 2nd))
+                        (sub1 level))))]))]
+     [else
+      (make-expr (expr-op expr)
+                 (eval-expr (expr-1st expr) (sub1 level))
+                 (eval-expr (expr-2nd expr) (sub1 level)))]))
+  (dynamic-wind
+    begin-busy-cursor
+    (lambda () (eval-expr expr (or EVAL-DEPTH -1)))
+    end-busy-cursor))
+
+(define (split-expr expr op)
+  (cond
+   [(or (simple-expr? expr) (abstraction-expr? expr))
+    (make-expr op expr expr)]
+   [(eq? (expr-op expr) op) expr]
+   [else
+    (let* ([e1   (split-expr (expr-1st expr) op)]
+           [e2   (split-expr (expr-2nd expr) op)]
+           [e11  (expr-1st e1)]
+           [e12  (expr-2nd e1)]
+           [e21  (expr-1st e2)]
+           [e22  (expr-2nd e2)]
+           [e-op (expr-op expr)])
+      (make-expr op (make-expr e-op e11 e21) (make-expr e-op e12 e22)))]))
+
+(define (substitute new old expr)
+  (cond
+   [(composite-expr? expr)
+    (if (and (abstraction-expr? expr) (equal? (expr-1st expr) old))
+      expr
+      (let-values ([(new1 new2) (if SPLIT-ARGS
+                                  (let ([x (split-expr new (expr-op expr))])
+                                    (values (expr-1st x) (expr-2nd x)))
+                                  (values new new))])
+        (make-expr (expr-op expr)
+                   (substitute new1 old (expr-1st expr))
+                   (substitute new2 old (expr-2nd expr)))))]
+   [(equal? expr old) new]
+   [else expr]))
+
+(define (valid-expr? obj)
+  (cond [(null-expr? obj) #t]
+        [(list? obj)   (case (length obj)
+                         [(2) (and (eq? (1st obj) 'var)
+                                   (not (list? (2nd obj)))
+                                   (valid-expr? (2nd obj)))]
+                         [(3 4) (case (car obj)
+                                  [(\| - / apply lambda)
+                                   (and (valid-expr? (expr-1st obj))
+                                        (valid-expr? (expr-2nd obj)))]
+                                  [else #f])])]
+        [(symbol? obj) (and (assq obj COLORS) #t)]
+        [(vector? obj) (and (= (vector-length obj) 3)
+                            (let ([ok? (lambda (x)
+                                         (and (integer? x) (<= 0 x 255)))])
+                              (and (ok? (vector-ref obj 0))
+                                   (ok? (vector-ref obj 1))
+                                   (ok? (vector-ref obj 2)))))]
+        [else #f]))
+(define (valid-contents? obj)
+  (and (pair? obj)
+       (or (not (car obj)) (string? (car obj)))
+       (valid-expr? (cdr obj))))
+(define (validate-contents obj)
+  (if (valid-contents? obj)
+    obj
+    (begin (eprintf "~s is not a valid contents.\n" obj)
+           (error 'validate-contents "~s is not a valid contents." obj))))
+
+;;;============================================================================
+;;; GCalc drawing
+
+(define (expr-contains-transparent? expr)
+  (if (simple-expr? expr)
+    (or (null-expr? expr) (eq? expr 'transparent)
+        (and (var-expr? expr) (eq? (var-val expr) 'transparent)))
+    (let ([last (cddr expr)])
+      (when (null? (cdr last))
+        (set-cdr!
+         last
+         (list
+          (cond [(abstraction-expr? expr)
+                 (expr-contains-transparent? (expr-2nd expr))]
+                [(application-expr? expr)
+                 #t]
+                [else (or (expr-contains-transparent? (expr-1st expr))
+                          (expr-contains-transparent? (expr-2nd expr)))]))))
+      (2nd last))))
+
+;; Draw an exprression - the smart way.
+(define (draw-expr dc expr name . r)
+  (define size
+    (let-values ([(sx sy) (send dc get-size)]) (inexact->exact (min sx sy))))
+  (define eval? (if (null? r) #f (car r)))
+  (define (avg x y) (/ (+ x y) 2))
+  (define (rnd x) (inexact->exact (round x)))
+  (define dc-ofs 3D-OFFSET)
+  (define dc-size (- size dc-ofs dc-ofs))
+  (define draw-polygon ; efficient (could be more if it was global)
+    (let* ([p1 (instantiate point% ())] [p2 (instantiate point% ())]
+           [p3 (instantiate point% ())] [p4 (instantiate point% ())]
+           [points (list p1 p2 p3 p4)])
+      (lambda (x1 y1 x2 y2 x3 y3 x4 y4)
+        (send* p1 (set-x x1) (set-y y1)) (send* p2 (set-x x2) (set-y y2))
+        (send* p3 (set-x x3) (set-y y3)) (send* p4 (set-x x4) (set-y y4))
+        (send dc draw-polygon points))))
+  (define tmp-color (instantiate color% [])) ; reused for drawing colors
+  (define (draw expr level left? top? front? x1 y1 z1 x2 y2 z2 abstr)
+    (define eval? (or (not level) (> level 0)))
+    (define lev1  (and level (if (> level 0) (sub1 level) 0)))
+    (when (and eval? (application-expr? expr))
+      (set! expr (reduce-application expr level)))
+    (cond
+     [(null-expr? expr) expr]
+     [(composite-expr? expr)
+      (let ([1st (expr-1st expr)] [2nd (expr-2nd expr)])
+        (cond
+         [(left-right-expr? expr)
+          (let ([cut? (and DRAW-CUTOFF (< (* (- x2 x1) size) DRAW-CUTOFF))]
+                [x12  (avg x1 x2)]
+                [t?   (expr-contains-transparent? 1st)])
+            (make-right-left
+             (if (and (not cut?) (or top? front? t?))
+               (draw 2nd lev1 t? top? front? x12 y1 z1 x2 y2 z2 .0) 2nd)
+             (if cut?
+               (draw 1st lev1 left? top? front? x1 y1 z1 x2 y2 z2 abstr)
+               (draw 1st lev1 left? top? front? x1 y1 z1 x12 y2 z2 .0))))]
+         [(top-bottom-expr? expr)
+          (let ([cut? (and DRAW-CUTOFF (< (* (- y2 y1) size) DRAW-CUTOFF))]
+                [y12  (avg y1 y2)]
+                [t?   (expr-contains-transparent? 1st)])
+            (make-bottom-top
+             (if (and (not cut?) (or left? front? t?))
+               (draw 2nd lev1 left? t? front? x1 y12 z1 x2 y2 z2 .0) 2nd)
+             (if cut?
+               (draw 1st lev1 left? top? front? x1 y1 z1 x2 y2 z2 abstr)
+               (draw 1st lev1 left? top? front? x1 y1 z1 x2 y12 z2 .0))))]
+         [(front-back-expr? expr)
+          (let ([cut? (and DRAW-CUTOFF (< (* (- z2 z1) size) DRAW-CUTOFF))]
+                [z12  (avg z1 z2)]
+                [t?   (expr-contains-transparent? 1st)])
+            (make-back-front
+             (if (and (not cut?) (or left? top? t?))
+               (draw 2nd lev1 left? top? t? x1 y1 z1 x2 y2 z12 .0) 2nd)
+             (if cut?
+               (draw 1st lev1 left? top? front? x1 y1 z1 x2 y2 z2 abstr)
+               (draw 1st lev1 left? top? front? x1 y1 z12 x2 y2 z2 .0))))]
+         [(abstraction-expr? expr)
+          (draw 2nd 0 left? top? front? x1 y1 z1 x2 y2 z2 (+ abstr ABSTR-GAP))
+          (set-pen/brush dc (cdr (assq (var-val 1st) COLORS)))
+          (let ([xx (+ (rnd (* (+ x1 (* (- x2 x1) abstr) (* 3D-DX z2))
+                               (/ dc-size (+ 1 3D-DX))))
+                       dc-ofs)]
+                [yy (+ (rnd (* (+ y1 (* 3D-DY z2)) (/ dc-size (+ 1 3D-DY))))
+                       dc-ofs)]
+                [dx (rnd (* ABSTR-SIZE (- x2 x1) (/ dc-size (+ 1 3D-DX))))]
+                [dy (rnd (* ABSTR-SIZE (- y2 y1) (/ dc-size (+ 1 3D-DY))))])
+            (send dc draw-ellipse xx yy dx dy))
+          expr]
+         [(application-expr? expr)
+          (let* ([x12 (avg x1 x2)]
+                 [y12 (avg y1 y2)]
+                 [dx  (* (- x2 x1) 1/2 APPLY-SIZE)]
+                 [dy  (* (- y2 y1) 1/2 APPLY-SIZE)]
+                 [xx1 (- x12 dx)]
+                 [yy1 (- y12 dy)]
+                 [xx2 (+ x12 dx)]
+                 [yy2 (+ y12 dy)]
+                 [zz  (* (- z2 z1) APPLY-SIZE)]
+                 [z11 (+ z1 zz)]
+                 [z22 (- z2 zz)])
+            (make-application1
+             (draw 1st lev1 left? top? front? xx1 yy1 z1 xx2 yy2 z11 .0)
+             (draw 2nd lev1 left? top? front? xx1 yy1 z22 xx2 yy2 z2 .0)))]
+         [else (error 'draw-expr "Unknown composite expr -- ~s." expr)]))]
+     [(simple-expr? expr)
+      (unless (eq? 'transparent (if (var-expr? expr) (var-val expr) expr))
+        (let* (;;
+               ;; Calculate points:
+               ;;
+               ;;  xx0xx1    xx2 xx3
+               ;;  |  |      |   |
+               ;;  P---------P   -- yy0
+               ;;  |\         \
+               ;;  | \         \
+               ;;  |  P---------P-- yy1
+               ;;  |  |         |
+               ;;  P  |         |-- yy2
+               ;;   \ |         |
+               ;;    \|         |
+               ;;     P---------P-- yy3
+               ;;
+               ;;  (xx1 - x1) = (x2 - xx2) = (3D-DX * (x2 - x1))
+               ;;   and the same for y values
+               ;;
+               [dx  (* 3D-DX (- z2 z1))]
+               [xx0 (+ x1 (* z1 3D-DX))]
+               [xx1 (+ xx0 dx)]
+               [xx2 (+ x2 (* z1 3D-DX))]
+               [xx3 (+ xx2 dx)]
+               [dy  (* 3D-DY (- z2 z1))]
+               [yy0 (+ y1 (* z1 3D-DY))]
+               [yy1 (+ yy0 dy)]
+               [yy2 (+ y2 (* z1 3D-DY))]
+               [yy3 (+ yy2 dy)]
+               [xx00 (+ (rnd (* (/ xx0 (+ 1 3D-DX)) dc-size)) dc-ofs)]
+               [xx11 (+ (rnd (* (/ xx1 (+ 1 3D-DX)) dc-size)) dc-ofs)]
+               [xx22 (+ (rnd (* (/ xx2 (+ 1 3D-DX)) dc-size)) dc-ofs)]
+               [xx33 (+ (rnd (* (/ xx3 (+ 1 3D-DX)) dc-size)) dc-ofs)]
+               [yy00 (+ (rnd (* (/ yy0 (+ 1 3D-DY)) dc-size)) dc-ofs)]
+               [yy11 (+ (rnd (* (/ yy1 (+ 1 3D-DY)) dc-size)) dc-ofs)]
+               [yy22 (+ (rnd (* (/ yy2 (+ 1 3D-DY)) dc-size)) dc-ofs)]
+               [yy33 (+ (rnd (* (/ yy3 (+ 1 3D-DY)) dc-size)) dc-ofs)])
+          (set-pen/brush
+           dc
+           (cond
+            [(var-expr? expr) (cdr (assq (var-val expr) COLORS))]
+            [(symbol? expr)   (cdr (assq expr COLORS))]
+            [else ; explicit color
+             (send tmp-color set
+                   (vector-ref expr 0) (vector-ref expr 1) (vector-ref expr 2))
+             (list DK-PEN (send the-brush-list find-or-create-brush
+                                tmp-color 'solid))]))
+          (draw-polygon xx11 yy11 xx00 yy00 xx22 yy00 xx33 yy11)
+          (draw-polygon xx11 yy11 xx00 yy00 xx00 yy22 xx11 yy33)
+          (draw-polygon xx11 yy11 xx33 yy11 xx33 yy33 xx11 yy33)))
+      expr]
+     [else (error 'draw-expr "Unknown expr -- ~s." expr)]))
+  (dynamic-wind
+    begin-busy-cursor
+    (lambda ()
+      (send dc clear)
+      (set-pen/brush dc BG-PEN/BRUSH)
+      (send dc draw-rectangle 1 1 size size)
+      (let ([expr (draw expr (if eval? EVAL-DEPTH 0)
+                        #t #t #t .0 .0 .0 1.0 1.0 1.0 .0)])
+        (when name
+          (let-values ([(tw th d a) (send dc get-text-extent name)])
+            (let ([tw (min tw (- size 6))])
+              (set-pen/brush dc BG-PEN/BRUSH)
+              (send dc draw-rectangle (- size tw 3) 1 (+ 3 tw) (+ 2 th))
+              (send dc draw-text name (max 0 (- size tw 1)) 2))))
+        expr))
+    end-busy-cursor))
+
+;;;============================================================================
+;;; GUI
+
+(define gcalc-frame
+  (instantiate
+   (class frame%
+     (define/augment (on-close) (maybe-save-and-exit))
+     (define/public (open-file file) (open file))
+     (super-instantiate ("GCalc") (style '(no-resize-border)))
+     (send this stretchable-width #f)
+     (send this stretchable-height #f))
+   ()))
+
+(define main-pane
+  (instantiate horizontal-pane% (gcalc-frame)))
+
+(define help
+  (show-help (list "games" "gcalc") "GCalc Help" #t))
+
+(define file-name #f)
+(define modified? #f)
+(define (set-file-name! name)
+  (set! file-name name)
+  (send gcalc-frame set-label (string-append "GCalc: " name)))
+(define (save)
+  (if file-name
+    (begin
+      (when (file-exists? file-name) (delete-file file-name))
+      (with-output-to-file file-name
+        (lambda ()
+          (dynamic-wind
+            begin-busy-cursor
+            (lambda ()
+              (define (out x) (write x) (newline))
+              (out "GCALC")
+              (for-each (lambda (c) (out ((custom-getter c)))) customs)
+              (out (send main-cell get-contents))
+              (out (get-storage-contents))
+              (set! modified? #f))
+            end-busy-cursor)
+          (message-box "Save" (format "~s saved." file-name)
+                       gcalc-frame '(ok)))))
+    (save-as)))
+(define (open-examples)
+  (open (path->string (build-path (this-expression-source-directory)
+                                  "gcalc-examples"))))
+(define (open . file)
+  (maybe-save)
+  (let ([f (if (not (null? file))
+             (car file)
+             (path->string (get-file "Open" gcalc-frame)))])
+    (when f
+      (if (file-exists? f)
+        (with-input-from-file f
+          (lambda ()
+            (dynamic-wind
+              begin-busy-cursor
+              (lambda ()
+                (with-handlers
+                    ([exn:fail?
+                      (lambda (x)
+                        (message-box
+                         "Open" (format "~s is not a GCalc file." f)
+                         gcalc-frame '(ok)))])
+                  (or (equal? "GCALC" (read)) (error))
+                  (set-file-name! f)
+                  (for-each (lambda (c) ((custom-setter c) (read))) customs)
+                  (send main-cell set-contents! (validate-contents (read)))
+                  (set-storage-contents! (map validate-contents (read)))
+                  (set! modified? #f)))
+              end-busy-cursor)))
+        (message-box "Open" (format "~s does not exists." f)
+                     gcalc-frame '(ok))))))
+(define (save-as)
+  (let ([f (get-file "Save-as" gcalc-frame)])
+    (when f
+      (if (directory-exists? f)
+        (message-box
+         "Save-as" (format "\"~a\" is a directory." f) gcalc-frame '(ok))
+        (when (or (not (file-exists? f))
+                  (eq? 'yes
+                       (message-box
+                        "Save-as" (format "\"~a\" exists, overwrite?" f)
+                        gcalc-frame '(yes-no))))
+          (set-file-name! (path->string f))
+          (save))))))
+(define (maybe-save)
+  (when (and modified?
+             (begin
+               (bell)
+               (eq? 'yes
+                    (message-box
+                     "GCalc" "Save modifications?" gcalc-frame '(yes-no)))))
+    (save)))
+(define (maybe-save-and-exit)
+  (maybe-save)
+  (set! modified? #f) ; can appear again from drscheme
+  (send gcalc-frame show #f))
+
+(define set-options
+  (let ([dlg (instantiate dialog% ("GCalc Expression" gcalc-frame))])
+    (define ok? #f)
+    (define inits (lambda () (set! ok? #f)))
+    (define finals (lambda () (set! modified? #t)))
+    (define (add-init/final initializer finalizer)
+      (let ([c inits])  (set! inits  (lambda () (initializer) (c))))
+      (let ([c finals]) (set! finals (lambda () (finalizer)   (c)))))
+    (define (new-row . a)
+      (let ([p (instantiate horizontal-pane% (dlg))])
+        (send p set-alignment (if (null? a) 'left (car a)) 'center)
+        p))
+    (define (make-check-box getter setter title)
+      (let ([cb (instantiate check-box% (title (new-row) void))])
+        (add-init/final (lambda () (send cb set-value (getter)))
+                        (lambda () (setter (send cb get-value))))))
+    (define (make-check/slide getter setter title range)
+      (define row (new-row))
+      (define toggle
+        (instantiate check-box%
+          (title row
+           (let ([saved 0])
+             (lambda (this e)
+               (if (send this get-value)
+                 (send slider set-value saved)
+                 (begin (set! saved (send slider get-value))
+                        (send slider set-value 0))))))))
+      (define slider
+        (instantiate slider%
+          ["" 0 range row
+           (lambda (this e)
+             (send toggle set-value (not (zero? (send this get-value)))))]))
+      (add-init/final (lambda ()
+                        (let ([val (getter)])
+                          (send slider set-value (or val 0))
+                          (send toggle set-value (and val #t))))
+                      (lambda ()
+                        (setter (and (send toggle get-value)
+                                     (send slider get-value))))))
+    (define (make-ok-cancel)
+      (let ([row (new-row 'center)])
+        (instantiate button%
+          ["&OK" row (lambda (this e) (set! ok? #t) (send dlg show #f))]
+          [style '(border)])
+        (instantiate button%
+          ["&Cancel" row (lambda (this e) (send dlg show #f))])))
+    ;; Dialog components
+    (for-each (lambda (c)
+                (let ([type   (custom-type        c)]
+                      [getter (custom-getter      c)]
+                      [setter (custom-setter      c)]
+                      [desc   (custom-description c)])
+                  (cond [(eq? type 'bool) (make-check-box getter setter desc)]
+                        [(and (pair? type) (eq? (1st type) 'int))
+                         (make-check/slide getter setter desc (2nd type))])))
+              customs)
+    (make-ok-cancel)
+    ;; Main
+    (lambda () (inits) (send dlg show #t) (when ok? (finals)))))
+
+(define cell-menu-items   `((#\x      "C&ut"           cut:)
+                            (#\c      "&Copy"          copy:)
+                            (#\v      "Pas&te"         paste:)
+                            (#\r      "Clea&r"         clear:)
+                            (#\e      "&Eval"          eval:)
+                            (#\n      "Re&name"        rename:)
+                            (#\space  "Sho&w"          show:)
+                            (#\p      "&Print"         print:)))
+(define global-menu-items `((#\h      "&Help"          ,help)
+                            (#\o      "&Open"          ,open)
+                            (#\m      "Open-Exa&mples" ,open-examples)
+                            (#\s      "&Save"         ,save)
+                            (#\a      "Save-&as"      ,save-as)
+                            (#\return "Pre&ferences"  ,set-options)
+                            (#\q      "&Quit"         ,maybe-save-and-exit)))
+
+(define popup-cell-menu
+  (let ([menu (instantiate popup-menu% ("GCalc"))]
+        [this #f]
+        [cell-items '()])
+    (define (make-item mi)
+      (cons
+       (instantiate menu-item%
+        [(string-append "[" (case (1st mi)
+                              [(#\space) "SPC"] [(#\return) "RET"]
+                              [else (string (1st mi))])
+                        "]  " (2nd mi))
+         menu
+         (lambda (i e)
+           (let ([f (3rd mi)])
+             ((if (symbol? f) (lambda () ((send this get-cell-op f) e)) f))))])
+       mi))
+    (set! cell-items (map make-item cell-menu-items))
+    (instantiate separator-menu-item% (menu))
+    (for-each make-item global-menu-items)
+    (lambda (cell e x y)
+      (set! this cell)
+      (let ([ok? (not (null-expr? (send this get-expr)))])
+        (for-each (lambda (mi)
+                    (send (1st mi) enable
+                          ((send cell get-cell-op (4th mi)) 'enabled? e)))
+                  cell-items))
+      (send cell popup-menu menu x y))))
+
+(define cells '())
+(define (find-cell x y)
+  (let/ec return
+    (for-each
+     (lambda (c)
+       (let-values ([(x y) (send c screen->client x y)])
+         (when (and (< -1 x (send c get-width)) (< -1 y (send c get-height)))
+           (return c))))
+     cells)
+    #f))
+
+(define current-cell #f)
+
+(define cell%
+  (class canvas%
+    (init-field name expr draggable? dropper alt-func size parent)
+    (inherit get-dc)
+    (define bitmap (instantiate bitmap% (size size)))
+    (define dc     (instantiate bitmap-dc% (bitmap)))
+    ;; general operations
+    (define evaluate-next #f)
+    (define/private (draw-contents)
+      (unhighlight!)
+      (set! expr (draw-expr dc expr name evaluate-next))
+      (set! evaluate-next #f)
+      (on-paint))
+    (define/public (get-expr) expr)
+    (define/public (set-expr! e) (set-contents! (cons #f e)))
+    (define/public (get-contents) (cons name expr))
+    (define/public (set-contents! n/e)
+      (cond [(eq? dropper 'copy)
+             (set! modified? #t)
+             (set! name (car n/e))
+             (set! expr (cdr n/e))
+             (draw-contents)]
+            [dropper (dropper n/e)]
+            [else #f]))
+    (define/public (eval-next-expr) (set! evaluate-next #t))
+    (define/public (get-dropper) dropper)
+    ;; highlighting
+    (define/private (frame-xor-bitmap)
+      (set-pen/brush dc XOR-PEN/BRUSH)
+      (send* dc
+        (draw-rectangle 1 1 size size)
+        (draw-rectangle CELL-BORDER CELL-BORDER
+                        (- size CELL-BORDER CELL-BORDER -1)
+                        (- size CELL-BORDER CELL-BORDER -1)))
+      (on-paint))
+    (define highlighted? #f)
+    (define/public (highlight!)
+      (unless highlighted? (frame-xor-bitmap) (set! highlighted? #t)))
+    (define/public (unhighlight!)
+      (when highlighted? (frame-xor-bitmap) (set! highlighted? #f)))
+    ;; cell operations
+    (define (make-cell-op: op . enabled?)
+      (let ([enabled?
+             (cond [(null? enabled?) (lambda (e) (not (null-expr? expr)))]
+                   [(not (procedure? (car enabled?)))
+                    (lambda (e) (and (car enabled?) (not (null-expr? expr))))]
+                   [else (car enabled?)])])
+        (lambda (e . more)
+          (let ([enabled? (enabled? (if (eq? e 'enabled?) (car more) e))])
+            (cond [(eq? e 'enabled?) enabled?] [enabled? (op e)])))))
+    (define cut:
+      (make-cell-op: (lambda (e) (copy: e) (clear: e)) (and dropper #t)))
+    (define copy:
+      (make-cell-op: (lambda (e)
+                       (send the-clipboard set-clipboard-string
+                             (write-to-string (get-contents))
+                             (send e get-time-stamp)))))
+    (define paste:
+      (make-cell-op: (lambda (e)
+                       (set-contents!
+                        (read-from-string
+                         (send the-clipboard get-clipboard-string
+                               (send e get-time-stamp)))))
+                     (lambda (e)
+                       (and dropper
+                            (valid-contents?
+                             (read-from-string
+                              (send the-clipboard get-clipboard-string
+                                    (send e get-time-stamp))))))))
+    (define clear:
+      (make-cell-op: (lambda (e) (set-contents! (cons #f null-expr)))
+                     (and dropper #t)))
+    (define show:
+      (make-cell-op: (lambda (e) (unhighlight!) (show-expr expr name))))
+    (define print:
+      (make-cell-op: (lambda (e) (unhighlight!) (print-expr expr name))))
+    (define eval:
+      (make-cell-op: (lambda (e) (eval-next-expr) (draw-contents))
+                     (and dropper #t)))
+    (define rename:
+      (make-cell-op: (lambda (e)
+                       (let ([new (get-text-from-user
+                                   "GCalc" "Enter a new name" gcalc-frame
+                                   (or name ""))])
+                         (when new
+                           (set! modified? #t)
+                           (set! name new)
+                           (draw-contents))))
+                     (and dropper #t)))
+    (define/public (get-cell-op msg)
+      (case msg
+        [(cut:) cut:] [(copy:) copy:] [(paste:) paste:] [(clear:) clear:]
+        [(show:) show:] [(print:) print:] [(eval:) eval:] [(rename:) rename:]))
+    ;; events
+    (define/override (on-paint)
+      (send (get-dc) draw-bitmap bitmap 0 0))
+    (define right-menu-thread #f)
+    (define dragging? #f)
+    (define drag-to   #f)
+    (define last-click-time #f)
+    (define/override (on-event e)
+      (when (and right-menu-thread (not (send e get-right-down)))
+        (kill-thread right-menu-thread)
+        (set! right-menu-thread #f))
+      (case (send e get-event-type)
+        [(enter)
+         (set! current-cell this)
+         (send this focus)
+         (when (and draggable? (not (null-expr? expr)))
+           (highlight!))]
+        [(leave)
+         (unless dragging? (set! current-cell #f) (unhighlight!))]
+        [(left-down)
+         (let ([d? (and last-click-time
+                        (< (- (current-milliseconds) last-click-time)
+                           DOUBLE-MILISECS))])
+           (set! last-click-time (if d? #f (current-milliseconds)))
+           (if d?
+             (show: e)
+             (begin (set! dragging? #t) (set! drag-to #f))))]
+        [(left-up)
+         (set! dragging? #f)
+         (when drag-to
+           (send drag-to set-contents! (get-contents))
+           (when (and (not (send e get-shift-down))
+                      (not (eq? drag-to main-cell))
+                      (eq? 'copy (send drag-to get-dropper)))
+             (clear: e)))]
+        [(right-down)
+         (if alt-func
+           (set! right-menu-thread
+                 (thread
+                  (lambda ()
+                    (sleep 0.3)
+                    (queue-callback
+                     (lambda ()
+                       (popup-cell-menu this e (send e get-x) (send e get-y))))
+                    (set! right-menu-thread #f))))
+           (popup-cell-menu this e (send e get-x) (send e get-y)))]
+        [(right-up)
+         (when right-menu-thread
+           (kill-thread right-menu-thread)
+           (set! right-menu-thread #f))
+         (when (and alt-func (not (null-expr? (send main-cell get-expr))))
+           (alt-func this))]
+        [(middle-down)
+         (show: e)]
+        [(motion)
+         (when dragging?
+           (let*-values ([(x y) (send this client->screen
+                                      (send e get-x) (send e get-y))]
+                         [(c) (find-cell x y)])
+             (when (and c (let ([cdrop (send c get-dropper)])
+                            (or (eq? c this) (not cdrop)
+                                (and (not (eq? cdrop 'copy))
+                                     (null-expr? (send main-cell get-expr))))))
+               (set! c #f))
+             (unless (eq? c drag-to)
+               (when drag-to (send drag-to unhighlight!))
+               (when c (send c highlight!))
+               (set! drag-to c))))]))
+    (define/override (on-char e)
+      (let ([ch (send e get-key-code)])
+        (when (eq? this current-cell)
+          (cond [(memq ch '(escape f10))
+                 (popup-cell-menu this e (send e get-x) (send e get-y))]
+                [(eq? ch 'f1) (help)]
+                [(assq ch cell-menu-items) =>
+                 (lambda (mi)
+                   ((send this get-cell-op (3rd mi)) e))]
+                [(assq ch global-menu-items) =>
+                 (lambda (mi) ((3rd mi)))]))))
+    ;; initialization
+    (set! cells (cons this cells))
+    (when (and (not name) (symbol? expr)) (set! name (symbol->string expr)))
+    (super-instantiate (parent))
+    (send* this (min-width size) (min-height size))
+    (send dc set-text-mode 'solid)
+    (send dc set-font CELL-FONT)
+    (draw-contents)))
+
+(define show-expr
+  (let* ([dlg (instantiate dialog% ("GCalc Expression" gcalc-frame)
+                                   (style '(no-caption)))]
+         [bmp (instantiate bitmap% (SHOW-CELL-SIZE SHOW-CELL-SIZE))]
+         [dc  (instantiate bitmap-dc% (bmp))]
+         [cnv (instantiate
+               (class canvas%
+                 (inherit get-dc)
+                 (define/override (on-event e)
+                   (when (send e button-down?) (send dlg show #f)))
+                 (define/override (on-char e)
+                   (unless (memq (send e get-key-code)
+                                 '(release #\nul control shift))
+                     (send dlg show #f)))
+                 (define/override (on-paint)
+                   (send (get-dc) draw-bitmap bmp 0 0))
+                 (super-instantiate (dlg))
+                 (send* this
+                   (min-width  SHOW-CELL-SIZE)
+                   (min-height SHOW-CELL-SIZE)))
+               ())]
+         [cdc (send cnv get-dc)])
+    (send dc set-text-mode 'solid)
+    (send dc set-font SHOW-FONT)
+    (lambda (expr name)
+      (draw-expr dc expr name)
+      (send dlg show #t))))
+
+(define (print-expr expr name)
+  (let ([dc (instantiate post-script-dc% ())])
+    (send dc start-doc "Printing...")
+    (send dc start-page)
+    (fluid-let ([BG-PEN/BRUSH (list (instantiate pen%   ("BLACK" 1 'solid))
+                                    (instantiate brush% ("WHITE" 'solid)))])
+      (if (or NOBMP-PRINT (< (expr-size expr) 5000))
+        (draw-expr dc expr name)
+        (let* ([size  (let-values ([(sx sy) (send dc get-size)])
+                        (inexact->exact (min sx sy)))]
+               [bmp   (instantiate bitmap% (size size))]
+               [bmpdc (instantiate bitmap-dc% (bmp))])
+          (message-box "Printing"
+                       "The expression, is too complex, using bitmap."
+                       gcalc-frame '(ok))
+          (draw-expr bmpdc expr name)
+          (send dc draw-bitmap bmp 0 0))))
+    (send dc end-page)
+    (send dc end-doc)))
+
+(define tiled-panel%
+  (class vertical-panel%
+    (init-field width size)
+    (define current-pane #f)
+    (define left 0)
+    (define/public (add-cell name expr draggable? dropper . alt-func)
+      (set! alt-func (and (not (null? alt-func)) (car alt-func)))
+      (when (zero? left)
+        (set! current-pane (instantiate horizontal-pane% (this)))
+        (set! left width))
+      (set! left (sub1 left))
+      (instantiate cell%
+        (name expr draggable? dropper alt-func size current-pane)))
+    (super-instantiate (main-pane) (style '(border)))))
+
+;; colors
+(define colors-panel
+  (instantiate tiled-panel% (COLOR-CELL-ROW COLOR-CELL-SIZE)))
+(for-each (lambda (x)
+            (send colors-panel add-cell #f (car x) #t #f
+                  (lambda (this)
+                    (send main-cell set-expr!
+                          (make-abstraction (send this get-expr)
+                                            (send main-cell get-expr))))))
+          COLORS)
+
+;; operators
+(define operator-panel
+  (instantiate tiled-panel% (OPERS-CELL-ROW OPERS-CELL-SIZE)))
+(define (make-dropper name maker op 1st?)
+  (send operator-panel add-cell (string-append "  " name "  ") #f #f
+        (lambda (n/e)
+          (when (and EVAL-NOW (eq? op 'apply)) (send main-cell eval-next-expr))
+          (send main-cell set-expr!
+                (maker (cdr n/e) (send main-cell get-expr))))
+        (lambda (this)
+          (send main-cell set-expr!
+                ((if 1st? expr-1st expr-2nd)
+                 (split-expr (send main-cell get-expr) op))))))
+(make-dropper "Back"         make-back-front   '/     #t)
+(make-dropper "Top"          make-top-bottom   '-     #f)
+(make-dropper "Apply (func)" make-application1 'apply #f)
+(make-dropper "Left"         make-left-right   '\|    #f)
+(define main-cell (send operator-panel add-cell "  Main  " #f #t 'copy))
+(make-dropper "Right"        make-right-left   '\|    #t)
+(make-dropper "Apply (arg)"  make-application2 'apply #t)
+(make-dropper "Bottom"       make-bottom-top   '-     #t)
+(make-dropper "Front"        make-front-back   '/     #f)
+(send main-cell focus)
+
+;; storage
+(define store-panel
+  (instantiate tiled-panel% (STORE-CELL-ROW STORE-CELL-SIZE)))
+(define storage-cells
+  (let loop ([n (* STORE-CELL-ROW STORE-CELL-COL)] [cells '()])
+    (if (zero? n)
+      (reverse! cells)
+      (loop (sub1 n)
+            (cons (send store-panel add-cell #f #f #t 'copy) cells)))))
+(define (get-storage-contents)
+  (map (lambda (c) (send c get-contents)) storage-cells))
+(define (set-storage-contents! names/exprs)
+  (for-each (lambda (c n/e) (send c set-contents! n/e))
+            storage-cells names/exprs))
+
+;; start the whole thing
+(send gcalc-frame show #t)
+
+)))
diff --git a/collects/games/gcalc/info.ss b/collects/games/gcalc/info.ss
new file mode 100644
index 0000000000..8243b045c0
--- /dev/null
+++ b/collects/games/gcalc/info.ss
@@ -0,0 +1,4 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "GCalc")
+  (define doc.txt "doc.txt")
+  (define game "gcalc.ss"))
diff --git a/collects/games/ginrummy/doc.txt b/collects/games/ginrummy/doc.txt
new file mode 100644
index 0000000000..7061657251
--- /dev/null
+++ b/collects/games/ginrummy/doc.txt
@@ -0,0 +1,18 @@
+** To play _Rummy_, run the "Games" application. **
+
+This is a simple variant of Rummy.
+
+Put all cards in your hand into straights (3 or more cards) and 3- or
+4-of-a-kind sets to win. Each card counts for only one set. Aces can
+be used in both A-2-3 sequences and Q-K-A sequences.
+
+When all of your cards fit into sets (the game detects this
+automatically), you win.
+
+On each turn, you can either draw from the deck or from the top of the
+discard pile (drag from either to your hand), then you must discard
+one of your own cards (by dragging from your hand to the discard
+pile).
+
+The status line at the bottom of the window provides instructions as
+you go. The computer player is fairly smart.
diff --git a/collects/games/ginrummy/ginrummy.png b/collects/games/ginrummy/ginrummy.png
new file mode 100644
index 0000000000..9839d47809
Binary files /dev/null and b/collects/games/ginrummy/ginrummy.png differ
diff --git a/collects/games/ginrummy/ginrummy.ss b/collects/games/ginrummy/ginrummy.ss
new file mode 100644
index 0000000000..b1ebf81184
--- /dev/null
+++ b/collects/games/ginrummy/ginrummy.ss
@@ -0,0 +1,515 @@
+
+(module ginrummy mzscheme
+  (require (lib "cards.ss" "games" "cards")
+	   (lib "mred.ss" "mred")
+	   (lib "class.ss")
+           (lib "unit.ss")
+	   (lib "list.ss"))
+  
+  (provide game-unit)
+  
+  (define game-unit
+    (unit
+      (import)
+      (export)
+      
+      ;; Initial card count
+      (define DEAL-COUNT 10)
+      
+      ;; Messages
+      (define YOUR-TURN-MESSAGE "Your turn.  (Draw a card or pickup a discard.)")
+      (define DISCARD-MESSAGE "Drag a card from your hand to discard.")
+      (define GAME-OVER-MESSAGE "GAME OVER")
+      
+      ;; Area labels
+      (define YOU-NAME "You")
+      (define MACHINE-NAME "Opponent")
+      
+      ;; Region layout constants
+      (define MARGIN 5)
+      (define LABEL-H 15)
+      
+      ;; Randomize
+      (random-seed (modulo (current-milliseconds) 10000))
+      
+      ;; Set up the table
+      (define t (make-table "Rummy" 8 4.5))
+      (define status-pane (send t create-status-pane))
+      (send t add-help-button status-pane '("games" "ginrummy") "Rummy Help" #f)
+      (send t show #t)
+      (send t set-double-click-action #f)
+      (send t set-button-action 'left 'drag-raise/one)
+      (send t set-button-action 'middle 'drag/one)
+      (send t set-button-action 'right 'drag/above)
+      
+      ;; Get table width & height
+      (define w (send t table-width))
+      (define h (send t table-height))
+      
+      ;; Set up the cards
+      (define deck (shuffle-list (make-deck) 7))
+      (for-each
+       (lambda (card)
+         (send card user-can-move #f)
+         (send card user-can-flip #f))
+       deck)
+      
+      ;; Function for dealing or drawing cards
+      (define (deal n)
+        (let loop ([n n][d deck])
+          (if (zero? n)
+              (begin
+                (set! deck d)
+                null)
+              (cons (car d) (loop (sub1 n) (cdr d))))))
+      
+      ;; Card width & height
+      (define cw (send (car deck) card-width))
+      (define ch (send (car deck) card-height))
+      
+      ;; Draw and discard pile locations
+      (define draw-x (/ (- w (* 3 cw)) 2))
+      (define draw-y (/ (- h ch) 2))
+      (define discard-x (+ draw-x (* 2 cw)))
+      (define discard-y draw-y)
+      
+      ;; Put the cards on the table
+      (send t add-cards deck draw-x draw-y)
+      
+      ;; Player region size
+      (define pw (- w (* 2 MARGIN)))
+      (define ph (- (* 1.75 ch) (* 4 MARGIN)))
+      
+      ;; Define the regions
+      (define machine-region
+        (make-region
+         MARGIN MARGIN pw ph
+         MACHINE-NAME
+         #f))
+      (define you-region
+        (make-region
+         MARGIN (- h ph MARGIN) pw ph
+         YOU-NAME
+         void))
+      (define discard-region
+        (make-region
+         (- discard-x MARGIN) (- discard-y MARGIN)
+         (+ cw (* 2 MARGIN)) (+ ch (* 2 MARGIN))
+         "" #f))
+      
+      ;; Install the visible regions
+      (send t add-region machine-region)
+      (send t add-region you-region)
+      (send t add-region discard-region)
+      
+      ;; Deal the initial hands
+      (define machine-hand (deal DEAL-COUNT))
+      (define you-hand (deal DEAL-COUNT))
+      
+      ;; Function to inset a region
+      (define (region->display-region r)
+        (define m MARGIN)
+        (make-region
+         (+ m (region-x r)) (+ m (region-y r))
+         (- (region-w r) (* 2 m)) (- (region-h r) (* 2 m))
+         #f #f))
+      
+      ;; Place cards nicely
+      (define machine-display-region (region->display-region machine-region))
+      (send t move-cards-to-region machine-hand machine-display-region)
+      (send t move-cards-to-region you-hand (region->display-region you-region))
+      
+      ;; All cards in your hand are movable, but must stay in your region
+      (for-each 
+       (lambda (card) 
+         (send card home-region you-region)
+         (send card user-can-move #t))
+       you-hand)
+      
+      ;; More card setup: Show your cards
+      (send t cards-face-up you-hand)
+      
+      ;; Start the discard pile
+      (define discards (deal 1))
+      (send t card-face-up (car discards))
+      (send t move-card (car discards) discard-x discard-y)
+      
+      ;; ;;;;;;;;;;;;; Finding Rummy and The Machine Player Strategy ;;;;;;;;
+      
+      ;; Check whether a group of (at least 3) cards forms a set (building
+      ;; up to gin).
+      (define (set? cards)
+        (let ([values (map (lambda (c) (send c get-value)) cards)]
+              [suits (map (lambda (c) (send c get-suit-id)) cards)])
+          ;; All same value? ... or
+          (or (apply = values)
+              ;; ... All same suit and a straight?
+              (and (apply = suits)
+                   (let ([sorted (quicksort values <)]
+                         [try (lambda (l)
+                                (let loop ([l l])
+                                  (or (null? (cdr l))
+                                      (and (= (car l) (sub1 (cadr l)))
+                                           (loop (cdr l))))))])
+                     ;; Try with Ace at end and at beginning
+                     (or (try sorted)
+                         (and (= 1 (car sorted))
+                              (try (append (cdr sorted) (list 14))))))))))
+      
+      ;; Check how close a hand comes to winning by returning the maximum
+      ;; number of cards that can be arranged into sets. This function is
+      ;; used both to detect gin for the end-of-game condition, and also
+      ;; as part of the machine player's strategy.
+      (define (gin-size cards)
+        (if (<= (length cards) 2)
+            0
+            (let* ([sort (lambda (get)
+                           (quicksort cards
+                                      (lambda (a b)
+                                        (< (get a) (get b)))))]
+                   
+                   ;; It's not reasonable to test every combination of 10 cards,
+                   ;; but we can cut down the search space a lot by starting
+                   ;; with two different sorts on the card list.
+                   
+                   ;; We sort by value, to find 3-of-a-kind sets, and by
+                   ;; suit-then-value, to find straights. Whatever the
+                   ;; best allocation of cards to sets, one of the sets
+                   ;; must show up as three cards together in one of the
+                   ;; sorted lists.  Also, if an extension to that set
+                   ;; leads to an optimal allocation, the extended set
+                   ;; corresponds to an extended section of the list.
+                   [value-sorted (sort (lambda (c) (send c get-value)))]
+                   [suit-sorted (sort (lambda (c) (+ (* 20 (send c get-suit-id)) (send c get-value))))]
+                   
+                   ;; Procedure to find a set allocation given one of the sorted
+                   ;; lists. It picks each group of three consecutive items
+                   ;; from the list and see how that choice works out.
+                   ;; (We're still performing a lot of redundant work here,
+                   ;; but it's fast enough.)
+                   [find-set
+                    (lambda (l)
+                      ;; 3loop tries each group of three items
+                      (let 3loop ([pre null] ; prefix we've tried already
+                                  [group (list (car l) (cadr l) (caddr l))] ; the group to try
+                                  [post (cdddr l)]) ; suffix we haven't tried yet
+                        (max (if (set? group)
+                                 ;; We have a start; try to extend or not, and
+                                 ;; make gin with the rest, then try the next 3-set
+                                 (max (let exloop ([set group][post post])
+                                        (cond
+                                          [(null? post) 
+                                           ;; No more items? Can't extend the set. Does the
+                                           ;; set we found work out in the long run?
+                                           (+ (length set)
+                                              (if (null? pre)
+                                                  0
+                                                  (gin-size pre)))]
+                                          ;; Try to extend the set...
+                                          [(set? (cons (car post) set))
+                                           ;; The set can be extended.
+                                           ;; Maybe this extension works in the long run...
+                                           (max (exloop (cons (car post) set) (cdr post))
+                                                ;; or maybe without extension works in the long run...
+                                                (+ (length set) (gin-size (append pre post))))]
+                                          ;; Can't extend the set, so try without extension
+                                          [else (+ (length set)
+                                                   (gin-size (append pre post)))])))
+                                 0)
+                             ;; Try next three, if possible
+                             (if (null? post)
+                                 0
+                                 ;; Rotate the group, pulling a new last item in from post 
+                                 ;; and kicking the first item out to pre.
+                                 (3loop (cons (car group) pre)
+                                        (list (cadr group) (caddr group) (car post))
+                                        (cdr post))))))])
+              ;; Try the value-sorted list, the the suit-sorted list, then...
+              (max (find-set value-sorted)
+                   (find-set suit-sorted)
+                   ;; the suit-sorted list with with Aces at the end instead of the beginning
+                   (let ace-loop ([pre null][l suit-sorted])
+                     (cond
+                       [(null? l)
+                        ;; No more aces to find
+                        (find-set (reverse pre))]
+                       [(null? (cdr l))
+                        ;; No more aces to find
+                        (find-set (reverse (cons (car l) pre)))]
+                       ;; Is the front card an ace (before something else of the same suit)?
+                       [(and (= 1 (send (car l) get-value))
+                             (= (send (car l) get-suit-id) (send (cadr l) get-suit-id)))
+                        ;; Ace is at beginning; move it to the end
+                        (let* ([ace (car l)]
+                               [ace-suit (send ace get-suit-id)])
+                          (let loop ([pre (cons (cadr l) pre)][l (cddr l)])
+                            ;; At end of this suit?
+                            (if (or (null? l) 
+                                    (> (send (car l) get-suit-id) ace-suit))
+                                ;; At the end; add Ace here
+                                (ace-loop (cons ace pre) l)
+                                ;; still looking for new spot for Ace
+                                (loop (cons (car l) pre) (cdr l)))))]
+                       [else
+                        ;; Didn't find an ace; keep looking
+                        (ace-loop (cons (car l) pre) (cdr l))]))))))
+      
+      ;; A hand wins if the biggest gin configuration includes all the cards
+      (define (gin? cards)
+        (= (gin-size cards) (length cards)))
+      
+      ;; This procedure is the second part of the machine's strategy. If
+      ;; the machine sees two choices that are equally good according to
+      ;; gin-size, then it computes a rating based on pairs, i.e., cards
+      ;; that might eventually go together in a set.
+      (define (pair-rating cards gone-cards)
+        (let ([suits (map (lambda (card) (send card get-suit-id)) cards)]
+              [values (map (lambda (card) (send card get-value)) cards)])
+          ;; Its O(n*n), but n is always 10 or 11
+          (apply +
+                 (map (lambda (suit value)
+                        (apply +
+                               (map (lambda (suit2 value2)
+				      (cond
+				       [(= value value2)
+					(- 2 (count-gone value gone-cards))]
+				       [(= suit suit2)
+					(rate-straight suit value value2 gone-cards)]
+				       [else 0]))
+                                    suits values)))
+                      suits values))))
+
+      ;; count-gone checks how many of a given value are known
+      ;;  to be permanently discarded
+      (define (count-gone value gone-cards)
+	(cond
+	 [(null? gone-cards) 0]
+	 [(= value (send (car gone-cards) get-value)) 
+	  (+ 1 (count-gone value (cdr gone-cards)))]
+	 [else (count-gone value (cdr gone-cards))]))
+
+      ;; count-avail checks whether a given value/suit is
+      ;;  known to be discarded (returns 0) or not (returns 1)
+      (define (count-avail value suit gone-cards)
+	(cond
+	 [(null? gone-cards) 1]
+	 [(and (= value (send (car gone-cards) get-value)) 
+	       (= suit (send (car gone-cards) get-suit-id))) 
+	  0]
+	 [else (count-avail value suit (cdr gone-cards))]))
+
+      ;; rates the possibility for forming a straight given
+      ;;  two card values in a particular suit, and taking
+      ;;  into account cards known to be discarded; the
+      ;;  rating is the number of non-discarded cards that 
+      ;;  would form a straight with the given values
+      (define (rate-straight suit value value2 gone-cards)
+	(let ([v1 (if (= value 1)
+		      (if (value2 . > . 6)
+			  14
+			  1)
+		      value)]
+	      [v2 (if (= value2 1)
+		      (if (value . > . 6)
+			  14
+			  1)
+		      value2)])
+	  (let ([delta (abs (- v1 v2))])
+	    (cond
+	     [(= delta 1)
+	      (cond
+	       [(or (= v1 1) (= v2 1))
+		;; Might get the 3?
+		(count-avail 3 suit gone-cards)]
+	       [(or (= v1 14) (= v2 14))
+		;; Might get the queen?
+		(count-avail 12 suit gone-cards)]
+	       [(or (= v1 13) (= v2 13))
+		;; Might get the jack or ace?
+		(+ (count-avail 11 suit gone-cards)
+		   (count-avail 1 suit gone-cards))]
+	       [else
+		;; Might get top or bottom?
+		(+ (count-avail (sub1 (min v1 v2)) suit gone-cards)
+		   (count-avail (add1 (max v1 v2)) suit gone-cards))])]
+	     [(= delta 2)
+	      ;; Might get the middle one?
+	      (let ([middle (quotient (+ v1 v2) 2)])
+		(count-avail middle suit gone-cards))]
+	     [else 0]))))
+      
+      ;; The procedure implements the machine's card-drawing choice
+      (define (machine-wants-card? machine-hand card gone-cards)
+        ;; Simple strategy: the machine wants the card if taking it will
+        ;; make the gin-size of its hand increase, or if taking it will not
+        ;; make the gin-size decrease but will increase the pair rating.
+        (let* ([orig-size (gin-size machine-hand)]
+               [new-hand (remq (machine-discard (cons card machine-hand) gone-cards) 
+                               (cons card machine-hand))]
+               [new-size (gin-size new-hand)])
+          (or (> new-size orig-size)
+              (and (= new-size orig-size)
+                   (> (pair-rating new-hand gone-cards) 
+		      (pair-rating machine-hand gone-cards))))))
+      
+      ;; The procedure implements the machine's discard choice
+      (define (machine-discard machine-hand gone-cards)
+        ;; Discard the card that leaves the hand with the largest
+        ;; gin-size.  If multiple cards leave the same largest gin size,
+        ;; pick card leaving the best pair rating.
+        (let* ([gin-size-card-pairs
+                (map (lambda (card) (cons (gin-size (remq card machine-hand))
+                                          card))
+                     machine-hand)]
+               [most (apply max (map car gin-size-card-pairs))]
+               [best (filter (lambda (x) (= most (car x))) gin-size-card-pairs)]
+               [best-cards (map cdr best)]
+               [rating-card-pairs
+                (map (lambda (card) (cons (pair-rating (remq card machine-hand) gone-cards)
+                                          card))
+                     best-cards)]
+               [most (apply max (map car rating-card-pairs))]
+               [best (filter (lambda (x) (= most (car x))) rating-card-pairs)])
+          (cdar best)))
+      
+      ;; ;;;;;; Game Loop  ;;;;;;;;
+      
+      ;; This procedure finalizes the display when the game is over
+      (define (end-of-game why)
+        (send t set-status-text 
+              (format "~aGame over. ~a."
+                      why
+                      (cond
+                        [(and (gin? you-hand) (gin? machine-hand)) "Tie"] ; only on deal
+                        [(gin? you-hand) "You win"]
+                        [else "Opponent wins"])))
+        (send t cards-face-up machine-hand))
+      
+      ;; Deck empty? Shuffle the discard pile (preserving the top discard)
+      (define (check-empty-deck)
+        (when (null? deck)
+          (set! deck (shuffle-list (cdr discards) 7))
+          (set! discards (list (car discards)))
+          (send t cards-face-down deck)
+          (send t stack-cards deck)
+          (send t move-cards deck draw-x draw-y)))
+      
+      ;; Check for starge start...
+      (if (or (gin? you-hand) (gin? machine-hand))
+          ;; Someone was delt gin - game over
+          (end-of-game "Dealt gin. ")
+          
+          ;; This is the main game loop
+          (let loop ()
+            (check-empty-deck)
+            
+            ;; Your turn; you can select the top card on the deck or on the discard pile
+            (send (car discards) user-can-move #t)
+            (send (car discards) snap-back-after-move #t)
+            (send (car deck) user-can-move #t)
+            (send (car deck) snap-back-after-move #t)
+            (send t set-status-text YOUR-TURN-MESSAGE)
+            (let ([something-happened (make-semaphore 0)])
+              ;; Set callback in your region to receive the deck/discard card
+              (set-region-callback! 
+               you-region
+               (lambda (cards)
+                 (let ([card (car cards)])
+                   ;; Adjust the deck, discard pile, and your hand
+                   (if (eq? card (car discards))
+                       (set! discards (cdr discards))
+                       (set! deck (cdr deck)))
+                   (set! you-hand (cons card you-hand))
+                   (send t card-face-up card))
+                 
+                 ;; Action done - clean up and move on
+                 (semaphore-post something-happened)
+                 (unless (null? deck) 
+                   (send (car deck) user-can-move #f)
+                   (send (car deck) home-region #f))
+                 (unless (null? discards) 
+                   (send (car discards) user-can-move #f)
+                   (send (car discards) home-region #f))
+                 (set-region-callback! you-region #f)
+                 (set-region-interactive-callback! you-region #f)))
+              ;; Interactive callback: change home of card if region is hilited.
+              ;; As a result, the card snaps to where you put it instead of back
+              ;; to its original position.
+              (set-region-interactive-callback!
+               you-region
+               (lambda (on? cards)
+                 (send (car cards) snap-back-after-move (not on?))
+                 (send (car cards) home-region (and on? you-region))))
+              ;; Wait for action (the action itself is handled by the callback
+              ;; for you-region)
+              (yield something-happened))
+            
+            ;; Time for you to discard something
+            (send t set-status-text DISCARD-MESSAGE)
+            (let ([something-happened (make-semaphore 0)])
+              ;; This time, the discard pile is the active region
+              (set-region-callback! 
+               discard-region
+               (lambda (cards)
+                 (let ([card (car cards)])
+                   ;; Adjust the discard pile and your hand
+                   (set! you-hand (remq card you-hand))
+                   (set! discards (cons card discards))
+                   (send t card-to-front card)
+                   (send t move-card card discard-x discard-y)
+                   
+                   ;; Discarded card is now relatively immobile
+                   (send card user-can-move #t)
+                   (send card home-region #f))
+                 
+                 ;; Action done - clean up and move on
+                 (semaphore-post something-happened)
+                 (set-region-callback! discard-region #f)
+                 (set-region-interactive-callback! discard-region #f)))
+              ;; Interactive callback: change home of card if region is hilited,
+              ;; so the card you drag snaps to the discard pile.
+              (set-region-interactive-callback!
+               discard-region
+               (lambda (on? cards)
+                 (send (car cards) home-region 
+                       (if on? discard-region you-region))))
+              ;; Wait for action
+              (yield something-happened))
+            
+            (if (gin? you-hand)
+                ;; Game over
+                (end-of-game "")
+                
+                ;; Keep going; machine's turn
+                (begin
+                  (check-empty-deck)
+                  ;; Machine picks a card
+                  (if (machine-wants-card? machine-hand (car discards) (cdr discards))
+                      (let ([card (car discards)])
+                        (set! discards (cdr discards))
+                        (send t card-face-down card)
+                        (send card user-can-move #f)
+                        (set! machine-hand (cons card machine-hand)))
+                      (let ([card (car deck)])
+                        (send t card-to-front card)
+                        (set! deck (cdr deck))
+                        (send card user-can-move #f)
+                        (set! machine-hand (cons card machine-hand))))
+                  (send t move-cards-to-region machine-hand machine-display-region)
+                  
+                  ;; Machine discards
+                  (let ([card (machine-discard machine-hand discards)])
+                    (send t card-face-up card)
+                    (send t card-to-front card)
+                    (send t move-card card discard-x discard-y)
+                    (set! discards (cons card discards))
+                    (set! machine-hand (remq card machine-hand))
+                    (send t move-cards-to-region machine-hand machine-display-region))
+                  
+                  (if (gin? machine-hand)
+                      ;; Game over
+                      (end-of-game "")
+                      
+                      ;; Next turn
+                      (loop)))))))))
+    
\ No newline at end of file
diff --git a/collects/games/ginrummy/info.ss b/collects/games/ginrummy/info.ss
new file mode 100644
index 0000000000..6a22762574
--- /dev/null
+++ b/collects/games/ginrummy/info.ss
@@ -0,0 +1,5 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Rummy")
+  (define doc.txt "doc.txt")
+  (define game "ginrummy.ss")
+  (define game-set "Card Games"))
diff --git a/collects/games/gl-board-game/doc.txt b/collects/games/gl-board-game/doc.txt
new file mode 100644
index 0000000000..3bb0940b2f
--- /dev/null
+++ b/collects/games/gl-board-game/doc.txt
@@ -0,0 +1,75 @@
+_gl-board.ss_
+
+The gl-board.ss library uses OpenGL, via the sgl library, to provide generic
+functionality for 3-dimensional views of board games.  It provides support for
+viewing and positioning the board as well as for moving pieces on the board.
+It does not handle rendering of the board and pieces themselves.  The arrow
+keys rotate the board, the = and - keys move the board closer and further, and
+the _ and + keys control the field of vision.  Games are played by left
+clicking the mouse on a piece and dragging it to a space.
+
+The checkers and goblet games both use the gl-board.ss library.
+
+The gl-board.ss module provides _gl-board%_, a subclass of canvas%, with the
+following public methods:
+
+> (add-space draw info): (->) X ->
+  Adds a space to the board.  The draw argument function should draw the space
+  using GL drawing commands.  The info argument is associated with the space.
+  Spaces should be drawn on the z = 0 plane.
+
+> (add-piece x y z draw info): real real real (->) X ->
+  Adds a piece to the board.  The draw argument function should draw the piece
+  using GL drawing commands.  The info argument is associated with the piece.
+  The x, y, and z arguments are the position at which the piece resides.
+
+> (get-spaces): -> (listof X)
+  Returns a list of the infos associated with the current spaces.
+
+> (get-pieces): -> (listof X)
+  Returns a list of the infos associated with the current pieces.
+
+> (set-space-draw info draw): X (->) ->
+  Sets to draw the drawing method of all spaces whose info is equal? to the
+  given info.
+
+> (set-piece-draw info draw): X (boolean ->) ->
+  Sets to draw the drawing method of all pieces whose info is equal? to the
+  given info.  The drawing method takes a boolean.  If the value it true, 
+  then the piece should be drawn for creating its shadow.  Otherwise is should
+  be drawn normally.
+
+> (enable-piece info on?): X boolean ->
+  Enables or disables a piece whose info is equal? to the given info.
+  Disabled pieces are not selectable.
+
+> (enabled? info): X -> boolean
+  If a piece whose info is equal? to the given info is enabled or not.
+
+> (remove-piece info): X ->
+  Removes all pieces whose info is equal? to the given info.
+
+
+A gl-board object is constructed as follows:
+(new gl-board% (min-x real) (max-x real)
+               (min-y real) (max-y real)
+               (lift real)
+               (move (X gl-double-vector ->))
+	       ;; Optional:
+	       (theta real) (phi real))
+
+The min-x, max-x, min-y, and max-y parameters all specify the dimensions of
+the board.  They are used to setup viewing parameters.  The board is viewed
+centered around the center of the coordinates, and the view attempts to fill
+the window to them. The optional theta and phi arguments determine the intitial
+rotation of the board, with respective defaults 45 and 0; theta corresponds to
+the up and down keys, and phi corresponds to the left and right keys.
+
+The lift parameter specifies how high off the board mouse-dragged pieces are.
+
+The gl-board% class invokes the move callback when a piece is selected
+(left-click) and then unselected.  It is given the info associated with the
+selected piece, and the coordinates the user has dragged it to.  If the piece
+should be moved permanently, the move function must update the board state
+with remove-piece and add-piece.
+
diff --git a/collects/games/gl-board-game/gl-board.ss b/collects/games/gl-board-game/gl-board.ss
new file mode 100644
index 0000000000..38258a8f49
--- /dev/null
+++ b/collects/games/gl-board-game/gl-board.ss
@@ -0,0 +1,390 @@
+(module gl-board mzscheme
+  (require (prefix gl- (lib "sgl.ss" "sgl"))
+           (lib "gl.ss" "sgl")
+           (lib "gl-vectors.ss" "sgl")
+           (lib "class.ss")
+           (lib "list.ss")
+           (lib "mred.ss" "mred"))
+  
+  (provide gl-board%)
+
+  (define-struct space (draw info))
+  (define-struct piece (x y z draw info enabled?))
+  
+  (define (get-info x)
+    (cond
+      ((piece? x) (piece-info x))
+      ((space? x) (space-info x))
+      (else #f)))
+  
+  ;; interpolate : real gl-double-vector gl-double-vector -> gl-double-vector
+  ;; returns the point on the p1-p2 line with the given z coordinate.
+  (define (interpolate z p1 p2)
+    (let* ((v (gl-double-vector- p2 p1))
+           (c (/ (- z (gl-vector-ref p1 2))
+                 (gl-vector-ref v 2))))
+      (gl-double-vector+ p1 (gl-double-vector* c v))))
+  
+  (define (get-viewport)
+    (glGetIntegerv GL_VIEWPORT 4))
+
+  (define (get-projection)
+    (glGetDoublev GL_PROJECTION_MATRIX 16))
+    
+  (define (get-modelview)
+    (glGetDoublev GL_MODELVIEW_MATRIX 16))
+
+  (define gl-board%
+    (class canvas%
+      (inherit with-gl-context swap-gl-buffers refresh get-width get-height get-dc focus)
+      
+      ;; min-x, max-x, min-y, max-y, lift: real
+      ;; move: info gl-double-vector ->
+      ;; min-x, max-x, min-y and max-y specify the dimensions of the board.
+      ;; lift specifies how far a piece is picked up when being moved.
+      ;; move is called when a piece is moved to a space (possibly it's current space),
+      ;; when a space is clicked on, and when a space is dragged to another space.
+      ;; move is given the info of the piece or space selected, and coordinates
+      ;; it is moved to.
+      (init-field min-x max-x min-y max-y lift (move void) (who "this game"))
+      
+      (define spaces null)
+      (define pieces null)
+      
+      (define/public (get-pieces) (map piece-info pieces))
+      (define/public (get-spaces) (map space-info spaces))
+
+      ;; add-space: (->) info ->
+      ;; Adds a space to this board.  The draw thunk should draw the space 
+      ;; when called.  The value of the info argument will be given to
+      ;; the move function when the space is selected.
+      (define/public (add-space draw info)
+        (set! spaces (cons (make-space draw info) spaces)))
+      
+      ;; add-piece: real real real (->) info ->
+      ;; Adds a piece to this board.  The draw thunk should draw the piece
+      ;; when called.  The value of the info argument will be given to
+      ;; the move function when the piece is selected.  The piece is translated
+      ;; by the x, y and z arguments before drawing.
+      (define/public (add-piece x y z draw info)
+        (set! pieces (cons (make-piece x y z draw info #t) pieces)))
+
+      ;; set-space-draw: info (->) ->
+      ;; Sets the drawing method of all spaces whose info is equal to space to d.
+      (define/public (set-space-draw space d)
+        (for-each
+         (lambda (s)
+           (when (equal? (space-info s) space)
+             (set-space-draw! s d)))
+         spaces))
+      
+      ;; set-piece-draw: info (boolean ->) ->
+      ;; Sets the drawing method of all pieces whose info is equal to piece to d.
+      (define/public (set-piece-draw piece d)
+        (for-each
+         (lambda (p)
+           (when (equal? (piece-info p) piece)
+             (set-piece-draw! p d)))
+         pieces))
+      
+      ;; enabled/disables dragging of a piece
+      (define/public (enable-piece info on?)
+	(let ([p (ormap (lambda (p)
+			  (and (equal? info (piece-info p)) p))
+			pieces)])
+	  (if p
+	      (set-piece-enabled?! p (and on? #t))
+	      (raise-mismatch-error "no matching piece: " info))))
+      
+      ;; enabled?: info -> boolean
+      (define/public (enabled? info)
+        (let ((p (ormap (lambda (p)
+                          (and (equal? info (piece-info p)) p))
+                        pieces)))
+          (if p
+              (piece-enabled? p)
+              (raise-mismatch-error "no matching piece: " info))))
+      
+      ;; remove-piece: info ->
+      ;; Removes all pieces whose info is equal? to p-i from this board.
+      (define/public (remove-piece p-i)
+        (set! pieces (filter
+                      (lambda (x)
+                        (not (equal? p-i (piece-info x))))
+                      pieces)))
+      
+      ;; How far the light is from the board's center
+      (define light-distance (* 4.0 (max (- max-x min-x) (- max-y min-y))))
+      ;; The board's center
+      (define center-x (/ (+ max-x min-x) 2))
+      (define center-y (/ (+ max-y min-y) 2))
+
+      (define eye-distance (* 2.0 (max (- max-x min-x) (- max-y min-y))))
+      (define delta-eye-distance (/ eye-distance 30.0))
+      (define fov 30)
+      (init-field [theta 45])
+      (init-field [phi 0])
+      
+      ;; Transformation used to draw shadows.
+      (define shadow-projection 
+        (let ((ld light-distance))
+          (gl-double-vector ld 0 0 0
+                            0 ld 0 0 
+                            0 0 ld (- 1)
+                            0 0 0 0)))
+      
+      ;; Either #f or the currently selected piece.
+      (define mouse-state #f)
+      
+      ;; dragging-correction : (union #f 3-element-gl-double-vector)
+      (define dragging-correction #f)
+      
+      ;; dragging : (union #f 3-element-gl-double-vector)
+      ;; The mouse's location while dragging
+      (define dragging #f)
+            
+      ;; draw-spaces : bool ->
+      ;; Draws the board.  If select? is true, then names are loaded for selection
+      ;; with each space named after its index in the spaces list.
+      (define/private (draw-spaces select?)
+        (gl-normal 0.0 0.0 1.0)
+        (let loop ((i 0)
+                   (s spaces))
+          (unless (null? s)
+            (when select?
+              (gl-load-name i))
+            ((space-draw (car s)))
+            (loop (add1 i)
+                  (cdr s)))))
+      
+      ;; draw-pieces : bool ->
+      ;; Draws the pieces.  If select? is true, then names are loaded for selection
+      ;; with each piece named after its index plus the number of spaces.
+      (define/private (draw-pieces select? shadow?)
+        (let loop ((i (length spaces))
+                   (ps (if (and (piece? mouse-state) 
+                                dragging)
+                           (cons (make-piece (gl-vector-ref dragging 0)
+                                             (gl-vector-ref dragging 1)
+                                             (gl-vector-ref dragging 2)
+                                             (piece-draw mouse-state)
+                                             (piece-info mouse-state)
+                                             #f)
+                                 pieces)
+                           pieces)))
+          (unless (null? ps)
+            (let ((p (car ps)))
+              (unless (and dragging (eq? mouse-state p))  ;; Don't draw the dragged piece
+                ;; in its home location.
+                (when select?
+                  (gl-load-name i))
+                (gl-push-matrix)
+                (gl-translate (piece-x p) (piece-y p) (piece-z p))
+                ((piece-draw p) shadow?)
+                (gl-pop-matrix))
+              (loop (add1 i)
+                    (cdr ps))))))
+      
+      (define/override (on-paint)
+        (with-gl-context
+         (lambda ()
+           (gl-clear 'color-buffer-bit 'depth-buffer-bit 'stencil-buffer-bit)
+
+           (draw-spaces #f)
+
+           ;; draw the board, putting 1 in the stencil buffer for each exposed
+           ;; pixel of a piece.
+           (gl-enable 'stencil-test)
+           (gl-stencil-func 'always 1 1)
+           (gl-stencil-op 'keep 'keep 'replace)
+           (draw-pieces #f #f)
+           (gl-disable 'stencil-test)
+           
+           ;; Very simple shadowing on the board, only blending the shadow
+           ;; with pixels stenciled to 0, i.e. avoid the pieces.
+	   (gl-enable 'stencil-test)
+	   (gl-stencil-func 'equal 0 1)
+           ;; Once a pixel has been shadows, use saturating incr to set its
+           ;; value to 1, preventing multi-shadowing.
+	   (gl-stencil-op 'keep 'keep 'incr)
+           (gl-disable 'depth-test)
+	   (gl-enable 'blend)
+	   (gl-blend-func 'dst-color 'zero)
+           (gl-color 0.5 0.5 0.5)
+           (gl-push-matrix)
+           (gl-translate center-x center-y light-distance)
+           (gl-mult-matrix shadow-projection)
+           (gl-translate (- center-x) (- center-y) (- light-distance))
+           (draw-pieces #f #t)
+           (gl-enable 'depth-test)
+	   (gl-disable 'blend)
+	   (gl-disable 'stencil-test)
+           (gl-pop-matrix)
+           (gl-flush)
+           (swap-gl-buffers))))
+      
+      (define/override (on-size w h)
+        (with-gl-context
+         (lambda ()
+           (gl-viewport 0 0 w h)
+           (setup-view/proj)))
+        (refresh))
+      
+      (define/private (setup-view/proj)
+        (gl-matrix-mode 'projection)
+        (gl-load-identity)
+        (gl-perspective fov (/ (get-width) (get-height))
+                        (/ eye-distance 2) (* 2 eye-distance))
+        (gl-matrix-mode 'modelview)
+        (gl-load-identity)
+        (gl-translate 0 0 (- eye-distance))
+        (gl-rotate (- theta) 1 0 0)
+        (gl-rotate phi 0 0 1)
+        (gl-translate (- center-x) (- center-y) 0))
+      
+      ;; pick: real real -> (union piece space #f)
+      ;; Returns the piece or space at screen coordinates x y and #f is there
+      ;; is no such object.
+      (define/private (pick x y)
+        (let ((vp (get-viewport))
+              (proj (get-projection))
+              (selection (glSelectBuffer 512)))
+          (gl-render-mode 'select)
+          (gl-matrix-mode 'projection)
+          (gl-push-matrix)
+          (gl-load-identity)
+          (gl-pick-matrix x (- (gl-vector-ref vp 3) y 1) 1.0 1.0 vp)
+          (gl-mult-matrix proj)
+          (gl-matrix-mode 'modelview)
+          (gl-init-names)
+          (gl-push-name 0)
+          (draw-spaces #t)
+          (draw-pieces #t #f)
+          (gl-matrix-mode 'projection)
+          (gl-pop-matrix)
+          (gl-matrix-mode 'modelview)
+          (gl-flush)
+          (let* ((hits (gl-render-mode 'render))
+                 (results (mergesort (gl-process-selection (select-buffer->gl-uint-vector selection)
+                                                           hits)
+                                     (lambda (a b)
+                                       (< (gl-selection-record-min-z a)
+                                          (gl-selection-record-min-z b))))))
+            (cond
+              ((null? results) #f)
+              (else
+               (let ((index (car (gl-selection-record-stack (car results)))))
+                 (cond
+                   ((< index (length spaces))
+                    (list-ref spaces index))
+                   (else
+                    (list-ref pieces (- index (length spaces)))))))))))
+         
+               
+      ;; screen-world: real real real -> gl-double-vector
+      ;; Given a screen x and y, return the world x, y, z 
+      ;; corresponding to the given world z.
+      (define/private (screen->world x y z)
+        (let* ((v (get-viewport))
+               (m (get-modelview))
+               (p (get-projection))
+               (real-y (- (gl-vector-ref v 3) y 1)))
+          (interpolate z
+                       (gl-un-project x real-y 0.0 m p v)
+                       (gl-un-project x real-y 1.0 m p v))))
+              
+      (define/private (drag x y)
+        (with-gl-context
+         (lambda ()
+           (set! dragging
+                 (gl-double-vector- (screen->world x y lift)
+                                    dragging-correction))))
+        (refresh))
+
+      (define/private (start-dragging x y)
+        (with-gl-context
+         (lambda ()
+           (let ((v (pick x y)))
+             (when (and (piece? v) (piece-enabled? v))
+               (set! mouse-state v)
+               (set! dragging-correction
+                     (gl-double-vector-
+                      (screen->world x y lift)
+                      (gl-double-vector (piece-x v) (piece-y v) lift)))
+               (drag x y))))))
+      
+      (define/private (stop-dragging x y)
+        (move (get-info mouse-state) dragging)
+        (set! mouse-state #f)
+        (set! dragging-correction #f)
+        (set! dragging #f)
+        (refresh))
+      
+      (define/override (on-event e)
+        (cond
+          ((send e button-down? 'left)
+           (start-dragging (send e get-x) (send e get-y)))
+          ((and mouse-state
+                (or (send e button-up? 'left)
+                    (and (send e moving?)
+                         (not (and (send e dragging?) (send e get-left-down))))))
+           (stop-dragging (send e get-x) (send e get-y)))
+          ((and (send e dragging?) (send e get-left-down))
+           (unless dragging
+             (start-dragging (send e get-x) (send e get-y)))
+           (when dragging
+             (drag (send e get-x) (send e get-y))))))
+      
+      (define/override (on-char e)
+        (case (send e get-key-code)
+          ((left) (set! phi (+ phi 3)))
+          ((right) (set! phi (- phi 3)))
+          ((up) (set! theta (- theta 3)))
+          ((down) (set! theta (+ theta 3)))
+          ((#\+) (unless (< fov 4)
+		   (set! fov (- fov 2))))
+          ((#\=) (set! eye-distance (- eye-distance delta-eye-distance)))
+          ((#\_) (unless (> fov 176)
+		   (set! fov (+ fov 2))))
+	  ((#\-) (set! eye-distance (+ eye-distance delta-eye-distance))))
+        (with-gl-context
+         (lambda ()
+           (setup-view/proj)))
+        (refresh))
+      
+      (let ([cfg (new gl-config%)])
+	(send cfg set-multisample-size 4)
+	(send cfg set-stencil-size 1)
+	(super-new (style '(no-autoclear)) (gl-config cfg)))
+      
+      (unless (send (get-dc) get-gl-context)
+	(message-box "Error"
+		     (format (string-append
+			      "~a requires OpenGL, but there was an error initializing"
+			      " the OpenGL context. Probably OpenGL is not supported by" 
+			      " the current display, or it was disabled when PLT Scheme was"
+			      " configured and compiled.")
+			     who)
+		     #f
+		     '(ok stop))
+	(exit))
+
+      ;; initial setup
+      (with-gl-context
+       (lambda ()
+         (gl-shade-model 'smooth)
+         (when (>= (gl-get-gl-version-number) 13)
+           (gl-enable 'multisample))
+         (gl-enable 'lighting)
+         (gl-enable 'light0)
+         (gl-enable 'depth-test)
+         ;(gl-light-model 'light-model-local-viewer 1.0)
+         ;(gl-light-model-v 'light-model-ambient (gl-float-vector 0.0 0.0 0.0 0.0))
+         (gl-light-v 'light0 'position (gl-float-vector center-x center-y light-distance 1.0))
+         ;(gl-light-v 'light0 'ambient (gl-float-vector 0.7 0.7 0.7 1.0))
+         ;(gl-light-v 'light0 'diffuse (gl-float-vector 0.9 0.9 0.9 1.0))
+         ;(gl-light-v 'light0 'specular (gl-float-vector 0.0 0.0 0.0 1.0))
+         (gl-clear-color 1.0 1.0 1.0 1.0)
+         (setup-view/proj)))
+      (focus)))
+  )
diff --git a/collects/games/gl-board-game/info.ss b/collects/games/gl-board-game/info.ss
new file mode 100644
index 0000000000..3fbbf1a681
--- /dev/null
+++ b/collects/games/gl-board-game/info.ss
@@ -0,0 +1,3 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "3D board game library")
+  (define doc.txt "doc.txt"))
diff --git a/collects/games/gobblet/check.ss b/collects/games/gobblet/check.ss
new file mode 100644
index 0000000000..7629c88941
--- /dev/null
+++ b/collects/games/gobblet/check.ss
@@ -0,0 +1,117 @@
+
+;; Checks that all paths in a tree of games leads to the expected
+;; winner. It also generates information for known plays to be used to
+;; speed up future games (i.e., converts learned strategy to a compact
+;; form).
+
+(module check mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "etc.ss")
+	   (lib "list.ss")
+	   "sig.ss"
+	   "model.ss"
+	   "explore.ss"
+	   "heuristics.ss")
+
+  (define board-size 3)
+  (define cannon-size +inf.0)
+
+  (invoke-unit/sig
+   (compound-unit/sig
+    (import)
+    (link
+     [CONFIG : config^ ((unit/sig config^
+			  (import)
+			  (define BOARD-SIZE board-size)))]
+     [MODEL : model^ (model-unit CONFIG)]
+     [HEURISTICS : heuristics^ (heuristics-unit CONFIG MODEL EXPLORE)]
+     [EXPLORE : explore^ (explore-unit CONFIG MODEL)]
+     [ROBOT : () ((unit/sig ()
+		    (import config^ explore^ model^ heuristics^)
+		    
+		    (define (mk-search)
+		      (make-search make-3x3-rate-board make-3x3-canned-moves))
+		    
+		    (define FLUSH-CACHE-COUNT 10)
+
+		    (let ([search (mk-search)]
+			  [cnt 0]
+			  [move-map (make-hash-table 'equal)]
+			  [canonicalize (make-canonicalize)])
+		      (let loop ([board empty-board]
+				 [depth 0]
+				 [history null])
+			(set! cnt (+ cnt 1))
+			(when (= cnt FLUSH-CACHE-COUNT)
+			  ;; Keep the canonlicalization information in `search'
+			  ;; from getting too big.
+			  (set! cnt 0)
+			  (set! search (mk-search)))
+			(printf "------------~n~a~n" (board->string depth board))
+			(cond
+			 [(winner? board 'red) 0]
+			 [(winner? board 'yellow)
+			  (error '! "yellow wins")]
+			 [else
+			  (let ([key+xform (canonicalize board 'red)])
+			    (list-ref
+			     (hash-table-get 
+			      move-map (car key+xform)
+			      (lambda ()
+				(let ([play (search 300.0 1 2 'red board history)])
+				  (let ([new-board (apply-play board play)])
+				    (let ([max-depth
+					   (if (winner? new-board 'red)
+					       0
+					       (max
+						(let ([pss (available-off-board new-board 'yellow)])
+						  (apply
+						   max
+						   (map
+						    (lambda (ps)
+						      (fold-board
+						       (lambda (i j v)
+							 (move new-board (list-ref yellow-pieces (car ps))
+							       #f #f i j
+							       (lambda (newer-board)
+								 (max v
+								      (loop newer-board
+									    (add1 depth)
+									    (list* new-board board history))))
+							       (lambda () v)))
+						       0))
+						    pss)))
+						(fold-board
+						 (lambda (from-i from-j v)
+						   (let ([ps (board-ref new-board from-i from-j)])
+						     (if (and (pair? ps)
+							      (eq? 'yellow (piece-color (car ps))))
+							 (fold-board
+							  (lambda (to-i to-j v)
+							    (move new-board (car ps)
+								  from-i from-j to-i to-j
+								  (lambda (newer-board)
+								    (max v
+									 (loop newer-board
+									       (add1 depth)
+									       (list* new-board board history))))
+								  (lambda () v)))
+							  v)
+							 v)))
+						 0)))])
+				      (let ([l (list (piece-size (car play))
+						     (and (list-ref play 1)
+							  (apply-xform (cdr key+xform)
+								       (list-ref play 1) (list-ref play 2)))
+						     (apply-xform (cdr key+xform)
+								  (list-ref play 3) (list-ref play 4))
+						     (add1 max-depth))])
+					(hash-table-put! move-map (car key+xform) l)
+					l))))))
+			     3))]))
+		      (hash-table-for-each move-map
+					   (lambda (k v)
+					     (when (> (list-ref v 3) 1)
+					       (printf "~s~n" (cons k v)))))))
+		  CONFIG EXPLORE MODEL HEURISTICS)])
+    (export))))
diff --git a/collects/games/gobblet/doc.txt b/collects/games/gobblet/doc.txt
new file mode 100644
index 0000000000..6ab28b757e
--- /dev/null
+++ b/collects/games/gobblet/doc.txt
@@ -0,0 +1,111 @@
+** To play _Goblet_, run the "Games" application. **
+
+"Gobblet!" is a board game from Blue Orange Games:
+       http://www.blueorangegames.com/
+
+Our 3x3 version actually corresponds to "Gobblet! Jr.", while the 4x4
+version matches "Gobblet!".
+
+The Blue Orange web site provides rules for Gobblet! Jr. and
+Gobblet!. The rules below are in our own words; see also the Blue
+Orange version.
+
+Game Rules
+----------
+
+The 3x3 game is a generalization of tic-tac-toe:
+
+ * The object of the game is to get three in a row of your color,
+   vetically, horizontally, or diagonally. Size doesn't matter for
+   determining a winner.
+
+ * Each player (red or yellow) starts with 6 pieces: two large, two
+   medium, and two small.
+
+ * On each turn, a player can either place a new piece on the board,
+   or move a piece already on the board --- from anywhere to anywhere,
+   as long as the "from" and "to" are different.
+
+ * A piece can be placed (or moved to) an empty space, or it can be
+   placed/moved on top of a smaller piece already on the board,
+   "gobbling" the smaller piece. The smaller piece does not have to be
+   an opponent's piece, and the smaller piece may itself have gobbled
+   another piece previouly.
+
+ * Only visible pieces can be moved, and only visible pieces count
+   toward winning. Gobbled pieces stay on the board, however, and when
+   a piece is moved, any piece that it gobbled stays put and becomes
+   visible.
+
+ * If moving a piece exposes a winning sequence for the opponent, and
+   if the destination for the move does not cover up one of the other
+   pieces in the sequence, then the opponent wins --- even if the move
+   makes a winning sequence for the moving player.
+
+ * Technically, if a player touches a piece, then the piece must be
+   moved on that turn. In other words, you're not allowed to peek
+   under a piece to remind yourself whether it gobbled anything. If
+   the piece can't be moved, the player forfeits. This particular rule
+   is not enforced by our version --- in part because our version
+   supports a rewind button, which is also not in the official game.
+
+The 4x4 game has a few changes:
+
+ * The object of the game is to get four in a row of your color.
+
+ * Each player (red or yellow) starts with 12 pieces: three large,
+   three medium-large, three medium-small, and three small.
+
+ * Each player's pieces are initially arranged into three stacks off
+   the board, and only visible pieces can be moved onto the board.
+   The initial stacks prevent playing a smaller piece before a
+   corresponding larger piece.
+
+ * When a piece is moved from off-board onto the board, it must be
+   moved to either (1) an empty space, or (2) a space to gobble an
+   opponent's piece that is part of three in a row (for the opponent).
+   In other words, a new piece can gobble only an opponent's piece,
+   and only to prevent an immediate win on the opponent's next turn.
+   These restrictions do not apply when a piece that is already on the
+   board is moved.
+
+Controls
+--------
+
+Click and drag pieces in the obvious way to take a turn. The shadow
+under a piece shows where it will land when you drop it.
+
+Use the arrow keys on your keyboard to rotate the board. Use the "-"
+and "=" keys to zoom in and out. Use "_" and "+" to make the game
+smaller and larger. (Changing the size adjusts perspective in a
+slightly different way than zooming.) Depending on how keyboard focus
+works on your machine, you may have to click the board area to make
+these controls work.
+
+The button labelled "<" at the bottom of the window rewinds the game
+by one turn. The button labelled ">" re-plays one turn in a rewound
+game. An alternate move can be made at any point in a rewound game,
+replacing the old game from that point on.
+
+Auto-Play
+---------
+
+Turn on a computer player at any time by checking the "Auto-Play Red"
+or "Auto-Play Yellow" checkbox. If you rewind the game, you can choose
+an alternate move for yourself or for the auto-player to find out what
+would have happened. The auto-player is not always deterministic, so
+replying the same move might lead to a different result. You can
+disable an auto-player at any point by unchecking the corresponding
+"Auto-Play" checkbox.
+
+Important: In the 3x3 game, you CANNOT win as yellow against the smart
+auto-player (if the auto-player is allowed to play red from the start
+of the game). In other words, red has a forced win in the 3x3 game,
+and the smart auto-player knows the path to victory. You might have a
+chance to beat the red player in the default mode, though, which is
+represented by the "Ok" choice (instead of "Smart") in the "Auto-Play
+Options" dialog.
+
+Configure the auto-player by clicking the "Auto-Play Options" button.
+Currently, there's no difference between "Smart" and "Ok" in the 4x4
+game.
diff --git a/collects/games/gobblet/explore.ss b/collects/games/gobblet/explore.ss
new file mode 100644
index 0000000000..d0d8cf2722
--- /dev/null
+++ b/collects/games/gobblet/explore.ss
@@ -0,0 +1,631 @@
+
+;; This is the main search engine for auto-play.
+;; See `make-search' for the main entry point.
+
+(module explore mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "etc.ss")
+	   (lib "list.ss")
+	   "sig.ss"
+	   "test.ss")
+
+  (provide explore-unit)
+
+  ;; Debugging:
+  (define-syntax (log-printf stx)
+    (syntax-case stx ()
+      [(_ n i arg ...)
+       (<= (syntax-e #'n) 0) ; adjust this number for print levels
+       #'(begin
+	   (when (i  . < . 100)
+	     (printf arg ...))
+	   (void))]
+      [(_ n i arg ...)
+       #'(void)]))
+
+  (define explore-unit
+    (unit/sig explore^
+      (import config^ model^)
+
+      (define-struct config (max-depth memory canonicalize rate-board canned-moves))
+      
+      ;; make-search : (canonicalize-proc -> (board sym num num -> num))
+      ;;               (canonicalize-proc hash-table -> (board sym compact xform -> plan)) 
+      ;;               -> search-proc
+      ;;  where canonicalize-proc = (board sym -> (cons compact xform))
+      ;;  and search-proc is below.
+      ;; Returns a search procedure that embeds a canonicalization table and 
+      ;; a memory of canned moves from the `make-canned-moves' procedure.
+      ;; The `make-canned-moves' proc can add to the given hash table, mapping
+      ;;  canonical compact boards to (listof (cons num plan)), where the
+      ;;  num for a plan is a rating for how good the plan is; +inf.0 means
+      ;;  forced win, and -inf.0 means forced loss. A plan is created
+      ;;  with `make-plan', described below.
+      (define (make-search make-rate-board make-canned-moves)
+	;; Long-term memory (i.e., spans searches)
+	(define init-memory (make-hash-table 'equal))
+	(define canonicalize (make-canonicalize))
+	(define rate-board (make-rate-board canonicalize))
+	(define canned-moves (make-canned-moves canonicalize init-memory))
+	(when learn?
+	  (load-memory init-memory canonicalize))
+	;; search-proc : num num num sym board (listof board) -> play
+	;;  Finds a move given search parameters, whose turn it is,
+	;;  the current board, and a list of past boards (not
+	;;  including the current one, used to avoid cycles in the game).
+	;; The result is a play, which can be applied to a board with
+	;;  `apply-play'.
+	(lambda (timeout max-steps one-step-depth
+			 me board history)
+	  (let* ([result #f]
+		 [once-sema (make-semaphore)]
+		 [result-sema (make-semaphore)]
+		 ;; Short-term memory (i.e., discarded after this search)
+		 [memory (make-hash-table 'equal)])
+	    ;; Record game-history boards as loop ties
+	    (let loop ([history history][me (other me)])
+	      (unless (null? history)
+		(let ([key+xform (canonicalize (car history) me)])
+		  (hash-table-put! memory (car key+xform) LOOP-TIE))
+		(loop (cdr history) (other me))))
+	    ;; Copy canned and learned info into short-term memory:
+	    (hash-table-for-each init-memory (lambda (k v) (hash-table-put! memory k v)))
+	    ;; Search in a background thread:
+	    (let ([t (thread
+		      (lambda ()
+			;; Try just one chunk of lookaheads, then loop
+			;; for more ambitious searches (if there's time)
+			(let loop ([steps (if (= timeout +inf.0)
+					      max-steps
+					      1)]
+				   [max-depth (if (= timeout +inf.0)
+						  one-step-depth
+						  2)])
+			  (set! result
+				;; ======== Here's where we get a move ============
+				(let ([v (multi-step-minmax
+					  steps
+					  3 ; span
+					  (make-config 
+					   (min max-depth one-step-depth)
+					   memory canonicalize rate-board canned-moves)
+					  0 ; indent 
+					  init-memory
+					  me board)])
+				  (log-printf 1 0 "> ~a/~a Result: ~a~n" 
+					      steps (min max-depth one-step-depth)
+					      (play->string v))
+				  v))
+			  ;; We have at least one result, now.
+			  (semaphore-post once-sema)
+			  ;; If we could learn more by searching deeper, then
+			  ;;  do so.
+			  (unless (or (and (= steps max-steps)
+					   (one-step-depth . <= . max-depth))
+				      ((car result) . = . +inf.0)
+				      ((car result) . = . -inf.0))
+			    (if (one-step-depth . <= . max-depth)
+				(loop (add1 steps) 2)
+				(loop steps (add1 max-depth)))))
+			(semaphore-post result-sema)))])
+	      ;; Sync with the background thread and return the result:
+	      (sync/timeout timeout result-sema)
+	      (semaphore-wait once-sema)
+	      (kill-thread t)
+	      (when (null? (cdr result))
+		(error 'search "didn't find a move!?"))
+	      (cdr result)))))
+
+      ;; `make-plan' takes a piece size, the source position (#f and #f for off
+      ;;  the board), the destination position, a xform inidcating how to
+      ;;  transform the positions into canonical positions, and a number
+      ;;  that estimates how many more steps until the end of game.
+      (define-struct plan (size from-i from-j to-i to-j xform turns))
+
+      ;; apply-play : board play -> board
+      ;; A play is (list piece from-i from-j to-i to-j turns)
+      ;;  where turns is an estimate of how many moves remain in
+      ;;  the game; the turns part is not used here (it can be left
+      ;;  out), but it is returned by a search-proc.
+      (define (apply-play board m)
+	(move board 
+	      (list-ref m 0)
+	      (list-ref m 1)
+	      (list-ref m 2)
+	      (list-ref m 3)
+	      (list-ref m 4)
+	      (lambda (new-board)
+		new-board)
+	      (lambda ()
+		(error 'apply-play "bad move: ~a" m))))
+
+      ;; ------------------------------------------------------------
+      ;; Checking and combining move plans
+            
+      (define delay-loss? #t)
+
+      ;; Discourage loops:
+      (define LOOP-TIE `((-1000.0 loop!)))
+      
+      ;; Translates a plan into the given coordinate xform
+      (define (xlate m xform)
+	(let-values ([(from-i from-j)
+		      (if (plan-from-i m)
+			  (unapply-xform xform (apply-xform (plan-xform m)
+							    (plan-from-i m)
+							    (plan-from-j m)))
+			  (values #f #f))]
+		     [(to-i to-j)
+		      (unapply-xform xform (apply-xform (plan-xform m)
+							(plan-to-i m)
+							(plan-to-j m)))])
+	  (make-plan (plan-size m) from-i from-j to-i to-j xform (plan-turns m))))
+
+      (define (found-win? v)
+	(and (pair? v)
+	     (= (caar v) +inf.0)))
+
+      (define (immediate? v)
+	(and (pair? v) (zero? (get-depth (car v)))))
+
+      (define (found-lose? v)
+	(and (pair? v)
+	     (= (caar v) -inf.0)))
+
+      (define (get-depth a)
+	(if (plan? (cdr a))
+	    (plan-turns (cdr a))
+	    0))
+
+      ;; Keeps the best move --- up to `span' of them --- in `a' and `b'.
+      ;;  The two lists are sorted, and the result should keep them sorted.
+      ;;  For -inf.0 ratings, prefer the move farthest from the end of the
+      ;;  game, otherwise prefer the move closest.
+      (define (best span a b)
+	(cond
+          ;; First, cases where span, a, or b goes to zero/null: 
+          [(zero? span) null]
+          [(null? a)
+           (if (null? b)
+               null
+               (cons (car b) (best (sub1 span) null (cdr b))))]
+          [(null? b)
+           (cons (car a) (best (sub1 span) null (cdr a)))]
+          ;; Pick best from first of a and first of b:
+          ;; - Case 1: a is rated better
+          [(> (caar a) (caar b))
+           (cons (car a) (best (sub1 span) (cdr a) b))]
+          ;; - Case 2: b is rated better
+          [(< (caar a) (caar b))
+           (cons (car b) (best (sub1 span) a (cdr b)))]
+          ;; - Case 3: same ratings, so pick based on distance to end-of-game
+          ;;  - Subcase 1: we're picking between losses, and we want to delay the loss
+          [(and delay-loss? 
+                (= (caar a) -inf.0))
+           (if (> (get-depth (car a)) (get-depth (car b)))
+               (cons (car a) (best (sub1 span) (cdr a) b))
+               (cons (car b) (best (sub1 span) a (cdr b))))]
+          ;;  - Subcase 2: a reaches the end first
+          [(< (get-depth (car a)) (get-depth (car b)))
+           (cons (car a) (best (sub1 span) (cdr a) b))]
+          ;;  - Subcase 3: b reaches the end first (or no later than a)
+          [else (cons (car b) (best (sub1 span) a (cdr b)))]))
+
+      ;; --- TESTS ---
+      #;
+      (let* ([plan1 (make-plan 0 0 0 0 0 0 1)]
+	     [plan2 (make-plan 0 0 0 0 0 0 2)]
+	     [plan1s (list (cons 2 plan1) (cons 1 plan1))])
+	;; Check empty/zero combinations:
+	(test null (best 20 null null))
+	(test plan1s (best 2 plan1s null))
+	(test plan1s (best 2 null plan1s))
+	(test plan1s (best 20 null plan1s))
+	(test null (best 0 plan1s plan1s))
+	;; Check rating choice
+	(test (list (cons 2 plan1)) (best 1 (list (cons 2 plan1)) (list (cons 1 plan1))))
+	(test (list (cons 1 plan1)) (best 1 (list (cons 1 plan1)) (list (cons -inf.0 plan2))))
+	(test (list (cons 1 plan2)) (best 1 (list (cons -inf.0 plan1)) (list (cons 1 plan2))))
+	(test (list (cons 10 plan2) (cons 2 plan1)) (best 2 
+							  (list (cons 2 plan1) (cons 1 plan2)) 
+							  (list (cons 10 plan2) (cons 1 plan1))))
+	;; Check time-til-end choice:
+	(test (list (cons 1 plan1)) (best 1 (list (cons 1 plan1)) (list (cons 1 plan2))))
+	(test (list (cons -inf.0 plan2)) (best 1 (list (cons -inf.0 plan1))
+                                               (list (cons -inf.0 plan2)))))
+
+      ;; ------------------------------------------------------------
+      ;;  Multi-step minmax (non-exhaustive):
+      
+      (define hit-count 0)
+      (define depth-count 0)
+      (define explore-count 0)
+      (define enter-count 0)
+      (define move-count 0)
+
+      ;; ...state and search params... -> (values (listof (cons num plan)) xform)
+      ;; Minimax search up to the given max-depth, returning up to span
+      ;; choices of move.
+      (define (minmax depth span config me board last-to-i last-to-j)
+	(set! hit-count (add1 hit-count))
+	(let* ([board-key+xform ((config-canonicalize config) board me)]
+	       [board-key (car board-key+xform)]
+	       [xform (cdr board-key+xform)]
+	       [key (vector board-key (- (config-max-depth config) depth) span)])
+	  (let ([choices
+		 (cond
+		  ;; Check for known win/loss at arbitrary depth:
+		  [(hash-table-get (config-memory config) board-key (lambda () #f)) 
+                   => (lambda (x) x)]
+		  ;; Check for known result at specific remaining depth:
+		  [(hash-table-get (config-memory config) key (lambda () #f)) 
+                   => (lambda (x) x)]
+		  ;; Check for immediate loss (only rating matters; plan is never used)
+		  [(winner? board (other me))
+		   (hash-table-put! (config-memory config) board-key '((-inf.0)))
+		   '((-inf.0))]
+		  ;; Check for immediate loss (only rating matters)
+		  [(winner? board me)
+		   (hash-table-put! (config-memory config) board-key '((+inf.0)))
+		   '((+inf.0))]
+		  ;; Check for depth
+		  [(depth . >= . (config-max-depth config))
+		   (set! depth-count (add1 depth-count))
+		   (let ([l (list 
+                             (list ((config-rate-board config) board me last-to-i last-to-j)))])
+		     (hash-table-put! (config-memory config) key l)
+		     l)]
+		  ;; Otherwise, we explore this state...
+		  [else 
+		   (set! depth-count (add1 depth-count))
+		   (set! explore-count (add1 explore-count))
+		   ;; In case we get back here while we're looking, claim an unknown tie:
+		   (hash-table-put! (config-memory config) board-key LOOP-TIE)
+		   (let* ([choices
+			   (map (lambda (g)
+				  ;; Make sure each canned move is in our coordinate system:
+				  (cons (car g) (xlate (cdr g) xform)))
+				((config-canned-moves config) board me board-key xform))]
+			  [choices
+			   (if (found-win? choices)
+			       choices
+			       (try-all-enters choices depth span config
+					       me board xform))]
+			  [choices
+			   (if (found-win? choices)
+			       choices
+			       (try-all-moves choices depth span config
+					      me board xform))]
+			  [choices (if (null? choices)
+				       ;; No moves! We lose
+				       '((-inf.0))
+				       ;; We have at least one move
+				       choices)])
+		     (hash-table-remove! (config-memory config) board-key)
+		     (let ([key (if (and ((caar choices) . < . +inf.0)
+					 ((caar choices) . > . -inf.0))
+				    ;; Result is only valid to current depth limit:
+				    key
+				    ;; Win or loss: result is valid to any depth:
+				    board-key)])
+		       (hash-table-put! (config-memory config) key choices)
+		       choices))])])
+	    (values choices xform))))
+
+      ;; try-all-enters : ... -> (listof (cons num plan))
+      ;; Try moving each available off-board piece onto each board position
+      (define (try-all-enters choices depth span config me board xform)
+	(let loop ([enters (pick-enters board me)]
+		   [choices choices])
+	  (if (null? enters)
+	      choices
+	      ;; For this piece....
+	      (let ([p (list-ref (if (eq? me 'red) red-pieces yellow-pieces) 
+				 (car enters))])
+		(loop (cdr enters)
+		      ;; ... try every target position:
+		      (fold-board/choices
+		       span choices
+		       (lambda (i j)
+			 (try-move depth config 
+				   board me
+				   p #f #f i j xform))))))))
+      
+      ;; try-all-moves : ... -> (listof (cons num plan))
+      ;; Try moving each on-board piece onto each other board position
+      (define (try-all-moves choices depth span config me board xform)
+	;; From each source...
+	(fold-board/choices
+	 span choices
+	 (lambda (from-i from-j)
+	   ;; ... if it has my piece...
+	   (let ([l (board-ref board from-i from-j)])
+	     (if (and (pair? l)
+		      (eq? me (piece-color (car l))))
+		 ;; ... try every target position:
+		 (fold-board/choices
+		  span choices
+		  (lambda (to-i to-j)
+		    (try-move depth config 
+			      board me 
+			      (car l) from-i from-j to-i to-j xform)))
+		 ;; Can't move from here:
+		 null)))))
+
+      ;; Try the move, and if it's ok, call `minmax' with the other
+      ;; player and invert the result
+      (define (try-move depth config 
+			board me
+			p from-i from-j to-i to-j xform)
+	(move board p from-i from-j to-i to-j
+	      (lambda (new-board)
+		;; Move is ok; rate it
+		(set! move-count (add1 move-count))
+		;; Min-max recur for other player:
+		(let-values ([(his-choices sxform)
+			      (minmax (add1 depth) 1 config
+				      (other me) new-board
+				      to-i to-j)])
+		  #;
+		  (when (zero? depth)
+                    (show-recur (piece-size p) from-i from-j to-i to-j his-choices))
+		  ;; Construct a plan for this choice, and rate it
+		  ;;  opposite of the minmax result
+		  (list (cons (- (caar his-choices))
+			      (make-plan (piece-size p) from-i from-j to-i to-j 
+					 xform 
+					 (add1 (get-depth (car his-choices))))))))
+	      (lambda ()
+		;; Move isn't ok
+		null)))
+
+      ;; pick-enters: board -> (listof num)
+      (define (pick-enters board me)
+	(let loop ([avail-pieces (available-off-board board me)]
+		   [played-sizes null])
+	  (cond
+	   [(null? avail-pieces) null]
+	   [(memq (caar avail-pieces) played-sizes)
+	    (loop (cdr avail-pieces)
+		  played-sizes)]
+	   [else
+	    (cons 
+	     ;; piece to move:
+	     (caar avail-pieces)
+	     ;; Try pieces from other stacks:
+	     (loop (cdr avail-pieces)
+		   (cons (caar avail-pieces) played-sizes)))])))
+
+      ;; Like `fold-board', but auto combines choices and
+      ;;  handles shortcut for known immediate wins
+      (define (fold-board/choices span choices f)
+	(fold-board
+	 (lambda (i j choices)
+	   (if (and (found-win? choices)
+		    (immediate? choices))
+	       choices
+	       (best span
+		     choices
+		     (f i j))))
+	 choices))
+
+      ;; --- TESTS ---
+      #;
+      (let* ([plan (make-plan 0 0 0 0 0 0 1)])
+	;; fold-board/choices
+	(test (if (= BOARD-SIZE 3) 
+		  (list (cons 4 plan) (cons 3 plan))
+		  (list (cons 6 plan) (cons 5 plan)))
+	      (fold-board/choices 2 null (lambda (i j)
+					   (list (cons (+ i j) plan)))))
+
+	;; pick-enters
+	(let* ([one-red (move empty-board (list-ref red-pieces (sub1 BOARD-SIZE)) 
+                              #f #f 0 0 values void)]
+	       [two-red (move one-red (list-ref red-pieces (- BOARD-SIZE 2))
+                              #f #f 1 1 values void)]
+	       [three-red (move two-red (list-ref red-pieces (sub1 BOARD-SIZE))
+                                #f #f 2 2 values void)]
+	       [place-all (lambda (l)
+			    (cdr
+			     (fold-board (lambda (i j l+b)
+					   (if (null? (car l+b))
+					       l+b
+					       (cons (cdr (car l+b))
+						     (move (cdr l+b) (caar l+b) 
+                                                           #f #f i j values void))))
+					 (cons l empty-board))))])
+	  (test (if (= BOARD-SIZE 3) '(2 1 0) '(3))
+		(pick-enters empty-board 'red))
+	  (test (if (= BOARD-SIZE 3) '(2 1 0) '(3 2))
+		(pick-enters one-red 'red))
+	  (test (if (= BOARD-SIZE 3) '(2 1 0) '(3 1))
+		(pick-enters two-red 'red))
+	  (test (if (= BOARD-SIZE 3) '(1 0) '(3 2 1))
+		(pick-enters three-red 'red))
+
+	  (let ([all-red-pieces (apply append 
+                                       (vector->list (make-vector (sub1 BOARD-SIZE) red-pieces)))])
+	    (test null (pick-enters (place-all all-red-pieces) 'red))
+	    (test '(2) (pick-enters (place-all (remq (list-ref red-pieces 2) 
+						     all-red-pieces))
+				    'red))
+	    (test (if (= BOARD-SIZE 3) '(1 0) '(1))
+		  (pick-enters (place-all (remq (list-ref red-pieces 0)
+						(remq (list-ref red-pieces 1) 
+						      all-red-pieces)))
+			       'red)))))
+      
+      ;; ------------------------------------------------------------
+      ;;  Multi-step minmax (non-exhaustive):
+
+      ;; Apply minmax, and if steps > 1, rate resulting moves by applying
+      ;; minmax to them. Meanwhile, in learning mode, record any resulting
+      ;; move that is known to lead to winning or losing.
+      (define (multi-step-minmax steps span config indent init-memory me board)
+	(define first-move? 
+	  ((fold-board (lambda (i j v) (+ v (length (board-ref board i j)))) 0) . < . 2))
+	(define now (current-inexact-milliseconds))
+	(set! hit-count 0)
+	(set! depth-count 0)
+	(set! explore-count 0)
+	(set! enter-count 0)
+	(set! move-count 0)
+	(log-printf 1 indent "~a> ~a Exploring for ~a~n" (make-string indent #\space) steps me)
+	(let-values ([(vs xform)
+		      (minmax 0
+			      (if (or (steps . <= . 1) first-move?)
+				  1
+				  span)
+			      config
+			      me
+			      board #f #f)])
+	  (log-printf 2 indent "~a>> Done ~a ~a ~a ~a+~a [~a secs]~n" 
+		      (make-string indent #\space) 
+		      hit-count depth-count explore-count enter-count move-count
+		      (float->string (/ (- (current-inexact-milliseconds) now) 1000)))
+	  (let ([plays
+		 (map (lambda (v)
+			;; Transform each result, and turn it into a list
+			(cons (car v) 
+			      (let ([m (xlate (cdr v) xform)])
+				(list (list-ref (if (eq? me 'red)
+						    red-pieces
+						    yellow-pieces)
+						(plan-size m))
+				      (plan-from-i m)
+				      (plan-from-j m)
+				      (plan-to-i m)
+				      (plan-to-j m)
+				      (get-depth v)))))
+		      (filter (lambda (v) (plan? (cdr v))) vs))])
+	    (log-printf 3 indent "~a>> Best Plays: ~a\n" 
+			(make-string indent #\space) (plays->string 
+						      (make-string (+ 15 indent) #\space)
+						      plays))
+
+	    ;; Record what we've learned...
+	    (when (and learn?
+		       (= steps 1))
+              (record-result plays board me config init-memory))
+
+	    (if (or (steps . <= . 1) first-move?)
+		(car plays)
+		(let ([nexts 
+                       ;; See what the other player thinks about our candidate moves,
+                       ;;  and pick the one that looks worst to the other player.
+		       (if ((caar plays) . < . +inf.0)
+			   (mergesort
+			    (map
+			     (lambda (play)
+			       (log-printf 4 indent " ~a>>> Checking: ~a\n" 
+					   (make-string indent #\space) (play->string play))
+			       (if (= -inf.0 (car play))
+				   (begin
+				     (log-printf 4 indent " ~a>>>> losing\n" 
+                                                 (make-string indent #\space))
+				     play)
+				   (let ([r (cons (- (car (multi-step-minmax 
+							   (sub1 steps) span config 
+							   (+ 3 indent) init-memory
+							   (other me)
+							   (apply-play board (cdr play)))))
+						  (cdr play))])
+				     (log-printf 4 indent " ~a>>>> deeper = ~a\n" 
+						 (make-string indent #\space)
+                                                 (float->string (car r)))
+				     r)))
+			     plays)
+			    (lambda (a b)
+			      (> (car a) (car b))))
+			   (list (car plays)))])
+		  (car nexts))))))
+
+      ;; ------------------------------------------------------------
+      ;;  Multi-run memory:
+
+      (define learn? #f)
+      (define MEMORY-FILE (and learn?
+			       (build-path (find-system-path 'addon-dir)
+					   (format "gobblet-memory-~a.ss" BOARD-SIZE))))
+
+      (define (record-result plays board me config init-memory)
+        (when (or (found-win? plays)
+                  (found-lose? plays))
+          (let ([board-key+xform ((config-canonicalize config) board me)])
+            (hash-table-get init-memory 
+                            (car board-key+xform)
+                            (lambda ()
+                              ;; This is new...
+                              (with-output-to-file MEMORY-FILE
+                                (lambda ()
+                                  (let ([m (cdar plays)])
+                                    (printf "(~a ~a ~a)~n#|~n~a|#~n" 
+                                            (if (found-win? plays) 'win 'lose)
+                                            (car board-key+xform)
+                                            (list
+                                             (piece-color (list-ref m 0))
+                                             (piece-size (list-ref m 0))
+                                             (list-ref m 1) (list-ref m 2)
+                                             (list-ref m 3) (list-ref m 4)
+                                             (list-ref m 5))
+                                            (board->string 0 board))))
+                                'append))))))
+      
+      ;; to load what we've learned from previous runs
+      (define (load-memory init-memory canonicalize)
+	(with-handlers ([exn:fail:filesystem? void])
+	  (with-input-from-file MEMORY-FILE
+	    (lambda ()
+	      (let loop ()
+		(let ([v (read)])
+		  (unless (eof-object? v)
+		    (let ([board-key+xform (canonicalize (cadr v) #f)])
+		      (hash-table-put! init-memory
+				       (car board-key+xform)
+				       (list
+					(cons (if (eq? 'win (car v)) +inf.0 -inf.0)
+					      (let ([n (caddr v)])
+						(make-plan
+						 (cadr n)
+						 (list-ref n 2) (list-ref n 3)
+                                                 (list-ref n 4) (list-ref n 5)
+						 (cdr board-key+xform)
+						 (list-ref n 6)))))))
+		    (loop))))))))
+
+      ;; ------------------------------------------------------------
+      ;;  Debugging helpers
+
+      (define (float->string v)
+	(let ([s (string-append (number->string v) "000000")])
+	  (substring s 0 (min 6 (string-length s)))))
+
+      (define (play->string p)
+	(format "~a (~a,~a)->(~a,~a) [~a/~a]"
+		(piece-size (list-ref p 1))
+		(list-ref p 2) (list-ref p 3)  (list-ref p 4) (list-ref p 5)
+		(float->string (car p))
+		(list-ref p 6)))
+
+      (define (plays->string is p)
+	(if (null? p)
+	    "()"
+	    (let ([s (plays->string is (cdr p))])
+	      (if (null? (cdr p))
+		  (play->string (car p))
+		  (string-append (play->string (car p))
+				 "\n"
+				 is
+				 s)))))
+
+      (define (show-recur sz from-i from-j to-i to-j sv)
+	(if (not (plan? (cdar sv)))
+	    (printf "   Recur ~a (~a,~a)->(~a,~a) ; ??? = ~a/~a~n"
+		    sz from-i from-j to-i to-j 
+		    (caar sv) (get-depth (car sv)))
+	    (printf "   Recur ~a (~a,~a)->(~a,~a) ; (~a,~a)->(~a,~a) = ~a/~a~n"
+		    sz from-i from-j to-i to-j 
+		    (plan-from-i (cdar sv)) (plan-from-j (cdar sv)) 
+		    (plan-to-i (cdar sv)) (plan-to-j (cdar sv))
+		    (caar sv) (get-depth (car sv))))))))
diff --git a/collects/games/gobblet/gobblet.png b/collects/games/gobblet/gobblet.png
new file mode 100644
index 0000000000..6c0637eeff
Binary files /dev/null and b/collects/games/gobblet/gobblet.png differ
diff --git a/collects/games/gobblet/gobblet.ss b/collects/games/gobblet/gobblet.ss
new file mode 100644
index 0000000000..0fcf80b81f
--- /dev/null
+++ b/collects/games/gobblet/gobblet.ss
@@ -0,0 +1,62 @@
+(module gobblet mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "unit.ss")
+	   (lib "file.ss")
+	   (lib "mred.ss" "mred")
+	   "sig.ss"
+	   "model.ss"
+	   "gui.ss"
+	   "heuristics.ss"
+	   "explore.ss"
+	   "../show-help.ss")
+
+  (provide game-unit)
+
+  (define game-unit 
+    (unit
+      (import)
+      (export)
+
+      (define (make-gobblet-unit size)
+	(compound-unit/sig
+	 (import)
+	 (link [CONFIG : config^ ((unit/sig config^
+				    (import)
+				    (define BOARD-SIZE size)))]
+	       [RESTART : restart^ ((unit/sig restart^
+				      (import)
+				      (define (new-game n)
+					(put-preferences '(gobblet:board-size) (list n) void)
+					(parameterize ([current-eventspace orig-eventspace])
+					  (queue-callback
+					   (lambda ()
+					     (start-gobblet n)))))
+				      (define (show-gobblet-help)
+					(parameterize ([current-eventspace orig-eventspace])
+					  (queue-callback
+					   (lambda ()
+					     (unless help
+					       (set! help (show-help (list "games" "gobblet")
+                                                                     "Gobblet Help" #f)))
+					     (help)))))))]
+	       [MODEL : model^ (model-unit CONFIG)]
+	       [HEURISTICS : heuristics^ (heuristics-unit CONFIG MODEL EXPLORE)]
+	       [EXPLORE : explore^ (explore-unit CONFIG MODEL)]
+	       [GUI : () (gui-unit CONFIG MODEL RESTART HEURISTICS EXPLORE)])
+	 (export)))
+
+      (define help #f)
+
+      (define orig-eventspace (current-eventspace))
+      
+      (define (start-gobblet board-size)
+	;; Start a new game as a child process:
+	(parameterize ([current-custodian (make-custodian)])
+	  (parameterize ([exit-handler (lambda (v)
+					 (custodian-shutdown-all (current-custodian)))])
+	    (parameterize ([current-eventspace (make-eventspace)])
+	      (queue-callback
+	       (lambda ()
+		 (invoke-unit/sig (make-gobblet-unit board-size))))))))
+      
+      (start-gobblet (get-preference 'gobblet:board-size (lambda () 3))))))
diff --git a/collects/games/gobblet/gui.ss b/collects/games/gobblet/gui.ss
new file mode 100644
index 0000000000..9cf4b95116
--- /dev/null
+++ b/collects/games/gobblet/gui.ss
@@ -0,0 +1,517 @@
+(module gui mzscheme
+  (require (lib "gl-board.ss" "games" "gl-board-game")
+           (lib "class.ss")
+	   (lib "mred.ss" "mred")
+           (lib "file.ss")
+           (lib "gl-vectors.ss" "sgl")
+           (prefix gl- (lib "sgl.ss" "sgl"))
+	   (lib "unitsig.ss")
+	   "sig.ss")
+
+  (provide gui-unit)
+  
+  (define gui-unit
+    (unit/sig ()
+      (import config^ model^ restart^ heuristics^ explore^)
+
+      ;; Configuration ------------------------------
+
+      (define JR? (= BOARD-SIZE 3))
+      
+      (define PIECE-SIZES (if JR?
+			      '(0.4 0.6 0.75)
+			      '(0.3 0.45 0.65 0.8)))
+
+      ;; Auto-play:
+      (define smart? (get-preference 'gobblet:auto-play-smart? (lambda () #f)))
+      (define timeout (let ([v (get-preference 'gobblet:auto-play-timeout (lambda () #f))])
+			(if (and (number? v) (real? v))
+			    v
+			    3.0)))
+      
+      ;; GUI ------------------------------
+      
+      (define yellow (gl-float-vector 1.0 1.0 0.0 1.0))
+      (define red (gl-float-vector 1.0 0.0 0.0 1.0))
+      (define light-blue (gl-float-vector 0.5 0.5 1.0 1.0))
+      (define dark-blue (gl-float-vector 0.0 0.0 1.0 1.0))
+      
+      ;; A gui-piece is
+      ;;  (make-gui-piece piece gl-description num num)
+      ;;  where the nums might be < 0 or > BOARD-SIZE
+      (define-struct gui-piece (piece dl i j))
+
+      ;; State ------------------------------
+
+      ;; The state of the game, as reflected in the GUI:
+      (define board empty-board)
+      (define turn 'red)
+
+      ;; past, future : (list-of (cons thunk thunk))
+      ;;                where first thunk is do and second is undo
+      (define past null)
+      (define future null)
+
+      ;; When `playing?' is true, double-check reset request
+      (define playing? #f)
+
+      ;; GUI Move ------------------------------
+
+      ;; This function is called when the user tries to move `gp'
+      ;;  to location `to'
+      (define (gui-move gp to)
+	(when (gui-piece? gp)
+	  ;; Get dest and source locations:
+	  (let* ((to-i (inexact->exact (floor (gl-vector-ref to 0))))
+		 (to-j (inexact->exact (floor (gl-vector-ref to 1))))
+		 (from-i (gui-piece-i gp))
+		 (from-j (gui-piece-j gp))
+		 (on-board? (<= 0 from-i (sub1 BOARD-SIZE))))
+	    ;; Only move if the requent lands on the board:
+	    (when (and (<= 0 to-i (sub1 BOARD-SIZE))
+		       (<= 0 to-j (sub1 BOARD-SIZE)))
+	      ;; Only move if the model says that it's ok:
+	      (move board (gui-piece-piece gp) 
+		    (and on-board? from-i) (and on-board? from-j)
+		    to-i to-j
+		    (lambda (new-board)
+		      (install-board new-board gp to-i to-j))
+		    (lambda ()
+		      ;; Move not allowed by model
+		      (void)))))))
+
+      (define (install-board new-board gp to-i to-j)
+	;; Move allowed by the model. Create a thunk to
+	;; execute this move and a thunk to undo this
+	;; move:
+	(let ([new-gp (make-gui-piece (gui-piece-piece gp) (gui-piece-dl gp)
+				      to-i to-j)]
+	      [old-board board]
+	      [old-turn turn])
+	  (action!
+	   ;; Forward thunk:
+	   (lambda ()
+	     (set! board new-board)
+	     (send gui-board remove-piece gp)
+	     (gui-add-piece new-gp)
+	     (let ([r? (winner? new-board 'red)]
+		   [y? (winner? new-board 'yellow)])
+	       (cond
+		[(and r? y?) (set-winner! (case old-turn
+					    [(red) "Yellow"]
+					    [(yellow) "Red"]))]
+		[r? (set-winner! "Red")]
+		[y? (set-winner! "Yellow")]
+		[else (set-turn! (other old-turn))])))
+	   ;; Rewind thunk:
+	   (lambda ()
+	     (set! board old-board)
+	     (send gui-board remove-piece new-gp)
+	     (gui-add-piece gp)
+	     (set-turn! old-turn)))))
+
+      ;; GUI Board and Pieces ------------------------------
+
+      (define f (new (class frame% 
+		       (define/augment (on-close)
+			 (inner (void) on-close)
+			 (exit))
+		       (super-new))
+		     (label "Gobblet") (width 800) (height 600)))
+      (define gui-board
+	(new gl-board% (parent f)  (who "Gobblet")
+	     (min-x (if JR? (- 1 BOARD-SIZE) -1))
+             (max-x (if JR? (sub1 (* 2 BOARD-SIZE)) (add1 BOARD-SIZE)))
+	     (min-y 0)
+             (max-y BOARD-SIZE)
+	     (lift 1.2)
+	     (move gui-move)
+	     (theta 30)))
+
+      (define q
+	(send gui-board with-gl-context
+	      (lambda () (gl-new-quadric))))
+
+      ;; Space description:
+      (define space-dl
+	(send gui-board with-gl-context
+	      (lambda ()
+		(let ((list-id (gl-gen-lists 1)))
+		  (gl-quadric-draw-style q 'fill)
+		  (gl-quadric-normals q 'smooth)
+		  (gl-new-list list-id 'compile)
+		  (gl-material-v 'front 'ambient-and-diffuse dark-blue)
+		  (gl-begin 'polygon)
+		  (gl-vertex 0.0 0.0 -0.02)
+		  (gl-vertex 1.0 0.0 -0.02)
+		  (gl-vertex 1.0 1.0 -0.02)
+		  (gl-vertex 0.0 1.0 -0.02)
+		  (gl-end)
+		  (gl-material-v 'front 'ambient-and-diffuse light-blue)
+		  (gl-push-matrix)
+		  (gl-translate 0.5 0.5 -0.01)
+		  (gl-disk q 0.0 .40 25 1)
+		  (gl-pop-matrix)
+		  (gl-end-list)
+		  list-id))))
+
+      ;; Install spaces on board:
+      (fold-board (lambda (i j v)
+		    (send gui-board add-space
+			  (lambda ()
+			    (gl-push-matrix)
+			    (gl-translate i j 0.01)
+			    (gl-call-list space-dl)
+			    (gl-pop-matrix))
+			  (cons i j)))
+		  void)
+      
+      ;; Piece description-maker:
+      (define (make-piece-dl color scale)
+	(send gui-board with-gl-context
+	      (lambda ()
+		(let ((list-id (gl-gen-lists 1)))
+		  (gl-quadric-draw-style q 'fill)
+		  (gl-quadric-normals q 'smooth)
+		  (gl-new-list list-id 'compile)
+		  (gl-material-v 'front 'ambient-and-diffuse color)
+		  (gl-cylinder q (/ scale 2) (/ scale 2) (* 1.5 scale) 25 1)
+		  (gl-push-matrix)
+		  (gl-translate 0.0 0.0 (* 1.5 scale))
+		  (gl-disk q 0.0 (/ scale 2) 25 1)
+		  (gl-pop-matrix)
+		  (gl-end-list)
+		  list-id))))
+
+      ;; Red piece descriptions:
+      (define red-dls (map (lambda (size)
+			     (make-piece-dl red size))
+			   PIECE-SIZES))
+
+      ;; Yellow piece descriptions:
+      (define yellow-dls (map (lambda (size)
+				(make-piece-dl yellow size))
+			      PIECE-SIZES))
+
+      ;; GUI piece records, with each piece at its initial place:
+      (define gui-pieces
+	(let loop ([red-dls red-dls][yellow-dls yellow-dls]
+		   [red-pieces red-pieces][yellow-pieces yellow-pieces]
+		   [sizes PIECE-SIZES][z 0])
+	  (if (null? red-dls)
+	      null
+	      (append
+	       (let ([sz (car sizes)])
+		 (let loop ([dw (if JR?
+				    (- BOARD-SIZE 2)
+				    (- BOARD-SIZE 1.5))])
+		   (if (negative? dw)
+		       null
+		       (list*
+			(make-gui-piece (car red-pieces) (car red-dls) 
+					(if JR? (- dw BOARD-SIZE -1) -1)
+					(if JR? z dw))
+			(make-gui-piece (car yellow-pieces) (car yellow-dls) 
+					(if JR? (+ BOARD-SIZE dw) BOARD-SIZE)
+					(if JR? z dw))
+			(loop (sub1 dw))))))
+	       (loop (cdr red-dls) (cdr yellow-dls) 
+		     (cdr red-pieces) (cdr yellow-pieces) 
+		     (cdr sizes) (+ z 1))))))
+      
+      ;; Places a gui-piece at its location on the board:
+      (define (gui-add-piece gp)
+	(send gui-board add-piece 
+	      (+ (gui-piece-i gp) 0.5) (+ (gui-piece-j gp) 0.5) 0
+	      (lambda (for-shadow?)
+                (when for-shadow?
+                  (gl-disable 'lighting))
+                (gl-call-list (gui-piece-dl gp))
+                (when for-shadow? 
+                  (gl-enable 'lighting)))
+	      gp))
+
+      ;; Extra GUI controls ----------------------------------------
+
+      ;; Define a 3-element pane that makes the left and right parts
+      ;;  the same width (so that the middle part is centered):
+      (define controls (new (class horizontal-pane% 
+			      ;; Override place-children for the 3-child case,
+			      ;;  make first and third the same width
+			      (define/override (place-children l w h)
+				(let ([r (super place-children l w h)])
+				  (if (= (length r) 3)
+				      (let ([a (list-ref r 0)]
+					    [b (list-ref r 1)]
+					    [c (list-ref r 2)])
+					(let* ([aw (list-ref a 2)]
+					       [cw (list-ref c 2)]
+					       [naw (quotient (+ aw cw) 2)])
+					  (list
+					   (list (car a) (cadr a) 
+                                                 naw (cadddr a))
+					   (list (+ (car b) (- naw aw)) (cadr b) 
+                                                 (caddr b) (cadddr b))
+					   (list (+ naw (caddr b)) (cadr c)
+                                                 (- (+ cw aw) naw) (cadddr c)))))
+				      r)))
+			      (super-new))
+			    (parent f)
+			    (stretchable-height #f)))
+
+      ;; Status message:
+      (define msg
+	(new message% (label "") (parent controls) (stretchable-width #t)))
+      
+      ;; Forward & Reverse buttons
+      (define controls-middle (new horizontal-pane% 
+				   (parent controls)
+				   (stretchable-height #f)
+				   (stretchable-width #f)))
+      (define arrows? (let ([f (make-object font% 12 'system)])
+			(and (send f screen-glyph-exists? #\u25C0 #t)
+			     (send f screen-glyph-exists? #\u25B6 #t))))
+      (define backward-button
+	(new button% (label (if arrows? " \u25C0 " " < ")) (parent controls-middle) 
+	     (callback (lambda (b e) (backward!)))))
+      (define forward-button
+	(new button% (label (if arrows? " \u25B6 " " > ")) (parent controls-middle)
+	     (callback (lambda (b e) (forward!)))))
+      (define (enable-buttons)
+	(send backward-button enable (pair? past))
+	(send forward-button enable (pair? future)))
+
+      ;; Reset & Help buttons:
+      (define controls-right (new horizontal-pane% 
+				  (parent controls)
+				  (stretchable-height #f)
+				  (alignment '(right center))))
+      (new button% (label "Reset") (parent controls-right)
+	   (callback (lambda (b e)
+		       (when (or (not playing?)
+				 (equal? 1 (message-box/custom
+					    "Warning"
+					    "Stop game in progress and reset?"
+					    "Reset"
+					    "Cancel"
+					    #f
+					    f
+					    '(default=1 caution))))
+			 (reset!)))))
+      (new button% (label (if (= BOARD-SIZE 3) "4x4 Game" "3x3 Game"))
+	   (parent controls-right)
+	   (callback (lambda (b e)
+		       (new-game (if (= BOARD-SIZE 3) 4 3)))))
+      (new button% (label "Help") (parent controls-right)
+	   (callback (lambda (b e)
+		       (show-gobblet-help))))
+
+      (define bottom (new horizontal-pane% 
+			  (parent f)
+			  (stretchable-height #f)
+			  (alignment '(left center))))
+
+      (define auto-red (new check-box% 
+			    (label "Auto-Play Red")
+			    (parent bottom)
+			    (callback (lambda (c e)
+					(when (eq? turn 'red)
+					  (check-auto-play))))))
+      (define auto-yellow (new check-box% 
+			       (label "Auto-Play Yellow")
+			       (parent bottom)
+			       (callback (lambda (c e)
+					   (when (eq? turn 'yellow)
+					     (check-auto-play))))))
+
+      (define auto-play-msg (new message%
+				 (label "") (parent bottom) (stretchable-width #t)))
+
+      (new button%
+	   [label "Auto-Play Options"]
+	   [parent bottom]
+	   [callback
+	    (lambda (b e)
+	      (letrec ([d (new dialog% 
+			       [label "Auto-Play Options"]
+			       [alignment '(left center)]
+			       [parent f])]
+		       [mode (new choice%
+				  [label "Mode:"]
+				  [parent d]
+				  [choices '("Smart - plays Red perfectly in 3x3 game"
+					     "Ok - tries to plan for next move")]
+				  [callback void])]
+		       [timeout-field (new text-field%
+					   [label "Auto-play Think Time (seconds):"]
+					   [parent d]
+					   [init-value (number->string timeout)]
+					   [callback 
+                                            (lambda (t e)
+                                              (let* ([e (send t get-editor)]
+                                                     [val (string->number (send e get-text))]
+                                                     [bad? (or (not val)
+                                                               (not (real? val))
+                                                               (val . < . 0))])
+                                                (send ok-button enable (not bad?))
+                                                (send e change-style 
+                                                      (send (make-object style-delta%)
+                                                            set-delta-background 
+                                                            (if bad? "yellow" "white"))
+                                                      0 (send e last-position))))])]
+		       [button-panel (new horizontal-pane% 
+					  [parent d]
+					  [alignment '(right center)]
+					  [stretchable-height #f])]
+		       [ok-button
+			(new button%
+			     [label "Ok"] [parent button-panel] [style '(border)]
+			     [callback (lambda (b e)
+					 (set! smart? (= 0 (send mode get-selection)))
+					 (set! timeout (string->number
+                                                        (send timeout-field get-value)))
+					 (put-preferences '(gobblet:auto-play-smart?) 
+                                                          (list smart?)
+                                                          void)
+					 (send d show #f))])])
+		(new button%
+		     [label "Cancel"] [parent button-panel]
+		     [callback (lambda (b e) (send d show #f))])
+		(send mode set-selection (if smart? 0 1))
+		(send d center)
+		(send d show #t)))])
+      
+      ;; Extra controls ----------------------------------------
+      
+      (define (action! forward backward)
+	(set! playing? #t)
+	(set! future null)
+	(set! past (cons (cons forward backward) past))
+	(forward)
+	(check-auto-play)
+	(enable-buttons))
+
+      (define (backward!)
+	(let ([fb (car past)])
+	  (set! past (cdr past))
+	  (set! future (cons fb future))
+	  ((cdr fb))
+	  (enable-buttons)
+	  (send gui-board refresh)))
+
+      (define (forward!)
+	(let ([fb (car future)])
+	  (set! future (cdr future))
+	  (set! past (cons fb past))
+	  ((car fb))
+	  (enable-buttons)
+	  (send gui-board refresh)
+	  (check-auto-play)))
+
+      (define (reset!)
+	(for-each (lambda (p)
+		    (send gui-board remove-piece p))
+		  (send gui-board get-pieces))
+	(init-game!)
+	(send gui-board refresh)
+	(check-auto-play))
+
+      (define (set-turn! c)
+	(set! turn c)
+	(send msg set-label (format "~a's turn" (if (eq? turn 'red) "Red" "Yellow")))
+	(enable-for-turn! c)
+	(check-auto-play))
+
+      (define (enable-for-turn! who)
+	(for-each (lambda (p)
+		    (send gui-board enable-piece p (eq? who (piece-color (gui-piece-piece p)))))
+		  (send gui-board get-pieces)))
+
+      (define (set-winner! who)
+	(set! playing? #f)
+	(set! turn #f)
+	(send msg set-label (format "~a wins!" who))
+	(enable-for-turn! #f)
+	(check-auto-play))
+
+      (define (init-game!)
+	(set! board empty-board)
+	(set! past null)
+	(set! future null)
+	(set! playing? #f)
+	(enable-buttons)
+	(for-each gui-add-piece gui-pieces)
+	(set-turn! 'red))
+
+      ;; Auto-play ----------------------------------------
+
+      (define auto-play-key #f)
+      (define auto-play-custodian #f)
+
+      (define (check-auto-play)
+	(when auto-play-custodian
+	  (set! auto-play-key (gensym))
+	  (custodian-shutdown-all auto-play-custodian)
+	  (set! auto-play-custodian #f)
+	  (send auto-play-msg set-label "")
+	  (enable-for-turn! turn))
+	(when (and (null? future)
+		   turn
+		   (send (if (eq? turn 'red) auto-red auto-yellow) get-value))
+	  (let ([key (gensym)]
+		[board board]
+		[turn turn])
+	    (enable-for-turn! #f)
+	    (set! auto-play-key key)
+	    (set! auto-play-custodian (make-custodian))
+	    (parameterize ([current-custodian auto-play-custodian])
+	      (thread
+	       (lambda () 
+		 (let ([move (auto-play board turn)])
+		   (queue-callback
+		    (lambda ()
+		      (when (eq? auto-play-key key)
+			(auto-move board turn move))))))))
+	    (send auto-play-msg set-label 
+		  (format "   Auto-play thinking for ~a..."
+			  (if (eq? turn 'red) "Red" "Yellow"))))))
+      
+
+      (define (auto-play board turn)
+	(let ([search (make-search (if (= BOARD-SIZE 3)
+				       make-3x3-rate-board
+				       make-4x4-rate-board)
+				   (if (= BOARD-SIZE 3)
+				       (if smart?
+					   make-3x3-canned-moves
+					   make-3x3-no-canned-moves)
+				       make-4x4-canned-moves))])
+	  (search timeout ; timeout
+		  2 ; lookahead steps (non-exhaustive)
+		  3 ; single-step lookahead (exhaustive)
+		  turn board null)))
+
+      (define (auto-move board turn move)
+	(send auto-play-msg set-label "")
+	(let ([gp (let ([piece (list-ref move 0)]
+			[from-i (list-ref move 1)]
+			[from-j (list-ref move 2)])
+		    (ormap (lambda (gp)
+			     (and (eq? piece (gui-piece-piece gp))
+				  (if from-i
+				      (and (= from-i (gui-piece-i gp))
+					   (= from-j (gui-piece-j gp)))
+				      (not (<= 0 (gui-piece-i gp) (sub1 BOARD-SIZE))))
+				  gp))
+			   (send gui-board get-pieces)))]
+	      [to-i (list-ref move 3)]
+	      [to-j (list-ref move 4)])
+	  (let ([new-board (apply-play board move)])
+	    (install-board new-board gp to-i to-j))
+	  (send gui-board refresh)))
+	
+      ;; Go ----------------------------------------
+      
+      (init-game!)
+
+      (send f show #t))))
diff --git a/collects/games/gobblet/heuristics.ss b/collects/games/gobblet/heuristics.ss
new file mode 100644
index 0000000000..d5e8aad1bc
--- /dev/null
+++ b/collects/games/gobblet/heuristics.ss
@@ -0,0 +1,80 @@
+
+;; Supplies canned moves and board-rating functions for the state
+;; explorer.
+
+(module heuristics mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "etc.ss")
+	   (lib "list.ss")
+	   "sig.ss"
+	   "plays-3x3.ss")
+
+  (provide heuristics-unit)
+
+  (define heuristics-unit
+    (unit/sig heuristics^
+      (import config^ model^ explore^)
+
+      (define (make-3x3-canned-moves canonicalize init-memory)
+	;; Add known good plays to init-memory. These plays define
+	;; a perfect red player.
+	(for-each (lambda (play)
+		    (let ([key+xform (canonicalize (list->bytes (vector->list (car play))) #f)])
+		      (hash-table-put! init-memory
+				       (car key+xform)
+				       (let-values ([(from-i from-j)
+						     (if (list-ref play 2)
+							 (unapply-xform (cdr key+xform) (list-ref play 2))
+							 (values #f #f))]
+						    [(to-i to-j)
+						     (unapply-xform (cdr key+xform) (list-ref play 3))])
+					 (list
+					  (cons +inf.0
+						(make-plan
+						 (list-ref play 1)
+						 from-i from-j to-i to-j
+						 (cdr key+xform)
+						 (list-ref play 4))))))))
+		  3x3-plays)
+	(lambda (board me k xform)
+	  null))
+
+      (define (make-3x3-no-canned-moves canonicalize init-memory) 
+	(lambda (board me k xform)
+	  null))
+
+      (define (make-3x3-rate-board canon)
+	(lambda (board me to-i to-j)
+	  (+ (random)
+	     ;; Occupying the middle cell seems good
+	     (rate-cell board me 1 1))))
+
+      (define (make-4x4-canned-moves canon init-memory) 
+	(lambda (board me k xform)
+	  null))
+
+      (define (make-4x4-rate-board canon)
+	(lambda (board me to-i to-j)
+	  (+ (random) 
+	     (if (and (top-color? board to-i to-j (other me))
+		      (3-in-a-row? board to-i to-j (other me)))
+		 -10
+		 0)
+	     ;; Controlling the middle cells seems good
+	     (rate-cell board me 1 1)
+	     (rate-cell board me 1 2)
+	     (rate-cell board me 2 1)
+	     (rate-cell board me 2 2))))
+
+      (define (rate-cell board me i j)
+	(let ([l (board-ref board i j)])
+	  (if (pair? l)
+	      (if (eq? (piece-color (car l)) me)
+		  2
+		  -2)
+	      0)))
+
+      (define (top-color? board i j c)
+	(let ([l (board-ref board i j)])
+	  (and (pair? l)
+	       (eq? (piece-color (car l)) c)))))))
diff --git a/collects/games/gobblet/info.ss b/collects/games/gobblet/info.ss
new file mode 100644
index 0000000000..d6512211da
--- /dev/null
+++ b/collects/games/gobblet/info.ss
@@ -0,0 +1,5 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Gobblet")
+  (define doc.txt "doc.txt")
+  (define game "gobblet.ss")
+  (define game-set "Board Games"))
diff --git a/collects/games/gobblet/model.ss b/collects/games/gobblet/model.ss
new file mode 100644
index 0000000000..b56c9f9d63
--- /dev/null
+++ b/collects/games/gobblet/model.ss
@@ -0,0 +1,500 @@
+(module model mzscheme
+  (require "sig.ss"
+	   (lib "unitsig.ss"))
+
+  (provide model-unit)
+
+  ;; Most tests are in test-model.ss, but for better coverage,
+  ;; uncomment the tests below for unexported functions when running
+  ;; the test suite.
+  
+  (define model-unit
+    (unit/sig model^
+      (import config^)
+
+      (define JR? (= BOARD-SIZE 3))
+      (define SIZES (if (= BOARD-SIZE 3)
+			'(0 1 2)
+			'(0 1 2 3)))
+      (define PIECE-COUNT (sub1 BOARD-SIZE))
+      
+      ;; A piece is
+      ;;  (make-piece num sym hash-table)
+      ;;  where the sym is 'red or 'yellow
+      ;; 
+      ;; The hash table maps a stack without this
+      ;; piece to a stack with this piece on top.
+      (define-struct piece (size color gobble-table))  
+
+      (define red-pieces (map (lambda (sz) (make-piece sz 'red (make-hash-table))) SIZES))
+      (define yellow-pieces (map (lambda (sz) (make-piece sz 'yellow (make-hash-table))) SIZES))
+
+      ;; Fill in stacks for pieces. By building each possible
+      ;;  stack once, we avoid allocating redudant stacks, and
+      ;;  we get a value we can eq-hash for canonicalization.
+      (define all-stacks
+	(let loop ([red-pieces red-pieces]
+		   [yellow-pieces yellow-pieces]
+		   [prev-stacks (list null)])
+	  (if (null? red-pieces)
+	      ;; Return all unique stacks:
+	      prev-stacks
+	      ;; Add stacks to first pieces' tables:
+	      (loop (cdr red-pieces)
+		    (cdr yellow-pieces)
+		    (apply
+		     append
+		     prev-stacks
+		     (map (lambda (p)
+			    (map (lambda (stack)
+				   (let ([new-stack (cons p stack)])
+				     (hash-table-put! (piece-gobble-table p) stack new-stack)
+				     new-stack))
+				 prev-stacks))
+			  (list (car red-pieces)
+				(car yellow-pieces))))))))
+
+      ;; A board is a 
+      ;;  (vector (vector (list piece ...) ...) ...)
+
+      (define empty-board
+	(make-vector BOARD-SIZE (make-vector BOARD-SIZE null)))
+
+      ;; board-ref : board num num -> piece
+      (define (board-ref a i j)
+	(vector-ref (vector-ref a i) j))
+
+      ;; board-set : board num num piece -> board
+      (define (board-set a i j p)
+	;; We implement functional update by copying two vectors
+	;;  and modifying them.
+	(let ([a2 (copy-vector a)]
+	      [r2 (copy-vector (vector-ref a i))])
+	  (vector-set! a2 i r2)
+	  (vector-set! r2 j p)
+	  a2))
+      
+      ;; copy-vector : vector -> vector
+      (define (copy-vector v)
+	(list->vector (vector->list v)))
+
+      ;; Utilities ------------------------------
+
+      ;; fold-rowcol : (num alpha -> alpha) alpha -> alpha
+      (define (fold-rowcol f v)
+	(let iloop ([i 0][v v])
+	  (if (= i BOARD-SIZE)
+	      v
+	      (iloop (add1 i) (f i v)))))
+
+      ;; fold-board : (num num alpha -> alpha) alpha -> alpha
+      (define (fold-board f v)
+	(fold-rowcol (lambda (i v)
+		       (fold-rowcol (lambda (j v)
+				      (f i j v))
+				    v))
+		     v))
+
+      ;; other : sym -> sym
+      (define (other c)
+	(if (eq? c 'red) 'yellow 'red))
+      
+      ;; Model ------------------------------
+
+      ;; move : board piece num-or-#f num-or-#f num num (board -> alpha) (-> alpha)
+      ;;        -> alpha
+      ;; Given a board, piece, current location of the piece (or #f if
+      ;; not on the board), and target location for the piece, either
+      ;; allows the move and calls the continuation k with the new
+      ;; board, or disallows and calls the failure continuation.
+      ;; The given piece and its source must be correct and ok to move.
+      (define (move board p from-i from-j to-i to-j k fail-k)
+	(let ([pl (board-ref board to-i to-j)])
+	  ;; The move is allowed if the target space is empty or the
+	  ;;  top piece is smaller than this one:
+	  (if (or (null? pl)
+		  (and (< (piece-size (car pl)) (piece-size p))
+		       (or from-i
+			   JR?
+			   ;; In 4x4 game, can't move onto board on top
+			   ;;  of piece unless it's part of 3-in-a-row
+			   (and (not (eq? (piece-color (car pl)) (piece-color p)))
+				(3-in-a-row? board to-i to-j (piece-color (car pl)))))))
+	      ;; Allowed:
+	      (let ([new-board (if from-i
+				   ;; Remove the piece from the old spot:
+				   (board-set board from-i from-j 
+					      (cdr (board-ref board from-i from-j)))
+				   ;; Wasn't on the board, yet:
+				   board)])
+		;; Add the piece at its new spot, and continue
+		(k (board-set new-board to-i to-j (gobble p pl))))
+	      ;; Not allowed; fail
+	      (fail-k))))
+
+      ;; gobble : piece (listof piece) -> (listof piece)
+      (define (gobble p l)
+	(hash-table-get (piece-gobble-table p) l))
+
+      ;; - - - - - - - - - - - - - - - - - -
+      
+      ;; winner? : board sym -> bool
+      ;;  Checks whether the given color has BOARD-SIZE in a row
+      (define (winner? board c)
+	(or (n-in-a-diag? BOARD-SIZE board c backslash-diag-flip)
+	    (n-in-a-diag? BOARD-SIZE board c slash-diag-flip)
+	    ;; Rows and columns:
+	    (fold-rowcol (lambda (i v)
+			   (or v
+			       (and 
+				;; Before we count in all directions,
+				;;  check the target square.
+				(let ([pl (board-ref board i i)])
+				  (and (pair? pl)
+				       (eq? c (piece-color (car pl)))))
+				;; Target square matches, so on to expensive check
+				(n-in-a-row/col? BOARD-SIZE board i i c))))
+			 #f)))
+
+      ;; 3-in-a-row? : board num num color -> bool
+      (define (3-in-a-row? board i j c)
+	(or (n-in-a-row/col? 3 board i j c)
+	    (and (= i j)
+		 (n-in-a-diag? 3 board c backslash-diag-flip))
+	    (and (= i (- BOARD-SIZE 1 j))
+		 (n-in-a-diag? 3 board c slash-diag-flip))))
+
+      ;; n-in-a-row/col? : num board num num color -> bool
+      (define (n-in-a-row/col? n board i j c)
+	(let ([row/col?
+	       (lambda (board-ref)
+		 (= n
+		    (fold-rowcol (lambda (z v)
+				   (+ v
+				      (let ([pl (board-ref z)])
+					(if (and (pair? pl)
+						 (eq? c (piece-color (car pl))))
+					    1
+					    0))))
+				 0)))])
+	  (or (row/col? (lambda (z) (board-ref board i z)))
+	      (row/col? (lambda (z) (board-ref board z j))))))
+
+      ;; n-in-a-diag? : num board color (num -> num) -> bool
+      (define (n-in-a-diag? n board c flip)
+	(= n
+	   (fold-rowcol (lambda (i v)
+			  (+ v
+			     (let ([pl (board-ref board i (flip i))])
+			       (if (and (pair? pl)
+					(eq? c (piece-color (car pl))))
+				   1
+				   0))))
+			0)))
+      (define backslash-diag-flip (lambda (x) x))
+      (define slash-diag-flip (lambda (x) (- BOARD-SIZE 1 x)))
+
+      ;; Tests for unexported helpers:
+      #;
+      (let* ([one-red-board (move empty-board (car red-pieces) #f #f 0 0 values void)]
+	     [two-red-board (move (move one-red-board (car red-pieces) #f #f 0 2 values void)
+				  (car yellow-pieces) #f #f 2 2 values void)]
+	     [three-red-board (move two-red-board (cadr red-pieces) #f #f 1 1 values void)])
+	(define (test x y)
+	  (unless (equal? x y) 
+	    (error 'test "failure!: ~s ~s~n" x y)))
+	(test #f (n-in-a-row/col? 1 empty-board 0 0 'red))
+	(test #t (n-in-a-row/col? 1 one-red-board 0 0 'red))
+	(test #t (n-in-a-row/col? 2 two-red-board 0 0 'red))
+	(test #t (n-in-a-row/col? 1 two-red-board 2 2 'red))
+	(test #f (n-in-a-row/col? 2 two-red-board 2 2 'red))
+	(test #t (n-in-a-row/col? 2 two-red-board 0 1 'red))
+	(test #t (n-in-a-row/col? 1 three-red-board 0 1 'red))
+	(test #t (n-in-a-row/col? 2 three-red-board 0 1 'red))
+
+	(test #f (n-in-a-diag? 1 one-red-board 'red slash-diag-flip))
+	(test #t (n-in-a-diag? 1 one-red-board 'red backslash-diag-flip))
+	(test (= BOARD-SIZE 3) (n-in-a-diag? 1 two-red-board 'red slash-diag-flip))
+	(test #f (n-in-a-diag? 2 two-red-board 'red slash-diag-flip))
+	(test #t (n-in-a-diag? 1 two-red-board 'red backslash-diag-flip))
+	(test (= BOARD-SIZE 3) (n-in-a-diag? 2 three-red-board 'red slash-diag-flip))
+	(test #t (n-in-a-diag? 2 three-red-board 'red backslash-diag-flip)))
+
+      
+      ;; - - - - - - - - - - - - - - - - - -
+      
+      ;; available-off-board : board sym -> (list-of (list-of num))
+      ;;  Returns pieces available to move onto the board. The pieces
+      ;;  are grouped where moving one piece is disallowed or
+      ;;  not sensible until another piece (earlier in the same set)
+      ;;  has been moved onto the board.
+      (define (available-off-board board c)
+	(let ([counts (make-vector BOARD-SIZE 0)])
+	  (fold-board (lambda (i j v)
+			(for-each (lambda (p)
+				    (when (eq? c (piece-color p))
+				      (vector-set! counts (piece-size p)
+						   (add1 (vector-ref counts (piece-size p))))))
+				  (board-ref board i j)))
+		      (void))
+	  (reverse
+	   (if JR?
+	       ;; Can move any piece onto board
+	       (let loop ([counts (vector->list counts)][sizes SIZES])
+		 (cond
+		  [(null? counts) null]
+		  [((car counts) . < . PIECE-COUNT)
+		   (cons (vector->list (make-vector (- PIECE-COUNT (car counts))
+						    (car sizes)))
+			 (loop (cdr counts) (cdr sizes)))]
+		  [else (loop (cdr counts) (cdr sizes))]))
+	       ;; Can only move pieces that are not covered by others:
+	       (let-values ([(l cnt)
+			     (let loop ([counts (vector->list counts)][sizes SIZES])
+			       (cond
+				[(null? counts) (values null 0)]
+				[else (let-values ([(l cnt) (loop (cdr counts) (cdr sizes))])
+					(let ([gone (+ cnt (car counts))])
+					  (if (gone . < . PIECE-COUNT)
+					      (values (append (vector->list
+							       (make-vector
+								(- PIECE-COUNT gone)
+								(let sloop ([sz (car sizes)])
+								  (if (negative? sz)
+								      null
+								      (cons sz
+									    (sloop (sub1 sz)))))))
+							    l)
+						      (+ cnt (- PIECE-COUNT gone)))
+					      (values l cnt))))]))])
+		 l)))))
+
+      ;; Canonicalization of boards ------------------------------
+
+      ;; Xforms for finding canonical forms. Seven transforms
+      ;;  (including the identity) are equivalent. We generate
+      ;;  them all and hash when a new board is encountered.
+      (define xforms
+	(if (= BOARD-SIZE 3)
+	    '(#(0 1 2 3 4 5 6 7 8)
+	      #(0 3 6 1 4 7 2 5 8)
+	      #(2 5 8 1 4 7 0 3 6)
+	      #(8 5 2 7 4 1 6 3 0)
+	      #(6 3 0 7 4 1 8 5 2)
+	      #(2 1 0 5 4 3 8 7 6)
+	      #(8 7 6 5 4 3 2 1 0)
+	      #(6 7 8 3 4 5 0 1 2))
+	    '(#(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)
+	      #(0 4 8 12 1 5 9 13 2 6 10 14 3 7 11 15)
+	      #(12 13 14 15 8 9 10 11 4 5 6 7 0 1 2 3)
+	      #(3 2 1 0 7 6 5 4 11 10 9 8 15 14 13 12)
+	      #(15 11 7 3 14 10 6 2 13 9 5 1 12 8 4 0)
+	      #(12 8 4 0 13 9 5 1 14 10 6 2 15 11 7 3)
+	      #(15 14 13 12 11 10 9 8 7 6 5 4 3 2 1 0)
+	      #(3 7 11 15 2 6 10 14 1 5 9 13 0 4 8 12))))
+
+      ;; Procedure form of the above xforms, effectively
+      ;;  unrolloing a loop over the vector.
+      (define xform-procs
+	(if (= BOARD-SIZE 3)
+	    (list 
+	     (lambda (v) v)
+	     (lambda (v) (bytes (bytes-ref v 0) (bytes-ref v 3) (bytes-ref v 6)
+                                (bytes-ref v 1) (bytes-ref v 4)
+                                (bytes-ref v 7) (bytes-ref v 2) (bytes-ref v 5) (bytes-ref v 8)))
+	     (lambda (v) (bytes (bytes-ref v 2) (bytes-ref v 5) (bytes-ref v 8)
+                                (bytes-ref v 1) (bytes-ref v 4)
+                                (bytes-ref v 7) (bytes-ref v 0) (bytes-ref v 3) (bytes-ref v 6)))
+	     (lambda (v) (bytes (bytes-ref v 8) (bytes-ref v 5) (bytes-ref v 2)
+                                (bytes-ref v 7) (bytes-ref v 4)
+                                (bytes-ref v 1) (bytes-ref v 6) (bytes-ref v 3) (bytes-ref v 0)))
+	     (lambda (v) (bytes (bytes-ref v 6) (bytes-ref v 3) (bytes-ref v 0)
+                                (bytes-ref v 7) (bytes-ref v 4)
+                                (bytes-ref v 1) (bytes-ref v 8) (bytes-ref v 5) (bytes-ref v 2)))
+	     (lambda (v) (bytes (bytes-ref v 2) (bytes-ref v 1) (bytes-ref v 0)
+                                (bytes-ref v 5) (bytes-ref v 4)
+                                (bytes-ref v 3) (bytes-ref v 8) (bytes-ref v 7) (bytes-ref v 6)))
+	     (lambda (v) (bytes (bytes-ref v 8) (bytes-ref v 7) (bytes-ref v 6)
+                                (bytes-ref v 5) (bytes-ref v 4)
+                                (bytes-ref v 3) (bytes-ref v 2) (bytes-ref v 1) (bytes-ref v 0)))
+	     (lambda (v) (bytes (bytes-ref v 6) (bytes-ref v 7) (bytes-ref v 8)
+                                (bytes-ref v 3) (bytes-ref v 4)
+                                (bytes-ref v 5) (bytes-ref v 0) (bytes-ref v 1) (bytes-ref v 2))))
+	    (list
+	     (lambda (v) v)
+	     (lambda (v) (bytes (bytes-ref v 0) (bytes-ref v 4) (bytes-ref v 8)
+                                (bytes-ref v 12) (bytes-ref v 1)
+                                (bytes-ref v 5) (bytes-ref v 9) (bytes-ref v 13)
+                                (bytes-ref v 2) (bytes-ref v 6)
+                                (bytes-ref v 10) (bytes-ref v 14)
+                                (bytes-ref v 3) (bytes-ref v 7) (bytes-ref v 11)
+                                (bytes-ref v 15)))
+	     (lambda (v) (bytes (bytes-ref v 12) (bytes-ref v 13) (bytes-ref v 14)
+                                (bytes-ref v 15) (bytes-ref v 8) 
+                                (bytes-ref v 9) (bytes-ref v 10) (bytes-ref v 11)
+                                (bytes-ref v 4) (bytes-ref v 5)
+                                (bytes-ref v 6) (bytes-ref v 7)
+                                (bytes-ref v 0) (bytes-ref v 1) (bytes-ref v 2)
+                                (bytes-ref v 3)))
+	     (lambda (v) (bytes (bytes-ref v 3) (bytes-ref v 2) (bytes-ref v 1)
+                                (bytes-ref v 0) (bytes-ref v 7) 
+                                (bytes-ref v 6) (bytes-ref v 5) (bytes-ref v 4)
+                                (bytes-ref v 11) (bytes-ref v 10)
+                                (bytes-ref v 9) (bytes-ref v 8)
+                                (bytes-ref v 15) (bytes-ref v 14) (bytes-ref v 13)
+                                (bytes-ref v 12)))
+	     (lambda (v) (bytes (bytes-ref v 15) (bytes-ref v 11) (bytes-ref v 7)
+                                (bytes-ref v 3) (bytes-ref v 14)
+                                (bytes-ref v 10) (bytes-ref v 6) (bytes-ref v 2)
+                                (bytes-ref v 13) (bytes-ref v 9)
+                                (bytes-ref v 5) (bytes-ref v 1)
+                                (bytes-ref v 12) (bytes-ref v 8) (bytes-ref v 4)
+                                (bytes-ref v 0)))
+	     (lambda (v) (bytes (bytes-ref v 12) (bytes-ref v 8) (bytes-ref v 4)
+                                (bytes-ref v 0) (bytes-ref v 13) 
+                                (bytes-ref v 9) (bytes-ref v 5) (bytes-ref v 1)
+                                (bytes-ref v 14) (bytes-ref v 10)
+                                (bytes-ref v 6) (bytes-ref v 2) 
+                                (bytes-ref v 15) (bytes-ref v 11) (bytes-ref v 7)
+                                (bytes-ref v 3)))
+	     (lambda (v) (bytes (bytes-ref v 15) (bytes-ref v 14) (bytes-ref v 13)
+                                (bytes-ref v 12) (bytes-ref v 11)
+                                (bytes-ref v 10) (bytes-ref v 9) (bytes-ref v 8)
+                                (bytes-ref v 7) (bytes-ref v 6)
+                                (bytes-ref v 5) (bytes-ref v 4)
+                                (bytes-ref v 3) (bytes-ref v 2) (bytes-ref v 1)
+                                (bytes-ref v 0)))
+	     (lambda (v) (bytes (bytes-ref v 3) (bytes-ref v 7) (bytes-ref v 11)
+                                (bytes-ref v 15) (bytes-ref v 2)
+                                (bytes-ref v 6) (bytes-ref v 10) (bytes-ref v 14)
+                                (bytes-ref v 1) (bytes-ref v 5)
+                                (bytes-ref v 9) (bytes-ref v 13)
+                                (bytes-ref v 0) (bytes-ref v 4) (bytes-ref v 8)
+                                (bytes-ref v 12))))))
+
+      ;; Generates the compact representation of a board, which is
+      ;; good for hashing, but bad for applying moves
+      (define flatten-board
+	(if (= BOARD-SIZE 3)
+	    (lambda (board stack-ids)
+	      (bytes (hash-table-get stack-ids (board-ref board 0 0))
+                     (hash-table-get stack-ids (board-ref board 1 0))
+                     (hash-table-get stack-ids (board-ref board 2 0))
+                     (hash-table-get stack-ids (board-ref board 0 1))
+                     (hash-table-get stack-ids (board-ref board 1 1))
+                     (hash-table-get stack-ids (board-ref board 2 1))
+                     (hash-table-get stack-ids (board-ref board 0 2))
+                     (hash-table-get stack-ids (board-ref board 1 2))
+                     (hash-table-get stack-ids (board-ref board 2 2))))
+	    (lambda (board stack-ids)
+	      (bytes (hash-table-get stack-ids (board-ref board 0 0))
+                     (hash-table-get stack-ids (board-ref board 1 0))
+                     (hash-table-get stack-ids (board-ref board 2 0))
+                     (hash-table-get stack-ids (board-ref board 3 0))
+                     (hash-table-get stack-ids (board-ref board 0 1))
+                     (hash-table-get stack-ids (board-ref board 1 1))
+                     (hash-table-get stack-ids (board-ref board 2 1))
+                     (hash-table-get stack-ids (board-ref board 3 1))
+                     (hash-table-get stack-ids (board-ref board 0 2))
+                     (hash-table-get stack-ids (board-ref board 1 2))
+                     (hash-table-get stack-ids (board-ref board 2 2))
+                     (hash-table-get stack-ids (board-ref board 3 2))
+                     (hash-table-get stack-ids (board-ref board 0 3))
+                     (hash-table-get stack-ids (board-ref board 1 3))
+                     (hash-table-get stack-ids (board-ref board 2 3))
+                     (hash-table-get stack-ids (board-ref board 3 3))))))
+
+
+      ;; Generate a numerical ID for each stack. This numerical
+      ;;  ID must stay constant for all of time, because we
+      ;;  record boards in compact form using these numbers.
+      ;;  (For example, see "plays-3x3.ss".)
+      (define red-stack-ids (make-hash-table))
+      (define yellow-stack-ids (make-hash-table))
+      (for-each (lambda (s)
+		  (hash-table-put! red-stack-ids s (hash-table-count red-stack-ids)))
+		all-stacks)
+      (for-each (lambda (s)
+		  (let ([inverse 
+                         (let loop ([s s])
+                           (if (null? s)
+                               null
+                               (hash-table-get (piece-gobble-table
+                                                (if (eq? (piece-color (car s)) 'red)
+                                                    (list-ref yellow-pieces (piece-size (car s)))
+                                                    (list-ref red-pieces (piece-size (car s)))))
+                                               (loop (cdr s)))))])
+		    (hash-table-put! yellow-stack-ids s (hash-table-get red-stack-ids inverse))))
+		all-stacks)
+
+      ;; Applies an appropriate flattener
+      (define (compact-board board who)
+	(flatten-board board
+		       (if (eq? who 'red) red-stack-ids yellow-stack-ids)))
+
+      ;; make-canonicalize : -> (union (board sym -> (cons compact xform))
+      ;;                               (compact #f -> (cons compact xform)))
+      ;;  The resulting procedure embeds a table for mapping a compact
+      ;;  board to its canonical compact board. The result includes an
+      ;;  xform for getting from the given board's locations to
+      ;;  locations in the canonical board.
+      (define (make-canonicalize)
+	(let ([memory (make-hash-table 'equal)])
+	  ;; Convert the board into a byte string, normalizing player:
+	  (lambda (board who)
+	    (let ([v (if who
+			 (compact-board board who)
+			 board)])
+	      ;; Find cannonical mapping.	      
+	      (hash-table-get 
+               memory v
+               (lambda ()
+                 (let* ([pr (cons v (car xforms))])
+                   (hash-table-put! memory v pr)
+                   ;; Add each equivalent to table:
+                   (for-each (lambda (xform xform-proc)
+                               (hash-table-put! memory (xform-proc v) (cons v xform)))
+                             (cdr xforms) (cdr xform-procs))
+                   pr)))))))
+      
+      ;; apply-xform : xform num num -> num
+      ;;  Returns a position in a canonical board
+      (define (apply-xform xform i j)
+	(vector-ref xform (+ (* j BOARD-SIZE) i)))
+      ;; unapply-xform : xform num -> (values num num)
+      ;;  Maps a canonical-board position to a position in
+      ;;  a specific board.
+      (define (unapply-xform xform v)
+	(let loop ([i 0])
+	  (if (= (vector-ref xform i) v)
+	      (values (modulo i BOARD-SIZE) (quotient i BOARD-SIZE))
+	      (loop (add1 i)))))
+
+      ;; Printing boards ------------------------------
+
+      ;; helper
+      (define (board->string depth b)
+	(let jloop ([j 0])
+	  (if (= j BOARD-SIZE)
+	      ""
+	      (string-append
+	       (make-string depth #\space)
+	       (let iloop ([i 0])
+		 (if (= i BOARD-SIZE)
+		     ""
+		     (string-append (stack->string (board-ref b i j))
+				    " "
+				    (iloop (add1 i)))))
+	       "\n"
+	       (jloop (add1 j))))))
+      
+      (define (stack->string s)
+	(let ([s (apply string-append 
+			"...."
+			(map (lambda (p)
+			       (list-ref (if (eq? 'red (piece-color p))
+					     '("_" "i" "I" "|")
+					     '("=" "o" "O" "0"))
+					 (piece-size p)))
+			     s))])
+	  (substring s (- (string-length s) BOARD-SIZE)))))))
diff --git a/collects/games/gobblet/plays-3x3.ss b/collects/games/gobblet/plays-3x3.ss
new file mode 100644
index 0000000000..640f559680
--- /dev/null
+++ b/collects/games/gobblet/plays-3x3.ss
@@ -0,0 +1,80 @@
+(module plays-3x3 mzscheme
+  (provide 3x3-plays)
+  (define 3x3-plays
+    ;; This list is generated by "check.ss".
+    ;; Generate it only when red knows how to win
+    ;; from all boards.
+    '((#9(15 0 0 21 9 0 0 0 18) 1 #f 6 2)
+      (#9(15 0 0 21 9 0 0 0 6) 1 #f 1 3)
+      (#9(0) 2 #f 4 8)
+      (#9(0 1 0 6 9 21 0 18 0) 2 #f 0 2)
+      (#9(0 1 21 8 9 15 0 18 0) 1 #f 0 2)
+      (#9(15 21 0 21 9 0 0 0 6) 0 #f 2 2)
+      (#9(23 18 0 0 9 0 0 9 0) 1 #f 2 2)
+      (#9(9 18 3 9 0 0 18 0) 2 0 5 2)
+      (#9(0 0 18 0 9 0 15 0) 1 #f 1 3)
+      (#9(0 7 0 0 9 21 0) 2 #f 1 4)
+      (#9(0 0 3 9 9 18 18 0) 2 4 0 3)
+      (#9(0 0 15 0 18 0 15 19 0) 1 #f 1 2)
+      (#9(0 16 0 6 9 21 0 18 0) 1 #f 0 2)
+      (#9(0 0 0 15 18 15 0 0 21) 1 #f 0 2)
+      (#9(6 0 0 3 9 18 0) 2 #f 0 2)
+      (#9(18 0 0 6 9 15 0) 2 4 3 4)
+      (#9(0 0 6 18 9 0 15 0) 0 #f 7 4)
+      (#9(0 0 21 9 9 18 0) 1 #f 8 2)
+      (#9(0 19 21 8 9 15 0) 1 #f 0 2)
+      (#9(0 0 0 18 9 15 21 0) 1 #f 0 2)
+      (#9(21 0 0 9 9 18 0) 1 #f 6 2)
+      (#9(0 0 21 20 9 15 0 0 7) 0 #f 0 2)
+      (#9(0 0 6 18 9 0 15 19 0) 2 4 2 3)
+      (#9(0 0 18 18 9 15 3 0) 1 6 8 3)
+      (#9(0 16 0 0 9 21 0 18 0) 1 #f 0 2)
+      (#9(9 0 21 9 0 0 18 0) 1 #f 4 2)
+      (#9(2 0 0 0 9 0) 2 #f 7 6)
+      (#9(21 0 9 0 9 0 18 0) 1 #f 3 2)
+      (#9(18 0 0 9 9 6 0) 2 3 5 5)
+      (#9(19 16 0 0 9 21 0 6 0) 1 #f 2 2)
+      (#9(0 0 0 18 9 15 0 0 21) 1 #f 2 2)
+      (#9(0 0 0 15 18 15 0) 1 #f 2 3)
+      (#9(6 0 0 21 9 0) 2 #f 0 4)
+      (#9(0 0 0 6 9 0) 1 #f 5 6)
+      (#9(0 0 21 20 9 15 0 6 0) 0 #f 8 3)
+      (#9(0 0 18 18 9 0 15 0) 1 #f 1 3)
+      (#9(0 0 21 20 9 15 0) 0 #f 8 3)
+      (#9(0 0 9 18 9 0 6 0) 2 2 6 5)
+      (#9(0 3 18 0 9 0 15 18 0) 1 #f 0 2)
+      (#9(0 0 21 11 9 18 0 6 0) 1 #f 8 2)
+      (#9(0 9 0 2 9 0 0 18 0) 1 #f 2 3)
+      (#9(0 0 0 18 9 15 0) 1 #f 2 3)
+      (#9(0 0 0 6 9 21 0) 0 #f 1 5)
+      (#9(0 9 21 2 9 0 0 18 0) 1 #f 0 2)
+      (#9(0 16 0 0 9 21 0 6 0) 0 #f 0 3)
+      (#9(0 0 0 9 9 18 0) 1 #f 0 3)
+      (#9(0 9 21 2 9 0 0 6 0) 2 1 3 5)
+      (#9(0 19 0 6 9 21 0) 1 #f 0 2)
+      (#9(0 0 9 18 9 0 18 0) 1 #f 0 3)
+      (#9(0 0 9 0 9 0 18 0) 2 2 7 6)
+      (#9(0 0 21 8 9 15 0) 0 #f 1 3)
+      (#9(0 21 18 0 9 0 15 0) 1 #f 0 2)
+      (#9(0 7 0 6 9 21 0) 2 #f 1 4)
+      (#9(2 18 0 0 9 0 0 9 0) 1 #f 0 3)
+      (#9(23 6 0 0 9 0 0 9 0) 2 7 1 4)
+      (#9(18 0 0 18 9 15 0) 1 #f 6 4)
+      (#9(0 0 0 2 9 0) 2 #f 1 7)
+      (#9(0 0 21 11 9 6 0 6 0) 2 3 5 4)
+      (#9(0 0 6 0 9 0 15 19 0) 2 4 2 3)
+      (#9(0 0 21 11 9 6 0) 2 3 5 4)
+      (#9(0 9 0 2 9 0 0 6 0) 1 #f 2 6)
+      (#9(0 0 0 24 9 3 0) 2 #f 2 2)
+      (#9(5 6 0 0 9 0 0 9 18) 2 4 1 2)
+      (#9(0 0 18 15 18 15 0 0 3) 1 #f 6 2)
+      (#9(23 15 0 0 18 0 0 15 0) 1 #f 8 2)
+      (#9(18 0 0 0 9 0) 2 #f 3 6)
+      (#9(18 0 0 15 18 15 0) 1 #f 8 3)
+      (#9(0 0 0 18 9 0) 2 #f 2 7)
+      (#9(2 6 0 0 9 0 0 9 0) 1 #f 0 5)
+      (#9(23 15 0 0 9 0 0 18 0) 1 #f 2 2)
+      (#9(6 0 0 0 9 0) 1 #f 3 5)
+      (#9(5 18 0 0 9 0 0 9 18) 2 7 3 2)
+      (#9(18 0 0 9 9 18 0) 1 #f 2 4)
+      (#9(23 15 0 0 9 0 0 6 0) 2 4 7 3))))
diff --git a/collects/games/gobblet/robot.ss b/collects/games/gobblet/robot.ss
new file mode 100644
index 0000000000..a22655f9bc
--- /dev/null
+++ b/collects/games/gobblet/robot.ss
@@ -0,0 +1,76 @@
+
+;; Plays automatic games, often useful when learning is enabled in explore.ss
+
+(module robot mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "etc.ss")
+	   (lib "list.ss")
+	   "sig.ss"
+	   "model.ss"
+	   "explore.ss"
+	   "heuristics.ss")
+
+  (define board-size 3)
+  (define steps 2)
+  (define depth 3)
+
+  (define timeout 3.0)
+  (define cannon-size +inf.0)
+
+  (invoke-unit/sig
+   (compound-unit/sig
+    (import)
+    (link
+     [CONFIG : config^ ((unit/sig config^
+			  (import)
+			  (define BOARD-SIZE board-size)))]
+     [MODEL : model^ (model-unit CONFIG)]
+     [HEURISTICS : heuristics^ (heuristics-unit CONFIG MODEL EXPLORE)]
+     [EXPLORE : explore^ (explore-unit CONFIG MODEL)]
+     [ROBOT : () ((unit/sig ()
+		    (import config^ explore^ model^ heuristics^)
+
+		    (define init-board 
+		      empty-board
+		      #;
+		      (move empty-board 
+			    (list-ref red-pieces 2) #f #f 0 0
+			    (lambda (b)
+			      (move b
+				    (list-ref yellow-pieces 2) #f #f 0 1
+				    (lambda (b) b)
+				    void))
+			    void))
+		    (define init-who 'red)
+
+		    ;; Play-a-game test
+		    (let go ()
+		      (sleep 1)
+		      ;; (random-seed 12)
+		      (let loop ([board init-board]
+				 [who init-who]
+				 [who-moved "no one"]
+				 [history null])
+			(cond
+			 [(winner? board who)
+			  (printf "----------- ~a wins!-------------~n~a~n" who (board->string 1 board))
+			  (go)]
+			 [(winner? board (other who))
+			  (printf "----------- ~a wins!-------------~n~a~n" (other who) (board->string 1 board))
+			  (go)]
+			 [else
+			  (printf "~n~a moved; ~a's turn~n~a~n" who-moved who (board->string 1 board))
+			  (let ([start (current-inexact-milliseconds)]
+				[m ((make-search (if (= BOARD-SIZE 3)
+						     make-3x3-rate-board
+						     make-4x4-rate-board)
+						 (if (= BOARD-SIZE 3)
+						     make-3x3-no-canned-moves
+						     make-4x4-canned-moves)) 
+				    timeout steps depth
+				    who board history)])
+			    (printf "[~a secs]~n" (/ (- (current-inexact-milliseconds) start)
+						     1000.0))
+			    (loop (apply-play board m) (other who) who (cons board history)))]))))
+		  CONFIG EXPLORE MODEL HEURISTICS)])
+    (export))))
diff --git a/collects/games/gobblet/sig.ss b/collects/games/gobblet/sig.ss
new file mode 100644
index 0000000000..965eb2987f
--- /dev/null
+++ b/collects/games/gobblet/sig.ss
@@ -0,0 +1,43 @@
+(module sig mzscheme
+  (require (lib "unitsig.ss"))
+
+  (provide config^ 
+	   heuristics^ explore^
+	   model^ restart^)
+
+  (define-signature config^
+    (BOARD-SIZE))
+
+  (define-signature heuristics^
+    (make-3x3-rate-board
+     make-3x3-canned-moves
+     make-3x3-no-canned-moves
+     make-4x4-rate-board
+     make-4x4-canned-moves))
+
+  (define-signature explore^
+    (make-search 
+     apply-play ; a play is (list piece from-i from-j to-i to-j)
+     (struct plan (size from-i from-j to-i to-j xform))))
+
+  (define-signature model^
+    (move 
+     winner? 3-in-a-row?
+     red-pieces yellow-pieces
+     piece-color piece-size
+     empty-board
+     board-ref
+     fold-board 
+     fold-rowcol 
+     other
+     available-off-board
+     compact-board
+     make-canonicalize
+     apply-xform unapply-xform
+     board->string))
+
+  (define-signature restart^
+    (new-game
+     show-gobblet-help)))
+
+
diff --git a/collects/games/gobblet/test-explore.ss b/collects/games/gobblet/test-explore.ss
new file mode 100644
index 0000000000..127d511b8a
--- /dev/null
+++ b/collects/games/gobblet/test-explore.ss
@@ -0,0 +1,77 @@
+
+(module test-explore mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "etc.ss")
+	   (lib "list.ss")
+	   "sig.ss"
+	   "model.ss"
+	   "explore.ss"
+	   "heuristics.ss")
+
+  (define board-size 3)
+
+  (invoke-unit/sig
+   (compound-unit/sig
+    (import)
+    (link
+     [CONFIG : config^ ((unit/sig config^
+			  (import)
+			  (define BOARD-SIZE board-size)))]
+     [MODEL : model^ (model-unit CONFIG)]
+     [HEURISTICS : heuristics^ (heuristics-unit CONFIG MODEL EXPLORE)]
+     [EXPLORE : explore^ (explore-unit CONFIG MODEL)]
+     [ROBOT : () 
+            ((unit/sig ()
+               (import config^ explore^ model^ heuristics^)
+               
+               (define (mv b p fi fj ti tj k)
+                 (move b p fi fj ti tj k void))
+               
+               (define big (sub1 BOARD-SIZE))
+               (define med (- BOARD-SIZE 2))
+               
+               (define 3x3-one-step-win
+                 ;; One-step win
+                 (mv empty-board (list-ref red-pieces big) #f #f 0 0
+                     (lambda (board)
+                       (mv board (list-ref red-pieces big) #f #f 1 1
+                           values))))
+               
+               (define 3x3-two-step-win
+                 (mv empty-board (list-ref red-pieces big) #f #f 0 0
+                     (lambda (board)
+                       (mv board (list-ref yellow-pieces big) #f #f 1 0
+                           (lambda (board)
+                             (mv board (list-ref red-pieces big) #f #f 1 1
+                                 (lambda (board)
+                                   (mv board (list-ref yellow-pieces big) 1 0 2 2
+                                       (lambda (board)
+                                         (mv board (list-ref red-pieces med) #f #f 1 0
+                                             (lambda (board)
+                                               (mv board (list-ref yellow-pieces big) #f #f 1 0
+                                                   values))))))))))))
+               
+               (define (test-search depth board who history)
+                 ((make-search (if (= BOARD-SIZE 3)
+                                   make-3x3-rate-board
+                                   make-4x4-rate-board)
+                               (if (= BOARD-SIZE 3)
+                                   make-3x3-no-canned-moves
+                                   make-4x4-canned-moves)) 
+                  +inf.0 1 
+                  depth ; depth
+                  who board history))
+               
+               (when (= BOARD-SIZE 3)
+                 (test-search 1 3x3-one-step-win 'red null)
+                 (test-search 3 3x3-one-step-win 'red null)
+                 (test-search 3 3x3-two-step-win 'red null))
+               
+               ;; Time test
+               (let ([start (current-inexact-milliseconds)]
+                     [m (test-search 5 empty-board 'red null)])
+                 (printf "[~a secs]~n" (/ (- (current-inexact-milliseconds) start)
+                                          1000.0))
+                 ))
+             CONFIG EXPLORE MODEL HEURISTICS)])
+    (export))))
diff --git a/collects/games/gobblet/test-model.ss b/collects/games/gobblet/test-model.ss
new file mode 100644
index 0000000000..06cc93efa6
--- /dev/null
+++ b/collects/games/gobblet/test-model.ss
@@ -0,0 +1,413 @@
+
+;; Some tests for the model
+
+(module test-model mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "etc.ss")
+	   (lib "list.ss")
+	   "sig.ss"
+	   "model.ss"
+	   "test.ss")
+
+  ;; Test basic procs:
+  (define (test-folding n)
+    (begin-with-definitions
+     (define BOARD-SIZE n)
+     (define-values/invoke-unit/sig model^
+       model-unit #f config^)
+     (test 'red (other 'yellow))
+     (test 'yellow (other 'red))
+     (test (if (= n 3)
+	       '(0 1 2)
+	       '(0 1 2 3))
+	   (mergesort (fold-rowcol (lambda (i v) (cons i v)) null)
+		      <))
+     (test (if (= n 3)
+	       '((0 . 0) (0 . 1) (0 . 2)
+		 (1 . 0) (1 . 1) (1 . 2)
+		 (2 . 0) (2 . 1) (2 . 2))
+	       '((0 . 0) (0 . 1) (0 . 2) (0 . 3)
+		 (1 . 0) (1 . 1) (1 . 2) (1 . 3)
+		 (2 . 0) (2 . 1) (2 . 2) (2 . 3)
+		 (3 . 0) (3 . 1) (3 . 2) (3 . 3)))
+	   (mergesort (fold-board (lambda (i j v) (cons (cons i j) v)) null)
+		      (lambda (a b)
+			(if (= (car a) (car b))
+			    (< (cdr a) (cdr b))
+			    (< (car a) (car b))))))))
+  (test-folding 3)
+  (test-folding 4)
+
+  ;; Test available-off-board for 3x3:
+  (let ()
+    (begin-with-definitions
+     (define BOARD-SIZE 3)
+     (define-values/invoke-unit/sig model^
+       model-unit #f config^)
+     (test '((2 2) (1 1) (0 0)) (available-off-board empty-board 'red))
+     (test '((2 2) (1 1) (0)) (available-off-board 
+                               (move empty-board (list-ref red-pieces 0) #f #f 1 1 values void)
+                               'red))
+     (let ([b2 (move empty-board (list-ref red-pieces 2) #f #f 1 1 values void)])
+       (test '((2) (1 1) (0 0)) (available-off-board b2 'red))
+       (let ([b3 (move b2 (list-ref yellow-pieces 1) #f #f 2 2 values void)])
+	 (test '((2) (1 1) (0 0)) (available-off-board b3 'red))
+	 (test '((2 2) (1) (0 0)) (available-off-board b3 'yellow))
+	 (let ([b4 (move b3 (list-ref red-pieces 2) #f #f 0 1 values void)])
+	   (test '((1 1) (0 0)) (available-off-board b4 'red))
+	   (test '((2 2) (1) (0 0)) (available-off-board b4 'yellow)))))))
+
+  ;; Test available-off-board for 4x4:
+  (let ()
+    (begin-with-definitions
+     (define BOARD-SIZE 4)
+     (define-values/invoke-unit/sig model^
+       model-unit #f config^)
+     (test '((3 2 1 0) (3 2 1 0) (3 2 1 0)) (available-off-board empty-board 'red))
+     (let ([b2 (move empty-board (list-ref red-pieces 3) #f #f 1 1 values void)])
+       (test '((3 2 1 0) (3 2 1 0) (2 1 0)) (available-off-board b2 'red))
+       (let ([b3 (move b2 (list-ref yellow-pieces 3) #f #f 2 2 values void)])
+	 (test '((3 2 1 0) (3 2 1 0) (2 1 0)) (available-off-board b3 'red))
+	 (test '((3 2 1 0) (3 2 1 0) (2 1 0)) (available-off-board b3 'yellow))
+	 (let ([b4 (move b3 (list-ref red-pieces 3) #f #f 0 1 values void)])
+	   (test '((3 2 1 0) (2 1 0) (2 1 0)) (available-off-board b4 'red))
+	   (let ([b5 (move b4 (list-ref red-pieces 2) #f #f 0 3 values void)])
+	     (test '((3 2 1 0) (2 1 0) (1 0)) (available-off-board b5 'red)))
+	   (let ([b5 (move b4 (list-ref red-pieces 3) #f #f 0 3 values void)])
+	     (test '((2 1 0) (2 1 0) (2 1 0)) (available-off-board b5 'red))))
+	 (let ([b4 (move b3 (list-ref red-pieces 2) #f #f 0 1 values void)])
+	   (test '((3 2 1 0) (3 2 1 0) (1 0)) (available-off-board b4 'red))
+	   (let ([b5 (move b4 (list-ref red-pieces 3) #f #f 0 3 values void)])
+	     (test '((3 2 1 0) (2 1 0) (1 0)) (available-off-board b5 'red))
+	     (let ([b6 (move b5 (list-ref red-pieces 2) #f #f 3 3 values void)])
+	       (test '((3 2 1 0) (1 0) (1 0)) (available-off-board b6 'red)))))))))
+
+  (define x-table (make-hash-table 'equal))
+  (define (testx id board)
+    (test id (hash-table-get x-table board
+			     (lambda ()
+			       (when (hash-table-get x-table id (lambda () #f))
+				 (error 'testx "id already mapped\n"))
+			       (hash-table-put! x-table id #t)
+			       (hash-table-put! x-table board id)
+			       id))))
+
+  ;; Given a canonicalize function, a board, the current player,
+  ;;  and the model exports, check that the canonicalizer works
+  ;;  on the board.
+  (define (canon-test BOARD-SIZE canonicalize board who 
+		      fold-board board-ref move empty-board
+		      yellow-pieces red-pieces piece-color piece-size other
+		      apply-xform unapply-xform)
+    (define (flip-stack stack)
+      (map (lambda (p)
+	     (if (eq? (piece-color p) 'red)
+		 (list-ref yellow-pieces (piece-size p))
+		 (list-ref red-pieces (piece-size p))))
+	   stack))
+    (define (board-xform board ijx flip-stack)
+      (fold-board
+       (lambda (i j b)
+	 (let ([stack (board-ref board i j)])
+	   (let loop ([stack (flip-stack stack)])
+	     (if (null? stack)
+		 b
+		 (let-values ([(i j) (ijx i j)])
+		   (move (loop (cdr stack))
+			 (car stack)
+			 #f #f
+			 i j
+			 values void))))))
+       empty-board))
+    (let* ([key+xform (canonicalize board who)]
+	   ;; flip vert
+	   [board2 (board-xform board (lambda (i j)
+					(values i (- BOARD-SIZE 1 j)))
+				values)]
+	   [key2+xform2 (canonicalize board2 who)]
+	   ;; flip horiz
+	   [board3 (board-xform board (lambda (i j)
+					(values (- BOARD-SIZE 1 i) j))
+				values)]
+	   [key3+xform3 (canonicalize board3 who)]
+	   ;; flip colors
+	   [board4 (board-xform board (lambda (i j) (values i j))
+				flip-stack)]
+	   [key4+xform4 (canonicalize board4 (other who))])
+      ;; Canoncal key should be the same for all boards:
+      (test (car key+xform) (car key2+xform2))
+      (test (car key+xform) (car key3+xform3))
+      (test (car key+xform) (car key4+xform4))
+      ;; Xforming coordinates should produce the same thing for each board:
+      (fold-board (lambda (i j v)
+		    (let ([pos (apply-xform (cdr key+xform) i j)]
+			  [s (board-ref board i j)])
+		      (let-values ([(i j) (unapply-xform (cdr key2+xform2) pos)])
+			(test s (board-ref board2 i j))
+			(test pos (apply-xform (cdr key2+xform2) i j)))
+		      (let-values ([(i j) (unapply-xform (cdr key3+xform3) pos)])
+			(test s (board-ref board3 i j))
+			(test pos (apply-xform (cdr key3+xform3) i j)))
+		      (let-values ([(i j) (unapply-xform (cdr key4+xform4) pos)])
+			(test (flip-stack s) (board-ref board4 i j))
+			(test pos (apply-xform (cdr key4+xform4) i j)))))
+		  (void))
+      (car key+xform)))
+  
+  ;; Test canonicalization, 3x3
+  (begin-with-definitions
+   (define BOARD-SIZE 3)
+   (define-values/invoke-unit/sig model^
+     model-unit #f config^)
+   (let ([c (let ([canonicalize (make-canonicalize)])
+	      (lambda (b who)
+		(canon-test 3 canonicalize b who 
+			    fold-board board-ref move empty-board
+			    yellow-pieces red-pieces piece-color piece-size other
+			    apply-xform unapply-xform)))])
+     (testx 0 (c empty-board 'red))
+     (testx 0 (c empty-board 'yellow))
+     (let ([b1 (move empty-board (list-ref red-pieces 2) #f #f 1 1 values void)])
+       (testx 1 (c b1 'red))
+       (testx 2 (c b1 'yellow))
+       (testx 1 (c b1 'red))
+       (let ([b2 (move b1 (list-ref red-pieces 2) #f #f 2 2 values void)])
+	 (testx 3 (c b2 'red))
+	 (testx 7 (c b2 'yellow)))
+       (let ([b2 (move b1 (list-ref red-pieces 2) #f #f 0 0 values void)])
+	 (testx 3 (c b2 'red))
+	 (testx 7 (c b2 'yellow))
+	 (let ([b3 (move b2 (list-ref yellow-pieces 1) #f #f 1 0 values void)])
+	   (testx 11 (c b3 'red))
+	   (testx 19 (c b3 'yellow))
+	   (let ([b4 (move b3 (list-ref red-pieces 2) #f #f 1 0 values void)])
+	     (testx 27 (c b4 'red))
+	     (testx 35 (c b4 'yellow))
+	     (let ([b5 (move b4 (list-ref red-pieces 2) 0 0 2 0 values void)])
+	       (testx 27 (c b5 'red))
+	       (testx 35 (c b5 'yellow)))))))))
+
+  (set! x-table (make-hash-table 'equal))
+
+  ;; Test canonicalization, 4x4
+  (begin-with-definitions
+   (define BOARD-SIZE 4)
+   (define-values/invoke-unit/sig model^
+     model-unit #f config^)
+   (let ([c (let ([canonicalize (make-canonicalize)])
+	      (lambda (b who)		
+		(canon-test 4 canonicalize b who 
+			    fold-board board-ref move empty-board
+			    yellow-pieces red-pieces piece-color piece-size other
+			    apply-xform unapply-xform)))])
+     (testx 0 (c empty-board 'red))
+     (testx 0 (c empty-board 'yellow))
+     (let ([b1 (move empty-board (list-ref red-pieces 0) #f #f 1 1 values void)])
+       (testx 1 (c b1 'red))
+       (testx 5 (c b1 'yellow))
+       (testx 1 (c b1 'red))
+       (let ([b1.1 (move b1 (list-ref red-pieces 0) #f #f 2 2 values void)])
+	 (let ([b2 (move b1.1 (list-ref red-pieces 2) #f #f 3 3 values void)])
+	   (testx 9 (c b2 'red))
+	   (testx 13 (c b2 'yellow)))
+	 (let ([b2 (move b1.1 (list-ref red-pieces 2) #f #f 0 0 values void)])
+	   (testx 9 (c b2 'red))
+	   (testx 13 (c b2 'yellow))
+	   (let ([b3 (move b2 (list-ref yellow-pieces 1) #f #f 1 0 values void)])
+	     (testx 17 (c b3 'red))
+	     (testx 25 (c b3 'yellow))))))))
+
+  (define (basic-tests size xform 4x4-finish-pos)
+    ;; When xform is the identity, then we build toward
+    ;;  _ _ Y -    _ = empty
+    ;;  _ Y _ -    - = optional (3x3 vs 4x4)
+    ;;  y R R -
+    ;;  - - - -
+    ;; The xform changes the cooridnate system so that we
+    ;; test rows and columns in addition to this diagonal.
+    (begin-with-definitions
+     (define BOARD-SIZE size)
+
+     (define-values (i00 j00) (xform 0 0))
+     (define-values (i11 j11) (xform 1 1))
+     (define-values (i22 j22) (xform 2 2))
+     (define-values (i12 j12) (xform 1 2))
+     (define-values (i02 j02) (xform 0 2))
+     (define-values (i20 j20) (xform 2 0))
+
+     (define-values/invoke-unit/sig model^
+       model-unit #f config^)
+
+     ;; Empty board --------------------
+     (define b empty-board)
+
+     (test null (board-ref b i00 j00))
+     (test null (board-ref b i22 j22))
+
+     (test #f (winner? b 'red))
+     (test #f (winner? b 'yellow))
+
+     (define big-red (list-ref red-pieces 2))
+     (define big-yellow (list-ref yellow-pieces 2))
+     (define med-red (list-ref red-pieces 1))
+     (define med-yellow (list-ref yellow-pieces 1))
+     (define small-yellow (list-ref yellow-pieces 0))
+
+     ;; Big red --------------------
+
+     (define b1 (move b big-red #f #f i00 j00 values void))
+     (test (list big-red) (board-ref b1 i00 j00))
+     (test (void) (move b1 big-yellow #f #f i00 j00 values void))
+
+     (test #f (winner? b1 'red))
+     (test #f (winner? b1 'yellow))
+
+     ;; Big red, big yellow --------------------
+
+     (define b2 (move b1 big-yellow #f #f i11 j11 values void))
+     (test (list big-red) (board-ref b2 i00 j00))
+     (test (list big-yellow) (board-ref b2 i11 j11))
+
+     (test #f (winner? b2 'red))
+     (test #f (winner? b2 'yellow))
+
+     (test (void) (move b2 big-red #f #f i11 j11 values void))
+     (test (void) (move b2 big-red i00 j00 i11 j11 values void))
+
+     ;; Big red moved, big yellow --------------------
+
+     (define b3 (move b2 big-red i00 j00 i22 j22 values void))
+     (test null (board-ref b3 i00 j00))
+     (test (list big-yellow) (board-ref b3 i11 j11))
+     (test (list big-red) (board-ref b3 i22 j22))
+
+     (test #f (winner? b3 'red))
+     (test #f (winner? b3 'yellow))
+
+     ;; Big red, big yellow, med yellow --------------------
+
+     (define b4 (move b3 med-yellow #f #f i02 j02 values void))
+     (test (list big-yellow) (board-ref b4 i11 j11))
+     (test (list big-red) (board-ref b4 i22 j22))
+     (test (list med-yellow) (board-ref b4 i02 j02))
+
+     (test #f (winner? b4 'red))
+     (test #f (winner? b4 'yellow))
+
+     (test (void) (move b4 med-red #f #f i02 j02 values void))
+     
+     ;; Big red gobble med yellow, big yellow --------------------
+     ;;  --- Add big red
+     (define b5.1 (move b4 big-red #f #f i02 j02 values void))
+     (when (= size 4)
+       ;; can't gobble yellow, since it's not in a 3-in-arow
+       (test (void) b5.1) 
+       ;; Generate board by cheating, giving red two turns...
+       (set! b5.1 (move (move b4 big-red i22 j22 i02 j02 values void)
+			big-red #f #f i22 j22 values void)))
+     (test (list big-yellow) (board-ref b5.1 i11 j11))
+     (test (list big-red) (board-ref b5.1 i22 j22))
+     (test (list big-red med-yellow) (board-ref b5.1 i02 j02))
+
+     ;;  --- Move big red
+     (define b5.2 (move b4 big-red i22 j22 i02 j02 values void))
+     (test (list big-yellow) (board-ref b5.2 i11 j11))
+     (test null (board-ref b5.2 i22 j22))
+     (test (list big-red med-yellow) (board-ref b5.2 i02 j02))
+
+     ;; Add small yellow ------------------------------
+     ;;  --- with 2 big red
+     (define b6.1 (move b5.1 small-yellow #f #f i20 j20 values void))
+     (test (list big-yellow) (board-ref b6.1 i11 j11))
+     (test (list big-red) (board-ref b6.1 i22 j22))
+     (test (list big-red med-yellow) (board-ref b6.1 i02 j02))
+     (test (list small-yellow) (board-ref b6.1 i20 j20))
+
+     (test #f (winner? b6.1 'red))
+     (test #f (winner? b6.1 'yellow))
+
+     ;;  --- with 1 big red
+     (define b6.2 (move b5.2 small-yellow #f #f i20 j20 values void))
+     (test (list big-yellow) (board-ref b6.2 i11 j11))
+     (test null (board-ref b6.2 i22 j22))
+     (test (list big-red med-yellow) (board-ref b6.2 i02 j02))
+     (test (list small-yellow) (board-ref b6.2 i20 j20))
+
+     (test #f (winner? b6.2 'red))
+     (test #f (winner? b6.2 'yellow))
+
+     ;; Expose med yellow for 3-in-row ----------
+     (define b7.1 (move b6.1 big-red i02 j02 i12 j12 values void))
+     (test (list big-yellow) (board-ref b7.1 i11 j11))
+     (test (list big-red) (board-ref b7.1 i22 j22))
+     (test (list med-yellow) (board-ref b7.1 i02 j02))
+     (test (list small-yellow) (board-ref b7.1 i20 j20))
+     (test (list big-red) (board-ref b7.1 i12 j12))
+
+     (test #f (winner? b7.1 'red))
+     (test (= size 3) (winner? b7.1 'yellow))
+
+     (define b7.2 (move b6.2 big-red i02 j02 i12 j12 values void))
+     (test (list big-yellow) (board-ref b7.2 i11 j11))
+     (test null (board-ref b7.2 i22 j22))
+     (test (list med-yellow) (board-ref b7.2 i02 j02))
+     (test (list small-yellow) (board-ref b7.2 i20 j20))
+     (test (list big-red) (board-ref b7.2 i12 j12))
+
+     (test #f (winner? b7.2 'red))
+     (test (= size 3) (winner? b7.2 'yellow))
+
+     (when (and (= size 4)
+		4x4-finish-pos)
+       ;; 4 x 4 game: now red can cover small yellow, because it's
+       ;; part of 3 in a row
+       (begin-with-definitions
+	(test #t (3-in-a-row? b7.2 i20 j20 'yellow))
+	(test #f (3-in-a-row? b7.2 i20 j20 'red))
+
+	(define b8.2 (move b7.2 med-red #f #f i20 j20 values void))
+	(test (list big-yellow) (board-ref b8.2 i11 j11))
+	(test null (board-ref b8.2 i22 j22))
+	(test (list med-yellow) (board-ref b8.2 i02 j02))
+	(test (list med-red small-yellow) (board-ref b8.2 i20 j20))
+	(test (list big-red) (board-ref b8.2 i12 j12))
+
+	(test #f (winner? b8.2 'red))
+	(test #f (winner? b8.2 'yellow))
+
+	(define b8.2x (move b7.2 med-yellow #f #f (car 4x4-finish-pos) (cdr 4x4-finish-pos) values void))
+	(test #f (winner? b8.2x 'red))
+	(test #t (winner? b8.2x 'yellow))))))
+	
+  (define (rotate i j)
+    (case i
+      [(0) (case j
+	     [(0) (values 1 0)]
+	     [(1) (values 0 0)]
+	     [(2) (values 0 1)])]
+      [(1) (case j
+	     [(0) (values 2 0)]
+	     [(1) (values 1 1)]
+	     [(2) (values 0 2)])]
+      [(2) (case j
+	     [(0) (values 2 1)]
+	     [(1) (values 2 2)]
+	     [(2) (values 1 2)])]
+      [else (values i j)]))
+
+  (map (lambda (xform+?)
+	 (basic-tests 3 ((cdr xform+?) 3) (car xform+?))
+	 (basic-tests 4 ((cdr xform+?) 4) (car xform+?)))
+       (list (cons #f (lambda (sz) (lambda (i j) (values i j))))
+	     (cons #f (lambda (sz) (lambda (i j) (values j i))))
+	     (cons #f (lambda (sz) (lambda (i j) (values i (- sz 1 j)))))
+	     (cons '(3 . 1) (lambda (sz) (lambda (i j) (rotate i j))))
+	     (cons '(1 . 3) (lambda (sz) (lambda (i j) (rotate i (- 3 1 j)))))))
+
+  ;; Extra tests for 4 x 4 to get yellow 3-in-a-row on diagonals:
+  (basic-tests 4 (lambda (i j) (values i (+ j 1))) '(3 . 0))
+  (basic-tests 4 (lambda (i j) (values i (- 3 (+ j 1)))) '(3 . 3))
+  
+  (report-test-results))
+
+	
\ No newline at end of file
diff --git a/collects/games/gobblet/test.ss b/collects/games/gobblet/test.ss
new file mode 100644
index 0000000000..d0293594cf
--- /dev/null
+++ b/collects/games/gobblet/test.ss
@@ -0,0 +1,27 @@
+
+(module test mzscheme
+  (provide test report-test-results)
+  
+  (define failed? #f)
+  (define (set-failed!) (set! failed? #t))
+
+  (define-syntax test
+    (syntax-rules ()
+      [(_ expect expr)
+       (begin
+	 (printf "~s =>" 'expr)
+	 (flush-output)
+	 (let ([v expr]
+	       [ex expect])
+	   (printf " ~s" v)
+	   (unless (equal? v ex)
+	     (set-failed!)
+	     (printf " EXPECTED ~s" ex)
+	     (exit))
+	   (printf "~n")))]))
+
+  (define (report-test-results)
+    (printf (if failed?
+		"~nTESTS FAILED~n"
+		"~nAll tests passed.~n"))))
+
diff --git a/collects/games/gofish/doc.txt b/collects/games/gofish/doc.txt
new file mode 100644
index 0000000000..ba54e931d6
--- /dev/null
+++ b/collects/games/gofish/doc.txt
@@ -0,0 +1,28 @@
+** To play _Go Fish_, run the "Games" application. **
+
+Go Fish is the children's card game where you try to get rid of all
+you cards by forming pairs. You play against two computer players.
+
+On Each turn, if you have a match in your hand, drag one of the
+matching cards to your numbered box, and the match will move into the
+box.
+
+After forming matches from your own hand, drag one of your cards to an
+opponent's area to ask the opponent for a matching card:
+
+ * If the opponent has a card with the same value as the card that you
+   drag, the opponent will give you the card, and they'll go into your
+   match area. Drag another card to an opponent.
+
+ * If the opponent has no matching card, the top card on draw pile
+   will move, indicating that you must "Go Fish!". Draw a card by
+   dragging it from the draw pile to your hand. If the drawn card
+   gives you a match, then the match will automatically move into your
+   match area, and it's still your turn (so drag another card to one
+   of the opponents).
+
+The game is over when one player runs out of cards. The winner is the
+one with the most matches.
+
+The status line at the bottom of the window provides instructions as
+you go. The computer players are not particularly smart.
diff --git a/collects/games/gofish/gofish.png b/collects/games/gofish/gofish.png
new file mode 100644
index 0000000000..7eea24f73d
Binary files /dev/null and b/collects/games/gofish/gofish.png differ
diff --git a/collects/games/gofish/gofish.ss b/collects/games/gofish/gofish.ss
new file mode 100644
index 0000000000..e9be80aff0
--- /dev/null
+++ b/collects/games/gofish/gofish.ss
@@ -0,0 +1,359 @@
+
+(module gofish mzscheme
+  (require (lib "cards.ss" "games" "cards")
+	   (lib "mred.ss" "mred")
+	   (lib "class.ss")
+           (lib "unit.ss")
+	   (lib "list.ss"))
+  
+  (provide game-unit)
+  
+  (define game-unit
+    (unit
+      (import)
+      (export)
+      
+      ;; Player record
+      (define-struct player (r hand-r discard-r count-r ; regions
+                               hand discarded ; cards
+                               tried)) ; memory for simulating players
+      
+      ;; Player names
+      (define PLAYER-1-NAME "Opponent 1")
+      (define PLAYER-2-NAME "Opponent 2")
+      (define YOUR-NAME "You")
+      
+      ;; Initial card count
+      (define DEAL-COUNT 7)
+      
+      ;; Messages
+      (define YOUR-TURN-MESSAGE "Your turn.  (Drag a match to your discard box or drag a card to an opponent.)")
+      (define GO-FISH-MESSAGE "Go Fish!  (Drag a card from the center deck to your box.)")
+      (define MATCH-MESSAGE "Match!")
+      (define GAME-OVER-MESSAGE "GAME OVER")
+      
+      ;; Region layout constants
+      (define MARGIN 10)
+      (define SUBMARGIN 10)
+      (define LABEL-H 15)
+      
+      ;; Randomize
+      (random-seed (modulo (current-milliseconds) 10000))
+      
+      ;; Set up the table
+      (define t (make-table "Go Fish" 8 4.5))
+      (define status-pane (send t create-status-pane))
+      (send t add-help-button status-pane '("games" "gofish") "Go Fish Help" #f)
+      (send t show #t)
+      (send t set-double-click-action #f)
+      (send t set-button-action 'left 'drag-raise/one)
+      (send t set-button-action 'middle 'drag/one)
+      (send t set-button-action 'right 'drag/one)
+      
+      ;; Get table width & height
+      (define w (send t table-width))
+      (define h (send t table-height))
+      
+      ;; Set up the cards
+      (define deck (shuffle-list (make-deck) 7))
+      (for-each
+       (lambda (card)
+         (send card snap-back-after-move #t)
+         (send card user-can-flip #f))
+       deck)
+      
+      ;; Function for dealing or drawing cards
+      (define (deal n)
+        (let loop ([n n][d deck])
+          (if (zero? n)
+              (begin
+                (set! deck d)
+                null)
+              (cons (car d) (loop (sub1 n) (cdr d))))))
+      
+      ;; Card width & height
+      (define cw (send (car deck) card-width))
+      (define ch (send (car deck) card-height))
+      
+      ;; Put the cards on the table
+      (send t add-cards 
+            deck
+            (/ (- w cw) 2)
+            (- (/ (- h ch) 2) (/ ch 3)))
+      
+      ;; Player region size
+      (define pw (- (/ (- w cw) 2) (* 2 MARGIN)))
+      (define ph (- (/ (- h (/ ch 3)) 2) (* 2 MARGIN)))
+      
+      ;; Region-makers
+      (define (make-hand-region r)
+        (define m SUBMARGIN)
+        (make-region
+         (+ m (region-x r)) (+ LABEL-H m (region-y r))
+         (- (region-w r) (* 3 m) cw) (- (region-h r) LABEL-H (* 2 m))
+         #f #f))
+      (define (make-discard-region r)
+        (make-region
+         (- (+ (region-x r) (region-w r)) SUBMARGIN cw)
+         (- (+ (region-y r) (region-h r)) SUBMARGIN ch)
+         cw ch
+         #f #f))
+      (define (make-discard-count-region r c cb)
+        (make-region
+         (- (+ (region-x r) (region-w r)) SUBMARGIN cw (/ SUBMARGIN 2))
+         (- (+ (region-y r) (region-h r)) SUBMARGIN ch LABEL-H (/ SUBMARGIN 2))
+         (+ cw SUBMARGIN) (+ ch LABEL-H SUBMARGIN)
+         (number->string c)
+         cb))
+      
+      ;; Define the initial regions
+      (define player-1-region
+        (make-region
+         MARGIN MARGIN pw ph
+         PLAYER-1-NAME
+         void))
+      (define player-2-region
+        (make-region
+         (- w MARGIN pw) MARGIN pw ph
+         PLAYER-2-NAME
+         void))
+      (define you-region
+        (make-region
+         MARGIN (- h MARGIN ph) (- w (* 2 MARGIN)) ph
+         YOUR-NAME
+         void))
+      
+      ;; Player setup
+      (define (create-player r discard-callback)
+        (let ([p (make-player
+                  r
+                  (make-hand-region r)
+                  (make-discard-region r)
+                  (make-discard-count-region r 0 discard-callback)
+                  (deal DEAL-COUNT)
+                  null
+                  null)])
+          (send t add-region r)
+          (send t add-region (player-count-r p))
+          (for-each (lambda (card) (send t card-to-front card)) (reverse (player-hand p))) 
+          (send t move-cards-to-region (player-hand p) (player-hand-r p))
+          p))
+      
+      (define player-1 (create-player player-1-region #f))
+      (define player-2 (create-player player-2-region #f))
+      (define you (create-player you-region 
+                                 ;; Dragging to your discard pile checks to see if the card
+                                 ;;  makes a match:
+                                 (lambda (cards) 
+                                   (check-hand you (car cards))
+                                   (send t set-status YOUR-TURN-MESSAGE))))
+      
+      ;; More card setup: Opponents's cards and deck initally can't be moved
+      (for-each
+       (lambda (card) (send card user-can-move #f))
+       (append
+        (player-hand player-1)
+        (player-hand player-2)
+        deck))
+      
+      ;; More card setup: Show your cards
+      (send t flip-cards (player-hand you))
+      
+      ;; Function to update the display for a player record
+      (define (rearrange-cards p)
+        ;; Stack cards in 3D first-to-last
+        (send t stack-cards (player-discarded p))
+        (send t stack-cards (player-hand p))
+        ;; Move them to their regions
+        (send t move-cards-to-region (player-discarded p) (player-discard-r p))
+        (send t move-cards-to-region (player-hand p) (player-hand-r p))
+        ;; Recreate the counter region to reset the count
+        (send t begin-card-sequence)
+        (send t remove-region (player-count-r p))
+        (set-player-count-r! p (make-discard-count-region 
+                                (player-r p) (/ (length (player-discarded p)) 2)
+                                (region-callback (player-count-r p))))
+        (send t add-region (player-count-r p))
+        (send t end-card-sequence))
+      
+      ;; Function to search for an equivalent card
+      (define (find-equiv card hand)
+        (ormap (lambda (c)
+                 (and (not (eq? c card))
+                      (= (send card get-value) (send c get-value))
+                      c))
+               hand))
+      
+      ;; Function to check for a match involving `card' already in the player's hand
+      (define (check-hand player card)
+        (let* ([h (player-hand player)]
+               [found (find-equiv card h)])
+          (if found
+              (begin
+                ;; Make sure the matching cards are face-up and pause for the user
+                (send t cards-face-up (list found card))
+                (send t set-status MATCH-MESSAGE)
+                ;; The players has a match! Move the card from the player's hand
+                ;;  to his discard pile
+                (set-player-hand! player (remove* (list card found) h))
+                (set-player-discarded! player (cons found 
+                                                    (cons card 
+                                                          (player-discarded player))))
+                ;; The dicarded cards can no longer be moved
+                (send card user-can-move #f)
+                (send found user-can-move #f)
+                ;; Move the cards to their new places
+                (rearrange-cards player)
+                ;; Slower
+                #t)
+              #f)))
+      
+      ;; Function to enable/disable moving your cards
+      (define (enable-your-cards on?)
+        (for-each (lambda (c) (send c user-can-move on?))
+                  (player-hand you)))
+      
+      ;; Callbacks communicate back to the main loop via these
+      (define something-happened (make-semaphore 1))
+      (define go-fish? #f)
+      
+      ;; Function for trying to get a card from another player
+      (define (ask-player-for-match getter giver card)
+        (let* ([h (player-hand giver)]
+               [found (find-equiv card h)])
+          (if found
+              (begin
+                ;; The giver player has a matching card - give it to the getter
+                (set-player-hand! giver (remq found h))
+                (set-player-hand! getter (cons found (player-hand getter)))
+                ;; Make sure the matching cards are face-up and pause for the user
+                (send t cards-face-up (list found card))
+                ;; Move the cards around
+                (check-hand getter card)
+                (rearrange-cards giver)
+                #t)
+              ;; The giver player doesn't have it - Go Fish!
+              #f)))
+      
+      ;; Callback for dragging a card to an opponent
+      (define (player-callback player)
+        (lambda (cards)
+          (set! go-fish? (not (ask-player-for-match you player (car cards))))
+          (semaphore-post something-happened)))
+      
+      ;; Visual info to go fish
+      (define wiggle-top-card
+        (lambda ()
+          (let ([top (car deck)]
+                [x (/ (- w cw) 2)]
+                [y (- (/ (- h ch) 2) (/ ch 3))])
+            (send t move-card top (- x 10) y)
+            (send t move-card top (+ x 10) y)
+            (send t move-card top x y))))
+      
+      ;; Callback for going fishing
+      (define fishing
+        (lambda (cards)
+          (send t flip-card (car deck))
+          (set-player-hand! you (append (deal 1) (player-hand you)))
+          (rearrange-cards you)
+          (semaphore-post something-happened)))
+      
+      ;; Function to simulate a player
+      (define (simulate-player player other-player k)
+        ;; Try cards in the players hand that haven't been tried
+        (let ([cards-to-try (remq* (player-tried player) (player-hand player))])
+          (if (null? cards-to-try)
+              (begin
+                ;; No cards to try. Reset the history and start over
+                (set-player-tried! player null)
+                (simulate-player player other-player k))
+              ;; Pick a random card and a random opponent
+              (let ([c (list-ref cards-to-try (random (length cards-to-try)))]
+                    [o (list-ref (list you other-player) (random 2))])
+                (set-player-tried! player (cons c (player-tried player)))
+                ;; Show you the card-to-ask
+                (send t flip-card c)
+                ;; Hilight player-to-ask
+                (send t hilite-region (player-r o))
+                ;; Wait a moment
+                (sleep 0.3)
+                ;; Unhilight player-to-ask
+                (send t unhilite-region (player-r o))
+                (if (ask-player-for-match player o c)
+                    ;; Got it - go again
+                    (check-done
+                     (lambda ()
+                       (simulate-player player other-player k)))
+                    ;; Go fish
+                    (begin
+                      ;; Wait a bit, then turn the asked-for card back over
+                      (sleep 0.3)
+                      (send t flip-card c)
+                      (if (null? deck)
+                          ;; No more cards; pass
+                          (k)
+                          (begin
+                            ;; Draw a card
+                            (set-player-hand! player (append (deal 1) (player-hand player)))
+                            (rearrange-cards player)
+                            (if (check-hand player (car (player-hand player)))
+                                ;; Drew a good card - keep going
+                                (check-done
+                                 (lambda ()
+                                   (simulate-player player other-player k)))
+                                ;; End of our turn
+                                (k))))))))))
+      
+      ;; Function to check for end-of-game
+      (define (check-done k)
+        (if (ormap (lambda (p) (null? (player-hand p))) (list player-1 player-2 you))
+            (begin
+              (enable-your-cards #f)
+              (send t set-status GAME-OVER-MESSAGE))
+            (k)))
+      
+      ;; Look in opponents' initial hands for matches
+      ;; (Since each player gets 7 cards, it's impossible to run out of cards this way)
+      (define (find-initial-matches player)
+        (when (ormap (lambda (card) (check-hand player card)) (player-hand player))
+          ;; Found a match in the hand
+          (find-initial-matches player)))
+      (find-initial-matches player-1)
+      (find-initial-matches player-2)   
+      
+      ;; Run the game loop
+      (let loop ()
+        (set-region-callback! (player-r you) #f)
+        (set-region-callback! (player-r player-1) (player-callback player-1))
+        (set-region-callback! (player-r player-2) (player-callback player-2))
+        (send t set-status YOUR-TURN-MESSAGE)
+        (yield something-happened)
+        (if go-fish?
+            (begin
+              (if (if (null? deck)
+                      ;; No more cards; pass
+                      #f
+                      ;; Draw a card (wait for the user to drag it)
+                      (begin
+                        (send t set-status GO-FISH-MESSAGE)
+                        (wiggle-top-card)
+                        (enable-your-cards #f)
+                        (set-region-callback! (player-r player-1) #f)
+                        (set-region-callback! (player-r player-2) #f)
+                        (set-region-callback! (player-r you) fishing)
+                        (send (car deck) user-can-move #t)
+                        (yield something-happened)
+                        (enable-your-cards #t)
+                        (check-hand you (car (player-hand you)))))
+                  (check-done loop)
+                  (begin
+                    (send t set-status PLAYER-1-NAME)
+                    (simulate-player 
+                     player-1 player-2
+                     (lambda ()
+                       (send t set-status PLAYER-2-NAME)
+                       (simulate-player player-2 player-1 loop))))))
+            (check-done loop))))))
+    
+    
\ No newline at end of file
diff --git a/collects/games/gofish/info.ss b/collects/games/gofish/info.ss
new file mode 100644
index 0000000000..4f9c3585c2
--- /dev/null
+++ b/collects/games/gofish/info.ss
@@ -0,0 +1,5 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Go Fish")
+  (define doc.txt "doc.txt")
+  (define game "gofish.ss")
+  (define game-set "Card Games"))
diff --git a/collects/games/info.ss b/collects/games/info.ss
new file mode 100644
index 0000000000..655c970ce7
--- /dev/null
+++ b/collects/games/info.ss
@@ -0,0 +1,22 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Games")
+  (define doc.txt "doc.txt")
+  (define mred-launcher-libraries (list "games.ss"))
+  (define mred-launcher-names (list "Games"))
+  (define doc-sub-collections
+    (list "cards" "paint-by-numbers" "same" "lights-out" "aces" "spider"
+	  "memory" "pousse" "crazy8s"
+          "gcalc" "parcheesi" "gl-board-game"))
+  (define blurb 
+    (list "Demos a few small "
+	  '(a ((MZSCHEME "
+(begin
+  (require (lib |mred.ss| |mred|))
+  (parameterize ([current-custodian (make-custodian)]) 
+    (parameterize ([current-eventspace (make-eventspace)])
+      (queue-callback 
+       (lambda ()
+         (exit-handler void) 
+         (dynamic-require (quote (lib |games.ss| |games|)) #f))))))")) "games")
+	  " implemented in Scheme.")))
+
diff --git a/collects/games/lights-out/board.ss b/collects/games/lights-out/board.ss
new file mode 100644
index 0000000000..0c0cbfe6cd
--- /dev/null
+++ b/collects/games/lights-out/board.ss
@@ -0,0 +1,144 @@
+(module board mzscheme
+  (require (lib "mred.ss" "mred")
+           (lib "class.ss")
+           (lib "etc.ss")
+           "boards.ss")
+
+  (provide
+   new-board      ;; : (-> board)  querys user
+   random-board)  ;; : (num -> board)
+
+  (define (new-board)
+    (letrec ([dialog (make-object dialog% "New Board")]
+	     [mode 'prebuilt]
+	     [update-mode
+	      (lambda ()
+		(send below-panel change-children
+		      (case mode
+			[(random)
+			 (lambda x (list random-panel))]
+			[(prebuilt)
+			 (lambda x (list prebuilt-panel))]
+			[(empty)
+			 (lambda x (list random-panel))])))]
+	     [radio-box
+	      (make-object radio-box% #f (list "Prebuilt" "Random" "Empty") dialog
+			   (lambda (rb evt)
+			     (cond
+			      [(= 0 (send rb get-selection))
+			       (set! mode 'prebuilt)]
+			      [(= 1 (send rb get-selection))
+			       (set! mode 'random)]
+			      [(= 2 (send rb get-selection))
+			       (set! mode 'empty)])
+			     (update-mode))
+			   '(horizontal))]
+	     [below-panel (make-object vertical-panel% dialog)]
+	     [prebuilt-panel (make-object vertical-panel% below-panel '(border))]
+	     [prebuilt
+	      (make-object choice%
+		#f
+		(map board-name boards)
+		prebuilt-panel
+		(lambda (choice evt)
+		  (void)))]
+	     [random-panel (make-object vertical-panel% below-panel '(border))]
+	     [random-slider
+	      (make-object slider%
+		"Board Size" 3 8 random-panel
+		(lambda (slider evt)
+		  (void))
+		6)]
+	     [button-panel (make-object horizontal-panel% dialog)]
+	     [cancel? #t]
+	     [ok (make-object button% "OK" 
+			      button-panel
+			      (lambda x
+				(set! cancel? #f)
+				(send dialog show #f)))]
+	     [cancel (make-object button% "Cancel"
+				  button-panel
+				  (lambda x
+				    (send dialog show #f)))])
+      (update-mode)
+      (send button-panel set-alignment 'right 'center)
+      (set! new-board
+	    (lambda ()
+	      (set! cancel? #t)
+	      (send dialog show #t)
+	      (if cancel?
+		  #f
+		  (case mode
+		    [(random)
+		     (random-board (send random-slider get-value))]
+		    [(empty)
+		     (build-vector 
+		      (send random-slider get-value)
+		      (lambda (x) (make-vector (send random-slider get-value) 'o)))]
+		    [(prebuilt)
+		     (board-board (list-ref boards (send prebuilt get-selection)))]))))
+      (new-board)))
+  
+  '(define (build-vector n f)
+    (list->vector
+     (let loop ([n n])
+       (cond
+	[(zero? n) null]
+	[else (cons (f (- n 1)) (loop (- n 1)))]))))
+  
+  (define (random-board n)
+    (let* ([choices
+	    (let loop ([i n]
+		       [res null])
+	      (cond
+	       [(zero? i) res]
+	       [else
+		(loop (- i 1)
+		      (let loop ([j n]
+				 [res res])
+			(cond
+			 [(zero? j) res]
+			 [else (loop (- j 1)
+				     (cons (cons (- i 1) (- j 1)) res))])))]))]
+	   [board (build-vector n (lambda (x) (make-vector n 'o)))]
+	   [flip
+	    (lambda (i j)
+	      (when (and (<= 0 i (- n 1))
+			 (<= 0 j (- n 1)))
+		(vector-set! (vector-ref board j) i
+			     (case (vector-ref (vector-ref board j) i)
+			       [(x) 'o]
+			       [(o) 'x]))))]
+	   [sim-click
+	    (lambda (i j)
+	      (flip i j)
+	      (flip (- i 1) j)
+	      (flip (+ i 1) j)
+	      (flip i (+ j 1))
+	      (flip i (- j 1)))]
+	   
+	   [number-of-clicks
+	    (let loop ([n (* (+ n 1) 2)])
+	      (cond
+	       [(zero? n) 0]
+	       [else (+ (random 2)
+			(loop (- n 1)))]))])
+      
+      (let loop ([clicks number-of-clicks])
+	(unless (zero? clicks)
+	  (let ([choice (random (length choices))]
+		[continue? (not (zero? (random 3)))]
+		[choice-coordinates #f])
+	    (set! choices
+		  (let loop ([choices choices]
+			     [n choice])
+		    (cond
+		     [(zero? n) 
+					;(printf "choose: ~a~n" (car choices))
+		      (set! choice-coordinates (car choices))
+		      (cdr choices)]
+		     [else (cons (car choices) (loop (cdr choices) (- n 1)))])))
+	    (sim-click (car choice-coordinates)
+		       (cdr choice-coordinates))
+	    (loop (- clicks 1)))))
+      board)))
\ No newline at end of file
diff --git a/collects/games/lights-out/boards.ss b/collects/games/lights-out/boards.ss
new file mode 100644
index 0000000000..29793d92c2
--- /dev/null
+++ b/collects/games/lights-out/boards.ss
@@ -0,0 +1,64 @@
+(module boards mzscheme
+  (provide boards
+           (struct board (name board)))
+
+  (define-struct board (name board))
+
+  (define boards
+    (list
+     (make-board
+      "1"
+      #(#(o o o o o)
+         #(o o o o o)
+         #(x o x o x)
+         #(o o o o o)
+         #(o o o o o)))
+     (make-board
+      "2"
+      #(#(x o x o x)
+         #(x o x o x)
+         #(o o o o o)
+         #(x o x o x)
+         #(x o x o x)))
+     (make-board
+      "3"
+      #(#(o x o x o)
+         #(x x o x x)
+         #(x x o x x)
+         #(x x o x x)
+         #(o x o x o)))
+     (make-board
+      "4"
+      #(#(o o o o o)
+         #(x x o x x)
+         #(o o o o o)
+         #(x o o o x)
+         #(x x o x x)))
+     (make-board
+      "5"
+      #(#(x x x x o)
+         #(x x x o x)
+         #(x x x o x)
+         #(o o o x x)
+         #(x x o x x)))
+     (make-board
+      "6"
+      #(#(o o o o o)
+         #(o o o o o)
+         #(x o x o x)
+         #(x o x o x)
+         #(o x x x o)))
+     (make-board
+      "7"
+      #(#(x x x x o)
+         #(x o o o x)
+         #(x o o o x)
+         #(x o o o x)
+         #(x x x x o)))
+     (make-board 
+      "Diagonal"
+      #(#(o o o o x)
+         #(o o o x o)
+         #(o o x o o)
+         #(o x o o o)
+         #(x o o o o))))))
\ No newline at end of file
diff --git a/collects/games/lights-out/doc.txt b/collects/games/lights-out/doc.txt
new file mode 100644
index 0000000000..60167628eb
--- /dev/null
+++ b/collects/games/lights-out/doc.txt
@@ -0,0 +1,7 @@
+_Lights Out_
+
+The object of this game is to turn all of the lights off. Click on a button
+to turn that light off, but beware it will also toggle the lights above, 
+below to the left and to the right of that button.
+
+Good luck.
\ No newline at end of file
diff --git a/collects/games/lights-out/info.ss b/collects/games/lights-out/info.ss
new file mode 100644
index 0000000000..2e5d639b62
--- /dev/null
+++ b/collects/games/lights-out/info.ss
@@ -0,0 +1,5 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Lights Out")
+  (define doc.txt "doc.txt")
+  (define game-set "Puzzle Games")
+  (define game "lights-out.ss"))
diff --git a/collects/games/lights-out/lights-out.png b/collects/games/lights-out/lights-out.png
new file mode 100644
index 0000000000..9811bca777
Binary files /dev/null and b/collects/games/lights-out/lights-out.png differ
diff --git a/collects/games/lights-out/lights-out.ss b/collects/games/lights-out/lights-out.ss
new file mode 100644
index 0000000000..087cf36923
--- /dev/null
+++ b/collects/games/lights-out/lights-out.ss
@@ -0,0 +1,208 @@
+(module lights-out mzscheme
+  (require "board.ss"
+           "../show-help.ss"
+           (lib "mred.ss" "mred")
+           (lib "class.ss")
+           (lib "unit.ss"))
+  
+  (provide game-unit)
+  
+  (define game-unit
+    (unit
+      (import)
+      (export init-board) ;; : (board -> void) resets the window(s)
+      
+      (define frame (make-object frame% "Lights Out"))
+      
+      (define label-size 30)
+      
+      (define orange (make-object color% 255 165 0))
+      (define light-orange (make-object color% 255 220 100))
+      
+      (define on-pen (send the-pen-list find-or-create-pen orange 1 'solid))
+      (define on-brush (send the-brush-list find-or-create-brush orange 'solid))
+      (define off-pen (send the-pen-list find-or-create-pen "BLACK" 1 'solid))
+      (define off-brush (send the-brush-list find-or-create-brush "BLACK" 'solid))
+      
+      (define dull-on-pen (send the-pen-list find-or-create-pen light-orange 1 'solid))
+      (define dull-on-brush (send the-brush-list find-or-create-brush light-orange 'solid))
+      (define dull-off-pen (send the-pen-list find-or-create-pen "DARK GRAY" 1 'solid))
+      (define dull-off-brush (send the-brush-list find-or-create-brush "DARK GRAY" 'solid))
+      
+      (define (flip-one i j)
+        (when (and (<= 0 i (- (vector-length current-board) 1))
+                   (<= 0 j (- (vector-length current-board) 1)))
+          (vector-set!
+           (vector-ref current-board j)
+           i
+           (case (vector-ref (vector-ref current-board j) i)
+             [(x) 'o]
+             [(o) 'x]))))
+      
+      (define (flip-surrounding i j)
+        (flip-one i j)
+        (flip-one (- i 1) j)
+        (flip-one i (- j 1))
+        (flip-one (+ i 1) j)
+        (flip-one i (+ j 1)))
+      
+      (define current-board #f)
+      (define original-board #f)
+      
+      (define board-canvas%
+        (class canvas%
+          (inherit get-dc get-client-size)
+          
+          (define/private (get-width) (let-values ([(w h) (get-client-size)]) w))
+          (define/private (get-height) (let-values ([(w h) (get-client-size)]) h))
+          
+          [define dull-i 1]
+          [define dull-j 1]
+          [define/private tile->screen
+            (lambda (i j)
+              (let ([x (inexact->exact (floor (* (/ i (vector-length current-board)) (- (get-width) 2))))]
+                    [y (inexact->exact (floor (* (/ j (vector-length current-board)) (- (get-height) 2))))]
+                    [w (inexact->exact (floor (* (/ (- (get-width) 2) (vector-length current-board)))))]
+                    [h (inexact->exact (floor (* (/ (- (get-height) 2) (vector-length current-board)))))])
+                (values (+ x 2)
+                        (+ y 2)
+                        (max 0 (- w 2))
+                        (max 0 (- h 2)))))]
+          [define/private screen->tile
+            (lambda (x y)
+              (values (inexact->exact (floor (* (/ x (get-width)) (vector-length current-board))))
+                      (inexact->exact (floor (* (/ y (get-height)) (vector-length current-board))))))]
+          [define/private draw-tile
+            (lambda (dc i j)
+              (when (and (<= 0 i (- (vector-length current-board) 1))
+                         (<= 0 j (- (vector-length current-board) 1)))
+                (let ([ent (vector-ref (vector-ref current-board j) i)]
+                      [dull? (and dull-i
+                                  dull-j
+                                  (or (and (= i dull-i)
+                                           (= j dull-j))
+                                      (and (= i (- dull-i 1))
+                                           (= j dull-j))
+                                      (and (= i (+ dull-i 1))
+                                           (= j dull-j))
+                                      (and (= i dull-i)
+                                           (= j (- dull-j 1)))
+                                      (and (= i dull-i)
+                                           (= j (+ dull-j 1)))))])
+                  (if dull?
+                      (if (eq? ent 'x)
+                          (begin
+                            (send dc set-pen dull-off-pen)
+                            (send dc set-brush dull-off-brush))
+                          (begin
+                            (send dc set-pen dull-on-pen)
+                            (send dc set-brush dull-on-brush)))
+                      (if (eq? ent 'x)
+                          (begin
+                            (send dc set-pen on-pen)
+                            (send dc set-brush on-brush))
+                          (begin
+                            (send dc set-pen off-pen)
+                            (send dc set-brush off-brush)))))
+                (let-values ([(x y w h) (tile->screen i j)])
+                  (send dc draw-rectangle x y w h))))]
+          [define/private get-changed
+            (lambda (x y)
+              (if (and x y)
+                  (list (cons x y)
+                        (cons (+ x 1) y)
+                        (cons (- x 1) y)
+                        (cons x (- y 1))
+                        (cons x (+ y 1)))
+                  null))]
+          [define/public redraw
+            (lambda ()
+              (let* ([dc (get-dc)])
+                (let loop ([j (vector-length current-board)])
+                  (cond
+                    [(zero? j) (void)]
+                    [else
+                     (let loop ([i (vector-length current-board)])
+                       (cond
+                         [(zero? i) (void)]
+                         [else
+                          (draw-tile dc
+                                     (- i 1)
+                                     (- j 1))
+                          (loop (- i 1))]))
+                     (loop (- j 1))]))))]
+          
+          [define/override on-event
+            (lambda (evt)
+              (cond
+                [(send evt button-up?)
+                 (let-values ([(x y) (screen->tile (send evt get-x) (send evt get-y))])
+                   (flip-surrounding x y)
+                   (redraw))]
+                [(send evt leaving?)
+                 (let ([changed (get-changed dull-i dull-j)])
+                   (set! dull-i #f)
+                   (set! dull-j #f)
+                   (for-each (lambda (pair) (draw-tile (get-dc) (car pair) (cdr pair)))
+                             changed))]
+                [(send evt moving?)
+                 (let ([changed-one (get-changed dull-i dull-j)])
+                   (let-values ([(x y) (screen->tile (send evt get-x) (send evt get-y))])
+                     (set! dull-i x)
+                     (set! dull-j y))
+                   (let ([changed-two (get-changed dull-i dull-j)])
+                     (for-each (lambda (pair) (draw-tile (get-dc) (car pair) (cdr pair)))
+                               (append changed-one changed-two))))]
+                [else (void)]))]
+          [define/override on-paint
+            (lambda ()
+              (send (get-dc) clear)
+              (redraw))]
+          (super-instantiate ()
+            (parent frame))))
+      
+      (define board-canvas (make-object board-canvas%))
+      (send board-canvas min-width 100)
+      (send board-canvas min-height 100)
+      
+      (define (copy-board board)
+        (list->vector
+         (map (lambda (x) (list->vector (vector->list x)))
+              (vector->list board))))
+      
+      (define (init-board new-board)
+        (set! current-board new-board)
+        (set! original-board (copy-board new-board))
+        (send board-canvas on-paint))
+      
+      (define button-panel (make-object horizontal-panel% frame))
+      
+      (make-object button% "New" button-panel
+        (lambda x
+          (let ([res (new-board)])
+            (when res
+              (init-board res)))))
+      
+      (make-object button% "Reset" button-panel
+        (lambda x
+          (init-board original-board)))
+      
+      (let ([help (show-help
+                   (list "games" "lights-out")
+                   "Lights Out Help")])
+        (make-object button% "Help" button-panel
+          (lambda x
+            (help))))
+      
+      (make-object grow-box-spacer-pane% button-panel)
+      (send button-panel stretchable-height #f)
+      
+      (init-board (random-board (+ 3 
+                                   (random 2)
+                                   (random 2)
+                                   (random 2)
+                                   (random 2)
+                                   (random 2))))
+      ;(send frame stretchable-width #f)
+      ;(send frame stretchable-height #f)
+      (send frame show #t))))
\ No newline at end of file
diff --git a/collects/games/loa/grid.ss b/collects/games/loa/grid.ss
new file mode 100644
index 0000000000..0f88986f64
--- /dev/null
+++ b/collects/games/loa/grid.ss
@@ -0,0 +1,296 @@
+(unit/sig loa:grid^
+  (import mzlib:function^
+	  mred^
+	  loa:utils^)
+
+  (define black-pen (send the-pen-list find-or-create-pen "BLACK" 1 'solid))
+  (define black-brush (send the-brush-list find-or-create-brush "BLACK" 'solid))
+
+  (define highlight-color "PALE GREEN")
+  (define highlight-pen (send the-pen-list find-or-create-pen highlight-color 1 'solid))
+  (define highlight-brush (send the-brush-list find-or-create-brush highlight-color 'solid))
+
+  (define line-color "CORNFLOWER BLUE")
+  (define line-pen (send the-pen-list find-or-create-pen line-color 1 'solid))
+  (define line-brush (send the-brush-list find-or-create-brush line-color 'solid))
+
+  (define grid-pasteboard%
+    (class pasteboard% (x-size y-size . args)
+      (inherit get-canvas find-first-snip move-to invalidate-bitmap-cache)
+      (private
+	[calculate-grid
+	 (lambda (entries pixels)
+	   (build-vector
+	    (+ entries 1)
+	    (lambda (i) (* i (/ pixels entries)))))])
+
+      (private
+	[margin 4]
+	[pieces (build-vector x-size (lambda (i) (build-vector y-size (lambda (j) null))))]
+	[y-grid (calculate-grid x-size (* x-size 2))]
+	[x-grid (calculate-grid y-size (* y-size 2))])
+
+      (public
+	[get-margin (lambda () margin)]
+	[set-margin (lambda (m) (when (>= m 4) (set! margin m)))])
+
+      (public
+	[get-moves
+	 (lambda (snip) (list (cons (send snip get-x) (send snip get-y))))])
+
+      (private
+	[valid-move? (lambda (snip cx cy)
+		       (let ([legal-moves (get-moves snip)])
+			 (member
+			  (cons cx cy)
+			  legal-moves)))])
+
+      (private
+	[grid-xy->pixel-xywh
+	 (lambda (x y)
+	   (let*-values ([(canvas) (get-canvas)]
+			 [(bx by) (send canvas get-client-size)])
+	     (values (* x (/ bx x-size))
+		     (* y (/ by y-size))
+		     (/ bx x-size)
+		     (/ by y-size))))]
+			 
+
+	[pixel-xy->grid-xy
+	 (lambda (px py)
+	   (let*-values ([(canvas) (get-canvas)]
+			 [(bx by) (send canvas get-client-size)]
+			 [(gx) (floor (* x-size (/ px bx)))]
+			 [(gy) (floor (* y-size (/ py by)))])
+	     (values (inexact->exact gx) (inexact->exact gy))))])
+
+      (private
+	[cursor-x/y #f]
+	[update-cursor-x/y
+	 (lambda (new-x/y)
+	   (unless (equal? cursor-x/y new-x/y)
+	     (set! cursor-x/y new-x/y)
+	     (invalidate-bitmap-cache)))])
+
+      (rename [super-on-local-event on-local-event])
+      (override
+       [on-local-event
+	(lambda (evt)
+	  (cond
+	   [(send evt leaving?)
+	    (update-cursor-x/y #f)]
+	   [(or (send evt moving?)
+		(send evt entering?))
+	    (let-values ([(px py) (pixel-xy->grid-xy (send evt get-x) (send evt get-y))])
+	      (update-cursor-x/y (cons px py)))]
+	   [else (void)])
+	  (super-on-local-event evt))])
+
+      (private 
+	[ignored-move? #f])
+      (public
+	[animate-to
+	 (lambda (snip x y)
+	   (set! ignored-move? #t)
+	   (let* ([canvas (get-canvas)])
+	     (let-values ([(bx by) (send canvas get-client-size)])
+	       (move-to snip 
+			(* x (/ bx x-size))
+			(* y (/ by y-size))))
+	     (set! ignored-move? #f)))])
+      (inherit find-next-selected-snip)
+
+      (public
+	[moved
+	 (lambda (l)
+	   (void))])
+
+      (override
+	[after-interactive-move
+	 (lambda (event)
+	   (unless ignored-move?
+	     (let ([moved-snips
+		    (let-values ([(cx cy) (pixel-xy->grid-xy (send event get-x) (send event get-y))])
+		      (let loop ([snip (find-next-selected-snip #f)])
+			(if snip
+			    (if (valid-move? snip cx cy)
+				(begin (send snip set-x cx)
+				       (send snip set-y cy)
+				       (animate-to snip cx cy)
+				       (cons snip (loop (find-next-selected-snip snip))))
+				(begin (bell)
+				       (animate-to snip (send snip get-x) (send snip get-y))
+				       (loop (find-next-selected-snip snip))))
+			    null)))])
+	       (unless (null? moved-snips)
+		 (moved moved-snips)))
+	     (invalidate-bitmap-cache)))])
+
+      (rename [super-on-paint on-paint])
+      (inherit begin-edit-sequence end-edit-sequence)
+      (override
+       [on-paint
+	(lambda (before dc left top right bottom dx dy draw-caret)
+	  (let ([orig-pen (send dc get-pen)]
+		[orig-brush (send dc get-brush)])
+
+	    (when cursor-x/y
+	      (if before
+		  (begin (send dc set-pen highlight-pen)
+			 (send dc set-brush highlight-brush))
+		  (begin (send dc set-pen line-pen)
+			 (send dc set-brush line-brush)))
+	      (let ([snip (get-snip-at (car cursor-x/y) (cdr cursor-x/y))])
+		(when snip
+		  (let ([spots (get-moves snip)])
+		    (for-each (lambda (spot)
+				(let-values ([(x y w h) (grid-xy->pixel-xywh (car spot) (cdr spot))])
+				  (if before
+				      (send dc draw-rectangle (+ x dx) (+ y dy) w h)
+				      (let-values ([(fx fy fw fh) (grid-xy->pixel-xywh (car cursor-x/y) (cdr cursor-x/y))])
+					(send dc draw-line
+					      (+ fx (/ fw 2))
+					      (+ fy (/ fh 2))
+					      (+ x (/ w 2))
+					      (+ y (/ h 2)))))))
+			      spots)))))
+
+	    (when before
+	      (send dc set-pen black-pen)
+
+	      (vector-for-each
+	       (get-x-grid)
+	       (lambda (x)
+		 (send dc draw-line (+ x dx) (+ top dy) (+ x dx) (+ bottom dy))))
+	      
+	      (vector-for-each
+	       (get-y-grid)
+	       (lambda (y)
+		 (send dc draw-line (+ left dx) (+ y dy) (+ right dx) (+ y dy)))))
+
+	    (super-on-paint before dc left top right bottom dx dy draw-caret)
+
+	    (send dc set-pen orig-pen)
+	    (send dc set-brush orig-brush)))])
+
+      (public
+	[on-size
+	 (lambda (w h)
+	   (set! x-grid (calculate-grid x-size w))
+	   (set! y-grid (calculate-grid y-size h))
+	   (let ([xs (/ w x-size)]
+		 [ys (/ h y-size)])
+	     (begin-edit-sequence)
+	     (let loop ([snip (find-first-snip)])
+	       (cond
+		 [(not snip) (void)]
+		 [else
+		  (send snip allow-resize #t)
+		  (send snip resize xs ys)
+		  (send snip allow-resize #f)
+		  (move-to snip 
+			   (* xs (send snip get-x))
+			   (* ys (send snip get-y)))
+		  (loop (send snip next))]))
+	     (end-edit-sequence)))])
+
+      (public
+	[get-x-grid (lambda () x-grid)]
+	[get-y-grid (lambda () y-grid)]
+	[get-pieces (lambda () pieces)])
+
+      (inherit insert resize find-snip)
+      (public
+	[get-snip-at
+	 (lambda (x y)
+	   (let ([snips (get-all-snips-at x y)])
+	     (if (null? snips)
+		 #f
+		 (car snips))))]
+	
+	[get-all-snips-at
+	 (lambda (x y)
+	   (let loop ([snip (find-first-snip)])
+	     (cond
+	       [snip
+		(if (and (= x (send snip get-x))
+			 (= y (send snip get-y)))
+		    (cons snip (loop (send snip next)))
+		    (loop (send snip next)))]
+	       [else null])))]
+
+	[insert-at
+	 (lambda (snip x y)
+	   (send snip set-x x)
+	   (send snip set-y y)
+	   (let ([canvas (get-canvas)])
+	     (if canvas
+		 (let-values ([(bx by) (send canvas get-client-size)])
+		   (let* ([xw (/ bx x-size)]
+			  [yw (/ by y-size)]
+			  [cx (* x xw)]
+			  [cy (* y yw)])
+		     (insert snip cx cy)
+		     (resize snip xw yw)))
+		 (insert snip 0 0)))
+	   (let ([col (vector-ref pieces x)])
+	     (vector-set! col y (cons snip (vector-ref col y)))))])
+      (sequence
+	(apply super-init args))))
+
+  (define grid-canvas%
+    (class editor-canvas% args
+      (inherit get-editor)
+      (rename [super-get-client-size get-client-size])
+      (override
+	[get-client-size
+	 (lambda ()
+	   (let-values ([(w h) (super-get-client-size)])
+	     (values (max 0 (- w 11))
+		     (max 0 (- h 11)))))]
+	[on-size
+	 (lambda (width height)
+	   (let ([media (get-editor)])
+	     (when media
+	       (let-values ([(w h) (get-client-size)])
+		 (send media on-size w h)))))])
+      (sequence (apply super-init args))))
+
+  (define grid-snip%
+    (class snip% (_x _y)
+      (private
+	[width 10]
+	[height 10])
+      (public
+	[allow-resize
+	 (let ([ans #f])
+	   (case-lambda
+	    [(x) (set! ans x)]
+	    [() ans]))]
+	[get-width (lambda () width)]
+	[get-height (lambda () height)])
+      (inherit get-admin)
+      (override
+	[resize 
+	 (lambda (w h)
+	   (and (allow-resize)
+		(begin (set! width w)
+		       (set! height h)
+		       (send (get-admin) resized this #f)
+		       #t)))]
+	[get-extent
+	 (lambda (dc x y w h descent space lspace rspace)
+	   (for-each (lambda (b) (when (box? b) (set-box! b 0)))
+		     (list descent space lspace rspace))
+	   (when (box? w) (set-box! w width))
+	   (when (box? h) (set-box! h height)))])
+
+      (private
+	[x _x]
+	[y _y])
+      (public
+	[get-x (lambda () x)]
+	[get-y (lambda () y)]
+	[set-x (lambda (nx) (set! x nx))]
+	[set-y (lambda (ny) (set! y ny))])
+      (sequence (super-init)))))
diff --git a/collects/games/loa/loa.ss b/collects/games/loa/loa.ss
new file mode 100644
index 0000000000..8ba9a613e2
--- /dev/null
+++ b/collects/games/loa/loa.ss
@@ -0,0 +1,157 @@
+(require-library "pretty.ss")
+
+(unit/sig loa^
+  (import mzlib:function^
+	  mred^
+	  loa:computer-player^
+	  loa:grid^)
+
+  (define color "VIOLET RED")
+
+  (define black-pen (send the-pen-list find-or-create-pen "BLACK" 1 'solid))
+  (define black-brush (send the-brush-list find-or-create-brush "BLACK" 'solid))
+  (define white-pen (send the-pen-list find-or-create-pen color 1 'solid))
+  (define white-brush (send the-brush-list find-or-create-brush color 'solid))
+
+  (define loa-canvas% grid-canvas%)
+
+  (define (get-connected-region board snip)
+    (let ([ht (make-hash-table)])
+      (let loop ([snip snip])
+	(hash-table-get
+	 ht
+	 snip
+	 (lambda ()
+	   (hash-table-put! ht snip #t)
+	   (let* ([x (send snip get-x)]
+		  [y (send snip get-y)]
+		  [check
+		   (lambda (nx ny)
+		     (let* ([next-snip (send board get-snip-at nx ny)]
+			    [condition
+			     (and next-snip
+				  (eq? (send next-snip get-color)
+				       (send snip get-color)))])
+		       (printf "at (~a, ~a) looking (~a, ~a): ~a~n" x y nx ny condition)
+		       (when condition
+			 (loop next-snip))))])
+	     (check (+ x 1) y)
+	     (check (- x 1) y)
+	     (check x (+ y 1))
+	     (check x (- y 1))
+	     (check (+ x 1) (+ y 1))
+	     (check (- x 1) (+ y 1))
+	     (check (+ x 1) (- y 1))
+	     (check (- x 1) (- y 1))))))
+      (hash-table-map ht (lambda (x y) x))))
+
+  (define (get-connected-regions board)
+    (let loop ([regions null]
+	       [snip (send board find-first-snip)])
+      (cond
+       [(not snip) regions]
+       [(ormap (lambda (region) (member snip region))
+	       regions)
+	(loop regions
+	      (send snip next))]
+       [else
+	(loop (cons (get-connected-region board snip) regions)
+	      (send snip next))])))
+
+  (define loa-pasteboard%
+    (class/d grid-pasteboard% (size)
+      ((inherit get-snip-at get-all-snips-at
+		animate-to find-first-snip
+		remove)
+       (public get-size get-color-at
+       (override get-moves moved))
+
+      (define (get-size) size)
+
+      (define (make-move snip x y)
+	(send snip set-x x)
+	(send snip set-y y)
+	(animate-to snip x y))
+
+      (define (do-computer-move)
+	(let-values ([(snip x y) (computer-move this)])
+	  (make-move snip x y)))
+
+      (define (moved moved-snips)
+	(for-each (lambda (moved-snip)
+		    (for-each (lambda (overlapping-snip)
+				(unless (eq? overlapping-snip moved-snip)
+				  (remove overlapping-snip)))
+			      (get-all-snips-at (send moved-snip get-x) (send moved-snip get-y))))
+		  moved-snips)
+	(let ([semaphore (make-semaphore)])
+	  (thread
+	   (lambda ()
+	     (do-computer-move)
+	     (semaphore-post semaphore)))
+	  (yield semaphore)))
+
+      (define (get-color-at i j)
+	(let loop ([snip (find-first-snip)])
+	  (cond
+	   [(not snip) #f]
+	   [else (if (and (= i (send snip get-x))
+			  (= j (send snip get-y)))
+		     (send snip get-color)
+		     (loop (send snip next)))])))
+
+      (define get-moves
+	(let* ([get-color (lambda (board i j) (get-color-at i j))]
+	       [f 
+	       (invoke-unit/sig (require-library "moves.ss" "games" "loa")
+				loa:move-import^
+				mzlib:function^)])
+	  (lambda (snip)
+	    (f (void) (send snip get-x) (send snip get-y)))))
+
+      (super-init size size)))
+
+  (define loa-checker%
+    (class grid-snip% (color x y)
+
+      (inherit get-width get-height)
+      (public
+	[get-color
+	 (lambda () color)])
+      (override
+	[draw
+	 (lambda (dc x y left top right bottom dx dy draw-caret)
+	   (let ([width (get-width)]
+		 [height (get-height)])
+	     (if (eq? color 'black)
+		 (begin (send dc set-pen black-pen)
+			(send dc set-brush black-brush))
+		 (begin (send dc set-pen white-pen)
+			(send dc set-brush white-brush)))
+	     (send dc draw-ellipse x y width height)))])
+
+      (sequence
+	(super-init x y))))
+
+
+  (define frame (make-object frame% "Lines of Action" #f))
+  (define loa-pasteboard (make-object loa-pasteboard% 8))
+  (define loa-canvas (make-object loa-canvas% frame loa-pasteboard))
+
+  (send loa-canvas min-width 300)
+  (send loa-canvas min-height 300)
+
+  (define (make color x y)
+    (send loa-pasteboard insert
+	  (make-object loa-checker% color x y)))
+
+  (let loop ([n 6])
+    (unless (zero? n)
+      (make 'white 0 n)
+      (make 'white 7 n)
+      (make 'black n 0)
+      (make 'black n 7)
+      (loop (- n 1))))
+
+  (send frame show #t))
+
diff --git a/collects/games/loa/main.ss b/collects/games/loa/main.ss
new file mode 100644
index 0000000000..3d8b4e2882
--- /dev/null
+++ b/collects/games/loa/main.ss
@@ -0,0 +1,2 @@
+
+  
\ No newline at end of file
diff --git a/collects/games/loa/run.ss b/collects/games/loa/run.ss
new file mode 100644
index 0000000000..4e6a8c7a30
--- /dev/null
+++ b/collects/games/loa/run.ss
@@ -0,0 +1,45 @@
+#|
+
+Matthew writes about the refreshing problem:
+
+Quoting Robert Bruce Findler:
+> It appears that invalidate bitmap cache in a pasteboard invalidates the
+> smallest square of the pasteboard that contains all of the snips, which
+> might not be the entire visible region of the pasteboard. The
+> documentation (and my preferred behavior) would be that it invalidates
+> the entire visible region, not just the region with snips.
+
+By default (i.e., unless `set-mininum-{width,height}' is called), the
+size of a pasetboard is the size of the smallest square that contains
+the pasteboard's snips. So both the documentation and implementation
+are correct in this case.
+
+A pasteboard may be displayed in a canvas with extra space around the
+pasteboard's area. That area is indeed not invalidated by
+`invalidate-bitmap-cache'. Call `refresh' to foce the updating of a
+canvas.
+
+I don't think `invalidate-bitmap-cache' should invalidate any area
+outside the editor's region; I belive the current behavior is the right
+one. I added a note on the difference to the docs.
+
+|#
+
+
+(require-library "errortrace.ss" "errortrace")
+
+(require-library "sig.ss" "games" "loa")
+
+(invoke-unit/sig
+ (compound-unit/sig
+  (import (mred : mred^))
+  (link
+   [core : mzlib:core^ ((require-library "corer.ss"))]
+   [utils : loa:utils^ ((require-library "utils.ss" "games" "loa"))]
+   [grid : loa:grid^ ((require-library "grid.ss" "games" "loa") (core function) mred utils)]
+   [computer : loa:computer-player^ ((require-library "computer.ss" "games" "loa") loa (core function))]
+   [loa : loa^ ((require-library "loa.ss" "games" "loa") (core function) mred computer grid)])
+  (export))
+ mred^)
+
+(yield (make-semaphore))
\ No newline at end of file
diff --git a/collects/games/loa/sig.ss b/collects/games/loa/sig.ss
new file mode 100644
index 0000000000..bc92aa7862
--- /dev/null
+++ b/collects/games/loa/sig.ss
@@ -0,0 +1,24 @@
+(require-library "cores.ss")
+(require-library "classd.ss")
+
+(define-signature loa:grid^
+  (grid-pasteboard%
+   grid-canvas%
+   grid-snip%))
+
+(define-signature loa^
+  (loa-pasteboard%
+   loa-canvas%
+   loa-checker%
+
+   get-connected-regions))
+
+(define-signature loa:utils^
+  (vector-for-each))
+
+(define-signature loa:computer-player^
+  (computer-move))
+
+(define-signature loa:move-import^
+  (get-color ; : (board num num -> (union 'black 'white #f))
+   ))
\ No newline at end of file
diff --git a/collects/games/loa/utils.ss b/collects/games/loa/utils.ss
new file mode 100644
index 0000000000..9a89094122
--- /dev/null
+++ b/collects/games/loa/utils.ss
@@ -0,0 +1,8 @@
+(unit/sig loa:utils^
+  (import)
+
+  (define (vector-for-each v f)
+    (let loop ([n (vector-length v)])
+      (unless (zero? n)
+	(f (vector-ref v (- n 1)))
+	(loop (- n 1))))))
\ No newline at end of file
diff --git a/collects/games/memory/images/club.png b/collects/games/memory/images/club.png
new file mode 100644
index 0000000000..e1e73ff43f
Binary files /dev/null and b/collects/games/memory/images/club.png differ
diff --git a/collects/games/memory/images/diamond.png b/collects/games/memory/images/diamond.png
new file mode 100644
index 0000000000..84d64a425e
Binary files /dev/null and b/collects/games/memory/images/diamond.png differ
diff --git a/collects/games/memory/images/fish.png b/collects/games/memory/images/fish.png
new file mode 100644
index 0000000000..81c923a273
Binary files /dev/null and b/collects/games/memory/images/fish.png differ
diff --git a/collects/games/memory/images/happy.png b/collects/games/memory/images/happy.png
new file mode 100644
index 0000000000..1ea8891df2
Binary files /dev/null and b/collects/games/memory/images/happy.png differ
diff --git a/collects/games/memory/images/heart.png b/collects/games/memory/images/heart.png
new file mode 100644
index 0000000000..c58548fcb2
Binary files /dev/null and b/collects/games/memory/images/heart.png differ
diff --git a/collects/games/memory/images/jack.png b/collects/games/memory/images/jack.png
new file mode 100644
index 0000000000..76c0b48be7
Binary files /dev/null and b/collects/games/memory/images/jack.png differ
diff --git a/collects/games/memory/images/spade.png b/collects/games/memory/images/spade.png
new file mode 100644
index 0000000000..e231db90fc
Binary files /dev/null and b/collects/games/memory/images/spade.png differ
diff --git a/collects/games/memory/images/star.png b/collects/games/memory/images/star.png
new file mode 100644
index 0000000000..336336a85a
Binary files /dev/null and b/collects/games/memory/images/star.png differ
diff --git a/collects/games/memory/images/two-fish.png b/collects/games/memory/images/two-fish.png
new file mode 100644
index 0000000000..8aee1304ad
Binary files /dev/null and b/collects/games/memory/images/two-fish.png differ
diff --git a/collects/games/memory/images/unhappy.png b/collects/games/memory/images/unhappy.png
new file mode 100644
index 0000000000..e9605526d7
Binary files /dev/null and b/collects/games/memory/images/unhappy.png differ
diff --git a/collects/games/memory/info.ss b/collects/games/memory/info.ss
new file mode 100644
index 0000000000..97250e35a2
--- /dev/null
+++ b/collects/games/memory/info.ss
@@ -0,0 +1,4 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Memory")
+  (define game "memory.ss")
+  (define game-set "Card Games"))
diff --git a/collects/games/memory/memory.png b/collects/games/memory/memory.png
new file mode 100644
index 0000000000..acf9932f64
Binary files /dev/null and b/collects/games/memory/memory.png differ
diff --git a/collects/games/memory/memory.ss b/collects/games/memory/memory.ss
new file mode 100644
index 0000000000..9d3b0935f1
--- /dev/null
+++ b/collects/games/memory/memory.ss
@@ -0,0 +1,176 @@
+
+(module memory mzscheme
+  (require (lib "cards.ss" "games" "cards")
+	   (lib "mred.ss" "mred")
+	   (lib "class.ss")
+           (lib "unit.ss")
+	   (lib "list.ss"))
+  
+  (provide game-unit)
+  
+  (define game-unit
+    (unit
+      (import)
+      (export) 
+
+      ;; Layout width and height:
+      (define WIDTH 5)
+      (define HEIGHT 4)
+      (define MAX-MATCHES (/ (* WIDTH HEIGHT) 2))
+      
+      ;; Randomize
+      (random-seed (modulo (current-milliseconds) 10000))
+      
+      ;; Set up the table
+      (define t (make-table "Memory" (+ 2 WIDTH) (+ 1 HEIGHT)))
+      (send t show #t)
+      (send t set-double-click-action #f)
+      
+      ;; Get table width & height
+      (define w (send t table-width))
+      (define h (send t table-height))
+      
+      ;; Set up the cards
+      (define deck 
+	(let ([cards (map (lambda (name value)
+			    (let ([bm (make-object bitmap%
+						   (build-path 
+						    (collection-path "games" "memory" "images")
+						    (format "~a.png" name)))])
+			      (make-card bm #f 0 value)))
+			  '("club" "heart" "spade" "diamond"
+			    "happy" "unhappy"
+			    "fish" "two-fish"
+			    "jack" "star")
+			  '(1 2 3 4 5 6 7 8 9 10))])
+	  (append cards (map (lambda (c) (send c copy)) cards))))
+      (for-each
+       (lambda (card)
+         (send card user-can-move #f)
+         (send card user-can-flip #t))
+       deck)
+
+      ;; Card width & height
+      (define cw (send (car deck) card-width))
+      (define ch (send (car deck) card-height))
+      
+      (define dx (/ cw (+ 2 WIDTH)))
+      (define dy (/ ch (+ 1 HEIGHT)))
+      
+      (define match-x (- w cw dx))
+      (define match-y dy)
+
+      (define time-h (+ 12 5 5))
+      (define time-x match-x)
+      (define time-y (+ ch dy dy))
+
+      ;; Put the cards on the table
+      (send t add-cards deck match-x match-y)
+
+      ;; Setup
+      (define (setup)
+	(reset-timer)
+	(set! deck (shuffle-list deck 7))
+        (send t stack-cards deck)
+	(send t move-cards deck 0 0
+	      (lambda (pos)
+		(let ([i (modulo pos WIDTH)]
+		      [j (quotient pos WIDTH)])
+		  (values (+ dx (* i (+ cw dx)))
+			  (+ dy (* j (+ ch dy))))))))
+
+      ;; Number of matches found so far:
+      (define matches 0)
+
+      ;; First card flipped, or #f if non flipped, yet
+      (define card-1 #f)
+
+      (define (flip-and-match c)
+	(cond
+	 [(eq? c card-1)
+	  ;; Cancel first card
+	  (send t flip-card c)
+	  (set! card-1 #f)]
+	 [(not (send c face-down?))
+	  ;; Can't click a matched card, unless the game is over, 
+	  ;; in which case we reset the game
+          (when (= matches MAX-MATCHES)
+            (send t flip-cards deck)
+            (set! matches 0)
+            (setup))]
+         [else
+	  ;; Flip over a card...
+          (send t flip-card c)
+          (send t card-to-front c)
+	  (run-timer)
+          (cond
+            [(not card-1)
+	     ;; That was the first card
+             (set! card-1 c)]
+            [(and (equal? (send card-1 get-value)
+                          (send c get-value))
+                  (equal? (send card-1 get-suit)
+                          (send c get-suit)))
+             ;; Match
+             (send t pause 0.5)
+             (send t move-cards (list card-1 c) match-x match-y)
+             (set! card-1 #f)
+             (set! matches (add1 matches))]
+            [else
+             ;; Not a match
+             (send t pause 0.5)
+             (send t flip-cards (list card-1 c))
+             (set! card-1 #f)])]))
+      (send t set-single-click-action flip-and-match)
+      
+      ;; The timer turns out to be the most difficult part:
+      (define (make-time-region secs)
+	(make-region time-x time-y cw time-h
+		     (if (>= secs 6000)
+			 "XX:XX"
+			 (format 
+			  "~a:~a"
+			  (substring (number->string (+ 100 (quotient secs 60))) 1)
+			  (substring (number->string (+ 100 (modulo secs 60))) 1)))
+		     #f))
+      (define start-time #f)   ; in inexact milliseconds; #f means not started
+      (define shown-seconds 0) ; used to compute the delay until the next update
+      (define time-region (make-time-region 0)) ; old region, so we wan remove it
+      (send t add-region time-region) ; start with the initial region added
+      (define (show-time n)
+	;; Compute new time to show:
+	(set! shown-seconds n)
+	;; Update the time by removing the old region and adding a new one:
+	(send t begin-card-sequence)
+	(send t remove-region time-region)	
+	(set! time-region (make-time-region shown-seconds)) 
+	(send t add-region time-region)
+	(send t end-card-sequence))
+      (define (get-update-delta)
+	;; Figure out how many milliseconds to sleep before the next update
+	(max 0
+	     (inexact->exact
+	      (floor
+	       (- (+ start-time (* 1000 shown-seconds) 1000)
+		  (current-inexact-milliseconds))))))
+      (define time-timer 
+	(make-object timer% (lambda ()
+			      (unless (= matches MAX-MATCHES)
+				(show-time
+				 (inexact->exact
+				  (floor (/ (- (current-inexact-milliseconds)
+					       start-time)
+					    1000))))
+				(send time-timer start (get-update-delta) #t)))))
+      (define (reset-timer)
+	(send time-timer stop)
+	(set! start-time #f)
+	(show-time 0))
+      (define (run-timer)
+	(unless start-time
+	  (set! start-time (current-inexact-milliseconds))
+	  (send time-timer start 1000 #t)))
+
+      ;; Start the game:
+      (send t pause 0.25)
+      (setup))))
diff --git a/collects/games/mines/info.ss b/collects/games/mines/info.ss
new file mode 100644
index 0000000000..71a29f3be5
--- /dev/null
+++ b/collects/games/mines/info.ss
@@ -0,0 +1,4 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Minesweeper")
+  (define game-set "Puzzle Games")
+  (define game "mines.ss"))
diff --git a/collects/games/mines/mines.png b/collects/games/mines/mines.png
new file mode 100644
index 0000000000..2abc1d52fd
Binary files /dev/null and b/collects/games/mines/mines.png differ
diff --git a/collects/games/mines/mines.ss b/collects/games/mines/mines.ss
new file mode 100644
index 0000000000..142c0d085c
--- /dev/null
+++ b/collects/games/mines/mines.ss
@@ -0,0 +1,437 @@
+
+;; An example implementation of the ever-popular Minesweeper game.
+
+;; The graphics are primitive, but the event-handling is general.  For
+;; example, clicking on a tile hilites the tile, but moving the mouse
+;; off the tile before releasing the mouse button unhilites the tile
+;; and ignores the click.
+
+;;;;;;;;;;;;;;;;; Configuration ;;;;;;;;;;;;;;;;;;
+
+(module mines mzscheme
+  
+  (require (lib "etc.ss") ; defines build-vector
+	   (lib "class.ss")
+           (lib "unit.ss")
+	   (lib "mred.ss" "mred"))
+  
+  (provide game-unit)
+  
+  ;; The game is implemented in a unit so it can be started multiple times
+  (define game-unit
+    (unit
+      (import)
+      (export)
+      
+      (define TILE-HW 24)        ; height/width of a tile
+      (define B-WIDTH 16)        ; number of tiles across
+      (define B-HEIGHT 16)       ; number of tiles down
+      (define THE-BOMB-COUNT 30) ; number of bombs to hide
+      
+      (define DIGIT-COLOR-NAMES
+        ;; 0th is background; 8th is foreground
+        (vector "LIGHT GRAY"  "BLUE"  "GREEN"  "RED"  "PURPLE" 
+                "ORANGE"  "YELLOW"  "BROWN"  "BLACK"))
+      
+      (define DIGIT-COLORS
+        (build-vector 9 (lambda (i)
+                          (send the-color-database find-color 
+                                (vector-ref DIGIT-COLOR-NAMES i)))))
+      
+      (define BG-COLOR (vector-ref DIGIT-COLORS 0))
+      (define FG-COLOR (vector-ref DIGIT-COLORS 8))
+      (define EXPLODE-COLOR (send the-color-database find-color "RED"))
+      
+      (define BG-PEN (make-object pen% BG-COLOR 1 'solid))
+      (define FG-PEN (make-object pen% FG-COLOR 1 'solid))
+      
+      ;; A general function for looping over numbers:
+      (define (step-while first test until  f accum init)
+        (let loop ([n first][a init])
+          (if (test n until)
+              (loop (add1 n) (accum a (f n)))
+              a)))
+      
+      ;; ;;;;;;;;;;;;;;; Tiles ;;;;;;;;;;;;;;;;;;
+      
+      ;; Class for a tile object
+      (define tile:plain%
+        (class object%
+          (define state 'covered)    ; 'covered, 'flagged, 'semi-flagged, or 'uncovered
+          (define neighbor-bomb-count 0) ; 0 to 8
+          
+          (public*
+           [set-state
+            (lambda (newstate)
+              (set! state newstate))]
+           [get-state
+            (lambda ()
+              state)]
+           [set-neighbor-bomb-count
+            (lambda (c)
+              (set! neighbor-bomb-count c))]
+           [get-neighbor-bomb-count
+            (lambda ()
+              neighbor-bomb-count)]
+           [draw-text-tile
+            (lambda (dc x y w h hilite? border? str color)
+              (if border?
+                  (send dc set-pen FG-PEN)
+                  (send dc set-pen BG-PEN))
+              (send dc draw-rectangle x y w h)
+              (when hilite?
+                (send dc draw-rectangle 
+                      (add1 x) (add1 y) 
+                      (- w 2) (- h 2)))
+              (when str
+                (send dc set-text-foreground (or color FG-COLOR))
+                ;; Draw text centered in the tile's box:
+                (let-values ([(tw th d a) (send dc get-text-extent str)])
+                  (send dc draw-text str 
+                        (+ x (/ (- w tw) 2))
+                        (+ y (/ (- h th) 2))))))]
+           [draw
+            (lambda (dc x y w h hilite?)
+              (case state
+                [(covered) (draw-text-tile dc x y w h hilite? #t #f #f)]
+                [(flagged) (draw-text-tile dc x y w h hilite? #t "X" #f)]
+                [(semi-flagged) (draw-text-tile dc x y w h hilite? #t "?" #f)]
+                [(uncovered) (draw-text-tile 
+                              dc x y w h #f #f
+                              (if (zero? neighbor-bomb-count)
+                                  #f
+                                  (number->string neighbor-bomb-count))
+                              (vector-ref DIGIT-COLORS neighbor-bomb-count))]))])
+          
+          (super-instantiate ())))
+      
+      ;; Class for a tile with a bomb underneath
+      (define tile:bomb%
+        (class tile:plain%
+          (inherit get-state draw-text-tile)
+          (define explode-source? #f) ; draw this bomb as the one that exploded?
+          
+          (public*
+           [set-explode-source
+            (lambda (s?)
+              (set! explode-source? s?))])
+          
+          (override*
+           [draw
+            (lambda (dc x y w h hilite?)
+              (if (eq? (get-state) 'uncovered)
+                  (draw-text-tile dc x y w h #f #f "*"
+                                  (and explode-source? EXPLODE-COLOR))
+                  (super draw dc x y w h hilite?)))])
+          
+          (super-instantiate ())))
+      
+      (define (is-bomb? x)
+        (is-a? x tile:bomb%))
+      
+      ;; ;;;;;;;;;;;;;;; Board Operations ;;;;;;;;;;;;;;;;;;
+      ;; A board is a vector of vectors of tiles
+      
+      (define board #f) ; initialized by calling make-board!
+      
+      (define (get-tile x y)
+        (vector-ref (vector-ref board x) y))
+      
+      (define (set-tile! x y t)
+        (vector-set! (vector-ref board x) y t))
+      
+      (define (do-surrounding x y accum start default f)
+        (step-while -1 <= 1
+                    (lambda (dx)
+                      (step-while -1 <= 1
+                                  (lambda (dy)
+                                    (if (and (not (and (zero? dx) (zero? dy)))
+                                             (< -1 (+ x dx) B-WIDTH)
+                                             (< -1 (+ y dy) B-HEIGHT))
+                                        (f dx dy)
+                                        default))
+                                  accum start))
+                    accum start))
+      
+      (define (count-surrounding-bombs x y)
+        (do-surrounding 
+         x y + 0 0
+         (lambda (dx dy)
+           (if (is-bomb? (get-tile (+ x dx) (+ y dy)))
+               1
+               0))))
+      
+      (define (for-each-tile f)
+        (step-while 0 < B-WIDTH
+                    (lambda (x)
+                      (step-while 0 < B-HEIGHT
+                                  (lambda (y)
+                                    (f (get-tile x y) x y))
+                                  void (void)))
+                    void (void)))
+      
+      (define (make-board!)
+        ;; Create the board
+        (set! board
+              (build-vector B-WIDTH
+                            (lambda (i)
+                              (build-vector B-HEIGHT
+                                            (lambda (j)
+                                              (make-object tile:plain%))))))
+        ;; Randomly insert bombs
+        (let loop ([n THE-BOMB-COUNT])
+          (unless (zero? n)
+            (let rloop ()
+              (let* ([x (random B-WIDTH)]
+                     [y (random B-HEIGHT)]
+                     [t (get-tile x y)])
+                (if (is-a? t tile:bomb%)
+                    (rloop)
+                    (begin
+                      (set-tile! x y (make-object tile:bomb%))
+                      (loop (sub1 n))))))))
+        ;; Set surrounding-bomb counts for each tile:
+        (for-each-tile (lambda (t x y)
+                         (send t
+                               set-neighbor-bomb-count
+                               (count-surrounding-bombs x y)))))
+      
+      ;; ;;;;;;;;;;;;;;; Graphic Interface ;;;;;;;;;;;;;;;;;;
+      
+      ;; Make a frame:
+      (define frame (instantiate
+                        (class frame% 
+                          (augment*
+                           [on-close ; stop the timer, in case it's running
+                            (lambda ()
+                              (send board-canvas stop-timer)
+			      (inner () on-close))])
+                          (super-instantiate ()))
+                      ("Minesweeper") 
+                      [style '(no-resize-border)]))
+      
+      ;; Make the row of controls at the top of the frame:
+      (define panel (make-object horizontal-panel% frame))
+      (send panel stretchable-height #f)
+      (define (make-centering-pane parent)
+        (let ([p (make-object vertical-pane% parent)])
+          (send p set-alignment 'center 'center)
+          p))
+      
+      (define time-display (make-object message% "Time: 00000" (make-centering-pane panel)))
+      (make-object button% "Reset" (make-centering-pane panel)
+        (lambda (b e) (send board-canvas reset)))
+      (define count-display (make-object message% "Count: 000" (make-centering-pane panel)))
+      
+      (define (set-time t)
+        (send time-display set-label (string-append "Time: " (number->string t))))
+      (define (set-count c)
+        (send count-display set-label (string-append "Bombs: " (number->string c))))
+      
+      ;; Most of the work is in this class, which extends the basic canvas
+      ;;  class for drawing the Minesweeper board and handling clicks.
+      (define board-canvas%
+        (class canvas% 
+          (init frame)
+          (inherit get-dc min-client-width min-client-height 
+                   stretchable-width stretchable-height)
+          
+          (define clicking #f)    ; #t => click in progress
+          (define clicking-x 0)   ; x position of click in progress
+          (define clicking-y 0)   ; y position of click in progress
+          (define ready? #t)      ; #t => accept clicks
+          (define start-time #f)  ; time of first click
+          (define elapsed-time 0) ; seconds since first click
+          (define timer #f)       ; a timer that updates elapsed-time
+          (define bomb-count THE-BOMB-COUNT) ; number of bombs minus the number of flags
+          (define cover-count (* B-HEIGHT B-WIDTH)) ; number of uncovered tiles
+          
+          (public*
+           [stop-timer      ; stop the clock
+            (lambda ()
+              (when timer
+                (send timer stop)
+                (set! timer #f)))]
+           [start-timer     ; start the clock
+            (lambda ()
+              (set! start-time (current-seconds))
+              (set! timer
+                    (make-object
+                        (class timer% ()
+                          (override*
+                           [notify
+                            (lambda ()
+                              (let ([e (- (current-seconds) start-time)])
+                                (when (> e elapsed-time)
+                                  (set! elapsed-time e)
+                                  (set-time e))))])
+                          (super-instantiate ()))))
+              (send timer start 100 #f))] ; check time roughly every .1 secs
+           [end-of-game     ; stop the game
+            (lambda (win?)
+              (stop-timer)
+              (set! ready? #f)
+              (set! start-time #f)
+              (unless win?
+                (show-all-bombs))
+              (set-count THE-BOMB-COUNT))]
+           [explode         ; stop the game because the player hit a bomb
+            (lambda ()
+              (end-of-game #f))]
+           [win             ; stop the game because the player won
+            (lambda ()
+              (end-of-game #t))]
+           [reset           ; quit the current game and reset the board
+            (lambda ()
+              (stop-timer)
+              (set! ready? #t)
+              (set! start-time #f)
+              (set! elapsed-time 0)
+              (set! cover-count (* B-HEIGHT B-WIDTH))
+              (send dc clear)
+              (set-time 0)
+              (set! bomb-count THE-BOMB-COUNT)
+              (set-count THE-BOMB-COUNT)
+              (make-board!)
+              (on-paint))]
+           [show-all-bombs  ; show the location of each bomb (after end-of-game)
+            (lambda ()
+              (for-each-tile (lambda (t x y)
+                               (when (is-bomb? t)
+                                 (change-state t (send t get-state) 'uncovered #f)
+                                 (paint-one t x y)))))]
+           [autoclick-surrounding   ; autoclick tiles (after a 0 tile is uncovered)
+            (lambda (x y)
+              (do-surrounding 
+               x y void (void) (void)
+               (lambda (dx dy)
+                 (let* ([x2 (+ x dx)]
+                        [y2 (+ y dy)]
+                        [t (get-tile x2 y2)]
+                        [state (send t get-state)]
+                        [nc (send t get-neighbor-bomb-count)])
+                   (unless (eq? state 'uncovered)
+                     (change-state t state 'uncovered #t)
+                     (paint-one t x2 y2)
+                     (when (zero? nc)
+                       (autoclick-surrounding x2 y2)))))))]
+           [change-state         ; update counters after a tile changes
+            (lambda (t old-state new-state update-count?)
+              (send t set-state new-state)
+              (when (and update-count? (not (eq? new-state old-state)))
+                (when (eq? new-state 'uncovered)
+                  (set! cover-count (sub1 cover-count)))
+                (when (eq? old-state 'uncovered)
+                  (set! cover-count (add1 cover-count)))
+                (when (eq? new-state 'flagged)
+                  (set! bomb-count (sub1 bomb-count))
+                  (set-count bomb-count))
+                (when (eq? old-state 'flagged)
+                  (set! bomb-count (add1 bomb-count))
+                  (set-count bomb-count))))]
+           [do-select            ; handle a click on a tile
+            (lambda (x y flag?)
+              (let* ([t (get-tile x y)]
+                     [state (send t get-state)]
+                     [new-state
+                      (case state
+                        [(covered)
+                         (if flag? 'flagged 'uncovered)]
+                        [(flagged)
+                         (if flag? 'semi-flagged state)]
+                        [(semi-flagged)
+                         (if flag? 'covered 'uncovered)]
+                        [else state])]
+                     [nc (send t get-neighbor-bomb-count)]
+                     [new-uncover? (and (eq? new-state 'uncovered)
+                                        (not (eq? state 'uncovered)))]
+                     [bomb? (is-bomb? t)])
+                (change-state t state new-state #t)
+                (when (and new-uncover? bomb?)
+                  (send t set-explode-source #t))
+                (paint-one t x y)
+                (when new-uncover?
+                  (if bomb?
+                      (explode)
+                      (begin
+                        (when (zero? nc)
+                          (autoclick-surrounding x y))))
+                  (when (and ready? (= cover-count THE-BOMB-COUNT))
+                    (win)))))]
+           [paint-one        ; draw one tile
+            (lambda (t x y)
+              (let ([xloc (* x TILE-HW)]
+                    [yloc (* y TILE-HW)])
+                (send t draw dc xloc yloc TILE-HW TILE-HW
+                      (eq? t clicking))))])
+          
+          (override*
+           [on-event        ; handle a click
+            (lambda (e)
+              (when ready?
+                (unless start-time    ; if the timer's not running, start it
+                  (when (send e button-down?)
+                    (start-timer)))
+                ;; Find the time for an (x,y) pixel position in the canvas
+                (let* ([x (quotient (inexact->exact (floor (send e get-x))) 
+                                    TILE-HW)]
+                       [y (quotient (inexact->exact (floor (send e get-y)))
+                                    TILE-HW)]
+                       [t (if (and (< -1 x B-WIDTH)
+                                   (< -1 y B-HEIGHT))
+                              (get-tile x y)
+                              #f)]) ; not a tile
+                  (cond
+                    [(and clicking (or (not (eq? t clicking))
+                                       (not (or (send e button-up?)
+                                                (send e dragging?)))))
+                     ;; We're already in the middle of a click, and the mouse
+                     ;;   was moved. Paint the tile to show whether releasing the
+                     ;;   mouse button selects the tile.
+                     (let ([old clicking])
+                       (set! clicking #f)
+                       (paint-one old clicking-x clicking-y))]
+                    [(and t
+                          (not (eq? (send t get-state) 'uncovered))
+                          (or (send e button-down?)
+                              (and (send e dragging?)
+                                   (= x clicking-x)
+                                   (= y clicking-y))))
+                     ;; Start a click on a covered tile
+                     (set! clicking t)
+                     (set! clicking-x x)
+                     (set! clicking-y y)
+                     (paint-one t x y)]
+                    [(send e button-down?) 
+                     ;; fallthough to here => clicking, but not on a tile
+                     (set! clicking-x -1)]
+                    [(and clicking (send e button-up?))
+                     ;; User released the button
+                     (set! clicking #f)
+                     (do-select x y (send e button-up? 'right))]
+                    [else 'ok]))))]
+           [on-paint       ; refresh the board
+            (lambda ()
+              (for-each-tile (lambda (tile x y) (paint-one tile x y))))])
+          
+          (super-instantiate (frame))
+          
+          ;; Make canvas size always match the board size:
+          (min-client-width (* TILE-HW B-WIDTH))
+          (min-client-height (* TILE-HW B-HEIGHT))
+          (stretchable-width #f)
+          (stretchable-height #f)
+          
+          (define dc (get-dc))
+          
+          (reset)  ; initialize the game
+          (send dc set-text-background BG-COLOR)
+          (send dc set-brush (send the-brush-list find-or-create-brush 
+                                   BG-COLOR 'solid))))
+      
+      ;; Make the board canvas:
+      (define board-canvas (make-object board-canvas% frame))
+      
+      ;; Show the frame (and handle events):
+      (send frame show #t))))
+    
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/all-problems.ss b/collects/games/paint-by-numbers/all-problems.ss
new file mode 100644
index 0000000000..284065fbd7
--- /dev/null
+++ b/collects/games/paint-by-numbers/all-problems.ss
@@ -0,0 +1,94 @@
+(module all-problems mzscheme
+  (require (lib "etc.ss")
+           (lib "list.ss")
+           (lib "unitsig.ss")
+           (lib "include.ss")
+           "problem.ss")
+
+  (require-for-syntax (lib "etc.ss"))
+
+  (define-signature paint-by-numbers:all-problems^ (problemss set-names))
+  (define-signature paint-by-numbers:problem-set^ (problems set-name))
+  (define-signature paint-by-numbers:problem^ ((struct problem (name rows cols solution))))
+
+  (define-syntax (mk-units stx)
+    (syntax-case stx ()
+      [(_)
+       (with-syntax ([(unit-names ...)
+                      (let loop ([files
+                                  (call-with-input-file
+                                      (build-path (collection-path "games" "paint-by-numbers")
+                                                  "problems" "directory")
+                                    read)])
+                        (cond
+                          [(null? files) null]
+                          [(or (member (car files) '("CVS" ".svn"))
+                               (not (file-exists? (build-path (collection-path "games" "paint-by-numbers")
+                                                              "problems" (car files)))))
+                           (loop (cdr files))]
+                          [else
+                           (cons (car files)
+                                 (loop (cdr files)))]))])
+         (syntax (list (include (build-path "problems" unit-names)) ...)))]))
+  
+  (define units (mk-units))
+  
+  (define empty-unit
+    (unit/sig paint-by-numbers:all-problems^
+      (import [p : paint-by-numbers:problem^])
+      
+      (define problemss null)
+      (define set-names null)))
+  
+  
+  (define (combine-units new-unit sofar)
+    (compound-unit/sig 
+      (import [p : paint-by-numbers:problem^])
+      (link [new : paint-by-numbers:problem-set^ (new-unit p)]
+            [old : paint-by-numbers:all-problems^ (sofar p)]
+            [combine : paint-by-numbers:all-problems^
+                     ((unit/sig paint-by-numbers:all-problems^
+                        (import [old : paint-by-numbers:all-problems^]
+                                [new : paint-by-numbers:problem-set^]
+                                paint-by-numbers:problem^)
+                        
+                        (define (expand-problem pbm)
+                          (make-problem (problem-name pbm)
+                                        (problem-rows pbm)
+                                        (problem-cols pbm)
+                                        (expand-solution (problem-solution pbm))))
+  
+                        (define problemss 
+                          (if (null? new:problems)
+                              old:problemss
+                              (cons (map expand-problem new:problems) old:problemss)))
+                        (define set-names
+                          (if (null? new:problems)
+                              old:set-names
+                              (cons new:set-name old:set-names))))
+                      old
+                      new
+                      p)])
+      (export
+       (open combine))))
+  
+  ;; expand-solution : (union #f (listof string[row])) -> 
+  ;;                   (union #f (vectorof (vectorof (union 'on 'off 'unknown))))
+  (define (expand-solution sol)
+    (and sol (apply vector (map expand-row sol))))
+  ;; expand-row : string -> (vectorof (union 'on 'off 'unknown))
+  (define (expand-row str)
+    (list->vector (map expand-char (string->list str))))
+  ;; expand-char : char -> (union 'on 'off 'unknown)
+  (define (expand-char c)
+    (case c
+      [(#\x) 'on]
+      [(#\space) 'off]
+      [(#\U) 'unknown]))
+
+  (provide-signature-elements paint-by-numbers:all-problems^)
+  
+  (define-values/invoke-unit/sig paint-by-numbers:all-problems^
+                                 (foldr combine-units empty-unit units)
+                                 #f
+                                 paint-by-numbers:problem^))
diff --git a/collects/games/paint-by-numbers/doc.txt b/collects/games/paint-by-numbers/doc.txt
new file mode 100644
index 0000000000..1dd1be205a
--- /dev/null
+++ b/collects/games/paint-by-numbers/doc.txt
@@ -0,0 +1,95 @@
+** To play _Paint By Numbers_, run the "Games" application. **
+
+The object of Paint By Numbers is to discover which cells should be
+colored blue and which should be colored white. Initially, all squares are
+grey, indicating that the correct colors are not known. The lists of
+numbers to the left and above the grid are your clues to the correct color
+of each square. Each list of numbers specifies the pattern of blue squares
+in the row beside it or the column below it. Each number indicates the
+length of a group of blue squares. For example, if the list of numbers
+beside the first row is "2 3" then you know that there is a contiguous
+block of two blue squares followed by a contiguous block of three blue
+squares with at least one white square between them. The label does not
+tell you where the blue squares are, only their shapes. The trick is to
+gather as much information as you can about each row, and then use that
+information to determine more about each column. Eventually you should be
+able to fill in the entire puzzle.
+
+Click on a square to toggle it between blue and gray. Hold down a modifier
+key (shift, command, meta, or alt depending on the platform) to toggle a
+square between white and gray. The third button under unix and the right
+button under windows also toggles between white and gray.
+
+For some puzzles, hints are available. Choose the Nongram|Show Mistakes
+menu item to receive the hints. This will turn all incorrectly colored
+squares red.
+
+Thanks to Shoichiro Hattori for his puzzles! Visit him on the web at: 
+
+  http://hattori.m78.com/puzzle/
+
+Thanks also to many of the contributors to the Kajitani web site for
+permission to re-distribute their puzzles. Visit them online at:
+
+  http://www02.so-net.ne.jp/~kajitani/index.html
+
+The specific contributers who have permitted their puzzles to be
+redistributed are:
+
+ snordmey /at/ dayton <dot> net
+ jtraub /at/ dragoncat <dot> net
+ e0gb258s /at/ mail <dot> erin <dot> utoronto <dot> ca
+ mattingly /at/ bigfoot <dot> com
+ jennifer <dot> forman /at/ umb <dot> edu
+ karen <dot> hoover /at/ bigfoot <dot> com
+ sssstree /at/ ix <dot> netcom <dot> com
+ we_bakers_3 /at/ earthlink <dot> net
+ bbart /at/ cs <dot> sfu <dot> ca
+ jonesjk /at/ thegrid <dot> net
+ rrichard /at/ lexitech <dot> ca
+ helena <dot> montauban /at/ auroraenergy <dot> com <dot> au
+ barblane /at/ ionsys <dot> com
+ m5rammy /at/ maale5 <dot> com
+ nmbauer /at/ sprynet <dot> com
+ ncfrench /at/ aol <dot> com
+ km29 /at/ drexel <dot> edu
+ jjl /at/ stanford <dot> edu
+ disneyfan13 /at/ hotmail <dot> com
+ richard /at/ condor-post <dot> com
+ lady_tabitha /at/ yahoo <dot> com
+ vaa /at/ psulias <dot> psu <dot> edu
+ kimbhall /at/ yahoo <dot> com
+ kcottam /at/ cusa <dot> com
+ karganov /at/ hotmail <dot> com
+ jdmaynard /at/ excite <dot> com
+ mnemoy /at/ gameworks <dot> com
+ arrelless /at/ jayco <dot> net
+ azisi /at/ skiathos <dot> physics <dot> auth <dot> gr
+ whoaleo /at/ hotmail <dot> com
+ tucker1999 /at/ earthlink <dot> net
+ bergles /at/ yahoo <dot> com
+ elisabeth <dot> springfelter /at/ lanab <dot> amv <dot> se
+ ewhaynes /at/ mit <dot> edu
+ mjcarroll /at/ ccnmail <dot> com
+ dahu /at/ netcourrier <dot> com
+ joy /at/ dcs <dot> gla <dot> ac <dot> uk
+ piobst /at/ wam <dot> umd <dot> edu
+ dani681 /at/ aol <dot> com
+ Talzhemir <pixel /at/ realtime <dot> net>
+ hkittredge /at/ hotmail <dot> com
+ allraft /at/ sccoast <dot> net
+ karlvonl /at/ geocities <dot> com
+ ailsa /at/ worldonline <dot> nl
+ Carey Willis <N8NRG /at/ hotmail <dot> com>
+ citragreen /at/ hotmail <dot> com
+ dhalayko /at/ cgocable <dot> net
+ jontive1 /at/ elp <dot> rr <dot> com
+ hublan /at/ rocketmail <dot> com
+ barbridgway /at/ compuserve <dot> com
+ mijoy /at/ mailcity <dot> com
+ joostdh /at/ sci <dot> kun <dot> nl
+ gossamer_kwaj /at/ hotmail <dot> com
+ williamson /at/ proaxis <dot> com
+ vacko_6 /at/ hotmail <dot> com
+ jojess /at/ earthlink <dot> net
+
diff --git a/collects/games/paint-by-numbers/gui.ss b/collects/games/paint-by-numbers/gui.ss
new file mode 100644
index 0000000000..927dc4978f
--- /dev/null
+++ b/collects/games/paint-by-numbers/gui.ss
@@ -0,0 +1,866 @@
+#|
+
+The paint-by-numbers-canavas% class accepts two initalization
+arguments. They must be lists of lists of numbers and they must be the
+same length. paint-by-numbers-canvas% objects accepts four methods:
+
+set-rect : (int int (union 'on 'off 'unknown) -> void)
+Sets the grid point specified by the first two arguments to the third.
+The coordinates are from the top-left and the x coordinate comes first.
+
+get-rect : (int int ->  (union 'on 'off 'unknown))
+Gets the value of the grid at the coordinates specified by the two integers
+
+paint-rect : (int int -> void)
+Draws the rectangle specified by the arguments.
+Call this after calling set-rect to see the changes updated on the screen.
+
+get-grid : (-> (list-of (list-of (union 'on 'off 'unknown 'wrong))))
+Returns the current state of the entire board as a list of lists.
+
+set-grid : ((vector-of (vector-of (union 'on 'off 'unknown 'wrong)))-> void)
+Sets the state of the board. No drawing takes place
+
+on-paint : (-> void)
+Redraws the entire canvas. May be used if many rects were set.
+
+all-unknown : (-> void)
+Sets all board positions to 'unknown
+
+close-up : (-> void)
+call when canvas is closed.
+
+See the bottom of this file for the creation of a file and a test
+paint by numbers.
+
+|#
+
+(module gui mzscheme
+  (require (lib "mred.ss" "mred")
+           (lib "framework.ss" "framework")
+           (lib "etc.ss")
+           (lib "class.ss"))
+
+  (provide paint-by-numbers-canvas%
+           design-paint-by-numbers-canvas%)
+  
+  (define UNKNOWN-BRUSH (send the-brush-list find-or-create-brush "DARK GRAY" 'solid))
+  (define ON-BRUSH (send the-brush-list find-or-create-brush "BLUE" 'solid))
+  (define OFF-BRUSH (send the-brush-list find-or-create-brush "WHITE" 'solid))
+  (define WRONG-BRUSH (send the-brush-list find-or-create-brush "RED" 'solid))
+  
+  (define LINES/NUMBERS-PEN (send the-pen-list find-or-create-pen "BLACK" 1 'solid))
+  
+  (define BLACK-PEN (send the-pen-list find-or-create-pen "BLACK" 1 'solid))
+  (define WHITE-PEN (send the-pen-list find-or-create-pen "WHITE" 1 'solid))
+  (define WHITE-BRUSH (send the-brush-list find-or-create-brush "WHITE" 'solid))
+  
+  (define BAR-PEN (send the-pen-list find-or-create-pen "SALMON" 1 'solid))
+  (define BAR-BRUSH (send the-brush-list find-or-create-brush "SALMON" 'solid))
+  
+  (define-struct ado (x y before after))
+  
+  (define-struct pt (x y))
+  
+  (define paint-by-numbers-canvas%
+    (class canvas%
+      (init-field row-numbers col-numbers)
+      (inherit get-dc get-client-size)
+      
+      (define/private (get-font) (send (get-dc) get-font))
+      
+      (define/public (get-row-numbers) row-numbers)
+      (define/public (get-col-numbers) col-numbers)
+      
+      (define/public (get-max-col-entries)
+        (apply max (map length (get-col-numbers))))
+      
+      [define extra-space-every 5]
+      
+      [define grid-x-size (length (get-col-numbers))]
+      [define grid-y-size (length (get-row-numbers))]
+      [define y-margin 1]
+      [define x-margin 3]
+      [define row-label-width 10]
+      [define row-label-height 10]
+      [define col-label-width 10]
+      [define col-label-height 10]
+      
+      [define/private (get-row-label-string l)
+        (if (null? l)
+            ""
+            (let ([first (car l)]
+                  [rest (cdr l)])
+              (apply string-append 
+                     (number->string first)
+                     (map (lambda (x) (format " ~a" x)) rest))))]
+      
+      [define/private get-col-label-strings
+        (lambda (l)
+          (map number->string l))]
+      
+      [define grid (build-vector grid-x-size (lambda (i) (make-vector grid-y-size UNKNOWN-BRUSH)))]
+      
+      [define/private get-string-height
+        (lambda (s)
+          (let ([dc (get-dc)])
+            (let-values ([(width height descent ascent) 
+                          (send dc get-text-extent s)])
+              (- height descent))))]
+      [define/private get-string-height/descent
+        (lambda (s)
+          (let ([dc (get-dc)])
+            (let-values ([(width height descent ascent) 
+                          (send dc get-text-extent s)])
+              height)))]
+      [define/private get-string-ascent
+        (lambda (s)
+          (let ([dc (get-dc)])
+            (let-values ([(width height descent ascent) 
+                          (send dc get-text-extent s)])
+              ascent)))]
+      [define/private get-string-width
+        (lambda (s)
+          (let ([dc (get-dc)])
+            (let-values ([(width height descent ascent) 
+                          (send dc get-text-extent s)])
+              width)))]
+      
+      [define/private loc->string
+        (lambda (x y)
+          (format "(~a,~a)" x y))]
+      
+      [define/private xy->grid
+        (lambda (x y)
+          (let* ([grid-width (/ (- (get-canvas-width) row-label-width) grid-x-size)]
+                 [grid-height (/ (- (get-canvas-height) col-label-height) grid-y-size)]
+                 [xp (- x row-label-width)]
+                 [yp (- y col-label-height)]
+                 [x (inexact->exact (floor (/ xp grid-width)))]
+                 [y (inexact->exact (floor (/ yp grid-height)))])
+            (if (and (<= 0 x)
+                     (< x grid-x-size)
+                     (<= 0 y)
+                     (< y grid-y-size))
+                (make-pt x y)
+                #f)))]
+      
+      [define/private grid->rect
+        (lambda (x y)
+          (let* ([grid-width (- (get-canvas-width)
+                                row-label-width
+                                (quotient grid-x-size extra-space-every))]
+                 [grid-height (- (get-canvas-height)
+                                 col-label-height
+                                 (quotient grid-y-size extra-space-every))]
+                 [left (+ row-label-width
+                          (quotient x extra-space-every)
+                          (* x (/ grid-width grid-x-size)))]
+                 [top (+ col-label-height
+                         (quotient y extra-space-every)
+                         (* y (/ grid-height grid-y-size)))]
+                 [width (/ grid-width grid-x-size)]
+                 [height (/ grid-height grid-y-size)])
+            (values left top width height)))]
+
+      (define/private (get-canvas-width) (let-values ([(w h) (get-client-size)]) w))
+      (define/private (get-canvas-height) (let-values ([(w h) (get-client-size)]) h))
+      
+      [define undo-history null]
+      [define redo-history null]
+      [define/private do-do
+        (lambda (do current-sel new-sel)
+          (let* ([x (ado-x do)]
+                 [y (ado-y do)]
+                 [actual (get-raw-rect x y)]
+                 [current (current-sel do)]
+                 [new (new-sel do)]
+                 [color->val
+                  (lambda (brush)
+                    (let ([color (send brush get-color)])
+                      (list (send color red)
+                            (send color green)
+                            (send color blue))))])
+            (unless (eq? current actual)
+              (error 'do-do "expected ~a found ~a at (~a,~a)"
+                     (color->val current)
+                     (color->val actual)
+                     x y))
+            (set-raw-rect x y new)
+            (paint-rect x y)))]
+      
+      [define/private brush->symbol
+        (lambda (res)
+          (cond
+	    [(eq? res UNKNOWN-BRUSH) 'unknown]
+	    [(eq? res OFF-BRUSH) 'off]
+	    [(eq? res ON-BRUSH) 'on]
+	    [(eq? res WRONG-BRUSH) 'wrong]))]
+      [define/private sym->brush
+        (lambda (sym)
+          (case sym
+            [(unknown) UNKNOWN-BRUSH]
+            [(off) OFF-BRUSH]
+            [(on) ON-BRUSH]
+            [(wrong) WRONG-BRUSH]))]
+      
+      [define/private in-rect?
+        (lambda (p cp1 cp2)
+          (or (and (<= (pt-x cp1) (pt-x p) (pt-x cp2))
+                   (<= (pt-y cp1) (pt-y p) (pt-y cp2)))
+              (and (<= (pt-x cp2) (pt-x p) (pt-x cp1))
+                   (<= (pt-y cp2) (pt-y p) (pt-y cp1)))))]
+      
+      ;; ((list-of (list-of (union 'unknown 'off 'on 'wrong))) -> void)
+      [define/public set-grid
+        (lambda (g)
+          (set! undo-history null)
+          (set! redo-history null)
+          (set! grid
+                (list->vector
+                 (map (lambda (x) (list->vector (map (lambda (x) (sym->brush x)) x)))
+                      g))))]
+      
+      ;; (-> (list-of (list-of (union 'unknown 'off 'on 'wrong))))
+      [define/public get-grid
+        (lambda ()
+          (map (lambda (x) (map (lambda (x) (brush->symbol x)) (vector->list x)))
+               (vector->list grid)))]
+      
+      ;; (-> void)
+      [define/public undo
+        (lambda ()
+          (cond
+	    [(null? undo-history) (bell)]
+	    [else
+	     (let ([do (car undo-history)])
+	       (set! undo-history (cdr undo-history))
+	       (set! redo-history (cons do redo-history))
+	       (do-do do ado-after ado-before))]))]
+      
+      ;; (-> void)
+      [define/public redo
+        (lambda ()
+          (cond
+	    [(null? redo-history) (bell)]
+	    [else
+	     (let ([do (car redo-history)])
+	       (set! redo-history (cdr redo-history))
+	       (set! undo-history (cons do undo-history))
+	       (do-do do ado-before ado-after))]))]
+      
+      [define/public paint-rect
+        (lambda (i j)
+          (send (get-dc) set-pen LINES/NUMBERS-PEN)
+          (paint-rect/lines-numbers-pen i j))]
+      
+      ;; (int int -> void)
+      [define/public paint-rect/lines-numbers-pen
+        (lambda (i j)
+          (let ([dc (get-dc)])
+            (let-values ([(left top width height) (grid->rect i j)])
+              (cond
+                [(and draw-small-start-p
+                      draw-small-end-p
+                      (in-rect? (make-pt i j)
+                                draw-small-start-p
+                                draw-small-end-p))
+		 (send dc set-pen WHITE-PEN)
+		 (send dc set-brush WHITE-BRUSH)
+		 (send dc draw-rectangle left top width height)
+                 
+		 (let ([spacing 2])
+		   (send dc set-pen LINES/NUMBERS-PEN)
+		   (send dc set-brush (new-brush (get-raw-rect (pt-x draw-small-start-p)
+                                                               (pt-y draw-small-start-p))
+                                                 modifier-on?))
+		   (send dc draw-rectangle
+			 (+ left spacing)
+			 (+ top spacing)
+			 (- width spacing spacing)
+			 (- height spacing spacing)))]
+                
+		[else
+		 (send dc set-brush (get-raw-rect i j))
+		 (send dc draw-rectangle left top width height)]))))]
+      
+      
+      ;; (int int -> (instance brush%))
+      [define/public get-raw-rect
+        (lambda (i j)
+          '(unless (and (<= 0 i)
+			(< i grid-x-size)
+			(<= 0 j)
+			(< j grid-y-size))
+	     (error 'get-raw-rect "cannot get (~a, ~a) in ~ax~a board"
+		    i j grid-x-size grid-y-size))
+          (vector-ref (vector-ref grid i) j))]
+      
+      ;; (int int -> (union 'on 'off 'unknown 'wrong))
+      [define/public get-rect
+        (lambda (i j)
+          (brush->symbol (get-raw-rect i j)))]
+      
+      ;; (int int (instance brush%) -> void)
+      [define/public set-raw-rect
+        (lambda (i j brush)
+          '(unless (and (<= 0 i)
+			(< i grid-x-size)
+			(<= 0 j)
+			(< j grid-y-size))
+	     (error 'set-raw-rect "cannot set (~a, ~a) in ~ax~a board"
+		    i j grid-x-size grid-y-size))
+          (vector-set! (vector-ref grid i) j brush))]
+      
+      ;; (int int (union 'on 'off 'unknown 'wrong) -> void)
+      [define/public set-rect
+        (lambda (i j sym)
+          (set-raw-rect i j (sym->brush sym)))]
+      
+      
+      ;; (int int -> void)
+      [define/public set-to-error
+        (lambda (i j)
+          (let ([brush (sym->brush 'wrong)])
+            (set! undo-history (cons (make-ado i j (get-raw-rect i j) brush) undo-history))
+            (set-raw-rect i j brush)
+            (paint-rect i j)))]
+      
+      ;; (-> void)
+      [define/public all-unknown
+        (lambda ()
+          (let loop ([i grid-x-size])
+            (cond
+	      [(zero? i) (void)]
+	      [else
+	       (let loop ([j grid-y-size])
+		 (cond
+                   [(zero? j) (void)]
+                   [else (set-rect (- i 1) (- j 1) 'unknown)
+                         (loop (- j 1))]))
+	       (loop (- i 1))])))]
+      
+      [define highlight-row #f]
+      [define highlight-col #f]
+      (define/public draw-row-label
+        (lambda (n)
+          (let-values ([(gx gy gw gh) (grid->rect 0 n)])
+            (when (and (gx . >= . 0)
+                       (gy . >= . 0)
+                       (gw . >= . 0)
+                       (gh . >= . 0))
+              (let* ([nums (list-ref (get-row-numbers) n)]
+                     [dc (get-dc)]
+                     [str (get-row-label-string nums)]
+                     [str-height (get-string-height str)]
+                     [str-ascent (get-string-ascent str)]
+                     [str-width (get-string-width str)]
+                     [sy (+ gy
+                            (- (/ gh 2)
+                               (/ str-height 2)))]
+                     [sx (- row-label-width str-width x-margin)]
+                     
+                     [x 0]
+                     [y gy]
+                     [w gx]
+                     [h gh])
+                
+                (if (and highlight-row
+                         (= highlight-row n))
+                    (begin
+                      (send dc set-pen BAR-PEN)
+                      (send dc set-brush BAR-BRUSH))
+                    (begin
+                      (send dc set-pen WHITE-PEN)
+                      (send dc set-brush WHITE-BRUSH)))
+                
+                (send dc draw-rectangle x y w h)
+                (send dc draw-text str sx sy))))))
+      
+      [define/public draw-col-label
+        (lambda (n)
+          (let-values ([(gx gy gw gh) (grid->rect n 0)])
+            (when (and (gx . >= . 0)
+                       (gy . >= . 0)
+                       (gw . >= . 0)
+                       (gh . >= . 0))
+              (let* ([nums (list-ref (get-col-numbers) n)]
+                     [strs (get-col-label-strings nums)]
+                     [dc (get-dc)])
+                
+                (if (and highlight-col
+                         (= highlight-col n))
+                    (begin
+                      (send dc set-pen BAR-PEN)
+                      (send dc set-brush BAR-BRUSH))
+                    (begin
+                      (send dc set-pen WHITE-PEN)
+                      (send dc set-brush WHITE-BRUSH)))
+                
+                (send dc draw-rectangle gx 0 gw gy)
+                (let loop ([ss strs]
+                           [line (- (get-max-col-entries) (length strs))])
+                  (cond
+                    [(null? ss) (void)]
+                    [else
+                     (let* ([s (car ss)]
+                            [str-width (get-string-width s)]
+                            [str-height (get-string-height s)]
+                            [x (+ gx
+                                  (- (/ gw 2)
+                                     (/ str-width 2)))]
+                            [y (* line (+ str-height y-margin))])
+                       (send dc draw-text (car ss) x y)
+                       (loop (cdr ss)
+                             (+ line 1)))]))))))]
+      
+      [define/private new-brush
+        (lambda (prev modifier?)
+          (cond
+            [(eq? prev UNKNOWN-BRUSH)
+             (if modifier?
+                 OFF-BRUSH
+                 ON-BRUSH)]
+            [(eq? prev ON-BRUSH) UNKNOWN-BRUSH]
+            [(eq? prev OFF-BRUSH) UNKNOWN-BRUSH]
+            [(eq? prev WRONG-BRUSH) UNKNOWN-BRUSH]
+            [else
+             (error 'internal-error
+                    "unkown brush in board ~s~n" prev)]))]
+      
+      [define/private check-modifier
+        (lambda (evt)
+          (or (send evt get-right-down)
+              (send evt button-up? 'right)
+              (send evt get-alt-down)
+              (send evt get-meta-down)
+              (send evt get-control-down)
+              (send evt get-shift-down)))]
+      
+      [define modifier-on? #f]
+      [define last-p #f]
+      
+      
+      ;; (union #f                   if button not down
+      ;;        (make-pt num num))   if button down
+      [define draw-small-start-p #f]
+      
+      ;; (union #f                   if button dragged outside board
+      ;;        (make-pt num num))   if button dragged in board
+      [define draw-small-end-p #f]
+      
+      [define coordinate-p #f]
+      
+      [define/private update-range-of-rects
+        (lambda (p1 p2)
+          (let ([x-small (min (pt-x p1) (pt-x p2))]
+                [x-large (max (pt-x p1) (pt-x p2))]
+                [y-small (min (pt-y p1) (pt-y p2))]
+                [y-large (max (pt-y p1) (pt-y p2))])
+            (let loop ([x x-small])
+              (when (<= x x-large)
+                (let loop ([y y-small])
+                  (when (<= y y-large)
+                    (paint-rect x y)
+                    (loop (+ y 1))))
+                (loop (+ x 1))))))]
+      
+      [define/override on-event
+	(lambda (evt)
+	  (let* ([x (send evt get-x)]
+		 [y (send evt get-y)]
+		 [p (xy->grid x y)])
+	    (cond
+              [(or (send evt moving?)
+                   (send evt entering?)
+                   (send evt leaving?))
+               
+               ;; update depressed squares
+               (when draw-small-start-p
+                 (let ([old-draw-small-end-p draw-small-end-p])
+                   (cond
+                     [(and draw-small-start-p
+                           p
+                           (or (= (pt-x p) (pt-x draw-small-start-p))
+                               (= (pt-y p) (pt-y draw-small-start-p))))
+                      (unless (equal? draw-small-end-p p)
+                        (set! draw-small-end-p p)
+                        (when old-draw-small-end-p
+                          (update-range-of-rects draw-small-start-p old-draw-small-end-p))
+                        (when draw-small-end-p
+                          (update-range-of-rects draw-small-start-p draw-small-end-p)))]
+                     [draw-small-start-p
+                      (set! draw-small-end-p #f)
+                      (when old-draw-small-end-p
+                        (update-range-of-rects draw-small-start-p old-draw-small-end-p))])))
+               
+               (let ([dc (get-dc)])
+                 
+                 ;; update the bars
+                 (let ([new-highlight-col
+                        (if (and p
+                                 (not (send evt leaving?)))
+                            (pt-x p)
+                            #f)]
+                       [old-highlight-col highlight-col])
+                   (unless (equal? old-highlight-col new-highlight-col)
+                     (set! highlight-col new-highlight-col)
+                     (when new-highlight-col
+                       (draw-col-label new-highlight-col))
+                     (when old-highlight-col
+                       (draw-col-label old-highlight-col))))
+                 
+                 (let ([new-highlight-row
+                        (if (and p
+                                 (not (send evt leaving?)))
+                            (pt-y p)
+                            #f)]
+                       [old-highlight-row highlight-row])
+                   (unless (equal? old-highlight-row new-highlight-row)
+                     (set! highlight-row new-highlight-row)
+                     (when new-highlight-row
+                       (draw-row-label new-highlight-row))
+                     (when old-highlight-row
+                       (draw-row-label old-highlight-row))))
+                 
+                 (set! last-p p)
+                 
+                 ;; update the coordinates
+                 (send dc set-pen WHITE-PEN)
+                 (send dc set-brush WHITE-BRUSH)
+                 (send dc draw-rectangle 0 0 row-label-width col-label-height)
+                 (when (and (not (send evt leaving?))
+                            p)
+                   (unless (equal? coordinate-p p)
+                     (let* ([i (pt-x p)]
+                            [j (pt-y p)]
+                            [string (loc->string (+ i 1) (+ j 1))]
+                            [width (get-string-width string)]
+                            [height (get-string-height string)]
+                            [sx (- (/ row-label-width 2)
+                                   (/ width 2))]
+                            [sy (- (/ col-label-height 2)
+                                   (/ height 2))])
+                       (send dc draw-text string sx sy)))))]
+              [(send evt button-down?)
+               (set! draw-small-start-p p)
+               (set! draw-small-end-p p)
+               (set! modifier-on? (check-modifier evt))
+               (when p
+                 (paint-rect (pt-x p) (pt-y p)))]
+              [(send evt button-up?)
+               (cond
+                 [(and p (or (= (pt-x p) (pt-x draw-small-start-p))
+                             (= (pt-y p) (pt-y draw-small-start-p))))
+                  (let ([new (new-brush (get-raw-rect 
+                                         (pt-x draw-small-start-p)
+                                         (pt-y draw-small-start-p))
+                                        (check-modifier evt))])
+                    ;(set! undo-history (cons (make-ado i j prev new) undo-history))
+                    ;(set! redo-history null)
+                    (let ([x-small (min (pt-x draw-small-start-p) (pt-x p))]
+                          [x-large (max (pt-x draw-small-start-p) (pt-x p))]
+                          [y-small (min (pt-y draw-small-start-p) (pt-y p))]
+                          [y-large (max (pt-y draw-small-start-p) (pt-y p))])
+                      
+                      (set! draw-small-start-p #f)
+                      (set! draw-small-end-p #f)
+                      (set! modifier-on? #f)
+                      
+                      (let loop ([x x-small])
+                        (when (<= x x-large)
+                          (let loop ([y y-small])
+                            (when (<= y y-large)
+                              (set-raw-rect x y new)
+                              (paint-rect x y)
+                              (loop (+ y 1))))
+                          (loop (+ x 1))))))]
+                 [else
+                  (let ([old-draw-small-start-p draw-small-start-p]
+                        [old-draw-small-end-p draw-small-end-p])
+                    (set! draw-small-start-p #f)
+                    (set! draw-small-end-p #f)
+                    (set! modifier-on? (check-modifier evt))
+                    (when (and old-draw-small-start-p
+                               old-draw-small-end-p)
+                      (update-range-of-rects old-draw-small-start-p
+                                             old-draw-small-end-p)))])])))]
+      [define/override on-paint
+	(lambda ()
+	  (let ([dc (get-dc)])
+	    (send dc clear)
+	    (let-values ([(width height) (get-client-size)])
+              
+	      (send dc set-pen LINES/NUMBERS-PEN)
+              (let loop ([i grid-x-size])
+                (cond
+		  [(zero? i) (void)]
+		  [else (let loop ([j grid-y-size])
+			  (cond
+                            [(zero? j) (void)]
+                            [else (paint-rect/lines-numbers-pen (- i 1) (- j 1))
+                                  (loop (- j 1))]))
+			(loop (- i 1))]))
+              
+	      (let loop ([l (get-col-numbers)]
+			 [n 0])
+		(cond
+                  [(null? l) (void)]
+                  [else
+                   
+                   (draw-col-label n)
+                   (loop (cdr l) (+ n 1))]))
+              
+	      (let loop ([l (get-row-numbers)]
+			 [n 0])
+		(cond
+                  [(null? l) (void)]
+                  [else
+                   (if (and last-p
+                            (= (pt-y last-p) n))
+                       (begin
+                         (send dc set-pen BAR-PEN)
+                         (send dc set-brush BAR-BRUSH))
+                       (begin
+                         (send dc set-pen WHITE-PEN)
+                         (send dc set-brush WHITE-BRUSH)))
+                   (draw-row-label n)
+                   (loop (cdr l)
+                         (+ n 1))]))
+	      
+	      (void))))]
+      
+      [define/public calculate-row-margins
+        (lambda ()
+          (let* ([dc (get-dc)])
+            (set! row-label-width
+                  (max (get-string-width (loc->string grid-x-size grid-y-size))
+                       (apply max (map (lambda (x) (+ x-margin
+                                                      (get-string-width (get-row-label-string x))
+                                                      x-margin))
+                                       (get-row-numbers)))))
+            
+            (let-values ([(width height descent ascent) (send dc get-text-extent "0123456789")])
+              (set! row-label-height (+ y-margin height y-margin)))))]
+      [define/public calculate-col-margins
+        (lambda ()
+          (let* ([dc (get-dc)])
+            
+            (set! col-label-height
+                  (max
+                   (get-string-height/descent (loc->string grid-x-size grid-y-size))
+                   (apply max
+                          (map (lambda (l)
+                                 (let* ([strs (get-col-label-strings l)]
+                                        [margins (* (length strs) y-margin)]
+                                        [height (apply + (map (lambda (x) (get-string-height x)) strs))])
+                                   (+ margins height)))
+                               (get-col-numbers)))))
+            
+            (set! col-label-width
+                  (apply max
+                         (map (lambda (l)
+                                (let ([label-strings (get-col-label-strings l)])
+                                  (if (null? label-strings)
+                                      (+ x-margin x-margin) ;; Minimum column label width (no labels)
+                                      (apply max
+                                             (map (lambda (x) (+ x-margin
+                                                                 (get-string-width x)
+                                                                 x-margin))
+                                                  label-strings)))))
+                              (get-col-numbers))))))]
+      [define/public update-min-spacing
+        (lambda ()
+          (min-width (inexact->exact (+ row-label-width (* grid-x-size col-label-width))))
+          (min-height (inexact->exact (+ col-label-height (* grid-y-size row-label-height)))))]
+      
+      (inherit min-width min-height)
+      (super-instantiate ())
+      
+      [define/public close-up
+        (lambda ()
+          (remove-pref-callback))]
+      [define/public reset-font
+        (lambda (font)
+          (send (get-dc) set-font font)
+          (calculate-row-margins)
+          (calculate-col-margins)
+          (update-min-spacing))]
+      
+      (define pref-callback (preferences:add-callback
+                             'paint-by-numbers:font
+                             (lambda (pref new-value)
+                               (reset-font new-value))))
+      [define/public (remove-pref-callback) (pref-callback)]
+      
+      (reset-font (preferences:get 'paint-by-numbers:font))
+      (calculate-row-margins)
+      (calculate-col-margins)
+      (update-min-spacing)))
+  
+  (define design-paint-by-numbers-canvas%
+    (class paint-by-numbers-canvas% 
+      (init-field width height)
+      [define row-spacing 5]
+      [define col-spacing 5]
+      [define row-numbers
+        (vector->list (make-vector height (vector->list (make-vector row-spacing 1))))]
+      [define col-numbers
+        (vector->list (make-vector width (vector->list (make-vector col-spacing 1))))]
+      
+      [define/override get-max-col-entries
+        (lambda ()
+          col-spacing)]
+      [define/override get-row-numbers
+        (lambda ()
+          row-numbers)]
+      [define/override get-col-numbers
+        (lambda ()
+          col-numbers)]
+      
+      (inherit draw-col-label draw-row-label get-rect
+               calculate-row-margins
+               calculate-col-margins
+               update-min-spacing
+               on-paint)
+      
+      [define/private calculate-col/row
+        (lambda (get-rect col/row-numbers num-row/cols)
+          (let loop ([i num-row/cols]
+                     [block-count 0]
+                     [ans null])
+            (cond
+              [(zero? i) (if (= block-count 0)
+                             ans
+                             (cons block-count ans))]
+              [else
+               (let ([this (get-rect (- i 1))])
+                 (case this
+                   [(unknown off wrong)
+                    (if (zero? block-count)
+                        (loop (- i 1) 0 ans)
+                        (loop (- i 1) 0 (cons block-count ans)))]
+                   [(on) (loop (- i 1) (+ block-count 1) ans)]
+                   [else (error 'calculate-col "unknown response from get-rect: ~a~n" this)]))])))]
+      
+      [define/private calculate-col
+        (lambda (col)
+          (calculate-col/row
+           (lambda (i) (get-rect col i))
+           col-numbers
+           (length row-numbers)))]
+      
+      [define/private calculate-row
+        (lambda (row)
+          (calculate-col/row
+           (lambda (i) (get-rect i row))
+           row-numbers
+           (length col-numbers)))]
+      
+      [define/private update-col/row
+        (lambda (col/row col/row-numbers calculate-col/row draw-col/row-label)
+          (let loop ([l col/row-numbers]
+                     [n col/row])
+            (cond
+              [(null? l) (error 'update-col/row "col/row too big: ~a~n" col/row)]
+              [(zero? n)
+               (let ([new-col/row (calculate-col/row col/row)])
+                 (set-car! l new-col/row)
+                 (draw-col/row-label col/row))]
+              [else
+               (loop (cdr l)
+                     (- n 1))])))]
+      
+      [define/private update-col
+        (lambda (col)
+          (update-col/row col
+                          col-numbers
+                          (lambda (x) (calculate-col x))
+                          (lambda (n) (draw-col-label n)))
+          (let ([len (length (list-ref col-numbers col))])
+            (when (< col-spacing len)
+              (set! col-spacing len)
+              (calculate-col-margins)
+              (update-min-spacing)
+              (on-paint))))]
+      
+      [define/private update-row
+        (lambda (row)
+          (update-col/row row
+                          row-numbers
+                          (lambda (x) (calculate-row x))
+                          (lambda (n) (draw-row-label n)))
+          (let ([len (length (list-ref row-numbers row))])
+            (when (< row-spacing len)
+              (set! row-spacing len)
+              (calculate-row-margins)
+              (update-min-spacing)
+              (on-paint))))]
+      
+      [define update-row-col? #t]
+      [define/override set-raw-rect
+        (lambda (i j n)
+          (super set-raw-rect i j n)
+          (when update-row-col?
+            (update-col i)
+            (update-row j)))]
+      
+      [define/private update-all-rows-cols
+        (lambda ()
+          (let loop ([i width])
+            (unless (zero? i)
+              (update-col (- i 1))
+              (loop (- i 1))))
+          (let loop ([i height])
+            (unless (zero? i)
+              (update-row (- i 1))
+              (loop (- i 1)))))]
+      (inherit set-rect)
+      [define/public set-bitmap
+        (lambda (bitmap)
+          (set! update-row-col? #f)
+          (let ([dc (make-object bitmap-dc% bitmap)]
+                [c (make-object color%)]
+                [width (send bitmap get-width)]
+                [height (send bitmap get-height)]
+                [warned? #f])
+            (let loop ([i width])
+              (unless (zero? i)
+                (let loop ([j height])
+                  (unless (zero? j)
+                    (let ([m (- i 1)]
+                          [n (- j 1)])
+                      (send dc get-pixel m n c)
+                      (when (and (not warned?)
+                                 (not (or (and (= 0 (send c red))
+                                               (= 0 (send c blue))
+                                               (= 0 (send c green)))
+                                          (and (= 255 (send c red))
+                                               (= 255 (send c blue))
+                                               (= 255 (send c green))))))
+                        (set! warned? #t)
+                        (message-box
+                         "Paint by Numbers"
+                         "WARNING: This is a color bitmap; non-white pixels will be considered black"))
+                      (set-rect m n
+                                (if (and (= 255 (send c red))
+                                         (= 255 (send c blue))
+                                         (= 255 (send c green)))
+                                    'off
+                                    'on)))
+                    (loop (- j 1))))
+                (loop (- i 1)))))
+          
+          (set! update-row-col? #t)
+          (update-all-rows-cols))]
+      
+      [define/override set-grid
+        (lambda (g)
+          (set! update-row-col? #f)
+          (super set-grid g)
+          (set! update-row-col? #t)
+          (update-all-rows-cols))]
+      
+      (super-instantiate () (row-numbers null) (col-numbers null))
+      (set! row-numbers (vector->list (make-vector height null)))
+      (set! col-numbers (vector->list (make-vector width null))))))
diff --git a/collects/games/paint-by-numbers/hattori/1.gif b/collects/games/paint-by-numbers/hattori/1.gif
new file mode 100644
index 0000000000..8152685883
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/1.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/10.gif b/collects/games/paint-by-numbers/hattori/10.gif
new file mode 100644
index 0000000000..f6fbde944b
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/10.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/100.gif b/collects/games/paint-by-numbers/hattori/100.gif
new file mode 100644
index 0000000000..d6ee00c858
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/100.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/101.gif b/collects/games/paint-by-numbers/hattori/101.gif
new file mode 100644
index 0000000000..78db5e6145
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/101.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/102.gif b/collects/games/paint-by-numbers/hattori/102.gif
new file mode 100644
index 0000000000..19b5710f51
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/102.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/103.gif b/collects/games/paint-by-numbers/hattori/103.gif
new file mode 100644
index 0000000000..41c74adec6
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/103.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/104.gif b/collects/games/paint-by-numbers/hattori/104.gif
new file mode 100644
index 0000000000..8fd78dbcbe
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/104.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/105.gif b/collects/games/paint-by-numbers/hattori/105.gif
new file mode 100644
index 0000000000..92fd309d0f
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/105.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/106.gif b/collects/games/paint-by-numbers/hattori/106.gif
new file mode 100644
index 0000000000..812d674845
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/106.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/107.gif b/collects/games/paint-by-numbers/hattori/107.gif
new file mode 100644
index 0000000000..b1409d5bf4
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/107.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/108.gif b/collects/games/paint-by-numbers/hattori/108.gif
new file mode 100644
index 0000000000..7dda7d055e
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/108.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/109.gif b/collects/games/paint-by-numbers/hattori/109.gif
new file mode 100644
index 0000000000..b2d40ed80f
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/109.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/11.gif b/collects/games/paint-by-numbers/hattori/11.gif
new file mode 100644
index 0000000000..d19f5c09f9
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/11.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/110.gif b/collects/games/paint-by-numbers/hattori/110.gif
new file mode 100644
index 0000000000..9b834d59a9
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/110.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/111.gif b/collects/games/paint-by-numbers/hattori/111.gif
new file mode 100644
index 0000000000..a741223071
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/111.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/112.gif b/collects/games/paint-by-numbers/hattori/112.gif
new file mode 100644
index 0000000000..b4dd3ec357
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/112.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/113.gif b/collects/games/paint-by-numbers/hattori/113.gif
new file mode 100644
index 0000000000..011bbf0c20
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/113.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/114.gif b/collects/games/paint-by-numbers/hattori/114.gif
new file mode 100644
index 0000000000..6c42b061c8
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/114.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/115.gif b/collects/games/paint-by-numbers/hattori/115.gif
new file mode 100644
index 0000000000..8e22ab3194
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/115.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/116.gif b/collects/games/paint-by-numbers/hattori/116.gif
new file mode 100644
index 0000000000..0c5455b432
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/116.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/117.gif b/collects/games/paint-by-numbers/hattori/117.gif
new file mode 100644
index 0000000000..8a63ea170d
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/117.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/118.gif b/collects/games/paint-by-numbers/hattori/118.gif
new file mode 100644
index 0000000000..173cd320bd
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/118.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/119.gif b/collects/games/paint-by-numbers/hattori/119.gif
new file mode 100644
index 0000000000..77e4f2e3ff
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/119.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/12.gif b/collects/games/paint-by-numbers/hattori/12.gif
new file mode 100644
index 0000000000..449430ae78
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/12.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/120.gif b/collects/games/paint-by-numbers/hattori/120.gif
new file mode 100644
index 0000000000..6454c4168f
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/120.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/121.gif b/collects/games/paint-by-numbers/hattori/121.gif
new file mode 100644
index 0000000000..ee311a3619
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/121.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/122.gif b/collects/games/paint-by-numbers/hattori/122.gif
new file mode 100644
index 0000000000..93b1843207
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/122.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/123.gif b/collects/games/paint-by-numbers/hattori/123.gif
new file mode 100644
index 0000000000..bb797bed2f
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/123.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/124.gif b/collects/games/paint-by-numbers/hattori/124.gif
new file mode 100644
index 0000000000..986aa23e0e
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/124.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/125.gif b/collects/games/paint-by-numbers/hattori/125.gif
new file mode 100644
index 0000000000..63fbad663a
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/125.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/126.gif b/collects/games/paint-by-numbers/hattori/126.gif
new file mode 100644
index 0000000000..95574fc7d9
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/126.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/127.gif b/collects/games/paint-by-numbers/hattori/127.gif
new file mode 100644
index 0000000000..de2bdb20b5
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/127.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/128.gif b/collects/games/paint-by-numbers/hattori/128.gif
new file mode 100644
index 0000000000..b9b45d5d43
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/128.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/129.gif b/collects/games/paint-by-numbers/hattori/129.gif
new file mode 100644
index 0000000000..22d05edb1c
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/129.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/13.gif b/collects/games/paint-by-numbers/hattori/13.gif
new file mode 100644
index 0000000000..e023d39821
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/13.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/130.gif b/collects/games/paint-by-numbers/hattori/130.gif
new file mode 100644
index 0000000000..f06cc7fb2f
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/130.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/131.gif b/collects/games/paint-by-numbers/hattori/131.gif
new file mode 100644
index 0000000000..e800934f1e
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/131.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/132.gif b/collects/games/paint-by-numbers/hattori/132.gif
new file mode 100644
index 0000000000..6de7ed5cd4
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/132.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/133.gif b/collects/games/paint-by-numbers/hattori/133.gif
new file mode 100644
index 0000000000..04fc23220a
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/133.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/134.gif b/collects/games/paint-by-numbers/hattori/134.gif
new file mode 100644
index 0000000000..1de7d7a77b
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/134.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/135.gif b/collects/games/paint-by-numbers/hattori/135.gif
new file mode 100644
index 0000000000..3d9a625ed9
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/135.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/136.gif b/collects/games/paint-by-numbers/hattori/136.gif
new file mode 100644
index 0000000000..d379ad1747
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/136.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/137.gif b/collects/games/paint-by-numbers/hattori/137.gif
new file mode 100644
index 0000000000..75188be41e
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/137.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/138.gif b/collects/games/paint-by-numbers/hattori/138.gif
new file mode 100644
index 0000000000..e6461ff05a
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/138.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/139.gif b/collects/games/paint-by-numbers/hattori/139.gif
new file mode 100644
index 0000000000..be9def19e6
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/139.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/14.gif b/collects/games/paint-by-numbers/hattori/14.gif
new file mode 100644
index 0000000000..501bb2a370
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/14.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/15.gif b/collects/games/paint-by-numbers/hattori/15.gif
new file mode 100644
index 0000000000..e21dd84df1
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/15.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/16.gif b/collects/games/paint-by-numbers/hattori/16.gif
new file mode 100644
index 0000000000..fbe9fdc125
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/16.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/17.gif b/collects/games/paint-by-numbers/hattori/17.gif
new file mode 100644
index 0000000000..2ebcfb199d
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/17.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/18.gif b/collects/games/paint-by-numbers/hattori/18.gif
new file mode 100644
index 0000000000..138807b098
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/18.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/19.gif b/collects/games/paint-by-numbers/hattori/19.gif
new file mode 100644
index 0000000000..a527290df4
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/19.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/2.gif b/collects/games/paint-by-numbers/hattori/2.gif
new file mode 100644
index 0000000000..d43a47ee33
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/2.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/20.gif b/collects/games/paint-by-numbers/hattori/20.gif
new file mode 100644
index 0000000000..0628c30657
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/20.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/21.gif b/collects/games/paint-by-numbers/hattori/21.gif
new file mode 100644
index 0000000000..8ff4f11e21
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/21.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/22.gif b/collects/games/paint-by-numbers/hattori/22.gif
new file mode 100644
index 0000000000..c23a7009f7
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/22.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/23.gif b/collects/games/paint-by-numbers/hattori/23.gif
new file mode 100644
index 0000000000..c3fbcb4e15
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/23.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/24.gif b/collects/games/paint-by-numbers/hattori/24.gif
new file mode 100644
index 0000000000..2b93e91954
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/24.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/25.gif b/collects/games/paint-by-numbers/hattori/25.gif
new file mode 100644
index 0000000000..d91b69a2e1
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/25.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/26.gif b/collects/games/paint-by-numbers/hattori/26.gif
new file mode 100644
index 0000000000..4b84b82bab
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/26.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/27.gif b/collects/games/paint-by-numbers/hattori/27.gif
new file mode 100644
index 0000000000..34b7f0bbd9
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/27.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/28.gif b/collects/games/paint-by-numbers/hattori/28.gif
new file mode 100644
index 0000000000..6397db1fc6
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/28.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/29.gif b/collects/games/paint-by-numbers/hattori/29.gif
new file mode 100644
index 0000000000..8376c377b8
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/29.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/3.gif b/collects/games/paint-by-numbers/hattori/3.gif
new file mode 100644
index 0000000000..cbbf50f091
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/3.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/30.gif b/collects/games/paint-by-numbers/hattori/30.gif
new file mode 100644
index 0000000000..4cf55f52b6
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/30.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/31.gif b/collects/games/paint-by-numbers/hattori/31.gif
new file mode 100644
index 0000000000..0f171ce1bc
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/31.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/32.gif b/collects/games/paint-by-numbers/hattori/32.gif
new file mode 100644
index 0000000000..95ace288a7
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/32.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/33.gif b/collects/games/paint-by-numbers/hattori/33.gif
new file mode 100644
index 0000000000..08403c454d
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/33.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/34.gif b/collects/games/paint-by-numbers/hattori/34.gif
new file mode 100644
index 0000000000..8d84208256
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/34.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/35.gif b/collects/games/paint-by-numbers/hattori/35.gif
new file mode 100644
index 0000000000..f630e85381
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/35.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/36.gif b/collects/games/paint-by-numbers/hattori/36.gif
new file mode 100644
index 0000000000..38a471f489
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/36.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/37.gif b/collects/games/paint-by-numbers/hattori/37.gif
new file mode 100644
index 0000000000..7aa072cc14
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/37.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/38.gif b/collects/games/paint-by-numbers/hattori/38.gif
new file mode 100644
index 0000000000..f4ff6f33ce
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/38.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/39.gif b/collects/games/paint-by-numbers/hattori/39.gif
new file mode 100644
index 0000000000..9450673436
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/39.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/4.gif b/collects/games/paint-by-numbers/hattori/4.gif
new file mode 100644
index 0000000000..2a73200604
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/4.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/40.gif b/collects/games/paint-by-numbers/hattori/40.gif
new file mode 100644
index 0000000000..9973f7ae11
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/40.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/41.gif b/collects/games/paint-by-numbers/hattori/41.gif
new file mode 100644
index 0000000000..a3c28f848d
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/41.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/42.gif b/collects/games/paint-by-numbers/hattori/42.gif
new file mode 100644
index 0000000000..3a3f779e3b
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/42.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/43.gif b/collects/games/paint-by-numbers/hattori/43.gif
new file mode 100644
index 0000000000..ce90e34365
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/43.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/44.gif b/collects/games/paint-by-numbers/hattori/44.gif
new file mode 100644
index 0000000000..87ef52c3a1
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/44.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/45.gif b/collects/games/paint-by-numbers/hattori/45.gif
new file mode 100644
index 0000000000..20696e7d8f
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/45.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/46.gif b/collects/games/paint-by-numbers/hattori/46.gif
new file mode 100644
index 0000000000..79847b4e6d
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/46.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/47.gif b/collects/games/paint-by-numbers/hattori/47.gif
new file mode 100644
index 0000000000..fa2d030409
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/47.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/48.gif b/collects/games/paint-by-numbers/hattori/48.gif
new file mode 100644
index 0000000000..8817a522fe
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/48.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/49.gif b/collects/games/paint-by-numbers/hattori/49.gif
new file mode 100644
index 0000000000..756da70501
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/49.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/5.gif b/collects/games/paint-by-numbers/hattori/5.gif
new file mode 100644
index 0000000000..74cde1782e
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/5.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/50.gif b/collects/games/paint-by-numbers/hattori/50.gif
new file mode 100644
index 0000000000..3c10bfa844
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/50.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/51.gif b/collects/games/paint-by-numbers/hattori/51.gif
new file mode 100644
index 0000000000..6d3d72b033
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/51.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/52.gif b/collects/games/paint-by-numbers/hattori/52.gif
new file mode 100644
index 0000000000..9bdadb19ec
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/52.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/53.gif b/collects/games/paint-by-numbers/hattori/53.gif
new file mode 100644
index 0000000000..9be42ca65c
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/53.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/54.gif b/collects/games/paint-by-numbers/hattori/54.gif
new file mode 100644
index 0000000000..aeae134153
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/54.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/55.gif b/collects/games/paint-by-numbers/hattori/55.gif
new file mode 100644
index 0000000000..e5d743f920
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/55.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/56.gif b/collects/games/paint-by-numbers/hattori/56.gif
new file mode 100644
index 0000000000..5f4964611b
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/56.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/57.gif b/collects/games/paint-by-numbers/hattori/57.gif
new file mode 100644
index 0000000000..2e546a25bc
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/57.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/58.gif b/collects/games/paint-by-numbers/hattori/58.gif
new file mode 100644
index 0000000000..ae20dedca0
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/58.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/59.gif b/collects/games/paint-by-numbers/hattori/59.gif
new file mode 100644
index 0000000000..d306cd0f47
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/59.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/6.gif b/collects/games/paint-by-numbers/hattori/6.gif
new file mode 100644
index 0000000000..54b547dc63
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/6.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/60.gif b/collects/games/paint-by-numbers/hattori/60.gif
new file mode 100644
index 0000000000..709f62fc8e
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/60.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/61.gif b/collects/games/paint-by-numbers/hattori/61.gif
new file mode 100644
index 0000000000..c6b236dd59
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/61.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/62.gif b/collects/games/paint-by-numbers/hattori/62.gif
new file mode 100644
index 0000000000..371744c3ab
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/62.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/63.gif b/collects/games/paint-by-numbers/hattori/63.gif
new file mode 100644
index 0000000000..22bda0e557
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/63.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/64.gif b/collects/games/paint-by-numbers/hattori/64.gif
new file mode 100644
index 0000000000..366028c588
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/64.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/65.gif b/collects/games/paint-by-numbers/hattori/65.gif
new file mode 100644
index 0000000000..588d051691
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/65.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/66.gif b/collects/games/paint-by-numbers/hattori/66.gif
new file mode 100644
index 0000000000..3ebb464e94
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/66.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/67.gif b/collects/games/paint-by-numbers/hattori/67.gif
new file mode 100644
index 0000000000..9a42def715
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/67.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/68.gif b/collects/games/paint-by-numbers/hattori/68.gif
new file mode 100644
index 0000000000..db0d4190e0
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/68.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/69.gif b/collects/games/paint-by-numbers/hattori/69.gif
new file mode 100644
index 0000000000..e21860e16f
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/69.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/7.gif b/collects/games/paint-by-numbers/hattori/7.gif
new file mode 100644
index 0000000000..158d4f109f
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/7.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/70.gif b/collects/games/paint-by-numbers/hattori/70.gif
new file mode 100644
index 0000000000..14ccd25b3c
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/70.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/71.gif b/collects/games/paint-by-numbers/hattori/71.gif
new file mode 100644
index 0000000000..260b5c9de9
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/71.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/72.gif b/collects/games/paint-by-numbers/hattori/72.gif
new file mode 100644
index 0000000000..40195de47f
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/72.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/73.gif b/collects/games/paint-by-numbers/hattori/73.gif
new file mode 100644
index 0000000000..51f7eef888
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/73.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/74.gif b/collects/games/paint-by-numbers/hattori/74.gif
new file mode 100644
index 0000000000..ec6fa54976
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/74.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/75.gif b/collects/games/paint-by-numbers/hattori/75.gif
new file mode 100644
index 0000000000..8235bb2fbd
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/75.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/76.gif b/collects/games/paint-by-numbers/hattori/76.gif
new file mode 100644
index 0000000000..0ee6bda7d8
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/76.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/77.gif b/collects/games/paint-by-numbers/hattori/77.gif
new file mode 100644
index 0000000000..d00f7b14f2
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/77.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/78.gif b/collects/games/paint-by-numbers/hattori/78.gif
new file mode 100644
index 0000000000..fd2ed23bf5
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/78.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/79.gif b/collects/games/paint-by-numbers/hattori/79.gif
new file mode 100644
index 0000000000..534d27eff8
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/79.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/8.gif b/collects/games/paint-by-numbers/hattori/8.gif
new file mode 100644
index 0000000000..d08fd358d0
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/8.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/80.gif b/collects/games/paint-by-numbers/hattori/80.gif
new file mode 100644
index 0000000000..86e6d2ad40
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/80.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/81.gif b/collects/games/paint-by-numbers/hattori/81.gif
new file mode 100644
index 0000000000..7ba0dc4edb
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/81.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/82.gif b/collects/games/paint-by-numbers/hattori/82.gif
new file mode 100644
index 0000000000..b10842aba4
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/82.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/83.gif b/collects/games/paint-by-numbers/hattori/83.gif
new file mode 100644
index 0000000000..b651aa1f03
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/83.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/84.gif b/collects/games/paint-by-numbers/hattori/84.gif
new file mode 100644
index 0000000000..a167012a34
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/84.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/85.gif b/collects/games/paint-by-numbers/hattori/85.gif
new file mode 100644
index 0000000000..e9d710a449
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/85.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/86.gif b/collects/games/paint-by-numbers/hattori/86.gif
new file mode 100644
index 0000000000..744ae4571e
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/86.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/87.gif b/collects/games/paint-by-numbers/hattori/87.gif
new file mode 100644
index 0000000000..f8f8c1ce2a
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/87.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/88.gif b/collects/games/paint-by-numbers/hattori/88.gif
new file mode 100644
index 0000000000..7a773c0fe1
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/88.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/89.gif b/collects/games/paint-by-numbers/hattori/89.gif
new file mode 100644
index 0000000000..48657c1368
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/89.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/9.gif b/collects/games/paint-by-numbers/hattori/9.gif
new file mode 100644
index 0000000000..0cf522657a
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/9.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/90.gif b/collects/games/paint-by-numbers/hattori/90.gif
new file mode 100644
index 0000000000..11fabf5895
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/90.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/91.gif b/collects/games/paint-by-numbers/hattori/91.gif
new file mode 100644
index 0000000000..83b2e87f29
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/91.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/92.gif b/collects/games/paint-by-numbers/hattori/92.gif
new file mode 100644
index 0000000000..2cb812e0d7
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/92.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/93.gif b/collects/games/paint-by-numbers/hattori/93.gif
new file mode 100644
index 0000000000..baa487f249
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/93.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/94.gif b/collects/games/paint-by-numbers/hattori/94.gif
new file mode 100644
index 0000000000..8eec54df97
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/94.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/95.gif b/collects/games/paint-by-numbers/hattori/95.gif
new file mode 100644
index 0000000000..a234a95d59
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/95.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/96.gif b/collects/games/paint-by-numbers/hattori/96.gif
new file mode 100644
index 0000000000..07511d0857
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/96.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/97.gif b/collects/games/paint-by-numbers/hattori/97.gif
new file mode 100644
index 0000000000..63d2f902cc
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/97.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/98.gif b/collects/games/paint-by-numbers/hattori/98.gif
new file mode 100644
index 0000000000..14698f94bb
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/98.gif differ
diff --git a/collects/games/paint-by-numbers/hattori/99.gif b/collects/games/paint-by-numbers/hattori/99.gif
new file mode 100644
index 0000000000..b5c92ffab2
Binary files /dev/null and b/collects/games/paint-by-numbers/hattori/99.gif differ
diff --git a/collects/games/paint-by-numbers/info.ss b/collects/games/paint-by-numbers/info.ss
new file mode 100644
index 0000000000..357ea95dc9
--- /dev/null
+++ b/collects/games/paint-by-numbers/info.ss
@@ -0,0 +1,26 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Paint by Numbers")
+  (define doc.txt "doc.txt")
+  (define game "paint-by-numbers.ss")
+  (define game-set "Puzzle Games")
+  (define compile-omit-files '(
+			       ;; Skipped because it's huge - lots
+			       ;; of data-encoding units
+			       "all-problems.ss"
+			       
+			       ;; Skipped because it requires
+			       ;; all-problems.ss
+			       "paint-by-numbers.ss"
+			       
+			       ;; Skipped because these are used
+			       ;; only to build the huge units.
+			       "build-hattori.ss"
+                               "build-kajitani.ss"
+                               "build-problems.ss"
+                               "raw-hattori.ss"
+                               "raw-kajitani.ss"
+                               "raw-problems.ss"
+                               "raw-misc.ss"
+                               "build-rows-cols.ss"
+                               "count-missing.ss"
+                               "main.ss")))
diff --git a/collects/games/paint-by-numbers/main.ss b/collects/games/paint-by-numbers/main.ss
new file mode 100644
index 0000000000..004d6b3754
--- /dev/null
+++ b/collects/games/paint-by-numbers/main.ss
@@ -0,0 +1,520 @@
+(unit/sig BOARD^
+
+  (import [GUI : GUI^]
+	  [SOLVE : SOLVE^]
+	  [fw : framework^]
+	  paint-by-numbers:problem^
+	  [all : paint-by-numbers:all-problems^]
+	  mzlib:pretty-print^
+	  mred^)
+
+  (define default-font (send the-font-list find-or-create-font 10 'roman 'normal 'normal #f))
+  (fw:preferences:set-un/marshall 'paint-by-numbers:font
+				  (lambda (font)
+				    (list (send font get-point-size)
+					  (send font get-face)
+					  (send font get-family)
+					  (send font get-style)
+					  (send font get-weight)
+					  (send font get-underlined)))
+				  (lambda (lst) (apply (ivar the-font-list find-or-create-font) lst)))
+  (fw:preferences:set-default 'paint-by-numbers:font default-font (lambda (f) (is-a? f font%)))
+				    
+  (define problems (car all:problemss))
+
+  (define game-name "Paint by Numbers")
+  (define editor-name "Paint by Numbers Designer")
+  (define biggest-editor 35)
+
+  (define (setup-progress max)
+    (let* ([e (make-eventspace)]
+	   [f (parameterize ([current-eventspace e])
+		(make-object frame% "Solver Setup Progress"))]
+	   [g (make-object gauge% #f max f)]
+	   [counter 0])
+      (send g min-width 300)
+      (send f show #t)
+      (lambda ()
+	(set! counter (+ 1 counter))
+	(cond
+	 [(= counter max)
+	  (collect-garbage)
+	  (send f show #f)]
+	 [else 
+	  (send g set-value counter)]))))
+
+  (define show-help
+    ((require-library "show-help.ss" "games")
+     (list "games" "paint-by-numbers")
+     "Paint by Numbers Help"))
+
+  (define (configure-font frame)
+    (let ([font (get-font-from-user
+		 "Choose a font for the labels"
+		 frame
+		 (fw:preferences:get 'paint-by-numbers:font))])
+      (when font
+	(fw:preferences:set 'paint-by-numbers:font font))))
+
+  (define (size-font inc)
+    (let ([old-font (fw:preferences:get 'paint-by-numbers:font)])
+      (fw:preferences:set 'paint-by-numbers:font
+			  (if (send old-font get-face)
+			      (send the-font-list find-or-create-font
+				    (inc (send old-font get-point-size))
+				    (send old-font get-face)
+				    (send old-font get-family)
+				    (send old-font get-style)
+				    (send old-font get-weight)
+				    (send old-font get-underlined))
+			      (send the-font-list find-or-create-font
+				    (inc (send old-font get-point-size))
+				    (send old-font get-family)
+				    (send old-font get-style)
+				    (send old-font get-weight)
+				    (send old-font get-underlined))))))
+
+  (define (add-font-items frame menu)
+    (make-object menu-item%
+      "Choose Font"
+      menu
+      (lambda x (configure-font frame)))
+    (make-object menu-item%
+      "Make Board Bigger"
+      menu
+      (lambda x (size-font add1))
+      #\b)
+    (make-object menu-item%
+      "Make Board Tinier"
+      menu
+      (lambda x (size-font sub1))
+      #\t))
+		 
+  (define generic-frame%
+    (class (fw:frame:standard-menus-mixin fw:frame:basic%) (name)
+
+      (inherit set-label get-label get-area-container)
+      (private
+	[filename #f])
+      (public
+	[update-filename
+	 (lambda (new-name)
+	   (set! filename new-name)
+
+	   (let* ([short-name (if new-name
+				  (let-values ([(_1 name _2) (split-path new-name)])
+				    name)
+				  #f)]
+		  [new-label (if short-name
+				 (format "~a - ~a" short-name name)
+				 game-name)])
+	     (unless (string=? new-label (get-label))
+	       (set-label new-label))))])
+      (public
+	[get-pbn-filename (lambda () filename)])
+
+      (public
+	[do-save void]
+	[get-canvas void])
+
+      (private
+	[save-as
+	 (lambda ()
+	   (let ([fn (put-file)])
+	     (when fn
+	       (update-filename fn)
+	       (do-save))))])
+      (rename [super-file-menu:between-new-and-open file-menu:between-new-and-open])
+
+      (override
+       [file-menu:new-string (lambda () "Puzzle")]
+       [file-menu:new
+	(lambda (_1 _2)
+	  (player))]
+       [file-menu:between-new-and-open
+	(lambda (menu)
+	  (make-object menu-item% "Design a Puzzle..." menu
+		       (lambda (_1 _2)
+			 (editor #f)))
+	  (make-object menu-item% "Design a Puzzle from a Bitmap..." menu
+		       (lambda (_1 _2)
+			 (editor #t)))
+	  (make-object separator-menu-item% menu))]
+       [file-menu:save
+	(lambda (_1 _2)
+	  (if filename
+	      (do-save)
+	      (save-as)))]
+       [file-menu:save-as
+	(lambda (_1 _2)
+	  (save-as))]
+       [file-menu:open
+	(lambda (_1 _2)
+	  (let ([fn (get-file)])
+	    (when fn
+	      (let* ([state (call-with-input-file fn read)]
+		     [type (car state)])
+		(case type
+		  [(editor)
+		   (let ([name (cadr state)]
+			 [problem
+			  (make-problem name
+					(caddr state)
+					(cadddr state)
+					(list->vector (map list->vector (car (cddddr state)))))])
+		   (editor problem))]
+		  [(player)
+		   (let ([name (cadr state)]
+			 [problem
+			  (make-problem name
+					(caddr state)
+					(cadddr state)
+					(car (cddddr state)))])
+		     (player problem (cadr (cddddr state))))]
+		  [else
+		   (message-box "Error"
+				(format "Unknown save file ~a" fn))])))))]
+
+       [edit-menu:undo
+	(lambda (_1 _2)
+	  (send (get-canvas) undo))]
+
+       [edit-menu:redo
+	(lambda (_1 _2)
+	  (send (get-canvas) redo))])
+
+      (sequence
+	(super-init name))
+      (public
+	[top-panel (make-object horizontal-panel% (get-area-container))]
+	[help-button
+	 (make-object button% "Help" top-panel (lambda (_1 _2) (show-help)))])
+      (sequence
+	(send top-panel stretchable-height #f)
+	(send top-panel set-alignment 'right 'center))))
+
+  (define pbn-frame%
+    (class generic-frame% ([_problem (car problems)])
+
+      (private
+	[problem _problem])
+
+      (inherit get-pbn-filename)
+      (override
+	[do-save
+	 (lambda ()
+	   (call-with-output-file (get-pbn-filename)
+	     (lambda (port)
+	       (pretty-print
+		(list 'player
+		      (problem-name problem)
+		      (problem-rows problem)
+		      (problem-cols problem)
+		      (problem-solution problem)
+		      (send canvas get-grid))
+		port))
+	     'truncate
+	     'text))])
+
+      (inherit can-close? show)
+
+      (inherit stretchable-width stretchable-height update-filename)
+      (private
+	[set-problem
+	 (lambda (prlmb)
+	   (update-filename #f)
+	   (send wrong-item enable (problem-solution prlmb))
+	   (send editor-item enable (problem-solution prlmb))
+	   (let ([rows (problem-rows prlmb)]
+		 [cols (problem-cols prlmb)])
+	     (set! problem prlmb)
+	     (when canvas (send canvas close-up))
+	     (set! canvas (make-object GUI:paint-by-numbers-canvas% canvas-panel rows cols))
+	     (send canvas-panel change-children (lambda (l) (list canvas))))
+	   (stretchable-width #f)
+	   (stretchable-height #f))]
+
+	[show-wrong
+	 (lambda ()
+	   (let loop ([i (length (problem-cols problem))])
+	     (unless (zero? i)
+	       (let loop ([j (length (problem-rows problem))])
+		 (unless (zero? j)
+		   (let* ([m (- i 1)]
+			  [n (- j 1)]
+			  [board-entry (get-entry m n)]
+			  [real-answer (vector-ref (vector-ref (problem-solution problem) m) n)])
+		     (unless (or (eq? board-entry real-answer)
+				 (eq? board-entry 'unknown)
+				 (eq? real-answer 'unknown))
+		       (send canvas set-to-error m n)))
+		   (loop (- j 1))))
+	       (loop (- i 1)))))]
+	
+	[get-entry
+	 (lambda (i j)
+	   (send canvas get-rect i j))]
+
+	[set-entry
+	 (lambda (i j nv)
+	   (send canvas set-rect i j nv)
+	   (send canvas paint-rect i j))]
+
+	[really-solve?
+	 (lambda ()
+	   (fw:gui-utils:get-choice
+	    (format "~
+  Solving can be a very computationally intense task;~
+~nyou may run out of memory and crash. ~
+~nReally continue? (Be sure to save your work!)")
+	    "Yes"
+	    "No"
+	    "Really Solve?"
+	    #f))]
+
+	[solve
+	 (lambda ()
+	   (when (really-solve?)
+	     (send canvas all-unknown)
+	     (send canvas on-paint)
+	     (SOLVE:solve
+	      (problem-rows problem)
+	      (problem-cols problem)
+	      set-entry
+	      setup-progress)))])
+
+      (sequence
+	(super-init game-name))
+
+      (private
+	[wrong-item #f]
+	[solve-item #f]
+	[editor-item #f])
+      (inherit get-menu-bar)
+      (sequence
+	(let* ([mb (get-menu-bar)]
+	       [pbn-menu (make-object menu% "Nonogram" mb)])
+	  (set! solve-item (make-object menu-item% "Solve" pbn-menu
+					(lambda (_1 _2)
+					  (solve))
+					#\l))
+	  (set! wrong-item (make-object menu-item% "Show Mistakes" pbn-menu
+					(lambda (_1 _2)
+					  (show-wrong)) #\h))
+	  (set! editor-item (make-object menu-item% "Edit this Puzzle" pbn-menu
+					 (lambda (_1 _2)
+					   (editor problem))))
+
+	  (make-object separator-menu-item% pbn-menu)
+	  (add-font-items this pbn-menu)))
+
+      (inherit top-panel help-button get-area-container)
+      (private
+	[gap (make-object horizontal-panel% top-panel)]
+	[set-choice
+	 (make-object choice%
+		      "Set"
+		      all:set-names
+		      top-panel
+		      (lambda (choice evt)
+			(set! problems (list-ref all:problemss (send choice get-selection)))
+			(send board-choice clear)
+			(for-each (lambda (problem) (send board-choice append (problem-name problem)))
+				  problems)
+			(set-problem (car problems))))]
+	[board-choice (make-object choice%
+				   "Board"
+				   (map problem-name problems)
+				   top-panel
+				   (lambda (choice evt)
+				     (set-problem (list-ref problems (send choice get-selection)))))]
+	[canvas/spacer-panel (make-object horizontal-panel% (get-area-container))]
+	[canvas-panel (make-object vertical-pane% canvas/spacer-panel)]
+	[spacer (make-object grow-box-spacer-pane% canvas/spacer-panel)]
+	[canvas #f])
+      (sequence
+	(send top-panel change-children (lambda (l) (list set-choice board-choice gap help-button))))
+
+      (override
+	[get-canvas
+	 (lambda ()
+	   canvas)])
+
+      (rename [super-on-close on-close])
+      (override
+       [on-close
+	(lambda ()
+	  (when canvas (send canvas close-up)))])
+
+      (sequence
+	(set-problem problem)
+	(show #t))))
+
+  (define editor-frame%
+    (class generic-frame% (indicator)
+      (inherit get-pbn-filename)
+      (override
+       [do-save
+	(lambda ()
+	  (let ([fn (get-pbn-filename)])
+	    (call-with-output-file fn
+	      (lambda (port)
+		(pretty-print
+		 (list 'editor
+		       (let-values ([(base name dir?) (split-path fn)])
+			 name)
+		       (send canvas get-row-numbers)
+		       (send canvas get-col-numbers)
+		       (let ([grid (send canvas get-grid)])
+			 (map (lambda (l) (map (lambda (x) (if (eq? x 'on) 'on 'off)) l)) grid)))
+		 port))
+	      'truncate
+	      'text)))])
+
+      (private
+	[test-puzzle
+	 (lambda ()
+	   (player
+	    (make-problem "<editor test>"
+			  (send canvas get-row-numbers)
+			  (send canvas get-col-numbers)
+			  (send canvas get-grid))))])
+
+      (private
+	[canvas #f])
+      (override
+	[get-canvas
+	 (lambda ()
+	   canvas)])
+
+
+      (rename [super-on-close on-close])
+      (override
+       [on-close
+	(lambda ()
+	  (when canvas (send canvas close-up))
+	  (super-on-close))])
+
+      (sequence
+	(super-init editor-name))
+
+      (inherit get-area-container)
+      (private
+	[space/canvas-panel (make-object horizontal-panel% (get-area-container))]
+	[canvas-panel (make-object vertical-pane% space/canvas-panel)]
+	[spacer (make-object grow-box-spacer-pane% canvas-panel)])
+
+      (sequence
+	(cond
+	 [(pair? indicator)
+	  (when canvas
+	    (send canvas close-up))
+	  (set! canvas
+		  (make-object GUI:design-paint-by-numbers-canvas%
+		    canvas-panel
+		    (car indicator)
+		    (cdr indicator)))]
+	 [(is-a? indicator bitmap%)
+	  (when canvas
+	    (send canvas close-up))
+	  (set! canvas
+		(make-object GUI:design-paint-by-numbers-canvas%
+		  canvas-panel
+		  (min biggest-editor (send indicator get-width))
+		  (min biggest-editor (send indicator get-height))))
+	  (when (or (> (send indicator get-width) biggest-editor)
+		    (> (send indicator get-height) biggest-editor))
+	    (message-box
+	     "Paint by Numbers"
+	     (format "WARNING: Bitmap is larger than ~ax~a. Truncating."
+		     biggest-editor biggest-editor)))
+	  (send canvas set-bitmap indicator)]
+	 [(problem? indicator)
+	  (when canvas
+	    (send canvas close-up))
+	  (set! canvas
+		(make-object GUI:design-paint-by-numbers-canvas%
+		  canvas-panel
+		  (length (problem-cols indicator))
+		  (length (problem-rows indicator))))
+	  (send canvas set-grid
+		(map vector->list (vector->list (problem-solution indicator))))]))
+
+      (inherit get-menu-bar)
+      (sequence
+	(let* ([mb (get-menu-bar)]
+	       [pbn-menu (make-object menu% "Nonogram" mb)])
+	  (make-object menu-item% "Test Puzzle" pbn-menu (lambda (_1 _2) (test-puzzle)))
+
+	  (make-object separator-menu-item% pbn-menu)
+	  (add-font-items this pbn-menu)))))
+
+  (define (editor bitmap?)
+    (let* ([default 15]
+	   [get-sizes
+	    (lambda ()
+	      (let* ([d (make-object dialog% "Size")]
+		     [m (make-object message% "How big should the designer be?" d)]
+		     [wp (make-object horizontal-panel% d)]
+		     [wm (make-object message% "Width" wp)]
+		     [gw (make-object slider% #f 1 biggest-editor wp void default)]
+		     [hp (make-object horizontal-panel% d)]
+		     [hm (make-object message% "Height" hp)]
+		     [gh (make-object slider% #f 1 biggest-editor hp void default)]
+		     [bp (make-object horizontal-panel% d)]
+		     [cancelled? #f]
+		     [cancel (make-object button% "Cancel" bp (lambda (_1 _2)
+								(set! cancelled? #t)
+								(send d show #f)))]
+		     [ok (make-object button% "OK" bp (lambda (_1 _2) (send d show #f)) '(border))])
+
+		(let ([label-width (max (send wm get-width)
+					(send hm get-width))])
+		  (send wm min-width label-width)
+		  (send hm min-width label-width))
+
+		(send bp set-alignment 'right 'center)
+      
+		(send d show #t)
+		(if cancelled?
+		    #f
+		    (cons (send gw get-value)
+			  (send gh get-value)))))]
+	   [get-bitmap
+	    (lambda ()
+	      (let* ([fn (get-file "Select a bitmap")]
+		     [bm (make-object bitmap% fn)])
+		(if (send bm ok?)
+		    bm
+		    (begin
+		      (message-box
+		       "Paint by Numbers"
+		       (format (format "Unreadable file: ~a" fn)))
+		      #f))))]
+	   [indicator
+	    (cond
+	     [(boolean? bitmap?)
+	      (if bitmap?
+		  (get-bitmap)
+		  (get-sizes))]
+	     [(problem? bitmap?)
+	      bitmap?])])
+		
+      (when indicator
+	(send (make-object editor-frame% indicator) show #t))))
+
+  (define player
+    (case-lambda
+     [() (player (car problems))]
+     [(problem)
+      (let ([f (make-object pbn-frame% problem)])
+	(send f show #t))]
+     [(problem state)
+      (let ([f (make-object pbn-frame% problem)])
+	(send (send f get-canvas) set-grid state)
+	(send f show #t))]))
+
+  (player)
+  ;(editor #f)
+
+  (yield (make-semaphore)))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/paint-by-numbers.png b/collects/games/paint-by-numbers/paint-by-numbers.png
new file mode 100644
index 0000000000..76cc96774d
Binary files /dev/null and b/collects/games/paint-by-numbers/paint-by-numbers.png differ
diff --git a/collects/games/paint-by-numbers/paint-by-numbers.ss b/collects/games/paint-by-numbers/paint-by-numbers.ss
new file mode 100644
index 0000000000..656167970e
--- /dev/null
+++ b/collects/games/paint-by-numbers/paint-by-numbers.ss
@@ -0,0 +1,518 @@
+
+(module paint-by-numbers mzscheme
+  (require "gui.ss" 
+           (prefix solve: "solve.ss")
+           "all-problems.ss"
+           "problem.ss"
+           "../show-help.ss"
+           (lib "framework.ss" "framework")
+           (lib "class.ss")
+           (lib "unit.ss")
+           (lib "pretty.ss")
+           (lib "list.ss")
+           (lib "mred.ss" "mred"))
+  
+  (provide game-unit)
+  
+  (define default-font (send the-font-list find-or-create-font 10 'roman 'normal 'normal #f))
+  (preferences:set-default 'paint-by-numbers:font default-font (lambda (f) (is-a? f font%)))
+  (preferences:set-un/marshall 'paint-by-numbers:font
+                               (lambda (font)
+                                 (list (send font get-point-size)
+                                       (send font get-family)
+                                       (send font get-style)
+                                       (send font get-weight)
+                                       (send font get-underlined)))
+                               (lambda (lst)
+                                 (let ([size (first lst)]
+                                       [family (second lst)]
+                                       [style (third lst)]
+                                       [weight (fourth lst)]
+                                       [underline (fifth lst)])
+                                   (cond
+                                     [(and (number? size)
+                                           (<= 1 size 72)
+                                           (memq family '(default decorative roman 
+                                                                  script swiss modern symbol system))
+                                           (memq style '(normal italic slant))
+                                           (memq weight '(normal bold light))
+                                           (boolean? underline))
+                                      
+                                      (or (send the-font-list find-or-create-font size family style weight underline)
+                                          default-font)]
+                                     [else default-font]))))
+  
+  (define problems (car problemss))
+  
+  (define game-name "Paint by Numbers")
+  (define editor-name "Paint by Numbers Designer")
+  (define biggest-editor 35)
+  
+  (define (setup-progress max)
+    (let* ([e (make-eventspace)]
+	   [f (parameterize ([current-eventspace e])
+		(make-object frame% "Solver Setup Progress"))]
+	   [g (make-object gauge% #f max f)]
+	   [counter 0])
+      (send g min-width 300)
+      (send f show #t)
+      (lambda ()
+	(set! counter (+ 1 counter))
+	(cond
+          [(= counter max)
+           (collect-garbage)
+           (send f show #f)]
+          [else 
+           (send g set-value counter)]))))
+  
+  (define show-this-help
+    (show-help
+     (list "games" "paint-by-numbers")
+     "Paint by Numbers Help"))
+  
+  (define (configure-font frame)
+    (let ([font (get-font-from-user
+		 "Choose a font for the labels"
+		 frame
+		 (preferences:get 'paint-by-numbers:font))])
+      (when font
+	(preferences:set 'paint-by-numbers:font font))))
+  
+  (define (size-font inc)
+    (let ([old-font (preferences:get 'paint-by-numbers:font)])
+      (preferences:set 'paint-by-numbers:font
+                       (if (send old-font get-face)
+                           (send the-font-list find-or-create-font
+                                 (inc (send old-font get-point-size))
+                                 (send old-font get-face)
+                                 (send old-font get-family)
+                                 (send old-font get-style)
+                                 (send old-font get-weight)
+                                 (send old-font get-underlined))
+                           (send the-font-list find-or-create-font
+                                 (inc (send old-font get-point-size))
+                                 (send old-font get-family)
+                                 (send old-font get-style)
+                                 (send old-font get-weight)
+                                 (send old-font get-underlined))))))
+  
+  (define (add-font-items frame menu)
+    (make-object menu-item%
+      "Choose Font"
+      menu
+      (lambda x (configure-font frame)))
+    (make-object menu-item%
+      "Make Board Bigger"
+      menu
+      (lambda x (size-font add1))
+      #\b)
+    (make-object menu-item%
+      "Make Board Tinier"
+      menu
+      (lambda x (size-font sub1))
+      #\t))
+  
+  (define generic-frame%
+    (class (frame:standard-menus-mixin frame:basic%) 
+      (inherit set-label get-label get-area-container)
+      (define filename #f)
+      [define/public update-filename
+        (lambda (new-name)
+          (set! filename new-name)
+          
+          (let* ([short-name (if new-name
+                                 (let-values ([(_1 name _2) (split-path new-name)])
+                                   name)
+                                 #f)]
+                 [new-label (if short-name
+                                (format "~a - ~a" short-name (get-label))
+                                game-name)])
+            (unless (string=? new-label (get-label))
+              (set-label new-label))))]
+      
+      [define/public get-pbn-filename (lambda () filename)]
+      
+      [define/public (do-save) (void)]
+      [define/public (get-canvas) (void)]
+      
+      [define/private save-as
+        (lambda ()
+          (let ([fn (put-file)])
+            (when fn
+              (update-filename fn)
+              (do-save))))]
+      
+      [define/override file-menu:new-string (lambda () "New Puzzle")]
+      [define/override file-menu:new-callback
+	(lambda (_1 _2)
+	  (player))]
+      [define/override file-menu:between-new-and-open
+	(lambda (menu)
+	  (make-object menu-item% "Design a Puzzle..." menu
+            (lambda (_1 _2)
+              (editor #f)))
+	  (make-object menu-item% "Design a Puzzle from a Bitmap..." menu
+            (lambda (_1 _2)
+              (editor #t)))
+	  ;(make-object separator-menu-item% menu)
+          )]
+      [define/override file-menu:save-callback
+	(lambda (_1 _2)
+	  (if filename
+	      (do-save)
+	      (save-as)))]
+      [define/override file-menu:save-as-callback
+	(lambda (_1 _2)
+	  (save-as))]
+      [define/override file-menu:open-callback
+	(lambda (_1 _2)
+	  (let ([fn (get-file)])
+	    (when fn
+	      (let* ([state (call-with-input-file fn read)]
+		     [type (car state)])
+		(case type
+		  [(editor)
+		   (let* ([name (cadr state)]
+                          [problem
+                           (make-problem name
+                                         (caddr state)
+                                         (cadddr state)
+                                         (list->vector (map list->vector (car (cddddr state)))))])
+                     (editor problem))]
+		  [(player)
+		   (let* ([name (cadr state)]
+                          [problem
+                           (make-problem name
+                                         (caddr state)
+                                         (cadddr state)
+                                         (car (cddddr state)))])
+		     (player problem (cadr (cddddr state))))]
+		  [else
+		   (message-box "Error"
+				(format "Unknown save file ~a" fn))])))))]
+      
+      [define/override edit-menu:undo-callback
+	(lambda (_1 _2)
+	  (send (get-canvas) undo))]
+      
+      [define/override edit-menu:redo-callback
+	(lambda (_1 _2)
+	  (send (get-canvas) redo))]
+      
+      (super-new (style '(no-resize-border)))
+      
+      [field [top-panel (make-object horizontal-panel% (get-area-container))]
+             [help-button
+              (make-object button% "Help" top-panel (lambda (_1 _2) (show-this-help)))]]
+      (send top-panel stretchable-height #f)
+      (send top-panel set-alignment 'right 'center)))
+  
+  (define pbn-frame%
+    (class generic-frame% 
+      (init-field (problem (car problems)))
+      
+      (inherit get-pbn-filename)
+      [define/override do-save
+        (lambda ()
+          (call-with-output-file (get-pbn-filename)
+            (lambda (port)
+              (pretty-print
+               (list 'player
+                     (problem-name problem)
+                     (problem-rows problem)
+                     (problem-cols problem)
+                     (problem-solution problem)
+                     (send canvas get-grid))
+               port))
+            'truncate
+            'text))]
+      
+      (inherit can-close? show)
+      
+      (inherit stretchable-width stretchable-height update-filename)
+      [define/private set-problem
+        (lambda (prlmb)
+          (update-filename #f)
+          (send wrong-item enable (problem-solution prlmb))
+          (send editor-item enable (problem-solution prlmb))
+          (let ([rows (problem-rows prlmb)]
+                [cols (problem-cols prlmb)])
+            (set! problem prlmb)
+            (when canvas (send canvas close-up))
+            (set! canvas (instantiate paint-by-numbers-canvas% ()
+                           (parent canvas-panel)
+                           (row-numbers rows)
+                           (col-numbers cols)))
+            (send canvas-panel change-children (lambda (l) (list canvas))))
+          (stretchable-width #f)
+          (stretchable-height #f))]
+      
+      [define/private show-wrong
+        (lambda ()
+          (let loop ([i (length (problem-cols problem))])
+            (unless (zero? i)
+              (let loop ([j (length (problem-rows problem))])
+                (unless (zero? j)
+                  (let* ([m (- i 1)]
+                         [n (- j 1)]
+                         [board-entry (get-entry m n)]
+                         [real-answer (vector-ref (vector-ref (problem-solution problem) m) n)])
+                    (unless (or (eq? board-entry real-answer)
+                                (eq? board-entry 'unknown)
+                                (eq? real-answer 'unknown))
+                      (send canvas set-to-error m n)))
+                  (loop (- j 1))))
+              (loop (- i 1)))))]
+      
+      [define/private get-entry
+        (lambda (i j)
+          (send canvas get-rect i j))]
+      
+      [define/private set-entry
+        (lambda (i j nv)
+          (send canvas set-rect i j nv)
+          (send canvas paint-rect i j))]
+      
+      [define/private really-solve?
+        (lambda ()
+          (gui-utils:get-choice
+           (format "~
+           Solving can be a very computationally intense task;~
+           ~nyou may run out of memory and crash. ~
+           ~nReally continue? (Be sure to save your work!)")
+           "Yes"
+           "No"
+           "Really Solve?"
+           #f))]
+      
+      [define/private solve
+        (lambda ()
+          (when (really-solve?)
+            (send canvas all-unknown)
+            (send canvas on-paint)
+            (solve:solve
+             (problem-rows problem)
+             (problem-cols problem)
+             (lambda (i j nv) (set-entry i j nv))
+             setup-progress)))]
+      
+      (super-new (label game-name))
+      
+      [define wrong-item #f]
+      [define solve-item #f]
+      [define editor-item #f]
+      (inherit get-menu-bar)
+      (let* ([mb (get-menu-bar)]
+             [pbn-menu (make-object menu% "Nonogram" mb)])
+        (set! solve-item (make-object menu-item% "Solve" pbn-menu
+                           (lambda (_1 _2)
+                             (solve))
+                           #\l))
+        (set! wrong-item (make-object menu-item% "Show Mistakes" pbn-menu
+                           (lambda (_1 _2)
+                             (show-wrong)) #\h))
+        (set! editor-item (make-object menu-item% "Edit this Puzzle" pbn-menu
+                            (lambda (_1 _2)
+                              (editor problem))))
+        
+        (make-object separator-menu-item% pbn-menu)
+        (add-font-items this pbn-menu))
+      
+      (inherit-field top-panel help-button)
+      (inherit get-area-container)
+      [define gap (make-object horizontal-panel% top-panel)]
+      [define set-choice
+        (make-object choice%
+          "Set"
+          set-names
+          top-panel
+          (lambda (choice evt)
+            (set! problems (list-ref problemss (send choice get-selection)))
+            (send board-choice clear)
+            (for-each (lambda (problem) (send board-choice append (problem-name problem)))
+                      problems)
+            (set-problem (car problems))))]
+      [define board-choice (make-object choice%
+                             "Board"
+                             (map problem-name problems)
+                             top-panel
+                             (lambda (choice evt)
+                               (set-problem (list-ref problems (send choice get-selection)))))]
+      [define canvas/spacer-panel (make-object horizontal-panel% (get-area-container))]
+      [define canvas-panel (make-object vertical-pane% canvas/spacer-panel)]
+      [define canvas #f]
+      (send top-panel change-children (lambda (l) (list set-choice board-choice gap help-button)))
+      
+      (define/override get-canvas
+        (lambda ()
+          canvas))
+      
+      (define/augment on-close
+        (lambda ()
+          (inner (void) on-close)
+	  (when canvas (send canvas close-up))))
+      
+      (set-problem problem)
+      (show #t)))
+  
+  (define editor-frame%
+    (class generic-frame% 
+      (init-field indicator)
+      (inherit get-pbn-filename)
+      [define/override do-save
+	(lambda ()
+	  (let ([fn (get-pbn-filename)])
+	    (call-with-output-file fn
+	      (lambda (port)
+		(pretty-print
+		 (list 'editor
+		       (let-values ([(base name dir?) (split-path fn)])
+			 name)
+		       (send canvas get-row-numbers)
+		       (send canvas get-col-numbers)
+		       (let ([grid (send canvas get-grid)])
+			 (map (lambda (l) (map (lambda (x) (if (eq? x 'on) 'on 'off)) l)) grid)))
+		 port))
+	      'truncate
+	      'text)))]
+      
+      [define/private test-puzzle
+        (lambda ()
+          (player
+           (make-problem "<editor test>"
+                         (send canvas get-row-numbers)
+                         (send canvas get-col-numbers)
+                         (send canvas get-grid))))]
+      
+      [define canvas #f]
+      [define/override get-canvas
+        (lambda ()
+          canvas)]
+      
+      
+      [define/augment on-close
+	(lambda ()
+	  (inner (void) on-close)
+	  (when canvas (send canvas close-up)))]
+      
+      (super-instantiate () (label editor-name))
+      
+      (inherit get-area-container)
+      [define space/canvas-panel (make-object horizontal-panel% (get-area-container))]
+      [define canvas-panel (make-object vertical-pane% space/canvas-panel)]
+      
+      (cond
+        [(pair? indicator)
+         (when canvas
+           (send canvas close-up))
+         (set! canvas
+               (instantiate design-paint-by-numbers-canvas% ()
+                 (parent canvas-panel)
+                 (width (car indicator))
+                 (height (cdr indicator))))]
+        [(is-a? indicator bitmap%)
+         (when canvas
+           (send canvas close-up))
+         (set! canvas
+               (instantiate design-paint-by-numbers-canvas% ()
+                 (parent canvas-panel)
+                 (width (min biggest-editor (send indicator get-width)))
+                 (height (min biggest-editor (send indicator get-height)))))
+         (when (or (> (send indicator get-width) biggest-editor)
+                   (> (send indicator get-height) biggest-editor))
+           (message-box
+            "Paint by Numbers"
+            (format "WARNING: Bitmap is larger than ~ax~a. Truncating."
+                    biggest-editor biggest-editor)))
+         (send canvas set-bitmap indicator)]
+        [(problem? indicator)
+         (when canvas
+           (send canvas close-up))
+         (set! canvas
+               (instantiate design-paint-by-numbers-canvas% ()
+                 (parent canvas-panel)
+                 (width (length (problem-cols indicator)))
+                 (height (length (problem-rows indicator)))))
+         (send canvas set-grid
+               (map vector->list (vector->list (problem-solution indicator))))])
+      
+      (inherit get-menu-bar)
+      (let* ([mb (get-menu-bar)]
+             [pbn-menu (make-object menu% "Nonogram" mb)])
+        (make-object menu-item% "Test Puzzle" pbn-menu (lambda (_1 _2) (test-puzzle)))
+        
+        (make-object separator-menu-item% pbn-menu)
+        (add-font-items this pbn-menu))))
+  
+  (define (editor bitmap?)
+    (let* ([default 15]
+	   [get-sizes
+	    (lambda ()
+	      (let* ([d (make-object dialog% "Size")]
+		     [m (make-object message% "How big should the designer be?" d)]
+		     [wp (make-object horizontal-panel% d)]
+		     [wm (make-object message% "Width" wp)]
+		     [gw (make-object slider% #f 1 biggest-editor wp void default)]
+		     [hp (make-object horizontal-panel% d)]
+		     [hm (make-object message% "Height" hp)]
+		     [gh (make-object slider% #f 1 biggest-editor hp void default)]
+		     [bp (make-object horizontal-panel% d)]
+		     [cancelled? #f]
+		     [cancel (make-object button% "Cancel" bp (lambda (_1 _2)
+								(set! cancelled? #t)
+								(send d show #f)))]
+		     [ok (make-object button% "OK" bp (lambda (_1 _2) (send d show #f)) '(border))])
+                
+		(let ([label-width (max (send wm get-width)
+					(send hm get-width))])
+		  (send wm min-width label-width)
+		  (send hm min-width label-width))
+                
+		(send bp set-alignment 'right 'center)
+                
+		(send d show #t)
+		(if cancelled?
+		    #f
+		    (cons (send gw get-value)
+			  (send gh get-value)))))]
+	   [get-bitmap
+	    (lambda ()
+	      (let* ([fn (get-file "Select a bitmap")]
+		     [bm (make-object bitmap% fn)])
+		(if (send bm ok?)
+		    bm
+		    (begin
+		      (message-box
+		       "Paint by Numbers"
+		       (format (format "Unreadable file: ~a" fn)))
+		      #f))))]
+	   [indicator
+	    (cond
+              [(boolean? bitmap?)
+               (if bitmap?
+                   (get-bitmap)
+                   (get-sizes))]
+              [(problem? bitmap?)
+               bitmap?])])
+      
+      (when indicator
+	(send (make-object editor-frame% indicator) show #t))))
+  
+  (define player
+    (case-lambda
+     [() (player (car problems))]
+     [(problem)
+      (let ([f (instantiate pbn-frame% () (problem problem))])
+	(send f show #t))]
+     [(problem state)
+      (let ([f (make-object pbn-frame% () (problem problem))])
+	(send (send f get-canvas) set-grid state)
+	(send f show #t))]))
+  
+  (define game-unit
+    (unit
+      (import)
+      (export)
+      (player)
+      ;(editor #f)
+      )))
diff --git a/collects/games/paint-by-numbers/problem.ss b/collects/games/paint-by-numbers/problem.ss
new file mode 100644
index 0000000000..ad22b47078
--- /dev/null
+++ b/collects/games/paint-by-numbers/problem.ss
@@ -0,0 +1,3 @@
+(module problem mzscheme
+  (provide (struct problem (name rows cols solution)))
+  (define-struct problem (name rows cols solution)))
diff --git a/collects/games/paint-by-numbers/problems/directory b/collects/games/paint-by-numbers/problems/directory
new file mode 100644
index 0000000000..2d8ca7b0f4
--- /dev/null
+++ b/collects/games/paint-by-numbers/problems/directory
@@ -0,0 +1,31 @@
+("games"
+ "misc"
+ "h1-30"
+ "h31-60"
+ "h61-90"
+ "h91-120"
+ "h121-138"
+ "k15x15"
+ "k15x20"
+ "k15x25"
+ "k20x15"
+ "k20x20"
+ "k20x25"
+ "k20x30"
+ "k25x15"
+ "k25x20"
+ "k25x25"
+ "k25x30"
+ "k25x35"
+ "k30x20"
+ "k30x25"
+ "k30x30"
+ "k30x35"
+ "k30x40"
+ "k35x25"
+ "k35x30"
+ "k35x35"
+ "k35x40"
+ "k40x30"
+ "k40x35"
+ "k40x40")
diff --git a/collects/games/paint-by-numbers/problems/games b/collects/games/paint-by-numbers/problems/games
new file mode 100644
index 0000000000..580b3cb288
--- /dev/null
+++ b/collects/games/paint-by-numbers/problems/games
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Games Magazine") (define problems (list (make-problem "Izay (1)" (quote ((2) (1 1) (4) (2 1) (3 1) (8) (8) (7) (5) (3))) (quote ((1) (2) (1 6) (9) (6) (5) (5) (4) (3) (4))) (quote ("  x       " " xx       " "x xxxxxx  " "xxxxxxxxx " "    xxxxxx" "     xxxxx" "     xxxxx" "     xxxx " "     xxx  " "   xxxx   "))) (make-problem "Oam (2)" (quote ((1) (2 3 1) (9) (8) (8) (3 2 1) (6 6) (9 4) (11 2) (13) (2 10) (7 11) (8 5 5) (8 4 3) (8 4 2) (2 5 5) (1 4 2 3 2) (2 1 4 2) (9 3) (7))) (quote ((5) (9) (7 2) (3 6 2) (3 6 2) (4 6 2) (4 6 2) (5 4 2) (6 1 2) (11 2) (14 2) (6 10) (6 10) (3 2 4 4) (8 2 2) (8 3 2) (4 2 3) (5 3 2) (2 4 2) (3))) (quote ("           xxxxx    " "         xxxxxxxxx  " "        xxxxxxx  xx " "       xxx xxxxxx xx" "       xxx xxxxxx xx" "      xxxx xxxxxx xx" "      xxxx xxxxxx xx" "      xxxxx xxxx  xx" "      xxxxxx    x xx" "      xxxxxxxxxxx xx" "  xxxxxxxxxxxxxx xx " "xxxxxx xxxxxxxxxx   " " xxxxxx xxxxxxxxxx  " "  xxx xx xxxx  xxxx " " xxxxxxxx xx     xx " " xxxxxxxx xxx    xx " " xxxx xx  xxx       " "  xxxxx    xxx  xx  " " xx        xxxx xx  " "            xxx     "))) (make-problem "Izuoh (3)" (quote ((2) (3) (3) (2) (2) (2) (4 2) (6 2) (6 3) (1 2 1 6) (2 2 9) (1 1 7) (1 1 5) (3 1 2) (2 6) (11) (13) (13) (4 10 2) (4 10 4) (4 10 4) (4 10 4) (4 9 4) (4 9 4) (3 8 3) (3 11 3) (3 3 2 3) (5 5 4 2) (3 1 10 4) (3 1 8 5))) (quote ((3) (5) (7) (7) (6 3) (6) (7 3) (7 5) (12 5) (3 1 1 3 5 1 3) (4 1 11 3) (4 12 2) (3 1 13 2) (19 3) (12 3) (16 2) (16 1) (3 12 2) (4 6 4) (4 1 8) (3 8 2) (4 8 1) (10 6) (11 3) (3))) (quote ("                           xxx" "                         xxxxx" "                       xxxxxxx" "                     xxxxxxx  " "                   xxxxxx  xxx" "                  xxxxxx      " "                xxxxxxx   xxx " "              xxxxxxx    xxxxx" "       xxxxxxxxxxxx      xxxxx" "      xxx x  x xxx xxxxx x xxx" "      xxxx   x xxxxxxxxxxx xxx" "      xxxx     xxxxxxxxxxxx xx" "      xxx x   xxxxxxxxxxxxx xx" "       xxxxxxxxxxxxxxxxxxx xxx" "              xxxxxxxxxxxx xxx" "          xxxxxxxxxxxxxxxx xx " "          xxxxxxxxxxxxxxxx x  " "          xxx xxxxxxxxxxxx  xx" "         xxxx   xxxxxx    xxxx" "         xxxx     x   xxxxxxxx" "         xxx       xxxxxxxx xx" "        xxxx      xxxxxxxx   x" " xxxxxxxxxx       xxxxxx      " "xxxxxxxxxxx        xxx        " "xxx                           "))) (make-problem "Ijgnog (4)" (quote ((4) (5) (2 3) (2 6) (5 5) (6 5) (7 5) (8 8) (2 5 10) (2 6 12) (2 16 3) (1 2 14 3) (1 2 1 12 2) (1 1 2 11 2) (1 1 13 3) (1 1 1 3 5 4) (1 1 1 1 1 10) (1 1 1 1 8) (2 1 2 3) (1 2 2) (1 2 2) (1 1) (1 1) (3 1) (4))) (quote ((11) (7 3) (5 8) (10) (7 6) (11) (7 4) (9) (9) (5) (8) (9) (12 1) (16) (10 1) (8 5 1) (8 9) (9 4 1) (2 10 3 1) (10 4) (16) (2 10) (4 5) (2) (1))) (quote ("      xxxxxxxxxxx        " "    xxxxxxx       xxx    " "   xxxxx   xxxxxxxx      " "   xxxxxxxxxx            " "    xxxxxxx  xxxxxx      " "    xxxxxxxxxxx          " "     xxxxxxx  xxxx       " "       xxxxxxxxx         " "         xxxxxxxxx       " "          xxxxx          " "          xxxxxxxx       " "         xxxxxxxxx       " "         xxxxxxxxxxxx  x " "        xxxxxxxxxxxxxxxx " "        xxxxxxxxxx     x " "       xxxxxxxx xxxxx   x" "       xxxxxxxx xxxxxxxxx" "     xxxxxxxxx xxxx     x" "xx xxxxxxxxxx xxx       x" "xxxxxxxxxx   xxxx        " "xxxxxxxxxxxxxxxx         " "xx xxxxxxxxxx            " " xxxx  xxxxx             " "  xx                     " "  x                      "))) (make-problem "Uhib (5)" (quote ((4) (5) (3 1) (5 1 2) (4 1 1) (4 5) (4 3) (6 1) (15) (17) (19) (3 19 4) (15 6 2) (7 8 6 5) (2 3 2 1) (2 2 2 2) (1 8 2) (4 3 2) (8 2 1 3) (2 4 1 4) (2 4 4) (1 12) (1 9) (1 7) (1))) (quote ((1 1) (1 1 2 5) (5 2) (4 3 2) (7 2 1) (11 2 2) (2 11 2) (4 7 2) (2 6 3) (7 2) (4 6 3) (9 3) (4 6 2) (1 1 6 3) (1 6 1 3) (6 1 1 3) (6 3 3) (4 2 3) (6 4 3) (7 1 3) (8 4) (8 4) (4 4) (11) (1 6) (2) (5) (1 1 1) (1 1) (1 1))) (quote ("           x x           " "           x x xx   xxxxx" "           xxxxx   xx    " "  xxxx      xxx   xx     " " xxxxxxx    xx    x      " "xxxxxxxxxxx xx   xx      " "xx xxxxxxxxxxx   xx      " "xxxx  xxxxxxx    xx      " "xx     xxxxxx    xxx     " "       xxxxxxx    xx     " "   xxxx xxxxxx    xxx    " "     xxxxxxxxx     xxx   " "   xxxx xxxxxx      xx   " "   x x  xxxxxx      xxx  " "     x  xxxxxx  x    xxx " "        xxxxxx  x x  xxx " "        xxxxxx  xxx  xxx " "        xxxx    xx   xxx " "        xxxxxx  xxxx xxx " "        xxxxxxx x    xxx " "         xxxxxxxx   xxxx " "         xxxxxxxx  xxxx  " "          xxxx    xxxx   " "          xxxxxxxxxxx    " "           x  xxxxxx     " "            xx           " "           xxxxx         " "           x x x         " "           x x           " "           x x           "))) (make-problem "Isaniew (6)" (quote ((4 1) (7 2) (3 6) (2 3) (2 4) (5) (7) (7) (3 3) (2 2 2) (1 2 4) (3 2 2) (2 3 2) (3 2) (4 2) (3 2) (2 2) (2 1 1) (3 2) (3 2) (3 1) (3 2) (5 3 1 4) (7 2 1 7) (8 3 1 10) (7 2 1 10) (2 3 2 2 4 4) (2 2 2 2 3) (4 4 5) (13))) (quote ((3) (5) (3 2) (4 1) (5 1) (5 2) (4 1) (3 1 1) (1 2 1) (3 2) (7 5 3) (2 5 2 11 3) (4 4 2 10 1 2) (8 2 4 3 5 1) (2 4 1 4 2 2 1 1) (4 4 3 2 4 2 1) (4 5 3 3 4 2) (4 7 5 2) (1 1 3 5 1) (1 1 5 1) (2 4 2) (2 5) (5) (3) (3))) (quote ("                        xxx   " "                       xxxxx  " "                       xxx xx " "                       xxxx x " "                      xxxxx x " "                      xxxxx xx" "                      xxxx   x" "                      xxx  x x" "                      x   xx x" "                        xxx xx" "      xxxxxxx        xxxxx xxx" " xx  xxxxx xx xxxxxxxxxxx  xxx" "xxxx xxxx xx xxxxxxxxxx   x xx" "xxxxxxxx xx xxxx  xxx  xxxxx x" "xx  xxxx x xxxx xx   xx    x x" "xxxx xxxx xxx  xx xxxx  xx   x" " xxxx xxxxx  xxx xxx   xxxx xx" " xxxx   xxxxxxx       xxxxx xx" "  x x     xxx         xxxxx x " "  x x                 xxxxx x " " xx                   xxxx xx " "xx                     xxxxx  " "                       xxxxx  " "                        xxx   " "                        xxx   "))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/problems/h1-30 b/collects/games/paint-by-numbers/problems/h1-30
new file mode 100644
index 0000000000..7d33f26571
--- /dev/null
+++ b/collects/games/paint-by-numbers/problems/h1-30
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Hattori 1 - 30") (define problems (list (make-problem "Hattori 1" (quote ((5) (1) (3 1) (8) (2 1) (1 6) (1 1 1) (3) (1) (10))) (quote ((1) (4 1) (2 3) (1 2 1) (1 1 1 1) (1 2 1 1) (4 1 1) (1 2 1 1) (1 1 1 1) (5 1))) (quote ("         x" "    xxxx x" "   xx  xxx" "   x  xx x" "x  x x   x" "x xx x   x" "xxxx x   x" "x xx x   x" "x  x x   x" "  xxxxx  x"))) (make-problem "Hattori 2" (quote ((5 1 5) (5 2 6) (15) (4 5) (3 5 2) (3 6 1 2) (3 4 1 2) (3 3) (3 4) (1 1 1 1) (8) () (2) (1 9 1) (2 2 2))) (quote ((10 2) (9 1) (9) (4 2 1) (3 2 1 3) (1 3 1 3) (2 3 1 1) (3 3 1 1) (1 3 1 1) (2 1 1 1) (4 2 1) (4 2 1 1) (4 2) (9 1) (10 2))) (quote ("xxxxxxxxxx   xx" "xxxxxxxxx     x" "xxxxxxxxx      " "xxxx     xx  x " "xxx xx    x xxx" "  x xxx   x xxx" " xx xxx   x  x " "xxx xxx   x  x " "  x xxx   x  x " " xx  x    x  x " "xxxx     xx  x " "xxxx xx x    x " "xxxx   xx      " "xxxxxxxxx     x" "xxxxxxxxxx   xx"))) (make-problem "Hattori 3" (quote ((11) (1 11) (2 3 4 2) (4 2 2) (3 4) (2 3 3 3) (2 1 1 3) (2 1 1 3) (2 3 4) (2 1 4) (3 3 4) (2 2 2 4) (4 6) (11) (9))) (quote ((9) (12) (1 2 4) (4 1 3) (3 1 4) (3 4 2 2) (2 3 2) (2 4 2 2) (3 1 4) (3 1 3) (4 4) (5 7) (2 10) (12) (9))) (quote ("  xxxxxxxxx    " " xxxxxxxxxxxx  " "x  xx     xxxx " "xxxx x      xxx" "xxx  x     xxxx" "xxx  xxxx xx xx" "xx      xxx  xx" "xx   xxxx xx xx" "xxx  x     xxxx" "xxx  x      xxx" "xxxx       xxxx" "xxxxx   xxxxxxx" "xx  xxxxxxxxxx " " xxxxxxxxxxxx  " "  xxxxxxxxx    "))) (make-problem "Hattori 4" (quote ((6) (3 2) (2 1) (2 2) (2 1) (1 1) (2 1) (5 1) (2 4 5) (1 4 2 4) (1 5 1 4) (7 1 5) (7 7) (5 7) (5))) (quote ((5) (2 3) (1 4) (8) (10) (2 7) (2 5) (2) (1 5) (2 2 3) (1 1 4) (1 12) (4 7) (2 7) (1 5))) (quote ("        xxxxx  " "       xx  xxx " "       x  xxxx " "      xxxxxxxx " "    xxxxxxxxxx " "   xx  xxxxxxx " "  xx    xxxxx  " " xx            " " x       xxxxx " "xx      xx  xxx" "x       x  xxxx" "x  xxxxxxxxxxxx" "xxxx    xxxxxxx" "xx      xxxxxxx" "x        xxxxx "))) (make-problem "Hattori 5" (quote ((2 1) (11) (3 3) (2 4) (3 3) (2 2 2 3) (2 2 2 2) (2 1 1 2) (2 2 2 2) (3 2) (1 1 2) (1 4) (1 3 1 1) (1 1 1 2) (6))) (quote ((7) (8) (4 5) (3 1) (2 4 3) (1 2 1 1 1) (1 3) (1 1) (1 2 1 1) (1 4 1) (1 2) (4 1) (5 1) (10) (10))) (quote ("    xxxxxxx    " "  xxxxxxxx     " " xxxx    xxxxx " "xxx           x" "xx   xxxx   xxx" " x   xx x   x x" " x          xxx" " x            x" " x   xx x     x" " x   xxxx    x " " x          xx " "xxxx       x   " " xxxxx     x   " "  xxxxxxxxxx   " "   xxxxxxxxxx  "))) (make-problem "Hattori 6" (quote ((4) (6 1) (2 1 1 2) (5 1 3) (5 1 2 1) (6 1 2 1) (6 3 1) (6 2 2) (4 1 1 2) (2 1 1) (2 2) (7) (1 1) (2 2) (6))) (quote ((1 1) (1 6) (1 7) (9) (8) (2 4) (1 1 6 1) (1 2 2) (8 4) (3 1 1) (2 1 2) (2 4) (2 1 1) (2 2 2) (6 2))) (quote (" x x           " " x xxxxxx      " " x xxxxxxx     " " xxxxxxxxx     " " xxxxxxxx      " "xx  xxxx       " "x x  xxxxxx   x" "x         xx xx" "xxxxxxxx   xxxx" "      xxx  x  x" "     xx    x xx" "    xx     xxxx" "   xx   x  x   " "  xx   xx xx   " "  xxxxxx xx    "))) (make-problem "Hattori 7" (quote ((3) (5) (3 1) (3 3 1) (6 2 1) (7 3) (2 2 1) (1 1 1 1 1) (2 1 1 1 1) (1 1 2 1) (1 1 1) (13) (4 8) (9) (4 3))) (quote ((3 3) (3 2 4) (2 5) (3 2 4) (3 1 1 1) (3 2 4) (3 6) (5 4) (3) (2) (4 2) (6 2) (4 8) (2 1 1) (4))) (quote ("      xxx   xxx" "    xxx xx xxxx" "    xx    xxxxx" "   xxx xx  xxxx" "   xxx   x x x " "   xxx xx  xxxx" "    xxx  xxxxxx" "     xxxxx xxxx" "           xxx " "           xx  " " xxxx      xx  " "xxxxxx     xx  " "xxxx xxxxxxxx  " "xx   x     x   " " xxxx          "))) (make-problem "Hattori 8" (quote ((7) (6 2) (1 3 3) (2 2 2) (2 1) (3 2 1) (3 3 2 1) (1 4 2 1) (1 2 2) (2 2 6) (1 2 1) (1 1 3) (1 4 1) (2 5) (9))) (quote ((4) (3 1 5) (1 2 2 2) (1 2 1 1) (2 1 1 1) (2 3 1 1) (3 1 2 1) (1 1 2 3 1) (1 2 2 1 1) (1 1 2 1 1) (2 1 3) (2 2 1 1) (1 2 3 1) (2 2 1 1) (7 3))) (quote ("      xxxx     " " xxx  x  xxxxx " " x xx xx     xx" " x  xx x      x" "xx   x x      x" "xx   xxx x    x" "xxx   x  xx   x" "x x   xx  xxx x" "x xx   xx   x x" "x  x    xx  x x" "xx       x  xxx" " xx  xx  x   x " "  x  xx  xxx x " "  xx    xx x x " "   xxxxxxx xxx "))) (make-problem "Hattori 9" (quote ((3) (2 2) (1 2) (1 11) (1 2 4) (2 2 2 1) (3 3 1 1) (2 2) (1 1) (1 1) (7) (3 3) (2 2) (3 3) (3 3))) (quote ((5) (2 2) (1 1) (2 2 5) (5 8) (3 2 2 2) (1 1 1) (1 2 2 2) (1 8) (1 5) (4) (3) (2) (4) (1))) (quote (" xxxxx         " "xx   xx        " "x     x        " "xx   xx   xxxxx" " xxxxx xxxxxxxx" "  xxx xx  xx xx" "   x  x   x    " "   x  xx  xx xx" "   x   xxxxxxxx" "   x      xxxxx" "   xxxx        " "   xxx         " "   xx          " "   xxxx        " "   x           "))) (make-problem "Hattori 10" (quote ((7 1) (2 2 1) (1 1 3) (1 1 1 3) (5 2) (13) (15) (3 5) (2 7 1) (3 10) (3 7) (6 2) (2 4) (2 3 2) (1 3 1) (1 3 1) (1 3 1) (2 2) (2 2) (6))) (quote ((5) (5) (3 2) (2 5) (1 2 2 2) (10 2 2) (2 6 1 2 1) (1 7 1 4 1) (2 13 1) (14 1 1) (1 2 5 2) (2 3 2 2) (2 2 2 5) (7 3) (5 4))) (quote ("      xxxxx         " "      xxxxx         " "     xxx xx         " "     xx      xxxxx  " "x    xx     xx   xx " "xxxxxxxxxx xx     xx" "xx  xxxxxx x  xx   x" "x  xxxxxxx x xxxx  x" "xx  xxxxxxxxxxxxx  x" "xxxxxxxxxxxxxx  x  x" "x    xx xxxxx     xx" "     xx xxx xx   xx " "  xx xx  xx  xxxxx  " "xxxxxxx  xxx        " "  xxxxx xxxx        "))) (make-problem "Hattori 11" (quote ((4) (6) (6) (3 6) (3 2 6) (3 6 4) (4 7) (11) (2 13) (1 13) (14) (9 4) (9 2) (8) (7) (6) (5 1) (3 4 3) (5 3 4) (16))) (quote ((5) (4) (3 1) (3 2) (5 3) (8 2) (10 2) (12 2) (13 1) (1 12 1) (14 1) (1 1 12) (12) (3 8) (4 3 1) (6 4 1) (6 3 2) (6 3 3) (6 2 3) (4 4))) (quote ("     xxxxx          " "     xxxx           " "     xxx         x  " "      xxx        xx " "       xxxxx     xxx" "     xxxxxxxx     xx" "    xxxxxxxxxx    xx" "   xxxxxxxxxxxx   xx" "   xxxxxxxxxxxxx   x" "   x xxxxxxxxxxxx  x" "    xxxxxxxxxxxxxx x" "    x x xxxxxxxxxxxx" "        xxxxxxxxxxxx" "        xxx xxxxxxxx" " xxxx   xxx        x" "xxxxxx  xxxx       x" "xxxxxx   xxx      xx" "xxxxxx    xxx    xxx" "xxxxxx     xx    xxx" " xxxx           xxxx"))) (make-problem "Hattori 12" (quote ((5 7) (5 3 3) (4 2 7 2) (4 1 1) (3 1 1) (2 1 3 1) (1 1 1 1) (1 1 9 1) (13) (2 11) (2 13) (3 11 2) (16 1) (15 1) (15 1) (13 1) (12 2) (10 3) (12) (18))) (quote ((8 1) (6 2) (5 3 1) (4 4 1) (2 6 1) (6 1) (7 8 1) (2 12) (1 13) (3 13) (1 1 13) (1 1 1 13) (1 1 15) (1 1 1 13) (1 1 13) (3 10 2) (1 9 2) (2 3 3 3) (7 2 4) (7 1))) (quote ("xxxxxxxx x          " "xxxxxx   xx         " "xxxxx     xxx      x" "xxxx       xxxx    x" "xx         xxxxxx  x" "            xxxxxx x" "  xxxxxxx xxxxxxxx x" " xx     xxxxxxxxxxxx" " x     xxxxxxxxxxxxx" "xxx    xxxxxxxxxxxxx" "x x    xxxxxxxxxxxxx" "x x  x xxxxxxxxxxxxx" "x x  xxxxxxxxxxxxxxx" "x x  x xxxxxxxxxxxxx" "x x    xxxxxxxxxxxxx" "xxx    xxxxxxxxxx xx" " x     xxxxxxxxx  xx" " xx     xxx xxx  xxx" "  xxxxxxx xx    xxxx" "           xxxxxxx x"))) (make-problem "Hattori 13" (quote ((2 2) (2 3) (3) (2 12) (2 15) (17) (18) (3 12) (4 1 13) (4 13) (8 7) (10 7) (11 7) (18) (18) (17) (14) (3) (3) (2))) (quote ((2 2 2) (2 7) (2 9) (2 11) (2 6) (3 1 7) (3 7) (14) (14) (7 6) (10 8) (10 7) (10 6) (14) (14) (14) (14) (14) (14) (3 2 2 2))) (quote ("   xx   xx xx       " "   xx  xxxxxxx      " "xx    xxxxxxxxx     " "xx   xxxxxxxxxxx    " "     xx   xxxxxx    " "    xxx x xxxxxxx   " "    xxx   xxxxxxx   " "   xxxxxxxxxxxxxx   " "   xxxxxxxxxxxxxx   " "   xxxxxxx xxxxxx   " "xxxxxxxxxx  xxxxxxxx" "xxxxxxxxxx   xxxxxxx" " xxxxxxxxxx  xxxxxx " "   xxxxxxxxxxxxxx   " "   xxxxxxxxxxxxxx   " "   xxxxxxxxxxxxxx   " "   xxxxxxxxxxxxxx   " "   xxxxxxxxxxxxxx   " "   xxxxxxxxxxxxxx   " "    xxx xx xx xx    "))) (make-problem "Hattori 14" (quote ((8) (9) (1 5) (1 1 3) (1 2) (2 2) (1 2 2) (3 3) (1 10) (12) (1 4 2 1) (1 5 6) (1 5 2 1) (1 6) (1 7) (1 3 3) (1 1 3 4) (1 6 3) (2 1 3 4) (19))) (quote ((3) (2) (1) (3 1 1) (2 11) (3 1 1) (5 2 7) (2 2 2 8) (2 1 14) (3 8 1) (3 11 2) (7 12) (6 2 1 6) (4 3 1 4) (2 5 1) (1 1) (1 1) (1 1) (3 1) (1 1))) (quote ("                xxx " "                  xx" "                   x" "       xxx       x x" "      xx xxxxxxxxxxx" "       xxx       x x" " xxxxx  xx   xxxxxxx" "xx   xx xx  xxxxxxxx" "xx x  xxxxxxxxxxxxxx" "xxx    xxxxxxxx    x" "xxx   xxxxxxxxxxx xx" "xxxxxxx xxxxxxxxxxxx" "xxxxxx  xx x  xxxxxx" "xxxx    xxx x   xxxx" "xx      xxxxx      x" "           x       x" "           x       x" "           x       x" "          xxx      x" "           x       x"))) (make-problem "Hattori 15" (quote ((1) (1 17) (3 1 1) (1 1 1 3 3 3 1) (1 1 1 3 1 1 1 1 1) (3 1 3 3 3 1) (1 3 1) (1 16) (1) (1) (1 9) (1 2 1 2) (1 2 1 1 1) (1 2 1 3 2) (2 16) (3 16) (1 4 7 3 1) (1 1 4 8) (1 2 1 8) (1 2 1))) (quote ((20) (1 1 2) (6 2) (1 2 1) (7 3) (1 1 5) (1 3 1 4 1) (1 3 1 2 5) (1 3 1 2 4) (1 1 1 4) (1 3 1 1 5) (1 1 1 1 7 1) (1 3 1 1 6) (1 1 1 6) (1 3 1 1 4 2) (1 1 1 1 1 6) (1 3 1 2 5) (1 1 8) (7 3 3) (5))) (quote ("xxxxxxxxxxxxxxxxxxxx" "  x  x        xx    " " xxxxxx        xx   " " x    xx        x   " " xxxxxxx      xxx   " " x     x     xxxxx  " " x xxx x    xxxx  x " " x xxx x   xx xxxxx " " x xxx x  xx  xxxx  " " x     x  x   xxxx  " " x xxx x  x   xxxxx " " x x x x  xxxxxxx  x" " x xxx x  x   xxxxxx" " x     x  x  xxxxxx " " x xxx x  x xxxx xx " " x x x x  x  xxxxxx " " x xxx x  xx  xxxxx " " x     x   xxxxxxxx " " xxxxxxx     xxx xxx" "              xxxxx "))) (make-problem "Hattori 16" (quote ((6) (10) (3 5 3) (8 7) (6 7 3) (2 8 7) (5 10 3) (1 5 4 1) (5 5) (3 3) (3 4 2) (3 5 3) (3 5 2) (13) (5) (6) (7) (7) (7) (5))) (quote ((5) (3 4) (10) (2 3 2) (7 2) (5 1 1) (7 1) (2 1 2 1) (7 4) (7 7) (3 3 9) (7 9) (5 1 9) (1 4 7) (7 1 5) (2 4 1 4) (4 2 2 3) (7 2) (3 4) (7))) (quote ("      xxxxx         " "    xxx xxxx        " "   xxxxxxxxxx       " "   xx xxx  xx       " "  xxxxxxx   xx      " " xxxxx x     x      " " xxxxxxx     x      " "xx x xx      x      " "xxxxxxx   xxxx      " "xxxxxxx   xxxxxxx   " "xxx xxx   xxxxxxxxx " "xxxxxxx   xxxxxxxxx " "xxxxx x    xxxxxxxxx" " x xxxx      xxxxxxx" " xxxxxxx     x xxxxx" "  xx xxxx    x  xxxx" "  xxxx xx   xx   xxx" "   xxxxxxx xx       " "    xxx xxxx        " "     xxxxxxx        "))) (make-problem "Hattori 17" (quote ((9 9) (6 10) (5 11) (4 3 5) (2 1 3) (2 4 2) (1 3 6) (5 1 1 1) (2 2 1 3 1) (7 4 1) (7 4 2) (1 3 9) (1 2 4 6) (1 6 9) (1 4 7) (2 1 4 2) (5 3 4) (5 7) (5 10) (5 11))) (quote ((1 8) (2 4 4) (4 1 2 4) (8 2 4) (6 1 3 7) (4 8 4) (3 7 1) (1 2) (1 2) (2 2 2 1) (3 2 1 1 1 2) (7 8 2) (3 7 4 2) (3 1 1 2 3 3) (3 4 6 3) (4 1 4 3) (4 1 4 4) (5 1 4 4) (7 4 5) (7 6 5))) (quote ("x       xxxxxxxx    " "xx     xxxx    xxxx " "xxxx   x xx     xxxx" "xxxxxxxx xx     xxxx" "xxxxxx x xxx xxxxxxx" "xxxx   xxxxxxxx xxxx" "xxx     xxxxxxx    x" "x            xx     " "x           xx      " "  xx    xx  xx     x" " xxx  xx x  x   x xx" "xxxxxxx  xxxxxxxx xx" "xxx  xxxxxxx xxxx xx" "xxx  x  x xx xxx xxx" "xxx  xxxx xxxxxx xxx" "xxxx  x    xxxx  xxx" "xxxx  x    xxxx xxxx" "xxxxx x    xxxx xxxx" "xxxxxxx   xxxx xxxxx" "xxxxxxx xxxxxx xxxxx"))) (make-problem "Hattori 18" (quote ((3 4) (1 3 2 1) (1 6 3 2) (1 1 2 1 1 6) (3 2 1 1) (1 1 1 1 2 1 1 1) (1 1 2 1 2 2 2) (1 1 2 1 1 2 1) (1 2 4 1 3) (1 16) (2 5 10) (8 4 2) (8 2 4) (5 2 1 4) (1 5 6) (2 7 3 2) (2 8 2) (2 3 5 1 1) (2 5 7 3) (2 5 5 4))) (quote ((5 7 6) (1 1 3 5) (2 3 3) (3 2 3 2) (2 1 6 2) (2 2 5 5) (2 2 11) (2 1 5 6) (3 3 4) (1 1 5 6) (1 1 3 6) (6 2 5) (1 2 3 4) (3 2 4 3) (1 1 8 2) (1 2 3 5) (1 2 2 5 1) (1 1 3 3 2) (3 10 2) (1 2 8 3))) (quote ("xxxxx xxxxxxx xxxxxx" "x   x     xxx  xxxxx" "xx  xxx    xxx      " " xxx   xx  xxx    xx" " xx  x  xxxxxx    xx" "  xx  xx xxxxx xxxxx" "  xx  xx xxxxxxxxxxx" " xx  x  xxxxx xxxxxx" "xxx     xxx  xxxx   " "x  x xxxxx   xxxxxx " "x   x   xxx   xxxxxx" "xxxxxx   xx    xxxxx" "  x  xx  xxx    xxxx" "  xxx xx xxxx    xxx" "   x x  xxxxxxxx  xx" "   x  xx xxx  xxxxx " "   x  xx xx xxxxx  x" "   x x  xxx xxx   xx" "  xxx xxxxxxxxxx  xx" "  x  xx xxxxxxxx xxx"))) (make-problem "Hattori 19" (quote ((2 2 2 3) (2 2 3 5) (2 2 3 5) (1 1 2 5) (2) (8 2 2) (10 3 2 1) (11 3 2 1) (11 2 1 1) (11) (11 5) (10 7) (6 7) (4 6) (5 6) (6 5) (7 6) (7 7) (7 7) (6 6))) (quote ((4 7) (3 14) (15) (4 15) (3 15) (8 6) (3 7 5) (4 7 4) (3 7) (1 6) (4 4) (5) (4 2 2) (4 4 2 3) (2 4 5 4) (10) (3 10) (4 10) (9) (3 7))) (quote ("xxxx  xxxxxxx       " "xxx  xxxxxxxxxxxxxx " "     xxxxxxxxxxxxxxx" "xxxx xxxxxxxxxxxxxxx" "xxx  xxxxxxxxxxxxxxx" "     xxxxxxxx xxxxxx" " xxx xxxxxxx   xxxxx" "xxxx xxxxxxx    xxxx" "xxx  xxxxxxx        " "   x  xxxxxx        " " xxxx  xxxx         " "xxxxx               " "xxxx  xx          xx" "xxxx xxxx  xx    xxx" " xx  xxxx xxxxx xxxx" "          xxxxxxxxxx" "     xxx  xxxxxxxxxx" "     xxxx xxxxxxxxxx" "          xxxxxxxxx " "      xxx  xxxxxxx  "))) (make-problem "Hattori 20" (quote ((3 3 5) (9 1) (2 16) (1 2 6 4) (1 1 1 1 6 4) (1 1 6 2) (1 1 5 1) (1 1 4 3) (2 1 2 2 4) (1 3 5) (9 5) (7 4) (6 3) (4 1 2) (3 7 1) (5 1 6 1) (1 1 1 1 6 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1) (3 3 3))) (quote ((3) (11) (2 1 1) (1 1 5) (2 1 10) (2 1 6 1) (4 5 5) (13 1) (3 5 5) (4 2 1) (5 7) (6 1) (7 3) (7 4) (6 3) (1 1 2 4) (1 3 4 3) (1 3 6 5) (1 4 7 1) (20))) (quote ("xxx                 " "xxxxxxxxxxx         " "xx      x x         " " x  x     xxxxx     " " xx     x xxxxxxxxxx" " xx x     xxxxxx   x" "xxxx     xxxxx xxxxx" "xxxxxxxxxxxxx  x    " "xxx     xxxxx  xxxxx" "  xxxx    xx       x" "  xxxxx      xxxxxxx" "  xxxxxx      x     " "  xxxxxxx     xxx   " "  xxxxxxx     xxxx  " "  xxxxxx      xxx   " "x x      xx   xxxx  " "x xxx   xxxx  xxx   " "x xxx  xxxxxx  xxxxx" "x xxxx xxxxxxx     x" "xxxxxxxxxxxxxxxxxxxx"))) (make-problem "Hattori 21" (quote ((4 10) (2 1 3) (1 1 10) (1 1 4) (1 1 4) (1 1 2 2) (1 1 2 2 2) (1 1 1 1 1 1) (1 1 6 1 1) (2 1 2 1 4 2) (6 1 2 1 4) (11 3) (1 4) (1 4) (1 4) (1 5) (1 6) (18) (18) (18))) (quote ((9) (2 2) (1 1 3) (1 1 3) (11 3) (10) (4 3) (2 2 1 3) (6 2 3) (2 2 1 3) (9 2 3) (7 4 3) (3 1 1 3) (1 1 4 3) (1 1 1 1 4) (1 1 1 5) (1 1 4 8) (1 1 1 11) (1 1 1 10) (1 1 1 10))) (quote (" xxxxxxxxx          " "xx       xx         " "x         x      xxx" "x         x      xxx" "xxxxxxxxxxx      xxx" "          xxxxxxxxxx" "        xxxx     xxx" "     xx xx x     xxx" "   xxxxxx xx     xxx" "   xx   xx x     xxx" "xxxxxxxxx xx     xxx" "xxxxxxx xxxx     xxx" "xxx      x x     xxx" "x x     xxxx     xxx" "x x      x x    xxxx" "x x        x   xxxxx" "x x    xxxx xxxxxxxx" "x x   x  xxxxxxxxxxx" "x x   x   xxxxxxxxxx" "x x    x  xxxxxxxxxx"))) (make-problem "Hattori 22" (quote ((7) (3 1 7) (1 3 7) (2 2 8) (7 8) (4 1 8) (1 1 4 8) (2 3 8) (3 10) (14) (15) (15) (18) (16 1) (8 6) (7 5) (7 2 2) (2 2 1) (1) (1))) (quote ((2 10) (11) (9) (3 9) (3 8) (1 4 9) (2 2 1 9) (14) (3 1 6) (10) (9) (2 8 2) (1 14) (16) (16) (9 5) (9 1 2) (7 2) (6) (6))) (quote ("      xx  xxxxxxxxxx" "       xxxxxxxxxxx  " "        xxxxxxxxx   " "  xxx   xxxxxxxxx   " "   xxx   xxxxxxxx   " " x  xxxx xxxxxxxxx  " " xx xx x xxxxxxxxx  " " xxxxxxxxxxxxxx     " "  xxx x xxxxxx      " "    xxxxxxxxxx      " "      xxxxxxxxx     " "xx     xxxxxxxx xx  " "x  xxxxxxxxxxxxxx   " "xxxxxxxxxxxxxxxx    " "xxxxxxxxxxxxxxxx    " "xxxxxxxxx   xxxxx   " "xxxxxxxxx   x  xx   " "xxxxxxx     xx      " " xxxxxx             " " xxxxxx             "))) (make-problem "Hattori 23" (quote ((8 4) (10 1) (12 1 1) (3 1 1 2) (2 2 2 1 1 2) (2 1 1 1 1 2) (2 1 1 2) (2 1 1 1 1 1 2) (3 1 1 1 1 1 1) (2 6 1 1 2) (2 1 1 4) (2 9 4) (14 4) (15) (8 4 2) (8 2 2 1) (8 1 1 3) (2 5 1 2 1) (11 1) (10 5))) (quote ((9) (10) (5 1 5) (8 8) (4 1 9) (3 1 12) (3 2 1 1 9) (3 2 9) (3 1 1 3 2) (3 2 2 3 2) (3 1 1 1 3 2 2) (3 6 3) (9 4 2) (1 4 1) (5) (3) (13 1) (1 3 1 2 1) (1 5 4 3 1) (1 11 1 1))) (quote ("         xxxxxxxxx  " "        xxxxxxxxxx  " "  xxxxx x   xxxxx   " " xxxxxxxx   xxxxxxxx" "xxxx   x   xxxxxxxxx" "xxx x   xxxxxxxxxxxx" "xxx xx x x xxxxxxxxx" "xxx     xx xxxxxxxxx" "xxx    x x xxx    xx" "xxx xx  xx xxx    xx" "xxx x  x x xxx xx xx" "xxx       xxxxxx xxx" " xxxxxxxxx xxxx   xx" "  x         xxxx  x " "             xxxxx  " "                 xxx" "xxxxxxxxxxxxx      x" "x         xxx x xx x" "x  xxxxx xxxx xxx  x" "x xxxxxxxxxxx   x  x"))) (make-problem "Hattori 24" (quote ((5 3) (4 4 4) (1 2 10) (1 1 6 1 3) (1 1 2 1 6 2) (1 1 1 1 4) (3 1 1 1 1 1) (2 1 1 1 1 1) (2 3 4 4) (5 1 2 3 1) (1 3 1 1) (3 1 1 1) (5 3 1 2) (7 1 8) (10 1 1 1) (5 11) (3 7) (3 6 2) (3 7 1) (2 5))) (quote ((7) (1 3 6) (1 1 1 2 7) (2 1 7) (2 1 4) (1 1 4) (12) (1 1 1 4) (2 9 2) (4 1 2) (4 7 1) (5 2 1 1 3) (1 5 2 1 3) (1 1 1 7) (3 2 1 5) (1 1 5 5) (2 2 2 6) (4 4 1 2) (6 1 2 3) (2 16))) (quote (" xxxxxxx            " " x    xxx     xxxxxx" " x  x x xx   xxxxxxx" " xx      x  xxxxxxx " "  xx     x  xxxx    " "    x    x  xxxx    " "   xxxxxxxxxxxx     " "x  x    x  xxxx     " "xx xxxxxxxxx xx     " "xxxx      x   xx    " "xxxx     xxxxxxx  x " "xxxxx   xx  x  x xxx" "  x xxxxx   xx x xxx" "  x x   x    xxxxxxx" "  xxx   xx   x xxxxx" "  x x    xxxxx xxxxx" " xx xx  xx   xxxxxx " "xxxx xxxx    x xx   " "xxxxxx  x   xx xxx  " "xx xxxxxxxxxxxxxxxx "))) (make-problem "Hattori 25" (quote ((6 7) (3 2 8) (3 2 2 4) (2 3 1 2 3) (2 1 1 1 4 3) (2 4 1 2 2) (2 2 1 1 3) (3 2 2 1) (4 2 1 2) (7 2 1) (2 1 1 1) (2 1 1 1) (2 3 1) (2 2 1) (2 5) (2 1 1) (2 2 1) (4 1 1) (18) (18))) (quote ((7) (9) (3 3 2) (2 2 3) (1 3 11) (1 1 1 11) (1 4 1 3) (2 2 2 2) (2 2 2) (6 2) (2) (2) (3 2 2) (8 6 4) (2 2 3 5 2) (2 1 3 1 2) (3 3 1 2) (5 1 12) (7 2) (5 2))) (quote ("  xxxxxxx           " " xxxxxxxxx          " "xxx    xxx        xx" "xx      xx       xxx" "x  xxx   xxxxxxxxxxx" "x  x x   xxxxxxxxxxx" "x  xxxx  x       xxx" "xx   xx xx        xx" " xx    xx         xx" "  xxxxxx          xx" "                  xx" "                  xx" "xxx xx            xx" "xxxxxxxx xxxxxx xxxx" "xx xx  xxx  xxxxx xx" "xx  x     xxx x   xx" "xxx   xxx     x   xx" "xxxxx x xxxxxxxxxxxx" "xxxxxxx           xx" " xxxxx            xx"))) (make-problem "Hattori 26" (quote ((1 1 1 2) (2 2 2 2) (9 4) (1 1 1 3) (2 1 1 3 2) (3 1 1 1 4 2) (1 1 1 2 1 2) (1 4 5 1 2) (1 4 5 1 2) (1 8 1 3) (1 8 1 3) (1 8 1 3) (1 7 1 3) (2 7 2 3) (1 1 7 1 3) (2 7 2 3) (2 1 1 1 1 3) (7 2 9) (16) (1 1 6))) (quote ((2 1) (3) (5 2) (2 4 1) (7 2 2) (3 5 4) (2 2 9 2) (1 10 2) (2 2 7 2) (1 9 2) (1 2 10 1) (2 9 2) (15 3) (5 4) (2 3 3) (2 9 3) (2 3) (2 11) (20) (20))) (quote ("              xx x  " "               xxx  " "     xxxxx      xx  " "    xx    xxxx   x  " "  xxxxxxx    xx  xx " "xxx    xxxxx   xxxx " " xx xx xxxxxxxxx xx " "  x    xxxxxxxxxx xx" "  xx xx  xxxxxxx xx " "  x    xxxxxxxxx xx " "  x xx xxxxxxxxxx x " " xx    xxxxxxxxx xx " "xxxxxxxxxxxxxxx  xxx" "    xxxxx      xxxx " "    xx       xxx xxx" "xx   xxxxxxxxx   xxx" " xx              xxx" "  xx     xxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxx"))) (make-problem "Hattori 27" (quote ((6) (8) (1 6) (10) (2 1 1 1 1) (2 1 1 1 1) (1 1 1 3) (3 3 1) (3 2) (1 2 2) (2 2 3 2) (2 3 3 2) (2 3 2 6) (5 3 7) (4 4 3 1) (7 2 3 3) (6 4 3 1 1) (9 3 2) (8 6) (11 5))) (quote ((11) (10) (7) (8) (4 3 5) (1 5 3 6) (1 1 1 2 2 3) (2 6 2 4) (4 1 3 2 1) (9 2 2 1) (4 1 2 2 1) (8 3) (4 1 3) (5 3 3) (7) (13) (7 2) (2 2 2) (1 1 3) (7))) (quote ("         xxxxxxxxxxx" "          xxxxxxxxxx" "             xxxxxxx" "            xxxxxxxx" "  xxxx     xxx xxxxx" " x xxxxx  xxx xxxxxx" " x x   x  xx  xx xxx" "xx xxxxxx    xx xxxx" "xxxx    x   xxx xx x" "xxxxxxxxx   xx xx  x" "xxxx   x xx    xx  x" "xxxxxxxx xxx        " "xxxx  x   xxx       " "  xxxxx    xxx xxx  " "            xxxxxxx " "       xxxxxxxxxxxxx" "        xxxxxxx   xx" "            xx xx xx" "             x x xxx" "             xxxxxxx"))) (make-problem "Hattori 28" (quote ((1 1) (5) (3 3) (8) (9) (1 1 3 3) (1 1 3 1) (4 4 1) (2 2 2 3 1) (5 2 2 1) (5 3 1) (6 3 1) (5 5 2) (4 3 3 2) (8 2 3 2) (7 3 6) (6 3 6) (5 3 6) (5 3 5) (7 4))) (quote ((2 1) (3 4 1) (3 1 5 1) (10 1) (14) (3 4) (4 4 1) (9 5 1) (8 5 1) (8 2 1) (2 2 6 6) (4 5 6) (4 4 5) (4 3) (3 7) (2 6) (5) (5) (7) (12))) (quote ("        xx        x " "       xxx xxxx   x " "     xxx x xxxxx  x " "       xxxxxxxxxx x " "     xxxxxxxxxxxxxx " "          xxx xxxx  " "        xxxx  xxxx x" "  xxxxxxxxx  xxxxx x" "xxxxxxxx     xxxxx x" " xxxxxxxx   xx     x" "xx xx  xxxxxx xxxxxx" " xxxx   xxxxx xxxxxx" " xxxx     xxxx xxxxx" "  xxxx      xxx     " "   xxx       xxxxxxx" "    xx        xxxxxx" "               xxxxx" "               xxxxx" "            xxxxxxx " "      xxxxxxxxxxxx  "))) (make-problem "Hattori 29" (quote ((2) (2) (2) (4) (3 2) (5 2 2) (1 1 2 2) (5 2 2) (5 2 4) (5 2 3) (6 2 2) (1 1 4 1) (1 1 2 3 1) (2 2 1 4) (2 2 3 1 2) (1 4 5 3) (1 17) (4 4 4 2) (5 5 5) (3 3))) (quote ((8) (6 2 1) (1 4 3) (1 4 5) (1 4 2 2) (15) (6) (2) (2 4) (4 2 1) (3 2 3 1) (3 2 5 1) (2 2 2 2 5) (1 2 3 2) (2 2 3) (2 2 5) (2 5 2) (2 2 5) (3 2 3) (7))) (quote ("          xxxxxxxx  " "     xxxxxx  xx  x  " "     x xxxx     xxx " "     x xxxx    xxxxx" "     x xxxx    xx xx" "     xxxxxxxxxxxxxxx" "             xxxxxx " "                xx  " "    xx         xxxx " "   xxxx        xx x " "  xxx xx      xxx x " " xxx   xx   xxxxx x " "xx xx   xx xx xxxxx " "x   xx   xxx    xx  " "     xx   xx    xxx " "      xx   xx  xxxxx" "       xx   xxxxx xx" "        xx  xx xxxxx" "        xxx  xx xxx " "        xxxxxxx     "))) (make-problem "Hattori 30" (quote ((3 6) (6 7) (7 6) (19) (7 6) (3 3) (1 3) (2 4 4 1) (9 6 2) (1 2 2 1 3 2) (1 2 1 2 1 1 3 1) (1 2 2 1 3 1) (1 6 7 1) (1 4 5 1) (1 3 1) (1 3 5 1) (2 1 8) (3 7) (5 6 6) (5 4 5))) (quote ((3 9 2) (5 2 4) (12 3) (6 6 3) (5 2 2 2) (5 2 1 2) (4 2 2 1) (1 6 2 2) (1 4 3 2) (1 2 2) (1 5 2) (1 2 2 1) (2 1 2 1 2 1) (5 2 2 3) (5 7 4) (6 6 5) (7 4 5) (7 5) (4 4 4) (12))) (quote ("  xxx   xxxxxxxxx xx" " xxxxx xx       xxxx" " xxxxxxxxxxxx    xxx" "xxxxxx  xxxxxx   xxx" "xxxxx  xx   xx    xx" "xxxxx  xx x xx      " " xxxx  xx   xx    x " "   x   xxxxxx xx  xx" "   x    xxxx  xxx xx" "   x          xx  xx" "   x    xxxxx     xx" "   x   xx   xx    x " "xx x   xx x xx  x   " "xxxxx  xx   xx xxx  " "xxxxx  xxxxxxx xxxx " "xxxxxx  xxxxxx xxxxx" "xxxxxxx  xxxx  xxxxx" "xxxxxxx        xxxxx" " xxxx xxxx      xxxx" "        xxxxxxxxxxxx"))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/problems/h121-138 b/collects/games/paint-by-numbers/problems/h121-138
new file mode 100644
index 0000000000..7d3839f1bd
--- /dev/null
+++ b/collects/games/paint-by-numbers/problems/h121-138
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Hattori 121 - 138") (define problems (list (make-problem "Hattori 121" (quote ((2) (3) (4) (5) (2 2) (2 2) (3) (8 3) (2 1 2 4) (3 1 2 1) (5 2 2 1) (1 4 2 1) (1 1 5) (3 3 5) (5 7) (6 6) (7 7) (17) (15) (13))) (quote ((3) (5) (6) (2 7) (4 7) (1 11) (3 1 1 4) (7 1 3) (4 3 2 3) (8 1 3) (4 1 1 4) (2 10) (3 7) (7) (6) (7) (10) (8) (2 2) (7))) (quote ("               xxx  " "              xxxxx " "              xxxxxx" "        xx   xxxxxxx" "       xxxx  xxxxxxx" "       x xxxxxxxxxxx" "   xxx x  x     xxxx" " xxxxxxx  x      xxx" "xxxx  xxx xx     xxx" "xxxxxxxx   x     xxx" "  xxxx x   x    xxxx" "       xx xxxxxxxxxx" "        xxx  xxxxxxx" "             xxxxxxx" "              xxxxxx" "            xxxxxxx " "        xxxxxxxxxx  " "       xxxxxxxx     " "       xx   xx      " "       xxxxxxx      "))) (make-problem "Hattori 122" (quote ((2 2 5) (2 2 7) (9 6 4) (1 1 1 1 8 1) (7 9 2) (7 10 3) (9 2 3 2) (12 1 2 2 2 3) (3 3 1 1 1 1 2) (2 2 1 1 2) (2 2 2 3 2 2) (2 2 1 3 2 2) (12 7 3) (1 2 2) (5 6) (2 1 1 1 4) (2 1 1 2 3 2) (1 1 3 4 2) (1 1 1 1 1 1) (1 1 1 1 1 1) (5 1 4 2) (5 1 1 1 3 4) (1 4 1 13) (1 2 4 3 3) (1 3 5 3) (1 1 1 6 2) (2 3 6 4) (2 8 5) (3 22) (1 12 8) (15 8) (11 7) (9 6) (12 6) (3 18 2) (2 18 3) (2 2 12 3 1) (1 2 7 1) (2 2 2 2) (10 8))) (quote ((1 1 6) (2 7 1 2 3) (13 1 2 2 2) (1 1 5 1 2 3 2 2 1) (6 1 2 1 1 1 1 1 1) (1 4 1 1 3 1 2 1) (6 1 2 1 1 1) (1 1 5 1 3 5 1 1) (13 14 1) (2 7 12 3) (1 1 5 13 2) (1 1 2 17 1) (2 1 1 12) (6 1 1 2 11) (3 3 9 11) (3 2 1 1 1 11) (4 1 8 1 4 5) (4 3 6 4 4) (4 1 3 2 2 3 4) (4 2 5 3 1 4) (5 4 7 1 5) (7 2 1 2 3 1 4 2) (2 8 4 1 1 9 1) (2 11 8 1) (3 5 2 8 1) (3 4 2 3 10 1) (3 4 2 2 2 8 1 1) (2 4 4 10 2 1) (4 8 2 2) (3 5 5))) (quote #f)) (make-problem "Hattori 123" (quote ((4 8) (5 1 9) (3 1 1 10) (3 1 1 3 8) (3 1 2 2 1 7) (1 1 2 1 1 1 2 5) (1 2 1 1 1 2 1 2) (1 1 2 1 2 1) (2 1 1 1 2) (2 2 1 2 1) (2 1 2 1 2) (2 1 1 1 1) (2 2 1 2 2) (2 2 1 1 1) (1 1 1 1 1) (2 3 2 2) (2 2 1 2) (2 2 2 2) (2 2 2 1) (2 2 1 2) (2 2 5) (8 6) (6 7) (6 7) (12 6))) (quote ((6) (1 4 1) (4 3 2) (1 2 2 2) (4 3 2) (1 2 3 2) (4 4 2) (1 2 4 2) (1 3 1) (4 2 1) (2 3 2 1) (1 2 1) (1 5 2 1) (4 3 4 3) (5 7) (2 10) (2 5) (4 2 4 2) (6 4 3 3) (5 3 2 4) (8 7) (6 4 5) (6 3 2 5) (7 3 2 5) (9 6))) (quote ("    xxxxxx               " "    x   xxxx            x" "   xxxx   xxx          xx" "   x  xx    xx         xx" "  xxxx       xxx       xx" "  x  xx        xxx     xx" " xxxx           xxxx   xx" " x  xx            xxxx xx" " x                  xxx x" " xxxx                xx x" "xx  xxx              xx x" "x                    xx x" "x        xxxxx       xx x" "xxxx   xxx  xxxx    xxx  " "   xxxxx       xxxxxxx   " "  xx      xxxxxxxxxx     " " xx   xxxxx              " "xxxx xx     xxxx       xx" "xxxxxx   xxxx  xxx    xxx" "xxxxx  xxx       xx  xxxx" "xxxxxxxx          xxxxxxx" "xxxxxx      xxxx    xxxxx" "xxxxxx    xxx  xx   xxxxx" "xxxxxxx xxx     xx xxxxx " "xxxxxxxxx        xxxxxx  "))) (make-problem "Hattori 124" (quote ((8) (12) (14) (3 5) (1 3) (1 1 1 2) (9) (2 5 2) (2 2 2 2) (2 1 3 1 2) (1 1 3 1 1) (2 1 3 1 2) (2 2 2 2) (2 5 2) (9))) (quote ((2 3) (2 2 2) (3 2 2) (2 2 2) (3 1 5 1) (3 4 3) (3 2 3 2) (3 3 3 2) (3 2 3 2) (3 4 3) (4 1 5 1) (4 2 2) (4 2 2) (5 2 2) (4 3))) (quote ("   xx    xxx   " "  xx    xx xx  " " xxx   xx   xx " " xx   xx     xx" "xxx   x xxxxx x" "xxx  xxxx   xxx" "xxx   xx xxx xx" "xxx  xxx xxx xx" "xxx   xx xxx xx" "xxx  xxxx   xxx" "xxxx  x xxxxx x" "xxxx  xx     xx" " xxxx  xx   xx " " xxxxx  xx xx  " "  xxxx   xxx   "))) (make-problem "Hattori 125" (quote ((11) (11) (2 7) (6 5) (8 3) (3 5 2) (4 4 3 1) (3 3 5 1) (1 3 2 3 1) (3 2 3 1) (4 2 2 1) (2 2 1 4 1) (2 2 3 1) (4 1 2) (3 2 2 2) (3 1) (2) (2 2) (3 2) (2 4))) (quote ((3 2 6) (3 2 6) (2 3 2 2) (2 2 4) (3 2 2) (5) (7) (11) (12) (9 1) (6 3) (1 1 1 2) (2 2 2 2) (1 2 1 1 1) (1 2 2 2 1) (1 4 4 2) (2 6 2) (1 3 2) (2 4) (10))) (quote ("xxx  xx  xxxxxx     " "xxx  xx  xxxxxx     " "xx   xxx xx  xx     " "xx    xx  xxxx      " "xxx    xx  xx       " "xxxxx               " "xxxxxxx             " "xxxxxxxxxxx         " "xxxxxxxxxxxx        " "xxxxxxxxx          x" "xxxxxx           xxx" "    x   x     x  xx " "   xx  xx     xx  xx" "   x  xx   x   x   x" "   x  xx   xx xx   x" "   x  xxxx xxxx   xx" "   xx  xxxxxx    xx " "    x   xxx     xx  " "    xx       xxxx   " "     xxxxxxxxxx     "))) (make-problem "Hattori 126" (quote ((2 2) (4 4) (12) (13) (3 1 1 1 3) (2 1 1 1 2) (1 7 1) (1 1) (2 2) (2 2) (3 3) (3 3) (9) (7) (5))) (quote ((5) (3 3) (3 3) (3 3) (7 3) (4 1 3) (3 1 3) (5 3) (2 1 3) (3 1 3) (7 3) (4 3) (4 3) (4 3) (5))) (quote ("    xxxxx      " "   xxx  xxx    " "  xxx    xxx   " " xxx      xxx  " "xxxxxxx    xxx " "xxxx  x     xxx" " xxx  x     xxx" "  xxxxx     xxx" "  xx  x     xxx" " xxx  x     xxx" "xxxxxxx    xxx " "xxxx      xxx  " " xxxx    xxx   " "  xxxx  xxx    " "    xxxxx      "))) (make-problem "Hattori 127" (quote ((4) (5) (5 6) (6 6) (15) (7 3 2) (7 2 3 2) (3 3 4 2) (2 13 1) (1 5 7 1) (1 5 4 1) (1 3 2 1) (1 1) (1 1 1 1) (1 1 1 2) (2 1 1 2) (2 2 2 2) (6 2 2) (16) (14))) (quote ((9) (1 3 3) (3 2 3) (5 2 3) (5 4 7) (10 4) (8 3) (8 2) (2 2 2) (4 1 2) (3 1 2 2) (4 2 2) (10 2) (11 3) (11 4) (3 1 5 4 2) (2 4 2) (2 3) (2 4) (9))) (quote ("       xxxxxxxxx    " "  x   xxx      xxx  " "  xxx xx        xxx " "  xxxxx   xx     xxx" "  xxxxx xxxx xxxxxxx" "  xxxxxxxxxx    xxxx" "   xxxxxxxx      xxx" "   xxxxxxxx       xx" "    xx  xx        xx" "   xxxx x         xx" "  xxx x xx        xx" " xxxx   xx        xx" "xxxxxxxxxx        xx" "xxxxxxxxxxx      xxx" "xxxxxxxxxxx     xxxx" "xxx x  xxxxx xxxx xx" "    xx  xxxx      xx" "     xx         xxx " "      xx      xxxx  " "       xxxxxxxxx    "))) (make-problem "Hattori 128" (quote ((14 1) (4 8 1) (3 8 3) (3 1 1 7 1 1) (4 1 1 1 6 2 1) (4 3 1 6 1 1) (4 5 2 1) (4 4 5 1 1) (5 1 1 3 3) (4 4 1) (2 2) (5 7 1) (7 5 6) (4 3 3 3) (4 2 4) (7 4 1) (4 4 3 6 1) (4 2 6 3 2) (7 5 1 3) (2 2 1 1) (2 4 2) (1 1 2) (2 7) (3 8) (14))) (quote ((4) (6) (6 8) (9 6 3) (10 4 1 2) (3 6 3 1 1 2) (2 5 2 2 2) (1 3 3 1 2 1) (1 1 2 1 1 1) (1 3 3 2 2 1 1) (1 1 1 2 4 1) (3 2 1 1 1 1 2) (4 3 2 3 3) (6 2 3 4) (8 3 3 3) (9 3 1 3) (10 3 2 3) (9 1 1 2 4) (7 1 4 5) (2 7) (1 3) (5 1 5) (1 1 1 1 3 1) (4 1 2 3 2) (1 1 1 1 7))) (quote ("               xxxx      " "              xxxxxx     " "   xxxxxx    xxxxxxxx    " " xxxxxxxxx   xxxxxx xxx  " "xxxxxxxxxx  xxxx  x   xx " "xxx xxxxxx xxx x  x    xx" "xx      xxxxx  xx xx   xx" "x  xxx    xxx   x  xx   x" "x    x     xx   x   x   x" "x  xxx xxx xx   xx  x   x" "x      x x  xx   xxxx   x" "xxx xx x x   x    x    xx" "xxxx   xxx  xx  xxx   xxx" "xxxxxx     xx   xxx  xxxx" "xxxxxxxx  xxx   xxx   xxx" "xxxxxxxxx xxx    x    xxx" "xxxxxxxxxx xxx  xx    xxx" "xxxxxxxxx  x x  xx   xxxx" " xxxxxxx   x xxxx   xxxxx" "           xx xxxxxxx    " "            x  xxx       " "   xxxxx    x xxxxx      " "  x x x x   xxx   x      " "xxxx x xx   xxx  xx      " "  x x x x  xxxxxxx       "))) (make-problem "Hattori 129" (quote ((3) (5) (5) (6) (5 6) (7 6) (4 3 6) (4 2 8) (4 2 10) (4 1 5 5) (4 2 7 4) (6 2 8 2) (3 1 12) (1 1 2 1 11 1) (1 1 2 11 1) (1 2 3 14) (1 6 14) (1 3 17) (1 5 17) (8 5 3) (1 5 1 1 1) (1 6 1 1 1) (11 1 1) (1 1 4 1 1 1) (4 3))) (quote ((5 11) (6 1 1) (15 1) (9 9) (3 3 7) (2 1 2 1 6) (3 1 1 1 1 6) (7 2 5) (3 1 2 3) (2 1 2 1) (1 1 8) (9 1) (13) (10 1) (12) (13) (14) (16) (18) (9 9) (10 8) (6 4 2 4) (4 6 5 1) (4 1 10) (2 6 1))) (quote ("       xxxxx xxxxxxxxxxx " "      xxxxxx       x  x  " "     xxxxxxxxxxxxxxx  x  " "    xxxxxxxxx  xxxxxxxxx " "    xxx    xxx  xxxxxxx  " "    xx     x xx x xxxxxx " "    xxx x x   x x xxxxxx " "    xxxxxxx    xx  xxxxx " "     xxx       x xx  xxx " "            xx x xx   x  " "           x  x  xxxxxxxx" "           xxxxxxxxx    x" "            xxxxxxxxxxxxx" "          xxxxxxxxxx    x" "        xxxxxxxxxxxx     " "      xxxxxxxxxxxxx      " "     xxxxxxxxxxxxxx      " "   xxxxxxxxxxxxxxxx      " " xxxxxxxxxxxxxxxxxx      " "xxxxxxxxx xxxxxxxxx      " "xxxxxxxxxx xxxxxxxx      " "xxxxxx xxxx xx xxxx      " " xxxx  xxxxxx  xxxxx    x" "        xxxx x xxxxxxxxxx" "         xx   xxxxxx    x"))) (make-problem "Hattori 130" (quote ((3) (5 8) (6 9) (7 9) (7 5 3) (7 4 3) (5 3 2) (3 2 2) (2 1 1 1) (2 1 1) (1 1) (3 5 1) (1 5 1) (3 5 1) (7 1) (7 3 1) (6 4 1) (6 4 1 1) (13 6) (5 6))) (quote ((6 1 4) (6 2 1 4) (7 2 3 4) (6 1 4) (11 4) (6 4) (5 2 1) (1 1 1) (2 4 2) (3 4 4) (4 9) (5 9) (6 9) (7) (8 2) (2 3) (3 2) (3 2) (4 2) (15))) (quote ("xxxxxx       x xxxx " "xxxxxx  xx   x xxxx " "xxxxxxx xx xxx xxxx " " xxxxxx    x   xxxx " " xxxxxxxxxxx   xxxx " "  xxxxxx       xxxx " "   xxxxx      xx  x " " x            x   x " " xx        xxxx   xx" " xxx       xxxx xxxx" " xxxx      xxxxxxxxx" " xxxxx     xxxxxxxxx" " xxxxxx    xxxxxxxxx" " xxxxxxx            " " xxxxxxxx         xx" "  xx             xxx" "  xxx             xx" "   xxx            xx" "    xxxx          xx" "     xxxxxxxxxxxxxxx"))) (make-problem "Hattori 131" (quote ((4) (2 3) (1 4) (1 4 4) (6 6) (4 7) (7) (7) (4 6) (6 1 1) (2 5 3) (1 6 1 1) (1 6 2 1) (8 1) (7 2) (6 1) (9) (3) (1) (4))) (quote ((4) (2 2) (1 4) (6 4) (6 2 2) (4 2 5) (8) (9) (9) (8) (7) (1) (1) (3 1) (5 3 1) (9 4) (6 1 1 1) (6 3 3) (6 1) (7 1))) (quote (" xxxx               " "xx  xx              " "x xxxx              " "xxxxxx    xxxx      " "xxxxxx   xx  xx     " " xxxx   xx xxxxx    " "        xxxxxxxx    " "        xxxxxxxxx   " "        xxxxxxxxx   " "         xxxxxxxx   " "          xxxxxxx   " "                x   " "                x   " "     xxx        x   " "    xxxxx   xxx x   " "    xxxxxxxxx xxxx  " "   xxxxxx x      x x" "   xxxxxx xxx    xxx" "   xxxxxx          x" "   xxxxxxx         x"))) (make-problem "Hattori 132" (quote ((3) (1 1) (1 1 6) (1 1 1 4) (1 1 2 5) (1 1 2 5) (1 1 9) (1 1 10) (1 1 3 1 3) (1 1 3 1 2) (1 1 2 1 3) (1 1 2 2) (5 1 2) (1 2 2 1) (1 2 7) (3 7 2) (5 1 7) (5 1 7) (5 14) (3 1))) (quote ((3) (5) (5) (5) (3) (4) (13 4) (1 1 1 1) (14 1 1) (7) (1 5) (6 4) (11 3) (1 6 2 3) (1 2 1 1 1 4) (1 6 1 5) (6 2 1) (9 1 1) (10 1 1) (6 2 2 1))) (quote ("                xxx " "               xxxxx" "               xxxxx" "               xxxxx" "                xxx " "            xxxx    " "xxxxxxxxxxxxx  xxxx " "x           x  x  x " "xxxxxxxxxxxxxx x  x " "            xxxxxxx " "       x      xxxxx " "      xxxxxx   xxxx " "   xxxxxxxxxxx  xxx " "  x xxxxxx   xx xxx " "  x   xx  x x x xxxx" "  x xxxxxx  x xxxxx " "  xxxxxx      xx  x " "  xxxxxxxxx   x   x " "  xxxxxxxxxx  x   x " "   xxxxxx xx xx   x "))) (make-problem "Hattori 133" (quote ((3) (3 4 1) (7 4 5) (11 4 2 1) (15 2) (13 2) (14) (11) (17) (20) (22) (24) (24) (5 13 2) (16 1) (18) (19) (10 10) (9 11) (9 6 5) (9 6 4) (8 7 2) (7 6 1) (5 5) (3 3))) (quote ((1 3 3) (2 4 6) (2 5 8) (4 6 8) (5 6 9) (6 5 9) (6 5 9) (21) (20) (19) (1 16) (3 14 4) (17 7) (24) (23) (21) (17) (17) (2 11) (2 12) (2 4 7) (1 4 6) (1 4 5) (1 4 4) (3))) (quote ("   x       xxx        xxx" "   xx     xxxx     xxxxxx" "   xx    xxxxx   xxxxxxxx" "  xxxx  xxxxxx  xxxxxxxx " "  xxxxx xxxxxx xxxxxxxxx " " xxxxxx xxxxx xxxxxxxxx  " " xxxxxx xxxxx xxxxxxxxx  " " xxxxxxxxxxxxxxxxxxxxx   " "  xxxxxxxxxxxxxxxxxxxx   " "  xxxxxxxxxxxxxxxxxxx    " "x  xxxxxxxxxxxxxxxx      " "xxx xxxxxxxxxxxxxx   xxxx" "xxxxxxxxxxxxxxxxx xxxxxxx" " xxxxxxxxxxxxxxxxxxxxxxxx" " xxxxxxxxxxxxxxxxxxxxxxx " "   xxxxxxxxxxxxxxxxxxxxx " "      xxxxxxxxxxxxxxxxx  " "     xxxxxxxxxxxxxxxxx   " "    xx  xxxxxxxxxxx      " "   xx   xxxxxxxxxxxx     " "  xx     xxxx xxxxxxx    " "  x      xxxx  xxxxxx    " "  x       xxxx   xxxxx   " "  x        xxxx    xxxx  " " xxx                     "))) (make-problem "Hattori 134" (quote ((4) (3 3 4) (2 2 6 5) (5 8 5) (2 1 8 3) (3 7 3) (4 7 3 3) (5 5 5 1 1) (1 3 4 6) (1 4 4 6) (1 3 2 3 1) (1 4 1 3) (1 3 4) (1 7 4) (1 3 2 2 2) (1 3 1 6) (1 7 4 2) (1 4 1 3 4) (1 2 12) (2 8 2 1) (3 1 1 1 4 7) (14 2 5) (12 3 3) (8 4 2) (5))) (quote ((2 2) (4 3) (1 20) (3 3 2) (8 4) (6 3) (7 4) (7 3) (7 4) (4 5 3) (8 1 3 3) (11 2 8) (10 4 4 1) (9 1 5 1) (6 5 2) (1 5 2 4) (1 2 1 2 4) (2 2 4 2) (3 2 6) (3 4 4 4) (3 4 3 6) (3 3 11) (12 1 2 2) (4 2 10) (14))) (quote ("  xx                xx   " " xxxx              xxx   " " x xxxxxxxxxxxxxxxxxxxx  " " xxx xxx             xx  " "  xxxxxxxx          xxxx " "      xxxxxx         xxx " "       xxxxxxx      xxxx " "         xxxxxxx     xxx " "           xxxxxxx  xxxx " "   xxxx      xxxxx   xxx " "  xxxxxxxx   x  xxx  xxx " " xxxxxxxxxxx xx xxxxxxxx " " xxxxxxxxxx  xxxx  xxxx x" " xxxxxxxxx      x xxxxx x" "  xxxxxx        xxxxx  xx" "x xxxxx           xx xxxx" "x  xx  x          xx xxxx" "xx    xx         xxxx xx " "xxx   xx        xxxxxx   " " xxx  xxxx     xxxx xxxx " " xxx   xxxx   xxx xxxxxx " "  xxx   xxx xxxxxxxxxxx  " "  xxxxxxxxxxxx x xx xx   " "   xxxx xx xxxxxxxxxx    " "     xxxxxxxxxxxxxx      "))) (make-problem "Hattori 135" (quote ((1) (2 3 3) (9 7) (3 3 2 5) (2 4 1) (2 1) (1 1 2 1) (1 2 1) (1 6) (1 1 2) (1 1 2 1) (1 4) (1 1) (1 2) (3 6) (4 7) (14) (1 14 3) (1 11 3) (2 6))) (quote ((3) (2 1) (3 2) (3 4) (2 3 5) (4 5) (3 5) (13 3) (2 5) (2 3 5) (2 1 6) (2 13) (6 5) (1 1 1 5) (2 3 2 3 1) (3 2 1) (4 1) (3 3) (2 3) (1 3))) (quote ("                 xxx" "   xx              x" "  xxx           xx  " " xxx           xxxx " " xx xxx       xxxxx " "  xxxx        xxxxx " "  xxx         xxxxx " " xxxxxxxxxxxxx  xxx " " xx           xxxxx " " xx     xxx   xxxxx " "  xx    x    xxxxxx " "   xx xxxxxxxxxxxxx " "      xxxxxx  xxxxx " "  x     x  x  xxxxx " "  xx  xxx xx   xxx x" " xxx            xx x" "xxxx               x" " xxx             xxx" "  xx             xxx" "  x              xxx"))) (make-problem "Hattori 136" (quote ((11) (6 6) (6 5) (9 8) (6 4) (5 3 3 4) (5 1 1 1 1 4) (5 4) (2 4 2) (3 2 2) (1 1 9 3) (1 7 4 1 1) (1 3 4 1) (6 2 2 2 1) (2 1 1 4) (9 6) (1 4 6) (1 4 2 2 1 1) (1 1 3 4 1) (4 7 4))) (quote ((4 5 1) (5 1 1 5) (6 3 1 1 1) (7 1 3 3) (8 7) (5 2 3 4) (4 4 4) (4 2 2 3 2) (2 1 1 2 1 1 1 1) (1 1 2 1 1 1 1 1 1) (1 1 1 1) (1 1 1 1 1 1 1) (2 1 2 1 2 1 1 1 1) (2 1 1 2 3 2) (4 2 4 4) (4 2 3 2 1) (8 5 2) (7 3 1 1 1) (6 1 1 4) (5 5 1))) (quote ("    xxxx xxxxx     x" "   xxxxx x   x xxxxx" "  xxxxxx xxx x x   x" " xxxxxxx   x xxx xxx" " xxxxxxxx  xxxxxxx  " "xxxxx   xx xxx xxxx " "xxxx     xxxx  xxxx " "xxxx xx   xx  xxx xx" "xx x x    xx x x x x" "x  x xx x x  x x x x" "x       x x        x" "x       x x  x x x x" "xx x xx x xx x x x x" "xx x x    xx  xxx xx" "xxxx xx  xxxx  xxxx " "xxxx    xx xxx xx x " " xxxxxxxx   xxxxx xx" " xxxxxxx  xxx x x  x" "  xxxxxx  x   x xxxx" "   xxxxx  xxxxx    x"))) (make-problem "Hattori 137" (quote ((5 3) (3 3 2) (5 3) (4 1 4) (3 3 2) (8 1 1) (2 4 2 1 1) (11 2 2) (4 3 8) (2 10 4) (10 5 1) (8 10) (5 9 3) (3 9 6) (10 6 2) (6 12) (3 10 3) (10 5) (6 4) (7))) (quote ((5) (8) (10) (8 2 3) (6 10) (4 13) (11 2 4) (3 3 9 1) (3 15) (1 1 7 8) (1 2 7 2 1) (1 2 1 10) (2 4 7) (1 8 4) (2 8 1) (2 2 8) (3 6 4) (2 1 6 2) (1 2 3 5) (1 11))) (quote ("             xxxxx  " "           xxxxxxxx " "         xxxxxxxxxx " "     xxxxxxxx xx xxx" "   xxxxxx xxxxxxxxxx" "  xxxx xxxxxxxxxxxxx" " xxxxxxxxxxx xx xxxx" " xxx xxx xxxxxxxxx x" "xxx  xxxxxxxxxxxxxxx" "x x xxxxxxx xxxxxxxx" "x   xx xxxxxxx xx x " "x  xx  x xxxxxxxxxx " "xx    xxxx xxxxxxx  " " x   xxxxxxxx xxxx  " " xx     xxxxxxxx x  " "  xx   xx xxxxxxxx  " " xxx  xxxxxx xxxx   " "xx x    xxxxxx xx   " "x  xx  xxx xxxxx    " "x   xxxxxxxxxxx     "))) (make-problem "Hattori 138" (quote ((6 1 1) (8 3 3 1) (3 2 1 2 5 2) (2 1 1 1 1 4 3 3) (1 1 1 1 1 2 6) (1 1 1 4) (2 3 1 1 2) (2 2 1) (6 1 3) (7 1 1) (8 3 1 2) (2 8 1) (2 3 3 6 1 2) (2 1 4 1 1 1) (2 5 4 1 1) (3 3 3 4 6) (8 4 1 1) (8 5 6) (3 3 2 1) (3 3 2 4 4) (3 3 1 6 6) (3 3 2 2 2 2 2) (3 3 2 2 5 2) (8 8 6) (8 4 4))) (quote ((7 16) (4 19) (3 3 10) (2 2 1 3 2 2) (2 1 6 9) (2 2 1 5 10) (3 6 10) (7 2 4 2) (1 2) (6 2) (16 7) (1 6 3 1) (2 1 4) (2 1 6) (2 6 2 2) (3 1 3 2 2) (3 1 3 6) (3 1 3 4) (3 1 1) (3 6 4) (3 1 1 1 6) (3 8 1 2 2) (4 1 1 1 2 2) (4 1 1 1 8) (4 1 1 3 4))) (quote (" xxxxxxx xxxxxxxxxxxxxxxx" "xxxx  xxxxxxxxxxxxxxxxxxx" "xxx     xxx    xxxxxxxxxx" "xx xx x xxx     xx     xx" "xx    x xxxxxx  xxxxxxxxx" "xx xx x xxxxx  xxxxxxxxxx" "xxx    xxxxxx  xxxxxxxxxx" " xxxxxxx  xx  xxxx     xx" "           x xx          " "          xxxxxx     xx  " "xxxxxxxxxxxxxxxx xxxxxxx " " x        xxxxxx xxx   x " " xx              x  xxxx " "  xx             x xxxxxx" "   xx       xxxxxx xx  xx" "  xxx       x xxx  xx  xx" " xxx        x xxx  xxxxxx" "xxx         x xxx   xxxx " " xxx        x         x  " "  xxx       xxxxxx  xxxx " "   xxx  x      x x xxxxxx" "    xxx xxxxxxxx x xx  xx" "   xxxx x      x x xx  xx" "  xxxx    x x  x xxxxxxxx" " xxxx     x x  xxx  xxxx "))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/problems/h31-60 b/collects/games/paint-by-numbers/problems/h31-60
new file mode 100644
index 0000000000..ca0829a509
--- /dev/null
+++ b/collects/games/paint-by-numbers/problems/h31-60
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Hattori 31 - 60") (define problems (list (make-problem "Hattori 31" (quote ((8 7) (10 8) (10 9) (7 1 9) (5 2 3) (4 4 3) (4 1 3) (4 1 2 3) (4 2 1 2 1) (4 1 1) (4 1 1) (3 1 1 2) (3 1 2 1) (4 2) (4 1 3) (3 2 2) (3 1 2 2) (1 8 2) (19) (20))) (quote ((16 1) (17 2) (20) (11 2 2) (5 2) (4 2) (4 1 1 2) (3 2 3) (3 3) (3 3 2 4) (4 5 3) (4 2 5) (3 1 1 4) (4 1 3) (4 3) (4 1 1 2) (4 2 2) (8 2 2) (8 1 1 3) (13 1 3))) (quote (" xxxxxxxxxxxxxxxx  x" "xxxxxxxxxxxxxxxxx xx" "xxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxx  xx   xx" "xxxxx             xx" "xxxx              xx" "xxxx    x   x     xx" "xxx    xx        xxx" "xxx              xxx" " xxx    xxx xx  xxxx" "    xxxx   xxxxx xxx" "  xxxx xx      xxxxx" " xxx x  x       xxxx" "xxxx x           xxx" "xxxx             xxx" "xxxx       x    x xx" "xxxx           xx xx" "xxxxxxxx      xx  xx" "xxxxxxxx   x  x  xxx" "xxxxxxxxxxxxx x  xxx"))) (make-problem "Hattori 32" (quote ((11 5) (11 7) (11 7) (9 2 2) (7 3 3) (7 3 3) (7 3 3) (1 1 3 3) (1 1 4 4) (2 2 4 4) (1 1 4 4) (2 2 4 4) (1 1 4 4) (1 3 1 4 4) (1 1 1 4 4) (2 1 2 3 3) (2 1 2 3 3) (5 9) (3 9) (3 1 1))) (quote ((3) (4 5) (7 3 2) (10 2) (7 1 3) (7 7) (7 1 3) (10 2) (7 3 2) (4 5) (3) (16) (18) (19) (3 7 2) (3 2) (3 7 2) (19) (18) (16))) (quote ("xxx                 " "xxxx       xxxxx    " "xxxxxxx  xxx   xx   " "xxxxxxxxxx      xx  " "xxxxxxx      x   xxx" "xxxxxxx      xxxxxxx" "xxxxxxx      x   xxx" "xxxxxxxxxx      xx  " "xxxxxxx  xxx   xx   " "xxxx       xxxxx    " "xxx                 " "    xxxxxxxxxxxxxxxx" " xxxxxxxxxxxxxxxxxx " "xxxxxxxxxxxxxxxxxxx " "xxx     xxxxxxx  xx " "xxx              xx " "xxx     xxxxxxx  xx " "xxxxxxxxxxxxxxxxxxx " " xxxxxxxxxxxxxxxxxx " "    xxxxxxxxxxxxxxxx"))) (make-problem "Hattori 33" (quote ((1 1 1 1) (3 3 3) (3 1 5 5) (6 6) (6 1) (4 3 2) (4 4 4) (4 11) (17) (18) (18) (16 1) (16 1) (4 5 4) (2 6 2) (3 2 2 1) (2 2 1 1) (1 1 1 1) (1 1 1 1) (2 2 2 2))) (quote ((2) (3) (11) (14) (1 11) (16) (9 1) (6 5) (9) (1 12 1) (2 16) (3 10) (2 9 1) (1 7 6) (1 9) (2 10 1) (3 14) (4 7) (3 3) (2 4))) (quote ("   xx               " "  xxx               " "  xxxxxxxxxxx       " "xxxxxxxxxxxxxx      " " x xxxxxxxxxxx      " "xxxxxxxxxxxxxxxx    " "        xxxxxxxxx  x" "       xxxxxx  xxxxx" "      xxxxxxxxx     " "  x  xxxxxxxxxxxx  x" " xx xxxxxxxxxxxxxxxx" "xxx  xxxxxxxxxx     " " xx    xxxxxxxxx   x" "  x   xxxxxxx xxxxxx" "   x xxxxxxxxx      " "  xx xxxxxxxxxx    x" " xxx  xxxxxxxxxxxxxx" "xxxx   xxxxxxx      " " xxx    xxx         " "  xx     xxxx       "))) (make-problem "Hattori 34" (quote ((10) (14) (13 1) (11 3) (14) (1 1) (15) (3 3 3 1 1) (1 1 1 1 1 1) (1 1 1 2 3) (1 11 1 2) (1 2 1) (2 5 1 1) (2 3 2 1) (5 2 1) (1 4 5 1) (1 4 7 1) (1 16 1) (8 11) (6 10))) (quote ((5) (6 1 2) (4 4 3) (1 5 7) (2 1 1 6) (3 2 1 5) (4 3 1 1 4) (4 2 1 2 2) (5 1 2 2 1) (5 1 1 2 2) (5 2 1 1 4) (5 3 1 5) (5 2 1 5) (5 1 2 6) (5 4 7) (3 3 3 5) (3 6 4) (4 1 3) (1 1 2 2) (3 10))) (quote ("              xxxxx " "       xxxxxx x   xx" "    xxxx    xxxx xxx" "    x xxxxx  xxxxxxx" "   xx x   x   xxxxxx" "  xxx xx  x    xxxxx" " xxxx xxx x x   xxxx" " xxxx xx  x xx   xx " "xxxxx x  xx xx   x  " "xxxxx x   x xx   xx " "xxxxx xx  x x   xxxx" "xxxxx xxx x    xxxxx" "xxxxx xx  x    xxxxx" "xxxxx x  xx   xxxxxx" "xxxxx xxxx   xxxxxxx" "xxx xxx    xxx xxxxx" "xxx   xxxxxx    xxxx" "xxxx     x       xxx" " x x     xx       xx" " xxx      xxxxxxxxxx"))) (make-problem "Hattori 35" (quote ((3 3) (1 2 2 1) (1 4 2) (3 1 1 4) (4 3 2 2) (2 2 6 4 1) (8 11) (2 3 2 2 2 2) (5 2 3 3) (4 3 3 3) (1 2 3 2 1 1) (4 2 2 3) (2 1 2 2 4) (5 1 1 3) (1 4 5) (3 3 4 2) (19) (3 3 5 3) (4 4 5) (13))) (quote ((10) (5 3 2) (3 4 5) (2 9 3) (6 7) (8 3 2) (1 1 3 5) (2 2 5 2 1) (2 1 4 4) (8 1 2) (1 3 4) (8 4) (2 5 2 1) (1 1 5 5) (7 5 5) (6 3 2) (1 4 8) (4 7 3) (1 4 7) (3 4 3))) (quote ("      xxxxxxxxxx    " "     xxxxx xxx xx   " "    xxx xxxx xxxxx  " "   xx xxxxxxxxx xxx " "   xxxxxx    xxxxxxx" "xxxxxxxx      xxx xx" "x     x   xxx  xxxxx" "xx   xx  xxxxx  xx x" " xx  x xxxx     xxxx" "  xxxxxxxx      x xx" "  x xxx         xxxx" " xxxxxxxx       xxxx" "xx   xxxxx      xx x" "x     x xxxxx  xxxxx" "xxxxxxx  xxxxx xxxxx" "  xxxxxx      xxx xx" "   x xxxx   xxxxxxxx" "   xxxx xxxxxxx xxx " "    x xxxx xxxxxxx  " "     xxx xxxx xxx   "))) (make-problem "Hattori 36" (quote ((3 3) (1 6 1) (1 7) (1 1 2) (1 2 2 1 2) (1 1 1 1 1) (2 2 1) (2 2 1) (1 2 2 2 1) (1 2 2 1 1) (1 1 1) (4 3 1 1) (2 1 1 1 1 1) (13 1 1) (1 1 1) (2 4 1 1) (11 1 1) (1 4 5 1) (1 1 1 1 1 1 1) (5 5 6))) (quote ((9) (2 3 2) (7 1 1 1 1) (1 2 3 4) (2 2 2 1 1 1) (1 1 1 1 1) (1 1 4) (1 1 2) (1 2 2 1 2 1) (2 1 2 3 4) (1 1 1 1 1) (7 3 2 1) (1 2 1 1 3) (1 2 1 1) (1 8 3) (1 1 1) (1 5) (2 1) (2 1) (16))) (quote ("       xxxxxxxxx    " "      xx   xxx xx   " "xxxxxxx    x x  x  x" "x       xx xxx  xxxx" "xx  xx  xx   x  x  x" " x  x        x  x  x" " x           x  xxxx" " x           x  xx  " " x  xx  xx   x  xx x" "xx  x   xx xxx  xxxx" "x          x x  x  x" "xxxxxxx    xxx xx  x" "  x   xx     x x xxx" "  x    xx      x x  " "  x     xxxxxxxx xxx" "  x              x x" "  x            xxxxx" "  xx               x" "   xx              x" "    xxxxxxxxxxxxxxxx"))) (make-problem "Hattori 37" (quote ((6) (2 3) (10) (1 1 1 1) (1 1 1 1) (8) (3 1 3) (15) (2 10 2) (1 8 1) (1 2 2 1 1) (2 1 2 9) (3 1 2 1 4 3) (1 2 2 3 3) (4 5 2) (2 8 1 3) (1 5 2 2) (2 3 1 2) (9 1 2) (4 2 7))) (quote ((4 5) (2 2 2 3) (2 1 1 2) (3 5 2) (10 2 1) (3 1 3 1 1 2) (1 4 3 1 1 4) (1 1 5 3 5) (1 4 3 1 2 2) (3 1 3 4) (3 1 10) (11 2) (1 3 4 4) (1 2 7 1) (1 3 1) (2 2 2) (4 5) (7 1) (5 1) (2))) (quote ("        xxxx   xxxxx" "       xx  xx xx xxx" "      xx    x x   xx" "      xxx xxxxx   xx" " xxxxxxxxxx   xx  x " "xxx  x xxx  x  x xx " "x xxxx xxx x x xxxx " "x x  xxxxx xxx xxxxx" "x xxxx xxx  x  xx xx" "xxx  x xxx   xxxx   " "xxx  x xxxxxxxxxx   " " xxxxxxxxxxx  xx    " "  x   xxx  xxxx xxxx" "  x   xx  xxxxxxx  x" "       x   xxx     x" "       xx  xx     xx" "        xxxx   xxxxx" "           xxxxxxx x" "           xxxxx   x" "            xx      "))) (make-problem "Hattori 38" (quote ((6 6) (9 8) (3 5 3) (2 2 1) (1) (1) (2 1) (1 4) (9 3) (11 2) (14 2) (8 3 2) (8 1 4 2) (8 5 3) (20) (12 7) (1 1 1 1 2 5) (1 1 1 1 3 4) (13 3) (16))) (quote ((2 6 1) (3 11) (2 8 2) (3 12) (2 8 2) (2 12) (2 8 2) (2 12) (3 3 2 2) (3 3 1 6) (2 1 4 6) (2 7 3) (3 5 2) (2 6 1) (2 5 1) (2 7) (2 2 6) (3 3 6) (2 11) (2 10))) (quote ("   xx     xxxxxx  x " " xxx     xxxxxxxxxxx" " xx     xxxxxxxx  xx" "xxx     xxxxxxxxxxxx" "xx      xxxxxxxx  xx" "xx      xxxxxxxxxxxx" "xx      xxxxxxxx  xx" "xx      xxxxxxxxxxxx" "xxx     xxx   xx  xx" " xxx    xxx x xxxxxx" "  xx x xxxx   xxxxxx" " xx      xxxxxxx xxx" "xxx       xxxxx   xx" "xx        xxxxxx   x" "xx          xxxxx  x" "xx           xxxxxxx" "xx    xx      xxxxxx" "xxx   xxx    xxxxxx " " xx    xxxxxxxxxxx  " "  xx  xxxxxxxxxx    "))) (make-problem "Hattori 39" (quote ((2) (1) (10 9) (10 7 1) (10 5 3) (8 8) (7 4 2) (7 2 2 4) (7 2 7) (2 1) (1) (1 4) (1 1 1) (1 2 1 1 1) (2 2 1 4 1) (2 1 1 4 2) (3 4 1 1) (1 1) (1 2 2 1) (18))) (quote ((15 1) (8 3) (7 2 1) (7 2 1) (7 3 2) (7 2) (7 1) (4 1) (3 4 1) (1 3 2 1 1 1) (2 2 1 3 1) (3 1 4 1) (4 1 3 1) (7 4 1) (7 1) (5 1 1) (2 4 2) (4 2 1 2) (1 5 1 1) (8 6))) (quote ("  xxxxxxxxxxxxxxx x " "  xxxxxxxx    xxx   " "  xxxxxxx       xx x" "  xxxxxxx    xx    x" "  xxxxxxx    xxx  xx" "  xxxxxxx         xx" "  xxxxxxx          x" "  xxxx             x" "  xxx       xxxx   x" "x xxx  xx  x    x  x" "xx     xx  x  xxx  x" "  xxx      x xxxx  x" "  xxxx     x  xxx  x" "  xxxxxxx   xxxx   x" "  xxxxxxx          x" "  xxxxx x          x" "  xx xxxx         xx" "  xxxx xx       x xx" "  x xxxxx      x   x" "  xxxxxxxx    xxxxxx"))) (make-problem "Hattori 40" (quote ((8) (3 8) (3 1 4 2) (4 1 1 2) (1 1 1 1 3 4) (1 1 1 1 3) (1 1 1 1 1) (1 1 4) (2 1 1) (1 5 2 1) (3 1 3 3) (3 1 3 1) (3 2 3 3) (3 3 1) (1 1 1 1 3) (1 5 1 1) (11 2) (1 1 3) (13 5) (13 6))) (quote ((2) (5 3 4) (1 9 2) (2 4 1 2) (1 2 3 2) (3 1 2 2) (1 4 2 2) (4 1 1 2 2) (1 2 3 2) (6 4 1 2) (1 8 2) (6 3 4) (3 2) (4) (5 4 1) (3 4 1 2) (2 1 1 5 2) (2 4 1 1 3) (3 1 1 1 4) (3 1 5))) (quote ("                  xx" "    xxxxx  xxx  xxxx" "   x    xxxxxxxxx xx" "   xx     xxxx  x xx" "   x     xx   xxx xx" "  xxx    x     xx xx" "  x      xxxx  xx xx" " xxxx    x  x  xx xx" " x       xx   xxx xx" " xxxxxx   xxxx  x xx" "    x    xxxxxxxx xx" "    xxxxxx xxx  xxxx" "xxx               xx" "xxxx                " "xxxxx  xxxx        x" "xxx xxxx  x       xx" "xx  x  x  xxxxx   xx" "xx  xxxx    x x  xxx" "xxx  x      x x xxxx" "xxx  x         xxxxx"))) (make-problem "Hattori 41" (quote ((6 1 3) (5 1) (3) (2) (2 2 2) (1 4 4) (2 2 3 2) (5 6) (3 5) (2 3) (1 4 1) (1 2 3 3) (1 2 3 1) (2 2 1) (2 3) (2 5) (1 5) (1 6) (1 1 1 1 1 1 1 6) (1 1 1 1 1 1 1 6))) (quote ((6 10) (5 3) (3 2) (2 2) (2 4 2) (1 2 2) (5 2 2) (3 3) (2 2) (4) (1 4 2) (2 3) (4 2) (6) (2 3 3) (5 5) (3 5) (1 2 6) (1 1 6) (2 9))) (quote ("xxxxxx    xxxxxxxxxx" "xxxxx        xxx    " "xxx               xx" "xx    xx            " "xx   xxxx         xx" "x   xx xx           " "    xxxxx  xx     xx" "     xxx  xxx       " "         xx       xx" "         xxxx       " "x         xxxx    xx" "      xx   xxx      " "     xxxx         xx" "    xxxxxx          " "    xx xxx       xxx" "     xxxxx     xxxxx" "      xxx      xxxxx" "x         xx  xxxxxx" "x          x  xxxxxx" "xx         xxxxxxxxx"))) (make-problem "Hattori 42" (quote ((9) (3 6) (3 1 6) (4 1 1 4) (4 5) (6 1 7) (4 2 2 4) (3 6 3) (2 1 2 2 3) (1 1 1 1 2) (1 6 1) (1 4 2) (1 1 2) (3 2 2 3) (10 2 1) (9 1 1) (10 3 2) (15 1) (11 2 1) (7 3))) (quote ((2) (5 2) (7 4) (12 5) (6 7) (2 6 6) (1 2 2 2 6) (2 1 2 10) (4 5 7) (3 3 2 6) (9 1 2 4) (6 2 3 3) (6 2 3) (10 2) (6 3) (4 2) (5) (2 2) (1 1 1) (7))) (quote ("     xx             " "   xxxxx       xx   " "  xxxxxxx     xxxx  " "xxxxxxxxxxxx xxxxx  " "xxxxxx      xxxxxxx " "xx   xxxxxx  xxxxxx " "x xx  xx  xx  xxxxxx" "xx   x xx xxxxxxxxxx" "xxxx   xxxxx xxxxxxx" "xxx  xxx  xx  xxxxxx" "xxxxxxxxx x  xx xxxx" "xxxxxx  xx  xxx  xxx" " xxxxxx    xx    xxx" "  xxxxxxxxxx     xx " "    xxxxxx      xxx " "     xxxx       xx  " "              xxxxx " "             xx   xx" "             x  x  x" "             xxxxxxx"))) (make-problem "Hattori 43" (quote ((5) (3 3 3) (1 2 4 1) (2 10) (1 1 3 1) (2 1 3 2 2 1) (2 1 5 1 1 1) (2 7 1) (3 7 3 2) (3 7 3 2) (4 6 2 2) (4 7 2) (5 11) (5 1 4 3) (3 4 3 3 2) (4 2 3 2) (2 3 1) (2 2 1) (2 1) (5))) (quote ((3 3) (3 4) (9) (8) (6 3) (5 9) (3 3 5) (1 5 1) (2 7 1 1) (1 10 1 1) (1 11 6) (13 2 1) (2 1 7 1) (3 1 3) (2 2 2 4) (2 3 4) (3 2 3 1 2) (1 1 1 3) (3 7) (8 2))) (quote ("    xxx        xxx  " "     xxx      xxxx  " "       xxxxxxxxx    " "        xxxxxxxx    " "        xxxxxx  xxx " "   xxxxx  xxxxxxxxx " " xxx   xxx  xxxxx   " " x    xxxxx   x     " "xx    xxxxxxx x    x" "x   xxxxxxxxxx x   x" "x xxxxxxxxxxx xxxxxx" "xxxxxxxxxxxxx xx   x" "xx x    xxxxxxx    x" " xxx x     xxx      " "  xx xx xx xxxx     " "  xx    xxx xxxx    " " xxx xx xxx x xx    " " x x x     xxx      " " xxx    xxxxxxx     " "   xxxxxxxx  xx     "))) (make-problem "Hattori 44" (quote ((5) (5 6) (2 2 6 1) (6 6 2) (8 5 3) (2 1 1 5 5) (11 6) (4 5 7) (13) (9) (4 6) (5 3 4) (4 5 1 2) (2 4 3 3) (1 5 1 3) (6 2 3) (6 3 3) (5 3 2) (4 3 1) (3 3))) (quote ((4 4 4) (4 3 5) (2 2 3 6) (7 3 5) (4 1 3 5) (1 8 5) (4 4 5) (4 8) (7) (6 2 4) (3 4 7) (3 6 5) (4 5) (5 2 2) (5 3 2) (4 4 2) (4 4 3) (3 5 3) (2 5 3) (5 3))) (quote ("    xxxx   xxxx xxxx" "    xxxx   xxx xxxxx" "   xx xx  xxx xxxxxx" " xxxxxxx  xxx xxxxx " " xxxx x  xxx xxxxx  " " x xxxxxxxx xxxxx   " " xxxx xxxx xxxxx    " " xxxx xxxxxxxx      " "      xxxxxxx       " "     xxxxxx xx  xxxx" "    xxx xxxx xxxxxxx" "   xxx  xxxxxx xxxxx" "  xxxx xxxxx        " " xxxxx xx  xx       " "xxxxx xxx   xx      " "xxxx xxxx    xx     " "xxxx xxxx    xxx    " "xxx xxxxx     xxx   " "xx xxxxx       xxx  " "  xxxxx         xxx "))) (make-problem "Hattori 45" (quote ((8 3) (3 11) (9 1 3) (1 6) (2 7 2) (2 1 4) (4 5 3) (3 5) (1 2 3 2) (1 6) (11 1) (3 5) (3 6 3) (4 6 4) (4 15) (3 7 4) (8 3) (1 2 5) (5 5) (4))) (quote ((1) (1 1 1) (1 2 1) (2 3 2 3) (3 3 1 1 1) (2 1 1 4 2) (2 1 1 6 1) (4 4 3 1) (4 4 6) (11 7) (8 8) (8 9) (2 6 9) (2 1 3 9) (2 1 1 2 1 4) (2 1 1 3) (3 2) (1 1 1 5 1) (1 1 1 1 1 5) (1 1 1 1 1 1 5))) (quote ("              x     " " x    x       x     " " x   xx       x     " " xx xxx  xx  xxx    " "  xxx xxx x  x x    " " xx    x  x xxxx xx " " xx  x x xxxxxx   x " "xxxx     xxxx xxx x " "xxxx    xxxx xxxxxx " "xxxxxxxxxxx xxxxxxx " "xxxxxxxx xxxxxxxx   " "xxxxxxxx xxxxxxxxx  " "xx xxxxxx xxxxxxxxx " "xx  x xxx xxxxxxxxx " "xx  x   x  xx x xxxx" " xx x         x  xxx" "             xxx  xx" "x x   x     xxxxx  x" "x x x x x   xxxxx   " "x x x x x x xxxxx   "))) (make-problem "Hattori 46" (quote ((5) (4 8) (15) (3 10) (2 9) (1 1 1 1 3 5) (1 1 6 2 4) (1 2 2 4 3) (4 4 3 1) (3 2 1 2 3 1) (1 1 4 3 2) (1 2 2 1 2 2) (2 5 2 1) (3 6 1) (10 4 2) (6 5 1) (2 2 2) (2 2 2) (5 6) (2 13))) (quote ((10) (2 2 3) (2 1 3 2 1) (2 2 1 2 2) (2 3 2 2 1) (2 1 3 1 5) (2 8 5) (2 3 3 2 2) (1 2 3 1 3 1) (3 2 1 2 2 1) (6 2 1 3 3) (14 1 2) (12 3 2) (5 3 2) (5 2 3 2) (5 3 2 2) (6 1 1 1 1) (5 2 1) (5 3 1) (5 3 1))) (quote ("    xxxxxxxxxx      " "   xx   xx  xxx     " "  xx  x xxx  xx    x" "  xx   xx  x  xx  xx" " xx  xxx   xx xx  x " " xx   x xxx x xxxxx " " xx  xxxxxxxx xxxxx " " xx   xxx xxx xx  xx" "  x  xx xxx x xxx  x" " xxx  xx   x xx xx x" "xxxxxx xx x xxx  xxx" "xxxxxxxxxxxxxx x  xx" "xxxxxxxxxxxx xxx  xx" "xxxxx        xxx  xx" "xxxxx    xx  xxx  xx" " xxxxx   xxx  xx  xx" " xxxxxx  x x     x x" "   xxxxx        xx x" "   xxxxx      xxx  x" "     xxxxx  xxx    x"))) (make-problem "Hattori 47" (quote ((12) (2 3) (1 8 3) (1 3 3 2) (1 2 2 2) (1 2 2 2) (1 3 2) (11 3) (7 7) (3 3) (3 2) (1 1) (3 1) (2 1 2 1 1) (6 2 1 1) (2 1 5 5 1) (2 1 1 1 1 1 1 1) (2 1 1 2 1 1 1) (2 3 3) (2 2))) (quote ((7) (7) (6 1) (2 1 4) (1 7 1) (1 7 3) (1 2 5 1 2) (1 1 2 5 1 2 1) (1 1 2 4 1 2) (1 1 2 4) (1 1 2 2) (1 2 1 2) (1 1 1 1) (1 1 2 4) (2 1 1) (1 1 3) (2 1 1) (1 3 4) (9 2) (17))) (quote ("             xxxxxxx" "             xxxxxxx" " xxxxxx       x     " "xx     x      xxxx  " "x xxxxxxx     x     " "x xxxxxxx     xxx   " "x xx  xxxxx    x xx " "x x xx xxxxx x xx x " "x x xx xxxx    x xx " "x x    xx     xxxx  " "x x    xx    xx     " "x xx   x    xx      " "x  x   x    x       " "x  x   xx   xxxx    " "xx      x      x    " " x      x      xxx  " " xx     x      x    " "  x    xxx     xxxx " "  xxxxxxxxx       xx" "   xxxxxxxxxxxxxxxxx"))) (make-problem "Hattori 48" (quote ((5 3) (10 1 1) (5 4) (3) (7 3) (14) (16) (5 4) (4 3) (3 3 3 2) (1 1 3 2 2 1) (1 1 4 1 3 1) (1 1 4 1 3 1) (1 4 4 2) (1 3) (2 4) (3 6) (18) (16) (12))) (quote ((1 10) (1 3 4) (1 4 3) (1 4 3) (1 3 2 3) (3 3 1 1 3) (3 3 1 3 3) (3 3 5 3) (3 3 5 3) (3 3 3 3) (3 3) (3 4 3) (3 2 1 3) (2 1 3 4) (2 5 4) (4 3 3) (6 4) (5 3 4) (1 2 3 4) (3 8))) (quote (" x      xxxxxxxxxx  " " x     xxx     xxxx " " x    xxxx      xxx " " x   xxxx        xxx" " x   xxx   xx    xxx" "xxx  xxx  x  x   xxx" "xxx xxx  x xxx   xxx" "xxx xxx  xxxxx   xxx" "xxx xxx  xxxxx   xxx" "xxx xxx   xxx    xxx" "    xxx          xxx" "    xxx   xxxx   xxx" "    xxx  xx  x   xxx" "     xx  x xxx  xxxx" "     xx  xxxxx  xxxx" "    xxxx  xxx   xxx " "  xxxxxx       xxxx " "xxxxx xxx     xxxx  " "x xx   xxx   xxxx   " "xxx     xxxxxxxx    "))) (make-problem "Hattori 49" (quote ((2 2) (2 2) (3 3 3 3) (5 8 5) (3 3 3 3) (2 1 1 4 1 1 2) (2 1 8 1 2) (1 2 2 1) (1 1 1 1 1 1 1 1) (2 2 1 1) (1 1 1 1 2 1 1) (2 1 1 1 1) (1 1 1 1) (1 4 1) (9) (7 7) (1 7 1) (13 1) (4 4) (5 5))) (quote ((3) (7 1) (7 1 1 2) (1 5) (8 1 3) (1 1 3 1 3) (6 5 1) (1 4 4) (1 2 9) (1 2 1 5) (1 2 2 2 2) (1 2 1 5) (1 2 3 4) (9 4) (1 1 4 1) (10 1 3) (1 1 2) (7 5) (7 1 1 2) (3 1))) (quote ("  xxx               " "xxxxxxx            x" "xxxxxxx x x       xx" "   x           xxxxx" "  xxxxxxxx     x xxx" "  x x    xxx   x xxx" "  xxxxxx   xxxxx x  " "   x  xxxx    xxxx  " "   x xx  xxxxxxxxx  " "   x xx x    xxxxx  " "   x xx   xx xx xx  " "   x xx x    xxxxx  " "   x  xx  xxx xxxx  " "  xxxxxxxxx   xxxx  " "  x x       xxxx x  " "  xxxxxxxxxx   x xxx" "   x           x  xx" "xxxxxxx        xxxxx" "xxxxxxx x x       xx" "  xxx              x"))) (make-problem "Hattori 50" (quote ((1 1) (1 1) (2 15 1) (3 2 2) (3 1 4 2) (2 5 1) (2 1 3 3 1) (1 7 2) (1 1 5 1) (2 1 6) (3 9) (5 5 3) (6 4 3) (4 2 5) (1 2 1 6) (2 1 3 6) (1 2 4 6) (1 3 3 6) (2 1 3 3 1) (4 2 2))) (quote ((8 3) (5 2 2) (2 1 1 1 3 1) (1 1 4 3) (1 6 3) (1 1 1 3 1) (1 1 1 4) (1 2 4) (1 5 2) (1 6 4) (1 1 6 5) (1 2 8 4) (5 6) (6 4 5) (1 5 1 6) (1 9) (1 8) (1 7) (2 5 1) (7 2))) (quote ("xxxxxxxx         xxx" "  xxxxx       xx  xx" "   xx   x x x  xxx x" "  x   x  xxxx    xxx" "  x     xxxxxx xxx  " "  x x  x   xxx  x   " "  x    x x xxxx     " "  x   xx   xxxx     " "  x   xxxxx    xx   " "  x   xxxxxx   xxxx " "  x  x xxxxxx  xxxxx" "  x xx xxxxxxxx xxxx" "  xxxxx xxxxxx      " "  xxxxxx xxxx xxxxx " "  x xxxxx x  xxxxxx " "  x       xxxxxxxxx " "  x       xxxxxxxx  " "  x        xxxxxxx  " "   xx        xxxxx x" "xxxxxxx           xx"))) (make-problem "Hattori 51" (quote ((1 1 3 3) (4 2 4) (6 6) (3 1 7) (1 2 1 8) (3 2 1 8) (2 1 8) (4 1 9) (2 1 13) (2 1 2 6) (1 3 1 2) (1 3 2 1) (4 2 1) (2 3) (3 2) (7) (1 1) (2 1 2) (4 1) (5))) (quote ((1 1 3) (1 5) (8) (2 7) (3 2 3) (2 2 1 1 1) (1 1 2 2 2) (9 1 1 1) (2 1 2 4) (1 1 1 2) (3 1 1) (3 5) (5 2 1 1) (7 2 1) (10 2) (10 3) (12) (9) (9) (10))) (quote ("   x x xxx          " "   x xxxxx          " "xxxxxxxx            " " xx    xxxxxxx      " "xxx xx      xxx     " " xx xx      x x  x  " "x x        xx xx xx " "xxxxxxxxx  x   x  x " "xx      x xx   xxxx " "        x x    x  xx" "        xxx    x   x" "       xxx     xxxxx" "    xxxxx     xx x x" "  xxxxxxx    xx    x" "xxxxxxxxxx  xx      " "xxxxxxxxxx xxx      " "xxxxxxxxxxxx        " " xxxxxxxxx          " "  xxxxxxxxx         " "   xxxxxxxxxx       "))) (make-problem "Hattori 52" (quote ((5 6) (2 4 2) (2 6 2) (2 2 2 2) (2 2 2 1 1) (1 2 2 2 1 1) (1 2 2 1 2 1) (1 2 3 5 4) (1 3 2 1 1 1) (1 8 4 1) (1 3 1 3 1) (1 2 1 1 1 1) (1 1 2 2 2 1) (1 13 1) (7 2 1 1) (3 2 1) (2 2 3 2) (2 1 1 2 3) (4 1 1) (2 1 1))) (quote ((12) (2 3) (2 7) (2 3 2 2 2) (2 5 2 2) (1 7 1 2) (1 3 1 3 3) (1 5 1) (2 7) (5 1 2) (10 2) (3 1 2 3 1) (1 1 2 1 1 1 2) (1 1 2 1 1 1 1) (1 2 2 1 2 2) (2 4 1 1 1 1) (2 1 1 1) (2 3 3) (5 2) (13))) (quote ("    xxxxxxxxxxxx    " "   xx         xxx   " "  xx       xxxxxxx  " " xx   xxx xx xx  xx " "xx    xxxxx  xx   xx" "x       xxxxxxx x xx" "x    xxx x  xxx xxx " "x    xxxxx   x      " "xx     xxxxxxx      " " xxxxx   x  xx      " "xxxxxxxxxx   xx     " "xxx    x xx  xxx x  " "x x xx x  x  x xx   " "x x xx x  x  x  x   " "x xx  xx x  xx  xx  " "xx xxxx  x  x x  x  " " xx    x x x        " "  xx   xxx       xxx" "   xxxxx        xx  " "       xxxxxxxxxxxxx"))) (make-problem "Hattori 53" (quote ((1 1 1) (3 1 1 1) (1 3 3 3) (4 4 1) (11) (4 4 3) (1 1 2 1 2 1 1 1 1) (4 3 3 3) (2 4 4 4 1) (1 1 2 1 2 1 2 2) (4 3 3 3) (18) (2 2) (1 1 1 1 1 1 1 1) (15) (3 3) (3 4 3 3) (2 2 2 3) (2 1 3 1 3 1 2) (1 2 1 1 1 2 1))) (quote ((1 5 4) (3 2 3 4) (1 2 8) (1 2 2 2 2) (3 2 1 2 2 1) (4 2 1 1 1 2) (4 2 2 2 1 1) (4 2 3 1 1 2) (1 4 2 2 2) (3 2 1 1 2) (1 5 2 1 2) (5 2 2 1 2) (3 2 3 2 1 1) (3 2 2 1 1 2) (3 2 1 2 2 1) (1 2 1 2 2) (1 3 7) (3 1 4 3) (1 6 3) (3))) (quote (" x    xxxxx     xxxx" "xxx    xx xxx  xxxx " " x    xx xxxxxxxx   " "     x xx xx  xx xx " "    xxx xx x xx xx x" "   xxxx xx x  x x xx" "  xxxx xx xx xx x x " " xxxx xx xxx  x x xx" "x xxxx xx xx xx     " "    xxx xx x  x   xx" "x xxxxx xx x xx     " " xxxxx xx xx  x   xx" "  xxx xx xxx xx x x " "   xxx xx xx  x x xx" "    xxx xx x xx xx x" "     x  xx x  xx xx " "  x   xxx xxxxxxx   " " xxx   x xxxx  xxx  " "  x   xxxxxx    xxx " "                 xxx"))) (make-problem "Hattori 54" (quote ((3 3) (7 1 1 1 1) (2 2 3 3) (2 2 1 1) (2 3 2 2 1) (1 2 2 1 1 1) (1 2 2 2 1 1) (1 1 1 2 1 4) (1 1 3 1 7) (1 1 1 2 2 6) (1 1 2 1 1 8) (1 2 1 3 5) (2 2 2 2 6) (1 3 1 7) (2 1 7) (3 10) (14) (12 1) (12 2) (12 4))) (quote ((9 1) (2 3 1) (2 6 2 2) (2 2 2 1 2) (1 2 3 2 2 2) (1 1 2 1 1 4) (1 2 2 2 4) (1 2 4 4) (1 2 4) (2 3 5) (2 11) (2 2 5) (3 2 5) (3 3 1 6) (1 3 3 6) (3 14) (11 1) (3 10 1) (1 14 2) (3 6 3))) (quote ("    xxxxxxxxx      x" "   xx       xxx    x" "  xx  xxxxxx  xx  xx" " xx  xx    xx  x  xx" " x  xx  xxx xx xx xx" " x  x  xx x  x  xxxx" " x  xx  xx  xx  xxxx" " x   xx  xxxx   xxxx" " x    xx        xxxx" " xx    xxx     xxxxx" "  xx     xxxxxxxxxxx" "   xx      xx  xxxxx" "    xxx   xx  xxxxx " "xxx   xxx x  xxxxxx " "x xxx   xxx xxxxxx  " "xxx xxxxxxxxxxxxxx  " "       xxxxxxxxxxx x" "xxx    xxxxxxxxxx  x" "x xxxxxxxxxxxxxx  xx" "xxx     xxxxxx   xxx"))) (make-problem "Hattori 55" (quote ((2 4 2) (4 7 4) (1 14 1) (1 11 1) (2 11 2) (1 2 4 1 1) (1 3 4 2 2) (2 11 1) (1 9 1) (1 13 1) (1 1 7 3) (5 6 1) (1 2 5 2) (3 2 3 2 1) (1 1 3 1) (2 1 5 1) (2 1 5 1 1) (1 1 1 1) (1 1 1 1 1 1 1 1) (7 7))) (quote ((4 5 2) (2 4 1 4) (2 1 1) (2 9) (1 3 1) (6 1 2) (8 1 1 1) (4 5 2 2 2) (5 6 2 1) (12 5) (17) (16) (14 4) (4 6 1) (3 4 2 2) (6 1 1 1) (2 1 2) (1 3 1) (2 3 1 8) (5 5))) (quote (" xxxx  xxxxx   xx   " "xx  xxxx   x xxxx   " "xx         x x      " " xx        xxxxxxxxx" "  x      xxx       x" "  xxxxxx x        xx" "  xxxxxxxx   x  x  x" " xxxx xxxxx xx xx xx" "xxxxx  xxxxxx  xx  x" "xxxxxxxxxxxx   xxxxx" "xxxxxxxxxxxxxxxxx   " "xxxxxxxxxxxxxxxx    " " xxxxxxxxxxxxxx xxxx" " xxxx  xxxxxx      x" "  xxx xxxx  xx    xx" "  xxxxxx x   x     x" " xx      x        xx" " x        xxx      x" "xx  xxx   x xxxxxxxx" "xxxxx xxxxx         "))) (make-problem "Hattori\n56" (quote ((2 3) (2 4) (2 5) (8) (11) (2 7) (4 1 2 4) (11 1) (2 9 1) (1 8 1) (1 6 2) (1 6 1) (1 8 1) (8 1 2 3) (7 2 1 2) (5 1 3) (1 2) (2 2 1) (4 1) (2))) (quote ((6) (2 2) (2 4 1) (10 2) (10 1) (10 1) (9 2) (10 1) (2 6) (1 3 3) (1 4 6) (8 1) (6) (1 4 4) (9 4) (7 2) (7 2) (6 2) (4 1) (1))) (quote ("        xxxxxx      " "       xx    xx     " "      xx    xxxx x  " "      xxxxxxxxxx xx " "      xxxxxxxxxx  x " "      xxxxxxxxxx  x " "       xxxxxxxxx xx " "     xxxxxxxxxx  x  " "    xx xxxxxx       " "    x  xxx  xxx     " "    x xxxx    xxxxxx" " xxxxxxxx          x" "xxxxxx              " "x  xxxx   xxxx      " "  xxxxxxxxx  xxxx   " "xxxxxxx        xx   " "xxxxxxx       xx    " "xxxxxx       xx     " " xxxx        x      " "             x      "))) (make-problem "Hattori 57" (quote ((2 6) (3 1 1 4) (3 2 3 3) (6 7) (6 2) (5 2 2 3) (3 1 2 1 3) (3 1 1 2 2) (11 2 1) (4 3 5) (1 2 9 3) (2 6 5 1) (5 3 3 1) (1 5 3 1) (1 2 2 5) (9 3 1) (2 2 3 1) (2 14 1) (2 2 2) (2 2 3))) (quote ((2 3 2) (4 1 2 4) (6 1 2 2 2) (7 2 1 2 1) (5 2 1 2 1 2) (2 3 1 1 1 1 3) (1 3 1 1 1 1 1 1) (2 1 6 1) (2 10) (1 6 3) (1 4 1) (1 1 1 1) (2 1 4 1) (1 2 2 4 1) (1 2 7 2) (1 1 2 9 1) (2 1 1 2 7 1) (4 2 1 2 2 3) (6 1 1 2 1) (5 2 3 4))) (quote ("         xx xxx xx  " "   xxxx  x xx  xxxx " "  xxxxxx x xx xx  xx" " xxxxxxx xx x xx   x" " xxxxx xx x xx x xx " "xx xxx  x  x x x xxx" "x xxx   x  x x x x x" " xx     x xxxxxx x  " "     xx xxxxxxxxxx  " "     x xxxxxx  xxx  " "      x xxxx     x  " "      x x x      x  " " xx  x xxxx      x  " "x xx xx xxxx     x  " "x xx   xxxxxxx  xx  " "x  x  xx xxxxxxxxx x" "xx x  x xx xxxxxxx x" "xxxx xx x xx  xx xxx" "xxxxxx x  x  xx   x " " xxxxx xx xxx xxxx  "))) (make-problem "Hattori\n58" (quote ((1 2 2) (1 2 1) (5 3) (4 2) (3 1) (3 1) (7 2 1) (1 8 6) (3 9) (3 6 2 3) (9 8) (5 6 1) (2 8 1) (10) (12) (1 8) (1 9) (1 2 4) (1 2) (2 4))) (quote ((3 2) (2 1) (1 2 3) (5 2) (5 2) (4 2 1) (7 6) (1 7 1) (3 9) (2 6 2 3) (9 8) (4 6 1) (2 7 1) (10 1) (11) (2 8) (2 9) (1 2 5) (1 2) (2 3))) (quote ("xxx    xx           " "  xx    x           " "x xx    xxx         " "xxxxx    xx         " " xxxxx   xx         " "    xxxx  xx       x" "     xxxxxxx  xxxxxx" "x     xxxxxxx x     " "xxx   xxxxxxxxx     " "  xx  xxxxxx xx xxx " "  xxxxxxxxx xxxxxxxx" "      xxxx xxxxxx  x" "       xx xxxxxxx  x" "        xxxxxxxxxx x" "       xxxxxxxxxxx  " "      xx  xxxxxxxx  " "      xx xxxxxxxxx  " "       x xx xxxxx   " "       x xx         " "      xx  xxx       "))) (make-problem "Hattori 59" (quote ((6) (2 2) (2 2 6) (1 2 2 1 2 2) (1 1 1 1 1 1) (1 2 8) (2 2 2 1 1) (8 1 2) (3 3 2 1) (3 2 1 2) (2 2 1 1) (1 14) (2 3 4) (1 2 4) (1 2 2 4) (4 3 4) (3 4 4) (3 4 4) (9 3) (3 4 2))) (quote ((5 2) (2 2 2) (2 1 3) (1 2 4) (1 3 9) (1 2 1 2 5) (1 1 1 1 5) (2 3 1 2 1) (2 7 1 1) (4 4 4) (2 5) (12) (6 9) (2 1 1) (1 1 9) (1 1 9) (1 1 8) (1 1 9) (2 1 3) (5))) (quote ("  xxxxx   xx        " " xx   xx xx         " "xx x   xxx          " "x  xx xxxx          " "x     xxx  xxxxxxxxx" "x  xx  x   xx  xxxxx" "x  x   x   x   xxxxx" "xx    xxx  x  xx  x " " xx  xxxxxxx  x   x " "  xxxx  xxxx    xxxx" "           xx  xxxxx" "        xxxxxxxxxxxx" "   xxxxxx  xxxxxxxxx" "  xx x     x        " "  x  x     xxxxxxxxx" "  x  x     xxxxxxxxx" "  x  x     xxxxxxxx " "  x  x   xxxxxxxxx  " "  xx x xxx          " "   xxxxx            "))) (make-problem "Hattori\n60" (quote ((3) (2 2 6) (1 1 3 8) (2 2 2 9) (2 2 1 1 10) (1 1 2 2 1 4) (2 2 2 5 3) (3 1 3 1 1 1 1 1) (2 2 4 1 3 1) (1 1 5 1 1) (5 1 1 1) (1 1 3 2) (2 1 4 1) (2 1 3) (2 1 1) (2 3 5) (2 1 1 3) (5 1 8) (1 10) (2 9))) (quote ((3 3) (4 3 3) (2 1 1 1 2 2) (1 1 1 3 1 2) (2 4 3 2 3) (3 1 1 1 3 1) (1 1 1 2 2) (2 5 1) (3 11) (2 1) (1 4) (9 2) (3 1 1 3) (3 3 5 3) (4 1 1 2 1 3) (4 3 2 1 3) (5 1 1 3) (7 5) (6 1 4) (12 4))) (quote ("    xxx xxx         " " xxxx xxx xxx       " "xx x x x xx xx      " "x x x xxx x  xx     " "xx xxxx xxx   xx xxx" " xxx x x x     xxx x" "  x x x xx      xx  " "  xx xxxxx       x  " "   xxx xxxxxxxxxxx  " "       xx      x    " "    x          xxxx " "   xxxxxxxxx      xx" "  xxx x    x     xxx" "  xxx xxx  xxxxx xxx" " xxxx x x   xx x xxx" " xxxx xxx   xx x xxx" " xxxxx      x  x xxx" " xxxxxxx       xxxxx" " xxxxxx    x    xxxx" " xxxxxxxxxxxx   xxxx"))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/problems/h61-90 b/collects/games/paint-by-numbers/problems/h61-90
new file mode 100644
index 0000000000..399eaa09d4
--- /dev/null
+++ b/collects/games/paint-by-numbers/problems/h61-90
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Hattori 61 - 90") (define problems (list (make-problem "Hattori 61" (quote ((6) (2 3) (5 1 3) (6 4) (10) (11) (1 8) (1 7) (1 5 1) (1 5 3) (2 5 4) (3 4 5) (4 4 6) (5 4 5) (5 3 5) (3 2 2 5) (1 2 5) (2 5) (2 7) (11 2))) (quote ((1) (2) (2) (2 5) (4 5) (6 6 1) (1 11 1) (1 1 2 3 1) (1 2 2 1) (7 3 2 1) (7 5 3) (14 2) (13 1) (7 3 2) (5 2 2) (4 10) (2 10) (12) (11) (8))) (quote ("   x                " "  xx                " "  xx                " "  xx        xxxxx   " " xxxx      xxxxx    " "xxxxxx    xxxxxx   x" "x   xxxxxxxxxxx    x" "x x xx       xxx   x" "x   xx         xx  x" "xxxxxxx   xxx   xx x" "xxxxxxx  xxxxx   xxx" " xxxxxxxxxxxxxx   xx" "   xxxxxxxxxxxxx   x" "    xxxxxxx  xxx  xx" "     xxxxx xx     xx" "     xxxx xxxxxxxxxx" "      xx xxxxxxxxxx " "       xxxxxxxxxxxx " "         xxxxxxxxxxx" "            xxxxxxxx"))) (make-problem "Hattori 62" (quote ((3 5 2) (1 3 1 1 3) (2 3 1 1 3) (1 2 1 3) (1 1 2 4) (2 3 1 4) (2 1 5) (5 1 5) (3 1 2 2 5) (9 2 5) (8 1 5) (5 2 2 5) (4 1 2 5) (2 1 1 1 1 5) (1 8 1 7) (5 1 2 6) (1 1 1 6) (1 1 6) (1 4 2 4) (4 1))) (quote ((6) (6 1) (2 5 2) (12 1) (4 1 3 2 2) (1 1 4 4 1) (2 1 1 3 1 2) (1 2 5 3 1) (2 1 2 1 2) (1 2 1) (3 1) (1 1 3 3) (1 2 2 2 2 1) (1 5 3 3) (5 4) (13) (15) (18) (19) (17))) (quote ("         xxxxxx     " "        xxxxxx x    " "     xx xxxxx xx    " "    xxxxxxxxxxxx   x" "xxxx   x xxx  xx  xx" "x x    xxxx   xxxx x" "xx   x x xxx  x   xx" " x  xx xxxxx  xxx x " " xx  x  xx    x  xx " "  x          xx   x " "xxx         x       " "x  x     xxx xxx    " "x xx    xx xx  xx x " "x   xxxxx   xxx  xxx" "xxxxx         xxxx  " "      xxxxxxxxxxxxx " "    xxxxxxxxxxxxxxx " " xxxxxxxxxxxxxxxxxx " "xxxxxxxxxxxxxxxxxxx " "xxxxxxxxxxxxxxxxx   "))) (make-problem "Hattori 63" (quote ((5) (7) (1 1) (2 2) (1 1) (1 1 1) (7) (9) (2 4 2) (16) (3 4 3) (5) (3 2) (2 2) (2 2) (3 2) (1 3 1) (20) (1 1) (1 1))) (quote ((1 4) (1 1) (2 1) (1 1) (1 1) (2 1) (3 1 1) (1 2 1 4 1) (8 1 5 1) (2 1 7 1) (2 7 2) (2 1 12) (18) (1 2 1 1) (3 1) (2 1) (1 1) (2 1) (1 1) (1 4))) (quote ("          x     xxxx" "          x      x  " "         xx      x  " "         x       x  " "         x       x  " "        xx       x  " "       xxx     x x  " " x    xx x  xxxx x  " "xxxxxxxx x xxxxx x  " "xx x  xxxxxxx    x  " "xx   xxxxxxx    xx  " "xx x  xxxxxxxxxxxx  " "xxxxxxxxxxxxxxxxxx  " " x    xx x       x  " "       xxx       x  " "        xx       x  " "         x       x  " "         xx      x  " "          x      x  " "          x     xxxx"))) (make-problem "Hattori\n64" (quote ((4) (19) (1 5) (3) (9) (2 1 4 2) (2 1 3 1 2) (1 1 3 9 1) (1 5 7 2 1) (1 1 2 3 2) (3 3 3) (2 1 4) (7) (1 1 1) (11 1) (1 1 1) (1 1 1) (12 5 1) (2 3 3 3 1) (3 4 2 2))) (quote ((1 5 2 3) (2 2 2 1 3) (2 2 8 1 1) (2 1 1 1 1 1) (2 1 2 3 1 2) (1 7 1 1 3) (1 1 6 1 3) (1 2 2 1 1 1) (1 12 1 1) (11 1 2) (1 8 1 2) (1 2 3) (1 2 1) (2 2 3) (2 2 2) (2 1 4) (2 3 2) (2 1 2 4) (1 2 1 1) (3 3))) (quote (" x    xxxxx  xx  xxx" "xx   xx   xx  x  xxx" "xx  xx xxxxxxxx  x x" "xx  x   x   x x  x  " "xx  x  xx xxx x  xx " " x  xxxxxxx x x  xxx" " x  x  xxxxxx x  xxx" " x  xx     xx x  x x" " x xxxxxxxxxxxx  x x" " xxxxxxxxxxx  x  xx " " x xxxxxxxx   x  xx " " x     xx        xxx" " x     xx          x" " xx    xx      xxx  " " xx    xx        xx " " xx    x       xxxx " " xx   xxx        xx " " xx  x  xx    xxxx  " " x   xx  x         x" "      xxx        xxx"))) (make-problem "Hattori 65" (quote ((4 3) (3 1 4) (3 6) (12) (8) (8) (1 1 7 3) (2 1 5 1) (6 1 5) (1 2 2 1 2 1) (1 1 2 1 2 3) (2 1 2) (5) (3) (6) (1 1 2 1 2 3) (1 1 1 2 1 2 1) (1 1 3 1 5) (5 3 1) (1 1 5 3))) (quote ((5 4) (2 2) (2 3) (5 2) (1 1 4) (1 2 1) (4 2 2) (1 5 2 2) (8 2 2 1) (1 5 3 2) (17) (5 3 2) (6 2 1 1) (7 2 2) (6 2 2) (4 2 2) (3 1 1) (2 5 3 1) (1 1 1 1 1 1) (1 1 1 1 3))) (quote ("      xxxxx    xxxx " "       xx         xx" "        xx      xxx " "      xxxxx       xx" " x      x      xxxx " " x      xx       x  " "xxxx     xx     xx  " "x xxxxx   xx   xx   " "xxxxxxxx   xx xx   x" "x  xxxxx    xxx   xx" "   xxxxxxxxxxxxxxxxx" "   xxxxx    xxx   xx" "  xxxxxx   xx x    x" "xxxxxxx   xx  xx    " "xxxxxx   xx    xx   " "xxxx    xx      xx  " " xxx    x        x  " "  xx  xxxxx    xxx x" "      x x x    x x x" "      x x x    x xxx"))) (make-problem "Hattori 66" (quote ((4 6) (2 3) (3 1 4 2) (2 4 1) (2 1 3 3) (2 1 3) (2 1 3 3 7) (1 5 9) (2 1 3 3 7) (1 2 1 3) (2 1 2 2) (1 3 2) (3 1 3 1 1) (3 2 3) (4 6 3) (3) (9) (2 6) (3 1 2) (11))) (quote ((1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1) (1 5 1) (3 2) (2 4 2) (1 4 1) (2 3 2) (1 2 1 1) (1 3 3 3 1 2) (1 5 5 1 3) (1 3 3 2 1 4) (2 1 2 1 1) (1 3 1 1 1) (2 3 1 4) (3 3 2 5 1) (14 1) (6 5 1) (5 4) (3 4))) (quote ("x x x x x x x x     " "x x x x x x x x     " "x x         x x     " "x    xxxxx    x     " "   xxx    xx        " "  xx  xxxx  xx      " " x    xxxx   x      " "xx    xxx    xx     " "x xx   x      x     " "x xxx xxx xxx x   xx" "x xxxxx xxxxx x  xxx" "x xxx xxx  xx x xxxx" "xx     x     xx x  x" " x    xxx    x  x  x" " xx   xxx   x   xxxx" "  xxx xxx xx xxxxx x" "    xxxxxxxxxxxxxx x" "    xxxxxx   xxxxx x" "     xxxxx      xxxx" "      xxx       xxxx"))) (make-problem "Hattori 67" (quote ((3 4 2) (3 6 2) (2 8 1) (1 2) (8) (2 5 1 3) (2 5 1 2 2) (4 1 1 2) (3 4 1 2 1) (1 1 7 1 3) (3 5 1 1 1) (11 2 2) (1 1 4 1 1) (3 7 3) (4 3 1) (4 1 1) (1 4 3 2) (1 1 6 1 1 2) (1 2 12) (2 2 1 2 2))) (quote ((6 3) (1 2 1 1) (2 6 3) (4 2 1 2) (3 8 1) (2 12) (14) (15) (1 4 3 1 3) (2 3 1 1 1 2) (3 2 5 3) (5 2) (9 1 1) (3 1 3 5) (2 1 3 1 1 1) (1 3 1 1 4) (1 1 2) (2 2 1 1 2) (2 2 1 1 1 2) (10))) (quote ("        xxxxxx   xxx" "        x xx x     x" "     xx xxxxxx  xxx " "xxxx xx    x      xx" "xxx     xxxxxxxx   x" "xx    xxxxxxxxxxxx  " "     xxxxxxxxxxxxxx " "     xxxxxxxxxxxxxxx" "  x xxxx xxx x  xxx " " xx xxx  x x x   xx " "xxx xx   xxxxx   xxx" "xxxxx             xx" "xxxxxxxxx  x      x " "xxx x    xxx  xxxxx " " xx x xxx     x x x " "  x xxx x     x xxxx" "x    x            xx" "xx   xx  x   x   xx " " xx   xx x x x  xx  " "       xxxxxxxxxx   "))) (make-problem "Hattori 68" (quote ((8) (3 2 2) (2 1 1 2) (2 2 1 1) (1 1 2 2) (1 6 3) (2 2 1 3 2) (5 3 4) (1 4 7) (1 9) (1 9) (1 6 3) (1 6 2) (1 2 2) (2 2 1) (2 2 1) (3 2 1) (6 1) (4 6) (6 5))) (quote ((4) (2 2) (2 2) (1 3) (2 3) (1 1 1 2) (2 1 1) (4 1 7 1) (1 6 2 2) (1 1 2 2) (1 2 1 4 1 2) (2 1 1 7 4) (2 1 8 1 1) (5 5 3) (2 6 3) (8 3) (5 3) (5 2) (5 2) (9))) (quote ("   xxxx             " "  xx  xx            " " xx    xx           " " x   xxx            " "xx   xxx            " "x x  x xx           " "xx   x  x           " "xxxx x  xxxxxxx    x" "x  xxxxxx     xx  xx" "x      x       xx xx" "x  xx  x xxxx   x xx" "xx  x x xxxxxxx xxxx" " xx   x xxxxxxxx x x" "  xxxxx xxxxx  xxx  " "    xx xxxxxx   xxx " "     xxxxxxxx    xxx" "      xxxxx      xxx" "       xxxxx      xx" "         xxxxx    xx" "           xxxxxxxxx"))) (make-problem "Hattori 69" (quote ((7) (2 2) (1 1) (10) (6 1 1 6) (4 1 2 2 1 3) (2 2 3 2) (1 6 2 2 2 1) (3 1 1 2) (1 1) (1 3 2) (4 1 1 1 1 4) (1 1 2 2 1) (2 3 7 1) (2 1 1 1) (3 1 3 2) (3 3 1 3) (1 3 1 3) (2 4 4 1) (17 2))) (quote ((12 3) (3 1 1 4 2) (2 2 1 3 1) (2 1 2 1 4) (1 1 1 3 3) (5 1 1 2) (3 2 2 2) (2 1 2 2 1 1) (1 1 1 1 1 3 1) (1 3 1 1 1 1) (1 1 1 1 1) (1 3 1 1) (1 1 1 2 1 1 1) (2 1 2 2 1 1) (6 3 3 2) (1 1 1 1 2) (1 1 1 3) (2 1 1 3) (3 1 1 3 1) (6 6 2))) (quote ("    xxxxxxxxxxxx xxx" "    xxx x  x xxxx xx" "    xx xx  x   xxx x" "    xx x  xx x  xxxx" "    x  x  x xxx  xxx" "   xxxxx  x  x    xx" " xxx  xx   xx     xx" "xx x   xx   xx  x  x" "x  x x     x x xxx x" "x  xxx x     x  x  x" "x  x   x     x     x" "x  xxx       x     x" "x  x x xx  x x     x" "xx x  xx    xx x   x" " xxxxxx   xxx xxx xx" "    x x   x    x  xx" "    x  x   x     xxx" "    xx x   x    xxx " "    xxx x  x   xxx x" "    xxxxxx xxxxxx xx"))) (make-problem "Hattori 70" (quote ((10) (3 3) (3 2) (2 5 1) (1 8 1) (2 2 5 1) (1 1 1 1 3 2) (1 1 2 1) (3 2 1 1 3 2) (1 2 5 1 3) (8 3 3) (13) (4 6) (8) (11) (1 1 1 1) (1 1 1 1) (1 3 2) (8) (1 1))) (quote ((3) (4 1) (3 4) (2 3 1) (1 5) (2 4 9) (1 2 7 1) (2 2 1 10) (1 2 2 1 2 3) (1 2 1 10) (1 2 6 1) (1 3 2 9) (1 4 2 1 3) (1 3 5 1) (1 2 1 3) (1 1 3) (2 1) (1 2) (2 3) (5))) (quote ("        xxx         " "     xxxx x         " "   xxx  xxxx        " "  xx     xxx  x     " "  x       xxxxx     " " xx  xxxx xxxxxxxxx " " x  xx  xxxxxxx   x " "xx xx x  xxxxxxxxxx " "x  xx   xx x xx  xxx" "x  xx x  xxxxxxxxxx " "x  xx    xxxxxx   x " "x  xxx xx xxxxxxxxx " "x   xxxx   xx x  xxx" "x   xxx xxxxx x     " "x    xx x xxx       " "x    x  xxx         " "xx       x          " " x      xx          " " xx   xxx           " "  xxxxx             "))) (make-problem "Hattori 71" (quote ((1 1 4) (2 3 7) (3 1 9) (2 3 5) (1 5 2) (7 1) (1 1 1 2) (1 3 1 2) (1 3 1 3) (1 1 2 1) (8 4) (2 2 1 2) (2 2 3) (2 3 2 3) (2 1 1 1 2 2) (1 2 2 2 2 3 1) (1 2 1 1 2 1 1 1) (1 2 1 1 2 1 1 1) (1 1 1 1 1 1) (1 5 1 1 1))) (quote ((5 6) (3 2) (1 2 3) (2 3) (7) (2 1 6) (1 3 2 1 1 1 1) (9 1 2 1) (1 3 2 1 1 1 1) (2 1 6) (1 6) (2 2 3) (3 2 3) (4 2) (5 7) (5 2) (4 4 5) (2 4 2) (1 3 5) (2 4 7))) (quote ("xxxxx         xxxxxx" " xxx         xx     " "  x         xx xxx  " "           xx  xxx  " "     xxxxxxx        " "    xx    x   xxxxxx" " x xxx xx x  x x   x" "xxxxxxxxx x  xx    x" " x xxx xx x  x x   x" "    xx    x   xxxxxx" "  x  xxxxxx         " " xx       xx   xxx  " " xxx       xx  xxx  " "xxxx        xx      " "xxxxx        xxxxxxx" "xxxxx         xx    " "xxxx     xxxx  xxxxx" " xx    xxxx xx      " "  x   xxx xxxxx     " "     xx xxxx xxxxxxx"))) (make-problem "Hattori\n72" (quote ((2 5 5) (3 1 1 1) (4 3 3 2) (5 1 3 1 3) (5 7 4) (5 3 4) (4 1 1 3) (1 1 1 1) (1 10) (5 2) (7) (8) (7 2) (8 2 2 1) (6 3 2 1) (4 1 2 3) (3 1 1) (1 1) (1 1 1 1) (4 4))) (quote ((4 3 3) (5 1 4) (5 1 4 2) (5 1 3 1) (4 2 3 1) (3 1 8) (1 4 1 2) (1 1 4) (1 3 1 4) (1 1 1 5) (7 6) (3 2 1 2) (7 1 1 1) (1 1 1 1 1 2) (1 3 1 2 5) (1 4 2 1) (1 3 2 1) (4 2 2) (4 1) (4 3))) (quote ("xxxx   xxx    xxx   " "xxxxx    x   xxxx   " " xxxxx   x   xxxx xx" "  xxxxx  x   xxx   x" "   xxxx  xx xxx    x" "    xxx   x xxxxxxxx" "x    xxxx x xx      " "x       x xxxx      " "x xxx   x xxxx      " "x x x   xxxxx       " "xxxxxxx xxxxxx      " "   xxx xx  x xx     " "xxxxxxx x  x  x     " "x x x   x  x  xx    " "x xxx   x  xx  xxxxx" "x    xxxx   xx     x" "x   xxx      xx    x" "   xxxx       xx  xx" "  xxxx         x    " " xxxx        xxx    "))) (make-problem "Hattori 73" (quote ((2) (3 4) (5 4) (9) (6) (4 3) (3 2 3) (5 3) (10 5) (12) (1 1 1 1 1) (1 1 1 1 2 1) (1 1 1 2 3 2) (5 2 3 2) (12 3) (1 2 1 1 3) (1 4 1 4) (12 5) (10 6) (7))) (quote ((1) (1 9) (2 2 2 2) (1 2 4 2) (8 2 2) (18) (4 3 5) (4 3 3 3) (3 12) (2 2 1 2) (1 2 3 2) (1 2 4 2) (2 9) (1 1 1) (1 1 2) (2 3 3) (1 1 1 4) (1 2 1 6) (2 1 1 8) (1 1 1 10))) (quote ("      x             " "      x  xxxxxxxxx  " "     xx xx   xx  xx " "     x  xx xxxx  xx " "  xxxxxxxx   xx  xx " " xxxxxxxxxxxxxxxxxx " " xxxx  xxx    xxxxx " " xxxx  xxx  xxx xxx " "  xxx  xxxxxxxxxxxx " "   xx   xx    x  xx " "   x    xx  xxx  xx " "   x    xx xxxx  xx " "  xx     xxxxxxxxx  " "  x    x           x" "  x    x          xx" " xx   xxx        xxx" " x    x x       xxxx" " x   xx x     xxxxxx" "xx   x  x   xxxxxxxx" "x    x  x xxxxxxxxxx"))) (make-problem "Hattori 74" (quote ((6 5) (5 5) (1 1 1 1) (5 4) (5 5) (12) (10) (11) (13) (4 3) (3 2 2 2) (2 1 1 1 1 1) (2 1 1) (2 4 4) (2 2 3 1) (2 4 1) (15) (1 3) (1 1) (20))) (quote ((1 2 1) (2 4 1) (6 3 2 2) (2 7 2 1 1) (2 7 3 1) (9 1 3 1) (6 1 2 1) (4 2 1 4) (4 2 1 1) (5 2 1 1) (8 1 1 1 1) (2 6 1 2 1) (2 6 2 2 1) (6 3 3 1) (2 9 1) (1 2 2 1 1) (2 1 1) (1 1 1) (3 1) (1))) (quote ("x         xx       x" "xx       xxxx      x" "xxxxxx  xxx xx    xx" "xx xxxxxxx   xx  x x" "xx xxxxxxx    xxx  x" "xxxxxxxxx  x   xxx x" "   xxxxxx x     xx x" "     xxxx xx x  xxxx" "     xxxx    xx x  x" "    xxxxx    xx x  x" " xxxxxxxx  x x  x  x" "xx xxxxxx x    xx  x" "xx xxxxxx xx   xx  x" "xxxxxx xxx    xxx  x" "xx      xxxxxxxxx  x" "x        xx  xx x  x" "            xx  x  x" "             x  x  x" "              xxx  x" "                   x"))) (make-problem "Hattori 75" (quote ((7 1 1) (9 3 2) (1 4 5 3) (2 1 3 10) (2 1 2) (1 9) (1 2 3 4) (1 3 1 2) (6 1 2) (5 4 1) (2 7 2 1) (7 1 3) (3 2 2 2) (1 2 1 1 1) (11 2) (1 4 1 1 2) (6 1 2) (1 1 1 3) (1 2 7) (1 12))) (quote ((7 3) (2 2 1 2 4) (2 1 1 3) (2 2 1 1 7 1) (2 9 2) (3 3 2 6) (4 3 1 1 1) (5 2 1 1 2 1) (6 3 1 1) (2 3 1 2) (1 1 1 8) (2 1 1 2) (3 1 1 2) (4 1 2 2) (3 2 4 3) (2 5 2 2) (1 2 2 2) (2 2 2 2) (3 2 2 2) (4 7))) (quote (" xxxxxxx      xxx   " "xx xx   x    xx xxxx" "xx    x x     xxx   " "xx xx x x xxxxxxx  x" "xx      xxxxxxxxx xx" "xxx    xxx xx xxxxxx" "xxxx   xxx x  x    x" "xxxxx xx x x  xx   x" " xxxxxx  xxx  x    x" "     xx   xxx x   xx" "   x x    x xxxxxxxx" "  xx x    x       xx" " xxx x    x       xx" "xxxx x   xx       xx" " xxx xx  xxxx    xxx" "  xx xxxxx  xx   xx " "   x xx  xx     xx  " "  xx  xx  xx   xx   " " xxx   xx  xx xx    " "xxxx    xxxxxxx     "))) (make-problem "Hattori 76" (quote ((1 1 3) (3 3 1 1) (1 7 1 4) (3 3 1) (1 8) (2 1 1 2 2) (1 2 2 1 2) (1 1 1) (1 7 1 1) (1 2 2 1 1) (1 1 1 1 1 1 1) (1 1 1 1 1 1 1) (1 2 2 1 1) (1 7 1 1) (2 1 1) (11 1) (1 1 1 2) (2 4 6 1) (1 1 1 1 1 1 1) (3 3 5))) (quote ((10) (6 2) (1 1 4 1) (3 1 2 2 3) (1 2 1 1 1 3) (1 1 2 1 1 1) (1 1 1 1 3) (1 1 2 1 1 1) (1 2 1 1 1 1) (3 1 2 2 1 3) (2 1 4 1 1) (5 1 3) (11 2) (1 1) (1 3) (1 1 1) (3 1 4) (1 1 2 1) (7 4) (1 11))) (quote ("     xxxxxxxxxx     " "xxxxxx        xx    " " x x     xxxx  x    " " xxx  x xx  xx xxx  " "  x  xx x    x x xxx" "  x     x xx x x   x" "  x     x    x x xxx" "  x     x xx x x x  " "  x  xx x    x x x  " " xxx  x xx  xx x xxx" "xx x     xxxx  x   x" " xxxxx         x xxx" "    xxxxxxxxxxx xx  " "    x            x  " "    x            xxx" "    x            x x" "xxx x           xxxx" "x x xx             x" "xxxxxxx         xxxx" "  x   xxxxxxxxxxx   "))) (make-problem "Hattori\n77" (quote ((14) (4 5) (1 1 3) (3 2) (4 1) (5 3) (4 1 4) (1 2 4) (2 1 2) (5 1 4) (1 5 1) (1 6 3) (4 2 1) (10 2 1 1) (1 10 2) (2 2 2 1 1) (3 1 2 2 1) (4 2 2 2) (11 4) (12 2))) (quote ((1) (1 1 2) (2 1 2) (2 1 1 2) (4 1 2 2) (1 2 7) (1 1 4 3) (2 3 11) (2 5 6 3) (3 3 4 2) (2 3 1 3 3) (1 6 2 6) (1 1 1 3 1) (1 2 2 1 1) (1 4 1 4) (2 2 2 3 1) (2 2 1 2 1) (3 1 2 2) (4 3 4) (5 1 2))) (quote ("                   x" "         x   x    xx" "         xx  x    xx" "        xx   x  x xx" "        xxxx x xx xx" "       x xx  xxxxxxx" "x     x   xxxx   xxx" "xx   xxx xxxxxxxxxxx" "xx  xxxxx xxxxxx xxx" "xxx xxx    xxxx   xx" "xx xxx     x xxx xxx" "x xxxxxx   xx xxxxxx" "x  x   x    xxx x   " "x     xx     xx  x x" "x    xxxx     x xxxx" "xx   xx xx    xxx x " "xx   xx  x   xx   x " "xxx      x xx    xx " "xxxx     xxx  xxxx  " "xxxxx      x xx     "))) (make-problem "Hattori 78" (quote ((8) (2 2) (1 1) (1 1 2) (1 1 1 4) (1 1 3 3) (3 11 2) (3 1 2 2) (3 1 2 2) (1 12 3) (1 1 2 2 1 4) (1 1 1 1 1 1) (1 1 1 1) (3 2 2 2 3) (1 1 2 2 1 1 1) (4 8 3) (1 4 4 1) (2 1 1 1) (1 4) (4 1 1 1))) (quote ((3 5) (8 1 3) (3 3 1) (2 1) (13 1 1) (2 1 1 2 1) (1 1 2 3) (1 1 3 1 1 1) (1 1 1 3) (1 1 1 3) (1 1 3 1) (1 3 2 1 1 1) (2 1 1 3) (13 2) (5 1) (2 2 1 2) (2 1 4 1) (3 5 1 1) (7 6) (5))) (quote ("      xxx    xxxxx  " "      xxxxxxxx x xxx" "      xxx    xxx   x" "               xx  x" " xxxxxxxxxxxxx  x  x" "xx    x  x   xx x   " "x     x  xx   xxx   " "x     x  xxx   x x x" "x     x  x   xxx    " "x     x  x   xxx    " "x     x  xxx   x    " "x   xxx  xx    x x x" "xx    x  x   xxx    " " xxxxxxxxxxxxx xx   " "     xxxxx      x   " "    xx   xx     x xx" "   xx     x  xxxx x " "   xxx   xxxxx x  x " "    xxxxxxx  xxxxxx " "     xxxxx          "))) (make-problem "Hattori 79" (quote ((1 1 1 1 1 1) (1 1 1 1 2 2 2) (1 2 2 1 3 1 1) (3 1 2 2 4) (2 1 2 4) (2 3 2) (4 1 2) (3 2 2) (4 9) (1 4 6) (2 2 1) (2 3 2) (3 2 1 3) (2 3 4) (1 3) (2 1 1) (4 5) (6 5) (6 7 3) (4 3))) (quote ((4 3 2) (2 1 2 2) (4 1 2 3) (3 2 2 1 4) (2 2 2 4) (9 6) (3 5 2) (2 1 2) (2 1 1) (3 3 1 1) (4 3 2) (2 2 1 1 2) (3 4 3 2) (8 2) (2 2 4 1) (2 1 3 2) (2 2 3) (3 6) (2 1 2 1 1) (2 3))) (quote ("xxxx    xxx       xx" "   xx   x xx      xx" "  xxxx  x  xx    xxx" "xxx  xx xx  x   xxxx" "      xx xx xx xxxx " "  xxxxxxxxx  xxxxxx " "xxx  xxxxx      xx  " "    xx  x        xx " "   xx   x         x " " xxx   xxx  x     x " "      xxxx xxx    xx" "xx      xx x x    xx" " xxx  xxxx xxx    xx" "  xxxxxxxx       xx " " xx xx   xxxx    x  " "xx  x      xxx  xx  " "   xx       xx  xxx " " xxx         xxxxxx " "xx x         xx x x " "  xx          xxx   "))) (make-problem "Hattori 80" (quote ((7) (1 1 1) (15) (2 2 2 2) (2 3 2) (3 1 4) (3 1 4) (3 3 4) (2 1 2 2) (1 1) (1 1) (1 1) (1 1) (4 1 3) (1 2 1 1 3) (2 2 1 1 1 1) (2 3 1 1 3) (2 1 1 1 1) (2 5 1) (2 3))) (quote ((5) (6 3) (2 3 1 2) (1 1 2) (1 2 2) (1 2 2) (1 1 2 1) (4 1) (1 3 10) (3 4) (1 3 2) (4 11) (1 1 1 1) (1 6) (1 1 1) (1 6) (2 3 1 1) (6 4) (5) (3))) (quote ("    xxxxx           " "   xxxxxx    xxx    " "  xx xxx     x xx   " "  x          x  xx  " "  x          xx  xx " "  x           xx  xx" "x x            xx  x" "xxxx            x   " "x xxx  xxxxxxxxxx   " "xxx xxxx            " "x xxx  xx           " "xxxx    xxxxxxxxxxx " "x x          x    x " "  x          xxxxxx " "  x           x   x " "  x           xxxxxx" "  xx xxx        x  x" "   xxxxxx       xxxx" "    xxxxx           " "     xxx            "))) (make-problem "Hattori 81" (quote ((1 1 1) (2 1 2) (7) (7) (5) (1 1 1) (2 1 2) (4 1 3) (10) (6))) (quote ((4) (3) (3 3) (5 3) (3 2) (10) (3 2) (5 3) (3 3) (4))) (quote ("     xxxx " "      xxx " " xxx   xxx" "xxxxx  xxx" "  xxx   xx" "xxxxxxxxxx" "  xxx   xx" "xxxxx  xxx" " xxx  xxx " "     xxxx "))) (make-problem "Hattori 82" (quote ((1) (2) (3) (2) (4) (4 1) (5 2) (6 2) (7 3) (8 4) (15) (1) (15) (13) (11))) (quote ((1 1) (2 2) (3 3) (4 3) (5 3) (6 3) (7 3) (8 3) (15) (2 1 1 3) (1 6 3) (5 3) (3 3) (2 2) (1 1))) (quote ("          x x  " "         xx xx " "        xxx xxx" "       xxxx xxx" "      xxxxx xxx" "     xxxxxx xxx" "    xxxxxxx xxx" "   xxxxxxxx xxx" "xxxxxxxxxxxxxxx" " xx x     x xxx" "  x  xxxxxx xxx" "      xxxxx xxx" "        xxx xxx" "         xx xx " "          x x  "))) (make-problem "Hattori 83" (quote ((1 1 1 1 12) (1 1 13) (1 1 14) (1 15) (1 16) (1 1) (1 5 7) (2 2 8) (1 1 1 1 1 8) (1 1 1 1 1 2 5) (1 1 1 3) (1 1 1 1 1 2) (1 3 1 1 2 2) (1 2 2 3 1 2) (1 1 1 1 1 2 2) (2 1 1 1 1 1) (1 1 2 2 5 1) (1 1 1 2 1 1) (1 7 3 4) (10))) (quote ((3 2 3) (3 3) (1 4 4) (2 2 1 3 1) (2 1 1 2 2 1) (4 1 1) (1 3 1 2 2 1) (4 2 1 4 1) (5 4 3) (5 3) (5 1 4) (5 9) (5 3 2) (5 11 1) (5 3 1 1 1) (5 4 2 1 1) (5 4 1 1 2) (5 5 4) (5 9 2) (5 14))) (quote ("xxx     xx      xxx " "    xxx     xxx     " "x      xxxx    xxxx " "  xx  xx   x xxx  x " "xx  x x xx  xx    x " "   xxxx     x     x " "x xxx x xx  xx    x " " xxxx xx   x xxxx x " "xxxxx  xxxx     xxx " "xxxxx        xxx    " "xxxxx        x  xxxx" "xxxxx      xxxxxxxxx" "xxxxx  xxx        xx" "xxxxx xxxxxxxxxxx  x" "xxxxx xxx     x x  x" "xxxxx xxxx xx   x  x" "xxxxx xxxx  x   x xx" "xxxxx xxxxx     xxxx" "xxxxx xxxxxxxxx   xx" "xxxxx xxxxxxxxxxxxxx"))) (make-problem "Hattori 84" (quote ((2) (3) (2 2) (4 2) (2 3 2) (8 1 2) (10 4) (2 16) (4 3 3 2) (3 3 3 1) (3 3 2) (4 3) (10) (3 4) (1 3 3 1) (2 2 3 2) (3 3 5) (5 4) (16) (12))) (quote ((2 3) (4 3) (5 3) (2 2 2) (8 4) (2 6 6) (2 13 2) (2 10 2) (2 8 2) (4 2 2) (4 1 2) (4 1 2) (4 2 2) (1 4 2) (9 2) (13) (4 4) (3 3) (4 3) (4 3))) (quote ("     xx       xxx   " "    xxxx       xxx  " "   xxxxx        xxx " "  xx xx          xx " "xxxxxxxx        xxxx" "xx xxxxxx     xxxxxx" " xx xxxxxxxxxxxxx xx" "  xx xxxxxxxxxx   xx" "   xx xxxxxxxx    xx" "    xxxx   xx     xx" "       xxxx x     xx" "       xxxx x     xx" "       xxxx xx    xx" "       x   xxxx   xx" "       xxxxxxxxx  xx" "       xxxxxxxxxxxxx" "      xxxx     xxxx " "     xxx        xxx " "     xxxx      xxx  " "      xxxx    xxx   "))) (make-problem "Hattori\n85" (quote ((1 1 1 1 1 1) (1 1 1 5 1 1) (1 1 9 1) (1 4 1 4) (6 6) (8 8) (10 9) (2 4 1 3 2) (1 1 1 1 1) (5 1) (8 1 6) (9 1 8) (5 1 1 8) (4 3 1 1 4) (3 1 1 1 3 3) (3 1 1 2 1 2) (4 3 1 1 2 1) (3 1 1 2 1) (1 2 1 2 2) (6 2 1 2))) (quote ((3 3 6) (3 8) (3 3 9 1) (3 5 4) (2 4 4 1) (5 3 1) (1 6 3 2 1 1) (7 2 1 1 2) (2 3 9) (2 1) (4 13) (2 1 1) (2 2 2 3) (6 6 3) (1 7 3 1 1 1) (5 3 3) (2 4 4) (3 5) (2 4 6 2) (4 9))) (quote (" xxx  xxx  xxxxxx   " "     xxx  xxxxxxxx  " "xxx xxx  xxxxxxxxx x" "    xxx  xxxxx  xxxx" "xx xxxx  xxxx      x" "   xxxxx xxx       x" "x xxxxxx xxx xx x  x" "  xxxxxxx xx x  x xx" " xx  xxx  xxxxxxxxx " " xx   x             " "xxxx   xxxxxxxxxxxxx" " xx   x            x" " xx  xx    xx  xxx  " "  xxxxxx  xxxxxx xxx" "x xxxxxxx xxx x x x " "   xxxxx  xxx xxx   " "xx xxxx   xxxx      " "    xxx   xxxxx     " " xx xxxx  xxxxxx  xx" "     xxxx  xxxxxxxxx"))) (make-problem "Hattori 86" (quote ((3 6 1) (3 6 3) (4 6 1) (4 9 2) (3 6 3) (3 6 3) (3 6) (2) (6) (2 2 2 3) (3 2 2 4) (3 1 1 1 4) (2 1 3 2 1 3) (3 1 1 2) (5 4) (8 2 7) (6 2 5) (6 1 1 5) (6 5) (13))) (quote ((4 4 3) (5 4 5) (7 2 5) (5 7) (3 7) (1 10) (2 1 2) (7 2 1 1 1 1) (7 1 3 1) (7 1 1 2 1) (7 1 2 1) (7 1 2 1) (7 2 1 1 1 1) (1 2 1 2) (1 10) (2 7) (2 1 2 5) (1 2 4 5) (2 1 1 4 3) (1 1 4))) (quote ("xxxx     xxxx  xxx  " "xxxxx    xxxx xxxxx " "xxxxxxx   xx  xxxxx " "  xxxxx      xxxxxxx" "     xxx     xxxxxxx" "       x  xxxxxxxxxx" "         xx    x  xx" "xxxxxxx xx  x  x x x" "xxxxxxx x  xxx     x" "xxxxxxx x   x  xx  x" "xxxxxxx x      xx  x" "xxxxxxx x   xx     x" "xxxxxxx xx  x  x x x" "   x     xx    x  xx" "   x      xxxxxxxxxx" "   xx        xxxxxxx" " xx x     xx  xxxxx " " x  xx   xxxx xxxxx " "xx x x   xxxx  xxx  " "   x x   xxxx       "))) (make-problem "Hattori 87" (quote ((5 5) (1 1 1 1) (3 1 3 1) (3 1 3 1) (1 1 3 1 2) (13) (15) (17) (3 2 12) (20) (5) (20) (11 4) (9 4 3) (8 5 2) (7 8) (3 11) (3 3 8) (3 3 6) (4 4 7))) (quote ((2 1 1) (3 2 1) (4 3 2) (8 1 4 3) (1 2 5 8) (1 8 7 1) (1 3 1 6 1) (10 5 2) (6 5 3) (10 8) (1 2 5 7) (1 8 2 1 1) (1 5 1 5 1) (10 1 7) (6 1 7) (7 7) (7 6) (7 5) (11) (9))) (quote ("        xx x       x" "       xxx xx      x" "      xxxx xxx    xx" "xxxxxxxx x xxxx  xxx" "x xx xxxxx xxxxxxxx " "x xxxxxxxx xxxxxxx x" "x    xxx x xxxxxx  x" "xxxxxxxxxx xxxxx  xx" "    xxxxxx xxxxx xxx" "xxxxxxxxxx xxxxxxxx " "x xx xxxxx xxxxxxx  " "x xxxxxxxx xx   x  x" "x    xxxxx x xxxxx x" "xxxxxxxxxx x xxxxxxx" "    xxxxxx x xxxxxxx" "     xxxxxxx xxxxxxx" "      xxxxxxx xxxxxx" "       xxxxxxx xxxxx" "        xxxxxxxxxxx " "         xxxxxxxxx  "))) (make-problem "Hattori 88" (quote ((4 4 5) (1 2 2 1 6) (1 1 1 8) (1 1 1 5) (3 2 2 2 1) (1 1 1 2 5) (2 3 2 1 3) (1 1 1 1 1 1) (2 4 1 3) (5 2 1 1) (1 3 1 1) (1 3 1 1 4) (6 2 2 1 2) (1 1 1 4 1 3) (1 2 5 2) (4 1 2) (1 3 4) (2 1 1) (1 1 5) (1 11))) (quote ((5 4) (1 3 4 1) (1 1 4 1 4) (2 2 4 3) (4 1 2) (3 6) (2 2 1) (3 2 3 1) (4 2 3 4) (2 3 4 1) (1 2 1 2 1) (1 2 5 1) (5 2) (2 2) (14 2) (4 1 2 2) (4 4 2 5) (3 2 1 3 1 1) (3 4 1 1 1 1) (3 1 1 1))) (quote ("xxxxx       xxxx    " "x   xxx  xxxx  x    " "x   x xxxx  x xxxx  " "xx      xx  xxxx xxx" " xxxx    x xx       " "    xxx  xxxxxx     " "      xx  xx  x     " "    xxx  xx xxx x   " " xxxx   xx  xxx xxxx" "xx    xxx    xxxx  x" "x    xx x   xx     x" "x   xx  xxxxx      x" "xxxxx             xx" "  xx              xx" " xxxxxxxxxxxxxx   xx" "xxxx x        xx  xx" "xxxx xxxx  xx  xxxxx" "xxx  xx x  xxx  x  x" "xxx  xxxx  x x  x  x" "xxx        x x  x   "))) (make-problem "Hattori 89" (quote ((9) (4 4) (4 3) (5 4) (4 4 2) (4 2 2 5 3) (4 1 1 5 2) (4 2 2 5 2) (4 9) (4 5 2) (2 1 2 5 1) (2 1 2 2 2 1) (2 2 1) (6 1) (1 1) (2 1 1 1 1) (2 2 5 1) (3 2 2 1 1) (1 2 2 2 1) (10 6))) (quote ((9) (10) (9 3) (13 1 1) (4 2 2 1) (2 1 1 1 2 1) (1 3 2 3 2) (1 2 1 3) (1 1 1 1 2 1) (2 3 2 2 1) (4 2 1) (12 2) (10 2) (9 3) (8 1 2) (6 4) (1 1 1) (2 1 2 1) (6 1) (15))) (quote ("   xxxxxxxxx        " "  xxxxxxxxxx        " " xxxxxxxxx       xxx" "xxxxxxxxxxxxx    x x" "xxxx        xx  xx x" "xx   x x     x xx  x" "x    xxx  xx xxx  xx" "x         xx x   xxx" "x    x x     x  xx x" "xx   xxx    xx xx  x" "xxxx       xx      x" "xxxxxxxxxxxx      xx" " xxxxxxxxxx      xx " "   xxxxxxxxx   xxx  " "    xxxxxxxx    x xx" "     xxxxxx     xxxx" "        x       x  x" "    xx  x      xx  x" "    xxxxxx         x" "     xxxxxxxxxxxxxxx"))) (make-problem "Hattori 90" (quote ((2 6) (11) (3 9) (3 1 1 1 2) (2 1 1 1 1) (3 1 2) (1 1 1 1 1) (1 2 2 1 2) (1 2 1 1) (2 6 3) (2 6 5) (13 2) (5 4 3) (4 4 5) (1 7) (6 3) (7 2) (14) (4 10 4) (4 4))) (quote ((5 2) (1 2 2) (5 2 2) (3 2 1 3) (3 6 1) (3 5 3) (2 5 4) (7 5 4) (3 6 5) (5 3 1 4) (3 2 3 4) (5 3 4) (3 5 2) (3 6 1 2) (3 3 3 2 3) (4 2 6) (6 3) (5 2) (2 2) (2))) (quote ("     xxxxx        xx" "     x   xx       xx" "   xxxxx  xx      xx" "  xxx  xx  x     xxx" " xxx    xxxxxx   x  " "xxx      xxxxx  xxx " "xx       xxxxx xxxx " " xxxxxxx xxxxx xxxx " "xxx    xxxxxx xxxxx " "xxxxx    xxx x xxxx " "xxx   xx   xxx xxxx " "xxxxx      xxx xxxx " "xxx       xxxxx  xx " "xxx    xxxxxx x  xx " " xxx xxx xxx xx xxx " "  xxxx   xx xxxxxx  " "          xxxxxx xxx" "           xxxxx  xx" "             xx   xx" "                  xx"))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/problems/h91-120 b/collects/games/paint-by-numbers/problems/h91-120
new file mode 100644
index 0000000000..edb0c59fd3
--- /dev/null
+++ b/collects/games/paint-by-numbers/problems/h91-120
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Hattori 91 - 120") (define problems (list (make-problem "Hattori 91" (quote ((5 5) (1 1 1 1) (1 1) (7) (4 1 2 2 3) (6 1 1 1 5) (4 3 1 3 3) (3 7 2) (2 1 1 1) (1 1 3 1 1) (1 1 1) (2 1 3 1 2) (18) (2 3 2) (2 1 4 1 1) (1 6 1) (2 5 2 2) (2 2 4 2 2) (4 3 3) (1 2 1))) (quote ((7) (5 2 3) (4 3 2) (3 2 2) (2 1 2 1 2) (2 2 1 1) (1 1 1 2) (1 5 1 2) (1 1 1 1 2) (5 3 7) (5 10) (4 3 9) (1 2 1 1 2 3) (1 5 1 2) (1 1 1 2) (2 2 1 2) (2 1 2 1 2) (3 1 2) (4 3 2) (7 4))) (quote ("     xxxxxxx        " "    xxxxx  xx xxx   " "    xxxx    xxx xx  " "    xxx     xx   xx " "    xx   x xx x   xx" "xx   xx     x     x " "x     x     x    xx " "x  xxxxx    x   xx  " "x  x   x    x  xx   " "xxxxx  xxx xxxxxxx  " "   xxxxx xxxxxxxxxx " "xxxx   xxx xxxxxxxxx" "x  xx  x    x xx xxx" "x  xxxxx    x  xx   " "x     x     x   xx  " "xx   xx     x    xx " "    xx   x xx x   xx" "    xxx     x    xx " "    xxxx   xxx  xx  " "     xxxxxxx xxxx   "))) (make-problem "Hattori 92" (quote ((5) (5 2) (7 4) (8 5) (9 6) (9 6) (9 8) (1 7 8) (1 4 8) (4 2 7) (1 2 3 6) (2 2 1 5 5) (2 1 1 2 2 5) (1 2 1 5 5) (1 2 2 3 6) (3 2 6) (1 2 7) (4 1 6) (1 1 4) (1 1 3))) (quote ((4) (2 2 1) (9 5) (5 1 1) (6 1 1 2 1) (7 1 4 1) (7) (8 5) (10 2) (10 3 2) (1 3 5 4) (1 2 2) (1 3 5 4) (10 3 5) (10 6) (17) (16) (15) (13) (9))) (quote ("            xxxx    " "    xx     xx  x    " "   xxxxxxxxx   xxxxx" "  xxxxx  x       x  " "  xxxxxx x x xx  x  " " xxxxxxx x xxxx  x  " " xxxxxxx            " " xxxxxxxx xxxxx     " " xxxxxxxxxx   xx    " "xxxxxxxxxx xxx xx   " "x     xxx xxxxx xxxx" "x         xx xx     " "x     xxx xxxxx xxxx" "xxxxxxxxxx xxx xxxxx" " xxxxxxxxxx   xxxxxx" "  xxxxxxxxxxxxxxxxx " "  xxxxxxxxxxxxxxxx  " "   xxxxxxxxxxxxxxx  " "    xxxxxxxxxxxxx   " "      xxxxxxxxx     "))) (make-problem "Hattori 93" (quote ((8 3) (3 1 3 1) (2 3 1) (1 2 2 4) (1 3 1 5) (2 1 1 2 1) (1 2 1 3) (1 2 2) (2 3 1) (3 1 3 2) (8 3) (5 9) (2 4 1) (2 9) (2 6 2) (2 1 4 1 1) (2 9 1) (2 1 1 1) (13 1) (15 3))) (quote ((9) (3 1 3 1) (2 3 2) (1 2 2) (1 2 10) (2 1 1 11) (1 3 2 2) (2 2 2 2 2) (3 3 3 1 2) (3 1 3 9) (7 6 2) (6 2) (1 4 2) (4 4) (1 1 1 2) (1 1 1 2 1) (7 1 2) (5 2 3 6) (1 2 1 1 1) (1 2 1 1))) (quote (" xxxxxxxxx          " "xxx  x  xxx        x" "xx       xxx      xx" "x         xx      xx" "x    xx   xxxxxxxxxx" "xx  x x  xxxxxxxxxxx" "x  xxx    xx      xx" "xx xx    xx    xx xx" "xxx     xxx xxx x xx" " xxx x xxx xxxxxxxxx" "  xxxxxxx  xxxxxx xx" "           xxxxxx xx" "           x xxxx xx" "           xxxx xxxx" "           x x  x xx" "    x      x x xx  x" "   xxxxxxx x xx     " "xxxxx xx xxx  xxxxxx" "x  xx x   x        x" "x  xx     x        x"))) (make-problem "Hattori 94" (quote ((3 5) (2 1 2 1) (2 3 2 1) (2 2 3 1) (2 2 4 1) (2 2 3 1 3) (1 2 4 2 1 2) (1 3 2 5 1) (1 2 3 2 1) (2 4 2 1) (1 1) (2 3 2 1) (1 1 1 2 1) (1 3 2 1) (1 2 1) (1 2 1) (1 1 2 2 1) (3 3 6 2) (5 3 3) (6 10))) (quote ((7) (3 2) (6 3) (4 2) (3 2 3 2) (2 3 1 1 3) (1 4 3 1 1) (6 1 2 1) (2 2 1 1 2) (2 4 1 2) (2 4 2 3) (1 5 1 3 1 1) (1 3 2 6 1) (1 2 2 2 1) (8 1 1 1) (2 1) (5 1) (1 1 2) (2 3) (14))) (quote ("           xxxxxxx  " "         xxx     xx " "    xxxxxx      xxx " "  xxxx            xx" " xxx   xx  xxx    xx" "xx    xxx  x x   xxx" "x   xxxx   xxx   x x" "xxxxxx   x      xx x" "  xx  xx x      x xx" " xx xxxx x       xx " "xx xxxx xx       xxx" "x xxxxx x    xxx x x" "x xxx  xx   xxxxxx x" "x     xx   xx   xx x" "xxxxxxxx   x     x x" "       xx          x" "     xxxxx         x" "     x   x        xx" "     xx          xxx" "      xxxxxxxxxxxxxx"))) (make-problem "Hattori 95" (quote ((3 9) (1 2 1 1 1 2) (1 1 1 2) (5 1 3 1) (4 1 1) (13) (13) (2 3) (8 3) (11 2) (2 5) (11 1) (1 1 1 1 5) (2 1 1 1 2) (2 2 3) (5 2 2) (2 1 4 1 2) (3 4 2 2 2) (6 1 2 5) (3 2 5 2 2))) (quote ((4 3) (1 1 4) (2 2 5) (5 1 1) (4 2 3 3) (4 7 3) (1 5 1 3) (4 2 2 3 2) (1 3 2 1 1 1) (2 1 2 2 4 2 1) (1 1 2 2 1 1 2 1) (2 1 2 2 1 1 1) (1 3 2 3 2) (4 2 2 1 2) (3 3 4 3) (4 6 2) (5 3 2) (3 1 2 1) (3 5) (4))) (quote ("xxxx             xxx" "x  x            xxxx" "xx xx          xxxxx" " xxxxx         x  x " "   xxxx  xx  xxx xxx" "    xxxx xxxxxxx xxx" "x    xxxxx x   xxx  " "xxxx xx xx xxx   xx " "x   xxx xx x    x  x" "xx x xx xx xxxx xx x" "x  x xx xx x  x xx x" "xx x xx xx x    x  x" "x   xxx xx xxx    xx" "xxxx xx xx x     xx " "xxx  xxx xxxx  xxx  " "     xxxx xxxxxx  xx" "      xxxxx xxx   xx" "        xxx x xx  x " "          xxx  xxxxx" "                xxxx"))) (make-problem "Hattori 96" (quote ((4 4) (2 3) (5 8) (3 10) (3 3 1 4) (3 2 2 2 1 1) (3 2 1 1 1) (3 2 1 1 2) (4 2 1 3) (4 1 3) (9 5) (4 6) (14) (1 1 1 2 4) (3 2 3) (6 3 3) (13 3) (4 1 4 4) (3 2 4 1 1) (4 2 5 4))) (quote ((2) (9 1) (1 8 4) (1 9 5) (3 4 5) (1 4 4 4) (2 6 3 3 1) (1 3 9 2) (1 2 1 1 1 4) (1 2 3 1 2 1 1) (3 1 1 1 1 2) (2 3 1 2 4) (2 1 1 5) (3 11) (4 10) (2 6) (5 4 3) (8 1) (7 1) (7))) (quote (" xx                 " "xxxxxxxxx          x" "x xxxxxxxx      xxxx" "x xxxxxxxxx    xxxxx" "xxx     xxxx   xxxxx" " x  xxxx xxxx xxxx  " "xx xxxxxx xxx xxx  x" "x xxx   xxxxxxxxx xx" "x xx x    x x  xxxx " "x xx xxx  x xx  x  x" "  xxx   x x x   x xx" "  xx xxx  x xx  xxxx" "  xx x      x  xxxxx" "  xxx    xxxxxxxxxxx" "  xxxx  xxxxxxxxxx  " "   xx  xxxxxx       " "    xxxxx xxxx   xxx" "          xxxxxxxx x" "           xxxxxxx x" "             xxxxxxx"))) (make-problem "Hattori 97" (quote ((7 3 2) (2 6 3) (12 2 4) (3 6 1) (2 4 3 3) (2 1 1 1 1) (3 1 3) (1 1 1 1) (1 2 3 2) (2 1 4 2) (1 1 1 1) (2 2 3 2) (1 2 1 2) (2 2 2 2) (1 2 2 1 1) (1 2 4 2) (1 2 3 4) (1 5 2 3) (2 1 1 1) (16 1))) (quote ((8 5) (6 3 1 2) (3 3 4 1) (1 1 2 1 1) (1 1 2 1 1) (1 1 2 2 1) (1 1 1 1 2 2 1) (1 1 2 2 2 1 1) (1 1 1 5 1 1 1) (10 1 1 1 1) (3 2 1 1 1) (5 2 2 1) (2 2 4 1) (5 4) (3 1 1) (1 1) (1 4) (8 3) (3 1 1 4 7) (3 3 1 1 1))) (quote ("  xxxxxxxx    xxxxx " " xxxxxx  xxx x    xx" " xxx  xxx  xxxx    x" "x x     xx    x    x" "x x       xx   x   x" "x x        xx  xx  x" "x x x    x  xx  xx x" "x x xx  xx   xx  x x" "x x x   xxxxx x  x x" "xxxxxxxxxx x   x x x" " xxx       xx  x x x" "xxxxx       xx xx  x" "xx xx        xxxx  x" "xxxxx           xxxx" " xxx             x x" "                x  x" "  x             xxxx" " xxxxxxxx      xxx  " "xxx x x xxxx xxxxxxx" "xxx xxx  x x x      "))) (make-problem "Hattori 98" (quote ((3) (7) (2 3 3) (8 1 4) (2 3 5) (10) (9) (3 4) (4 10) (3 10) (3 9) (2 4 4) (2 15) (2 15) (3 13) (4 5 5) (7 7) (18) (17) (13))) (quote ((1 1 8) (3 11) (1 3 5) (1 2 5) (1 2 3 4) (1 1 4 4) (3 5 4) (5 7 3) (6 3 4 3) (2 2 3 4 3) (2 1 2 3 4 3) (2 2 3 4 3) (6 3 4 3) (9 3 4) (8 4 4) (7 9) (5 8) (8) (6) (4))) (quote ("  x x    xxxxxxxx   " "  xxx   xxxxxxxxxxx " "   x    xxx   xxxxx " "   x   xx      xxxxx" "   x   xx xxx   xxxx" "   x   x  xxxx  xxxx" "  xxx    xxxxx  xxxx" " xxxxx  xxxxxxx  xxx" " xxxxxx xxx xxxx xxx" "xx   xx xxx xxxx xxx" "xx x xx xxx xxxx xxx" "xx   xx xxx xxxx xxx" " xxxxxx xxx xxxx xxx" " xxxxxxxxx  xxx xxxx" "  xxxxxxxx xxxx xxxx" "   xxxxxxx xxxxxxxxx" "    xxxxx  xxxxxxxx " "           xxxxxxxx " "            xxxxxx  " "             xxxx   "))) (make-problem "Hattori 99" (quote ((8) (14) (14) (14) (8 1) (1 1) (1 1) (1 1) (1 1) (1 1) (1 1) (1 1) (1 1) (1 4) (4 6) (6 7) (7 7) (7 6) (6 4) (4))) (quote ((3) (5) (5) (6) (6) (5) (17) (4) (4) (4) (4) (4) (5) (5 3) (4 5) (4 5) (4 6) (4 6) (4 5) (17))) (quote ("                xxx " "               xxxxx" "               xxxxx" "              xxxxxx" "              xxxxxx" "              xxxxx " " xxxxxxxxxxxxxxxxx  " " xxxx               " " xxxx               " " xxxx               " " xxxx               " " xxxx               " "xxxxx               " "xxxxx          xxx  " "xxxx          xxxxx " "xxxx          xxxxx " "xxxx         xxxxxx " "xxxx         xxxxxx " "xxxx         xxxxx  " "xxxxxxxxxxxxxxxxx   "))) (make-problem "Hattori 100" (quote ((3 7) (4 9 2) (4 10 1) (4 1 6 1) (5 1 1 1 2 1) (5 1 1 1 2 1) (5 7 2 1) (16 1) (11 1) (3 8 2) (2 1 11) (2 14) (3 13) (5 11) (3 6 3 3) (2 4 2 4 1) (1 3 2 7) (6 4 2 5) (3 3 2 2 1) (4 3 2))) (quote ((7 3 3) (7 5 1 2) (8 1 3 2) (7 2 2 2) (4 3 2 1) (1 3 3 1) (3 2 3 2) (3 2 2 3) (9 5 2) (3 9 2) (3 1 12) (3 10 2) (14 4) (4 11 1) (4 1 10) (4 12) (8 4 5) (6 2 2 2 1) (1 3 2 2) (10 2 2))) (quote ("xxxxxxx   xxx  xxx  " "xxxxxxx  xxxxx x xx " "xxxxxxxx x  xxx  xx " " xxxxxxx xx  xx  xx " "    xxxx    xxx xx x" "       x   xxx xxx x" "      xxx  xx xxx xx" "      xxx  xx xx xxx" " xxxxxxxxx xxxxx xx " "xxx   xxxxxxxxx xx  " "xxx x xxxxxxxxxxxx  " "xxx   xxxxxxxxxx  xx" "xxxxxxxxxxxxxx  xxxx" "xxxx   xxxxxxxxxxx x" "xxxx x xxxxxxxxxx   " "xxxx   xxxxxxxxxxxx " " xxxxxxxx xxxx xxxxx" "  xxxxxx  xx xx xx x" " x       xxx xx xx  " " xxxxxxxxxx   xx xx "))) (make-problem "Hattori 101" (quote ((5) (7) (9) (1 1 1 1) (1 1) (1 2 1) (2 2) (1 4 1 1) (6 4 7) (1 2 4 2 2) (1 4 4 7) (1 1 1 1 1 1) (3 1 1 1 1) (4 8 1 1) (1 3 1) (1 7 1) (1 4 4 1) (2 9 2) (1 5 5 1) (11))) (quote ((1) (6 3) (1 2 2) (1 4) (1 1 1 2) (1 3 2 4) (11 7) (3 1 1 5) (4 7 5) (3 1 4 1 1 1 1) (4 1 4 1 5) (3 7 5) (6 7) (6 1 4) (3 3 2) (1 1) (1 1) (1 1 2) (3 5) (4))) (quote ("             x      " "        xxxxxx xxx  " "        x   xx   xx " "        x xxxx      " "  x     x x       xx" "  x     xxx xx  xxxx" " xxxxxxxxxxx xxxxxxx" "xxx   x      x xxxxx" "xxxx   xxxxxxx xxxxx" "xxx  x xxxx  x x x x" "xxxx x xxxx  x xxxxx" "xxx    xxxxxxx xxxxx" " xxxxxx      xxxxxxx" "      xxxxxx  x xxxx" "        xxx xxx   xx" "        x x         " "        x x         " "        x x      xx " "        xxx  xxxxx  " "       xxxx         "))) (make-problem "Hattori 102" (quote ((2 7) (1 5 3) (2 7 2 2 1) (1 2 2 2 2 1) (1 2 2 3 1) (1 2 4 6) (4 6 5) (3 6 4) (1 4 1) (3 1 3 1) (6 5 1) (7 5 2) (3 5 3 1) (1 1 1 6 2) (1 2 1 2 3) (1 4 1 5 1) (1 4 4 3) (7 1) (1 1) (4))) (quote ((1 5) (5 1) (1 9) (3 4 3 2) (6 3 1 2) (3 2 2) (2 2 8) (4 9 2) (4 4 3 1 1) (3 4 2 1 1) (1 5 6 1) (1 2 2 2 5 1) (1 2 4 5) (3 4 2) (1 2 4 2) (2 4 2 1) (6 4) (5 3 1) (7 3) (4))) (quote ("  x         xxxxx   " "  xxxxx     x       " "x     xxxxxxxxx     " "xxx xxxx xxx  xx    " "  xxxxxx xxx x xx   " " xxx      xx   xx   " " xx   xx  xxxxxxxx  " "xxxx xxxxxxxxx  xx  " "xxxx xxxx  xxx x x  " "xxx  xxxx   xx   x x" "x   xxxxx   xxxxxx x" "x  xx xx  xx xxxxx x" "x xx     xxxx  xxxxx" "xxx      xxxx  xx   " " x   xx  xxxx xx    " " xx xxxx  xx  x     " "  xxxxxx     xxxx   " "   xxxxx   xxx  x   " "     xxxxxxx    xxx " "  xxxx              "))) (make-problem "Hattori 103" (quote ((7) (2 2) (1 2 2 1) (1 1 1 1) (1 5 1) (1 1 1 1) (9) (9) (1 1 2) (9 4) (9 4) (9 2) (9) (1 1 7) (9 7) (10 2) (1 1 2) (10 2) (9 2) (9 2))) (quote ((3) (1 1) (1 1) (1 4) (1 2 1) (12 2 3) (2 2 4 2 3) (1 1 4 4 2 3) (1 3 2 7 3) (1 1 2 3 1 3) (1 3 2 3 1 3) (1 1 4 3 1 3) (2 2 3 5) (11 2 2) (2) (2 2) (4 7) (4 7) (2 2) (2))) (quote ("            xxx     " "            x x     " "            x x     " "            x xxxx  " "            x xx x  " " xxxxxxxxxxxx xx xxx" "xx    xx xxxx xx xxx" "x x xxxx xxxx xx xxx" "x xxx xx xxxxxxx xxx" "x   x xx xxx   x xxx" "x xxx xx xxx   x xxx" "x x xxxx xxx   x xxx" "xx    xx xxx   xxxxx" " xxxxxxxxxxx xx   xx" "             xx     " "         xx  xx     " "        xxxx xxxxxxx" "        xxxx xxxxxxx" "         xx  xx     " "             xx     "))) (make-problem "Hattori 104" (quote ((11) (1 1) (1 1) (2 1 1 1) (5 1) (3 1) (5 1) (7 1) (9 1) (9 1) (8 1) (6 4 1) (1 3 1) (3 2 3 1) (2 1 4 1) (1 3 5 1) (1 1 4 1) (5 5) (7 4 1) (9 5))) (quote ((3) (3) (6) (2 3) (1 1 3) (3 1 2) (2 1 2 2) (1 5 1) (2 6 1) (1 8) (12) (1 7 2) (1 2 6 1 1) (1 5 1 1) (1 9 2) (1 9) (1 8) (1 5) (1 1) (19))) (quote ("                 xxx" "                 xxx" "              xxxxxx" "             xx  xxx" "             x x xxx" "           xxx x  xx" "        xx x   xx xx" "   x   xxxxx       x" "   xx xxxxxx       x" "x   xxxxxxxx        " "xxxxxxxxxxxx        " "x   xxxxxxx  xx     " "x  xx xxxxxx x     x" "x      xxxxx   x   x" "x       xxxxxxxxx xx" "x          xxxxxxxxx" "x           xxxxxxxx" "x             xxxxx " "x                x  " "xxxxxxxxxxxxxxxxxxx "))) (make-problem "Hattori 105" (quote ((3) (2 6) (2 2 2) (2 2 2) (13) (1 2) (1 3 3 1) (1 1 1 1 1 1) (1 3 3 1) (3 1) (1 4 1) (1 4 1 1) (1 1 2 1 2 1) (1 1 2 1 1 1) (4 2 3 1) (1 2) (2 1) (3 2) (4 2) (11))) (quote ((6) (1 1) (7 3) (3 3) (2 1 3 2) (2 1 1 1 1 1) (1 1 3 4 2) (2 1 4 1) (2 1 3 1 1) (4 1 1 2) (1 2 3 5 1) (1 1 1 1 1) (2 1 1 3 1) (3 1 1 1) (3 1) (11 1) (3 1) (3) (2) (1))) (quote ("         xxxxxx     " "         x    x     " "   xxxxxxx  xxx     " "  xxx         xxx   " " xx x xxx       xx  " "xx  x x x  x     x  " "x   x xxx  xxxx  xx " "xx  x      xxxx   x " " xx x xxx  x      x " " xxxx x x         xx" " x xx xxx xxxxx    x" " x  x     x   x    x" " xx x     x xxx    x" "  xxx     x x      x" "   xxx             x" "     xxxxxxxxxxx   x" "               xxx x" "                 xxx" "                  xx" "                   x"))) (make-problem "Hattori 106" (quote ((3 3 4) (2 1 3 1 2 1) (1 9 1 4) (13 1) (9 4) (3 4 1) (1 2 3 1 4) (1 7 1 1 2 1) (2 1 3 2 4 1) (2 1 1 2 1) (2 1 2 2 1) (1 1 1 4) (1 1 1 1 1) (2 1 2 3) (1 1 1 1) (1 1 1 4) (1 3 1 2 1) (1 5 1 4) (1 7 1 2 1) (13 4))) (quote ((1 1 6) (3 4 4 1) (1 1 2 1) (8 1) (5 2 2) (1 3 1 3) (5 2 4) (4 13) (5 2 4) (1 3 2 3) (5 1 2) (7 1) (1 1 3 1) (3 1 4 1) (1 4 6) (1) (20) (1 1 1 6 1 5) (1 1 1 1 3 1 1 1) (1 1 1 6 5))) (quote (" x      x    xxxxxx " " xxx xxxx xxxx     x" "   x x   xx        x" "  xxxxxxxx         x" "xxxxx xx          xx" "x xxx  x         xxx" "xxxxx  xx       xxxx" " xxxx  xxxxxxxxxxxxx" "xxxxx  xx       xxxx" "x xxx xx         xxx" "xxxxx x           xx" "  xxxxxxx          x" "   x x  xxx        x" " xxx x    xxxx     x" " x   xxxx    xxxxxx " "        x           " "xxxxxxxxxxxxxxxxxxxx" "x x x xxxxxx x xxxxx" "x x x x    xxx x x x" "x x x xxxxxx   xxxxx"))) (make-problem "Hattori 107" (quote ((1) (1 5) (1 1 1 1) (1 8) (1 4 1 2) (1 14) (1 4 9 1) (1 1 1 3) (2 12 2) (5 2 1 2 6) (8 8) (1 2 2 2 2 3) (1 13) (1 4 4) (1 1 1 1) (1 1 1 1) (1 7) (1 1 1) (1 3 3) (1 1 1))) (quote ((3) (19) (2) (2 5) (3 6) (4 1 1 2) (15 1) (1 3 6 4) (1 1 2 1 1 1 1) (7 2 1 3) (1 1 2 1 1 1 1) (1 4 6 4) (15 1) (2 1 1 2) (2 6) (2 4) (2 2) (5) (6) (1 1 1))) (quote ("        xxx         " " xxxxxxxxxxxxxxxxxxx" "         xx         " "     xx xxxxx       " "    xxx xxxxxx      " "   xxxx x x xx      " "  xxxxxxxxxxxxxxx x " " x xxx  xxxxxx  xxxx" " x x xx x   x   x x " "xxxxxxx xx  x xxx   " " x x xx x   x   x x " " x xxxx xxxxxx  xxxx" "  xxxxxxxxxxxxxxx x " "     xx x x xx      " "     xx xxxxxx      " "     xx  xxxx       " "     xx  xx         " "       xxxxx        " "      xxxxxx        " "       x x x        "))) (make-problem "Hattori\n108" (quote ((11 7) (1 2 1 1 9) (1 1 1 3 10) (6 2 1 10) (1 4 1 10) (1 4 1 1 5) (1 1 3 1 1) (1 2 1 2 1 4 3) (3 1 3 4 3) (1 1 1 2 1 1 1) (11 4 3) (1 1) (1 1 6) (1 1 1 6) (1 4 1 4) (1 2 1 2 2) (3 1 1 5) (5 3 1 1) (6 2 1 1 1) (6 2 1 11) (2 4 1 8) (1 4 2 8) (12 12) (4 1 8) (4 3 2 1) (4 3 2 2 1) (4 1 8 1) (4 1 1) (4 4 1) (6 15))) (quote ((16 4) (1 1 1 1 8) (2 1 2 1 3 7) (4 3 1 3 8) (1 3 1 4 1 4) (11 6 1 2) (1 3 1 8 1) (1 2 2 1 6 2) (1 2 2 1 3 5) (1 1 1 1 2 2 1 1) (11 6 1 2 2) (1 1 3 1) (2 5 2 1) (2 2 2 1) (5 1 1 1) (3 1 1 1 1) (15 1 1 1 1) (4 4 2 5 1 1) (5 2 1 2 1 5 1 1) (5 4 3 1 8 1) (6 3 1 8 1) (6 3 8 1) (6 4 3 5 1) (6 2 1 2 5 1) (6 4 11))) (quote ("xxxxxxxxxxxxxxxx      xxxx    " "x  x    x x         xxxxxxxx  " "xx x   xx x       xxx xxxxxxx " "xxxx xxx  x      xxx  xxxxxxxx" "x  xxx    x     xxxx  x   xxxx" "xxxxxxxxxxx    xxxxxx x     xx" "x   xxx   x    xxxxxxxx      x" "x  xx xx  x      xxxxxx     xx" "x xx   xx x         xxx  xxxxx" "x x     x x       xx xx  x  x " "xxxxxxxxxxx   xxxxxx  x xx  xx" "              x  x    xxx    x" "             xx  xxxxx  xx   x" "              xx     xx  xx  x" "               xxxxx  x   x  x" "  xxx              x  x   x  x" " xxxxxxxxxxxxxxx   x  x   x  x" " xxxx  xxxx    xx  xxxxx  x  x" "xxxxx  xx x xx  x  xxxxx  x  x" "xxxxx  xxxx xxx x  xxxxxxxx  x" "xxxxxx      xxx x  xxxxxxxx  x" "xxxxxx      xxx xxxxxxxx     x" "xxxxxx xxxx xxx    xxxxx     x" "xxxxxx xx x xx     xxxxx     x" "xxxxxx xxxx        xxxxxxxxxxx"))) (make-problem "Hattori 109" (quote ((11 7) (13 11) (16 13) (31) (9 18) (7 17) (4 1 1 1 2 8) (3 1 1 1 1 2 6) (3 2 3 1 2 2 6) (3 1 1 2 2 5) (5 2 1 8 4) (4 2 3 1 1 1 4) (3 3 1 1 1 3) (4 4 1 2 5) (1 7 6 1 2) (2 1 2 2 1 2 3) (4 1 2 2 2 5) (4 11 4 1) (10 2 2 1 3) (20 1 1 2) (2 4 3 3 3 2 4) (1 2 4 2 2 5 1) (1 5 1 1 1 2 3 1 1) (1 1 5 6 1 2 5) (1 1 5 4 1 1 1 1) (1 1 1 5 1 1 1) (1 1 5 5 1) (1 3 4 2 1) (1 2 3 6 1) (4 4 3 3 2 1) (17 12) (10 7 9))) (quote ((8 8 1) (10 3 2 2) (13 4 4) (7 4 4 3) (6 2 4 6 3) (6 1 8 3) (6 8 2) (5 2 5 2) (5 1 2 1 2 3 2) (4 1 1 3 4 3) (4 3 1 4 6 1 2) (4 2 1 1 3 2 5) (4 4 21) (4 8 2) (4 1 2 1 2 10) (12 1 3 9) (4 18) (7 6 5 2) (13 1 1 3 2 2) (5 1 1 7 4) (6 1 3 1 4) (6 4 1 2 2 3 2 2) (6 2 2 1 2 2) (6 1 4 2 4) (7 1 1 2 2 3 3) (7 1 1 1 1 2) (9 2 1 1 2) (9 1 2 3 1 2) (11 1 1 2 4 1) (13 2 2 1 1 1) (16 2 1 1) (13 10))) (quote ("   xxxxxxxx       xxxxxxxx     x" "  xxxxxxxxxx      xxx     xx  xx" " xxxxxxxxxxxxx  xxxx        xxxx" "xxxxxxx   xxxx  xxxx         xxx" "xxxxxx xx xxxx xxxxxx        xxx" "xxxxxx  x    xxxxxxxx        xxx" "xxxxxx            xxxxxxxx    xx" "xxxxx     xx      xxxxx       xx" "xxxxx   x xx  x   xx  xxx     xx" "xxxx    x     x  xxx xxxx    xxx" "xxxx  xxx  x  xxxx xxxxxx  x xx " "xxxx       xx x  x xxx xx  xxxxx" "xxxx  xxxx xxxxxxxxxxxxxxxxxxxxx" "xxxx        xxxxxxxx          xx" " xxxx   x    xx  x xx xxxxxxxxxx" "  xxxxxxxxxxxx   x xxx xxxxxxxxx" "  xxxx        xxxxxxxxxxxxxxxxxx" "   xxxxxxx    xxxxxx   xxxxx  xx" "  xxxxxxxxxxxxx  x x xxx xx xx  " " xxxxx    x   x  xxxxxxx    xxxx" "xxxxxx    x   xxx   x       xxxx" "xxxxxx   xxxx x xx xx xxx  xx xx" "xxxxxx   xx      xx   x    xx xx" "xxxxxx    x      xxxx xx    xxxx" "xxxxxxx   x  x   xx xx xxx   xxx" "xxxxxxx   x  x       x    x   xx" "xxxxxxxxx     xx     x    x   xx" " xxxxxxxxx   x xx    xxx  x   xx" " xxxxxxxxxxx x  x   xx xxxx   x " " xxxxxxxxxxxxx xx  xx  x  x   x " "  xxxxxxxxxxxxxxxx xx  x      x " "    xxxxxxxxxxxxx   xxxxxxxxxx  "))) (make-problem "Hattori 110" (quote ((2 2 8 5) (3 1 2 1 4 1 1 3) (1 3 8 7 2) (3 4 2 2 4 4 2) (2 1 5 2 2 5 4) (2 1 5 1 5 3) (4 1 2) (4 3 2) (4 2) (4 6 2) (5 10 3) (1 8 1) (30) (1 5 5 6 7 1) (11 3 1 2 1) (3 8 8 1) (1 23) (1 2 9 9 1) (1 3 10 5 2 1) (1 6 1 2 3 1 1 2 1) (3 2 14 1 1 1) (1 1 2 13 1 2 1) (1 1 4 6 1 1) (2 1 2 7 2 1) (2 2 1 1 1) (2 2 2 2) (1 5 2 2) (1 4 2 2) (1 5 2 2) (1 7 3 2) (1 10 7 2) (30))) (quote ((2 4 5) (3 5 2 2 1) (1 8 1 2 2 1) (12 1 4 1) (2 1 4 2 1) (1 1 1 6 2 1) (2 2 7 3) (1 2 3 1 2 1 5) (4 1 8 5) (5 6 2 2 5) (2 2 8 1 1 6) (4 10 2 1 4) (5 12 1 3) (1 1 7 3 2 2) (1 2 3 10 2 2) (1 2 5 4 4 2) (2 4 5 6 1 1) (2 1 5 1 6 1) (2 1 5 3 4 1) (2 1 5 8 1) (1 2 5 3 5 2) (1 2 3 9 2 2) (5 1 7 4 1 2) (4 9 1 1 3) (2 2 2 4 2 1 6) (4 8 1 5) (4 2 3 2 2) (1 2 5 1 1 1) (1 2 3 2 1) (2 2 1 1 2 1) (16 1 7) (11 14))) (quote ("xx    xxxx      UUUUUUUUUUUUUUU " "xxx   xxxxx xx  UUUUUUUUUUUUUUU " " x xxxxxxxx x   UUUUUUUUUUUUUU x" "  xxxxxxxxxxxx  UUUUUUUUUUUUUU x" "  xx      x xxxx  UUUUUUUUUUUU x" "  x  x    x xxxxxx UUUUUUUUUU  x" "xx xx       xxxxxxx          xxx" "x xx        xxx x xx x     xxxxx" "  xxxx      x xxxxxxxx     xxxxx" " xxxxx      xxxxxx xx xx   xxxxx" " xx xx      xxxxxxxx x  x xxxxxx" "  xxxx      xxxxxxxxxx xx x xxxx" " xxxxx      xxxxxxxxxxxx  x  xxx" "  x       x xxxxxxx xxx  xx   xx" "x xx      xxx xxxxxxxxxx xx   xx" "x  xx    xxxxx xxxx xxxx      xx" "xx  xxxx xxxxx  xxxxxx x       x" "xx     x xxxxx  x xxxxxx       x" "xx     x xxxxx  xxx xxxx       x" "xx  x    xxxxx  xxxxxxxx       x" "x  xx    xxxxx xxx xxxxx      xx" "x xx      xxx xxxxxxxxx xx    xx" " xxxxx    x xxxxxxx xxxx x    xx" "  xxxx      xxxxxxxxx  x  x  xxx" " xx xx      xx xxxx xx  x xxxxxx" "  xxxx      xxxxxxxx  x    xxxxx" "  xxxx      xx xxx  xx        xx" "x xx        xxxxx x  x         x" "x  xx       xxx   xx           x" "xx  xx    x x      xx          x" "xxxxxxxxxxxxxxxx x       xxxxxxx" "xxxxxxxxxxx       xxxxxxxxxxxxxx"))) (make-problem "Hattori 111" (quote ((7) (1 1 2 6) (2 2 1 7) (5 1 8) (8 1 9) (5 1 10) (3 1 10) (2 2 6) (5) (1 4) (1 1 6) (3 1 8) (4 1 1 7) (1 3 1 1 1 3) (3 1 1 1 2) (6 3 1 1) (1 2 2 1 4 1) (8 3 6) (3 2 1 1 10) (8 1 6) (5 3 12) (2 4 2 1 5) (4 4 1 8) (6 1 2 3 1) (3 2 1 1 4) (1 3 4 1 1 1 2) (4 2 1 1 2 2 1) (2 8 4) (7 2) (2 1 1 1 3))) (quote ((2 9 3 4) (3 2 2 8 2) (1 4 10 5) (7 2 3 5 2) (3 3 5 3) (4 5 4) (3 2 5 2) (2 4 1 3 1) (4 1 3) (1 4) (7 1 3) (2 2 6 2) (1 8 1 4 3) (1 1 4 1 4) (2 2 4 1 1 1 2) (9 2 2 1 1) (8 3 1 3 1 4) (8 4 4 2 2) (7 4 6 1 1) (7 5 13) (5 14 4) (5 4 8) (4 1 5 1) (3 1 1 2) (2 5))) (quote ("    xx    xxxxxxxxx xxx xxxx  " "    xxx    xx xx xxxxxxxx xx  " "  x xxxx   xxxxxxxxxx xxxxx   " " xxxxxxx    xx xxx xxxxx xx   " "   xxx       xxx xxxxx xxx    " " xxxx          xxxxx xxxx     " "  xxx           xx xxxxx  xx  " "   xx            xxxx x  xxx x" "                   xxxx  x xxx" "                     x   xxxx " " xxxxxxx                 x xxx" "xx     xx      xxxxxx      xx " "x       xxxxxxxx x  xxxx   xxx" "x       x      xxxx x    xxxx " "xx     xx  xxxx x x x       xx" "xxxxxxxxx xx   xx x x         " "xxxxxxxx xxx x  xxx x  xxxx   " "xxxxxxxx xxxx    xxxx xx  xx  " " xxxxxxx xxxx    xxxxxx    x x" " xxxxxxx xxxxx   xxxxxxxxxxxxx" "  xxxxx   xxxxxxxxxxxxxx  xxxx" "  xxxxx    xxxx  xxxxxxxx     " "   xxxx     x     xxxxx x     " "    xxx     x         x xx    " "     xx               xxxxx   "))) (make-problem "Hattori\n112" (quote ((3 6) (9 4) (1 1 1 5) (2 2 2 3) (1 1 1 1) (1 2 1) (15 1) (4 1 4) (3 1 4) (3 5) (7) (6 1) (7 2) (8 1 3) (7 3 3) (1 2 1 1 6) (1 3 4) (1 2 1) (1 1 2) (20))) (quote ((1 1) (2 1) (3 1) (1 4 1 1) (1 9 1) (3 1 7 1) (2 2 1 5 1) (3 15) (2 2 1 7 1) (3 1 7 1) (1 5 4 1) (1 4 1) (3 6) (2 2 2 1) (1 1 1 3 1) (1 2 1 1) (3 1 3 2) (6 7) (4 5 1) (7 3 2 1))) (quote ("      x            x" "      xx           x" "      xxx          x" " x    xxxx   x     x" " x    xxxxxxxxx    x" " xxx  x  xxxxxxx   x" "xx xx x   xxxxx    x" "xxx  xxxxxxxxxxxxxxx" "xx xx x  xxxxxxx   x" " xxx  x xxxxxxx    x" " x    xxxxx xxxx   x" " x    xxxx         x" "      xxx     xxxxxx" "      xx     xx xx x" "x  x  x       xxx  x" "x xx           x   x" "xxx  x        xxx xx" "xxxxxx       xxxxxxx" "xxxx        xxxxx  x" "xxxxxxx    xxx xx  x"))) (make-problem "Hattori 113" (quote ((9) (1 3) (1 1 1 3) (4 1 1) (1 4 1 1 1) (2 1 3 1) (4 2 6) (1 3 1) (1 1 1 1) (1 3 7 1) (8 1) (1 7 1) (10) (3 1 2 1) (5 1 4) (5 1 1) (5 7) (3 1 1) (1 1) (10 5 3))) (quote ((3 1) (2 5 1) (1 1 1 1 5 1) (1 2 5 1) (1 1 3 1) (1 1 1) (6 1) (1 1 1) (1 1 1) (3 1 1 1) (1 3 9) (1 1 2 4 1 1) (1 1 2 4 4) (1 1 1 4 1 1) (1 2 4 4) (3 2 4 1 1) (5 1 9) (3 1 3 1) (1 1 1 1) (9 1))) (quote ("              xxx  x" "   xx        xxxxx x" "   x x   x x xxxxx x" "   x xx      xxxxx x" "   x  x       xxx  x" "    x x            x" "    xxxxxx         x" "    x    x         x" "    x    x         x" "xxx  x    x        x" "x  xxx  xxxxxxxxx   " "x x  xx  xxxx   x  x" "x   x xx xxxx   xxxx" "x x    x xxxx   x  x" "x     xx xxxx   xxxx" "xxx  xx  xxxx   x  x" "xxxxx x xxxxxxxxx   " "xxx   x     xxx    x" "      x     x x    x" "      xxxxxxxxx    x"))) (make-problem "Hattori 114" (quote ((8 7) (10 7) (12 1 1) (4 1 1 1) (3 1 1 3) (3 1 1 1 1 4) (2 3 4 3 3) (2 1 4) (3 1 3 2) (2 1 2) (2 3 1 2) (2 3 2) (2 3 2 2) (6 1 3) (5 3 5) (6 2 2) (7 2 2 1) (3 8 1 6) (3 7 3 1 1 1) (3 6 2 5 4) (4 4 3 8 2) (6 1 4 5) (4 5) (2 4) (1 4))) (quote ((6 7) (9 9) (5 4 11) (4 6 4) (3 1 8 2 1) (3 1 9) (3 2 1 1 5) (3 1 2 5) (3 2 1 1 4 1) (3 1 1 1 3 4) (3 1 1 2 2 5) (11 1 2 6) (1 2 2 7) (4 2) (2 2 3) (3 3 3) (3 2 1 1 3) (8 2 1 2 3) (2 2 1 5) (2 2 3 2) (2 2 1 1 1) (2 3 1 2) (2 3 3) (6 2) (3))) (quote ("   xxxxxx      xxxxxxx   " "  xxxxxxxxx   xxxxxxxxx  " " xxxxx  xxxx xxxxxxxxxxx " "xxxx       xxxxxx   xxxx " "xxx   x     xxxxxxxx xx x" "xxx   x      xxxxxxxxx   " "xxx  xx   x  x  xxxxx    " "xxx       x xx   xxxxx   " "xxx  xx   x x    xxxx x  " "xxx   x     x x  xxx xxxx" "xxx   x    x xx  xx xxxxx" " xxxxxxxxxxx  x xx xxxxxx" "  x        xx  xx xxxxxxx" "            xxxx xx      " "       xx    xx   xxx    " "      xxx   xxx    xxx   " "      xxx  xx x x  xxx   " "xxxxxxxx  xx  x xx xxx   " "xx       xx    x xxxxx   " "xx      xx     xxx  xx   " "xx   xx x        x  x    " "xx  xxx          x xx    " "xx  xxx          xxx     " "xxxxxx             xx    " "                  xxx    "))) (make-problem "Hattori 115" (quote ((11 12 4) (1 12 3) (1 2 1 12 3) (1 2 1 1 4 3 2 3) (1 1 2 1 1 1 1 2) (6 6 2 2 3 1) (1 9 4) (3 1 7 3 6) (1 1 1 4 2 2 8) (3 2 2 3 9) (4 3 4 10 4) (7 10 1 1) (2 1 2 8 2 1) (2 1 2 9 1 1) (3 4 2 1 2 4) (1 3 5 1 2) (1 1 1 2 1 1 1 3) (1 1 1 1 11 2) (1 1 1 1 2 2 2 2) (1 3 3 2 1 2 1 1) (3 5 3 2 3 1 1) (2 2 2 1 2 7 1) (2 1 2 2 5 4) (2 2 2 4 2 4) (7 8 5))) (quote ((1 4 2 8) (1 1 2 2 3) (1 9 4 2 2) (1 2 1 1 3 5 2) (1 1 3 1 1 2 1) (1 2 3 1 2 1) (1 2 2 1 5) (1 3 5 1 2) (1 1 1 1 2 2 1) (1 1 2 2 5 2) (4 4 1 2 1 2 2) (4 1 3 3) (4 1 3 3 1) (2 3 1 4 2) (3 3 4) (12 6 3) (4 7 4 2) (4 1 5 1 2 1) (6 1 4 1 2 1) (3 2 4 1 1 1) (6 2 4 3 1) (4 1 5 7) (4 6 1 5) (3 8 1 2) (12 2 1 2) (2 5 4 4) (1 6 3 2 4) (4 7 1 1 5) (5 4 1 3 2) (6 7 6 1))) (quote ("x xxxx   xx   xxxxxxxx   " "x    x   xx  xx     xxx  " "x xxxxxxxxx xxxx   xx xx " "x xx x x  xxx  xxxxx   xx" "x    x xxx x   x   xx   x" "x   xx   xxx  x     xx  x" "x  xx     xx  x     xxxxx" "x     xxx xxxxx     x  xx" "x     x  x x  xx   xx   x" "x     x xx xx  xxxxx   xx" "xxxx xxxx x xx x   xx xx " "     xxxx x  xxx    xxx  " "     xxxx x   xxx  xxx  x" "xx   xxx  x     xxxx   xx" "xxx  xxx             xxxx" "xxxxxxxxxxxx xxxxxx   xxx" "xxxx   xxxxxxx   xxxx  xx" "xxxx x   xxxxx   x  xx  x" "xxxxxx x  xxxx   x   xx x" "xxx    xx xxxx   x    x x" "xxxxxx xx xxxx  xxx   x  " "xxxx x   xxxxx   xxxxxxx " "xxxx    xxxxxx   x xxxxx " "xxx    xxxxxxxx  x  xx   " "xxxxxxxxxxxx  xx x   xx  " "  xx xxxxx     xxxx  xxxx" "x    xxxxxx xxx   xx xxxx" "xxxx  xxxxxxx x x   xxxxx" "xxxxx  xxxx   x xxx    xx" "xxxxxx  xxxxxxx xxxxxx  x"))) (make-problem "Hattori 116" (quote ((3 2) (7) (9) (9) (6) (2 3 2) (4 2) (12 1) (15) (5 11) (3 11) (3 13) (2 13) (2 14) (16) (15) (9 5) (8 4) (7 4) (11))) (quote ((8) (11) (3 6) (3 7) (2 8) (2 9) (2 9) (11 1) (10 1) (10 2) (14) (2 15) (3 14) (3 11) (6 10) (6 8) (6 7) (4 5) (7) (1 6))) (quote ("           xxxxxxxx " "         xxxxxxxxxxx" "         xxx  xxxxxx" "        xxx  xxxxxxx" "        xx  xxxxxxxx" "        xx xxxxxxxxx" "       xx  xxxxxxxxx" "       xxxxxxxxxxx x" "       xxxxxxxxxx  x" "      xxxxxxxxxx  xx" "      xxxxxxxxxxxxxx" "  xx xxxxxxxxxxxxxxx" " xxx xxxxxxxxxxxxxx " " xxx   xxxxxxxxxxx  " "xxxxxx xxxxxxxxxx   " "xxxxxx xxxxxxxx     " "xxxxxx xxxxxxx      " " xxxx  xxxxx        " "xxxxxxx             " "x xxxxxx            "))) (make-problem "Hattori 117" (quote ((15 3) (15 4) (2 3 1 3 2 4) (2 1 5 1) (15 2 3) (3 3 2 2 1 2) (3 3 1 1 3) (14 3 1) (15 1 2 2) (5 6 1 1 1) (18 1 3) (5 5 2 5) (7 7 7) (7 7 6) (15 5) (15 4) (15 5) (15 8) (15 1 2) (3 1 2) (3 1 2) (3 8) (3 2) (3 4) (7 4))) (quote ((19) (19) (2 15) (3 1 12) (3 1 12 1) (3 1 2 1 7 1) (2 5 1 13) (9 1 11) (2 5 1 13) (3 1 2 1 7 1) (3 1 12 1) (3 1 12) (2 15) (6 12) (5 11) (1 2) (1 1) (2 5 5) (2 1 2 1 1) (4 2 1 1) (7 2 1) (2 3 7 1 2) (5 12 1 2) (3 3 1 15) (3 1 15))) (quote ("xxxxxxxxxxxxxxxxxxx      " "xxxxxxxxxxxxxxxxxxx      " "xx  xxxxxxxxxxxxxxx      " "xxx x  xxxxxxxxxxxx      " "xxx x  xxxxxxxxxxxx     x" "xxx x  xx x xxxxxxx     x" "xx  xxxxx x xxxxxxxxxxxxx" "xxxxxxxxx x   xxxxxxxxxxx" "xx  xxxxx x xxxxxxxxxxxxx" "xxx x  xx x xxxxxxx     x" "xxx x  xxxxxxxxxxxx     x" "xxx x  xxxxxxxxxxxx      " "xx  xxxxxxxxxxxxxxx      " "xxxxxx xxxxxxxxxxxx      " "xxxxx   xxxxxxxxxxx      " "   x     xx              " "   x      x              " "   xx  xxxxx     xxxxx   " "    xx x   xx    x   x   " "     xxxx   xx   x   x   " "        xxxxxxx xx   x   " " xx xxx    xxxxxxx   x xx" "xxxxx xxxxxxxxxxxx   x xx" "xxx xxx x xxxxxxxxxxxxxxx" "xxx  x    xxxxxxxxxxxxxxx"))) (make-problem "Hattori 118" (quote ((11) (12) (7 1) (6 2 2) (6 2 1) (4 1) (5 2 2) (8 1 3) (11 1) (8 5 3) (7 9) (6 5 2) (6 4 1) (6 1 1) (6 4 2) (6 4 1 1) (6 4 2 2) (6 4 2 2) (5 4 2 1) (3 11))) (quote ((10) (12) (13) (14) (14) (14) (5) (3 2 6) (5 2 3 6) (7 1 3 6) (20) (6 3 1) (5 2 2 1) (5 2 2 1) (3 2 3) (2 2 2 2) (2 2 1 6 1) (2 1 1 3 1) (4 4 2) (2 4 2))) (quote ("        xxxxxxxxxx  " "       xxxxxxxxxxxx " "      xxxxxxxxxxxxx " "      xxxxxxxxxxxxxx" "      xxxxxxxxxxxxxx" "      xxxxxxxxxxxxxx" "      xxxxx         " "       xxx xx xxxxxx" " xxxxx xx xxx xxxxxx" "xxxxxxx x xxx xxxxxx" "xxxxxxxxxxxxxxxxxxxx" "xxxxxx   xxx       x" "xxxxx    xx    xx  x" "xxxxx    xx     xx x" "xxx      xx      xxx" "xx xx     xx      xx" "xx xx  x xxxxxx    x" "xx     x x    xxx  x" "xxxx  xxxx      xx  " "xx xxxx          xx "))) (make-problem "Hattori 119" (quote ((12) (1 11) (3 3 3) (1 1 1 1) (1 1 1) (3 1 3 1 3 3) (3 1 1 5 2 1) (2 13 5) (7 5 3 4) (11 3 5) (3 2 2 3 7) (5 3 9) (8 1 1 4) (4 5 5 3) (3 3 2 1 2) (3 2 1 2) (4 3 2 2) (5 4) (9 1 2 3) (2 7 12) (1 6 6 5) (2 2 3 5 1) (3 2 2 2 2 2) (7 2 6 2) (8 3 7) (4 7 9) (3 3 2 4 5) (2 2 1 3 5) (2 3 2 3 4) (8 4 1))) (quote ((3 6 6) (1 1 7 9) (3 2 3 1 2 7) (2 2 4 1 3 2) (6 3 7 2 1) (3 14 3 1) (4 1 7 9 2) (2 1 1 1 2 5 6) (4 1 7 4 5) (3 8 3 2 1) (6 3 3 4 2 2) (2 2 5 10) (1 3 2 4 6) (3 3 1 3 1) (7 2 5) (5 2 6) (3 1 2 2 7) (7 9) (3 1 10) (7 1 1 1 3) (5 1 11) (7 13) (9 2 3 4) (1 1 6 2 2 3) (3 4 5 4))) (quote ("xxx  xxxxxx          xxxxxx   " "x x xxxxxxx        xxxxxxxxx  " "xxx  xx xxx     x xx  xxxxxxx " "xx      xx   xxxx x    xxx  xx" "xxxxxx xxx  xxxxxxx    xx    x" "xxx   xxxxxxxxxxxxxx  xxx    x" "xxxx x xxxxxxx   xxxxxxxxx  xx" "xx   x x x xx    xxxxx  xxxxxx" "xxxx x xxxxxxx   xxxx    xxxxx" "xxx   xxxxxxxx    xxx    xx  x" "xxxxxx xxx  xxx   xxxx  xx  xx" "xx     xx   xxxxx  xxxxxxxxxx " " x    xxx xx xxxx    xxxxxx   " "     xxx xxx    x xxx        x" "     xxxxxxx       xx    xxxxx" "     xxxxx         xx   xxxxxx" "      xxx  x xx    xx  xxxxxxx" "          xxxxxxx xxxxxxxxx   " "         xxx x  xxxxxxxxxx    " "        xxxxxxx  x x x xxx    " "       xxxxx x   xxxxxxxxxxx  " "      xxxxxxx   xxxxxxxxxxxxx " "     xxxxxxxxx xx xxx    xxxx " "     x x  xxxxxx   xx xx  xxx " "     xxx   xxxx    xxxxx  xxxx"))) (make-problem "Hattori 120" (quote ((2) (2 2 3) (3 2 4 3 3) (3 2 6 6) (3 4 4 4 1) (9 5 1) (17 1) (17 1) (16 2) (18) (16) (13) (11) (9) (8) (2 3) (3 2 2) (1 3 1) (1 2 2) (1 3 3) (2 14) (15) (12) (10) (8))) (quote ((5) (1 2) (1 2 1) (2 5) (4 7) (5 2 5) (5 2 5) (5 1 5) (7 1 5) (9 1 5) (11 1 5) (2 11 5) (1 1 10 5) (3 10 5) (5 8 1 5) (5 8 2 5) (3 8 5) (1 1 9) (2 9) (13) (11) (9) (3 2) (2 3) (8))) (quote ("                xxxxx    " "                x   xx   " "  x             xx   x   " "  xx             xxxxx   " "  xxxx          xxxxxxx  " "   xxxxx       xx  xxxxx " "    xxxxx     xx    xxxxx" "     xxxxx    x     xxxxx" "    xxxxxxx   x     xxxxx" "   xxxxxxxxx  x     xxxxx" "  xxxxxxxxxxx x     xxxxx" " xx xxxxxxxxxxx     xxxxx" " x x xxxxxxxxxx     xxxxx" "  xxx xxxxxxxxxx    xxxxx" "xxxxx xxxxxxxx x   xxxxx " "xxxxx xxxxxxxx xx xxxxx  " "  xxx xxxxxxxx  xxxxx    " " x x xxxxxxxxx           " " xx  xxxxxxxxx           " " xxxxxxxxxxxxx           " "  xxxxxxxxxxx            " "   xxxxxxxxx             " "  xxx    xx              " "  xx    xxx              " "  xxxxxxxx               "))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/problems/k15x15 b/collects/games/paint-by-numbers/problems/k15x15
new file mode 100644
index 0000000000..1185144d4d
--- /dev/null
+++ b/collects/games/paint-by-numbers/problems/k15x15
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 15x15") (define problems (list (make-problem "19980519-KHA (1)" (quote ((2 2) (4 4) (6 6) (15) (1 2 1 2 1 1) (2 2 1 1 1) (2 3 2 1 1) (1 3 3 1) (13) (11) (9) (7) (5) (3) (1))) (quote ((5) (2 2 1) (3 2) (4 2 3) (12) (4 7) (2 7) (2 7) (2 7) (4 7) (12) (4 3) (6 2) (2 1) (5))) (quote ("   xxxxx       " "  xx xx x      " " xxx    xx     " "xxxx xx xxx    " "xxxxxxxxxxxx   " " xxxx xxxxxxx  " "  xx   xxxxxxx " "   xx   xxxxxxx" "  xx   xxxxxxx " " xxxx xxxxxxx  " "xxxxxxxxxxxx   " "xxxx    xxx    " " xxxxxx xx     " "  xx    x      " "   xxxxx       "))) (make-problem "19980805-BER (2)" (quote ((1 13) (1 1 1) (1 1 9 1) (1 1 1) (1 3 9) (1 1 1 1) (1 1 11) (1 1) (1 11 1) (1 1 3) (1 1 7 1) (1 1 1 1 1) (1 1 5 1 3) (1 1) (14))) (quote ((15) (1) (3 3 5 1) (1 1 1 1) (1 5 1 3 1) (1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1) (1 1 1 1 1 5) (1 1 1 1 1 1) (1 1 1 1 2 1 1) (1 1 1 1 1 1) (13))) (quote ("xxxxxxxxxxxxxxx" "              x" "xxx xxx xxxxx x" "x   x   x     x" "x xxxxx x xxx x" "x x   x x x x x" "x x x x x x x x" "x x x x x x x x" "x x x x x x x x" "x x x x x x   x" "x x x x x xxxxx" "x x x x x     x" "x x x x xx  x x" "x   x x  x  x x" "xxxxxxxxxxxxx  "))) (make-problem "19980828-PAU (3)" (quote ((4 4) (6 6) (1 1 1 1) (3 3) (4 5 4) (1 1 1 1) (1 1 1) (1) (3) (3) (3 5 3) (2 2) (3 3) (9) (7))) (quote ((1) (2 1 1) (2 1 3) (2 3 4) (2 1 1 3) (2 3 1 2) (2 1 3 2) (1 5 2) (2 1 3 2) (2 3 1 2) (2 1 1 3) (2 3 4) (2 1 3) (2 1 1) (1))) (quote ("    x          " " xx x     x    " "xx  x     xxx  " "xx xxx    xxxx " "xx x  x     xxx" "xx xxx    x  xx" " xx x   xxx  xx" "    x xxxxx  xx" " xx x   xxx  xx" "xx xxx    x  xx" "xx x  x     xxx" "xx xxx    xxxx " "xx  x     xxx  " " xx x     x    " "    x          "))) (make-problem "19990211bJAM (4)" (quote ((3 2) (2 2 2) (2 4) (2 3) (2 5 2) (2 1 1 1 2) (3 5 3) (1 1 1 1 1) (1 5 1) (1 1) (1 4 1) (1 1 1 1) (1 1 1 1) (1 1 1 1) (1 1 1 1))) (quote ((1) (2) (11) (2) (2 5) (2 5 1) (2 1 1 1 1) (1 5 5) (2 1 1 1) (2 5) (2) (5) (15) (2) (1))) (quote ("      x        " "     xx        " "    xxxxxxxxxxx" "   xx          " "  xx      xxxxx" " xx xxxxx x    " "xx  x x x x    " "x   xxxxx xxxxx" "xx  x x x      " " xx xxxxx      " "  xx           " "xxxxx          " "xxxxxxxxxxxxxxx" "     xx        " "      x        "))) (make-problem "19990221bFRA (5)" (quote ((1) (1 1) (2 2) (3 3) (4 4) (5 5) (6 6) (7 7) (1) (1) (15) (13) (11) (9) (9))) (quote ((1 1) (2 2) (3 3) (4 5) (5 5) (6 5) (7 5) (1 7) (7 5) (6 5) (5 5) (4 5) (3 3) (2 2) (1 1))) (quote ("       x  x    " "      xx  xx   " "     xxx  xxx  " "    xxxx  xxxxx" "   xxxxx  xxxxx" "  xxxxxx  xxxxx" " xxxxxxx  xxxxx" "x       xxxxxxx" " xxxxxxx  xxxxx" "  xxxxxx  xxxxx" "   xxxxx  xxxxx" "    xxxx  xxxxx" "     xxx  xxx  " "      xx  xx   " "       x  x    "))) (make-problem "19990421aMIJ (6)" (quote ((3) (3) (2) (4 4) (1 1 2) (1 1) (13) (1 1) (12) (1 1) (14) (1 1) (1 3 1) (4 3) ())) (quote (() (7) (1 1 1 1 1) (1 1 1 1 1) (1 1 1 1 1) (1 1 1 1 1) (1 1 1 1 2) (2 1 1 1 1 1) (4 1 1 1 1) (2 1 1 1 1 1) (1 1 1 1 1 1) (1 1 1 1 1) (1 3 1 1) (1 1 3) (1 1))) (quote ("               " "     xxxxxxx   " "    x x x x x  " "   x  x x x  x " "   x  x x x  x " "   x  x x x  x " "   x  x x x xx " " xx x x x x x  " "xxxx  x x x x  " "xx x  x x x  x " "x  x  x x x  x " "   x  x x x  x " "    x xxx x x  " "    x x  xxx   " "     x    x    "))) (make-problem "19990527cDRA (7)" (quote ((3 4) (1 2) (1 6 1) (1 11) (5 4) (4 2 4) (3 3 3) (1 1 3 1 2) (1 2 2 1) (1 1 2 2) (3 7 3) (4 5 4) (5 5) (15) (15))) (quote ((15) (1 3 5) (1 4 1 5) (3 2 4) (2 2 3) (2 2 2) (2 3 2 2) (2 3 2 2) (2 2 2 2) (2 2 2) (3 2 3) (1 3 3 4) (1 4 1 5) (2 4 6) (3 10))) (quote ("xxxxxxxxxxxxxxx" "x   xxx   xxxxx" "x  xxxx x xxxxx" "   xxx xx  xxxx" "   xx    xx xxx" "  xx      xx xx" "  xx xxx  xx xx" "  xx xxx  xx xx" "  xx  xx  xx xx" "  xx      xx xx" "  xxx    xx xxx" "x  xxx xxx xxxx" "x  xxxx x xxxxx" "xx  xxxx xxxxxx" "xxx  xxxxxxxxxx"))) (make-problem "19990723aDAH (8)" (quote (() () (6 6) (1 3 1) (1 1) (3 3) (2 2 2 2) (9) (9) (1 5 1) (1 3 1) (1 1 1) (1 1) (9) ())) (quote ((4) (1 1) (1 2) (1 8) (1 2 1) (1 4 1) (1 5 1) (1 5 1) (1 5 1) (1 4 1) (1 2 1) (1 8) (1 2) (1 1) (4))) (quote ("  xxxx         " "  x  x         " "  x  xx        " "  x   xxxxxxxx " "  x    xx    x " "  x   xxxx   x " "   x  xxxxx  x " "   x   xxxxx x " "   x  xxxxx  x " "  x   xxxx   x " "  x    xx    x " "  x   xxxxxxxx " "  x  xx        " "  x  x         " "  xxxx         "))) (make-problem "19990723bDAH (9)" (quote ((4 6) (2 4 2) (1 2 2) (1 1 2 1) (1 1 4 1) (1 1 1 2 1) (1 6 1) (1 1 2 2) (1 1 2 2) (1 1 1 2) (2 2 1 2) (1 1 1 1) (4 4) (1 1 1 1) (1 1 1 1))) (quote ((10) (2 5) (1 1) (1 1) (2 5) (10) (2 1) (2 1 7) (1 5 1) (1 2 2 1) (1 4 5) (1 2 2) (2 2) (2 2) (6))) (quote (" xxxxxxxxxx    " "xx        xxxxx" "x           x  " "x           x  " "xx        xxxxx" " xxxxxxxxxx    " " xx   x        " "xx    x xxxxxxx" "x   xxxxx   x  " "x  xx xx    x  " "x  xxxx   xxxxx" "x   xx   xx    " "xx      xx     " " xx    xx      " "  xxxxxx       "))) (make-problem "19990728-DAH (10)" (quote ((5 5) (3 5 3) (2 4 3 2) (1 4 2 1) (1 1 5 1 1) (3 5 2) (4 4 1) (5 6) (1 1 1 1) (1 1 1 1) (1 7 2 1) (1 8 1 1) (2 8 2) (3 5 3) (5 5))) (quote ((5 5) (3 5 3) (2 4 2 2) (1 1 3 3 1) (1 2 2 3 1) (4 1 4) (5 1 4) (1 4 5) (1 4 4) (2 5 3) (1 1 3 1 1 1) (1 2 1 1 1) (2 3 1 2 2) (3 5 3) (5 5))) (quote ("xxxxx     xxxxx" "xxx  xxxxx  xxx" "xx  xxxx  xx xx" "x x  xxx  xxx x" "x xx  xx  xxx x" " xxxx  x  xxxx " " xxxxx  x xxxx " " x xxxx  xxxxx " " x  xxxx  xxxx " " xx xxxxx  xxx " "x x  xxx x  x x" "x xx   x  x   x" "xx xxx x  xx xx" "xxx  xxxxx  xxx" "xxxxx     xxxxx"))) (make-problem "19990917aMAT (11)" (quote ((2 3 2) (1 5 1) (2 1 2) (3 3) (1 1 1 1) (1 1 5 2 1) (1 3 4 1) (3 4) (2 2) (2 2) (2 2) (2 2) (11) (1 2 2 1) (3 3))) (quote (() (2 1) (1 1 1 1) (2 6 1 1) (1 2 9) (6 3) (2 1 1 1) (3 1 1) (2 1 1 1) (6 3) (1 2 9) (2 6 1 1) (3 1 1) (1 1 1) (2))) (quote ("               " "     xx      x " "    x  x    x x" "xx   xxxxxx x x" "x xx  xxxxxxxxx" " xxxxxx    xxx " "xx x x      x  " "xxx  x      x  " "xx x x      x  " " xxxxxx    xxx " "x xx  xxxxxxxxx" "xx   xxxxxx x x" "     xxx    x x" "    x  x     x " "     xx        "))) (make-problem "19990917bMAT (12)" (quote ((3 2) (4 2) (7 2) (1 11) (1 7) (1 1 4) (7 3) (2 1 2 3) (1 1 1 1 3) (7 3) (7 3) (3) (3) (5) (15))) (quote ((1 1) (1 1 1) (11 1) (3 2 2 1) (3 1 3 1) (3 2 2 1) (2 1 3 1) (2 2 1 1) (8 1) (2 1) (2 2) (3 2) (12) (15) (15))) (quote ("          x   x" "x         x   x" "xxxxxxxxxxx   x" "xxx   xx xx   x" " xxx  x xxx   x" " xxx  xx xx   x" "  xx  x xxx   x" "  xx  xx x    x" "  xxxxxxxx    x" "   xx         x" "   xx        xx" "   xxx       xx" "   xxxxxxxxxxxx" "xxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxx"))) (make-problem "19990917cMAT (13)" (quote ((1) (1 1) (11) (1 5 1) (1 7 1) (1 1) (1 1 5 1) (1 1) (1 1 5 1) (1 1) (1 1 5 1) (1 1) (1 1 5 1) (1 1) (11))) (quote (() () (13) (1 1) (1 1 1 1 1 1 1) (3 1) (4 1 1 1 1 1) (1 3 1 1 1 1 1) (4 1 1 1 1 1) (3 1 1 1 1 1) (1 1 1 1 1 1 1) (1 1) (13) () ())) (quote ("               " "               " "  xxxxxxxxxxxxx" "  x           x" "  x x x x x x x" "  xxx         x" " xxxx x x x x x" "x xxx x x x x x" " xxxx x x x x x" "  xxx x x x x x" "  x x x x x x x" "  x           x" "  xxxxxxxxxxxxx" "               " "               "))) (make-problem "19990917dMAT (14)" (quote ((9 3) (1 1 3) (1 1 3) (2 2 3) (3 3 5) (5 2 1 2) (5 1 1 1) (1 1 1 2 1) (1 1 1 1 1) (1 1 2 2) (1 1 1 5) (1 1 1 3) (1 3 1 3) (7 3) (9 3))) (quote ((1 1) (5 5) (1 4 2 2) (1 4 3) (1 2 1 5) (1 4 3) (1 4 2 2) (5 5) (1 5 1) (2 2) (5 1 5) (8 5) (5 5) (2 2) (5))) (quote ("x             x" "xxxxx     xxxxx" "x  xxxx xx   xx" "x   xxxx    xxx" "x    xx x xxxxx" "x   xxxx    xxx" "x  xxxx xx   xx" "xxxxx     xxxxx" "x    xxxxx    x" "    xx   xx    " "xxxxx  x  xxxxx" "xxxxxxxx  xxxxx" "xxxxx     xxxxx" "    xx   xx    " "     xxxxx     "))) (make-problem "19990917eMAT (15)" (quote ((3) (1 2) (2) (1) (2) (1) (5) (5 5) (7 5) (9 5) (1 1 5) (7 5) (1 1 3) (9 3) (7 3))) (quote ((2 2) (2 1 2) (3 1 2) (3 1 2) (3 1 2) (3 1 2) (1 3 1 2) (1 2 1 2) (1 2 2) (2) (2 6) (3 9) (11) (9) (6))) (quote ("         xx xx " "        xx x xx" "       xxx x xx" "       xxx x xx" "       xxx x xx" "       xxx x xx" " x     xxx x xx" "x       xx x xx" "x        xx xx " "xx             " " xx   xxxxxx   " "  xxx xxxxxxxxx" "    xxxxxxxxxxx" "      xxxxxxxxx" "      xxxxxx   "))) (make-problem "19990918aMAT (16)" (quote ((5) (3) (9) (2 2) (2 3 2) (2 1 1 1 2) (2 2 2 2) (2 3 2) (2 2 1 2 2) (2 2 2 2) (2 3 2) (2 2 2 2) (2 2 2 2) (3 3) (13))) (quote (() (11) (12) (2 2) (1 1 1 1) (1 1 2 2 2 1) (3 1 2 3 1) (3 2 2 1 1) (3 1 2 3 1) (1 1 2 2 2 1) (1 1 1 1) (2 2) (12) (11) ())) (quote ("               " "    xxxxxxxxxxx" "   xxxxxxxxxxxx" "  xx         xx" "  x     x   x x" "x x  xx xx xx x" "xxx x xx xxx  x" "xxx xx xx x   x" "xxx x xx xxx  x" "x x  xx xx xx x" "  x     x   x x" "  xx         xx" "   xxxxxxxxxxxx" "    xxxxxxxxxxx" "               "))) (make-problem "19990918bMAT (17)" (quote ((1 1) (5) (1 1 1 1 1) (2 5 1 1) (1 2 3 2 1) (2 3 3 1) (2 1 1 2) (4 4) (1 1) (4 4) (3 3 2) (2 2 2 2) (2 2 1) (3 1 1) (1))) (quote ((2 1) (2 2) (2 2 1 1) (2 1 2 1) (2 1 1 2) (3 5 2) (2 3 3) (4 1) (2 3 3) (3 5 2) (2 1 1 3) (3 1 2) (2 2) (4 3) ())) (quote ("    xx     x   " "     xx   xx   " "  xx  xx  x  x " "   xx  x xx  x " "    xx x x  xx " " xxx xxxxx xx  " "xx xxx   xxx   " " xxxx     x    " "xx xxx   xxx   " " xxx xxxxx xx  " "    xx x x  xxx" "  xxx  x xx    " "      xx  xx   " "   xxxx    xxx " "               "))) (make-problem "19990918cMAT (18)" (quote ((2 3) (2 3) (4) (2) (4) (15) (1 3 1 1) (1 5 1 1 1) (1 2 1 2 1 1) (1 3 3 1 1 1) (1 1 3 1 1 1) (1 1 1 1 1 1) (1 3 1 1) (15) (1 1))) (quote ((9) (1 2) (1 3 1) (1 1 3 1 1) (2 3 2 2) (2 5 1 2) (6 2 2) (4 3 1 1) (2 2 3 1) (1 1 1) (2 9) (1 1 1) (1 1 1 1 1 1) (1 2) (9))) (quote ("     xxxxxxxxx " "     x       xx" "     x  xxx  x " "x    x xxx x x " "xx   xxx xx xx " " xx xxxxx x xx " "  xxxxxx xx xx " "  xxxx xxx x x " " xx xx  xxx  x " " x   x       x " "xx   xxxxxxxxx " "x    x       x " "x    x x x x x " "     x       xx" "     xxxxxxxxx "))) (make-problem "19990918dMAT (19)" (quote ((1) (3) (1) (1) (5) (9) (13) (15) (1 1 1 1 1) (1 1 1 1 1 1 1) (1 1 1 1 1) (3 1 3) (3 1 3) (3 1 3) (15))) (quote ((1 1) (9) (2 4) (10) (3 1) (4 1 1) (1 4 1) (15) (1 4 1) (4 1 1) (3 1) (10) (2 4) (9) (1 1))) (quote ("       x      x" "      xxxxxxxxx" "      xx   xxxx" "     xxxxxxxxxx" "     xxx      x" "    xxxx x    x" " x  xxxx      x" "xxxxxxxxxxxxxxx" " x  xxxx      x" "    xxxx x    x" "     xxx      x" "     xxxxxxxxxx" "      xx   xxxx" "      xxxxxxxxx" "       x      x"))) (make-problem "19990918eMAT (20)" (quote (() (3) (8) (4 1 2) (1 1 1 1) (2 2 6) (12) (1 8) (1 11) (1 13) (3 5 3) (1 1 2 2) (2 1 2 2) (5 4) (6))) (quote ((6) (3 3) (1 1 2 2) (1 4 1) (2 5 2) (13) (1 5 2) (2 6 1) (11 1) (2 10) (1 5 2) (2 2 2 1) (3 3 2) (5) (3))) (quote ("     xxxxxx    " "    xxx   xxx  " "   x  x  xx xx " "   x  xxxx   x " "  xx xxxxx   xx" "  xxxxxxxxxxxxx" "  x   xxxxx  xx" " xx  xxxxxx   x" " xxxxxxxxxxx  x" " xx  xxxxxxxxxx" "  x  xxxxx  xx " "  xx xx xx   x " "   xxx  xxx xx " "        xxxxx  " "         xxx   "))) (make-problem "19990918fMAT (21)" (quote ((1 1) (2 1 1 2) (2 1 1 2) (3 3 3) (4 3 4) (15) (15) (15) (4 3 4) (3 3 3) (2 1 2) (2 1 2) (1 1 1) (1 1 1) (1))) (quote ((3) (7) (11) (14) (5) (3) (9) (12) (9) (3) (5) (14) (11) (7) (3))) (quote ("     xxx       " "   xxxxxxx     " " xxxxxxxxxxx   " "xxxxxxxxxxxxxx " "    xxxxx      " "     xxx       " " xxxxxxxxx     " "   xxxxxxxxxxxx" " xxxxxxxxx     " "     xxx       " "    xxxxx      " "xxxxxxxxxxxxxx " " xxxxxxxxxxx   " "   xxxxxxx     " "     xxx       "))) (make-problem "19990918gMAT (22)" (quote ((1 1) (1 2) (1 4) (1 5) (1 6) (8 2) (9) (10) (1 9) (1 10) (2 1 1 1) (1 1 1 1 1) (1 1 1 2 1) (2 1 1 1) (1))) (quote ((2) (1 1) (1 1) (7) (6) (5 3) (5) (15) (5) (6 1) (11) (7 2) (4 5) (4) (3))) (quote ("        xx     " "       x     x " "       x     x " "      xxxxxxx  " "     xxxxxx    " "     xxxxx xxx " "     xxxxx     " "xxxxxxxxxxxxxxx" "     xxxxx     " "    xxxxxx  x  " "  xxxxxxxxxxx  " "xxxxxxx xx     " " xxxx    xxxxx " "  xxxx         " "   xxx         "))) (make-problem "19990918hMAT (23)" (quote ((4) (6) (12 1) (12 1) (2 1 2 6) (6) (4) () (3) (2 2) (2 1 2) (1 13) (2 1 2 1 1) (2 2 2 2) (3))) (quote ((2 3) (3 2 2) (3 2 1 2) (2 1 3 1) (3 2 1 2) (2 5) (3 3) (3 1) (2 1) (5 1) (7 1 1) (7 3) (2 3 1) (2 3 3) (5 1 1))) (quote ("  xx      xxx  " "  xxx    xx xx " "  xxx   xx x xx" "  xx    x xxx x" "  xxx   xx x xx" "  xx     xxxxx " "  xxx     xxx  " "  xxx      x   " "  xx       x   " " xxxxx     x   " "xxxxxxx    x x " "xxxxxxx    xxx " "xx  xxx    x   " "xx  xxx    xxx " " xxxxx     x x "))) (make-problem "19990918iMAT (24)" (quote ((2 1) (1 2 1) (1 1 1) (1 1) (3) (7) (9) (2 8) (1 9) (1 9) (11) (11) (11) (9) (7))) (quote (() (6) (2 4) (2 7) (10) (11) (13) (1 11) (1 10) (1 10) (1 8) (1 6) (1) (2 1) (1))) (quote ("               " "       xxxxxx  " "      xx  xxxx " "     xx xxxxxxx" "     xxxxxxxxxx" "    xxxxxxxxxxx" "  xxxxxxxxxxxxx" " x  xxxxxxxxxxx" "x    xxxxxxxxxx" "x    xxxxxxxxxx" " x    xxxxxxxx " " x     xxxxxx  " "  x            " "xx x           " "  x            "))) (make-problem "19990918jMAT (25)" (quote ((3 3) (2 2 2 1) (1 3) (1) (1 4) (1 6) (1 9) (2 9) (2 10) (10 3) (13) (8 5) (10) (2 10) (1))) (quote ((3 3) (2 3 3) (2 4) (1 4) (2 5) (2 6) (12) (2 8) (2 9) (1 7 2) (2 8 1) (5 2 1) (8 1) (7 1) (6))) (quote ("      xxx   xxx" " xx    xxx xxx " "xx       xxxx  " "x        xxxx  " "xx       xxxxx " " xx     xxxxxx " "  xxxxxxxxxxxx " " xx   xxxxxxxx " "xx   xxxxxxxxx " "x   xxxxxxx xx " "xx  xxxxxxxx x " "    xxxxx xx x " "    xxxxxxxx x " "     xxxxxxx x " "      xxxxxx   "))) (make-problem "19990918kMAT (26)" (quote ((1 1 2) (3 1 2) (1 3 1 2 2) (7 1 1) (3 1 1) (3 1 1) (1 2 2) (6 2 3) (2 6 1) (1 3) (1 4) (6) (2 3) (2 3) (3))) (quote ((3) (2 2 1) (1 1 4) (6 8) (11) (6 5) (1 2 4) (2 1 3) (2 2) (3 2) (2 2) (1 1) (2 2) (2 2) (5))) (quote ("        xxx    " "  xx   xx     x" "   x   x   xxxx" "xxxxxx xxxxxxxx" " xxxxxxxxxxx   " "xxxxxx xxxxx   " "   x   xx xxxx " "  xx    x  xxx " "       xx   xx " "  xxx xx       " " xx  xx        " "x      x       " "xx     xx      " " xx   xx       " "  xxxxx        "))) (make-problem "19990918lMAT (27)" (quote ((5) (2 2) (2 5 2) (2 2 2 2) (4 1 4) (5 2 5) (1 1 3 1 1) (5 3 5) (1 2 2 1) (6 1 4) (4 2 5) (3 4 4) (11) (3 4) (5))) (quote ((5) (3 1 3) (4 1 4) (2 2 1 5) (1 8 2) (1 2 2 4) (1 1 1 3 1) (1 1 3 4 1) (1 1 4 4) (1 2 1 1 3) (1 3 2 4) (2 10) (4 1 4) (3 1 3) (5))) (quote ("     xxxxx     " "   xxx x xxx   " "  xxxx x xxxx  " " xx xx x xxxxx " " x xxxxxxxx xx " "x xx    xx xxxx" "x x    x  xxx x" "x x  xxx xxxx x" "x x xxxx   xxxx" "x xx  x   x xxx" " x xxx xx xxxx " " xx xxxxxxxxxx " "  xxxx x xxxx  " "   xxx x xxx   " "     xxxxx     "))) (make-problem "19990918mMAT (28)" (quote ((15) (5 1) (4 3 5) (1 4 3 2) (3 2 1) (1 2 1 1 1) (1 4 3 2) (7 7) (1 6 6) (1 6 6) (2 7) (12) (1 2 5) (3 6 4) (15))) (quote ((1 2 4 3) (1 1 1 2) (1 1 1 3 3) (1 2 7 1) (2 2 6 2) (10 1 2) (10 1 2) (3 2 1 2) (2 5 2 2) (1 3 6 2) (1 2 7 1) (1 1 8) (1 1 1 8) (1 2 9) (2 12))) (quote ("x xx  xxxx  xxx" "x x    x     xx" "x x  x xxx  xxx" "x xx  xxxxxxx x" "xx xx xxxxxx xx" "xxxxxxxxxx x xx" "xxxxxxxxxx x xx" "xxx     xx x xx" "xx xxxxx  xx xx" "x xxx xxxxxx xx" "x xx  xxxxxxx x" "x x    xxxxxxxx" "x x  x xxxxxxxx" "x xx  xxxxxxxxx" "xx xxxxxxxxxxxx"))) (make-problem "19990918nMAT (29)" (quote ((7) (1) (6) (7) (3 1) (3 1) (3 1) (8) (9) (8) (4 3) (2 3 2 2) (3 3 1 1 1) (1 1 1 1 1) (2 2))) (quote ((1 1) (1 1) (1 2) (1 1 1) (1 1 1) (1 2) (13) (11) (10) (2 4 2) (2 3 1 1) (8 1 1) (1 4 2) (5) (1 4))) (quote ("x           x  " "x           x  " "x           xx " "x          x  x" "x          x  x" "x           xx " "xxxxxxxxxxxxx  " "  xxxxxxxxxxx  " "  xxxxxxxxxx   " "  xx   xxxx xx " "  xx   xxx x  x" "  xxxxxxxx x  x" "   x   xxxx xx " "       xxxxx   " "        x xxxx "))) (make-problem "19990918oMAT (30)" (quote ((2) (3) (1 1) (1 2 4) (1 1 2 1) (1 1 2 1) (1 1 2 2 1) (1 2 2 3) (2 8) (14) (4 5 2) (2 2 3 2 1) (1 1 1 1 1 1) (1 1 1 1 1) (2 2))) (quote ((1 2) (5 1 4) (2 2 3) (3 2 2) (7 1 1) (4 1 1) (2 2) (9) (11) (1 4) (1 3 2) (6 1 1) (3 1 1) (4 2) (1 2))) (quote ("      x  xx    " "xxxxx  x xxxx  " "xx   xx  xxx   " " xxx     xx xx " "   xxxxxxx x  x" "      xxxx x  x" "         xx xx " "   xxxxxxxxx   " "   xxxxxxxxxxx " "   x    xxxx   " "   x    xxx xx " "    xxxxxx x  x" "       xxx x  x" "       xxxx xx " "        x xx   "))) (make-problem "19990920aMAT (31)" (quote ((4) (1 1) (1 1) (1 1) (3 1 1) (15) (1 9 1) (6 2 1) (5 3 5) (4 5 4) (4 5 4) (4 5 4) (5 3 5) (1 4 6) (15))) (quote ((10) (2 6 1) (11) (11) (4 3) (3 3 2) (2 5 1) (2 5 1) (2 5 1) (3 3 2) (9 3) (1 1 7) (1 1 7) (6 7) (10))) (quote ("     xxxxxxxxxx" "    xx xxxxxx x" "    xxxxxxxxxxx" "    xxxxxxxxxxx" "     xxxx   xxx" "     xxx xxx xx" "     xx xxxxx x" "     xx xxxxx x" "     xx xxxxx x" "     xxx xxx xx" "xxxxxxxxx   xxx" "x    x  xxxxxxx" "x    x  xxxxxxx" "xxxxxx  xxxxxxx" "     xxxxxxxxxx"))) (make-problem "19990920bMAT (32)" (quote ((2 1 1) (1 1 1 1) (3 1 1) (1 1 1 1) (1 1) (2 1 1 2) (3 3) (4 1 4) (13) (9) (1 1) (11) (11) (11) (9))) (quote ((1) (3) (1 3 4) (2 5 4) (1 4 2 4) (1 1 2 4) (1 1 2 4) (2 3 4) (2 1 2 4) (2 4) (4 2 4) (2 5 4) (3 4) (3) (1))) (quote ("       x       " "      xxx      " "   x  xxx xxxx " " xx  xxxxx xxxx" "x xxxx  xx xxxx" "x x     xx xxxx" " x   x  xx xxxx" "  xx   xxx xxxx" "xx   x  xx xxxx" "        xx xxxx" "  xxxx  xx xxxx" "xx   xxxxx xxxx" "      xxx xxxx " "      xxx      " "       x       "))) (make-problem "19990920cMAT (33)" (quote ((1) (5) (1 3) (5) (2 2) (5) (1 3) (5) (2 2) (5) (6 1) (8 1) (9 1) (10) (6 3))) (quote (() (2) (3) (3) (4) (5) (15) (1 3 7) (3 3 6) (14) (14) (1) (1 1) (1) ())) (quote ("               " "             xx" "            xxx" "            xxx" "           xxxx" "          xxxxx" "xxxxxxxxxxxxxxx" " x xxx xxxxxxx " " xxx xxx xxxxxx" " xxxxxxxxxxxxxx" " xxxxxxxxxxxxxx" "           x   " "          x x  " "           x   " "               "))) (make-problem "19990920dMAT (34)" (quote ((2) (3) (4 1) (3 1 2) (1 3 1 1) (1 1 1 1) (1 1 1 1) (1 1 2 1 1) (2 1 1 1 2) (1 4 1) (3 3) (6) (2) (2) (6))) (quote (() (2) (3) (4 1) (1 1 2) (3 1 1 1) (4 3 1 1) (1 1 2 1 4) (1 1 1 4) (2 1 1 2 1) (1 4 1 1) (3 3) (6) () ())) (quote ("               " "       xx      " "        xxx    " "    xxxx  x    " "   x    x xx   " "  xxx    x x  x" "  xxxx xxx x  x" "  x x xx x xxxx" "x x      x xxxx" "xx x    x xx  x" " x  xxxx  x   x" " xxx    xxx    " "   xxxxxx      " "               " "               "))) (make-problem "19990920eMAT (35)" (quote ((2) (1 1) (2 1) (15) (1 10) (1 2 2 1) (1 1 1 2 1 1) (1 4 2 1 1) (1 1 2 1 1) (1 1 1 1 1) (1 1 1 1) (1 1 2) (1 1) (1 1) (1 1))) (quote ((12) (1) (1 8) (1 2) (1 1 1) (5) (2) (8) (8 1) (1 2 1 1) (1 2 3 1) (1 2 1) (8) (2) (2))) (quote ("   xxxxxxxxxxxx" "   x           " "   x   xxxxxxxx" "   x  xx       " "   x x x       " "   xxxxx       " "   xx          " "  xxxxxxxx     " " xxxxxxxx x    " "x  xx    x x   " "x  xx xxx  x   " " x xx     x    " "  xxxxxxxx     " "   xx          " "   xx          "))) (make-problem "19990923-MAT (36)" (quote ((5 5) (4 5 4) (3 1 1 3) (2 9 2) (1 1 5 1 1) (9) (2 2) (2 2) (2 2) (2 2) (1 2 2 1) (2 2 2 2) (3 2 2 3) (4 4) (5 5))) (quote ((5 5) (4 4) (3 1 3) (2 3 3 2) (1 2 3 2 1 1) (1 4 3) (1 3 1) (1 3 1) (1 3 3) (1 5 2 1) (1 2 2 3 1) (2 3 1 2) (3 3) (4 4) (5 5))) (quote ("xxxxx     xxxxx" "xxxx       xxxx" "xxx     x   xxx" "xx xxx xxx   xx" "x xx xxx xx x x" " x xxxx   xxx  " " x xxx     x   " " x xxx  x      " " x xxx xxx     " " x xxxxx xx x  " "x xx xx   xxx x" "xx xxx     x xx" "xxx         xxx" "xxxx       xxxx" "xxxxx     xxxxx"))) (make-problem "19990924aMAT (37)" (quote ((1) (1 1 1 1) (3 1 1 3) (1 1 1 5 1 1) (8 2 1 1) (1 1 1 1 1 1 1) (1 1 1 1 1 1 1) (1 1 1 1 1 1 1) (1 1 1 1 1 1 1) (1 1 1 1 1 1 1) (1 1 2 1 2 1) (1 1 1 1 1 1) (1 1 1 1 1 1) (1 1 9 1) (1 3 2 2 3))) (quote ((12) (1) (13) (2 1 1) (13) (1 1 1) (8 2) (1 2 2) (1 1 4) (1 2 2) (8 2) (1 1) (13) (2 1) (13))) (quote ("   xxxxxxxxxxxx" "    x          " "  xxxxxxxxxxxxx" " xx x         x" "  xxxxxxxxxxxxx" "    x     x  x " "  xxxxxxxx   xx" " x xx        xx" "x  x      xxxx " " x xx        xx" "  xxxxxxxx   xx" "          x  x " "  xxxxxxxxxxxxx" " xx           x" "  xxxxxxxxxxxxx"))) (make-problem "19990924bMAT (38)" (quote ((15) (6 7) (6 7) (9 2 1) (7 2 1 1) (5 1 3 1 1) (5 1 4 1) (2 1 1 4 1) (2 2 4 1) (2 3 3 2) (1 2 2 1 2) (3 2 2 2 1) (3 1 2 2 1) (3 1 1 7) (3 1 1 7))) (quote ((9 5) (10 4) (7 1 4) (7) (8 1 2) (5 4) (1 12) (1 1) (15) (3 11) (4 5 2) (5 3 5) (3 1 4) (3 2 2) (15))) (quote ("xxxxxxxxx xxxxx" "xxxxxxxxxx xxxx" "xxxxxxx  x xxxx" "xxxxxxx        " "xxxxxxxx x   xx" "xxxxx   xxxx   " "x  xxxxxxxxxxxx" "x  x           " "xxxxxxxxxxxxxxx" "xxx xxxxxxxxxxx" "xxxx xxxxx   xx" "xxxxx xxx xxxxx" "xxx  x     xxxx" "xxx      xx  xx" "xxxxxxxxxxxxxxx"))) (make-problem "19990924cMAT (39)" (quote ((2) (2 2) (1 1 4) (1 2 1 2) (1 2 1 2) () (4 4) (7 1 2 1) (1 2 2 2 1) (1 4 1 2 1) (6 4) (6 1 1) (8 1 1) (8 1 1) (8 2 2))) (quote ((2 3) (2 1 5) (1 2 6) (1 2 9) (1 2 9) (1 2 6) (2 1 5) (2 3) (2) (1 1) (1 1 5) (5 5) (5 5) (1 1 5) (3 1))) (quote ("        xx  xxx" "   xx  x  xxxxx" "  x   xx xxxxxx" " x xx xxxxxxxxx" " x xx xxxxxxxxx" "  x   xx xxxxxx" "   xx  x  xxxxx" "       xx   xxx" "        xx     " "       x      x" "  x   x   xxxxx" "xxxxx xxxxx    " "xxxxx xxxxx    " "  x   x   xxxxx" "       xxx    x"))) (make-problem "19990924dMAT (40)" (quote ((3 3) (5 5) (7 7) (7 7) (7 7) (5 5) (3 3) (11) (6 1 2 2) (13) (7 5) (10 2) (1 1 1) (1 1 1) (1 1 1))) (quote ((3) (5 2) (12) (12) (12 1) (5 7) (3 5) (1 6) (3 5) (5 1 1 3) (12 1) (12) (7 2) (5 4) (3 4))) (quote ("  xxx          " " xxxxx xx      " "xxxxxxxxxxxx   " "xxxxxxxxxxxx   " "xxxxxxxxxxxx  x" " xxxxx xxxxxxx " "  xxx  xxxxx   " "       x xxxxxx" "  xxx  xxxxx   " " xxxxx x x xxx " "xxxxxxxxxxxx  x" "xxxxxxxxxxxx   " "xxxxxxx  xx    " " xxxxx  xxxx   " "  xxx   xxxx   "))) (make-problem "19990924eMAT (41)" (quote ((1 10) (8) (2 2 4) (1 1 4 3) (7 3) (1 6 3) (1 8 2) (2 9 2) (3 8 2) (4 7 1) (6 6 1) (7 3 1) (9 1 2) (10 2) (12 1))) (quote ((1 10) (8) (2 7) (1 1 6) (2 3 5) (1 5 5) (1 6 4) (2 8 3) (11 3) (12 2) (2 10 1) (3 6 1) (6 2 2) (9 2) (12 1))) (quote ("x    xxxxxxxxxx" "       xxxxxxxx" "  xx    xxxxxxx" "  x    x xxxxxx" "   xx xxx xxxxx" "x   xxxxx xxxxx" "x   xxxxxx xxxx" "xx xxxxxxxx xxx" "xxxxxxxxxxx xxx" "xxxxxxxxxxxx xx" "xx xxxxxxxxxx x" "xxx   xxxxxx  x" "xxxxxx   xx xx " "xxxxxxxxx   xx " "xxxxxxxxxxxx  x"))) (make-problem "19990925-MAT (42)" (quote ((9 4) (9 1 2) (10 2 1) (10 1 1) (6 1) (5 1 4) (4 1 4) (4 1 4) (4 4) (4 5) (2 6) (2 10) (1 1 10) (1 2 10) (2 11))) (quote ((11 2) (11 1 1) (10 1 1) (10 3) (6 1) (5 2 4) (4 1 4) (4 4) (4 4) (2 5) (1 6) (1 2 10) (1 1 11) (2 10) (4 10))) (quote ("xxxxxxxxxxx  xx" "xxxxxxxxxxx x x" "xxxxxxxxxx x x " "xxxxxxxxxx xxx " "xxxxxx        x" "xxxxx xx   xxxx" "xxxx x     xxxx" "xxxx       xxxx" "xxxx       xxxx" "  xx      xxxxx" " x       xxxxxx" "x xx xxxxxxxxxx" "x x xxxxxxxxxxx" "xx   xxxxxxxxxx" "xxxx xxxxxxxxxx"))) (make-problem "19990927aMAT (43)" (quote ((12) (12) (2 7) (2 5) (2 1) (2 7) (2 1 1 4) (2 1 1 2) (2 1 1 1 2) (2 1 1 2) (2 9 2) (2 9 2) (2 7) (2 5) (12))) (quote ((15) (15) (2 1) (2 1 3 1) (3 2 1 3 1) (4 1 1 5) (4 1 5) (7 1 5) (4 1 5) (4 3 5) (3 1 1 3 1) (2 1 3 1) (2) (5) (4))) (quote ("xxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxx" "xx            x" "xx   x   xxx  x" "xxx  xx x xxx x" "xxxx x x  xxxxx" "xxxx x    xxxxx" "xxxxxxx x xxxxx" "xxxx x    xxxxx" "xxxx xxx  xxxxx" "xxx   x x xxx x" "xx    x  xxx  x" "      xx       " "       xxxxx   " "        xxxx   "))) (make-problem "19990927bMAT (44)" (quote (() (2) (1 2) (2 2) (6 3) (3 3 1) (4 4 2) (15) (1 7 1) (3 5 3) (2 2 3 2 2) (1 1 1 3 1 1 1) (2 2 2 2) (3 3) ())) (quote ((2 2 3) (5 2 2) (4 1 1 1) (4 2 2) (1 3 3) (1 1 3) (1 5) (2 6) (2 7) (7) (5 3) (1 1 2 2) (3 1 1 1) (2 2 2) (2 3))) (quote ("   xx  xx xxx  " "   xxxxx xx xx " "    xxxx x x x " "    xxxx xx xx " "    x xxx xxx  " "  x x  xxx     " " x     xxxxx   " " xx   xxxxxx   " "  xx xxxxxxx   " "   xxxxxxx     " "    xxxxx xxx  " "    x  x xx xx " "     xxx x x x " "      xx xx xx " "       xx xxx  "))) (make-problem "19990927cMAT (45)" (quote (() (10) (2 1) (1 1) (1 1) (1 1) (2 2) (2 3 2) (13) (1 3 1) (13) (1 1 1 1 1 1 1 1) (2 1 1 1 1 1 2) (1 1 1 1 1 1 1 1) (15))) (quote ((4) (5 1 1) (5 2 2) (1 1 1 1 1) (1 1 2 2) (2 1 1 1 1) (1 5 2) (1 4 1 1) (1 5 2) (1 1 1 1 1) (1 1 2 2) (1 1 1 1 1) (1 5 2 2) (1 1 5 1 1) (2 4))) (quote ("           xxxx" "      xxxxx x x" "    xxxxx xx xx" "   x    x x x x" "  x     x xx xx" " xx     x x x x" " x     xxxxx xx" " x     xxxx x x" " x     xxxxx xx" " x      x x x x" " x      x xx xx" " x      x x x x" " x  xxxxx xx xx" " x x  xxxxx x x" " xx        xxxx"))) (make-problem "19990927dMAT (46)" (quote ((3) (2 2) (1 1) (1 1) (1 2) (3 3) (2 2 2) (1 2 6) (1 10) (2 2 2) (4 2) (2 2) (2) (2) (1))) (quote ((4 1) (2 3) (1 1) (1 1) (1 2) (4) (3 2) (2 3 6) (1 10) (2 2 2) (4 2) (2) (2) (2) (1))) (quote ("      xxxx x   " "     xx  xxx   " "     x    x    " "     x    x    " "      x  xx    " "      xxxx     " " xxx   xx      " "xx  xxx xxxxxx " "x    xxxxxxxxxx" "xx  xx xx      " " xxxx  xx      " "       xx      " "       xx      " "       xx      " "        x      "))) (make-problem "19990930-TPV (47)" (quote (() (13) (1 11) (13) (13) (13) (13) (13) (13) (2 4) (2 3 4) (2 3 4) (2 3 4) (1 3 4) ())) (quote (() (12) (1 11) (8) (8 4) (8 4) (8 4) (8) (8) (8) (13) (13) (13) (13) ())) (quote ("               " " xxxxxxxxxxxx  " " x xxxxxxxxxxx " " xxxxxxxx      " " xxxxxxxx xxxx " " xxxxxxxx xxxx " " xxxxxxxx xxxx " " xxxxxxxx      " " xxxxxxxx      " " xxxxxxxx      " " xxxxxxxxxxxxx " " xxxxxxxxxxxxx " " xxxxxxxxxxxxx " " xxxxxxxxxxxxx " "               "))) (make-problem "19991001aMAT (48)" (quote ((2) (4) (4 2) (2 5) (7) (2 4) (4) (6) (1 5) (5) (5 1) (6 2) (2 4 1) (3 4 2) (2 2 3))) (quote ((2) (2 1) (1 2) (4 1 1) (2 2 1 2) (6 1 2) (13) (9 1) (11) (8) (6) (4) (1) (2 2) (3))) (quote ("  xx           " "  xx x         " "  x xx         " " xxxx   x     x" "xx xx  x     xx" "xxxxxx x    xx " " xxxxxxxxxxxxx " "   xxxxxxxxx  x" "    xxxxxxxxxxx" "      xxxxxxxx " "        xxxxxx " "           xxxx" "              x" "          xx xx" "           xxx "))) (make-problem "19991001bMAT (49)" (quote ((2) (1 2) (1 1 2) (1 4) (1 3) (13) (3 11) (2 8 1) (3 7 2) (13) (3 2) (3 2) (3 2) (3 2) (2 1))) (quote ((3) (5) (6 3) (1 3) (2 5) (5 3) (5 3) (5 2) (2 5) (1 7) (11 1) (7 6) (3 1 1 1) (2 2) (3))) (quote ("      xxx      " "     xxxxx     " " xxxxxx xxx    " "     x   xxx   " "     xx xxxxx  " "     xxxxx xxx " "     xxxxx  xxx" "     xxxxx   xx" "  xx xxxxx     " "x  xxxxxxx     " "xxxxxxxxxxx x  " " xxxxxxx xxxxxx" "     xxx x x x " "     xx xx     " "      xxx      "))) (make-problem "19991001cMAT (50)" (quote ((3) (3) (3) (3) (9) (5 3) (3) (1 1 1) (1 1 1 1) (1 1 1 1 1) (1 1 1 1) (1 1 1 1 1) (1 1) (1 1) (2 2))) (quote (() (1) (1) (2 1 1) (1 1 1 1) (2 1 1 4) (3 3 1 1) (3 4 1 1) (3 3 1 1) (2 1 1 4) (1 1 1 1) (2 1 1) (1) (1) ())) (quote ("               " "   x           " "   x           " "   xx    x x   " "    x   x x   x" "    xx x x xxxx" "xxx xxx x x    " "xxx xxxx x x   " "xxx xxx x x    " "    xx x x xxxx" "    x   x x   x" "    xx   x x   " "     x         " "     x         " "               "))) (make-problem "19991001dMAT (51)" (quote ((1 3) (2 4) (1 2) (2 3) (1 4) (2 4) (4 4) (1 5) (2 1 2) (3 1 1 1) (1 1 1 1 1 1) (1 1 2) (3 2 1) (2 2 1) (1 3))) (quote ((4) (2 4 3) (3 1 2 2) (4) (2 1) () (1) () (5) (1 2) (4 1 1 2) (7 2 1) (9 3) (2 8) (2))) (quote ("         xxxx  " "xx    xxxx  xxx" " xxx  x xx  xx " "   xxxx        " "     xx   x    " "               " "          x    " "               " "        xxxxx  " "       x    xx " "    xxxx x x xx" " xxxxxxx  xx  x" "xxxxxxxxx   xxx" "xx xxxxxxxx    " "xx             "))) (make-problem "19991010bTPV (52)" (quote ((1) (1) (2 1) (1 4) (2 3 2 1) (6 6) (14) (12) (12) (11) (3 2) (3 2) (5) (3) (2 2))) (quote ((2 3) (6) (6) (8) (9) (6 2) (5 1 1) (1 4 3) (1 1 4 3) (1 1 7 2) (9 1) (7) (1 2) (3) (1))) (quote ("   xx xxx      " "    xxxxxx     " "     xxxxxx    " "    xxxxxxxx   " "    xxxxxxxxx  " "    xxxxxx xx  " "     xxxxx  x x" "  x   xxxx  xxx" "x x   xxxx xxx " " x x xxxxxxx xx" "  xxxxxxxxx   x" "   xxxxxxx     " "   x xx        " "    xxx        " "     x         "))) (make-problem "19991012-PIX (53)" (quote ((2) (2 2) (6 7) (3 1 1 4) (4 1 3) (11 3) (1 6 2) (2 2 3) (2 2 2) (2 2 2) (1 1 1) (2 2 2) (15) (15) (15))) (quote ((2 4 3) (5 1 3) (5 3) (5 3) (1 5 4) (2 10) (2 3) (2 3) (2 1 3) (1 1 4) (1 2 7) (4 3 3) (8 3) (8 4) (4 7))) (quote (" xx xxxx    xxx" " xxxxx x    xxx" "  xxxxx     xxx" "  xxxxx     xxx" "  x  xxxxx xxxx" "  xx xxxxxxxxxx" "     xx     xxx" "     xx     xxx" "  xx x      xxx" "  x  x     xxxx" "  x xx  xxxxxxx" "xxxx   xxx  xxx" "xxxxxxxx    xxx" "  xxxxxxxx xxxx" "  xxxx  xxxxxxx"))) (make-problem "19991112-SHE (54)" (quote ((9) (1 1) (1 1) (1 1) (1 1) (1 1) (1 1) (9) (11) (7 1) (11) (1) (9) (2 2 2 2) (13))) (quote (() (1) (3 2) (11 3) (1 4 1 1) (1 4 3) (1 4 3) (1 4 1 1) (1 4 3) (1 2 1 3) (1 2 3 1) (9 1 3) (3 2) (1) ())) (quote ("               " "              x" "        xxx  xx" "xxxxxxxxxxx xxx" "x      xxxx x x" "x      xxxx xxx" "x      xxxx xxx" "x      xxxx x x" "x      xxxx xxx" "x      xx x xxx" "x      xx xxx x" "xxxxxxxxx x xxx" "        xxx  xx" "              x" "               "))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/problems/k15x20 b/collects/games/paint-by-numbers/problems/k15x20
new file mode 100644
index 0000000000..fd45d43d91
--- /dev/null
+++ b/collects/games/paint-by-numbers/problems/k15x20
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 15x20") (define problems (list (make-problem "19990127aLLO (1)" (quote ((6 2) (1 1 6) (1 1 2 2) (2 2 1 1) (1 2 1) (6 1 4 1) (1 1 1 1 1) (1 1 1 1) (3 1 1 1 1 1) (1 1 1 1) (5 1 1 1 1) (1 1 1 1 1 1) (3 1 1 1 1) (1 1 1 1) (1 1 1 1 1 1) (6 1 1 1) (1 1 1 1 1) (1 2 2 1) (5 4 1) (1 1 2 1))) (quote ((4 2 1 1 3 2) (1 1 1 1 1 1 1) (1 1 1 3 1 1) (1 1 1 1 1 3) (1 1 1 1 3 1 1) (4 1 3) () (16) (2 2) (1 10 2) (2 2 2) (2 2 2) (1 13) (2) (18))) (quote ("xxxx xx x x   xxx xx" "x  x x  x x    x  x " "x    x  x xxx  x  x " "x    x    x x  x xxx" "x  x x  x xxx  x  x " "xxxx x        xxx   " "                    " "  xxxxxxxxxxxxxxxx  " " xx              xx " " x   xxxxxxxxxx   xx" "xx  xx            xx" "xx  xx           xx " " x   xxxxxxxxxxxxx  " " xx                 " "  xxxxxxxxxxxxxxxxxx"))) (make-problem "19990127bLLO (2)" (quote ((3) (5) (7) (1 7) (2 4) (7) (5) (5) (5) (8) (6 2) (2 3 1 1) (2 2 2) (8) (5) (5) (5) (7) (7) (5))) (quote ((1) (3) (2 2) (2 3 1) (1 2 3 1 2) (3 15) (4 6 8) (4 5 1 7) (11 8) (19) (4 2) (2) () () ())) (quote ("           x        " "          xxx       " "         xx xx      " "   xx    xxx x      " "  x xx   xxx x   xx " " xxx xxxxxxxxxxxxxxx" "xxxx xxxxxx xxxxxxxx" "xxxx xxxxx x xxxxxxx" "xxxxxxxxxxx xxxxxxxx" " xxxxxxxxxxxxxxxxxxx" "  xxxx           xx " "   xx               " "                    " "                    " "                    "))) (make-problem "19990421bMIJ (3)" (quote (() (1 1 1) (2 2) (1 1 1) (2 1) (1 1) (1 1) (1) (1) (1 1 1 1) (3 1 3) (3 4) (1 3) (1 2) (1 1 1) (2 1 1) (2 1) (1 1) (15) (15))) (quote ((2) (1 2) (3 1 2) (10) (3 1 2) (5 1 2) (1 1 1 2) (1 1 13) (1 1 3 2) (5 3 2) (2 2) (2 2) (2) (2) (2))) (quote ("                  xx" "              x   xx" "         xxx   x  xx" "          xxxxxxxxxx" "         xxx    x xx" " xxxxx         x  xx" "  x x x           xx" " x x   xxxxxxxxxxxxx" "  x   x    xxx    xx" " xxxxx    xxx     xx" "          xx      xx" "         xx       xx" "                  xx" "                  xx" "                  xx"))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/problems/k15x25 b/collects/games/paint-by-numbers/problems/k15x25
new file mode 100644
index 0000000000..701cbb3331
--- /dev/null
+++ b/collects/games/paint-by-numbers/problems/k15x25
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 15x25") (define problems (list (make-problem "19990804aVAC (1)" (quote ((3) (4) (4 4) (7 3) (7 3) (2 2 2) (1 2) (4 2) (7) (8) (2 1 3) (1 2) (2 2) (2 2) (1 1 1 2) (1 1 1 2) (1 1 1 1 2) (6 2 1) (1 1 1 4) (1 3 1 4) (1 1 3 1) (1 6 2) (1 4 2) (1 2 2) (1 2))) (quote ((2 5) (3 1 1) (4 6 1 1) (3 4 3 1 1) (3 2 1 1 2 1) (4 2 6 3) (7 3) (4 3 1) (3 3 3 1) (2 3 1 1) (3 3 2) (5 14 2) (7 10 1) (4 3) (3))) (quote ("   xx           xxxxx    " "   xxx           x   x   " "  xxxx      xxxxxx  x x  " "  xxx     xxxx   xxx x x " "  xxx    xx      x x xx x" "  xxxx  xx    xxxxxx xxx " "   xxxxxxx           xxx " "       xxxx         xxx x" "       xxx    xxx  xxx  x" "xx     xxx          x  x " "xxx     xxx           xx " "xxxxx xxxxxxxxxxxxxx xx  " " xxxxxxx  xxxxxxxxxx x   " "  xxxx            xxx    " "                 xxx     "))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/problems/k20x15 b/collects/games/paint-by-numbers/problems/k20x15
new file mode 100644
index 0000000000..ede59cd852
--- /dev/null
+++ b/collects/games/paint-by-numbers/problems/k20x15
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 20x15") (define problems (list (make-problem "19990524-KHO (1)" (quote ((1) (2 2 1) (1 1 2) (3 1) (5 2) (3 3 1) (8 1) (19) (1 14) (1 13) (13) (2 1 1 3 3) (4 1 1 2 2) (4 1 1 1 1) (2 1 1 2 2))) (quote ((2) (3 1 4) (1 4 4) (1 4 2) (3 2) (6 1) (12) (1 7 1) (1 8) (4) (4) (4) (5) (6 1) (8) (4) (6 1) (3 8) (3 5) (4))) (quote ("            xx " "     xxx x xxxx" " x   xxxx  xxxx" " x  xxxx    xx " "  xxx xx       " "   xxxxxx     x" "  xxxxxxxxxxxx " " x  xxxxxxx   x" " x    xxxxxxxx " "       xxxx    " "       xxxx    " "       xxxx    " "       xxxxx   " "       xxxxxx x" "       xxxxxxxx" "       xxxx    " "       xxxxxx x" "xxx    xxxxxxxx" "  xxx  xxxxx   " "    xxxx       "))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/problems/k20x20 b/collects/games/paint-by-numbers/problems/k20x20
new file mode 100644
index 0000000000..5f1f7548de
--- /dev/null
+++ b/collects/games/paint-by-numbers/problems/k20x20
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 20x20") (define problems (list (make-problem "19980407-KVL (1)" (quote ((10 8) (9 6) (5 5 5) (6 7 4) (6 9 3) (4 2 2 1 1 3) (5 3 2 1 1 3) (5 2 2 1 2 2) (4 2 2 1 2 2) (5 3 7 2) (5 1 2 1 3) (2 1 1 7 3) (3 1 6 4) (3 1 8 3) (2 6 5 2) (3 4 3 2) () (2 3 3 3 3 1) (2 3 3 3 3 1) ())) (quote ((16 2) (16 2) (11 2 1) (12 1 2) (5 2 2 2 2) (2 2 5 2) (2 5 2) (2 6 2 2) (2 4 2 2 2) (1 3 4 2) (8 3) (8 4 2) (1 3 1 5 2) (1 14 2) (2 2 1 5) (3 6 1 2 2) (4 3 1 2) (7 4 2) (16) (16 2))) (quote ("xxxxxxxxxxxxxxxx xx " "xxxxxxxxxxxxxxxx xx " "xxxxxxxxxxx xx x    " "xxxxxxxxxxxx  x  xx " "xxxxx xx xx   xx xx " "xx xx      xxxxx xx " "xx    xxxxx   xx    " "xx  xxxxxx    xx xx " "xx xxxx  xx  xx  xx " "x xxx     xxxx   xx " "  xxxxxxxx xxx      " "  xxxxxxxx xxxx  xx " "x xxx    x xxxxx xx " "x xxxxxxxxxxxxxx xx " "xx xx    x xxxxx    " "xxx xxxxxx x xx  xx " "xxxx   xxx  x    xx " "xxxxxxx   xxxx   xx " "xxxxxxxxxxxxxxxx    " "xxxxxxxxxxxxxxxx xx "))) (make-problem "19980501aGOS (2)" (quote ((7 7) (5 5) (3 3) (2 2) (2 2) (1 2 2 1) (1 4 4 1) (2 1 2 1) (2 2) () (2 2) (4 4) (1 1 4 1 1) (1 2 1 1 2 1) (1 3 3 1) (2 4 2) (2 2) (3 3) (5 5) (7 7))) (quote ((7 7) (5 5) (3 3) (2 1 2) (2 3 2) (1 2 1 1 1) (1 4 4 1) (2 1 1 1) (2 4) (1 1) (1 1) (2 4) (4 1 1) (1 2 1 4 1) (1 2 1 1 1) (2 3 2) (2 1 2) (3 3) (5 5) (7 7))) (quote ("xxxxxxx      xxxxxxx" "xxxxx          xxxxx" "xxx              xxx" "xx        x       xx" "xx        xxx     xx" "x     xx   x x     x" "x    xxxx  xxxx    x" "     xx x  x  x     " "      xx    xxxx    " "            x  x    " "            x  x    " "      xx    xxxx    " "     xxxx  x  x     " "x    xx x  xxxx    x" "x     xx   x x     x" "xx        xxx     xx" "xx        x       xx" "xxx              xxx" "xxxxx          xxxxx" "xxxxxxx      xxxxxxx"))) (make-problem "19980608-JEN (3)" (quote ((3 2 2 1) (1 2 2 2) (1 1) (1 1) (1 2 1) (1 2 1 3) (1 1 3 1 1) (1 1 2 1 1) (1 2 2 3) (1 1 1) (1 1 3) (2 1 3) (5 1 3) (1 5 1 3) (3 4 4) (4 1 4) (5 6) (7) (5) (4))) (quote ((15) (1 2 1) (2 2 1 2) (1 1 1 1 1) (1 1 1 2 1) (1 1 1 2) (1 1 1 1) (1 3 1 1) (1 1 2 2 1) (1 1 1 1 2) (1 3 1 3) (6 12) (1 1 4) (3 5) (5) (8) (8) (5) () ())) (quote ("xxxxxxxxxxxxxxx     " "x          xx x     " "xx    xx    x xx    " " x   x  x   x  x    " "x    x  x   xx x    " "x     x      x xx   " " x    x      x  x   " " x   xxx     x  x   " "x   x  xx    xx x   " "x   x   x     x xx  " " x   xxx      x  xxx" "xxxxxx  xxxxxxxxxxxx" "     x  x       xxxx" "      xxx      xxxxx" "              xxxxx " "          xxxxxxxx  " "         xxxxxxxx   " "          xxxxx     " "                    " "                    "))) (make-problem "19980907-KEV (4)" (quote (() (7 2 3) (8 2 4) (2 2 4 1 1) (2 2 4 4) (2 2 1 1 3) (2 2 4 1 2) (5 2 1 1 1 2) (4 5 3 2) () () (1 1 2 3 2) (1 1 2 4 3) (1 1 4 1 1 2) (1 1 4 4 2) (1 1 1 1 1 3 2) (1 1 1 4 1 2 2) (5 1 1 1 6) (3 2 3 5) ())) (quote ((2 7) (2 2 2) (4 2 4) (2 4 2) (2 2 7) (2 1) (8 6) (8 4 1) (2 1 4 1) (2 1 6) (6 1) (4 1 8) (4 1 2 2) (6 2 3) (1 3 3) (8 2) (2 2 2 2) (2 3 4 2) (3 3 2 4) (2 2 2))) (quote ("       xx  xxxxxxx  " "   xx  xx        xx " "  xxxx xx      xxxx " " xx  xxxx        xx " " xx   xx   xxxxxxx  " " xx               x " " xxxxxxxx    xxxxxx " " xxxxxxxx  xxxx x   " " xx     x  xxxx x   " " xx     x    xxxxxx " "   xxxxxx         x " " xxxx x    xxxxxxxx " " xxxx x    xx xx    " "   xxxxxx  xx xxx   " "        x   xxx xxx " " xxxxxxxx        xx " " xx xx       xx  xx " " xx xxx     xxxx xx " "  xxx xxx  xx  xxxx " "       xx  xx   xx  "))) (make-problem "19990126aLLO (5)" (quote ((1 1 1) (2 1 2) (1 2 1) (1 1 1) (2 2 2) (1 1 1) (1 1 1) (2 2 2) (1 1 1) () (11) (2 2 3) (2 4 1) (4 5 1) (17 1) (15 3) (13) (11) (2 7 2) (17))) (quote ((1) (4 2) (6 1) (2 2 5 1) (4 2 1 5 1) (4 1 6) (1 6) (3 1 6) (3 2 1 6) (4 1 6) (1 6) (2 4 1 6) (4 2 1 5 1) (2 5 1) (6 1) (4 1) (3 1) (2 2 2) (1 1 1) (5))) (quote ("                  x " "            xxxx  xx" "           xxxxxx  x" "xx        xx xxxxx x" " xxxx  xx x  xxxxx x" "    xxxx  x   xxxxxx" "          x   xxxxxx" "xxx       x   xxxxxx" "  xxx  xx x   xxxxxx" "    xxxx  x   xxxxxx" "          x   xxxxxx" "xx  xxxx  x   xxxxxx" " xxxx  xx x  xxxxx x" "          xx xxxxx x" "           xxxxxx  x" "            xxxx   x" "            xxx    x" "           xx xx  xx" "           x   x  x " "           xxxxx    "))) (make-problem "19990211aJAM (6)" (quote (() (4 4) (2 3 3 2) (1 2 2) (2 1 1 2) (2 2) (2) (4) (4) (4) (6) (6) (2) () (9) (11) (3 3) (2 5 3) (2 3 3) ())) (quote (() (2) (2 1) (1 2) (1 2 2) (2 2 2) (1 3) (2 2 2) (2 5 2 1) (7 2 2) (7 2 2) (2 5 2 2) (2 2 2 1) (1 2) (2 3) (1 2 3) (1 2 3) (2 2) (1 1) ())) (quote ("                    " "  xx                " " xx               x " " x               xx " " x  xx          xx  " " xx xx         xx   " "  x           xxx   " "  xx      xx  xx    " "   xx  xxxxx  xx x  " "      xxxxxxx xx xx " "      xxxxxxx xx xx " "   xx  xxxxx  xx xx " "  xx      xx  xx x  " "  x           xx    " " xx           xxx   " " x  xx         xxx  " " x  xx          xxx " " xx              xx " "  x               x " "                    "))) (make-problem "19990214bFRA (7)" (quote ((20) (1 3 3 2) (3 4 1 1) (3 4 1) (3 4 1) (3 5 2) (3 6 3) (3 7 4) (3 8 5) (1 7 6) (20) (20) (1 4 3 5 3) (1 3 3 3 3) (1 2 4 1 4) (1 1 1 5 5) (1 2 6 6) (1 3 6 6) (1 4 6 6) (20))) (quote ((20) (1 7 2 1) (1 7 3 5) (1 4 4) (1 7 5 3) (1 7 6 2) (12 1) (20) (2 15) (1 14) (1 5 6) (1 5 5) (2 5 4) (3 5 1) (2 5 4) (1 5 5) (1 5 6) (1 14) (2 15) (20))) (quote ("xxxxxxxxxxxxxxxxxxxx" "x xxxxxxx xx       x" "x xxxxxxx xxx  xxxxx" "x         xxxx  xxxx" "x xxxxxxx xxxxx  xxx" "x xxxxxxx xxxxxx  xx" "xxxxxxxxxxxx       x" "xxxxxxxxxxxxxxxxxxxx" "xx   xxxxxxxxxxxxxxx" "x     xxxxxxxxxxxxxx" "x      xxxxx  xxxxxx" "x       xxxxx  xxxxx" "xx       xxxxx  xxxx" "xxx       xxxxx    x" "xx       xxxxx  xxxx" "x       xxxxx  xxxxx" "x      xxxxx  xxxxxx" "x     xxxxxxxxxxxxxx" "xx   xxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxx"))) (make-problem "19990306-RMA (8)" (quote ((1) (8) (6 1 2) (5 2 2) (5 2 2) (5 3 3) (5 4 3) (2 1 1 5 1 3) (2 1 2 5) (1 1 1) (1) (1) (1) (1) (1) (1) (1) (1) (1 1) (3))) (quote ((1) (3) (3) (5) (5) (5) (4 1 2) (3 1 1) (2 2 1) (2 3 6) (1 10) (8) (1 3) (2 1) (2 1) (3 1) (6) (4) (3) (2))) (quote ("       x            " "     xxx            " "    xxx             " "   xxxxx            " "  xxxxx             " "  xxxxx             " " xxxx  x          xx" " xxx    x          x" " xx    xx          x" " xx  xxx     xxxxxx " " x xxxxxxxxxx       " "xxxxxxxx            " " x    xxx           " " xx     x           " "  xx   x            " "   xxx  x           " "    xxxxxx          " "     xxxx           " "      xxx           " "        xx          "))) (make-problem "19990412-RAB (9)" (quote (() (9) (1 1 1 1 3) (9 2) (1 3 1) (2 1 1 1 3) (2 1 1 1 2) (1 1 3) (9 3) (1 1 1 4 9) (12 1 1 1 1) (1 12) (3 1 1) (2 1 1 1 1 2) (2 1 1 2 1 2) (2 1 1) (14) (2 1 1 1 1 1 1) (12) ())) (quote ((3 3) (1 1 2 1 1) (3 2 3) (1 1 1 1) (10) (1 1 1 1 4) (3 2 10) (1 1 3 1 2) (11 2 1 1) (1 1 3 3) (4 2 7 1) (1 7 3) (6 1 2 1 1) (3 1 3) (1 1 1 1) (10) (1 1 1 1) (3 2 3) (1 1 2 1 1) (3 3))) (quote (" xxx    xxx         " " x x xx x x         " " xxx xx xxx         " " x x    x x         " " xxxxxxxxxx         " " x x    x x xxxx    " " xxx xx xxxxxxxxxx  " " x x    xxx x   xx  " " xxxxxxxxxxx xx x x " "  x x    xxx    xxx " "  xxxx xx xxxxxxx x " "   x xxxxxxx    xxx " "    xxxxxx x xx x x " "         xxx  x xxx " "         x x    x x " "         xxxxxxxxxx " "         x x    x x " "         xxx xx xxx " "         x x xx x x " "         xxx    xxx "))) (make-problem "19990806-ELS (10)" (quote (() (1 1) (2 2) (3 3) (4 4) (4 4) (4 4) (4 4) (4 4) (3 3) (5) (3) (5) (11) (2 1 1 2) (2 1 1 2) (1 2 2 1) (1 2 2 1) (4 4) ())) (quote (() (4) (4 4) (4 2 1) (4 2 1) (4 1 2) (4 1 2) (4 5) (6) (4) (6) (4 5) (4 1 2) (4 1 2) (4 2 1) (4 2 1) (4 4) (4) () ())) (quote ("                    " " xxxx               " "  xxxx         xxxx " "   xxxx       xx  x " "    xxxx     xx   x " "     xxxx    x   xx " "      xxxx   x  xx  " "       xxxx xxxxx   " "        xxxxxx      " "          xxxx      " "        xxxxxx      " "       xxxx xxxxx   " "      xxxx   x  xx  " "     xxxx    x   xx " "    xxxx     xx   x " "   xxxx       xx  x " "  xxxx         xxxx " " xxxx               " "                    " "                    "))) (make-problem "19990929-LSA (11)" (quote ((4 3) (3 5 2) (2 9 1) (1 11) (1 13) (1 2 1) (8 5) (9 5) (3 3 1 1) (4 4 2 2) (9 5) (9 5) (5 2 4) (6 5) (13) (4 4) (1 4 4 1) (2 8 1) (3 5 3) (5 7))) (quote ((5) (3) (2) (1 5) (11 4) (2 10 3) (3 2 8 2) (3 2 8 1) (4 2 9 1) (4 6 2 3) (12 1 2) (12 1 2) (4 2 3) (3 14) (3 2 9 1) (2 2 7 2) (4 7 2) (1 6 4) (2 1) (3 1))) (quote ("xxxxx               " "xxx                 " "xx                  " "x      xxxxx        " "    xxxxxxxxxxx xxxx" "   xx xxxxxxxxxx xxx" "  xxx xx xxxxxxxx xx" "  xxx xx  xxxxxxxx x" " xxxx xx xxxxxxxxx x" " xxxx xxxxxx xx xxx " " xxxxxxxxxxxx x  xx " " xxxxxxxxxxxx x  xx " " xxxx        xx xxx " "  xxx xxxxxxxxxxxxxx" "  xxx xx xxxxxxxxx x" "   xx xx  xxxxxxx xx" "    xxxx xxxxxxx  xx" "x     xxxxxx    xxxx" "xx                 x" "xxx                x"))) (make-problem "19991002aTPV (12)" (quote (() () (6) (2 2 3) (1 1 1 3 1) (1 2 1) (2 3 1) (3 4 1) (3 3 1) (4 3 4 1) (5 9) (6 7) (7 4) (6 3) (7 4) (7 3) (6 3) (6) () ())) (quote (() () (6) (10) (1 10) (1 8) (2 7) (1 7) (1 1 6) (3 2 4) (2 2 3) (1 1 1 2 1) (10 2) (9 3) (1 11) (1 7) (2 5) (6) () ())) (quote ("                    " "                    " "       xxxxxx       " "     xxxxxxxxxx     " "    x xxxxxxxxxx    " "   x     xxxxxxxx   " "   xx     xxxxxxx   " "  x        xxxxxxx  " "  x      x  xxxxxx  " "  xxx    xx   xxxx  " "  xx     xx    xxx  " "  x x  x  xx     x  " "  xxxxxxxxxx    xx  " "   xxxxxxxxx  xxx   " "   x  xxxxxxxxxxx   " "    x    xxxxxxx    " "     xx   xxxxx     " "       xxxxxx       " "                    " "                    "))) (make-problem "19991119bKHO (13)" (quote ((4 4) (3 2 1 1 1 1 1 3) (2 2 1 1 1 1 2) (2 1 1 1 1 1 1 2 2) (1 1 1 1 1 1 1 1 1 2) (1 1 1 1 1 2 1 2) (1 1 1 1 1 1 1 2 2) (2 13 3) (3 4) (3 4) (3 4) (3 4) (3 4) (4 5) (4 5) (5 6) (6 7) (8 9) (9 10) (20))) (quote ((20) (4 13) (2 1 1 12) (1 2 1 1 7) (2 1 2 5) (1 1 1 4) (1 1 2 3) (1 1 1 1 3) (1 2 2) (1 1 1 1 1) (1 1 2 2) (1 1 1 1 3) (1 2 3) (1 1 1 1 4) (1 2 1 5) (1 1 2 7) (1 5 12) (2 13) (20) (20))) (quote ("xxxxxxxxxxxxxxxxxxxx" "xxxx   xxxxxxxxxxxxx" "xx  x x xxxxxxxxxxxx" "x xx x x     xxxxxxx" " xx x xx       xxxxx" " x x   x        xxxx" "  x x xx         xxx" " x x x x         xxx" "    x xx          xx" " x x x x           x" "  x x xx          xx" " x x x x         xxx" "    x xx         xxx" " x x x x        xxxx" "  x xx x       xxxxx" " x x  xx     xxxxxxx" "x xxxxx xxxxxxxxxxxx" "xx     xxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxx"))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/problems/k20x25 b/collects/games/paint-by-numbers/problems/k20x25
new file mode 100644
index 0000000000..47ef9920c8
--- /dev/null
+++ b/collects/games/paint-by-numbers/problems/k20x25
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 20x25") (define problems (list (make-problem "19980620-KKA (1)" (quote (() (1) (3) () () () () (1) (2) (1) (2) (2) (2 1 1) (2 3 2) (1 2 4 1 1) (1 2 1 1 2 1) (1 1 2 2 1 1 2) (1 4 1 4 4) (20) () (11 1 3 1) (1 1 1 1 1 1 1 1) (1 3 1 2 1 3 1) (1 1 1 1 1 1 1) (1 3 1 1 1 1 3 1))) (quote ((1 1) (5 5) (1 1) (5 5) (1 2 2 1 1 1) (2 2 1 1 1) (6 1) (1 1 1 1 5) (2 2 1 1 1) (1 4 2 3 5) (4 2 1 1 1) (1 2 1 2) (3) (3 2 5) (2 4) (1 3 1) (5 1 1 1) (3 1 3) (2) (2 3 1))) (quote ("                  x x    " "              xxxxx xxxxx" "                  x x    " "              xxxxx xxxxx" "            x xx xx x x x" "            xx   xx x x x" "             xxxxxx x    " "  x           x x x xxxxx" " xx    xx     x   x x    " "  x     xxxx xx xxx xxxxx" "          xxxx xx x x x  " "             x   xx  x xx" "                xxx      " "             xxx xx xxxxx" "            xx xxxx      " "                  x xxx x" "              xxxxx x x x" "                xxx x xxx" "                 xx      " "                 xx xxx x"))) (make-problem "19991113cBAR (2)" (quote ((3 1 2 1) (2 3 2 3 2) (17 1) (19) (19) (12 7) (8 2 1 5) (4 1 5) (3 4) (6 7) (2 3 3 4) (3 2 2 4) (4 5) (4 6) (5 3 6) (4 5 6) (5 1 6) (4 5 5) (4 3 3 3) (2 3) (5 6) (8 7) (17) (13 1) (1 2 3 3))) (quote ((1 5 4 3 1) (21) (23) (7 1 7 5) (5 1 3 4) (7 2 1 4) (8 2 1 4) (7 2 1 2 3) (4 2 1 4) (7 4 3) (6 2 1 3) (4 2 1 2 3) (5 2 1 4) (7 2 1 5) (5 1 4 5) (8 7 3) (24) (22) (18) (1 4 2 6))) (quote ("   x xxxxx xxxx xxx x    " "  xxxxxxxxxxxxxxxxxxxxx  " " xxxxxxxxxxxxxxxxxxxxxxx " " xxxxxxx x  xxxxxxx xxxxx" "  xxxxx  x    xxx   xxxx " "xxxxxxx  xx       x  xxxx" "xxxxxxxx  xx      x  xxxx" "xxxxxxx   xx   x xx  xxx " "  xxxx        xx x   xxxx" "xxxxxxx       xxxx    xxx" " xxxxxx       xx x    xxx" "  xxxx    xx   x xx  xxx " "xxxxx     xx      x  xxxx" "xxxxxxx  xx       x xxxxx" " xxxxx   x   xxxx   xxxxx" "  xxxxxxxx xxxxxxx  xxx  " "xxxxxxxxxxxxxxxxxxxxxxxx " " xxxxxxxxxxxxxxxxxxxxxx  " "   xxxxxxxxxxxxxxxxxx    " "  x xxxx xx xxxxxx       "))) (make-problem "19991113gBAR (3)" (quote (() () (4 4) (8 6) (14 3) (3 7 2) (3 5 2) (6 2) (6 2) (6 3) (6 4) (8 4) (14) (14) (10 3) (14) (16) (18) (3 14) (3 14) (4 13) (4 11) (3 9) (12) (10))) (quote ((2 4) (3 6) (3 9) (4 5 4) (4 8 4) (4 10 2) (2 16 2) (3 18) (21) (21) (21) (21) (3 3 10) (3 13) (3 12) (2 12) (2 4 6) (3 4 4) (9) (7))) (quote ("  xx             xxxx    " "  xxx           xxxxxx   " "  xxx         xxxxxxxxx  " "  xxxx       xxxxx  xxxx " "   xxxx     xxxxxxxx xxxx" "   xxxx    xxxxxxxxxx  xx" "   xx xxxxxxxxxxxxxxxx xx" "   xxx xxxxxxxxxxxxxxxxxx" "    xxxxxxxxxxxxxxxxxxxxx" "    xxxxxxxxxxxxxxxxxxxxx" "    xxxxxxxxxxxxxxxxxxxxx" "    xxxxxxxxxxxxxxxxxxxxx" "    xxx    xxx xxxxxxxxxx" "   xxx      xxxxxxxxxxxxx" "  xxx       xxxxxxxxxxxx " "  xx       xxxxxxxxxxxx  " "  xx      xxxx  xxxxxx   " "  xxx    xxxx    xxxx    " "   xxxxxxxxx             " "    xxxxxxx              "))) (make-problem "19991115cBAR (4)" (quote ((8 9) (8 8) (4 2 5 1) (4 2 3 1) (4 2 2 1) (1 2 1 1 2) (1 3 1 3) (1 1 3) (1 1 3 2 1) (2 5 1 1) (4 2 4 1) (2 2 4 2 2) (1 1 5 3) (4 2 5) (2 4 4) (1 2 5 2) (4 3 1) (2 1 1 1) (1 2 2 1) (1 2 1 2 1) (2 1 1 4) (5 1 4) (4 2 4) (4 4 5) (5 7 5))) (quote ((13 10) (5 3 2 5) (5 1 1 4) (6 1 1 4) (2 2 1 1 2 1) (2 1 1 1 1) (3 2 1 1) (4 1 5 1 1) (2 3 3 2 2) (2 2 3 2 2) (9 3) (1 3 1 3 7) (3 7 2 1) (7 5) (5) (4 2 1 2 2) (3 1 2 6) (2 2 3 5) (2 3 5 5) (18 6))) (quote ("xxxxxxxxxxxxx  xxxxxxxxxx" "xxxxx    xxx    xx  xxxxx" "xxxxx     x     x    xxxx" "xxxxxx    x     x    xxxx" "xx   xx    x   x    xx  x" "xx    x    x   x   x     " "xxx   xx           x    x" "xxxx    x xxxxx   x     x" "   xx    xxx xxx xx    xx" "    xx  xx xxx xx      xx" "        xxxxxxxxx     xxx" "x       xxx x xxx xxxxxxx" "xxx      xxxxxxx xx     x" "xxxxxxx   xxxxx          " "xxxxx                    " "xxxx    xx   x    xx   xx" "xxx     x    xx    xxxxxx" "xx    xx    xxx     xxxxx" "xx   xxx   xxxxx    xxxxx" "xxxxxxxxxxxxxxxxxx xxxxxx"))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/problems/k20x30 b/collects/games/paint-by-numbers/problems/k20x30
new file mode 100644
index 0000000000..edcfacc2e4
--- /dev/null
+++ b/collects/games/paint-by-numbers/problems/k20x30
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 20x30") (define problems (list (make-problem "19991007aKHO (1)" (quote ((1 1 1 1 1) (1 5 1) (8 2) (8) (8) (2 2) (1 1) (2 2) (1 6 1) (2 8 2) (1 1) (1 2 2 1) (1 1 1 1 1 1) (1 4 4 1) (3 4 4 3) (1 1 1 1 1 1 1 1) (1 1 2 2 2 1 1) (2 1 4 1 2) (3 4 3) (1 4 1) (1 2 1) (2 2) (14) (2 2) (1 2 4 2 1) (1 6 1) (1 1) (14) (5 5) (7 7))) (quote ((3) (1 2 1) (1 1 2) (21) (1 3 3 3) (2 3 4 1 1 3) (4 1 1 2 1 1 1 3) (1 3 2 1 2 1 1 1 1 1) (4 2 4 3 1 2 1) (5 2 5 1 2 1) (4 2 5 1 2 1) (5 2 4 3 1 2 1) (4 2 1 2 1 1 1 1 1) (1 3 1 1 2 1 1 1 3) (1 3 4 1 1 3) (2 3 3 3) (21) (1 1 2) (1 2 1) (3))) (quote ("               xxx            " "              x  xx          x" "              x   x         xx" "         xxxxxxxxxxxxxxxxxxxxx" "x      xxx           xxx   xxx" " xx  xxx    xxxx      x x  xxx" "  xxxx   x x xx x     x x  xxx" "x xxx   xx x xx x     x  x x x" " xxxx   xx  xxxx xxx  x xx x  " "xxxxx   xx      xxxxx x xx x  " " xxxx   xx      xxxxx x xx x  " "xxxxx   xx  xxxx xxx  x xx x  " " xxxx   xx x xx x     x  x x x" "x  xxx   x x xx x     x x  xxx" "  x  xxx    xxxx      x x  xxx" " xx    xxx           xxx   xxx" "         xxxxxxxxxxxxxxxxxxxxx" "              x   x         xx" "              x  xx          x" "               xxx            "))) (make-problem "19991007bKHO (2)" (quote ((20) (1 1) (1 16 1) (1 16 1) (1 2 2 1) (1 2 2 1) (1 5 2 1) (1 2 6 1) (1 2 1 1 2 1) (1 2 3 2 1) (1 2 1 1 2 1) (1 3 1 1 1 1 1 2 1) (1 2 1 1 1 1 1 3 1) (1 16 1) (1 16 1) (1 1) (1 6 1) (1 2 1) (1 2 4 1) (1 2 2 4 1) (1 6 4 2 1) (1 6 4 1) (1 2 2 1) (1 2 1) (1 1 1 1) (1 1 1 1 1) (1 2 2 1 1 1) (1 1 1 1 1) (1 1 1 1) (20))) (quote ((30) (1 1) (1 13 2 1) (1 13 2 1) (1 2 1 1 2 6 1) (1 2 1 3 6 1) (1 2 1 1 1 2 2 1 1) (1 2 1 3 1 2 1 1) (1 2 4 2 1 1) (1 2 1 3 1 1 1) (1 2 2 2 1 2 1 1) (1 2 3 1 4 1) (1 2 1 1 2 1 4 1) (1 2 1 3 2 1 1 1) (1 2 1 1 2 2 1 1 2) (1 2 1 3 4 1 1 1) (1 13 4 1 1 2) (1 13 2 1 1 1) (1 1) (30))) (quote ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "x                            x" "x xxxxxxxxxxxxx     xx       x" "x xxxxxxxxxxxxx     xx       x" "x xx  x    x xx   xxxxxx     x" "x xx  x     xxx   xxxxxx     x" "x xx  x x  x xx     xx    x  x" "x xx     x  xxx x   xx    x  x" "x xx    xxxx xx x            x" "x xx     x  xxx x         x  x" "x xx      xx xx x   xx    x  x" "x xx        xxx x  xxxx      x" "x xx   x   x xx x  xxxx      x" "x xx   x    xxx     xx   x x x" "x xx   x   x xx   xx    x x xx" "x xx   x    xxx  xxxx    x x x" "x xxxxxxxxxxxxx  xxxx   x x xx" "x xxxxxxxxxxxxx   xx     x x x" "x                            x" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"))) (make-problem "19991113bBAR (3)" (quote ((6) (8) (10) (3 8) (1 2 1) (12) (1 1 1 3) (1 6 1) (1 2) (1 4 1) (3 2 4) (5 6) (7 8) (19) (4 10 3) (4 11 3) (17 1) (2 14 1) (1 2 1 1 1 1) (3 15) (14) (14) (13) (11) (4 5) (1 1 2 1) (4 4) (5 5) (6 6) (6 6))) (quote ((5) (5 1) (5 1) (3 6 1) (1 1 5 6) (4 7 3 4 2) (2 3 8 5 3) (4 1 1 7 11) (4 3 1 6 6 4) (4 1 1 2 5 6 4) (4 1 1 2 17) (4 3 1 5 5) (4 1 1 14) (3 2 7 11) (5 10 6 4) (3 8 6 4) (4 2 11) (6 6 3) (5 1 2) (7))) (quote ("               xxxxx          " "             xxxxx x          " "            xxxxx  x          " "   xxx     xxxxxx x           " "   x x    xxxxx xxxxxx        " "  xxxx xxxxxxx xxx xxxx     xx" " xx xxx   xxxxxxxx xxxxx   xxx" "xxxx x x   xxxxxxx xxxxxxxxxxx" "xxxx xxx x  xxxxxx xxxxxx xxxx" "xxxx x x xx  xxxxx xxxxxx xxxx" "xxxx x x xx  xxxxxxxxxxxxxxxxx" "xxxx xxx x   xxxxx xxxxx      " "xxxx x x    xxxxxxxxxxxxxx    " " xxx xx    xxxxxxx xxxxxxxxxxx" "  xxxxx xxxxxxxxxx xxxxxx xxxx" "      xxx xxxxxxxx xxxxxx xxxx" "          xxxx  xx xxxxxxxxxxx" "          xxxxxx xxxxxx    xxx" "           xxxxx   x        xx" "            xxxxxxx           "))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/problems/k25x15 b/collects/games/paint-by-numbers/problems/k25x15
new file mode 100644
index 0000000000..a60f7aceb6
--- /dev/null
+++ b/collects/games/paint-by-numbers/problems/k25x15
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 25x15") (define problems (list (make-problem "19990709-DAH (1)" (quote ((25) (1 1) (1 3 1) (1 3 1 3 1) (1 3 1 1 1 1) (1 1 1 1 1 1) (1 1 1 1 1 1) (1 1 1 3 1 1) (1 1 3 4 3 1) (1 3 4 4 4 1) (1 4 4 2 4 1) (1 4 2 2 1) (1 2 1) (1 1) (25))) (quote ((15) (1 1) (1 2 1) (1 4 1) (1 4 1) (1 8 1) (1 1 1) (1 1 2 1) (1 1 4 1) (1 1 4 1) (1 8 1) (1 1) (1 1) (1 2 1) (1 4 1) (1 4 1) (1 8 1) (1 1 1) (1 1 2 1) (1 1 4 1) (1 1 4 1) (1 8 1) (1 1) (1 1) (15))) (quote ("xxxxxxxxxxxxxxx" "x             x" "x         xx  x" "x        xxxx x" "x        xxxx x" "x   xxxxxxxx  x" "x   x         x" "x   x    xx   x" "x  x    xxxx  x" "x  x    xxxx  x" "x  xxxxxxxx   x" "x             x" "x             x" "x       xx    x" "x      xxxx   x" "x      xxxx   x" "x xxxxxxxx    x" "x x           x" "x x      xx   x" "x  x    xxxx  x" "x  x    xxxx  x" "x  xxxxxxxx   x" "x             x" "x             x" "xxxxxxxxxxxxxxx"))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/problems/k25x20 b/collects/games/paint-by-numbers/problems/k25x20
new file mode 100644
index 0000000000..a19adf8fb1
--- /dev/null
+++ b/collects/games/paint-by-numbers/problems/k25x20
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 25x20") (define problems (list (make-problem "19980410-GOS (1)" (quote (() (9) (3 1 4 3) (4 2 1 3 4) (2 1 11 4) (4 2 3 2 1 1) (1 1 2 1 3 1 2 1 1) (2 1 2 3 2 5) (5 5 5 1 1) (3 1 4 3 2 1 1 1) (5 4 3 4 5) (1 4 1 4 2) (1 1 2 1 1 1 2 2 1) (2 1 2 3 3 2 4) (3 3 1 1 1 3 3) (3 1 1 1 3) (2 3 2) (2 2) (7) ())) (quote ((7) (6 2) (2 3 1) (3 1 5) (1 7) (3 4) (2 11) (1 7 3) (1 2 3 1 3) (4 1 3 1 2) (1 1 1 3 1) (1 4 2 1 1 1) (7 4 3 1) (2 4 2 1 1 1) (4 1 3 1) (4 1 3 1 2) (1 2 3 1 3) (1 5 1 3) (2 11) (3 4) (9) (2 1 5) (1 1 1 3) (3 2 2) (7))) (quote ("       xxxxxxx      " "     xxxxxx  xx     " "    xx  xxx   x     " "   xxx  x xxxxx     " "   x xxxxxxx        " "  xxx      xxxx     " "  xx xxxxxxxxxxx    " "  x xxxxxxx   xxx   " " x xx   xxx x  xxx  " " xxxx x xxx  x   xx " " x  x   x    xxx  x " " x  xxxx xx  x  x x " " xxxxxxx xxxx xxx x " " xx xxxx xx  x  x x " " xxxx   x    xxx  x " " xxxx x xxx  x   xx " " x xx   xxx x  xxx  " "  x xxxxx x   xxx   " "  xx xxxxxxxxxxx    " "  xxx      xxxx     " "   xxxxxxxxx        " "   xx  x  xxxxx     " "    x  x  x xxx     " "     xxx  xx xx     " "       xxxxxxx      "))) (make-problem "19981116-JAM (2)" (quote ((10) (17) (4 9 3) (4 2 7 2 3) (3 4 5 3 4) (3 4 5 3 4) (4 4 5 3 4) (4 2 5 2 5) (5 6 6) (6 4 2 7) (12 11) (11 10) (10 9) (5 6 5 5) (5 13 4) (4 15 3) (1 1 13 1 1) (5 11 5) (5 5) (8 7))) (quote ((10) (15) (14 2) (14 3) (3 7 4) (2 3 4 1 3) (1 4 7 2) (1 5 8 1) (3 4 9 1) (4 10 1) (12 5 1) (11 5) (9 4) (9 4 1) (11 5 1) (4 3 5 1) (3 3 8 1) (2 5 8 1) (1 5 8 2) (2 5 1 3) (14 3) (14 2) (13 2) (14) (7))) (quote ("      xxxxxxxxxx    " "   xxxxxxxxxxxxxxx  " "  xxxxxxxxxxxxxx xx " "  xxxxxxxxxxxxxx xxx" " xxx    xxxxxxx xxxx" " xx xxx  xxxx  x xxx" " x xxxx   xxxxxxx xx" " x xxxxx  xxxxxxxx x" "xxx xxxx xxxxxxxxx x" "xxxx    xxxxxxxxxx x" "xxxxxxxxxxxx xxxxx x" "xxxxxxxxxxx  xxxxx  " "xxxxxxxxx     xxxx  " "xxxxxxxxx     xxxx x" "xxxxxxxxxxx  xxxxx x" "xxxx     xxx xxxxx x" "xxx xxx   xxxxxxxx x" "xx xxxxx  xxxxxxxx x" " x xxxxx xxxxxxxx xx" " xx     xxxxx  x xxx" " xxxxxxxxxxxxxx xxx " "  xxxxxxxxxxxxxx xx " "   xxxxxxxxxxxxx xx " "    xxxxxxxxxxxxxx  " "       xxxxxxx      "))) (make-problem "19981119-MSS (3)" (quote ((3 1 3 1 1 1 1 1) (1 1 1 1 1 2 1 1 1 1) (1 1 1 3 1 2 1 1) (1 1 1 1 1 1 1 1 2) () (3) (2 3) (2 2 3) (1 2 2 3) (1 2 2 3) (4 3 1 2) (1) (8 1) (16) (25) (24) (21) (16) (11) (4))) (quote ((1 1 4) (4 1 4) (1 1 4) (3 5) (4 5) (4 5) (1 4 5) (4 1 6) (1 4 5) (4 5) (3 1 5) (1 1 5 5) (3 5 6) (5 6) (4 1 6) (1 9) (1 5) (4 5) (6) (4 6) (6) (2 6) (1 1 5) (1 1 3) (1))) (quote ("x         x xxxx    " "xxxx      x xxxx    " "x         x xxxx    " "        xxx xxxxx   " "xxxx        xxxxx   " "       xxxx xxxxx   " "x      xxxx xxxxx   " "xxxx      x xxxxxx  " "x     xxxx   xxxxx  " "      xxxx   xxxxx  " " xxx      x  xxxxx  " "x x  xxxxx   xxxxx  " " xxx xxxxx   xxxxxx " "     xxxxx   xxxxxx " "xxxx      x  xxxxxx " " x        xxxxxxxxx " "  x           xxxxx " "xxxx          xxxxx " "              xxxxxx" "xxxx          xxxxxx" "              xxxxxx" " xx           xxxxxx" "x  x          xxxxx " " x x          xxx   " "              x     "))) (make-problem "19990126bLLO (4)" (quote ((2 2 1) (3 7) (6 2 2 5) (6 4 4 2) (4 4 1) (3 2 2 1) (2 3 2) (1 2 3) (1 3 2) (3 2 3) (5 1 3) (7 2) (7 2) (7 2) (5 2) (25) (3) (20 3) (3) (18 2))) (quote ((1 1 1) (1 1 1 1) (2 1 1 1) (3 1 1 1) (3 3 1 1 1) (2 6 1 1) (2 7 1 1) (1 7 1 1) (1 7 1 1) (6 1 1) (3 3 1 1 1) (2 1 1 1) (2 1 1 1) (3 1 1 1) (3 1 1 1) (3 3 1 1 1) (1 1 4 1 1 1) (3 5 1 1 1) (7 1 1) (1 2 1 1) (8 1) (4 6 5) (2 13) (1 2 10) (4 1))) (quote ("               x x x" "  x            x x x" " xx            x x x" " xxx           x x x" " xxx       xxx x x x" "  xx      xxxxxx x x" "  xx     xxxxxxx x x" "   x     xxxxxxx x x" "   x     xxxxxxx x x" "          xxxxxx x x" "      xxx  xxx x x x" "     xx        x x x" "    xx         x x x" "   xxx         x x x" "  xxx          x x x" "  xxx   xxx    x x x" " x x  xxxx     x x x" "xxx xxxxx      x x x" "xxxxxxx        x x  " " x xx          x x  " "xxxxxxxx       x    " "xxxx xxxxxx    xxxxx" " xx    xxxxxxxxxxxxx" "x xx     xxxxxxxxxx " "  xxxx         x    "))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/problems/k25x25 b/collects/games/paint-by-numbers/problems/k25x25
new file mode 100644
index 0000000000..6d96b217a9
--- /dev/null
+++ b/collects/games/paint-by-numbers/problems/k25x25
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 25x25") (define problems (list (make-problem "19980522-SDN (1)" (quote ((1 1) (1 1 1) (1 1 3) (3 3) (1 1 3) (1 1 5) (5) (7) (7) (9) (11) (15) (17) (19) (19) (19) (17) (15) (11) (7 1) (1 1 1) (3 1 1) (5 3) (9 1 1) (9 1 1))) (quote (() (5) (1 1) (5 3) (5) (7) (7) (9) (10 2) (13 2) (15 3) (18 4) (25) (18 4) (15 3) (13 2) (10 2) (9) (7) (7) (5) (3) (5) (1 1) (5))) (quote ("                         " " xxxxx                   " "x  x                     " " xxxxx       xxx         " "            xxxxx        " "           xxxxxxx       " "           xxxxxxx       " "          xxxxxxxxx      " "         xxxxxxxxxx    xx" "       xxxxxxxxxxxxx   xx" "     xxxxxxxxxxxxxxx  xxx" "  xxxxxxxxxxxxxxxxxx xxxx" "xxxxxxxxxxxxxxxxxxxxxxxxx" "  xxxxxxxxxxxxxxxxxx xxxx" "     xxxxxxxxxxxxxxx  xxx" "       xxxxxxxxxxxxx   xx" "         xxxxxxxxxx    xx" "          xxxxxxxxx      " "           xxxxxxx       " "           xxxxxxx       " "            xxxxx        " "             xxx         " "                    xxxxx" "                   x  x  " "                    xxxxx"))) (make-problem "19980909-YEN (2)" (quote ((10 10) (8 5 8) (5 9 5) (4 7 4 4) (3 7 4 3) (2 7 3 2) (2 8 4 2) (2 9 5 2) (1 16 1) (1 15 1) (14) (12) (11) (9) (7) (1 5 1) (1 4 1) (2 3 1 2) (2 3 3 2) (2 3 5 2) (3 2 3 3) (4 2 1 4) (5 5) (8 8) (10 10))) (quote ((10 10) (8 5 8) (5 9 5) (4 15 4) (3 17 3) (2 19 2) (2 13 1 2) (2 12 2) (1 12 1) (1 12 1) (4 7 1) (3 6 3) (2 4 5) (3 4 3) (4 5 1) (1 8 1) (1 8 1) (2 5 2) (2 2) (2 2) (3 3) (4 4) (5 5) (8 8) (10 10))) (quote ("xxxxxxxxxx     xxxxxxxxxx" "xxxxxxxx  xxxxx  xxxxxxxx" "xxxxx   xxxxxxxxx   xxxxx" "xxxx xxxxxxxxxxxxxxx xxxx" "xxx xxxxxxxxxxxxxxxxx xxx" "xx xxxxxxxxxxxxxxxxxxx xx" "xx xxxxxxxxxxxxx     x xx" "xx xxxxxxxxxxxx        xx" "x xxxxxxxxxxxx          x" "x xxxxxxxxxxxx          x" " xxxx xxxxxxx      x     " " xxx   xxxxxx     xxx    " " xx     xxxx     xxxxx   " " xxx   xxxx       xxx    " " xxxx xxxxx        x     " "x xxxxxxxx              x" "x xxxxxxxx              x" "xx  xxxxx              xx" "xx                     xx" "xx                     xx" "xxx                   xxx" "xxxx                 xxxx" "xxxxx               xxxxx" "xxxxxxxx         xxxxxxxx" "xxxxxxxxxx     xxxxxxxxxx"))) (make-problem "19990924-VAL (3)" (quote (() () (1) (1) (1) (10) (12) (6 3 3) (3 2 1 1 1 2) (2 1 1 1 1 2 1) (1 3 3 4) (6 7) (7 2 4) (2 7 2 1) (2 10 1) (6 8) (5 7) (2 7 2) (1 7 1) (11) (4 4) (4 4) (2 6) (1 5) (5))) (quote (() () () () () (3 4) (3 7) (3 3 5) (3 8 4) (4 14) (5 11 1) (3 5 8) (4 3 7 3) (1 3 15) (5 14) (3 2 10) (2 9 4) (3 11) (3 3 3) (3 5) () () () () ())) (quote ("                         " "                         " "                         " "                         " "                         " "        xxx xxxx         " "       xxx xxxxxxx       " "      xxx xxx  xxxxx     " "     xxx xxxxxxxx  xxxx  " "     xxxx xxxxxxxxxxxxxx " "     xxxxx xxxxxxxxxxx  x" "     xxx  xxxxx  xxxxxxxx" "   xxxx xxx  xxxxxxx  xxx" "  x  xxx  xxxxxxxxxxxxxxx" "     xxxxx xxxxxxxxxxxxxx" "     xxx  xx  xxxxxxxxxx " "     xx xxxxxxxxx  xxxx  " "     xxx xxxxxxxxxxx     " "      xxx xxx  xxx       " "       xxx xxxxx         " "                         " "                         " "                         " "                         " "                         "))) (make-problem "19991020aSHE (4)" (quote ((20 2) (3 14 2) (2 11 2) (1 9 3) (2 9 3) (3 9 4) (12 4) (8 5) (7 6) (6 7) (5 8) (5 9) (7 9) (7 6) (7 4) (3 2 3) (2 4 3) (3 3 3) (1 6) (2 6) (1 6) (2 1 6) (2 1 8) (1 11) (13))) (quote ((25) (3 14 1 2 1) (2 11 1 2) (1 9 3) (2 10 2) (3 6 3 3) (9 4 4) (8 2 3) (7 2 5) (7 9) (7 9) (7 7) (6 7) (5 5) (4 4) (3 3) (2 6) (2 6) (1 6) (1 7) (7) (9) (10) (13) (13))) (quote ("xxxxxxxxxxxxxxxxxxxxxxxxx" "xxx xxxxxxxxxxxxxx x xx x" "xx   xxxxxxxxxxx x     xx" "x     xxxxxxxxx       xxx" "xx   xxxxxxxxxx        xx" "xxx xxxxxx  xxx       xxx" "xxxxxxxxx   xxxx     xxxx" "xxxxxxxx       xx     xxx" "xxxxxxx         xx  xxxxx" "xxxxxxx         xxxxxxxxx" "xxxxxxx         xxxxxxxxx" "xxxxxxx           xxxxxxx" "xxxxxx            xxxxxxx" "xxxxx            xxxxx   " "xxxx            xxxx     " "xxx            xxx       " "xx         xxxxxx        " "xx        xxxxxx         " "x        xxxxxx          " "x       xxxxxxx          " "       xxxxxxx           " "     xxxxxxxxx           " "   xxxxxxxxxx            " "xxxxxxxxxxxxx            " "xxxxxxxxxxxxx            "))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/problems/k25x30 b/collects/games/paint-by-numbers/problems/k25x30
new file mode 100644
index 0000000000..febd796550
--- /dev/null
+++ b/collects/games/paint-by-numbers/problems/k25x30
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 25x30") (define problems (list (make-problem "19980714-GAS (1)" (quote (() (3) (4) (4) (5) (4) (3) (4 2 4) (8 8) (20) (21) (20) (20) (20) (19) (19) (19) (19) (20) (21) (21) (22) (22) (20) (18) (16) (14) (3 3) () ())) (quote (() (8) (13) (15) (17) (18) (20) (21) (21) (21) (19) (19) (4 18) (5 18) (5 19) (5 19) (4 21) (2 21) (21) (20) (6 8) (4 6) (2 4) (2) ())) (quote ("                              " "            xxxxxxxx          " "          xxxxxxxxxxxxx       " "         xxxxxxxxxxxxxxx      " "        xxxxxxxxxxxxxxxxx     " "        xxxxxxxxxxxxxxxxxx    " "       xxxxxxxxxxxxxxxxxxxx   " "       xxxxxxxxxxxxxxxxxxxxx  " "       xxxxxxxxxxxxxxxxxxxxx  " "       xxxxxxxxxxxxxxxxxxxxx  " "        xxxxxxxxxxxxxxxxxxx   " "        xxxxxxxxxxxxxxxxxxx   " "    xxxx xxxxxxxxxxxxxxxxxx   " "   xxxxx xxxxxxxxxxxxxxxxxx   " "  xxxxx xxxxxxxxxxxxxxxxxxx   " " xxxxx  xxxxxxxxxxxxxxxxxxx   " " xxxx  xxxxxxxxxxxxxxxxxxxxx  " " xx    xxxxxxxxxxxxxxxxxxxxx  " "       xxxxxxxxxxxxxxxxxxxxx  " "       xxxxxxxxxxxxxxxxxxxx   " "        xxxxxx    xxxxxxxx    " "        xxxx       xxxxxx     " "         xx         xxxx      " "                     xx       " "                              "))) (make-problem "19980716cGAS (2)" (quote (() (7) (3 3) (2 3 2) (2 3 3 2) (1 2 2 1) (1 2 2 1) (1 1 1 1) (1 1 1 1) (1 1 7 1 1) (1 2 2 1) (3 3) (2 2) (2 5 2) (1 4 4 1) (2 5 5 2) (1 2 7 2 1) (1 3 5 3 1) (1 6 6 1) (1 5 5 1) (1 1 2 2 1 1) (1 5 5 1) (1 6 6 1) (2 3 5 3 2) (1 2 7 2 1) (2 5 5 2) (2 4 4 2) (2 5 2) (3 3) (9))) (quote (() () (9) (3 3) (2 2) (9 5 2) (2 1 4 4 2) (2 6 5 5 1) (1 2 1 2 7 2 2) (2 2 1 3 5 3 1) (1 1 1 6 6 1) (1 2 1 5 5 1) (1 1 1 1 2 2 1 1) (1 2 1 5 5 1) (1 1 1 6 6 1) (2 2 1 3 5 3 1) (1 2 1 2 7 2 2) (2 6 5 5 1) (2 1 4 4 2) (9 5 2) (2 2) (3 3) (9) () ())) (quote ("                              " "                              " "               xxxxxxxxx      " "             xxx       xxx    " "            xx           xx   " "    xxxxxxxxx     xxxxx   xx  " "   xx      x    xxxx xxxx  xx " "  xx  xxxxxx   xxxxx xxxxx  x " "  x  xx   x   xx xxxxxxx xx xx" " xx xx   x    xxx xxxxx xxx  x" " x  x    x   xxxxxx   xxxxxx x" " x xx    x   xxxxx     xxxxx x" " x x     x   x  xx     xx  x x" " x xx    x   xxxxx     xxxxx x" " x  x    x   xxxxxx   xxxxxx x" " xx xx   x    xxx xxxxx xxx  x" "  x  xx   x   xx xxxxxxx xx xx" "  xx  xxxxxx   xxxxx xxxxx  x " "   xx      x    xxxx xxxx  xx " "    xxxxxxxxx     xxxxx   xx  " "            xx           xx   " "             xxx       xxx    " "               xxxxxxxxx      " "                              " "                              "))) (make-problem "19980802-JON (3)" (quote (() (1) (3) (4) (4) (4) (3) (2) (7 6) (18) (20) (22) (21) (20) (19) (19) (19) (19) (19) (20) (21) (21) (21) (19) (19) (17) (15) (13) (4 4) ())) (quote (() (10) (13) (16) (18) (19) (20) (21) (21) (21) (21) (19) (19) (3 19) (25) (4 21) (4 21) (4 21) (2 20) (19) (5 7) (3 5) (1 2) () ())) (quote ("                              " "           xxxxxxxxxx         " "          xxxxxxxxxxxxx       " "         xxxxxxxxxxxxxxxx     " "        xxxxxxxxxxxxxxxxxx    " "        xxxxxxxxxxxxxxxxxxx   " "        xxxxxxxxxxxxxxxxxxxx  " "        xxxxxxxxxxxxxxxxxxxxx " "        xxxxxxxxxxxxxxxxxxxxx " "        xxxxxxxxxxxxxxxxxxxxx " "        xxxxxxxxxxxxxxxxxxxxx " "         xxxxxxxxxxxxxxxxxxx  " "         xxxxxxxxxxxxxxxxxxx  " "     xxx xxxxxxxxxxxxxxxxxxx  " "    xxxxxxxxxxxxxxxxxxxxxxxxx " "   xxxx xxxxxxxxxxxxxxxxxxxxx " "  xxxx  xxxxxxxxxxxxxxxxxxxxx " " xxxx   xxxxxxxxxxxxxxxxxxxxx " "  xx    xxxxxxxxxxxxxxxxxxxx  " "        xxxxxxxxxxxxxxxxxxx   " "         xxxxx     xxxxxxx    " "          xxx       xxxxx     " "           x         xx       " "                              " "                              "))) (make-problem "19990723-KHO (4)" (quote ((8 8) (6 6) (4 5 4) (3 7 3) (2 9 2) (1 6 1 1) (1 5 3 1) (4 4) (4 4) (2 4) (3) (3) (3 3) (5 5) (13) (15) (3 9 1) (3 9 3) (3 2 1 4) (3 1 2 3 3) (3 5 5 1) (3 11 1) (3 9 3) (1 3 7 3 1) (1 3 3 1) (2 11 2) (3 8 3) (4 4) (6 6) (8 8))) (quote ((7 7) (5 5) (4 4) (3 5 3) (2 7 2) (2 9 2) (1 3 3 1) (1 4 3 3 1 3 1) (6 6 3 3) (7 6 4 2) (7 7 5 2) (5 9 5 2) (4 5 5 4 2) (3 5 6 1 3 2) (3 4 6 5 2) (2 3 6 5 2) (2 4 1 3 2) (1 3 5 3 1) (1 2 4 3 1) (2 1 3 2 2) (2 1 3 2) (3 3) (4 4) (5 5) (7 7))) (quote ("xxxxxxx                xxxxxxx" "xxxxx                    xxxxx" "xxxx                      xxxx" "xxx              xxxxx     xxx" "xx              xxxxxxx     xx" "xx             xxxxxxxxx    xx" "x             xxx     xxx    x" "x    xxxx    xxx xxx x xxx   x" "    xxxxxx   xxxxxx xxx xxx   " "   xxxxxxx  xxxxxx  xxxx xx   " "  xxxxxxx  xxxxxxx xxxxx xx   " "  xxxxx  xxxxxxxxx xxxxx xx   " "  xxxx xxxxx  xxxxx xxxx xx   " "  xxx xxxxx xxxxxx x xxx xx   " "  xxx xxxx  xxxxxx xxxxx xx   " "   xx xxx   xxxxxx xxxxx xx   " "    xx       xxxx x xxx xx    " "x            xxx xxxxx xxx   x" "x             xx xxxx xxx    x" "xx             x xxx  xx    xx" "xx              x   xxx     xx" "xxx                        xxx" "xxxx                      xxxx" "xxxxx                    xxxxx" "xxxxxxx                xxxxxxx"))) (make-problem "19990920-LLO (5)" (quote ((6) (4 4) (3 3) (2 2) (2 2 2) (2 2 2) (1 2 1) (2 2 2) (1 2 1) (1 4 1) (22) (3 3) (22) (22) (1 1) (1 5 1) (2 2) (20) (12) (8 5) (4 7) (1 2 4 4) (1 2 3 3) (1 2 3 5) (1 2 3 3) (1 2 4 4) (1 2 7) (1 2 5) (1 2) (1 2))) (quote ((4 5) (3 4 2) (2 4 1) (2 4 1) (2 1 2 1) (1 1 2 2) (2 1 1 2 2) (1 2 1 2 3) (2 2 1 2 3) (2 2 2 2 13) (1 4 2 4) (1 3 2 13) (2 2 2 13) (2 1 2 3) (1 1 2 1 3) (2 1 2 1 2) (1 1 2 1 2 5) (2 1 2 1 1 7) (2 4 1 1 9) (2 4 1 3 3) (3 4 2 2 1 2) (4 5 3 1 3) (9) (7) (5))) (quote ("       xxxx xxxxx             " "     xxx  xxxx  xx            " "    xx    xxxx   x            " "   xx     xxxx   x            " "  xx      x xx   x            " "  x       x xx   xx           " " xx x     x xx   xx           " " x  xx    x xx   xxx          " "xx   xx   x xx   xxx          " "xx    xx xx xx   xxxxxxxxxxxxx" "x      xxxx xx   xxxx         " "x       xxx xx   xxxxxxxxxxxxx" "xx       xx xx   xxxxxxxxxxxxx" "xx        x xx   xxx          " " x        x xx x xxx          " " xx       x xx x xx           " "  x       x xx x xx  xxxxx    " "  xx      x xx x x  xxxxxxx   " "   xx     xxxx x x xxxxxxxxx  " "    xx    xxxx   x xxx   xxx  " "     xxx  xxxx  xx xx  x  xx  " "       xxxx xxxxx  xxx x xxx  " "                   xxxxxxxxx  " "                    xxxxxxx   " "                     xxxxx    "))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/problems/k25x35 b/collects/games/paint-by-numbers/problems/k25x35
new file mode 100644
index 0000000000..832720cfe4
--- /dev/null
+++ b/collects/games/paint-by-numbers/problems/k25x35
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 25x35") (define problems (list (make-problem "19981015bGAS (1)" (quote (() (21) (1 1) (1 15 1) (1 1 1 1) (1 1 1 1) (1 15 1) (1 1) (1 1) (1 3 3 3 3 1) (1 1 1 1 1 1 1 1 1 1) (1 3 3 3 3 1) (1 1) (1 3 3 3 3 1) (1 1 1 1 1 1 1 1 1 1) (1 3 3 3 3 1) (1 1) (1 3 3 3 3 1) (1 1 1 1 1 1 1 1 1 1) (1 3 3 3 3 1) (1 1) (1 3 3 3 3 1) (1 1 1 1 1 1 1 1 1 1) (1 3 3 3 3 1) (1 1) (1 3 3 3 3 1) (1 1 1 1 1 1 1 1 1 1) (1 3 3 3 1 1 1) (1 1 1 1) (1 7 3 1 1 1) (1 1 1 1 1 1 1 1) (1 7 3 3 1) (1 1) (21) ())) (quote (() () (33) (1 1) (1 1) (1 4 3 3 3 3 3 3 1) (1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1) (1 1 1 3 3 3 3 3 1 1 1) (1 1 1 1 1 1) (1 1 1 3 3 3 3 3 1 1 1) (1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1) (1 1 1 3 3 3 3 3 3 1) (1 1 1 1) (1 1 1 3 3 3 3 3 3 1) (1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1) (1 1 1 3 3 3 3 3 3 1) (1 1 1 1) (1 1 1 3 3 3 3 7 1) (1 1 1 1 1 1 1 1 1 1 1 1 1 1) (1 4 3 3 3 3 7 1) (1 1) (1 1) (33) () ())) (quote ("                                   " "                                   " " xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx " " x                               x " " x                               x " " x xxxx  xxx xxx xxx xxx xxx xxx x " " x x  x  x x x x x x x x x x x x x " " x x  x  xxx xxx xxx xxx xxx x x x " " x x  x                      x x x " " x x  x  xxx xxx xxx xxx xxx x x x " " x x  x  x x x x x x x x x x x x x " " x x  x  xxx xxx xxx xxx xxx xxx x " " x x  x                          x " " x x  x  xxx xxx xxx xxx xxx xxx x " " x x  x  x x x x x x x x x x x x x " " x x  x  xxx xxx xxx xxx xxx xxx x " " x x  x                          x " " x x  x  xxx xxx xxx xxx xxxxxxx x " " x x  x  x x x x x x x x x     x x " " x xxxx  xxx xxx xxx xxx xxxxxxx x " " x                               x " " x                               x " " xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx " "                                   " "                                   "))) (make-problem "19990527dDRA (2)" (quote ((25) (25) (20 2) (8 7 2) (7 1 1 1 5 1) (6 1 1 1 4 1) (5 1 1 1 1 1 2) (5 1 1 1 1 1 2) (5 1 1 1 1 1 2) (5 1 1 1 1 1 2 1 1) (5 1 1 1 1 1 2 2 2) (5 1 1 1 1 1 4 2) (5 1 1 1 1 1 5 3) (5 1 1 1 1 1 5 3) (5 1 1 1 1 1 5 3) (5 1 1 1 5 3) (4 4 1 1 5 3) (3 8 5 3) (2 12 5 3) (1 12 5 3) (1 8 1 5 3) (1 3 4 2 5 3) (1 3 2 3 5 3) (1 3 5 3 5 3) (1 3 5 3 5 3) (1 3 5 3 5 3) (1 9 3 4 2) (1 9 3 3 1) (1 9 13) (1 9 13) (11 13) (11 13) (11 13) (25) (25))) (quote ((35) (19 5) (18 1 14) (17 2 14) (16 3 14) (6 5 9) (5 9 5 13) (4 5 13) (3 11 6 12) (3 5 12) (3 12 5 12) (3 5 2) (3 13 3 13) (4 2 14) (5 11 1 15) (6 7) (35) (35) (6 24) (4 18 7) (2 1 14 7) (2 7) (2 1 14 7) (4 18 7) (6 24))) (quote ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxx           xxxxx" "xxxxxxxxxxxxxxxxxx x xxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxx xx xxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxx xxx xxxxxxxxxxxxxx" "xxxxxx          xxxxx     xxxxxxxxx" "xxxxx xxxxxxxxx xxxxx xxxxxxxxxxxxx" "xxxx            xxxxx xxxxxxxxxxxxx" "xxx xxxxxxxxxxx xxxxxx xxxxxxxxxxxx" "xxx              xxxxx xxxxxxxxxxxx" "xxx xxxxxxxxxxxx xxxxx xxxxxxxxxxxx" "xxx              xxxxx           xx" "xxx xxxxxxxxxxxxx xxx xxxxxxxxxxxxx" "xxxx              xx xxxxxxxxxxxxxx" "xxxxx xxxxxxxxxxx x xxxxxxxxxxxxxxx" "xxxxxx                      xxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxx     xxxxxxxxxxxxxxxxxxxxxxxx" "xxxx     xxxxxxxxxxxxxxxxxx xxxxxxx" "xx        x xxxxxxxxxxxxxx  xxxxxxx" "xx                          xxxxxxx" "xx        x xxxxxxxxxxxxxx  xxxxxxx" "xxxx     xxxxxxxxxxxxxxxxxx xxxxxxx" "xxxxxx     xxxxxxxxxxxxxxxxxxxxxxxx"))) (make-problem "19990607bDRA (3)" (quote (() (4 1 1 4 1 1) (1 1 1 1 1 2 1) (4 1 1 1 4 1 1 1) (1 2 2 1 1 1 2) (4 1 1 1 1 1 1) () () () () () (3) (2 2) (7) (3) (3) (3) (3) (3) (3) (3) (2 3) (2 2 4 3) (2 10 3) (12 1 3) (3 7 2 3) (3 4 8) (4 8) (15) (13) (10) () () () ())) (quote (() () (3 1) (1 1 1 4) (1 1 1 5) (1 3 5) (4 4) (5 5 4) (1 3 4) (1 4 3) (1 5 3) (5 5 3) (3 5 3) (5 5 4 4) (1 1 1 4 2 5) (1 1 3 3 1 6) (5 2 3 7) (1 3 4) (5 1 3 4) (1 10) (1 8) (1 6) (5) () ())) (quote ("                                   " "                                   " " xxx x                             " " x x x                xxxx         " " x x x                xxxxx        " " x xxx                  xxxxx      " "                     xxxx xxxx     " " xxxxx               xxxxx xxxx    " "    x                  xxx xxxx    " "   x                   xxxx xxx    " "    x                 xxxxx xxx    " " xxxxx                xxxxx xxx    " "            xxx       xxxxx xxx    " " xxxxx     xxxxx      xxxx xxxx    " " x x       x xxxx      xx xxxxx    " " x x       xxx xxx     x xxxxxx    " " xxxxx      xx  xxx     xxxxxxx    " "             x   xxx      xxxx     " " xxxxx       x    xxx     xxxx     " "  x                xxxxxxxxxx      " "   x                xxxxxxxx       " "    x                xxxxxx        " " xxxxx                             " "                                   " "                                   "))) (make-problem "19991010cTPV (4)" (quote ((25) (3 1 1 9) (2 8) (2 8) (2 9) (3 3 10) (3 2 7) (3 2 6) (3 3 6) (3 2 7) (4 3 8) (5 2 5) (4 3 2 4) (4 2 3) (3 1 3) (3 4) (3 5) (2 7) (2 1 2 7) (2 2 4 8) (2 2 4 8) (2 6 7) (2 3 5) (2 3) (2 2 2) (2 1 3 2) (3 1 4 2) (3 3 1 4 2) (4 4 1 3 3) (5 5 2 4) (6 5 9) (7 5 9) (8 3 10) (10 11) (25))) (quote ((35) (35) (2 12 9) (1 4 7) (1 1 6) (1 5) (2 2 4) (1 2 3) (1 1 2 2) (1 2 1 2) (1 2 4 3 1) (1 5 5 1) (2 1 5 1 6 1) (1 2 3 7 1) (1 1 1 5 2) (1 1 1 1 1 3) (2 2 2 2 8) (6 2 2 2 6) (7 2 1 5 3 5) (11 2 5 4 5) (12 2 7 5 5) (13 8 4 6) (24 7) (35) (35))) (quote ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xx   xxxxxxxxxxxx         xxxxxxxxx" "x         xxxx              xxxxxxx" "x          x                 xxxxxx" "x                             xxxxx" "xx                xx           xxxx" "x                  xx           xxx" "x    x              xx           xx" "x    xx              x           xx" "x    xx            xxxx      xxx  x" "x                 xxxxx     xxxxx x" "xx       x        xxxxx  x xxxxxx x" "x        xx        xxx    xxxxxxx x" "x         x x              xxxxx xx" "x    x  x x x                   xxx" "xx  xx xx  xx              xxxxxxxx" "xxxxxx xx xx       xx        xxxxxx" "xxxxxxx  xx x    xxxxx    xxx xxxxx" "xxxxxxxxxxx xx   xxxxx   xxxx xxxxx" "xxxxxxxxxxxx xx xxxxxxx xxxxx xxxxx" "xxxxxxxxxxxxx  xxxxxxxx xxxx xxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxx    xxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/problems/k30x20 b/collects/games/paint-by-numbers/problems/k30x20
new file mode 100644
index 0000000000..6067dc4612
--- /dev/null
+++ b/collects/games/paint-by-numbers/problems/k30x20
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 30x20") (define problems (list (make-problem "19981106-KVL (1)" (quote (() (1 1) (2 2) (8) (8) (2 2 2) (10 8) (15 6) (19 4) (21 2 1) (22 3) (28) (17 10) (3 10 3 4 2) (3 6 2 2 3 3) (3 5 3 4) (12 3 6) (9 2 4) () ())) (quote (() (3) (6) (8) (5 3) (7 2) (8 2) (8 2) (9 2) (9 2) (9 2) (9 2) (8 3) (8 3) (8 3) (7 3) (7 2) (7 1) (5 5) (11) (6 1) (4 5 1 2) (7 6 2) (3 3 5 2) (7 3 3) (7 3 2) (3 3 3 3) (7 7) (4 5) ())) (quote ("                    " "           xxx      " "         xxxxxx     " "        xxxxxxxx    " "        xxxxx xxx   " "       xxxxxxx xx   " "       xxxxxxxx xx  " "       xxxxxxxx xx  " "      xxxxxxxxx xx  " "      xxxxxxxxx xx  " "      xxxxxxxxx xx  " "      xxxxxxxxx xx  " "      xxxxxxxx xxx  " "      xxxxxxxx xxx  " "      xxxxxxxx xxx  " "      xxxxxxx xxx   " "      xxxxxxx xx    " "      xxxxxxx   x   " "       xxxxx xxxxx  " "       xxxxxxxxxxx  " "        xxxxxx x    " "   xxxx xxxxx x xx  " " xxxxxxx xxxxxx xx  " "  xxx xxx xxxxx xx  " "   xxxxxxx xxx xxx  " "   xxxxxxx xxx xx   " "  xxx xxx xxx xxx   " " xxxxxxx xxxxxxx    " "   xxxx   xxxxx     " "                    "))) (make-problem "19990311-FRA (2)" (quote (() (2) (2) (2) (3) (4) (27) (27) (27) (4) (4 1) (4 1) (6 1 3) (3 1 1) (3 1 1 3 1 1 1) (1 3 1 1 2 1 3 1) (1 3 1 2 1 1 1) (1 1 1 3) (1 1 1) (1 3))) (quote (() (1) (8 1) (9 6) (10 1) (11) (2 3 1) (1 3) (3) (3) (3 6) (3 1 1) (3 3) (3) (3 1 3) (3 1 1 1) (3 5) (3) (3 4) (3 1) (3 1) (3 4) (3) (3 3 1) (3 1 1 1) (3 5) (3) (3 4 1) (3) ())) (quote ("                    " "            x       " "     xxxxxxxx x     " "    xxxxxxxxx xxxxxx" "   xxxxxxxxxx x     " "  xxxxxxxxxxx       " " xx   xxx   x       " " x    xxx           " "      xxx           " "      xxx           " "      xxx xxxxxx    " "      xxx    x x    " "      xxx    xxx    " "      xxx           " "      xxx   x xxx   " "      xxx   x x x   " "      xxx   xxxxx   " "      xxx           " "      xxx     xxxx  " "      xxx      x    " "      xxx       x   " "      xxx     xxxx  " "      xxx           " "      xxx      xxx x" "      xxx      x x x" "      xxx      xxxxx" "      xxx           " "      xxx    xxxx x " "      xxx           " "                    "))) (make-problem "19990601cDRA (3)" (quote (() (3 1 3 1) (1 1 1 1) (2 1 2 3 1 2 1 1 2 3) (1 1 1 2 1 1 1 1 1 2) (1 1 1 3 1 1 2 2 1 1) () () (26) (2 2 7) (2 6 2 1) (9 1 1 1 2 1) (1 1 1 1 1 2 1) (1 2 2 1) (1 2 2 1) (1 1 1 1 1 1) (2 2 11 2 7) (2 2) () ())) (quote ((5) (1 1 1 6) (1 1 1 1) (1 1 1) (1 3 4 1 2) (4 1 2) (3 1 1 1) (1 1 1 1) (1 1 1) (3 1 2 1) (3 1 1 1) (1 1 1 4 1) (1 1 1) (3 1) (1 3 1) (5 1 1 1) (1 1 4 1) (3 1 1 1) (1 1 3 1) (3 1 2) (2 2 1 2) (1 2 1) (3 2 2 1) (2 2 1) (3 2 1) (1 1 3 1) (1 2 1) (5 4) (2 1) (2 1))) (quote (" xxxxx              " " x x    x  xxxxxx   " " x      x  x    x   " "        x  x   x    " " x xxx  xxxx  x xx  " "        xxxx  x xx  " "   xxx  x  x   x    " "   x    x  x    x   " "        x  x    x   " "   xxx  x  xx   x   " "   xxx  x    x  x   " "   x x  x xxxx  x   " "        x x     x   " "        xxx     x   " " x      xxx     x   " " xxxxx  x x     x   " " x      x xxxx  x   " "   xxx  x    x  x   " "   x    x xxx  x    " "        xxx   x xx  " "   xx   xx    x xx  " "     x  xx     x    " "   xxx  xx xx   x   " "        xx xx   x   " "   xxx  xx      x   " "   x x  xxx     x   " "        x  xx   x   " " xxxxx       xxxx   " "   xx           x   " "  xx x              "))) (make-problem "19991106-BDH (4)" (quote ((7) (9) (6 3) (6 3) (13) (16) (1 13) (2 10) (3 7) (5 5 7) (23) (7 10 5) (7 8 6) (8 7) (25) (25) (25) (24) (22) (20))) (quote ((8) (12) (12) (12) (11) (10) (10) (1 7) (2 6) (4 6) (4 6) (4 6) (4 6) (4 6) (4 3 6) (7 4 6) (13 6) (12 6) (11 7) (20) (2 16) (2 16) (9 10) (7 8) (6 6) (3) (3) (2) (1) (1))) (quote ("         xxxxxxxx   " "      xxxxxxxxxxxx  " "       xxxxxxxxxxxx " "        xxxxxxxxxxxx" "         xxxxxxxxxxx" "          xxxxxxxxxx" "          xxxxxxxxxx" "          x  xxxxxxx" "          xx  xxxxxx" "         xxxx xxxxxx" "         xxxx xxxxxx" "         xxxx xxxxxx" "         xxxx xxxxxx" "         xxxx xxxxxx" "  xxxx    xxx xxxxxx" " xxxxxxx xxxx xxxxxx" "xxxxxxxxxxxxx xxxxxx" "xxxxxxxxxxxx  xxxxxx" "xxxxxxxxxxx  xxxxxxx" "xxxxxxxxxxxxxxxxxxxx" "xx  xxxxxxxxxxxxxxxx" "xx  xxxxxxxxxxxxxxxx" "xxxxxxxxx xxxxxxxxxx" " xxxxxxx   xxxxxxxx " "  xxxxxx    xxxxxx  " "    xxx             " "    xxx             " "     xx             " "     x              " "     x              "))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/problems/k30x25 b/collects/games/paint-by-numbers/problems/k30x25
new file mode 100644
index 0000000000..a4b69b6a99
--- /dev/null
+++ b/collects/games/paint-by-numbers/problems/k30x25
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 30x25") (define problems (list (make-problem "19980715-GAS (1)" (quote ((30) (30) (30) (13 15) (12 14) (12 14) (12 14) (12 14) (12 14) (13 15) (13 12) (7 6) (4 3) (1 1) (1 2) (3 1 3 4) (3 3 4 3) (2 4 4 3) (2 3 3 2) (1 2 2 1 2) (1 1 1 1 3 1) (3 4 1) (4 5) () ())) (quote ((11 7) (11 4) (11 2) (12) (13) (14) (13 2) (13 3) (12 2) (12 1 1) (11 3) (11 4) (4 2 6) (3) (3) (4 2) (11 6) (11 5) (11 4) (11 2 1) (12 2) (12 3) (13 4) (13 3) (13) (12) (11 1) (10 3) (10 6) (10 9))) (quote ("xxxxxxxxxxx   xxxxxxx    " "xxxxxxxxxxx    xxxx      " "xxxxxxxxxxx    xx        " "xxxxxxxxxxxx             " "xxxxxxxxxxxxx            " "xxxxxxxxxxxxxx           " "xxxxxxxxxxxxx        xx  " "xxxxxxxxxxxxx       xxx  " "xxxxxxxxxxxx         xx  " "xxxxxxxxxxxx     x    x  " "xxxxxxxxxxx     xxx      " "xxxxxxxxxxx     xxxx     " "xxxx     xx    xxxxxx    " "xxx                      " "xxx                      " "xxxx     xx              " "xxxxxxxxxxx    xxxxxx    " "xxxxxxxxxxx    xxxxx     " "xxxxxxxxxxx    xxxx      " "xxxxxxxxxxx     xx    x  " "xxxxxxxxxxxx         xx  " "xxxxxxxxxxxx        xxx  " "xxxxxxxxxxxxx      xxxx  " "xxxxxxxxxxxxx       xxx  " "xxxxxxxxxxxxx            " "xxxxxxxxxxxx             " "xxxxxxxxxxx    x         " "xxxxxxxxxx     xxx       " "xxxxxxxxxx    xxxxxx     " "xxxxxxxxxx   xxxxxxxxx   "))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/problems/k30x30 b/collects/games/paint-by-numbers/problems/k30x30
new file mode 100644
index 0000000000..e6c7fe788a
--- /dev/null
+++ b/collects/games/paint-by-numbers/problems/k30x30
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 30x30") (define problems (list (make-problem "19981106-GAS (1)" (quote (() () (5 6) (1 2 2 1) (2 12 2) (1 2 2 1) (3 3) (1 3 3 1) (1 1 1 1 1 1) (2 1 3 3 1 2) (1 1 3 1 3 1 1) (1 4 1 4 1) (1 2 1 2 1) (1 1 1) (1 1 1) (1 3 1) (2 7 2) (1 3 1) (2 1 1 2) (2 2 11 2 2) (2 2 1 1 1 2 2) (1 2 1 2 1) (2 1 1 1 1) (1 7 1) (1 1) (1 1) (1 1 6 1) (1 1 1 1) (1 1 1 2) (25))) (quote (() () (8) (3 1) (3 8 2 1) (1 6 4 1) (1 1 1 4) (1 1 1 1) (2 1 2 1 1) (3 1 1 1 1) (1 1 4 3 1) (1 1 4 1 1 1) (1 5 1 5 1) (1 1 1 1 1) (1 3 1 1 1) (1 8 5 1) (1 3 1 1 1) (1 1 1 1 3) (1 5 1 5 1 1) (1 1 4 1 1 1 1) (2 1 4 3 1 1) (2 1 1 1 1 1 1) (1 1 2 1 1 1) (1 1 1 1 1) (1 1 1 1) (1 6 4 1) (3 8 2 2) (9) () ())) (quote #f)) (make-problem "19981230-SQU (2)" (quote (() () (4 4) (6 6) (8 8) (9 9) (9 9) (8 8) (7 6 7) (5 8 5) (10) (13) (14) (14) (18) (2 14 2) (2 14 2) (2 16 2) (2 2 12 2 2) (1 2 10 2 1) (4 3 2 3 4) (2 2 6 2 2) (4 2 2 2 4) (1 2 1 2 1 2 1) (2 1 2 2 2 1 2) (2 2 2 2 2) (2 2 2 2) (2 2 2 2) (2 2 2 2) (30))) (quote ((1) (3 1) (5 3 3 1) (7 2 3 2 1) (7 2 3 2 1) (8 2 2 2 2 1) (8 2 2 2 3) (7 1 2 2) (6 7 3 1) (5 8 2 2 1) (12 2 1) (12 2 1) (14 3) (12 1 2) (18 1) (18 1) (12 1 2) (14 3) (12 2 1) (12 2 1) (5 8 2 2 1) (6 6 3 1) (7 1 2 2) (8 2 2 2 3) (8 2 2 2 2 1) (7 2 3 2 1) (7 2 3 2 1) (5 3 3 1) (3 1) (1))) (quote ("                             x" "    xxx                      x" "   xxxxx          xxx xxx    x" "  xxxxxxx        xx xxx xx   x" "  xxxxxxx       xx  xxx  xx  x" "  xxxxxxxx     xx  xx xx  xx x" "  xxxxxxxx    xx  xx   xx  xxx" "   xxxxxxx    x  xx         xx" "    xxxxxx xxxxxxx    xxx    x" "     xxxxx xxxxxxxx  xx xx   x" "          xxxxxxxxxxxx   xx  x" "         xxxxxxxxxxxx     xx x" "        xxxxxxxxxxxxxx     xxx" "        xxxxxxxxxxxx x      xx" "        xxxxxxxxxxxxxxxxxx   x" "        xxxxxxxxxxxxxxxxxx   x" "        xxxxxxxxxxxx x      xx" "        xxxxxxxxxxxxxx     xxx" "         xxxxxxxxxxxx     xx x" "          xxxxxxxxxxxx   xx  x" "     xxxxx xxxxxxxx  xx xx   x" "    xxxxxx  xxxxxx    xxx    x" "   xxxxxxx    x  xx         xx" "  xxxxxxxx    xx  xx   xx  xxx" "  xxxxxxxx     xx  xx xx  xx x" "  xxxxxxx       xx  xxx  xx  x" "  xxxxxxx        xx xxx xx   x" "   xxxxx          xxx xxx    x" "    xxx                      x" "                             x"))) (make-problem "19990104-FRA (3)" (quote ((7) (7) (7) (7) (7) (7) (8) (9) (18) (19) (30) (11 1 3 8) (12 4 1 9) (11 5 10) (10 5 10) (10 4 1 9) (9 3 3 8) (25) (3 20) (1 17) (15) (12) (10) (7) (7) (5) (4) (5) (3) ())) (quote ((2) (3) (4) (6) (7) (8) (9) (10) (9) (8) (19) (11 8) (11 9) (11 5) (11 11) (11 11) (25) (5 4 9) (5 2 12) (5 13) (4 2 13) (3 4 12) (17 2) (15) (14) (13) (13) (12) (10) (9))) (quote ("          xx                  " "          xxx                 " "          xxxx                " "          xxxxxx              " "          xxxxxxx             " "          xxxxxxxx            " "          xxxxxxxxx           " "          xxxxxxxxxx          " "          xxxxxxxxx           " "          xxxxxxxx            " "xxxxxxxxxxxxxxxxxxx           " "xxxxxxxxxxx xxxxxxxx          " "xxxxxxxxxxx xxxxxxxxx         " "xxxxxxxxxxx      xxxxx        " "xxxxxxxxxxx xxxxxxxxxxx       " "xxxxxxxxxxx xxxxxxxxxxx       " "xxxxxxxxxxxxxxxxxxxxxxxxx     " "      xxxxx xxxx xxxxxxxxx    " "       xxxxx xx xxxxxxxxxxxx  " "        xxxxx  xxxxxxxxxxxxx  " "        xxxx xx xxxxxxxxxxxxx " "        xxx xxxx xxxxxxxxxxxx " "        xxxxxxxxxxxxxxxxx  xx " "        xxxxxxxxxxxxxxx       " "        xxxxxxxxxxxxxx        " "        xxxxxxxxxxxxx         " "        xxxxxxxxxxxxx         " "        xxxxxxxxxxxx          " "         xxxxxxxxxx           " "          xxxxxxxxx           "))) (make-problem "19990708-VEG (4)" (quote ((1 1 3 1 1 3 1 1) (1 1 1 1 2 2 1 5) (3 1 1 1 1 1 2 5) (1 1 1 1 1 1 1 3) (1 1 3 1 1 3 1) () () () () (1) (3) (5 1) (7 1) (10) (11) (13) (15) (2 2) (2 2 2 2) (2 2 2 2) (2 2) (2 2) (12 3 9) (1 1 1 3 3 3 1 1) (2 2 2 2 3 2 2 2) (1 1 1 3 3 3 1 1) (30) (13) (1 1) (1 1))) (quote ((5 2 2) (1 1 1 1) (5 1 1 1) (2 2) (5 1 1 1) (1 1 1 1 1) (5 2 2) (1 1 1) (5 1 1 1) (1 1 2 2) (1 13) (1 14) (5 4 2) (5 2 2) (5 6 2 2) (1 1 1 7 6) (1 1 8 6) (7 2 6) (6 2 3) (5 2 1) (2 4 3) (4 17 1) (4 13) (4 1 2 2) (2 1 1 1) (1 1 1) (2 2) (1 1 1) (1 1 1) (2 2))) (quote ("xxxxx                 xx xx   " "  x                   x x x   " "xxxxx                 x x x   " "                      xx xx   " "xxxxx                 x x x   " "x   x                 x x x   " "xxxxx                 xx xx   " "                      x x x   " "xxxxx                 x x x   " " x              x     xx xx   " "  x            xxxxxxxxxxxxx  " " x            xxxxxxxxxxxxxx  " "xxxxx        xxxx         xx  " "            xxxxx xx      xx  " "xxxxx      xxxxxx xx      xx  " "x x x     xxxxxxx     xxxxxx  " "x   x    xxxxxxxx     xxxxxx  " "          xxxxxxx xx  xxxxxx  " "           xxxxxx xx      xxx " "            xxxxx         xx x" " xx          xxxx         xxx " "xxxx       xxxxxxxxxxxxxxxxx x" " xxxx          xxxxxxxxxxxxx  " "xxxx            x     xx xx   " " xx                   x x x   " "                      x x x   " "                      xx xx   " "                      x x x   " "                      x x x   " "                      xx xx   "))) (make-problem "19990729-WHO (5)" (quote ((3) (1 2) (1 5) (1 1 1 4) (1 1 1 3) (1 1 1 2) (1 5) (1 3) (1 2) (1 1) (1 1) (1 1) (3 2) (12 5) (13 6) (14 8) (15 9) (16 9) (16 10) (16 10) (16 9) (16 9) (8 7 9) (8 16) (27) (26) (25) (22) (15) (5))) (quote (() (3) (6) (12) (13) (14) (15) (16) (16) (17) (9 6) (9 6) (17) (17) (16) (16) (17) (17) (28) (1 5) (28) (2 3 16) (6 15) (1 1 15) (5 14) (3 13) (2 11) (1 10) (7) (2))) (quote ("                              " "                        xxx   " "                      xxxxxx  " "                 xxxxxxxxxxxx " "                xxxxxxxxxxxxx " "               xxxxxxxxxxxxxx " "              xxxxxxxxxxxxxxx " "             xxxxxxxxxxxxxxxx " "             xxxxxxxxxxxxxxxx " "             xxxxxxxxxxxxxxxxx" "             xxxxxxxxx  xxxxxx" "             xxxxxxxxx  xxxxxx" "             xxxxxxxxxxxxxxxxx" "             xxxxxxxxxxxxxxxxx" "             xxxxxxxxxxxxxxxx " "             xxxxxxxxxxxxxxxx " "            xxxxxxxxxxxxxxxxx " "            xxxxxxxxxxxxxxxxx " "xxxxxxxxxxxxxxxxxxxxxxxxxxxx  " "x                      xxxxx  " "xxxxxxxxxxxxxxxxxxxxxxxxxxxx  " " xx   xxx   xxxxxxxxxxxxxxxx  " "  xxxxxx     xxxxxxxxxxxxxxx  " "  x   x      xxxxxxxxxxxxxxx  " "  xxxxx      xxxxxxxxxxxxxx   " "   xxx        xxxxxxxxxxxxx   " "   xx          xxxxxxxxxxx    " "   x           xxxxxxxxxx     " "                xxxxxxx       " "                  xx          "))) (make-problem "19990820-DAH (6)" (quote (() (7 1 8) (1 4 2 1 2 1) (1 2 3 1 1 1 1) (1 2 4 1 1 1 1) (1 3 5 1 2 1) (1 2 1 2 1 1 1 1) (3 2 1 2 2) (3 2 8) () () (8 4) (8 3 4 2 2) (2 2 2 3 2) (1 1 1 1 3) (1 2 1 1 1 2) (1 1 1 1) (8 1 1 2) (6 2) () () (6 3) (1 1 2 1 1 1) (1 1 1 4 2 1 1) (1 1 1 1 2 2 1) (1 1 1 5 3 2) (6 1 1 1 2 2) (4 2 1 2) (1 2 1 6) ())) (quote (() (7 6) (1 1 2 1 6 1) (1 1 1 1 2 1 2) (2 1 1 1 1 1 3) (2 1 1 1 1 1 1 3) (8 1 1 2 1 2) (7 2 1 6 1) (6) () () (3 6) (3 2 1 2) (6 2 1 1 1 1 1) (4 1 1 1 1 1) (4 2 1 1 1 1) (5 3 1 1 1 1 1) (1 1 3 2 3 1) (3 2) () () (8 6) (1 2 1 5) (1 2 1 1 2 1) (2 1 1 1 2 2 2) (2 1 1 1 2 2 1 1 1) (1 2 1 1 4 1 3) (1 2 2 1 1) (8 3) ())) (quote #f)) (make-problem "19990821-ICO (7)" (quote (() () (1 1 1 1 1) (2 1 1 1 1) (2 2 1 1 1 1) (1 2 1 4 3 1 1 1 1) (1 2 1 6 3 1 1 1 1) (1 2 1 6 3 1 1 1 1) (1 2 1 6 3 1 1 1 1) (1 2 1 6 3 1 1 1 1) (1 2 1 6 3 1 1 1 1) (1 2 1 6 3 7) (6 4 3 5) (6 2 2 3) (2 2 2 1) (2 2 2 1) (2 2 2 1) (2 2 2 1) (2 2 2 1) (2 2 2 1) (2 2 2 1) (2 2 2 1) (2 2 2 1) (2 2 2 1) (1 1 3 3 1 1 3 1 1 3) (1 1 1 1 2 1 1 1 1 1) (1 1 1 3 1 2 3 1 1 3) (1 1 1 1 1 1 1 1 1 1) (3 1 3 1 1 3 1 2 3) ())) (quote ((9) (2 5) (19 1) (24) (2) (9 1) (5) (1) (6) (8 5) (21 1 1) (21 1 1) (8) (6 5) (1) (1) (5) (22) (24 1) (8 1 1 1) (1 3) () (10 5) (2) (12 5) (13 1) (12) (2 3 1) (10 1 1 1) (1 3))) (quote ("     xxxxxxxxx                " "            xx          xxxxx " "     xxxxxxxxxxxxxxxxxxx    x " "     xxxxxxxxxxxxxxxxxxxxxxxx " "            xx                " "     xxxxxxxxx          x     " "                        xxxxx " "                        x     " "      xxxxxx                  " "     xxxxxxxx           xxxxx " "    xxxxxxxxxxxxxxxxxxxxx x x " "    xxxxxxxxxxxxxxxxxxxxx x x " "     xxxxxxxx                 " "      xxxxxx            xxxxx " "                         x    " "                          x   " "                        xxxxx " "  xxxxxxxxxxxxxxxxxxxxxx      " "   xxxxxxxxxxxxxxxxxxxxxxxx x " "     xxxxxxxx           x x x " "                        x xxx " "                              " "  xxxxxxxxxx            xxxxx " "           xx                 " "  xxxxxxxxxxxx          xxxxx " "           xxxxxxxxxxxxx    x " "  xxxxxxxxxxxx                " "           xx           xxx x " "  xxxxxxxxxx            x x x " "                        x xxx "))) (make-problem "19990908-ALE (8)" (quote ((12 16) (11 15) (10 14) (4 4 14) (3 4 3 10) (2 4 3 9) (2 3 4 8) (3 4 4 8) (4 5 5 9) (6 5 5 10) (7 4 6 10) (8 3 5 11) (8 3 4 12) (8 4 3 12) (8 4 2 5 6) (8 4 2 4 5) (8 4 2 3 5) (9 3 2 3 4) (9 4 1 2 1 1 3) (10 4 1 3 3 2) (10 4 3 4) (11 2 3) (16 1 1 2) (21 2 2) (21 5) (20 4) (19 3) (21 1 6) (21 1 6) (20 1 5))) (quote ((30) (30) (5 23) (4 22) (3 21) (3 21) (4 1 20) (5 3 19) (11 13) (17 11) (2 15 9) (1 1 12 8) (3 8 8) (7 3 8) (1 13 2 8) (2 15 8) (6 6 7) (5 3 8 7) (4 1 7 2 7) (4 7 2 3 3) (5 7 2 3 2) (6 7 1) (14 3) (14) (15 1 2) (17 2 3 3) (18 2 3 3) (19 2 6) (30) (30))) (quote ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxx  xxxxxxxxxxxxxxxxxxxxxxx" "xxxx    xxxxxxxxxxxxxxxxxxxxxx" "xxx      xxxxxxxxxxxxxxxxxxxxx" "xxx      xxxxxxxxxxxxxxxxxxxxx" "xxxx    x xxxxxxxxxxxxxxxxxxxx" "xxxxx  xxx xxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxx      xxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxx  xxxxxxxxxxx" "xx  xxxxxxxxxxxxxxx  xxxxxxxxx" "x    x   xxxxxxxxxxxx xxxxxxxx" "      xxx    xxxxxxxx xxxxxxxx" "      xxxxxxx     xxx xxxxxxxx" "x    xxxxxxxxxxxxx xx xxxxxxxx" "xx  xxxxxxxxxxxxxxx   xxxxxxxx" "xxxxxx  xxxxxx         xxxxxxx" "xxxxx    xxx  xxxxxxxx xxxxxxx" "xxxx      x xxxxxxx xx xxxxxxx" "xxxx       xxxxxxx xx  xxx xxx" "xxxxx    xxxxxxx  xx  xxx  xx " "xxxxxx  xxxxxxx    x          " "xxxxxxxxxxxxxx             xxx" "xxxxxxxxxxxxxx                " "xxxxxxxxxxxxxxx    x       xx " "xxxxxxxxxxxxxxxxx xx  xxx  xxx" "xxxxxxxxxxxxxxxxxx xx  xxx xxx" "xxxxxxxxxxxxxxxxxxx xx  xxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"))) (make-problem "19990913-TUC (9)" (quote ((12 14) (13 15) (13 15) (13 15) (1 6 6 3) (1 3 5 5 3 3) (1 1 4 4 3 3) (1 1 1 3 3 1 3) (1 3 3 3 1 1 3) (1 3 3 3 3 3) (1 3 3 6 3 3 3) (2 1 4 6 4 1 4) (3 5 6 5 5) (3 5 6 5 5) (3 5 5 5) (3 5 5 5) (3 5 5 5) (2 4 4 4) (1 1 1 3 3 1 1 3) (1 3 3 3 3 3) (2 4 4 4) (30) () (30) (1 1 2 1 1 1 2) (1 2 1 2 1 4 4 2 1 3) (1 4 1 2 2 2) (1 2 1 2 1 4 4 2 4) (1 1 2 1 1 1 2 1) (30))) (quote ((22 7) (4 7 2 1 1) (4 1 4 5 2 1 1 3 1) (4 2 4 1 1 1 3 1) (4 1 4 5 2 1 1 1 1) (4 7 2 7) (22 1 1) (22 3 3) (22 3 3) (7 1 1 1) (6 1 7) (5 4 1 1 1) (3 4 1 1 1 1 1) (4 1 1 1 1 1) (4 1 1 3 1) (3 4 1 7) (5 4 1 1 1) (6 1 1 1 1 1) (7 1 1 1 1 1) (22 1 3 1) (22 7) (22 1 1) (4 7 2 1 1 3) (4 2 3 5 2 1 1 1 3) (4 3 3 1 1 2 1 1) (4 2 3 5 2 1 7) (4 7 2 1 1 1) (22 1 1 1 1) (22 1 1 1 1) (22 1 1 1))) (quote ("xxxxxxxxxxxxxxxxxxxxxx xxxxxxx" "xxxx       xxxxxxx  xx x     x" "xxxx x xxxx xxxxx xx x x xxx x" "xxxx xx xxxx       x x x xxx x" "xxxx x xxxx xxxxx xx x x  x  x" "xxxx       xxxxxxx  xx xxxxxxx" "xxxxxxxxxxxxxxxxxxxxxx x     x" "xxxxxxxxxxxxxxxxxxxxxx xxx xxx" "xxxxxxxxxxxxxxxxxxxxxx xxx xxx" "xxxxxxx              x x     x" "xxxxxx               x xxxxxxx" "xxxxx     xxxx       x x     x" " xxx      xxxx       x x x x x" "          xxxx       x x x x x" "          xxxx       x x xxx x" " xxx      xxxx       x xxxxxxx" "xxxxx     xxxx       x x     x" "xxxxxx               x x x x x" "xxxxxxx              x x x x x" "xxxxxxxxxxxxxxxxxxxxxx x xxx x" "xxxxxxxxxxxxxxxxxxxxxx xxxxxxx" "xxxxxxxxxxxxxxxxxxxxxx x     x" "xxxx       xxxxxxx  xx x x xxx" "xxxx xx xxx xxxxx xx x x x xxx" "xxxx xxx xxx       x x xx x  x" "xxxx xx xxx xxxxx xx x xxxxxxx" "xxxx       xxxxxxx  xx x   x x" "xxxxxxxxxxxxxxxxxxxxxx x x x x" "xxxxxxxxxxxxxxxxxxxxxx x x x x" "xxxxxxxxxxxxxxxxxxxxxx x x   x"))) (make-problem "19990916bCAR (10)" (quote ((30) (30) (30) (7 7 6) (6 5 5) (5 3 3 3 4) (5 5 1 5 4) (5 6 6 4) (5 15 4) (5 5 5 4) (6 4 4 5) (6 3 3 5) (7 4 4 6) (8 3 3 7) (9 5 8) (9 3 8) (10 1 9) (11 10) (12 11) (13 12) (14 13) (15 8 3) (23 3 2) (7 12 3 1) (7 2) (7 2) (7 1 1 12 3 1) (7 1 13 3 2) (24 3) (30))) (quote ((30) (30) (30) (30) (30) (5 20) (4 18) (3 10 2) (3 3 9 4) (3 5 7 2) (3 6 6 4) (3 8 5 3) (4 8 5 4) (5 8 4 4) (6 1 4 3 4) (7 1 3 2 4) (6 1 4 3 4) (5 8 4 4) (4 8 5 4) (3 8 6 4) (3 6 7 4) (3 5 8 4) (3 3 10 4) (3 9 1 1 2) (4 9 1 1 1) (5 11 2 2 1) (21 2 2 1) (22 4 2) (23 2 3) (24 4))) (quote ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxx     xxxxxxxxxxxxxxxxxxxx" "xxxx        xxxxxxxxxxxxxxxxxx" "xxx          xxxxxxxxxx     xx" "xxx   xxx     xxxxxxxxx   xxxx" "xxx  xxxxx      xxxxxxx     xx" "xxx  xxxxxx      xxxxxx   xxxx" "xxx  xxxxxxxx     xxxxx    xxx" "xxxx  xxxxxxxx     xxxxx  xxxx" "xxxxx  xxxxxxxx     xxxx  xxxx" "xxxxxx  x   xxxx     xxx  xxxx" "xxxxxxx x     xxx     xx  xxxx" "xxxxxx  x   xxxx     xxx  xxxx" "xxxxx  xxxxxxxx     xxxx  xxxx" "xxxx  xxxxxxxx     xxxxx  xxxx" "xxx  xxxxxxxx     xxxxxx  xxxx" "xxx  xxxxxx      xxxxxxx  xxxx" "xxx  xxxxx      xxxxxxxx  xxxx" "xxx   xxx     xxxxxxxxxx  xxxx" "xxx          xxxxxxxxx x  x xx" "xxxx        xxxxxxxxx x    x x" "xxxxx     xxxxxxxxxxx xx  xx x" "xxxxxxxxxxxxxxxxxxxxx xx  xx x" "xxxxxxxxxxxxxxxxxxxxxx xxxx xx" "xxxxxxxxxxxxxxxxxxxxxxx xx xxx" "xxxxxxxxxxxxxxxxxxxxxxxx  xxxx"))) (make-problem "19990920-BBA (11)" (quote ((6) (3 2 1 2) (1 1 1 4 4) (3 1 1 1 2 3) (8 2 2 1 4) (11 8 2) (1 1 1 6 9 1) (1 24) (1 2 12 4 3) (4 1 1 1 1 1 3 7 1) (1 5 3 5 4 1 2) (3 5 2 4 7 1) (3 1 5 1 1 4 2 1) (1 4 3 4 5 7) (1 1 3 4 1 3 2 3 1) (4 1 6 4 9) (7 1 2 2 4 3) (3 4 2 2 2 1 3 2) (3 1 1 1 2 2 1 8) (2 3 3 4 1 3 1 1) (3 2 2 1 2 2 1 4) (2 1 3 3 2 4 2) (1 1 3 3 2 1 1 1) (1 1 1 1 1 3 1) (1 3 1 1) (2 6) (5 6) (3 5 2 1 1) (1 3 1 1 2 4) (2 3 3 4 1))) (quote ((4) (4 2 1) (2 6 6) (1 3 1 4 2) (2 3 3 5 1) (1 2 2 5 1 1) (4 4 1 1 3 1 1) (1 2 1 4 3 4 2) (1 7 5 3 2 1) (5 2 8 3 1 1) (1 8 1 2 4 1 1) (1 1 5 2 4 1 2) (2 6 1 1 6 4) (3 6 1 3 8) (1 2 4 2 3 4 2) (3 1 6 14) (1 1 2 2 4 4 2 1 1) (1 1 7 3 7 2) (2 7 3 7 3 1) (8 2 2 5) (2 3 1 1 2 2 2) (1 9 6 1 2 1) (1 8 2 5 1 1) (11 1 3 1 1 3) (2 10 2 4 1) (4 1 1 6 1 1 1) (2 1 8 5 1) (4 2 4 2 2 1) (2 2 3 3) (3 2))) (quote ("            xxxx              " "         xxxx  xx  x          " "        xx xxxxxx xxxxxx      " "       x xxx x xxxx xx        " "     xx xxx xxx xxxxx x       " "     x xx xx xxxxx x x        " "    xxxx xxxx x x xxx x      x" "  x xx x  xxxx xxx  xxxx    xx" " x xxxxxxx xxxxx xxx xx    x  " " xxxxx xx xxxxxxxx xxx     x x" " x xxxxxxxx x xx xxxx      x x" "x x xxxxx xx xxxx         x xx" "xx xxxxxx  x x xxxxxx    xxxx " "xxx xxxxxx   x   xxx xxxxxxxx " "x xx xxxx xx xxx   xxxx   xx  " "xxx x xxxxxx   xxxxxxxxxxxxxx " "x x xx xx xxxx xxxx     xx x x" " x x xxxxxxx xxx    xxxxxxx xx" " xx xxxxxxx xxx xxxxxxx  xxx x" "  xxxxxxxx   xx xx      xxxxx " "  xx xxx   x x xx        xx xx" "  x xxxxxxxxx xxxxxx x    xx x" "   x xxxxxxxx xx  xxxxx   x  x" "   xxxxxxxxxxx x xxx x x   xxx" "   xx xxxxxxxxxx xx xxxx    x " "    xxxx x x xxxxxx x  x    x " "    xx x xxxxxxxx xxxxx     x " "      xxxx  xx xxxx xx xx    x" "       xx xx xxx xxx          " "        xxx xx                "))) (make-problem "19991002bTPV (12)" (quote ((30) () (2 1) (3 2) (3 3) (1 2 4) (1 1 5) (30) (1 2 4 1) (1 1 4 1) (1 3 1) (1 2 1) (1 1 1) (1 1 1) (30) (1 1 1) (5 1 5) (6 1 1 6) (6 1 6) (4 1 1 4) (1 1 1) (30) (4 1) (4 5) (2 1 6) (1 2 6) (4 4) (4) (30) (1 1))) (quote ((1 1 1 1 1) (1 1 1 2 1 1) (1 1 1 4 1 1) (1 1 1 4 1 1) (1 1 1 4 1 1) (1 1 1 4 1 1) (1 17 1 1) (1 3 1 1 1 1) (1 3 1 1 1 1 1) (1 4 1 1 1) (1 3 1 1 2 2) (1 1 1 10) (1 1 1 3 3) (1 1 1 11) (1 1 1 2 2 1) (1 1 1 1 1) (1 1 1 1 2 1) (1 1 1 1 4 1) (1 1 1 1 4 1) (1 1 1 1 4 1) (1 1 1 1 4 1) (1 1 17 1) (1 5 1 1 1) (1 4 1 2 1 1) (1 4 1 4 1 1) (1 4 1 4 1 1) (1 4 1 4 1 1) (1 5 1 4 1 1) (1 17 1 1) (1 1 1 1 1))) (quote ("x      x      x      x      x " "x      x      x  xx  x      x " "x      x      x xxxx x      x " "x      x      x xxxx x      x " "x      x      x xxxx x      x " "x      x      x xxxx x      x " "x xxxxxxxxxxxxxxxxx  x      x " "x xxx  x      x      x      x " "x  xxx x      x  x   x      x " "x    xxxx     x      x      x " "x      xxx    x      x xx  xx " "x      x      x     xxxxxxxxxx" "x      x      x      xxx  xxx " "x      x      x    xxxxxxxxxxx" "x      x      x      xx  xx x " "x      x      x      x      x " "x      x      x      x  xx  x " "x      x      x      x xxxx x " "x      x      x      x xxxx x " "x      x      x      x xxxx x " "x      x      x      x xxxx x " "x      x xxxxxxxxxxxxxxxxx  x " "x      xxxxx  x      x      x " "x      xxxx   x  xx  x      x " "x     xxxx    x xxxx x      x " "x    xxxx     x xxxx x      x " "x   xxxx      x xxxx x      x " "x  xxxxx      x xxxx x      x " "x xxxxxxxxxxxxxxxxx  x      x " "x      x      x      x      x "))) (make-problem "19991012-LSA (13)" (quote ((16 13) (4 4 5 4 3 1) (2 1 2 5 2 2 1) (4 2 2 3 1 3 3) (5 1 3 3 2 4 3) (1 2 1 1 2 2 2 3) (2 2 1 2 2 1 2 3) (3 1 2 2 2 1 2 4) (1 2 2 2 1 2 1 2 5) (2 1 1 2 1 2 2 1 1 1) (3 2 2 2 2 1 1 1) (4 1 1 1 1 1 1 3) (5 2 3 1 2 1 2 4) (1 2 2 2 1 1 1 5) (3 1 1 1 1 2 2 2 1) (7 3 1 1 2 1 4) (7 2 1 2 1 1 1) (3 2 1 1 1 2 3 1 1) (1 1 1) (1 1 22 1 1) (3 1 1 3) (2 2 1 1 1 3 1 1 3 1 3) (2 2 1 1 1 1 1 1 1 1 1 1 2) (2 2 1 3 1 1 3 1 1 5) (2 2 5) (6 6) (7 7) (8 8) (9 9) (10 10))) (quote ((30) (5 2 4 4 10) (2 2 2 3 4 2 5) (2 3 1 2 2 9) (1 3 1 1 2 11) (3 3 1 1 2 1 5) (2 1 1 2 1 3 1 1 1 4) (2 3 1 1 1 1 1 1 3) (2 2 2 1 1 1 1 2) (1 2 3 4 1 2 1) (1 3 3 2 1 1 1) (1 3 3 1 1 1) (2 1 2 2 1 1 1) (3 3 4 1 2) (4 1 1 1) (5 12 1 1) (10 1 1 1) (1 1 2 1 4 1 2) (1 8 1 1 1) (3 7 1 1) (6 1 1 1 1 1 1) (2 1 7 1 2 2) (2 1 4 1 1 1 3) (1 5 1 1 1 1 1 4) (1 5 3 1 1 1 5) (5 2 1 1 11) (2 2 2 2 7) (2 6 4 1 5 7) (1 6 3 1 10) (10 19))) (quote ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxx xx xxxx xxxx  xxxxxxxxxx" "xx xx  xx xxx xxxx xx    xxxxx" "xx xxx  x  xx  xx    xxxxxxxxx" "x   xxx  x  x  xx  xxxxxxxxxxx" "xxx   xxx x  x xx  x     xxxxx" "xx x    x xx x xxx x x x  xxxx" "xx xxx   x  x x  x x  x    xxx" "xx    xx    xx x   x x x    xx" "x xx   xxx   xxxx  x  xx     x" "x xxx   xxx    xx  x x x      " "x   xxx   xxx    x x  x       " "xx  x xx    xx     x x x      " "xxx    xxx  xxxx   x xx       " "xxxx               x x x      " "xxxxx xxxxxxxxxxxx x  x       " " xxxxxxxxxx        x x x      " "x x xx      x xxxx x  xx      " "x        xxxxxxxx  x x x      " "xxx xxxxxxx        x  x       " "xxxxxx        x  x x x x     x" "xx      x  xxxxxxx x xx     xx" "xx  x  xxxx        x x x   xxx" "x  xxxxx    x x  x x  x   xxxx" "x xxxxx   xxx x  x x     xxxxx" "xxxxx   xx   x   x xxxxxxxxxxx" "xx     xx   xx xx      xxxxxxx" "xx xxxxxx xxxx x xxxxx xxxxxxx" "x  xxxxxx  xxx x    xxxxxxxxxx" "xxxxxxxxxx xxxxxxxxxxxxxxxxxxx"))) (make-problem "19991028-BDH (14)" (quote ((7 7) (9 9) (11 11) (12 12) (12 12) (12 12) (12 12) (12 12) (30) (28) (8 4 8) (5 1 2 1 5) (2 3 3 2) (3 3 3 3) (2 3 3 2) (2 3 3 2) (3 3 3 3) (3 1 1 3) (2 2) (2 2) (2 4 2) (2 6 2) (2 4 2) (1 1) (1 1 1 1) (2 14 2) (2 10 2) (3 4 3) (3 3) (10))) (quote ((7) (9) (11) (12 7) (12 13) (18 2) (14 2) (12 1) (11 2 2) (10 5 1 1) (8 7 2 2) (7 5 2 1) (2 1 2 1) (3 3 3 1) (4 3 3 1) (4 3 3 1) (3 3 3 1) (2 1 2 1) (7 5 2 1) (8 7 2 2) (10 5 1 1) (11 2 2) (12 1) (14 2) (18 2) (12 13) (12 7) (11) (9) (7))) (quote ("  xxxxxxx                     " " xxxxxxxxx                    " "xxxxxxxxxxx                   " "xxxxxxxxxxxx    xxxxxxx       " "xxxxxxxxxxxx xxxxxxxxxxxxx    " "xxxxxxxxxxxxxxxxxx       xx   " "xxxxxxxxxxxxxx            xx  " "xxxxxxxxxxxx               x  " "xxxxxxxxxxx             xx xx " " xxxxxxxxxx xxxxx        x  x " "  xxxxxxxx xxxxxxx       xx xx" "   xxxxxxx  xxxxx        xx  x" "        xx           x   xx  x" "        xxx         xxx  xxx x" "        xxxx        xxx  xxx x" "        xxxx        xxx  xxx x" "        xxx         xxx  xxx x" "        xx           x   xx  x" "   xxxxxxx  xxxxx        xx  x" "  xxxxxxxx xxxxxxx       xx xx" " xxxxxxxxxx xxxxx        x  x " "xxxxxxxxxxx             xx xx " "xxxxxxxxxxxx               x  " "xxxxxxxxxxxxxx            xx  " "xxxxxxxxxxxxxxxxxx       xx   " "xxxxxxxxxxxx xxxxxxxxxxxxx    " "xxxxxxxxxxxx    xxxxxxx       " "xxxxxxxxxxx                   " " xxxxxxxxx                    " "  xxxxxxx                     "))) (make-problem "19991101-SHE (15)" (quote ((4) (2 2) (1 2) (2 1 3) (2 3) (2 1 3) (3 3) (3 4) (5 4) (1 7) (2 7) (2 8) (2 4) (1 2 2 2) (1 2 3 4) (3 3 4 7) (3 4 4 2) (8 7 1) (6 11 1) (5 8 3) (5 8) (17) (17) (16) (15) (14) (13) (11) (9) (5))) (quote (() (3) (3) (5) (5) (7) (9) (11) (1 4 8) (5 8) (3 8) (9) (9) (9) (3 11) (4 8 13) (8 16) (2 3 15) (1 1 3 13) (1 1 3 11) (2 1 4 8) (14 6) (14 1) (9 2 1) (5 2 1) (2 1 1) (1 1 1) (1 2 1) (5) ())) (quote ("                              " "             xxx              " "               xxx            " "               xxxxx          " "                xxxxx         " "                 xxxxxxx      " "                 xxxxxxxxx    " "                xxxxxxxxxxx   " "             x xxxx xxxxxxxx  " "             xxxxx   xxxxxxxx " "              xxx    xxxxxxxx " "                     xxxxxxxxx" "                     xxxxxxxxx" "                     xxxxxxxxx" "          xxx      xxxxxxxxxxx" "   xxxx xxxxxxxx xxxxxxxxxxxxx" " xxxxxxxx    xxxxxxxxxxxxxxxx " "xx    xxx     xxxxxxxxxxxxxxx " "x  x   xxx     xxxxxxxxxxxxx  " "x    x  xxx     xxxxxxxxxxx   " "xx x     xxxx    xxxxxxxx     " " xxxxxxxxxxxxxx  xxxxxx       " "  xxxxxxxxxxxxxx  x           " "    xxxxxxxxx xx  x           " "       xxxxx  xx  x           " "          xx   x  x           " "           x   x   x          " "           x   xx  x          " "               xxxxx          " "                              "))) (make-problem "19991105bBDH (16)" (quote ((1) (1 1) (1 1) (1 1 1) (1 1 2) (2 3) (1 1 1) (2 1) (4 1) (1 1) (1 1) (1 1) (1 1) (1 1) (1 1) (1 1) (1 1) (1 1) (1 1) (1 1) (1 1 4) (1 1 1 1) (1 1 1 1) (4 1 1 1 1) (6 1 1 5) (7 1 1 4) (4 1 1 6) (17) (16) (14))) (quote ((2) (2) (3) (3) (2) (3) (3) (4) (5) (3) (22) (1 3) (3 1 3) (1 1 1 3) (1 4 3) (3 1 3) (1 3) (1 3) (2 3) (27) (3) (4) (3) (2) (2) (6) (1 3) (1 1) (1 1) (5))) (quote ("                       xx     " "                       xx     " "                       xxx    " "                       xxx    " "                        xx    " "                        xxx   " "                         xxx  " "                         xxxx " "                         xxxxx" "                           xxx" "        xxxxxxxxxxxxxxxxxxxxxx" "        x                  xxx" "  xxx   x                  xxx" " x   x  x                  xxx" "x   xxxx                   xxx" " xxx   x                   xxx" "      x                    xxx" "     x                     xxx" "    xx                     xxx" "   xxxxxxxxxxxxxxxxxxxxxxxxxxx" "                           xxx" "                          xxxx" "                          xxx " "                         xx   " "                         xx   " "                     xxxxxx   " "                    x   xxx   " "                    x   x     " "                    x   x     " "                    xxxxx     "))) (make-problem "19991113aBAR (17)" (quote ((11) (15) (18) (20) (22) (24) (25) (27) (24 2) (5 4 1) (2 2 1) (1 5 5 1 1) (6 2 2 5 2) (4 6 7) (2 18 2) (2 3 3 2) (8 3 3 6) (6 7 8) (4 3 2 2 4 4) (3 5 6 2) (2 3 4 3 2) (2 13 1) (2 4 4 1) (2 1) (2 1 2) (3 2 3) (4 1 1 3 1 3) (6 1 1 2 4) (11 2 2 11) (30))) (quote ((12) (3 13) (3 8 5) (3 7 4) (5 2 2 3) (6 3 3 5) (7 2 1 4 2 2) (7 1 3 3 2) (8 1 3 3 2) (8 1 3 3 4) (9 2 1 2 2 2) (9 3 2 2 1) (9 2 1 2 1) (9 2 2 3 2) (9 2 2 2 2) (9 2 2 2 1 1) (9 3 1 3 1 2) (9 2 1 2 2 4) (9 1 3 2 2 1) (9 1 3 4 2) (9 1 3 3 2) (9 2 1 4 2) (9 3 4 2) (8 2 4 3) (9 7 4) (6 8 2) (4 1 3 3) (3 1 3 5) (3 2 4 6) (6 12))) (quote ("                  xxxxxxxxxxxx" "          xxx    xxxxxxxxxxxxx" "        xxx xxxxxxxx     xxxxx" "       xxx  xxxxxxx       xxxx" "     xxxxx  xx  xx         xxx" "    xxxxxx  xxx xxx      xxxxx" "   xxxxxxx xx x xxxx    xx  xx" "  xxxxxxx  x  xxx xxx       xx" " xxxxxxxx  x  xxx  xxx      xx" " xxxxxxxx  x  xxx  xxx    xxxx" "xxxxxxxxx  xx x   xx xx     xx" "xxxxxxxxx   xxx  xx  xx      x" "xxxxxxxxx    xx  x   xx      x" "xxxxxxxxx    xx xx  xxx     xx" "xxxxxxxxx    xx xx  xx      xx" "xxxxxxxxx    xx xx  xx    x  x" "xxxxxxxxx   xxx  x  xxx   x xx" "xxxxxxxxx  xx x  xx  xx   xxxx" "xxxxxxxxx  x  xxx xx xx      x" "xxxxxxxxx  x  xxx  xxxx     xx" "xxxxxxxxx  x  xxx  xxx      xx" " xxxxxxxxx xx x  xxxx       xx" " xxxxxxxxx  xxx xxxx        xx" "  xxxxxxxx  xx  xxxx       xxx" "  xxxxxxxxx xxxxxxx       xxxx" "   xxxxxx xxxxxxxx          xx" "    xxxx     x  xxx        xxx" "     xxx     x  xxx      xxxxx" "      xxx   xx   xxxx   xxxxxx" "       xxxxxx     xxxxxxxxxxxx"))) (make-problem "19991113eBAR (18)" (quote ((6) (1 8) (11 1) (12) (1 6) (2 1 7 1) (1 2 7) (5 10) (6 9) (4 8) (7 8) (5 8) (2 10) (2 2 9) (1 3 13) (1 2 3 8) (6 4 3 5) (1 1 1 4 3) (6 9) (7 8) (8 8) (8 8) (8 5 2) (8 6 1) (18) (17) (16) (14) (12) (10))) (quote ((4) (2 1 1 1) (2 2 2 1 1) (2 4 2 1 1) (11 2 1) (4 7 7) (4 1 5 1 7) (4 3 1 9) (6 1 10) (6 3 17) (17 12) (16 11) (13 1 10) (12 7) (2 11 6) (11 6) (13 6) (2 7 6) (1 1 2 6) (2 7) (3 6) (4 6) (11) (10) (8) (5) (5) (5) (6) (6))) (quote ("             xxxx             " "      xx  x  x  x             " " xx    xx xx  x x             " "  xx xxxx xx  x x             " " xxxxxxxxxxx xx x             " "xxxx   xxxxxxx  xxxxxxx       " "xxxx x  xxxxx  x  xxxxxxx     " "xxxx    xxx    x  xxxxxxxxx   " "xxxxxx        x   xxxxxxxxxx  " "xxxxxx xxx  xxxxxxxxxxxxxxxxx " "xxxxxxxxxxxxxxxxx xxxxxxxxxxxx" " xxxxxxxxxxxxxxxx  xxxxxxxxxxx" "  xxxxxxxxxxxxx x   xxxxxxxxxx" "   xxxxxxxxxxxx        xxxxxxx" "  xx xxxxxxxxxxx        xxxxxx" "      xxxxxxxxxxx       xxxxxx" "     xxxxxxxxxxxxx      xxxxxx" "       xx xxxxxxx       xxxxxx" "       x    x xx        xxxxxx" "              xx       xxxxxxx" "              xxx      xxxxxx " "               xxxx   xxxxxx  " "                xxxxxxxxxxx   " "                xxxxxxxxxx    " "                xxxxxxxx      " "                  xxxxx       " "                 xxxxx        " "                 xxxxx        " "                 xxxxxx       " "                  xxxxxx      "))) (make-problem "19991115aBAR (19)" (quote ((3 11) (3 9) (4 8) (5 6) (6 5) (12 4) (6 3) (8 3) (1 7 2) (8 2) (3 2 2) (2 4 1) (7 1) (10 1) (11 1) (3 4 4 1) (9 4 4) (10 4 1) (9 3 1) (13 1) (13 1) (13 1) (13 2) (8 3 2) (7 4 2) (4 2 1 2 3) (6 3 3) (6 4 4) (5 1 2 5) (4 6))) (quote ((3) (4) (4) (4) (3) (2) (2) (1) (1 2 1 2) (1 1 3 2 5) (6 4 5 6) (11 13) (9 4 9) (27) (25) (6 13 3) (4 12 2) (1 1 3 7) (1 2 6) (1 1 3 6) (1 2 7) (2 2 6) (3 2 3 3) (3 3 2) (4 3 1) (5 1 2) (6 2 3) (8 1 5) (11 1 8) (30))) (quote ("                           xxx" "                          xxxx" "                          xxxx" "                          xxxx" "                          xxx " "                          xx  " "                         xx   " "                         x    " "     x  xx x            xx    " "x    x   xxx   xx    xxxxx    " "xxxxxx xxxx  xxxxx xxxxxx     " "xxxxxxxxxxx xxxxxxxxxxxxx     " " xxxxxxxxx xxxx xxxxxxxxx     " "  xxxxxxxxxxxxxxxxxxxxxxxxxxx " "   xxxxxxxxxxxxxxxxxxxxxxxxx  " "    xxxxxx xxxxxxxxxxxxx  xxx " "     xxxx   xxxxxxxxxxxx   xx " "     x x    xxx xxxxxxx       " "     x       xx  xxxxxx       " "x    x       xxx xxxxxx       " "x             xx   xxxxxxx    " "xx             xx  xxxxxx     " "xxx            xx xxx  xxx    " "xxx             xxx     xx    " "xxxx            xxx          x" "xxxxx            x          xx" "xxxxxx          xx         xxx" "xxxxxxxx        x        xxxxx" "xxxxxxxxxxx     x     xxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/problems/k30x35 b/collects/games/paint-by-numbers/problems/k30x35
new file mode 100644
index 0000000000..c43916694b
--- /dev/null
+++ b/collects/games/paint-by-numbers/problems/k30x35
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 30x35") (define problems (list (make-problem "19990507aJOJ (1)" (quote ((6 2 1 3 1 2 1 1 4) (5 1 1 1 4 1 1 1 1 3) (5 1 1 1 1 1 1 1 1 1) (4 1 1 1 1 1 2 1 1 1 3) (2 1 1 3 2 2 3 3 1) (1 2 18 2) (1 23) (2 21 2) (1 25) (3 22 2) (3 11 8 3) (2 10 7 2) (2 5 6 1) (1 5 2 2 5) (3 1 1 1 1 2) (2 1 1 1 1 1 1 1 1 1) (2 1 1 1 2 1 1 1 1) (2 1 2 4 2 1 1) (2 1 6 1 2) (1 3 6 3) (2 2 6 2 1) (3 2 2 4 2 2 1) (3 2 3 3 2 1) (4 2 5 5 2 2) (4 2 12 2 3) (3 4 6 3 3) (1 7 5 2) (3 4 3 2 1) (29) (1 8 2) (12 10) () (30) () (30))) (quote ((7 6 3 8 3 1 1) (5 1 4 5 6 2 1 1 1) (4 1 1 2 2 2 5 2 1 1 1) (4 1 1 4 2 2 3 1 1 1) (3 1 1 6 3 4 2 1 1 1 1) (1 1 8 1 6 1 1 1 1) (1 1 8 4 1 1 1 1) (1 1 8 1 2 1 1 1 1) (2 1 7 2 3 1 1 1) (1 8 2 3 1 1 1) (2 9 2 3 2 1 1 1) (1 8 1 1 2 2 1 1 1) (2 1 7 1 1 1 2 2 1 1) (2 7 1 1 3 3 2 1 1) (2 8 2 5 2 2 1 1) (2 5 6 2 2 1 1) (1 7 6 2 2 1 1) (9 2 5 2 2 1 1) (1 6 1 1 3 3 2 1 1) (1 8 1 1 1 2 2 1 1) (2 8 1 1 2 2 1 1 1) (1 9 2 3 2 1 1 1) (1 8 2 3 1 1 1) (1 10 2 2 1 1 1 1) (1 1 10 1 3 1 1 1 1) (1 1 8 1 4 1 1 1 1) (1 1 1 1 3 3 5 3 1 1 1) (2 1 1 1 1 3 4 2 2 1 1 1) (2 1 1 1 3 2 2 4 3 1 1) (3 1 1 4 4 8 2 1 1))) (quote ("xxxxxxx xxxxxx xxx xxxxxxxx xxx x x" "xxxxx  x xxxx xxxxx xxxxxx xx x x x" "xxxx x x xx  xx   xx xxxxx xx x x x" "xxxx x  x  xxxx    xx  xx xxx x x x" "xxx x x xxxxxx xxx xxxx  xx x x x x" "x  x  xxxxxxxx    x  xxxxxx x x x x" " x  x xxxxxxxx         xxxx x x x x" "x x  xxxxxxxx        x   xx x x x x" "xx x xxxxxxx         xx   xxx x x x" "  x xxxxxxxx          xx  xxx x x x" "xx xxxxxxxxx   xx     xxx  xx x x x" "  x xxxxxxxx  x  x     xx  xx x x x" "xx x xxxxxxx x x x     xx   xx  x x" "xx  xxxxxxx  x  x xxx  xxx  xx  x x" "xx xxxxxxxx   xx xxxxx  xx  xx  x x" " xx  xxxxx      xxxxxx  xx  xx  x x" "x  xxxxxxx      xxxxxx  xx  xx  x x" " xxxxxxxxx    xx xxxxx  xx  xx  x x" "x    xxxxxx  x  x xxx  xxx  xx  x x" "x  xxxxxxxx  x x x     xx   xx  x x" " xx xxxxxxxx  x  x     xx  xx x x x" "x  xxxxxxxxx   xx     xxx  xx x x x" "  x  xxxxxxxx         xx  xxx x x x" " x xxxxxxxxxx        xx  xx x x x x" "x x xxxxxxxxxx       x  xxx x x x x" " x  x xxxxxxxx    x    xxxx x x x x" "x  x  x x  xxx xxx xxxxx  xxx x x x" "xx x x  x x xxx    xxxx xx xx x x x" "xx x x x xxx xx   xx   xxxx xxx x x" "xxx x  x xxxx  xxxx xxxxxxxx xx x x"))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/problems/k30x40 b/collects/games/paint-by-numbers/problems/k30x40
new file mode 100644
index 0000000000..47435bbeda
--- /dev/null
+++ b/collects/games/paint-by-numbers/problems/k30x40
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 30x40") (define problems (list (make-problem "19980514-KVL (1)" (quote ((14) (14) (16) (18) (20) (1 7 6) (1 3 4 4) (3 9 3) (5 8 2) (1 4 8 2) (1 1 13 1) (1 1 5 1 1) (1 1 2 1) (1 1 1 3 1) (3 1 1 6 1) (5 1 9 1) (1 4 8 2) (1 1 10 2) (1 1 8 3) (1 1 2 4 4) (1 4 6) (3 13) (5 11) (1 4 11) (1 1 15) (1 1 14) (1 1 1 11) (1 1 3 3) (3 4 2) (5 2 2) (1 4 2 2) (1 15) (1 14) (1 1 14) (1 14) (3 13) (5 11) (7 11) (18) (16))) (quote (() () () () () (34) (2 2 2 2 2 4) (3 2 2 2 2 5) (6 5 2 1 5 2 1 4) (6 2 2 2 2 4) (7 2 2 2 2 3) (7 2 4 3 5 5 3) (8 2 1 3 2 5 2) (6 1 2 2 2 2 5 2) (6 12 20) (5 7 5 19) (5 6 5 8 9) (5 5 6 6 1 9) (5 5 7 6 9) (6 4 6 7 9) (6 4 6 7 9) (7 3 4 8 9) (6 2 2 10 9) (7 23) (34) () () () () ())) (quote #f)) (make-problem "19990224aJOJ (2)" (quote ((13 1 1) (14 1) (1 14) (7 1 1 13) (8 3 12) (2 2 1 3 11) (2 2 4 11) (2 2 1 3 11) (2 2 4 11) (2 2 1 3 11) (8 3 12) (7 1 1 13) (1 14) (14 1) (13 1 1 3 2) (12 3 3 2) (11 3 1 4 2) (11 4 5 2) (11 3 1 2 2 2) (11 4 2 5) (11 3 1 2 4) (12 3 2 3) (13 1 1 2 3) (14 1) (1 14) (4 1 1 13) (6 3 12) (2 2 1 3 11) (2 2 4 11) (8 1 3 11) (8 4 11) (2 2 1 3 11) (2 2 3 12) (2 2 1 1 13) (1 14) (14 1) (13 1 1) (12 3) (11 3 1) (11 4))) (quote ((2 11 5) (2 9 11 6 5) (2 9 11 8 5) (2 2 2 11 3 2 5) (2 2 2 11 2 2 5) (2 2 2 11 2 2 5) (2 2 2 11 3 2 5) (2 9 11 8 5) (2 7 11 6 5) (2 11 5) (2 11 5) (2 5 3 3 5 3) (2 1 1 1 1 2 1 1 1 2 1 1 1 1 2 1) (1 2 1 1 2 1 1 1 1 1 2 1 1 2 1 1) (1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1) (1 1 1 1 1 1 2 1 1 2 1 1 1 1 1 2 1) (2 1 1 1 2 1 1 1 1 2 1 1 1 2 1 1) (3 3 5 3 3 2) (11 11) (11 11) (11 9 11) (11 9 11) (11 4 11) (11 4 11) (11 4 11) (11 4 11) (11 9 11) (11 9 11) (11 11))) (quote ("xx           xxxxxxxxxxx           xxxxx" "xx xxxxxxxxx xxxxxxxxxxx    xxxxxx xxxxx" "xx xxxxxxxxx xxxxxxxxxxx  xxxxxxxx xxxxx" "xx xx     xx xxxxxxxxxxx xxx xx    xxxxx" "xx xx     xx xxxxxxxxxxx xx  xx    xxxxx" "xx xx     xx xxxxxxxxxxx xx  xx    xxxxx" "xx xx     xx xxxxxxxxxxx xxx xx    xxxxx" "xx xxxxxxxxx xxxxxxxxxxx  xxxxxxxx xxxxx" "xx  xxxxxxx  xxxxxxxxxxx    xxxxxx xxxxx" "xx           xxxxxxxxxxx           xxxxx" "xx           xxxxxxxxxxx           xxxxx" "xx   xxxxx   xxx     xxx   xxxxx   xxx  " "xx  x x x x  xx x x x xx  x x x x  xx x " " x xx x x xx x  x x x  x xx x x xx x  x " "x x x x x x x x x x x x x x x x x x x x " " x x x x x x x x x x x x x x x x x x x x" "x x  x x x  x xx x x xx x  x x x  x xx x" "  xx x x x xx  x x x x  xx x x x xx  x x" "  xxx     xxx   xxxxx   xxx     xxx   xx" "  xxxxxxxxxxx           xxxxxxxxxxx     " "  xxxxxxxxxxx           xxxxxxxxxxx     " "  xxxxxxxxxxx xxxxxxxxx xxxxxxxxxxx     " "  xxxxxxxxxxx xxxxxxxxx xxxxxxxxxxx     " "  xxxxxxxxxxx xxxx      xxxxxxxxxxx     " "  xxxxxxxxxxx   xxxx    xxxxxxxxxxx     " "  xxxxxxxxxxx    xxxx   xxxxxxxxxxx     " "  xxxxxxxxxxx      xxxx xxxxxxxxxxx     " "  xxxxxxxxxxx xxxxxxxxx xxxxxxxxxxx     " "  xxxxxxxxxxx xxxxxxxxx xxxxxxxxxxx     " "  xxxxxxxxxxx           xxxxxxxxxxx     "))) (make-problem "19990507bJOJ (3)" (quote ((2 1 1 2 1 1 1) (2 1 1 1 1 1 1 3) (3 1 1 1 1 2 1 1) (2 11 2) (3 12 2) (2 12 2) (13 2) (1 2 14 2) (2 1 16) (18) (3 9) (2 2) (2 2) (2 2) (2 2) (2 2) (2 8 2) (2 10 2) (2 2) (3 3 3 3) (3 2 1 1 2 3) (2 1 2 2 2 1 2) (2 1 1 2 2 2 1 1 2) (2 1 2 1 1 2 1 2) (2 1 3 2 3 1 2) (2 1 4 1 2) (2 4 2) (2 6 2) (2 6 2) (2 6 2) (2 4 2) (2 2) (2 12 2) (2 3 2 2) (3 7 3) (6 6) (3 6 6 3) (2 1 1 11 1 1 2) (3 1 1 1 3 1 1 1 3) (2 1 1 1 2 2 1 1 1 2))) (quote (() (1) (3 2) (5 2) (1 1 2 2 2 4) (2 1 1 2 3 6 2) (1 2 1 1 4 1 13) (1 1 1 1 5 4) (1 1 1 2 4 6) (2 2 2 6 4 1 2) (1 1 2 4 1 2 2 2 5) (1 8 2 1 2 1 2 2 1) (9 2 1 2 1 3 3 2) (1 7 2 1 1 6 1 1 2) (9 2 2 7 1 1 2) (1 7 2 2 7 1 1 2) (10 2 1 1 6 1 1 2) (8 2 1 2 1 3 1 1 2) (10 2 1 2 1 3 2) (1 9 1 2 2 2 2 1) (1 9 4 1 5) (1 2 1 8 2) (1 1 4 6 6) (1 1 1 3 5 4) (2 1 1 1 1 3 1 13) (1 1 1 1 2 3 6 2) (2 1 2 2 2 4) (1 5 2) (3 2) (1))) (quote #f)) (make-problem "19990525bKHO (4)" (quote ((2) (2) (2) (2) (2) (2) (4) (10) (2 2) (1 4 1) (1 1 1 1) (1 1 4 1 1) (1 1 1 1) (1 1 4 1 1) (1 1 1 1) (1 4 1) (1 1) (12) (1 1) (1 1 2 1 1) (1 2 2 2 1) (1 1) (1 2 2 2 1) (1 2 2 2 1) (1 1) (1 2 2 2 1) (1 2 2 2 1) (1 1) (1 2 2 2 1) (1 2 2 2 1) (1 1) (1 2 2 2 1) (1 1 2 1 1) (1 1) (1 3 1) (1 5 1) (1 5 1) (1 3 1) (2 2) (10))) (quote (() () () () () () () (31) (2 1 2) (1 3 1 1 2 2 2 1 1) (1 1 1 1 2 2 2 2 2 2 1) (1 1 1 1 1 1 4 1) (1 1 1 1 1 1 2 2 2 2 2 4 1) (1 1 1 1 1 1 2 2 2 2 2 4 1) (2 1 1 1 1 1 2 1) (8 1 1 1 2 2 2 2 2 1) (8 3 1 1 2 2 2 1 1) (3 1 2) (31) () () () () () () () () () () ())) (quote #f)) (make-problem "19990611-KVL (5)" (quote (() (9) (13) (11 2) (9 6 1) (6 5) (4 2) (3 2) (3 1) (4 2) (4 1) (5 1) (5 1) (10 2 1) (11 7 3) (12 1 2) (12 5 2) (12 4 2) (13 2 1) (12) (4 2) (5 3) (5 3) (6 7) (13) (12) (11) (10) (13 1) (10) (10) (10) (7) (6) (7) (10 2) (14 2) (16 2) (15 3) (15 4))) (quote ((1) (7 3) (18 3) (20 4) (25 4) (16 12 5) (4 9 17) (5 7 16) (4 7 16) (5 7 17) (4 7 19) (4 27) (4 18 6) (4 4 3 5 5) (3 1 1 2 5) (4 1 1 1 3) (4 1 2 1 2) (2 1 6) (1 1 2 3 1) (1 2 1 2) (3 1 1) (1 1 1) (2) (2) (2) (3 1 1) (10 5) (4 4) (2) (1))) (quote ("                                       x" "                  xxxxxxx            xxx" "         xxxxxxxxxxxxxxxxxx          xxx" "       xxxxxxxxxxxxxxxxxxxx         xxxx" "     xxxxxxxxxxxxxxxxxxxxxxxxx      xxxx" "    xxxxxxxxxxxxxxxx xxxxxxxxxxxx  xxxxx" "   xxxx    xxxxxxxxx   xxxxxxxxxxxxxxxxx" "  xxxxx      xxxxxxx    xxxxxxxxxxxxxxxx" "  xxxx       xxxxxxx    xxxxxxxxxxxxxxxx" " xxxxx       xxxxxxx   xxxxxxxxxxxxxxxxx" " xxxx        xxxxxxx xxxxxxxxxxxxxxxxxxx" " xxxx        xxxxxxxxxxxxxxxxxxxxxxxxxxx" " xxxx         xxxxxxxxxxxxxxxxxx  xxxxxx" " xxxx          xxxx    xxx xxxxx   xxxxx" " xxx                   x    x xx   xxxxx" " xxxx         x        x    x       xxx " " xxxx         x xx          x       xx  " " xx x        xxxxxx                     " "  x x        xx xxx         x           " "  x xx        x xx                      " "   xxx        x x                       " "   x x        x                         " "    xx                                  " "     xx                                 " "      xx                                " "       xxx    x                    x    " "         xxxxxxxxxx                xxxxx" "              xxxx                  xxxx" "                                      xx" "                                       x"))) (make-problem "19990612-ARE (6)" (quote ((9) (3 3) (4 5) (20 5) (23 1) (2 19 5) (18 1) (1 17 5) (1 15) (1 13 5) (1 5 10 1 1) (5 9 5) (4 7 1 1) (4 11 1 1) (4 1 10) (4 12 3) (3 1 4 6 1) (2 1 4 6 1) (1 6 1) (1 1 5 3) (1 1 7) (1 5 1) (2 7 1) (1 3 4 1) (6 1) (6 5) (2 4) (2 4 5) (2 4 1 1) (9 1 1) (8 1 1) (6 5) (6) (8 5) (10 1 1) (10 5) (10 1 1) (9 1 1) (6 1) (2 1))) (quote ((1) (3 2) (4 9 1 2 1) (3 6 3) (4 8) (5 7 1) (1 4 2 2) (1 5 1 2) (1 6 1 1 1 2) (1 8 1 1 1 2 6) (1 8 5 2 7) (1 9 5 1 3 6) (1 10 5 2 1 11) (1 10 4 1 10) (1 13 1 1 2 11) (1 16 1 1 14) (1 36) (1 26 6) (1 25 3) (23) (10 8) (6) (5) (3) () (3 1 5 5 5 5) (1 1 1 1 1 1 1 1 1 1 1 1) (1 1 1 1 1 5 1 1 1 1 1) (1 1 1 1 1 1 1 1 1 1 1 2) (1 3 5 1 5 3 1))) (quote #f)) (make-problem "19990715-TAN (7)" (quote ((17) (2 2) (2 6 6 2) (2 6 6 2) (2 5 5 2) (2 9 1 6 2) (2 4 9 2) (1 5 3 4 1) (1 9 4 6 1) (1 4 5 3 1) (1 3 4 2 1) (1 7 6 3 1) (1 5 1) (1 4 2 2 7) (1 3 1 1 3 2) (1 3 1 3 5) (1 3 1 2 6) (1 5 1 2) (1 7 2 2) (1 4 4 1 2) (2 2 2 4 1) (2 2 1 2 4 1) (2 3 3 3 1) (4 7 1) (2 3 1) (1 1 4 2 1) (6 2 6 1) (1 1 1) (1 4 3 2 4 1) (1 4 2 4 4 1 2 1) (1 3 2 4 2 1) (1 3 8 12 1) (1 11 11 1) (2 9 9 2) (2 8 8 2) (2 5 5 2) (2 2 2 2) (2 13 2) (2 2) (17))) (quote ((15 8) (2 2 1 2) (2 11 2 1 4 2) (2 13 2 1 5 2) (2 15 1 1 6 2) (2 5 3 5 4 2 3 2) (2 5 2 5 1 2 5 2) (1 6 1 1 1 1 8 1) (1 4 1 2 3 1 1 1 2 9 1) (1 4 1 1 2 3 5 1 1) (1 4 2 1 3 1 5 1 1) (1 2 1 1 1 1 2 4 1 1) (1 2 1 1 2 4 1 1) (1 1 1 2 2 1 1) (1 1 1) (1 1 2 2 1 1) (1 2 2 1 2 4 1 1) (1 2 1 2 1 1 4 1 1) (1 5 2 1 2 1 2 1 5 1 1) (1 5 2 1 3 2 2 1 5 1 1) (1 5 1 1 3 1 2 1 9 1) (1 4 2 1 2 1 1 2 7 1) (2 5 1 5 2 1 2 6 2) (2 4 4 2 1 1 1 5 2) (2 4 1 1 1 6 1 1 3 2) (2 5 1 2 7 5 2) (2 4 1 2 11 2) (2 1 2 2) (8 15) ())) (quote #f)) (make-problem "19990803aDAH (8)" (quote ((30) (1 1) (1 2 2 3 2 3 1) (1 1 1 1 1 1 1 2 1) (1 2 3 1 1 2 1 1 1 1) (1 3 2 1 1 7 1) (1 1 1 1 1 3 2 1) (1 3 6 1 2 2 1) (1 2 1 1 2 1 1 2 1 1) (1 1 2 1 6 1 2 1) (1 6 2 3 2 1 1 1 1) (1 1 1 3 3 6 1) (1 2 3 2 1 3 1 1) (1 1 2 2 2 4 1 1) (1 3 3 7 3 1 1) (1 3 1 8 3 3 1) (1 1 16 4 1) (1 4 12 1 1 1) (1 1 10 2 1 1) (1 1 1 3 9 1 1 1) (1 5 7 4 2 1) (1 1 7 4 1) (1 6 1) (1 6 1) (1 6 1) (1 6 1) (12 6 10) (12 6 10) (12 6 10) (12 6 10) (12 6 9) (10 7 7) (8 3 1 1 3 6) (7 3 2 1 2 2) (3 2 3 3 5 1) (1 5 2 1 2 2 2 1) (1 1 1 1 3 1 3 1 1) (1 3 2 3 4 2 2 3 1) (1 1) (30))) (quote ((40) (1 9 1) (1 2 2 2 2 2 9 2 1) (1 1 1 1 1 1 8 1 1) (1 2 2 1 1 2 1 3 8 3 1) (1 2 5 3 1 8 1 1) (1 1 1 1 1 2 2 8 1 1 1) (1 6 2 2 1 1 7 3 1) (1 1 1 1 1 4 6 2 1) (1 3 3 3 4 6 2 1 1) (1 1 1 1 1 2 5 1 1 1) (1 5 2 4 5 2 2 1) (1 1 2 1 2 9 1 2 1) (1 1 1 19 4 1) (1 5 24 2 1 1) (1 3 25 1 1) (1 1 3 2 18 1 1) (1 3 2 22 1) (1 3 20 1 1 1) (1 2 1 1 4 2 4 1) (1 1 3 3 2 2 3 4 1 1 1) (1 1 1 1 1 1 1 5 2 1 1) (1 4 2 2 4 2 5 5 1) (1 1 2 1 1 1 2 6 3 1) (1 3 1 3 2 3 1 7 1 2 1) (1 1 1 1 2 1 1 7 1 1 1) (1 1 3 1 2 7 2 1 1) (1 2 2 2 3 7 2 1) (1 8 1) (40))) (quote ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "x                         xxxxxxxxx    x" "x     xx  xx xx xx xx     xxxxxxxxx xx x" "x      x  x   x  x  x     xxxxxxxx   x x" "x  xx  xx x x xx x xxx    xxxxxxxx xxx x" "x   xx  xxxxx  xxx  x     xxxxxxxx x   x" "x x  x    x  x xx  xx     xxxxxxxx x x x" "x xxxxxx  xx xx x  x      xxxxxxx  xxx x" "x   x  x   x  x xxxx      xxxxxx  xx   x" "x xxx xxx xxx xxxx        xxxxxx xx  x x" "x x    x  x x   xx        xxxxx  x   x x" "x    xxxxx  xx xxxx       xxxxx xx  xx x" "x x xx x xx  xxxxxxxxx          x  xx  x" "x x       x   xxxxxxxxxxxxxxxxxxx xxxx x" "x xxxxx xxxxxxxxxxxxxxxxxxxxxxxx xx  x x" "x     xxx  xxxxxxxxxxxxxxxxxxxxxxxxx x x" "x x xxx   xx  xxxxxxxxxxxxxxxxxx     x x" "x xxx    xx  xxxxxxxxxxxxxxxxxxxxxx    x" "x      xxx  xxxxxxxxxxxxxxxxxxxx  x  x x" "x     xx x   x  xxxx           xx xxxx x" "x x xxx xxx xx xx xxx     xxxx  x  x   x" "x x  x   x  x  x    x     xxxxx xx   x x" "x xxxx  xx xx xxxx xx     xxxxx  xxxxx x" "x    x xx  x  x x   xx    xxxxxx  xxx  x" "x  xxx x xxx xx xxx  x    xxxxxxx x xx x" "x  x x     x   xx x  x    xxxxxxx x  x x" "x    x   xxx   x    xx    xxxxxxx xx x x" "x       xx xx xx  xxx     xxxxxxx  xx  x" "x                         xxxxxxxx     x" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"))) (make-problem "19990803bDAH (9)" (quote ((30) (1 1 1 1 1 1 1 1) (1 1 4 1 1 1 1 3 1 1 1) (1 1 1 1 1 1 3 1 1 1) (1 4 3 3 2 1 2 2 2) (1 1 1 5 1 1 1 1) (1 1 1 5 2 2 2 2) (1 2 1 1 1 1 1 1 1 1) (1 1 3 3 1 2 1 2 1 1) (2 1 1 1 1 1 1 1 1 3 1) (1 1 2 2 1 3 1 2 4 1 1) (1 2 1 1 1 1 1 1 1 1) (1 3 2 4 1 6 2 1) (2 1 1 1 1 1 1 1) (1 1 6 1 5 3 1 2) (1 2 1 1 1 1 1) (1 1 2 1 1 2 1 10) (6 1 1 2 2 1 1 1 1) (1 1 2 1 1 4 1) (1 4 1 5 1 1 1 1 1) (1 1 1 6 1 3 1 2 1) (1 2 1 1 1 1 1 1 1) (1 1 1 5 7 3 1 1) (1 4 1 1 1 1) (1 1 1 1 3 13 1) (1 6 1 1 1 1 1 1 1 1 1 1) (1 1 1 2 1 2) (1 3 6 1 2 2 1) (1 1 1 1 2 4 4 1) (1 1 1 1 1 3 1 9 1) (1 1 1 1 1 1 1 1 9 1) (1 1 1 1 1 2 2 1 7 2) (1 1 1 2 7 3) (1 3 3 1 3 1 5 2) (1 1 1 1 1 1 1 3 1 1) (1 1 1 1 1 5 1 2 1 2 1) (1 1 1 1 1 1 1 2 1) (1 3 1 4 2 1 5 3) (1 1 1) (30))) (quote ((1 38) (1 1 1 1 1) (5 1 1 1 1 3 3 1 3 1 2 2) (1 1 10 1 1 1 1 1 1 1 1) (1 3 1 1 1 1 1 5 3 1 1) (1 1 4 2 1 4 5 1 1 1) (1 1 1 1 1 5 3 1 1) (1 3 3 1 1 5 4 1 1 1) (1 1 1 5 1 1 1 1 3 5 1) (1 3 1 1 1 1 1 1 6 1) (1 1 3 3 1 1 7 3 1) (1 5 3 1 1 1 2 1 1 1 1 1 1) (1 1 1 1 4 2 1 1 1 1 1 1 1) (1 4 2 3 1 1 1 3 5 1 1) (1 1 1 1 1 2 4 1 1 1) (4 1 6 1 2 1 1 5 1 1) (1 1 1 2 1 2 1 1 8 1) (1 1 2 6 1 1 1 1 1) (1 1 1 1 1 4 1 2 2 3 4 1) (3 1 3 1 1 6 1 1) (1 3 3 2 6 1 2 7 2 1) (3 1 1 3 1 7 1 1) (1 3 1 1 3 3 1 3 7 1 1) (2 2 5 1 1 1 1 7 1 1) (1 2 2 1 5 2 7 2 1) (2 2 2 2 1 1 1 1 6 2 1) (1 3 1 3 1 1 1 2 3 2 1) (3 5 1 7 1 1 1) (1 1 1 1 1 1 3 1 1) (40))) (quote #f)) (make-problem "19991021-BBA (10)" (quote ((3 2) (5 2) (5 5 2) (5 1 3) (1 3 3 9) (3 5 1 3) (3 3 1 5 2) (3 5 1 1 2) (3 5 3 2) (4 5 1 2) (6 5 2 2) (5 3 7 2) (4 3 9 2) (3 4 13) (1 6 1 8) (8 4 2) (2 3 2 2) (1 1 1 1 1 2) (4 2 2 2) (3 4 1) (2 3 1 1) (2 2 2) (10) (10) (1 1) (9) (9) (8) (8) (8) (7) (7) (2 2 4 3) (1 1 4 4) (9 4 4) (7 4 3) (1 1 1 5 3) (5 9) (5 9) (3 4 5))) (quote ((3) (1 2) (5) (3 2 3) (6 6) (7 2 3) (3 2 3 5) (5 3 1 2) (5 4 3) (5 5 6 4) (3 3 15 8) (6 3 2 2 15) (12 2 1 2 15) (13 2 2 14) (2 17 7 3) (6 4 2 3 15) (2 2 1 2 2 15) (4 2 1 3 15) (5 11 2 1) (3) (3) (3 3) (1 1 2 4) (1 1 1 1 4) (1 1 1 2 4) (1 1 1 1 3) (1 1 2 3) (3 2) (19) (19))) (quote #f)))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/problems/k35x25 b/collects/games/paint-by-numbers/problems/k35x25
new file mode 100644
index 0000000000..017a564176
--- /dev/null
+++ b/collects/games/paint-by-numbers/problems/k35x25
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 35x25") (define problems (list (make-problem "19980530-GOS (1)" (quote ((16 14) (13 12) (10 10) (9 1 3 2 1 9) (9 1 1 1 1 1 1 1 8) (9 1 1 1 1 1 3 7) (8 1 1 1 3 1 1 1 2) (8 2 1 1 1 1 1) (8 1) (7 2 4 2) (7 2 2 4 1 1 5) (6 2 3 1 1 3 3) (5 3 4 3 2 1) (5 2 2 2 2 2 1 1) (5 2 2 2 2 1 4 5) (1 2 6 4 6) (2 4 1 6) (2 3 2 5 7) (3 2 1 9 7) (3 3 9 8) (7 7 8) (4 9) (2 1 11) (4 4 12) (14 14))) (quote ((16 3) (15 3) (15 3 2) (15 5 2) (15 5 1) (12 2 1) (11 3 1) (9 4 2) (6 9 2) (3 9 3) (2 4 2) (2 4 5 1) (2 1 5 1) (1 4 4 2 1 1) (1 1 3 2 3) (1 5 5 3) (1 5 3) (4 3) (1 1 1 2 3) (5 1 3 4) (1 2 1 4) (1 5 1 1 1 3 1) (1 1 3 1 2 1) (2 4 1 2) (2 1 2 3) (3 1 3 3) (4 1 2 1 4) (5 1 1 1 6) (6 3 1 8) (7 10) (6 1 11) (6 1 11) (6 2 11) (7 3 11) (7 17))) (quote ("xxxxxxxxxxxxxxxx      xxx" "xxxxxxxxxxxxxxx       xxx" "xxxxxxxxxxxxxxx   xxx  xx" "xxxxxxxxxxxxxxx  xxxxx xx" "xxxxxxxxxxxxxxx  xxxxx  x" "xxxxxxxxxxxx        xx  x" "xxxxxxxxxxx        xxx  x" "xxxxxxxxx        xxxx  xx" "xxxxxx      xxxxxxxxx  xx" "xxx      xxxxxxxxx    xxx" "xx       xxxx          xx" "xx xxxx       xxxxx     x" "xx     x     xxxxx      x" "x   xxxx  xxxx xx  x    x" "x  x      xxx  xx xxx    " "x  xxxxx   xxxxx  xxx    " "   x        xxxxx xxx    " "    xxxx          xxx    " "   x  x    x  xx  xxx    " "   xxxxx  x  xxx xxxx    " "          x xx x xxxx    " "x  xxxxx  x x  x xxx    x" "x    x    xxx x  xx     x" "xx  xxxx         x     xx" "xx        x  xx       xxx" "xxx      x  xxx       xxx" "xxxx     x xx x      xxxx" "xxxxx    x x  x    xxxxxx" "xxxxxx   xxx x   xxxxxxxx" "xxxxxxx        xxxxxxxxxx" "xxxxxx    x   xxxxxxxxxxx" "xxxxxx    x   xxxxxxxxxxx" "xxxxxx    xx  xxxxxxxxxxx" "xxxxxxx  xxx  xxxxxxxxxxx" "xxxxxxx xxxxxxxxxxxxxxxxx"))) (make-problem "19980616-HEI (2)" (quote ((1 1 4 8 1) (3 1 6 10 3) (1 6 10 3) (1 6 16) (1 1 1 1 6 6 1) (1 3 1 8 6 1) (1 1 1 6 1) (1 1 1 6 1 1 1) (1 6 1 1 1) (9 7 5 1 1 1) (9 4 1) (2 1 2 3 1) (2 3 2 2 1) (2 1 2 11) (2 2) (3 2 2 1 2 2) (4 2 1 1 1 1 1 2) (5 2 2 1 2 2 4) (5 2 1 1 1 1 2 5) (5 2 2 6) (5 15 7) (2 15 6) (1 2 6 1) (2 6) (5 8))) (quote ((1 1 6 1) (1 4 1 6 1 1) (2 1 6 1) (2 1 9) (1 1 8) (4 1) (1) (1 9) (10 10) (2 2) (1 2 4 2) (5 2 1 1 2) (6 2 1 1 2) (6 2 1 2) (6 5 4 2) (6 2 1 2) (5 2 4 2) (1 2 1 1 2) (2 1 2) (9 2 2) (10 10) (11 9) (12) (13) (14) (4 1) (4 1) (3 1 1 4) (3 1 1 1 5) (1 1 6) (11 7) (1 1 8) (3 1 1 1 8) (3 1 1 4 1) (4 1 4 1 1))) (quote (" x       x     xxxxxx   x" " x  xxxx x     xxxxxx x x" "xx       x     xxxxxx   x" "    xx   x      xxxxxxxxx" "     x   x       xxxxxxxx" "    xxxx x               " "         x               " "         x   xxxxxxxxx   " "xxxxxxxxxx  xxxxxxxxxx   " "           xx       xx   " "     x    xx   xxxx xx   " " xxxxx   xx    x x  xx   " "xxxxxx   xx     x x xx   " "xxxxxx   xx x       xx   " "xxxxxx   xxxxx xxxx xx   " "xxxxxx   xx x       xx   " " xxxxx   xx    xxxx xx   " "     x   xx    x x  xx   " "          xx    x   xx   " "xxxxxxxxx  xx       xx   " "xxxxxxxxxx  xxxxxxxxxx   " "xxxxxxxxxxx  xxxxxxxxx   " "xxxxxxxxxxxx             " "xxxxxxxxxxxxx            " "xxxxxxxxxxxxxx           " "xxxx         x           " "xxxx         x           " " xxx    x    x       xxxx" " xxx   x x   x      xxxxx" "   x         x     xxxxxx" "   xxxxxxxxxxx    xxxxxxx" "   x         x   xxxxxxxx" " xxx   x x   x   xxxxxxxx" " xxx    x    x   xxxx   x" "xxxx         x   xxxx x x"))) (make-problem "19980716aGAS (3)" (quote (() () (11) (5 5) (3 1 1 3) (3 2 5 2 3) (2 2 5 2 2) (2 4 5 4 2) (1 6 5 6 1) (2 7 7 7 2) (1 27 1) (1 27 1) (1 27 1) (1 27 1) (1 27 1) (2 4 13 4 2) (1 3 1 5 1 3 1) (2 1 1 5 1 1 2) (2 1 1 1 2) (3 1 3) (3 3) (5 5) (11) () ())) (quote (() () (7) (3 3) (2 5 2) (2 9 2) (1 9 1) (2 11 2) (1 9 1 1) (2 9 2) (1 10 1) (1 1 7 1) (2 8 2) (2 6 2) (1 7 1) (1 14 1) (1 13 1) (1 15 1) (1 13 1) (1 14 1) (1 7 1) (2 6 2) (2 8 2) (1 1 7 1) (1 10 1) (2 9 2) (1 9 1 1) (2 11 2) (1 9 1) (2 9 2) (2 5 2) (3 3) (7) () ())) (quote ("                         " "                         " "         xxxxxxx         " "       xxx     xxx       " "      xx  xxxxx  xx      " "     xx xxxxxxxxx xx     " "     x  xxxxxxxxx  x     " "    xx xxxxxxxxxxx xx    " "    x  xxxxxxxxx  x x    " "   xx xxxxxxxxx     xx   " "   x xxxxxxxxxx      x   " "   x x   xxxxxxx     x   " "  xx      xxxxxxxx   xx  " "  xx      xxxxxx     xx  " "  x      xxxxxxx      x  " "  x xxxxxxxxxxxxxx    x  " "  x  xxxxxxxxxxxxx    x  " "  x  xxxxxxxxxxxxxxx  x  " "  x  xxxxxxxxxxxxx    x  " "  x xxxxxxxxxxxxxx    x  " "  x      xxxxxxx      x  " "  xx      xxxxxx     xx  " "  xx      xxxxxxxx   xx  " "   x x   xxxxxxx     x   " "   x xxxxxxxxxx      x   " "   xx xxxxxxxxx     xx   " "    x  xxxxxxxxx  x x    " "    xx xxxxxxxxxxx xx    " "     x  xxxxxxxxx  x     " "     xx xxxxxxxxx xx     " "      xx  xxxxx  xx      " "       xxx     xxx       " "         xxxxxxx         " "                         " "                         "))) (make-problem "19990119-JAM (4)" (quote (() (7) (7) (8) (9) (9) (9) (6 2) (5 1) (6 2) (9) (9) (3 5) (2 1 5) (3 14 7) (8 8 1 7) (7 8 5 3) (8 5 8 1 3) (5 7 8 4) (4 1 7 14) (4 13 8) (17 6) (15 6) (19) ())) (quote (() () () () (17) (21) (12 8) (11 1 7) (12 5 3) (7 9 1 2) (6 9 4) (7 7 7) (11 6) (3 7) (10) (10) (10) (4 5) (3 4) (4 5) (10) (1 8) (1 4 2) (1 4 1) (7 2) (10) (10) (3 6) (2 1 5) (3 5) (7) (5) (3) () ())) (quote ("                         " "                         " "                         " "                         " "   xxxxxxxxxxxxxxxxx     " " xxxxxxxxxxxxxxxxxxxxx   " " xxxxxxxxxxxx xxxxxxxx   " " xxxxxxxxxxx x xxxxxxx   " " xxxxxxxxxxxx xxxxx xxx  " " xxxxxxx xxxxxxxxx x xx  " " xxxxxx   xxxxxxxxx xxxx " " xxxxxxx xxxxxxx xxxxxxx " "    xxxxxxxxxxx   xxxxxx " "             xxx xxxxxxx " "              xxxxxxxxxx " "              xxxxxxxxxx " "              xxxxxxxxxx " "              xxxx xxxxx " "              xxx   xxxx " "              xxxx xxxxx " "              xxxxxxxxxx " "              x xxxxxxxx " "               x xxxx xx " "              x xxxx   x " "              xxxxxxx xx " "              xxxxxxxxxx " "              xxxxxxxxxx " "              xxx xxxxxx " "              xx x xxxxx " "              xxx xxxxx  " "               xxxxxxx   " "                xxxxx    " "                 xxx     " "                         " "                         "))) (make-problem "19990208aFRA (5)" (quote ((1 24) (31) (1 29) (3 28) (3 2 27) (2 2 8 8) (2 2 5 11 7) (3 6 2 1 2 6) (9 2 1 2 5) (8 2 1 3 5) (4 2 1 3 4) (3 26 3) (2 28 2) (2 29 2) (1 30 1) (30) (35) (3 3) (5 5) (2 2 2 2) (5 5) (3 3) () (8 8 8 4) ())) (quote ((1 5 1) (10 1 1) (1 6 3 1) (3 4 4 3 1) (3 2 2 10 1) (2 2 4 8 2 1) (2 2 3 11 1) (3 5 6 3 1) (9 6 1) (8 6) (7 6) (7 7 1) (6 8 1) (6 2 6 1) (5 2 6 1) (5 2 6 1) (5 1 6 1) (5 1 6 1) (5 1 6 1) (5 1 6) (5 11) (5 1 6 1) (5 1 6 1) (5 1 6 1) (5 1 6 1) (5 11 3 1) (5 15 1) (6 10 2 1) (7 11 1) (8 6 3) (10 6) (11 5 1) (12 1 1) (14 1 1) (15 1 1))) (quote ("     x    xxxxx x        " "    xxxxxxxxxx  x      x " "    x xxxxxx  xxx      x " "   xxx xxxx  xxxx xxx  x " " xxx xx xx  xxxxxxxxxx x " "xx xx xxxx xxxxxxxx xx x " " xx xx xxx xxxxxxxxxxx x " " xxx xxxxx xxxxxx xxx  x " " xxxxxxxxx xxxxxx      x " " xxxxxxxx  xxxxxx        " " xxxxxxx   xxxxxx        " "xxxxxxx   xxxxxxx      x " "xxxxxx   xxxxxxxx      x " "xxxxxx  xx xxxxxx      x " "xxxxx  xx  xxxxxx      x " "xxxxx xx   xxxxxx      x " "xxxxx x    xxxxxx      x " "xxxxx x    xxxxxx      x " "xxxxx x    xxxxxx      x " "xxxxx x    xxxxxx        " "xxxxx xxxxxxxxxxx        " "xxxxx x    xxxxxx      x " "xxxxx x    xxxxxx      x " "xxxxx x    xxxxxx      x " "xxxxx x    xxxxxx      x " "xxxxx xxxxxxxxxxx xxx  x " "xxxxx  xxxxxxxxxxxxxxx x " "xxxxxx   xxxxxxxxxx xx x " "xxxxxxx    xxxxxxxxxxx x " "xxxxxxxx   xxxxxx xxx    " "xxxxxxxxxx xxxxxx        " "xxxxxxxxxxx xxxxx      x " "xxxxxxxxxxxx    x      x " "xxxxxxxxxxxxxx  x      x " "xxxxxxxxxxxxxxx x      x "))) (make-problem "19990220aFRA (6)" (quote ((35) (22 10) (21 3 9) (17 1 3 9) (16 3 3 9) (16 4 3 9) (9 2 4 2 9) (8 2 1 10) (7 3 9) (6 1 8) (5 7) (5 3 2) (4 9 1 1) (3 1 8 9 3) (2 5 8 5 3 1) (1 28 1 2) (30 3) (31 2) (1 31 1) (2 20) (4 5 13) (5 3 14) (6 26) (35) (35))) (quote ((16 7) (15 2 6) (14 4 5) (13 5 5) (12 7 4) (10 7 3) (9 8 2) (8 8 2) (7 7 2) (6 6 3) (6 1 5 4) (6 1 10) (6 12) (6 12) (7 12) (8 12) (4 2 12) (3 3 1 12) (3 3 1 11) (3 3 11) (4 3 10) (2 1 10) (1 4 2 10) (1 5 2 10) (1 5 1 7 3) (2 1 7 3) (9 7 3) (10 7 3) (11 7 3) (14 4 3) (13 1 3 3) (12 3 2 3) (11 3 1 1 3) (12 1 3 3) (13 5 3))) (quote ("xxxxxxxxxxxxxxxx  xxxxxxx" "xxxxxxxxxxxxxxx xx xxxxxx" "xxxxxxxxxxxxxx xxxx xxxxx" "xxxxxxxxxxxxx xxxxx xxxxx" "xxxxxxxxxxxx xxxxxxx xxxx" "xxxxxxxxxx    xxxxxxx xxx" "xxxxxxxxx     xxxxxxxx xx" "xxxxxxxx      xxxxxxxx xx" "xxxxxxx        xxxxxxx xx" "xxxxxx         xxxxxx xxx" "xxxxxx       x xxxxx xxxx" "xxxxxx       x xxxxxxxxxx" "xxxxxx       xxxxxxxxxxxx" "xxxxxx       xxxxxxxxxxxx" "xxxxxxx      xxxxxxxxxxxx" "xxxxxxxx     xxxxxxxxxxxx" "xxxx   xx    xxxxxxxxxxxx" "xxx xxx x    xxxxxxxxxxxx" "xxx xxx x     xxxxxxxxxxx" "xxx xxx       xxxxxxxxxxx" "xxxx xxx       xxxxxxxxxx" "xx           x xxxxxxxxxx" "x xxxx      xx xxxxxxxxxx" "x xxxxx     xx xxxxxxxxxx" "x xxxxx  x  xxxxxxx   xxx" "xx     x    xxxxxxx   xxx" "xxxxxxxxx   xxxxxxx   xxx" "xxxxxxxxxx  xxxxxxx   xxx" "xxxxxxxxxxx xxxxxxx   xxx" "xxxxxxxxxxxxxx xxxx   xxx" "xxxxxxxxxxxxx x xxx   xxx" "xxxxxxxxxxxx xxx xx   xxx" "xxxxxxxxxxx xxx x x   xxx" "xxxxxxxxxxxx x xxx    xxx" "xxxxxxxxxxxxx xxxxx   xxx"))) (make-problem "19990220bFRA (7)" (quote ((35) (8 9 3 1 4) (7 9 3 3) (6 8 3 3) (6 8 4 4) (1 4 4 2 4 5) (1 3 3 15) (1 1 1 2 1 4 1 4) (1 2 1 1 2 5 2 1 4) (1 4 2 2 4 5 2 4) (1 5 5 5 15) (1 6 6 1 1 2 2 1) (1 7 7 1 1 1 2 1 1 1) (1 6 6 1 1 1 2 1 1 1) (1 7 7 1 1 1 1 1) (1 8 8 1 2 2 1 1 1) (1 8 8 1 1 1 2 1 1 1) (1 8 8 1 1 1 2 1 1 1) (1 8 8 1 1 1 1 1 1 1) (1 8 8 15) (1 7 7 15) (3 5 5 17) (5 3 3 19) (7 1 1 21) (8 22))) (quote ((25) (5 4) (6 5 5 4) (7 5 7 3) (7 12 3) (8 13 2) (3 1 12 2) (2 1 12 1) (1 2 11) (1 1 12) (1 1) (1 1 12) (1 2 11) (2 1 12 1) (3 1 12 2) (8 13 2) (8 12 3) (7 5 7 3) (6 5 5 4) (5 4) (25) (11 6) (1 3 5 2 9) (1 5 1 6) (1 3 1 17) (7 1 6) (7 3 2 3 6) (2 21) (1 2 2 6) (2 1 1 1 2 10) (1 2 2 6) (2 21) (11 6) (11 6 6) (12 7))) (quote ("xxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxx                xxxx" "xxxxxx xxxxx   xxxxx xxxx" "xxxxxxx xxxxx xxxxxxx xxx" "xxxxxxx  xxxxxxxxxxxx xxx" "xxxxxxxx xxxxxxxxxxxxx xx" "xxx     x xxxxxxxxxxxx xx" "xx       x xxxxxxxxxxxx x" "x        xx xxxxxxxxxxx  " "x         x xxxxxxxxxxxx " "x         x              " "x         x xxxxxxxxxxxx " "x        xx xxxxxxxxxxx  " "xx       x xxxxxxxxxxxx x" "xxx     x xxxxxxxxxxxx xx" "xxxxxxxx xxxxxxxxxxxxx xx" "xxxxxxxx xxxxxxxxxxxx xxx" "xxxxxxx xxxxx xxxxxxx xxx" "xxxxxx xxxxx   xxxxx xxxx" "xxxxx                xxxx" "xxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxx        xxxxxx" "x xxx xxxxx xx  xxxxxxxxx" "x     xxxxx    x   xxxxxx" "x xxx x xxxxxxxxxxxxxxxxx" "xxxxxxx   x        xxxxxx" "xxxxxxx xxx xx xxx xxxxxx" "xx  xxxxxxxxxxxxxxxxxxxxx" "x    xx   xx       xxxxxx" "xx    x x x xx xxxxxxxxxx" "x    xx   xx       xxxxxx" "xx  xxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxx        xxxxxx" "xxxxxxxxxxx xxxxxx xxxxxx" "xxxxxxxxxxxx      xxxxxxx"))) (make-problem "19990305-FRA (8)" (quote ((12 20) (12 1 3 1 14) (12 1 3 1 2 5 4) (12 3 1 1 1 1 1 2 1) (3 3 1 1 1 1 1 2 1 2) (1 7 2 2 1 1 1 2 3) (9 9 1 1 2 1 2) (11 12 1 2 2) (13 19) (14 19) (6 7 19) (5 2 6 7 9) (5 2 6 4 9) (6 7 2 10) (15 11) (15 13) (14 16) (14 18) (14 10) (13 9) (13 8) (11 21) (9 22) (1 7 23) (2 7 24))) (quote ((6 13 2) (5 15 1) (5 17) (4 20) (4 20) (4 6 12) (4 5 2 11) (4 5 2 11) (4 6 12) (4 20) (4 17) (5 15 1) (2 13 2) (2 3 10 3) (2 6 4) (5 3 4) (4 9 4) (14 1 4) (1 7 1 4) (5 7 2 4) (1 6 2 4) (12 2 4) (3 5 3 4) (2 1 6 3 4) (3 4 4 4) (11 6 4) (3 12 4) (3 3 17) (25) (2 17) (5 19) (4 1 18) (3 3 17) (25) (2 1 16))) (quote ("xxxxxx  xxxxxxxxxxxxx  xx" "xxxxx  xxxxxxxxxxxxxxx  x" "xxxxx xxxxxxxxxxxxxxxxx  " "xxxx xxxxxxxxxxxxxxxxxxxx" "xxxx xxxxxxxxxxxxxxxxxxxx" "xxxx xxxxxx  xxxxxxxxxxxx" "xxxx xxxxx xx xxxxxxxxxxx" "xxxx xxxxx xx xxxxxxxxxxx" "xxxx xxxxxx  xxxxxxxxxxxx" "xxxx xxxxxxxxxxxxxxxxxxxx" "xxxx  xxxxxxxxxxxxxxxxx  " "xxxxx  xxxxxxxxxxxxxxx  x" "    xx  xxxxxxxxxxxxx  xx" " xx xxx  xxxxxxxxxx   xxx" "      xx  xxxxxx     xxxx" "xxxxx xxx            xxxx" "xxxx xxxxxxxxx       xxxx" "xxxxxxxxxxxxxx   x   xxxx" "x     xxxxxxx    x   xxxx" "xxxxx xxxxxxx   xx   xxxx" "x     xxxxxx    xx   xxxx" "xxxxxxxxxxxx    xx   xxxx" "xxx    xxxxx   xxx   xxxx" "xx x xxxxxx    xxx   xxxx" "xxx    xxxx   xxxx   xxxx" "xxxxxxxxxxx  xxxxxx  xxxx" "xxx     xxxxxxxxxxxx xxxx" "xxx xxx xxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxx" "xx      xxxxxxxxxxxxxxxxx" "xxxxx xxxxxxxxxxxxxxxxxxx" "xxxx x xxxxxxxxxxxxxxxxxx" "xxx xxx xxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxx" "xx     x xxxxxxxxxxxxxxxx"))) (make-problem "19990909-PIP (9)" (quote ((8) (2 2) (5 2 2 5) (1 3 1 1 3 1) (1 1 1 1 1 1) (2 2 2 3) (8 3 6 3 6 1) (1 1 10 1 1) (1 1 3 2 1 1 1) (9 1 6 1 9) (8 1 3 1 1 2 1 8) (9 1 1 1 1 1 2 9) (9 2 1 1 1 1 9) (8 2 1 1 1 1 1 8) (8 1 1 1 1 1 2 8) (8 2 1 1 1 1 1 1 8) (8 1 1 1 1 1 1 2 8) (8 2 1 1 1 1 1 1 8) (7 3 1 1 1 1 2 7) (1 1 1 1 1 1 2 1) (1 4 1 1 3 1) (1 10 1) (1 6 1) (2 2) (6))) (quote (() () (13) (3 10) (1 1 10) (1 1 10) (1 1 10) (1 1 10) (2 1 10) (2 1 10) (3 3 2 2) (2 1 6 1) (3 1 2 3 1 4 1) (2 3 1 1 1 1 2 1) (2 2 2 1 1 3 1) (1 2 2 1 1 1 3 1) (1 2 1 1 1 1 1 1 2 1) (1 2 2 1 1 1 1 3 1) (1 2 1 1 1 1 1 1 2 1) (1 2 2 1 1 1 1 3 1) (1 2 1 1 1 1 1 1 2 1) (2 1 1 1 1 1 1 2 1) (2 3 2 1 1 1 3 1) (3 1 2 2 1 1 3 1) (2 1 6 1) (3 3 2 2) (2 1 10) (2 1 10) (1 1 10) (1 1 10) (1 1 10) (1 2 11) (2 1 10) (2 10) ())) (quote #f)) (make-problem "19991011aLLO (10)" (quote ((5 14) (7 12) (9 10) (9 2 2) (7 2 2) (5 2 2) (5 2 2) (5 1 2 2) (5 3 2 2) (5 3 10) (17 1) (1 3 1 6 1 1) (2 1 6 6) (3 8 1 2 1 1) (3 10 11 1 1) (2 3 4 1 1) (1 15 4 3 1 1) (1 15 1 1 2 1 1) (17 1 1 1 3 1 1) (17 1 2 2 1 1) (4 4 9) (4 2 2 7 2 1 3) (2 4 4 1 1 1 1 1 1 1) (1 4 4 6 1 1) (2 2 4))) (quote ((3) (3) (2 3) (4 4) (2 11) (4 1 2 2) (11 3 4) (12 1 4 4) (12 1 4 2) (12 1 4) (11 1 4 2) (4 1 2 4 4) (2 1 2 4 4) (3 2 4 2) (4 2 4 1) (3 2 4 3) (1 2 4 1 1) (1 1 4 3) (1 1 1 4 1 1) (2 1 3 3) (18 3 1) (10 3 1 1 1) (3 1 2 2 1 1 1) (3 1 2 1 1 1 1 1 1) (3 1 2 1 1 1 1 1) (3 1 2 1 1 1 1 1) (3 1 2 1 1 1 1 1 1) (3 1 2 2 1 1 1) (10 3 1 1 1) (22) (2 9) (1 1 2) (10) (1 2) (10))) (quote ("                     xxx " "                    xxx  " "             xx    xxx   " "            xxxx  xxxx   " "  xx      xxxxxxxxxxx    " " xxxx     x       xx  xx " "xxxxxxxxxxx      xxx xxxx" "xxxxxxxxxxxx  x xxxx xxxx" "xxxxxxxxxxxx  x xxxx  xx " "xxxxxxxxxxxx  x xxxx     " "xxxxxxxxxxx   x xxxx  xx " " xxxx     x  xx xxxx xxxx" "  xx      x  xx xxxx xxxx" "        xxx  xx xxxx  xx " "       xxxx  xx xxxx x   " "        xxx  xx xxxx xxx " "          x  xx xxxx x x " "          x  x  xxxx xxx " "x         x  x  xxxx x x " "xx        x     xxx  xxx " "xxxxxxxxxxxxxxxxxx xxx x " "xxxxxxxxxx    xxx x x x  " "xxx      x xx xx x  x  x " "xxx      x xx x x x x x x" "xxx      x xx x x  x x  x" "xxx      x xx x x  x x  x" "xxx      x xx x x x x x x" "xxx      x xx xx x  x  x " "xxxxxxxxxx    xxx x x x  " "xxxxxxxxxxxxxxxxxxxxxx   " "xx          xxxxxxxxx    " "x           x       xx   " "            xxxxxxxxxx   " "            x       xx   " "           xxxxxxxxxx    "))) (make-problem "19991013-KHO (11)" (quote (() (1) (1) (5) (1 4) (7) (5 1) (2 3 3) (4 1 1) (5 1) (17 2) (20 3) (21 3) (12 8) (10 7) (8 7) (5 6) (3 1 4) (2 2 6) (1 2 2 3) (1 1 2 2) (2 1 2 2) (2 1 2 2) (1 2 1 1) (2 2 2 2))) (quote (() (2) (3) (3 5 1) (1 2 7 4) (4 15) (1 3 12) (16 1) (3 10 2 2) (7 7) (6) (5) (5) (4) (4) (3) (3) (3) (6) (7) (8) (9) (10) (7 3 1) (4 2 4) (2 2) (1 3) (2 3 1) (1 1 4) (1 2) (1 1) (3) () () ())) (quote ("                         " "      xx                 " "     xxx                 " "    xxx    xxxxx        x" "   x xx   xxxxxxx    xxxx" "   xxxx xxxxxxxxxxxxxxx  " " x xxx xxxxxxxxxxxx      " "  xxxxxxxxxxxxxxxx      x" "   xxx xxxxxxxxxx xx   xx" "         xxxxxxx xxxxxxx " "          xxxxxx         " "          xxxxx          " "          xxxxx          " "          xxxx           " "          xxxx           " "          xxx            " "          xxx            " "          xxx            " "          xxxxxx         " "          xxxxxxx        " "          xxxxxxxx       " "           xxxxxxxxx     " "           xxxxxxxxxx    " "            xxxxxxx xxx x" "             xxxx xx xxxx" "            xx    xx     " "            x     xxx    " "           xx       xxx x" "        x  x         xxxx" "       x  xx             " "       x  x              " "       xxx               " "                         " "                         " "                         "))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/problems/k35x30 b/collects/games/paint-by-numbers/problems/k35x30
new file mode 100644
index 0000000000..d0e8576aa5
--- /dev/null
+++ b/collects/games/paint-by-numbers/problems/k35x30
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 35x30") (define problems (list (make-problem "19980420-KVL (1)" (quote (() () () (4) (7) (9) (8 2) (5 6) (4 6) (5 4 2) (6 4 2) (2 10 4) (20) (1 1) (21) (21) (2 7 7 1) (2 3 3 6 3) (11 2 2 4) (19 4 1) (7 8 5 2) (2 3 7 3 1) (6 7 3 2) (6 8 6 1) (2 4 5 2 1 3 2) (1 10 2 4 1) (2 11 3 5 1) (10 4 4 5 2) (21 8) ())) (quote ((17) (4 11 3) (6 2 3 2 2) (5 1 2 7 3) (8 15) (9 15) (4 3 7 5) (4 2 3 2 4) (4 2 6 4) (5 3 6 4) (10 7 3 1) (2 6 2 10) (8 2 10) (4 2 2 10) (2 1 11 2) (2 2 10 1) (4 4 5 1) (3 11 2) (2 6 6) (1 4 4) (4 3) () (1) (2) (3 2) (4 1) (7 1) (3 8) (1 7) (6) (4) (3) (3 1) (2 3 2) (4))) (quote ("            xxxxxxxxxxxxxxxxx " "         xxxx xxxxxxxxxxx xxx " "       xxxxxx xx  xxx xx   xx " "      xxxxx x xx  xxxxxxx xxx " "     xxxxxxxx xxxxxxxxxxxxxxx " "    xxxxxxxxx xxxxxxxxxxxxxxx " "    xxxx  xxx xxxxxxx   xxxxx " "   xxxx    xx xxx xx     xxxx " "   xxxx    xx xxxxxx     xxxx " "   xxxxx  xxx xxxxxx     xxxx " "   xxxxxxxxxx xxxxxxx   xxx x " "    xx xxxxxx xx   xxxxxxxxxx " "     xxxxxxxx xx   xxxxxxxxxx " "      xxxx xx xx   xxxxxxxxxx " "       xx   x xxxxxxxxxxx  xx " "        xx xx xxxxxxxxxx    x " "         xxxx xxxx xxxxx    x " "          xxx xxxxxxxxxxx  xx " "           xx xxxxxx   xxxxxx " "            x xxxx       xxxx " "             xxxx         xxx " "                              " "                    x         " "                   xx         " "                  xxx  xx     " "                  xxxx x      " "                 xxxxxxx    x " "                xxx  xxxxxxxx " "                 x    xxxxxxx " "                       xxxxxx " "                         xxxx " "                          xxx " "                    xxx     x " "                   xx xxx  xx " "                        xxxx  "))) (make-problem "19980716bGAS (2)" (quote ((5) (5 4 1) (8 5 4) (10 4 7) (10 13) (10 9) (10 9) (10 9) (10 2 9) (10 2 9) (10 6 9) (10 6 9) (10 1 4 1 9) (10 3 4 3 9) (10 10 9) (10 12 9) (10 10 9) (10 6 9) (10 1 2 1 9) (10 2 9) (10 2 9) (10 2 9) (10 9) (10 9) (10 9) (14 9) (8 4 9) (5 5 8) (2 4 5) (5))) (quote ((26) (26) (26) (26) (26) (26) (26) (26) (26) (26) (1 1) (1 1) (2 1 1 1) (1 5 2) (1 4 1) (2 2 5 1) (1 8 2) (1 14 1) (1 14 1) (2 8 1) (1 2 5 2) (1 4 1) (2 5 1) (1 1 1 2) (1 1) (1 1) (26) (26) (26) (26) (26) (26) (26) (26) (26))) (quote ("   xxxxxxxxxxxxxxxxxxxxxxxxxx " "   xxxxxxxxxxxxxxxxxxxxxxxxxx " "  xxxxxxxxxxxxxxxxxxxxxxxxxx  " "  xxxxxxxxxxxxxxxxxxxxxxxxxx  " "  xxxxxxxxxxxxxxxxxxxxxxxxxx  " " xxxxxxxxxxxxxxxxxxxxxxxxxx   " " xxxxxxxxxxxxxxxxxxxxxxxxxx   " " xxxxxxxxxxxxxxxxxxxxxxxxxx   " "xxxxxxxxxxxxxxxxxxxxxxxxxx    " "xxxxxxxxxxxxxxxxxxxxxxxxxx    " "x                        x    " "x                        x    " "xx           x x         x    " " x          xxxxx        xx   " " x           xxxx         x   " " xx       xx  xxxxx       x   " "  x       xxxxxxxx        xx  " "  x     xxxxxxxxxxxxxx     x  " "  x     xxxxxxxxxxxxxx     x  " "  xx      xxxxxxxx         x  " "   x      xx  xxxxx        xx " "   x         xxxx           x " "   xx       xxxxx           x " "    x        x x            xx" "    x                        x" "    x                        x" "    xxxxxxxxxxxxxxxxxxxxxxxxxx" "    xxxxxxxxxxxxxxxxxxxxxxxxxx" "   xxxxxxxxxxxxxxxxxxxxxxxxxx " "   xxxxxxxxxxxxxxxxxxxxxxxxxx " "   xxxxxxxxxxxxxxxxxxxxxxxxxx " "  xxxxxxxxxxxxxxxxxxxxxxxxxx  " "  xxxxxxxxxxxxxxxxxxxxxxxxxx  " "  xxxxxxxxxxxxxxxxxxxxxxxxxx  " " xxxxxxxxxxxxxxxxxxxxxxxxxx   "))) (make-problem "19981201-JAM (3)" (quote ((8 7 18) (7 1 5 1 5 10) (7 2 3 3 3 2 9) (6 4 5 3 9) (3 7 5 5 8) (3 3 6 2 1 6 3) (4 3 3 2 7 3) (5 3 1 3 4 2 5 1 3) (6 3 4 3 2 2 3) (6 2 1 1 4 4 3 3) (5 2 3 6 2 3 1 3 2) (3 2 3 1 4 4 1 2 4 1) (2 2 3 2 3 5 4 4) (3 2 4 2 5 1 4 2 1) (3 2 5 1 4 3 4 1 1) (3 1 3 3 3 4 5 2) (2 1 3 4 1 2 1 6 4 2) (1 3 2 5 1 1 7 3 3) (4 3 2 1 2 3 1 3 2) (1 3 3 3 5 1 3 1) (2 4 3 2 7 2) (3 3 2 2 4 5 4 3 1) (4 4 5 4 3 3 2) (6 4 6 2 2 1 4 2) (6 3 2 4 1 4 6 1) (6 2 5 2 6 4) (5 2 1 6 1 8 2) (4 2 3 6 2 3 5) (5 2 2 1 2 2 1 6) (9 4 6 4 7))) (quote ((18 11) (17 1 10) (12 3 2 9) (4 5 5 8) (4 1 4 1 2 5 4 2) (4 2 2 2 1 1 3 3 1 1) (3 3 2 4 2 2 1) (1 2 5 2 5 5 1) (5 3 3 1 2 5 1 1) (1 5 1 3 2 1 4 3) (2 5 3 2 3 2 1 2) (3 3 1 1 3 3 2 3 1) (3 2 3 4 2 3 3 2) (3 2 2 1 3 1 2 2 2 2) (2 1 2 2 3 2 3 3 1) (1 4 4 1 1 5 3) (5 1 6 1 1 5 2 1) (1 3 2 4 1 1 5 1 1) (2 2 2 2 3 1 2 3 1 1) (3 2 1 1 6 4 2 1) (3 6 1 6 2) (3 2 2 5 2 5 2 2) (2 3 3 3 3 4 4) (1 5 3 1 5 2 5 1) (1 6 3 6 1 4 2) (2 4 2 1 5 2 3 2) (4 4 3 2 4 3 1) (5 3 6 1 3 1 3) (5 2 1 6 1 1 2 2 1) (5 1 4 6 4 2) (5 6 6 5 3) (5 4 2 2 5 3) (10 4 1 1 1 2 3) (11 1 4 2 4) (12 7 4 4))) (quote ("xxxxxxxxxxxxxxxxxx xxxxxxxxxxx" "xxxxxxxxxxxxxxxxx x xxxxxxxxxx" "xxxxxxxxxxxx xxx xx  xxxxxxxxx" "xxxx  xxxxx     xxxxx xxxxxxxx" "xxxx x xxxx x xx xxxxx xxxx xx" "xxxx xx xx xx x x  xxx xxx x x" "xxx  xxx  xx   xxxx xx    xx x" "x  xx xxxxx xx xxxxx  xxxxx  x" " xxxxx xxx xxx x  xx xxxxx x x" "x xxxxx x xxx   xx x xxxx xxx " "xx xxxxx xxx xx xxx   xx x xx " "xxx xxx x x xxx xxx xx  xxx  x" "xxx xx xxx xxxx xx xxx  xxx xx" "xxx xx xx x  xxx x xx xx xx xx" "xx x   xx xx  xxx xx xxx xxx x" "x xxxx    xxxx x x  xxxxx xxx " " xxxxx x xxxxxx x x xxxxx xx x" "x xxx xx xxxx   x x  xxxxx x x" "xx xx xx xx  xxx x xx  xxx x x" "xxx xx x x xxxxxx  xxxx   xx x" "xxx       xxxxxx x xxxxxx   xx" "xxx xx xx xxxxx xx xxxxx xx xx" "xx xxx xxx xxx xxx xxxx xxxx  " "x xxxxx xxx x xxxxx xx xxxxx x" "x xxxxxx xxx xxxxxx x  xxxx xx" "xx  xxxx xx x xxxxx  xx xxx xx" "xxxx xxxx  xxx  xx  xxxx xxx x" "xxxxx xxx xxxxxx  x xxx x xxx " "xxxxx xx x  xxxxxx x x xx xx x" "xxxxx x xxxx xxxxxx   xxxx  xx" "xxxxx  xxxxxx xxxxxx xxxxx xxx" "xxxxx     xxxx xx xx xxxxx xxx" "xxxxxxxxxx xxxx  x x x  xx xxx" "xxxxxxxxxxx x  xxxx   xx  xxxx" "xxxxxxxxxxxx xxxxxxx xxxx xxxx"))) (make-problem "19990205-FRA (4)" (quote ((11 23) (10 1 11 4 2) (9 3 9 1 1) (8 5 8 1) (7 7 7 1) (6 9 6 1) (5 11 6 2) (4 13 6 3) (3 15 6 4) (2 17 6 5) (1 6 6) (1 1 1 13) (1 2 2 13) (1 3 3 5 5) (1 5 5 4 4) (1 6 6 4 4) (1 7 8 3 4) (1 8 8 3 1) (1 7 3 7 3) (1 6 5 6 3) (1 5 7 5 3) (1 4 9 4 3 1) (1 3 11 3 3 3) (1 2 13 2 13) (1 1 15 1 13) (1 17 13) (1 13) (35) (35) (35))) (quote ((30) (10 3) (9 14 3) (8 1 12 1 3) (7 2 10 2 3) (6 3 8 3 3) (5 4 7 4 3) (4 5 5 5 3) (3 6 3 6 3) (2 7 1 7 3) (1 8 8 3) (9 8 3) (1 8 8 3) (2 7 2 7 3) (3 6 3 6 3) (4 5 5 5 3) (5 4 7 4 3) (6 3 8 3 3) (7 2 10 2 3) (8 1 12 1 3) (9 14 3) (10 3) (30) (2 24) (1 23) (1 8 7) (2 5 7) (2 3 7) (3 2 7) (2 3 7) (1 5 7) (1 9 7) (1 10 8) (2 11 8) (18 9))) (quote ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxx                 xxx" "xxxxxxxxx  xxxxxxxxxxxxxx  xxx" "xxxxxxxx x  xxxxxxxxxxxx x xxx" "xxxxxxx xx   xxxxxxxxxx xx xxx" "xxxxxx xxx    xxxxxxxx xxx xxx" "xxxxx xxxx    xxxxxxx xxxx xxx" "xxxx xxxxx     xxxxx xxxxx xxx" "xxx xxxxxx      xxx xxxxxx xxx" "xx xxxxxxx       x xxxxxxx xxx" "x xxxxxxxx        xxxxxxxx xxx" " xxxxxxxxx        xxxxxxxx xxx" "x xxxxxxxx        xxxxxxxx xxx" "xx xxxxxxx      xx xxxxxxx xxx" "xxx xxxxxx      xxx xxxxxx xxx" "xxxx xxxxx     xxxxx xxxxx xxx" "xxxxx xxxx    xxxxxxx xxxx xxx" "xxxxxx xxx    xxxxxxxx xxx xxx" "xxxxxxx xx   xxxxxxxxxx xx xxx" "xxxxxxxx x  xxxxxxxxxxxx x xxx" "xxxxxxxxx  xxxxxxxxxxxxxx  xxx" "xxxxxxxxxx                 xxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xx    xxxxxxxxxxxxxxxxxxxxxxxx" "x      xxxxxxxxxxxxxxxxxxxxxxx" "x       xxxxxxxx       xxxxxxx" "xx       xxxxx         xxxxxxx" "xx        xxx          xxxxxxx" "xxx        xx          xxxxxxx" "xx        xxx          xxxxxxx" "x        xxxxx         xxxxxxx" "x       xxxxxxxxx      xxxxxxx" "x      xxxxxxxxxx     xxxxxxxx" "xx    xxxxxxxxxxx     xxxxxxxx" "xxxxxxxxxxxxxxxxxx   xxxxxxxxx"))) (make-problem "19991010aTPV (5)" (quote (() () (12) (7 7) (8 4 8) (3 3 3 3) (3 4 8 4 3) (4 10 4) (11 11) (9 4 9) (9 9) (1 18 3) (3 14 7) (1 3 2 2 2 3 1 1 3) (2 1 10 1 1 3 1) (3 1 1 1 1 1 1 1 3) (4 1 1 1 1 1 2 1 2) (3 3 1 1 1 3 1 1 2) (5 14 6 3) (7 2 2 2 10 1 2) (22 6) (18 2 2) (12 3 2) (2 1 2) (1 1 2) (1 1 2) (2 3 1) (3 3) (5) ())) (quote (() (3 4) (5 6) (17) (2 4 1 1 3) (2 1 5 5) (2 1 4 5 3) (2 1 6 5) (3 1 6 5) (4 6 5 3) (13 5) (2 4 5 5) (1 1 2 1 2 1 1 3) (1 1 2 1 12) (1 1 2 1 4 5) (1 1 2 1 2 1 1 3) (2 4 5 5) (21) (4 6 1 1 3) (3 1 6 5) (2 1 6 5) (2 1 4 5 3) (2 1 5 5) (2 4 1 1 3) (17) (5 2 2 6) (3 3 2 1 3) (1 6 1 2) (3 2 1 1 1) (2 9) (1 1 3 2) (3 1 1 1 1) (12) (8) ())) (quote ("                              " "      xxx      xxxx           " "     xxxxx    xxxxxx          " "    xxxxxxxxxxxxxxxxx         " "    xx xxxx x   x xxx         " "   xx x xxxxx    xxxxx        " "   xx x xxxx xxxxx xxx        " "   xx x xxxxxx   xxxxx        " "  xxx x xxxxxx    xxxxx       " "  xxxx xxxxxx xxxxx xxx       " "  xxxxxxxxxxxxx   xxxxx       " "  xx xxxx xxxxx   xxxxx       " "  x x xx x xx x   x xxx       " "  x x xx x xxxxxxxxxxxx       " "  x x xx x xxxx   xxxxx       " "  x x xx x xx x   x xxx       " "  xx xxxx xxxxx   xxxxx       " "  xxxxxxxxxxxxxxxxxxxxx       " "  xxxx xxxxxx x   x xxx       " "  xxx x xxxxxx    xxxxx       " "   xx x xxxxxx   xxxxx        " "   xx x xxxx xxxxx xxx        " "   xx x xxxxx    xxxxx        " "    xx xxxx x   x xxx         " "    xxxxxxxxxxxxxxxxx         " "     xxxxx xx     xx   xxxxxx " "      xxx  xxx    xx   x  xxx " "            x xxxxxx  x    xx " "            xxx    xx x   x x " "             xx     xxxxxxxxx " "             x x   xxx    xx  " "              xxx x x    x x  " "               xxxxxxxxxxxx   " "                 xxxxxxxx     " "                              "))) (make-problem "19991118-BDH (6)" (quote ((35) (1 1) (1 7 1) (1 11 4) (5 11 1 1) (1 1 15 3 1) (1 1 1 3) (1 6 3 1) (1 1 5 1) (1 1 1 1) (1 3 12) (8 1) (1 1) (1 1) (3 3) (1 11 5 1) (1 1 1 1) (13 1 1) (2 2 1) (2 8) (2 7 1) (1 9 1) (1 7 7 1) (1 8 5 8 1) (1 9 5 9 1) (1 11 3 11 1) (1 12 3 12 1) (1 12 1 12 1) (1 12 3 12 1) (1 12 3 12 1))) (quote ((30) (1 1 1 1 4) (1 1 1 2 1 4) (1 1 1 1 1 5) (1 4 1 1 1 6) (1 1 1 1 1 7) (1 1 1 1 1 8) (1 1 2 1 1 8) (1 1 1 1 1 8) (1 4 1 1 8) (1 1 1 1 8) (1 1 1 1 8) (1 3 3 8) (1 3 1 5) (1 4 2) (1 4 2 2) (1 4 2 4 2) (1 4 2 7) (1 4 2 4 2) (1 4 2 2) (1 4 2) (1 3 1 5) (1 3 8) (1 1 3 8) (1 1 1 1 8) (1 1 1 8) (1 1 1 8) (1 2 1 2 8) (1 1 1 5 8) (1 3 1 1 1 7) (1 1 1 1 1 6) (1 3 1 1 1 5) (1 1 1 1 2 1 4) (1 1 1 1 1 1) (30))) (quote ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "x   x      x  x  xxxx         " "x   x      x  xx x        xxxx" "x   x      x   x x       xxxxx" "x   xxxx   x   x x      xxxxxx" "x      x   x   x x     xxxxxxx" "x      x   x   x x    xxxxxxxx" "x      x  xx   x x    xxxxxxxx" "x      x  x    x x    xxxxxxxx" "x      xxxx    x x    xxxxxxxx" "x    x         x x    xxxxxxxx" "x    x         x x    xxxxxxxx" "x  xxx         xxx    xxxxxxxx" "x  xxx               x   xxxxx" "x xxxx              xx        " "x xxxx              xx xx     " "x xxxx              xx xxxx xx" "x xxxx              xx xxxxxxx" "x xxxx              xx xxxx xx" "x xxxx              xx xx     " "x xxxx              xx        " "x  xxx               x   xxxxx" "x  xxx                xxxxxxxx" "x    x  xxx           xxxxxxxx" "x    x  x x           xxxxxxxx" "x       x x           xxxxxxxx" "x       x x           xxxxxxxx" "x      xx x       xx  xxxxxxxx" "x      x  x    xxxxx  xxxxxxxx" "x    xxx  x    x   x   xxxxxxx" "x    x    x    x   x    xxxxxx" "x  xxx    x    x   x     xxxxx" "x  x  x   x   xx   x      xxxx" "x  x  x   x   x    x          " "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/problems/k35x35 b/collects/games/paint-by-numbers/problems/k35x35
new file mode 100644
index 0000000000..afe38b564f
--- /dev/null
+++ b/collects/games/paint-by-numbers/problems/k35x35
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 35x35") (define problems (list (make-problem "19981015aGAS (1)" (quote ((17) (1 2) (1 1 1) (17 1) (1 1 1) (1 1 1) (1 1 1) (1 1 1 1 1) (1 5 1 1) (1 1 1) (1 1 1) (1 1 1) (17 1) (1 1 1) (1 1 1) (1 1 1) (1 1 1 1 1) (1 5 1 1) (1 1 1) (1 1 1) (1 1 1) (17 1) (1 1 1 1 1 1 1 2 1) (1 1 1 1 1 1 1 3 1) (1 1 1 1 1 1 1 2 1 1) (16 1 1) (1 1 1 1) (1 1 1 1) (1 1 1 1 1 1) (1 6 1 1 1) (1 1 2 1) (1 2 1 1) (16 1 1) (1 2) (18))) (quote (() () () () () () () (8) (2 3) (19 1 1 1 1) (2 1 2 2 1 1) (1 1 1 1 1 1 1 1) (1 1 1 2 2 2 1 1) (1 1 1 1 1 1 1 1 1) (1 1 1 2 2 1 1 1) (1 1 2 1 2 1 1 1 1 1 1) (1 1 1 1 1 2 2 1 1 1) (1 1 1 1 1 1 1 1 2 1 1) (1 1 1 1 1 2 2 1 1) (1 1 2 1 2 1 1 1 1 1) (1 1 1 2 2 1 1) (1 1 1 1 1 1 1 1) (1 1 1 2 9 1) (1 1 1 1 2 1 1) (1 1 1 3 1 1) (1 32) (1 1 1) (2 1) (32) () () () () () ())) (quote #f)) (make-problem "19990202-SQU (2)" (quote ((3 3 3 2 3) (3 3 1 1 3 1 1 1) (3 1 1 1 3 3 2 1) (3 1 1 3 1 1 1) (3 3 3 2 1) (3 3) (26) (2 3 3 2) (2 5 3) (2 3 4) (30) (1 3 1) (1 2 1) (1 16 1 2) (1 16 2 1 3) (1 2 2 2 5) (1 2 2 5) (1 2 2 3 1) (1 2 2 2 2 1) (1 2 2 2 1 2) (1 2 2 1 3) (1 2 2 5) (1 2 2 2 5) (1 2 2 4 3 1) (1 2 2 4 2 1) (1 2 2 2 1 2) (1 2 2 1 3) (4 2 2 7) (1 1 16 5 1) (1 1 16 4 1) (1 1 3 1) (1 27 1) (1 1) (1 1) (35))) (quote ((8) (1 1) (1 1) (1 22 1) (2 2 1 1) (3 3 1 1) (3 2 1 17 1 1) (3 2 1 17 1 1) (4 1 2 2 1 1) (3 1 2 2 1 1) (1 3 1 2 2 1 1) (3 3 1 2 2 1 1) (1 5 2 2 1 1) (1 3 2 2 1 1) (2 5 2 2 1 1) (1 3 1 2 2 1 1) (2 3 1 2 2 1 1) (3 1 2 2 1 1) (4 1 2 2 1 1) (3 1 1 2 2 1 1) (3 1 1 17 1 1) (3 1 1 17 1 1) (2 1 1 1 1) (1 1 1 2 1 1) (1 1 2 2 4 1 1) (3 1 1 1 2 2 4 1 1) (1 1 1 1 1 2 1 1) (1 3 1 1 1 1) (1 22 1) (5 1 4 4 4 5 1) (1 1 1 1 4 4 4 5 1) (5 4 4 5 1) (1 23 1) (5 1 1) (1 8))) (quote #f)) (make-problem "19990220-JOJ (3)" (quote ((35) (13 6 14) (12 4 13) (11 2 12) (10 11) (5 5) (5 6) (6 7) (7 8) (8 1 1 1 1 1 1 9) (6 1 3 1 1 3 1 7) (4 1 1 1 1 1 1 5) (2 1 2 1 1 2 1 3) (3 1 3 1 1 3 1 4) (4 1 3 1 1 3 1 5) (5 1 1 1 1 6) (6 1 3 1 1 3 1 7) (5 2 1 1 2 6) (4 2 3 4 3 2 5) (3 1 4 4 1 4) (4 1 2 2 1 5) (6 1 1 7) (8 1 2 2 1 9) (8 2 3 3 2 9) (9 1 6 1 10) (10 1 1 11) (13 14) (11 1 1 2 1 1 12) (12 1 1 1 1 13) (11 12) (10 11) (8 9) (7 4 4 8) (6 14 7) (5 16 6))) (quote ((35) (35) (12 22) (12 5 15) (11 3 14) (5 4 1 13) (5 2 11) (5 1 4 10) (5 1 2 1 7) (5 1 3 3 6 1) (4 1 1 1 2 1 4 2) (3 1 2 1 3 1 1 1 1 3) (2 2 3 1 3 2 3 3) (1 1 3 1 1 1 1 3) (2 1 1 1 2 1 3) (3 1 3 3 1 1 2) (4 1 1 1 2) (4 1 1 1 2) (3 1 3 3 1 1 2) (2 1 1 1 2 1 3) (1 1 3 1 1 1 1 3) (2 2 3 1 3 2 3 3) (3 1 2 1 3 1 1 1 1 3) (4 1 1 1 2 1 4 2) (5 1 3 3 6 1) (5 1 2 1 7) (5 1 4 10) (5 2 11) (5 4 1 13) (5 5 3 14) (12 5 15) (12 22) (35) (35) (35))) (quote ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxx xxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxx  xxxxx xxxxxxxxxxxxxxx" "xxxxxxxxxxx    xxx   xxxxxxxxxxxxxx" "xxxxx  xxxx     x    xxxxxxxxxxxxx " "xxxxx   xx            xxxxxxxxxxx  " "xxxxx    x      xxxx  xxxxxxxxxx   " "xxxxx      x     xx x   xxxxxxx    " "xxxxx     x xxx      xxx xxxxxx   x" "xxxx     x x   x  xx   x  xxxx   xx" "xxx       x  xx x xxx x x x x   xxx" "xx       xx xxx x xxx xx xxx    xxx" "x         x xxx x  x   x    x   xxx" "xx       x x   x       xx  x    xxx" "xxx       x xxx xxx     x   x    xx" "xxxx              x     x  x     xx" "xxxx              x     x  x     xx" "xxx       x xxx xxx     x   x    xx" "xx       x x   x       xx  x    xxx" "x         x xxx x  x   x    x   xxx" "xx       xx xxx x xxx xx xxx    xxx" "xxx       x  xx x xxx x x x x   xxx" "xxxx     x x   x  xx   x  xxxx   xx" "xxxxx     x xxx      xxx xxxxxx   x" "xxxxx      x     xx x   xxxxxxx    " "xxxxx    x      xxxx  xxxxxxxxxx   " "xxxxx   xx            xxxxxxxxxxx  " "xxxxx  xxxx     x    xxxxxxxxxxxxx " "xxxxx xxxxx    xxx   xxxxxxxxxxxxxx" "xxxxxxxxxxxx  xxxxx xxxxxxxxxxxxxxx" "xxxxxxxxxxxx xxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"))) (make-problem "19990416-SNI (4)" (quote ((8 15 5) (7 2 13 6) (6 2 12 7) (5 2 11 4 8) (5 1 10 4 9) (4 1 10 3 2 8) (4 1 2 4 1 7) (4 11 5 3 6) (4 11 6 5 5) (3 12 5 7 4) (3 12 5 8 3) (3 1 5 4 3 10 2) (2 1 3 1 4 2 9 3) (2 1 1 3 2 4 1 9 4) (1 3 5 6 9 5) (1 5 11 8 6) (1 10 4 6 7) (1 1 1 2 1 4 4 9) (1 3 2 3 4 3 10) (2 15 1 1 11) (3 13 2 2 10) (3 1 10 4 3 9) (3 1 6 7 3 8) (3 1 5 7 1 2 9) (3 1 4 3 3 3 10) (3 4 2 8 11) (4 6 9 10) (4 17 9) (5 8 7 10) (5 8 7 11) (6 8 6 12) (6 8 4 13) (5 2 4 14) (4 3 5 4 15) (4 6 16))) (quote ((35) (14 16) (12 2 1 15) (9 8 9) (5 3 3 7 5) (3 2 3 1 3 2 2 2 1) (2 2 5 3 12 2) (1 2 1 8 1 13 2) (2 2 11 13 1) (1 3 11 13 2) (4 5 3 6 6 2) (6 4 1 8 2 5 2) (6 4 2 2 4 3 5 2) (6 5 2 6 6 2) (6 9 5 3 2) (6 10 12 1 1) (6 1 10 9 2) (5 1 3 8 13) (4 2 4 5 3 9) (4 1 7 1 3 9 1) (3 2 6 3 3 8 2) (3 1 5 6 8 3) (2 2 3 11 4) (2 2 2 10 4 5) (1 1 2 10 1 3 1 6) (1 1 1 10 3 1 3 7) (1 10 5 12) (3 9 18) (5 7 19) (7 5 20) (9 3 21) (10 1 22) (11 23) (35) (35))) (quote ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxx     xxxxxxxxxxxxxxxx" "xxxxxxxxxxxx  xx  x xxxxxxxxxxxxxxx" "xxxxxxxxx   xxxxxxxx      xxxxxxxxx" "xxxxx    xxx  xxx xxxxxxx   xxxxx  " "xxx  xx xxx  x xxx xx     xx  xx x " "xx xx  xxxxx  xxx xxxxxxxxxxxx  xx " "x xx x xxxxxxxx x xxxxxxxxxxxxx xx " " xx xx xxxxxxxxxxx xxxxxxxxxxxxx  x" " x xxx xxxxxxxxxxx xxxxxxxxxxxxx xx" "  xxxx xxxxx  xxx xxxxxx  xxxxxx xx" "xxxxxx xxxx  x xxxxxxxx xx xxxxx xx" "xxxxxx xxxx xx xx xxxx xxx xxxxx xx" "xxxxxx xxxxx  xx   xxxxxx xxxxxx xx" "xxxxxx xxxxxxxxx   xxxxx xxx  xx   " "xxxxxx xxxxxxxxxx xxxxxxxxxxxx x x " "xxxxxx x   xxxxxxxxxx xxxxxxxxx xx " "xxxxx x xxx xxxxxxxx xxxxxxxxxxxxx " "xxxx xx xxxx  xxxxx  xxx xxxxxxxxx " "xxxx x xxxxxxx   x  xxx xxxxxxxxx x" "xxx xx xxxxxx xxx  xxx  xxxxxxxx xx" "xxx x xxxxx  xxxxxx    xxxxxxxx xxx" "xx xx xxx  xxxxxxxxxxx         xxxx" "xx xx xx xxxxxxxxxx xxxx      xxxxx" "x  x xx xxxxxxxxxx x xxx x   xxxxxx" "x  x x xxxxxxxxxx xxx x xxx xxxxxxx" "    x xxxxxxxxxx xxxxx xxxxxxxxxxxx" "   xxx xxxxxxxxx xxxxxxxxxxxxxxxxxx" "  xxxxx xxxxxxx xxxxxxxxxxxxxxxxxxx" " xxxxxxx xxxxx xxxxxxxxxxxxxxxxxxxx" "xxxxxxxxx xxx xxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxx x xxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxx xxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"))) (make-problem "19990520-TAM (5)" (quote ((1 1) (1 1 2) (1 1 1 1) (1 1 1 1) (1 1 1) (1 1 18 2) (1 1 20 2) (2 2 2 14 2) (2 2 3 2 2 3) (6 6) (5 2 2 5) (3 4 4 3) (3 4 4 3) (3 2 2 3) (1 3 3) (2 24) (1 1 4 1 1 1 1 1 1 1 1 3) (1 24) (1 24) (2 24) (2 24) (1 2 2 2 2 2 1) (1 2 2 2 2 2 1) (24) (1 2 2 2 2 2 1) (1 2 2 2 2 2 1) (26) (26) (26) (26) (26) (2 2) (2 2) (2 2) (2 2))) (quote (() (2 2) (7 7) (1 1) (1 2 1) (8) (5) (23) (14 1 5) (15 1 9) (2 2 20) (2 2 1 14) (5 6 1 5) (4 2 1 4 1 5) (3 4 16) (3 4 1 14) (3 2 6 1 5) (3 1 4 1 5) (3 16) (3 1 14) (3 6 1 5) (3 2 1 4 1 5) (3 4 16) (3 4 1 14) (4 2 6 1 5) (5 1 4 1 5) (2 2 16) (2 2 1 18) (15 1 9) (14 1 5) (23) (2 5) (7) (1) (2))) (quote ("                                   " "       xx          xx              " "  xxxxxxx     xxxxxxx              " " x             x                   " "x      xx       x                  " " xxxxxxxx                          " "                          xxxxx    " "        xxxxxxxxxxxxxxxxxxxxxxx    " "       xxxxxxxxxxxxxx  x  xxxxx    " "      xxxxxxxxxxxxxxx  x  xxxxxxxxx" "     xx  xx    xxxxxxxxxxxxxxxxxxxx" "     xx  xx    x xxxxxxxxxxxxxx    " "     xxxxx     xxxxxx  x  xxxxx    " "     xxxx  xx  x xxxx  x  xxxxx    " "     xxx  xxxx xxxxxxxxxxxxxxxx    " "     xxx  xxxx x xxxxxxxxxxxxxx    " "     xxx   xx  xxxxxx  x  xxxxx    " "     xxx       x xxxx  x  xxxxx    " "     xxx       xxxxxxxxxxxxxxxx    " "     xxx       x xxxxxxxxxxxxxx    " "     xxx       xxxxxx  x  xxxxx    " "     xxx   xx  x xxxx  x  xxxxx    " "     xxx  xxxx xxxxxxxxxxxxxxxx    " "     xxx  xxxx x xxxxxxxxxxxxxx    " "     xxxx  xx  xxxxxx  x  xxxxx    " "     xxxxx     x xxxx  x  xxxxx    " "     xx  xx    xxxxxxxxxxxxxxxx    " "     xx  xx    x xxxxxxxxxxxxxxxxxx" "      xxxxxxxxxxxxxxx  x  xxxxxxxxx" "       xxxxxxxxxxxxxx  x  xxxxx    " "        xxxxxxxxxxxxxxxxxxxxxxx    " "     xx                   xxxxx    " "xxxxxxx                            " " x                                 " "  xx                               "))) (make-problem "19990830-KHO (6)" (quote ((35) (26 5) (7 12 3 4) (6 1 1 1 4 4 4) (5 2 1 1 2 2 3) (4 4 2 1 2) (3 6 1 1 7 1) (2 6 3 3 7) (1 6 1 3 1 6) (2 5 1 1 6) (4 4 4 3) (4 4 4 4) (2 4 5 4 7) (1 4 7 4 4 1) (2 4 3 1 3 4 2) (10 1 3 1 1 10) (9 1 3 9) (9 3 4 2) (9 1 3 1 3 3 3 1) (10 5 1 3 2 2) (12 2 3 3 4 1 1 1) (4 8 1 1 7 3 1) (3 9 3 8 1 2) (2 2 6 8 2 1) (2 1 1 4 9 2) (2 3 3 11) (3 8 12) (8 1 1 6) (7 1 1 5) (7 7 5) (7 1 1 7 1 1 5) (9 2 11 2 7) (35) (35) (35))) (quote ((9 22) (8 21) (7 2 8 9) (6 4 7 3 8) (5 4 6 2 1 8) (4 2 6 1 2 8) (3 1 10 9) (2 2 3 15 4) (2 22 4) (2 12 8 1 3) (2 9 5 1 4) (2 8 4 1 4) (3 4 2 1 1 3) (4 1 2 1 4) (3 1 2 3 1 1 1 4) (4 2 1 3 1 1 7) (3 2 2 1 3 1 6) (3 1 5 3 1 6) (3 2 2 1 3 1 6) (4 2 1 3 1 1 6) (5 2 3 1 1 6) (5 1 3 7) (4 4 3 4 1 4) (3 8 5 4 1 4) (2 1 9 3 7 1 3) (2 2 10 8 4) (1 3 21 4) (1 2 5 14 1 3) (1 1 2 3 5 5 4) (1 4 3 3 5 4) (2 4 2 2 2 11) (4 3 2 1 2 12) (5 2 2 2 2 10) (6 1 4 4 11) (7 7 12))) (quote ("xxxxxxxxx    xxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxx      xxxxxxxxxxxxxxxxxxxxx" "xxxxxxx   xx   xxxxxxxx   xxxxxxxxx" "xxxxxx   xxxx  xxxxxxx xxx xxxxxxxx" "xxxxx    xxxx  xxxxxx xx x xxxxxxxx" "xxxx      xx   xxxxxx x xx xxxxxxxx" "xxx x         xxxxxxxxxx  xxxxxxxxx" "xx xx xxx    xxxxxxxxxxxxxxx   xxxx" "xx   xxxxxxxxxxxxxxxxxxxxxx    xxxx" "xx  xxxxxxxxxxxx   xxxxxxxx   x xxx" "xx   xxxxxxxxx      xxxxx x    xxxx" "xx   xxxxxxxx       xxxx  x    xxxx" "xxx   xxxx           xx   x   x xxx" "xxxx          x     xx    x    xxxx" "xxx x  xx    xxx  x x      x   xxxx" "xxxx  xx x  xxx    x x      xxxxxxx" "xxx    xx   xx x  xxx x      xxxxxx" "xxx     x   xxxxx xxx x      xxxxxx" "xxx    xx   xx x  xxx x      xxxxxx" "xxxx  xx x  xxx    x x       xxxxxx" "xxxxx  xx    xxx  x x        xxxxxx" "xxxxx         x     xxx     xxxxxxx" "xxxx  xxxx      xxx xxxx   x   xxxx" "xxx  xxxxxxxx  xxxxx xxxx x    xxxx" "xx x xxxxxxxxx  xxx xxxxxxx   x xxx" "xx xx xxxxxxxxxx   xxxxxxxx    xxxx" "x xxx xxxxxxxxxxxxxxxxxxxxx    xxxx" "x xx xxxxx   xxxxxxxxxxxxxx   x xxx" "x x   xx  xxx xxxxx   xxxxx    xxxx" "x         xxxx xxx xxx xxxxx   xxxx" "xx        xxxx xx xx xx xxxxxxxxxxx" "xxxx       xxx xx x xx xxxxxxxxxxxx" "xxxxx       xx xx xx  xx xxxxxxxxxx" "xxxxxx      x xxxx xxxx xxxxxxxxxxx" "xxxxxxx     xxxxxxx    xxxxxxxxxxxx"))) (make-problem "19990904-PIP (7)" (quote ((29) (27 1) (1 1 2) (2 2 1) (1 1 28) (1 2 1 1) (1 4 9 1 9 1) (2 1 1 1 1 1 1) (1 1 1 1 3 1 1) (2 2 1 1 1 1) (1 1 4 1 2 1 1 1 1 1 1) (1 2 1 1 1 1 1 1 1 1 1 1 1 1) (1 4 1 2 1 1 1 1 2 1 1) (2 1 1 1 1 1 1 1 1 1 1 1 1) (1 1 1 1 2 1 1 1 1 1 1) (2 2 1 2 2 1) (1 1 4 1 1 1) (1 2 1 1 1 13 1 1 1) (1 4 1 1 1) (2 1 2 13 2 1) (1 1 1 1 1 1) (2 2 1 1 1 1) (1 1 4 1 1 1) (1 2 1 1 1 1) (1 4 1 1 1) (1 1 1 1 1) (2 1 1 1 1) (1 1 1 1 3 1 1) (1 2 1 1 1 1 1 1) (1 4 9 1 9 1) (2 1 1) (28) () () ())) (quote ((28) (2 1 1 1 1 1 1 1 1 1) (3 1 1 1 1 1 1 1 1 1) (2 1 1 1 1 1 1 1 1 1 1) (2 1 1 1 1 1 1 1 1 1 1) (2 1 1 1 1 1 1 1 1 1 1) (2 1 1 1 1 1 1 1 1 1 1) (2 1 1 1 1 1 1 1 1 1 1) (2 28) (2 1 1) (2 1 10 1 11 1) (2 1 1 1 1 1 1) (2 1 1 3 1 1) (2 1 1 5 1 1) (2 1 1 1 1 1 1 1 1 1) (2 1 1 1 1 1 1 1 1) (2 1 1 1 1 1 1) (2 1 1 3 1 1 1 1) (2 1 2 1 1 1 1 2 1) (2 1 1 3 1 1 1 1) (2 1 1 1 1 1 1 1 1) (2 1 1 3 1 1 1 1) (2 1 2 1 1 1 1 2 1) (2 1 1 3 1 1 1 1) (2 1 1 1 1 1 1) (2 1 1 5 1 1 1 1) (2 1 1 1 1 1 1 1) (1 1 1 1 2 2 1 1) (5 1 3 1 1) (1 1 1 1 1 1) (1 10 1 11 1) (1 1) (28) () ())) (quote #f)) (make-problem "19991007cKHO (8)" (quote ((3 3) (3 3) (3 4 3) (3 1 1 3) (5 3 5) (1 3 7) (1 3 3 2) (1 3 4 2 2) (1 2 2 1 2 3 2) (1 1 1 1 2 1 3) (1 1 1 2 5) (1 2 1 1 2 6) (1 3 1 2 6) (3 1 2 8) (3 3 1 2 6 3) (3 1 3 1 7 3) (3 1 3 1 5 4 3) (1 3 3 3 3 1 5) (1 3 7 3 7) (1 3 7 1 3 5 2) (1 3 5 3 1 1 5 3) (1 1 2 1 2 1 2 1 1 1 2 5) (1 1 1 1 2 1 2 1 1 1 2 3 2) (1 1 1 1 1 3 1 1 1 1 2 1 3) (1 1 1 1 1 2 1 1 1 1 2 5) (1 1 2 1 1 1 1 1 1 1 2 6) (1 2 1 1 3 1 1 2 1 2 6) (3 1 1 7 2 1 2 6) (3 1 1 5 3 1 2 4) (3 1 5 3 1 5) (3 3 3 3) (3 3) () () ())) (quote ((12) (1 1) (3 6 2) (1 1 1 1 1) (2 2 2 1 2) (1 1 1 1 1) (2 2 4 2) (1 2 1 1) (12 1 13) (2 1 1 1 1) (3 4 2 1 13) (1 1 2 2 1 4 2) (2 2 1 1 2 3 2 5) (1 1 2 1 1 2 4 4) (2 2 2 1 5 1 5) (1 2 1 6 2) (1 1 1 23) (1 1 1 1 1) (1 1 1 23) (1 1 12 1) (2 2 4 7 2) (1 1 2 6 1 2 1) (2 2 2 7 2 1 2) (1 2 2 6 1 1) (4 7 13) (12 2 1 1) (12 1 13) (1 1 12) (2 1 3 2) (1 2 2 5) (2 3 2 6) (1 2 2 5) (4 2 6) (12) (12))) (quote #f)))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/problems/k35x40 b/collects/games/paint-by-numbers/problems/k35x40
new file mode 100644
index 0000000000..459cfdaee9
--- /dev/null
+++ b/collects/games/paint-by-numbers/problems/k35x40
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 35x40") (define problems (list (make-problem "19980425-HUB (1)" (quote ((8 6 2 2 6) (8 8 2 2 8) (2 2 2 2 2 2 2) (2 2 2 2 2 2 2) (2 2 2 2 2 2 2) (2 2 8 6 8) (3 3 8 4 8) (6 2 2 2 2 2) (4 2 2 1 2 2 2) (1) (5 1 1 1 1 1 9) (3 1 1 1 1 1 6) (5 1 1 1 1 1 1 8) (3 1 1 1 1 1 6) (4 1 1 1 1 1 10) (2 1 1 1 1 1 5) (4 1 1 1 1 1 8) (2 1 1 1 1 1 5) (4 1 11 1 8) (5 1 1 1 5 1) (3 1 11 1 3) (1 21 1 3) (3 17 8) (2 3 9 7 2) (2 4 10 2) (2 9 1 7 2) (5 1 1 1 1 8 2) (2 1 1 1 1 6 2) (1 6 1 1 1 1 7 3) (1 2 1 1 1 1 9 1) (1 6 1 1 1 1 8 2) (1 2 1 1 1 8 4) (2 6 1 1 1 8 5) (2 3 1 1 1 6 6) (3 4 1 1 1 6 7) (4 2 1 1 6 8) (5 3 1 1 5 9) (7 9 11) (10 14) (35))) (quote ((2 2 9 12) (2 3 9 6 8) (2 3 5 1 1 1 9 6) (2 2 1 1 1 1 1 1 1 7 5) (2 2 1 1 1 1 1 1 4 4) (2 3 1 1 1 1 1 1 3 3) (8 2 4 1 1 1 1 1 4 3) (7 2 5 1 1 1 1 2 2) (1 2 1 1 1 1 2) (8 1 2 1 1 2) (9 1 2 1 3 1 1 1) (2 2 2 9 1 1 1) (2 2 1 4 1 1 1) (2 2 6 1 1 1) (2 2 3 4 4 2 1 1 1 1 2 1) (9 2 1 4 1 1 1 1 1 1 1 1) (8 1 4 2 1 1 1 1 2 1) (2 7 1 1 1 1 1 1 1 1) (4 3 4 1 4 2 1 1 1 1 2 1) (6 1 4 1 1 1 1 1 3 1) (3 1 3 1 1 1 1 1 3 1) (4 1 2 2 1 1 6 2) (4 2 6 1 1 1 7 2) (3 2 3 1 2 12 2) (6 1 1 13 3) (4 1 1 1 1 12 3) (1 1 1 11 4) (8 1 1 1 1 1 1 11 5) (9 1 1 1 1 1 1 10 6) (2 2 5 1 1 6 2 7) (2 2 9 2 2 8) (2 2 9 2 2 9) (2 2 9 2 2 9) (9 9 7 10) (8 10 5 11))) (quote #f)) (make-problem "19981020-MON (2)" (quote ((3 11) (4 5 4) (3 5 4) (3 5 3) (3 5 2) (4 5 2) (3 5 2) (4 2) (4 3 3 3 2 1) (4 1 1 1 1 1 2 1) (2 1 2 1 3 2 2) (2 1 1 1 1 1 2 2) (4 1 1 3 1 2 3) (4 2 2) (4 1 2 1 1 1) (2 1 1 2 4 1) (2 1 3 4 1 1 1) (1 4 3 8 1) (1 1 1 3 2 4 1) (1 6 3 1 2 2 1) (2 5 1 3 1 2 4 1) (2 1 12 8 1) (1 1 2 6 12) (3 4 2 10) (8 2 10) (4 1 2 10) (1 1 4 2 11) (3 1 1 2 2 9) (5 5 2 2 8) (2 1 4 2 2 3 7) (12 2 2 6) (9 1 2 2 6) (13 2 4) (10 3 5) (6 2 3 5) (2 9 5) (2 4 3 5) (2 2 4 5) (2 2 1 2 3) (2 2 10))) (quote ((2) (1 1 4 1) (2 2 5 3 3 3) (2 2 4 6 5) (5 2 3 7 1) (5 2 7 3) (3 2 10) (2 9) (34) (13 2 4 1 4 3 1) (6 3 1 6 1 3 4 3) (37) (5 3 2 2 1) (5 5 1 1 2 2 1) (5 1 1 2 2 2 1) (4 2 2 2 2 2 1) (3 2 2 2 2) (2 1 1 7 2 2 3) (1 5 9 2 2 3) (1 1 1 7 2 3 3) (1 2 2 2 4) (1 5 1 2 2 4) (2 1 1 2 2 2 4) (3 3 2 2 4) (4 2 2 4) (33) (32) (2 11) (5 12) (1 15) (16) (4 2 2 10) (3 2 7) (2 6) (13))) (quote #f)) (make-problem "19990202bLLO (3)" (quote ((8 20) (2 2 2 2) (1 1 1 1 1 2 1 1 3 1) (1 4 3 1 1 1 1 1 1 1 2) (1 1 1 3 3 2 1 1 1 1 2) (1 1 1 3 1 1 1 1 1 1 1 2) (1 1 1 1 1 1 1 2 2 2 3 1) (1 1 1 1 2 2) (1 1 1 1 20) (1 1 1 1) (2 1 1 2 6 6 6) (1 1 1 1 1 1 1 1 1 1) (2 2 1 2 1 1 2 1 1 2 1) (2 2 1 1 1 1 1 1 1 1 1) (2 2 1 1 1 1 1 1 1 1 1) (5 5 1 1 1 1 2 1 1 1 1) (1 2 2 1 1 1 1 1 1 1) (1 2 2 1 6 6 6) (5 5) (2 2 6 6 6) (2 2 1 1 1 1 1 1) (2 2 1 1 1 1 2 1 1 1 1) (2 2 1 2 1 1 1 1 1 1 1) (2 2 1 1 1 1 1 1 1 2 1) (2 2 1 1 1 1 2 1 1 2 1) (2 2 1 1 1 1 1 1) (2 2 6 6 6) (1 1 1 1) (2 1 1 2 6 6 6) (1 1 1 1 1 1 1 1 1 1) (1 1 1 1 1 2 1 1 2 1 1 2 1) (1 1 1 1 1 1 1 1 2 1 1 2 1) (1 1 1 1 1 1 1 1 2 1 1 1 1) (1 1 1 1 1 1 1 1 2 1 1 1 1) (1 4 1 1 1 1 1 1 1) (1 1 6 6 6) (2 2 4) (8 8) (3 4 5) (3 4 5))) (quote ((4) (10 1 1 9) (2 2 1 1 2 2) (1 15 1) (1 32 2) (1 1 1 3) (1 1 1 3) (1 32 1 1) (1 15 1) (2 2 1 1 2 2) (10 1 1 9) (3 4 1) (7 1) (2 2 8 8 8 2) (1 1 1 1 1 1 1 1 2) (1 5 1 1 1 1 1 2 1 1 1 2 1 2) (1 1 1 1 4 1 1 3 1 1 2 1 2) (1 5 1 1 1 1 1 1 3) (1 1 8 8 10) (1 5 1 2) (1 1 1 1 1 8 8 11) (1 1 1 1 1 1 1 1 2) (1 5 1 1 1 2 1 1 2 1 1 1 4 1 3) (1 1 1 1 2 1 1 1 1 2 1 1 4 1 2) (1 1 1 1 1 1 1 1 2) (1 5 1 8 8 8 1) (1 1 1 1) (1 1 8 8 8) (1 5 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1 1 4 1 1 2 1) (1 5 1 1 3 1 1 2 1 1 4 1) (1 1 1 1 1 1 1 1) (2 2 8 8 8) (7) (3))) (quote #f)) (make-problem "19990529aDRA (4)" (quote (() () (3) (5) (7) (7) (6) (7) (6) (5) (7) (2 9) (1 3 10) (2 16 4) (2 15 4) (2 2 2 5) (4 4 2 5 12) (2 1 1 8 1) (2 1 5 2 1 1) (2 1 5 2 1) (2 1 2 6 1) (2 1 7 1) (2 1 7 1) (14 8 11) (2 1 8 1) (2 1 10 1) (2 1 11 1) (2 1 6 5 1) (2 1 5 4 1) (2 1 3 4 1) (9 4 7 4 7) (2 4 4) (2 4 4) (2 4 3) (2 4 4) (2 3 3) (2 3 3) (2 5 4) (2 4 3) (2))) (quote ((27) (27) (1 1 1) (3 1 1 1) (1 3 1 1) (5 1 1) (3 15) (3 1 1 1) (2 1 1 1) (2 1 1) (2 2 3 1 3) (5 2 1 3 1 5) (6 2 5 1 7) (7 4 3 1 4 4 2) (7 6 3 5 4 2) (13 1 5 1 3 2) (11 3 8 1 6) (8 3 7 1 4) (6 3 7 1 2) (4 3 9 1) (7 10 1) (5 9 1) (4 3 5) (2 1 4) (1 1 4) (1 1 4 2) (1 1 4 2) (1 1 4 3) (15 6) (1 1 1 3) (1 1 1 2) (1 1 1) (1 1 1) (1 1 1) (1 1 1))) (quote ("             xxxxxxxxxxxxxxxxxxxxxxxxxxx" "             xxxxxxxxxxxxxxxxxxxxxxxxxxx" "                x      x      x         " "            xxx x      x      x         " "           x xxx       x      x         " "           xxxxx       x      x         " "            xxx xxxxxxxxxxxxxxx         " "            xxx x      x      x         " "             xx x      x      x         " "             xx x      x                " "    xx       xx  xxx   x    xxx         " "   xxxxx     xx x xxx  x   xxxxx        " "  xxxxxx     xx xxxxx  x  xxxxxxx       " "  xxxxxxx  xxxx  xxx   x xxxx xxxx   xx " "  xxxxxxx xxxxxx xxx    xxxxx  xxxx  xx " "   xxxxxxxxxxxxx x     xxxxx  x xxx  xx " "    xxxxxxxxxxx xxx xxxxxxxx  x  xxxxxx " "       xxxxxxxx xxx xxxxxxx   x   xxxx  " "        xxxxxx xxx  xxxxxxx   x    xx   " "         xxxx  xxx xxxxxxxxx  x         " "          xxxxxxx xxxxxxxxxx  x         " "           xxxxx    xxxxxxxxx x         " "            xxxx     xxx xxxxx          " "             xx x          xxxx         " "                x      x    xxxx        " "                x      x     xxxx    xx " "                x      x      xxxx   xx " "                x      x       xxxx xxx " "                xxxxxxxxxxxxxxx xxxxxx  " "                x      x      x   xxx   " "                x      x      x   xx    " "                x      x      x         " "                x      x      x         " "                x      x      x         " "                x      x      x         "))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/problems/k40x30 b/collects/games/paint-by-numbers/problems/k40x30
new file mode 100644
index 0000000000..eb42a0a870
--- /dev/null
+++ b/collects/games/paint-by-numbers/problems/k40x30
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 40x30") (define problems (list (make-problem "19980501bGOS (1)" (quote (() () () () () () () () () (37) (37) (1 1 1 1 2 2 2 1 1 1 1 2 2) (1 1 1 3 1 1 1 1 2 1 3 1 2 1 1 1) (1 1 1 3 1 1 3 2 1 3 1 1 2 3) (1 1 1 3 2 1 2 6 2) (1 1 1 3 1 3 1 2 1 4 7 1) (1 1 1 3 1 1 1 1 2 1 4 5 1 1) (1 1 1 1 1 2 2 2 1 2 6 2) (37) (6 3) (6 5 1 4 1 6 3) (6 3) (37) () () () () () () ())) (quote (() (14) (2 5) (5 8) (2 5) (14) (2 5) (2 2 2 1 1) (2 2 2 1 1) (10 1 1) (2 1 1 1) (2 2 4 1 1) (2 1 1 1 1) (10 1 1) (3 2 2 1) (2 2 2 1 1) (3 2 2 1 1) (10 1) (2 1 1 1) (5 4 1 1) (5 4 1 1) (2 1 1 1) (10 1) (2 1 1 1) (2 2 2 1 1) (2 2 2 1 1 1) (10 1 1) (2 5 1 1) (5 1 1 1) (2 5 1 1) (10 1 1) (2 1 5 1) (2 6 1) (10 1) (3 2 2 1) (2 2 2 5) (3 2 6) (14) () ())) (quote #f)) (make-problem "19980501cGOS (2)" (quote (() (3 4) (6 6) (1 8 7) (2 2 16 2) (3 2 16 2 2) (5 5 1 5 2 3) (8 4 1 5 5) (15 3 4 8) (2 12 1 16) (3 25 2) (3 19 3) (16 3) (3 6) (3 5) (2 1 4) (4 4) (2 4) (10) (10) (9) (9) (7) (7) (3 3) (3 3) (4 4) (5 5) (5 5) ())) (quote (() () (2) (2 3 1) (2 2 2) (7) (5) (6) (7) (4) (4) (4) (4 4) (11) (14 2) (21 3) (28) (4 3 1 11) (4 1 3 2 11) (10 6) (2 1 3 11) (3 19) (27) (21 3) (19 2) (14) (7 5) (4 4) (4) (4) (4) (7) (7) (5) (7) (2 2 2) (2 3 1) (2) () ())) (quote ("                              " "                              " "        xx                    " "    xx xxx x                  " "    xx xx xx                  " "     xxxxxxx                  " "      xxxxx                   " "    xxxxxx                    " "   xxxxxxx                    " "      xxxx                    " "       xxxx                   " "        xxxx                  " "   xxxx xxxx                  " "  xxxxxxxxxxx                 " " xxxxxxxxxxxxxx            xx " " xxxxxxxxxxxxxxxxxxxxx    xxx " " xxxxxxxxxxxxxxxxxxxxxxxxxxxx " "  xxxx    xxx   x xxxxxxxxxxx " "  xxxx  x xxx  xx xxxxxxxxxxx " "   xxxxxxxxxx     xxxxxx      " "    xx  x xxx     xxxxxxxxxxx " "   xxx    xxxxxxxxxxxxxxxxxxx " "  xxxxxxxxxxxxxxxxxxxxxxxxxxx " " xxxxxxxxxxxxxxxxxxxxx    xxx " " xxxxxxxxxxxxxxxxxxx       xx " " xxxxxxxxxxxxxx               " " xxxxxxx xxxxx                " "  xxxx   xxxx                 " "         xxxx                 " "        xxxx                  " "       xxxx                   " "    xxxxxxx                   " "    xxxxxxx                   " "       xxxxx                  " "      xxxxxxx                 " "     xx xx xx                 " "     xx xxx x                 " "         xx                   " "                              " "                              "))) (make-problem "19980508-SDN (3)" (quote ((15 7 10) (1 1 1 1 10) (1 11 1 1 1 2 2) (1 11 1 1 1 10) (1 11 1 1 1 5 3) (1 11 1 13 10) (1 11 1 24) (1 11 1 13 10) (1 11 1 6 1 2 10) (1 11 1 13 10) (1 11 1 1 1 10) (1 1 10) (15 10) (1 1 1 6 2 10) (15 7 2) (3 2 10) (1 14 10 2) (3 1 2 10) (9 3 1 10) (9 1 1 10) (1 1) (25 10) (25 1) (2 1 1 1 1 1 1 3 3) (25 1 1) (1 1 1 1 1 1 1 1 1 1 1) (25 3) (2 1 1 1 1 1 1 3 3) (25) (25))) (quote ((15 9) (1 1 1 4 4) (1 9 3 2 1 1 2) (1 9 1 1 2 2 3 2) (1 9 3 2 4 4) (1 9 1 1 2 2 1 1 2) (1 9 4 3 2 3 2) (1 9 8 4 4) (1 9 4 3 2 1 1 2) (1 9 3 2 2 3 2) (1 9 3 3 4 4) (1 9 3 1 2 2 1 1 2) (1 9 1 1 1 2 3 2) (1 3 1 4 4) (15 1 2 1 1 2) (1 2 3 2) (5 1 4 4) (5 1 2 1 1 2) (5 1 2 3 2) (11 1 4 4) (1 5 1 2 1 1 2) (1 5 1 2 3 2) (1 3 1 1 4 4) (1 3 1 1 7 4) (1 5 2 1 9) (8 2 1 1) (3 1 1 2) (5 1 2 1) (5 1 1 1 1) (1 1 1 1) (20 1) (20 1) (2 17 1) (2 11 5 1) (2 11 5 1) (2 1 9 5 1) (2 1 9 1 3 1) (2 11 1 3 1 5) (20 3 2) (20 5))) (quote #f)) (make-problem "19981027aMNT (4)" (quote ((2) (2) (8) (2) (1 2) (1 2) (5 2) (1 10) (1 2) (1 2) (1 10) (7 10) (1 10) (1 4 4) (1 18) (24) (24) (18) (34) (24) (32) (40) (17 12) (17 6) (21 5) (20 1) (19 2) (18 2) (17 2) (32))) (quote ((1 1) (1 2) (1 3) (1 1 4) (1 10) (1 10) (1 1 10) (1 1 1 10) (1 1 2 12) (13 12) (1 1 2 12) (1 1 16) (1 16) (16) (16) (1 20) (1 1 20) (1 1 20) (1 1 20) (13 16) (13 16) (1 1 12 1) (1 1 12 1) (1 1 12 1) (1 13 1) (9 1) (9 1) (9 1) (9 1) (2 5 1) (2 6 1) (2 6 1) (1 4 1) (1 4 1) (1 4 1) (1 5 2) (1 1 1 2) (1 1 2) (1 3) (1 1))) (quote ("                     x  x     " "                     x  xx    " "                     x  xxx   " "                  x  x  xxxx  " "                  x xxxxxxxxxx" "                  x xxxxxxxxxx" "           x      x xxxxxxxxxx" "      x    x      x xxxxxxxxxx" "      x    x   xx xxxxxxxxxxxx" "    xxxxxxxxxxxxx xxxxxxxxxxxx" "      x    x   xx xxxxxxxxxxxx" "      x    x  xxxxxxxxxxxxxxxx" "           x  xxxxxxxxxxxxxxxx" "              xxxxxxxxxxxxxxxx" "              xxxxxxxxxxxxxxxx" "       x  xxxxxxxxxxxxxxxxxxxx" "  x    x  xxxxxxxxxxxxxxxxxxxx" "  x    x  xxxxxxxxxxxxxxxxxxxx" "  x    x  xxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxx xxxxxxxxxxxxxxxx" "xxxxxxxxxxxxx xxxxxxxxxxxxxxxx" "  x    x  xxxxxxxxxxxx       x" "  x    x  xxxxxxxxxxxx       x" "  x    x  xxxxxxxxxxxx       x" "       x  xxxxxxxxxxxxx      x" "              xxxxxxxxx      x" "              xxxxxxxxx      x" "              xxxxxxxxx      x" "              xxxxxxxxx      x" "               xx xxxxx      x" "               xx xxxxxx     x" "               xx xxxxxx     x" "                  x xxxx     x" "                  x xxxx     x" "                  x xxxx     x" "                  x xxxxx   xx" "                  x  x  x  xx " "                     x  x xx  " "                     x  xxx   " "                     x  x     "))) (make-problem "19981027bMNT (5)" (quote ((16) (3 7 3) (4 7 3) (2 7 4 1) (3 7 3 2) (17 3) (3 7 3 4) (4 7 2 5) (17 13) (1 1 7 5 1) (16 8 1 1 1 1) (16 1 5 1 1 2 1) (7 7 1 5 8 1) (7 7 4 2 1 3 1 1) (16 4 2 1 3 2 1) (16 7 12 1) (16 8 1) (16 6 15) (16 4 1 15) (2 8 2 3 3 1 8 2) (2 8 2 2 1 1 1 8 2) (16 2 1 1 15) (17 1 4 6 7) (1 4 6 7) (1 3 15) (1 2 15) (1 1 1 8 2) (1 1 8 2) (1 15) (16))) (quote ((14) (1 13) (2 9 2) (3 9 2) (4 13) (5 13) (3 1 13) (4 1 2 9) (2 4 2 9) (3 4 13) (9 13) (1 6 13) (1 6 9 2) (9 9 2) (9 13) (6 1 13) (6 2 1) (3 4 12) (3 3 2 11) (7 3 7 1) (1 3 12 4 1) (1 2 7 3 1 3 1) (4 8 3 1 4 1) (3 13 9 1) (15 1 1) (1 1 13) (8 2 5 2) (2 1 1 2 5 2) (5 1 13) (2 4 13) (2 4 13) (1 6 5 6) (1 2 1 5 6) (1 1 1 13) (1 3 13) (1 2 13) (1 1 2 5 2) (1 2 5 2) (1 13) (14))) (quote ("         xxxxxxxxxxxxxx       " "        x xxxxxxxxxxxxx       " "       xx xxxxxxxxx  xx       " "      xxx xxxxxxxxx  xx       " "     xxxx xxxxxxxxxxxxx       " "    xxxxx xxxxxxxxxxxxx       " "   xxx  x xxxxxxxxxxxxx       " "  xxxx  x xx  xxxxxxxxx       " " xx  xxxx xx  xxxxxxxxx       " "xxx  xxxx xxxxxxxxxxxxx       " "xxxxxxxxx xxxxxxxxxxxxx       " "x  xxxxxx xxxxxxxxxxxxx       " "x  xxxxxx xxxxxxxxx  xx       " "xxxxxxxxx xxxxxxxxx  xx       " "xxxxxxxxx xxxxxxxxxxxxx       " "xxxxxx  x xxxxxxxxxxxxx       " "xxxxxx  xx            x       " "xxx  xxxx xxxxxxxxxxxx        " "xxx  xxx xx  xxxxxxxxxxx      " "xxxxxxx xxx  xxxxxxx    x     " "x  xxx xxxxxxxxxxxx xxxx x    " "x  xx xxxxxxx  xxx x  xxx x   " "xxxx xxxxxxxx  xxx x  xxxx x  " "xxx xxxxxxxxxxxxx xxxxxxxxx x " "xxxxxxxxxxxxxxx x            x" "        x      x xxxxxxxxxxxxx" "        xxxxxxxx xx  xxxxx  xx" "        xx  x  x xx  xxxxx  xx" "        xxxxx  x xxxxxxxxxxxxx" "        xx  xxxx xxxxxxxxxxxxx" "        xx  xxxx xxxxxxxxxxxxx" "        x xxxxxx xxxxx  xxxxxx" "         x xx  x xxxxx  xxxxxx" "          x x  x xxxxxxxxxxxxx" "           x xxx xxxxxxxxxxxxx" "            x xx xxxxxxxxxxxxx" "             x x xx  xxxxx  xx" "              x  xx  xxxxx  xx" "               x xxxxxxxxxxxxx" "                xxxxxxxxxxxxxx"))) (make-problem "19981228-BAU (6)" (quote ((5) (7) (3 3) (2 2 2) (2 2 2) (3 3 2) (2 2 2) (2 2 2) (3 3 3) (2 2 2 2) (2 2 4 2) (3 3 6 3) (2 2 2 2 2) (2 2 3 2 2) (3 3 5 3 2) (2 2 2 2 2 2) (2 2 2 2 2 2) (3 3 3 3 3 3) (2 2 2 2 2 2) (2 2 2 2 2 2) (3 17 3 3) (3 17 2 3) (2 3 2 2) (2 3 3 2) (26 2 2) (26 2 2) (2 4) (2 3) (29) (27))) (quote (() () (5) (7) (3 4) (4 2 2) (3 2 2) (4 2 2) (3 2 2) (4 3 2 2) (3 5 2 2) (4 3 2 2 2) (3 4 2 2 2) (4 3 2 2 2) (3 4 3 2 2) (4 3 5 2 2) (3 4 3 2 2 2) (3 3 4 2 2 2) (2 4 3 2 2 2) (2 3 4 2 2 2) (2 3 6 2 2 2) (4 3 4 2 2 2) (2 3 3 2 2 2) (3 3 5 2 2) (4 4 4 2 2) (4 3 6 2) (3 4 4 2) (4 3 3 2) (3 4 2) (4 3 2) (3 4 2) (3 4 2) (3 7) (4 3) (3 2) (7) (5) () () ())) (quote #f)) (make-problem "19990118-FRA (7)" (quote (() (3 3) (1 2 2 1) (1 2 2 1) (1 12 1) (1 14 1) (1 16 1) (1 20 1) (6 6 6) (4 1 1 4 1 1 4) (4 1 1 4 1 1 4) (5 6 5) (22) (10 9) (10 9) (11 10) (11 10) (7 2 2 6) (8 3 7) (9 1 8) (9 8) (16) (12) (8) () (1 1 4 4 1 1) (2 2 1 1 1 1 1 1) (1 2 1 3 1 1 1 1 1 1) (1 1 1 1 1 2 2) (1 1 4 4 1 1))) (quote (() () () () () () () () (8 5) (1 11 1) (1 13 1) (1 14 1) (1 16 1) (1 4 11 5) (5 2 11) (4 11 5) (4 2 5 6 1 1 1) (5 7 5 1 1 1) (14 5 1 1) (9 2 1 4) (9 2 3 5) (9 2 1 4 1 1) (5 7 5 1 1) (4 2 6 5 5) (4 5 5) (5 2 11 5) (1 4 11 1) (1 16 1) (1 14 1) (1 13 1) (1 11 1) (8 5) () () () () () () () ())) (quote #f)) (make-problem "19990123aFRA (8)" (quote (() () (2) (8) (10) (12 3) (4 14 3) (1 2 1 1 3) (1 23) (1 21) (3 20) (20) (16) (14) (12) (10) (8) (6) (10) () () (12 12) (1 10 10 1) (1 8 8 1) (9 9) (7 7) (5 5) (11 11) () ())) (quote (() () () (2) (1 1 1) (2 1 1) (3 5 1) (1 2 7) (1 1 7) (2 1 7) (2 1 7) (4 7) (6 5 1) (1 6 3 1) (2 7 2 1) (3 8 1 1) (4 9 1) (4 11) (4 11) (5 11) (5 11) (4 11) (4 11) (4 9 1) (3 8 1 1) (2 7 2 1) (1 6 3 1) (6 5 1) (4 7) (4 7) (3 7) (3 7) (3 7) (3 5 1) (2 2 1 1) (1 1 1 1) (2) () () ())) (quote ("                              " "                              " "                              " "                      xx      " "                     x  x  x  " "                     xx x  x  " "      xxx            xxxxx x  " "      x  xx          xxxxxxx  " "      x   x          xxxxxxx  " "      xx  x          xxxxxxx  " "       xx  x         xxxxxxx  " "        xxxx         xxxxxxx  " "       xxxxxx        xxxxx x  " "      x xxxxxx       xxx   x  " "     xx xxxxxxx      xx    x  " "    xxx xxxxxxxx  x  x        " "   xxxx xxxxxxxxx x           " "   xxxx xxxxxxxxxxx           " "   xxxx xxxxxxxxxxx           " "  xxxxx xxxxxxxxxxx           " "  xxxxx xxxxxxxxxxx           " "   xxxx xxxxxxxxxxx           " "   xxxx xxxxxxxxxxx           " "   xxxx xxxxxxxxx x           " "    xxx xxxxxxxx  x  x        " "     xx xxxxxxx      xx    x  " "      x xxxxxx       xxx   x  " "       xxxxxx        xxxxx x  " "        xxxx         xxxxxxx  " "        xxxx         xxxxxxx  " "        xxx          xxxxxxx  " "       xxx           xxxxxxx  " "      xxx            xxxxxxx  " "     xxx             xxxxx x  " "     xx              xx x  x  " "     x               x  x  x  " "                      xx      " "                              " "                              " "                              "))) (make-problem "19990208bFRA (9)" (quote ((2 22) (1 21) (1 22) (3 13 2 6) (1 4 4 10 2 7) (1 10 9 2 8) (1 9 2 8) (1 10 2 7) (1 16 10 2 7) (1 16 9 2 8) (1 1 1 1 1 1 1 8 2 9) (1 1 2 1 1 1 1 1 1 9 2 8) (1 1 1 1 1 1 1 1 21) (1 2 1 1 1 1 1 3 4 3) (1 1 1 1 1 3 3 12 2) (1 16 2 14 1) (1 2 12 1) (1 3 2) (1 4 3) (1 5 4) (1 6 5) (1 5 4) (1 21) (1 5 13) (1 4 3 12) (1 4 3 2) (1 16 4 3 2) (1 4 3 12) (1 5 13) (40))) (quote ((30) (1 1 1) (2 8 1 1) (1 2 1 1 1 1) (1 2 1 1 1 1) (2 8 1 1) (1 2 1 1 1) (1 2 3 1 1 1) (1 2 1 1 1) (1 8 1 1) (1 2 1 1 1) (1 6 1 1 1) (1 2 1 1 1) (1 8 1 1) (2 2 1 1 1) (1 2 1 3 1 1) (1 2 3 1 1) (2 8 1 1) (1 2 1) (30) (30) (15 13) (14 12) (13 1 5 2) (13 3 1 1 4 1) (13 3 1 4 1) (13 3 1 4 1) (10 2 3 2 2) (5 2 1 1 3 3 3) (4 2 4 3 3 3) (3 6 2 3 3 3) (5 2 1 1 3 3 3) (4 2 4 3 3 3) (3 9 3 3 3) (13 3 3 3) (13 3 1 3 3) (13 1 6 3) (14 7 3) (15 13) (30))) (quote ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "x  x                         x" "   xx   xxxxxxxx          x  x" "    x   xx   x x          x  x" "    x   xx x   x          x  x" "    xx  xxxxxxxx          x  x" "     x  xx     x          x  x" "     x  xx xxx x          x  x" "     x  xx     x          x  x" "     x  xxxxxxxx          x  x" "     x  xx     x          x  x" "     x  xxxxxx x          x  x" "     x  xx     x          x  x" "     x  xxxxxxxx          x  x" "    xx  xx     x          x  x" "    x   xx x xxx          x  x" "    x   xx   xxx          x  x" "   xx   xxxxxxxx          x  x" "x xx                         x" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxx  xxxxxxxxxxxxx" "xxxxxxxxxxxxxx    xxxxxxxxxxxx" "xxxxxxxxxxxxx  x   xxxxx    xx" "xxxxxxxxxxxxx xxx   x x xxxx x" "xxxxxxxxxxxxx xxx     x xxxx x" "xxxxxxxxxxxxx xxx     x xxxx x" "xxxxxxxxxx xx xxx     xx    xx" "xxxxx  xx x x xxx     xxx  xxx" "xxxx xx  xxxx xxx     xxx  xxx" "xxx xxxxxx xx xxx     xxx  xxx" "xxxxx  xx x x xxx     xxx  xxx" "xxxx xx  xxxx xxx     xxx  xxx" "xxx xxxxxxxxx xxx     xxx  xxx" "xxxxxxxxxxxxx xxx     xxx  xxx" "xxxxxxxxxxxxx xxx   x xxx  xxx" "xxxxxxxxxxxxx  x   xxxxxx  xxx" "xxxxxxxxxxxxxx    xxxxxxx  xxx" "xxxxxxxxxxxxxxx  xxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"))) (make-problem "19990208cFRA (10)" (quote (() () (17 18) (4 3 3 2 18) (5 2 2 3 5 8 3) (5 1 1 3 4 2 2 2) (3 2 1 1 2 1 5 2 3) (4 3 3 2 6 1 1 4) (4 1 2 6 1 2 1 4) (3 4 4 1 4 1 1 1 1 2) (6 1 1 4 4 1 1 1 1 2) (5 1 1 3 6 1 2 1 4) (5 2 2 3 6 1 1 4) (4 4 4 2 4 1 1 2) (9 7 5 2 2 2 3) (9 7 9 7) () (9 7 9 7) (4 2 2 2 7 1 1 5) (3 3 1 1 3 1 8 6) (8 6 9 7) (5 3 5 3) (5 3 5 3) (6 4 6 4) (6 4 6 4) (6 4 7 5) (6 4 7 5) (7 5 8 6) () ())) (quote (() () (14 11) (14 11) (14 11) (4 2 6 2 8) (1 3 4 2 1 9) (2 2 2 3 1 2 5) (2 1 1 3 1 2 1) (3 1 1 4 2 1) (1 3 6 3) (1 1) (1 3 6 3) (3 1 1 4 2 1) (2 1 1 3 1 2 1) (2 2 2 3 1 2 5) (1 3 4 2 1 9) (4 2 6 2 8) (14 11) () (14 11) (14 11) (14 11) (14 11) (3 3 2 2 11) (2 2 2 1 4 5) (3 2 2 4 3) (4 1 1 2 1 2 1) (4 1 2 2 1 2 1) (3 1 1 1 1) (3 1 1 1 1) (4 1 2 2 1 2 1) (4 1 1 2 1 2 1) (3 2 2 4 3) (2 2 2 1 4 5) (3 3 2 2 11) (14 11) (14 11) () ())) (quote ("                              " "                              " "  xxxxxxxxxxxxxx xxxxxxxxxxx  " "  xxxxxxxxxxxxxx xxxxxxxxxxx  " "  xxxxxxxxxxxxxx xxxxxxxxxxx  " "  xxxx xx xxxxxx xx xxxxxxxx  " "  x xxx  xxxx xx x xxxxxxxxx  " "  xx  xx xx  xxx x xx  xxxxx  " "  xx   x x   xxx x xx      x  " "  xxx  x x  xxxx xx x         " "  x xxx   xxxxxx xxx          " "  x     x                     " "  x xxx   xxxxxx xxx          " "  xxx  x x  xxxx xx x         " "  xx   x x   xxx x xx      x  " "  xx  xx xx  xxx x xx  xxxxx  " "  x xxx  xxxx xx x xxxxxxxxx  " "  xxxx xx xxxxxx xx xxxxxxxx  " "  xxxxxxxxxxxxxx xxxxxxxxxxx  " "                              " "  xxxxxxxxxxxxxx xxxxxxxxxxx  " "  xxxxxxxxxxxxxx xxxxxxxxxxx  " "  xxxxxxxxxxxxxx xxxxxxxxxxx  " "  xxxxxxxxxxxxxx xxxxxxxxxxx  " "  xxx xxx  xx xx xxxxxxxxxxx  " "  xx   xx  xx  x xxxx  xxxxx  " "  xxx    xx   xx xxxx    xxx  " "  xxxx  x  x  xx x xx      x  " "  xxxx x xx xx x xx x         " "  xxx x x  x  x               " "  xxx x x  x  x               " "  xxxx x xx xx x xx x         " "  xxxx  x  x  xx x xx      x  " "  xxx    xx   xx xxxx    xxx  " "  xx   xx  xx  x xxxx  xxxxx  " "  xxx xxx  xx xx xxxxxxxxxxx  " "  xxxxxxxxxxxxxx xxxxxxxxxxx  " "  xxxxxxxxxxxxxx xxxxxxxxxxx  " "                              " "                              "))) (make-problem "19990221aFRA (11)" (quote ((33) (23 8) (21 8) (20 8) (19 8) (18 8) (2 11 8) (1 9 8) (1 3 7 8) (1 4 5 8) (1 5 3 8) (2 1 8) (10 24) (10 1 22) (8 19) (6 4 16) (4 3 6 13) (2 4 9 10) (1 4 11 7) (1 3 14 5) (1 1 17 3) (2 21) (6 1 3 1 1 5) (6 3 2 1 1 1 19) (6 1 1 1 1 1 3 1 3 1 1 1) (8 1 2 1 1 5 3 2 1 1 1 1) (6 1 3 1 1 5 1 1 1 1 1 1) (26 1 2 1 1 3) (24 1 3 1 1 3) (40))) (quote ((30) (7 7 9) (6 5 8) (6 3 5 2 8) (6 3 4 4 8) (6 3 4 3 8) (7 2 3 3 1 1 3) (8 1 3 2 2 1 1 3) (9 2 1 3 1 3) (10 2 13) (11 7 3) (12 1 8 6) (11 9 5) (10 2 10 4) (9 3 6 3) (8 5 14) (7 6 5 3) (6 8 13) (5 9 4 3) (4 11 4 1 5) (3 12 3 5) (2 14 11) (2 8 6 10) (1 8 7 10) (9 8 3 1 1) (8 12 1 1 1) (7 10 1 1 1) (6 9 7) (5 8 1 1) (4 7 2 4) (3 6 3 3) (2 5 4 2) (1 4 1 1) (3 7) (2 1 1) (1 7) (1 1 1) (1 1 3) (1 3) (7))) (quote ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxx    xxxxxxx   xxxxxxxxx" "xxxxxx      xxxxx     xxxxxxxx" "xxxxxx  xxx xxxxx xx  xxxxxxxx" "xxxxxx  xxx xxxx xxxx xxxxxxxx" "xxxxxx  xxx xxxx xxx  xxxxxxxx" "xxxxxxx  xx xxx xxx  x   x xxx" "xxxxxxxx  x xxx xx  xx x x xxx" "xxxxxxxxx   xx  x  xxx x   xxx" "xxxxxxxxxx  xx   xxxxxxxxxxxxx" "xxxxxxxxxxx    xxxxxxx     xxx" "xxxxxxxxxxxx x xxxxxxxx xxxxxx" "xxxxxxxxxxx    xxxxxxxxx xxxxx" "xxxxxxxxxx  xx xxxxxxxxxx xxxx" "xxxxxxxxx  xxx  xxxxxx     xxx" "xxxxxxxx  xxxxx xxxxxxxxxxxxxx" "xxxxxxx  xxxxxx  xxxxx     xxx" "xxxxxx  xxxxxxxx xxxxxxxxxxxxx" "xxxxx  xxxxxxxxx  xxxx     xxx" "xxxx  xxxxxxxxxxx xxxx x xxxxx" "xxx  xxxxxxxxxxxx  xxx   xxxxx" "xx  xxxxxxxxxxxxxx xxxxxxxxxxx" "xx xxxxxxxx xxxxxx  xxxxxxxxxx" "x xxxxxxxx  xxxxxxx xxxxxxxxxx" "xxxxxxxxx   xxxxxxxx xxx   x x" "xxxxxxxx    xxxxxxxxxxxx x x x" "xxxxxxx     xxxxxxxxxx x x   x" "xxxxxx      xxxxxxxxx  xxxxxxx" "xxxxx       xxxxxxxx   x     x" "xxxx        xxxxxxx    xx xxxx" "xxx         xxxxxx     xxx xxx" "xx          xxxxx      xxxx xx" "x           xxxx       x     x" "            xxx        xxxxxxx" "            xx         x     x" "            x          xxxxxxx" "            x          x     x" "                       x x xxx" "                       x   xxx" "                       xxxxxxx"))) (make-problem "19990401-JOJ (12)" (quote ((40) (40) (12 24) (9 21) (7 4 19) (6 10 18) (5 5 5 17) (4 3 4 16) (3 3 6 3 15) (2 3 3 3 3 14) (2 2 2 2 2 5 7) (2 2 3 5 2 2 4 7) (1 2 2 2 2 1 2 5 5 1) (1 1 2 2 2 2 2 4 5 1) (2 2 2 3 1 2 2 4 5 1) (2 1 1 3 1 2 2 5 3 2) (2 1 1 3 2 2 2 5 3 2) (2 2 2 5 2 2 7 1 3) (1 2 2 2 2 2 6 2) (1 2 3 3 3 3 5 4 1) (2 2 3 7 3 3 3 2 1) (2 2 3 2 3 2 8 1) (2 3 4 4 9 1) (3 3 9 12 2) (4 4 4 10 4) (5 5 11 7) (6 19 10) (8 16 11) (9 13 13) (10 15))) (quote ((14 12) (12 10) (9 4 7) (8 10 6) (7 4 5 5) (6 3 3 4) (5 3 7 3 3) (4 3 4 4 3 3) (4 2 3 3 2 2) (3 2 3 4 3 3 1) (3 2 1 2 2 2 3) (3 2 2 2 2 2 4) (2 2 1 2 2 2 2 3) (2 2 1 1 4 2 2 3) (2 2 1 1 4 2 2 3) (2 2 1 1 1 1 2 2 3) (3 2 2 2 1 1 2 3) (3 2 1 2 2 2 1 3) (3 3 2 4 2 2 4) (4 2 2 2 2 4) (4 3 3 3 2 4) (5 3 5 3 5) (6 3 2 3 5) (7 4 4 6) (8 9 5) (9 4 1 5 1) (11 3 4 1) (13 4 4 2) (21 4 2) (20 3 3) (20 4 4) (10 7 3 4) (12 4 4 4) (15 1 5 5) (17 5 5) (18 1 2 5) (17 4 6) (15 1 2 6) (12 4 7) (10 18))) (quote ("xxxxxxxxxxxxxx    xxxxxxxxxxxx" "xxxxxxxxxxxx        xxxxxxxxxx" "xxxxxxxxx     xxxx     xxxxxxx" "xxxxxxxx   xxxxxxxxxx   xxxxxx" "xxxxxxx  xxxx     xxxxx  xxxxx" "xxxxxx  xxx          xxx  xxxx" "xxxxx  xxx   xxxxxxx  xxx  xxx" "xxxx  xxx  xxxx  xxxx  xxx xxx" "xxxx  xx  xxx      xxx  xx  xx" "xxx  xx  xxx  xxxx  xxx xxx  x" "xxx  xx  x   xx  xx  xx  xxx  " "xxx  xx xx  xx    xx  xx xxxx " "xx  xx  x  xx  xx  xx xx  xxx " "xx  xx  x  x  xxxx xx  xx xxx " "xx  xx  x  x  xxxx  xx xx xxx " "xx  xx  x  x  x  x  xx xx xxx " "xxx  xx xx xx    x  x  xx xxx " "xxx  xx  x  xx  xx xx  x  xxx " "xxx  xxx xx  xxxx  xx xx xxxx " "xxxx  xx  xx      xx  xx xxxx " "xxxx  xxx  xxx  xxx  xx  xxxx " "xxxxx  xxx   xxxxx  xxx xxxxx " "xxxxxx  xxx   xx   xxx  xxxxx " "xxxxxxx  xxxx    xxxx  xxxxxx " "xxxxxxxx   xxxxxxxxx   xxxxx  " "xxxxxxxxx    xxxx    x xxxxx x" "xxxxxxxxxxx        xxx xxxx  x" "xxxxxxxxxxxxx    xxxx  xxxx xx" "xxxxxxxxxxxxxxxxxxxxx xxxx  xx" "xxxxxxxxxxxxxxxxxxxx  xxx  xxx" "xxxxxxxxxxxxxxxxxxxx xxxx xxxx" "xxxxxxxxxx  xxxxxxx  xxx  xxxx" "xxxxxxxxxxxx   xxxx xxxx  xxxx" "xxxxxxxxxxxxxxx  x xxxxx xxxxx" "xxxxxxxxxxxxxxxxx  xxxxx xxxxx" "xxxxxxxxxxxxxxxxxx x xx  xxxxx" "xxxxxxxxxxxxxxxxx  xxxx xxxxxx" "xxxxxxxxxxxxxxx  x  xx  xxxxxx" "xxxxxxxxxxxx   xxxx    xxxxxxx" "xxxxxxxxxx  xxxxxxxxxxxxxxxxxx"))) (make-problem "19990525aKHO (13)" (quote ((2 3 1 1 2) (9 2 3 3 4) (4 21 1) (5 2 1 5 2 2 2 2) (3 2 2 4) (4) (2) () (7) (12 5) (12 3) (2 2 3) (2 2 3) (2 2 3) (2 2 3) (2 2 3) (2 2 3) (24) (2 4 9 3 2) (2 4 10 2 1) (2 2 4 15 1) (3 3 2 1 1) (1 2 23 1) (2 8 3 16 1) (3 2 2 4 16) (11 1 2 2 9 3) (2 5 2 1 1 1 1 1 2 3) (1 1 3 1 4 1 1 7 1 1 2) (1 1 1 1 1 2 2 1 1 3) (1 1 4 2 4))) (quote ((8) (2 4 1) (3 2 2 1 1) (5 2 2 1) (5 1 3) (4 1 4) (1 1 1 3) (3 1 2 1) (4 1 1 1 1) (4 4 1) (2 5) (2 2 1) (2 2 1) (2 19) (1 16) (2 2 1 3 4) (4 2 4 1 2 2) (5 2 4 1 1 1) (3 2 4 1 1 1) (2 2 4 1 2 2) (2 2 1 3 4) (3 16) (4 12 6) (1 4 4 1) (2 4 4 1) (4 4 4 1) (4 4 4 1) (2 4 4 1) (2 4 4 1) (3 1 4 5) (2 1 2 4 2) (2 11 1 3 1 1) (4 11 1 3 1 1) (4 11 1 4 2) (2 2 1 2 5) (1 10) (2 1 4) (5 3) (2) (1))) (quote #f)) (make-problem "19990527aDRA (14)" (quote ((11 27) (10 2 25) (9 2 2 23) (8 8 21) (7 5 5 19) (6 11 19) (6 1 4 3 1 10 7) (6 3 5 2 8 2 6) (6 5 2 3 6 5 5) (6 2 4 4 4 4 3 4) (6 5 2 4 2 11 3) (6 2 5 2 1 2 4 4 3 2) (6 5 2 4 2 13 1) (6 2 5 4 2 1 4 6 1) (6 4 2 3 3 2 8 1 1) (8 5 2 4 3 5 3 1) (10 3 1 5 1 2 2 5 1) (12 1 6 5 5 1 1) (14 7 6 1 5 1) (23 6 7 1) (1 1 2 1 1 1 2 2 3 3 1) (1 3 2 1 2 1 2 1 4 4 5 1 1) (1 3 2 1 2 3 3 1 5 1) (1 3 1 2 2 1 6 4 2 5 2) (1 1 2 1 2 1 4 5 1 3 4) (29 1 6) (30 8) (40) (40) (40))) (quote ((30) (20 5) (20 3 5) (20 3 5) (30) (20 5) (5 5 1 7) (4 8 5 1 6) (3 2 8 4 2 5) (2 3 2 1 1 1 14) (1 5 8 4 5) (6 8 3 1 7) (1 5 1 1 1 2 2 1 7) (1 2 3 8 2 5) (1 4 2 8 11) (2 6 1 5) (2 5 8 2 1 7) (3 3 8 3 1 7) (3 2 4 3 4 8) (4 8 15) (4 6 1 5) (20 1 1 5) (20 1 5) (10 10) (10 1 7 9) (9 3 2 4 8) (9 4 7 7) (8 6 4 2 6) (8 2 4 7 5) (7 9 7 4) (7 5 3 3) (6 2 6 9 3) (6 9 1 3 2 4) (7 3 3 9 4) (8 6 4 3 5) (9 4 9 5) (10 3 2 3 1 6) (11 1 9 6) (12 7) (30))) (quote ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxx     xxxxx" "xxxxxxxxxxxxxxxxxxxx xxx xxxxx" "xxxxxxxxxxxxxxxxxxxx xxx xxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxx     xxxxx" "xxxxx          xxxxx x xxxxxxx" "xxxx  xxxxxxxx xxxxx x  xxxxxx" "xxx xx xxxxxxxx xxxx  xx xxxxx" "xx xxx xx x x x xxxxxxxxxxxxxx" "x xxxxx xxxxxxxx xxxx    xxxxx" " xxxxxx xxxxxxxx xxx x xxxxxxx" " x xxxxx x x x xx xx x xxxxxxx" "x xx xxx xxxxxxxx xx     xxxxx" "x xxxx xx xxxxxxxx xxxxxxxxxxx" "xx xxxxxx          x     xxxxx" "xx xxxxx xxxxxxxx xx x xxxxxxx" "xxx xxx xxxxxxxx xxx x xxxxxxx" "xxx xx xxxx xxx xxxx  xxxxxxxx" "xxxx  xxxxxxxx xxxxxxxxxxxxxxx" "xxxx          xxxxxx   x xxxxx" "xxxxxxxxxxxxxxxxxxxx x x xxxxx" "xxxxxxxxxxxxxxxxxxxx x   xxxxx" "xxxxxxxxxx          xxxxxxxxxx" "xxxxxxxxxx x xxxxxxx xxxxxxxxx" "xxxxxxxxx xxx xx xxxx xxxxxxxx" "xxxxxxxxx xxxx xxxxxxx xxxxxxx" "xxxxxxxx xxxxxx xxxx xx xxxxxx" "xxxxxxxx xx xxxx xxxxxxx xxxxx" "xxxxxxx xxxxxxxxx xxxxxxx xxxx" "xxxxxxx xxxxx xxx          xxx" "xxxxxx xx xxxxxx xxxxxxxxx xxx" "xxxxxx xxxxxxxxx x xxx xx xxxx" "xxxxxxx xxx xxx xxxxxxxxx xxxx" "xxxxxxxx xxxxxx xxxx xxx xxxxx" "xxxxxxxxx xxxx xxxxxxxxx xxxxx" "xxxxxxxxxx xxx xx xxx x xxxxxx" "xxxxxxxxxxx x xxxxxxxxx xxxxxx" "xxxxxxxxxxxx           xxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"))) (make-problem "19990527eDRA (15)" (quote ((16 11 11) (17 9 12) (18 7 13) (14 4) (12 6 3 8 4) (10 19 2 4) (8 19 4 4) (7 6 4) (7 20 6 4) (7 20 6 4) (7 2 4 6 4) (7 2 12 1 1 6 4) (7 2 3 3 1 1 6 4) (7 2 2 3 4 6 4) (7 2 1 5 3 4 6 4) (7 2 1 1 1 1 3 1 1 6 4) (7 2 1 2 2 3 1 1 6 4) (7 2 1 5 4 4 6 4) (7 2 1 1 1 4 4 6 4) (7 2 2 3 5 1 1 6 4) (7 2 1 1 2 1 1 6 4) (7 2 9 1 4 6 4) (7 2 10 1 1 1 6 4) (7 2 2 5 1 1 1 1 6 4) (7 2 4 6 4) (7 20 5 4) (7 20 3 6) (7 20 1 8) (7 10) (40))) (quote ((30) (30) (30) (30) (30) (30) (30) (7 1) (6 20 1) (6 20 1) (5 1 2 3 1) (5 1 2 9 2 3 1) (4 2 2 3 1 3 3 1) (4 2 2 2 5 3 3 1) (3 3 2 1 1 2 1 3 3 1) (3 3 2 1 2 1 1 3 3 1) (2 3 2 1 1 2 1 3 3 1) (1 1 3 2 1 5 4 3 1) (2 3 2 1 1 3 3 1) (3 3 2 1 3 2 3 1) (3 2 2 9 3 3 1) (3 3 2 10 3 1) (3 3 2 13 3 1) (3 3 2 3 1) (3 2 20 1) (3 3 3 2 2 1 4 1) (2 3 3 2 2 1 4 1) (1 1 3 20 1) (2 3 1) (3 2 21 1) (3 2 20 2) (3 1 21 2) (3 1 20 3) (3 21 3) (3 20 4) (3 4) (30) (30) (30) (30))) (quote ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxx                      x" "xxxxxx  xxxxxxxxxxxxxxxxxxxx x" "xxxxxx  xxxxxxxxxxxxxxxxxxxx x" "xxxxx x xx               xxx x" "xxxxx x xx xxxxxxxxx  xx xxx x" "xxxx xx xx xxx     x xxx xxx x" "xxxx xx xx xx xxxxx xxx  xxx x" "xxx xxx xx x  x xx x xxx xxx x" "xxx xxx xx x  xx x x xxx xxx x" " xx xxx xx x  x xx x xxx xxx x" "x x xxx xx x  xxxxx xxxx xxx x" "xx  xxx xx x       x xxx xxx x" "xxx xxx xx x     xxx xx  xxx x" "xxx  xx xx xxxxxxxxx xxx xxx x" "xxx xxx xx xxxxxxxxxx    xxx x" "xxx xxx xx xxxxxxxxxxxxx xxx x" "xxx xxx xx               xxx x" "xxx  xx xxxxxxxxxxxxxxxxxxxx x" "xxx xxx xxx  xx  xx  x  xxxx x" "xx  xxx xxx  xx  xx  x  xxxx x" "x x xxx xxxxxxxxxxxxxxxxxxxx x" " xx xxx                      x" "xxx xx xxxxxxxxxxxxxxxxxxxxx x" "xxx xx xxxxxxxxxxxxxxxxxxxx xx" "xxx x xxxxxxxxxxxxxxxxxxxxx xx" "xxx x xxxxxxxxxxxxxxxxxxxx xxx" "xxx  xxxxxxxxxxxxxxxxxxxxx xxx" "xxx  xxxxxxxxxxxxxxxxxxxx xxxx" "xxx                       xxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"))) (make-problem "19990613-FRA (16)" (quote ((40) (40) (8 2 23) (18 18) (22 14) (27 12) (27 12) (3 1 11) (3 1 1 10) (3 1 2 9) (3 1 8) (3 1 3 8) (3 1 1 1 8) (3 1 3 4) (3 1 7 4) (3 7 4) (3 1 7 4) (3 4) (5 13 6 7) (4 3 11 3 4 3 6) (4 3 11 3 4 3 6) (5 13 6 7) (40) (1 4 2 2) (40) (40) (40) (40) (40) (40))) (quote ((30) (23 6) (23 6) (7 5 6) (7 1 2 6) (7 2 1 6) (7 2 1 6) (7 2 1 6) (2 4 1 2 6) (2 4 5 6) (2 4 12) (2 4 12) (7 12) (7 12) (2 4 5 6) (2 4 5 6) (2 4 5 6) (7 5 6) (3 3 5 6) (3 3 5 6) (3 3 1 2 6) (3 3 2 1 6) (4 2 2 1 6) (4 2 2 8) (4 2 1 9) (4 2 5 6) (15 1 5 6) (5 5 6) (7 2 6 5 6) (8 1 1 4 1 2 6) (9 6 2 1 6) (10 3 2 1 6) (13 3 2 1 6) (13 3 1 9) (13 3 12) (13 5 6) (23 6) (23 6) (23 6) (23 6))) (quote ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxx xxxxxx" "xxxxxxxxxxxxxxxxxxxxxxx xxxxxx" "xxxxxxx           xxxxx xxxxxx" "xxxxxxx           x  xx xxxxxx" "xxxxxxx            xx x xxxxxx" "xxxxxxx            xx x xxxxxx" "xxxxxxx            xx x xxxxxx" "xx xxxx           x  xx xxxxxx" "xx xxxx           xxxxx xxxxxx" "xx xxxx           xxxxxxxxxxxx" "xx xxxx           xxxxxxxxxxxx" "xxxxxxx           xxxxxxxxxxxx" "xxxxxxx           xxxxxxxxxxxx" "xx xxxx           xxxxx xxxxxx" "xx xxxx           xxxxx xxxxxx" "xx xxxx           xxxxx xxxxxx" "xxxxxxx           xxxxx xxxxxx" "xxx xxx           xxxxx xxxxxx" "xxx xxx           xxxxx xxxxxx" "xxx xxx           x  xx xxxxxx" "xxx xxx            xx x xxxxxx" "xxxx xx            xx x xxxxxx" "xxxx xx            xx xxxxxxxx" "xxxx xx           x  xxxxxxxxx" "xxxx xx           xxxxx xxxxxx" "xxxxxxxxxxxxxxx x xxxxx xxxxxx" "xxxxx             xxxxx xxxxxx" "xxxxxxx xx xxxxxx xxxxx xxxxxx" "xxxxxxxx x x xxxx x  xx xxxxxx" "xxxxxxxxx  xxxxxx  xx x xxxxxx" "xxxxxxxxxx    xxx  xx x xxxxxx" "xxxxxxxxxxxxx xxx  xx x xxxxxx" "xxxxxxxxxxxxx xxx x  xxxxxxxxx" "xxxxxxxxxxxxx xxx xxxxxxxxxxxx" "xxxxxxxxxxxxx     xxxxx xxxxxx" "xxxxxxxxxxxxxxxxxxxxxxx xxxxxx" "xxxxxxxxxxxxxxxxxxxxxxx xxxxxx" "xxxxxxxxxxxxxxxxxxxxxxx xxxxxx" "xxxxxxxxxxxxxxxxxxxxxxx xxxxxx"))) (make-problem "19990714aNEP (17)" (quote ((33) (2) (1 1 3 3 1 1 1 1 2 2 2 3) (1 1 1 1 1 1 1 1 1 1 1 1 1 3) (1 1 3 1 1 1 1 1 1 1 1 2 3) (1 1 1 3 3 3 1 1 1 2) (1 1 2) (26 2) (2 2) (2 3) (2 3) (2 6) (1 6) (1 6) (2 6) (2 7) (2 7) (2 7) (2 8) (2 8) (2 8) (2 8) (3 6) (2 4) (2 3) (2 2) (2 7) (2 11) (5 13) (4 14))) (quote ((1 3 4) (1 1 2 2) (1 3 2 2) (1 2 2) (1 4 2 2) (1 1 1 1 2) (1 4 1 2) (1 1 2) (1 4 1 2) (1 1 1 1 1) (1 1 1 1 2) (1 1 2) (1 4 1 2) (1 1 1 2) (1 4 1 2) (1 1 2) (1 4 1 1) (1 1 1 1) (1 4 1 1) (1 1 2) (1 4 1 1) (1 1 1 1) (1 2 1 1) (1 1 1) (1 6 1) (1 1 2) (1 1 3) (1 1 3) (1 1 5 3) (1 4 10 4) (1 3 19) (3 21) (2 20 4) (20 4) (3 11 4) (2 11 4) (1 3) (2) () ())) (quote #f)) (make-problem "19990729-DAH (18)" (quote ((16 16) (11 6 11) (9 16 9) (7 7 9 7) (5 4 3 4 5) (4 4 3 4 4) (3 3 3 3 3 3) (2 4 3 7 4 2) (1 3 3 11 3 1) (4 3 7 3 4) (3 3 7 3 3) (3 3 7 3 3) (3 3 8 3 3) (3 3 9 3 3) (3 3 9 3 3) (3 3 10 3 3) (3 3 9 3 3) (3 3 8 3 3) (3 3 8 3 3) (3 3 7 3 3) (4 3 7 3 4) (1 3 11 3 3 1) (2 4 7 3 4 2) (3 3 3 3 3 3) (4 4 3 4 4) (5 4 3 4 5) (7 9 7 7) (9 15 9) (12 6 11) (16 16))) (quote ((9 6 9) (8 10 8) (7 12 7) (6 4 4 6) (5 3 3 5) (4 4 4 4) (4 3 3 4) (3 3 3 3) (3 2 6 2 3) (2 2 10 2 2) (2 2 12 2 2) (1 2 4 4 2 2) (1 2 2 2 1 1) (1 2 2 2 2 1) (1 2 1 2 2 1) (1 2 2 4 3 2 1) (2 1 7 4 2) (2 2 15 3) (2 1 15 4) (2 2 15 1 2) (2 1 15 2 2) (4 15 1 2) (3 15 2 2) (2 4 7 1 2) (1 2 3 4 2 2 1) (1 2 2 1 2 1) (1 2 2 2 2 1) (1 2 2 2 2 1) (1 2 4 4 2 1) (2 2 12 2 2) (2 2 10 2 2) (3 2 6 2 3) (3 3 3 3) (4 3 3 4) (4 4 4 4) (5 3 3 5) (6 4 4 6) (7 12 7) (8 10 8) (9 6 9))) (quote ("xxxxxxxxx   xxxxxx   xxxxxxxxx" "xxxxxxxx  xxxxxxxxxx  xxxxxxxx" "xxxxxxx  xxxxxxxxxxxx  xxxxxxx" "xxxxxx  xxxx      xxxx  xxxxxx" "xxxxx  xxx          xxx  xxxxx" "xxxx  xxxx          xxxx  xxxx" "xxxx xxx              xxx xxxx" "xxx  xxx              xxx  xxx" "xxx xx      xxxxxx      xx xxx" "xx  xx    xxxxxxxxxx    xx  xx" "xx xx    xxxxxxxxxxxx    xx xx" "x  xx   xxxx      xxxx   xx xx" "x xx    xx          xx    x  x" "x xx   xx            xx   xx x" "x xx   x             xx   xx x" "x xx  xx    xxxx     xxx  xx x" "  xx  x   xxxxxxx   xxxx  xx  " " xx  xx  xxxxxxxxxxxxxxx  xxx " " xx  x  xxxxxxxxxxxxxxx  xxxx " " xx xx  xxxxxxxxxxxxxxx  x xx " " xx x  xxxxxxxxxxxxxxx  xx xx " " xxxx  xxxxxxxxxxxxxxx  x  xx " " xxx  xxxxxxxxxxxxxxx  xx  xx " "  xx  xxxx   xxxxxxx   x  xx  " "x xx  xxx      xxxx   xx  xx x" "x xx   xx             x   xx x" "x xx   xx            xx   xx x" "x xx    xx          xx    xx x" "x  xx   xxxx      xxxx   xx  x" "xx xx    xxxxxxxxxxxx    xx xx" "xx  xx    xxxxxxxxxx    xx  xx" "xxx xx      xxxxxx      xx xxx" "xxx  xxx              xxx  xxx" "xxxx xxx              xxx xxxx" "xxxx  xxxx          xxxx  xxxx" "xxxxx  xxx          xxx  xxxxx" "xxxxxx  xxxx      xxxx  xxxxxx" "xxxxxxx  xxxxxxxxxxxx  xxxxxxx" "xxxxxxxx  xxxxxxxxxx  xxxxxxxx" "xxxxxxxxx   xxxxxx   xxxxxxxxx"))) (make-problem "19990924-KHO (19)" (quote (() (37) (31) (24) (17) (14) (21 13) (23 4) (24 3) (8 8 3) (9 10 2) (10 13 2) (11 3 2) (12 3 2) (13 3 2) (14 5 2 3) (15 6 1 3) (16 6 4) (22 7) (19 10) (16 13) (13 16) (10 19) (7 22) (4 25) (1 28) (31) (34) (37) ())) (quote (() (20) (1 19 1) (1 19 1) (1 19 1) (1 18 2) (1 18 2) (1 18 2) (2 17 3) (2 3 13 3) (2 3 12 3) (2 3 10 4) (2 3 9 4) (2 3 8 4) (2 3 6 5) (3 3 5 5) (3 3 4 5) (3 3 2 6) (3 3 2 6) (3 3 2 6) (3 3 2 7) (3 3 2 7) (4 2 1 2 7) (4 2 1 2 8) (4 1 1 2 8) (5 2 2 8) (6 3 2 9) (6 3 2 9) (6 3 2 9) (6 3 1 10) (6 3 1 10) (6 3 10) (6 6 11) (6 8 11) (6 6 11) (7 12) (9 14) (28) (28) ())) (quote ("                              " "      xxxxxxxxxxxxxxxxxxxx    " " x    xxxxxxxxxxxxxxxxxxx   x " " x    xxxxxxxxxxxxxxxxxxx   x " " x    xxxxxxxxxxxxxxxxxxx   x " " x    xxxxxxxxxxxxxxxxxx   xx " " x    xxxxxxxxxxxxxxxxxx   xx " " x    xxxxxxxxxxxxxxxxxx   xx " " xx   xxxxxxxxxxxxxxxxx   xxx " " xx   xxx xxxxxxxxxxxxx   xxx " " xx   xxx  xxxxxxxxxxxx   xxx " " xx   xxx   xxxxxxxxxx   xxxx " " xx   xxx    xxxxxxxxx   xxxx " " xx   xxx     xxxxxxxx   xxxx " " xx   xxx      xxxxxx   xxxxx " " xxx  xxx       xxxxx   xxxxx " " xxx  xxx        xxxx   xxxxx " " xxx  xxx         xx   xxxxxx " " xxx  xxx         xx   xxxxxx " " xxx  xxx         xx   xxxxxx " " xxx  xxx        xx   xxxxxxx " " xxx  xxx        xx   xxxxxxx " " xxxx  xx  x     xx   xxxxxxx " " xxxx  xx  x    xx   xxxxxxxx " " xxxx   x  x    xx   xxxxxxxx " " xxxxx    xx    xx   xxxxxxxx " " xxxxxx  xxx   xx   xxxxxxxxx " " xxxxxx  xxx   xx   xxxxxxxxx " " xxxxxx  xxx   xx   xxxxxxxxx " " xxxxxx  xxx   x   xxxxxxxxxx " " xxxxxx  xxx   x   xxxxxxxxxx " " xxxxxx  xxx       xxxxxxxxxx " " xxxxxx  xxxxxx   xxxxxxxxxxx " " xxxxxx  xxxxxxxx xxxxxxxxxxx " " xxxxxx   xxxxxx  xxxxxxxxxxx " " xxxxxxx         xxxxxxxxxxxx " " xxxxxxxxx     xxxxxxxxxxxxxx " " xxxxxxxxxxxxxxxxxxxxxxxxxxxx " " xxxxxxxxxxxxxxxxxxxxxxxxxxxx " "                              "))) (make-problem "19990928-BBA (20)" (quote ((3 2) (1 2) (3) (3) (1 2 27) (1 1 1 2 3 3 2 2 1) (3 2 1 2 1 1 3 2) (1 1 2 1 1 1 3 3) (1 1 3 3 1 1 3 1 3) (3 1 5 2 1 1 3 2 3) (5 8 8 1 5) (3 1 5 1 4 1 5) (1 1 3 1 1 2 1 5) (1 1 1 3 1 1 1 2 3) (1 1 1 1 2 1 3) (1 1 1 1 2 3) (1 3 1 1 1 1 3) (1 1 1 1 1 1 3) (1 1 1 1 1 1 1 1 3) (1 1 1 1 1 1 1 1 1 3) (2 1 1 3 15) (2 2 5 2 1 5) (1 1 1 2 3 1 1 4) (1 5 1 2 3 3 2) (1 3 1 3 2 1 1 1 1) (1 1 1 1 1 2 1 3 1) (1 6 1 7 1 1) (1 1 1 2 3 1 2 2) (1 7 1 13) (1 2 3 2 4 2 1))) (quote ((1 1) (7 1) (1 2 1 3) (4 5) (2 3 3) (1 1 1) () (26) (1 1 2) (1 3 1 7) (1 5 1 1 2 1 2) (1 7 11) (1 5 1 1 1) (2 3 1 1 5 1) (4 1 1 2 4) (1 4 2 1 2 1 3) (2 5 3 3 3 1) (3 1 1 1 1 2 1 1) (2 1 2 1 1 1 2 3) (1 1 1 1 1 3 1) (2 1 2 7 1) (3 1 9 2 5) (2 1 3 1 1 1 1) (1 11 1 3 1 2) (2 3 2 2 1 1 2) (5 6 2 2 2) (1 2 2 2 1 1 2) (3 3 3 1 3 3) (2 2 2 1 1 2) (1 5 2 1 2) (1 3 3 3 2) (1 16 1 1) (1 18 2) (26) () () () () () ())) (quote #f)) (make-problem "19991011bLLO (21)" (quote ((9) (4 2 4 3) (6 2 5 2) (5 12 4) (1 13 7) (3 3 5 3 4 2) (4 4 2 4 1 5) (1 4 8 10) (2 7 4 1 4 1) (7 4 1 6 3) (4 4 8 5 1) (2 4 1 3 4 4 1 2) (11 9 5) (3 2 6 1 5 1) (3 4 1 4 5 2 1) (1 5 5 3 1 2 1) (7 2 8) (5 1 1 1 3) (4 1 1) (4 1 1) (3 1 1) (3 1 1) (3 1 1) (3 1 1) (3 1 1 10) (3 1 1 2 2) (4 1 1 5 4 5) (5 6 1 1 2 1 1) (5 1 4 1) (8 1 1 2 2 1 1))) (quote ((7 3 1) (1 2 7) (7 2 3 1) (4 2 4 2 1) (5 6 2 4) (2 6 19) (5 22) (3 3 1 1 16) (1 6 3 1 4 3) (2 3 4 2 3 1) (1 8 6) (8 3 1 1) (2 3 9 1) (5 2 1 5) (15 1 1) (1 2 2 1 3 2 11) (8 5 2 1) (5 7 3 1) (1 2 1 2 3 12) (7 6 1) (4 3 4 1) (10 4) (2 3 4 3 1) (3 1 1 1 2 2 1) (8 2 1 1 1) (2 2 2 2 1) (1 2 1 1 1) (2 1) (2 1) (3 2) (1 3) (1 3) (3 2) (2 1) (1) (1 1) (2 1) (1 1) (2 1) (1))) (quote #f)))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/problems/k40x35 b/collects/games/paint-by-numbers/problems/k40x35
new file mode 100644
index 0000000000..9e395fcb61
--- /dev/null
+++ b/collects/games/paint-by-numbers/problems/k40x35
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 40x35") (define problems (list (make-problem "19981012-TAB (1)" (quote ((12 13 13) (9 10) (12 13 13) (9 10) (13 9 14) (12 13 13) (12 13 13) (11 15 12) (11 11 12) (11 5 12) (11 1 12) (11 12) (12 13) (13 14) (14 15) (16 17) (18 19) (18 1 19) (18 19) (16 3 17) (14 3 3 15) (13 11 14) (12 6 6 13) (11 7 7 12) (11 6 6 12) (11 5 5 12) (11 4 4 12) (11 3 3 12) (12 1 1 13) (12 13) (13 14) (9 10) (12 13 13) (9 10) (12 13 13))) (quote ((35) (35) (35) (35) (35) (35) (35) (35) (35) (1 1 27 1 1) (1 1 27 1 1) (1 1 3 11 3 1 1) (1 1 9 5 1) (1 1 3 7 7 1 1) (1 1 4 5 7 1 1) (1 1 5 5 6 1 1) (1 1 5 3 6 1 1) (1 1 6 3 5 1 1) (1 1 6 5 1 1) (1 1 7 1 1 1 1 1) (1 1 6 5 1 1) (1 1 6 3 5 1 1) (1 1 5 3 6 1 1) (1 1 5 5 6 1 1) (1 1 4 5 7 1 1) (1 1 3 7 7 1 1) (1 1 9 5 1) (1 1 3 11 3 1 1) (1 1 27 1 1) (1 1 27 1 1) (35) (35) (35) (35) (35) (35) (35) (35) (35) (35))) (quote ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "x x xxxxxxxxxxxxxxxxxxxxxxxxxxx x x" "x x xxxxxxxxxxxxxxxxxxxxxxxxxxx x x" "x x xxx     xxxxxxxxxxx     xxx x x" "    x  x     xxxxxxxxx xxxxx  x    " "x x  xxx      xxxxxxx xxxxxxx   x x" "x x  xxxx      xxxxx xxxxxxx    x x" "x x xxxxx      xxxxx xxxxxx     x x" "x x xxxxx       xxx xxxxxx      x x" "x x xxxxxx      xxx xxxxx       x x" "x x xxxxxx         xxxxx        x x" "x x xxxxxxx      x x x          x x" "x x xxxxxx         xxxxx        x x" "x x xxxxxx      xxx xxxxx       x x" "x x xxxxx       xxx xxxxxx      x x" "x x xxxxx      xxxxx xxxxxx     x x" "x x  xxxx      xxxxx xxxxxxx    x x" "x x  xxx      xxxxxxx xxxxxxx   x x" "    x  x     xxxxxxxxx xxxxx  x    " "x x xxx     xxxxxxxxxxx     xxx x x" "x x xxxxxxxxxxxxxxxxxxxxxxxxxxx x x" "x x xxxxxxxxxxxxxxxxxxxxxxxxxxx x x" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"))) (make-problem "19981216-JTR (2)" (quote ((40) (14 10 14) (3 7 8 7 3) (2 1 1 4 8 4 2 2) (1 2 4 1 4 6 4 5 1) (2 1 4 4 4 2 1 1) (3 2 2 1 3 4 3 1 2 2 3) (2 1 2 3 1 3 2 3 1 1 1 2 1) (1 2 3 1 2 2 2 1 3 1 2 1) (2 3 2 2 1 1 2 1 1 2 2 2 2) (1 1 1 1 1 2 1 1 1 1 1 1 1 1 1) (2 6 1 1 1 1 6 1 2) (1 1 2 1 3 1 1 1 1 1 2 1) (1 1 4 2 1 2 2 6 1 1) (2 2 1 1 4 2 1 3 1 1 2) (3 3 3 1 2 1 3 2 3) (4 2 1 3 2 5 3 4) (5 2 7 2 1 3 3 5) (6 2 2 2 6) (5 7 2 7 5) (5 5 1 2 1 5 5) (5 2 1 1 1 2 1 1 5) (4 1 1 1 5 2 6 1 2 4) (4 1 4 1 1 2 1 1 4 4) (4 2 1 1 1 1 2 1 1 1 3 4) (4 1 1 2 1 1 2 2 1 2 1 1 4) (4 1 1 2 1 2 2 1 2 1 4) (4 2 1 1 1 1 1 1 2 1 2 4) (5 3 1 1 2 2 1 1 2 5) (6 1 1 1 8 1 2 1 6) (7 5 8 1 7) (8 10 8) (40) (40) (40))) (quote ((5 23) (4 5 21) (3 1 2 1 2 20) (2 3 2 2 19) (2 1 1 1 1 1 5 7) (2 1 3 1 1 1 1 3 6) (2 2 4 1 3 2 2 1 5) (2 1 2 1 1 3 3 3 4) (3 1 3 1 2 1 2 2 3) (3 2 1 5 1 1 2 3 1 3) (3 1 3 1 1 1 1 1 1 2 1 1 3) (4 1 2 2 1 1 1 1 3 2 3) (5 1 2 2 2 1 1 2 1 3) (6 1 2 1 1 1 1 6 1 3) (1 5 1 1 3 1 1 1 1 3) (2 4 1 1 2 2 2 3 3 4) (4 4 1 1 1 2 1 1 2 6) (5 3 1 2 1 1 7) (7 2 8) (10 13 6) (10 13 6) (7 2 8) (5 3 3 1 1 1 7) (4 4 1 2 1 1 2 2 6) (2 4 1 1 2 2 2 3 3 4) (1 5 1 1 1 1 1 1 1 1 3) (6 1 1 1 2 1 6 3) (5 1 2 3 1 1 1 3 3) (4 2 2 1 1 1 1 3 2 3) (3 1 1 1 1 1 1 2 2 3) (3 2 1 1 4 1 1 1 3 3) (3 1 5 1 3 1 1 1 2 3) (2 1 1 1 1 2 2 1 2 4) (2 2 2 1 1 1 1 1 1 1 1 5) (2 3 1 3 1 1 1 2 6) (2 1 1 1 3 5 7) (2 1 1 1 2 19) (3 2 1 1 20) (4 4 21) (5 23))) (quote #f)) (make-problem "19990420-DRA (3)" (quote ((40) (40) (40) (6 2 30) (6 29) (5 1 28) (4 1 2 27) (3 3 26) (2 5 25) (1 5 24) (1 5 5 23) (2 7 5 6 4 3) (11 5 2 1 2) (11 6 4 1) (11 4 2 1) (11 1 1 1 1 1) (11 1 1 1) (10 1 2) (9 1 2) (7 2 1 1) (6 4 3 1 1) (5 2 10 4 1) (4 5 11 5 1) (4 5 10 1 3 2) (5 4 11 2 5) (6 3 11 4 5) (7 3 11 5 5) (7 2 11 5 6) (8 2 11 5 6) (9 2 11 5 6) (12 11 4 6) (12 11 4 5) (11 13 3 6) (40) (40))) (quote ((35) (9 24) (8 23) (7 24) (6 12 11) (5 11 10) (3 10 9) (4 1 9 2 7) (4 9 3 6) (3 1 7 6 5) (4 5 5 14) (5 5 10 2) (6 5 1 2) (7 6 2) (8 6 7 3) (9 6 13) (10 4 14) (11 4 14) (11 14) (11 14) (11 14) (12 14) (12 15) (12 15) (12 15) (12 3 4) (12 3) (11 4 2) (11 11) (11 12) (11 10) (12 7 2) (13 2) (13 3 2) (12 1 5 4 3) (11 1 20) (11 3 14) (12 4 2 1 11) (13 2 12) (35))) (quote ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxx  xxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxx    xxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxx    xxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxx    xxxxxxxxxxxx  xxxxxxxxxxx" "xxxxx     xxxxxxxxxxx    xxxxxxxxxx" "xxx       xxxxxxxxxx      xxxxxxxxx" "xxxx  x   xxxxxxxxx   xx    xxxxxxx" "xxxx      xxxxxxxxx   xxx    xxxxxx" "xxx     x  xxxxxxx   xxxxxx   xxxxx" "xxxx xxxxx  xxxxx    xxxxxxxxxxxxxx" "xxxxx xxxxx           xxxxxxxxxx xx" "xxxxxx xxxxx x                   xx" "xxxxxxx xxxxxx                   xx" "xxxxxxxx xxxxxx         xxxxxxx xxx" "xxxxxxxxx xxxxxx      xxxxxxxxxxxxx" "xxxxxxxxxx xxxx      xxxxxxxxxxxxxx" "xxxxxxxxxxx xxxx     xxxxxxxxxxxxxx" "xxxxxxxxxxx          xxxxxxxxxxxxxx" "xxxxxxxxxxx          xxxxxxxxxxxxxx" "xxxxxxxxxxx          xxxxxxxxxxxxxx" "xxxxxxxxxxxx         xxxxxxxxxxxxxx" "xxxxxxxxxxxx        xxxxxxxxxxxxxxx" "xxxxxxxxxxxx        xxxxxxxxxxxxxxx" "xxxxxxxxxxxx        xxxxxxxxxxxxxxx" "xxxxxxxxxxxx        xxx        xxxx" "xxxxxxxxxxxx                    xxx" "xxxxxxxxxxx               xxxx   xx" "xxxxxxxxxxx             xxxxxxxxxxx" "xxxxxxxxxxx            xxxxxxxxxxxx" "xxxxxxxxxxx              xxxxxxxxxx" "xxxxxxxxxxxx             xxxxxxx xx" "xxxxxxxxxxxxx                    xx" "xxxxxxxxxxxxx       xxx          xx" "xxxxxxxxxxxx x     xxxxx   xxxx xxx" "xxxxxxxxxxx  x xxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxx xxx      xxxxxxxxxxxxxx" "xxxxxxxxxxxx xxxx  xx x xxxxxxxxxxx" "xxxxxxxxxxxxx    xx    xxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/problems/k40x40 b/collects/games/paint-by-numbers/problems/k40x40
new file mode 100644
index 0000000000..1cdb482c12
--- /dev/null
+++ b/collects/games/paint-by-numbers/problems/k40x40
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 40x40") (define problems (list (make-problem "19980410-KVL (1)" (quote ((40) (7 14 6 4) (6 5 3 15 3) (5 1 4 17 2) (2 2 1 5 8 8 2) (5 7 17 2) (4 17 3) (2 11 16 4) (1 2 1 1 1 2 9 12) (1 2 1 1 1 2 22) (2 11 6 8 7) (4 25) (8 29) (8 27) (9 5 5 11 2) (3 5 15 8) (10 23) (10 21) (11 6 9 3) (6 4 18) (12 8 8) (2 9 15) (13 14) (13 12) (14 2 11) (14 3 2 9) (15 2 8) (15 1 4 6) (16 5 3 5) (7 8 1 3) (1 5 8 1 2) (2 7 2) (3 10) (3 3 10) (3 3 32) () () () () ())) (quote ((35) (8 20 4) (4 2 2 10 9 3) (7 2 4 15) (6 1 1 19 2) (3 1 1 19 2) (2 3 4 7 11 2) (1 1 1 1 1 17) (1 1 2 1 1 16 3) (1 4 4 15 3) (1 4 1 1 17) (1 4 1 1 1 15) (2 3 4 1 13) (3 1 1 2 11) (6 1 1 3 9) (7 2 4 7) (2 4 2 5 5) (8 7 3) (17 2 1) (14 3 1 1) (19 1 1 1 1) (19 1 5 1) (4 15 4 1) (10 10 2 1) (21 2 2 1) (14 7 2 1 1) (1 16 4 1 1) (8 14 1) (24 1) (25 1) (25 1) (3 9 4 5 1) (2 3 16 1) (1 19 1) (1 20 1) (1 21 1) (2 11 10 1) (3 8 15 1) (31 1) (31 1))) (quote ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx     " "xxxxxxxx  xxxxxxxxxxxxxxxxxxxx xxxx     " "xxxx xx xx xxxxxxxxxx xxxxxxxxx xxx     " "xxxxxxx xx xxxx xxxxxxxxxxxxxxx         " "xxxxxx x  x xxxxxxxxxxxxxxxxxxx  xx     " "xxx    x  x xxxxxxxxxxxxxxxxxxx  xx     " "xx xxx xxxx xxxxxxx xxxxxxxxxxx  xx     " "x x  x x  x xxxxxxxxxxxxxxxxx           " "x x xx x  x   xxxxxxxxxxxxxxxx  xxx     " "x xxxx xxxx     xxxxxxxxxxxxxxx xxx     " "x xxxx x  x       xxxxxxxxxxxxxxxxx     " "x xxxx x  x x       xxxxxxxxxxxxxxx     " "xx xxx xxxx x         xxxxxxxxxxxxx     " "xxx    x  x xx          xxxxxxxxxxx     " "xxxxxx x  x xxx           xxxxxxxxx     " "xxxxxxx xx xxxx             xxxxxxx     " "xx xxxx xx xxxxx              xxxxx     " "xxxxxxxx  xxxxxxx               xxx     " "xxxxxxxxxxxxxxxxx          xx     x     " "xxxxxxxxxxxxxx xxx          x     x     " "xxxxxxxxxxxxxxxxxxx      x  x  x  x     " "xxxxxxxxxxxxxxxxxxx      x xxxxx  x     " "xxxx xxxxxxxxxxxxxxx     xxxx     x     " "xxxxxxxxxx xxxxxxxxxx     xx      x     " "xxxxxxxxxxxxxxxxxxxxx   xx xx     x     " "xxxxxxxxxxxxxx xxxxxxx  xx  x     x     " "x xxxxxxxxxxxxxxxx xxxx     x     x     " "xxxxxxxx xxxxxxxxxxxxxx           x     " "xxxxxxxxxxxxxxxxxxxxxxxx          x     " "xxxxxxxxxxxxxxxxxxxxxxxxx         x     " "xxxxxxxxxxxxxxxxxxxxxxxxx         x     " "xxx   xxxxxxxxx xxxx xxxxx        x     " "xx     xxx xxxxxxxxxxxxxxxx       x     " "x       xxxxxxxxxxxxxxxxxxx       x     " "x       xxxxxxxxxxxxxxxxxxxx      x     " "x       xxxxxxxxxxxxxxxxxxxxx     x     " "xx     xxxxxxxxxxx xxxxxxxxxx     x     " "xxx   xxxxxxxx xxxxxxxxxxxxxxx    x     " "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx   x     " "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx   x     "))) (make-problem "19980512-SDN (2)" (quote ((18) (26) (20 2) (2 9 2) (1 1 2) (2 2 2) (2 2 10 2) (1 1 18 2) (2 18 3 2) (13 2 1 2) (2 1 2) (2 1 2) (2 1 2) (2 1 2) (4 1 2) (11 1 2) (18 1 1 2) (2 8 1 1 2) (1 1 1 1 2) (2 2 1 1 2) (2 2 8 2) (1 1 16 2) (2 19 2) (13 2) (2) (2) (2) (2) (2) (13) (24) (22 2) (2 8 2) (1 1 2) (2 2 2) (2 2 11) (1 1 22) (2 21) (13) ())) (quote (() (2) (6) (2 2 2) (1 1 6 2) (1 1 2 2 6) (2 2 1 1 2 2) (8 1 1 1 1) (2 2 2 2 2 1 1) (2 2 8 2 2) (2 2 2 2 2 8) (2 2 2 2 2 2 2) (2 2 2 2 2 2) (2 2 2 2 2 2) (3 2 2 2 2 2) (2 3 3 2 2 2) (2 2 2 2 3 2) (2 2 2 3 2 2) (2 2 2 2 2 3) (2 2 2 2 2 2) (2 2 2 2 2 2) (2 2 2 2 2 2) (3 2 3 2 2 2) (2 3 2 2 2 2) (2 2 2 2 2 2) (2 2 10 2 2) (2 2 2 3 2 2) (2 2 2 2 3 2) (2 2 2 2 2 2) (2 2 2 2 2 3) (2 4 2 2 2) (2 3 2 2 2) (2 16 2 2) (2 2 2) (2 2 2) (2 2 2) (2 2 2) (2 2 2) (37) (37))) (quote #f)) (make-problem "19980716dGAS (3)" (quote ((40) (18 18) (17 17) (16 4 16) (15 6 15) (14 8 14) (13 10 13) (12 12 12) (11 5 5 11) (10 5 5 10) (9 6 6 9) (8 7 7 8) (7 8 8 7) (6 1 1 10 6) (5 2 4 15 5) (4 3 3 15 4) (3 4 1 1 16 3) (2 5 1 2 5 8 2) (1 6 3 5 8 1) (1 4 7 1) (1 6 9 8 1) (1 7 8 9 1) (2 6 19 2) (3 5 1 17 3) (4 4 2 16 4) (5 3 2 5 8 5) (6 2 2 4 6 6) (7 1 3 4 4 7) (8 2 2 2 8) (9 2 2 1 9) (10 16 10) (11 14 11) (12 12 12) (13 10 13) (14 8 14) (15 6 15) (16 4 16) (17 17) (18 18) (40))) (quote ((40) (18 18) (17 17) (16 4 16) (15 6 15) (14 8 14) (13 10 13) (12 5 6 12) (11 6 7 11) (10 1 7 10) (9 2 4 9) (8 3 2 8) (7 4 2 1 1 7) (6 5 1 9 6) (5 6 9 5) (4 7 1 1 4 4) (3 8 2 2 5 3) (2 5 1 3 3 1 6 2) (1 5 1 17 1) (1 5 5 17 1) (1 5 5 8 7 1) (1 5 5 7 7 1) (2 5 6 6 6 2) (3 14 5 5 3) (4 11 3 4 4) (5 10 4 3 5) (6 9 5 2 6) (7 8 6 1 7) (8 8 9 8) (9 8 9 9) (10 16 10) (11 14 11) (12 12 12) (13 10 13) (14 8 14) (15 6 15) (16 4 16) (17 17) (18 18) (40))) (quote ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxx    xxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxx      xxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxx  xxxx  xxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxx  xxxxxx  xxxxxxxxxxxxxxx" "xxxxxxxxxxxxxx  xxxxxxxx  xxxxxxxxxxxxxx" "xxxxxxxxxxxxx  xxxxxxxxxx  xxxxxxxxxxxxx" "xxxxxxxxxxxx  xxxxx xxxxxx  xxxxxxxxxxxx" "xxxxxxxxxxx  xxxxxx xxxxxxx  xxxxxxxxxxx" "xxxxxxxxxx  x        xxxxxxx  xxxxxxxxxx" "xxxxxxxxx  xx xxxx             xxxxxxxxx" "xxxxxxxx  xxx xx                xxxxxxxx" "xxxxxxx  xxxx xx           x  x  xxxxxxx" "xxxxxx  xxxxx x        xxxxxxxxx  xxxxxx" "xxxxx  xxxxxx           xxxxxxxxx  xxxxx" "xxxx  xxxxxxx     x x         xxxx  xxxx" "xxx  xxxxxxxx    xx xx        xxxxx  xxx" "xx  xxxxx    x  xxx xxx    x  xxxxxx  xx" "x  xxxxx      x     xxxxxxxxxxxxxxxxx  x" "x  xxxxx      xxxxx xxxxxxxxxxxxxxxxx  x" "x  xxxxx      xxxxx xxxxxxxx  xxxxxxx  x" "x  xxxxx      xxxxx xxxxxxx   xxxxxxx  x" "xx  xxxxx    xxxxxx xxxxxx    xxxxxx  xx" "xxx  xxxxxxxxxxxxxx xxxxx     xxxxx  xxx" "xxxx  xxxxxxxxxxx     xxx     xxxx  xxxx" "xxxxx  xxxxxxxxxx     xxxx    xxx  xxxxx" "xxxxxx  xxxxxxxxx     xxxxx   xx  xxxxxx" "xxxxxxx  xxxxxxxx     xxxxxx  x  xxxxxxx" "xxxxxxxx  xxxxxxxx   xxxxxxxxx  xxxxxxxx" "xxxxxxxxx  xxxxxxxx xxxxxxxxx  xxxxxxxxx" "xxxxxxxxxx  xxxxxxxxxxxxxxxx  xxxxxxxxxx" "xxxxxxxxxxx  xxxxxxxxxxxxxx  xxxxxxxxxxx" "xxxxxxxxxxxx  xxxxxxxxxxxx  xxxxxxxxxxxx" "xxxxxxxxxxxxx  xxxxxxxxxx  xxxxxxxxxxxxx" "xxxxxxxxxxxxxx  xxxxxxxx  xxxxxxxxxxxxxx" "xxxxxxxxxxxxxxx  xxxxxx  xxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxx  xxxx  xxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxx      xxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxx    xxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"))) (make-problem "19980828-GOS (4)" (quote (() (20) (22) (24) (26) (28) (30) (32) (34) (36) (38) (4 3 3 4 4) (3 2 2 3 3) (2 1 1 2 2 2) (2 1 3 3 3 2 3 2) (2 3 3 2 5 1 3 2) (2 8 2 5 1 3 2) (2 7 2 5 1 2 2) (2 5 2 5 1 3) (2 5 2 5 1 4) (3 4 2 5 1 6) (4 3 2 5 1 6) (6 3 2 5 1 6) (7 3 2 5 1 6) (2 3 3 2 5 1 6) (2 1 3 3 3 2 6) (2 3 3 2 6) (3 4 4 3 6) (4 5 5 4 6) (38) (36) (34) (32) (30) (28) (26) (24) (22) (20) ())) (quote (() (20) (22) (5 4 5) (5 3 5) (5 2 3 5) (6 4 4 6) (7 3 2 7) (9 4 9) (11 5 11) (38) (10 25) (10 25) (10 10) (10 10) (10 10) (10 25) (10 25) (14 14) (12 12) (11 11) (10 10 10) (10 12 10) (10 12 10) (10 12 10) (10 10 10) (11 11) (12 12) (14 14) (38) (9 9) (8 8) (7 5 7) (6 5 15) (5 3 14) (5 14) (5 14) (22) (20) ())) (quote ("                                        " "          xxxxxxxxxxxxxxxxxxxx          " "         xxxxxxxxxxxxxxxxxxxxxx         " "        xxxxx       xxxx   xxxxx        " "       xxxxx         xxx    xxxxx       " "      xxxxx    xx     xxx    xxxxx      " "     xxxxxx   xxxx    xxxx   xxxxxx     " "    xxxxxxx    xxx     xx    xxxxxxx    " "   xxxxxxxxx    xxxx        xxxxxxxxx   " "  xxxxxxxxxxx   xxxxx      xxxxxxxxxxx  " " xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx " " xxxxxxxxxx   xxxxxxxxxxxxxxxxxxxxxxxxx " " xxxxxxxxxx   xxxxxxxxxxxxxxxxxxxxxxxxx " " xxxxxxxxxx                  xxxxxxxxxx " " xxxxxxxxxx                  xxxxxxxxxx " " xxxxxxxxxx                  xxxxxxxxxx " " xxxxxxxxxx   xxxxxxxxxxxxxxxxxxxxxxxxx " " xxxxxxxxxx   xxxxxxxxxxxxxxxxxxxxxxxxx " " xxxxxxxxxxxxxx          xxxxxxxxxxxxxx " " xxxxxxxxxxxx              xxxxxxxxxxxx " " xxxxxxxxxxx                xxxxxxxxxxx " " xxxxxxxxxx    xxxxxxxxxx    xxxxxxxxxx " " xxxxxxxxxx   xxxxxxxxxxxx   xxxxxxxxxx " " xxxxxxxxxx   xxxxxxxxxxxx   xxxxxxxxxx " " xxxxxxxxxx   xxxxxxxxxxxx   xxxxxxxxxx " " xxxxxxxxxx    xxxxxxxxxx    xxxxxxxxxx " " xxxxxxxxxxx                xxxxxxxxxxx " " xxxxxxxxxxxx              xxxxxxxxxxxx " " xxxxxxxxxxxxxx          xxxxxxxxxxxxxx " " xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx " "  xxxxxxxxx                  xxxxxxxxx  " "   xxxxxxxx                  xxxxxxxx   " "    xxxxxxx  xxxxx           xxxxxxx    " "     xxxxxx  xxxxx  xxxxxxxxxxxxxxx     " "      xxxxx   xxx   xxxxxxxxxxxxxx      " "       xxxxx       xxxxxxxxxxxxxx       " "        xxxxx     xxxxxxxxxxxxxx        " "         xxxxxxxxxxxxxxxxxxxxxx         " "          xxxxxxxxxxxxxxxxxxxx          " "                                        "))) (make-problem "19980926-JON (5)" (quote ((15 19) (16 3 17) (18 3 16) (7 6 3 4 6) (5 6 3 3 3 5 4) (4 2 7 1 3 1 4 3 3) (3 2 4 5 2 4 3 2) (3 2 4 5 2 6 4 3 1) (2 2 4 5 3 7 3 2 1) (1 2 4 5 3 8 4 3) (1 2 4 3 6 5 3 4 2) (2 3 3 6 3 2 5 1) (2 3 2 8 7 1) (2 6 6 6 2) (2 5 4 5 2) (1 5 2 5 1) (1 34 1) (1 4 4 19 4 1) (1 4 4 6 7 3 4 1) (6 3 6 6 10) (1 3 4 6 6 3 4 1) (1 3 4 5 4 4 3 2) (1 4 4 4 4 3 4 2) (2 3 4 3 7 4 2) (2 8 3 6 5 2) (2 2 8 8 1 3) (1 2 24 5) (2 1 22 4) (2 1 18 4) (1 4 3 3 4 1) (1 4 3 3 4 1) (2 5 3 3 5 2) (2 5 3 5 2) (3 5 3 5 3) (4 5 3 5 4) (5 25 5) (7 22 6) (8 17 8) (9 10) (11 4 11))) (quote ((11 11) (9 13 9) (8 5 1 7 7) (6 5 8 5 6) (5 3 14 4 5) (4 2 24 4) (4 2 12 3 5 4) (3 2 10 2 2 4 3) (3 1 5 2 11 4 2) (3 6 3 12 4 1) (3 4 3 12 3 1) (3 3 4 3 7 3) (3 2 4 1 3 4 3) (4 5 16 3) (4 6 16 3) (3 7 9 6 3) (3 2 3 7 3 3) (3 1 6 5 3 3) (1 3 8 3 3 6 1) (2 11 3 6 1) (5 7 3 6 1) (1 4 4 3 3 3 3 1) (1 3 7 5 3 3) (2 6 7 6 3) (6 5 9 6 3) (5 5 16 3) (5 4 13 3) (4 1 3 5 6 3) (3 2 3 2 8 2) (3 4 3 12 3 1) (3 6 2 8 3 4 2) (3 1 9 6 3 4 2) (3 2 10 1 4 5 3) (3 3 16 5 3) (4 3 24 4) (4 4 14 7 5) (5 4 6 7 6) (6 6 1 9 7) (7 14 9) (9 11))) (quote ("xxxxxxxxxxx                  xxxxxxxxxxx" "xxxxxxxxx    xxxxxxxxxxxxx     xxxxxxxxx" "xxxxxxxx  xxxxx    x   xxxxxxx   xxxxxxx" "xxxxxx  xxxxx  xxxxxxxx    xxxxx  xxxxxx" "xxxxx  xxx   xxxxxxxxxxxxxx  xxxx  xxxxx" "xxxx  xx  xxxxxxxxxxxxxxxxxxxxxxxx  xxxx" "xxxx xx xxxxxxxxxxxx  xxx     xxxxx xxxx" "xxx xx xxxxxxxxxx   xx  xx     xxxx  xxx" "xxx x xxxxx  xx xxxxxxxxxxx     xxxx  xx" "xxx xxxxxx xxx  xxxxxxxxxxxx     xxxx  x" "xxx xxxx  xxx   xxxxxxxxxxxx      xxx  x" "xxx xxx xxxx    xxx   xxxxxxx      xxx  " "xxx xx xxxx     x  xxx   xxxx      xxx  " "xxxx xxxxx      xxxxxxxxxxxxxxxx   xxx  " "xxxx xxxxxx     xxxxxxxxxxxxxxxx   xxx  " " xxx xxxxxxx    xxxxxxxxx xxxxxx   xxx  " "  xxx xx  xxx   xxxxxxx   xxx      xxx  " "  xxx x xxxxxx  xxxxx     xxx      xxx  " " x xxx xxxxxxxx xxx       xxx   xxxxxx x" " xx    xxxxxxxxxxx        xxx   xxxxxx x" " xxxxx     xxxxxxx        xxx   xxxxxx x" "x xxxx xxxx xxx xxx       xxx      xxx x" "x  xxx xxxxxxx  xxxxx     xxx      xxx  " "xx     xxxxxx   xxxxxxx   xxxxxx   xxx  " "xxxxxx xxxxx    xxxxxxxxx xxxxxx   xxx  " "xxxxx xxxxx     xxxxxxxxxxxxxxxx   xxx  " "xxxxx xxxx      xxxxxxxxxxxxx      xxx  " "xxxx x  xxx     xxxxx  xxxxxx      xxx  " "xxx  xx  xxx    xx   xxxxxxxx      xx   " "xxx xxxx  xxx   xxxxxxxxxxxx      xxx  x" "xxx xxxxxx  xx  xxxxxxxx xxx     xxxx xx" "xxx x xxxxxxxxx xxxxxx  xxx     xxxx  xx" "xxx xx xxxxxxxxxx  x  xxxx     xxxxx xxx" "xxx xxx  xxxxxxxxxxxxxxxx     xxxxx  xxx" "xxxx xxx  xxxxxxxxxxxxxxxxxxxxxxxx  xxxx" "xxxx  xxxx xxxxxxxxxxxxxx xxxxxxx  xxxxx" "xxxxx  xxxx    xxxxxx    xxxxxxx  xxxxxx" "xxxxxx   xxxxxx    x xxxxxxxxx   xxxxxxx" "xxxxxxx      xxxxxxxxxxxxxx    xxxxxxxxx" "xxxxxxxxx                    xxxxxxxxxxx"))) (make-problem "19981120-VAL (6)" (quote ((8 7) (10 2 2 2 2 2 2 2 8) (8 1 1 1 1 1 1 1 1 7) (8 7) (8 7) (40) (10 3 3 3 3 3 9) (9 1 1 1 1 1 7) (8 1 1 1 1 1 1 1 1 1 6) (7 3 3 3 3 3 3 5) (7 1 1 1 1 1 1 1 1 1 5) (7 3 3 3 4) (6 1 1 1 4) (6 3) (6 2) (5 2) (7 2 2 2 2 2 2 2 2 2 2 2) (5 1 1 1 1 1 1 1 1 1 1 1 1) (5 1) (5 1) (5 1 2) (5 1 1 2 3) (5 2 2 8) (6 4 4 8) (6 3 2 2 3 8) (6 3 1 1 3 8) (7 4 4 8) (7 1 8) (7 4 4 8) (8 3 1 1 3 9) (8 3 2 2 3 9) (9 4 4 10) (9 2 2 10) (9 1 1 11) (10 11) (11 12) (12 13) (13 14) (15 15) (17 17))) (quote ((40) (40) (40) (40) (40) (15 1 17) (12 1 14) (9 1 11) (1 3 1 9) (1 2 1 1 6) (1 1 3 1 5) (1 2 1 1 1 4) (1 4 3 1 3) (1 2 1 1 1 1 1 2) (1 1 3 1 2 2 2) (1 2 1 1 4 4 1) (1 3 1 3 2 2 3 1) (1 2 1 1 3 1 1 3) (1 1 3 1 4 4) (1 2 1 1 1 1) (1 4 3 1 4 4) (1 2 1 1 1 3 1 1 3) (1 1 3 1 3 2 2 3) (1 2 1 1 4 4 1) (1 3 1 2 2 1) (1 2 1 1 1 1 2) (1 1 3 1 3) (1 2 1 1 1 4) (1 4 3 1 5) (1 2 1 1 1 7) (1 1 3 1 9) (1 2 1 1 11) (1 2 1 20) (8 1 19) (9 1 18) (11 1 18) (13 1 18) (14 1 19) (17 20) (40))) (quote #f)) (make-problem "19981207-JTR (7)" (quote ((1) (1) (1 1 1 1) (1 1 1 1 1 1) (1 1 1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 2 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 4 1 1 1 1 1 1 1) (1 1 1 1 1 3 4 3 1 1 1 1 1) (1 1 1 3 3 4 3 3 1 1 1) (1 3 3 3 4 3 3 3 1) (3 3 3 3 4 3 3 3 3) (3 3 3 3 4 3 3 3 3) (3 3 3 3 4 3 3 3 3) (3 3 3 3 4 3 3 3 3) (3 3 3 3 4 3 3 3 3) (3 3 3 3 4 3 3 3 3) (3 3 3 3 4 3 3 3 3) (3 3 3 4 4 4 3 3 3) (3 3 3 16 3 3 3) (3 3 4 14 4 3 3) (3 4 4 12 4 4 3) (4 4 4 4 4 4 4) (4 4 18 4 4) (4 4 16 4 4) (4 4 14 4 4) (4 4 4 4 4) (4 20 4) (4 18 4) (4 16 4) (4 4 4) (22) (20) (18) (4) (4) (4) (14) (22) (30))) (quote ((3 12) (2 14) (3 14) (4) (3 12 4) (2 14 4 1) (3 14 4 1) (4 4 1) (3 12 4 4 1) (2 14 4 4 2) (3 14 4 4 2) (4 4 4 2) (3 12 4 4 3 2) (2 14 4 3 3 3) (3 14 3 3 3 3) (4 3 3 3 3) (3 3 3 3 3) (3 3 3 3 3) (3 33) (1 34) (2 34) (4 33) (3 3 3 3 3) (3 3 3 3 3) (4 3 3 3 3) (3 14 3 3 3 3) (2 14 4 3 3 3) (3 12 4 4 3 2) (4 4 4 2) (3 14 4 4 2) (2 14 4 4 2) (3 12 4 4 1) (4 4 1) (3 14 4 1) (2 14 4 1) (3 12 4) (4) (3 14) (2 14) (3 12))) (quote #f)) (make-problem "19981221-SDN (8)" (quote (() (6 2 2 2 2 6) (6 2 2 2 2 6) (2 2 2 2 2 2) (2 2 2 2 2 2) (5 2 7 2 6) (5 2 7 2 6) (2 2 2 2 2) (2 3 2 2 2 2) (6 3 2 2 2 6) (6 3 2 2 2 6) () () () (6 6 2 6 6) (6 6 2 6 6) (2 2 2 2 2 2) (2 2 2 2 2 2) (6 6 6 6 5) (6 6 6 6 5) (2 2 2 2 2 2) (2 2 2 2 2 2) (2 6 6 6 6) (2 6 6 6 6) () () () (6 6 1) (6 6 11) (2 2 2 6 11) (2 2 2 6 1 2 2) (6 6 2 2) (6 6 2 2) (2 2 6 2 2) (2 2 6 2 2) (6 2 2 2) (6 2) () () ())) (quote (() (2 2 6 6 2) (2 2 2 6 6 2) (2 2 2 2 2 2 2 2) (2 2 2 2 2 2 2 2) (10 10 2 6) (10 10 2 6) () () (3 2 6 6) (3 2 6 6) (3 2 2 2 2 2) (2 2 2 2 2) (6 2 10) (10 6 2 10) (10) () (10 2 2) (6 10 2 2) (6 2 2 2 2) (2 2 2 2 2) (2 6 2 2) (2 6 2 2) (10) (10) (6 2) (6 2 2) (10 2 2 2 2) (10 2 2 2 2) (2 6 8) (2 6 8) (6 2 2) (6 2 2) (2 2 2 2 2 8) (2 2 2 2 2 2 8) (2 6 2 2 2 2) (2 6 2 2 2 2) (10 2) (10) ())) (quote #f)) (make-problem "19981223aBAU (9)" (quote ((1 4) (2 6) (3 7 2) (4 4 4 4 4) (3 7 5 2 4 7 2) (6 2 7 5 8) (2 5 9 1 2 6) (3 2 9 3) (1 11 2) (1 13 1) (4 13 1) (5 15 3) (4 1 15 5) (3 3 15 6) (2 2 1 15 1 2 3) (3 1 15 10) (2 1 13 1 1 5) (1 2 1 2 2 4) (1 6 1 1 1 2 2 4) (20 5) (25 4) (5 21 3) (7 20 3) (3 1 6 8 4 4) (4 4 1 13 4) (1 1 7 2 2 1 3 3) (3 4 1 5 5 2) (1 1 6 2 2 1 2 1) (4 3 2 4 5 3) (4 6 4 4 4) (3 3 2 2 2 2 1 5) (3 6 5 7) (3 2 2 2 2 1 3) (2 4 5 3) (1 3 1 5) (6 4) (4 5) (4 5) (3 2) (1))) (quote ((3 5 3) (3 4 4 5) (3 2 1 14) (4 4 5 1 2 3) (5 2 1 4 5 2) (1 1 4 5 2) (4 2 1 2 1 3 4) (4 6 5 6 3) (4 2 1 4 8 4) (2 3 5 10 8) (5 8 12 5) (2 18 5 1 1) (1 18 2 5) (12 7 2) (13 6) (13 4) (19) (13 5) (13 8) (12 9) (19 5) (1 19 4) (5 8 11 2) (4 2 5 6 8) (3 6 1 5 2 2) (7 5 3 1 4) (3 1 3 1 6 4) (5 5 4 1 4) (6 4 7 4) (3 2 2 2 4 3 3) (4 3 1 8 2) (3 4 4 2 2) (3 3 1 4 1 2) (3 4 3 1) (3 3 1 2 4) (3 4 3 3) (3 4 3 3) (2 7 3) (2 7 3) (1 4 3))) (quote #f)) (make-problem "19981223bBAU (10)" (quote ((5 11) (8 6 6) (2 6 7 8) (3 8 2 12 2) (12 3 4 5 3 3) (5 5 8 3 2 5) (6 4 9 1 8) (9 16 8) (6 2 12 9) (3 4 9 9) (9 5 2 7) (8 6 6) (6 12 3) (5 6 10 2) (2 5 7 11) (2 5 8 9) (2 6 9 6) (3 8 16) (2 9 1 5) (2 9 2 2) (2 9 4 3) (2 9 14) (3 1 3 1 18) (3 7 11 6) (1 1 5 9 8) (1 1 3 7 10) (4 1 12) (4 1 5 5 1) (4 1 8 3 3) (4 1 10 5) (5 2 8 3 5) (3 1 1 1 1 5 4 5) (2 3 2 4 6 5) (1 3 3 12 6) (7 8 7 2 3) (16 7 3 2) (6 8 3 8) (4 7 2 8) (2 7 2 7) (9 8))) (quote ((4 15) (7 8 8) (8 3 11 2) (2 7 2 5 3) (2 7 1 1 6) (3 1 5 8) (5 2 2 4 8) (6 1 2 7 4 1) (5 5 6 2 1 3 1) (5 5 11 1 1 2) (5 22 5) (5 17 1 6) (1 2 12 2 6) (2 2 13 7) (1 2 3 5 8) (5 9) (5 2 4) (5 8 5 3) (7 5 5 8) (7 5 5 7) (8 6 5 7) (9 7 5 5 1) (2 6 8 5 4 1) (3 4 14 2 3) (5 3 1 4 6 2 5) (6 2 2 2 6 10) (8 4 1 5 10) (6 5 1 5 7 1) (1 2 7 3 1 4 2) (1 2 7 2 2 3 3) (4 8 2 3 5) (6 10 6 4) (10 6 6 5) (5 5 4 7 6) (4 6 3 7 6) (2 7 2 12 2) (13 4 6 2) (11 3 9) (9 2 8) (7 8))) (quote ("    xxxx         xxxxxxxxxxxxxxx        " "  xxxxxxx       xxxxxxxx  xxxxxxxx      " " xxxxxxxx      xxx    xxxxxxxxxxx xx    " "xx xxxxxxx    xx          xxxxx   xxx   " "xx  xxxxxxx   x               x xxxxxx  " "xxx x xxxxx                    xxxxxxxx " "xxxxx  xx xx      xxxx          xxxxxxxx" "xxxxxx x  xx     xxxxxxx          xxxx x" " xxxxx xxxxx    xxxxxx xx      x  xxx  x" " xxxxx  xxxxx  xxxxxxxxxxx    x    x  xx" "  xxxxx  xxxxxxxxxxxxxxxxxxxxxx    xxxxx" "   xxxxx xxxxxxxxxxxxxxxxx     x  xxxxxx" "   x  xx  xxxxxxxxxxxx xx         xxxxxx" "   xx xx   xxxxxxxxxxxxx         xxxxxxx" "    x  xx   xxx  xxxxx          xxxxxxxx" "    xxxxx                     xxxxxxxxx " "     xxxxx                   xx   xxxx  " "     xxxxx    xxxxxxxx      xxxxx xxx   " "    xxxxxxx  xxxxx xxxxx   xxxxxxxx     " "    xxxxxxx  xxxxx  xxxxx  xxxxxxx      " "   xxxxxxxx  xxxxxx xxxxx  xxxxxxx      " "  xxxxxxxxx xxxxxxx  xxxxx xxxxx x      " " xx  xxxxxx xxxxxxxx xxxxx xxxx  x      " " xxx  xxxx  xxxxxxxxxxxxxx  xx  xxx     " "xxxxx  xxx  x  xxxx xxxxxx  xx xxxxx    " "xxxxxx xx   xx  xx  xxxxxx   xxxxxxxxxx " "xxxxxxxx   xxxx  x   xxxxx    xxxxxxxxxx" "xxxxxx     xxxxx x   xxxxx    xxxxxxx  x" "x  xx      xxxxxxx   xxx  x     xxxx  xx" "x xx       xxxxxxx   xx  xx      xxx xxx" "xxxx      xxxxxxxx   xx xxx        xxxxx" "xxxxxx  xxxxxxxxxx    xxxxxx        xxxx" "xxxxxxxxxx  xxxxxx    xxxxxx       xxxxx" "xxxxx xxxxx  xxxx     xxxxxxx     xxxxxx" "xxxx  xxxxxx xxx      xxxxxxx    xxxxxx " " xx  xxxxxxx  xx      xxxxxxxxxxxx  xx  " "  xxxxxxxxxxxxx        xxxx  xxxxxx xx  " "   xxxxxxxxxxx          xxx xxxxxxxxx   " "    xxxxxxxxx            xx xxxxxxxx    " "     xxxxxxx              xxxxxxxx      "))) (make-problem "19990208-ELS (11)" (quote ((2 2 2 1 2 2) (4 4 2 1 2 4) (1 1 1 2 1 2 6) (1 2 1 2 1 2 2 8) (1 2 1 2 1 2 1 2 10) (1 1 1 2 1 2 1 1) (11 2 1 2 1 2 2 1) (1 1 1 2 2 1 2 2 1) (1 2 1 2 1 2 1 2 1 1) (1 2 1 2 1 2 1 2 1 2 1) (1 1 1 1 1 2 1 2 1) (11 2 2 10) (2 1 3) (2 1 1 2) (12 1 1 13) (20 1 12) (1) (1) (1) (4 3 3 3) (3 3 3 4) (1) (1) (1) (12 1 20) (13 1 1 13) (2 1 1 2) (2 1 2 3 1 2 1 1) (2 2 2 2 2 1 1 3) (2 2 2 2 1 2 1 5) (1 2 2 1 2 1 2 1 1 5) (1 2 3 2 1 2 1 1 1) (3 2 2 2 2 2 1 1 1 1 1) (7 2 2 1 2 5 1 1 1) (2 10 2 1 2 1 1 1 1) (6 1 2 1 2 1 1 1 1 1 1 1) (4 2 2 1 1 1 1 1) (4 2 1 2 1 1 1 1 1 1) (4 2 1 2 1 1 1 1 1) (6 2 1 2 1 1 1 1 1 1 1))) (quote ((2 1 2 1 1) (10 2 1 2 5) (1 1 1 2 1 2 1 2) (2 2 1 2 1 2 2 3 2) (2 2 1 2 1 2 1 2 3 3 1) (1 1 1 2 1 2 10) (10 2 1 2 1 9) (1 1 1 2 2 3 7) (2 2 1 2 1 2 1 2 2 6) (2 2 1 2 1 2 1 2 1 2 3 1) (1 1 1 2 1 2 2 4) (10 3 2 5 2) (2 1 1 2 1 1) (2 1 1 2) (12 1 1 13) (10 1 20) (1) (1) (1) (3 3 3 4) (4 3 3 3) (1) (1) (1) (20 1 12) (13 1 1 13) (2 1 1 2) (2 1 3 7) (8 2 2 2) (2 1 2 1 2 2 1 1 1) (3 2 1 2 1 2 1) (4 2 1 2 1 2 11) (5 3 2 2 1) (5 3 2 1 2 1 1 1 1 1 1) (4 2 1 2 1 2 1) (3 2 1 2 1 2 11) (2 1 2 2 3) (8 2 1 2 4 2 2 2) (2 1 2 3) (2 1 2 11))) (quote #f)) (make-problem "19990418-DRA (12)" (quote (() (38) (18 19) (17 1 18) (15 3 17) (13 6 16) (12 9 1 13) (10 11 1 11) (9 1 2 8 2 10) (6 2 1 2 1 3 2 9) (6 5 5 3 2 3 8) (6 4 5 5 1 4 7) (7 2 6 1 4 5 7) (6 3 7 1 4 4 7) (5 3 6 2 5 2 8) (5 4 5 1 1 4 2 9) (6 4 4 3 3 2 9) (6 4 6 1 3 2 10) (7 2 1 5 3 3 10) (8 1 2 3 1 2 2 11) (9 3 2 1 13) (10 2 1 4 14) (11 1 2 1 2 15) (12 1 1 16) (15 1 18) (11 1 19) (10 1 4 16) (10 2 3 15) (16 13) (12 3 3 12) (11 4 12) (10 2 7 12) (10 3 21) (10 5 3 16) (16 2 15) (16 1 1 14) (16 4 14) (16 6 14) (16 21) ())) (quote (() (38) (38) (38) (38) (38) (13 23) (8 1 2 21) (8 2 5 20) (8 9 19) (7 5 5 18) (6 4 1 2 4 3 5) (6 1 4 4 2 2 6) (5 3 7 4 1 1 6) (4 3 9 1 1 2 7) (4 2 11 2 1 3 8) (3 3 11 2 4 8) (3 4 4 3) (2 5 1 1 1 2 4 7 2) (1 7 2 1 1 2 2 2 6 3) (2 5 2 5 2 3 5 4) (3 4 3 1 2 2 3 3 3) (4 3 6 3 2 2 2 3) (5 3 8 2 4 3 2) (6 3 6 1 6 4 1) (5 1 3 4 2 7 7) (6 1 1 1 2 9 7) (6 6 4 19) (7 8 20) (8 5 22) (9 3 24) (10 25) (38) (38) (38) (38) (38) (38) (38) ())) (quote ("                                        " " xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx " " xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx " " xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx " " xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx " " xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx " " xxxxxxxxxxxxx  xxxxxxxxxxxxxxxxxxxxxxx " " xxxxxxxx   x xx  xxxxxxxxxxxxxxxxxxxxx " " xxxxxxxx xx xxxxx xxxxxxxxxxxxxxxxxxxx " " xxxxxxxx xxxxxxxxx xxxxxxxxxxxxxxxxxxx " " xxxxxxx xxxxx xxxxx xxxxxxxxxxxxxxxxxx " " xxxxxx xxxx  x xx    xxxx  xxx   xxxxx " " xxxxxx   x xxxx  xxxx xx   xx   xxxxxx " " xxxxx xxx xxxxxxx xxxx x   x    xxxxxx " " xxxx xxx xxxxxxxxx x   x   xx  xxxxxxx " " xxxx xx xxxxxxxxxxx xx x  xxx xxxxxxxx " " xxx xxx xxxxxxxxxxx  xx  xxxx xxxxxxxx " " xxx xxxx xxxx   xxx                    " " xx xxxxx x  x x xx     xxxx xxxxxxx xx " " x xxxxxxx xx x x  xx xx  xx xxxxxx xxx " " xx xxxxx xx xxxxx  xx   xxx xxxxx xxxx " " xxx xxxx xxx   x xx xx xxx   xxx   xxx " " xxxx xxx xxxxxx xxx xx xx     xx   xxx " " xxxxx xxx xxxxxxxx xx xxxx    xxx   xx " " xxxxxx xxx xxxxxx x  xxxxxx   xxxx   x " " xxxxx x xxx xxxx xx xxxxxxx    xxxxxxx " " xxxxxx x   x x  xx xxxxxxxxx   xxxxxxx " " xxxxxx xxxxxx xxxx xxxxxxxxxxxxxxxxxxx " " xxxxxxx xxxxxxxx  xxxxxxxxxxxxxxxxxxxx " " xxxxxxxx xxxxx  xxxxxxxxxxxxxxxxxxxxxx " " xxxxxxxxx xxx xxxxxxxxxxxxxxxxxxxxxxxx " " xxxxxxxxxx   xxxxxxxxxxxxxxxxxxxxxxxxx " " xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx " " xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx " " xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx " " xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx " " xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx " " xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx " " xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx " "                                        "))) (make-problem "19990422-VOL (13)" (quote (() () () () () (1 1 1 1 1 1) (3 1 1 3 3 3 3) (1 3 1 5 1 3 2 2 2 2 2 2) (10 6 1 18) (3 3 4 6 1 2 5 2 2 1) (15 3 6 11) (1 4 4 5 1 1 7 2 3) (19 8 2 5) (2 2 4 2 5 2 2 1 7 1) (7 8 2 7 9) (19 3 3 5 3) (3 3 2 1 1 2 1 7 7 1) (1 3 13 1 6 2 5) (7 3 3 1 1 5 3 4 1) (19 18) () (19 18) (1 1 1 9 3 2 5 2 3 2) (1 1 3 3 5 1 6 11) (1 1 1 13 10 7) (1 15 3 3 8 1) (7 1 2 2 5 8 3) (1 1 2 4 1 9 6) (1 5 3 7 10) (1 3 1 1 1 1 1 2 5 4 2 4) (1 5 3 15 2) (8 4 3 4 9) (1 5 3 1 10 2 4) (1 1 2 12 6 11) (1 1 10 4 2 15) (1 7 7 4 7 2 2) (15 3 18) (5 2 4 5 1 5 2 5 1) (19 18) ())) (quote (() (13 18) (3 5 2 1 1 1 3) (6 6 4 1 1 2 2 3) (3 6 3 1 1 4 3) (15 18) (1 5 3 2 1 1 2 9 1) (4 8 8 3 5) (1 4 1 1 1 2 2 1 1 8) (13 6 5 1) (14 5 1 6) (1 1 4 2 3 5 6) (5 6 1 2 2 1 2 3) (2 6 3 5 6) (5 6 5 1 4 1) (9 3 6 2 4) (1 2 7 1 1 5 1 5 2) (9 5 5 2 9) (2 2 4 1 1 2 8 6) (13 18) () (13 18) (3 1 5 2 6 9 1) (2 5 6 1 11 4) (9 4 4 5 7) (2 10 14 3) (5 4 1 5 2 9) (3 9 2 9 5) (7 3 4 2 8 1) (2 4 2 1 8 7) (5 4 1 18) (2 1 6 1 3 4 2 4 1) (3 6 1 1 4 11) (5 4 2 14 3) (3 10 8 2 6) (2 3 3 4 5 12) (14 1 7 4 3) (2 3 2 1 1 4 11 1) (12 18) ())) (quote #f)) (make-problem "19990503-DRA (14)" (quote ((7 23) (5 10 21) (4 14 20) (3 6 4 19) (2 6 4 1 4 18) (1 6 7 4 17) (1 2 6 5 16) (1 1 2 2 4 6 15) (1 1 9 4 14) (1 5 10 5 13) (1 4 6 5 4 12) (1 3 5 1 4 1 5 11) (1 2 1 2 1 4 10) (1 3 7 3 5 5 9) (1 13 6 2 3 8) (1 13 4 2 1 4 7) (1 13 5 6 3 6) (1 12 6 5 4 5) (1 7 1 3 4 1 3 4) (2 6 2 2 3 7 4 3) (2 6 9 2 2 3 3 2) (2 16 3 3 3 4 1) (2 16 5 3 2 1) (2 17 1 2 3 1 2 1) (3 15 12 1 2 1) (3 14 15 1 1) (3 14 9 3 2 1 1) (3 14 8 2 1 1 1) (4 14 4 2 4 2 1) (4 16 2 4 3 1 2 1) (4 10 1 1 7 1 3 1) (5 8 7 1 3 2) (5 8 7 7 3 3) (6 14 7 4 3) (7 3 7 5 6 3) (8 3 4 8 4) (9 3 6 9 5) (10 4 11 6) (11 20 7) (12 8))) (quote ((40) (5 21) (4 13 16) (3 3 15 12) (2 3 3 15 9) (1 4 2 17 7) (1 4 1 1 19 6) (5 1 1 21 5) (4 2 2 22 4) (3 1 4 6 15 3) (2 8 5 17 2) (2 7 5 15 3 1) (2 3 4 5 15 3) (2 7 6 15 2) (2 5 1 3 11 2 2) (2 10 10 3 1 1) (3 10 11 3 1 1) (1 3 3 5 11 3 1 1) (1 6 2 5 5 2 3 1 1) (2 5 1 5 1 1 1 3 1 1) (3 4 4 6 2 1 2 2 1) (4 5 2 6 5 1 1 2 1) (5 4 1 3 2 6 3 2) (6 5 4 1 9 4 2) (7 4 9 5 4 2) (8 5 12 6 3) (9 4 5 1 11 3) (10 3 4 10 4) (11 4 1 2 6 5 4) (12 3 8 3 4) (13 4 7 4 5) (14 3 1 7 5) (15 4 6 1 5 1) (16 3 1 1 1 5 2) (17 4 4 1 5 3) (18 3 2 5 4) (19 5 4 5) (20 10 8) (21 9) (40))) (quote ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxx              xxxxxxxxxxxxxxxxxxxxx" "xxxx xxxxxxxxxxxxx      xxxxxxxxxxxxxxxx" "xxx xxx  xxxxxxxxxxxxxxx    xxxxxxxxxxxx" "xx xxx   xxx xxxxxxxxxxxxxxx   xxxxxxxxx" "x xxxx   xx   xxxxxxxxxxxxxxxxx  xxxxxxx" "x xxxx   x x  xxxxxxxxxxxxxxxxxxx xxxxxx" " xxxxx x   x xxxxxxxxxxxxxxxxxxxxx xxxxx" " xxxx  xx xx xxxxxxxxxxxxxxxxxxxxxx xxxx" " xxx x  xxxx xxxxxx  xxxxxxxxxxxxxxx xxx" " xx xxxxxxxx xxxxx  xxxxxxxxxxxxxxxxx xx" " xx xxxxxxx  xxxxx xxxxxxxxxxxxxxx xxx x" " xx xxx xxxx xxxxx xxxxxxxxxxxxxxx  xxx " " xx xxxxxxx xxxxxx  xxxxxxxxxxxxxxx  xx " " xx  xxxxx x  xxx   xxxxxxxxxxx  xx  xx " " xx xxxxxxxxxx      xxxxxxxxxx  xxx x x " " xxx   xxxxxxxxxx  xxxxxxxxxxx  xxx x x " "x xxx    xxx xxxxx xxxxxxxxxxx  xxx x x " "x xxxxxx xx   xxxxx xxxxx   xx  xxx x x " "xx xxxxx  x  xxxxx x   x     x  xxx x x " "xxx xxxx   xxxx xxxxxx   xx  x  xx xx x " "xxxx xxxxx   xx  xxxxxx xxxxx x x xx  x " "xxxxx xxxx   x  xxx  xx xxxxxx   xxx xx " "xxxxxx xxxxx xxxx  x  xxxxxxxxx xxxx xx " "xxxxxxx xxxx  xxxxxxxxx xxxxx  xxxx  xx " "xxxxxxxx xxxxx  xxxxxxxxxxxx xxxxxx xxx " "xxxxxxxxx xxxx xxxxx x xxxxxxxxxxx  xxx " "xxxxxxxxxx xxx  xxxx    xxxxxxxxxx xxxx " "xxxxxxxxxxx xxxx x xx xxxxxx xxxxx xxxx " "xxxxxxxxxxxx xxx  xxxxxxxx    xxx  xxxx " "xxxxxxxxxxxxx xxxx  xxxxxxx xxxx  xxxxx " "xxxxxxxxxxxxxx xxx   x  xxxxxxx   xxxxx " "xxxxxxxxxxxxxxx xxxx    xxxxxx x xxxxx x" "xxxxxxxxxxxxxxxx xxx     x  x x xxxxx xx" "xxxxxxxxxxxxxxxxx xxxx xxxx  x xxxxx xxx" "xxxxxxxxxxxxxxxxxx xxx    xx  xxxxx xxxx" "xxxxxxxxxxxxxxxxxxx xxxxx   xxxx   xxxxx" "xxxxxxxxxxxxxxxxxxxx xxxxxxxxxx xxxxxxxx" "xxxxxxxxxxxxxxxxxxxxx          xxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"))) (make-problem "19990518-MNT (15)" (quote ((11 10 15) (10 14 14) (9 2 2 12) (8 2 3 11) (7 2 3 10) (6 2 2 9) (6 2 2 8) (6 2 2 7) (6 2 2 6) (6 4 2 5) (7 3 3 4) (8 8 2 4) (9 7 3 3) (9 2 2 3) (12 8 5 2 3) (12 9 6 2 3) (11 4 5 9 3) (10 1 3 6 9 3) (8 1 1 1 1 2 1 3) (8 6 2 4 5 4 2) (8 7 2 2 4 1 1 1) (7 6 1 1 4 1 4 1) (7 7 1 1 4 2 1 1) (3 2 1 1 9 1 1) (2 11 1 1 8 1 1 1) (1 12 3 2 1 7 4 1) (1 13 3 4 6 5 1) (1 14 1 12 1) (1 31 2) (1 22 11 1) (1 9 11 6 1 4) (3 12 4 1 5) (9 13 8 5) (9 3 9 8 6) (9 4 6 9 7) (10 5 4 9 7) (11 5 9 8) (12 5 9 10) (13 14 11) (14 11 12))) (quote ((40) (25 9) (24 4 9) (23 5 8) (23 7 8) (23 7 8) (5 13 7 8) (4 5 10 7 8) (3 7 6 1 7 8) (2 2 3 4 4 7 5) (1 2 4 3 5 7 2 4) (2 2 2 1 4 7 4 3) (1 2 1 4 7 5 2) (2 6 11 2 4 1) (2 6 15 4) (2 2 3 1 1 7 4) (2 2 2 1 1 1 7 4) (2 2 1 1 2 8 3) (2 2 1 1 2 8 2) (2 3 1 6 9 2) (2 4 1 1 8 3) (2 3 1 2 7 4) (2 2 1 2 6 5) (1 3 2 1 5 6) (2 2 1 6 2 2 7) (1 2 2 2 3 8) (2 2 2 12 8) (2 2 4 12 7) (3 2 4 19 1) (4 2 2 18 2) (5 2 2 1 13 3) (6 2 3 1 12 3) (7 3 3 1 4 3 1 4) (8 4 2 1 4 2 3 6) (9 8 1 1 1 3 1 7) (10 8 1 4 1 9) (12 1 2 2 1 10) (19 1 4 1 10) (20 1 1 10) (21 5 11))) (quote ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxx      xxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxx  xxxx xxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxx  xxxxx  xxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxx xxxxxxx xxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxx xxxxxxx xxxxxxxx" "xxxxx     xxxxxxxxxxxxx xxxxxxx xxxxxxxx" "xxxx xxxxx xxxxxxxxxx   xxxxxxx xxxxxxxx" "xxx xxxxxxx xxxxxx    x xxxxxxx xxxxxxxx" "xx xx    xxx  xxxx xxxx xxxxxxx    xxxxx" "x xx     xxxx xxx xxxxx xxxxxxx  xx xxxx" " xx        xx xx x xxxx xxxxxxx xxxx xxx" " x         xx   x  xxxx xxxxxxx xxxxx xx" "xx         xxxxxx  xxxxxxxxxxx xx xxxx x" "xx         xxxxxx  xxxxxxxxxxxxxxx xxxx " "xx         xx xxx x x      xxxxxxx xxxx " "xx         xx xx x x      x xxxxxxx xxxx" "xx            xx x x     xx xxxxxxxx xxx" "xx            xx x  x    xx xxxxxxxx  xx" "xx            xxx x xxxxxx xxxxxxxxx  xx" "xx            xxxx x      x xxxxxxxx xxx" "xx             xxx x     xx xxxxxxx xxxx" "xx              xx x     xx xxxxxx xxxxx" " x             xxx xx     x xxxxx xxxxxx" " xx           xx x  xxxxxx xx xx xxxxxxx" "x xx          xx xx        xxx  xxxxxxxx" "xx xx         xx   xxxxxxxxxxxx xxxxxxxx" "xx xx         xxxx xxxxxxxxxxxx xxxxxxx " "xxx xx        xxxx xxxxxxxxxxxxxxxxxxx x" "xxxx xx         xx xxxxxxxxxxxxxxxxxx xx" "xxxxx xx        xx x   xxxxxxxxxxxxx xxx" "xxxxxx xx       xxx  x xxxxxxxxxxxx  xxx" "xxxxxxx xxx     xxx x xxxx xxx  x   xxxx" "xxxxxxxx xxxx   xx x xxxx xx xxx  xxxxxx" "xxxxxxxxx xxxxxxxx x x x xxx x   xxxxxxx" "xxxxxxxxxx  xxxxxxxx x  xxxx x xxxxxxxxx" "xxxxxxxxxxxx       x xx  xx x xxxxxxxxxx" "xxxxxxxxxxxxxxxxxxx x  xxxx x xxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxx x     x  xxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxx xxxxx  xxxxxxxxxxx"))) (make-problem "19990525-DRA (16)" (quote ((1) (3 1 1 3 3 1 1 3 2 3 1) (1 1 3 1 1 1 2 1 1 1 1 1 1 1 1) (1 1 1 1 1 3 1 2 3 1 1 3) (3 1 1 3 1 1 1 1 1 1 3 1 1 1) () () (1) (3) (5) (7) (11) (11) (11) (11) (11) (4 11 4) (5 11 5) (6 11 6) (7 11 7) (27) (27) (25) (23) (23) (23) (25) (25) (19) (11) (13) (15) (1) (1) (1) (1) (1) () () ())) (quote (() (4) (1 1) (4) () (4) (1) (4 6) (7 2) (12) (12) (4 12) (1 1 11) (1 1 10 1) (9 2) (4 21) (1 1 21) (4 22) (23) (4 24) (1 30) (1 24) (4 23) (22) (4 21) (1 1 21) (4 9 2) (10 1) (4 11) (1 1 12) (3 12) (12) (4 7 2) (1 1 6) (4) () () (3 1) () ())) (quote #f)) (make-problem "19990527bDRA (17)" (quote ((40) (40) (40) (21 16) (8 14 3 11) (6 10 5 2 2 8) (2 2 12 5 1 1 9) (2 2 5 6 5 9) (2 3 2 2 2 1 7 11) (2 1 2 2 3 2 4 4 6) (2 3 3 4 4 3 7) (4 2 2 3 4 2 8) (4 5 2 3 3 3 4 3) (4 4 2 2 5 2 5 3) (6 4 2 5 4 1 3) (3 2 4 2 3 3 4 1 3) (2 4 2 2 2 2 6 1 3) (4 4 2 2 1 1 7 1 3) (6 2 2 2 2 2 4 4) (6 2 2 4 2 3 5) (8 2 5 1 2 6) (9 1 3 5 2 1 4 3) (10 1 2 2 2 5 2) (3 5 2 2 1 3 5 3) (4 2 2 3 2 3 6) (6 1 1 3 2 2 8) (7 3 3 1 9) (6 7 3 2 2 4) (5 9 3 2 2 1 5) (4 11 1 1 5 6) (16 1 5 7) (17 2 7 4) (17 1 8 5) (17 1 15) (16 1 15) (16 2 15) (15 1 14) (13 15) (12 13) (40))) (quote ((40) (40) (6 5 23) (9 4 6 16) (10 3 6 4 10) (6 1 2 3 6 3 11) (5 3 2 5 1 12) (5 5 2 2 5 13) (4 6 3 2 3 14) (8 4 3 1 15) (11 3 1 14) (12 5 3 13) (7 3 5 2 11 1) (9 2 3 2 10 1) (11 1 3 9 1) (8 2 4 5 7 1) (8 3 4 3 3 1) (9 3 4 1 1) (5 2 5 3 6 1 1) (6 5 5 3 4 1) (10 9 2 1) (3 6 2 3 1) (3 5 4 2 1) (3 13 3 2 1) (4 6 4 5 3 1 1) (5 4 3 5 7 1 1) (6 3 1 2 9 1) (7 2 1 11) (4 2 3 1 4 10) (7 6 3 2 3 9) (6 5 6 2 2 9) (5 5 7 2 3 9) (10 4 3 3 2 8) (9 5 3 2 4 1 7) (14 3 4 2 7) (18 4 3 3 8) (12 3 16) (22 17) (40) (40))) (quote ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxx     xxxxx xxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxx  xxxx  xxxxxx xxxxxxxxxxxxxxxx" "xxxxxxxxxx    xxx xxxxxx xxxx xxxxxxxxxx" "xxxxxx  x  xx xxx xxxxxx xxx xxxxxxxxxxx" "xxxxx     xxx   xx  xxxxx x xxxxxxxxxxxx" "xxxxx xxxxx xx  xx  xxxxx  xxxxxxxxxxxxx" "xxxx xxxxxx xxx  xx  xxx  xxxxxxxxxxxxxx" "xxxxxxxx    xxxx xxx  x  xxxxxxxxxxxxxxx" "xxxxxxxxxxx  xxx   x      xxxxxxxxxxxxxx" "xxxxxxxxxxxx  xxxxx  xxx   xxxxxxxxxxxxx" "xxxxxxx   xxx  xxxxx   xx  xxxxxxxxxxx x" "xxxxxxxxx   xx     xxx  xx xxxxxxxxxx  x" "xxxxxxxxxxx  x      xxx     xxxxxxxxx  x" "xxxxxxxx xx    xxxx  xxxxx   xxxxxxx   x" "xxxxxxxx xxx   xxxx    xxx     xxx     x" "xxxxxxxxx xxx           xxxx       x   x" "xxxxx xx   xxxxx   xxx    xxxxxx   x   x" "xxxxxx      xxxxx xxxxx   xxx  xxxx    x" "xxxxxxxxxx     xxxxxxxxx    xx         x" "xxx xxxxxx  xx     xxx                 x" "xxx xxxxx  xxxx     xx                 x" "xxx  xxxxxxxxxxxxx     xxx  xx         x" "xxxx  xxxxxx xxxx    xxxxx  xxx     x  x" "xxxxx   xxxx xxx   xxxxx     xxxxxxx x x" "xxxxxx  xxx   x   xx         xxxxxxxxx x" "xxxxxxx          xx  x       xxxxxxxxxxx" "xxxx        xx xxx  x  xxxx   xxxxxxxxxx" "xxxxxxx xxxxxx xxx xx  xxx     xxxxxxxxx" "xxxxxx  xxxxx xxxxxx   xx  xx  xxxxxxxxx" "xxxxx xxxxx  xxxxxxx  xx  xxx  xxxxxxxxx" "xxxxxxxxxx xxxx xxx  xxx xx     xxxxxxxx" "xxxxxxxxx xxxxx xxx  xx  xxxx x  xxxxxxx" "xxxxxxxxxxxxxx      xxx xxxx xx  xxxxxxx" "xxxxxxxxxxxxxxxxxx xxxx xxx xxx xxxxxxxx" "xxxxxxxxxxxx      xxx   xxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"))) (make-problem "19990529bDRA (18)" (quote (() (9) (13) (11 5) (14 5) (16 5) (22) (3 3 1 12) (2 2 6) (2 6) (5 8 6) (2 2 1 1 1 1) (4 1 6) (2 1 1 2 7) (3 1 2 1 1 7) (5 2 3 1 7) (1 4 5 2 4) (2 2 1 6) (2 2 2) (1 3) (1 2 2) (1 1 1 2) (1 7 4) (2 3 1 2) (1 4) (2 4) (2 2 2) (2 2 2) (3 3 4) (8 2 2) (2 2 4) (8 2 7) (6 2 2 9) (8 2 2 11) (10 2 2 12) (12 2 2 14) (14 4 15) (15 16) (35) (35))) (quote (() () (4) (5) (6) (7) (7 8) (4 3 9) (11 2 9) (12 2 9) (4 1 1 2 2 9) (4 1 1 1 1 1 1 9) (5 1 2 2 2 2 1 7) (7 2 1 2 4 6) (7 3 1 2 5 5) (6 4 2 3 1 2 4) (6 2 1 1 2 3) (7 1 1 1 1 2 2) (6 1 3 1 1 2) (7 1 1 2 2 1 2) (7 1 1 1 1 2 2) (7 1 3 2 2 3) (2 4 1 1 2 2 4) (3 3 2 2 2 5) (3 2 3 2 6) (8 4 1 8 7) (16 9 8) (8 4 3 4 1 9) (14 4 12) (6 9 11) (4 7 10) (8 10) (9) (9) (8) (7) (5) () () ())) (quote #f)) (make-problem "19990530aDRA (19)" (quote ((40) (40) (26 13) (5 20 13) (5 11 3 13) (5 20 13) (5 5 1 4 1 1 11) (4 1 4 3 2 3 13) (5 4 4 3 2 3 13) (4 4 4 3 2 3 2 10) (4 4 6 1 4 10) (4 4 30) (40) (14 24) (13 1 24) (6 4 1 24) (6 1 3 1 12) (6 1 5 5 10) (5 2 1 1 2 7 7) (4 1 2 3 4 5) (3 1 2 1 1 1 5 4) (3 1 2 1 1 3 4) (3 1 1 1 3 4 1 2 1 4) (3 2 3 3 1 1 4) (3 1 3 3 2 1 1 4) (3 2 1 5 3 1 1 1 4) (3 2 2 3 2 2 1 1 4) (3 1 2 5 5 1 2 4) (4 1 2 11 1 2 5) (5 1 6 5 2 6) (6 1 13 2 7) (7 5 5 8) (8 15 9) (12 13) (40) (40) (40) (40) (40) (40))) (quote ((40) (40) (40) (20 12) (7 1 7 1 1 2 1 11) (3 8 2 1 10) (4 2 7 2 1 9) (4 2 7 1 1 2 1 8) (4 10 1 2 1 7) (4 2 2 5 2 2 1 1 7) (4 2 7 1 1 1 1 7) (6 10 2 1 1 1 1 7) (6 9 4 1 1 2 6) (6 7 3 1 2 1 6) (13 7 3 1 1 1 6) (6 3 4 2 1 1 1 6) (10 5 2 3 1 1 1 1 6) (10 5 1 1 3 1 1 1 6) (10 5 1 3 1 1 1 6) (7 5 2 1 2 1 1 1 6) (6 3 5 2 4 1 1 1 1 6) (16 3 1 1 1 6) (4 1 5 1 3 1 1 1 6) (16 4 2 1 1 1 6) (6 9 3 1 1 1 1 6) (6 9 2 1 2 1 6) (2 6 2 1 1 2 6) (6 3 5 2 1 1 1 7) (6 3 6 1 2 1 1 1 7) (9 6 2 2 1 1 7) (18 2 1 1 2 7) (18 5 1 1 2 8) (18 4 1 1 2 9) (19 2 1 1 2 10) (19 1 1 1 2 11) (20 12) (40) (40) (40) (40))) (quote ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxx        xxxxxxxxxxxx" "xxxxxxx x   xxxxxxx x x xx x xxxxxxxxxxx" "xxx       xxxxxxxx       xx x xxxxxxxxxx" "xxxx xx xxxxxxx           xx x xxxxxxxxx" "xxxx xx xxxxxxx x        x xx x xxxxxxxx" "xxxx xxxxxxxxxx           x xx x xxxxxxx" "xxxx xx xx  xxxxx    xx   xx x x xxxxxxx" "xxxx xx   xxxxxxx x        x x x xxxxxxx" "xxxxxx xxxxxxxxxx xx     x x x x xxxxxxx" "xxxxxx xxxxxxxxx      xxxx x x xx xxxxxx" "xxxxxx xxxxxxx         xxx x xx x xxxxxx" "xxxxxxxxxxxxx xxxxxxx   xxx x x x xxxxxx" "xxxxxx    xxx      xxxx  xx x x x xxxxxx" "xxxxxxxxxx xxxxx xx  xxx  x x x x xxxxxx" "xxxxxxxxxx xxxxx x  x xxx   x x x xxxxxx" "xxxxxxxxxx xxxxx x     xxx  x x x xxxxxx" "xxxxxxx    xxxxx xx   x xx  x x x xxxxxx" "xxxxxx xxx xxxxx xx xxxx x  x x x xxxxxx" "xxxxxxxxxxxxxxxx      xxx   x x x xxxxxx" "xxxx x     xxxxx   x  xxx   x x x xxxxxx" "xxxxxxxxxxxxxxxx xxxx    xx x x x xxxxxx" "xxxxxx xxxxxxxxx xxx      x x x x xxxxxx" "xxxxxx xxxxxxxxx xx        x xx x xxxxxx" "xx        xxxxxx xx        x x xx xxxxxx" "xxxxxx xxx xxxxx xx        x x x xxxxxxx" "xxxxxx xxx xxxxxx x  xx    x x x xxxxxxx" "xxxxxxxxx  xxxxxx xx      xx x x xxxxxxx" "xxxxxxxxxxxxxxxxxx xx     x x xx xxxxxxx" "xxxxxxxxxxxxxxxxxx xxxxx x x xx xxxxxxxx" "xxxxxxxxxxxxxxxxxx xxxx x x xx xxxxxxxxx" "xxxxxxxxxxxxxxxxxxx xx x x xx xxxxxxxxxx" "xxxxxxxxxxxxxxxxxxx x x x xx xxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxx        xxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"))) (make-problem "19990530bDRA (20)" (quote ((40) (40) (40) (40) (40) (15 15) (14 14) (13 13) (12 12) (11 11) (10 10) (9 9) (8 8) (7 7) (6 1 1 6) (6 5 5 6) (6 6 6 6) (6 6 6 6) (6 4 4 6) (6 2 2 6) (6 6) (7 1 1 7) (8 2 2 8) (3 3 9) (1 4 10) (1 6 1 1 1 1 6 3) (1 6 1 1 1 1 6 3) (1 5 1 1 1 6 1) (4 5 1 1 1 6 1) (5 4 5 1) (6 5 6 5) (7 4 5 6) (8 3 4 7) (9 2 3 8) (10 4 5 9) (11 12 10) (12 10 11) (13 8 12) (14 3 13) (15 14))) (quote ((40) (24 12) (24 12) (23 12) (23 11) (23 10) (14 6 9) (13 7 8) (12 7 7) (11 7 6) (10 7 5) (9 8 4) (8 3 4 3) (7 4 5 2) (6 6 1 1) (5 5 2) (5 4 2 3) (5 2 1 2 3) (5 2 2 3) (5 2 4) (5 2 2 4) (5 1 2 4) (5 2 2 3) (5 4 4) (5 5 4) (6 6 3) (7 4 6 1) (8 3 5 2) (9 9 3) (10 8 4) (11 8 5) (12 8 6) (13 8 7) (14 8 8) (25 9) (25 10) (25 10) (27 10) (27 10) (40))) (quote ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxx    xxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxx    xxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxx     xxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxx      xxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxx       xxxxxxxxxx" "xxxxxxxxxxxxxx       xxxxxx    xxxxxxxxx" "xxxxxxxxxxxxx         xxxxxxx   xxxxxxxx" "xxxxxxxxxxxx           xxxxxxx   xxxxxxx" "xxxxxxxxxxx             xxxxxxx   xxxxxx" "xxxxxxxxxx               xxxxxxx   xxxxx" "xxxxxxxxx                xxxxxxxx   xxxx" "xxxxxxxx       xxx            xxxx   xxx" "xxxxxxx        xxxx           xxxxx   xx" "xxxxxx        xxxxxx              x    x" "xxxxx          xxxxx              xx    " "xxxxx          xxxx      xx       xxx   " "xxxxx           xx    x    xx      xxx  " "xxxxx                xx  xx        xxx  " "xxxxx                      xx      xxxx " "xxxxx                xx  xx        xxxx " "xxxxx                 x    xx      xxxx " "xxxxx           xx       xx        xxx  " "xxxxx          xxxx               xxxx  " "xxxxx          xxxxx              xxxx  " "xxxxxx        xxxxxx              xxx   " "xxxxxxx        xxxx           xxxxxx   x" "xxxxxxxx       xxx            xxxxx   xx" "xxxxxxxxx                xxxxxxxxx   xxx" "xxxxxxxxxx               xxxxxxxx   xxxx" "xxxxxxxxxxx             xxxxxxxx   xxxxx" "xxxxxxxxxxxx           xxxxxxxx   xxxxxx" "xxxxxxxxxxxxx         xxxxxxxx   xxxxxxx" "xxxxxxxxxxxxxx       xxxxxxxx   xxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxx      xxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxx     xxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxx     xxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxx   xxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxx   xxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"))) (make-problem "19990530cDRA (21)" (quote ((40) (40) (9 28) (7 3 27) (6 5 12 10) (5 8 1 1 9) (5 5 3 8) (5 3 2 6 7) (5 3 2 6 7) (5 4 1 7 7) (5 4 1 4 2 1 7) (6 3 1 3 1 3 1 7) (6 3 2 6 1 7) (6 2 3 2 1 7) (6 2 3 3 2 7) (6 4 1 2 7) (13 1 1 3 7) (13 8 12) (12 3 11) (11 1 3 1 10) (10 3 3 9) (10 4 4 9) (4 5 19 9) (3 5 19 9) (2 5 19 9) (2 4 16 8) (2 3 15 5 7) (3 1 2 15 5 7) (4 3 1 4 10 5 7) (5 3 4 11 8) (6 3 4 13 10) (7 2 4 13 10) (8 1 4 13 10) (8 13 10) (7 5 11) (7 4 3 11) (7 4 11) (8 1 5 12) (40) (40))) (quote ((40) (40) (24 13) (23 12) (22 11) (5 14 1 10) (4 6 10 3 9) (3 10 11 3 2 3) (3 11 12 3 2) (2 4 4 14 3 2) (2 4 1 7 2) (2 3 12 13 2) (3 2 1 6 14 2) (4 2 4 13 2) (5 8 12 3) (5 8 6 2 2) (6 4 1 2 12 2 2) (5 3 1 1 12 2 2) (5 4 1 3 12 2 2) (5 1 4 1 3 13 3) (5 2 3 14 3) (5 1 1 14 3) (5 1 1 14 3) (6 2 2 13 3) (5 1 12 2) (5 12 2) (4 5 5 2) (4 5 3 4 2) (4 7 6 3 4 3) (4 5 5 3 6) (5 4 3 10) (6 8 3 10) (7 9 11) (40) (40) (40) (40) (40) (40) (40))) (quote ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxx   xxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxx     xxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxx       xxxxxxxxxxx" "xxxxx      xxxxxxxxxxxxxx   x xxxxxxxxxx" "xxxx xxxxxx     xxxxxxxxxx xxx xxxxxxxxx" "xxx  xxxxxxxxxx xxxxxxxxxxx xxx xx   xxx" "xxx xxxxxxxxxxx xxxxxxxxxxxx xxx      xx" "xx xxxx  xxxx  xxxxxxxxxxxxxx xxx     xx" "xx xxxx x    xxxxxxx                  xx" "xx xxx xxxxxxxxxxxx xxxxxxxxxxxxx     xx" "xxx xx x    xxxxxx xxxxxxxxxxxxxx     xx" "xxxx xx xxxx        xxxxxxxxxxxxx     xx" "xxxxx xxxxxxxx       xxxxxxxxxxxx    xxx" "xxxxx xxxxxxxx        xxxxxx       xx xx" "xxxxxx xxxx x   xx    xxxxxxxxxxxx xx xx" "xxxxx  xxx  x    x    xxxxxxxxxxxx xx xx" "xxxxx  xxxx x    xxx  xxxxxxxxxxxx xx xx" "xxxxx  x xxxx x  xxx  xxxxxxxxxxxxx  xxx" "xxxxx         xx xxx  xxxxxxxxxxxxxx xxx" "xxxxx         x  x    xxxxxxxxxxxxxx xxx" "xxxxx      x     x    xxxxxxxxxxxxxx xxx" "xxxxxx    xx    xx    xxxxxxxxxxxxx  xxx" "xxxxx      x          xxxxxxxxxxxx    xx" "xxxxx                 xxxxxxxxxxxx    xx" "xxxx                 xxxxx   xxxxx    xx" "xxxx                xxxxx xxx xxxx    xx" "xxxx       xxxxxxx xxxxxx xxx xxxx   xxx" "xxxx          xxxxx xxxxx xxx     xxxxxx" "xxxxx           xxxx      xxx xxxxxxxxxx" "xxxxxx           xxxxxxxx xxx xxxxxxxxxx" "xxxxxxx          xxxxxxxxx   xxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"))) (make-problem "19990601aDRA (22)" (quote ((18 1 19) (5 10 9 7) (5 10 9 7) (7 10 9 9) (8 8 9 10) (3 1 5 16 4 1 4) (2 5 11 4 3) (2 6 9 8 3) (3 8 7 10 4) (4 10 5 12 5) (13 17) (12 10 16) (11 12 15) (10 1 4 1 6 4) (3 3 1 1 4 1 1 5 4 3) (2 4 1 1 4 1 4 6 2) (1 7 1 4 1 3 8 1) (1 8 14 2 9 1) (9 4 4 4 2 10) (10 4 4 2 11) (11 10 2 12) (12 2 2 13) (12 2 2 1 13 1) (1 10 10 14 1) (1 9 12 13 1) (1 8 14 11 2) (2 6 14 10 2) (3 5 12 8 2) (4 4 2 4 3) (5 4 4) (8 1 1 1 11) (7 1 2 2 2 10) (6 2 16 3 9) (5 4 14 5 8) (3 6 7 6) (10 14) (9 13) (7 10 10) (6 6 8 7 9) (5 8 9 8))) (quote ((18 17) (16 5 14) (6 7 10 13) (5 5 12 6 5) (6 4 13 5 5) (1 2 5 14 3 5) (1 3 6 14 2 5 1) (3 11 13 1 5 2) (4 10 13 6 2) (4 11 9 3 2) (4 8 6 3 1 2) (5 6 6 4 2 3 2) (6 4 1 3 2 4 2 2) (7 2 2 4 5 2 1 1) (8 1 2 1 4 6 2 2) (9 2 1 2 6 2 2) (10 8 1 5 2 2) (1 7 8 2 5 2 2) (6 8 2 5 2 2) (1 5 8 1 5 2 2) (6 2 1 2 6 2 2) (1 6 2 4 6 2 2) (8 1 2 1 4 5 2 1 1) (7 3 1 3 2 4 2 2) (6 5 6 2 1 2 3 2) (6 6 2 3 3 1 2) (6 13 5 3 2) (6 12 7 1 7 2) (5 11 8 2 6 2) (4 11 11 2 5 2) (3 11 12 3 5 1) (1 11 13 4 5) (1 3 5 15 4 5) (5 4 15 4 5) (6 3 15 10) (5 4 15 10) (6 6 13 11) (15 9 12) (16 4 15) (18 18))) (quote ("xxxxxxxxxxxxxxxxxx     xxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxx  xxxxx   xxxxxxxxxxxxxx" "xxxxxx  xxxxxxx xxxxxxxxxx xxxxxxxxxxxxx" "xxxxx    xxxxx xxxxxxxxxxxx xxxxxx xxxxx" "xxxxxx    xxxx xxxxxxxxxxxxx xxxxx xxxxx" "x  xx    xxxxx xxxxxxxxxxxxxx xxx xxxxx " "x  xxx  xxxxxx xxxxxxxxxxxxxx xx xxxxx x" "xxx xxxxxxxxxxx xxxxxxxxxxxxx x xxxxx xx" "xxxx xxxxxxxxxx xxxxxxxxxxxxx  xxxxxx xx" "xxxx xxxxxxxxxxx xxxxxxxxx       xxx  xx" "xxxx xxxxxxxx      xxxxxx     xxx x   xx" "xxxxx xxxxxx xxxxxx xxxx xx    xxx    xx" "xxxxxx xxxx x    xxx xx xxxx    xx    xx" "xxxxxxx xx xx    xxxx  xxxxx    xx   x x" "xxxxxxxx x xx x  xxxx xxxxxx    xx   xx " "xxxxxxxxx  xx    x xx xxxxxx    xx   xx " "xxxxxxxxxx xxxxxxxx x  xxxxx    xx   xx " "x  xxxxxxx xxxxxxxx xx xxxxx    xx   xx " "    xxxxxx xxxxxxxx xx xxxxx    xx   xx " "x    xxxxx xxxxxxxx x  xxxxx    xx   xx " "    xxxxxx xx    x xx xxxxxx    xx   xx " "x  xxxxxx  xx    xxxx xxxxxx    xx   xx " "xxxxxxxx x xx x  xxxx  xxxxx    xx   x x" "xxxxxxx xxx x    xxx xx xxxx    xx    xx" "xxxxxx xxxxx xxxxxx xx x xx    xxx    xx" "xxxxxx xxxxxx      xx xxx     xxx x   xx" "xxxxxx xxxxxxxxxxxxx xxxxx       xxx  xx" "xxxxxx xxxxxxxxxxxx xxxxxxx x xxxxxxx xx" "xxxxx xxxxxxxxxxx  xxxxxxxx xx xxxxxx xx" "xxxx xxxxxxxxxxx xxxxxxxxxxx xx xxxxx xx" "xxx xxxxxxxxxxx xxxxxxxxxxxx xxx xxxxx x" "x  xxxxxxxxxxx xxxxxxxxxxxxx xxxx xxxxx " "x  xxx  xxxxx xxxxxxxxxxxxxxx xxxx xxxxx" "xxxxx    xxxx xxxxxxxxxxxxxxx xxxx xxxxx" "xxxxxx    xxx xxxxxxxxxxxxxxx xxxxxxxxxx" "xxxxx    xxxx xxxxxxxxxxxxxxx xxxxxxxxxx" "xxxxxx  xxxxxx xxxxxxxxxxxxx xxxxxxxxxxx" "xxxxxxxxxxxxxxx xxxxxxxxx   xxxxxxxxxxxx" "xxxxxxxxxxxxxxxx  xxxx   xxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxx    xxxxxxxxxxxxxxxxxx"))) (make-problem "19990601bDRA (23)" (quote ((35) (13 21) (14 19) (15 17) (16 6 7) (17 4 3) (17 1 4 5) (14 2 1 4 7) (13 1 3 4 7) (12 1 11 7) (11 4 10 8) (3 4 6 7 10) (2 1 2 15 10) (2 5 13 10) (1 8 12 12) (13 8 12) (7 7 7 13) (6 1 7 6 13) (6 7 4 13) (7 9 12) (6 10 2 11) (4 9 7 8) (3 7 9 7) (2 4 12 7) (1 1 3 15 6) (5 6 11 6) (4 10 1 9 6) (3 11 8 7) (3 14 5 9) (2 16 2 9) (2 17 11) (2 5 10 13) (1 4 10 13) (7 2 6 2 12) (6 4 4 5 11) (6 5 8 10) (29 10) (40) (40) (40))) (quote ((25 13) (14 9 6 7) (12 8 4 7) (11 9 3 10) (11 9 2 11) (11 8 1 12) (12 4 1 1 7 4) (12 3 1 5 5) (13 2 1 2 5 7) (13 3 5 5 7) (11 4 5 5 6) (10 9 6 6) (9 2 8 7 4) (1 6 4 7 10 4) (1 4 6 7 10 4) (2 3 5 7 10 4) (3 3 5 5 10 4) (4 1 5 4 3 6 4) (5 1 5 2 2 6 4) (5 2 6 1 1 4 4) (5 2 7 2 2 5) (5 10 5 1 5) (5 10 7 6) (5 11 7 6) (4 11 8 7) (4 7 10 7) (4 1 4 10 6) (5 5 3 8 2 5) (11 6 7 3 4) (10 7 6 5 3) (9 10 4 10) (7 10 3 12) (5 12 12) (5 17 13) (3 33) (1 34) (34) (35) (35) (35))) (quote ("xxxxxxxxxxxxxxxxxxxxxxxxx  xxxxxxxxxxxxx" "xxxxxxxxxxxxxx xxxxxxxxx  xxxxxx xxxxxxx" "xxxxxxxxxxxx   xxxxxxxx  xxxx    xxxxxxx" "xxxxxxxxxxx  xxxxxxxxx  xxx   xxxxxxxxxx" "xxxxxxxxxxx xxxxxxxxx    xx  xxxxxxxxxxx" "xxxxxxxxxxx  xxxxxxxx    x  xxxxxxxxxxxx" "xxxxxxxxxxxx xxxx  x     x xxxxxxx  xxxx" "xxxxxxxxxxxx xxx        x  xxxxx   xxxxx" "xxxxxxxxxxxxx xx x     xx xxxxx  xxxxxxx" "xxxxxxxxxxxxx xxx   xxxxx xxxxx  xxxxxxx" "xxxxxxxxxxx   xxxx xxxxx  xxxxx   xxxxxx" "xxxxxxxxxx     xxxxxxxxx  xxxxxx  xxxxxx" "xxxxxxxxx  xx  xxxxxxxx   xxxxxxx   xxxx" "x xxxxxx  xxxx  xxxxxxx  xxxxxxxxxx xxxx" "x  xxxx  xxxxxx xxxxxxx  xxxxxxxxxx xxxx" "xx  xxx   xxxxx xxxxxxx  xxxxxxxxxx xxxx" "xxx  xxx  xxxxx  xxxxx   xxxxxxxxxx xxxx" "xxxx   x   xxxxx  xxxx  xxx xxxxxx  xxxx" "xxxxx   x   xxxxx  xx   xx  xxxxxx  xxxx" "xxxxx    xx xxxxxx      x x  xxxx   xxxx" "xxxxx    xx xxxxxxx    xx      xx  xxxxx" "xxxxx    xxxxxxxxxx  xxxxx      x  xxxxx" "xxxxx    xxxxxxxxxx  xxxxxxx      xxxxxx" "xxxxx   xxxxxxxxxxx  xxxxxxx      xxxxxx" "xxxx   xxxxxxxxxxx   xxxxxxxx    xxxxxxx" "xxxx    xxxxxxx     xxxxxxxxxx   xxxxxxx" "xxxx  x  xxxx       xxxxxxxxxx    xxxxxx" "xxxxx  xxxxx    xxx  xxxxxxxx  xx  xxxxx" "xxxxxxxxxxx   xxxxxx  xxxxxxx  xxx  xxxx" "xxxxxxxxxx    xxxxxxx xxxxxx  xxxxx  xxx" "xxxxxxxxx  xxxxxxxxxx  xxxx   xxxxxxxxxx" "xxxxxxx    xxxxxxxxxx  xxx  xxxxxxxxxxxx" "xxxxx     xxxxxxxxxxxx      xxxxxxxxxxxx" "xxxxx  xxxxxxxxxxxxxxxxx   xxxxxxxxxxxxx" "xxx    xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" " x    xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "      xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "     xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "     xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "     xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"))) (make-problem "19990604aDRA (24)" (quote ((40) (40) (40) (7 32) (5 2 21 8) (5 3 17 2 6) (5 3 15 3 6) (5 3 15 3 6) (5 3 15 3 6) (6 1 17 3 6) (8 8 3 7 1 7) (8 8 3 8 9) (8 9 1 9 9) (8 6 6 9) (8 6 1 1 6 9) (9 3 2 2 4 9) (10 1 2 2 2 10) (11 1 11) (11 12) (11 12) (6 7) (2 1 5 5 1 3) (4 6 6 5) (2 7 7 3) (11 2 2 12) (12 2 2 13) (12 1 1 1 1 14) (9 1 1 11) (4 3 6 5 3 6) (5 1 8 7 1 7) (4 24 6) (40) (40) (5 2 4 3 14) (5 2 2 2 2 2 2 2 13) (5 5 3 2 14) (5 5 2 2 2 2 2 13) (5 2 2 2 2 2 2 2 13) (5 2 2 2 2 2 14) (40))) (quote ((40) (40) (21 1 16) (21 1 16) (22 5 1 9) (4 12 7 2 1) (4 10 9 2 4 1) (3 5 10 8 3 4 1) (10 5 7 4 2 1) (4 4 5 4 6 12) (5 7 3 6 12) (5 8 2 5 1) (16 6 1 4) (15 1 1 5 1 4) (15 1 2 6 1 1) (13 2 2 11) (13 2 10) (10 1 4 1) (12 3 1 4) (13 3 1 4) (12 4 1) (10 1 10) (13 2 2 10) (13 2 2 4 1) (15 1 1 1 5 1 2 1) (15 6 1 2 1) (16 1 6 1 2) (6 8 2 12) (6 7 2 6 12) (5 4 5 3 7 11) (11 4 8 10) (4 5 9 9 9) (5 9 8 9) (5 11 6 1 9) (22 17) (21 1 16) (21 1 16) (40) (40) (40))) (quote ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxx x xxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxx x xxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxx xxxxx x xxxxxxxxx" "xxxx     xxxxxxxxxxxx xxxxxxx  xx      x" "xxxx      xxxxxxxxxx xxxxxxxxx xx xxxx x" "xxx xxxxx xxxxxxxxxx xxxxxxxx xxx xxxx x" "xxxxxxxxxx     xxxxx xxxxxxx xxxx  xx  x" "xxxx xxxx xxxxx xxxx xxxxxx xxxxxxxxxxxx" "xxxxx    xxxxxxx xxx xxxxxx xxxxxxxxxxxx" "xxxxx    xxxxxxxx        xx xxxxx      x" "xxxxxxxxxxxxxxxx           xxxxxx x xxxx" "xxxxxxxxxxxxxxx         x x xxxxx x xxxx" "xxxxxxxxxxxxxxx x       xx  xxxxxx x   x" "xxxxxxxxxxxxx  xx        xx  xxxxxxxxxxx" "xxxxxxxxxxxxx xx              xxxxxxxxxx" "xxxxxxxxxx  x                 xxxx     x" "xxxxxxxxxxxx                  xxx x xxxx" "xxxxxxxxxxxxx                 xxx x xxxx" "xxxxxxxxxxxx                  xxxx     x" "xxxxxxxxxx  x                 xxxxxxxxxx" "xxxxxxxxxxxxx xx         xx   xxxxxxxxxx" "xxxxxxxxxxxxx  xx       xx   xxxx      x" "xxxxxxxxxxxxxxx x       x x xxxxx x xx x" "xxxxxxxxxxxxxxx            xxxxxx x xx x" "xxxxxxxxxxxxxxxx          x xxxxxx x  xx" "xxxxxx    xxxxxxxx       xx xxxxxxxxxxxx" "xxxxxx    xxxxxxx xx xxxxxx xxxxxxxxxxxx" "xxxxx xxxx xxxxx xxx xxxxxxx xxxxxxxxxxx" "xxxxxxxxxxx     xxxx xxxxxxxx xxxxxxxxxx" "xxxx xxxxx xxxxxxxxx xxxxxxxxx xxxxxxxxx" "xxxxx      xxxxxxxxx xxxxxxxx  xxxxxxxxx" "xxxxx     xxxxxxxxxxx xxxxxx x xxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxx x xxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxx x xxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"))) (make-problem "19990604bDRA (25)" (quote (() (19 18) (18 1 17) (18 2 16) (14 1 2 16) (13 3 3 2 10) (12 5 1 2 3 10) (11 5 1 1 3 11) (13 2 4 11) (16 4 4 7) (16 2 2 3 6) (3 10 5 4 1 5) (2 3 1 5 2 1 3 4) (2 2 1 1 1 1 2 10) (1 4 3 3 2 2 10) (1 6 2 2 1 2 11) (10 3 2 13) (5 3 4 2 3 9) (4 3 4 2 3 8) (3 3 3 3 1 3 2 6) (2 5 3 2 1 2 5 4) (1 7 6 3) (1 5 1 2 1 1 3 4 2) (1 3 5 1 1 2 7 3 2) (1 3 4 4 10 3 2) (1 3 3 12 3 2) (4 3 2) (5 3 2) (7 8) (7 1 1 8) (7 21 8) (8 19 9) (8 15 9) (9 1 9 1 10) (9 4 4 10) (10 15 11) (10 15 11) (11 13 12) (11 13 12) ())) (quote (() (25 12) (13 5 13) (11 5 17) (10 5 18) (10 5 19) (11 4 4 11) (11 3 4 11) (12 2 3 1 8) (13 2 2 2 2 6) (12 3 1 2 2 4) (11 1 3 4 2 2 2) (6 4 2 3 3 3 3) (5 4 3 2 1 3 5) (4 2 4 3 1 1 3 5) (3 3 3 1 3 3 4 4) (3 3 2 1 1 3 2 4 4) (3 4 2 2 4 2 4 4) (4 3 3 2 3 4 4 4) (1 1 4 1 4 4) (6 2 2 3 3 4 4) (1 3 1 2 2 3 4 4) (2 2 1 2 2 1 2 4 4) (6 3 1 2 2 2 4 4) (5 4 2 3 3 3 5) (4 4 1 1 3 4 3 5) (4 3 1 3 4 3 3) (4 1 4 2 1 4 2 2 2) (4 5 2 3 2 2 4) (10 4 3 2 2 6) (9 6 2 1 8) (8 8 3 11) (9 7 2 11) (10 7 18) (11 7 17) (20 16) (21 11) (38) (38) ())) (quote ("                                        " " xxxxxxxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxx " " xxxxxxxxxxxxx  xxxxx     xxxxxxxxxxxxx " " xxxxxxxxxxx   xxxxx  xxxxxxxxxxxxxxxxx " " xxxxxxxxxx   xxxxx  xxxxxxxxxxxxxxxxxx " " xxxxxxxxxx  xxxxx  xxxxxxxxxxxxxxxxxxx " " xxxxxxxxxxx xxxx  xxxx     xxxxxxxxxxx " " xxxxxxxxxxx  xxx  xxxx     xxxxxxxxxxx " " xxxxxxxxxxxx  xx  xxx x       xxxxxxxx " " xxxxxxxxxxxxx  xx  xx xx    xx  xxxxxx " " xxxxxxxxxxxx   xxx  x xx     xx   xxxx " " xxxxxxxxxxx  x  xxx  xxxx    xx xx  xx " " xxxxxx xxxx xx   xxx  xxx    xxx xxx   " " xxxxx  xxxx  xxx  xx    x    xxx xxxxx " " xxxx xx xxxx  xxx  x x       xxx xxxxx " " xxx xxx xxx x  xxx   xxx     xxxx xxxx " " xxx xxx xx x x  xxx    xx    xxxx xxxx " " xxx xxxx  xx xx xxxx   xx    xxxx xxxx " " xxxx xxx xxx xx  xxx xxxx    xxxx xxxx " " x   x    xxxx           x    xxxx xxxx " "  xxxxxx   xx xx  xxx  xxx    xxxx xxxx " " x xxx     x xx  xx    xxx    xxxx xxxx " " xx   xx x  xx  xx    x xx    xxxx xxxx " " xxxxxx xxx x  xx  xx   xx    xxxx xxxx " " xxxxx xxxx   xx  xxx  xxx    xxx xxxxx " " xxxx xxxx x  x  xxx  xxxx    xxx xxxxx " " xxxx xxx  x    xxx   xxxx    xxx xxx   " " xxxx x  xxxx   xx  x xxxx    xx xx  xx " " xxxx  xxxxx   xx  xxx xx     xx   xxxx " " xxxxxxxxxx  xxxx  xxx xx    xx  xxxxxx " " xxxxxxxxx  xxxxxx  xx x       xxxxxxxx " " xxxxxxxx  xxxxxxxx xxx     xxxxxxxxxxx " " xxxxxxxxx  xxxxxxx  xx     xxxxxxxxxxx " " xxxxxxxxxx  xxxxxxx xxxxxxxxxxxxxxxxxx " " xxxxxxxxxxx xxxxxxx  xxxxxxxxxxxxxxxxx " " xxxxxxxxxxxxxxxxxxxx  xxxxxxxxxxxxxxxx " " xxxxxxxxxxxxxxxxxxxxx      xxxxxxxxxxx " " xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx " " xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx " "                                        "))) (make-problem "19990606-DRA (26)" (quote (() (6) (14) (19) (21) (24) (27) (27) (2 5 5) (2 21) (2 12 4) (5 19) (6 18) (1 17) (2 16) (5 16) (9 19) (14 2 11) (3 3 3 1 1 8) (4 2 1 1 1 8) (2 1 2 1 1 8) (2 2 3 1 8) (2 3 2 1 8) (2 4 3 3 8) (2 2 2 3 1 8) (2 2 2 4 2 3 5) (6 6 2 1 1 4) (2 4 5 1 2 1 1 4) (4 2 4 1 1 2 1 3) (7 2 2 1 2 1 3) (1 2 1 1 2 1 3 3) (5 2 6 4) (5 16) (2 2 16) (2 2 6 9) (2 2 5 10) (3 5 11) (5 6 12) (14 13) (12 14))) (quote (() (2) (4) (3 1) (3 2) (1 2 2 1) (3 2 11) (1 9 6 7) (7 11 2 2 2) (8 3 3 2 2 1) (3 2 4 2 1 1 3 2) (4 2 4 1 2 1 2 2 3) (5 1 4 1 1 1 2 2 2) (5 2 1 2 1 1 2) (5 1 1 2 2) (7 1 2 2 2) (8 2 2) (9 2 2) (9 2 3 2) (10 1 5 3) (6 4 2 4 3) (7 5 1 4 4) (7 6 1 5 8) (7 8 5 7) (7 8 4 7 1) (7 9 7 2) (7 10 11 3) (6 8 2 4 4 4) (6 10 1 7 5) (5 1 7 5 1 1 1 9) (5 1 7 2 1 1 8) (6 15 2 1 8) (5 14 1 1 8) (19 3 8) (19 9) (32) (31) (29) (13) ())) (quote #f)) (make-problem "19990606-KVL (27)" (quote ((4 33) (2 17 1 11) (2 18 12) (1 30) (1 23 3) (1 25 1 2) (2 8 10 3) (2 5 5 8) (4 5 4 8 6) (11 3 5 5) (10 2 3 4) (9 2 2 3) (8 2 2 2) (7 2 2 1) (7 1 2 1) (7 1 1 4 1) (7 1 1 7 1) (8 2 2 8) (9 1 2 8) (13 1 8) (29) (29) (21 6) (21 6) (21 7) (15 4 4 2) (16 1 1 3) (5 10 5) (4 3 9 7) (3 7 6 7) (3 10 3 6) (3 13 6) (4 12 3) (7 6 3) (10 3 6 3) (13 7 5) (12 12) (3 9) (5) ())) (quote ((38) (3 32) (1 30) (1 21 5) (19 3 4) (18 4 4) (18 4 4) (1 5 10 5 3) (1 4 10 4 3) (3 5 9 4 3) (10 5 9 5 2) (9 2 12 4 2) (8 2 10 4 1) (8 2 9 5) (7 2 4 10 4) (7 1 2 2 5 4 4) (7 2 2 7 3 2 1) (6 1 2 6 4 1 2) (6 1 2 6 3 1 2) (6 2 1 2 7 3 3) (6 1 2 11 4) (6 1 1 7 4) (6 1 1 7 1 5) (6 1 1 8 3 4 2) (6 2 10 5 1 2) (6 1 10 6 5) (1 5 1 8 6 5) (2 4 1 7 6 4) (1 5 1 12 4) (7 1 7 4) (7 1 2) (7 1) (8) (4 3) (4 4) (5 4) (6 4) (5 6) (4 8) (4 12))) (quote ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx  " "xxx   xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx  " "x       xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx  " "x       xxxxxxxxxxxxxxxxxxxxx   xxxxx   " "         xxxxxxxxxxxxxxxxxxx xxx xxxx   " "         xxxxxxxxxxxxxxxxxx xxxx xxxx   " "         xxxxxxxxxxxxxxxxxx xxxx xxxx   " "x       xxxxx    xxxxxxxxxx xxxxx xxx   " "x       xxxx      xxxxxxxxxx xxxx xxx   " "xxx   xxxxx        xxxxxxxxx xxxx xxx   " "xxxxxxxxxx   xxxxx xxxxxxxxx xxxxx xx   " "xxxxxxxxx   xx   xxxxxxxxxxxx xxxx xx   " "xxxxxxxx   xx      xxxxxxxxxx xxxx x    " "xxxxxxxx  xx        xxxxxxxxx xxxxx     " "xxxxxxx  xx   xxxx  xxxxxxxxxx xxxx     " "xxxxxxx  x   xx  xx xxxxx xxxx xxxx     " "xxxxxxx xx  xx    xxxxxxx  xxx xx  x    " "xxxxxx  x  xx       xxxxxx xxxx x xx    " "xxxxxx  x xx        xxxxxx  xxx x xx    " "xxxxxx xx x     xx  xxxxxxx xxx   xxx   " "xxxxxx x xx    xxxxxxxxxxx       xxxx   " "xxxxxx x x     xxxxxxx           xxxx   " "xxxxxx x x     xxxxxxx   x       xxxxx  " "xxxxxx x x     xxxxxxxx xxx xxxx    xx  " "xxxxxx  xx      xxxxxxxxxx  xxxxx x xx  " "xxxxxx  x       xxxxxxxxxx xxxxxx xxxxx " "x xxxxx x        xxxxxxxx  xxxxxx xxxxx " "xx xxxx x         xxxxxxx xxxxxx   xxxx " "x xxxxx x           xxxxxxxxxxxx   xxxx " "xxxxxxx x              xxxxxxx     xxxx " "xxxxxxx x                           xx  " "xxxxxxx x                               " "xxxxxxxx                                " "xxxx xxx                                " "xxxx xxxx                               " "xxxxx xxxx                              " "xxxxxx xxxx                             " "xxxxx xxxxxx                            " "xxxx xxxxxxxx                           " "xxxx xxxxxxxxxxxx                       "))) (make-problem "19990607aDRA (28)" (quote ((40) (40) (9 30) (40) (3 16 18) (21 2 1 1 10) (21 3 7) (7 8 6 1 1 6) (3 3 12 1 1 2 3 4) (3 13 5 3 5) (18 1 6 3 1 6) (11 7 2 2 4) (19 2 1 4 1 5) (18 1 2 2 2 3) (17 1 3 3 4 2 4) (18 3 4 2 4) (21 4 5 2 1) (21 1 1 2 2 1) (5 4 10 1 6 2 2 1) (2 2 2 3 7 1 1 2 2 1) (1 2 1 4 7 2 4 2 2 1) (1 2 1 4 8 1 2 1 1) (1 2 5 10 2 3 1 1) (1 4 5 13 2 2 2 1) (1 3 5 15 2 1 3) (1 3 5 16 1 1 1 2) (1 3 5 16 1 1 3) (1 2 4 17 1 1 1 2) (2 2 3 18 1 1 3) (2 2 3 6 8 1 1 1 2) (2 2 3 5 7 1 1 3) (2 1 2 6 2 6 1 1 1 2) (3 1 1 7 3 5 1 1 1 3) (3 2 8 7 1 1 7) (3 2 10 3 8) (3 2 11 7 9) (3 1 13 12) (4 33) (4 34) (4 34))) (quote ((40) (20 12) (19 8) (4 3 17 3) (9 21) (18 14) (19 1 3 2) (7 13 3) (7 11 9 4) (2 16 10 6) (18 11 7) (11 16 8) (27 9) (24 12) (19 13) (20 16) (40) (7 6 25) (7 1 2 1 14 6) (7 1 1 1 14 5) (4 2 1 1 15 2 4) (4 1 2 1 2 10 3 1 3) (5 5 2 2 9 2 1 3) (6 1 3 1 2 2 9 1 1 3) (6 4 1 4 12 1 3) (5 1 2 4 2 12 1 3) (6 1 1 3 1 2 11 1 3) (5 1 1 11 1 3) (6 1 1 1 1 1 1 1 10 1 4) (5 1 3 1 1 1 1 1 1 8 2 4) (7 3 1 1 1 1 1 2 6 1 1 4) (8 1 1 1 1 1 1 2 1 1 5) (6 1 2 1 7 1 6) (7 1 13 1 7) (9 1 18 7) (8 2 1 8) (13 2 4 2 1 1 1 1 7) (16 5 2 1 1 1 8) (16 16) (40))) (quote ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxx        xxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxx             xxxxxxxx" "xxxx xxx  xxxxxxxxxxxxxxxxx          xxx" "xxxxxxxxx xxxxxxxxxxxxxxxxxxxxx         " "xxxxxxxxxxxxxxxxxx     xxxxxxxxxxxxxx   " "xxxxxxxxxxxxxxxxxxx    x         xxx  xx" "xxxxxxx  xxxxxxxxxxxxx               xxx" "xxxxxxx  xxxxxxxxxxx    xxxxxxxxx   xxxx" "xx xxxxxxxxxxxxxxxx   xxxxxxxxxx  xxxxxx" "xxxxxxxxxxxxxxxxxx  xxxxxxxxxxx  xxxxxxx" "xxxxxxxxxxx xxxxxxxxxxxxxxxx    xxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxx    xxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxx    xxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxx        xxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxx    xxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxx xxxxxx xxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxx x  xx x xxxxxxxxxxxxxx    xxxxxx" "xxxxxxx x x  x xxxxxxxxxxxxxx      xxxxx" "xxxx xx x   x xxxxxxxxxxxxxxx  xx   xxxx" "xxxx   x xx x xx   xxxxxxxxxx  xxx x xxx" "xxxxx  xxxxx xx xx  xxxxxxxxx   xx x xxx" "xxxxxx x xxx x xx xx xxxxxxxxx   x x xxx" "xxxxxx xxxx x xxxx    xxxxxxxxxxxx x xxx" "xxxxx  x xx  xxxx  xx xxxxxxxxxxxx x xxx" "xxxxxx x  x  xxx  x xx xxxxxxxxxxx x xxx" "xxxxx           x x    xxxxxxxxxxx x xxx" "xxxxxx x  x x x x x x  xxxxxxxxxx x xxxx" "xxxxx x xxx x x x x x x xxxxxxxx xx xxxx" "xxxxxxx xxx x x x x x xx xxxxxx x x xxxx" "xxxxxxxx x  x x x x x  xx      x x xxxxx" "xxxxxx  x xx          x xxxxxxx x xxxxxx" "xxxxxxx x  xxxxxxxxxxxxx       x xxxxxxx" "xxxxxxxxx x  xxxxxxxxxxxxxxxxxx  xxxxxxx" "xxxxxxxx xx x                   xxxxxxxx" "xxxxxxxxxxxxx xx xxxx xx x x x x xxxxxxx" "xxxxxxxxxxxxxxxx xxxxx xx x x x xxxxxxxx" "xxxxxxxxxxxxxxxx        xxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"))) (make-problem "19990607cDRA (29)" (quote ((40) (9 16 12) (8 14 11) (8 1 12 1 11) (7 3 10 1 11) (7 4 8 1 11) (6 2 2 7 1 11) (6 1 2 6 2 11) (5 2 3 4 3 11) (5 2 2 4 10) (4 3 3 4 10) (4 4 4 3 10) (4 4 3 2 10) (4 2 3 4 1 10) (5 8 1 11) (4 3 3 1 12) (3 3 4 2 2 12) (3 3 2 2 2 1 11) (3 3 2 7 11) (2 5 2 8 11) (2 6 12 10) (2 7 8 9) (1 12 8 8) (1 22 7) (1 23 6) (1 1 22 5) (1 3 22 4) (1 4 19 3) (1 5 7 8 3) (1 6 3 7 4) (1 8 2 6 4) (2 11 2 5) (2 16 1 4 6) (2 16 2 7) (2 15 14) (2 15 14) (2 14 14) (2 19 13) (2 22 13) (2 24 12))) (quote ((40) (22 9) (19) (16 1) (10 1 2) (8 2) (6 3 2) (4 6 3) (2 7 4 3) (1 3 4 7 3) (1 3 1 17 3) (2 5 3 7 14) (3 8 9 12) (4 5 11 11) (5 2 3 9 10) (8 3 1 8 10) (9 2 3 7 9) (9 2 2 2 7 9) (9 2 1 1 7 9) (9 2 1 1 7 9) (8 2 2 2 7 8) (7 2 4 7 8) (6 3 4 7 8) (5 15 8) (4 2 1 11 1 8) (3 4 2 11 1 1 3) (2 6 13 1 1 3 1) (1 11 12 1 6) (2 2 10 1 7) (9 6 10 1 6) (21 9 1 6) (22 8 1 6) (23 7 1 6) (24 2 2 7) (25 1 1 8) (26 9) (27 11) (40) (40) (40))) (quote ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxx         xxxxxxxxx" "xxxxxxxxxxxxxxxxxxx                     " "xxxxxxxxxxxxxxxx                       x" "xxxxxxxxxx    x                       xx" "xxxxxxxx                              xx" "xxxxxx     xxx                        xx" "xxxx    xxxxxx                       xxx" "xx    xxxxxxx              xxxx      xxx" "x   xxx   xxxx            xxxxxxx    xxx" "x  xxx       x     xxxxxxxxxxxxxxxxx xxx" "xx  xxxxx  xxx    xxxxxxx xxxxxxxxxxxxxx" "xxx  xxxxxxxx    xxxxxxxxx  xxxxxxxxxxxx" "xxxx    xxxxx   xxxxxxxxxxx  xxxxxxxxxxx" "xxxxx     xx   xxx xxxxxxxxx  xxxxxxxxxx" "xxxxxxxx      xxx x xxxxxxxx  xxxxxxxxxx" "xxxxxxxxx     xx xxx xxxxxxx   xxxxxxxxx" "xxxxxxxxx    xx xx xx xxxxxxx  xxxxxxxxx" "xxxxxxxxx    xx x   x xxxxxxx  xxxxxxxxx" "xxxxxxxxx    xx x   x xxxxxxx  xxxxxxxxx" "xxxxxxxx     xx xx xx xxxxxxx   xxxxxxxx" "xxxxxxx       xx xxxx xxxxxxx   xxxxxxxx" "xxxxxx        xxx xxxx xxxxxxx  xxxxxxxx" "xxxxx          xxxxxxxxxxxxxxx  xxxxxxxx" "xxxx     xx   x  xxxxxxxxxxx x  xxxxxxxx" "xxx     xxxx   xx xxxxxxxxxxx x  x   xxx" "xx     xxxxxx   xxxxxxxxxxxxx x x xxx  x" "x  xxxxxxxxxxx    xxxxxxxxxxxx x xxxxxx " "xx             xx   xxxxxxxxxx x xxxxxxx" "xxxxxxxxx     xxxxxx xxxxxxxxxx x xxxxxx" "xxxxxxxxxxxxxxxxxxxxx xxxxxxxxx x xxxxxx" "xxxxxxxxxxxxxxxxxxxxxx xxxxxxxx x xxxxxx" "xxxxxxxxxxxxxxxxxxxxxxx xxxxxxx x xxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxx xx  xx  xxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxx x   x xxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxx     xxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxx  xxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"))) (make-problem "19990616-DRA (30)" (quote ((40) (1 12 5 17) (2 13 5 17) (2 1 1 1 1 1 1 1 1 3 1 3) (2 1 1 1 1 1 3 1 1 1 1 1 1 1 1 1 2 2) (2 1 1 1 1 1 1 1 2 1 2 2 2) (40) (40) (40) (40) (40) (40) (40) (12 12) (10 14 10) (8 18 8) (7 4 1 1 1 1 1 1 1 3 7) (6 4 1 1 1 1 1 1 1 1 3 6) (5 3 1 1 1 1 1 1 1 1 1 2 5) (4 24 4) (3 1 24 1 3) (2 2 24 2 2) (1 3 24 3 1) (1 3 24 3 1) (1 3 24 3 1) (2 2 24 2 2) (3 1 24 1 3) (4 24 4) (5 24 5) (6 24 6) (7 23 7) (8 19 8) (10 14 10) (12 12) (40) (40) (40) (40) (40) (40))) (quote ((40) (1 20 15) (1 15 3 14) (1 18 5 13) (3 13 7 12) (3 1 12 11) (3 11 10) (16 9) (3 9 13 8) (5 9 15 8) (3 8 15 7) (14 3 13 7) (3 7 2 14 6) (3 1 7 2 1 14 6) (3 1 7 3 15 6) (13 2 1 14 6) (1 7 3 15 6) (3 9 2 1 14 6) (3 7 3 15 6) (13 2 1 14 6) (3 7 3 15 6) (3 1 7 2 1 14 6) (1 7 3 15 6) (13 2 1 14 6) (3 7 3 15 6) (3 1 7 2 1 14 6) (3 7 3 15 6) (13 1 1 13 6) (3 9 2 14 7) (5 8 2 13 7) (4 10 15 8) (5 9 14 8) (3 11 9) (17 10) (3 12 11) (3 15 7 12) (3 16 5 13) (4 15 3 14) (22 15) (40))) (quote ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "x xxxxxxxxxxxxxxxxxxxx   xxxxxxxxxxxxxxx" "x     xxxxxxxxxxxxxxx xxx xxxxxxxxxxxxxx" "x xxxxxxxxxxxxxxxxxx xxxxx xxxxxxxxxxxxx" "xxx   xxxxxxxxxxxxx xxxxxxx xxxxxxxxxxxx" "xxx x xxxxxxxxxxxx           xxxxxxxxxxx" "xxx   xxxxxxxxxxx             xxxxxxxxxx" "xxxxxxxxxxxxxxxx               xxxxxxxxx" "xxx   xxxxxxxxx  xxxxxxxxxxxxx  xxxxxxxx" "xxxxx xxxxxxxxx xxxxxxxxxxxxxxx xxxxxxxx" "xxx   xxxxxxxx  xxxxxxxxxxxxxxx  xxxxxxx" "xxxxxxxxxxxxxx xxx xxxxxxxxxxxxx xxxxxxx" "xxx   xxxxxxx  xx xxxxxxxxxxxxxx  xxxxxx" "xxx x xxxxxxx xx x xxxxxxxxxxxxxx xxxxxx" "xxx x xxxxxxx xxx xxxxxxxxxxxxxxx xxxxxx" "xxxxxxxxxxxxx xx x xxxxxxxxxxxxxx xxxxxx" "x     xxxxxxx xxx xxxxxxxxxxxxxxx xxxxxx" "xxx xxxxxxxxx xx x xxxxxxxxxxxxxx xxxxxx" "xxx   xxxxxxx xxx xxxxxxxxxxxxxxx xxxxxx" "xxxxxxxxxxxxx xx x xxxxxxxxxxxxxx xxxxxx" "xxx   xxxxxxx xxx xxxxxxxxxxxxxxx xxxxxx" "xxx x xxxxxxx xx x xxxxxxxxxxxxxx xxxxxx" "x     xxxxxxx xxx xxxxxxxxxxxxxxx xxxxxx" "xxxxxxxxxxxxx xx x xxxxxxxxxxxxxx xxxxxx" "xxx   xxxxxxx xxx xxxxxxxxxxxxxxx xxxxxx" "xxx x xxxxxxx xx x xxxxxxxxxxxxxx xxxxxx" "xxx   xxxxxxx xxx xxxxxxxxxxxxxxx xxxxxx" "xxxxxxxxxxxxx  x x xxxxxxxxxxxxx  xxxxxx" "xxx  xxxxxxxxx xx xxxxxxxxxxxxxx xxxxxxx" "xxxxx xxxxxxxx  xx xxxxxxxxxxxxx xxxxxxx" "xxxx xxxxxxxxxx xxxxxxxxxxxxxxx xxxxxxxx" "xxxxx xxxxxxxxx  xxxxxxxxxxxxxx xxxxxxxx" "xxx  xxxxxxxxxxx               xxxxxxxxx" "xxxxxxxxxxxxxxxxx             xxxxxxxxxx" "xxx   xxxxxxxxxxxx           xxxxxxxxxxx" "xxx xxxxxxxxxxxxxxx xxxxxxx xxxxxxxxxxxx" "xxx xxxxxxxxxxxxxxxx xxxxx xxxxxxxxxxxxx" "xxxx  xxxxxxxxxxxxxxx xxx xxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxx   xxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"))) (make-problem "19990618aDRA (31)" (quote ((40) (10 13 11) (9 3 11 3 10) (8 4 1 1 4 9) (8 4 4 9) (8 4 4 9) (9 10) (2 3 4 1 1 12) (1 1 3 12) (1 3 3 12) (1 3 1 12) (2 4 2 1 2 5 3 2) (2 4 5 4 1 1) (3 6 3 5 1) (4 8 6 1) (14 8 2) (15 9 2) (15 10 3) (13 9 4) (10 10) (9 9) (8 8) (8 8) (7 7) (6 6) (4 4) (3 2 2 3) (2 4 4 2) (2 4 4 2) (2 4 1 1 4 2) (2 4 2 2 4 2) (3 2 2 2 2 3) (4 2 3 3 2 4) (7 5 5 7) (7 5 5 7) (7 5 5 7) (7 5 2 5 7) (8 3 6 3 8) (9 16 9) (40))) (quote ((40) (8 29) (7 14 9) (8 12 4 8) (9 10 6 7) (8 11 6 7) (7 11 4 8) (8 12 2 3) (3 15 2 4 2) (2 3 13 2 6 1) (1 4 12 6 1) (1 4 6 6 1) (1 4 5 4 2) (2 3 2) (4 2 2) (3 2) (3 1 1 2) (3 2 3) (3 1 2 3) (3 5 4) (3 1 2 4) (3 2 3) (3 1 1 3) (3 2) (4 2 2) (2 3 2) (1 4 5 2) (1 4 6 4 2) (1 4 12 6 1) (2 3 12 6 1) (3 14 2 6 1) (21 2 4 2) (12 8 2 3) (11 7 4 8) (12 7 6 7) (13 6 6 7) (12 8 4 8) (11 10 9) (12 25) (40))) (quote ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxx   xxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxx      xxxxxxxxxxxxxx    xxxxxxxxx" "xxxxxxxx      xxxxxxxxxxxx xxxx xxxxxxxx" "xxxxxxxxx      xxxxxxxxxx xxxxxx xxxxxxx" "xxxxxxxx      xxxxxxxxxxx xxxxxx xxxxxxx" "xxxxxxx      xxxxxxxxxxx   xxxx xxxxxxxx" "xxxxxxxx   xxxxxxxxxxxx        xx    xxx" "xxx   xxxxxxxxxxxxxxx         xx xxxx xx" "xx xxx xxxxxxxxxxxxx         xx xxxxxx x" "x xxxx xxxxxxxxxxxx             xxxxxx x" "x xxxx       xxxxxx             xxxxxx x" "x xxxx        xxxxx              xxxx xx" "xx             xxx                    xx" "xxxx            xx                    xx" "xxx                                   xx" "xxx    x   x                          xx" "xxx        xx                        xxx" "xxx      x  xx                       xxx" "xxx      xxxxx                      xxxx" "xxx      x  xx                      xxxx" "xxx        xx                        xxx" "xxx    x   x                         xxx" "xxx                                   xx" "xxxx            xx                    xx" "xx             xxx                    xx" "x xxxx        xxxxx                   xx" "x xxxx       xxxxxx              xxxx xx" "x xxxx xxxxxxxxxxxx             xxxxxx x" "xx xxx xxxxxxxxxxxx             xxxxxx x" "xxx   xxxxxxxxxxxxxx         xx xxxxxx x" "xxxxxxxxxxxxxxxxxxxxx         xx xxxx xx" "xxxxxxxxxxxx   xxxxxxxx        xx    xxx" "xxxxxxxxxxx      xxxxxxx   xxxx xxxxxxxx" "xxxxxxxxxxxx      xxxxxxx xxxxxx xxxxxxx" "xxxxxxxxxxxxx      xxxxxx xxxxxx xxxxxxx" "xxxxxxxxxxxx      xxxxxxxx xxxx xxxxxxxx" "xxxxxxxxxxx      xxxxxxxxxx    xxxxxxxxx" "xxxxxxxxxxxx   xxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"))) (make-problem "19990618bDRA (32)" (quote (() () () (2 2) (3 3) (5 5) (7 7) (3 5 2 9) (1 2 8 4 8 3 1) (1 4 6 6 4 3 2) (2 4 5 2 1 3 6 2) (2 11 2 1 2 8 2) (2 5 5 4 4 6 2) (1 5 5 6 4 5 2) (1 4 7 4 6 4 1) (12 6 5) (7 4 4 7) (6 3 1 2 2 6) (3 3 2 3 3 3) (2 3 3 3 3 2) (3 4 3 2) (3 4 3 3) (5 4 3 3) (5 5 3 4) (4 6 4 3) (4 6 4 4) (4 7 4 4) (12 6 3) (11 10) (10 11) (5 5 11) (4 4 12) (4 3 12) (4 3 6 6) (2 2 5 5) (1 1 3 4) (2 2) (1 1) () ())) (quote (() () (3) (9 3) (3 3 3 4) (7 7 7) (4 12 7) (4 10 7) (3 9 8) (3 4 3 8) (4 2 3 4 4) (3 1 3 4 6) (8 4 8) (8 4 10) (8 3 12) (7 3 8 3) (1 3 1 3 8) (1 1 2 8) (7 1 7) (8 5) (3 3) (7 3) (1 1 4 5) (1 3 1 1 17) (7 2 19) (3 4 2 17) (2 5 2 12) (2 1 3 6 8) (2 3 2 8 6) (3 4 2 12) (3 4 3 11) (3 6 2 10) (15 7) (17 6) (6 6 6) (3 5 3 3) (9) () () ())) (quote #f)) (make-problem "19990618cDRA (33)" (quote ((40) (40) (2 3 33) (2 3 11 18) (2 10 17) (2 3 9 1 16) (2 3 8 4 16) (14 22) (3 7 22) (2 3 5 21) (2 4 20) (2 3 3 2 19) (2 3 1 4 18) (8 6 17) (2 3 2 7 16) (2 1 3 8 15) (2 1 1 4 9 14) (2 3 16 13) (2 3 17 12) (25 11) (2 3 19 10) (2 1 20 9) (2 1 1 21 8) (2 3 22 7) (2 3 1 19 6) (9 21 5) (2 2 22 4) (2 6 3 17 3) (2 4 4 19 2) (2 6 4 4 13 2) (2 2 4 5 15 2) (8 9) (2 2 9) (2 3 1 9) (2 1 9) (2 2 8 5 19) (2 3 13 19) (20 19) (40) (40))) (quote ((40) (40) (2 2 1 1 1 1 3) (4 3 1 4 5 4 1 1 1 1 5) (4 3 1 5 5 3 1 1 1 1 5) (4 3 1 4 5 4 3 1 1 4) (2 2 1 1 1 3 2 1 3) (40) (12 10 6 5) (12 9 5) (11 8 6 5) (10 14 5) (9 14 5) (8 14 3 5) (7 15 4) (6 16 3 5) (5 20 5) (4 19 5) (3 2 18 5) (3 4 15 1 5) (3 5 14 2) (3 7 13 1 5) (4 7 14 5) (5 7 13 5) (15 12 5) (16 11 5) (17 10 5) (18 9 5) (19 8 5) (20 7 5) (21 6 5) (22 14) (23 13) (24 12) (25 11) (26 10) (27 9) (28 9) (40) (40))) (quote ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xx     xx    x     x     x     x     xxx" "xxxx xxx x xxxx xxxxx xxxx x x x x xxxxx" "xxxx xxx x xxxxx xxxxx xxx x x x x xxxxx" "xxxx xxx x xxxx xxxxx xxxx xxx x x  xxxx" "xx     xx    x     x     x xxx xx  x xxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxx  xxxxxxxxxx xxxxxx    xxxxx" "xxxxxxxxxxxx   xxxxxxxxx           xxxxx" "xxxxxxxxxxx     xxxxxxxx xxxxxx    xxxxx" "xxxxxxxxxx       xxxxxxxxxxxxxx    xxxxx" "xxxxxxxxx        xxxxxxxxxxxxxx    xxxxx" "xxxxxxxx     xxxxxxxxxxxxxx xxx    xxxxx" "xxxxxxx     xxxxxxxxxxxxxxx         xxxx" "xxxxxx     xxxxxxxxxxxxxxxx xxx    xxxxx" "xxxxx      xxxxxxxxxxxxxxxxxxxx    xxxxx" "xxxx        xxxxxxxxxxxxxxxxxxx    xxxxx" "xxx    xx    xxxxxxxxxxxxxxxxxx    xxxxx" "xxx   xxxx    xxxxxxxxxxxxxxx x    xxxxx" "xxx   xxxxx    xxxxxxxxxxxxxx         xx" "xxx  xxxxxxx    xxxxxxxxxxxxx x    xxxxx" "xxxx  xxxxxxx    xxxxxxxxxxxxxx    xxxxx" "xxxxx  xxxxxxx    xxxxxxxxxxxxx    xxxxx" "xxxxxxxxxxxxxxx    xxxxxxxxxxxx    xxxxx" "xxxxxxxxxxxxxxxx    xxxxxxxxxxx    xxxxx" "xxxxxxxxxxxxxxxxx    xxxxxxxxxx    xxxxx" "xxxxxxxxxxxxxxxxxx    xxxxxxxxx    xxxxx" "xxxxxxxxxxxxxxxxxxx    xxxxxxxx    xxxxx" "xxxxxxxxxxxxxxxxxxxx    xxxxxxx    xxxxx" "xxxxxxxxxxxxxxxxxxxxx    xxxxxx    xxxxx" "xxxxxxxxxxxxxxxxxxxxxx    xxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxx    xxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxx    xxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxx    xxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxx    xxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxx    xxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxx   xxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"))) (make-problem "19990625-DRA (34)" (quote ((40) (16 17) (15 16) (5 8 15) (6 6 14) (6 4 13) (6 4 9 3) (6 4 8 3) (1 5 3 2 2 7 3) (2 4 2 3 3 7 4) (2 5 2 2 2 6 4) (2 4 2 2 2 5 5) (2 3 2 5 6) (3 3 2 4 6) (3 3 2 4 6) (3 3 2 5 6) (3 3 2 5 4 1) (3 3 2 5 4 1) (4 3 2 2 5 1) (4 3 5 1) (5 6 2) (6 6 2) (7 8 2) (11 8 2) (5 3) (4 4) (3 5) (2 6 12) (1 8 2 10) (1 7 1 4 8) (1 7 3 7 7) (1 6 5 8 5) (1 6 7 10 5) (1 6 7 11 4) (1 5 8 7 3) (1 5 10 8 2) (4 15 6 1) (4 17 6) (3 23 8) (2 27 7))) (quote ((36 2) (8 19 3) (9 14 4) (11 8 8) (12 5 9 1) (3 13 3 9 1) (4 10 2 8 2) (5 9 1 8 2) (8 3 1 7 3) (9 2 1 4 4) (15 1 1 3 5) (16 2 6) (5 2 2 8) (4 2 8) (3 2 9) (2 2 1 10) (1 4 11) (1 2 1 10) (1 9) (1 5) (1 4) (1 2 1 4) (1 4 6 4) (2 2 1 6 4) (3 2 5 3) (4 2 5 2) (5 3 1 5 2) (18 2 6 2) (18 2 1 6 2) (17 3 1 5 1) (16 4 2 5 1) (13 5 2 5) (11 6 3 6) (10 7 4 5) (8 11 4 5) (7 10 7 4) (6 10 9 3) (17 11 3) (16 16 2) (37 2))) (quote ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx  xx" "xxxxxxxx xxxxxxxxxxxxxxxxxxx         xxx" "xxxxxxxxx    xxxxxxxxxxxxxx        xxxx " "xxxxxxxxxxx       xxxxxxxx    xxxxxxxx  " "xxxxxxxxxxxx        xxxxx    xxxxxxxxx x" "xxx xxxxxxxxxxxxx    xxx    xxxxxxxxx  x" "xxxx    xxxxxxxxxx    xx    xxxxxxxx  xx" "xxxxx     xxxxxxxxx    x   xxxxxxxx   xx" "xxxxxxxx         xxx   x   xxxxxxx   xxx" "xxxxxxxxx         xx   x   xxxx     xxxx" "xxxxxxxxxxxxxxx    x   x   xxx     xxxxx" "xxxxxxxxxxxxxxxx           xx     xxxxxx" "xxxxx          xx          xx   xxxxxxxx" "xxxx            xx              xxxxxxxx" "xxx              xx            xxxxxxxxx" "xx       xx       x           xxxxxxxxxx" "x       xxxx                 xxxxxxxxxxx" "x       xx x                  xxxxxxxxxx" "x                              xxxxxxxxx" "x                                  xxxxx" "x                                   xxxx" "x       xx x                        xxxx" "x       xxxx                xxxxxx  xxxx" "xx       xx       x         xxxxxx  xxxx" "xxx              xx          xxxxx   xxx" "xxxx            xx           xxxxx    xx" "xxxxx          xxx     x      xxxxx   xx" "xxxxxxxxxxxxxxxxxx    xx      xxxxxx  xx" "xxxxxxxxxxxxxxxxxx    xx   x  xxxxxx  xx" "xxxxxxxxxxxxxxxxx    xxx   x   xxxxx   x" "xxxxxxxxxxxxxxxx    xxxx   xx   xxxxx  x" "xxxxxxxxxxxxx      xxxxx   xx   xxxxx   " "xxxxxxxxxxx       xxxxxx   xxx   xxxxxx " "xxxxxxxxxx       xxxxxxx   xxxx    xxxxx" "xxxxxxxx    xxxxxxxxxxx    xxxx    xxxxx" "xxxxxxx    xxxxxxxxxx     xxxxxxx   xxxx" "xxxxxx   xxxxxxxxxx      xxxxxxxxx   xxx" "xxxxxxxxxxxxxxxxx       xxxxxxxxxxx  xxx" "xxxxxxxxxxxxxxxx    xxxxxxxxxxxxxxxx  xx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx xx"))) (make-problem "19990628-DRA (35)" (quote ((40) (1 26 1) (2 20 2) (3 12 3) (4 4) (6 14 6) (9 14 9) (11 16 11) (11 16 11) (1 18 1) (1 7 20 7 1) (2 5 2 16 2 5 2) (3 3 3 14 3 3 3) (4 1 4 8 4 1 4) (8 7 6 7 8) (8 4 4 4 8) (8 4 2 4 8) (9 4 4 4 9) (10 16 10) (11 16 11) (11 16 11) (11 14 11) (12 14 12) (12 14 12) (12 14 12) (12 14 12) (12 14 12) (12 14 12) (12 14 12) (11 16 11) (11 1 8 1 11) (11 2 8 2 11) (11 3 8 3 11) (11 16 11) (11 16 11) (12 14 12) (13 1 1 13) (14 10 14) (15 15) (40))) (quote ((40) (1 7 29) (1 6 1 28) (1 5 2 27) (1 4 3 26) (1 4 3 26) (1 3 3 26) (2 3 2 27) (2 3 1 23) (2 2 5 22) (3 2 7 21) (3 2 6 7 5) (3 5 8 6 4) (3 8 1 14 5 3) (4 8 1 13 5 2) (4 8 1 12 3 1 1) (4 9 18 1 1) (4 10 18 1 1) (4 11 19 1 1) (4 31 1 1) (4 31 1 1) (4 11 19 1 1) (4 10 18 1 1) (4 9 18 1 1) (4 8 1 12 3 1 1) (4 8 1 13 5 2) (3 8 1 14 5 3) (3 5 8 6 4) (3 2 6 7 5) (3 2 7 21) (2 2 5 22) (2 3 1 23) (2 3 2 27) (1 3 3 26) (1 4 3 26) (1 4 3 26) (1 5 2 27) (1 6 1 28) (1 7 29) (40))) (quote ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "x xxxxxxx  xxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "x  xxxxxx x xxxxxxxxxxxxxxxxxxxxxxxxxxxx" "x   xxxxx xx xxxxxxxxxxxxxxxxxxxxxxxxxxx" "x    xxxx xxx xxxxxxxxxxxxxxxxxxxxxxxxxx" "x    xxxx xxx xxxxxxxxxxxxxxxxxxxxxxxxxx" "x     xxx xxx xxxxxxxxxxxxxxxxxxxxxxxxxx" "xx    xxx xx xxxxxxxxxxxxxxxxxxxxxxxxxxx" "xx    xxx x      xxxxxxxxxxxxxxxxxxxxxxx" "xx     xx  xxxxx  xxxxxxxxxxxxxxxxxxxxxx" "xxx    xx xxxxxxx  xxxxxxxxxxxxxxxxxxxxx" "xxx      xx xxxxxx    xxxxxxx      xxxxx" "xxx    xxxxx xxxxxxxx        xxxxxx xxxx" "xxx  xxxxxxxx x xxxxxxxxxxxxxx xxxxx xxx" "xxxx xxxxxxxx x  xxxxxxxxxxxxx  xxxxx xx" "xxxx xxxxxxxx x   xxxxxxxxxxxx   xxx x x" "xxxx xxxxxxxxx    xxxxxxxxxxxxxxxxxx x x" "xxxx xxxxxxxxxx   xxxxxxxxxxxxxxxxxx x x" "xxxx xxxxxxxxxxx xxxxxxxxxxxxxxxxxxx x x" "xxxx xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx x x" "xxxx xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx x x" "xxxx xxxxxxxxxxx xxxxxxxxxxxxxxxxxxx x x" "xxxx xxxxxxxxxx   xxxxxxxxxxxxxxxxxx x x" "xxxx xxxxxxxxx    xxxxxxxxxxxxxxxxxx x x" "xxxx xxxxxxxx x   xxxxxxxxxxxx   xxx x x" "xxxx xxxxxxxx x  xxxxxxxxxxxxx  xxxxx xx" "xxx  xxxxxxxx x xxxxxxxxxxxxxx xxxxx xxx" "xxx    xxxxx xxxxxxxx        xxxxxx xxxx" "xxx      xx xxxxxx    xxxxxxx      xxxxx" "xxx    xx xxxxxxx  xxxxxxxxxxxxxxxxxxxxx" "xx     xx  xxxxx  xxxxxxxxxxxxxxxxxxxxxx" "xx    xxx x      xxxxxxxxxxxxxxxxxxxxxxx" "xx    xxx xx xxxxxxxxxxxxxxxxxxxxxxxxxxx" "x     xxx xxx xxxxxxxxxxxxxxxxxxxxxxxxxx" "x    xxxx xxx xxxxxxxxxxxxxxxxxxxxxxxxxx" "x    xxxx xxx xxxxxxxxxxxxxxxxxxxxxxxxxx" "x   xxxxx xx xxxxxxxxxxxxxxxxxxxxxxxxxxx" "x  xxxxxx x xxxxxxxxxxxxxxxxxxxxxxxxxxxx" "x xxxxxxx  xxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"))) (make-problem "19990703-NEP (36)" (quote ((13 13) (9 2 2 3 2) (3 7 1 1 1 1 1 1) (7 3 2 1 1 1 1 3) (14 1 1 1 1 1 3) (11 2 1 1 1 1 3) (3 10 1 1 1 1 1 3) (6 8 2 2 3 4) (7 7 13) (2 14 1) (4 28) (1 5 27) (3 5 26) (1 4 5 25) (2 4 31) (3 4 17 11) (1 2 5 15 1) (1 3 4 14 1 7 1) (1 3 18 3 1 1 1 2) (1 4 6 14 1 1 3) (2 9 2 13 5 3) (2 8 4 11 7 1 1) (2 8 2 7 1 6 2) (12 1 4 6 1 2 6 1) (13 1 1 5 1 4 2 2) (4 1 1 5 1 4 1 2 1) (9 4 4 5 2 2 1 4) (2 3 1 4 4 5 3 2 4) (1 1 1 1 4 4 5 5 1 2 1) (1 1 1 2 4 4 5 4 2 1 2) (1 1 1 1 4 4 5 3 4 4) (2 3 1 5 7 3 2 4 1) (9 4 4 7 3 4 2) () (32 7) (1 3 2 1 3 2 1 3 5 2 3) (1 2 2 1 1 1 1 1 1 1 1 2 2 1 2 2) (1 1 1 1 1 1 1 1 1 2 1 2 2 1 2 2) (1 3 1 3 1 1 1 2 1 2 2 1 4 2) (5 2 3 2 2 2 2 1 2 3))) (quote ((9 1 1 6) (2 5 7 1 1) (7 2 2 2 4 1) (10 1 3 1 3 1) (3 8 2 2 2 3) (6 6 7 1 1 1) (6 5 2 2 1 1 1) (2 12 1 3 1 2 1) (4 10 2 1 2 6) (6 9 1) (2 6 15 1 4) (4 10 10 2 2) (2 5 8 2 9 1 4) (1 3 6 6 4 8 2) (1 4 6 5 2 1 6) (1 4 13 1 2 5 1 2 1) (2 4 13 1 6 1 1 3) (2 5 13 2 5 1 2 1) (2 5 13 1 6 1 6) (3 18 1 1) (3 29 2 3) (3 29 1 4) (33 2) (33 6) (33 2 1) (1 1 1 1 1 7 5 2 1 3) (1 1 1 1 7 5 7 1 1 3) (9 5 5 1 6 2) (1 1 5 3 1 2 6 5) (9 6 1 1 4 2 2 6) (2 2 6 2 2 4 1 1 1 2) (1 5 1 6 1 4 2 1 3 2 2) (2 2 6 2 4 2 3) (9 6 1 7 1 1 1 6) (2 2 6 2 5 2 1 2 2 3) (1 5 1 6 1 3 4 3 1 1 1) (2 2 6 2 2 4 3 1 1 1) (9 6 4 2 2 3 2 1) (1 6 6 4 1 2 3 1 6) (1 6 7 3 2 6))) (quote ("                xxxxxxxxx x     x xxxxxx" "              xx    xxxxx xxxxxxx x    x" "             xxxxxxx   xx xx   xx xxxx x" "               xxxxxxxxxx x xxx x xxx  x" "            xxx  xxxxxxxx xx   xx xx xxx" "           xxxxxx  xxxxxx xxxxxxx x x x " "            xxxxxx  xxxxx xx   xx x x x " "          xx xxxxxxxxxxxx x xxx x xx   x" "         xxxx  xxxxxxxxxx xx x xx xxxxxx" "         xxxxxx xxxxxxxxx         x     " "       xx xxxxxx  xxxxxxxxxxxxxxx x xxxx" "      xxxx xxxxxxxxxx  xxxxxxxxxx xx  xx" "   xx xxxxx xxxxxxxx xx xxxxxxxxx x xxxx" "x xxx xxxxxx xxxxxx xxxx xxxxxxxx xx    " "x xxxx xxxxxx xxxxx xx         x  xxxxxx" "x xxxx xxxxxxxxxxxxx x xx xxxxx x xx   x" "xx xxxx xxxxxxxxxxxxx  x xxxxxx x x xxx " "xx xxxxx xxxxxxxxxxxxx xx xxxxx x xx   x" "xx xxxxx xxxxxxxxxxxxx x xxxxxx x xxxxxx" "xxx xxxxxxxxxxxxxxxxxx         x  x     " "xxx xxxxxxxxxxxxxxxxxxxxxxxxxxxxx xx xxx" "xxx xxxxxxxxxxxxxxxxxxxxxxxxxxxxx x xxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx xx    " "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx xxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx xx   x" "x x x x x xxxxxxx  xxxxx       xx x xxx " " x x x x xxxxxxx  xxxxx xxxxxxx x x xxx " "xxxxxxxxx xxxxx  xxxxx x  xxxxxx  xx    " "x       x xxxxx   xxx x xx xxxxxx xxxxx " "xxxxxxxxx xxxxxx x   x xxxx xx xx xxxxxx" "xx     xx xxxxxx xx xx xxxx x x x xx    " "x xxxxx x xxxxxx x xxxx xx x xxx  xx xx " "xx     xx xxxxxx xx xxxx  xx xxx        " "xxxxxxxxx xxxxxx x xxxxxxx  x x x xxxxxx" "xx     xx xxxxxx xx xxxxx xx x xx xx xxx" "x xxxxx x xxxxxx x   xxx xxxx xxx x x x " "xx     xx xxxxxx   xx xx xxxx xxx x x x " "xxxxxxxxx xxxxxx  xxxx xx xx xxx  xx   x" "x  xxxxxx xxxxxx xxxx x xx  xxx x xxxxxx" "x  xxxxxx xxxxxxx    xxx       xx xxxxxx"))) (make-problem "19990714bNEP (37)" (quote ((3 2 3) (2 1 2 1 2 1) (1 1 1 2 1 1) (1 2 2 2 2 1 2) (2 2 2 2 2 1 2 2) (2 1 2 2 2 2) (2 2 2 2 2) (2 2 2 2 2 1) (1 2 2 2 2 2) (2 2 2 2 2 2 2) (2 2 2 2 2 2 2 1) (1 2 2 2 2 2 2 2) (2 2 2 2 2 2 2 2 2) (2 2 2 2 2 2 2 2 2 1) (1 2 2 2 2 2 2 2 2 2) (2 2 2 2 2 2 2 2 2 2) (2 2 2 2 2 2 2 2 2 2) (2 2 2 2 2 2 2 2 2 2) (2 2 2 2 2 2 2 2 2 2) (30) (1 1 1 1 1 1 1 1 1 1 1 1 1) (1 1) (34) (1 1 1 1 1 1 1 1 1 1 1 1 1 1) (1 1) (38) (1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1) (1 1) (38) (1 32 1) (1 32 1) (1 32 1) (1 32 1) (1 10 1 1 1 10 1) (1 10 1 1 1 10 1) (1 10 2 2 2 10 1) (1 10 2 2 2 10 1) (2 10 10 2) (2 32 2) ())) (quote (() (4 2) (1 11) (5 1) (1 1 11) (2 1 8 2 11) (5 7 2 1 11) (2 2 1 1 11) (1 2 10 2 2 11) (5 1 9 1 1 11) (1 1 2 11) (1 11 2 1 11) (14 1 1 11) (1 2 2 11) (17 1 1 5 1) (1 14 1 2 5 1) (1 2 1 9 1) (1 18 1 1 5 2 1) (19 2 2 5 1) (2 1 1 5 2 1) (1 1 2 9 1) (20 2 1 5 1) (1 19 1 1 9 1) (1 2 2 5 2 1) (1 16 1 1 5 1) (17 1 2 5 1) (1 2 1 11) (15 1 1 11) (1 12 2 2 11) (2 1 1 11) (1 9 1 2 11) (12 2 1 11) (1 1 1 11) (8 2 2 11) (1 9 1 11) (2 1 2 11) (5 4 1) (2 1 11) (1 2 4 2) (5))) (quote #f)) (make-problem "19990722-DRA (38)" (quote ((40) (40) (2 3 1 3 1 2 16) (2 2 1 3 3 3 19) (2 1 1 1 3 3 3 2 5) (2 2 1 3 3 7 1 8 4) (2 3 2 3 3 1 10 3) (24 12 2) (22 13 2) (21 16 1) (7 4 7 17 1) (7 2 7 17 1) (7 1 1 6 16 1) (7 4 6 8 8 2) (6 1 2 1 5 7 7 2) (6 6 5 6 2 5 3) (6 2 2 5 6 3 4) (6 6 4 6 13) (7 2 2 3 5 13) (9 6 3 5 12) (8 9 1 4 12) (7 13 4 12) (7 7 6 3 12) (7 4 2 8 2 11) (4 3 2 10 2 11) (3 6 2 12 2 10) (3 1 2 1 12 2 10) (3 3 1 1 1 12 1 10) (3 5 2 2 3 7 1 9) (3 5 1 1 2 10 9) (3 4 5 1 1 10 9) (4 7 1 10 9) (15 2 9 11) (16 7 11) (2 8 4 7 10) (1 3 6 5 6 10) (5 6 12 9) (5 10 9) (1 3 34) (2 35))) (quote ((36 2) (35 2 1) (2 27 4) (3 21 3 4) (4 19 2 3 2 4) (5 18 1 4 3 2 1) (2 7 6 1 4 4 2) (10 4 2 1 4 8) (2 5 2 3 1 6 2 9) (6 5 3 2 8 10) (6 5 3 2 5 1 10) (6 4 2 3 5 4 10) (2 3 4 4 2 6 4) (14 7 2 4 1 3) (2 14 6 2 2 3 1 3) (2 15 3 4 1 1 1 3) (2 11 11 2 1 3) (2 16 11 1 2 2) (2 17 8 1 1 2) (12 2 7 4 1 1 2) (3 1 3 5 1 7 4 1 1 2) (2 1 1 2 9 1 12 1 2) (2 1 1 1 11 12 1 2) (2 1 1 1 13 14 2) (4 1 15 13 2) (6 16 12 2) (5 9 6 10 2) (4 9 4 4 9 2) (4 8 8 3 3 3 2) (4 9 9 1 2 1 2) (4 10 11 4 2) (4 11 23) (4 11 23) (4 11 23) (4 11 23) (5 10 23) (6 8 24) (7 3 25) (9 27) (40))) (quote ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx  xx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx xx x" "xx     xxxxxxxxxxxxxxxxxxxxxxxxxxx xxxx " "xxx xxxxxxxxxxxxxxxxxxxxx      xxx xxxx " "xxxx xxxxxxxxxxxxxxxxxxx xx xxx xx xxxx " "xxxxx xxxxxxxxxxxxxxxxxx x xxxx xxx xx x" "xx     xxxxxxx    xxxxxx x xxxx xxxx  xx" "xxxxxxxxxx    xxxx xx    x xxxx xxxxxxxx" "xx    xxxxx xx xxx x xxxxxx xx xxxxxxxxx" "xxxxxx xxxxx xxx xx xxxxxxxx  xxxxxxxxxx" "xxxxxx xxxxx xxx xx xxxxx   x xxxxxxxxxx" "xxxxxx xxxx xx xxx xxxxx xxxx xxxxxxxxxx" "xx     xxx    xxxx xxxx xx   xxxxxx xxxx" "xxxxxxxxxxxxxx    xxxxxxx  xx xxxx x xxx" "xx xxxxxxxxxxxxxx xxxxxx xx xx xxx x xxx" "xx xxxxxxxxxxxxxxx xxx  xxxx  x  x x xxx" "xx     xxxxxxxxxxx xxxxxxxxxxx xx  x xxx" "xx xxxxxxxxxxxxxxxx xxxxxxxxxxx x xx  xx" "xx xxxxxxxxxxxxxxxxx xxxxxxxx     x x xx" "xxxxxxxxxxxx      xx xxxxxxx xxxx x x xx" "xxx  x xxx   xxxxx x xxxxxxx xxxx x x xx" "xx x x xx xxxxxxxxx x xxxxxxxxxxxx  x xx" "xx x x x xxxxxxxxxxx   xxxxxxxxxxxx x xx" "xx x x x xxxxxxxxxxxxx xxxxxxxxxxxxxx xx" "xxxx  x xxxxxxxxxxxxxxx xxxxxxxxxxxxx xx" "xxxxxx xxxxxxxxxxxxxxxx  xxxxxxxxxxxx xx" "xxxxx xxxxxxxxx    xxxxxx  xxxxxxxxxx xx" "xxxx xxxxxxxxx xxxx    xxxx xxxxxxxxx xx" "xxxx xxxxxxxx  xxxxxxxx  xxx xxx  xxx xx" "xxxx xxxxxxxxx  xxxxxxxxx   x   xx  x xx" "xxxx xxxxxxxxxx  xxxxxxxxxxx    xxxx  xx" "xxxx xxxxxxxxxxx xxxxxxxxxxxxxxxxxxxxxxx" "xxxx xxxxxxxxxxx xxxxxxxxxxxxxxxxxxxxxxx" "xxxx xxxxxxxxxxx xxxxxxxxxxxxxxxxxxxxxxx" "xxxx xxxxxxxxxxx xxxxxxxxxxxxxxxxxxxxxxx" "xxxxx xxxxxxxxxx xxxxxxxxxxxxxxxxxxxxxxx" "xxxxxx xxxxxxxx xxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxx  xxx   xxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxx    xxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"))) (make-problem "19990801-NEP (39)" (quote ((1 1) (1 1 1 1) (1 1 1 1) (1 1) (1 1) (1 1) (1 1 2 1 1) (1 2 1 1 2 1) (1 3 1 1 3 1) (1 1 3 2 3 1 1) (1 1 2 2 1 1) (1 2 1 1 2 1) (1 2 6 2 1) (1 2 2 2 1) (1 1 1 1) (3 2 2 3) (1 1 1 1) (1 12 1) (5 4 5) (40) (40) (40) (40) (1 1) (40) (1 1 1 1 1 1) (1 1 1 1 1 1) (7 5 5 7) (1 1 1 1 1 1 1 1 1 1 1 1) (1 1 1 5 5 1 1 1) (7 1 1 7) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (7 1 1 7) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (7 5 5 7) (1 1 1 2 2 2 2 1 1 1) (1 1 1 2 8 2 1 1 1) (7 2 2 2 2 7))) (quote ((21) (5 1 1 1 1 1 1) (2 1 5 1 4 4 1) (1 20 1 1 1 1 1 1) (2 1 5 4 4 4) (5 1 1 1 1 1 1) (4 16) (4 1) (4 1) (4 1 2) (4 1 3) (4 1 3 2) (4 1 1 1 1) (6 4 1 10) (2 2 1 4 1 1 1 1) (2 2 3 4 1 3 2) (1 3 1 4 1 3) (4 1 4 1 2) (2 1 1 6 1 1) (1 1 2 6 1 1) (1 1 2 6 1 1) (2 1 1 6 1 1) (4 1 4 1 2) (1 3 1 4 1 3) (2 2 3 4 1 3 2) (2 2 1 4 1 1 1 1) (6 4 1 10) (4 1 1 1 1) (4 1 3 2) (4 1 3) (4 1 2) (4 1) (4 1) (4 16) (5 1 1 1 1 1 1) (2 1 5 4 4 4) (1 20 1 1 1 1 1 1) (2 1 5 1 4 4 1) (5 1 1 1 1 1 1) (21))) (quote #f)) (make-problem "19990807-DRN (40)" (quote ((2) (1) (2) (3) (2) (1) (2) (3) (2) (1) (2) (3) (2) () (2) (1 2 4) (5 2 1 1) (2 2 2 1 1 1) (2 2 2 1 1 1 2) (1 2 2 2 1 1 1) (2 2 1 1 1 2) (2 1 1 2) (12 4) (1 2) (1 2) (2 3 1 4) (1 3 1 1 1 6) (2 3 3 1 15) (3 1 17) (3 1 20 2) (13 19 4) (15 16 6) (17 11 7) (19 6 10) (22 4 12) (23 13) (27 12) (28 11) (29 10) (30 9))) (quote ((13 1 2 1 1 1 10) (1 3 3 3 5 1 3 10) (1 1 1 2 1 10) (2 3 1 14) (2 3 1 14) (2 1 14) (2 1 10) (2 1 3 10) (2 1 1 1 10) (3 3 10) (2 10) (18) (10) (9) (9) (1 8) (2 8) (3 7) (4 7) (6 6) (6 6) (4 6 6) (2 1 1 8 5) (2 1 1 1 10 4) (1 1 1 14 4) (2 1 1 13 4) (1 1 1 2 10 4) (1 1 2 8 1 3) (4 6 3 2) (6 4 1) (5 6) (5 7) (5 7) (4 8) (2 9) (1 9) (10) (10) (11) (11))) (quote #f)) (make-problem "19990808bVAC (41)" (quote ((5 5 5) (3 2 3 3 2 3) (2 2 2 1 1 2 2 2) (2 2 2 9 2 2 2) (1 2 1 3 3 1 2 1) (2 3 2 2 2 1 1 2 2 2 3 2) (1 2 1 1 2 2 1 1 2 1) (1 2 2 4 1 4 2 1 1) (1 2 2 1 4 4 1 1 1 2 1) (1 2 1 1 5 5 1 2 2 1 1) (1 2 2 1 4 4 2 1 2 1) (1 1 1 1 4 5 1 1 1 1) (1 2 2 2 4 4 2 1 2 1 1) (2 1 1 1 5 1 5 2 2 1 2) (1 2 1 1 13 1 1 1 2 1) (1 1 3 3 5 3 3 1 1) (2 1 2 5 1 3 1 6 1 2) (1 1 1 3 1 1 1 1) (2 2 7 1 1 8 1 2) (2 3 7 3 2) (3 3 4 4 3 1 3) (5 4 4 3 1) (2 6 6 1 2) (2 3 4 5 4 3 3) (2 2 4 3 4 1 1 2) (1 2 6 5 6 3 1) (2 2 4 5 5 4 2 2) (1 1 4 3 3 4 1 1) (1 2 6 5 5 6 2 1) (1 1 4 5 5 5 4 1 1) (2 3 3 3 3 4 2) (7 5 5 5 7) (2 5 5 5 5 2) (2 3 3 3 3 2) (3 5 5 5 5 3) (7 5 5 5 7) (6 3 3 3 6) (7 5 5 5 7) (33) (2 2))) (quote ((9) (3 4) (2 1 2 3 5) (2 1 2 3 2 3 2 4) (1 1 2 3 2 2 2 1 6) (2 2 3 1 2 3 8) (1 1 2 3 3 3 2 4 5) (1 2 2 2 2 1 2 4 4) (1 2 3 1 1 1 2 6 5) (2 2 3 2 2 1 1 4 5 2) (2 3 3 1 1 1 1 4 3 1) (2 4 1 1 1 6 5 2) (3 3 1 1 1 4 5 5) (3 7 1 1 4 3 4) (9 1 6 5 5) (17 4 5 5 2) (1 8 2 4 3 3 1) (2 2 2 2 6 5 5 3) (2 1 1 1 4 2 5 5 6) (1 1 1 5 1 3 3 4) (2 1 1 1 4 2 5 5 6) (2 2 2 2 6 5 5 3) (1 8 2 4 3 3 1) (17 4 5 5 2) (9 1 6 5 5) (3 7 1 1 4 3 4) (3 3 1 1 1 4 5 5) (2 3 1 1 1 1 6 5 2) (2 3 1 1 1 1 1 1 1 4 3 1) (2 2 2 2 1 1 1 1 4 5 2) (1 2 2 1 13 6 5) (1 2 1 1 1 1 1 1 4 4) (1 1 1 2 1 3 8 4 5) (2 2 2 2 3 1 2 3 9) (1 1 1 1 2 2 2 2 1 6) (2 1 2 1 2 2 3 2 4) (2 1 1 3 5) (3 4) (9) ())) (quote #f)) (make-problem "19990831-DAH (42)" (quote ((40) (40) (40) (14 16) (12 12) (10 12 10) (8 16 9) (7 20 8) (6 22 7) (5 24 6) (5 25 5) (4 34) (4 13 2 2 2 4) (3 12 2 2 2 5) (3 12 2 2 2 2 3) (3 32 3) (3 10 2 2 2 4 2) (2 9 2 2 2 6 2) (2 9 2 2 2 7 2) (2 34 2) (2 7 2 2 2 9 2) (2 6 2 2 2 9 2) (2 4 2 2 2 10 3) (3 32 3) (3 2 2 2 2 12 3) (5 2 2 2 12 3) (4 2 2 2 13 4) (34 4) (5 25 5) (6 24 5) (7 22 6) (8 20 7) (9 16 8) (10 12 10) (12 12) (14 14) (40) (40) (40) (40))) (quote ((40) (40) (17 17) (13 4 15) (11 12 13) (9 13 1 11) (8 14 1 10) (7 15 2 9) (6 14 1 3 8) (6 14 3 3 7) (5 13 2 4 6) (5 14 2 5 6) (4 12 1 3 6 5) (4 12 3 1 8 5) (3 11 2 3 6 4) (3 11 2 2 7 4) (3 9 1 3 2 7 4) (3 8 3 1 3 8 4) (3 7 2 3 1 9 4) (3 7 2 2 3 7 4) (3 7 3 2 2 7 4) (3 9 1 3 2 7 4) (3 8 3 1 3 8 4) (3 7 2 3 1 9 4) (4 7 2 2 11 4) (4 6 3 2 11 4) (4 8 1 3 12 5) (4 6 3 1 12 5) (5 5 2 14 6) (5 4 2 13 6) (6 3 3 14 7) (7 3 1 14 7) (8 2 15 8) (9 1 14 9) (10 1 13 10) (12 12 12) (14 4 14) (16 18) (40) (40))) (quote ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxx      xxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxx     xxxx   xxxxxxxxxxxxxxx" "xxxxxxxxxxx   xxxxxxxxxxxx xxxxxxxxxxxxx" "xxxxxxxxx   xxxxxxxxxxxxx  x xxxxxxxxxxx" "xxxxxxxx  xxxxxxxxxxxxxx   x  xxxxxxxxxx" "xxxxxxx  xxxxxxxxxxxxxxx  xx   xxxxxxxxx" "xxxxxx  xxxxxxxxxxxxxx x xxx    xxxxxxxx" "xxxxxx xxxxxxxxxxxxxx  xxx xxx   xxxxxxx" "xxxxx  xxxxxxxxxxxxx   xx  xxxx   xxxxxx" "xxxxx xxxxxxxxxxxxxx  xx   xxxxx  xxxxxx" "xxxx  xxxxxxxxxxxx x xxx  xxxxxx   xxxxx" "xxxx xxxxxxxxxxxx  xxx x xxxxxxxx  xxxxx" "xxx  xxxxxxxxxxx   xx  xxx xxxxxx   xxxx" "xxx  xxxxxxxxxxx  xx   xx  xxxxxxx  xxxx" "xxx  xxxxxxxxx x xxx  xx   xxxxxxx  xxxx" "xxx  xxxxxxxx  xxx x xxx  xxxxxxxx  xxxx" "xxx  xxxxxxx   xx  xxx x xxxxxxxxx  xxxx" "xxx  xxxxxxx  xx   xx  xxx xxxxxxx  xxxx" "xxx  xxxxxxx xxx  xx   xx  xxxxxxx  xxxx" "xxx  xxxxxxxxx x xxx  xx   xxxxxxx  xxxx" "xxx  xxxxxxxx  xxx x xxx  xxxxxxxx  xxxx" "xxx  xxxxxxx   xx  xxx x xxxxxxxxx  xxxx" "xxxx xxxxxxx  xx   xx  xxxxxxxxxxx  xxxx" "xxxx  xxxxxx xxx  xx   xxxxxxxxxxx  xxxx" "xxxx  xxxxxxxx x xxx  xxxxxxxxxxxx xxxxx" "xxxx   xxxxxx  xxx x xxxxxxxxxxxx  xxxxx" "xxxxx  xxxxx   xx  xxxxxxxxxxxxxx xxxxxx" "xxxxx   xxxx  xx   xxxxxxxxxxxxx  xxxxxx" "xxxxxx   xxx xxx  xxxxxxxxxxxxxx xxxxxxx" "xxxxxxx    xxx x xxxxxxxxxxxxxx  xxxxxxx" "xxxxxxxx   xx  xxxxxxxxxxxxxxx  xxxxxxxx" "xxxxxxxxx  x   xxxxxxxxxxxxxx  xxxxxxxxx" "xxxxxxxxxx x  xxxxxxxxxxxxx   xxxxxxxxxx" "xxxxxxxxxxxx xxxxxxxxxxxx   xxxxxxxxxxxx" "xxxxxxxxxxxxxx   xxxx     xxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxx      xxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"))) (make-problem "19990902-TUC (43)" (quote ((19 3 2 12) (19 3 1 12) (18 1 2 1 12) (18 1 2 2 12) (17 2 1 2 12) (17 2 17) (16 3 16) (16 3 16) (15 3 15) (8 3 8) (8 5 3 5 8) (8 5 2 5 8) (3 3 4 2 4 8) (1 1 3 3 1 3 8) (1 1 3 1 1 1 8) (1 3 2 8) (6 3 6) (4 5 4) (2 6 2) (6) (5) (1 5 2) (3 1 5 4) (5 3 2) (7 2 4 3) (8 1 4 1) (8 2 3 4 3) (8 4 4 4) (8 5 1 5 8) (8 5 3 5 8) (8 3 8) (15 3 15) (16 3 16) (16 3 16) (17 2 17) (12 1 2 17) (12 5 1 18) (12 2 1 19) (15 3 19) (12 3 19))) (quote ((12 3 19) (15 3 18) (13 3 1 18) (15 2 1 17) (12 1 2 17) (17 2 1 16) (16 3 16) (16 3 15) (9 3 9) (9 5 3 4 9) (9 4 3 4 9) (9 4 1 3 9) (9 3 3 4 1) (9 2 2 4 1 1) (9 4 1 1) (8 2 3 1) (6 3 6) (4 5 4) (2 6 2) (6) (6) (2 6 3) (4 5 4) (6 5 6) (3 5 8) (1 7 9) (2 6 2 2 9) (4 3 3 9) (9 4 1 4 9) (9 4 3 4 9) (9 5 2 5 9) (9 3 9) (16 2 16) (16 3 16) (17 2 17) (17 2 17) (18 1 1 12) (18 1 1 1 1 12) (19 2 1 1 12) (19 2 3 12))) (quote ("xxxxxxxxxxxx    xxx  xxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxx xxx   xxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxx  xxx x  xxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxx xx x   xxxxxxxxxxxxxxxxx" "xxxxxxxxxxxx    x xx   xxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxx xx  x xxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxx xxx    xxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxx xxx     xxxxxxxxxxxxxxx" "xxxxxxxxx       xxx            xxxxxxxxx" "xxxxxxxxx xxxxx xxx       xxxx xxxxxxxxx" "xxxxxxxxx xxxx xxx        xxxx xxxxxxxxx" "xxxxxxxxx xxxx x           xxx xxxxxxxxx" "xxxxxxxxx xxx              xxx xxxx   x " "xxxxxxxxx xx                xx xxxx x x " "xxxxxxxxx                      xxxx x x " "xxxxxxxx                    xx  xxx x   " "xxxxxx                       xxx  xxxxxx" "xxxx                         xxxxx  xxxx" "xx                            xxxxxx  xx" "                                xxxxxx  " "  xxxxxx                                " "xx  xxxxxx                           xxx" "xxxx  xxxxx                         xxxx" "xxxxxx  xxxxx                     xxxxxx" "     xxx  xxxxx                 xxxxxxxx" "x xxxxxxx                      xxxxxxxxx" "xx xxxxxx xx                xx xxxxxxxxx" "     xxxx xxx              xxx xxxxxxxxx" "xxxxxxxxx xxxx          x xxxx xxxxxxxxx" "xxxxxxxxx xxxx        xxx xxxx xxxxxxxxx" "xxxxxxxxx xxxxx       xx xxxxx xxxxxxxxx" "xxxxxxxxx            xxx       xxxxxxxxx" "xxxxxxxxxxxxxxxx     xx xxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxx    xxx xxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxx   xx xxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxx   xx xxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxx  x x     xxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxx  x x x x xxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxx  xx x x xxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxx  xx xxx xxxxxxxxxxxx"))) (make-problem "19990905-ARE (44)" (quote ((1) (1) (1 17) (1 19) (1 20) (1 1 3) (1 7 3) (1 5 1 1 3) (1 1 1 1 3) (2 2 1 2 3) (2 3 1 3) (2 5 17 3) (1 5 19 3) (6 21 3) (4 23 3) (2 27) (28) (1 1) (2 23 1) (1 1) (1 2 2 2 2 2 1) (1 2 2 2 2 2 1) (1 2 2 2 2 2 1) (1 2 2 2 2 2 1) (1 2 2 2 2 2 1) (1 2 2 2 2 2 1) (1 2 2 2 2 2 1) (1 2 2 2 2 2 1) (1 2 2 2 2 2 1) (1 2 2 2 2 2 1) (1 2 2 2 2 2 1) (1 2 2 2 2 2 1) (1 1 1 1) (2 31 2) () (4 3 3 1 3 3 3 4) (2 1 1 1 1 1 1 1 1 1 2) (3 1 2 3 3 1 1 1 3) (2 1 1 1 1 1 1 1 1 2) (4 1 3 1 1 1 3 1 4))) (quote ((2 1) (1 3) (5) (3 3 1 1) (3 3 2 2 1 1) (2 4 1 1 1) (1 5 16) (2 5 3 1) (1 5 2 1) (1 4 3 1 12 1 1) (1 1 4 1 12 1 5) (2 1 5 1 1 1) (3 1 6 1 1) (6 6 1 1 5) (3 1 9 1 12 1 1 1 1) (3 1 6 1 12 1 1 1) (3 1 6 1 1) (3 1 1 6 1 1 4) (3 4 6 1 1 1 1) (3 6 1 12 1 4) (3 6 1 12 1) (3 6 1 1 5) (3 6 1 1 1 1) (3 6 1 1 3) (3 6 1 12 1) (3 6 1 12 1 5) (3 6 1 1 1 1) (3 6 1 1 5) (3 6 1 1) (3 5 1 12 1 1) (3 4 1 12 1 5) (3 3 1 1 1) (3 2 1) (12 1) (9 15 1 1) (6 1 1 1) (1 1) (5) (1 3) (2 1))) (quote #f)) (make-problem "19990916aCAR (45)" (quote ((22 8 6) (3 17 6 5) (2 17 6 4) (3 8 15 3) (11 14 3) (12 15 3) (29 4) (7 14 7 5) (6 12 7 6) (7 4 9 17) (13 26) (14 24) (3 12 23) (2 12 13 7) (3 15 11 6) (11 8 11 7) (10 8 18) (11 10 1 15) (24 1 7 4) (22 1 7 3) (24 6 2) (23 2 4 2) (31 1 1 1) (30 2 2 1 1) (5 1 4 14 8) (4 1 3 12 9) (4 2 2 2 8 10) (5 3 3 3 8 11) (6 3 4 3 5 12) (3 1 5 14) (2 2 3 2 6 15) (2 2 3 2 5 12 3) (2 2 3 2 4 3 3 2 2) (3 4 2 4 2 5) (5 6 11 8) (4 1 2 1 23) (1 1 1 3 1 1 23) (4 1 4 1 1 23) (5 1 6 1 23) (4 1 4 1 22))) (quote ((37 2) (36 3) (2 10 16 3 3) (1 8 14 3 2 3) (2 10 11 2 3 1 3) (24 1) (8 15 5) (7 15 2) (8 15 4 5 3) (24 3 5 4) (16 9 5 4) (4 10 12 3 3) (3 3 6 12 3 2 2) (4 5 14 2 3 1 3) (11 12 1) (11 12 5) (12 12 2) (13 15 4 4) (13 15 4 5) (14 11 3 6) (15 10 6 6) (1 6 7 15 6) (4 7 1 11 1 6) (1 6 10 1 8 2 6) (17 1 9 2 6) (19 7 2 7) (18 2 6 3 7) (28 3 7) (3 21 4 7) (2 18 6 6) (1 15 9 5) (5 6 11 5) (4 4 10 6) (5 4 8 7) (1 10 9 7) (2 11 8 8) (3 13 7 8) (20 10 7) (22 9 6) (24 7 6))) (quote ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx xx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx xxx" "xx xxxxxxxxxx xxxxxxxxxxxxxxxx   xxx xxx" "x   xxxxxxxx   xxxxxxxxxxxxxx xxx xx xxx" "xx xxxxxxxxxx xxxxxxxxxxx  xx xxx x xxx " "xxxxxxxxxxxxxxxxxxxxxxxx    x           " "xxxxxxxx xxxxxxxxxxxxxxx           xxxxx" "xxxxxxx   xxxxxxxxxxxxxxx  xx           " "xxxxxxxx xxxxxxxxxxxxxxx xxxx xxxxx xxx " "xxxxxxxxxxxxxxxxxxxxxxxx  xxx xxxxx xxxx" "xxxxxxxxxxxxxxxx xxxxxxxxx    xxxxx xxxx" "xxxx xxxxxxxxxx   xxxxxxxxxxxx   xxx xxx" "xxx   xxx xxxxxx xxxxxxxxxxxx xxx xx  xx" "xxxx xxxxx xxxxxxxxxxxxxx  xx xxx x xxx " "xxxxxxxxxxx xxxxxxxxxxxx    x           " "xxxxxxxxxxx xxxxxxxxxxxx           xxxxx" "xxxxxxxxxxxx xxxxxxxxxxxx  xx           " "xxxxxxxxxxxxx xxxxxxxxxxxxxxx xxxx xxxx " "xxxxxxxxxxxxx xxxxxxxxxxxxxxx xxxx xxxxx" "xxxxxxxxxxxxxx xxxxxxxxxxx    xxx xxxxxx" "xxxxxxxxxxxxxxx xxxxxxxxxx xxxxxx xxxxxx" "x xxxxxx xxxxxxx xxxxxxxxxxxxxxx  xxxxxx" "   xxxx   xxxxxxx x xxxxxxxxxxx x xxxxxx" "x xxxxxx xxxxxxxxxx x xxxxxxxx xx xxxxxx" "xxxxxxxxxxxxxxxxx  x xxxxxxxxx xx xxxxxx" "xxxxxxxxxxxxxxxxxxx  xxxxxxx  xx xxxxxxx" "xxxxxxxxxxxxxxxxxx xx xxxxxx xxx xxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxx xxx xxxxxxx" "xxx   xxxxxxxxxxxxxxxxxxxxx xxxx xxxxxxx" "xx     xxxxxxxxxxxxxxxxxx  xxxxxx xxxxxx" "x       xxxxxxxxxxxxxxx  xxxxxxxxx xxxxx" "         xxxxx xxxxxx  xxxxxxxxxxx xxxxx" "         xxxx   xxxx  xxxxxxxxxx  xxxxxx" "         xxxxx xxxx     xxxxxxxx xxxxxxx" "x       xxxxxxxxxx     xxxxxxxxx xxxxxxx" "xx     xxxxxxxxxxx     xxxxxxxx xxxxxxxx" "xxx   xxxxxxxxxxxxx     xxxxxxx xxxxxxxx" "xxxxxxxxxxxxxxxxxxxx  xxxxxxxxxx xxxxxxx" "xxxxxxxxxxxxxxxxxxxxxx  xxxxxxxxx xxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxx  xxxxxxx xxxxxx"))) (make-problem "19990927-BBA (46)" (quote ((2 1) (2 2) (2 3) (2 3) (2 4) (2 4) (2 2 4) (2 2 4) (3 2 2 4) (6 2 2 5) (3 3 2 2 5) (2 3 2 2 2 3) (3 2 2 2 2 3) (2 4 2 2 2 4) (2 2 5 2 2 6) (2 3 4 17) (4 2 4 9 7) (5 2 6 2 2 4) (10 8 2 2 4) (9 2 2 4 2 4) (8 2 2 5 4) (7 2 2 5 3) (7 2 2 2 14) (10 2 2 14) (4 4 2 1 3) (3 5 2 2) (4 3 4 2 2) (7 5 3) (8 8 6) (12 6 7) (10 20) (11 4 15) (14 4 8) (14 4 6) (19 6) (24) (21) (18) (14) (10))) (quote ((4) (7) (12) (3 14) (3 15) (2 15) (3 7 8) (2 6 8) (2 8 10) (2 4 13) (3 3 4 9) (2 3 4 8) (3 3 2 10) (3 3 13) (7 4 7) (5 3 7) (24 3 8) (24 12) (2 12) (19 4 7) (16 1 2 6) (4 2 2 3 7) (4 2 1 10) (21 10) (21 10) (5 2 2 3 6) (17 2 5) (15 3 6) (5 2 9) (5 2 8) (5 2 7) (6 3 7) (6 3 6) (2 3 4 5) (2 5 2 5) (2 4 6) (3 4) (2 3) (2 1) (2 1))) (quote ("                xxxx                    " "              xxxxxxx                   " "            xxxxxxxxxxxx                " "           xxx  xxxxxxxxxxxxxx          " "          xxx    xxxxxxxxxxxxxxx        " "         xx       xxxxxxxxxxxxxxx       " "        xxx       xxxxxxx xxxxxxxx      " "        xx        xxxxxx   xxxxxxxx     " "        xx       xxxxxxxx xxxxxxxxxx    " "         xx    xxxx    xxxxxxxxxxxxx    " "         xxx  xxx      xxxx xxxxxxxxx   " "          xx xxx      xxxx   xxxxxxxx   " "           xxx      xxx  xx xxxxxxxxxx  " "            xxx    xxx   xxxxxxxxxxxxx  " "             xxxxxxx      xxxx xxxxxxx  " "              xxxxx       xxx   xxxxxxx " "xxxxxxxxxxxxxxxxxxxxxxxx   xxx xxxxxxxx " "xxxxxxxxxxxxxxxxxxxxxxxx   xxxxxxxxxxxx " "                 xx         xxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxx         xxxx xxxxxxx" " xxxxxxxxxxxxxxxx x          xx   xxxxxx" "  xxxx         xx xx         xxx xxxxxxx" "    xxxx       xx  x          xxxxxxxxxx" "      xxxxxxxxxxxxxxxxxxxxx   xxxxxxxxxx" "      xxxxxxxxxxxxxxxxxxxxx   xxxxxxxxxx" "      xxxxx    xx   xx        xxx xxxxxx" "        xxxxxxxxxxxxxxxxx     xx   xxxxx" "         xxxxxxxxxxxxxxx      xxx xxxxxx" "           xxxxx      xx      xxxxxxxxx " "             xxxxx    xx      xxxxxxxx  " "              xxxxx   xx      xxxxxxx   " "              xxxxxx  xxx    xxxxxxx    " "               xxxxxx xxx    xxxxxx     " "               xx xxx xxxx   xxxxx      " "               xx  xxxxx xx xxxxx       " "               xx   xxxx  xxxxxx        " "                     xxx   xxxx         " "                      xx   xxx          " "                      xx    x           " "                      xx    x           "))) (make-problem "19991008-LLO (47)" (quote ((6 6 2) (16 1 1) (18 1 4) (5 12 6) (5 14 4) (1 4 15 2) (3 4 15 1 1) (5 4 4 1 1 2) (3 4 2 2 1 3) (2 2 5 1 9 1 1 4) (1 6 3 3 4 1) (1 4 3 2 3 1) (3 2 1 3 2 2 2 1) (5 2 1 2 1 1 2 1 1 2) (4 1 1 2 1 1 2 1 3) (5 4 2 1 2 1 2 1 4) (6 2 3 1 3 4 1) (1 3 1 5 1 1 5 3 1) (5 5 2 5 2 1) (3 2 14 1 2) (4 2 4 4 4 1 3) (8 4 4 1 4) (4 2 12 4 1) (1 3 2 10 3 1) (8 10 2 1) (3 1 2 8 1 2) (4 1 2 6 1 3) (7 1 4) (1 6 1 6 1) (3 1 3 8 1) (3 1 1 1 3 3 4) (7 3 2 2 1) (9 3 2 1 2 1 2) (4 2 2 7 4 4 1 4) (1 3 2 3 7 1 1 2 1 1 1 1) (8 3 1 1 1 1 1) (7 3 2 2 3 1 1 1 3) (8 7 5 1 1 1 1 2 1) (3 8 1 1 1 1 1 1 1) (3 6 6 9))) (quote ((1 1 5 5 5 4 2) (4 5 5 4 5 5) (4 30) (4 7 5 3 10) (1 1 1 5 1 3 3 2 4) (1 5 1 3 4 3) (7 1 6 3 7) (10 2 1 4 3 1 2 1) (13 2 1 2 1 3 2) (13 2 1 2 2 2) (5 3 2 1 1 2) (4 4 1 1 1) (3 6 7 1) (3 4 1 7 3 2) (8 2 7 5 3) (7 1 4 8 3 3 3) (6 2 2 9 2 2 2) (7 1 1 2 6 2 2 2) (7 1 1 2 2 8 2 2) (7 1 1 3 8 2 2) (7 1 1 1 3 9 3 3) (7 1 1 1 2 6 3 5) (7 1 2 2 6 2 3) (6 1 3 9 2 3) (5 2 8 2 2 1) (4 2 7 2 1 1) (2 3 7 7) (2 6 1) (8) (2) (2) (8) (2 20 1 1) (1 2 1 3 3 3 12) (1 4 3 3 3 1 1) (1 4 3 3 3 1 1 1) (4 4 3 3 2 2 3) (2 20 2 2 1) (2 1 1) (7))) (quote #f)) (make-problem "19991011-VAL (48)" (quote ((2) (2) (10) (16) (18) (18) (1 1) (3 6 3) (2 1 2 2 1 2) (1 2 4 2 1) (1 1 6 1 1) (1 6 1) (1 6 1) (1 4 1) (1 1) (3 6 3) (2 1 2 2 1 2) (1 2 4 2 1) (1 1 1 1 1 1) (1 1 1 1) (1 1 1 1) (1 4 1) (1 1) (3 6 3) (2 1 2 2 1 2) (1 2 4 2 1) (1 1 1 1 1 1) (1 1 1 1) (1 1 1 1) (1 4 1) (1 1) (1 1) (18) () () (4 5 4 4) (1 1 1 1 1 1) (4 1 1 1 4) (1 1 1 1 1) (4 1 4 1))) (quote (() () () () () () () (1 1 1) (1 1 1) (1 1 1) (1 1 1 3 1) (29 1 1 1) (3 1 1 1 1) (3 1 1 3) (3 1) (4 2 2 2 1 1) (4 2 2 2 1 1) (4 2 3 2 3 2 3 1 5) (4 1 5 1 1 1 1 1 1 1 1) (6 1 5 1 1 1 1 1 1 1 1) (6 1 5 1 1 1 1 1 1 1) (4 1 5 1 1 1 1 1 1 1 5) (4 2 3 2 3 2 3 1 1 1) (4 2 2 2 1 1 1) (4 2 2 2 1 5) (3 1) (3 1 5) (3 1 1 1) (29 1 1) (1 1 1 3) (1 1 1) (1 1 1) (1 1 1) () () () () () () ())) (quote #f)) (make-problem "19991103-BDH (49)" (quote ((12 23) (11 22) (10 21) (10 20) (9 20) (10 18) (10 11) (11 10) (12 10) (14 5 4) (14 4 4) (9 3 5 4 5) (9 1 9 4) (10 2 1 2) (11 3 7 1) (11 4 9 1) (10 5 9 1) (9 5 10) (8 7 10) (8 8 9) (8 1 5 2 9) (8 2 4 1 1 9) (8 3 4 1 2 10) (8 4 3 2 2 10) (8 5 3 2 2 10) (8 2 2 3 2 3 10) (9 2 1 5 4 10) (9 2 2 3 5 10) (10 2 2 6 10) (10 3 11 11) (11 11 11) (10 15 1 11) (8 13 1 11) (8 5 1 11) (9 3 3 2 1 11) (10 5 2 1 11) (19 2 2 11) (20 2 2 12) (21 4 13) (22 14))) (quote ((40) (40) (40) (40) (40) (40) (40) (40) (18 6 6) (4 6 4 5 4 1 5) (2 5 2 7 1 3 4) (1 4 7 4 4) (3 1 2 2 4 4) (2 1 2 1 3 5) (1 5 2 6) (1 2 3 6) (1 7 4 6) (1 1 10 4 5) (2 1 11 4 1 4) (3 1 12 4 2 3) (5 1 12 4 2 2) (5 1 2 3 4 2 1) (6 1 2 2 4 2) (6 1 2 2 4 1) (6 2 6 5 1) (6 2 2 6 2) (6 2 5 2 1) (6 2 7 6 2) (6 1 2 8 3) (7 3 11) (11 5 18) (11 26) (11 26) (11 26) (10 26) (9 1 25) (13 25) (13 24) (14 23) (40))) (quote ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxx        xxxxxx  xxxxxx" "xxxx xxxxxx  xxxx   xxxxx   xxxx x xxxxx" "xx     xxxxx  xx     xxxxxxx  x xxx xxxx" "x       xxxx          xxxxxxx  xxxx xxxx" "         xxx x         xx   xx xxxx xxxx" "         xx  x          xx   x xxx xxxxx" "            x            xxxxx xx xxxxxx" "           x               xx xxx xxxxxx" "           x  xxxxxxx        xxxx xxxxxx" "x          x xxxxxxxxxx      xxxx  xxxxx" "xx         x  xxxxxxxxxxx    xxxx x xxxx" "xxx        x   xxxxxxxxxxxx  xxxx xx xxx" "xxxxx       x   xxxxxxxxxxxx xxxx  xx xx" "xxxxx       x     xx     xxx xxxx   xx x" "xxxxxx      x     xx      xx xxxx    xx " "xxxxxx      x      xx    xx xxxx      x " "xxxxxx     xx       xxxxxx xxxxx      x " "xxxxxx     xx          xx xxxxxx     xx " "xxxxxx     xx            xxxxx      xx x" "xxxxxx     xx         xxxxxxx  xxxxxx xx" "xxxxxx      x xx     xxxxxxxx        xxx" "xxxxxxx       xxx            xxxxxxxxxxx" "xxxxxxxxxxx   xxxxx   xxxxxxxxxxxxxxxxxx" "xxxxxxxxxxx   xxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxx   xxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxx   xxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxx    xxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxx  x   xxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxx  xxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxx   xxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxx   xxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"))) (make-problem "19991109-TMA (50)" (quote ((35) (1 1 1 1 17) (1 4 2 1 4 20) (1 1 1 1 2 1 16 2) (1 2 1 1 2 4 2 19) (1 1 2 1 1 20) (40) (1 20) (40) (14 1 1 1 1 1 1) (14 1 1 1 2 1 2 1 2 1 4) (14 3 1 2 1 2 1 1 2) (14 3 1 2 1 2 1 1 2 4) (7 6 3 1 1 1 2 1 1) (7 32) (6 5 1) (1 1 1 1 1 26) (2 6 1 4 1 2) (1 8 1 6 1 1 1 2) (3 9 2 1 1 1 2) (4 10 4 6 3 2) (1 2 2 1 6 2 4 1 2) (1 1 1 26) (4 2) (1 26) (2 6 2 2 1 3) (3 1 11) (7 9 1 1 3 1 1 2) (7 8 1 1 2 7 3) (7 7 2 2 3 5 4) (13 1 3 3 5) (11 11 1 5) (9 4 1 1 6 5) (7 2 3 1 1 1 10 3) (5 4 2 1 6 2 2) (4 5 5 3 5 2 1) (2 3 4 1 5 3) (1 20 3) () (6 22 5))) (quote ((21 1 2 11 1) (1 1 8 1 3 1 10 1) (1 3 1 9 2 9 1) (1 1 1 1 8 2 9 1) (1 1 1 9 2 8 1) (7 8 7 1) (1 1 7 7) (1 1 3 5 3) (1 1 2 7 6) (1 1 1 8 5 1 1) (7 9 2 5 4 1) (1 1 8 2 4 4 1) (1 1 1 1 9 2 4 5 1) (1 1 1 1 8 1 3 1 3 3 1 1) (1 3 1 1 1 5 1 2 3 1 2 1) (7 1 5 13 3 3 1) (1 1 2 4 12 8 1) (1 3 1 1 5 11 2 7 1) (1 1 1 1 1 1 10 1 1 1 1 1) (1 1 1 7 1 5 1 1 1 1 1 1) (9 1 1 5 1 1 1 1) (9 3 1 1 1 1 2 1 7 1) (9 3 1 1 4 6 1 1 1 1) (9 1 7 1 1 1 1 1 1) (15 1 1 1 2 3 1 1 1) (9 1 1 1 1 1 3 10 1) (9 3 1 1 1 1 1 2 2 5 1) (9 3 1 7 1 3 1 5 1) (9 1 3 3 1 4 7 1) (15 3 3 1 1 3 6 1) (9 1 7 1 1 3 3 1) (9 1 3 1 1 1 3 3 2) (9 1 2 1 1 1 1 1 4 2) (9 1 1 1 1 1 1 1 2) (15 7 4 1) (8 1 1 1 1 3 3 1 1) (2 5 1 1 1 1 1 1 1 2 4 4 1) (6 1 1 1 1 1 1 6 3 1) (6 3 1 9 8 2 1) (20 9 1))) (quote ("xxxxxxxxxxxxxxxxxxxxx x xx xxxxxxxxxxx x" "x     x xxxxxxxx x xxx   x xxxxxxxxxx  x" "x xxx x xxxxxxxxx  xx      xxxxxxxxx   x" "x x x x xxxxxxxx    xx     xxxxxxxxx   x" "x x   x xxxxxxxxx    xx    xxxxxxxx    x" "xxxxxxx xxxxxxxx           xxxxxxx     x" "x     x xxxxxxx            xxxxxxx      " "x x xxx xxxxx                 xxx       " "x x  xx xxxxxxx            xxxxxx       " "x   x x xxxxxxxx           xxxxx   x   x" "xxxxxxx xxxxxxxxx    xx    xxxxx  xxxx x" "x     x xxxxxxxx    xx     xxxx   xxxx x" "x x x x xxxxxxxxx  xx      xxxx  xxxxx x" "x x x x xxxxxxxx x xxx   x xxx   xxx x x" "x xxx x x     x xxxxx x xx xxx  x   xx x" "xxxxxxx x xxxxx xxxxxxxxxxxxx  xxx xxx x" "x     x xx xxxx xxxxxxxxxxxx  xxxxxxxx x" "x xxx x x xxxxx xxxxxxxxxxx xx xxxxxxx x" "x x x x x     x xxxxxxxxxx   x x   x x x" "x x   x xxxxxxx x xxxxx x      x x x x x" "xxxxxxxxx     x x xxxxx x      x     x x" "xxxxxxxxx xxx x x x   x xx   x xxxxxxx x" "xxxxxxxxx xxx x x  xxxx xxxxxx x   x x x" "xxxxxxxxx     x xxxxxxx x      x x x x x" "xxxxxxxxxxxxxxx x   x x xx xxx x     x x" "xxxxxxxxx     x x x x x xxx xxxxxxxxxx x" "xxxxxxxxx xxx x x x   x x xx xx  xxxxx x" "xxxxxxxxx xxx x xxxxxxx x xxx x  xxxxx x" "xxxxxxxxx     x xxx xxx x xxxx xxxxxxx x" "xxxxxxxxxxxxxxx xxx xxx x x xxx xxxxxx x" "xxxxxxxxx     x xxxxxxx x x xxx xxx    x" "xxxxxxxxx x xxx x   x x xxx xxx xx      " "xxxxxxxxx x  xx x x x x x xxxx  xx      " "xxxxxxxxx   x x x     x x x x   xx      " "xxxxxxxxxxxxxxx xxxxxxx xxxx     x      " " xxxxxxxx     x x   x x xxx   xxx x    x" " xx xxxxx x x x x x x x xx   xxxx xxxx x" "   xxxxxx x x x x     x x   xxxxxx xxx x" "   xxxxxx xxx x xxxxxxxxx  xxxxxxxx xx x" "     xxxxxxxxxxxxxxxxxxxx  xxxxxxxxx   x"))) (make-problem "19991118-CIT (51)" (quote ((24 15) (1 17 15) (1 12 3 3 10) (3 8 3 1 1 1 1 3 4) (3 9 1 2 1 1 1 1 2 1 5) (3 10 3 1 1 1 1 3 6) (3 9 1 2 1 1 1 1 2 1 5) (13 3 1 1 1 1 3 4) (1 12 3 3 10) (1 5 3) (3 7 3) (3 14 3 3 10) (1 6 1 1 1 1 3 4) (1 6 3 1 1 1 1 1 2 1 5) (13 3 1 1 1 1 1 3 6) (1 6 3 1 1 1 1 1 2 1 5) (1 6 1 1 1 1 3 4) (1 16 3 3 10) (1 9 3) (1 5 3) (1 12 3 3 10) (13 3 1 1 1 1 4) (14 1 2 1 1 1 1 1 3 4) (15 3 1 1 1 1 1 3 4) (14 1 2 1 1 1 1 1 3 4) (1 6 3 1 1 1 1 4) (1 12 3 3 10) (3 19 15) (3 35) (3 35) (3 35) (40) (1 1 4 1 1 2) (1 1 4 1 1 6) (1 2 1 10 3 2 1 3) (1 1 10 3 2 1 3) (1 1 6 3 1 6) (1 2 1 6 3 1 2) (40) (40))) (quote ((40) (1 5 2 1 4 5 2) (1 5 2 1 4 5 2) (1 1 1 2 4 1 1 3) (1 1 1 2 4 1 1 3) (1 5 2 1 2 4 5 2) (1 5 2 1 2 4 5 2) (40) (32 2) (32 2) (32 2 2) (32 2 2) (9 7 12 2 2) (3 3 1 1 1 1 3 6 2 2) (4 1 2 1 3 1 2 1 15) (5 3 1 3 1 3 16) (4 1 2 1 3 1 2 1 15) (3 3 1 1 1 1 3 14) (9 7 12 6) (2 5 6) (2 5 2) (9 7 12 2) (3 1 1 1 1 6 6) (3 3 1 1 3 1 1 3 6 6) (12) (3 3 1 1 3 1 1 3 6 2) (3 1 1 1 1 6 2) (9 7 12 2 2) (2 5 2 2) (2 5 2) (9 7 12 2) (3 3 1 1 3 1 1 14) (4 1 2 2 1 2 1 3 6 2) (5 3 3 3 1 3 6 2) (4 1 2 2 1 2 1 3 6 1 1 2) (3 3 1 1 3 1 1 6 1 1 2) (9 7 12 1 1 2) (32 4 2) (40) (40))) (quote ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "x  xxxxx  xx  x      xxxx  xxxxx      xx" "x  xxxxx  xx  x      xxxx  xxxxx      xx" "x      x      x  xx  xxxx      x  x  xxx" "x      x      x  xx  xxxx      x  x  xxx" "x  xxxxx  xx  x  xx  xxxx  xxxxx      xx" "x  xxxxx  xx  x  xx  xxxx  xxxxx      xx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx      xx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx      xx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx  xx  xx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx  xx  xx" "xxxxxxxxx  xxxxxxx  xxxxxxxxxxxx  xx  xx" "xxx xxx x  x     x  x xxx xxxxxx  xx  xx" "xxxx x xx  x xxx x  xx x xxxxxxxxxxxxxxx" "xxxxx xxx  x xxx x  xxx xxxxxxxxxxxxxxxx" "xxxx x xx  x xxx x  xx x xxxxxxxxxxxxxxx" "xxx xxx x  x     x  x xxx xxxxxxxxxxxxxx" "xxxxxxxxx  xxxxxxx  xxxxxxxxxxxx  xxxxxx" "xx                         xxxxx  xxxxxx" "xx                         xxxxx      xx" "xxxxxxxxx  xxxxxxx  xxxxxxxxxxxx      xx" "xxx     x  x     x  x     xxxxxx  xxxxxx" "xxx xxx x  x xxx x  x xxx xxxxxx  xxxxxx" "                            xxxxxxxxxxxx" "xxx xxx x  x xxx x  x xxx xxxxxx      xx" "xxx     x  x     x  x     xxxxxx      xx" "xxxxxxxxx  xxxxxxx  xxxxxxxxxxxx  xx  xx" "xx                         xxxxx  xx  xx" "xx                         xxxxx      xx" "xxxxxxxxx  xxxxxxx  xxxxxxxxxxxx      xx" "xxx xxx x  x xxx x  x     xxxxxxxxxxxxxx" "xxxx x xx  xx x xx  x xxx xxxxxx      xx" "xxxxx xxx  xxx xxx  x xxx xxxxxx      xx" "xxxx x xx  xx x xx  x xxx xxxxxx x  x xx" "xxx xxx x  x xxx x  x     xxxxxx x  x xx" "xxxxxxxxx  xxxxxxx  xxxxxxxxxxxx x  x xx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx xxxx xx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"))) (make-problem "19991119aKHO (52)" (quote ((19 5 8) (11 3 3 7) (10 2 1 5 1 5 6) (9 3 2 2 1 1 2 6) (9 1 2 2 2 2 2 6) (9 2 4 2 2 2 3 7) (5 4 3 2 2 2 3 1 4) (4 4 4 2 2 2 2 2 3) (3 2 2 4 2 1 1 1 2 3 3) (3 2 3 3 1 1 1 3 4 2) (3 4 4 3 1 1 2 4 2 1) (4 4 3 2 1 2 4 4 1) (2 1 4 13 3 2 2 1) (1 5 6 3 5 1) (2 5 1 1 1 2 4 2) (2 3 1 1 3 3 1 1 5 1) (2 5 1 2 2 2 3 1) (1 5 1 1 2 2 1 2 2) (2 4 2 3 1 1 2 3) (2 5 1 1 1 1 1 2 3) (1 4 1 2 2 1 2 1 2 3) (1 3 1 1 2 1 3 2) (1 3 1 3 1 2 1 1 4 2) (4 2 2 1 1 1 5 2) (1 2 2 2 3 2 6 2) (2 1 2 2 3 2 2 2 4 2) (5 1 3 3 2 1 1 1 2 2) (6 1 1 2 3 2 2 2 2 2) (8 2 2 2 2 2 2 4 2) (7 3 3 1 1 1 5 2) (7 2 4 1 2 1 2 6 2) (8 1 3 3 2 2 2 8 2) (9 3 3 2 2 1 9 3) (9 2 1 2 3 1 9 3) (10 1 3 2 2 3 4) (13 2 1 2 3 1 5) (14 5 3 12) (22 3 11) (22 3 9) (21 1 1 1 8))) (quote ((14 4 16) (13 2 15) (12 3 14) (8 1 5 5 14) (7 1 1 2 2 14) (6 3 2 1 2 1 1 13) (6 5 2 2 2 2 12) (6 1 2 2 2 1 2 1 9) (6 1 2 1 1 2 2 2 2 8) (3 3 2 1 1 1 2 3 5 6) (2 2 3 1 1 1 2 2 2 2 5) (1 4 2 1 1 2 1 3 4 5) (1 1 3 1 2 2 2 4 5 6) (1 2 3 2 1 1 1 2 1 4 1 4) (1 4 3 4 2 1 3 2 2 3) (2 3 2 3 5 5 3) (3 3 2 2 1 1 2 2 5 4) (2 4 1 2 2 1 1 3 2 5) (1 2 5 2 6 2 4) (6 2 3 5 4) (1 6 1 1 2 2 4 5) (1 2 2 1 1 2 4 1 2) (1 6 1 1 1 2 3 4) (6 1 1 1 2 1 1) (1 2 2 1 3 4) (2 7 2 2 2 2 2 5) (4 3 2 1 1 1 1 1 1 1 2 1 1 3) (2 2 2 1 3 1 2 1) (1 3 3 3 1 1 1 3 1 1) (1 3 4 2 2 1 6 3) (1 2 4 1 1 1 8 2) (4 4 3 1 8 3) (1 3 1 3 5 2 7 4) (2 1 2 4 5 6 4) (6 15 4 4) (6 2 15 2 5) (7 7 6 6) (9 3 1 3 8) (10 1 24) (16 23))) (quote #f)) (make-problem "19991202-DAN (53)" (quote ((13) (27) (18 21) (18 21) (4 8 4 2 12 5) (4 3 2 4 2 10 5) (4 1 1 4 2 6 6) (4 5 3 6) (4 6 4 7) (4 6 4 7) (5 7 4 6) (5 2 4 3 2 2 5) (11 3 3 1 1 4) (6 2 3 2 3) (6 1 4 2 3 3) (6 5 2 1 4) (5 6 3 1 5) (4 11 4 1 1 1 6) (4 11 5 3 7) (1 4 7) (4 11) (4 12 4 7) (5 12 4 6) (5 12 4 6) (5 11 3 6) (5 11 3 5) (5 11 3 5) (5 11 2 4) (5 10 2 3) (6 10 2 3) (5 10 1 3) (5 10 3) (5 10 3) (3 5 3) (3 4 3) (3 4 3) (4 5 3) (4 4 3) (5 5 3) (5 5 3))) (quote ((15) (28) (17 20) (17 20) (2 9 20) (3 4 11 4) (4 1 4 2) (5 1 2 4) (4 3 2 8) (3 2 2 13) (5 2 2 13) (4 2 2 13 2) (3 3 3 13 4) (3 4 4 20) (11 5 20) (18 20) (18 17) (18 14) (1 12) (18) (19 10) (3 6 4 9) (4 3 3 6) (5 2 3) (5) (6 2) (6 1 1) (7 1 1) (7 5) (7 1 1) (7 1 1) (6 2) (6 2 1) (5 2 3 4) (4 5 4 7) (12 5 19) (20 19) (20 19) (20 6) (13))) (quote ("  xxxxxxxxxxxxxxx                       " "  xxxxxxxxxxxxxxxxxxxxxxxxxxxx          " "  xxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxxxxxx" "  xxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxxxxxx" "  xx      xxxxxxxxx xxxxxxxxxxxxxxxxxxxx" "  xxx       xxxx      xxxxxxxxxxx   xxxx" "  xxxx      x                xxxx     xx" "  xxxxx     x    xx xxxx                " "  xxxx      xxx  xx xxxxxxxx            " "  xxx       xx   xx xxxxxxxxxxxxx       " "  xxxxx    xx    xx xxxxxxxxxxxxx       " "  xxxx    xx     xx xxxxxxxxxxxxx     xx" "  xxx   xxx     xxx xxxxxxxxxxxxx   xxxx" " xxx   xxxx    xxxx xxxxxxxxxxxxxxxxxxxx" " xxxxxxxxxxx  xxxxx xxxxxxxxxxxxxxxxxxxx" " xxxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxxxxxx" " xxxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxxx   " " xxxxxxxxxxxxxxxxxx xxxxxxxxxxxxxx      " " x                   xxxxxxxxxxxx       " " xxxxxxxxxxxxxxxxxx                     " " xxxxxxxxxxxxxxxxxxx xxxxxxxxxx         " " xxx   xxxxxx   xxxx xxxxxxxxx          " " xxxx   xxx      xxx xxxxxx             " " xxxxx            xx xxx                " " xxxxx                                  " " xxxxxx    xx                           " " xxxxxx    x     x                      " "xxxxxxx       x   x                     " "xxxxxxx       xxxxx                     " "xxxxxxx       x   x                     " "xxxxxxx    x     x                      " "xxxxxx     xx                           " "xxxxxx            xx x                  " "xxxxx   xx       xxx xxxx               " "xxxx  xxxxx     xxxx xxxxxxx            " "xxxxxxxxxxxx   xxxxx xxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxxxxx" "xxxxxxxxxxxxxxxxxxxx xxxxxx             " "xxxxxxxxxxxxx                           "))) (make-problem "19991203-DAN (54)" (quote ((3 3 1 1 4) (1 1 1 2 1 1 1) (1 1 1 1 1 1 1 1 3) (1 1 1 1 2 1 1) (3 3 1 1 4) (5) (4 2 1 1 3 7) (1 1 1 1 1 1 1 2 6) (3 1 1 1 1 3 11) (1 4 1 1 1 1 11) (3 1 1 4 1 1 11) (6) (19 7) (6) (7) (7) (6) (7) (6) (10 6) (14 5) (16 5) (18 5) (26) (25) (25) (24) (24) (23) (24) (23) (22) (5 4 4) (5 4 4) (5 4 4) (6 4 4) (7 4 4) (8 4 4) (7 4 4) ())) (quote ((5 2 1 1 1) (1 1 1 1 1 1 2) (1 1 1 1 1 1 2) (3 1 2 1 3) (1 3) (1 1 4 1 4) (5 1 1 1 4) (1 1 1 1 1 4) (4 1 5) (5 1 6) (1 5 1 7) (1 1 1 8) (1 1 1 11) (5 5 1 11) (1 11) (5 5 1 17) (1 1 1 1 1 19) (1 1 1 1 1 20) (5 1 2 1 20) (13 2) (1 13) (1 13) (1 13) (2 13) (4 13) (5 18) (2 3 20) (6 19) (6 19) (8 11 2) (11 10) (12 8) (13 8) (22) (18) (15) (12) (7) () ())) (quote #f)))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/problems/misc b/collects/games/paint-by-numbers/problems/misc
new file mode 100644
index 0000000000..771c52a5ba
--- /dev/null
+++ b/collects/games/paint-by-numbers/problems/misc
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Misc") (define problems (list (make-problem "Happy Happy Joy Joy" (quote ((5) (9) (2 7) (4 8) (4 7) (6 7) (7 7) (7 6) (7 5) (5 1 4) (4 2 3) (2 4 1) (9) (5))) (quote ((4) (8) (10) (12) (1 8 1) (2 5 2) (4 3 3) (5 4) (7 5) (8 3) (9 1) (10 1) (10) (8) (4))) (quote ("     xxxx     " "   xxxxxxxx   " "  xxxxxxxxxx  " " xxxxxxxxxxxx " " x xxxxxxxx x " "xx   xxxxx  xx" "xxxx  xxx  xxx" "xxxxx     xxxx" "xxxxxxx  xxxxx" "xxxxxxxx   xxx" " xxxxxxxxx  x " " xxxxxxxxxx x " "  xxxxxxxxxx  " "   xxxxxxxx   " "     xxxx     "))) (make-problem "Solver Breaker" (quote ((1) (2 2) (1) (2) (2 2) (1))) (quote ((1) (2 2) (1 1) (1) (2 2) (1))) (quote ("UUUUUU" "UUUUUU" "UUUUUU" "UUUUUU" "UUUUUU" "UUUUUU"))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/raw-problems/allowed-email b/collects/games/paint-by-numbers/raw-problems/allowed-email
new file mode 100644
index 0000000000..9b0d68596f
--- /dev/null
+++ b/collects/games/paint-by-numbers/raw-problems/allowed-email
@@ -0,0 +1,61 @@
+; -*- Scheme -*-
+
+("snordmey@dayton.net"
+ "jtraub@dragoncat.net"
+ ("snicker@tmbg.org" "e0gb258s@mail.erin.utoronto.ca")
+ "mattingly@bigfoot.com"
+ "jennifer.forman@umb.edu"
+ "karen.hoover@bigfoot.com"
+ "sssstree@ix.netcom.com"
+ "we_bakers_3@earthlink.net"
+ "bbart@cs.sfu.ca"
+ "jonesjk@thegrid.net"
+ "rrichard@lexitech.ca"
+ "helena.montauban@auroraenergy.com.au"
+ "barblane@ionsys.com"
+ ("rman@mishkei.org.il" "m5rammy@maale5.com")
+ "nmbauer@sprynet.com"
+ "ncfrench@aol.com"
+ ("blumbergk@auhs.edu" "km29@drexel.edu")
+ "jjl@stanford.edu"
+ "disneyfan13@hotmail.com"
+ "adjusting@yahoo.com"
+ "richard@condor-post.com"
+ "lady_tabitha@yahoo.com"
+ "vaa@psulias.psu.edu"
+ "kimbhall@yahoo.com"
+ "kcottam@cusa.com"
+ "karganov@hotmail.com"
+ "jdmaynard@excite.com"
+ "mnemoy@gameworks.com"
+ "arrelless@jayco.net"
+ "azisi@skiathos.physics.auth.gr"
+ "whoaleo@hotmail.com"
+ "tucker1999@earthlink.net"
+ "bergles@yahoo.com"
+ "elisabeth.springfelter@lanab.amv.se"
+ "ewhaynes@mit.edu"
+ "mjcarroll@ccnmail.com"
+ ("dahu@chez.com" "dahu@netcourrier.com")
+ "joy@dcs.gla.ac.uk"
+ "piobst@wam.umd.edu"
+ "dani681@aol.com"
+ ("pixel@bga.com" "Talzhemir pixel@realtime.net")
+ "hkittredge@hotmail.com"
+ "allraft@sccoast.net"
+ "karlvonl@geocities.com"
+ ("ailsa@worldonline.nl" "alisa@euronet.nl")
+ ("nievmelody@aol.com" "Carey Willis N8NRG@hotmail.com")
+ "citragreen@hotmail.com"
+ "dhalayko@cgocable.net"
+ "jontive1@elp.rr.com"
+ "hublan@rocketmail.com"
+ "barbridgway@compuserve.com"
+ "mijoy@mailcity.com"
+ "joostdh@sci.kun.nl"
+ ("steven.paradise@m.cc.utah.edu" "gossamer_kwaj@hotmail.com")
+ "williamson@proaxis.com"
+ "vacko_6@hotmail.com"
+ "jojess@earthlink.net"
+
+ )
diff --git a/collects/games/paint-by-numbers/raw-problems/build-final.ss b/collects/games/paint-by-numbers/raw-problems/build-final.ss
new file mode 100644
index 0000000000..a7d801e3af
--- /dev/null
+++ b/collects/games/paint-by-numbers/raw-problems/build-final.ss
@@ -0,0 +1,71 @@
+#!/bin/sh
+#| 
+exec mzscheme -qr $0 "$@"
+
+This script constructs the contents of the problems directory
+from the solutions directory. This process merely consists of
+reading in each file in the solutions directory (based on the 
+directory file) and rewriting it into the format described
+in ...
+
+|#         
+
+(require (lib "match.ss"))
+
+;; shrink-file : string -> string
+(define (shrink-file filename)
+  (printf "shrinking ~a..." filename)
+  (flush-output)
+  (let ([shrunk (shrink-set (call-with-input-file (build-path 'up "solution-sets" filename) read))])
+    (call-with-output-file (build-path 'up "problems" filename)
+      (lambda (port)
+        (write shrunk port))))
+  (printf "done\n"))
+
+;; shrink-set sexp[set] -> sexp[set]
+(define (shrink-set set)
+  (match set
+    [`(unit/sig paint-by-numbers:problem-set^
+        (import paint-by-numbers:problem^)
+        
+        (define set-name ,set-name)
+        
+        (define problems (list ,@problems)))
+     `(unit/sig paint-by-numbers:problem-set^
+        (import paint-by-numbers:problem^)
+        
+        (define set-name ,set-name)
+        
+        (define problems (list ,@(map shrink-problem problems))))]))
+     
+;; shrink-problem : sexp[problem] -> sexp[problem]
+(define (shrink-problem problem)
+  (match problem
+    [`(make-problem ,name ,rows ,cols ',solution)
+     `(make-problem ,name ,rows ,cols ',(shrink-solution solution))]))
+
+;; shrink-soution :    (union #f (vectorof (vectorof (union 'on 'off 'unknown))))
+;;                  -> (union #f (listof string))
+;; produces the data in a representation that is much smaller when written
+(define (shrink-solution soln)
+  (and soln
+       (map (lambda (line)
+              (apply string (map (lambda (x)
+                                   (case x
+                                     [(on) #\x]
+                                     [(off) #\space]
+                                     [(unknown) #\U]))
+                                 (vector->list line))))
+            (vector->list soln))))
+
+
+;; erase old contents of the solutions directory
+(for-each
+ (lambda (file) (when (file-exists? (build-path 'up "problems" file))
+                  (delete-file (build-path 'up "problems" file))))
+ (directory-list (build-path 'up "problems")))
+
+(copy-file (build-path 'up "solution-sets" "directory")
+           (build-path 'up "problems" "directory"))
+
+(for-each shrink-file (call-with-input-file (build-path 'up "problems" "directory") read))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/raw-problems/build-hattori.ss b/collects/games/paint-by-numbers/raw-problems/build-hattori.ss
new file mode 100644
index 0000000000..ad6917ec56
--- /dev/null
+++ b/collects/games/paint-by-numbers/raw-problems/build-hattori.ss
@@ -0,0 +1,175 @@
+#!/bin/sh
+
+string=? ; exec mred -qmvr $0
+
+;;; these come from:
+;;; http://www.ask.ne.jp/~hattori/puzzle/menu.html
+;;; We must cite him in the game somewhere...
+
+(require-library "pretty.ss")
+(require-library "errortrace.ss" "errortrace")
+
+(define pixel-size 10)
+
+(define (main n)
+  (let ([grid (calculate-grid (build-path "hattori" (format "~a.gif" n)))])
+    (display-grid grid)
+    (pretty-print
+     (build-problem 
+      n grid))
+    (newline)
+    (newline (current-error-port))
+    (newline (current-error-port))))
+
+(define (calculate-grid filename)
+  (fprintf (current-error-port) "reading ~a~n" filename)
+  (let* ([bitmap (make-object bitmap% filename)]
+	 [_ (unless (send bitmap ok?)
+	      (error 'bad-bitmap "name: ~a" filename))]
+	 [bitmap-dc (make-object bitmap-dc% bitmap)]
+	 [raw-width (send bitmap get-width)]
+	 [raw-height (send bitmap get-height)]
+	 [image-width raw-width]
+	 [image-height (get-puzzle-height bitmap-dc raw-height)]
+	 [grid-x-start (get-grid-start bitmap-dc #t)]
+	 [grid-y-start (get-grid-start bitmap-dc #f)]
+	 [puzzle-width (- image-width grid-x-start)]
+	 [puzzle-height (- image-height grid-y-start)]
+	 [new-bitmap-width (floor (/ (- puzzle-width 1) pixel-size))]
+	 [new-bitmap-height (floor (/ (- puzzle-height 1) pixel-size))])
+
+    (begin
+    (fprintf (current-error-port) "size of picture: ~a x ~a~n" raw-width raw-height)
+    (fprintf (current-error-port) "  size of image: ~a x ~a~n" image-width image-height)
+    (fprintf (current-error-port) "grid-start (~a, ~a)~n" grid-x-start grid-y-start)
+    (fprintf (current-error-port) "size of puzzle: ~a x ~a~n"
+	    puzzle-width
+	    puzzle-height))
+    (reverse
+     (let loop ([j new-bitmap-height])
+       (cond
+	[(zero? j) null]
+	[else
+	 (cons
+	  (reverse
+	   (let loop ([i new-bitmap-width])
+	     (cond
+	      [(zero? i) null]
+	      [else
+	       (let ([pixel-value
+		      (if (black-pixel?
+			   bitmap-dc
+			   (floor
+			    (+ grid-x-start
+			       (* pixel-size (+ i -1 1/2))))
+			   (floor
+			    (+ grid-y-start
+			       (* pixel-size (+ j -1 1/2)))))
+			  'x
+			  'o)])
+		 ;(fprintf (current-error-port) "(~a, ~a) is ~a~n" i j pixel-value)
+		 (cons pixel-value
+		       (loop (- i 1))))])))
+	  (loop (- j 1)))])))))
+
+(define (display-grid grid)
+  (display "+" (current-error-port))
+  (for-each (lambda (x) (display "-" (current-error-port))) (car grid))
+  (display "+" (current-error-port))
+  (newline (current-error-port))
+
+  (for-each
+   (lambda (row)
+     (display "|" (current-error-port))
+     (for-each
+      (lambda (i)
+	(if (eq? i 'x)
+	    (display "#" (current-error-port))
+	    (display " " (current-error-port))))
+      row)
+     (display "|" (current-error-port))
+     (newline (current-error-port)))
+   grid)
+  (display "+" (current-error-port))
+  (for-each (lambda (x) (display "-" (current-error-port))) (car grid))
+  (display "+" (current-error-port))
+  (newline (current-error-port)))
+
+(define tmp-color (make-object color%))
+
+(define (colored-pixel? value)
+  (lambda (bitmap-dc x y)
+    (send bitmap-dc get-pixel x y tmp-color)
+    (= value
+       (send tmp-color red)
+       (send tmp-color green)
+       (send tmp-color blue))))
+
+(define white-pixel? (colored-pixel? 255))
+(define black-pixel? (colored-pixel? 0))
+
+(define (get-puzzle-height bitmap-dc raw-height)
+  (let loop ([i raw-height])
+    (cond
+      [(white-pixel? bitmap-dc 0 (- i 1))
+       (loop (- i 1))]
+      [else i])))
+
+(define (get-grid-start bitmap-dc x?)
+  (let loop ([i 0])
+    (cond
+      [(if x?
+	   (white-pixel? bitmap-dc i 0)
+	   (white-pixel? bitmap-dc 0 i))
+       (loop (+ i 1))]
+      [else i])))
+
+
+(define (on-off->blocks l)
+  (let loop ([l l]
+	     [in? #f]
+	     [size 0])
+    (cond
+     [(null? l) (if (= size 0)
+		    null
+		    (list size))]
+     [else
+      (let ([on? (eq? (car l) 'x)])
+	(cond
+	 [(and in? on?) 
+	  (loop (cdr l)
+		on?
+		(+ size 1))]
+	 [(and in? (not on?))
+	  (cons size
+		(loop (cdr l)
+		      #f
+		      0))]
+	 [(and (not in?) on?)
+	  (loop (cdr l)
+		#t
+		1)]
+	 [(and (not in?) (not on?))
+	  (loop (cdr l)
+		#f
+		0)]))])))
+
+(define (transpose l) (apply map list l))
+
+(define (build-problem n on-off-lists)
+  (list (format "Hattori ~a" n)
+	(map on-off->blocks on-off-lists)
+	(map on-off->blocks (transpose on-off-lists))
+	on-off-lists))
+
+(call-with-output-file "raw-hattori.ss"
+  (lambda (port)
+    (parameterize ([current-output-port port])
+      (printf "`(~n")
+      (let loop ([n 1])
+	(when (<= n 139)
+	  (main n)
+	  (loop (+ n 1))))
+      (printf ")")))
+  'text
+  'truncate)
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/raw-problems/build-kajitani.ss b/collects/games/paint-by-numbers/raw-problems/build-kajitani.ss
new file mode 100644
index 0000000000..5412ae9e04
--- /dev/null
+++ b/collects/games/paint-by-numbers/raw-problems/build-kajitani.ss
@@ -0,0 +1,107 @@
+#!/bin/sh
+
+string=? ; exec mzscheme -qr $0
+
+;; this builds raw-kajitani.ss from full-kajitani
+;; raw-kajitani.ss is used in build-problems.ss
+
+(require-library "pretty.ss")
+(require-library "function.ss")
+(require-library "errortrace.ss" "errortrace")
+(require-library "string.ss")
+
+(define (make-strings-mutable sexp)
+  (cond
+   [(string? sexp) (string-copy sexp)]
+   [(cons? sexp) (cons (make-strings-mutable (car sexp))
+		       (make-strings-mutable (cdr sexp)))]
+   [else sexp]))
+
+(define raw-kajitani
+  (make-strings-mutable
+   (call-with-input-file (build-path (collection-path "games" "paint-by-numbers")
+				     "full-kajitani")
+     read)))
+
+(define allowed-emails
+  (map (lambda (x) (if (list? x) (car x) x))
+       (call-with-input-file (build-path (collection-path "games" "paint-by-numbers")
+					 "allowed-email")
+	 read)))
+
+(define counters (make-hash-table))
+
+(define email-ht (make-hash-table))
+(for-each (lambda (email) (hash-table-put! email-ht (string->symbol email) null))
+          allowed-emails)
+
+(define kajitani-sets
+  (let ([ht (make-hash-table)])
+    (for-each
+     (lambda (kaj-set)
+       (let ([email (cadddr kaj-set)])
+         (when (string? email)
+           (string-lowercase! email))
+         (when (member email allowed-emails)
+           (let ([email-sym (string->symbol email)])
+             (hash-table-put! email-ht email-sym
+                              (cons
+                               (car kaj-set)
+                               (hash-table-get email-ht email-sym))))
+           
+           (let ([tag (string->symbol (format "~ax~a" (car (car kaj-set)) (cadr (car kaj-set))))]
+                 [rows/cols (list (caddr (car kaj-set)) (cdr kaj-set))])
+             (hash-table-put!
+              ht
+              tag
+              (cons
+               rows/cols
+               (hash-table-get
+                ht
+                tag
+                (lambda ()
+                  null))))))))
+     raw-kajitani)
+    (hash-table-map ht (lambda (x l) (list x (reverse l))))))
+     
+(printf "stats by email~n")
+(let ([total 0])
+  (for-each 
+   (lambda (x)
+     (let ([k (car x)]
+	   [v (cadr x)])
+       (let ([len (length v)])
+	 (set! total (+ len total))
+	 (printf "~s ~s~n" k
+		 len
+		 ;v
+		 ))))
+   (quicksort (hash-table-map email-ht list)
+	      (lambda (x y) (> (length (cadr x)) (length (cadr y))))))
+
+  
+  (printf "total: ~s~n" total))
+
+(define (build-solutionless-kajitani kaj-set)
+  (list
+   (format "Kajitani ~a" (car kaj-set))
+   (format "k~a" (car kaj-set))
+   (map
+    (let ([n 0])
+      (lambda (kaj)
+	(set! n (+ n 1))
+	(list (format "~a (~a)" (car kaj) n)
+	      (cadr (cadr kaj))
+	      (car (cadr kaj)))))
+    (cadr kaj-set))))
+
+(call-with-output-file (build-path (collection-path "games" "paint-by-numbers")
+				   "raw-kajitani.ss")
+  (lambda (port)
+    (pretty-print
+     (quicksort
+      (map build-solutionless-kajitani kajitani-sets)
+      (lambda (s1 s2)
+	(string<=? (car s1) (car s2))))
+     port))
+  'truncate)
diff --git a/collects/games/paint-by-numbers/raw-problems/build-rows-cols.ss b/collects/games/paint-by-numbers/raw-problems/build-rows-cols.ss
new file mode 100644
index 0000000000..3c002e00ed
--- /dev/null
+++ b/collects/games/paint-by-numbers/raw-problems/build-rows-cols.ss
@@ -0,0 +1,91 @@
+#!/bin/sh
+
+string=? ; exec mred -mvgqr $0 "$@"
+
+(when (equal? (vector) argv)
+  (error 'build-rows-cols.ss
+	 "expected an image file on the command-line"))
+	 
+(define image (vector-ref argv 0))
+(fprintf (current-error-port) "processing ~a~n" image)
+
+(define bitmap (make-object bitmap% image))
+(when (send bitmap is-color?)
+  (fprintf (current-error-port)
+	   "expected a monochrome bitmap -- all non-black spaces will be considered white~n"))
+
+(newline (current-error-port))
+
+(define bitmap-dc (make-object bitmap-dc% bitmap))
+
+(define on-off-lists
+  (let ([color (make-object color%)])
+    (let loop ([i (send bitmap get-height)]
+	       [ans null])
+      (cond
+       [(zero? i) ans]
+       [else
+	(loop
+	 (- i 1)
+	 (cons
+	  (let loop ([j (send bitmap get-width)]
+		     [ans null])
+	    (cond
+	     [(zero? j) ans]
+	     [else
+	      (send bitmap-dc get-pixel (- j 1) (- i 1) color)
+	      (loop (- j 1)
+		    (cons
+		     (if (and (= 0 (send color red))
+			      (= 0 (send color blue))
+			      (= 0 (send color green)))
+			 'on
+			 'off)
+		     ans))]))
+	  ans))]))))
+
+(define (on-off->blocks l)
+  (let loop ([l l]
+	     [in? #f]
+	     [size 0])
+    (cond
+     [(null? l) (if (= size 0)
+		    null
+		    (list size))]
+     [else
+      (let ([on? (eq? (car l) 'on)])
+	(cond
+	 [(and in? on?) 
+	  (loop (cdr l)
+		on?
+		(+ size 1))]
+	 [(and in? (not on?))
+	  (cons size
+		(loop (cdr l)
+		      #f
+		      0))]
+	 [(and (not in?) on?)
+	  (loop (cdr l)
+		#t
+		1)]
+	 [(and (not in?) (not on?))
+	  (loop (cdr l)
+		#f
+		0)]))])))
+
+(define (transpose l) (apply map list l))
+
+(for-each
+ (lambda (l)
+   (for-each
+    (lambda (i) (display (if (eq? i 'on) "#" " ") (current-error-port)))
+    l)
+   (newline (current-error-port)))
+ on-off-lists)
+(newline (current-error-port))
+
+(define rows (map on-off->blocks on-off-lists))
+(define cols (map on-off->blocks (transpose on-off-lists)))
+
+(write (list image rows cols))
+(newline)
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/raw-problems/build-solution-sets.ss b/collects/games/paint-by-numbers/raw-problems/build-solution-sets.ss
new file mode 100644
index 0000000000..77f83b93a4
--- /dev/null
+++ b/collects/games/paint-by-numbers/raw-problems/build-solution-sets.ss
@@ -0,0 +1,298 @@
+#!/bin/sh
+
+string=? ; exec mred -qr $0 "$@"
+
+#|
+
+Shell script to read in the ../problems/raw-*.ss file and produce
+the files in the ../solution-sets subdirectory via John's solver. 
+
+This file must produce code that evaluates to a list of problem
+structs. The problem struct should have four fields: a string, a col,
+a row and a (union #f solution)
+
+The col and row type specs are in sig.ss and the solution type is:
+
+  (vectorof (vectorof (union 'on 'off 'unknown)))
+
+|#
+
+
+(define argv (current-command-line-arguments))
+
+(require (lib "etc.ss")
+         (lib "list.ss")
+         (lib "file.ss")
+         (lib "pretty.ss")
+         (prefix solve: "../solve.ss"))
+
+(if (eq? (vector) argv)
+    (fprintf (current-error-port) "pass any command line argument to skip the solver~n~n")
+    (fprintf (current-error-port) "skipping the solver~n"))
+
+(define memory-limit (* 1024 1024 400)) ;; in bytes (500 megs)
+
+(define memory-frame%
+  (class frame%
+    (define/override (can-close?) #f)
+    (super-instantiate ())))
+
+(define memory-frame (parameterize ([current-eventspace (make-eventspace)])
+                       (make-object memory-frame% "memory stats frame" #f 500 50)))
+(define memory-hp (make-object horizontal-panel% memory-frame))
+(define memory-vp (make-object vertical-panel% memory-hp))
+(define memory-text (make-object text%))
+(define memory-ec (make-object editor-canvas% memory-vp memory-text '(hide-hscroll hide-vscroll)))
+(define memory-gauge (make-object gauge% #f 10000 memory-vp))
+(define memory-canvas (make-object canvas% memory-hp))
+(define memory-on-bitmap (make-object bitmap% (build-path (collection-path "icons") "recycle.gif")))
+(define memory-off-bitmap (make-object bitmap%
+                            (send memory-on-bitmap get-width)
+                            (send memory-on-bitmap get-height)))
+
+(let ([memory-off-bitmap-dc (make-object bitmap-dc% memory-off-bitmap)])
+  (send memory-off-bitmap-dc clear)
+  (send memory-off-bitmap-dc set-bitmap #f))
+
+(register-collecting-blit memory-canvas 0 0
+                          (send memory-on-bitmap get-width) (send memory-on-bitmap get-height)
+                          memory-on-bitmap memory-off-bitmap)
+(send memory-canvas min-width (send memory-on-bitmap get-width))
+(send memory-canvas min-height (send memory-on-bitmap get-height))
+(send memory-canvas stretchable-width #f)
+(send memory-canvas stretchable-height #f)
+(send memory-ec set-line-count 1)
+(send memory-text hide-caret #t)
+(define (format-memory-txt use)
+  (format "~a megs (~a bytes)" (bytes->megs use) use))
+(define (bytes->megs n) (floor (/ n 1024 1024)))
+(define (update-memory-display)
+  (let ([use (current-memory-use)])
+    (send memory-text lock #f)
+    (send memory-text begin-edit-sequence)
+    (send memory-text erase)
+    (send memory-text insert (format-memory-txt use))
+    (send memory-text end-edit-sequence)
+    (send memory-text lock #t)
+    (send memory-gauge set-value (min 10000 (floor (* 10000 (/ use memory-limit)))))))
+(update-memory-display)
+(send memory-frame show #t)
+
+(define problems-dir (collection-path "games" "paint-by-numbers"))
+
+(define hattori-sets
+  (let* ([set-size 30]
+         [raw-hattori
+          (call-with-input-file (build-path problems-dir "raw-problems" "raw-hattori.ss")
+            (compose eval read))]
+         [hattori-count (length raw-hattori)])
+    (let o-loop ([n 0])
+      (cond
+        [(= n (- hattori-count 1)) null]
+        [else 
+         (let ([first n]
+               [last (if (< (+ n set-size) hattori-count)
+                         (+ n set-size)
+                         (- hattori-count 1))])
+           (let i-loop ([i first]
+                        [set null])
+             (cond
+               [(= i last) (cons 
+                            (list (format "Hattori ~a - ~a" (+ first 1) last)
+                                  (format "h~a-~a" (+ first 1) last)
+                                  (reverse set))
+                            (o-loop last))]
+               [else (i-loop (+ i 1)
+                             (cons (list-ref raw-hattori i)
+                                   set))])))]))))
+
+(define (build-set name output-file input-file)
+  (list name
+        output-file
+        (call-with-input-file (build-path problems-dir input-file) (compose eval read))))
+
+(define games-set (build-set "Games Magazine" "games" "raw-problems/raw-problems.ss"))
+
+(define misc-set (build-set "Misc" "misc" "raw-problems/raw-misc.ss"))
+
+(define kajitani-sets
+  (call-with-input-file (build-path (collection-path "games" "paint-by-numbers") "raw-problems" "raw-kajitani.ss")
+    read))
+
+(define sets (append (list games-set)
+                     (list misc-set)
+                     kajitani-sets
+                     hattori-sets))
+
+(define (sum-list l) (apply + l))
+(define (sum-lists ls) (sum-list (map sum-list ls)))
+
+(define board #f)
+(define known 0)
+(define solving-progress-output void)
+
+(define (set-entry i j nv)
+  (when (and (eq? (get-entry i j) 'unknown)
+             (not (eq? nv 'unknown)))
+    (solving-progress-output))
+  (vector-set! (vector-ref board i) j nv))
+
+(define (get-entry i j)
+  (vector-ref (vector-ref board i) j))
+
+(define progress-bar-max 64)
+(define guide-string ".......:.......|.......:.......|.......:.......|.......:........")
+
+(define (build-progress-outputer max cleanup)
+  (let ([counter 0]
+        [dots-printed 0])
+    (lambda ()
+      (set! counter (+ 1 counter))
+      (cond
+        [(= counter max)
+         
+         (cleanup)
+         
+         ;; dots-printed should always equal progress-bar-max
+         (let loop ([n (- progress-bar-max dots-printed)])
+           (cond
+             [(zero? n) (void)]
+             [else (display "." (current-error-port))
+                   (loop (- n 1))]))
+         (newline (current-error-port))]
+        [else
+         (let ([dots-to-print (floor (- (* progress-bar-max (/ counter (- max 1))) dots-printed))])
+           '(fprintf (current-error-port) "~spercentage: ~a ~a ~a ~a~n"
+                     cleanup
+                     dots-to-print
+                     counter
+                     (exact->inexact (/ counter max))
+                     (exact->inexact (* progress-bar-max (/ counter max))))
+           (set! dots-printed (+ dots-to-print dots-printed))
+           (let loop ([n dots-to-print])
+             (cond
+               [(zero? n) (void)]
+               [else
+                (display "." (current-error-port))
+                (loop (- n 1))]))
+           (flush-output (current-error-port)))]))))
+
+(define (setup-progress max cleanup)
+  (display guide-string (current-error-port))
+  (newline (current-error-port))
+  (build-progress-outputer max cleanup))
+
+(define (solve name rows cols)
+  (cond
+    [(equal? argv (vector))
+     (fprintf (current-error-port) "Solving ~s; memory limit ~a~n"
+              name (format-memory-txt memory-limit))
+     (let ([row-count (length rows)]
+           [col-count (length cols)])
+       (set! board
+             (build-vector col-count
+                           (lambda (i) (make-vector row-count 'unknown))))
+       (set! known 0)
+       (set! solving-progress-output (build-progress-outputer
+                                      (* row-count col-count)
+                                      void)))
+     (letrec ([done (make-semaphore 0)]
+              [kill (make-semaphore 1)]
+              [sucessful? #f]
+              [t (thread
+                  (lambda ()
+                    (with-handlers ([(lambda (x) #t)
+                                     (lambda (x)
+                                       (semaphore-wait kill)
+                                       (set! sucessful? #f)
+                                       (kill-thread k)
+                                       (fprintf (current-error-port) "~nsolver raised an exception~n~a~n"
+                                                (if (exn? x)
+                                                    (exn-message x)
+                                                    x))
+                                       (semaphore-post done))])
+                      (solve:solve rows cols set-entry
+                                   (lambda (max)
+                                     (setup-progress
+                                      max
+                                      (lambda ()
+                                        (semaphore-wait kill)
+                                        (set! sucessful? #t)
+                                        (kill-thread k)))))
+                      (semaphore-post done))))]
+              [k
+               (thread
+                (lambda ()
+                  (let ([check-interval 10]) ;; in seconds
+                    (let loop ()
+                      (sleep check-interval)
+                      (update-memory-display)
+                      (if (<= (current-memory-use) memory-limit)
+                          (loop)
+                          (begin (collect-garbage)(collect-garbage)(collect-garbage)
+                                 (update-memory-display)
+                                 (if (<= (current-memory-use) memory-limit)
+                                     (loop)
+                                     (void))))))
+                  (semaphore-wait kill)
+                  (kill-thread t)
+                  (fprintf (current-error-port) "~n memory limit expired.~n")
+                  (collect-garbage)(collect-garbage)(collect-garbage)(collect-garbage)(collect-garbage)
+                  (update-memory-display)
+                  (semaphore-post done)))])
+       (semaphore-wait done)
+       (newline (current-error-port))
+       (newline (current-error-port))
+       (if sucessful?
+           board
+           #f))]
+    [else #f]))
+
+(define (sanity-check problem)
+  (let ([name (first problem)]
+        [cols (second problem)]
+        [rows (third problem)])
+    (when (null? cols)
+      (error 'build-problems.ss
+             "problem ~a doesn't have any cols" name))
+    (when (null? rows)
+      (error 'build-problems.ss
+             "problem ~a doesn't have any rows" name))
+    (unless (= (sum-lists cols) (sum-lists rows))
+      (error 'build-problems.ss
+             "problem ~a: sum of the column lists is not the same as the sum of the row lists"
+             name))))
+
+
+(for-each 
+ (lambda (set)
+   (let ([set-name (car set)]
+         [output-file (build-path (collection-path "games" "paint-by-numbers" "solution-sets")
+                                  (cadr set))]
+         [problems (caddr set)])
+     (for-each sanity-check problems)
+     (if (file-exists? output-file)
+         (printf "skipping ~s (~a)~n" set-name (normalize-path output-file))
+         (call-with-output-file output-file
+           (lambda (port)
+             (printf "Building ~s~n" set-name)
+             (parameterize ([current-output-port port])
+               (write
+                `(unit/sig paint-by-numbers:problem-set^
+                   (import paint-by-numbers:problem^)
+                   
+                   (define set-name ,set-name)
+                   
+                   (define problems
+                     (list
+                      ,@(map (lambda (x)
+                               (let ([name (first x)]
+                                     [rows (second x)]
+                                     [cols (third x)])
+                                 `(make-problem
+                                   ,(first x)
+                                   ',rows
+                                   ',cols
+                                   ',(solve name rows cols))))
+                             problems)))))))))))
+ sets)
diff --git a/collects/games/paint-by-numbers/raw-problems/count-missing.ss b/collects/games/paint-by-numbers/raw-problems/count-missing.ss
new file mode 100644
index 0000000000..2d208eaaaf
--- /dev/null
+++ b/collects/games/paint-by-numbers/raw-problems/count-missing.ss
@@ -0,0 +1,45 @@
+#!/bin/sh
+
+string=? ; exec mzscheme -qr $0
+
+(printf "checking problems in ~s~n" (collection-path "games" "paint-by-numbers"))
+
+(require-library "sig.ss" "games" "paint-by-numbers")
+
+(require-library "errortrace.ss" "errortrace")
+
+(define counter
+  (unit/sig ()
+    (import paint-by-numbers:problem^
+	    paint-by-numbers:all-problems^)
+
+    (define total 0)
+    (define total-missing 0)
+
+    (define (filter p l)
+      (cond
+       [(null? l) null]
+       [(p (car l)) (cons (car l) (filter p (cdr l)))]
+       [else (filter p (cdr l))]))
+
+    (define (check-set problems set-name)
+      (let ([missing (filter (lambda (x) x)
+			     (map (lambda (problem) (if (problem-solution problem) #f (problem-name problem)))
+				  problems))])
+	(set! total (+ (length problems) total))
+	(set! total-missing (+ (length missing) total-missing))
+	(unless (null? missing)
+	  (printf "~a missing ~a~n" set-name (length missing))
+	  (for-each (lambda (x) (printf "  ~a~n" x)) missing))))
+
+
+    (for-each check-set problemss set-names)
+    (printf "missing ~a of ~a~n" total-missing total)))
+
+(invoke-unit/sig
+ (compound-unit/sig (import)
+   (link
+    [problem : paint-by-numbers:problem^ ((require-library "problem.ss" "games" "paint-by-numbers"))]
+    [all : paint-by-numbers:all-problems^ ((require-library "all-problems.ss" "games" "paint-by-numbers") problem)]
+    [counter : () (counter problem all)])
+   (export)))
diff --git a/collects/games/paint-by-numbers/raw-problems/raw-hattori.ss b/collects/games/paint-by-numbers/raw-problems/raw-hattori.ss
new file mode 100644
index 0000000000..6647d65373
--- /dev/null
+++ b/collects/games/paint-by-numbers/raw-problems/raw-hattori.ss
@@ -0,0 +1,8716 @@
+`(
+("Hattori 1"
+ ((5) (1) (3 1) (8) (2 1) (1 6) (1 1 1) (3) (1) (10))
+ ((1)
+  (4 1)
+  (2 3)
+  (1 2 1)
+  (1 1 1 1)
+  (1 2 1 1)
+  (4 1 1)
+  (1 2 1 1)
+  (1 1 1 1)
+  (5 1))
+ ((o o o o x x x x x o)
+  (o o o o o o x o o o)
+  (o o o o o x x x o x)
+  (o o x x x x x x x x)
+  (o x x o o o o o o x)
+  (o x o o x x x x x x)
+  (o x o x o o o o o x)
+  (o x x x o o o o o o)
+  (o o x o o o o o o o)
+  (x x x x x x x x x x)))
+
+("Hattori 2"
+ ((5 1 5)
+  (5 2 6)
+  (15)
+  (4 5)
+  (3 5 2)
+  (3 6 1 2)
+  (3 4 1 2)
+  (3 3)
+  (3 4)
+  (1 1 1 1)
+  (8)
+  ()
+  (2)
+  (1 9 1)
+  (2 2 2))
+ ((10 2)
+  (9 1)
+  (9)
+  (4 2 1)
+  (3 2 1 3)
+  (1 3 1 3)
+  (2 3 1 1)
+  (3 3 1 1)
+  (1 3 1 1)
+  (2 1 1 1)
+  (4 2 1)
+  (4 2 1 1)
+  (4 2)
+  (9 1)
+  (10 2))
+ ((x x x x x o o x o o x x x x x)
+  (x x x x x o x x o x x x x x x)
+  (x x x x x x x x x x x x x x x)
+  (x x x x o o o o o o x x x x x)
+  (x x x o x x x x x o o o o x x)
+  (x x x o x x x x x x o x o x x)
+  (x x x o o x x x x o o x o x x)
+  (x x x o o o o o o o o o x x x)
+  (x x x o o o o o o o o x x x x)
+  (x o o x o o o o o o x o o o x)
+  (o o o x x x x x x x x o o o o)
+  (o o o o o o o o o o o o o o o)
+  (o o o o x x o o o o o o o o o)
+  (x o o x x x x x x x x x o o x)
+  (x x o o x x o o o o o o o x x)))
+
+("Hattori 3"
+ ((11)
+  (1 11)
+  (2 3 4 2)
+  (4 2 2)
+  (3 4)
+  (2 3 3 3)
+  (2 1 1 3)
+  (2 1 1 3)
+  (2 3 4)
+  (2 1 4)
+  (3 3 4)
+  (2 2 2 4)
+  (4 6)
+  (11)
+  (9))
+ ((9)
+  (12)
+  (1 2 4)
+  (4 1 3)
+  (3 1 4)
+  (3 4 2 2)
+  (2 3 2)
+  (2 4 2 2)
+  (3 1 4)
+  (3 1 3)
+  (4 4)
+  (5 7)
+  (2 10)
+  (12)
+  (9))
+ ((o o x x x x x x x x x x x o o)
+  (o x o x x x x x x x x x x x o)
+  (x x o x x x o o x x x x o x x)
+  (x x x x o o o o o o x x o x x)
+  (x x x o o o o o o o o x x x x)
+  (x x o x x x o x x x o o x x x)
+  (x x o o o x o x o o o o x x x)
+  (x x o o o x o x o o o o x x x)
+  (x x o o o x x x o o o x x x x)
+  (x x o o o o x o o o o x x x x)
+  (x x x o o x x x o o o x x x x)
+  (o x x o x x o x x o x x x x o)
+  (o x x x x o o o x x x x x x o)
+  (o o x x x x x x x x x x x o o)
+  (o o o x x x x x x x x x o o o)))
+
+("Hattori 4"
+ ((6)
+  (3 2)
+  (2 1)
+  (2 2)
+  (2 1)
+  (1 1)
+  (2 1)
+  (5 1)
+  (2 4 5)
+  (1 4 2 4)
+  (1 5 1 4)
+  (7 1 5)
+  (7 7)
+  (5 7)
+  (5))
+ ((5)
+  (2 3)
+  (1 4)
+  (8)
+  (10)
+  (2 7)
+  (2 5)
+  (2)
+  (1 5)
+  (2 2 3)
+  (1 1 4)
+  (1 12)
+  (4 7)
+  (2 7)
+  (1 5))
+ ((o o o o o o o o o x x x x x x)
+  (o o o o o o o x x x o o x x o)
+  (o o o o o o x x o o o o x o o)
+  (o o o o o x x o o o o x x o o)
+  (o o o o x x o o o o o x o o o)
+  (o o o o x o o o o o o x o o o)
+  (o o o x x o o o o o o x o o o)
+  (o x x x x x o o o o o x o o o)
+  (x x o x x x x o o x x x x x o)
+  (x o o x x x x o x x o x x x x)
+  (x o x x x x x o x o o x x x x)
+  (x x x x x x x o x o x x x x x)
+  (x x x x x x x o x x x x x x x)
+  (o x x x x x o o x x x x x x x)
+  (o o o o o o o o o x x x x x o)))
+
+("Hattori 5"
+ ((2 1)
+  (11)
+  (3 3)
+  (2 4)
+  (3 3)
+  (2 2 2 3)
+  (2 2 2 2)
+  (2 1 1 2)
+  (2 2 2 2)
+  (3 2)
+  (1 1 2)
+  (1 4)
+  (1 3 1 1)
+  (1 1 1 2)
+  (6))
+ ((7)
+  (8)
+  (4 5)
+  (3 1)
+  (2 4 3)
+  (1 2 1 1 1)
+  (1 3)
+  (1 1)
+  (1 2 1 1)
+  (1 4 1)
+  (1 2)
+  (4 1)
+  (5 1)
+  (10)
+  (10))
+ ((o o o x x o o o o o o x o o o)
+  (o o x x x x x x x x x x x o o)
+  (o x x x o o o o o o o x x x o)
+  (o x x o o o o o o o o x x x x)
+  (x x x o o o o o o o o o x x x)
+  (x x o o x x o o x x o o x x x)
+  (x x o o x x o o x x o o o x x)
+  (x x o o x o o o o x o o o x x)
+  (x x o o x x o o x x o o o x x)
+  (x x x o o o o o o o o o o x x)
+  (x o x o o o o o o o o o o x x)
+  (o o x o o o o o o o o x x x x)
+  (o o x o x x x o o o x o o o x)
+  (o o x o x o x o o x x o o o o)
+  (o o o x x x x x x o o o o o o)))
+
+("Hattori 6"
+ ((4)
+  (6 1)
+  (2 1 1 2)
+  (5 1 3)
+  (5 1 2 1)
+  (6 1 2 1)
+  (6 3 1)
+  (6 2 2)
+  (4 1 1 2)
+  (2 1 1)
+  (2 2)
+  (7)
+  (1 1)
+  (2 2)
+  (6))
+ ((1 1)
+  (1 6)
+  (1 7)
+  (9)
+  (8)
+  (2 4)
+  (1 1 6 1)
+  (1 2 2)
+  (8 4)
+  (3 1 1)
+  (2 1 2)
+  (2 4)
+  (2 1 1)
+  (2 2 2)
+  (6 2))
+ ((o o o o o x x x x o o o o o o)
+  (x x x x x x o o x o o o o o o)
+  (o o o x x o x o x o o o o x x)
+  (x x x x x o o o x o o o x x x)
+  (o x x x x x o o x o o x x o x)
+  (o x x x x x x o x o x x o o x)
+  (o x x x x x x o x x x o o o x)
+  (o x x x x x x o x x o o o x x)
+  (o x x x x o x o o x o o x x o)
+  (o o x x o o x o o o o o o o x)
+  (o o o o o o x x o o o o o x x)
+  (o o o o o o o x x x x x x x o)
+  (o o o o o o o o x o o x o o o)
+  (o o o o o o o x x o x x o o o)
+  (o o o o o o x x x x x x o o o)))
+
+("Hattori 7"
+ ((3)
+  (5)
+  (3 1)
+  (3 3 1)
+  (6 2 1)
+  (7 3)
+  (2 2 1)
+  (1 1 1 1 1)
+  (2 1 1 1 1)
+  (1 1 2 1)
+  (1 1 1)
+  (13)
+  (4 8)
+  (9)
+  (4 3))
+ ((3 3)
+  (3 2 4)
+  (2 5)
+  (3 2 4)
+  (3 1 1 1)
+  (3 2 4)
+  (3 6)
+  (5 4)
+  (3)
+  (2)
+  (4 2)
+  (6 2)
+  (4 8)
+  (2 1 1)
+  (4))
+ ((o o o o o o o o o o o x x x o)
+  (o o o o o o o o o o x x x x x)
+  (o o o o o o o o o o x x x o x)
+  (o o o x x x o o o o x x x o x)
+  (o x x x x x x o o o x x o o x)
+  (o x x x x x x x o o o x x x o)
+  (x x o o o o x x o o o o x o o)
+  (x o o x o x o x o o o o x o o)
+  (x x o x o x o x o o o o x o o)
+  (o x o o x o x x o o o o x o o)
+  (o o x o o o x o o o o o x o o)
+  (o x x x x x x x x x x x x x o)
+  (x x x x o x x x x x x x x o o)
+  (x x x x x x x x x o o o o o o)
+  (x x x x o x x x o o o o o o o)))
+
+("Hattori 8"
+ ((7)
+  (6 2)
+  (1 3 3)
+  (2 2 2)
+  (2 1)
+  (3 2 1)
+  (3 3 2 1)
+  (1 4 2 1)
+  (1 2 2)
+  (2 2 6)
+  (1 2 1)
+  (1 1 3)
+  (1 4 1)
+  (2 5)
+  (9))
+ ((4)
+  (3 1 5)
+  (1 2 2 2)
+  (1 2 1 1)
+  (2 1 1 1)
+  (2 3 1 1)
+  (3 1 2 1)
+  (1 1 2 3 1)
+  (1 2 2 1 1)
+  (1 1 2 1 1)
+  (2 1 3)
+  (2 2 1 1)
+  (1 2 3 1)
+  (2 2 1 1)
+  (7 3))
+ ((o o o o x x x x x x x o o o o)
+  (o x x x x x x o o o x x o o o)
+  (o x o o o o x x x o o x x x o)
+  (o x x o o o o o x x o o o x x)
+  (o o x x o o o o o o o o o o x)
+  (o o o x x x o o o o o x x o x)
+  (x x x o o x x x o o o x x o x)
+  (x o x x x x o x x o o o o o x)
+  (x o o o o o o o x x o o o x x)
+  (x x o o o x x o o x x x x x x)
+  (o x o o o o x x o o o o x o o)
+  (o x o o o o o x o o o o x x x)
+  (o x o o o o o x x x x o o o x)
+  (o x x o o o o o o o x x x x x)
+  (o o x x x x x x x x x o o o o)))
+
+("Hattori 9"
+ ((3)
+  (2 2)
+  (1 2)
+  (1 11)
+  (1 2 4)
+  (2 2 2 1)
+  (3 3 1 1)
+  (2 2)
+  (1 1)
+  (1 1)
+  (7)
+  (3 3)
+  (2 2)
+  (3 3)
+  (3 3))
+ ((5)
+  (2 2)
+  (1 1)
+  (2 2 5)
+  (5 8)
+  (3 2 2 2)
+  (1 1 1)
+  (1 2 2 2)
+  (1 8)
+  (1 5)
+  (4)
+  (3)
+  (2)
+  (4)
+  (1))
+ ((o x x x o o o o o o o o o o o)
+  (x x o x x o o o o o o o o o o)
+  (x o o o x x o o o o o o o o o)
+  (x o o o x x x x x x x x x x x)
+  (x o o o x x o o o o x x x x o)
+  (x x o x x o o o o o x x o x o)
+  (o x x x o x x x o o x o o x o)
+  (o o o o x x o x x o o o o o o)
+  (o o o o x o o o x o o o o o o)
+  (o o o o x o o o x o o o o o o)
+  (o o o x x x x x x x o o o o o)
+  (o o o x x x o x x x o o o o o)
+  (o o o x x o o o x x o o o o o)
+  (o o o x x x o x x x o o o o o)
+  (o o o x x x o x x x o o o o o)))
+
+("Hattori 10"
+ ((7 1)
+  (2 2 1)
+  (1 1 3)
+  (1 1 1 3)
+  (5 2)
+  (13)
+  (15)
+  (3 5)
+  (2 7 1)
+  (3 10)
+  (3 7)
+  (6 2)
+  (2 4)
+  (2 3 2)
+  (1 3 1)
+  (1 3 1)
+  (1 3 1)
+  (2 2)
+  (2 2)
+  (6))
+ ((5)
+  (5)
+  (3 2)
+  (2 5)
+  (1 2 2 2)
+  (10 2 2)
+  (2 6 1 2 1)
+  (1 7 1 4 1)
+  (2 13 1)
+  (14 1 1)
+  (1 2 5 2)
+  (2 3 2 2)
+  (2 2 2 5)
+  (7 3)
+  (5 4))
+ ((o o o o x x x x x x x o o x o)
+  (o o o o o x x o x x o o o x o)
+  (o o o o o x o o o x o o x x x)
+  (o o o o o x o x o x o o x x x)
+  (o o o o o x x x x x o o o x x)
+  (o o x x x x x x x x x x x x x)
+  (x x x x x x x x x x x x x x x)
+  (x x x o o x x x x x o o o o o)
+  (x x o o o x x x x x x x o o x)
+  (x x x o o x x x x x x x x x x)
+  (x x x o o o o o x x x x x x x)
+  (o o o o o x x x x x x o o x x)
+  (o o o o x x o o x x x x o o o)
+  (o o o x x o o x x x o x x o o)
+  (o o o x o o x x x o o o x o o)
+  (o o o x o o x x x o o o x o o)
+  (o o o x o o o x x x o o x o o)
+  (o o o x x o o o o o o x x o o)
+  (o o o o x x o o o o x x o o o)
+  (o o o o o x x x x x x o o o o)))
+
+("Hattori 11"
+ ((4)
+  (6)
+  (6)
+  (3 6)
+  (3 2 6)
+  (3 6 4)
+  (4 7)
+  (11)
+  (2 13)
+  (1 13)
+  (14)
+  (9 4)
+  (9 2)
+  (8)
+  (7)
+  (6)
+  (5 1)
+  (3 4 3)
+  (5 3 4)
+  (16))
+ ((5)
+  (4)
+  (3 1)
+  (3 2)
+  (5 3)
+  (8 2)
+  (10 2)
+  (12 2)
+  (13 1)
+  (1 12 1)
+  (14 1)
+  (1 1 12)
+  (12)
+  (3 8)
+  (4 3 1)
+  (6 4 1)
+  (6 3 2)
+  (6 3 3)
+  (6 2 3)
+  (4 4))
+ ((o o o o o o o o o o o o o o o x x x x o)
+  (o o o o o o o o o o o o o o x x x x x x)
+  (o o o o o o o o o o o o o o x x x x x x)
+  (o o o o o o o x x x o o o o x x x x x x)
+  (o o o o o o x x x o x x o o x x x x x x)
+  (x x x o o x x x x x x o o o o x x x x o)
+  (x x x x o x x x x x x x o o o o o o o o)
+  (x x x x x x x x x x x o o o o o o o o o)
+  (x x o x x x x x x x x x x x x x o o o o)
+  (x o o o x x x x x x x x x x x x x o o o)
+  (o o o o x x x x x x x x x x x x x x o o)
+  (o o o o x x x x x x x x x o o x x x x o)
+  (o o o o o x x x x x x x x x o o o x x o)
+  (o o o o o o x x x x x x x x o o o o o o)
+  (o o o o o o o x x x x x x x o o o o o o)
+  (o o o o o o o o x x x x x x o o o o o o)
+  (o o o o o o o o o x x x x x o o o o o x)
+  (o o x x x o o o o o x x x x o o o x x x)
+  (o o o x x x x x o o o x x x o o x x x x)
+  (o o o o x x x x x x x x x x x x x x x x)))
+
+("Hattori 12"
+ ((5 7)
+  (5 3 3)
+  (4 2 7 2)
+  (4 1 1)
+  (3 1 1)
+  (2 1 3 1)
+  (1 1 1 1)
+  (1 1 9 1)
+  (13)
+  (2 11)
+  (2 13)
+  (3 11 2)
+  (16 1)
+  (15 1)
+  (15 1)
+  (13 1)
+  (12 2)
+  (10 3)
+  (12)
+  (18))
+ ((8 1)
+  (6 2)
+  (5 3 1)
+  (4 4 1)
+  (2 6 1)
+  (6 1)
+  (7 8 1)
+  (2 12)
+  (1 13)
+  (3 13)
+  (1 1 13)
+  (1 1 1 13)
+  (1 1 15)
+  (1 1 1 13)
+  (1 1 13)
+  (3 10 2)
+  (1 9 2)
+  (2 3 3 3)
+  (7 2 4)
+  (7 1))
+ ((x x x x x o o o o x x x x x x x o o o o)
+  (x x x x x o o x x x o o o o o x x x o o)
+  (x x x x o o x x o x x x x x x x o x x o)
+  (x x x x o o x o o o o o o o o o o o x o)
+  (x x x o o o x o o o o o o o o o o o x o)
+  (x x o o o o x o o o o x x x o o o o x o)
+  (x o o o o o x o o o o o x o o o o o x o)
+  (x o o o o o x o x x x x x x x x x o x o)
+  (o o o o o o x x x x x x x x x x x x x o)
+  (x x o o o o o x x x x x x x x x x x o o)
+  (o x x o o o x x x x x x x x x x x x x o)
+  (o o x x x o x x x x x x x x x x x o x x)
+  (o o x x x x x x x x x x x x x x x x o x)
+  (o o o x x x x x x x x x x x x x x x o x)
+  (o o o x x x x x x x x x x x x x x x o x)
+  (o o o o x x x x x x x x x x x x x o o x)
+  (o o o o x x x x x x x x x x x x o o x x)
+  (o o o o o x x x x x x x x x x o o x x x)
+  (o o o o o o o x x x x x x x x x x x x o)
+  (o o x x x x x x x x x x x x x x x x x x)))
+
+("Hattori 13"
+ ((2 2)
+  (2 3)
+  (3)
+  (2 12)
+  (2 15)
+  (17)
+  (18)
+  (3 12)
+  (4 1 13)
+  (4 13)
+  (8 7)
+  (10 7)
+  (11 7)
+  (18)
+  (18)
+  (17)
+  (14)
+  (3)
+  (3)
+  (2))
+ ((2 2 2)
+  (2 7)
+  (2 9)
+  (2 11)
+  (2 6)
+  (3 1 7)
+  (3 7)
+  (14)
+  (14)
+  (7 6)
+  (10 8)
+  (10 7)
+  (10 6)
+  (14)
+  (14)
+  (14)
+  (14)
+  (14)
+  (14)
+  (3 2 2 2))
+ ((o o x x o o o o o o x x o o o o o o o o)
+  (o o x x o o o o o o x x x o o o o o o o)
+  (o o o o o o o o o o x x x o o o o o o o)
+  (x x o o o o o x x x x x x x x x x x x o)
+  (x x o o o x x x x x x x x x x x x x x x)
+  (o o o x x x x x x x x x x x x x x x x x)
+  (o o x x x x x x x x x x x x x x x x x x)
+  (o x x x o o o x x x x x x x x x x x x o)
+  (x x x x o x o x x x x x x x x x x x x x)
+  (x x x x o o o x x x x x x x x x x x x x)
+  (o x x x x x x x x o o o x x x x x x x o)
+  (x x x x x x x x x x o o o x x x x x x x)
+  (x x x x x x x x x x x o o x x x x x x x)
+  (o x x x x x x x x x x x x x x x x x x o)
+  (o o x x x x x x x x x x x x x x x x x x)
+  (o o o x x x x x x x x x x x x x x x x x)
+  (o o o o o x x x x x x x x x x x x x x o)
+  (o o o o o o o o o o x x x o o o o o o o)
+  (o o o o o o o o o o x x x o o o o o o o)
+  (o o o o o o o o o o x x o o o o o o o o)))
+
+("Hattori 14"
+ ((8)
+  (9)
+  (1 5)
+  (1 1 3)
+  (1 2)
+  (2 2)
+  (1 2 2)
+  (3 3)
+  (1 10)
+  (12)
+  (1 4 2 1)
+  (1 5 6)
+  (1 5 2 1)
+  (1 6)
+  (1 7)
+  (1 3 3)
+  (1 1 3 4)
+  (1 6 3)
+  (2 1 3 4)
+  (19))
+ ((3)
+  (2)
+  (1)
+  (3 1 1)
+  (2 11)
+  (3 1 1)
+  (5 2 7)
+  (2 2 2 8)
+  (2 1 14)
+  (3 8 1)
+  (3 11 2)
+  (7 12)
+  (6 2 1 6)
+  (4 3 1 4)
+  (2 5 1)
+  (1 1)
+  (1 1)
+  (1 1)
+  (3 1)
+  (1 1))
+ ((o o o o o o o x x x x x x x x o o o o o)
+  (o o o o o o x x x x x x x x x o o o o o)
+  (o o o o o o x o o x x x x x o o o o o o)
+  (o o o o o o x o x o o x x x o o o o o o)
+  (o o o o o o x o o o o x x o o o o o o o)
+  (o o o o o o x x o o o x x o o o o o o o)
+  (o o o o x o o x x o x x o o o o o o o o)
+  (o o o x x x o o x x x o o o o o o o o o)
+  (o o o x o x x x x x x x x x x o o o o o)
+  (o o o x x x x x x x x x x x x o o o o o)
+  (o o o o x o o o x x x x o x x o o o x o)
+  (o o o o x o o o x x x x x o x x x x x x)
+  (o o o o x o o x x x x x o x x o o o x o)
+  (o o o o x o x x x x x x o o o o o o o o)
+  (o o o o x o x x x x x x x o o o o o o o)
+  (o o o o x o x x x o x x x o o o o o o o)
+  (x o o o x o x x x o x x x x o o o o o o)
+  (x o o x x x x x x o o x x x o o o o o o)
+  (x x o o x o x x x o x x x x o o o o o o)
+  (o x x x x x x x x x x x x x x x x x x x)))
+
+("Hattori 15"
+ ((1)
+  (1 17)
+  (3 1 1)
+  (1 1 1 3 3 3 1)
+  (1 1 1 3 1 1 1 1 1)
+  (3 1 3 3 3 1)
+  (1 3 1)
+  (1 16)
+  (1)
+  (1)
+  (1 9)
+  (1 2 1 2)
+  (1 2 1 1 1)
+  (1 2 1 3 2)
+  (2 16)
+  (3 16)
+  (1 4 7 3 1)
+  (1 1 4 8)
+  (1 2 1 8)
+  (1 2 1))
+ ((20)
+  (1 1 2)
+  (6 2)
+  (1 2 1)
+  (7 3)
+  (1 1 5)
+  (1 3 1 4 1)
+  (1 3 1 2 5)
+  (1 3 1 2 4)
+  (1 1 1 4)
+  (1 3 1 1 5)
+  (1 1 1 1 7 1)
+  (1 3 1 1 6)
+  (1 1 1 6)
+  (1 3 1 1 4 2)
+  (1 1 1 1 1 6)
+  (1 3 1 2 5)
+  (1 1 8)
+  (7 3 3)
+  (5))
+ ((x o o o o o o o o o o o o o o o o o o o)
+  (x o x x x x x x x x x x x x x x x x x o)
+  (x x x o x o o o o o o o o o o o o o x o)
+  (x o x o x o x x x o x x x o x x x o x o)
+  (x o x o x o x x x o x o x o x o x o x o)
+  (x x x o x o x x x o x x x o x x x o x o)
+  (x o x x x o o o o o o o o o o o o o x o)
+  (x o o x x x x x x x x x x x x x x x x o)
+  (x o o o o o o o o o o o o o o o o o o o)
+  (x o o o o o o o o o o o o o o o o o o o)
+  (x o o o o o o o x x x x x x x x x o o o)
+  (x o o o o o o x x o o x o o o o x x o o)
+  (x o o o o o x x o o o x o o x o o x o o)
+  (x o o o o x x o o o o x o x x x o x x o)
+  (x x o o x x x x x x x x x x x x x x x x)
+  (x x x o x x x x x x x x x x x x x x x x)
+  (x o x x x x o x x x x x x x o x x x o x)
+  (x o o o o x o x x x x o x x x x x x x x)
+  (x o o o o o x x o o x o x x x x x x x x)
+  (x o o o o o o o o o o x x o o o o o x o)))
+
+("Hattori 16"
+ ((6)
+  (10)
+  (3 5 3)
+  (8 7)
+  (6 7 3)
+  (2 8 7)
+  (5 10 3)
+  (1 5 4 1)
+  (5 5)
+  (3 3)
+  (3 4 2)
+  (3 5 3)
+  (3 5 2)
+  (13)
+  (5)
+  (6)
+  (7)
+  (7)
+  (7)
+  (5))
+ ((5)
+  (3 4)
+  (10)
+  (2 3 2)
+  (7 2)
+  (5 1 1)
+  (7 1)
+  (2 1 2 1)
+  (7 4)
+  (7 7)
+  (3 3 9)
+  (7 9)
+  (5 1 9)
+  (1 4 7)
+  (7 1 5)
+  (2 4 1 4)
+  (4 2 2 3)
+  (7 2)
+  (3 4)
+  (7))
+ ((o o o o o o o x x x x x x o o o o o o o)
+  (o o o o o x x x x x x x x x x o o o o o)
+  (o o o o x x x o x x x x x o x x x o o o)
+  (o o x x x x x x x x o x x x x x x x o o)
+  (o x x x x x x o x x x x x x x o x x x o)
+  (o x x o x x x x x x x x o x x x x x x x)
+  (x x x x x o x x x x x x x x x x o x x x)
+  (x o x x x x x o o o o o o o x x x x o x)
+  (x x x x x o o o o o o o o o o x x x x x)
+  (x x x o o o o o o o o o o o o o o x x x)
+  (x x x o o o o o x x x x o o o o o o x x)
+  (o x x x o o o o x x x x x o o o o x x x)
+  (o o x x x o o o x x x x x o o o x x o o)
+  (o o o o x x x x x x x x x x x x x o o o)
+  (o o o o o o o o o x x x x x o o o o o o)
+  (o o o o o o o o o x x x x x x o o o o o)
+  (o o o o o o o o o x x x x x x x o o o o)
+  (o o o o o o o o o o x x x x x x x o o o)
+  (o o o o o o o o o o x x x x x x x o o o)
+  (o o o o o o o o o o o o x x x x x o o o)))
+
+("Hattori 17"
+ ((9 9)
+  (6 10)
+  (5 11)
+  (4 3 5)
+  (2 1 3)
+  (2 4 2)
+  (1 3 6)
+  (5 1 1 1)
+  (2 2 1 3 1)
+  (7 4 1)
+  (7 4 2)
+  (1 3 9)
+  (1 2 4 6)
+  (1 6 9)
+  (1 4 7)
+  (2 1 4 2)
+  (5 3 4)
+  (5 7)
+  (5 10)
+  (5 11))
+ ((1 8)
+  (2 4 4)
+  (4 1 2 4)
+  (8 2 4)
+  (6 1 3 7)
+  (4 8 4)
+  (3 7 1)
+  (1 2)
+  (1 2)
+  (2 2 2 1)
+  (3 2 1 1 1 2)
+  (7 8 2)
+  (3 7 4 2)
+  (3 1 1 2 3 3)
+  (3 4 6 3)
+  (4 1 4 3)
+  (4 1 4 4)
+  (5 1 4 4)
+  (7 4 5)
+  (7 6 5))
+ ((x x x x x x x x x o o x x x x x x x x x)
+  (o x x x x x x o o o x x x x x x x x x x)
+  (o o x x x x x o o x x x x x x x x x x x)
+  (o o x x x x o o o x x x o o o x x x x x)
+  (o o o x x o o o o o o x o o o o o x x x)
+  (o o o x x o o o o o o x x x x o o o x x)
+  (o o o x o o o o o o x x x o x x x x x x)
+  (o x x x x x o o o o x o x o x o o o o o)
+  (x x o o o x x o o x o o x x x o o o o x)
+  (x x x x x x x o o x x x x o o o o o o x)
+  (x x x x x x x o o o o x x x x o o o x x)
+  (x o o o x x x o o o o x x x x x x x x x)
+  (x o o o o x x o x x x x o o x x x x x x)
+  (x o o o x x x x x x o x x x x x x x x x)
+  (x o o o x x x x o o o x x x x x x x o o)
+  (x x o o x o o o o o o x x x x o o o x x)
+  (o x x x x x o o o o x x x o o o x x x x)
+  (o x x x x x o o o o o o o x x x x x x x)
+  (o x x x x x o o o o x x x x x x x x x x)
+  (o o x x x x x o o x x x x x x x x x x x)))
+
+("Hattori 18"
+ ((3 4)
+  (1 3 2 1)
+  (1 6 3 2)
+  (1 1 2 1 1 6)
+  (3 2 1 1)
+  (1 1 1 1 2 1 1 1)
+  (1 1 2 1 2 2 2)
+  (1 1 2 1 1 2 1)
+  (1 2 4 1 3)
+  (1 16)
+  (2 5 10)
+  (8 4 2)
+  (8 2 4)
+  (5 2 1 4)
+  (1 5 6)
+  (2 7 3 2)
+  (2 8 2)
+  (2 3 5 1 1)
+  (2 5 7 3)
+  (2 5 5 4))
+ ((5 7 6)
+  (1 1 3 5)
+  (2 3 3)
+  (3 2 3 2)
+  (2 1 6 2)
+  (2 2 5 5)
+  (2 2 11)
+  (2 1 5 6)
+  (3 3 4)
+  (1 1 5 6)
+  (1 1 3 6)
+  (6 2 5)
+  (1 2 3 4)
+  (3 2 4 3)
+  (1 1 8 2)
+  (1 2 3 5)
+  (1 2 2 5 1)
+  (1 1 3 3 2)
+  (3 10 2)
+  (1 2 8 3))
+ ((x x x o o o o o x x x x o o o o o o o o)
+  (x o x x x o o x x o o x o o o o o o o o)
+  (x o o x x x x x x o o x x x o o o o x x)
+  (x o o x o x x o o x o x o x x x x x x o)
+  (x x x o o o o o o o x x o x o o o o x o)
+  (o o x o x o o x o x o x x o x o o x o x)
+  (x o x o o x x o o x o o x x o x x o x x)
+  (x o o x o x x o o x o o o x o x x o x o)
+  (x o o x x o o x x x x o o o x o o x x x)
+  (x o o o x x x x x x x x x x x x x x x x)
+  (x x o o x x x x x o x x x x x x x x x x)
+  (x x x x x x x x o o o o x x x x o o x x)
+  (x x x x x x x x o o o o o x x o x x x x)
+  (o o x x x x x o x x o o o o x o x x x x)
+  (x o o o o o x x x x x o o o x x x x x x)
+  (x x o o o x x x x x x x o o x x x o x x)
+  (x x o o o x x x x x x x x o o x x o o o)
+  (x x o o o x x x o x x x x x o x o o o x)
+  (x x o x x x x x o x x x x x x x o x x x)
+  (x x o x x x x x o o x x x x x o x x x x)))
+
+("Hattori 19"
+ ((2 2 2 3)
+  (2 2 3 5)
+  (2 2 3 5)
+  (1 1 2 5)
+  (2)
+  (8 2 2)
+  (10 3 2 1)
+  (11 3 2 1)
+  (11 2 1 1)
+  (11)
+  (11 5)
+  (10 7)
+  (6 7)
+  (4 6)
+  (5 6)
+  (6 5)
+  (7 6)
+  (7 7)
+  (7 7)
+  (6 6))
+ ((4 7)
+  (3 14)
+  (15)
+  (4 15)
+  (3 15)
+  (8 6)
+  (3 7 5)
+  (4 7 4)
+  (3 7)
+  (1 6)
+  (4 4)
+  (5)
+  (4 2 2)
+  (4 4 2 3)
+  (2 4 5 4)
+  (10)
+  (3 10)
+  (4 10)
+  (9)
+  (3 7))
+ ((x x o x x o o x x o o x x x o o o o o o)
+  (x x o x x o x x x o x x x x x o o o o o)
+  (x x o x x o x x x o x x x x x o o o o o)
+  (x o o x o o x x o x x x x x o o o o o o)
+  (o o o o o o o o o o x x o o o o o o o o)
+  (o x x x x x x x x o o o o x x o x x o o)
+  (x x x x x x x x x x o o x x x o x x o x)
+  (x x x x x x x x x x x o x x x o x x o x)
+  (x x x x x x x x x x x o o x x o o x o x)
+  (x x x x x x x x x x x o o o o o o o o o)
+  (x x x x x x x x x x x o o o x x x x x o)
+  (x x x x x x x x x x o o o x x x x x x x)
+  (x x x x x x o o o o o o o x x x x x x x)
+  (o x x x x o o o o o o o o o x x x x x x)
+  (o x x x x x o o o o o o o o x x x x x x)
+  (o x x x x x x o o o o o o o o x x x x x)
+  (o x x x x x x x o o o o o o x x x x x x)
+  (o x x x x x x x o o o o o x x x x x x x)
+  (o x x x x x x x o o o o x x x x x x x o)
+  (o o x x x x x x o o o o x x x x x x o o)))
+
+("Hattori 20"
+ ((3 3 5)
+  (9 1)
+  (2 16)
+  (1 2 6 4)
+  (1 1 1 1 6 4)
+  (1 1 6 2)
+  (1 1 5 1)
+  (1 1 4 3)
+  (2 1 2 2 4)
+  (1 3 5)
+  (9 5)
+  (7 4)
+  (6 3)
+  (4 1 2)
+  (3 7 1)
+  (5 1 6 1)
+  (1 1 1 1 6 1)
+  (1 1 1 1 1 1 1 1)
+  (1 1 1 1 1 1)
+  (3 3 3))
+ ((3)
+  (11)
+  (2 1 1)
+  (1 1 5)
+  (2 1 10)
+  (2 1 6 1)
+  (4 5 5)
+  (13 1)
+  (3 5 5)
+  (4 2 1)
+  (5 7)
+  (6 1)
+  (7 3)
+  (7 4)
+  (6 3)
+  (1 1 2 4)
+  (1 3 4 3)
+  (1 3 6 5)
+  (1 4 7 1)
+  (20))
+ ((x x x o o o x x x o o o o o o x x x x x)
+  (x x x x x x x x x o o o o o o o o o o x)
+  (x x o o x x x x x x x x x x x x x x x x)
+  (o x o o o o x x o x x x x x x o x x x x)
+  (o x o x o x o x o x x x x x x o x x x x)
+  (o x o o o o o x o x x x x x x o o o x x)
+  (o x o o o o o x o o x x x x x o o o o x)
+  (o x o o o o o x o o o x x x x o o x x x)
+  (o x x o x o o x x o o o x x o o x x x x)
+  (o x o o o o x x x o o o o o o x x x x x)
+  (o x x x x x x x x x o o o o o x x x x x)
+  (o o o x x x x x x x o o o o o o x x x x)
+  (o o o x x x x x x o o o o o o o o x x x)
+  (o o o x x x x o o o x o o o o o o o x x)
+  (o o o x x x o o o o x x x x x x x o o x)
+  (o o o o x x x x x o x o x x x x x x o x)
+  (o o o o x o x o x o x o x x x x x x o x)
+  (o o o o x o x o x o x o o x o x o x o x)
+  (o o o o x o x o x o x o o o o o o x o x)
+  (o o o o x x x o x x x o o o o o o x x x)))
+
+("Hattori 21"
+ ((4 10)
+  (2 1 3)
+  (1 1 10)
+  (1 1 4)
+  (1 1 4)
+  (1 1 2 2)
+  (1 1 2 2 2)
+  (1 1 1 1 1 1)
+  (1 1 6 1 1)
+  (2 1 2 1 4 2)
+  (6 1 2 1 4)
+  (11 3)
+  (1 4)
+  (1 4)
+  (1 4)
+  (1 5)
+  (1 6)
+  (18)
+  (18)
+  (18))
+ ((9)
+  (2 2)
+  (1 1 3)
+  (1 1 3)
+  (11 3)
+  (10)
+  (4 3)
+  (2 2 1 3)
+  (6 2 3)
+  (2 2 1 3)
+  (9 2 3)
+  (7 4 3)
+  (3 1 1 3)
+  (1 1 4 3)
+  (1 1 1 1 4)
+  (1 1 1 5)
+  (1 1 4 8)
+  (1 1 1 11)
+  (1 1 1 10)
+  (1 1 1 10))
+ ((o x x x x o o o o o x x x x x x x x x x)
+  (x x o o x o o o o o x x x o o o o o o o)
+  (x o o o x o o o o o x x x x x x x x x x)
+  (x o o o x o o o x x x x o o o o o o o o)
+  (x o o o x o o o x x x x o o o o o o o o)
+  (x o o o x o o x x o x x o o o o o o o o)
+  (x o o o x o o x x o x x o o o o o x x o)
+  (x o o o x o o o x o x o o o o o x o o x)
+  (x o o o x o x x x x x x o x o o x o o o)
+  (x x o o x o x x o x o x x x x o x x o o)
+  (o x x x x x x o x o x x o x o o x x x x)
+  (o o o o o x x x x x x x x x x x o x x x)
+  (o o o o o x o o o o o o o o o o x x x x)
+  (o o o o o x o o o o o o o o o o x x x x)
+  (o o o o o x o o o o o o o o o o x x x x)
+  (o o o o o x o o o o o o o o o x x x x x)
+  (o o o o o x o o o o o o o o x x x x x x)
+  (o o x x x x x x x x x x x x x x x x x x)
+  (o o x x x x x x x x x x x x x x x x x x)
+  (o o x x x x x x x x x x x x x x x x x x)))
+
+("Hattori 22"
+ ((7)
+  (3 1 7)
+  (1 3 7)
+  (2 2 8)
+  (7 8)
+  (4 1 8)
+  (1 1 4 8)
+  (2 3 8)
+  (3 10)
+  (14)
+  (15)
+  (15)
+  (18)
+  (16 1)
+  (8 6)
+  (7 5)
+  (7 2 2)
+  (2 2 1)
+  (1)
+  (1))
+ ((2 10)
+  (11)
+  (9)
+  (3 9)
+  (3 8)
+  (1 4 9)
+  (2 2 1 9)
+  (14)
+  (3 1 6)
+  (10)
+  (9)
+  (2 8 2)
+  (1 14)
+  (16)
+  (16)
+  (9 5)
+  (9 1 2)
+  (7 2)
+  (6)
+  (6))
+ ((o o o o o o o o o o o x x x x x x x o o)
+  (o o o o o x x x o o o x o x x x x x x x)
+  (o o o x o o x x x o o o o x x x x x x x)
+  (o o o x x o o x x o o o x x x x x x x x)
+  (o o o x x x x x x x o o x x x x x x x x)
+  (o o o o x x x x o x o o x x x x x x x x)
+  (x o o o o x o x x x x o x x x x x x x x)
+  (x x o o o x x x o x x x x x x x x o o o)
+  (o x x x o o o x x x x x x x x x x o o o)
+  (o x x x x x x x x x x x x x x o o o o o)
+  (x x x x x x x x x x x x x x x o o o o o)
+  (x x x x x x x x x x x x x x x o o o o o)
+  (x x x x x x x x x x x x x x x x x x o o)
+  (x x x x x x x x x x x x x x x x o x o o)
+  (x x x x x x x x o o x x x x x x o o o o)
+  (x x x x x x x o o o o o x x x x x o o o)
+  (x x x x x x x o o o o x x o o x x o o o)
+  (x x o o o x x o o o o x o o o o o o o o)
+  (x o o o o o o o o o o o o o o o o o o o)
+  (x o o o o o o o o o o o o o o o o o o o)))
+
+("Hattori 23"
+ ((8 4)
+  (10 1)
+  (12 1 1)
+  (3 1 1 2)
+  (2 2 2 1 1 2)
+  (2 1 1 1 1 2)
+  (2 1 1 2)
+  (2 1 1 1 1 1 2)
+  (3 1 1 1 1 1 1)
+  (2 6 1 1 2)
+  (2 1 1 4)
+  (2 9 4)
+  (14 4)
+  (15)
+  (8 4 2)
+  (8 2 2 1)
+  (8 1 1 3)
+  (2 5 1 2 1)
+  (11 1)
+  (10 5))
+ ((9)
+  (10)
+  (5 1 5)
+  (8 8)
+  (4 1 9)
+  (3 1 12)
+  (3 2 1 1 9)
+  (3 2 9)
+  (3 1 1 3 2)
+  (3 2 2 3 2)
+  (3 1 1 1 3 2 2)
+  (3 6 3)
+  (9 4 2)
+  (1 4 1)
+  (5)
+  (3)
+  (13 1)
+  (1 3 1 2 1)
+  (1 5 4 3 1)
+  (1 11 1 1))
+ ((o o o o x x x x x x x x o o o o x x x x)
+  (o o o x x x x x x x x x x o o o x o o o)
+  (o o x x x x x x x x x x x x o o x o o x)
+  (o o x x x o o o o o o o x o o o x o x x)
+  (o o x x o x x o o x x o x o o o x o x x)
+  (o o x x o o x o o x o o x o o o x o x x)
+  (o o x x o o o o o o o o x o o o x o x x)
+  (o o o x x o x o x o x o x o o o x o x x)
+  (o x x x o x o x o x o o x o o o x o o x)
+  (x x o o o x x x x x x o x o o o x o x x)
+  (x x o o o x o o o o o x o o o o x x x x)
+  (x x o o x x x x x x x x x o o o x x x x)
+  (x x x x x x x x x x x x x x o o x x x x)
+  (x x x x x x x x x x x x x x x o o o o o)
+  (x x x x x x x x o o o x x x x o o x x o)
+  (x x x x x x x x o o x x o x x o o o x o)
+  (x x x x x x x x o o x o o o x o o x x x)
+  (x x o x x x x x o o o x o o x x o x o o)
+  (o o o x x x x x x x x x x x o x o o o o)
+  (o o o x x x x x x x x x x o o x x x x x)))
+
+("Hattori 24"
+ ((5 3)
+  (4 4 4)
+  (1 2 10)
+  (1 1 6 1 3)
+  (1 1 2 1 6 2)
+  (1 1 1 1 4)
+  (3 1 1 1 1 1)
+  (2 1 1 1 1 1)
+  (2 3 4 4)
+  (5 1 2 3 1)
+  (1 3 1 1)
+  (3 1 1 1)
+  (5 3 1 2)
+  (7 1 8)
+  (10 1 1 1)
+  (5 11)
+  (3 7)
+  (3 6 2)
+  (3 7 1)
+  (2 5))
+ ((7)
+  (1 3 6)
+  (1 1 1 2 7)
+  (2 1 7)
+  (2 1 4)
+  (1 1 4)
+  (12)
+  (1 1 1 4)
+  (2 9 2)
+  (4 1 2)
+  (4 7 1)
+  (5 2 1 1 3)
+  (1 5 2 1 3)
+  (1 1 1 7)
+  (3 2 1 5)
+  (1 1 5 5)
+  (2 2 2 6)
+  (4 4 1 2)
+  (6 1 2 3)
+  (2 16))
+ ((o o o o o o o x x x x x o o o o o x x x)
+  (x x x x o o o o x x x x o o o o x x x x)
+  (x o o x x o o o o x x x x x x x x x x o)
+  (x o o o x o x x x x x x o o x o o x x x)
+  (x o x o o x x o x o o x x x x x x o x x)
+  (x o o o o o x o x o o o x o o o x x x x)
+  (x x x o o o x o x o o o x o o o o x o x)
+  (x x o o o o x o x o o o x o o o o x o x)
+  (o x x o o o x x x o o x x x x o x x x x)
+  (o o x x x x x o x o x x o o x x x o o x)
+  (o o o o o o x o x x x o o o o x o o o x)
+  (o o o o o o x x x o x o o o o x o o o x)
+  (o o o x x x x x o o x x x o o x o o x x)
+  (o o x x x x x x x o x o x x x x x x x x)
+  (o x x x x x x x x x x o o x o o x o o x)
+  (o x x x x x o o o x x x x x x x x x x x)
+  (o x x x o o o o o o o o o x x x x x x x)
+  (o x x x o o o o o o o x x x x x x o x x)
+  (o x x x o o o o o o x x x x x x x o o x)
+  (o x x o o o o o o o o x x x x x o o o o)))
+
+("Hattori 25"
+ ((6 7)
+  (3 2 8)
+  (3 2 2 4)
+  (2 3 1 2 3)
+  (2 1 1 1 4 3)
+  (2 4 1 2 2)
+  (2 2 1 1 3)
+  (3 2 2 1)
+  (4 2 1 2)
+  (7 2 1)
+  (2 1 1 1)
+  (2 1 1 1)
+  (2 3 1)
+  (2 2 1)
+  (2 5)
+  (2 1 1)
+  (2 2 1)
+  (4 1 1)
+  (18)
+  (18))
+ ((7)
+  (9)
+  (3 3 2)
+  (2 2 3)
+  (1 3 11)
+  (1 1 1 11)
+  (1 4 1 3)
+  (2 2 2 2)
+  (2 2 2)
+  (6 2)
+  (2)
+  (2)
+  (3 2 2)
+  (8 6 4)
+  (2 2 3 5 2)
+  (2 1 3 1 2)
+  (3 3 1 2)
+  (5 1 12)
+  (7 2)
+  (5 2))
+ ((o o x x x x x x o o o o x x x x x x x o)
+  (o x x x o o o x x o o o x x x x x x x x)
+  (x x x o o o o o x x o o x x o o x x x x)
+  (x x o o x x x o o x o o o x x o o x x x)
+  (x x o o x o x o o x o o x x x x o x x x)
+  (x x o o x x x x o x o o x x o o o o x x)
+  (x x o o o o x x o x o o o x o o x x x o)
+  (x x x o o o o o x x o o o x x o x o o o)
+  (x x x x o o o x x o o o o o x o x x o o)
+  (o x x x x x x x o o o o o x x o o x o o)
+  (o o o o x x o o o o o o o x o x o x o o)
+  (o o o o x x o o o o o o o x o x o x o o)
+  (o o o o x x o o o o o o o x x x o x o o)
+  (o o o o x x o o o o o o o x x o o x o o)
+  (o o o o x x o o o o o o o x x x x x o o)
+  (o o o o x x o o o o o o o o x o o x o o)
+  (o o o o x x o o o o o o o x x o o x o o)
+  (o o o x x x x o o o o o o x o o o x o o)
+  (o o x x x x x x x x x x x x x x x x x x)
+  (o o x x x x x x x x x x x x x x x x x x)))
+
+("Hattori 26"
+ ((1 1 1 2)
+  (2 2 2 2)
+  (9 4)
+  (1 1 1 3)
+  (2 1 1 3 2)
+  (3 1 1 1 4 2)
+  (1 1 1 2 1 2)
+  (1 4 5 1 2)
+  (1 4 5 1 2)
+  (1 8 1 3)
+  (1 8 1 3)
+  (1 8 1 3)
+  (1 7 1 3)
+  (2 7 2 3)
+  (1 1 7 1 3)
+  (2 7 2 3)
+  (2 1 1 1 1 3)
+  (7 2 9)
+  (16)
+  (1 1 6))
+ ((2 1)
+  (3)
+  (5 2)
+  (2 4 1)
+  (7 2 2)
+  (3 5 4)
+  (2 2 9 2)
+  (1 10 2)
+  (2 2 7 2)
+  (1 9 2)
+  (1 2 10 1)
+  (2 9 2)
+  (15 3)
+  (5 4)
+  (2 3 3)
+  (2 9 3)
+  (2 3)
+  (2 11)
+  (20)
+  (20))
+ ((o o o o o x o o o o o o x o o x o o x x)
+  (o o o o o x x o o o o x x o o x x o x x)
+  (o o o o x x x x x x x x x o o o x x x x)
+  (o o o o x o o o x o o o x o o o o x x x)
+  (o o o x x o x o o o x o x x x o o o x x)
+  (o o x x x o x o x o x o x x x x o o x x)
+  (o o x o x o o o x o o o x x o x o o x x)
+  (o o x o x x x x o x x x x x o x o o x x)
+  (o o x o x x x x o x x x x x o x o o x x)
+  (o o x o o x x x x x x x x o o x o x x x)
+  (o o o x o x x x x x x x x o o x o x x x)
+  (o o o x o x x x x x x x x o o x o x x x)
+  (o o o x o o x x x x x x x o o x o x x x)
+  (o o o x x o x x x x x x x o x x o x x x)
+  (x o o o x o x x x x x x x o x o o x x x)
+  (x x o o o x x x x x x x o x x o o x x x)
+  (o x x o o x o x o o x o o x o o o x x x)
+  (x x x x x x x o x x o x x x x x x x x x)
+  (o o o o x x x x x x x x x x x x x x x x)
+  (o o o o o o o x o o o o x o x x x x x x)))
+
+("Hattori 27"
+ ((6)
+  (8)
+  (1 6)
+  (10)
+  (2 1 1 1 1)
+  (2 1 1 1 1)
+  (1 1 1 3)
+  (3 3 1)
+  (3 2)
+  (1 2 2)
+  (2 2 3 2)
+  (2 3 3 2)
+  (2 3 2 6)
+  (5 3 7)
+  (4 4 3 1)
+  (7 2 3 3)
+  (6 4 3 1 1)
+  (9 3 2)
+  (8 6)
+  (11 5))
+ ((11)
+  (10)
+  (7)
+  (8)
+  (4 3 5)
+  (1 5 3 6)
+  (1 1 1 2 2 3)
+  (2 6 2 4)
+  (4 1 3 2 1)
+  (9 2 2 1)
+  (4 1 2 2 1)
+  (8 3)
+  (4 1 3)
+  (5 3 3)
+  (7)
+  (13)
+  (7 2)
+  (2 2 2)
+  (1 1 3)
+  (7))
+ ((o o o o o o o x x x x x x o o o o o o o)
+  (o o o o o x x x x x x x x o o o o o o o)
+  (o o o o x o o o x x x x x x o o o o o o)
+  (o o o o x x x x x x x x x x o o o o o o)
+  (o o o o x x o x o x o x o x o o o o o o)
+  (o o o o x x o x o x o x o x o o o o o o)
+  (o o o o o x o x o x o x x x o o o o o o)
+  (o o o o o x x x o x x x o o o x o o o o)
+  (o o o o o o o x x x o o o o o x x o o o)
+  (x o o o o o o o o o x x o o o x x o o o)
+  (x x o o o x x o o o x x x o o x x o o o)
+  (x x o o x x x o o o o x x x o x x o o o)
+  (x x o x x x o o x x o o x x x x x x o o)
+  (x x x x x o o x x x o o o x x x x x x x)
+  (x x x x o x x x x o o o o o x x x o o x)
+  (x x x x x x x o o x x o o x x x o x x x)
+  (x x x x x x o x x x x o o x x x o x o x)
+  (x x x x x x x x x o o o o x x x o o x x)
+  (x x x x x x x x o o o o o o x x x x x x)
+  (x x x x x x x x x x x o o o o x x x x x)))
+
+("Hattori 28"
+ ((1 1)
+  (5)
+  (3 3)
+  (8)
+  (9)
+  (1 1 3 3)
+  (1 1 3 1)
+  (4 4 1)
+  (2 2 2 3 1)
+  (5 2 2 1)
+  (5 3 1)
+  (6 3 1)
+  (5 5 2)
+  (4 3 3 2)
+  (8 2 3 2)
+  (7 3 6)
+  (6 3 6)
+  (5 3 6)
+  (5 3 5)
+  (7 4))
+ ((2 1)
+  (3 4 1)
+  (3 1 5 1)
+  (10 1)
+  (14)
+  (3 4)
+  (4 4 1)
+  (9 5 1)
+  (8 5 1)
+  (8 2 1)
+  (2 2 6 6)
+  (4 5 6)
+  (4 4 5)
+  (4 3)
+  (3 7)
+  (2 6)
+  (5)
+  (5)
+  (7)
+  (12))
+ ((o o o o o o o o x o x o o o o o o o o o)
+  (o o o o o o o o x x x x x o o o o o o o)
+  (o o o o o o o x x x o x x x o o o o o o)
+  (o o o o o o o x x x x x x x x o o o o o)
+  (o o o o o o o x x x x x x x x x o o o o)
+  (o o x o x o o x x x o o o x x x o o o o)
+  (o o x o x o o x x x o o o o o o o o o x)
+  (o x x x x o o x x x x o o o o o o o o x)
+  (x x o x x o x x o x x x o o o o o o o x)
+  (x x x x x o x x o o x x o o o o o o o x)
+  (o o o x x x x x o o x x x o o o o o o x)
+  (o x x x x x x o o o x x x o o o o o o x)
+  (o x x x x x o o o x x x x x o o o o x x)
+  (o x x x x o o x x x o o x x x o o o x x)
+  (o x x x x x x x x o x x o x x x o o x x)
+  (o o x x x x x x x o x x x o x x x x x x)
+  (o o o x x x x x x o x x x o x x x x x x)
+  (o o o o x x x x x o x x x o x x x x x x)
+  (x x x x x o o o o o x x x o x x x x x o)
+  (o o o o o o x x x x x x x o x x x x o o)))
+
+("Hattori 29"
+ ((2)
+  (2)
+  (2)
+  (4)
+  (3 2)
+  (5 2 2)
+  (1 1 2 2)
+  (5 2 2)
+  (5 2 4)
+  (5 2 3)
+  (6 2 2)
+  (1 1 4 1)
+  (1 1 2 3 1)
+  (2 2 1 4)
+  (2 2 3 1 2)
+  (1 4 5 3)
+  (1 17)
+  (4 4 4 2)
+  (5 5 5)
+  (3 3))
+ ((8)
+  (6 2 1)
+  (1 4 3)
+  (1 4 5)
+  (1 4 2 2)
+  (15)
+  (6)
+  (2)
+  (2 4)
+  (4 2 1)
+  (3 2 3 1)
+  (3 2 5 1)
+  (2 2 2 2 5)
+  (1 2 3 2)
+  (2 2 3)
+  (2 2 5)
+  (2 5 2)
+  (2 2 5)
+  (3 2 3)
+  (7))
+ ((o o o o o o o o o o o o x x o o o o o o)
+  (o o o o o o o o o o o x x o o o o o o o)
+  (o o o o o o o o o o x x o o o o o o o o)
+  (o o o o o o o o o x x x x o o o o o o o)
+  (o o o o o o o o x x x o x x o o o o o o)
+  (o x x x x x o o x x o o o x x o o o o o)
+  (o x o o o x o o o x x o o o x x o o o o)
+  (o x x x x x o o o o x x o o o x x o o o)
+  (o x x x x x o o o o o x x o o o x x x x)
+  (o x x x x x o o o o o o x x o o o x x x)
+  (x x x x x x o o o o o o o x x o o o x x)
+  (x o o o o x o o o o o o x x x x o o o x)
+  (x o o o o x o o o o o x x o o x x x o x)
+  (x x o o o x x o o o o x o o o o x x x x)
+  (x x o o o x x o o o x x x o o o x o x x)
+  (x o o x x x x o x x x x x o o x x x o o)
+  (x o x x x x x x x x x x x x x x x x x o)
+  (x x x x o x x x x o o o x x x x o x x o)
+  (o o x x x x x o x x x x x o x x x x x o)
+  (o o o x x x o o o o o o o o o x x x o o)))
+
+("Hattori 30"
+ ((3 6)
+  (6 7)
+  (7 6)
+  (19)
+  (7 6)
+  (3 3)
+  (1 3)
+  (2 4 4 1)
+  (9 6 2)
+  (1 2 2 1 3 2)
+  (1 2 1 2 1 1 3 1)
+  (1 2 2 1 3 1)
+  (1 6 7 1)
+  (1 4 5 1)
+  (1 3 1)
+  (1 3 5 1)
+  (2 1 8)
+  (3 7)
+  (5 6 6)
+  (5 4 5))
+ ((3 9 2)
+  (5 2 4)
+  (12 3)
+  (6 6 3)
+  (5 2 2 2)
+  (5 2 1 2)
+  (4 2 2 1)
+  (1 6 2 2)
+  (1 4 3 2)
+  (1 2 2)
+  (1 5 2)
+  (1 2 2 1)
+  (2 1 2 1 2 1)
+  (5 2 2 3)
+  (5 7 4)
+  (6 6 5)
+  (7 4 5)
+  (7 5)
+  (4 4 4)
+  (12))
+ ((o o o x x x o o o o o o x x x x x x o o)
+  (o x x x x x x o o o o o x x x x x x x o)
+  (x x x x x x x o o o o o o x x x x x x o)
+  (x x x x x x x x x x x x x x x x x x x o)
+  (x x x x x x x o o o o o o x x x x x x o)
+  (o x x x o o o o o o o o o o o x x x o o)
+  (o o x o o o o o o o o o o o o o x x x o)
+  (o x x o x x x x o o o x x x x o o o x o)
+  (x x x x x x x x x o x x x x x x o o x x)
+  (x o x x o o o x x o x o o o x x x o x x)
+  (x o x x o x o x x o x o x o x x x o o x)
+  (x o x x o o o x x o x o o o x x x o o x)
+  (x o x x x x x x o o x x x x x x x o o x)
+  (x o o x x x x o o o o x x x x x o o o x)
+  (x o o o o o o x x x o o o o o o o o o x)
+  (x o o o o o o x x x o o o x x x x x o x)
+  (x x o o o o o o x o o o x x x x x x x x)
+  (o x x x o o o o o o o o o x x x x x x x)
+  (x x x x x o x x x x x x o o x x x x x x)
+  (x x x x x o o x x x x o o o o x x x x x)))
+
+("Hattori 31"
+ ((8 7)
+  (10 8)
+  (10 9)
+  (7 1 9)
+  (5 2 3)
+  (4 4 3)
+  (4 1 3)
+  (4 1 2 3)
+  (4 2 1 2 1)
+  (4 1 1)
+  (4 1 1)
+  (3 1 1 2)
+  (3 1 2 1)
+  (4 2)
+  (4 1 3)
+  (3 2 2)
+  (3 1 2 2)
+  (1 8 2)
+  (19)
+  (20))
+ ((16 1)
+  (17 2)
+  (20)
+  (11 2 2)
+  (5 2)
+  (4 2)
+  (4 1 1 2)
+  (3 2 3)
+  (3 3)
+  (3 3 2 4)
+  (4 5 3)
+  (4 2 5)
+  (3 1 1 4)
+  (4 1 3)
+  (4 3)
+  (4 1 1 2)
+  (4 2 2)
+  (8 2 2)
+  (8 1 1 3)
+  (13 1 3))
+ ((o x x x x x x x x o o o o x x x x x x x)
+  (x x x x x x x x x x o o x x x x x x x x)
+  (x x x x x x x x x x o x x x x x x x x x)
+  (x x x x x x x o o x o x x x x x x x x x)
+  (x x x x x o o o o o x x o o o o o x x x)
+  (x x x x o o o o o o x x x x o o o x x x)
+  (x x x x o o o o o o x o o o o o o x x x)
+  (x x x x o o o x o o x x o o o o o x x x)
+  (x x x x o o x x o x o x x o o o o o o x)
+  (x x x x o o o o o x o o o o o o o o o x)
+  (x x x x o o o o o x o o o o o o o o o x)
+  (x x x o o o o o o o x o o o o x o o x x)
+  (x x x o o o x o o x x o o o o o o o o x)
+  (x x x x o o o o o x x o o o o o o o o o)
+  (x x x x o o o o o o x o o o o o o x x x)
+  (x x x o o o o o o o x x o o o o x x o o)
+  (x x x o o o o o o x o x x o o x x o o o)
+  (o o x o o o o x x x x x x x x o o o x x)
+  (o x x x x x x x x x x x x x x x x x x x)
+  (x x x x x x x x x x x x x x x x x x x x)))
+
+("Hattori 32"
+ ((11 5)
+  (11 7)
+  (11 7)
+  (9 2 2)
+  (7 3 3)
+  (7 3 3)
+  (7 3 3)
+  (1 1 3 3)
+  (1 1 4 4)
+  (2 2 4 4)
+  (1 1 4 4)
+  (2 2 4 4)
+  (1 1 4 4)
+  (1 3 1 4 4)
+  (1 1 1 4 4)
+  (2 1 2 3 3)
+  (2 1 2 3 3)
+  (5 9)
+  (3 9)
+  (3 1 1))
+ ((3)
+  (4 5)
+  (7 3 2)
+  (10 2)
+  (7 1 3)
+  (7 7)
+  (7 1 3)
+  (10 2)
+  (7 3 2)
+  (4 5)
+  (3)
+  (16)
+  (18)
+  (19)
+  (3 7 2)
+  (3 2)
+  (3 7 2)
+  (19)
+  (18)
+  (16))
+ ((x x x x x x x x x x x o o x x x x x o o)
+  (x x x x x x x x x x x o x x x x x x x o)
+  (x x x x x x x x x x x o x x x x x x x o)
+  (o x x x x x x x x x o o x x o o o x x o)
+  (o o x x x x x x x o o x x x o o o x x x)
+  (o o x x x x x x x o o x x x o o o x x x)
+  (o o x x x x x x x o o x x x o o o x x x)
+  (o o o x o o o x o o o x x x o o o x x x)
+  (o o o x o o o x o o o x x x x o x x x x)
+  (o o x x o o o x x o o x x x x o x x x x)
+  (o o x o o o o o x o o x x x x o x x x x)
+  (o x x o o o o o x x o x x x x o x x x x)
+  (o x o o o o o o o x o x x x x o x x x x)
+  (o x o o x x x o o x o x x x x o x x x x)
+  (o x o o o x o o o x o x x x x o x x x x)
+  (o x x o o x o o x x o x x x o o o x x x)
+  (o o x x o x o x x o o x x x o o o x x x)
+  (o o o x x x x x o o o x x x x x x x x x)
+  (o o o o x x x o o o o x x x x x x x x x)
+  (o o o o x x x o o o o x o o o o o o o x)))
+
+("Hattori 33"
+ ((1 1 1 1)
+  (3 3 3)
+  (3 1 5 5)
+  (6 6)
+  (6 1)
+  (4 3 2)
+  (4 4 4)
+  (4 11)
+  (17)
+  (18)
+  (18)
+  (16 1)
+  (16 1)
+  (4 5 4)
+  (2 6 2)
+  (3 2 2 1)
+  (2 2 1 1)
+  (1 1 1 1)
+  (1 1 1 1)
+  (2 2 2 2))
+ ((2)
+  (3)
+  (11)
+  (14)
+  (1 11)
+  (16)
+  (9 1)
+  (6 5)
+  (9)
+  (1 12 1)
+  (2 16)
+  (3 10)
+  (2 9 1)
+  (1 7 6)
+  (1 9)
+  (2 10 1)
+  (3 14)
+  (4 7)
+  (3 3)
+  (2 4))
+ ((o o o x o x o o o o o x o o o o o x o o)
+  (o o o x x x o o o o x x x o o o x x x o)
+  (o x x x o x o o o x x x x x o x x x x x)
+  (x x x x x x o o o o o o o o x x x x x x)
+  (x x x x x x o o o o x o o o o o o o o o)
+  (o o x x x x o o o x x x o o x x o o o o)
+  (o o x x x x o o x x x x o x x x x o o o)
+  (o o x x x x o x x x x x x x x x x x o o)
+  (o o x x x x x x x x x x x x x x x x x o)
+  (o o x x x x x x x x x x x x x x x x x x)
+  (o o x x x x x x x x x x x x x x x x x x)
+  (o o x x x x x x x x x x x x x x x x o x)
+  (o o x x x x x x x x x x x x x x x x o x)
+  (o o o x x x x o x x x x x o x x x x o o)
+  (o o o o o x x o x x x x x x o x x o o o)
+  (o o o o o x x x o x x o x x o o x o o o)
+  (o o o o o o x x o x x o o x o o x o o o)
+  (o o o o o o o x o o x o o x o o x o o o)
+  (o o o o o o o x o o x o o x o o x o o o)
+  (o o o o o o x x o x x o x x o x x o o o)))
+
+("Hattori 34"
+ ((10)
+  (14)
+  (13 1)
+  (11 3)
+  (14)
+  (1 1)
+  (15)
+  (3 3 3 1 1)
+  (1 1 1 1 1 1)
+  (1 1 1 2 3)
+  (1 11 1 2)
+  (1 2 1)
+  (2 5 1 1)
+  (2 3 2 1)
+  (5 2 1)
+  (1 4 5 1)
+  (1 4 7 1)
+  (1 16 1)
+  (8 11)
+  (6 10))
+ ((5)
+  (6 1 2)
+  (4 4 3)
+  (1 5 7)
+  (2 1 1 6)
+  (3 2 1 5)
+  (4 3 1 1 4)
+  (4 2 1 2 2)
+  (5 1 2 2 1)
+  (5 1 1 2 2)
+  (5 2 1 1 4)
+  (5 3 1 5)
+  (5 2 1 5)
+  (5 1 2 6)
+  (5 4 7)
+  (3 3 3 5)
+  (3 6 4)
+  (4 1 3)
+  (1 1 2 2)
+  (3 10))
+ ((o o o o o o o o x x x x x x x x x x o o)
+  (o o o o o o x x x x x x x x x x x x x x)
+  (o o o o o x x x x x x x x x x x x x o x)
+  (o o o o x x x x x x x x x x x o o x x x)
+  (o o x x x x x x x x x x x x x x o o o o)
+  (o o x o o o o o o o o o o o o x o o o o)
+  (o o x x x x x x x x x x x x x x x o o o)
+  (o x x x o x x x o o x x x o x o x o o o)
+  (o x o x o o x o o o o x o o x o x o o o)
+  (o x o x o o o o x o o o o x x o x x x o)
+  (o x o x x x x x x x x x x x o o x o x x)
+  (o x o o o o o o o o o o o o o x x o o x)
+  (o x x o o o x x x x x o o o o x o o o x)
+  (o o x x o o o x x x o o o o x x o o o x)
+  (x x x x x o o o o o o o o x x o o o o x)
+  (x o x x x x o o o o o x x x x x o o o x)
+  (x o o x x x x o o o x x x x x x x o o x)
+  (x o x x x x x x x x x x x x x x x x o x)
+  (x x x x x x x x o x x x x x x x x x x x)
+  (o x x x x x x o o o x x x x x x x x x x)))
+
+("Hattori 35"
+ ((3 3)
+  (1 2 2 1)
+  (1 4 2)
+  (3 1 1 4)
+  (4 3 2 2)
+  (2 2 6 4 1)
+  (8 11)
+  (2 3 2 2 2 2)
+  (5 2 3 3)
+  (4 3 3 3)
+  (1 2 3 2 1 1)
+  (4 2 2 3)
+  (2 1 2 2 4)
+  (5 1 1 3)
+  (1 4 5)
+  (3 3 4 2)
+  (19)
+  (3 3 5 3)
+  (4 4 5)
+  (13))
+ ((10)
+  (5 3 2)
+  (3 4 5)
+  (2 9 3)
+  (6 7)
+  (8 3 2)
+  (1 1 3 5)
+  (2 2 5 2 1)
+  (2 1 4 4)
+  (8 1 2)
+  (1 3 4)
+  (8 4)
+  (2 5 2 1)
+  (1 1 5 5)
+  (7 5 5)
+  (6 3 2)
+  (1 4 8)
+  (4 7 3)
+  (1 4 7)
+  (3 4 3))
+ ((o o o o o x x x o o o o x x x o o o o o)
+  (o o o o o x o x x o o x x o x o o o o o)
+  (o o o o o x o o x x x x o o x x o o o o)
+  (o o o x x x o o o x o x o o x x x x o o)
+  (o o x x x x o o o x x x o o x x o x x o)
+  (o x x o x x o x x x x x x o x x x x o x)
+  (x x x x x x x x o x x x x x x x x x x x)
+  (x x o x x x o o x x o x x o o x x o x x)
+  (x x x x x o o o x x o x x x o o x x x o)
+  (x x x x o o o x x x o o x x x o o x x x)
+  (x o x x o o x x x o o o o x x o o x o x)
+  (x x x x o o x x o o o o o x x o o x x x)
+  (x x o x o o x x o o o o o x x o x x x x)
+  (x x x x x o o x o o o o o o x o x x x o)
+  (x o x x x x o o o o o o o o o x x x x x)
+  (x x x o x x x o o o o o o x x x x o x x)
+  (o x x x x x x x x x x x x x x x x x x x)
+  (o o x x x o x x x o x x x x x o x x x o)
+  (o o o x x x x o x x x x o x x x x x o o)
+  (o o o o x x x x x x x x x x x x x o o o)))
+
+("Hattori 36"
+ ((3 3)
+  (1 6 1)
+  (1 7)
+  (1 1 2)
+  (1 2 2 1 2)
+  (1 1 1 1 1)
+  (2 2 1)
+  (2 2 1)
+  (1 2 2 2 1)
+  (1 2 2 1 1)
+  (1 1 1)
+  (4 3 1 1)
+  (2 1 1 1 1 1)
+  (13 1 1)
+  (1 1 1)
+  (2 4 1 1)
+  (11 1 1)
+  (1 4 5 1)
+  (1 1 1 1 1 1 1)
+  (5 5 6))
+ ((9)
+  (2 3 2)
+  (7 1 1 1 1)
+  (1 2 3 4)
+  (2 2 2 1 1 1)
+  (1 1 1 1 1)
+  (1 1 4)
+  (1 1 2)
+  (1 2 2 1 2 1)
+  (2 1 2 3 4)
+  (1 1 1 1 1)
+  (7 3 2 1)
+  (1 2 1 1 3)
+  (1 2 1 1)
+  (1 8 3)
+  (1 1 1)
+  (1 5)
+  (2 1)
+  (2 1)
+  (16))
+ ((o o x x x o o o o x x x o o o o o o o o)
+  (o o x o x x x x x x o x o o o o o o o o)
+  (o o x o o o o o o o o x x x x x x x o o)
+  (o o x o o o o o o o o x o o o o o x x o)
+  (o o x o x x o o x x o x o o o o o o x x)
+  (o o x o x o o o x o o x o o o o o o o x)
+  (o x x o o o o o o o o x x o o o o o o x)
+  (x x o o o o o o o o o o x x o o o o o x)
+  (x o o x x o o o x x o o o x x o o o o x)
+  (x o o x x o o o x x o o o o x o o o o x)
+  (x o o o o o o o o o o o o o x o o o o x)
+  (x x x x o o o o o x x x o o x o o o o x)
+  (x x o x o o o o o x o x o o x o o o o x)
+  (x x x x x x x x x x x x x o x o o o o x)
+  (x o o o o o o o o o o o o o x o o o o x)
+  (x x o o o o o o o o o x x x x o x o o x)
+  (o x x x x x x x x x x x o o o o x o o x)
+  (o o o x o o x x x x o o x x x x x o o x)
+  (o o o x o o x o o x o o x o x o x o o x)
+  (o o x x x x x o x x x x x o x x x x x x)))
+
+("Hattori 37"
+ ((6)
+  (2 3)
+  (10)
+  (1 1 1 1)
+  (1 1 1 1)
+  (8)
+  (3 1 3)
+  (15)
+  (2 10 2)
+  (1 8 1)
+  (1 2 2 1 1)
+  (2 1 2 9)
+  (3 1 2 1 4 3)
+  (1 2 2 3 3)
+  (4 5 2)
+  (2 8 1 3)
+  (1 5 2 2)
+  (2 3 1 2)
+  (9 1 2)
+  (4 2 7))
+ ((4 5)
+  (2 2 2 3)
+  (2 1 1 2)
+  (3 5 2)
+  (10 2 1)
+  (3 1 3 1 1 2)
+  (1 4 3 1 1 4)
+  (1 1 5 3 5)
+  (1 4 3 1 2 2)
+  (3 1 3 4)
+  (3 1 10)
+  (11 2)
+  (1 3 4 4)
+  (1 2 7 1)
+  (1 3 1)
+  (2 2 2)
+  (4 5)
+  (7 1)
+  (5 1)
+  (2))
+ ((o o o o o x x x x x x o o o o o o o o o)
+  (o o o o x x o o o x x x o o o o o o o o)
+  (o o o o x x x x x x x x x x o o o o o o)
+  (o o o o x o x o x o o x o o o o o o o o)
+  (o o o o x o x o x o o x o o o o o o o o)
+  (o o o o x x x x x x x x o o o o o o o o)
+  (o o x x x o o x o o o x x x o o o o o o)
+  (o x x x x x x x x x x x x x x x o o o o)
+  (x x o x x x x x x x x x x o o x x o o o)
+  (x o o o x x x x x x x x o o o o x o o o)
+  (x o o x x o o o o o x x o x o o x o o o)
+  (x x o x o o x x o o x x x x x x x x x o)
+  (o x x x o x o x x o x o x x x x o x x x)
+  (o o o x o o x x o x x o x x x o o x x x)
+  (o x x x x o o o o x x x x x o o o x x o)
+  (x x o o x x x x x x x x o x o o x x x o)
+  (x o o o o o x x x x x o x x o o x x o o)
+  (x x o o o x x x o o o o x o o o x x o o)
+  (x x x x x x x x x o o o x o o x x o o o)
+  (x x x x o o o x x o o o x x x x x x x o)))
+
+("Hattori 38"
+ ((6 6)
+  (9 8)
+  (3 5 3)
+  (2 2 1)
+  (1)
+  (1)
+  (2 1)
+  (1 4)
+  (9 3)
+  (11 2)
+  (14 2)
+  (8 3 2)
+  (8 1 4 2)
+  (8 5 3)
+  (20)
+  (12 7)
+  (1 1 1 1 2 5)
+  (1 1 1 1 3 4)
+  (13 3)
+  (16))
+ ((2 6 1)
+  (3 11)
+  (2 8 2)
+  (3 12)
+  (2 8 2)
+  (2 12)
+  (2 8 2)
+  (2 12)
+  (3 3 2 2)
+  (3 3 1 6)
+  (2 1 4 6)
+  (2 7 3)
+  (3 5 2)
+  (2 6 1)
+  (2 5 1)
+  (2 7)
+  (2 2 6)
+  (3 3 6)
+  (2 11)
+  (2 10))
+ ((o o o x x x x x x o o o x x x x x x o o)
+  (o x x x x x x x x x o x x x x x x x x o)
+  (o x x x o o o o x x x x x o o o o x x x)
+  (x x o o o o o o o x x o o o o o o o o x)
+  (x o o o o o o o o o o o o o o o o o o o)
+  (o o o o o o o o o o x o o o o o o o o o)
+  (o o o o o o o o o o o o o o o o x x o x)
+  (o o o o o o o o o o x o o o o o x x x x)
+  (o o x x x x x x x x x o o o o o o x x x)
+  (o x x x x x x x x x x x o o o o o o x x)
+  (x x x x x x x x x x x x x x o o o o x x)
+  (x x x x x x x x o o o x x x o o o o x x)
+  (x x x x x x x x o x o x x x x o o o x x)
+  (x x x x x x x x o o o x x x x x o x x x)
+  (x x x x x x x x x x x x x x x x x x x x)
+  (x x x x x x x x x x x x o x x x x x x x)
+  (o x o x o x o x o x x o o o x x x x x o)
+  (o x o x o x o x o x x x o o o x x x x o)
+  (x x x x x x x x x x x x x o o x x x o o)
+  (o x x x x x x x x x x x x x x x x o o o)))
+
+("Hattori 39"
+ ((2)
+  (1)
+  (10 9)
+  (10 7 1)
+  (10 5 3)
+  (8 8)
+  (7 4 2)
+  (7 2 2 4)
+  (7 2 7)
+  (2 1)
+  (1)
+  (1 4)
+  (1 1 1)
+  (1 2 1 1 1)
+  (2 2 1 4 1)
+  (2 1 1 4 2)
+  (3 4 1 1)
+  (1 1)
+  (1 2 2 1)
+  (18))
+ ((15 1)
+  (8 3)
+  (7 2 1)
+  (7 2 1)
+  (7 3 2)
+  (7 2)
+  (7 1)
+  (4 1)
+  (3 4 1)
+  (1 3 2 1 1 1)
+  (2 2 1 3 1)
+  (3 1 4 1)
+  (4 1 3 1)
+  (7 4 1)
+  (7 1)
+  (5 1 1)
+  (2 4 2)
+  (4 2 1 2)
+  (1 5 1 1)
+  (8 6))
+ ((o o o o o o o o o x x o o o o o o o o o)
+  (o o o o o o o o o o x o o o o o o o o o)
+  (x x x x x x x x x x o x x x x x x x x x)
+  (x x x x x x x x x x o x x x x x x x o x)
+  (x x x x x x x x x x o x x x x x o x x x)
+  (x x x x x x x x o o o o x x x x x x x x)
+  (x x x x x x x o o o o o o x x x x o x x)
+  (x x x x x x x o o x x o o x x o x x x x)
+  (x x x x x x x o o x x o o x x x x x x x)
+  (x x o o o o o o o o o o o o o o o o o x)
+  (x o o o o o o o o o o o o o o o o o o o)
+  (x o o o o o o o o x x x x o o o o o o o)
+  (x o o o o o o o x o o o o x o o o o o o)
+  (x o o x x o o o x o o x o x o o o o o o)
+  (x x o x x o o o x o x x x x o o o o o x)
+  (x x o o x o o o x o x x x x o o o o x x)
+  (x x x o o o o o o x x x x o o o o x o x)
+  (o o x o o o o o o o o o o o o o o o o x)
+  (x o o o x x o o o o o o o o o o x x o x)
+  (o o x x x x x x x x x x x x x x x x x x)))
+
+("Hattori 40"
+ ((8)
+  (3 8)
+  (3 1 4 2)
+  (4 1 1 2)
+  (1 1 1 1 3 4)
+  (1 1 1 1 3)
+  (1 1 1 1 1)
+  (1 1 4)
+  (2 1 1)
+  (1 5 2 1)
+  (3 1 3 3)
+  (3 1 3 1)
+  (3 2 3 3)
+  (3 3 1)
+  (1 1 1 1 3)
+  (1 5 1 1)
+  (11 2)
+  (1 1 3)
+  (13 5)
+  (13 6))
+ ((2)
+  (5 3 4)
+  (1 9 2)
+  (2 4 1 2)
+  (1 2 3 2)
+  (3 1 2 2)
+  (1 4 2 2)
+  (4 1 1 2 2)
+  (1 2 3 2)
+  (6 4 1 2)
+  (1 8 2)
+  (6 3 4)
+  (3 2)
+  (4)
+  (5 4 1)
+  (3 4 1 2)
+  (2 1 1 5 2)
+  (2 4 1 1 3)
+  (3 1 1 1 4)
+  (3 1 5))
+ ((o o o o o o o o o o o o x x x x x x x x)
+  (o o o o o o o x x x o o x x x x x x x x)
+  (o o o o o x x x o x o o x x x x o o x x)
+  (o o x x x x o x o x o o o x x o o o o o)
+  (o x o x o x o x o x x x o o x x x x o o)
+  (o x o o o o o o o x o x o o o x o x x x)
+  (o x o o o o o o o x o x o o o x o x o o)
+  (o x o o o o o o o o o x o o x x x x o o)
+  (o x x o o o o o o o o x o o x o o o o o)
+  (o o x o x x x x x o x x o o x o o o o o)
+  (o o x x x o x o x x x o o o x x x o o o)
+  (o x x x o o x o o x x x o o o o x o o o)
+  (o x x x o o x x o x x x o o o o x x x o)
+  (o x x x o o o o o x x x o o o o x o o o)
+  (o o x o x o o o x o x o o o o o x x x o)
+  (o o x o x x x x x o x o o o o o o o o x)
+  (o x x x x x x x x x x x o o o o o o x x)
+  (o x o o o o o o o o o x o o o o o x x x)
+  (x x x x x x x x x x x x x o o x x x x x)
+  (x x x x x x x x x x x x x o x x x x x x)))
+
+("Hattori 41"
+ ((6 1 3)
+  (5 1)
+  (3)
+  (2)
+  (2 2 2)
+  (1 4 4)
+  (2 2 3 2)
+  (5 6)
+  (3 5)
+  (2 3)
+  (1 4 1)
+  (1 2 3 3)
+  (1 2 3 1)
+  (2 2 1)
+  (2 3)
+  (2 5)
+  (1 5)
+  (1 6)
+  (1 1 1 1 1 1 1 6)
+  (1 1 1 1 1 1 1 6))
+ ((6 10)
+  (5 3)
+  (3 2)
+  (2 2)
+  (2 4 2)
+  (1 2 2)
+  (5 2 2)
+  (3 3)
+  (2 2)
+  (4)
+  (1 4 2)
+  (2 3)
+  (4 2)
+  (6)
+  (2 3 3)
+  (5 5)
+  (3 5)
+  (1 2 6)
+  (1 1 6)
+  (2 9))
+ ((x x x x x x o o o o x o o o o o o x x x)
+  (x x x x x o o o o o o o o o o o o o o x)
+  (x x x o o o o o o o o o o o o o o o o o)
+  (x x o o o o o o o o o o o o o o o o o o)
+  (x x o o o x x o o o o o o x x o o o o o)
+  (x o o o x x x x o o o o x x x x o o o o)
+  (o o o x x o x x o o o x x x o x x o o o)
+  (o o o x x x x x o o o x x x x x x o o o)
+  (o o o o x x x o o o o o x x x x x o o o)
+  (o o o o o o o o x x o o o x x x o o o o)
+  (x o o o o o o x x x x o o o o o o x o o)
+  (x o o o o o x x o x x x o o o o o x x x)
+  (x o o o o o x x o x x x o o o o o o o x)
+  (x x o o o o o o o o x x o o o o o o o x)
+  (x x o o o o o o o o o o o o o o o x x x)
+  (x x o o o o o o o o o o o o o x x x x x)
+  (x o o o o o o o o o o o o o o x x x x x)
+  (x o o o o o o o o o o o o o x x x x x x)
+  (x o x o x o x o x o x o x o x x x x x x)
+  (x o x o x o x o x o x o x o x x x x x x)))
+
+("Hattori 42"
+ ((9)
+  (3 6)
+  (3 1 6)
+  (4 1 1 4)
+  (4 5)
+  (6 1 7)
+  (4 2 2 4)
+  (3 6 3)
+  (2 1 2 2 3)
+  (1 1 1 1 2)
+  (1 6 1)
+  (1 4 2)
+  (1 1 2)
+  (3 2 2 3)
+  (10 2 1)
+  (9 1 1)
+  (10 3 2)
+  (15 1)
+  (11 2 1)
+  (7 3))
+ ((2)
+  (5 2)
+  (7 4)
+  (12 5)
+  (6 7)
+  (2 6 6)
+  (1 2 2 2 6)
+  (2 1 2 10)
+  (4 5 7)
+  (3 3 2 6)
+  (9 1 2 4)
+  (6 2 3 3)
+  (6 2 3)
+  (10 2)
+  (6 3)
+  (4 2)
+  (5)
+  (2 2)
+  (1 1 1)
+  (7))
+ ((o o o x x x x x x x x x o o o o o o o o)
+  (o o o x x x o x x x x x x o o o o o o o)
+  (o o x x x o x o x x x x x x o o o o o o)
+  (o x x x x o x o x o x x x x o o o o o o)
+  (o x x x x o o o o o x x x x x o o o o o)
+  (x x x x x x o x o x x x x x x x o o o o)
+  (x x x x o x x o o x x o x x x x o o o o)
+  (o x x x o x x x x x x o o x x x o o o o)
+  (o o x x o x o x x o x x o x x x o o o o)
+  (o o o x o x o o x o o x o x x o o o o o)
+  (o o o x o x x x x x x o o x o o o o o o)
+  (o o o x o o x x x x o o x x o o o o o o)
+  (o o o o x o o x o o o x x o o o o o o o)
+  (o o o x x x o x x o x x o o o o o x x x)
+  (o o x x x x x x x x x x o o o o x x o x)
+  (o x x x x x x x x x o o o o o o x o o x)
+  (o x x x x x x x x x x o o o x x x o x x)
+  (o o x x x x x x x x x x x x x x x o o x)
+  (o o o o x x x x x x x x x x x o x x o x)
+  (o o o o o o x x x x x x x o o o o x x x)))
+
+("Hattori 43"
+ ((5)
+  (3 3 3)
+  (1 2 4 1)
+  (2 10)
+  (1 1 3 1)
+  (2 1 3 2 2 1)
+  (2 1 5 1 1 1)
+  (2 7 1)
+  (3 7 3 2)
+  (3 7 3 2)
+  (4 6 2 2)
+  (4 7 2)
+  (5 11)
+  (5 1 4 3)
+  (3 4 3 3 2)
+  (4 2 3 2)
+  (2 3 1)
+  (2 2 1)
+  (2 1)
+  (5))
+ ((3 3)
+  (3 4)
+  (9)
+  (8)
+  (6 3)
+  (5 9)
+  (3 3 5)
+  (1 5 1)
+  (2 7 1 1)
+  (1 10 1 1)
+  (1 11 6)
+  (13 2 1)
+  (2 1 7 1)
+  (3 1 3)
+  (2 2 2 4)
+  (2 3 4)
+  (3 2 3 1 2)
+  (1 1 1 3)
+  (3 7)
+  (8 2))
+ ((o o o o o o o o x x x x x o o o o o o o)
+  (o o o o o o x x x o o x x x o o x x x o)
+  (o o o o o o x o o o x x o x x x x o x o)
+  (o o o o o x x o o o x x x x x x x x x x)
+  (x o o o o x o o o x x x o o o o o o o x)
+  (x x o o o x o o o x x x o x x o x x o x)
+  (x x o o o x o x x x x x o o x o x o o x)
+  (o x x o o x x x x x x x o o o o o o o x)
+  (o o x x x o x x x x x x x o x x x o x x)
+  (o o x x x o x x x x x x x o x x x o x x)
+  (o o x x x x o x x x x x x o o x x o x x)
+  (o o x x x x o o x x x x x x x o o x x o)
+  (o o x x x x x o x x x x x x x x x x x o)
+  (o o x x x x x o o x o o x x x x o x x x)
+  (o x x x o x x x x o x x x o x x x o x x)
+  (x x x x o x x o o x x x o o o x x o o o)
+  (x x o o x x x o o o x o o o o o o o o o)
+  (x x o o x x o o o o x o o o o o o o o o)
+  (o o o o x x o o o o x o o o o o o o o o)
+  (o o o o o o o o x x x x x o o o o o o o)))
+
+("Hattori 44"
+ ((5)
+  (5 6)
+  (2 2 6 1)
+  (6 6 2)
+  (8 5 3)
+  (2 1 1 5 5)
+  (11 6)
+  (4 5 7)
+  (13)
+  (9)
+  (4 6)
+  (5 3 4)
+  (4 5 1 2)
+  (2 4 3 3)
+  (1 5 1 3)
+  (6 2 3)
+  (6 3 3)
+  (5 3 2)
+  (4 3 1)
+  (3 3))
+ ((4 4 4)
+  (4 3 5)
+  (2 2 3 6)
+  (7 3 5)
+  (4 1 3 5)
+  (1 8 5)
+  (4 4 5)
+  (4 8)
+  (7)
+  (6 2 4)
+  (3 4 7)
+  (3 6 5)
+  (4 5)
+  (5 2 2)
+  (5 3 2)
+  (4 4 2)
+  (4 4 3)
+  (3 5 3)
+  (2 5 3)
+  (5 3))
+ ((o o o o o o o o o o o o o o x x x x x o)
+  (o o o x x x x x o o o o o x x x x x x o)
+  (o o o x x o x x o o o o x x x x x x o x)
+  (o o x x x x x x o o o x x x x x x o x x)
+  (x x x x x x x x o o x x x x x o o x x x)
+  (x x o x o x o o o x x x x x o x x x x x)
+  (x x x x x x x x x x x o o o x x x x x x)
+  (x x x x o x x x x x o o x x x x x x x o)
+  (o o o o o x x x x x x x x x x x x x o o)
+  (o o o o x x x x x x x x x o o o o o o o)
+  (o o x x x x o x x x x x x o o o o o o o)
+  (x x x x x o x x x o x x x x o o o o o o)
+  (x x x x o x x x x x o x o x x o o o o o)
+  (x x o o x x x x o x x x o o x x x o o o)
+  (x o x x x x x o o o x o o o o x x x o o)
+  (o x x x x x x o o o x x o o o o x x x o)
+  (x x x x x x o o o x x x o o o o o x x x)
+  (x x x x x o o o o x x x o o o o o o x x)
+  (x x x x o o o o o x x x o o o o o o o x)
+  (x x x o o o o o o x x x o o o o o o o o)))
+
+("Hattori 45"
+ ((8 3)
+  (3 11)
+  (9 1 3)
+  (1 6)
+  (2 7 2)
+  (2 1 4)
+  (4 5 3)
+  (3 5)
+  (1 2 3 2)
+  (1 6)
+  (11 1)
+  (3 5)
+  (3 6 3)
+  (4 6 4)
+  (4 15)
+  (3 7 4)
+  (8 3)
+  (1 2 5)
+  (5 5)
+  (4))
+ ((1)
+  (1 1 1)
+  (1 2 1)
+  (2 3 2 3)
+  (3 3 1 1 1)
+  (2 1 1 4 2)
+  (2 1 1 6 1)
+  (4 4 3 1)
+  (4 4 6)
+  (11 7)
+  (8 8)
+  (8 9)
+  (2 6 9)
+  (2 1 3 9)
+  (2 1 1 2 1 4)
+  (2 1 1 3)
+  (3 2)
+  (1 1 1 5 1)
+  (1 1 1 1 1 5)
+  (1 1 1 1 1 1 5))
+ ((o o o o o o o x x x x x x x x o o x x x)
+  (o x x x o x x x x x x x x x x x o o o o)
+  (o o o x x x x x x x x x o o o x o x x x)
+  (o o o o x o o x x x x x x o o o o o o o)
+  (o o o x x o o o o x x x x x x x o o x x)
+  (o o x x o o x o o x x x x o o o o o o o)
+  (o x x x x o o o o x x x x x o o o x x x)
+  (o o o o x x x o o x x x x x o o o o o o)
+  (o o o o x o o o x x o o x x x o o o x x)
+  (o o o x o o x x x x x x o o o o o o o o)
+  (o o o x x x x x x x x x x x o o o o o x)
+  (o o o o o o x x x o x x x x x o o o o o)
+  (o o o o o x x x o x x x x x x o o x x x)
+  (o o o x x x x o x x x x x x o o x x x x)
+  (x x x x o x x x x x x x x x x x x x x x)
+  (o o o x x x o x x x x x x x o o x x x x)
+  (o o o o o o o x x x x x x x x o o x x x)
+  (o o o o o x o o x x o x x x x x o o o o)
+  (o o o o o x x x x x o o x x x x x o o o)
+  (o o o o o o o o o o o o o o x x x x o o)))
+
+("Hattori 46"
+ ((5)
+  (4 8)
+  (15)
+  (3 10)
+  (2 9)
+  (1 1 1 1 3 5)
+  (1 1 6 2 4)
+  (1 2 2 4 3)
+  (4 4 3 1)
+  (3 2 1 2 3 1)
+  (1 1 4 3 2)
+  (1 2 2 1 2 2)
+  (2 5 2 1)
+  (3 6 1)
+  (10 4 2)
+  (6 5 1)
+  (2 2 2)
+  (2 2 2)
+  (5 6)
+  (2 13))
+ ((10)
+  (2 2 3)
+  (2 1 3 2 1)
+  (2 2 1 2 2)
+  (2 3 2 2 1)
+  (2 1 3 1 5)
+  (2 8 5)
+  (2 3 3 2 2)
+  (1 2 3 1 3 1)
+  (3 2 1 2 2 1)
+  (6 2 1 3 3)
+  (14 1 2)
+  (12 3 2)
+  (5 3 2)
+  (5 2 3 2)
+  (5 3 2 2)
+  (6 1 1 1 1)
+  (5 2 1)
+  (5 3 1)
+  (5 3 1))
+ ((o o o o o o o o o o x x x x x o o o o o)
+  (o o o o x x x x o x x x x x x x x o o o)
+  (o o x x x x x x x x x x x x x x x o o o)
+  (o x x x o o o o o x x x x x x x x x x o)
+  (x x o o o o o o o o x x x x x x x x x o)
+  (x o o o x o x o x o x x x o o x x x x x)
+  (x o x o x x x x x x o x x o o o x x x x)
+  (x o o x x o x x o x x x x o o o o x x x)
+  (x x x x o x x x x o x x x o o o o o o x)
+  (x x x o o x x o x o o x x o x x x o o x)
+  (x o x o o x x x x o x x x o x x o o o o)
+  (x o o x x o x x o x o x x o o x x o o o)
+  (x x o o x x x x x o x x o o o o o o o x)
+  (x x x o o o o o o x x x x x x o o o o x)
+  (o x x x x x x x x x x o x x x x o o x x)
+  (o o o x x x x x x o o x x x x x o o x o)
+  (o o o o o x x o x x o o o o o o o x x o)
+  (o o o o o x x o o x x o o o o o x x o o)
+  (o o o x x x x x o o x x x x x x o o o o)
+  (o o x x o o o x x x x x x x x x x x x x)))
+
+("Hattori 47"
+ ((12)
+  (2 3)
+  (1 8 3)
+  (1 3 3 2)
+  (1 2 2 2)
+  (1 2 2 2)
+  (1 3 2)
+  (11 3)
+  (7 7)
+  (3 3)
+  (3 2)
+  (1 1)
+  (3 1)
+  (2 1 2 1 1)
+  (6 2 1 1)
+  (2 1 5 5 1)
+  (2 1 1 1 1 1 1 1)
+  (2 1 1 2 1 1 1)
+  (2 3 3)
+  (2 2))
+ ((7)
+  (7)
+  (6 1)
+  (2 1 4)
+  (1 7 1)
+  (1 7 3)
+  (1 2 5 1 2)
+  (1 1 2 5 1 2 1)
+  (1 1 2 4 1 2)
+  (1 1 2 4)
+  (1 1 2 2)
+  (1 2 1 2)
+  (1 1 1 1)
+  (1 1 2 4)
+  (2 1 1)
+  (1 1 3)
+  (2 1 1)
+  (1 3 4)
+  (9 2)
+  (17))
+ ((o o o x x x x x x x x x x x x o o o o o)
+  (o o x x o o o o o o o o o o x x x o o o)
+  (o o x o x x x x x x x x o o o o x x x o)
+  (o o x o x x x o o o o x x x o o o o x x)
+  (o o x o x x o x x o o o o o o o o o x x)
+  (o o x o x x o x x o o o o o o o o o x x)
+  (o o x o x x x o o o o o o o o o o o x x)
+  (o o o x x x x x x x x x x x o o o x x x)
+  (o o o o x x x x x x x o o x x x x x x x)
+  (o o o o o o x x x o o o o o o o o x x x)
+  (o o o o o o x x x o o o o o o o o o x x)
+  (o o o o o o o x o o o o o o o o o o o x)
+  (o o o o o o o o o o o x x x o o o o o x)
+  (x x o o o o o x o o x x o x o o o o o x)
+  (x x x x x x o o o x x o o x o o o o o x)
+  (x x o x o x x x x x o o o x x x x x o x)
+  (x x o x o x o x o x o o o o o x o x o x)
+  (x x o x o o x o x x o o o o o x o x o x)
+  (x x o o o o x x x o o o o o o o o x x x)
+  (x x o o o o o o o o o o o o o o o o x x)))
+
+("Hattori 48"
+ ((5 3)
+  (10 1 1)
+  (5 4)
+  (3)
+  (7 3)
+  (14)
+  (16)
+  (5 4)
+  (4 3)
+  (3 3 3 2)
+  (1 1 3 2 2 1)
+  (1 1 4 1 3 1)
+  (1 1 4 1 3 1)
+  (1 4 4 2)
+  (1 3)
+  (2 4)
+  (3 6)
+  (18)
+  (16)
+  (12))
+ ((1 10)
+  (1 3 4)
+  (1 4 3)
+  (1 4 3)
+  (1 3 2 3)
+  (3 3 1 1 3)
+  (3 3 1 3 3)
+  (3 3 5 3)
+  (3 3 5 3)
+  (3 3 3 3)
+  (3 3)
+  (3 4 3)
+  (3 2 1 3)
+  (2 1 3 4)
+  (2 5 4)
+  (4 3 3)
+  (6 4)
+  (5 3 4)
+  (1 2 3 4)
+  (3 8))
+ ((o o o o o x x x x x o o o o o o o x x x)
+  (x x x x x x x x x x o o o o o o o x o x)
+  (o o o o o x x x x x o o o o o o x x x x)
+  (o o o o o o o o o o o o o o o o x x x o)
+  (o o o o o o x x x x x x x o o x x x o o)
+  (o o o x x x x x x x x x x x x x x o o o)
+  (o o x x x x x x x x x x x x x x x x o o)
+  (o x x x x x o o o o o o o o o x x x x o)
+  (x x x x o o o o o o o o o o o o o x x x)
+  (x x x o o o x x x o o o x x x o o o x x)
+  (x o o o o x o x x x o x x o x x o o o x)
+  (x o o o x o x x x x o x o x x x o o o x)
+  (x o o o x o x x x x o x o x x x o o o x)
+  (x o o o o x x x x o o x x x x o o o x x)
+  (x o o o o o o o o o o o o o o o o x x x)
+  (x x o o o o o o o o o o o o o o x x x x)
+  (x x x o o o o o o o o o o x x x x x x o)
+  (x x x x x x x x x x x x x x x x x x o o)
+  (o x x x x x x x x x x x x x x x x o o o)
+  (o o o x x x x x x x x x x x x o o o o o)))
+
+("Hattori 49"
+ ((2 2)
+  (2 2)
+  (3 3 3 3)
+  (5 8 5)
+  (3 3 3 3)
+  (2 1 1 4 1 1 2)
+  (2 1 8 1 2)
+  (1 2 2 1)
+  (1 1 1 1 1 1 1 1)
+  (2 2 1 1)
+  (1 1 1 1 2 1 1)
+  (2 1 1 1 1)
+  (1 1 1 1)
+  (1 4 1)
+  (9)
+  (7 7)
+  (1 7 1)
+  (13 1)
+  (4 4)
+  (5 5))
+ ((3)
+  (7 1)
+  (7 1 1 2)
+  (1 5)
+  (8 1 3)
+  (1 1 3 1 3)
+  (6 5 1)
+  (1 4 4)
+  (1 2 9)
+  (1 2 1 5)
+  (1 2 2 2 2)
+  (1 2 1 5)
+  (1 2 3 4)
+  (9 4)
+  (1 1 4 1)
+  (10 1 3)
+  (1 1 2)
+  (7 5)
+  (7 1 1 2)
+  (3 1))
+ ((o x x o o o o o o o o o o o o o o x x o)
+  (o x x o o o o o o o o o o o o o o x x o)
+  (x x x o x x x o o o o o o x x x o x x x)
+  (x x x x x o x x x x x x x x o x x x x x)
+  (x x x o x x x o o o o o o x x x o x x x)
+  (o x x o x o x o x x x x o x o x o x x o)
+  (o x x o x o x x x x x x x x o x o x x o)
+  (o o o o x o x x o o o o x x o x o o o o)
+  (o o x o x o o x o x o x o x o x o o x o)
+  (o o o o x x o x x o o o o x o x o o o o)
+  (o o x o o x o o x o x o x x o x o o x o)
+  (o o o o o x x o x o x o x o o x o o o o)
+  (o o o o o o x o x o o o x o x o o o o o)
+  (o o o o o o x o x x x x o o x o o o o o)
+  (o o o o o o x x x x x x x x x o o o o o)
+  (o o o x x x x x x x o x x x x x x x o o)
+  (o o o x o o o x x x x x x x o o o x o o)
+  (o o o x x x x x x x x x x x x x o x o o)
+  (o o x x x x o o o o o o o o o x x x x o)
+  (o x x x x x o o o o o o o o o x x x x x)))
+
+("Hattori 50"
+ ((1 1)
+  (1 1)
+  (2 15 1)
+  (3 2 2)
+  (3 1 4 2)
+  (2 5 1)
+  (2 1 3 3 1)
+  (1 7 2)
+  (1 1 5 1)
+  (2 1 6)
+  (3 9)
+  (5 5 3)
+  (6 4 3)
+  (4 2 5)
+  (1 2 1 6)
+  (2 1 3 6)
+  (1 2 4 6)
+  (1 3 3 6)
+  (2 1 3 3 1)
+  (4 2 2))
+ ((8 3)
+  (5 2 2)
+  (2 1 1 1 3 1)
+  (1 1 4 3)
+  (1 6 3)
+  (1 1 1 3 1)
+  (1 1 1 4)
+  (1 2 4)
+  (1 5 2)
+  (1 6 4)
+  (1 1 6 5)
+  (1 2 8 4)
+  (5 6)
+  (6 4 5)
+  (1 5 1 6)
+  (1 9)
+  (1 8)
+  (1 7)
+  (2 5 1)
+  (7 2))
+ ((x o o o o o o o o o o o o o o o o o o x)
+  (x o o o o o o o o o o o o o o o o o o x)
+  (x x o x x x x x x x x x x x x x x x o x)
+  (x x x o o o o o o o o o x x o o o o x x)
+  (x x x o o x o o o o o x x x x o o o x x)
+  (x x o o o o o o o o x x x x x o o o o x)
+  (x x o x o o o x x x o o x x x o o o o x)
+  (x o o o o x x x x x x x o x x o o o o o)
+  (o o x o x o o o x x x x x o x o o o o o)
+  (o o o x x o x o x x x x x x o o o o o o)
+  (o o x x x o o o x x x x x x x x x o o o)
+  (o o o x x x x x o x x x x x o x x x o o)
+  (o o x x x x x x o o x x x x o x x x o o)
+  (o o o o x x x x o o o x x o x x x x x o)
+  (o x o o o o x x o o o x o x x x x x x o)
+  (o x x o x o o o x x x o o x x x x x x o)
+  (o o x o x x o o x x x x o x x x x x x o)
+  (x o x x x o o o o x x x o x x x x x x o)
+  (x x o x o o o o o x x x o x x x o o o x)
+  (x x x x o o o o o o x x o o o o o o x x)))
+
+("Hattori 51"
+ ((1 1 3 3)
+  (4 2 4)
+  (6 6)
+  (3 1 7)
+  (1 2 1 8)
+  (3 2 1 8)
+  (2 1 8)
+  (4 1 9)
+  (2 1 13)
+  (2 1 2 6)
+  (1 3 1 2)
+  (1 3 2 1)
+  (4 2 1)
+  (2 3)
+  (3 2)
+  (7)
+  (1 1)
+  (2 1 2)
+  (4 1)
+  (5))
+ ((1 1 3)
+  (1 5)
+  (8)
+  (2 7)
+  (3 2 3)
+  (2 2 1 1 1)
+  (1 1 2 2 2)
+  (9 1 1 1)
+  (2 1 2 4)
+  (1 1 1 2)
+  (3 1 1)
+  (3 5)
+  (5 2 1 1)
+  (7 2 1)
+  (10 2)
+  (10 3)
+  (12)
+  (9)
+  (9)
+  (10))
+ ((o o x o x o x x x o o o o o x x x o o o)
+  (o o x x x x o x x o o o o o x x x x o o)
+  (o o x x x x x x o o o o o x x x x x x o)
+  (x x x o o o o x o o o o o x x x x x x x)
+  (o o x o x x o x o o o o x x x x x x x x)
+  (x x x o x x o x o o o o x x x x x x x x)
+  (o x x o o o o x o o o o x x x x x x x x)
+  (x x x x o o o x o o o x x x x x x x x x)
+  (x x o x o o o x x x x x x x x x x x x x)
+  (x x o x o o o o o o x x o o x x x x x x)
+  (o o o x o o o o x x x o o o o o x o x x)
+  (o o o x o o x x x o o o o o o x x o o x)
+  (o o o x x x x o o o o o o o x x o o o x)
+  (o o o x x o o o o o o o o x x x o o o o)
+  (o o o o x x x o o o o o x x o o o o o o)
+  (o o o o o o x x x x x x x o o o o o o o)
+  (o o o o o o o o x o o x o o o o o o o o)
+  (o o o o o x x o x o o x x o o o o o o o)
+  (o o o o o o x x x x o x o o o o o o o o)
+  (o o o o o o o o o x x x x x o o o o o o)))
+
+("Hattori 52"
+ ((5 6)
+  (2 4 2)
+  (2 6 2)
+  (2 2 2 2)
+  (2 2 2 1 1)
+  (1 2 2 2 1 1)
+  (1 2 2 1 2 1)
+  (1 2 3 5 4)
+  (1 3 2 1 1 1)
+  (1 8 4 1)
+  (1 3 1 3 1)
+  (1 2 1 1 1 1)
+  (1 1 2 2 2 1)
+  (1 13 1)
+  (7 2 1 1)
+  (3 2 1)
+  (2 2 3 2)
+  (2 1 1 2 3)
+  (4 1 1)
+  (2 1 1))
+ ((12)
+  (2 3)
+  (2 7)
+  (2 3 2 2 2)
+  (2 5 2 2)
+  (1 7 1 2)
+  (1 3 1 3 3)
+  (1 5 1)
+  (2 7)
+  (5 1 2)
+  (10 2)
+  (3 1 2 3 1)
+  (1 1 2 1 1 1 2)
+  (1 1 2 1 1 1 1)
+  (1 2 2 1 2 2)
+  (2 4 1 1 1 1)
+  (2 1 1 1)
+  (2 3 3)
+  (5 2)
+  (13))
+ ((o o o o x x x x x o x x x x x x o o o o)
+  (o o o x x o o o x x x x o o o x x o o o)
+  (o o x x o o o o o x x x x x x o x x o o)
+  (o x x o o o o o o x x o o o x x o x x o)
+  (x x o o o o o o o x x o x x o x o o x o)
+  (x o o o o o x x o x x o x x o x o o x o)
+  (x o o x x o x x o o x o o o x x o o x o)
+  (x o o x x o x x x o x x x x x o x x x x)
+  (x o o x x x o x x o x o o o o o o x o x)
+  (x o o o x x x x x x x x o o x x x x o x)
+  (x o o x x x o o x o o x x x o o o o o x)
+  (x o x x o x o o x o o o o o o o x o o x)
+  (x o x o o x x o x x o o o o x x o o o x)
+  (x o x x x x x x x x x x x x x o o o o x)
+  (x x x x x x x o o o x x o o o x o o o x)
+  (x x x o o o o o o o o x x o o o o o o x)
+  (o x x o o x x o o o o o x x x o o o x x)
+  (o o x x o o x o o o o x o o x x o x x x)
+  (o o o x x x x o o o o o o o o o o x o x)
+  (o o o o x x o o o o o o o o o o o x o x)))
+
+("Hattori 53"
+ ((1 1 1)
+  (3 1 1 1)
+  (1 3 3 3)
+  (4 4 1)
+  (11)
+  (4 4 3)
+  (1 1 2 1 2 1 1 1 1)
+  (4 3 3 3)
+  (2 4 4 4 1)
+  (1 1 2 1 2 1 2 2)
+  (4 3 3 3)
+  (18)
+  (2 2)
+  (1 1 1 1 1 1 1 1)
+  (15)
+  (3 3)
+  (3 4 3 3)
+  (2 2 2 3)
+  (2 1 3 1 3 1 2)
+  (1 2 1 1 1 2 1))
+ ((1 5 4)
+  (3 2 3 4)
+  (1 2 8)
+  (1 2 2 2 2)
+  (3 2 1 2 2 1)
+  (4 2 1 1 1 2)
+  (4 2 2 2 1 1)
+  (4 2 3 1 1 2)
+  (1 4 2 2 2)
+  (3 2 1 1 2)
+  (1 5 2 1 2)
+  (5 2 2 1 2)
+  (3 2 3 2 1 1)
+  (3 2 2 1 1 2)
+  (3 2 1 2 2 1)
+  (1 2 1 2 2)
+  (1 3 7)
+  (3 1 4 3)
+  (1 6 3)
+  (3))
+ ((o x o o o o o o x o x o o o o o o o o o)
+  (x x x o o o o x o o o x o o o o o x o o)
+  (o x o o o o x x x o x x x o o o x x x o)
+  (o o o o o x x x x o x x x x o o o x o o)
+  (o o o o x x x x x x x x x x x o o o o o)
+  (o o o x x x x o x x x x o x x x o o o o)
+  (x o x o x x o x o x x o x o x o x o x o)
+  (x x x x o o x x x o o x x x o o x x x o)
+  (x x o x x x x o x x x x o x x x x o x o)
+  (x o x o x x o x o x x o x o x x o x x o)
+  (x x x x o o x x x o o x x x o o x x x o)
+  (o x x x x x x x x x x x x x x x x x x o)
+  (o x x o o o o o o o o o o o o o x x o o)
+  (o o x o x o x o x o x o x o x o x o o o)
+  (o o x x x x x x x x x x x x x x x o o o)
+  (o x x x o o o o o o o o o o o x x x o o)
+  (x x x o x x x x o o o o x x x o x x x o)
+  (x x o x x o o o o o o o o o x x o x x x)
+  (x x o x o x x x o x o x x x o x o o x x)
+  (x o o o x x o x o x o x o x x o o o o x)))
+
+("Hattori 54"
+ ((3 3)
+  (7 1 1 1 1)
+  (2 2 3 3)
+  (2 2 1 1)
+  (2 3 2 2 1)
+  (1 2 2 1 1 1)
+  (1 2 2 2 1 1)
+  (1 1 1 2 1 4)
+  (1 1 3 1 7)
+  (1 1 1 2 2 6)
+  (1 1 2 1 1 8)
+  (1 2 1 3 5)
+  (2 2 2 2 6)
+  (1 3 1 7)
+  (2 1 7)
+  (3 10)
+  (14)
+  (12 1)
+  (12 2)
+  (12 4))
+ ((9 1)
+  (2 3 1)
+  (2 6 2 2)
+  (2 2 2 1 2)
+  (1 2 3 2 2 2)
+  (1 1 2 1 1 4)
+  (1 2 2 2 4)
+  (1 2 4 4)
+  (1 2 4)
+  (2 3 5)
+  (2 11)
+  (2 2 5)
+  (3 2 5)
+  (3 3 1 6)
+  (1 3 3 6)
+  (3 14)
+  (11 1)
+  (3 10 1)
+  (1 14 2)
+  (3 6 3))
+ ((o o o o o o o o o o o o o x x x o x x x)
+  (o o o x x x x x x x o o o x o x o x o x)
+  (o o x x o o o o o x x o o x x x o x x x)
+  (o x x o o o o o o o x x o o x o o o x o)
+  (x x o o x x x o o o o x x o x x o o x o)
+  (x o o x x o x x o o o o x o o x o o x o)
+  (x o x x o o o x x o o o x x o x o o x o)
+  (x o x o o x o o x x o o o x o x x x x o)
+  (x o x o x x x o o x o o o x x x x x x x)
+  (x o x o x o x x o x x o o o x x x x x x)
+  (x o x o x x o x o o x o x x x x x x x x)
+  (x o x x o o o x o o x x x o o x x x x x)
+  (x x o x x o x x o o x x o o x x x x x x)
+  (o x o o x x x o o o x o o x x x x x x x)
+  (o x x o o o o o o o x o x x x x x x x o)
+  (o o x x x o o o o x x x x x x x x x x o)
+  (o o o o x x x x x x x x x x x x x x o o)
+  (o o o o o x x x x x x x x x x x x o o x)
+  (o o x x x x x x x x x x x x o o o o x x)
+  (x x x x x x x x x x x x o o o o x x x x)))
+
+("Hattori 55"
+ ((2 4 2)
+  (4 7 4)
+  (1 14 1)
+  (1 11 1)
+  (2 11 2)
+  (1 2 4 1 1)
+  (1 3 4 2 2)
+  (2 11 1)
+  (1 9 1)
+  (1 13 1)
+  (1 1 7 3)
+  (5 6 1)
+  (1 2 5 2)
+  (3 2 3 2 1)
+  (1 1 3 1)
+  (2 1 5 1)
+  (2 1 5 1 1)
+  (1 1 1 1)
+  (1 1 1 1 1 1 1 1)
+  (7 7))
+ ((4 5 2)
+  (2 4 1 4)
+  (2 1 1)
+  (2 9)
+  (1 3 1)
+  (6 1 2)
+  (8 1 1 1)
+  (4 5 2 2 2)
+  (5 6 2 1)
+  (12 5)
+  (17)
+  (16)
+  (14 4)
+  (4 6 1)
+  (3 4 2 2)
+  (6 1 1 1)
+  (2 1 2)
+  (1 3 1)
+  (2 3 1 8)
+  (5 5))
+ ((o x x o o o o o x x x x o o o o o o x x)
+  (x x x x o o o x x x x x x x o o x x x x)
+  (x o o x x x x x x x x x x x x x x o o x)
+  (x o o o o x x x x x x x x x x x o o o x)
+  (x x o o o x x x x x x x x x x x o o x x)
+  (o x o o o x x o o x x x x o o x o o x o)
+  (o x o o o x x x o x x x x o x x o o x x)
+  (x x o o o x x x x x x x x x x x o o o x)
+  (x o o o o o x x x x x x x x x o o o o x)
+  (x o o o x x x x x x x x x x x x x o o x)
+  (x o o o x o o x x x x x x x o o o x x x)
+  (x x x x x o o o x x x x x x o o o x o o)
+  (o o o x o o o x x o x x x x x o o x x o)
+  (o x x x o o x x o o x x x o x x o o x o)
+  (o x o x o o o o o o x x x o o o o o x o)
+  (x x o x o o o x x x x x o o o o o o x o)
+  (x x o x o o x x x x x o x o o o o o x o)
+  (o o o x o o o o o x o o x o o o o o x o)
+  (o o o x o x o x o x o o x o x o x o x o)
+  (o o o x x x x x x x o o x x x x x x x o)))
+
+("Hattori 56"
+ ((2 3)
+  (2 4)
+  (2 5)
+  (8)
+  (11)
+  (2 7)
+  (4 1 2 4)
+  (11 1)
+  (2 9 1)
+  (1 8 1)
+  (1 6 2)
+  (1 6 1)
+  (1 8 1)
+  (8 1 2 3)
+  (7 2 1 2)
+  (5 1 3)
+  (1 2)
+  (2 2 1)
+  (4 1)
+  (2))
+ ((6)
+  (2 2)
+  (2 4 1)
+  (10 2)
+  (10 1)
+  (10 1)
+  (9 2)
+  (10 1)
+  (2 6)
+  (1 3 3)
+  (1 4 6)
+  (8 1)
+  (6)
+  (1 4 4)
+  (9 4)
+  (7 2)
+  (7 2)
+  (6 2)
+  (4 1)
+  (1))
+ ((o o o o o o o o o o o o x x o x x x o o)
+  (o o o o o o o o o o o x x o o x x x x o)
+  (o o o o o o o o o o o x x o x x x x x o)
+  (o o o o o o o o o o o x x x x x x x x o)
+  (o o o o o o o o x x x x x x x x x x x o)
+  (o o o o o o o x x o o x x x x x x x o o)
+  (o o x x x x o x o o x x o x x x x o o o)
+  (o x x x x x x x x x x x o o x o o o o o)
+  (x x o x x x x x x x x x o o x o o o o o)
+  (x o o x x x x x x x x o o o x o o o o o)
+  (x o o x x x x x x o o o o x x o o o o o)
+  (x o o x x x x x x o o o o x o o o o o o)
+  (x o x x x x x x x x o o o x o o o o o o)
+  (x x x x x x x x o x o o o x x o o x x x)
+  (o x x x x x x x o x x o o o x o x x o o)
+  (o o x x x x x o o o x o o o x x x o o o)
+  (o o o o o o o o o o x o o o x x o o o o)
+  (o o x x o o x x o o x o o o o o o o o o)
+  (o o o x x x x o o o x o o o o o o o o o)
+  (o o o o o o o o o o x x o o o o o o o o)))
+
+("Hattori 57"
+ ((2 6)
+  (3 1 1 4)
+  (3 2 3 3)
+  (6 7)
+  (6 2)
+  (5 2 2 3)
+  (3 1 2 1 3)
+  (3 1 1 2 2)
+  (11 2 1)
+  (4 3 5)
+  (1 2 9 3)
+  (2 6 5 1)
+  (5 3 3 1)
+  (1 5 3 1)
+  (1 2 2 5)
+  (9 3 1)
+  (2 2 3 1)
+  (2 14 1)
+  (2 2 2)
+  (2 2 3))
+ ((2 3 2)
+  (4 1 2 4)
+  (6 1 2 2 2)
+  (7 2 1 2 1)
+  (5 2 1 2 1 2)
+  (2 3 1 1 1 1 3)
+  (1 3 1 1 1 1 1 1)
+  (2 1 6 1)
+  (2 10)
+  (1 6 3)
+  (1 4 1)
+  (1 1 1 1)
+  (2 1 4 1)
+  (1 2 2 4 1)
+  (1 2 7 2)
+  (1 1 2 9 1)
+  (2 1 1 2 7 1)
+  (4 2 1 2 2 3)
+  (6 1 1 2 1)
+  (5 2 3 4))
+ ((o o o o o x x o o o o o o x x x x x x o)
+  (o o o x x x o x o o o o x o o o x x x x)
+  (o o x x x o x x o o o o x x x o o x x x)
+  (o x x x x x x o o o o o o x x x x x x x)
+  (o x x x x x x o o o o o o o o o o o x x)
+  (o x x x x x o o x x o o x x o o o x x x)
+  (o x x x o o o o x o x x o x o x x x o o)
+  (o o x x x o o o o x o o x o x x o o x x)
+  (o o o o x x x x x x x x x x x o x x o x)
+  (x x x x o o o o x x x o x x x x x o o o)
+  (x o o x x o o x x x x x x x x x o x x x)
+  (o x x o o x x x x x x o o x x x x x o x)
+  (x x x x x o o x x x o o o o x x x o o x)
+  (x o o o x x x x x o o o o o x x x o x o)
+  (x o x x o o o x x o o o o o o x x x x x)
+  (o x x x x x x x x x o o o o o x x x o x)
+  (x x o o o o o o x x o o o o x x x o o x)
+  (x x o o x x x x x x x x x x x x x x o x)
+  (o x x o x x o o o o o o o o o o o x x o)
+  (o o x x o x x o o o o o o o o x x x o o)))
+
+("Hattori 58"
+ ((1 2 2)
+  (1 2 1)
+  (5 3)
+  (4 2)
+  (3 1)
+  (3 1)
+  (7 2 1)
+  (1 8 6)
+  (3 9)
+  (3 6 2 3)
+  (9 8)
+  (5 6 1)
+  (2 8 1)
+  (10)
+  (12)
+  (1 8)
+  (1 9)
+  (1 2 4)
+  (1 2)
+  (2 4))
+ ((3 2)
+  (2 1)
+  (1 2 3)
+  (5 2)
+  (5 2)
+  (4 2 1)
+  (7 6)
+  (1 7 1)
+  (3 9)
+  (2 6 2 3)
+  (9 8)
+  (4 6 1)
+  (2 7 1)
+  (10 1)
+  (11)
+  (2 8)
+  (2 9)
+  (1 2 5)
+  (1 2)
+  (2 3))
+ ((x o x x o o o x x o o o o o o o o o o o)
+  (x o o x x o o o x o o o o o o o o o o o)
+  (x x x x x o o o x x x o o o o o o o o o)
+  (o x x x x o o o o x x o o o o o o o o o)
+  (o o o x x x o o o o x o o o o o o o o o)
+  (o o o o x x x o o o x o o o o o o o o o)
+  (o o o o o x x x x x x x o o o x x o o x)
+  (x o o o o x x x x x x x x o x x x x x x)
+  (x x x o o o x x x x x x x x x o o o o o)
+  (o o x x x o x x x x x x o x x o x x x o)
+  (o o x x x x x x x x x o x x x x x x x x)
+  (o o o o o x x x x x o x x x x x x o o x)
+  (o o o o o o o x x o x x x x x x x x o x)
+  (o o o o o o o o x x x x x x x x x x o o)
+  (o o o o o o x x x x x x x x x x x x o o)
+  (o o o o o o x o o o x x x x x x x x o o)
+  (o o o o o o x o o x x x x x x x x x o o)
+  (o o o o o o x o o x x o o x x x x o o o)
+  (o o o o o o x o o x x o o o o o o o o o)
+  (o o o o o x x o o o x x x x o o o o o o)))
+
+("Hattori 59"
+ ((6)
+  (2 2)
+  (2 2 6)
+  (1 2 2 1 2 2)
+  (1 1 1 1 1 1)
+  (1 2 8)
+  (2 2 2 1 1)
+  (8 1 2)
+  (3 3 2 1)
+  (3 2 1 2)
+  (2 2 1 1)
+  (1 14)
+  (2 3 4)
+  (1 2 4)
+  (1 2 2 4)
+  (4 3 4)
+  (3 4 4)
+  (3 4 4)
+  (9 3)
+  (3 4 2))
+ ((5 2)
+  (2 2 2)
+  (2 1 3)
+  (1 2 4)
+  (1 3 9)
+  (1 2 1 2 5)
+  (1 1 1 1 5)
+  (2 3 1 2 1)
+  (2 7 1 1)
+  (4 4 4)
+  (2 5)
+  (12)
+  (6 9)
+  (2 1 1)
+  (1 1 9)
+  (1 1 9)
+  (1 1 8)
+  (1 1 9)
+  (2 1 3)
+  (5))
+ ((o o x x x x x x o o o o o o o o o o o o)
+  (o x x o o o o x x o o o o o o o o o o o)
+  (x x o o o o o o x x o o o x x x x x x o)
+  (x o x x o x x o o x o o x x o o o o x x)
+  (x o o x o x o o o x o o x o o o o o o x)
+  (x o o o o o o o x x o o x x x x x x x x)
+  (x x o x x o o x x o o o x o o o o o o x)
+  (o x x x x x x x x o o o x o o o o o x x)
+  (o o x x x o o x x x o x x o o o o o x o)
+  (o x x x o o o o x x o x o o o o o x x o)
+  (x x o o o o o o x x o x o o o o o x o o)
+  (x o o o x x x x x x x x x x x x x x o o)
+  (o o o o x x o o o o x x x o x x x x o o)
+  (o o o o x o o o o o o x x o x x x x o o)
+  (o o o o x o o x x o o x x o x x x x o o)
+  (o o o o x x x x o o x x x o x x x x o o)
+  (o o o o x x x o o x x x x o x x x x o o)
+  (o o o o x x x o o x x x x o x x x x o o)
+  (o o o o x x x x x x x x x o x x x o o o)
+  (o o o o x x x o o x x x x o x x o o o o)))
+
+("Hattori 60"
+ ((3)
+  (2 2 6)
+  (1 1 3 8)
+  (2 2 2 9)
+  (2 2 1 1 10)
+  (1 1 2 2 1 4)
+  (2 2 2 5 3)
+  (3 1 3 1 1 1 1 1)
+  (2 2 4 1 3 1)
+  (1 1 5 1 1)
+  (5 1 1 1)
+  (1 1 3 2)
+  (2 1 4 1)
+  (2 1 3)
+  (2 1 1)
+  (2 3 5)
+  (2 1 1 3)
+  (5 1 8)
+  (1 10)
+  (2 9))
+ ((3 3)
+  (4 3 3)
+  (2 1 1 1 2 2)
+  (1 1 1 3 1 2)
+  (2 4 3 2 3)
+  (3 1 1 1 3 1)
+  (1 1 1 2 2)
+  (2 5 1)
+  (3 11)
+  (2 1)
+  (1 4)
+  (9 2)
+  (3 1 1 3)
+  (3 3 5 3)
+  (4 1 1 2 1 3)
+  (4 3 2 1 3)
+  (5 1 1 3)
+  (7 5)
+  (6 1 4)
+  (12 4))
+ ((o o x x x o o o o o o o o o o o o o o o)
+  (o x x o x x o o o o o o o o x x x x x x)
+  (o x o x o x x x o o o o x x x x x x x x)
+  (o x x o x x o x x o o x x x x x x x x x)
+  (x x o x x o x o x o x x x x x x x x x x)
+  (x o x o x x o x x o o x o o o o x x x x)
+  (x x o x x o x x o o o x x x x x o x x x)
+  (o x x x o x o x x x o x o x o x o x o x)
+  (x x o x x o x x x x o x o x x x o o o x)
+  (x o x o x x x x x o o x o o o o o o o x)
+  (x x x x x o o o x o o x o o o o o o o x)
+  (o x o o o o o o x o o x x x o o o o x x)
+  (o x x o o o o o x o o o o x x x x o o x)
+  (o o x x o o o o x o o o o x x x o o o o)
+  (o o o x x o o o x o o o o x o o o o o o)
+  (o o o o x x o o x x x o o x x x x x o o)
+  (o o o o o x x o x o x o o o o o o x x x)
+  (o o o o x x x x x o x o x x x x x x x x)
+  (o o o o x o o o o o x x x x x x x x x x)
+  (o o o o x x o o o o o x x x x x x x x x)))
+
+("Hattori 61"
+ ((6)
+  (2 3)
+  (5 1 3)
+  (6 4)
+  (10)
+  (11)
+  (1 8)
+  (1 7)
+  (1 5 1)
+  (1 5 3)
+  (2 5 4)
+  (3 4 5)
+  (4 4 6)
+  (5 4 5)
+  (5 3 5)
+  (3 2 2 5)
+  (1 2 5)
+  (2 5)
+  (2 7)
+  (11 2))
+ ((1)
+  (2)
+  (2)
+  (2 5)
+  (4 5)
+  (6 6 1)
+  (1 11 1)
+  (1 1 2 3 1)
+  (1 2 2 1)
+  (7 3 2 1)
+  (7 5 3)
+  (14 2)
+  (13 1)
+  (7 3 2)
+  (5 2 2)
+  (4 10)
+  (2 10)
+  (12)
+  (11)
+  (8))
+ ((o o o o o x x x x x x o o o o o o o o o)
+  (o o o o x x o o o x x x o o o o o o o o)
+  (o x x x x x o x o x x x o o o o o o o o)
+  (x x x x x x o o o x x x x o o o o o o o)
+  (o o o o x x x x x x x x x x o o o o o o)
+  (o o o o o x x x x x x x x x x x o o o o)
+  (o o o o o o x o o x x x x x x x x o o o)
+  (o o o o o o x o o o o x x x x x x x o o)
+  (o o o o o o x o o o o x x x x x o x o o)
+  (o o o o o o x o o o x x x x x o x x x o)
+  (o o o o o x x o o x x x x x o x x x x o)
+  (o o o o x x x o o x x x x o x x x x x o)
+  (o o o x x x x o o x x x x o x x x x x x)
+  (o o o x x x x x o o x x x x o x x x x x)
+  (o o o x x x x x o o o x x x o x x x x x)
+  (o o o x x x o x x o o o x x o x x x x x)
+  (o o o x o o o o x x o o o o o x x x x x)
+  (o o o o o o o o o x x o o o o x x x x x)
+  (o o o o o o o o o o x x o x x x x x x x)
+  (o o o o o x x x x x x x x x x x o o x x)))
+
+("Hattori 62"
+ ((3 5 2)
+  (1 3 1 1 3)
+  (2 3 1 1 3)
+  (1 2 1 3)
+  (1 1 2 4)
+  (2 3 1 4)
+  (2 1 5)
+  (5 1 5)
+  (3 1 2 2 5)
+  (9 2 5)
+  (8 1 5)
+  (5 2 2 5)
+  (4 1 2 5)
+  (2 1 1 1 1 5)
+  (1 8 1 7)
+  (5 1 2 6)
+  (1 1 1 6)
+  (1 1 6)
+  (1 4 2 4)
+  (4 1))
+ ((6)
+  (6 1)
+  (2 5 2)
+  (12 1)
+  (4 1 3 2 2)
+  (1 1 4 4 1)
+  (2 1 1 3 1 2)
+  (1 2 5 3 1)
+  (2 1 2 1 2)
+  (1 2 1)
+  (3 1)
+  (1 1 3 3)
+  (1 2 2 2 2 1)
+  (1 5 3 3)
+  (5 4)
+  (13)
+  (15)
+  (18)
+  (19)
+  (17))
+ ((o o o o x x x o o o x x x x x o o o x x)
+  (o o o o x o x x x o x o o o x o o x x x)
+  (o o o o x x o o x x x o x o x o o x x x)
+  (o o o o x o o o o o o x x o x o o x x x)
+  (o o o x o o o x o o o o o x x o x x x x)
+  (o o x x o o x x x o o o o x o o x x x x)
+  (o o x x o o o o o o o o o x o x x x x x)
+  (o o o x x x x x o o o o o x o x x x x x)
+  (o x x x o x o x x o o o x x o x x x x x)
+  (x x x x x x x x x o o x x o o x x x x x)
+  (x x x x x x x x o o o x o o o x x x x x)
+  (x x x x x o x x o o o x x o o x x x x x)
+  (x x x x o o o o o o x o x x o x x x x x)
+  (x x o x o o o o o x o x o x o x x x x x)
+  (x o x x x x x x x x o x o x x x x x x x)
+  (o x x x x x o x o o o x x o x x x x x x)
+  (o o o o o x o x o o o o x o x x x x x x)
+  (o o o o o x o o x o o o o x x x x x x o)
+  (o o o o x o x x x x o o x x o x x x x o)
+  (o o o x x x x o o o o o o x o o o o o o)))
+
+("Hattori 63"
+ ((5)
+  (7)
+  (1 1)
+  (2 2)
+  (1 1)
+  (1 1 1)
+  (7)
+  (9)
+  (2 4 2)
+  (16)
+  (3 4 3)
+  (5)
+  (3 2)
+  (2 2)
+  (2 2)
+  (3 2)
+  (1 3 1)
+  (20)
+  (1 1)
+  (1 1))
+ ((1 4)
+  (1 1)
+  (2 1)
+  (1 1)
+  (1 1)
+  (2 1)
+  (3 1 1)
+  (1 2 1 4 1)
+  (8 1 5 1)
+  (2 1 7 1)
+  (2 7 2)
+  (2 1 12)
+  (18)
+  (1 2 1 1)
+  (3 1)
+  (2 1)
+  (1 1)
+  (2 1)
+  (1 1)
+  (1 4))
+ ((o o o o o o o o x x x x x o o o o o o o)
+  (o o o o o o o x x x x x x x o o o o o o)
+  (o o o o o o o o x o o o x o o o o o o o)
+  (o o o o o o o o x x o x x o o o o o o o)
+  (o o o o o o o o x o o o x o o o o o o o)
+  (o o o o o o o o x o x o x o o o o o o o)
+  (o o o o o o o x x x x x x x o o o o o o)
+  (o o o o o o x x x x x x x x x o o o o o)
+  (o o o o o x x o o x x x x o x x o o o o)
+  (o o x x x x x x x x x x x x x x x x o o)
+  (x x x o o o o o o x x x x o o o o x x x)
+  (o o o o o o o o x x x x x o o o o o o o)
+  (o o o o o o o x x x o x x o o o o o o o)
+  (o o o o o o o x x o o x x o o o o o o o)
+  (o o o o o o o x x o o x x o o o o o o o)
+  (o o o o o o x x x o o x x o o o o o o o)
+  (x o o o o o o o o o x x x o o o o o o x)
+  (x x x x x x x x x x x x x x x x x x x x)
+  (x o o o o o o o o o o o o o o o o o o x)
+  (x o o o o o o o o o o o o o o o o o o x)))
+
+("Hattori 64"
+ ((4)
+  (19)
+  (1 5)
+  (3)
+  (9)
+  (2 1 4 2)
+  (2 1 3 1 2)
+  (1 1 3 9 1)
+  (1 5 7 2 1)
+  (1 1 2 3 2)
+  (3 3 3)
+  (2 1 4)
+  (7)
+  (1 1 1)
+  (11 1)
+  (1 1 1)
+  (1 1 1)
+  (12 5 1)
+  (2 3 3 3 1)
+  (3 4 2 2))
+ ((1 5 2 3)
+  (2 2 2 1 3)
+  (2 2 8 1 1)
+  (2 1 1 1 1 1)
+  (2 1 2 3 1 2)
+  (1 7 1 1 3)
+  (1 1 6 1 3)
+  (1 2 2 1 1 1)
+  (1 12 1 1)
+  (11 1 2)
+  (1 8 1 2)
+  (1 2 3)
+  (1 2 1)
+  (2 2 3)
+  (2 2 2)
+  (2 1 4)
+  (2 3 2)
+  (2 1 2 4)
+  (1 2 1 1)
+  (3 3))
+ ((o x x x x o o o o o o o o o o o o o o o)
+  (x x x x x x x x x x x x x x x x x x x o)
+  (o o o o o o o o o x o o o x x x x x o o)
+  (o o o o o o o o x x x o o o o o o o o o)
+  (o o x x x x x x x x x o o o o o o o o o)
+  (o x x o o x o x x x x o o o o o o x x o)
+  (x x o o o x o o x x x o o o o o x o x x)
+  (x o x o x x x o x x x x x x x x x o o x)
+  (x o x x x x x o x x x x x x x o x x o x)
+  (x o x o o x x o x x x o o o o o o x x o)
+  (x x x o x x x o x x x o o o o o o o o o)
+  (o x x o x o x x x x o o o o o o o o o o)
+  (o o x x x x x x x o o o o o o o o o o o)
+  (x o x o o o o o x o o o o o o o o o o o)
+  (x x x x x x x x x x x o o o o o o x o o)
+  (o o o o o o o o o o o o o x o x o x o o)
+  (o o o o o o o o o o o o o x o x o x o o)
+  (x x x x x x x x x x x x o x x x x x o x)
+  (x x o o x x x o o x x x o o x x x o o x)
+  (x x x o o x x x x o o x x o o o o o x x)))
+
+("Hattori 65"
+ ((4 3)
+  (3 1 4)
+  (3 6)
+  (12)
+  (8)
+  (8)
+  (1 1 7 3)
+  (2 1 5 1)
+  (6 1 5)
+  (1 2 2 1 2 1)
+  (1 1 2 1 2 3)
+  (2 1 2)
+  (5)
+  (3)
+  (6)
+  (1 1 2 1 2 3)
+  (1 1 1 2 1 2 1)
+  (1 1 3 1 5)
+  (5 3 1)
+  (1 1 5 3))
+ ((5 4)
+  (2 2)
+  (2 3)
+  (5 2)
+  (1 1 4)
+  (1 2 1)
+  (4 2 2)
+  (1 5 2 2)
+  (8 2 2 1)
+  (1 5 3 2)
+  (17)
+  (5 3 2)
+  (6 2 1 1)
+  (7 2 2)
+  (6 2 2)
+  (4 2 2)
+  (3 1 1)
+  (2 5 3 1)
+  (1 1 1 1 1 1)
+  (1 1 1 1 3))
+ ((o o o o o o x x x x o o o x x x o o o o)
+  (o o o o x x x o x o o o o x x x x o o o)
+  (o o o o o o x x x o o o x x x x x x o o)
+  (o o o o o o x x x x x x x x x x x x o o)
+  (o o o o o o o x x x x x x x x o o o o o)
+  (o o o o o o o x x x x x x x x o o o o o)
+  (x o o x o o o x x x x x x x o o o x x x)
+  (x x o x o o o o x x x x x o o o o x o o)
+  (x x x x x x o o o o x o o o o x x x x x)
+  (x o x x o x x o o o x o o o x x o x o o)
+  (x o o x o o x x o o x o o x x o o x x x)
+  (o o o o o o o x x o x o x x o o o o o o)
+  (o o o o o o o o x x x x x o o o o o o o)
+  (o o o o o o o o o x x x o o o o o o o o)
+  (o o o o o o o o x x x x x x o o o o o o)
+  (x o o o x o o x x o x o o x x o o x x x)
+  (x o x o x o x x o o x o o o x x o x o o)
+  (x o x o x x x o o o x o o o o x x x x x)
+  (x x x x x o o o o x x x o o o o o o o x)
+  (o x o x o o o o x x x x x o o o o x x x)))
+
+("Hattori 66"
+ ((4 6)
+  (2 3)
+  (3 1 4 2)
+  (2 4 1)
+  (2 1 3 3)
+  (2 1 3)
+  (2 1 3 3 7)
+  (1 5 9)
+  (2 1 3 3 7)
+  (1 2 1 3)
+  (2 1 2 2)
+  (1 3 2)
+  (3 1 3 1 1)
+  (3 2 3)
+  (4 6 3)
+  (3)
+  (9)
+  (2 6)
+  (3 1 2)
+  (11))
+ ((1 1 1 1 1 1 1 1)
+  (1 1 1 1 1 1 1 1)
+  (1 1 1 1)
+  (1 5 1)
+  (3 2)
+  (2 4 2)
+  (1 4 1)
+  (2 3 2)
+  (1 2 1 1)
+  (1 3 3 3 1 2)
+  (1 5 5 1 3)
+  (1 3 3 2 1 4)
+  (2 1 2 1 1)
+  (1 3 1 1 1)
+  (2 3 1 4)
+  (3 3 2 5 1)
+  (14 1)
+  (6 5 1)
+  (5 4)
+  (3 4))
+ ((x x x x o o o x x x x x x o o o o o o o)
+  (o o o o o o x x o o o o x x x o o o o o)
+  (x x x o o x o o x x x x o o x x o o o o)
+  (o o o o x x o o x x x x o o o x o o o o)
+  (x x o o x o o o o x x x o o o x x x o o)
+  (o o o x x o o o o o x o o o o o x x x o)
+  (x x o x o x x x o x x x o x x x x x x x)
+  (o o o x o x x x x x o x x x x x x x x x)
+  (x x o x o x x x o x x x o x x x x x x x)
+  (o o o x o x x o o o x o o o o o x x x o)
+  (x x o o x o o o o x x o o o o x x o o o)
+  (o o o o x o o o o x x x o o o x x o o o)
+  (x x x o o x o o o x x x o o x o x o o o)
+  (o o o o o x x x o o o o x x o x x x o o)
+  (x x x x o o o x x x x x x o o x x x o o)
+  (o o o o o o o o o o o o o o o x x x o o)
+  (o o o o o o o o o o o x x x x x x x x x)
+  (o o o o o o o o o o x x o o x x x x x x)
+  (o o o o o o o o o x x x o o x o o o x x)
+  (o o o o o o o o o x x x x x x x x x x x)))
+
+("Hattori 67"
+ ((3 4 2)
+  (3 6 2)
+  (2 8 1)
+  (1 2)
+  (8)
+  (2 5 1 3)
+  (2 5 1 2 2)
+  (4 1 1 2)
+  (3 4 1 2 1)
+  (1 1 7 1 3)
+  (3 5 1 1 1)
+  (11 2 2)
+  (1 1 4 1 1)
+  (3 7 3)
+  (4 3 1)
+  (4 1 1)
+  (1 4 3 2)
+  (1 1 6 1 1 2)
+  (1 2 12)
+  (2 2 1 2 2))
+ ((6 3)
+  (1 2 1 1)
+  (2 6 3)
+  (4 2 1 2)
+  (3 8 1)
+  (2 12)
+  (14)
+  (15)
+  (1 4 3 1 3)
+  (2 3 1 1 1 2)
+  (3 2 5 3)
+  (5 2)
+  (9 1 1)
+  (3 1 3 5)
+  (2 1 3 1 1 1)
+  (1 3 1 1 4)
+  (1 1 2)
+  (2 2 1 1 2)
+  (2 2 1 1 1 2)
+  (10))
+ ((o o o x x x o o o o x x x x o o x x o o)
+  (o o o x x x o o o x x x x x x o o x x o)
+  (o o o x x o o o x x x x x x x x o o x o)
+  (o o o x o o o o o o o x x o o o o o o o)
+  (o o o o o o o o x x x x x x x x o o o o)
+  (o o x x o o x x x x x o x o o x x x o o)
+  (o o x x o x x x x x o o x o x x o x x o)
+  (o o o o o x x x x o o o x o x o o o x x)
+  (x x x o x x x x o o o o x o x x o o o x)
+  (x o x o x x x x x x x o o x o o o x x x)
+  (x x x o x x x x x o x o o x o o o o o x)
+  (x x x x x x x x x x x o x x o o o o x x)
+  (x o x o x x x x o o x o o o o o o o o x)
+  (x x x o x x x x x x x o o o o o o x x x)
+  (o o o o x x x x o o o o o x x x o o o x)
+  (o o o o x x x x o o o o o x o o o o o x)
+  (o o x o o x x x x o o o o x x x o o x x)
+  (x o x o o x x x x x x o o x o x o x x o)
+  (x o x x o o x x x x x x x x x x x x o o)
+  (x x o x x o o x o o x x o o o x x o o o)))
+
+("Hattori 68"
+ ((8)
+  (3 2 2)
+  (2 1 1 2)
+  (2 2 1 1)
+  (1 1 2 2)
+  (1 6 3)
+  (2 2 1 3 2)
+  (5 3 4)
+  (1 4 7)
+  (1 9)
+  (1 9)
+  (1 6 3)
+  (1 6 2)
+  (1 2 2)
+  (2 2 1)
+  (2 2 1)
+  (3 2 1)
+  (6 1)
+  (4 6)
+  (6 5))
+ ((4)
+  (2 2)
+  (2 2)
+  (1 3)
+  (2 3)
+  (1 1 1 2)
+  (2 1 1)
+  (4 1 7 1)
+  (1 6 2 2)
+  (1 1 2 2)
+  (1 2 1 4 1 2)
+  (2 1 1 7 4)
+  (2 1 8 1 1)
+  (5 5 3)
+  (2 6 3)
+  (8 3)
+  (5 3)
+  (5 2)
+  (5 2)
+  (9))
+ ((o o o o x x x x x x x x o o o o o o o o)
+  (o o x x x o x x o o o x x o o o o o o o)
+  (o x x o o x o x o o o o x x o o o o o o)
+  (x x o o o o o x x o x o o x o o o o o o)
+  (x o o o o o o o x o x x o x x o o o o o)
+  (x o o x x x x x x o o o o x x x o o o o)
+  (x x o x x o o o x o o x x x o x x o o o)
+  (o x x x x x o o x x x o o o x x x x o o)
+  (o o x o o x x x x o o x x x x x x x o o)
+  (o o o o o o o x o o x x x x x x x x x o)
+  (o o o o o o o x o o x x x x x x x x x o)
+  (o o o o o o o x o o x x x x x x o x x x)
+  (o o o o o o o x o o x x x x x x o o x x)
+  (o o o o o o o x o o o x x o o o o o x x)
+  (o o o o o o o x x o o x x o o o o o o x)
+  (o o o o o o o o x x o o x x o o o o o x)
+  (o o o o o o o o o x x x o x x o o o o x)
+  (o o o o o o o o o o o x x x x x x o o x)
+  (o o o o o o o o x x x x o o x x x x x x)
+  (o o o o o o o x x x x x x o o x x x x x)))
+
+("Hattori 69"
+ ((7)
+  (2 2)
+  (1 1)
+  (10)
+  (6 1 1 6)
+  (4 1 2 2 1 3)
+  (2 2 3 2)
+  (1 6 2 2 2 1)
+  (3 1 1 2)
+  (1 1)
+  (1 3 2)
+  (4 1 1 1 1 4)
+  (1 1 2 2 1)
+  (2 3 7 1)
+  (2 1 1 1)
+  (3 1 3 2)
+  (3 3 1 3)
+  (1 3 1 3)
+  (2 4 4 1)
+  (17 2))
+ ((12 3)
+  (3 1 1 4 2)
+  (2 2 1 3 1)
+  (2 1 2 1 4)
+  (1 1 1 3 3)
+  (5 1 1 2)
+  (3 2 2 2)
+  (2 1 2 2 1 1)
+  (1 1 1 1 1 3 1)
+  (1 3 1 1 1 1)
+  (1 1 1 1 1)
+  (1 3 1 1)
+  (1 1 1 2 1 1 1)
+  (2 1 2 2 1 1)
+  (6 3 3 2)
+  (1 1 1 1 2)
+  (1 1 1 3)
+  (2 1 1 3)
+  (3 1 1 3 1)
+  (6 6 2))
+ ((o o o o o o o x x x x x x x o o o o o o)
+  (o o o o o o x x o o o o o x x o o o o o)
+  (o o o o o o x o o o o o o o x o o o o o)
+  (o o o o o x x x x x x x x x x o o o o o)
+  (x x x x x x o o o x o x o o x x x x x x)
+  (x x x x o x o o x x o x x o x o o x x x)
+  (x x o o o x x o o o o o o x x x o o x x)
+  (x o x x x x x x o x x o x x o o x x o x)
+  (x x x o o o o x o o o o x o o o o o x x)
+  (x o o o o o o o o o o o o o o o o o o x)
+  (x o o x x x o o o o o o o o x x o o o o)
+  (x x x x o o x o x o o o x o x o x x x x)
+  (x o o o x o x x o o o o o x x o o o o x)
+  (x x o x x x o x x x x x x x o o o o o x)
+  (x x o o x o o o o o o o o o x o o o o x)
+  (x x x o o o o o x o o o o x x x o o x x)
+  (o x x x o o o x x x o o o o x o o x x x)
+  (x o x x x o o o x o o o o o o o x x x o)
+  (x x o x x x x o o o o o o o x x x x o x)
+  (x x x x x x x x x x x x x x x x x o x x)))
+
+("Hattori 70"
+ ((10)
+  (3 3)
+  (3 2)
+  (2 5 1)
+  (1 8 1)
+  (2 2 5 1)
+  (1 1 1 1 3 2)
+  (1 1 2 1)
+  (3 2 1 1 3 2)
+  (1 2 5 1 3)
+  (8 3 3)
+  (13)
+  (4 6)
+  (8)
+  (11)
+  (1 1 1 1)
+  (1 1 1 1)
+  (1 3 2)
+  (8)
+  (1 1))
+ ((3)
+  (4 1)
+  (3 4)
+  (2 3 1)
+  (1 5)
+  (2 4 9)
+  (1 2 7 1)
+  (2 2 1 10)
+  (1 2 2 1 2 3)
+  (1 2 1 10)
+  (1 2 6 1)
+  (1 3 2 9)
+  (1 4 2 1 3)
+  (1 3 5 1)
+  (1 2 1 3)
+  (1 1 3)
+  (2 1)
+  (1 2)
+  (2 3)
+  (5))
+ ((o o o o o o o x x x x x x x x x x o o o)
+  (o o o o o x x x o o o o o o o o x x x o)
+  (o o o x x x o o o o o o o o o o o o x x)
+  (o o x x o o o x x x x x o o o o o o o x)
+  (o o x o o o x x x x x x x x o o o o o x)
+  (o x x o o x x o o o o x x x x x o o o x)
+  (o x o o o x o x o x o o x x x o o o x x)
+  (o x o o o x o o o o o x x o o o o o x o)
+  (x x x o o x x o x o o x o x x x o x x o)
+  (x o x x o o x x x x x o o x o x x x o o)
+  (x x x x x x x x o x x x o x x x o o o o)
+  (o o x x x x x x x x x x x x x o o o o o)
+  (o o o o x x x x o x x x x x x o o o o o)
+  (o o o o x x x x x x x x o o o o o o o o)
+  (o o o x x x x x x x x x x x o o o o o o)
+  (o o o o o x o x o x o x o o o o o o o o)
+  (o o o o o x o x o x o x o o o o o o o o)
+  (o o o o o x o x x x o x x o o o o o o o)
+  (o o o o o x x x x x x x x o o o o o o o)
+  (o o o o o o o o x o o o x o o o o o o o)))
+
+("Hattori 71"
+ ((1 1 4)
+  (2 3 7)
+  (3 1 9)
+  (2 3 5)
+  (1 5 2)
+  (7 1)
+  (1 1 1 2)
+  (1 3 1 2)
+  (1 3 1 3)
+  (1 1 2 1)
+  (8 4)
+  (2 2 1 2)
+  (2 2 3)
+  (2 3 2 3)
+  (2 1 1 1 2 2)
+  (1 2 2 2 2 3 1)
+  (1 2 1 1 2 1 1 1)
+  (1 2 1 1 2 1 1 1)
+  (1 1 1 1 1 1)
+  (1 5 1 1 1))
+ ((5 6)
+  (3 2)
+  (1 2 3)
+  (2 3)
+  (7)
+  (2 1 6)
+  (1 3 2 1 1 1 1)
+  (9 1 2 1)
+  (1 3 2 1 1 1 1)
+  (2 1 6)
+  (1 6)
+  (2 2 3)
+  (3 2 3)
+  (4 2)
+  (5 7)
+  (5 2)
+  (4 4 5)
+  (2 4 2)
+  (1 3 5)
+  (2 4 7))
+ ((x o o o o o o x o o o o o x x x x o o o)
+  (x x o o o o x x x o o x x x x x x x o o)
+  (x x x o o o o x o o x x x x x x x x x o)
+  (x x o o o o x x x o o o x x x x x o o o)
+  (x o o o o x x x x x o o o o x x o o o o)
+  (o o o o x x x x x x x o o o o o o o o x)
+  (o o o o x o o x o o x o o o o o o o x x)
+  (o o o o x o x x x o x o o o o o o x x o)
+  (o o o o x o x x x o x o o o o o o x x x)
+  (o o o o x o o o o o x o o o o o x x o x)
+  (o o o o x x x x x x x x o o o o x x x x)
+  (o o o x x o o o o o o x x o o o x o x x)
+  (o o x x o o o o o o o o x x o o x x x o)
+  (o x x o o o x x x o o o o x x o o x x x)
+  (x x o o o x o x o x o o o o x x o o x x)
+  (x o x x o x x o x x o x x o x x x o o x)
+  (x o x x o x o o o x o x x o x o x o o x)
+  (x o x x o x o o o x o x x o x o x o o x)
+  (x o o o o x o o o x o o o o x o x o o x)
+  (x o o o o x x x x x o o o o x o x o o x)))
+
+("Hattori 72"
+ ((2 5 5)
+  (3 1 1 1)
+  (4 3 3 2)
+  (5 1 3 1 3)
+  (5 7 4)
+  (5 3 4)
+  (4 1 1 3)
+  (1 1 1 1)
+  (1 10)
+  (5 2)
+  (7)
+  (8)
+  (7 2)
+  (8 2 2 1)
+  (6 3 2 1)
+  (4 1 2 3)
+  (3 1 1)
+  (1 1)
+  (1 1 1 1)
+  (4 4))
+ ((4 3 3)
+  (5 1 4)
+  (5 1 4 2)
+  (5 1 3 1)
+  (4 2 3 1)
+  (3 1 8)
+  (1 4 1 2)
+  (1 1 4)
+  (1 3 1 4)
+  (1 1 1 5)
+  (7 6)
+  (3 2 1 2)
+  (7 1 1 1)
+  (1 1 1 1 1 2)
+  (1 3 1 2 5)
+  (1 4 2 1)
+  (1 3 2 1)
+  (4 2 2)
+  (4 1)
+  (4 3))
+ ((x x o o o o x x x x x o x x x x x o o o)
+  (x x x o o o o o o o x o x o o o o o o x)
+  (x x x x o o o o x x x o x x x o o o x x)
+  (x x x x x o o o x o x x x o x o o x x x)
+  (o x x x x x o o x x x x x x x o x x x x)
+  (o o x x x x x o o o x x x o o x x x x o)
+  (o o o x x x x o o o x o x o o x x x o o)
+  (x o o o o o x o o o o x o o o x o o o o)
+  (x o o o o o x x x x x x x x x x o o o o)
+  (x x x x x o o o o x x o o o o o o o o o)
+  (o o o o x x x x x x x o o o o o o o o o)
+  (o o o o o o o x x x x x x x x o o o o o)
+  (o o o o x x x x x x x o o o x x o o o o)
+  (o x x x x x x x x o x x o o o x x o o x)
+  (x x x x x x o o o o o x x x o o x x o x)
+  (x x x x o x o o o o o o o x x o o x x x)
+  (x x x o o x o o o o o o o o x o o o o o)
+  (o o o o o x o o o o o o o o x o o o o o)
+  (o o x o o x o o o o o o o o x o o x o o)
+  (o o x x x x o o o o o o o o x x x x o o)))
+
+("Hattori 73"
+ ((2)
+  (3 4)
+  (5 4)
+  (9)
+  (6)
+  (4 3)
+  (3 2 3)
+  (5 3)
+  (10 5)
+  (12)
+  (1 1 1 1 1)
+  (1 1 1 1 2 1)
+  (1 1 1 2 3 2)
+  (5 2 3 2)
+  (12 3)
+  (1 2 1 1 3)
+  (1 4 1 4)
+  (12 5)
+  (10 6)
+  (7))
+ ((1)
+  (1 9)
+  (2 2 2 2)
+  (1 2 4 2)
+  (8 2 2)
+  (18)
+  (4 3 5)
+  (4 3 3 3)
+  (3 12)
+  (2 2 1 2)
+  (1 2 3 2)
+  (1 2 4 2)
+  (2 9)
+  (1 1 1)
+  (1 1 2)
+  (2 3 3)
+  (1 1 1 4)
+  (1 2 1 6)
+  (2 1 1 8)
+  (1 1 1 10))
+ ((o o o o o o o o o o o o o o o o o o x x)
+  (o o o o o x x x o o o o o o o x x x x o)
+  (o o o o x x x x x o o o x x x x o o o o)
+  (o o o o x x x x x x x x x o o o o o o o)
+  (o o o o x x x x x x o o o o o o o o o o)
+  (o o x x x x o o o o o o o o o o o x x x)
+  (x x x o x x o o o o o o o o o x x x o o)
+  (o o o o x x x x x o o o o x x x o o o o)
+  (o o x x x x x x x x x x o o o x x x x x)
+  (o x x x x x x x x x x x x o o o o o o o)
+  (o x o o o x o o x o o o x o o o o o o x)
+  (o x o x o x o o x o o x x o o o o o o x)
+  (o x o x o x o x x o x x x o o o o o x x)
+  (o x x x x x o x x o x x x o o o o o x x)
+  (o x x x x x x x x x x x x o o o o x x x)
+  (o x o o o x x o x o o o x o o o o x x x)
+  (o x o o o x x x x o o o x o o o x x x x)
+  (o x x x x x x x x x x x x o o x x x x x)
+  (o o x x x x x x x x x x o o x x x x x x)
+  (o o o o o o o o o o o o o x x x x x x x)))
+
+("Hattori 74"
+ ((6 5)
+  (5 5)
+  (1 1 1 1)
+  (5 4)
+  (5 5)
+  (12)
+  (10)
+  (11)
+  (13)
+  (4 3)
+  (3 2 2 2)
+  (2 1 1 1 1 1)
+  (2 1 1)
+  (2 4 4)
+  (2 2 3 1)
+  (2 4 1)
+  (15)
+  (1 3)
+  (1 1)
+  (20))
+ ((1 2 1)
+  (2 4 1)
+  (6 3 2 2)
+  (2 7 2 1 1)
+  (2 7 3 1)
+  (9 1 3 1)
+  (6 1 2 1)
+  (4 2 1 4)
+  (4 2 1 1)
+  (5 2 1 1)
+  (8 1 1 1 1)
+  (2 6 1 2 1)
+  (2 6 2 2 1)
+  (6 3 3 1)
+  (2 9 1)
+  (1 2 2 1 1)
+  (2 1 1)
+  (1 1 1)
+  (3 1)
+  (1))
+ ((x x x x x x o o o o o x x x x x o o o o)
+  (o x x x x x o o o o x x x x x o o o o o)
+  (o o x o o x o o o o x o o x o o o o o o)
+  (o o x x x x x o o o x x x x o o o o o o)
+  (o o x x x x x o o x x x x x o o o o o o)
+  (o o x x x x x x x x x x x x o o o o o o)
+  (o o o x x x x x x x x x x o o o o o o o)
+  (o o o x x x x x x x x x x x o o o o o o)
+  (o o x x x x x x x x x x x x x o o o o o)
+  (o x x x x o o o o o o o o x x x o o o o)
+  (x x x o o o x x o o o x x o x x o o o o)
+  (x x o o o x o x o o x o x o x o o o o o)
+  (o x x o o o o o o o o o o o x o x o o o)
+  (o o x x o o o x x x x o o o x x x x o o)
+  (o o o x x o o o x x o o o x x x o o x o)
+  (o o o o x x o o o o o x x x x o o o x o)
+  (o o o o x x x x x x x x x x x x x x x o)
+  (o o o x o x x x o o o o o o o o o o o o)
+  (o o x o o o o x o o o o o o o o o o o o)
+  (x x x x x x x x x x x x x x x x x x x x)))
+
+("Hattori 75"
+ ((7 1 1)
+  (9 3 2)
+  (1 4 5 3)
+  (2 1 3 10)
+  (2 1 2)
+  (1 9)
+  (1 2 3 4)
+  (1 3 1 2)
+  (6 1 2)
+  (5 4 1)
+  (2 7 2 1)
+  (7 1 3)
+  (3 2 2 2)
+  (1 2 1 1 1)
+  (11 2)
+  (1 4 1 1 2)
+  (6 1 2)
+  (1 1 1 3)
+  (1 2 7)
+  (1 12))
+ ((7 3)
+  (2 2 1 2 4)
+  (2 1 1 3)
+  (2 2 1 1 7 1)
+  (2 9 2)
+  (3 3 2 6)
+  (4 3 1 1 1)
+  (5 2 1 1 2 1)
+  (6 3 1 1)
+  (2 3 1 2)
+  (1 1 1 8)
+  (2 1 1 2)
+  (3 1 1 2)
+  (4 1 2 2)
+  (3 2 4 3)
+  (2 5 2 2)
+  (1 2 2 2)
+  (2 2 2 2)
+  (3 2 2 2)
+  (4 7))
+ ((o x x x x x x x o o o o o x o o o o o x)
+  (x x x x x x x x x o o o x x x o o o x x)
+  (x o o o o x x x x o o x x x x x o x x x)
+  (x x o x o o x x x o x x x x x x x x x x)
+  (x x o x o o o x x o o o o o o o o o o o)
+  (x o o o o o o o x x x x x x x x x o o o)
+  (x o x x o o o x x x o o o o x x x x o o)
+  (x o o o o x x x o o o o o o o x o x x o)
+  (o x x x x x x o o o o o o o o x o o x x)
+  (o o o o x x x x x o o o o x x x x o o x)
+  (o o o x x o o o x x x x x x x o x x o x)
+  (o o o x x x x x x x o o o o x o o x x x)
+  (o o o x x x o o o x x o o o x x o o x x)
+  (o x o x x o o o o o x o o o o x o o o x)
+  (x x x x x x x x x x x o o o o o o o x x)
+  (x o x x x x o x o o x o o o o o o x x o)
+  (x x x x x x o o o o x o o o o o x x o o)
+  (o x o o o x o o o o x o o o x x x o o o)
+  (o x o o x x o o o x x x x x x x o o o o)
+  (o x o x x x x x x x x x x x x o o o o o)))
+
+("Hattori 76"
+ ((1 1 3)
+  (3 3 1 1)
+  (1 7 1 4)
+  (3 3 1)
+  (1 8)
+  (2 1 1 2 2)
+  (1 2 2 1 2)
+  (1 1 1)
+  (1 7 1 1)
+  (1 2 2 1 1)
+  (1 1 1 1 1 1 1)
+  (1 1 1 1 1 1 1)
+  (1 2 2 1 1)
+  (1 7 1 1)
+  (2 1 1)
+  (11 1)
+  (1 1 1 2)
+  (2 4 6 1)
+  (1 1 1 1 1 1 1)
+  (3 3 5))
+ ((10)
+  (6 2)
+  (1 1 4 1)
+  (3 1 2 2 3)
+  (1 2 1 1 1 3)
+  (1 1 2 1 1 1)
+  (1 1 1 1 3)
+  (1 1 2 1 1 1)
+  (1 2 1 1 1 1)
+  (3 1 2 2 1 3)
+  (2 1 4 1 1)
+  (5 1 3)
+  (11 2)
+  (1 1)
+  (1 3)
+  (1 1 1)
+  (3 1 4)
+  (1 1 2 1)
+  (7 4)
+  (1 11))
+ ((o x o o o o o o o o x o o o o o x x x o)
+  (o x x x o o o o o x x x o o o o x o x o)
+  (o x o x x x x x x x o x o o o o x x x x)
+  (o x x x o o o o o x x x o o o o o o x o)
+  (o x o o o o o o o o o x x x x x x x x o)
+  (x x o o x o o o x o o x x o o o o x x o)
+  (x o o x x o o o x x o o x o o o o o x x)
+  (x o o o o o o o o o o o x o o o o o o x)
+  (x o o x x x x x x x o o x o o o o o o x)
+  (x o x x o o o o o x x o x o o o o o o x)
+  (x o x o o x o x o o x o x o o o o o o x)
+  (x o x o o x o x o o x o x o o o o o o x)
+  (x o x x o o o o o x x o x o o o o o o x)
+  (x o o x x x x x x x o o x o o o o o o x)
+  (x x o o o o o o o o o o x o o o o o o x)
+  (o x x x x x x x x x x x o o o o o o o x)
+  (o o o x o o o o o o o o x o o o x o x x)
+  (o o o x x o x x x x o x x x x x x o x o)
+  (o o o o x o x o o x o x o o x o x o x o)
+  (o o o o x x x o o x x x o o x x x x x o)))
+
+("Hattori 77"
+ ((14)
+  (4 5)
+  (1 1 3)
+  (3 2)
+  (4 1)
+  (5 3)
+  (4 1 4)
+  (1 2 4)
+  (2 1 2)
+  (5 1 4)
+  (1 5 1)
+  (1 6 3)
+  (4 2 1)
+  (10 2 1 1)
+  (1 10 2)
+  (2 2 2 1 1)
+  (3 1 2 2 1)
+  (4 2 2 2)
+  (11 4)
+  (12 2))
+ ((1)
+  (1 1 2)
+  (2 1 2)
+  (2 1 1 2)
+  (4 1 2 2)
+  (1 2 7)
+  (1 1 4 3)
+  (2 3 11)
+  (2 5 6 3)
+  (3 3 4 2)
+  (2 3 1 3 3)
+  (1 6 2 6)
+  (1 1 1 3 1)
+  (1 2 2 1 1)
+  (1 4 1 4)
+  (2 2 2 3 1)
+  (2 2 1 2 1)
+  (3 1 2 2)
+  (4 3 4)
+  (5 1 2))
+ ((o o o o o o x x x x x x x x x x x x x x)
+  (o o o o o o o x x x x o o o o x x x x x)
+  (o o o o o o o o o x o x o o o o o x x x)
+  (o o o o o o o o o o x x x o o o o o x x)
+  (o o o o o o o o x x x x o o o o o o o x)
+  (o o o o o o o x x x x x o o x x x o o o)
+  (o o o o o o x x x x o x o x x x x o o o)
+  (o o o o o x o x x o o x x x x o o o o o)
+  (o o o x x o o o x o o o o o x x o o o o)
+  (o x x x x x o x o o o o o o o x x x x o)
+  (o o x o x x x x x o o o o o o o o o x o)
+  (o o o o x o x x x x x x o o o o o x x x)
+  (o o o o o o x x x x o x x o o o o x o o)
+  (o x x x x x x x x x x o x x o o x o o x)
+  (o o o o o x o x x x x x x x x x x o x x)
+  (o o o o x x o x x o x x o o o x o o x o)
+  (o o o x x x o x o o o x x o x x o o x o)
+  (o o o o o x x x x o x x o x x o o x x o)
+  (o x x x x x x x x x x x o o x x x x o o)
+  (x x x x x x x x x x x x o x x o o o o o)))
+
+("Hattori 78"
+ ((8)
+  (2 2)
+  (1 1)
+  (1 1 2)
+  (1 1 1 4)
+  (1 1 3 3)
+  (3 11 2)
+  (3 1 2 2)
+  (3 1 2 2)
+  (1 12 3)
+  (1 1 2 2 1 4)
+  (1 1 1 1 1 1)
+  (1 1 1 1)
+  (3 2 2 2 3)
+  (1 1 2 2 1 1 1)
+  (4 8 3)
+  (1 4 4 1)
+  (2 1 1 1)
+  (1 4)
+  (4 1 1 1))
+ ((3 5)
+  (8 1 3)
+  (3 3 1)
+  (2 1)
+  (13 1 1)
+  (2 1 1 2 1)
+  (1 1 2 3)
+  (1 1 3 1 1 1)
+  (1 1 1 3)
+  (1 1 1 3)
+  (1 1 3 1)
+  (1 3 2 1 1 1)
+  (2 1 1 3)
+  (13 2)
+  (5 1)
+  (2 2 1 2)
+  (2 1 4 1)
+  (3 5 1 1)
+  (7 6)
+  (5))
+ ((o o o o o x x x x x x x x o o o o o o o)
+  (o o o o x x o o o o o o x x o o o o o o)
+  (o o o o x o o o o o o o o x o o o o o o)
+  (o o o o x o o o o o o o o x o o x x o o)
+  (o o o o x o o o o o o x o x o x x x x o)
+  (o o o o x o o o o o o x o x x x o x x x)
+  (x x x o x x x x x x x x x x x o o o x x)
+  (x x x o x o o o o o o o o x x o o o x x)
+  (x x x o x o o o o o o o o x x o o o x x)
+  (o x o o x x x x x x x x x x x x o x x x)
+  (o x o o x o x x o o x x o x o x x x x o)
+  (o x o o x o o x o o x o o x o o o x o o)
+  (o x o o x o o o o o o o o x o o o x o o)
+  (x x x o x x o o x x o o x x o o x x x o)
+  (x o x o o x x o x x o o x o o o x o x o)
+  (x x x x o o x x x x x x x x o o x x x o)
+  (x o o x x x x o o o o o o x x x x o x o)
+  (x x o o o o o x o o o x o o o o o o x o)
+  (o x o o o o o o o o o o o o o x x x x o)
+  (o x x x x o o x o o o x o o o x o o o o)))
+
+("Hattori 79"
+ ((1 1 1 1 1 1)
+  (1 1 1 1 2 2 2)
+  (1 2 2 1 3 1 1)
+  (3 1 2 2 4)
+  (2 1 2 4)
+  (2 3 2)
+  (4 1 2)
+  (3 2 2)
+  (4 9)
+  (1 4 6)
+  (2 2 1)
+  (2 3 2)
+  (3 2 1 3)
+  (2 3 4)
+  (1 3)
+  (2 1 1)
+  (4 5)
+  (6 5)
+  (6 7 3)
+  (4 3))
+ ((4 3 2)
+  (2 1 2 2)
+  (4 1 2 3)
+  (3 2 2 1 4)
+  (2 2 2 4)
+  (9 6)
+  (3 5 2)
+  (2 1 2)
+  (2 1 1)
+  (3 3 1 1)
+  (4 3 2)
+  (2 2 1 1 2)
+  (3 4 3 2)
+  (8 2)
+  (2 2 4 1)
+  (2 1 3 2)
+  (2 2 3)
+  (3 6)
+  (2 1 2 1 1)
+  (2 3))
+ ((x o o x o o x o o o o x o o o x o o x o)
+  (x o o x o o x o o x o x x o x x o x x o)
+  (x o x x o x x o o x o o x x x o o x o x)
+  (x x x o o x o o x x o o x x o o x x x x)
+  (o x x o o x o x x o o o o x x x x o o o)
+  (o o x x o x x x o o o o o x x o o o o o)
+  (o o o x x x x o o o x o x x o o o o o o)
+  (o o o o x x x o o x x o x x o o o o o o)
+  (x x x x o x x x x x x x x x o o o o o o)
+  (x o o x x x x o o x x x x x x o o o o o)
+  (x x o o x x o o o o o o o o x o o o o o)
+  (o x x o o o o o o o x x x o x x o o o o)
+  (o o x x x o o o o x x o x o x x x o o o)
+  (o o o o x x o o o o x x x o o x x x x o)
+  (o o o o o x o o o o o o o o o o o x x x)
+  (o o o o x x o o o o o o o o o o o x o x)
+  (o o o x x x x o o o o o o o o x x x x x)
+  (o o x x x x x x o o o o o x x x x x o o)
+  (x x x x x x o x x x x x x x o o x x x o)
+  (x x x x o o o o o o x x x o o o o o o o)))
+
+("Hattori 80"
+ ((7)
+  (1 1 1)
+  (15)
+  (2 2 2 2)
+  (2 3 2)
+  (3 1 4)
+  (3 1 4)
+  (3 3 4)
+  (2 1 2 2)
+  (1 1)
+  (1 1)
+  (1 1)
+  (1 1)
+  (4 1 3)
+  (1 2 1 1 3)
+  (2 2 1 1 1 1)
+  (2 3 1 1 3)
+  (2 1 1 1 1)
+  (2 5 1)
+  (2 3))
+ ((5)
+  (6 3)
+  (2 3 1 2)
+  (1 1 2)
+  (1 2 2)
+  (1 2 2)
+  (1 1 2 1)
+  (4 1)
+  (1 3 10)
+  (3 4)
+  (1 3 2)
+  (4 11)
+  (1 1 1 1)
+  (1 6)
+  (1 1 1)
+  (1 6)
+  (2 3 1 1)
+  (6 4)
+  (5)
+  (3))
+ ((o o o o o o x x x x x x x o o o o o o o)
+  (o o o o o o o x o x o x o o o o o o o o)
+  (o o x x x x x x x x x x x x x x x o o o)
+  (o x x o o o o x x o x x o o o o x x o o)
+  (x x o o o o o o x x x o o o o o o x x o)
+  (x x x o o o o o o x o o o o o o x x x x)
+  (x x x o o o o o o x o o o o o o x x x x)
+  (x x x o o o o o x x x o o o o o x x x x)
+  (x x o o o o o o x o x x o o o o o x x o)
+  (o o o o o o o o x o o x o o o o o o o o)
+  (o o o o o o o o x o o x o o o o o o o o)
+  (o o o o o o o o x o o x o o o o o o o o)
+  (o o o o o o o o x o o x o o o o o o o o)
+  (o x x x x o o o x o o x x x o o o o o o)
+  (o x o o x x o o x o o x o x x x o o o o)
+  (o x x o o x x o x o o x o x o x o o o o)
+  (o o x x o o x x x o o x o x o x x x o o)
+  (o o o x x o o o o o o x o x o x o x o o)
+  (o o o o x x o o o o o x x x x x o x o o)
+  (o o o o o x x o o o o o o o o x x x o o)))
+
+("Hattori 81"
+ ((1 1 1) (2 1 2) (7) (7) (5) (1 1 1) (2 1 2) (4 1 3) (10) (6))
+ ((4) (3) (3 3) (5 3) (3 2) (10) (3 2) (5 3) (3 3) (4))
+ ((o o o x o x o x o o)
+  (o o x x o x o x x o)
+  (o o x x x x x x x o)
+  (o o x x x x x x x o)
+  (o o o x x x x x o o)
+  (x o o o o x o o o x)
+  (x x o o o x o o x x)
+  (x x x x o x o x x x)
+  (x x x x x x x x x x)
+  (o o x x x x x x o o)))
+
+("Hattori 82"
+ ((1) (2) (3) (2) (4) (4 1) (5 2) (6 2) (7 3) (8 4) (15) (1) (15) (13) (11))
+ ((1 1)
+  (2 2)
+  (3 3)
+  (4 3)
+  (5 3)
+  (6 3)
+  (7 3)
+  (8 3)
+  (15)
+  (2 1 1 3)
+  (1 6 3)
+  (5 3)
+  (3 3)
+  (2 2)
+  (1 1))
+ ((o o o o o o o o x o o o o o o)
+  (o o o o o o o o x x o o o o o)
+  (o o o o o o o o x x x o o o o)
+  (o o o o o o o x x o o o o o o)
+  (o o o o o o x x x x o o o o o)
+  (o o o o o x x x x o x o o o o)
+  (o o o o x x x x x o x x o o o)
+  (o o o x x x x x x o x x o o o)
+  (o o x x x x x x x o x x x o o)
+  (o x x x x x x x x o x x x x o)
+  (x x x x x x x x x x x x x x x)
+  (o o o o o o o o x o o o o o o)
+  (x x x x x x x x x x x x x x x)
+  (o x x x x x x x x x x x x x o)
+  (o o x x x x x x x x x x x o o)))
+
+("Hattori 83"
+ ((1 1 1 1 12)
+  (1 1 13)
+  (1 1 14)
+  (1 15)
+  (1 16)
+  (1 1)
+  (1 5 7)
+  (2 2 8)
+  (1 1 1 1 1 8)
+  (1 1 1 1 1 2 5)
+  (1 1 1 3)
+  (1 1 1 1 1 2)
+  (1 3 1 1 2 2)
+  (1 2 2 3 1 2)
+  (1 1 1 1 1 2 2)
+  (2 1 1 1 1 1)
+  (1 1 2 2 5 1)
+  (1 1 1 2 1 1)
+  (1 7 3 4)
+  (10))
+ ((3 2 3)
+  (3 3)
+  (1 4 4)
+  (2 2 1 3 1)
+  (2 1 1 2 2 1)
+  (4 1 1)
+  (1 3 1 2 2 1)
+  (4 2 1 4 1)
+  (5 4 3)
+  (5 3)
+  (5 1 4)
+  (5 9)
+  (5 3 2)
+  (5 11 1)
+  (5 3 1 1 1)
+  (5 4 2 1 1)
+  (5 4 1 1 2)
+  (5 5 4)
+  (5 9 2)
+  (5 14))
+ ((x o x o x o x o x x x x x x x x x x x x)
+  (x o o o x o o x x x x x x x x x x x x x)
+  (x o o x o o x x x x x x x x x x x x x x)
+  (o o o x o x x x x x x x x x x x x x x x)
+  (o x o o x x x x x x x x x x x x x x x x)
+  (o x o o o x o o o o o o o o o o o o o o)
+  (o x o x x x x x o o o o o x x x x x x x)
+  (o o x x o o o x x o o o x x x x x x x x)
+  (x o x o x o x o x o o o x x x x x x x x)
+  (x o x o x o x o x o o o x x o x x x x x)
+  (o o x o o o o o x o o o o x o o o x x x)
+  (o o o x o o o x o o o x o x o x o o x x)
+  (o x o o x x x o o o o x o x o x x o x x)
+  (o x o x x o x x o x x x o x o o o o x x)
+  (o x o x o o o x o x o x o x x o o o x x)
+  (o o x x o o o x o x o x o x o o o o o x)
+  (x o x o o o o x x o x x o x x x x x o x)
+  (x o x o o o o o x o x x o o o o o x o x)
+  (x o x x x x x x x o x x x o o o x x x x)
+  (o o o o o o o o o o x x x x x x x x x x)))
+
+("Hattori 84"
+ ((2)
+  (3)
+  (2 2)
+  (4 2)
+  (2 3 2)
+  (8 1 2)
+  (10 4)
+  (2 16)
+  (4 3 3 2)
+  (3 3 3 1)
+  (3 3 2)
+  (4 3)
+  (10)
+  (3 4)
+  (1 3 3 1)
+  (2 2 3 2)
+  (3 3 5)
+  (5 4)
+  (16)
+  (12))
+ ((2 3)
+  (4 3)
+  (5 3)
+  (2 2 2)
+  (8 4)
+  (2 6 6)
+  (2 13 2)
+  (2 10 2)
+  (2 8 2)
+  (4 2 2)
+  (4 1 2)
+  (4 1 2)
+  (4 2 2)
+  (1 4 2)
+  (9 2)
+  (13)
+  (4 4)
+  (3 3)
+  (4 3)
+  (4 3))
+ ((o o o o x x o o o o o o o o o o o o o o)
+  (o o o o x x x o o o o o o o o o o o o o)
+  (o o o x x o x x o o o o o o o o o o o o)
+  (o o x x x x o x x o o o o o o o o o o o)
+  (o x x o x x x o x x o o o o o o o o o o)
+  (x x x x x x x x o x o o o o o o o x x o)
+  (x x x x x x x x x x o o o o o o x x x x)
+  (o x x o x x x x x x x x x x x x x x x x)
+  (o o o o o x x x x o x x x o x x x o x x)
+  (o o o o o o x x x o x x x o x x x o o x)
+  (o o o o o o x x x o x x x o x x o o o o)
+  (o o o o o o x x x x o o o x x x o o o o)
+  (o o o o o o x x x x x x x x x x o o o o)
+  (o o o o o o x x x o o o x x x x o o o o)
+  (x o o o o x x x o o o o o x x x o o o x)
+  (x x o o o x x o o o o o o o x x x o x x)
+  (x x x o x x x o o o o o o o o x x x x x)
+  (o x x x x x o o o o o o o o o x x x x o)
+  (o o x x x x x x x x x x x x x x x x o o)
+  (o o o o x x x x x x x x x x x x o o o o)))
+
+("Hattori 85"
+ ((1 1 1 1 1 1)
+  (1 1 1 5 1 1)
+  (1 1 9 1)
+  (1 4 1 4)
+  (6 6)
+  (8 8)
+  (10 9)
+  (2 4 1 3 2)
+  (1 1 1 1 1)
+  (5 1)
+  (8 1 6)
+  (9 1 8)
+  (5 1 1 8)
+  (4 3 1 1 4)
+  (3 1 1 1 3 3)
+  (3 1 1 2 1 2)
+  (4 3 1 1 2 1)
+  (3 1 1 2 1)
+  (1 2 1 2 2)
+  (6 2 1 2))
+ ((3 3 6)
+  (3 8)
+  (3 3 9 1)
+  (3 5 4)
+  (2 4 4 1)
+  (5 3 1)
+  (1 6 3 2 1 1)
+  (7 2 1 1 2)
+  (2 3 9)
+  (2 1)
+  (4 13)
+  (2 1 1)
+  (2 2 2 3)
+  (6 6 3)
+  (1 7 3 1 1 1)
+  (5 3 3)
+  (2 4 4)
+  (3 5)
+  (2 4 6 2)
+  (4 9))
+ ((o o x o x o x o o o x o o o x o x o o o)
+  (x o x o x o o o x x x x x o o o x o x o)
+  (x o x o o o x x x x x x x x x o o o x o)
+  (x o o o x x x x o o x o o x x x x o o o)
+  (o o x x x x x x o o o o o x x x x x x o)
+  (o x x x x x x x x o o o x x x x x x x x)
+  (x x x x x x x x x x o x x x x x x x x x)
+  (x x o o o x x x x o x o o x x x o o x x)
+  (x o o o o o o x o o x o o o x o o o o x)
+  (o o x x x x x o o o x o o o o o o o o o)
+  (o x x x x x x x x o x o o x x x x x x o)
+  (x x x x x x x x x o x o x x x x x x x x)
+  (x x x x x o o o x o x o x x x x x x x x)
+  (x x x x o o x x x o x o o x o o x x x x)
+  (x x x o o o x o x o x o o x x x o x x x)
+  (x x x o o o o o x o x o x x o x o o x x)
+  (x x x x o o x x x o x o x o x x o o o x)
+  (o x x x o o o o x o x o x x o o o o o x)
+  (o o o x o o o x x o x o o x x o o o x x)
+  (o o x x x x x x o o x x o x o o o o x x)))
+
+("Hattori 86"
+ ((3 6 1)
+  (3 6 3)
+  (4 6 1)
+  (4 9 2)
+  (3 6 3)
+  (3 6 3)
+  (3 6)
+  (2)
+  (6)
+  (2 2 2 3)
+  (3 2 2 4)
+  (3 1 1 1 4)
+  (2 1 3 2 1 3)
+  (3 1 1 2)
+  (5 4)
+  (8 2 7)
+  (6 2 5)
+  (6 1 1 5)
+  (6 5)
+  (13))
+ ((4 4 3)
+  (5 4 5)
+  (7 2 5)
+  (5 7)
+  (3 7)
+  (1 10)
+  (2 1 2)
+  (7 2 1 1 1 1)
+  (7 1 3 1)
+  (7 1 1 2 1)
+  (7 1 2 1)
+  (7 1 2 1)
+  (7 2 1 1 1 1)
+  (1 2 1 2)
+  (1 10)
+  (2 7)
+  (2 1 2 5)
+  (1 2 4 5)
+  (2 1 1 4 3)
+  (1 1 4))
+ ((x x x o o o o x x x x x x o o o o o x o)
+  (x x x o o o o x x x x x x o o o x x x o)
+  (x x x x o o o x x x x x x o o o x o o o)
+  (x x x x o o o x x x x x x x x x o o x x)
+  (o x x x o o o x x x x x x o o x x x o o)
+  (o o x x x o o x x x x x x o o o o x x x)
+  (o o x x x o o x x x x x x o o o o o o o)
+  (o o o o x x o o o o o o o o o o o o o o)
+  (o o o o o o o x x x x x x o o o o o o o)
+  (x x o o o o x x o o o o x x o o o x x x)
+  (x x x o o x x o o o o o o x x o x x x x)
+  (x x x o o x o o x o o o o o x o x x x x)
+  (x x o o o x o x x x o x x o x o o x x x)
+  (o o o x x x o o x o o x o o x x o o o o)
+  (o x x x x x o o o o o o o o x x x x o o)
+  (x x x x x x x x o x x o x x x x x x x o)
+  (x x x x x x o o o x x o o o x x x x x o)
+  (x x x x x x o x o o o o x o x x x x x o)
+  (o x x x x x x o o o o o o x x x x x o o)
+  (o o o x x x x x x x x x x x x x o o o o)))
+
+("Hattori 87"
+ ((5 5)
+  (1 1 1 1)
+  (3 1 3 1)
+  (3 1 3 1)
+  (1 1 3 1 2)
+  (13)
+  (15)
+  (17)
+  (3 2 12)
+  (20)
+  (5)
+  (20)
+  (11 4)
+  (9 4 3)
+  (8 5 2)
+  (7 8)
+  (3 11)
+  (3 3 8)
+  (3 3 6)
+  (4 4 7))
+ ((2 1 1)
+  (3 2 1)
+  (4 3 2)
+  (8 1 4 3)
+  (1 2 5 8)
+  (1 8 7 1)
+  (1 3 1 6 1)
+  (10 5 2)
+  (6 5 3)
+  (10 8)
+  (1 2 5 7)
+  (1 8 2 1 1)
+  (1 5 1 5 1)
+  (10 1 7)
+  (6 1 7)
+  (7 7)
+  (7 6)
+  (7 5)
+  (11)
+  (9))
+ ((o o o x x x x x o x x x x x o o o o o o)
+  (o o o x o o o x o x o o o x o o o o o o)
+  (o o o x x x o x o x x x o x o o o o o o)
+  (o o o x x x o x o x x x o x o o o o o o)
+  (o o o x o x o x x x o x o x x o o o o o)
+  (o o o x x x x x x x x x x x x x o o o o)
+  (o o x x x x x x x x x x x x x x x o o o)
+  (o x x x x x x x x x x x x x x x x x o o)
+  (x x x o x x o x x x x x x x x x x x x o)
+  (x x x x x x x x x x x x x x x x x x x x)
+  (o o o o o o o o o o o o o o o x x x x x)
+  (x x x x x x x x x x x x x x x x x x x x)
+  (o x x x x x x x x x x x o o o o x x x x)
+  (o o x x x x x x x x x o x x x x o x x x)
+  (o o o x x x x x x x x o x x x x x o x x)
+  (o o o o x x x x x x x o x x x x x x x x)
+  (o o o o x x x o o x x x x x x x x x x x)
+  (o o o x x x o o x x x o x x x x x x x x)
+  (o o x x x o o x x x o o o x x x x x x o)
+  (x x x x o x x x x o o x x x x x x x o o)))
+
+("Hattori 88"
+ ((4 4 5)
+  (1 2 2 1 6)
+  (1 1 1 8)
+  (1 1 1 5)
+  (3 2 2 2 1)
+  (1 1 1 2 5)
+  (2 3 2 1 3)
+  (1 1 1 1 1 1)
+  (2 4 1 3)
+  (5 2 1 1)
+  (1 3 1 1)
+  (1 3 1 1 4)
+  (6 2 2 1 2)
+  (1 1 1 4 1 3)
+  (1 2 5 2)
+  (4 1 2)
+  (1 3 4)
+  (2 1 1)
+  (1 1 5)
+  (1 11))
+ ((5 4)
+  (1 3 4 1)
+  (1 1 4 1 4)
+  (2 2 4 3)
+  (4 1 2)
+  (3 6)
+  (2 2 1)
+  (3 2 3 1)
+  (4 2 3 4)
+  (2 3 4 1)
+  (1 2 1 2 1)
+  (1 2 5 1)
+  (5 2)
+  (2 2)
+  (14 2)
+  (4 1 2 2)
+  (4 4 2 5)
+  (3 2 1 3 1 1)
+  (3 4 1 1 1 1)
+  (3 1 1 1))
+ ((x x x x o o o o o x x x x o o x x x x x)
+  (x o o x x o o o x x o o x o x x x x x x)
+  (x o o o x o o o x o o o x x x x x x x x)
+  (x o o o x o o o x o o o x x x x x o o o)
+  (x x x o x x o x x o o x x o x o o o o o)
+  (o x o o o x o x o o x x o o x x x x x o)
+  (o x x o o x x x o x x o o o x o x x x o)
+  (o o x o o o x o o x o o o o x o x o x o)
+  (o o x x o o o o x x x x o o x o x x x o)
+  (o x x x x x o x x o o x o o x o o o o o)
+  (o x o o o x x x o o o x o o x o o o o o)
+  (o x o o x x x o o o o x o o x o x x x x)
+  (x x x x x x o x x o x x o o x o x x o o)
+  (x o o x o x o x x x x o o o x o o x x x)
+  (x o x x o x x x x x o o o o x x o o o o)
+  (x x x x o o o o o x o o o o o x x o o o)
+  (o o x o o o o x x x o o o o o o x x x x)
+  (o o x x o o o o x o o o o o o o x o o o)
+  (o o o x o o o o x o o o x x x x x o o o)
+  (o o o x o o o o x x x x x x x x x x x o)))
+
+("Hattori 89"
+ ((9)
+  (4 4)
+  (4 3)
+  (5 4)
+  (4 4 2)
+  (4 2 2 5 3)
+  (4 1 1 5 2)
+  (4 2 2 5 2)
+  (4 9)
+  (4 5 2)
+  (2 1 2 5 1)
+  (2 1 2 2 2 1)
+  (2 2 1)
+  (6 1)
+  (1 1)
+  (2 1 1 1 1)
+  (2 2 5 1)
+  (3 2 2 1 1)
+  (1 2 2 2 1)
+  (10 6))
+ ((9)
+  (10)
+  (9 3)
+  (13 1 1)
+  (4 2 2 1)
+  (2 1 1 1 2 1)
+  (1 3 2 3 2)
+  (1 2 1 3)
+  (1 1 1 1 2 1)
+  (2 3 2 2 1)
+  (4 2 1)
+  (12 2)
+  (10 2)
+  (9 3)
+  (8 1 2)
+  (6 4)
+  (1 1 1)
+  (2 1 2 1)
+  (6 1)
+  (15))
+ ((o o o x x x x x x x x x o o o o o o o o)
+  (o o x x x x o o o x x x x o o o o o o o)
+  (o x x x x o o o o o x x x o o o o o o o)
+  (x x x x x o o o o o x x x x o o o o o o)
+  (x x x x o o o o o o o x x x x o o x x o)
+  (x x x x o x x o x x o x x x x x o x x x)
+  (x x x x o o x o o x o x x x x x o o x x)
+  (x x x x o x x o x x o x x x x x o o x x)
+  (x x x x o o o o o o o x x x x x x x x x)
+  (x x x x o o o o o o o x x x x x o o x x)
+  (x x o x o o x x o o o x x x x x o o o x)
+  (x x o x o o x x o o x x o x x o o o o x)
+  (o o o x x o o o o x x o o o o o o o o x)
+  (o o o o x x x x x x o o o o o o o o o x)
+  (o o o o o o x o o o o o o o o o o o o x)
+  (o o o o o x x o o x o o o x o o o x o x)
+  (o o o o x x o o x x o o o x x x x x o x)
+  (o o x x x o o x x o o o x x o x o o o x)
+  (o o x o o o x x o o o x x o x x o o o x)
+  (o o x x x x x x x x x x o o x x x x x x)))
+
+("Hattori 90"
+ ((2 6)
+  (11)
+  (3 9)
+  (3 1 1 1 2)
+  (2 1 1 1 1)
+  (3 1 2)
+  (1 1 1 1 1)
+  (1 2 2 1 2)
+  (1 2 1 1)
+  (2 6 3)
+  (2 6 5)
+  (13 2)
+  (5 4 3)
+  (4 4 5)
+  (1 7)
+  (6 3)
+  (7 2)
+  (14)
+  (4 10 4)
+  (4 4))
+ ((5 2)
+  (1 2 2)
+  (5 2 2)
+  (3 2 1 3)
+  (3 6 1)
+  (3 5 3)
+  (2 5 4)
+  (7 5 4)
+  (3 6 5)
+  (5 3 1 4)
+  (3 2 3 4)
+  (5 3 4)
+  (3 5 2)
+  (3 6 1 2)
+  (3 3 3 2 3)
+  (4 2 6)
+  (6 3)
+  (5 2)
+  (2 2)
+  (2))
+ ((o o o o o x x o x x x x x x o o o o o o)
+  (o o o o x x x x x x x x x x x o o o o o)
+  (o o o x x x o x x x x x x x x x o o o o)
+  (o o x x x o o x o x o x o o x x o o o o)
+  (o o x x o o o x o x o x o o o x o o o o)
+  (x x x o o o o x o o o o o o x x o o o o)
+  (x o x o o o o x o o x o o o x o o o o o)
+  (x o x x o o o x x o x o o x x o o o o o)
+  (x o o x x o o o x o o o o x o o o o o o)
+  (x x o o x x x x x x o o o x x x o o o o)
+  (o x x o x x x x x x o o x x x x x o o o)
+  (o o x x x x x x x x x x x x x o x x o o)
+  (o o o o x x x x x o x x x x o x x x o o)
+  (o o o o x x x x o x x x x o x x x x x o)
+  (o o o o o o o o x o o o x x x x x x x o)
+  (o o o o o o x x x x x x o o o x x x o o)
+  (o o o o o x x x x x x x o o x x o o o o)
+  (o o o x x x x x x x x x x x x x x o o o)
+  (x x x x o x x x x x x x x x x o x x x x)
+  (x x x x o o o o o o o o o o o o x x x x)))
+
+("Hattori 91"
+ ((5 5)
+  (1 1 1 1)
+  (1 1)
+  (7)
+  (4 1 2 2 3)
+  (6 1 1 1 5)
+  (4 3 1 3 3)
+  (3 7 2)
+  (2 1 1 1)
+  (1 1 3 1 1)
+  (1 1 1)
+  (2 1 3 1 2)
+  (18)
+  (2 3 2)
+  (2 1 4 1 1)
+  (1 6 1)
+  (2 5 2 2)
+  (2 2 4 2 2)
+  (4 3 3)
+  (1 2 1))
+ ((7)
+  (5 2 3)
+  (4 3 2)
+  (3 2 2)
+  (2 1 2 1 2)
+  (2 2 1 1)
+  (1 1 1 2)
+  (1 5 1 2)
+  (1 1 1 1 2)
+  (5 3 7)
+  (5 10)
+  (4 3 9)
+  (1 2 1 1 2 3)
+  (1 5 1 2)
+  (1 1 1 2)
+  (2 2 1 2)
+  (2 1 2 1 2)
+  (3 1 2)
+  (4 3 2)
+  (7 4))
+ ((o o o o o x x x x x o x x x x x o o o o)
+  (o o o o o x o o o x o x o o o x o o o o)
+  (o o o o o o o o o x o x o o o o o o o o)
+  (o o o o o o o x x x x x x x o o o o o o)
+  (o x x x x o o x o x x o x x o o x x x o)
+  (x x x x x x o x o o x o o x o x x x x x)
+  (x x x x o x x x o o x o o x x x o x x x)
+  (x x x o o o o x x x x x x x o o o o x x)
+  (x x o o o o o o o x o x o o o o o o o x)
+  (x o o o x o o o o x x x o o o o x o o x)
+  (x o o o o o o o o o x o o o o o o o o x)
+  (x x o o x o o o o x x x o o o o x o x x)
+  (o x x x x x x x x x x x x x x x x x x o)
+  (o o x x o o o o o x x x o o o o o o x x)
+  (o x x o x o o o o x x x x o o o x o o x)
+  (o x o o o o o o x x x x x x o o o o o x)
+  (o x x o o o o x x x x x o x x o o o x x)
+  (o o x x o o x x o x x x x o x x o x x o)
+  (o o o x x x x o o o x x x o o x x x o o)
+  (o o o o x o o o o o o x x o o o x o o o)))
+
+("Hattori 92"
+ ((5)
+  (5 2)
+  (7 4)
+  (8 5)
+  (9 6)
+  (9 6)
+  (9 8)
+  (1 7 8)
+  (1 4 8)
+  (4 2 7)
+  (1 2 3 6)
+  (2 2 1 5 5)
+  (2 1 1 2 2 5)
+  (1 2 1 5 5)
+  (1 2 2 3 6)
+  (3 2 6)
+  (1 2 7)
+  (4 1 6)
+  (1 1 4)
+  (1 1 3))
+ ((4)
+  (2 2 1)
+  (9 5)
+  (5 1 1)
+  (6 1 1 2 1)
+  (7 1 4 1)
+  (7)
+  (8 5)
+  (10 2)
+  (10 3 2)
+  (1 3 5 4)
+  (1 2 2)
+  (1 3 5 4)
+  (10 3 5)
+  (10 6)
+  (17)
+  (16)
+  (15)
+  (13)
+  (9))
+ ((o o o o o o o o o x x x x x o o o o o o)
+  (o o o o o x x x x x o o o x x o o o o o)
+  (o o o x x x x x x x o o o x x x x o o o)
+  (o o x x x x x x x x o o o x x x x x o o)
+  (o x x x x x x x x x o o o x x x x x x o)
+  (o x x x x x x x x x o o o x x x x x x o)
+  (o o x x x x x x x x x o x x x x x x x x)
+  (o o x o x x x x x x x o x x x x x x x x)
+  (o o x o o o o x x x x o x x x x x x x x)
+  (o o x x x x o o x x o o o x x x x x x x)
+  (o o x o o o o x x o x x x o x x x x x x)
+  (o x x o x x o x o x x x x x o x x x x x)
+  (x x o o o x o x o x x o x x o x x x x x)
+  (x o o o x x o x o x x x x x o x x x x x)
+  (x o o o x x o x x o x x x o x x x x x x)
+  (x x x o o o o o x x o o o x x x x x x o)
+  (o o x o o o o o o x x o x x x x x x x o)
+  (o o x x x x o o o o x o x x x x x x o o)
+  (o o x o o o o o o o x o x x x x o o o o)
+  (o o x o o o o o o o x o x x x o o o o o)))
+
+("Hattori 93"
+ ((8 3)
+  (3 1 3 1)
+  (2 3 1)
+  (1 2 2 4)
+  (1 3 1 5)
+  (2 1 1 2 1)
+  (1 2 1 3)
+  (1 2 2)
+  (2 3 1)
+  (3 1 3 2)
+  (8 3)
+  (5 9)
+  (2 4 1)
+  (2 9)
+  (2 6 2)
+  (2 1 4 1 1)
+  (2 9 1)
+  (2 1 1 1)
+  (13 1)
+  (15 3))
+ ((9)
+  (3 1 3 1)
+  (2 3 2)
+  (1 2 2)
+  (1 2 10)
+  (2 1 1 11)
+  (1 3 2 2)
+  (2 2 2 2 2)
+  (3 3 3 1 2)
+  (3 1 3 9)
+  (7 6 2)
+  (6 2)
+  (1 4 2)
+  (4 4)
+  (1 1 1 2)
+  (1 1 1 2 1)
+  (7 1 2)
+  (5 2 3 6)
+  (1 2 1 1 1)
+  (1 2 1 1))
+ ((o x x x x x x x x o o o o o o o o x x x)
+  (x x x o o x o x x x o o o o o o o x o o)
+  (x x o o o o o o x x x o o o o o o x o o)
+  (x o o o o o x x o x x o o o o o x x x x)
+  (x o o o o x x x o o x o o o o x x x x x)
+  (x x o o x o x o o x x o o o o o x o o o)
+  (x o o o x x o o o o x o o o o o x x x o)
+  (x o o o o o o o o x x o o o o o x x o o)
+  (x x o o o o o o x x x o o o o o x o o o)
+  (x x x o o x o x x x o o o o o o x x o o)
+  (o x x x x x x x x o o o o o o o o x x x)
+  (o o x x x x x o o x x x x x x x x x o o)
+  (o o o o x x o o x x x x o x o o o o o o)
+  (o o o o x x o o x x x x x x x x x o o o)
+  (o o o o x x o o x x x x x x o o x x o o)
+  (o o o o x x o x o x x x x o o x o x o o)
+  (o o o o x x o x x x x x x x x x o x o o)
+  (o o o o x x o o o x o o o x o o o x o o)
+  (o o x x x x x x x x x x x x x o o x o o)
+  (o x x x x x x x x x x x x x x x o x x x)))
+
+("Hattori 94"
+ ((3 5)
+  (2 1 2 1)
+  (2 3 2 1)
+  (2 2 3 1)
+  (2 2 4 1)
+  (2 2 3 1 3)
+  (1 2 4 2 1 2)
+  (1 3 2 5 1)
+  (1 2 3 2 1)
+  (2 4 2 1)
+  (1 1)
+  (2 3 2 1)
+  (1 1 1 2 1)
+  (1 3 2 1)
+  (1 2 1)
+  (1 2 1)
+  (1 1 2 2 1)
+  (3 3 6 2)
+  (5 3 3)
+  (6 10))
+ ((7)
+  (3 2)
+  (6 3)
+  (4 2)
+  (3 2 3 2)
+  (2 3 1 1 3)
+  (1 4 3 1 1)
+  (6 1 2 1)
+  (2 2 1 1 2)
+  (2 4 1 2)
+  (2 4 2 3)
+  (1 5 1 3 1 1)
+  (1 3 2 6 1)
+  (1 2 2 2 1)
+  (8 1 1 1)
+  (2 1)
+  (5 1)
+  (1 1 2)
+  (2 3)
+  (14))
+ ((o o o o o x x x o o x x x x x o o o o o)
+  (o o o o x x o x o x x o o o x o o o o o)
+  (o o o x x o o x x x o x x o x o o o o o)
+  (o o o x x o o x x o x x x o x o o o o o)
+  (o o x x o o x x o x x x x o x o o o o o)
+  (o o x x o o x x o x x x o o x o x x x o)
+  (o o x o o x x o x x x x o x x o x o x x)
+  (o o x o x x x o x x o o x x x x x o o x)
+  (o o x o x x o o o o x x x o o x x o o x)
+  (o x x o o o o x x x x o o o o o x x o x)
+  (o x o o o o o o o o o o o o o o o o o x)
+  (x x o o x x x o o o o o o x x o o o o x)
+  (x o o o x o x o o o o o x x o o o o o x)
+  (x o o o x x x o o o o x x o o o o o o x)
+  (x o o o o o o o o o o x x o o o o o o x)
+  (x o o o o o o o o o o x x o o o o o o x)
+  (x o x o o o o x x o o o x x o o o o o x)
+  (x x x o o x x x o x x x x x x o o o x x)
+  (o x x x x x o o x x x o o o o o o x x x)
+  (o o o x x x x x x o x x x x x x x x x x)))
+
+("Hattori 95"
+ ((3 9)
+  (1 2 1 1 1 2)
+  (1 1 1 2)
+  (5 1 3 1)
+  (4 1 1)
+  (13)
+  (13)
+  (2 3)
+  (8 3)
+  (11 2)
+  (2 5)
+  (11 1)
+  (1 1 1 1 5)
+  (2 1 1 1 2)
+  (2 2 3)
+  (5 2 2)
+  (2 1 4 1 2)
+  (3 4 2 2 2)
+  (6 1 2 5)
+  (3 2 5 2 2))
+ ((4 3)
+  (1 1 4)
+  (2 2 5)
+  (5 1 1)
+  (4 2 3 3)
+  (4 7 3)
+  (1 5 1 3)
+  (4 2 2 3 2)
+  (1 3 2 1 1 1)
+  (2 1 2 2 4 2 1)
+  (1 1 2 2 1 1 2 1)
+  (2 1 2 2 1 1 1)
+  (1 3 2 3 2)
+  (4 2 2 1 2)
+  (3 3 4 3)
+  (4 6 2)
+  (5 3 2)
+  (3 1 2 1)
+  (3 5)
+  (4))
+ ((x x x o o o x x x x x x x x x o o o o o)
+  (x o x x o o o x o x o x o x x o o o o o)
+  (x o o x o o o x o o o o o x x o o o o o)
+  (x x x x x o o x o x x x o x o o o o o o)
+  (o o x x x x o o x o o o x o o o o o o o)
+  (o o o x x x x x x x x x x x x x o o o o)
+  (o o o o x x x x x x x x x x x x x o o o)
+  (o o o o o x x o o o o o o o x x x o o o)
+  (o o o o o o x x x x x x x x o x x x o o)
+  (o o o o x x x x x x x x x x x o x x o o)
+  (o o o o x x o o o o o o o o x x x x x o)
+  (o o o o o x x x x x x x x x x x o o x o)
+  (o o o o o x o x o x o o x o x x x x x o)
+  (o o o o x x o x o x o o x o o x x o o o)
+  (o o o o x x o o o x x o o o o x x x o o)
+  (o o x x x x x o o o o o o o x x o x x o)
+  (o x x o o o x o x x x x o o x o o o x x)
+  (x x x o x x x x o x x o o x x o o o x x)
+  (x x x x x x o x o o o o x x o x x x x x)
+  (x x x o x x o o x x x x x o o x x o x x)))
+
+("Hattori 96"
+ ((4 4)
+  (2 3)
+  (5 8)
+  (3 10)
+  (3 3 1 4)
+  (3 2 2 2 1 1)
+  (3 2 1 1 1)
+  (3 2 1 1 2)
+  (4 2 1 3)
+  (4 1 3)
+  (9 5)
+  (4 6)
+  (14)
+  (1 1 1 2 4)
+  (3 2 3)
+  (6 3 3)
+  (13 3)
+  (4 1 4 4)
+  (3 2 4 1 1)
+  (4 2 5 4))
+ ((2)
+  (9 1)
+  (1 8 4)
+  (1 9 5)
+  (3 4 5)
+  (1 4 4 4)
+  (2 6 3 3 1)
+  (1 3 9 2)
+  (1 2 1 1 1 4)
+  (1 2 3 1 2 1 1)
+  (3 1 1 1 1 2)
+  (2 3 1 2 4)
+  (2 1 1 5)
+  (3 11)
+  (4 10)
+  (2 6)
+  (5 4 3)
+  (8 1)
+  (7 1)
+  (7))
+ ((o x x x x o x x x x o o o o o o o o o o)
+  (x x o o x x x o o o o o o o o o o o o o)
+  (x x x x x o o x x x x x x x x o o o o o)
+  (o x x x o o x x x x x x x x x x o o o o)
+  (o x x x o x x x o o x o o x x x x o o o)
+  (o x x x o x x o x x o x x o x o x o o o)
+  (o x x x o x x o o x o x o o o o x o o o)
+  (o x x x o x x o o x o x o o o x x o o o)
+  (o x x x x o x x o o x o o o x x x o o o)
+  (o o x x x x o x o o o o o x x x o o o o)
+  (o o o x x x x x x x x x o x x x x x o o)
+  (o o o o x x x x o o o o o x x x x x x o)
+  (o o o o o x x x x x x x x x x x x x x o)
+  (o o o o o o o x o x o x o x x o x x x x)
+  (o o o o o x x x o o o o o x x o o x x x)
+  (o o o x x x x x x o o o x x x o o x x x)
+  (o o x x x x x x x x x x x x x o o x x x)
+  (o o x x x x o o x o o x x x x o x x x x)
+  (o o x x x o o x x o x x x x o o x o o x)
+  (o x x x x o x x o x x x x x o o x x x x)))
+
+("Hattori 97"
+ ((7 3 2)
+  (2 6 3)
+  (12 2 4)
+  (3 6 1)
+  (2 4 3 3)
+  (2 1 1 1 1)
+  (3 1 3)
+  (1 1 1 1)
+  (1 2 3 2)
+  (2 1 4 2)
+  (1 1 1 1)
+  (2 2 3 2)
+  (1 2 1 2)
+  (2 2 2 2)
+  (1 2 2 1 1)
+  (1 2 4 2)
+  (1 2 3 4)
+  (1 5 2 3)
+  (2 1 1 1)
+  (16 1))
+ ((8 5)
+  (6 3 1 2)
+  (3 3 4 1)
+  (1 1 2 1 1)
+  (1 1 2 1 1)
+  (1 1 2 2 1)
+  (1 1 1 1 2 2 1)
+  (1 1 2 2 2 1 1)
+  (1 1 1 5 1 1 1)
+  (10 1 1 1 1)
+  (3 2 1 1 1)
+  (5 2 2 1)
+  (2 2 4 1)
+  (5 4)
+  (3 1 1)
+  (1 1)
+  (1 4)
+  (8 3)
+  (3 1 1 4 7)
+  (3 3 1 1 1))
+ ((o o o x x x x x x x o x x x o o o o x x)
+  (o x x o o o o o o x x x x x x o o x x x)
+  (x x x x x x x x x x x x o x x o x x x x)
+  (x x x o o o o o o x x x x x x o o x o o)
+  (x x o o o o x x x x o x x x o o o x x x)
+  (x x o o o o o x o x o o o o o o o x o x)
+  (x x x o o o o o o x o o o o o o o x x x)
+  (x o x o o o o o o x o o o o o o o x o o)
+  (x o x x o o o x x x o o o o o o o x x o)
+  (x x o x o o x x x x o o o o o o o o x x)
+  (o x o o x o o o x o o o o o o o o o x o)
+  (o x x o x x o o x x x o o o o o o o x x)
+  (o o x o o x x o x o x x o o o o o o o o)
+  (o x x o o o x x o o o x x o o o o o x x)
+  (x o x x o o o x x o o o x o o o o o x o)
+  (x o o o x x o o o x x x x o o o o x x o)
+  (x o o o o x x o o o o x x x o x x x x o)
+  (x o o o o o x x x x x o o x x o x x x o)
+  (x x o o o o o o o o o o o x o o x o x o)
+  (o x x x x x x x x x x x x x x x x o x o)))
+
+("Hattori 98"
+ ((3)
+  (7)
+  (2 3 3)
+  (8 1 4)
+  (2 3 5)
+  (10)
+  (9)
+  (3 4)
+  (4 10)
+  (3 10)
+  (3 9)
+  (2 4 4)
+  (2 15)
+  (2 15)
+  (3 13)
+  (4 5 5)
+  (7 7)
+  (18)
+  (17)
+  (13))
+ ((1 1 8)
+  (3 11)
+  (1 3 5)
+  (1 2 5)
+  (1 2 3 4)
+  (1 1 4 4)
+  (3 5 4)
+  (5 7 3)
+  (6 3 4 3)
+  (2 2 3 4 3)
+  (2 1 2 3 4 3)
+  (2 2 3 4 3)
+  (6 3 4 3)
+  (9 3 4)
+  (8 4 4)
+  (7 9)
+  (5 8)
+  (8)
+  (6)
+  (4))
+ ((o o o o o o o o o x x x o o o o o o o o)
+  (o o o o o o o x x x x x x x o o o o o o)
+  (x x o o o o x x x o o o x x x o o o o o)
+  (o x x x x x x x x o x o x x x x o o o o)
+  (x x o o o o x x x o o o x x x x x o o o)
+  (o o o o o o o x x x x x x x x x x o o o)
+  (o o o o o o o o x x x x x x x x x o o o)
+  (o o o x x x o o o o o o o x x x x o o o)
+  (o x x x x o o x x x x x x x x x x o o o)
+  (x x x o o o x x x x x x x x x x o o o o)
+  (x x x o x x x x x x x x x o o o o o o o)
+  (x x o o x x x x o o o o o o x x x x o o)
+  (x x o o x x x x x x x x x x x x x x x o)
+  (x x o o o x x x x x x x x x x x x x x x)
+  (x x x o o o o x x x x x x x x x x x x x)
+  (x x x x o o o o x x x x x o o x x x x x)
+  (x x x x x x x o o o o o o x x x x x x x)
+  (o x x x x x x x x x x x x x x x x x x o)
+  (o x x x x x x x x x x x x x x x x x o o)
+  (o o o x x x x x x x x x x x x x o o o o)))
+
+("Hattori 99"
+ ((8)
+  (14)
+  (14)
+  (14)
+  (8 1)
+  (1 1)
+  (1 1)
+  (1 1)
+  (1 1)
+  (1 1)
+  (1 1)
+  (1 1)
+  (1 1)
+  (1 4)
+  (4 6)
+  (6 7)
+  (7 7)
+  (7 6)
+  (6 4)
+  (4))
+ ((3)
+  (5)
+  (5)
+  (6)
+  (6)
+  (5)
+  (17)
+  (4)
+  (4)
+  (4)
+  (4)
+  (4)
+  (5)
+  (5 3)
+  (4 5)
+  (4 5)
+  (4 6)
+  (4 6)
+  (4 5)
+  (17))
+ ((o o o o o o o o o o o o x x x x x x x x)
+  (o o o o o o x x x x x x x x x x x x x x)
+  (o o o o o o x x x x x x x x x x x x x x)
+  (o o o o o o x x x x x x x x x x x x x x)
+  (o o o o o o x x x x x x x x o o o o o x)
+  (o o o o o o x o o o o o o o o o o o o x)
+  (o o o o o o x o o o o o o o o o o o o x)
+  (o o o o o o x o o o o o o o o o o o o x)
+  (o o o o o o x o o o o o o o o o o o o x)
+  (o o o o o o x o o o o o o o o o o o o x)
+  (o o o o o o x o o o o o o o o o o o o x)
+  (o o o o o o x o o o o o o o o o o o o x)
+  (o o o o o o x o o o o o o o o o o o o x)
+  (o o o o o o x o o o o o o o o o x x x x)
+  (o o o x x x x o o o o o o o x x x x x x)
+  (o x x x x x x o o o o o o x x x x x x x)
+  (x x x x x x x o o o o o o x x x x x x x)
+  (x x x x x x x o o o o o o x x x x x x o)
+  (x x x x x x o o o o o o o o x x x x o o)
+  (o x x x x o o o o o o o o o o o o o o o)))
+
+("Hattori 100"
+ ((3 7)
+  (4 9 2)
+  (4 10 1)
+  (4 1 6 1)
+  (5 1 1 1 2 1)
+  (5 1 1 1 2 1)
+  (5 7 2 1)
+  (16 1)
+  (11 1)
+  (3 8 2)
+  (2 1 11)
+  (2 14)
+  (3 13)
+  (5 11)
+  (3 6 3 3)
+  (2 4 2 4 1)
+  (1 3 2 7)
+  (6 4 2 5)
+  (3 3 2 2 1)
+  (4 3 2))
+ ((7 3 3)
+  (7 5 1 2)
+  (8 1 3 2)
+  (7 2 2 2)
+  (4 3 2 1)
+  (1 3 3 1)
+  (3 2 3 2)
+  (3 2 2 3)
+  (9 5 2)
+  (3 9 2)
+  (3 1 12)
+  (3 10 2)
+  (14 4)
+  (4 11 1)
+  (4 1 10)
+  (4 12)
+  (8 4 5)
+  (6 2 2 2 1)
+  (1 3 2 2)
+  (10 2 2))
+ ((x x x o o o o o o x x x x x x x o o o o)
+  (x x x x o o o o x x x x x x x x x o x x)
+  (x x x x o o o o x x x x x x x x x x o x)
+  (x x x x o o o o x o o o x x x x x x o x)
+  (x x x x x o o o x o x o x o o o x x o x)
+  (x x x x x o o o x o o o x o x o x x o x)
+  (x x x x x o x x x x x x x o o o x x o x)
+  (o o x x x x x x x x x x x x x x x x o x)
+  (o o o o o o x x x x x x x x x x x o o x)
+  (o x x x o o o o x x x x x x x x o o x x)
+  (x x o x o o o o o x x x x x x x x x x x)
+  (x x o o o x x x x x x x x x x x x x x o)
+  (x x x o x x x x x x x x x x x x x o o o)
+  (o x x x x x o o x x x x x x x x x x x o)
+  (o o x x x o x x x x x x o x x x o x x x)
+  (x x o o o x x x x o x x o x x x x o o x)
+  (x o o o x x x o o x x o x x x x x x x o)
+  (x x x x x x o x x x x o x x o x x x x x)
+  (o x x x o o x x x o o x x o o x x o o x)
+  (o o o o x x x x o o o x x x o o x x o o)))
+
+("Hattori 101"
+ ((5)
+  (7)
+  (9)
+  (1 1 1 1)
+  (1 1)
+  (1 2 1)
+  (2 2)
+  (1 4 1 1)
+  (6 4 7)
+  (1 2 4 2 2)
+  (1 4 4 7)
+  (1 1 1 1 1 1)
+  (3 1 1 1 1)
+  (4 8 1 1)
+  (1 3 1)
+  (1 7 1)
+  (1 4 4 1)
+  (2 9 2)
+  (1 5 5 1)
+  (11))
+ ((1)
+  (6 3)
+  (1 2 2)
+  (1 4)
+  (1 1 1 2)
+  (1 3 2 4)
+  (11 7)
+  (3 1 1 5)
+  (4 7 5)
+  (3 1 4 1 1 1 1)
+  (4 1 4 1 5)
+  (3 7 5)
+  (6 7)
+  (6 1 4)
+  (3 3 2)
+  (1 1)
+  (1 1)
+  (1 1 2)
+  (3 5)
+  (4))
+ ((o o o o o o o x x x x x o o o o o o o o)
+  (o o o o o o x x x x x x x o o o o o o o)
+  (o o o o x x x x x x x x x o o o o o o o)
+  (o o o o o o x o x o x o x o o o o o o o)
+  (o o o o o o x o o o o o x o o o o o o o)
+  (o o o o o o x o o x x o x o o o o o o o)
+  (o o o o o o x x o o o o x x o o o o o o)
+  (o o o o o o x o x x x x o x o o o o o x)
+  (o x x x x x x o x x x x o x x x x x x x)
+  (o x o o o x x o x x x x o x x o o o x x)
+  (o x o x x x x o x x x x o x x x x x x x)
+  (o x o x o o x o x o o x o x o o o o o o)
+  (o x x x o x o o x o o x o o x o o o o o)
+  (x x x x o x x x x x x x x o x o o o x o)
+  (o o o o o o x o o o o o x x x o o o x o)
+  (o x o o o o x x x x x x x o o o o o x o)
+  (o x o o o x x x x o x x x x o o o o x o)
+  (o x x o o x x x x x x x x x o o o x x o)
+  (o o x o x x x x x o x x x x x o o x o o)
+  (o o o o x x x x x x x x x x x o o o o o)))
+
+("Hattori 102"
+ ((2 7)
+  (1 5 3)
+  (2 7 2 2 1)
+  (1 2 2 2 2 1)
+  (1 2 2 3 1)
+  (1 2 4 6)
+  (4 6 5)
+  (3 6 4)
+  (1 4 1)
+  (3 1 3 1)
+  (6 5 1)
+  (7 5 2)
+  (3 5 3 1)
+  (1 1 1 6 2)
+  (1 2 1 2 3)
+  (1 4 1 5 1)
+  (1 4 4 3)
+  (7 1)
+  (1 1)
+  (4))
+ ((1 5)
+  (5 1)
+  (1 9)
+  (3 4 3 2)
+  (6 3 1 2)
+  (3 2 2)
+  (2 2 8)
+  (4 9 2)
+  (4 4 3 1 1)
+  (3 4 2 1 1)
+  (1 5 6 1)
+  (1 2 2 2 5 1)
+  (1 2 4 5)
+  (3 4 2)
+  (1 2 4 2)
+  (2 4 2 1)
+  (6 4)
+  (5 3 1)
+  (7 3)
+  (4))
+ ((o o x x o o o x x x x x x x o o o o o o)
+  (o o o x o x x x x x o o o x x x o o o o)
+  (x x o x x x x x x x o o x x o x x o o x)
+  (o x o o x x o x x o o x x o o o x x o x)
+  (o x o x x o o o o o x x o o o x x x o x)
+  (o x o x x o o x x x x o o o x x x x x x)
+  (o x x x x o x x x x x x o o x x x x x o)
+  (o o x x x o x x x x x x o o o x x x x o)
+  (o o x o o o o x x x x o o o o o o o x o)
+  (o o x x x o o x o o o o x x x o o o x o)
+  (o o x x x x x x o o o x x x x x o o x o)
+  (o o x x x x x x x o o x x x x x o x x o)
+  (x x x o o o x x x x x o x x x o o x o o)
+  (x o x o x o x x x x x x o o o o x x o o)
+  (x o x x o o x o o o x x o o x x x o o o)
+  (x o o x x x x o x o x x x x x o x o o o)
+  (x o o o x x x x o o x x x x o o x x x o)
+  (o o o o o o x x x x x x x o o o o o x o)
+  (o o o o o o o o o o o o x o o o o o x o)
+  (o o o o o o o o o x x x x o o o o o o o)))
+
+("Hattori 103"
+ ((7)
+  (2 2)
+  (1 2 2 1)
+  (1 1 1 1)
+  (1 5 1)
+  (1 1 1 1)
+  (9)
+  (9)
+  (1 1 2)
+  (9 4)
+  (9 4)
+  (9 2)
+  (9)
+  (1 1 7)
+  (9 7)
+  (10 2)
+  (1 1 2)
+  (10 2)
+  (9 2)
+  (9 2))
+ ((3)
+  (1 1)
+  (1 1)
+  (1 4)
+  (1 2 1)
+  (12 2 3)
+  (2 2 4 2 3)
+  (1 1 4 4 2 3)
+  (1 3 2 7 3)
+  (1 1 2 3 1 3)
+  (1 3 2 3 1 3)
+  (1 1 4 3 1 3)
+  (2 2 3 5)
+  (11 2 2)
+  (2)
+  (2 2)
+  (4 7)
+  (4 7)
+  (2 2)
+  (2))
+ ((o o o o o o x x x x x x x o o o o o o o)
+  (o o o o o x x o o o o o x x o o o o o o)
+  (o o o o o x o x x o x x o x o o o o o o)
+  (o o o o o x o o x o x o o x o o o o o o)
+  (o o o o o x o x x x x x o x o o o o o o)
+  (o o o o o x o x o o o x o x o o o o o o)
+  (o o o o o x x x x x x x x x o o o o o o)
+  (o o o o o x x x x x x x x x o o o o o o)
+  (o o o o o x o o o o o o o x o o x x o o)
+  (o o o o o x x x x x x x x x o x x x x o)
+  (o o o o o x x x x x x x x x o x x x x o)
+  (o o o o o x x x x x x x x x o o x x o o)
+  (x x x x x x x x x o o o o o o o o o o o)
+  (x o o o o o o o x o o o o x x x x x x x)
+  (x x x x x x x x x o o o o x x x x x x x)
+  (o o o x x x x x x x x x x o o o x x o o)
+  (o o o x o o o o o o o o x o o o x x o o)
+  (o o o x x x x x x x x x x o o o x x o o)
+  (o o o o o x x x x x x x x x o o x x o o)
+  (o o o o o x x x x x x x x x o o x x o o)))
+
+("Hattori 104"
+ ((11)
+  (1 1)
+  (1 1)
+  (2 1 1 1)
+  (5 1)
+  (3 1)
+  (5 1)
+  (7 1)
+  (9 1)
+  (9 1)
+  (8 1)
+  (6 4 1)
+  (1 3 1)
+  (3 2 3 1)
+  (2 1 4 1)
+  (1 3 5 1)
+  (1 1 4 1)
+  (5 5)
+  (7 4 1)
+  (9 5))
+ ((3)
+  (3)
+  (6)
+  (2 3)
+  (1 1 3)
+  (3 1 2)
+  (2 1 2 2)
+  (1 5 1)
+  (2 6 1)
+  (1 8)
+  (12)
+  (1 7 2)
+  (1 2 6 1 1)
+  (1 5 1 1)
+  (1 9 2)
+  (1 9)
+  (1 8)
+  (1 5)
+  (1 1)
+  (19))
+ ((o o o o o o o o o x x x x x x x x x x x)
+  (o o o o o o o o o o x o o o o o o o o x)
+  (o o o o o o o o o o x o o o o o o o o x)
+  (o o o o o o o x x o x o x o o o o o o x)
+  (o o o o o o o o x x x x x o o o o o o x)
+  (o o o o o o o o o x x x o o o o o o o x)
+  (o o o o o o o o x x x x x o o o o o o x)
+  (o o o o o o o x x x x x x x o o o o o x)
+  (o o o o o o x x x x x x x x x o o o o x)
+  (o o o o o o x x x x x x x x x o o o o x)
+  (o o o o o o o x x x x x x x x o o o o x)
+  (o o o o o x x x x x x o x x x x o o o x)
+  (o o o o o x o o o o o o o o x x x o o x)
+  (o o o x x x o o o o o x x o x x x o o x)
+  (o o x x o o o o o o o x o o x x x x o x)
+  (o o x o x x x o o o o o o x x x x x o x)
+  (o o x o o o x o o o o o o o x x x x o x)
+  (x x x x x o o o o o o o o o o x x x x x)
+  (x x x x x x x o o o o o o o x x x x o x)
+  (x x x x x x x x x o o o x x x x x o o o)))
+
+("Hattori 105"
+ ((3)
+  (2 6)
+  (2 2 2)
+  (2 2 2)
+  (13)
+  (1 2)
+  (1 3 3 1)
+  (1 1 1 1 1 1)
+  (1 3 3 1)
+  (3 1)
+  (1 4 1)
+  (1 4 1 1)
+  (1 1 2 1 2 1)
+  (1 1 2 1 1 1)
+  (4 2 3 1)
+  (1 2)
+  (2 1)
+  (3 2)
+  (4 2)
+  (11))
+ ((6)
+  (1 1)
+  (7 3)
+  (3 3)
+  (2 1 3 2)
+  (2 1 1 1 1 1)
+  (1 1 3 4 2)
+  (2 1 4 1)
+  (2 1 3 1 1)
+  (4 1 1 2)
+  (1 2 3 5 1)
+  (1 1 1 1 1)
+  (2 1 1 3 1)
+  (3 1 1 1)
+  (3 1)
+  (11 1)
+  (3 1)
+  (3)
+  (2)
+  (1))
+ ((o o o o o x x x o o o o o o o o o o o o)
+  (o o o o x x o x x x x x x o o o o o o o)
+  (o o o x x o o o x x o o x x o o o o o o)
+  (o o x x o o o o o x x o o x x o o o o o)
+  (o o x x x x x x x x x x x x x o o o o o)
+  (o o x o o o o o o o o o o o x x o o o o)
+  (o o x o x x x o x x x o o o o x o o o o)
+  (o o x o x o x o x o x o o o o x o o o o)
+  (o o x o x x x o x x x o o o o x o o o o)
+  (x x x o o o o o o o o o o o o x o o o o)
+  (x o o o o o o o o o x x x x o x o o o o)
+  (x o o o o x x x x o x o o o o x o o o o)
+  (x o x o o o x x o o x o x x o x o o o o)
+  (x o x o o o x x o o x o x o o x o o o o)
+  (x x x x o o x x o o x x x o o x o o o o)
+  (o o o x o o o o o o o o o o o x x o o o)
+  (o o o x x o o o o o o o o o o o x o o o)
+  (o o o o x x x o o o o o o o o o x x o o)
+  (o o o o o o x x x x o o o o o o o x x o)
+  (o o o o o o o o o x x x x x x x x x x x)))
+
+("Hattori 106"
+ ((3 3 4)
+  (2 1 3 1 2 1)
+  (1 9 1 4)
+  (13 1)
+  (9 4)
+  (3 4 1)
+  (1 2 3 1 4)
+  (1 7 1 1 2 1)
+  (2 1 3 2 4 1)
+  (2 1 1 2 1)
+  (2 1 2 2 1)
+  (1 1 1 4)
+  (1 1 1 1 1)
+  (2 1 2 3)
+  (1 1 1 1)
+  (1 1 1 4)
+  (1 3 1 2 1)
+  (1 5 1 4)
+  (1 7 1 2 1)
+  (13 4))
+ ((1 1 6)
+  (3 4 4 1)
+  (1 1 2 1)
+  (8 1)
+  (5 2 2)
+  (1 3 1 3)
+  (5 2 4)
+  (4 13)
+  (5 2 4)
+  (1 3 2 3)
+  (5 1 2)
+  (7 1)
+  (1 1 3 1)
+  (3 1 4 1)
+  (1 4 6)
+  (1)
+  (20)
+  (1 1 1 6 1 5)
+  (1 1 1 1 3 1 1 1)
+  (1 1 1 6 5))
+ ((o o o o x x x o x x x o o o o o x x x x)
+  (x x o o x o x x x o x o o x x o x o o o)
+  (o x o x x x x x x x x x o x o o x x x x)
+  (o x x x x x x x x x x x x x o o x o o o)
+  (o o o x x x x x x x x x o o o o x x x x)
+  (o x x x o o o o o o o x x x x o x o o o)
+  (o x o x x o o o o x x x o o x o x x x x)
+  (o x o x x x x x x x o x o o x o x x o x)
+  (x x o x o o x x x o o x x o x x x x o x)
+  (o o x x o o o x o o o o x o o o x x o x)
+  (o x x o o o o x o o o o x x o o x x o x)
+  (o x o o o o o x o o o o o x o o x x x x)
+  (o x o o o o o x o o o o o x o o x o x o)
+  (x x o o o o o x o o o o o x x o x x x o)
+  (x o o o o o o x o o o o o o x o x o o o)
+  (x o o o o o o x o o o o o o x o x x x x)
+  (x o o o o o x x x o o o o o x o x x o x)
+  (x o o o o x x x x x o o o o x o x x x x)
+  (x o o o x x x x x x x o o o x o x x o x)
+  (o x x x x x x x x x x x x x o o x x x x)))
+
+("Hattori 107"
+ ((1)
+  (1 5)
+  (1 1 1 1)
+  (1 8)
+  (1 4 1 2)
+  (1 14)
+  (1 4 9 1)
+  (1 1 1 3)
+  (2 12 2)
+  (5 2 1 2 6)
+  (8 8)
+  (1 2 2 2 2 3)
+  (1 13)
+  (1 4 4)
+  (1 1 1 1)
+  (1 1 1 1)
+  (1 7)
+  (1 1 1)
+  (1 3 3)
+  (1 1 1))
+ ((3)
+  (19)
+  (2)
+  (2 5)
+  (3 6)
+  (4 1 1 2)
+  (15 1)
+  (1 3 6 4)
+  (1 1 2 1 1 1 1)
+  (7 2 1 3)
+  (1 1 2 1 1 1 1)
+  (1 4 6 4)
+  (15 1)
+  (2 1 1 2)
+  (2 6)
+  (2 4)
+  (2 2)
+  (5)
+  (6)
+  (1 1 1))
+ ((o o o o o o o o o x o o o o o o o o o o)
+  (o x o o o o o x x x x x o o o o o o o o)
+  (o x o o o o x o o x o o x o o o o o o o)
+  (o x o o o x x x x x x x x o o o o o o o)
+  (o x o o x x x x o x o x x o o o o o o o)
+  (o x o x x x x x x x x x x x x x x o o o)
+  (o x o x x x x o x x x x x x x x x o x o)
+  (o x o o o o x o o o o o x o o o o x x x)
+  (x x o x x x x x x x x x x x x o o x x o)
+  (x x x x x o x x o x o x x o x x x x x x)
+  (x x x x x x x x o o o x x x x x x x x o)
+  (o x o x x o x x o o o x x o x x o x x x)
+  (o x o x x x x x x x x x x x x x o o o o)
+  (o x o o x x x x o o o x x x x o o o o o)
+  (o x o o o o x o o x o o x o o o o o o o)
+  (o x o o o o x o o x o o x o o o o o o o)
+  (o x o o o o x x x x x x x o o o o o o o)
+  (o x o o o o o x o o o x o o o o o o o o)
+  (o x o o o o x x x o x x x o o o o o o o)
+  (o x o o o o o x o o o x o o o o o o o o)))
+
+("Hattori 108"
+ ((11 7)
+  (1 2 1 1 9)
+  (1 1 1 3 10)
+  (6 2 1 10)
+  (1 4 1 10)
+  (1 4 1 1 5)
+  (1 1 3 1 1)
+  (1 2 1 2 1 4 3)
+  (3 1 3 4 3)
+  (1 1 1 2 1 1 1)
+  (11 4 3)
+  (1 1)
+  (1 1 6)
+  (1 1 1 6)
+  (1 4 1 4)
+  (1 2 1 2 2)
+  (3 1 1 5)
+  (5 3 1 1)
+  (6 2 1 1 1)
+  (6 2 1 11)
+  (2 4 1 8)
+  (1 4 2 8)
+  (12 12)
+  (4 1 8)
+  (4 3 2 1)
+  (4 3 2 2 1)
+  (4 1 8 1)
+  (4 1 1)
+  (4 4 1)
+  (6 15))
+ ((16 4)
+  (1 1 1 1 8)
+  (2 1 2 1 3 7)
+  (4 3 1 3 8)
+  (1 3 1 4 1 4)
+  (11 6 1 2)
+  (1 3 1 8 1)
+  (1 2 2 1 6 2)
+  (1 2 2 1 3 5)
+  (1 1 1 1 2 2 1 1)
+  (11 6 1 2 2)
+  (1 1 3 1)
+  (2 5 2 1)
+  (2 2 2 1)
+  (5 1 1 1)
+  (3 1 1 1 1)
+  (15 1 1 1 1)
+  (4 4 2 5 1 1)
+  (5 2 1 2 1 5 1 1)
+  (5 4 3 1 8 1)
+  (6 3 1 8 1)
+  (6 3 8 1)
+  (6 4 3 5 1)
+  (6 2 1 2 5 1)
+  (6 4 11))
+ ((x x x x x x x x x x x o o o o o o o x x x x x x x)
+  (x o x x o x o o o o x o o o o o x x x x x x x x x)
+  (x o o x o x o o x x x o o o o x x x x x x x x x x)
+  (x x x x x x o x x o x o o o o x x x x x x x x x x)
+  (x o o o x x x x o o x o o o o x x x x x x x x x x)
+  (x o o x x x x o o o x o o o o o x o o o x x x x x)
+  (x o o x o x x x o o x o o o o o x o o o o o o o o)
+  (x o x x o x o x x o x o o o o o x x x x o o x x x)
+  (x x x o o x o o x x x o o o o o x x x x o o x x x)
+  (x o o o o x o o o o x o o o o o x x o x o o x o x)
+  (x x x x x x x x x x x o o o o o x x x x o o x x x)
+  (x o o o o o o o o o o o o o o o x o o o o o o o o)
+  (x o o o o o o o o o o o o o o o x o x x x x x x o)
+  (x o o o o o o o o o o o x o o o x o x x x x x x o)
+  (x o o o o o o o o o x x x x o o x o o x x x x o o)
+  (x o o o o x x o o o x o o x x o x x o o o o o o o)
+  (o o o o x x x o o o x o o o x o o x x x x x o o o)
+  (o o o x x x x x o o x x x o x o o o o o o x o o o)
+  (o o x x x x x x o x x o x o x o o o o o o x o o o)
+  (o o x x x x x x o x x o x o x x x x x x x x x x x)
+  (o x x o o x x x x o o o x o o o o x x x x x x x x)
+  (o x o o o o x x x x o o x x o o o x x x x x x x x)
+  (x x x x x x x x x x x x o x x x x x x x x x x x x)
+  (x x x x o o o o o o o x o o o o o x x x x x x x x)
+  (x x x x o o o o o o x x x o o o o o o x x o o o x)
+  (x x x x o o o o x x x o x x o o o o o x x o o o x)
+  (o x x x x o o o x o o o o x x x x x x x x o o o x)
+  (o x x x x o o o x o o o o o o o o o o o o o o o x)
+  (o o x x x x o x x x x o o o o o o o o o o o o o x)
+  (o o o x x x x x x o x x x x x x x x x x x x x x x)))
+
+("Hattori 109"
+ ((11 7)
+  (13 11)
+  (16 13)
+  (31)
+  (9 18)
+  (7 17)
+  (4 1 1 1 2 8)
+  (3 1 1 1 1 2 6)
+  (3 2 3 1 2 2 6)
+  (3 1 1 2 2 5)
+  (5 2 1 8 4)
+  (4 2 3 1 1 1 4)
+  (3 3 1 1 1 3)
+  (4 4 1 2 5)
+  (1 7 6 1 2)
+  (2 1 2 2 1 2 3)
+  (4 1 2 2 2 5)
+  (4 11 4 1)
+  (10 2 2 1 3)
+  (20 1 1 2)
+  (2 4 3 3 3 2 4)
+  (1 2 4 2 2 5 1)
+  (1 5 1 1 1 2 3 1 1)
+  (1 1 5 6 1 2 5)
+  (1 1 5 4 1 1 1 1)
+  (1 1 1 5 1 1 1)
+  (1 1 5 5 1)
+  (1 3 4 2 1)
+  (1 2 3 6 1)
+  (4 4 3 3 2 1)
+  (17 12)
+  (10 7 9))
+ ((8 8 1)
+  (10 3 2 2)
+  (13 4 4)
+  (7 4 4 3)
+  (6 2 4 6 3)
+  (6 1 8 3)
+  (6 8 2)
+  (5 2 5 2)
+  (5 1 2 1 2 3 2)
+  (4 1 1 3 4 3)
+  (4 3 1 4 6 1 2)
+  (4 2 1 1 3 2 5)
+  (4 4 21)
+  (4 8 2)
+  (4 1 2 1 2 10)
+  (12 1 3 9)
+  (4 18)
+  (7 6 5 2)
+  (13 1 1 3 2 2)
+  (5 1 1 7 4)
+  (6 1 3 1 4)
+  (6 4 1 2 2 3 2 2)
+  (6 2 2 1 2 2)
+  (6 1 4 2 4)
+  (7 1 1 2 2 3 3)
+  (7 1 1 1 1 2)
+  (9 2 1 1 2)
+  (9 1 2 3 1 2)
+  (11 1 1 2 4 1)
+  (13 2 2 1 1 1)
+  (16 2 1 1)
+  (13 10))
+ ((o o o x x x x x x x x x x x o o o o o o x x x x x x x o o o o o)
+  (o o x x x x x x x x x x x x x o o o o x x x x x x x x x x x o o)
+  (o x x x x x x x x x x x x x x x x o x x x x x x x x x x x x x o)
+  (x x x x x x x x x x x x x x x x x x x x x x x x x x x x x x x o)
+  (x x x x x x x x x o o o o o x x x x x x x x x x x x x x x x x x)
+  (x x x x x x x o o o o o o o o x x x x x x x x x x x x x x x x x)
+  (x x x x o o o o o o x o x o o x o x x o o o o o x x x x x x x x)
+  (x x x o x o o o o o x o x o o x o x x o o o o o o o x x x x x x)
+  (x x x o x x o o x x x o x o x x o x x o o o o o o o x x x x x x)
+  (x x x o o o o o o o o o x o o x o x x o o x x o o o o x x x x x)
+  (x x x x x o o x x o o o o o o x o o x x x x x x x x o o x x x x)
+  (o x x x x o o x x o x x x o o x o o x o o x o o o o o o x x x x)
+  (o o x x x o o o o o o x x x o x o o x o o x o o o o o o o x x x)
+  (o o x x x x o o o o o o x x x x o o x o o o o o x x o x x x x x)
+  (o o o o o x o o x x x x x x x o x x x x x x o o o o x o o o x x)
+  (o o o o x x o o o o x o x x o o x x o o x o o o o o x x o x x x)
+  (o o x x x x o o o o x o x x o o x x o o x x o o o o o x x x x x)
+  (o o x x x x o o o x x x x x x x x x x x o x x x x o o o o o x o)
+  (x x x x x x x x x x o o x x o o x x o x o o x x x o o o o o o o)
+  (x x x x x x x x x x x x x x x x x x x x o x o x o o o o o x x o)
+  (x x o o x x x x o o x x x o x x x o o x x x o x x o o o x x x x)
+  (x o o o o o x x o x x x x o o x x o x x o o o o x x x x x o o x)
+  (x o o o o o x x x x x o x o x o x o x x o x x x o o o x o o o x)
+  (x o o o o o x o x x x x x o x x x x x x o x o x x o o x x x x x)
+  (x o o o o o x o x x x x x o x x x x o o o x o o x o o o x o o x)
+  (x o o o o o x o o o o o x o x x x x x o o o o o x o o o x o o x)
+  (o x o o o o o o o o o o x o x x x x x o o o o o o x x x x x o x)
+  (o x o o o o o o o o x x x o x x x x o o o x x o o o o o o o o x)
+  (o o x o o o o o o o o x x o x x x o x x x x x x o o o o o o o x)
+  (o o x x x x o o o x x x x o x x x o x x x o o x x o o o o o o x)
+  (o x x x x x x x x x x x x x x x x x o x x x x x x x x x x x x o)
+  (x x x x x x x x x x o x x x x x x x o x x x x x x x x x o o o o)))
+
+("Hattori 110"
+ ((2 2 8 5)
+  (3 1 2 1 4 1 1 3)
+  (1 3 8 7 2)
+  (3 4 2 2 4 4 2)
+  (2 1 5 2 2 5 4)
+  (2 1 5 1 5 3)
+  (4 1 2)
+  (4 3 2)
+  (4 2)
+  (4 6 2)
+  (5 10 3)
+  (1 8 1)
+  (30)
+  (1 5 5 6 7 1)
+  (11 3 1 2 1)
+  (3 8 8 1)
+  (1 23)
+  (1 2 9 9 1)
+  (1 3 10 5 2 1)
+  (1 6 1 2 3 1 1 2 1)
+  (3 2 14 1 1 1)
+  (1 1 2 13 1 2 1)
+  (1 1 4 6 1 1)
+  (2 1 2 7 2 1)
+  (2 2 1 1 1)
+  (2 2 2 2)
+  (1 5 2 2)
+  (1 4 2 2)
+  (1 5 2 2)
+  (1 7 3 2)
+  (1 10 7 2)
+  (30))
+ ((2 4 5)
+  (3 5 2 2 1)
+  (1 8 1 2 2 1)
+  (12 1 4 1)
+  (2 1 4 2 1)
+  (1 1 1 6 2 1)
+  (2 2 7 3)
+  (1 2 3 1 2 1 5)
+  (4 1 8 5)
+  (5 6 2 2 5)
+  (2 2 8 1 1 6)
+  (4 10 2 1 4)
+  (5 12 1 3)
+  (1 1 7 3 2 2)
+  (1 2 3 10 2 2)
+  (1 2 5 4 4 2)
+  (2 4 5 6 1 1)
+  (2 1 5 1 6 1)
+  (2 1 5 3 4 1)
+  (2 1 5 8 1)
+  (1 2 5 3 5 2)
+  (1 2 3 9 2 2)
+  (5 1 7 4 1 2)
+  (4 9 1 1 3)
+  (2 2 2 4 2 1 6)
+  (4 8 1 5)
+  (4 2 3 2 2)
+  (1 2 5 1 1 1)
+  (1 2 3 2 1)
+  (2 2 1 1 2 1)
+  (16 1 7)
+  (11 14))
+ ((x x o o o o x x o o o o o o x x x x x x x x o o o o o x x x x x)
+  (x x x o o o x o o x x o x o o o x x x x o o x o x o o o o x x x)
+  (o x o x x x o x x x x x x x x o o o o o o x x x x x x x o o x x)
+  (o o x x x o x x x x o x x o x x o o o o x x x x o x x x x o x x)
+  (o o x x o o x o x x x x x o o x x o o x x o x x x x x o x x x x)
+  (o o x x o x o o x x x x x o o o x o o o o o x x x x x o o x x x)
+  (x x x x o o o o o o o o o o o o x o o o o o o o o o o o o o x x)
+  (x x x x o o o o o o o o o o o o x x x o o o o o o o o o o o x x)
+  (x x x x o o o o o o o o o o o o o o o o o o o o o o o o o o x x)
+  (x x x x o o o o o o o o o o o x x x x x x o o o o o o o o o x x)
+  (o x x x x x o o o o o o o x x x x x x x x x x o o o o o o x x x)
+  (o o o x o o o o o o o o o o x x x x x x x x o o o o o o o o x o)
+  (o x x x x x x x x x x x x x x x x x x x x x x x x x x x x x x o)
+  (o x o x x x x x o x x x x x o x x x x x x o x x x x x x x o x o)
+  (o o o o x x x x x x x x x x x o o o o o o x x x o x o x x o x o)
+  (o o o o x x x o x x x x x x x x o o o o x x x x x x x x o o x o)
+  (o o x o o x x x x x x x x x x x x x x x x x x x x x x x o o o o)
+  (o o x o o x x o x x x x x x x x x o x x x x x x x x x o o o x o)
+  (o o o x o o x x x o x x x x x x x x x x o x x x x x o x x o o x)
+  (o o o o x o o x x x x x x o x o x x o x x x o x o x o o x x o x)
+  (o o o x x x o o x x o x x x x x x x x x x x x x x o x o o x o x)
+  (o o o x o x o x x o x x x x x x x x x x x x x o x o x x o o o x)
+  (o o o x o o o o o x o o x x x x o x x x x x x o o x o o o o o x)
+  (o o x x o o o o o x o x x o x x x x x x x o x x o o o o o o o x)
+  (o x x o o o o o o o x x o o o o o o o o o x o o x o o o o o o x)
+  (x x o o o o o o o o o o o x x o o o o o o x x o o o o o o o x x)
+  (x o o o o o o o o o x x x x x o o o o o o o o x x o o o o o x x)
+  (x o o o o o o x x x x o o o o o o o o o o o o o x x o o o o x x)
+  (x o o o o o o x x x x x o o o o o o o o o o o o x x o o o o x x)
+  (x o o o o o x x x x x x x o o o o o o o o o o x x x o o o o x x)
+  (o x o o o o x x x x x x x x x x o o o o x x x x x x x o o o x x)
+  (o o x x x x x x x x x x x x x x x x x x x x x x x x x x x x x x)))
+
+("Hattori 111"
+ ((7)
+  (1 1 2 6)
+  (2 2 1 7)
+  (5 1 8)
+  (8 1 9)
+  (5 1 10)
+  (3 1 10)
+  (2 2 6)
+  (5)
+  (1 4)
+  (1 1 6)
+  (3 1 8)
+  (4 1 1 7)
+  (1 3 1 1 1 3)
+  (3 1 1 1 2)
+  (6 3 1 1)
+  (1 2 2 1 4 1)
+  (8 3 6)
+  (3 2 1 1 10)
+  (8 1 6)
+  (5 3 12)
+  (2 4 2 1 5)
+  (4 4 1 8)
+  (6 1 2 3 1)
+  (3 2 1 1 4)
+  (1 3 4 1 1 1 2)
+  (4 2 1 1 2 2 1)
+  (2 8 4)
+  (7 2)
+  (2 1 1 1 3))
+ ((2 9 3 4)
+  (3 2 2 8 2)
+  (1 4 10 5)
+  (7 2 3 5 2)
+  (3 3 5 3)
+  (4 5 4)
+  (3 2 5 2)
+  (2 4 1 3 1)
+  (4 1 3)
+  (1 4)
+  (7 1 3)
+  (2 2 6 2)
+  (1 8 1 4 3)
+  (1 1 4 1 4)
+  (2 2 4 1 1 1 2)
+  (9 2 2 1 1)
+  (8 3 1 3 1 4)
+  (8 4 4 2 2)
+  (7 4 6 1 1)
+  (7 5 13)
+  (5 14 4)
+  (5 4 8)
+  (4 1 5 1)
+  (3 1 1 2)
+  (2 5))
+ ((o o o o o o o o o o o x x x x x x x o o o o o o o)
+  (o o o x o x o o o o x x o o x x x x x x o o o o o)
+  (o o x x o x x o o o x o o o o x x x x x x x o o o)
+  (o o o x x x x x o o x o o o o x x x x x x x x o o)
+  (x x x x x x x x o o x o o o o x x x x x x x x x o)
+  (x x x x x o o o o o x o o o o x x x x x x x x x x)
+  (o x x x o o o o o o x o o o o x x x x x x x x x x)
+  (o o x x o o o o o o x x o o x x x x x x o o o o o)
+  (o o o o o o o o o o o x x x x x o o o o o o o o o)
+  (o o o o o o o o o o o o x o o o x x x x o o o o o)
+  (x o o o o o o o o o o o x o o x x x x x x o o o o)
+  (x x x o o o o o o o o o x o x x x x x x x x o o o)
+  (x x x x o o o o o o o o x o x o o x x x x x x x o)
+  (x o x x x o o o o o o o x o x o x o o x x x o o o)
+  (x x x o x o o o o o o o x o x o o o o o x x o o o)
+  (x x x x x x o o o o o x x x o x o o o o x o o o o)
+  (x o x x o x x o o o o x o x x x x o o o x o o o o)
+  (x x x x x x x x o o o x x x o o x x x x x x o o o)
+  (x x x o x x o x o o o x o x x x x x x x x x x o o)
+  (o x x x x x x x x o o x o o o o o x x x x x x o o)
+  (x x x x x o x x x o o x x x x x x x x x x x x o o)
+  (x x o x x x x o x x o o x o o o o o x x x x x o o)
+  (x x x x o x x x x o o o x o o o o x x x x x x x x)
+  (o x x x x x x o o o o o x o o o x x o x x x o o x)
+  (x x x o x x o o o o o o o o o o x o o x o x x x x)
+  (x o x x x o o x x x x o o x o o x o o x o o o x x)
+  (x x x x o o x x o x o o o x o o x x o x x o o o x)
+  (x x o o o o x x x x x x x x o o o x x x x o o o o)
+  (o o o o o o o o x x x x x x x o o o o x x o o o o)
+  (o o o o o o o x x o x o x o x o o o x x x o o o o)))
+
+("Hattori 112"
+ ((3 6)
+  (9 4)
+  (1 1 1 5)
+  (2 2 2 3)
+  (1 1 1 1)
+  (1 2 1)
+  (15 1)
+  (4 1 4)
+  (3 1 4)
+  (3 5)
+  (7)
+  (6 1)
+  (7 2)
+  (8 1 3)
+  (7 3 3)
+  (1 2 1 1 6)
+  (1 3 4)
+  (1 2 1)
+  (1 1 2)
+  (20))
+ ((1 1)
+  (2 1)
+  (3 1)
+  (1 4 1 1)
+  (1 9 1)
+  (3 1 7 1)
+  (2 2 1 5 1)
+  (3 15)
+  (2 2 1 7 1)
+  (3 1 7 1)
+  (1 5 4 1)
+  (1 4 1)
+  (3 6)
+  (2 2 2 1)
+  (1 1 1 3 1)
+  (1 2 1 1)
+  (3 1 3 2)
+  (6 7)
+  (4 5 1)
+  (7 3 2 1))
+ ((o o o o o o x x x o o o o o x x x x x x)
+  (o o o x x x x x x x x x o o o o x x x x)
+  (o o o o o x o x o x o o o o o x x x x x)
+  (o o o o o x x o x x o o o o x x o x x x)
+  (o o o o o o x o x o o o o o o o o x o x)
+  (o o o o o o o x o o o o o o o o x x o x)
+  (x x x x x x x x x x x x x x x o o o o x)
+  (o x x x x o o x o o x x x x o o o o o o)
+  (o o x x x o o x o x x x x o o o o o o o)
+  (o o o x x x o x x x x x o o o o o o o o)
+  (o o o o x x x x x x x o o o o o o o o o)
+  (o o o o x x x x x x o o o o o o o o o x)
+  (o o o o x x x x x x x o o o o o o o x x)
+  (o o o x x x x x x x x o o x o o o x x x)
+  (o o o o x x x x x x x o x x x o x x x o)
+  (o o o o o x o x x o x o x o x x x x x x)
+  (o o o o o o o x o o o o x x x o x x x x)
+  (o o o o o o o x o o o o x x o o o x o o)
+  (o o o o o o o x o o o o x o o o x x o o)
+  (x x x x x x x x x x x x x x x x x x x x)))
+
+("Hattori 113"
+ ((9)
+  (1 3)
+  (1 1 1 3)
+  (4 1 1)
+  (1 4 1 1 1)
+  (2 1 3 1)
+  (4 2 6)
+  (1 3 1)
+  (1 1 1 1)
+  (1 3 7 1)
+  (8 1)
+  (1 7 1)
+  (10)
+  (3 1 2 1)
+  (5 1 4)
+  (5 1 1)
+  (5 7)
+  (3 1 1)
+  (1 1)
+  (10 5 3))
+ ((3 1)
+  (2 5 1)
+  (1 1 1 1 5 1)
+  (1 2 5 1)
+  (1 1 3 1)
+  (1 1 1)
+  (6 1)
+  (1 1 1)
+  (1 1 1)
+  (3 1 1 1)
+  (1 3 9)
+  (1 1 2 4 1 1)
+  (1 1 2 4 4)
+  (1 1 1 4 1 1)
+  (1 2 4 4)
+  (3 2 4 1 1)
+  (5 1 9)
+  (3 1 3 1)
+  (1 1 1 1)
+  (9 1))
+ ((o o o o o o o o o x x x x x x x x x o o)
+  (o o o o o o o o o x o o o o o x x x o o)
+  (o o o o o o o o o x o x o x o x x x o o)
+  (o x x x x o o o o o x o o o o o x o o o)
+  (o x o o o x x x x o x o x o o o x o o o)
+  (o o x x o o x o o x x x o o o x o o o o)
+  (o o o x x x x o o o o x x o x x x x x x)
+  (o o o o o o x o o o o o x x x o o o o x)
+  (o o o o o o x o o o x o o o o o x o o x)
+  (o o x o o o x x x o x x x x x x x o o x)
+  (o o o o o o o o o x x x x x x x x o o x)
+  (o o x o o o o o o o x x x x x x x o o x)
+  (o o o o o o o o o o x x x x x x x x x x)
+  (o x x x o o o o o o x o o o o o x x o x)
+  (x x x x x o o o o o x o o o o o x x x x)
+  (x x x x x o o o o o x o o o o o x o o o)
+  (x x x x x o o o o o x x x x x x x o o o)
+  (o x x x o o o o o o o o x o x o o o o o)
+  (o o o o o o o o o o o o x o x o o o o o)
+  (x x x x x x x x x x o x x x x x o x x x)))
+
+("Hattori 114"
+ ((8 7)
+  (10 7)
+  (12 1 1)
+  (4 1 1 1)
+  (3 1 1 3)
+  (3 1 1 1 1 4)
+  (2 3 4 3 3)
+  (2 1 4)
+  (3 1 3 2)
+  (2 1 2)
+  (2 3 1 2)
+  (2 3 2)
+  (2 3 2 2)
+  (6 1 3)
+  (5 3 5)
+  (6 2 2)
+  (7 2 2 1)
+  (3 8 1 6)
+  (3 7 3 1 1 1)
+  (3 6 2 5 4)
+  (4 4 3 8 2)
+  (6 1 4 5)
+  (4 5)
+  (2 4)
+  (1 4))
+ ((6 7)
+  (9 9)
+  (5 4 11)
+  (4 6 4)
+  (3 1 8 2 1)
+  (3 1 9)
+  (3 2 1 1 5)
+  (3 1 2 5)
+  (3 2 1 1 4 1)
+  (3 1 1 1 3 4)
+  (3 1 1 2 2 5)
+  (11 1 2 6)
+  (1 2 2 7)
+  (4 2)
+  (2 2 3)
+  (3 3 3)
+  (3 2 1 1 3)
+  (8 2 1 2 3)
+  (2 2 1 5)
+  (2 2 3 2)
+  (2 2 1 1 1)
+  (2 3 1 2)
+  (2 3 3)
+  (6 2)
+  (3))
+ ((o o o x x x x x x x x o o o o o o x x x x x x x o)
+  (o o x x x x x x x x x x o o o o o x x x x x x x o)
+  (o x x x x x x x x x x x x o o o o x o o o o o x o)
+  (x x x x o o o o o o o x o o o o o x o o o o o x o)
+  (x x x o o o o o o o o x o o o o o x o o o x x x o)
+  (x x x o o o x o x o o x o o o o o x o o x x x x o)
+  (x x o o x x x o x x x x o o o x x x o o x x x o o)
+  (x x o o o o o o o o o x o o x x x x o o o o o o o)
+  (x x x o o o o o o o o x o o x x x o o x x o o o o)
+  (o x x o o o o o o o o x o o o o o o x x o o o o o)
+  (o x x o o o x x x o o x o o o o o x x o o o o o o)
+  (o o x x o o o o o o x x x o o o x x o o o o o o o)
+  (o o o x x o o x x x o o x x o x x o o o o o o o o)
+  (o o x x x x x x o o x o o x x x o o o o o o o o o)
+  (o x x x x x o o o x x x o x x x x x o o o o o o o)
+  (x x x x x x o o o o o o x x o o o o x x o o o o o)
+  (x x x x x x x o o o o x x o o o x x o x o o o o o)
+  (x x x o x x x x x x x x o x o o o x x x x x x o o)
+  (x x x o x x x x x x x o x x x o o o x o o o x o x)
+  (x x x o x x x x x x o x x o x x x x x o o x x x x)
+  (x x x x o x x x x o x x x o x x x x x x x x o x x)
+  (x x x x x x o x o x x x x o o x x x x x o o o o o)
+  (o x x x x o o o x x x x x o o o o o o o o o o o o)
+  (o o x x o o o o o x x x x o o o o o o o o o o o o)
+  (o o o o x o o o o x x x x o o o o o o o o o o o o)))
+
+("Hattori 115"
+ ((11 12 4)
+  (1 12 3)
+  (1 2 1 12 3)
+  (1 2 1 1 4 3 2 3)
+  (1 1 2 1 1 1 1 2)
+  (6 6 2 2 3 1)
+  (1 9 4)
+  (3 1 7 3 6)
+  (1 1 1 4 2 2 8)
+  (3 2 2 3 9)
+  (4 3 4 10 4)
+  (7 10 1 1)
+  (2 1 2 8 2 1)
+  (2 1 2 9 1 1)
+  (3 4 2 1 2 4)
+  (1 3 5 1 2)
+  (1 1 1 2 1 1 1 3)
+  (1 1 1 1 11 2)
+  (1 1 1 1 2 2 2 2)
+  (1 3 3 2 1 2 1 1)
+  (3 5 3 2 3 1 1)
+  (2 2 2 1 2 7 1)
+  (2 1 2 2 5 4)
+  (2 2 2 4 2 4)
+  (7 8 5))
+ ((1 4 2 8)
+  (1 1 2 2 3)
+  (1 9 4 2 2)
+  (1 2 1 1 3 5 2)
+  (1 1 3 1 1 2 1)
+  (1 2 3 1 2 1)
+  (1 2 2 1 5)
+  (1 3 5 1 2)
+  (1 1 1 1 2 2 1)
+  (1 1 2 2 5 2)
+  (4 4 1 2 1 2 2)
+  (4 1 3 3)
+  (4 1 3 3 1)
+  (2 3 1 4 2)
+  (3 3 4)
+  (12 6 3)
+  (4 7 4 2)
+  (4 1 5 1 2 1)
+  (6 1 4 1 2 1)
+  (3 2 4 1 1 1)
+  (6 2 4 3 1)
+  (4 1 5 7)
+  (4 6 1 5)
+  (3 8 1 2)
+  (12 2 1 2)
+  (2 5 4 4)
+  (1 6 3 2 4)
+  (4 7 1 1 5)
+  (5 4 1 3 2)
+  (6 7 6 1))
+ ((x x x x x x x x x x x o o x x x x x x x x x x x x o x x x x)
+  (o o o o o o o o o o x o o x x x x x x x x x x x x o o x x x)
+  (x o x x o o o o o o x o o o x x x x x x x x x x x x o x x x)
+  (x o x x o o x o o o x o o o o x x x x o x x x o x x o x x x)
+  (x o x o o x x o o o o o o o o x o o x o x o o o x o o o x x)
+  (x x x x x x o o o o x x x x x x o x x o x x o o x x x o o x)
+  (o o x o o o o x x x x x x x x x o o o o o o o o x x x x o o)
+  (o o x x x o o x o o x x x x x x x o x x x o o x x x x x x o)
+  (o o x o x o o x o x x x x o o x x o o x x o x x x x x x x x)
+  (x x x o x x o o x x o o o o o x x x o o o x x x x x x x x x)
+  (x x x x o x x x o o x x x x o x x x x x x x x x x o x x x x)
+  (o o o x x x x x x x o o o o o x x x x x x x x x x o o x o x)
+  (o o x x o o o x o x x o o o o o x x x x x x x x o o x x o x)
+  (o x x o o o o x o o x x o o o x x x x x x x x x o o x o o x)
+  (x x x o o x x x x o o x x o o x o o o o o o o x x o x x x x)
+  (x o x x x o o o x x x x x o o x o o o o o o o o x x o o o o)
+  (x o o x o o o o o x o o x x o x o o o o x o o o o x o x x x)
+  (x o o x o o o o o x o o o x o x x x x x x x x x x x o o x x)
+  (x o o x o o o o o x o o o x o x x o o o x x o o o x x o x x)
+  (x o x x x o o o x x x o x x o o x o o o o x x o o o x o o x)
+  (x x x o x x x x x o x x x o o o x x o o o x x x o o o x o x)
+  (x x o o o x x o o o o x x o x o o x x o o x x x x x x x o x)
+  (o x x o o o x o o o x x o o x x o o x x x x x o x x x x o o)
+  (o o x x o o x x o x x o o x x x x o o o o x x o o x x x x o)
+  (o o o x x x x x x x o o x x x x x x x x o o o o o x x x x x)))
+
+("Hattori 116"
+ ((3 2)
+  (7)
+  (9)
+  (9)
+  (6)
+  (2 3 2)
+  (4 2)
+  (12 1)
+  (15)
+  (5 11)
+  (3 11)
+  (3 13)
+  (2 13)
+  (2 14)
+  (16)
+  (15)
+  (9 5)
+  (8 4)
+  (7 4)
+  (11))
+ ((8)
+  (11)
+  (3 6)
+  (3 7)
+  (2 8)
+  (2 9)
+  (2 9)
+  (11 1)
+  (10 1)
+  (10 2)
+  (14)
+  (2 15)
+  (3 14)
+  (3 11)
+  (6 10)
+  (6 8)
+  (6 7)
+  (4 5)
+  (7)
+  (1 6))
+ ((o o o o o o o o o o o o o o x x x o x x)
+  (o o o o o o o o o o o o x x x x x x x o)
+  (o o o o o o o o o o o x x x x x x x x x)
+  (o o o o o o o o o o o x x x x x x x x x)
+  (o o o o o o o o o o o o o o x x x x x x)
+  (o o o o o o o o o o o x x o x x x o x x)
+  (o o o o o o o o o x x x x o o o o o x x)
+  (o o o o o o x x x x x x x x x x x x o x)
+  (o o o x x x x x x x x x x x x x x x o o)
+  (o x x x x x o x x x x x x x x x x x o o)
+  (o x x x o o o x x x x x x x x x x x o o)
+  (x x x o o x x x x x x x x x x x x x o o)
+  (x x o o x x x x x x x x x x x x x o o o)
+  (x x o x x x x x x x x x x x x x x o o o)
+  (x x x x x x x x x x x x x x x x o o o o)
+  (x x x x x x x x x x x x x x x o o o o o)
+  (x x x x x x x x x o x x x x x o o o o o)
+  (x x x x x x x x o o x x x x o o o o o o)
+  (x x x x x x x o o x x x x o o o o o o o)
+  (o x x x x x x x x x x x o o o o o o o o)))
+
+("Hattori 117"
+ ((15 3)
+  (15 4)
+  (2 3 1 3 2 4)
+  (2 1 5 1)
+  (15 2 3)
+  (3 3 2 2 1 2)
+  (3 3 1 1 3)
+  (14 3 1)
+  (15 1 2 2)
+  (5 6 1 1 1)
+  (18 1 3)
+  (5 5 2 5)
+  (7 7 7)
+  (7 7 6)
+  (15 5)
+  (15 4)
+  (15 5)
+  (15 8)
+  (15 1 2)
+  (3 1 2)
+  (3 1 2)
+  (3 8)
+  (3 2)
+  (3 4)
+  (7 4))
+ ((19)
+  (19)
+  (2 15)
+  (3 1 12)
+  (3 1 12 1)
+  (3 1 2 1 7 1)
+  (2 5 1 13)
+  (9 1 11)
+  (2 5 1 13)
+  (3 1 2 1 7 1)
+  (3 1 12 1)
+  (3 1 12)
+  (2 15)
+  (6 12)
+  (5 11)
+  (1 2)
+  (1 1)
+  (2 5 5)
+  (2 1 2 1 1)
+  (4 2 1 1)
+  (7 2 1)
+  (2 3 7 1 2)
+  (5 12 1 2)
+  (3 3 1 15)
+  (3 1 15))
+ ((x x x x x x x x x x x x x x x o o o o o o o x x x)
+  (x x x x x x x x x x x x x x x o o o o o o x x x x)
+  (x x o x x x o x o x x x o x x o o o o o o x x x x)
+  (x x o o o o o x o o o o o x x x x x o o o o x o o)
+  (x x x x x x x x x x x x x x x o o x x o o x x x o)
+  (x x x o o o x x x o o o x x o o o o x x o x o x x)
+  (x x x o o o x x x o o o x o o o o o o x o x x x o)
+  (x x x x x x x x x x x x x x o o o x x x o o x o o)
+  (x x x x x x x x x x x x x x x o o x o x x o x x o)
+  (x x x x x o o o o o x x x x x x o x o o x o x o o)
+  (x x x x x x x x x x x x x x x x x x o o x o x x x)
+  (x x x x x o o o o o x x x x x o o x x o x x x x x)
+  (x x x x x x x o x x x x x x x o o o x x x x x x x)
+  (x x x x x x x o x x x x x x x o o o o x x x x x x)
+  (x x x x x x x x x x x x x x x o o o o o x x x x x)
+  (x x x x x x x x x x x x x x x o o o o o o x x x x)
+  (x x x x x x x x x x x x x x x o o o o o x x x x x)
+  (x x x x x x x x x x x x x x x o o x x x x x x x x)
+  (x x x x x x x x x x x x x x x o o x o o o o o x x)
+  (o o o o o o x x x o o o o o o o o x o o o o o x x)
+  (o o o o o o x x x o o o o o o o o x o o o o o x x)
+  (o o o o o o x x x o o o o o o o o x x x x x x x x)
+  (o o o o o o x x x o o o o o o o o o o o o o o x x)
+  (o o o o o o x x x o o o o o o o o o o o o x x x x)
+  (o o o o x x x x x x x o o o o o o o o o o x x x x)))
+
+("Hattori 118"
+ ((11)
+  (12)
+  (7 1)
+  (6 2 2)
+  (6 2 1)
+  (4 1)
+  (5 2 2)
+  (8 1 3)
+  (11 1)
+  (8 5 3)
+  (7 9)
+  (6 5 2)
+  (6 4 1)
+  (6 1 1)
+  (6 4 2)
+  (6 4 1 1)
+  (6 4 2 2)
+  (6 4 2 2)
+  (5 4 2 1)
+  (3 11))
+ ((10)
+  (12)
+  (13)
+  (14)
+  (14)
+  (14)
+  (5)
+  (3 2 6)
+  (5 2 3 6)
+  (7 1 3 6)
+  (20)
+  (6 3 1)
+  (5 2 2 1)
+  (5 2 2 1)
+  (3 2 3)
+  (2 2 2 2)
+  (2 2 1 6 1)
+  (2 1 1 3 1)
+  (4 4 2)
+  (2 4 2))
+ ((o o o o o o o o o x x x x x x x x x x x)
+  (o o o o o o o o x x x x x x x x x x x x)
+  (o o o o o o o o x x x x x x x o o o x o)
+  (o o o o o o o o x x x x x x o x x o x x)
+  (o o o o o o o o x x x x x x o x x o o x)
+  (o o o o o o o o x x x x o o o o o o o x)
+  (o o x x x x x o o x x o o o o o o o x x)
+  (o x x x x x x x x o x o o o o o x x x o)
+  (x x x x x x x x x x x o o o o o o o x o)
+  (x x x x x x x x o o x x x x x o x x x o)
+  (x x x x x x x o x x x x x x x x x o o o)
+  (x x x x x x o x x x x x o o o x x o o o)
+  (x x x x x x o x x x x o o o o o x o o o)
+  (x x x x x x o o o o x o o o o o x o o o)
+  (x x x x x x o x x x x o o o o o x x o o)
+  (x x x x x x o x x x x o x o o o o x o o)
+  (x x x x x x o x x x x o x x o o o x x o)
+  (x x x x x x o x x x x o o x x o o o x x)
+  (o x x x x x o x x x x o o o x x o o o x)
+  (o o o x x x o x x x x x x x x x x x o o)))
+
+("Hattori 119"
+ ((12)
+  (1 11)
+  (3 3 3)
+  (1 1 1 1)
+  (1 1 1)
+  (3 1 3 1 3 3)
+  (3 1 1 5 2 1)
+  (2 13 5)
+  (7 5 3 4)
+  (11 3 5)
+  (3 2 2 3 7)
+  (5 3 9)
+  (8 1 1 4)
+  (4 5 5 3)
+  (3 3 2 1 2)
+  (3 2 1 2)
+  (4 3 2 2)
+  (5 4)
+  (9 1 2 3)
+  (2 7 12)
+  (1 6 6 5)
+  (2 2 3 5 1)
+  (3 2 2 2 2 2)
+  (7 2 6 2)
+  (8 3 7)
+  (4 7 9)
+  (3 3 2 4 5)
+  (2 2 1 3 5)
+  (2 3 2 3 4)
+  (8 4 1))
+ ((3 6 6)
+  (1 1 7 9)
+  (3 2 3 1 2 7)
+  (2 2 4 1 3 2)
+  (6 3 7 2 1)
+  (3 14 3 1)
+  (4 1 7 9 2)
+  (2 1 1 1 2 5 6)
+  (4 1 7 4 5)
+  (3 8 3 2 1)
+  (6 3 3 4 2 2)
+  (2 2 5 10)
+  (1 3 2 4 6)
+  (3 3 1 3 1)
+  (7 2 5)
+  (5 2 6)
+  (3 1 2 2 7)
+  (7 9)
+  (3 1 10)
+  (7 1 1 1 3)
+  (5 1 11)
+  (7 13)
+  (9 2 3 4)
+  (1 1 6 2 2 3)
+  (3 4 5 4))
+ ((x x x x x x x x x x x x o o o o o o o o o o o o o)
+  (x o x x x x x x x x x x x o o o o o o o o o o o o)
+  (x x x o x x x o x x x o o o o o o o o o o o o o o)
+  (o o o o x o x o x o x o o o o o o o o o o o o o o)
+  (o x o o x o o o o o x o o o o o o o o o o o o o o)
+  (x x x o x o x x x o x o o x x x o o o o o o x x x)
+  (x x x o o x o o o x o o x x x x x o o o o x x o x)
+  (x x o o x x x x x x x x x x x x x o o o x x x x x)
+  (x x x x x x x o x x x x x o x x x o o x x x x o o)
+  (x x x x x x x x x x x o o x x x o o x x x x x o o)
+  (x x x o o x x o x x o o x x x o o x x x x x x x o)
+  (o o o o o x x x x x o o x x x o x x x x x x x x x)
+  (o o o o x x x x x x x x o o o o o x o x o x x x x)
+  (o o o x x x x o x x x x x o o o x x x x x o x x x)
+  (o o o x x x o o o o x x x o o o x x o x o o o x x)
+  (o o o x x x o o o o o x x o o o o x o o o o x x o)
+  (o o x x x x o o o o o x x x o o o x x o o x x o o)
+  (o o o o x x x x x o o o o o o o o o x x x x o o o)
+  (o o x x x x x x x x x o o x o o o x x o x x x o o)
+  (o x x o o x x x x x x x o x x x x x x x x x x x x)
+  (o x o o o o x x x x x x o x x x x x x o x x x x x)
+  (x x o o o o x x o o x x x o o o o x x x x x o o x)
+  (x x x o o x x o o o o x x o o o o x x o x x o x x)
+  (x x x x x x x o o o o x x o o o x x x x x x o x x)
+  (x x x x x x x x o o x x x o o x x x x x x x o o o)
+  (x x x x o o x x x x x x x o x x x x x x x x x o o)
+  (x x x o o o o x x x o x x o x x x x o o x x x x x)
+  (o x x o o o o x x o o x o o x x x o o o x x x x x)
+  (o o x x o o x x x o x x o o x x x o o o o x x x x)
+  (o o o x x x x x x x x o o x x x x o o o o o o o x)))
+
+("Hattori 120"
+ ((2)
+  (2 2 3)
+  (3 2 4 3 3)
+  (3 2 6 6)
+  (3 4 4 4 1)
+  (9 5 1)
+  (17 1)
+  (17 1)
+  (16 2)
+  (18)
+  (16)
+  (13)
+  (11)
+  (9)
+  (8)
+  (2 3)
+  (3 2 2)
+  (1 3 1)
+  (1 2 2)
+  (1 3 3)
+  (2 14)
+  (15)
+  (12)
+  (10)
+  (8))
+ ((5)
+  (1 2)
+  (1 2 1)
+  (2 5)
+  (4 7)
+  (5 2 5)
+  (5 2 5)
+  (5 1 5)
+  (7 1 5)
+  (9 1 5)
+  (11 1 5)
+  (2 11 5)
+  (1 1 10 5)
+  (3 10 5)
+  (5 8 1 5)
+  (5 8 2 5)
+  (3 8 5)
+  (1 1 9)
+  (2 9)
+  (13)
+  (11)
+  (9)
+  (3 2)
+  (2 3)
+  (8))
+ ((o o o o o o o o o o o o o o x x o o o o o o o o o)
+  (o o o o o o o o o o o x x o x x o x x x o o o o o)
+  (o o x x x o o o o o x x o x x x x o x x x o x x x)
+  (o o o x x x o o o x x o x x x x x x o x x x x x x)
+  (o o o o x x x o x x x x o x x x x o o x x x x o x)
+  (o o o o x x x x x x x x x o o o o x x x x x o o x)
+  (o o o o o x x x x x x x x x x x x x x x x x o o x)
+  (o o o o o x x x x x x x x x x x x x x x x x o o x)
+  (o o o o o o x x x x x x x x x x x x x x x x o x x)
+  (o o o o o o o x x x x x x x x x x x x x x x x x x)
+  (o o o o o o o o x x x x x x x x x x x x x x x x o)
+  (o o o o o o o o o x x x x x x x x x x x x x o o o)
+  (o o o o o o o o o o x x x x x x x x x x x o o o o)
+  (o o o o o o o o o o o x x x x x x x x x o o o o o)
+  (o o o o o o x x x x x x x x o o o o o o o o o o o)
+  (o o o o o x x o o o o o o x x x o o o o o o o o o)
+  (x x x o x x o o o o o o o o o x x o o o o o o o o)
+  (x o x x x o o o o o o o o o o o x o o o o o o o o)
+  (x o o x x o o o o o o o o o o x x o o o o o o o o)
+  (x o o x x x o o o o o o o o x x x o o o o o o o o)
+  (x x o x x x x x x x x x x x x x x o o o o o o o o)
+  (o x x x x x x x x x x x x x x x o o o o o o o o o)
+  (o o o o x x x x x x x x x x x x o o o o o o o o o)
+  (o o o o o x x x x x x x x x x o o o o o o o o o o)
+  (o o o o o o x x x x x x x x o o o o o o o o o o o)))
+
+("Hattori 121"
+ ((2)
+  (3)
+  (4)
+  (5)
+  (2 2)
+  (2 2)
+  (3)
+  (8 3)
+  (2 1 2 4)
+  (3 1 2 1)
+  (5 2 2 1)
+  (1 4 2 1)
+  (1 1 5)
+  (3 3 5)
+  (5 7)
+  (6 6)
+  (7 7)
+  (17)
+  (15)
+  (13))
+ ((3)
+  (5)
+  (6)
+  (2 7)
+  (4 7)
+  (1 11)
+  (3 1 1 4)
+  (7 1 3)
+  (4 3 2 3)
+  (8 1 3)
+  (4 1 1 4)
+  (2 10)
+  (3 7)
+  (7)
+  (6)
+  (7)
+  (10)
+  (8)
+  (2 2)
+  (7))
+ ((o o o o o o o o x x o o o o o o o o o o)
+  (o o o o o o o x x x o o o o o o o o o o)
+  (o o o o o o o x x x x o o o o o o o o o)
+  (o o o o o o x x x x x o o o o o o o o o)
+  (o o o o o o x x o x x o o o o o o o o o)
+  (o o o o o o x x o x x o o o o o o o o o)
+  (o o o o o o o x x x o o o o o o o o o o)
+  (o o o o x x x x x x x x o o o o o x x x)
+  (o o o x x o o o x o o x x o o o x x x x)
+  (o o o x x x o o o o o o x o o o x x o x)
+  (o o o o x x x x x o o x x o o o x x o x)
+  (o o o o o x o o x x x x o o o o x x o x)
+  (o o o o o x o o o o o x o o o x x x x x)
+  (o o o x x x o o o o o x x x o x x x x x)
+  (o x x x x x o o o o o x x x x x x x o o)
+  (x x x x x x o o o o o x x x x x x o o o)
+  (x x x x x x x o o o x x x x x x x o o o)
+  (x x x x x x x x x x x x x x x x x o o o)
+  (o x x x x x x x x x x x x x x x o o o o)
+  (o o x x x x x x x x x x x x x o o o o o)))
+
+("Hattori 122"
+ ((2 2 5)
+  (2 2 7)
+  (9 6 4)
+  (1 1 1 1 8 1)
+  (7 9 2)
+  (7 10 3)
+  (9 2 3 2)
+  (12 1 2 2 2 3)
+  (3 3 1 1 1 1 2)
+  (2 2 1 1 2)
+  (2 2 2 3 2 2)
+  (2 2 1 3 2 2)
+  (12 7 3)
+  (1 2 2)
+  (5 6)
+  (2 1 1 1 4)
+  (2 1 1 2 3 2)
+  (1 1 3 4 2)
+  (1 1 1 1 1 1)
+  (1 1 1 1 1 1)
+  (5 1 4 2)
+  (5 1 1 1 3 4)
+  (1 4 1 13)
+  (1 2 4 3 3)
+  (1 3 5 3)
+  (1 1 1 6 2)
+  (2 3 6 4)
+  (2 8 5)
+  (3 22)
+  (1 12 8)
+  (15 8)
+  (11 7)
+  (9 6)
+  (12 6)
+  (3 18 2)
+  (2 18 3)
+  (2 2 12 3 1)
+  (1 2 7 1)
+  (2 2 2 2)
+  (10 8))
+ ((1 1 6)
+  (2 7 1 2 3)
+  (13 1 2 2 2)
+  (1 1 5 1 2 3 2 2 1)
+  (6 1 2 1 1 1 1 1 1)
+  (1 4 1 1 3 1 2 1)
+  (6 1 2 1 1 1)
+  (1 1 5 1 3 5 1 1)
+  (13 14 1)
+  (2 7 12 3)
+  (1 1 5 13 2)
+  (1 1 2 17 1)
+  (2 1 1 12)
+  (6 1 1 2 11)
+  (3 3 9 11)
+  (3 2 1 1 1 11)
+  (4 1 8 1 4 5)
+  (4 3 6 4 4)
+  (4 1 3 2 2 3 4)
+  (4 2 5 3 1 4)
+  (5 4 7 1 5)
+  (7 2 1 2 3 1 4 2)
+  (2 8 4 1 1 9 1)
+  (2 11 8 1)
+  (3 5 2 8 1)
+  (3 4 2 3 10 1)
+  (3 4 2 2 2 8 1 1)
+  (2 4 4 10 2 1)
+  (4 8 2 2)
+  (3 5 5))
+ ((o o x x o o o x x o o o o o o o o o o o o o x x x x x o o o)
+  (o x x o o o o o x x o o o o o o o o o o o x x x x x x x o o)
+  (o x x x x x x x x x o o o o o o x x x x x x o o x x x x o o)
+  (o o x o x o x o x o o o o o o x x x x x x x x o o o o o o x)
+  (o o x x x x x x x o o o o o x x x x x x x x x o o o o o x x)
+  (o o x x x x x x x o o o o x x x x x x x x x x o o o o x x x)
+  (o x x x x x x x x x o o o x x o o o o o x x x o o o o x x o)
+  (x x x x x x x x x x x x o x o x x o x x o x x o o o x x x o)
+  (o x x x o o o x x x o o o x o x o o o x o o x o o o x x o o)
+  (o x x o o o o o x x o o o x o o o o o o o o x o o x x o o o)
+  (o x x o o o o o x x o o o x x o x x x o o x x o o x x o o o)
+  (o x x o o o o o x x o o o o x o x x x o x x o o x x o o o o)
+  (x x x x x x x x x x x x o o x x x x x x x o o x x x o o o o)
+  (o o o o o o o o o o o o o o o o x o o x x o o x x o o o o o)
+  (o o o o o o o o o o o o x x x x x o o x x x x x x o o o o o)
+  (o o o o o o o o o o o x x o x o x o o x o o x x x x o o o o)
+  (o o o o o o o o o o x x o o x o x o x x o x x x o x x o o o)
+  (o o o o o o o o o o x o o o x o x x x o x x x x o o x x o o)
+  (o o o o o o o o o o x o o o x o o x o o x o o x o o o x o o)
+  (o o o o o o o o o o x o o o x o o x o o x o o x o o o x o o)
+  (o o o o o o o o o o x x x x x o o x o o x x x x o o x x o o)
+  (x x x x x o o o o o o x o o x o o x o x x x o x x x x o o o)
+  (x o o x x x x o o o o x o x x x x x x x x x x x x x o o o o)
+  (x o o o o o x x o o x x x x o o o o x x x o o o o x x x o o)
+  (x o o x x x o x x x x x o o o o o o o o o o o o o o x x x o)
+  (x o o x o x o x x x x x x o o o o o o o o o o o o o o x x o)
+  (x x o x x x o o x x x x x x o o o o o o o o o o o o x x x x)
+  (o x x o o o o o x x x x x x x x o o o o o o o o o x x x x x)
+  (o o x x x o o o x x x x x x x x x x x x x x x x x x x x x x)
+  (o o o x o o o x x x x x x x x x x x x o o o x x x x x x x x)
+  (o o o o x x x x x x x x x x x x x x x o o o x x x x x x x x)
+  (o o o o o o o x x x x x x x x x x x o o o o x x x x x x x o)
+  (o o o o o o o x x x x x x x x x o o o o o o x x x x x x o o)
+  (o o o o o x x x x x x x x x x x x o o o o x x x x x x o o o)
+  (o o o x x x o o x x x x x x x x x x x x x x x x x x o o x x)
+  (o o x x o o o o x x x x x x x x x x x x x x x x x x o x x x)
+  (o x x o o o o x x o o x x x x x x x x x x x x o o x x x o x)
+  (o x o o o o o o x x o o o o x x x x x x x o o o o o o o o x)
+  (o x x o o o o o o x x o o o o o o o o o x x o o o o o o x x)
+  (o o x x x x x x x x x x o o o o o o o o o x x x x x x x x o)))
+
+("Hattori 123"
+ ((4 8)
+  (5 1 9)
+  (3 1 1 10)
+  (3 1 1 3 8)
+  (3 1 2 2 1 7)
+  (1 1 2 1 1 1 2 5)
+  (1 2 1 1 1 2 1 2)
+  (1 1 2 1 2 1)
+  (2 1 1 1 2)
+  (2 2 1 2 1)
+  (2 1 2 1 2)
+  (2 1 1 1 1)
+  (2 2 1 2 2)
+  (2 2 1 1 1)
+  (1 1 1 1 1)
+  (2 3 2 2)
+  (2 2 1 2)
+  (2 2 2 2)
+  (2 2 2 1)
+  (2 2 1 2)
+  (2 2 5)
+  (8 6)
+  (6 7)
+  (6 7)
+  (12 6))
+ ((6)
+  (1 4 1)
+  (4 3 2)
+  (1 2 2 2)
+  (4 3 2)
+  (1 2 3 2)
+  (4 4 2)
+  (1 2 4 2)
+  (1 3 1)
+  (4 2 1)
+  (2 3 2 1)
+  (1 2 1)
+  (1 5 2 1)
+  (4 3 4 3)
+  (5 7)
+  (2 10)
+  (2 5)
+  (4 2 4 2)
+  (6 4 3 3)
+  (5 3 2 4)
+  (8 7)
+  (6 4 5)
+  (6 3 2 5)
+  (7 3 2 5)
+  (9 6))
+ ((o o o o o o o o o o x x x x o o o x x x x x x x x)
+  (o o o o o o x x x x x o o x o o x x x x x x x x x)
+  (o o o o x x x o o x o o o x o x x x x x x x x x x)
+  (o o x x x o x o o x o o o x x x o x x x x x x x x)
+  (x x x o x o x x o x x o o o x o o o x x x x x x x)
+  (x o x o x x o x o o x o o o x o o x x o x x x x x)
+  (x o x x o x o o o o x o o o x o x x o o x o o x x)
+  (x o o x o o o o o o o o o x x o x o o x x o o o x)
+  (x x o o o o o o o o o o o x o o x o o x o o o x x)
+  (x x o o o o o o o o o o x x o o x o x x o o o x o)
+  (o x x o o o o o o o o o x o o x x o x o o o x x o)
+  (o x x o o o o o o o o o x o o x o o x o o o x o o)
+  (o o x x o o o o o o o o x x o x o x x o o x x o o)
+  (o o o x x o o o o o o o x x o x o x o o o x o o o)
+  (o o o o x o o o o o o o o x o x o x o o o x o o o)
+  (o o o o x x o o o o o o o x x x o x x o o x x o o)
+  (o o o o o x x o o o o o o o x x o o x o o o x x o)
+  (o o o o o x x o o o o o o o x x o o x x o o o x x)
+  (o o o o o o x x o o o o o o x x o o o x x o o o x)
+  (o o o o o o x x o o o o o o x x o o o o x o o x x)
+  (o o o o o o o x x o o o o x x o o o o o x x x x x)
+  (o o o o o o o x x x x x x x x o o o o x x x x x x)
+  (o o o o o o o o x x x x x x o o o o x x x x x x x)
+  (o o x x x x x x o o o o o o o o o x x x x x x x o)
+  (o x x x x x x x x x x x x o o o o x x x x x x o o)))
+
+("Hattori 124"
+ ((8)
+  (12)
+  (14)
+  (3 5)
+  (1 3)
+  (1 1 1 2)
+  (9)
+  (2 5 2)
+  (2 2 2 2)
+  (2 1 3 1 2)
+  (1 1 3 1 1)
+  (2 1 3 1 2)
+  (2 2 2 2)
+  (2 5 2)
+  (9))
+ ((2 3)
+  (2 2 2)
+  (3 2 2)
+  (2 2 2)
+  (3 1 5 1)
+  (3 4 3)
+  (3 2 3 2)
+  (3 3 3 2)
+  (3 2 3 2)
+  (3 4 3)
+  (4 1 5 1)
+  (4 2 2)
+  (4 2 2)
+  (5 2 2)
+  (4 3))
+ ((o o o o x x x x x x x x o o o)
+  (o o x x x x x x x x x x x x o)
+  (o x x x x x x x x x x x x x x)
+  (x x x o o o o o o o x x x x x)
+  (x o o o o o o o o o o o x x x)
+  (o o o o o x o x o x o o o x x)
+  (o o o x x x x x x x x x o o o)
+  (o o x x o x x x x x o x x o o)
+  (o x x o x x o o o x x o x x o)
+  (x x o o x o x x x o x o o x x)
+  (x o o o x o x x x o x o o o x)
+  (x x o o x o x x x o x o o x x)
+  (o x x o x x o o o x x o x x o)
+  (o o x x o x x x x x o x x o o)
+  (o o o x x x x x x x x x o o o)))
+
+("Hattori 125"
+ ((11)
+  (11)
+  (2 7)
+  (6 5)
+  (8 3)
+  (3 5 2)
+  (4 4 3 1)
+  (3 3 5 1)
+  (1 3 2 3 1)
+  (3 2 3 1)
+  (4 2 2 1)
+  (2 2 1 4 1)
+  (2 2 3 1)
+  (4 1 2)
+  (3 2 2 2)
+  (3 1)
+  (2)
+  (2 2)
+  (3 2)
+  (2 4))
+ ((3 2 6)
+  (3 2 6)
+  (2 3 2 2)
+  (2 2 4)
+  (3 2 2)
+  (5)
+  (7)
+  (11)
+  (12)
+  (9 1)
+  (6 3)
+  (1 1 1 2)
+  (2 2 2 2)
+  (1 2 1 1 1)
+  (1 2 2 2 1)
+  (1 4 4 2)
+  (2 6 2)
+  (1 3 2)
+  (2 4)
+  (10))
+ ((x x x x x x x x x x x o o o o o o o o o)
+  (x x x x x x x x x x x o o o o o o o o o)
+  (x x o o x x x x x x x o o o o o o o o o)
+  (o o o o o x x x x x x o x x x x x o o o)
+  (o o o o o x x x x x x x x o o o x x x o)
+  (x x x o o o x x x x x o o o o o o o x x)
+  (x x x x o o x x x x o o o x x x o o o x)
+  (o o x x x o o x x x o o x x x x x o o x)
+  (o o o o x o o x x x o x x o o x x x o x)
+  (x x x o o o o x x o o o o o o x x x o x)
+  (x x x x o o o x x o o o o o o o x x o x)
+  (x x o x x o o o x o o o o x x x x o o x)
+  (x x o x x o o o o o o o o o x x x o o x)
+  (x x x x o o o o o o o o o o o x o o x x)
+  (x x x o o o o o o o o x x o x x o o x x)
+  (o o o o o o o o o o o o x x x o o o x o)
+  (o o o o o o o o o o o o o o o o o x x o)
+  (o o o o o o o o o o x x o o o o x x o o)
+  (o o o o o o o o o o x x x o o x x o o o)
+  (o o o o o o o o o x x o x x x x o o o o)))
+
+("Hattori 126"
+ ((2 2)
+  (4 4)
+  (12)
+  (13)
+  (3 1 1 1 3)
+  (2 1 1 1 2)
+  (1 7 1)
+  (1 1)
+  (2 2)
+  (2 2)
+  (3 3)
+  (3 3)
+  (9)
+  (7)
+  (5))
+ ((5)
+  (3 3)
+  (3 3)
+  (3 3)
+  (7 3)
+  (4 1 3)
+  (3 1 3)
+  (5 3)
+  (2 1 3)
+  (3 1 3)
+  (7 3)
+  (4 3)
+  (4 3)
+  (4 3)
+  (5))
+ ((o o o o x x o o o o x x o o o)
+  (o o o x x x x o o x x x x o o)
+  (o o x x x x x x x x x x x x o)
+  (o x x x x x x x x x x x x x o)
+  (x x x o x o o x o o x o x x x)
+  (x x o o x o o x o o x o o x x)
+  (x o o o x x x x x x x o o o x)
+  (x o o o o o o o o o o o o o x)
+  (x x o o o o o o o o o o o x x)
+  (o x x o o o o o o o o o x x o)
+  (o x x x o o o o o o o x x x o)
+  (o o x x x o o o o o x x x o o)
+  (o o o x x x x x x x x x o o o)
+  (o o o o x x x x x x x o o o o)
+  (o o o o o x x x x x o o o o o)))
+
+("Hattori 127"
+ ((4)
+  (5)
+  (5 6)
+  (6 6)
+  (15)
+  (7 3 2)
+  (7 2 3 2)
+  (3 3 4 2)
+  (2 13 1)
+  (1 5 7 1)
+  (1 5 4 1)
+  (1 3 2 1)
+  (1 1)
+  (1 1 1 1)
+  (1 1 1 2)
+  (2 1 1 2)
+  (2 2 2 2)
+  (6 2 2)
+  (16)
+  (14))
+ ((9)
+  (1 3 3)
+  (3 2 3)
+  (5 2 3)
+  (5 4 7)
+  (10 4)
+  (8 3)
+  (8 2)
+  (2 2 2)
+  (4 1 2)
+  (3 1 2 2)
+  (4 2 2)
+  (10 2)
+  (11 3)
+  (11 4)
+  (3 1 5 4 2)
+  (2 4 2)
+  (2 3)
+  (2 4)
+  (9))
+ ((o o o o o o o o o o o o x x x x o o o o)
+  (o o o o o o o o o o o x x x x x o o o o)
+  (o x x x x x o o o o x x x x x x o o o o)
+  (o o x x x x x x o x x x x x x o o o o o)
+  (o o x x x x x x x x x x x x x x x o o o)
+  (o o o x x x x x x x o o x x x o x x o o)
+  (o x x x x x x x o x x o x x x o o x x o)
+  (x x x o o x x x o o o o x x x x o o x x)
+  (x x o o x x x x x x x x x x x x x o o x)
+  (x o o o x x x x x o x x x x x x x o o x)
+  (x o o x x x x x o o o o o x x x x o o x)
+  (x o o x x x o o o o o o o o o x x o o x)
+  (x o o o o o o o o o o o o o o o o o o x)
+  (x o o o x o o o o o o o o o o x o o o x)
+  (x o o o x o o o o o o o o o o x o o x x)
+  (x x o o x o o o o o o o o o o x o o x x)
+  (o x x o x x o o o o o o o o x x o x x o)
+  (o x x x x x x o o o o o o x x o o x x o)
+  (o o x x x x x x x x x x x x x x x x o o)
+  (o o o x x x x x x x x x x x x x x o o o)))
+
+("Hattori 128"
+ ((14 1)
+  (4 8 1)
+  (3 8 3)
+  (3 1 1 7 1 1)
+  (4 1 1 1 6 2 1)
+  (4 3 1 6 1 1)
+  (4 5 2 1)
+  (4 4 5 1 1)
+  (5 1 1 3 3)
+  (4 4 1)
+  (2 2)
+  (5 7 1)
+  (7 5 6)
+  (4 3 3 3)
+  (4 2 4)
+  (7 4 1)
+  (4 4 3 6 1)
+  (4 2 6 3 2)
+  (7 5 1 3)
+  (2 2 1 1)
+  (2 4 2)
+  (1 1 2)
+  (2 7)
+  (3 8)
+  (14))
+ ((4)
+  (6)
+  (6 8)
+  (9 6 3)
+  (10 4 1 2)
+  (3 6 3 1 1 2)
+  (2 5 2 2 2)
+  (1 3 3 1 2 1)
+  (1 1 2 1 1 1)
+  (1 3 3 2 2 1 1)
+  (1 1 1 2 4 1)
+  (3 2 1 1 1 1 2)
+  (4 3 2 3 3)
+  (6 2 3 4)
+  (8 3 3 3)
+  (9 3 1 3)
+  (10 3 2 3)
+  (9 1 1 2 4)
+  (7 1 4 5)
+  (2 7)
+  (1 3)
+  (5 1 5)
+  (1 1 1 1 3 1)
+  (4 1 2 3 2)
+  (1 1 1 1 7))
+ ((o o o o x x x x x x x x x x x x x x o o o o o x o)
+  (o o o x x x x o o o o x x x x x x x x o o o o x o)
+  (o o o x x x o o o o o x x x x x x x x o o o x x x)
+  (o o x x x o o x o x o o x x x x x x x o o x o x o)
+  (o o x x x x o x o x o x o x x x x x x o o x x o x)
+  (o o x x x x o x x x o x o x x x x x x o o x o x o)
+  (o o x x x x o o o o o o o o x x x x x o o x x o x)
+  (o o x x x x o o o x x x x o x x x x x o o x o x o)
+  (o o x x x x x o o x o o x o o x x x o o o o x x x)
+  (o o o x x x x o o x x x x o o o x o o o o o o o o)
+  (o o o o o o x x o o o o o o x x o o o o o o o o o)
+  (o o o o o x x x x x o o o x x x x x x x o o o o x)
+  (o o o o x x x x x x x o x x x x x o o x x x x x x)
+  (o o x x x x o o o o x x x o o o x x x o o o x x x)
+  (o x x x x o o o o o o o o o o o o o x x o x x x x)
+  (x x x x x x x o o o o o o o o o o o x x x x o o x)
+  (x x x x o o x x x x o o x x x o x x x x x x o o x)
+  (x x x x o o o o o x x o x x x x x x o x x x o x x)
+  (x x x x x x x o o o x x x x x o o o o x o x x x o)
+  (o x x o o o x x o o x o o o o o o o o x o o o o o)
+  (o o x x o o o x x x x o o o o o o o x x o o o o o)
+  (o o o x o o o o o o o o o x o o o x x o o o o o o)
+  (o o o x x o o o o o o o x x x x x x x o o o o o o)
+  (o o o o x x x o o o o x x x x x x x x o o o o o o)
+  (o o o o o x x x x x x x x x x x x x x o o o o o o)))
+
+("Hattori 129"
+ ((3)
+  (5)
+  (5)
+  (6)
+  (5 6)
+  (7 6)
+  (4 3 6)
+  (4 2 8)
+  (4 2 10)
+  (4 1 5 5)
+  (4 2 7 4)
+  (6 2 8 2)
+  (3 1 12)
+  (1 1 2 1 11 1)
+  (1 1 2 11 1)
+  (1 2 3 14)
+  (1 6 14)
+  (1 3 17)
+  (1 5 17)
+  (8 5 3)
+  (1 5 1 1 1)
+  (1 6 1 1 1)
+  (11 1 1)
+  (1 1 4 1 1 1)
+  (4 3))
+ ((5 11)
+  (6 1 1)
+  (15 1)
+  (9 9)
+  (3 3 7)
+  (2 1 2 1 6)
+  (3 1 1 1 1 6)
+  (7 2 5)
+  (3 1 2 3)
+  (2 1 2 1)
+  (1 1 8)
+  (9 1)
+  (13)
+  (10 1)
+  (12)
+  (13)
+  (14)
+  (16)
+  (18)
+  (9 9)
+  (10 8)
+  (6 4 2 4)
+  (4 6 5 1)
+  (4 1 10)
+  (2 6 1))
+ ((o o o o o o o o o o o o o o o o o o o x x x o o o)
+  (o o o o o o o o o o o o o o o o o o x x x x x o o)
+  (o o o o o o o o o o o o o o o o o o x x x x x o o)
+  (o o o o o o o o o o o o o o o o o x x x x x x o o)
+  (o o o x x x x x o o o o o o o o o x x x x x x o o)
+  (o o x x x x x x x o o o o o o o x x x x x x o o o)
+  (o x x x x o x x x o o o o o o x x x x x x o o o o)
+  (x x x x o o o x x o o o o o o x x x x x x x x o o)
+  (x x x x o o x x o o o o o o x x x x x x x x x x o)
+  (x x x x o o o x o o o o o o x x x x x o x x x x x)
+  (x x x x o o x x o o o o o x x x x x x x o x x x x)
+  (x x x x x x o o o o x x o x x x x x x x x o x x o)
+  (o o x x x o o o o x o x x x x x x x x x x x x o o)
+  (x o x o x x o o o x o x x x x x x x x x x x o x o)
+  (x o x o o x x o o o x x x x x x x x x x x o o o x)
+  (x o x x o o o x x x o x x x x x x x x x x x x x x)
+  (x o x x x x x x o o o x x x x x x x x x x x x x x)
+  (x o x x x o o o x x x x x x x x x x x x x x x x x)
+  (x o x x x x x o x x x x x x x x x x x x x x x x x)
+  (x x x x x x x x o o x x x x x o o o o o o o x x x)
+  (x o o x x x x x o o x o x o o o o o o o o o o x o)
+  (x o o x x x x x x o x o x o o o o o o o o o o x o)
+  (x x x x x x x x x x x o x o o o o o o o o o o x o)
+  (x o o x o x x x x o x o x o o o o o o o o o o x o)
+  (o o o o o o o o o o x x x x o o o o o o o o x x x)))
+
+("Hattori 130"
+ ((3)
+  (5 8)
+  (6 9)
+  (7 9)
+  (7 5 3)
+  (7 4 3)
+  (5 3 2)
+  (3 2 2)
+  (2 1 1 1)
+  (2 1 1)
+  (1 1)
+  (3 5 1)
+  (1 5 1)
+  (3 5 1)
+  (7 1)
+  (7 3 1)
+  (6 4 1)
+  (6 4 1 1)
+  (13 6)
+  (5 6))
+ ((6 1 4)
+  (6 2 1 4)
+  (7 2 3 4)
+  (6 1 4)
+  (11 4)
+  (6 4)
+  (5 2 1)
+  (1 1 1)
+  (2 4 2)
+  (3 4 4)
+  (4 9)
+  (5 9)
+  (6 9)
+  (7)
+  (8 2)
+  (2 3)
+  (3 2)
+  (3 2)
+  (4 2)
+  (15))
+ ((x x x o o o o o o o o o o o o o o o o o)
+  (x x x x x o o x x x x x x x x o o o o o)
+  (x x x x x x o o x x x x x x x x x o o o)
+  (x x x x x x x o o x x x x x x x x x o o)
+  (x x x x x x x o o o x x x x x o x x x o)
+  (x x x x x x x o o o o x x x x o o x x x)
+  (o o x x x x x o o o o o x x x o o o x x)
+  (o o o o x x x o o o o o o x x o o o x x)
+  (o x x o x o o o o o o o o o x o o o o x)
+  (o x x o x o o o o o o o o o o o o o o x)
+  (o o o o x o o o o o o o o o o o o o o x)
+  (o o x x x o o o x x x x x o o o o o o x)
+  (o o x o o o o o x x x x x o o o o o o x)
+  (x x x o o o o o x x x x x o o o o o o x)
+  (o o o o o o x x x x x x x o o o o o o x)
+  (x x x x x x x o o o x x x o o o o o o x)
+  (x x x x x x o o o x x x x o o o o o o x)
+  (x x x x x x o o o x x x x o o x o o o x)
+  (x x x x x x x x x x x x x o x x x x x x)
+  (o o o o o o o o x x x x x o x x x x x x)))
+
+("Hattori 131"
+ ((4)
+  (2 3)
+  (1 4)
+  (1 4 4)
+  (6 6)
+  (4 7)
+  (7)
+  (7)
+  (4 6)
+  (6 1 1)
+  (2 5 3)
+  (1 6 1 1)
+  (1 6 2 1)
+  (8 1)
+  (7 2)
+  (6 1)
+  (9)
+  (3)
+  (1)
+  (4))
+ ((4)
+  (2 2)
+  (1 4)
+  (6 4)
+  (6 2 2)
+  (4 2 5)
+  (8)
+  (9)
+  (9)
+  (8)
+  (7)
+  (1)
+  (1)
+  (3 1)
+  (5 3 1)
+  (9 4)
+  (6 1 1 1)
+  (6 3 3)
+  (6 1)
+  (7 1))
+ ((o x x x x o o o o o o o o o o o o o o o)
+  (x x o x x x o o o o o o o o o o o o o o)
+  (x o x x x x o o o o o o o o o o o o o o)
+  (x o x x x x o o o o o o o o o o x x x x)
+  (x x x x x x o o o o o o o o x x x x x x)
+  (o x x x x o o o o o o o o x x x x x x x)
+  (o o o o o o o o o o o o o x x x x x x x)
+  (o o o o o o o o o o o o o x x x x x x x)
+  (o o o o o x x x x o o o o o x x x x x x)
+  (o o o o x x x x x x o o o o o x o o o x)
+  (o o o x x o x x x x x o o o o x x x o o)
+  (o o o x o x x x x x x o o o o x o x o o)
+  (o o o x o x x x x x x o o o x x o x o o)
+  (o o o x x x x x x x x o o o x o o o o o)
+  (o o o o x x x x x x x o o o x x o o o o)
+  (o o o o o x x x x x x o o o o x o o o o)
+  (o o o o o o o x x x x x x x x x o o o o)
+  (o o o o o o o o o o o o o o o x x x o o)
+  (o o o o o o o o o o o o o o o o o x o o)
+  (o o o o o o o o o o o o o o o o x x x x)))
+
+("Hattori 132"
+ ((3)
+  (1 1)
+  (1 1 6)
+  (1 1 1 4)
+  (1 1 2 5)
+  (1 1 2 5)
+  (1 1 9)
+  (1 1 10)
+  (1 1 3 1 3)
+  (1 1 3 1 2)
+  (1 1 2 1 3)
+  (1 1 2 2)
+  (5 1 2)
+  (1 2 2 1)
+  (1 2 7)
+  (3 7 2)
+  (5 1 7)
+  (5 1 7)
+  (5 14)
+  (3 1))
+ ((3)
+  (5)
+  (5)
+  (5)
+  (3)
+  (4)
+  (13 4)
+  (1 1 1 1)
+  (14 1 1)
+  (7)
+  (1 5)
+  (6 4)
+  (11 3)
+  (1 6 2 3)
+  (1 2 1 1 1 4)
+  (1 6 1 5)
+  (6 2 1)
+  (9 1 1)
+  (10 1 1)
+  (6 2 2 1))
+ ((o o o o o o x x x o o o o o o o o o o o)
+  (o o o o o o x o x o o o o o o o o o o o)
+  (o o o o o o x o x o o o o x x x x x x o)
+  (o o o o o o x o x o o o x o o o x x x x)
+  (o o o o o o x o x o o o x x o x x x x x)
+  (o o o o o o x o x o o o x x o x x x x x)
+  (o o o o o o x o x o o x x x x x x x x x)
+  (o o o o o o x o x o x x x x x x x x x x)
+  (o o o o o o x o x o o x x x o x o x x x)
+  (o o o o o o x o x o o x x x o x o x x o)
+  (o o o o o o x o x o o x x o x o o x x x)
+  (o o o o o o x o x o o x x o o o o o x x)
+  (o o o o o x x x x x o o x o x x o o o o)
+  (o o o o o x o o x x o o x x o o o o o x)
+  (o o o o o x o o o x x o o x x x x x x x)
+  (o x x x o x x x x x x x o o o x x o o o)
+  (x x x x x o x o o x x x x x x x o o o o)
+  (x x x x x o x o o x x x x x x x o o o o)
+  (x x x x x o x x x x x x x x x x x x x x)
+  (o x x x o o o o o o o o o o x o o o o o)))
+
+("Hattori 133"
+ ((3)
+  (3 4 1)
+  (7 4 5)
+  (11 4 2 1)
+  (15 2)
+  (13 2)
+  (14)
+  (11)
+  (17)
+  (20)
+  (22)
+  (24)
+  (24)
+  (5 13 2)
+  (16 1)
+  (18)
+  (19)
+  (10 10)
+  (9 11)
+  (9 6 5)
+  (9 6 4)
+  (8 7 2)
+  (7 6 1)
+  (5 5)
+  (3 3))
+ ((1 3 3)
+  (2 4 6)
+  (2 5 8)
+  (4 6 8)
+  (5 6 9)
+  (6 5 9)
+  (6 5 9)
+  (21)
+  (20)
+  (19)
+  (1 16)
+  (3 14 4)
+  (17 7)
+  (24)
+  (23)
+  (21)
+  (17)
+  (17)
+  (2 11)
+  (2 12)
+  (2 4 7)
+  (1 4 6)
+  (1 4 5)
+  (1 4 4)
+  (3))
+ ((o o o o o o o o o o x x x o o o o o o o o o o o o)
+  (o o o o o x x x o o o x x x x o o o o o o o o o x)
+  (o o o x x x x x x x o x x x x o o o o o x x x x x)
+  (x x x x x x x x x x x o x x x x o o o x x o o o x)
+  (o x x x x x x x x x x x x x x x o o x x o o o o o)
+  (o o o x x x x x x x x x x x x x o x x o o o o o o)
+  (o o o o x x x x x x x x x x x x x x o o o o o o o)
+  (o o o o o o o x x x x x x x x x x x o o o o o o o)
+  (o o o x x x x x x x x x x x x x x x x x o o o o o)
+  (o o x x x x x x x x x x x x x x x x x x x x o o o)
+  (o x x x x x x x x x x x x x x x x x x x x x x o o)
+  (x x x x x x x x x x x x x x x x x x x x x x x x o)
+  (x x x x x x x x x x x x x x x x x x x x x x x x o)
+  (x x x x x o o x x x x x x x x x x x x x o o x x o)
+  (o o o o o x x x x x x x x x x x x x x x x o o x o)
+  (o o o o x x x x x x x x x x x x x x x x x x o o o)
+  (o o o x x x x x x x x x x x x x x x x x x x o o o)
+  (o o x x x x x x x x x x o x x x x x x x x x x o o)
+  (o o x x x x x x x x x o x x x x x x x x x x x o o)
+  (o x x x x x x x x x o o x x x x x x o x x x x x o)
+  (o x x x x x x x x x o o x x x x x x o o x x x x o)
+  (o x x x x x x x x o o x x x x x x x o o o o x x o)
+  (x x x x x x x o o o o x x x x x x o o o o o o x o)
+  (x x x x x o o o o o o x x x x x o o o o o o o o o)
+  (x x x o o o o o o o o x x x o o o o o o o o o o o)))
+
+("Hattori 134"
+ ((4)
+  (3 3 4)
+  (2 2 6 5)
+  (5 8 5)
+  (2 1 8 3)
+  (3 7 3)
+  (4 7 3 3)
+  (5 5 5 1 1)
+  (1 3 4 6)
+  (1 4 4 6)
+  (1 3 2 3 1)
+  (1 4 1 3)
+  (1 3 4)
+  (1 7 4)
+  (1 3 2 2 2)
+  (1 3 1 6)
+  (1 7 4 2)
+  (1 4 1 3 4)
+  (1 2 12)
+  (2 8 2 1)
+  (3 1 1 1 4 7)
+  (14 2 5)
+  (12 3 3)
+  (8 4 2)
+  (5))
+ ((2 2)
+  (4 3)
+  (1 20)
+  (3 3 2)
+  (8 4)
+  (6 3)
+  (7 4)
+  (7 3)
+  (7 4)
+  (4 5 3)
+  (8 1 3 3)
+  (11 2 8)
+  (10 4 4 1)
+  (9 1 5 1)
+  (6 5 2)
+  (1 5 2 4)
+  (1 2 1 2 4)
+  (2 2 4 2)
+  (3 2 6)
+  (3 4 4 4)
+  (3 4 3 6)
+  (3 3 11)
+  (12 1 2 2)
+  (4 2 10)
+  (14))
+ ((o o o o o o o o o o o o o o o x x x x o o o o o o)
+  (o x x x o o o o o o o x x x o o o x x x x o o o o)
+  (x x o x x o o o o o x x x x x x o o x x x x x o o)
+  (x x x x x o o o o x x x x x x x x o o x x x x x o)
+  (o x x o x o o o o x x x x x x x x o o o o x x x o)
+  (o o x x x o o o o x x x x x x x o o o o o o x x x)
+  (o o x x x x o o o x x x x x x x o x x x o o x x x)
+  (o o x x x x x o o o x x x x x o x x x x x o x o x)
+  (o o x o x x x o o o x x x x o o o o o x x x x x x)
+  (o o x o x x x x o o x x x x o o o o o x x x x x x)
+  (o o x o o x x x o o o x x o o o o o o o x x x o x)
+  (o o x o o x x x x o o x o o o o o o o o o o x x x)
+  (o o x o o o x x x o o o o o o o o o o o o x x x x)
+  (o o x o o o x x x x x x x o o o o o o o o x x x x)
+  (o o x o o o o x x x o x x o o o o o o o x x o x x)
+  (o o x o o o o x x x o o x o o o o o o x x x x x x)
+  (o o x o o o o o x x x x x x x o o o x x x x o x x)
+  (o o x o o o o o x x x x o o x o o x x x o x x x x)
+  (o o x o o o o o o o x x o x x x x x x x x x x x x)
+  (o x x o o o o o o o o x x x x x x x x o x x o x o)
+  (x x x o x o x o x o o x x x x o o x x x x x x x o)
+  (x x x x x x x x x x x x x x o x x o x x x x x o o)
+  (o o x x x x x x x x x x x x o x x x o x x x o o o)
+  (o o o o x x x x x x x x o o x x x x o x x o o o o)
+  (o o o o o o o o o o o o x x x x x o o o o o o o o)))
+
+("Hattori 135"
+ ((1)
+  (2 3 3)
+  (9 7)
+  (3 3 2 5)
+  (2 4 1)
+  (2 1)
+  (1 1 2 1)
+  (1 2 1)
+  (1 6)
+  (1 1 2)
+  (1 1 2 1)
+  (1 4)
+  (1 1)
+  (1 2)
+  (3 6)
+  (4 7)
+  (14)
+  (1 14 3)
+  (1 11 3)
+  (2 6))
+ ((3)
+  (2 1)
+  (3 2)
+  (3 4)
+  (2 3 5)
+  (4 5)
+  (3 5)
+  (13 3)
+  (2 5)
+  (2 3 5)
+  (2 1 6)
+  (2 13)
+  (6 5)
+  (1 1 1 5)
+  (2 3 2 3 1)
+  (3 2 1)
+  (4 1)
+  (3 3)
+  (2 3)
+  (1 3))
+ ((o o o o o o o o o o o o o o o o x o o o)
+  (o o o x x o o x x x o o o o o x x x o o)
+  (o o x x x x x x x x x o o x x x x x x x)
+  (o x x x o x x x o o x x o o x x x x x o)
+  (o x x o x x x x o o o x o o o o o o o o)
+  (o o o o x x o x o o o o o o o o o o o o)
+  (o o o o x o o x o o o x x o x o o o o o)
+  (o o o o o o o x o o o x x o x o o o o o)
+  (o o o o o o o x o x x x x x x o o o o o)
+  (o o o o o o o x o x o x x o o o o o o o)
+  (o o o o o o o x o x o x x o x o o o o o)
+  (o o o o o o o x o o o x x x x o o o o o)
+  (o o o o o o o x o o o x o o o o o o o o)
+  (o o o o o o o x o o x x o o o o o o o o)
+  (o o o o x x x o x x x x x x o o o o o o)
+  (o o o x x x x o x x x x x x x o o o o o)
+  (o o x x x x x x x x x x x x x x o o o o)
+  (x o x x x x x x x x x x x x x x o x x x)
+  (x o o x x x x x x x x x x x o o o x x x)
+  (x x o o o o o o o o o o o o x x x x x x)))
+
+("Hattori 136"
+ ((11)
+  (6 6)
+  (6 5)
+  (9 8)
+  (6 4)
+  (5 3 3 4)
+  (5 1 1 1 1 4)
+  (5 4)
+  (2 4 2)
+  (3 2 2)
+  (1 1 9 3)
+  (1 7 4 1 1)
+  (1 3 4 1)
+  (6 2 2 2 1)
+  (2 1 1 4)
+  (9 6)
+  (1 4 6)
+  (1 4 2 2 1 1)
+  (1 1 3 4 1)
+  (4 7 4))
+ ((4 5 1)
+  (5 1 1 5)
+  (6 3 1 1 1)
+  (7 1 3 3)
+  (8 7)
+  (5 2 3 4)
+  (4 4 4)
+  (4 2 2 3 2)
+  (2 1 1 2 1 1 1 1)
+  (1 1 2 1 1 1 1 1 1)
+  (1 1 1 1)
+  (1 1 1 1 1 1 1)
+  (2 1 2 1 2 1 1 1 1)
+  (2 1 1 2 3 2)
+  (4 2 4 4)
+  (4 2 3 2 1)
+  (8 5 2)
+  (7 3 1 1 1)
+  (6 1 1 4)
+  (5 5 1))
+ ((o o o o o x x x x x x x x x x x o o o o)
+  (o o o x x x x x x o o o x x x x x x o o)
+  (o o x x x x x x o o o o o o x x x x x o)
+  (o x x x x x x x x x o o x x x x x x x x)
+  (x x x x x x o o o o o o o o o o x x x x)
+  (x x x x x o o x x x o o x x x o x x x x)
+  (x x x x x o o x o x o o x o x o x x x x)
+  (x x x x x o o o o o o o o o o o x x x x)
+  (o o o o x x o o o x x x x o o x x o o o)
+  (x x x o o x x o o o o o o o x x o o o o)
+  (x o x o o o x x x x x x x x x o o x x x)
+  (x o x x x x x x x o o o x x x x o x o x)
+  (x o o o x x x o o o o o o o x x x x o x)
+  (x x x x x x o o x x o x x o o x x o o x)
+  (o o o x x o o x o o o o o x o o x x x x)
+  (o x x x x x x x x x o x x x x x x o o o)
+  (o x o o x x x x o o o o o x x x x x x o)
+  (o x o x x x x o x x o x x o x o o o x o)
+  (o x o x o x x x o o o o o x x x x o x o)
+  (x x x x o o o x x x x x x x o o x x x x)))
+
+("Hattori 137"
+ ((5 3)
+  (3 3 2)
+  (5 3)
+  (4 1 4)
+  (3 3 2)
+  (8 1 1)
+  (2 4 2 1 1)
+  (11 2 2)
+  (4 3 8)
+  (2 10 4)
+  (10 5 1)
+  (8 10)
+  (5 9 3)
+  (3 9 6)
+  (10 6 2)
+  (6 12)
+  (3 10 3)
+  (10 5)
+  (6 4)
+  (7))
+ ((5)
+  (8)
+  (10)
+  (8 2 3)
+  (6 10)
+  (4 13)
+  (11 2 4)
+  (3 3 9 1)
+  (3 15)
+  (1 1 7 8)
+  (1 2 7 2 1)
+  (1 2 1 10)
+  (2 4 7)
+  (1 8 4)
+  (2 8 1)
+  (2 2 8)
+  (3 6 4)
+  (2 1 6 2)
+  (1 2 3 5)
+  (1 11))
+ ((o o o o o o o o x x x x x o o o o x x x)
+  (o o o o o o x x x o o o x x x o x x o o)
+  (o o o o o x x x x x o o o o x x x o o o)
+  (o o o o x x x x o o o x o o o x x x x o)
+  (o o o o x x x o o x x x o o o o o o x x)
+  (o o o x x x x x x x x o o x o o o o o x)
+  (o o o x x o x x x x o o x x o o x o o x)
+  (o o o x x x x x x x x x x x o x x o x x)
+  (o o o x x x x o x x x o x x x x x x x x)
+  (o o x x o x x x x x x x x x x o x x x x)
+  (o o x x x x x x x x x x o x x x x x o x)
+  (o x x x x x x x x o x x x x x x x x x x)
+  (o x x x x x o x x x x x x x x x o x x x)
+  (x x x o x x x x x x x x x o x x x x x x)
+  (x x x x x x x x x x o x x x x x x o x x)
+  (x x x x x x o x x x x x x x x x x x x o)
+  (x x x o x x x x x x x x x x o x x x o o)
+  (x x x x x x x x x x o x x x x x o o o o)
+  (o x x x x x x o x x x x o o o o o o o o)
+  (o o o x x x x x x x o o o o o o o o o o)))
+
+("Hattori 138"
+ ((6 1 1)
+  (8 3 3 1)
+  (3 2 1 2 5 2)
+  (2 1 1 1 1 4 3 3)
+  (1 1 1 1 1 2 6)
+  (1 1 1 4)
+  (2 3 1 1 2)
+  (2 2 1)
+  (6 1 3)
+  (7 1 1)
+  (8 3 1 2)
+  (2 8 1)
+  (2 3 3 6 1 2)
+  (2 1 4 1 1 1)
+  (2 5 4 1 1)
+  (3 3 3 4 6)
+  (8 4 1 1)
+  (8 5 6)
+  (3 3 2 1)
+  (3 3 2 4 4)
+  (3 3 1 6 6)
+  (3 3 2 2 2 2 2)
+  (3 3 2 2 5 2)
+  (8 8 6)
+  (8 4 4))
+ ((7 16)
+  (4 19)
+  (3 3 10)
+  (2 2 1 3 2 2)
+  (2 1 6 9)
+  (2 2 1 5 10)
+  (3 6 10)
+  (7 2 4 2)
+  (1 2)
+  (6 2)
+  (16 7)
+  (1 6 3 1)
+  (2 1 4)
+  (2 1 6)
+  (2 6 2 2)
+  (3 1 3 2 2)
+  (3 1 3 6)
+  (3 1 3 4)
+  (3 1 1)
+  (3 6 4)
+  (3 1 1 1 6)
+  (3 8 1 2 2)
+  (4 1 1 1 2 2)
+  (4 1 1 1 8)
+  (4 1 1 3 4))
+ ((o x x x x x x o o o x o o o o o o x o o o o o o o)
+  (x x x x x x x x o o x x x o o o x x x o o o o o x)
+  (x x x o o o x x o o x o x x o x x x x x o o o x x)
+  (x x o x o x o x o o x o o x x x x o x x x o x x x)
+  (x o o x o x o x o o x o o o x x o o o x x x x x x)
+  (x o o o o o o x o o x o o o o o o o o o x x x x o)
+  (x x o x x x o x o o x o o o o o o o o o o x x o o)
+  (x x o o o o x x o o x o o o o o o o o o o o o o o)
+  (o x x x x x x o o o x o o o o o o o o o x x x o o)
+  (x x x x x x x o o o x o o o o o o o o o o x o o o)
+  (x x x x x x x x o x x x o o o o o o o o o x o x x)
+  (x x o o x x x x x x x x o o o o o o o o o x o o o)
+  (x x o o x x x o o x x x o o x x x x x x o x o x x)
+  (x x o o x o o o x x x x o o x o o o o x o x o o o)
+  (x x o o o o o x x x x x o o x x x x o x o x o o o)
+  (x x x o o x x x o x x x o o x x x x o x x x x x x)
+  (x x x x x x x x o o o o o o x x x x o x o o o o x)
+  (x x x x x x x x o o x x x x x o o o o x x x x x x)
+  (x x x o x x x o o o x x o o o o o o o o o o o x o)
+  (x x x o x x x o o o x x o x x x x o o o x x x x o)
+  (x x x o x x x o o o x o x x x x x x o x x x x x x)
+  (x x x o x x x o o x x o x x o o x x o x x o o x x)
+  (x x x o x x x o o x x o x x o o x x x x x o o x x)
+  (x x x x x x x x o o x x x x x x x x o x x x x x x)
+  (x x x x x x x x o o o o o x x x x o o o x x x x o)))
+
+("Hattori 139"
+ ((3 5)
+  (5 1 3 1)
+  (5 3 7)
+  (3 3 5 1)
+  (5 5 6)
+  (5 3 5 8)
+  (10 3 9)
+  (3 5 9)
+  (3 5 3 8)
+  (5 3 5 7)
+  (5 5 6)
+  (5 3 5 6)
+  (3 5 3 5)
+  (5 4 1)
+  (3 5 3 2 2)
+  (5 3 5 1)
+  (5 5 4 2)
+  (5 3 5 7)
+  (3 5 3 8)
+  (5 8)
+  (3 5 8)
+  (5 3 9)
+  (5 9)
+  (5 7 2)
+  (3 4))
+ ((3 3 3)
+  (3 5 5 5)
+  (10 5 5)
+  (10 5 5)
+  (5 3 3 3)
+  (3 3 3)
+  (2 3 5 5)
+  (4 5 5 5)
+  (4 5 5 5)
+  (4 5 3 3)
+  (2 3 3)
+  (3 3 5)
+  (1 5 5 5)
+  (7 5 5)
+  (1 5 5 3)
+  (1 3 3 2)
+  (2 2 2 4)
+  (1 4 9)
+  (2 10 9)
+  (1 11 8)
+  (1 11 8)
+  (12 7)
+  (1 9 7)
+  (1 8 3 6)
+  (2 5 2 5))
+ ((o o o o o o o x x x o o x x x x x o o o o o o o o)
+  (o o o o o o x x x x x o o x o o x x x o o o o o x)
+  (o o o o o o x x x x x o x x x o o o x x x x x x x)
+  (o o x x x o o x x x o x x x x x o o o o o x o o o)
+  (o x x x x x o o o o o x x x x x o o x x x x x x o)
+  (o x x x x x o x x x o x x x x x o x x x x x x x x)
+  (o x x x x x x x x x x o x x x o x x x x x x x x x)
+  (o o x x x o x x x x x o o o o o x x x x x x x x x)
+  (o x x x o o x x x x x o x x x o o x x x x x x x x)
+  (x x x x x o o x x x o x x x x x o o x x x x x x x)
+  (x x x x x o o o o o o x x x x x o o x x x x x x o)
+  (x x x x x o x x x o o x x x x x o o x x x x x x o)
+  (o x x x o x x x x x o o x x x o o o x x x x x o o)
+  (o o o o o x x x x x o o o o o o o o x x x x o o x)
+  (o x x x o x x x x x o x x x o o o o o x x o o x x)
+  (x x x x x o x x x o x x x x x o o o o o o o o x o)
+  (x x x x x o o o o o x x x x x o o x x x x o x x o)
+  (x x x x x o x x x o x x x x x o x x x x x x x o o)
+  (o x x x o x x x x x o x x x o o x x x x x x x x o)
+  (o o o o o x x x x x o o o o o o o x x x x x x x x)
+  (o x x x o x x x x x o o o o o o o x x x x x x x x)
+  (x x x x x o x x x o o o o o o o x x x x x x x x x)
+  (x x x x x o o o o o o o o o o o x x x x x x x x x)
+  (x x x x x o o o o o o o o o o x x x x x x x o x x)
+  (o x x x o o o o o o o o o o o x x x x o o o o o o)))
+
+)
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/raw-problems/raw-kajitani.ss b/collects/games/paint-by-numbers/raw-problems/raw-kajitani.ss
new file mode 100644
index 0000000000..48d9394b95
--- /dev/null
+++ b/collects/games/paint-by-numbers/raw-problems/raw-kajitani.ss
@@ -0,0 +1,14477 @@
+(("Kajitani 15x15"
+  "k15x15"
+  (("19980519-KHA (1)"
+    ((2 2)
+     (4 4)
+     (6 6)
+     (15)
+     (1 2 1 2 1 1)
+     (2 2 1 1 1)
+     (2 3 2 1 1)
+     (1 3 3 1)
+     (13)
+     (11)
+     (9)
+     (7)
+     (5)
+     (3)
+     (1))
+    ((5)
+     (2 2 1)
+     (3 2)
+     (4 2 3)
+     (12)
+     (4 7)
+     (2 7)
+     (2 7)
+     (2 7)
+     (4 7)
+     (12)
+     (4 3)
+     (6 2)
+     (2 1)
+     (5)))
+   ("19980805-BER (2)"
+    ((1 13)
+     (1 1 1)
+     (1 1 9 1)
+     (1 1 1)
+     (1 3 9)
+     (1 1 1 1)
+     (1 1 11)
+     (1 1)
+     (1 11 1)
+     (1 1 3)
+     (1 1 7 1)
+     (1 1 1 1 1)
+     (1 1 5 1 3)
+     (1 1)
+     (14))
+    ((15)
+     (1)
+     (3 3 5 1)
+     (1 1 1 1)
+     (1 5 1 3 1)
+     (1 1 1 1 1 1 1)
+     (1 1 1 1 1 1 1 1)
+     (1 1 1 1 1 1 1 1)
+     (1 1 1 1 1 1 1 1)
+     (1 1 1 1 1 1 1)
+     (1 1 1 1 1 5)
+     (1 1 1 1 1 1)
+     (1 1 1 1 2 1 1)
+     (1 1 1 1 1 1)
+     (13)))
+   ("19980828-PAU (3)"
+    ((4 4)
+     (6 6)
+     (1 1 1 1)
+     (3 3)
+     (4 5 4)
+     (1 1 1 1)
+     (1 1 1)
+     (1)
+     (3)
+     (3)
+     (3 5 3)
+     (2 2)
+     (3 3)
+     (9)
+     (7))
+    ((1)
+     (2 1 1)
+     (2 1 3)
+     (2 3 4)
+     (2 1 1 3)
+     (2 3 1 2)
+     (2 1 3 2)
+     (1 5 2)
+     (2 1 3 2)
+     (2 3 1 2)
+     (2 1 1 3)
+     (2 3 4)
+     (2 1 3)
+     (2 1 1)
+     (1)))
+   ("19990211bJAM (4)"
+    ((3 2)
+     (2 2 2)
+     (2 4)
+     (2 3)
+     (2 5 2)
+     (2 1 1 1 2)
+     (3 5 3)
+     (1 1 1 1 1)
+     (1 5 1)
+     (1 1)
+     (1 4 1)
+     (1 1 1 1)
+     (1 1 1 1)
+     (1 1 1 1)
+     (1 1 1 1))
+    ((1)
+     (2)
+     (11)
+     (2)
+     (2 5)
+     (2 5 1)
+     (2 1 1 1 1)
+     (1 5 5)
+     (2 1 1 1)
+     (2 5)
+     (2)
+     (5)
+     (15)
+     (2)
+     (1)))
+   ("19990221bFRA (5)"
+    ((1)
+     (1 1)
+     (2 2)
+     (3 3)
+     (4 4)
+     (5 5)
+     (6 6)
+     (7 7)
+     (1)
+     (1)
+     (15)
+     (13)
+     (11)
+     (9)
+     (9))
+    ((1 1)
+     (2 2)
+     (3 3)
+     (4 5)
+     (5 5)
+     (6 5)
+     (7 5)
+     (1 7)
+     (7 5)
+     (6 5)
+     (5 5)
+     (4 5)
+     (3 3)
+     (2 2)
+     (1 1)))
+   ("19990421aMIJ (6)"
+    ((3)
+     (3)
+     (2)
+     (4 4)
+     (1 1 2)
+     (1 1)
+     (13)
+     (1 1)
+     (12)
+     (1 1)
+     (14)
+     (1 1)
+     (1 3 1)
+     (4 3)
+     ())
+    (()
+     (7)
+     (1 1 1 1 1)
+     (1 1 1 1 1)
+     (1 1 1 1 1)
+     (1 1 1 1 1)
+     (1 1 1 1 2)
+     (2 1 1 1 1 1)
+     (4 1 1 1 1)
+     (2 1 1 1 1 1)
+     (1 1 1 1 1 1)
+     (1 1 1 1 1)
+     (1 3 1 1)
+     (1 1 3)
+     (1 1)))
+   ("19990527cDRA (7)"
+    ((3 4)
+     (1 2)
+     (1 6 1)
+     (1 11)
+     (5 4)
+     (4 2 4)
+     (3 3 3)
+     (1 1 3 1 2)
+     (1 2 2 1)
+     (1 1 2 2)
+     (3 7 3)
+     (4 5 4)
+     (5 5)
+     (15)
+     (15))
+    ((15)
+     (1 3 5)
+     (1 4 1 5)
+     (3 2 4)
+     (2 2 3)
+     (2 2 2)
+     (2 3 2 2)
+     (2 3 2 2)
+     (2 2 2 2)
+     (2 2 2)
+     (3 2 3)
+     (1 3 3 4)
+     (1 4 1 5)
+     (2 4 6)
+     (3 10)))
+   ("19990723aDAH (8)"
+    (()
+     ()
+     (6 6)
+     (1 3 1)
+     (1 1)
+     (3 3)
+     (2 2 2 2)
+     (9)
+     (9)
+     (1 5 1)
+     (1 3 1)
+     (1 1 1)
+     (1 1)
+     (9)
+     ())
+    ((4)
+     (1 1)
+     (1 2)
+     (1 8)
+     (1 2 1)
+     (1 4 1)
+     (1 5 1)
+     (1 5 1)
+     (1 5 1)
+     (1 4 1)
+     (1 2 1)
+     (1 8)
+     (1 2)
+     (1 1)
+     (4)))
+   ("19990723bDAH (9)"
+    ((4 6)
+     (2 4 2)
+     (1 2 2)
+     (1 1 2 1)
+     (1 1 4 1)
+     (1 1 1 2 1)
+     (1 6 1)
+     (1 1 2 2)
+     (1 1 2 2)
+     (1 1 1 2)
+     (2 2 1 2)
+     (1 1 1 1)
+     (4 4)
+     (1 1 1 1)
+     (1 1 1 1))
+    ((10)
+     (2 5)
+     (1 1)
+     (1 1)
+     (2 5)
+     (10)
+     (2 1)
+     (2 1 7)
+     (1 5 1)
+     (1 2 2 1)
+     (1 4 5)
+     (1 2 2)
+     (2 2)
+     (2 2)
+     (6)))
+   ("19990728-DAH (10)"
+    ((5 5)
+     (3 5 3)
+     (2 4 3 2)
+     (1 4 2 1)
+     (1 1 5 1 1)
+     (3 5 2)
+     (4 4 1)
+     (5 6)
+     (1 1 1 1)
+     (1 1 1 1)
+     (1 7 2 1)
+     (1 8 1 1)
+     (2 8 2)
+     (3 5 3)
+     (5 5))
+    ((5 5)
+     (3 5 3)
+     (2 4 2 2)
+     (1 1 3 3 1)
+     (1 2 2 3 1)
+     (4 1 4)
+     (5 1 4)
+     (1 4 5)
+     (1 4 4)
+     (2 5 3)
+     (1 1 3 1 1 1)
+     (1 2 1 1 1)
+     (2 3 1 2 2)
+     (3 5 3)
+     (5 5)))
+   ("19990917aMAT (11)"
+    ((2 3 2)
+     (1 5 1)
+     (2 1 2)
+     (3 3)
+     (1 1 1 1)
+     (1 1 5 2 1)
+     (1 3 4 1)
+     (3 4)
+     (2 2)
+     (2 2)
+     (2 2)
+     (2 2)
+     (11)
+     (1 2 2 1)
+     (3 3))
+    (()
+     (2 1)
+     (1 1 1 1)
+     (2 6 1 1)
+     (1 2 9)
+     (6 3)
+     (2 1 1 1)
+     (3 1 1)
+     (2 1 1 1)
+     (6 3)
+     (1 2 9)
+     (2 6 1 1)
+     (3 1 1)
+     (1 1 1)
+     (2)))
+   ("19990917bMAT (12)"
+    ((3 2)
+     (4 2)
+     (7 2)
+     (1 11)
+     (1 7)
+     (1 1 4)
+     (7 3)
+     (2 1 2 3)
+     (1 1 1 1 3)
+     (7 3)
+     (7 3)
+     (3)
+     (3)
+     (5)
+     (15))
+    ((1 1)
+     (1 1 1)
+     (11 1)
+     (3 2 2 1)
+     (3 1 3 1)
+     (3 2 2 1)
+     (2 1 3 1)
+     (2 2 1 1)
+     (8 1)
+     (2 1)
+     (2 2)
+     (3 2)
+     (12)
+     (15)
+     (15)))
+   ("19990917cMAT (13)"
+    ((1)
+     (1 1)
+     (11)
+     (1 5 1)
+     (1 7 1)
+     (1 1)
+     (1 1 5 1)
+     (1 1)
+     (1 1 5 1)
+     (1 1)
+     (1 1 5 1)
+     (1 1)
+     (1 1 5 1)
+     (1 1)
+     (11))
+    (()
+     ()
+     (13)
+     (1 1)
+     (1 1 1 1 1 1 1)
+     (3 1)
+     (4 1 1 1 1 1)
+     (1 3 1 1 1 1 1)
+     (4 1 1 1 1 1)
+     (3 1 1 1 1 1)
+     (1 1 1 1 1 1 1)
+     (1 1)
+     (13)
+     ()
+     ()))
+   ("19990917dMAT (14)"
+    ((9 3)
+     (1 1 3)
+     (1 1 3)
+     (2 2 3)
+     (3 3 5)
+     (5 2 1 2)
+     (5 1 1 1)
+     (1 1 1 2 1)
+     (1 1 1 1 1)
+     (1 1 2 2)
+     (1 1 1 5)
+     (1 1 1 3)
+     (1 3 1 3)
+     (7 3)
+     (9 3))
+    ((1 1)
+     (5 5)
+     (1 4 2 2)
+     (1 4 3)
+     (1 2 1 5)
+     (1 4 3)
+     (1 4 2 2)
+     (5 5)
+     (1 5 1)
+     (2 2)
+     (5 1 5)
+     (8 5)
+     (5 5)
+     (2 2)
+     (5)))
+   ("19990917eMAT (15)"
+    ((3)
+     (1 2)
+     (2)
+     (1)
+     (2)
+     (1)
+     (5)
+     (5 5)
+     (7 5)
+     (9 5)
+     (1 1 5)
+     (7 5)
+     (1 1 3)
+     (9 3)
+     (7 3))
+    ((2 2)
+     (2 1 2)
+     (3 1 2)
+     (3 1 2)
+     (3 1 2)
+     (3 1 2)
+     (1 3 1 2)
+     (1 2 1 2)
+     (1 2 2)
+     (2)
+     (2 6)
+     (3 9)
+     (11)
+     (9)
+     (6)))
+   ("19990918aMAT (16)"
+    ((5)
+     (3)
+     (9)
+     (2 2)
+     (2 3 2)
+     (2 1 1 1 2)
+     (2 2 2 2)
+     (2 3 2)
+     (2 2 1 2 2)
+     (2 2 2 2)
+     (2 3 2)
+     (2 2 2 2)
+     (2 2 2 2)
+     (3 3)
+     (13))
+    (()
+     (11)
+     (12)
+     (2 2)
+     (1 1 1 1)
+     (1 1 2 2 2 1)
+     (3 1 2 3 1)
+     (3 2 2 1 1)
+     (3 1 2 3 1)
+     (1 1 2 2 2 1)
+     (1 1 1 1)
+     (2 2)
+     (12)
+     (11)
+     ()))
+   ("19990918bMAT (17)"
+    ((1 1)
+     (5)
+     (1 1 1 1 1)
+     (2 5 1 1)
+     (1 2 3 2 1)
+     (2 3 3 1)
+     (2 1 1 2)
+     (4 4)
+     (1 1)
+     (4 4)
+     (3 3 2)
+     (2 2 2 2)
+     (2 2 1)
+     (3 1 1)
+     (1))
+    ((2 1)
+     (2 2)
+     (2 2 1 1)
+     (2 1 2 1)
+     (2 1 1 2)
+     (3 5 2)
+     (2 3 3)
+     (4 1)
+     (2 3 3)
+     (3 5 2)
+     (2 1 1 3)
+     (3 1 2)
+     (2 2)
+     (4 3)
+     ()))
+   ("19990918cMAT (18)"
+    ((2 3)
+     (2 3)
+     (4)
+     (2)
+     (4)
+     (15)
+     (1 3 1 1)
+     (1 5 1 1 1)
+     (1 2 1 2 1 1)
+     (1 3 3 1 1 1)
+     (1 1 3 1 1 1)
+     (1 1 1 1 1 1)
+     (1 3 1 1)
+     (15)
+     (1 1))
+    ((9)
+     (1 2)
+     (1 3 1)
+     (1 1 3 1 1)
+     (2 3 2 2)
+     (2 5 1 2)
+     (6 2 2)
+     (4 3 1 1)
+     (2 2 3 1)
+     (1 1 1)
+     (2 9)
+     (1 1 1)
+     (1 1 1 1 1 1)
+     (1 2)
+     (9)))
+   ("19990918dMAT (19)"
+    ((1)
+     (3)
+     (1)
+     (1)
+     (5)
+     (9)
+     (13)
+     (15)
+     (1 1 1 1 1)
+     (1 1 1 1 1 1 1)
+     (1 1 1 1 1)
+     (3 1 3)
+     (3 1 3)
+     (3 1 3)
+     (15))
+    ((1 1)
+     (9)
+     (2 4)
+     (10)
+     (3 1)
+     (4 1 1)
+     (1 4 1)
+     (15)
+     (1 4 1)
+     (4 1 1)
+     (3 1)
+     (10)
+     (2 4)
+     (9)
+     (1 1)))
+   ("19990918eMAT (20)"
+    (()
+     (3)
+     (8)
+     (4 1 2)
+     (1 1 1 1)
+     (2 2 6)
+     (12)
+     (1 8)
+     (1 11)
+     (1 13)
+     (3 5 3)
+     (1 1 2 2)
+     (2 1 2 2)
+     (5 4)
+     (6))
+    ((6)
+     (3 3)
+     (1 1 2 2)
+     (1 4 1)
+     (2 5 2)
+     (13)
+     (1 5 2)
+     (2 6 1)
+     (11 1)
+     (2 10)
+     (1 5 2)
+     (2 2 2 1)
+     (3 3 2)
+     (5)
+     (3)))
+   ("19990918fMAT (21)"
+    ((1 1)
+     (2 1 1 2)
+     (2 1 1 2)
+     (3 3 3)
+     (4 3 4)
+     (15)
+     (15)
+     (15)
+     (4 3 4)
+     (3 3 3)
+     (2 1 2)
+     (2 1 2)
+     (1 1 1)
+     (1 1 1)
+     (1))
+    ((3) (7) (11) (14) (5) (3) (9) (12) (9) (3) (5) (14) (11) (7) (3)))
+   ("19990918gMAT (22)"
+    ((1 1)
+     (1 2)
+     (1 4)
+     (1 5)
+     (1 6)
+     (8 2)
+     (9)
+     (10)
+     (1 9)
+     (1 10)
+     (2 1 1 1)
+     (1 1 1 1 1)
+     (1 1 1 2 1)
+     (2 1 1 1)
+     (1))
+    ((2)
+     (1 1)
+     (1 1)
+     (7)
+     (6)
+     (5 3)
+     (5)
+     (15)
+     (5)
+     (6 1)
+     (11)
+     (7 2)
+     (4 5)
+     (4)
+     (3)))
+   ("19990918hMAT (23)"
+    ((4)
+     (6)
+     (12 1)
+     (12 1)
+     (2 1 2 6)
+     (6)
+     (4)
+     ()
+     (3)
+     (2 2)
+     (2 1 2)
+     (1 13)
+     (2 1 2 1 1)
+     (2 2 2 2)
+     (3))
+    ((2 3)
+     (3 2 2)
+     (3 2 1 2)
+     (2 1 3 1)
+     (3 2 1 2)
+     (2 5)
+     (3 3)
+     (3 1)
+     (2 1)
+     (5 1)
+     (7 1 1)
+     (7 3)
+     (2 3 1)
+     (2 3 3)
+     (5 1 1)))
+   ("19990918iMAT (24)"
+    ((2 1)
+     (1 2 1)
+     (1 1 1)
+     (1 1)
+     (3)
+     (7)
+     (9)
+     (2 8)
+     (1 9)
+     (1 9)
+     (11)
+     (11)
+     (11)
+     (9)
+     (7))
+    (()
+     (6)
+     (2 4)
+     (2 7)
+     (10)
+     (11)
+     (13)
+     (1 11)
+     (1 10)
+     (1 10)
+     (1 8)
+     (1 6)
+     (1)
+     (2 1)
+     (1)))
+   ("19990918jMAT (25)"
+    ((3 3)
+     (2 2 2 1)
+     (1 3)
+     (1)
+     (1 4)
+     (1 6)
+     (1 9)
+     (2 9)
+     (2 10)
+     (10 3)
+     (13)
+     (8 5)
+     (10)
+     (2 10)
+     (1))
+    ((3 3)
+     (2 3 3)
+     (2 4)
+     (1 4)
+     (2 5)
+     (2 6)
+     (12)
+     (2 8)
+     (2 9)
+     (1 7 2)
+     (2 8 1)
+     (5 2 1)
+     (8 1)
+     (7 1)
+     (6)))
+   ("19990918kMAT (26)"
+    ((1 1 2)
+     (3 1 2)
+     (1 3 1 2 2)
+     (7 1 1)
+     (3 1 1)
+     (3 1 1)
+     (1 2 2)
+     (6 2 3)
+     (2 6 1)
+     (1 3)
+     (1 4)
+     (6)
+     (2 3)
+     (2 3)
+     (3))
+    ((3)
+     (2 2 1)
+     (1 1 4)
+     (6 8)
+     (11)
+     (6 5)
+     (1 2 4)
+     (2 1 3)
+     (2 2)
+     (3 2)
+     (2 2)
+     (1 1)
+     (2 2)
+     (2 2)
+     (5)))
+   ("19990918lMAT (27)"
+    ((5)
+     (2 2)
+     (2 5 2)
+     (2 2 2 2)
+     (4 1 4)
+     (5 2 5)
+     (1 1 3 1 1)
+     (5 3 5)
+     (1 2 2 1)
+     (6 1 4)
+     (4 2 5)
+     (3 4 4)
+     (11)
+     (3 4)
+     (5))
+    ((5)
+     (3 1 3)
+     (4 1 4)
+     (2 2 1 5)
+     (1 8 2)
+     (1 2 2 4)
+     (1 1 1 3 1)
+     (1 1 3 4 1)
+     (1 1 4 4)
+     (1 2 1 1 3)
+     (1 3 2 4)
+     (2 10)
+     (4 1 4)
+     (3 1 3)
+     (5)))
+   ("19990918mMAT (28)"
+    ((15)
+     (5 1)
+     (4 3 5)
+     (1 4 3 2)
+     (3 2 1)
+     (1 2 1 1 1)
+     (1 4 3 2)
+     (7 7)
+     (1 6 6)
+     (1 6 6)
+     (2 7)
+     (12)
+     (1 2 5)
+     (3 6 4)
+     (15))
+    ((1 2 4 3)
+     (1 1 1 2)
+     (1 1 1 3 3)
+     (1 2 7 1)
+     (2 2 6 2)
+     (10 1 2)
+     (10 1 2)
+     (3 2 1 2)
+     (2 5 2 2)
+     (1 3 6 2)
+     (1 2 7 1)
+     (1 1 8)
+     (1 1 1 8)
+     (1 2 9)
+     (2 12)))
+   ("19990918nMAT (29)"
+    ((7)
+     (1)
+     (6)
+     (7)
+     (3 1)
+     (3 1)
+     (3 1)
+     (8)
+     (9)
+     (8)
+     (4 3)
+     (2 3 2 2)
+     (3 3 1 1 1)
+     (1 1 1 1 1)
+     (2 2))
+    ((1 1)
+     (1 1)
+     (1 2)
+     (1 1 1)
+     (1 1 1)
+     (1 2)
+     (13)
+     (11)
+     (10)
+     (2 4 2)
+     (2 3 1 1)
+     (8 1 1)
+     (1 4 2)
+     (5)
+     (1 4)))
+   ("19990918oMAT (30)"
+    ((2)
+     (3)
+     (1 1)
+     (1 2 4)
+     (1 1 2 1)
+     (1 1 2 1)
+     (1 1 2 2 1)
+     (1 2 2 3)
+     (2 8)
+     (14)
+     (4 5 2)
+     (2 2 3 2 1)
+     (1 1 1 1 1 1)
+     (1 1 1 1 1)
+     (2 2))
+    ((1 2)
+     (5 1 4)
+     (2 2 3)
+     (3 2 2)
+     (7 1 1)
+     (4 1 1)
+     (2 2)
+     (9)
+     (11)
+     (1 4)
+     (1 3 2)
+     (6 1 1)
+     (3 1 1)
+     (4 2)
+     (1 2)))
+   ("19990920aMAT (31)"
+    ((4)
+     (1 1)
+     (1 1)
+     (1 1)
+     (3 1 1)
+     (15)
+     (1 9 1)
+     (6 2 1)
+     (5 3 5)
+     (4 5 4)
+     (4 5 4)
+     (4 5 4)
+     (5 3 5)
+     (1 4 6)
+     (15))
+    ((10)
+     (2 6 1)
+     (11)
+     (11)
+     (4 3)
+     (3 3 2)
+     (2 5 1)
+     (2 5 1)
+     (2 5 1)
+     (3 3 2)
+     (9 3)
+     (1 1 7)
+     (1 1 7)
+     (6 7)
+     (10)))
+   ("19990920bMAT (32)"
+    ((2 1 1)
+     (1 1 1 1)
+     (3 1 1)
+     (1 1 1 1)
+     (1 1)
+     (2 1 1 2)
+     (3 3)
+     (4 1 4)
+     (13)
+     (9)
+     (1 1)
+     (11)
+     (11)
+     (11)
+     (9))
+    ((1)
+     (3)
+     (1 3 4)
+     (2 5 4)
+     (1 4 2 4)
+     (1 1 2 4)
+     (1 1 2 4)
+     (2 3 4)
+     (2 1 2 4)
+     (2 4)
+     (4 2 4)
+     (2 5 4)
+     (3 4)
+     (3)
+     (1)))
+   ("19990920cMAT (33)"
+    ((1)
+     (5)
+     (1 3)
+     (5)
+     (2 2)
+     (5)
+     (1 3)
+     (5)
+     (2 2)
+     (5)
+     (6 1)
+     (8 1)
+     (9 1)
+     (10)
+     (6 3))
+    (() (2) (3) (3) (4) (5) (15) (1 3 7) (3 3 6) (14) (14) (1) (1 1) (1) ()))
+   ("19990920dMAT (34)"
+    ((2)
+     (3)
+     (4 1)
+     (3 1 2)
+     (1 3 1 1)
+     (1 1 1 1)
+     (1 1 1 1)
+     (1 1 2 1 1)
+     (2 1 1 1 2)
+     (1 4 1)
+     (3 3)
+     (6)
+     (2)
+     (2)
+     (6))
+    (()
+     (2)
+     (3)
+     (4 1)
+     (1 1 2)
+     (3 1 1 1)
+     (4 3 1 1)
+     (1 1 2 1 4)
+     (1 1 1 4)
+     (2 1 1 2 1)
+     (1 4 1 1)
+     (3 3)
+     (6)
+     ()
+     ()))
+   ("19990920eMAT (35)"
+    ((2)
+     (1 1)
+     (2 1)
+     (15)
+     (1 10)
+     (1 2 2 1)
+     (1 1 1 2 1 1)
+     (1 4 2 1 1)
+     (1 1 2 1 1)
+     (1 1 1 1 1)
+     (1 1 1 1)
+     (1 1 2)
+     (1 1)
+     (1 1)
+     (1 1))
+    ((12)
+     (1)
+     (1 8)
+     (1 2)
+     (1 1 1)
+     (5)
+     (2)
+     (8)
+     (8 1)
+     (1 2 1 1)
+     (1 2 3 1)
+     (1 2 1)
+     (8)
+     (2)
+     (2)))
+   ("19990923-MAT (36)"
+    ((5 5)
+     (4 5 4)
+     (3 1 1 3)
+     (2 9 2)
+     (1 1 5 1 1)
+     (9)
+     (2 2)
+     (2 2)
+     (2 2)
+     (2 2)
+     (1 2 2 1)
+     (2 2 2 2)
+     (3 2 2 3)
+     (4 4)
+     (5 5))
+    ((5 5)
+     (4 4)
+     (3 1 3)
+     (2 3 3 2)
+     (1 2 3 2 1 1)
+     (1 4 3)
+     (1 3 1)
+     (1 3 1)
+     (1 3 3)
+     (1 5 2 1)
+     (1 2 2 3 1)
+     (2 3 1 2)
+     (3 3)
+     (4 4)
+     (5 5)))
+   ("19990924aMAT (37)"
+    ((1)
+     (1 1 1 1)
+     (3 1 1 3)
+     (1 1 1 5 1 1)
+     (8 2 1 1)
+     (1 1 1 1 1 1 1)
+     (1 1 1 1 1 1 1)
+     (1 1 1 1 1 1 1)
+     (1 1 1 1 1 1 1)
+     (1 1 1 1 1 1 1)
+     (1 1 2 1 2 1)
+     (1 1 1 1 1 1)
+     (1 1 1 1 1 1)
+     (1 1 9 1)
+     (1 3 2 2 3))
+    ((12)
+     (1)
+     (13)
+     (2 1 1)
+     (13)
+     (1 1 1)
+     (8 2)
+     (1 2 2)
+     (1 1 4)
+     (1 2 2)
+     (8 2)
+     (1 1)
+     (13)
+     (2 1)
+     (13)))
+   ("19990924bMAT (38)"
+    ((15)
+     (6 7)
+     (6 7)
+     (9 2 1)
+     (7 2 1 1)
+     (5 1 3 1 1)
+     (5 1 4 1)
+     (2 1 1 4 1)
+     (2 2 4 1)
+     (2 3 3 2)
+     (1 2 2 1 2)
+     (3 2 2 2 1)
+     (3 1 2 2 1)
+     (3 1 1 7)
+     (3 1 1 7))
+    ((9 5)
+     (10 4)
+     (7 1 4)
+     (7)
+     (8 1 2)
+     (5 4)
+     (1 12)
+     (1 1)
+     (15)
+     (3 11)
+     (4 5 2)
+     (5 3 5)
+     (3 1 4)
+     (3 2 2)
+     (15)))
+   ("19990924cMAT (39)"
+    ((2)
+     (2 2)
+     (1 1 4)
+     (1 2 1 2)
+     (1 2 1 2)
+     ()
+     (4 4)
+     (7 1 2 1)
+     (1 2 2 2 1)
+     (1 4 1 2 1)
+     (6 4)
+     (6 1 1)
+     (8 1 1)
+     (8 1 1)
+     (8 2 2))
+    ((2 3)
+     (2 1 5)
+     (1 2 6)
+     (1 2 9)
+     (1 2 9)
+     (1 2 6)
+     (2 1 5)
+     (2 3)
+     (2)
+     (1 1)
+     (1 1 5)
+     (5 5)
+     (5 5)
+     (1 1 5)
+     (3 1)))
+   ("19990924dMAT (40)"
+    ((3 3)
+     (5 5)
+     (7 7)
+     (7 7)
+     (7 7)
+     (5 5)
+     (3 3)
+     (11)
+     (6 1 2 2)
+     (13)
+     (7 5)
+     (10 2)
+     (1 1 1)
+     (1 1 1)
+     (1 1 1))
+    ((3)
+     (5 2)
+     (12)
+     (12)
+     (12 1)
+     (5 7)
+     (3 5)
+     (1 6)
+     (3 5)
+     (5 1 1 3)
+     (12 1)
+     (12)
+     (7 2)
+     (5 4)
+     (3 4)))
+   ("19990924eMAT (41)"
+    ((1 10)
+     (8)
+     (2 2 4)
+     (1 1 4 3)
+     (7 3)
+     (1 6 3)
+     (1 8 2)
+     (2 9 2)
+     (3 8 2)
+     (4 7 1)
+     (6 6 1)
+     (7 3 1)
+     (9 1 2)
+     (10 2)
+     (12 1))
+    ((1 10)
+     (8)
+     (2 7)
+     (1 1 6)
+     (2 3 5)
+     (1 5 5)
+     (1 6 4)
+     (2 8 3)
+     (11 3)
+     (12 2)
+     (2 10 1)
+     (3 6 1)
+     (6 2 2)
+     (9 2)
+     (12 1)))
+   ("19990925-MAT (42)"
+    ((9 4)
+     (9 1 2)
+     (10 2 1)
+     (10 1 1)
+     (6 1)
+     (5 1 4)
+     (4 1 4)
+     (4 1 4)
+     (4 4)
+     (4 5)
+     (2 6)
+     (2 10)
+     (1 1 10)
+     (1 2 10)
+     (2 11))
+    ((11 2)
+     (11 1 1)
+     (10 1 1)
+     (10 3)
+     (6 1)
+     (5 2 4)
+     (4 1 4)
+     (4 4)
+     (4 4)
+     (2 5)
+     (1 6)
+     (1 2 10)
+     (1 1 11)
+     (2 10)
+     (4 10)))
+   ("19990927aMAT (43)"
+    ((12)
+     (12)
+     (2 7)
+     (2 5)
+     (2 1)
+     (2 7)
+     (2 1 1 4)
+     (2 1 1 2)
+     (2 1 1 1 2)
+     (2 1 1 2)
+     (2 9 2)
+     (2 9 2)
+     (2 7)
+     (2 5)
+     (12))
+    ((15)
+     (15)
+     (2 1)
+     (2 1 3 1)
+     (3 2 1 3 1)
+     (4 1 1 5)
+     (4 1 5)
+     (7 1 5)
+     (4 1 5)
+     (4 3 5)
+     (3 1 1 3 1)
+     (2 1 3 1)
+     (2)
+     (5)
+     (4)))
+   ("19990927bMAT (44)"
+    (()
+     (2)
+     (1 2)
+     (2 2)
+     (6 3)
+     (3 3 1)
+     (4 4 2)
+     (15)
+     (1 7 1)
+     (3 5 3)
+     (2 2 3 2 2)
+     (1 1 1 3 1 1 1)
+     (2 2 2 2)
+     (3 3)
+     ())
+    ((2 2 3)
+     (5 2 2)
+     (4 1 1 1)
+     (4 2 2)
+     (1 3 3)
+     (1 1 3)
+     (1 5)
+     (2 6)
+     (2 7)
+     (7)
+     (5 3)
+     (1 1 2 2)
+     (3 1 1 1)
+     (2 2 2)
+     (2 3)))
+   ("19990927cMAT (45)"
+    (()
+     (10)
+     (2 1)
+     (1 1)
+     (1 1)
+     (1 1)
+     (2 2)
+     (2 3 2)
+     (13)
+     (1 3 1)
+     (13)
+     (1 1 1 1 1 1 1 1)
+     (2 1 1 1 1 1 2)
+     (1 1 1 1 1 1 1 1)
+     (15))
+    ((4)
+     (5 1 1)
+     (5 2 2)
+     (1 1 1 1 1)
+     (1 1 2 2)
+     (2 1 1 1 1)
+     (1 5 2)
+     (1 4 1 1)
+     (1 5 2)
+     (1 1 1 1 1)
+     (1 1 2 2)
+     (1 1 1 1 1)
+     (1 5 2 2)
+     (1 1 5 1 1)
+     (2 4)))
+   ("19990927dMAT (46)"
+    ((3)
+     (2 2)
+     (1 1)
+     (1 1)
+     (1 2)
+     (3 3)
+     (2 2 2)
+     (1 2 6)
+     (1 10)
+     (2 2 2)
+     (4 2)
+     (2 2)
+     (2)
+     (2)
+     (1))
+    ((4 1)
+     (2 3)
+     (1 1)
+     (1 1)
+     (1 2)
+     (4)
+     (3 2)
+     (2 3 6)
+     (1 10)
+     (2 2 2)
+     (4 2)
+     (2)
+     (2)
+     (2)
+     (1)))
+   ("19990930-TPV (47)"
+    (()
+     (13)
+     (1 11)
+     (13)
+     (13)
+     (13)
+     (13)
+     (13)
+     (13)
+     (2 4)
+     (2 3 4)
+     (2 3 4)
+     (2 3 4)
+     (1 3 4)
+     ())
+    (() (12) (1 11) (8) (8 4) (8 4) (8 4) (8) (8) (8) (13) (13) (13) (13) ()))
+   ("19991001aMAT (48)"
+    ((2)
+     (4)
+     (4 2)
+     (2 5)
+     (7)
+     (2 4)
+     (4)
+     (6)
+     (1 5)
+     (5)
+     (5 1)
+     (6 2)
+     (2 4 1)
+     (3 4 2)
+     (2 2 3))
+    ((2)
+     (2 1)
+     (1 2)
+     (4 1 1)
+     (2 2 1 2)
+     (6 1 2)
+     (13)
+     (9 1)
+     (11)
+     (8)
+     (6)
+     (4)
+     (1)
+     (2 2)
+     (3)))
+   ("19991001bMAT (49)"
+    ((2)
+     (1 2)
+     (1 1 2)
+     (1 4)
+     (1 3)
+     (13)
+     (3 11)
+     (2 8 1)
+     (3 7 2)
+     (13)
+     (3 2)
+     (3 2)
+     (3 2)
+     (3 2)
+     (2 1))
+    ((3)
+     (5)
+     (6 3)
+     (1 3)
+     (2 5)
+     (5 3)
+     (5 3)
+     (5 2)
+     (2 5)
+     (1 7)
+     (11 1)
+     (7 6)
+     (3 1 1 1)
+     (2 2)
+     (3)))
+   ("19991001cMAT (50)"
+    ((3)
+     (3)
+     (3)
+     (3)
+     (9)
+     (5 3)
+     (3)
+     (1 1 1)
+     (1 1 1 1)
+     (1 1 1 1 1)
+     (1 1 1 1)
+     (1 1 1 1 1)
+     (1 1)
+     (1 1)
+     (2 2))
+    (()
+     (1)
+     (1)
+     (2 1 1)
+     (1 1 1 1)
+     (2 1 1 4)
+     (3 3 1 1)
+     (3 4 1 1)
+     (3 3 1 1)
+     (2 1 1 4)
+     (1 1 1 1)
+     (2 1 1)
+     (1)
+     (1)
+     ()))
+   ("19991001dMAT (51)"
+    ((1 3)
+     (2 4)
+     (1 2)
+     (2 3)
+     (1 4)
+     (2 4)
+     (4 4)
+     (1 5)
+     (2 1 2)
+     (3 1 1 1)
+     (1 1 1 1 1 1)
+     (1 1 2)
+     (3 2 1)
+     (2 2 1)
+     (1 3))
+    ((4)
+     (2 4 3)
+     (3 1 2 2)
+     (4)
+     (2 1)
+     ()
+     (1)
+     ()
+     (5)
+     (1 2)
+     (4 1 1 2)
+     (7 2 1)
+     (9 3)
+     (2 8)
+     (2)))
+   ("19991010bTPV (52)"
+    ((1)
+     (1)
+     (2 1)
+     (1 4)
+     (2 3 2 1)
+     (6 6)
+     (14)
+     (12)
+     (12)
+     (11)
+     (3 2)
+     (3 2)
+     (5)
+     (3)
+     (2 2))
+    ((2 3)
+     (6)
+     (6)
+     (8)
+     (9)
+     (6 2)
+     (5 1 1)
+     (1 4 3)
+     (1 1 4 3)
+     (1 1 7 2)
+     (9 1)
+     (7)
+     (1 2)
+     (3)
+     (1)))
+   ("19991012-PIX (53)"
+    ((2)
+     (2 2)
+     (6 7)
+     (3 1 1 4)
+     (4 1 3)
+     (11 3)
+     (1 6 2)
+     (2 2 3)
+     (2 2 2)
+     (2 2 2)
+     (1 1 1)
+     (2 2 2)
+     (15)
+     (15)
+     (15))
+    ((2 4 3)
+     (5 1 3)
+     (5 3)
+     (5 3)
+     (1 5 4)
+     (2 10)
+     (2 3)
+     (2 3)
+     (2 1 3)
+     (1 1 4)
+     (1 2 7)
+     (4 3 3)
+     (8 3)
+     (8 4)
+     (4 7)))
+   ("19991112-SHE (54)"
+    ((9)
+     (1 1)
+     (1 1)
+     (1 1)
+     (1 1)
+     (1 1)
+     (1 1)
+     (9)
+     (11)
+     (7 1)
+     (11)
+     (1)
+     (9)
+     (2 2 2 2)
+     (13))
+    (()
+     (1)
+     (3 2)
+     (11 3)
+     (1 4 1 1)
+     (1 4 3)
+     (1 4 3)
+     (1 4 1 1)
+     (1 4 3)
+     (1 2 1 3)
+     (1 2 3 1)
+     (9 1 3)
+     (3 2)
+     (1)
+     ()))))
+ ("Kajitani 15x20"
+  "k15x20"
+  (("19990127aLLO (1)"
+    ((6 2)
+     (1 1 6)
+     (1 1 2 2)
+     (2 2 1 1)
+     (1 2 1)
+     (6 1 4 1)
+     (1 1 1 1 1)
+     (1 1 1 1)
+     (3 1 1 1 1 1)
+     (1 1 1 1)
+     (5 1 1 1 1)
+     (1 1 1 1 1 1)
+     (3 1 1 1 1)
+     (1 1 1 1)
+     (1 1 1 1 1 1)
+     (6 1 1 1)
+     (1 1 1 1 1)
+     (1 2 2 1)
+     (5 4 1)
+     (1 1 2 1))
+    ((4 2 1 1 3 2)
+     (1 1 1 1 1 1 1)
+     (1 1 1 3 1 1)
+     (1 1 1 1 1 3)
+     (1 1 1 1 3 1 1)
+     (4 1 3)
+     ()
+     (16)
+     (2 2)
+     (1 10 2)
+     (2 2 2)
+     (2 2 2)
+     (1 13)
+     (2)
+     (18)))
+   ("19990127bLLO (2)"
+    ((3)
+     (5)
+     (7)
+     (1 7)
+     (2 4)
+     (7)
+     (5)
+     (5)
+     (5)
+     (8)
+     (6 2)
+     (2 3 1 1)
+     (2 2 2)
+     (8)
+     (5)
+     (5)
+     (5)
+     (7)
+     (7)
+     (5))
+    ((1)
+     (3)
+     (2 2)
+     (2 3 1)
+     (1 2 3 1 2)
+     (3 15)
+     (4 6 8)
+     (4 5 1 7)
+     (11 8)
+     (19)
+     (4 2)
+     (2)
+     ()
+     ()
+     ()))
+   ("19990421bMIJ (3)"
+    (()
+     (1 1 1)
+     (2 2)
+     (1 1 1)
+     (2 1)
+     (1 1)
+     (1 1)
+     (1)
+     (1)
+     (1 1 1 1)
+     (3 1 3)
+     (3 4)
+     (1 3)
+     (1 2)
+     (1 1 1)
+     (2 1 1)
+     (2 1)
+     (1 1)
+     (15)
+     (15))
+    ((2)
+     (1 2)
+     (3 1 2)
+     (10)
+     (3 1 2)
+     (5 1 2)
+     (1 1 1 2)
+     (1 1 13)
+     (1 1 3 2)
+     (5 3 2)
+     (2 2)
+     (2 2)
+     (2)
+     (2)
+     (2)))))
+ ("Kajitani 15x25"
+  "k15x25"
+  (("19990804aVAC (1)"
+    ((3)
+     (4)
+     (4 4)
+     (7 3)
+     (7 3)
+     (2 2 2)
+     (1 2)
+     (4 2)
+     (7)
+     (8)
+     (2 1 3)
+     (1 2)
+     (2 2)
+     (2 2)
+     (1 1 1 2)
+     (1 1 1 2)
+     (1 1 1 1 2)
+     (6 2 1)
+     (1 1 1 4)
+     (1 3 1 4)
+     (1 1 3 1)
+     (1 6 2)
+     (1 4 2)
+     (1 2 2)
+     (1 2))
+    ((2 5)
+     (3 1 1)
+     (4 6 1 1)
+     (3 4 3 1 1)
+     (3 2 1 1 2 1)
+     (4 2 6 3)
+     (7 3)
+     (4 3 1)
+     (3 3 3 1)
+     (2 3 1 1)
+     (3 3 2)
+     (5 14 2)
+     (7 10 1)
+     (4 3)
+     (3)))))
+ ("Kajitani 20x15"
+  "k20x15"
+  (("19990524-KHO (1)"
+    ((1)
+     (2 2 1)
+     (1 1 2)
+     (3 1)
+     (5 2)
+     (3 3 1)
+     (8 1)
+     (19)
+     (1 14)
+     (1 13)
+     (13)
+     (2 1 1 3 3)
+     (4 1 1 2 2)
+     (4 1 1 1 1)
+     (2 1 1 2 2))
+    ((2)
+     (3 1 4)
+     (1 4 4)
+     (1 4 2)
+     (3 2)
+     (6 1)
+     (12)
+     (1 7 1)
+     (1 8)
+     (4)
+     (4)
+     (4)
+     (5)
+     (6 1)
+     (8)
+     (4)
+     (6 1)
+     (3 8)
+     (3 5)
+     (4)))))
+ ("Kajitani 20x20"
+  "k20x20"
+  (("19980407-KVL (1)"
+    ((10 8)
+     (9 6)
+     (5 5 5)
+     (6 7 4)
+     (6 9 3)
+     (4 2 2 1 1 3)
+     (5 3 2 1 1 3)
+     (5 2 2 1 2 2)
+     (4 2 2 1 2 2)
+     (5 3 7 2)
+     (5 1 2 1 3)
+     (2 1 1 7 3)
+     (3 1 6 4)
+     (3 1 8 3)
+     (2 6 5 2)
+     (3 4 3 2)
+     ()
+     (2 3 3 3 3 1)
+     (2 3 3 3 3 1)
+     ())
+    ((16 2)
+     (16 2)
+     (11 2 1)
+     (12 1 2)
+     (5 2 2 2 2)
+     (2 2 5 2)
+     (2 5 2)
+     (2 6 2 2)
+     (2 4 2 2 2)
+     (1 3 4 2)
+     (8 3)
+     (8 4 2)
+     (1 3 1 5 2)
+     (1 14 2)
+     (2 2 1 5)
+     (3 6 1 2 2)
+     (4 3 1 2)
+     (7 4 2)
+     (16)
+     (16 2)))
+   ("19980501aGOS (2)"
+    ((7 7)
+     (5 5)
+     (3 3)
+     (2 2)
+     (2 2)
+     (1 2 2 1)
+     (1 4 4 1)
+     (2 1 2 1)
+     (2 2)
+     ()
+     (2 2)
+     (4 4)
+     (1 1 4 1 1)
+     (1 2 1 1 2 1)
+     (1 3 3 1)
+     (2 4 2)
+     (2 2)
+     (3 3)
+     (5 5)
+     (7 7))
+    ((7 7)
+     (5 5)
+     (3 3)
+     (2 1 2)
+     (2 3 2)
+     (1 2 1 1 1)
+     (1 4 4 1)
+     (2 1 1 1)
+     (2 4)
+     (1 1)
+     (1 1)
+     (2 4)
+     (4 1 1)
+     (1 2 1 4 1)
+     (1 2 1 1 1)
+     (2 3 2)
+     (2 1 2)
+     (3 3)
+     (5 5)
+     (7 7)))
+   ("19980608-JEN (3)"
+    ((3 2 2 1)
+     (1 2 2 2)
+     (1 1)
+     (1 1)
+     (1 2 1)
+     (1 2 1 3)
+     (1 1 3 1 1)
+     (1 1 2 1 1)
+     (1 2 2 3)
+     (1 1 1)
+     (1 1 3)
+     (2 1 3)
+     (5 1 3)
+     (1 5 1 3)
+     (3 4 4)
+     (4 1 4)
+     (5 6)
+     (7)
+     (5)
+     (4))
+    ((15)
+     (1 2 1)
+     (2 2 1 2)
+     (1 1 1 1 1)
+     (1 1 1 2 1)
+     (1 1 1 2)
+     (1 1 1 1)
+     (1 3 1 1)
+     (1 1 2 2 1)
+     (1 1 1 1 2)
+     (1 3 1 3)
+     (6 12)
+     (1 1 4)
+     (3 5)
+     (5)
+     (8)
+     (8)
+     (5)
+     ()
+     ()))
+   ("19980907-KEV (4)"
+    (()
+     (7 2 3)
+     (8 2 4)
+     (2 2 4 1 1)
+     (2 2 4 4)
+     (2 2 1 1 3)
+     (2 2 4 1 2)
+     (5 2 1 1 1 2)
+     (4 5 3 2)
+     ()
+     ()
+     (1 1 2 3 2)
+     (1 1 2 4 3)
+     (1 1 4 1 1 2)
+     (1 1 4 4 2)
+     (1 1 1 1 1 3 2)
+     (1 1 1 4 1 2 2)
+     (5 1 1 1 6)
+     (3 2 3 5)
+     ())
+    ((2 7)
+     (2 2 2)
+     (4 2 4)
+     (2 4 2)
+     (2 2 7)
+     (2 1)
+     (8 6)
+     (8 4 1)
+     (2 1 4 1)
+     (2 1 6)
+     (6 1)
+     (4 1 8)
+     (4 1 2 2)
+     (6 2 3)
+     (1 3 3)
+     (8 2)
+     (2 2 2 2)
+     (2 3 4 2)
+     (3 3 2 4)
+     (2 2 2)))
+   ("19990126aLLO (5)"
+    ((1 1 1)
+     (2 1 2)
+     (1 2 1)
+     (1 1 1)
+     (2 2 2)
+     (1 1 1)
+     (1 1 1)
+     (2 2 2)
+     (1 1 1)
+     ()
+     (11)
+     (2 2 3)
+     (2 4 1)
+     (4 5 1)
+     (17 1)
+     (15 3)
+     (13)
+     (11)
+     (2 7 2)
+     (17))
+    ((1)
+     (4 2)
+     (6 1)
+     (2 2 5 1)
+     (4 2 1 5 1)
+     (4 1 6)
+     (1 6)
+     (3 1 6)
+     (3 2 1 6)
+     (4 1 6)
+     (1 6)
+     (2 4 1 6)
+     (4 2 1 5 1)
+     (2 5 1)
+     (6 1)
+     (4 1)
+     (3 1)
+     (2 2 2)
+     (1 1 1)
+     (5)))
+   ("19990211aJAM (6)"
+    (()
+     (4 4)
+     (2 3 3 2)
+     (1 2 2)
+     (2 1 1 2)
+     (2 2)
+     (2)
+     (4)
+     (4)
+     (4)
+     (6)
+     (6)
+     (2)
+     ()
+     (9)
+     (11)
+     (3 3)
+     (2 5 3)
+     (2 3 3)
+     ())
+    (()
+     (2)
+     (2 1)
+     (1 2)
+     (1 2 2)
+     (2 2 2)
+     (1 3)
+     (2 2 2)
+     (2 5 2 1)
+     (7 2 2)
+     (7 2 2)
+     (2 5 2 2)
+     (2 2 2 1)
+     (1 2)
+     (2 3)
+     (1 2 3)
+     (1 2 3)
+     (2 2)
+     (1 1)
+     ()))
+   ("19990214bFRA (7)"
+    ((20)
+     (1 3 3 2)
+     (3 4 1 1)
+     (3 4 1)
+     (3 4 1)
+     (3 5 2)
+     (3 6 3)
+     (3 7 4)
+     (3 8 5)
+     (1 7 6)
+     (20)
+     (20)
+     (1 4 3 5 3)
+     (1 3 3 3 3)
+     (1 2 4 1 4)
+     (1 1 1 5 5)
+     (1 2 6 6)
+     (1 3 6 6)
+     (1 4 6 6)
+     (20))
+    ((20)
+     (1 7 2 1)
+     (1 7 3 5)
+     (1 4 4)
+     (1 7 5 3)
+     (1 7 6 2)
+     (12 1)
+     (20)
+     (2 15)
+     (1 14)
+     (1 5 6)
+     (1 5 5)
+     (2 5 4)
+     (3 5 1)
+     (2 5 4)
+     (1 5 5)
+     (1 5 6)
+     (1 14)
+     (2 15)
+     (20)))
+   ("19990306-RMA (8)"
+    ((1)
+     (8)
+     (6 1 2)
+     (5 2 2)
+     (5 2 2)
+     (5 3 3)
+     (5 4 3)
+     (2 1 1 5 1 3)
+     (2 1 2 5)
+     (1 1 1)
+     (1)
+     (1)
+     (1)
+     (1)
+     (1)
+     (1)
+     (1)
+     (1)
+     (1 1)
+     (3))
+    ((1)
+     (3)
+     (3)
+     (5)
+     (5)
+     (5)
+     (4 1 2)
+     (3 1 1)
+     (2 2 1)
+     (2 3 6)
+     (1 10)
+     (8)
+     (1 3)
+     (2 1)
+     (2 1)
+     (3 1)
+     (6)
+     (4)
+     (3)
+     (2)))
+   ("19990412-RAB (9)"
+    (()
+     (9)
+     (1 1 1 1 3)
+     (9 2)
+     (1 3 1)
+     (2 1 1 1 3)
+     (2 1 1 1 2)
+     (1 1 3)
+     (9 3)
+     (1 1 1 4 9)
+     (12 1 1 1 1)
+     (1 12)
+     (3 1 1)
+     (2 1 1 1 1 2)
+     (2 1 1 2 1 2)
+     (2 1 1)
+     (14)
+     (2 1 1 1 1 1 1)
+     (12)
+     ())
+    ((3 3)
+     (1 1 2 1 1)
+     (3 2 3)
+     (1 1 1 1)
+     (10)
+     (1 1 1 1 4)
+     (3 2 10)
+     (1 1 3 1 2)
+     (11 2 1 1)
+     (1 1 3 3)
+     (4 2 7 1)
+     (1 7 3)
+     (6 1 2 1 1)
+     (3 1 3)
+     (1 1 1 1)
+     (10)
+     (1 1 1 1)
+     (3 2 3)
+     (1 1 2 1 1)
+     (3 3)))
+   ("19990806-ELS (10)"
+    (()
+     (1 1)
+     (2 2)
+     (3 3)
+     (4 4)
+     (4 4)
+     (4 4)
+     (4 4)
+     (4 4)
+     (3 3)
+     (5)
+     (3)
+     (5)
+     (11)
+     (2 1 1 2)
+     (2 1 1 2)
+     (1 2 2 1)
+     (1 2 2 1)
+     (4 4)
+     ())
+    (()
+     (4)
+     (4 4)
+     (4 2 1)
+     (4 2 1)
+     (4 1 2)
+     (4 1 2)
+     (4 5)
+     (6)
+     (4)
+     (6)
+     (4 5)
+     (4 1 2)
+     (4 1 2)
+     (4 2 1)
+     (4 2 1)
+     (4 4)
+     (4)
+     ()
+     ()))
+   ("19990929-LSA (11)"
+    ((4 3)
+     (3 5 2)
+     (2 9 1)
+     (1 11)
+     (1 13)
+     (1 2 1)
+     (8 5)
+     (9 5)
+     (3 3 1 1)
+     (4 4 2 2)
+     (9 5)
+     (9 5)
+     (5 2 4)
+     (6 5)
+     (13)
+     (4 4)
+     (1 4 4 1)
+     (2 8 1)
+     (3 5 3)
+     (5 7))
+    ((5)
+     (3)
+     (2)
+     (1 5)
+     (11 4)
+     (2 10 3)
+     (3 2 8 2)
+     (3 2 8 1)
+     (4 2 9 1)
+     (4 6 2 3)
+     (12 1 2)
+     (12 1 2)
+     (4 2 3)
+     (3 14)
+     (3 2 9 1)
+     (2 2 7 2)
+     (4 7 2)
+     (1 6 4)
+     (2 1)
+     (3 1)))
+   ("19991002aTPV (12)"
+    (()
+     ()
+     (6)
+     (2 2 3)
+     (1 1 1 3 1)
+     (1 2 1)
+     (2 3 1)
+     (3 4 1)
+     (3 3 1)
+     (4 3 4 1)
+     (5 9)
+     (6 7)
+     (7 4)
+     (6 3)
+     (7 4)
+     (7 3)
+     (6 3)
+     (6)
+     ()
+     ())
+    (()
+     ()
+     (6)
+     (10)
+     (1 10)
+     (1 8)
+     (2 7)
+     (1 7)
+     (1 1 6)
+     (3 2 4)
+     (2 2 3)
+     (1 1 1 2 1)
+     (10 2)
+     (9 3)
+     (1 11)
+     (1 7)
+     (2 5)
+     (6)
+     ()
+     ()))
+   ("19991119bKHO (13)"
+    ((4 4)
+     (3 2 1 1 1 1 1 3)
+     (2 2 1 1 1 1 2)
+     (2 1 1 1 1 1 1 2 2)
+     (1 1 1 1 1 1 1 1 1 2)
+     (1 1 1 1 1 2 1 2)
+     (1 1 1 1 1 1 1 2 2)
+     (2 13 3)
+     (3 4)
+     (3 4)
+     (3 4)
+     (3 4)
+     (3 4)
+     (4 5)
+     (4 5)
+     (5 6)
+     (6 7)
+     (8 9)
+     (9 10)
+     (20))
+    ((20)
+     (4 13)
+     (2 1 1 12)
+     (1 2 1 1 7)
+     (2 1 2 5)
+     (1 1 1 4)
+     (1 1 2 3)
+     (1 1 1 1 3)
+     (1 2 2)
+     (1 1 1 1 1)
+     (1 1 2 2)
+     (1 1 1 1 3)
+     (1 2 3)
+     (1 1 1 1 4)
+     (1 2 1 5)
+     (1 1 2 7)
+     (1 5 12)
+     (2 13)
+     (20)
+     (20)))))
+ ("Kajitani 20x25"
+  "k20x25"
+  (("19980620-KKA (1)"
+    (()
+     (1)
+     (3)
+     ()
+     ()
+     ()
+     ()
+     (1)
+     (2)
+     (1)
+     (2)
+     (2)
+     (2 1 1)
+     (2 3 2)
+     (1 2 4 1 1)
+     (1 2 1 1 2 1)
+     (1 1 2 2 1 1 2)
+     (1 4 1 4 4)
+     (20)
+     ()
+     (11 1 3 1)
+     (1 1 1 1 1 1 1 1)
+     (1 3 1 2 1 3 1)
+     (1 1 1 1 1 1 1)
+     (1 3 1 1 1 1 3 1))
+    ((1 1)
+     (5 5)
+     (1 1)
+     (5 5)
+     (1 2 2 1 1 1)
+     (2 2 1 1 1)
+     (6 1)
+     (1 1 1 1 5)
+     (2 2 1 1 1)
+     (1 4 2 3 5)
+     (4 2 1 1 1)
+     (1 2 1 2)
+     (3)
+     (3 2 5)
+     (2 4)
+     (1 3 1)
+     (5 1 1 1)
+     (3 1 3)
+     (2)
+     (2 3 1)))
+   ("19991113cBAR (2)"
+    ((3 1 2 1)
+     (2 3 2 3 2)
+     (17 1)
+     (19)
+     (19)
+     (12 7)
+     (8 2 1 5)
+     (4 1 5)
+     (3 4)
+     (6 7)
+     (2 3 3 4)
+     (3 2 2 4)
+     (4 5)
+     (4 6)
+     (5 3 6)
+     (4 5 6)
+     (5 1 6)
+     (4 5 5)
+     (4 3 3 3)
+     (2 3)
+     (5 6)
+     (8 7)
+     (17)
+     (13 1)
+     (1 2 3 3))
+    ((1 5 4 3 1)
+     (21)
+     (23)
+     (7 1 7 5)
+     (5 1 3 4)
+     (7 2 1 4)
+     (8 2 1 4)
+     (7 2 1 2 3)
+     (4 2 1 4)
+     (7 4 3)
+     (6 2 1 3)
+     (4 2 1 2 3)
+     (5 2 1 4)
+     (7 2 1 5)
+     (5 1 4 5)
+     (8 7 3)
+     (24)
+     (22)
+     (18)
+     (1 4 2 6)))
+   ("19991113gBAR (3)"
+    (()
+     ()
+     (4 4)
+     (8 6)
+     (14 3)
+     (3 7 2)
+     (3 5 2)
+     (6 2)
+     (6 2)
+     (6 3)
+     (6 4)
+     (8 4)
+     (14)
+     (14)
+     (10 3)
+     (14)
+     (16)
+     (18)
+     (3 14)
+     (3 14)
+     (4 13)
+     (4 11)
+     (3 9)
+     (12)
+     (10))
+    ((2 4)
+     (3 6)
+     (3 9)
+     (4 5 4)
+     (4 8 4)
+     (4 10 2)
+     (2 16 2)
+     (3 18)
+     (21)
+     (21)
+     (21)
+     (21)
+     (3 3 10)
+     (3 13)
+     (3 12)
+     (2 12)
+     (2 4 6)
+     (3 4 4)
+     (9)
+     (7)))
+   ("19991115cBAR (4)"
+    ((8 9)
+     (8 8)
+     (4 2 5 1)
+     (4 2 3 1)
+     (4 2 2 1)
+     (1 2 1 1 2)
+     (1 3 1 3)
+     (1 1 3)
+     (1 1 3 2 1)
+     (2 5 1 1)
+     (4 2 4 1)
+     (2 2 4 2 2)
+     (1 1 5 3)
+     (4 2 5)
+     (2 4 4)
+     (1 2 5 2)
+     (4 3 1)
+     (2 1 1 1)
+     (1 2 2 1)
+     (1 2 1 2 1)
+     (2 1 1 4)
+     (5 1 4)
+     (4 2 4)
+     (4 4 5)
+     (5 7 5))
+    ((13 10)
+     (5 3 2 5)
+     (5 1 1 4)
+     (6 1 1 4)
+     (2 2 1 1 2 1)
+     (2 1 1 1 1)
+     (3 2 1 1)
+     (4 1 5 1 1)
+     (2 3 3 2 2)
+     (2 2 3 2 2)
+     (9 3)
+     (1 3 1 3 7)
+     (3 7 2 1)
+     (7 5)
+     (5)
+     (4 2 1 2 2)
+     (3 1 2 6)
+     (2 2 3 5)
+     (2 3 5 5)
+     (18 6)))))
+ ("Kajitani 20x30"
+  "k20x30"
+  (("19991007aKHO (1)"
+    ((1 1 1 1 1)
+     (1 5 1)
+     (8 2)
+     (8)
+     (8)
+     (2 2)
+     (1 1)
+     (2 2)
+     (1 6 1)
+     (2 8 2)
+     (1 1)
+     (1 2 2 1)
+     (1 1 1 1 1 1)
+     (1 4 4 1)
+     (3 4 4 3)
+     (1 1 1 1 1 1 1 1)
+     (1 1 2 2 2 1 1)
+     (2 1 4 1 2)
+     (3 4 3)
+     (1 4 1)
+     (1 2 1)
+     (2 2)
+     (14)
+     (2 2)
+     (1 2 4 2 1)
+     (1 6 1)
+     (1 1)
+     (14)
+     (5 5)
+     (7 7))
+    ((3)
+     (1 2 1)
+     (1 1 2)
+     (21)
+     (1 3 3 3)
+     (2 3 4 1 1 3)
+     (4 1 1 2 1 1 1 3)
+     (1 3 2 1 2 1 1 1 1 1)
+     (4 2 4 3 1 2 1)
+     (5 2 5 1 2 1)
+     (4 2 5 1 2 1)
+     (5 2 4 3 1 2 1)
+     (4 2 1 2 1 1 1 1 1)
+     (1 3 1 1 2 1 1 1 3)
+     (1 3 4 1 1 3)
+     (2 3 3 3)
+     (21)
+     (1 1 2)
+     (1 2 1)
+     (3)))
+   ("19991007bKHO (2)"
+    ((20)
+     (1 1)
+     (1 16 1)
+     (1 16 1)
+     (1 2 2 1)
+     (1 2 2 1)
+     (1 5 2 1)
+     (1 2 6 1)
+     (1 2 1 1 2 1)
+     (1 2 3 2 1)
+     (1 2 1 1 2 1)
+     (1 3 1 1 1 1 1 2 1)
+     (1 2 1 1 1 1 1 3 1)
+     (1 16 1)
+     (1 16 1)
+     (1 1)
+     (1 6 1)
+     (1 2 1)
+     (1 2 4 1)
+     (1 2 2 4 1)
+     (1 6 4 2 1)
+     (1 6 4 1)
+     (1 2 2 1)
+     (1 2 1)
+     (1 1 1 1)
+     (1 1 1 1 1)
+     (1 2 2 1 1 1)
+     (1 1 1 1 1)
+     (1 1 1 1)
+     (20))
+    ((30)
+     (1 1)
+     (1 13 2 1)
+     (1 13 2 1)
+     (1 2 1 1 2 6 1)
+     (1 2 1 3 6 1)
+     (1 2 1 1 1 2 2 1 1)
+     (1 2 1 3 1 2 1 1)
+     (1 2 4 2 1 1)
+     (1 2 1 3 1 1 1)
+     (1 2 2 2 1 2 1 1)
+     (1 2 3 1 4 1)
+     (1 2 1 1 2 1 4 1)
+     (1 2 1 3 2 1 1 1)
+     (1 2 1 1 2 2 1 1 2)
+     (1 2 1 3 4 1 1 1)
+     (1 13 4 1 1 2)
+     (1 13 2 1 1 1)
+     (1 1)
+     (30)))
+   ("19991113bBAR (3)"
+    ((6)
+     (8)
+     (10)
+     (3 8)
+     (1 2 1)
+     (12)
+     (1 1 1 3)
+     (1 6 1)
+     (1 2)
+     (1 4 1)
+     (3 2 4)
+     (5 6)
+     (7 8)
+     (19)
+     (4 10 3)
+     (4 11 3)
+     (17 1)
+     (2 14 1)
+     (1 2 1 1 1 1)
+     (3 15)
+     (14)
+     (14)
+     (13)
+     (11)
+     (4 5)
+     (1 1 2 1)
+     (4 4)
+     (5 5)
+     (6 6)
+     (6 6))
+    ((5)
+     (5 1)
+     (5 1)
+     (3 6 1)
+     (1 1 5 6)
+     (4 7 3 4 2)
+     (2 3 8 5 3)
+     (4 1 1 7 11)
+     (4 3 1 6 6 4)
+     (4 1 1 2 5 6 4)
+     (4 1 1 2 17)
+     (4 3 1 5 5)
+     (4 1 1 14)
+     (3 2 7 11)
+     (5 10 6 4)
+     (3 8 6 4)
+     (4 2 11)
+     (6 6 3)
+     (5 1 2)
+     (7)))))
+ ("Kajitani 25x15"
+  "k25x15"
+  (("19990709-DAH (1)"
+    ((25)
+     (1 1)
+     (1 3 1)
+     (1 3 1 3 1)
+     (1 3 1 1 1 1)
+     (1 1 1 1 1 1)
+     (1 1 1 1 1 1)
+     (1 1 1 3 1 1)
+     (1 1 3 4 3 1)
+     (1 3 4 4 4 1)
+     (1 4 4 2 4 1)
+     (1 4 2 2 1)
+     (1 2 1)
+     (1 1)
+     (25))
+    ((15)
+     (1 1)
+     (1 2 1)
+     (1 4 1)
+     (1 4 1)
+     (1 8 1)
+     (1 1 1)
+     (1 1 2 1)
+     (1 1 4 1)
+     (1 1 4 1)
+     (1 8 1)
+     (1 1)
+     (1 1)
+     (1 2 1)
+     (1 4 1)
+     (1 4 1)
+     (1 8 1)
+     (1 1 1)
+     (1 1 2 1)
+     (1 1 4 1)
+     (1 1 4 1)
+     (1 8 1)
+     (1 1)
+     (1 1)
+     (15)))))
+ ("Kajitani 25x20"
+  "k25x20"
+  (("19980410-GOS (1)"
+    (()
+     (9)
+     (3 1 4 3)
+     (4 2 1 3 4)
+     (2 1 11 4)
+     (4 2 3 2 1 1)
+     (1 1 2 1 3 1 2 1 1)
+     (2 1 2 3 2 5)
+     (5 5 5 1 1)
+     (3 1 4 3 2 1 1 1)
+     (5 4 3 4 5)
+     (1 4 1 4 2)
+     (1 1 2 1 1 1 2 2 1)
+     (2 1 2 3 3 2 4)
+     (3 3 1 1 1 3 3)
+     (3 1 1 1 3)
+     (2 3 2)
+     (2 2)
+     (7)
+     ())
+    ((7)
+     (6 2)
+     (2 3 1)
+     (3 1 5)
+     (1 7)
+     (3 4)
+     (2 11)
+     (1 7 3)
+     (1 2 3 1 3)
+     (4 1 3 1 2)
+     (1 1 1 3 1)
+     (1 4 2 1 1 1)
+     (7 4 3 1)
+     (2 4 2 1 1 1)
+     (4 1 3 1)
+     (4 1 3 1 2)
+     (1 2 3 1 3)
+     (1 5 1 3)
+     (2 11)
+     (3 4)
+     (9)
+     (2 1 5)
+     (1 1 1 3)
+     (3 2 2)
+     (7)))
+   ("19981116-JAM (2)"
+    ((10)
+     (17)
+     (4 9 3)
+     (4 2 7 2 3)
+     (3 4 5 3 4)
+     (3 4 5 3 4)
+     (4 4 5 3 4)
+     (4 2 5 2 5)
+     (5 6 6)
+     (6 4 2 7)
+     (12 11)
+     (11 10)
+     (10 9)
+     (5 6 5 5)
+     (5 13 4)
+     (4 15 3)
+     (1 1 13 1 1)
+     (5 11 5)
+     (5 5)
+     (8 7))
+    ((10)
+     (15)
+     (14 2)
+     (14 3)
+     (3 7 4)
+     (2 3 4 1 3)
+     (1 4 7 2)
+     (1 5 8 1)
+     (3 4 9 1)
+     (4 10 1)
+     (12 5 1)
+     (11 5)
+     (9 4)
+     (9 4 1)
+     (11 5 1)
+     (4 3 5 1)
+     (3 3 8 1)
+     (2 5 8 1)
+     (1 5 8 2)
+     (2 5 1 3)
+     (14 3)
+     (14 2)
+     (13 2)
+     (14)
+     (7)))
+   ("19981119-MSS (3)"
+    ((3 1 3 1 1 1 1 1)
+     (1 1 1 1 1 2 1 1 1 1)
+     (1 1 1 3 1 2 1 1)
+     (1 1 1 1 1 1 1 1 2)
+     ()
+     (3)
+     (2 3)
+     (2 2 3)
+     (1 2 2 3)
+     (1 2 2 3)
+     (4 3 1 2)
+     (1)
+     (8 1)
+     (16)
+     (25)
+     (24)
+     (21)
+     (16)
+     (11)
+     (4))
+    ((1 1 4)
+     (4 1 4)
+     (1 1 4)
+     (3 5)
+     (4 5)
+     (4 5)
+     (1 4 5)
+     (4 1 6)
+     (1 4 5)
+     (4 5)
+     (3 1 5)
+     (1 1 5 5)
+     (3 5 6)
+     (5 6)
+     (4 1 6)
+     (1 9)
+     (1 5)
+     (4 5)
+     (6)
+     (4 6)
+     (6)
+     (2 6)
+     (1 1 5)
+     (1 1 3)
+     (1)))
+   ("19990126bLLO (4)"
+    ((2 2 1)
+     (3 7)
+     (6 2 2 5)
+     (6 4 4 2)
+     (4 4 1)
+     (3 2 2 1)
+     (2 3 2)
+     (1 2 3)
+     (1 3 2)
+     (3 2 3)
+     (5 1 3)
+     (7 2)
+     (7 2)
+     (7 2)
+     (5 2)
+     (25)
+     (3)
+     (20 3)
+     (3)
+     (18 2))
+    ((1 1 1)
+     (1 1 1 1)
+     (2 1 1 1)
+     (3 1 1 1)
+     (3 3 1 1 1)
+     (2 6 1 1)
+     (2 7 1 1)
+     (1 7 1 1)
+     (1 7 1 1)
+     (6 1 1)
+     (3 3 1 1 1)
+     (2 1 1 1)
+     (2 1 1 1)
+     (3 1 1 1)
+     (3 1 1 1)
+     (3 3 1 1 1)
+     (1 1 4 1 1 1)
+     (3 5 1 1 1)
+     (7 1 1)
+     (1 2 1 1)
+     (8 1)
+     (4 6 5)
+     (2 13)
+     (1 2 10)
+     (4 1)))))
+ ("Kajitani 25x25"
+  "k25x25"
+  (("19980522-SDN (1)"
+    ((1 1)
+     (1 1 1)
+     (1 1 3)
+     (3 3)
+     (1 1 3)
+     (1 1 5)
+     (5)
+     (7)
+     (7)
+     (9)
+     (11)
+     (15)
+     (17)
+     (19)
+     (19)
+     (19)
+     (17)
+     (15)
+     (11)
+     (7 1)
+     (1 1 1)
+     (3 1 1)
+     (5 3)
+     (9 1 1)
+     (9 1 1))
+    (()
+     (5)
+     (1 1)
+     (5 3)
+     (5)
+     (7)
+     (7)
+     (9)
+     (10 2)
+     (13 2)
+     (15 3)
+     (18 4)
+     (25)
+     (18 4)
+     (15 3)
+     (13 2)
+     (10 2)
+     (9)
+     (7)
+     (7)
+     (5)
+     (3)
+     (5)
+     (1 1)
+     (5)))
+   ("19980909-YEN (2)"
+    ((10 10)
+     (8 5 8)
+     (5 9 5)
+     (4 7 4 4)
+     (3 7 4 3)
+     (2 7 3 2)
+     (2 8 4 2)
+     (2 9 5 2)
+     (1 16 1)
+     (1 15 1)
+     (14)
+     (12)
+     (11)
+     (9)
+     (7)
+     (1 5 1)
+     (1 4 1)
+     (2 3 1 2)
+     (2 3 3 2)
+     (2 3 5 2)
+     (3 2 3 3)
+     (4 2 1 4)
+     (5 5)
+     (8 8)
+     (10 10))
+    ((10 10)
+     (8 5 8)
+     (5 9 5)
+     (4 15 4)
+     (3 17 3)
+     (2 19 2)
+     (2 13 1 2)
+     (2 12 2)
+     (1 12 1)
+     (1 12 1)
+     (4 7 1)
+     (3 6 3)
+     (2 4 5)
+     (3 4 3)
+     (4 5 1)
+     (1 8 1)
+     (1 8 1)
+     (2 5 2)
+     (2 2)
+     (2 2)
+     (3 3)
+     (4 4)
+     (5 5)
+     (8 8)
+     (10 10)))
+   ("19990924-VAL (3)"
+    (()
+     ()
+     (1)
+     (1)
+     (1)
+     (10)
+     (12)
+     (6 3 3)
+     (3 2 1 1 1 2)
+     (2 1 1 1 1 2 1)
+     (1 3 3 4)
+     (6 7)
+     (7 2 4)
+     (2 7 2 1)
+     (2 10 1)
+     (6 8)
+     (5 7)
+     (2 7 2)
+     (1 7 1)
+     (11)
+     (4 4)
+     (4 4)
+     (2 6)
+     (1 5)
+     (5))
+    (()
+     ()
+     ()
+     ()
+     ()
+     (3 4)
+     (3 7)
+     (3 3 5)
+     (3 8 4)
+     (4 14)
+     (5 11 1)
+     (3 5 8)
+     (4 3 7 3)
+     (1 3 15)
+     (5 14)
+     (3 2 10)
+     (2 9 4)
+     (3 11)
+     (3 3 3)
+     (3 5)
+     ()
+     ()
+     ()
+     ()
+     ()))
+   ("19991020aSHE (4)"
+    ((20 2)
+     (3 14 2)
+     (2 11 2)
+     (1 9 3)
+     (2 9 3)
+     (3 9 4)
+     (12 4)
+     (8 5)
+     (7 6)
+     (6 7)
+     (5 8)
+     (5 9)
+     (7 9)
+     (7 6)
+     (7 4)
+     (3 2 3)
+     (2 4 3)
+     (3 3 3)
+     (1 6)
+     (2 6)
+     (1 6)
+     (2 1 6)
+     (2 1 8)
+     (1 11)
+     (13))
+    ((25)
+     (3 14 1 2 1)
+     (2 11 1 2)
+     (1 9 3)
+     (2 10 2)
+     (3 6 3 3)
+     (9 4 4)
+     (8 2 3)
+     (7 2 5)
+     (7 9)
+     (7 9)
+     (7 7)
+     (6 7)
+     (5 5)
+     (4 4)
+     (3 3)
+     (2 6)
+     (2 6)
+     (1 6)
+     (1 7)
+     (7)
+     (9)
+     (10)
+     (13)
+     (13)))))
+ ("Kajitani 25x30"
+  "k25x30"
+  (("19980714-GAS (1)"
+    (()
+     (3)
+     (4)
+     (4)
+     (5)
+     (4)
+     (3)
+     (4 2 4)
+     (8 8)
+     (20)
+     (21)
+     (20)
+     (20)
+     (20)
+     (19)
+     (19)
+     (19)
+     (19)
+     (20)
+     (21)
+     (21)
+     (22)
+     (22)
+     (20)
+     (18)
+     (16)
+     (14)
+     (3 3)
+     ()
+     ())
+    (()
+     (8)
+     (13)
+     (15)
+     (17)
+     (18)
+     (20)
+     (21)
+     (21)
+     (21)
+     (19)
+     (19)
+     (4 18)
+     (5 18)
+     (5 19)
+     (5 19)
+     (4 21)
+     (2 21)
+     (21)
+     (20)
+     (6 8)
+     (4 6)
+     (2 4)
+     (2)
+     ()))
+   ("19980716cGAS (2)"
+    (()
+     (7)
+     (3 3)
+     (2 3 2)
+     (2 3 3 2)
+     (1 2 2 1)
+     (1 2 2 1)
+     (1 1 1 1)
+     (1 1 1 1)
+     (1 1 7 1 1)
+     (1 2 2 1)
+     (3 3)
+     (2 2)
+     (2 5 2)
+     (1 4 4 1)
+     (2 5 5 2)
+     (1 2 7 2 1)
+     (1 3 5 3 1)
+     (1 6 6 1)
+     (1 5 5 1)
+     (1 1 2 2 1 1)
+     (1 5 5 1)
+     (1 6 6 1)
+     (2 3 5 3 2)
+     (1 2 7 2 1)
+     (2 5 5 2)
+     (2 4 4 2)
+     (2 5 2)
+     (3 3)
+     (9))
+    (()
+     ()
+     (9)
+     (3 3)
+     (2 2)
+     (9 5 2)
+     (2 1 4 4 2)
+     (2 6 5 5 1)
+     (1 2 1 2 7 2 2)
+     (2 2 1 3 5 3 1)
+     (1 1 1 6 6 1)
+     (1 2 1 5 5 1)
+     (1 1 1 1 2 2 1 1)
+     (1 2 1 5 5 1)
+     (1 1 1 6 6 1)
+     (2 2 1 3 5 3 1)
+     (1 2 1 2 7 2 2)
+     (2 6 5 5 1)
+     (2 1 4 4 2)
+     (9 5 2)
+     (2 2)
+     (3 3)
+     (9)
+     ()
+     ()))
+   ("19980802-JON (3)"
+    (()
+     (1)
+     (3)
+     (4)
+     (4)
+     (4)
+     (3)
+     (2)
+     (7 6)
+     (18)
+     (20)
+     (22)
+     (21)
+     (20)
+     (19)
+     (19)
+     (19)
+     (19)
+     (19)
+     (20)
+     (21)
+     (21)
+     (21)
+     (19)
+     (19)
+     (17)
+     (15)
+     (13)
+     (4 4)
+     ())
+    (()
+     (10)
+     (13)
+     (16)
+     (18)
+     (19)
+     (20)
+     (21)
+     (21)
+     (21)
+     (21)
+     (19)
+     (19)
+     (3 19)
+     (25)
+     (4 21)
+     (4 21)
+     (4 21)
+     (2 20)
+     (19)
+     (5 7)
+     (3 5)
+     (1 2)
+     ()
+     ()))
+   ("19990723-KHO (4)"
+    ((8 8)
+     (6 6)
+     (4 5 4)
+     (3 7 3)
+     (2 9 2)
+     (1 6 1 1)
+     (1 5 3 1)
+     (4 4)
+     (4 4)
+     (2 4)
+     (3)
+     (3)
+     (3 3)
+     (5 5)
+     (13)
+     (15)
+     (3 9 1)
+     (3 9 3)
+     (3 2 1 4)
+     (3 1 2 3 3)
+     (3 5 5 1)
+     (3 11 1)
+     (3 9 3)
+     (1 3 7 3 1)
+     (1 3 3 1)
+     (2 11 2)
+     (3 8 3)
+     (4 4)
+     (6 6)
+     (8 8))
+    ((7 7)
+     (5 5)
+     (4 4)
+     (3 5 3)
+     (2 7 2)
+     (2 9 2)
+     (1 3 3 1)
+     (1 4 3 3 1 3 1)
+     (6 6 3 3)
+     (7 6 4 2)
+     (7 7 5 2)
+     (5 9 5 2)
+     (4 5 5 4 2)
+     (3 5 6 1 3 2)
+     (3 4 6 5 2)
+     (2 3 6 5 2)
+     (2 4 1 3 2)
+     (1 3 5 3 1)
+     (1 2 4 3 1)
+     (2 1 3 2 2)
+     (2 1 3 2)
+     (3 3)
+     (4 4)
+     (5 5)
+     (7 7)))
+   ("19990920-LLO (5)"
+    ((6)
+     (4 4)
+     (3 3)
+     (2 2)
+     (2 2 2)
+     (2 2 2)
+     (1 2 1)
+     (2 2 2)
+     (1 2 1)
+     (1 4 1)
+     (22)
+     (3 3)
+     (22)
+     (22)
+     (1 1)
+     (1 5 1)
+     (2 2)
+     (20)
+     (12)
+     (8 5)
+     (4 7)
+     (1 2 4 4)
+     (1 2 3 3)
+     (1 2 3 5)
+     (1 2 3 3)
+     (1 2 4 4)
+     (1 2 7)
+     (1 2 5)
+     (1 2)
+     (1 2))
+    ((4 5)
+     (3 4 2)
+     (2 4 1)
+     (2 4 1)
+     (2 1 2 1)
+     (1 1 2 2)
+     (2 1 1 2 2)
+     (1 2 1 2 3)
+     (2 2 1 2 3)
+     (2 2 2 2 13)
+     (1 4 2 4)
+     (1 3 2 13)
+     (2 2 2 13)
+     (2 1 2 3)
+     (1 1 2 1 3)
+     (2 1 2 1 2)
+     (1 1 2 1 2 5)
+     (2 1 2 1 1 7)
+     (2 4 1 1 9)
+     (2 4 1 3 3)
+     (3 4 2 2 1 2)
+     (4 5 3 1 3)
+     (9)
+     (7)
+     (5)))))
+ ("Kajitani 25x35"
+  "k25x35"
+  (("19981015bGAS (1)"
+    (()
+     (21)
+     (1 1)
+     (1 15 1)
+     (1 1 1 1)
+     (1 1 1 1)
+     (1 15 1)
+     (1 1)
+     (1 1)
+     (1 3 3 3 3 1)
+     (1 1 1 1 1 1 1 1 1 1)
+     (1 3 3 3 3 1)
+     (1 1)
+     (1 3 3 3 3 1)
+     (1 1 1 1 1 1 1 1 1 1)
+     (1 3 3 3 3 1)
+     (1 1)
+     (1 3 3 3 3 1)
+     (1 1 1 1 1 1 1 1 1 1)
+     (1 3 3 3 3 1)
+     (1 1)
+     (1 3 3 3 3 1)
+     (1 1 1 1 1 1 1 1 1 1)
+     (1 3 3 3 3 1)
+     (1 1)
+     (1 3 3 3 3 1)
+     (1 1 1 1 1 1 1 1 1 1)
+     (1 3 3 3 1 1 1)
+     (1 1 1 1)
+     (1 7 3 1 1 1)
+     (1 1 1 1 1 1 1 1)
+     (1 7 3 3 1)
+     (1 1)
+     (21)
+     ())
+    (()
+     ()
+     (33)
+     (1 1)
+     (1 1)
+     (1 4 3 3 3 3 3 3 1)
+     (1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)
+     (1 1 1 3 3 3 3 3 1 1 1)
+     (1 1 1 1 1 1)
+     (1 1 1 3 3 3 3 3 1 1 1)
+     (1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)
+     (1 1 1 3 3 3 3 3 3 1)
+     (1 1 1 1)
+     (1 1 1 3 3 3 3 3 3 1)
+     (1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)
+     (1 1 1 3 3 3 3 3 3 1)
+     (1 1 1 1)
+     (1 1 1 3 3 3 3 7 1)
+     (1 1 1 1 1 1 1 1 1 1 1 1 1 1)
+     (1 4 3 3 3 3 7 1)
+     (1 1)
+     (1 1)
+     (33)
+     ()
+     ()))
+   ("19990527dDRA (2)"
+    ((25)
+     (25)
+     (20 2)
+     (8 7 2)
+     (7 1 1 1 5 1)
+     (6 1 1 1 4 1)
+     (5 1 1 1 1 1 2)
+     (5 1 1 1 1 1 2)
+     (5 1 1 1 1 1 2)
+     (5 1 1 1 1 1 2 1 1)
+     (5 1 1 1 1 1 2 2 2)
+     (5 1 1 1 1 1 4 2)
+     (5 1 1 1 1 1 5 3)
+     (5 1 1 1 1 1 5 3)
+     (5 1 1 1 1 1 5 3)
+     (5 1 1 1 5 3)
+     (4 4 1 1 5 3)
+     (3 8 5 3)
+     (2 12 5 3)
+     (1 12 5 3)
+     (1 8 1 5 3)
+     (1 3 4 2 5 3)
+     (1 3 2 3 5 3)
+     (1 3 5 3 5 3)
+     (1 3 5 3 5 3)
+     (1 3 5 3 5 3)
+     (1 9 3 4 2)
+     (1 9 3 3 1)
+     (1 9 13)
+     (1 9 13)
+     (11 13)
+     (11 13)
+     (11 13)
+     (25)
+     (25))
+    ((35)
+     (19 5)
+     (18 1 14)
+     (17 2 14)
+     (16 3 14)
+     (6 5 9)
+     (5 9 5 13)
+     (4 5 13)
+     (3 11 6 12)
+     (3 5 12)
+     (3 12 5 12)
+     (3 5 2)
+     (3 13 3 13)
+     (4 2 14)
+     (5 11 1 15)
+     (6 7)
+     (35)
+     (35)
+     (6 24)
+     (4 18 7)
+     (2 1 14 7)
+     (2 7)
+     (2 1 14 7)
+     (4 18 7)
+     (6 24)))
+   ("19990607bDRA (3)"
+    (()
+     (4 1 1 4 1 1)
+     (1 1 1 1 1 2 1)
+     (4 1 1 1 4 1 1 1)
+     (1 2 2 1 1 1 2)
+     (4 1 1 1 1 1 1)
+     ()
+     ()
+     ()
+     ()
+     ()
+     (3)
+     (2 2)
+     (7)
+     (3)
+     (3)
+     (3)
+     (3)
+     (3)
+     (3)
+     (3)
+     (2 3)
+     (2 2 4 3)
+     (2 10 3)
+     (12 1 3)
+     (3 7 2 3)
+     (3 4 8)
+     (4 8)
+     (15)
+     (13)
+     (10)
+     ()
+     ()
+     ()
+     ())
+    (()
+     ()
+     (3 1)
+     (1 1 1 4)
+     (1 1 1 5)
+     (1 3 5)
+     (4 4)
+     (5 5 4)
+     (1 3 4)
+     (1 4 3)
+     (1 5 3)
+     (5 5 3)
+     (3 5 3)
+     (5 5 4 4)
+     (1 1 1 4 2 5)
+     (1 1 3 3 1 6)
+     (5 2 3 7)
+     (1 3 4)
+     (5 1 3 4)
+     (1 10)
+     (1 8)
+     (1 6)
+     (5)
+     ()
+     ()))
+   ("19991010cTPV (4)"
+    ((25)
+     (3 1 1 9)
+     (2 8)
+     (2 8)
+     (2 9)
+     (3 3 10)
+     (3 2 7)
+     (3 2 6)
+     (3 3 6)
+     (3 2 7)
+     (4 3 8)
+     (5 2 5)
+     (4 3 2 4)
+     (4 2 3)
+     (3 1 3)
+     (3 4)
+     (3 5)
+     (2 7)
+     (2 1 2 7)
+     (2 2 4 8)
+     (2 2 4 8)
+     (2 6 7)
+     (2 3 5)
+     (2 3)
+     (2 2 2)
+     (2 1 3 2)
+     (3 1 4 2)
+     (3 3 1 4 2)
+     (4 4 1 3 3)
+     (5 5 2 4)
+     (6 5 9)
+     (7 5 9)
+     (8 3 10)
+     (10 11)
+     (25))
+    ((35)
+     (35)
+     (2 12 9)
+     (1 4 7)
+     (1 1 6)
+     (1 5)
+     (2 2 4)
+     (1 2 3)
+     (1 1 2 2)
+     (1 2 1 2)
+     (1 2 4 3 1)
+     (1 5 5 1)
+     (2 1 5 1 6 1)
+     (1 2 3 7 1)
+     (1 1 1 5 2)
+     (1 1 1 1 1 3)
+     (2 2 2 2 8)
+     (6 2 2 2 6)
+     (7 2 1 5 3 5)
+     (11 2 5 4 5)
+     (12 2 7 5 5)
+     (13 8 4 6)
+     (24 7)
+     (35)
+     (35)))))
+ ("Kajitani 30x20"
+  "k30x20"
+  (("19981106-KVL (1)"
+    (()
+     (1 1)
+     (2 2)
+     (8)
+     (8)
+     (2 2 2)
+     (10 8)
+     (15 6)
+     (19 4)
+     (21 2 1)
+     (22 3)
+     (28)
+     (17 10)
+     (3 10 3 4 2)
+     (3 6 2 2 3 3)
+     (3 5 3 4)
+     (12 3 6)
+     (9 2 4)
+     ()
+     ())
+    (()
+     (3)
+     (6)
+     (8)
+     (5 3)
+     (7 2)
+     (8 2)
+     (8 2)
+     (9 2)
+     (9 2)
+     (9 2)
+     (9 2)
+     (8 3)
+     (8 3)
+     (8 3)
+     (7 3)
+     (7 2)
+     (7 1)
+     (5 5)
+     (11)
+     (6 1)
+     (4 5 1 2)
+     (7 6 2)
+     (3 3 5 2)
+     (7 3 3)
+     (7 3 2)
+     (3 3 3 3)
+     (7 7)
+     (4 5)
+     ()))
+   ("19990311-FRA (2)"
+    (()
+     (2)
+     (2)
+     (2)
+     (3)
+     (4)
+     (27)
+     (27)
+     (27)
+     (4)
+     (4 1)
+     (4 1)
+     (6 1 3)
+     (3 1 1)
+     (3 1 1 3 1 1 1)
+     (1 3 1 1 2 1 3 1)
+     (1 3 1 2 1 1 1)
+     (1 1 1 3)
+     (1 1 1)
+     (1 3))
+    (()
+     (1)
+     (8 1)
+     (9 6)
+     (10 1)
+     (11)
+     (2 3 1)
+     (1 3)
+     (3)
+     (3)
+     (3 6)
+     (3 1 1)
+     (3 3)
+     (3)
+     (3 1 3)
+     (3 1 1 1)
+     (3 5)
+     (3)
+     (3 4)
+     (3 1)
+     (3 1)
+     (3 4)
+     (3)
+     (3 3 1)
+     (3 1 1 1)
+     (3 5)
+     (3)
+     (3 4 1)
+     (3)
+     ()))
+   ("19990601cDRA (3)"
+    (()
+     (3 1 3 1)
+     (1 1 1 1)
+     (2 1 2 3 1 2 1 1 2 3)
+     (1 1 1 2 1 1 1 1 1 2)
+     (1 1 1 3 1 1 2 2 1 1)
+     ()
+     ()
+     (26)
+     (2 2 7)
+     (2 6 2 1)
+     (9 1 1 1 2 1)
+     (1 1 1 1 1 2 1)
+     (1 2 2 1)
+     (1 2 2 1)
+     (1 1 1 1 1 1)
+     (2 2 11 2 7)
+     (2 2)
+     ()
+     ())
+    ((5)
+     (1 1 1 6)
+     (1 1 1 1)
+     (1 1 1)
+     (1 3 4 1 2)
+     (4 1 2)
+     (3 1 1 1)
+     (1 1 1 1)
+     (1 1 1)
+     (3 1 2 1)
+     (3 1 1 1)
+     (1 1 1 4 1)
+     (1 1 1)
+     (3 1)
+     (1 3 1)
+     (5 1 1 1)
+     (1 1 4 1)
+     (3 1 1 1)
+     (1 1 3 1)
+     (3 1 2)
+     (2 2 1 2)
+     (1 2 1)
+     (3 2 2 1)
+     (2 2 1)
+     (3 2 1)
+     (1 1 3 1)
+     (1 2 1)
+     (5 4)
+     (2 1)
+     (2 1)))
+   ("19991106-BDH (4)"
+    ((7)
+     (9)
+     (6 3)
+     (6 3)
+     (13)
+     (16)
+     (1 13)
+     (2 10)
+     (3 7)
+     (5 5 7)
+     (23)
+     (7 10 5)
+     (7 8 6)
+     (8 7)
+     (25)
+     (25)
+     (25)
+     (24)
+     (22)
+     (20))
+    ((8)
+     (12)
+     (12)
+     (12)
+     (11)
+     (10)
+     (10)
+     (1 7)
+     (2 6)
+     (4 6)
+     (4 6)
+     (4 6)
+     (4 6)
+     (4 6)
+     (4 3 6)
+     (7 4 6)
+     (13 6)
+     (12 6)
+     (11 7)
+     (20)
+     (2 16)
+     (2 16)
+     (9 10)
+     (7 8)
+     (6 6)
+     (3)
+     (3)
+     (2)
+     (1)
+     (1)))))
+ ("Kajitani 30x25"
+  "k30x25"
+  (("19980715-GAS (1)"
+    ((30)
+     (30)
+     (30)
+     (13 15)
+     (12 14)
+     (12 14)
+     (12 14)
+     (12 14)
+     (12 14)
+     (13 15)
+     (13 12)
+     (7 6)
+     (4 3)
+     (1 1)
+     (1 2)
+     (3 1 3 4)
+     (3 3 4 3)
+     (2 4 4 3)
+     (2 3 3 2)
+     (1 2 2 1 2)
+     (1 1 1 1 3 1)
+     (3 4 1)
+     (4 5)
+     ()
+     ())
+    ((11 7)
+     (11 4)
+     (11 2)
+     (12)
+     (13)
+     (14)
+     (13 2)
+     (13 3)
+     (12 2)
+     (12 1 1)
+     (11 3)
+     (11 4)
+     (4 2 6)
+     (3)
+     (3)
+     (4 2)
+     (11 6)
+     (11 5)
+     (11 4)
+     (11 2 1)
+     (12 2)
+     (12 3)
+     (13 4)
+     (13 3)
+     (13)
+     (12)
+     (11 1)
+     (10 3)
+     (10 6)
+     (10 9)))))
+ ("Kajitani 30x30"
+  "k30x30"
+  (("19981106-GAS (1)"
+    (()
+     ()
+     (5 6)
+     (1 2 2 1)
+     (2 12 2)
+     (1 2 2 1)
+     (3 3)
+     (1 3 3 1)
+     (1 1 1 1 1 1)
+     (2 1 3 3 1 2)
+     (1 1 3 1 3 1 1)
+     (1 4 1 4 1)
+     (1 2 1 2 1)
+     (1 1 1)
+     (1 1 1)
+     (1 3 1)
+     (2 7 2)
+     (1 3 1)
+     (2 1 1 2)
+     (2 2 11 2 2)
+     (2 2 1 1 1 2 2)
+     (1 2 1 2 1)
+     (2 1 1 1 1)
+     (1 7 1)
+     (1 1)
+     (1 1)
+     (1 1 6 1)
+     (1 1 1 1)
+     (1 1 1 2)
+     (25))
+    (()
+     ()
+     (8)
+     (3 1)
+     (3 8 2 1)
+     (1 6 4 1)
+     (1 1 1 4)
+     (1 1 1 1)
+     (2 1 2 1 1)
+     (3 1 1 1 1)
+     (1 1 4 3 1)
+     (1 1 4 1 1 1)
+     (1 5 1 5 1)
+     (1 1 1 1 1)
+     (1 3 1 1 1)
+     (1 8 5 1)
+     (1 3 1 1 1)
+     (1 1 1 1 3)
+     (1 5 1 5 1 1)
+     (1 1 4 1 1 1 1)
+     (2 1 4 3 1 1)
+     (2 1 1 1 1 1 1)
+     (1 1 2 1 1 1)
+     (1 1 1 1 1)
+     (1 1 1 1)
+     (1 6 4 1)
+     (3 8 2 2)
+     (9)
+     ()
+     ()))
+   ("19981230-SQU (2)"
+    (()
+     ()
+     (4 4)
+     (6 6)
+     (8 8)
+     (9 9)
+     (9 9)
+     (8 8)
+     (7 6 7)
+     (5 8 5)
+     (10)
+     (13)
+     (14)
+     (14)
+     (18)
+     (2 14 2)
+     (2 14 2)
+     (2 16 2)
+     (2 2 12 2 2)
+     (1 2 10 2 1)
+     (4 3 2 3 4)
+     (2 2 6 2 2)
+     (4 2 2 2 4)
+     (1 2 1 2 1 2 1)
+     (2 1 2 2 2 1 2)
+     (2 2 2 2 2)
+     (2 2 2 2)
+     (2 2 2 2)
+     (2 2 2 2)
+     (30))
+    ((1)
+     (3 1)
+     (5 3 3 1)
+     (7 2 3 2 1)
+     (7 2 3 2 1)
+     (8 2 2 2 2 1)
+     (8 2 2 2 3)
+     (7 1 2 2)
+     (6 7 3 1)
+     (5 8 2 2 1)
+     (12 2 1)
+     (12 2 1)
+     (14 3)
+     (12 1 2)
+     (18 1)
+     (18 1)
+     (12 1 2)
+     (14 3)
+     (12 2 1)
+     (12 2 1)
+     (5 8 2 2 1)
+     (6 6 3 1)
+     (7 1 2 2)
+     (8 2 2 2 3)
+     (8 2 2 2 2 1)
+     (7 2 3 2 1)
+     (7 2 3 2 1)
+     (5 3 3 1)
+     (3 1)
+     (1)))
+   ("19990104-FRA (3)"
+    ((7)
+     (7)
+     (7)
+     (7)
+     (7)
+     (7)
+     (8)
+     (9)
+     (18)
+     (19)
+     (30)
+     (11 1 3 8)
+     (12 4 1 9)
+     (11 5 10)
+     (10 5 10)
+     (10 4 1 9)
+     (9 3 3 8)
+     (25)
+     (3 20)
+     (1 17)
+     (15)
+     (12)
+     (10)
+     (7)
+     (7)
+     (5)
+     (4)
+     (5)
+     (3)
+     ())
+    ((2)
+     (3)
+     (4)
+     (6)
+     (7)
+     (8)
+     (9)
+     (10)
+     (9)
+     (8)
+     (19)
+     (11 8)
+     (11 9)
+     (11 5)
+     (11 11)
+     (11 11)
+     (25)
+     (5 4 9)
+     (5 2 12)
+     (5 13)
+     (4 2 13)
+     (3 4 12)
+     (17 2)
+     (15)
+     (14)
+     (13)
+     (13)
+     (12)
+     (10)
+     (9)))
+   ("19990708-VEG (4)"
+    ((1 1 3 1 1 3 1 1)
+     (1 1 1 1 2 2 1 5)
+     (3 1 1 1 1 1 2 5)
+     (1 1 1 1 1 1 1 3)
+     (1 1 3 1 1 3 1)
+     ()
+     ()
+     ()
+     ()
+     (1)
+     (3)
+     (5 1)
+     (7 1)
+     (10)
+     (11)
+     (13)
+     (15)
+     (2 2)
+     (2 2 2 2)
+     (2 2 2 2)
+     (2 2)
+     (2 2)
+     (12 3 9)
+     (1 1 1 3 3 3 1 1)
+     (2 2 2 2 3 2 2 2)
+     (1 1 1 3 3 3 1 1)
+     (30)
+     (13)
+     (1 1)
+     (1 1))
+    ((5 2 2)
+     (1 1 1 1)
+     (5 1 1 1)
+     (2 2)
+     (5 1 1 1)
+     (1 1 1 1 1)
+     (5 2 2)
+     (1 1 1)
+     (5 1 1 1)
+     (1 1 2 2)
+     (1 13)
+     (1 14)
+     (5 4 2)
+     (5 2 2)
+     (5 6 2 2)
+     (1 1 1 7 6)
+     (1 1 8 6)
+     (7 2 6)
+     (6 2 3)
+     (5 2 1)
+     (2 4 3)
+     (4 17 1)
+     (4 13)
+     (4 1 2 2)
+     (2 1 1 1)
+     (1 1 1)
+     (2 2)
+     (1 1 1)
+     (1 1 1)
+     (2 2)))
+   ("19990729-WHO (5)"
+    ((3)
+     (1 2)
+     (1 5)
+     (1 1 1 4)
+     (1 1 1 3)
+     (1 1 1 2)
+     (1 5)
+     (1 3)
+     (1 2)
+     (1 1)
+     (1 1)
+     (1 1)
+     (3 2)
+     (12 5)
+     (13 6)
+     (14 8)
+     (15 9)
+     (16 9)
+     (16 10)
+     (16 10)
+     (16 9)
+     (16 9)
+     (8 7 9)
+     (8 16)
+     (27)
+     (26)
+     (25)
+     (22)
+     (15)
+     (5))
+    (()
+     (3)
+     (6)
+     (12)
+     (13)
+     (14)
+     (15)
+     (16)
+     (16)
+     (17)
+     (9 6)
+     (9 6)
+     (17)
+     (17)
+     (16)
+     (16)
+     (17)
+     (17)
+     (28)
+     (1 5)
+     (28)
+     (2 3 16)
+     (6 15)
+     (1 1 15)
+     (5 14)
+     (3 13)
+     (2 11)
+     (1 10)
+     (7)
+     (2)))
+   ("19990820-DAH (6)"
+    (()
+     (7 1 8)
+     (1 4 2 1 2 1)
+     (1 2 3 1 1 1 1)
+     (1 2 4 1 1 1 1)
+     (1 3 5 1 2 1)
+     (1 2 1 2 1 1 1 1)
+     (3 2 1 2 2)
+     (3 2 8)
+     ()
+     ()
+     (8 4)
+     (8 3 4 2 2)
+     (2 2 2 3 2)
+     (1 1 1 1 3)
+     (1 2 1 1 1 2)
+     (1 1 1 1)
+     (8 1 1 2)
+     (6 2)
+     ()
+     ()
+     (6 3)
+     (1 1 2 1 1 1)
+     (1 1 1 4 2 1 1)
+     (1 1 1 1 2 2 1)
+     (1 1 1 5 3 2)
+     (6 1 1 1 2 2)
+     (4 2 1 2)
+     (1 2 1 6)
+     ())
+    (()
+     (7 6)
+     (1 1 2 1 6 1)
+     (1 1 1 1 2 1 2)
+     (2 1 1 1 1 1 3)
+     (2 1 1 1 1 1 1 3)
+     (8 1 1 2 1 2)
+     (7 2 1 6 1)
+     (6)
+     ()
+     ()
+     (3 6)
+     (3 2 1 2)
+     (6 2 1 1 1 1 1)
+     (4 1 1 1 1 1)
+     (4 2 1 1 1 1)
+     (5 3 1 1 1 1 1)
+     (1 1 3 2 3 1)
+     (3 2)
+     ()
+     ()
+     (8 6)
+     (1 2 1 5)
+     (1 2 1 1 2 1)
+     (2 1 1 1 2 2 2)
+     (2 1 1 1 2 2 1 1 1)
+     (1 2 1 1 4 1 3)
+     (1 2 2 1 1)
+     (8 3)
+     ()))
+   ("19990821-ICO (7)"
+    (()
+     ()
+     (1 1 1 1 1)
+     (2 1 1 1 1)
+     (2 2 1 1 1 1)
+     (1 2 1 4 3 1 1 1 1)
+     (1 2 1 6 3 1 1 1 1)
+     (1 2 1 6 3 1 1 1 1)
+     (1 2 1 6 3 1 1 1 1)
+     (1 2 1 6 3 1 1 1 1)
+     (1 2 1 6 3 1 1 1 1)
+     (1 2 1 6 3 7)
+     (6 4 3 5)
+     (6 2 2 3)
+     (2 2 2 1)
+     (2 2 2 1)
+     (2 2 2 1)
+     (2 2 2 1)
+     (2 2 2 1)
+     (2 2 2 1)
+     (2 2 2 1)
+     (2 2 2 1)
+     (2 2 2 1)
+     (2 2 2 1)
+     (1 1 3 3 1 1 3 1 1 3)
+     (1 1 1 1 2 1 1 1 1 1)
+     (1 1 1 3 1 2 3 1 1 3)
+     (1 1 1 1 1 1 1 1 1 1)
+     (3 1 3 1 1 3 1 2 3)
+     ())
+    ((9)
+     (2 5)
+     (19 1)
+     (24)
+     (2)
+     (9 1)
+     (5)
+     (1)
+     (6)
+     (8 5)
+     (21 1 1)
+     (21 1 1)
+     (8)
+     (6 5)
+     (1)
+     (1)
+     (5)
+     (22)
+     (24 1)
+     (8 1 1 1)
+     (1 3)
+     ()
+     (10 5)
+     (2)
+     (12 5)
+     (13 1)
+     (12)
+     (2 3 1)
+     (10 1 1 1)
+     (1 3)))
+   ("19990908-ALE (8)"
+    ((12 16)
+     (11 15)
+     (10 14)
+     (4 4 14)
+     (3 4 3 10)
+     (2 4 3 9)
+     (2 3 4 8)
+     (3 4 4 8)
+     (4 5 5 9)
+     (6 5 5 10)
+     (7 4 6 10)
+     (8 3 5 11)
+     (8 3 4 12)
+     (8 4 3 12)
+     (8 4 2 5 6)
+     (8 4 2 4 5)
+     (8 4 2 3 5)
+     (9 3 2 3 4)
+     (9 4 1 2 1 1 3)
+     (10 4 1 3 3 2)
+     (10 4 3 4)
+     (11 2 3)
+     (16 1 1 2)
+     (21 2 2)
+     (21 5)
+     (20 4)
+     (19 3)
+     (21 1 6)
+     (21 1 6)
+     (20 1 5))
+    ((30)
+     (30)
+     (5 23)
+     (4 22)
+     (3 21)
+     (3 21)
+     (4 1 20)
+     (5 3 19)
+     (11 13)
+     (17 11)
+     (2 15 9)
+     (1 1 12 8)
+     (3 8 8)
+     (7 3 8)
+     (1 13 2 8)
+     (2 15 8)
+     (6 6 7)
+     (5 3 8 7)
+     (4 1 7 2 7)
+     (4 7 2 3 3)
+     (5 7 2 3 2)
+     (6 7 1)
+     (14 3)
+     (14)
+     (15 1 2)
+     (17 2 3 3)
+     (18 2 3 3)
+     (19 2 6)
+     (30)
+     (30)))
+   ("19990913-TUC (9)"
+    ((12 14)
+     (13 15)
+     (13 15)
+     (13 15)
+     (1 6 6 3)
+     (1 3 5 5 3 3)
+     (1 1 4 4 3 3)
+     (1 1 1 3 3 1 3)
+     (1 3 3 3 1 1 3)
+     (1 3 3 3 3 3)
+     (1 3 3 6 3 3 3)
+     (2 1 4 6 4 1 4)
+     (3 5 6 5 5)
+     (3 5 6 5 5)
+     (3 5 5 5)
+     (3 5 5 5)
+     (3 5 5 5)
+     (2 4 4 4)
+     (1 1 1 3 3 1 1 3)
+     (1 3 3 3 3 3)
+     (2 4 4 4)
+     (30)
+     ()
+     (30)
+     (1 1 2 1 1 1 2)
+     (1 2 1 2 1 4 4 2 1 3)
+     (1 4 1 2 2 2)
+     (1 2 1 2 1 4 4 2 4)
+     (1 1 2 1 1 1 2 1)
+     (30))
+    ((22 7)
+     (4 7 2 1 1)
+     (4 1 4 5 2 1 1 3 1)
+     (4 2 4 1 1 1 3 1)
+     (4 1 4 5 2 1 1 1 1)
+     (4 7 2 7)
+     (22 1 1)
+     (22 3 3)
+     (22 3 3)
+     (7 1 1 1)
+     (6 1 7)
+     (5 4 1 1 1)
+     (3 4 1 1 1 1 1)
+     (4 1 1 1 1 1)
+     (4 1 1 3 1)
+     (3 4 1 7)
+     (5 4 1 1 1)
+     (6 1 1 1 1 1)
+     (7 1 1 1 1 1)
+     (22 1 3 1)
+     (22 7)
+     (22 1 1)
+     (4 7 2 1 1 3)
+     (4 2 3 5 2 1 1 1 3)
+     (4 3 3 1 1 2 1 1)
+     (4 2 3 5 2 1 7)
+     (4 7 2 1 1 1)
+     (22 1 1 1 1)
+     (22 1 1 1 1)
+     (22 1 1 1)))
+   ("19990916bCAR (10)"
+    ((30)
+     (30)
+     (30)
+     (7 7 6)
+     (6 5 5)
+     (5 3 3 3 4)
+     (5 5 1 5 4)
+     (5 6 6 4)
+     (5 15 4)
+     (5 5 5 4)
+     (6 4 4 5)
+     (6 3 3 5)
+     (7 4 4 6)
+     (8 3 3 7)
+     (9 5 8)
+     (9 3 8)
+     (10 1 9)
+     (11 10)
+     (12 11)
+     (13 12)
+     (14 13)
+     (15 8 3)
+     (23 3 2)
+     (7 12 3 1)
+     (7 2)
+     (7 2)
+     (7 1 1 12 3 1)
+     (7 1 13 3 2)
+     (24 3)
+     (30))
+    ((30)
+     (30)
+     (30)
+     (30)
+     (30)
+     (5 20)
+     (4 18)
+     (3 10 2)
+     (3 3 9 4)
+     (3 5 7 2)
+     (3 6 6 4)
+     (3 8 5 3)
+     (4 8 5 4)
+     (5 8 4 4)
+     (6 1 4 3 4)
+     (7 1 3 2 4)
+     (6 1 4 3 4)
+     (5 8 4 4)
+     (4 8 5 4)
+     (3 8 6 4)
+     (3 6 7 4)
+     (3 5 8 4)
+     (3 3 10 4)
+     (3 9 1 1 2)
+     (4 9 1 1 1)
+     (5 11 2 2 1)
+     (21 2 2 1)
+     (22 4 2)
+     (23 2 3)
+     (24 4)))
+   ("19990920-BBA (11)"
+    ((6)
+     (3 2 1 2)
+     (1 1 1 4 4)
+     (3 1 1 1 2 3)
+     (8 2 2 1 4)
+     (11 8 2)
+     (1 1 1 6 9 1)
+     (1 24)
+     (1 2 12 4 3)
+     (4 1 1 1 1 1 3 7 1)
+     (1 5 3 5 4 1 2)
+     (3 5 2 4 7 1)
+     (3 1 5 1 1 4 2 1)
+     (1 4 3 4 5 7)
+     (1 1 3 4 1 3 2 3 1)
+     (4 1 6 4 9)
+     (7 1 2 2 4 3)
+     (3 4 2 2 2 1 3 2)
+     (3 1 1 1 2 2 1 8)
+     (2 3 3 4 1 3 1 1)
+     (3 2 2 1 2 2 1 4)
+     (2 1 3 3 2 4 2)
+     (1 1 3 3 2 1 1 1)
+     (1 1 1 1 1 3 1)
+     (1 3 1 1)
+     (2 6)
+     (5 6)
+     (3 5 2 1 1)
+     (1 3 1 1 2 4)
+     (2 3 3 4 1))
+    ((4)
+     (4 2 1)
+     (2 6 6)
+     (1 3 1 4 2)
+     (2 3 3 5 1)
+     (1 2 2 5 1 1)
+     (4 4 1 1 3 1 1)
+     (1 2 1 4 3 4 2)
+     (1 7 5 3 2 1)
+     (5 2 8 3 1 1)
+     (1 8 1 2 4 1 1)
+     (1 1 5 2 4 1 2)
+     (2 6 1 1 6 4)
+     (3 6 1 3 8)
+     (1 2 4 2 3 4 2)
+     (3 1 6 14)
+     (1 1 2 2 4 4 2 1 1)
+     (1 1 7 3 7 2)
+     (2 7 3 7 3 1)
+     (8 2 2 5)
+     (2 3 1 1 2 2 2)
+     (1 9 6 1 2 1)
+     (1 8 2 5 1 1)
+     (11 1 3 1 1 3)
+     (2 10 2 4 1)
+     (4 1 1 6 1 1 1)
+     (2 1 8 5 1)
+     (4 2 4 2 2 1)
+     (2 2 3 3)
+     (3 2)))
+   ("19991002bTPV (12)"
+    ((30)
+     ()
+     (2 1)
+     (3 2)
+     (3 3)
+     (1 2 4)
+     (1 1 5)
+     (30)
+     (1 2 4 1)
+     (1 1 4 1)
+     (1 3 1)
+     (1 2 1)
+     (1 1 1)
+     (1 1 1)
+     (30)
+     (1 1 1)
+     (5 1 5)
+     (6 1 1 6)
+     (6 1 6)
+     (4 1 1 4)
+     (1 1 1)
+     (30)
+     (4 1)
+     (4 5)
+     (2 1 6)
+     (1 2 6)
+     (4 4)
+     (4)
+     (30)
+     (1 1))
+    ((1 1 1 1 1)
+     (1 1 1 2 1 1)
+     (1 1 1 4 1 1)
+     (1 1 1 4 1 1)
+     (1 1 1 4 1 1)
+     (1 1 1 4 1 1)
+     (1 17 1 1)
+     (1 3 1 1 1 1)
+     (1 3 1 1 1 1 1)
+     (1 4 1 1 1)
+     (1 3 1 1 2 2)
+     (1 1 1 10)
+     (1 1 1 3 3)
+     (1 1 1 11)
+     (1 1 1 2 2 1)
+     (1 1 1 1 1)
+     (1 1 1 1 2 1)
+     (1 1 1 1 4 1)
+     (1 1 1 1 4 1)
+     (1 1 1 1 4 1)
+     (1 1 1 1 4 1)
+     (1 1 17 1)
+     (1 5 1 1 1)
+     (1 4 1 2 1 1)
+     (1 4 1 4 1 1)
+     (1 4 1 4 1 1)
+     (1 4 1 4 1 1)
+     (1 5 1 4 1 1)
+     (1 17 1 1)
+     (1 1 1 1 1)))
+   ("19991012-LSA (13)"
+    ((16 13)
+     (4 4 5 4 3 1)
+     (2 1 2 5 2 2 1)
+     (4 2 2 3 1 3 3)
+     (5 1 3 3 2 4 3)
+     (1 2 1 1 2 2 2 3)
+     (2 2 1 2 2 1 2 3)
+     (3 1 2 2 2 1 2 4)
+     (1 2 2 2 1 2 1 2 5)
+     (2 1 1 2 1 2 2 1 1 1)
+     (3 2 2 2 2 1 1 1)
+     (4 1 1 1 1 1 1 3)
+     (5 2 3 1 2 1 2 4)
+     (1 2 2 2 1 1 1 5)
+     (3 1 1 1 1 2 2 2 1)
+     (7 3 1 1 2 1 4)
+     (7 2 1 2 1 1 1)
+     (3 2 1 1 1 2 3 1 1)
+     (1 1 1)
+     (1 1 22 1 1)
+     (3 1 1 3)
+     (2 2 1 1 1 3 1 1 3 1 3)
+     (2 2 1 1 1 1 1 1 1 1 1 1 2)
+     (2 2 1 3 1 1 3 1 1 5)
+     (2 2 5)
+     (6 6)
+     (7 7)
+     (8 8)
+     (9 9)
+     (10 10))
+    ((30)
+     (5 2 4 4 10)
+     (2 2 2 3 4 2 5)
+     (2 3 1 2 2 9)
+     (1 3 1 1 2 11)
+     (3 3 1 1 2 1 5)
+     (2 1 1 2 1 3 1 1 1 4)
+     (2 3 1 1 1 1 1 1 3)
+     (2 2 2 1 1 1 1 2)
+     (1 2 3 4 1 2 1)
+     (1 3 3 2 1 1 1)
+     (1 3 3 1 1 1)
+     (2 1 2 2 1 1 1)
+     (3 3 4 1 2)
+     (4 1 1 1)
+     (5 12 1 1)
+     (10 1 1 1)
+     (1 1 2 1 4 1 2)
+     (1 8 1 1 1)
+     (3 7 1 1)
+     (6 1 1 1 1 1 1)
+     (2 1 7 1 2 2)
+     (2 1 4 1 1 1 3)
+     (1 5 1 1 1 1 1 4)
+     (1 5 3 1 1 1 5)
+     (5 2 1 1 11)
+     (2 2 2 2 7)
+     (2 6 4 1 5 7)
+     (1 6 3 1 10)
+     (10 19)))
+   ("19991028-BDH (14)"
+    ((7 7)
+     (9 9)
+     (11 11)
+     (12 12)
+     (12 12)
+     (12 12)
+     (12 12)
+     (12 12)
+     (30)
+     (28)
+     (8 4 8)
+     (5 1 2 1 5)
+     (2 3 3 2)
+     (3 3 3 3)
+     (2 3 3 2)
+     (2 3 3 2)
+     (3 3 3 3)
+     (3 1 1 3)
+     (2 2)
+     (2 2)
+     (2 4 2)
+     (2 6 2)
+     (2 4 2)
+     (1 1)
+     (1 1 1 1)
+     (2 14 2)
+     (2 10 2)
+     (3 4 3)
+     (3 3)
+     (10))
+    ((7)
+     (9)
+     (11)
+     (12 7)
+     (12 13)
+     (18 2)
+     (14 2)
+     (12 1)
+     (11 2 2)
+     (10 5 1 1)
+     (8 7 2 2)
+     (7 5 2 1)
+     (2 1 2 1)
+     (3 3 3 1)
+     (4 3 3 1)
+     (4 3 3 1)
+     (3 3 3 1)
+     (2 1 2 1)
+     (7 5 2 1)
+     (8 7 2 2)
+     (10 5 1 1)
+     (11 2 2)
+     (12 1)
+     (14 2)
+     (18 2)
+     (12 13)
+     (12 7)
+     (11)
+     (9)
+     (7)))
+   ("19991101-SHE (15)"
+    ((4)
+     (2 2)
+     (1 2)
+     (2 1 3)
+     (2 3)
+     (2 1 3)
+     (3 3)
+     (3 4)
+     (5 4)
+     (1 7)
+     (2 7)
+     (2 8)
+     (2 4)
+     (1 2 2 2)
+     (1 2 3 4)
+     (3 3 4 7)
+     (3 4 4 2)
+     (8 7 1)
+     (6 11 1)
+     (5 8 3)
+     (5 8)
+     (17)
+     (17)
+     (16)
+     (15)
+     (14)
+     (13)
+     (11)
+     (9)
+     (5))
+    (()
+     (3)
+     (3)
+     (5)
+     (5)
+     (7)
+     (9)
+     (11)
+     (1 4 8)
+     (5 8)
+     (3 8)
+     (9)
+     (9)
+     (9)
+     (3 11)
+     (4 8 13)
+     (8 16)
+     (2 3 15)
+     (1 1 3 13)
+     (1 1 3 11)
+     (2 1 4 8)
+     (14 6)
+     (14 1)
+     (9 2 1)
+     (5 2 1)
+     (2 1 1)
+     (1 1 1)
+     (1 2 1)
+     (5)
+     ()))
+   ("19991105bBDH (16)"
+    ((1)
+     (1 1)
+     (1 1)
+     (1 1 1)
+     (1 1 2)
+     (2 3)
+     (1 1 1)
+     (2 1)
+     (4 1)
+     (1 1)
+     (1 1)
+     (1 1)
+     (1 1)
+     (1 1)
+     (1 1)
+     (1 1)
+     (1 1)
+     (1 1)
+     (1 1)
+     (1 1)
+     (1 1 4)
+     (1 1 1 1)
+     (1 1 1 1)
+     (4 1 1 1 1)
+     (6 1 1 5)
+     (7 1 1 4)
+     (4 1 1 6)
+     (17)
+     (16)
+     (14))
+    ((2)
+     (2)
+     (3)
+     (3)
+     (2)
+     (3)
+     (3)
+     (4)
+     (5)
+     (3)
+     (22)
+     (1 3)
+     (3 1 3)
+     (1 1 1 3)
+     (1 4 3)
+     (3 1 3)
+     (1 3)
+     (1 3)
+     (2 3)
+     (27)
+     (3)
+     (4)
+     (3)
+     (2)
+     (2)
+     (6)
+     (1 3)
+     (1 1)
+     (1 1)
+     (5)))
+   ("19991113aBAR (17)"
+    ((11)
+     (15)
+     (18)
+     (20)
+     (22)
+     (24)
+     (25)
+     (27)
+     (24 2)
+     (5 4 1)
+     (2 2 1)
+     (1 5 5 1 1)
+     (6 2 2 5 2)
+     (4 6 7)
+     (2 18 2)
+     (2 3 3 2)
+     (8 3 3 6)
+     (6 7 8)
+     (4 3 2 2 4 4)
+     (3 5 6 2)
+     (2 3 4 3 2)
+     (2 13 1)
+     (2 4 4 1)
+     (2 1)
+     (2 1 2)
+     (3 2 3)
+     (4 1 1 3 1 3)
+     (6 1 1 2 4)
+     (11 2 2 11)
+     (30))
+    ((12)
+     (3 13)
+     (3 8 5)
+     (3 7 4)
+     (5 2 2 3)
+     (6 3 3 5)
+     (7 2 1 4 2 2)
+     (7 1 3 3 2)
+     (8 1 3 3 2)
+     (8 1 3 3 4)
+     (9 2 1 2 2 2)
+     (9 3 2 2 1)
+     (9 2 1 2 1)
+     (9 2 2 3 2)
+     (9 2 2 2 2)
+     (9 2 2 2 1 1)
+     (9 3 1 3 1 2)
+     (9 2 1 2 2 4)
+     (9 1 3 2 2 1)
+     (9 1 3 4 2)
+     (9 1 3 3 2)
+     (9 2 1 4 2)
+     (9 3 4 2)
+     (8 2 4 3)
+     (9 7 4)
+     (6 8 2)
+     (4 1 3 3)
+     (3 1 3 5)
+     (3 2 4 6)
+     (6 12)))
+   ("19991113eBAR (18)"
+    ((6)
+     (1 8)
+     (11 1)
+     (12)
+     (1 6)
+     (2 1 7 1)
+     (1 2 7)
+     (5 10)
+     (6 9)
+     (4 8)
+     (7 8)
+     (5 8)
+     (2 10)
+     (2 2 9)
+     (1 3 13)
+     (1 2 3 8)
+     (6 4 3 5)
+     (1 1 1 4 3)
+     (6 9)
+     (7 8)
+     (8 8)
+     (8 8)
+     (8 5 2)
+     (8 6 1)
+     (18)
+     (17)
+     (16)
+     (14)
+     (12)
+     (10))
+    ((4)
+     (2 1 1 1)
+     (2 2 2 1 1)
+     (2 4 2 1 1)
+     (11 2 1)
+     (4 7 7)
+     (4 1 5 1 7)
+     (4 3 1 9)
+     (6 1 10)
+     (6 3 17)
+     (17 12)
+     (16 11)
+     (13 1 10)
+     (12 7)
+     (2 11 6)
+     (11 6)
+     (13 6)
+     (2 7 6)
+     (1 1 2 6)
+     (2 7)
+     (3 6)
+     (4 6)
+     (11)
+     (10)
+     (8)
+     (5)
+     (5)
+     (5)
+     (6)
+     (6)))
+   ("19991115aBAR (19)"
+    ((3 11)
+     (3 9)
+     (4 8)
+     (5 6)
+     (6 5)
+     (12 4)
+     (6 3)
+     (8 3)
+     (1 7 2)
+     (8 2)
+     (3 2 2)
+     (2 4 1)
+     (7 1)
+     (10 1)
+     (11 1)
+     (3 4 4 1)
+     (9 4 4)
+     (10 4 1)
+     (9 3 1)
+     (13 1)
+     (13 1)
+     (13 1)
+     (13 2)
+     (8 3 2)
+     (7 4 2)
+     (4 2 1 2 3)
+     (6 3 3)
+     (6 4 4)
+     (5 1 2 5)
+     (4 6))
+    ((3)
+     (4)
+     (4)
+     (4)
+     (3)
+     (2)
+     (2)
+     (1)
+     (1 2 1 2)
+     (1 1 3 2 5)
+     (6 4 5 6)
+     (11 13)
+     (9 4 9)
+     (27)
+     (25)
+     (6 13 3)
+     (4 12 2)
+     (1 1 3 7)
+     (1 2 6)
+     (1 1 3 6)
+     (1 2 7)
+     (2 2 6)
+     (3 2 3 3)
+     (3 3 2)
+     (4 3 1)
+     (5 1 2)
+     (6 2 3)
+     (8 1 5)
+     (11 1 8)
+     (30)))))
+ ("Kajitani 30x35"
+  "k30x35"
+  (("19990507aJOJ (1)"
+    ((6 2 1 3 1 2 1 1 4)
+     (5 1 1 1 4 1 1 1 1 3)
+     (5 1 1 1 1 1 1 1 1 1)
+     (4 1 1 1 1 1 2 1 1 1 3)
+     (2 1 1 3 2 2 3 3 1)
+     (1 2 18 2)
+     (1 23)
+     (2 21 2)
+     (1 25)
+     (3 22 2)
+     (3 11 8 3)
+     (2 10 7 2)
+     (2 5 6 1)
+     (1 5 2 2 5)
+     (3 1 1 1 1 2)
+     (2 1 1 1 1 1 1 1 1 1)
+     (2 1 1 1 2 1 1 1 1)
+     (2 1 2 4 2 1 1)
+     (2 1 6 1 2)
+     (1 3 6 3)
+     (2 2 6 2 1)
+     (3 2 2 4 2 2 1)
+     (3 2 3 3 2 1)
+     (4 2 5 5 2 2)
+     (4 2 12 2 3)
+     (3 4 6 3 3)
+     (1 7 5 2)
+     (3 4 3 2 1)
+     (29)
+     (1 8 2)
+     (12 10)
+     ()
+     (30)
+     ()
+     (30))
+    ((7 6 3 8 3 1 1)
+     (5 1 4 5 6 2 1 1 1)
+     (4 1 1 2 2 2 5 2 1 1 1)
+     (4 1 1 4 2 2 3 1 1 1)
+     (3 1 1 6 3 4 2 1 1 1 1)
+     (1 1 8 1 6 1 1 1 1)
+     (1 1 8 4 1 1 1 1)
+     (1 1 8 1 2 1 1 1 1)
+     (2 1 7 2 3 1 1 1)
+     (1 8 2 3 1 1 1)
+     (2 9 2 3 2 1 1 1)
+     (1 8 1 1 2 2 1 1 1)
+     (2 1 7 1 1 1 2 2 1 1)
+     (2 7 1 1 3 3 2 1 1)
+     (2 8 2 5 2 2 1 1)
+     (2 5 6 2 2 1 1)
+     (1 7 6 2 2 1 1)
+     (9 2 5 2 2 1 1)
+     (1 6 1 1 3 3 2 1 1)
+     (1 8 1 1 1 2 2 1 1)
+     (2 8 1 1 2 2 1 1 1)
+     (1 9 2 3 2 1 1 1)
+     (1 8 2 3 1 1 1)
+     (1 10 2 2 1 1 1 1)
+     (1 1 10 1 3 1 1 1 1)
+     (1 1 8 1 4 1 1 1 1)
+     (1 1 1 1 3 3 5 3 1 1 1)
+     (2 1 1 1 1 3 4 2 2 1 1 1)
+     (2 1 1 1 3 2 2 4 3 1 1)
+     (3 1 1 4 4 8 2 1 1)))))
+ ("Kajitani 30x40"
+  "k30x40"
+  (("19980514-KVL (1)"
+    ((14)
+     (14)
+     (16)
+     (18)
+     (20)
+     (1 7 6)
+     (1 3 4 4)
+     (3 9 3)
+     (5 8 2)
+     (1 4 8 2)
+     (1 1 13 1)
+     (1 1 5 1 1)
+     (1 1 2 1)
+     (1 1 1 3 1)
+     (3 1 1 6 1)
+     (5 1 9 1)
+     (1 4 8 2)
+     (1 1 10 2)
+     (1 1 8 3)
+     (1 1 2 4 4)
+     (1 4 6)
+     (3 13)
+     (5 11)
+     (1 4 11)
+     (1 1 15)
+     (1 1 14)
+     (1 1 1 11)
+     (1 1 3 3)
+     (3 4 2)
+     (5 2 2)
+     (1 4 2 2)
+     (1 15)
+     (1 14)
+     (1 1 14)
+     (1 14)
+     (3 13)
+     (5 11)
+     (7 11)
+     (18)
+     (16))
+    (()
+     ()
+     ()
+     ()
+     ()
+     (34)
+     (2 2 2 2 2 4)
+     (3 2 2 2 2 5)
+     (6 5 2 1 5 2 1 4)
+     (6 2 2 2 2 4)
+     (7 2 2 2 2 3)
+     (7 2 4 3 5 5 3)
+     (8 2 1 3 2 5 2)
+     (6 1 2 2 2 2 5 2)
+     (6 12 20)
+     (5 7 5 19)
+     (5 6 5 8 9)
+     (5 5 6 6 1 9)
+     (5 5 7 6 9)
+     (6 4 6 7 9)
+     (6 4 6 7 9)
+     (7 3 4 8 9)
+     (6 2 2 10 9)
+     (7 23)
+     (34)
+     ()
+     ()
+     ()
+     ()
+     ()))
+   ("19990224aJOJ (2)"
+    ((13 1 1)
+     (14 1)
+     (1 14)
+     (7 1 1 13)
+     (8 3 12)
+     (2 2 1 3 11)
+     (2 2 4 11)
+     (2 2 1 3 11)
+     (2 2 4 11)
+     (2 2 1 3 11)
+     (8 3 12)
+     (7 1 1 13)
+     (1 14)
+     (14 1)
+     (13 1 1 3 2)
+     (12 3 3 2)
+     (11 3 1 4 2)
+     (11 4 5 2)
+     (11 3 1 2 2 2)
+     (11 4 2 5)
+     (11 3 1 2 4)
+     (12 3 2 3)
+     (13 1 1 2 3)
+     (14 1)
+     (1 14)
+     (4 1 1 13)
+     (6 3 12)
+     (2 2 1 3 11)
+     (2 2 4 11)
+     (8 1 3 11)
+     (8 4 11)
+     (2 2 1 3 11)
+     (2 2 3 12)
+     (2 2 1 1 13)
+     (1 14)
+     (14 1)
+     (13 1 1)
+     (12 3)
+     (11 3 1)
+     (11 4))
+    ((2 11 5)
+     (2 9 11 6 5)
+     (2 9 11 8 5)
+     (2 2 2 11 3 2 5)
+     (2 2 2 11 2 2 5)
+     (2 2 2 11 2 2 5)
+     (2 2 2 11 3 2 5)
+     (2 9 11 8 5)
+     (2 7 11 6 5)
+     (2 11 5)
+     (2 11 5)
+     (2 5 3 3 5 3)
+     (2 1 1 1 1 2 1 1 1 2 1 1 1 1 2 1)
+     (1 2 1 1 2 1 1 1 1 1 2 1 1 2 1 1)
+     (1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)
+     (1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)
+     (1 1 1 1 1 1 2 1 1 2 1 1 1 1 1 2 1)
+     (2 1 1 1 2 1 1 1 1 2 1 1 1 2 1 1)
+     (3 3 5 3 3 2)
+     (11 11)
+     (11 11)
+     (11 9 11)
+     (11 9 11)
+     (11 4 11)
+     (11 4 11)
+     (11 4 11)
+     (11 4 11)
+     (11 9 11)
+     (11 9 11)
+     (11 11)))
+   ("19990507bJOJ (3)"
+    ((2 1 1 2 1 1 1)
+     (2 1 1 1 1 1 1 3)
+     (3 1 1 1 1 2 1 1)
+     (2 11 2)
+     (3 12 2)
+     (2 12 2)
+     (13 2)
+     (1 2 14 2)
+     (2 1 16)
+     (18)
+     (3 9)
+     (2 2)
+     (2 2)
+     (2 2)
+     (2 2)
+     (2 2)
+     (2 8 2)
+     (2 10 2)
+     (2 2)
+     (3 3 3 3)
+     (3 2 1 1 2 3)
+     (2 1 2 2 2 1 2)
+     (2 1 1 2 2 2 1 1 2)
+     (2 1 2 1 1 2 1 2)
+     (2 1 3 2 3 1 2)
+     (2 1 4 1 2)
+     (2 4 2)
+     (2 6 2)
+     (2 6 2)
+     (2 6 2)
+     (2 4 2)
+     (2 2)
+     (2 12 2)
+     (2 3 2 2)
+     (3 7 3)
+     (6 6)
+     (3 6 6 3)
+     (2 1 1 11 1 1 2)
+     (3 1 1 1 3 1 1 1 3)
+     (2 1 1 1 2 2 1 1 1 2))
+    (()
+     (1)
+     (3 2)
+     (5 2)
+     (1 1 2 2 2 4)
+     (2 1 1 2 3 6 2)
+     (1 2 1 1 4 1 13)
+     (1 1 1 1 5 4)
+     (1 1 1 2 4 6)
+     (2 2 2 6 4 1 2)
+     (1 1 2 4 1 2 2 2 5)
+     (1 8 2 1 2 1 2 2 1)
+     (9 2 1 2 1 3 3 2)
+     (1 7 2 1 1 6 1 1 2)
+     (9 2 2 7 1 1 2)
+     (1 7 2 2 7 1 1 2)
+     (10 2 1 1 6 1 1 2)
+     (8 2 1 2 1 3 1 1 2)
+     (10 2 1 2 1 3 2)
+     (1 9 1 2 2 2 2 1)
+     (1 9 4 1 5)
+     (1 2 1 8 2)
+     (1 1 4 6 6)
+     (1 1 1 3 5 4)
+     (2 1 1 1 1 3 1 13)
+     (1 1 1 1 2 3 6 2)
+     (2 1 2 2 2 4)
+     (1 5 2)
+     (3 2)
+     (1)))
+   ("19990525bKHO (4)"
+    ((2)
+     (2)
+     (2)
+     (2)
+     (2)
+     (2)
+     (4)
+     (10)
+     (2 2)
+     (1 4 1)
+     (1 1 1 1)
+     (1 1 4 1 1)
+     (1 1 1 1)
+     (1 1 4 1 1)
+     (1 1 1 1)
+     (1 4 1)
+     (1 1)
+     (12)
+     (1 1)
+     (1 1 2 1 1)
+     (1 2 2 2 1)
+     (1 1)
+     (1 2 2 2 1)
+     (1 2 2 2 1)
+     (1 1)
+     (1 2 2 2 1)
+     (1 2 2 2 1)
+     (1 1)
+     (1 2 2 2 1)
+     (1 2 2 2 1)
+     (1 1)
+     (1 2 2 2 1)
+     (1 1 2 1 1)
+     (1 1)
+     (1 3 1)
+     (1 5 1)
+     (1 5 1)
+     (1 3 1)
+     (2 2)
+     (10))
+    (()
+     ()
+     ()
+     ()
+     ()
+     ()
+     ()
+     (31)
+     (2 1 2)
+     (1 3 1 1 2 2 2 1 1)
+     (1 1 1 1 2 2 2 2 2 2 1)
+     (1 1 1 1 1 1 4 1)
+     (1 1 1 1 1 1 2 2 2 2 2 4 1)
+     (1 1 1 1 1 1 2 2 2 2 2 4 1)
+     (2 1 1 1 1 1 2 1)
+     (8 1 1 1 2 2 2 2 2 1)
+     (8 3 1 1 2 2 2 1 1)
+     (3 1 2)
+     (31)
+     ()
+     ()
+     ()
+     ()
+     ()
+     ()
+     ()
+     ()
+     ()
+     ()
+     ()))
+   ("19990611-KVL (5)"
+    (()
+     (9)
+     (13)
+     (11 2)
+     (9 6 1)
+     (6 5)
+     (4 2)
+     (3 2)
+     (3 1)
+     (4 2)
+     (4 1)
+     (5 1)
+     (5 1)
+     (10 2 1)
+     (11 7 3)
+     (12 1 2)
+     (12 5 2)
+     (12 4 2)
+     (13 2 1)
+     (12)
+     (4 2)
+     (5 3)
+     (5 3)
+     (6 7)
+     (13)
+     (12)
+     (11)
+     (10)
+     (13 1)
+     (10)
+     (10)
+     (10)
+     (7)
+     (6)
+     (7)
+     (10 2)
+     (14 2)
+     (16 2)
+     (15 3)
+     (15 4))
+    ((1)
+     (7 3)
+     (18 3)
+     (20 4)
+     (25 4)
+     (16 12 5)
+     (4 9 17)
+     (5 7 16)
+     (4 7 16)
+     (5 7 17)
+     (4 7 19)
+     (4 27)
+     (4 18 6)
+     (4 4 3 5 5)
+     (3 1 1 2 5)
+     (4 1 1 1 3)
+     (4 1 2 1 2)
+     (2 1 6)
+     (1 1 2 3 1)
+     (1 2 1 2)
+     (3 1 1)
+     (1 1 1)
+     (2)
+     (2)
+     (2)
+     (3 1 1)
+     (10 5)
+     (4 4)
+     (2)
+     (1)))
+   ("19990612-ARE (6)"
+    ((9)
+     (3 3)
+     (4 5)
+     (20 5)
+     (23 1)
+     (2 19 5)
+     (18 1)
+     (1 17 5)
+     (1 15)
+     (1 13 5)
+     (1 5 10 1 1)
+     (5 9 5)
+     (4 7 1 1)
+     (4 11 1 1)
+     (4 1 10)
+     (4 12 3)
+     (3 1 4 6 1)
+     (2 1 4 6 1)
+     (1 6 1)
+     (1 1 5 3)
+     (1 1 7)
+     (1 5 1)
+     (2 7 1)
+     (1 3 4 1)
+     (6 1)
+     (6 5)
+     (2 4)
+     (2 4 5)
+     (2 4 1 1)
+     (9 1 1)
+     (8 1 1)
+     (6 5)
+     (6)
+     (8 5)
+     (10 1 1)
+     (10 5)
+     (10 1 1)
+     (9 1 1)
+     (6 1)
+     (2 1))
+    ((1)
+     (3 2)
+     (4 9 1 2 1)
+     (3 6 3)
+     (4 8)
+     (5 7 1)
+     (1 4 2 2)
+     (1 5 1 2)
+     (1 6 1 1 1 2)
+     (1 8 1 1 1 2 6)
+     (1 8 5 2 7)
+     (1 9 5 1 3 6)
+     (1 10 5 2 1 11)
+     (1 10 4 1 10)
+     (1 13 1 1 2 11)
+     (1 16 1 1 14)
+     (1 36)
+     (1 26 6)
+     (1 25 3)
+     (23)
+     (10 8)
+     (6)
+     (5)
+     (3)
+     ()
+     (3 1 5 5 5 5)
+     (1 1 1 1 1 1 1 1 1 1 1 1)
+     (1 1 1 1 1 5 1 1 1 1 1)
+     (1 1 1 1 1 1 1 1 1 1 1 2)
+     (1 3 5 1 5 3 1)))
+   ("19990715-TAN (7)"
+    ((17)
+     (2 2)
+     (2 6 6 2)
+     (2 6 6 2)
+     (2 5 5 2)
+     (2 9 1 6 2)
+     (2 4 9 2)
+     (1 5 3 4 1)
+     (1 9 4 6 1)
+     (1 4 5 3 1)
+     (1 3 4 2 1)
+     (1 7 6 3 1)
+     (1 5 1)
+     (1 4 2 2 7)
+     (1 3 1 1 3 2)
+     (1 3 1 3 5)
+     (1 3 1 2 6)
+     (1 5 1 2)
+     (1 7 2 2)
+     (1 4 4 1 2)
+     (2 2 2 4 1)
+     (2 2 1 2 4 1)
+     (2 3 3 3 1)
+     (4 7 1)
+     (2 3 1)
+     (1 1 4 2 1)
+     (6 2 6 1)
+     (1 1 1)
+     (1 4 3 2 4 1)
+     (1 4 2 4 4 1 2 1)
+     (1 3 2 4 2 1)
+     (1 3 8 12 1)
+     (1 11 11 1)
+     (2 9 9 2)
+     (2 8 8 2)
+     (2 5 5 2)
+     (2 2 2 2)
+     (2 13 2)
+     (2 2)
+     (17))
+    ((15 8)
+     (2 2 1 2)
+     (2 11 2 1 4 2)
+     (2 13 2 1 5 2)
+     (2 15 1 1 6 2)
+     (2 5 3 5 4 2 3 2)
+     (2 5 2 5 1 2 5 2)
+     (1 6 1 1 1 1 8 1)
+     (1 4 1 2 3 1 1 1 2 9 1)
+     (1 4 1 1 2 3 5 1 1)
+     (1 4 2 1 3 1 5 1 1)
+     (1 2 1 1 1 1 2 4 1 1)
+     (1 2 1 1 2 4 1 1)
+     (1 1 1 2 2 1 1)
+     (1 1 1)
+     (1 1 2 2 1 1)
+     (1 2 2 1 2 4 1 1)
+     (1 2 1 2 1 1 4 1 1)
+     (1 5 2 1 2 1 2 1 5 1 1)
+     (1 5 2 1 3 2 2 1 5 1 1)
+     (1 5 1 1 3 1 2 1 9 1)
+     (1 4 2 1 2 1 1 2 7 1)
+     (2 5 1 5 2 1 2 6 2)
+     (2 4 4 2 1 1 1 5 2)
+     (2 4 1 1 1 6 1 1 3 2)
+     (2 5 1 2 7 5 2)
+     (2 4 1 2 11 2)
+     (2 1 2 2)
+     (8 15)
+     ()))
+   ("19990803aDAH (8)"
+    ((30)
+     (1 1)
+     (1 2 2 3 2 3 1)
+     (1 1 1 1 1 1 1 2 1)
+     (1 2 3 1 1 2 1 1 1 1)
+     (1 3 2 1 1 7 1)
+     (1 1 1 1 1 3 2 1)
+     (1 3 6 1 2 2 1)
+     (1 2 1 1 2 1 1 2 1 1)
+     (1 1 2 1 6 1 2 1)
+     (1 6 2 3 2 1 1 1 1)
+     (1 1 1 3 3 6 1)
+     (1 2 3 2 1 3 1 1)
+     (1 1 2 2 2 4 1 1)
+     (1 3 3 7 3 1 1)
+     (1 3 1 8 3 3 1)
+     (1 1 16 4 1)
+     (1 4 12 1 1 1)
+     (1 1 10 2 1 1)
+     (1 1 1 3 9 1 1 1)
+     (1 5 7 4 2 1)
+     (1 1 7 4 1)
+     (1 6 1)
+     (1 6 1)
+     (1 6 1)
+     (1 6 1)
+     (12 6 10)
+     (12 6 10)
+     (12 6 10)
+     (12 6 10)
+     (12 6 9)
+     (10 7 7)
+     (8 3 1 1 3 6)
+     (7 3 2 1 2 2)
+     (3 2 3 3 5 1)
+     (1 5 2 1 2 2 2 1)
+     (1 1 1 1 3 1 3 1 1)
+     (1 3 2 3 4 2 2 3 1)
+     (1 1)
+     (30))
+    ((40)
+     (1 9 1)
+     (1 2 2 2 2 2 9 2 1)
+     (1 1 1 1 1 1 8 1 1)
+     (1 2 2 1 1 2 1 3 8 3 1)
+     (1 2 5 3 1 8 1 1)
+     (1 1 1 1 1 2 2 8 1 1 1)
+     (1 6 2 2 1 1 7 3 1)
+     (1 1 1 1 1 4 6 2 1)
+     (1 3 3 3 4 6 2 1 1)
+     (1 1 1 1 1 2 5 1 1 1)
+     (1 5 2 4 5 2 2 1)
+     (1 1 2 1 2 9 1 2 1)
+     (1 1 1 19 4 1)
+     (1 5 24 2 1 1)
+     (1 3 25 1 1)
+     (1 1 3 2 18 1 1)
+     (1 3 2 22 1)
+     (1 3 20 1 1 1)
+     (1 2 1 1 4 2 4 1)
+     (1 1 3 3 2 2 3 4 1 1 1)
+     (1 1 1 1 1 1 1 5 2 1 1)
+     (1 4 2 2 4 2 5 5 1)
+     (1 1 2 1 1 1 2 6 3 1)
+     (1 3 1 3 2 3 1 7 1 2 1)
+     (1 1 1 1 2 1 1 7 1 1 1)
+     (1 1 3 1 2 7 2 1 1)
+     (1 2 2 2 3 7 2 1)
+     (1 8 1)
+     (40)))
+   ("19990803bDAH (9)"
+    ((30)
+     (1 1 1 1 1 1 1 1)
+     (1 1 4 1 1 1 1 3 1 1 1)
+     (1 1 1 1 1 1 3 1 1 1)
+     (1 4 3 3 2 1 2 2 2)
+     (1 1 1 5 1 1 1 1)
+     (1 1 1 5 2 2 2 2)
+     (1 2 1 1 1 1 1 1 1 1)
+     (1 1 3 3 1 2 1 2 1 1)
+     (2 1 1 1 1 1 1 1 1 3 1)
+     (1 1 2 2 1 3 1 2 4 1 1)
+     (1 2 1 1 1 1 1 1 1 1)
+     (1 3 2 4 1 6 2 1)
+     (2 1 1 1 1 1 1 1)
+     (1 1 6 1 5 3 1 2)
+     (1 2 1 1 1 1 1)
+     (1 1 2 1 1 2 1 10)
+     (6 1 1 2 2 1 1 1 1)
+     (1 1 2 1 1 4 1)
+     (1 4 1 5 1 1 1 1 1)
+     (1 1 1 6 1 3 1 2 1)
+     (1 2 1 1 1 1 1 1 1)
+     (1 1 1 5 7 3 1 1)
+     (1 4 1 1 1 1)
+     (1 1 1 1 3 13 1)
+     (1 6 1 1 1 1 1 1 1 1 1 1)
+     (1 1 1 2 1 2)
+     (1 3 6 1 2 2 1)
+     (1 1 1 1 2 4 4 1)
+     (1 1 1 1 1 3 1 9 1)
+     (1 1 1 1 1 1 1 1 9 1)
+     (1 1 1 1 1 2 2 1 7 2)
+     (1 1 1 2 7 3)
+     (1 3 3 1 3 1 5 2)
+     (1 1 1 1 1 1 1 3 1 1)
+     (1 1 1 1 1 5 1 2 1 2 1)
+     (1 1 1 1 1 1 1 2 1)
+     (1 3 1 4 2 1 5 3)
+     (1 1 1)
+     (30))
+    ((1 38)
+     (1 1 1 1 1)
+     (5 1 1 1 1 3 3 1 3 1 2 2)
+     (1 1 10 1 1 1 1 1 1 1 1)
+     (1 3 1 1 1 1 1 5 3 1 1)
+     (1 1 4 2 1 4 5 1 1 1)
+     (1 1 1 1 1 5 3 1 1)
+     (1 3 3 1 1 5 4 1 1 1)
+     (1 1 1 5 1 1 1 1 3 5 1)
+     (1 3 1 1 1 1 1 1 6 1)
+     (1 1 3 3 1 1 7 3 1)
+     (1 5 3 1 1 1 2 1 1 1 1 1 1)
+     (1 1 1 1 4 2 1 1 1 1 1 1 1)
+     (1 4 2 3 1 1 1 3 5 1 1)
+     (1 1 1 1 1 2 4 1 1 1)
+     (4 1 6 1 2 1 1 5 1 1)
+     (1 1 1 2 1 2 1 1 8 1)
+     (1 1 2 6 1 1 1 1 1)
+     (1 1 1 1 1 4 1 2 2 3 4 1)
+     (3 1 3 1 1 6 1 1)
+     (1 3 3 2 6 1 2 7 2 1)
+     (3 1 1 3 1 7 1 1)
+     (1 3 1 1 3 3 1 3 7 1 1)
+     (2 2 5 1 1 1 1 7 1 1)
+     (1 2 2 1 5 2 7 2 1)
+     (2 2 2 2 1 1 1 1 6 2 1)
+     (1 3 1 3 1 1 1 2 3 2 1)
+     (3 5 1 7 1 1 1)
+     (1 1 1 1 1 1 3 1 1)
+     (40)))
+   ("19991021-BBA (10)"
+    ((3 2)
+     (5 2)
+     (5 5 2)
+     (5 1 3)
+     (1 3 3 9)
+     (3 5 1 3)
+     (3 3 1 5 2)
+     (3 5 1 1 2)
+     (3 5 3 2)
+     (4 5 1 2)
+     (6 5 2 2)
+     (5 3 7 2)
+     (4 3 9 2)
+     (3 4 13)
+     (1 6 1 8)
+     (8 4 2)
+     (2 3 2 2)
+     (1 1 1 1 1 2)
+     (4 2 2 2)
+     (3 4 1)
+     (2 3 1 1)
+     (2 2 2)
+     (10)
+     (10)
+     (1 1)
+     (9)
+     (9)
+     (8)
+     (8)
+     (8)
+     (7)
+     (7)
+     (2 2 4 3)
+     (1 1 4 4)
+     (9 4 4)
+     (7 4 3)
+     (1 1 1 5 3)
+     (5 9)
+     (5 9)
+     (3 4 5))
+    ((3)
+     (1 2)
+     (5)
+     (3 2 3)
+     (6 6)
+     (7 2 3)
+     (3 2 3 5)
+     (5 3 1 2)
+     (5 4 3)
+     (5 5 6 4)
+     (3 3 15 8)
+     (6 3 2 2 15)
+     (12 2 1 2 15)
+     (13 2 2 14)
+     (2 17 7 3)
+     (6 4 2 3 15)
+     (2 2 1 2 2 15)
+     (4 2 1 3 15)
+     (5 11 2 1)
+     (3)
+     (3)
+     (3 3)
+     (1 1 2 4)
+     (1 1 1 1 4)
+     (1 1 1 2 4)
+     (1 1 1 1 3)
+     (1 1 2 3)
+     (3 2)
+     (19)
+     (19)))))
+ ("Kajitani 35x25"
+  "k35x25"
+  (("19980530-GOS (1)"
+    ((16 14)
+     (13 12)
+     (10 10)
+     (9 1 3 2 1 9)
+     (9 1 1 1 1 1 1 1 8)
+     (9 1 1 1 1 1 3 7)
+     (8 1 1 1 3 1 1 1 2)
+     (8 2 1 1 1 1 1)
+     (8 1)
+     (7 2 4 2)
+     (7 2 2 4 1 1 5)
+     (6 2 3 1 1 3 3)
+     (5 3 4 3 2 1)
+     (5 2 2 2 2 2 1 1)
+     (5 2 2 2 2 1 4 5)
+     (1 2 6 4 6)
+     (2 4 1 6)
+     (2 3 2 5 7)
+     (3 2 1 9 7)
+     (3 3 9 8)
+     (7 7 8)
+     (4 9)
+     (2 1 11)
+     (4 4 12)
+     (14 14))
+    ((16 3)
+     (15 3)
+     (15 3 2)
+     (15 5 2)
+     (15 5 1)
+     (12 2 1)
+     (11 3 1)
+     (9 4 2)
+     (6 9 2)
+     (3 9 3)
+     (2 4 2)
+     (2 4 5 1)
+     (2 1 5 1)
+     (1 4 4 2 1 1)
+     (1 1 3 2 3)
+     (1 5 5 3)
+     (1 5 3)
+     (4 3)
+     (1 1 1 2 3)
+     (5 1 3 4)
+     (1 2 1 4)
+     (1 5 1 1 1 3 1)
+     (1 1 3 1 2 1)
+     (2 4 1 2)
+     (2 1 2 3)
+     (3 1 3 3)
+     (4 1 2 1 4)
+     (5 1 1 1 6)
+     (6 3 1 8)
+     (7 10)
+     (6 1 11)
+     (6 1 11)
+     (6 2 11)
+     (7 3 11)
+     (7 17)))
+   ("19980616-HEI (2)"
+    ((1 1 4 8 1)
+     (3 1 6 10 3)
+     (1 6 10 3)
+     (1 6 16)
+     (1 1 1 1 6 6 1)
+     (1 3 1 8 6 1)
+     (1 1 1 6 1)
+     (1 1 1 6 1 1 1)
+     (1 6 1 1 1)
+     (9 7 5 1 1 1)
+     (9 4 1)
+     (2 1 2 3 1)
+     (2 3 2 2 1)
+     (2 1 2 11)
+     (2 2)
+     (3 2 2 1 2 2)
+     (4 2 1 1 1 1 1 2)
+     (5 2 2 1 2 2 4)
+     (5 2 1 1 1 1 2 5)
+     (5 2 2 6)
+     (5 15 7)
+     (2 15 6)
+     (1 2 6 1)
+     (2 6)
+     (5 8))
+    ((1 1 6 1)
+     (1 4 1 6 1 1)
+     (2 1 6 1)
+     (2 1 9)
+     (1 1 8)
+     (4 1)
+     (1)
+     (1 9)
+     (10 10)
+     (2 2)
+     (1 2 4 2)
+     (5 2 1 1 2)
+     (6 2 1 1 2)
+     (6 2 1 2)
+     (6 5 4 2)
+     (6 2 1 2)
+     (5 2 4 2)
+     (1 2 1 1 2)
+     (2 1 2)
+     (9 2 2)
+     (10 10)
+     (11 9)
+     (12)
+     (13)
+     (14)
+     (4 1)
+     (4 1)
+     (3 1 1 4)
+     (3 1 1 1 5)
+     (1 1 6)
+     (11 7)
+     (1 1 8)
+     (3 1 1 1 8)
+     (3 1 1 4 1)
+     (4 1 4 1 1)))
+   ("19980716aGAS (3)"
+    (()
+     ()
+     (11)
+     (5 5)
+     (3 1 1 3)
+     (3 2 5 2 3)
+     (2 2 5 2 2)
+     (2 4 5 4 2)
+     (1 6 5 6 1)
+     (2 7 7 7 2)
+     (1 27 1)
+     (1 27 1)
+     (1 27 1)
+     (1 27 1)
+     (1 27 1)
+     (2 4 13 4 2)
+     (1 3 1 5 1 3 1)
+     (2 1 1 5 1 1 2)
+     (2 1 1 1 2)
+     (3 1 3)
+     (3 3)
+     (5 5)
+     (11)
+     ()
+     ())
+    (()
+     ()
+     (7)
+     (3 3)
+     (2 5 2)
+     (2 9 2)
+     (1 9 1)
+     (2 11 2)
+     (1 9 1 1)
+     (2 9 2)
+     (1 10 1)
+     (1 1 7 1)
+     (2 8 2)
+     (2 6 2)
+     (1 7 1)
+     (1 14 1)
+     (1 13 1)
+     (1 15 1)
+     (1 13 1)
+     (1 14 1)
+     (1 7 1)
+     (2 6 2)
+     (2 8 2)
+     (1 1 7 1)
+     (1 10 1)
+     (2 9 2)
+     (1 9 1 1)
+     (2 11 2)
+     (1 9 1)
+     (2 9 2)
+     (2 5 2)
+     (3 3)
+     (7)
+     ()
+     ()))
+   ("19990119-JAM (4)"
+    (()
+     (7)
+     (7)
+     (8)
+     (9)
+     (9)
+     (9)
+     (6 2)
+     (5 1)
+     (6 2)
+     (9)
+     (9)
+     (3 5)
+     (2 1 5)
+     (3 14 7)
+     (8 8 1 7)
+     (7 8 5 3)
+     (8 5 8 1 3)
+     (5 7 8 4)
+     (4 1 7 14)
+     (4 13 8)
+     (17 6)
+     (15 6)
+     (19)
+     ())
+    (()
+     ()
+     ()
+     ()
+     (17)
+     (21)
+     (12 8)
+     (11 1 7)
+     (12 5 3)
+     (7 9 1 2)
+     (6 9 4)
+     (7 7 7)
+     (11 6)
+     (3 7)
+     (10)
+     (10)
+     (10)
+     (4 5)
+     (3 4)
+     (4 5)
+     (10)
+     (1 8)
+     (1 4 2)
+     (1 4 1)
+     (7 2)
+     (10)
+     (10)
+     (3 6)
+     (2 1 5)
+     (3 5)
+     (7)
+     (5)
+     (3)
+     ()
+     ()))
+   ("19990208aFRA (5)"
+    ((1 24)
+     (31)
+     (1 29)
+     (3 28)
+     (3 2 27)
+     (2 2 8 8)
+     (2 2 5 11 7)
+     (3 6 2 1 2 6)
+     (9 2 1 2 5)
+     (8 2 1 3 5)
+     (4 2 1 3 4)
+     (3 26 3)
+     (2 28 2)
+     (2 29 2)
+     (1 30 1)
+     (30)
+     (35)
+     (3 3)
+     (5 5)
+     (2 2 2 2)
+     (5 5)
+     (3 3)
+     ()
+     (8 8 8 4)
+     ())
+    ((1 5 1)
+     (10 1 1)
+     (1 6 3 1)
+     (3 4 4 3 1)
+     (3 2 2 10 1)
+     (2 2 4 8 2 1)
+     (2 2 3 11 1)
+     (3 5 6 3 1)
+     (9 6 1)
+     (8 6)
+     (7 6)
+     (7 7 1)
+     (6 8 1)
+     (6 2 6 1)
+     (5 2 6 1)
+     (5 2 6 1)
+     (5 1 6 1)
+     (5 1 6 1)
+     (5 1 6 1)
+     (5 1 6)
+     (5 11)
+     (5 1 6 1)
+     (5 1 6 1)
+     (5 1 6 1)
+     (5 1 6 1)
+     (5 11 3 1)
+     (5 15 1)
+     (6 10 2 1)
+     (7 11 1)
+     (8 6 3)
+     (10 6)
+     (11 5 1)
+     (12 1 1)
+     (14 1 1)
+     (15 1 1)))
+   ("19990220aFRA (6)"
+    ((35)
+     (22 10)
+     (21 3 9)
+     (17 1 3 9)
+     (16 3 3 9)
+     (16 4 3 9)
+     (9 2 4 2 9)
+     (8 2 1 10)
+     (7 3 9)
+     (6 1 8)
+     (5 7)
+     (5 3 2)
+     (4 9 1 1)
+     (3 1 8 9 3)
+     (2 5 8 5 3 1)
+     (1 28 1 2)
+     (30 3)
+     (31 2)
+     (1 31 1)
+     (2 20)
+     (4 5 13)
+     (5 3 14)
+     (6 26)
+     (35)
+     (35))
+    ((16 7)
+     (15 2 6)
+     (14 4 5)
+     (13 5 5)
+     (12 7 4)
+     (10 7 3)
+     (9 8 2)
+     (8 8 2)
+     (7 7 2)
+     (6 6 3)
+     (6 1 5 4)
+     (6 1 10)
+     (6 12)
+     (6 12)
+     (7 12)
+     (8 12)
+     (4 2 12)
+     (3 3 1 12)
+     (3 3 1 11)
+     (3 3 11)
+     (4 3 10)
+     (2 1 10)
+     (1 4 2 10)
+     (1 5 2 10)
+     (1 5 1 7 3)
+     (2 1 7 3)
+     (9 7 3)
+     (10 7 3)
+     (11 7 3)
+     (14 4 3)
+     (13 1 3 3)
+     (12 3 2 3)
+     (11 3 1 1 3)
+     (12 1 3 3)
+     (13 5 3)))
+   ("19990220bFRA (7)"
+    ((35)
+     (8 9 3 1 4)
+     (7 9 3 3)
+     (6 8 3 3)
+     (6 8 4 4)
+     (1 4 4 2 4 5)
+     (1 3 3 15)
+     (1 1 1 2 1 4 1 4)
+     (1 2 1 1 2 5 2 1 4)
+     (1 4 2 2 4 5 2 4)
+     (1 5 5 5 15)
+     (1 6 6 1 1 2 2 1)
+     (1 7 7 1 1 1 2 1 1 1)
+     (1 6 6 1 1 1 2 1 1 1)
+     (1 7 7 1 1 1 1 1)
+     (1 8 8 1 2 2 1 1 1)
+     (1 8 8 1 1 1 2 1 1 1)
+     (1 8 8 1 1 1 2 1 1 1)
+     (1 8 8 1 1 1 1 1 1 1)
+     (1 8 8 15)
+     (1 7 7 15)
+     (3 5 5 17)
+     (5 3 3 19)
+     (7 1 1 21)
+     (8 22))
+    ((25)
+     (5 4)
+     (6 5 5 4)
+     (7 5 7 3)
+     (7 12 3)
+     (8 13 2)
+     (3 1 12 2)
+     (2 1 12 1)
+     (1 2 11)
+     (1 1 12)
+     (1 1)
+     (1 1 12)
+     (1 2 11)
+     (2 1 12 1)
+     (3 1 12 2)
+     (8 13 2)
+     (8 12 3)
+     (7 5 7 3)
+     (6 5 5 4)
+     (5 4)
+     (25)
+     (11 6)
+     (1 3 5 2 9)
+     (1 5 1 6)
+     (1 3 1 17)
+     (7 1 6)
+     (7 3 2 3 6)
+     (2 21)
+     (1 2 2 6)
+     (2 1 1 1 2 10)
+     (1 2 2 6)
+     (2 21)
+     (11 6)
+     (11 6 6)
+     (12 7)))
+   ("19990305-FRA (8)"
+    ((12 20)
+     (12 1 3 1 14)
+     (12 1 3 1 2 5 4)
+     (12 3 1 1 1 1 1 2 1)
+     (3 3 1 1 1 1 1 2 1 2)
+     (1 7 2 2 1 1 1 2 3)
+     (9 9 1 1 2 1 2)
+     (11 12 1 2 2)
+     (13 19)
+     (14 19)
+     (6 7 19)
+     (5 2 6 7 9)
+     (5 2 6 4 9)
+     (6 7 2 10)
+     (15 11)
+     (15 13)
+     (14 16)
+     (14 18)
+     (14 10)
+     (13 9)
+     (13 8)
+     (11 21)
+     (9 22)
+     (1 7 23)
+     (2 7 24))
+    ((6 13 2)
+     (5 15 1)
+     (5 17)
+     (4 20)
+     (4 20)
+     (4 6 12)
+     (4 5 2 11)
+     (4 5 2 11)
+     (4 6 12)
+     (4 20)
+     (4 17)
+     (5 15 1)
+     (2 13 2)
+     (2 3 10 3)
+     (2 6 4)
+     (5 3 4)
+     (4 9 4)
+     (14 1 4)
+     (1 7 1 4)
+     (5 7 2 4)
+     (1 6 2 4)
+     (12 2 4)
+     (3 5 3 4)
+     (2 1 6 3 4)
+     (3 4 4 4)
+     (11 6 4)
+     (3 12 4)
+     (3 3 17)
+     (25)
+     (2 17)
+     (5 19)
+     (4 1 18)
+     (3 3 17)
+     (25)
+     (2 1 16)))
+   ("19990909-PIP (9)"
+    ((8)
+     (2 2)
+     (5 2 2 5)
+     (1 3 1 1 3 1)
+     (1 1 1 1 1 1)
+     (2 2 2 3)
+     (8 3 6 3 6 1)
+     (1 1 10 1 1)
+     (1 1 3 2 1 1 1)
+     (9 1 6 1 9)
+     (8 1 3 1 1 2 1 8)
+     (9 1 1 1 1 1 2 9)
+     (9 2 1 1 1 1 9)
+     (8 2 1 1 1 1 1 8)
+     (8 1 1 1 1 1 2 8)
+     (8 2 1 1 1 1 1 1 8)
+     (8 1 1 1 1 1 1 2 8)
+     (8 2 1 1 1 1 1 1 8)
+     (7 3 1 1 1 1 2 7)
+     (1 1 1 1 1 1 2 1)
+     (1 4 1 1 3 1)
+     (1 10 1)
+     (1 6 1)
+     (2 2)
+     (6))
+    (()
+     ()
+     (13)
+     (3 10)
+     (1 1 10)
+     (1 1 10)
+     (1 1 10)
+     (1 1 10)
+     (2 1 10)
+     (2 1 10)
+     (3 3 2 2)
+     (2 1 6 1)
+     (3 1 2 3 1 4 1)
+     (2 3 1 1 1 1 2 1)
+     (2 2 2 1 1 3 1)
+     (1 2 2 1 1 1 3 1)
+     (1 2 1 1 1 1 1 1 2 1)
+     (1 2 2 1 1 1 1 3 1)
+     (1 2 1 1 1 1 1 1 2 1)
+     (1 2 2 1 1 1 1 3 1)
+     (1 2 1 1 1 1 1 1 2 1)
+     (2 1 1 1 1 1 1 2 1)
+     (2 3 2 1 1 1 3 1)
+     (3 1 2 2 1 1 3 1)
+     (2 1 6 1)
+     (3 3 2 2)
+     (2 1 10)
+     (2 1 10)
+     (1 1 10)
+     (1 1 10)
+     (1 1 10)
+     (1 2 11)
+     (2 1 10)
+     (2 10)
+     ()))
+   ("19991011aLLO (10)"
+    ((5 14)
+     (7 12)
+     (9 10)
+     (9 2 2)
+     (7 2 2)
+     (5 2 2)
+     (5 2 2)
+     (5 1 2 2)
+     (5 3 2 2)
+     (5 3 10)
+     (17 1)
+     (1 3 1 6 1 1)
+     (2 1 6 6)
+     (3 8 1 2 1 1)
+     (3 10 11 1 1)
+     (2 3 4 1 1)
+     (1 15 4 3 1 1)
+     (1 15 1 1 2 1 1)
+     (17 1 1 1 3 1 1)
+     (17 1 2 2 1 1)
+     (4 4 9)
+     (4 2 2 7 2 1 3)
+     (2 4 4 1 1 1 1 1 1 1)
+     (1 4 4 6 1 1)
+     (2 2 4))
+    ((3)
+     (3)
+     (2 3)
+     (4 4)
+     (2 11)
+     (4 1 2 2)
+     (11 3 4)
+     (12 1 4 4)
+     (12 1 4 2)
+     (12 1 4)
+     (11 1 4 2)
+     (4 1 2 4 4)
+     (2 1 2 4 4)
+     (3 2 4 2)
+     (4 2 4 1)
+     (3 2 4 3)
+     (1 2 4 1 1)
+     (1 1 4 3)
+     (1 1 1 4 1 1)
+     (2 1 3 3)
+     (18 3 1)
+     (10 3 1 1 1)
+     (3 1 2 2 1 1 1)
+     (3 1 2 1 1 1 1 1 1)
+     (3 1 2 1 1 1 1 1)
+     (3 1 2 1 1 1 1 1)
+     (3 1 2 1 1 1 1 1 1)
+     (3 1 2 2 1 1 1)
+     (10 3 1 1 1)
+     (22)
+     (2 9)
+     (1 1 2)
+     (10)
+     (1 2)
+     (10)))
+   ("19991013-KHO (11)"
+    (()
+     (1)
+     (1)
+     (5)
+     (1 4)
+     (7)
+     (5 1)
+     (2 3 3)
+     (4 1 1)
+     (5 1)
+     (17 2)
+     (20 3)
+     (21 3)
+     (12 8)
+     (10 7)
+     (8 7)
+     (5 6)
+     (3 1 4)
+     (2 2 6)
+     (1 2 2 3)
+     (1 1 2 2)
+     (2 1 2 2)
+     (2 1 2 2)
+     (1 2 1 1)
+     (2 2 2 2))
+    (()
+     (2)
+     (3)
+     (3 5 1)
+     (1 2 7 4)
+     (4 15)
+     (1 3 12)
+     (16 1)
+     (3 10 2 2)
+     (7 7)
+     (6)
+     (5)
+     (5)
+     (4)
+     (4)
+     (3)
+     (3)
+     (3)
+     (6)
+     (7)
+     (8)
+     (9)
+     (10)
+     (7 3 1)
+     (4 2 4)
+     (2 2)
+     (1 3)
+     (2 3 1)
+     (1 1 4)
+     (1 2)
+     (1 1)
+     (3)
+     ()
+     ()
+     ()))))
+ ("Kajitani 35x30"
+  "k35x30"
+  (("19980420-KVL (1)"
+    (()
+     ()
+     ()
+     (4)
+     (7)
+     (9)
+     (8 2)
+     (5 6)
+     (4 6)
+     (5 4 2)
+     (6 4 2)
+     (2 10 4)
+     (20)
+     (1 1)
+     (21)
+     (21)
+     (2 7 7 1)
+     (2 3 3 6 3)
+     (11 2 2 4)
+     (19 4 1)
+     (7 8 5 2)
+     (2 3 7 3 1)
+     (6 7 3 2)
+     (6 8 6 1)
+     (2 4 5 2 1 3 2)
+     (1 10 2 4 1)
+     (2 11 3 5 1)
+     (10 4 4 5 2)
+     (21 8)
+     ())
+    ((17)
+     (4 11 3)
+     (6 2 3 2 2)
+     (5 1 2 7 3)
+     (8 15)
+     (9 15)
+     (4 3 7 5)
+     (4 2 3 2 4)
+     (4 2 6 4)
+     (5 3 6 4)
+     (10 7 3 1)
+     (2 6 2 10)
+     (8 2 10)
+     (4 2 2 10)
+     (2 1 11 2)
+     (2 2 10 1)
+     (4 4 5 1)
+     (3 11 2)
+     (2 6 6)
+     (1 4 4)
+     (4 3)
+     ()
+     (1)
+     (2)
+     (3 2)
+     (4 1)
+     (7 1)
+     (3 8)
+     (1 7)
+     (6)
+     (4)
+     (3)
+     (3 1)
+     (2 3 2)
+     (4)))
+   ("19980716bGAS (2)"
+    ((5)
+     (5 4 1)
+     (8 5 4)
+     (10 4 7)
+     (10 13)
+     (10 9)
+     (10 9)
+     (10 9)
+     (10 2 9)
+     (10 2 9)
+     (10 6 9)
+     (10 6 9)
+     (10 1 4 1 9)
+     (10 3 4 3 9)
+     (10 10 9)
+     (10 12 9)
+     (10 10 9)
+     (10 6 9)
+     (10 1 2 1 9)
+     (10 2 9)
+     (10 2 9)
+     (10 2 9)
+     (10 9)
+     (10 9)
+     (10 9)
+     (14 9)
+     (8 4 9)
+     (5 5 8)
+     (2 4 5)
+     (5))
+    ((26)
+     (26)
+     (26)
+     (26)
+     (26)
+     (26)
+     (26)
+     (26)
+     (26)
+     (26)
+     (1 1)
+     (1 1)
+     (2 1 1 1)
+     (1 5 2)
+     (1 4 1)
+     (2 2 5 1)
+     (1 8 2)
+     (1 14 1)
+     (1 14 1)
+     (2 8 1)
+     (1 2 5 2)
+     (1 4 1)
+     (2 5 1)
+     (1 1 1 2)
+     (1 1)
+     (1 1)
+     (26)
+     (26)
+     (26)
+     (26)
+     (26)
+     (26)
+     (26)
+     (26)
+     (26)))
+   ("19981201-JAM (3)"
+    ((8 7 18)
+     (7 1 5 1 5 10)
+     (7 2 3 3 3 2 9)
+     (6 4 5 3 9)
+     (3 7 5 5 8)
+     (3 3 6 2 1 6 3)
+     (4 3 3 2 7 3)
+     (5 3 1 3 4 2 5 1 3)
+     (6 3 4 3 2 2 3)
+     (6 2 1 1 4 4 3 3)
+     (5 2 3 6 2 3 1 3 2)
+     (3 2 3 1 4 4 1 2 4 1)
+     (2 2 3 2 3 5 4 4)
+     (3 2 4 2 5 1 4 2 1)
+     (3 2 5 1 4 3 4 1 1)
+     (3 1 3 3 3 4 5 2)
+     (2 1 3 4 1 2 1 6 4 2)
+     (1 3 2 5 1 1 7 3 3)
+     (4 3 2 1 2 3 1 3 2)
+     (1 3 3 3 5 1 3 1)
+     (2 4 3 2 7 2)
+     (3 3 2 2 4 5 4 3 1)
+     (4 4 5 4 3 3 2)
+     (6 4 6 2 2 1 4 2)
+     (6 3 2 4 1 4 6 1)
+     (6 2 5 2 6 4)
+     (5 2 1 6 1 8 2)
+     (4 2 3 6 2 3 5)
+     (5 2 2 1 2 2 1 6)
+     (9 4 6 4 7))
+    ((18 11)
+     (17 1 10)
+     (12 3 2 9)
+     (4 5 5 8)
+     (4 1 4 1 2 5 4 2)
+     (4 2 2 2 1 1 3 3 1 1)
+     (3 3 2 4 2 2 1)
+     (1 2 5 2 5 5 1)
+     (5 3 3 1 2 5 1 1)
+     (1 5 1 3 2 1 4 3)
+     (2 5 3 2 3 2 1 2)
+     (3 3 1 1 3 3 2 3 1)
+     (3 2 3 4 2 3 3 2)
+     (3 2 2 1 3 1 2 2 2 2)
+     (2 1 2 2 3 2 3 3 1)
+     (1 4 4 1 1 5 3)
+     (5 1 6 1 1 5 2 1)
+     (1 3 2 4 1 1 5 1 1)
+     (2 2 2 2 3 1 2 3 1 1)
+     (3 2 1 1 6 4 2 1)
+     (3 6 1 6 2)
+     (3 2 2 5 2 5 2 2)
+     (2 3 3 3 3 4 4)
+     (1 5 3 1 5 2 5 1)
+     (1 6 3 6 1 4 2)
+     (2 4 2 1 5 2 3 2)
+     (4 4 3 2 4 3 1)
+     (5 3 6 1 3 1 3)
+     (5 2 1 6 1 1 2 2 1)
+     (5 1 4 6 4 2)
+     (5 6 6 5 3)
+     (5 4 2 2 5 3)
+     (10 4 1 1 1 2 3)
+     (11 1 4 2 4)
+     (12 7 4 4)))
+   ("19990205-FRA (4)"
+    ((11 23)
+     (10 1 11 4 2)
+     (9 3 9 1 1)
+     (8 5 8 1)
+     (7 7 7 1)
+     (6 9 6 1)
+     (5 11 6 2)
+     (4 13 6 3)
+     (3 15 6 4)
+     (2 17 6 5)
+     (1 6 6)
+     (1 1 1 13)
+     (1 2 2 13)
+     (1 3 3 5 5)
+     (1 5 5 4 4)
+     (1 6 6 4 4)
+     (1 7 8 3 4)
+     (1 8 8 3 1)
+     (1 7 3 7 3)
+     (1 6 5 6 3)
+     (1 5 7 5 3)
+     (1 4 9 4 3 1)
+     (1 3 11 3 3 3)
+     (1 2 13 2 13)
+     (1 1 15 1 13)
+     (1 17 13)
+     (1 13)
+     (35)
+     (35)
+     (35))
+    ((30)
+     (10 3)
+     (9 14 3)
+     (8 1 12 1 3)
+     (7 2 10 2 3)
+     (6 3 8 3 3)
+     (5 4 7 4 3)
+     (4 5 5 5 3)
+     (3 6 3 6 3)
+     (2 7 1 7 3)
+     (1 8 8 3)
+     (9 8 3)
+     (1 8 8 3)
+     (2 7 2 7 3)
+     (3 6 3 6 3)
+     (4 5 5 5 3)
+     (5 4 7 4 3)
+     (6 3 8 3 3)
+     (7 2 10 2 3)
+     (8 1 12 1 3)
+     (9 14 3)
+     (10 3)
+     (30)
+     (2 24)
+     (1 23)
+     (1 8 7)
+     (2 5 7)
+     (2 3 7)
+     (3 2 7)
+     (2 3 7)
+     (1 5 7)
+     (1 9 7)
+     (1 10 8)
+     (2 11 8)
+     (18 9)))
+   ("19991010aTPV (5)"
+    (()
+     ()
+     (12)
+     (7 7)
+     (8 4 8)
+     (3 3 3 3)
+     (3 4 8 4 3)
+     (4 10 4)
+     (11 11)
+     (9 4 9)
+     (9 9)
+     (1 18 3)
+     (3 14 7)
+     (1 3 2 2 2 3 1 1 3)
+     (2 1 10 1 1 3 1)
+     (3 1 1 1 1 1 1 1 3)
+     (4 1 1 1 1 1 2 1 2)
+     (3 3 1 1 1 3 1 1 2)
+     (5 14 6 3)
+     (7 2 2 2 10 1 2)
+     (22 6)
+     (18 2 2)
+     (12 3 2)
+     (2 1 2)
+     (1 1 2)
+     (1 1 2)
+     (2 3 1)
+     (3 3)
+     (5)
+     ())
+    (()
+     (3 4)
+     (5 6)
+     (17)
+     (2 4 1 1 3)
+     (2 1 5 5)
+     (2 1 4 5 3)
+     (2 1 6 5)
+     (3 1 6 5)
+     (4 6 5 3)
+     (13 5)
+     (2 4 5 5)
+     (1 1 2 1 2 1 1 3)
+     (1 1 2 1 12)
+     (1 1 2 1 4 5)
+     (1 1 2 1 2 1 1 3)
+     (2 4 5 5)
+     (21)
+     (4 6 1 1 3)
+     (3 1 6 5)
+     (2 1 6 5)
+     (2 1 4 5 3)
+     (2 1 5 5)
+     (2 4 1 1 3)
+     (17)
+     (5 2 2 6)
+     (3 3 2 1 3)
+     (1 6 1 2)
+     (3 2 1 1 1)
+     (2 9)
+     (1 1 3 2)
+     (3 1 1 1 1)
+     (12)
+     (8)
+     ()))
+   ("19991118-BDH (6)"
+    ((35)
+     (1 1)
+     (1 7 1)
+     (1 11 4)
+     (5 11 1 1)
+     (1 1 15 3 1)
+     (1 1 1 3)
+     (1 6 3 1)
+     (1 1 5 1)
+     (1 1 1 1)
+     (1 3 12)
+     (8 1)
+     (1 1)
+     (1 1)
+     (3 3)
+     (1 11 5 1)
+     (1 1 1 1)
+     (13 1 1)
+     (2 2 1)
+     (2 8)
+     (2 7 1)
+     (1 9 1)
+     (1 7 7 1)
+     (1 8 5 8 1)
+     (1 9 5 9 1)
+     (1 11 3 11 1)
+     (1 12 3 12 1)
+     (1 12 1 12 1)
+     (1 12 3 12 1)
+     (1 12 3 12 1))
+    ((30)
+     (1 1 1 1 4)
+     (1 1 1 2 1 4)
+     (1 1 1 1 1 5)
+     (1 4 1 1 1 6)
+     (1 1 1 1 1 7)
+     (1 1 1 1 1 8)
+     (1 1 2 1 1 8)
+     (1 1 1 1 1 8)
+     (1 4 1 1 8)
+     (1 1 1 1 8)
+     (1 1 1 1 8)
+     (1 3 3 8)
+     (1 3 1 5)
+     (1 4 2)
+     (1 4 2 2)
+     (1 4 2 4 2)
+     (1 4 2 7)
+     (1 4 2 4 2)
+     (1 4 2 2)
+     (1 4 2)
+     (1 3 1 5)
+     (1 3 8)
+     (1 1 3 8)
+     (1 1 1 1 8)
+     (1 1 1 8)
+     (1 1 1 8)
+     (1 2 1 2 8)
+     (1 1 1 5 8)
+     (1 3 1 1 1 7)
+     (1 1 1 1 1 6)
+     (1 3 1 1 1 5)
+     (1 1 1 1 2 1 4)
+     (1 1 1 1 1 1)
+     (30)))))
+ ("Kajitani 35x35"
+  "k35x35"
+  (("19981015aGAS (1)"
+    ((17)
+     (1 2)
+     (1 1 1)
+     (17 1)
+     (1 1 1)
+     (1 1 1)
+     (1 1 1)
+     (1 1 1 1 1)
+     (1 5 1 1)
+     (1 1 1)
+     (1 1 1)
+     (1 1 1)
+     (17 1)
+     (1 1 1)
+     (1 1 1)
+     (1 1 1)
+     (1 1 1 1 1)
+     (1 5 1 1)
+     (1 1 1)
+     (1 1 1)
+     (1 1 1)
+     (17 1)
+     (1 1 1 1 1 1 1 2 1)
+     (1 1 1 1 1 1 1 3 1)
+     (1 1 1 1 1 1 1 2 1 1)
+     (16 1 1)
+     (1 1 1 1)
+     (1 1 1 1)
+     (1 1 1 1 1 1)
+     (1 6 1 1 1)
+     (1 1 2 1)
+     (1 2 1 1)
+     (16 1 1)
+     (1 2)
+     (18))
+    (()
+     ()
+     ()
+     ()
+     ()
+     ()
+     ()
+     (8)
+     (2 3)
+     (19 1 1 1 1)
+     (2 1 2 2 1 1)
+     (1 1 1 1 1 1 1 1)
+     (1 1 1 2 2 2 1 1)
+     (1 1 1 1 1 1 1 1 1)
+     (1 1 1 2 2 1 1 1)
+     (1 1 2 1 2 1 1 1 1 1 1)
+     (1 1 1 1 1 2 2 1 1 1)
+     (1 1 1 1 1 1 1 1 2 1 1)
+     (1 1 1 1 1 2 2 1 1)
+     (1 1 2 1 2 1 1 1 1 1)
+     (1 1 1 2 2 1 1)
+     (1 1 1 1 1 1 1 1)
+     (1 1 1 2 9 1)
+     (1 1 1 1 2 1 1)
+     (1 1 1 3 1 1)
+     (1 32)
+     (1 1 1)
+     (2 1)
+     (32)
+     ()
+     ()
+     ()
+     ()
+     ()
+     ()))
+   ("19990202-SQU (2)"
+    ((3 3 3 2 3)
+     (3 3 1 1 3 1 1 1)
+     (3 1 1 1 3 3 2 1)
+     (3 1 1 3 1 1 1)
+     (3 3 3 2 1)
+     (3 3)
+     (26)
+     (2 3 3 2)
+     (2 5 3)
+     (2 3 4)
+     (30)
+     (1 3 1)
+     (1 2 1)
+     (1 16 1 2)
+     (1 16 2 1 3)
+     (1 2 2 2 5)
+     (1 2 2 5)
+     (1 2 2 3 1)
+     (1 2 2 2 2 1)
+     (1 2 2 2 1 2)
+     (1 2 2 1 3)
+     (1 2 2 5)
+     (1 2 2 2 5)
+     (1 2 2 4 3 1)
+     (1 2 2 4 2 1)
+     (1 2 2 2 1 2)
+     (1 2 2 1 3)
+     (4 2 2 7)
+     (1 1 16 5 1)
+     (1 1 16 4 1)
+     (1 1 3 1)
+     (1 27 1)
+     (1 1)
+     (1 1)
+     (35))
+    ((8)
+     (1 1)
+     (1 1)
+     (1 22 1)
+     (2 2 1 1)
+     (3 3 1 1)
+     (3 2 1 17 1 1)
+     (3 2 1 17 1 1)
+     (4 1 2 2 1 1)
+     (3 1 2 2 1 1)
+     (1 3 1 2 2 1 1)
+     (3 3 1 2 2 1 1)
+     (1 5 2 2 1 1)
+     (1 3 2 2 1 1)
+     (2 5 2 2 1 1)
+     (1 3 1 2 2 1 1)
+     (2 3 1 2 2 1 1)
+     (3 1 2 2 1 1)
+     (4 1 2 2 1 1)
+     (3 1 1 2 2 1 1)
+     (3 1 1 17 1 1)
+     (3 1 1 17 1 1)
+     (2 1 1 1 1)
+     (1 1 1 2 1 1)
+     (1 1 2 2 4 1 1)
+     (3 1 1 1 2 2 4 1 1)
+     (1 1 1 1 1 2 1 1)
+     (1 3 1 1 1 1)
+     (1 22 1)
+     (5 1 4 4 4 5 1)
+     (1 1 1 1 4 4 4 5 1)
+     (5 4 4 5 1)
+     (1 23 1)
+     (5 1 1)
+     (1 8)))
+   ("19990220-JOJ (3)"
+    ((35)
+     (13 6 14)
+     (12 4 13)
+     (11 2 12)
+     (10 11)
+     (5 5)
+     (5 6)
+     (6 7)
+     (7 8)
+     (8 1 1 1 1 1 1 9)
+     (6 1 3 1 1 3 1 7)
+     (4 1 1 1 1 1 1 5)
+     (2 1 2 1 1 2 1 3)
+     (3 1 3 1 1 3 1 4)
+     (4 1 3 1 1 3 1 5)
+     (5 1 1 1 1 6)
+     (6 1 3 1 1 3 1 7)
+     (5 2 1 1 2 6)
+     (4 2 3 4 3 2 5)
+     (3 1 4 4 1 4)
+     (4 1 2 2 1 5)
+     (6 1 1 7)
+     (8 1 2 2 1 9)
+     (8 2 3 3 2 9)
+     (9 1 6 1 10)
+     (10 1 1 11)
+     (13 14)
+     (11 1 1 2 1 1 12)
+     (12 1 1 1 1 13)
+     (11 12)
+     (10 11)
+     (8 9)
+     (7 4 4 8)
+     (6 14 7)
+     (5 16 6))
+    ((35)
+     (35)
+     (12 22)
+     (12 5 15)
+     (11 3 14)
+     (5 4 1 13)
+     (5 2 11)
+     (5 1 4 10)
+     (5 1 2 1 7)
+     (5 1 3 3 6 1)
+     (4 1 1 1 2 1 4 2)
+     (3 1 2 1 3 1 1 1 1 3)
+     (2 2 3 1 3 2 3 3)
+     (1 1 3 1 1 1 1 3)
+     (2 1 1 1 2 1 3)
+     (3 1 3 3 1 1 2)
+     (4 1 1 1 2)
+     (4 1 1 1 2)
+     (3 1 3 3 1 1 2)
+     (2 1 1 1 2 1 3)
+     (1 1 3 1 1 1 1 3)
+     (2 2 3 1 3 2 3 3)
+     (3 1 2 1 3 1 1 1 1 3)
+     (4 1 1 1 2 1 4 2)
+     (5 1 3 3 6 1)
+     (5 1 2 1 7)
+     (5 1 4 10)
+     (5 2 11)
+     (5 4 1 13)
+     (5 5 3 14)
+     (12 5 15)
+     (12 22)
+     (35)
+     (35)
+     (35)))
+   ("19990416-SNI (4)"
+    ((8 15 5)
+     (7 2 13 6)
+     (6 2 12 7)
+     (5 2 11 4 8)
+     (5 1 10 4 9)
+     (4 1 10 3 2 8)
+     (4 1 2 4 1 7)
+     (4 11 5 3 6)
+     (4 11 6 5 5)
+     (3 12 5 7 4)
+     (3 12 5 8 3)
+     (3 1 5 4 3 10 2)
+     (2 1 3 1 4 2 9 3)
+     (2 1 1 3 2 4 1 9 4)
+     (1 3 5 6 9 5)
+     (1 5 11 8 6)
+     (1 10 4 6 7)
+     (1 1 1 2 1 4 4 9)
+     (1 3 2 3 4 3 10)
+     (2 15 1 1 11)
+     (3 13 2 2 10)
+     (3 1 10 4 3 9)
+     (3 1 6 7 3 8)
+     (3 1 5 7 1 2 9)
+     (3 1 4 3 3 3 10)
+     (3 4 2 8 11)
+     (4 6 9 10)
+     (4 17 9)
+     (5 8 7 10)
+     (5 8 7 11)
+     (6 8 6 12)
+     (6 8 4 13)
+     (5 2 4 14)
+     (4 3 5 4 15)
+     (4 6 16))
+    ((35)
+     (14 16)
+     (12 2 1 15)
+     (9 8 9)
+     (5 3 3 7 5)
+     (3 2 3 1 3 2 2 2 1)
+     (2 2 5 3 12 2)
+     (1 2 1 8 1 13 2)
+     (2 2 11 13 1)
+     (1 3 11 13 2)
+     (4 5 3 6 6 2)
+     (6 4 1 8 2 5 2)
+     (6 4 2 2 4 3 5 2)
+     (6 5 2 6 6 2)
+     (6 9 5 3 2)
+     (6 10 12 1 1)
+     (6 1 10 9 2)
+     (5 1 3 8 13)
+     (4 2 4 5 3 9)
+     (4 1 7 1 3 9 1)
+     (3 2 6 3 3 8 2)
+     (3 1 5 6 8 3)
+     (2 2 3 11 4)
+     (2 2 2 10 4 5)
+     (1 1 2 10 1 3 1 6)
+     (1 1 1 10 3 1 3 7)
+     (1 10 5 12)
+     (3 9 18)
+     (5 7 19)
+     (7 5 20)
+     (9 3 21)
+     (10 1 22)
+     (11 23)
+     (35)
+     (35)))
+   ("19990520-TAM (5)"
+    ((1 1)
+     (1 1 2)
+     (1 1 1 1)
+     (1 1 1 1)
+     (1 1 1)
+     (1 1 18 2)
+     (1 1 20 2)
+     (2 2 2 14 2)
+     (2 2 3 2 2 3)
+     (6 6)
+     (5 2 2 5)
+     (3 4 4 3)
+     (3 4 4 3)
+     (3 2 2 3)
+     (1 3 3)
+     (2 24)
+     (1 1 4 1 1 1 1 1 1 1 1 3)
+     (1 24)
+     (1 24)
+     (2 24)
+     (2 24)
+     (1 2 2 2 2 2 1)
+     (1 2 2 2 2 2 1)
+     (24)
+     (1 2 2 2 2 2 1)
+     (1 2 2 2 2 2 1)
+     (26)
+     (26)
+     (26)
+     (26)
+     (26)
+     (2 2)
+     (2 2)
+     (2 2)
+     (2 2))
+    (()
+     (2 2)
+     (7 7)
+     (1 1)
+     (1 2 1)
+     (8)
+     (5)
+     (23)
+     (14 1 5)
+     (15 1 9)
+     (2 2 20)
+     (2 2 1 14)
+     (5 6 1 5)
+     (4 2 1 4 1 5)
+     (3 4 16)
+     (3 4 1 14)
+     (3 2 6 1 5)
+     (3 1 4 1 5)
+     (3 16)
+     (3 1 14)
+     (3 6 1 5)
+     (3 2 1 4 1 5)
+     (3 4 16)
+     (3 4 1 14)
+     (4 2 6 1 5)
+     (5 1 4 1 5)
+     (2 2 16)
+     (2 2 1 18)
+     (15 1 9)
+     (14 1 5)
+     (23)
+     (2 5)
+     (7)
+     (1)
+     (2)))
+   ("19990830-KHO (6)"
+    ((35)
+     (26 5)
+     (7 12 3 4)
+     (6 1 1 1 4 4 4)
+     (5 2 1 1 2 2 3)
+     (4 4 2 1 2)
+     (3 6 1 1 7 1)
+     (2 6 3 3 7)
+     (1 6 1 3 1 6)
+     (2 5 1 1 6)
+     (4 4 4 3)
+     (4 4 4 4)
+     (2 4 5 4 7)
+     (1 4 7 4 4 1)
+     (2 4 3 1 3 4 2)
+     (10 1 3 1 1 10)
+     (9 1 3 9)
+     (9 3 4 2)
+     (9 1 3 1 3 3 3 1)
+     (10 5 1 3 2 2)
+     (12 2 3 3 4 1 1 1)
+     (4 8 1 1 7 3 1)
+     (3 9 3 8 1 2)
+     (2 2 6 8 2 1)
+     (2 1 1 4 9 2)
+     (2 3 3 11)
+     (3 8 12)
+     (8 1 1 6)
+     (7 1 1 5)
+     (7 7 5)
+     (7 1 1 7 1 1 5)
+     (9 2 11 2 7)
+     (35)
+     (35)
+     (35))
+    ((9 22)
+     (8 21)
+     (7 2 8 9)
+     (6 4 7 3 8)
+     (5 4 6 2 1 8)
+     (4 2 6 1 2 8)
+     (3 1 10 9)
+     (2 2 3 15 4)
+     (2 22 4)
+     (2 12 8 1 3)
+     (2 9 5 1 4)
+     (2 8 4 1 4)
+     (3 4 2 1 1 3)
+     (4 1 2 1 4)
+     (3 1 2 3 1 1 1 4)
+     (4 2 1 3 1 1 7)
+     (3 2 2 1 3 1 6)
+     (3 1 5 3 1 6)
+     (3 2 2 1 3 1 6)
+     (4 2 1 3 1 1 6)
+     (5 2 3 1 1 6)
+     (5 1 3 7)
+     (4 4 3 4 1 4)
+     (3 8 5 4 1 4)
+     (2 1 9 3 7 1 3)
+     (2 2 10 8 4)
+     (1 3 21 4)
+     (1 2 5 14 1 3)
+     (1 1 2 3 5 5 4)
+     (1 4 3 3 5 4)
+     (2 4 2 2 2 11)
+     (4 3 2 1 2 12)
+     (5 2 2 2 2 10)
+     (6 1 4 4 11)
+     (7 7 12)))
+   ("19990904-PIP (7)"
+    ((29)
+     (27 1)
+     (1 1 2)
+     (2 2 1)
+     (1 1 28)
+     (1 2 1 1)
+     (1 4 9 1 9 1)
+     (2 1 1 1 1 1 1)
+     (1 1 1 1 3 1 1)
+     (2 2 1 1 1 1)
+     (1 1 4 1 2 1 1 1 1 1 1)
+     (1 2 1 1 1 1 1 1 1 1 1 1 1 1)
+     (1 4 1 2 1 1 1 1 2 1 1)
+     (2 1 1 1 1 1 1 1 1 1 1 1 1)
+     (1 1 1 1 2 1 1 1 1 1 1)
+     (2 2 1 2 2 1)
+     (1 1 4 1 1 1)
+     (1 2 1 1 1 13 1 1 1)
+     (1 4 1 1 1)
+     (2 1 2 13 2 1)
+     (1 1 1 1 1 1)
+     (2 2 1 1 1 1)
+     (1 1 4 1 1 1)
+     (1 2 1 1 1 1)
+     (1 4 1 1 1)
+     (1 1 1 1 1)
+     (2 1 1 1 1)
+     (1 1 1 1 3 1 1)
+     (1 2 1 1 1 1 1 1)
+     (1 4 9 1 9 1)
+     (2 1 1)
+     (28)
+     ()
+     ()
+     ())
+    ((28)
+     (2 1 1 1 1 1 1 1 1 1)
+     (3 1 1 1 1 1 1 1 1 1)
+     (2 1 1 1 1 1 1 1 1 1 1)
+     (2 1 1 1 1 1 1 1 1 1 1)
+     (2 1 1 1 1 1 1 1 1 1 1)
+     (2 1 1 1 1 1 1 1 1 1 1)
+     (2 1 1 1 1 1 1 1 1 1 1)
+     (2 28)
+     (2 1 1)
+     (2 1 10 1 11 1)
+     (2 1 1 1 1 1 1)
+     (2 1 1 3 1 1)
+     (2 1 1 5 1 1)
+     (2 1 1 1 1 1 1 1 1 1)
+     (2 1 1 1 1 1 1 1 1)
+     (2 1 1 1 1 1 1)
+     (2 1 1 3 1 1 1 1)
+     (2 1 2 1 1 1 1 2 1)
+     (2 1 1 3 1 1 1 1)
+     (2 1 1 1 1 1 1 1 1)
+     (2 1 1 3 1 1 1 1)
+     (2 1 2 1 1 1 1 2 1)
+     (2 1 1 3 1 1 1 1)
+     (2 1 1 1 1 1 1)
+     (2 1 1 5 1 1 1 1)
+     (2 1 1 1 1 1 1 1)
+     (1 1 1 1 2 2 1 1)
+     (5 1 3 1 1)
+     (1 1 1 1 1 1)
+     (1 10 1 11 1)
+     (1 1)
+     (28)
+     ()
+     ()))
+   ("19991007cKHO (8)"
+    ((3 3)
+     (3 3)
+     (3 4 3)
+     (3 1 1 3)
+     (5 3 5)
+     (1 3 7)
+     (1 3 3 2)
+     (1 3 4 2 2)
+     (1 2 2 1 2 3 2)
+     (1 1 1 1 2 1 3)
+     (1 1 1 2 5)
+     (1 2 1 1 2 6)
+     (1 3 1 2 6)
+     (3 1 2 8)
+     (3 3 1 2 6 3)
+     (3 1 3 1 7 3)
+     (3 1 3 1 5 4 3)
+     (1 3 3 3 3 1 5)
+     (1 3 7 3 7)
+     (1 3 7 1 3 5 2)
+     (1 3 5 3 1 1 5 3)
+     (1 1 2 1 2 1 2 1 1 1 2 5)
+     (1 1 1 1 2 1 2 1 1 1 2 3 2)
+     (1 1 1 1 1 3 1 1 1 1 2 1 3)
+     (1 1 1 1 1 2 1 1 1 1 2 5)
+     (1 1 2 1 1 1 1 1 1 1 2 6)
+     (1 2 1 1 3 1 1 2 1 2 6)
+     (3 1 1 7 2 1 2 6)
+     (3 1 1 5 3 1 2 4)
+     (3 1 5 3 1 5)
+     (3 3 3 3)
+     (3 3)
+     ()
+     ()
+     ())
+    ((12)
+     (1 1)
+     (3 6 2)
+     (1 1 1 1 1)
+     (2 2 2 1 2)
+     (1 1 1 1 1)
+     (2 2 4 2)
+     (1 2 1 1)
+     (12 1 13)
+     (2 1 1 1 1)
+     (3 4 2 1 13)
+     (1 1 2 2 1 4 2)
+     (2 2 1 1 2 3 2 5)
+     (1 1 2 1 1 2 4 4)
+     (2 2 2 1 5 1 5)
+     (1 2 1 6 2)
+     (1 1 1 23)
+     (1 1 1 1 1)
+     (1 1 1 23)
+     (1 1 12 1)
+     (2 2 4 7 2)
+     (1 1 2 6 1 2 1)
+     (2 2 2 7 2 1 2)
+     (1 2 2 6 1 1)
+     (4 7 13)
+     (12 2 1 1)
+     (12 1 13)
+     (1 1 12)
+     (2 1 3 2)
+     (1 2 2 5)
+     (2 3 2 6)
+     (1 2 2 5)
+     (4 2 6)
+     (12)
+     (12)))))
+ ("Kajitani 35x40"
+  "k35x40"
+  (("19980425-HUB (1)"
+    ((8 6 2 2 6)
+     (8 8 2 2 8)
+     (2 2 2 2 2 2 2)
+     (2 2 2 2 2 2 2)
+     (2 2 2 2 2 2 2)
+     (2 2 8 6 8)
+     (3 3 8 4 8)
+     (6 2 2 2 2 2)
+     (4 2 2 1 2 2 2)
+     (1)
+     (5 1 1 1 1 1 9)
+     (3 1 1 1 1 1 6)
+     (5 1 1 1 1 1 1 8)
+     (3 1 1 1 1 1 6)
+     (4 1 1 1 1 1 10)
+     (2 1 1 1 1 1 5)
+     (4 1 1 1 1 1 8)
+     (2 1 1 1 1 1 5)
+     (4 1 11 1 8)
+     (5 1 1 1 5 1)
+     (3 1 11 1 3)
+     (1 21 1 3)
+     (3 17 8)
+     (2 3 9 7 2)
+     (2 4 10 2)
+     (2 9 1 7 2)
+     (5 1 1 1 1 8 2)
+     (2 1 1 1 1 6 2)
+     (1 6 1 1 1 1 7 3)
+     (1 2 1 1 1 1 9 1)
+     (1 6 1 1 1 1 8 2)
+     (1 2 1 1 1 8 4)
+     (2 6 1 1 1 8 5)
+     (2 3 1 1 1 6 6)
+     (3 4 1 1 1 6 7)
+     (4 2 1 1 6 8)
+     (5 3 1 1 5 9)
+     (7 9 11)
+     (10 14)
+     (35))
+    ((2 2 9 12)
+     (2 3 9 6 8)
+     (2 3 5 1 1 1 9 6)
+     (2 2 1 1 1 1 1 1 1 7 5)
+     (2 2 1 1 1 1 1 1 4 4)
+     (2 3 1 1 1 1 1 1 3 3)
+     (8 2 4 1 1 1 1 1 4 3)
+     (7 2 5 1 1 1 1 2 2)
+     (1 2 1 1 1 1 2)
+     (8 1 2 1 1 2)
+     (9 1 2 1 3 1 1 1)
+     (2 2 2 9 1 1 1)
+     (2 2 1 4 1 1 1)
+     (2 2 6 1 1 1)
+     (2 2 3 4 4 2 1 1 1 1 2 1)
+     (9 2 1 4 1 1 1 1 1 1 1 1)
+     (8 1 4 2 1 1 1 1 2 1)
+     (2 7 1 1 1 1 1 1 1 1)
+     (4 3 4 1 4 2 1 1 1 1 2 1)
+     (6 1 4 1 1 1 1 1 3 1)
+     (3 1 3 1 1 1 1 1 3 1)
+     (4 1 2 2 1 1 6 2)
+     (4 2 6 1 1 1 7 2)
+     (3 2 3 1 2 12 2)
+     (6 1 1 13 3)
+     (4 1 1 1 1 12 3)
+     (1 1 1 11 4)
+     (8 1 1 1 1 1 1 11 5)
+     (9 1 1 1 1 1 1 10 6)
+     (2 2 5 1 1 6 2 7)
+     (2 2 9 2 2 8)
+     (2 2 9 2 2 9)
+     (2 2 9 2 2 9)
+     (9 9 7 10)
+     (8 10 5 11)))
+   ("19981020-MON (2)"
+    ((3 11)
+     (4 5 4)
+     (3 5 4)
+     (3 5 3)
+     (3 5 2)
+     (4 5 2)
+     (3 5 2)
+     (4 2)
+     (4 3 3 3 2 1)
+     (4 1 1 1 1 1 2 1)
+     (2 1 2 1 3 2 2)
+     (2 1 1 1 1 1 2 2)
+     (4 1 1 3 1 2 3)
+     (4 2 2)
+     (4 1 2 1 1 1)
+     (2 1 1 2 4 1)
+     (2 1 3 4 1 1 1)
+     (1 4 3 8 1)
+     (1 1 1 3 2 4 1)
+     (1 6 3 1 2 2 1)
+     (2 5 1 3 1 2 4 1)
+     (2 1 12 8 1)
+     (1 1 2 6 12)
+     (3 4 2 10)
+     (8 2 10)
+     (4 1 2 10)
+     (1 1 4 2 11)
+     (3 1 1 2 2 9)
+     (5 5 2 2 8)
+     (2 1 4 2 2 3 7)
+     (12 2 2 6)
+     (9 1 2 2 6)
+     (13 2 4)
+     (10 3 5)
+     (6 2 3 5)
+     (2 9 5)
+     (2 4 3 5)
+     (2 2 4 5)
+     (2 2 1 2 3)
+     (2 2 10))
+    ((2)
+     (1 1 4 1)
+     (2 2 5 3 3 3)
+     (2 2 4 6 5)
+     (5 2 3 7 1)
+     (5 2 7 3)
+     (3 2 10)
+     (2 9)
+     (34)
+     (13 2 4 1 4 3 1)
+     (6 3 1 6 1 3 4 3)
+     (37)
+     (5 3 2 2 1)
+     (5 5 1 1 2 2 1)
+     (5 1 1 2 2 2 1)
+     (4 2 2 2 2 2 1)
+     (3 2 2 2 2)
+     (2 1 1 7 2 2 3)
+     (1 5 9 2 2 3)
+     (1 1 1 7 2 3 3)
+     (1 2 2 2 4)
+     (1 5 1 2 2 4)
+     (2 1 1 2 2 2 4)
+     (3 3 2 2 4)
+     (4 2 2 4)
+     (33)
+     (32)
+     (2 11)
+     (5 12)
+     (1 15)
+     (16)
+     (4 2 2 10)
+     (3 2 7)
+     (2 6)
+     (13)))
+   ("19990202bLLO (3)"
+    ((8 20)
+     (2 2 2 2)
+     (1 1 1 1 1 2 1 1 3 1)
+     (1 4 3 1 1 1 1 1 1 1 2)
+     (1 1 1 3 3 2 1 1 1 1 2)
+     (1 1 1 3 1 1 1 1 1 1 1 2)
+     (1 1 1 1 1 1 1 2 2 2 3 1)
+     (1 1 1 1 2 2)
+     (1 1 1 1 20)
+     (1 1 1 1)
+     (2 1 1 2 6 6 6)
+     (1 1 1 1 1 1 1 1 1 1)
+     (2 2 1 2 1 1 2 1 1 2 1)
+     (2 2 1 1 1 1 1 1 1 1 1)
+     (2 2 1 1 1 1 1 1 1 1 1)
+     (5 5 1 1 1 1 2 1 1 1 1)
+     (1 2 2 1 1 1 1 1 1 1)
+     (1 2 2 1 6 6 6)
+     (5 5)
+     (2 2 6 6 6)
+     (2 2 1 1 1 1 1 1)
+     (2 2 1 1 1 1 2 1 1 1 1)
+     (2 2 1 2 1 1 1 1 1 1 1)
+     (2 2 1 1 1 1 1 1 1 2 1)
+     (2 2 1 1 1 1 2 1 1 2 1)
+     (2 2 1 1 1 1 1 1)
+     (2 2 6 6 6)
+     (1 1 1 1)
+     (2 1 1 2 6 6 6)
+     (1 1 1 1 1 1 1 1 1 1)
+     (1 1 1 1 1 2 1 1 2 1 1 2 1)
+     (1 1 1 1 1 1 1 1 2 1 1 2 1)
+     (1 1 1 1 1 1 1 1 2 1 1 1 1)
+     (1 1 1 1 1 1 1 1 2 1 1 1 1)
+     (1 4 1 1 1 1 1 1 1)
+     (1 1 6 6 6)
+     (2 2 4)
+     (8 8)
+     (3 4 5)
+     (3 4 5))
+    ((4)
+     (10 1 1 9)
+     (2 2 1 1 2 2)
+     (1 15 1)
+     (1 32 2)
+     (1 1 1 3)
+     (1 1 1 3)
+     (1 32 1 1)
+     (1 15 1)
+     (2 2 1 1 2 2)
+     (10 1 1 9)
+     (3 4 1)
+     (7 1)
+     (2 2 8 8 8 2)
+     (1 1 1 1 1 1 1 1 2)
+     (1 5 1 1 1 1 1 2 1 1 1 2 1 2)
+     (1 1 1 1 4 1 1 3 1 1 2 1 2)
+     (1 5 1 1 1 1 1 1 3)
+     (1 1 8 8 10)
+     (1 5 1 2)
+     (1 1 1 1 1 8 8 11)
+     (1 1 1 1 1 1 1 1 2)
+     (1 5 1 1 1 2 1 1 2 1 1 1 4 1 3)
+     (1 1 1 1 2 1 1 1 1 2 1 1 4 1 2)
+     (1 1 1 1 1 1 1 1 2)
+     (1 5 1 8 8 8 1)
+     (1 1 1 1)
+     (1 1 8 8 8)
+     (1 5 1 1 1 1 1 1 1)
+     (1 1 1 1 1 1 1 1 1 4 1 1 2 1)
+     (1 5 1 1 3 1 1 2 1 1 4 1)
+     (1 1 1 1 1 1 1 1)
+     (2 2 8 8 8)
+     (7)
+     (3)))
+   ("19990529aDRA (4)"
+    (()
+     ()
+     (3)
+     (5)
+     (7)
+     (7)
+     (6)
+     (7)
+     (6)
+     (5)
+     (7)
+     (2 9)
+     (1 3 10)
+     (2 16 4)
+     (2 15 4)
+     (2 2 2 5)
+     (4 4 2 5 12)
+     (2 1 1 8 1)
+     (2 1 5 2 1 1)
+     (2 1 5 2 1)
+     (2 1 2 6 1)
+     (2 1 7 1)
+     (2 1 7 1)
+     (14 8 11)
+     (2 1 8 1)
+     (2 1 10 1)
+     (2 1 11 1)
+     (2 1 6 5 1)
+     (2 1 5 4 1)
+     (2 1 3 4 1)
+     (9 4 7 4 7)
+     (2 4 4)
+     (2 4 4)
+     (2 4 3)
+     (2 4 4)
+     (2 3 3)
+     (2 3 3)
+     (2 5 4)
+     (2 4 3)
+     (2))
+    ((27)
+     (27)
+     (1 1 1)
+     (3 1 1 1)
+     (1 3 1 1)
+     (5 1 1)
+     (3 15)
+     (3 1 1 1)
+     (2 1 1 1)
+     (2 1 1)
+     (2 2 3 1 3)
+     (5 2 1 3 1 5)
+     (6 2 5 1 7)
+     (7 4 3 1 4 4 2)
+     (7 6 3 5 4 2)
+     (13 1 5 1 3 2)
+     (11 3 8 1 6)
+     (8 3 7 1 4)
+     (6 3 7 1 2)
+     (4 3 9 1)
+     (7 10 1)
+     (5 9 1)
+     (4 3 5)
+     (2 1 4)
+     (1 1 4)
+     (1 1 4 2)
+     (1 1 4 2)
+     (1 1 4 3)
+     (15 6)
+     (1 1 1 3)
+     (1 1 1 2)
+     (1 1 1)
+     (1 1 1)
+     (1 1 1)
+     (1 1 1)))))
+ ("Kajitani 40x30"
+  "k40x30"
+  (("19980501bGOS (1)"
+    (()
+     ()
+     ()
+     ()
+     ()
+     ()
+     ()
+     ()
+     ()
+     (37)
+     (37)
+     (1 1 1 1 2 2 2 1 1 1 1 2 2)
+     (1 1 1 3 1 1 1 1 2 1 3 1 2 1 1 1)
+     (1 1 1 3 1 1 3 2 1 3 1 1 2 3)
+     (1 1 1 3 2 1 2 6 2)
+     (1 1 1 3 1 3 1 2 1 4 7 1)
+     (1 1 1 3 1 1 1 1 2 1 4 5 1 1)
+     (1 1 1 1 1 2 2 2 1 2 6 2)
+     (37)
+     (6 3)
+     (6 5 1 4 1 6 3)
+     (6 3)
+     (37)
+     ()
+     ()
+     ()
+     ()
+     ()
+     ()
+     ())
+    (()
+     (14)
+     (2 5)
+     (5 8)
+     (2 5)
+     (14)
+     (2 5)
+     (2 2 2 1 1)
+     (2 2 2 1 1)
+     (10 1 1)
+     (2 1 1 1)
+     (2 2 4 1 1)
+     (2 1 1 1 1)
+     (10 1 1)
+     (3 2 2 1)
+     (2 2 2 1 1)
+     (3 2 2 1 1)
+     (10 1)
+     (2 1 1 1)
+     (5 4 1 1)
+     (5 4 1 1)
+     (2 1 1 1)
+     (10 1)
+     (2 1 1 1)
+     (2 2 2 1 1)
+     (2 2 2 1 1 1)
+     (10 1 1)
+     (2 5 1 1)
+     (5 1 1 1)
+     (2 5 1 1)
+     (10 1 1)
+     (2 1 5 1)
+     (2 6 1)
+     (10 1)
+     (3 2 2 1)
+     (2 2 2 5)
+     (3 2 6)
+     (14)
+     ()
+     ()))
+   ("19980501cGOS (2)"
+    (()
+     (3 4)
+     (6 6)
+     (1 8 7)
+     (2 2 16 2)
+     (3 2 16 2 2)
+     (5 5 1 5 2 3)
+     (8 4 1 5 5)
+     (15 3 4 8)
+     (2 12 1 16)
+     (3 25 2)
+     (3 19 3)
+     (16 3)
+     (3 6)
+     (3 5)
+     (2 1 4)
+     (4 4)
+     (2 4)
+     (10)
+     (10)
+     (9)
+     (9)
+     (7)
+     (7)
+     (3 3)
+     (3 3)
+     (4 4)
+     (5 5)
+     (5 5)
+     ())
+    (()
+     ()
+     (2)
+     (2 3 1)
+     (2 2 2)
+     (7)
+     (5)
+     (6)
+     (7)
+     (4)
+     (4)
+     (4)
+     (4 4)
+     (11)
+     (14 2)
+     (21 3)
+     (28)
+     (4 3 1 11)
+     (4 1 3 2 11)
+     (10 6)
+     (2 1 3 11)
+     (3 19)
+     (27)
+     (21 3)
+     (19 2)
+     (14)
+     (7 5)
+     (4 4)
+     (4)
+     (4)
+     (4)
+     (7)
+     (7)
+     (5)
+     (7)
+     (2 2 2)
+     (2 3 1)
+     (2)
+     ()
+     ()))
+   ("19980508-SDN (3)"
+    ((15 7 10)
+     (1 1 1 1 10)
+     (1 11 1 1 1 2 2)
+     (1 11 1 1 1 10)
+     (1 11 1 1 1 5 3)
+     (1 11 1 13 10)
+     (1 11 1 24)
+     (1 11 1 13 10)
+     (1 11 1 6 1 2 10)
+     (1 11 1 13 10)
+     (1 11 1 1 1 10)
+     (1 1 10)
+     (15 10)
+     (1 1 1 6 2 10)
+     (15 7 2)
+     (3 2 10)
+     (1 14 10 2)
+     (3 1 2 10)
+     (9 3 1 10)
+     (9 1 1 10)
+     (1 1)
+     (25 10)
+     (25 1)
+     (2 1 1 1 1 1 1 3 3)
+     (25 1 1)
+     (1 1 1 1 1 1 1 1 1 1 1)
+     (25 3)
+     (2 1 1 1 1 1 1 3 3)
+     (25)
+     (25))
+    ((15 9)
+     (1 1 1 4 4)
+     (1 9 3 2 1 1 2)
+     (1 9 1 1 2 2 3 2)
+     (1 9 3 2 4 4)
+     (1 9 1 1 2 2 1 1 2)
+     (1 9 4 3 2 3 2)
+     (1 9 8 4 4)
+     (1 9 4 3 2 1 1 2)
+     (1 9 3 2 2 3 2)
+     (1 9 3 3 4 4)
+     (1 9 3 1 2 2 1 1 2)
+     (1 9 1 1 1 2 3 2)
+     (1 3 1 4 4)
+     (15 1 2 1 1 2)
+     (1 2 3 2)
+     (5 1 4 4)
+     (5 1 2 1 1 2)
+     (5 1 2 3 2)
+     (11 1 4 4)
+     (1 5 1 2 1 1 2)
+     (1 5 1 2 3 2)
+     (1 3 1 1 4 4)
+     (1 3 1 1 7 4)
+     (1 5 2 1 9)
+     (8 2 1 1)
+     (3 1 1 2)
+     (5 1 2 1)
+     (5 1 1 1 1)
+     (1 1 1 1)
+     (20 1)
+     (20 1)
+     (2 17 1)
+     (2 11 5 1)
+     (2 11 5 1)
+     (2 1 9 5 1)
+     (2 1 9 1 3 1)
+     (2 11 1 3 1 5)
+     (20 3 2)
+     (20 5)))
+   ("19981027aMNT (4)"
+    ((2)
+     (2)
+     (8)
+     (2)
+     (1 2)
+     (1 2)
+     (5 2)
+     (1 10)
+     (1 2)
+     (1 2)
+     (1 10)
+     (7 10)
+     (1 10)
+     (1 4 4)
+     (1 18)
+     (24)
+     (24)
+     (18)
+     (34)
+     (24)
+     (32)
+     (40)
+     (17 12)
+     (17 6)
+     (21 5)
+     (20 1)
+     (19 2)
+     (18 2)
+     (17 2)
+     (32))
+    ((1 1)
+     (1 2)
+     (1 3)
+     (1 1 4)
+     (1 10)
+     (1 10)
+     (1 1 10)
+     (1 1 1 10)
+     (1 1 2 12)
+     (13 12)
+     (1 1 2 12)
+     (1 1 16)
+     (1 16)
+     (16)
+     (16)
+     (1 20)
+     (1 1 20)
+     (1 1 20)
+     (1 1 20)
+     (13 16)
+     (13 16)
+     (1 1 12 1)
+     (1 1 12 1)
+     (1 1 12 1)
+     (1 13 1)
+     (9 1)
+     (9 1)
+     (9 1)
+     (9 1)
+     (2 5 1)
+     (2 6 1)
+     (2 6 1)
+     (1 4 1)
+     (1 4 1)
+     (1 4 1)
+     (1 5 2)
+     (1 1 1 2)
+     (1 1 2)
+     (1 3)
+     (1 1)))
+   ("19981027bMNT (5)"
+    ((16)
+     (3 7 3)
+     (4 7 3)
+     (2 7 4 1)
+     (3 7 3 2)
+     (17 3)
+     (3 7 3 4)
+     (4 7 2 5)
+     (17 13)
+     (1 1 7 5 1)
+     (16 8 1 1 1 1)
+     (16 1 5 1 1 2 1)
+     (7 7 1 5 8 1)
+     (7 7 4 2 1 3 1 1)
+     (16 4 2 1 3 2 1)
+     (16 7 12 1)
+     (16 8 1)
+     (16 6 15)
+     (16 4 1 15)
+     (2 8 2 3 3 1 8 2)
+     (2 8 2 2 1 1 1 8 2)
+     (16 2 1 1 15)
+     (17 1 4 6 7)
+     (1 4 6 7)
+     (1 3 15)
+     (1 2 15)
+     (1 1 1 8 2)
+     (1 1 8 2)
+     (1 15)
+     (16))
+    ((14)
+     (1 13)
+     (2 9 2)
+     (3 9 2)
+     (4 13)
+     (5 13)
+     (3 1 13)
+     (4 1 2 9)
+     (2 4 2 9)
+     (3 4 13)
+     (9 13)
+     (1 6 13)
+     (1 6 9 2)
+     (9 9 2)
+     (9 13)
+     (6 1 13)
+     (6 2 1)
+     (3 4 12)
+     (3 3 2 11)
+     (7 3 7 1)
+     (1 3 12 4 1)
+     (1 2 7 3 1 3 1)
+     (4 8 3 1 4 1)
+     (3 13 9 1)
+     (15 1 1)
+     (1 1 13)
+     (8 2 5 2)
+     (2 1 1 2 5 2)
+     (5 1 13)
+     (2 4 13)
+     (2 4 13)
+     (1 6 5 6)
+     (1 2 1 5 6)
+     (1 1 1 13)
+     (1 3 13)
+     (1 2 13)
+     (1 1 2 5 2)
+     (1 2 5 2)
+     (1 13)
+     (14)))
+   ("19981228-BAU (6)"
+    ((5)
+     (7)
+     (3 3)
+     (2 2 2)
+     (2 2 2)
+     (3 3 2)
+     (2 2 2)
+     (2 2 2)
+     (3 3 3)
+     (2 2 2 2)
+     (2 2 4 2)
+     (3 3 6 3)
+     (2 2 2 2 2)
+     (2 2 3 2 2)
+     (3 3 5 3 2)
+     (2 2 2 2 2 2)
+     (2 2 2 2 2 2)
+     (3 3 3 3 3 3)
+     (2 2 2 2 2 2)
+     (2 2 2 2 2 2)
+     (3 17 3 3)
+     (3 17 2 3)
+     (2 3 2 2)
+     (2 3 3 2)
+     (26 2 2)
+     (26 2 2)
+     (2 4)
+     (2 3)
+     (29)
+     (27))
+    (()
+     ()
+     (5)
+     (7)
+     (3 4)
+     (4 2 2)
+     (3 2 2)
+     (4 2 2)
+     (3 2 2)
+     (4 3 2 2)
+     (3 5 2 2)
+     (4 3 2 2 2)
+     (3 4 2 2 2)
+     (4 3 2 2 2)
+     (3 4 3 2 2)
+     (4 3 5 2 2)
+     (3 4 3 2 2 2)
+     (3 3 4 2 2 2)
+     (2 4 3 2 2 2)
+     (2 3 4 2 2 2)
+     (2 3 6 2 2 2)
+     (4 3 4 2 2 2)
+     (2 3 3 2 2 2)
+     (3 3 5 2 2)
+     (4 4 4 2 2)
+     (4 3 6 2)
+     (3 4 4 2)
+     (4 3 3 2)
+     (3 4 2)
+     (4 3 2)
+     (3 4 2)
+     (3 4 2)
+     (3 7)
+     (4 3)
+     (3 2)
+     (7)
+     (5)
+     ()
+     ()
+     ()))
+   ("19990118-FRA (7)"
+    (()
+     (3 3)
+     (1 2 2 1)
+     (1 2 2 1)
+     (1 12 1)
+     (1 14 1)
+     (1 16 1)
+     (1 20 1)
+     (6 6 6)
+     (4 1 1 4 1 1 4)
+     (4 1 1 4 1 1 4)
+     (5 6 5)
+     (22)
+     (10 9)
+     (10 9)
+     (11 10)
+     (11 10)
+     (7 2 2 6)
+     (8 3 7)
+     (9 1 8)
+     (9 8)
+     (16)
+     (12)
+     (8)
+     ()
+     (1 1 4 4 1 1)
+     (2 2 1 1 1 1 1 1)
+     (1 2 1 3 1 1 1 1 1 1)
+     (1 1 1 1 1 2 2)
+     (1 1 4 4 1 1))
+    (()
+     ()
+     ()
+     ()
+     ()
+     ()
+     ()
+     ()
+     (8 5)
+     (1 11 1)
+     (1 13 1)
+     (1 14 1)
+     (1 16 1)
+     (1 4 11 5)
+     (5 2 11)
+     (4 11 5)
+     (4 2 5 6 1 1 1)
+     (5 7 5 1 1 1)
+     (14 5 1 1)
+     (9 2 1 4)
+     (9 2 3 5)
+     (9 2 1 4 1 1)
+     (5 7 5 1 1)
+     (4 2 6 5 5)
+     (4 5 5)
+     (5 2 11 5)
+     (1 4 11 1)
+     (1 16 1)
+     (1 14 1)
+     (1 13 1)
+     (1 11 1)
+     (8 5)
+     ()
+     ()
+     ()
+     ()
+     ()
+     ()
+     ()
+     ()))
+   ("19990123aFRA (8)"
+    (()
+     ()
+     (2)
+     (8)
+     (10)
+     (12 3)
+     (4 14 3)
+     (1 2 1 1 3)
+     (1 23)
+     (1 21)
+     (3 20)
+     (20)
+     (16)
+     (14)
+     (12)
+     (10)
+     (8)
+     (6)
+     (10)
+     ()
+     ()
+     (12 12)
+     (1 10 10 1)
+     (1 8 8 1)
+     (9 9)
+     (7 7)
+     (5 5)
+     (11 11)
+     ()
+     ())
+    (()
+     ()
+     ()
+     (2)
+     (1 1 1)
+     (2 1 1)
+     (3 5 1)
+     (1 2 7)
+     (1 1 7)
+     (2 1 7)
+     (2 1 7)
+     (4 7)
+     (6 5 1)
+     (1 6 3 1)
+     (2 7 2 1)
+     (3 8 1 1)
+     (4 9 1)
+     (4 11)
+     (4 11)
+     (5 11)
+     (5 11)
+     (4 11)
+     (4 11)
+     (4 9 1)
+     (3 8 1 1)
+     (2 7 2 1)
+     (1 6 3 1)
+     (6 5 1)
+     (4 7)
+     (4 7)
+     (3 7)
+     (3 7)
+     (3 7)
+     (3 5 1)
+     (2 2 1 1)
+     (1 1 1 1)
+     (2)
+     ()
+     ()
+     ()))
+   ("19990208bFRA (9)"
+    ((2 22)
+     (1 21)
+     (1 22)
+     (3 13 2 6)
+     (1 4 4 10 2 7)
+     (1 10 9 2 8)
+     (1 9 2 8)
+     (1 10 2 7)
+     (1 16 10 2 7)
+     (1 16 9 2 8)
+     (1 1 1 1 1 1 1 8 2 9)
+     (1 1 2 1 1 1 1 1 1 9 2 8)
+     (1 1 1 1 1 1 1 1 21)
+     (1 2 1 1 1 1 1 3 4 3)
+     (1 1 1 1 1 3 3 12 2)
+     (1 16 2 14 1)
+     (1 2 12 1)
+     (1 3 2)
+     (1 4 3)
+     (1 5 4)
+     (1 6 5)
+     (1 5 4)
+     (1 21)
+     (1 5 13)
+     (1 4 3 12)
+     (1 4 3 2)
+     (1 16 4 3 2)
+     (1 4 3 12)
+     (1 5 13)
+     (40))
+    ((30)
+     (1 1 1)
+     (2 8 1 1)
+     (1 2 1 1 1 1)
+     (1 2 1 1 1 1)
+     (2 8 1 1)
+     (1 2 1 1 1)
+     (1 2 3 1 1 1)
+     (1 2 1 1 1)
+     (1 8 1 1)
+     (1 2 1 1 1)
+     (1 6 1 1 1)
+     (1 2 1 1 1)
+     (1 8 1 1)
+     (2 2 1 1 1)
+     (1 2 1 3 1 1)
+     (1 2 3 1 1)
+     (2 8 1 1)
+     (1 2 1)
+     (30)
+     (30)
+     (15 13)
+     (14 12)
+     (13 1 5 2)
+     (13 3 1 1 4 1)
+     (13 3 1 4 1)
+     (13 3 1 4 1)
+     (10 2 3 2 2)
+     (5 2 1 1 3 3 3)
+     (4 2 4 3 3 3)
+     (3 6 2 3 3 3)
+     (5 2 1 1 3 3 3)
+     (4 2 4 3 3 3)
+     (3 9 3 3 3)
+     (13 3 3 3)
+     (13 3 1 3 3)
+     (13 1 6 3)
+     (14 7 3)
+     (15 13)
+     (30)))
+   ("19990208cFRA (10)"
+    (()
+     ()
+     (17 18)
+     (4 3 3 2 18)
+     (5 2 2 3 5 8 3)
+     (5 1 1 3 4 2 2 2)
+     (3 2 1 1 2 1 5 2 3)
+     (4 3 3 2 6 1 1 4)
+     (4 1 2 6 1 2 1 4)
+     (3 4 4 1 4 1 1 1 1 2)
+     (6 1 1 4 4 1 1 1 1 2)
+     (5 1 1 3 6 1 2 1 4)
+     (5 2 2 3 6 1 1 4)
+     (4 4 4 2 4 1 1 2)
+     (9 7 5 2 2 2 3)
+     (9 7 9 7)
+     ()
+     (9 7 9 7)
+     (4 2 2 2 7 1 1 5)
+     (3 3 1 1 3 1 8 6)
+     (8 6 9 7)
+     (5 3 5 3)
+     (5 3 5 3)
+     (6 4 6 4)
+     (6 4 6 4)
+     (6 4 7 5)
+     (6 4 7 5)
+     (7 5 8 6)
+     ()
+     ())
+    (()
+     ()
+     (14 11)
+     (14 11)
+     (14 11)
+     (4 2 6 2 8)
+     (1 3 4 2 1 9)
+     (2 2 2 3 1 2 5)
+     (2 1 1 3 1 2 1)
+     (3 1 1 4 2 1)
+     (1 3 6 3)
+     (1 1)
+     (1 3 6 3)
+     (3 1 1 4 2 1)
+     (2 1 1 3 1 2 1)
+     (2 2 2 3 1 2 5)
+     (1 3 4 2 1 9)
+     (4 2 6 2 8)
+     (14 11)
+     ()
+     (14 11)
+     (14 11)
+     (14 11)
+     (14 11)
+     (3 3 2 2 11)
+     (2 2 2 1 4 5)
+     (3 2 2 4 3)
+     (4 1 1 2 1 2 1)
+     (4 1 2 2 1 2 1)
+     (3 1 1 1 1)
+     (3 1 1 1 1)
+     (4 1 2 2 1 2 1)
+     (4 1 1 2 1 2 1)
+     (3 2 2 4 3)
+     (2 2 2 1 4 5)
+     (3 3 2 2 11)
+     (14 11)
+     (14 11)
+     ()
+     ()))
+   ("19990221aFRA (11)"
+    ((33)
+     (23 8)
+     (21 8)
+     (20 8)
+     (19 8)
+     (18 8)
+     (2 11 8)
+     (1 9 8)
+     (1 3 7 8)
+     (1 4 5 8)
+     (1 5 3 8)
+     (2 1 8)
+     (10 24)
+     (10 1 22)
+     (8 19)
+     (6 4 16)
+     (4 3 6 13)
+     (2 4 9 10)
+     (1 4 11 7)
+     (1 3 14 5)
+     (1 1 17 3)
+     (2 21)
+     (6 1 3 1 1 5)
+     (6 3 2 1 1 1 19)
+     (6 1 1 1 1 1 3 1 3 1 1 1)
+     (8 1 2 1 1 5 3 2 1 1 1 1)
+     (6 1 3 1 1 5 1 1 1 1 1 1)
+     (26 1 2 1 1 3)
+     (24 1 3 1 1 3)
+     (40))
+    ((30)
+     (7 7 9)
+     (6 5 8)
+     (6 3 5 2 8)
+     (6 3 4 4 8)
+     (6 3 4 3 8)
+     (7 2 3 3 1 1 3)
+     (8 1 3 2 2 1 1 3)
+     (9 2 1 3 1 3)
+     (10 2 13)
+     (11 7 3)
+     (12 1 8 6)
+     (11 9 5)
+     (10 2 10 4)
+     (9 3 6 3)
+     (8 5 14)
+     (7 6 5 3)
+     (6 8 13)
+     (5 9 4 3)
+     (4 11 4 1 5)
+     (3 12 3 5)
+     (2 14 11)
+     (2 8 6 10)
+     (1 8 7 10)
+     (9 8 3 1 1)
+     (8 12 1 1 1)
+     (7 10 1 1 1)
+     (6 9 7)
+     (5 8 1 1)
+     (4 7 2 4)
+     (3 6 3 3)
+     (2 5 4 2)
+     (1 4 1 1)
+     (3 7)
+     (2 1 1)
+     (1 7)
+     (1 1 1)
+     (1 1 3)
+     (1 3)
+     (7)))
+   ("19990401-JOJ (12)"
+    ((40)
+     (40)
+     (12 24)
+     (9 21)
+     (7 4 19)
+     (6 10 18)
+     (5 5 5 17)
+     (4 3 4 16)
+     (3 3 6 3 15)
+     (2 3 3 3 3 14)
+     (2 2 2 2 2 5 7)
+     (2 2 3 5 2 2 4 7)
+     (1 2 2 2 2 1 2 5 5 1)
+     (1 1 2 2 2 2 2 4 5 1)
+     (2 2 2 3 1 2 2 4 5 1)
+     (2 1 1 3 1 2 2 5 3 2)
+     (2 1 1 3 2 2 2 5 3 2)
+     (2 2 2 5 2 2 7 1 3)
+     (1 2 2 2 2 2 6 2)
+     (1 2 3 3 3 3 5 4 1)
+     (2 2 3 7 3 3 3 2 1)
+     (2 2 3 2 3 2 8 1)
+     (2 3 4 4 9 1)
+     (3 3 9 12 2)
+     (4 4 4 10 4)
+     (5 5 11 7)
+     (6 19 10)
+     (8 16 11)
+     (9 13 13)
+     (10 15))
+    ((14 12)
+     (12 10)
+     (9 4 7)
+     (8 10 6)
+     (7 4 5 5)
+     (6 3 3 4)
+     (5 3 7 3 3)
+     (4 3 4 4 3 3)
+     (4 2 3 3 2 2)
+     (3 2 3 4 3 3 1)
+     (3 2 1 2 2 2 3)
+     (3 2 2 2 2 2 4)
+     (2 2 1 2 2 2 2 3)
+     (2 2 1 1 4 2 2 3)
+     (2 2 1 1 4 2 2 3)
+     (2 2 1 1 1 1 2 2 3)
+     (3 2 2 2 1 1 2 3)
+     (3 2 1 2 2 2 1 3)
+     (3 3 2 4 2 2 4)
+     (4 2 2 2 2 4)
+     (4 3 3 3 2 4)
+     (5 3 5 3 5)
+     (6 3 2 3 5)
+     (7 4 4 6)
+     (8 9 5)
+     (9 4 1 5 1)
+     (11 3 4 1)
+     (13 4 4 2)
+     (21 4 2)
+     (20 3 3)
+     (20 4 4)
+     (10 7 3 4)
+     (12 4 4 4)
+     (15 1 5 5)
+     (17 5 5)
+     (18 1 2 5)
+     (17 4 6)
+     (15 1 2 6)
+     (12 4 7)
+     (10 18)))
+   ("19990525aKHO (13)"
+    ((2 3 1 1 2)
+     (9 2 3 3 4)
+     (4 21 1)
+     (5 2 1 5 2 2 2 2)
+     (3 2 2 4)
+     (4)
+     (2)
+     ()
+     (7)
+     (12 5)
+     (12 3)
+     (2 2 3)
+     (2 2 3)
+     (2 2 3)
+     (2 2 3)
+     (2 2 3)
+     (2 2 3)
+     (24)
+     (2 4 9 3 2)
+     (2 4 10 2 1)
+     (2 2 4 15 1)
+     (3 3 2 1 1)
+     (1 2 23 1)
+     (2 8 3 16 1)
+     (3 2 2 4 16)
+     (11 1 2 2 9 3)
+     (2 5 2 1 1 1 1 1 2 3)
+     (1 1 3 1 4 1 1 7 1 1 2)
+     (1 1 1 1 1 2 2 1 1 3)
+     (1 1 4 2 4))
+    ((8)
+     (2 4 1)
+     (3 2 2 1 1)
+     (5 2 2 1)
+     (5 1 3)
+     (4 1 4)
+     (1 1 1 3)
+     (3 1 2 1)
+     (4 1 1 1 1)
+     (4 4 1)
+     (2 5)
+     (2 2 1)
+     (2 2 1)
+     (2 19)
+     (1 16)
+     (2 2 1 3 4)
+     (4 2 4 1 2 2)
+     (5 2 4 1 1 1)
+     (3 2 4 1 1 1)
+     (2 2 4 1 2 2)
+     (2 2 1 3 4)
+     (3 16)
+     (4 12 6)
+     (1 4 4 1)
+     (2 4 4 1)
+     (4 4 4 1)
+     (4 4 4 1)
+     (2 4 4 1)
+     (2 4 4 1)
+     (3 1 4 5)
+     (2 1 2 4 2)
+     (2 11 1 3 1 1)
+     (4 11 1 3 1 1)
+     (4 11 1 4 2)
+     (2 2 1 2 5)
+     (1 10)
+     (2 1 4)
+     (5 3)
+     (2)
+     (1)))
+   ("19990527aDRA (14)"
+    ((11 27)
+     (10 2 25)
+     (9 2 2 23)
+     (8 8 21)
+     (7 5 5 19)
+     (6 11 19)
+     (6 1 4 3 1 10 7)
+     (6 3 5 2 8 2 6)
+     (6 5 2 3 6 5 5)
+     (6 2 4 4 4 4 3 4)
+     (6 5 2 4 2 11 3)
+     (6 2 5 2 1 2 4 4 3 2)
+     (6 5 2 4 2 13 1)
+     (6 2 5 4 2 1 4 6 1)
+     (6 4 2 3 3 2 8 1 1)
+     (8 5 2 4 3 5 3 1)
+     (10 3 1 5 1 2 2 5 1)
+     (12 1 6 5 5 1 1)
+     (14 7 6 1 5 1)
+     (23 6 7 1)
+     (1 1 2 1 1 1 2 2 3 3 1)
+     (1 3 2 1 2 1 2 1 4 4 5 1 1)
+     (1 3 2 1 2 3 3 1 5 1)
+     (1 3 1 2 2 1 6 4 2 5 2)
+     (1 1 2 1 2 1 4 5 1 3 4)
+     (29 1 6)
+     (30 8)
+     (40)
+     (40)
+     (40))
+    ((30)
+     (20 5)
+     (20 3 5)
+     (20 3 5)
+     (30)
+     (20 5)
+     (5 5 1 7)
+     (4 8 5 1 6)
+     (3 2 8 4 2 5)
+     (2 3 2 1 1 1 14)
+     (1 5 8 4 5)
+     (6 8 3 1 7)
+     (1 5 1 1 1 2 2 1 7)
+     (1 2 3 8 2 5)
+     (1 4 2 8 11)
+     (2 6 1 5)
+     (2 5 8 2 1 7)
+     (3 3 8 3 1 7)
+     (3 2 4 3 4 8)
+     (4 8 15)
+     (4 6 1 5)
+     (20 1 1 5)
+     (20 1 5)
+     (10 10)
+     (10 1 7 9)
+     (9 3 2 4 8)
+     (9 4 7 7)
+     (8 6 4 2 6)
+     (8 2 4 7 5)
+     (7 9 7 4)
+     (7 5 3 3)
+     (6 2 6 9 3)
+     (6 9 1 3 2 4)
+     (7 3 3 9 4)
+     (8 6 4 3 5)
+     (9 4 9 5)
+     (10 3 2 3 1 6)
+     (11 1 9 6)
+     (12 7)
+     (30)))
+   ("19990527eDRA (15)"
+    ((16 11 11)
+     (17 9 12)
+     (18 7 13)
+     (14 4)
+     (12 6 3 8 4)
+     (10 19 2 4)
+     (8 19 4 4)
+     (7 6 4)
+     (7 20 6 4)
+     (7 20 6 4)
+     (7 2 4 6 4)
+     (7 2 12 1 1 6 4)
+     (7 2 3 3 1 1 6 4)
+     (7 2 2 3 4 6 4)
+     (7 2 1 5 3 4 6 4)
+     (7 2 1 1 1 1 3 1 1 6 4)
+     (7 2 1 2 2 3 1 1 6 4)
+     (7 2 1 5 4 4 6 4)
+     (7 2 1 1 1 4 4 6 4)
+     (7 2 2 3 5 1 1 6 4)
+     (7 2 1 1 2 1 1 6 4)
+     (7 2 9 1 4 6 4)
+     (7 2 10 1 1 1 6 4)
+     (7 2 2 5 1 1 1 1 6 4)
+     (7 2 4 6 4)
+     (7 20 5 4)
+     (7 20 3 6)
+     (7 20 1 8)
+     (7 10)
+     (40))
+    ((30)
+     (30)
+     (30)
+     (30)
+     (30)
+     (30)
+     (30)
+     (7 1)
+     (6 20 1)
+     (6 20 1)
+     (5 1 2 3 1)
+     (5 1 2 9 2 3 1)
+     (4 2 2 3 1 3 3 1)
+     (4 2 2 2 5 3 3 1)
+     (3 3 2 1 1 2 1 3 3 1)
+     (3 3 2 1 2 1 1 3 3 1)
+     (2 3 2 1 1 2 1 3 3 1)
+     (1 1 3 2 1 5 4 3 1)
+     (2 3 2 1 1 3 3 1)
+     (3 3 2 1 3 2 3 1)
+     (3 2 2 9 3 3 1)
+     (3 3 2 10 3 1)
+     (3 3 2 13 3 1)
+     (3 3 2 3 1)
+     (3 2 20 1)
+     (3 3 3 2 2 1 4 1)
+     (2 3 3 2 2 1 4 1)
+     (1 1 3 20 1)
+     (2 3 1)
+     (3 2 21 1)
+     (3 2 20 2)
+     (3 1 21 2)
+     (3 1 20 3)
+     (3 21 3)
+     (3 20 4)
+     (3 4)
+     (30)
+     (30)
+     (30)
+     (30)))
+   ("19990613-FRA (16)"
+    ((40)
+     (40)
+     (8 2 23)
+     (18 18)
+     (22 14)
+     (27 12)
+     (27 12)
+     (3 1 11)
+     (3 1 1 10)
+     (3 1 2 9)
+     (3 1 8)
+     (3 1 3 8)
+     (3 1 1 1 8)
+     (3 1 3 4)
+     (3 1 7 4)
+     (3 7 4)
+     (3 1 7 4)
+     (3 4)
+     (5 13 6 7)
+     (4 3 11 3 4 3 6)
+     (4 3 11 3 4 3 6)
+     (5 13 6 7)
+     (40)
+     (1 4 2 2)
+     (40)
+     (40)
+     (40)
+     (40)
+     (40)
+     (40))
+    ((30)
+     (23 6)
+     (23 6)
+     (7 5 6)
+     (7 1 2 6)
+     (7 2 1 6)
+     (7 2 1 6)
+     (7 2 1 6)
+     (2 4 1 2 6)
+     (2 4 5 6)
+     (2 4 12)
+     (2 4 12)
+     (7 12)
+     (7 12)
+     (2 4 5 6)
+     (2 4 5 6)
+     (2 4 5 6)
+     (7 5 6)
+     (3 3 5 6)
+     (3 3 5 6)
+     (3 3 1 2 6)
+     (3 3 2 1 6)
+     (4 2 2 1 6)
+     (4 2 2 8)
+     (4 2 1 9)
+     (4 2 5 6)
+     (15 1 5 6)
+     (5 5 6)
+     (7 2 6 5 6)
+     (8 1 1 4 1 2 6)
+     (9 6 2 1 6)
+     (10 3 2 1 6)
+     (13 3 2 1 6)
+     (13 3 1 9)
+     (13 3 12)
+     (13 5 6)
+     (23 6)
+     (23 6)
+     (23 6)
+     (23 6)))
+   ("19990714aNEP (17)"
+    ((33)
+     (2)
+     (1 1 3 3 1 1 1 1 2 2 2 3)
+     (1 1 1 1 1 1 1 1 1 1 1 1 1 3)
+     (1 1 3 1 1 1 1 1 1 1 1 2 3)
+     (1 1 1 3 3 3 1 1 1 2)
+     (1 1 2)
+     (26 2)
+     (2 2)
+     (2 3)
+     (2 3)
+     (2 6)
+     (1 6)
+     (1 6)
+     (2 6)
+     (2 7)
+     (2 7)
+     (2 7)
+     (2 8)
+     (2 8)
+     (2 8)
+     (2 8)
+     (3 6)
+     (2 4)
+     (2 3)
+     (2 2)
+     (2 7)
+     (2 11)
+     (5 13)
+     (4 14))
+    ((1 3 4)
+     (1 1 2 2)
+     (1 3 2 2)
+     (1 2 2)
+     (1 4 2 2)
+     (1 1 1 1 2)
+     (1 4 1 2)
+     (1 1 2)
+     (1 4 1 2)
+     (1 1 1 1 1)
+     (1 1 1 1 2)
+     (1 1 2)
+     (1 4 1 2)
+     (1 1 1 2)
+     (1 4 1 2)
+     (1 1 2)
+     (1 4 1 1)
+     (1 1 1 1)
+     (1 4 1 1)
+     (1 1 2)
+     (1 4 1 1)
+     (1 1 1 1)
+     (1 2 1 1)
+     (1 1 1)
+     (1 6 1)
+     (1 1 2)
+     (1 1 3)
+     (1 1 3)
+     (1 1 5 3)
+     (1 4 10 4)
+     (1 3 19)
+     (3 21)
+     (2 20 4)
+     (20 4)
+     (3 11 4)
+     (2 11 4)
+     (1 3)
+     (2)
+     ()
+     ()))
+   ("19990729-DAH (18)"
+    ((16 16)
+     (11 6 11)
+     (9 16 9)
+     (7 7 9 7)
+     (5 4 3 4 5)
+     (4 4 3 4 4)
+     (3 3 3 3 3 3)
+     (2 4 3 7 4 2)
+     (1 3 3 11 3 1)
+     (4 3 7 3 4)
+     (3 3 7 3 3)
+     (3 3 7 3 3)
+     (3 3 8 3 3)
+     (3 3 9 3 3)
+     (3 3 9 3 3)
+     (3 3 10 3 3)
+     (3 3 9 3 3)
+     (3 3 8 3 3)
+     (3 3 8 3 3)
+     (3 3 7 3 3)
+     (4 3 7 3 4)
+     (1 3 11 3 3 1)
+     (2 4 7 3 4 2)
+     (3 3 3 3 3 3)
+     (4 4 3 4 4)
+     (5 4 3 4 5)
+     (7 9 7 7)
+     (9 15 9)
+     (12 6 11)
+     (16 16))
+    ((9 6 9)
+     (8 10 8)
+     (7 12 7)
+     (6 4 4 6)
+     (5 3 3 5)
+     (4 4 4 4)
+     (4 3 3 4)
+     (3 3 3 3)
+     (3 2 6 2 3)
+     (2 2 10 2 2)
+     (2 2 12 2 2)
+     (1 2 4 4 2 2)
+     (1 2 2 2 1 1)
+     (1 2 2 2 2 1)
+     (1 2 1 2 2 1)
+     (1 2 2 4 3 2 1)
+     (2 1 7 4 2)
+     (2 2 15 3)
+     (2 1 15 4)
+     (2 2 15 1 2)
+     (2 1 15 2 2)
+     (4 15 1 2)
+     (3 15 2 2)
+     (2 4 7 1 2)
+     (1 2 3 4 2 2 1)
+     (1 2 2 1 2 1)
+     (1 2 2 2 2 1)
+     (1 2 2 2 2 1)
+     (1 2 4 4 2 1)
+     (2 2 12 2 2)
+     (2 2 10 2 2)
+     (3 2 6 2 3)
+     (3 3 3 3)
+     (4 3 3 4)
+     (4 4 4 4)
+     (5 3 3 5)
+     (6 4 4 6)
+     (7 12 7)
+     (8 10 8)
+     (9 6 9)))
+   ("19990924-KHO (19)"
+    (()
+     (37)
+     (31)
+     (24)
+     (17)
+     (14)
+     (21 13)
+     (23 4)
+     (24 3)
+     (8 8 3)
+     (9 10 2)
+     (10 13 2)
+     (11 3 2)
+     (12 3 2)
+     (13 3 2)
+     (14 5 2 3)
+     (15 6 1 3)
+     (16 6 4)
+     (22 7)
+     (19 10)
+     (16 13)
+     (13 16)
+     (10 19)
+     (7 22)
+     (4 25)
+     (1 28)
+     (31)
+     (34)
+     (37)
+     ())
+    (()
+     (20)
+     (1 19 1)
+     (1 19 1)
+     (1 19 1)
+     (1 18 2)
+     (1 18 2)
+     (1 18 2)
+     (2 17 3)
+     (2 3 13 3)
+     (2 3 12 3)
+     (2 3 10 4)
+     (2 3 9 4)
+     (2 3 8 4)
+     (2 3 6 5)
+     (3 3 5 5)
+     (3 3 4 5)
+     (3 3 2 6)
+     (3 3 2 6)
+     (3 3 2 6)
+     (3 3 2 7)
+     (3 3 2 7)
+     (4 2 1 2 7)
+     (4 2 1 2 8)
+     (4 1 1 2 8)
+     (5 2 2 8)
+     (6 3 2 9)
+     (6 3 2 9)
+     (6 3 2 9)
+     (6 3 1 10)
+     (6 3 1 10)
+     (6 3 10)
+     (6 6 11)
+     (6 8 11)
+     (6 6 11)
+     (7 12)
+     (9 14)
+     (28)
+     (28)
+     ()))
+   ("19990928-BBA (20)"
+    ((3 2)
+     (1 2)
+     (3)
+     (3)
+     (1 2 27)
+     (1 1 1 2 3 3 2 2 1)
+     (3 2 1 2 1 1 3 2)
+     (1 1 2 1 1 1 3 3)
+     (1 1 3 3 1 1 3 1 3)
+     (3 1 5 2 1 1 3 2 3)
+     (5 8 8 1 5)
+     (3 1 5 1 4 1 5)
+     (1 1 3 1 1 2 1 5)
+     (1 1 1 3 1 1 1 2 3)
+     (1 1 1 1 2 1 3)
+     (1 1 1 1 2 3)
+     (1 3 1 1 1 1 3)
+     (1 1 1 1 1 1 3)
+     (1 1 1 1 1 1 1 1 3)
+     (1 1 1 1 1 1 1 1 1 3)
+     (2 1 1 3 15)
+     (2 2 5 2 1 5)
+     (1 1 1 2 3 1 1 4)
+     (1 5 1 2 3 3 2)
+     (1 3 1 3 2 1 1 1 1)
+     (1 1 1 1 1 2 1 3 1)
+     (1 6 1 7 1 1)
+     (1 1 1 2 3 1 2 2)
+     (1 7 1 13)
+     (1 2 3 2 4 2 1))
+    ((1 1)
+     (7 1)
+     (1 2 1 3)
+     (4 5)
+     (2 3 3)
+     (1 1 1)
+     ()
+     (26)
+     (1 1 2)
+     (1 3 1 7)
+     (1 5 1 1 2 1 2)
+     (1 7 11)
+     (1 5 1 1 1)
+     (2 3 1 1 5 1)
+     (4 1 1 2 4)
+     (1 4 2 1 2 1 3)
+     (2 5 3 3 3 1)
+     (3 1 1 1 1 2 1 1)
+     (2 1 2 1 1 1 2 3)
+     (1 1 1 1 1 3 1)
+     (2 1 2 7 1)
+     (3 1 9 2 5)
+     (2 1 3 1 1 1 1)
+     (1 11 1 3 1 2)
+     (2 3 2 2 1 1 2)
+     (5 6 2 2 2)
+     (1 2 2 2 1 1 2)
+     (3 3 3 1 3 3)
+     (2 2 2 1 1 2)
+     (1 5 2 1 2)
+     (1 3 3 3 2)
+     (1 16 1 1)
+     (1 18 2)
+     (26)
+     ()
+     ()
+     ()
+     ()
+     ()
+     ()))
+   ("19991011bLLO (21)"
+    ((9)
+     (4 2 4 3)
+     (6 2 5 2)
+     (5 12 4)
+     (1 13 7)
+     (3 3 5 3 4 2)
+     (4 4 2 4 1 5)
+     (1 4 8 10)
+     (2 7 4 1 4 1)
+     (7 4 1 6 3)
+     (4 4 8 5 1)
+     (2 4 1 3 4 4 1 2)
+     (11 9 5)
+     (3 2 6 1 5 1)
+     (3 4 1 4 5 2 1)
+     (1 5 5 3 1 2 1)
+     (7 2 8)
+     (5 1 1 1 3)
+     (4 1 1)
+     (4 1 1)
+     (3 1 1)
+     (3 1 1)
+     (3 1 1)
+     (3 1 1)
+     (3 1 1 10)
+     (3 1 1 2 2)
+     (4 1 1 5 4 5)
+     (5 6 1 1 2 1 1)
+     (5 1 4 1)
+     (8 1 1 2 2 1 1))
+    ((7 3 1)
+     (1 2 7)
+     (7 2 3 1)
+     (4 2 4 2 1)
+     (5 6 2 4)
+     (2 6 19)
+     (5 22)
+     (3 3 1 1 16)
+     (1 6 3 1 4 3)
+     (2 3 4 2 3 1)
+     (1 8 6)
+     (8 3 1 1)
+     (2 3 9 1)
+     (5 2 1 5)
+     (15 1 1)
+     (1 2 2 1 3 2 11)
+     (8 5 2 1)
+     (5 7 3 1)
+     (1 2 1 2 3 12)
+     (7 6 1)
+     (4 3 4 1)
+     (10 4)
+     (2 3 4 3 1)
+     (3 1 1 1 2 2 1)
+     (8 2 1 1 1)
+     (2 2 2 2 1)
+     (1 2 1 1 1)
+     (2 1)
+     (2 1)
+     (3 2)
+     (1 3)
+     (1 3)
+     (3 2)
+     (2 1)
+     (1)
+     (1 1)
+     (2 1)
+     (1 1)
+     (2 1)
+     (1)))))
+ ("Kajitani 40x35"
+  "k40x35"
+  (("19981012-TAB (1)"
+    ((12 13 13)
+     (9 10)
+     (12 13 13)
+     (9 10)
+     (13 9 14)
+     (12 13 13)
+     (12 13 13)
+     (11 15 12)
+     (11 11 12)
+     (11 5 12)
+     (11 1 12)
+     (11 12)
+     (12 13)
+     (13 14)
+     (14 15)
+     (16 17)
+     (18 19)
+     (18 1 19)
+     (18 19)
+     (16 3 17)
+     (14 3 3 15)
+     (13 11 14)
+     (12 6 6 13)
+     (11 7 7 12)
+     (11 6 6 12)
+     (11 5 5 12)
+     (11 4 4 12)
+     (11 3 3 12)
+     (12 1 1 13)
+     (12 13)
+     (13 14)
+     (9 10)
+     (12 13 13)
+     (9 10)
+     (12 13 13))
+    ((35)
+     (35)
+     (35)
+     (35)
+     (35)
+     (35)
+     (35)
+     (35)
+     (35)
+     (1 1 27 1 1)
+     (1 1 27 1 1)
+     (1 1 3 11 3 1 1)
+     (1 1 9 5 1)
+     (1 1 3 7 7 1 1)
+     (1 1 4 5 7 1 1)
+     (1 1 5 5 6 1 1)
+     (1 1 5 3 6 1 1)
+     (1 1 6 3 5 1 1)
+     (1 1 6 5 1 1)
+     (1 1 7 1 1 1 1 1)
+     (1 1 6 5 1 1)
+     (1 1 6 3 5 1 1)
+     (1 1 5 3 6 1 1)
+     (1 1 5 5 6 1 1)
+     (1 1 4 5 7 1 1)
+     (1 1 3 7 7 1 1)
+     (1 1 9 5 1)
+     (1 1 3 11 3 1 1)
+     (1 1 27 1 1)
+     (1 1 27 1 1)
+     (35)
+     (35)
+     (35)
+     (35)
+     (35)
+     (35)
+     (35)
+     (35)
+     (35)
+     (35)))
+   ("19981216-JTR (2)"
+    ((40)
+     (14 10 14)
+     (3 7 8 7 3)
+     (2 1 1 4 8 4 2 2)
+     (1 2 4 1 4 6 4 5 1)
+     (2 1 4 4 4 2 1 1)
+     (3 2 2 1 3 4 3 1 2 2 3)
+     (2 1 2 3 1 3 2 3 1 1 1 2 1)
+     (1 2 3 1 2 2 2 1 3 1 2 1)
+     (2 3 2 2 1 1 2 1 1 2 2 2 2)
+     (1 1 1 1 1 2 1 1 1 1 1 1 1 1 1)
+     (2 6 1 1 1 1 6 1 2)
+     (1 1 2 1 3 1 1 1 1 1 2 1)
+     (1 1 4 2 1 2 2 6 1 1)
+     (2 2 1 1 4 2 1 3 1 1 2)
+     (3 3 3 1 2 1 3 2 3)
+     (4 2 1 3 2 5 3 4)
+     (5 2 7 2 1 3 3 5)
+     (6 2 2 2 6)
+     (5 7 2 7 5)
+     (5 5 1 2 1 5 5)
+     (5 2 1 1 1 2 1 1 5)
+     (4 1 1 1 5 2 6 1 2 4)
+     (4 1 4 1 1 2 1 1 4 4)
+     (4 2 1 1 1 1 2 1 1 1 3 4)
+     (4 1 1 2 1 1 2 2 1 2 1 1 4)
+     (4 1 1 2 1 2 2 1 2 1 4)
+     (4 2 1 1 1 1 1 1 2 1 2 4)
+     (5 3 1 1 2 2 1 1 2 5)
+     (6 1 1 1 8 1 2 1 6)
+     (7 5 8 1 7)
+     (8 10 8)
+     (40)
+     (40)
+     (40))
+    ((5 23)
+     (4 5 21)
+     (3 1 2 1 2 20)
+     (2 3 2 2 19)
+     (2 1 1 1 1 1 5 7)
+     (2 1 3 1 1 1 1 3 6)
+     (2 2 4 1 3 2 2 1 5)
+     (2 1 2 1 1 3 3 3 4)
+     (3 1 3 1 2 1 2 2 3)
+     (3 2 1 5 1 1 2 3 1 3)
+     (3 1 3 1 1 1 1 1 1 2 1 1 3)
+     (4 1 2 2 1 1 1 1 3 2 3)
+     (5 1 2 2 2 1 1 2 1 3)
+     (6 1 2 1 1 1 1 6 1 3)
+     (1 5 1 1 3 1 1 1 1 3)
+     (2 4 1 1 2 2 2 3 3 4)
+     (4 4 1 1 1 2 1 1 2 6)
+     (5 3 1 2 1 1 7)
+     (7 2 8)
+     (10 13 6)
+     (10 13 6)
+     (7 2 8)
+     (5 3 3 1 1 1 7)
+     (4 4 1 2 1 1 2 2 6)
+     (2 4 1 1 2 2 2 3 3 4)
+     (1 5 1 1 1 1 1 1 1 1 3)
+     (6 1 1 1 2 1 6 3)
+     (5 1 2 3 1 1 1 3 3)
+     (4 2 2 1 1 1 1 3 2 3)
+     (3 1 1 1 1 1 1 2 2 3)
+     (3 2 1 1 4 1 1 1 3 3)
+     (3 1 5 1 3 1 1 1 2 3)
+     (2 1 1 1 1 2 2 1 2 4)
+     (2 2 2 1 1 1 1 1 1 1 1 5)
+     (2 3 1 3 1 1 1 2 6)
+     (2 1 1 1 3 5 7)
+     (2 1 1 1 2 19)
+     (3 2 1 1 20)
+     (4 4 21)
+     (5 23)))
+   ("19990221-JOJ (3)"
+    ((40)
+     (5 33)
+     (3 33)
+     (2 6)
+     (2 5)
+     (2 4)
+     (2 5 2 3)
+     (2 6 4 2)
+     (2 2 2 6 2)
+     (2 2 2 2 2 3)
+     (2 6 2 2 4)
+     (2 5 6 5)
+     (2 2 6 5)
+     (2 2 2 2 4)
+     (2 2 2 2 3)
+     (2 2 2 2 2)
+     (2 2)
+     (2 3)
+     (2 4)
+     (2 5)
+     (40)
+     (40)
+     (2 1 1 3 2 1 2 2 3 1)
+     (1 2 5 1 2 5 2 2 1 2 1 3)
+     (3 4 4 3 2 2 1 1 1 1 1)
+     (1 2 6 6 2 2 2 1 2 1 3)
+     (2 1 3 3 3 3 2 3 1)
+     (40)
+     (40)
+     (10 1 2 2 1 9)
+     (9 5 2 2 2 2 12)
+     (10 3 2 2 2 10)
+     (12 2 2 2 2 2 12)
+     (9 3 2 2 2 2 9)
+     (40))
+    ((22 8)
+     (24 10)
+     (3 3 1 9)
+     (2 2 3 8)
+     (2 15)
+     (1 2 8)
+     (1 2 1 1 8)
+     (3 2 1 1 8)
+     (3 2 3 8)
+     (3 10 2 1)
+     (3 2 6 1 1 1)
+     (3 3 5 1 1 1)
+     (3 4 2 2 2)
+     (3 10 3 11)
+     (3 10 2 6 5)
+     (3 2 2 9 1)
+     (3 2 2 3 2 2 5)
+     (3 6 2 1 1 8)
+     (3 4 2 1 1 3 1)
+     (3 2 2 3 1 3)
+     (3 9 1 3)
+     (3 8 2 7 1)
+     (3 9 2 8)
+     (3 3 2 2 6 5)
+     (3 3 2 9 1)
+     (3 9 3 3 5)
+     (3 8 2 3 8)
+     (3 2 3 2 1)
+     (3 3 3 1 1 1)
+     (3 9 1 1 1)
+     (3 2 2 3 1)
+     (3 3 11)
+     (3 4 10)
+     (3 5 9)
+     (4 2 8)
+     (5 2 16)
+     (6 4 4 8)
+     (7 6 5 1 1 8)
+     (22 1 1 8)
+     (22 3 8)))
+   ("19990420-DRA (4)"
+    ((40)
+     (40)
+     (40)
+     (6 2 30)
+     (6 29)
+     (5 1 28)
+     (4 1 2 27)
+     (3 3 26)
+     (2 5 25)
+     (1 5 24)
+     (1 5 5 23)
+     (2 7 5 6 4 3)
+     (11 5 2 1 2)
+     (11 6 4 1)
+     (11 4 2 1)
+     (11 1 1 1 1 1)
+     (11 1 1 1)
+     (10 1 2)
+     (9 1 2)
+     (7 2 1 1)
+     (6 4 3 1 1)
+     (5 2 10 4 1)
+     (4 5 11 5 1)
+     (4 5 10 1 3 2)
+     (5 4 11 2 5)
+     (6 3 11 4 5)
+     (7 3 11 5 5)
+     (7 2 11 5 6)
+     (8 2 11 5 6)
+     (9 2 11 5 6)
+     (12 11 4 6)
+     (12 11 4 5)
+     (11 13 3 6)
+     (40)
+     (40))
+    ((35)
+     (9 24)
+     (8 23)
+     (7 24)
+     (6 12 11)
+     (5 11 10)
+     (3 10 9)
+     (4 1 9 2 7)
+     (4 9 3 6)
+     (3 1 7 6 5)
+     (4 5 5 14)
+     (5 5 10 2)
+     (6 5 1 2)
+     (7 6 2)
+     (8 6 7 3)
+     (9 6 13)
+     (10 4 14)
+     (11 4 14)
+     (11 14)
+     (11 14)
+     (11 14)
+     (12 14)
+     (12 15)
+     (12 15)
+     (12 15)
+     (12 3 4)
+     (12 3)
+     (11 4 2)
+     (11 11)
+     (11 12)
+     (11 10)
+     (12 7 2)
+     (13 2)
+     (13 3 2)
+     (12 1 5 4 3)
+     (11 1 20)
+     (11 3 14)
+     (12 4 2 1 11)
+     (13 2 12)
+     (35)))))
+ ("Kajitani 40x40"
+  "k40x40"
+  (("19980410-KVL (1)"
+    ((40)
+     (7 14 6 4)
+     (6 5 3 15 3)
+     (5 1 4 17 2)
+     (2 2 1 5 8 8 2)
+     (5 7 17 2)
+     (4 17 3)
+     (2 11 16 4)
+     (1 2 1 1 1 2 9 12)
+     (1 2 1 1 1 2 22)
+     (2 11 6 8 7)
+     (4 25)
+     (8 29)
+     (8 27)
+     (9 5 5 11 2)
+     (3 5 15 8)
+     (10 23)
+     (10 21)
+     (11 6 9 3)
+     (6 4 18)
+     (12 8 8)
+     (2 9 15)
+     (13 14)
+     (13 12)
+     (14 2 11)
+     (14 3 2 9)
+     (15 2 8)
+     (15 1 4 6)
+     (16 5 3 5)
+     (7 8 1 3)
+     (1 5 8 1 2)
+     (2 7 2)
+     (3 10)
+     (3 3 10)
+     (3 3 32)
+     ()
+     ()
+     ()
+     ()
+     ())
+    ((35)
+     (8 20 4)
+     (4 2 2 10 9 3)
+     (7 2 4 15)
+     (6 1 1 19 2)
+     (3 1 1 19 2)
+     (2 3 4 7 11 2)
+     (1 1 1 1 1 17)
+     (1 1 2 1 1 16 3)
+     (1 4 4 15 3)
+     (1 4 1 1 17)
+     (1 4 1 1 1 15)
+     (2 3 4 1 13)
+     (3 1 1 2 11)
+     (6 1 1 3 9)
+     (7 2 4 7)
+     (2 4 2 5 5)
+     (8 7 3)
+     (17 2 1)
+     (14 3 1 1)
+     (19 1 1 1 1)
+     (19 1 5 1)
+     (4 15 4 1)
+     (10 10 2 1)
+     (21 2 2 1)
+     (14 7 2 1 1)
+     (1 16 4 1 1)
+     (8 14 1)
+     (24 1)
+     (25 1)
+     (25 1)
+     (3 9 4 5 1)
+     (2 3 16 1)
+     (1 19 1)
+     (1 20 1)
+     (1 21 1)
+     (2 11 10 1)
+     (3 8 15 1)
+     (31 1)
+     (31 1)))
+   ("19980512-SDN (2)"
+    ((18)
+     (26)
+     (20 2)
+     (2 9 2)
+     (1 1 2)
+     (2 2 2)
+     (2 2 10 2)
+     (1 1 18 2)
+     (2 18 3 2)
+     (13 2 1 2)
+     (2 1 2)
+     (2 1 2)
+     (2 1 2)
+     (2 1 2)
+     (4 1 2)
+     (11 1 2)
+     (18 1 1 2)
+     (2 8 1 1 2)
+     (1 1 1 1 2)
+     (2 2 1 1 2)
+     (2 2 8 2)
+     (1 1 16 2)
+     (2 19 2)
+     (13 2)
+     (2)
+     (2)
+     (2)
+     (2)
+     (2)
+     (13)
+     (24)
+     (22 2)
+     (2 8 2)
+     (1 1 2)
+     (2 2 2)
+     (2 2 11)
+     (1 1 22)
+     (2 21)
+     (13)
+     ())
+    (()
+     (2)
+     (6)
+     (2 2 2)
+     (1 1 6 2)
+     (1 1 2 2 6)
+     (2 2 1 1 2 2)
+     (8 1 1 1 1)
+     (2 2 2 2 2 1 1)
+     (2 2 8 2 2)
+     (2 2 2 2 2 8)
+     (2 2 2 2 2 2 2)
+     (2 2 2 2 2 2)
+     (2 2 2 2 2 2)
+     (3 2 2 2 2 2)
+     (2 3 3 2 2 2)
+     (2 2 2 2 3 2)
+     (2 2 2 3 2 2)
+     (2 2 2 2 2 3)
+     (2 2 2 2 2 2)
+     (2 2 2 2 2 2)
+     (2 2 2 2 2 2)
+     (3 2 3 2 2 2)
+     (2 3 2 2 2 2)
+     (2 2 2 2 2 2)
+     (2 2 10 2 2)
+     (2 2 2 3 2 2)
+     (2 2 2 2 3 2)
+     (2 2 2 2 2 2)
+     (2 2 2 2 2 3)
+     (2 4 2 2 2)
+     (2 3 2 2 2)
+     (2 16 2 2)
+     (2 2 2)
+     (2 2 2)
+     (2 2 2)
+     (2 2 2)
+     (2 2 2)
+     (37)
+     (37)))
+   ("19980716dGAS (3)"
+    ((40)
+     (18 18)
+     (17 17)
+     (16 4 16)
+     (15 6 15)
+     (14 8 14)
+     (13 10 13)
+     (12 12 12)
+     (11 5 5 11)
+     (10 5 5 10)
+     (9 6 6 9)
+     (8 7 7 8)
+     (7 8 8 7)
+     (6 1 1 10 6)
+     (5 2 4 15 5)
+     (4 3 3 15 4)
+     (3 4 1 1 16 3)
+     (2 5 1 2 5 8 2)
+     (1 6 3 5 8 1)
+     (1 4 7 1)
+     (1 6 9 8 1)
+     (1 7 8 9 1)
+     (2 6 19 2)
+     (3 5 1 17 3)
+     (4 4 2 16 4)
+     (5 3 2 5 8 5)
+     (6 2 2 4 6 6)
+     (7 1 3 4 4 7)
+     (8 2 2 2 8)
+     (9 2 2 1 9)
+     (10 16 10)
+     (11 14 11)
+     (12 12 12)
+     (13 10 13)
+     (14 8 14)
+     (15 6 15)
+     (16 4 16)
+     (17 17)
+     (18 18)
+     (40))
+    ((40)
+     (18 18)
+     (17 17)
+     (16 4 16)
+     (15 6 15)
+     (14 8 14)
+     (13 10 13)
+     (12 5 6 12)
+     (11 6 7 11)
+     (10 1 7 10)
+     (9 2 4 9)
+     (8 3 2 8)
+     (7 4 2 1 1 7)
+     (6 5 1 9 6)
+     (5 6 9 5)
+     (4 7 1 1 4 4)
+     (3 8 2 2 5 3)
+     (2 5 1 3 3 1 6 2)
+     (1 5 1 17 1)
+     (1 5 5 17 1)
+     (1 5 5 8 7 1)
+     (1 5 5 7 7 1)
+     (2 5 6 6 6 2)
+     (3 14 5 5 3)
+     (4 11 3 4 4)
+     (5 10 4 3 5)
+     (6 9 5 2 6)
+     (7 8 6 1 7)
+     (8 8 9 8)
+     (9 8 9 9)
+     (10 16 10)
+     (11 14 11)
+     (12 12 12)
+     (13 10 13)
+     (14 8 14)
+     (15 6 15)
+     (16 4 16)
+     (17 17)
+     (18 18)
+     (40)))
+   ("19980828-GOS (4)"
+    (()
+     (20)
+     (22)
+     (24)
+     (26)
+     (28)
+     (30)
+     (32)
+     (34)
+     (36)
+     (38)
+     (4 3 3 4 4)
+     (3 2 2 3 3)
+     (2 1 1 2 2 2)
+     (2 1 3 3 3 2 3 2)
+     (2 3 3 2 5 1 3 2)
+     (2 8 2 5 1 3 2)
+     (2 7 2 5 1 2 2)
+     (2 5 2 5 1 3)
+     (2 5 2 5 1 4)
+     (3 4 2 5 1 6)
+     (4 3 2 5 1 6)
+     (6 3 2 5 1 6)
+     (7 3 2 5 1 6)
+     (2 3 3 2 5 1 6)
+     (2 1 3 3 3 2 6)
+     (2 3 3 2 6)
+     (3 4 4 3 6)
+     (4 5 5 4 6)
+     (38)
+     (36)
+     (34)
+     (32)
+     (30)
+     (28)
+     (26)
+     (24)
+     (22)
+     (20)
+     ())
+    (()
+     (20)
+     (22)
+     (5 4 5)
+     (5 3 5)
+     (5 2 3 5)
+     (6 4 4 6)
+     (7 3 2 7)
+     (9 4 9)
+     (11 5 11)
+     (38)
+     (10 25)
+     (10 25)
+     (10 10)
+     (10 10)
+     (10 10)
+     (10 25)
+     (10 25)
+     (14 14)
+     (12 12)
+     (11 11)
+     (10 10 10)
+     (10 12 10)
+     (10 12 10)
+     (10 12 10)
+     (10 10 10)
+     (11 11)
+     (12 12)
+     (14 14)
+     (38)
+     (9 9)
+     (8 8)
+     (7 5 7)
+     (6 5 15)
+     (5 3 14)
+     (5 14)
+     (5 14)
+     (22)
+     (20)
+     ()))
+   ("19980926-JON (5)"
+    ((15 19)
+     (16 3 17)
+     (18 3 16)
+     (7 6 3 4 6)
+     (5 6 3 3 3 5 4)
+     (4 2 7 1 3 1 4 3 3)
+     (3 2 4 5 2 4 3 2)
+     (3 2 4 5 2 6 4 3 1)
+     (2 2 4 5 3 7 3 2 1)
+     (1 2 4 5 3 8 4 3)
+     (1 2 4 3 6 5 3 4 2)
+     (2 3 3 6 3 2 5 1)
+     (2 3 2 8 7 1)
+     (2 6 6 6 2)
+     (2 5 4 5 2)
+     (1 5 2 5 1)
+     (1 34 1)
+     (1 4 4 19 4 1)
+     (1 4 4 6 7 3 4 1)
+     (6 3 6 6 10)
+     (1 3 4 6 6 3 4 1)
+     (1 3 4 5 4 4 3 2)
+     (1 4 4 4 4 3 4 2)
+     (2 3 4 3 7 4 2)
+     (2 8 3 6 5 2)
+     (2 2 8 8 1 3)
+     (1 2 24 5)
+     (2 1 22 4)
+     (2 1 18 4)
+     (1 4 3 3 4 1)
+     (1 4 3 3 4 1)
+     (2 5 3 3 5 2)
+     (2 5 3 5 2)
+     (3 5 3 5 3)
+     (4 5 3 5 4)
+     (5 25 5)
+     (7 22 6)
+     (8 17 8)
+     (9 10)
+     (11 4 11))
+    ((11 11)
+     (9 13 9)
+     (8 5 1 7 7)
+     (6 5 8 5 6)
+     (5 3 14 4 5)
+     (4 2 24 4)
+     (4 2 12 3 5 4)
+     (3 2 10 2 2 4 3)
+     (3 1 5 2 11 4 2)
+     (3 6 3 12 4 1)
+     (3 4 3 12 3 1)
+     (3 3 4 3 7 3)
+     (3 2 4 1 3 4 3)
+     (4 5 16 3)
+     (4 6 16 3)
+     (3 7 9 6 3)
+     (3 2 3 7 3 3)
+     (3 1 6 5 3 3)
+     (1 3 8 3 3 6 1)
+     (2 11 3 6 1)
+     (5 7 3 6 1)
+     (1 4 4 3 3 3 3 1)
+     (1 3 7 5 3 3)
+     (2 6 7 6 3)
+     (6 5 9 6 3)
+     (5 5 16 3)
+     (5 4 13 3)
+     (4 1 3 5 6 3)
+     (3 2 3 2 8 2)
+     (3 4 3 12 3 1)
+     (3 6 2 8 3 4 2)
+     (3 1 9 6 3 4 2)
+     (3 2 10 1 4 5 3)
+     (3 3 16 5 3)
+     (4 3 24 4)
+     (4 4 14 7 5)
+     (5 4 6 7 6)
+     (6 6 1 9 7)
+     (7 14 9)
+     (9 11)))
+   ("19981120-VAL (6)"
+    ((8 7)
+     (10 2 2 2 2 2 2 2 8)
+     (8 1 1 1 1 1 1 1 1 7)
+     (8 7)
+     (8 7)
+     (40)
+     (10 3 3 3 3 3 9)
+     (9 1 1 1 1 1 7)
+     (8 1 1 1 1 1 1 1 1 1 6)
+     (7 3 3 3 3 3 3 5)
+     (7 1 1 1 1 1 1 1 1 1 5)
+     (7 3 3 3 4)
+     (6 1 1 1 4)
+     (6 3)
+     (6 2)
+     (5 2)
+     (7 2 2 2 2 2 2 2 2 2 2 2)
+     (5 1 1 1 1 1 1 1 1 1 1 1 1)
+     (5 1)
+     (5 1)
+     (5 1 2)
+     (5 1 1 2 3)
+     (5 2 2 8)
+     (6 4 4 8)
+     (6 3 2 2 3 8)
+     (6 3 1 1 3 8)
+     (7 4 4 8)
+     (7 1 8)
+     (7 4 4 8)
+     (8 3 1 1 3 9)
+     (8 3 2 2 3 9)
+     (9 4 4 10)
+     (9 2 2 10)
+     (9 1 1 11)
+     (10 11)
+     (11 12)
+     (12 13)
+     (13 14)
+     (15 15)
+     (17 17))
+    ((40)
+     (40)
+     (40)
+     (40)
+     (40)
+     (15 1 17)
+     (12 1 14)
+     (9 1 11)
+     (1 3 1 9)
+     (1 2 1 1 6)
+     (1 1 3 1 5)
+     (1 2 1 1 1 4)
+     (1 4 3 1 3)
+     (1 2 1 1 1 1 1 2)
+     (1 1 3 1 2 2 2)
+     (1 2 1 1 4 4 1)
+     (1 3 1 3 2 2 3 1)
+     (1 2 1 1 3 1 1 3)
+     (1 1 3 1 4 4)
+     (1 2 1 1 1 1)
+     (1 4 3 1 4 4)
+     (1 2 1 1 1 3 1 1 3)
+     (1 1 3 1 3 2 2 3)
+     (1 2 1 1 4 4 1)
+     (1 3 1 2 2 1)
+     (1 2 1 1 1 1 2)
+     (1 1 3 1 3)
+     (1 2 1 1 1 4)
+     (1 4 3 1 5)
+     (1 2 1 1 1 7)
+     (1 1 3 1 9)
+     (1 2 1 1 11)
+     (1 2 1 20)
+     (8 1 19)
+     (9 1 18)
+     (11 1 18)
+     (13 1 18)
+     (14 1 19)
+     (17 20)
+     (40)))
+   ("19981207-JTR (7)"
+    ((1)
+     (1)
+     (1 1 1 1)
+     (1 1 1 1 1 1)
+     (1 1 1 1 1 1 1 1 1 1)
+     (1 1 1 1 1 1 1 1 1 1 1 1 1 1)
+     (1 1 1 1 1 1 1 2 1 1 1 1 1 1 1)
+     (1 1 1 1 1 1 1 4 1 1 1 1 1 1 1)
+     (1 1 1 1 1 3 4 3 1 1 1 1 1)
+     (1 1 1 3 3 4 3 3 1 1 1)
+     (1 3 3 3 4 3 3 3 1)
+     (3 3 3 3 4 3 3 3 3)
+     (3 3 3 3 4 3 3 3 3)
+     (3 3 3 3 4 3 3 3 3)
+     (3 3 3 3 4 3 3 3 3)
+     (3 3 3 3 4 3 3 3 3)
+     (3 3 3 3 4 3 3 3 3)
+     (3 3 3 3 4 3 3 3 3)
+     (3 3 3 4 4 4 3 3 3)
+     (3 3 3 16 3 3 3)
+     (3 3 4 14 4 3 3)
+     (3 4 4 12 4 4 3)
+     (4 4 4 4 4 4 4)
+     (4 4 18 4 4)
+     (4 4 16 4 4)
+     (4 4 14 4 4)
+     (4 4 4 4 4)
+     (4 20 4)
+     (4 18 4)
+     (4 16 4)
+     (4 4 4)
+     (22)
+     (20)
+     (18)
+     (4)
+     (4)
+     (4)
+     (14)
+     (22)
+     (30))
+    ((3 12)
+     (2 14)
+     (3 14)
+     (4)
+     (3 12 4)
+     (2 14 4 1)
+     (3 14 4 1)
+     (4 4 1)
+     (3 12 4 4 1)
+     (2 14 4 4 2)
+     (3 14 4 4 2)
+     (4 4 4 2)
+     (3 12 4 4 3 2)
+     (2 14 4 3 3 3)
+     (3 14 3 3 3 3)
+     (4 3 3 3 3)
+     (3 3 3 3 3)
+     (3 3 3 3 3)
+     (3 33)
+     (1 34)
+     (2 34)
+     (4 33)
+     (3 3 3 3 3)
+     (3 3 3 3 3)
+     (4 3 3 3 3)
+     (3 14 3 3 3 3)
+     (2 14 4 3 3 3)
+     (3 12 4 4 3 2)
+     (4 4 4 2)
+     (3 14 4 4 2)
+     (2 14 4 4 2)
+     (3 12 4 4 1)
+     (4 4 1)
+     (3 14 4 1)
+     (2 14 4 1)
+     (3 12 4)
+     (4)
+     (3 14)
+     (2 14)
+     (3 12)))
+   ("19981221-SDN (8)"
+    (()
+     (6 2 2 2 2 6)
+     (6 2 2 2 2 6)
+     (2 2 2 2 2 2)
+     (2 2 2 2 2 2)
+     (5 2 7 2 6)
+     (5 2 7 2 6)
+     (2 2 2 2 2)
+     (2 3 2 2 2 2)
+     (6 3 2 2 2 6)
+     (6 3 2 2 2 6)
+     ()
+     ()
+     ()
+     (6 6 2 6 6)
+     (6 6 2 6 6)
+     (2 2 2 2 2 2)
+     (2 2 2 2 2 2)
+     (6 6 6 6 5)
+     (6 6 6 6 5)
+     (2 2 2 2 2 2)
+     (2 2 2 2 2 2)
+     (2 6 6 6 6)
+     (2 6 6 6 6)
+     ()
+     ()
+     ()
+     (6 6 1)
+     (6 6 11)
+     (2 2 2 6 11)
+     (2 2 2 6 1 2 2)
+     (6 6 2 2)
+     (6 6 2 2)
+     (2 2 6 2 2)
+     (2 2 6 2 2)
+     (6 2 2 2)
+     (6 2)
+     ()
+     ()
+     ())
+    (()
+     (2 2 6 6 2)
+     (2 2 2 6 6 2)
+     (2 2 2 2 2 2 2 2)
+     (2 2 2 2 2 2 2 2)
+     (10 10 2 6)
+     (10 10 2 6)
+     ()
+     ()
+     (3 2 6 6)
+     (3 2 6 6)
+     (3 2 2 2 2 2)
+     (2 2 2 2 2)
+     (6 2 10)
+     (10 6 2 10)
+     (10)
+     ()
+     (10 2 2)
+     (6 10 2 2)
+     (6 2 2 2 2)
+     (2 2 2 2 2)
+     (2 6 2 2)
+     (2 6 2 2)
+     (10)
+     (10)
+     (6 2)
+     (6 2 2)
+     (10 2 2 2 2)
+     (10 2 2 2 2)
+     (2 6 8)
+     (2 6 8)
+     (6 2 2)
+     (6 2 2)
+     (2 2 2 2 2 8)
+     (2 2 2 2 2 2 8)
+     (2 6 2 2 2 2)
+     (2 6 2 2 2 2)
+     (10 2)
+     (10)
+     ()))
+   ("19981223aBAU (9)"
+    ((1 4)
+     (2 6)
+     (3 7 2)
+     (4 4 4 4 4)
+     (3 7 5 2 4 7 2)
+     (6 2 7 5 8)
+     (2 5 9 1 2 6)
+     (3 2 9 3)
+     (1 11 2)
+     (1 13 1)
+     (4 13 1)
+     (5 15 3)
+     (4 1 15 5)
+     (3 3 15 6)
+     (2 2 1 15 1 2 3)
+     (3 1 15 10)
+     (2 1 13 1 1 5)
+     (1 2 1 2 2 4)
+     (1 6 1 1 1 2 2 4)
+     (20 5)
+     (25 4)
+     (5 21 3)
+     (7 20 3)
+     (3 1 6 8 4 4)
+     (4 4 1 13 4)
+     (1 1 7 2 2 1 3 3)
+     (3 4 1 5 5 2)
+     (1 1 6 2 2 1 2 1)
+     (4 3 2 4 5 3)
+     (4 6 4 4 4)
+     (3 3 2 2 2 2 1 5)
+     (3 6 5 7)
+     (3 2 2 2 2 1 3)
+     (2 4 5 3)
+     (1 3 1 5)
+     (6 4)
+     (4 5)
+     (4 5)
+     (3 2)
+     (1))
+    ((3 5 3)
+     (3 4 4 5)
+     (3 2 1 14)
+     (4 4 5 1 2 3)
+     (5 2 1 4 5 2)
+     (1 1 4 5 2)
+     (4 2 1 2 1 3 4)
+     (4 6 5 6 3)
+     (4 2 1 4 8 4)
+     (2 3 5 10 8)
+     (5 8 12 5)
+     (2 18 5 1 1)
+     (1 18 2 5)
+     (12 7 2)
+     (13 6)
+     (13 4)
+     (19)
+     (13 5)
+     (13 8)
+     (12 9)
+     (19 5)
+     (1 19 4)
+     (5 8 11 2)
+     (4 2 5 6 8)
+     (3 6 1 5 2 2)
+     (7 5 3 1 4)
+     (3 1 3 1 6 4)
+     (5 5 4 1 4)
+     (6 4 7 4)
+     (3 2 2 2 4 3 3)
+     (4 3 1 8 2)
+     (3 4 4 2 2)
+     (3 3 1 4 1 2)
+     (3 4 3 1)
+     (3 3 1 2 4)
+     (3 4 3 3)
+     (3 4 3 3)
+     (2 7 3)
+     (2 7 3)
+     (1 4 3)))
+   ("19981223bBAU (10)"
+    ((5 11)
+     (8 6 6)
+     (2 6 7 8)
+     (3 8 2 12 2)
+     (12 3 4 5 3 3)
+     (5 5 8 3 2 5)
+     (6 4 9 1 8)
+     (9 16 8)
+     (6 2 12 9)
+     (3 4 9 9)
+     (9 5 2 7)
+     (8 6 6)
+     (6 12 3)
+     (5 6 10 2)
+     (2 5 7 11)
+     (2 5 8 9)
+     (2 6 9 6)
+     (3 8 16)
+     (2 9 1 5)
+     (2 9 2 2)
+     (2 9 4 3)
+     (2 9 14)
+     (3 1 3 1 18)
+     (3 7 11 6)
+     (1 1 5 9 8)
+     (1 1 3 7 10)
+     (4 1 12)
+     (4 1 5 5 1)
+     (4 1 8 3 3)
+     (4 1 10 5)
+     (5 2 8 3 5)
+     (3 1 1 1 1 5 4 5)
+     (2 3 2 4 6 5)
+     (1 3 3 12 6)
+     (7 8 7 2 3)
+     (16 7 3 2)
+     (6 8 3 8)
+     (4 7 2 8)
+     (2 7 2 7)
+     (9 8))
+    ((4 15)
+     (7 8 8)
+     (8 3 11 2)
+     (2 7 2 5 3)
+     (2 7 1 1 6)
+     (3 1 5 8)
+     (5 2 2 4 8)
+     (6 1 2 7 4 1)
+     (5 5 6 2 1 3 1)
+     (5 5 11 1 1 2)
+     (5 22 5)
+     (5 17 1 6)
+     (1 2 12 2 6)
+     (2 2 13 7)
+     (1 2 3 5 8)
+     (5 9)
+     (5 2 4)
+     (5 8 5 3)
+     (7 5 5 8)
+     (7 5 5 7)
+     (8 6 5 7)
+     (9 7 5 5 1)
+     (2 6 8 5 4 1)
+     (3 4 14 2 3)
+     (5 3 1 4 6 2 5)
+     (6 2 2 2 6 10)
+     (8 4 1 5 10)
+     (6 5 1 5 7 1)
+     (1 2 7 3 1 4 2)
+     (1 2 7 2 2 3 3)
+     (4 8 2 3 5)
+     (6 10 6 4)
+     (10 6 6 5)
+     (5 5 4 7 6)
+     (4 6 3 7 6)
+     (2 7 2 12 2)
+     (13 4 6 2)
+     (11 3 9)
+     (9 2 8)
+     (7 8)))
+   ("19990208-ELS (11)"
+    ((2 2 2 1 2 2)
+     (4 4 2 1 2 4)
+     (1 1 1 2 1 2 6)
+     (1 2 1 2 1 2 2 8)
+     (1 2 1 2 1 2 1 2 10)
+     (1 1 1 2 1 2 1 1)
+     (11 2 1 2 1 2 2 1)
+     (1 1 1 2 2 1 2 2 1)
+     (1 2 1 2 1 2 1 2 1 1)
+     (1 2 1 2 1 2 1 2 1 2 1)
+     (1 1 1 1 1 2 1 2 1)
+     (11 2 2 10)
+     (2 1 3)
+     (2 1 1 2)
+     (12 1 1 13)
+     (20 1 12)
+     (1)
+     (1)
+     (1)
+     (4 3 3 3)
+     (3 3 3 4)
+     (1)
+     (1)
+     (1)
+     (12 1 20)
+     (13 1 1 13)
+     (2 1 1 2)
+     (2 1 2 3 1 2 1 1)
+     (2 2 2 2 2 1 1 3)
+     (2 2 2 2 1 2 1 5)
+     (1 2 2 1 2 1 2 1 1 5)
+     (1 2 3 2 1 2 1 1 1)
+     (3 2 2 2 2 2 1 1 1 1 1)
+     (7 2 2 1 2 5 1 1 1)
+     (2 10 2 1 2 1 1 1 1)
+     (6 1 2 1 2 1 1 1 1 1 1 1)
+     (4 2 2 1 1 1 1 1)
+     (4 2 1 2 1 1 1 1 1 1)
+     (4 2 1 2 1 1 1 1 1)
+     (6 2 1 2 1 1 1 1 1 1 1))
+    ((2 1 2 1 1)
+     (10 2 1 2 5)
+     (1 1 1 2 1 2 1 2)
+     (2 2 1 2 1 2 2 3 2)
+     (2 2 1 2 1 2 1 2 3 3 1)
+     (1 1 1 2 1 2 10)
+     (10 2 1 2 1 9)
+     (1 1 1 2 2 3 7)
+     (2 2 1 2 1 2 1 2 2 6)
+     (2 2 1 2 1 2 1 2 1 2 3 1)
+     (1 1 1 2 1 2 2 4)
+     (10 3 2 5 2)
+     (2 1 1 2 1 1)
+     (2 1 1 2)
+     (12 1 1 13)
+     (10 1 20)
+     (1)
+     (1)
+     (1)
+     (3 3 3 4)
+     (4 3 3 3)
+     (1)
+     (1)
+     (1)
+     (20 1 12)
+     (13 1 1 13)
+     (2 1 1 2)
+     (2 1 3 7)
+     (8 2 2 2)
+     (2 1 2 1 2 2 1 1 1)
+     (3 2 1 2 1 2 1)
+     (4 2 1 2 1 2 11)
+     (5 3 2 2 1)
+     (5 3 2 1 2 1 1 1 1 1 1)
+     (4 2 1 2 1 2 1)
+     (3 2 1 2 1 2 11)
+     (2 1 2 2 3)
+     (8 2 1 2 4 2 2 2)
+     (2 1 2 3)
+     (2 1 2 11)))
+   ("19990219-JOJ (12)"
+    (()
+     ()
+     ()
+     ()
+     (3)
+     (5 3)
+     (5 6)
+     (6 8)
+     (7 8)
+     (7 8)
+     (9 10)
+     (11 12)
+     (12 14)
+     (29)
+     (21 11)
+     (18 12)
+     (18 14)
+     (34)
+     (20 8)
+     (16 1)
+     (15 2)
+     (21)
+     (3 6 2 1 3)
+     (5 2 3 1 2)
+     (3 6 2 2 1 2)
+     (2 1 4 4 2 3 1 3)
+     (2 1 2 5 1 1 1 1 1)
+     (3 1 3 3 1 3 1)
+     (1 1 1 1 1 3 13)
+     (1 3 1 4 1 3 1)
+     (16 3 1 1 1 1 1)
+     (1 3 1 4 3 1 3)
+     (1 1 1 1 1 4 2 1 2)
+     (3 1 3 2 1 2)
+     (2 1 2 3)
+     (2 1 2)
+     (3)
+     ()
+     ()
+     ())
+    (()
+     (3)
+     (5 3)
+     (6 2 1 2)
+     (6 2 1 2)
+     (7 3 1 3)
+     (8 1 1 1 1 1)
+     (9 1 3 1)
+     (12 13)
+     (12 1 3 1)
+     (13 1 1 1 1 1)
+     (14 3 1 3)
+     (15 3 1 2)
+     (17 2 2 1 2)
+     (21 3)
+     (21 1)
+     (22 1)
+     (22 1)
+     (20)
+     (2 2 3 6)
+     (2 2 1 7)
+     (2 2 1 2 4)
+     (3 2 1 2 2)
+     (2 2 1 2 2)
+     (7 3)
+     (10 2)
+     (11 1 3)
+     (15 2 1 2)
+     (13 6 1 2)
+     (14 3 1 3)
+     (14 1 1 1 1 1)
+     (14 1 3 1)
+     (13 13)
+     (3 8 1 3 1)
+     (1 8 1 1 1 1 1)
+     (2 2 3 1 3)
+     (2 1 2)
+     (2 1 2)
+     (3)
+     ()))
+   ("19990222-JOJ (13)"
+    (()
+     ()
+     ()
+     (22)
+     (2 1 2)
+     (2 2)
+     (2 1 2)
+     (2 1 2)
+     (2 2 2)
+     (2 1 4 1 2)
+     (1 1 2 6 2 2)
+     (2 2 2 2 8 2)
+     (7 2 12 2)
+     (7 2 11 2)
+     (9 2 6 2 2)
+     (7 2 2 3 1 2)
+     (11 2 1 2)
+     (11 2 2)
+     (10 2 2)
+     (6 10)
+     (6 4 22)
+     (6 6 2 22)
+     (4 8 2 22)
+     (2 11 2)
+     (2 11 2)
+     (2 10 2)
+     (2 10 2)
+     (2 10 2)
+     (2 10 3 2)
+     (2 10 4 2)
+     (2 10 2 2)
+     (2 10 2 2)
+     (2 10 2 2)
+     (2 8 3 2)
+     (2 8 3 2)
+     (2 2 7 2)
+     (2 2 3 2)
+     (2 2 2 2)
+     (2 2 2 2)
+     (2 3 3 2))
+    ((3)
+     (20)
+     (20)
+     (3)
+     (2)
+     (5 2 10 1)
+     (7 18)
+     (10 19)
+     (24)
+     (23)
+     (26)
+     (25)
+     (3 4 19)
+     (5 18)
+     (4 10 2 1)
+     (2 4 2)
+     (2 3)
+     (3)
+     (1 5 3 3)
+     (2 8 3 2)
+     (3 2 3 3 2)
+     (1 3 2 3 2)
+     (1 1 1 2 3 2)
+     (2 1 1 3 2)
+     (1 1 3 4)
+     (1 5 4)
+     (1 2 3 4)
+     (1 7 4)
+     (1 8 4)
+     (1 10 4)
+     (1 5 4)
+     (1 3 4)
+     (1 3 4)
+     (1 5 4)
+     (1 7 1 3)
+     (1 1 2 3)
+     (1 3 2 3)
+     (3 2 3 20)
+     (2 8 20)
+     (1 5 3)))
+   ("19990402-JOJ (14)"
+    ((12 3 20)
+     (1 11 2 2 4 12)
+     (10 2 2 3 3 11)
+     (11 2 2 1 1 10)
+     (11 2 6 1 9)
+     (8 2 7 1 9)
+     (1 8 2 2 3 1 9)
+     (1 7 2 2 2 1 9)
+     (6 2 2 3 10)
+     (9 2 2 11)
+     (5 2 2 10)
+     (1 5 2 2 10)
+     (1 4 2 2 9)
+     (4 2 2 8)
+     (6 2 2 8)
+     (1 3 2 2 7)
+     (3 2 2 6)
+     (2 2 2 5)
+     (1 2 2 3 2 5)
+     (4 2 2 2 6)
+     (2 2 2 6)
+     (1 4 2 7)
+     (2 1 2 2 6)
+     (5 2 3 4)
+     (5 3 3)
+     (6 1 3)
+     (6 3 3)
+     (7 5 2)
+     (8 5 2)
+     (9 1 5 2)
+     (10 3 3 3)
+     (11 2 2 3)
+     (11 3 2 4)
+     (12 3 3 5)
+     (13 4 4 6)
+     (14 6 8)
+     (15 1 1 6)
+     (17 7 4)
+     (18 5 6 3)
+     (19 6 3 2))
+    ((1 1 1 3 17)
+     (1 2 2 1 2 2 3 18)
+     (2 1 1 1 19)
+     (20 1 17)
+     (19 2 17)
+     (17 3 15)
+     (14 3 13)
+     (12 6 12)
+     (10 5 11)
+     (8 4 10)
+     (7 4 9)
+     (4 3 7)
+     (3 4 6)
+     (2 4 5)
+     (1 2 4)
+     (2 3)
+     (2 1 3)
+     (1 3 2)
+     (8 1)
+     (5)
+     (1 2)
+     (3 2)
+     (3 2 1)
+     (3 3 5 2)
+     (2 1 2 2 7 2)
+     (1 1 2 2 2 5 2)
+     (1 1 3 1 2 2 3)
+     (1 1 4 5)
+     (2 1 1 3 2 1 1)
+     (3 4 1 3 2 1)
+     (4 4 3 2 1 2)
+     (13 2 5 2 2)
+     (15 5 1 3 1 1 2)
+     (16 2 1 2 5 2 1 1)
+     (17 4 1 7 3 2)
+     (23 8 4 2)
+     (24 3 6 1)
+     (27 9)
+     (40)
+     (40)))
+   ("19990414-JOJ (15)"
+    ((1 1 9 14 4 3)
+     (1 1 5 17 5 1 1)
+     (1 4 21 3 1 1)
+     (1 3 25 1 1 1)
+     (1 3 26 1 3)
+     (2 20 5 1)
+     (1 1 17 2 3 1 3)
+     (1 1 1 15 2 1 2 3 1 1)
+     (3 14 1 2 3 3 3)
+     (1 1 14 1 2 4 3 1 1)
+     (1 1 15 1 2 2 2 3 1 1)
+     (8 3 2 4 3)
+     (3 7 8 3 3)
+     (1 1 5 2 3 2 1 1)
+     (3 2 2 1 3 2 2 3)
+     (1 1 1 2 2 3 2 2 1 1)
+     (3 3 2 2 2 2 3 3)
+     (3 2 2 2 2 4)
+     (3 3 2 2 6 5 3)
+     (1 1 3 2 1 2 2 4 1 1)
+     (3 3 2 2 3 3 3)
+     (1 1 2 2 2 2 2 1 1)
+     (3 1 3 2 2 1 3)
+     (1 3 3 2)
+     (1 4 6 2 3)
+     (1 1 5 4 2 2 1 1)
+     (3 6 4 2 2 1 3)
+     (1 1 1 7 1 2 2 1 1 1)
+     (1 1 1 8 2 2 1 1)
+     (1 3 6 2 3)
+     (4 2 7 2 6)
+     (4 2 8 3 6)
+     (3 2 7 2 7)
+     (3 2 3 7 3 7)
+     (3 2 2 2 6 3 6)
+     (2 2 2 2 7 2 2 5)
+     (2 2 2 2 7 2 5)
+     (2 2 2 2 2 4 2 4)
+     (2 2 2 5 2 6 2 3)
+     (2 2 2 3 4 7 2 3))
+    ((2 4 5 5 4 10)
+     (3 1 1 1 1 1 1 1 1 1 1 10)
+     (2 4 5 5 4 5)
+     (3 4)
+     (8 4 9 2 7)
+     (6 7 6 3 7)
+     (5 9 5 11)
+     (3 9 9 6)
+     (2 26 7)
+     (1 19 5 1)
+     (1 11 5 2)
+     (1 10 2 5 2)
+     (1 9 4 5 2)
+     (10 2 2 5 2)
+     (10 4 2)
+     (10 4 1)
+     (11 4 2)
+     (12 4 3)
+     (9 2 4 2)
+     (8 4 1)
+     (8 1 3)
+     (7 2 3 1)
+     (7 3 3 2 2 2)
+     (6 1 1 3 2 2 2)
+     (6 1 4 3 2 2 1)
+     (6 3 2 3 2 2)
+     (6 3 2 1 2 2 1 2)
+     (5 1 3 1 2 1 1 4)
+     (5 1 4 2 6 5)
+     (6 3 2 4 4 7)
+     (1 8 2 2 1 2 4 3)
+     (1 4 3 5 1 2 1 7 2)
+     (2 4 3 3 2 6 2 1)
+     (3 2 6 5 6 2 3)
+     (3 15 3 7 3)
+     (23 11 2)
+     (9)
+     (5 5 5 5 5 10)
+     (1 1 1 1 1 1 1 1 1 1 1 1 10)
+     (5 5 5 5 5 10)))
+   ("19990418-DRA (16)"
+    (()
+     (38)
+     (18 19)
+     (17 1 18)
+     (15 3 17)
+     (13 6 16)
+     (12 9 1 13)
+     (10 11 1 11)
+     (9 1 2 8 2 10)
+     (6 2 1 2 1 3 2 9)
+     (6 5 5 3 2 3 8)
+     (6 4 5 5 1 4 7)
+     (7 2 6 1 4 5 7)
+     (6 3 7 1 4 4 7)
+     (5 3 6 2 5 2 8)
+     (5 4 5 1 1 4 2 9)
+     (6 4 4 3 3 2 9)
+     (6 4 6 1 3 2 10)
+     (7 2 1 5 3 3 10)
+     (8 1 2 3 1 2 2 11)
+     (9 3 2 1 13)
+     (10 2 1 4 14)
+     (11 1 2 1 2 15)
+     (12 1 1 16)
+     (15 1 18)
+     (11 1 19)
+     (10 1 4 16)
+     (10 2 3 15)
+     (16 13)
+     (12 3 3 12)
+     (11 4 12)
+     (10 2 7 12)
+     (10 3 21)
+     (10 5 3 16)
+     (16 2 15)
+     (16 1 1 14)
+     (16 4 14)
+     (16 6 14)
+     (16 21)
+     ())
+    (()
+     (38)
+     (38)
+     (38)
+     (38)
+     (38)
+     (13 23)
+     (8 1 2 21)
+     (8 2 5 20)
+     (8 9 19)
+     (7 5 5 18)
+     (6 4 1 2 4 3 5)
+     (6 1 4 4 2 2 6)
+     (5 3 7 4 1 1 6)
+     (4 3 9 1 1 2 7)
+     (4 2 11 2 1 3 8)
+     (3 3 11 2 4 8)
+     (3 4 4 3)
+     (2 5 1 1 1 2 4 7 2)
+     (1 7 2 1 1 2 2 2 6 3)
+     (2 5 2 5 2 3 5 4)
+     (3 4 3 1 2 2 3 3 3)
+     (4 3 6 3 2 2 2 3)
+     (5 3 8 2 4 3 2)
+     (6 3 6 1 6 4 1)
+     (5 1 3 4 2 7 7)
+     (6 1 1 1 2 9 7)
+     (6 6 4 19)
+     (7 8 20)
+     (8 5 22)
+     (9 3 24)
+     (10 25)
+     (38)
+     (38)
+     (38)
+     (38)
+     (38)
+     (38)
+     (38)
+     ()))
+   ("19990422-VOL (17)"
+    (()
+     ()
+     ()
+     ()
+     ()
+     (1 1 1 1 1 1)
+     (3 1 1 3 3 3 3)
+     (1 3 1 5 1 3 2 2 2 2 2 2)
+     (10 6 1 18)
+     (3 3 4 6 1 2 5 2 2 1)
+     (15 3 6 11)
+     (1 4 4 5 1 1 7 2 3)
+     (19 8 2 5)
+     (2 2 4 2 5 2 2 1 7 1)
+     (7 8 2 7 9)
+     (19 3 3 5 3)
+     (3 3 2 1 1 2 1 7 7 1)
+     (1 3 13 1 6 2 5)
+     (7 3 3 1 1 5 3 4 1)
+     (19 18)
+     ()
+     (19 18)
+     (1 1 1 9 3 2 5 2 3 2)
+     (1 1 3 3 5 1 6 11)
+     (1 1 1 13 10 7)
+     (1 15 3 3 8 1)
+     (7 1 2 2 5 8 3)
+     (1 1 2 4 1 9 6)
+     (1 5 3 7 10)
+     (1 3 1 1 1 1 1 2 5 4 2 4)
+     (1 5 3 15 2)
+     (8 4 3 4 9)
+     (1 5 3 1 10 2 4)
+     (1 1 2 12 6 11)
+     (1 1 10 4 2 15)
+     (1 7 7 4 7 2 2)
+     (15 3 18)
+     (5 2 4 5 1 5 2 5 1)
+     (19 18)
+     ())
+    (()
+     (13 18)
+     (3 5 2 1 1 1 3)
+     (6 6 4 1 1 2 2 3)
+     (3 6 3 1 1 4 3)
+     (15 18)
+     (1 5 3 2 1 1 2 9 1)
+     (4 8 8 3 5)
+     (1 4 1 1 1 2 2 1 1 8)
+     (13 6 5 1)
+     (14 5 1 6)
+     (1 1 4 2 3 5 6)
+     (5 6 1 2 2 1 2 3)
+     (2 6 3 5 6)
+     (5 6 5 1 4 1)
+     (9 3 6 2 4)
+     (1 2 7 1 1 5 1 5 2)
+     (9 5 5 2 9)
+     (2 2 4 1 1 2 8 6)
+     (13 18)
+     ()
+     (13 18)
+     (3 1 5 2 6 9 1)
+     (2 5 6 1 11 4)
+     (9 4 4 5 7)
+     (2 10 14 3)
+     (5 4 1 5 2 9)
+     (3 9 2 9 5)
+     (7 3 4 2 8 1)
+     (2 4 2 1 8 7)
+     (5 4 1 18)
+     (2 1 6 1 3 4 2 4 1)
+     (3 6 1 1 4 11)
+     (5 4 2 14 3)
+     (3 10 8 2 6)
+     (2 3 3 4 5 12)
+     (14 1 7 4 3)
+     (2 3 2 1 1 4 11 1)
+     (12 18)
+     ()))
+   ("19990503-DRA (18)"
+    ((7 23)
+     (5 10 21)
+     (4 14 20)
+     (3 6 4 19)
+     (2 6 4 1 4 18)
+     (1 6 7 4 17)
+     (1 2 6 5 16)
+     (1 1 2 2 4 6 15)
+     (1 1 9 4 14)
+     (1 5 10 5 13)
+     (1 4 6 5 4 12)
+     (1 3 5 1 4 1 5 11)
+     (1 2 1 2 1 4 10)
+     (1 3 7 3 5 5 9)
+     (1 13 6 2 3 8)
+     (1 13 4 2 1 4 7)
+     (1 13 5 6 3 6)
+     (1 12 6 5 4 5)
+     (1 7 1 3 4 1 3 4)
+     (2 6 2 2 3 7 4 3)
+     (2 6 9 2 2 3 3 2)
+     (2 16 3 3 3 4 1)
+     (2 16 5 3 2 1)
+     (2 17 1 2 3 1 2 1)
+     (3 15 12 1 2 1)
+     (3 14 15 1 1)
+     (3 14 9 3 2 1 1)
+     (3 14 8 2 1 1 1)
+     (4 14 4 2 4 2 1)
+     (4 16 2 4 3 1 2 1)
+     (4 10 1 1 7 1 3 1)
+     (5 8 7 1 3 2)
+     (5 8 7 7 3 3)
+     (6 14 7 4 3)
+     (7 3 7 5 6 3)
+     (8 3 4 8 4)
+     (9 3 6 9 5)
+     (10 4 11 6)
+     (11 20 7)
+     (12 8))
+    ((40)
+     (5 21)
+     (4 13 16)
+     (3 3 15 12)
+     (2 3 3 15 9)
+     (1 4 2 17 7)
+     (1 4 1 1 19 6)
+     (5 1 1 21 5)
+     (4 2 2 22 4)
+     (3 1 4 6 15 3)
+     (2 8 5 17 2)
+     (2 7 5 15 3 1)
+     (2 3 4 5 15 3)
+     (2 7 6 15 2)
+     (2 5 1 3 11 2 2)
+     (2 10 10 3 1 1)
+     (3 10 11 3 1 1)
+     (1 3 3 5 11 3 1 1)
+     (1 6 2 5 5 2 3 1 1)
+     (2 5 1 5 1 1 1 3 1 1)
+     (3 4 4 6 2 1 2 2 1)
+     (4 5 2 6 5 1 1 2 1)
+     (5 4 1 3 2 6 3 2)
+     (6 5 4 1 9 4 2)
+     (7 4 9 5 4 2)
+     (8 5 12 6 3)
+     (9 4 5 1 11 3)
+     (10 3 4 10 4)
+     (11 4 1 2 6 5 4)
+     (12 3 8 3 4)
+     (13 4 7 4 5)
+     (14 3 1 7 5)
+     (15 4 6 1 5 1)
+     (16 3 1 1 1 5 2)
+     (17 4 4 1 5 3)
+     (18 3 2 5 4)
+     (19 5 4 5)
+     (20 10 8)
+     (21 9)
+     (40)))
+   ("19990509-JOJ (19)"
+    ((16)
+     (7 5)
+     (4 3)
+     (4 2)
+     (3 2)
+     (3 1)
+     (2 1)
+     (2 2)
+     (2 3 2)
+     (2 4 3)
+     (2 9)
+     (1 1)
+     (2 7)
+     (1 7 6)
+     (1 5 4)
+     (2 3 2)
+     (2 2)
+     (2 5 3 1)
+     (1 8 5 2)
+     (1 16 6)
+     (1 5 4 4 2)
+     (1 4 2 2 4 1)
+     (1 4 1 1 6)
+     (1 6 3 1 3 8)
+     (2 8 2 1 2 9)
+     (2 10 3 9 1)
+     (2 3 25 2)
+     (2 7 17 3 2)
+     (2 9 18 1 1)
+     (1 3 29 1)
+     (1 3 1 5 12 7 1)
+     (1 3 3 3 14 5 2)
+     (1 4 6 1 10 1 5 2)
+     (1 4 8 8 2)
+     (2 7 6 4 7 3)
+     (3 3 7 4 6 3)
+     (4 1 6 6 4)
+     (8 14 4)
+     (4 6 4)
+     (5 5))
+    ((11 8)
+     (6 5 3)
+     (4 2 3 2)
+     (4 6 2)
+     (4 8 2)
+     (3 4 3 1)
+     (3 3 1 3 1)
+     (2 3 3 2 1)
+     (2 3 2 2 2)
+     (2 1 4 3 3)
+     (2 2 8 3)
+     (2 1 3 6 1 2)
+     (1 1 4 8 1)
+     (2 2 9 5 1)
+     (2 1 10 6 1)
+     (2 1 11 1 5)
+     (2 2 14 5)
+     (1 2 4 9 5)
+     (1 1 1 4 8 2)
+     (1 1 1 3 1 7 1 2)
+     (1 2 1 3 2 7 2 2)
+     (1 1 2 3 2 7 2 2)
+     (1 2 2 4 7 2 2)
+     (1 2 1 4 8 1 2)
+     (1 1 1 14 2)
+     (1 1 2 3 8 3)
+     (2 4 3 1 7 4 1)
+     (2 1 2 3 2 6 4 1)
+     (2 1 1 3 2 4 1 4 1)
+     (1 1 2 3 5 4 2)
+     (2 2 2 4 3 3 3 2)
+     (1 1 1 2 4 6 2)
+     (2 2 2 1 6 6 2)
+     (2 2 2 1 7 5 2)
+     (4 4 7 5 2)
+     (2 6 4 2)
+     (1 6 3 3)
+     (1 4 3)
+     (2 2 2 4)
+     (2 8)))
+   ("19990518-MNT (20)"
+    ((11 10 15)
+     (10 14 14)
+     (9 2 2 12)
+     (8 2 3 11)
+     (7 2 3 10)
+     (6 2 2 9)
+     (6 2 2 8)
+     (6 2 2 7)
+     (6 2 2 6)
+     (6 4 2 5)
+     (7 3 3 4)
+     (8 8 2 4)
+     (9 7 3 3)
+     (9 2 2 3)
+     (12 8 5 2 3)
+     (12 9 6 2 3)
+     (11 4 5 9 3)
+     (10 1 3 6 9 3)
+     (8 1 1 1 1 2 1 3)
+     (8 6 2 4 5 4 2)
+     (8 7 2 2 4 1 1 1)
+     (7 6 1 1 4 1 4 1)
+     (7 7 1 1 4 2 1 1)
+     (3 2 1 1 9 1 1)
+     (2 11 1 1 8 1 1 1)
+     (1 12 3 2 1 7 4 1)
+     (1 13 3 4 6 5 1)
+     (1 14 1 12 1)
+     (1 31 2)
+     (1 22 11 1)
+     (1 9 11 6 1 4)
+     (3 12 4 1 5)
+     (9 13 8 5)
+     (9 3 9 8 6)
+     (9 4 6 9 7)
+     (10 5 4 9 7)
+     (11 5 9 8)
+     (12 5 9 10)
+     (13 14 11)
+     (14 11 12))
+    ((40)
+     (25 9)
+     (24 4 9)
+     (23 5 8)
+     (23 7 8)
+     (23 7 8)
+     (5 13 7 8)
+     (4 5 10 7 8)
+     (3 7 6 1 7 8)
+     (2 2 3 4 4 7 5)
+     (1 2 4 3 5 7 2 4)
+     (2 2 2 1 4 7 4 3)
+     (1 2 1 4 7 5 2)
+     (2 6 11 2 4 1)
+     (2 6 15 4)
+     (2 2 3 1 1 7 4)
+     (2 2 2 1 1 1 7 4)
+     (2 2 1 1 2 8 3)
+     (2 2 1 1 2 8 2)
+     (2 3 1 6 9 2)
+     (2 4 1 1 8 3)
+     (2 3 1 2 7 4)
+     (2 2 1 2 6 5)
+     (1 3 2 1 5 6)
+     (2 2 1 6 2 2 7)
+     (1 2 2 2 3 8)
+     (2 2 2 12 8)
+     (2 2 4 12 7)
+     (3 2 4 19 1)
+     (4 2 2 18 2)
+     (5 2 2 1 13 3)
+     (6 2 3 1 12 3)
+     (7 3 3 1 4 3 1 4)
+     (8 4 2 1 4 2 3 6)
+     (9 8 1 1 1 3 1 7)
+     (10 8 1 4 1 9)
+     (12 1 2 2 1 10)
+     (19 1 4 1 10)
+     (20 1 1 10)
+     (21 5 11)))
+   ("19990525-DRA (21)"
+    ((1)
+     (3 1 1 3 3 1 1 3 2 3 1)
+     (1 1 3 1 1 1 2 1 1 1 1 1 1 1 1)
+     (1 1 1 1 1 3 1 2 3 1 1 3)
+     (3 1 1 3 1 1 1 1 1 1 3 1 1 1)
+     ()
+     ()
+     (1)
+     (3)
+     (5)
+     (7)
+     (11)
+     (11)
+     (11)
+     (11)
+     (11)
+     (4 11 4)
+     (5 11 5)
+     (6 11 6)
+     (7 11 7)
+     (27)
+     (27)
+     (25)
+     (23)
+     (23)
+     (23)
+     (25)
+     (25)
+     (19)
+     (11)
+     (13)
+     (15)
+     (1)
+     (1)
+     (1)
+     (1)
+     (1)
+     ()
+     ()
+     ())
+    (()
+     (4)
+     (1 1)
+     (4)
+     ()
+     (4)
+     (1)
+     (4 6)
+     (7 2)
+     (12)
+     (12)
+     (4 12)
+     (1 1 11)
+     (1 1 10 1)
+     (9 2)
+     (4 21)
+     (1 1 21)
+     (4 22)
+     (23)
+     (4 24)
+     (1 30)
+     (1 24)
+     (4 23)
+     (22)
+     (4 21)
+     (1 1 21)
+     (4 9 2)
+     (10 1)
+     (4 11)
+     (1 1 12)
+     (3 12)
+     (12)
+     (4 7 2)
+     (1 1 6)
+     (4)
+     ()
+     ()
+     (3 1)
+     ()
+     ()))
+   ("19990527bDRA (22)"
+    ((40)
+     (40)
+     (40)
+     (21 16)
+     (8 14 3 11)
+     (6 10 5 2 2 8)
+     (2 2 12 5 1 1 9)
+     (2 2 5 6 5 9)
+     (2 3 2 2 2 1 7 11)
+     (2 1 2 2 3 2 4 4 6)
+     (2 3 3 4 4 3 7)
+     (4 2 2 3 4 2 8)
+     (4 5 2 3 3 3 4 3)
+     (4 4 2 2 5 2 5 3)
+     (6 4 2 5 4 1 3)
+     (3 2 4 2 3 3 4 1 3)
+     (2 4 2 2 2 2 6 1 3)
+     (4 4 2 2 1 1 7 1 3)
+     (6 2 2 2 2 2 4 4)
+     (6 2 2 4 2 3 5)
+     (8 2 5 1 2 6)
+     (9 1 3 5 2 1 4 3)
+     (10 1 2 2 2 5 2)
+     (3 5 2 2 1 3 5 3)
+     (4 2 2 3 2 3 6)
+     (6 1 1 3 2 2 8)
+     (7 3 3 1 9)
+     (6 7 3 2 2 4)
+     (5 9 3 2 2 1 5)
+     (4 11 1 1 5 6)
+     (16 1 5 7)
+     (17 2 7 4)
+     (17 1 8 5)
+     (17 1 15)
+     (16 1 15)
+     (16 2 15)
+     (15 1 14)
+     (13 15)
+     (12 13)
+     (40))
+    ((40)
+     (40)
+     (6 5 23)
+     (9 4 6 16)
+     (10 3 6 4 10)
+     (6 1 2 3 6 3 11)
+     (5 3 2 5 1 12)
+     (5 5 2 2 5 13)
+     (4 6 3 2 3 14)
+     (8 4 3 1 15)
+     (11 3 1 14)
+     (12 5 3 13)
+     (7 3 5 2 11 1)
+     (9 2 3 2 10 1)
+     (11 1 3 9 1)
+     (8 2 4 5 7 1)
+     (8 3 4 3 3 1)
+     (9 3 4 1 1)
+     (5 2 5 3 6 1 1)
+     (6 5 5 3 4 1)
+     (10 9 2 1)
+     (3 6 2 3 1)
+     (3 5 4 2 1)
+     (3 13 3 2 1)
+     (4 6 4 5 3 1 1)
+     (5 4 3 5 7 1 1)
+     (6 3 1 2 9 1)
+     (7 2 1 11)
+     (4 2 3 1 4 10)
+     (7 6 3 2 3 9)
+     (6 5 6 2 2 9)
+     (5 5 7 2 3 9)
+     (10 4 3 3 2 8)
+     (9 5 3 2 4 1 7)
+     (14 3 4 2 7)
+     (18 4 3 3 8)
+     (12 3 16)
+     (22 17)
+     (40)
+     (40)))
+   ("19990529bDRA (23)"
+    (()
+     (9)
+     (13)
+     (11 5)
+     (14 5)
+     (16 5)
+     (22)
+     (3 3 1 12)
+     (2 2 6)
+     (2 6)
+     (5 8 6)
+     (2 2 1 1 1 1)
+     (4 1 6)
+     (2 1 1 2 7)
+     (3 1 2 1 1 7)
+     (5 2 3 1 7)
+     (1 4 5 2 4)
+     (2 2 1 6)
+     (2 2 2)
+     (1 3)
+     (1 2 2)
+     (1 1 1 2)
+     (1 7 4)
+     (2 3 1 2)
+     (1 4)
+     (2 4)
+     (2 2 2)
+     (2 2 2)
+     (3 3 4)
+     (8 2 2)
+     (2 2 4)
+     (8 2 7)
+     (6 2 2 9)
+     (8 2 2 11)
+     (10 2 2 12)
+     (12 2 2 14)
+     (14 4 15)
+     (15 16)
+     (35)
+     (35))
+    (()
+     ()
+     (4)
+     (5)
+     (6)
+     (7)
+     (7 8)
+     (4 3 9)
+     (11 2 9)
+     (12 2 9)
+     (4 1 1 2 2 9)
+     (4 1 1 1 1 1 1 9)
+     (5 1 2 2 2 2 1 7)
+     (7 2 1 2 4 6)
+     (7 3 1 2 5 5)
+     (6 4 2 3 1 2 4)
+     (6 2 1 1 2 3)
+     (7 1 1 1 1 2 2)
+     (6 1 3 1 1 2)
+     (7 1 1 2 2 1 2)
+     (7 1 1 1 1 2 2)
+     (7 1 3 2 2 3)
+     (2 4 1 1 2 2 4)
+     (3 3 2 2 2 5)
+     (3 2 3 2 6)
+     (8 4 1 8 7)
+     (16 9 8)
+     (8 4 3 4 1 9)
+     (14 4 12)
+     (6 9 11)
+     (4 7 10)
+     (8 10)
+     (9)
+     (9)
+     (8)
+     (7)
+     (5)
+     ()
+     ()
+     ()))
+   ("19990530aDRA (24)"
+    ((40)
+     (40)
+     (26 13)
+     (5 20 13)
+     (5 11 3 13)
+     (5 20 13)
+     (5 5 1 4 1 1 11)
+     (4 1 4 3 2 3 13)
+     (5 4 4 3 2 3 13)
+     (4 4 4 3 2 3 2 10)
+     (4 4 6 1 4 10)
+     (4 4 30)
+     (40)
+     (14 24)
+     (13 1 24)
+     (6 4 1 24)
+     (6 1 3 1 12)
+     (6 1 5 5 10)
+     (5 2 1 1 2 7 7)
+     (4 1 2 3 4 5)
+     (3 1 2 1 1 1 5 4)
+     (3 1 2 1 1 3 4)
+     (3 1 1 1 3 4 1 2 1 4)
+     (3 2 3 3 1 1 4)
+     (3 1 3 3 2 1 1 4)
+     (3 2 1 5 3 1 1 1 4)
+     (3 2 2 3 2 2 1 1 4)
+     (3 1 2 5 5 1 2 4)
+     (4 1 2 11 1 2 5)
+     (5 1 6 5 2 6)
+     (6 1 13 2 7)
+     (7 5 5 8)
+     (8 15 9)
+     (12 13)
+     (40)
+     (40)
+     (40)
+     (40)
+     (40)
+     (40))
+    ((40)
+     (40)
+     (40)
+     (20 12)
+     (7 1 7 1 1 2 1 11)
+     (3 8 2 1 10)
+     (4 2 7 2 1 9)
+     (4 2 7 1 1 2 1 8)
+     (4 10 1 2 1 7)
+     (4 2 2 5 2 2 1 1 7)
+     (4 2 7 1 1 1 1 7)
+     (6 10 2 1 1 1 1 7)
+     (6 9 4 1 1 2 6)
+     (6 7 3 1 2 1 6)
+     (13 7 3 1 1 1 6)
+     (6 3 4 2 1 1 1 6)
+     (10 5 2 3 1 1 1 1 6)
+     (10 5 1 1 3 1 1 1 6)
+     (10 5 1 3 1 1 1 6)
+     (7 5 2 1 2 1 1 1 6)
+     (6 3 5 2 4 1 1 1 1 6)
+     (16 3 1 1 1 6)
+     (4 1 5 1 3 1 1 1 6)
+     (16 4 2 1 1 1 6)
+     (6 9 3 1 1 1 1 6)
+     (6 9 2 1 2 1 6)
+     (2 6 2 1 1 2 6)
+     (6 3 5 2 1 1 1 7)
+     (6 3 6 1 2 1 1 1 7)
+     (9 6 2 2 1 1 7)
+     (18 2 1 1 2 7)
+     (18 5 1 1 2 8)
+     (18 4 1 1 2 9)
+     (19 2 1 1 2 10)
+     (19 1 1 1 2 11)
+     (20 12)
+     (40)
+     (40)
+     (40)
+     (40)))
+   ("19990530bDRA (25)"
+    ((40)
+     (40)
+     (40)
+     (40)
+     (40)
+     (15 15)
+     (14 14)
+     (13 13)
+     (12 12)
+     (11 11)
+     (10 10)
+     (9 9)
+     (8 8)
+     (7 7)
+     (6 1 1 6)
+     (6 5 5 6)
+     (6 6 6 6)
+     (6 6 6 6)
+     (6 4 4 6)
+     (6 2 2 6)
+     (6 6)
+     (7 1 1 7)
+     (8 2 2 8)
+     (3 3 9)
+     (1 4 10)
+     (1 6 1 1 1 1 6 3)
+     (1 6 1 1 1 1 6 3)
+     (1 5 1 1 1 6 1)
+     (4 5 1 1 1 6 1)
+     (5 4 5 1)
+     (6 5 6 5)
+     (7 4 5 6)
+     (8 3 4 7)
+     (9 2 3 8)
+     (10 4 5 9)
+     (11 12 10)
+     (12 10 11)
+     (13 8 12)
+     (14 3 13)
+     (15 14))
+    ((40)
+     (24 12)
+     (24 12)
+     (23 12)
+     (23 11)
+     (23 10)
+     (14 6 9)
+     (13 7 8)
+     (12 7 7)
+     (11 7 6)
+     (10 7 5)
+     (9 8 4)
+     (8 3 4 3)
+     (7 4 5 2)
+     (6 6 1 1)
+     (5 5 2)
+     (5 4 2 3)
+     (5 2 1 2 3)
+     (5 2 2 3)
+     (5 2 4)
+     (5 2 2 4)
+     (5 1 2 4)
+     (5 2 2 3)
+     (5 4 4)
+     (5 5 4)
+     (6 6 3)
+     (7 4 6 1)
+     (8 3 5 2)
+     (9 9 3)
+     (10 8 4)
+     (11 8 5)
+     (12 8 6)
+     (13 8 7)
+     (14 8 8)
+     (25 9)
+     (25 10)
+     (25 10)
+     (27 10)
+     (27 10)
+     (40)))
+   ("19990530cDRA (26)"
+    ((40)
+     (40)
+     (9 28)
+     (7 3 27)
+     (6 5 12 10)
+     (5 8 1 1 9)
+     (5 5 3 8)
+     (5 3 2 6 7)
+     (5 3 2 6 7)
+     (5 4 1 7 7)
+     (5 4 1 4 2 1 7)
+     (6 3 1 3 1 3 1 7)
+     (6 3 2 6 1 7)
+     (6 2 3 2 1 7)
+     (6 2 3 3 2 7)
+     (6 4 1 2 7)
+     (13 1 1 3 7)
+     (13 8 12)
+     (12 3 11)
+     (11 1 3 1 10)
+     (10 3 3 9)
+     (10 4 4 9)
+     (4 5 19 9)
+     (3 5 19 9)
+     (2 5 19 9)
+     (2 4 16 8)
+     (2 3 15 5 7)
+     (3 1 2 15 5 7)
+     (4 3 1 4 10 5 7)
+     (5 3 4 11 8)
+     (6 3 4 13 10)
+     (7 2 4 13 10)
+     (8 1 4 13 10)
+     (8 13 10)
+     (7 5 11)
+     (7 4 3 11)
+     (7 4 11)
+     (8 1 5 12)
+     (40)
+     (40))
+    ((40)
+     (40)
+     (24 13)
+     (23 12)
+     (22 11)
+     (5 14 1 10)
+     (4 6 10 3 9)
+     (3 10 11 3 2 3)
+     (3 11 12 3 2)
+     (2 4 4 14 3 2)
+     (2 4 1 7 2)
+     (2 3 12 13 2)
+     (3 2 1 6 14 2)
+     (4 2 4 13 2)
+     (5 8 12 3)
+     (5 8 6 2 2)
+     (6 4 1 2 12 2 2)
+     (5 3 1 1 12 2 2)
+     (5 4 1 3 12 2 2)
+     (5 1 4 1 3 13 3)
+     (5 2 3 14 3)
+     (5 1 1 14 3)
+     (5 1 1 14 3)
+     (6 2 2 13 3)
+     (5 1 12 2)
+     (5 12 2)
+     (4 5 5 2)
+     (4 5 3 4 2)
+     (4 7 6 3 4 3)
+     (4 5 5 3 6)
+     (5 4 3 10)
+     (6 8 3 10)
+     (7 9 11)
+     (40)
+     (40)
+     (40)
+     (40)
+     (40)
+     (40)
+     (40)))
+   ("19990601aDRA (27)"
+    ((18 1 19)
+     (5 10 9 7)
+     (5 10 9 7)
+     (7 10 9 9)
+     (8 8 9 10)
+     (3 1 5 16 4 1 4)
+     (2 5 11 4 3)
+     (2 6 9 8 3)
+     (3 8 7 10 4)
+     (4 10 5 12 5)
+     (13 17)
+     (12 10 16)
+     (11 12 15)
+     (10 1 4 1 6 4)
+     (3 3 1 1 4 1 1 5 4 3)
+     (2 4 1 1 4 1 4 6 2)
+     (1 7 1 4 1 3 8 1)
+     (1 8 14 2 9 1)
+     (9 4 4 4 2 10)
+     (10 4 4 2 11)
+     (11 10 2 12)
+     (12 2 2 13)
+     (12 2 2 1 13 1)
+     (1 10 10 14 1)
+     (1 9 12 13 1)
+     (1 8 14 11 2)
+     (2 6 14 10 2)
+     (3 5 12 8 2)
+     (4 4 2 4 3)
+     (5 4 4)
+     (8 1 1 1 11)
+     (7 1 2 2 2 10)
+     (6 2 16 3 9)
+     (5 4 14 5 8)
+     (3 6 7 6)
+     (10 14)
+     (9 13)
+     (7 10 10)
+     (6 6 8 7 9)
+     (5 8 9 8))
+    ((18 17)
+     (16 5 14)
+     (6 7 10 13)
+     (5 5 12 6 5)
+     (6 4 13 5 5)
+     (1 2 5 14 3 5)
+     (1 3 6 14 2 5 1)
+     (3 11 13 1 5 2)
+     (4 10 13 6 2)
+     (4 11 9 3 2)
+     (4 8 6 3 1 2)
+     (5 6 6 4 2 3 2)
+     (6 4 1 3 2 4 2 2)
+     (7 2 2 4 5 2 1 1)
+     (8 1 2 1 4 6 2 2)
+     (9 2 1 2 6 2 2)
+     (10 8 1 5 2 2)
+     (1 7 8 2 5 2 2)
+     (6 8 2 5 2 2)
+     (1 5 8 1 5 2 2)
+     (6 2 1 2 6 2 2)
+     (1 6 2 4 6 2 2)
+     (8 1 2 1 4 5 2 1 1)
+     (7 3 1 3 2 4 2 2)
+     (6 5 6 2 1 2 3 2)
+     (6 6 2 3 3 1 2)
+     (6 13 5 3 2)
+     (6 12 7 1 7 2)
+     (5 11 8 2 6 2)
+     (4 11 11 2 5 2)
+     (3 11 12 3 5 1)
+     (1 11 13 4 5)
+     (1 3 5 15 4 5)
+     (5 4 15 4 5)
+     (6 3 15 10)
+     (5 4 15 10)
+     (6 6 13 11)
+     (15 9 12)
+     (16 4 15)
+     (18 18)))
+   ("19990601bDRA (28)"
+    ((35)
+     (13 21)
+     (14 19)
+     (15 17)
+     (16 6 7)
+     (17 4 3)
+     (17 1 4 5)
+     (14 2 1 4 7)
+     (13 1 3 4 7)
+     (12 1 11 7)
+     (11 4 10 8)
+     (3 4 6 7 10)
+     (2 1 2 15 10)
+     (2 5 13 10)
+     (1 8 12 12)
+     (13 8 12)
+     (7 7 7 13)
+     (6 1 7 6 13)
+     (6 7 4 13)
+     (7 9 12)
+     (6 10 2 11)
+     (4 9 7 8)
+     (3 7 9 7)
+     (2 4 12 7)
+     (1 1 3 15 6)
+     (5 6 11 6)
+     (4 10 1 9 6)
+     (3 11 8 7)
+     (3 14 5 9)
+     (2 16 2 9)
+     (2 17 11)
+     (2 5 10 13)
+     (1 4 10 13)
+     (7 2 6 2 12)
+     (6 4 4 5 11)
+     (6 5 8 10)
+     (29 10)
+     (40)
+     (40)
+     (40))
+    ((25 13)
+     (14 9 6 7)
+     (12 8 4 7)
+     (11 9 3 10)
+     (11 9 2 11)
+     (11 8 1 12)
+     (12 4 1 1 7 4)
+     (12 3 1 5 5)
+     (13 2 1 2 5 7)
+     (13 3 5 5 7)
+     (11 4 5 5 6)
+     (10 9 6 6)
+     (9 2 8 7 4)
+     (1 6 4 7 10 4)
+     (1 4 6 7 10 4)
+     (2 3 5 7 10 4)
+     (3 3 5 5 10 4)
+     (4 1 5 4 3 6 4)
+     (5 1 5 2 2 6 4)
+     (5 2 6 1 1 4 4)
+     (5 2 7 2 2 5)
+     (5 10 5 1 5)
+     (5 10 7 6)
+     (5 11 7 6)
+     (4 11 8 7)
+     (4 7 10 7)
+     (4 1 4 10 6)
+     (5 5 3 8 2 5)
+     (11 6 7 3 4)
+     (10 7 6 5 3)
+     (9 10 4 10)
+     (7 10 3 12)
+     (5 12 12)
+     (5 17 13)
+     (3 33)
+     (1 34)
+     (34)
+     (35)
+     (35)
+     (35)))
+   ("19990604aDRA (29)"
+    ((40)
+     (40)
+     (40)
+     (7 32)
+     (5 2 21 8)
+     (5 3 17 2 6)
+     (5 3 15 3 6)
+     (5 3 15 3 6)
+     (5 3 15 3 6)
+     (6 1 17 3 6)
+     (8 8 3 7 1 7)
+     (8 8 3 8 9)
+     (8 9 1 9 9)
+     (8 6 6 9)
+     (8 6 1 1 6 9)
+     (9 3 2 2 4 9)
+     (10 1 2 2 2 10)
+     (11 1 11)
+     (11 12)
+     (11 12)
+     (6 7)
+     (2 1 5 5 1 3)
+     (4 6 6 5)
+     (2 7 7 3)
+     (11 2 2 12)
+     (12 2 2 13)
+     (12 1 1 1 1 14)
+     (9 1 1 11)
+     (4 3 6 5 3 6)
+     (5 1 8 7 1 7)
+     (4 24 6)
+     (40)
+     (40)
+     (5 2 4 3 14)
+     (5 2 2 2 2 2 2 2 13)
+     (5 5 3 2 14)
+     (5 5 2 2 2 2 2 13)
+     (5 2 2 2 2 2 2 2 13)
+     (5 2 2 2 2 2 14)
+     (40))
+    ((40)
+     (40)
+     (21 1 16)
+     (21 1 16)
+     (22 5 1 9)
+     (4 12 7 2 1)
+     (4 10 9 2 4 1)
+     (3 5 10 8 3 4 1)
+     (10 5 7 4 2 1)
+     (4 4 5 4 6 12)
+     (5 7 3 6 12)
+     (5 8 2 5 1)
+     (16 6 1 4)
+     (15 1 1 5 1 4)
+     (15 1 2 6 1 1)
+     (13 2 2 11)
+     (13 2 10)
+     (10 1 4 1)
+     (12 3 1 4)
+     (13 3 1 4)
+     (12 4 1)
+     (10 1 10)
+     (13 2 2 10)
+     (13 2 2 4 1)
+     (15 1 1 1 5 1 2 1)
+     (15 6 1 2 1)
+     (16 1 6 1 2)
+     (6 8 2 12)
+     (6 7 2 6 12)
+     (5 4 5 3 7 11)
+     (11 4 8 10)
+     (4 5 9 9 9)
+     (5 9 8 9)
+     (5 11 6 1 9)
+     (22 17)
+     (21 1 16)
+     (21 1 16)
+     (40)
+     (40)
+     (40)))
+   ("19990604bDRA (30)"
+    (()
+     (19 18)
+     (18 1 17)
+     (18 2 16)
+     (14 1 2 16)
+     (13 3 3 2 10)
+     (12 5 1 2 3 10)
+     (11 5 1 1 3 11)
+     (13 2 4 11)
+     (16 4 4 7)
+     (16 2 2 3 6)
+     (3 10 5 4 1 5)
+     (2 3 1 5 2 1 3 4)
+     (2 2 1 1 1 1 2 10)
+     (1 4 3 3 2 2 10)
+     (1 6 2 2 1 2 11)
+     (10 3 2 13)
+     (5 3 4 2 3 9)
+     (4 3 4 2 3 8)
+     (3 3 3 3 1 3 2 6)
+     (2 5 3 2 1 2 5 4)
+     (1 7 6 3)
+     (1 5 1 2 1 1 3 4 2)
+     (1 3 5 1 1 2 7 3 2)
+     (1 3 4 4 10 3 2)
+     (1 3 3 12 3 2)
+     (4 3 2)
+     (5 3 2)
+     (7 8)
+     (7 1 1 8)
+     (7 21 8)
+     (8 19 9)
+     (8 15 9)
+     (9 1 9 1 10)
+     (9 4 4 10)
+     (10 15 11)
+     (10 15 11)
+     (11 13 12)
+     (11 13 12)
+     ())
+    (()
+     (25 12)
+     (13 5 13)
+     (11 5 17)
+     (10 5 18)
+     (10 5 19)
+     (11 4 4 11)
+     (11 3 4 11)
+     (12 2 3 1 8)
+     (13 2 2 2 2 6)
+     (12 3 1 2 2 4)
+     (11 1 3 4 2 2 2)
+     (6 4 2 3 3 3 3)
+     (5 4 3 2 1 3 5)
+     (4 2 4 3 1 1 3 5)
+     (3 3 3 1 3 3 4 4)
+     (3 3 2 1 1 3 2 4 4)
+     (3 4 2 2 4 2 4 4)
+     (4 3 3 2 3 4 4 4)
+     (1 1 4 1 4 4)
+     (6 2 2 3 3 4 4)
+     (1 3 1 2 2 3 4 4)
+     (2 2 1 2 2 1 2 4 4)
+     (6 3 1 2 2 2 4 4)
+     (5 4 2 3 3 3 5)
+     (4 4 1 1 3 4 3 5)
+     (4 3 1 3 4 3 3)
+     (4 1 4 2 1 4 2 2 2)
+     (4 5 2 3 2 2 4)
+     (10 4 3 2 2 6)
+     (9 6 2 1 8)
+     (8 8 3 11)
+     (9 7 2 11)
+     (10 7 18)
+     (11 7 17)
+     (20 16)
+     (21 11)
+     (38)
+     (38)
+     ()))
+   ("19990606-DRA (31)"
+    (()
+     (6)
+     (14)
+     (19)
+     (21)
+     (24)
+     (27)
+     (27)
+     (2 5 5)
+     (2 21)
+     (2 12 4)
+     (5 19)
+     (6 18)
+     (1 17)
+     (2 16)
+     (5 16)
+     (9 19)
+     (14 2 11)
+     (3 3 3 1 1 8)
+     (4 2 1 1 1 8)
+     (2 1 2 1 1 8)
+     (2 2 3 1 8)
+     (2 3 2 1 8)
+     (2 4 3 3 8)
+     (2 2 2 3 1 8)
+     (2 2 2 4 2 3 5)
+     (6 6 2 1 1 4)
+     (2 4 5 1 2 1 1 4)
+     (4 2 4 1 1 2 1 3)
+     (7 2 2 1 2 1 3)
+     (1 2 1 1 2 1 3 3)
+     (5 2 6 4)
+     (5 16)
+     (2 2 16)
+     (2 2 6 9)
+     (2 2 5 10)
+     (3 5 11)
+     (5 6 12)
+     (14 13)
+     (12 14))
+    (()
+     (2)
+     (4)
+     (3 1)
+     (3 2)
+     (1 2 2 1)
+     (3 2 11)
+     (1 9 6 7)
+     (7 11 2 2 2)
+     (8 3 3 2 2 1)
+     (3 2 4 2 1 1 3 2)
+     (4 2 4 1 2 1 2 2 3)
+     (5 1 4 1 1 1 2 2 2)
+     (5 2 1 2 1 1 2)
+     (5 1 1 2 2)
+     (7 1 2 2 2)
+     (8 2 2)
+     (9 2 2)
+     (9 2 3 2)
+     (10 1 5 3)
+     (6 4 2 4 3)
+     (7 5 1 4 4)
+     (7 6 1 5 8)
+     (7 8 5 7)
+     (7 8 4 7 1)
+     (7 9 7 2)
+     (7 10 11 3)
+     (6 8 2 4 4 4)
+     (6 10 1 7 5)
+     (5 1 7 5 1 1 1 9)
+     (5 1 7 2 1 1 8)
+     (6 15 2 1 8)
+     (5 14 1 1 8)
+     (19 3 8)
+     (19 9)
+     (32)
+     (31)
+     (29)
+     (13)
+     ()))
+   ("19990606-KVL (32)"
+    ((4 33)
+     (2 17 1 11)
+     (2 18 12)
+     (1 30)
+     (1 23 3)
+     (1 25 1 2)
+     (2 8 10 3)
+     (2 5 5 8)
+     (4 5 4 8 6)
+     (11 3 5 5)
+     (10 2 3 4)
+     (9 2 2 3)
+     (8 2 2 2)
+     (7 2 2 1)
+     (7 1 2 1)
+     (7 1 1 4 1)
+     (7 1 1 7 1)
+     (8 2 2 8)
+     (9 1 2 8)
+     (13 1 8)
+     (29)
+     (29)
+     (21 6)
+     (21 6)
+     (21 7)
+     (15 4 4 2)
+     (16 1 1 3)
+     (5 10 5)
+     (4 3 9 7)
+     (3 7 6 7)
+     (3 10 3 6)
+     (3 13 6)
+     (4 12 3)
+     (7 6 3)
+     (10 3 6 3)
+     (13 7 5)
+     (12 12)
+     (3 9)
+     (5)
+     ())
+    ((38)
+     (3 32)
+     (1 30)
+     (1 21 5)
+     (19 3 4)
+     (18 4 4)
+     (18 4 4)
+     (1 5 10 5 3)
+     (1 4 10 4 3)
+     (3 5 9 4 3)
+     (10 5 9 5 2)
+     (9 2 12 4 2)
+     (8 2 10 4 1)
+     (8 2 9 5)
+     (7 2 4 10 4)
+     (7 1 2 2 5 4 4)
+     (7 2 2 7 3 2 1)
+     (6 1 2 6 4 1 2)
+     (6 1 2 6 3 1 2)
+     (6 2 1 2 7 3 3)
+     (6 1 2 11 4)
+     (6 1 1 7 4)
+     (6 1 1 7 1 5)
+     (6 1 1 8 3 4 2)
+     (6 2 10 5 1 2)
+     (6 1 10 6 5)
+     (1 5 1 8 6 5)
+     (2 4 1 7 6 4)
+     (1 5 1 12 4)
+     (7 1 7 4)
+     (7 1 2)
+     (7 1)
+     (8)
+     (4 3)
+     (4 4)
+     (5 4)
+     (6 4)
+     (5 6)
+     (4 8)
+     (4 12)))
+   ("19990607aDRA (33)"
+    ((40)
+     (40)
+     (9 30)
+     (40)
+     (3 16 18)
+     (21 2 1 1 10)
+     (21 3 7)
+     (7 8 6 1 1 6)
+     (3 3 12 1 1 2 3 4)
+     (3 13 5 3 5)
+     (18 1 6 3 1 6)
+     (11 7 2 2 4)
+     (19 2 1 4 1 5)
+     (18 1 2 2 2 3)
+     (17 1 3 3 4 2 4)
+     (18 3 4 2 4)
+     (21 4 5 2 1)
+     (21 1 1 2 2 1)
+     (5 4 10 1 6 2 2 1)
+     (2 2 2 3 7 1 1 2 2 1)
+     (1 2 1 4 7 2 4 2 2 1)
+     (1 2 1 4 8 1 2 1 1)
+     (1 2 5 10 2 3 1 1)
+     (1 4 5 13 2 2 2 1)
+     (1 3 5 15 2 1 3)
+     (1 3 5 16 1 1 1 2)
+     (1 3 5 16 1 1 3)
+     (1 2 4 17 1 1 1 2)
+     (2 2 3 18 1 1 3)
+     (2 2 3 6 8 1 1 1 2)
+     (2 2 3 5 7 1 1 3)
+     (2 1 2 6 2 6 1 1 1 2)
+     (3 1 1 7 3 5 1 1 1 3)
+     (3 2 8 7 1 1 7)
+     (3 2 10 3 8)
+     (3 2 11 7 9)
+     (3 1 13 12)
+     (4 33)
+     (4 34)
+     (4 34))
+    ((40)
+     (20 12)
+     (19 8)
+     (4 3 17 3)
+     (9 21)
+     (18 14)
+     (19 1 3 2)
+     (7 13 3)
+     (7 11 9 4)
+     (2 16 10 6)
+     (18 11 7)
+     (11 16 8)
+     (27 9)
+     (24 12)
+     (19 13)
+     (20 16)
+     (40)
+     (7 6 25)
+     (7 1 2 1 14 6)
+     (7 1 1 1 14 5)
+     (4 2 1 1 15 2 4)
+     (4 1 2 1 2 10 3 1 3)
+     (5 5 2 2 9 2 1 3)
+     (6 1 3 1 2 2 9 1 1 3)
+     (6 4 1 4 12 1 3)
+     (5 1 2 4 2 12 1 3)
+     (6 1 1 3 1 2 11 1 3)
+     (5 1 1 11 1 3)
+     (6 1 1 1 1 1 1 1 10 1 4)
+     (5 1 3 1 1 1 1 1 1 8 2 4)
+     (7 3 1 1 1 1 1 2 6 1 1 4)
+     (8 1 1 1 1 1 1 2 1 1 5)
+     (6 1 2 1 7 1 6)
+     (7 1 13 1 7)
+     (9 1 18 7)
+     (8 2 1 8)
+     (13 2 4 2 1 1 1 1 7)
+     (16 5 2 1 1 1 8)
+     (16 16)
+     (40)))
+   ("19990607cDRA (34)"
+    ((40)
+     (9 16 12)
+     (8 14 11)
+     (8 1 12 1 11)
+     (7 3 10 1 11)
+     (7 4 8 1 11)
+     (6 2 2 7 1 11)
+     (6 1 2 6 2 11)
+     (5 2 3 4 3 11)
+     (5 2 2 4 10)
+     (4 3 3 4 10)
+     (4 4 4 3 10)
+     (4 4 3 2 10)
+     (4 2 3 4 1 10)
+     (5 8 1 11)
+     (4 3 3 1 12)
+     (3 3 4 2 2 12)
+     (3 3 2 2 2 1 11)
+     (3 3 2 7 11)
+     (2 5 2 8 11)
+     (2 6 12 10)
+     (2 7 8 9)
+     (1 12 8 8)
+     (1 22 7)
+     (1 23 6)
+     (1 1 22 5)
+     (1 3 22 4)
+     (1 4 19 3)
+     (1 5 7 8 3)
+     (1 6 3 7 4)
+     (1 8 2 6 4)
+     (2 11 2 5)
+     (2 16 1 4 6)
+     (2 16 2 7)
+     (2 15 14)
+     (2 15 14)
+     (2 14 14)
+     (2 19 13)
+     (2 22 13)
+     (2 24 12))
+    ((40)
+     (22 9)
+     (19)
+     (16 1)
+     (10 1 2)
+     (8 2)
+     (6 3 2)
+     (4 6 3)
+     (2 7 4 3)
+     (1 3 4 7 3)
+     (1 3 1 17 3)
+     (2 5 3 7 14)
+     (3 8 9 12)
+     (4 5 11 11)
+     (5 2 3 9 10)
+     (8 3 1 8 10)
+     (9 2 3 7 9)
+     (9 2 2 2 7 9)
+     (9 2 1 1 7 9)
+     (9 2 1 1 7 9)
+     (8 2 2 2 7 8)
+     (7 2 4 7 8)
+     (6 3 4 7 8)
+     (5 15 8)
+     (4 2 1 11 1 8)
+     (3 4 2 11 1 1 3)
+     (2 6 13 1 1 3 1)
+     (1 11 12 1 6)
+     (2 2 10 1 7)
+     (9 6 10 1 6)
+     (21 9 1 6)
+     (22 8 1 6)
+     (23 7 1 6)
+     (24 2 2 7)
+     (25 1 1 8)
+     (26 9)
+     (27 11)
+     (40)
+     (40)
+     (40)))
+   ("19990616-DRA (35)"
+    ((40)
+     (1 12 5 17)
+     (2 13 5 17)
+     (2 1 1 1 1 1 1 1 1 3 1 3)
+     (2 1 1 1 1 1 3 1 1 1 1 1 1 1 1 1 2 2)
+     (2 1 1 1 1 1 1 1 2 1 2 2 2)
+     (40)
+     (40)
+     (40)
+     (40)
+     (40)
+     (40)
+     (40)
+     (12 12)
+     (10 14 10)
+     (8 18 8)
+     (7 4 1 1 1 1 1 1 1 3 7)
+     (6 4 1 1 1 1 1 1 1 1 3 6)
+     (5 3 1 1 1 1 1 1 1 1 1 2 5)
+     (4 24 4)
+     (3 1 24 1 3)
+     (2 2 24 2 2)
+     (1 3 24 3 1)
+     (1 3 24 3 1)
+     (1 3 24 3 1)
+     (2 2 24 2 2)
+     (3 1 24 1 3)
+     (4 24 4)
+     (5 24 5)
+     (6 24 6)
+     (7 23 7)
+     (8 19 8)
+     (10 14 10)
+     (12 12)
+     (40)
+     (40)
+     (40)
+     (40)
+     (40)
+     (40))
+    ((40)
+     (1 20 15)
+     (1 15 3 14)
+     (1 18 5 13)
+     (3 13 7 12)
+     (3 1 12 11)
+     (3 11 10)
+     (16 9)
+     (3 9 13 8)
+     (5 9 15 8)
+     (3 8 15 7)
+     (14 3 13 7)
+     (3 7 2 14 6)
+     (3 1 7 2 1 14 6)
+     (3 1 7 3 15 6)
+     (13 2 1 14 6)
+     (1 7 3 15 6)
+     (3 9 2 1 14 6)
+     (3 7 3 15 6)
+     (13 2 1 14 6)
+     (3 7 3 15 6)
+     (3 1 7 2 1 14 6)
+     (1 7 3 15 6)
+     (13 2 1 14 6)
+     (3 7 3 15 6)
+     (3 1 7 2 1 14 6)
+     (3 7 3 15 6)
+     (13 1 1 13 6)
+     (3 9 2 14 7)
+     (5 8 2 13 7)
+     (4 10 15 8)
+     (5 9 14 8)
+     (3 11 9)
+     (17 10)
+     (3 12 11)
+     (3 15 7 12)
+     (3 16 5 13)
+     (4 15 3 14)
+     (22 15)
+     (40)))
+   ("19990618aDRA (36)"
+    ((40)
+     (10 13 11)
+     (9 3 11 3 10)
+     (8 4 1 1 4 9)
+     (8 4 4 9)
+     (8 4 4 9)
+     (9 10)
+     (2 3 4 1 1 12)
+     (1 1 3 12)
+     (1 3 3 12)
+     (1 3 1 12)
+     (2 4 2 1 2 5 3 2)
+     (2 4 5 4 1 1)
+     (3 6 3 5 1)
+     (4 8 6 1)
+     (14 8 2)
+     (15 9 2)
+     (15 10 3)
+     (13 9 4)
+     (10 10)
+     (9 9)
+     (8 8)
+     (8 8)
+     (7 7)
+     (6 6)
+     (4 4)
+     (3 2 2 3)
+     (2 4 4 2)
+     (2 4 4 2)
+     (2 4 1 1 4 2)
+     (2 4 2 2 4 2)
+     (3 2 2 2 2 3)
+     (4 2 3 3 2 4)
+     (7 5 5 7)
+     (7 5 5 7)
+     (7 5 5 7)
+     (7 5 2 5 7)
+     (8 3 6 3 8)
+     (9 16 9)
+     (40))
+    ((40)
+     (8 29)
+     (7 14 9)
+     (8 12 4 8)
+     (9 10 6 7)
+     (8 11 6 7)
+     (7 11 4 8)
+     (8 12 2 3)
+     (3 15 2 4 2)
+     (2 3 13 2 6 1)
+     (1 4 12 6 1)
+     (1 4 6 6 1)
+     (1 4 5 4 2)
+     (2 3 2)
+     (4 2 2)
+     (3 2)
+     (3 1 1 2)
+     (3 2 3)
+     (3 1 2 3)
+     (3 5 4)
+     (3 1 2 4)
+     (3 2 3)
+     (3 1 1 3)
+     (3 2)
+     (4 2 2)
+     (2 3 2)
+     (1 4 5 2)
+     (1 4 6 4 2)
+     (1 4 12 6 1)
+     (2 3 12 6 1)
+     (3 14 2 6 1)
+     (21 2 4 2)
+     (12 8 2 3)
+     (11 7 4 8)
+     (12 7 6 7)
+     (13 6 6 7)
+     (12 8 4 8)
+     (11 10 9)
+     (12 25)
+     (40)))
+   ("19990618bDRA (37)"
+    (()
+     ()
+     ()
+     (2 2)
+     (3 3)
+     (5 5)
+     (7 7)
+     (3 5 2 9)
+     (1 2 8 4 8 3 1)
+     (1 4 6 6 4 3 2)
+     (2 4 5 2 1 3 6 2)
+     (2 11 2 1 2 8 2)
+     (2 5 5 4 4 6 2)
+     (1 5 5 6 4 5 2)
+     (1 4 7 4 6 4 1)
+     (12 6 5)
+     (7 4 4 7)
+     (6 3 1 2 2 6)
+     (3 3 2 3 3 3)
+     (2 3 3 3 3 2)
+     (3 4 3 2)
+     (3 4 3 3)
+     (5 4 3 3)
+     (5 5 3 4)
+     (4 6 4 3)
+     (4 6 4 4)
+     (4 7 4 4)
+     (12 6 3)
+     (11 10)
+     (10 11)
+     (5 5 11)
+     (4 4 12)
+     (4 3 12)
+     (4 3 6 6)
+     (2 2 5 5)
+     (1 1 3 4)
+     (2 2)
+     (1 1)
+     ()
+     ())
+    (()
+     ()
+     (3)
+     (9 3)
+     (3 3 3 4)
+     (7 7 7)
+     (4 12 7)
+     (4 10 7)
+     (3 9 8)
+     (3 4 3 8)
+     (4 2 3 4 4)
+     (3 1 3 4 6)
+     (8 4 8)
+     (8 4 10)
+     (8 3 12)
+     (7 3 8 3)
+     (1 3 1 3 8)
+     (1 1 2 8)
+     (7 1 7)
+     (8 5)
+     (3 3)
+     (7 3)
+     (1 1 4 5)
+     (1 3 1 1 17)
+     (7 2 19)
+     (3 4 2 17)
+     (2 5 2 12)
+     (2 1 3 6 8)
+     (2 3 2 8 6)
+     (3 4 2 12)
+     (3 4 3 11)
+     (3 6 2 10)
+     (15 7)
+     (17 6)
+     (6 6 6)
+     (3 5 3 3)
+     (9)
+     ()
+     ()
+     ()))
+   ("19990618cDRA (38)"
+    ((40)
+     (40)
+     (2 3 33)
+     (2 3 11 18)
+     (2 10 17)
+     (2 3 9 1 16)
+     (2 3 8 4 16)
+     (14 22)
+     (3 7 22)
+     (2 3 5 21)
+     (2 4 20)
+     (2 3 3 2 19)
+     (2 3 1 4 18)
+     (8 6 17)
+     (2 3 2 7 16)
+     (2 1 3 8 15)
+     (2 1 1 4 9 14)
+     (2 3 16 13)
+     (2 3 17 12)
+     (25 11)
+     (2 3 19 10)
+     (2 1 20 9)
+     (2 1 1 21 8)
+     (2 3 22 7)
+     (2 3 1 19 6)
+     (9 21 5)
+     (2 2 22 4)
+     (2 6 3 17 3)
+     (2 4 4 19 2)
+     (2 6 4 4 13 2)
+     (2 2 4 5 15 2)
+     (8 9)
+     (2 2 9)
+     (2 3 1 9)
+     (2 1 9)
+     (2 2 8 5 19)
+     (2 3 13 19)
+     (20 19)
+     (40)
+     (40))
+    ((40)
+     (40)
+     (2 2 1 1 1 1 3)
+     (4 3 1 4 5 4 1 1 1 1 5)
+     (4 3 1 5 5 3 1 1 1 1 5)
+     (4 3 1 4 5 4 3 1 1 4)
+     (2 2 1 1 1 3 2 1 3)
+     (40)
+     (12 10 6 5)
+     (12 9 5)
+     (11 8 6 5)
+     (10 14 5)
+     (9 14 5)
+     (8 14 3 5)
+     (7 15 4)
+     (6 16 3 5)
+     (5 20 5)
+     (4 19 5)
+     (3 2 18 5)
+     (3 4 15 1 5)
+     (3 5 14 2)
+     (3 7 13 1 5)
+     (4 7 14 5)
+     (5 7 13 5)
+     (15 12 5)
+     (16 11 5)
+     (17 10 5)
+     (18 9 5)
+     (19 8 5)
+     (20 7 5)
+     (21 6 5)
+     (22 14)
+     (23 13)
+     (24 12)
+     (25 11)
+     (26 10)
+     (27 9)
+     (28 9)
+     (40)
+     (40)))
+   ("19990625-DRA (39)"
+    ((40)
+     (16 17)
+     (15 16)
+     (5 8 15)
+     (6 6 14)
+     (6 4 13)
+     (6 4 9 3)
+     (6 4 8 3)
+     (1 5 3 2 2 7 3)
+     (2 4 2 3 3 7 4)
+     (2 5 2 2 2 6 4)
+     (2 4 2 2 2 5 5)
+     (2 3 2 5 6)
+     (3 3 2 4 6)
+     (3 3 2 4 6)
+     (3 3 2 5 6)
+     (3 3 2 5 4 1)
+     (3 3 2 5 4 1)
+     (4 3 2 2 5 1)
+     (4 3 5 1)
+     (5 6 2)
+     (6 6 2)
+     (7 8 2)
+     (11 8 2)
+     (5 3)
+     (4 4)
+     (3 5)
+     (2 6 12)
+     (1 8 2 10)
+     (1 7 1 4 8)
+     (1 7 3 7 7)
+     (1 6 5 8 5)
+     (1 6 7 10 5)
+     (1 6 7 11 4)
+     (1 5 8 7 3)
+     (1 5 10 8 2)
+     (4 15 6 1)
+     (4 17 6)
+     (3 23 8)
+     (2 27 7))
+    ((36 2)
+     (8 19 3)
+     (9 14 4)
+     (11 8 8)
+     (12 5 9 1)
+     (3 13 3 9 1)
+     (4 10 2 8 2)
+     (5 9 1 8 2)
+     (8 3 1 7 3)
+     (9 2 1 4 4)
+     (15 1 1 3 5)
+     (16 2 6)
+     (5 2 2 8)
+     (4 2 8)
+     (3 2 9)
+     (2 2 1 10)
+     (1 4 11)
+     (1 2 1 10)
+     (1 9)
+     (1 5)
+     (1 4)
+     (1 2 1 4)
+     (1 4 6 4)
+     (2 2 1 6 4)
+     (3 2 5 3)
+     (4 2 5 2)
+     (5 3 1 5 2)
+     (18 2 6 2)
+     (18 2 1 6 2)
+     (17 3 1 5 1)
+     (16 4 2 5 1)
+     (13 5 2 5)
+     (11 6 3 6)
+     (10 7 4 5)
+     (8 11 4 5)
+     (7 10 7 4)
+     (6 10 9 3)
+     (17 11 3)
+     (16 16 2)
+     (37 2)))
+   ("19990628-DRA (40)"
+    ((40)
+     (1 26 1)
+     (2 20 2)
+     (3 12 3)
+     (4 4)
+     (6 14 6)
+     (9 14 9)
+     (11 16 11)
+     (11 16 11)
+     (1 18 1)
+     (1 7 20 7 1)
+     (2 5 2 16 2 5 2)
+     (3 3 3 14 3 3 3)
+     (4 1 4 8 4 1 4)
+     (8 7 6 7 8)
+     (8 4 4 4 8)
+     (8 4 2 4 8)
+     (9 4 4 4 9)
+     (10 16 10)
+     (11 16 11)
+     (11 16 11)
+     (11 14 11)
+     (12 14 12)
+     (12 14 12)
+     (12 14 12)
+     (12 14 12)
+     (12 14 12)
+     (12 14 12)
+     (12 14 12)
+     (11 16 11)
+     (11 1 8 1 11)
+     (11 2 8 2 11)
+     (11 3 8 3 11)
+     (11 16 11)
+     (11 16 11)
+     (12 14 12)
+     (13 1 1 13)
+     (14 10 14)
+     (15 15)
+     (40))
+    ((40)
+     (1 7 29)
+     (1 6 1 28)
+     (1 5 2 27)
+     (1 4 3 26)
+     (1 4 3 26)
+     (1 3 3 26)
+     (2 3 2 27)
+     (2 3 1 23)
+     (2 2 5 22)
+     (3 2 7 21)
+     (3 2 6 7 5)
+     (3 5 8 6 4)
+     (3 8 1 14 5 3)
+     (4 8 1 13 5 2)
+     (4 8 1 12 3 1 1)
+     (4 9 18 1 1)
+     (4 10 18 1 1)
+     (4 11 19 1 1)
+     (4 31 1 1)
+     (4 31 1 1)
+     (4 11 19 1 1)
+     (4 10 18 1 1)
+     (4 9 18 1 1)
+     (4 8 1 12 3 1 1)
+     (4 8 1 13 5 2)
+     (3 8 1 14 5 3)
+     (3 5 8 6 4)
+     (3 2 6 7 5)
+     (3 2 7 21)
+     (2 2 5 22)
+     (2 3 1 23)
+     (2 3 2 27)
+     (1 3 3 26)
+     (1 4 3 26)
+     (1 4 3 26)
+     (1 5 2 27)
+     (1 6 1 28)
+     (1 7 29)
+     (40)))
+   ("19990703-NEP (41)"
+    ((13 13)
+     (9 2 2 3 2)
+     (3 7 1 1 1 1 1 1)
+     (7 3 2 1 1 1 1 3)
+     (14 1 1 1 1 1 3)
+     (11 2 1 1 1 1 3)
+     (3 10 1 1 1 1 1 3)
+     (6 8 2 2 3 4)
+     (7 7 13)
+     (2 14 1)
+     (4 28)
+     (1 5 27)
+     (3 5 26)
+     (1 4 5 25)
+     (2 4 31)
+     (3 4 17 11)
+     (1 2 5 15 1)
+     (1 3 4 14 1 7 1)
+     (1 3 18 3 1 1 1 2)
+     (1 4 6 14 1 1 3)
+     (2 9 2 13 5 3)
+     (2 8 4 11 7 1 1)
+     (2 8 2 7 1 6 2)
+     (12 1 4 6 1 2 6 1)
+     (13 1 1 5 1 4 2 2)
+     (4 1 1 5 1 4 1 2 1)
+     (9 4 4 5 2 2 1 4)
+     (2 3 1 4 4 5 3 2 4)
+     (1 1 1 1 4 4 5 5 1 2 1)
+     (1 1 1 2 4 4 5 4 2 1 2)
+     (1 1 1 1 4 4 5 3 4 4)
+     (2 3 1 5 7 3 2 4 1)
+     (9 4 4 7 3 4 2)
+     ()
+     (32 7)
+     (1 3 2 1 3 2 1 3 5 2 3)
+     (1 2 2 1 1 1 1 1 1 1 1 2 2 1 2 2)
+     (1 1 1 1 1 1 1 1 1 2 1 2 2 1 2 2)
+     (1 3 1 3 1 1 1 2 1 2 2 1 4 2)
+     (5 2 3 2 2 2 2 1 2 3))
+    ((9 1 1 6)
+     (2 5 7 1 1)
+     (7 2 2 2 4 1)
+     (10 1 3 1 3 1)
+     (3 8 2 2 2 3)
+     (6 6 7 1 1 1)
+     (6 5 2 2 1 1 1)
+     (2 12 1 3 1 2 1)
+     (4 10 2 1 2 6)
+     (6 9 1)
+     (2 6 15 1 4)
+     (4 10 10 2 2)
+     (2 5 8 2 9 1 4)
+     (1 3 6 6 4 8 2)
+     (1 4 6 5 2 1 6)
+     (1 4 13 1 2 5 1 2 1)
+     (2 4 13 1 6 1 1 3)
+     (2 5 13 2 5 1 2 1)
+     (2 5 13 1 6 1 6)
+     (3 18 1 1)
+     (3 29 2 3)
+     (3 29 1 4)
+     (33 2)
+     (33 6)
+     (33 2 1)
+     (1 1 1 1 1 7 5 2 1 3)
+     (1 1 1 1 7 5 7 1 1 3)
+     (9 5 5 1 6 2)
+     (1 1 5 3 1 2 6 5)
+     (9 6 1 1 4 2 2 6)
+     (2 2 6 2 2 4 1 1 1 2)
+     (1 5 1 6 1 4 2 1 3 2 2)
+     (2 2 6 2 4 2 3)
+     (9 6 1 7 1 1 1 6)
+     (2 2 6 2 5 2 1 2 2 3)
+     (1 5 1 6 1 3 4 3 1 1 1)
+     (2 2 6 2 2 4 3 1 1 1)
+     (9 6 4 2 2 3 2 1)
+     (1 6 6 4 1 2 3 1 6)
+     (1 6 7 3 2 6)))
+   ("19990714bNEP (42)"
+    ((3 2 3)
+     (2 1 2 1 2 1)
+     (1 1 1 2 1 1)
+     (1 2 2 2 2 1 2)
+     (2 2 2 2 2 1 2 2)
+     (2 1 2 2 2 2)
+     (2 2 2 2 2)
+     (2 2 2 2 2 1)
+     (1 2 2 2 2 2)
+     (2 2 2 2 2 2 2)
+     (2 2 2 2 2 2 2 1)
+     (1 2 2 2 2 2 2 2)
+     (2 2 2 2 2 2 2 2 2)
+     (2 2 2 2 2 2 2 2 2 1)
+     (1 2 2 2 2 2 2 2 2 2)
+     (2 2 2 2 2 2 2 2 2 2)
+     (2 2 2 2 2 2 2 2 2 2)
+     (2 2 2 2 2 2 2 2 2 2)
+     (2 2 2 2 2 2 2 2 2 2)
+     (30)
+     (1 1 1 1 1 1 1 1 1 1 1 1 1)
+     (1 1)
+     (34)
+     (1 1 1 1 1 1 1 1 1 1 1 1 1 1)
+     (1 1)
+     (38)
+     (1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)
+     (1 1)
+     (38)
+     (1 32 1)
+     (1 32 1)
+     (1 32 1)
+     (1 32 1)
+     (1 10 1 1 1 10 1)
+     (1 10 1 1 1 10 1)
+     (1 10 2 2 2 10 1)
+     (1 10 2 2 2 10 1)
+     (2 10 10 2)
+     (2 32 2)
+     ())
+    (()
+     (4 2)
+     (1 11)
+     (5 1)
+     (1 1 11)
+     (2 1 8 2 11)
+     (5 7 2 1 11)
+     (2 2 1 1 11)
+     (1 2 10 2 2 11)
+     (5 1 9 1 1 11)
+     (1 1 2 11)
+     (1 11 2 1 11)
+     (14 1 1 11)
+     (1 2 2 11)
+     (17 1 1 5 1)
+     (1 14 1 2 5 1)
+     (1 2 1 9 1)
+     (1 18 1 1 5 2 1)
+     (19 2 2 5 1)
+     (2 1 1 5 2 1)
+     (1 1 2 9 1)
+     (20 2 1 5 1)
+     (1 19 1 1 9 1)
+     (1 2 2 5 2 1)
+     (1 16 1 1 5 1)
+     (17 1 2 5 1)
+     (1 2 1 11)
+     (15 1 1 11)
+     (1 12 2 2 11)
+     (2 1 1 11)
+     (1 9 1 2 11)
+     (12 2 1 11)
+     (1 1 1 11)
+     (8 2 2 11)
+     (1 9 1 11)
+     (2 1 2 11)
+     (5 4 1)
+     (2 1 11)
+     (1 2 4 2)
+     (5)))
+   ("19990722-DRA (43)"
+    ((40)
+     (40)
+     (2 3 1 3 1 2 16)
+     (2 2 1 3 3 3 19)
+     (2 1 1 1 3 3 3 2 5)
+     (2 2 1 3 3 7 1 8 4)
+     (2 3 2 3 3 1 10 3)
+     (24 12 2)
+     (22 13 2)
+     (21 16 1)
+     (7 4 7 17 1)
+     (7 2 7 17 1)
+     (7 1 1 6 16 1)
+     (7 4 6 8 8 2)
+     (6 1 2 1 5 7 7 2)
+     (6 6 5 6 2 5 3)
+     (6 2 2 5 6 3 4)
+     (6 6 4 6 13)
+     (7 2 2 3 5 13)
+     (9 6 3 5 12)
+     (8 9 1 4 12)
+     (7 13 4 12)
+     (7 7 6 3 12)
+     (7 4 2 8 2 11)
+     (4 3 2 10 2 11)
+     (3 6 2 12 2 10)
+     (3 1 2 1 12 2 10)
+     (3 3 1 1 1 12 1 10)
+     (3 5 2 2 3 7 1 9)
+     (3 5 1 1 2 10 9)
+     (3 4 5 1 1 10 9)
+     (4 7 1 10 9)
+     (15 2 9 11)
+     (16 7 11)
+     (2 8 4 7 10)
+     (1 3 6 5 6 10)
+     (5 6 12 9)
+     (5 10 9)
+     (1 3 34)
+     (2 35))
+    ((36 2)
+     (35 2 1)
+     (2 27 4)
+     (3 21 3 4)
+     (4 19 2 3 2 4)
+     (5 18 1 4 3 2 1)
+     (2 7 6 1 4 4 2)
+     (10 4 2 1 4 8)
+     (2 5 2 3 1 6 2 9)
+     (6 5 3 2 8 10)
+     (6 5 3 2 5 1 10)
+     (6 4 2 3 5 4 10)
+     (2 3 4 4 2 6 4)
+     (14 7 2 4 1 3)
+     (2 14 6 2 2 3 1 3)
+     (2 15 3 4 1 1 1 3)
+     (2 11 11 2 1 3)
+     (2 16 11 1 2 2)
+     (2 17 8 1 1 2)
+     (12 2 7 4 1 1 2)
+     (3 1 3 5 1 7 4 1 1 2)
+     (2 1 1 2 9 1 12 1 2)
+     (2 1 1 1 11 12 1 2)
+     (2 1 1 1 13 14 2)
+     (4 1 15 13 2)
+     (6 16 12 2)
+     (5 9 6 10 2)
+     (4 9 4 4 9 2)
+     (4 8 8 3 3 3 2)
+     (4 9 9 1 2 1 2)
+     (4 10 11 4 2)
+     (4 11 23)
+     (4 11 23)
+     (4 11 23)
+     (4 11 23)
+     (5 10 23)
+     (6 8 24)
+     (7 3 25)
+     (9 27)
+     (40)))
+   ("19990801-NEP (44)"
+    ((1 1)
+     (1 1 1 1)
+     (1 1 1 1)
+     (1 1)
+     (1 1)
+     (1 1)
+     (1 1 2 1 1)
+     (1 2 1 1 2 1)
+     (1 3 1 1 3 1)
+     (1 1 3 2 3 1 1)
+     (1 1 2 2 1 1)
+     (1 2 1 1 2 1)
+     (1 2 6 2 1)
+     (1 2 2 2 1)
+     (1 1 1 1)
+     (3 2 2 3)
+     (1 1 1 1)
+     (1 12 1)
+     (5 4 5)
+     (40)
+     (40)
+     (40)
+     (40)
+     (1 1)
+     (40)
+     (1 1 1 1 1 1)
+     (1 1 1 1 1 1)
+     (7 5 5 7)
+     (1 1 1 1 1 1 1 1 1 1 1 1)
+     (1 1 1 5 5 1 1 1)
+     (7 1 1 7)
+     (1 1 1 1 1 1 1 1)
+     (1 1 1 1 1 1 1 1)
+     (7 1 1 7)
+     (1 1 1 1 1 1 1 1)
+     (1 1 1 1 1 1 1 1)
+     (7 5 5 7)
+     (1 1 1 2 2 2 2 1 1 1)
+     (1 1 1 2 8 2 1 1 1)
+     (7 2 2 2 2 7))
+    ((21)
+     (5 1 1 1 1 1 1)
+     (2 1 5 1 4 4 1)
+     (1 20 1 1 1 1 1 1)
+     (2 1 5 4 4 4)
+     (5 1 1 1 1 1 1)
+     (4 16)
+     (4 1)
+     (4 1)
+     (4 1 2)
+     (4 1 3)
+     (4 1 3 2)
+     (4 1 1 1 1)
+     (6 4 1 10)
+     (2 2 1 4 1 1 1 1)
+     (2 2 3 4 1 3 2)
+     (1 3 1 4 1 3)
+     (4 1 4 1 2)
+     (2 1 1 6 1 1)
+     (1 1 2 6 1 1)
+     (1 1 2 6 1 1)
+     (2 1 1 6 1 1)
+     (4 1 4 1 2)
+     (1 3 1 4 1 3)
+     (2 2 3 4 1 3 2)
+     (2 2 1 4 1 1 1 1)
+     (6 4 1 10)
+     (4 1 1 1 1)
+     (4 1 3 2)
+     (4 1 3)
+     (4 1 2)
+     (4 1)
+     (4 1)
+     (4 16)
+     (5 1 1 1 1 1 1)
+     (2 1 5 4 4 4)
+     (1 20 1 1 1 1 1 1)
+     (2 1 5 1 4 4 1)
+     (5 1 1 1 1 1 1)
+     (21)))
+   ("19990807-DRN (45)"
+    ((2)
+     (1)
+     (2)
+     (3)
+     (2)
+     (1)
+     (2)
+     (3)
+     (2)
+     (1)
+     (2)
+     (3)
+     (2)
+     ()
+     (2)
+     (1 2 4)
+     (5 2 1 1)
+     (2 2 2 1 1 1)
+     (2 2 2 1 1 1 2)
+     (1 2 2 2 1 1 1)
+     (2 2 1 1 1 2)
+     (2 1 1 2)
+     (12 4)
+     (1 2)
+     (1 2)
+     (2 3 1 4)
+     (1 3 1 1 1 6)
+     (2 3 3 1 15)
+     (3 1 17)
+     (3 1 20 2)
+     (13 19 4)
+     (15 16 6)
+     (17 11 7)
+     (19 6 10)
+     (22 4 12)
+     (23 13)
+     (27 12)
+     (28 11)
+     (29 10)
+     (30 9))
+    ((13 1 2 1 1 1 10)
+     (1 3 3 3 5 1 3 10)
+     (1 1 1 2 1 10)
+     (2 3 1 14)
+     (2 3 1 14)
+     (2 1 14)
+     (2 1 10)
+     (2 1 3 10)
+     (2 1 1 1 10)
+     (3 3 10)
+     (2 10)
+     (18)
+     (10)
+     (9)
+     (9)
+     (1 8)
+     (2 8)
+     (3 7)
+     (4 7)
+     (6 6)
+     (6 6)
+     (4 6 6)
+     (2 1 1 8 5)
+     (2 1 1 1 10 4)
+     (1 1 1 14 4)
+     (2 1 1 13 4)
+     (1 1 1 2 10 4)
+     (1 1 2 8 1 3)
+     (4 6 3 2)
+     (6 4 1)
+     (5 6)
+     (5 7)
+     (5 7)
+     (4 8)
+     (2 9)
+     (1 9)
+     (10)
+     (10)
+     (11)
+     (11)))
+   ("19990808bVAC (46)"
+    ((5 5 5)
+     (3 2 3 3 2 3)
+     (2 2 2 1 1 2 2 2)
+     (2 2 2 9 2 2 2)
+     (1 2 1 3 3 1 2 1)
+     (2 3 2 2 2 1 1 2 2 2 3 2)
+     (1 2 1 1 2 2 1 1 2 1)
+     (1 2 2 4 1 4 2 1 1)
+     (1 2 2 1 4 4 1 1 1 2 1)
+     (1 2 1 1 5 5 1 2 2 1 1)
+     (1 2 2 1 4 4 2 1 2 1)
+     (1 1 1 1 4 5 1 1 1 1)
+     (1 2 2 2 4 4 2 1 2 1 1)
+     (2 1 1 1 5 1 5 2 2 1 2)
+     (1 2 1 1 13 1 1 1 2 1)
+     (1 1 3 3 5 3 3 1 1)
+     (2 1 2 5 1 3 1 6 1 2)
+     (1 1 1 3 1 1 1 1)
+     (2 2 7 1 1 8 1 2)
+     (2 3 7 3 2)
+     (3 3 4 4 3 1 3)
+     (5 4 4 3 1)
+     (2 6 6 1 2)
+     (2 3 4 5 4 3 3)
+     (2 2 4 3 4 1 1 2)
+     (1 2 6 5 6 3 1)
+     (2 2 4 5 5 4 2 2)
+     (1 1 4 3 3 4 1 1)
+     (1 2 6 5 5 6 2 1)
+     (1 1 4 5 5 5 4 1 1)
+     (2 3 3 3 3 4 2)
+     (7 5 5 5 7)
+     (2 5 5 5 5 2)
+     (2 3 3 3 3 2)
+     (3 5 5 5 5 3)
+     (7 5 5 5 7)
+     (6 3 3 3 6)
+     (7 5 5 5 7)
+     (33)
+     (2 2))
+    ((9)
+     (3 4)
+     (2 1 2 3 5)
+     (2 1 2 3 2 3 2 4)
+     (1 1 2 3 2 2 2 1 6)
+     (2 2 3 1 2 3 8)
+     (1 1 2 3 3 3 2 4 5)
+     (1 2 2 2 2 1 2 4 4)
+     (1 2 3 1 1 1 2 6 5)
+     (2 2 3 2 2 1 1 4 5 2)
+     (2 3 3 1 1 1 1 4 3 1)
+     (2 4 1 1 1 6 5 2)
+     (3 3 1 1 1 4 5 5)
+     (3 7 1 1 4 3 4)
+     (9 1 6 5 5)
+     (17 4 5 5 2)
+     (1 8 2 4 3 3 1)
+     (2 2 2 2 6 5 5 3)
+     (2 1 1 1 4 2 5 5 6)
+     (1 1 1 5 1 3 3 4)
+     (2 1 1 1 4 2 5 5 6)
+     (2 2 2 2 6 5 5 3)
+     (1 8 2 4 3 3 1)
+     (17 4 5 5 2)
+     (9 1 6 5 5)
+     (3 7 1 1 4 3 4)
+     (3 3 1 1 1 4 5 5)
+     (2 3 1 1 1 1 6 5 2)
+     (2 3 1 1 1 1 1 1 1 4 3 1)
+     (2 2 2 2 1 1 1 1 4 5 2)
+     (1 2 2 1 13 6 5)
+     (1 2 1 1 1 1 1 1 4 4)
+     (1 1 1 2 1 3 8 4 5)
+     (2 2 2 2 3 1 2 3 9)
+     (1 1 1 1 2 2 2 2 1 6)
+     (2 1 2 1 2 2 3 2 4)
+     (2 1 1 3 5)
+     (3 4)
+     (9)
+     ()))
+   ("19990831-DAH (47)"
+    ((40)
+     (40)
+     (40)
+     (14 16)
+     (12 12)
+     (10 12 10)
+     (8 16 9)
+     (7 20 8)
+     (6 22 7)
+     (5 24 6)
+     (5 25 5)
+     (4 34)
+     (4 13 2 2 2 4)
+     (3 12 2 2 2 5)
+     (3 12 2 2 2 2 3)
+     (3 32 3)
+     (3 10 2 2 2 4 2)
+     (2 9 2 2 2 6 2)
+     (2 9 2 2 2 7 2)
+     (2 34 2)
+     (2 7 2 2 2 9 2)
+     (2 6 2 2 2 9 2)
+     (2 4 2 2 2 10 3)
+     (3 32 3)
+     (3 2 2 2 2 12 3)
+     (5 2 2 2 12 3)
+     (4 2 2 2 13 4)
+     (34 4)
+     (5 25 5)
+     (6 24 5)
+     (7 22 6)
+     (8 20 7)
+     (9 16 8)
+     (10 12 10)
+     (12 12)
+     (14 14)
+     (40)
+     (40)
+     (40)
+     (40))
+    ((40)
+     (40)
+     (17 17)
+     (13 4 15)
+     (11 12 13)
+     (9 13 1 11)
+     (8 14 1 10)
+     (7 15 2 9)
+     (6 14 1 3 8)
+     (6 14 3 3 7)
+     (5 13 2 4 6)
+     (5 14 2 5 6)
+     (4 12 1 3 6 5)
+     (4 12 3 1 8 5)
+     (3 11 2 3 6 4)
+     (3 11 2 2 7 4)
+     (3 9 1 3 2 7 4)
+     (3 8 3 1 3 8 4)
+     (3 7 2 3 1 9 4)
+     (3 7 2 2 3 7 4)
+     (3 7 3 2 2 7 4)
+     (3 9 1 3 2 7 4)
+     (3 8 3 1 3 8 4)
+     (3 7 2 3 1 9 4)
+     (4 7 2 2 11 4)
+     (4 6 3 2 11 4)
+     (4 8 1 3 12 5)
+     (4 6 3 1 12 5)
+     (5 5 2 14 6)
+     (5 4 2 13 6)
+     (6 3 3 14 7)
+     (7 3 1 14 7)
+     (8 2 15 8)
+     (9 1 14 9)
+     (10 1 13 10)
+     (12 12 12)
+     (14 4 14)
+     (16 18)
+     (40)
+     (40)))
+   ("19990902-TUC (48)"
+    ((19 3 2 12)
+     (19 3 1 12)
+     (18 1 2 1 12)
+     (18 1 2 2 12)
+     (17 2 1 2 12)
+     (17 2 17)
+     (16 3 16)
+     (16 3 16)
+     (15 3 15)
+     (8 3 8)
+     (8 5 3 5 8)
+     (8 5 2 5 8)
+     (3 3 4 2 4 8)
+     (1 1 3 3 1 3 8)
+     (1 1 3 1 1 1 8)
+     (1 3 2 8)
+     (6 3 6)
+     (4 5 4)
+     (2 6 2)
+     (6)
+     (5)
+     (1 5 2)
+     (3 1 5 4)
+     (5 3 2)
+     (7 2 4 3)
+     (8 1 4 1)
+     (8 2 3 4 3)
+     (8 4 4 4)
+     (8 5 1 5 8)
+     (8 5 3 5 8)
+     (8 3 8)
+     (15 3 15)
+     (16 3 16)
+     (16 3 16)
+     (17 2 17)
+     (12 1 2 17)
+     (12 5 1 18)
+     (12 2 1 19)
+     (15 3 19)
+     (12 3 19))
+    ((12 3 19)
+     (15 3 18)
+     (13 3 1 18)
+     (15 2 1 17)
+     (12 1 2 17)
+     (17 2 1 16)
+     (16 3 16)
+     (16 3 15)
+     (9 3 9)
+     (9 5 3 4 9)
+     (9 4 3 4 9)
+     (9 4 1 3 9)
+     (9 3 3 4 1)
+     (9 2 2 4 1 1)
+     (9 4 1 1)
+     (8 2 3 1)
+     (6 3 6)
+     (4 5 4)
+     (2 6 2)
+     (6)
+     (6)
+     (2 6 3)
+     (4 5 4)
+     (6 5 6)
+     (3 5 8)
+     (1 7 9)
+     (2 6 2 2 9)
+     (4 3 3 9)
+     (9 4 1 4 9)
+     (9 4 3 4 9)
+     (9 5 2 5 9)
+     (9 3 9)
+     (16 2 16)
+     (16 3 16)
+     (17 2 17)
+     (17 2 17)
+     (18 1 1 12)
+     (18 1 1 1 1 12)
+     (19 2 1 1 12)
+     (19 2 3 12)))
+   ("19990905-ARE (49)"
+    ((1)
+     (1)
+     (1 17)
+     (1 19)
+     (1 20)
+     (1 1 3)
+     (1 7 3)
+     (1 5 1 1 3)
+     (1 1 1 1 3)
+     (2 2 1 2 3)
+     (2 3 1 3)
+     (2 5 17 3)
+     (1 5 19 3)
+     (6 21 3)
+     (4 23 3)
+     (2 27)
+     (28)
+     (1 1)
+     (2 23 1)
+     (1 1)
+     (1 2 2 2 2 2 1)
+     (1 2 2 2 2 2 1)
+     (1 2 2 2 2 2 1)
+     (1 2 2 2 2 2 1)
+     (1 2 2 2 2 2 1)
+     (1 2 2 2 2 2 1)
+     (1 2 2 2 2 2 1)
+     (1 2 2 2 2 2 1)
+     (1 2 2 2 2 2 1)
+     (1 2 2 2 2 2 1)
+     (1 2 2 2 2 2 1)
+     (1 2 2 2 2 2 1)
+     (1 1 1 1)
+     (2 31 2)
+     ()
+     (4 3 3 1 3 3 3 4)
+     (2 1 1 1 1 1 1 1 1 1 2)
+     (3 1 2 3 3 1 1 1 3)
+     (2 1 1 1 1 1 1 1 1 2)
+     (4 1 3 1 1 1 3 1 4))
+    ((2 1)
+     (1 3)
+     (5)
+     (3 3 1 1)
+     (3 3 2 2 1 1)
+     (2 4 1 1 1)
+     (1 5 16)
+     (2 5 3 1)
+     (1 5 2 1)
+     (1 4 3 1 12 1 1)
+     (1 1 4 1 12 1 5)
+     (2 1 5 1 1 1)
+     (3 1 6 1 1)
+     (6 6 1 1 5)
+     (3 1 9 1 12 1 1 1 1)
+     (3 1 6 1 12 1 1 1)
+     (3 1 6 1 1)
+     (3 1 1 6 1 1 4)
+     (3 4 6 1 1 1 1)
+     (3 6 1 12 1 4)
+     (3 6 1 12 1)
+     (3 6 1 1 5)
+     (3 6 1 1 1 1)
+     (3 6 1 1 3)
+     (3 6 1 12 1)
+     (3 6 1 12 1 5)
+     (3 6 1 1 1 1)
+     (3 6 1 1 5)
+     (3 6 1 1)
+     (3 5 1 12 1 1)
+     (3 4 1 12 1 5)
+     (3 3 1 1 1)
+     (3 2 1)
+     (12 1)
+     (9 15 1 1)
+     (6 1 1 1)
+     (1 1)
+     (5)
+     (1 3)
+     (2 1)))
+   ("19990916aCAR (50)"
+    ((22 8 6)
+     (3 17 6 5)
+     (2 17 6 4)
+     (3 8 15 3)
+     (11 14 3)
+     (12 15 3)
+     (29 4)
+     (7 14 7 5)
+     (6 12 7 6)
+     (7 4 9 17)
+     (13 26)
+     (14 24)
+     (3 12 23)
+     (2 12 13 7)
+     (3 15 11 6)
+     (11 8 11 7)
+     (10 8 18)
+     (11 10 1 15)
+     (24 1 7 4)
+     (22 1 7 3)
+     (24 6 2)
+     (23 2 4 2)
+     (31 1 1 1)
+     (30 2 2 1 1)
+     (5 1 4 14 8)
+     (4 1 3 12 9)
+     (4 2 2 2 8 10)
+     (5 3 3 3 8 11)
+     (6 3 4 3 5 12)
+     (3 1 5 14)
+     (2 2 3 2 6 15)
+     (2 2 3 2 5 12 3)
+     (2 2 3 2 4 3 3 2 2)
+     (3 4 2 4 2 5)
+     (5 6 11 8)
+     (4 1 2 1 23)
+     (1 1 1 3 1 1 23)
+     (4 1 4 1 1 23)
+     (5 1 6 1 23)
+     (4 1 4 1 22))
+    ((37 2)
+     (36 3)
+     (2 10 16 3 3)
+     (1 8 14 3 2 3)
+     (2 10 11 2 3 1 3)
+     (24 1)
+     (8 15 5)
+     (7 15 2)
+     (8 15 4 5 3)
+     (24 3 5 4)
+     (16 9 5 4)
+     (4 10 12 3 3)
+     (3 3 6 12 3 2 2)
+     (4 5 14 2 3 1 3)
+     (11 12 1)
+     (11 12 5)
+     (12 12 2)
+     (13 15 4 4)
+     (13 15 4 5)
+     (14 11 3 6)
+     (15 10 6 6)
+     (1 6 7 15 6)
+     (4 7 1 11 1 6)
+     (1 6 10 1 8 2 6)
+     (17 1 9 2 6)
+     (19 7 2 7)
+     (18 2 6 3 7)
+     (28 3 7)
+     (3 21 4 7)
+     (2 18 6 6)
+     (1 15 9 5)
+     (5 6 11 5)
+     (4 4 10 6)
+     (5 4 8 7)
+     (1 10 9 7)
+     (2 11 8 8)
+     (3 13 7 8)
+     (20 10 7)
+     (22 9 6)
+     (24 7 6)))
+   ("19990927-BBA (51)"
+    ((2 1)
+     (2 2)
+     (2 3)
+     (2 3)
+     (2 4)
+     (2 4)
+     (2 2 4)
+     (2 2 4)
+     (3 2 2 4)
+     (6 2 2 5)
+     (3 3 2 2 5)
+     (2 3 2 2 2 3)
+     (3 2 2 2 2 3)
+     (2 4 2 2 2 4)
+     (2 2 5 2 2 6)
+     (2 3 4 17)
+     (4 2 4 9 7)
+     (5 2 6 2 2 4)
+     (10 8 2 2 4)
+     (9 2 2 4 2 4)
+     (8 2 2 5 4)
+     (7 2 2 5 3)
+     (7 2 2 2 14)
+     (10 2 2 14)
+     (4 4 2 1 3)
+     (3 5 2 2)
+     (4 3 4 2 2)
+     (7 5 3)
+     (8 8 6)
+     (12 6 7)
+     (10 20)
+     (11 4 15)
+     (14 4 8)
+     (14 4 6)
+     (19 6)
+     (24)
+     (21)
+     (18)
+     (14)
+     (10))
+    ((4)
+     (7)
+     (12)
+     (3 14)
+     (3 15)
+     (2 15)
+     (3 7 8)
+     (2 6 8)
+     (2 8 10)
+     (2 4 13)
+     (3 3 4 9)
+     (2 3 4 8)
+     (3 3 2 10)
+     (3 3 13)
+     (7 4 7)
+     (5 3 7)
+     (24 3 8)
+     (24 12)
+     (2 12)
+     (19 4 7)
+     (16 1 2 6)
+     (4 2 2 3 7)
+     (4 2 1 10)
+     (21 10)
+     (21 10)
+     (5 2 2 3 6)
+     (17 2 5)
+     (15 3 6)
+     (5 2 9)
+     (5 2 8)
+     (5 2 7)
+     (6 3 7)
+     (6 3 6)
+     (2 3 4 5)
+     (2 5 2 5)
+     (2 4 6)
+     (3 4)
+     (2 3)
+     (2 1)
+     (2 1)))
+   ("19991008-LLO (52)"
+    ((6 6 2)
+     (16 1 1)
+     (18 1 4)
+     (5 12 6)
+     (5 14 4)
+     (1 4 15 2)
+     (3 4 15 1 1)
+     (5 4 4 1 1 2)
+     (3 4 2 2 1 3)
+     (2 2 5 1 9 1 1 4)
+     (1 6 3 3 4 1)
+     (1 4 3 2 3 1)
+     (3 2 1 3 2 2 2 1)
+     (5 2 1 2 1 1 2 1 1 2)
+     (4 1 1 2 1 1 2 1 3)
+     (5 4 2 1 2 1 2 1 4)
+     (6 2 3 1 3 4 1)
+     (1 3 1 5 1 1 5 3 1)
+     (5 5 2 5 2 1)
+     (3 2 14 1 2)
+     (4 2 4 4 4 1 3)
+     (8 4 4 1 4)
+     (4 2 12 4 1)
+     (1 3 2 10 3 1)
+     (8 10 2 1)
+     (3 1 2 8 1 2)
+     (4 1 2 6 1 3)
+     (7 1 4)
+     (1 6 1 6 1)
+     (3 1 3 8 1)
+     (3 1 1 1 3 3 4)
+     (7 3 2 2 1)
+     (9 3 2 1 2 1 2)
+     (4 2 2 7 4 4 1 4)
+     (1 3 2 3 7 1 1 2 1 1 1 1)
+     (8 3 1 1 1 1 1)
+     (7 3 2 2 3 1 1 1 3)
+     (8 7 5 1 1 1 1 2 1)
+     (3 8 1 1 1 1 1 1 1)
+     (3 6 6 9))
+    ((1 1 5 5 5 4 2)
+     (4 5 5 4 5 5)
+     (4 30)
+     (4 7 5 3 10)
+     (1 1 1 5 1 3 3 2 4)
+     (1 5 1 3 4 3)
+     (7 1 6 3 7)
+     (10 2 1 4 3 1 2 1)
+     (13 2 1 2 1 3 2)
+     (13 2 1 2 2 2)
+     (5 3 2 1 1 2)
+     (4 4 1 1 1)
+     (3 6 7 1)
+     (3 4 1 7 3 2)
+     (8 2 7 5 3)
+     (7 1 4 8 3 3 3)
+     (6 2 2 9 2 2 2)
+     (7 1 1 2 6 2 2 2)
+     (7 1 1 2 2 8 2 2)
+     (7 1 1 3 8 2 2)
+     (7 1 1 1 3 9 3 3)
+     (7 1 1 1 2 6 3 5)
+     (7 1 2 2 6 2 3)
+     (6 1 3 9 2 3)
+     (5 2 8 2 2 1)
+     (4 2 7 2 1 1)
+     (2 3 7 7)
+     (2 6 1)
+     (8)
+     (2)
+     (2)
+     (8)
+     (2 20 1 1)
+     (1 2 1 3 3 3 12)
+     (1 4 3 3 3 1 1)
+     (1 4 3 3 3 1 1 1)
+     (4 4 3 3 2 2 3)
+     (2 20 2 2 1)
+     (2 1 1)
+     (7)))
+   ("19991011-VAL (53)"
+    ((2)
+     (2)
+     (10)
+     (16)
+     (18)
+     (18)
+     (1 1)
+     (3 6 3)
+     (2 1 2 2 1 2)
+     (1 2 4 2 1)
+     (1 1 6 1 1)
+     (1 6 1)
+     (1 6 1)
+     (1 4 1)
+     (1 1)
+     (3 6 3)
+     (2 1 2 2 1 2)
+     (1 2 4 2 1)
+     (1 1 1 1 1 1)
+     (1 1 1 1)
+     (1 1 1 1)
+     (1 4 1)
+     (1 1)
+     (3 6 3)
+     (2 1 2 2 1 2)
+     (1 2 4 2 1)
+     (1 1 1 1 1 1)
+     (1 1 1 1)
+     (1 1 1 1)
+     (1 4 1)
+     (1 1)
+     (1 1)
+     (18)
+     ()
+     ()
+     (4 5 4 4)
+     (1 1 1 1 1 1)
+     (4 1 1 1 4)
+     (1 1 1 1 1)
+     (4 1 4 1))
+    (()
+     ()
+     ()
+     ()
+     ()
+     ()
+     ()
+     (1 1 1)
+     (1 1 1)
+     (1 1 1)
+     (1 1 1 3 1)
+     (29 1 1 1)
+     (3 1 1 1 1)
+     (3 1 1 3)
+     (3 1)
+     (4 2 2 2 1 1)
+     (4 2 2 2 1 1)
+     (4 2 3 2 3 2 3 1 5)
+     (4 1 5 1 1 1 1 1 1 1 1)
+     (6 1 5 1 1 1 1 1 1 1 1)
+     (6 1 5 1 1 1 1 1 1 1)
+     (4 1 5 1 1 1 1 1 1 1 5)
+     (4 2 3 2 3 2 3 1 1 1)
+     (4 2 2 2 1 1 1)
+     (4 2 2 2 1 5)
+     (3 1)
+     (3 1 5)
+     (3 1 1 1)
+     (29 1 1)
+     (1 1 1 3)
+     (1 1 1)
+     (1 1 1)
+     (1 1 1)
+     ()
+     ()
+     ()
+     ()
+     ()
+     ()
+     ()))
+   ("19991103-BDH (54)"
+    ((12 23)
+     (11 22)
+     (10 21)
+     (10 20)
+     (9 20)
+     (10 18)
+     (10 11)
+     (11 10)
+     (12 10)
+     (14 5 4)
+     (14 4 4)
+     (9 3 5 4 5)
+     (9 1 9 4)
+     (10 2 1 2)
+     (11 3 7 1)
+     (11 4 9 1)
+     (10 5 9 1)
+     (9 5 10)
+     (8 7 10)
+     (8 8 9)
+     (8 1 5 2 9)
+     (8 2 4 1 1 9)
+     (8 3 4 1 2 10)
+     (8 4 3 2 2 10)
+     (8 5 3 2 2 10)
+     (8 2 2 3 2 3 10)
+     (9 2 1 5 4 10)
+     (9 2 2 3 5 10)
+     (10 2 2 6 10)
+     (10 3 11 11)
+     (11 11 11)
+     (10 15 1 11)
+     (8 13 1 11)
+     (8 5 1 11)
+     (9 3 3 2 1 11)
+     (10 5 2 1 11)
+     (19 2 2 11)
+     (20 2 2 12)
+     (21 4 13)
+     (22 14))
+    ((40)
+     (40)
+     (40)
+     (40)
+     (40)
+     (40)
+     (40)
+     (40)
+     (18 6 6)
+     (4 6 4 5 4 1 5)
+     (2 5 2 7 1 3 4)
+     (1 4 7 4 4)
+     (3 1 2 2 4 4)
+     (2 1 2 1 3 5)
+     (1 5 2 6)
+     (1 2 3 6)
+     (1 7 4 6)
+     (1 1 10 4 5)
+     (2 1 11 4 1 4)
+     (3 1 12 4 2 3)
+     (5 1 12 4 2 2)
+     (5 1 2 3 4 2 1)
+     (6 1 2 2 4 2)
+     (6 1 2 2 4 1)
+     (6 2 6 5 1)
+     (6 2 2 6 2)
+     (6 2 5 2 1)
+     (6 2 7 6 2)
+     (6 1 2 8 3)
+     (7 3 11)
+     (11 5 18)
+     (11 26)
+     (11 26)
+     (11 26)
+     (10 26)
+     (9 1 25)
+     (13 25)
+     (13 24)
+     (14 23)
+     (40)))
+   ("19991109-TMA (55)"
+    ((35)
+     (1 1 1 1 17)
+     (1 4 2 1 4 20)
+     (1 1 1 1 2 1 16 2)
+     (1 2 1 1 2 4 2 19)
+     (1 1 2 1 1 20)
+     (40)
+     (1 20)
+     (40)
+     (14 1 1 1 1 1 1)
+     (14 1 1 1 2 1 2 1 2 1 4)
+     (14 3 1 2 1 2 1 1 2)
+     (14 3 1 2 1 2 1 1 2 4)
+     (7 6 3 1 1 1 2 1 1)
+     (7 32)
+     (6 5 1)
+     (1 1 1 1 1 26)
+     (2 6 1 4 1 2)
+     (1 8 1 6 1 1 1 2)
+     (3 9 2 1 1 1 2)
+     (4 10 4 6 3 2)
+     (1 2 2 1 6 2 4 1 2)
+     (1 1 1 26)
+     (4 2)
+     (1 26)
+     (2 6 2 2 1 3)
+     (3 1 11)
+     (7 9 1 1 3 1 1 2)
+     (7 8 1 1 2 7 3)
+     (7 7 2 2 3 5 4)
+     (13 1 3 3 5)
+     (11 11 1 5)
+     (9 4 1 1 6 5)
+     (7 2 3 1 1 1 10 3)
+     (5 4 2 1 6 2 2)
+     (4 5 5 3 5 2 1)
+     (2 3 4 1 5 3)
+     (1 20 3)
+     ()
+     (6 22 5))
+    ((21 1 2 11 1)
+     (1 1 8 1 3 1 10 1)
+     (1 3 1 9 2 9 1)
+     (1 1 1 1 8 2 9 1)
+     (1 1 1 9 2 8 1)
+     (7 8 7 1)
+     (1 1 7 7)
+     (1 1 3 5 3)
+     (1 1 2 7 6)
+     (1 1 1 8 5 1 1)
+     (7 9 2 5 4 1)
+     (1 1 8 2 4 4 1)
+     (1 1 1 1 9 2 4 5 1)
+     (1 1 1 1 8 1 3 1 3 3 1 1)
+     (1 3 1 1 1 5 1 2 3 1 2 1)
+     (7 1 5 13 3 3 1)
+     (1 1 2 4 12 8 1)
+     (1 3 1 1 5 11 2 7 1)
+     (1 1 1 1 1 1 10 1 1 1 1 1)
+     (1 1 1 7 1 5 1 1 1 1 1 1)
+     (9 1 1 5 1 1 1 1)
+     (9 3 1 1 1 1 2 1 7 1)
+     (9 3 1 1 4 6 1 1 1 1)
+     (9 1 7 1 1 1 1 1 1)
+     (15 1 1 1 2 3 1 1 1)
+     (9 1 1 1 1 1 3 10 1)
+     (9 3 1 1 1 1 1 2 2 5 1)
+     (9 3 1 7 1 3 1 5 1)
+     (9 1 3 3 1 4 7 1)
+     (15 3 3 1 1 3 6 1)
+     (9 1 7 1 1 3 3 1)
+     (9 1 3 1 1 1 3 3 2)
+     (9 1 2 1 1 1 1 1 4 2)
+     (9 1 1 1 1 1 1 1 2)
+     (15 7 4 1)
+     (8 1 1 1 1 3 3 1 1)
+     (2 5 1 1 1 1 1 1 1 2 4 4 1)
+     (6 1 1 1 1 1 1 6 3 1)
+     (6 3 1 9 8 2 1)
+     (20 9 1)))
+   ("19991118-CIT (56)"
+    ((24 15)
+     (1 17 15)
+     (1 12 3 3 10)
+     (3 8 3 1 1 1 1 3 4)
+     (3 9 1 2 1 1 1 1 2 1 5)
+     (3 10 3 1 1 1 1 3 6)
+     (3 9 1 2 1 1 1 1 2 1 5)
+     (13 3 1 1 1 1 3 4)
+     (1 12 3 3 10)
+     (1 5 3)
+     (3 7 3)
+     (3 14 3 3 10)
+     (1 6 1 1 1 1 3 4)
+     (1 6 3 1 1 1 1 1 2 1 5)
+     (13 3 1 1 1 1 1 3 6)
+     (1 6 3 1 1 1 1 1 2 1 5)
+     (1 6 1 1 1 1 3 4)
+     (1 16 3 3 10)
+     (1 9 3)
+     (1 5 3)
+     (1 12 3 3 10)
+     (13 3 1 1 1 1 4)
+     (14 1 2 1 1 1 1 1 3 4)
+     (15 3 1 1 1 1 1 3 4)
+     (14 1 2 1 1 1 1 1 3 4)
+     (1 6 3 1 1 1 1 4)
+     (1 12 3 3 10)
+     (3 19 15)
+     (3 35)
+     (3 35)
+     (3 35)
+     (40)
+     (1 1 4 1 1 2)
+     (1 1 4 1 1 6)
+     (1 2 1 10 3 2 1 3)
+     (1 1 10 3 2 1 3)
+     (1 1 6 3 1 6)
+     (1 2 1 6 3 1 2)
+     (40)
+     (40))
+    ((40)
+     (1 5 2 1 4 5 2)
+     (1 5 2 1 4 5 2)
+     (1 1 1 2 4 1 1 3)
+     (1 1 1 2 4 1 1 3)
+     (1 5 2 1 2 4 5 2)
+     (1 5 2 1 2 4 5 2)
+     (40)
+     (32 2)
+     (32 2)
+     (32 2 2)
+     (32 2 2)
+     (9 7 12 2 2)
+     (3 3 1 1 1 1 3 6 2 2)
+     (4 1 2 1 3 1 2 1 15)
+     (5 3 1 3 1 3 16)
+     (4 1 2 1 3 1 2 1 15)
+     (3 3 1 1 1 1 3 14)
+     (9 7 12 6)
+     (2 5 6)
+     (2 5 2)
+     (9 7 12 2)
+     (3 1 1 1 1 6 6)
+     (3 3 1 1 3 1 1 3 6 6)
+     (12)
+     (3 3 1 1 3 1 1 3 6 2)
+     (3 1 1 1 1 6 2)
+     (9 7 12 2 2)
+     (2 5 2 2)
+     (2 5 2)
+     (9 7 12 2)
+     (3 3 1 1 3 1 1 14)
+     (4 1 2 2 1 2 1 3 6 2)
+     (5 3 3 3 1 3 6 2)
+     (4 1 2 2 1 2 1 3 6 1 1 2)
+     (3 3 1 1 3 1 1 6 1 1 2)
+     (9 7 12 1 1 2)
+     (32 4 2)
+     (40)
+     (40)))
+   ("19991119aKHO (57)"
+    ((19 5 8)
+     (11 3 3 7)
+     (10 2 1 5 1 5 6)
+     (9 3 2 2 1 1 2 6)
+     (9 1 2 2 2 2 2 6)
+     (9 2 4 2 2 2 3 7)
+     (5 4 3 2 2 2 3 1 4)
+     (4 4 4 2 2 2 2 2 3)
+     (3 2 2 4 2 1 1 1 2 3 3)
+     (3 2 3 3 1 1 1 3 4 2)
+     (3 4 4 3 1 1 2 4 2 1)
+     (4 4 3 2 1 2 4 4 1)
+     (2 1 4 13 3 2 2 1)
+     (1 5 6 3 5 1)
+     (2 5 1 1 1 2 4 2)
+     (2 3 1 1 3 3 1 1 5 1)
+     (2 5 1 2 2 2 3 1)
+     (1 5 1 1 2 2 1 2 2)
+     (2 4 2 3 1 1 2 3)
+     (2 5 1 1 1 1 1 2 3)
+     (1 4 1 2 2 1 2 1 2 3)
+     (1 3 1 1 2 1 3 2)
+     (1 3 1 3 1 2 1 1 4 2)
+     (4 2 2 1 1 1 5 2)
+     (1 2 2 2 3 2 6 2)
+     (2 1 2 2 3 2 2 2 4 2)
+     (5 1 3 3 2 1 1 1 2 2)
+     (6 1 1 2 3 2 2 2 2 2)
+     (8 2 2 2 2 2 2 4 2)
+     (7 3 3 1 1 1 5 2)
+     (7 2 4 1 2 1 2 6 2)
+     (8 1 3 3 2 2 2 8 2)
+     (9 3 3 2 2 1 9 3)
+     (9 2 1 2 3 1 9 3)
+     (10 1 3 2 2 3 4)
+     (13 2 1 2 3 1 5)
+     (14 5 3 12)
+     (22 3 11)
+     (22 3 9)
+     (21 1 1 1 8))
+    ((14 4 16)
+     (13 2 15)
+     (12 3 14)
+     (8 1 5 5 14)
+     (7 1 1 2 2 14)
+     (6 3 2 1 2 1 1 13)
+     (6 5 2 2 2 2 12)
+     (6 1 2 2 2 1 2 1 9)
+     (6 1 2 1 1 2 2 2 2 8)
+     (3 3 2 1 1 1 2 3 5 6)
+     (2 2 3 1 1 1 2 2 2 2 5)
+     (1 4 2 1 1 2 1 3 4 5)
+     (1 1 3 1 2 2 2 4 5 6)
+     (1 2 3 2 1 1 1 2 1 4 1 4)
+     (1 4 3 4 2 1 3 2 2 3)
+     (2 3 2 3 5 5 3)
+     (3 3 2 2 1 1 2 2 5 4)
+     (2 4 1 2 2 1 1 3 2 5)
+     (1 2 5 2 6 2 4)
+     (6 2 3 5 4)
+     (1 6 1 1 2 2 4 5)
+     (1 2 2 1 1 2 4 1 2)
+     (1 6 1 1 1 2 3 4)
+     (6 1 1 1 2 1 1)
+     (1 2 2 1 3 4)
+     (2 7 2 2 2 2 2 5)
+     (4 3 2 1 1 1 1 1 1 1 2 1 1 3)
+     (2 2 2 1 3 1 2 1)
+     (1 3 3 3 1 1 1 3 1 1)
+     (1 3 4 2 2 1 6 3)
+     (1 2 4 1 1 1 8 2)
+     (4 4 3 1 8 3)
+     (1 3 1 3 5 2 7 4)
+     (2 1 2 4 5 6 4)
+     (6 15 4 4)
+     (6 2 15 2 5)
+     (7 7 6 6)
+     (9 3 1 3 8)
+     (10 1 24)
+     (16 23)))
+   ("19991126-JOJ (58)"
+    ((12 2 2 13)
+     (12 6 7 11)
+     (11 17 9)
+     (11 19 8)
+     (9 19 9)
+     (8 22 8)
+     (9 11 1 7 7)
+     (9 3 1 2 7 6)
+     (9 3 2 2 5 7)
+     (8 3 2 1 4 8)
+     (9 2 2 2 3 8)
+     (9 3 1 2 1 2 2 9)
+     (10 3 1 2 1 2 2 10)
+     (10 2 1 2 1 2 3 9)
+     (11 2 2 1 2 2 10)
+     (12 2 1 1 2 11)
+     (12 1 5 5 12)
+     (13 1 1 1 12)
+     (14 12)
+     (13 2 11)
+     (12 4 4 10)
+     (12 12 10)
+     (11 1 9 1 9)
+     (10 1 8 3 8)
+     (10 2 7 5 7)
+     (9 3 7 6 6)
+     (8 2 7 5 5)
+     (7 2 7 5 4)
+     (5 2 7 6 3)
+     (3 3 6 7 1)
+     (8 4 4 8 5)
+     (14 15)
+     (4 2 9 2 10)
+     (1 1 1 4 2 1 1 2 1 2)
+     (1 1 1 2 1 1 3 1 2 1 1 1 1 1)
+     (1 2 2 2 3 1 2 1 1 1 1 1)
+     (1 1 2 2 3 2 2 1 2 1 2)
+     (12 3 3 11 3)
+     (15 4 11 3)
+     (15 5 16))
+    ((32 3)
+     (32 1 1 3)
+     (32 1 3)
+     (29 4 4)
+     (29 3 1 3)
+     (28 3 1 3)
+     (28 3 6)
+     (27 2 3)
+     (5 3 16 2 6)
+     (4 1 1 13 4 6)
+     (4 7 9 4 3)
+     (2 10 7 6 6)
+     (7 4 3 3 3 2 2)
+     (7 1 3 1 3 2 4 3)
+     (8 1 1 1 4 4 1 5)
+     (6 2 3 1 1 5 6)
+     (6 1 1 1 1 10 5)
+     (6 5 1 11 3 1)
+     (7 3 1 11 2 2)
+     (6 2 10 1 3)
+     (6 1 1 8 4)
+     (5 2 6 5)
+     (5 3 1 6 1)
+     (6 1 1 1 1 4)
+     (6 1 5 1 3 2 1)
+     (7 1 3 1 2 3 9)
+     (7 1 1 6 10)
+     (1 8 4 9 3)
+     (1 13 3 8 1 1 3)
+     (2 9 1 5 7 1 3)
+     (2 1 6 1 8 8 4)
+     (3 1 3 12 6 2 3)
+     (6 1 15 6 4)
+     (7 17 5 4)
+     (26 2 2 3)
+     (27 4 4)
+     (28 3 1)
+     (29 3 2 3)
+     (29 4 4)
+     (40)))
+   ("19991202-DAN (59)"
+    ((13)
+     (27)
+     (18 21)
+     (18 21)
+     (4 8 4 2 12 5)
+     (4 3 2 4 2 10 5)
+     (4 1 1 4 2 6 6)
+     (4 5 3 6)
+     (4 6 4 7)
+     (4 6 4 7)
+     (5 7 4 6)
+     (5 2 4 3 2 2 5)
+     (11 3 3 1 1 4)
+     (6 2 3 2 3)
+     (6 1 4 2 3 3)
+     (6 5 2 1 4)
+     (5 6 3 1 5)
+     (4 11 4 1 1 1 6)
+     (4 11 5 3 7)
+     (1 4 7)
+     (4 11)
+     (4 12 4 7)
+     (5 12 4 6)
+     (5 12 4 6)
+     (5 11 3 6)
+     (5 11 3 5)
+     (5 11 3 5)
+     (5 11 2 4)
+     (5 10 2 3)
+     (6 10 2 3)
+     (5 10 1 3)
+     (5 10 3)
+     (5 10 3)
+     (3 5 3)
+     (3 4 3)
+     (3 4 3)
+     (4 5 3)
+     (4 4 3)
+     (5 5 3)
+     (5 5 3))
+    ((15)
+     (28)
+     (17 20)
+     (17 20)
+     (2 9 20)
+     (3 4 11 4)
+     (4 1 4 2)
+     (5 1 2 4)
+     (4 3 2 8)
+     (3 2 2 13)
+     (5 2 2 13)
+     (4 2 2 13 2)
+     (3 3 3 13 4)
+     (3 4 4 20)
+     (11 5 20)
+     (18 20)
+     (18 17)
+     (18 14)
+     (1 12)
+     (18)
+     (19 10)
+     (3 6 4 9)
+     (4 3 3 6)
+     (5 2 3)
+     (5)
+     (6 2)
+     (6 1 1)
+     (7 1 1)
+     (7 5)
+     (7 1 1)
+     (7 1 1)
+     (6 2)
+     (6 2 1)
+     (5 2 3 4)
+     (4 5 4 7)
+     (12 5 19)
+     (20 19)
+     (20 19)
+     (20 6)
+     (13)))
+   ("19991203-DAN (60)"
+    ((3 3 1 1 4)
+     (1 1 1 2 1 1 1)
+     (1 1 1 1 1 1 1 1 3)
+     (1 1 1 1 2 1 1)
+     (3 3 1 1 4)
+     (5)
+     (4 2 1 1 3 7)
+     (1 1 1 1 1 1 1 2 6)
+     (3 1 1 1 1 3 11)
+     (1 4 1 1 1 1 11)
+     (3 1 1 4 1 1 11)
+     (6)
+     (19 7)
+     (6)
+     (7)
+     (7)
+     (6)
+     (7)
+     (6)
+     (10 6)
+     (14 5)
+     (16 5)
+     (18 5)
+     (26)
+     (25)
+     (25)
+     (24)
+     (24)
+     (23)
+     (24)
+     (23)
+     (22)
+     (5 4 4)
+     (5 4 4)
+     (5 4 4)
+     (6 4 4)
+     (7 4 4)
+     (8 4 4)
+     (7 4 4)
+     ())
+    ((5 2 1 1 1)
+     (1 1 1 1 1 1 2)
+     (1 1 1 1 1 1 2)
+     (3 1 2 1 3)
+     (1 3)
+     (1 1 4 1 4)
+     (5 1 1 1 4)
+     (1 1 1 1 1 4)
+     (4 1 5)
+     (5 1 6)
+     (1 5 1 7)
+     (1 1 1 8)
+     (1 1 1 11)
+     (5 5 1 11)
+     (1 11)
+     (5 5 1 17)
+     (1 1 1 1 1 19)
+     (1 1 1 1 1 20)
+     (5 1 2 1 20)
+     (13 2)
+     (1 13)
+     (1 13)
+     (1 13)
+     (2 13)
+     (4 13)
+     (5 18)
+     (2 3 20)
+     (6 19)
+     (6 19)
+     (8 11 2)
+     (11 10)
+     (12 8)
+     (13 8)
+     (22)
+     (18)
+     (15)
+     (12)
+     (7)
+     ()
+     ())))))
diff --git a/collects/games/paint-by-numbers/raw-problems/raw-misc.ss b/collects/games/paint-by-numbers/raw-problems/raw-misc.ss
new file mode 100644
index 0000000000..841909f98f
--- /dev/null
+++ b/collects/games/paint-by-numbers/raw-problems/raw-misc.ss
@@ -0,0 +1,38 @@
+#|
+
+raw-problems.ss
+
+This file contains the built-in problems in a raw format. It is
+intended to be processed by the solver which will produce
+`problems.ss'. This file should contain a single sexpression of this
+type:
+
+  (listof (list string cols rows))
+
+The cols and rows types are specified in sig.ss
+
+|#
+
+`(
+
+  ("Happy Happy Joy Joy"
+   ((5) (9) (2 7) (4 8) (4 7) (6 7) (7 7) (7 6) (7 5) (5 1 4) (4 2 3) (2 4 1) (9) (5))
+   ((4) (8) (10) (12) (1 8 1) (2 5 2) (4 3 3) (5 4) (7 5) (8 3) (9 1) (10 1) (10) (8) (4)))
+
+;  ("Ieleuj"
+;   ((1) (1) (2) (1) (1) (2) (1) (1) (1 2) (5) (3) (1) (1) (1 3) (4 2) (3) (1) (1 1) (1 3) (4 1 3) (2 2 2) (6) (1) (1) (1 1) (1 1 2) (3 1 3) (4 1 3) (6) (3) (1) (1 1) (3 1 3) (2 1 1 1 2) (2 1 1 1 2) (5 3 1) (2 1 2) (9) (3 1 1) (1) (1 1 1) (2 1 2) (3 1 1 1 3) (2 1 1 1 2) (1 4 1 4 1) (2 1 2) (9) (3 1 3) (1) (1) (1) (1) (1))
+;   ((1) (1 2) (2 2) (1 1 2 1) (1 1 1 2) (1 1 1 1 2 2 2 2) (3 1 2 1 2 2 1 1 1 1) (7 2 1 1 1 2 1 2) (7 2 3 4 4) (2 7 2 4 4) (1 2 11 1 1) (2 2 1 21) (1 3 2 1 1 1) (2 2 5 4) (2 2 2 4) (2 2 1 2 1 2) (2 2 1 1) (1 1 2) (2 2) (2 1) (2 2) (2) (1)))
+
+;  ("John "
+;   ((15 16) (9 2 1 2 14) (6 1 2 2 1 2 12) (9 2 1 1 1 13) (4 1 1 2 2 1 1 1 11) (5 2 1 1 1 1 1 1 10) (4 2 1 1 2 1 1 2 10) (3 1 1 2 2 1 1 1 1 1 4 3) (2 3 2 2 4 1 1 1 1 1 4) (1 1 1 2 2 3 2 1 1 1 1 2 2) (1 2 1 6 2 2 1 6 3) (2 1 3 8 1 3 1 2 2) (1 1 2 1 2 2 2 1 2 5 3) (2 1 1 10 1 10) (1 1 1 2 1 1 1 2 2 2 2 1) (2 2 2 2 1 2 1 1 6 2) (1 1 1 1 1 3 1 2 1 1 1 3) (1 1 3 1 1 1 2 1 1 2 2 1 1) (3 1 3 2 1 1 1 2 2 2 1) (1 2 2 2 2 2 1 1 1 1 1 2) (1 1 2 2 3 2 1 1 2 2 1 1) (2 2 2 3 4 4 2 4) (1 2 1 4 2 1 2 1 2 1 1) (3 3 1 2 4 10) (1 1 1 1 7 1 2 1 1 1) (2 3 1 1 1 9 5) (1 2 2 1 2 1 2 5 1) (1 1 2 1 1 1 1 2 1 1 1 2) (2 1 1 2 1 1 1 3 2 1 1) (1 1 2 1 2 2 1 1 2 1) (1 1 1 1 1 1 2 2 1 1 1) (2 1 1 2 1 1 2 1 1 1) (1 1 2 1 1 1 1 1 2 1 1 1))
+;   ((11 1 1 1 3 4 4) (9 1 4 2 1 1 1 1 1) (8 5 2 1 3 5 1) (7 1 1 3 2 3 2 1) (4 1 3 3 1 1 3 2 4 1) (5 1 1 1 1 1 3 1 2 1 1 1 2) (2 1 3 1 1 1 1 1 1 1 2 1 1 1) (6 5 3 6 3 1 2) (2 1 3 2 2 2 1 1 1 1 2) (1 1 2 1 2 2 2 2 8 1) (5 1 6 1 1 4 1 3) (2 1 1 2 2 2 1 1 2 7 1) (1 1 1 2 5 6 3 1 2) (5 1 2 4 1 1 2 2 4 1) (1 1 5 1 1 2 2 4 1 1) (4 1 1 8 5 1 2 3) (2 1 3 3 2 1 5 2) (1 3 1 3 5 1 2 2 1 2) (3 1 2 1 1 1 1 2 2 2 4 1) (2 2 1 1 1 1 1 1 2 4 1 1) (4 4 1 1 1 1 2 3 3 2 1) (5 1 5 2 2 1 2 2 1) (9 2 1 3 2 3 3 1) (7 7 1 3 2 1) (9 1 10 3 2) (8 5 1 1 1 2 1 1 1) (9 1 5 2 1 4) (8 6 3 4 1) (7 2 1 1 2 1 1 1 1) (9 1 4 5 1) (14) (13)))
+
+;  ("buff"
+;   ((2 3 3) (2 2 2 2 2) (2 2 2) (5 2 2 2 2) (2 4 7 5) (2 4 2 2 2) (2 4 2 2 2) (2 4 3 2 2) (5 5 2 2))
+;   ((9) (9) (1 1) (1 1) (6) (4) (5) (6) (1) (2) (6) (6) (1) (8) (9) (1 1) (2 1) (1) (1) (8) (9) (1 1) (2 1) (1)))
+
+  ("Solver Breaker"
+   ((1) (2 2) (1) (2) (2 2) (1))
+   ((1) (2 2) (1 1) (1) (2 2) (1)))
+
+  )
diff --git a/collects/games/paint-by-numbers/raw-problems/raw-problems.ss b/collects/games/paint-by-numbers/raw-problems/raw-problems.ss
new file mode 100644
index 0000000000..3fd0ef19b7
--- /dev/null
+++ b/collects/games/paint-by-numbers/raw-problems/raw-problems.ss
@@ -0,0 +1,77 @@
+#|
+
+raw-problems.ss
+
+This file contains the built-in problems in a raw format. 
+This file should contain a single sexpression of this
+type:
+
+  (listof (list string cols rows))
+
+The cols and rows types are specified in sig.ss
+
+|#
+
+`(
+
+  ("Izay (1)"
+   ((2) (1 1) (4)   (2 1) (3 1) (8) (8) (7) (5) (3))
+   ((1) (2)   (1 6) (9)   (6)   (5) (5) (4) (3) (4)))
+  ("Oam (2)"
+   ((1) (2 3 1) (9) (8) (8)
+	(3 2 1) (6 6) (9 4) (11 2) (13)
+	(2 10) (7 11) (8 5 5) (8 4 3) (8 4 2)
+	(2 5 5) (1 4 2 3 2) (2 1 4 2) (9 3) (7))
+   ((5) (9) (7 2) (3 6 2) (3 6 2)
+	(4 6 2) (4 6 2) (5 4 2) (6 1 2) (11 2)
+	(14 2) (6 10) (6 10) (3 2 4 4) (8 2 2)
+	(8 3 2) (4 2 3) (5 3 2) (2 4 2) (3)))
+  ("Izuoh (3)"
+   ((2) (3) (3) (2) (2)
+    (2) (4 2) (6 2) (6 3) (1 2 1 6)
+    (2 2 9) (1 1 7) (1 1 5) (3 1 2) (2 6)
+    (11) (13) (13) (4 10 2) (4 10 4)
+    (4 10 4) (4 10 4) (4 9 4) (4 9 4) (3 8 3)
+    (3 11 3) (3 3 2 3) (5 5 4 2) (3 1 10 4) (3 1 8 5))
+   ((3) (5) (7) (7) (6 3)
+    (6) (7 3) (7 5) (12 5) (3 1 1 3 5 1 3)
+    (4 1 11 3) (4 12 2) (3 1 13 2) (19 3) (12 3)
+    (16 2) (16 1) (3 12 2) (4 6 4) (4 1 8)
+    (3 8 2) (4 8 1) (10 6) (11 3) (3)))
+  ("Ijgnog (4)"
+   ((4) (5) (2 3) (2 6) (5 5)
+    (6 5) (7 5) (8 8) (2 5 10) (2 6 12)
+    (2 16 3) (1 2 14 3) (1 2 1 12 2) (1 1 2 11 2) (1 1 13 3)
+    (1 1 1 3 5 4) (1 1 1 1 1 10) (1 1 1 1 8) (2 1 2 3) (1 2 2)
+    (1 2 2) (1 1) (1 1) (3 1) (4))
+   ((11) (7 3) (5 8) (10) (7 6)
+    (11) (7 4) (9) (9) (5)
+    (8) (9) (12 1) (16) (10 1)
+    (8 5 1) (8 9) (9 4 1) (2 10 3 1) (10 4)
+    (16) (2 10) (4 5) (2) (1)))
+  ("Uhib (5)"
+   ((4) (5) (3 1) (5 1 2) (4 1 1)
+    (4 5) (4 3) (6 1) (15) (17)
+    (19) (3 19 4) (15 6 2) (7 8 6 5) (2 3 2 1)
+    (2 2 2 2) (1 8 2) (4 3 2) (8 2 1 3) (2 4 1 4)
+    (2 4 4) (1 12) (1 9) (1 7) (1))
+   ((1 1) (1 1 2 5) (5 2) (4 3 2) (7 2 1)     
+    (11 2 2) (2 11 2) (4 7 2) (2 6 3) (7 2)
+    (4 6 3) (9 3) (4 6 2) (1 1 6 3) (1 6 1 3)
+    (6 1 1 3) (6 3 3) (4 2 3) (6 4 3) (7 1 3)
+    (8 4) (8 4) (4 4) (11) (1 6)
+    (2) (5) (1 1 1) (1 1) (1 1)))
+  ("Isaniew (6)"
+   ((4 1) (7 2) (3 6) (2 3) (2 4)
+    (5) (7) (7) (3 3) (2 2 2)
+    (1 2 4) (3 2 2) (2 3 2) (3 2) (4 2)
+    (3 2) (2 2) (2 1 1) (3 2) (3 2)
+    (3 1) (3 2) (5 3 1 4) (7 2 1 7) (8 3 1 10)
+    (7 2 1 10) (2 3 2 2 4 4) (2 2 2 2 3) (4 4 5) (13))
+   ((3) (5) (3 2) (4 1) (5 1)
+    (5 2) (4 1) (3 1 1) (1 2 1) (3 2)
+    (7 5 3) (2 5 2 11 3) (4 4 2 10 1 2) (8 2 4 3 5 1) (2 4 1 4 2 2 1 1)
+    (4 4 3 2 4 2 1) (4 5 3 3 4 2) (4 7 5 2) (1 1 3 5 1) (1 1 5 1)
+    (2 4 2) (2 5) (5) (3) (3)))
+
+  )
diff --git a/collects/games/paint-by-numbers/raw-problems/size-calculation.ss b/collects/games/paint-by-numbers/raw-problems/size-calculation.ss
new file mode 100644
index 0000000000..4906b41c16
--- /dev/null
+++ b/collects/games/paint-by-numbers/raw-problems/size-calculation.ss
@@ -0,0 +1,187 @@
+(require-library "function.ss")
+(require-library "pretty.ss")
+
+(define raw-hattori (call-with-input-file 
+			(build-path (collection-path "games" "paint-by-numbers")
+				    "raw-hattori.ss")
+		      (lambda (x) (eval (read x)))))
+
+(define (num-possibilities size col)
+  (let* ([col-len (length col)]
+	 [boxes (+ col-len 1)]
+	 [balls (- size (+ (apply + col) col-len))])
+    (if (< balls 0)
+	0
+	(f boxes balls))))
+
+(define (f boxes balls)
+  (/ (! (+ boxes balls -1))
+     (* (! (- boxes 1)) (! balls))))
+
+(define (! n)
+  (cond
+   [(zero? n) 1]
+   [else (* n (! (- n 1)))]))
+
+(define (badness rows cols)
+  (let ([col-count (length rows)]
+	[row-count (length cols)])
+    (+ (apply + (map (lambda (x) (num-possibilities row-count x)) rows))
+       (apply + (map (lambda (x) (num-possibilities col-count x)) cols)))))
+
+(pretty-print
+ (quicksort
+  (let loop ([hattoris raw-hattori])
+    (cond
+     [(null? hattoris) empty]
+     [else (let* ([hattori (car hattoris)]
+		  [name (car hattori)]
+		  [rows (cadr hattori)]
+		  [cols (caddr hattori)])
+	     (let ([badness (badness rows cols)])
+	       (cons (list name badness)
+		     (loop (cdr hattoris)))))]))
+  (lambda (x y) (< (cadr x) (cadr y)))))
+
+#|
+;; result of previous expression
+(("Hattori 81" 158)
+  ("Hattori 1" 205)
+  ("Hattori 3" 647)
+  ("Hattori 82" 709)
+  ("Hattori 4" 842)
+  ("Hattori 124" 911)
+  ("Hattori 126" 931)
+  ("Hattori 116" 1242)
+  ("Hattori 2" 1243)
+  ("Hattori 9" 1260)
+  ("Hattori 13" 1437)
+  ("Hattori 6" 1490)
+  ("Hattori 22" 1516)
+  ("Hattori 7" 1671)
+  ("Hattori 19" 1761)
+  ("Hattori 11" 1774)
+  ("Hattori 5" 1804)
+  ("Hattori 98" 1844)
+  ("Hattori 137" 1857)
+  ("Hattori 99" 2089)
+  ("Hattori 8" 2182)
+  ("Hattori 44" 2452)
+  ("Hattori 100" 2575)
+  ("Hattori 38" 2635)
+  ("Hattori 10" 2835)
+  ("Hattori 92" 3010)
+  ("Hattori 32" 3036)
+  ("Hattori 131" 3080)
+  ("Hattori 16" 3207)
+  ("Hattori 56" 3732)
+  ("Hattori 121" 3748)
+  ("Hattori 48" 3867)
+  ("Hattori 118" 3898)
+  ("Hattori 61" 3989)
+  ("Hattori 17" 4121)
+  ("Hattori 28" 4177)
+  ("Hattori 35" 4414)
+  ("Hattori 58" 4449)
+  ("Hattori 18" 4562)
+  ("Hattori 46" 4620)
+  ("Hattori 133" 4634)
+  ("Hattori 84" 4666)
+  ("Hattori 96" 4668)
+  ("Hattori 12" 4709)
+  ("Hattori 102" 5006)
+  ("Hattori 86" 5031)
+  ("Hattori 30" 5133)
+  ("Hattori 87" 5133)
+  ("Hattori 14" 5495)
+  ("Hattori 130" 5502)
+  ("Hattori 42" 5650)
+  ("Hattori 45" 5763)
+  ("Hattori 54" 5947)
+  ("Hattori 43" 5991)
+  ("Hattori 41" 6140)
+  ("Hattori 23" 6169)
+  ("Hattori 136" 6295)
+  ("Hattori 26" 6510)
+  ("Hattori 62" 6614)
+  ("Hattori 53" 6675)
+  ("Hattori 31" 6866)
+  ("Hattori 63" 6876)
+  ("Hattori 57" 7182)
+  ("Hattori 29" 7318)
+  ("Hattori 50" 7325)
+  ("Hattori 135" 7595)
+  ("Hattori 104" 7941)
+  ("Hattori 20" 8126)
+  ("Hattori 103" 8126)
+  ("Hattori 34" 8324)
+  ("Hattori 60" 8330)
+  ("Hattori 55" 8375)
+  ("Hattori 67" 8549)
+  ("Hattori 27" 8637)
+  ("Hattori 127" 8648)
+  ("Hattori 15" 8674)
+  ("Hattori 33" 8729)
+  ("Hattori 95" 8732)
+  ("Hattori 39" 8855)
+  ("Hattori 24" 9051)
+  ("Hattori 132" 9371)
+  ("Hattori 51" 9450)
+  ("Hattori 37" 9582)
+  ("Hattori 125" 9648)
+  ("Hattori 83" 9698)
+  ("Hattori 70" 9937)
+  ("Hattori 25" 9942)
+  ("Hattori 120" 10033)
+  ("Hattori 68" 10110)
+  ("Hattori 85" 10517)
+  ("Hattori 65" 10556)
+  ("Hattori 74" 10901)
+  ("Hattori 90" 10913)
+  ("Hattori 21" 11220)
+  ("Hattori 59" 11255)
+  ("Hattori 64" 11317)
+  ("Hattori 89" 11323)
+  ("Hattori 112" 11355)
+  ("Hattori 77" 11627)
+  ("Hattori 73" 11705)
+  ("Hattori 139" 11806)
+  ("Hattori 75" 11989)
+  ("Hattori 49" 12203)
+  ("Hattori 101" 12500)
+  ("Hattori 71" 12522)
+  ("Hattori 47" 12626)
+  ("Hattori 52" 12646)
+  ("Hattori 66" 12762)
+  ("Hattori 72" 12942)
+  ("Hattori 88" 13166)
+  ("Hattori 79" 13223)
+  ("Hattori 107" 13368)
+  ("Hattori 40" 13558)
+  ("Hattori 94" 13567)
+  ("Hattori 106" 15177)
+  ("Hattori 80" 15306)
+  ("Hattori 113" 15776)
+  ("Hattori 93" 16352)
+  ("Hattori 91" 17856)
+  ("Hattori 69" 18918)
+  ("Hattori 105" 19069)
+  ("Hattori 78" 19968)
+  ("Hattori 97" 20828)
+  ("Hattori 117" 21432)
+  ("Hattori 134" 22118)
+  ("Hattori 76" 24896)
+  ("Hattori 36" 25351)
+  ("Hattori 129" 27863)
+  ("Hattori 138" 36306)
+  ("Hattori 114" 46788)
+  ("Hattori 128" 60393)
+  ("Hattori 119" 64012)
+  ("Hattori 111" 106611)
+  ("Hattori 123" 110847)
+  ("Hattori 108" 288996)
+  ("Hattori 115" 330042)
+  ("Hattori 109" 469815)
+  ("Hattori 110" 516937)
+  ("Hattori 122" 5784954))
+|#
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/solution-sets/directory b/collects/games/paint-by-numbers/solution-sets/directory
new file mode 100644
index 0000000000..2d8ca7b0f4
--- /dev/null
+++ b/collects/games/paint-by-numbers/solution-sets/directory
@@ -0,0 +1,31 @@
+("games"
+ "misc"
+ "h1-30"
+ "h31-60"
+ "h61-90"
+ "h91-120"
+ "h121-138"
+ "k15x15"
+ "k15x20"
+ "k15x25"
+ "k20x15"
+ "k20x20"
+ "k20x25"
+ "k20x30"
+ "k25x15"
+ "k25x20"
+ "k25x25"
+ "k25x30"
+ "k25x35"
+ "k30x20"
+ "k30x25"
+ "k30x30"
+ "k30x35"
+ "k30x40"
+ "k35x25"
+ "k35x30"
+ "k35x35"
+ "k35x40"
+ "k40x30"
+ "k40x35"
+ "k40x40")
diff --git a/collects/games/paint-by-numbers/solution-sets/games b/collects/games/paint-by-numbers/solution-sets/games
new file mode 100644
index 0000000000..5f0a15f734
--- /dev/null
+++ b/collects/games/paint-by-numbers/solution-sets/games
@@ -0,0 +1,195 @@
+(unit/sig paint-by-numbers:problem-set^ (import
+paint-by-numbers:problem^) (define set-name "Games Magazine") (define
+problems (list (make-problem "Izay (1)" '((2) (1 1) (4) (2 1) (3 1)
+(8) (8) (7) (5) (3)) '((1) (2) (1 6) (9) (6) (5) (5) (4) (3) (4))
+'#10(#10(off off on off) #10(off on on off) #10(on off on on on on on
+on off) #10(on on on on on on on on on off) #10(off off off off on)
+#10(off off off off off on) #10(off off off off off on) #10(off off
+off off off on on on on off) #10(off off off off off on on on off)
+#10(off off off on on on on off))) (make-problem "Oam (2)" '((1) (2 3
+1) (9) (8) (8) (3 2 1) (6 6) (9 4) (11 2) (13) (2 10) (7 11) (8 5 5)
+(8 4 3) (8 4 2) (2 5 5) (1 4 2 3 2) (2 1 4 2) (9 3) (7)) '((5) (9) (7
+2) (3 6 2) (3 6 2) (4 6 2) (4 6 2) (5 4 2) (6 1 2) (11 2) (14 2) (6
+10) (6 10) (3 2 4 4) (8 2 2) (8 3 2) (4 2 3) (5 3 2) (2 4 2) (3))
+'#20(#20(off off off off off off off off off off off on on on on on
+off) #20(off off off off off off off off off on on on on on on on on
+on off) #20(off off off off off off off off on on on on on on on off
+off on on off) #20(off off off off off off off on on on off on on on
+on on on off on) #20(off off off off off off off on on on off on on on
+on on on off on) #20(off off off off off off on on on on off on on on
+on on on off on) #20(off off off off off off on on on on off on on on
+on on on off on) #20(off off off off off off on on on on on off on on
+on on off off on) #20(off off off off off off on on on on on on off
+off off off on off on) #20(off off off off off off on on on on on on
+on on on on on off on) #20(off off on on on on on on on on on on on on
+on on off on on off) #20(on on on on on on off on on on on on on on on
+on on off) #20(off on on on on on on off on on on on on on on on on on
+off) #20(off off on on on off on on off on on on on off off on on on
+on off) #20(off on on on on on on on on off on on off off off off off
+on on off) #20(off on on on on on on on on off on on on off off off
+off on on off) #20(off on on on on off on on off off on on on off)
+#20(off off on on on on on off off off off on on on off off on on off)
+#20(off on on off off off off off off off off on on on on off on on
+off) #20(off off off off off off off off off off off off on on on
+off))) (make-problem "Izuoh (3)" '((2) (3) (3) (2) (2) (2) (4 2) (6 2)
+(6 3) (1 2 1 6) (2 2 9) (1 1 7) (1 1 5) (3 1 2) (2 6) (11) (13) (13)
+(4 10 2) (4 10 4) (4 10 4) (4 10 4) (4 9 4) (4 9 4) (3 8 3) (3 11 3)
+(3 3 2 3) (5 5 4 2) (3 1 10 4) (3 1 8 5)) '((3) (5) (7) (7) (6 3) (6)
+(7 3) (7 5) (12 5) (3 1 1 3 5 1 3) (4 1 11 3) (4 12 2) (3 1 13 2) (19
+3) (12 3) (16 2) (16 1) (3 12 2) (4 6 4) (4 1 8) (3 8 2) (4 8 1) (10
+6) (11 3) (3)) '#25(#30(off off off off off off off off off off off
+off off off off off off off off off off off off off off off off on)
+#30(off off off off off off off off off off off off off off off off
+off off off off off off off off off on) #30(off off off off off off
+off off off off off off off off off off off off off off off off off
+on) #30(off off off off off off off off off off off off off off off
+off off off off off off on on on on on on on off) #30(off off off off
+off off off off off off off off off off off off off off off on on on
+on on on off off on) #30(off off off off off off off off off off off
+off off off off off off off on on on on on on off) #30(off off off off
+off off off off off off off off off off off off on on on on on on on
+off off off on on on off) #30(off off off off off off off off off off
+off off off off on on on on on on on off off off off on) #30(off off
+off off off off off on on on on on on on on on on on on off off off
+off off off on) #30(off off off off off off on on on off on off off on
+off on on on off on on on on on off on off on) #30(off off off off off
+off on on on on off off off on off on on on on on on on on on on on
+off on) #30(off off off off off off on on on on off off off off off on
+on on on on on on on on on on on off on) #30(off off off off off off
+on on on off on off off off on on on on on on on on on on on on on off
+on) #30(off off off off off off off on on on on on on on on on on on
+on on on on on on on on off on) #30(off off off off off off off off
+off off off off off off on on on on on on on on on on on on off on)
+#30(off off off off off off off off off off on on on on on on on on on
+on on on on on on on off on on off) #30(off off off off off off off
+off off off on on on on on on on on on on on on on on on on off on
+off) #30(off off off off off off off off off off on on on off on on on
+on on on on on on on on on off off on) #30(off off off off off off off
+off off on on on on off off off on on on on on on off off off off on)
+#30(off off off off off off off off off on on on on off off off off
+off on off off off on) #30(off off off off off off off off off on on
+on off off off off off off off on on on on on on on on off on) #30(off
+off off off off off off off on on on on off off off off off off on on
+on on on on on on off off off on) #30(off on on on on on on on on on
+on off off off off off off off on on on on on on off) #30(on on on on
+on on on on on on on off off off off off off off off on on on off)
+#30(on on on off))) (make-problem "Ijgnog (4)" '((4) (5) (2 3) (2 6)
+(5 5) (6 5) (7 5) (8 8) (2 5 10) (2 6 12) (2 16 3) (1 2 14 3) (1 2 1
+12 2) (1 1 2 11 2) (1 1 13 3) (1 1 1 3 5 4) (1 1 1 1 1 10) (1 1 1 1 8)
+(2 1 2 3) (1 2 2) (1 2 2) (1 1) (1 1) (3 1) (4)) '((11) (7 3) (5 8)
+(10) (7 6) (11) (7 4) (9) (9) (5) (8) (9) (12 1) (16) (10 1) (8 5 1)
+(8 9) (9 4 1) (2 10 3 1) (10 4) (16) (2 10) (4 5) (2) (1))
+'#25(#25(off off off off off off on on on on on on on on on on on off)
+#25(off off off off on on on on on on on off off off off off off off
+on on on off) #25(off off off on on on on on off off off on on on on
+on on on on off) #25(off off off on on on on on on on on on on off)
+#25(off off off off on on on on on on on off off on on on on on on
+off) #25(off off off off on on on on on on on on on on on off) #25(off
+off off off off on on on on on on on off off on on on on off) #25(off
+off off off off off off on on on on on on on on on off) #25(off off
+off off off off off off off on on on on on on on on on off) #25(off
+off off off off off off off off off on on on on on off) #25(off off
+off off off off off off off off on on on on on on on on off) #25(off
+off off off off off off off off on on on on on on on on on off)
+#25(off off off off off off off off off on on on on on on on on on on
+on on off off on off) #25(off off off off off off off off on on on on
+on on on on on on on on on on on on off) #25(off off off off off off
+off off on on on on on on on on on on off off off off off on off)
+#25(off off off off off off off on on on on on on on on off on on on
+on on off off off on) #25(off off off off off off off on on on on on
+on on on off on) #25(off off off off off on on on on on on on on on
+off on on on on off off off off off on) #25(on on off on on on on on
+on on on on on off on on on off off off off off off off on) #25(on on
+on on on on on on on on off off off on on on on off) #25(on on on on
+on on on on on on on on on on on on off) #25(on on off on on on on on
+on on on on on off) #25(off on on on on off off on on on on on off)
+#25(off off on on off) #25(off off on off))) (make-problem "Uhib (5)"
+'((4) (5) (3 1) (5 1 2) (4 1 1) (4 5) (4 3) (6 1) (15) (17) (19) (3 19
+4) (15 6 2) (7 8 6 5) (2 3 2 1) (2 2 2 2) (1 8 2) (4 3 2) (8 2 1 3) (2
+4 1 4) (2 4 4) (1 12) (1 9) (1 7) (1)) '((1 1) (1 1 2 5) (5 2) (4 3 2)
+(7 2 1) (11 2 2) (2 11 2) (4 7 2) (2 6 3) (7 2) (4 6 3) (9 3) (4 6 2)
+(1 1 6 3) (1 6 1 3) (6 1 1 3) (6 3 3) (4 2 3) (6 4 3) (7 1 3) (8 4) (8
+4) (4 4) (11) (1 6) (2) (5) (1 1 1) (1 1) (1 1)) '#30(#25(off off off
+off off off off off off off off on off on off) #25(off off off off off
+off off off off off off on off on off on on off off off on) #25(off
+off off off off off off off off off off on on on on on off off off on
+on off) #25(off off on on on on off off off off off off on on on off
+off off on on off) #25(off on on on on on on on off off off off on on
+off off off off on off) #25(on on on on on on on on on on on off on on
+off off off on on off) #25(on on off on on on on on on on on on on on
+off off off on on off) #25(on on on on off off on on on on on on on
+off off off off on on off) #25(on on off off off off off on on on on
+on on off off off off on on on off) #25(off off off off off off off on
+on on on on on on off off off off on on off) #25(off off off on on on
+on off on on on on on on off off off off on on on off) #25(off off off
+off off on on on on on on on on on off off off off off on on on off)
+#25(off off off on on on on off on on on on on on off off off off off
+off on on off) #25(off off off on off on off off on on on on on on off
+off off off off off on on on off) #25(off off off off off on off off
+on on on on on on off off on off off off off on on on off) #25(off off
+off off off off off off on on on on on on off off on off on off off on
+on on off) #25(off off off off off off off off on on on on on on off
+off on on on off off on on on off) #25(off off off off off off off off
+on on on on off off off off on on off off off on on on off) #25(off
+off off off off off off off on on on on on on off off on on on on off
+on on on off) #25(off off off off off off off off on on on on on on on
+off on off off off off on on on off) #25(off off off off off off off
+off off on on on on on on on on off off off on on on on off) #25(off
+off off off off off off off off on on on on on on on on off off on on
+on on off) #25(off off off off off off off off off off on on on on off
+off off off on on on on off) #25(off off off off off off off off off
+off on on on on on on on on on on on off) #25(off off off off off off
+off off off off off on off off on on on on on on off) #25(off off off
+off off off off off off off off off on on off) #25(off off off off off
+off off off off off off on on on on on off) #25(off off off off off
+off off off off off off on off on off on off) #25(off off off off off
+off off off off off off on off on off) #25(off off off off off off off
+off off off off on off on off))) (make-problem "Isaniew (6)" '((4 1)
+(7 2) (3 6) (2 3) (2 4) (5) (7) (7) (3 3) (2 2 2) (1 2 4) (3 2 2) (2 3
+2) (3 2) (4 2) (3 2) (2 2) (2 1 1) (3 2) (3 2) (3 1) (3 2) (5 3 1 4)
+(7 2 1 7) (8 3 1 10) (7 2 1 10) (2 3 2 2 4 4) (2 2 2 2 3) (4 4 5)
+(13)) '((3) (5) (3 2) (4 1) (5 1) (5 2) (4 1) (3 1 1) (1 2 1) (3 2) (7
+5 3) (2 5 2 11 3) (4 4 2 10 1 2) (8 2 4 3 5 1) (2 4 1 4 2 2 1 1) (4 4
+3 2 4 2 1) (4 5 3 3 4 2) (4 7 5 2) (1 1 3 5 1) (1 1 5 1) (2 4 2) (2 5)
+(5) (3) (3)) '#25(#30(off off off off off off off off off off off off
+off off off off off off off off off off off off on on on off) #30(off
+off off off off off off off off off off off off off off off off off
+off off off off off on on on on on off) #30(off off off off off off
+off off off off off off off off off off off off off off off off off on
+on on off on on off) #30(off off off off off off off off off off off
+off off off off off off off off off off off off on on on on off on
+off) #30(off off off off off off off off off off off off off off off
+off off off off off off off on on on on on off on off) #30(off off off
+off off off off off off off off off off off off off off off off off
+off off on on on on on off on) #30(off off off off off off off off off
+off off off off off off off off off off off off off on on on on off
+off off on) #30(off off off off off off off off off off off off off
+off off off off off off off off off on on on off off on off on)
+#30(off off off off off off off off off off off off off off off off
+off off off off off off on off off off on on off on) #30(off off off
+off off off off off off off off off off off off off off off off off
+off off off off on on on off on) #30(off off off off off off on on on
+on on on on off off off off off off off off on on on on on off on)
+#30(off on on off off on on on on on off on on off on on on on on on
+on on on on on off off on) #30(on on on on off on on on on off on on
+off on on on on on on on on on on off off off on off on) #30(on on on
+on on on on on off on on off on on on on off off on on on off off on
+on on on on off on) #30(on on off off on on on on off on off on on on
+on off on on off off off on on off off off off on off on) #30(on on on
+on off on on on on off on on on off off on on off on on on on off off
+on on off off off on) #30(off on on on on off on on on on on off off
+on on on off on on on off off off on on on on off on) #30(off on on on
+on off off off on on on on on on on off off off off off off off on on
+on on on off on) #30(off off on off on off off off off off on on on
+off off off off off off off off off on on on on on off on off) #30(off
+off on off on off off off off off off off off off off off off off off
+off off off on on on on on off on off) #30(off on on off off off off
+off off off off off off off off off off off off off off off on on on
+on off on on off) #30(on on off off off off off off off off off off
+off off off off off off off off off off off on on on on on off)
+#30(off off off off off off off off off off off off off off off off
+off off off off off off off on on on on on off) #30(off off off off
+off off off off off off off off off off off off off off off off off
+off off off on on on off) #30(off off off off off off off off off off
+off off off off off off off off off off off off off off on on on
+off))))))
diff --git a/collects/games/paint-by-numbers/solution-sets/h1-30 b/collects/games/paint-by-numbers/solution-sets/h1-30
new file mode 100644
index 0000000000..a671649f7f
--- /dev/null
+++ b/collects/games/paint-by-numbers/solution-sets/h1-30
@@ -0,0 +1,607 @@
+(unit/sig paint-by-numbers:problem-set^ (import
+paint-by-numbers:problem^) (define set-name "Hattori 1 - 30") (define
+problems (list (make-problem "Hattori 1" '((5) (1) (3 1) (8) (2 1) (1
+6) (1 1 1) (3) (1) (10)) '((1) (4 1) (2 3) (1 2 1) (1 1 1 1) (1 2 1 1)
+(4 1 1) (1 2 1 1) (1 1 1 1) (5 1)) '#10(#10(off off off off off off
+off off off on) #10(off off off off on on on on off on) #10(off off
+off on on off off on) #10(off off off on off off on on off on) #10(on
+off off on off on off off off on) #10(on off on on off on off off off
+on) #10(on on on on off on off off off on) #10(on off on on off on off
+off off on) #10(on off off on off on off off off on) #10(off off on on
+on on on off off on))) (make-problem "Hattori 2" '((5 1 5) (5 2 6)
+(15) (4 5) (3 5 2) (3 6 1 2) (3 4 1 2) (3 3) (3 4) (1 1 1 1) (8) ()
+(2) (1 9 1) (2 2 2)) '((10 2) (9 1) (9) (4 2 1) (3 2 1 3) (1 3 1 3) (2
+3 1 1) (3 3 1 1) (1 3 1 1) (2 1 1 1) (4 2 1) (4 2 1 1) (4 2) (9 1) (10
+2)) '#15(#15(on on on on on on on on on on off off off on) #15(on on
+on on on on on on on off off off off off on) #15(on on on on on on on
+on on off) #15(on on on on off off off off off on on off off on off)
+#15(on on on off on on off off off off on off on) #15(off off on off
+on on on off off off on off on) #15(off on on off on on on off off off
+on off off on off) #15(on on on off on on on off off off on off off on
+off) #15(off off on off on on on off off off on off off on off)
+#15(off on on off off on off off off off on off off on off) #15(on on
+on on off off off off off on on off off on off) #15(on on on on off on
+on off on off off off off on off) #15(on on on on off off off on on
+off) #15(on on on on on on on on on off off off off off on) #15(on on
+on on on on on on on on off off off on))) (make-problem "Hattori 3"
+'((11) (1 11) (2 3 4 2) (4 2 2) (3 4) (2 3 3 3) (2 1 1 3) (2 1 1 3) (2
+3 4) (2 1 4) (3 3 4) (2 2 2 4) (4 6) (11) (9)) '((9) (12) (1 2 4) (4 1
+3) (3 1 4) (3 4 2 2) (2 3 2) (2 4 2 2) (3 1 4) (3 1 3) (4 4) (5 7) (2
+10) (12) (9)) '#15(#15(off off on on on on on on on on on off) #15(off
+on on on on on on on on on on on on off) #15(on off off on on off off
+off off off on on on on off) #15(on on on on off on off off off off
+off off on) #15(on on on off off on off off off off off on) #15(on on
+on off off on on on on off on on off on) #15(on on off off off off off
+off on on on off off on) #15(on on off off off on on on on off on on
+off on) #15(on on on off off on off off off off off on) #15(on on on
+off off on off off off off off off on) #15(on on on on off off off off
+off off off on) #15(on on on on on off off off on) #15(on on off off
+on on on on on on on on on on off) #15(off on on on on on on on on on
+on on on off) #15(off off on on on on on on on on on off)))
+(make-problem "Hattori 4" '((6) (3 2) (2 1) (2 2) (2 1) (1 1) (2 1) (5
+1) (2 4 5) (1 4 2 4) (1 5 1 4) (7 1 5) (7 7) (5 7) (5)) '((5) (2 3) (1
+4) (8) (10) (2 7) (2 5) (2) (1 5) (2 2 3) (1 1 4) (1 12) (4 7) (2 7)
+(1 5)) '#15(#15(off off off off off off off off on on on on on off)
+#15(off off off off off off off on on off off on on on off) #15(off
+off off off off off off on off off on on on on off) #15(off off off
+off off off on on on on on on on on off) #15(off off off off on on on
+on on on on on on on off) #15(off off off on on off off on on on on on
+on on off) #15(off off on on off off off off on on on on on off)
+#15(off on on off) #15(off on off off off off off off off on on on on
+on off) #15(on on off off off off off off on on off off on) #15(on off
+off off off off off off on off off on) #15(on off off on) #15(on on on
+on off off off off on) #15(on on off off off off off off on) #15(on
+off off off off off off off off on on on on on off))) (make-problem
+"Hattori 5" '((2 1) (11) (3 3) (2 4) (3 3) (2 2 2 3) (2 2 2 2) (2 1 1
+2) (2 2 2 2) (3 2) (1 1 2) (1 4) (1 3 1 1) (1 1 1 2) (6)) '((7) (8) (4
+5) (3 1) (2 4 3) (1 2 1 1 1) (1 3) (1 1) (1 2 1 1) (1 4 1) (1 2) (4 1)
+(5 1) (10) (10)) '#15(#15(off off off off on on on on on on on off)
+#15(off off on on on on on on on on off) #15(off on on on on off off
+off off on on on on on off) #15(on on on off off off off off off off
+off off off off on) #15(on on off off off on on on on off off off on)
+#15(off on off off off on on off on off off off on off on) #15(off on
+off off off off off off off off off off on) #15(off on off off off off
+off off off off off off off off on) #15(off on off off off on on off
+on off off off off off on) #15(off on off off off on on on on off off
+off off on off) #15(off on off off off off off off off off off off on
+on off) #15(on on on on off off off off off off off on off) #15(off on
+on on on on off off off off off on off) #15(off off on on on on on on
+on on on on off) #15(off off off on on on on on on on on on on off)))
+(make-problem "Hattori 6" '((4) (6 1) (2 1 1 2) (5 1 3) (5 1 2 1) (6 1
+2 1) (6 3 1) (6 2 2) (4 1 1 2) (2 1 1) (2 2) (7) (1 1) (2 2) (6)) '((1
+1) (1 6) (1 7) (9) (8) (2 4) (1 1 6 1) (1 2 2) (8 4) (3 1 1) (2 1 2)
+(2 4) (2 1 1) (2 2 2) (6 2)) '#15(#15(off on off on off) #15(off on
+off on on on on on on off) #15(off on off on on on on on on on off)
+#15(off on on on on on on on on on off) #15(off on on on on on on on
+on off) #15(on on off off on on on on off) #15(on off on off off on on
+on on on on off off off on) #15(on off off off off off off off off off
+on on off on) #15(on on on on on on on on off off off on) #15(off off
+off off off off on on on off off on off off on) #15(off off off off
+off on on off off off off on off on) #15(off off off off on on off off
+off off off on) #15(off off off on on off off off on off off on off)
+#15(off off on on off off off on on off on on off) #15(off off on on
+on on on on off on on off))) (make-problem "Hattori 7" '((3) (5) (3 1)
+(3 3 1) (6 2 1) (7 3) (2 2 1) (1 1 1 1 1) (2 1 1 1 1) (1 1 2 1) (1 1
+1) (13) (4 8) (9) (4 3)) '((3 3) (3 2 4) (2 5) (3 2 4) (3 1 1 1) (3 2
+4) (3 6) (5 4) (3) (2) (4 2) (6 2) (4 8) (2 1 1) (4)) '#15(#15(off off
+off off off off on on on off off off on) #15(off off off off on on on
+off on on off on) #15(off off off off on on off off off off on)
+#15(off off off on on on off on on off off on) #15(off off off on on
+on off off off on off on off on off) #15(off off off on on on off on
+on off off on) #15(off off off off on on on off off on) #15(off off
+off off off on on on on on off on) #15(off off off off off off off off
+off off off on on on off) #15(off off off off off off off off off off
+off on on off) #15(off on on on on off off off off off off on on off)
+#15(on on on on on on off off off off off on on off) #15(on on on on
+off on on on on on on on on off) #15(on on off off off on off off off
+off off on off) #15(off on on on on off))) (make-problem "Hattori 8"
+'((7) (6 2) (1 3 3) (2 2 2) (2 1) (3 2 1) (3 3 2 1) (1 4 2 1) (1 2 2)
+(2 2 6) (1 2 1) (1 1 3) (1 4 1) (2 5) (9)) '((4) (3 1 5) (1 2 2 2) (1
+2 1 1) (2 1 1 1) (2 3 1 1) (3 1 2 1) (1 1 2 3 1) (1 2 2 1 1) (1 1 2 1
+1) (2 1 3) (2 2 1 1) (1 2 3 1) (2 2 1 1) (7 3)) '#15(#15(off off off
+off off off on on on on off) #15(off on on on off off on off off on on
+on on on off) #15(off on off on on off on on off off off off off on)
+#15(off on off off on on off on off off off off off off on) #15(on on
+off off off on off on off off off off off off on) #15(on on off off
+off on on on off on off off off off on) #15(on on on off off off on
+off off on on off off off on) #15(on off on off off off on on off off
+on on on off on) #15(on off on on off off off on on off off off on off
+on) #15(on off off on off off off off on on off off on off on) #15(on
+on off off off off off off off on off off on) #15(off on on off off on
+on off off on off off off on off) #15(off off on off off on on off off
+on on on off on off) #15(off off on on off off off off on on off on
+off on off) #15(off off off on on on on on on on off on on on off)))
+(make-problem "Hattori 9" '((3) (2 2) (1 2) (1 11) (1 2 4) (2 2 2 1)
+(3 3 1 1) (2 2) (1 1) (1 1) (7) (3 3) (2 2) (3 3) (3 3)) '((5) (2 2)
+(1 1) (2 2 5) (5 8) (3 2 2 2) (1 1 1) (1 2 2 2) (1 8) (1 5) (4) (3)
+(2) (4) (1)) '#15(#15(off on on on on on off) #15(on on off off off on
+on off) #15(on off off off off off on off) #15(on on off off off on on
+off off off on) #15(off on on on on on off on) #15(off off on on on
+off on on off off on on off on) #15(off off off on off off on off off
+off on off) #15(off off off on off off on on off off on on off on)
+#15(off off off on off off off on) #15(off off off on off off off off
+off off on) #15(off off off on on on on off) #15(off off off on on on
+off) #15(off off off on on off) #15(off off off on on on on off)
+#15(off off off on off))) (make-problem "Hattori 10" '((7 1) (2 2 1)
+(1 1 3) (1 1 1 3) (5 2) (13) (15) (3 5) (2 7 1) (3 10) (3 7) (6 2) (2
+4) (2 3 2) (1 3 1) (1 3 1) (1 3 1) (2 2) (2 2) (6)) '((5) (5) (3 2) (2
+5) (1 2 2 2) (10 2 2) (2 6 1 2 1) (1 7 1 4 1) (2 13 1) (14 1 1) (1 2 5
+2) (2 3 2 2) (2 2 2 5) (7 3) (5 4)) '#15(#20(off off off off off off
+on on on on on off) #20(off off off off off off on on on on on off)
+#20(off off off off off on on on off on on off) #20(off off off off
+off on on off off off off off off on on on on on off) #20(on off off
+off off on on off off off off off on on off off off on on off) #20(on
+on on on on on on on on on off on on off off off off off on) #20(on on
+off off on on on on on on off on off off on on off off off on) #20(on
+off off on on on on on on on off on off on on on on off off on) #20(on
+on off off on on on on on on on on on on on on on off off on) #20(on
+on on on on on on on on on on on on on off off on off off on) #20(on
+off off off off on on off on on on on on off off off off off on)
+#20(off off off off off on on off on on on off on on off off off on on
+off) #20(off off on on off on on off off on on off off on on on on on
+off) #20(on on on on on on on off off on on on off) #20(off off on on
+on on on off on on on on off))) (make-problem "Hattori 11" '((4) (6)
+(6) (3 6) (3 2 6) (3 6 4) (4 7) (11) (2 13) (1 13) (14) (9 4) (9 2)
+(8) (7) (6) (5 1) (3 4 3) (5 3 4) (16)) '((5) (4) (3 1) (3 2) (5 3) (8
+2) (10 2) (12 2) (13 1) (1 12 1) (14 1) (1 1 12) (12) (3 8) (4 3 1) (6
+4 1) (6 3 2) (6 3 3) (6 2 3) (4 4)) '#20(#20(off off off off off on on
+on on on off) #20(off off off off off on on on on off) #20(off off off
+off off on on on off off off off off off off off off on off) #20(off
+off off off off off on on on off off off off off off off off on on
+off) #20(off off off off off off off on on on on on off off off off
+off on) #20(off off off off off on on on on on on on on off off off
+off off on) #20(off off off off on on on on on on on on on on off off
+off off on) #20(off off off on on on on on on on on on on on on off
+off off on) #20(off off off on on on on on on on on on on on on on off
+off off on) #20(off off off on off on on on on on on on on on on on on
+off off on) #20(off off off off on on on on on on on on on on on on on
+on off on) #20(off off off off on off on off on) #20(off off off off
+off off off off on) #20(off off off off off off off off on on on off
+on) #20(off on on on on off off off on on on off off off off off off
+off off on) #20(on on on on on on off off on on on on off off off off
+off off off on) #20(on on on on on on off off off on on on off off off
+off off off on) #20(on on on on on on off off off off on on on off off
+off off on) #20(on on on on on on off off off off off on on off off
+off off on) #20(off on on on on off off off off off off off off off
+off off on))) (make-problem "Hattori 12" '((5 7) (5 3 3) (4 2 7 2) (4
+1 1) (3 1 1) (2 1 3 1) (1 1 1 1) (1 1 9 1) (13) (2 11) (2 13) (3 11 2)
+(16 1) (15 1) (15 1) (13 1) (12 2) (10 3) (12) (18)) '((8 1) (6 2) (5
+3 1) (4 4 1) (2 6 1) (6 1) (7 8 1) (2 12) (1 13) (3 13) (1 1 13) (1 1
+1 13) (1 1 15) (1 1 1 13) (1 1 13) (3 10 2) (1 9 2) (2 3 3 3) (7 2 4)
+(7 1)) '#20(#20(on on on on on on on on off on off) #20(on on on on on
+on off off off on on off) #20(on on on on on off off off off off on on
+on off off off off off off on) #20(on on on on off off off off off off
+off on on on on off off off off on) #20(on on off off off off off off
+off off off on on on on on on off off on) #20(off off off off off off
+off off off off off off on on on on on on off on) #20(off off on on on
+on on on on off on on on on on on on on off on) #20(off on on off off
+off off off on) #20(off on off off off off off on) #20(on on on off
+off off off on) #20(on off on off off off off on) #20(on off on off
+off on off on) #20(on off on off off on) #20(on off on off off on off
+on) #20(on off on off off off off on) #20(on on on off off off off on
+on on on on on on on on on off on) #20(off on off off off off off on
+on on on on on on on on off off on) #20(off on on off off off off off
+on on on off on on on off off on) #20(off off on on on on on on on off
+on on off off off off on) #20(off off off off off off off off off off
+off on on on on on on on off on))) (make-problem "Hattori 13" '((2 2)
+(2 3) (3) (2 12) (2 15) (17) (18) (3 12) (4 1 13) (4 13) (8 7) (10 7)
+(11 7) (18) (18) (17) (14) (3) (3) (2)) '((2 2 2) (2 7) (2 9) (2 11)
+(2 6) (3 1 7) (3 7) (14) (14) (7 6) (10 8) (10 7) (10 6) (14) (14)
+(14) (14) (14) (14) (3 2 2 2)) '#20(#20(off off off on on off off off
+on on off on on off) #20(off off off on on off off on on on on on on
+on off) #20(on on off off off off on on on on on on on on on off)
+#20(on on off off off on on on on on on on on on on on off) #20(off
+off off off off on on off off off on on on on on on off) #20(off off
+off off on on on off on off on on on on on on on off) #20(off off off
+off on on on off off off on on on on on on on off) #20(off off off on
+on on on on on on on on on on on on on off) #20(off off off on on on
+on on on on on on on on on on on off) #20(off off off on on on on on
+on on off on on on on on on off) #20(on on on on on on on on on on off
+off on) #20(on on on on on on on on on on off off off on) #20(off on
+on on on on on on on on on off off on on on on on on off) #20(off off
+off on on on on on on on on on on on on on on off) #20(off off off on
+on on on on on on on on on on on on on off) #20(off off off on on on
+on on on on on on on on on on on off) #20(off off off on on on on on
+on on on on on on on on on off) #20(off off off on on on on on on on
+on on on on on on on off) #20(off off off on on on on on on on on on
+on on on on on off) #20(off off off off on on on off on on off on on
+off on on off))) (make-problem "Hattori 14" '((8) (9) (1 5) (1 1 3) (1
+2) (2 2) (1 2 2) (3 3) (1 10) (12) (1 4 2 1) (1 5 6) (1 5 2 1) (1 6)
+(1 7) (1 3 3) (1 1 3 4) (1 6 3) (2 1 3 4) (19)) '((3) (2) (1) (3 1 1)
+(2 11) (3 1 1) (5 2 7) (2 2 2 8) (2 1 14) (3 8 1) (3 11 2) (7 12) (6 2
+1 6) (4 3 1 4) (2 5 1) (1 1) (1 1) (1 1) (3 1) (1 1)) '#20(#20(off off
+off off off off off off off off off off off off off off on on on off)
+#20(off off off off off off off off off off off off off off off off
+off off on) #20(off off off off off off off off off off off off off
+off off off off off off on) #20(off off off off off off off on on on
+off off off off off off off on off on) #20(off off off off off off on
+on off on) #20(off off off off off off off on on on off off off off
+off off off on off on) #20(off on on on on on off off on on off off
+off on) #20(on on off off off on on off on on off off on) #20(on on
+off on off off on) #20(on on on off off off off on on on on on on on
+on off off off off on) #20(on on on off off off on on on on on on on
+on on on on off on) #20(on on on on on on on off on) #20(on on on on
+on on off off on on off on off off on) #20(on on on on off off off off
+on on on off on off off off on) #20(on on off off off off off off on
+on on on on off off off off off off on) #20(off off off off off off
+off off off off off on off off off off off off off on) #20(off off off
+off off off off off off off off on off off off off off off off on)
+#20(off off off off off off off off off off off on off off off off off
+off off on) #20(off off off off off off off off off off on on on off
+off off off off off on) #20(off off off off off off off off off off
+off on off off off off off off off on))) (make-problem "Hattori 15"
+'((1) (1 17) (3 1 1) (1 1 1 3 3 3 1) (1 1 1 3 1 1 1 1 1) (3 1 3 3 3 1)
+(1 3 1) (1 16) (1) (1) (1 9) (1 2 1 2) (1 2 1 1 1) (1 2 1 3 2) (2 16)
+(3 16) (1 4 7 3 1) (1 1 4 8) (1 2 1 8) (1 2 1)) '((20) (1 1 2) (6 2)
+(1 2 1) (7 3) (1 1 5) (1 3 1 4 1) (1 3 1 2 5) (1 3 1 2 4) (1 1 1 4) (1
+3 1 1 5) (1 1 1 1 7 1) (1 3 1 1 6) (1 1 1 6) (1 3 1 1 4 2) (1 1 1 1 1
+6) (1 3 1 2 5) (1 1 8) (7 3 3) (5)) '#20(#20(on) #20(off off on off
+off on off off off off off off off off on on off) #20(off on on on on
+on on off off off off off off off off on on off) #20(off on off off
+off off on on off off off off off off off off on off) #20(off on on on
+on on on on off off off off off off on on on off) #20(off on off off
+off off off on off off off off off on on on on on off) #20(off on off
+on on on off on off off off off on on on on off off on off) #20(off on
+off on on on off on off off off on on off on on on on on off) #20(off
+on off on on on off on off off on on off off on on on on off) #20(off
+on off off off off off on off off on off off off on on on on off)
+#20(off on off on on on off on off off on off off off on on on on on
+off) #20(off on off on off on off on off off on on on on on on on off
+off on) #20(off on off on on on off on off off on off off off on)
+#20(off on off off off off off on off off on off off on on on on on on
+off) #20(off on off on on on off on off off on off on on on on off on
+on off) #20(off on off on off on off on off off on off off on on on on
+on on off) #20(off on off on on on off on off off on on off off on on
+on on on off) #20(off on off off off off off on off off off on on on
+on on on on on off) #20(off on on on on on on on off off off off off
+on on on off on) #20(off off off off off off off off off off off off
+off off on on on on on off))) (make-problem "Hattori 16" '((6) (10) (3
+5 3) (8 7) (6 7 3) (2 8 7) (5 10 3) (1 5 4 1) (5 5) (3 3) (3 4 2) (3 5
+3) (3 5 2) (13) (5) (6) (7) (7) (7) (5)) '((5) (3 4) (10) (2 3 2) (7
+2) (5 1 1) (7 1) (2 1 2 1) (7 4) (7 7) (3 3 9) (7 9) (5 1 9) (1 4 7)
+(7 1 5) (2 4 1 4) (4 2 2 3) (7 2) (3 4) (7)) '#20(#20(off off off off
+off off on on on on on off) #20(off off off off on on on off on on on
+on off) #20(off off off on on on on on on on on on on off) #20(off off
+off on on off on on on off off on on off) #20(off off on on on on on
+on on off off off on on off) #20(off on on on on on off on off off off
+off off on off) #20(off on on on on on on on off off off off off on
+off) #20(on on off on off on on off off off off off off on off) #20(on
+on on on on on on off off off on on on on off) #20(on on on on on on
+on off off off on on on on on on on off) #20(on on on off on on on off
+off off on on on on on on on on on off) #20(on on on on on on on off
+off off on on on on on on on on on off) #20(on on on on on off on off
+off off off on) #20(off on off on on on on off off off off off off on)
+#20(off on on on on on on on off off off off off on off on) #20(off
+off on on off on on on on off off off off on off off on) #20(off off
+on on on on off on on off off off on on off off off on) #20(off off
+off on on on on on on on off on on off) #20(off off off off on on on
+off on on on on off) #20(off off off off off on on on on on on on
+off))) (make-problem "Hattori 17" '((9 9) (6 10) (5 11) (4 3 5) (2 1
+3) (2 4 2) (1 3 6) (5 1 1 1) (2 2 1 3 1) (7 4 1) (7 4 2) (1 3 9) (1 2
+4 6) (1 6 9) (1 4 7) (2 1 4 2) (5 3 4) (5 7) (5 10) (5 11)) '((1 8) (2
+4 4) (4 1 2 4) (8 2 4) (6 1 3 7) (4 8 4) (3 7 1) (1 2) (1 2) (2 2 2 1)
+(3 2 1 1 1 2) (7 8 2) (3 7 4 2) (3 1 1 2 3 3) (3 4 6 3) (4 1 4 3) (4 1
+4 4) (5 1 4 4) (7 4 5) (7 6 5)) '#20(#20(on off off off off off off
+off on on on on on on on on off) #20(on on off off off off off on on
+on on off off off off on on on on off) #20(on on on on off off off on
+off on on off off off off off on) #20(on on on on on on on on off on
+on off off off off off on) #20(on on on on on on off on off on on on
+off on) #20(on on on on off off off on on on on on on on on off on)
+#20(on on on off off off off off on on on on on on on off off off off
+on) #20(on off off off off off off off off off off off off on on off)
+#20(on off off off off off off off off off off off on on off) #20(off
+off on on off off off off on on off off on on off off off off off on)
+#20(off on on on off off on on off on off off on off off off on off
+on) #20(on on on on on on on off off on on on on on on on on off on)
+#20(on on on off off on on on on on on on off on on on on off on)
+#20(on on on off off on off off on off on on off on on on off on)
+#20(on on on off off on on on on off on on on on on on off on) #20(on
+on on on off off on off off off off on on on on off off on) #20(on on
+on on off off on off off off off on on on on off on) #20(on on on on
+on off on off off off off on on on on off on) #20(on on on on on on on
+off off off on on on on off on) #20(on on on on on on on off on on on
+on on on off on))) (make-problem "Hattori 18" '((3 4) (1 3 2 1) (1 6 3
+2) (1 1 2 1 1 6) (3 2 1 1) (1 1 1 1 2 1 1 1) (1 1 2 1 2 2 2) (1 1 2 1
+1 2 1) (1 2 4 1 3) (1 16) (2 5 10) (8 4 2) (8 2 4) (5 2 1 4) (1 5 6)
+(2 7 3 2) (2 8 2) (2 3 5 1 1) (2 5 7 3) (2 5 5 4)) '((5 7 6) (1 1 3 5)
+(2 3 3) (3 2 3 2) (2 1 6 2) (2 2 5 5) (2 2 11) (2 1 5 6) (3 3 4) (1 1
+5 6) (1 1 3 6) (6 2 5) (1 2 3 4) (3 2 4 3) (1 1 8 2) (1 2 3 5) (1 2 2
+5 1) (1 1 3 3 2) (3 10 2) (1 2 8 3)) '#20(#20(on on on on on off on on
+on on on on on off on) #20(on off off off on off off off off off on on
+on off off on) #20(on on off off on on on off off off off on on on
+off) #20(off on on on off off off on on off off on on on off off off
+off on) #20(off on on off off on off off on on on on on on off off off
+off on) #20(off off on on off off on on off on on on on on off on)
+#20(off off on on off off on on off on) #20(off on on off off on off
+off on on on on on off on) #20(on on on off off off off off on on on
+off off on on on on off) #20(on off off on off on on on on on off off
+off on on on on on on off) #20(on off off off on off off off on on on
+off off off on) #20(on on on on on on off off off on on off off off
+off on) #20(off off on off off on on off off on on on off off off off
+on) #20(off off on on on off on on off on on on on off off off off on)
+#20(off off off on off on off off on on on on on on on on off off on)
+#20(off off off on off off on on off on on on off off on on on on on
+off) #20(off off off on off off on on off on on off on on on on on off
+off on) #20(off off off on off on off off on on on off on on on off
+off off on) #20(off off on on on off on on on on on on on on on on off
+off on) #20(off off on off off on on off on on on on on on on on off
+on))) (make-problem "Hattori 19" '((2 2 2 3) (2 2 3 5) (2 2 3 5) (1 1
+2 5) (2) (8 2 2) (10 3 2 1) (11 3 2 1) (11 2 1 1) (11) (11 5) (10 7)
+(6 7) (4 6) (5 6) (6 5) (7 6) (7 7) (7 7) (6 6)) '((4 7) (3 14) (15)
+(4 15) (3 15) (8 6) (3 7 5) (4 7 4) (3 7) (1 6) (4 4) (5) (4 2 2) (4 4
+2 3) (2 4 5 4) (10) (3 10) (4 10) (9) (3 7)) '#20(#20(on on on on off
+off on on on on on on on off) #20(on on on off off on on on on on on
+on on on on on on on on off) #20(off off off off off on) #20(on on on
+on off on) #20(on on on off off on) #20(off off off off off on on on
+on on on on on off on) #20(off on on on off on on on on on on on off
+off off on) #20(on on on on off on on on on on on on off off off off
+on) #20(on on on off off on on on on on on on off) #20(off off off on
+off off on on on on on on off) #20(off on on on on off off on on on on
+off) #20(on on on on on off) #20(on on on on off off on on off off off
+off off off off off off off on) #20(on on on on off on on on on off
+off on on off off off off on) #20(off on on off off on on on on off on
+on on on on off on) #20(off off off off off off off off off off on)
+#20(off off off off off on on on off off on) #20(off off off off off
+on on on on off on) #20(off off off off off off off off off off on on
+on on on on on on on off) #20(off off off off off off on on on off off
+on on on on on on on off))) (make-problem "Hattori 20" '((3 3 5) (9 1)
+(2 16) (1 2 6 4) (1 1 1 1 6 4) (1 1 6 2) (1 1 5 1) (1 1 4 3) (2 1 2 2
+4) (1 3 5) (9 5) (7 4) (6 3) (4 1 2) (3 7 1) (5 1 6 1) (1 1 1 1 6 1)
+(1 1 1 1 1 1 1 1) (1 1 1 1 1 1) (3 3 3)) '((3) (11) (2 1 1) (1 1 5) (2
+1 10) (2 1 6 1) (4 5 5) (13 1) (3 5 5) (4 2 1) (5 7) (6 1) (7 3) (7 4)
+(6 3) (1 1 2 4) (1 3 4 3) (1 3 6 5) (1 4 7 1) (20)) '#20(#20(on on on
+off) #20(on on on on on on on on on on on off) #20(on on off off off
+off off off on off on off) #20(off on off off on off off off off off
+on on on on on off) #20(off on on off off off off off on off on)
+#20(off on on off on off off off off off on on on on on on off off off
+on) #20(on on on on off off off off off on on on on on off on) #20(on
+on on on on on on on on on on on on off off on off) #20(on on on off
+off off off off on on on on on off off on) #20(off off on on on on off
+off off off on on off off off off off off off on) #20(off off on on on
+on on off off off off off off on) #20(off off on on on on on on off
+off off off off off on off) #20(off off on on on on on on on off off
+off off off on on on off) #20(off off on on on on on on on off off off
+off off on on on on off) #20(off off on on on on on on off off off off
+off off on on on off) #20(on off on off off off off off off on on off
+off off on on on on off) #20(on off on on on off off off on on on on
+off off on on on off) #20(on off on on on off off on on on on on on
+off off on) #20(on off on on on on off on on on on on on on off off
+off off off on) #20(on))) (make-problem "Hattori 21" '((4 10) (2 1 3)
+(1 1 10) (1 1 4) (1 1 4) (1 1 2 2) (1 1 2 2 2) (1 1 1 1 1 1) (1 1 6 1
+1) (2 1 2 1 4 2) (6 1 2 1 4) (11 3) (1 4) (1 4) (1 4) (1 5) (1 6) (18)
+(18) (18)) '((9) (2 2) (1 1 3) (1 1 3) (11 3) (10) (4 3) (2 2 1 3) (6
+2 3) (2 2 1 3) (9 2 3) (7 4 3) (3 1 1 3) (1 1 4 3) (1 1 1 1 4) (1 1 1
+5) (1 1 4 8) (1 1 1 11) (1 1 1 10) (1 1 1 10)) '#20(#20(off on on on
+on on on on on on off) #20(on on off off off off off off off on on
+off) #20(on off off off off off off off off off on off off off off off
+off on) #20(on off off off off off off off off off on off off off off
+off off on) #20(on on on on on on on on on on on off off off off off
+off on) #20(off off off off off off off off off off on) #20(off off
+off off off off off off on on on on off off off off off on) #20(off
+off off off off on on off on on off on off off off off off on) #20(off
+off off on on on on on on off on on off off off off off on) #20(off
+off off on on off off off on on off on off off off off off on) #20(on
+on on on on on on on on off on on off off off off off on) #20(on on on
+on on on on off on on on on off off off off off on) #20(on on on off
+off off off off off on off on off off off off off on) #20(on off on
+off off off off off on on on on off off off off off on) #20(on off on
+off off off off off off on off on off off off off on) #20(on off on
+off off off off off off off off on off off off on) #20(on off on off
+off off off on on on on off on) #20(on off on off off off on off off
+on) #20(on off on off off off on off off off on) #20(on off on off off
+off off on off off on))) (make-problem "Hattori 22" '((7) (3 1 7) (1 3
+7) (2 2 8) (7 8) (4 1 8) (1 1 4 8) (2 3 8) (3 10) (14) (15) (15) (18)
+(16 1) (8 6) (7 5) (7 2 2) (2 2 1) (1) (1)) '((2 10) (11) (9) (3 9) (3
+8) (1 4 9) (2 2 1 9) (14) (3 1 6) (10) (9) (2 8 2) (1 14) (16) (16) (9
+5) (9 1 2) (7 2) (6) (6)) '#20(#20(off off off off off off on on off
+off on) #20(off off off off off off off on on on on on on on on on on
+on off) #20(off off off off off off off off on on on on on on on on on
+off) #20(off off on on on off off off on on on on on on on on on off)
+#20(off off off on on on off off off on on on on on on on on off)
+#20(off on off off on on on on off on on on on on on on on on off)
+#20(off on on off on on off on off on on on on on on on on on off)
+#20(off on on on on on on on on on on on on on on off) #20(off off on
+on on off on off on on on on on on off) #20(off off off off on on on
+on on on on on on on off) #20(off off off off off off on on on on on
+on on on on off) #20(on on off off off off off on on on on on on on on
+off on on off) #20(on off off on on on on on on on on on on on on on
+on off) #20(on on on on on on on on on on on on on on on on off)
+#20(on on on on on on on on on on on on on on on on off) #20(on on on
+on on on on on on off off off on on on on on off) #20(on on on on on
+on on on on off off off on off off on on off) #20(on on on on on on on
+off off off off off on on off) #20(off on on on on on on off) #20(off
+on on on on on on off))) (make-problem "Hattori 23" '((8 4) (10 1) (12
+1 1) (3 1 1 2) (2 2 2 1 1 2) (2 1 1 1 1 2) (2 1 1 2) (2 1 1 1 1 1 2)
+(3 1 1 1 1 1 1) (2 6 1 1 2) (2 1 1 4) (2 9 4) (14 4) (15) (8 4 2) (8 2
+2 1) (8 1 1 3) (2 5 1 2 1) (11 1) (10 5)) '((9) (10) (5 1 5) (8 8) (4
+1 9) (3 1 12) (3 2 1 1 9) (3 2 9) (3 1 1 3 2) (3 2 2 3 2) (3 1 1 1 3 2
+2) (3 6 3) (9 4 2) (1 4 1) (5) (3) (13 1) (1 3 1 2 1) (1 5 4 3 1) (1
+11 1 1)) '#20(#20(off off off off off off off off off on on on on on
+on on on on off) #20(off off off off off off off off on on on on on on
+on on on on off) #20(off off on on on on on off on off off off on on
+on on on off) #20(off on on on on on on on on off off off on) #20(on
+on on on off off off on off off off on) #20(on on on off on off off
+off on) #20(on on on off on on off on off on off on) #20(on on on off
+off off off off on on off on) #20(on on on off off off off on off on
+off on on on off off off off on) #20(on on on off on on off off on on
+off on on on off off off off on) #20(on on on off on off off on off on
+off on on on off on on off on) #20(on on on off off off off off off
+off on on on on on on off on) #20(off on on on on on on on on on off
+on on on on off off off on) #20(off off on off off off off off off off
+off off on on on on off off on off) #20(off off off off off off off
+off off off off off off on on on on on off) #20(off off off off off
+off off off off off off off off off off off off on) #20(on on on on on
+on on on on on on on on off off off off off off on) #20(on off off off
+off off off off off off on on on off on off on on off on) #20(on off
+off on on on on on off on on on on off on on on off off on) #20(on off
+on on on on on on on on on on on off off off on off off on)))
+(make-problem "Hattori 24" '((5 3) (4 4 4) (1 2 10) (1 1 6 1 3) (1 1 2
+1 6 2) (1 1 1 1 4) (3 1 1 1 1 1) (2 1 1 1 1 1) (2 3 4 4) (5 1 2 3 1)
+(1 3 1 1) (3 1 1 1) (5 3 1 2) (7 1 8) (10 1 1 1) (5 11) (3 7) (3 6 2)
+(3 7 1) (2 5)) '((7) (1 3 6) (1 1 1 2 7) (2 1 7) (2 1 4) (1 1 4) (12)
+(1 1 1 4) (2 9 2) (4 1 2) (4 7 1) (5 2 1 1 3) (1 5 2 1 3) (1 1 1 7) (3
+2 1 5) (1 1 5 5) (2 2 2 6) (4 4 1 2) (6 1 2 3) (2 16)) '#20(#20(off on
+on on on on on on off) #20(off on off off off off on on on off off off
+off off on) #20(off on off off on off on off on on off off off on)
+#20(off on on off off off off off off on off off on on on on on on on
+off) #20(off off on on off off off off off on off off on on on on off)
+#20(off off off off on off off off off on off off on on on on off)
+#20(off off off on on on on on on on on on on on on off) #20(on off
+off on off off off off on off off on on on on off) #20(on on off on on
+on on on on on on on off on on off) #20(on on on on off off off off
+off off on off off off on on off) #20(on on on on off off off off off
+on on on on on on on off off on off) #20(on on on on on off off off on
+on off off on off off on off on) #20(off off on off on on on on on off
+off off on on off on off on) #20(off off on off on off off off on off
+off off off on) #20(off off on on on off off off on on off off off on
+off on) #20(off off on off on off off off off on on on on on off on)
+#20(off on on off on on off off on on off off off on on on on on on
+off) #20(on on on on off on on on on off off off off on off on on off)
+#20(on on on on on on off off on off off off on on off on on on off)
+#20(on on off on on on on on on on on on on on on on on on on off)))
+(make-problem "Hattori 25" '((6 7) (3 2 8) (3 2 2 4) (2 3 1 2 3) (2 1
+1 1 4 3) (2 4 1 2 2) (2 2 1 1 3) (3 2 2 1) (4 2 1 2) (7 2 1) (2 1 1 1)
+(2 1 1 1) (2 3 1) (2 2 1) (2 5) (2 1 1) (2 2 1) (4 1 1) (18) (18))
+'((7) (9) (3 3 2) (2 2 3) (1 3 11) (1 1 1 11) (1 4 1 3) (2 2 2 2) (2 2
+2) (6 2) (2) (2) (3 2 2) (8 6 4) (2 2 3 5 2) (2 1 3 1 2) (3 3 1 2) (5
+1 12) (7 2) (5 2)) '#20(#20(off off on on on on on on on off) #20(off
+on on on on on on on on on off) #20(on on on off off off off on on on
+off off off off off off off off on) #20(on on off off off off off off
+on on off off off off off off off on) #20(on off off on on on off off
+off on) #20(on off off on off on off off off on) #20(on off off on on
+on on off off on off off off off off off off on) #20(on on off off off
+on on off on on off off off off off off off off on) #20(off on on off
+off off off on on off off off off off off off off off on) #20(off off
+on on on on on on off off off off off off off off off off on) #20(off
+off off off off off off off off off off off off off off off off off
+on) #20(off off off off off off off off off off off off off off off
+off off off on) #20(on on on off on on off off off off off off off off
+off off off off on) #20(on on on on on on on on off on on on on on on
+off on) #20(on on off on on off off on on on off off on on on on on
+off on) #20(on on off off on off off off off off on on on off on off
+off off on) #20(on on on off off off on on on off off off off off on
+off off off on) #20(on on on on on off on off on) #20(on on on on on
+on on off off off off off off off off off off off on) #20(off on on on
+on on off off off off off off off off off off off off on)))
+(make-problem "Hattori 26" '((1 1 1 2) (2 2 2 2) (9 4) (1 1 1 3) (2 1
+1 3 2) (3 1 1 1 4 2) (1 1 1 2 1 2) (1 4 5 1 2) (1 4 5 1 2) (1 8 1 3)
+(1 8 1 3) (1 8 1 3) (1 7 1 3) (2 7 2 3) (1 1 7 1 3) (2 7 2 3) (2 1 1 1
+1 3) (7 2 9) (16) (1 1 6)) '((2 1) (3) (5 2) (2 4 1) (7 2 2) (3 5 4)
+(2 2 9 2) (1 10 2) (2 2 7 2) (1 9 2) (1 2 10 1) (2 9 2) (15 3) (5 4)
+(2 3 3) (2 9 3) (2 3) (2 11) (20) (20)) '#20(#20(off off off off off
+off off off off off off off off off on on off on off) #20(off off off
+off off off off off off off off off off off off on on on off) #20(off
+off off off off on on on on on off off off off off off on on off)
+#20(off off off off on on off off off off on on on on off off off on
+off) #20(off off on on on on on on on off off off off on on off off on
+on off) #20(on on on off off off off on on on on on off off off on on
+on on off) #20(off on on off on on off on on on on on on on on on off
+on on off) #20(off off on off off off off on on on on on on on on on
+on off on) #20(off off on on off on on off off on on on on on on on
+off on on off) #20(off off on off off off off on on on on on on on on
+on off on on off) #20(off off on off on on off on on on on on on on on
+on on off on off) #20(off on on off off off off on on on on on on on
+on on off on on off) #20(on on on on on on on on on on on on on on on
+off off on) #20(off off off off on on on on on off off off off off off
+on on on on off) #20(off off off off on on off off off off off off off
+on on on off on) #20(on on off off off on on on on on on on on on off
+off off on) #20(off on on off off off off off off off off off off off
+off off off on) #20(off off on on off off off off off on) #20(on)
+#20(on))) (make-problem "Hattori 27" '((6) (8) (1 6) (10) (2 1 1 1 1)
+(2 1 1 1 1) (1 1 1 3) (3 3 1) (3 2) (1 2 2) (2 2 3 2) (2 3 3 2) (2 3 2
+6) (5 3 7) (4 4 3 1) (7 2 3 3) (6 4 3 1 1) (9 3 2) (8 6) (11 5))
+'((11) (10) (7) (8) (4 3 5) (1 5 3 6) (1 1 1 2 2 3) (2 6 2 4) (4 1 3 2
+1) (9 2 2 1) (4 1 2 2 1) (8 3) (4 1 3) (5 3 3) (7) (13) (7 2) (2 2 2)
+(1 1 3) (7)) '#20(#20(off off off off off off off off off on) #20(off
+off off off off off off off off off on) #20(off off off off off off
+off off off off off off off on) #20(off off off off off off off off
+off off off off on) #20(off off on on on on off off off off off on on
+on off on) #20(off on off on on on on on off off on on on off on)
+#20(off on off on off off off on off off on on off off on on off on)
+#20(on on off on on on on on on off off off off on on off on) #20(on
+on on on off off off off on off off off on on on off on on off on)
+#20(on on on on on on on on on off off off on on off on on off off on)
+#20(on on on on off off off on off on on off off off off on on off off
+on) #20(on on on on on on on on off on on on off) #20(on on on on off
+off on off off off on on on off) #20(off off on on on on on off off
+off off on on on off on on on off) #20(off off off off off off off off
+off off off off on on on on on on on off) #20(off off off off off off
+off on) #20(off off off off off off off off on on on on on on on off
+off off on) #20(off off off off off off off off off off off off on on
+off on on off on) #20(off off off off off off off off off off off off
+off on off on off on) #20(off off off off off off off off off off off
+off off on))) (make-problem "Hattori 28" '((1 1) (5) (3 3) (8) (9) (1
+1 3 3) (1 1 3 1) (4 4 1) (2 2 2 3 1) (5 2 2 1) (5 3 1) (6 3 1) (5 5 2)
+(4 3 3 2) (8 2 3 2) (7 3 6) (6 3 6) (5 3 6) (5 3 5) (7 4)) '((2 1) (3
+4 1) (3 1 5 1) (10 1) (14) (3 4) (4 4 1) (9 5 1) (8 5 1) (8 2 1) (2 2
+6 6) (4 5 6) (4 4 5) (4 3) (3 7) (2 6) (5) (5) (7) (12)) '#20(#20(off
+off off off off off off off on on off off off off off off off off on
+off) #20(off off off off off off off on on on off on on on on off off
+off on off) #20(off off off off off on on on off on off on on on on on
+off off on off) #20(off off off off off off off on on on on on on on
+on on on off on off) #20(off off off off off on on on on on on on on
+on on on on on on off) #20(off off off off off off off off off off on
+on on off on on on on off) #20(off off off off off off off off on on
+on on off off on on on on off on) #20(off off on on on on on on on on
+on off off on on on on on off on) #20(on on on on on on on on off off
+off off off on on on on on off on) #20(off on on on on on on on on off
+off off on on off off off off off on) #20(on on off on on off off on
+on on on on on off on) #20(off on on on on off off off on on on on on
+off on) #20(off on on on on off off off off off on on on on off on)
+#20(off off on on on on off off off off off off on on on off) #20(off
+off off on on on off off off off off off off on) #20(off off off off
+on on off off off off off off off off on) #20(off off off off off off
+off off off off off off off off off on) #20(off off off off off off
+off off off off off off off off off on) #20(off off off off off off
+off off off off off off on on on on on on on off) #20(off off off off
+off off on on on on on on on on on on on on off))) (make-problem
+"Hattori 29" '((2) (2) (2) (4) (3 2) (5 2 2) (1 1 2 2) (5 2 2) (5 2 4)
+(5 2 3) (6 2 2) (1 1 4 1) (1 1 2 3 1) (2 2 1 4) (2 2 3 1 2) (1 4 5 3)
+(1 17) (4 4 4 2) (5 5 5) (3 3)) '((8) (6 2 1) (1 4 3) (1 4 5) (1 4 2
+2) (15) (6) (2) (2 4) (4 2 1) (3 2 3 1) (3 2 5 1) (2 2 2 2 5) (1 2 3
+2) (2 2 3) (2 2 5) (2 5 2) (2 2 5) (3 2 3) (7)) '#20(#20(off off off
+off off off off off off off on on on on on on on on off) #20(off off
+off off off on on on on on on off off on on off off on off) #20(off
+off off off off on off on on on on off off off off off on on on off)
+#20(off off off off off on off on on on on off off off off on) #20(off
+off off off off on off on on on on off off off off on on off on)
+#20(off off off off off on) #20(off off off off off off off off off
+off off off off on on on on on on off) #20(off off off off off off off
+off off off off off off off off off on on off) #20(off off off off on
+on off off off off off off off off off on on on on off) #20(off off
+off on on on on off off off off off off off off on on off on off)
+#20(off off on on on off on on off off off off off off on on on off on
+off) #20(off on on on off off off on on off off off on on on on on off
+on off) #20(on on off on on off off off on on off on on off on on on
+on on off) #20(on off off off on on off off off on on on off off off
+off on on off) #20(off off off off off on on off off off on on off off
+off off on on on off) #20(off off off off off off on on off off off on
+on off off on) #20(off off off off off off off on on off off off on on
+on on on off on) #20(off off off off off off off off on on off off on
+on off on) #20(off off off off off off off off on on on off off on on
+off on on on off) #20(off off off off off off off off on on on on on
+on on off))) (make-problem "Hattori 30" '((3 6) (6 7) (7 6) (19) (7 6)
+(3 3) (1 3) (2 4 4 1) (9 6 2) (1 2 2 1 3 2) (1 2 1 2 1 1 3 1) (1 2 2 1
+3 1) (1 6 7 1) (1 4 5 1) (1 3 1) (1 3 5 1) (2 1 8) (3 7) (5 6 6) (5 4
+5)) '((3 9 2) (5 2 4) (12 3) (6 6 3) (5 2 2 2) (5 2 1 2) (4 2 2 1) (1
+6 2 2) (1 4 3 2) (1 2 2) (1 5 2) (1 2 2 1) (2 1 2 1 2 1) (5 2 2 3) (5
+7 4) (6 6 5) (7 4 5) (7 5) (4 4 4) (12)) '#20(#20(off off on on on off
+off off on on on on on on on on on off on) #20(off on on on on on off
+on on off off off off off off off on) #20(off on on on on on on on on
+on on on on off off off off on) #20(on on on on on on off off on on on
+on on on off off off on) #20(on on on on on off off on on off off off
+on on off off off off on) #20(on on on on on off off on on off on off
+on on off) #20(off on on on on off off on on off off off on on off off
+off off on off) #20(off off off on off off off on on on on on on off
+on on off off on) #20(off off off on off off off off on on on on off
+off on on on off on) #20(off off off on off off off off off off off
+off off off on on off off on) #20(off off off on off off off off on on
+on on on off off off off off on) #20(off off off on off off off on on
+off off off on on off off off off on off) #20(on on off on off off off
+on on off on off on on off off on off) #20(on on on on on off off on
+on off off off on on off on on on off) #20(on on on on on off off on
+on on on on on on off on on on on off) #20(on on on on on on off off
+on on on on on on off on) #20(on on on on on on on off off on on on on
+off off on) #20(on on on on on on on off off off off off off off off
+on) #20(off on on on on off on on on on off off off off off off on)
+#20(off off off off off off off off on))))))
diff --git a/collects/games/paint-by-numbers/solution-sets/h121-138 b/collects/games/paint-by-numbers/solution-sets/h121-138
new file mode 100644
index 0000000000..c221515dad
--- /dev/null
+++ b/collects/games/paint-by-numbers/solution-sets/h121-138
@@ -0,0 +1,482 @@
+(unit/sig paint-by-numbers:problem-set^ (import
+paint-by-numbers:problem^) (define set-name "Hattori 121 - 138")
+(define problems (list (make-problem "Hattori 121" '((2) (3) (4) (5)
+(2 2) (2 2) (3) (8 3) (2 1 2 4) (3 1 2 1) (5 2 2 1) (1 4 2 1) (1 1 5)
+(3 3 5) (5 7) (6 6) (7 7) (17) (15) (13)) '((3) (5) (6) (2 7) (4 7) (1
+11) (3 1 1 4) (7 1 3) (4 3 2 3) (8 1 3) (4 1 1 4) (2 10) (3 7) (7) (6)
+(7) (10) (8) (2 2) (7)) '#20(#20(off off off off off off off off off
+off off off off off off on on on off) #20(off off off off off off off
+off off off off off off off on on on on on off) #20(off off off off
+off off off off off off off off off off on) #20(off off off off off
+off off off on on off off off on) #20(off off off off off off off on
+on on on off off on) #20(off off off off off off off on off on)
+#20(off off off on on on off on off off on off off off off off on)
+#20(off on on on on on on on off off on off off off off off off on)
+#20(on on on on off off on on on off on on off off off off off on)
+#20(on on on on on on on on off off off on off off off off off on)
+#20(off off on on on on off on off off off on off off off off on)
+#20(off off off off off off off on on off on) #20(off off off off off
+off off off on on on off off on) #20(off off off off off off off off
+off off off off off on) #20(off off off off off off off off off off
+off off off off on) #20(off off off off off off off off off off off
+off on on on on on on on off) #20(off off off off off off off off on
+on on on on on on on on on off) #20(off off off off off off off on on
+on on on on on on off) #20(off off off off off off off on on off off
+off on on off) #20(off off off off off off off on on on on on on on
+off))) (make-problem "Hattori 122" '((2 2 5) (2 2 7) (9 6 4) (1 1 1 1
+8 1) (7 9 2) (7 10 3) (9 2 3 2) (12 1 2 2 2 3) (3 3 1 1 1 1 2) (2 2 1
+1 2) (2 2 2 3 2 2) (2 2 1 3 2 2) (12 7 3) (1 2 2) (5 6) (2 1 1 1 4) (2
+1 1 2 3 2) (1 1 3 4 2) (1 1 1 1 1 1) (1 1 1 1 1 1) (5 1 4 2) (5 1 1 1
+3 4) (1 4 1 13) (1 2 4 3 3) (1 3 5 3) (1 1 1 6 2) (2 3 6 4) (2 8 5) (3
+22) (1 12 8) (15 8) (11 7) (9 6) (12 6) (3 18 2) (2 18 3) (2 2 12 3 1)
+(1 2 7 1) (2 2 2 2) (10 8)) '((1 1 6) (2 7 1 2 3) (13 1 2 2 2) (1 1 5
+1 2 3 2 2 1) (6 1 2 1 1 1 1 1 1) (1 4 1 1 3 1 2 1) (6 1 2 1 1 1) (1 1
+5 1 3 5 1 1) (13 14 1) (2 7 12 3) (1 1 5 13 2) (1 1 2 17 1) (2 1 1 12)
+(6 1 1 2 11) (3 3 9 11) (3 2 1 1 1 11) (4 1 8 1 4 5) (4 3 6 4 4) (4 1
+3 2 2 3 4) (4 2 5 3 1 4) (5 4 7 1 5) (7 2 1 2 3 1 4 2) (2 8 4 1 1 9 1)
+(2 11 8 1) (3 5 2 8 1) (3 4 2 3 10 1) (3 4 2 2 2 8 1 1) (2 4 4 10 2 1)
+(4 8 2 2) (3 5 5)) '#f) (make-problem "Hattori 123" '((4 8) (5 1 9) (3
+1 1 10) (3 1 1 3 8) (3 1 2 2 1 7) (1 1 2 1 1 1 2 5) (1 2 1 1 1 2 1 2)
+(1 1 2 1 2 1) (2 1 1 1 2) (2 2 1 2 1) (2 1 2 1 2) (2 1 1 1 1) (2 2 1 2
+2) (2 2 1 1 1) (1 1 1 1 1) (2 3 2 2) (2 2 1 2) (2 2 2 2) (2 2 2 1) (2
+2 1 2) (2 2 5) (8 6) (6 7) (6 7) (12 6)) '((6) (1 4 1) (4 3 2) (1 2 2
+2) (4 3 2) (1 2 3 2) (4 4 2) (1 2 4 2) (1 3 1) (4 2 1) (2 3 2 1) (1 2
+1) (1 5 2 1) (4 3 4 3) (5 7) (2 10) (2 5) (4 2 4 2) (6 4 3 3) (5 3 2
+4) (8 7) (6 4 5) (6 3 2 5) (7 3 2 5) (9 6)) '#25(#25(off off off off
+on on on on on on off) #25(off off off off on off off off on on on on
+off off off off off off off off off off off off on) #25(off off off on
+on on on off off off on on on off off off off off off off off off off
+on) #25(off off off on off off on on off off off off on on off off off
+off off off off off off on) #25(off off on on on on off off off off
+off off off on on on off off off off off off off on) #25(off off on
+off off on on off off off off off off off off on on on off off off off
+off on) #25(off on on on on off off off off off off off off off off
+off on on on on off off off on) #25(off on off off on on off off off
+off off off off off off off off off on on on on off on) #25(off on off
+off off off off off off off off off off off off off off off off off on
+on on off on) #25(off on on on on off off off off off off off off off
+off off off off off off off on on off on) #25(on on off off on on on
+off off off off off off off off off off off off off off on on off on)
+#25(on off off off off off off off off off off off off off off off off
+off off off off on on off on) #25(on off off off off off off off off
+on on on on on off off off off off off off on on off on) #25(on on on
+on off off off on on on off off on on on on off off off off on on on
+off) #25(off off off on on on on on off off off off off off off on on
+on on on on on off) #25(off off on on off off off off off off on on on
+on on on on on on on off) #25(off on on off off off on on on on on
+off) #25(on on on on off on on off off off off off on on on on off off
+off off off off off on) #25(on on on on on on off off off on on on on
+off off on on on off off off off on) #25(on on on on on off off on on
+on off off off off off off off on on off off on) #25(on on on on on on
+on on off off off off off off off off off off on) #25(on on on on on
+on off off off off off off on on on on off off off off on) #25(on on
+on on on on off off off off on on on off off on on off off off on)
+#25(on on on on on on on off on on on off off off off off on on off on
+on on on on off) #25(on on on on on on on on on off off off off off
+off off off on on on on on on off))) (make-problem "Hattori 124" '((8)
+(12) (14) (3 5) (1 3) (1 1 1 2) (9) (2 5 2) (2 2 2 2) (2 1 3 1 2) (1 1
+3 1 1) (2 1 3 1 2) (2 2 2 2) (2 5 2) (9)) '((2 3) (2 2 2) (3 2 2) (2 2
+2) (3 1 5 1) (3 4 3) (3 2 3 2) (3 3 3 2) (3 2 3 2) (3 4 3) (4 1 5 1)
+(4 2 2) (4 2 2) (5 2 2) (4 3)) '#15(#15(off off off on on off off off
+off on on on off) #15(off off on on off off off off on on off on on
+off) #15(off on on on off off off on on off off off on on off) #15(off
+on on off off off on on off off off off off on) #15(on on on off off
+off on off on on on on on off on) #15(on on on off off on on on on off
+off off on) #15(on on on off off off on on off on on on off on) #15(on
+on on off off on on on off on on on off on) #15(on on on off off off
+on on off on on on off on) #15(on on on off off on on on on off off
+off on) #15(on on on on off off on off on on on on on off on) #15(on
+on on on off off on on off off off off off on) #15(off on on on on off
+off on on off off off on on off) #15(off on on on on on off off on on
+off on on off) #15(off off on on on on off off off on on on off)))
+(make-problem "Hattori 125" '((11) (11) (2 7) (6 5) (8 3) (3 5 2) (4 4
+3 1) (3 3 5 1) (1 3 2 3 1) (3 2 3 1) (4 2 2 1) (2 2 1 4 1) (2 2 3 1)
+(4 1 2) (3 2 2 2) (3 1) (2) (2 2) (3 2) (2 4)) '((3 2 6) (3 2 6) (2 3
+2 2) (2 2 4) (3 2 2) (5) (7) (11) (12) (9 1) (6 3) (1 1 1 2) (2 2 2 2)
+(1 2 1 1 1) (1 2 2 2 1) (1 4 4 2) (2 6 2) (1 3 2) (2 4) (10))
+'#20(#20(on on on off off on on off off on on on on on on off) #20(on
+on on off off on on off off on on on on on on off) #20(on on off off
+off on on on off on on off off on on off) #20(on on off off off off on
+on off off on on on on off) #20(on on on off off off off on on off off
+on on off) #20(on on on on on off) #20(on on on on on on on off)
+#20(on on on on on on on on on on on off) #20(on on on on on on on on
+on on on on off) #20(on on on on on on on on on off off off off off
+off off off off off on) #20(on on on on on on off off off off off off
+off off off off off on) #20(off off off off on off off off on off off
+off off off on off off on on off) #20(off off off on on off off on on
+off off off off off on on off off on) #20(off off off on off off on on
+off off off on off off off on off off off on) #20(off off off on off
+off on on off off off on on off on on off off off on) #20(off off off
+on off off on on on on off on on on on off off off on) #20(off off off
+on on off off on on on on on on off off off off on on off) #20(off off
+off off on off off off on on on off off off off off on on off) #20(off
+off off off on on off off off off off off off on on on on off) #20(off
+off off off off on on on on on on on on on on off))) (make-problem
+"Hattori 126" '((2 2) (4 4) (12) (13) (3 1 1 1 3) (2 1 1 1 2) (1 7 1)
+(1 1) (2 2) (2 2) (3 3) (3 3) (9) (7) (5)) '((5) (3 3) (3 3) (3 3) (7
+3) (4 1 3) (3 1 3) (5 3) (2 1 3) (3 1 3) (7 3) (4 3) (4 3) (4 3) (5))
+'#15(#15(off off off off on on on on on off) #15(off off off on on on
+off off on on on off) #15(off off on on on off off off off on on on
+off) #15(off on on on off off off off off off on on on off) #15(on on
+on on on on on off off off off on on on off) #15(on on on on off off
+on off off off off off on) #15(off on on on off off on off off off off
+off on) #15(off off on on on on on off off off off off on) #15(off off
+on on off off on off off off off off on) #15(off on on on off off on
+off off off off off on) #15(on on on on on on on off off off off on on
+on off) #15(on on on on off off off off off off on on on off) #15(off
+on on on on off off off off on on on off) #15(off off on on on on off
+off on on on off) #15(off off off off on on on on on off)))
+(make-problem "Hattori 127" '((4) (5) (5 6) (6 6) (15) (7 3 2) (7 2 3
+2) (3 3 4 2) (2 13 1) (1 5 7 1) (1 5 4 1) (1 3 2 1) (1 1) (1 1 1 1) (1
+1 1 2) (2 1 1 2) (2 2 2 2) (6 2 2) (16) (14)) '((9) (1 3 3) (3 2 3) (5
+2 3) (5 4 7) (10 4) (8 3) (8 2) (2 2 2) (4 1 2) (3 1 2 2) (4 2 2) (10
+2) (11 3) (11 4) (3 1 5 4 2) (2 4 2) (2 3) (2 4) (9)) '#20(#20(off off
+off off off off off on on on on on on on on on off) #20(off off on off
+off off on on on off off off off off off on on on off) #20(off off on
+on on off on on off off off off off off off off on on on off) #20(off
+off on on on on on off off off on on off off off off off on) #20(off
+off on on on on on off on on on on off on) #20(off off on on on on on
+on on on on on off off off off on) #20(off off off on on on on on on
+on on off off off off off off on) #20(off off off on on on on on on on
+on off off off off off off off on) #20(off off off off on on off off
+on on off off off off off off off off on) #20(off off off on on on on
+off on off off off off off off off off off on) #20(off off on on on
+off on off on on off off off off off off off off on) #20(off on on on
+on off off off on on off off off off off off off off on) #20(on on on
+on on on on on on on off off off off off off off off on) #20(on on on
+on on on on on on on on off off off off off off on) #20(on on on on on
+on on on on on on off off off off off on) #20(on on on off on off off
+on on on on on off on on on on off on) #20(off off off off on on off
+off on on on on off off off off off off on) #20(off off off off off on
+on off off off off off off off off off on on on off) #20(off off off
+off off off on on off off off off off off on on on on off) #20(off off
+off off off off off on on on on on on on on on off))) (make-problem
+"Hattori 128" '((14 1) (4 8 1) (3 8 3) (3 1 1 7 1 1) (4 1 1 1 6 2 1)
+(4 3 1 6 1 1) (4 5 2 1) (4 4 5 1 1) (5 1 1 3 3) (4 4 1) (2 2) (5 7 1)
+(7 5 6) (4 3 3 3) (4 2 4) (7 4 1) (4 4 3 6 1) (4 2 6 3 2) (7 5 1 3) (2
+2 1 1) (2 4 2) (1 1 2) (2 7) (3 8) (14)) '((4) (6) (6 8) (9 6 3) (10 4
+1 2) (3 6 3 1 1 2) (2 5 2 2 2) (1 3 3 1 2 1) (1 1 2 1 1 1) (1 3 3 2 2
+1 1) (1 1 1 2 4 1) (3 2 1 1 1 1 2) (4 3 2 3 3) (6 2 3 4) (8 3 3 3) (9
+3 1 3) (10 3 2 3) (9 1 1 2 4) (7 1 4 5) (2 7) (1 3) (5 1 5) (1 1 1 1 3
+1) (4 1 2 3 2) (1 1 1 1 7)) '#25(#25(off off off off off off off off
+off off off off off off off on on on on off) #25(off off off off off
+off off off off off off off off off on on on on on on off) #25(off off
+off on on on on on on off off off off on on on on on on on on off)
+#25(off on on on on on on on on on off off off on on on on on on off
+on on on off) #25(on on on on on on on on on on off off on on on on
+off off on off off off on on off) #25(on on on off on on on on on on
+off on on on off on off off on off off off off on) #25(on on off off
+off off off off on on on on on off off on on off on on off off off on)
+#25(on off off on on on off off off off on on on off off off on off
+off on on off off off on) #25(on off off off off on off off off off
+off on on off off off on off off off on off off off on) #25(on off off
+on on on off on on on off on on off off off on on off off on off off
+off on) #25(on off off off off off off on off on off off on on off off
+off on on on on off off off on) #25(on on on off on on off on off on
+off off off on off off off off on off off off off on) #25(on on on on
+off off off on on on off off on on off off on on on off off off on)
+#25(on on on on on on off off off off off on on off off off on on on
+off off on) #25(on on on on on on on on off off on on on off off off
+on on on off off off on) #25(on on on on on on on on on off on on on
+off off off off on off off off off on) #25(on on on on on on on on on
+on off on on on off off on on off off off off on) #25(on on on on on
+on on on on off off on off on off off on on off off off on) #25(off on
+on on on on on on off off off on off on on on on off off off on)
+#25(off off off off off off off off off off off on on off on on on on
+on on on off) #25(off off off off off off off off off off off off on
+off off on on on off) #25(off off off on on on on on off off off off
+on off on on on on on off) #25(off off on off on off on off on off off
+off on on on off off off on off) #25(on on on on off on off on on off
+off off on on on off off on on off) #25(off off on off on off on off
+on off off on on on on on on on off))) (make-problem "Hattori 129"
+'((3) (5) (5) (6) (5 6) (7 6) (4 3 6) (4 2 8) (4 2 10) (4 1 5 5) (4 2
+7 4) (6 2 8 2) (3 1 12) (1 1 2 1 11 1) (1 1 2 11 1) (1 2 3 14) (1 6
+14) (1 3 17) (1 5 17) (8 5 3) (1 5 1 1 1) (1 6 1 1 1) (11 1 1) (1 1 4
+1 1 1) (4 3)) '((5 11) (6 1 1) (15 1) (9 9) (3 3 7) (2 1 2 1 6) (3 1 1
+1 1 6) (7 2 5) (3 1 2 3) (2 1 2 1) (1 1 8) (9 1) (13) (10 1) (12) (13)
+(14) (16) (18) (9 9) (10 8) (6 4 2 4) (4 6 5 1) (4 1 10) (2 6 1))
+'#25(#25(off off off off off off off on on on on on off on on on on on
+on on on on on on off) #25(off off off off off off on on on on on on
+off off off off off off off on off off on off) #25(off off off off off
+on on on on on on on on on on on on on on on off off on off) #25(off
+off off off on on on on on on on on on off off on on on on on on on on
+on off) #25(off off off off on on on off off off off on on on off off
+on on on on on on on off) #25(off off off off on on off off off off
+off on off on on off on off on on on on on on off) #25(off off off off
+on on on off on off on off off off on off on off on on on on on on
+off) #25(off off off off on on on on on on on off off off off on on
+off off on on on on on off) #25(off off off off off on on on off off
+off off off off off on off on on off off on on on off) #25(off off off
+off off off off off off off off off on on off on off on on off off off
+on off) #25(off off off off off off off off off off off on off off on
+off off on) #25(off off off off off off off off off off off on on on
+on on on on on on off off off off on) #25(off off off off off off off
+off off off off off on) #25(off off off off off off off off off off on
+on on on on on on on on on off off off off on) #25(off off off off off
+off off off on on on on on on on on on on on on off) #25(off off off
+off off off on on on on on on on on on on on on on off) #25(off off
+off off off on on on on on on on on on on on on on on off) #25(off off
+off on on on on on on on on on on on on on on on on off) #25(off on on
+on on on on on on on on on on on on on on on on off) #25(on on on on
+on on on on on off on on on on on on on on on off) #25(on on on on on
+on on on on on off on on on on on on on on off) #25(on on on on on on
+off on on on on off on on off on on on on off) #25(off on on on on off
+off on on on on on on off off on on on on on off off off off on)
+#25(off off off off off off off off on on on on off on off on) #25(off
+off off off off off off off off on on off off off on on on on on on
+off off off off on))) (make-problem "Hattori 130" '((3) (5 8) (6 9) (7
+9) (7 5 3) (7 4 3) (5 3 2) (3 2 2) (2 1 1 1) (2 1 1) (1 1) (3 5 1) (1
+5 1) (3 5 1) (7 1) (7 3 1) (6 4 1) (6 4 1 1) (13 6) (5 6)) '((6 1 4)
+(6 2 1 4) (7 2 3 4) (6 1 4) (11 4) (6 4) (5 2 1) (1 1 1) (2 4 2) (3 4
+4) (4 9) (5 9) (6 9) (7) (8 2) (2 3) (3 2) (3 2) (4 2) (15))
+'#20(#20(on on on on on on off off off off off off off on off on on on
+on off) #20(on on on on on on off off on on off off off on off on on
+on on off) #20(on on on on on on on off on on off on on on off on on
+on on off) #20(off on on on on on on off off off off on off off off on
+on on on off) #20(off on on on on on on on on on on on off off off on
+on on on off) #20(off off on on on on on on off off off off off off
+off on on on on off) #20(off off off on on on on on off off off off
+off off on on off off on off) #20(off on off off off off off off off
+off off off off off on off off off on off) #20(off on on off off off
+off off off off off on on on on off off off on) #20(off on on on off
+off off off off off off on on on on off on) #20(off on on on on off
+off off off off off on) #20(off on on on on on off off off off off on)
+#20(off on on on on on on off off off off on) #20(off on on on on on
+on on off) #20(off on on on on on on on on off off off off off off off
+off off on) #20(off off on on off off off off off off off off off off
+off off off on) #20(off off on on on off off off off off off off off
+off off off off off on) #20(off off off on on on off off off off off
+off off off off off off off on) #20(off off off off on on on on off
+off off off off off off off off off on) #20(off off off off off on)))
+(make-problem "Hattori 131" '((4) (2 3) (1 4) (1 4 4) (6 6) (4 7) (7)
+(7) (4 6) (6 1 1) (2 5 3) (1 6 1 1) (1 6 2 1) (8 1) (7 2) (6 1) (9)
+(3) (1) (4)) '((4) (2 2) (1 4) (6 4) (6 2 2) (4 2 5) (8) (9) (9) (8)
+(7) (1) (1) (3 1) (5 3 1) (9 4) (6 1 1 1) (6 3 3) (6 1) (7 1))
+'#20(#20(off on on on on off) #20(on on off off on on off) #20(on off
+on on on on off) #20(on on on on on on off off off off on on on on
+off) #20(on on on on on on off off off on on off off on on off)
+#20(off on on on on off off off on on off on on on on on off) #20(off
+off off off off off off off on on on on on on on on off) #20(off off
+off off off off off off on on on on on on on on on off) #20(off off
+off off off off off off on on on on on on on on on off) #20(off off
+off off off off off off off on on on on on on on on off) #20(off off
+off off off off off off off off on on on on on on on off) #20(off off
+off off off off off off off off off off off off off off on off)
+#20(off off off off off off off off off off off off off off off off on
+off) #20(off off off off off on on on off off off off off off off off
+on off) #20(off off off off on on on on on off off off on on on off on
+off) #20(off off off off on on on on on on on on on off on on on on
+off) #20(off off off on on on on on on off on off off off off off off
+on off on) #20(off off off on on on on on on off on on on off off off
+off on) #20(off off off on on on on on on off off off off off off off
+off off off on) #20(off off off on on on on on on on off off off off
+off off off off off on))) (make-problem "Hattori 132" '((3) (1 1) (1 1
+6) (1 1 1 4) (1 1 2 5) (1 1 2 5) (1 1 9) (1 1 10) (1 1 3 1 3) (1 1 3 1
+2) (1 1 2 1 3) (1 1 2 2) (5 1 2) (1 2 2 1) (1 2 7) (3 7 2) (5 1 7) (5
+1 7) (5 14) (3 1)) '((3) (5) (5) (5) (3) (4) (13 4) (1 1 1 1) (14 1 1)
+(7) (1 5) (6 4) (11 3) (1 6 2 3) (1 2 1 1 1 4) (1 6 1 5) (6 2 1) (9 1
+1) (10 1 1) (6 2 2 1)) '#20(#20(off off off off off off off off off
+off off off off off off off on on on off) #20(off off off off off off
+off off off off off off off off off on) #20(off off off off off off
+off off off off off off off off off on) #20(off off off off off off
+off off off off off off off off off on) #20(off off off off off off
+off off off off off off off off off off on on on off) #20(off off off
+off off off off off off off off off on on on on off) #20(on on on on
+on on on on on on on on on off off on on on on off) #20(on off off off
+off off off off off off off off on off off on off off on off) #20(on
+on on on on on on on on on on on on on off on off off on off) #20(off
+off off off off off off off off off off off on on on on on on on off)
+#20(off off off off off off off on off off off off off off on on on on
+on off) #20(off off off off off off on on on on on on off off off on
+on on on off) #20(off off off on on on on on on on on on on on off off
+on on on off) #20(off off on off on on on on on on off off off on on
+off on on on off) #20(off off on off off off on on off off on off on
+off on off on) #20(off off on off on on on on on on off off on off on
+on on on on off) #20(off off on on on on on on off off off off off off
+on on off off on off) #20(off off on on on on on on on on on off off
+off on off off off on off) #20(off off on on on on on on on on on on
+off off on off off off on off) #20(off off off on on on on on on off
+on on off on on off off off on off))) (make-problem "Hattori 133"
+'((3) (3 4 1) (7 4 5) (11 4 2 1) (15 2) (13 2) (14) (11) (17) (20)
+(22) (24) (24) (5 13 2) (16 1) (18) (19) (10 10) (9 11) (9 6 5) (9 6
+4) (8 7 2) (7 6 1) (5 5) (3 3)) '((1 3 3) (2 4 6) (2 5 8) (4 6 8) (5 6
+9) (6 5 9) (6 5 9) (21) (20) (19) (1 16) (3 14 4) (17 7) (24) (23)
+(21) (17) (17) (2 11) (2 12) (2 4 7) (1 4 6) (1 4 5) (1 4 4) (3))
+'#25(#25(off off off on off off off off off off off on on on off off
+off off off off off off on) #25(off off off on on off off off off off
+on on on on off off off off off on) #25(off off off on on off off off
+off on on on on on off off off on) #25(off off on on on on off off on
+on on on on on off off on on on on on on on on off) #25(off off on on
+on on on off on on on on on on off on on on on on on on on on off)
+#25(off on on on on on on off on on on on on off on on on on on on on
+on on off) #25(off on on on on on on off on on on on on off on on on
+on on on on on on off) #25(off on on on on on on on on on on on on on
+on on on on on on on on off) #25(off off on on on on on on on on on on
+on on on on on on on on on on off) #25(off off on on on on on on on on
+on on on on on on on on on on on off) #25(on off off on on on on on on
+on on on on on on on on on on off) #25(on on on off on on on on on on
+on on on on on on on on off off off on) #25(on on on on on on on on on
+on on on on on on on on off on) #25(off on) #25(off on on on on on on
+on on on on on on on on on on on on on on on on on off) #25(off off
+off on on on on on on on on on on on on on on on on on on on on on
+off) #25(off off off off off off on on on on on on on on on on on on
+on on on on on off) #25(off off off off off on on on on on on on on on
+on on on on on on on on off) #25(off off off off on on off off on on
+on on on on on on on on on off) #25(off off off on on off off off on
+on on on on on on on on on on on off) #25(off off on on off off off
+off off on on on on off on on on on on on on off) #25(off off on off
+off off off off off on on on on off off on on on on on on off) #25(off
+off on off off off off off off off on on on on off off off on on on on
+on off) #25(off off on off off off off off off off off on on on on off
+off off off on on on on off) #25(off on on on off))) (make-problem
+"Hattori 134" '((4) (3 3 4) (2 2 6 5) (5 8 5) (2 1 8 3) (3 7 3) (4 7 3
+3) (5 5 5 1 1) (1 3 4 6) (1 4 4 6) (1 3 2 3 1) (1 4 1 3) (1 3 4) (1 7
+4) (1 3 2 2 2) (1 3 1 6) (1 7 4 2) (1 4 1 3 4) (1 2 12) (2 8 2 1) (3 1
+1 1 4 7) (14 2 5) (12 3 3) (8 4 2) (5)) '((2 2) (4 3) (1 20) (3 3 2)
+(8 4) (6 3) (7 4) (7 3) (7 4) (4 5 3) (8 1 3 3) (11 2 8) (10 4 4 1) (9
+1 5 1) (6 5 2) (1 5 2 4) (1 2 1 2 4) (2 2 4 2) (3 2 6) (3 4 4 4) (3 4
+3 6) (3 3 11) (12 1 2 2) (4 2 10) (14)) '#25(#25(off off on on off off
+off off off off off off off off off off off off off off on on off)
+#25(off on on on on off off off off off off off off off off off off
+off off on on on off) #25(off on off on on on on on on on on on on on
+on on on on on on on on on off) #25(off on on on off on on on off off
+off off off off off off off off off off off on on off) #25(off off on
+on on on on on on on off off off off off off off off off off on on on
+on off) #25(off off off off off off on on on on on on off off off off
+off off off off off on on on off) #25(off off off off off off off on
+on on on on on on off off off off off off on on on on off) #25(off off
+off off off off off off off on on on on on on on off off off off off
+on on on off) #25(off off off off off off off off off off off on on on
+on on on on off off on on on on off) #25(off off off on on on on off
+off off off off off on on on on on off off off on on on off) #25(off
+off on on on on on on on on off off off on off off on on on off off on
+on on off) #25(off on on on on on on on on on on on off on on off on
+on on on on on on on off) #25(off on on on on on on on on on on off
+off on on on on off off on on on on off on) #25(off on on on on on on
+on on on off off off off off off on off on on on on on off on) #25(off
+off on on on on on on off off off off off off off off on on on on on
+off off on) #25(on off on on on on on off off off off off off off off
+off off off on on off on) #25(on off off on on off off on off off off
+off off off off off off off on on off on) #25(on on off off off off on
+on off off off off off off off off off on on on on off on on off)
+#25(on on on off off off on on off off off off off off off off on on
+on on on on off) #25(off on on on off off on on on on off off off off
+off on on on on off on on on on off) #25(off on on on off off off on
+on on on off off off on on on off on on on on on on off) #25(off off
+on on on off off off on on on off on on on on on on on on on on on
+off) #25(off off on on on on on on on on on on on on off on off on on
+off on on off) #25(off off off on on on on off on on off on on on on
+on on on on on on off) #25(off off off off off on on on on on on on on
+on on on on on on off))) (make-problem "Hattori 135" '((1) (2 3 3) (9
+7) (3 3 2 5) (2 4 1) (2 1) (1 1 2 1) (1 2 1) (1 6) (1 1 2) (1 1 2 1)
+(1 4) (1 1) (1 2) (3 6) (4 7) (14) (1 14 3) (1 11 3) (2 6)) '((3) (2
+1) (3 2) (3 4) (2 3 5) (4 5) (3 5) (13 3) (2 5) (2 3 5) (2 1 6) (2 13)
+(6 5) (1 1 1 5) (2 3 2 3 1) (3 2 1) (4 1) (3 3) (2 3) (1 3))
+'#20(#20(off off off off off off off off off off off off off off off
+off off on) #20(off off off on on off off off off off off off off off
+off off off off off on) #20(off off on on on off off off off off off
+off off off off off on on off) #20(off on on on off off off off off
+off off off off off off on on on on off) #20(off on on off on on on
+off off off off off off off on on on on on off) #20(off off on on on
+on off off off off off off off off on on on on on off) #20(off off on
+on on off off off off off off off off off on on on on on off) #20(off
+on on on on on on on on on on on on on off off on on on off) #20(off
+on on off off off off off off off off off off off on on on on on off)
+#20(off on on off off off off off on on on off off off on on on on on
+off) #20(off off on on off off off off on off off off off on on on on
+on on off) #20(off off off on on off on on on on on on on on on on on
+on on off) #20(off off off off off off on on on on on on off off on on
+on on on off) #20(off off on off off off off off on off off on off off
+on on on on on off) #20(off off on on off off on on on off on on off
+off off on on on off on) #20(off on on on off off off off off off off
+off off off off off on on off on) #20(on on on on off off off off off
+off off off off off off off off off off on) #20(off on on on off off
+off off off off off off off off off off off on) #20(off off on on off
+off off off off off off off off off off off off on) #20(off off on off
+off off off off off off off off off off off off off on)))
+(make-problem "Hattori 136" '((11) (6 6) (6 5) (9 8) (6 4) (5 3 3 4)
+(5 1 1 1 1 4) (5 4) (2 4 2) (3 2 2) (1 1 9 3) (1 7 4 1 1) (1 3 4 1) (6
+2 2 2 1) (2 1 1 4) (9 6) (1 4 6) (1 4 2 2 1 1) (1 1 3 4 1) (4 7 4))
+'((4 5 1) (5 1 1 5) (6 3 1 1 1) (7 1 3 3) (8 7) (5 2 3 4) (4 4 4) (4 2
+2 3 2) (2 1 1 2 1 1 1 1) (1 1 2 1 1 1 1 1 1) (1 1 1 1) (1 1 1 1 1 1 1)
+(2 1 2 1 2 1 1 1 1) (2 1 1 2 3 2) (4 2 4 4) (4 2 3 2 1) (8 5 2) (7 3 1
+1 1) (6 1 1 4) (5 5 1)) '#20(#20(off off off off on on on on off on on
+on on on off off off off off on) #20(off off off on on on on on off on
+off off off on off on) #20(off off on on on on on on off on on on off
+on off on off off off on) #20(off on on on on on on on off off off on
+off on on on off on) #20(off on on on on on on on on off off on on on
+on on on on off) #20(on on on on on off off off on on off on on on off
+on on on on off) #20(on on on on off off off off off on on on on off
+off on on on on off) #20(on on on on off on on off off off on on off
+off on on on off on) #20(on on off on off on off off off off on on off
+on off on off on off on) #20(on off off on off on on off on off on off
+off on off on off on off on) #20(on off off off off off off off on off
+on off off off off off off off off on) #20(on off off off off off off
+off on off on off off on off on off on off on) #20(on on off on off on
+on off on off on on off on off on off on off on) #20(on on off on off
+on off off off off on on off off on on on off on) #20(on on on on off
+on on off off on on on on off off on on on on off) #20(on on on on off
+off off off on on off on on on off on on off on off) #20(off on on on
+on on on on on off off off on on on on on off on) #20(off on on on on
+on on on off off on on on off on off on off off on) #20(off off on on
+on on on on off off on off off off on off on) #20(off off off on on on
+on on off off on on on on on off off off off on))) (make-problem
+"Hattori 137" '((5 3) (3 3 2) (5 3) (4 1 4) (3 3 2) (8 1 1) (2 4 2 1
+1) (11 2 2) (4 3 8) (2 10 4) (10 5 1) (8 10) (5 9 3) (3 9 6) (10 6 2)
+(6 12) (3 10 3) (10 5) (6 4) (7)) '((5) (8) (10) (8 2 3) (6 10) (4 13)
+(11 2 4) (3 3 9 1) (3 15) (1 1 7 8) (1 2 7 2 1) (1 2 1 10) (2 4 7) (1
+8 4) (2 8 1) (2 2 8) (3 6 4) (2 1 6 2) (1 2 3 5) (1 11)) '#20(#20(off
+off off off off off off off off off off off off on on on on on off)
+#20(off off off off off off off off off off off on on on on on on on
+on off) #20(off off off off off off off off off on on on on on on on
+on on on off) #20(off off off off off on on on on on on on on off on
+on off on) #20(off off off on on on on on on off on) #20(off off on on
+on on off on) #20(off on on on on on on on on on on on off on on off
+on) #20(off on on on off on on on off on on on on on on on on on off
+on) #20(on on on off off on) #20(on off on off on on on on on on on
+off on) #20(on off off off on on off on on on on on on on off on on
+off on off) #20(on off off on on off off on off on on on on on on on
+on on on off) #20(on on off off off off on on on on off on on on on on
+on on off) #20(off on off off off on on on on on on on on off on on on
+on off) #20(off on on off off off off off on on on on on on on on off
+on off) #20(off off on on off off off on on off on on on on on on on
+on off) #20(off on on on off off on on on on on on off on on on on
+off) #20(on on off on off off off off on on on on on on off on on off)
+#20(on off off on on off off on on on off on on on on on off) #20(on
+off off off on on on on on on on on on on on off))) (make-problem
+"Hattori 138" '((6 1 1) (8 3 3 1) (3 2 1 2 5 2) (2 1 1 1 1 4 3 3) (1 1
+1 1 1 2 6) (1 1 1 4) (2 3 1 1 2) (2 2 1) (6 1 3) (7 1 1) (8 3 1 2) (2
+8 1) (2 3 3 6 1 2) (2 1 4 1 1 1) (2 5 4 1 1) (3 3 3 4 6) (8 4 1 1) (8
+5 6) (3 3 2 1) (3 3 2 4 4) (3 3 1 6 6) (3 3 2 2 2 2 2) (3 3 2 2 5 2)
+(8 8 6) (8 4 4)) '((7 16) (4 19) (3 3 10) (2 2 1 3 2 2) (2 1 6 9) (2 2
+1 5 10) (3 6 10) (7 2 4 2) (1 2) (6 2) (16 7) (1 6 3 1) (2 1 4) (2 1
+6) (2 6 2 2) (3 1 3 2 2) (3 1 3 6) (3 1 3 4) (3 1 1) (3 6 4) (3 1 1 1
+6) (3 8 1 2 2) (4 1 1 1 2 2) (4 1 1 1 8) (4 1 1 3 4)) '#25(#25(off on
+on on on on on on off on) #25(on on on on off off on) #25(on on on off
+off off off off on on on off off off off on) #25(on on off on on off
+on off on on on off off off off off on on off off off off off on)
+#25(on on off off off off on off on on on on on on off off on) #25(on
+on off on on off on off on on on on on off off on) #25(on on on off
+off off off on on on on on on off off on) #25(off on on on on on on on
+off off on on off off on on on on off off off off off on) #25(off off
+off off off off off off off off off on off on on off) #25(off off off
+off off off off off off off on on on on on on off off off off off on
+on off) #25(on on on on on on on on on on on on on on on on off on on
+on on on on on off) #25(off on off off off off off off off off on on
+on on on on off on on on off off off on off) #25(off on on off off off
+off off off off off off off off off off off on off off on on on on
+off) #25(off off on on off off off off off off off off off off off off
+off on off on) #25(off off off on on off off off off off off off on on
+on on on on off on on off off on) #25(off off on on on off off off off
+off off off on off on on on off off on on off off on) #25(off on on on
+off off off off off off off off on off on on on off off on) #25(on on
+on off off off off off off off off off on off on on on off off off on
+on on on off) #25(off on on on off off off off off off off off on off
+off off off off off off off off on off) #25(off off on on on off off
+off off off off off on on on on on on off off on on on on off) #25(off
+off off on on on off off on off off off off off off on off on off on)
+#25(off off off off on on on off on on on on on on on on off on off on
+on off off on) #25(off off off on on on on off on off off off off off
+off on off on off on on off off on) #25(off off on on on on off off
+off off on off on off off on off on) #25(off on on on on off off off
+off off on off on off off on on on off off on on on on off))))))
diff --git a/collects/games/paint-by-numbers/solution-sets/h31-60 b/collects/games/paint-by-numbers/solution-sets/h31-60
new file mode 100644
index 0000000000..337a9cb565
--- /dev/null
+++ b/collects/games/paint-by-numbers/solution-sets/h31-60
@@ -0,0 +1,731 @@
+(unit/sig paint-by-numbers:problem-set^ (import
+paint-by-numbers:problem^) (define set-name "Hattori 31 - 60") (define
+problems (list (make-problem "Hattori 31" '((8 7) (10 8) (10 9) (7 1
+9) (5 2 3) (4 4 3) (4 1 3) (4 1 2 3) (4 2 1 2 1) (4 1 1) (4 1 1) (3 1
+1 2) (3 1 2 1) (4 2) (4 1 3) (3 2 2) (3 1 2 2) (1 8 2) (19) (20))
+'((16 1) (17 2) (20) (11 2 2) (5 2) (4 2) (4 1 1 2) (3 2 3) (3 3) (3 3
+2 4) (4 5 3) (4 2 5) (3 1 1 4) (4 1 3) (4 3) (4 1 1 2) (4 2 2) (8 2 2)
+(8 1 1 3) (13 1 3)) '#20(#20(off on on on on on on on on on on on on
+on on on on off off on) #20(on on on on on on on on on on on on on on
+on on on off on) #20(on) #20(on on on on on on on on on on on off off
+on on off off off on) #20(on on on on on off off off off off off off
+off off off off off off on) #20(on on on on off off off off off off
+off off off off off off off off on) #20(on on on on off off off off on
+off off off on off off off off off on) #20(on on on off off off off on
+on off off off off off off off off on) #20(on on on off off off off
+off off off off off off off off off off on) #20(off on on on off off
+off off on on on off on on off off on) #20(off off off off on on on on
+off off off on on on on on off on) #20(off off on on on on off on on
+off off off off off off on) #20(off on on on off on off off on off off
+off off off off off on) #20(on on on on off on off off off off off off
+off off off off off on) #20(on on on on off off off off off off off
+off off off off off off on) #20(on on on on off off off off off off
+off on off off off off on off on) #20(on on on on off off off off off
+off off off off off off on on off on) #20(on on on on on on on on off
+off off off off off on on off off on) #20(on on on on on on on on off
+off off on off off on off off on) #20(on on on on on on on on on on on
+on on off on off off on))) (make-problem "Hattori 32" '((11 5) (11 7)
+(11 7) (9 2 2) (7 3 3) (7 3 3) (7 3 3) (1 1 3 3) (1 1 4 4) (2 2 4 4)
+(1 1 4 4) (2 2 4 4) (1 1 4 4) (1 3 1 4 4) (1 1 1 4 4) (2 1 2 3 3) (2 1
+2 3 3) (5 9) (3 9) (3 1 1)) '((3) (4 5) (7 3 2) (10 2) (7 1 3) (7 7)
+(7 1 3) (10 2) (7 3 2) (4 5) (3) (16) (18) (19) (3 7 2) (3 2) (3 7 2)
+(19) (18) (16)) '#20(#20(on on on off) #20(on on on on off off off off
+off off off on on on on on off) #20(on on on on on on on off off on on
+on off off off on on off) #20(on on on on on on on on on on off off
+off off off off on on off) #20(on on on on on on on off off off off
+off off on off off off on) #20(on on on on on on on off off off off
+off off on) #20(on on on on on on on off off off off off off on off
+off off on) #20(on on on on on on on on on on off off off off off off
+on on off) #20(on on on on on on on off off on on on off off off on on
+off) #20(on on on on off off off off off off off on on on on on off)
+#20(on on on off) #20(off off off off on) #20(off on on on on on on on
+on on on on on on on on on on on off) #20(on on on on on on on on on
+on on on on on on on on on on off) #20(on on on off off off off off on
+on on on on on on off off on on off) #20(on on on off off off off off
+off off off off off off off off off on on off) #20(on on on off off
+off off off on on on on on on on off off on on off) #20(on on on on on
+on on on on on on on on on on on on on on off) #20(off on on on on on
+on on on on on on on on on on on on on off) #20(off off off off on)))
+(make-problem "Hattori 33" '((1 1 1 1) (3 3 3) (3 1 5 5) (6 6) (6 1)
+(4 3 2) (4 4 4) (4 11) (17) (18) (18) (16 1) (16 1) (4 5 4) (2 6 2) (3
+2 2 1) (2 2 1 1) (1 1 1 1) (1 1 1 1) (2 2 2 2)) '((2) (3) (11) (14) (1
+11) (16) (9 1) (6 5) (9) (1 12 1) (2 16) (3 10) (2 9 1) (1 7 6) (1 9)
+(2 10 1) (3 14) (4 7) (3 3) (2 4)) '#20(#20(off off off on on off)
+#20(off off on on on off) #20(off off on on on on on on on on on on on
+off) #20(on on on on on on on on on on on on on on off) #20(off on off
+on on on on on on on on on on on off) #20(on on on on on on on on on
+on on on on on on on off) #20(off off off off off off off off on on on
+on on on on on on off off on) #20(off off off off off off off on on on
+on on on off off on) #20(off off off off off off on on on on on on on
+on on off) #20(off off on off off on on on on on on on on on on on on
+off off on) #20(off on on off on) #20(on on on off off on on on on on
+on on on on on off) #20(off on on off off off off on on on on on on on
+on on off off off on) #20(off off on off off off on on on on on on on
+off on) #20(off off off on off on on on on on on on on on off) #20(off
+off on on off on on on on on on on on on on off off off off on)
+#20(off on on on off off on) #20(on on on on off off off on on on on
+on on on off) #20(off on on on off off off off on on on off) #20(off
+off on on off off off off off on on on on off))) (make-problem
+"Hattori 34" '((10) (14) (13 1) (11 3) (14) (1 1) (15) (3 3 3 1 1) (1
+1 1 1 1 1) (1 1 1 2 3) (1 11 1 2) (1 2 1) (2 5 1 1) (2 3 2 1) (5 2 1)
+(1 4 5 1) (1 4 7 1) (1 16 1) (8 11) (6 10)) '((5) (6 1 2) (4 4 3) (1 5
+7) (2 1 1 6) (3 2 1 5) (4 3 1 1 4) (4 2 1 2 2) (5 1 2 2 1) (5 1 1 2 2)
+(5 2 1 1 4) (5 3 1 5) (5 2 1 5) (5 1 2 6) (5 4 7) (3 3 3 5) (3 6 4) (4
+1 3) (1 1 2 2) (3 10)) '#20(#20(off off off off off off off off off
+off off off off off on on on on on off) #20(off off off off off off
+off on on on on on on off on off off off on) #20(off off off off on on
+on on off off off off on on on on off on) #20(off off off off on off
+on on on on on off off on) #20(off off off on on off on off off off on
+off off off on) #20(off off on on on off on on off off on off off off
+off on) #20(off on on on on off on on on off on off on off off off on)
+#20(off on on on on off on on off off on off on on off off off on on
+off) #20(on on on on on off on off off on on off on on off off off on
+off) #20(on on on on on off on off off off on off on on off off off on
+on off) #20(on on on on on off on on off off on off on off off off on)
+#20(on on on on on off on on on off on off off off off on) #20(on on
+on on on off on on off off on off off off off on) #20(on on on on on
+off on off off on on off off off on) #20(on on on on on off on on on
+on off off off on) #20(on on on off on on on off off off off on on on
+off on) #20(on on on off off off on on on on on on off off off off on)
+#20(on on on on off off off off off on off off off off off off off on)
+#20(off on off on off off off off off on on off off off off off off
+off on) #20(off on on on off off off off off off on))) (make-problem
+"Hattori 35" '((3 3) (1 2 2 1) (1 4 2) (3 1 1 4) (4 3 2 2) (2 2 6 4 1)
+(8 11) (2 3 2 2 2 2) (5 2 3 3) (4 3 3 3) (1 2 3 2 1 1) (4 2 2 3) (2 1
+2 2 4) (5 1 1 3) (1 4 5) (3 3 4 2) (19) (3 3 5 3) (4 4 5) (13)) '((10)
+(5 3 2) (3 4 5) (2 9 3) (6 7) (8 3 2) (1 1 3 5) (2 2 5 2 1) (2 1 4 4)
+(8 1 2) (1 3 4) (8 4) (2 5 2 1) (1 1 5 5) (7 5 5) (6 3 2) (1 4 8) (4 7
+3) (1 4 7) (3 4 3)) '#20(#20(off off off off off off on on on on on on
+on on on on off) #20(off off off off off on on on on on off on on on
+off on on off) #20(off off off off on on on off on on on on off on on
+on on on off) #20(off off off on on off on on on on on on on on on off
+on on on off) #20(off off off on on on on on on off off off off on)
+#20(on on on on on on on on off off off off off off on on on off on)
+#20(on off off off off off on off off off on on on off off on) #20(on
+on off off off on on off off on on on on on off off on on off on)
+#20(off on on off off on off on on on on off off off off off on)
+#20(off off on on on on on on on on off off off off off off on off on)
+#20(off off on off on on on off off off off off off off off off on)
+#20(off on on on on on on on on off off off off off off off on) #20(on
+on off off off on on on on on off off off off off off on on off on)
+#20(on off off off off off on off on on on on on off off on) #20(on on
+on on on on on off off on on on on on off on) #20(off off on on on on
+on on off off off off off off on on on off on) #20(off off off on off
+on on on on off off off on) #20(off off off on on on on off on on on
+on on on on off on on on off) #20(off off off off on off on on on on
+off on on on on on on on off) #20(off off off off off on on on off on
+on on on off on on on off))) (make-problem "Hattori 36" '((3 3) (1 6
+1) (1 7) (1 1 2) (1 2 2 1 2) (1 1 1 1 1) (2 2 1) (2 2 1) (1 2 2 2 1)
+(1 2 2 1 1) (1 1 1) (4 3 1 1) (2 1 1 1 1 1) (13 1 1) (1 1 1) (2 4 1 1)
+(11 1 1) (1 4 5 1) (1 1 1 1 1 1 1) (5 5 6)) '((9) (2 3 2) (7 1 1 1 1)
+(1 2 3 4) (2 2 2 1 1 1) (1 1 1 1 1) (1 1 4) (1 1 2) (1 2 2 1 2 1) (2 1
+2 3 4) (1 1 1 1 1) (7 3 2 1) (1 2 1 1 3) (1 2 1 1) (1 8 3) (1 1 1) (1
+5) (2 1) (2 1) (16)) '#20(#20(off off off off off off off on on on on
+on on on on on off) #20(off off off off off off on on off off off on
+on on off on on off) #20(on on on on on on on off off off off on off
+on off off on off off on) #20(on off off off off off off off on on off
+on on on off off on) #20(on on off off on on off off on on off off off
+on off off on off off on) #20(off on off off on off off off off off
+off off off on off off on off off on) #20(off on off off off off off
+off off off off off off on off off on) #20(off on off off off off off
+off off off off off off on off off on on off) #20(off on off off on on
+off off on on off off off on off off on on off on) #20(on on off off
+on off off off on on off on on on off off on) #20(on off off off off
+off off off off off off on off on off off on off off on) #20(on on on
+on on on on off off off off on on on off on on off off on) #20(off off
+on off off off on on off off off off off on off on off on) #20(off off
+on off off off off on on off off off off off off on off on off)
+#20(off off on off off off off off on on on on on on on on off on)
+#20(off off on off off off off off off off off off off off off off off
+on off on) #20(off off on off off off off off off off off off off off
+off on) #20(off off on on off off off off off off off off off off off
+off off off off on) #20(off off off on on off off off off off off off
+off off off off off off off on) #20(off off off off on)))
+(make-problem "Hattori 37" '((6) (2 3) (10) (1 1 1 1) (1 1 1 1) (8) (3
+1 3) (15) (2 10 2) (1 8 1) (1 2 2 1 1) (2 1 2 9) (3 1 2 1 4 3) (1 2 2
+3 3) (4 5 2) (2 8 1 3) (1 5 2 2) (2 3 1 2) (9 1 2) (4 2 7)) '((4 5) (2
+2 2 3) (2 1 1 2) (3 5 2) (10 2 1) (3 1 3 1 1 2) (1 4 3 1 1 4) (1 1 5 3
+5) (1 4 3 1 2 2) (3 1 3 4) (3 1 10) (11 2) (1 3 4 4) (1 2 7 1) (1 3 1)
+(2 2 2) (4 5) (7 1) (5 1) (2)) '#20(#20(off off off off off off off
+off on on on on off off off on) #20(off off off off off off off on on
+off off on on off on on off on) #20(off off off off off off on on off
+off off off on off on off off off on) #20(off off off off off off on
+on on off on on on on on off off off on) #20(off on on on on on on on
+on on on off off off on on off off on off) #20(on on on off off on off
+on on on off off on off off on off on on off) #20(on off on on on on
+off on on on off on off on off on on on on off) #20(on off on off off
+on on on on on off on on on off on) #20(on off on on on on off on on
+on off off on off off on on off on) #20(on on on off off on off on on
+on off off off on on on on off) #20(on on on off off on off on on on
+on on on on on on on off) #20(off on on on on on on on on on on on off
+off on on off) #20(off off on off off off on on on off off on on on on
+off on) #20(off off on off off off on on off off on on on on on on on
+off off on) #20(off off off off off off off on off off off on on on
+off off off off off on) #20(off off off off off off off on on off off
+on on off off off off off on) #20(off off off off off off off off on
+on on on off off off on) #20(off off off off off off off off off off
+off on on on on on on on off on) #20(off off off off off off off off
+off off off on on on on on off off off on) #20(off off off off off off
+off off off off off off on on off))) (make-problem "Hattori 38" '((6
+6) (9 8) (3 5 3) (2 2 1) (1) (1) (2 1) (1 4) (9 3) (11 2) (14 2) (8 3
+2) (8 1 4 2) (8 5 3) (20) (12 7) (1 1 1 1 2 5) (1 1 1 1 3 4) (13 3)
+(16)) '((2 6 1) (3 11) (2 8 2) (3 12) (2 8 2) (2 12) (2 8 2) (2 12) (3
+3 2 2) (3 3 1 6) (2 1 4 6) (2 7 3) (3 5 2) (2 6 1) (2 5 1) (2 7) (2 2
+6) (3 3 6) (2 11) (2 10)) '#20(#20(off off off on on off off off off
+off on on on on on on off off on off) #20(off on on on off off off off
+off on) #20(off on on off off off off off on on on on on on on on off
+off on) #20(on on on off off off off off on) #20(on on off off off off
+off off on on on on on on on on off off on) #20(on on off off off off
+off off on) #20(on on off off off off off off on on on on on on on on
+off off on) #20(on on off off off off off off on) #20(on on on off off
+off off off on on on off off off on on off off on) #20(off on on on
+off off off off on on on off on off on) #20(off off on on off on off
+on on on on off off off on) #20(off on on off off off off off off on
+on on on on on on off on) #20(on on on off off off off off off off on
+on on on on off off off on) #20(on on off off off off off off off off
+on on on on on on off off off on) #20(on on off off off off off off
+off off off off on on on on on off off on) #20(on on off off off off
+off off off off off off off on) #20(on on off off off off on on off
+off off off off off on) #20(on on on off off off on on on off off off
+off on on on on on on off) #20(off on on off off off off on on on on
+on on on on on on on off) #20(off off on on off off on on on on on on
+on on on on off))) (make-problem "Hattori 39" '((2) (1) (10 9) (10 7
+1) (10 5 3) (8 8) (7 4 2) (7 2 2 4) (7 2 7) (2 1) (1) (1 4) (1 1 1) (1
+2 1 1 1) (2 2 1 4 1) (2 1 1 4 2) (3 4 1 1) (1 1) (1 2 2 1) (18)) '((15
+1) (8 3) (7 2 1) (7 2 1) (7 3 2) (7 2) (7 1) (4 1) (3 4 1) (1 3 2 1 1
+1) (2 2 1 3 1) (3 1 4 1) (4 1 3 1) (7 4 1) (7 1) (5 1 1) (2 4 2) (4 2
+1 2) (1 5 1 1) (8 6)) '#20(#20(off off on on on on on on on on on on
+on on on on on off on off) #20(off off on on on on on on on on off off
+off off on on on off) #20(off off on on on on on on on off off off off
+off off off on on off on) #20(off off on on on on on on on off off off
+off on on off off off off on) #20(off off on on on on on on on off off
+off off on on on off off on) #20(off off on on on on on on on off off
+off off off off off off off on) #20(off off on on on on on on on off
+off off off off off off off off off on) #20(off off on on on on off
+off off off off off off off off off off off off on) #20(off off on on
+on off off off off off off off on on on on off off off on) #20(on off
+on on on off off on on off off on off off off off on off off on)
+#20(on on off off off off off on on off off on off off on on on off
+off on) #20(off off on on on off off off off off off on off on on on
+on off off on) #20(off off on on on on off off off off off on off off
+on on on off off on) #20(off off on on on on on on on off off off on
+on on on off off off on) #20(off off on on on on on on on off off off
+off off off off off off off on) #20(off off on on on on on off on off
+off off off off off off off off off on) #20(off off on on off on on on
+on off off off off off off off off off on) #20(off off on on on on off
+on on off off off off off off off on off on) #20(off off on off on on
+on on on off off off off off off on off off off on) #20(off off on on
+on on on on on on off off off off on))) (make-problem "Hattori 40"
+'((8) (3 8) (3 1 4 2) (4 1 1 2) (1 1 1 1 3 4) (1 1 1 1 3) (1 1 1 1 1)
+(1 1 4) (2 1 1) (1 5 2 1) (3 1 3 3) (3 1 3 1) (3 2 3 3) (3 3 1) (1 1 1
+1 3) (1 5 1 1) (11 2) (1 1 3) (13 5) (13 6)) '((2) (5 3 4) (1 9 2) (2
+4 1 2) (1 2 3 2) (3 1 2 2) (1 4 2 2) (4 1 1 2 2) (1 2 3 2) (6 4 1 2)
+(1 8 2) (6 3 4) (3 2) (4) (5 4 1) (3 4 1 2) (2 1 1 5 2) (2 4 1 1 3) (3
+1 1 1 4) (3 1 5)) '#20(#20(off off off off off off off off off off off
+off off off off off off off on) #20(off off off off on on on on on off
+off on on on off off on) #20(off off off on off off off off on on on
+on on on on on on off on) #20(off off off on on off off off off off on
+on on on off off on off on) #20(off off off on off off off off off on
+on off off off on on on off on) #20(off off on on on off off off off
+on off off off off off on on off on) #20(off off on off off off off
+off off on on on on off off on on off on) #20(off on on on on off off
+off off on off off on off off on on off on) #20(off on off off off off
+off off off on on off off off on on on off on) #20(off on on on on on
+on off off off on on on on off off on off on) #20(off off off off on
+off off off off on on on on on on on on off on) #20(off off off off on
+on on on on on off on on on off off on) #20(on on on off off off off
+off off off off off off off off off off off on) #20(on on on on off)
+#20(on on on on on off off on on on on off off off off off off off off
+on) #20(on on on off on on on on off off on off off off off off off
+off on) #20(on on off off on off off on off off on on on on on off off
+off on) #20(on on off off on on on on off off off off on off on off
+off on) #20(on on on off off on off off off off off off on off on off
+on) #20(on on on off off on off off off off off off off off off on)))
+(make-problem "Hattori 41" '((6 1 3) (5 1) (3) (2) (2 2 2) (1 4 4) (2
+2 3 2) (5 6) (3 5) (2 3) (1 4 1) (1 2 3 3) (1 2 3 1) (2 2 1) (2 3) (2
+5) (1 5) (1 6) (1 1 1 1 1 1 1 6) (1 1 1 1 1 1 1 6)) '((6 10) (5 3) (3
+2) (2 2) (2 4 2) (1 2 2) (5 2 2) (3 3) (2 2) (4) (1 4 2) (2 3) (4 2)
+(6) (2 3 3) (5 5) (3 5) (1 2 6) (1 1 6) (2 9)) '#20(#20(on on on on on
+on off off off off on) #20(on on on on on off off off off off off off
+off on on on off) #20(on on on off off off off off off off off off off
+off off off off off on) #20(on on off off off off on on off) #20(on on
+off off off on on on on off off off off off off off off off on) #20(on
+off off off on on off on on off) #20(off off off off on on on on on
+off off on on off off off off off on) #20(off off off off off on on on
+off off on on on off) #20(off off off off off off off off off on on
+off off off off off off off on) #20(off off off off off off off off
+off on on on on off) #20(on off off off off off off off off off on on
+on on off off off off on) #20(off off off off off off on on off off
+off on on on off) #20(off off off off off on on on on off off off off
+off off off off off on) #20(off off off off on on on on on on off)
+#20(off off off off on on off on on on off off off off off off off on)
+#20(off off off off off on on on on on off off off off off on) #20(off
+off off off off off on on on off off off off off off on) #20(on off
+off off off off off off off off on on off off on) #20(on off off off
+off off off off off off off on off off on) #20(on on off off off off
+off off off off off on))) (make-problem "Hattori 42" '((9) (3 6) (3 1
+6) (4 1 1 4) (4 5) (6 1 7) (4 2 2 4) (3 6 3) (2 1 2 2 3) (1 1 1 1 2)
+(1 6 1) (1 4 2) (1 1 2) (3 2 2 3) (10 2 1) (9 1 1) (10 3 2) (15 1) (11
+2 1) (7 3)) '((2) (5 2) (7 4) (12 5) (6 7) (2 6 6) (1 2 2 2 6) (2 1 2
+10) (4 5 7) (3 3 2 6) (9 1 2 4) (6 2 3 3) (6 2 3) (10 2) (6 3) (4 2)
+(5) (2 2) (1 1 1) (7)) '#20(#20(off off off off off on on off) #20(off
+off off on on on on on off off off off off off off on on off) #20(off
+off on on on on on on on off off off off off on on on on off) #20(on
+on on on on on on on on on on on off on on on on on off) #20(on on on
+on on on off off off off off off on on on on on on on off) #20(on on
+off off off on on on on on on off off on on on on on on off) #20(on
+off on on off off on on off off on on off off on) #20(on on off off
+off on off on on off on) #20(on on on on off off off on on on on on
+off on) #20(on on on off off on on on off off on on off off on) #20(on
+on on on on on on on on off on off off on on off on) #20(on on on on
+on on off off on on off off on on on off off on) #20(off on on on on
+on on off off off off on on off off off off on) #20(off off on on on
+on on on on on on on off off off off off on on off) #20(off off off
+off on on on on on on off off off off off off on on on off) #20(off
+off off off off on on on on off off off off off off off on on off)
+#20(off off off off off off off off off off off off off off on on on
+on on off) #20(off off off off off off off off off off off off off on
+on off off off on) #20(off off off off off off off off off off off off
+off on off off on off off on) #20(off off off off off off off off off
+off off off off on))) (make-problem "Hattori 43" '((5) (3 3 3) (1 2 4
+1) (2 10) (1 1 3 1) (2 1 3 2 2 1) (2 1 5 1 1 1) (2 7 1) (3 7 3 2) (3 7
+3 2) (4 6 2 2) (4 7 2) (5 11) (5 1 4 3) (3 4 3 3 2) (4 2 3 2) (2 3 1)
+(2 2 1) (2 1) (5)) '((3 3) (3 4) (9) (8) (6 3) (5 9) (3 3 5) (1 5 1)
+(2 7 1 1) (1 10 1 1) (1 11 6) (13 2 1) (2 1 7 1) (3 1 3) (2 2 2 4) (2
+3 4) (3 2 3 1 2) (1 1 1 3) (3 7) (8 2)) '#20(#20(off off off off on on
+on off off off off off off off off on on on off) #20(off off off off
+off on on on off off off off off off on on on on off) #20(off off off
+off off off off on on on on on on on on on off) #20(off off off off
+off off off off on on on on on on on on off) #20(off off off off off
+off off off on on on on on on off off on on on off) #20(off off off on
+on on on on off off on on on on on on on on on off) #20(off on on on
+off off off on on on off off on on on on on off) #20(off on off off
+off off on on on on on off off off on off) #20(on on off off off off
+on on on on on on on off on off off off off on) #20(on off off off on
+on on on on on on on on on off on off off off on) #20(on off on on on
+on on on on on on on on off on) #20(on on on on on on on on on on on
+on on off on on off off off on) #20(on on off on off off off off on on
+on on on on on off off off off on) #20(off on on on off on off off off
+off off on on on off) #20(off off on on off on on off on on off on on
+on on off) #20(off off on on off off off off on on on off on on on on
+off) #20(off on on on off on on off on on on off on off on on off)
+#20(off on off on off on off off off off off on on on off) #20(off on
+on on off off off off on on on on on on on off) #20(off off off on on
+on on on on on on off off on on off))) (make-problem "Hattori 44"
+'((5) (5 6) (2 2 6 1) (6 6 2) (8 5 3) (2 1 1 5 5) (11 6) (4 5 7) (13)
+(9) (4 6) (5 3 4) (4 5 1 2) (2 4 3 3) (1 5 1 3) (6 2 3) (6 3 3) (5 3
+2) (4 3 1) (3 3)) '((4 4 4) (4 3 5) (2 2 3 6) (7 3 5) (4 1 3 5) (1 8
+5) (4 4 5) (4 8) (7) (6 2 4) (3 4 7) (3 6 5) (4 5) (5 2 2) (5 3 2) (4
+4 2) (4 4 3) (3 5 3) (2 5 3) (5 3)) '#20(#20(off off off off on on on
+on off off off on on on on off on) #20(off off off off on on on on off
+off off on on on off on) #20(off off off on on off on on off off on on
+on off on) #20(off on on on on on on on off off on on on off on on on
+on on off) #20(off on on on on off on off off on on on off on on on on
+on off) #20(off on off on on on on on on on on off on on on on on off)
+#20(off on on on on off on on on on off on on on on on off) #20(off on
+on on on off on on on on on on on on off) #20(off off off off off off
+on on on on on on on off) #20(off off off off off on on on on on on
+off on on off off on) #20(off off off off on on on off on on on on off
+on) #20(off off off on on on off off on on on on on on off on) #20(off
+off on on on on off on on on on on off) #20(off on on on on on off on
+on off off on on off) #20(on on on on on off on on on off off off on
+on off) #20(on on on on off on on on on off off off off on on off)
+#20(on on on on off on on on on off off off off on on on off) #20(on
+on on off on on on on on off off off off off on on on off) #20(on on
+off on on on on on off off off off off off off on on on off) #20(off
+off on on on on on off off off off off off off off off on on on off)))
+(make-problem "Hattori 45" '((8 3) (3 11) (9 1 3) (1 6) (2 7 2) (2 1
+4) (4 5 3) (3 5) (1 2 3 2) (1 6) (11 1) (3 5) (3 6 3) (4 6 4) (4 15)
+(3 7 4) (8 3) (1 2 5) (5 5) (4)) '((1) (1 1 1) (1 2 1) (2 3 2 3) (3 3
+1 1 1) (2 1 1 4 2) (2 1 1 6 1) (4 4 3 1) (4 4 6) (11 7) (8 8) (8 9) (2
+6 9) (2 1 3 9) (2 1 1 2 1 4) (2 1 1 3) (3 2) (1 1 1 5 1) (1 1 1 1 1 5)
+(1 1 1 1 1 1 5)) '#20(#20(off off off off off off off off off off off
+off off off on off) #20(off on off off off off on off off off off off
+off off on off) #20(off on off off off on on off off off off off off
+off on off) #20(off on on off on on on off off on on off off on on on
+off) #20(off off on on on off on on on off on off off on off on off)
+#20(off on on off off off off on off off on off on on on on off on on
+off) #20(off on on off off on off on off on on on on on on off off off
+on off) #20(on on on on off off off off off on on on on off on on on
+off on off) #20(on on on on off off off off on on on on off on on on
+on on on off) #20(on on on on on on on on on on on off on on on on on
+on on off) #20(on on on on on on on on off on on on on on on on on
+off) #20(on on on on on on on on off on on on on on on on on on off)
+#20(on on off on on on on on on off on on on on on on on on on off)
+#20(on on off off on off on on on off on on on on on on on on on off)
+#20(on on off off on off off off on off off on on off on off on)
+#20(off on on off on off off off off off off off off off on off off
+on) #20(off off off off off off off off off off off off off on on on
+off off on) #20(on off on off off off on off off off off off on on on
+on on off off on) #20(on off on off on off on off on off off off on on
+on on on off) #20(on off on off on off on off on off on off on on on
+on on off))) (make-problem "Hattori 46" '((5) (4 8) (15) (3 10) (2 9)
+(1 1 1 1 3 5) (1 1 6 2 4) (1 2 2 4 3) (4 4 3 1) (3 2 1 2 3 1) (1 1 4 3
+2) (1 2 2 1 2 2) (2 5 2 1) (3 6 1) (10 4 2) (6 5 1) (2 2 2) (2 2 2) (5
+6) (2 13)) '((10) (2 2 3) (2 1 3 2 1) (2 2 1 2 2) (2 3 2 2 1) (2 1 3 1
+5) (2 8 5) (2 3 3 2 2) (1 2 3 1 3 1) (3 2 1 2 2 1) (6 2 1 3 3) (14 1
+2) (12 3 2) (5 3 2) (5 2 3 2) (5 3 2 2) (6 1 1 1 1) (5 2 1) (5 3 1) (5
+3 1)) '#20(#20(off off off off on on on on on on on on on on off)
+#20(off off off on on off off off on on off off on on on off) #20(off
+off on on off off on off on on on off off on on off off off off on)
+#20(off off on on off off off on on off off on off off on on off off
+on) #20(off on on off off on on on off off off on on off on on off off
+on off) #20(off on on off off off on off on on on off on off on on on
+on on off) #20(off on on off off on on on on on on on on off on on on
+on on off) #20(off on on off off off on on on off on on on off on on
+off off on) #20(off off on off off on on off on on on off on off on on
+on off off on) #20(off on on on off off on on off off off on off on on
+off on on off on) #20(on on on on on on off on on off on off on on on
+off off on) #20(on on on on on on on on on on on on on on off on off
+off on) #20(on on on on on on on on on on on on off on on on off off
+on) #20(on on on on on off off off off off off off off on on on off
+off on) #20(on on on on on off off off off on on off off on on on off
+off on) #20(off on on on on on off off off on on on off off on on off
+off on) #20(off on on on on on on off off on off on off off off off
+off on off on) #20(off off off on on on on on off off off off off off
+off off on on off on) #20(off off off on on on on on off off off off
+off off on on on off off on) #20(off off off off off on on on on on
+off off on on on off off off off on))) (make-problem "Hattori 47"
+'((12) (2 3) (1 8 3) (1 3 3 2) (1 2 2 2) (1 2 2 2) (1 3 2) (11 3) (7
+7) (3 3) (3 2) (1 1) (3 1) (2 1 2 1 1) (6 2 1 1) (2 1 5 5 1) (2 1 1 1
+1 1 1 1) (2 1 1 2 1 1 1) (2 3 3) (2 2)) '((7) (7) (6 1) (2 1 4) (1 7
+1) (1 7 3) (1 2 5 1 2) (1 1 2 5 1 2 1) (1 1 2 4 1 2) (1 1 2 4) (1 1 2
+2) (1 2 1 2) (1 1 1 1) (1 1 2 4) (2 1 1) (1 1 3) (2 1 1) (1 3 4) (9 2)
+(17)) '#20(#20(off off off off off off off off off off off off off on)
+#20(off off off off off off off off off off off off off on) #20(off on
+on on on on on off off off off off off off on off) #20(on on off off
+off off off on off off off off off off on on on on off) #20(on off on
+on on on on on on off off off off off on off) #20(on off on on on on
+on on on off off off off off on on on off) #20(on off on on off off on
+on on on on off off off off on off on on off) #20(on off on off on on
+off on on on on on off on off on on off on off) #20(on off on off on
+on off on on on on off off off off on off on on off) #20(on off on off
+off off off on on off off off off off on on on on off) #20(on off on
+off off off off on on off off off off on on off) #20(on off on on off
+off off on off off off off on on off) #20(on off off on off off off on
+off off off off on off) #20(on off off on off off off on on off off
+off on on on on off) #20(on on off off off off off off on off off off
+off off off on off) #20(off on off off off off off off on off off off
+off off off on on on off) #20(off on on off off off off off on off off
+off off off off on off) #20(off off on off off off off on on on off
+off off off off on on on on off) #20(off off on on on on on on on on
+on off off off off off off off on) #20(off off off on))) (make-problem
+"Hattori 48" '((5 3) (10 1 1) (5 4) (3) (7 3) (14) (16) (5 4) (4 3) (3
+3 3 2) (1 1 3 2 2 1) (1 1 4 1 3 1) (1 1 4 1 3 1) (1 4 4 2) (1 3) (2 4)
+(3 6) (18) (16) (12)) '((1 10) (1 3 4) (1 4 3) (1 4 3) (1 3 2 3) (3 3
+1 1 3) (3 3 1 3 3) (3 3 5 3) (3 3 5 3) (3 3 3 3) (3 3) (3 4 3) (3 2 1
+3) (2 1 3 4) (2 5 4) (4 3 3) (6 4) (5 3 4) (1 2 3 4) (3 8))
+'#20(#20(off on off off off off off off on on on on on on on on on on
+off) #20(off on off off off off off on on on off off off off off on on
+on on off) #20(off on off off off off on on on on off off off off off
+off on on on off) #20(off on off off off on on on on off off off off
+off off off off on) #20(off on off off off on on on off off off on on
+off off off off on) #20(on on on off off on on on off off on off off
+on off off off on) #20(on on on off on on on off off on off on on on
+off off off on) #20(on on on off on on on off off on on on on on off
+off off on) #20(on on on off on on on off off on on on on on off off
+off on) #20(on on on off on on on off off off on on on off off off off
+on) #20(off off off off on on on off off off off off off off off off
+off on) #20(off off off off on on on off off off on on on on off off
+off on) #20(off off off off on on on off off on on off off on off off
+off on) #20(off off off off off on on off off on off on on on off off
+on) #20(off off off off off on on off off on on on on on off off on)
+#20(off off off off on on on on off off on on on off off off on on on
+off) #20(off off on on on on on on off off off off off off off on on
+on on off) #20(on on on on on off on on on off off off off off on on
+on on off) #20(on off on on off off off on on on off off off on on on
+on off) #20(on on on off off off off off on on on on on on on on
+off))) (make-problem "Hattori 49" '((2 2) (2 2) (3 3 3 3) (5 8 5) (3 3
+3 3) (2 1 1 4 1 1 2) (2 1 8 1 2) (1 2 2 1) (1 1 1 1 1 1 1 1) (2 2 1 1)
+(1 1 1 1 2 1 1) (2 1 1 1 1) (1 1 1 1) (1 4 1) (9) (7 7) (1 7 1) (13 1)
+(4 4) (5 5)) '((3) (7 1) (7 1 1 2) (1 5) (8 1 3) (1 1 3 1 3) (6 5 1)
+(1 4 4) (1 2 9) (1 2 1 5) (1 2 2 2 2) (1 2 1 5) (1 2 3 4) (9 4) (1 1 4
+1) (10 1 3) (1 1 2) (7 5) (7 1 1 2) (3 1)) '#20(#20(off off on on on
+off) #20(on on on on on on on off off off off off off off off off off
+off off on) #20(on on on on on on on off on off on off off off off off
+off off on) #20(off off off on off off off off off off off off off off
+off on) #20(off off on on on on on on on on off off off off off on off
+on) #20(off off on off on off off off off on on on off off off on off
+on) #20(off off on on on on on on off off off on on on on on off on
+off) #20(off off off on off off on on on on off off off off on on on
+on off) #20(off off off on off on on off off on on on on on on on on
+on off) #20(off off off on off on on off on off off off off on on on
+on on off) #20(off off off on off on on off off off on on off on on
+off on on off) #20(off off off on off on on off on off off off off on
+on on on on off) #20(off off off on off off on on off off on on on off
+on on on on off) #20(off off on on on on on on on on on off off off on
+on on on off) #20(off off on off on off off off off off off off on on
+on on off on off) #20(off off on on on on on on on on on on off off
+off on off on) #20(off off off on off off off off off off off off off
+off off on off off on) #20(on on on on on on on off off off off off
+off off off on) #20(on on on on on on on off on off on off off off off
+off off off on) #20(off off on on on off off off off off off off off
+off off off off off off on))) (make-problem "Hattori 50" '((1 1) (1 1)
+(2 15 1) (3 2 2) (3 1 4 2) (2 5 1) (2 1 3 3 1) (1 7 2) (1 1 5 1) (2 1
+6) (3 9) (5 5 3) (6 4 3) (4 2 5) (1 2 1 6) (2 1 3 6) (1 2 4 6) (1 3 3
+6) (2 1 3 3 1) (4 2 2)) '((8 3) (5 2 2) (2 1 1 1 3 1) (1 1 4 3) (1 6
+3) (1 1 1 3 1) (1 1 1 4) (1 2 4) (1 5 2) (1 6 4) (1 1 6 5) (1 2 8 4)
+(5 6) (6 4 5) (1 5 1 6) (1 9) (1 8) (1 7) (2 5 1) (7 2)) '#20(#20(on
+on on on on on on on off off off off off off off off off on) #20(off
+off on on on on on off off off off off off off on on off off on)
+#20(off off off on on off off off on off on off on off off on on on
+off on) #20(off off on off off off on off off on on on on off off off
+off on) #20(off off on off off off off off on on on on on on off on on
+on off) #20(off off on off on off off on off off off on on on off off
+on off) #20(off off on off off off off on off on off on on on on off)
+#20(off off on off off off on on off off off on on on on off) #20(off
+off on off off off on on on on on off off off off on on off) #20(off
+off on off off off on on on on on on off off off on on on on off)
+#20(off off on off off on off on on on on on on off off on) #20(off
+off on off on on off on on on on on on on on off on) #20(off off on on
+on on on off on on on on on on off) #20(off off on on on on on on off
+on on on on off on on on on on off) #20(off off on off on on on on on
+off on off off on on on on on on off) #20(off off on off off off off
+off off off on on on on on on on on on off) #20(off off on off off off
+off off off off on on on on on on on on off) #20(off off on off off
+off off off off off off on on on on on on on off) #20(off off off on
+on off off off off off off off off on on on on on off on) #20(on on on
+on on on on off off off off off off off off off off off on)))
+(make-problem "Hattori 51" '((1 1 3 3) (4 2 4) (6 6) (3 1 7) (1 2 1 8)
+(3 2 1 8) (2 1 8) (4 1 9) (2 1 13) (2 1 2 6) (1 3 1 2) (1 3 2 1) (4 2
+1) (2 3) (3 2) (7) (1 1) (2 1 2) (4 1) (5)) '((1 1 3) (1 5) (8) (2 7)
+(3 2 3) (2 2 1 1 1) (1 1 2 2 2) (9 1 1 1) (2 1 2 4) (1 1 1 2) (3 1 1)
+(3 5) (5 2 1 1) (7 2 1) (10 2) (10 3) (12) (9) (9) (10)) '#20(#20(off
+off off on off on off on on on off) #20(off off off on off on on on on
+on off) #20(on on on on on on on on off) #20(off on on off off off off
+on on on on on on on off) #20(on on on off on on off off off off off
+off on on on off) #20(off on on off on on off off off off off off on
+off on off off on off) #20(on off on off off off off off off off off
+on on off on on off on on off) #20(on on on on on on on on on off off
+on off off off on off off on off) #20(on on off off off off off off on
+off on on off off off on on on on off) #20(off off off off off off off
+off on off on off off off off on off off on) #20(off off off off off
+off off off on on on off off off off on off off off on) #20(off off
+off off off off off on on on off off off off off on) #20(off off off
+off on on on on on off off off off off on on off on off on) #20(off
+off on on on on on on on off off off off on on off off off off on)
+#20(on on on on on on on on on on off off on on off) #20(on on on on
+on on on on on on off on on on off) #20(on on on on on on on on on on
+on on off) #20(off on on on on on on on on on off) #20(off off on on
+on on on on on on on off) #20(off off off on on on on on on on on on
+on off))) (make-problem "Hattori 52" '((5 6) (2 4 2) (2 6 2) (2 2 2 2)
+(2 2 2 1 1) (1 2 2 2 1 1) (1 2 2 1 2 1) (1 2 3 5 4) (1 3 2 1 1 1) (1 8
+4 1) (1 3 1 3 1) (1 2 1 1 1 1) (1 1 2 2 2 1) (1 13 1) (7 2 1 1) (3 2
+1) (2 2 3 2) (2 1 1 2 3) (4 1 1) (2 1 1)) '((12) (2 3) (2 7) (2 3 2 2
+2) (2 5 2 2) (1 7 1 2) (1 3 1 3 3) (1 5 1) (2 7) (5 1 2) (10 2) (3 1 2
+3 1) (1 1 2 1 1 1 2) (1 1 2 1 1 1 1) (1 2 2 1 2 2) (2 4 1 1 1 1) (2 1
+1 1) (2 3 3) (5 2) (13)) '#20(#20(off off off off on on on on on on on
+on on on on on off) #20(off off off on on off off off off off off off
+off off on on on off) #20(off off on on off off off off off off off on
+on on on on on on off) #20(off on on off off off on on on off on on
+off on on off off on on off) #20(on on off off off off on on on on on
+off off on on off off off on) #20(on off off off off off off off on on
+on on on on on off on off on) #20(on off off off off on on on off on
+off off on on on off on on on off) #20(on off off off off on on on on
+on off off off on off) #20(on on off off off off off on on on on on on
+on off) #20(off on on on on on off off off on off off on on off)
+#20(on on on on on on on on on on off off off on on off) #20(on on on
+off off off off on off on on off off on on on off on off) #20(on off
+on off on on off on off off on off off on off on on off) #20(on off on
+off on on off on off off on off off on off off on off) #20(on off on
+on off off on on off on off off on on off off on on off) #20(on on off
+on on on on off off on off off on off on off off on off) #20(off on on
+off off off off on off on off on off) #20(off off on on off off off on
+on on off off off off off off off on) #20(off off off on on on on on
+off off off off off off off off on on off) #20(off off off off off off
+off on))) (make-problem "Hattori 53" '((1 1 1) (3 1 1 1) (1 3 3 3) (4
+4 1) (11) (4 4 3) (1 1 2 1 2 1 1 1 1) (4 3 3 3) (2 4 4 4 1) (1 1 2 1 2
+1 2 2) (4 3 3 3) (18) (2 2) (1 1 1 1 1 1 1 1) (15) (3 3) (3 4 3 3) (2
+2 2 3) (2 1 3 1 3 1 2) (1 2 1 1 1 2 1)) '((1 5 4) (3 2 3 4) (1 2 8) (1
+2 2 2 2) (3 2 1 2 2 1) (4 2 1 1 1 2) (4 2 2 2 1 1) (4 2 3 1 1 2) (1 4
+2 2 2) (3 2 1 1 2) (1 5 2 1 2) (5 2 2 1 2) (3 2 3 2 1 1) (3 2 2 1 1 2)
+(3 2 1 2 2 1) (1 2 1 2 2) (1 3 7) (3 1 4 3) (1 6 3) (3)) '#20(#20(off
+on off off off off on on on on on off off off off off on) #20(on on on
+off off off off on on off on on on off off on on on on off) #20(off on
+off off off off on on off on on on on on on on on off) #20(off off off
+off off on off on on off on on off off on on off on on off) #20(off
+off off off on on on off on on off on off on on off on on off on)
+#20(off off off on on on on off on on off on off off on off on off on)
+#20(off off on on on on off on on off on on off on on off on off on
+off) #20(off on on on on off on on off on on on off off on off on off
+on) #20(on off on on on on off on on off on on off on on off) #20(off
+off off off on on on off on on off on off off on off off off on)
+#20(on off on on on on on off on on off on off on on off) #20(off on
+on on on on off on on off on on off off on off off off on) #20(off off
+on on on off on on off on on on off on on off on off on off) #20(off
+off off on on on off on on off on on off off on off on off on) #20(off
+off off off on on on off on on off on off on on off on on off on)
+#20(off off off off off on off off on on off on off off on on off on
+on off) #20(off off on off off off on on on off on on on on on on on
+off) #20(off on on on off off off on off on on on on off off on on on
+off) #20(off off on off off off on on on on on on off off off off on
+on on off) #20(off off off off off off off off off off off off off off
+off off off on))) (make-problem "Hattori 54" '((3 3) (7 1 1 1 1) (2 2
+3 3) (2 2 1 1) (2 3 2 2 1) (1 2 2 1 1 1) (1 2 2 2 1 1) (1 1 1 2 1 4)
+(1 1 3 1 7) (1 1 1 2 2 6) (1 1 2 1 1 8) (1 2 1 3 5) (2 2 2 2 6) (1 3 1
+7) (2 1 7) (3 10) (14) (12 1) (12 2) (12 4)) '((9 1) (2 3 1) (2 6 2 2)
+(2 2 2 1 2) (1 2 3 2 2 2) (1 1 2 1 1 4) (1 2 2 2 4) (1 2 4 4) (1 2 4)
+(2 3 5) (2 11) (2 2 5) (3 2 5) (3 3 1 6) (1 3 3 6) (3 14) (11 1) (3 10
+1) (1 14 2) (3 6 3)) '#20(#20(off off off off on on on on on on on on
+on off off off off off off on) #20(off off off on on off off off off
+off off off on on on off off off off on) #20(off off on on off off on
+on on on on on off off on on off off on) #20(off on on off off on on
+off off off off on on off off on off off on) #20(off on off off on on
+off off on on on off on on off on on off on) #20(off on off off on off
+off on on off on off off on off off on) #20(off on off off on on off
+off on on off off on on off off on) #20(off on off off off on on off
+off on on on on off off off on) #20(off on off off off off on on off
+off off off off off off off on) #20(off on on off off off off on on on
+off off off off off on) #20(off off on on off off off off off on)
+#20(off off off on on off off off off off off on on off off on)
+#20(off off off off on on on off off off on on off off on on on on on
+off) #20(on on on off off off on on on off on off off on on on on on
+on off) #20(on off on on on off off off on on on off on on on on on on
+off) #20(on on on off on on on on on on on on on on on on on on off)
+#20(off off off off off off off on on on on on on on on on on on off
+on) #20(on on on off off off off on on on on on on on on on on off off
+on) #20(on off on on on on on on on on on on on on on on off off on)
+#20(on on on off off off off off on on on on on on off off off on)))
+(make-problem "Hattori 55" '((2 4 2) (4 7 4) (1 14 1) (1 11 1) (2 11
+2) (1 2 4 1 1) (1 3 4 2 2) (2 11 1) (1 9 1) (1 13 1) (1 1 7 3) (5 6 1)
+(1 2 5 2) (3 2 3 2 1) (1 1 3 1) (2 1 5 1) (2 1 5 1 1) (1 1 1 1) (1 1 1
+1 1 1 1 1) (7 7)) '((4 5 2) (2 4 1 4) (2 1 1) (2 9) (1 3 1) (6 1 2) (8
+1 1 1) (4 5 2 2 2) (5 6 2 1) (12 5) (17) (16) (14 4) (4 6 1) (3 4 2 2)
+(6 1 1 1) (2 1 2) (1 3 1) (2 3 1 8) (5 5)) '#20(#20(off on on on on
+off off on on on on on off off off on on off) #20(on on off off on on
+on on off off off on off on on on on off) #20(on on off off off off
+off off off off off on off on off) #20(off on on off off off off off
+off off off on) #20(off off on off off off off off off on on on off
+off off off off off off on) #20(off off on on on on on on off on off
+off off off off off off off on) #20(off off on on on on on on on on
+off off off on off off on off off on) #20(off on on on on off on on on
+on on off on on off on on off on) #20(on on on on on off off on on on
+on on on off off on on off off on) #20(on on on on on on on on on on
+on on off off off on) #20(on on on on on on on on on on on on on on on
+on on off) #20(on on on on on on on on on on on on on on on on off)
+#20(off on on on on on on on on on on on on on on off on) #20(off on
+on on on off off on on on on on on off off off off off off on) #20(off
+off on on on off on on on on off off on on off off off off on) #20(off
+off on on on on on on off on off off off on off off off off off on)
+#20(off on on off off off off off off on off off off off off off off
+off on) #20(off on off off off off off off off off on on on off off
+off off off off on) #20(on on off off on on on off off off on off on)
+#20(on on on on on off on on on on on off))) (make-problem "Hattori
+56" '((2 3) (2 4) (2 5) (8) (11) (2 7) (4 1 2 4) (11 1) (2 9 1) (1 8
+1) (1 6 2) (1 6 1) (1 8 1) (8 1 2 3) (7 2 1 2) (5 1 3) (1 2) (2 2 1)
+(4 1) (2)) '((6) (2 2) (2 4 1) (10 2) (10 1) (10 1) (9 2) (10 1) (2 6)
+(1 3 3) (1 4 6) (8 1) (6) (1 4 4) (9 4) (7 2) (7 2) (6 2) (4 1) (1))
+'#20(#20(off off off off off off off off on on on on on on off)
+#20(off off off off off off off on on off off off off on on off)
+#20(off off off off off off on on off off off off on on on on off on
+off) #20(off off off off off off on on on on on on on on on on off on
+on off) #20(off off off off off off on on on on on on on on on on off
+off on off) #20(off off off off off off on on on on on on on on on on
+off off on off) #20(off off off off off off off on on on on on on on
+on on off on on off) #20(off off off off off on on on on on on on on
+on on off off on off) #20(off off off off on on off on on on on on on
+off) #20(off off off off on off off on on on off off on on on off)
+#20(off off off off on off on on on on off off off off on) #20(off on
+on on on on on on on off off off off off off off off off off on)
+#20(on on on on on on off) #20(on off off on on on on off off off on
+on on on off) #20(off off on on on on on on on on on off off on on on
+on off) #20(on on on on on on on off off off off off off off off on on
+off) #20(on on on on on on on off off off off off off off on on off)
+#20(on on on on on on off off off off off off off on on off) #20(off
+on on on on off off off off off off off off on off) #20(off off off
+off off off off off off off off off off on off))) (make-problem
+"Hattori 57" '((2 6) (3 1 1 4) (3 2 3 3) (6 7) (6 2) (5 2 2 3) (3 1 2
+1 3) (3 1 1 2 2) (11 2 1) (4 3 5) (1 2 9 3) (2 6 5 1) (5 3 3 1) (1 5 3
+1) (1 2 2 5) (9 3 1) (2 2 3 1) (2 14 1) (2 2 2) (2 2 3)) '((2 3 2) (4
+1 2 4) (6 1 2 2 2) (7 2 1 2 1) (5 2 1 2 1 2) (2 3 1 1 1 1 3) (1 3 1 1
+1 1 1 1) (2 1 6 1) (2 10) (1 6 3) (1 4 1) (1 1 1 1) (2 1 4 1) (1 2 2 4
+1) (1 2 7 2) (1 1 2 9 1) (2 1 1 2 7 1) (4 2 1 2 2 3) (6 1 1 2 1) (5 2
+3 4)) '#20(#20(off off off off off off off off off on on off on on on
+off on on off) #20(off off off on on on on off off on off on on off
+off on on on on off) #20(off off on on on on on on off on off on on
+off on on off off on) #20(off on on on on on on on off on on off on
+off on on off off off on) #20(off on on on on on off on on off on off
+on on off on off on on off) #20(on on off on on on off off on off off
+on off on off on off on) #20(on off on on on off off off on off off on
+off on off on off on off on) #20(off on on off off off off off on off
+on on on on on on off on off) #20(off off off off off on on off on on
+on on on on on on on on off) #20(off off off off off on off on on on
+on on on off off on on on off) #20(off off off off off off on off on
+on on on off off off off off on off) #20(off off off off off off on
+off on off on off off off off off off on off) #20(off on on off off on
+off on on on on off off off off off off on off) #20(on off on on off
+on on off on on on on off off off off off on off) #20(on off on on off
+off off on on on on on on on off off on on off) #20(on off off on off
+off on on off on on on on on on on on on off on) #20(on on off on off
+off on off on on off on on on on on on on off on) #20(on on on on off
+on on off on off on on off off on on off on) #20(on on on on on on off
+on off off on off off on on off off off on off) #20(off on on on on on
+off on on off on on on off on on on on off))) (make-problem "Hattori
+58" '((1 2 2) (1 2 1) (5 3) (4 2) (3 1) (3 1) (7 2 1) (1 8 6) (3 9) (3
+6 2 3) (9 8) (5 6 1) (2 8 1) (10) (12) (1 8) (1 9) (1 2 4) (1 2) (2
+4)) '((3 2) (2 1) (1 2 3) (5 2) (5 2) (4 2 1) (7 6) (1 7 1) (3 9) (2 6
+2 3) (9 8) (4 6 1) (2 7 1) (10 1) (11) (2 8) (2 9) (1 2 5) (1 2) (2
+3)) '#20(#20(on on on off off off off on on off) #20(off off on on off
+off off off on off) #20(on off on on off off off off on on on off)
+#20(on on on on on off off off off on on off) #20(off on on on on on
+off off off on on off) #20(off off off off on on on on off off on on
+off off off off off off off on) #20(off off off off off on on on on on
+on on off off on) #20(on off off off off off on on on on on on on off
+on off) #20(on on on off off off on on on on on on on on on off)
+#20(off off on on off off on on on on on on off on on off on on on
+off) #20(off off on on on on on on on on on off on) #20(off off off
+off off off on on on on off on on on on on on off off on) #20(off off
+off off off off off on on off on on on on on on on off off on) #20(off
+off off off off off off off on on on on on on on on on on off on)
+#20(off off off off off off off on on on on on on on on on on on off)
+#20(off off off off off off on on off off on on on on on on on on off)
+#20(off off off off off off on on off on on on on on on on on on off)
+#20(off off off off off off off on off on on off on on on on on off)
+#20(off off off off off off off on off on on off) #20(off off off off
+off off on on off off on on on off))) (make-problem "Hattori 59" '((6)
+(2 2) (2 2 6) (1 2 2 1 2 2) (1 1 1 1 1 1) (1 2 8) (2 2 2 1 1) (8 1 2)
+(3 3 2 1) (3 2 1 2) (2 2 1 1) (1 14) (2 3 4) (1 2 4) (1 2 2 4) (4 3 4)
+(3 4 4) (3 4 4) (9 3) (3 4 2)) '((5 2) (2 2 2) (2 1 3) (1 2 4) (1 3 9)
+(1 2 1 2 5) (1 1 1 1 5) (2 3 1 2 1) (2 7 1 1) (4 4 4) (2 5) (12) (6 9)
+(2 1 1) (1 1 9) (1 1 9) (1 1 8) (1 1 9) (2 1 3) (5)) '#20(#20(off off
+on on on on on off off off on on off) #20(off on on off off off on on
+off on on off) #20(on on off on off off off on on on off) #20(on off
+off on on off on on on on off) #20(on off off off off off on on on off
+off on) #20(on off off on on off off on off off off on on off off on)
+#20(on off off on off off off on off off off on off off off on) #20(on
+on off off off off on on on off off on off off on on off off on off)
+#20(off on on off off on on on on on on on off off on off off off on
+off) #20(off off on on on on off off on on on on off off off off on)
+#20(off off off off off off off off off off off on on off off on)
+#20(off off off off off off off off on) #20(off off off on on on on on
+on off off on) #20(off off on on off on off off off off off on off)
+#20(off off on off off on off off off off off on) #20(off off on off
+off on off off off off off on) #20(off off on off off on off off off
+off off on on on on on on on on off) #20(off off on off off on off off
+off on on on on on on on on on off) #20(off off on on off on off on on
+on off) #20(off off off on on on on on off))) (make-problem "Hattori
+60" '((3) (2 2 6) (1 1 3 8) (2 2 2 9) (2 2 1 1 10) (1 1 2 2 1 4) (2 2
+2 5 3) (3 1 3 1 1 1 1 1) (2 2 4 1 3 1) (1 1 5 1 1) (5 1 1 1) (1 1 3 2)
+(2 1 4 1) (2 1 3) (2 1 1) (2 3 5) (2 1 1 3) (5 1 8) (1 10) (2 9)) '((3
+3) (4 3 3) (2 1 1 1 2 2) (1 1 1 3 1 2) (2 4 3 2 3) (3 1 1 1 3 1) (1 1
+1 2 2) (2 5 1) (3 11) (2 1) (1 4) (9 2) (3 1 1 3) (3 3 5 3) (4 1 1 2 1
+3) (4 3 2 1 3) (5 1 1 3) (7 5) (6 1 4) (12 4)) '#20(#20(off off off
+off on on on off on on on off) #20(off on on on on off on on on off on
+on on off) #20(on on off on off on off on off on on off on on off)
+#20(on off on off on off on on on off on off off on on off) #20(on on
+off on on on on off on on on off off off on on off on) #20(off on on
+on off on off on off on off off off off off on on on off on) #20(off
+off on off on off on off on on off off off off off off on on off)
+#20(off off on on off on on on on on off off off off off off off on
+off) #20(off off off on on on off on on on on on on on on on on on
+off) #20(off off off off off off off on on off off off off off off on
+off) #20(off off off off on off off off off off off off off off off on
+on on on off) #20(off off off on on on on on on on on on off off off
+off off off on) #20(off off on on on off on off off off off on off off
+off off off on) #20(off off on on on off on on on off off on on on on
+on off on) #20(off on on on on off on off on off off off on on off on
+off on) #20(off on on on on off on on on off off off on on off on off
+on) #20(off on on on on on off off off off off off on off off on off
+on) #20(off on on on on on on on off off off off off off off on)
+#20(off on on on on on on off off off off on off off off off on)
+#20(off on on on on on on on on on on on on off off off on))))))
diff --git a/collects/games/paint-by-numbers/solution-sets/h61-90 b/collects/games/paint-by-numbers/solution-sets/h61-90
new file mode 100644
index 0000000000..5c62d04c67
--- /dev/null
+++ b/collects/games/paint-by-numbers/solution-sets/h61-90
@@ -0,0 +1,730 @@
+(unit/sig paint-by-numbers:problem-set^ (import
+paint-by-numbers:problem^) (define set-name "Hattori 61 - 90") (define
+problems (list (make-problem "Hattori 61" '((6) (2 3) (5 1 3) (6 4)
+(10) (11) (1 8) (1 7) (1 5 1) (1 5 3) (2 5 4) (3 4 5) (4 4 6) (5 4 5)
+(5 3 5) (3 2 2 5) (1 2 5) (2 5) (2 7) (11 2)) '((1) (2) (2) (2 5) (4
+5) (6 6 1) (1 11 1) (1 1 2 3 1) (1 2 2 1) (7 3 2 1) (7 5 3) (14 2) (13
+1) (7 3 2) (5 2 2) (4 10) (2 10) (12) (11) (8)) '#20(#20(off off off
+on off) #20(off off on on off) #20(off off on on off) #20(off off on
+on off off off off off off off off on on on on on off) #20(off on on
+on on off off off off off off on on on on on off) #20(on on on on on
+on off off off off on on on on on on off off off on) #20(on off off
+off on on on on on on on on on on on off off off off on) #20(on off on
+off on on off off off off off off off on on on off off off on) #20(on
+off off off on on off off off off off off off off off on on off off
+on) #20(on on on on on on on off off off on on on off off off on on
+off on) #20(on on on on on on on off off on on on on on off off off
+on) #20(off on on on on on on on on on on on on on on off off off on)
+#20(off off off on on on on on on on on on on on on on off off off on)
+#20(off off off off on on on on on on on off off on on on off off on)
+#20(off off off off off on on on on on off on on off off off off off
+on) #20(off off off off off on on on on off on) #20(off off off off
+off off on on off on on on on on on on on on on off) #20(off off off
+off off off off on on on on on on on on on on on on off) #20(off off
+off off off off off off off on) #20(off off off off off off off off
+off off off off on))) (make-problem "Hattori 62" '((3 5 2) (1 3 1 1 3)
+(2 3 1 1 3) (1 2 1 3) (1 1 2 4) (2 3 1 4) (2 1 5) (5 1 5) (3 1 2 2 5)
+(9 2 5) (8 1 5) (5 2 2 5) (4 1 2 5) (2 1 1 1 1 5) (1 8 1 7) (5 1 2 6)
+(1 1 1 6) (1 1 6) (1 4 2 4) (4 1)) '((6) (6 1) (2 5 2) (12 1) (4 1 3 2
+2) (1 1 4 4 1) (2 1 1 3 1 2) (1 2 5 3 1) (2 1 2 1 2) (1 2 1) (3 1) (1
+1 3 3) (1 2 2 2 2 1) (1 5 3 3) (5 4) (13) (15) (18) (19) (17))
+'#20(#20(off off off off off off off off off on on on on on on off)
+#20(off off off off off off off off on on on on on on off on off)
+#20(off off off off off on on off on on on on on off on on off)
+#20(off off off off on on on on on on on on on on on on off off off
+on) #20(on on on on off off off on off on on on off off on on off off
+on) #20(on off on off off off off on on on on off off off on on on on
+off on) #20(on on off off off on off on off on on on off off on off
+off off on) #20(off on off off on on off on on on on on off off on on
+on off on off) #20(off on on off off on off off on on off off off off
+on off off on on off) #20(off off on off off off off off off off off
+off off on on off off off on off) #20(on on on off off off off off off
+off off off on off) #20(on off off on off off off off off on on on off
+on on on off) #20(on off on on off off off off on on off on on off off
+on on off on off) #20(on off off off on on on on on off off off on on
+on off off on) #20(on on on on on off off off off off off off off off
+on on on on off) #20(off off off off off off on on on on on on on on
+on on on on on off) #20(off off off off on on on on on on on on on on
+on on on on on off) #20(off on on on on on on on on on on on on on on
+on on on on off) #20(on on on on on on on on on on on on on on on on
+on on on off) #20(on on on on on on on on on on on on on on on on on
+off))) (make-problem "Hattori 63" '((5) (7) (1 1) (2 2) (1 1) (1 1 1)
+(7) (9) (2 4 2) (16) (3 4 3) (5) (3 2) (2 2) (2 2) (3 2) (1 3 1) (20)
+(1 1) (1 1)) '((1 4) (1 1) (2 1) (1 1) (1 1) (2 1) (3 1 1) (1 2 1 4 1)
+(8 1 5 1) (2 1 7 1) (2 7 2) (2 1 12) (18) (1 2 1 1) (3 1) (2 1) (1 1)
+(2 1) (1 1) (1 4)) '#20(#20(off off off off off off off off off off on
+off off off off off on) #20(off off off off off off off off off off on
+off off off off off off on off) #20(off off off off off off off off
+off on on off off off off off off on off) #20(off off off off off off
+off off off on off off off off off off off on off) #20(off off off off
+off off off off off on off off off off off off off on off) #20(off off
+off off off off off off on on off off off off off off off on off)
+#20(off off off off off off off on on on off off off off off on off on
+off) #20(off on off off off off on on off on off off on on on on off
+on off) #20(on on on on on on on on off on off on on on on on off on
+off) #20(on on off on off off on on on on on on on off off off off on
+off) #20(on on off off off on on on on on on on off off off off on on
+off) #20(on on off on off off on on on on on on on on on on on on off)
+#20(on on on on on on on on on on on on on on on on on on off) #20(off
+on off off off off on on off on off off off off off off off on off)
+#20(off off off off off off off on on on off off off off off off off
+on off) #20(off off off off off off off off on on off off off off off
+off off on off) #20(off off off off off off off off off on off off off
+off off off off on off) #20(off off off off off off off off off on on
+off off off off off off on off) #20(off off off off off off off off
+off off on off off off off off off on off) #20(off off off off off off
+off off off off on off off off off off on))) (make-problem "Hattori
+64" '((4) (19) (1 5) (3) (9) (2 1 4 2) (2 1 3 1 2) (1 1 3 9 1) (1 5 7
+2 1) (1 1 2 3 2) (3 3 3) (2 1 4) (7) (1 1 1) (11 1) (1 1 1) (1 1 1)
+(12 5 1) (2 3 3 3 1) (3 4 2 2)) '((1 5 2 3) (2 2 2 1 3) (2 2 8 1 1) (2
+1 1 1 1 1) (2 1 2 3 1 2) (1 7 1 1 3) (1 1 6 1 3) (1 2 2 1 1 1) (1 12 1
+1) (11 1 2) (1 8 1 2) (1 2 3) (1 2 1) (2 2 3) (2 2 2) (2 1 4) (2 3 2)
+(2 1 2 4) (1 2 1 1) (3 3)) '#20(#20(off on off off off off on on on on
+on off off on on off off on) #20(on on off off off on on off off off
+on on off off on off off on) #20(on on off off on on off on on on on
+on on on on off off on off on) #20(on on off off on off off off on off
+off off on off on off off on off) #20(on on off off on off off on on
+off on on on off on off off on on off) #20(off on off off on on on on
+on on on off on off on off off on) #20(off on off off on off off on on
+on on on on off on off off on) #20(off on off off on on off off off
+off off on on off on off off on off on) #20(off on off on on on on on
+on on on on on on on off off on off on) #20(off on on on on on on on
+on on on on off off on off off on on off) #20(off on off on on on on
+on on on on off off off on off off on on off) #20(off on off off off
+off off on on off off off off off off off off on) #20(off on off off
+off off off on on off off off off off off off off off off on) #20(off
+on on off off off off on on off off off off off off on on on off)
+#20(off on on off off off off on on off off off off off off off off on
+on off) #20(off on on off off off off on off off off off off off off
+on on on on off) #20(off on on off off off on on on off off off off
+off off off off on on off) #20(off on on off off on off off on on off
+off off off on on on on off) #20(off on off off off on on off off on
+off off off off off off off off off on) #20(off off off off off off on
+on on off off off off off off off off on))) (make-problem "Hattori 65"
+'((4 3) (3 1 4) (3 6) (12) (8) (8) (1 1 7 3) (2 1 5 1) (6 1 5) (1 2 2
+1 2 1) (1 1 2 1 2 3) (2 1 2) (5) (3) (6) (1 1 2 1 2 3) (1 1 1 2 1 2 1)
+(1 1 3 1 5) (5 3 1) (1 1 5 3)) '((5 4) (2 2) (2 3) (5 2) (1 1 4) (1 2
+1) (4 2 2) (1 5 2 2) (8 2 2 1) (1 5 3 2) (17) (5 3 2) (6 2 1 1) (7 2
+2) (6 2 2) (4 2 2) (3 1 1) (2 5 3 1) (1 1 1 1 1 1) (1 1 1 1 3))
+'#20(#20(off off off off off off on on on on on off off off off on on
+on on off) #20(off off off off off off off on on off off off off off
+off off off off on) #20(off off off off off off off off on on off off
+off off off off on on on off) #20(off off off off off off on on on on
+on off off off off off off off on) #20(off on off off off off off off
+on off off off off off off on on on on off) #20(off on off off off off
+off off on on off off off off off off off on off) #20(on on on on off
+off off off off on on off off off off off on on off) #20(on off on on
+on on on off off off on on off off off on on off) #20(on on on on on
+on on on off off off on on off on on off off off on) #20(on off off on
+on on on on off off off off on on on off off off on) #20(off off off
+on) #20(off off off on on on on on off off off off on on on off off
+off on) #20(off off on on on on on on off off off on on off on off off
+off off on) #20(on on on on on on on off off off on on off off on on
+off) #20(on on on on on on off off off on on off off off off on on
+off) #20(on on on on off off off off on on off off off off off off on
+on off) #20(off on on on off off off off on off off off off off off
+off off on off) #20(off off on on off off on on on on on off off off
+off on on on off on) #20(off off off off off off on off on off on off
+off off off on off on off on) #20(off off off off off off on off on
+off on off off off off on off on))) (make-problem "Hattori 66" '((4 6)
+(2 3) (3 1 4 2) (2 4 1) (2 1 3 3) (2 1 3) (2 1 3 3 7) (1 5 9) (2 1 3 3
+7) (1 2 1 3) (2 1 2 2) (1 3 2) (3 1 3 1 1) (3 2 3) (4 6 3) (3) (9) (2
+6) (3 1 2) (11)) '((1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1) (1 5
+1) (3 2) (2 4 2) (1 4 1) (2 3 2) (1 2 1 1) (1 3 3 3 1 2) (1 5 5 1 3)
+(1 3 3 2 1 4) (2 1 2 1 1) (1 3 1 1 1) (2 3 1 4) (3 3 2 5 1) (14 1) (6
+5 1) (5 4) (3 4)) '#20(#20(on off on off on off on off on off on off
+on off on off) #20(on off on off on off on off on off on off on off on
+off) #20(on off on off off off off off off off off off on off on off)
+#20(on off off off off on on on on on off off off off on off) #20(off
+off off on on on off off off off on on off) #20(off off on on off off
+on on on on off off on on off) #20(off on off off off off on on on on
+off off off on off) #20(on on off off off off on on on off off off off
+on on off) #20(on off on on off off off on off off off off off off on
+off) #20(on off on on on off on on on off on on on off on off off off
+on) #20(on off on on on on on off on on on on on off on off off on)
+#20(on off on on on off on on on off off on on off on off on) #20(on
+on off off off off off on off off off off off on on off on off off on)
+#20(off on off off off off on on on off off off off on off off on off
+off on) #20(off on on off off off on on on off off off on off off off
+on) #20(off off on on on off on on on off on on off on on on on on off
+on) #20(off off off off on on on on on on on on on on on on on on off
+on) #20(off off off off on on on on on on off off off on on on on on
+off on) #20(off off off off off on on on on on off off off off off off
+on) #20(off off off off off off on on on off off off off off off off
+on))) (make-problem "Hattori 67" '((3 4 2) (3 6 2) (2 8 1) (1 2) (8)
+(2 5 1 3) (2 5 1 2 2) (4 1 1 2) (3 4 1 2 1) (1 1 7 1 3) (3 5 1 1 1)
+(11 2 2) (1 1 4 1 1) (3 7 3) (4 3 1) (4 1 1) (1 4 3 2) (1 1 6 1 1 2)
+(1 2 12) (2 2 1 2 2)) '((6 3) (1 2 1 1) (2 6 3) (4 2 1 2) (3 8 1) (2
+12) (14) (15) (1 4 3 1 3) (2 3 1 1 1 2) (3 2 5 3) (5 2) (9 1 1) (3 1 3
+5) (2 1 3 1 1 1) (1 3 1 1 4) (1 1 2) (2 2 1 1 2) (2 2 1 1 1 2) (10))
+'#20(#20(off off off off off off off off on on on on on on off off off
+on) #20(off off off off off off off off on off on on off on off off
+off off off on) #20(off off off off off on on off on on on on on on
+off off on on on off) #20(on on on on off on on off off off off on off
+off off off off off on) #20(on on on off off off off off on on on on
+on on on on off off off on) #20(on on off off off off on on on on on
+on on on on on on on off) #20(off off off off off on on on on on on on
+on on on on on on on off) #20(off off off off off on) #20(off off on
+off on on on on off on on on off on off off on on on off) #20(off on
+on off on on on off off on off on off on off off off on on off) #20(on
+on on off on on off off off on on on on on off off off on) #20(on on
+on on on off off off off off off off off off off off off off on)
+#20(on on on on on on on on on off off on off off off off off off on
+off) #20(on on on off on off off off off on on on off off on on on on
+on off) #20(off on on off on off on on on off off off off off on off
+on off on off) #20(off off on off on on on off on off off off off off
+on off on) #20(on off off off off on off off off off off off off off
+off off off off on) #20(on on off off off on on off off on off off off
+on off off off on on off) #20(off on on off off off on on off on off
+on off on off off on on off) #20(off off off off off off off on on on
+on on on on on on on off))) (make-problem "Hattori 68" '((8) (3 2 2)
+(2 1 1 2) (2 2 1 1) (1 1 2 2) (1 6 3) (2 2 1 3 2) (5 3 4) (1 4 7) (1
+9) (1 9) (1 6 3) (1 6 2) (1 2 2) (2 2 1) (2 2 1) (3 2 1) (6 1) (4 6)
+(6 5)) '((4) (2 2) (2 2) (1 3) (2 3) (1 1 1 2) (2 1 1) (4 1 7 1) (1 6
+2 2) (1 1 2 2) (1 2 1 4 1 2) (2 1 1 7 4) (2 1 8 1 1) (5 5 3) (2 6 3)
+(8 3) (5 3) (5 2) (5 2) (9)) '#20(#20(off off off on on on on off)
+#20(off off on on off off on on off) #20(off on on off off off off on
+on off) #20(off on off off off on on on off) #20(on on off off off on
+on on off) #20(on off on off off on off on on off) #20(on on off off
+off on off off on off) #20(on on on on off on off off on on on on on
+on on off off off off on) #20(on off off on on on on on on off off off
+off off on on off off on) #20(on off off off off off off on off off
+off off off off off on on off on) #20(on off off on on off off on off
+on on on on off off off on off on) #20(on on off off on off on off on
+on on on on on on off on) #20(off on on off off off on off on on on on
+on on on on off on off on) #20(off off on on on on on off on on on on
+on off off on on on off) #20(off off off off on on off on on on on on
+on off off off on on on off) #20(off off off off off on on on on on on
+on on off off off off on) #20(off off off off off off on on on on on
+off off off off off off on) #20(off off off off off off off on on on
+on on off off off off off off on) #20(off off off off off off off off
+off on on on on on off off off off on) #20(off off off off off off off
+off off off off on))) (make-problem "Hattori 69" '((7) (2 2) (1 1)
+(10) (6 1 1 6) (4 1 2 2 1 3) (2 2 3 2) (1 6 2 2 2 1) (3 1 1 2) (1 1)
+(1 3 2) (4 1 1 1 1 4) (1 1 2 2 1) (2 3 7 1) (2 1 1 1) (3 1 3 2) (3 3 1
+3) (1 3 1 3) (2 4 4 1) (17 2)) '((12 3) (3 1 1 4 2) (2 2 1 3 1) (2 1 2
+1 4) (1 1 1 3 3) (5 1 1 2) (3 2 2 2) (2 1 2 2 1 1) (1 1 1 1 1 3 1) (1
+3 1 1 1 1) (1 1 1 1 1) (1 3 1 1) (1 1 1 2 1 1 1) (2 1 2 2 1 1) (6 3 3
+2) (1 1 1 1 2) (1 1 1 3) (2 1 1 3) (3 1 1 3 1) (6 6 2)) '#20(#20(off
+off off off on on on on on on on on on on on on off on) #20(off off
+off off on on on off on off off on off on on on on off on) #20(off off
+off off on on off on on off off on off off off on on on off on)
+#20(off off off off on on off on off off on on off on off off on)
+#20(off off off off on off off on off off on off on on on off off on)
+#20(off off off on on on on on off off on off off on off off off off
+on) #20(off on on on off off on on off off off on on off off off off
+off on) #20(on on off on off off off on on off off off on on off off
+on off off on) #20(on off off on off on off off off off off on off on
+off on on on off on) #20(on off off on on on off on off off off off
+off on off off on off off on) #20(on off off on off off off on off off
+off off off on off off off off off on) #20(on off off on on on off off
+off off off off off on off off off off off on) #20(on off off on off
+on off on on off off on off on off off off off off on) #20(on on off
+on off off on on off off off off on on off on off off off on) #20(off
+on on on on on on off off off on on on off on on on off on) #20(off
+off off off on off on off off off on off off off off on off off on)
+#20(off off off off on off off on off off off on off off off off off
+on) #20(off off off off on on off on off off off on off off off off on
+on on off) #20(off off off off on on on off on off off on off off off
+on on on off on) #20(off off off off on on on on on on off on on on on
+on on off on))) (make-problem "Hattori 70" '((10) (3 3) (3 2) (2 5 1)
+(1 8 1) (2 2 5 1) (1 1 1 1 3 2) (1 1 2 1) (3 2 1 1 3 2) (1 2 5 1 3) (8
+3 3) (13) (4 6) (8) (11) (1 1 1 1) (1 1 1 1) (1 3 2) (8) (1 1)) '((3)
+(4 1) (3 4) (2 3 1) (1 5) (2 4 9) (1 2 7 1) (2 2 1 10) (1 2 2 1 2 3)
+(1 2 1 10) (1 2 6 1) (1 3 2 9) (1 4 2 1 3) (1 3 5 1) (1 2 1 3) (1 1 3)
+(2 1) (1 2) (2 3) (5)) '#20(#20(off off off off off off off off on on
+on off) #20(off off off off off on on on on off on off) #20(off off
+off on on on off off on on on on off) #20(off off on on off off off
+off off on on on off off on off) #20(off off on off off off off off
+off off on on on on on off) #20(off on on off off on on on on off on
+on on on on on on on on off) #20(off on off off on on off off on on on
+on on on on off off off on off) #20(on on off on on off on off off on
+on on on on on on on on on off) #20(on off off on on off off off on on
+off on off on on off off on) #20(on off off on on off on off off on on
+on on on on on on on on off) #20(on off off on on off off off off on
+on on on on on off off off on off) #20(on off off on on on off on on
+off on on on on on on on on on off) #20(on off off off on on on on off
+off off on on off on off off on) #20(on off off off on on on off on on
+on on on off on off) #20(on off off off off on on off on off on on on
+off) #20(on off off off off on off off on on on off) #20(on on off off
+off off off off off on off) #20(off on off off off off off off on on
+off) #20(off on on off off off on on on off) #20(off off on on on on
+on off))) (make-problem "Hattori 71" '((1 1 4) (2 3 7) (3 1 9) (2 3 5)
+(1 5 2) (7 1) (1 1 1 2) (1 3 1 2) (1 3 1 3) (1 1 2 1) (8 4) (2 2 1 2)
+(2 2 3) (2 3 2 3) (2 1 1 1 2 2) (1 2 2 2 2 3 1) (1 2 1 1 2 1 1 1) (1 2
+1 1 2 1 1 1) (1 1 1 1 1 1) (1 5 1 1 1)) '((5 6) (3 2) (1 2 3) (2 3)
+(7) (2 1 6) (1 3 2 1 1 1 1) (9 1 2 1) (1 3 2 1 1 1 1) (2 1 6) (1 6) (2
+2 3) (3 2 3) (4 2) (5 7) (5 2) (4 4 5) (2 4 2) (1 3 5) (2 4 7))
+'#20(#20(on on on on on off off off off off off off off off on)
+#20(off on on on off off off off off off off off off on on off)
+#20(off off on off off off off off off off off off on on off on on on
+off) #20(off off off off off off off off off off off on on off off on
+on on off) #20(off off off off off on on on on on on on off) #20(off
+off off off on on off off off off on off off off on) #20(off on off on
+on on off on on off on off off on off on off off off on) #20(on on on
+on on on on on on off on off off on on off off off off on) #20(off on
+off on on on off on on off on off off on off on off off off on)
+#20(off off off off on on off off off off on off off off on) #20(off
+off on off off on on on on on on off) #20(off on on off off off off
+off off off on on off off off on on on off) #20(off on on on off off
+off off off off off on on off off on on on off) #20(on on on on off
+off off off off off off off on on off) #20(on on on on on off off off
+off off off off off on) #20(on on on on on off off off off off off off
+off off on on off) #20(on on on on off off off off off on on on on off
+off on) #20(off on on off off off off on on on on off on on off)
+#20(off off on off off off on on on off on on on on on off) #20(off
+off off off off on on off on on on on off on))) (make-problem "Hattori
+72" '((2 5 5) (3 1 1 1) (4 3 3 2) (5 1 3 1 3) (5 7 4) (5 3 4) (4 1 1
+3) (1 1 1 1) (1 10) (5 2) (7) (8) (7 2) (8 2 2 1) (6 3 2 1) (4 1 2 3)
+(3 1 1) (1 1) (1 1 1 1) (4 4)) '((4 3 3) (5 1 4) (5 1 4 2) (5 1 3 1)
+(4 2 3 1) (3 1 8) (1 4 1 2) (1 1 4) (1 3 1 4) (1 1 1 5) (7 6) (3 2 1
+2) (7 1 1 1) (1 1 1 1 1 2) (1 3 1 2 5) (1 4 2 1) (1 3 2 1) (4 2 2) (4
+1) (4 3)) '#20(#20(on on on on off off off on on on off off off off on
+on on off) #20(on on on on on off off off off on off off off on on on
+on off) #20(off on on on on on off off off on off off off on on on on
+off on) #20(off off on on on on on off off on off off off on on on off
+off off on) #20(off off off on on on on off off on on off on on on off
+off off off on) #20(off off off off on on on off off off on off on)
+#20(on off off off off on on on on off on off on on off) #20(on off
+off off off off off off on off on on on on off) #20(on off on on on
+off off off on off on on on on off) #20(on off on off on off off off
+on on on on on off) #20(on on on on on on on off on on on on on on
+off) #20(off off off on on on off on on off off on off on on off)
+#20(on on on on on on on off on off off on off off on off) #20(on off
+on off on off off off on off off on off off on on off) #20(on off on
+on on off off off on off off on on off off on) #20(on off off off off
+on on on on off off off on on off off off off off on) #20(on off off
+off on on on off off off off off off on on off off off off on) #20(off
+off off on on on on off off off off off off off on on off off on)
+#20(off off on on on on off off off off off off off off off on off)
+#20(off on on on on off off off off off off off off on on on off)))
+(make-problem "Hattori 73" '((2) (3 4) (5 4) (9) (6) (4 3) (3 2 3) (5
+3) (10 5) (12) (1 1 1 1 1) (1 1 1 1 2 1) (1 1 1 2 3 2) (5 2 3 2) (12
+3) (1 2 1 1 3) (1 4 1 4) (12 5) (10 6) (7)) '((1) (1 9) (2 2 2 2) (1 2
+4 2) (8 2 2) (18) (4 3 5) (4 3 3 3) (3 12) (2 2 1 2) (1 2 3 2) (1 2 4
+2) (2 9) (1 1 1) (1 1 2) (2 3 3) (1 1 1 4) (1 2 1 6) (2 1 1 8) (1 1 1
+10)) '#20(#20(off off off off off off on off) #20(off off off off off
+off on off off on on on on on on on on on off) #20(off off off off off
+on on off on on off off off on on off off on on off) #20(off off off
+off off on off off on on off on on on on off off on on off) #20(off
+off on on on on on on on on off off off on on off off on on off)
+#20(off on on on on on on on on on on on on on on on on on on off)
+#20(off on on on on off off on on on off off off off on on on on on
+off) #20(off on on on on off off on on on off off on on on off on on
+on off) #20(off off on on on off off on on on on on on on on on on on
+on off) #20(off off off on on off off off on on off off off off on off
+off on on off) #20(off off off on off off off off on on off off on on
+on off off on on off) #20(off off off on off off off off on on off on
+on on on off off on on off) #20(off off on on off off off off off on
+on on on on on on on on off) #20(off off on off off off off on off off
+off off off off off off off off off on) #20(off off on off off off off
+on off off off off off off off off off off on) #20(off on on off off
+off on on on off off off off off off off off on) #20(off on off off
+off off on off on off off off off off off off on) #20(off on off off
+off on on off on off off off off off on) #20(on on off off off on off
+off on off off off on) #20(on off off off off on off off on off on)))
+(make-problem "Hattori 74" '((6 5) (5 5) (1 1 1 1) (5 4) (5 5) (12)
+(10) (11) (13) (4 3) (3 2 2 2) (2 1 1 1 1 1) (2 1 1) (2 4 4) (2 2 3 1)
+(2 4 1) (15) (1 3) (1 1) (20)) '((1 2 1) (2 4 1) (6 3 2 2) (2 7 2 1 1)
+(2 7 3 1) (9 1 3 1) (6 1 2 1) (4 2 1 4) (4 2 1 1) (5 2 1 1) (8 1 1 1
+1) (2 6 1 2 1) (2 6 2 2 1) (6 3 3 1) (2 9 1) (1 2 2 1 1) (2 1 1) (1 1
+1) (3 1) (1)) '#20(#20(on off off off off off off off off off on on
+off off off off off off off on) #20(on on off off off off off off off
+on on on on off off off off off off on) #20(on on on on on on off off
+on on on off on on off off off off on) #20(on on off on on on on on on
+on off off off on on off off on off on) #20(on on off on on on on on
+on on off off off off on on on off off on) #20(on on on on on on on on
+on off off on off off off on on on off on) #20(off off off on on on on
+on on off on off off off off off on on off on) #20(off off off off off
+on on on on off on on off on off off on) #20(off off off off off on on
+on on off off off off on on off on off off on) #20(off off off off on
+on on on on off off off off on on off on off off on) #20(off on on on
+on on on on on off off on off on off off on off off on) #20(on on off
+on on on on on on off on off off off off on on off off on) #20(on on
+off on on on on on on off on on off off off on on off off on) #20(on
+on on on on on off on on on off off off off on on on off off on)
+#20(on on off off off off off off on on on on on on on on on off off
+on) #20(on off off off off off off off off on on off off on on off on
+off off on) #20(off off off off off off off off off off off off on on
+off off on off off on) #20(off off off off off off off off off off off
+off off on off off on off off on) #20(off off off off off off off off
+off off off off off off on on on off off on) #20(off off off off off
+off off off off off off off off off off off off off off on)))
+(make-problem "Hattori 75" '((7 1 1) (9 3 2) (1 4 5 3) (2 1 3 10) (2 1
+2) (1 9) (1 2 3 4) (1 3 1 2) (6 1 2) (5 4 1) (2 7 2 1) (7 1 3) (3 2 2
+2) (1 2 1 1 1) (11 2) (1 4 1 1 2) (6 1 2) (1 1 1 3) (1 2 7) (1 12))
+'((7 3) (2 2 1 2 4) (2 1 1 3) (2 2 1 1 7 1) (2 9 2) (3 3 2 6) (4 3 1 1
+1) (5 2 1 1 2 1) (6 3 1 1) (2 3 1 2) (1 1 1 8) (2 1 1 2) (3 1 1 2) (4
+1 2 2) (3 2 4 3) (2 5 2 2) (1 2 2 2) (2 2 2 2) (3 2 2 2) (4 7))
+'#20(#20(off on on on on on on on off off off off off off on on on
+off) #20(on on off on on off off off on off off off off on on off on)
+#20(on on off off off off on off on off off off off off on on on off)
+#20(on on off on on off on off on off on on on on on on on off off on)
+#20(on on off off off off off off on on on on on on on on on off on)
+#20(on on on off off off off on on on off on on off on) #20(on on on
+on off off off on on on off on off off on off off off off on) #20(on
+on on on on off on on off on off on off off on on off off off on)
+#20(off on on on on on on off off on on on off off on off off off off
+on) #20(off off off off off on on off off off on on on off on off off
+off on) #20(off off off on off on off off off off on off on) #20(off
+off on on off on off off off off on off off off off off off off on)
+#20(off on on on off on off off off off on off off off off off off off
+on) #20(on on on on off on off off off on on off off off off off off
+off on) #20(off on on on off on on off off on on on on off off off off
+on) #20(off off on on off on on on on on off off on on off off off on
+on off) #20(off off off on off on on off off on on off off off off off
+on on off) #20(off off on on off off on on off off on on off off off
+on on off) #20(off on on on off off off on on off off on on off on on
+off) #20(on on on on off off off off on on on on on on on off)))
+(make-problem "Hattori 76" '((1 1 3) (3 3 1 1) (1 7 1 4) (3 3 1) (1 8)
+(2 1 1 2 2) (1 2 2 1 2) (1 1 1) (1 7 1 1) (1 2 2 1 1) (1 1 1 1 1 1 1)
+(1 1 1 1 1 1 1) (1 2 2 1 1) (1 7 1 1) (2 1 1) (11 1) (1 1 1 2) (2 4 6
+1) (1 1 1 1 1 1 1) (3 3 5)) '((10) (6 2) (1 1 4 1) (3 1 2 2 3) (1 2 1
+1 1 3) (1 1 2 1 1 1) (1 1 1 1 3) (1 1 2 1 1 1) (1 2 1 1 1 1) (3 1 2 2
+1 3) (2 1 4 1 1) (5 1 3) (11 2) (1 1) (1 3) (1 1 1) (3 1 4) (1 1 2 1)
+(7 4) (1 11)) '#20(#20(off off off off off on on on on on on on on on
+on off) #20(on on on on on on off off off off off off off off on on
+off) #20(off on off on off off off off off on on on on off off on off)
+#20(off on on on off off on off on on off off on on off on on on off)
+#20(off off on off off on on off on off off off off on off on off on)
+#20(off off on off off off off off on off on on off on off on off off
+off on) #20(off off on off off off off off on off off off off on off
+on off on) #20(off off on off off off off off on off on on off on off
+on off on off) #20(off off on off off on on off on off off off off on
+off on off on off) #20(off on on on off off on off on on off off on on
+off on off on) #20(on on off on off off off off off on on on on off
+off on off off off on) #20(off on on on on on off off off off off off
+off off off on off on) #20(off off off off on on on on on on on on on
+on on off on on off) #20(off off off off on off off off off off off
+off off off off off off on off) #20(off off off off on off off off off
+off off off off off off off off on) #20(off off off off on off off off
+off off off off off off off off off on off on) #20(on on on off on off
+off off off off off off off off off off on) #20(on off on off on on
+off off off off off off off off off off off off off on) #20(on on on
+on on on on off off off off off off off off off on) #20(off off on off
+off off on on on on on on on on on on on off))) (make-problem "Hattori
+77" '((14) (4 5) (1 1 3) (3 2) (4 1) (5 3) (4 1 4) (1 2 4) (2 1 2) (5
+1 4) (1 5 1) (1 6 3) (4 2 1) (10 2 1 1) (1 10 2) (2 2 2 1 1) (3 1 2 2
+1) (4 2 2 2) (11 4) (12 2)) '((1) (1 1 2) (2 1 2) (2 1 1 2) (4 1 2 2)
+(1 2 7) (1 1 4 3) (2 3 11) (2 5 6 3) (3 3 4 2) (2 3 1 3 3) (1 6 2 6)
+(1 1 1 3 1) (1 2 2 1 1) (1 4 1 4) (2 2 2 3 1) (2 2 1 2 1) (3 1 2 2) (4
+3 4) (5 1 2)) '#20(#20(off off off off off off off off off off off off
+off off off off off off off on) #20(off off off off off off off off
+off on off off off on off off off off on) #20(off off off off off off
+off off off on on off off on off off off off on) #20(off off off off
+off off off off on on off off off on off off on off on) #20(off off
+off off off off off off on on on on off on off on on off on) #20(off
+off off off off off off on off on on off off on) #20(on off off off
+off off on off off off on on on on off off off on) #20(on on off off
+off on on on off on) #20(on on off off on on on on on off on on on on
+on on off on) #20(on on on off on on on off off off off on on on on
+off off off on) #20(on on off on on on off off off off off on off on
+on on off on) #20(on off on on on on on on off off off on on off on)
+#20(on off off on off off off on off off off off on on on off on off)
+#20(on off off off off off on on off off off off off on on off off on
+off on) #20(on off off off off on on on on off off off off off on off
+on) #20(on on off off off on on off on on off off off off on on on off
+on off) #20(on on off off off on on off off on off off off on on off
+off off on off) #20(on on on off off off off off off on off on on off
+off off off on on off) #20(on on on on off off off off off on on on
+off off on on on on off) #20(on on on on on off off off off off off on
+off on on off))) (make-problem "Hattori 78" '((8) (2 2) (1 1) (1 1 2)
+(1 1 1 4) (1 1 3 3) (3 11 2) (3 1 2 2) (3 1 2 2) (1 12 3) (1 1 2 2 1
+4) (1 1 1 1 1 1) (1 1 1 1) (3 2 2 2 3) (1 1 2 2 1 1 1) (4 8 3) (1 4 4
+1) (2 1 1 1) (1 4) (4 1 1 1)) '((3 5) (8 1 3) (3 3 1) (2 1) (13 1 1)
+(2 1 1 2 1) (1 1 2 3) (1 1 3 1 1 1) (1 1 1 3) (1 1 1 3) (1 1 3 1) (1 3
+2 1 1 1) (2 1 1 3) (13 2) (5 1) (2 2 1 2) (2 1 4 1) (3 5 1 1) (7 6)
+(5)) '#20(#20(off off off off off off on on on off off off off on on
+on on on off) #20(off off off off off off on on on on on on on on off
+on off on) #20(off off off off off off on on on off off off off on on
+on off off off on) #20(off off off off off off off off off off off off
+off off off on on off off on) #20(off on on on on on on on on on on on
+on on off off on off off on) #20(on on off off off off on off off on
+off off off on on off on off) #20(on off off off off off on off off on
+on off off off on on on off) #20(on off off off off off on off off on
+on on off off off on off on off on) #20(on off off off off off on off
+off on off off off on on on off) #20(on off off off off off on off off
+on off off off on on on off) #20(on off off off off off on off off on
+on on off off off on off) #20(on off off off on on on off off on on
+off off off off on off on off on) #20(on on off off off off on off off
+on off off off on on on off) #20(off on on on on on on on on on on on
+on on off on on off) #20(off off off off off on on on on on off off
+off off off off on off) #20(off off off off on on off off off on on
+off off off off off on off on) #20(off off off on on off off off off
+off on off off on on on on off on off) #20(off off off on on on off
+off off on on on on on off on off off on off) #20(off off off off on
+on on on on on on off off on on on on on on off) #20(off off off off
+off on on on on on off))) (make-problem "Hattori 79" '((1 1 1 1 1 1)
+(1 1 1 1 2 2 2) (1 2 2 1 3 1 1) (3 1 2 2 4) (2 1 2 4) (2 3 2) (4 1 2)
+(3 2 2) (4 9) (1 4 6) (2 2 1) (2 3 2) (3 2 1 3) (2 3 4) (1 3) (2 1 1)
+(4 5) (6 5) (6 7 3) (4 3)) '((4 3 2) (2 1 2 2) (4 1 2 3) (3 2 2 1 4)
+(2 2 2 4) (9 6) (3 5 2) (2 1 2) (2 1 1) (3 3 1 1) (4 3 2) (2 2 1 1 2)
+(3 4 3 2) (8 2) (2 2 4 1) (2 1 3 2) (2 2 3) (3 6) (2 1 2 1 1) (2 3))
+'#20(#20(on on on on off off off off on on on off off off off off off
+off on) #20(off off off on on off off off on off on on off off off off
+off off on) #20(off off on on on on off off on off off on on off off
+off off on) #20(on on on off off on on off on on off off on off off
+off on) #20(off off off off off off on on off on on off on on off on
+on on on off) #20(off off on on on on on on on on on off off on on on
+on on on off) #20(on on on off off on on on on on off off off off off
+off on on off) #20(off off off off on on off off on off off off off
+off off off off on on off) #20(off off off on on off off off on off
+off off off off off off off off on off) #20(off on on on off off off
+on on on off off on off off off off off on off) #20(off off off off
+off off on on on on off on on on off off off off on) #20(on on off off
+off off off off on on off on off on off off off off on) #20(off on on
+on off off on on on on off on on on off off off off on) #20(off off on
+on on on on on on on off off off off off off off on on off) #20(off on
+on off on on off off off on on on on off off off off on off) #20(on on
+off off on off off off off off off on on on off off on on off) #20(off
+off off on on off off off off off off off on on off off on on on off)
+#20(off on on on off off off off off off off off off on on on on on on
+off) #20(on on off on off off off off off off off off off on on off on
+off on off) #20(off off on on off off off off off off off off off off
+on on on off))) (make-problem "Hattori 80" '((7) (1 1 1) (15) (2 2 2
+2) (2 3 2) (3 1 4) (3 1 4) (3 3 4) (2 1 2 2) (1 1) (1 1) (1 1) (1 1)
+(4 1 3) (1 2 1 1 3) (2 2 1 1 1 1) (2 3 1 1 3) (2 1 1 1 1) (2 5 1) (2
+3)) '((5) (6 3) (2 3 1 2) (1 1 2) (1 2 2) (1 2 2) (1 1 2 1) (4 1) (1 3
+10) (3 4) (1 3 2) (4 11) (1 1 1 1) (1 6) (1 1 1) (1 6) (2 3 1 1) (6 4)
+(5) (3)) '#20(#20(off off off off on on on on on off) #20(off off off
+on on on on on on off off off off on on on off) #20(off off on on off
+on on on off off off off off on off on on off) #20(off off on off off
+off off off off off off off off on off off on on off) #20(off off on
+off off off off off off off off off off on on off off on on off)
+#20(off off on off off off off off off off off off off off on on off
+off on) #20(on off on off off off off off off off off off off off off
+on on off off on) #20(on on on on off off off off off off off off off
+off off off on off) #20(on off on on on off off on on on on on on on
+on on on off) #20(on on on off on on on on off) #20(on off on on on
+off off on on off) #20(on on on on off off off off on on on on on on
+on on on on on off) #20(on off on off off off off off off off off off
+off on off off off off on off) #20(off off on off off off off off off
+off off off off on on on on on on off) #20(off off on off off off off
+off off off off off off off on off off off on off) #20(off off on off
+off off off off off off off off off off on) #20(off off on on off on
+on on off off off off off off off off on off off on) #20(off off off
+on on on on on on off off off off off off off on) #20(off off off off
+on on on on on off) #20(off off off off off on on on off)))
+(make-problem "Hattori 81" '((1 1 1) (2 1 2) (7) (7) (5) (1 1 1) (2 1
+2) (4 1 3) (10) (6)) '((4) (3) (3 3) (5 3) (3 2) (10) (3 2) (5 3) (3
+3) (4)) '#10(#10(off off off off off on on on on off) #10(off off off
+off off off on on on off) #10(off on on on off off off on) #10(on on
+on on on off off on) #10(off off on on on off off off on) #10(on)
+#10(off off on on on off off off on) #10(on on on on on off off on)
+#10(off on on on off off on on on off) #10(off off off off off on on
+on on off))) (make-problem "Hattori 82" '((1) (2) (3) (2) (4) (4 1) (5
+2) (6 2) (7 3) (8 4) (15) (1) (15) (13) (11)) '((1 1) (2 2) (3 3) (4
+3) (5 3) (6 3) (7 3) (8 3) (15) (2 1 1 3) (1 6 3) (5 3) (3 3) (2 2) (1
+1)) '#15(#15(off off off off off off off off off off on off on off)
+#15(off off off off off off off off off on on off on on off) #15(off
+off off off off off off off on on on off on) #15(off off off off off
+off off on on on on off on) #15(off off off off off off on on on on on
+off on) #15(off off off off off on on on on on on off on) #15(off off
+off off on on on on on on on off on) #15(off off off on on on on on on
+on on off on) #15(on) #15(off on on off on off off off off off on off
+on) #15(off off on off off on on on on on on off on) #15(off off off
+off off off on on on on on off on) #15(off off off off off off off off
+on on on off on) #15(off off off off off off off off off on on off on
+on off) #15(off off off off off off off off off off on off on off)))
+(make-problem "Hattori 83" '((1 1 1 1 12) (1 1 13) (1 1 14) (1 15) (1
+16) (1 1) (1 5 7) (2 2 8) (1 1 1 1 1 8) (1 1 1 1 1 2 5) (1 1 1 3) (1 1
+1 1 1 2) (1 3 1 1 2 2) (1 2 2 3 1 2) (1 1 1 1 1 2 2) (2 1 1 1 1 1) (1
+1 2 2 5 1) (1 1 1 2 1 1) (1 7 3 4) (10)) '((3 2 3) (3 3) (1 4 4) (2 2
+1 3 1) (2 1 1 2 2 1) (4 1 1) (1 3 1 2 2 1) (4 2 1 4 1) (5 4 3) (5 3)
+(5 1 4) (5 9) (5 3 2) (5 11 1) (5 3 1 1 1) (5 4 2 1 1) (5 4 1 1 2) (5
+5 4) (5 9 2) (5 14)) '#20(#20(on on on off off off off off on on off
+off off off off off on on on off) #20(off off off off on on on off off
+off off off on on on off) #20(on off off off off off off on on on on
+off off off off on on on on off) #20(off off on on off off on on off
+off off on off on on on off off on off) #20(on on off off on off on
+off on on off off on on off off off off on off) #20(off off off on on
+on on off off off off off on off off off off off on off) #20(on off on
+on on off on off on on off off on on off off off off on off) #20(off
+on on on on off on on off off off on off on on on on off on off)
+#20(on on on on on off off on on on on off off off off off on on on
+off) #20(on on on on on off off off off off off off off on on on off)
+#20(on on on on on off off off off off off off off on off off on)
+#20(on on on on on off off off off off off on) #20(on on on on on off
+off on on on off off off off off off off off on) #20(on on on on on
+off on on on on on on on on on on on off off on) #20(on on on on on
+off on on on off off off off off on off on off off on) #20(on on on on
+on off on on on on off on on off off off on off off on) #20(on on on
+on on off on on on on off off on off off off on off on) #20(on on on
+on on off on on on on on off off off off off on) #20(on on on on on
+off on on on on on on on on on off off off on) #20(on on on on on off
+on))) (make-problem "Hattori 84" '((2) (3) (2 2) (4 2) (2 3 2) (8 1 2)
+(10 4) (2 16) (4 3 3 2) (3 3 3 1) (3 3 2) (4 3) (10) (3 4) (1 3 3 1)
+(2 2 3 2) (3 3 5) (5 4) (16) (12)) '((2 3) (4 3) (5 3) (2 2 2) (8 4)
+(2 6 6) (2 13 2) (2 10 2) (2 8 2) (4 2 2) (4 1 2) (4 1 2) (4 2 2) (1 4
+2) (9 2) (13) (4 4) (3 3) (4 3) (4 3)) '#20(#20(off off off off off on
+on off off off off off off off on on on off) #20(off off off off on on
+on on off off off off off off off on on on off) #20(off off off on on
+on on on off off off off off off off off on on on off) #20(off off on
+on off on on off off off off off off off off off off on on off) #20(on
+on on on on on on on off off off off off off off off on) #20(on on off
+on on on on on on off off off off off on) #20(off on on off on on on
+on on on on on on on on on on off on) #20(off off on on off on on on
+on on on on on on on off off off on) #20(off off off on on off on on
+on on on on on on off off off off on) #20(off off off off on on on on
+off off off on on off off off off off on) #20(off off off off off off
+off on on on on off on off off off off off on) #20(off off off off off
+off off on on on on off on off off off off off on) #20(off off off off
+off off off on on on on off on on off off off off on) #20(off off off
+off off off off on off off off on on on on off off off on) #20(off off
+off off off off off on on on on on on on on on off off on) #20(off off
+off off off off off on) #20(off off off off off off on on on on off
+off off off off on on on on off) #20(off off off off off on on on off
+off off off off off off off on on on off) #20(off off off off off on
+on on on off off off off off off on on on off) #20(off off off off off
+off on on on on off off off off on on on off))) (make-problem "Hattori
+85" '((1 1 1 1 1 1) (1 1 1 5 1 1) (1 1 9 1) (1 4 1 4) (6 6) (8 8) (10
+9) (2 4 1 3 2) (1 1 1 1 1) (5 1) (8 1 6) (9 1 8) (5 1 1 8) (4 3 1 1 4)
+(3 1 1 1 3 3) (3 1 1 2 1 2) (4 3 1 1 2 1) (3 1 1 2 1) (1 2 1 2 2) (6 2
+1 2)) '((3 3 6) (3 8) (3 3 9 1) (3 5 4) (2 4 4 1) (5 3 1) (1 6 3 2 1
+1) (7 2 1 1 2) (2 3 9) (2 1) (4 13) (2 1 1) (2 2 2 3) (6 6 3) (1 7 3 1
+1 1) (5 3 3) (2 4 4) (3 5) (2 4 6 2) (4 9)) '#20(#20(off on on on off
+off on on on off off on on on on on on off) #20(off off off off off on
+on on off off on on on on on on on on off) #20(on on on off on on on
+off off on on on on on on on on on off on) #20(off off off off on on
+on off off on on on on on off off on) #20(on on off on on on on off
+off on on on on off off off off off off on) #20(off off off on on on
+on on off on on on off off off off off off off on) #20(on off on on on
+on on on off on on on off on on off on off off on) #20(off off on on
+on on on on on off on on off on off off on off on) #20(off on on off
+off on on on off off on on on on on on on on on off) #20(off on on off
+off off on off) #20(on on on on off off off on) #20(off on on off off
+off on off off off off off off off off off off off off on) #20(off on
+on off off on on off off off off on on off off on on on off) #20(off
+off on on on on on on off off on on on on on on off on) #20(on off on
+on on on on on on off on on on off on off on off on off) #20(off off
+off on on on on on off off on on on off on on on off) #20(on on off on
+on on on off off off on on on on off) #20(off off off off on on on off
+off off on on on on on off) #20(off on on off on on on on off off on
+on on on on on off off on) #20(off off off off off on on on on off off
+on))) (make-problem "Hattori 86" '((3 6 1) (3 6 3) (4 6 1) (4 9 2) (3
+6 3) (3 6 3) (3 6) (2) (6) (2 2 2 3) (3 2 2 4) (3 1 1 1 4) (2 1 3 2 1
+3) (3 1 1 2) (5 4) (8 2 7) (6 2 5) (6 1 1 5) (6 5) (13)) '((4 4 3) (5
+4 5) (7 2 5) (5 7) (3 7) (1 10) (2 1 2) (7 2 1 1 1 1) (7 1 3 1) (7 1 1
+2 1) (7 1 2 1) (7 1 2 1) (7 2 1 1 1 1) (1 2 1 2) (1 10) (2 7) (2 1 2
+5) (1 2 4 5) (2 1 1 4 3) (1 1 4)) '#20(#20(on on on on off off off off
+off on on on on off off on on on off) #20(on on on on on off off off
+off on on on on off on on on on on off) #20(on on on on on on on off
+off off on on off off on on on on on off) #20(off off on on on on on
+off off off off off off on) #20(off off off off off on on on off off
+off off off on) #20(off off off off off off off on off off on) #20(off
+off off off off off off off off on on off off off off on off off on)
+#20(on on on on on on on off on on off off on off off on off on off
+on) #20(on on on on on on on off on off off on on on off off off off
+off on) #20(on on on on on on on off on off off off on off off on on
+off off on) #20(on on on on on on on off on off off off off off off on
+on off off on) #20(on on on on on on on off on off off off on on off
+off off off off on) #20(on on on on on on on off on on off off on off
+off on off on off on) #20(off off off on off off off off off on on off
+off off off on off off on) #20(off off off on off off off off off off
+on) #20(off off off on on off off off off off off off off on) #20(off
+on on off on off off off off off on on off off on on on on on off)
+#20(off on off off on on off off off on on on on off on on on on on
+off) #20(on on off on off on off off off on on on on off off on on on
+off) #20(off off off on off on off off off on on on on off)))
+(make-problem "Hattori 87" '((5 5) (1 1 1 1) (3 1 3 1) (3 1 3 1) (1 1
+3 1 2) (13) (15) (17) (3 2 12) (20) (5) (20) (11 4) (9 4 3) (8 5 2) (7
+8) (3 11) (3 3 8) (3 3 6) (4 4 7)) '((2 1 1) (3 2 1) (4 3 2) (8 1 4 3)
+(1 2 5 8) (1 8 7 1) (1 3 1 6 1) (10 5 2) (6 5 3) (10 8) (1 2 5 7) (1 8
+2 1 1) (1 5 1 5 1) (10 1 7) (6 1 7) (7 7) (7 6) (7 5) (11) (9))
+'#20(#20(off off off off off off off off on on off on off off off off
+off off off on) #20(off off off off off off off on on on off on on off
+off off off off off on) #20(off off off off off off on on on on off on
+on on off off off off on) #20(on on on on on on on on off on off on on
+on on off off on) #20(on off on on off on on on on on off on on on on
+on on on on off) #20(on off on on on on on on on on off on on on on on
+on on off on) #20(on off off off off on on on off on off on on on on
+on on off off on) #20(on on on on on on on on on on off on on on on on
+off off on) #20(off off off off on on on on on on off on on on on on
+off on) #20(on on on on on on on on on on off on on on on on on on on
+off) #20(on off on on off on on on on on off on on on on on on on off)
+#20(on off on on on on on on on on off on on off off off on off off
+on) #20(on off off off off on on on on on off on off on on on on on
+off on) #20(on on on on on on on on on on off on off on) #20(off off
+off off on on on on on on off on off on) #20(off off off off off on on
+on on on on on off on) #20(off off off off off off on on on on on on
+on off on) #20(off off off off off off off on on on on on on on off
+on) #20(off off off off off off off off on on on on on on on on on on
+on off) #20(off off off off off off off off off on on on on on on on
+on on off))) (make-problem "Hattori 88" '((4 4 5) (1 2 2 1 6) (1 1 1
+8) (1 1 1 5) (3 2 2 2 1) (1 1 1 2 5) (2 3 2 1 3) (1 1 1 1 1 1) (2 4 1
+3) (5 2 1 1) (1 3 1 1) (1 3 1 1 4) (6 2 2 1 2) (1 1 1 4 1 3) (1 2 5 2)
+(4 1 2) (1 3 4) (2 1 1) (1 1 5) (1 11)) '((5 4) (1 3 4 1) (1 1 4 1 4)
+(2 2 4 3) (4 1 2) (3 6) (2 2 1) (3 2 3 1) (4 2 3 4) (2 3 4 1) (1 2 1 2
+1) (1 2 5 1) (5 2) (2 2) (14 2) (4 1 2 2) (4 4 2 5) (3 2 1 3 1 1) (3 4
+1 1 1 1) (3 1 1 1)) '#20(#20(on on on on on off off off off off off
+off on on on on off) #20(on off off off on on on off off on on on on
+off off on off) #20(on off off off on off on on on on off off on off
+on on on on off) #20(on on off off off off off off on on off off on on
+on on off on) #20(off on on on on off off off off on off on on off)
+#20(off off off off on on on off off on on on on on on off) #20(off
+off off off off off on on off off on on off off on off) #20(off off
+off off on on on off off on on off on on on off on off) #20(off on on
+on on off off off on on off off on on on off on) #20(on on off off off
+off on on on off off off off on on on on off off on) #20(on off off
+off off on on off on off off off on on off off off off off on) #20(on
+off off off on on off off on on on on on off off off off off off on)
+#20(on on on on on off off off off off off off off off off off off off
+on) #20(off off on on off off off off off off off off off off off off
+off off on) #20(off on on on on on on on on on on on on on on off off
+off on) #20(on on on on off on off off off off off off off off on on
+off off on) #20(on on on on off on on on on off off on on off off on)
+#20(on on on off off on on off on off off on on on off off on off off
+on) #20(on on on off off on on on on off off on off on off off on off
+off on) #20(on on on off off off off off off off off on off on off off
+on off))) (make-problem "Hattori 89" '((9) (4 4) (4 3) (5 4) (4 4 2)
+(4 2 2 5 3) (4 1 1 5 2) (4 2 2 5 2) (4 9) (4 5 2) (2 1 2 5 1) (2 1 2 2
+2 1) (2 2 1) (6 1) (1 1) (2 1 1 1 1) (2 2 5 1) (3 2 2 1 1) (1 2 2 2 1)
+(10 6)) '((9) (10) (9 3) (13 1 1) (4 2 2 1) (2 1 1 1 2 1) (1 3 2 3 2)
+(1 2 1 3) (1 1 1 1 2 1) (2 3 2 2 1) (4 2 1) (12 2) (10 2) (9 3) (8 1
+2) (6 4) (1 1 1) (2 1 2 1) (6 1) (15)) '#20(#20(off off off on on on
+on on on on on on off) #20(off off on on on on on on on on on on off)
+#20(off on on on on on on on on on off off off off off off off on)
+#20(on on on on on on on on on on on on on off off off off on off on)
+#20(on on on on off off off off off off off off on on off off on on
+off on) #20(on on off off off on off on off off off off off on off on
+on off off on) #20(on off off off off on on on off off on on off on on
+on off off on) #20(on off off off off off off off off off on on off on
+off off off on) #20(on off off off off on off on off off off off off
+on off off on on off on) #20(on on off off off on on on off off off
+off on on off on on off off on) #20(on on on on off off off off off
+off off on on off off off off off off on) #20(on on on on on on on on
+on on on on off off off off off off on) #20(off on on on on on on on
+on on on off off off off off off on on off) #20(off off off on on on
+on on on on on on off off off on on on off) #20(off off off off on on
+on on on on on on off off off off on off on) #20(off off off off off
+on on on on on on off off off off off on) #20(off off off off off off
+off off on off off off off off off off on off off on) #20(off off off
+off on on off off on off off off off off off on on off off on) #20(off
+off off off on on on on on on off off off off off off off off off on)
+#20(off off off off off on))) (make-problem "Hattori 90" '((2 6) (11)
+(3 9) (3 1 1 1 2) (2 1 1 1 1) (3 1 2) (1 1 1 1 1) (1 2 2 1 2) (1 2 1
+1) (2 6 3) (2 6 5) (13 2) (5 4 3) (4 4 5) (1 7) (6 3) (7 2) (14) (4 10
+4) (4 4)) '((5 2) (1 2 2) (5 2 2) (3 2 1 3) (3 6 1) (3 5 3) (2 5 4) (7
+5 4) (3 6 5) (5 3 1 4) (3 2 3 4) (5 3 4) (3 5 2) (3 6 1 2) (3 3 3 2 3)
+(4 2 6) (6 3) (5 2) (2 2) (2)) '#20(#20(off off off off off on on on
+on on off off off off off off off off on) #20(off off off off off on
+off off off on on off off off off off off off on) #20(off off off on
+on on on on off off on on off off off off off off on) #20(off off on
+on on off off on on off off on off off off off off on) #20(off on on
+on off off off off on on on on on on off off off on off) #20(on on on
+off off off off off off on on on on on off off on on on off) #20(on on
+off off off off off off off on on on on on off on on on on off)
+#20(off on on on on on on on off on on on on on off on on on on off)
+#20(on on on off off off off on on on on on on off on on on on on off)
+#20(on on on on on off off off off on on on off on off on on on on
+off) #20(on on on off off off on on off off off on on on off on on on
+on off) #20(on on on on on off off off off off off on on on off on on
+on on off) #20(on on on off off off off off off off on on on on on off
+off on on off) #20(on on on off off off off on on on on on on off on
+off off on on off) #20(off on on on off on on on off on on on off on
+on off on on on off) #20(off off on on on on off off off on on off on
+on on on on on off) #20(off off off off off off off off off off on on
+on on on on off on) #20(off off off off off off off off off off off on
+on on on on off off on) #20(off off off off off off off off off off
+off off off on on off off off on) #20(off off off off off off off off
+off off off off off off off off off off on))))))
diff --git a/collects/games/paint-by-numbers/solution-sets/h91-120 b/collects/games/paint-by-numbers/solution-sets/h91-120
new file mode 100644
index 0000000000..0b05de6092
--- /dev/null
+++ b/collects/games/paint-by-numbers/solution-sets/h91-120
@@ -0,0 +1,932 @@
+(unit/sig paint-by-numbers:problem-set^ (import
+paint-by-numbers:problem^) (define set-name "Hattori 91 - 120")
+(define problems (list (make-problem "Hattori 91" '((5 5) (1 1 1 1) (1
+1) (7) (4 1 2 2 3) (6 1 1 1 5) (4 3 1 3 3) (3 7 2) (2 1 1 1) (1 1 3 1
+1) (1 1 1) (2 1 3 1 2) (18) (2 3 2) (2 1 4 1 1) (1 6 1) (2 5 2 2) (2 2
+4 2 2) (4 3 3) (1 2 1)) '((7) (5 2 3) (4 3 2) (3 2 2) (2 1 2 1 2) (2 2
+1 1) (1 1 1 2) (1 5 1 2) (1 1 1 1 2) (5 3 7) (5 10) (4 3 9) (1 2 1 1 2
+3) (1 5 1 2) (1 1 1 2) (2 2 1 2) (2 1 2 1 2) (3 1 2) (4 3 2) (7 4))
+'#20(#20(off off off off off on on on on on on on off) #20(off off off
+off on on on on on off off on on off on on on off) #20(off off off off
+on on on on off off off off on on on off on on off) #20(off off off
+off on on on off off off off off on on off off off on on off) #20(off
+off off off on on off off off on off on on off on off off off on)
+#20(on on off off off on on off off off off off on off off off off off
+on off) #20(on off off off off off on off off off off off on off off
+off off on on off) #20(on off off on on on on on off off off off on
+off off off on on off) #20(on off off on off off off on off off off
+off on off off on on off) #20(on on on on on off off on on on off on
+on on on on on on off) #20(off off off on on on on on off on on on on
+on on on on on on off) #20(on on on on off off off on on on off on)
+#20(on off off on on off off on off off off off on off on on off on)
+#20(on off off on on on on on off off off off on off off on on off)
+#20(on off off off off off on off off off off off on off off off on on
+off) #20(on on off off off on on off off off off off on off off off
+off on on off) #20(off off off off on on off off off on off on on off
+on off off off on) #20(off off off off on on on off off off off off on
+off off off off on on off) #20(off off off off on on on on off off off
+on on on off off on on off) #20(off off off off off on on on on on on
+on off on on on on off))) (make-problem "Hattori 92" '((5) (5 2) (7 4)
+(8 5) (9 6) (9 6) (9 8) (1 7 8) (1 4 8) (4 2 7) (1 2 3 6) (2 2 1 5 5)
+(2 1 1 2 2 5) (1 2 1 5 5) (1 2 2 3 6) (3 2 6) (1 2 7) (4 1 6) (1 1 4)
+(1 1 3)) '((4) (2 2 1) (9 5) (5 1 1) (6 1 1 2 1) (7 1 4 1) (7) (8 5)
+(10 2) (10 3 2) (1 3 5 4) (1 2 2) (1 3 5 4) (10 3 5) (10 6) (17) (16)
+(15) (13) (9)) '#20(#20(off off off off off off off off off off off
+off on on on on off) #20(off off off off on on off off off off off on
+on off off on off) #20(off off off on on on on on on on on on off off
+off on) #20(off off on on on on on off off on off off off off off off
+off on off) #20(off off on on on on on on off on off on off on on off
+off on off) #20(off on on on on on on on off on off on on on on off
+off on off) #20(off on on on on on on on off) #20(off on on on on on
+on on on off on on on on on off) #20(off on on on on on on on on on on
+off off off on on off) #20(on on on on on on on on on on off on on on
+off on on off) #20(on off off off off off on on on off on on on on on
+off on) #20(on off off off off off off off off off on on off on on
+off) #20(on off off off off off on on on off on on on on on off on)
+#20(on on on on on on on on on on off on on on off on) #20(off on on
+on on on on on on on on off off off on) #20(off off on on on on on on
+on on on on on on on on on on on off) #20(off off on on on on on on on
+on on on on on on on on on off) #20(off off off on on on on on on on
+on on on on on on on on off) #20(off off off off on on on on on on on
+on on on on on on off) #20(off off off off off off on on on on on on
+on on on off))) (make-problem "Hattori 93" '((8 3) (3 1 3 1) (2 3 1)
+(1 2 2 4) (1 3 1 5) (2 1 1 2 1) (1 2 1 3) (1 2 2) (2 3 1) (3 1 3 2) (8
+3) (5 9) (2 4 1) (2 9) (2 6 2) (2 1 4 1 1) (2 9 1) (2 1 1 1) (13 1)
+(15 3)) '((9) (3 1 3 1) (2 3 2) (1 2 2) (1 2 10) (2 1 1 11) (1 3 2 2)
+(2 2 2 2 2) (3 3 3 1 2) (3 1 3 9) (7 6 2) (6 2) (1 4 2) (4 4) (1 1 1
+2) (1 1 1 2 1) (7 1 2) (5 2 3 6) (1 2 1 1 1) (1 2 1 1)) '#20(#20(off
+on on on on on on on on on off) #20(on on on off off on off off on on
+on off off off off off off off off on) #20(on on off off off off off
+off off on on on off off off off off off on) #20(on off off off off
+off off off off off on on off off off off off off on) #20(on off off
+off off on on off off off on) #20(on on off off on off on off off on)
+#20(on off off on on on off off off off on on off off off off off off
+on) #20(on on off on on off off off off on on off off off off on on
+off on) #20(on on on off off off off off on on on off on on on off on
+off on) #20(off on on on off on off on on on off on) #20(off off on on
+on on on on on off off on on on on on on off on) #20(off off off off
+off off off off off off off on on on on on on off on) #20(off off off
+off off off off off off off off on off on on on on off on) #20(off off
+off off off off off off off off off on on on on off on) #20(off off
+off off off off off off off off off on off on off off on off on)
+#20(off off off off on off off off off off off on off on off on on off
+off on) #20(off off off on on on on on on on off on off on on off)
+#20(on on on on on off on on off on on on off off on) #20(on off off
+on on off on off off off on off off off off off off off off on) #20(on
+off off on on off off off off off on off off off off off off off off
+on))) (make-problem "Hattori 94" '((3 5) (2 1 2 1) (2 3 2 1) (2 2 3 1)
+(2 2 4 1) (2 2 3 1 3) (1 2 4 2 1 2) (1 3 2 5 1) (1 2 3 2 1) (2 4 2 1)
+(1 1) (2 3 2 1) (1 1 1 2 1) (1 3 2 1) (1 2 1) (1 2 1) (1 1 2 2 1) (3 3
+6 2) (5 3 3) (6 10)) '((7) (3 2) (6 3) (4 2) (3 2 3 2) (2 3 1 1 3) (1
+4 3 1 1) (6 1 2 1) (2 2 1 1 2) (2 4 1 2) (2 4 2 3) (1 5 1 3 1 1) (1 3
+2 6 1) (1 2 2 2 1) (8 1 1 1) (2 1) (5 1) (1 1 2) (2 3) (14))
+'#20(#20(off off off off off off off off off off off on on on on on on
+on off) #20(off off off off off off off off off on on on off off off
+off off on on off) #20(off off off off on on on on on on off off off
+off off off on on on off) #20(off off on on on on off off off off off
+off off off off off off off on) #20(off on on on off off off on on off
+off on on on off off off off on) #20(on on off off off off on on on
+off off on off on off off off on) #20(on off off off on on on on off
+off off on on on off off off on off on) #20(on on on on on on off off
+off on off off off off off off on on off on) #20(off off on on off off
+on on off on off off off off off off on off on) #20(off on on off on
+on on on off on off off off off off off off on on off) #20(on on off
+on on on on off on on off off off off off off off on) #20(on off on on
+on on on off on off off off off on on on off on off on) #20(on off on
+on on off off on on off off off on on on on on on off on) #20(on off
+off off off off on on off off off on on off off off on on off on)
+#20(on on on on on on on on off off off on off off off off off on off
+on) #20(off off off off off off off on on off off off off off off off
+off off off on) #20(off off off off off on on on on on off off off off
+off off off off off on) #20(off off off off off on off off off on off
+off off off off off off off on) #20(off off off off off on on off off
+off off off off off off off off on) #20(off off off off off off on)))
+(make-problem "Hattori 95" '((3 9) (1 2 1 1 1 2) (1 1 1 2) (5 1 3 1)
+(4 1 1) (13) (13) (2 3) (8 3) (11 2) (2 5) (11 1) (1 1 1 1 5) (2 1 1 1
+2) (2 2 3) (5 2 2) (2 1 4 1 2) (3 4 2 2 2) (6 1 2 5) (3 2 5 2 2)) '((4
+3) (1 1 4) (2 2 5) (5 1 1) (4 2 3 3) (4 7 3) (1 5 1 3) (4 2 2 3 2) (1
+3 2 1 1 1) (2 1 2 2 4 2 1) (1 1 2 2 1 1 2 1) (2 1 2 2 1 1 1) (1 3 2 3
+2) (4 2 2 1 2) (3 3 4 3) (4 6 2) (5 3 2) (3 1 2 1) (3 5) (4))
+'#20(#20(on on on on off off off off off off off off off off off off
+off on) #20(on off off on off off off off off off off off off off off
+off on) #20(on on off on on off off off off off off off off off off
+on) #20(off on on on on on off off off off off off off off off on off
+off on off) #20(off off off on on on on off off on on off off on on on
+off on) #20(off off off off on on on on off on on on on on on on off
+on) #20(on off off off off on on on on on off on off off off on on on
+off) #20(on on on on off on on off on on off on on on off off off on
+on off) #20(on off off off on on on off on on off on off off off off
+on off off on) #20(on on off on off on on off on on off on on on on
+off on on off on) #20(on off off on off on on off on on off on off off
+on off on on off on) #20(on on off on off on on off on on off on off
+off off off on off off on) #20(on off off off on on on off on on off
+on on on off off off off on) #20(on on on on off on on off on on off
+on off off off off off on on off) #20(on on on off off on on on off on
+on on on off off on on on off) #20(off off off off off on on on on off
+on on on on on on off off on) #20(off off off off off off on on on on
+on off on on on off off off on) #20(off off off off off off off off on
+on on off on off on on off off on off) #20(off off off off off off off
+off off off on on on off off on) #20(off off off off off off off off
+off off off off off off off off on))) (make-problem "Hattori 96" '((4
+4) (2 3) (5 8) (3 10) (3 3 1 4) (3 2 2 2 1 1) (3 2 1 1 1) (3 2 1 1 2)
+(4 2 1 3) (4 1 3) (9 5) (4 6) (14) (1 1 1 2 4) (3 2 3) (6 3 3) (13 3)
+(4 1 4 4) (3 2 4 1 1) (4 2 5 4)) '((2) (9 1) (1 8 4) (1 9 5) (3 4 5)
+(1 4 4 4) (2 6 3 3 1) (1 3 9 2) (1 2 1 1 1 4) (1 2 3 1 2 1 1) (3 1 1 1
+1 2) (2 3 1 2 4) (2 1 1 5) (3 11) (4 10) (2 6) (5 4 3) (8 1) (7 1)
+(7)) '#20(#20(off on on off) #20(on on on on on on on on on off off
+off off off off off off off off on) #20(on off on on on on on on on on
+off off off off off off on) #20(on off on on on on on on on on on off
+off off off on) #20(on on on off off off off off on on on on off off
+off on) #20(off on off off on on on on off on on on on off on on on on
+off) #20(on on off on on on on on on off on on on off on on on off off
+on) #20(on off on on on off off off on on on on on on on on on off on)
+#20(on off on on off on off off off off on off on off off on on on on
+off) #20(on off on on off on on on off off on off on on off off on off
+off on) #20(off off on on on off off off on off on off on off off off
+on off on) #20(off off on on off on on on off off on off on on off off
+on) #20(off off on on off on off off off off off off on off off on)
+#20(off off on on on off off off off on) #20(off off on on on on off
+off on on on on on on on on on on off) #20(off off off on on off off
+on on on on on on off) #20(off off off off on on on on on off on on on
+on off off off on) #20(off off off off off off off off off off on on
+on on on on on on off on) #20(off off off off off off off off off off
+off on on on on on on on off on) #20(off off off off off off off off
+off off off off off on))) (make-problem "Hattori 97" '((7 3 2) (2 6 3)
+(12 2 4) (3 6 1) (2 4 3 3) (2 1 1 1 1) (3 1 3) (1 1 1 1) (1 2 3 2) (2
+1 4 2) (1 1 1 1) (2 2 3 2) (1 2 1 2) (2 2 2 2) (1 2 2 1 1) (1 2 4 2)
+(1 2 3 4) (1 5 2 3) (2 1 1 1) (16 1)) '((8 5) (6 3 1 2) (3 3 4 1) (1 1
+2 1 1) (1 1 2 1 1) (1 1 2 2 1) (1 1 1 1 2 2 1) (1 1 2 2 2 1 1) (1 1 1
+5 1 1 1) (10 1 1 1 1) (3 2 1 1 1) (5 2 2 1) (2 2 4 1) (5 4) (3 1 1) (1
+1) (1 4) (8 3) (3 1 1 4 7) (3 3 1 1 1)) '#20(#20(off off on on on on
+on on on on off off off off on on on on on off) #20(off on on on on on
+on off off on on on off on off off off off on) #20(off on on on off
+off on on on off off on on on on off off off off on) #20(on off on off
+off off off off on on off off off off on off off off off on) #20(on
+off on off off off off off off off on on off off off on off off off
+on) #20(on off on off off off off off off off off on on off off on on
+off off on) #20(on off on off on off off off off on off off on on off
+off on on off on) #20(on off on off on on off off on on off off off on
+on off off on off on) #20(on off on off on off off off on on on on on
+off on off off on off on) #20(on on on on on on on on on on off on off
+off off on off on off on) #20(off on on on off off off off off off off
+on on off off on off on off on) #20(on on on on on off off off off off
+off off on on off on on off off on) #20(on on off on on off off off
+off off off off off on on on on off off on) #20(on on on on on off off
+off off off off off off off off off on) #20(off on on on off off off
+off off off off off off off off off off on off on) #20(off off off off
+off off off off off off off off off off off off on off off on) #20(off
+off on off off off off off off off off off off off off off on) #20(off
+on on on on on on on on off off off off off off on on on off) #20(on
+on on off on off on off on on on on off on) #20(on on on off on on on
+off off on off on off on off))) (make-problem "Hattori 98" '((3) (7)
+(2 3 3) (8 1 4) (2 3 5) (10) (9) (3 4) (4 10) (3 10) (3 9) (2 4 4) (2
+15) (2 15) (3 13) (4 5 5) (7 7) (18) (17) (13)) '((1 1 8) (3 11) (1 3
+5) (1 2 5) (1 2 3 4) (1 1 4 4) (3 5 4) (5 7 3) (6 3 4 3) (2 2 3 4 3)
+(2 1 2 3 4 3) (2 2 3 4 3) (6 3 4 3) (9 3 4) (8 4 4) (7 9) (5 8) (8)
+(6) (4)) '#20(#20(off off on off on off off off off on on on on on on
+on on off) #20(off off on on on off off off on on on on on on on on on
+on on off) #20(off off off on off off off off on on on off off off on
+on on on on off) #20(off off off on off off off on on off off off off
+off off on) #20(off off off on off off off on on off on on on off off
+off on) #20(off off off on off off off on off off on on on on off off
+on) #20(off off on on on off off off off on on on on on off off on)
+#20(off on on on on on off off on on on on on on on off off on)
+#20(off on on on on on on off on on on off on on on on off on) #20(on
+on off off off on on off on on on off on on on on off on) #20(on on
+off on off on on off on on on off on on on on off on) #20(on on off
+off off on on off on on on off on on on on off on) #20(off on on on on
+on on off on on on off on on on on off on) #20(off on on on on on on
+on on on off off on on on off on) #20(off off on on on on on on on on
+off on on on on off on) #20(off off off on on on on on on on off on)
+#20(off off off off on on on on on off off on on on on on on on on
+off) #20(off off off off off off off off off off off on on on on on on
+on on off) #20(off off off off off off off off off off off off on on
+on on on on off) #20(off off off off off off off off off off off off
+off on on on on off))) (make-problem "Hattori 99" '((8) (14) (14) (14)
+(8 1) (1 1) (1 1) (1 1) (1 1) (1 1) (1 1) (1 1) (1 1) (1 4) (4 6) (6
+7) (7 7) (7 6) (6 4) (4)) '((3) (5) (5) (6) (6) (5) (17) (4) (4) (4)
+(4) (4) (5) (5 3) (4 5) (4 5) (4 6) (4 6) (4 5) (17)) '#20(#20(off off
+off off off off off off off off off off off off off off on on on off)
+#20(off off off off off off off off off off off off off off off on)
+#20(off off off off off off off off off off off off off off off on)
+#20(off off off off off off off off off off off off off off on)
+#20(off off off off off off off off off off off off off off on)
+#20(off off off off off off off off off off off off off off on on on
+on on off) #20(off on on on on on on on on on on on on on on on on on
+off) #20(off on on on on off) #20(off on on on on off) #20(off on on
+on on off) #20(off on on on on off) #20(off on on on on off) #20(on on
+on on on off) #20(on on on on on off off off off off off off off off
+off on on on off) #20(on on on on off off off off off off off off off
+off on on on on on off) #20(on on on on off off off off off off off
+off off off on on on on on off) #20(on on on on off off off off off
+off off off off on on on on on on off) #20(on on on on off off off off
+off off off off off on on on on on on off) #20(on on on on off off off
+off off off off off off on on on on on off) #20(on on on on on on on
+on on on on on on on on on on off))) (make-problem "Hattori 100" '((3
+7) (4 9 2) (4 10 1) (4 1 6 1) (5 1 1 1 2 1) (5 1 1 1 2 1) (5 7 2 1)
+(16 1) (11 1) (3 8 2) (2 1 11) (2 14) (3 13) (5 11) (3 6 3 3) (2 4 2 4
+1) (1 3 2 7) (6 4 2 5) (3 3 2 2 1) (4 3 2)) '((7 3 3) (7 5 1 2) (8 1 3
+2) (7 2 2 2) (4 3 2 1) (1 3 3 1) (3 2 3 2) (3 2 2 3) (9 5 2) (3 9 2)
+(3 1 12) (3 10 2) (14 4) (4 11 1) (4 1 10) (4 12) (8 4 5) (6 2 2 2 1)
+(1 3 2 2) (10 2 2)) '#20(#20(on on on on on on on off off off on on on
+off off on on on off) #20(on on on on on on on off off on on on on on
+off on off on on off) #20(on on on on on on on on off on off off on on
+on off off on on off) #20(off on on on on on on on off on on off off
+on on off off on on off) #20(off off off off on on on on off off off
+off on on on off on on off on) #20(off off off off off off off on off
+off off on on on off on on on off on) #20(off off off off off off on
+on on off off on on off on on on off on) #20(off off off off off off
+on on on off off on on off on on off on) #20(off on on on on on on on
+on on off on on on on on off on on off) #20(on on on off off off on on
+on on on on on on on off on on off) #20(on on on off on off on on on
+on on on on on on on on on off) #20(on on on off off off on on on on
+on on on on on on off off on) #20(on on on on on on on on on on on on
+on on off off on) #20(on on on on off off off on on on on on on on on
+on on on off on) #20(on on on on off on off on on on on on on on on on
+on off) #20(on on on on off off off on on on on on on on on on on on
+on off) #20(off on on on on on on on on off on on on on off on)
+#20(off off on on on on on on off off on on off on on off on on off
+on) #20(off on off off off off off off off on on on off on on off on
+on off) #20(off on on on on on on on on on on off off off on on off on
+on off))) (make-problem "Hattori 101" '((5) (7) (9) (1 1 1 1) (1 1) (1
+2 1) (2 2) (1 4 1 1) (6 4 7) (1 2 4 2 2) (1 4 4 7) (1 1 1 1 1 1) (3 1
+1 1 1) (4 8 1 1) (1 3 1) (1 7 1) (1 4 4 1) (2 9 2) (1 5 5 1) (11))
+'((1) (6 3) (1 2 2) (1 4) (1 1 1 2) (1 3 2 4) (11 7) (3 1 1 5) (4 7 5)
+(3 1 4 1 1 1 1) (4 1 4 1 5) (3 7 5) (6 7) (6 1 4) (3 3 2) (1 1) (1 1)
+(1 1 2) (3 5) (4)) '#20(#20(off off off off off off off off off off
+off off off on off) #20(off off off off off off off off on on on on on
+on off on on on off) #20(off off off off off off off off on off off
+off on on off off off on on off) #20(off off off off off off off off
+on off on on on on off) #20(off off on off off off off off on off on
+off off off off off off off on) #20(off off on off off off off off on
+on on off on on off off on) #20(off on on on on on on on on on on on
+off on) #20(on on on off off off on off off off off off off on off on)
+#20(on on on on off off off on on on on on on on off on) #20(on on on
+off off on off on on on on off off on off on off on off on) #20(on on
+on on off on off on on on on off off on off on) #20(on on on off off
+off off on on on on on on on off on) #20(off on on on on on on off off
+off off off off on) #20(off off off off off off on on on on on on off
+off on off on) #20(off off off off off off off off on on on off on on
+on off off off on) #20(off off off off off off off off on off on off)
+#20(off off off off off off off off on off on off) #20(off off off off
+off off off off on off on off off off off off off on on off) #20(off
+off off off off off off off on on on off off on on on on on off)
+#20(off off off off off off off on on on on off))) (make-problem
+"Hattori 102" '((2 7) (1 5 3) (2 7 2 2 1) (1 2 2 2 2 1) (1 2 2 3 1) (1
+2 4 6) (4 6 5) (3 6 4) (1 4 1) (3 1 3 1) (6 5 1) (7 5 2) (3 5 3 1) (1
+1 1 6 2) (1 2 1 2 3) (1 4 1 5 1) (1 4 4 3) (7 1) (1 1) (4)) '((1 5) (5
+1) (1 9) (3 4 3 2) (6 3 1 2) (3 2 2) (2 2 8) (4 9 2) (4 4 3 1 1) (3 4
+2 1 1) (1 5 6 1) (1 2 2 2 5 1) (1 2 4 5) (3 4 2) (1 2 4 2) (2 4 2 1)
+(6 4) (5 3 1) (7 3) (4)) '#20(#20(off off on off off off off off off
+off off off on on on on on off) #20(off off on on on on on off off off
+off off on off) #20(on off off off off off on on on on on on on on on
+off) #20(on on on off on on on on off on on on off off on on off)
+#20(off off on on on on on on off on on on off on off on on off)
+#20(off on on on off off off off off off on on off off off on on off)
+#20(off on on off off off on on off off on on on on on on on on off)
+#20(on on on on off on on on on on on on on on off off on on off)
+#20(on on on on off on on on on off off on on on off on off on off)
+#20(on on on off off on on on on off off off on on off off off on off
+on) #20(on off off off on on on on on off off off on on on on on on
+off on) #20(on off off on on off on on off off on on off on on on on
+on off on) #20(on off on on off off off off off on on on on off off
+on) #20(on on on off off off off off off on on on on off off on on
+off) #20(off on off off off on on off off on on on on off on on off)
+#20(off on on off on on on on off off on on off off on off) #20(off
+off on on on on on on off off off off off on on on on off) #20(off off
+off on on on on on off off off on on on off off on off) #20(off off
+off off off on on on on on on on off off off off on on on off) #20(off
+off on on on on off))) (make-problem "Hattori 103" '((7) (2 2) (1 2 2
+1) (1 1 1 1) (1 5 1) (1 1 1 1) (9) (9) (1 1 2) (9 4) (9 4) (9 2) (9)
+(1 1 7) (9 7) (10 2) (1 1 2) (10 2) (9 2) (9 2)) '((3) (1 1) (1 1) (1
+4) (1 2 1) (12 2 3) (2 2 4 2 3) (1 1 4 4 2 3) (1 3 2 7 3) (1 1 2 3 1
+3) (1 3 2 3 1 3) (1 1 4 3 1 3) (2 2 3 5) (11 2 2) (2) (2 2) (4 7) (4
+7) (2 2) (2)) '#20(#20(off off off off off off off off off off off off
+on on on off) #20(off off off off off off off off off off off off on
+off on off) #20(off off off off off off off off off off off off on off
+on off) #20(off off off off off off off off off off off off on off on
+on on on off) #20(off off off off off off off off off off off off on
+off on on off on off) #20(off on on on on on on on on on on on on off
+on on off on) #20(on on off off off off on on off on on on on off on
+on off on) #20(on off on off on on on on off on on on on off on on off
+on) #20(on off on on on off on on off on on on on on on on off on)
+#20(on off off off on off on on off on on on off off off on off on)
+#20(on off on on on off on on off on on on off off off on off on)
+#20(on off on off on on on on off on on on off off off on off on)
+#20(on on off off off off on on off on on on off off off on) #20(off
+on on on on on on on on on on on off on on off off off on) #20(off off
+off off off off off off off off off off off on on off) #20(off off off
+off off off off off off on on off off on on off) #20(off off off off
+off off off off on on on on off on) #20(off off off off off off off
+off on on on on off on) #20(off off off off off off off off off on on
+off off on on off) #20(off off off off off off off off off off off off
+off on on off))) (make-problem "Hattori 104" '((11) (1 1) (1 1) (2 1 1
+1) (5 1) (3 1) (5 1) (7 1) (9 1) (9 1) (8 1) (6 4 1) (1 3 1) (3 2 3 1)
+(2 1 4 1) (1 3 5 1) (1 1 4 1) (5 5) (7 4 1) (9 5)) '((3) (3) (6) (2 3)
+(1 1 3) (3 1 2) (2 1 2 2) (1 5 1) (2 6 1) (1 8) (12) (1 7 2) (1 2 6 1
+1) (1 5 1 1) (1 9 2) (1 9) (1 8) (1 5) (1 1) (19)) '#20(#20(off off
+off off off off off off off off off off off off off off off on)
+#20(off off off off off off off off off off off off off off off off
+off on) #20(off off off off off off off off off off off off off off
+on) #20(off off off off off off off off off off off off off on on off
+off on) #20(off off off off off off off off off off off off off on off
+on off on) #20(off off off off off off off off off off off on on on
+off on off off on) #20(off off off off off off off off on on off on
+off off off on on off on) #20(off off off on off off off on on on on
+on off off off off off off off on) #20(off off off on on off on on on
+on on on off off off off off off off on) #20(on off off off on on on
+on on on on on off) #20(on on on on on on on on on on on on off)
+#20(on off off off on on on on on on on off off on on off) #20(on off
+off on on off on on on on on on off on off off off off off on) #20(on
+off off off off off off on on on on on off off off on off off off on)
+#20(on off off off off off off off on on on on on on on on on off on)
+#20(on off off off off off off off off off off on) #20(on off off off
+off off off off off off off off on) #20(on off off off off off off off
+off off off off off off on on on on on off) #20(on off off off off off
+off off off off off off off off off off off on off) #20(on on on on on
+on on on on on on on on on on on on on on off))) (make-problem
+"Hattori 105" '((3) (2 6) (2 2 2) (2 2 2) (13) (1 2) (1 3 3 1) (1 1 1
+1 1 1) (1 3 3 1) (3 1) (1 4 1) (1 4 1 1) (1 1 2 1 2 1) (1 1 2 1 1 1)
+(4 2 3 1) (1 2) (2 1) (3 2) (4 2) (11)) '((6) (1 1) (7 3) (3 3) (2 1 3
+2) (2 1 1 1 1 1) (1 1 3 4 2) (2 1 4 1) (2 1 3 1 1) (4 1 1 2) (1 2 3 5
+1) (1 1 1 1 1) (2 1 1 3 1) (3 1 1 1) (3 1) (11 1) (3 1) (3) (2) (1))
+'#20(#20(off off off off off off off off off on on on on on on off)
+#20(off off off off off off off off off on off off off off on off)
+#20(off off off on on on on on on on off off on on on off) #20(off off
+on on on off off off off off off off off off on on on off) #20(off on
+on off on off on on on off off off off off off off on on off) #20(on
+on off off on off on off on off off on off off off off off on off)
+#20(on off off off on off on on on off off on on on on off off on on
+off) #20(on on off off on off off off off off off on on on on off off
+off on off) #20(off on on off on off on on on off off on off off off
+off off off on off) #20(off on on on on off on off on off off off off
+off off off off off on) #20(off on off on on off on on on off on on on
+on on off off off off on) #20(off on off off on off off off off off on
+off off off on off off off off on) #20(off on on off on off off off
+off off on off on on on off off off off on) #20(off off on on on off
+off off off off on off on off off off off off off on) #20(off off off
+on on on off off off off off off off off off off off off off on)
+#20(off off off off off on on on on on on on on on on on off off off
+on) #20(off off off off off off off off off off off off off off off on
+on on off on) #20(off off off off off off off off off off off off off
+off off off off on) #20(off off off off off off off off off off off
+off off off off off off off on) #20(off off off off off off off off
+off off off off off off off off off off off on))) (make-problem
+"Hattori 106" '((3 3 4) (2 1 3 1 2 1) (1 9 1 4) (13 1) (9 4) (3 4 1)
+(1 2 3 1 4) (1 7 1 1 2 1) (2 1 3 2 4 1) (2 1 1 2 1) (2 1 2 2 1) (1 1 1
+4) (1 1 1 1 1) (2 1 2 3) (1 1 1 1) (1 1 1 4) (1 3 1 2 1) (1 5 1 4) (1
+7 1 2 1) (13 4)) '((1 1 6) (3 4 4 1) (1 1 2 1) (8 1) (5 2 2) (1 3 1 3)
+(5 2 4) (4 13) (5 2 4) (1 3 2 3) (5 1 2) (7 1) (1 1 3 1) (3 1 4 1) (1
+4 6) (1) (20) (1 1 1 6 1 5) (1 1 1 1 3 1 1 1) (1 1 1 6 5))
+'#20(#20(off on off off off off off off on off off off off on on on on
+on on off) #20(off on on on off on on on on off on on on on off off
+off off off on) #20(off off off on off on off off off on on off off
+off off off off off off on) #20(off off on on on on on on on on off
+off off off off off off off off on) #20(on on on on on off on on off
+off off off off off off off off off on) #20(on off on on on off off on
+off off off off off off off off off on) #20(on on on on on off off on
+on off off off off off off off on) #20(off on on on on off off on)
+#20(on on on on on off off on on off off off off off off off on)
+#20(on off on on on off on on off off off off off off off off off on)
+#20(on on on on on off on off off off off off off off off off off off
+on) #20(off off on on on on on on on off off off off off off off off
+off off on) #20(off off off on off on off off on on on off off off off
+off off off off on) #20(off on on on off on off off off off on on on
+on off off off off off on) #20(off on off off off on on on on off off
+off off on on on on on on off) #20(off off off off off off off off on
+off) #20(on) #20(on off on off on off on on on on on on off on off on)
+#20(on off on off on off on off off off off on on on off on off on off
+on) #20(on off on off on off on on on on on on off off off on)))
+(make-problem "Hattori 107" '((1) (1 5) (1 1 1 1) (1 8) (1 4 1 2) (1
+14) (1 4 9 1) (1 1 1 3) (2 12 2) (5 2 1 2 6) (8 8) (1 2 2 2 2 3) (1
+13) (1 4 4) (1 1 1 1) (1 1 1 1) (1 7) (1 1 1) (1 3 3) (1 1 1)) '((3)
+(19) (2) (2 5) (3 6) (4 1 1 2) (15 1) (1 3 6 4) (1 1 2 1 1 1 1) (7 2 1
+3) (1 1 2 1 1 1 1) (1 4 6 4) (15 1) (2 1 1 2) (2 6) (2 4) (2 2) (5)
+(6) (1 1 1)) '#20(#20(off off off off off off off off on on on off)
+#20(off on) #20(off off off off off off off off off on on off) #20(off
+off off off off on on off on on on on on off) #20(off off off off on
+on on off on on on on on on off) #20(off off off on on on on off on
+off on off on on off) #20(off off on on on on on on on on on on on on
+on on on off on off) #20(off on off on on on off off on on on on on on
+off off on) #20(off on off on off on on off on off off off on off off
+off on off on off) #20(on on on on on on on off on on off off on off
+on on on off) #20(off on off on off on on off on off off off on off
+off off on off on off) #20(off on off on on on on off on on on on on
+on off off on) #20(off off on on on on on on on on on on on on on on
+on off on off) #20(off off off off off on on off on off on off on on
+off) #20(off off off off off on on off on on on on on on off) #20(off
+off off off off on on off off on on on on off) #20(off off off off off
+on on off off on on off) #20(off off off off off off off on on on on
+on off) #20(off off off off off off on on on on on on off) #20(off off
+off off off off off on off on off on off))) (make-problem "Hattori
+108" '((11 7) (1 2 1 1 9) (1 1 1 3 10) (6 2 1 10) (1 4 1 10) (1 4 1 1
+5) (1 1 3 1 1) (1 2 1 2 1 4 3) (3 1 3 4 3) (1 1 1 2 1 1 1) (11 4 3) (1
+1) (1 1 6) (1 1 1 6) (1 4 1 4) (1 2 1 2 2) (3 1 1 5) (5 3 1 1) (6 2 1
+1 1) (6 2 1 11) (2 4 1 8) (1 4 2 8) (12 12) (4 1 8) (4 3 2 1) (4 3 2 2
+1) (4 1 8 1) (4 1 1) (4 4 1) (6 15)) '((16 4) (1 1 1 1 8) (2 1 2 1 3
+7) (4 3 1 3 8) (1 3 1 4 1 4) (11 6 1 2) (1 3 1 8 1) (1 2 2 1 6 2) (1 2
+2 1 3 5) (1 1 1 1 2 2 1 1) (11 6 1 2 2) (1 1 3 1) (2 5 2 1) (2 2 2 1)
+(5 1 1 1) (3 1 1 1 1) (15 1 1 1 1) (4 4 2 5 1 1) (5 2 1 2 1 5 1 1) (5
+4 3 1 8 1) (6 3 1 8 1) (6 3 8 1) (6 4 3 5 1) (6 2 1 2 5 1) (6 4 11))
+'#25(#30(on on on on on on on on on on on on on on on on off off off
+off off off on on on on off) #30(on off off on off off off off on off
+on off off off off off off off off off on on on on on on on on off)
+#30(on on off on off off off on on off on off off off off off off off
+on on on off on on on on on on on off) #30(on on on on off on on on
+off off on off off off off off off on on on off off on) #30(on off off
+on on on off off off off on off off off off off on on on on off off on
+off off off on) #30(on on on on on on on on on on on off off off off
+on on on on on on off on off off off off off on) #30(on off off off on
+on on off off off on off off off off on on on on on on on on off off
+off off off off on) #30(on off off on on off on on off off on off off
+off off off off on on on on on on off off off off off on) #30(on off
+on on off off off on on off on off off off off off off off off off on
+on on off off on) #30(on off on off off off off off on off on off off
+off off off off off on on off on on off off on off off on off) #30(on
+on on on on on on on on on on off off off on on on on on on off off on
+off on on off off on) #30(off off off off off off off off off off off
+off off off on off off on off off off off on on on off off off off on)
+#30(off off off off off off off off off off off off off on on off off
+on on on on on off off on on off off off on) #30(off off off off off
+off off off off off off off off off on on off off off off off on on
+off off on on off off on) #30(off off off off off off off off off off
+off off off off off on on on on on off off on off off off on off off
+on) #30(off off on on on off off off off off off off off off off off
+off off off on off off on off off off on off off on) #30(off on on on
+on on on on on on on on on on on on off off off on off off on off off
+off on off off on) #30(off on on on on off off on on on on off off off
+off on on off off on on on on on off off on off off on) #30(on on on
+on on off off on on off on off on on off off on off off on on on on on
+off off on off off on) #30(on on on on on off off on on on on off on
+on on off on off off on on on on on on on on off off on) #30(on on on
+on on on off off off off off off on on on off on off off on on on on
+on on on on off off on) #30(on on on on on on off off off off off off
+on on on off on on on on on on on on off off off off off on) #30(on on
+on on on on off on on on on off on on on off off off off on on on on
+on off off off off off on) #30(on on on on on on off on on off on off
+on on off off off off off on on on on on off off off off off on)
+#30(on on on on on on off on on on on off off off off off off off off
+on))) (make-problem "Hattori 109" '((11 7) (13 11) (16 13) (31) (9 18)
+(7 17) (4 1 1 1 2 8) (3 1 1 1 1 2 6) (3 2 3 1 2 2 6) (3 1 1 2 2 5) (5
+2 1 8 4) (4 2 3 1 1 1 4) (3 3 1 1 1 3) (4 4 1 2 5) (1 7 6 1 2) (2 1 2
+2 1 2 3) (4 1 2 2 2 5) (4 11 4 1) (10 2 2 1 3) (20 1 1 2) (2 4 3 3 3 2
+4) (1 2 4 2 2 5 1) (1 5 1 1 1 2 3 1 1) (1 1 5 6 1 2 5) (1 1 5 4 1 1 1
+1) (1 1 1 5 1 1 1) (1 1 5 5 1) (1 3 4 2 1) (1 2 3 6 1) (4 4 3 3 2 1)
+(17 12) (10 7 9)) '((8 8 1) (10 3 2 2) (13 4 4) (7 4 4 3) (6 2 4 6 3)
+(6 1 8 3) (6 8 2) (5 2 5 2) (5 1 2 1 2 3 2) (4 1 1 3 4 3) (4 3 1 4 6 1
+2) (4 2 1 1 3 2 5) (4 4 21) (4 8 2) (4 1 2 1 2 10) (12 1 3 9) (4 18)
+(7 6 5 2) (13 1 1 3 2 2) (5 1 1 7 4) (6 1 3 1 4) (6 4 1 2 2 3 2 2) (6
+2 2 1 2 2) (6 1 4 2 4) (7 1 1 2 2 3 3) (7 1 1 1 1 2) (9 2 1 1 2) (9 1
+2 3 1 2) (11 1 1 2 4 1) (13 2 2 1 1 1) (16 2 1 1) (13 10))
+'#32(#32(off off off on on on on on on on on off off off off off off
+off on on on on on on on on off off off off off on) #32(off off on on
+on on on on on on on on off off off off off off on on on off off off
+off off on on off off on) #32(off on on on on on on on on on on on on
+on off off on on on on off off off off off off off off on) #32(on on
+on on on on on off off off on on on on off off on on on on off off off
+off off off off off off on) #32(on on on on on on off on on off on on
+on on off on on on on on on off off off off off off off off on) #32(on
+on on on on on off off on off off off off on on on on on on on on off
+off off off off off off off on) #32(on on on on on on off off off off
+off off off off off off off off on on on on on on on on off off off
+off on) #32(on on on on on off off off off off on on off off off off
+off off on on on on on off off off off off off off on) #32(on on on on
+on off off off on off on on off off on off off off on on off off on on
+on off off off off off on) #32(on on on on off off off off on off off
+off off off on off off on on on off on on on on off off off off on)
+#32(on on on on off off on on on off off on off off on on on on off on
+on on on on on off off on off on on off) #32(on on on on off off off
+off off off off on on off on off off on off on on on off on on off off
+on) #32(on on on on off off on on on on off on) #32(on on on on off
+off off off off off off off on on on on on on on on off off off off
+off off off off off off on) #32(off on on on on off off off on off off
+off off on on off off on off on on off on) #32(off off on on on on on
+on on on on on on on off off off on off on on on off on) #32(off off
+on on on on off off off off off off off off on) #32(off off off on on
+on on on on on off off off off on on on on on on off off off on on on
+on on off off on) #32(off off on on on on on on on on on on on on on
+off off on off on off on on on off on on off on on off) #32(off on on
+on on on off off off off on off off off on off off on on on on on on
+on off off off off on) #32(on on on on on on off off off off on off
+off off on on on off off off on off off off off off off off on) #32(on
+on on on on on off off off on on on on off on off on on off on on off
+on on on off off on on off on) #32(on on on on on on off off off on on
+off off off off off off on on off off off on off off off off on on off
+on) #32(on on on on on on off off off off on off off off off off off
+on on on on off on on off off off off on) #32(on on on on on on on off
+off off on off off on off off off on on off on on off on on on off off
+off on) #32(on on on on on on on off off off on off off on off off off
+off off off off on off off off off on off off off on) #32(on on on on
+on on on on on off off off off off on on off off off off off on off
+off off off on off off off on) #32(off on on on on on on on on on off
+off off on off on on off off off off on on on off off on off off off
+on) #32(off on on on on on on on on on on on off on off off on off off
+off on on off on on on on off off off on off) #32(off on on on on on
+on on on on on on on on off on on off off on on off off on off off on
+off off off on off) #32(off off on on on on on on on on on on on on on
+on on on off on on off off on off off off off off off on off) #32(off
+off off off on on on on on on on on on on on on on off off off on on
+on on on on on on on on off))) (make-problem "Hattori 110" '((2 2 8 5)
+(3 1 2 1 4 1 1 3) (1 3 8 7 2) (3 4 2 2 4 4 2) (2 1 5 2 2 5 4) (2 1 5 1
+5 3) (4 1 2) (4 3 2) (4 2) (4 6 2) (5 10 3) (1 8 1) (30) (1 5 5 6 7 1)
+(11 3 1 2 1) (3 8 8 1) (1 23) (1 2 9 9 1) (1 3 10 5 2 1) (1 6 1 2 3 1
+1 2 1) (3 2 14 1 1 1) (1 1 2 13 1 2 1) (1 1 4 6 1 1) (2 1 2 7 2 1) (2
+2 1 1 1) (2 2 2 2) (1 5 2 2) (1 4 2 2) (1 5 2 2) (1 7 3 2) (1 10 7 2)
+(30)) '((2 4 5) (3 5 2 2 1) (1 8 1 2 2 1) (12 1 4 1) (2 1 4 2 1) (1 1
+1 6 2 1) (2 2 7 3) (1 2 3 1 2 1 5) (4 1 8 5) (5 6 2 2 5) (2 2 8 1 1 6)
+(4 10 2 1 4) (5 12 1 3) (1 1 7 3 2 2) (1 2 3 10 2 2) (1 2 5 4 4 2) (2
+4 5 6 1 1) (2 1 5 1 6 1) (2 1 5 3 4 1) (2 1 5 8 1) (1 2 5 3 5 2) (1 2
+3 9 2 2) (5 1 7 4 1 2) (4 9 1 1 3) (2 2 2 4 2 1 6) (4 8 1 5) (4 2 3 2
+2) (1 2 5 1 1 1) (1 2 3 2 1) (2 2 1 1 2 1) (16 1 7) (11 14))
+'#32(#32(on on off off off off on on on on off off off off off off
+unknown unknown unknown unknown unknown unknown unknown unknown
+unknown unknown unknown unknown unknown unknown unknown off) #32(on on
+on off off off on on on on on off on on off off unknown unknown
+unknown unknown unknown unknown unknown unknown unknown unknown
+unknown unknown unknown unknown unknown off) #32(off on off on on on
+on on on on on off on off off off unknown unknown unknown unknown
+unknown unknown unknown unknown unknown unknown unknown unknown
+unknown unknown off on) #32(off off on on on on on on on on on on on
+on off off unknown unknown unknown unknown unknown unknown unknown
+unknown unknown unknown unknown unknown unknown unknown off on)
+#32(off off on on off off off off off off on off on on on on off off
+unknown unknown unknown unknown unknown unknown unknown unknown
+unknown unknown unknown unknown off on) #32(off off on off off on off
+off off off on off on on on on on on off unknown unknown unknown
+unknown unknown unknown unknown unknown unknown unknown off off on)
+#32(on on off on on off off off off off off off on on on on on on on
+off off off off off off off off off off on) #32(on off on on off off
+off off off off off off on on on off on off on on off on off off off
+off off on) #32(off off on on on on off off off off off off on off on
+on on on on on on on off off off off off on) #32(off on on on on on
+off off off off off off on on on on on on off on on off on on off off
+off on) #32(off on on off on on off off off off off off on on on on on
+on on on off on off off on off on) #32(off off on on on on off off off
+off off off on on on on on on on on on on off on on off on off on)
+#32(off on on on on on off off off off off off on on on on on on on on
+on on on on off off on off off on) #32(off off on off off off off off
+off off on off on on on on on on on off on on on off off on on off off
+off on) #32(on off on on off off off off off off on on on off on on on
+on on on on on on on off on on off off off on) #32(on off off on on
+off off off off on on on on on off on on on on off on on on on off off
+off off off off on) #32(on on off off on on on on off on on on on on
+off off on on on on on on off on off off off off off off off on)
+#32(on on off off off off off on off on on on on on off off on off on
+on on on on on off off off off off off off on) #32(on on off off off
+off off on off on on on on on off off on on on off on on on on off off
+off off off off off on) #32(on on off off on off off off off on on on
+on on off off on on on on on on on on off off off off off off off on)
+#32(on off off on on off off off off on on on on on off on on on off
+on on on on on off off off off off off on) #32(on off on on off off
+off off off off on on on off on on on on on on on on on off on on off
+off off off on) #32(off on on on on on off off off off on off on on on
+on on on on off on on on on off on off off off off on) #32(off off on
+on on on off off off off off off on on on on on on on on on off off on
+off off on off off on) #32(off on on off on on off off off off off off
+on on off on on on on off on on off off on off on) #32(off off on on
+on on off off off off off off on on on on on on on on off off on off
+off off off on) #32(off off on on on on off off off off off off on on
+off on on on off off on on off off off off off off off off on) #32(on
+off on on off off off off off off off off on on on on on off on off
+off on off off off off off off off off off on) #32(on off off on on
+off off off off off off off on on on off off off on on off off off off
+off off off off off off off on) #32(on on off off on on off off off
+off on off on off off off off off off on on off off off off off off
+off off off off on) #32(on on on on on on on on on on on on on on on
+on off on off off off off off off off on) #32(on on on on on on on on
+on on on off off off off off off off on))) (make-problem "Hattori 111"
+'((7) (1 1 2 6) (2 2 1 7) (5 1 8) (8 1 9) (5 1 10) (3 1 10) (2 2 6)
+(5) (1 4) (1 1 6) (3 1 8) (4 1 1 7) (1 3 1 1 1 3) (3 1 1 1 2) (6 3 1
+1) (1 2 2 1 4 1) (8 3 6) (3 2 1 1 10) (8 1 6) (5 3 12) (2 4 2 1 5) (4
+4 1 8) (6 1 2 3 1) (3 2 1 1 4) (1 3 4 1 1 1 2) (4 2 1 1 2 2 1) (2 8 4)
+(7 2) (2 1 1 1 3)) '((2 9 3 4) (3 2 2 8 2) (1 4 10 5) (7 2 3 5 2) (3 3
+5 3) (4 5 4) (3 2 5 2) (2 4 1 3 1) (4 1 3) (1 4) (7 1 3) (2 2 6 2) (1
+8 1 4 3) (1 1 4 1 4) (2 2 4 1 1 1 2) (9 2 2 1 1) (8 3 1 3 1 4) (8 4 4
+2 2) (7 4 6 1 1) (7 5 13) (5 14 4) (5 4 8) (4 1 5 1) (3 1 1 2) (2 5))
+'#25(#30(off off off off on on off off off off on on on on on on on on
+on off on on on off on on on on off) #30(off off off off on on on off
+off off off on on off on on off on on on on on on on on off on on off)
+#30(off off on off on on on on off off off on on on on on on on on on
+on off on on on on on off) #30(off on on on on on on on off off off
+off on on off on on on off on on on on on off on on off) #30(off off
+off on on on off off off off off off off on on on off on on on on on
+off on on on off) #30(off on on on on off off off off off off off off
+off off on on on on on off on on on on off) #30(off off on on on off
+off off off off off off off off off off on on off on on on on on off
+off on on off) #30(off off off on on off off off off off off off off
+off off off off on on on on off on off off on on on off on) #30(off
+off off off off off off off off off off off off off off off off off
+off on on on on off off on off on) #30(off off off off off off off off
+off off off off off off off off off off off off off on off off off on
+on on on off) #30(off on on on on on on on off off off off off off off
+off off off off off off off off off off on off on) #30(on on off off
+off off off on on off off off off off off on on on on on on off off
+off off off off on on off) #30(on off off off off off off off on on on
+on on on on on off on off off on on on on off off off on) #30(on off
+off off off off off off on off off off off off off on on on on off on
+off off off off on on on on off) #30(on on off off off off off on on
+off off on on on on off on off on off on off off off off off off off
+on) #30(on on on on on on on on on off on on off off off on on off on
+off on off) #30(on on on on on on on on off on on on off on off off on
+on on off on off off on on on on off) #30(on on on on on on on on off
+on on on on off off off off on on on on off on on off off on on off)
+#30(off on on on on on on on off on on on on off off off off on on on
+on on on off off off off on off on) #30(off on on on on on on on off
+on on on on on off off off on) #30(off off on on on on on off off off
+on on on on on on on on on on on on on on off off on) #30(off off on
+on on on on off off off off on on on on off off on on on on on on on
+on off) #30(off off off on on on on off off off off off on off off off
+off off on on on on on off on off) #30(off off off off on on on off
+off off off off on off off off off off off off off off on off on on
+off) #30(off off off off off on on off off off off off off off off off
+off off off off off off on on on on on off))) (make-problem "Hattori
+112" '((3 6) (9 4) (1 1 1 5) (2 2 2 3) (1 1 1 1) (1 2 1) (15 1) (4 1
+4) (3 1 4) (3 5) (7) (6 1) (7 2) (8 1 3) (7 3 3) (1 2 1 1 6) (1 3 4)
+(1 2 1) (1 1 2) (20)) '((1 1) (2 1) (3 1) (1 4 1 1) (1 9 1) (3 1 7 1)
+(2 2 1 5 1) (3 15) (2 2 1 7 1) (3 1 7 1) (1 5 4 1) (1 4 1) (3 6) (2 2
+2 1) (1 1 1 3 1) (1 2 1 1) (3 1 3 2) (6 7) (4 5 1) (7 3 2 1))
+'#20(#20(off off off off off off on off off off off off off off off
+off off off off on) #20(off off off off off off on on off off off off
+off off off off off off off on) #20(off off off off off off on on on
+off off off off off off off off off off on) #20(off on off off off off
+on on on on off off off on off off off off off on) #20(off on off off
+off off on on on on on on on on on off off off off on) #20(off on on
+on off off on off off on on on on on on on off off off on) #20(on on
+off on on off on off off off on on on on on off off off off on) #20(on
+on on off off on) #20(on on off on on off on off off on on on on on on
+on off off off on) #20(off on on on off off on off on on on on on on
+on off off off off on) #20(off on off off off off on on on on on off
+on on on on off off off on) #20(off on off off off off on on on on off
+off off off off off off off off on) #20(off off off off off off on on
+on off off off off off on) #20(off off off off off off on on off off
+off off off on on off on on off on) #20(on off off on off off on off
+off off off off off off on on on off off on) #20(on off on on off off
+off off off off off off off off off on off off off on) #20(on on on
+off off on off off off off off off off off on on on off on) #20(on on
+on on on on off off off off off off off on) #20(on on on on off off
+off off off off off off on on on on on off off on) #20(on on on on on
+on on off off off off on on on off on on off off on))) (make-problem
+"Hattori 113" '((9) (1 3) (1 1 1 3) (4 1 1) (1 4 1 1 1) (2 1 3 1) (4 2
+6) (1 3 1) (1 1 1 1) (1 3 7 1) (8 1) (1 7 1) (10) (3 1 2 1) (5 1 4) (5
+1 1) (5 7) (3 1 1) (1 1) (10 5 3)) '((3 1) (2 5 1) (1 1 1 1 5 1) (1 2
+5 1) (1 1 3 1) (1 1 1) (6 1) (1 1 1) (1 1 1) (3 1 1 1) (1 3 9) (1 1 2
+4 1 1) (1 1 2 4 4) (1 1 1 4 1 1) (1 2 4 4) (3 2 4 1 1) (5 1 9) (3 1 3
+1) (1 1 1 1) (9 1)) '#20(#20(off off off off off off off off off off
+off off off off on on on off off on) #20(off off off on on off off off
+off off off off off on on on on on off on) #20(off off off on off on
+off off off on off on off on on on on on off on) #20(off off off on
+off on on off off off off off off on on on on on off on) #20(off off
+off on off off on off off off off off off off on on on off off on)
+#20(off off off off on off on off off off off off off off off off off
+off off on) #20(off off off off on on on on on on off off off off off
+off off off off on) #20(off off off off on off off off off on off off
+off off off off off off off on) #20(off off off off on off off off off
+on off off off off off off off off off on) #20(on on on off off on off
+off off off on off off off off off off off off on) #20(on off off on
+on on off off on on on on on on on on on off) #20(on off on off off on
+on off off on on on on off off off on off off on) #20(on off off off
+on off on on off on on on on off off off on) #20(on off on off off off
+off on off on on on on off off off on off off on) #20(on off off off
+off off on on off on on on on off off off on) #20(on on on off off on
+on off off on on on on off off off on off off on) #20(on on on on on
+off on off on on on on on on on on on off) #20(on on on off off off on
+off off off off off on on on off off off off on) #20(off off off off
+off off on off off off off off on off on off off off off on) #20(off
+off off off off off on on on on on on on on on off off off off on)))
+(make-problem "Hattori 114" '((8 7) (10 7) (12 1 1) (4 1 1 1) (3 1 1
+3) (3 1 1 1 1 4) (2 3 4 3 3) (2 1 4) (3 1 3 2) (2 1 2) (2 3 1 2) (2 3
+2) (2 3 2 2) (6 1 3) (5 3 5) (6 2 2) (7 2 2 1) (3 8 1 6) (3 7 3 1 1 1)
+(3 6 2 5 4) (4 4 3 8 2) (6 1 4 5) (4 5) (2 4) (1 4)) '((6 7) (9 9) (5
+4 11) (4 6 4) (3 1 8 2 1) (3 1 9) (3 2 1 1 5) (3 1 2 5) (3 2 1 1 4 1)
+(3 1 1 1 3 4) (3 1 1 2 2 5) (11 1 2 6) (1 2 2 7) (4 2) (2 2 3) (3 3 3)
+(3 2 1 1 3) (8 2 1 2 3) (2 2 1 5) (2 2 3 2) (2 2 1 1 1) (2 3 1 2) (2 3
+3) (6 2) (3)) '#25(#25(off off off on on on on on on off off off off
+off off on on on on on on on off) #25(off off on on on on on on on on
+on off off off on on on on on on on on on off) #25(off on on on on on
+off off on on on on off on on on on on on on on on on on off) #25(on
+on on on off off off off off off off on on on on on on off off off on
+on on on off) #25(on on on off off off on off off off off off on on on
+on on on on on off on on off on) #25(on on on off off off on off off
+off off off off on on on on on on on on on off) #25(on on on off off
+on on off off off on off off on off off on on on on on off) #25(on on
+on off off off off off off off on off on on off off off on on on on on
+off) #25(on on on off off on on off off off on off on off off off off
+on on on on off on off) #25(on on on off off off on off off off off
+off on off on off off on on on off on) #25(on on on off off off on off
+off off off on off on on off off on on off on) #25(off on on on on on
+on on on on on on off off on off on on off on) #25(off off on off off
+off off off off off off on on off off on on off on) #25(off off off
+off off off off off off off off off on on on on off on on off) #25(off
+off off off off off off on on off off off off on on off off off on on
+on off) #25(off off off off off off on on on off off off on on on off
+off off off on on on off) #25(off off off off off off on on on off off
+on on off on off on off off on on on off) #25(on on on on on on on on
+off off on on off off on off on on off on on on off) #25(on on off off
+off off off off off on on off off off off on off on on on on on off)
+#25(on on off off off off off off on on off off off off off on on on
+off off on on off) #25(on on off off off on on off on off off off off
+off off off off on off off on off) #25(on on off off on on on off off
+off off off off off off off off on off on on off) #25(on on off off on
+on on off off off off off off off off off off on on on off) #25(on on
+on on on on off off off off off off off off off off off off off on on
+off) #25(off off off off off off off off off off off off off off off
+off off off on on on off))) (make-problem "Hattori 115" '((11 12 4) (1
+12 3) (1 2 1 12 3) (1 2 1 1 4 3 2 3) (1 1 2 1 1 1 1 2) (6 6 2 2 3 1)
+(1 9 4) (3 1 7 3 6) (1 1 1 4 2 2 8) (3 2 2 3 9) (4 3 4 10 4) (7 10 1
+1) (2 1 2 8 2 1) (2 1 2 9 1 1) (3 4 2 1 2 4) (1 3 5 1 2) (1 1 1 2 1 1
+1 3) (1 1 1 1 11 2) (1 1 1 1 2 2 2 2) (1 3 3 2 1 2 1 1) (3 5 3 2 3 1
+1) (2 2 2 1 2 7 1) (2 1 2 2 5 4) (2 2 2 4 2 4) (7 8 5)) '((1 4 2 8) (1
+1 2 2 3) (1 9 4 2 2) (1 2 1 1 3 5 2) (1 1 3 1 1 2 1) (1 2 3 1 2 1) (1
+2 2 1 5) (1 3 5 1 2) (1 1 1 1 2 2 1) (1 1 2 2 5 2) (4 4 1 2 1 2 2) (4
+1 3 3) (4 1 3 3 1) (2 3 1 4 2) (3 3 4) (12 6 3) (4 7 4 2) (4 1 5 1 2
+1) (6 1 4 1 2 1) (3 2 4 1 1 1) (6 2 4 3 1) (4 1 5 7) (4 6 1 5) (3 8 1
+2) (12 2 1 2) (2 5 4 4) (1 6 3 2 4) (4 7 1 1 5) (5 4 1 3 2) (6 7 6 1))
+'#30(#25(on off on on on on off off off on on off off off on on on on
+on on on on off) #25(on off off off off on off off off on on off off
+on on off off off off off on on on off) #25(on off on on on on on on
+on on on off on on on on off off off on on off on on off) #25(on off
+on on off on off on off off on on on off off on on on on on off off
+off on) #25(on off off off off on off on on on off on off off off on
+off off off on on off off off on) #25(on off off off on on off off off
+on on on off off on off off off off off on on off off on) #25(on off
+off on on off off off off off on on off off on off off off off off on)
+#25(on off off off off off on on on off on on on on on off off off off
+off on off off on) #25(on off off off off off on off off on off on off
+off on on off off off on on off off off on) #25(on off off off off off
+on off on on off on on off off on on on on on off off off on) #25(on
+on on on off on on on on off on off on on off on off off off on on off
+on on off) #25(off off off off off on on on on off on off off on on on
+off off off off on on on off) #25(off off off off off on on on on off
+on off off off on on on off off on on on off off on) #25(on on off off
+off on on on off off on off off off off off on on on on off off off
+on) #25(on on on off off on on on off off off off off off off off off
+off off off off on) #25(on on on on on on on on on on on on off on on
+on on on on off off off on) #25(on on on on off off off on on on on on
+on on off off off on on on on off off on) #25(on on on on off on off
+off off on on on on on off off off on off off on on off off on) #25(on
+on on on on on off on off off on on on on off off off on off off off
+on on off on) #25(on on on off off off off on on off on on on on off
+off off on off off off off on off on) #25(on on on on on on off on on
+off on on on on off off on on on off off off on off) #25(on on on on
+off on off off off on on on on on off off off on on on on on on on
+off) #25(on on on on off off off off on on on on on on off off off on
+off on on on on on off) #25(on on on off off off off on on on on on on
+on on off off on off off on on off) #25(on on on on on on on on on on
+on on off off on on off on off off off on on off) #25(off off on on
+off on on on on on off off off off off on on on on off off on) #25(on
+off off off off on on on on on on off on on on off off off on on off
+on) #25(on on on on off off on on on on on on on off on off on off off
+off on) #25(on on on on on off off on on on on off off off on off on
+on on off off off off on) #25(on on on on on on off off on on on on on
+on on off on on on on on on off off on))) (make-problem "Hattori 116"
+'((3 2) (7) (9) (9) (6) (2 3 2) (4 2) (12 1) (15) (5 11) (3 11) (3 13)
+(2 13) (2 14) (16) (15) (9 5) (8 4) (7 4) (11)) '((8) (11) (3 6) (3 7)
+(2 8) (2 9) (2 9) (11 1) (10 1) (10 2) (14) (2 15) (3 14) (3 11) (6
+10) (6 8) (6 7) (4 5) (7) (1 6)) '#20(#20(off off off off off off off
+off off off off on on on on on on on on off) #20(off off off off off
+off off off off on) #20(off off off off off off off off off on on on
+off off on) #20(off off off off off off off off on on on off off on)
+#20(off off off off off off off off on on off off on) #20(off off off
+off off off off off on on off on) #20(off off off off off off off on
+on off off on) #20(off off off off off off off on on on on on on on on
+on on on off on) #20(off off off off off off off on on on on on on on
+on on on off off on) #20(off off off off off off on on on on on on on
+on on on off off on) #20(off off off off off off on) #20(off off on on
+off on) #20(off on on on off on on on on on on on on on on on on on on
+off) #20(off on on on off off off on on on on on on on on on on on
+off) #20(on on on on on on off on on on on on on on on on on off)
+#20(on on on on on on off on on on on on on on on off) #20(on on on on
+on on off on on on on on on on off) #20(off on on on on off off on on
+on on on off) #20(on on on on on on on off) #20(on off on on on on on
+on off))) (make-problem "Hattori 117" '((15 3) (15 4) (2 3 1 3 2 4) (2
+1 5 1) (15 2 3) (3 3 2 2 1 2) (3 3 1 1 3) (14 3 1) (15 1 2 2) (5 6 1 1
+1) (18 1 3) (5 5 2 5) (7 7 7) (7 7 6) (15 5) (15 4) (15 5) (15 8) (15
+1 2) (3 1 2) (3 1 2) (3 8) (3 2) (3 4) (7 4)) '((19) (19) (2 15) (3 1
+12) (3 1 12 1) (3 1 2 1 7 1) (2 5 1 13) (9 1 11) (2 5 1 13) (3 1 2 1 7
+1) (3 1 12 1) (3 1 12) (2 15) (6 12) (5 11) (1 2) (1 1) (2 5 5) (2 1 2
+1 1) (4 2 1 1) (7 2 1) (2 3 7 1 2) (5 12 1 2) (3 3 1 15) (3 1 15))
+'#25(#25(on on on on on on on on on on on on on on on on on on on off)
+#25(on on on on on on on on on on on on on on on on on on on off)
+#25(on on off off on on on on on on on on on on on on on on on off)
+#25(on on on off on off off on on on on on on on on on on on on off)
+#25(on on on off on off off on on on on on on on on on on on on off
+off off off off on) #25(on on on off on off off on on off on off on on
+on on on on on off off off off off on) #25(on on off off on on on on
+on off on off on) #25(on on on on on on on on on off on off off off
+on) #25(on on off off on on on on on off on off on) #25(on on on off
+on off off on on off on off on on on on on on on off off off off off
+on) #25(on on on off on off off on on on on on on on on on on on on
+off off off off off on) #25(on on on off on off off on on on on on on
+on on on on on on off) #25(on on off off on on on on on on on on on on
+on on on on on off) #25(on on on on on on off on on on on on on on on
+on on on on off) #25(on on on on on off off off on on on on on on on
+on on on on off) #25(off off off on off off off off off on on off)
+#25(off off off on off off off off off off on off) #25(off off off on
+on off off on on on on on off off off off off on on on on on off)
+#25(off off off off on on off on off off off on on off off off off on
+off off off on off) #25(off off off off off on on on on off off off on
+on off off off on off off off on off) #25(off off off off off off off
+off on on on on on on on off on on off off off on off) #25(off on on
+off on on on off off off off on on on on on on on off off off on off
+on) #25(on on on on on off on on on on on on on on on on on on off off
+off on off on) #25(on on on off on on on off on off on) #25(on on on
+off off on off off off off on))) (make-problem "Hattori 118" '((11)
+(12) (7 1) (6 2 2) (6 2 1) (4 1) (5 2 2) (8 1 3) (11 1) (8 5 3) (7 9)
+(6 5 2) (6 4 1) (6 1 1) (6 4 2) (6 4 1 1) (6 4 2 2) (6 4 2 2) (5 4 2
+1) (3 11)) '((10) (12) (13) (14) (14) (14) (5) (3 2 6) (5 2 3 6) (7 1
+3 6) (20) (6 3 1) (5 2 2 1) (5 2 2 1) (3 2 3) (2 2 2 2) (2 2 1 6 1) (2
+1 1 3 1) (4 4 2) (2 4 2)) '#20(#20(off off off off off off off off on
+on on on on on on on on on off) #20(off off off off off off off on on
+on on on on on on on on on on off) #20(off off off off off off on on
+on on on on on on on on on on on off) #20(off off off off off off on)
+#20(off off off off off off on) #20(off off off off off off on)
+#20(off off off off off off on on on on on off) #20(off off off off
+off off off on on on off on on off on) #20(off on on on on on off on
+on off on on on off on) #20(on on on on on on on off on off on on on
+off on) #20(on) #20(on on on on on on off off off on on on off off off
+off off off off on) #20(on on on on on off off off off on on off off
+off off on on off off on) #20(on on on on on off off off off on on off
+off off off off on on off on) #20(on on on off off off off off off on
+on off off off off off off on) #20(on on off on on off off off off off
+on on off off off off off off on) #20(on on off on on off off on off
+on on on on on on off off off off on) #20(on on off off off off off on
+off on off off off off on on on off off on) #20(on on on on off off on
+on on on off off off off off off on on off) #20(on on off on on on on
+off off off off off off off off off off on on off))) (make-problem
+"Hattori 119" '((12) (1 11) (3 3 3) (1 1 1 1) (1 1 1) (3 1 3 1 3 3) (3
+1 1 5 2 1) (2 13 5) (7 5 3 4) (11 3 5) (3 2 2 3 7) (5 3 9) (8 1 1 4)
+(4 5 5 3) (3 3 2 1 2) (3 2 1 2) (4 3 2 2) (5 4) (9 1 2 3) (2 7 12) (1
+6 6 5) (2 2 3 5 1) (3 2 2 2 2 2) (7 2 6 2) (8 3 7) (4 7 9) (3 3 2 4 5)
+(2 2 1 3 5) (2 3 2 3 4) (8 4 1)) '((3 6 6) (1 1 7 9) (3 2 3 1 2 7) (2
+2 4 1 3 2) (6 3 7 2 1) (3 14 3 1) (4 1 7 9 2) (2 1 1 1 2 5 6) (4 1 7 4
+5) (3 8 3 2 1) (6 3 3 4 2 2) (2 2 5 10) (1 3 2 4 6) (3 3 1 3 1) (7 2
+5) (5 2 6) (3 1 2 2 7) (7 9) (3 1 10) (7 1 1 1 3) (5 1 11) (7 13) (9 2
+3 4) (1 1 6 2 2 3) (3 4 5 4)) '#25(#30(on on on off off on on on on on
+on off off off off off off off off off off on on on on on on off)
+#30(on off on off on on on on on on on off off off off off off off off
+on on on on on on on on on off) #30(on on on off off on on off on on
+on off off off off off on off on on off off on on on on on on on off)
+#30(on on off off off off off off on on off off off on on on on off on
+off off off off on on on off off on) #30(on on on on on on off on on
+on off off on on on on on on on off off off off on on off off off off
+on) #30(on on on off off off on on on on on on on on on on on on on on
+off off on on on off off off off on) #30(on on on on off on off on on
+on on on on on off off off on on on on on on on on on off off on)
+#30(on on off off off on off on off on off on on off off off off on on
+on on on off off on) #30(on on on on off on off on on on on on on on
+off off off on on on on off off off off on) #30(on on on off off off
+on on on on on on on on off off off off on on on off off off off on on
+off off on) #30(on on on on on on off on on on off off on on on off
+off off on on on on off off on on off off on) #30(on on off off off
+off off on on off off off on on on on on off off on on on on on on on
+on on on off) #30(off on off off off off on on on off on on off on on
+on on off off off off on on on on on on off) #30(off off off off off
+on on on off on on on off off off off on off on on on off off off off
+off off off off on) #30(off off off off off on on on on on on on off
+off off off off off off on on off off off off on) #30(off off off off
+off on on on on on off off off off off off off off off on on off off
+off on) #30(off off off off off off on on on off off on off on on off
+off off off on on off off on) #30(off off off off off off off off off
+off on on on on on on on off on on on on on on on on on off) #30(off
+off off off off off off off off on on on off on off off on on on on on
+on on on on on off) #30(off off off off off off off off on on on on on
+on on off off on off on off on off on on on off) #30(off off off off
+off off off on on on on on off on off off off on on on on on on on on
+on on on off) #30(off off off off off off on on on on on on on off off
+off on on on on on on on on on on on on on off) #30(off off off off
+off on on on on on on on on on off on on off on on on off off off off
+on on on on off) #30(off off off off off on off on off off on on on on
+on on off off off on on off on on off off on on on off) #30(off off
+off off off on on on off off off on on on on off off off off on on on
+on on off off on))) (make-problem "Hattori 120" '((2) (2 2 3) (3 2 4 3
+3) (3 2 6 6) (3 4 4 4 1) (9 5 1) (17 1) (17 1) (16 2) (18) (16) (13)
+(11) (9) (8) (2 3) (3 2 2) (1 3 1) (1 2 2) (1 3 3) (2 14) (15) (12)
+(10) (8)) '((5) (1 2) (1 2 1) (2 5) (4 7) (5 2 5) (5 2 5) (5 1 5) (7 1
+5) (9 1 5) (11 1 5) (2 11 5) (1 1 10 5) (3 10 5) (5 8 1 5) (5 8 2 5)
+(3 8 5) (1 1 9) (2 9) (13) (11) (9) (3 2) (2 3) (8)) '#25(#25(off off
+off off off off off off off off off off off off off off on on on on on
+off) #25(off off off off off off off off off off off off off off off
+off on off off off on on off) #25(off off on off off off off off off
+off off off off off off off on on off off off on off) #25(off off on
+on off off off off off off off off off off off off off on on on on on
+off) #25(off off on on on on off off off off off off off off off off
+on on on on on on on off) #25(off off off on on on on on off off off
+off off off off on on off off on on on on on off) #25(off off off off
+on on on on on off off off off off on on off off off off on) #25(off
+off off off off on on on on on off off off off on off off off off off
+on) #25(off off off off on on on on on on on off off off on off off
+off off off on) #25(off off off on on on on on on on on on off off on
+off off off off off on) #25(off off on on on on on on on on on on on
+off on off off off off off on) #25(off on on off on on on on on on on
+on on on on off off off off off on) #25(off on off on off on on on on
+on on on on on on off off off off off on) #25(off off on on on off on
+on on on on on on on on on off off off off on) #25(on on on on on off
+on on on on on on on on off on off off off on on on on on off) #25(on
+on on on on off on on on on on on on on off on on off on on on on on
+off) #25(off off on on on off on on on on on on on on off off on on on
+on on off) #25(off on off on off on on on on on on on on on off)
+#25(off on on off off on on on on on on on on on off) #25(off on on on
+on on on on on on on on on on off) #25(off off on on on on on on on on
+on on on off) #25(off off off on on on on on on on on on off) #25(off
+off on on on off off off off on on off) #25(off off on on off off off
+off on on on off) #25(off off on on on on on on on on off))))))
diff --git a/collects/games/paint-by-numbers/solution-sets/k15x15 b/collects/games/paint-by-numbers/solution-sets/k15x15
new file mode 100644
index 0000000000..7af687618f
--- /dev/null
+++ b/collects/games/paint-by-numbers/solution-sets/k15x15
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 15x15") (define problems (list (make-problem "19980519-KHA (1)" (quote ((2 2) (4 4) (6 6) (15) (1 2 1 2 1 1) (2 2 1 1 1) (2 3 2 1 1) (1 3 3 1) (13) (11) (9) (7) (5) (3) (1))) (quote ((5) (2 2 1) (3 2) (4 2 3) (12) (4 7) (2 7) (2 7) (2 7) (4 7) (12) (4 3) (6 2) (2 1) (5))) (quote #15(#15(off off off on on on on on off) #15(off off on on off on on off on off) #15(off on on on off off off off on on off) #15(on on on on off on on off on on on off) #15(on on on on on on on on on on on on off) #15(off on on on on off on on on on on on on off) #15(off off on on off off off on on on on on on on off) #15(off off off on on off off off on) #15(off off on on off off off on on on on on on on off) #15(off on on on on off on on on on on on on off) #15(on on on on on on on on on on on on off) #15(on on on on off off off off on on on off) #15(off on on on on on on off on on off) #15(off off on on off off off off on off) #15(off off off on on on on on off)))) (make-problem "19980805-BER (2)" (quote ((1 13) (1 1 1) (1 1 9 1) (1 1 1) (1 3 9) (1 1 1 1) (1 1 11) (1 1) (1 11 1) (1 1 3) (1 1 7 1) (1 1 1 1 1) (1 1 5 1 3) (1 1) (14))) (quote ((15) (1) (3 3 5 1) (1 1 1 1) (1 5 1 3 1) (1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1) (1 1 1 1 1 5) (1 1 1 1 1 1) (1 1 1 1 2 1 1) (1 1 1 1 1 1) (13))) (quote #15(#15(on) #15(off off off off off off off off off off off off off off on) #15(on on on off on on on off on on on on on off on) #15(on off off off on off off off on off off off off off on) #15(on off on on on on on off on off on on on off on) #15(on off on off off off on off on off on off on off on) #15(on off on off on off on off on off on off on off on) #15(on off on off on off on off on off on off on off on) #15(on off on off on off on off on off on off on off on) #15(on off on off on off on off on off on off off off on) #15(on off on off on off on off on off on) #15(on off on off on off on off on off off off off off on) #15(on off on off on off on off on on off off on off on) #15(on off off off on off on off off on off off on off on) #15(on on on on on on on on on on on on on off)))) (make-problem "19980828-PAU (3)" (quote ((4 4) (6 6) (1 1 1 1) (3 3) (4 5 4) (1 1 1 1) (1 1 1) (1) (3) (3) (3 5 3) (2 2) (3 3) (9) (7))) (quote ((1) (2 1 1) (2 1 3) (2 3 4) (2 1 1 3) (2 3 1 2) (2 1 3 2) (1 5 2) (2 1 3 2) (2 3 1 2) (2 1 1 3) (2 3 4) (2 1 3) (2 1 1) (1))) (quote #15(#15(off off off off on off) #15(off on on off on off off off off off on off) #15(on on off off on off off off off off on on on off) #15(on on off on on on off off off off on on on on off) #15(on on off on off off on off off off off off on) #15(on on off on on on off off off off on off off on) #15(off on on off on off off off on on on off off on) #15(off off off off on off on on on on on off off on) #15(off on on off on off off off on on on off off on) #15(on on off on on on off off off off on off off on) #15(on on off on off off on off off off off off on) #15(on on off on on on off off off off on on on on off) #15(on on off off on off off off off off on on on off) #15(off on on off on off off off off off on off) #15(off off off off on off)))) (make-problem "19990211bJAM (4)" (quote ((3 2) (2 2 2) (2 4) (2 3) (2 5 2) (2 1 1 1 2) (3 5 3) (1 1 1 1 1) (1 5 1) (1 1) (1 4 1) (1 1 1 1) (1 1 1 1) (1 1 1 1) (1 1 1 1))) (quote ((1) (2) (11) (2) (2 5) (2 5 1) (2 1 1 1 1) (1 5 5) (2 1 1 1) (2 5) (2) (5) (15) (2) (1))) (quote #15(#15(off off off off off off on off) #15(off off off off off on on off) #15(off off off off on) #15(off off off on on off) #15(off off on on off off off off off off on) #15(off on on off on on on on on off on off) #15(on on off off on off on off on off on off) #15(on off off off on on on on on off on) #15(on on off off on off on off on off) #15(off on on off on on on on on off) #15(off off on on off) #15(on on on on on off) #15(on) #15(off off off off off on on off) #15(off off off off off off on off)))) (make-problem "19990221bFRA (5)" (quote ((1) (1 1) (2 2) (3 3) (4 4) (5 5) (6 6) (7 7) (1) (1) (15) (13) (11) (9) (9))) (quote ((1 1) (2 2) (3 3) (4 5) (5 5) (6 5) (7 5) (1 7) (7 5) (6 5) (5 5) (4 5) (3 3) (2 2) (1 1))) (quote #15(#15(off off off off off off off on off off on off) #15(off off off off off off on on off off on on off) #15(off off off off off on on on off off on on on off) #15(off off off off on on on on off off on) #15(off off off on on on on on off off on) #15(off off on on on on on on off off on) #15(off on on on on on on on off off on) #15(on off off off off off off off on) #15(off on on on on on on on off off on) #15(off off on on on on on on off off on) #15(off off off on on on on on off off on) #15(off off off off on on on on off off on) #15(off off off off off on on on off off on on on off) #15(off off off off off off on on off off on on off) #15(off off off off off off off on off off on off)))) (make-problem "19990421aMIJ (6)" (quote ((3) (3) (2) (4 4) (1 1 2) (1 1) (13) (1 1) (12) (1 1) (14) (1 1) (1 3 1) (4 3) ())) (quote (() (7) (1 1 1 1 1) (1 1 1 1 1) (1 1 1 1 1) (1 1 1 1 1) (1 1 1 1 2) (2 1 1 1 1 1) (4 1 1 1 1) (2 1 1 1 1 1) (1 1 1 1 1 1) (1 1 1 1 1) (1 3 1 1) (1 1 3) (1 1))) (quote #15(#15(off) #15(off off off off off on on on on on on on off) #15(off off off off on off on off on off on off on off) #15(off off off on off off on off on off on off off on off) #15(off off off on off off on off on off on off off on off) #15(off off off on off off on off on off on off off on off) #15(off off off on off off on off on off on off on on off) #15(off on on off on off on off on off on off on off) #15(on on on on off off on off on off on off on off) #15(on on off on off off on off on off on off off on off) #15(on off off on off off on off on off on off off on off) #15(off off off on off off on off on off on off off on off) #15(off off off off on off on on on off on off on off) #15(off off off off on off on off off on on on off) #15(off off off off off on off off off off on off)))) (make-problem "19990527cDRA (7)" (quote ((3 4) (1 2) (1 6 1) (1 11) (5 4) (4 2 4) (3 3 3) (1 1 3 1 2) (1 2 2 1) (1 1 2 2) (3 7 3) (4 5 4) (5 5) (15) (15))) (quote ((15) (1 3 5) (1 4 1 5) (3 2 4) (2 2 3) (2 2 2) (2 3 2 2) (2 3 2 2) (2 2 2 2) (2 2 2) (3 2 3) (1 3 3 4) (1 4 1 5) (2 4 6) (3 10))) (quote #15(#15(on) #15(on off off off on on on off off off on) #15(on off off on on on on off on off on) #15(off off off on on on off on on off off on) #15(off off off on on off off off off on on off on) #15(off off on on off off off off off off on on off on) #15(off off on on off on on on off off on on off on) #15(off off on on off on on on off off on on off on) #15(off off on on off off on on off off on on off on) #15(off off on on off off off off off off on on off on) #15(off off on on on off off off off on on off on) #15(on off off on on on off on on on off on) #15(on off off on on on on off on off on) #15(on on off off on on on on off on) #15(on on on off off on)))) (make-problem "19990723aDAH (8)" (quote (() () (6 6) (1 3 1) (1 1) (3 3) (2 2 2 2) (9) (9) (1 5 1) (1 3 1) (1 1 1) (1 1) (9) ())) (quote ((4) (1 1) (1 2) (1 8) (1 2 1) (1 4 1) (1 5 1) (1 5 1) (1 5 1) (1 4 1) (1 2 1) (1 8) (1 2) (1 1) (4))) (quote #15(#15(off off on on on on off) #15(off off on off off on off) #15(off off on off off on on off) #15(off off on off off off on on on on on on on on off) #15(off off on off off off off on on off off off off on off) #15(off off on off off off on on on on off off off on off) #15(off off off on off off on on on on on off off on off) #15(off off off on off off off on on on on on off on off) #15(off off off on off off on on on on on off off on off) #15(off off on off off off on on on on off off off on off) #15(off off on off off off off on on off off off off on off) #15(off off on off off off on on on on on on on on off) #15(off off on off off on on off) #15(off off on off off on off) #15(off off on on on on off)))) (make-problem "19990723bDAH (9)" (quote ((4 6) (2 4 2) (1 2 2) (1 1 2 1) (1 1 4 1) (1 1 1 2 1) (1 6 1) (1 1 2 2) (1 1 2 2) (1 1 1 2) (2 2 1 2) (1 1 1 1) (4 4) (1 1 1 1) (1 1 1 1))) (quote ((10) (2 5) (1 1) (1 1) (2 5) (10) (2 1) (2 1 7) (1 5 1) (1 2 2 1) (1 4 5) (1 2 2) (2 2) (2 2) (6))) (quote #15(#15(off on on on on on on on on on on off) #15(on on off off off off off off off off on) #15(on off off off off off off off off off off off on off) #15(on off off off off off off off off off off off on off) #15(on on off off off off off off off off on) #15(off on on on on on on on on on on off) #15(off on on off off off on off) #15(on on off off off off on off on) #15(on off off off on on on on on off off off on off) #15(on off off on on off on on off off off off on off) #15(on off off on on on on off off off on) #15(on off off off on on off off off on on off) #15(on on off off off off off off on on off) #15(off on on off off off off on on off) #15(off off on on on on on on off)))) (make-problem "19990728-DAH (10)" (quote ((5 5) (3 5 3) (2 4 3 2) (1 4 2 1) (1 1 5 1 1) (3 5 2) (4 4 1) (5 6) (1 1 1 1) (1 1 1 1) (1 7 2 1) (1 8 1 1) (2 8 2) (3 5 3) (5 5))) (quote ((5 5) (3 5 3) (2 4 2 2) (1 1 3 3 1) (1 2 2 3 1) (4 1 4) (5 1 4) (1 4 5) (1 4 4) (2 5 3) (1 1 3 1 1 1) (1 2 1 1 1) (2 3 1 2 2) (3 5 3) (5 5))) (quote #15(#15(on on on on on off off off off off on) #15(on on on off off on on on on on off off on) #15(on on off off on on on on off off on on off on) #15(on off on off off on on on off off on on on off on) #15(on off on on off off on on off off on on on off on) #15(off on on on on off off on off off on on on on off) #15(off on on on on on off off on off on on on on off) #15(off on off on on on on off off on on on on on off) #15(off on off off on on on on off off on on on on off) #15(off on on off on on on on on off off on on on off) #15(on off on off off on on on off on off off on off on) #15(on off on on off off off on off off on off off off on) #15(on on off on on on off on off off on on off on) #15(on on on off off on on on on on off off on) #15(on on on on on off off off off off on)))) (make-problem "19990917aMAT (11)" (quote ((2 3 2) (1 5 1) (2 1 2) (3 3) (1 1 1 1) (1 1 5 2 1) (1 3 4 1) (3 4) (2 2) (2 2) (2 2) (2 2) (11) (1 2 2 1) (3 3))) (quote (() (2 1) (1 1 1 1) (2 6 1 1) (1 2 9) (6 3) (2 1 1 1) (3 1 1) (2 1 1 1) (6 3) (1 2 9) (2 6 1 1) (3 1 1) (1 1 1) (2))) (quote #15(#15(off) #15(off off off off off on on off off off off off off on off) #15(off off off off on off off on off off off off on off on) #15(on on off off off on on on on on on off on off on) #15(on off on on off off on) #15(off on on on on on on off off off off on on on off) #15(on on off on off on off off off off off off on off) #15(on on on off off on off off off off off off on off) #15(on on off on off on off off off off off off on off) #15(off on on on on on on off off off off on on on off) #15(on off on on off off on) #15(on on off off off on on on on on on off on off on) #15(off off off off off on on on off off off off on off on) #15(off off off off on off off on off off off off off on off) #15(off off off off off on on off)))) (make-problem "19990917bMAT (12)" (quote ((3 2) (4 2) (7 2) (1 11) (1 7) (1 1 4) (7 3) (2 1 2 3) (1 1 1 1 3) (7 3) (7 3) (3) (3) (5) (15))) (quote ((1 1) (1 1 1) (11 1) (3 2 2 1) (3 1 3 1) (3 2 2 1) (2 1 3 1) (2 2 1 1) (8 1) (2 1) (2 2) (3 2) (12) (15) (15))) (quote #15(#15(off off off off off off off off off off on off off off on) #15(on off off off off off off off off off on off off off on) #15(on on on on on on on on on on on off off off on) #15(on on on off off off on on off on on off off off on) #15(off on on on off off on off on on on off off off on) #15(off on on on off off on on off on on off off off on) #15(off off on on off off on off on on on off off off on) #15(off off on on off off on on off on off off off off on) #15(off off on on on on on on on on off off off off on) #15(off off off on on off off off off off off off off off on) #15(off off off on on off off off off off off off off on) #15(off off off on on on off off off off off off off on) #15(off off off on) #15(on) #15(on)))) (make-problem "19990917cMAT (13)" (quote ((1) (1 1) (11) (1 5 1) (1 7 1) (1 1) (1 1 5 1) (1 1) (1 1 5 1) (1 1) (1 1 5 1) (1 1) (1 1 5 1) (1 1) (11))) (quote (() () (13) (1 1) (1 1 1 1 1 1 1) (3 1) (4 1 1 1 1 1) (1 3 1 1 1 1 1) (4 1 1 1 1 1) (3 1 1 1 1 1) (1 1 1 1 1 1 1) (1 1) (13) () ())) (quote #15(#15(off) #15(off) #15(off off on) #15(off off on off off off off off off off off off off off on) #15(off off on off on off on off on off on off on off on) #15(off off on on on off off off off off off off off off on) #15(off on on on on off on off on off on off on off on) #15(on off on on on off on off on off on off on off on) #15(off on on on on off on off on off on off on off on) #15(off off on on on off on off on off on off on off on) #15(off off on off on off on off on off on off on off on) #15(off off on off off off off off off off off off off off on) #15(off off on) #15(off) #15(off)))) (make-problem "19990917dMAT (14)" (quote ((9 3) (1 1 3) (1 1 3) (2 2 3) (3 3 5) (5 2 1 2) (5 1 1 1) (1 1 1 2 1) (1 1 1 1 1) (1 1 2 2) (1 1 1 5) (1 1 1 3) (1 3 1 3) (7 3) (9 3))) (quote ((1 1) (5 5) (1 4 2 2) (1 4 3) (1 2 1 5) (1 4 3) (1 4 2 2) (5 5) (1 5 1) (2 2) (5 1 5) (8 5) (5 5) (2 2) (5))) (quote #15(#15(on off off off off off off off off off off off off off on) #15(on on on on on off off off off off on) #15(on off off on on on on off on on off off off on) #15(on off off off on on on on off off off off on) #15(on off off off off on on off on off on) #15(on off off off on on on on off off off off on) #15(on off off on on on on off on on off off off on) #15(on on on on on off off off off off on) #15(on off off off off on on on on on off off off off on) #15(off off off off on on off off off on on off) #15(on on on on on off off on off off on) #15(on on on on on on on on off off on) #15(on on on on on off off off off off on) #15(off off off off on on off off off on on off) #15(off off off off off on on on on on off)))) (make-problem "19990917eMAT (15)" (quote ((3) (1 2) (2) (1) (2) (1) (5) (5 5) (7 5) (9 5) (1 1 5) (7 5) (1 1 3) (9 3) (7 3))) (quote ((2 2) (2 1 2) (3 1 2) (3 1 2) (3 1 2) (3 1 2) (1 3 1 2) (1 2 1 2) (1 2 2) (2) (2 6) (3 9) (11) (9) (6))) (quote #15(#15(off off off off off off off off off on on off on on off) #15(off off off off off off off off on on off on off on) #15(off off off off off off off on on on off on off on) #15(off off off off off off off on on on off on off on) #15(off off off off off off off on on on off on off on) #15(off off off off off off off on on on off on off on) #15(off on off off off off off on on on off on off on) #15(on off off off off off off off on on off on off on) #15(on off off off off off off off off on on off on on off) #15(on on off) #15(off on on off off off on on on on on on off) #15(off off on on on off on) #15(off off off off on) #15(off off off off off off on) #15(off off off off off off on on on on on on off)))) (make-problem "19990918aMAT (16)" (quote ((5) (3) (9) (2 2) (2 3 2) (2 1 1 1 2) (2 2 2 2) (2 3 2) (2 2 1 2 2) (2 2 2 2) (2 3 2) (2 2 2 2) (2 2 2 2) (3 3) (13))) (quote (() (11) (12) (2 2) (1 1 1 1) (1 1 2 2 2 1) (3 1 2 3 1) (3 2 2 1 1) (3 1 2 3 1) (1 1 2 2 2 1) (1 1 1 1) (2 2) (12) (11) ())) (quote #15(#15(off) #15(off off off off on) #15(off off off on) #15(off off on on off off off off off off off off off on) #15(off off on off off off off off on off off off on off on) #15(on off on off off on on off on on off on on off on) #15(on on on off on off on on off on on on off off on) #15(on on on off on on off on on off on off off off on) #15(on on on off on off on on off on on on off off on) #15(on off on off off on on off on on off on on off on) #15(off off on off off off off off on off off off on off on) #15(off off on on off off off off off off off off off on) #15(off off off on) #15(off off off off on) #15(off)))) (make-problem "19990918bMAT (17)" (quote ((1 1) (5) (1 1 1 1 1) (2 5 1 1) (1 2 3 2 1) (2 3 3 1) (2 1 1 2) (4 4) (1 1) (4 4) (3 3 2) (2 2 2 2) (2 2 1) (3 1 1) (1))) (quote ((2 1) (2 2) (2 2 1 1) (2 1 2 1) (2 1 1 2) (3 5 2) (2 3 3) (4 1) (2 3 3) (3 5 2) (2 1 1 3) (3 1 2) (2 2) (4 3) ())) (quote #15(#15(off off off off on on off off off off off on off) #15(off off off off off on on off off off on on off) #15(off off on on off off on on off off on off off on off) #15(off off off on on off off on off on on off off on off) #15(off off off off on on off on off on off off on on off) #15(off on on on off on on on on on off on on off) #15(on on off on on on off off off on on on off) #15(off on on on on off off off off off on off) #15(on on off on on on off off off on on on off) #15(off on on on off on on on on on off on on off) #15(off off off off on on off on off on off off on) #15(off off on on on off off on off on on off) #15(off off off off off off on on off off on on off) #15(off off off on on on on off off off off on on on off) #15(off)))) (make-problem "19990918cMAT (18)" (quote ((2 3) (2 3) (4) (2) (4) (15) (1 3 1 1) (1 5 1 1 1) (1 2 1 2 1 1) (1 3 3 1 1 1) (1 1 3 1 1 1) (1 1 1 1 1 1) (1 3 1 1) (15) (1 1))) (quote ((9) (1 2) (1 3 1) (1 1 3 1 1) (2 3 2 2) (2 5 1 2) (6 2 2) (4 3 1 1) (2 2 3 1) (1 1 1) (2 9) (1 1 1) (1 1 1 1 1 1) (1 2) (9))) (quote #15(#15(off off off off off on on on on on on on on on off) #15(off off off off off on off off off off off off off on) #15(off off off off off on off off on on on off off on off) #15(on off off off off on off on on on off on off on off) #15(on on off off off on on on off on on off on on off) #15(off on on off on on on on on off on off on on off) #15(off off on on on on on on off on on off on on off) #15(off off on on on on off on on on off on off on off) #15(off on on off on on off off on on on off off on off) #15(off on off off off on off off off off off off off on off) #15(on on off off off on on on on on on on on on off) #15(on off off off off on off off off off off off off on off) #15(on off off off off on off on off on off on off on off) #15(off off off off off on off off off off off off off on) #15(off off off off off on on on on on on on on on off)))) (make-problem "19990918dMAT (19)" (quote ((1) (3) (1) (1) (5) (9) (13) (15) (1 1 1 1 1) (1 1 1 1 1 1 1) (1 1 1 1 1) (3 1 3) (3 1 3) (3 1 3) (15))) (quote ((1 1) (9) (2 4) (10) (3 1) (4 1 1) (1 4 1) (15) (1 4 1) (4 1 1) (3 1) (10) (2 4) (9) (1 1))) (quote #15(#15(off off off off off off off on off off off off off off on) #15(off off off off off off on) #15(off off off off off off on on off off off on) #15(off off off off off on) #15(off off off off off on on on off off off off off off on) #15(off off off off on on on on off on off off off off on) #15(off on off off on on on on off off off off off off on) #15(on) #15(off on off off on on on on off off off off off off on) #15(off off off off on on on on off on off off off off on) #15(off off off off off on on on off off off off off off on) #15(off off off off off on) #15(off off off off off off on on off off off on) #15(off off off off off off on) #15(off off off off off off off on off off off off off off on)))) (make-problem "19990918eMAT (20)" (quote (() (3) (8) (4 1 2) (1 1 1 1) (2 2 6) (12) (1 8) (1 11) (1 13) (3 5 3) (1 1 2 2) (2 1 2 2) (5 4) (6))) (quote ((6) (3 3) (1 1 2 2) (1 4 1) (2 5 2) (13) (1 5 2) (2 6 1) (11 1) (2 10) (1 5 2) (2 2 2 1) (3 3 2) (5) (3))) (quote #15(#15(off off off off off on on on on on on off) #15(off off off off on on on off off off on on on off) #15(off off off on off off on off off on on off on on off) #15(off off off on off off on on on on off off off on off) #15(off off on on off on on on on on off off off on) #15(off off on) #15(off off on off off off on on on on on off off on) #15(off on on off off on on on on on on off off off on) #15(off on on on on on on on on on on on off off on) #15(off on on off off on) #15(off off on off off on on on on on off off on on off) #15(off off on on off on on off on on off off off on off) #15(off off off on on on off off on on on off on on off) #15(off off off off off off off off on on on on on off) #15(off off off off off off off off off on on on off)))) (make-problem "19990918fMAT (21)" (quote ((1 1) (2 1 1 2) (2 1 1 2) (3 3 3) (4 3 4) (15) (15) (15) (4 3 4) (3 3 3) (2 1 2) (2 1 2) (1 1 1) (1 1 1) (1))) (quote ((3) (7) (11) (14) (5) (3) (9) (12) (9) (3) (5) (14) (11) (7) (3))) (quote #15(#15(off off off off off on on on off) #15(off off off on on on on on on on off) #15(off on on on on on on on on on on on off) #15(on on on on on on on on on on on on on on off) #15(off off off off on on on on on off) #15(off off off off off on on on off) #15(off on on on on on on on on on off) #15(off off off on) #15(off on on on on on on on on on off) #15(off off off off off on on on off) #15(off off off off on on on on on off) #15(on on on on on on on on on on on on on on off) #15(off on on on on on on on on on on on off) #15(off off off on on on on on on on off) #15(off off off off off on on on off)))) (make-problem "19990918gMAT (22)" (quote ((1 1) (1 2) (1 4) (1 5) (1 6) (8 2) (9) (10) (1 9) (1 10) (2 1 1 1) (1 1 1 1 1) (1 1 1 2 1) (2 1 1 1) (1))) (quote ((2) (1 1) (1 1) (7) (6) (5 3) (5) (15) (5) (6 1) (11) (7 2) (4 5) (4) (3))) (quote #15(#15(off off off off off off off off on on off) #15(off off off off off off off on off off off off off on off) #15(off off off off off off off on off off off off off on off) #15(off off off off off off on on on on on on on off) #15(off off off off off on on on on on on off) #15(off off off off off on on on on on off on on on off) #15(off off off off off on on on on on off) #15(on) #15(off off off off off on on on on on off) #15(off off off off on on on on on on off off on off) #15(off off on on on on on on on on on on on off) #15(on on on on on on on off on on off) #15(off on on on on off off off off on on on on on off) #15(off off on on on on off) #15(off off off on on on off)))) (make-problem "19990918hMAT (23)" (quote ((4) (6) (12 1) (12 1) (2 1 2 6) (6) (4) () (3) (2 2) (2 1 2) (1 13) (2 1 2 1 1) (2 2 2 2) (3))) (quote ((2 3) (3 2 2) (3 2 1 2) (2 1 3 1) (3 2 1 2) (2 5) (3 3) (3 1) (2 1) (5 1) (7 1 1) (7 3) (2 3 1) (2 3 3) (5 1 1))) (quote #15(#15(off off on on off off off off off off on on on off) #15(off off on on on off off off off on on off on on off) #15(off off on on on off off off on on off on off on) #15(off off on on off off off off on off on on on off on) #15(off off on on on off off off on on off on off on) #15(off off on on off off off off off on on on on on off) #15(off off on on on off off off off off on on on off) #15(off off on on on off off off off off off on off) #15(off off on on off off off off off off off on off) #15(off on on on on on off off off off off on off) #15(on on on on on on on off off off off on off on off) #15(on on on on on on on off off off off on on on off) #15(on on off off on on on off off off off on off) #15(on on off off on on on off off off off on on on off) #15(off on on on on on off off off off off on off on off)))) (make-problem "19990918iMAT (24)" (quote ((2 1) (1 2 1) (1 1 1) (1 1) (3) (7) (9) (2 8) (1 9) (1 9) (11) (11) (11) (9) (7))) (quote (() (6) (2 4) (2 7) (10) (11) (13) (1 11) (1 10) (1 10) (1 8) (1 6) (1) (2 1) (1))) (quote #15(#15(off) #15(off off off off off off off on on on on on on off) #15(off off off off off off on on off off on on on on off) #15(off off off off off on on off on) #15(off off off off off on) #15(off off off off on) #15(off off on) #15(off on off off on) #15(on off off off off on) #15(on off off off off on) #15(off on off off off off on on on on on on on on off) #15(off on off off off off off on on on on on on off) #15(off off on off) #15(on on off on off) #15(off off on off)))) (make-problem "19990918jMAT (25)" (quote ((3 3) (2 2 2 1) (1 3) (1) (1 4) (1 6) (1 9) (2 9) (2 10) (10 3) (13) (8 5) (10) (2 10) (1))) (quote ((3 3) (2 3 3) (2 4) (1 4) (2 5) (2 6) (12) (2 8) (2 9) (1 7 2) (2 8 1) (5 2 1) (8 1) (7 1) (6))) (quote #15(#15(off off off off off off on on on off off off on) #15(off on on off off off off on on on off on on on off) #15(on on off off off off off off off on on on on off) #15(on off off off off off off off off on on on on off) #15(on on off off off off off off off on on on on on off) #15(off on on off off off off off on on on on on on off) #15(off off on on on on on on on on on on on on off) #15(off on on off off off on on on on on on on on off) #15(on on off off off on on on on on on on on on off) #15(on off off off on on on on on on on off on on off) #15(on on off off on on on on on on on on off on off) #15(off off off off on on on on on off on on off on off) #15(off off off off on on on on on on on on off on off) #15(off off off off off on on on on on on on off on off) #15(off off off off off off on on on on on on off)))) (make-problem "19990918kMAT (26)" (quote ((1 1 2) (3 1 2) (1 3 1 2 2) (7 1 1) (3 1 1) (3 1 1) (1 2 2) (6 2 3) (2 6 1) (1 3) (1 4) (6) (2 3) (2 3) (3))) (quote ((3) (2 2 1) (1 1 4) (6 8) (11) (6 5) (1 2 4) (2 1 3) (2 2) (3 2) (2 2) (1 1) (2 2) (2 2) (5))) (quote #15(#15(off off off off off off off off on on on off) #15(off off on on off off off on on off off off off off on) #15(off off off on off off off on off off off on) #15(on on on on on on off on) #15(off on on on on on on on on on on on off) #15(on on on on on on off on on on on on off) #15(off off off on off off off on on off on on on on off) #15(off off on on off off off off on off off on on on off) #15(off off off off off off off on on off off off on on off) #15(off off on on on off on on off) #15(off on on off off on on off) #15(on off off off off off off on off) #15(on on off off off off off on on off) #15(off on on off off off on on off) #15(off off on on on on on off)))) (make-problem "19990918lMAT (27)" (quote ((5) (2 2) (2 5 2) (2 2 2 2) (4 1 4) (5 2 5) (1 1 3 1 1) (5 3 5) (1 2 2 1) (6 1 4) (4 2 5) (3 4 4) (11) (3 4) (5))) (quote ((5) (3 1 3) (4 1 4) (2 2 1 5) (1 8 2) (1 2 2 4) (1 1 1 3 1) (1 1 3 4 1) (1 1 4 4) (1 2 1 1 3) (1 3 2 4) (2 10) (4 1 4) (3 1 3) (5))) (quote #15(#15(off off off off off on on on on on off) #15(off off off on on on off on off on on on off) #15(off off on on on on off on off on on on on off) #15(off on on off on on off on off on on on on on off) #15(off on off on on on on on on on on off on on off) #15(on off on on off off off off on on off on) #15(on off on off off off off on off off on on on off on) #15(on off on off off on on on off on on on on off on) #15(on off on off on on on on off off off on) #15(on off on on off off on off off off on off on) #15(off on off on on on off on on off on on on on off) #15(off on on off on on on on on on on on on on off) #15(off off on on on on off on off on on on on off) #15(off off off on on on off on off on on on off) #15(off off off off off on on on on on off)))) (make-problem "19990918mMAT (28)" (quote ((15) (5 1) (4 3 5) (1 4 3 2) (3 2 1) (1 2 1 1 1) (1 4 3 2) (7 7) (1 6 6) (1 6 6) (2 7) (12) (1 2 5) (3 6 4) (15))) (quote ((1 2 4 3) (1 1 1 2) (1 1 1 3 3) (1 2 7 1) (2 2 6 2) (10 1 2) (10 1 2) (3 2 1 2) (2 5 2 2) (1 3 6 2) (1 2 7 1) (1 1 8) (1 1 1 8) (1 2 9) (2 12))) (quote #15(#15(on off on on off off on on on on off off on) #15(on off on off off off off on off off off off off on) #15(on off on off off on off on on on off off on) #15(on off on on off off on on on on on on on off on) #15(on on off on on off on on on on on on off on) #15(on on on on on on on on on on off on off on) #15(on on on on on on on on on on off on off on) #15(on on on off off off off off on on off on off on) #15(on on off on on on on on off off on on off on) #15(on off on on on off on on on on on on off on) #15(on off on on off off on on on on on on on off on) #15(on off on off off off off on) #15(on off on off off on off on) #15(on off on on off off on) #15(on on off on)))) (make-problem "19990918nMAT (29)" (quote ((7) (1) (6) (7) (3 1) (3 1) (3 1) (8) (9) (8) (4 3) (2 3 2 2) (3 3 1 1 1) (1 1 1 1 1) (2 2))) (quote ((1 1) (1 1) (1 2) (1 1 1) (1 1 1) (1 2) (13) (11) (10) (2 4 2) (2 3 1 1) (8 1 1) (1 4 2) (5) (1 4))) (quote #15(#15(on off off off off off off off off off off off on off) #15(on off off off off off off off off off off off on off) #15(on off off off off off off off off off off off on on off) #15(on off off off off off off off off off off on off off on) #15(on off off off off off off off off off off on off off on) #15(on off off off off off off off off off off off on on off) #15(on on on on on on on on on on on on on off) #15(off off on on on on on on on on on on on off) #15(off off on on on on on on on on on on off) #15(off off on on off off off on on on on off on on off) #15(off off on on off off off on on on off on off off on) #15(off off on on on on on on on on off on off off on) #15(off off off on off off off on on on on off on on off) #15(off off off off off off off on on on on on off) #15(off off off off off off off off on off on on on on off)))) (make-problem "19990918oMAT (30)" (quote ((2) (3) (1 1) (1 2 4) (1 1 2 1) (1 1 2 1) (1 1 2 2 1) (1 2 2 3) (2 8) (14) (4 5 2) (2 2 3 2 1) (1 1 1 1 1 1) (1 1 1 1 1) (2 2))) (quote ((1 2) (5 1 4) (2 2 3) (3 2 2) (7 1 1) (4 1 1) (2 2) (9) (11) (1 4) (1 3 2) (6 1 1) (3 1 1) (4 2) (1 2))) (quote #15(#15(off off off off off off on off off on on off) #15(on on on on on off off on off on on on on off) #15(on on off off off on on off off on on on off) #15(off on on on off off off off off on on off on on off) #15(off off off on on on on on on on off on off off on) #15(off off off off off off on on on on off on off off on) #15(off off off off off off off off off on on off on on off) #15(off off off on on on on on on on on on off) #15(off off off on on on on on on on on on on on off) #15(off off off on off off off off on on on on off) #15(off off off on off off off off on on on off on on off) #15(off off off off on on on on on on off on off off on) #15(off off off off off off off on on on off on off off on) #15(off off off off off off off on on on on off on on off) #15(off off off off off off off off on off on on off)))) (make-problem "19990920aMAT (31)" (quote ((4) (1 1) (1 1) (1 1) (3 1 1) (15) (1 9 1) (6 2 1) (5 3 5) (4 5 4) (4 5 4) (4 5 4) (5 3 5) (1 4 6) (15))) (quote ((10) (2 6 1) (11) (11) (4 3) (3 3 2) (2 5 1) (2 5 1) (2 5 1) (3 3 2) (9 3) (1 1 7) (1 1 7) (6 7) (10))) (quote #15(#15(off off off off off on) #15(off off off off on on off on on on on on on off on) #15(off off off off on) #15(off off off off on) #15(off off off off off on on on on off off off on) #15(off off off off off on on on off on on on off on) #15(off off off off off on on off on on on on on off on) #15(off off off off off on on off on on on on on off on) #15(off off off off off on on off on on on on on off on) #15(off off off off off on on on off on on on off on) #15(on on on on on on on on on off off off on) #15(on off off off off on off off on) #15(on off off off off on off off on) #15(on on on on on on off off on) #15(off off off off off on)))) (make-problem "19990920bMAT (32)" (quote ((2 1 1) (1 1 1 1) (3 1 1) (1 1 1 1) (1 1) (2 1 1 2) (3 3) (4 1 4) (13) (9) (1 1) (11) (11) (11) (9))) (quote ((1) (3) (1 3 4) (2 5 4) (1 4 2 4) (1 1 2 4) (1 1 2 4) (2 3 4) (2 1 2 4) (2 4) (4 2 4) (2 5 4) (3 4) (3) (1))) (quote #15(#15(off off off off off off off on off) #15(off off off off off off on on on off) #15(off off off on off off on on on off on on on on off) #15(off on on off off on on on on on off on) #15(on off on on on on off off on on off on) #15(on off on off off off off off on on off on) #15(off on off off off on off off on on off on) #15(off off on on off off off on on on off on) #15(on on off off off on off off on on off on) #15(off off off off off off off off on on off on) #15(off off on on on on off off on on off on) #15(on on off off off on on on on on off on) #15(off off off off off off on on on off on on on on off) #15(off off off off off off on on on off) #15(off off off off off off off on off)))) (make-problem "19990920cMAT (33)" (quote ((1) (5) (1 3) (5) (2 2) (5) (1 3) (5) (2 2) (5) (6 1) (8 1) (9 1) (10) (6 3))) (quote (() (2) (3) (3) (4) (5) (15) (1 3 7) (3 3 6) (14) (14) (1) (1 1) (1) ())) (quote #15(#15(off) #15(off off off off off off off off off off off off off on) #15(off off off off off off off off off off off off on) #15(off off off off off off off off off off off off on) #15(off off off off off off off off off off off on) #15(off off off off off off off off off off on) #15(on) #15(off on off on on on off on on on on on on on off) #15(off on on on off on on on off on) #15(off on) #15(off on) #15(off off off off off off off off off off off on off) #15(off off off off off off off off off off on off on off) #15(off off off off off off off off off off off on off) #15(off)))) (make-problem "19990920dMAT (34)" (quote ((2) (3) (4 1) (3 1 2) (1 3 1 1) (1 1 1 1) (1 1 1 1) (1 1 2 1 1) (2 1 1 1 2) (1 4 1) (3 3) (6) (2) (2) (6))) (quote (() (2) (3) (4 1) (1 1 2) (3 1 1 1) (4 3 1 1) (1 1 2 1 4) (1 1 1 4) (2 1 1 2 1) (1 4 1 1) (3 3) (6) () ())) (quote #15(#15(off) #15(off off off off off off off on on off) #15(off off off off off off off off on on on off) #15(off off off off on on on on off off on off) #15(off off off on off off off off on off on on off) #15(off off on on on off off off off on off on off off on) #15(off off on on on on off on on on off on off off on) #15(off off on off on off on on off on off on) #15(on off on off off off off off off on off on) #15(on on off on off off off off on off on on off off on) #15(off on off off on on on on off off on off off off on) #15(off on on on off off off off on on on off) #15(off off off on on on on on on off) #15(off) #15(off)))) (make-problem "19990920eMAT (35)" (quote ((2) (1 1) (2 1) (15) (1 10) (1 2 2 1) (1 1 1 2 1 1) (1 4 2 1 1) (1 1 2 1 1) (1 1 1 1 1) (1 1 1 1) (1 1 2) (1 1) (1 1) (1 1))) (quote ((12) (1) (1 8) (1 2) (1 1 1) (5) (2) (8) (8 1) (1 2 1 1) (1 2 3 1) (1 2 1) (8) (2) (2))) (quote #15(#15(off off off on) #15(off off off on off) #15(off off off on off off off on) #15(off off off on off off on on off) #15(off off off on off on off on off) #15(off off off on on on on on off) #15(off off off on on off) #15(off off on on on on on on on on off) #15(off on on on on on on on on off on off) #15(on off off on on off off off off on off on off) #15(on off off on on off on on on off off on off) #15(off on off on on off off off off off on off) #15(off off on on on on on on on on off) #15(off off off on on off) #15(off off off on on off)))) (make-problem "19990923-MAT (36)" (quote ((5 5) (4 5 4) (3 1 1 3) (2 9 2) (1 1 5 1 1) (9) (2 2) (2 2) (2 2) (2 2) (1 2 2 1) (2 2 2 2) (3 2 2 3) (4 4) (5 5))) (quote ((5 5) (4 4) (3 1 3) (2 3 3 2) (1 2 3 2 1 1) (1 4 3) (1 3 1) (1 3 1) (1 3 3) (1 5 2 1) (1 2 2 3 1) (2 3 1 2) (3 3) (4 4) (5 5))) (quote #15(#15(on on on on on off off off off off on) #15(on on on on off off off off off off off on) #15(on on on off off off off off on off off off on) #15(on on off on on on off on on on off off off on) #15(on off on on off on on on off on on off on off on) #15(off on off on on on on off off off on on on off) #15(off on off on on on off off off off off on off) #15(off on off on on on off off on off) #15(off on off on on on off on on on off) #15(off on off on on on on on off on on off on off) #15(on off on on off on on off off off on on on off on) #15(on on off on on on off off off off off on off on) #15(on on on off off off off off off off off off on) #15(on on on on off off off off off off off on) #15(on on on on on off off off off off on)))) (make-problem "19990924aMAT (37)" (quote ((1) (1 1 1 1) (3 1 1 3) (1 1 1 5 1 1) (8 2 1 1) (1 1 1 1 1 1 1) (1 1 1 1 1 1 1) (1 1 1 1 1 1 1) (1 1 1 1 1 1 1) (1 1 1 1 1 1 1) (1 1 2 1 2 1) (1 1 1 1 1 1) (1 1 1 1 1 1) (1 1 9 1) (1 3 2 2 3))) (quote ((12) (1) (13) (2 1 1) (13) (1 1 1) (8 2) (1 2 2) (1 1 4) (1 2 2) (8 2) (1 1) (13) (2 1) (13))) (quote #15(#15(off off off on) #15(off off off off on off) #15(off off on) #15(off on on off on off off off off off off off off off on) #15(off off on) #15(off off off off on off off off off off on off off on off) #15(off off on on on on on on on on off off off on) #15(off on off on on off off off off off off off off on) #15(on off off on off off off off off off on on on on off) #15(off on off on on off off off off off off off off on) #15(off off on on on on on on on on off off off on) #15(off off off off off off off off off off on off off on off) #15(off off on) #15(off on on off off off off off off off off off off off on) #15(off off on)))) (make-problem "19990924bMAT (38)" (quote ((15) (6 7) (6 7) (9 2 1) (7 2 1 1) (5 1 3 1 1) (5 1 4 1) (2 1 1 4 1) (2 2 4 1) (2 3 3 2) (1 2 2 1 2) (3 2 2 2 1) (3 1 2 2 1) (3 1 1 7) (3 1 1 7))) (quote ((9 5) (10 4) (7 1 4) (7) (8 1 2) (5 4) (1 12) (1 1) (15) (3 11) (4 5 2) (5 3 5) (3 1 4) (3 2 2) (15))) (quote #15(#15(on on on on on on on on on off on) #15(on on on on on on on on on on off on) #15(on on on on on on on off off on off on) #15(on on on on on on on off) #15(on on on on on on on on off on off off off on) #15(on on on on on off off off on on on on off) #15(on off off on) #15(on off off on off) #15(on) #15(on on on off on) #15(on on on on off on on on on on off off off on) #15(on on on on on off on on on off on) #15(on on on off off on off off off off off on) #15(on on on off off off off off off on on off off on) #15(on)))) (make-problem "19990924cMAT (39)" (quote ((2) (2 2) (1 1 4) (1 2 1 2) (1 2 1 2) () (4 4) (7 1 2 1) (1 2 2 2 1) (1 4 1 2 1) (6 4) (6 1 1) (8 1 1) (8 1 1) (8 2 2))) (quote ((2 3) (2 1 5) (1 2 6) (1 2 9) (1 2 9) (1 2 6) (2 1 5) (2 3) (2) (1 1) (1 1 5) (5 5) (5 5) (1 1 5) (3 1))) (quote #15(#15(off off off off off off off off on on off off on) #15(off off off on on off off on off off on) #15(off off on off off off on on off on) #15(off on off on on off on) #15(off on off on on off on) #15(off off on off off off on on off on) #15(off off off on on off off on off off on) #15(off off off off off off off on on off off off on) #15(off off off off off off off off on on off) #15(off off off off off off off on off off off off off off on) #15(off off on off off off on off off off on) #15(on on on on on off on on on on on off) #15(on on on on on off on on on on on off) #15(off off on off off off on off off off on) #15(off off off off off off off on on on off off off off on)))) (make-problem "19990924dMAT (40)" (quote ((3 3) (5 5) (7 7) (7 7) (7 7) (5 5) (3 3) (11) (6 1 2 2) (13) (7 5) (10 2) (1 1 1) (1 1 1) (1 1 1))) (quote ((3) (5 2) (12) (12) (12 1) (5 7) (3 5) (1 6) (3 5) (5 1 1 3) (12 1) (12) (7 2) (5 4) (3 4))) (quote #15(#15(off off on on on off) #15(off on on on on on off on on off) #15(on on on on on on on on on on on on off) #15(on on on on on on on on on on on on off) #15(on on on on on on on on on on on on off off on) #15(off on on on on on off on on on on on on on off) #15(off off on on on off off on on on on on off) #15(off off off off off off off on off on) #15(off off on on on off off on on on on on off) #15(off on on on on on off on off on off on on on off) #15(on on on on on on on on on on on on off off on) #15(on on on on on on on on on on on on off) #15(on on on on on on on off off on on off) #15(off on on on on on off off on on on on off) #15(off off on on on off off off on on on on off)))) (make-problem "19990924eMAT (41)" (quote ((1 10) (8) (2 2 4) (1 1 4 3) (7 3) (1 6 3) (1 8 2) (2 9 2) (3 8 2) (4 7 1) (6 6 1) (7 3 1) (9 1 2) (10 2) (12 1))) (quote ((1 10) (8) (2 7) (1 1 6) (2 3 5) (1 5 5) (1 6 4) (2 8 3) (11 3) (12 2) (2 10 1) (3 6 1) (6 2 2) (9 2) (12 1))) (quote #15(#15(on off off off off on) #15(off off off off off off off on) #15(off off on on off off off off on) #15(off off on off off off off on off on) #15(off off off on on off on on on off on) #15(on off off off on on on on on off on) #15(on off off off on on on on on on off on) #15(on on off on on on on on on on on off on) #15(on on on on on on on on on on on off on) #15(on on on on on on on on on on on on off on) #15(on on off on on on on on on on on on on off on) #15(on on on off off off on on on on on on off off on) #15(on on on on on on off off off on on off on on off) #15(on on on on on on on on on off off off on on off) #15(on on on on on on on on on on on on off off on)))) (make-problem "19990925-MAT (42)" (quote ((9 4) (9 1 2) (10 2 1) (10 1 1) (6 1) (5 1 4) (4 1 4) (4 1 4) (4 4) (4 5) (2 6) (2 10) (1 1 10) (1 2 10) (2 11))) (quote ((11 2) (11 1 1) (10 1 1) (10 3) (6 1) (5 2 4) (4 1 4) (4 4) (4 4) (2 5) (1 6) (1 2 10) (1 1 11) (2 10) (4 10))) (quote #15(#15(on on on on on on on on on on on off off on) #15(on on on on on on on on on on on off on off on) #15(on on on on on on on on on on off on off on off) #15(on on on on on on on on on on off on on on off) #15(on on on on on on off off off off off off off off on) #15(on on on on on off on on off off off on) #15(on on on on off on off off off off off on) #15(on on on on off off off off off off off on) #15(on on on on off off off off off off off on) #15(off off on on off off off off off off on) #15(off on off off off off off off off on) #15(on off on on off on) #15(on off on off on) #15(on on off off off on) #15(on on on on off on)))) (make-problem "19990927aMAT (43)" (quote ((12) (12) (2 7) (2 5) (2 1) (2 7) (2 1 1 4) (2 1 1 2) (2 1 1 1 2) (2 1 1 2) (2 9 2) (2 9 2) (2 7) (2 5) (12))) (quote ((15) (15) (2 1) (2 1 3 1) (3 2 1 3 1) (4 1 1 5) (4 1 5) (7 1 5) (4 1 5) (4 3 5) (3 1 1 3 1) (2 1 3 1) (2) (5) (4))) (quote #15(#15(on) #15(on) #15(on on off off off off off off off off off off off off on) #15(on on off off off on off off off on on on off off on) #15(on on on off off on on off on off on on on off on) #15(on on on on off on off on off off on) #15(on on on on off on off off off off on) #15(on on on on on on on off on off on) #15(on on on on off on off off off off on) #15(on on on on off on on on off off on) #15(on on on off off off on off on off on on on off on) #15(on on off off off off on off off on on on off off on) #15(off off off off off off on on off) #15(off off off off off off off on on on on on off) #15(off off off off off off off off on on on on off)))) (make-problem "19990927bMAT (44)" (quote (() (2) (1 2) (2 2) (6 3) (3 3 1) (4 4 2) (15) (1 7 1) (3 5 3) (2 2 3 2 2) (1 1 1 3 1 1 1) (2 2 2 2) (3 3) ())) (quote ((2 2 3) (5 2 2) (4 1 1 1) (4 2 2) (1 3 3) (1 1 3) (1 5) (2 6) (2 7) (7) (5 3) (1 1 2 2) (3 1 1 1) (2 2 2) (2 3))) (quote #15(#15(off off off on on off off on on off on on on off) #15(off off off on on on on on off on on off on on off) #15(off off off off on on on on off on off on off on off) #15(off off off off on on on on off on on off on on off) #15(off off off off on off on on on off on on on off) #15(off off on off on off off on on on off) #15(off on off off off off off on on on on on off) #15(off on on off off off on on on on on on off) #15(off off on on off on on on on on on on off) #15(off off off on on on on on on on off) #15(off off off off on on on on on off on on on off) #15(off off off off on off off on off on on off on on off) #15(off off off off off on on on off on off on off on off) #15(off off off off off off on on off on on off on on off) #15(off off off off off off off on on off on on on off)))) (make-problem "19990927cMAT (45)" (quote (() (10) (2 1) (1 1) (1 1) (1 1) (2 2) (2 3 2) (13) (1 3 1) (13) (1 1 1 1 1 1 1 1) (2 1 1 1 1 1 2) (1 1 1 1 1 1 1 1) (15))) (quote ((4) (5 1 1) (5 2 2) (1 1 1 1 1) (1 1 2 2) (2 1 1 1 1) (1 5 2) (1 4 1 1) (1 5 2) (1 1 1 1 1) (1 1 2 2) (1 1 1 1 1) (1 5 2 2) (1 1 5 1 1) (2 4))) (quote #15(#15(off off off off off off off off off off off on) #15(off off off off off off on on on on on off on off on) #15(off off off off on on on on on off on on off on) #15(off off off on off off off off on off on off on off on) #15(off off on off off off off off on off on on off on) #15(off on on off off off off off on off on off on off on) #15(off on off off off off off on on on on on off on) #15(off on off off off off off on on on on off on off on) #15(off on off off off off off on on on on on off on) #15(off on off off off off off off on off on off on off on) #15(off on off off off off off off on off on on off on) #15(off on off off off off off off on off on off on off on) #15(off on off off on on on on on off on on off on) #15(off on off on off off on on on on on off on off on) #15(off on on off off off off off off off off on)))) (make-problem "19990927dMAT (46)" (quote ((3) (2 2) (1 1) (1 1) (1 2) (3 3) (2 2 2) (1 2 6) (1 10) (2 2 2) (4 2) (2 2) (2) (2) (1))) (quote ((4 1) (2 3) (1 1) (1 1) (1 2) (4) (3 2) (2 3 6) (1 10) (2 2 2) (4 2) (2) (2) (2) (1))) (quote #15(#15(off off off off off off on on on on off on off) #15(off off off off off on on off off on on on off) #15(off off off off off on off off off off on off) #15(off off off off off on off off off off on off) #15(off off off off off off on off off on on off) #15(off off off off off off on on on on off) #15(off on on on off off off on on off) #15(on on off off on on on off on on on on on on off) #15(on off off off off on) #15(on on off off on on off on on off) #15(off on on on on off off on on off) #15(off off off off off off off on on off) #15(off off off off off off off on on off) #15(off off off off off off off on on off) #15(off off off off off off off off on off)))) (make-problem "19990930-TPV (47)" (quote (() (13) (1 11) (13) (13) (13) (13) (13) (13) (2 4) (2 3 4) (2 3 4) (2 3 4) (1 3 4) ())) (quote (() (12) (1 11) (8) (8 4) (8 4) (8 4) (8) (8) (8) (13) (13) (13) (13) ())) (quote #15(#15(off) #15(off on on on on on on on on on on on on off) #15(off on off on on on on on on on on on on on off) #15(off on on on on on on on on off) #15(off on on on on on on on on off on on on on off) #15(off on on on on on on on on off on on on on off) #15(off on on on on on on on on off on on on on off) #15(off on on on on on on on on off) #15(off on on on on on on on on off) #15(off on on on on on on on on off) #15(off on on on on on on on on on on on on on off) #15(off on on on on on on on on on on on on on off) #15(off on on on on on on on on on on on on on off) #15(off on on on on on on on on on on on on on off) #15(off)))) (make-problem "19991001aMAT (48)" (quote ((2) (4) (4 2) (2 5) (7) (2 4) (4) (6) (1 5) (5) (5 1) (6 2) (2 4 1) (3 4 2) (2 2 3))) (quote ((2) (2 1) (1 2) (4 1 1) (2 2 1 2) (6 1 2) (13) (9 1) (11) (8) (6) (4) (1) (2 2) (3))) (quote #15(#15(off off on on off) #15(off off on on off on off) #15(off off on off on on off) #15(off on on on on off off off on off off off off off on) #15(on on off on on off off on off off off off off on) #15(on on on on on on off on off off off off on on off) #15(off on on on on on on on on on on on on on off) #15(off off off on on on on on on on on on off off on) #15(off off off off on) #15(off off off off off off on on on on on on on on off) #15(off off off off off off off off on on on on on on off) #15(off off off off off off off off off off off on) #15(off off off off off off off off off off off off off off on) #15(off off off off off off off off off off on on off on) #15(off off off off off off off off off off off on on on off)))) (make-problem "19991001bMAT (49)" (quote ((2) (1 2) (1 1 2) (1 4) (1 3) (13) (3 11) (2 8 1) (3 7 2) (13) (3 2) (3 2) (3 2) (3 2) (2 1))) (quote ((3) (5) (6 3) (1 3) (2 5) (5 3) (5 3) (5 2) (2 5) (1 7) (11 1) (7 6) (3 1 1 1) (2 2) (3))) (quote #15(#15(off off off off off off on on on off) #15(off off off off off on on on on on off) #15(off on on on on on on off on on on off) #15(off off off off off on off off off on on on off) #15(off off off off off on on off on on on on on off) #15(off off off off off on on on on on off on on on off) #15(off off off off off on on on on on off off on) #15(off off off off off on on on on on off off off on) #15(off off on on off on on on on on off) #15(on off off on on on on on on on off) #15(on on on on on on on on on on on off on off) #15(off on on on on on on on off on) #15(off off off off off on on on off on off on off on off) #15(off off off off off on on off on on off) #15(off off off off off off on on on off)))) (make-problem "19991001cMAT (50)" (quote ((3) (3) (3) (3) (9) (5 3) (3) (1 1 1) (1 1 1 1) (1 1 1 1 1) (1 1 1 1) (1 1 1 1 1) (1 1) (1 1) (2 2))) (quote (() (1) (1) (2 1 1) (1 1 1 1) (2 1 1 4) (3 3 1 1) (3 4 1 1) (3 3 1 1) (2 1 1 4) (1 1 1 1) (2 1 1) (1) (1) ())) (quote #15(#15(off) #15(off off off on off) #15(off off off on off) #15(off off off on on off off off off on off on off) #15(off off off off on off off off on off on off off off on) #15(off off off off on on off on off on off on) #15(on on on off on on on off on off on off) #15(on on on off on on on on off on off on off) #15(on on on off on on on off on off on off) #15(off off off off on on off on off on off on) #15(off off off off on off off off on off on off off off on) #15(off off off off on on off off off on off on off) #15(off off off off off on off) #15(off off off off off on off) #15(off)))) (make-problem "19991001dMAT (51)" (quote ((1 3) (2 4) (1 2) (2 3) (1 4) (2 4) (4 4) (1 5) (2 1 2) (3 1 1 1) (1 1 1 1 1 1) (1 1 2) (3 2 1) (2 2 1) (1 3))) (quote ((4) (2 4 3) (3 1 2 2) (4) (2 1) () (1) () (5) (1 2) (4 1 1 2) (7 2 1) (9 3) (2 8) (2))) (quote #15(#15(off off off off off off off off off on on on on off) #15(on on off off off off on on on on off off on) #15(off on on on off off on off on on off off on on off) #15(off off off on on on on off) #15(off off off off off on on off off off on off) #15(off) #15(off off off off off off off off off off on off) #15(off) #15(off off off off off off off off on on on on on off) #15(off off off off off off off on off off off off on on off) #15(off off off off on on on on off on off on off on) #15(off on on on on on on on off off on on off off on) #15(on on on on on on on on on off off off on) #15(on on off on on on on on on on on off) #15(on on off)))) (make-problem "19991010bTPV (52)" (quote ((1) (1) (2 1) (1 4) (2 3 2 1) (6 6) (14) (12) (12) (11) (3 2) (3 2) (5) (3) (2 2))) (quote ((2 3) (6) (6) (8) (9) (6 2) (5 1 1) (1 4 3) (1 1 4 3) (1 1 7 2) (9 1) (7) (1 2) (3) (1))) (quote #15(#15(off off off on on off on on on off) #15(off off off off on on on on on on off) #15(off off off off off on on on on on on off) #15(off off off off on on on on on on on on off) #15(off off off off on on on on on on on on on off) #15(off off off off on on on on on on off on on off) #15(off off off off off on on on on on off off on off on) #15(off off on off off off on on on on off off on) #15(on off on off off off on on on on off on on on off) #15(off on off on off on on on on on on on off on) #15(off off on on on on on on on on on off off off on) #15(off off off on on on on on on on off) #15(off off off on off on on off) #15(off off off off on on on off) #15(off off off off off on off)))) (make-problem "19991012-PIX (53)" (quote ((2) (2 2) (6 7) (3 1 1 4) (4 1 3) (11 3) (1 6 2) (2 2 3) (2 2 2) (2 2 2) (1 1 1) (2 2 2) (15) (15) (15))) (quote ((2 4 3) (5 1 3) (5 3) (5 3) (1 5 4) (2 10) (2 3) (2 3) (2 1 3) (1 1 4) (1 2 7) (4 3 3) (8 3) (8 4) (4 7))) (quote #15(#15(off on on off on on on on off off off off on) #15(off on on on on on off on off off off off on) #15(off off on on on on on off off off off off on) #15(off off on on on on on off off off off off on) #15(off off on off off on on on on on off on) #15(off off on on off on) #15(off off off off off on on off off off off off on) #15(off off off off off on on off off off off off on) #15(off off on on off on off off off off off off on) #15(off off on off off on off off off off off on) #15(off off on off on on off off on) #15(on on on on off off off on on on off off on) #15(on on on on on on on on off off off off on) #15(off off on on on on on on on on off on) #15(off off on on on on off off on)))) (make-problem "19991112-SHE (54)" (quote ((9) (1 1) (1 1) (1 1) (1 1) (1 1) (1 1) (9) (11) (7 1) (11) (1) (9) (2 2 2 2) (13))) (quote (() (1) (3 2) (11 3) (1 4 1 1) (1 4 3) (1 4 3) (1 4 1 1) (1 4 3) (1 2 1 3) (1 2 3 1) (9 1 3) (3 2) (1) ())) (quote #15(#15(off) #15(off off off off off off off off off off off off off off on) #15(off off off off off off off off on on on off off on) #15(on on on on on on on on on on on off on) #15(on off off off off off off on on on on off on off on) #15(on off off off off off off on on on on off on) #15(on off off off off off off on on on on off on) #15(on off off off off off off on on on on off on off on) #15(on off off off off off off on on on on off on) #15(on off off off off off off on on off on off on) #15(on off off off off off off on on off on on on off on) #15(on on on on on on on on on off on off on) #15(off off off off off off off off on on on off off on) #15(off off off off off off off off off off off off off off on) #15(off)))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/solution-sets/k15x20 b/collects/games/paint-by-numbers/solution-sets/k15x20
new file mode 100644
index 0000000000..1fff8c5280
--- /dev/null
+++ b/collects/games/paint-by-numbers/solution-sets/k15x20
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 15x20") (define problems (list (make-problem "19990127aLLO (1)" (quote ((6 2) (1 1 6) (1 1 2 2) (2 2 1 1) (1 2 1) (6 1 4 1) (1 1 1 1 1) (1 1 1 1) (3 1 1 1 1 1) (1 1 1 1) (5 1 1 1 1) (1 1 1 1 1 1) (3 1 1 1 1) (1 1 1 1) (1 1 1 1 1 1) (6 1 1 1) (1 1 1 1 1) (1 2 2 1) (5 4 1) (1 1 2 1))) (quote ((4 2 1 1 3 2) (1 1 1 1 1 1 1) (1 1 1 3 1 1) (1 1 1 1 1 3) (1 1 1 1 3 1 1) (4 1 3) () (16) (2 2) (1 10 2) (2 2 2) (2 2 2) (1 13) (2) (18))) (quote #15(#20(on on on on off on on off on off on off off off on on on off on) #20(on off off on off on off off on off on off off off off on off off on off) #20(on off off off off on off off on off on on on off off on off off on off) #20(on off off off off on off off off off on off on off off on off on) #20(on off off on off on off off on off on on on off off on off off on off) #20(on on on on off on off off off off off off off off on on on off) #20(off) #20(off off on on on on on on on on on on on on on on on on off) #20(off on on off off off off off off off off off off off off off off on on off) #20(off on off off off on on on on on on on on on on off off off on) #20(on on off off on on off off off off off off off off off off off off on) #20(on on off off on on off off off off off off off off off off off on on off) #20(off on off off off on on on on on on on on on on on on on off) #20(off on on off) #20(off off on)))) (make-problem "19990127bLLO (2)" (quote ((3) (5) (7) (1 7) (2 4) (7) (5) (5) (5) (8) (6 2) (2 3 1 1) (2 2 2) (8) (5) (5) (5) (7) (7) (5))) (quote ((1) (3) (2 2) (2 3 1) (1 2 3 1 2) (3 15) (4 6 8) (4 5 1 7) (11 8) (19) (4 2) (2) () () ())) (quote #15(#20(off off off off off off off off off off off on off) #20(off off off off off off off off off off on on on off) #20(off off off off off off off off off on on off on on off) #20(off off off on on off off off off on on on off on off) #20(off off on off on on off off off on on on off on off off off on on off) #20(off on on on off on) #20(on on on on off on on on on on on off on) #20(on on on on off on on on on on off on off on) #20(on on on on on on on on on on on off on) #20(off on) #20(off off on on on on off off off off off off off off off off off on on off) #20(off off off on on off) #20(off) #20(off) #20(off)))) (make-problem "19990421bMIJ (3)" (quote (() (1 1 1) (2 2) (1 1 1) (2 1) (1 1) (1 1) (1) (1) (1 1 1 1) (3 1 3) (3 4) (1 3) (1 2) (1 1 1) (2 1 1) (2 1) (1 1) (15) (15))) (quote ((2) (1 2) (3 1 2) (10) (3 1 2) (5 1 2) (1 1 1 2) (1 1 13) (1 1 3 2) (5 3 2) (2 2) (2 2) (2) (2) (2))) (quote #15(#20(off off off off off off off off off off off off off off off off off off on) #20(off off off off off off off off off off off off off off on off off off on) #20(off off off off off off off off off on on on off off off on off off on) #20(off off off off off off off off off off on) #20(off off off off off off off off off on on on off off off off on off on) #20(off on on on on on off off off off off off off off off on off off on) #20(off off on off on off on off off off off off off off off off off off on) #20(off on off on off off off on) #20(off off on off off off on off off off off on on on off off off off on) #20(off on on on on on off off off off on on on off off off off off on) #20(off off off off off off off off off off on on off off off off off off on) #20(off off off off off off off off off on on off off off off off off off on) #20(off off off off off off off off off off off off off off off off off off on) #20(off off off off off off off off off off off off off off off off off off on) #20(off off off off off off off off off off off off off off off off off off on)))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/solution-sets/k15x25 b/collects/games/paint-by-numbers/solution-sets/k15x25
new file mode 100644
index 0000000000..aadd34f9e8
--- /dev/null
+++ b/collects/games/paint-by-numbers/solution-sets/k15x25
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 15x25") (define problems (list (make-problem "19990804aVAC (1)" (quote ((3) (4) (4 4) (7 3) (7 3) (2 2 2) (1 2) (4 2) (7) (8) (2 1 3) (1 2) (2 2) (2 2) (1 1 1 2) (1 1 1 2) (1 1 1 1 2) (6 2 1) (1 1 1 4) (1 3 1 4) (1 1 3 1) (1 6 2) (1 4 2) (1 2 2) (1 2))) (quote ((2 5) (3 1 1) (4 6 1 1) (3 4 3 1 1) (3 2 1 1 2 1) (4 2 6 3) (7 3) (4 3 1) (3 3 3 1) (2 3 1 1) (3 3 2) (5 14 2) (7 10 1) (4 3) (3))) (quote #15(#25(off off off on on off off off off off off off off off off off on on on on on off) #25(off off off on on on off off off off off off off off off off off on off off off on off) #25(off off on on on on off off off off off off on on on on on on off off on off on off) #25(off off on on on off off off off off on on on on off off off on on on off on off on off) #25(off off on on on off off off off on on off off off off off off on off on off on on off on) #25(off off on on on on off off on on off off off off on on on on on on off on on on off) #25(off off off on on on on on on on off off off off off off off off off off off on on on off) #25(off off off off off off off on on on on off off off off off off off off off on on on off on) #25(off off off off off off off on on on off off off off on on on off off on on on off off on) #25(on on off off off off off on on on off off off off off off off off off off on off off on off) #25(on on on off off off off off on on on off off off off off off off off off off off on on off) #25(on on on on on off on on on on on on on on on on on on on on off on on off) #25(off on on on on on on on off off on on on on on on on on on on off on off) #25(off off on on on on off off off off off off off off off off off off on on on off) #25(off off off off off off off off off off off off off off off off off on on on off)))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/solution-sets/k20x15 b/collects/games/paint-by-numbers/solution-sets/k20x15
new file mode 100644
index 0000000000..29fffd92a7
--- /dev/null
+++ b/collects/games/paint-by-numbers/solution-sets/k20x15
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 20x15") (define problems (list (make-problem "19990524-KHO (1)" (quote ((1) (2 2 1) (1 1 2) (3 1) (5 2) (3 3 1) (8 1) (19) (1 14) (1 13) (13) (2 1 1 3 3) (4 1 1 2 2) (4 1 1 1 1) (2 1 1 2 2))) (quote ((2) (3 1 4) (1 4 4) (1 4 2) (3 2) (6 1) (12) (1 7 1) (1 8) (4) (4) (4) (5) (6 1) (8) (4) (6 1) (3 8) (3 5) (4))) (quote #20(#15(off off off off off off off off off off off off on on off) #15(off off off off off on on on off on off on) #15(off on off off off on on on on off off on) #15(off on off off on on on on off off off off on on off) #15(off off on on on off on on off) #15(off off off on on on on on on off off off off off on) #15(off off on on on on on on on on on on on on off) #15(off on off off on on on on on on on off off off on) #15(off on off off off off on on on on on on on on off) #15(off off off off off off off on on on on off) #15(off off off off off off off on on on on off) #15(off off off off off off off on on on on off) #15(off off off off off off off on on on on on off) #15(off off off off off off off on on on on on on off on) #15(off off off off off off off on) #15(off off off off off off off on on on on off) #15(off off off off off off off on on on on on on off on) #15(on on on off off off off on) #15(off off on on on off off on on on on on off) #15(off off off off on on on on off)))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/solution-sets/k20x20 b/collects/games/paint-by-numbers/solution-sets/k20x20
new file mode 100644
index 0000000000..560edcccef
--- /dev/null
+++ b/collects/games/paint-by-numbers/solution-sets/k20x20
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 20x20") (define problems (list (make-problem "19980407-KVL (1)" (quote ((10 8) (9 6) (5 5 5) (6 7 4) (6 9 3) (4 2 2 1 1 3) (5 3 2 1 1 3) (5 2 2 1 2 2) (4 2 2 1 2 2) (5 3 7 2) (5 1 2 1 3) (2 1 1 7 3) (3 1 6 4) (3 1 8 3) (2 6 5 2) (3 4 3 2) () (2 3 3 3 3 1) (2 3 3 3 3 1) ())) (quote ((16 2) (16 2) (11 2 1) (12 1 2) (5 2 2 2 2) (2 2 5 2) (2 5 2) (2 6 2 2) (2 4 2 2 2) (1 3 4 2) (8 3) (8 4 2) (1 3 1 5 2) (1 14 2) (2 2 1 5) (3 6 1 2 2) (4 3 1 2) (7 4 2) (16) (16 2))) (quote #20(#20(on on on on on on on on on on on on on on on on off on on off) #20(on on on on on on on on on on on on on on on on off on on off) #20(on on on on on on on on on on on off on on off on off) #20(on on on on on on on on on on on on off off on off off on on off) #20(on on on on on off on on off on on off off off on on off on on off) #20(on on off on on off off off off off off on on on on on off on on off) #20(on on off off off off on on on on on off off off on on off) #20(on on off off on on on on on on off off off off on on off on on off) #20(on on off on on on on off off on on off off on on off off on on off) #20(on off on on on off off off off off on on on on off off off on on off) #20(off off on on on on on on on on off on on on off) #20(off off on on on on on on on on off on on on on off off on on off) #20(on off on on on off off off off on off on on on on on off on on off) #20(on off on on on on on on on on on on on on on on off on on off) #20(on on off on on off off off off on off on on on on on off) #20(on on on off on on on on on on off on off on on off off on on off) #20(on on on on off off off on on on off off on off off off off on on off) #20(on on on on on on on off off off on on on on off off off on on off) #20(on on on on on on on on on on on on on on on on off) #20(on on on on on on on on on on on on on on on on off on on off)))) (make-problem "19980501aGOS (2)" (quote ((7 7) (5 5) (3 3) (2 2) (2 2) (1 2 2 1) (1 4 4 1) (2 1 2 1) (2 2) () (2 2) (4 4) (1 1 4 1 1) (1 2 1 1 2 1) (1 3 3 1) (2 4 2) (2 2) (3 3) (5 5) (7 7))) (quote ((7 7) (5 5) (3 3) (2 1 2) (2 3 2) (1 2 1 1 1) (1 4 4 1) (2 1 1 1) (2 4) (1 1) (1 1) (2 4) (4 1 1) (1 2 1 4 1) (1 2 1 1 1) (2 3 2) (2 1 2) (3 3) (5 5) (7 7))) (quote #20(#20(on on on on on on on off off off off off off on) #20(on on on on on off off off off off off off off off off on) #20(on on on off off off off off off off off off off off off off off on) #20(on on off off off off off off off off on off off off off off off off on) #20(on on off off off off off off off off on on on off off off off off on) #20(on off off off off off on on off off off on off on off off off off off on) #20(on off off off off on on on on off off on on on on off off off off on) #20(off off off off off on on off on off off on off off on off) #20(off off off off off off on on off off off off on on on on off) #20(off off off off off off off off off off off off on off off on off) #20(off off off off off off off off off off off off on off off on off) #20(off off off off off off on on off off off off on on on on off) #20(off off off off off on on on on off off on off off on off) #20(on off off off off on on off on off off on on on on off off off off on) #20(on off off off off off on on off off off on off on off off off off off on) #20(on on off off off off off off off off on on on off off off off off on) #20(on on off off off off off off off off on off off off off off off off on) #20(on on on off off off off off off off off off off off off off off on) #20(on on on on on off off off off off off off off off off on) #20(on on on on on on on off off off off off off on)))) (make-problem "19980608-JEN (3)" (quote ((3 2 2 1) (1 2 2 2) (1 1) (1 1) (1 2 1) (1 2 1 3) (1 1 3 1 1) (1 1 2 1 1) (1 2 2 3) (1 1 1) (1 1 3) (2 1 3) (5 1 3) (1 5 1 3) (3 4 4) (4 1 4) (5 6) (7) (5) (4))) (quote ((15) (1 2 1) (2 2 1 2) (1 1 1 1 1) (1 1 1 2 1) (1 1 1 2) (1 1 1 1) (1 3 1 1) (1 1 2 2 1) (1 1 1 1 2) (1 3 1 3) (6 12) (1 1 4) (3 5) (5) (8) (8) (5) () ())) (quote #20(#20(on on on on on on on on on on on on on on on off) #20(on off off off off off off off off off off on on off on off) #20(on on off off off off on on off off off off on off on on off) #20(off on off off off on off off on off off off on off off on off) #20(on off off off off on off off on off off off on on off on off) #20(on off off off off off on off off off off off off on off on on off) #20(off on off off off off on off off off off off off on off off on off) #20(off on off off off on on on off off off off off on off off on off) #20(on off off off on off off on on off off off off on on off on off) #20(on off off off on off off off on off off off off off on off on on off) #20(off on off off off on on on off off off off off off on off off on) #20(on on on on on on off off on) #20(off off off off off on off off on off off off off off off off on) #20(off off off off off off on on on off off off off off off on) #20(off off off off off off off off off off off off off off on on on on on off) #20(off off off off off off off off off off on on on on on on on on off) #20(off off off off off off off off off on on on on on on on on off) #20(off off off off off off off off off off on on on on on off) #20(off) #20(off)))) (make-problem "19980907-KEV (4)" (quote (() (7 2 3) (8 2 4) (2 2 4 1 1) (2 2 4 4) (2 2 1 1 3) (2 2 4 1 2) (5 2 1 1 1 2) (4 5 3 2) () () (1 1 2 3 2) (1 1 2 4 3) (1 1 4 1 1 2) (1 1 4 4 2) (1 1 1 1 1 3 2) (1 1 1 4 1 2 2) (5 1 1 1 6) (3 2 3 5) ())) (quote ((2 7) (2 2 2) (4 2 4) (2 4 2) (2 2 7) (2 1) (8 6) (8 4 1) (2 1 4 1) (2 1 6) (6 1) (4 1 8) (4 1 2 2) (6 2 3) (1 3 3) (8 2) (2 2 2 2) (2 3 4 2) (3 3 2 4) (2 2 2))) (quote #20(#20(off off off off off off off on on off off on on on on on on on off) #20(off off off on on off off on on off off off off off off off off on on off) #20(off off on on on on off on on off off off off off off on on on on off) #20(off on on off off on on on on off off off off off off off off on on off) #20(off on on off off off on on off off off on on on on on on on off) #20(off on on off off off off off off off off off off off off off off off on off) #20(off on on on on on on on on off off off off on on on on on on off) #20(off on on on on on on on on off off on on on on off on off) #20(off on on off off off off off on off off on on on on off on off) #20(off on on off off off off off on off off off off on on on on on on off) #20(off off off on on on on on on off off off off off off off off off on off) #20(off on on on on off on off off off off on on on on on on on on off) #20(off on on on on off on off off off off on on off on on off) #20(off off off on on on on on on off off on on off on on on off) #20(off off off off off off off off on off off off on on on off on on on off) #20(off on on on on on on on on off off off off off off off off on on off) #20(off on on off on on off off off off off off off on on off off on on off) #20(off on on off on on on off off off off off on on on on off on on off) #20(off off on on on off on on on off off on on off off on on on on off) #20(off off off off off off off on on off off on on off off off on on off)))) (make-problem "19990126aLLO (5)" (quote ((1 1 1) (2 1 2) (1 2 1) (1 1 1) (2 2 2) (1 1 1) (1 1 1) (2 2 2) (1 1 1) () (11) (2 2 3) (2 4 1) (4 5 1) (17 1) (15 3) (13) (11) (2 7 2) (17))) (quote ((1) (4 2) (6 1) (2 2 5 1) (4 2 1 5 1) (4 1 6) (1 6) (3 1 6) (3 2 1 6) (4 1 6) (1 6) (2 4 1 6) (4 2 1 5 1) (2 5 1) (6 1) (4 1) (3 1) (2 2 2) (1 1 1) (5))) (quote #20(#20(off off off off off off off off off off off off off off off off off off on off) #20(off off off off off off off off off off off off on on on on off off on) #20(off off off off off off off off off off off on on on on on on off off on) #20(on on off off off off off off off off on on off on on on on on off on) #20(off on on on on off off on on off on off off on on on on on off on) #20(off off off off on on on on off off on off off off on) #20(off off off off off off off off off off on off off off on) #20(on on on off off off off off off off on off off off on) #20(off off on on on off off on on off on off off off on) #20(off off off off on on on on off off on off off off on) #20(off off off off off off off off off off on off off off on) #20(on on off off on on on on off off on off off off on) #20(off on on on on off off on on off on off off on on on on on off on) #20(off off off off off off off off off off on on off on on on on on off on) #20(off off off off off off off off off off off on on on on on on off off on) #20(off off off off off off off off off off off off on on on on off off off on) #20(off off off off off off off off off off off off on on on off off off off on) #20(off off off off off off off off off off off on on off on on off off on) #20(off off off off off off off off off off off on off off off on off off on off) #20(off off off off off off off off off off off on on on on on off)))) (make-problem "19990211aJAM (6)" (quote (() (4 4) (2 3 3 2) (1 2 2) (2 1 1 2) (2 2) (2) (4) (4) (4) (6) (6) (2) () (9) (11) (3 3) (2 5 3) (2 3 3) ())) (quote (() (2) (2 1) (1 2) (1 2 2) (2 2 2) (1 3) (2 2 2) (2 5 2 1) (7 2 2) (7 2 2) (2 5 2 2) (2 2 2 1) (1 2) (2 3) (1 2 3) (1 2 3) (2 2) (1 1) ())) (quote #20(#20(off) #20(off off on on off) #20(off on on off off off off off off off off off off off off off off off on off) #20(off on off off off off off off off off off off off off off off off on on off) #20(off on off off on on off off off off off off off off off off on on off) #20(off on on off on on off off off off off off off off off on on off) #20(off off on off off off off off off off off off off off on on on off) #20(off off on on off off off off off off on on off off on on off) #20(off off off on on off off on on on on on off off on on off on off) #20(off off off off off off on on on on on on on off on on off on on off) #20(off off off off off off on on on on on on on off on on off on on off) #20(off off off on on off off on on on on on off off on on off on on off) #20(off off on on off off off off off off on on off off on on off on off) #20(off off on off off off off off off off off off off off on on off) #20(off on on off off off off off off off off off off off on on on off) #20(off on off off on on off off off off off off off off off on on on off) #20(off on off off on on off off off off off off off off off off on on on off) #20(off on on off off off off off off off off off off off off off off on on off) #20(off off on off off off off off off off off off off off off off off off on off) #20(off)))) (make-problem "19990214bFRA (7)" (quote ((20) (1 3 3 2) (3 4 1 1) (3 4 1) (3 4 1) (3 5 2) (3 6 3) (3 7 4) (3 8 5) (1 7 6) (20) (20) (1 4 3 5 3) (1 3 3 3 3) (1 2 4 1 4) (1 1 1 5 5) (1 2 6 6) (1 3 6 6) (1 4 6 6) (20))) (quote ((20) (1 7 2 1) (1 7 3 5) (1 4 4) (1 7 5 3) (1 7 6 2) (12 1) (20) (2 15) (1 14) (1 5 6) (1 5 5) (2 5 4) (3 5 1) (2 5 4) (1 5 5) (1 5 6) (1 14) (2 15) (20))) (quote #20(#20(on) #20(on off on on on on on on on off on on off off off off off off off on) #20(on off on on on on on on on off on on on off off on) #20(on off off off off off off off off off on on on on off off on) #20(on off on on on on on on on off on on on on on off off on) #20(on off on on on on on on on off on on on on on on off off on) #20(on on on on on on on on on on on on off off off off off off off on) #20(on) #20(on on off off off on) #20(on off off off off off on) #20(on off off off off off off on on on on on off off on) #20(on off off off off off off off on on on on on off off on) #20(on on off off off off off off off on on on on on off off on) #20(on on on off off off off off off off on on on on on off off off off on) #20(on on off off off off off off off on on on on on off off on) #20(on off off off off off off off on on on on on off off on) #20(on off off off off off off on on on on on off off on) #20(on off off off off off on) #20(on on off off off on) #20(on)))) (make-problem "19990306-RMA (8)" (quote ((1) (8) (6 1 2) (5 2 2) (5 2 2) (5 3 3) (5 4 3) (2 1 1 5 1 3) (2 1 2 5) (1 1 1) (1) (1) (1) (1) (1) (1) (1) (1) (1 1) (3))) (quote ((1) (3) (3) (5) (5) (5) (4 1 2) (3 1 1) (2 2 1) (2 3 6) (1 10) (8) (1 3) (2 1) (2 1) (3 1) (6) (4) (3) (2))) (quote #20(#20(off off off off off off off on off) #20(off off off off off on on on off) #20(off off off off on on on off) #20(off off off on on on on on off) #20(off off on on on on on off) #20(off off on on on on on off) #20(off on on on on off off on off off off off off off off off off off on) #20(off on on on off off off off on off off off off off off off off off off on) #20(off on on off off off off on on off off off off off off off off off off on) #20(off on on off off on on on off off off off off on on on on on on off) #20(off on off on on on on on on on on on on off) #20(on on on on on on on on off) #20(off on off off off off on on on off) #20(off on on off off off off off on off) #20(off off on on off off off on off) #20(off off off on on on off off on off) #20(off off off off on on on on on on off) #20(off off off off off on on on on off) #20(off off off off off off on on on off) #20(off off off off off off off off on on off)))) (make-problem "19990412-RAB (9)" (quote (() (9) (1 1 1 1 3) (9 2) (1 3 1) (2 1 1 1 3) (2 1 1 1 2) (1 1 3) (9 3) (1 1 1 4 9) (12 1 1 1 1) (1 12) (3 1 1) (2 1 1 1 1 2) (2 1 1 2 1 2) (2 1 1) (14) (2 1 1 1 1 1 1) (12) ())) (quote ((3 3) (1 1 2 1 1) (3 2 3) (1 1 1 1) (10) (1 1 1 1 4) (3 2 10) (1 1 3 1 2) (11 2 1 1) (1 1 3 3) (4 2 7 1) (1 7 3) (6 1 2 1 1) (3 1 3) (1 1 1 1) (10) (1 1 1 1) (3 2 3) (1 1 2 1 1) (3 3))) (quote #20(#20(off on on on off off off off on on on off) #20(off on off on off on on off on off on off) #20(off on on on off on on off on on on off) #20(off on off on off off off off on off on off) #20(off on on on on on on on on on on off) #20(off on off on off off off off on off on off on on on on off) #20(off on on on off on on off on on on on on on on on on on off) #20(off on off on off off off off on on on off on off off off on on off) #20(off on on on on on on on on on on on off on on off on off on off) #20(off off on off on off off off off on on on off off off off on on on off) #20(off off on on on on off on on off on on on on on on on off on off) #20(off off off on off on on on on on on on off off off off on on on off) #20(off off off off on on on on on on off on off on on off on off on off) #20(off off off off off off off off off on on on off off on off on on on off) #20(off off off off off off off off off on off on off off off off on off on off) #20(off off off off off off off off off on on on on on on on on on on off) #20(off off off off off off off off off on off on off off off off on off on off) #20(off off off off off off off off off on on on off on on off on on on off) #20(off off off off off off off off off on off on off on on off on off on off) #20(off off off off off off off off off on on on off off off off on on on off)))) (make-problem "19990806-ELS (10)" (quote (() (1 1) (2 2) (3 3) (4 4) (4 4) (4 4) (4 4) (4 4) (3 3) (5) (3) (5) (11) (2 1 1 2) (2 1 1 2) (1 2 2 1) (1 2 2 1) (4 4) ())) (quote (() (4) (4 4) (4 2 1) (4 2 1) (4 1 2) (4 1 2) (4 5) (6) (4) (6) (4 5) (4 1 2) (4 1 2) (4 2 1) (4 2 1) (4 4) (4) () ())) (quote #20(#20(off) #20(off on on on on off) #20(off off on on on on off off off off off off off off off on on on on off) #20(off off off on on on on off off off off off off off on on off off on off) #20(off off off off on on on on off off off off off on on off off off on off) #20(off off off off off on on on on off off off off on off off off on on off) #20(off off off off off off on on on on off off off on off off on on off) #20(off off off off off off off on on on on off on on on on on off) #20(off off off off off off off off on on on on on on off) #20(off off off off off off off off off off on on on on off) #20(off off off off off off off off on on on on on on off) #20(off off off off off off off on on on on off on on on on on off) #20(off off off off off off on on on on off off off on off off on on off) #20(off off off off off on on on on off off off off on off off off on on off) #20(off off off off on on on on off off off off off on on off off off on off) #20(off off off on on on on off off off off off off off on on off off on off) #20(off off on on on on off off off off off off off off off on on on on off) #20(off on on on on off) #20(off) #20(off)))) (make-problem "19990929-LSA (11)" (quote ((4 3) (3 5 2) (2 9 1) (1 11) (1 13) (1 2 1) (8 5) (9 5) (3 3 1 1) (4 4 2 2) (9 5) (9 5) (5 2 4) (6 5) (13) (4 4) (1 4 4 1) (2 8 1) (3 5 3) (5 7))) (quote ((5) (3) (2) (1 5) (11 4) (2 10 3) (3 2 8 2) (3 2 8 1) (4 2 9 1) (4 6 2 3) (12 1 2) (12 1 2) (4 2 3) (3 14) (3 2 9 1) (2 2 7 2) (4 7 2) (1 6 4) (2 1) (3 1))) (quote #20(#20(on on on on on off) #20(on on on off) #20(on on off) #20(on off off off off off off on on on on on off) #20(off off off off on on on on on on on on on on on off on) #20(off off off on on off on on on on on on on on on on off on) #20(off off on on on off on on off on on on on on on on on off on) #20(off off on on on off on on off off on on on on on on on on off on) #20(off on on on on off on on off on on on on on on on on on off on) #20(off on on on on off on on on on on on off on on off on on on off) #20(off on on on on on on on on on on on on off on off off on on off) #20(off on on on on on on on on on on on on off on off off on on off) #20(off on on on on off off off off off off off off on on off on on on off) #20(off off on on on off on) #20(off off on on on off on on off on on on on on on on on on off on) #20(off off off on on off on on off off on on on on on on on off on) #20(off off off off on on on on off on on on on on on on off off on) #20(on off off off off off on on on on on on off off off off on) #20(on on off off off off off off off off off off off off off off off off off on) #20(on on on off off off off off off off off off off off off off off off off on)))) (make-problem "19991002aTPV (12)" (quote (() () (6) (2 2 3) (1 1 1 3 1) (1 2 1) (2 3 1) (3 4 1) (3 3 1) (4 3 4 1) (5 9) (6 7) (7 4) (6 3) (7 4) (7 3) (6 3) (6) () ())) (quote (() () (6) (10) (1 10) (1 8) (2 7) (1 7) (1 1 6) (3 2 4) (2 2 3) (1 1 1 2 1) (10 2) (9 3) (1 11) (1 7) (2 5) (6) () ())) (quote #20(#20(off) #20(off) #20(off off off off off off off on on on on on on off) #20(off off off off off on on on on on on on on on on off) #20(off off off off on off on on on on on on on on on on off) #20(off off off on off off off off off on on on on on on on on off) #20(off off off on on off off off off off on on on on on on on off) #20(off off on off off off off off off off off on on on on on on on off) #20(off off on off off off off off off on off off on on on on on on off) #20(off off on on on off off off off on on off off off on on on on off) #20(off off on on off off off off off on on off off off off on on on off) #20(off off on off on off off on off off on on off off off off off on off) #20(off off on on on on on on on on on on off off off off on on off) #20(off off off on on on on on on on on on off off on on on off) #20(off off off on off off on on on on on on on on on on on off) #20(off off off off on off off off off on on on on on on on off) #20(off off off off off on on off off off on on on on on off) #20(off off off off off off off on on on on on on off) #20(off) #20(off)))) (make-problem "19991119bKHO (13)" (quote ((4 4) (3 2 1 1 1 1 1 3) (2 2 1 1 1 1 2) (2 1 1 1 1 1 1 2 2) (1 1 1 1 1 1 1 1 1 2) (1 1 1 1 1 2 1 2) (1 1 1 1 1 1 1 2 2) (2 13 3) (3 4) (3 4) (3 4) (3 4) (3 4) (4 5) (4 5) (5 6) (6 7) (8 9) (9 10) (20))) (quote ((20) (4 13) (2 1 1 12) (1 2 1 1 7) (2 1 2 5) (1 1 1 4) (1 1 2 3) (1 1 1 1 3) (1 2 2) (1 1 1 1 1) (1 1 2 2) (1 1 1 1 3) (1 2 3) (1 1 1 1 4) (1 2 1 5) (1 1 2 7) (1 5 12) (2 13) (20) (20))) (quote #20(#20(on) #20(on on on on off off off on) #20(on on off off on off on off on) #20(on off on on off on off on off off off off off on) #20(off on on off on off on on off off off off off off off on) #20(off on off on off off off on off off off off off off off off on) #20(off off on off on off on on off off off off off off off off off on) #20(off on off on off on off on off off off off off off off off off on) #20(off off off off on off on on off off off off off off off off off off on) #20(off on off on off on off on off off off off off off off off off off off on) #20(off off on off on off on on off off off off off off off off off off on) #20(off on off on off on off on off off off off off off off off off on) #20(off off off off on off on on off off off off off off off off off on) #20(off on off on off on off on off off off off off off off off on) #20(off off on off on on off on off off off off off off off on) #20(off on off on off off on on off off off off off on) #20(on off on on on on on off on) #20(on on off off off off off on) #20(on) #20(on)))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/solution-sets/k20x25 b/collects/games/paint-by-numbers/solution-sets/k20x25
new file mode 100644
index 0000000000..581559cec4
--- /dev/null
+++ b/collects/games/paint-by-numbers/solution-sets/k20x25
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 20x25") (define problems (list (make-problem "19980620-KKA (1)" (quote (() (1) (3) () () () () (1) (2) (1) (2) (2) (2 1 1) (2 3 2) (1 2 4 1 1) (1 2 1 1 2 1) (1 1 2 2 1 1 2) (1 4 1 4 4) (20) () (11 1 3 1) (1 1 1 1 1 1 1 1) (1 3 1 2 1 3 1) (1 1 1 1 1 1 1) (1 3 1 1 1 1 3 1))) (quote ((1 1) (5 5) (1 1) (5 5) (1 2 2 1 1 1) (2 2 1 1 1) (6 1) (1 1 1 1 5) (2 2 1 1 1) (1 4 2 3 5) (4 2 1 1 1) (1 2 1 2) (3) (3 2 5) (2 4) (1 3 1) (5 1 1 1) (3 1 3) (2) (2 3 1))) (quote #20(#25(off off off off off off off off off off off off off off off off off off on off on off) #25(off off off off off off off off off off off off off off on on on on on off on) #25(off off off off off off off off off off off off off off off off off off on off on off) #25(off off off off off off off off off off off off off off on on on on on off on) #25(off off off off off off off off off off off off on off on on off on on off on off on off on) #25(off off off off off off off off off off off off on on off off off on on off on off on off on) #25(off off off off off off off off off off off off off on on on on on on off on off) #25(off off on off off off off off off off off off off off on off on off on off on) #25(off on on off off off off on on off off off off off on off off off on off on off) #25(off off on off off off off off on on on on off on on off on on on off on) #25(off off off off off off off off off off on on on on off on on off on off on off on off) #25(off off off off off off off off off off off off off on off off off on on off off on off on) #25(off off off off off off off off off off off off off off off off on on on off) #25(off off off off off off off off off off off off off on on on off on on off on) #25(off off off off off off off off off off off off on on off on on on on off) #25(off off off off off off off off off off off off off off off off off off on off on on on off on) #25(off off off off off off off off off off off off off off on on on on on off on off on off on) #25(off off off off off off off off off off off off off off off off on on on off on off on) #25(off off off off off off off off off off off off off off off off off on on off) #25(off off off off off off off off off off off off off off off off off on on off on on on off on)))) (make-problem "19991113cBAR (2)" (quote ((3 1 2 1) (2 3 2 3 2) (17 1) (19) (19) (12 7) (8 2 1 5) (4 1 5) (3 4) (6 7) (2 3 3 4) (3 2 2 4) (4 5) (4 6) (5 3 6) (4 5 6) (5 1 6) (4 5 5) (4 3 3 3) (2 3) (5 6) (8 7) (17) (13 1) (1 2 3 3))) (quote ((1 5 4 3 1) (21) (23) (7 1 7 5) (5 1 3 4) (7 2 1 4) (8 2 1 4) (7 2 1 2 3) (4 2 1 4) (7 4 3) (6 2 1 3) (4 2 1 2 3) (5 2 1 4) (7 2 1 5) (5 1 4 5) (8 7 3) (24) (22) (18) (1 4 2 6))) (quote #20(#25(off off off on off on on on on on off on on on on off on on on off on off) #25(off off on on on on on on on on on on on on on on on on on on on on on off) #25(off on on on on on on on on on on on on on on on on on on on on on on on off) #25(off on on on on on on on off on off off on on on on on on on off on) #25(off off on on on on on off off on off off off off on on on off off off on on on on off) #25(on on on on on on on off off on on off off off off off off off on off off on) #25(on on on on on on on on off off on on off off off off off off on off off on) #25(on on on on on on on off off off on on off off off on off on on off off on on on off) #25(off off on on on on off off off off off off off off on on off on off off off on) #25(on on on on on on on off off off off off off off on on on on off off off off on) #25(off on on on on on on off off off off off off off on on off on off off off off on) #25(off off on on on on off off off off on on off off off on off on on off off on on on off) #25(on on on on on off off off off off on on off off off off off off on off off on) #25(on on on on on on on off off on on off off off off off off off on off on) #25(off on on on on on off off off on off off off on on on on off off off on) #25(off off on on on on on on on on off on on on on on on on off off on on on off) #25(on on on on on on on on on on on on on on on on on on on on on on on on off) #25(off on on on on on on on on on on on on on on on on on on on on on on off) #25(off off off on on on on on on on on on on on on on on on on on on off) #25(off off on off on on on on off on on off on on on on on on off)))) (make-problem "19991113gBAR (3)" (quote (() () (4 4) (8 6) (14 3) (3 7 2) (3 5 2) (6 2) (6 2) (6 3) (6 4) (8 4) (14) (14) (10 3) (14) (16) (18) (3 14) (3 14) (4 13) (4 11) (3 9) (12) (10))) (quote ((2 4) (3 6) (3 9) (4 5 4) (4 8 4) (4 10 2) (2 16 2) (3 18) (21) (21) (21) (21) (3 3 10) (3 13) (3 12) (2 12) (2 4 6) (3 4 4) (9) (7))) (quote #20(#25(off off on on off off off off off off off off off off off off off on on on on off) #25(off off on on on off off off off off off off off off off off on on on on on on off) #25(off off on on on off off off off off off off off off on on on on on on on on on off) #25(off off on on on on off off off off off off off on on on on on off off on on on on off) #25(off off off on on on on off off off off off on on on on on on on on off on) #25(off off off on on on on off off off off on on on on on on on on on on off off on) #25(off off off on on off on on on on on on on on on on on on on on on on off on) #25(off off off on on on off on) #25(off off off off on) #25(off off off off on) #25(off off off off on) #25(off off off off on) #25(off off off off on on on off off off off on on on off on) #25(off off off on on on off off off off off off on) #25(off off on on on off off off off off off off on on on on on on on on on on on on off) #25(off off on on off off off off off off off on on on on on on on on on on on on off) #25(off off on on off off off off off off on on on on off off on on on on on on off) #25(off off on on on off off off off on on on on off off off off on on on on off) #25(off off off on on on on on on on on on off) #25(off off off off on on on on on on on off)))) (make-problem "19991115cBAR (4)" (quote ((8 9) (8 8) (4 2 5 1) (4 2 3 1) (4 2 2 1) (1 2 1 1 2) (1 3 1 3) (1 1 3) (1 1 3 2 1) (2 5 1 1) (4 2 4 1) (2 2 4 2 2) (1 1 5 3) (4 2 5) (2 4 4) (1 2 5 2) (4 3 1) (2 1 1 1) (1 2 2 1) (1 2 1 2 1) (2 1 1 4) (5 1 4) (4 2 4) (4 4 5) (5 7 5))) (quote ((13 10) (5 3 2 5) (5 1 1 4) (6 1 1 4) (2 2 1 1 2 1) (2 1 1 1 1) (3 2 1 1) (4 1 5 1 1) (2 3 3 2 2) (2 2 3 2 2) (9 3) (1 3 1 3 7) (3 7 2 1) (7 5) (5) (4 2 1 2 2) (3 1 2 6) (2 2 3 5) (2 3 5 5) (18 6))) (quote #20(#25(on on on on on on on on on on on on on off off on) #25(on on on on on off off off off on on on off off off off on on off off on) #25(on on on on on off off off off off on off off off off off on off off off off on) #25(on on on on on on off off off off on off off off off off on off off off off on) #25(on on off off off on on off off off off on off off off on off off off off on on off off on) #25(on on off off off off on off off off off on off off off on off off off on off) #25(on on on off off off on on off off off off off off off off off off off on off off off off on) #25(on on on on off off off off on off on on on on on off off off on off off off off off on) #25(off off off on on off off off off on on on off on on on off on on off off off off on) #25(off off off off on on off off on on off on on on off on on off off off off off off on) #25(off off off off off off off off on on on on on on on on on off off off off off on) #25(on off off off off off off off on on on off on off on on on off on) #25(on on on off off off off off off on on on on on on on off on on off off off off off on) #25(on on on on on on on off off off on on on on on off) #25(on on on on on off) #25(on on on on off off off off on on off off off on off off off off on on off off off on) #25(on on on off off off off off on off off off off on on off off off off on) #25(on on off off off off on on off off off off on on on off off off off off on) #25(on on off off off on on on off off off on on on on on off off off off on) #25(on on on on on on on on on on on on on on on on on on off on)))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/solution-sets/k20x30 b/collects/games/paint-by-numbers/solution-sets/k20x30
new file mode 100644
index 0000000000..48aa6adf55
--- /dev/null
+++ b/collects/games/paint-by-numbers/solution-sets/k20x30
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 20x30") (define problems (list (make-problem "19991007aKHO (1)" (quote ((1 1 1 1 1) (1 5 1) (8 2) (8) (8) (2 2) (1 1) (2 2) (1 6 1) (2 8 2) (1 1) (1 2 2 1) (1 1 1 1 1 1) (1 4 4 1) (3 4 4 3) (1 1 1 1 1 1 1 1) (1 1 2 2 2 1 1) (2 1 4 1 2) (3 4 3) (1 4 1) (1 2 1) (2 2) (14) (2 2) (1 2 4 2 1) (1 6 1) (1 1) (14) (5 5) (7 7))) (quote ((3) (1 2 1) (1 1 2) (21) (1 3 3 3) (2 3 4 1 1 3) (4 1 1 2 1 1 1 3) (1 3 2 1 2 1 1 1 1 1) (4 2 4 3 1 2 1) (5 2 5 1 2 1) (4 2 5 1 2 1) (5 2 4 3 1 2 1) (4 2 1 2 1 1 1 1 1) (1 3 1 1 2 1 1 1 3) (1 3 4 1 1 3) (2 3 3 3) (21) (1 1 2) (1 2 1) (3))) (quote #20(#30(off off off off off off off off off off off off off off off on on on off) #30(off off off off off off off off off off off off off off on off off on on off off off off off off off off off off on) #30(off off off off off off off off off off off off off off on off off off on off off off off off off off off off on) #30(off off off off off off off off off on) #30(on off off off off off off on on on off off off off off off off off off off off on on on off off off on) #30(off on on off off on on on off off off off on on on on off off off off off off on off on off off on) #30(off off on on on on off off off on off on off on on off on off off off off off on off on off off on) #30(on off on on on off off off on on off on off on on off on off off off off off on off off on off on off on) #30(off on on on on off off off on on off off on on on on off on on on off off on off on on off on off) #30(on on on on on off off off on on off off off off off off on on on on on off on off on on off on off) #30(off on on on on off off off on on off off off off off off on on on on on off on off on on off on off) #30(on on on on on off off off on on off off on on on on off on on on off off on off on on off on off) #30(off on on on on off off off on on off on off on on off on off off off off off on off off on off on off on) #30(on off off on on on off off off on off on off on on off on off off off off off on off on off off on) #30(off off on off off on on on off off off off on on on on off off off off off off on off on off off on) #30(off on on off off off off on on on off off off off off off off off off off off on on on off off off on) #30(off off off off off off off off off on) #30(off off off off off off off off off off off off off off on off off off on off off off off off off off off off on) #30(off off off off off off off off off off off off off off on off off on on off off off off off off off off off off on) #30(off off off off off off off off off off off off off off off on on on off)))) (make-problem "19991007bKHO (2)" (quote ((20) (1 1) (1 16 1) (1 16 1) (1 2 2 1) (1 2 2 1) (1 5 2 1) (1 2 6 1) (1 2 1 1 2 1) (1 2 3 2 1) (1 2 1 1 2 1) (1 3 1 1 1 1 1 2 1) (1 2 1 1 1 1 1 3 1) (1 16 1) (1 16 1) (1 1) (1 6 1) (1 2 1) (1 2 4 1) (1 2 2 4 1) (1 6 4 2 1) (1 6 4 1) (1 2 2 1) (1 2 1) (1 1 1 1) (1 1 1 1 1) (1 2 2 1 1 1) (1 1 1 1 1) (1 1 1 1) (20))) (quote ((30) (1 1) (1 13 2 1) (1 13 2 1) (1 2 1 1 2 6 1) (1 2 1 3 6 1) (1 2 1 1 1 2 2 1 1) (1 2 1 3 1 2 1 1) (1 2 4 2 1 1) (1 2 1 3 1 1 1) (1 2 2 2 1 2 1 1) (1 2 3 1 4 1) (1 2 1 1 2 1 4 1) (1 2 1 3 2 1 1 1) (1 2 1 1 2 2 1 1 2) (1 2 1 3 4 1 1 1) (1 13 4 1 1 2) (1 13 2 1 1 1) (1 1) (30))) (quote #20(#30(on) #30(on off off off off off off off off off off off off off off off off off off off off off off off off off off off off on) #30(on off on on on on on on on on on on on on on off off off off off on on off off off off off off off on) #30(on off on on on on on on on on on on on on on off off off off off on on off off off off off off off on) #30(on off on on off off on off off off off on off on on off off off on on on on on on off off off off off on) #30(on off on on off off on off off off off off on on on off off off on on on on on on off off off off off on) #30(on off on on off off on off on off off on off on on off off off off off on on off off off off on off off on) #30(on off on on off off off off off on off off on on on off on off off off on on off off off off on off off on) #30(on off on on off off off off on on on on off on on off on off off off off off off off off off off off off on) #30(on off on on off off off off off on off off on on on off on off off off off off off off off off on off off on) #30(on off on on off off off off off off on on off on on off on off off off on on off off off off on off off on) #30(on off on on off off off off off off off off on on on off on off off on on on on off off off off off off on) #30(on off on on off off off on off off off on off on on off on off off on on on on off off off off off off on) #30(on off on on off off off on off off off off on on on off off off off off on on off off off on off on off on) #30(on off on on off off off on off off off on off on on off off off on on off off off off on off on off on) #30(on off on on off off off on off off off off on on on off off on on on on off off off off on off on off on) #30(on off on on on on on on on on on on on on on off off on on on on off off off on off on off on) #30(on off on on on on on on on on on on on on on off off off on on off off off off off on off on off on) #30(on off off off off off off off off off off off off off off off off off off off off off off off off off off off off on) #30(on)))) (make-problem "19991113bBAR (3)" (quote ((6) (8) (10) (3 8) (1 2 1) (12) (1 1 1 3) (1 6 1) (1 2) (1 4 1) (3 2 4) (5 6) (7 8) (19) (4 10 3) (4 11 3) (17 1) (2 14 1) (1 2 1 1 1 1) (3 15) (14) (14) (13) (11) (4 5) (1 1 2 1) (4 4) (5 5) (6 6) (6 6))) (quote ((5) (5 1) (5 1) (3 6 1) (1 1 5 6) (4 7 3 4 2) (2 3 8 5 3) (4 1 1 7 11) (4 3 1 6 6 4) (4 1 1 2 5 6 4) (4 1 1 2 17) (4 3 1 5 5) (4 1 1 14) (3 2 7 11) (5 10 6 4) (3 8 6 4) (4 2 11) (6 6 3) (5 1 2) (7))) (quote #20(#30(off off off off off off off off off off off off off off off on on on on on off) #30(off off off off off off off off off off off off off on on on on on off on off) #30(off off off off off off off off off off off off on on on on on off off on off) #30(off off off on on on off off off off off on on on on on on off on off) #30(off off off on off on off off off off on on on on on off on on on on on on off) #30(off off on on on on off on on on on on on on off on on on off on on on on off off off off off on) #30(off on on off on on on off off off on on on on on on on on off on on on on on off off off on) #30(on on on on off on off on off off off on on on on on on on off on) #30(on on on on off on on on off on off off on on on on on on off on on on on on on off on) #30(on on on on off on off on off on on off off on on on on on off on on on on on on off on) #30(on on on on off on off on off on on off off on) #30(on on on on off on on on off on off off off on on on on on off on on on on on off) #30(on on on on off on off on off off off off on on on on on on on on on on on on on on off) #30(off on on on off on on off off off off on on on on on on on off on) #30(off off on on on on on off on on on on on on on on on on off on on on on on on off on) #30(off off off off off off on on on off on on on on on on on on off on on on on on on off on) #30(off off off off off off off off off off on on on on off off on on off on) #30(off off off off off off off off off off on on on on on on off on on on on on on off off off off on) #30(off off off off off off off off off off off on on on on on off off off on off off off off off off off off on) #30(off off off off off off off off off off off off on on on on on on on off)))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/solution-sets/k25x15 b/collects/games/paint-by-numbers/solution-sets/k25x15
new file mode 100644
index 0000000000..413b7f9ddf
--- /dev/null
+++ b/collects/games/paint-by-numbers/solution-sets/k25x15
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 25x15") (define problems (list (make-problem "19990709-DAH (1)" (quote ((25) (1 1) (1 3 1) (1 3 1 3 1) (1 3 1 1 1 1) (1 1 1 1 1 1) (1 1 1 1 1 1) (1 1 1 3 1 1) (1 1 3 4 3 1) (1 3 4 4 4 1) (1 4 4 2 4 1) (1 4 2 2 1) (1 2 1) (1 1) (25))) (quote ((15) (1 1) (1 2 1) (1 4 1) (1 4 1) (1 8 1) (1 1 1) (1 1 2 1) (1 1 4 1) (1 1 4 1) (1 8 1) (1 1) (1 1) (1 2 1) (1 4 1) (1 4 1) (1 8 1) (1 1 1) (1 1 2 1) (1 1 4 1) (1 1 4 1) (1 8 1) (1 1) (1 1) (15))) (quote #25(#15(on) #15(on off off off off off off off off off off off off off on) #15(on off off off off off off off off off on on off off on) #15(on off off off off off off off off on on on on off on) #15(on off off off off off off off off on on on on off on) #15(on off off off on on on on on on on on off off on) #15(on off off off on off off off off off off off off off on) #15(on off off off on off off off off on on off off off on) #15(on off off on off off off off on on on on off off on) #15(on off off on off off off off on on on on off off on) #15(on off off on on on on on on on on off off off on) #15(on off off off off off off off off off off off off off on) #15(on off off off off off off off off off off off off off on) #15(on off off off off off off off on on off off off off on) #15(on off off off off off off on on on on off off off on) #15(on off off off off off off on on on on off off off on) #15(on off on on on on on on on on off off off off on) #15(on off on off off off off off off off off off off off on) #15(on off on off off off off off off on on off off off on) #15(on off off on off off off off on on on on off off on) #15(on off off on off off off off on on on on off off on) #15(on off off on on on on on on on on off off off on) #15(on off off off off off off off off off off off off off on) #15(on off off off off off off off off off off off off off on) #15(on)))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/solution-sets/k25x20 b/collects/games/paint-by-numbers/solution-sets/k25x20
new file mode 100644
index 0000000000..9a6811c1ac
--- /dev/null
+++ b/collects/games/paint-by-numbers/solution-sets/k25x20
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 25x20") (define problems (list (make-problem "19980410-GOS (1)" (quote (() (9) (3 1 4 3) (4 2 1 3 4) (2 1 11 4) (4 2 3 2 1 1) (1 1 2 1 3 1 2 1 1) (2 1 2 3 2 5) (5 5 5 1 1) (3 1 4 3 2 1 1 1) (5 4 3 4 5) (1 4 1 4 2) (1 1 2 1 1 1 2 2 1) (2 1 2 3 3 2 4) (3 3 1 1 1 3 3) (3 1 1 1 3) (2 3 2) (2 2) (7) ())) (quote ((7) (6 2) (2 3 1) (3 1 5) (1 7) (3 4) (2 11) (1 7 3) (1 2 3 1 3) (4 1 3 1 2) (1 1 1 3 1) (1 4 2 1 1 1) (7 4 3 1) (2 4 2 1 1 1) (4 1 3 1) (4 1 3 1 2) (1 2 3 1 3) (1 5 1 3) (2 11) (3 4) (9) (2 1 5) (1 1 1 3) (3 2 2) (7))) (quote #25(#20(off off off off off off off on on on on on on on off) #20(off off off off off on on on on on on off off on on off) #20(off off off off on on off off on on on off off off on off) #20(off off off on on on off off on off on on on on on off) #20(off off off on off on on on on on on on off) #20(off off on on on off off off off off off on on on on off) #20(off off on on off on on on on on on on on on on on off) #20(off off on off on on on on on on on off off off on on on off) #20(off on off on on off off off on on on off on off off on on on off) #20(off on on on on off on off on on on off off on off off off on on off) #20(off on off off on off off off on off off off off on on on off off on off) #20(off on off off on on on on off on on off off on off off on off on off) #20(off on on on on on on on off on on on on off on on on off on off) #20(off on on off on on on on off on on off off on off off on off on off) #20(off on on on on off off off on off off off off on on on off off on off) #20(off on on on on off on off on on on off off on off off off on on off) #20(off on off on on off off off on on on off on off off on on on off) #20(off off on off on on on on on off on off off off on on on off) #20(off off on on off on on on on on on on on on on on off) #20(off off on on on off off off off off off on on on on off) #20(off off off on on on on on on on on on off) #20(off off off on on off off on off off on on on on on off) #20(off off off off on off off on off off on off on on on off) #20(off off off off off on on on off off on on off on on off) #20(off off off off off off off on on on on on on on off)))) (make-problem "19981116-JAM (2)" (quote ((10) (17) (4 9 3) (4 2 7 2 3) (3 4 5 3 4) (3 4 5 3 4) (4 4 5 3 4) (4 2 5 2 5) (5 6 6) (6 4 2 7) (12 11) (11 10) (10 9) (5 6 5 5) (5 13 4) (4 15 3) (1 1 13 1 1) (5 11 5) (5 5) (8 7))) (quote ((10) (15) (14 2) (14 3) (3 7 4) (2 3 4 1 3) (1 4 7 2) (1 5 8 1) (3 4 9 1) (4 10 1) (12 5 1) (11 5) (9 4) (9 4 1) (11 5 1) (4 3 5 1) (3 3 8 1) (2 5 8 1) (1 5 8 2) (2 5 1 3) (14 3) (14 2) (13 2) (14) (7))) (quote #25(#20(off off off off off off on on on on on on on on on on off) #20(off off off on on on on on on on on on on on on on on on off) #20(off off on on on on on on on on on on on on on on off on on off) #20(off off on on on on on on on on on on on on on on off on) #20(off on on on off off off off on on on on on on on off on) #20(off on on off on on on off off on on on on off off on off on) #20(off on off on on on on off off off on on on on on on on off on) #20(off on off on on on on on off off on on on on on on on on off on) #20(on on on off on on on on off on on on on on on on on on off on) #20(on on on on off off off off on on on on on on on on on on off on) #20(on on on on on on on on on on on on off on on on on on off on) #20(on on on on on on on on on on on off off on on on on on off) #20(on on on on on on on on on off off off off off on on on on off) #20(on on on on on on on on on off off off off off on on on on off on) #20(on on on on on on on on on on on off off on on on on on off on) #20(on on on on off off off off off on on on off on on on on on off on) #20(on on on off on on on off off off on on on on on on on on off on) #20(on on off on on on on on off off on on on on on on on on off on) #20(off on off on on on on on off on on on on on on on on off on) #20(off on on off off off off off on on on on on off off on off on) #20(off on on on on on on on on on on on on on on off on on on off) #20(off off on on on on on on on on on on on on on on off on on off) #20(off off off on on on on on on on on on on on on on off on on off) #20(off off off off on on on on on on on on on on on on on on off) #20(off off off off off off off on on on on on on on off)))) (make-problem "19981119-MSS (3)" (quote ((3 1 3 1 1 1 1 1) (1 1 1 1 1 2 1 1 1 1) (1 1 1 3 1 2 1 1) (1 1 1 1 1 1 1 1 2) () (3) (2 3) (2 2 3) (1 2 2 3) (1 2 2 3) (4 3 1 2) (1) (8 1) (16) (25) (24) (21) (16) (11) (4))) (quote ((1 1 4) (4 1 4) (1 1 4) (3 5) (4 5) (4 5) (1 4 5) (4 1 6) (1 4 5) (4 5) (3 1 5) (1 1 5 5) (3 5 6) (5 6) (4 1 6) (1 9) (1 5) (4 5) (6) (4 6) (6) (2 6) (1 1 5) (1 1 3) (1))) (quote #25(#20(on off off off off off off off off off on off on on on on off) #20(on on on on off off off off off off on off on on on on off) #20(on off off off off off off off off off on off on on on on off) #20(off off off off off off off off on on on off on on on on on off) #20(on on on on off off off off off off off off on on on on on off) #20(off off off off off off off on on on on off on on on on on off) #20(on off off off off off off on on on on off on on on on on off) #20(on on on on off off off off off off on off on on on on on on off) #20(on off off off off off on on on on off off off on on on on on off) #20(off off off off off off on on on on off off off on on on on on off) #20(off on on on off off off off off off on off off on on on on on off) #20(on off on off off on on on on on off off off on on on on on off) #20(off on on on off on on on on on off off off on on on on on on off) #20(off off off off off on on on on on off off off on on on on on on off) #20(on on on on off off off off off off on off off on on on on on on off) #20(off on off off off off off off off off on on on on on on on on on off) #20(off off on off off off off off off off off off off off on on on on on off) #20(on on on on off off off off off off off off off off on on on on on off) #20(off off off off off off off off off off off off off off on) #20(on on on on off off off off off off off off off off on) #20(off off off off off off off off off off off off off off on) #20(off on on off off off off off off off off off off off on) #20(on off off on off off off off off off off off off off on on on on on off) #20(off on off on off off off off off off off off off off on on on off) #20(off off off off off off off off off off off off off off on off)))) (make-problem "19990126bLLO (4)" (quote ((2 2 1) (3 7) (6 2 2 5) (6 4 4 2) (4 4 1) (3 2 2 1) (2 3 2) (1 2 3) (1 3 2) (3 2 3) (5 1 3) (7 2) (7 2) (7 2) (5 2) (25) (3) (20 3) (3) (18 2))) (quote ((1 1 1) (1 1 1 1) (2 1 1 1) (3 1 1 1) (3 3 1 1 1) (2 6 1 1) (2 7 1 1) (1 7 1 1) (1 7 1 1) (6 1 1) (3 3 1 1 1) (2 1 1 1) (2 1 1 1) (3 1 1 1) (3 1 1 1) (3 3 1 1 1) (1 1 4 1 1 1) (3 5 1 1 1) (7 1 1) (1 2 1 1) (8 1) (4 6 5) (2 13) (1 2 10) (4 1))) (quote #25(#20(off off off off off off off off off off off off off off off on off on off on) #20(off off on off off off off off off off off off off off off on off on off on) #20(off on on off off off off off off off off off off off off on off on off on) #20(off on on on off off off off off off off off off off off on off on off on) #20(off on on on off off off off off off off on on on off on off on off on) #20(off off on on off off off off off off on on on on on on off on off on) #20(off off on on off off off off off on on on on on on on off on off on) #20(off off off on off off off off off on on on on on on on off on off on) #20(off off off on off off off off off on on on on on on on off on off on) #20(off off off off off off off off off off on on on on on on off on off on) #20(off off off off off off on on on off off on on on off on off on off on) #20(off off off off off on on off off off off off off off off on off on off on) #20(off off off off on on off off off off off off off off off on off on off on) #20(off off off on on on off off off off off off off off off on off on off on) #20(off off on on on off off off off off off off off off off on off on off on) #20(off off on on on off off off on on on off off off off on off on off on) #20(off on off on off off on on on on off off off off off on off on off on) #20(on on on off on on on on on off off off off off off on off on off on) #20(on on on on on on on off off off off off off off off on off on off) #20(off on off on on off off off off off off off off off off on off on off) #20(on on on on on on on on off off off off off off off on off) #20(on on on on off on on on on on on off off off off on) #20(off on on off off off off on) #20(on off on on off off off off off on on on on on on on on on on off) #20(off off on on on on off off off off off off off off off on off)))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/solution-sets/k25x25 b/collects/games/paint-by-numbers/solution-sets/k25x25
new file mode 100644
index 0000000000..09deb9a02f
--- /dev/null
+++ b/collects/games/paint-by-numbers/solution-sets/k25x25
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 25x25") (define problems (list (make-problem "19980522-SDN (1)" (quote ((1 1) (1 1 1) (1 1 3) (3 3) (1 1 3) (1 1 5) (5) (7) (7) (9) (11) (15) (17) (19) (19) (19) (17) (15) (11) (7 1) (1 1 1) (3 1 1) (5 3) (9 1 1) (9 1 1))) (quote (() (5) (1 1) (5 3) (5) (7) (7) (9) (10 2) (13 2) (15 3) (18 4) (25) (18 4) (15 3) (13 2) (10 2) (9) (7) (7) (5) (3) (5) (1 1) (5))) (quote #25(#25(off) #25(off on on on on on off) #25(on off off on off) #25(off on on on on on off off off off off off off on on on off) #25(off off off off off off off off off off off off on on on on on off) #25(off off off off off off off off off off off on on on on on on on off) #25(off off off off off off off off off off off on on on on on on on off) #25(off off off off off off off off off off on on on on on on on on on off) #25(off off off off off off off off off on on on on on on on on on on off off off off on) #25(off off off off off off off on on on on on on on on on on on on on off off off on) #25(off off off off off on on on on on on on on on on on on on on on off off on) #25(off off on on on on on on on on on on on on on on on on on on off on) #25(on) #25(off off on on on on on on on on on on on on on on on on on on off on) #25(off off off off off on on on on on on on on on on on on on on on off off on) #25(off off off off off off off on on on on on on on on on on on on on off off off on) #25(off off off off off off off off off on on on on on on on on on on off off off off on) #25(off off off off off off off off off off on on on on on on on on on off) #25(off off off off off off off off off off off on on on on on on on off) #25(off off off off off off off off off off off on on on on on on on off) #25(off off off off off off off off off off off off on on on on on off) #25(off off off off off off off off off off off off off on on on off) #25(off off off off off off off off off off off off off off off off off off off off on) #25(off off off off off off off off off off off off off off off off off off off on off off on off) #25(off off off off off off off off off off off off off off off off off off off off on)))) (make-problem "19980909-YEN (2)" (quote ((10 10) (8 5 8) (5 9 5) (4 7 4 4) (3 7 4 3) (2 7 3 2) (2 8 4 2) (2 9 5 2) (1 16 1) (1 15 1) (14) (12) (11) (9) (7) (1 5 1) (1 4 1) (2 3 1 2) (2 3 3 2) (2 3 5 2) (3 2 3 3) (4 2 1 4) (5 5) (8 8) (10 10))) (quote ((10 10) (8 5 8) (5 9 5) (4 15 4) (3 17 3) (2 19 2) (2 13 1 2) (2 12 2) (1 12 1) (1 12 1) (4 7 1) (3 6 3) (2 4 5) (3 4 3) (4 5 1) (1 8 1) (1 8 1) (2 5 2) (2 2) (2 2) (3 3) (4 4) (5 5) (8 8) (10 10))) (quote #25(#25(on on on on on on on on on on off off off off off on) #25(on on on on on on on on off off on on on on on off off on) #25(on on on on on off off off on on on on on on on on on off off off on) #25(on on on on off on on on on on on on on on on on on on on on off on) #25(on on on off on on on on on on on on on on on on on on on on on off on) #25(on on off on on on on on on on on on on on on on on on on on on on off on) #25(on on off on on on on on on on on on on on on on off off off off off on off on) #25(on on off on on on on on on on on on on on on off off off off off off off off on) #25(on off on on on on on on on on on on on on off off off off off off off off off off on) #25(on off on on on on on on on on on on on on off off off off off off off off off off on) #25(off on on on on off on on on on on on on off off off off off off on off) #25(off on on on off off off on on on on on on off off off off off on on on off) #25(off on on off off off off off on on on on off off off off off on on on on on off) #25(off on on on off off off on on on on off off off off off off off on on on off) #25(off on on on on off on on on on on off off off off off off off off on off) #25(on off on on on on on on on on off off off off off off off off off off off off off off on) #25(on off on on on on on on on on off off off off off off off off off off off off off off on) #25(on on off off on on on on on off off off off off off off off off off off off off off on) #25(on on off off off off off off off off off off off off off off off off off off off off off on) #25(on on off off off off off off off off off off off off off off off off off off off off off on) #25(on on on off off off off off off off off off off off off off off off off off off off on) #25(on on on on off off off off off off off off off off off off off off off off off on) #25(on on on on on off off off off off off off off off off off off off off off on) #25(on on on on on on on on off off off off off off off off off on) #25(on on on on on on on on on on off off off off off on)))) (make-problem "19990924-VAL (3)" (quote (() () (1) (1) (1) (10) (12) (6 3 3) (3 2 1 1 1 2) (2 1 1 1 1 2 1) (1 3 3 4) (6 7) (7 2 4) (2 7 2 1) (2 10 1) (6 8) (5 7) (2 7 2) (1 7 1) (11) (4 4) (4 4) (2 6) (1 5) (5))) (quote (() () () () () (3 4) (3 7) (3 3 5) (3 8 4) (4 14) (5 11 1) (3 5 8) (4 3 7 3) (1 3 15) (5 14) (3 2 10) (2 9 4) (3 11) (3 3 3) (3 5) () () () () ())) (quote #25(#25(off) #25(off) #25(off) #25(off) #25(off) #25(off off off off off off off off on on on off on on on on off) #25(off off off off off off off on on on off on on on on on on on off) #25(off off off off off off on on on off on on on off off on on on on on off) #25(off off off off off on on on off on on on on on on on on off off on on on on off) #25(off off off off off on on on on off on on on on on on on on on on on on on on off) #25(off off off off off on on on on on off on on on on on on on on on on on off off on) #25(off off off off off on on on off off on on on on on off off on) #25(off off off on on on on off on on on off off on on on on on on on off off on) #25(off off on off off on on on off off on) #25(off off off off off on on on on on off on) #25(off off off off off on on on off off on on off off on on on on on on on on on on off) #25(off off off off off on on off on on on on on on on on on off off on on on on off) #25(off off off off off on on on off on on on on on on on on on on on off) #25(off off off off off off on on on off on on on off off on on on off) #25(off off off off off off off on on on off on on on on on off) #25(off) #25(off) #25(off) #25(off) #25(off)))) (make-problem "19991020aSHE (4)" (quote ((20 2) (3 14 2) (2 11 2) (1 9 3) (2 9 3) (3 9 4) (12 4) (8 5) (7 6) (6 7) (5 8) (5 9) (7 9) (7 6) (7 4) (3 2 3) (2 4 3) (3 3 3) (1 6) (2 6) (1 6) (2 1 6) (2 1 8) (1 11) (13))) (quote ((25) (3 14 1 2 1) (2 11 1 2) (1 9 3) (2 10 2) (3 6 3 3) (9 4 4) (8 2 3) (7 2 5) (7 9) (7 9) (7 7) (6 7) (5 5) (4 4) (3 3) (2 6) (2 6) (1 6) (1 7) (7) (9) (10) (13) (13))) (quote #25(#25(on) #25(on on on off on on on on on on on on on on on on on on off on off on on off on) #25(on on off off off on on on on on on on on on on on off on off off off off off on) #25(on off off off off off on on on on on on on on on off off off off off off off on) #25(on on off off off on on on on on on on on on on off off off off off off off off on) #25(on on on off on on on on on on off off on on on off off off off off off off on) #25(on on on on on on on on on off off off on on on on off off off off off on) #25(on on on on on on on on off off off off off off off on on off off off off off on) #25(on on on on on on on off off off off off off off off off on on off off on) #25(on on on on on on on off off off off off off off off off on) #25(on on on on on on on off off off off off off off off off on) #25(on on on on on on on off off off off off off off off off off off on) #25(on on on on on on off off off off off off off off off off off off on) #25(on on on on on off off off off off off off off off off off off on on on on on off) #25(on on on on off off off off off off off off off off off off on on on on off) #25(on on on off off off off off off off off off off off off on on on off) #25(on on off off off off off off off off off on on on on on on off) #25(on on off off off off off off off off on on on on on on off) #25(on off off off off off off off off on on on on on on off) #25(on off off off off off off off on on on on on on on off) #25(off off off off off off off on on on on on on on off) #25(off off off off off on on on on on on on on on off) #25(off off off on on on on on on on on on on off) #25(on on on on on on on on on on on on on off) #25(on on on on on on on on on on on on on off)))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/solution-sets/k25x30 b/collects/games/paint-by-numbers/solution-sets/k25x30
new file mode 100644
index 0000000000..cee99307a7
--- /dev/null
+++ b/collects/games/paint-by-numbers/solution-sets/k25x30
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 25x30") (define problems (list (make-problem "19980714-GAS (1)" (quote (() (3) (4) (4) (5) (4) (3) (4 2 4) (8 8) (20) (21) (20) (20) (20) (19) (19) (19) (19) (20) (21) (21) (22) (22) (20) (18) (16) (14) (3 3) () ())) (quote (() (8) (13) (15) (17) (18) (20) (21) (21) (21) (19) (19) (4 18) (5 18) (5 19) (5 19) (4 21) (2 21) (21) (20) (6 8) (4 6) (2 4) (2) ())) (quote #25(#30(off) #30(off off off off off off off off off off off off on on on on on on on on off) #30(off off off off off off off off off off on on on on on on on on on on on on on off) #30(off off off off off off off off off on on on on on on on on on on on on on on on off) #30(off off off off off off off off on on on on on on on on on on on on on on on on on off) #30(off off off off off off off off on on on on on on on on on on on on on on on on on on off) #30(off off off off off off off on on on on on on on on on on on on on on on on on on on on off) #30(off off off off off off off on on on on on on on on on on on on on on on on on on on on on off) #30(off off off off off off off on on on on on on on on on on on on on on on on on on on on on off) #30(off off off off off off off on on on on on on on on on on on on on on on on on on on on on off) #30(off off off off off off off off on on on on on on on on on on on on on on on on on on on off) #30(off off off off off off off off on on on on on on on on on on on on on on on on on on on off) #30(off off off off on on on on off on on on on on on on on on on on on on on on on on on off) #30(off off off on on on on on off on on on on on on on on on on on on on on on on on on off) #30(off off on on on on on off on on on on on on on on on on on on on on on on on on on off) #30(off on on on on on off off on on on on on on on on on on on on on on on on on on on off) #30(off on on on on off off on on on on on on on on on on on on on on on on on on on on on off) #30(off on on off off off off on on on on on on on on on on on on on on on on on on on on on off) #30(off off off off off off off on on on on on on on on on on on on on on on on on on on on on off) #30(off off off off off off off on on on on on on on on on on on on on on on on on on on on off) #30(off off off off off off off off on on on on on on off off off off on on on on on on on on off) #30(off off off off off off off off on on on on off off off off off off off on on on on on on off) #30(off off off off off off off off off on on off off off off off off off off off on on on on off) #30(off off off off off off off off off off off off off off off off off off off off off on on off) #30(off)))) (make-problem "19980716cGAS (2)" (quote (() (7) (3 3) (2 3 2) (2 3 3 2) (1 2 2 1) (1 2 2 1) (1 1 1 1) (1 1 1 1) (1 1 7 1 1) (1 2 2 1) (3 3) (2 2) (2 5 2) (1 4 4 1) (2 5 5 2) (1 2 7 2 1) (1 3 5 3 1) (1 6 6 1) (1 5 5 1) (1 1 2 2 1 1) (1 5 5 1) (1 6 6 1) (2 3 5 3 2) (1 2 7 2 1) (2 5 5 2) (2 4 4 2) (2 5 2) (3 3) (9))) (quote (() () (9) (3 3) (2 2) (9 5 2) (2 1 4 4 2) (2 6 5 5 1) (1 2 1 2 7 2 2) (2 2 1 3 5 3 1) (1 1 1 6 6 1) (1 2 1 5 5 1) (1 1 1 1 2 2 1 1) (1 2 1 5 5 1) (1 1 1 6 6 1) (2 2 1 3 5 3 1) (1 2 1 2 7 2 2) (2 6 5 5 1) (2 1 4 4 2) (9 5 2) (2 2) (3 3) (9) () ())) (quote #25(#30(off) #30(off) #30(off off off off off off off off off off off off off off off on on on on on on on on on off) #30(off off off off off off off off off off off off off on on on off off off off off off off on on on off) #30(off off off off off off off off off off off off on on off off off off off off off off off off off on on off) #30(off off off off on on on on on on on on on off off off off off on on on on on off off off on on off) #30(off off off on on off off off off off off on off off off off on on on on off on on on on off off on on off) #30(off off on on off off on on on on on on off off off on on on on on off on on on on on off off on off) #30(off off on off off on on off off off on off off off on on off on on on on on on on off on on off on) #30(off on on off on on off off off on off off off off on on on off on on on on on off on on on off off on) #30(off on off off on off off off off on off off off on on on on on on off off off on on on on on on off on) #30(off on off on on off off off off on off off off on on on on on off off off off off on on on on on off on) #30(off on off on off off off off off on off off off on off off on on off off off off off on on off off on off on) #30(off on off on on off off off off on off off off on on on on on off off off off off on on on on on off on) #30(off on off off on off off off off on off off off on on on on on on off off off on on on on on on off on) #30(off on on off on on off off off on off off off off on on on off on on on on on off on on on off off on) #30(off off on off off on on off off off on off off off on on off on on on on on on on off on on off on) #30(off off on on off off on on on on on on off off off on on on on on off on on on on on off off on off) #30(off off off on on off off off off off off on off off off off on on on on off on on on on off off on on off) #30(off off off off on on on on on on on on on off off off off off on on on on on off off off on on off) #30(off off off off off off off off off off off off on on off off off off off off off off off off off on on off) #30(off off off off off off off off off off off off off on on on off off off off off off off on on on off) #30(off off off off off off off off off off off off off off off on on on on on on on on on off) #30(off) #30(off)))) (make-problem "19980802-JON (3)" (quote (() (1) (3) (4) (4) (4) (3) (2) (7 6) (18) (20) (22) (21) (20) (19) (19) (19) (19) (19) (20) (21) (21) (21) (19) (19) (17) (15) (13) (4 4) ())) (quote (() (10) (13) (16) (18) (19) (20) (21) (21) (21) (21) (19) (19) (3 19) (25) (4 21) (4 21) (4 21) (2 20) (19) (5 7) (3 5) (1 2) () ())) (quote #25(#30(off) #30(off off off off off off off off off off off on on on on on on on on on on off) #30(off off off off off off off off off off on on on on on on on on on on on on on off) #30(off off off off off off off off off on on on on on on on on on on on on on on on on off) #30(off off off off off off off off on on on on on on on on on on on on on on on on on on off) #30(off off off off off off off off on on on on on on on on on on on on on on on on on on on off) #30(off off off off off off off off on on on on on on on on on on on on on on on on on on on on off) #30(off off off off off off off off on on on on on on on on on on on on on on on on on on on on on off) #30(off off off off off off off off on on on on on on on on on on on on on on on on on on on on on off) #30(off off off off off off off off on on on on on on on on on on on on on on on on on on on on on off) #30(off off off off off off off off on on on on on on on on on on on on on on on on on on on on on off) #30(off off off off off off off off off on on on on on on on on on on on on on on on on on on on off) #30(off off off off off off off off off on on on on on on on on on on on on on on on on on on on off) #30(off off off off off on on on off on on on on on on on on on on on on on on on on on on on off) #30(off off off off on on on on on on on on on on on on on on on on on on on on on on on on on off) #30(off off off on on on on off on on on on on on on on on on on on on on on on on on on on on off) #30(off off on on on on off off on on on on on on on on on on on on on on on on on on on on on off) #30(off on on on on off off off on on on on on on on on on on on on on on on on on on on on on off) #30(off off on on off off off off on on on on on on on on on on on on on on on on on on on on off) #30(off off off off off off off off on on on on on on on on on on on on on on on on on on on off) #30(off off off off off off off off off on on on on on off off off off off on on on on on on on off) #30(off off off off off off off off off off on on on off off off off off off off on on on on on off) #30(off off off off off off off off off off off on off off off off off off off off off on on off) #30(off) #30(off)))) (make-problem "19990723-KHO (4)" (quote ((8 8) (6 6) (4 5 4) (3 7 3) (2 9 2) (1 6 1 1) (1 5 3 1) (4 4) (4 4) (2 4) (3) (3) (3 3) (5 5) (13) (15) (3 9 1) (3 9 3) (3 2 1 4) (3 1 2 3 3) (3 5 5 1) (3 11 1) (3 9 3) (1 3 7 3 1) (1 3 3 1) (2 11 2) (3 8 3) (4 4) (6 6) (8 8))) (quote ((7 7) (5 5) (4 4) (3 5 3) (2 7 2) (2 9 2) (1 3 3 1) (1 4 3 3 1 3 1) (6 6 3 3) (7 6 4 2) (7 7 5 2) (5 9 5 2) (4 5 5 4 2) (3 5 6 1 3 2) (3 4 6 5 2) (2 3 6 5 2) (2 4 1 3 2) (1 3 5 3 1) (1 2 4 3 1) (2 1 3 2 2) (2 1 3 2) (3 3) (4 4) (5 5) (7 7))) (quote #25(#30(on on on on on on on off off off off off off off off off off off off off off off off on) #30(on on on on on off off off off off off off off off off off off off off off off off off off off on) #30(on on on on off off off off off off off off off off off off off off off off off off off off off off on) #30(on on on off off off off off off off off off off off off off off on on on on on off off off off off on) #30(on on off off off off off off off off off off off off off off on on on on on on on off off off off off on) #30(on on off off off off off off off off off off off off off on on on on on on on on on off off off off on) #30(on off off off off off off off off off off off off off on on on off off off off off on on on off off off off on) #30(on off off off off on on on on off off off off on on on off on on on off on off on on on off off off on) #30(off off off off on on on on on on off off off on on on on on on off on on on off on on on off) #30(off off off on on on on on on on off off on on on on on on off off on on on on off on on off) #30(off off on on on on on on on off off on on on on on on on off on on on on on off on on off) #30(off off on on on on on off off on on on on on on on on on off on on on on on off on on off) #30(off off on on on on off on on on on on off off on on on on on off on on on on off on on off) #30(off off on on on off on on on on on off on on on on on on off on off on on on off on on off) #30(off off on on on off on on on on off off on on on on on on off on on on on on off on on off) #30(off off off on on off on on on off off off on on on on on on off on on on on on off on on off) #30(off off off off on on off off off off off off off on on on on off on off on on on off on on off) #30(on off off off off off off off off off off off off on on on off on on on on on off on on on off off off on) #30(on off off off off off off off off off off off off off on on off on on on on off on on on off off off off on) #30(on on off off off off off off off off off off off off off on off on on on off off on on off off off off on) #30(on on off off off off off off off off off off off off off off on off off off on on on off off off off off on) #30(on on on off off off off off off off off off off off off off off off off off off off off off off off off on) #30(on on on on off off off off off off off off off off off off off off off off off off off off off off on) #30(on on on on on off off off off off off off off off off off off off off off off off off off off on) #30(on on on on on on on off off off off off off off off off off off off off off off off on)))) (make-problem "19990920-LLO (5)" (quote ((6) (4 4) (3 3) (2 2) (2 2 2) (2 2 2) (1 2 1) (2 2 2) (1 2 1) (1 4 1) (22) (3 3) (22) (22) (1 1) (1 5 1) (2 2) (20) (12) (8 5) (4 7) (1 2 4 4) (1 2 3 3) (1 2 3 5) (1 2 3 3) (1 2 4 4) (1 2 7) (1 2 5) (1 2) (1 2))) (quote ((4 5) (3 4 2) (2 4 1) (2 4 1) (2 1 2 1) (1 1 2 2) (2 1 1 2 2) (1 2 1 2 3) (2 2 1 2 3) (2 2 2 2 13) (1 4 2 4) (1 3 2 13) (2 2 2 13) (2 1 2 3) (1 1 2 1 3) (2 1 2 1 2) (1 1 2 1 2 5) (2 1 2 1 1 7) (2 4 1 1 9) (2 4 1 3 3) (3 4 2 2 1 2) (4 5 3 1 3) (9) (7) (5))) (quote #25(#30(off off off off off off off on on on on off on on on on on off) #30(off off off off off on on on off off on on on on off off on on off) #30(off off off off on on off off off off on on on on off off off on off) #30(off off off on on off off off off off on on on on off off off on off) #30(off off on on off off off off off off on off on on off off off on off) #30(off off on off off off off off off off on off on on off off off on on off) #30(off on on off on off off off off off on off on on off off off on on off) #30(off on off off on on off off off off on off on on off off off on on on off) #30(on on off off off on on off off off on off on on off off off on on on off) #30(on on off off off off on on off on on off on on off off off on) #30(on off off off off off off on on on on off on on off off off on on on on off) #30(on off off off off off off off on on on off on on off off off on) #30(on on off off off off off off off on on off on on off off off on) #30(on on off off off off off off off off on off on on off off off on on on off) #30(off on off off off off off off off off on off on on off on off on on on off) #30(off on on off off off off off off off on off on on off on off on on off) #30(off off on off off off off off off off on off on on off on off on on off off on on on on on off) #30(off off on on off off off off off off on off on on off on off on off off on on on on on on on off) #30(off off off on on off off off off off on on on on off on off on off on on on on on on on on on off) #30(off off off off on on off off off off on on on on off off off on off on on on off off off on on on off) #30(off off off off off on on on off off on on on on off off on on off on on off off on off off on on off) #30(off off off off off off off on on on on off on on on on on off off on on on off on off on on on off) #30(off off off off off off off off off off off off off off off off off off off on on on on on on on on on off) #30(off off off off off off off off off off off off off off off off off off off off on on on on on on on off) #30(off off off off off off off off off off off off off off off off off off off off off on on on on on off)))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/solution-sets/k25x35 b/collects/games/paint-by-numbers/solution-sets/k25x35
new file mode 100644
index 0000000000..dca8c48612
--- /dev/null
+++ b/collects/games/paint-by-numbers/solution-sets/k25x35
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 25x35") (define problems (list (make-problem "19981015bGAS (1)" (quote (() (21) (1 1) (1 15 1) (1 1 1 1) (1 1 1 1) (1 15 1) (1 1) (1 1) (1 3 3 3 3 1) (1 1 1 1 1 1 1 1 1 1) (1 3 3 3 3 1) (1 1) (1 3 3 3 3 1) (1 1 1 1 1 1 1 1 1 1) (1 3 3 3 3 1) (1 1) (1 3 3 3 3 1) (1 1 1 1 1 1 1 1 1 1) (1 3 3 3 3 1) (1 1) (1 3 3 3 3 1) (1 1 1 1 1 1 1 1 1 1) (1 3 3 3 3 1) (1 1) (1 3 3 3 3 1) (1 1 1 1 1 1 1 1 1 1) (1 3 3 3 1 1 1) (1 1 1 1) (1 7 3 1 1 1) (1 1 1 1 1 1 1 1) (1 7 3 3 1) (1 1) (21) ())) (quote (() () (33) (1 1) (1 1) (1 4 3 3 3 3 3 3 1) (1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1) (1 1 1 3 3 3 3 3 1 1 1) (1 1 1 1 1 1) (1 1 1 3 3 3 3 3 1 1 1) (1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1) (1 1 1 3 3 3 3 3 3 1) (1 1 1 1) (1 1 1 3 3 3 3 3 3 1) (1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1) (1 1 1 3 3 3 3 3 3 1) (1 1 1 1) (1 1 1 3 3 3 3 7 1) (1 1 1 1 1 1 1 1 1 1 1 1 1 1) (1 4 3 3 3 3 7 1) (1 1) (1 1) (33) () ())) (quote #25(#35(off) #35(off) #35(off on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on off) #35(off on off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off on off) #35(off on off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off on off) #35(off on off on on on on off off on on on off on on on off on on on off on on on off on on on off on on on off on off) #35(off on off on off off on off off on off on off on off on off on off on off on off on off on off on off on off on off on off) #35(off on off on off off on off off on on on off on on on off on on on off on on on off on on on off on off on off on off) #35(off on off on off off on off off off off off off off off off off off off off off off off off off off off off off on off on off on off) #35(off on off on off off on off off on on on off on on on off on on on off on on on off on on on off on off on off on off) #35(off on off on off off on off off on off on off on off on off on off on off on off on off on off on off on off on off on off) #35(off on off on off off on off off on on on off on on on off on on on off on on on off on on on off on on on off on off) #35(off on off on off off on off off off off off off off off off off off off off off off off off off off off off off off off off off on off) #35(off on off on off off on off off on on on off on on on off on on on off on on on off on on on off on on on off on off) #35(off on off on off off on off off on off on off on off on off on off on off on off on off on off on off on off on off on off) #35(off on off on off off on off off on on on off on on on off on on on off on on on off on on on off on on on off on off) #35(off on off on off off on off off off off off off off off off off off off off off off off off off off off off off off off off off on off) #35(off on off on off off on off off on on on off on on on off on on on off on on on off on on on on on on on off on off) #35(off on off on off off on off off on off on off on off on off on off on off on off on off on off off off off off on off on off) #35(off on off on on on on off off on on on off on on on off on on on off on on on off on on on on on on on off on off) #35(off on off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off on off) #35(off on off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off on off) #35(off on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on off) #35(off) #35(off)))) (make-problem "19990527dDRA (2)" (quote ((25) (25) (20 2) (8 7 2) (7 1 1 1 5 1) (6 1 1 1 4 1) (5 1 1 1 1 1 2) (5 1 1 1 1 1 2) (5 1 1 1 1 1 2) (5 1 1 1 1 1 2 1 1) (5 1 1 1 1 1 2 2 2) (5 1 1 1 1 1 4 2) (5 1 1 1 1 1 5 3) (5 1 1 1 1 1 5 3) (5 1 1 1 1 1 5 3) (5 1 1 1 5 3) (4 4 1 1 5 3) (3 8 5 3) (2 12 5 3) (1 12 5 3) (1 8 1 5 3) (1 3 4 2 5 3) (1 3 2 3 5 3) (1 3 5 3 5 3) (1 3 5 3 5 3) (1 3 5 3 5 3) (1 9 3 4 2) (1 9 3 3 1) (1 9 13) (1 9 13) (11 13) (11 13) (11 13) (25) (25))) (quote ((35) (19 5) (18 1 14) (17 2 14) (16 3 14) (6 5 9) (5 9 5 13) (4 5 13) (3 11 6 12) (3 5 12) (3 12 5 12) (3 5 2) (3 13 3 13) (4 2 14) (5 11 1 15) (6 7) (35) (35) (6 24) (4 18 7) (2 1 14 7) (2 7) (2 1 14 7) (4 18 7) (6 24))) (quote #25(#35(on) #35(on on on on on on on on on on on on on on on on on on on off off off off off off off off off off off on) #35(on on on on on on on on on on on on on on on on on on off on off on) #35(on on on on on on on on on on on on on on on on on off on on off on) #35(on on on on on on on on on on on on on on on on off on on on off on) #35(on on on on on on off off off off off off off off off off on on on on on off off off off off on) #35(on on on on on off on on on on on on on on on off on on on on on off on) #35(on on on on off off off off off off off off off off off off on on on on on off on) #35(on on on off on on on on on on on on on on on off on on on on on on off on) #35(on on on off off off off off off off off off off off off off off on on on on on off on) #35(on on on off on on on on on on on on on on on on off on on on on on off on) #35(on on on off off off off off off off off off off off off off off on on on on on off off off off off off off off off off off on) #35(on on on off on on on on on on on on on on on on on off on on on off on) #35(on on on on off off off off off off off off off off off off off off on on off on) #35(on on on on on off on on on on on on on on on on on off on off on) #35(on on on on on on off off off off off off off off off off off off off off off off off off off off off off on) #35(on) #35(on) #35(on on on on on on off off off off off on) #35(on on on on off off off off off on on on on on on on on on on on on on on on on on on off on) #35(on on off off off off off off off off on off on on on on on on on on on on on on on on off off on) #35(on on off off off off off off off off off off off off off off off off off off off off off off off off off off on) #35(on on off off off off off off off off on off on on on on on on on on on on on on on on off off on) #35(on on on on off off off off off on on on on on on on on on on on on on on on on on on off on) #35(on on on on on on off off off off off on)))) (make-problem "19990607bDRA (3)" (quote (() (4 1 1 4 1 1) (1 1 1 1 1 2 1) (4 1 1 1 4 1 1 1) (1 2 2 1 1 1 2) (4 1 1 1 1 1 1) () () () () () (3) (2 2) (7) (3) (3) (3) (3) (3) (3) (3) (2 3) (2 2 4 3) (2 10 3) (12 1 3) (3 7 2 3) (3 4 8) (4 8) (15) (13) (10) () () () ())) (quote (() () (3 1) (1 1 1 4) (1 1 1 5) (1 3 5) (4 4) (5 5 4) (1 3 4) (1 4 3) (1 5 3) (5 5 3) (3 5 3) (5 5 4 4) (1 1 1 4 2 5) (1 1 3 3 1 6) (5 2 3 7) (1 3 4) (5 1 3 4) (1 10) (1 8) (1 6) (5) () ())) (quote #25(#35(off) #35(off) #35(off on on on off on off) #35(off on off on off on off off off off off off off off off off off off off off off off on on on on off) #35(off on off on off on off off off off off off off off off off off off off off off off on on on on on off) #35(off on off on on on off off off off off off off off off off off off off off off off off off on on on on on off) #35(off off off off off off off off off off off off off off off off off off off off off on on on on off on on on on off) #35(off on on on on on off off off off off off off off off off off off off off off on on on on on off on on on on off) #35(off off off off on off off off off off off off off off off off off off off off off off off on on on off on on on on off) #35(off off off on off off off off off off off off off off off off off off off off off off off on on on on off on on on off) #35(off off off off on off off off off off off off off off off off off off off off off off on on on on on off on on on off) #35(off on on on on on off off off off off off off off off off off off off off off off on on on on on off on on on off) #35(off off off off off off off off off off off off on on on off off off off off off off on on on on on off on on on off) #35(off on on on on on off off off off off on on on on on off off off off off off on on on on off on on on on off) #35(off on off on off off off off off off off on off on on on on off off off off off off on on off on on on on on off) #35(off on off on off off off off off off off on on on off on on on off off off off off on off on on on on on on off) #35(off on on on on on off off off off off off on on off off on on on off off off off off on on on on on on on off) #35(off off off off off off off off off off off off off on off off off on on on off off off off off off on on on on off) #35(off on on on on on off off off off off off off on off off off off on on on off off off off off on on on on off) #35(off off on off off off off off off off off off off off off off off off off on on on on on on on on on on off) #35(off off off on off off off off off off off off off off off off off off off off on on on on on on on on off) #35(off off off off on off off off off off off off off off off off off off off off off on on on on on on off) #35(off on on on on on off) #35(off) #35(off)))) (make-problem "19991010cTPV (4)" (quote ((25) (3 1 1 9) (2 8) (2 8) (2 9) (3 3 10) (3 2 7) (3 2 6) (3 3 6) (3 2 7) (4 3 8) (5 2 5) (4 3 2 4) (4 2 3) (3 1 3) (3 4) (3 5) (2 7) (2 1 2 7) (2 2 4 8) (2 2 4 8) (2 6 7) (2 3 5) (2 3) (2 2 2) (2 1 3 2) (3 1 4 2) (3 3 1 4 2) (4 4 1 3 3) (5 5 2 4) (6 5 9) (7 5 9) (8 3 10) (10 11) (25))) (quote ((35) (35) (2 12 9) (1 4 7) (1 1 6) (1 5) (2 2 4) (1 2 3) (1 1 2 2) (1 2 1 2) (1 2 4 3 1) (1 5 5 1) (2 1 5 1 6 1) (1 2 3 7 1) (1 1 1 5 2) (1 1 1 1 1 3) (2 2 2 2 8) (6 2 2 2 6) (7 2 1 5 3 5) (11 2 5 4 5) (12 2 7 5 5) (13 8 4 6) (24 7) (35) (35))) (quote #25(#35(on) #35(on) #35(on on off off off on on on on on on on on on on on on off off off off off off off off off on) #35(on off off off off off off off off off on on on on off off off off off off off off off off off off off off on) #35(on off off off off off off off off off off on off off off off off off off off off off off off off off off off off on) #35(on off off off off off off off off off off off off off off off off off off off off off off off off off off off off off on) #35(on on off off off off off off off off off off off off off off off off on on off off off off off off off off off off off on) #35(on off off off off off off off off off off off off off off off off off off on on off off off off off off off off off off off on) #35(on off off off off on off off off off off off off off off off off off off off on on off off off off off off off off off off off on) #35(on off off off off on on off off off off off off off off off off off off off off on off off off off off off off off off off off on) #35(on off off off off on on off off off off off off off off off off off off on on on on off off off off off off on on on off off on) #35(on off off off off off off off off off off off off off off off off off on on on on on off off off off off on on on on on off on) #35(on on off off off off off off off on off off off off off off off off on on on on on off off on off on on on on on on off on) #35(on off off off off off off off off on on off off off off off off off off on on on off off off off on on on on on on on off on) #35(on off off off off off off off off off on off on off off off off off off off off off off off off off off on on on on on off on) #35(on off off off off on off off on off on off on off off off off off off off off off off off off off off off off off off off on) #35(on on off off on on off on on off off on on off off off off off off off off off off off off off off on) #35(on on on on on on off on on off on on off off off off off off off on on off off off off off off off off on) #35(on on on on on on on off off on on off on off off off off on on on on on off off off off on on on off on) #35(on on on on on on on on on on on off on on off off off on on on on on off off off on on on on off on) #35(on on on on on on on on on on on on off on on off on on on on on on on off on on on on on off on) #35(on on on on on on on on on on on on on off off on on on on on on on on off on on on on off on) #35(on on on on on on on on on on on on on on on on on on on on on on on on off off off off on) #35(on) #35(on)))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/solution-sets/k30x20 b/collects/games/paint-by-numbers/solution-sets/k30x20
new file mode 100644
index 0000000000..c13d166bf1
--- /dev/null
+++ b/collects/games/paint-by-numbers/solution-sets/k30x20
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 30x20") (define problems (list (make-problem "19981106-KVL (1)" (quote (() (1 1) (2 2) (8) (8) (2 2 2) (10 8) (15 6) (19 4) (21 2 1) (22 3) (28) (17 10) (3 10 3 4 2) (3 6 2 2 3 3) (3 5 3 4) (12 3 6) (9 2 4) () ())) (quote (() (3) (6) (8) (5 3) (7 2) (8 2) (8 2) (9 2) (9 2) (9 2) (9 2) (8 3) (8 3) (8 3) (7 3) (7 2) (7 1) (5 5) (11) (6 1) (4 5 1 2) (7 6 2) (3 3 5 2) (7 3 3) (7 3 2) (3 3 3 3) (7 7) (4 5) ())) (quote #30(#20(off) #20(off off off off off off off off off off off on on on off) #20(off off off off off off off off off on on on on on on off) #20(off off off off off off off off on on on on on on on on off) #20(off off off off off off off off on on on on on off on on on off) #20(off off off off off off off on on on on on on on off on on off) #20(off off off off off off off on on on on on on on on off on on off) #20(off off off off off off off on on on on on on on on off on on off) #20(off off off off off off on on on on on on on on on off on on off) #20(off off off off off off on on on on on on on on on off on on off) #20(off off off off off off on on on on on on on on on off on on off) #20(off off off off off off on on on on on on on on on off on on off) #20(off off off off off off on on on on on on on on off on on on off) #20(off off off off off off on on on on on on on on off on on on off) #20(off off off off off off on on on on on on on on off on on on off) #20(off off off off off off on on on on on on on off on on on off) #20(off off off off off off on on on on on on on off on on off) #20(off off off off off off on on on on on on on off off off on off) #20(off off off off off off off on on on on on off on on on on on off) #20(off off off off off off off on on on on on on on on on on on off) #20(off off off off off off off off on on on on on on off on off) #20(off off off on on on on off on on on on on off on off on on off) #20(off on on on on on on on off on on on on on on off on on off) #20(off off on on on off on on on off on on on on on off on on off) #20(off off off on on on on on on on off on on on off on on on off) #20(off off off on on on on on on on off on on on off on on off) #20(off off on on on off on on on off on on on off on on on off) #20(off on on on on on on on off on on on on on on on off) #20(off off off on on on on off off off on on on on on off) #20(off)))) (make-problem "19990311-FRA (2)" (quote (() (2) (2) (2) (3) (4) (27) (27) (27) (4) (4 1) (4 1) (6 1 3) (3 1 1) (3 1 1 3 1 1 1) (1 3 1 1 2 1 3 1) (1 3 1 2 1 1 1) (1 1 1 3) (1 1 1) (1 3))) (quote (() (1) (8 1) (9 6) (10 1) (11) (2 3 1) (1 3) (3) (3) (3 6) (3 1 1) (3 3) (3) (3 1 3) (3 1 1 1) (3 5) (3) (3 4) (3 1) (3 1) (3 4) (3) (3 3 1) (3 1 1 1) (3 5) (3) (3 4 1) (3) ())) (quote #30(#20(off) #20(off off off off off off off off off off off off on off) #20(off off off off off on on on on on on on on off on off) #20(off off off off on on on on on on on on on off on) #20(off off off on on on on on on on on on on off on off) #20(off off on on on on on on on on on on on off) #20(off on on off off off on on on off off off on off) #20(off on off off off off on on on off) #20(off off off off off off on on on off) #20(off off off off off off on on on off) #20(off off off off off off on on on off on on on on on on off) #20(off off off off off off on on on off off off off on off on off) #20(off off off off off off on on on off off off off on on on off) #20(off off off off off off on on on off) #20(off off off off off off on on on off off off on off on on on off) #20(off off off off off off on on on off off off on off on off on off) #20(off off off off off off on on on off off off on on on on on off) #20(off off off off off off on on on off) #20(off off off off off off on on on off off off off off on on on on off) #20(off off off off off off on on on off off off off off off on off) #20(off off off off off off on on on off off off off off off off on off) #20(off off off off off off on on on off off off off off on on on on off) #20(off off off off off off on on on off) #20(off off off off off off on on on off off off off off off on on on off on) #20(off off off off off off on on on off off off off off off on off on off on) #20(off off off off off off on on on off off off off off off on) #20(off off off off off off on on on off) #20(off off off off off off on on on off off off off on on on on off on off) #20(off off off off off off on on on off) #20(off)))) (make-problem "19990601cDRA (3)" (quote (() (3 1 3 1) (1 1 1 1) (2 1 2 3 1 2 1 1 2 3) (1 1 1 2 1 1 1 1 1 2) (1 1 1 3 1 1 2 2 1 1) () () (26) (2 2 7) (2 6 2 1) (9 1 1 1 2 1) (1 1 1 1 1 2 1) (1 2 2 1) (1 2 2 1) (1 1 1 1 1 1) (2 2 11 2 7) (2 2) () ())) (quote ((5) (1 1 1 6) (1 1 1 1) (1 1 1) (1 3 4 1 2) (4 1 2) (3 1 1 1) (1 1 1 1) (1 1 1) (3 1 2 1) (3 1 1 1) (1 1 1 4 1) (1 1 1) (3 1) (1 3 1) (5 1 1 1) (1 1 4 1) (3 1 1 1) (1 1 3 1) (3 1 2) (2 2 1 2) (1 2 1) (3 2 2 1) (2 2 1) (3 2 1) (1 1 3 1) (1 2 1) (5 4) (2 1) (2 1))) (quote #30(#20(off on on on on on off) #20(off on off on off off off off on off off on on on on on on off) #20(off on off off off off off off on off off on off off off off on off) #20(off off off off off off off off on off off on off off off on off) #20(off on off on on on off off on on on on off off on off on on off) #20(off off off off off off off off on on on on off off on off on on off) #20(off off off on on on off off on off off on off off off on off) #20(off off off on off off off off on off off on off off off off on off) #20(off off off off off off off off on off off on off off off off on off) #20(off off off on on on off off on off off on on off off off on off) #20(off off off on on on off off on off off off off on off off on off) #20(off off off on off on off off on off on on on on off off on off) #20(off off off off off off off off on off on off off off off off on off) #20(off off off off off off off off on on on off off off off off on off) #20(off on off off off off off off on on on off off off off off on off) #20(off on on on on on off off on off on off off off off off on off) #20(off on off off off off off off on off on on on on off off on off) #20(off off off on on on off off on off off off off on off off on off) #20(off off off on off off off off on off on on on off off on off) #20(off off off off off off off off on on on off off off on off on on off) #20(off off off on on off off off on on off off off off on off on on off) #20(off off off off off on off off on on off off off off off on off) #20(off off off on on on off off on on off on on off off off on off) #20(off off off off off off off off on on off on on off off off on off) #20(off off off on on on off off on on off off off off off off on off) #20(off off off on off on off off on on on off off off off off on off) #20(off off off off off off off off on off off on on off off off on off) #20(off on on on on on off off off off off off off on on on on off) #20(off off off on on off off off off off off off off off off off on off) #20(off off on on off on off)))) (make-problem "19991106-BDH (4)" (quote ((7) (9) (6 3) (6 3) (13) (16) (1 13) (2 10) (3 7) (5 5 7) (23) (7 10 5) (7 8 6) (8 7) (25) (25) (25) (24) (22) (20))) (quote ((8) (12) (12) (12) (11) (10) (10) (1 7) (2 6) (4 6) (4 6) (4 6) (4 6) (4 6) (4 3 6) (7 4 6) (13 6) (12 6) (11 7) (20) (2 16) (2 16) (9 10) (7 8) (6 6) (3) (3) (2) (1) (1))) (quote #30(#20(off off off off off off off off off on on on on on on on on off) #20(off off off off off off on on on on on on on on on on on on off) #20(off off off off off off off on on on on on on on on on on on on off) #20(off off off off off off off off on) #20(off off off off off off off off off on) #20(off off off off off off off off off off on) #20(off off off off off off off off off off on) #20(off off off off off off off off off off on off off on) #20(off off off off off off off off off off on on off off on) #20(off off off off off off off off off on on on on off on) #20(off off off off off off off off off on on on on off on) #20(off off off off off off off off off on on on on off on) #20(off off off off off off off off off on on on on off on) #20(off off off off off off off off off on on on on off on) #20(off off on on on on off off off off on on on off on) #20(off on on on on on on on off on on on on off on) #20(on on on on on on on on on on on on on off on) #20(on on on on on on on on on on on on off off on) #20(on on on on on on on on on on on off off on) #20(on) #20(on on off off on) #20(on on off off on) #20(on on on on on on on on on off on) #20(off on on on on on on on off off off on on on on on on on on off) #20(off off on on on on on on off off off off on on on on on on off) #20(off off off off on on on off) #20(off off off off on on on off) #20(off off off off off on on off) #20(off off off off off on off) #20(off off off off off on off)))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/solution-sets/k30x25 b/collects/games/paint-by-numbers/solution-sets/k30x25
new file mode 100644
index 0000000000..d3b01dc138
--- /dev/null
+++ b/collects/games/paint-by-numbers/solution-sets/k30x25
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 30x25") (define problems (list (make-problem "19980715-GAS (1)" (quote ((30) (30) (30) (13 15) (12 14) (12 14) (12 14) (12 14) (12 14) (13 15) (13 12) (7 6) (4 3) (1 1) (1 2) (3 1 3 4) (3 3 4 3) (2 4 4 3) (2 3 3 2) (1 2 2 1 2) (1 1 1 1 3 1) (3 4 1) (4 5) () ())) (quote ((11 7) (11 4) (11 2) (12) (13) (14) (13 2) (13 3) (12 2) (12 1 1) (11 3) (11 4) (4 2 6) (3) (3) (4 2) (11 6) (11 5) (11 4) (11 2 1) (12 2) (12 3) (13 4) (13 3) (13) (12) (11 1) (10 3) (10 6) (10 9))) (quote #30(#25(on on on on on on on on on on on off off off on on on on on on on off) #25(on on on on on on on on on on on off off off off on on on on off) #25(on on on on on on on on on on on off off off off on on off) #25(on on on on on on on on on on on on off) #25(on on on on on on on on on on on on on off) #25(on on on on on on on on on on on on on on off) #25(on on on on on on on on on on on on on off off off off off off off off on on off) #25(on on on on on on on on on on on on on off off off off off off off on on on off) #25(on on on on on on on on on on on on off off off off off off off off off on on off) #25(on on on on on on on on on on on on off off off off off on off off off off on off) #25(on on on on on on on on on on on off off off off off on on on off) #25(on on on on on on on on on on on off off off off off on on on on off) #25(on on on on off off off off off on on off off off off on on on on on on off) #25(on on on off) #25(on on on off) #25(on on on on off off off off off on on off) #25(on on on on on on on on on on on off off off off on on on on on on off) #25(on on on on on on on on on on on off off off off on on on on on off) #25(on on on on on on on on on on on off off off off on on on on off) #25(on on on on on on on on on on on off off off off off on on off off off off on off) #25(on on on on on on on on on on on on off off off off off off off off off on on off) #25(on on on on on on on on on on on on off off off off off off off off on on on off) #25(on on on on on on on on on on on on on off off off off off off on on on on off) #25(on on on on on on on on on on on on on off off off off off off off on on on off) #25(on on on on on on on on on on on on on off) #25(on on on on on on on on on on on on off) #25(on on on on on on on on on on on off off off off on off) #25(on on on on on on on on on on off off off off off on on on off) #25(on on on on on on on on on on off off off off on on on on on on off) #25(on on on on on on on on on on off off off on on on on on on on on on off)))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/solution-sets/k30x30 b/collects/games/paint-by-numbers/solution-sets/k30x30
new file mode 100644
index 0000000000..70dbebc4a9
--- /dev/null
+++ b/collects/games/paint-by-numbers/solution-sets/k30x30
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 30x30") (define problems (list (make-problem "19981106-GAS (1)" (quote (() () (5 6) (1 2 2 1) (2 12 2) (1 2 2 1) (3 3) (1 3 3 1) (1 1 1 1 1 1) (2 1 3 3 1 2) (1 1 3 1 3 1 1) (1 4 1 4 1) (1 2 1 2 1) (1 1 1) (1 1 1) (1 3 1) (2 7 2) (1 3 1) (2 1 1 2) (2 2 11 2 2) (2 2 1 1 1 2 2) (1 2 1 2 1) (2 1 1 1 1) (1 7 1) (1 1) (1 1) (1 1 6 1) (1 1 1 1) (1 1 1 2) (25))) (quote (() () (8) (3 1) (3 8 2 1) (1 6 4 1) (1 1 1 4) (1 1 1 1) (2 1 2 1 1) (3 1 1 1 1) (1 1 4 3 1) (1 1 4 1 1 1) (1 5 1 5 1) (1 1 1 1 1) (1 3 1 1 1) (1 8 5 1) (1 3 1 1 1) (1 1 1 1 3) (1 5 1 5 1 1) (1 1 4 1 1 1 1) (2 1 4 3 1 1) (2 1 1 1 1 1 1) (1 1 2 1 1 1) (1 1 1 1 1) (1 1 1 1) (1 6 4 1) (3 8 2 2) (9) () ())) (quote #f)) (make-problem "19981230-SQU (2)" (quote (() () (4 4) (6 6) (8 8) (9 9) (9 9) (8 8) (7 6 7) (5 8 5) (10) (13) (14) (14) (18) (2 14 2) (2 14 2) (2 16 2) (2 2 12 2 2) (1 2 10 2 1) (4 3 2 3 4) (2 2 6 2 2) (4 2 2 2 4) (1 2 1 2 1 2 1) (2 1 2 2 2 1 2) (2 2 2 2 2) (2 2 2 2) (2 2 2 2) (2 2 2 2) (30))) (quote ((1) (3 1) (5 3 3 1) (7 2 3 2 1) (7 2 3 2 1) (8 2 2 2 2 1) (8 2 2 2 3) (7 1 2 2) (6 7 3 1) (5 8 2 2 1) (12 2 1) (12 2 1) (14 3) (12 1 2) (18 1) (18 1) (12 1 2) (14 3) (12 2 1) (12 2 1) (5 8 2 2 1) (6 6 3 1) (7 1 2 2) (8 2 2 2 3) (8 2 2 2 2 1) (7 2 3 2 1) (7 2 3 2 1) (5 3 3 1) (3 1) (1))) (quote #30(#30(off off off off off off off off off off off off off off off off off off off off off off off off off off off off off on) #30(off off off off on on on off off off off off off off off off off off off off off off off off off off off off off on) #30(off off off on on on on on off off off off off off off off off off on on on off on on on off off off off on) #30(off off on on on on on on on off off off off off off off off on on off on on on off on on off off off on) #30(off off on on on on on on on off off off off off off off on on off off on on on off off on on off off on) #30(off off on on on on on on on on off off off off off on on off off on on off on on off off on on off on) #30(off off on on on on on on on on off off off off on on off off on on off off off on on off off on) #30(off off off on on on on on on on off off off off on off off on on off off off off off off off off off on) #30(off off off off on on on on on on off on on on on on on on off off off off on on on off off off off on) #30(off off off off off on on on on on off on on on on on on on on off off on on off on on off off off on) #30(off off off off off off off off off off on on on on on on on on on on on on off off off on on off off on) #30(off off off off off off off off off on on on on on on on on on on on on off off off off off on on off on) #30(off off off off off off off off on on on on on on on on on on on on on on off off off off off on) #30(off off off off off off off off on on on on on on on on on on on on off on off off off off off off on) #30(off off off off off off off off on on on on on on on on on on on on on on on on on on off off off on) #30(off off off off off off off off on on on on on on on on on on on on on on on on on on off off off on) #30(off off off off off off off off on on on on on on on on on on on on off on off off off off off off on) #30(off off off off off off off off on on on on on on on on on on on on on on off off off off off on) #30(off off off off off off off off off on on on on on on on on on on on on off off off off off on on off on) #30(off off off off off off off off off off on on on on on on on on on on on on off off off on on off off on) #30(off off off off off on on on on on off on on on on on on on on off off on on off on on off off off on) #30(off off off off on on on on on on off off on on on on on on off off off off on on on off off off off on) #30(off off off on on on on on on on off off off off on off off on on off off off off off off off off off on) #30(off off on on on on on on on on off off off off on on off off on on off off off on on off off on) #30(off off on on on on on on on on off off off off off on on off off on on off on on off off on on off on) #30(off off on on on on on on on off off off off off off off on on off off on on on off off on on off off on) #30(off off on on on on on on on off off off off off off off off on on off on on on off on on off off off on) #30(off off off on on on on on off off off off off off off off off off on on on off on on on off off off off on) #30(off off off off on on on off off off off off off off off off off off off off off off off off off off off off off on) #30(off off off off off off off off off off off off off off off off off off off off off off off off off off off off off on)))) (make-problem "19990104-FRA (3)" (quote ((7) (7) (7) (7) (7) (7) (8) (9) (18) (19) (30) (11 1 3 8) (12 4 1 9) (11 5 10) (10 5 10) (10 4 1 9) (9 3 3 8) (25) (3 20) (1 17) (15) (12) (10) (7) (7) (5) (4) (5) (3) ())) (quote ((2) (3) (4) (6) (7) (8) (9) (10) (9) (8) (19) (11 8) (11 9) (11 5) (11 11) (11 11) (25) (5 4 9) (5 2 12) (5 13) (4 2 13) (3 4 12) (17 2) (15) (14) (13) (13) (12) (10) (9))) (quote #30(#30(off off off off off off off off off off on on off) #30(off off off off off off off off off off on on on off) #30(off off off off off off off off off off on on on on off) #30(off off off off off off off off off off on on on on on on off) #30(off off off off off off off off off off on on on on on on on off) #30(off off off off off off off off off off on on on on on on on on off) #30(off off off off off off off off off off on on on on on on on on on off) #30(off off off off off off off off off off on on on on on on on on on on off) #30(off off off off off off off off off off on on on on on on on on on off) #30(off off off off off off off off off off on on on on on on on on off) #30(on on on on on on on on on on on on on on on on on on on off) #30(on on on on on on on on on on on off on on on on on on on on off) #30(on on on on on on on on on on on off on on on on on on on on on off) #30(on on on on on on on on on on on off off off off off off on on on on on off) #30(on on on on on on on on on on on off on on on on on on on on on on on off) #30(on on on on on on on on on on on off on on on on on on on on on on on off) #30(on on on on on on on on on on on on on on on on on on on on on on on on on off) #30(off off off off off off on on on on on off on on on on off on on on on on on on on on off) #30(off off off off off off off on on on on on off on on off on on on on on on on on on on on on off) #30(off off off off off off off off on on on on on off off on on on on on on on on on on on on on off) #30(off off off off off off off off on on on on off on on off on on on on on on on on on on on on on off) #30(off off off off off off off off on on on off on on on on off on on on on on on on on on on on on off) #30(off off off off off off off off on on on on on on on on on on on on on on on on on off off on on off) #30(off off off off off off off off on on on on on on on on on on on on on on on off) #30(off off off off off off off off on on on on on on on on on on on on on on off) #30(off off off off off off off off on on on on on on on on on on on on on off) #30(off off off off off off off off on on on on on on on on on on on on on off) #30(off off off off off off off off on on on on on on on on on on on on off) #30(off off off off off off off off off on on on on on on on on on on off) #30(off off off off off off off off off off on on on on on on on on on off)))) (make-problem "19990708-VEG (4)" (quote ((1 1 3 1 1 3 1 1) (1 1 1 1 2 2 1 5) (3 1 1 1 1 1 2 5) (1 1 1 1 1 1 1 3) (1 1 3 1 1 3 1) () () () () (1) (3) (5 1) (7 1) (10) (11) (13) (15) (2 2) (2 2 2 2) (2 2 2 2) (2 2) (2 2) (12 3 9) (1 1 1 3 3 3 1 1) (2 2 2 2 3 2 2 2) (1 1 1 3 3 3 1 1) (30) (13) (1 1) (1 1))) (quote ((5 2 2) (1 1 1 1) (5 1 1 1) (2 2) (5 1 1 1) (1 1 1 1 1) (5 2 2) (1 1 1) (5 1 1 1) (1 1 2 2) (1 13) (1 14) (5 4 2) (5 2 2) (5 6 2 2) (1 1 1 7 6) (1 1 8 6) (7 2 6) (6 2 3) (5 2 1) (2 4 3) (4 17 1) (4 13) (4 1 2 2) (2 1 1 1) (1 1 1) (2 2) (1 1 1) (1 1 1) (2 2))) (quote #30(#30(on on on on on off off off off off off off off off off off off off off off off off on on off on on off) #30(off off on off off off off off off off off off off off off off off off off off off off on off on off on off) #30(on on on on on off off off off off off off off off off off off off off off off off on off on off on off) #30(off off off off off off off off off off off off off off off off off off off off off off on on off on on off) #30(on on on on on off off off off off off off off off off off off off off off off off on off on off on off) #30(on off off off on off off off off off off off off off off off off off off off off off on off on off on off) #30(on on on on on off off off off off off off off off off off off off off off off off on on off on on off) #30(off off off off off off off off off off off off off off off off off off off off off off on off on off on off) #30(on on on on on off off off off off off off off off off off off off off off off off on off on off on off) #30(off on off off off off off off off off off off off off off off on off off off off off on on off on on off) #30(off off on off off off off off off off off off off off off on on on on on on on on on on on on on off) #30(off on off off off off off off off off off off off off on on on on on on on on on on on on on on off) #30(on on on on on off off off off off off off off on on on on off off off off off off off off off on on off) #30(off off off off off off off off off off off off on on on on on off on on off off off off off off on on off) #30(on on on on on off off off off off off on on on on on on off on on off off off off off off on on off) #30(on off on off on off off off off off on on on on on on on off off off off off on on on on on on off) #30(on off off off on off off off off on on on on on on on on off off off off off on on on on on on off) #30(off off off off off off off off off off on on on on on on on off on on off off on on on on on on off) #30(off off off off off off off off off off off on on on on on on off on on off off off off off off on on on off) #30(off off off off off off off off off off off off on on on on on off off off off off off off off off on on off on) #30(off on on off off off off off off off off off off on on on on off off off off off off off off off on on on off) #30(on on on on off off off off off off off on on on on on on on on on on on on on on on on on off on) #30(off on on on on off off off off off off off off off off on on on on on on on on on on on on on off) #30(on on on on off off off off off off off off off off off off on off off off off off on on off on on off) #30(off on on off off off off off off off off off off off off off off off off off off off on off on off on off) #30(off off off off off off off off off off off off off off off off off off off off off off on off on off on off) #30(off off off off off off off off off off off off off off off off off off off off off off on on off on on off) #30(off off off off off off off off off off off off off off off off off off off off off off on off on off on off) #30(off off off off off off off off off off off off off off off off off off off off off off on off on off on off) #30(off off off off off off off off off off off off off off off off off off off off off off on on off on on off)))) (make-problem "19990729-WHO (5)" (quote ((3) (1 2) (1 5) (1 1 1 4) (1 1 1 3) (1 1 1 2) (1 5) (1 3) (1 2) (1 1) (1 1) (1 1) (3 2) (12 5) (13 6) (14 8) (15 9) (16 9) (16 10) (16 10) (16 9) (16 9) (8 7 9) (8 16) (27) (26) (25) (22) (15) (5))) (quote (() (3) (6) (12) (13) (14) (15) (16) (16) (17) (9 6) (9 6) (17) (17) (16) (16) (17) (17) (28) (1 5) (28) (2 3 16) (6 15) (1 1 15) (5 14) (3 13) (2 11) (1 10) (7) (2))) (quote #30(#30(off) #30(off off off off off off off off off off off off off off off off off off off off off off off off on on on off) #30(off off off off off off off off off off off off off off off off off off off off off off on on on on on on off) #30(off off off off off off off off off off off off off off off off off on on on on on on on on on on on on off) #30(off off off off off off off off off off off off off off off off on on on on on on on on on on on on on off) #30(off off off off off off off off off off off off off off off on on on on on on on on on on on on on on off) #30(off off off off off off off off off off off off off off on on on on on on on on on on on on on on on off) #30(off off off off off off off off off off off off off on on on on on on on on on on on on on on on on off) #30(off off off off off off off off off off off off off on on on on on on on on on on on on on on on on off) #30(off off off off off off off off off off off off off on) #30(off off off off off off off off off off off off off on on on on on on on on on off off on) #30(off off off off off off off off off off off off off on on on on on on on on on off off on) #30(off off off off off off off off off off off off off on) #30(off off off off off off off off off off off off off on) #30(off off off off off off off off off off off off off on on on on on on on on on on on on on on on on off) #30(off off off off off off off off off off off off off on on on on on on on on on on on on on on on on off) #30(off off off off off off off off off off off off on on on on on on on on on on on on on on on on on off) #30(off off off off off off off off off off off off on on on on on on on on on on on on on on on on on off) #30(on on on on on on on on on on on on on on on on on on on on on on on on on on on on off) #30(on off off off off off off off off off off off off off off off off off off off off off off on on on on on off) #30(on on on on on on on on on on on on on on on on on on on on on on on on on on on on off) #30(off on on off off off on on on off off off on on on on on on on on on on on on on on on on off) #30(off off on on on on on on off off off off off on on on on on on on on on on on on on on on off) #30(off off on off off off on off off off off off off on on on on on on on on on on on on on on on off) #30(off off on on on on on off off off off off off on on on on on on on on on on on on on on off) #30(off off off on on on off off off off off off off off on on on on on on on on on on on on on off) #30(off off off on on off off off off off off off off off off on on on on on on on on on on on off) #30(off off off on off off off off off off off off off off off on on on on on on on on on on off) #30(off off off off off off off off off off off off off off off off on on on on on on on off) #30(off off off off off off off off off off off off off off off off off off on on off)))) (make-problem "19990820-DAH (6)" (quote (() (7 1 8) (1 4 2 1 2 1) (1 2 3 1 1 1 1) (1 2 4 1 1 1 1) (1 3 5 1 2 1) (1 2 1 2 1 1 1 1) (3 2 1 2 2) (3 2 8) () () (8 4) (8 3 4 2 2) (2 2 2 3 2) (1 1 1 1 3) (1 2 1 1 1 2) (1 1 1 1) (8 1 1 2) (6 2) () () (6 3) (1 1 2 1 1 1) (1 1 1 4 2 1 1) (1 1 1 1 2 2 1) (1 1 1 5 3 2) (6 1 1 1 2 2) (4 2 1 2) (1 2 1 6) ())) (quote (() (7 6) (1 1 2 1 6 1) (1 1 1 1 2 1 2) (2 1 1 1 1 1 3) (2 1 1 1 1 1 1 3) (8 1 1 2 1 2) (7 2 1 6 1) (6) () () (3 6) (3 2 1 2) (6 2 1 1 1 1 1) (4 1 1 1 1 1) (4 2 1 1 1 1) (5 3 1 1 1 1 1) (1 1 3 2 3 1) (3 2) () () (8 6) (1 2 1 5) (1 2 1 1 2 1) (2 1 1 1 2 2 2) (2 1 1 1 2 2 1 1 1) (1 2 1 1 4 1 3) (1 2 2 1 1) (8 3) ())) (quote #f)) (make-problem "19990821-ICO (7)" (quote (() () (1 1 1 1 1) (2 1 1 1 1) (2 2 1 1 1 1) (1 2 1 4 3 1 1 1 1) (1 2 1 6 3 1 1 1 1) (1 2 1 6 3 1 1 1 1) (1 2 1 6 3 1 1 1 1) (1 2 1 6 3 1 1 1 1) (1 2 1 6 3 1 1 1 1) (1 2 1 6 3 7) (6 4 3 5) (6 2 2 3) (2 2 2 1) (2 2 2 1) (2 2 2 1) (2 2 2 1) (2 2 2 1) (2 2 2 1) (2 2 2 1) (2 2 2 1) (2 2 2 1) (2 2 2 1) (1 1 3 3 1 1 3 1 1 3) (1 1 1 1 2 1 1 1 1 1) (1 1 1 3 1 2 3 1 1 3) (1 1 1 1 1 1 1 1 1 1) (3 1 3 1 1 3 1 2 3) ())) (quote ((9) (2 5) (19 1) (24) (2) (9 1) (5) (1) (6) (8 5) (21 1 1) (21 1 1) (8) (6 5) (1) (1) (5) (22) (24 1) (8 1 1 1) (1 3) () (10 5) (2) (12 5) (13 1) (12) (2 3 1) (10 1 1 1) (1 3))) (quote #30(#30(off off off off off on on on on on on on on on off) #30(off off off off off off off off off off off off on on off off off off off off off off off off on on on on on off) #30(off off off off off on on on on on on on on on on on on on on on on on on on off off off off on off) #30(off off off off off on on on on on on on on on on on on on on on on on on on on on on on on off) #30(off off off off off off off off off off off off on on off) #30(off off off off off on on on on on on on on on off off off off off off off off off off on off) #30(off off off off off off off off off off off off off off off off off off off off off off off off on on on on on off) #30(off off off off off off off off off off off off off off off off off off off off off off off off on off) #30(off off off off off off on on on on on on off) #30(off off off off off on on on on on on on on off off off off off off off off off off off on on on on on off) #30(off off off off on on on on on on on on on on on on on on on on on on on on on off on off on off) #30(off off off off on on on on on on on on on on on on on on on on on on on on on off on off on off) #30(off off off off off on on on on on on on on off) #30(off off off off off off on on on on on on off off off off off off off off off off off off on on on on on off) #30(off off off off off off off off off off off off off off off off off off off off off off off off off on off) #30(off off off off off off off off off off off off off off off off off off off off off off off off off off on off) #30(off off off off off off off off off off off off off off off off off off off off off off off off on on on on on off) #30(off off on on on on on on on on on on on on on on on on on on on on on on off) #30(off off off on on on on on on on on on on on on on on on on on on on on on on on on off on off) #30(off off off off off on on on on on on on on off off off off off off off off off off off on off on off on off) #30(off off off off off off off off off off off off off off off off off off off off off off off off on off on on on off) #30(off) #30(off off on on on on on on on on on on off off off off off off off off off off off off on on on on on off) #30(off off off off off off off off off off off on on off) #30(off off on on on on on on on on on on on on off off off off off off off off off off on on on on on off) #30(off off off off off off off off off off off on on on on on on on on on on on on on off off off off on off) #30(off off on on on on on on on on on on on on off) #30(off off off off off off off off off off off on on off off off off off off off off off off off on on on off on off) #30(off off on on on on on on on on on on off off off off off off off off off off off off on off on off on off) #30(off off off off off off off off off off off off off off off off off off off off off off off off on off on on on off)))) (make-problem "19990908-ALE (8)" (quote ((12 16) (11 15) (10 14) (4 4 14) (3 4 3 10) (2 4 3 9) (2 3 4 8) (3 4 4 8) (4 5 5 9) (6 5 5 10) (7 4 6 10) (8 3 5 11) (8 3 4 12) (8 4 3 12) (8 4 2 5 6) (8 4 2 4 5) (8 4 2 3 5) (9 3 2 3 4) (9 4 1 2 1 1 3) (10 4 1 3 3 2) (10 4 3 4) (11 2 3) (16 1 1 2) (21 2 2) (21 5) (20 4) (19 3) (21 1 6) (21 1 6) (20 1 5))) (quote ((30) (30) (5 23) (4 22) (3 21) (3 21) (4 1 20) (5 3 19) (11 13) (17 11) (2 15 9) (1 1 12 8) (3 8 8) (7 3 8) (1 13 2 8) (2 15 8) (6 6 7) (5 3 8 7) (4 1 7 2 7) (4 7 2 3 3) (5 7 2 3 2) (6 7 1) (14 3) (14) (15 1 2) (17 2 3 3) (18 2 3 3) (19 2 6) (30) (30))) (quote #30(#30(on) #30(on) #30(on on on on on off off on) #30(on on on on off off off off on) #30(on on on off off off off off off on) #30(on on on off off off off off off on) #30(on on on on off off off off on off on) #30(on on on on on off off on on on off on) #30(on on on on on on on on on on on off off off off off off on) #30(on on on on on on on on on on on on on on on on on off off on) #30(on on off off on on on on on on on on on on on on on on on off off on) #30(on off off off off on off off off on on on on on on on on on on on on off on) #30(off off off off off off on on on off off off off on on on on on on on on off on) #30(off off off off off off on on on on on on on off off off off off on on on off on) #30(on off off off off on on on on on on on on on on on on on off on on off on) #30(on on off off on on on on on on on on on on on on on on on off off off on) #30(on on on on on on off off on on on on on on off off off off off off off off off on) #30(on on on on on off off off off on on on off off on on on on on on on on off on) #30(on on on on off off off off off off on off on on on on on on on off on on off on) #30(on on on on off off off off off off off on on on on on on on off on on off off on on on off on) #30(on on on on on off off off off on on on on on on on off off on on off off on on on off off on on off) #30(on on on on on on off off on on on on on on on off off off off on off) #30(on on on on on on on on on on on on on on off off off off off off off off off off off off off on) #30(on on on on on on on on on on on on on on off) #30(on on on on on on on on on on on on on on on off off off off on off off off off off off off on on off) #30(on on on on on on on on on on on on on on on on on off on on off off on on on off off on) #30(on on on on on on on on on on on on on on on on on on off on on off off on on on off on) #30(on on on on on on on on on on on on on on on on on on on off on on off off on) #30(on) #30(on)))) (make-problem "19990913-TUC (9)" (quote ((12 14) (13 15) (13 15) (13 15) (1 6 6 3) (1 3 5 5 3 3) (1 1 4 4 3 3) (1 1 1 3 3 1 3) (1 3 3 3 1 1 3) (1 3 3 3 3 3) (1 3 3 6 3 3 3) (2 1 4 6 4 1 4) (3 5 6 5 5) (3 5 6 5 5) (3 5 5 5) (3 5 5 5) (3 5 5 5) (2 4 4 4) (1 1 1 3 3 1 1 3) (1 3 3 3 3 3) (2 4 4 4) (30) () (30) (1 1 2 1 1 1 2) (1 2 1 2 1 4 4 2 1 3) (1 4 1 2 2 2) (1 2 1 2 1 4 4 2 4) (1 1 2 1 1 1 2 1) (30))) (quote ((22 7) (4 7 2 1 1) (4 1 4 5 2 1 1 3 1) (4 2 4 1 1 1 3 1) (4 1 4 5 2 1 1 1 1) (4 7 2 7) (22 1 1) (22 3 3) (22 3 3) (7 1 1 1) (6 1 7) (5 4 1 1 1) (3 4 1 1 1 1 1) (4 1 1 1 1 1) (4 1 1 3 1) (3 4 1 7) (5 4 1 1 1) (6 1 1 1 1 1) (7 1 1 1 1 1) (22 1 3 1) (22 7) (22 1 1) (4 7 2 1 1 3) (4 2 3 5 2 1 1 1 3) (4 3 3 1 1 2 1 1) (4 2 3 5 2 1 7) (4 7 2 1 1 1) (22 1 1 1 1) (22 1 1 1 1) (22 1 1 1))) (quote #30(#30(on on on on on on on on on on on on on on on on on on on on on on off on) #30(on on on on off off off off off off off on on on on on on on off off on on off on off off off off off on) #30(on on on on off on off on on on on off on on on on on off on on off on off on off on on on off on) #30(on on on on off on on off on on on on off off off off off off off on off on off on off on on on off on) #30(on on on on off on off on on on on off on on on on on off on on off on off on off off on off off on) #30(on on on on off off off off off off off on on on on on on on off off on on off on) #30(on on on on on on on on on on on on on on on on on on on on on on off on off off off off off on) #30(on on on on on on on on on on on on on on on on on on on on on on off on on on off on) #30(on on on on on on on on on on on on on on on on on on on on on on off on on on off on) #30(on on on on on on on off off off off off off off off off off off off off off on off on off off off off off on) #30(on on on on on on off off off off off off off off off off off off off off off on off on) #30(on on on on on off off off off off on on on on off off off off off off off on off on off off off off off on) #30(off on on on off off off off off off on on on on off off off off off off off on off on off on off on off on) #30(off off off off off off off off off off on on on on off off off off off off off on off on off on off on off on) #30(off off off off off off off off off off on on on on off off off off off off off on off on off on on on off on) #30(off on on on off off off off off off on on on on off off off off off off off on off on) #30(on on on on on off off off off off on on on on off off off off off off off on off on off off off off off on) #30(on on on on on on off off off off off off off off off off off off off off off on off on off on off on off on) #30(on on on on on on on off off off off off off off off off off off off off off on off on off on off on off on) #30(on on on on on on on on on on on on on on on on on on on on on on off on off on on on off on) #30(on on on on on on on on on on on on on on on on on on on on on on off on) #30(on on on on on on on on on on on on on on on on on on on on on on off on off off off off off on) #30(on on on on off off off off off off off on on on on on on on off off on on off on off on off on) #30(on on on on off on on off on on on off on on on on on off on on off on off on off on off on) #30(on on on on off on on on off on on on off off off off off off off on off on off on on off on off off on) #30(on on on on off on on off on on on off on on on on on off on on off on off on) #30(on on on on off off off off off off off on on on on on on on off off on on off on off off off on off on) #30(on on on on on on on on on on on on on on on on on on on on on on off on off on off on off on) #30(on on on on on on on on on on on on on on on on on on on on on on off on off on off on off on) #30(on on on on on on on on on on on on on on on on on on on on on on off on off on off off off on)))) (make-problem "19990916bCAR (10)" (quote ((30) (30) (30) (7 7 6) (6 5 5) (5 3 3 3 4) (5 5 1 5 4) (5 6 6 4) (5 15 4) (5 5 5 4) (6 4 4 5) (6 3 3 5) (7 4 4 6) (8 3 3 7) (9 5 8) (9 3 8) (10 1 9) (11 10) (12 11) (13 12) (14 13) (15 8 3) (23 3 2) (7 12 3 1) (7 2) (7 2) (7 1 1 12 3 1) (7 1 13 3 2) (24 3) (30))) (quote ((30) (30) (30) (30) (30) (5 20) (4 18) (3 10 2) (3 3 9 4) (3 5 7 2) (3 6 6 4) (3 8 5 3) (4 8 5 4) (5 8 4 4) (6 1 4 3 4) (7 1 3 2 4) (6 1 4 3 4) (5 8 4 4) (4 8 5 4) (3 8 6 4) (3 6 7 4) (3 5 8 4) (3 3 10 4) (3 9 1 1 2) (4 9 1 1 1) (5 11 2 2 1) (21 2 2 1) (22 4 2) (23 2 3) (24 4))) (quote #30(#30(on) #30(on) #30(on) #30(on) #30(on) #30(on on on on on off off off off off on) #30(on on on on off off off off off off off off on) #30(on on on off off off off off off off off off off on on on on on on on on on on off off off off off on) #30(on on on off off off on on on off off off off off on on on on on on on on on off off off on) #30(on on on off off on on on on on off off off off off off on on on on on on on off off off off off on) #30(on on on off off on on on on on on off off off off off off on on on on on on off off off on) #30(on on on off off on on on on on on on on off off off off off on on on on on off off off off on) #30(on on on on off off on on on on on on on on off off off off off on on on on on off off on) #30(on on on on on off off on on on on on on on on off off off off off on on on on off off on) #30(on on on on on on off off on off off off on on on on off off off off off on on on off off on) #30(on on on on on on on off on off off off off off on on on off off off off off on on off off on) #30(on on on on on on off off on off off off on on on on off off off off off on on on off off on) #30(on on on on on off off on on on on on on on on off off off off off on on on on off off on) #30(on on on on off off on on on on on on on on off off off off off on on on on on off off on) #30(on on on off off on on on on on on on on off off off off off on on on on on on off off on) #30(on on on off off on on on on on on off off off off off off on on on on on on on off off on) #30(on on on off off on on on on on off off off off off off on on on on on on on on off off on) #30(on on on off off off on on on off off off off off on on on on on on on on on on off off on) #30(on on on off off off off off off off off off off on on on on on on on on on off on off off on off on) #30(on on on on off off off off off off off off on on on on on on on on on off on off off off off on off on) #30(on on on on on off off off off off on on on on on on on on on on on off on on off off on on off on) #30(on on on on on on on on on on on on on on on on on on on on on off on on off off on on off on) #30(on on on on on on on on on on on on on on on on on on on on on on off on on on on off on) #30(on on on on on on on on on on on on on on on on on on on on on on on off on on off on) #30(on on on on on on on on on on on on on on on on on on on on on on on on off off on)))) (make-problem "19990920-BBA (11)" (quote ((6) (3 2 1 2) (1 1 1 4 4) (3 1 1 1 2 3) (8 2 2 1 4) (11 8 2) (1 1 1 6 9 1) (1 24) (1 2 12 4 3) (4 1 1 1 1 1 3 7 1) (1 5 3 5 4 1 2) (3 5 2 4 7 1) (3 1 5 1 1 4 2 1) (1 4 3 4 5 7) (1 1 3 4 1 3 2 3 1) (4 1 6 4 9) (7 1 2 2 4 3) (3 4 2 2 2 1 3 2) (3 1 1 1 2 2 1 8) (2 3 3 4 1 3 1 1) (3 2 2 1 2 2 1 4) (2 1 3 3 2 4 2) (1 1 3 3 2 1 1 1) (1 1 1 1 1 3 1) (1 3 1 1) (2 6) (5 6) (3 5 2 1 1) (1 3 1 1 2 4) (2 3 3 4 1))) (quote ((4) (4 2 1) (2 6 6) (1 3 1 4 2) (2 3 3 5 1) (1 2 2 5 1 1) (4 4 1 1 3 1 1) (1 2 1 4 3 4 2) (1 7 5 3 2 1) (5 2 8 3 1 1) (1 8 1 2 4 1 1) (1 1 5 2 4 1 2) (2 6 1 1 6 4) (3 6 1 3 8) (1 2 4 2 3 4 2) (3 1 6 14) (1 1 2 2 4 4 2 1 1) (1 1 7 3 7 2) (2 7 3 7 3 1) (8 2 2 5) (2 3 1 1 2 2 2) (1 9 6 1 2 1) (1 8 2 5 1 1) (11 1 3 1 1 3) (2 10 2 4 1) (4 1 1 6 1 1 1) (2 1 8 5 1) (4 2 4 2 2 1) (2 2 3 3) (3 2))) (quote #30(#30(off off off off off off off off off off off off on on on on off) #30(off off off off off off off off off on on on on off off on on off off on off) #30(off off off off off off off off on on off on on on on on on off on on on on on on off) #30(off off off off off off off on off on on on off on off on on on on off on on off) #30(off off off off off on on off on on on off on on on off on on on on on off on off) #30(off off off off off on off on on off on on off on on on on on off on off on off) #30(off off off off on on on on off on on on on off on off on off on on on off on off off off off off off on) #30(off off on off on on off on off off on on on on off on on on off off on on on on off off off off on) #30(off on off on on on on on on on off on on on on on off on on on off on on off off off off on off) #30(off on on on on on off on on off on on on on on on on on off on on on off off off off off on off on) #30(off on off on on on on on on on on off on off on on off on on on on off off off off off off on off on) #30(on off on off on on on on on off on on off on on on on off off off off off off off off off on off on) #30(on on off on on on on on on off off on off on off on on on on on on off off off off on on on on off) #30(on on on off on on on on on on off off off on off off off on on on off on on on on on on on on off) #30(on off on on off on on on on off on on off on on on off off off on on on on off off off on on off) #30(on on on off on off on on on on on on off off off on on on on on on on on on on on on on on off) #30(on off on off on on off on on off on on on on off on on on on off off off off off on on off on off on) #30(off on off on off on on on on on on on off on on on off off off off on on on on on on on off on) #30(off on on off on on on on on on on off on on on off on on on on on on on off off on on on off on) #30(off off on on on on on on on on off off off on on off on on off off off off off off on on on on on off) #30(off off on on off on on on off off off on off on off on on off off off off off off off off on on off on) #30(off off on off on on on on on on on on on off on on on on on on off on off off off off on on off on) #30(off off off on off on on on on on on on on off on on off off on on on on on off off off on off off on) #30(off off off on on on on on on on on on on on off on off on on on off on off on off off off on) #30(off off off on on off on on on on on on on on on on off on on off on on on on off off off off on off) #30(off off off off on on on on off on off on off on on on on on on off on off off on off off off off on off) #30(off off off off on on off on off on on on on on on on on off on on on on on off off off off off on off) #30(off off off off off off on on on on off off on on off on on on on off on on off on on off off off off on) #30(off off off off off off off on on off on on off on on on off on on on off) #30(off off off off off off off off on on on off on on off)))) (make-problem "19991002bTPV (12)" (quote ((30) () (2 1) (3 2) (3 3) (1 2 4) (1 1 5) (30) (1 2 4 1) (1 1 4 1) (1 3 1) (1 2 1) (1 1 1) (1 1 1) (30) (1 1 1) (5 1 5) (6 1 1 6) (6 1 6) (4 1 1 4) (1 1 1) (30) (4 1) (4 5) (2 1 6) (1 2 6) (4 4) (4) (30) (1 1))) (quote ((1 1 1 1 1) (1 1 1 2 1 1) (1 1 1 4 1 1) (1 1 1 4 1 1) (1 1 1 4 1 1) (1 1 1 4 1 1) (1 17 1 1) (1 3 1 1 1 1) (1 3 1 1 1 1 1) (1 4 1 1 1) (1 3 1 1 2 2) (1 1 1 10) (1 1 1 3 3) (1 1 1 11) (1 1 1 2 2 1) (1 1 1 1 1) (1 1 1 1 2 1) (1 1 1 1 4 1) (1 1 1 1 4 1) (1 1 1 1 4 1) (1 1 1 1 4 1) (1 1 17 1) (1 5 1 1 1) (1 4 1 2 1 1) (1 4 1 4 1 1) (1 4 1 4 1 1) (1 4 1 4 1 1) (1 5 1 4 1 1) (1 17 1 1) (1 1 1 1 1))) (quote #30(#30(on off off off off off off on off off off off off off on off off off off off off on off off off off off off on off) #30(on off off off off off off on off off off off off off on off off on on off off on off off off off off off on off) #30(on off off off off off off on off off off off off off on off on on on on off on off off off off off off on off) #30(on off off off off off off on off off off off off off on off on on on on off on off off off off off off on off) #30(on off off off off off off on off off off off off off on off on on on on off on off off off off off off on off) #30(on off off off off off off on off off off off off off on off on on on on off on off off off off off off on off) #30(on off on on on on on on on on on on on on on on on on on off off on off off off off off off on off) #30(on off on on on off off on off off off off off off on off off off off off off on off off off off off off on off) #30(on off off on on on off on off off off off off off on off off on off off off on off off off off off off on off) #30(on off off off off on on on on off off off off off on off off off off off off on off off off off off off on off) #30(on off off off off off off on on on off off off off on off off off off off off on off on on off off on on off) #30(on off off off off off off on off off off off off off on off off off off off on) #30(on off off off off off off on off off off off off off on off off off off off off on on on off off on on on off) #30(on off off off off off off on off off off off off off on off off off off on) #30(on off off off off off off on off off off off off off on off off off off off off on on off off on on off on off) #30(on off off off off off off on off off off off off off on off off off off off off on off off off off off off on off) #30(on off off off off off off on off off off off off off on off off off off off off on off off on on off off on off) #30(on off off off off off off on off off off off off off on off off off off off off on off on on on on off on off) #30(on off off off off off off on off off off off off off on off off off off off off on off on on on on off on off) #30(on off off off off off off on off off off off off off on off off off off off off on off on on on on off on off) #30(on off off off off off off on off off off off off off on off off off off off off on off on on on on off on off) #30(on off off off off off off on off on on on on on on on on on on on on on on on on on off off on off) #30(on off off off off off off on on on on on off off on off off off off off off on off off off off off off on off) #30(on off off off off off off on on on on off off off on off off on on off off on off off off off off off on off) #30(on off off off off off on on on on off off off off on off on on on on off on off off off off off off on off) #30(on off off off off on on on on off off off off off on off on on on on off on off off off off off off on off) #30(on off off off on on on on off off off off off off on off on on on on off on off off off off off off on off) #30(on off off on on on on on off off off off off off on off on on on on off on off off off off off off on off) #30(on off on on on on on on on on on on on on on on on on on off off on off off off off off off on off) #30(on off off off off off off on off off off off off off on off off off off off off on off off off off off off on off)))) (make-problem "19991012-LSA (13)" (quote ((16 13) (4 4 5 4 3 1) (2 1 2 5 2 2 1) (4 2 2 3 1 3 3) (5 1 3 3 2 4 3) (1 2 1 1 2 2 2 3) (2 2 1 2 2 1 2 3) (3 1 2 2 2 1 2 4) (1 2 2 2 1 2 1 2 5) (2 1 1 2 1 2 2 1 1 1) (3 2 2 2 2 1 1 1) (4 1 1 1 1 1 1 3) (5 2 3 1 2 1 2 4) (1 2 2 2 1 1 1 5) (3 1 1 1 1 2 2 2 1) (7 3 1 1 2 1 4) (7 2 1 2 1 1 1) (3 2 1 1 1 2 3 1 1) (1 1 1) (1 1 22 1 1) (3 1 1 3) (2 2 1 1 1 3 1 1 3 1 3) (2 2 1 1 1 1 1 1 1 1 1 1 2) (2 2 1 3 1 1 3 1 1 5) (2 2 5) (6 6) (7 7) (8 8) (9 9) (10 10))) (quote ((30) (5 2 4 4 10) (2 2 2 3 4 2 5) (2 3 1 2 2 9) (1 3 1 1 2 11) (3 3 1 1 2 1 5) (2 1 1 2 1 3 1 1 1 4) (2 3 1 1 1 1 1 1 3) (2 2 2 1 1 1 1 2) (1 2 3 4 1 2 1) (1 3 3 2 1 1 1) (1 3 3 1 1 1) (2 1 2 2 1 1 1) (3 3 4 1 2) (4 1 1 1) (5 12 1 1) (10 1 1 1) (1 1 2 1 4 1 2) (1 8 1 1 1) (3 7 1 1) (6 1 1 1 1 1 1) (2 1 7 1 2 2) (2 1 4 1 1 1 3) (1 5 1 1 1 1 1 4) (1 5 3 1 1 1 5) (5 2 1 1 11) (2 2 2 2 7) (2 6 4 1 5 7) (1 6 3 1 10) (10 19))) (quote #30(#30(on) #30(on on on on on off on on off on on on on off on on on on off off on) #30(on on off on on off off on on off on on on off on on on on off on on off off off off on) #30(on on off on on on off off on off off on on off off on on off off off off on) #30(on off off off on on on off off on off off on off off on on off off on) #30(on on on off off off on on on off on off off on off on on off off on off off off off off on) #30(on on off on off off off off on off on on off on off on on on off on off on off on off off on) #30(on on off on on on off off off on off off on off on off off on off on off off on off off off off on) #30(on on off off off off on on off off off off on on off on off off off on off on off on off off off off on) #30(on off on on off off off on on on off off off on on on on off off on off off on on off off off off off on) #30(on off on on on off off off on on on off off off off on on off off on off on off on off) #30(on off off off on on on off off off on on on off off off off on off on off off on off) #30(on on off off on off on on off off off off on on off off off off off on off on off on off) #30(on on on off off off off on on on off off on on on on off off off on off on on off) #30(on on on on off off off off off off off off off off off off off off off on off on off on off) #30(on on on on on off on on on on on on on on on on on on off on off off on off) #30(off on on on on on on on on on on off off off off off off off off on off on off on off) #30(on off on off on on off off off off off off on off on on on on off on off off on on off) #30(on off off off off off off off off on on on on on on on on off off on off on off on off) #30(on on on off on on on on on on on off off off off off off off off on off off on off) #30(on on on on on on off off off off off off off off on off off on off on off on off on off off off off off on) #30(on on off off off off off off on off off on on on on on on on off on off on on off off off off off on) #30(on on off off on off off on on on on off off off off off off off off on off on off on off off off on) #30(on off off on on on on on off off off off on off on off off on off on off off on off off off on) #30(on off on on on on on off off off on on on off on off off on off on off off off off off on) #30(on on on on on off off off on on off off off on off off off on off on) #30(on on off off off off off on on off off off on on off on on off off off off off off on) #30(on on off on on on on on on off on on on on off on off on on on on on off on) #30(on off off on on on on on on off off on on on off on off off off off on) #30(on on on on on on on on on on off on)))) (make-problem "19991028-BDH (14)" (quote ((7 7) (9 9) (11 11) (12 12) (12 12) (12 12) (12 12) (12 12) (30) (28) (8 4 8) (5 1 2 1 5) (2 3 3 2) (3 3 3 3) (2 3 3 2) (2 3 3 2) (3 3 3 3) (3 1 1 3) (2 2) (2 2) (2 4 2) (2 6 2) (2 4 2) (1 1) (1 1 1 1) (2 14 2) (2 10 2) (3 4 3) (3 3) (10))) (quote ((7) (9) (11) (12 7) (12 13) (18 2) (14 2) (12 1) (11 2 2) (10 5 1 1) (8 7 2 2) (7 5 2 1) (2 1 2 1) (3 3 3 1) (4 3 3 1) (4 3 3 1) (3 3 3 1) (2 1 2 1) (7 5 2 1) (8 7 2 2) (10 5 1 1) (11 2 2) (12 1) (14 2) (18 2) (12 13) (12 7) (11) (9) (7))) (quote #30(#30(off off on on on on on on on off) #30(off on on on on on on on on on off) #30(on on on on on on on on on on on off) #30(on on on on on on on on on on on on off off off off on on on on on on on off) #30(on on on on on on on on on on on on off on on on on on on on on on on on on on off) #30(on on on on on on on on on on on on on on on on on on off off off off off off off on on off) #30(on on on on on on on on on on on on on on off off off off off off off off off off off off on on off) #30(on on on on on on on on on on on on off off off off off off off off off off off off off off off on off) #30(on on on on on on on on on on on off off off off off off off off off off off off off on on off on on off) #30(off on on on on on on on on on on off on on on on on off off off off off off off off on off off on off) #30(off off on on on on on on on on off on on on on on on on off off off off off off off on on off on) #30(off off off on on on on on on on off off on on on on on off off off off off off off off on on off off on) #30(off off off off off off off off on on off off off off off off off off off off off on off off off on on off off on) #30(off off off off off off off off on on on off off off off off off off off off on on on off off on on on off on) #30(off off off off off off off off on on on on off off off off off off off off on on on off off on on on off on) #30(off off off off off off off off on on on on off off off off off off off off on on on off off on on on off on) #30(off off off off off off off off on on on off off off off off off off off off on on on off off on on on off on) #30(off off off off off off off off on on off off off off off off off off off off off on off off off on on off off on) #30(off off off on on on on on on on off off on on on on on off off off off off off off off on on off off on) #30(off off on on on on on on on on off on on on on on on on off off off off off off off on on off on) #30(off on on on on on on on on on on off on on on on on off off off off off off off off on off off on off) #30(on on on on on on on on on on on off off off off off off off off off off off off off on on off on on off) #30(on on on on on on on on on on on on off off off off off off off off off off off off off off off on off) #30(on on on on on on on on on on on on on on off off off off off off off off off off off off on on off) #30(on on on on on on on on on on on on on on on on on on off off off off off off off on on off) #30(on on on on on on on on on on on on off on on on on on on on on on on on on on off) #30(on on on on on on on on on on on on off off off off on on on on on on on off) #30(on on on on on on on on on on on off) #30(off on on on on on on on on on off) #30(off off on on on on on on on off)))) (make-problem "19991101-SHE (15)" (quote ((4) (2 2) (1 2) (2 1 3) (2 3) (2 1 3) (3 3) (3 4) (5 4) (1 7) (2 7) (2 8) (2 4) (1 2 2 2) (1 2 3 4) (3 3 4 7) (3 4 4 2) (8 7 1) (6 11 1) (5 8 3) (5 8) (17) (17) (16) (15) (14) (13) (11) (9) (5))) (quote (() (3) (3) (5) (5) (7) (9) (11) (1 4 8) (5 8) (3 8) (9) (9) (9) (3 11) (4 8 13) (8 16) (2 3 15) (1 1 3 13) (1 1 3 11) (2 1 4 8) (14 6) (14 1) (9 2 1) (5 2 1) (2 1 1) (1 1 1) (1 2 1) (5) ())) (quote #30(#30(off) #30(off off off off off off off off off off off off off on on on off) #30(off off off off off off off off off off off off off off off on on on off) #30(off off off off off off off off off off off off off off off on on on on on off) #30(off off off off off off off off off off off off off off off off on on on on on off) #30(off off off off off off off off off off off off off off off off off on on on on on on on off) #30(off off off off off off off off off off off off off off off off off on on on on on on on on on off) #30(off off off off off off off off off off off off off off off off on on on on on on on on on on on off) #30(off off off off off off off off off off off off off on off on on on on off on on on on on on on on off) #30(off off off off off off off off off off off off off on on on on on off off off on on on on on on on on off) #30(off off off off off off off off off off off off off off on on on off off off off on on on on on on on on off) #30(off off off off off off off off off off off off off off off off off off off off off on) #30(off off off off off off off off off off off off off off off off off off off off off on) #30(off off off off off off off off off off off off off off off off off off off off off on) #30(off off off off off off off off off off on on on off off off off off off on) #30(off off off on on on on off on on on on on on on on off on) #30(off on on on on on on on on off off off off on on on on on on on on on on on on on on on on off) #30(on on off off off off on on on off off off off off on on on on on on on on on on on on on on on off) #30(on off off on off off off on on on off off off off off on on on on on on on on on on on on on off) #30(on off off off off on off off on on on off off off off off on on on on on on on on on on on off) #30(on on off on off off off off off on on on on off off off off on on on on on on on on off) #30(off on on on on on on on on on on on on on on off off on on on on on on off) #30(off off on on on on on on on on on on on on on on off off on off) #30(off off off off on on on on on on on on on off on on off off on off) #30(off off off off off off off on on on on on off off on on off off on off) #30(off off off off off off off off off off on on off off off on off off on off) #30(off off off off off off off off off off off on off off off on off off off on off) #30(off off off off off off off off off off off on off off off on on off off on off) #30(off off off off off off off off off off off off off off off on on on on on off) #30(off)))) (make-problem "19991105bBDH (16)" (quote ((1) (1 1) (1 1) (1 1 1) (1 1 2) (2 3) (1 1 1) (2 1) (4 1) (1 1) (1 1) (1 1) (1 1) (1 1) (1 1) (1 1) (1 1) (1 1) (1 1) (1 1) (1 1 4) (1 1 1 1) (1 1 1 1) (4 1 1 1 1) (6 1 1 5) (7 1 1 4) (4 1 1 6) (17) (16) (14))) (quote ((2) (2) (3) (3) (2) (3) (3) (4) (5) (3) (22) (1 3) (3 1 3) (1 1 1 3) (1 4 3) (3 1 3) (1 3) (1 3) (2 3) (27) (3) (4) (3) (2) (2) (6) (1 3) (1 1) (1 1) (5))) (quote #30(#30(off off off off off off off off off off off off off off off off off off off off off off off on on off) #30(off off off off off off off off off off off off off off off off off off off off off off off on on off) #30(off off off off off off off off off off off off off off off off off off off off off off off on on on off) #30(off off off off off off off off off off off off off off off off off off off off off off off on on on off) #30(off off off off off off off off off off off off off off off off off off off off off off off off on on off) #30(off off off off off off off off off off off off off off off off off off off off off off off off on on on off) #30(off off off off off off off off off off off off off off off off off off off off off off off off off on on on off) #30(off off off off off off off off off off off off off off off off off off off off off off off off off on on on on off) #30(off off off off off off off off off off off off off off off off off off off off off off off off off on) #30(off off off off off off off off off off off off off off off off off off off off off off off off off off off on) #30(off off off off off off off off on) #30(off off off off off off off off on off off off off off off off off off off off off off off off off off off on) #30(off off on on on off off off on off off off off off off off off off off off off off off off off off off on) #30(off on off off off on off off on off off off off off off off off off off off off off off off off off off on) #30(on off off off on on on on off off off off off off off off off off off off off off off off off off off on) #30(off on on on off off off on off off off off off off off off off off off off off off off off off off off on) #30(off off off off off off on off off off off off off off off off off off off off off off off off off off off on) #30(off off off off off on off off off off off off off off off off off off off off off off off off off off off on) #30(off off off off on on off off off off off off off off off off off off off off off off off off off off off on) #30(off off off on) #30(off off off off off off off off off off off off off off off off off off off off off off off off off off off on) #30(off off off off off off off off off off off off off off off off off off off off off off off off off off on) #30(off off off off off off off off off off off off off off off off off off off off off off off off off off on on on off) #30(off off off off off off off off off off off off off off off off off off off off off off off off off on on off) #30(off off off off off off off off off off off off off off off off off off off off off off off off off on on off) #30(off off off off off off off off off off off off off off off off off off off off off on on on on on on off) #30(off off off off off off off off off off off off off off off off off off off off on off off off on on on off) #30(off off off off off off off off off off off off off off off off off off off off on off off off on off) #30(off off off off off off off off off off off off off off off off off off off off on off off off on off) #30(off off off off off off off off off off off off off off off off off off off off on on on on on off)))) (make-problem "19991113aBAR (17)" (quote ((11) (15) (18) (20) (22) (24) (25) (27) (24 2) (5 4 1) (2 2 1) (1 5 5 1 1) (6 2 2 5 2) (4 6 7) (2 18 2) (2 3 3 2) (8 3 3 6) (6 7 8) (4 3 2 2 4 4) (3 5 6 2) (2 3 4 3 2) (2 13 1) (2 4 4 1) (2 1) (2 1 2) (3 2 3) (4 1 1 3 1 3) (6 1 1 2 4) (11 2 2 11) (30))) (quote ((12) (3 13) (3 8 5) (3 7 4) (5 2 2 3) (6 3 3 5) (7 2 1 4 2 2) (7 1 3 3 2) (8 1 3 3 2) (8 1 3 3 4) (9 2 1 2 2 2) (9 3 2 2 1) (9 2 1 2 1) (9 2 2 3 2) (9 2 2 2 2) (9 2 2 2 1 1) (9 3 1 3 1 2) (9 2 1 2 2 4) (9 1 3 2 2 1) (9 1 3 4 2) (9 1 3 3 2) (9 2 1 4 2) (9 3 4 2) (8 2 4 3) (9 7 4) (6 8 2) (4 1 3 3) (3 1 3 5) (3 2 4 6) (6 12))) (quote #30(#30(off off off off off off off off off off off off off off off off off off on) #30(off off off off off off off off off off on on on off off off off on) #30(off off off off off off off off on on on off on on on on on on on on off off off off off on) #30(off off off off off off off on on on off off on on on on on on on off off off off off off off on) #30(off off off off off on on on on on off off on on off off on on off off off off off off off off off on) #30(off off off off on on on on on on off off on on on off on on on off off off off off off on) #30(off off off on on on on on on on off on on off on off on on on on off off off off on on off off on) #30(off off on on on on on on on off off on off off on on on off on on on off off off off off off off on) #30(off on on on on on on on on off off on off off on on on off off on on on off off off off off off on) #30(off on on on on on on on on off off on off off on on on off off on on on off off off off on) #30(on on on on on on on on on off off on on off on off off off on on off on on off off off off off on) #30(on on on on on on on on on off off off on on on off off on on off off on on off off off off off off on) #30(on on on on on on on on on off off off off on on off off on off off off on on off off off off off off on) #30(on on on on on on on on on off off off off on on off on on off off on on on off off off off off on) #30(on on on on on on on on on off off off off on on off on on off off on on off off off off off off on) #30(on on on on on on on on on off off off off on on off on on off off on on off off off off on off off on) #30(on on on on on on on on on off off off on on on off off on off off on on on off off off on off on) #30(on on on on on on on on on off off on on off on off off on on off off on on off off off on) #30(on on on on on on on on on off off on off off on on on off on on off on on off off off off off off on) #30(on on on on on on on on on off off on off off on on on off off on on on on off off off off off on) #30(on on on on on on on on on off off on off off on on on off off on on on off off off off off off on) #30(off on on on on on on on on on off on on off on off off on on on on off off off off off off off on) #30(off on on on on on on on on on off off on on on off on on on on off off off off off off off off on) #30(off off on on on on on on on on off off on on off off on on on on off off off off off off off on) #30(off off on on on on on on on on on off on on on on on on on off off off off off off off on) #30(off off off on on on on on on off on on on on on on on on off off off off off off off off off off on) #30(off off off off on on on on off off off off off on off off on on on off off off off off off off off on) #30(off off off off off on on on off off off off off on off off on on on off off off off off off on) #30(off off off off off off on on on off off off on on off off off on on on on off off off on) #30(off off off off off off off on on on on on on off off off off off on)))) (make-problem "19991113eBAR (18)" (quote ((6) (1 8) (11 1) (12) (1 6) (2 1 7 1) (1 2 7) (5 10) (6 9) (4 8) (7 8) (5 8) (2 10) (2 2 9) (1 3 13) (1 2 3 8) (6 4 3 5) (1 1 1 4 3) (6 9) (7 8) (8 8) (8 8) (8 5 2) (8 6 1) (18) (17) (16) (14) (12) (10))) (quote ((4) (2 1 1 1) (2 2 2 1 1) (2 4 2 1 1) (11 2 1) (4 7 7) (4 1 5 1 7) (4 3 1 9) (6 1 10) (6 3 17) (17 12) (16 11) (13 1 10) (12 7) (2 11 6) (11 6) (13 6) (2 7 6) (1 1 2 6) (2 7) (3 6) (4 6) (11) (10) (8) (5) (5) (5) (6) (6))) (quote #30(#30(off off off off off off off off off off off off off on on on on off) #30(off off off off off off on on off off on off off on off off on off) #30(off on on off off off off on on off on on off off on off on off) #30(off off on on off on on on on off on on off off on off on off) #30(off on on on on on on on on on on on off on on off on off) #30(on on on on off off off on on on on on on on off off on on on on on on on off) #30(on on on on off on off off on on on on on off off on off off on on on on on on on off) #30(on on on on off off off off on on on off off off off on off off on on on on on on on on on off) #30(on on on on on on off off off off off off off off on off off off on on on on on on on on on on off) #30(on on on on on on off on on on off off on on on on on on on on on on on on on on on on on off) #30(on on on on on on on on on on on on on on on on on off on) #30(off on on on on on on on on on on on on on on on on off off on) #30(off off on on on on on on on on on on on on on off on off off off on) #30(off off off on on on on on on on on on on on on off off off off off off off off on) #30(off off on on off on on on on on on on on on on on off off off off off off off off on) #30(off off off off off off on on on on on on on on on on on off off off off off off off on) #30(off off off off off on on on on on on on on on on on on on off off off off off off on) #30(off off off off off off off on on off on on on on on on on off off off off off off off on) #30(off off off off off off off on off off off off on off on on off off off off off off off off on) #30(off off off off off off off off off off off off off off on on off off off off off off off on) #30(off off off off off off off off off off off off off off on on on off off off off off off on on on on on on off) #30(off off off off off off off off off off off off off off off on on on on off off off on on on on on on off) #30(off off off off off off off off off off off off off off off off on on on on on on on on on on on off) #30(off off off off off off off off off off off off off off off off on on on on on on on on on on off) #30(off off off off off off off off off off off off off off off off on on on on on on on on off) #30(off off off off off off off off off off off off off off off off off off on on on on on off) #30(off off off off off off off off off off off off off off off off off on on on on on off) #30(off off off off off off off off off off off off off off off off off on on on on on off) #30(off off off off off off off off off off off off off off off off off on on on on on on off) #30(off off off off off off off off off off off off off off off off off off on on on on on on off)))) (make-problem "19991115aBAR (19)" (quote ((3 11) (3 9) (4 8) (5 6) (6 5) (12 4) (6 3) (8 3) (1 7 2) (8 2) (3 2 2) (2 4 1) (7 1) (10 1) (11 1) (3 4 4 1) (9 4 4) (10 4 1) (9 3 1) (13 1) (13 1) (13 1) (13 2) (8 3 2) (7 4 2) (4 2 1 2 3) (6 3 3) (6 4 4) (5 1 2 5) (4 6))) (quote ((3) (4) (4) (4) (3) (2) (2) (1) (1 2 1 2) (1 1 3 2 5) (6 4 5 6) (11 13) (9 4 9) (27) (25) (6 13 3) (4 12 2) (1 1 3 7) (1 2 6) (1 1 3 6) (1 2 7) (2 2 6) (3 2 3 3) (3 3 2) (4 3 1) (5 1 2) (6 2 3) (8 1 5) (11 1 8) (30))) (quote #30(#30(off off off off off off off off off off off off off off off off off off off off off off off off off off off on) #30(off off off off off off off off off off off off off off off off off off off off off off off off off off on) #30(off off off off off off off off off off off off off off off off off off off off off off off off off off on) #30(off off off off off off off off off off off off off off off off off off off off off off off off off off on) #30(off off off off off off off off off off off off off off off off off off off off off off off off off off on on on off) #30(off off off off off off off off off off off off off off off off off off off off off off off off off off on on off) #30(off off off off off off off off off off off off off off off off off off off off off off off off off on on off) #30(off off off off off off off off off off off off off off off off off off off off off off off off off on off) #30(off off off off off on off off on on off on off off off off off off off off off off off off on on off) #30(on off off off off on off off off on on on off off off on on off off off off on on on on on off) #30(on on on on on on off on on on on off off on on on on on off on on on on on on off) #30(on on on on on on on on on on on off on on on on on on on on on on on on on off) #30(off on on on on on on on on on off on on on on off on on on on on on on on on off) #30(off off on on on on on on on on on on on on on on on on on on on on on on on on on on on off) #30(off off off on on on on on on on on on on on on on on on on on on on on on on on on on off) #30(off off off off on on on on on on off on on on on on on on on on on on on on off off on on on off) #30(off off off off off on on on on off off off on on on on on on on on on on on on off off off on on off) #30(off off off off off on off on off off off off on on on off on on on on on on on off) #30(off off off off off on off off off off off off off on on off off on on on on on on off) #30(on off off off off on off off off off off off off on on on off on on on on on on off) #30(on off off off off off off off off off off off off off on on off off off on on on on on on on off) #30(on on off off off off off off off off off off off off off on on off off on on on on on on off) #30(on on on off off off off off off off off off off off off on on off on on on off off on on on off) #30(on on on off off off off off off off off off off off off off on on on off off off off off on on off) #30(on on on on off off off off off off off off off off off off on on on off off off off off off off off off off on) #30(on on on on on off off off off off off off off off off off off on off off off off off off off off off off on) #30(on on on on on on off off off off off off off off off off on on off off off off off off off off off on) #30(on on on on on on on on off off off off off off off off on off off off off off off off off on) #30(on on on on on on on on on on on off off off off off on off off off off off on) #30(on)))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/solution-sets/k30x35 b/collects/games/paint-by-numbers/solution-sets/k30x35
new file mode 100644
index 0000000000..a29a1f955d
--- /dev/null
+++ b/collects/games/paint-by-numbers/solution-sets/k30x35
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 30x35") (define problems (list (make-problem "19990507aJOJ (1)" (quote ((6 2 1 3 1 2 1 1 4) (5 1 1 1 4 1 1 1 1 3) (5 1 1 1 1 1 1 1 1 1) (4 1 1 1 1 1 2 1 1 1 3) (2 1 1 3 2 2 3 3 1) (1 2 18 2) (1 23) (2 21 2) (1 25) (3 22 2) (3 11 8 3) (2 10 7 2) (2 5 6 1) (1 5 2 2 5) (3 1 1 1 1 2) (2 1 1 1 1 1 1 1 1 1) (2 1 1 1 2 1 1 1 1) (2 1 2 4 2 1 1) (2 1 6 1 2) (1 3 6 3) (2 2 6 2 1) (3 2 2 4 2 2 1) (3 2 3 3 2 1) (4 2 5 5 2 2) (4 2 12 2 3) (3 4 6 3 3) (1 7 5 2) (3 4 3 2 1) (29) (1 8 2) (12 10) () (30) () (30))) (quote ((7 6 3 8 3 1 1) (5 1 4 5 6 2 1 1 1) (4 1 1 2 2 2 5 2 1 1 1) (4 1 1 4 2 2 3 1 1 1) (3 1 1 6 3 4 2 1 1 1 1) (1 1 8 1 6 1 1 1 1) (1 1 8 4 1 1 1 1) (1 1 8 1 2 1 1 1 1) (2 1 7 2 3 1 1 1) (1 8 2 3 1 1 1) (2 9 2 3 2 1 1 1) (1 8 1 1 2 2 1 1 1) (2 1 7 1 1 1 2 2 1 1) (2 7 1 1 3 3 2 1 1) (2 8 2 5 2 2 1 1) (2 5 6 2 2 1 1) (1 7 6 2 2 1 1) (9 2 5 2 2 1 1) (1 6 1 1 3 3 2 1 1) (1 8 1 1 1 2 2 1 1) (2 8 1 1 2 2 1 1 1) (1 9 2 3 2 1 1 1) (1 8 2 3 1 1 1) (1 10 2 2 1 1 1 1) (1 1 10 1 3 1 1 1 1) (1 1 8 1 4 1 1 1 1) (1 1 1 1 3 3 5 3 1 1 1) (2 1 1 1 1 3 4 2 2 1 1 1) (2 1 1 1 3 2 2 4 3 1 1) (3 1 1 4 4 8 2 1 1))) (quote #30(#35(on on on on on on on off on on on on on on off on on on off on on on on on on on on off on on on off on off on) #35(on on on on on off off on off on on on on off on on on on on off on on on on on on off on on off on off on off on) #35(on on on on off on off on off on on off off on on off off off on on off on on on on on off on on off on off on off on) #35(on on on on off on off off on off off on on on on off off off off on on off off on on off on on on off on off on off on) #35(on on on off on off on off on on on on on on off on on on off on on on on off off on on off on off on off on off on) #35(on off off on off off on on on on on on on on off off off off on off off on on on on on on off on off on off on off on) #35(off on off off on off on on on on on on on on off off off off off off off off off on on on on off on off on off on off on) #35(on off on off off on on on on on on on on off off off off off off off off on off off off on on off on off on off on off on) #35(on on off on off on on on on on on on off off off off off off off off off on on off off off on on on off on off on off on) #35(off off on off on on on on on on on on off off off off off off off off off off on on off off on on on off on off on off on) #35(on on off on on on on on on on on on off off off on on off off off off off on on on off off on on off on off on off on) #35(off off on off on on on on on on on on off off on off off on off off off off off on on off off on on off on off on off on) #35(on on off on off on on on on on on on off on off on off on off off off off off on on off off off on on off off on off on) #35(on on off off on on on on on on on off off on off off on off on on on off off on on on off off on on off off on off on) #35(on on off on on on on on on on on off off off on on off on on on on on off off on on off off on on off off on off on) #35(off on on off off on on on on on off off off off off off on on on on on on off off on on off off on on off off on off on) #35(on off off on on on on on on on off off off off off off on on on on on on off off on on off off on on off off on off on) #35(off on on on on on on on on on off off off off on on off on on on on on off off on on off off on on off off on off on) #35(on off off off off on on on on on on off off on off off on off on on on off off on on on off off on on off off on off on) #35(on off off on on on on on on on on off off on off on off on off off off off off on on off off off on on off off on off on) #35(off on on off on on on on on on on on off off on off off on off off off off off on on off off on on off on off on off on) #35(on off off on on on on on on on on on off off off on on off off off off off on on on off off on on off on off on off on) #35(off off on off off on on on on on on on on off off off off off off off off off on on off off on on on off on off on off on) #35(off on off on on on on on on on on on on off off off off off off off off on on off off on on off on off on off on off on) #35(on off on off on on on on on on on on on on off off off off off off off on off off on on on off on off on off on off on) #35(off on off off on off on on on on on on on on off off off off on off off off off on on on on off on off on off on off on) #35(on off off on off off on off on off off on on on off on on on off on on on on on off off on on on off on off on off on) #35(on on off on off on off off on off on off on on on off off off off on on on on off on on off on on off on off on off on) #35(on on off on off on off on off on on on off on on off off off on on off off off on on on on off on on on off on off on) #35(on on on off on off off on off on on on on off off on on on on off on on on on on on on on off on on off on off on)))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/solution-sets/k30x40 b/collects/games/paint-by-numbers/solution-sets/k30x40
new file mode 100644
index 0000000000..5fc884cd29
--- /dev/null
+++ b/collects/games/paint-by-numbers/solution-sets/k30x40
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 30x40") (define problems (list (make-problem "19980514-KVL (1)" (quote ((14) (14) (16) (18) (20) (1 7 6) (1 3 4 4) (3 9 3) (5 8 2) (1 4 8 2) (1 1 13 1) (1 1 5 1 1) (1 1 2 1) (1 1 1 3 1) (3 1 1 6 1) (5 1 9 1) (1 4 8 2) (1 1 10 2) (1 1 8 3) (1 1 2 4 4) (1 4 6) (3 13) (5 11) (1 4 11) (1 1 15) (1 1 14) (1 1 1 11) (1 1 3 3) (3 4 2) (5 2 2) (1 4 2 2) (1 15) (1 14) (1 1 14) (1 14) (3 13) (5 11) (7 11) (18) (16))) (quote (() () () () () (34) (2 2 2 2 2 4) (3 2 2 2 2 5) (6 5 2 1 5 2 1 4) (6 2 2 2 2 4) (7 2 2 2 2 3) (7 2 4 3 5 5 3) (8 2 1 3 2 5 2) (6 1 2 2 2 2 5 2) (6 12 20) (5 7 5 19) (5 6 5 8 9) (5 5 6 6 1 9) (5 5 7 6 9) (6 4 6 7 9) (6 4 6 7 9) (7 3 4 8 9) (6 2 2 10 9) (7 23) (34) () () () () ())) (quote #f)) (make-problem "19990224aJOJ (2)" (quote ((13 1 1) (14 1) (1 14) (7 1 1 13) (8 3 12) (2 2 1 3 11) (2 2 4 11) (2 2 1 3 11) (2 2 4 11) (2 2 1 3 11) (8 3 12) (7 1 1 13) (1 14) (14 1) (13 1 1 3 2) (12 3 3 2) (11 3 1 4 2) (11 4 5 2) (11 3 1 2 2 2) (11 4 2 5) (11 3 1 2 4) (12 3 2 3) (13 1 1 2 3) (14 1) (1 14) (4 1 1 13) (6 3 12) (2 2 1 3 11) (2 2 4 11) (8 1 3 11) (8 4 11) (2 2 1 3 11) (2 2 3 12) (2 2 1 1 13) (1 14) (14 1) (13 1 1) (12 3) (11 3 1) (11 4))) (quote ((2 11 5) (2 9 11 6 5) (2 9 11 8 5) (2 2 2 11 3 2 5) (2 2 2 11 2 2 5) (2 2 2 11 2 2 5) (2 2 2 11 3 2 5) (2 9 11 8 5) (2 7 11 6 5) (2 11 5) (2 11 5) (2 5 3 3 5 3) (2 1 1 1 1 2 1 1 1 2 1 1 1 1 2 1) (1 2 1 1 2 1 1 1 1 1 2 1 1 2 1 1) (1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1) (1 1 1 1 1 1 2 1 1 2 1 1 1 1 1 2 1) (2 1 1 1 2 1 1 1 1 2 1 1 1 2 1 1) (3 3 5 3 3 2) (11 11) (11 11) (11 9 11) (11 9 11) (11 4 11) (11 4 11) (11 4 11) (11 4 11) (11 9 11) (11 9 11) (11 11))) (quote #30(#40(on on off off off off off off off off off off off on on on on on on on on on on on off off off off off off off off off off off on) #40(on on off on on on on on on on on on off on on on on on on on on on on on off off off off on on on on on on off on) #40(on on off on on on on on on on on on off on on on on on on on on on on on off off on on on on on on on on off on) #40(on on off on on off off off off off on on off on on on on on on on on on on on off on on on off on on off off off off on) #40(on on off on on off off off off off on on off on on on on on on on on on on on off on on off off on on off off off off on) #40(on on off on on off off off off off on on off on on on on on on on on on on on off on on off off on on off off off off on) #40(on on off on on off off off off off on on off on on on on on on on on on on on off on on on off on on off off off off on) #40(on on off on on on on on on on on on off on on on on on on on on on on on off off on on on on on on on on off on) #40(on on off off on on on on on on on off off on on on on on on on on on on on off off off off on on on on on on off on) #40(on on off off off off off off off off off off off on on on on on on on on on on on off off off off off off off off off off off on) #40(on on off off off off off off off off off off off on on on on on on on on on on on off off off off off off off off off off off on) #40(on on off off off on on on on on off off off on on on off off off off off on on on off off off on on on on on off off off on on on off) #40(on on off off on off on off on off on off off on on off on off on off on off on on off off on off on off on off on off off on on off on off) #40(off on off on on off on off on off on on off on off off on off on off on off off on off on on off on off on off on on off on off off on off) #40(on off on off on off on off on off on off on off on off on off on off on off on off on off on off on off on off on off on off on off on off) #40(off on off on off on off on off on off on off on off on off on off on off on off on off on off on off on off on off on off on off on off on) #40(on off on off off on off on off on off off on off on on off on off on off on on off on off off on off on off on off off on off on on off on) #40(off off on on off on off on off on off on on off off on off on off on off on off off on on off on off on off on off on on off off on off on) #40(off off on on on off off off off off on on on off off off on on on on on off off off on on on off off off off off on on on off off off on) #40(off off on on on on on on on on on on on off off off off off off off off off off off on on on on on on on on on on on off) #40(off off on on on on on on on on on on on off off off off off off off off off off off on on on on on on on on on on on off) #40(off off on on on on on on on on on on on off on on on on on on on on on off on on on on on on on on on on on off) #40(off off on on on on on on on on on on on off on on on on on on on on on off on on on on on on on on on on on off) #40(off off on on on on on on on on on on on off on on on on off off off off off off on on on on on on on on on on on off) #40(off off on on on on on on on on on on on off off off on on on on off off off off on on on on on on on on on on on off) #40(off off on on on on on on on on on on on off off off off on on on on off off off on on on on on on on on on on on off) #40(off off on on on on on on on on on on on off off off off off off on on on on off on on on on on on on on on on on off) #40(off off on on on on on on on on on on on off on on on on on on on on on off on on on on on on on on on on on off) #40(off off on on on on on on on on on on on off on on on on on on on on on off on on on on on on on on on on on off) #40(off off on on on on on on on on on on on off off off off off off off off off off off on on on on on on on on on on on off)))) (make-problem "19990507bJOJ (3)" (quote ((2 1 1 2 1 1 1) (2 1 1 1 1 1 1 3) (3 1 1 1 1 2 1 1) (2 11 2) (3 12 2) (2 12 2) (13 2) (1 2 14 2) (2 1 16) (18) (3 9) (2 2) (2 2) (2 2) (2 2) (2 2) (2 8 2) (2 10 2) (2 2) (3 3 3 3) (3 2 1 1 2 3) (2 1 2 2 2 1 2) (2 1 1 2 2 2 1 1 2) (2 1 2 1 1 2 1 2) (2 1 3 2 3 1 2) (2 1 4 1 2) (2 4 2) (2 6 2) (2 6 2) (2 6 2) (2 4 2) (2 2) (2 12 2) (2 3 2 2) (3 7 3) (6 6) (3 6 6 3) (2 1 1 11 1 1 2) (3 1 1 1 3 1 1 1 3) (2 1 1 1 2 2 1 1 1 2))) (quote (() (1) (3 2) (5 2) (1 1 2 2 2 4) (2 1 1 2 3 6 2) (1 2 1 1 4 1 13) (1 1 1 1 5 4) (1 1 1 2 4 6) (2 2 2 6 4 1 2) (1 1 2 4 1 2 2 2 5) (1 8 2 1 2 1 2 2 1) (9 2 1 2 1 3 3 2) (1 7 2 1 1 6 1 1 2) (9 2 2 7 1 1 2) (1 7 2 2 7 1 1 2) (10 2 1 1 6 1 1 2) (8 2 1 2 1 3 1 1 2) (10 2 1 2 1 3 2) (1 9 1 2 2 2 2 1) (1 9 4 1 5) (1 2 1 8 2) (1 1 4 6 6) (1 1 1 3 5 4) (2 1 1 1 1 3 1 13) (1 1 1 1 2 3 6 2) (2 1 2 2 2 4) (1 5 2) (3 2) (1))) (quote #f)) (make-problem "19990525bKHO (4)" (quote ((2) (2) (2) (2) (2) (2) (4) (10) (2 2) (1 4 1) (1 1 1 1) (1 1 4 1 1) (1 1 1 1) (1 1 4 1 1) (1 1 1 1) (1 4 1) (1 1) (12) (1 1) (1 1 2 1 1) (1 2 2 2 1) (1 1) (1 2 2 2 1) (1 2 2 2 1) (1 1) (1 2 2 2 1) (1 2 2 2 1) (1 1) (1 2 2 2 1) (1 2 2 2 1) (1 1) (1 2 2 2 1) (1 1 2 1 1) (1 1) (1 3 1) (1 5 1) (1 5 1) (1 3 1) (2 2) (10))) (quote (() () () () () () () (31) (2 1 2) (1 3 1 1 2 2 2 1 1) (1 1 1 1 2 2 2 2 2 2 1) (1 1 1 1 1 1 4 1) (1 1 1 1 1 1 2 2 2 2 2 4 1) (1 1 1 1 1 1 2 2 2 2 2 4 1) (2 1 1 1 1 1 2 1) (8 1 1 1 2 2 2 2 2 1) (8 3 1 1 2 2 2 1 1) (3 1 2) (31) () () () () () () () () () () ())) (quote #f)) (make-problem "19990611-KVL (5)" (quote (() (9) (13) (11 2) (9 6 1) (6 5) (4 2) (3 2) (3 1) (4 2) (4 1) (5 1) (5 1) (10 2 1) (11 7 3) (12 1 2) (12 5 2) (12 4 2) (13 2 1) (12) (4 2) (5 3) (5 3) (6 7) (13) (12) (11) (10) (13 1) (10) (10) (10) (7) (6) (7) (10 2) (14 2) (16 2) (15 3) (15 4))) (quote ((1) (7 3) (18 3) (20 4) (25 4) (16 12 5) (4 9 17) (5 7 16) (4 7 16) (5 7 17) (4 7 19) (4 27) (4 18 6) (4 4 3 5 5) (3 1 1 2 5) (4 1 1 1 3) (4 1 2 1 2) (2 1 6) (1 1 2 3 1) (1 2 1 2) (3 1 1) (1 1 1) (2) (2) (2) (3 1 1) (10 5) (4 4) (2) (1))) (quote #30(#40(off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off on) #40(off off off off off off off off off off off off off off off off off off on on on on on on on off off off off off off off off off off off off on) #40(off off off off off off off off off on on on on on on on on on on on on on on on on on on off off off off off off off off off off on) #40(off off off off off off off on on on on on on on on on on on on on on on on on on on on off off off off off off off off off on) #40(off off off off off on on on on on on on on on on on on on on on on on on on on on on on on on off off off off off off on) #40(off off off off on on on on on on on on on on on on on on on on off on on on on on on on on on on on on off off on) #40(off off off on on on on off off off off on on on on on on on on on off off off on) #40(off off on on on on on off off off off off off on on on on on on on off off off off on) #40(off off on on on on off off off off off off off on on on on on on on off off off off on) #40(off on on on on on off off off off off off off on on on on on on on off off off on) #40(off on on on on off off off off off off off off on on on on on on on off on) #40(off on on on on off off off off off off off off on) #40(off on on on on off off off off off off off off off on on on on on on on on on on on on on on on on on on off off on) #40(off on on on on off off off off off off off off off off on on on on off off off off on on on off on on on on on off off off on) #40(off on on on off off off off off off off off off off off off off off off off off off off on off off off off on off on on off off off on) #40(off on on on on off off off off off off off off off on off off off off off off off off on off off off off on off off off off off off off on on on off) #40(off on on on on off off off off off off off off off on off on on off off off off off off off off off off on off off off off off off off on on off) #40(off on on off on off off off off off off off off on on on on on on off) #40(off off on off on off off off off off off off off on on off on on on off off off off off off off off off on off) #40(off off on off on on off off off off off off off off on off on on off) #40(off off off on on on off off off off off off off off on off on off) #40(off off off on off on off off off off off off off off on off) #40(off off off off on on off) #40(off off off off off on on off) #40(off off off off off off on on off) #40(off off off off off off off on on on off off off off on off off off off off off off off off off off off off off off off off off off off on off) #40(off off off off off off off off off on on on on on on on on on on off off off off off off off off off off off off off off off off on) #40(off off off off off off off off off off off off off off on on on on off off off off off off off off off off off off off off off off off off on) #40(off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off on) #40(off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off on)))) (make-problem "19990612-ARE (6)" (quote ((9) (3 3) (4 5) (20 5) (23 1) (2 19 5) (18 1) (1 17 5) (1 15) (1 13 5) (1 5 10 1 1) (5 9 5) (4 7 1 1) (4 11 1 1) (4 1 10) (4 12 3) (3 1 4 6 1) (2 1 4 6 1) (1 6 1) (1 1 5 3) (1 1 7) (1 5 1) (2 7 1) (1 3 4 1) (6 1) (6 5) (2 4) (2 4 5) (2 4 1 1) (9 1 1) (8 1 1) (6 5) (6) (8 5) (10 1 1) (10 5) (10 1 1) (9 1 1) (6 1) (2 1))) (quote ((1) (3 2) (4 9 1 2 1) (3 6 3) (4 8) (5 7 1) (1 4 2 2) (1 5 1 2) (1 6 1 1 1 2) (1 8 1 1 1 2 6) (1 8 5 2 7) (1 9 5 1 3 6) (1 10 5 2 1 11) (1 10 4 1 10) (1 13 1 1 2 11) (1 16 1 1 14) (1 36) (1 26 6) (1 25 3) (23) (10 8) (6) (5) (3) () (3 1 5 5 5 5) (1 1 1 1 1 1 1 1 1 1 1 1) (1 1 1 1 1 5 1 1 1 1 1) (1 1 1 1 1 1 1 1 1 1 1 2) (1 3 5 1 5 3 1))) (quote #f)) (make-problem "19990715-TAN (7)" (quote ((17) (2 2) (2 6 6 2) (2 6 6 2) (2 5 5 2) (2 9 1 6 2) (2 4 9 2) (1 5 3 4 1) (1 9 4 6 1) (1 4 5 3 1) (1 3 4 2 1) (1 7 6 3 1) (1 5 1) (1 4 2 2 7) (1 3 1 1 3 2) (1 3 1 3 5) (1 3 1 2 6) (1 5 1 2) (1 7 2 2) (1 4 4 1 2) (2 2 2 4 1) (2 2 1 2 4 1) (2 3 3 3 1) (4 7 1) (2 3 1) (1 1 4 2 1) (6 2 6 1) (1 1 1) (1 4 3 2 4 1) (1 4 2 4 4 1 2 1) (1 3 2 4 2 1) (1 3 8 12 1) (1 11 11 1) (2 9 9 2) (2 8 8 2) (2 5 5 2) (2 2 2 2) (2 13 2) (2 2) (17))) (quote ((15 8) (2 2 1 2) (2 11 2 1 4 2) (2 13 2 1 5 2) (2 15 1 1 6 2) (2 5 3 5 4 2 3 2) (2 5 2 5 1 2 5 2) (1 6 1 1 1 1 8 1) (1 4 1 2 3 1 1 1 2 9 1) (1 4 1 1 2 3 5 1 1) (1 4 2 1 3 1 5 1 1) (1 2 1 1 1 1 2 4 1 1) (1 2 1 1 2 4 1 1) (1 1 1 2 2 1 1) (1 1 1) (1 1 2 2 1 1) (1 2 2 1 2 4 1 1) (1 2 1 2 1 1 4 1 1) (1 5 2 1 2 1 2 1 5 1 1) (1 5 2 1 3 2 2 1 5 1 1) (1 5 1 1 3 1 2 1 9 1) (1 4 2 1 2 1 1 2 7 1) (2 5 1 5 2 1 2 6 2) (2 4 4 2 1 1 1 5 2) (2 4 1 1 1 6 1 1 3 2) (2 5 1 2 7 5 2) (2 4 1 2 11 2) (2 1 2 2) (8 15) ())) (quote #f)) (make-problem "19990803aDAH (8)" (quote ((30) (1 1) (1 2 2 3 2 3 1) (1 1 1 1 1 1 1 2 1) (1 2 3 1 1 2 1 1 1 1) (1 3 2 1 1 7 1) (1 1 1 1 1 3 2 1) (1 3 6 1 2 2 1) (1 2 1 1 2 1 1 2 1 1) (1 1 2 1 6 1 2 1) (1 6 2 3 2 1 1 1 1) (1 1 1 3 3 6 1) (1 2 3 2 1 3 1 1) (1 1 2 2 2 4 1 1) (1 3 3 7 3 1 1) (1 3 1 8 3 3 1) (1 1 16 4 1) (1 4 12 1 1 1) (1 1 10 2 1 1) (1 1 1 3 9 1 1 1) (1 5 7 4 2 1) (1 1 7 4 1) (1 6 1) (1 6 1) (1 6 1) (1 6 1) (12 6 10) (12 6 10) (12 6 10) (12 6 10) (12 6 9) (10 7 7) (8 3 1 1 3 6) (7 3 2 1 2 2) (3 2 3 3 5 1) (1 5 2 1 2 2 2 1) (1 1 1 1 3 1 3 1 1) (1 3 2 3 4 2 2 3 1) (1 1) (30))) (quote ((40) (1 9 1) (1 2 2 2 2 2 9 2 1) (1 1 1 1 1 1 8 1 1) (1 2 2 1 1 2 1 3 8 3 1) (1 2 5 3 1 8 1 1) (1 1 1 1 1 2 2 8 1 1 1) (1 6 2 2 1 1 7 3 1) (1 1 1 1 1 4 6 2 1) (1 3 3 3 4 6 2 1 1) (1 1 1 1 1 2 5 1 1 1) (1 5 2 4 5 2 2 1) (1 1 2 1 2 9 1 2 1) (1 1 1 19 4 1) (1 5 24 2 1 1) (1 3 25 1 1) (1 1 3 2 18 1 1) (1 3 2 22 1) (1 3 20 1 1 1) (1 2 1 1 4 2 4 1) (1 1 3 3 2 2 3 4 1 1 1) (1 1 1 1 1 1 1 5 2 1 1) (1 4 2 2 4 2 5 5 1) (1 1 2 1 1 1 2 6 3 1) (1 3 1 3 2 3 1 7 1 2 1) (1 1 1 1 2 1 1 7 1 1 1) (1 1 3 1 2 7 2 1 1) (1 2 2 2 3 7 2 1) (1 8 1) (40))) (quote #30(#40(on) #40(on off off off off off off off off off off off off off off off off off off off off off off off off off on on on on on on on on on off off off off on) #40(on off off off off off on on off off on on off on on off on on off on on off off off off off on on on on on on on on on off on on off on) #40(on off off off off off off on off off on off off off on off off on off off on off off off off off on on on on on on on on off off off on off on) #40(on off off on on off off on on off on off on off on on off on off on on on off off off off on on on on on on on on off on on on off on) #40(on off off off on on off off on on on on on off off on on on off off on off off off off off on on on on on on on on off on off off off on) #40(on off on off off on off off off off on off off on off on on off off on on off off off off off on on on on on on on on off on off on off on) #40(on off on on on on on on off off on on off on on off on off off on off off off off off off on on on on on on on off off on on on off on) #40(on off off off on off off on off off off on off off on off on on on on off off off off off off on on on on on on off off on on off off off on) #40(on off on on on off on on on off on on on off on on on on off off off off off off off off on on on on on on off on on off off on off on) #40(on off on off off off off on off off on off on off off off on on off off off off off off off off on on on on on off off on off off off on off on) #40(on off off off off on on on on on off off on on off on on on on off off off off off off off on on on on on off on on off off on on off on) #40(on off on off on on off on off on on off off on on on on on on on on on off off off off off off off off off off on off off on on off off on) #40(on off on off off off off off off off on off off off on on on on on on on on on on on on on on on on on on on off on on on on off on) #40(on off on on on on on off on on on on on on on on on on on on on on on on on on on on on on on on off on on off off on off on) #40(on off off off off off on on on off off on on on on on on on on on on on on on on on on on on on on on on on on on off on off on) #40(on off on off on on on off off off on on off off on on on on on on on on on on on on on on on on on on off off off off off on off on) #40(on off on on on off off off off on on off off on on on on on on on on on on on on on on on on on on on on on on off off off off on) #40(on off off off off off off on on on off off on on on on on on on on on on on on on on on on on on on on off off on off off on off on) #40(on off off off off off on on off on off off off on off off on on on on off off off off off off off off off off off on on off on on on on off on) #40(on off on off on on on off on on on off on on off on on off on on on off off off off off on on on on off off on off off on off off off on) #40(on off on off off on off off off on off off on off off on off off off off on off off off off off on on on on on off on on off off off on off on) #40(on off on on on on off off on on off on on off on on on on off on on off off off off off on on on on on off off on on on on on off on) #40(on off off off off on off on on off off on off off on off on off off off on on off off off off on on on on on on off off on on on off off on) #40(on off off on on on off on off on on on off on on off on on on off off on off off off off on on on on on on on off on off on on off on) #40(on off off on off on off off off off off on off off off on on off on off off on off off off off on on on on on on on off on off off on off on) #40(on off off off off on off off off on on on off off off on off off off off on on off off off off on on on on on on on off on on off on off on) #40(on off off off off off off off on on off on on off on on off off on on on off off off off off on on on on on on on off off on on off off on) #40(on off off off off off off off off off off off off off off off off off off off off off off off off off on on on on on on on on off off off off off on) #40(on)))) (make-problem "19990803bDAH (9)" (quote ((30) (1 1 1 1 1 1 1 1) (1 1 4 1 1 1 1 3 1 1 1) (1 1 1 1 1 1 3 1 1 1) (1 4 3 3 2 1 2 2 2) (1 1 1 5 1 1 1 1) (1 1 1 5 2 2 2 2) (1 2 1 1 1 1 1 1 1 1) (1 1 3 3 1 2 1 2 1 1) (2 1 1 1 1 1 1 1 1 3 1) (1 1 2 2 1 3 1 2 4 1 1) (1 2 1 1 1 1 1 1 1 1) (1 3 2 4 1 6 2 1) (2 1 1 1 1 1 1 1) (1 1 6 1 5 3 1 2) (1 2 1 1 1 1 1) (1 1 2 1 1 2 1 10) (6 1 1 2 2 1 1 1 1) (1 1 2 1 1 4 1) (1 4 1 5 1 1 1 1 1) (1 1 1 6 1 3 1 2 1) (1 2 1 1 1 1 1 1 1) (1 1 1 5 7 3 1 1) (1 4 1 1 1 1) (1 1 1 1 3 13 1) (1 6 1 1 1 1 1 1 1 1 1 1) (1 1 1 2 1 2) (1 3 6 1 2 2 1) (1 1 1 1 2 4 4 1) (1 1 1 1 1 3 1 9 1) (1 1 1 1 1 1 1 1 9 1) (1 1 1 1 1 2 2 1 7 2) (1 1 1 2 7 3) (1 3 3 1 3 1 5 2) (1 1 1 1 1 1 1 3 1 1) (1 1 1 1 1 5 1 2 1 2 1) (1 1 1 1 1 1 1 2 1) (1 3 1 4 2 1 5 3) (1 1 1) (30))) (quote ((1 38) (1 1 1 1 1) (5 1 1 1 1 3 3 1 3 1 2 2) (1 1 10 1 1 1 1 1 1 1 1) (1 3 1 1 1 1 1 5 3 1 1) (1 1 4 2 1 4 5 1 1 1) (1 1 1 1 1 5 3 1 1) (1 3 3 1 1 5 4 1 1 1) (1 1 1 5 1 1 1 1 3 5 1) (1 3 1 1 1 1 1 1 6 1) (1 1 3 3 1 1 7 3 1) (1 5 3 1 1 1 2 1 1 1 1 1 1) (1 1 1 1 4 2 1 1 1 1 1 1 1) (1 4 2 3 1 1 1 3 5 1 1) (1 1 1 1 1 2 4 1 1 1) (4 1 6 1 2 1 1 5 1 1) (1 1 1 2 1 2 1 1 8 1) (1 1 2 6 1 1 1 1 1) (1 1 1 1 1 4 1 2 2 3 4 1) (3 1 3 1 1 6 1 1) (1 3 3 2 6 1 2 7 2 1) (3 1 1 3 1 7 1 1) (1 3 1 1 3 3 1 3 7 1 1) (2 2 5 1 1 1 1 7 1 1) (1 2 2 1 5 2 7 2 1) (2 2 2 2 1 1 1 1 6 2 1) (1 3 1 3 1 1 1 2 3 2 1) (3 5 1 7 1 1 1) (1 1 1 1 1 1 3 1 1) (40))) (quote #f)) (make-problem "19991021-BBA (10)" (quote ((3 2) (5 2) (5 5 2) (5 1 3) (1 3 3 9) (3 5 1 3) (3 3 1 5 2) (3 5 1 1 2) (3 5 3 2) (4 5 1 2) (6 5 2 2) (5 3 7 2) (4 3 9 2) (3 4 13) (1 6 1 8) (8 4 2) (2 3 2 2) (1 1 1 1 1 2) (4 2 2 2) (3 4 1) (2 3 1 1) (2 2 2) (10) (10) (1 1) (9) (9) (8) (8) (8) (7) (7) (2 2 4 3) (1 1 4 4) (9 4 4) (7 4 3) (1 1 1 5 3) (5 9) (5 9) (3 4 5))) (quote ((3) (1 2) (5) (3 2 3) (6 6) (7 2 3) (3 2 3 5) (5 3 1 2) (5 4 3) (5 5 6 4) (3 3 15 8) (6 3 2 2 15) (12 2 1 2 15) (13 2 2 14) (2 17 7 3) (6 4 2 3 15) (2 2 1 2 2 15) (4 2 1 3 15) (5 11 2 1) (3) (3) (3 3) (1 1 2 4) (1 1 1 1 4) (1 1 1 2 4) (1 1 1 1 3) (1 1 2 3) (3 2) (19) (19))) (quote #f)))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/solution-sets/k35x25 b/collects/games/paint-by-numbers/solution-sets/k35x25
new file mode 100644
index 0000000000..1b8efc70b5
--- /dev/null
+++ b/collects/games/paint-by-numbers/solution-sets/k35x25
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 35x25") (define problems (list (make-problem "19980530-GOS (1)" (quote ((16 14) (13 12) (10 10) (9 1 3 2 1 9) (9 1 1 1 1 1 1 1 8) (9 1 1 1 1 1 3 7) (8 1 1 1 3 1 1 1 2) (8 2 1 1 1 1 1) (8 1) (7 2 4 2) (7 2 2 4 1 1 5) (6 2 3 1 1 3 3) (5 3 4 3 2 1) (5 2 2 2 2 2 1 1) (5 2 2 2 2 1 4 5) (1 2 6 4 6) (2 4 1 6) (2 3 2 5 7) (3 2 1 9 7) (3 3 9 8) (7 7 8) (4 9) (2 1 11) (4 4 12) (14 14))) (quote ((16 3) (15 3) (15 3 2) (15 5 2) (15 5 1) (12 2 1) (11 3 1) (9 4 2) (6 9 2) (3 9 3) (2 4 2) (2 4 5 1) (2 1 5 1) (1 4 4 2 1 1) (1 1 3 2 3) (1 5 5 3) (1 5 3) (4 3) (1 1 1 2 3) (5 1 3 4) (1 2 1 4) (1 5 1 1 1 3 1) (1 1 3 1 2 1) (2 4 1 2) (2 1 2 3) (3 1 3 3) (4 1 2 1 4) (5 1 1 1 6) (6 3 1 8) (7 10) (6 1 11) (6 1 11) (6 2 11) (7 3 11) (7 17))) (quote #35(#25(on on on on on on on on on on on on on on on on off off off off off off on) #25(on on on on on on on on on on on on on on on off off off off off off off on) #25(on on on on on on on on on on on on on on on off off off on on on off off on) #25(on on on on on on on on on on on on on on on off off on on on on on off on) #25(on on on on on on on on on on on on on on on off off on on on on on off off on) #25(on on on on on on on on on on on on off off off off off off off off on on off off on) #25(on on on on on on on on on on on off off off off off off off off on on on off off on) #25(on on on on on on on on on off off off off off off off off on on on on off off on) #25(on on on on on on off off off off off off on on on on on on on on on off off on) #25(on on on off off off off off off on on on on on on on on on off off off off on) #25(on on off off off off off off off on on on on off off off off off off off off off off on) #25(on on off on on on on off off off off off off off on on on on on off off off off off on) #25(on on off off off off off on off off off off off on on on on on off off off off off off on) #25(on off off off on on on on off off on on on on off on on off off on off off off off on) #25(on off off on off off off off off off on on on off off on on off on on on off) #25(on off off on on on on on off off off on on on on on off off on on on off) #25(off off off on off off off off off off off off on on on on on off on on on off) #25(off off off off on on on on off off off off off off off off off off on on on off) #25(off off off on off off on off off off off on off off on on off off on on on off) #25(off off off on on on on on off off on off off on on on off on on on on off) #25(off off off off off off off off off off on off on on off on off on on on on off) #25(on off off on on on on on off off on off on off off on off on on on off off off off on) #25(on off off off off on off off off off on on on off on off off on on off off off off off on) #25(on on off off on on on on off off off off off off off off off on off off off off off on) #25(on on off off off off off off off off on off off on on off off off off off off off on) #25(on on on off off off off off off on off off on on on off off off off off off off on) #25(on on on on off off off off off on off on on off on off off off off off off on) #25(on on on on on off off off off on off on off off on off off off off on) #25(on on on on on on off off off on on on off on off off off on) #25(on on on on on on on off off off off off off off off on) #25(on on on on on on off off off off on off off off on) #25(on on on on on on off off off off on off off off on) #25(on on on on on on off off off off on on off off on) #25(on on on on on on on off off on on on off off on) #25(on on on on on on on off on)))) (make-problem "19980616-HEI (2)" (quote ((1 1 4 8 1) (3 1 6 10 3) (1 6 10 3) (1 6 16) (1 1 1 1 6 6 1) (1 3 1 8 6 1) (1 1 1 6 1) (1 1 1 6 1 1 1) (1 6 1 1 1) (9 7 5 1 1 1) (9 4 1) (2 1 2 3 1) (2 3 2 2 1) (2 1 2 11) (2 2) (3 2 2 1 2 2) (4 2 1 1 1 1 1 2) (5 2 2 1 2 2 4) (5 2 1 1 1 1 2 5) (5 2 2 6) (5 15 7) (2 15 6) (1 2 6 1) (2 6) (5 8))) (quote ((1 1 6 1) (1 4 1 6 1 1) (2 1 6 1) (2 1 9) (1 1 8) (4 1) (1) (1 9) (10 10) (2 2) (1 2 4 2) (5 2 1 1 2) (6 2 1 1 2) (6 2 1 2) (6 5 4 2) (6 2 1 2) (5 2 4 2) (1 2 1 1 2) (2 1 2) (9 2 2) (10 10) (11 9) (12) (13) (14) (4 1) (4 1) (3 1 1 4) (3 1 1 1 5) (1 1 6) (11 7) (1 1 8) (3 1 1 1 8) (3 1 1 4 1) (4 1 4 1 1))) (quote #35(#25(off on off off off off off off off on off off off off off on on on on on on off off off on) #25(off on off off on on on on off on off off off off off on on on on on on off on off on) #25(on on off off off off off off off on off off off off off on on on on on on off off off on) #25(off off off off on on off off off on off off off off off off on) #25(off off off off off on off off off on off off off off off off off on) #25(off off off off on on on on off on off) #25(off off off off off off off off off on off) #25(off off off off off off off off off on off off off on on on on on on on on on off) #25(on on on on on on on on on on off off on on on on on on on on on on off) #25(off off off off off off off off off off off on on off off off off off off off on on off) #25(off off off off off on off off off off on on off off off on on on on off on on off) #25(off on on on on on off off off on on off off off off on off on off off on on off) #25(on on on on on on off off off on on off off off off off on off on off on on off) #25(on on on on on on off off off on on off on off off off off off off off on on off) #25(on on on on on on off off off on on on on on off on on on on off on on off) #25(on on on on on on off off off on on off on off off off off off off off on on off) #25(off on on on on on off off off on on off off off off on on on on off on on off) #25(off off off off off on off off off on on off off off off on off on off off on on off) #25(off off off off off off off off off off on on off off off off on off off off on on off) #25(on on on on on on on on on off off on on off off off off off off off on on off) #25(on on on on on on on on on on off off on on on on on on on on on on off) #25(on on on on on on on on on on on off off on on on on on on on on on off) #25(on on on on on on on on on on on on off) #25(on on on on on on on on on on on on on off) #25(on on on on on on on on on on on on on on off) #25(on on on on off off off off off off off off off on off) #25(on on on on off off off off off off off off off on off) #25(off on on on off off off off on off off off off on off off off off off off off on) #25(off on on on off off off on off on off off off on off off off off off off on) #25(off off off on off off off off off off off off off on off off off off off on) #25(off off off on on on on on on on on on on on off off off off on) #25(off off off on off off off off off off off off off on off off off on) #25(off on on on off off off on off on off off off on off off off on) #25(off on on on off off off off on off off off off on off off off on on on on off off off on) #25(on on on on off off off off off off off off off on off off off on on on on off on off on)))) (make-problem "19980716aGAS (3)" (quote (() () (11) (5 5) (3 1 1 3) (3 2 5 2 3) (2 2 5 2 2) (2 4 5 4 2) (1 6 5 6 1) (2 7 7 7 2) (1 27 1) (1 27 1) (1 27 1) (1 27 1) (1 27 1) (2 4 13 4 2) (1 3 1 5 1 3 1) (2 1 1 5 1 1 2) (2 1 1 1 2) (3 1 3) (3 3) (5 5) (11) () ())) (quote (() () (7) (3 3) (2 5 2) (2 9 2) (1 9 1) (2 11 2) (1 9 1 1) (2 9 2) (1 10 1) (1 1 7 1) (2 8 2) (2 6 2) (1 7 1) (1 14 1) (1 13 1) (1 15 1) (1 13 1) (1 14 1) (1 7 1) (2 6 2) (2 8 2) (1 1 7 1) (1 10 1) (2 9 2) (1 9 1 1) (2 11 2) (1 9 1) (2 9 2) (2 5 2) (3 3) (7) () ())) (quote #35(#25(off) #25(off) #25(off off off off off off off off off on on on on on on on off) #25(off off off off off off off on on on off off off off off on on on off) #25(off off off off off off on on off off on on on on on off off on on off) #25(off off off off off on on off on on on on on on on on on off on on off) #25(off off off off off on off off on on on on on on on on on off off on off) #25(off off off off on on off on on on on on on on on on on on off on on off) #25(off off off off on off off on on on on on on on on on off off on off on off) #25(off off off on on off on on on on on on on on on off off off off off on on off) #25(off off off on off on on on on on on on on on on off off off off off off on off) #25(off off off on off on off off off on on on on on on on off off off off off on off) #25(off off on on off off off off off off on on on on on on on on off off off on on off) #25(off off on on off off off off off off on on on on on on off off off off off on on off) #25(off off on off off off off off off on on on on on on on off off off off off off on off) #25(off off on off on on on on on on on on on on on on on on off off off off on off) #25(off off on off off on on on on on on on on on on on on on off off off off on off) #25(off off on off off on on on on on on on on on on on on on on on off off on off) #25(off off on off off on on on on on on on on on on on on on off off off off on off) #25(off off on off on on on on on on on on on on on on on on off off off off on off) #25(off off on off off off off off off on on on on on on on off off off off off off on off) #25(off off on on off off off off off off on on on on on on off off off off off on on off) #25(off off on on off off off off off off on on on on on on on on off off off on on off) #25(off off off on off on off off off on on on on on on on off off off off off on off) #25(off off off on off on on on on on on on on on on off off off off off off on off) #25(off off off on on off on on on on on on on on on off off off off off on on off) #25(off off off off on off off on on on on on on on on on off off on off on off) #25(off off off off on on off on on on on on on on on on on on off on on off) #25(off off off off off on off off on on on on on on on on on off off on off) #25(off off off off off on on off on on on on on on on on on off on on off) #25(off off off off off off on on off off on on on on on off off on on off) #25(off off off off off off off on on on off off off off off on on on off) #25(off off off off off off off off off on on on on on on on off) #25(off) #25(off)))) (make-problem "19990119-JAM (4)" (quote (() (7) (7) (8) (9) (9) (9) (6 2) (5 1) (6 2) (9) (9) (3 5) (2 1 5) (3 14 7) (8 8 1 7) (7 8 5 3) (8 5 8 1 3) (5 7 8 4) (4 1 7 14) (4 13 8) (17 6) (15 6) (19) ())) (quote (() () () () (17) (21) (12 8) (11 1 7) (12 5 3) (7 9 1 2) (6 9 4) (7 7 7) (11 6) (3 7) (10) (10) (10) (4 5) (3 4) (4 5) (10) (1 8) (1 4 2) (1 4 1) (7 2) (10) (10) (3 6) (2 1 5) (3 5) (7) (5) (3) () ())) (quote #35(#25(off) #25(off) #25(off) #25(off) #25(off off off on on on on on on on on on on on on on on on on on off) #25(off on on on on on on on on on on on on on on on on on on on on on off) #25(off on on on on on on on on on on on on off on on on on on on on on off) #25(off on on on on on on on on on on on off on off on on on on on on on off) #25(off on on on on on on on on on on on on off on on on on on off on on on off) #25(off on on on on on on on off on on on on on on on on on off on off on on off) #25(off on on on on on on off off off on on on on on on on on on off on on on on off) #25(off on on on on on on on off on on on on on on on off on on on on on on on off) #25(off off off off on on on on on on on on on on on off off off on on on on on on off) #25(off off off off off off off off off off off off off on on on off on on on on on on on off) #25(off off off off off off off off off off off off off off on on on on on on on on on on off) #25(off off off off off off off off off off off off off off on on on on on on on on on on off) #25(off off off off off off off off off off off off off off on on on on on on on on on on off) #25(off off off off off off off off off off off off off off on on on on off on on on on on off) #25(off off off off off off off off off off off off off off on on on off off off on on on on off) #25(off off off off off off off off off off off off off off on on on on off on on on on on off) #25(off off off off off off off off off off off off off off on on on on on on on on on on off) #25(off off off off off off off off off off off off off off on off on on on on on on on on off) #25(off off off off off off off off off off off off off off off on off on on on on off on on off) #25(off off off off off off off off off off off off off off on off on on on on off off off on off) #25(off off off off off off off off off off off off off off on on on on on on on off on on off) #25(off off off off off off off off off off off off off off on on on on on on on on on on off) #25(off off off off off off off off off off off off off off on on on on on on on on on on off) #25(off off off off off off off off off off off off off off on on on off on on on on on on off) #25(off off off off off off off off off off off off off off on on off on off on on on on on off) #25(off off off off off off off off off off off off off off on on on off on on on on on off) #25(off off off off off off off off off off off off off off off on on on on on on on off) #25(off off off off off off off off off off off off off off off off on on on on on off) #25(off off off off off off off off off off off off off off off off off on on on off) #25(off) #25(off)))) (make-problem "19990208aFRA (5)" (quote ((1 24) (31) (1 29) (3 28) (3 2 27) (2 2 8 8) (2 2 5 11 7) (3 6 2 1 2 6) (9 2 1 2 5) (8 2 1 3 5) (4 2 1 3 4) (3 26 3) (2 28 2) (2 29 2) (1 30 1) (30) (35) (3 3) (5 5) (2 2 2 2) (5 5) (3 3) () (8 8 8 4) ())) (quote ((1 5 1) (10 1 1) (1 6 3 1) (3 4 4 3 1) (3 2 2 10 1) (2 2 4 8 2 1) (2 2 3 11 1) (3 5 6 3 1) (9 6 1) (8 6) (7 6) (7 7 1) (6 8 1) (6 2 6 1) (5 2 6 1) (5 2 6 1) (5 1 6 1) (5 1 6 1) (5 1 6 1) (5 1 6) (5 11) (5 1 6 1) (5 1 6 1) (5 1 6 1) (5 1 6 1) (5 11 3 1) (5 15 1) (6 10 2 1) (7 11 1) (8 6 3) (10 6) (11 5 1) (12 1 1) (14 1 1) (15 1 1))) (quote #35(#25(off off off off off on off off off off on on on on on off on off) #25(off off off off on on on on on on on on on on off off on off off off off off off on off) #25(off off off off on off on on on on on on off off on on on off off off off off off on off) #25(off off off on on on off on on on on off off on on on on off on on on off off on off) #25(off on on on off on on off on on off off on on on on on on on on on on off on off) #25(on on off on on off on on on on off on on on on on on on on off on on off on off) #25(off on on off on on off on on on off on on on on on on on on on on on off on off) #25(off on on on off on on on on on off on on on on on on off on on on off off on off) #25(off on on on on on on on on on off on on on on on on off off off off off off on off) #25(off on on on on on on on on off off on on on on on on off) #25(off on on on on on on on off off off on on on on on on off) #25(on on on on on on on off off off on on on on on on on off off off off off off on off) #25(on on on on on on off off off on on on on on on on on off off off off off off on off) #25(on on on on on on off off on on off on on on on on on off off off off off off on off) #25(on on on on on off off on on off off on on on on on on off off off off off off on off) #25(on on on on on off on on off off off on on on on on on off off off off off off on off) #25(on on on on on off on off off off off on on on on on on off off off off off off on off) #25(on on on on on off on off off off off on on on on on on off off off off off off on off) #25(on on on on on off on off off off off on on on on on on off off off off off off on off) #25(on on on on on off on off off off off on on on on on on off) #25(on on on on on off on on on on on on on on on on on off) #25(on on on on on off on off off off off on on on on on on off off off off off off on off) #25(on on on on on off on off off off off on on on on on on off off off off off off on off) #25(on on on on on off on off off off off on on on on on on off off off off off off on off) #25(on on on on on off on off off off off on on on on on on off off off off off off on off) #25(on on on on on off on on on on on on on on on on on off on on on off off on off) #25(on on on on on off off on on on on on on on on on on on on on on on off on off) #25(on on on on on on off off off on on on on on on on on on on off on on off on off) #25(on on on on on on on off off off off on on on on on on on on on on on off on off) #25(on on on on on on on on off off off on on on on on on off on on on off) #25(on on on on on on on on on on off on on on on on on off) #25(on on on on on on on on on on on off on on on on on off off off off off off on off) #25(on on on on on on on on on on on on off off off off on off off off off off off on off) #25(on on on on on on on on on on on on on on off off on off off off off off off on off) #25(on on on on on on on on on on on on on on on off on off off off off off off on off)))) (make-problem "19990220aFRA (6)" (quote ((35) (22 10) (21 3 9) (17 1 3 9) (16 3 3 9) (16 4 3 9) (9 2 4 2 9) (8 2 1 10) (7 3 9) (6 1 8) (5 7) (5 3 2) (4 9 1 1) (3 1 8 9 3) (2 5 8 5 3 1) (1 28 1 2) (30 3) (31 2) (1 31 1) (2 20) (4 5 13) (5 3 14) (6 26) (35) (35))) (quote ((16 7) (15 2 6) (14 4 5) (13 5 5) (12 7 4) (10 7 3) (9 8 2) (8 8 2) (7 7 2) (6 6 3) (6 1 5 4) (6 1 10) (6 12) (6 12) (7 12) (8 12) (4 2 12) (3 3 1 12) (3 3 1 11) (3 3 11) (4 3 10) (2 1 10) (1 4 2 10) (1 5 2 10) (1 5 1 7 3) (2 1 7 3) (9 7 3) (10 7 3) (11 7 3) (14 4 3) (13 1 3 3) (12 3 2 3) (11 3 1 1 3) (12 1 3 3) (13 5 3))) (quote #35(#25(on on on on on on on on on on on on on on on on off off on) #25(on on on on on on on on on on on on on on on off on on off on) #25(on on on on on on on on on on on on on on off on on on on off on) #25(on on on on on on on on on on on on on off on on on on on off on) #25(on on on on on on on on on on on on off on on on on on on on off on) #25(on on on on on on on on on on off off off off on on on on on on on off on) #25(on on on on on on on on on off off off off off on on on on on on on on off on) #25(on on on on on on on on off off off off off off on on on on on on on on off on) #25(on on on on on on on off off off off off off off off on on on on on on on off on) #25(on on on on on on off off off off off off off off off on on on on on on off on) #25(on on on on on on off off off off off off off on off on on on on on off on) #25(on on on on on on off off off off off off off on off on) #25(on on on on on on off off off off off off off on) #25(on on on on on on off off off off off off off on) #25(on on on on on on on off off off off off off on) #25(on on on on on on on on off off off off off on) #25(on on on on off off off on on off off off off on) #25(on on on off on on on off on off off off off on) #25(on on on off on on on off on off off off off off on) #25(on on on off on on on off off off off off off off on) #25(on on on on off on on on off off off off off off off on) #25(on on off off off off off off off off off off off on off on) #25(on off on on on on off off off off off off on on off on) #25(on off on on on on on off off off off off on on off on) #25(on off on on on on on off off on off off on on on on on on on off off off on) #25(on on off off off off off on off off off off on on on on on on on off off off on) #25(on on on on on on on on on off off off on on on on on on on off off off on) #25(on on on on on on on on on on off off on on on on on on on off off off on) #25(on on on on on on on on on on on off on on on on on on on off off off on) #25(on on on on on on on on on on on on on on off on on on on off off off on) #25(on on on on on on on on on on on on on off on off on on on off off off on) #25(on on on on on on on on on on on on off on on on off on on off off off on) #25(on on on on on on on on on on on off on on on off on off on off off off on) #25(on on on on on on on on on on on on off on off on on on off off off off on) #25(on on on on on on on on on on on on on off on on on on on off off off on)))) (make-problem "19990220bFRA (7)" (quote ((35) (8 9 3 1 4) (7 9 3 3) (6 8 3 3) (6 8 4 4) (1 4 4 2 4 5) (1 3 3 15) (1 1 1 2 1 4 1 4) (1 2 1 1 2 5 2 1 4) (1 4 2 2 4 5 2 4) (1 5 5 5 15) (1 6 6 1 1 2 2 1) (1 7 7 1 1 1 2 1 1 1) (1 6 6 1 1 1 2 1 1 1) (1 7 7 1 1 1 1 1) (1 8 8 1 2 2 1 1 1) (1 8 8 1 1 1 2 1 1 1) (1 8 8 1 1 1 2 1 1 1) (1 8 8 1 1 1 1 1 1 1) (1 8 8 15) (1 7 7 15) (3 5 5 17) (5 3 3 19) (7 1 1 21) (8 22))) (quote ((25) (5 4) (6 5 5 4) (7 5 7 3) (7 12 3) (8 13 2) (3 1 12 2) (2 1 12 1) (1 2 11) (1 1 12) (1 1) (1 1 12) (1 2 11) (2 1 12 1) (3 1 12 2) (8 13 2) (8 12 3) (7 5 7 3) (6 5 5 4) (5 4) (25) (11 6) (1 3 5 2 9) (1 5 1 6) (1 3 1 17) (7 1 6) (7 3 2 3 6) (2 21) (1 2 2 6) (2 1 1 1 2 10) (1 2 2 6) (2 21) (11 6) (11 6 6) (12 7))) (quote #35(#25(on) #25(on on on on on off off off off off off off off off off off off off off off off on) #25(on on on on on on off on on on on on off off off on on on on on off on) #25(on on on on on on on off on on on on on off on on on on on on on off on) #25(on on on on on on on off off on on on on on on on on on on on on off on) #25(on on on on on on on on off on on on on on on on on on on on on on off on) #25(on on on off off off off off on off on on on on on on on on on on on on off on) #25(on on off off off off off off off on off on on on on on on on on on on on on off on) #25(on off off off off off off off off on on off on on on on on on on on on on on off) #25(on off off off off off off off off off on off on on on on on on on on on on on on off) #25(on off off off off off off off off off on off) #25(on off off off off off off off off off on off on on on on on on on on on on on on off) #25(on off off off off off off off off on on off on on on on on on on on on on on off) #25(on on off off off off off off off on off on on on on on on on on on on on on off on) #25(on on on off off off off off on off on on on on on on on on on on on on off on) #25(on on on on on on on on off on on on on on on on on on on on on on off on) #25(on on on on on on on on off on on on on on on on on on on on on off on) #25(on on on on on on on off on on on on on off on on on on on on on off on) #25(on on on on on on off on on on on on off off off on on on on on off on) #25(on on on on on off off off off off off off off off off off off off off off off on) #25(on) #25(on on on on on on on on on on on off off off off off off off off on) #25(on off on on on off on on on on on off on on off off on) #25(on off off off off off on on on on on off off off off on off off off on) #25(on off on on on off on off on) #25(on on on on on on on off off off on off off off off off off off off on) #25(on on on on on on on off on on on off on on off on on on off on) #25(on on off off on) #25(on off off off off on on off off off on on off off off off off off off on) #25(on on off off off off on off on off on off on on off on) #25(on off off off off on on off off off on on off off off off off off off on) #25(on on off off on) #25(on on on on on on on on on on on off off off off off off off off on) #25(on on on on on on on on on on on off on on on on on on off on) #25(on on on on on on on on on on on on off off off off off off on)))) (make-problem "19990305-FRA (8)" (quote ((12 20) (12 1 3 1 14) (12 1 3 1 2 5 4) (12 3 1 1 1 1 1 2 1) (3 3 1 1 1 1 1 2 1 2) (1 7 2 2 1 1 1 2 3) (9 9 1 1 2 1 2) (11 12 1 2 2) (13 19) (14 19) (6 7 19) (5 2 6 7 9) (5 2 6 4 9) (6 7 2 10) (15 11) (15 13) (14 16) (14 18) (14 10) (13 9) (13 8) (11 21) (9 22) (1 7 23) (2 7 24))) (quote ((6 13 2) (5 15 1) (5 17) (4 20) (4 20) (4 6 12) (4 5 2 11) (4 5 2 11) (4 6 12) (4 20) (4 17) (5 15 1) (2 13 2) (2 3 10 3) (2 6 4) (5 3 4) (4 9 4) (14 1 4) (1 7 1 4) (5 7 2 4) (1 6 2 4) (12 2 4) (3 5 3 4) (2 1 6 3 4) (3 4 4 4) (11 6 4) (3 12 4) (3 3 17) (25) (2 17) (5 19) (4 1 18) (3 3 17) (25) (2 1 16))) (quote #35(#25(on on on on on on off off on on on on on on on on on on on on on off off on) #25(on on on on on off off on on on on on on on on on on on on on on on off off on) #25(on on on on on off on on on on on on on on on on on on on on on on on off) #25(on on on on off on) #25(on on on on off on) #25(on on on on off on on on on on on off off on) #25(on on on on off on on on on on off on on off on) #25(on on on on off on on on on on off on on off on) #25(on on on on off on on on on on on off off on) #25(on on on on off on) #25(on on on on off off on on on on on on on on on on on on on on on on on off) #25(on on on on on off off on on on on on on on on on on on on on on on off off on) #25(off off off off on on off off on on on on on on on on on on on on on off off on) #25(off on on off on on on off off on on on on on on on on on on off off off on) #25(off off off off off off on on off off on on on on on on off off off off off on) #25(on on on on on off on on on off off off off off off off off off off off off on) #25(on on on on off on on on on on on on on on off off off off off off off on) #25(on on on on on on on on on on on on on on off off off on off off off on) #25(on off off off off off on on on on on on on off off off off on off off off on) #25(on on on on on off on on on on on on on off off off on on off off off on) #25(on off off off off off on on on on on on off off off off on on off off off on) #25(on on on on on on on on on on on on off off off off on on off off off on) #25(on on on off off off off on on on on on off off off on on on off off off on) #25(on on off on off on on on on on on off off off off on on on off off off on) #25(on on on off off off off on on on on off off off on on on on off off off on) #25(on on on on on on on on on on on off off on on on on on on off off on) #25(on on on off off off off off on on on on on on on on on on on on off on) #25(on on on off on on on off on) #25(on) #25(on on off off off off off off on) #25(on on on on on off on) #25(on on on on off on off on) #25(on on on off on on on off on) #25(on) #25(on on off off off off off on off on)))) (make-problem "19990909-PIP (9)" (quote ((8) (2 2) (5 2 2 5) (1 3 1 1 3 1) (1 1 1 1 1 1) (2 2 2 3) (8 3 6 3 6 1) (1 1 10 1 1) (1 1 3 2 1 1 1) (9 1 6 1 9) (8 1 3 1 1 2 1 8) (9 1 1 1 1 1 2 9) (9 2 1 1 1 1 9) (8 2 1 1 1 1 1 8) (8 1 1 1 1 1 2 8) (8 2 1 1 1 1 1 1 8) (8 1 1 1 1 1 1 2 8) (8 2 1 1 1 1 1 1 8) (7 3 1 1 1 1 2 7) (1 1 1 1 1 1 2 1) (1 4 1 1 3 1) (1 10 1) (1 6 1) (2 2) (6))) (quote (() () (13) (3 10) (1 1 10) (1 1 10) (1 1 10) (1 1 10) (2 1 10) (2 1 10) (3 3 2 2) (2 1 6 1) (3 1 2 3 1 4 1) (2 3 1 1 1 1 2 1) (2 2 2 1 1 3 1) (1 2 2 1 1 1 3 1) (1 2 1 1 1 1 1 1 2 1) (1 2 2 1 1 1 1 3 1) (1 2 1 1 1 1 1 1 2 1) (1 2 2 1 1 1 1 3 1) (1 2 1 1 1 1 1 1 2 1) (2 1 1 1 1 1 1 2 1) (2 3 2 1 1 1 3 1) (3 1 2 2 1 1 3 1) (2 1 6 1) (3 3 2 2) (2 1 10) (2 1 10) (1 1 10) (1 1 10) (1 1 10) (1 2 11) (2 1 10) (2 10) ())) (quote #f)) (make-problem "19991011aLLO (10)" (quote ((5 14) (7 12) (9 10) (9 2 2) (7 2 2) (5 2 2) (5 2 2) (5 1 2 2) (5 3 2 2) (5 3 10) (17 1) (1 3 1 6 1 1) (2 1 6 6) (3 8 1 2 1 1) (3 10 11 1 1) (2 3 4 1 1) (1 15 4 3 1 1) (1 15 1 1 2 1 1) (17 1 1 1 3 1 1) (17 1 2 2 1 1) (4 4 9) (4 2 2 7 2 1 3) (2 4 4 1 1 1 1 1 1 1) (1 4 4 6 1 1) (2 2 4))) (quote ((3) (3) (2 3) (4 4) (2 11) (4 1 2 2) (11 3 4) (12 1 4 4) (12 1 4 2) (12 1 4) (11 1 4 2) (4 1 2 4 4) (2 1 2 4 4) (3 2 4 2) (4 2 4 1) (3 2 4 3) (1 2 4 1 1) (1 1 4 3) (1 1 1 4 1 1) (2 1 3 3) (18 3 1) (10 3 1 1 1) (3 1 2 2 1 1 1) (3 1 2 1 1 1 1 1 1) (3 1 2 1 1 1 1 1) (3 1 2 1 1 1 1 1) (3 1 2 1 1 1 1 1 1) (3 1 2 2 1 1 1) (10 3 1 1 1) (22) (2 9) (1 1 2) (10) (1 2) (10))) (quote #35(#25(off off off off off off off off off off off off off off off off off off off off off on on on off) #25(off off off off off off off off off off off off off off off off off off off off on on on off) #25(off off off off off off off off off off off off off on on off off off off on on on off) #25(off off off off off off off off off off off off on on on on off off on on on on off) #25(off off on on off off off off off off on on on on on on on on on on on off) #25(off on on on on off off off off off on off off off off off off off on on off off on on off) #25(on on on on on on on on on on on off off off off off off on on on off on) #25(on on on on on on on on on on on on off off on off on on on on off on) #25(on on on on on on on on on on on on off off on off on on on on off off on on off) #25(on on on on on on on on on on on on off off on off on on on on off) #25(on on on on on on on on on on on off off off on off on on on on off off on on off) #25(off on on on on off off off off off on off off on on off on on on on off on) #25(off off on on off off off off off off on off off on on off on on on on off on) #25(off off off off off off off off on on on off off on on off on on on on off off on on off) #25(off off off off off off off on on on on off off on on off on on on on off on off) #25(off off off off off off off off on on on off off on on off on on on on off on on on off) #25(off off off off off off off off off off on off off on on off on on on on off on off on off) #25(off off off off off off off off off off on off off on off off on on on on off on on on off) #25(on off off off off off off off off off on off off on off off on on on on off on off on off) #25(on on off off off off off off off off on off off off off off on on on off off on on on off) #25(on on on on on on on on on on on on on on on on on on off on on on off on off) #25(on on on on on on on on on on off off off off on on on off on off on off on off) #25(on on on off off off off off off on off on on off on on off on off off on off off on off) #25(on on on off off off off off off on off on on off on off on off on off on off on off on) #25(on on on off off off off off off on off on on off on off on off off on off on off off on) #25(on on on off off off off off off on off on on off on off on off off on off on off off on) #25(on on on off off off off off off on off on on off on off on off on off on off on off on) #25(on on on off off off off off off on off on on off on on off on off off on off off on off) #25(on on on on on on on on on on off off off off on on on off on off on off on off) #25(on on on on on on on on on on on on on on on on on on on on on on off) #25(on on off off off off off off off off off off on on on on on on on on on off) #25(on off off off off off off off off off off off on off off off off off off off on on off) #25(off off off off off off off off off off off off on on on on on on on on on on off) #25(off off off off off off off off off off off off on off off off off off off off on on off) #25(off off off off off off off off off off off on on on on on on on on on on off)))) (make-problem "19991013-KHO (11)" (quote (() (1) (1) (5) (1 4) (7) (5 1) (2 3 3) (4 1 1) (5 1) (17 2) (20 3) (21 3) (12 8) (10 7) (8 7) (5 6) (3 1 4) (2 2 6) (1 2 2 3) (1 1 2 2) (2 1 2 2) (2 1 2 2) (1 2 1 1) (2 2 2 2))) (quote (() (2) (3) (3 5 1) (1 2 7 4) (4 15) (1 3 12) (16 1) (3 10 2 2) (7 7) (6) (5) (5) (4) (4) (3) (3) (3) (6) (7) (8) (9) (10) (7 3 1) (4 2 4) (2 2) (1 3) (2 3 1) (1 1 4) (1 2) (1 1) (3) () () ())) (quote #35(#25(off) #25(off off off off off off on on off) #25(off off off off off on on on off) #25(off off off off on on on off off off off on on on on on off off off off off off off off on) #25(off off off on off on on off off off on on on on on on on off off off off on) #25(off off off on on on on off on on on on on on on on on on on on on on on off) #25(off on off on on on off on on on on on on on on on on on on off) #25(off off on on on on on on on on on on on on on on on on off off off off off off on) #25(off off off on on on off on on on on on on on on on on off on on off off off on) #25(off off off off off off off off off on on on on on on on off on on on on on on on off) #25(off off off off off off off off off off on on on on on on off) #25(off off off off off off off off off off on on on on on off) #25(off off off off off off off off off off on on on on on off) #25(off off off off off off off off off off on on on on off) #25(off off off off off off off off off off on on on on off) #25(off off off off off off off off off off on on on off) #25(off off off off off off off off off off on on on off) #25(off off off off off off off off off off on on on off) #25(off off off off off off off off off off on on on on on on off) #25(off off off off off off off off off off on on on on on on on off) #25(off off off off off off off off off off on on on on on on on on off) #25(off off off off off off off off off off off on on on on on on on on on off) #25(off off off off off off off off off off off on on on on on on on on on on off) #25(off off off off off off off off off off off off on on on on on on on off on on on off on) #25(off off off off off off off off off off off off off on on on on off on on off on) #25(off off off off off off off off off off off off on on off off off off on on off) #25(off off off off off off off off off off off off on off off off off off on on on off) #25(off off off off off off off off off off off on on off off off off off off off on on on off on) #25(off off off off off off off off on off off on off off off off off off off off off on) #25(off off off off off off off on off off on on off) #25(off off off off off off off on off off on off) #25(off off off off off off off on on on off) #25(off) #25(off) #25(off)))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/solution-sets/k35x30 b/collects/games/paint-by-numbers/solution-sets/k35x30
new file mode 100644
index 0000000000..8116e1b9b1
--- /dev/null
+++ b/collects/games/paint-by-numbers/solution-sets/k35x30
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 35x30") (define problems (list (make-problem "19980420-KVL (1)" (quote (() () () (4) (7) (9) (8 2) (5 6) (4 6) (5 4 2) (6 4 2) (2 10 4) (20) (1 1) (21) (21) (2 7 7 1) (2 3 3 6 3) (11 2 2 4) (19 4 1) (7 8 5 2) (2 3 7 3 1) (6 7 3 2) (6 8 6 1) (2 4 5 2 1 3 2) (1 10 2 4 1) (2 11 3 5 1) (10 4 4 5 2) (21 8) ())) (quote ((17) (4 11 3) (6 2 3 2 2) (5 1 2 7 3) (8 15) (9 15) (4 3 7 5) (4 2 3 2 4) (4 2 6 4) (5 3 6 4) (10 7 3 1) (2 6 2 10) (8 2 10) (4 2 2 10) (2 1 11 2) (2 2 10 1) (4 4 5 1) (3 11 2) (2 6 6) (1 4 4) (4 3) () (1) (2) (3 2) (4 1) (7 1) (3 8) (1 7) (6) (4) (3) (3 1) (2 3 2) (4))) (quote #35(#30(off off off off off off off off off off off off on on on on on on on on on on on on on on on on on off) #30(off off off off off off off off off on on on on off on on on on on on on on on on on off on on on off) #30(off off off off off off off on on on on on on off on on off off on on on off on on off off off on on off) #30(off off off off off off on on on on on off on off on on off off on on on on on on on off on on on off) #30(off off off off off on on on on on on on on off on on on on on on on on on on on on on on on off) #30(off off off off on on on on on on on on on off on on on on on on on on on on on on on on on off) #30(off off off off on on on on off off on on on off on on on on on on on off off off on on on on on off) #30(off off off on on on on off off off off on on off on on on off on on off off off off off on on on on off) #30(off off off on on on on off off off off on on off on on on on on on off off off off off on on on on off) #30(off off off on on on on on off off on on on off on on on on on on off off off off off on on on on off) #30(off off off on on on on on on on on on on off on on on on on on on off off off on on on off on off) #30(off off off off on on off on on on on on on off on on off off off on on on on on on on on on on off) #30(off off off off off on on on on on on on on off on on off off off on on on on on on on on on on off) #30(off off off off off off on on on on off on on off on on off off off on on on on on on on on on on off) #30(off off off off off off off on on off off off on off on on on on on on on on on on on off off on on off) #30(off off off off off off off off on on off on on off on on on on on on on on on on off off off off on off) #30(off off off off off off off off off on on on on off on on on on off on on on on on off off off off on off) #30(off off off off off off off off off off on on on off on on on on on on on on on on on off off on on off) #30(off off off off off off off off off off off on on off on on on on on on off off off on on on on on on off) #30(off off off off off off off off off off off off on off on on on on off off off off off off off on on on on off) #30(off off off off off off off off off off off off off on on on on off off off off off off off off off on on on off) #30(off) #30(off off off off off off off off off off off off off off off off off off off off on off) #30(off off off off off off off off off off off off off off off off off off off on on off) #30(off off off off off off off off off off off off off off off off off off on on on off off on on off) #30(off off off off off off off off off off off off off off off off off off on on on on off on off) #30(off off off off off off off off off off off off off off off off off on on on on on on on off off off off on off) #30(off off off off off off off off off off off off off off off off on on on off off on on on on on on on on off) #30(off off off off off off off off off off off off off off off off off on off off off off on on on on on on on off) #30(off off off off off off off off off off off off off off off off off off off off off off off on on on on on on off) #30(off off off off off off off off off off off off off off off off off off off off off off off off off on on on on off) #30(off off off off off off off off off off off off off off off off off off off off off off off off off off on on on off) #30(off off off off off off off off off off off off off off off off off off off off on on on off off off off off on off) #30(off off off off off off off off off off off off off off off off off off off on on off on on on off off on on off) #30(off off off off off off off off off off off off off off off off off off off off off off off off on on on on off)))) (make-problem "19980716bGAS (2)" (quote ((5) (5 4 1) (8 5 4) (10 4 7) (10 13) (10 9) (10 9) (10 9) (10 2 9) (10 2 9) (10 6 9) (10 6 9) (10 1 4 1 9) (10 3 4 3 9) (10 10 9) (10 12 9) (10 10 9) (10 6 9) (10 1 2 1 9) (10 2 9) (10 2 9) (10 2 9) (10 9) (10 9) (10 9) (14 9) (8 4 9) (5 5 8) (2 4 5) (5))) (quote ((26) (26) (26) (26) (26) (26) (26) (26) (26) (26) (1 1) (1 1) (2 1 1 1) (1 5 2) (1 4 1) (2 2 5 1) (1 8 2) (1 14 1) (1 14 1) (2 8 1) (1 2 5 2) (1 4 1) (2 5 1) (1 1 1 2) (1 1) (1 1) (26) (26) (26) (26) (26) (26) (26) (26) (26))) (quote #35(#30(off off off on on on on on on on on on on on on on on on on on on on on on on on on on on off) #30(off off off on on on on on on on on on on on on on on on on on on on on on on on on on on off) #30(off off on on on on on on on on on on on on on on on on on on on on on on on on on on off) #30(off off on on on on on on on on on on on on on on on on on on on on on on on on on on off) #30(off off on on on on on on on on on on on on on on on on on on on on on on on on on on off) #30(off on on on on on on on on on on on on on on on on on on on on on on on on on on off) #30(off on on on on on on on on on on on on on on on on on on on on on on on on on on off) #30(off on on on on on on on on on on on on on on on on on on on on on on on on on on off) #30(on on on on on on on on on on on on on on on on on on on on on on on on on on off) #30(on on on on on on on on on on on on on on on on on on on on on on on on on on off) #30(on off off off off off off off off off off off off off off off off off off off off off off off off on off) #30(on off off off off off off off off off off off off off off off off off off off off off off off off on off) #30(on on off off off off off off off off off off off on off on off off off off off off off off off on off) #30(off on off off off off off off off off off off on on on on on off off off off off off off off on on off) #30(off on off off off off off off off off off off off on on on on off off off off off off off off off on off) #30(off on on off off off off off off off on on off off on on on on on off off off off off off off on off) #30(off off on off off off off off off off on on on on on on on on off off off off off off off off on on off) #30(off off on off off off off off on on on on on on on on on on on on on on off off off off off on off) #30(off off on off off off off off on on on on on on on on on on on on on on off off off off off on off) #30(off off on on off off off off off off on on on on on on on on off off off off off off off off off on off) #30(off off off on off off off off off off on on off off on on on on on off off off off off off off off on on off) #30(off off off on off off off off off off off off off on on on on off off off off off off off off off off off on off) #30(off off off on on off off off off off off off on on on on on off off off off off off off off off off off on off) #30(off off off off on off off off off off off off off on off on off off off off off off off off off off off off on) #30(off off off off on off off off off off off off off off off off off off off off off off off off off off off off off on) #30(off off off off on off off off off off off off off off off off off off off off off off off off off off off off off on) #30(off off off off on) #30(off off off off on) #30(off off off on on on on on on on on on on on on on on on on on on on on on on on on on on off) #30(off off off on on on on on on on on on on on on on on on on on on on on on on on on on on off) #30(off off off on on on on on on on on on on on on on on on on on on on on on on on on on on off) #30(off off on on on on on on on on on on on on on on on on on on on on on on on on on on off) #30(off off on on on on on on on on on on on on on on on on on on on on on on on on on on off) #30(off off on on on on on on on on on on on on on on on on on on on on on on on on on on off) #30(off on on on on on on on on on on on on on on on on on on on on on on on on on on off)))) (make-problem "19981201-JAM (3)" (quote ((8 7 18) (7 1 5 1 5 10) (7 2 3 3 3 2 9) (6 4 5 3 9) (3 7 5 5 8) (3 3 6 2 1 6 3) (4 3 3 2 7 3) (5 3 1 3 4 2 5 1 3) (6 3 4 3 2 2 3) (6 2 1 1 4 4 3 3) (5 2 3 6 2 3 1 3 2) (3 2 3 1 4 4 1 2 4 1) (2 2 3 2 3 5 4 4) (3 2 4 2 5 1 4 2 1) (3 2 5 1 4 3 4 1 1) (3 1 3 3 3 4 5 2) (2 1 3 4 1 2 1 6 4 2) (1 3 2 5 1 1 7 3 3) (4 3 2 1 2 3 1 3 2) (1 3 3 3 5 1 3 1) (2 4 3 2 7 2) (3 3 2 2 4 5 4 3 1) (4 4 5 4 3 3 2) (6 4 6 2 2 1 4 2) (6 3 2 4 1 4 6 1) (6 2 5 2 6 4) (5 2 1 6 1 8 2) (4 2 3 6 2 3 5) (5 2 2 1 2 2 1 6) (9 4 6 4 7))) (quote ((18 11) (17 1 10) (12 3 2 9) (4 5 5 8) (4 1 4 1 2 5 4 2) (4 2 2 2 1 1 3 3 1 1) (3 3 2 4 2 2 1) (1 2 5 2 5 5 1) (5 3 3 1 2 5 1 1) (1 5 1 3 2 1 4 3) (2 5 3 2 3 2 1 2) (3 3 1 1 3 3 2 3 1) (3 2 3 4 2 3 3 2) (3 2 2 1 3 1 2 2 2 2) (2 1 2 2 3 2 3 3 1) (1 4 4 1 1 5 3) (5 1 6 1 1 5 2 1) (1 3 2 4 1 1 5 1 1) (2 2 2 2 3 1 2 3 1 1) (3 2 1 1 6 4 2 1) (3 6 1 6 2) (3 2 2 5 2 5 2 2) (2 3 3 3 3 4 4) (1 5 3 1 5 2 5 1) (1 6 3 6 1 4 2) (2 4 2 1 5 2 3 2) (4 4 3 2 4 3 1) (5 3 6 1 3 1 3) (5 2 1 6 1 1 2 2 1) (5 1 4 6 4 2) (5 6 6 5 3) (5 4 2 2 5 3) (10 4 1 1 1 2 3) (11 1 4 2 4) (12 7 4 4))) (quote #35(#30(on on on on on on on on on on on on on on on on on on off on) #30(on on on on on on on on on on on on on on on on on off on off on) #30(on on on on on on on on on on on on off on on on off on on off off on) #30(on on on on off off on on on on on off off off off off on on on on on off on) #30(on on on on off on off on on on on off on off on on off on on on on on off on on on on off on) #30(on on on on off on on off on on off on on off on off on off off on on on off on on on off on off on) #30(on on on off off on on on off off on on off off off on on on on off on on off off off off on on off on) #30(on off off on on off on on on on on off on on off on on on on on off off on on on on on off off on) #30(off on on on on on off on on on off on on on off on off off on on off on on on on on off on off on) #30(on off on on on on on off on off on on on off off off on on off on off on on on on off on on on off) #30(on on off on on on on on off on on on off on on off on on on off off off on on off on off on on off) #30(on on on off on on on off on off on off on on on off on on on off on on off off on on on off off on) #30(on on on off on on off on on on off on on on on off on on off on on on off off on on on off on) #30(on on on off on on off on on off on off off on on on off on off on on off on on off on on off on) #30(on on off on off off off on on off on on off off on on on off on on off on on on off on on on off on) #30(on off on on on on off off off off on on on on off on off on off off on on on on on off on on on off) #30(off on on on on on off on off on on on on on on off on off on off on on on on on off on on off on) #30(on off on on on off on on off on on on on off off off on off on off off on on on on on off on off on) #30(on on off on on off on on off on on off off on on on off on off on on off off on on on off on off on) #30(on on on off on on off on off on off on on on on on on off off on on on on off off off on on off on) #30(on on on off off off off off off off on on on on on on off on off on on on on on on off off off on) #30(on on on off on on off on on off on on on on on off on on off on on on on on off on on off on) #30(on on off on on on off on on on off on on on off on on on off on on on on off on on on on off) #30(on off on on on on on off on on on off on off on on on on on off on on off on on on on on off on) #30(on off on on on on on on off on on on off on on on on on on off on off off on on on on off on) #30(on on off off on on on on off on on off on off on on on on on off off on on off on on on off on) #30(on on on on off on on on on off off on on on off off on on off off on on on on off on on on off on) #30(on on on on on off on on on off on on on on on on off off on off on on on off on off on on on off) #30(on on on on on off on on off on off off on on on on on on off on off on off on on off on on off on) #30(on on on on on off on off on on on on off on on on on on on off off off on on on on off off on) #30(on on on on on off off on on on on on on off on on on on on on off on on on on on off on) #30(on on on on on off off off off off on on on on off on on off on on off on on on on on off on) #30(on on on on on on on on on on off on on on on off off on off on off on off off on on off on) #30(on on on on on on on on on on on off on off off on on on on off off off on on off off on) #30(on on on on on on on on on on on on off on on on on on on on off on on on on off on)))) (make-problem "19990205-FRA (4)" (quote ((11 23) (10 1 11 4 2) (9 3 9 1 1) (8 5 8 1) (7 7 7 1) (6 9 6 1) (5 11 6 2) (4 13 6 3) (3 15 6 4) (2 17 6 5) (1 6 6) (1 1 1 13) (1 2 2 13) (1 3 3 5 5) (1 5 5 4 4) (1 6 6 4 4) (1 7 8 3 4) (1 8 8 3 1) (1 7 3 7 3) (1 6 5 6 3) (1 5 7 5 3) (1 4 9 4 3 1) (1 3 11 3 3 3) (1 2 13 2 13) (1 1 15 1 13) (1 17 13) (1 13) (35) (35) (35))) (quote ((30) (10 3) (9 14 3) (8 1 12 1 3) (7 2 10 2 3) (6 3 8 3 3) (5 4 7 4 3) (4 5 5 5 3) (3 6 3 6 3) (2 7 1 7 3) (1 8 8 3) (9 8 3) (1 8 8 3) (2 7 2 7 3) (3 6 3 6 3) (4 5 5 5 3) (5 4 7 4 3) (6 3 8 3 3) (7 2 10 2 3) (8 1 12 1 3) (9 14 3) (10 3) (30) (2 24) (1 23) (1 8 7) (2 5 7) (2 3 7) (3 2 7) (2 3 7) (1 5 7) (1 9 7) (1 10 8) (2 11 8) (18 9))) (quote #35(#30(on) #30(on on on on on on on on on on off off off off off off off off off off off off off off off off off on) #30(on on on on on on on on on off off on on on on on on on on on on on on on on off off on) #30(on on on on on on on on off on off off on on on on on on on on on on on on off on off on) #30(on on on on on on on off on on off off off on on on on on on on on on on off on on off on) #30(on on on on on on off on on on off off off off on on on on on on on on off on on on off on) #30(on on on on on off on on on on off off off off on on on on on on on off on on on on off on) #30(on on on on off on on on on on off off off off off on on on on on off on on on on on off on) #30(on on on off on on on on on on off off off off off off on on on off on on on on on on off on) #30(on on off on on on on on on on off off off off off off off on off on on on on on on on off on) #30(on off on on on on on on on on off off off off off off off off on on on on on on on on off on) #30(off on on on on on on on on on off off off off off off off off on on on on on on on on off on) #30(on off on on on on on on on on off off off off off off off off on on on on on on on on off on) #30(on on off on on on on on on on off off off off off off on on off on on on on on on on off on) #30(on on on off on on on on on on off off off off off off on on on off on on on on on on off on) #30(on on on on off on on on on on off off off off off on on on on on off on on on on on off on) #30(on on on on on off on on on on off off off off on on on on on on on off on on on on off on) #30(on on on on on on off on on on off off off off on on on on on on on on off on on on off on) #30(on on on on on on on off on on off off off on on on on on on on on on on off on on off on) #30(on on on on on on on on off on off off on on on on on on on on on on on on off on off on) #30(on on on on on on on on on off off on on on on on on on on on on on on on on off off on) #30(on on on on on on on on on on off off off off off off off off off off off off off off off off off on) #30(on) #30(on on off off off off on) #30(on off off off off off off on) #30(on off off off off off off off on on on on on on on on off off off off off off off on) #30(on on off off off off off off off on on on on on off off off off off off off off off on) #30(on on off off off off off off off off on on on off off off off off off off off off off on) #30(on on on off off off off off off off off on on off off off off off off off off off off on) #30(on on off off off off off off off off on on on off off off off off off off off off off on) #30(on off off off off off off off off on on on on on off off off off off off off off off on) #30(on off off off off off off off on on on on on on on on on off off off off off off on) #30(on off off off off off off on on on on on on on on on on off off off off off on) #30(on on off off off off on on on on on on on on on on on off off off off off on) #30(on on on on on on on on on on on on on on on on on on off off off on)))) (make-problem "19991010aTPV (5)" (quote (() () (12) (7 7) (8 4 8) (3 3 3 3) (3 4 8 4 3) (4 10 4) (11 11) (9 4 9) (9 9) (1 18 3) (3 14 7) (1 3 2 2 2 3 1 1 3) (2 1 10 1 1 3 1) (3 1 1 1 1 1 1 1 3) (4 1 1 1 1 1 2 1 2) (3 3 1 1 1 3 1 1 2) (5 14 6 3) (7 2 2 2 10 1 2) (22 6) (18 2 2) (12 3 2) (2 1 2) (1 1 2) (1 1 2) (2 3 1) (3 3) (5) ())) (quote (() (3 4) (5 6) (17) (2 4 1 1 3) (2 1 5 5) (2 1 4 5 3) (2 1 6 5) (3 1 6 5) (4 6 5 3) (13 5) (2 4 5 5) (1 1 2 1 2 1 1 3) (1 1 2 1 12) (1 1 2 1 4 5) (1 1 2 1 2 1 1 3) (2 4 5 5) (21) (4 6 1 1 3) (3 1 6 5) (2 1 6 5) (2 1 4 5 3) (2 1 5 5) (2 4 1 1 3) (17) (5 2 2 6) (3 3 2 1 3) (1 6 1 2) (3 2 1 1 1) (2 9) (1 1 3 2) (3 1 1 1 1) (12) (8) ())) (quote #35(#30(off) #30(off off off off off off on on on off off off off off off on on on on off) #30(off off off off off on on on on on off off off off on on on on on on off) #30(off off off off on on on on on on on on on on on on on on on on on off) #30(off off off off on on off on on on on off on off off off on off on on on off) #30(off off off on on off on off on on on on on off off off off on on on on on off) #30(off off off on on off on off on on on on off on on on on on off on on on off) #30(off off off on on off on off on on on on on on off off off on on on on on off) #30(off off on on on off on off on on on on on on off off off off on on on on on off) #30(off off on on on on off on on on on on on off on on on on on off on on on off) #30(off off on on on on on on on on on on on on on off off off on on on on on off) #30(off off on on off on on on on off on on on on on off off off on on on on on off) #30(off off on off on off on on off on off on on off on off off off on off on on on off) #30(off off on off on off on on off on off on on on on on on on on on on on on off) #30(off off on off on off on on off on off on on on on off off off on on on on on off) #30(off off on off on off on on off on off on on off on off off off on off on on on off) #30(off off on on off on on on on off on on on on on off off off on on on on on off) #30(off off on on on on on on on on on on on on on on on on on on on on on off) #30(off off on on on on off on on on on on on off on off off off on off on on on off) #30(off off on on on off on off on on on on on on off off off off on on on on on off) #30(off off off on on off on off on on on on on on off off off on on on on on off) #30(off off off on on off on off on on on on off on on on on on off on on on off) #30(off off off on on off on off on on on on on off off off off on on on on on off) #30(off off off off on on off on on on on off on off off off on off on on on off) #30(off off off off on on on on on on on on on on on on on on on on on off) #30(off off off off off on on on on on off on on off off off off off on on off off off on on on on on on off) #30(off off off off off off on on on off off on on on off off off off on on off off off on off off on on on off) #30(off off off off off off off off off off off off on off on on on on on on off off on off off off off on on off) #30(off off off off off off off off off off off off on on on off off off off on on off on off off off on off on off) #30(off off off off off off off off off off off off off on on off off off off off on on on on on on on on on off) #30(off off off off off off off off off off off off off on off on off off off on on on off off off off on on off) #30(off off off off off off off off off off off off off off on on on off on off on off off off off on off on off) #30(off off off off off off off off off off off off off off off on on on on on on on on on on on on off) #30(off off off off off off off off off off off off off off off off off on on on on on on on on off) #30(off)))) (make-problem "19991118-BDH (6)" (quote ((35) (1 1) (1 7 1) (1 11 4) (5 11 1 1) (1 1 15 3 1) (1 1 1 3) (1 6 3 1) (1 1 5 1) (1 1 1 1) (1 3 12) (8 1) (1 1) (1 1) (3 3) (1 11 5 1) (1 1 1 1) (13 1 1) (2 2 1) (2 8) (2 7 1) (1 9 1) (1 7 7 1) (1 8 5 8 1) (1 9 5 9 1) (1 11 3 11 1) (1 12 3 12 1) (1 12 1 12 1) (1 12 3 12 1) (1 12 3 12 1))) (quote ((30) (1 1 1 1 4) (1 1 1 2 1 4) (1 1 1 1 1 5) (1 4 1 1 1 6) (1 1 1 1 1 7) (1 1 1 1 1 8) (1 1 2 1 1 8) (1 1 1 1 1 8) (1 4 1 1 8) (1 1 1 1 8) (1 1 1 1 8) (1 3 3 8) (1 3 1 5) (1 4 2) (1 4 2 2) (1 4 2 4 2) (1 4 2 7) (1 4 2 4 2) (1 4 2 2) (1 4 2) (1 3 1 5) (1 3 8) (1 1 3 8) (1 1 1 1 8) (1 1 1 8) (1 1 1 8) (1 2 1 2 8) (1 1 1 5 8) (1 3 1 1 1 7) (1 1 1 1 1 6) (1 3 1 1 1 5) (1 1 1 1 2 1 4) (1 1 1 1 1 1) (30))) (quote #35(#30(on) #30(on off off off on off off off off off off on off off on off off on on on on off) #30(on off off off on off off off off off off on off off on on off on off off off off off off off off on) #30(on off off off on off off off off off off on off off off on off on off off off off off off off on) #30(on off off off on on on on off off off on off off off on off on off off off off off off on) #30(on off off off off off off on off off off on off off off on off on off off off off off on) #30(on off off off off off off on off off off on off off off on off on off off off off on) #30(on off off off off off off on off off on on off off off on off on off off off off on) #30(on off off off off off off on off off on off off off off on off on off off off off on) #30(on off off off off off off on on on on off off off off on off on off off off off on) #30(on off off off off on off off off off off off off off off on off on off off off off on) #30(on off off off off on off off off off off off off off off on off on off off off off on) #30(on off off on on on off off off off off off off off off on on on off off off off on) #30(on off off on on on off off off off off off off off off off off off off off off on off off off on) #30(on off on on on on off off off off off off off off off off off off off off on on off) #30(on off on on on on off off off off off off off off off off off off off off on on off on on off) #30(on off on on on on off off off off off off off off off off off off off off on on off on on on on off on) #30(on off on on on on off off off off off off off off off off off off off off on on off on) #30(on off on on on on off off off off off off off off off off off off off off on on off on on on on off on) #30(on off on on on on off off off off off off off off off off off off off off on on off on on off) #30(on off on on on on off off off off off off off off off off off off off off on on off) #30(on off off on on on off off off off off off off off off off off off off off off on off off off on) #30(on off off on on on off off off off off off off off off off off off off off off off on) #30(on off off off off on off off on on on off off off off off off off off off off off on) #30(on off off off off on off off on off on off off off off off off off off off off off on) #30(on off off off off off off off on off on off off off off off off off off off off off on) #30(on off off off off off off off on off on off off off off off off off off off off off on) #30(on off off off off off off on on off on off off off off off off off on on off off on) #30(on off off off off off off on off off on off off off off on on on on on off off on) #30(on off off off off on on on off off on off off off off on off off off on off off off on) #30(on off off off off on off off off off on off off off off on off off off on off off off off on) #30(on off off on on on off off off off on off off off off on off off off on off off off off off on) #30(on off off on off off on off off off on off off off on on off off off on off off off off off off on) #30(on off off on off off on off off off on off off off on off off off off on off) #30(on)))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/solution-sets/k35x35 b/collects/games/paint-by-numbers/solution-sets/k35x35
new file mode 100644
index 0000000000..e019e45906
--- /dev/null
+++ b/collects/games/paint-by-numbers/solution-sets/k35x35
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 35x35") (define problems (list (make-problem "19981015aGAS (1)" (quote ((17) (1 2) (1 1 1) (17 1) (1 1 1) (1 1 1) (1 1 1) (1 1 1 1 1) (1 5 1 1) (1 1 1) (1 1 1) (1 1 1) (17 1) (1 1 1) (1 1 1) (1 1 1) (1 1 1 1 1) (1 5 1 1) (1 1 1) (1 1 1) (1 1 1) (17 1) (1 1 1 1 1 1 1 2 1) (1 1 1 1 1 1 1 3 1) (1 1 1 1 1 1 1 2 1 1) (16 1 1) (1 1 1 1) (1 1 1 1) (1 1 1 1 1 1) (1 6 1 1 1) (1 1 2 1) (1 2 1 1) (16 1 1) (1 2) (18))) (quote (() () () () () () () (8) (2 3) (19 1 1 1 1) (2 1 2 2 1 1) (1 1 1 1 1 1 1 1) (1 1 1 2 2 2 1 1) (1 1 1 1 1 1 1 1 1) (1 1 1 2 2 1 1 1) (1 1 2 1 2 1 1 1 1 1 1) (1 1 1 1 1 2 2 1 1 1) (1 1 1 1 1 1 1 1 2 1 1) (1 1 1 1 1 2 2 1 1) (1 1 2 1 2 1 1 1 1 1) (1 1 1 2 2 1 1) (1 1 1 1 1 1 1 1) (1 1 1 2 9 1) (1 1 1 1 2 1 1) (1 1 1 3 1 1) (1 32) (1 1 1) (2 1) (32) () () () () () ())) (quote #f)) (make-problem "19990202-SQU (2)" (quote ((3 3 3 2 3) (3 3 1 1 3 1 1 1) (3 1 1 1 3 3 2 1) (3 1 1 3 1 1 1) (3 3 3 2 1) (3 3) (26) (2 3 3 2) (2 5 3) (2 3 4) (30) (1 3 1) (1 2 1) (1 16 1 2) (1 16 2 1 3) (1 2 2 2 5) (1 2 2 5) (1 2 2 3 1) (1 2 2 2 2 1) (1 2 2 2 1 2) (1 2 2 1 3) (1 2 2 5) (1 2 2 2 5) (1 2 2 4 3 1) (1 2 2 4 2 1) (1 2 2 2 1 2) (1 2 2 1 3) (4 2 2 7) (1 1 16 5 1) (1 1 16 4 1) (1 1 3 1) (1 27 1) (1 1) (1 1) (35))) (quote ((8) (1 1) (1 1) (1 22 1) (2 2 1 1) (3 3 1 1) (3 2 1 17 1 1) (3 2 1 17 1 1) (4 1 2 2 1 1) (3 1 2 2 1 1) (1 3 1 2 2 1 1) (3 3 1 2 2 1 1) (1 5 2 2 1 1) (1 3 2 2 1 1) (2 5 2 2 1 1) (1 3 1 2 2 1 1) (2 3 1 2 2 1 1) (3 1 2 2 1 1) (4 1 2 2 1 1) (3 1 1 2 2 1 1) (3 1 1 17 1 1) (3 1 1 17 1 1) (2 1 1 1 1) (1 1 1 2 1 1) (1 1 2 2 4 1 1) (3 1 1 1 2 2 4 1 1) (1 1 1 1 1 2 1 1) (1 3 1 1 1 1) (1 22 1) (5 1 4 4 4 5 1) (1 1 1 1 4 4 4 5 1) (5 4 4 5 1) (1 23 1) (5 1 1) (1 8))) (quote #f)) (make-problem "19990220-JOJ (3)" (quote ((35) (13 6 14) (12 4 13) (11 2 12) (10 11) (5 5) (5 6) (6 7) (7 8) (8 1 1 1 1 1 1 9) (6 1 3 1 1 3 1 7) (4 1 1 1 1 1 1 5) (2 1 2 1 1 2 1 3) (3 1 3 1 1 3 1 4) (4 1 3 1 1 3 1 5) (5 1 1 1 1 6) (6 1 3 1 1 3 1 7) (5 2 1 1 2 6) (4 2 3 4 3 2 5) (3 1 4 4 1 4) (4 1 2 2 1 5) (6 1 1 7) (8 1 2 2 1 9) (8 2 3 3 2 9) (9 1 6 1 10) (10 1 1 11) (13 14) (11 1 1 2 1 1 12) (12 1 1 1 1 13) (11 12) (10 11) (8 9) (7 4 4 8) (6 14 7) (5 16 6))) (quote ((35) (35) (12 22) (12 5 15) (11 3 14) (5 4 1 13) (5 2 11) (5 1 4 10) (5 1 2 1 7) (5 1 3 3 6 1) (4 1 1 1 2 1 4 2) (3 1 2 1 3 1 1 1 1 3) (2 2 3 1 3 2 3 3) (1 1 3 1 1 1 1 3) (2 1 1 1 2 1 3) (3 1 3 3 1 1 2) (4 1 1 1 2) (4 1 1 1 2) (3 1 3 3 1 1 2) (2 1 1 1 2 1 3) (1 1 3 1 1 1 1 3) (2 2 3 1 3 2 3 3) (3 1 2 1 3 1 1 1 1 3) (4 1 1 1 2 1 4 2) (5 1 3 3 6 1) (5 1 2 1 7) (5 1 4 10) (5 2 11) (5 4 1 13) (5 5 3 14) (12 5 15) (12 22) (35) (35) (35))) (quote #35(#35(on) #35(on) #35(on on on on on on on on on on on on off on) #35(on on on on on on on on on on on on off off on on on on on off on) #35(on on on on on on on on on on on off off off off on on on off off off on) #35(on on on on on off off on on on on off off off off off on off off off off on on on on on on on on on on on on on off) #35(on on on on on off off off on on off off off off off off off off off off off off on on on on on on on on on on on off) #35(on on on on on off off off off on off off off off off off on on on on off off on on on on on on on on on on off) #35(on on on on on off off off off off off on off off off off off on on off on off off off on on on on on on on off) #35(on on on on on off off off off off on off on on on off off off off off off on on on off on on on on on on off off off on) #35(on on on on off off off off off on off on off off off on off off on on off off off on off off on on on on off off off on) #35(on on on off off off off off off off on off off on on off on off on on on off on off on off on off on off off off on) #35(on on off off off off off off off on on off on on on off on off on on on off on on off on on on off off off off on) #35(on off off off off off off off off off on off on on on off on off off on off off off on off off off off on off off off on) #35(on on off off off off off off off on off on off off off on off off off off off off off on on off off on off off off off on) #35(on on on off off off off off off off on off on on on off on on on off off off off off on off off off on off off off off on) #35(on on on on off off off off off off off off off off off off off off on off off off off off on off off on off off off off off on) #35(on on on on off off off off off off off off off off off off off off on off off off off off on off off on off off off off off on) #35(on on on off off off off off off off on off on on on off on on on off off off off off on off off off on off off off off on) #35(on on off off off off off off off on off on off off off on off off off off off off off on on off off on off off off off on) #35(on off off off off off off off off off on off on on on off on off off on off off off on off off off off on off off off on) #35(on on off off off off off off off on on off on on on off on off on on on off on on off on on on off off off off on) #35(on on on off off off off off off off on off off on on off on off on on on off on off on off on off on off off off on) #35(on on on on off off off off off on off on off off off on off off on on off off off on off off on on on on off off off on) #35(on on on on on off off off off off on off on on on off off off off off off on on on off on on on on on on off off off on) #35(on on on on on off off off off off off on off off off off off on on off on off off off on on on on on on on off) #35(on on on on on off off off off on off off off off off off on on on on off off on on on on on on on on on on off) #35(on on on on on off off off on on off off off off off off off off off off off off on on on on on on on on on on on off) #35(on on on on on off off on on on on off off off off off on off off off off on on on on on on on on on on on on on off) #35(on on on on on off on on on on on off off off off on on on off off off on) #35(on on on on on on on on on on on on off off on on on on on off on) #35(on on on on on on on on on on on on off on) #35(on) #35(on) #35(on)))) (make-problem "19990416-SNI (4)" (quote ((8 15 5) (7 2 13 6) (6 2 12 7) (5 2 11 4 8) (5 1 10 4 9) (4 1 10 3 2 8) (4 1 2 4 1 7) (4 11 5 3 6) (4 11 6 5 5) (3 12 5 7 4) (3 12 5 8 3) (3 1 5 4 3 10 2) (2 1 3 1 4 2 9 3) (2 1 1 3 2 4 1 9 4) (1 3 5 6 9 5) (1 5 11 8 6) (1 10 4 6 7) (1 1 1 2 1 4 4 9) (1 3 2 3 4 3 10) (2 15 1 1 11) (3 13 2 2 10) (3 1 10 4 3 9) (3 1 6 7 3 8) (3 1 5 7 1 2 9) (3 1 4 3 3 3 10) (3 4 2 8 11) (4 6 9 10) (4 17 9) (5 8 7 10) (5 8 7 11) (6 8 6 12) (6 8 4 13) (5 2 4 14) (4 3 5 4 15) (4 6 16))) (quote ((35) (14 16) (12 2 1 15) (9 8 9) (5 3 3 7 5) (3 2 3 1 3 2 2 2 1) (2 2 5 3 12 2) (1 2 1 8 1 13 2) (2 2 11 13 1) (1 3 11 13 2) (4 5 3 6 6 2) (6 4 1 8 2 5 2) (6 4 2 2 4 3 5 2) (6 5 2 6 6 2) (6 9 5 3 2) (6 10 12 1 1) (6 1 10 9 2) (5 1 3 8 13) (4 2 4 5 3 9) (4 1 7 1 3 9 1) (3 2 6 3 3 8 2) (3 1 5 6 8 3) (2 2 3 11 4) (2 2 2 10 4 5) (1 1 2 10 1 3 1 6) (1 1 1 10 3 1 3 7) (1 10 5 12) (3 9 18) (5 7 19) (7 5 20) (9 3 21) (10 1 22) (11 23) (35) (35))) (quote #35(#35(on) #35(on on on on on on on on on on on on on on off off off off off on) #35(on on on on on on on on on on on on off off on on off off on off on) #35(on on on on on on on on on off off off on on on on on on on on off off off off off off on) #35(on on on on on off off off off on on on off off on on on off on on on on on on on off off off on on on on on off) #35(on on on off off on on off on on on off off on off on on on off on on off off off off off on on off off on on off on off) #35(on on off on on off off on on on on on off off on on on off on on on on on on on on on on on on off off on on off) #35(on off on on off on off on on on on on on on on off on off on on on on on on on on on on on on on off on on off) #35(off on on off on on off on on on on on on on on on on on off on on on on on on on on on on on on on off off on) #35(off on off on on on off on on on on on on on on on on on off on on on on on on on on on on on on on off on) #35(off off on on on on off on on on on on off off on on on off on on on on on on off off on on on on on on off on) #35(on on on on on on off on on on on off off on off on on on on on on on on off on on off on on on on on off on) #35(on on on on on on off on on on on off on on off on on off on on on on off on on on off on on on on on off on) #35(on on on on on on off on on on on on off off on on off off off on on on on on on off on on on on on on off on) #35(on on on on on on off on on on on on on on on on off off off on on on on on off on on on off off on on off) #35(on on on on on on off on on on on on on on on on on off on on on on on on on on on on on on off on off on off) #35(on on on on on on off on off off off on on on on on on on on on on off on on on on on on on on on off on on off) #35(on on on on on off on off on on on off on on on on on on on on off on on on on on on on on on on on on on off) #35(on on on on off on on off on on on on off off on on on on on off off on on on off on on on on on on on on on off) #35(on on on on off on off on on on on on on on off off off on off off on on on off on on on on on on on on on off on) #35(on on on off on on off on on on on on on off on on on off off on on on off off on on on on on on on on off on) #35(on on on off on off on on on on on off off on on on on on on off off off off on on on on on on on on off on) #35(on on off on on off on on on off off on on on on on on on on on on on off off off off off off off off off on) #35(on on off on on off on on off on on on on on on on on on on off on on on on off off off off off off on) #35(on off off on off on on off on on on on on on on on on on off on off on on on off on off off off on) #35(on off off on off on off on on on on on on on on on on off on on on off on off on on on off on) #35(off off off off on off on on on on on on on on on on off on on on on on off on) #35(off off off on on on off on on on on on on on on on off on) #35(off off on on on on on off on on on on on on on off on) #35(off on on on on on on on off on on on on on off on) #35(on on on on on on on on on off on on on off on) #35(on on on on on on on on on on off on off on) #35(on on on on on on on on on on on off on) #35(on) #35(on)))) (make-problem "19990520-TAM (5)" (quote ((1 1) (1 1 2) (1 1 1 1) (1 1 1 1) (1 1 1) (1 1 18 2) (1 1 20 2) (2 2 2 14 2) (2 2 3 2 2 3) (6 6) (5 2 2 5) (3 4 4 3) (3 4 4 3) (3 2 2 3) (1 3 3) (2 24) (1 1 4 1 1 1 1 1 1 1 1 3) (1 24) (1 24) (2 24) (2 24) (1 2 2 2 2 2 1) (1 2 2 2 2 2 1) (24) (1 2 2 2 2 2 1) (1 2 2 2 2 2 1) (26) (26) (26) (26) (26) (2 2) (2 2) (2 2) (2 2))) (quote (() (2 2) (7 7) (1 1) (1 2 1) (8) (5) (23) (14 1 5) (15 1 9) (2 2 20) (2 2 1 14) (5 6 1 5) (4 2 1 4 1 5) (3 4 16) (3 4 1 14) (3 2 6 1 5) (3 1 4 1 5) (3 16) (3 1 14) (3 6 1 5) (3 2 1 4 1 5) (3 4 16) (3 4 1 14) (4 2 6 1 5) (5 1 4 1 5) (2 2 16) (2 2 1 18) (15 1 9) (14 1 5) (23) (2 5) (7) (1) (2))) (quote #35(#35(off) #35(off off off off off off off on on off off off off off off off off off off on on off) #35(off off on on on on on on on off off off off off on on on on on on on off) #35(off on off off off off off off off off off off off off off on off) #35(on off off off off off off on on off off off off off off off on off) #35(off on on on on on on on on off) #35(off off off off off off off off off off off off off off off off off off off off off off off off off off on on on on on off) #35(off off off off off off off off on on on on on on on on on on on on on on on on on on on on on on on off) #35(off off off off off off off on on on on on on on on on on on on on on off off on off off on on on on on off) #35(off off off off off off on on on on on on on on on on on on on on on off off on off off on) #35(off off off off off on on off off on on off off off off on) #35(off off off off off on on off off on on off off off off on off on on on on on on on on on on on on on on off) #35(off off off off off on on on on on off off off off off on on on on on on off off on off off on on on on on off) #35(off off off off off on on on on off off on on off off on off on on on on off off on off off on on on on on off) #35(off off off off off on on on off off on on on on off on on on on on on on on on on on on on on on on off) #35(off off off off off on on on off off on on on on off on off on on on on on on on on on on on on on on off) #35(off off off off off on on on off off off on on off off on on on on on on off off on off off on on on on on off) #35(off off off off off on on on off off off off off off off on off on on on on off off on off off on on on on on off) #35(off off off off off on on on off off off off off off off on on on on on on on on on on on on on on on on off) #35(off off off off off on on on off off off off off off off on off on on on on on on on on on on on on on on off) #35(off off off off off on on on off off off off off off off on on on on on on off off on off off on on on on on off) #35(off off off off off on on on off off off on on off off on off on on on on off off on off off on on on on on off) #35(off off off off off on on on off off on on on on off on on on on on on on on on on on on on on on on off) #35(off off off off off on on on off off on on on on off on off on on on on on on on on on on on on on on off) #35(off off off off off on on on on off off on on off off on on on on on on off off on off off on on on on on off) #35(off off off off off on on on on on off off off off off on off on on on on off off on off off on on on on on off) #35(off off off off off on on off off on on off off off off on on on on on on on on on on on on on on on on off) #35(off off off off off on on off off on on off off off off on off on) #35(off off off off off off on on on on on on on on on on on on on on on off off on off off on) #35(off off off off off off off on on on on on on on on on on on on on on off off on off off on on on on on off) #35(off off off off off off off off on on on on on on on on on on on on on on on on on on on on on on on off) #35(off off off off off on on off off off off off off off off off off off off off off off off off off off on on on on on off) #35(on on on on on on on off) #35(off on off) #35(off off on on off)))) (make-problem "19990830-KHO (6)" (quote ((35) (26 5) (7 12 3 4) (6 1 1 1 4 4 4) (5 2 1 1 2 2 3) (4 4 2 1 2) (3 6 1 1 7 1) (2 6 3 3 7) (1 6 1 3 1 6) (2 5 1 1 6) (4 4 4 3) (4 4 4 4) (2 4 5 4 7) (1 4 7 4 4 1) (2 4 3 1 3 4 2) (10 1 3 1 1 10) (9 1 3 9) (9 3 4 2) (9 1 3 1 3 3 3 1) (10 5 1 3 2 2) (12 2 3 3 4 1 1 1) (4 8 1 1 7 3 1) (3 9 3 8 1 2) (2 2 6 8 2 1) (2 1 1 4 9 2) (2 3 3 11) (3 8 12) (8 1 1 6) (7 1 1 5) (7 7 5) (7 1 1 7 1 1 5) (9 2 11 2 7) (35) (35) (35))) (quote ((9 22) (8 21) (7 2 8 9) (6 4 7 3 8) (5 4 6 2 1 8) (4 2 6 1 2 8) (3 1 10 9) (2 2 3 15 4) (2 22 4) (2 12 8 1 3) (2 9 5 1 4) (2 8 4 1 4) (3 4 2 1 1 3) (4 1 2 1 4) (3 1 2 3 1 1 1 4) (4 2 1 3 1 1 7) (3 2 2 1 3 1 6) (3 1 5 3 1 6) (3 2 2 1 3 1 6) (4 2 1 3 1 1 6) (5 2 3 1 1 6) (5 1 3 7) (4 4 3 4 1 4) (3 8 5 4 1 4) (2 1 9 3 7 1 3) (2 2 10 8 4) (1 3 21 4) (1 2 5 14 1 3) (1 1 2 3 5 5 4) (1 4 3 3 5 4) (2 4 2 2 2 11) (4 3 2 1 2 12) (5 2 2 2 2 10) (6 1 4 4 11) (7 7 12))) (quote #35(#35(on on on on on on on on on off off off off on) #35(on on on on on on on on off off off off off off on) #35(on on on on on on on off off off on on off off off on on on on on on on on off off off on) #35(on on on on on on off off off on on on on off off on on on on on on on off on on on off on) #35(on on on on on off off off off on on on on off off on on on on on on off on on off on off on) #35(on on on on off off off off off off on on off off off on on on on on on off on off on on off on) #35(on on on off on off off off off off off off off off on on on on on on on on on on off off on) #35(on on off on on off on on on off off off off on on on on on on on on on on on on on on on off off off on) #35(on on off off off on on on on on on on on on on on on on on on on on on on on on on off off off off on) #35(on on off off on on on on on on on on on on on on off off off on on on on on on on on off off off on off on) #35(on on off off off on on on on on on on on on off off off off off off on on on on on off on off off off off on) #35(on on off off off on on on on on on on on off off off off off off off on on on on off off on off off off off on) #35(on on on off off off on on on on off off off off off off off off off off off on on off off off on off off off on off on) #35(on on on on off off off off off off off off off off on off off off off off on on off off off off on off off off off on) #35(on on on off on off off on on off off off off on on on off off on off on off off off off off off on off off off on) #35(on on on on off off on on off on off off on on on off off off off on off on off off off off off off on) #35(on on on off off off off on on off off off on on off on off off on on on off on off off off off off off on) #35(on on on off off off off off on off off off on on on on on off on on on off on off off off off off off on) #35(on on on off off off off on on off off off on on off on off off on on on off on off off off off off off on) #35(on on on on off off on on off on off off on on on off off off off on off on off off off off off off off on) #35(on on on on on off off on on off off off off on on on off off on off on off off off off off off off off on) #35(on on on on on off off off off off off off off off on off off off off off on on on off off off off off on) #35(on on on on off off on on on on off off off off off off on on on off on on on on off off off on off off off on) #35(on on on off off on on on on on on on on off off on on on on on off on on on on off on off off off off on) #35(on on off on off on on on on on on on on on off off on on on off on on on on on on on off off off on off on) #35(on on off on on off on on on on on on on on on on off off off on on on on on on on on off off off off on) #35(on off on on on off on on on on on on on on on on on on on on on on on on on on on off off off off on) #35(on off on on off on on on on on off off off on on on on on on on on on on on on on on off off off on off on) #35(on off on off off off on on off off on on on off on on on on on off off off on on on on on off off off off on) #35(on off off off off off off off off off on on on on off on on on off on on on off on on on on on off off off on) #35(on on off off off off off off off off on on on on off on on off on on off on on off on) #35(on on on on off off off off off off off on on on off on on off on off on on off on) #35(on on on on on off off off off off off off on on off on on off on on off off on on off on) #35(on on on on on on off off off off off off on off on on on on off on on on on off on) #35(on on on on on on on off off off off off on on on on on on on off off off off on)))) (make-problem "19990904-PIP (7)" (quote ((29) (27 1) (1 1 2) (2 2 1) (1 1 28) (1 2 1 1) (1 4 9 1 9 1) (2 1 1 1 1 1 1) (1 1 1 1 3 1 1) (2 2 1 1 1 1) (1 1 4 1 2 1 1 1 1 1 1) (1 2 1 1 1 1 1 1 1 1 1 1 1 1) (1 4 1 2 1 1 1 1 2 1 1) (2 1 1 1 1 1 1 1 1 1 1 1 1) (1 1 1 1 2 1 1 1 1 1 1) (2 2 1 2 2 1) (1 1 4 1 1 1) (1 2 1 1 1 13 1 1 1) (1 4 1 1 1) (2 1 2 13 2 1) (1 1 1 1 1 1) (2 2 1 1 1 1) (1 1 4 1 1 1) (1 2 1 1 1 1) (1 4 1 1 1) (1 1 1 1 1) (2 1 1 1 1) (1 1 1 1 3 1 1) (1 2 1 1 1 1 1 1) (1 4 9 1 9 1) (2 1 1) (28) () () ())) (quote ((28) (2 1 1 1 1 1 1 1 1 1) (3 1 1 1 1 1 1 1 1 1) (2 1 1 1 1 1 1 1 1 1 1) (2 1 1 1 1 1 1 1 1 1 1) (2 1 1 1 1 1 1 1 1 1 1) (2 1 1 1 1 1 1 1 1 1 1) (2 1 1 1 1 1 1 1 1 1 1) (2 28) (2 1 1) (2 1 10 1 11 1) (2 1 1 1 1 1 1) (2 1 1 3 1 1) (2 1 1 5 1 1) (2 1 1 1 1 1 1 1 1 1) (2 1 1 1 1 1 1 1 1) (2 1 1 1 1 1 1) (2 1 1 3 1 1 1 1) (2 1 2 1 1 1 1 2 1) (2 1 1 3 1 1 1 1) (2 1 1 1 1 1 1 1 1) (2 1 1 3 1 1 1 1) (2 1 2 1 1 1 1 2 1) (2 1 1 3 1 1 1 1) (2 1 1 1 1 1 1) (2 1 1 5 1 1 1 1) (2 1 1 1 1 1 1 1) (1 1 1 1 2 2 1 1) (5 1 3 1 1) (1 1 1 1 1 1) (1 10 1 11 1) (1 1) (28) () ())) (quote #f)) (make-problem "19991007cKHO (8)" (quote ((3 3) (3 3) (3 4 3) (3 1 1 3) (5 3 5) (1 3 7) (1 3 3 2) (1 3 4 2 2) (1 2 2 1 2 3 2) (1 1 1 1 2 1 3) (1 1 1 2 5) (1 2 1 1 2 6) (1 3 1 2 6) (3 1 2 8) (3 3 1 2 6 3) (3 1 3 1 7 3) (3 1 3 1 5 4 3) (1 3 3 3 3 1 5) (1 3 7 3 7) (1 3 7 1 3 5 2) (1 3 5 3 1 1 5 3) (1 1 2 1 2 1 2 1 1 1 2 5) (1 1 1 1 2 1 2 1 1 1 2 3 2) (1 1 1 1 1 3 1 1 1 1 2 1 3) (1 1 1 1 1 2 1 1 1 1 2 5) (1 1 2 1 1 1 1 1 1 1 2 6) (1 2 1 1 3 1 1 2 1 2 6) (3 1 1 7 2 1 2 6) (3 1 1 5 3 1 2 4) (3 1 5 3 1 5) (3 3 3 3) (3 3) () () ())) (quote ((12) (1 1) (3 6 2) (1 1 1 1 1) (2 2 2 1 2) (1 1 1 1 1) (2 2 4 2) (1 2 1 1) (12 1 13) (2 1 1 1 1) (3 4 2 1 13) (1 1 2 2 1 4 2) (2 2 1 1 2 3 2 5) (1 1 2 1 1 2 4 4) (2 2 2 1 5 1 5) (1 2 1 6 2) (1 1 1 23) (1 1 1 1 1) (1 1 1 23) (1 1 12 1) (2 2 4 7 2) (1 1 2 6 1 2 1) (2 2 2 7 2 1 2) (1 2 2 6 1 1) (4 7 13) (12 2 1 1) (12 1 13) (1 1 12) (2 1 3 2) (1 2 2 5) (2 3 2 6) (1 2 2 5) (4 2 6) (12) (12))) (quote #f)))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/solution-sets/k35x40 b/collects/games/paint-by-numbers/solution-sets/k35x40
new file mode 100644
index 0000000000..e310a545cc
--- /dev/null
+++ b/collects/games/paint-by-numbers/solution-sets/k35x40
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 35x40") (define problems (list (make-problem "19980425-HUB (1)" (quote ((8 6 2 2 6) (8 8 2 2 8) (2 2 2 2 2 2 2) (2 2 2 2 2 2 2) (2 2 2 2 2 2 2) (2 2 8 6 8) (3 3 8 4 8) (6 2 2 2 2 2) (4 2 2 1 2 2 2) (1) (5 1 1 1 1 1 9) (3 1 1 1 1 1 6) (5 1 1 1 1 1 1 8) (3 1 1 1 1 1 6) (4 1 1 1 1 1 10) (2 1 1 1 1 1 5) (4 1 1 1 1 1 8) (2 1 1 1 1 1 5) (4 1 11 1 8) (5 1 1 1 5 1) (3 1 11 1 3) (1 21 1 3) (3 17 8) (2 3 9 7 2) (2 4 10 2) (2 9 1 7 2) (5 1 1 1 1 8 2) (2 1 1 1 1 6 2) (1 6 1 1 1 1 7 3) (1 2 1 1 1 1 9 1) (1 6 1 1 1 1 8 2) (1 2 1 1 1 8 4) (2 6 1 1 1 8 5) (2 3 1 1 1 6 6) (3 4 1 1 1 6 7) (4 2 1 1 6 8) (5 3 1 1 5 9) (7 9 11) (10 14) (35))) (quote ((2 2 9 12) (2 3 9 6 8) (2 3 5 1 1 1 9 6) (2 2 1 1 1 1 1 1 1 7 5) (2 2 1 1 1 1 1 1 4 4) (2 3 1 1 1 1 1 1 3 3) (8 2 4 1 1 1 1 1 4 3) (7 2 5 1 1 1 1 2 2) (1 2 1 1 1 1 2) (8 1 2 1 1 2) (9 1 2 1 3 1 1 1) (2 2 2 9 1 1 1) (2 2 1 4 1 1 1) (2 2 6 1 1 1) (2 2 3 4 4 2 1 1 1 1 2 1) (9 2 1 4 1 1 1 1 1 1 1 1) (8 1 4 2 1 1 1 1 2 1) (2 7 1 1 1 1 1 1 1 1) (4 3 4 1 4 2 1 1 1 1 2 1) (6 1 4 1 1 1 1 1 3 1) (3 1 3 1 1 1 1 1 3 1) (4 1 2 2 1 1 6 2) (4 2 6 1 1 1 7 2) (3 2 3 1 2 12 2) (6 1 1 13 3) (4 1 1 1 1 12 3) (1 1 1 11 4) (8 1 1 1 1 1 1 11 5) (9 1 1 1 1 1 1 10 6) (2 2 5 1 1 6 2 7) (2 2 9 2 2 8) (2 2 9 2 2 9) (2 2 9 2 2 9) (9 9 7 10) (8 10 5 11))) (quote #f)) (make-problem "19981020-MON (2)" (quote ((3 11) (4 5 4) (3 5 4) (3 5 3) (3 5 2) (4 5 2) (3 5 2) (4 2) (4 3 3 3 2 1) (4 1 1 1 1 1 2 1) (2 1 2 1 3 2 2) (2 1 1 1 1 1 2 2) (4 1 1 3 1 2 3) (4 2 2) (4 1 2 1 1 1) (2 1 1 2 4 1) (2 1 3 4 1 1 1) (1 4 3 8 1) (1 1 1 3 2 4 1) (1 6 3 1 2 2 1) (2 5 1 3 1 2 4 1) (2 1 12 8 1) (1 1 2 6 12) (3 4 2 10) (8 2 10) (4 1 2 10) (1 1 4 2 11) (3 1 1 2 2 9) (5 5 2 2 8) (2 1 4 2 2 3 7) (12 2 2 6) (9 1 2 2 6) (13 2 4) (10 3 5) (6 2 3 5) (2 9 5) (2 4 3 5) (2 2 4 5) (2 2 1 2 3) (2 2 10))) (quote ((2) (1 1 4 1) (2 2 5 3 3 3) (2 2 4 6 5) (5 2 3 7 1) (5 2 7 3) (3 2 10) (2 9) (34) (13 2 4 1 4 3 1) (6 3 1 6 1 3 4 3) (37) (5 3 2 2 1) (5 5 1 1 2 2 1) (5 1 1 2 2 2 1) (4 2 2 2 2 2 1) (3 2 2 2 2) (2 1 1 7 2 2 3) (1 5 9 2 2 3) (1 1 1 7 2 3 3) (1 2 2 2 4) (1 5 1 2 2 4) (2 1 1 2 2 2 4) (3 3 2 2 4) (4 2 2 4) (33) (32) (2 11) (5 12) (1 15) (16) (4 2 2 10) (3 2 7) (2 6) (13))) (quote #f)) (make-problem "19990202bLLO (3)" (quote ((8 20) (2 2 2 2) (1 1 1 1 1 2 1 1 3 1) (1 4 3 1 1 1 1 1 1 1 2) (1 1 1 3 3 2 1 1 1 1 2) (1 1 1 3 1 1 1 1 1 1 1 2) (1 1 1 1 1 1 1 2 2 2 3 1) (1 1 1 1 2 2) (1 1 1 1 20) (1 1 1 1) (2 1 1 2 6 6 6) (1 1 1 1 1 1 1 1 1 1) (2 2 1 2 1 1 2 1 1 2 1) (2 2 1 1 1 1 1 1 1 1 1) (2 2 1 1 1 1 1 1 1 1 1) (5 5 1 1 1 1 2 1 1 1 1) (1 2 2 1 1 1 1 1 1 1) (1 2 2 1 6 6 6) (5 5) (2 2 6 6 6) (2 2 1 1 1 1 1 1) (2 2 1 1 1 1 2 1 1 1 1) (2 2 1 2 1 1 1 1 1 1 1) (2 2 1 1 1 1 1 1 1 2 1) (2 2 1 1 1 1 2 1 1 2 1) (2 2 1 1 1 1 1 1) (2 2 6 6 6) (1 1 1 1) (2 1 1 2 6 6 6) (1 1 1 1 1 1 1 1 1 1) (1 1 1 1 1 2 1 1 2 1 1 2 1) (1 1 1 1 1 1 1 1 2 1 1 2 1) (1 1 1 1 1 1 1 1 2 1 1 1 1) (1 1 1 1 1 1 1 1 2 1 1 1 1) (1 4 1 1 1 1 1 1 1) (1 1 6 6 6) (2 2 4) (8 8) (3 4 5) (3 4 5))) (quote ((4) (10 1 1 9) (2 2 1 1 2 2) (1 15 1) (1 32 2) (1 1 1 3) (1 1 1 3) (1 32 1 1) (1 15 1) (2 2 1 1 2 2) (10 1 1 9) (3 4 1) (7 1) (2 2 8 8 8 2) (1 1 1 1 1 1 1 1 2) (1 5 1 1 1 1 1 2 1 1 1 2 1 2) (1 1 1 1 4 1 1 3 1 1 2 1 2) (1 5 1 1 1 1 1 1 3) (1 1 8 8 10) (1 5 1 2) (1 1 1 1 1 8 8 11) (1 1 1 1 1 1 1 1 2) (1 5 1 1 1 2 1 1 2 1 1 1 4 1 3) (1 1 1 1 2 1 1 1 1 2 1 1 4 1 2) (1 1 1 1 1 1 1 1 2) (1 5 1 8 8 8 1) (1 1 1 1) (1 1 8 8 8) (1 5 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1 1 4 1 1 2 1) (1 5 1 1 3 1 1 2 1 1 4 1) (1 1 1 1 1 1 1 1) (2 2 8 8 8) (7) (3))) (quote #f)) (make-problem "19990529aDRA (4)" (quote (() () (3) (5) (7) (7) (6) (7) (6) (5) (7) (2 9) (1 3 10) (2 16 4) (2 15 4) (2 2 2 5) (4 4 2 5 12) (2 1 1 8 1) (2 1 5 2 1 1) (2 1 5 2 1) (2 1 2 6 1) (2 1 7 1) (2 1 7 1) (14 8 11) (2 1 8 1) (2 1 10 1) (2 1 11 1) (2 1 6 5 1) (2 1 5 4 1) (2 1 3 4 1) (9 4 7 4 7) (2 4 4) (2 4 4) (2 4 3) (2 4 4) (2 3 3) (2 3 3) (2 5 4) (2 4 3) (2))) (quote ((27) (27) (1 1 1) (3 1 1 1) (1 3 1 1) (5 1 1) (3 15) (3 1 1 1) (2 1 1 1) (2 1 1) (2 2 3 1 3) (5 2 1 3 1 5) (6 2 5 1 7) (7 4 3 1 4 4 2) (7 6 3 5 4 2) (13 1 5 1 3 2) (11 3 8 1 6) (8 3 7 1 4) (6 3 7 1 2) (4 3 9 1) (7 10 1) (5 9 1) (4 3 5) (2 1 4) (1 1 4) (1 1 4 2) (1 1 4 2) (1 1 4 3) (15 6) (1 1 1 3) (1 1 1 2) (1 1 1) (1 1 1) (1 1 1) (1 1 1))) (quote #35(#40(off off off off off off off off off off off off off on) #40(off off off off off off off off off off off off off on) #40(off off off off off off off off off off off off off off off off on off off off off off off on off off off off off off on off) #40(off off off off off off off off off off off off on on on off on off off off off off off on off off off off off off on off) #40(off off off off off off off off off off off on off on on on off off off off off off off on off off off off off off on off) #40(off off off off off off off off off off off on on on on on off off off off off off off on off off off off off off on off) #40(off off off off off off off off off off off off on on on off on on on on on on on on on on on on on on on off) #40(off off off off off off off off off off off off on on on off on off off off off off off on off off off off off off on off) #40(off off off off off off off off off off off off off on on off on off off off off off off on off off off off off off on off) #40(off off off off off off off off off off off off off on on off on off off off off off off on off) #40(off off off off on on off off off off off off off on on off off on on on off off off on off off off off on on on off) #40(off off off on on on on on off off off off off on on off on off on on on off off on off off off on on on on on off) #40(off off on on on on on on off off off off off on on off on on on on on off off on off off on on on on on on on off) #40(off off on on on on on on on off off on on on on off off on on on off off off on off on on on on off on on on on off off off on on off) #40(off off on on on on on on on off on on on on on on off on on on off off off off on on on on on off off on on on on off off on on off) #40(off off off on on on on on on on on on on on on on off on off off off off off on on on on on off off on off on on on off off on on off) #40(off off off off on on on on on on on on on on on off on on on off on on on on on on on on off off on off off on on on on on on off) #40(off off off off off off off on on on on on on on on off on on on off on on on on on on on off off off on off off off on on on on off) #40(off off off off off off off off on on on on on on off on on on off off on on on on on on on off off off on off off off off on on off) #40(off off off off off off off off off on on on on off off on on on off on on on on on on on on on off off on off) #40(off off off off off off off off off off on on on on on on on off on on on on on on on on on on off off on off) #40(off off off off off off off off off off off on on on on on off off off off on on on on on on on on on off on off) #40(off off off off off off off off off off off off on on on on off off off off off on on on off on on on on on off) #40(off off off off off off off off off off off off off on on off on off off off off off off off off off off on on on on off) #40(off off off off off off off off off off off off off off off off on off off off off off off on off off off off on on on on off) #40(off off off off off off off off off off off off off off off off on off off off off off off on off off off off off on on on on off off off off on on off) #40(off off off off off off off off off off off off off off off off on off off off off off off on off off off off off off on on on on off off off on on off) #40(off off off off off off off off off off off off off off off off on off off off off off off on off off off off off off off on on on on off on on on off) #40(off off off off off off off off off off off off off off off off on on on on on on on on on on on on on on on off on on on on on on off) #40(off off off off off off off off off off off off off off off off on off off off off off off on off off off off off off on off off off on on on off) #40(off off off off off off off off off off off off off off off off on off off off off off off on off off off off off off on off off off on on off) #40(off off off off off off off off off off off off off off off off on off off off off off off on off off off off off off on off) #40(off off off off off off off off off off off off off off off off on off off off off off off on off off off off off off on off) #40(off off off off off off off off off off off off off off off off on off off off off off off on off off off off off off on off) #40(off off off off off off off off off off off off off off off off on off off off off off off on off off off off off off on off)))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/solution-sets/k40x30 b/collects/games/paint-by-numbers/solution-sets/k40x30
new file mode 100644
index 0000000000..ee88d8d2a7
--- /dev/null
+++ b/collects/games/paint-by-numbers/solution-sets/k40x30
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 40x30") (define problems (list (make-problem "19980501bGOS (1)" (quote (() () () () () () () () () (37) (37) (1 1 1 1 2 2 2 1 1 1 1 2 2) (1 1 1 3 1 1 1 1 2 1 3 1 2 1 1 1) (1 1 1 3 1 1 3 2 1 3 1 1 2 3) (1 1 1 3 2 1 2 6 2) (1 1 1 3 1 3 1 2 1 4 7 1) (1 1 1 3 1 1 1 1 2 1 4 5 1 1) (1 1 1 1 1 2 2 2 1 2 6 2) (37) (6 3) (6 5 1 4 1 6 3) (6 3) (37) () () () () () () ())) (quote (() (14) (2 5) (5 8) (2 5) (14) (2 5) (2 2 2 1 1) (2 2 2 1 1) (10 1 1) (2 1 1 1) (2 2 4 1 1) (2 1 1 1 1) (10 1 1) (3 2 2 1) (2 2 2 1 1) (3 2 2 1 1) (10 1) (2 1 1 1) (5 4 1 1) (5 4 1 1) (2 1 1 1) (10 1) (2 1 1 1) (2 2 2 1 1) (2 2 2 1 1 1) (10 1 1) (2 5 1 1) (5 1 1 1) (2 5 1 1) (10 1 1) (2 1 5 1) (2 6 1) (10 1) (3 2 2 1) (2 2 2 5) (3 2 6) (14) () ())) (quote #f)) (make-problem "19980501cGOS (2)" (quote (() (3 4) (6 6) (1 8 7) (2 2 16 2) (3 2 16 2 2) (5 5 1 5 2 3) (8 4 1 5 5) (15 3 4 8) (2 12 1 16) (3 25 2) (3 19 3) (16 3) (3 6) (3 5) (2 1 4) (4 4) (2 4) (10) (10) (9) (9) (7) (7) (3 3) (3 3) (4 4) (5 5) (5 5) ())) (quote (() () (2) (2 3 1) (2 2 2) (7) (5) (6) (7) (4) (4) (4) (4 4) (11) (14 2) (21 3) (28) (4 3 1 11) (4 1 3 2 11) (10 6) (2 1 3 11) (3 19) (27) (21 3) (19 2) (14) (7 5) (4 4) (4) (4) (4) (7) (7) (5) (7) (2 2 2) (2 3 1) (2) () ())) (quote #40(#30(off) #30(off) #30(off off off off off off off off on on off) #30(off off off off on on off on on on off on off) #30(off off off off on on off on on off on on off) #30(off off off off off on on on on on on on off) #30(off off off off off off on on on on on off) #30(off off off off on on on on on on off) #30(off off off on on on on on on on off) #30(off off off off off off on on on on off) #30(off off off off off off off on on on on off) #30(off off off off off off off off on on on on off) #30(off off off on on on on off on on on on off) #30(off off on on on on on on on on on on on off) #30(off on on on on on on on on on on on on on on off off off off off off off off off off off off on on off) #30(off on on on on on on on on on on on on on on on on on on on on on off off off off on on on off) #30(off on on on on on on on on on on on on on on on on on on on on on on on on on on on on off) #30(off off on on on on off off off off on on on off off off on off on on on on on on on on on on on off) #30(off off on on on on off off on off on on on off off on on off on on on on on on on on on on on off) #30(off off off on on on on on on on on on on off off off off off on on on on on on off) #30(off off off off on on off off on off on on on off off off off off on on on on on on on on on on on off) #30(off off off on on on off off off off on on on on on on on on on on on on on on on on on on on off) #30(off off on on on on on on on on on on on on on on on on on on on on on on on on on on on off) #30(off on on on on on on on on on on on on on on on on on on on on on off off off off on on on off) #30(off on on on on on on on on on on on on on on on on on on on off off off off off off off on on off) #30(off on on on on on on on on on on on on on on off) #30(off on on on on on on on off on on on on on off) #30(off off on on on on off off off on on on on off) #30(off off off off off off off off off on on on on off) #30(off off off off off off off off on on on on off) #30(off off off off off off off on on on on off) #30(off off off off on on on on on on on off) #30(off off off off on on on on on on on off) #30(off off off off off off off on on on on on off) #30(off off off off off off on on on on on on on off) #30(off off off off off on on off on on off on on off) #30(off off off off off on on off on on on off on off) #30(off off off off off off off off off on on off) #30(off) #30(off)))) (make-problem "19980508-SDN (3)" (quote ((15 7 10) (1 1 1 1 10) (1 11 1 1 1 2 2) (1 11 1 1 1 10) (1 11 1 1 1 5 3) (1 11 1 13 10) (1 11 1 24) (1 11 1 13 10) (1 11 1 6 1 2 10) (1 11 1 13 10) (1 11 1 1 1 10) (1 1 10) (15 10) (1 1 1 6 2 10) (15 7 2) (3 2 10) (1 14 10 2) (3 1 2 10) (9 3 1 10) (9 1 1 10) (1 1) (25 10) (25 1) (2 1 1 1 1 1 1 3 3) (25 1 1) (1 1 1 1 1 1 1 1 1 1 1) (25 3) (2 1 1 1 1 1 1 3 3) (25) (25))) (quote ((15 9) (1 1 1 4 4) (1 9 3 2 1 1 2) (1 9 1 1 2 2 3 2) (1 9 3 2 4 4) (1 9 1 1 2 2 1 1 2) (1 9 4 3 2 3 2) (1 9 8 4 4) (1 9 4 3 2 1 1 2) (1 9 3 2 2 3 2) (1 9 3 3 4 4) (1 9 3 1 2 2 1 1 2) (1 9 1 1 1 2 3 2) (1 3 1 4 4) (15 1 2 1 1 2) (1 2 3 2) (5 1 4 4) (5 1 2 1 1 2) (5 1 2 3 2) (11 1 4 4) (1 5 1 2 1 1 2) (1 5 1 2 3 2) (1 3 1 1 4 4) (1 3 1 1 7 4) (1 5 2 1 9) (8 2 1 1) (3 1 1 2) (5 1 2 1) (5 1 1 1 1) (1 1 1 1) (20 1) (20 1) (2 17 1) (2 11 5 1) (2 11 5 1) (2 1 9 5 1) (2 1 9 1 3 1) (2 11 1 3 1 5) (20 3 2) (20 5))) (quote #f)) (make-problem "19981027aMNT (4)" (quote ((2) (2) (8) (2) (1 2) (1 2) (5 2) (1 10) (1 2) (1 2) (1 10) (7 10) (1 10) (1 4 4) (1 18) (24) (24) (18) (34) (24) (32) (40) (17 12) (17 6) (21 5) (20 1) (19 2) (18 2) (17 2) (32))) (quote ((1 1) (1 2) (1 3) (1 1 4) (1 10) (1 10) (1 1 10) (1 1 1 10) (1 1 2 12) (13 12) (1 1 2 12) (1 1 16) (1 16) (16) (16) (1 20) (1 1 20) (1 1 20) (1 1 20) (13 16) (13 16) (1 1 12 1) (1 1 12 1) (1 1 12 1) (1 13 1) (9 1) (9 1) (9 1) (9 1) (2 5 1) (2 6 1) (2 6 1) (1 4 1) (1 4 1) (1 4 1) (1 5 2) (1 1 1 2) (1 1 2) (1 3) (1 1))) (quote #40(#30(off off off off off off off off off off off off off off off off off off off off off on off off on off) #30(off off off off off off off off off off off off off off off off off off off off off on off off on on off) #30(off off off off off off off off off off off off off off off off off off off off off on off off on on on off) #30(off off off off off off off off off off off off off off off off off off on off off on off off on on on on off) #30(off off off off off off off off off off off off off off off off off off on off on) #30(off off off off off off off off off off off off off off off off off off on off on) #30(off off off off off off off off off off off on off off off off off off on off on) #30(off off off off off off on off off off off on off off off off off off on off on) #30(off off off off off off on off off off off on off off off on on off on) #30(off off off off on on on on on on on on on on on on on off on) #30(off off off off off off on off off off off on off off off on on off on) #30(off off off off off off on off off off off on off off on) #30(off off off off off off off off off off off on off off on) #30(off off off off off off off off off off off off off off on) #30(off off off off off off off off off off off off off off on) #30(off off off off off off off on off off on) #30(off off on off off off off on off off on) #30(off off on off off off off on off off on) #30(off off on off off off off on off off on) #30(on on on on on on on on on on on on on off on) #30(on on on on on on on on on on on on on off on) #30(off off on off off off off on off off on on on on on on on on on on on on off off off off off off off on) #30(off off on off off off off on off off on on on on on on on on on on on on off off off off off off off on) #30(off off on off off off off on off off on on on on on on on on on on on on off off off off off off off on) #30(off off off off off off off on off off on on on on on on on on on on on on on off off off off off off on) #30(off off off off off off off off off off off off off off on on on on on on on on on off off off off off off on) #30(off off off off off off off off off off off off off off on on on on on on on on on off off off off off off on) #30(off off off off off off off off off off off off off off on on on on on on on on on off off off off off off on) #30(off off off off off off off off off off off off off off on on on on on on on on on off off off off off off on) #30(off off off off off off off off off off off off off off off on on off on on on on on off off off off off off on) #30(off off off off off off off off off off off off off off off on on off on on on on on on off off off off off on) #30(off off off off off off off off off off off off off off off on on off on on on on on on off off off off off on) #30(off off off off off off off off off off off off off off off off off off on off on on on on off off off off off on) #30(off off off off off off off off off off off off off off off off off off on off on on on on off off off off off on) #30(off off off off off off off off off off off off off off off off off off on off on on on on off off off off off on) #30(off off off off off off off off off off off off off off off off off off on off on on on on on off off off on) #30(off off off off off off off off off off off off off off off off off off on off off on off off on off off on on off) #30(off off off off off off off off off off off off off off off off off off off off off on off off on off on on off) #30(off off off off off off off off off off off off off off off off off off off off off on off off on on on off) #30(off off off off off off off off off off off off off off off off off off off off off on off off on off)))) (make-problem "19981027bMNT (5)" (quote ((16) (3 7 3) (4 7 3) (2 7 4 1) (3 7 3 2) (17 3) (3 7 3 4) (4 7 2 5) (17 13) (1 1 7 5 1) (16 8 1 1 1 1) (16 1 5 1 1 2 1) (7 7 1 5 8 1) (7 7 4 2 1 3 1 1) (16 4 2 1 3 2 1) (16 7 12 1) (16 8 1) (16 6 15) (16 4 1 15) (2 8 2 3 3 1 8 2) (2 8 2 2 1 1 1 8 2) (16 2 1 1 15) (17 1 4 6 7) (1 4 6 7) (1 3 15) (1 2 15) (1 1 1 8 2) (1 1 8 2) (1 15) (16))) (quote ((14) (1 13) (2 9 2) (3 9 2) (4 13) (5 13) (3 1 13) (4 1 2 9) (2 4 2 9) (3 4 13) (9 13) (1 6 13) (1 6 9 2) (9 9 2) (9 13) (6 1 13) (6 2 1) (3 4 12) (3 3 2 11) (7 3 7 1) (1 3 12 4 1) (1 2 7 3 1 3 1) (4 8 3 1 4 1) (3 13 9 1) (15 1 1) (1 1 13) (8 2 5 2) (2 1 1 2 5 2) (5 1 13) (2 4 13) (2 4 13) (1 6 5 6) (1 2 1 5 6) (1 1 1 13) (1 3 13) (1 2 13) (1 1 2 5 2) (1 2 5 2) (1 13) (14))) (quote #40(#30(off off off off off off off off off on on on on on on on on on on on on on on off) #30(off off off off off off off off on off on on on on on on on on on on on on on off) #30(off off off off off off off on on off on on on on on on on on on off off on on off) #30(off off off off off off on on on off on on on on on on on on on off off on on off) #30(off off off off off on on on on off on on on on on on on on on on on on on off) #30(off off off off on on on on on off on on on on on on on on on on on on on off) #30(off off off on on on off off on off on on on on on on on on on on on on on off) #30(off off on on on on off off on off on on off off on on on on on on on on on off) #30(off on on off off on on on on off on on off off on on on on on on on on on off) #30(on on on off off on on on on off on on on on on on on on on on on on on off) #30(on on on on on on on on on off on on on on on on on on on on on on on off) #30(on off off on on on on on on off on on on on on on on on on on on on on off) #30(on off off on on on on on on off on on on on on on on on on off off on on off) #30(on on on on on on on on on off on on on on on on on on on off off on on off) #30(on on on on on on on on on off on on on on on on on on on on on on on off) #30(on on on on on on off off on off on on on on on on on on on on on on on off) #30(on on on on on on off off on on off off off off off off off off off off off off on off) #30(on on on off off on on on on off on on on on on on on on on on on on off) #30(on on on off off on on on off on on off off on on on on on on on on on on on off) #30(on on on on on on on off on on on off off on on on on on on on off off off off on off) #30(on off off on on on off on on on on on on on on on on on on off on on on on off on off) #30(on off off on on off on on on on on on on off off on on on off on off off on on on off on off) #30(on on on on off on on on on on on on on off off on on on off on off off on on on on off on off) #30(on on on off on on on on on on on on on on on on on off on on on on on on on on on off on off) #30(on on on on on on on on on on on on on on on off on off off off off off off off off off off off off on) #30(off off off off off off off off on off off off off off off on off on) #30(off off off off off off off off on on on on on on on on off on on off off on on on on on off off on) #30(off off off off off off off off on on off off on off off on off on on off off on on on on on off off on) #30(off off off off off off off off on on on on on off off on off on) #30(off off off off off off off off on on off off on on on on off on) #30(off off off off off off off off on on off off on on on on off on) #30(off off off off off off off off on off on on on on on on off on on on on on off off on) #30(off off off off off off off off off on off on on off off on off on on on on on off off on) #30(off off off off off off off off off off on off on off off on off on) #30(off off off off off off off off off off off on off on on on off on) #30(off off off off off off off off off off off off on off on on off on) #30(off off off off off off off off off off off off off on off on off on on off off on on on on on off off on) #30(off off off off off off off off off off off off off off on off off on on off off on on on on on off off on) #30(off off off off off off off off off off off off off off off on off on) #30(off off off off off off off off off off off off off off off off on)))) (make-problem "19981228-BAU (6)" (quote ((5) (7) (3 3) (2 2 2) (2 2 2) (3 3 2) (2 2 2) (2 2 2) (3 3 3) (2 2 2 2) (2 2 4 2) (3 3 6 3) (2 2 2 2 2) (2 2 3 2 2) (3 3 5 3 2) (2 2 2 2 2 2) (2 2 2 2 2 2) (3 3 3 3 3 3) (2 2 2 2 2 2) (2 2 2 2 2 2) (3 17 3 3) (3 17 2 3) (2 3 2 2) (2 3 3 2) (26 2 2) (26 2 2) (2 4) (2 3) (29) (27))) (quote (() () (5) (7) (3 4) (4 2 2) (3 2 2) (4 2 2) (3 2 2) (4 3 2 2) (3 5 2 2) (4 3 2 2 2) (3 4 2 2 2) (4 3 2 2 2) (3 4 3 2 2) (4 3 5 2 2) (3 4 3 2 2 2) (3 3 4 2 2 2) (2 4 3 2 2 2) (2 3 4 2 2 2) (2 3 6 2 2 2) (4 3 4 2 2 2) (2 3 3 2 2 2) (3 3 5 2 2) (4 4 4 2 2) (4 3 6 2) (3 4 4 2) (4 3 3 2) (3 4 2) (4 3 2) (3 4 2) (3 4 2) (3 7) (4 3) (3 2) (7) (5) () () ())) (quote #f)) (make-problem "19990118-FRA (7)" (quote (() (3 3) (1 2 2 1) (1 2 2 1) (1 12 1) (1 14 1) (1 16 1) (1 20 1) (6 6 6) (4 1 1 4 1 1 4) (4 1 1 4 1 1 4) (5 6 5) (22) (10 9) (10 9) (11 10) (11 10) (7 2 2 6) (8 3 7) (9 1 8) (9 8) (16) (12) (8) () (1 1 4 4 1 1) (2 2 1 1 1 1 1 1) (1 2 1 3 1 1 1 1 1 1) (1 1 1 1 1 2 2) (1 1 4 4 1 1))) (quote (() () () () () () () () (8 5) (1 11 1) (1 13 1) (1 14 1) (1 16 1) (1 4 11 5) (5 2 11) (4 11 5) (4 2 5 6 1 1 1) (5 7 5 1 1 1) (14 5 1 1) (9 2 1 4) (9 2 3 5) (9 2 1 4 1 1) (5 7 5 1 1) (4 2 6 5 5) (4 5 5) (5 2 11 5) (1 4 11 1) (1 16 1) (1 14 1) (1 13 1) (1 11 1) (8 5) () () () () () () () ())) (quote #f)) (make-problem "19990123aFRA (8)" (quote (() () (2) (8) (10) (12 3) (4 14 3) (1 2 1 1 3) (1 23) (1 21) (3 20) (20) (16) (14) (12) (10) (8) (6) (10) () () (12 12) (1 10 10 1) (1 8 8 1) (9 9) (7 7) (5 5) (11 11) () ())) (quote (() () () (2) (1 1 1) (2 1 1) (3 5 1) (1 2 7) (1 1 7) (2 1 7) (2 1 7) (4 7) (6 5 1) (1 6 3 1) (2 7 2 1) (3 8 1 1) (4 9 1) (4 11) (4 11) (5 11) (5 11) (4 11) (4 11) (4 9 1) (3 8 1 1) (2 7 2 1) (1 6 3 1) (6 5 1) (4 7) (4 7) (3 7) (3 7) (3 7) (3 5 1) (2 2 1 1) (1 1 1 1) (2) () () ())) (quote #40(#30(off) #30(off) #30(off) #30(off off off off off off off off off off off off off off off off off off off off off off on on off) #30(off off off off off off off off off off off off off off off off off off off off off on off off on off off on off) #30(off off off off off off off off off off off off off off off off off off off off off on on off on off off on off) #30(off off off off off off on on on off off off off off off off off off off off off on on on on on off on off) #30(off off off off off off on off off on on off off off off off off off off off off on on on on on on on off) #30(off off off off off off on off off off on off off off off off off off off off off on on on on on on on off) #30(off off off off off off on on off off on off off off off off off off off off off on on on on on on on off) #30(off off off off off off off on on off off on off off off off off off off off off on on on on on on on off) #30(off off off off off off off off on on on on off off off off off off off off off on on on on on on on off) #30(off off off off off off off on on on on on on off off off off off off off off on on on on on off on off) #30(off off off off off off on off on on on on on on off off off off off off off on on on off off off on off) #30(off off off off off on on off on on on on on on on off off off off off off on on off off off off on off) #30(off off off off on on on off on on on on on on on on off off on off off on off) #30(off off off on on on on off on on on on on on on on on off on off) #30(off off off on on on on off on on on on on on on on on on on off) #30(off off off on on on on off on on on on on on on on on on on off) #30(off off on on on on on off on on on on on on on on on on on off) #30(off off on on on on on off on on on on on on on on on on on off) #30(off off off on on on on off on on on on on on on on on on on off) #30(off off off on on on on off on on on on on on on on on on on off) #30(off off off on on on on off on on on on on on on on on off on off) #30(off off off off on on on off on on on on on on on on off off on off off on off) #30(off off off off off on on off on on on on on on on off off off off off off on on off off off off on off) #30(off off off off off off on off on on on on on on off off off off off off off on on on off off off on off) #30(off off off off off off off on on on on on on off off off off off off off off on on on on on off on off) #30(off off off off off off off off on on on on off off off off off off off off off on on on on on on on off) #30(off off off off off off off off on on on on off off off off off off off off off on on on on on on on off) #30(off off off off off off off off on on on off off off off off off off off off off on on on on on on on off) #30(off off off off off off off on on on off off off off off off off off off off off on on on on on on on off) #30(off off off off off off on on on off off off off off off off off off off off off on on on on on on on off) #30(off off off off off on on on off off off off off off off off off off off off off on on on on on off on off) #30(off off off off off on on off off off off off off off off off off off off off off on on off on off off on off) #30(off off off off off on off off off off off off off off off off off off off off off on off off on off off on off) #30(off off off off off off off off off off off off off off off off off off off off off off on on off) #30(off) #30(off) #30(off)))) (make-problem "19990208bFRA (9)" (quote ((2 22) (1 21) (1 22) (3 13 2 6) (1 4 4 10 2 7) (1 10 9 2 8) (1 9 2 8) (1 10 2 7) (1 16 10 2 7) (1 16 9 2 8) (1 1 1 1 1 1 1 8 2 9) (1 1 2 1 1 1 1 1 1 9 2 8) (1 1 1 1 1 1 1 1 21) (1 2 1 1 1 1 1 3 4 3) (1 1 1 1 1 3 3 12 2) (1 16 2 14 1) (1 2 12 1) (1 3 2) (1 4 3) (1 5 4) (1 6 5) (1 5 4) (1 21) (1 5 13) (1 4 3 12) (1 4 3 2) (1 16 4 3 2) (1 4 3 12) (1 5 13) (40))) (quote ((30) (1 1 1) (2 8 1 1) (1 2 1 1 1 1) (1 2 1 1 1 1) (2 8 1 1) (1 2 1 1 1) (1 2 3 1 1 1) (1 2 1 1 1) (1 8 1 1) (1 2 1 1 1) (1 6 1 1 1) (1 2 1 1 1) (1 8 1 1) (2 2 1 1 1) (1 2 1 3 1 1) (1 2 3 1 1) (2 8 1 1) (1 2 1) (30) (30) (15 13) (14 12) (13 1 5 2) (13 3 1 1 4 1) (13 3 1 4 1) (13 3 1 4 1) (10 2 3 2 2) (5 2 1 1 3 3 3) (4 2 4 3 3 3) (3 6 2 3 3 3) (5 2 1 1 3 3 3) (4 2 4 3 3 3) (3 9 3 3 3) (13 3 3 3) (13 3 1 3 3) (13 1 6 3) (14 7 3) (15 13) (30))) (quote #40(#30(on) #30(on off off on off off off off off off off off off off off off off off off off off off off off off off off off off on) #30(off off off on on off off off on on on on on on on on off off off off off off off off off off on off off on) #30(off off off off on off off off on on off off off on off on off off off off off off off off off off on off off on) #30(off off off off on off off off on on off on off off off on off off off off off off off off off off on off off on) #30(off off off off on on off off on on on on on on on on off off off off off off off off off off on off off on) #30(off off off off off on off off on on off off off off off on off off off off off off off off off off on off off on) #30(off off off off off on off off on on off on on on off on off off off off off off off off off off on off off on) #30(off off off off off on off off on on off off off off off on off off off off off off off off off off on off off on) #30(off off off off off on off off on on on on on on on on off off off off off off off off off off on off off on) #30(off off off off off on off off on on off off off off off on off off off off off off off off off off on off off on) #30(off off off off off on off off on on on on on on off on off off off off off off off off off off on off off on) #30(off off off off off on off off on on off off off off off on off off off off off off off off off off on off off on) #30(off off off off off on off off on on on on on on on on off off off off off off off off off off on off off on) #30(off off off off on on off off on on off off off off off on off off off off off off off off off off on off off on) #30(off off off off on off off off on on off on off on on on off off off off off off off off off off on off off on) #30(off off off off on off off off on on off off off on on on off off off off off off off off off off on off off on) #30(off off off on on off off off on on on on on on on on off off off off off off off off off off on off off on) #30(on off on on off off off off off off off off off off off off off off off off off off off off off off off off off on) #30(on) #30(on) #30(on on on on on on on on on on on on on on on off off on) #30(on on on on on on on on on on on on on on off off off off on) #30(on on on on on on on on on on on on on off off on off off off on on on on on off off off off on) #30(on on on on on on on on on on on on on off on on on off off off on off on off on on on on off on) #30(on on on on on on on on on on on on on off on on on off off off off off on off on on on on off on) #30(on on on on on on on on on on on on on off on on on off off off off off on off on on on on off on) #30(on on on on on on on on on on off on on off on on on off off off off off on on off off off off on) #30(on on on on on off off on on off on off on off on on on off off off off off on on on off off on) #30(on on on on off on on off off on on on on off on on on off off off off off on on on off off on) #30(on on on off on on on on on on off on on off on on on off off off off off on on on off off on) #30(on on on on on off off on on off on off on off on on on off off off off off on on on off off on) #30(on on on on off on on off off on on on on off on on on off off off off off on on on off off on) #30(on on on off on on on on on on on on on off on on on off off off off off on on on off off on) #30(on on on on on on on on on on on on on off on on on off off off off off on on on off off on) #30(on on on on on on on on on on on on on off on on on off off off on off on on on off off on) #30(on on on on on on on on on on on on on off off on off off off on on on on on on off off on) #30(on on on on on on on on on on on on on on off off off off on on on on on on on off off on) #30(on on on on on on on on on on on on on on on off off on) #30(on)))) (make-problem "19990208cFRA (10)" (quote (() () (17 18) (4 3 3 2 18) (5 2 2 3 5 8 3) (5 1 1 3 4 2 2 2) (3 2 1 1 2 1 5 2 3) (4 3 3 2 6 1 1 4) (4 1 2 6 1 2 1 4) (3 4 4 1 4 1 1 1 1 2) (6 1 1 4 4 1 1 1 1 2) (5 1 1 3 6 1 2 1 4) (5 2 2 3 6 1 1 4) (4 4 4 2 4 1 1 2) (9 7 5 2 2 2 3) (9 7 9 7) () (9 7 9 7) (4 2 2 2 7 1 1 5) (3 3 1 1 3 1 8 6) (8 6 9 7) (5 3 5 3) (5 3 5 3) (6 4 6 4) (6 4 6 4) (6 4 7 5) (6 4 7 5) (7 5 8 6) () ())) (quote (() () (14 11) (14 11) (14 11) (4 2 6 2 8) (1 3 4 2 1 9) (2 2 2 3 1 2 5) (2 1 1 3 1 2 1) (3 1 1 4 2 1) (1 3 6 3) (1 1) (1 3 6 3) (3 1 1 4 2 1) (2 1 1 3 1 2 1) (2 2 2 3 1 2 5) (1 3 4 2 1 9) (4 2 6 2 8) (14 11) () (14 11) (14 11) (14 11) (14 11) (3 3 2 2 11) (2 2 2 1 4 5) (3 2 2 4 3) (4 1 1 2 1 2 1) (4 1 2 2 1 2 1) (3 1 1 1 1) (3 1 1 1 1) (4 1 2 2 1 2 1) (4 1 1 2 1 2 1) (3 2 2 4 3) (2 2 2 1 4 5) (3 3 2 2 11) (14 11) (14 11) () ())) (quote #40(#30(off) #30(off) #30(off off on on on on on on on on on on on on on on off on on on on on on on on on on on off) #30(off off on on on on on on on on on on on on on on off on on on on on on on on on on on off) #30(off off on on on on on on on on on on on on on on off on on on on on on on on on on on off) #30(off off on on on on off on on off on on on on on on off on on off on on on on on on on on off) #30(off off on off on on on off off on on on on off on on off on off on on on on on on on on on off) #30(off off on on off off on on off on on off off on on on off on off on on off off on on on on on off) #30(off off on on off off off on off on off off off on on on off on off on on off off off off off off on off) #30(off off on on on off off on off on off off on on on on off on on off on off) #30(off off on off on on on off off off on on on on on on off on on on off) #30(off off on off off off off off on off) #30(off off on off on on on off off off on on on on on on off on on on off) #30(off off on on on off off on off on off off on on on on off on on off on off) #30(off off on on off off off on off on off off off on on on off on off on on off off off off off off on off) #30(off off on on off off on on off on on off off on on on off on off on on off off on on on on on off) #30(off off on off on on on off off on on on on off on on off on off on on on on on on on on on off) #30(off off on on on on off on on off on on on on on on off on on off on on on on on on on on off) #30(off off on on on on on on on on on on on on on on off on on on on on on on on on on on off) #30(off) #30(off off on on on on on on on on on on on on on on off on on on on on on on on on on on off) #30(off off on on on on on on on on on on on on on on off on on on on on on on on on on on off) #30(off off on on on on on on on on on on on on on on off on on on on on on on on on on on off) #30(off off on on on on on on on on on on on on on on off on on on on on on on on on on on off) #30(off off on on on off on on on off off on on off on on off on on on on on on on on on on on off) #30(off off on on off off off on on off off on on off off on off on on on on off off on on on on on off) #30(off off on on on off off off off on on off off off on on off on on on on off off off off on on on off) #30(off off on on on on off off on off off on off off on on off on off on on off off off off off off on off) #30(off off on on on on off on off on on off on on off on off on on off on off) #30(off off on on on off on off on off off on off off on off) #30(off off on on on off on off on off off on off off on off) #30(off off on on on on off on off on on off on on off on off on on off on off) #30(off off on on on on off off on off off on off off on on off on off on on off off off off off off on off) #30(off off on on on off off off off on on off off off on on off on on on on off off off off on on on off) #30(off off on on off off off on on off off on on off off on off on on on on off off on on on on on off) #30(off off on on on off on on on off off on on off on on off on on on on on on on on on on on off) #30(off off on on on on on on on on on on on on on on off on on on on on on on on on on on off) #30(off off on on on on on on on on on on on on on on off on on on on on on on on on on on off) #30(off) #30(off)))) (make-problem "19990221aFRA (11)" (quote ((33) (23 8) (21 8) (20 8) (19 8) (18 8) (2 11 8) (1 9 8) (1 3 7 8) (1 4 5 8) (1 5 3 8) (2 1 8) (10 24) (10 1 22) (8 19) (6 4 16) (4 3 6 13) (2 4 9 10) (1 4 11 7) (1 3 14 5) (1 1 17 3) (2 21) (6 1 3 1 1 5) (6 3 2 1 1 1 19) (6 1 1 1 1 1 3 1 3 1 1 1) (8 1 2 1 1 5 3 2 1 1 1 1) (6 1 3 1 1 5 1 1 1 1 1 1) (26 1 2 1 1 3) (24 1 3 1 1 3) (40))) (quote ((30) (7 7 9) (6 5 8) (6 3 5 2 8) (6 3 4 4 8) (6 3 4 3 8) (7 2 3 3 1 1 3) (8 1 3 2 2 1 1 3) (9 2 1 3 1 3) (10 2 13) (11 7 3) (12 1 8 6) (11 9 5) (10 2 10 4) (9 3 6 3) (8 5 14) (7 6 5 3) (6 8 13) (5 9 4 3) (4 11 4 1 5) (3 12 3 5) (2 14 11) (2 8 6 10) (1 8 7 10) (9 8 3 1 1) (8 12 1 1 1) (7 10 1 1 1) (6 9 7) (5 8 1 1) (4 7 2 4) (3 6 3 3) (2 5 4 2) (1 4 1 1) (3 7) (2 1 1) (1 7) (1 1 1) (1 1 3) (1 3) (7))) (quote #40(#30(on) #30(on on on on on on on off off off off on on on on on on on off off off on) #30(on on on on on on off off off off off off on on on on on off off off off off on) #30(on on on on on on off off on on on off on on on on on off on on off off on) #30(on on on on on on off off on on on off on on on on off on on on on off on) #30(on on on on on on off off on on on off on on on on off on on on off off on) #30(on on on on on on on off off on on off on on on off on on on off off on off off off on off on) #30(on on on on on on on on off off on off on on on off on on off off on on off on off on off on) #30(on on on on on on on on on off off off on on off off on off off on on on off on off off off on) #30(on on on on on on on on on on off off on on off off off on) #30(on on on on on on on on on on on off off off off on on on on on on on off off off off off on) #30(on on on on on on on on on on on on off on off on on on on on on on on off on) #30(on on on on on on on on on on on off off off off on on on on on on on on on off on) #30(on on on on on on on on on on off off on on off on on on on on on on on on on off on) #30(on on on on on on on on on off off on on on off off on on on on on on off off off off off on) #30(on on on on on on on on off off on on on on on off on) #30(on on on on on on on off off on on on on on on off off on on on on on off off off off off on) #30(on on on on on on off off on on on on on on on on off on) #30(on on on on on off off on on on on on on on on on off off on on on on off off off off off on) #30(on on on on off off on on on on on on on on on on on off on on on on off on off on) #30(on on on off off on on on on on on on on on on on on off off on on on off off off on) #30(on on off off on on on on on on on on on on on on on on off on) #30(on on off on on on on on on on on off on on on on on on off off on) #30(on off on on on on on on on on off off on on on on on on on off on) #30(on on on on on on on on on off off off on on on on on on on on off on on on off off off on off on) #30(on on on on on on on on off off off off on on on on on on on on on on on on off on off on off on) #30(on on on on on on on off off off off off on on on on on on on on on on off on off on off off off on) #30(on on on on on on off off off off off off on on on on on on on on on off off on) #30(on on on on on off off off off off off off on on on on on on on on off off off on off off off off off on) #30(on on on on off off off off off off off off on on on on on on on off off off off on on off on) #30(on on on off off off off off off off off off on on on on on on off off off off off on on on off on) #30(on on off off off off off off off off off off on on on on on off off off off off off on on on on off on) #30(on off off off off off off off off off off off on on on on off off off off off off off on off off off off off on) #30(off off off off off off off off off off off off on on on off off off off off off off off on) #30(off off off off off off off off off off off off on on off off off off off off off off off on off off off off off on) #30(off off off off off off off off off off off off on off off off off off off off off off off on) #30(off off off off off off off off off off off off on off off off off off off off off off off on off off off off off on) #30(off off off off off off off off off off off off off off off off off off off off off off off on off on off on) #30(off off off off off off off off off off off off off off off off off off off off off off off on off off off on) #30(off off off off off off off off off off off off off off off off off off off off off off off on)))) (make-problem "19990401-JOJ (12)" (quote ((40) (40) (12 24) (9 21) (7 4 19) (6 10 18) (5 5 5 17) (4 3 4 16) (3 3 6 3 15) (2 3 3 3 3 14) (2 2 2 2 2 5 7) (2 2 3 5 2 2 4 7) (1 2 2 2 2 1 2 5 5 1) (1 1 2 2 2 2 2 4 5 1) (2 2 2 3 1 2 2 4 5 1) (2 1 1 3 1 2 2 5 3 2) (2 1 1 3 2 2 2 5 3 2) (2 2 2 5 2 2 7 1 3) (1 2 2 2 2 2 6 2) (1 2 3 3 3 3 5 4 1) (2 2 3 7 3 3 3 2 1) (2 2 3 2 3 2 8 1) (2 3 4 4 9 1) (3 3 9 12 2) (4 4 4 10 4) (5 5 11 7) (6 19 10) (8 16 11) (9 13 13) (10 15))) (quote ((14 12) (12 10) (9 4 7) (8 10 6) (7 4 5 5) (6 3 3 4) (5 3 7 3 3) (4 3 4 4 3 3) (4 2 3 3 2 2) (3 2 3 4 3 3 1) (3 2 1 2 2 2 3) (3 2 2 2 2 2 4) (2 2 1 2 2 2 2 3) (2 2 1 1 4 2 2 3) (2 2 1 1 4 2 2 3) (2 2 1 1 1 1 2 2 3) (3 2 2 2 1 1 2 3) (3 2 1 2 2 2 1 3) (3 3 2 4 2 2 4) (4 2 2 2 2 4) (4 3 3 3 2 4) (5 3 5 3 5) (6 3 2 3 5) (7 4 4 6) (8 9 5) (9 4 1 5 1) (11 3 4 1) (13 4 4 2) (21 4 2) (20 3 3) (20 4 4) (10 7 3 4) (12 4 4 4) (15 1 5 5) (17 5 5) (18 1 2 5) (17 4 6) (15 1 2 6) (12 4 7) (10 18))) (quote #40(#30(on on on on on on on on on on on on on on off off off off on) #30(on on on on on on on on on on on on off off off off off off off off on) #30(on on on on on on on on on off off off off off on on on on off off off off off on) #30(on on on on on on on on off off off on on on on on on on on on on off off off on) #30(on on on on on on on off off on on on on off off off off off on on on on on off off on) #30(on on on on on on off off on on on off off off off off off off off off off on on on off off on) #30(on on on on on off off on on on off off off on on on on on on on off off on on on off off on) #30(on on on on off off on on on off off on on on on off off on on on on off off on on on off on) #30(on on on on off off on on off off on on on off off off off off off on on on off off on on off off on) #30(on on on off off on on off off on on on off off on on on on off off on on on off on on on off off on) #30(on on on off off on on off off on off off off on on off off on on off off on on off off on on on off) #30(on on on off off on on off on on off off on on off off off off on on off off on on off on on on on off) #30(on on off off on on off off on off off on on off off on on off off on on off on on off off on on on off) #30(on on off off on on off off on off off on off off on on on on off on on off off on on off on on on off) #30(on on off off on on off off on off off on off off on on on on off off on on off on on off on on on off) #30(on on off off on on off off on off off on off off on off off on off off on on off on on off on on on off) #30(on on on off off on on off on on off on on off off off off on off off on off off on on off on on on off) #30(on on on off off on on off off on off off on on off off on on off on on off off on off off on on on off) #30(on on on off off on on on off on on off off on on on on off off on on off on on off on on on on off) #30(on on on on off off on on off off on on off off off off off off on on off off on on off on on on on off) #30(on on on on off off on on on off off on on on off off on on on off off on on off off on on on on off) #30(on on on on on off off on on on off off off on on on on on off off on on on off on on on on on off) #30(on on on on on on off off on on on off off off on on off off off on on on off off on on on on on off) #30(on on on on on on on off off on on on on off off off off on on on on off off on on on on on on off) #30(on on on on on on on on off off off on on on on on on on on on off off off on on on on on off) #30(on on on on on on on on on off off off off on on on on off off off off on off on on on on on off on) #30(on on on on on on on on on on on off off off off off off off off on on on off on on on on off off on) #30(on on on on on on on on on on on on on off off off off on on on on off off on on on on off on) #30(on on on on on on on on on on on on on on on on on on on on on off on on on on off off on) #30(on on on on on on on on on on on on on on on on on on on on off off on on on off off on) #30(on on on on on on on on on on on on on on on on on on on on off on on on on off on) #30(on on on on on on on on on on off off on on on on on on on off off on on on off off on) #30(on on on on on on on on on on on on off off off on on on on off on on on on off off on) #30(on on on on on on on on on on on on on on on off off on off on on on on on off on) #30(on on on on on on on on on on on on on on on on on off off on on on on on off on) #30(on on on on on on on on on on on on on on on on on on off on off on on off off on) #30(on on on on on on on on on on on on on on on on on off off on on on on off on) #30(on on on on on on on on on on on on on on on off off on off off on on off off on) #30(on on on on on on on on on on on on off off off on on on on off off off off on) #30(on on on on on on on on on on off off on)))) (make-problem "19990525aKHO (13)" (quote ((2 3 1 1 2) (9 2 3 3 4) (4 21 1) (5 2 1 5 2 2 2 2) (3 2 2 4) (4) (2) () (7) (12 5) (12 3) (2 2 3) (2 2 3) (2 2 3) (2 2 3) (2 2 3) (2 2 3) (24) (2 4 9 3 2) (2 4 10 2 1) (2 2 4 15 1) (3 3 2 1 1) (1 2 23 1) (2 8 3 16 1) (3 2 2 4 16) (11 1 2 2 9 3) (2 5 2 1 1 1 1 1 2 3) (1 1 3 1 4 1 1 7 1 1 2) (1 1 1 1 1 2 2 1 1 3) (1 1 4 2 4))) (quote ((8) (2 4 1) (3 2 2 1 1) (5 2 2 1) (5 1 3) (4 1 4) (1 1 1 3) (3 1 2 1) (4 1 1 1 1) (4 4 1) (2 5) (2 2 1) (2 2 1) (2 19) (1 16) (2 2 1 3 4) (4 2 4 1 2 2) (5 2 4 1 1 1) (3 2 4 1 1 1) (2 2 4 1 2 2) (2 2 1 3 4) (3 16) (4 12 6) (1 4 4 1) (2 4 4 1) (4 4 4 1) (4 4 4 1) (2 4 4 1) (2 4 4 1) (3 1 4 5) (2 1 2 4 2) (2 11 1 3 1 1) (4 11 1 3 1 1) (4 11 1 4 2) (2 2 1 2 5) (1 10) (2 1 4) (5 3) (2) (1))) (quote #f)) (make-problem "19990527aDRA (14)" (quote ((11 27) (10 2 25) (9 2 2 23) (8 8 21) (7 5 5 19) (6 11 19) (6 1 4 3 1 10 7) (6 3 5 2 8 2 6) (6 5 2 3 6 5 5) (6 2 4 4 4 4 3 4) (6 5 2 4 2 11 3) (6 2 5 2 1 2 4 4 3 2) (6 5 2 4 2 13 1) (6 2 5 4 2 1 4 6 1) (6 4 2 3 3 2 8 1 1) (8 5 2 4 3 5 3 1) (10 3 1 5 1 2 2 5 1) (12 1 6 5 5 1 1) (14 7 6 1 5 1) (23 6 7 1) (1 1 2 1 1 1 2 2 3 3 1) (1 3 2 1 2 1 2 1 4 4 5 1 1) (1 3 2 1 2 3 3 1 5 1) (1 3 1 2 2 1 6 4 2 5 2) (1 1 2 1 2 1 4 5 1 3 4) (29 1 6) (30 8) (40) (40) (40))) (quote ((30) (20 5) (20 3 5) (20 3 5) (30) (20 5) (5 5 1 7) (4 8 5 1 6) (3 2 8 4 2 5) (2 3 2 1 1 1 14) (1 5 8 4 5) (6 8 3 1 7) (1 5 1 1 1 2 2 1 7) (1 2 3 8 2 5) (1 4 2 8 11) (2 6 1 5) (2 5 8 2 1 7) (3 3 8 3 1 7) (3 2 4 3 4 8) (4 8 15) (4 6 1 5) (20 1 1 5) (20 1 5) (10 10) (10 1 7 9) (9 3 2 4 8) (9 4 7 7) (8 6 4 2 6) (8 2 4 7 5) (7 9 7 4) (7 5 3 3) (6 2 6 9 3) (6 9 1 3 2 4) (7 3 3 9 4) (8 6 4 3 5) (9 4 9 5) (10 3 2 3 1 6) (11 1 9 6) (12 7) (30))) (quote #40(#30(on) #30(on on on on on on on on on on on on on on on on on on on on off off off off off on) #30(on on on on on on on on on on on on on on on on on on on on off on on on off on) #30(on on on on on on on on on on on on on on on on on on on on off on on on off on) #30(on) #30(on on on on on on on on on on on on on on on on on on on on off off off off off on) #30(on on on on on off off off off off off off off off off on on on on on off on off on) #30(on on on on off off on on on on on on on on off on on on on on off on off off on) #30(on on on off on on off on on on on on on on on off on on on on off off on on off on) #30(on on off on on on off on on off on off on off on off on) #30(on off on on on on on off on on on on on on on on off on on on on off off off off on) #30(off on on on on on on off on on on on on on on on off on on on off on off on) #30(off on off on on on on on off on off on off on off on on off on on off on off on) #30(on off on on off on on on off on on on on on on on on off on on off off off off off on) #30(on off on on on on off on on off on on on on on on on on off on) #30(on on off on on on on on on off off off off off off off off off off on off off off off off on) #30(on on off on on on on on off on on on on on on on on off on on off on off on) #30(on on on off on on on off on on on on on on on on off on on on off on off on) #30(on on on off on on off on on on on off on on on off on on on on off off on) #30(on on on on off off on on on on on on on on off on) #30(on on on on off off off off off off off off off off on on on on on on off off off on off on) #30(on on on on on on on on on on on on on on on on on on on on off on off on off on) #30(on on on on on on on on on on on on on on on on on on on on off on off off off on) #30(on on on on on on on on on on off off off off off off off off off off on) #30(on on on on on on on on on on off on off on on on on on on on off on) #30(on on on on on on on on on off on on on off on on off on on on on off on) #30(on on on on on on on on on off on on on on off on on on on on on on off on) #30(on on on on on on on on off on on on on on on off on on on on off on on off on) #30(on on on on on on on on off on on off on on on on off on on on on on on on off on) #30(on on on on on on on off on on on on on on on on on off on on on on on on on off on) #30(on on on on on on on off on on on on on off on on on off off off off off off off off off off on) #30(on on on on on on off on on off on on on on on on off on on on on on on on on on off on) #30(on on on on on on off on on on on on on on on on off on off on on on off on on off on) #30(on on on on on on on off on on on off on on on off on on on on on on on on on off on) #30(on on on on on on on on off on on on on on on off on on on on off on on on off on) #30(on on on on on on on on on off on on on on off on on on on on on on on on off on) #30(on on on on on on on on on on off on on on off on on off on on on off on off on) #30(on on on on on on on on on on on off on off on on on on on on on on on off on) #30(on on on on on on on on on on on on off off off off off off off off off off off on) #30(on)))) (make-problem "19990527eDRA (15)" (quote ((16 11 11) (17 9 12) (18 7 13) (14 4) (12 6 3 8 4) (10 19 2 4) (8 19 4 4) (7 6 4) (7 20 6 4) (7 20 6 4) (7 2 4 6 4) (7 2 12 1 1 6 4) (7 2 3 3 1 1 6 4) (7 2 2 3 4 6 4) (7 2 1 5 3 4 6 4) (7 2 1 1 1 1 3 1 1 6 4) (7 2 1 2 2 3 1 1 6 4) (7 2 1 5 4 4 6 4) (7 2 1 1 1 4 4 6 4) (7 2 2 3 5 1 1 6 4) (7 2 1 1 2 1 1 6 4) (7 2 9 1 4 6 4) (7 2 10 1 1 1 6 4) (7 2 2 5 1 1 1 1 6 4) (7 2 4 6 4) (7 20 5 4) (7 20 3 6) (7 20 1 8) (7 10) (40))) (quote ((30) (30) (30) (30) (30) (30) (30) (7 1) (6 20 1) (6 20 1) (5 1 2 3 1) (5 1 2 9 2 3 1) (4 2 2 3 1 3 3 1) (4 2 2 2 5 3 3 1) (3 3 2 1 1 2 1 3 3 1) (3 3 2 1 2 1 1 3 3 1) (2 3 2 1 1 2 1 3 3 1) (1 1 3 2 1 5 4 3 1) (2 3 2 1 1 3 3 1) (3 3 2 1 3 2 3 1) (3 2 2 9 3 3 1) (3 3 2 10 3 1) (3 3 2 13 3 1) (3 3 2 3 1) (3 2 20 1) (3 3 3 2 2 1 4 1) (2 3 3 2 2 1 4 1) (1 1 3 20 1) (2 3 1) (3 2 21 1) (3 2 20 2) (3 1 21 2) (3 1 20 3) (3 21 3) (3 20 4) (3 4) (30) (30) (30) (30))) (quote #40(#30(on) #30(on) #30(on) #30(on) #30(on) #30(on) #30(on) #30(on on on on on on on off off off off off off off off off off off off off off off off off off off off off off on) #30(on on on on on on off off on on on on on on on on on on on on on on on on on on on on off on) #30(on on on on on on off off on on on on on on on on on on on on on on on on on on on on off on) #30(on on on on on off on off on on off off off off off off off off off off off off off off off on on on off on) #30(on on on on on off on off on on off on on on on on on on on on off off on on off on on on off on) #30(on on on on off on on off on on off on on on off off off off off on off on on on off on on on off on) #30(on on on on off on on off on on off on on off on on on on on off on on on off off on on on off on) #30(on on on off on on on off on on off on off off on off on on off on off on on on off on on on off on) #30(on on on off on on on off on on off on off off on on off on off on off on on on off on on on off on) #30(off on on off on on on off on on off on off off on off on on off on off on on on off on on on off on) #30(on off on off on on on off on on off on off off on on on on on off on on on on off on on on off on) #30(on on off off on on on off on on off on off off off off off off off on off on on on off on on on off on) #30(on on on off on on on off on on off on off off off off off on on on off on on off off on on on off on) #30(on on on off off on on off on on off on on on on on on on on on off on on on off on on on off on) #30(on on on off on on on off on on off on on on on on on on on on on off off off off on on on off on) #30(on on on off on on on off on on off on on on on on on on on on on on on on off on on on off on) #30(on on on off on on on off on on off off off off off off off off off off off off off off off on on on off on) #30(on on on off off on on off on on on on on on on on on on on on on on on on on on on on off on) #30(on on on off on on on off on on on off off on on off off on on off off on off off on on on on off on) #30(on on off off on on on off on on on off off on on off off on on off off on off off on on on on off on) #30(on off on off on on on off on on on on on on on on on on on on on on on on on on on on off on) #30(off on on off on on on off off off off off off off off off off off off off off off off off off off off off off on) #30(on on on off on on off on on on on on on on on on on on on on on on on on on on on on off on) #30(on on on off on on off on on on on on on on on on on on on on on on on on on on on off on) #30(on on on off on off on on on on on on on on on on on on on on on on on on on on on off on) #30(on on on off on off on on on on on on on on on on on on on on on on on on on on off on) #30(on on on off off on on on on on on on on on on on on on on on on on on on on on off on) #30(on on on off off on on on on on on on on on on on on on on on on on on on on off on) #30(on on on off off off off off off off off off off off off off off off off off off off off off off off on) #30(on) #30(on) #30(on) #30(on)))) (make-problem "19990613-FRA (16)" (quote ((40) (40) (8 2 23) (18 18) (22 14) (27 12) (27 12) (3 1 11) (3 1 1 10) (3 1 2 9) (3 1 8) (3 1 3 8) (3 1 1 1 8) (3 1 3 4) (3 1 7 4) (3 7 4) (3 1 7 4) (3 4) (5 13 6 7) (4 3 11 3 4 3 6) (4 3 11 3 4 3 6) (5 13 6 7) (40) (1 4 2 2) (40) (40) (40) (40) (40) (40))) (quote ((30) (23 6) (23 6) (7 5 6) (7 1 2 6) (7 2 1 6) (7 2 1 6) (7 2 1 6) (2 4 1 2 6) (2 4 5 6) (2 4 12) (2 4 12) (7 12) (7 12) (2 4 5 6) (2 4 5 6) (2 4 5 6) (7 5 6) (3 3 5 6) (3 3 5 6) (3 3 1 2 6) (3 3 2 1 6) (4 2 2 1 6) (4 2 2 8) (4 2 1 9) (4 2 5 6) (15 1 5 6) (5 5 6) (7 2 6 5 6) (8 1 1 4 1 2 6) (9 6 2 1 6) (10 3 2 1 6) (13 3 2 1 6) (13 3 1 9) (13 3 12) (13 5 6) (23 6) (23 6) (23 6) (23 6))) (quote #40(#30(on) #30(on on on on on on on on on on on on on on on on on on on on on on on off on) #30(on on on on on on on on on on on on on on on on on on on on on on on off on) #30(on on on on on on on off off off off off off off off off off off on on on on on off on) #30(on on on on on on on off off off off off off off off off off off on off off on on off on) #30(on on on on on on on off off off off off off off off off off off off on on off on off on) #30(on on on on on on on off off off off off off off off off off off off on on off on off on) #30(on on on on on on on off off off off off off off off off off off off on on off on off on) #30(on on off on on on on off off off off off off off off off off off on off off on on off on) #30(on on off on on on on off off off off off off off off off off off on on on on on off on) #30(on on off on on on on off off off off off off off off off off off on) #30(on on off on on on on off off off off off off off off off off off on) #30(on on on on on on on off off off off off off off off off off off on) #30(on on on on on on on off off off off off off off off off off off on) #30(on on off on on on on off off off off off off off off off off off on on on on on off on) #30(on on off on on on on off off off off off off off off off off off on on on on on off on) #30(on on off on on on on off off off off off off off off off off off on on on on on off on) #30(on on on on on on on off off off off off off off off off off off on on on on on off on) #30(on on on off on on on off off off off off off off off off off off on on on on on off on) #30(on on on off on on on off off off off off off off off off off off on on on on on off on) #30(on on on off on on on off off off off off off off off off off off on off off on on off on) #30(on on on off on on on off off off off off off off off off off off off on on off on off on) #30(on on on on off on on off off off off off off off off off off off off on on off on off on) #30(on on on on off on on off off off off off off off off off off off off on on off on) #30(on on on on off on on off off off off off off off off off off off on off off on) #30(on on on on off on on off off off off off off off off off off off on on on on on off on) #30(on on on on on on on on on on on on on on on off on off on on on on on off on) #30(on on on on on off off off off off off off off off off off off off on on on on on off on) #30(on on on on on on on off on on off on on on on on on off on on on on on off on) #30(on on on on on on on on off on off on off on on on on off on off off on on off on) #30(on on on on on on on on on off off on on on on on on off off on on off on off on) #30(on on on on on on on on on on off off off off on on on off off on on off on off on) #30(on on on on on on on on on on on on on off on on on off off on on off on off on) #30(on on on on on on on on on on on on on off on on on off on off off on) #30(on on on on on on on on on on on on on off on on on off on) #30(on on on on on on on on on on on on on off off off off off on on on on on off on) #30(on on on on on on on on on on on on on on on on on on on on on on on off on) #30(on on on on on on on on on on on on on on on on on on on on on on on off on) #30(on on on on on on on on on on on on on on on on on on on on on on on off on) #30(on on on on on on on on on on on on on on on on on on on on on on on off on)))) (make-problem "19990714aNEP (17)" (quote ((33) (2) (1 1 3 3 1 1 1 1 2 2 2 3) (1 1 1 1 1 1 1 1 1 1 1 1 1 3) (1 1 3 1 1 1 1 1 1 1 1 2 3) (1 1 1 3 3 3 1 1 1 2) (1 1 2) (26 2) (2 2) (2 3) (2 3) (2 6) (1 6) (1 6) (2 6) (2 7) (2 7) (2 7) (2 8) (2 8) (2 8) (2 8) (3 6) (2 4) (2 3) (2 2) (2 7) (2 11) (5 13) (4 14))) (quote ((1 3 4) (1 1 2 2) (1 3 2 2) (1 2 2) (1 4 2 2) (1 1 1 1 2) (1 4 1 2) (1 1 2) (1 4 1 2) (1 1 1 1 1) (1 1 1 1 2) (1 1 2) (1 4 1 2) (1 1 1 2) (1 4 1 2) (1 1 2) (1 4 1 1) (1 1 1 1) (1 4 1 1) (1 1 2) (1 4 1 1) (1 1 1 1) (1 2 1 1) (1 1 1) (1 6 1) (1 1 2) (1 1 3) (1 1 3) (1 1 5 3) (1 4 10 4) (1 3 19) (3 21) (2 20 4) (20 4) (3 11 4) (2 11 4) (1 3) (2) () ())) (quote #f)) (make-problem "19990729-DAH (18)" (quote ((16 16) (11 6 11) (9 16 9) (7 7 9 7) (5 4 3 4 5) (4 4 3 4 4) (3 3 3 3 3 3) (2 4 3 7 4 2) (1 3 3 11 3 1) (4 3 7 3 4) (3 3 7 3 3) (3 3 7 3 3) (3 3 8 3 3) (3 3 9 3 3) (3 3 9 3 3) (3 3 10 3 3) (3 3 9 3 3) (3 3 8 3 3) (3 3 8 3 3) (3 3 7 3 3) (4 3 7 3 4) (1 3 11 3 3 1) (2 4 7 3 4 2) (3 3 3 3 3 3) (4 4 3 4 4) (5 4 3 4 5) (7 9 7 7) (9 15 9) (12 6 11) (16 16))) (quote ((9 6 9) (8 10 8) (7 12 7) (6 4 4 6) (5 3 3 5) (4 4 4 4) (4 3 3 4) (3 3 3 3) (3 2 6 2 3) (2 2 10 2 2) (2 2 12 2 2) (1 2 4 4 2 2) (1 2 2 2 1 1) (1 2 2 2 2 1) (1 2 1 2 2 1) (1 2 2 4 3 2 1) (2 1 7 4 2) (2 2 15 3) (2 1 15 4) (2 2 15 1 2) (2 1 15 2 2) (4 15 1 2) (3 15 2 2) (2 4 7 1 2) (1 2 3 4 2 2 1) (1 2 2 1 2 1) (1 2 2 2 2 1) (1 2 2 2 2 1) (1 2 4 4 2 1) (2 2 12 2 2) (2 2 10 2 2) (3 2 6 2 3) (3 3 3 3) (4 3 3 4) (4 4 4 4) (5 3 3 5) (6 4 4 6) (7 12 7) (8 10 8) (9 6 9))) (quote #40(#30(on on on on on on on on on off off off on on on on on on off off off on) #30(on on on on on on on on off off on on on on on on on on on on off off on) #30(on on on on on on on off off on on on on on on on on on on on on off off on) #30(on on on on on on off off on on on on off off off off off off on on on on off off on) #30(on on on on on off off on on on off off off off off off off off off off on on on off off on) #30(on on on on off off on on on on off off off off off off off off off off on on on on off off on) #30(on on on on off on on on off off off off off off off off off off off off off off on on on off on) #30(on on on off off on on on off off off off off off off off off off off off off off on on on off off on) #30(on on on off on on off off off off off off on on on on on on off off off off off off on on off on) #30(on on off off on on off off off off on on on on on on on on on on off off off off on on off off on) #30(on on off on on off off off off on on on on on on on on on on on on off off off off on on off on) #30(on off off on on off off off on on on on off off off off off off on on on on off off off on on off on) #30(on off on on off off off off on on off off off off off off off off off off on on off off off off on off off on) #30(on off on on off off off on on off off off off off off off off off off off off on on off off off on on off on) #30(on off on on off off off on off off off off off off off off off off off off off on on off off off on on off on) #30(on off on on off off on on off off off off on on on on off off off off off on on on off off on on off on) #30(off off on on off off on off off off on on on on on on on off off off on on on on off off on on off) #30(off on on off off on on off off on on on on on on on on on on on on on on on off off on on on off) #30(off on on off off on off off on on on on on on on on on on on on on on on off off on on on on off) #30(off on on off on on off off on on on on on on on on on on on on on on on off off on off on on off) #30(off on on off on off off on on on on on on on on on on on on on on on off off on on off on on off) #30(off on on on on off off on on on on on on on on on on on on on on on off off on off off on on off) #30(off on on on off off on on on on on on on on on on on on on on on off off on on off off on on off) #30(off off on on off off on on on on off off off on on on on on on on off off off on off off on on off) #30(on off on on off off on on on off off off off off off on on on on off off off on on off off on on off on) #30(on off on on off off off on on off off off off off off off off off off off off off on off off off on on off on) #30(on off on on off off off on on off off off off off off off off off off off off on on off off off on on off on) #30(on off on on off off off off on on off off off off off off off off off off on on off off off off on on off on) #30(on off off on on off off off on on on on off off off off off off on on on on off off off on on off off on) #30(on on off on on off off off off on on on on on on on on on on on on off off off off on on off on) #30(on on off off on on off off off off on on on on on on on on on on off off off off on on off off on) #30(on on on off on on off off off off off off on on on on on on off off off off off off on on off on) #30(on on on off off on on on off off off off off off off off off off off off off off on on on off off on) #30(on on on on off on on on off off off off off off off off off off off off off off on on on off on) #30(on on on on off off on on on on off off off off off off off off off off on on on on off off on) #30(on on on on on off off on on on off off off off off off off off off off on on on off off on) #30(on on on on on on off off on on on on off off off off off off on on on on off off on) #30(on on on on on on on off off on on on on on on on on on on on on off off on) #30(on on on on on on on on off off on on on on on on on on on on off off on) #30(on on on on on on on on on off off off on on on on on on off off off on)))) (make-problem "19990924-KHO (19)" (quote (() (37) (31) (24) (17) (14) (21 13) (23 4) (24 3) (8 8 3) (9 10 2) (10 13 2) (11 3 2) (12 3 2) (13 3 2) (14 5 2 3) (15 6 1 3) (16 6 4) (22 7) (19 10) (16 13) (13 16) (10 19) (7 22) (4 25) (1 28) (31) (34) (37) ())) (quote (() (20) (1 19 1) (1 19 1) (1 19 1) (1 18 2) (1 18 2) (1 18 2) (2 17 3) (2 3 13 3) (2 3 12 3) (2 3 10 4) (2 3 9 4) (2 3 8 4) (2 3 6 5) (3 3 5 5) (3 3 4 5) (3 3 2 6) (3 3 2 6) (3 3 2 6) (3 3 2 7) (3 3 2 7) (4 2 1 2 7) (4 2 1 2 8) (4 1 1 2 8) (5 2 2 8) (6 3 2 9) (6 3 2 9) (6 3 2 9) (6 3 1 10) (6 3 1 10) (6 3 10) (6 6 11) (6 8 11) (6 6 11) (7 12) (9 14) (28) (28) ())) (quote #40(#30(off) #30(off off off off off off on on on on on on on on on on on on on on on on on on on on off) #30(off on off off off off on on on on on on on on on on on on on on on on on on on off off off on off) #30(off on off off off off on on on on on on on on on on on on on on on on on on on off off off on off) #30(off on off off off off on on on on on on on on on on on on on on on on on on on off off off on off) #30(off on off off off off on on on on on on on on on on on on on on on on on on off off off on on off) #30(off on off off off off on on on on on on on on on on on on on on on on on on off off off on on off) #30(off on off off off off on on on on on on on on on on on on on on on on on on off off off on on off) #30(off on on off off off on on on on on on on on on on on on on on on on on off off off on on on off) #30(off on on off off off on on on off on on on on on on on on on on on on on off off off on on on off) #30(off on on off off off on on on off off on on on on on on on on on on on on off off off on on on off) #30(off on on off off off on on on off off off on on on on on on on on on on off off off on on on on off) #30(off on on off off off on on on off off off off on on on on on on on on on off off off on on on on off) #30(off on on off off off on on on off off off off off on on on on on on on on off off off on on on on off) #30(off on on off off off on on on off off off off off off on on on on on on off off off on on on on on off) #30(off on on on off off on on on off off off off off off off on on on on on off off off on on on on on off) #30(off on on on off off on on on off off off off off off off off on on on on off off off on on on on on off) #30(off on on on off off on on on off off off off off off off off off on on off off off on on on on on on off) #30(off on on on off off on on on off off off off off off off off off on on off off off on on on on on on off) #30(off on on on off off on on on off off off off off off off off off on on off off off on on on on on on off) #30(off on on on off off on on on off off off off off off off off on on off off off on on on on on on on off) #30(off on on on off off on on on off off off off off off off off on on off off off on on on on on on on off) #30(off on on on on off off on on off off on off off off off off on on off off off on on on on on on on off) #30(off on on on on off off on on off off on off off off off on on off off off on on on on on on on on off) #30(off on on on on off off off on off off on off off off off on on off off off on on on on on on on on off) #30(off on on on on on off off off off on on off off off off on on off off off on on on on on on on on off) #30(off on on on on on on off off on on on off off off on on off off off on on on on on on on on on off) #30(off on on on on on on off off on on on off off off on on off off off on on on on on on on on on off) #30(off on on on on on on off off on on on off off off on on off off off on on on on on on on on on off) #30(off on on on on on on off off on on on off off off on off off off on on on on on on on on on on off) #30(off on on on on on on off off on on on off off off on off off off on on on on on on on on on on off) #30(off on on on on on on off off on on on off off off off off off off on on on on on on on on on on off) #30(off on on on on on on off off on on on on on on off off off on on on on on on on on on on on off) #30(off on on on on on on off off on on on on on on on on off on on on on on on on on on on on off) #30(off on on on on on on off off off on on on on on on off off on on on on on on on on on on on off) #30(off on on on on on on on off off off off off off off off off on on on on on on on on on on on on off) #30(off on on on on on on on on on off off off off off on on on on on on on on on on on on on on off) #30(off on on on on on on on on on on on on on on on on on on on on on on on on on on on on off) #30(off on on on on on on on on on on on on on on on on on on on on on on on on on on on on off) #30(off)))) (make-problem "19990928-BBA (20)" (quote ((3 2) (1 2) (3) (3) (1 2 27) (1 1 1 2 3 3 2 2 1) (3 2 1 2 1 1 3 2) (1 1 2 1 1 1 3 3) (1 1 3 3 1 1 3 1 3) (3 1 5 2 1 1 3 2 3) (5 8 8 1 5) (3 1 5 1 4 1 5) (1 1 3 1 1 2 1 5) (1 1 1 3 1 1 1 2 3) (1 1 1 1 2 1 3) (1 1 1 1 2 3) (1 3 1 1 1 1 3) (1 1 1 1 1 1 3) (1 1 1 1 1 1 1 1 3) (1 1 1 1 1 1 1 1 1 3) (2 1 1 3 15) (2 2 5 2 1 5) (1 1 1 2 3 1 1 4) (1 5 1 2 3 3 2) (1 3 1 3 2 1 1 1 1) (1 1 1 1 1 2 1 3 1) (1 6 1 7 1 1) (1 1 1 2 3 1 2 2) (1 7 1 13) (1 2 3 2 4 2 1))) (quote ((1 1) (7 1) (1 2 1 3) (4 5) (2 3 3) (1 1 1) () (26) (1 1 2) (1 3 1 7) (1 5 1 1 2 1 2) (1 7 11) (1 5 1 1 1) (2 3 1 1 5 1) (4 1 1 2 4) (1 4 2 1 2 1 3) (2 5 3 3 3 1) (3 1 1 1 1 2 1 1) (2 1 2 1 1 1 2 3) (1 1 1 1 1 3 1) (2 1 2 7 1) (3 1 9 2 5) (2 1 3 1 1 1 1) (1 11 1 3 1 2) (2 3 2 2 1 1 2) (5 6 2 2 2) (1 2 2 2 1 1 2) (3 3 3 1 3 3) (2 2 2 1 1 2) (1 5 2 1 2) (1 3 3 3 2) (1 16 1 1) (1 18 2) (26) () () () () () ())) (quote #f)) (make-problem "19991011bLLO (21)" (quote ((9) (4 2 4 3) (6 2 5 2) (5 12 4) (1 13 7) (3 3 5 3 4 2) (4 4 2 4 1 5) (1 4 8 10) (2 7 4 1 4 1) (7 4 1 6 3) (4 4 8 5 1) (2 4 1 3 4 4 1 2) (11 9 5) (3 2 6 1 5 1) (3 4 1 4 5 2 1) (1 5 5 3 1 2 1) (7 2 8) (5 1 1 1 3) (4 1 1) (4 1 1) (3 1 1) (3 1 1) (3 1 1) (3 1 1) (3 1 1 10) (3 1 1 2 2) (4 1 1 5 4 5) (5 6 1 1 2 1 1) (5 1 4 1) (8 1 1 2 2 1 1))) (quote ((7 3 1) (1 2 7) (7 2 3 1) (4 2 4 2 1) (5 6 2 4) (2 6 19) (5 22) (3 3 1 1 16) (1 6 3 1 4 3) (2 3 4 2 3 1) (1 8 6) (8 3 1 1) (2 3 9 1) (5 2 1 5) (15 1 1) (1 2 2 1 3 2 11) (8 5 2 1) (5 7 3 1) (1 2 1 2 3 12) (7 6 1) (4 3 4 1) (10 4) (2 3 4 3 1) (3 1 1 1 2 2 1) (8 2 1 1 1) (2 2 2 2 1) (1 2 1 1 1) (2 1) (2 1) (3 2) (1 3) (1 3) (3 2) (2 1) (1) (1 1) (2 1) (1 1) (2 1) (1))) (quote #f)))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/solution-sets/k40x35 b/collects/games/paint-by-numbers/solution-sets/k40x35
new file mode 100644
index 0000000000..f894896322
--- /dev/null
+++ b/collects/games/paint-by-numbers/solution-sets/k40x35
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 40x35") (define problems (list (make-problem "19981012-TAB (1)" (quote ((12 13 13) (9 10) (12 13 13) (9 10) (13 9 14) (12 13 13) (12 13 13) (11 15 12) (11 11 12) (11 5 12) (11 1 12) (11 12) (12 13) (13 14) (14 15) (16 17) (18 19) (18 1 19) (18 19) (16 3 17) (14 3 3 15) (13 11 14) (12 6 6 13) (11 7 7 12) (11 6 6 12) (11 5 5 12) (11 4 4 12) (11 3 3 12) (12 1 1 13) (12 13) (13 14) (9 10) (12 13 13) (9 10) (12 13 13))) (quote ((35) (35) (35) (35) (35) (35) (35) (35) (35) (1 1 27 1 1) (1 1 27 1 1) (1 1 3 11 3 1 1) (1 1 9 5 1) (1 1 3 7 7 1 1) (1 1 4 5 7 1 1) (1 1 5 5 6 1 1) (1 1 5 3 6 1 1) (1 1 6 3 5 1 1) (1 1 6 5 1 1) (1 1 7 1 1 1 1 1) (1 1 6 5 1 1) (1 1 6 3 5 1 1) (1 1 5 3 6 1 1) (1 1 5 5 6 1 1) (1 1 4 5 7 1 1) (1 1 3 7 7 1 1) (1 1 9 5 1) (1 1 3 11 3 1 1) (1 1 27 1 1) (1 1 27 1 1) (35) (35) (35) (35) (35) (35) (35) (35) (35) (35))) (quote #40(#35(on) #35(on) #35(on) #35(on) #35(on) #35(on) #35(on) #35(on) #35(on) #35(on off on off on on on on on on on on on on on on on on on on on on on on on on on on on on on off on off on) #35(on off on off on on on on on on on on on on on on on on on on on on on on on on on on on on on off on off on) #35(on off on off on on on off off off off off on on on on on on on on on on on off off off off off on on on off on off on) #35(off off off off on off off on off off off off off on on on on on on on on on off on on on on on off off on off) #35(on off on off off on on on off off off off off off on on on on on on on off on on on on on on on off off off on off on) #35(on off on off off on on on on off off off off off off on on on on on off on on on on on on on off off off off on off on) #35(on off on off on on on on on off off off off off off on on on on on off on on on on on on off off off off off on off on) #35(on off on off on on on on on off off off off off off off on on on off on on on on on on off off off off off off on off on) #35(on off on off on on on on on on off off off off off off on on on off on on on on on off off off off off off off on off on) #35(on off on off on on on on on on off off off off off off off off off on on on on on off off off off off off off off on off on) #35(on off on off on on on on on on on off off off off off off on off on off on off off off off off off off off off off on off on) #35(on off on off on on on on on on off off off off off off off off off on on on on on off off off off off off off off on off on) #35(on off on off on on on on on on off off off off off off on on on off on on on on on off off off off off off off on off on) #35(on off on off on on on on on off off off off off off off on on on off on on on on on on off off off off off off on off on) #35(on off on off on on on on on off off off off off off on on on on on off on on on on on on off off off off off on off on) #35(on off on off off on on on on off off off off off off on on on on on off on on on on on on on off off off off on off on) #35(on off on off off on on on off off off off off off on on on on on on on off on on on on on on on off off off on off on) #35(off off off off on off off on off off off off off on on on on on on on on on off on on on on on off off on off) #35(on off on off on on on off off off off off on on on on on on on on on on on off off off off off on on on off on off on) #35(on off on off on on on on on on on on on on on on on on on on on on on on on on on on on on on off on off on) #35(on off on off on on on on on on on on on on on on on on on on on on on on on on on on on on on off on off on) #35(on) #35(on) #35(on) #35(on) #35(on) #35(on) #35(on) #35(on) #35(on) #35(on)))) (make-problem "19981216-JTR (2)" (quote ((40) (14 10 14) (3 7 8 7 3) (2 1 1 4 8 4 2 2) (1 2 4 1 4 6 4 5 1) (2 1 4 4 4 2 1 1) (3 2 2 1 3 4 3 1 2 2 3) (2 1 2 3 1 3 2 3 1 1 1 2 1) (1 2 3 1 2 2 2 1 3 1 2 1) (2 3 2 2 1 1 2 1 1 2 2 2 2) (1 1 1 1 1 2 1 1 1 1 1 1 1 1 1) (2 6 1 1 1 1 6 1 2) (1 1 2 1 3 1 1 1 1 1 2 1) (1 1 4 2 1 2 2 6 1 1) (2 2 1 1 4 2 1 3 1 1 2) (3 3 3 1 2 1 3 2 3) (4 2 1 3 2 5 3 4) (5 2 7 2 1 3 3 5) (6 2 2 2 6) (5 7 2 7 5) (5 5 1 2 1 5 5) (5 2 1 1 1 2 1 1 5) (4 1 1 1 5 2 6 1 2 4) (4 1 4 1 1 2 1 1 4 4) (4 2 1 1 1 1 2 1 1 1 3 4) (4 1 1 2 1 1 2 2 1 2 1 1 4) (4 1 1 2 1 2 2 1 2 1 4) (4 2 1 1 1 1 1 1 2 1 2 4) (5 3 1 1 2 2 1 1 2 5) (6 1 1 1 8 1 2 1 6) (7 5 8 1 7) (8 10 8) (40) (40) (40))) (quote ((5 23) (4 5 21) (3 1 2 1 2 20) (2 3 2 2 19) (2 1 1 1 1 1 5 7) (2 1 3 1 1 1 1 3 6) (2 2 4 1 3 2 2 1 5) (2 1 2 1 1 3 3 3 4) (3 1 3 1 2 1 2 2 3) (3 2 1 5 1 1 2 3 1 3) (3 1 3 1 1 1 1 1 1 2 1 1 3) (4 1 2 2 1 1 1 1 3 2 3) (5 1 2 2 2 1 1 2 1 3) (6 1 2 1 1 1 1 6 1 3) (1 5 1 1 3 1 1 1 1 3) (2 4 1 1 2 2 2 3 3 4) (4 4 1 1 1 2 1 1 2 6) (5 3 1 2 1 1 7) (7 2 8) (10 13 6) (10 13 6) (7 2 8) (5 3 3 1 1 1 7) (4 4 1 2 1 1 2 2 6) (2 4 1 1 2 2 2 3 3 4) (1 5 1 1 1 1 1 1 1 1 3) (6 1 1 1 2 1 6 3) (5 1 2 3 1 1 1 3 3) (4 2 2 1 1 1 1 3 2 3) (3 1 1 1 1 1 1 2 2 3) (3 2 1 1 4 1 1 1 3 3) (3 1 5 1 3 1 1 1 2 3) (2 1 1 1 1 2 2 1 2 4) (2 2 2 1 1 1 1 1 1 1 1 5) (2 3 1 3 1 1 1 2 6) (2 1 1 1 3 5 7) (2 1 1 1 2 19) (3 2 1 1 20) (4 4 21) (5 23))) (quote #f)) (make-problem "19990420-DRA (3)" (quote ((40) (40) (40) (6 2 30) (6 29) (5 1 28) (4 1 2 27) (3 3 26) (2 5 25) (1 5 24) (1 5 5 23) (2 7 5 6 4 3) (11 5 2 1 2) (11 6 4 1) (11 4 2 1) (11 1 1 1 1 1) (11 1 1 1) (10 1 2) (9 1 2) (7 2 1 1) (6 4 3 1 1) (5 2 10 4 1) (4 5 11 5 1) (4 5 10 1 3 2) (5 4 11 2 5) (6 3 11 4 5) (7 3 11 5 5) (7 2 11 5 6) (8 2 11 5 6) (9 2 11 5 6) (12 11 4 6) (12 11 4 5) (11 13 3 6) (40) (40))) (quote ((35) (9 24) (8 23) (7 24) (6 12 11) (5 11 10) (3 10 9) (4 1 9 2 7) (4 9 3 6) (3 1 7 6 5) (4 5 5 14) (5 5 10 2) (6 5 1 2) (7 6 2) (8 6 7 3) (9 6 13) (10 4 14) (11 4 14) (11 14) (11 14) (11 14) (12 14) (12 15) (12 15) (12 15) (12 3 4) (12 3) (11 4 2) (11 11) (11 12) (11 10) (12 7 2) (13 2) (13 3 2) (12 1 5 4 3) (11 1 20) (11 3 14) (12 4 2 1 11) (13 2 12) (35))) (quote #40(#35(on) #35(on on on on on on on on on off off on) #35(on on on on on on on on off off off off on) #35(on on on on on on on off off off off on) #35(on on on on on on off off off off on on on on on on on on on on on on off off on) #35(on on on on on off off off off off on on on on on on on on on on on off off off off on) #35(on on on off off off off off off off on on on on on on on on on on off off off off off off on) #35(on on on on off off on off off off on on on on on on on on on off off off on on off off off off on) #35(on on on on off off off off off off on on on on on on on on on off off off on on on off off off off on) #35(on on on off off off off off on off off on on on on on on on off off off on on on on on on off off off on) #35(on on on on off on on on on on off off on on on on on off off off off on) #35(on on on on on off on on on on on off off off off off off off off off off off on on on on on on on on on on off on) #35(on on on on on on off on on on on on off on off off off off off off off off off off off off off off off off off off off on) #35(on on on on on on on off on on on on on on off off off off off off off off off off off off off off off off off off off on) #35(on on on on on on on on off on on on on on on off off off off off off off off off on on on on on on on off on) #35(on on on on on on on on on off on on on on on on off off off off off off on) #35(on on on on on on on on on on off on on on on off off off off off off on) #35(on on on on on on on on on on on off on on on on off off off off off on) #35(on on on on on on on on on on on off off off off off off off off off off on) #35(on on on on on on on on on on on off off off off off off off off off off on) #35(on on on on on on on on on on on off off off off off off off off off off on) #35(on on on on on on on on on on on on off off off off off off off off off on) #35(on on on on on on on on on on on on off off off off off off off off on) #35(on on on on on on on on on on on on off off off off off off off off on) #35(on on on on on on on on on on on on off off off off off off off off on) #35(on on on on on on on on on on on on off off off off off off off off on on on off off off off off off off off on) #35(on on on on on on on on on on on on off off off off off off off off off off off off off off off off off off off off on) #35(on on on on on on on on on on on off off off off off off off off off off off off off off off on on on on off off off on) #35(on on on on on on on on on on on off off off off off off off off off off off off off on) #35(on on on on on on on on on on on off off off off off off off off off off off off on) #35(on on on on on on on on on on on off off off off off off off off off off off off off off on) #35(on on on on on on on on on on on on off off off off off off off off off off off off off on on on on on on on off on) #35(on on on on on on on on on on on on on off off off off off off off off off off off off off off off off off off off off on) #35(on on on on on on on on on on on on on off off off off off off off on on on off off off off off off off off off off on) #35(on on on on on on on on on on on on off on off off off off off on on on on on off off off on on on on off on) #35(on on on on on on on on on on on off off on off on) #35(on on on on on on on on on on on off on on on off off off off off off on) #35(on on on on on on on on on on on on off on on on on off off on on off on off on) #35(on on on on on on on on on on on on on off off off off on on off off off off on) #35(on)))))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/solution-sets/k40x40 b/collects/games/paint-by-numbers/solution-sets/k40x40
new file mode 100644
index 0000000000..e61d63b9f4
--- /dev/null
+++ b/collects/games/paint-by-numbers/solution-sets/k40x40
@@ -0,0 +1 @@
+(unit/sig paint-by-numbers:problem-set^ (import paint-by-numbers:problem^) (define set-name "Kajitani 40x40") (define problems (list (make-problem "19980410-KVL (1)" (quote ((40) (7 14 6 4) (6 5 3 15 3) (5 1 4 17 2) (2 2 1 5 8 8 2) (5 7 17 2) (4 17 3) (2 11 16 4) (1 2 1 1 1 2 9 12) (1 2 1 1 1 2 22) (2 11 6 8 7) (4 25) (8 29) (8 27) (9 5 5 11 2) (3 5 15 8) (10 23) (10 21) (11 6 9 3) (6 4 18) (12 8 8) (2 9 15) (13 14) (13 12) (14 2 11) (14 3 2 9) (15 2 8) (15 1 4 6) (16 5 3 5) (7 8 1 3) (1 5 8 1 2) (2 7 2) (3 10) (3 3 10) (3 3 32) () () () () ())) (quote ((35) (8 20 4) (4 2 2 10 9 3) (7 2 4 15) (6 1 1 19 2) (3 1 1 19 2) (2 3 4 7 11 2) (1 1 1 1 1 17) (1 1 2 1 1 16 3) (1 4 4 15 3) (1 4 1 1 17) (1 4 1 1 1 15) (2 3 4 1 13) (3 1 1 2 11) (6 1 1 3 9) (7 2 4 7) (2 4 2 5 5) (8 7 3) (17 2 1) (14 3 1 1) (19 1 1 1 1) (19 1 5 1) (4 15 4 1) (10 10 2 1) (21 2 2 1) (14 7 2 1 1) (1 16 4 1 1) (8 14 1) (24 1) (25 1) (25 1) (3 9 4 5 1) (2 3 16 1) (1 19 1) (1 20 1) (1 21 1) (2 11 10 1) (3 8 15 1) (31 1) (31 1))) (quote #40(#40(on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on off) #40(on on on on on on on on off off on on on on on on on on on on on on on on on on on on on on off on on on on off) #40(on on on on off on on off on on off on on on on on on on on on on off on on on on on on on on on off on on on off) #40(on on on on on on on off on on off on on on on off on on on on on on on on on on on on on on on off) #40(on on on on on on off on off off on off on on on on on on on on on on on on on on on on on on on off off on on off) #40(on on on off off off off on off off on off on on on on on on on on on on on on on on on on on on on off off on on off) #40(on on off on on on off on on on on off on on on on on on on off on on on on on on on on on on on off off on on off) #40(on off on off off on off on off off on off on on on on on on on on on on on on on on on on on off) #40(on off on off on on off on off off on off off off on on on on on on on on on on on on on on on on off off on on on off) #40(on off on on on on off on on on on off off off off off on on on on on on on on on on on on on on on off on on on off) #40(on off on on on on off on off off on off off off off off off off on on on on on on on on on on on on on on on on on off) #40(on off on on on on off on off off on off on off off off off off off off on on on on on on on on on on on on on on on off) #40(on on off on on on off on on on on off on off off off off off off off off off on on on on on on on on on on on on on off) #40(on on on off off off off on off off on off on on off off off off off off off off off off on on on on on on on on on on on off) #40(on on on on on on off on off off on off on on on off off off off off off off off off off off on on on on on on on on on off) #40(on on on on on on on off on on off on on on on off off off off off off off off off off off off off on on on on on on on off) #40(on on off on on on on off on on off on on on on on off off off off off off off off off off off off off off on on on on on off) #40(on on on on on on on on off off on on on on on on on off off off off off off off off off off off off off off off on on on off) #40(on on on on on on on on on on on on on on on on on off off off off off off off off off off on on off off off off off on off) #40(on on on on on on on on on on on on on on off on on on off off off off off off off off off off on off off off off off on off) #40(on on on on on on on on on on on on on on on on on on on off off off off off off on off off on off off on off off on off) #40(on on on on on on on on on on on on on on on on on on on off off off off off off on off on on on on on off off on off) #40(on on on on off on on on on on on on on on on on on on on on off off off off off on on on on off off off off off on off) #40(on on on on on on on on on on off on on on on on on on on on on off off off off off on on off off off off off off on off) #40(on on on on on on on on on on on on on on on on on on on on on off off off on on off on on off off off off off on off) #40(on on on on on on on on on on on on on on off on on on on on on on off off on on off off on off off off off off on off) #40(on off on on on on on on on on on on on on on on on on off on on on on off off off off off on off off off off off on off) #40(on on on on on on on on off on on on on on on on on on on on on on on off off off off off off off off off off off on off) #40(on on on on on on on on on on on on on on on on on on on on on on on on off off off off off off off off off off on off) #40(on on on on on on on on on on on on on on on on on on on on on on on on on off off off off off off off off off on off) #40(on on on on on on on on on on on on on on on on on on on on on on on on on off off off off off off off off off on off) #40(on on on off off off on on on on on on on on on off on on on on off on on on on on off off off off off off off off on off) #40(on on off off off off off on on on off on on on on on on on on on on on on on on on on off off off off off off off on off) #40(on off off off off off off off on on on on on on on on on on on on on on on on on on on off off off off off off off on off) #40(on off off off off off off off on on on on on on on on on on on on on on on on on on on on off off off off off off on off) #40(on off off off off off off off on on on on on on on on on on on on on on on on on on on on on off off off off off on off) #40(on on off off off off off on on on on on on on on on on on off on on on on on on on on on on off off off off off on off) #40(on on on off off off on on on on on on on on off on on on on on on on on on on on on on on on off off off off on off) #40(on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on off off off on off) #40(on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on off off off on off)))) (make-problem "19980512-SDN (2)" (quote ((18) (26) (20 2) (2 9 2) (1 1 2) (2 2 2) (2 2 10 2) (1 1 18 2) (2 18 3 2) (13 2 1 2) (2 1 2) (2 1 2) (2 1 2) (2 1 2) (4 1 2) (11 1 2) (18 1 1 2) (2 8 1 1 2) (1 1 1 1 2) (2 2 1 1 2) (2 2 8 2) (1 1 16 2) (2 19 2) (13 2) (2) (2) (2) (2) (2) (13) (24) (22 2) (2 8 2) (1 1 2) (2 2 2) (2 2 11) (1 1 22) (2 21) (13) ())) (quote (() (2) (6) (2 2 2) (1 1 6 2) (1 1 2 2 6) (2 2 1 1 2 2) (8 1 1 1 1) (2 2 2 2 2 1 1) (2 2 8 2 2) (2 2 2 2 2 8) (2 2 2 2 2 2 2) (2 2 2 2 2 2) (2 2 2 2 2 2) (3 2 2 2 2 2) (2 3 3 2 2 2) (2 2 2 2 3 2) (2 2 2 3 2 2) (2 2 2 2 2 3) (2 2 2 2 2 2) (2 2 2 2 2 2) (2 2 2 2 2 2) (3 2 3 2 2 2) (2 3 2 2 2 2) (2 2 2 2 2 2) (2 2 10 2 2) (2 2 2 3 2 2) (2 2 2 2 3 2) (2 2 2 2 2 2) (2 2 2 2 2 3) (2 4 2 2 2) (2 3 2 2 2) (2 16 2 2) (2 2 2) (2 2 2) (2 2 2) (2 2 2) (2 2 2) (37) (37))) (quote #f)) (make-problem "19980716dGAS (3)" (quote ((40) (18 18) (17 17) (16 4 16) (15 6 15) (14 8 14) (13 10 13) (12 12 12) (11 5 5 11) (10 5 5 10) (9 6 6 9) (8 7 7 8) (7 8 8 7) (6 1 1 10 6) (5 2 4 15 5) (4 3 3 15 4) (3 4 1 1 16 3) (2 5 1 2 5 8 2) (1 6 3 5 8 1) (1 4 7 1) (1 6 9 8 1) (1 7 8 9 1) (2 6 19 2) (3 5 1 17 3) (4 4 2 16 4) (5 3 2 5 8 5) (6 2 2 4 6 6) (7 1 3 4 4 7) (8 2 2 2 8) (9 2 2 1 9) (10 16 10) (11 14 11) (12 12 12) (13 10 13) (14 8 14) (15 6 15) (16 4 16) (17 17) (18 18) (40))) (quote ((40) (18 18) (17 17) (16 4 16) (15 6 15) (14 8 14) (13 10 13) (12 5 6 12) (11 6 7 11) (10 1 7 10) (9 2 4 9) (8 3 2 8) (7 4 2 1 1 7) (6 5 1 9 6) (5 6 9 5) (4 7 1 1 4 4) (3 8 2 2 5 3) (2 5 1 3 3 1 6 2) (1 5 1 17 1) (1 5 5 17 1) (1 5 5 8 7 1) (1 5 5 7 7 1) (2 5 6 6 6 2) (3 14 5 5 3) (4 11 3 4 4) (5 10 4 3 5) (6 9 5 2 6) (7 8 6 1 7) (8 8 9 8) (9 8 9 9) (10 16 10) (11 14 11) (12 12 12) (13 10 13) (14 8 14) (15 6 15) (16 4 16) (17 17) (18 18) (40))) (quote #40(#40(on) #40(on on on on on on on on on on on on on on on on on on off off off off on) #40(on on on on on on on on on on on on on on on on on off off off off off off on) #40(on on on on on on on on on on on on on on on on off off on on on on off off on) #40(on on on on on on on on on on on on on on on off off on on on on on on off off on) #40(on on on on on on on on on on on on on on off off on on on on on on on on off off on) #40(on on on on on on on on on on on on on off off on on on on on on on on on on off off on) #40(on on on on on on on on on on on on off off on on on on on off on on on on on on off off on) #40(on on on on on on on on on on on off off on on on on on on off on on on on on on on off off on) #40(on on on on on on on on on on off off on off off off off off off off off on on on on on on on off off on) #40(on on on on on on on on on off off on on off on on on on off off off off off off off off off off off off off on) #40(on on on on on on on on off off on on on off on on off off off off off off off off off off off off off off off off on) #40(on on on on on on on off off on on on on off on on off off off off off off off off off off off on off off on off off on) #40(on on on on on on off off on on on on on off on off off off off off off off off on on on on on on on on on off off on) #40(on on on on on off off on on on on on on off off off off off off off off off off off on on on on on on on on on off off on) #40(on on on on off off on on on on on on on off off off off off on off on off off off off off off off off off on on on on off off on) #40(on on on off off on on on on on on on on off off off off on on off on on off off off off off off off off on on on on on off off on) #40(on on off off on on on on on off off off off on off off on on on off on on on off off off off on off off on on on on on on off off on) #40(on off off on on on on on off off off off off off on off off off off off on on on on on on on on on on on on on on on on on off off on) #40(on off off on on on on on off off off off off off on on on on on off on on on on on on on on on on on on on on on on on off off on) #40(on off off on on on on on off off off off off off on on on on on off on on on on on on on on off off on on on on on on on off off on) #40(on off off on on on on on off off off off off off on on on on on off on on on on on on on off off off on on on on on on on off off on) #40(on on off off on on on on on off off off off on on on on on on off on on on on on on off off off off on on on on on on off off on) #40(on on on off off on on on on on on on on on on on on on on off on on on on on off off off off off on on on on on off off on) #40(on on on on off off on on on on on on on on on on on off off off off off on on on off off off off off on on on on off off on) #40(on on on on on off off on on on on on on on on on on off off off off off on on on on off off off off on on on off off on) #40(on on on on on on off off on on on on on on on on on off off off off off on on on on on off off off on on off off on) #40(on on on on on on on off off on on on on on on on on off off off off off on on on on on on off off on off off on) #40(on on on on on on on on off off on on on on on on on on off off off on on on on on on on on on off off on) #40(on on on on on on on on on off off on on on on on on on on off on on on on on on on on on off off on) #40(on on on on on on on on on on off off on on on on on on on on on on on on on on on on off off on) #40(on on on on on on on on on on on off off on on on on on on on on on on on on on on off off on) #40(on on on on on on on on on on on on off off on on on on on on on on on on on on off off on) #40(on on on on on on on on on on on on on off off on on on on on on on on on on off off on) #40(on on on on on on on on on on on on on on off off on on on on on on on on off off on) #40(on on on on on on on on on on on on on on on off off on on on on on on off off on) #40(on on on on on on on on on on on on on on on on off off on on on on off off on) #40(on on on on on on on on on on on on on on on on on off off off off off off on) #40(on on on on on on on on on on on on on on on on on on off off off off on) #40(on)))) (make-problem "19980828-GOS (4)" (quote (() (20) (22) (24) (26) (28) (30) (32) (34) (36) (38) (4 3 3 4 4) (3 2 2 3 3) (2 1 1 2 2 2) (2 1 3 3 3 2 3 2) (2 3 3 2 5 1 3 2) (2 8 2 5 1 3 2) (2 7 2 5 1 2 2) (2 5 2 5 1 3) (2 5 2 5 1 4) (3 4 2 5 1 6) (4 3 2 5 1 6) (6 3 2 5 1 6) (7 3 2 5 1 6) (2 3 3 2 5 1 6) (2 1 3 3 3 2 6) (2 3 3 2 6) (3 4 4 3 6) (4 5 5 4 6) (38) (36) (34) (32) (30) (28) (26) (24) (22) (20) ())) (quote (() (20) (22) (5 4 5) (5 3 5) (5 2 3 5) (6 4 4 6) (7 3 2 7) (9 4 9) (11 5 11) (38) (10 25) (10 25) (10 10) (10 10) (10 10) (10 25) (10 25) (14 14) (12 12) (11 11) (10 10 10) (10 12 10) (10 12 10) (10 12 10) (10 10 10) (11 11) (12 12) (14 14) (38) (9 9) (8 8) (7 5 7) (6 5 15) (5 3 14) (5 14) (5 14) (22) (20) ())) (quote #40(#40(off) #40(off off off off off off off off off off on on on on on on on on on on on on on on on on on on on on off) #40(off off off off off off off off off on on on on on on on on on on on on on on on on on on on on on on off) #40(off off off off off off off off on on on on on off off off off off off off on on on on off off off on on on on on off) #40(off off off off off off off on on on on on off off off off off off off off off on on on off off off off on on on on on off) #40(off off off off off off on on on on on off off off off on on off off off off off on on on off off off off on on on on on off) #40(off off off off off on on on on on on off off off on on on on off off off off on on on on off off off on on on on on on off) #40(off off off off on on on on on on on off off off off on on on off off off off off on on off off off off on on on on on on on off) #40(off off off on on on on on on on on on off off off off on on on on off off off off off off off off on on on on on on on on on off) #40(off off on on on on on on on on on on on off off off on on on on on off off off off off off on on on on on on on on on on on off) #40(off on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on off) #40(off on on on on on on on on on on off off off on on on on on on on on on on on on on on on on on on on on on on on on on off) #40(off on on on on on on on on on on off off off on on on on on on on on on on on on on on on on on on on on on on on on on off) #40(off on on on on on on on on on on off off off off off off off off off off off off off off off off off off on on on on on on on on on on off) #40(off on on on on on on on on on on off off off off off off off off off off off off off off off off off off on on on on on on on on on on off) #40(off on on on on on on on on on on off off off off off off off off off off off off off off off off off off on on on on on on on on on on off) #40(off on on on on on on on on on on off off off on on on on on on on on on on on on on on on on on on on on on on on on on off) #40(off on on on on on on on on on on off off off on on on on on on on on on on on on on on on on on on on on on on on on on off) #40(off on on on on on on on on on on on on on on off off off off off off off off off off on on on on on on on on on on on on on on off) #40(off on on on on on on on on on on on on off off off off off off off off off off off off off off on on on on on on on on on on on on off) #40(off on on on on on on on on on on on off off off off off off off off off off off off off off off off on on on on on on on on on on on off) #40(off on on on on on on on on on on off off off off on on on on on on on on on on off off off off on on on on on on on on on on off) #40(off on on on on on on on on on on off off off on on on on on on on on on on on on off off off on on on on on on on on on on off) #40(off on on on on on on on on on on off off off on on on on on on on on on on on on off off off on on on on on on on on on on off) #40(off on on on on on on on on on on off off off on on on on on on on on on on on on off off off on on on on on on on on on on off) #40(off on on on on on on on on on on off off off off on on on on on on on on on on off off off off on on on on on on on on on on off) #40(off on on on on on on on on on on on off off off off off off off off off off off off off off off off on on on on on on on on on on on off) #40(off on on on on on on on on on on on on off off off off off off off off off off off off off off on on on on on on on on on on on on off) #40(off on on on on on on on on on on on on on on off off off off off off off off off off on on on on on on on on on on on on on on off) #40(off on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on off) #40(off off on on on on on on on on on off off off off off off off off off off off off off off off off off off on on on on on on on on on off) #40(off off off on on on on on on on on off off off off off off off off off off off off off off off off off off on on on on on on on on off) #40(off off off off on on on on on on on off off on on on on on off off off off off off off off off off off on on on on on on on off) #40(off off off off off on on on on on on off off on on on on on off off on on on on on on on on on on on on on on on off) #40(off off off off off off on on on on on off off off on on on off off off on on on on on on on on on on on on on on off) #40(off off off off off off off on on on on on off off off off off off off on on on on on on on on on on on on on on off) #40(off off off off off off off off on on on on on off off off off off on on on on on on on on on on on on on on off) #40(off off off off off off off off off on on on on on on on on on on on on on on on on on on on on on on off) #40(off off off off off off off off off off on on on on on on on on on on on on on on on on on on on on off) #40(off)))) (make-problem "19980926-JON (5)" (quote ((15 19) (16 3 17) (18 3 16) (7 6 3 4 6) (5 6 3 3 3 5 4) (4 2 7 1 3 1 4 3 3) (3 2 4 5 2 4 3 2) (3 2 4 5 2 6 4 3 1) (2 2 4 5 3 7 3 2 1) (1 2 4 5 3 8 4 3) (1 2 4 3 6 5 3 4 2) (2 3 3 6 3 2 5 1) (2 3 2 8 7 1) (2 6 6 6 2) (2 5 4 5 2) (1 5 2 5 1) (1 34 1) (1 4 4 19 4 1) (1 4 4 6 7 3 4 1) (6 3 6 6 10) (1 3 4 6 6 3 4 1) (1 3 4 5 4 4 3 2) (1 4 4 4 4 3 4 2) (2 3 4 3 7 4 2) (2 8 3 6 5 2) (2 2 8 8 1 3) (1 2 24 5) (2 1 22 4) (2 1 18 4) (1 4 3 3 4 1) (1 4 3 3 4 1) (2 5 3 3 5 2) (2 5 3 5 2) (3 5 3 5 3) (4 5 3 5 4) (5 25 5) (7 22 6) (8 17 8) (9 10) (11 4 11))) (quote ((11 11) (9 13 9) (8 5 1 7 7) (6 5 8 5 6) (5 3 14 4 5) (4 2 24 4) (4 2 12 3 5 4) (3 2 10 2 2 4 3) (3 1 5 2 11 4 2) (3 6 3 12 4 1) (3 4 3 12 3 1) (3 3 4 3 7 3) (3 2 4 1 3 4 3) (4 5 16 3) (4 6 16 3) (3 7 9 6 3) (3 2 3 7 3 3) (3 1 6 5 3 3) (1 3 8 3 3 6 1) (2 11 3 6 1) (5 7 3 6 1) (1 4 4 3 3 3 3 1) (1 3 7 5 3 3) (2 6 7 6 3) (6 5 9 6 3) (5 5 16 3) (5 4 13 3) (4 1 3 5 6 3) (3 2 3 2 8 2) (3 4 3 12 3 1) (3 6 2 8 3 4 2) (3 1 9 6 3 4 2) (3 2 10 1 4 5 3) (3 3 16 5 3) (4 3 24 4) (4 4 14 7 5) (5 4 6 7 6) (6 6 1 9 7) (7 14 9) (9 11))) (quote #40(#40(on on on on on on on on on on on off off off off off off off off off off off off off off off off off off on) #40(on on on on on on on on on off off off off on on on on on on on on on on on on on off off off off off on) #40(on on on on on on on on off off on on on on on off off off off on off off off on on on on on on on off off off on) #40(on on on on on on off off on on on on on off off on on on on on on on on off off off off on on on on on off off on) #40(on on on on on off off on on on off off off on on on on on on on on on on on on on on off off on on on on off off on) #40(on on on on off off on on off off on on on on on on on on on on on on on on on on on on on on on on on on off off on) #40(on on on on off on on off on on on on on on on on on on on on off off on on on off off off off off on on on on on off on) #40(on on on off on on off on on on on on on on on on on off off off on on off off on on off off off off off on on on on off off on) #40(on on on off on off on on on on on off off on on off on on on on on on on on on on on off off off off off on on on on off off on) #40(on on on off on on on on on on off on on on off off on on on on on on on on on on on on off off off off off on on on on off off on) #40(on on on off on on on on off off on on on off off off on on on on on on on on on on on on off off off off off off on on on off off on) #40(on on on off on on on off on on on on off off off off on on on off off off on on on on on on on off off off off off off on on on off) #40(on on on off on on off on on on on off off off off off on off off on on on off off off on on on on off off off off off off on on on off) #40(on on on on off on on on on on off off off off off off on on on on on on on on on on on on on on on on off off off on on on off) #40(on on on on off on on on on on on off off off off off on on on on on on on on on on on on on on on on off off off on on on off) #40(off on on on off on on on on on on on off off off off on on on on on on on on on off on on on on on on off off off on on on off) #40(off off on on on off on on off off on on on off off off on on on on on on on off off off on on on off off off off off off on on on off) #40(off off on on on off on off on on on on on on off off on on on on on off off off off off on on on off off off off off off on on on off) #40(off on off on on on off on on on on on on on on off on on on off off off off off off off on on on off off off on on on on on on off on) #40(off on on off off off off on on on on on on on on on on on off off off off off off off off on on on off off off on on on on on on off on) #40(off on on on on on off off off off off on on on on on on on off off off off off off off off on on on off off off on on on on on on off on) #40(on off on on on on off on on on on off on on on off on on on off off off off off off off on on on off off off off off off on on on off on) #40(on off off on on on off on on on on on on on off off on on on on on off off off off off on on on off off off off off off on on on off) #40(on on off off off off off on on on on on on off off off on on on on on on on off off off on on on on on on off off off on on on off) #40(on on on on on on off on on on on on off off off off on on on on on on on on on off on on on on on on off off off on on on off) #40(on on on on on off on on on on on off off off off off on on on on on on on on on on on on on on on on off off off on on on off) #40(on on on on on off on on on on off off off off off off on on on on on on on on on on on on on off off off off off off on on on off) #40(on on on on off on off off on on on off off off off off on on on on on off off on on on on on on off off off off off off on on on off) #40(on on on off off on on off off on on on off off off off on on off off off on on on on on on on on off off off off off off on on off) #40(on on on off on on on on off off on on on off off off on on on on on on on on on on on on off off off off off off on on on off off on) #40(on on on off on on on on on on off off on on off off on on on on on on on on off on on on off off off off off on on on on off on) #40(on on on off on off on on on on on on on on on off on on on on on on off off on on on off off off off off on on on on off off on) #40(on on on off on on off on on on on on on on on on on off off on off off on on on on off off off off off on on on on on off on) #40(on on on off on on on off off on on on on on on on on on on on on on on on on off off off off off on on on on on off off on) #40(on on on on off on on on off off on on on on on on on on on on on on on on on on on on on on on on on on off off on) #40(on on on on off off on on on on off on on on on on on on on on on on on on on off on on on on on on on off off on) #40(on on on on on off off on on on on off off off off on on on on on on off off off off on on on on on on on off off on) #40(on on on on on on off off off on on on on on on off off off off on off on on on on on on on on on off off off on) #40(on on on on on on on off off off off off off on on on on on on on on on on on on on on off off off off on) #40(on on on on on on on on on off off off off off off off off off off off off off off off off off off off off on)))) (make-problem "19981120-VAL (6)" (quote ((8 7) (10 2 2 2 2 2 2 2 8) (8 1 1 1 1 1 1 1 1 7) (8 7) (8 7) (40) (10 3 3 3 3 3 9) (9 1 1 1 1 1 7) (8 1 1 1 1 1 1 1 1 1 6) (7 3 3 3 3 3 3 5) (7 1 1 1 1 1 1 1 1 1 5) (7 3 3 3 4) (6 1 1 1 4) (6 3) (6 2) (5 2) (7 2 2 2 2 2 2 2 2 2 2 2) (5 1 1 1 1 1 1 1 1 1 1 1 1) (5 1) (5 1) (5 1 2) (5 1 1 2 3) (5 2 2 8) (6 4 4 8) (6 3 2 2 3 8) (6 3 1 1 3 8) (7 4 4 8) (7 1 8) (7 4 4 8) (8 3 1 1 3 9) (8 3 2 2 3 9) (9 4 4 10) (9 2 2 10) (9 1 1 11) (10 11) (11 12) (12 13) (13 14) (15 15) (17 17))) (quote ((40) (40) (40) (40) (40) (15 1 17) (12 1 14) (9 1 11) (1 3 1 9) (1 2 1 1 6) (1 1 3 1 5) (1 2 1 1 1 4) (1 4 3 1 3) (1 2 1 1 1 1 1 2) (1 1 3 1 2 2 2) (1 2 1 1 4 4 1) (1 3 1 3 2 2 3 1) (1 2 1 1 3 1 1 3) (1 1 3 1 4 4) (1 2 1 1 1 1) (1 4 3 1 4 4) (1 2 1 1 1 3 1 1 3) (1 1 3 1 3 2 2 3) (1 2 1 1 4 4 1) (1 3 1 2 2 1) (1 2 1 1 1 1 2) (1 1 3 1 3) (1 2 1 1 1 4) (1 4 3 1 5) (1 2 1 1 1 7) (1 1 3 1 9) (1 2 1 1 11) (1 2 1 20) (8 1 19) (9 1 18) (11 1 18) (13 1 18) (14 1 19) (17 20) (40))) (quote #f)) (make-problem "19981207-JTR (7)" (quote ((1) (1) (1 1 1 1) (1 1 1 1 1 1) (1 1 1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 2 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 4 1 1 1 1 1 1 1) (1 1 1 1 1 3 4 3 1 1 1 1 1) (1 1 1 3 3 4 3 3 1 1 1) (1 3 3 3 4 3 3 3 1) (3 3 3 3 4 3 3 3 3) (3 3 3 3 4 3 3 3 3) (3 3 3 3 4 3 3 3 3) (3 3 3 3 4 3 3 3 3) (3 3 3 3 4 3 3 3 3) (3 3 3 3 4 3 3 3 3) (3 3 3 3 4 3 3 3 3) (3 3 3 4 4 4 3 3 3) (3 3 3 16 3 3 3) (3 3 4 14 4 3 3) (3 4 4 12 4 4 3) (4 4 4 4 4 4 4) (4 4 18 4 4) (4 4 16 4 4) (4 4 14 4 4) (4 4 4 4 4) (4 20 4) (4 18 4) (4 16 4) (4 4 4) (22) (20) (18) (4) (4) (4) (14) (22) (30))) (quote ((3 12) (2 14) (3 14) (4) (3 12 4) (2 14 4 1) (3 14 4 1) (4 4 1) (3 12 4 4 1) (2 14 4 4 2) (3 14 4 4 2) (4 4 4 2) (3 12 4 4 3 2) (2 14 4 3 3 3) (3 14 3 3 3 3) (4 3 3 3 3) (3 3 3 3 3) (3 3 3 3 3) (3 33) (1 34) (2 34) (4 33) (3 3 3 3 3) (3 3 3 3 3) (4 3 3 3 3) (3 14 3 3 3 3) (2 14 4 3 3 3) (3 12 4 4 3 2) (4 4 4 2) (3 14 4 4 2) (2 14 4 4 2) (3 12 4 4 1) (4 4 1) (3 14 4 1) (2 14 4 1) (3 12 4) (4) (3 14) (2 14) (3 12))) (quote #f)) (make-problem "19981221-SDN (8)" (quote (() (6 2 2 2 2 6) (6 2 2 2 2 6) (2 2 2 2 2 2) (2 2 2 2 2 2) (5 2 7 2 6) (5 2 7 2 6) (2 2 2 2 2) (2 3 2 2 2 2) (6 3 2 2 2 6) (6 3 2 2 2 6) () () () (6 6 2 6 6) (6 6 2 6 6) (2 2 2 2 2 2) (2 2 2 2 2 2) (6 6 6 6 5) (6 6 6 6 5) (2 2 2 2 2 2) (2 2 2 2 2 2) (2 6 6 6 6) (2 6 6 6 6) () () () (6 6 1) (6 6 11) (2 2 2 6 11) (2 2 2 6 1 2 2) (6 6 2 2) (6 6 2 2) (2 2 6 2 2) (2 2 6 2 2) (6 2 2 2) (6 2) () () ())) (quote (() (2 2 6 6 2) (2 2 2 6 6 2) (2 2 2 2 2 2 2 2) (2 2 2 2 2 2 2 2) (10 10 2 6) (10 10 2 6) () () (3 2 6 6) (3 2 6 6) (3 2 2 2 2 2) (2 2 2 2 2) (6 2 10) (10 6 2 10) (10) () (10 2 2) (6 10 2 2) (6 2 2 2 2) (2 2 2 2 2) (2 6 2 2) (2 6 2 2) (10) (10) (6 2) (6 2 2) (10 2 2 2 2) (10 2 2 2 2) (2 6 8) (2 6 8) (6 2 2) (6 2 2) (2 2 2 2 2 8) (2 2 2 2 2 2 8) (2 6 2 2 2 2) (2 6 2 2 2 2) (10 2) (10) ())) (quote #f)) (make-problem "19981223aBAU (9)" (quote ((1 4) (2 6) (3 7 2) (4 4 4 4 4) (3 7 5 2 4 7 2) (6 2 7 5 8) (2 5 9 1 2 6) (3 2 9 3) (1 11 2) (1 13 1) (4 13 1) (5 15 3) (4 1 15 5) (3 3 15 6) (2 2 1 15 1 2 3) (3 1 15 10) (2 1 13 1 1 5) (1 2 1 2 2 4) (1 6 1 1 1 2 2 4) (20 5) (25 4) (5 21 3) (7 20 3) (3 1 6 8 4 4) (4 4 1 13 4) (1 1 7 2 2 1 3 3) (3 4 1 5 5 2) (1 1 6 2 2 1 2 1) (4 3 2 4 5 3) (4 6 4 4 4) (3 3 2 2 2 2 1 5) (3 6 5 7) (3 2 2 2 2 1 3) (2 4 5 3) (1 3 1 5) (6 4) (4 5) (4 5) (3 2) (1))) (quote ((3 5 3) (3 4 4 5) (3 2 1 14) (4 4 5 1 2 3) (5 2 1 4 5 2) (1 1 4 5 2) (4 2 1 2 1 3 4) (4 6 5 6 3) (4 2 1 4 8 4) (2 3 5 10 8) (5 8 12 5) (2 18 5 1 1) (1 18 2 5) (12 7 2) (13 6) (13 4) (19) (13 5) (13 8) (12 9) (19 5) (1 19 4) (5 8 11 2) (4 2 5 6 8) (3 6 1 5 2 2) (7 5 3 1 4) (3 1 3 1 6 4) (5 5 4 1 4) (6 4 7 4) (3 2 2 2 4 3 3) (4 3 1 8 2) (3 4 4 2 2) (3 3 1 4 1 2) (3 4 3 1) (3 3 1 2 4) (3 4 3 3) (3 4 3 3) (2 7 3) (2 7 3) (1 4 3))) (quote #f)) (make-problem "19981223bBAU (10)" (quote ((5 11) (8 6 6) (2 6 7 8) (3 8 2 12 2) (12 3 4 5 3 3) (5 5 8 3 2 5) (6 4 9 1 8) (9 16 8) (6 2 12 9) (3 4 9 9) (9 5 2 7) (8 6 6) (6 12 3) (5 6 10 2) (2 5 7 11) (2 5 8 9) (2 6 9 6) (3 8 16) (2 9 1 5) (2 9 2 2) (2 9 4 3) (2 9 14) (3 1 3 1 18) (3 7 11 6) (1 1 5 9 8) (1 1 3 7 10) (4 1 12) (4 1 5 5 1) (4 1 8 3 3) (4 1 10 5) (5 2 8 3 5) (3 1 1 1 1 5 4 5) (2 3 2 4 6 5) (1 3 3 12 6) (7 8 7 2 3) (16 7 3 2) (6 8 3 8) (4 7 2 8) (2 7 2 7) (9 8))) (quote ((4 15) (7 8 8) (8 3 11 2) (2 7 2 5 3) (2 7 1 1 6) (3 1 5 8) (5 2 2 4 8) (6 1 2 7 4 1) (5 5 6 2 1 3 1) (5 5 11 1 1 2) (5 22 5) (5 17 1 6) (1 2 12 2 6) (2 2 13 7) (1 2 3 5 8) (5 9) (5 2 4) (5 8 5 3) (7 5 5 8) (7 5 5 7) (8 6 5 7) (9 7 5 5 1) (2 6 8 5 4 1) (3 4 14 2 3) (5 3 1 4 6 2 5) (6 2 2 2 6 10) (8 4 1 5 10) (6 5 1 5 7 1) (1 2 7 3 1 4 2) (1 2 7 2 2 3 3) (4 8 2 3 5) (6 10 6 4) (10 6 6 5) (5 5 4 7 6) (4 6 3 7 6) (2 7 2 12 2) (13 4 6 2) (11 3 9) (9 2 8) (7 8))) (quote #40(#40(off off off off on on on on off off off off off off off off off on on on on on on on on on on on on on on on off) #40(off off on on on on on on on off off off off off off off on on on on on on on on off off on on on on on on on on off) #40(off on on on on on on on on off off off off off off on on on off off off off on on on on on on on on on on on off on on off) #40(on on off on on on on on on on off off off off on on off off off off off off off off off off on on on on on off off off on on on off) #40(on on off off on on on on on on on off off off on off off off off off off off off off off off off off off off on off on on on on on on off) #40(on on on off on off on on on on on off off off off off off off off off off off off off off off off off off off off on on on on on on on on off) #40(on on on on on off off on on off on on off off off off off off on on on on off off off off off off off off off off on) #40(on on on on on on off on off off on on off off off off off on on on on on on on off off off off off off off off off off on on on on off on) #40(off on on on on on off on on on on on off off off off on on on on on on off on on off off off off off off on off off on on on off off on) #40(off on on on on on off off on on on on on off off on on on on on on on on on on on off off off off on off off off off on off off on) #40(off off on on on on on off off on on on on on on on on on on on on on on on on on on on on on on off off off off on) #40(off off off on on on on on off on on on on on on on on on on on on on on on on on off off off off off on off off on) #40(off off off on off off on on off off on on on on on on on on on on on on off on on off off off off off off off off off on) #40(off off off on on off on on off off off on on on on on on on on on on on on on off off off off off off off off off on) #40(off off off off on off off on on off off off on on on off off on on on on on off off off off off off off off off off on) #40(off off off off on on on on on off off off off off off off off off off off off off off off off off off off off off on on on on on on on on on off) #40(off off off off off on on on on on off off off off off off off off off off off off off off off off off off off on on off off off on on on on off) #40(off off off off off on on on on on off off off off on on on on on on on on off off off off off off on on on on on off on on on off) #40(off off off off on on on on on on on off off on on on on on off on on on on on off off off on on on on on on on on off) #40(off off off off on on on on on on on off off on on on on on off off on on on on on off off on on on on on on on off) #40(off off off on on on on on on on on off off on on on on on on off on on on on on off off on on on on on on on off) #40(off off on on on on on on on on on off on on on on on on on off off on on on on on off on on on on on off on off) #40(off on on off off on on on on on on off on on on on on on on on off on on on on on off on on on on off off on off) #40(off on on on off off on on on on off off on on on on on on on on on on on on on on off off on on off off on on on off) #40(on on on on on off off on on on off off on off off on on on on off on on on on on on off off on on off on on on on on off) #40(on on on on on on off on on off off off on on off off on on off off on on on on on on off off off on on on on on on on on on on off) #40(on on on on on on on on off off off on on on on off off on off off off on on on on on off off off off on) #40(on on on on on on off off off off off on on on on on off on off off off on on on on on off off off off on on on on on on on off off on) #40(on off off on on off off off off off off on on on on on on on off off off on on on off off on off off off off off on on on on off off on) #40(on off on on off off off off off off off on on on on on on on off off off on on off off on on off off off off off off on on on off on) #40(on on on on off off off off off off on on on on on on on on off off off on on off on on on off off off off off off off off on) #40(on on on on on on off off on on on on on on on on on on off off off off on on on on on on off off off off off off off off on) #40(on on on on on on on on on on off off on on on on on on off off off off on on on on on on off off off off off off off on) #40(on on on on on off on on on on on off off on on on on off off off off off on on on on on on on off off off off off on) #40(on on on on off off on on on on on on off on on on off off off off off off on on on on on on on off off off off on on on on on on off) #40(off on on off off on on on on on on on off off on on off off off off off off on on on on on on on on on on on on off off on on off) #40(off off on on on on on on on on on on on on on off off off off off off off off on on on on off off on on on on on on off on on off) #40(off off off on on on on on on on on on on on off off off off off off off off off off on on on off on on on on on on on on on off) #40(off off off off on on on on on on on on on off off off off off off off off off off off off on on off on on on on on on on on off) #40(off off off off off on on on on on on on off off off off off off off off off off off off off off on on on on on on on on off)))) (make-problem "19990208-ELS (11)" (quote ((2 2 2 1 2 2) (4 4 2 1 2 4) (1 1 1 2 1 2 6) (1 2 1 2 1 2 2 8) (1 2 1 2 1 2 1 2 10) (1 1 1 2 1 2 1 1) (11 2 1 2 1 2 2 1) (1 1 1 2 2 1 2 2 1) (1 2 1 2 1 2 1 2 1 1) (1 2 1 2 1 2 1 2 1 2 1) (1 1 1 1 1 2 1 2 1) (11 2 2 10) (2 1 3) (2 1 1 2) (12 1 1 13) (20 1 12) (1) (1) (1) (4 3 3 3) (3 3 3 4) (1) (1) (1) (12 1 20) (13 1 1 13) (2 1 1 2) (2 1 2 3 1 2 1 1) (2 2 2 2 2 1 1 3) (2 2 2 2 1 2 1 5) (1 2 2 1 2 1 2 1 1 5) (1 2 3 2 1 2 1 1 1) (3 2 2 2 2 2 1 1 1 1 1) (7 2 2 1 2 5 1 1 1) (2 10 2 1 2 1 1 1 1) (6 1 2 1 2 1 1 1 1 1 1 1) (4 2 2 1 1 1 1 1) (4 2 1 2 1 1 1 1 1 1) (4 2 1 2 1 1 1 1 1) (6 2 1 2 1 1 1 1 1 1 1))) (quote ((2 1 2 1 1) (10 2 1 2 5) (1 1 1 2 1 2 1 2) (2 2 1 2 1 2 2 3 2) (2 2 1 2 1 2 1 2 3 3 1) (1 1 1 2 1 2 10) (10 2 1 2 1 9) (1 1 1 2 2 3 7) (2 2 1 2 1 2 1 2 2 6) (2 2 1 2 1 2 1 2 1 2 3 1) (1 1 1 2 1 2 2 4) (10 3 2 5 2) (2 1 1 2 1 1) (2 1 1 2) (12 1 1 13) (10 1 20) (1) (1) (1) (3 3 3 4) (4 3 3 3) (1) (1) (1) (20 1 12) (13 1 1 13) (2 1 1 2) (2 1 3 7) (8 2 2 2) (2 1 2 1 2 2 1 1 1) (3 2 1 2 1 2 1) (4 2 1 2 1 2 11) (5 3 2 2 1) (5 3 2 1 2 1 1 1 1 1 1) (4 2 1 2 1 2 1) (3 2 1 2 1 2 11) (2 1 2 2 3) (8 2 1 2 4 2 2 2) (2 1 2 3) (2 1 2 11))) (quote #f)) (make-problem "19990418-DRA (12)" (quote (() (38) (18 19) (17 1 18) (15 3 17) (13 6 16) (12 9 1 13) (10 11 1 11) (9 1 2 8 2 10) (6 2 1 2 1 3 2 9) (6 5 5 3 2 3 8) (6 4 5 5 1 4 7) (7 2 6 1 4 5 7) (6 3 7 1 4 4 7) (5 3 6 2 5 2 8) (5 4 5 1 1 4 2 9) (6 4 4 3 3 2 9) (6 4 6 1 3 2 10) (7 2 1 5 3 3 10) (8 1 2 3 1 2 2 11) (9 3 2 1 13) (10 2 1 4 14) (11 1 2 1 2 15) (12 1 1 16) (15 1 18) (11 1 19) (10 1 4 16) (10 2 3 15) (16 13) (12 3 3 12) (11 4 12) (10 2 7 12) (10 3 21) (10 5 3 16) (16 2 15) (16 1 1 14) (16 4 14) (16 6 14) (16 21) ())) (quote (() (38) (38) (38) (38) (38) (13 23) (8 1 2 21) (8 2 5 20) (8 9 19) (7 5 5 18) (6 4 1 2 4 3 5) (6 1 4 4 2 2 6) (5 3 7 4 1 1 6) (4 3 9 1 1 2 7) (4 2 11 2 1 3 8) (3 3 11 2 4 8) (3 4 4 3) (2 5 1 1 1 2 4 7 2) (1 7 2 1 1 2 2 2 6 3) (2 5 2 5 2 3 5 4) (3 4 3 1 2 2 3 3 3) (4 3 6 3 2 2 2 3) (5 3 8 2 4 3 2) (6 3 6 1 6 4 1) (5 1 3 4 2 7 7) (6 1 1 1 2 9 7) (6 6 4 19) (7 8 20) (8 5 22) (9 3 24) (10 25) (38) (38) (38) (38) (38) (38) (38) ())) (quote #40(#40(off) #40(off on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on off) #40(off on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on off) #40(off on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on off) #40(off on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on off) #40(off on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on off) #40(off on on on on on on on on on on on on on off off on on on on on on on on on on on on on on on on on on on on on on on off) #40(off on on on on on on on on off off off on off on on off off on on on on on on on on on on on on on on on on on on on on on off) #40(off on on on on on on on on off on on off on on on on on off on on on on on on on on on on on on on on on on on on on on off) #40(off on on on on on on on on off on on on on on on on on on off on on on on on on on on on on on on on on on on on on on off) #40(off on on on on on on on off on on on on on off on on on on on off on on on on on on on on on on on on on on on on on on off) #40(off on on on on on on off on on on on off off on off on on off off off off on on on on off off on on on off off off on on on on on off) #40(off on on on on on on off off off on off on on on on off off on on on on off on on off off off on on off off off on on on on on on off) #40(off on on on on on off on on on off on on on on on on on off on on on on off on off off off on off off off off on on on on on on off) #40(off on on on on off on on on off on on on on on on on on on off on off off off on off off off on on off off on on on on on on on off) #40(off on on on on off on on off on on on on on on on on on on on off on on off on off off on on on off on on on on on on on on off) #40(off on on on off on on on off on on on on on on on on on on on off off on on off off on on on on off on on on on on on on on off) #40(off on on on off on on on on off on on on on off off off on on on off) #40(off on on off on on on on on off on off off on off on off on on off off off off off on on on on off on on on on on on on off on on off) #40(off on off on on on on on on on off on on off on off on off off on on off on on off off on on off on on on on on on off on on on off) #40(off on on off on on on on on off on on off on on on on on off off on on off off off on on on off on on on on on off on on on on off) #40(off on on on off on on on on off on on on off off off on off on on off on on off on on on off off off on on on off off off on on on off) #40(off on on on on off on on on off on on on on on on off on on on off on on off on on off off off off off on on off off off on on on off) #40(off on on on on on off on on on off on on on on on on on on off on on off on on on on off off off off on on on off off off on on off) #40(off on on on on on on off on on on off on on on on on on off on off off on on on on on on off off off on on on on off off off on off) #40(off on on on on on off on off on on on off on on on on off on on off on on on on on on on off off off off on on on on on on on off) #40(off on on on on on on off on off off off on off on off off on on off on on on on on on on on on off off off on on on on on on on off) #40(off on on on on on on off on on on on on on off on on on on off on on on on on on on on on on on on on on on on on on on off) #40(off on on on on on on on off on on on on on on on on off off on on on on on on on on on on on on on on on on on on on on off) #40(off on on on on on on on on off on on on on on off off on on on on on on on on on on on on on on on on on on on on on on off) #40(off on on on on on on on on on off on on on off on on on on on on on on on on on on on on on on on on on on on on on on off) #40(off on on on on on on on on on on off off off on on on on on on on on on on on on on on on on on on on on on on on on on off) #40(off on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on off) #40(off on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on off) #40(off on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on off) #40(off on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on off) #40(off on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on off) #40(off on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on off) #40(off on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on off) #40(off)))) (make-problem "19990422-VOL (13)" (quote (() () () () () (1 1 1 1 1 1) (3 1 1 3 3 3 3) (1 3 1 5 1 3 2 2 2 2 2 2) (10 6 1 18) (3 3 4 6 1 2 5 2 2 1) (15 3 6 11) (1 4 4 5 1 1 7 2 3) (19 8 2 5) (2 2 4 2 5 2 2 1 7 1) (7 8 2 7 9) (19 3 3 5 3) (3 3 2 1 1 2 1 7 7 1) (1 3 13 1 6 2 5) (7 3 3 1 1 5 3 4 1) (19 18) () (19 18) (1 1 1 9 3 2 5 2 3 2) (1 1 3 3 5 1 6 11) (1 1 1 13 10 7) (1 15 3 3 8 1) (7 1 2 2 5 8 3) (1 1 2 4 1 9 6) (1 5 3 7 10) (1 3 1 1 1 1 1 2 5 4 2 4) (1 5 3 15 2) (8 4 3 4 9) (1 5 3 1 10 2 4) (1 1 2 12 6 11) (1 1 10 4 2 15) (1 7 7 4 7 2 2) (15 3 18) (5 2 4 5 1 5 2 5 1) (19 18) ())) (quote (() (13 18) (3 5 2 1 1 1 3) (6 6 4 1 1 2 2 3) (3 6 3 1 1 4 3) (15 18) (1 5 3 2 1 1 2 9 1) (4 8 8 3 5) (1 4 1 1 1 2 2 1 1 8) (13 6 5 1) (14 5 1 6) (1 1 4 2 3 5 6) (5 6 1 2 2 1 2 3) (2 6 3 5 6) (5 6 5 1 4 1) (9 3 6 2 4) (1 2 7 1 1 5 1 5 2) (9 5 5 2 9) (2 2 4 1 1 2 8 6) (13 18) () (13 18) (3 1 5 2 6 9 1) (2 5 6 1 11 4) (9 4 4 5 7) (2 10 14 3) (5 4 1 5 2 9) (3 9 2 9 5) (7 3 4 2 8 1) (2 4 2 1 8 7) (5 4 1 18) (2 1 6 1 3 4 2 4 1) (3 6 1 1 4 11) (5 4 2 14 3) (3 10 8 2 6) (2 3 3 4 5 12) (14 1 7 4 3) (2 3 2 1 1 4 11 1) (12 18) ())) (quote #f)) (make-problem "19990503-DRA (14)" (quote ((7 23) (5 10 21) (4 14 20) (3 6 4 19) (2 6 4 1 4 18) (1 6 7 4 17) (1 2 6 5 16) (1 1 2 2 4 6 15) (1 1 9 4 14) (1 5 10 5 13) (1 4 6 5 4 12) (1 3 5 1 4 1 5 11) (1 2 1 2 1 4 10) (1 3 7 3 5 5 9) (1 13 6 2 3 8) (1 13 4 2 1 4 7) (1 13 5 6 3 6) (1 12 6 5 4 5) (1 7 1 3 4 1 3 4) (2 6 2 2 3 7 4 3) (2 6 9 2 2 3 3 2) (2 16 3 3 3 4 1) (2 16 5 3 2 1) (2 17 1 2 3 1 2 1) (3 15 12 1 2 1) (3 14 15 1 1) (3 14 9 3 2 1 1) (3 14 8 2 1 1 1) (4 14 4 2 4 2 1) (4 16 2 4 3 1 2 1) (4 10 1 1 7 1 3 1) (5 8 7 1 3 2) (5 8 7 7 3 3) (6 14 7 4 3) (7 3 7 5 6 3) (8 3 4 8 4) (9 3 6 9 5) (10 4 11 6) (11 20 7) (12 8))) (quote ((40) (5 21) (4 13 16) (3 3 15 12) (2 3 3 15 9) (1 4 2 17 7) (1 4 1 1 19 6) (5 1 1 21 5) (4 2 2 22 4) (3 1 4 6 15 3) (2 8 5 17 2) (2 7 5 15 3 1) (2 3 4 5 15 3) (2 7 6 15 2) (2 5 1 3 11 2 2) (2 10 10 3 1 1) (3 10 11 3 1 1) (1 3 3 5 11 3 1 1) (1 6 2 5 5 2 3 1 1) (2 5 1 5 1 1 1 3 1 1) (3 4 4 6 2 1 2 2 1) (4 5 2 6 5 1 1 2 1) (5 4 1 3 2 6 3 2) (6 5 4 1 9 4 2) (7 4 9 5 4 2) (8 5 12 6 3) (9 4 5 1 11 3) (10 3 4 10 4) (11 4 1 2 6 5 4) (12 3 8 3 4) (13 4 7 4 5) (14 3 1 7 5) (15 4 6 1 5 1) (16 3 1 1 1 5 2) (17 4 4 1 5 3) (18 3 2 5 4) (19 5 4 5) (20 10 8) (21 9) (40))) (quote #40(#40(on) #40(on on on on on off off off off off off off off off off off off off off on) #40(on on on on off on on on on on on on on on on on on on off off off off off off on) #40(on on on off on on on off off on on on on on on on on on on on on on on on off off off off on) #40(on on off on on on off off off on on on off on on on on on on on on on on on on on on on off off off on) #40(on off on on on on off off off on on off off off on on on on on on on on on on on on on on on on on off off on) #40(on off on on on on off off off on off on off off on on on on on on on on on on on on on on on on on on on off on) #40(off on on on on on off on off off off on off on on on on on on on on on on on on on on on on on on on on on off on) #40(off on on on on off off on on off on on off on on on on on on on on on on on on on on on on on on on on on on off on) #40(off on on on off on off off on on on on off on on on on on on off off on on on on on on on on on on on on on on on off on) #40(off on on off on on on on on on on on off on on on on on off off on on on on on on on on on on on on on on on on on off on) #40(off on on off on on on on on on on off off on on on on on off on on on on on on on on on on on on on on on off on on on off on) #40(off on on off on on on off on on on on off on on on on on off on on on on on on on on on on on on on on on off off on on on off) #40(off on on off on on on on on on on off on on on on on on off off on on on on on on on on on on on on on on on off off on on off) #40(off on on off off on on on on on off on off off on on on off off off on on on on on on on on on on on off off on on off off on on off) #40(off on on off on on on on on on on on on on off off off off off off on on on on on on on on on on off off on on on off on off on off) #40(off on on on off off off on on on on on on on on on on off off on on on on on on on on on on on off off on on on off on off on off) #40(on off on on on off off off off on on on off on on on on on off on on on on on on on on on on on off off on on on off on off on off) #40(on off on on on on on on off on on off off off on on on on on off on on on on on off off off on on off off on on on off on off on off) #40(on on off on on on on on off off on off off on on on on on off on off off off on off off off off off on off off on on on off on off on off) #40(on on on off on on on on off off off on on on on off on on on on on on off off off on on off off on off off on on off on on off on off) #40(on on on on off on on on on on off off off on on off off on on on on on on off on on on on on off on off on off on on off off on off) #40(on on on on on off on on on on off off off on off off on on on off off on on off on on on on on on off off off on on on off on on off) #40(on on on on on on off on on on on on off on on on on off off on off off on on on on on on on on on off on on on on off on on off) #40(on on on on on on on off on on on on off off on on on on on on on on on off on on on on on off off on on on on off off on on off) #40(on on on on on on on on off on on on on on off off on on on on on on on on on on on on off on on on on on on off on on on off) #40(on on on on on on on on on off on on on on off on on on on on off on off on on on on on on on on on on on off off on on on off) #40(on on on on on on on on on on off on on on off off on on on on off off off off on on on on on on on on on on off on on on on off) #40(on on on on on on on on on on on off on on on on off on off on on off on on on on on on off on on on on on off on on on on off) #40(on on on on on on on on on on on on off on on on off off on on on on on on on on off off off off on on on off off on on on on off) #40(on on on on on on on on on on on on on off on on on on off off on on on on on on on off on on on on off off on on on on on off) #40(on on on on on on on on on on on on on on off on on on off off off on off off on on on on on on on off off off on on on on on off) #40(on on on on on on on on on on on on on on on off on on on on off off off off on on on on on on off on off on on on on on off on) #40(on on on on on on on on on on on on on on on on off on on on off off off off off on off off on off on off on on on on on off on) #40(on on on on on on on on on on on on on on on on on off on on on on off on on on on off off on off on on on on on off on) #40(on on on on on on on on on on on on on on on on on on off on on on off off off off on on off off on on on on on off on) #40(on on on on on on on on on on on on on on on on on on on off on on on on on off off off on on on on off off off on) #40(on on on on on on on on on on on on on on on on on on on on off on on on on on on on on on on off on) #40(on on on on on on on on on on on on on on on on on on on on on off off off off off off off off off off on) #40(on)))) (make-problem "19990518-MNT (15)" (quote ((11 10 15) (10 14 14) (9 2 2 12) (8 2 3 11) (7 2 3 10) (6 2 2 9) (6 2 2 8) (6 2 2 7) (6 2 2 6) (6 4 2 5) (7 3 3 4) (8 8 2 4) (9 7 3 3) (9 2 2 3) (12 8 5 2 3) (12 9 6 2 3) (11 4 5 9 3) (10 1 3 6 9 3) (8 1 1 1 1 2 1 3) (8 6 2 4 5 4 2) (8 7 2 2 4 1 1 1) (7 6 1 1 4 1 4 1) (7 7 1 1 4 2 1 1) (3 2 1 1 9 1 1) (2 11 1 1 8 1 1 1) (1 12 3 2 1 7 4 1) (1 13 3 4 6 5 1) (1 14 1 12 1) (1 31 2) (1 22 11 1) (1 9 11 6 1 4) (3 12 4 1 5) (9 13 8 5) (9 3 9 8 6) (9 4 6 9 7) (10 5 4 9 7) (11 5 9 8) (12 5 9 10) (13 14 11) (14 11 12))) (quote ((40) (25 9) (24 4 9) (23 5 8) (23 7 8) (23 7 8) (5 13 7 8) (4 5 10 7 8) (3 7 6 1 7 8) (2 2 3 4 4 7 5) (1 2 4 3 5 7 2 4) (2 2 2 1 4 7 4 3) (1 2 1 4 7 5 2) (2 6 11 2 4 1) (2 6 15 4) (2 2 3 1 1 7 4) (2 2 2 1 1 1 7 4) (2 2 1 1 2 8 3) (2 2 1 1 2 8 2) (2 3 1 6 9 2) (2 4 1 1 8 3) (2 3 1 2 7 4) (2 2 1 2 6 5) (1 3 2 1 5 6) (2 2 1 6 2 2 7) (1 2 2 2 3 8) (2 2 2 12 8) (2 2 4 12 7) (3 2 4 19 1) (4 2 2 18 2) (5 2 2 1 13 3) (6 2 3 1 12 3) (7 3 3 1 4 3 1 4) (8 4 2 1 4 2 3 6) (9 8 1 1 1 3 1 7) (10 8 1 4 1 9) (12 1 2 2 1 10) (19 1 4 1 10) (20 1 1 10) (21 5 11))) (quote #40(#40(on) #40(on on on on on on on on on on on on on on on on on on on on on on on on on off off off off off off on) #40(on on on on on on on on on on on on on on on on on on on on on on on on off off on on on on off on) #40(on on on on on on on on on on on on on on on on on on on on on on on off off on on on on on off off on) #40(on on on on on on on on on on on on on on on on on on on on on on on off on on on on on on on off on) #40(on on on on on on on on on on on on on on on on on on on on on on on off on on on on on on on off on) #40(on on on on on off off off off off on on on on on on on on on on on on on off on on on on on on on off on) #40(on on on on off on on on on on off on on on on on on on on on on off off off on on on on on on on off on) #40(on on on off on on on on on on on off on on on on on on off off off off on off on on on on on on on off on) #40(on on off on on off off off off on on on off off on on on on off on on on on off on on on on on on on off off off off on) #40(on off on on off off off off off on on on on off on on on off on on on on on off on on on on on on on off off on on off on) #40(off on on off off off off off off off off on on off on on off on off on on on on off on on on on on on on off on on on on off on) #40(off on off off off off off off off off off on on off off off on off off on on on on off on on on on on on on off on on on on on off on) #40(on on off off off off off off off off off on on on on on on off off on on on on on on on on on on on off on on off on on on on off on) #40(on on off off off off off off off off off on on on on on on off off on on on on on on on on on on on on on on on off on on on on off) #40(on on off off off off off off off off off on on off on on on off on off on off off off off off off on on on on on on on off on on on on off) #40(on on off off off off off off off off off on on off on on off on off on off off off off off off on off on on on on on on on off on) #40(on on off off off off off off off off off off off off on on off on off on off off off off off on on off on on on on on on on on off on) #40(on on off off off off off off off off off off off off on on off on off off on off off off off on on off on on on on on on on on off off on) #40(on on off off off off off off off off off off off off on on on off on off on on on on on on off on on on on on on on on on off off on) #40(on on off off off off off off off off off off off off on on on on off on off off off off off off on off on on on on on on on on off on) #40(on on off off off off off off off off off off off off off on on on off on off off off off off on on off on on on on on on on off on) #40(on on off off off off off off off off off off off off off off on on off on off off off off off on on off on on on on on on off on) #40(off on off off off off off off off off off off off off off on on on off on on off off off off off on off on on on on on off on) #40(off on on off off off off off off off off off off off on on off on off off on on on on on on off on on off on on off on) #40(on off on on off off off off off off off off off off on on off on on off off off off off off off off on on on off off on) #40(on on off on on off off off off off off off off off on on off off off on on on on on on on on on on on on off on) #40(on on off on on off off off off off off off off off on on on on off on on on on on on on on on on on on off on on on on on on on off) #40(on on on off on on off off off off off off off off on on on on off on on on on on on on on on on on on on on on on on on on off on) #40(on on on on off on on off off off off off off off off off on on off on on on on on on on on on on on on on on on on on on off on) #40(on on on on on off on on off off off off off off off off on on off on off off off on on on on on on on on on on on on on off on) #40(on on on on on on off on on off off off off off off off on on on off off on off on on on on on on on on on on on on off off on) #40(on on on on on on on off on on on off off off off off on on on off on off on on on on off on on on off off on off off off on) #40(on on on on on on on on off on on on on off off off on on off on off on on on on off on on off on on on off off on) #40(on on on on on on on on on off on on on on on on on on off on off on off on off on on on off on off off off on) #40(on on on on on on on on on on off off on on on on on on on on off on off off on on on on off on off on) #40(on on on on on on on on on on on on off off off off off off off on off on on off off on on off on off on) #40(on on on on on on on on on on on on on on on on on on on off on off off on on on on off on off on) #40(on on on on on on on on on on on on on on on on on on on on off on off off off off off on off off on) #40(on on on on on on on on on on on on on on on on on on on on on off on on on on on off off on)))) (make-problem "19990525-DRA (16)" (quote ((1) (3 1 1 3 3 1 1 3 2 3 1) (1 1 3 1 1 1 2 1 1 1 1 1 1 1 1) (1 1 1 1 1 3 1 2 3 1 1 3) (3 1 1 3 1 1 1 1 1 1 3 1 1 1) () () (1) (3) (5) (7) (11) (11) (11) (11) (11) (4 11 4) (5 11 5) (6 11 6) (7 11 7) (27) (27) (25) (23) (23) (23) (25) (25) (19) (11) (13) (15) (1) (1) (1) (1) (1) () () ())) (quote (() (4) (1 1) (4) () (4) (1) (4 6) (7 2) (12) (12) (4 12) (1 1 11) (1 1 10 1) (9 2) (4 21) (1 1 21) (4 22) (23) (4 24) (1 30) (1 24) (4 23) (22) (4 21) (1 1 21) (4 9 2) (10 1) (4 11) (1 1 12) (3 12) (12) (4 7 2) (1 1 6) (4) () () (3 1) () ())) (quote #f)) (make-problem "19990527bDRA (17)" (quote ((40) (40) (40) (21 16) (8 14 3 11) (6 10 5 2 2 8) (2 2 12 5 1 1 9) (2 2 5 6 5 9) (2 3 2 2 2 1 7 11) (2 1 2 2 3 2 4 4 6) (2 3 3 4 4 3 7) (4 2 2 3 4 2 8) (4 5 2 3 3 3 4 3) (4 4 2 2 5 2 5 3) (6 4 2 5 4 1 3) (3 2 4 2 3 3 4 1 3) (2 4 2 2 2 2 6 1 3) (4 4 2 2 1 1 7 1 3) (6 2 2 2 2 2 4 4) (6 2 2 4 2 3 5) (8 2 5 1 2 6) (9 1 3 5 2 1 4 3) (10 1 2 2 2 5 2) (3 5 2 2 1 3 5 3) (4 2 2 3 2 3 6) (6 1 1 3 2 2 8) (7 3 3 1 9) (6 7 3 2 2 4) (5 9 3 2 2 1 5) (4 11 1 1 5 6) (16 1 5 7) (17 2 7 4) (17 1 8 5) (17 1 15) (16 1 15) (16 2 15) (15 1 14) (13 15) (12 13) (40))) (quote ((40) (40) (6 5 23) (9 4 6 16) (10 3 6 4 10) (6 1 2 3 6 3 11) (5 3 2 5 1 12) (5 5 2 2 5 13) (4 6 3 2 3 14) (8 4 3 1 15) (11 3 1 14) (12 5 3 13) (7 3 5 2 11 1) (9 2 3 2 10 1) (11 1 3 9 1) (8 2 4 5 7 1) (8 3 4 3 3 1) (9 3 4 1 1) (5 2 5 3 6 1 1) (6 5 5 3 4 1) (10 9 2 1) (3 6 2 3 1) (3 5 4 2 1) (3 13 3 2 1) (4 6 4 5 3 1 1) (5 4 3 5 7 1 1) (6 3 1 2 9 1) (7 2 1 11) (4 2 3 1 4 10) (7 6 3 2 3 9) (6 5 6 2 2 9) (5 5 7 2 3 9) (10 4 3 3 2 8) (9 5 3 2 4 1 7) (14 3 4 2 7) (18 4 3 3 8) (12 3 16) (22 17) (40) (40))) (quote #40(#40(on) #40(on) #40(on on on on on on off off off off off on on on on on off on) #40(on on on on on on on on on off off on on on on off off on on on on on on off on) #40(on on on on on on on on on on off off off off on on on off on on on on on on off on on on on off on) #40(on on on on on on off off on off off on on off on on on off on on on on on on off on on on off on) #40(on on on on on off off off off off on on on off off off on on off off on on on on on off on off on) #40(on on on on on off on on on on on off on on off off on on off off on on on on on off off on) #40(on on on on off on on on on on on off on on on off off on on off off on on on off off on) #40(on on on on on on on on off off off off on on on on off on on on off off on off off on) #40(on on on on on on on on on on on off off on on on off off off on off off off off off off on) #40(on on on on on on on on on on on on off off on on on on on off off on on on off off off on) #40(on on on on on on on off off off on on on off off on on on on on off off off on on off off on on on on on on on on on on on off on) #40(on on on on on on on on on off off off on on off off off off off on on on off off on on off on on on on on on on on on on off off on) #40(on on on on on on on on on on on off off on off off off off off off on on on off off off off off on on on on on on on on on off off on) #40(on on on on on on on on off on on off off off off on on on on off off on on on on on off off off on on on on on on on off off off on) #40(on on on on on on on on off on on on off off off on on on on off off off off on on on off off off off off on on on off off off off off on) #40(on on on on on on on on on off on on on off off off off off off off off off off off on on on on off off off off off off off on off off off on) #40(on on on on on off on on off off off on on on on on off off off on on on off off off off on on on on on on off off off on off off off on) #40(on on on on on on off off off off off off on on on on on off on on on on on off off off on on on off off on on on on off off off off on) #40(on on on on on on on on on on off off off off off on on on on on on on on on off off off off on on off off off off off off off off off on) #40(on on on off on on on on on on off off on on off off off off off on on on off off off off off off off off off off off off off off off off off on) #40(on on on off on on on on on off off on on on on off off off off off on on off off off off off off off off off off off off off off off off off on) #40(on on on off off on on on on on on on on on on on on on off off off off off on on on off off on on off off off off off off off off off on) #40(on on on on off off on on on on on on off on on on on off off off off on on on on on off off on on on off off off off off on off off on) #40(on on on on on off off off on on on on off on on on off off off on on on on on off off off off off on on on on on on on off on off on) #40(on on on on on on off off on on on off off off on off off off on on off off off off off off off off off on on on on on on on on on off on) #40(on on on on on on on off off off off off off off off off off on on off off on off off off off off off off on) #40(on on on on off off off off off off off off on on off on on on off off on off off on on on on off off off on) #40(on on on on on on on off on on on on on on off on on on off on on off off on on on off off off off off on) #40(on on on on on on off off on on on on on off on on on on on on off off off on on off off on on off off on) #40(on on on on on off on on on on on off off on on on on on on on off off on on off off on on on off off on) #40(on on on on on on on on on on off on on on on off on on on off off on on on off on on off off off off off on) #40(on on on on on on on on on off on on on on on off on on on off off on on off off on on on on off on off off on) #40(on on on on on on on on on on on on on on off off off off off off on on on off on on on on off on on off off on) #40(on on on on on on on on on on on on on on on on on on off on on on on off on on on off on on on off on) #40(on on on on on on on on on on on on off off off off off off on on on off off off on) #40(on on on on on on on on on on on on on on on on on on on on on on off on) #40(on) #40(on)))) (make-problem "19990529bDRA (18)" (quote (() (9) (13) (11 5) (14 5) (16 5) (22) (3 3 1 12) (2 2 6) (2 6) (5 8 6) (2 2 1 1 1 1) (4 1 6) (2 1 1 2 7) (3 1 2 1 1 7) (5 2 3 1 7) (1 4 5 2 4) (2 2 1 6) (2 2 2) (1 3) (1 2 2) (1 1 1 2) (1 7 4) (2 3 1 2) (1 4) (2 4) (2 2 2) (2 2 2) (3 3 4) (8 2 2) (2 2 4) (8 2 7) (6 2 2 9) (8 2 2 11) (10 2 2 12) (12 2 2 14) (14 4 15) (15 16) (35) (35))) (quote (() () (4) (5) (6) (7) (7 8) (4 3 9) (11 2 9) (12 2 9) (4 1 1 2 2 9) (4 1 1 1 1 1 1 9) (5 1 2 2 2 2 1 7) (7 2 1 2 4 6) (7 3 1 2 5 5) (6 4 2 3 1 2 4) (6 2 1 1 2 3) (7 1 1 1 1 2 2) (6 1 3 1 1 2) (7 1 1 2 2 1 2) (7 1 1 1 1 2 2) (7 1 3 2 2 3) (2 4 1 1 2 2 4) (3 3 2 2 2 5) (3 2 3 2 6) (8 4 1 8 7) (16 9 8) (8 4 3 4 1 9) (14 4 12) (6 9 11) (4 7 10) (8 10) (9) (9) (8) (7) (5) () () ())) (quote #f)) (make-problem "19990530aDRA (19)" (quote ((40) (40) (26 13) (5 20 13) (5 11 3 13) (5 20 13) (5 5 1 4 1 1 11) (4 1 4 3 2 3 13) (5 4 4 3 2 3 13) (4 4 4 3 2 3 2 10) (4 4 6 1 4 10) (4 4 30) (40) (14 24) (13 1 24) (6 4 1 24) (6 1 3 1 12) (6 1 5 5 10) (5 2 1 1 2 7 7) (4 1 2 3 4 5) (3 1 2 1 1 1 5 4) (3 1 2 1 1 3 4) (3 1 1 1 3 4 1 2 1 4) (3 2 3 3 1 1 4) (3 1 3 3 2 1 1 4) (3 2 1 5 3 1 1 1 4) (3 2 2 3 2 2 1 1 4) (3 1 2 5 5 1 2 4) (4 1 2 11 1 2 5) (5 1 6 5 2 6) (6 1 13 2 7) (7 5 5 8) (8 15 9) (12 13) (40) (40) (40) (40) (40) (40))) (quote ((40) (40) (40) (20 12) (7 1 7 1 1 2 1 11) (3 8 2 1 10) (4 2 7 2 1 9) (4 2 7 1 1 2 1 8) (4 10 1 2 1 7) (4 2 2 5 2 2 1 1 7) (4 2 7 1 1 1 1 7) (6 10 2 1 1 1 1 7) (6 9 4 1 1 2 6) (6 7 3 1 2 1 6) (13 7 3 1 1 1 6) (6 3 4 2 1 1 1 6) (10 5 2 3 1 1 1 1 6) (10 5 1 1 3 1 1 1 6) (10 5 1 3 1 1 1 6) (7 5 2 1 2 1 1 1 6) (6 3 5 2 4 1 1 1 1 6) (16 3 1 1 1 6) (4 1 5 1 3 1 1 1 6) (16 4 2 1 1 1 6) (6 9 3 1 1 1 1 6) (6 9 2 1 2 1 6) (2 6 2 1 1 2 6) (6 3 5 2 1 1 1 7) (6 3 6 1 2 1 1 1 7) (9 6 2 2 1 1 7) (18 2 1 1 2 7) (18 5 1 1 2 8) (18 4 1 1 2 9) (19 2 1 1 2 10) (19 1 1 1 2 11) (20 12) (40) (40) (40) (40))) (quote #40(#40(on) #40(on) #40(on) #40(on on on on on on on on on on on on on on on on on on on on off off off off off off off off on) #40(on on on on on on on off on off off off on on on on on on on off on off on off on on off on off on) #40(on on on off off off off off off off on on on on on on on on off off off off off off off on on off on off on) #40(on on on on off on on off on on on on on on on off off off off off off off off off off off on on off on off on) #40(on on on on off on on off on on on on on on on off on off off off off off off off off on off on on off on off on) #40(on on on on off on on on on on on on on on on off off off off off off off off off off off on off on on off on off on) #40(on on on on off on on off on on off off on on on on on off off off off on on off off off on on off on off on off on) #40(on on on on off on on off off off on on on on on on on off on off off off off off off off off on off on off on off on) #40(on on on on on on off on on on on on on on on on on off on on off off off off off on off on off on off on off on) #40(on on on on on on off on on on on on on on on on off off off off off off on on on on off on off on off on on off on) #40(on on on on on on off on on on on on on on off off off off off off off off off on on on off on off on on off on off on) #40(on on on on on on on on on on on on on off on on on on on on on off off off on on on off on off on off on off on) #40(on on on on on on off off off off on on on off off off off off off on on on on off off on on off on off on off on off on) #40(on on on on on on on on on on off on on on on on off on on off off on on on off off on off on off on off on off on) #40(on on on on on on on on on on off on on on on on off on off off on off on on on off off off on off on off on off on) #40(on on on on on on on on on on off on on on on on off on off off off off off on on on off off on off on off on off on) #40(on on on on on on on off off off off on on on on on off on on off off off on off on on off off on off on off on off on) #40(on on on on on on off on on on off on on on on on off on on off on on on on off on off off on off on off on off on) #40(on on on on on on on on on on on on on on on on off off off off off off on on on off off off on off on off on off on) #40(on on on on off on off off off off off on on on on on off off off on off off on on on off off off on off on off on off on) #40(on on on on on on on on on on on on on on on on off on on on on off off off off on on off on off on off on off on) #40(on on on on on on off on on on on on on on on on off on on on off off off off off off on off on off on off on off on) #40(on on on on on on off on on on on on on on on on off on on off off off off off off off off on off on on off on off on) #40(on on off off off off off off off off on on on on on on off on on off off off off off off off off on off on off on on off on) #40(on on on on on on off on on on off on on on on on off on on off off off off off off off off on off on off on off on) #40(on on on on on on off on on on off on on on on on on off on off off on on off off off off on off on off on off on) #40(on on on on on on on on on off off on on on on on on off on on off off off off off off on on off on off on off on) #40(on on on on on on on on on on on on on on on on on on off on on off off off off off on off on off on on off on) #40(on on on on on on on on on on on on on on on on on on off on on on on on off on off on off on on off on) #40(on on on on on on on on on on on on on on on on on on off on on on on off on off on off on on off on) #40(on on on on on on on on on on on on on on on on on on on off on on off on off on off on on off on) #40(on on on on on on on on on on on on on on on on on on on off on off on off on off on on off on) #40(on on on on on on on on on on on on on on on on on on on on off off off off off off off off on) #40(on) #40(on) #40(on) #40(on)))) (make-problem "19990530bDRA (20)" (quote ((40) (40) (40) (40) (40) (15 15) (14 14) (13 13) (12 12) (11 11) (10 10) (9 9) (8 8) (7 7) (6 1 1 6) (6 5 5 6) (6 6 6 6) (6 6 6 6) (6 4 4 6) (6 2 2 6) (6 6) (7 1 1 7) (8 2 2 8) (3 3 9) (1 4 10) (1 6 1 1 1 1 6 3) (1 6 1 1 1 1 6 3) (1 5 1 1 1 6 1) (4 5 1 1 1 6 1) (5 4 5 1) (6 5 6 5) (7 4 5 6) (8 3 4 7) (9 2 3 8) (10 4 5 9) (11 12 10) (12 10 11) (13 8 12) (14 3 13) (15 14))) (quote ((40) (24 12) (24 12) (23 12) (23 11) (23 10) (14 6 9) (13 7 8) (12 7 7) (11 7 6) (10 7 5) (9 8 4) (8 3 4 3) (7 4 5 2) (6 6 1 1) (5 5 2) (5 4 2 3) (5 2 1 2 3) (5 2 2 3) (5 2 4) (5 2 2 4) (5 1 2 4) (5 2 2 3) (5 4 4) (5 5 4) (6 6 3) (7 4 6 1) (8 3 5 2) (9 9 3) (10 8 4) (11 8 5) (12 8 6) (13 8 7) (14 8 8) (25 9) (25 10) (25 10) (27 10) (27 10) (40))) (quote #40(#40(on) #40(on on on on on on on on on on on on on on on on on on on on on on on on off off off off on) #40(on on on on on on on on on on on on on on on on on on on on on on on on off off off off on) #40(on on on on on on on on on on on on on on on on on on on on on on on off off off off off on) #40(on on on on on on on on on on on on on on on on on on on on on on on off off off off off off on) #40(on on on on on on on on on on on on on on on on on on on on on on on off off off off off off off on) #40(on on on on on on on on on on on on on on off off off off off off off on on on on on on off off off off on) #40(on on on on on on on on on on on on on off off off off off off off off off on on on on on on on off off off on) #40(on on on on on on on on on on on on off off off off off off off off off off off on on on on on on on off off off on) #40(on on on on on on on on on on on off off off off off off off off off off off off off on on on on on on on off off off on) #40(on on on on on on on on on on off off off off off off off off off off off off off off off on on on on on on on off off off on) #40(on on on on on on on on on off off off off off off off off off off off off off off off off on on on on on on on on off off off on) #40(on on on on on on on on off off off off off off off on on on off off off off off off off off off off off off on on on on off off off on) #40(on on on on on on on off off off off off off off off on on on on off off off off off off off off off off off on on on on on off off off on) #40(on on on on on on off off off off off off off off on on on on on on off off off off off off off off off off off off off off on off off off off on) #40(on on on on on off off off off off off off off off off on on on on on off off off off off off off off off off off off off off on on off) #40(on on on on on off off off off off off off off off off on on on on off off off off off off on on off off off off off off off on on on off) #40(on on on on on off off off off off off off off off off off on on off off off off on off off off off on on off off off off off off on on on off) #40(on on on on on off off off off off off off off off off off off off off off off on on off off on on off off off off off off off off on on on off) #40(on on on on on off off off off off off off off off off off off off off off off off off off off off off on on off off off off off off on on on on off) #40(on on on on on off off off off off off off off off off off off off off off off on on off off on on off off off off off off off off on on on on off) #40(on on on on on off off off off off off off off off off off off off off off off off on off off off off on on off off off off off off on on on on off) #40(on on on on on off off off off off off off off off off off on on off off off off off off off on on off off off off off off off off on on on off) #40(on on on on on off off off off off off off off off off on on on on off off off off off off off off off off off off off off off on on on on off) #40(on on on on on off off off off off off off off off off on on on on on off off off off off off off off off off off off off off on on on on off) #40(on on on on on on off off off off off off off off on on on on on on off off off off off off off off off off off off off off on on on off) #40(on on on on on on on off off off off off off off off on on on on off off off off off off off off off off off on on on on on on off off off on) #40(on on on on on on on on off off off off off off off on on on off off off off off off off off off off off off on on on on on off off off on) #40(on on on on on on on on on off off off off off off off off off off off off off off off off on on on on on on on on on off off off on) #40(on on on on on on on on on on off off off off off off off off off off off off off off off on on on on on on on on off off off on) #40(on on on on on on on on on on on off off off off off off off off off off off off off on on on on on on on on off off off on) #40(on on on on on on on on on on on on off off off off off off off off off off off on on on on on on on on off off off on) #40(on on on on on on on on on on on on on off off off off off off off off off on on on on on on on on off off off on) #40(on on on on on on on on on on on on on on off off off off off off off on on on on on on on on off off off on) #40(on on on on on on on on on on on on on on on on on on on on on on on on on off off off off off off on) #40(on on on on on on on on on on on on on on on on on on on on on on on on on off off off off off on) #40(on on on on on on on on on on on on on on on on on on on on on on on on on off off off off off on) #40(on on on on on on on on on on on on on on on on on on on on on on on on on on on off off off on) #40(on on on on on on on on on on on on on on on on on on on on on on on on on on on off off off on) #40(on)))) (make-problem "19990530cDRA (21)" (quote ((40) (40) (9 28) (7 3 27) (6 5 12 10) (5 8 1 1 9) (5 5 3 8) (5 3 2 6 7) (5 3 2 6 7) (5 4 1 7 7) (5 4 1 4 2 1 7) (6 3 1 3 1 3 1 7) (6 3 2 6 1 7) (6 2 3 2 1 7) (6 2 3 3 2 7) (6 4 1 2 7) (13 1 1 3 7) (13 8 12) (12 3 11) (11 1 3 1 10) (10 3 3 9) (10 4 4 9) (4 5 19 9) (3 5 19 9) (2 5 19 9) (2 4 16 8) (2 3 15 5 7) (3 1 2 15 5 7) (4 3 1 4 10 5 7) (5 3 4 11 8) (6 3 4 13 10) (7 2 4 13 10) (8 1 4 13 10) (8 13 10) (7 5 11) (7 4 3 11) (7 4 11) (8 1 5 12) (40) (40))) (quote ((40) (40) (24 13) (23 12) (22 11) (5 14 1 10) (4 6 10 3 9) (3 10 11 3 2 3) (3 11 12 3 2) (2 4 4 14 3 2) (2 4 1 7 2) (2 3 12 13 2) (3 2 1 6 14 2) (4 2 4 13 2) (5 8 12 3) (5 8 6 2 2) (6 4 1 2 12 2 2) (5 3 1 1 12 2 2) (5 4 1 3 12 2 2) (5 1 4 1 3 13 3) (5 2 3 14 3) (5 1 1 14 3) (5 1 1 14 3) (6 2 2 13 3) (5 1 12 2) (5 12 2) (4 5 5 2) (4 5 3 4 2) (4 7 6 3 4 3) (4 5 5 3 6) (5 4 3 10) (6 8 3 10) (7 9 11) (40) (40) (40) (40) (40) (40) (40))) (quote #40(#40(on) #40(on) #40(on on on on on on on on on on on on on on on on on on on on on on on on off off off on) #40(on on on on on on on on on on on on on on on on on on on on on on on off off off off off on) #40(on on on on on on on on on on on on on on on on on on on on on on off off off off off off off on) #40(on on on on on off off off off off off on on on on on on on on on on on on on on off off off on off on) #40(on on on on off on on on on on on off off off off off on on on on on on on on on on off on on on off on) #40(on on on off off on on on on on on on on on on off on on on on on on on on on on on off on on on off on on off off off on) #40(on on on off on on on on on on on on on on on off on on on on on on on on on on on on off on on on off off off off off off on) #40(on on off on on on on off off on on on on off off on on on on on on on on on on on on on on off on on on off off off off off on) #40(on on off on on on on off on off off off off on on on on on on on off off off off off off off off off off off off off off off off off off on) #40(on on off on on on off on on on on on on on on on on on on off on on on on on on on on on on on on on off off off off off on) #40(on on on off on on off on off off off off on on on on on on off on on on on on on on on on on on on on on off off off off off on) #40(on on on on off on on off on on on on off off off off off off off off on on on on on on on on on on on on on off off off off off on) #40(on on on on on off on on on on on on on on off off off off off off off on on on on on on on on on on on on off off off off on) #40(on on on on on off on on on on on on on on off off off off off off off off on on on on on on off off off off off off off on on off on) #40(on on on on on on off on on on on off on off off off on on off off off off on on on on on on on on on on on on off on on off on) #40(on on on on on off off on on on off off on off off off off on off off off off on on on on on on on on on on on on off on on off on) #40(on on on on on off off on on on on off on off off off off on on on off off on on on on on on on on on on on on off on on off on) #40(on on on on on off off on off on on on on off on off off on on on off off on on on on on on on on on on on on on off off on) #40(on on on on on off off off off off off off off off on on off on on on off off on on on on on on on on on on on on on on off on) #40(on on on on on off off off off off off off off off on off off on off off off off on on on on on on on on on on on on on on off on) #40(on on on on on off off off off off off on off off off off off on off off off off on on on on on on on on on on on on on on off on) #40(on on on on on on off off off off on on off off off off on on off off off off on on on on on on on on on on on on on off off on) #40(on on on on on off off off off off off on off off off off off off off off off off on on on on on on on on on on on on off off off off on) #40(on on on on on off off off off off off off off off off off off off off off off off on on on on on on on on on on on on off off off off on) #40(on on on on off off off off off off off off off off off off off off off off off on on on on on off off off on on on on on off off off off on) #40(on on on on off off off off off off off off off off off off off off off off on on on on on off on on on off on on on on off off off off on) #40(on on on on off off off off off off off on on on on on on on off on on on on on on off on on on off on on on on off off off on) #40(on on on on off off off off off off off off off off on on on on on off on on on on on off on on on off off off off off on) #40(on on on on on off off off off off off off off off off off on on on on off off off off off off on on on off on) #40(on on on on on on off off off off off off off off off off off on on on on on on on on off on on on off on) #40(on on on on on on on off off off off off off off off off off on on on on on on on on on off off off on) #40(on) #40(on) #40(on) #40(on) #40(on) #40(on) #40(on)))) (make-problem "19990601aDRA (22)" (quote ((18 1 19) (5 10 9 7) (5 10 9 7) (7 10 9 9) (8 8 9 10) (3 1 5 16 4 1 4) (2 5 11 4 3) (2 6 9 8 3) (3 8 7 10 4) (4 10 5 12 5) (13 17) (12 10 16) (11 12 15) (10 1 4 1 6 4) (3 3 1 1 4 1 1 5 4 3) (2 4 1 1 4 1 4 6 2) (1 7 1 4 1 3 8 1) (1 8 14 2 9 1) (9 4 4 4 2 10) (10 4 4 2 11) (11 10 2 12) (12 2 2 13) (12 2 2 1 13 1) (1 10 10 14 1) (1 9 12 13 1) (1 8 14 11 2) (2 6 14 10 2) (3 5 12 8 2) (4 4 2 4 3) (5 4 4) (8 1 1 1 11) (7 1 2 2 2 10) (6 2 16 3 9) (5 4 14 5 8) (3 6 7 6) (10 14) (9 13) (7 10 10) (6 6 8 7 9) (5 8 9 8))) (quote ((18 17) (16 5 14) (6 7 10 13) (5 5 12 6 5) (6 4 13 5 5) (1 2 5 14 3 5) (1 3 6 14 2 5 1) (3 11 13 1 5 2) (4 10 13 6 2) (4 11 9 3 2) (4 8 6 3 1 2) (5 6 6 4 2 3 2) (6 4 1 3 2 4 2 2) (7 2 2 4 5 2 1 1) (8 1 2 1 4 6 2 2) (9 2 1 2 6 2 2) (10 8 1 5 2 2) (1 7 8 2 5 2 2) (6 8 2 5 2 2) (1 5 8 1 5 2 2) (6 2 1 2 6 2 2) (1 6 2 4 6 2 2) (8 1 2 1 4 5 2 1 1) (7 3 1 3 2 4 2 2) (6 5 6 2 1 2 3 2) (6 6 2 3 3 1 2) (6 13 5 3 2) (6 12 7 1 7 2) (5 11 8 2 6 2) (4 11 11 2 5 2) (3 11 12 3 5 1) (1 11 13 4 5) (1 3 5 15 4 5) (5 4 15 4 5) (6 3 15 10) (5 4 15 10) (6 6 13 11) (15 9 12) (16 4 15) (18 18))) (quote #40(#40(on on on on on on on on on on on on on on on on on on off off off off off on) #40(on on on on on on on on on on on on on on on on off off on on on on on off off off on) #40(on on on on on on off off on on on on on on on off on on on on on on on on on on off on) #40(on on on on on off off off off on on on on on off on on on on on on on on on on on on off on on on on on on off on) #40(on on on on on on off off off off on on on on off on on on on on on on on on on on on on off on on on on on off on) #40(on off off on on off off off off on on on on on off on on on on on on on on on on on on on on off on on on off on on on on on off) #40(on off off on on on off off on on on on on on off on on on on on on on on on on on on on on off on on off on on on on on off on) #40(on on on off on on on on on on on on on on on off on on on on on on on on on on on on on off on off on on on on on off on) #40(on on on on off on on on on on on on on on on off on on on on on on on on on on on on on off off on on on on on on off on) #40(on on on on off on on on on on on on on on on on off on on on on on on on on on off off off off off off off on on on off off on) #40(on on on on off on on on on on on on on off off off off off off on on on on on on off off off off off on on on off on off off off on) #40(on on on on on off on on on on on on off on on on on on on off on on on on off on on off off off off on on on off off off off on) #40(on on on on on on off on on on on off on off off off off on on on off on on off on on on on off off off off on on off off off off on) #40(on on on on on on on off on on off on on off off off off on on on on off off on on on on on off off off off on on off off off on off on) #40(on on on on on on on on off on off on on off on off off on on on on off on on on on on on off off off off on on off off off on on off) #40(on on on on on on on on on off off on on off off off off on off on on off on on on on on on off off off off on on off off off on on off) #40(on on on on on on on on on on off on on on on on on on on off on off off on on on on on off off off off on on off off off on on off) #40(on off off on on on on on on on off on on on on on on on on off on on off on on on on on off off off off on on off off off on on off) #40(off off off off on on on on on on off on on on on on on on on off on on off on on on on on off off off off on on off off off on on off) #40(on off off off off on on on on on off on on on on on on on on off on off off on on on on on off off off off on on off off off on on off) #40(off off off off on on on on on on off on on off off off off on off on on off on on on on on on off off off off on on off off off on on off) #40(on off off on on on on on on off off on on off off off off on on on on off on on on on on on off off off off on on off off off on on off) #40(on on on on on on on on off on off on on off on off off on on on on off off on on on on on off off off off on on off off off on off on) #40(on on on on on on on off on on on off on off off off off on on on off on on off on on on on off off off off on on off off off off on) #40(on on on on on on off on on on on on off on on on on on on off on on off on off on on off off off off on on on off off off off on) #40(on on on on on on off on on on on on on off off off off off off on on off on on on off off off off off on on on off on off off off on) #40(on on on on on on off on on on on on on on on on on on on on off on on on on on off off off off off off off on on on off off on) #40(on on on on on on off on on on on on on on on on on on on off on on on on on on on off on off on on on on on on on off on) #40(on on on on on off on on on on on on on on on on on off off on on on on on on on on off on on off on on on on on on off on) #40(on on on on off on on on on on on on on on on on off on on on on on on on on on on on off on on off on on on on on off on) #40(on on on off on on on on on on on on on on on off on on on on on on on on on on on on off on on on off on on on on on off on) #40(on off off on on on on on on on on on on on off on on on on on on on on on on on on on off on on on on off on on on on on off) #40(on off off on on on off off on on on on on off on on on on on on on on on on on on on on on off on on on on off on) #40(on on on on on off off off off on on on on off on on on on on on on on on on on on on on on off on on on on off on) #40(on on on on on on off off off off on on on off on on on on on on on on on on on on on on on off on) #40(on on on on on off off off off on on on on off on on on on on on on on on on on on on on on off on) #40(on on on on on on off off on on on on on on off on on on on on on on on on on on on on off on) #40(on on on on on on on on on on on on on on on off on on on on on on on on on off off off on) #40(on on on on on on on on on on on on on on on on off off on on on on off off off on) #40(on on on on on on on on on on on on on on on on on on off off off off on)))) (make-problem "19990601bDRA (23)" (quote ((35) (13 21) (14 19) (15 17) (16 6 7) (17 4 3) (17 1 4 5) (14 2 1 4 7) (13 1 3 4 7) (12 1 11 7) (11 4 10 8) (3 4 6 7 10) (2 1 2 15 10) (2 5 13 10) (1 8 12 12) (13 8 12) (7 7 7 13) (6 1 7 6 13) (6 7 4 13) (7 9 12) (6 10 2 11) (4 9 7 8) (3 7 9 7) (2 4 12 7) (1 1 3 15 6) (5 6 11 6) (4 10 1 9 6) (3 11 8 7) (3 14 5 9) (2 16 2 9) (2 17 11) (2 5 10 13) (1 4 10 13) (7 2 6 2 12) (6 4 4 5 11) (6 5 8 10) (29 10) (40) (40) (40))) (quote ((25 13) (14 9 6 7) (12 8 4 7) (11 9 3 10) (11 9 2 11) (11 8 1 12) (12 4 1 1 7 4) (12 3 1 5 5) (13 2 1 2 5 7) (13 3 5 5 7) (11 4 5 5 6) (10 9 6 6) (9 2 8 7 4) (1 6 4 7 10 4) (1 4 6 7 10 4) (2 3 5 7 10 4) (3 3 5 5 10 4) (4 1 5 4 3 6 4) (5 1 5 2 2 6 4) (5 2 6 1 1 4 4) (5 2 7 2 2 5) (5 10 5 1 5) (5 10 7 6) (5 11 7 6) (4 11 8 7) (4 7 10 7) (4 1 4 10 6) (5 5 3 8 2 5) (11 6 7 3 4) (10 7 6 5 3) (9 10 4 10) (7 10 3 12) (5 12 12) (5 17 13) (3 33) (1 34) (34) (35) (35) (35))) (quote #40(#40(on on on on on on on on on on on on on on on on on on on on on on on on on off off on) #40(on on on on on on on on on on on on on on off on on on on on on on on on off off on on on on on on off on) #40(on on on on on on on on on on on on off off off on on on on on on on on off off on on on on off off off off on) #40(on on on on on on on on on on on off off on on on on on on on on on off off on on on off off off on) #40(on on on on on on on on on on on off on on on on on on on on on off off off off on on off off on) #40(on on on on on on on on on on on off off on on on on on on on on off off off off on off off on) #40(on on on on on on on on on on on on off on on on on off off on off off off off off on off on on on on on on on off off on) #40(on on on on on on on on on on on on off on on on off off off off off off off off on off off on on on on on off off off on) #40(on on on on on on on on on on on on on off on on off on off off off off off on on off on on on on on off off on) #40(on on on on on on on on on on on on on off on on on off off off on on on on on off on on on on on off off on) #40(on on on on on on on on on on on off off off on on on on off on on on on on off off on on on on on off off off on) #40(on on on on on on on on on on off off off off off on on on on on on on on on off off on on on on on on off off on) #40(on on on on on on on on on off off on on off off on on on on on on on on off off off on on on on on on on off off off on) #40(on off on on on on on on off off on on on on off off on on on on on on on off off on on on on on on on on on on off on) #40(on off off on on on on off off on on on on on on off on on on on on on on off off on on on on on on on on on on off on) #40(on on off off on on on off off off on on on on on off on on on on on on on off off on on on on on on on on on on off on) #40(on on on off off on on on off off on on on on on off off on on on on on off off off on on on on on on on on on on off on) #40(on on on on off off off on off off off on on on on on off off on on on on off off on on on off on on on on on on off off on) #40(on on on on on off off off on off off off on on on on on off off on on off off off on on off off on on on on on on off off on) #40(on on on on on off off off off on on off on on on on on on off off off off off off on off on off off on on on on off off off on) #40(on on on on on off off off off on on off on on on on on on on off off off off on on off off off off off off on on off off on) #40(on on on on on off off off off on on on on on on on on on on off off on on on on on off off off off off off on off off on) #40(on on on on on off off off off on on on on on on on on on on off off on on on on on on on off off off off off off on) #40(on on on on on off off off on on on on on on on on on on on off off on on on on on on on off off off off off off on) #40(on on on on off off off on on on on on on on on on on on off off off on on on on on on on on off off off off on) #40(on on on on off off off off on on on on on on on off off off off off on on on on on on on on on on off off off on) #40(on on on on off off on off off on on on on off off off off off off off on on on on on on on on on on off off off off on) #40(on on on on on off off on on on on on off off off off on on on off off on on on on on on on on off off on on off off on) #40(on on on on on on on on on on on off off off on on on on on on off off on on on on on on on off off on on on off off on) #40(on on on on on on on on on on off off off off on on on on on on on off on on on on on on off off on on on on on off off on) #40(on on on on on on on on on off off on on on on on on on on on on off off on on on on off off off on) #40(on on on on on on on off off off off on on on on on on on on on on off off on on on off off on) #40(on on on on on off off off off off on on on on on on on on on on on on off off off off off off on) #40(on on on on on off off on on on on on on on on on on on on on on on on on off off off on) #40(on on on off off off off on) #40(off on off off off off on) #40(off off off off off off on) #40(off off off off off on) #40(off off off off off on) #40(off off off off off on)))) (make-problem "19990604aDRA (24)" (quote ((40) (40) (40) (7 32) (5 2 21 8) (5 3 17 2 6) (5 3 15 3 6) (5 3 15 3 6) (5 3 15 3 6) (6 1 17 3 6) (8 8 3 7 1 7) (8 8 3 8 9) (8 9 1 9 9) (8 6 6 9) (8 6 1 1 6 9) (9 3 2 2 4 9) (10 1 2 2 2 10) (11 1 11) (11 12) (11 12) (6 7) (2 1 5 5 1 3) (4 6 6 5) (2 7 7 3) (11 2 2 12) (12 2 2 13) (12 1 1 1 1 14) (9 1 1 11) (4 3 6 5 3 6) (5 1 8 7 1 7) (4 24 6) (40) (40) (5 2 4 3 14) (5 2 2 2 2 2 2 2 13) (5 5 3 2 14) (5 5 2 2 2 2 2 13) (5 2 2 2 2 2 2 2 13) (5 2 2 2 2 2 14) (40))) (quote ((40) (40) (21 1 16) (21 1 16) (22 5 1 9) (4 12 7 2 1) (4 10 9 2 4 1) (3 5 10 8 3 4 1) (10 5 7 4 2 1) (4 4 5 4 6 12) (5 7 3 6 12) (5 8 2 5 1) (16 6 1 4) (15 1 1 5 1 4) (15 1 2 6 1 1) (13 2 2 11) (13 2 10) (10 1 4 1) (12 3 1 4) (13 3 1 4) (12 4 1) (10 1 10) (13 2 2 10) (13 2 2 4 1) (15 1 1 1 5 1 2 1) (15 6 1 2 1) (16 1 6 1 2) (6 8 2 12) (6 7 2 6 12) (5 4 5 3 7 11) (11 4 8 10) (4 5 9 9 9) (5 9 8 9) (5 11 6 1 9) (22 17) (21 1 16) (21 1 16) (40) (40) (40))) (quote #40(#40(on) #40(on) #40(on on on on on on on on on on on on on on on on on on on on on off on off on) #40(on on on on on on on on on on on on on on on on on on on on on off on off on) #40(on on on on on on on on on on on on on on on on on on on on on on off on on on on on off on off on) #40(on on on on off off off off off on on on on on on on on on on on on off on on on on on on on off off on on off off off off off off on) #40(on on on on off off off off off off on on on on on on on on on on off on on on on on on on on on off on on off on on on on off on) #40(on on on off on on on on on off on on on on on on on on on on off on on on on on on on on off on on on off on on on on off on) #40(on on on on on on on on on on off off off off off on on on on on off on on on on on on on off on on on on off off on on off off on) #40(on on on on off on on on on off on on on on on off on on on on off on on on on on on off on) #40(on on on on on off off off off on on on on on on on off on on on off on on on on on on off on) #40(on on on on on off off off off on on on on on on on on off off off off off off off off on on off on on on on on off off off off off off on) #40(on on on on on on on on on on on on on on on on off off off off off off off off off off off on on on on on on off on off on) #40(on on on on on on on on on on on on on on on off off off off off off off off off on off on off on on on on on off on off on) #40(on on on on on on on on on on on on on on on off on off off off off off off off on on off off on on on on on on off on off off off on) #40(on on on on on on on on on on on on on off off on on off off off off off off off off on on off off on) #40(on on on on on on on on on on on on on off on on off off off off off off off off off off off off off off on) #40(on on on on on on on on on on off off on off off off off off off off off off off off off off off off off off on on on on off off off off off on) #40(on on on on on on on on on on on on off off off off off off off off off off off off off off off off off off on on on off on off on) #40(on on on on on on on on on on on on on off off off off off off off off off off off off off off off off off on on on off on off on) #40(on on on on on on on on on on on on off off off off off off off off off off off off off off off off off off on on on on off off off off off on) #40(on on on on on on on on on on off off on off off off off off off off off off off off off off off off off off on) #40(on on on on on on on on on on on on on off on on off off off off off off off off off on on off off off on) #40(on on on on on on on on on on on on on off off on on off off off off off off off on on off off off on on on on off off off off off off on) #40(on on on on on on on on on on on on on on on off on off off off off off off off on off on off on on on on on off on off on on off on) #40(on on on on on on on on on on on on on on on off off off off off off off off off off off off on on on on on on off on off on on off on) #40(on on on on on on on on on on on on on on on on off off off off off off off off off off on off on on on on on on off on off off on) #40(on on on on on on off off off off on on on on on on on on off off off off off off off on on off on) #40(on on on on on on off off off off on on on on on on on off on on off on on on on on on off on) #40(on on on on on off on on on on off on on on on on off on on on off on on on on on on on off on) #40(on on on on on on on on on on on off off off off off on on on on off on on on on on on on on off on) #40(on on on on off on on on on on off on on on on on on on on on off on on on on on on on on on off on) #40(on on on on on off off off off off off on on on on on on on on on off on on on on on on on on off off on) #40(on on on on on off off off off off on on on on on on on on on on on off on on on on on on off on off on) #40(on on on on on on on on on on on on on on on on on on on on on on off on) #40(on on on on on on on on on on on on on on on on on on on on on off on off on) #40(on on on on on on on on on on on on on on on on on on on on on off on off on) #40(on) #40(on) #40(on)))) (make-problem "19990604bDRA (25)" (quote (() (19 18) (18 1 17) (18 2 16) (14 1 2 16) (13 3 3 2 10) (12 5 1 2 3 10) (11 5 1 1 3 11) (13 2 4 11) (16 4 4 7) (16 2 2 3 6) (3 10 5 4 1 5) (2 3 1 5 2 1 3 4) (2 2 1 1 1 1 2 10) (1 4 3 3 2 2 10) (1 6 2 2 1 2 11) (10 3 2 13) (5 3 4 2 3 9) (4 3 4 2 3 8) (3 3 3 3 1 3 2 6) (2 5 3 2 1 2 5 4) (1 7 6 3) (1 5 1 2 1 1 3 4 2) (1 3 5 1 1 2 7 3 2) (1 3 4 4 10 3 2) (1 3 3 12 3 2) (4 3 2) (5 3 2) (7 8) (7 1 1 8) (7 21 8) (8 19 9) (8 15 9) (9 1 9 1 10) (9 4 4 10) (10 15 11) (10 15 11) (11 13 12) (11 13 12) ())) (quote (() (25 12) (13 5 13) (11 5 17) (10 5 18) (10 5 19) (11 4 4 11) (11 3 4 11) (12 2 3 1 8) (13 2 2 2 2 6) (12 3 1 2 2 4) (11 1 3 4 2 2 2) (6 4 2 3 3 3 3) (5 4 3 2 1 3 5) (4 2 4 3 1 1 3 5) (3 3 3 1 3 3 4 4) (3 3 2 1 1 3 2 4 4) (3 4 2 2 4 2 4 4) (4 3 3 2 3 4 4 4) (1 1 4 1 4 4) (6 2 2 3 3 4 4) (1 3 1 2 2 3 4 4) (2 2 1 2 2 1 2 4 4) (6 3 1 2 2 2 4 4) (5 4 2 3 3 3 5) (4 4 1 1 3 4 3 5) (4 3 1 3 4 3 3) (4 1 4 2 1 4 2 2 2) (4 5 2 3 2 2 4) (10 4 3 2 2 6) (9 6 2 1 8) (8 8 3 11) (9 7 2 11) (10 7 18) (11 7 17) (20 16) (21 11) (38) (38) ())) (quote #40(#40(off) #40(off on on on on on on on on on on on on on on on on on on on on on on on on on off on on on on on on on on on on on on off) #40(off on on on on on on on on on on on on on off off on on on on on off off off off off on on on on on on on on on on on on on off) #40(off on on on on on on on on on on on off off off on on on on on off off on on on on on on on on on on on on on on on on on off) #40(off on on on on on on on on on on off off off on on on on on off off on on on on on on on on on on on on on on on on on on off) #40(off on on on on on on on on on on off off on on on on on off off on on on on on on on on on on on on on on on on on on on off) #40(off on on on on on on on on on on on off on on on on off off on on on on off off off off off on on on on on on on on on on on off) #40(off on on on on on on on on on on on off off on on on off off on on on on off off off off off on on on on on on on on on on on off) #40(off on on on on on on on on on on on on off off on on off off on on on off on off off off off off off off on on on on on on on on off) #40(off on on on on on on on on on on on on on off off on on off off on on off on on off off off off on on off off on on on on on on off) #40(off on on on on on on on on on on on on off off off on on on off off on off on on off off off off off on on off off off on on on on off) #40(off on on on on on on on on on on on off off on off off on on on off off on on on on off off off off on on off on on off off on on off) #40(off on on on on on on off on on on on off on on off off off on on on off off on on on off off off off on on on off on on on off) #40(off on on on on on off off on on on on off off on on on off off on on off off off off on off off off off on on on off on on on on on off) #40(off on on on on off on on off on on on on off off on on on off off on off on off off off off off off off on on on off on on on on on off) #40(off on on on off on on on off on on on off on off off on on on off off off on on on off off off off off on on on on off on on on on off) #40(off on on on off on on on off on on off on off on off off on on on off off off off on on off off off off on on on on off on on on on off) #40(off on on on off on on on on off off on on off on on off on on on on off off off on on off off off off on on on on off on on on on off) #40(off on on on on off on on on off on on on off on on off off on on on off on on on on off off off off on on on on off on on on on off) #40(off on off off off on off off off off on on on on off off off off off off off off off off off on off off off off on on on on off on on on on off) #40(off off on on on on on on off off off on on off on on off off on on on off off on on on off off off off on on on on off on on on on off) #40(off on off on on on off off off off off on off on on off off on on off off off off on on on off off off off on on on on off on on on on off) #40(off on on off off off on on off on off off on on off off on on off off off off on off on on off off off off on on on on off on on on on off) #40(off on on on on on on off on on on off on off off on on off off on on off off off on on off off off off on on on on off on on on on off) #40(off on on on on on off on on on on off off off on on off off on on on off off on on on off off off off on on on off on on on on on off) #40(off on on on on off on on on on off on off off on off off on on on off off on on on on off off off off on on on off on on on on on off) #40(off on on on on off on on on off off on off off off off on on on off off off on on on on off off off off on on on off on on on off) #40(off on on on on off on off off on on on on off off off on on off off on off on on on on off off off off on on off on on off off on on off) #40(off on on on on off off on on on on on off off off on on off off on on on off on on off off off off off on on off off off on on on on off) #40(off on on on on on on on on on on off off on on on on off off on on on off on on off off off off on on off off on on on on on on off) #40(off on on on on on on on on on off off on on on on on on off off on on off on off off off off off off off on on on on on on on on off) #40(off on on on on on on on on off off on on on on on on on on off on on on off off off off off on on on on on on on on on on on off) #40(off on on on on on on on on on off off on on on on on on on off off on on off off off off off on on on on on on on on on on on off) #40(off on on on on on on on on on on off off on on on on on on on off on on on on on on on on on on on on on on on on on on off) #40(off on on on on on on on on on on on off on on on on on on on off off on on on on on on on on on on on on on on on on on off) #40(off on on on on on on on on on on on on on on on on on on on on off off on on on on on on on on on on on on on on on on off) #40(off on on on on on on on on on on on on on on on on on on on on on off off off off off off on on on on on on on on on on on off) #40(off on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on off) #40(off on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on off) #40(off)))) (make-problem "19990606-DRA (26)" (quote (() (6) (14) (19) (21) (24) (27) (27) (2 5 5) (2 21) (2 12 4) (5 19) (6 18) (1 17) (2 16) (5 16) (9 19) (14 2 11) (3 3 3 1 1 8) (4 2 1 1 1 8) (2 1 2 1 1 8) (2 2 3 1 8) (2 3 2 1 8) (2 4 3 3 8) (2 2 2 3 1 8) (2 2 2 4 2 3 5) (6 6 2 1 1 4) (2 4 5 1 2 1 1 4) (4 2 4 1 1 2 1 3) (7 2 2 1 2 1 3) (1 2 1 1 2 1 3 3) (5 2 6 4) (5 16) (2 2 16) (2 2 6 9) (2 2 5 10) (3 5 11) (5 6 12) (14 13) (12 14))) (quote (() (2) (4) (3 1) (3 2) (1 2 2 1) (3 2 11) (1 9 6 7) (7 11 2 2 2) (8 3 3 2 2 1) (3 2 4 2 1 1 3 2) (4 2 4 1 2 1 2 2 3) (5 1 4 1 1 1 2 2 2) (5 2 1 2 1 1 2) (5 1 1 2 2) (7 1 2 2 2) (8 2 2) (9 2 2) (9 2 3 2) (10 1 5 3) (6 4 2 4 3) (7 5 1 4 4) (7 6 1 5 8) (7 8 5 7) (7 8 4 7 1) (7 9 7 2) (7 10 11 3) (6 8 2 4 4 4) (6 10 1 7 5) (5 1 7 5 1 1 1 9) (5 1 7 2 1 1 8) (6 15 2 1 8) (5 14 1 1 8) (19 3 8) (19 9) (32) (31) (29) (13) ())) (quote #f)) (make-problem "19990606-KVL (27)" (quote ((4 33) (2 17 1 11) (2 18 12) (1 30) (1 23 3) (1 25 1 2) (2 8 10 3) (2 5 5 8) (4 5 4 8 6) (11 3 5 5) (10 2 3 4) (9 2 2 3) (8 2 2 2) (7 2 2 1) (7 1 2 1) (7 1 1 4 1) (7 1 1 7 1) (8 2 2 8) (9 1 2 8) (13 1 8) (29) (29) (21 6) (21 6) (21 7) (15 4 4 2) (16 1 1 3) (5 10 5) (4 3 9 7) (3 7 6 7) (3 10 3 6) (3 13 6) (4 12 3) (7 6 3) (10 3 6 3) (13 7 5) (12 12) (3 9) (5) ())) (quote ((38) (3 32) (1 30) (1 21 5) (19 3 4) (18 4 4) (18 4 4) (1 5 10 5 3) (1 4 10 4 3) (3 5 9 4 3) (10 5 9 5 2) (9 2 12 4 2) (8 2 10 4 1) (8 2 9 5) (7 2 4 10 4) (7 1 2 2 5 4 4) (7 2 2 7 3 2 1) (6 1 2 6 4 1 2) (6 1 2 6 3 1 2) (6 2 1 2 7 3 3) (6 1 2 11 4) (6 1 1 7 4) (6 1 1 7 1 5) (6 1 1 8 3 4 2) (6 2 10 5 1 2) (6 1 10 6 5) (1 5 1 8 6 5) (2 4 1 7 6 4) (1 5 1 12 4) (7 1 7 4) (7 1 2) (7 1) (8) (4 3) (4 4) (5 4) (6 4) (5 6) (4 8) (4 12))) (quote #40(#40(on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on off) #40(on on on off off off on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on off) #40(on off off off off off off off on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on off) #40(on off off off off off off off on on on on on on on on on on on on on on on on on on on on on off off off on on on on on off) #40(off off off off off off off off off on on on on on on on on on on on on on on on on on on on off on on on off on on on on off) #40(off off off off off off off off off on on on on on on on on on on on on on on on on on on off on on on on off on on on on off) #40(off off off off off off off off off on on on on on on on on on on on on on on on on on on off on on on on off on on on on off) #40(on off off off off off off off on on on on on off off off off on on on on on on on on on on off on on on on on off on on on off) #40(on off off off off off off off on on on on off off off off off off on on on on on on on on on on off on on on on off on on on off) #40(on on on off off off on on on on on off off off off off off off off on on on on on on on on on off on on on on off on on on off) #40(on on on on on on on on on on off off off on on on on on off on on on on on on on on on off on on on on on off on on off) #40(on on on on on on on on on off off off on on off off off on on on on on on on on on on on on off on on on on off on on off) #40(on on on on on on on on off off off on on off off off off off off on on on on on on on on on on off on on on on off on off) #40(on on on on on on on on off off on on off off off off off off off off on on on on on on on on on off on on on on on off) #40(on on on on on on on off off on on off off off on on on on off off on on on on on on on on on on off on on on on off) #40(on on on on on on on off off on off off off on on off off on on off on on on on on off on on on on off on on on on off) #40(on on on on on on on off on on off off on on off off off off on on on on on on on off off on on on off on on off off on off) #40(on on on on on on off off on off off on on off off off off off off off on on on on on on off on on on on off on off on on off) #40(on on on on on on off off on off on on off off off off off off off off on on on on on on off off on on on off on off on on off) #40(on on on on on on off on on off on off off off off off on on off off on on on on on on on off on on on off off off on on on off) #40(on on on on on on off on off on on off off off off on on on on on on on on on on on off off off off off off off on on on on off) #40(on on on on on on off on off on off off off off off on on on on on on on off off off off off off off off off off off on on on on off) #40(on on on on on on off on off on off off off off off on on on on on on on off off off on off off off off off off off on on on on on off) #40(on on on on on on off on off on off off off off off on on on on on on on on off on on on off on on on on off off off off on on off) #40(on on on on on on off off on on off off off off off off on on on on on on on on on on off off on on on on on off on off on on off) #40(on on on on on on off off on off off off off off off off on on on on on on on on on on off on on on on on on off on on on on on off) #40(on off on on on on on off on off off off off off off off off on on on on on on on on off off on on on on on on off on on on on on off) #40(on on off on on on on off on off off off off off off off off off on on on on on on on off on on on on on on off off off on on on on off) #40(on off on on on on on off on off off off off off off off off off off off on on on on on on on on on on on on off off off on on on on off) #40(on on on on on on on off on off off off off off off off off off off off off off off on on on on on on on off off off off off on on on on off) #40(on on on on on on on off on off off off off off off off off off off off off off off off off off off off off off off off off off off off on on off) #40(on on on on on on on off on off) #40(on on on on on on on on off) #40(on on on on off on on on off) #40(on on on on off on on on on off) #40(on on on on on off on on on on off) #40(on on on on on on off on on on on off) #40(on on on on on off on on on on on on off) #40(on on on on off on on on on on on on on off) #40(on on on on off on on on on on on on on on on on on off)))) (make-problem "19990607aDRA (28)" (quote ((40) (40) (9 30) (40) (3 16 18) (21 2 1 1 10) (21 3 7) (7 8 6 1 1 6) (3 3 12 1 1 2 3 4) (3 13 5 3 5) (18 1 6 3 1 6) (11 7 2 2 4) (19 2 1 4 1 5) (18 1 2 2 2 3) (17 1 3 3 4 2 4) (18 3 4 2 4) (21 4 5 2 1) (21 1 1 2 2 1) (5 4 10 1 6 2 2 1) (2 2 2 3 7 1 1 2 2 1) (1 2 1 4 7 2 4 2 2 1) (1 2 1 4 8 1 2 1 1) (1 2 5 10 2 3 1 1) (1 4 5 13 2 2 2 1) (1 3 5 15 2 1 3) (1 3 5 16 1 1 1 2) (1 3 5 16 1 1 3) (1 2 4 17 1 1 1 2) (2 2 3 18 1 1 3) (2 2 3 6 8 1 1 1 2) (2 2 3 5 7 1 1 3) (2 1 2 6 2 6 1 1 1 2) (3 1 1 7 3 5 1 1 1 3) (3 2 8 7 1 1 7) (3 2 10 3 8) (3 2 11 7 9) (3 1 13 12) (4 33) (4 34) (4 34))) (quote ((40) (20 12) (19 8) (4 3 17 3) (9 21) (18 14) (19 1 3 2) (7 13 3) (7 11 9 4) (2 16 10 6) (18 11 7) (11 16 8) (27 9) (24 12) (19 13) (20 16) (40) (7 6 25) (7 1 2 1 14 6) (7 1 1 1 14 5) (4 2 1 1 15 2 4) (4 1 2 1 2 10 3 1 3) (5 5 2 2 9 2 1 3) (6 1 3 1 2 2 9 1 1 3) (6 4 1 4 12 1 3) (5 1 2 4 2 12 1 3) (6 1 1 3 1 2 11 1 3) (5 1 1 11 1 3) (6 1 1 1 1 1 1 1 10 1 4) (5 1 3 1 1 1 1 1 1 8 2 4) (7 3 1 1 1 1 1 2 6 1 1 4) (8 1 1 1 1 1 1 2 1 1 5) (6 1 2 1 7 1 6) (7 1 13 1 7) (9 1 18 7) (8 2 1 8) (13 2 4 2 1 1 1 1 7) (16 5 2 1 1 1 8) (16 16) (40))) (quote #40(#40(on) #40(on on on on on on on on on on on on on on on on on on on on off off off off off off off off on) #40(on on on on on on on on on on on on on on on on on on on off off off off off off off off off off off off off on) #40(on on on on off on on on off off on on on on on on on on on on on on on on on on on off off off off off off off off off off on) #40(on on on on on on on on on off on on on on on on on on on on on on on on on on on on on on on off) #40(on on on on on on on on on on on on on on on on on on off off off off off on on on on on on on on on on on on on on off) #40(on on on on on on on on on on on on on on on on on on on off off off off on off off off off off off off off off on on on off off on) #40(on on on on on on on off off on on on on on on on on on on on on on off off off off off off off off off off off off off off off on) #40(on on on on on on on off off on on on on on on on on on on on off off off off on on on on on on on on on off off off on) #40(on on off on on on on on on on on on on on on on on on on off off off on on on on on on on on on on off off on) #40(on on on on on on on on on on on on on on on on on on off off on on on on on on on on on on on off off on) #40(on on on on on on on on on on on off on on on on on on on on on on on on on on on on off off off off on) #40(on on on on on on on on on on on on on on on on on on on on on on on on on on on off off off off on) #40(on on on on on on on on on on on on on on on on on on on on on on on on off off off off on) #40(on on on on on on on on on on on on on on on on on on on off off off off off off off off on) #40(on on on on on on on on on on on on on on on on on on on on off off off off on) #40(on) #40(on on on on on on on off on on on on on on off on) #40(on on on on on on on off on off off on on off on off on on on on on on on on on on on on on on off off off off on) #40(on on on on on on on off on off on off off on off on on on on on on on on on on on on on on off off off off off off on) #40(on on on on off on on off on off off off on off on on on on on on on on on on on on on on on off off on on off off off on) #40(on on on on off off off on off on on off on off on on off off off on on on on on on on on on on off off on on on off on off on) #40(on on on on on off off on on on on on off on on off on on off off on on on on on on on on on off off off on on off on off on) #40(on on on on on on off on off on on on off on off on on off on on off on on on on on on on on on off off off on off on off on) #40(on on on on on on off on on on on off on off on on on on off off off off on on on on on on on on on on on on off on off on) #40(on on on on on off off on off on on off off on on on on off off on on off on on on on on on on on on on on on off on off on) #40(on on on on on on off on off off on off off on on on off off on off on on off on on on on on on on on on on on off on off on) #40(on on on on on off off off off off off off off off off off on off on off off off off on on on on on on on on on on on off on off on) #40(on on on on on on off on off off on off on off on off on off on off on off off on on on on on on on on on on off on off on) #40(on on on on on off on off on on on off on off on off on off on off on off on off on on on on on on on on off on on off on) #40(on on on on on on on off on on on off on off on off on off on off on off on on off on on on on on on off on off on off on) #40(on on on on on on on on off on off off on off on off on off on off on off off on on off off off off off off on off on off on) #40(on on on on on on off off on off on on off off off off off off off off off off on off on on on on on on on off on off on) #40(on on on on on on on off on off off on on on on on on on on on on on on on off off off off off off off on off on) #40(on on on on on on on on on off on off off on on on on on on on on on on on on on on on on on on off off on) #40(on on on on on on on on off on on off on off off off off off off off off off off off off off off off off off off off on) #40(on on on on on on on on on on on on on off on on off on on on on off on on off on off on off on off on off on) #40(on on on on on on on on on on on on on on on on off on on on on on off on on off on off on off on off on) #40(on on on on on on on on on on on on on on on on off off off off off off off off on) #40(on)))) (make-problem "19990607cDRA (29)" (quote ((40) (9 16 12) (8 14 11) (8 1 12 1 11) (7 3 10 1 11) (7 4 8 1 11) (6 2 2 7 1 11) (6 1 2 6 2 11) (5 2 3 4 3 11) (5 2 2 4 10) (4 3 3 4 10) (4 4 4 3 10) (4 4 3 2 10) (4 2 3 4 1 10) (5 8 1 11) (4 3 3 1 12) (3 3 4 2 2 12) (3 3 2 2 2 1 11) (3 3 2 7 11) (2 5 2 8 11) (2 6 12 10) (2 7 8 9) (1 12 8 8) (1 22 7) (1 23 6) (1 1 22 5) (1 3 22 4) (1 4 19 3) (1 5 7 8 3) (1 6 3 7 4) (1 8 2 6 4) (2 11 2 5) (2 16 1 4 6) (2 16 2 7) (2 15 14) (2 15 14) (2 14 14) (2 19 13) (2 22 13) (2 24 12))) (quote ((40) (22 9) (19) (16 1) (10 1 2) (8 2) (6 3 2) (4 6 3) (2 7 4 3) (1 3 4 7 3) (1 3 1 17 3) (2 5 3 7 14) (3 8 9 12) (4 5 11 11) (5 2 3 9 10) (8 3 1 8 10) (9 2 3 7 9) (9 2 2 2 7 9) (9 2 1 1 7 9) (9 2 1 1 7 9) (8 2 2 2 7 8) (7 2 4 7 8) (6 3 4 7 8) (5 15 8) (4 2 1 11 1 8) (3 4 2 11 1 1 3) (2 6 13 1 1 3 1) (1 11 12 1 6) (2 2 10 1 7) (9 6 10 1 6) (21 9 1 6) (22 8 1 6) (23 7 1 6) (24 2 2 7) (25 1 1 8) (26 9) (27 11) (40) (40) (40))) (quote #40(#40(on) #40(on on on on on on on on on on on on on on on on on on on on on on off off off off off off off off off on) #40(on on on on on on on on on on on on on on on on on on on off) #40(on on on on on on on on on on on on on on on on off off off off off off off off off off off off off off off off off off off off off off off on) #40(on on on on on on on on on on off off off off on off off off off off off off off off off off off off off off off off off off off off off off on) #40(on on on on on on on on off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off on) #40(on on on on on on off off off off off on on on off off off off off off off off off off off off off off off off off off off off off off off off on) #40(on on on on off off off off on on on on on on off off off off off off off off off off off off off off off off off off off off off off off on) #40(on on off off off off on on on on on on on off off off off off off off off off off off off off off on on on on off off off off off off on) #40(on off off off on on on off off off on on on on off off off off off off off off off off off off on on on on on on on off off off off on) #40(on off off on on on off off off off off off off on off off off off off on on on on on on on on on on on on on on on on on off on) #40(on on off off on on on on on off off on on on off off off off on on on on on on on off on) #40(on on on off off on on on on on on on on off off off off on on on on on on on on on off off on) #40(on on on on off off off off on on on on on off off off on on on on on on on on on on on off off on) #40(on on on on on off off off off off on on off off off on on on off on on on on on on on on on off off on) #40(on on on on on on on on off off off off off off on on on off on off on on on on on on on on off off on) #40(on on on on on on on on on off off off off off on on off on on on off on on on on on on on off off off on) #40(on on on on on on on on on off off off off on on off on on off on on off on on on on on on on off off on) #40(on on on on on on on on on off off off off on on off on off off off on off on on on on on on on off off on) #40(on on on on on on on on on off off off off on on off on off off off on off on on on on on on on off off on) #40(on on on on on on on on off off off off off on on off on on off on on off on on on on on on on off off off on) #40(on on on on on on on off off off off off off off on on off on on on on off on on on on on on on off off off on) #40(on on on on on on off off off off off off off off on on on off on on on on off on on on on on on on off off on) #40(on on on on on off off off off off off off off off off on on on on on on on on on on on on on on on off off on) #40(on on on on off off off off off on on off off off on off off on on on on on on on on on on on off on off off on) #40(on on on off off off off off on on on on off off off on on off on on on on on on on on on on on off on off off on off off off on) #40(on on off off off off off on on on on on on off off off on on on on on on on on on on on on on off on off on off on on on off off on) #40(on off off on on on on on on on on on on on off off off off on on on on on on on on on on on on off on off on on on on on on off) #40(on on off off off off off off off off off off off off off on on off off off on on on on on on on on on on off on off on) #40(on on on on on on on on on off off off off off on on on on on on off on on on on on on on on on on off on off on) #40(on on on on on on on on on on on on on on on on on on on on on off on on on on on on on on on off on off on) #40(on on on on on on on on on on on on on on on on on on on on on on off on on on on on on on on off on off on) #40(on on on on on on on on on on on on on on on on on on on on on on on off on on on on on on on off on off on) #40(on on on on on on on on on on on on on on on on on on on on on on on on off on on off off on on off off on) #40(on on on on on on on on on on on on on on on on on on on on on on on on on off on off off off on off on) #40(on on on on on on on on on on on on on on on on on on on on on on on on on on off off off off off on) #40(on on on on on on on on on on on on on on on on on on on on on on on on on on on off off on) #40(on) #40(on) #40(on)))) (make-problem "19990616-DRA (30)" (quote ((40) (1 12 5 17) (2 13 5 17) (2 1 1 1 1 1 1 1 1 3 1 3) (2 1 1 1 1 1 3 1 1 1 1 1 1 1 1 1 2 2) (2 1 1 1 1 1 1 1 2 1 2 2 2) (40) (40) (40) (40) (40) (40) (40) (12 12) (10 14 10) (8 18 8) (7 4 1 1 1 1 1 1 1 3 7) (6 4 1 1 1 1 1 1 1 1 3 6) (5 3 1 1 1 1 1 1 1 1 1 2 5) (4 24 4) (3 1 24 1 3) (2 2 24 2 2) (1 3 24 3 1) (1 3 24 3 1) (1 3 24 3 1) (2 2 24 2 2) (3 1 24 1 3) (4 24 4) (5 24 5) (6 24 6) (7 23 7) (8 19 8) (10 14 10) (12 12) (40) (40) (40) (40) (40) (40))) (quote ((40) (1 20 15) (1 15 3 14) (1 18 5 13) (3 13 7 12) (3 1 12 11) (3 11 10) (16 9) (3 9 13 8) (5 9 15 8) (3 8 15 7) (14 3 13 7) (3 7 2 14 6) (3 1 7 2 1 14 6) (3 1 7 3 15 6) (13 2 1 14 6) (1 7 3 15 6) (3 9 2 1 14 6) (3 7 3 15 6) (13 2 1 14 6) (3 7 3 15 6) (3 1 7 2 1 14 6) (1 7 3 15 6) (13 2 1 14 6) (3 7 3 15 6) (3 1 7 2 1 14 6) (3 7 3 15 6) (13 1 1 13 6) (3 9 2 14 7) (5 8 2 13 7) (4 10 15 8) (5 9 14 8) (3 11 9) (17 10) (3 12 11) (3 15 7 12) (3 16 5 13) (4 15 3 14) (22 15) (40))) (quote #40(#40(on) #40(on off on on on on on on on on on on on on on on on on on on on on off off off on) #40(on off off off off off on on on on on on on on on on on on on on on off on on on off on) #40(on off on on on on on on on on on on on on on on on on on on off on on on on on off on) #40(on on on off off off on on on on on on on on on on on on on off on on on on on on on off on) #40(on on on off on off on on on on on on on on on on on on off off off off off off off off off off off on) #40(on on on off off off on on on on on on on on on on on off off off off off off off off off off off off off on) #40(on on on on on on on on on on on on on on on on off off off off off off off off off off off off off off off on) #40(on on on off off off on on on on on on on on on off off on on on on on on on on on on on on on off off on) #40(on on on on on off on on on on on on on on on off on on on on on on on on on on on on on on on off on) #40(on on on off off off on on on on on on on on off off on on on on on on on on on on on on on on on off off on) #40(on on on on on on on on on on on on on on off on on on off on on on on on on on on on on on on on off on) #40(on on on off off off on on on on on on on off off on on off on on on on on on on on on on on on on on off off on) #40(on on on off on off on on on on on on on off on on off on off on on on on on on on on on on on on on on off on) #40(on on on off on off on on on on on on on off on on on off on on on on on on on on on on on on on on on off on) #40(on on on on on on on on on on on on on off on on off on off on on on on on on on on on on on on on on off on) #40(on off off off off off on on on on on on on off on on on off on on on on on on on on on on on on on on on off on) #40(on on on off on on on on on on on on on off on on off on off on on on on on on on on on on on on on on off on) #40(on on on off off off on on on on on on on off on on on off on on on on on on on on on on on on on on on off on) #40(on on on on on on on on on on on on on off on on off on off on on on on on on on on on on on on on on off on) #40(on on on off off off on on on on on on on off on on on off on on on on on on on on on on on on on on on off on) #40(on on on off on off on on on on on on on off on on off on off on on on on on on on on on on on on on on off on) #40(on off off off off off on on on on on on on off on on on off on on on on on on on on on on on on on on on off on) #40(on on on on on on on on on on on on on off on on off on off on on on on on on on on on on on on on on off on) #40(on on on off off off on on on on on on on off on on on off on on on on on on on on on on on on on on on off on) #40(on on on off on off on on on on on on on off on on off on off on on on on on on on on on on on on on on off on) #40(on on on off off off on on on on on on on off on on on off on on on on on on on on on on on on on on on off on) #40(on on on on on on on on on on on on on off off on off on off on on on on on on on on on on on on on off off on) #40(on on on off off on on on on on on on on on off on on off on on on on on on on on on on on on on on off on) #40(on on on on on off on on on on on on on on off off on on off on on on on on on on on on on on on on off on) #40(on on on on off on on on on on on on on on on off on on on on on on on on on on on on on on on off on) #40(on on on on on off on on on on on on on on on off off on on on on on on on on on on on on on on off on) #40(on on on off off on on on on on on on on on on on off off off off off off off off off off off off off off off on) #40(on on on on on on on on on on on on on on on on on off off off off off off off off off off off off off on) #40(on on on off off off on on on on on on on on on on on on off off off off off off off off off off off on) #40(on on on off on on on on on on on on on on on on on on on off on on on on on on on off on) #40(on on on off on on on on on on on on on on on on on on on on off on on on on on off on) #40(on on on on off off on on on on on on on on on on on on on on on off on on on off on) #40(on on on on on on on on on on on on on on on on on on on on on on off off off on) #40(on)))) (make-problem "19990618aDRA (31)" (quote ((40) (10 13 11) (9 3 11 3 10) (8 4 1 1 4 9) (8 4 4 9) (8 4 4 9) (9 10) (2 3 4 1 1 12) (1 1 3 12) (1 3 3 12) (1 3 1 12) (2 4 2 1 2 5 3 2) (2 4 5 4 1 1) (3 6 3 5 1) (4 8 6 1) (14 8 2) (15 9 2) (15 10 3) (13 9 4) (10 10) (9 9) (8 8) (8 8) (7 7) (6 6) (4 4) (3 2 2 3) (2 4 4 2) (2 4 4 2) (2 4 1 1 4 2) (2 4 2 2 4 2) (3 2 2 2 2 3) (4 2 3 3 2 4) (7 5 5 7) (7 5 5 7) (7 5 5 7) (7 5 2 5 7) (8 3 6 3 8) (9 16 9) (40))) (quote ((40) (8 29) (7 14 9) (8 12 4 8) (9 10 6 7) (8 11 6 7) (7 11 4 8) (8 12 2 3) (3 15 2 4 2) (2 3 13 2 6 1) (1 4 12 6 1) (1 4 6 6 1) (1 4 5 4 2) (2 3 2) (4 2 2) (3 2) (3 1 1 2) (3 2 3) (3 1 2 3) (3 5 4) (3 1 2 4) (3 2 3) (3 1 1 3) (3 2) (4 2 2) (2 3 2) (1 4 5 2) (1 4 6 4 2) (1 4 12 6 1) (2 3 12 6 1) (3 14 2 6 1) (21 2 4 2) (12 8 2 3) (11 7 4 8) (12 7 6 7) (13 6 6 7) (12 8 4 8) (11 10 9) (12 25) (40))) (quote #40(#40(on) #40(on on on on on on on on off off off on) #40(on on on on on on on off off off off off off on on on on on on on on on on on on on on off off off off on) #40(on on on on on on on on off off off off off off on on on on on on on on on on on on off on on on on off on) #40(on on on on on on on on on off off off off off off on on on on on on on on on on off on on on on on on off on) #40(on on on on on on on on off off off off off off on on on on on on on on on on on off on on on on on on off on) #40(on on on on on on on off off off off off off on on on on on on on on on on on off off off on on on on off on) #40(on on on on on on on on off off off on on on on on on on on on on on on off off off off off off off off on on off off off off on) #40(on on on off off off on on on on on on on on on on on on on on on off off off off off off off off off on on off on on on on off on) #40(on on off on on on off on on on on on on on on on on on on on off off off off off off off off off on on off on on on on on on off on) #40(on off on on on on off on on on on on on on on on on on on off off off off off off off off off off off off off on on on on on on off on) #40(on off on on on on off off off off off off off on on on on on on off off off off off off off off off off off off off on on on on on on off on) #40(on off on on on on off off off off off off off off on on on on on off off off off off off off off off off off off off off on on on on off on) #40(on on off off off off off off off off off off off off off on on on off off off off off off off off off off off off off off off off off off off off on) #40(on on on on off off off off off off off off off off off off on on off off off off off off off off off off off off off off off off off off off off on) #40(on on on off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off on) #40(on on on off off off off on off off off on off off off off off off off off off off off off off off off off off off off off off off off off off off on) #40(on on on off off off off off off off off on on off off off off off off off off off off off off off off off off off off off off off off off off on) #40(on on on off off off off off off on off off on on off off off off off off off off off off off off off off off off off off off off off off off on) #40(on on on off off off off off off on on on on on off off off off off off off off off off off off off off off off off off off off off off on) #40(on on on off off off off off off on off off on on off off off off off off off off off off off off off off off off off off off off off off on) #40(on on on off off off off off off off off on on off off off off off off off off off off off off off off off off off off off off off off off off on) #40(on on on off off off off on off off off on off off off off off off off off off off off off off off off off off off off off off off off off off on) #40(on on on off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off on) #40(on on on on off off off off off off off off off off off off on on off off off off off off off off off off off off off off off off off off off off on) #40(on on off off off off off off off off off off off off off on on on off off off off off off off off off off off off off off off off off off off off on) #40(on off on on on on off off off off off off off off on on on on on off off off off off off off off off off off off off off off off off off off on) #40(on off on on on on off off off off off off off on on on on on on off off off off off off off off off off off off off off on on on on off on) #40(on off on on on on off on on on on on on on on on on on on off off off off off off off off off off off off off on on on on on on off on) #40(on on off on on on off on on on on on on on on on on on on off off off off off off off off off off off off off on on on on on on off on) #40(on on on off off off on on on on on on on on on on on on on on off off off off off off off off off on on off on on on on on on off on) #40(on on on on on on on on on on on on on on on on on on on on on off off off off off off off off off on on off on on on on off on) #40(on on on on on on on on on on on on off off off on on on on on on on on off off off off off off off off on on off off off off on) #40(on on on on on on on on on on on off off off off off off on on on on on on on off off off on on on on off on) #40(on on on on on on on on on on on on off off off off off off on on on on on on on off on on on on on on off on) #40(on on on on on on on on on on on on on off off off off off off on on on on on on off on on on on on on off on) #40(on on on on on on on on on on on on off off off off off off on on on on on on on on off on on on on off on) #40(on on on on on on on on on on on off off off off off off on on on on on on on on on on off off off off on) #40(on on on on on on on on on on on on off off off on) #40(on)))) (make-problem "19990618bDRA (32)" (quote (() () () (2 2) (3 3) (5 5) (7 7) (3 5 2 9) (1 2 8 4 8 3 1) (1 4 6 6 4 3 2) (2 4 5 2 1 3 6 2) (2 11 2 1 2 8 2) (2 5 5 4 4 6 2) (1 5 5 6 4 5 2) (1 4 7 4 6 4 1) (12 6 5) (7 4 4 7) (6 3 1 2 2 6) (3 3 2 3 3 3) (2 3 3 3 3 2) (3 4 3 2) (3 4 3 3) (5 4 3 3) (5 5 3 4) (4 6 4 3) (4 6 4 4) (4 7 4 4) (12 6 3) (11 10) (10 11) (5 5 11) (4 4 12) (4 3 12) (4 3 6 6) (2 2 5 5) (1 1 3 4) (2 2) (1 1) () ())) (quote (() () (3) (9 3) (3 3 3 4) (7 7 7) (4 12 7) (4 10 7) (3 9 8) (3 4 3 8) (4 2 3 4 4) (3 1 3 4 6) (8 4 8) (8 4 10) (8 3 12) (7 3 8 3) (1 3 1 3 8) (1 1 2 8) (7 1 7) (8 5) (3 3) (7 3) (1 1 4 5) (1 3 1 1 17) (7 2 19) (3 4 2 17) (2 5 2 12) (2 1 3 6 8) (2 3 2 8 6) (3 4 2 12) (3 4 3 11) (3 6 2 10) (15 7) (17 6) (6 6 6) (3 5 3 3) (9) () () ())) (quote #f)) (make-problem "19990618cDRA (33)" (quote ((40) (40) (2 3 33) (2 3 11 18) (2 10 17) (2 3 9 1 16) (2 3 8 4 16) (14 22) (3 7 22) (2 3 5 21) (2 4 20) (2 3 3 2 19) (2 3 1 4 18) (8 6 17) (2 3 2 7 16) (2 1 3 8 15) (2 1 1 4 9 14) (2 3 16 13) (2 3 17 12) (25 11) (2 3 19 10) (2 1 20 9) (2 1 1 21 8) (2 3 22 7) (2 3 1 19 6) (9 21 5) (2 2 22 4) (2 6 3 17 3) (2 4 4 19 2) (2 6 4 4 13 2) (2 2 4 5 15 2) (8 9) (2 2 9) (2 3 1 9) (2 1 9) (2 2 8 5 19) (2 3 13 19) (20 19) (40) (40))) (quote ((40) (40) (2 2 1 1 1 1 3) (4 3 1 4 5 4 1 1 1 1 5) (4 3 1 5 5 3 1 1 1 1 5) (4 3 1 4 5 4 3 1 1 4) (2 2 1 1 1 3 2 1 3) (40) (12 10 6 5) (12 9 5) (11 8 6 5) (10 14 5) (9 14 5) (8 14 3 5) (7 15 4) (6 16 3 5) (5 20 5) (4 19 5) (3 2 18 5) (3 4 15 1 5) (3 5 14 2) (3 7 13 1 5) (4 7 14 5) (5 7 13 5) (15 12 5) (16 11 5) (17 10 5) (18 9 5) (19 8 5) (20 7 5) (21 6 5) (22 14) (23 13) (24 12) (25 11) (26 10) (27 9) (28 9) (40) (40))) (quote #40(#40(on) #40(on) #40(on on off off off off off on on off off off off on off off off off off on off off off off off on off off off off off on off off off off off on) #40(on on on on off on on on off on off on on on on off on on on on on off on on on on off on off on off on off on off on) #40(on on on on off on on on off on off on on on on on off on on on on on off on on on off on off on off on off on off on) #40(on on on on off on on on off on off on on on on off on on on on on off on on on on off on on on off on off on off off on) #40(on on off off off off off on on off off off off on off off off off off on off off off off off on off on on on off on on off off on off on) #40(on) #40(on on on on on on on on on on on on off off on on on on on on on on on on off on on on on on on off off off off on) #40(on on on on on on on on on on on on off off off on on on on on on on on on off off off off off off off off off off off on) #40(on on on on on on on on on on on off off off off off on on on on on on on on off on on on on on on off off off off on) #40(on on on on on on on on on on off off off off off off off on on on on on on on on on on on on on on off off off off on) #40(on on on on on on on on on off off off off off off off off on on on on on on on on on on on on on on off off off off on) #40(on on on on on on on on off off off off off on on on on on on on on on on on on on on off on on on off off off off on) #40(on on on on on on on off off off off off on on on on on on on on on on on on on on on off off off off off off off off off on) #40(on on on on on on off off off off off on on on on on on on on on on on on on on on on off on on on off off off off on) #40(on on on on on off off off off off off on on on on on on on on on on on on on on on on on on on on off off off off on) #40(on on on on off off off off off off off off on on on on on on on on on on on on on on on on on on on off off off off on) #40(on on on off off off off on on off off off off on on on on on on on on on on on on on on on on on on off off off off on) #40(on on on off off off on on on on off off off off on on on on on on on on on on on on on on on off on off off off off on) #40(on on on off off off on on on on on off off off off on on on on on on on on on on on on on on off off off off off off off off off on) #40(on on on off off on on on on on on on off off off off on on on on on on on on on on on on on off on off off off off on) #40(on on on on off off on on on on on on on off off off off on on on on on on on on on on on on on on off off off off on) #40(on on on on on off off on on on on on on on off off off off on on on on on on on on on on on on on off off off off on) #40(on on on on on on on on on on on on on on on off off off off on on on on on on on on on on on on off off off off on) #40(on on on on on on on on on on on on on on on on off off off off on on on on on on on on on on on off off off off on) #40(on on on on on on on on on on on on on on on on on off off off off on on on on on on on on on on off off off off on) #40(on on on on on on on on on on on on on on on on on on off off off off on on on on on on on on on off off off off on) #40(on on on on on on on on on on on on on on on on on on on off off off off on on on on on on on on off off off off on) #40(on on on on on on on on on on on on on on on on on on on on off off off off on on on on on on on off off off off on) #40(on on on on on on on on on on on on on on on on on on on on on off off off off on on on on on on off off off off on) #40(on on on on on on on on on on on on on on on on on on on on on on off off off off on) #40(on on on on on on on on on on on on on on on on on on on on on on on off off off off on) #40(on on on on on on on on on on on on on on on on on on on on on on on on off off off off on) #40(on on on on on on on on on on on on on on on on on on on on on on on on on off off off off on) #40(on on on on on on on on on on on on on on on on on on on on on on on on on on off off off off on) #40(on on on on on on on on on on on on on on on on on on on on on on on on on on on off off off off on) #40(on on on on on on on on on on on on on on on on on on on on on on on on on on on on off off off on) #40(on) #40(on)))) (make-problem "19990625-DRA (34)" (quote ((40) (16 17) (15 16) (5 8 15) (6 6 14) (6 4 13) (6 4 9 3) (6 4 8 3) (1 5 3 2 2 7 3) (2 4 2 3 3 7 4) (2 5 2 2 2 6 4) (2 4 2 2 2 5 5) (2 3 2 5 6) (3 3 2 4 6) (3 3 2 4 6) (3 3 2 5 6) (3 3 2 5 4 1) (3 3 2 5 4 1) (4 3 2 2 5 1) (4 3 5 1) (5 6 2) (6 6 2) (7 8 2) (11 8 2) (5 3) (4 4) (3 5) (2 6 12) (1 8 2 10) (1 7 1 4 8) (1 7 3 7 7) (1 6 5 8 5) (1 6 7 10 5) (1 6 7 11 4) (1 5 8 7 3) (1 5 10 8 2) (4 15 6 1) (4 17 6) (3 23 8) (2 27 7))) (quote ((36 2) (8 19 3) (9 14 4) (11 8 8) (12 5 9 1) (3 13 3 9 1) (4 10 2 8 2) (5 9 1 8 2) (8 3 1 7 3) (9 2 1 4 4) (15 1 1 3 5) (16 2 6) (5 2 2 8) (4 2 8) (3 2 9) (2 2 1 10) (1 4 11) (1 2 1 10) (1 9) (1 5) (1 4) (1 2 1 4) (1 4 6 4) (2 2 1 6 4) (3 2 5 3) (4 2 5 2) (5 3 1 5 2) (18 2 6 2) (18 2 1 6 2) (17 3 1 5 1) (16 4 2 5 1) (13 5 2 5) (11 6 3 6) (10 7 4 5) (8 11 4 5) (7 10 7 4) (6 10 9 3) (17 11 3) (16 16 2) (37 2))) (quote #40(#40(on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on off off on) #40(on on on on on on on on off on on on on on on on on on on on on on on on on on on on off off off off off off off off off on) #40(on on on on on on on on on off off off off on on on on on on on on on on on on on on off off off off off off off off on on on on off) #40(on on on on on on on on on on on off off off off off off off on on on on on on on on off off off off on on on on on on on on off) #40(on on on on on on on on on on on on off off off off off off off off on on on on on off off off off on on on on on on on on on off on) #40(on on on off on on on on on on on on on on on on on off off off off on on on off off off off on on on on on on on on on off off on) #40(on on on on off off off off on on on on on on on on on on off off off off on on off off off off on on on on on on on on off off on) #40(on on on on on off off off off off on on on on on on on on on off off off off on off off off on on on on on on on on off off off on) #40(on on on on on on on on off off off off off off off off off on on on off off off on off off off on on on on on on on off off off on) #40(on on on on on on on on on off off off off off off off off off on on off off off on off off off on on on on off off off off off on) #40(on on on on on on on on on on on on on on on off off off off on off off off on off off off on on on off off off off off on) #40(on on on on on on on on on on on on on on on on off off off off off off off off off off off on on off off off off off on) #40(on on on on on off off off off off off off off off off on on off off off off off off off off off off on on off off off on) #40(on on on on off off off off off off off off off off off off on on off off off off off off off off off off off off off off on) #40(on on on off off off off off off off off off off off off off off on on off off off off off off off off off off off off on) #40(on on off off off off off off off on on off off off off off off off on off off off off off off off off off off off on) #40(on off off off off off off off on on on on off off off off off off off off off off off off off off off off off on) #40(on off off off off off off off on on off on off off off off off off off off off off off off off off off off off off on) #40(on off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off on) #40(on off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off on) #40(on off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off on) #40(on off off off off off off off on on off on off off off off off off off off off off off off off off off off off off off off off off off off on) #40(on off off off off off off off on on on on off off off off off off off off off off off off off off off off on on on on on on off off on) #40(on on off off off off off off off on on off off off off off off off on off off off off off off off off off on on on on on on off off on) #40(on on on off off off off off off off off off off off off off off on on off off off off off off off off off off on on on on on off off off on) #40(on on on on off off off off off off off off off off off off on on off off off off off off off off off off off on on on on on off off off off on) #40(on on on on on off off off off off off off off off off on on on off off off off off on off off off off off off on on on on on off off off on) #40(on on on on on on on on on on on on on on on on on on off off off off on on off off off off off off on on on on on on off off on) #40(on on on on on on on on on on on on on on on on on on off off off off on on off off off on off off on on on on on on off off on) #40(on on on on on on on on on on on on on on on on on off off off off on on on off off off on off off off on on on on on off off off on) #40(on on on on on on on on on on on on on on on on off off off off on on on on off off off on on off off off on on on on on off off on) #40(on on on on on on on on on on on on on off off off off off off on on on on on off off off on on off off off on on on on on off) #40(on on on on on on on on on on on off off off off off off off on on on on on on off off off on on on off off off on on on on on on off) #40(on on on on on on on on on on off off off off off off off on on on on on on on off off off on on on on off off off off on) #40(on on on on on on on on off off off off on on on on on on on on on on on off off off off on on on on off off off off on) #40(on on on on on on on off off off off on on on on on on on on on on off off off off off on on on on on on on off off off on) #40(on on on on on on off off off on on on on on on on on on on off off off off off off on on on on on on on on on off off off on) #40(on on on on on on on on on on on on on on on on on off off off off off off off on on on on on on on on on on on off off on) #40(on on on on on on on on on on on on on on on on off off off off on on on on on on on on on on on on on on on on off off on) #40(on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on off on)))) (make-problem "19990628-DRA (35)" (quote ((40) (1 26 1) (2 20 2) (3 12 3) (4 4) (6 14 6) (9 14 9) (11 16 11) (11 16 11) (1 18 1) (1 7 20 7 1) (2 5 2 16 2 5 2) (3 3 3 14 3 3 3) (4 1 4 8 4 1 4) (8 7 6 7 8) (8 4 4 4 8) (8 4 2 4 8) (9 4 4 4 9) (10 16 10) (11 16 11) (11 16 11) (11 14 11) (12 14 12) (12 14 12) (12 14 12) (12 14 12) (12 14 12) (12 14 12) (12 14 12) (11 16 11) (11 1 8 1 11) (11 2 8 2 11) (11 3 8 3 11) (11 16 11) (11 16 11) (12 14 12) (13 1 1 13) (14 10 14) (15 15) (40))) (quote ((40) (1 7 29) (1 6 1 28) (1 5 2 27) (1 4 3 26) (1 4 3 26) (1 3 3 26) (2 3 2 27) (2 3 1 23) (2 2 5 22) (3 2 7 21) (3 2 6 7 5) (3 5 8 6 4) (3 8 1 14 5 3) (4 8 1 13 5 2) (4 8 1 12 3 1 1) (4 9 18 1 1) (4 10 18 1 1) (4 11 19 1 1) (4 31 1 1) (4 31 1 1) (4 11 19 1 1) (4 10 18 1 1) (4 9 18 1 1) (4 8 1 12 3 1 1) (4 8 1 13 5 2) (3 8 1 14 5 3) (3 5 8 6 4) (3 2 6 7 5) (3 2 7 21) (2 2 5 22) (2 3 1 23) (2 3 2 27) (1 3 3 26) (1 4 3 26) (1 4 3 26) (1 5 2 27) (1 6 1 28) (1 7 29) (40))) (quote #40(#40(on) #40(on off on on on on on on on off off on) #40(on off off on on on on on on off on off on) #40(on off off off on on on on on off on on off on) #40(on off off off off on on on on off on on on off on) #40(on off off off off on on on on off on on on off on) #40(on off off off off off on on on off on on on off on) #40(on on off off off off on on on off on on off on) #40(on on off off off off on on on off on off off off off off off on) #40(on on off off off off off on on off off on on on on on off off on) #40(on on on off off off off on on off on on on on on on on off off on) #40(on on on off off off off off off on on off on on on on on on off off off off on on on on on on on off off off off off off on) #40(on on on off off off off on on on on on off on on on on on on on on off off off off off off off off on on on on on on off on) #40(on on on off off on on on on on on on on off on off on on on on on on on on on on on on on on off on on on on on off on) #40(on on on on off on on on on on on on on off on off off on on on on on on on on on on on on on off off on on on on on off on) #40(on on on on off on on on on on on on on off on off off off on on on on on on on on on on on on off off off on on on off on off on) #40(on on on on off on on on on on on on on on off off off off on on on on on on on on on on on on on on on on on on off on off on) #40(on on on on off on on on on on on on on on on off off off on on on on on on on on on on on on on on on on on on off on off on) #40(on on on on off on on on on on on on on on on on off on on on on on on on on on on on on on on on on on on on off on off on) #40(on on on on off on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on off on off on) #40(on on on on off on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on off on off on) #40(on on on on off on on on on on on on on on on on off on on on on on on on on on on on on on on on on on on on off on off on) #40(on on on on off on on on on on on on on on on off off off on on on on on on on on on on on on on on on on on on off on off on) #40(on on on on off on on on on on on on on on off off off off on on on on on on on on on on on on on on on on on on off on off on) #40(on on on on off on on on on on on on on off on off off off on on on on on on on on on on on on off off off on on on off on off on) #40(on on on on off on on on on on on on on off on off off on on on on on on on on on on on on on off off on on on on on off on) #40(on on on off off on on on on on on on on off on off on on on on on on on on on on on on on on off on on on on on off on) #40(on on on off off off off on on on on on off on on on on on on on on off off off off off off off off on on on on on on off on) #40(on on on off off off off off off on on off on on on on on on off off off off on on on on on on on off off off off off off on) #40(on on on off off off off on on off on on on on on on on off off on) #40(on on off off off off off on on off off on on on on on off off on) #40(on on off off off off on on on off on off off off off off off on) #40(on on off off off off on on on off on on off on) #40(on off off off off off on on on off on on on off on) #40(on off off off off on on on on off on on on off on) #40(on off off off off on on on on off on on on off on) #40(on off off off on on on on on off on on off on) #40(on off off on on on on on on off on off on) #40(on off on on on on on on on off off on) #40(on)))) (make-problem "19990703-NEP (36)" (quote ((13 13) (9 2 2 3 2) (3 7 1 1 1 1 1 1) (7 3 2 1 1 1 1 3) (14 1 1 1 1 1 3) (11 2 1 1 1 1 3) (3 10 1 1 1 1 1 3) (6 8 2 2 3 4) (7 7 13) (2 14 1) (4 28) (1 5 27) (3 5 26) (1 4 5 25) (2 4 31) (3 4 17 11) (1 2 5 15 1) (1 3 4 14 1 7 1) (1 3 18 3 1 1 1 2) (1 4 6 14 1 1 3) (2 9 2 13 5 3) (2 8 4 11 7 1 1) (2 8 2 7 1 6 2) (12 1 4 6 1 2 6 1) (13 1 1 5 1 4 2 2) (4 1 1 5 1 4 1 2 1) (9 4 4 5 2 2 1 4) (2 3 1 4 4 5 3 2 4) (1 1 1 1 4 4 5 5 1 2 1) (1 1 1 2 4 4 5 4 2 1 2) (1 1 1 1 4 4 5 3 4 4) (2 3 1 5 7 3 2 4 1) (9 4 4 7 3 4 2) () (32 7) (1 3 2 1 3 2 1 3 5 2 3) (1 2 2 1 1 1 1 1 1 1 1 2 2 1 2 2) (1 1 1 1 1 1 1 1 1 2 1 2 2 1 2 2) (1 3 1 3 1 1 1 2 1 2 2 1 4 2) (5 2 3 2 2 2 2 1 2 3))) (quote ((9 1 1 6) (2 5 7 1 1) (7 2 2 2 4 1) (10 1 3 1 3 1) (3 8 2 2 2 3) (6 6 7 1 1 1) (6 5 2 2 1 1 1) (2 12 1 3 1 2 1) (4 10 2 1 2 6) (6 9 1) (2 6 15 1 4) (4 10 10 2 2) (2 5 8 2 9 1 4) (1 3 6 6 4 8 2) (1 4 6 5 2 1 6) (1 4 13 1 2 5 1 2 1) (2 4 13 1 6 1 1 3) (2 5 13 2 5 1 2 1) (2 5 13 1 6 1 6) (3 18 1 1) (3 29 2 3) (3 29 1 4) (33 2) (33 6) (33 2 1) (1 1 1 1 1 7 5 2 1 3) (1 1 1 1 7 5 7 1 1 3) (9 5 5 1 6 2) (1 1 5 3 1 2 6 5) (9 6 1 1 4 2 2 6) (2 2 6 2 2 4 1 1 1 2) (1 5 1 6 1 4 2 1 3 2 2) (2 2 6 2 4 2 3) (9 6 1 7 1 1 1 6) (2 2 6 2 5 2 1 2 2 3) (1 5 1 6 1 3 4 3 1 1 1) (2 2 6 2 2 4 3 1 1 1) (9 6 4 2 2 3 2 1) (1 6 6 4 1 2 3 1 6) (1 6 7 3 2 6))) (quote #40(#40(off off off off off off off off off off off off off off off off on on on on on on on on on off on off off off off off on off on) #40(off off off off off off off off off off off off off off on on off off off off on on on on on off on on on on on on on off on off off off off on) #40(off off off off off off off off off off off off off on on on on on on on off off off on on off on on off off off on on off on on on on off on) #40(off off off off off off off off off off off off off off off on on on on on on on on on on off on off on on on off on off on on on off off on) #40(off off off off off off off off off off off off on on on off off on on on on on on on on off on on off off off on on off on on off on) #40(off off off off off off off off off off off on on on on on on off off on on on on on on off on on on on on on on off on off on off on off) #40(off off off off off off off off off off off off on on on on on on off off on on on on on off on on off off off on on off on off on off on off) #40(off off off off off off off off off off on on off on on on on on on on on on on on on off on off on on on off on off on on off off off on) #40(off off off off off off off off off on on on on off off on on on on on on on on on on off on on off on off on on off on) #40(off off off off off off off off off on on on on on on off on on on on on on on on on off off off off off off off off off on off) #40(off off off off off off off on on off on on on on on on off off on on on on on on on on on on on on on on on off on off on) #40(off off off off off off on on on on off on on on on on on on on on on off off on on on on on on on on on on off on on off off on) #40(off off off on on off on on on on on off on on on on on on on on off on on off on on on on on on on on on off on off on) #40(on off on on on off on on on on on on off on on on on on on off on on on on off on on on on on on on on off on on off) #40(on off on on on on off on on on on on on off on on on on on off on on off off off off off off off off off on off off on) #40(on off on on on on off on on on on on on on on on on on on on off on off on on off on on on on on off on off on on off off off on) #40(on on off on on on on off on on on on on on on on on on on on on off off on off on on on on on on off on off on off on on on off) #40(on on off on on on on on off on on on on on on on on on on on on on off on on off on on on on on off on off on on off off off on) #40(on on off on on on on on off on on on on on on on on on on on on on off on off on on on on on on off on off on) #40(on on on off on on on on on on on on on on on on on on on on on on off off off off off off off off off on off off on off) #40(on on on off on on on on on on on on on on on on on on on on on on on on on on on on on on on on on off on on off on) #40(on on on off on on on on on on on on on on on on on on on on on on on on on on on on on on on on on off on off on) #40(on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on off on on off) #40(on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on off on) #40(on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on off on on off off off on) #40(on off on off on off on off on off on on on on on on on off off on on on on on off off off off off off off on on off on off on on on off) #40(off on off on off on off on off on on on on on on on off off on on on on on off on on on on on on on off on off on off on on on off) #40(on on on on on on on on on off on on on on on off off on on on on on off on off off on on on on on on off off on on off) #40(on off off off off off off off on off on on on on on off off off on on on off on off on on off on on on on on on off on on on on on off) #40(on on on on on on on on on off on on on on on on off on off off off on off on on on on off on on off on on off on) #40(on on off off off off off on on off on on on on on on off on on off on on off on on on on off on off on off on off on on off) #40(on off on on on on on off on off on on on on on on off on off on on on on off on on off on off on on on off off on on off on on off) #40(on on off off off off off on on off on on on on on on off on on off on on on on off off on on off on on on off) #40(on on on on on on on on on off on on on on on on off on off on on on on on on on off off on off on off on off on) #40(on on off off off off off on on off on on on on on on off on on off on on on on on off on on off on off on on off on on off on) #40(on off on on on on on off on off on on on on on on off on off off off on on on off on on on on off on on on off on off on off on off) #40(on on off off off off off on on off on on on on on on off off off on on off on on off on on on on off on on on off on off on off on off) #40(on on on on on on on on on off on on on on on on off off on on on on off on on off on on off on on on off off on on off off off on) #40(on off off on on on on on on off on on on on on on off on on on on off on off on on off off on on on off on off on) #40(on off off on on on on on on off on on on on on on on off off off off on on on off off off off off off off on on off on)))) (make-problem "19990714bNEP (37)" (quote ((3 2 3) (2 1 2 1 2 1) (1 1 1 2 1 1) (1 2 2 2 2 1 2) (2 2 2 2 2 1 2 2) (2 1 2 2 2 2) (2 2 2 2 2) (2 2 2 2 2 1) (1 2 2 2 2 2) (2 2 2 2 2 2 2) (2 2 2 2 2 2 2 1) (1 2 2 2 2 2 2 2) (2 2 2 2 2 2 2 2 2) (2 2 2 2 2 2 2 2 2 1) (1 2 2 2 2 2 2 2 2 2) (2 2 2 2 2 2 2 2 2 2) (2 2 2 2 2 2 2 2 2 2) (2 2 2 2 2 2 2 2 2 2) (2 2 2 2 2 2 2 2 2 2) (30) (1 1 1 1 1 1 1 1 1 1 1 1 1) (1 1) (34) (1 1 1 1 1 1 1 1 1 1 1 1 1 1) (1 1) (38) (1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1) (1 1) (38) (1 32 1) (1 32 1) (1 32 1) (1 32 1) (1 10 1 1 1 10 1) (1 10 1 1 1 10 1) (1 10 2 2 2 10 1) (1 10 2 2 2 10 1) (2 10 10 2) (2 32 2) ())) (quote (() (4 2) (1 11) (5 1) (1 1 11) (2 1 8 2 11) (5 7 2 1 11) (2 2 1 1 11) (1 2 10 2 2 11) (5 1 9 1 1 11) (1 1 2 11) (1 11 2 1 11) (14 1 1 11) (1 2 2 11) (17 1 1 5 1) (1 14 1 2 5 1) (1 2 1 9 1) (1 18 1 1 5 2 1) (19 2 2 5 1) (2 1 1 5 2 1) (1 1 2 9 1) (20 2 1 5 1) (1 19 1 1 9 1) (1 2 2 5 2 1) (1 16 1 1 5 1) (17 1 2 5 1) (1 2 1 11) (15 1 1 11) (1 12 2 2 11) (2 1 1 11) (1 9 1 2 11) (12 2 1 11) (1 1 1 11) (8 2 2 11) (1 9 1 11) (2 1 2 11) (5 4 1) (2 1 11) (1 2 4 2) (5))) (quote #f)) (make-problem "19990722-DRA (38)" (quote ((40) (40) (2 3 1 3 1 2 16) (2 2 1 3 3 3 19) (2 1 1 1 3 3 3 2 5) (2 2 1 3 3 7 1 8 4) (2 3 2 3 3 1 10 3) (24 12 2) (22 13 2) (21 16 1) (7 4 7 17 1) (7 2 7 17 1) (7 1 1 6 16 1) (7 4 6 8 8 2) (6 1 2 1 5 7 7 2) (6 6 5 6 2 5 3) (6 2 2 5 6 3 4) (6 6 4 6 13) (7 2 2 3 5 13) (9 6 3 5 12) (8 9 1 4 12) (7 13 4 12) (7 7 6 3 12) (7 4 2 8 2 11) (4 3 2 10 2 11) (3 6 2 12 2 10) (3 1 2 1 12 2 10) (3 3 1 1 1 12 1 10) (3 5 2 2 3 7 1 9) (3 5 1 1 2 10 9) (3 4 5 1 1 10 9) (4 7 1 10 9) (15 2 9 11) (16 7 11) (2 8 4 7 10) (1 3 6 5 6 10) (5 6 12 9) (5 10 9) (1 3 34) (2 35))) (quote ((36 2) (35 2 1) (2 27 4) (3 21 3 4) (4 19 2 3 2 4) (5 18 1 4 3 2 1) (2 7 6 1 4 4 2) (10 4 2 1 4 8) (2 5 2 3 1 6 2 9) (6 5 3 2 8 10) (6 5 3 2 5 1 10) (6 4 2 3 5 4 10) (2 3 4 4 2 6 4) (14 7 2 4 1 3) (2 14 6 2 2 3 1 3) (2 15 3 4 1 1 1 3) (2 11 11 2 1 3) (2 16 11 1 2 2) (2 17 8 1 1 2) (12 2 7 4 1 1 2) (3 1 3 5 1 7 4 1 1 2) (2 1 1 2 9 1 12 1 2) (2 1 1 1 11 12 1 2) (2 1 1 1 13 14 2) (4 1 15 13 2) (6 16 12 2) (5 9 6 10 2) (4 9 4 4 9 2) (4 8 8 3 3 3 2) (4 9 9 1 2 1 2) (4 10 11 4 2) (4 11 23) (4 11 23) (4 11 23) (4 11 23) (5 10 23) (6 8 24) (7 3 25) (9 27) (40))) (quote #40(#40(on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on off off on) #40(on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on off on on off on) #40(on on off off off off off on on on on on on on on on on on on on on on on on on on on on on on on on on on off on on on on off) #40(on on on off on on on on on on on on on on on on on on on on on on on on on off off off off off off on on on off on on on on off) #40(on on on on off on on on on on on on on on on on on on on on on on on on off on on off on on on off on on off on on on on off) #40(on on on on on off on on on on on on on on on on on on on on on on on on off on off on on on on off on on on off on on off on) #40(on on off off off off off on on on on on on on off off off off on on on on on on off on off on on on on off on on on on off off on) #40(on on on on on on on on on on off off off off on on on on off on on off off off off on off on on on on off on) #40(on on off off off off on on on on on off on on off on on on off on off on on on on on on off on on off on) #40(on on on on on on off on on on on on off on on on off on on off on on on on on on on on off off on) #40(on on on on on on off on on on on on off on on on off on on off on on on on on off off off on off on) #40(on on on on on on off on on on on off on on off on on on off on on on on on off on on on on off on) #40(on on off off off off off on on on off off off off on on on on off on on on on off on on off off off on on on on on on off on) #40(on on on on on on on on on on on on on on off off off off on on on on on on on off off on on off on on on on off on off on) #40(on on off on on on on on on on on on on on on on on off on on on on on on off on on off on on off on on on off on off on) #40(on on off on on on on on on on on on on on on on on on off on on on off off on on on on off off on off off on off on off on) #40(on on off off off off off on on on on on on on on on on on off on on on on on on on on on on on off on on off off on off on) #40(on on off on on on on on on on on on on on on on on on on off on on on on on on on on on on on off on off on on off off on) #40(on on off on on on on on on on on on on on on on on on on on off on on on on on on on on off off off off off on off on off on) #40(on on on on on on on on on on on on off off off off off off on on off on on on on on on on off on on on on off on off on off on) #40(on on on off off on off on on on off off off on on on on on off on off on on on on on on on off on on on on off on off on off on) #40(on on off on off on off on on off on on on on on on on on on off on off on on on on on on on on on on on on off off on off on) #40(on on off on off on off on off on on on on on on on on on on on off off off on on on on on on on on on on on on off on off on) #40(on on off on off on off on off on on on on on on on on on on on on on off on on on on on on on on on on on on on on off on) #40(on on on on off off on off on on on on on on on on on on on on on on on off on on on on on on on on on on on on on off on) #40(on on on on on on off on on on on on on on on on on on on on on on on off off on on on on on on on on on on on on off on) #40(on on on on on off on on on on on on on on on off off off off on on on on on on off off on on on on on on on on on on off on) #40(on on on on off on on on on on on on on on off on on on on off off off off on on on on off on on on on on on on on on off on) #40(on on on on off on on on on on on on on off off on on on on on on on on off off on on on off on on on off off on on on off on) #40(on on on on off on on on on on on on on on off off on on on on on on on on on off off off on off off off on on off off on off on) #40(on on on on off on on on on on on on on on on off off on on on on on on on on on on on off off off off on on on on off off on) #40(on on on on off on on on on on on on on on on on off on) #40(on on on on off on on on on on on on on on on on off on) #40(on on on on off on on on on on on on on on on on off on) #40(on on on on off on on on on on on on on on on on off on) #40(on on on on on off on on on on on on on on on on off on) #40(on on on on on on off on on on on on on on on off on) #40(on on on on on on on off off on on on off off off on) #40(on on on on on on on on on off off off off on) #40(on)))) (make-problem "19990801-NEP (39)" (quote ((1 1) (1 1 1 1) (1 1 1 1) (1 1) (1 1) (1 1) (1 1 2 1 1) (1 2 1 1 2 1) (1 3 1 1 3 1) (1 1 3 2 3 1 1) (1 1 2 2 1 1) (1 2 1 1 2 1) (1 2 6 2 1) (1 2 2 2 1) (1 1 1 1) (3 2 2 3) (1 1 1 1) (1 12 1) (5 4 5) (40) (40) (40) (40) (1 1) (40) (1 1 1 1 1 1) (1 1 1 1 1 1) (7 5 5 7) (1 1 1 1 1 1 1 1 1 1 1 1) (1 1 1 5 5 1 1 1) (7 1 1 7) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (7 1 1 7) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (7 5 5 7) (1 1 1 2 2 2 2 1 1 1) (1 1 1 2 8 2 1 1 1) (7 2 2 2 2 7))) (quote ((21) (5 1 1 1 1 1 1) (2 1 5 1 4 4 1) (1 20 1 1 1 1 1 1) (2 1 5 4 4 4) (5 1 1 1 1 1 1) (4 16) (4 1) (4 1) (4 1 2) (4 1 3) (4 1 3 2) (4 1 1 1 1) (6 4 1 10) (2 2 1 4 1 1 1 1) (2 2 3 4 1 3 2) (1 3 1 4 1 3) (4 1 4 1 2) (2 1 1 6 1 1) (1 1 2 6 1 1) (1 1 2 6 1 1) (2 1 1 6 1 1) (4 1 4 1 2) (1 3 1 4 1 3) (2 2 3 4 1 3 2) (2 2 1 4 1 1 1 1) (6 4 1 10) (4 1 1 1 1) (4 1 3 2) (4 1 3) (4 1 2) (4 1) (4 1) (4 16) (5 1 1 1 1 1 1) (2 1 5 4 4 4) (1 20 1 1 1 1 1 1) (2 1 5 1 4 4 1) (5 1 1 1 1 1 1) (21))) (quote #f)) (make-problem "19990807-DRN (40)" (quote ((2) (1) (2) (3) (2) (1) (2) (3) (2) (1) (2) (3) (2) () (2) (1 2 4) (5 2 1 1) (2 2 2 1 1 1) (2 2 2 1 1 1 2) (1 2 2 2 1 1 1) (2 2 1 1 1 2) (2 1 1 2) (12 4) (1 2) (1 2) (2 3 1 4) (1 3 1 1 1 6) (2 3 3 1 15) (3 1 17) (3 1 20 2) (13 19 4) (15 16 6) (17 11 7) (19 6 10) (22 4 12) (23 13) (27 12) (28 11) (29 10) (30 9))) (quote ((13 1 2 1 1 1 10) (1 3 3 3 5 1 3 10) (1 1 1 2 1 10) (2 3 1 14) (2 3 1 14) (2 1 14) (2 1 10) (2 1 3 10) (2 1 1 1 10) (3 3 10) (2 10) (18) (10) (9) (9) (1 8) (2 8) (3 7) (4 7) (6 6) (6 6) (4 6 6) (2 1 1 8 5) (2 1 1 1 10 4) (1 1 1 14 4) (2 1 1 13 4) (1 1 1 2 10 4) (1 1 2 8 1 3) (4 6 3 2) (6 4 1) (5 6) (5 7) (5 7) (4 8) (2 9) (1 9) (10) (10) (11) (11))) (quote #f)) (make-problem "19990808bVAC (41)" (quote ((5 5 5) (3 2 3 3 2 3) (2 2 2 1 1 2 2 2) (2 2 2 9 2 2 2) (1 2 1 3 3 1 2 1) (2 3 2 2 2 1 1 2 2 2 3 2) (1 2 1 1 2 2 1 1 2 1) (1 2 2 4 1 4 2 1 1) (1 2 2 1 4 4 1 1 1 2 1) (1 2 1 1 5 5 1 2 2 1 1) (1 2 2 1 4 4 2 1 2 1) (1 1 1 1 4 5 1 1 1 1) (1 2 2 2 4 4 2 1 2 1 1) (2 1 1 1 5 1 5 2 2 1 2) (1 2 1 1 13 1 1 1 2 1) (1 1 3 3 5 3 3 1 1) (2 1 2 5 1 3 1 6 1 2) (1 1 1 3 1 1 1 1) (2 2 7 1 1 8 1 2) (2 3 7 3 2) (3 3 4 4 3 1 3) (5 4 4 3 1) (2 6 6 1 2) (2 3 4 5 4 3 3) (2 2 4 3 4 1 1 2) (1 2 6 5 6 3 1) (2 2 4 5 5 4 2 2) (1 1 4 3 3 4 1 1) (1 2 6 5 5 6 2 1) (1 1 4 5 5 5 4 1 1) (2 3 3 3 3 4 2) (7 5 5 5 7) (2 5 5 5 5 2) (2 3 3 3 3 2) (3 5 5 5 5 3) (7 5 5 5 7) (6 3 3 3 6) (7 5 5 5 7) (33) (2 2))) (quote ((9) (3 4) (2 1 2 3 5) (2 1 2 3 2 3 2 4) (1 1 2 3 2 2 2 1 6) (2 2 3 1 2 3 8) (1 1 2 3 3 3 2 4 5) (1 2 2 2 2 1 2 4 4) (1 2 3 1 1 1 2 6 5) (2 2 3 2 2 1 1 4 5 2) (2 3 3 1 1 1 1 4 3 1) (2 4 1 1 1 6 5 2) (3 3 1 1 1 4 5 5) (3 7 1 1 4 3 4) (9 1 6 5 5) (17 4 5 5 2) (1 8 2 4 3 3 1) (2 2 2 2 6 5 5 3) (2 1 1 1 4 2 5 5 6) (1 1 1 5 1 3 3 4) (2 1 1 1 4 2 5 5 6) (2 2 2 2 6 5 5 3) (1 8 2 4 3 3 1) (17 4 5 5 2) (9 1 6 5 5) (3 7 1 1 4 3 4) (3 3 1 1 1 4 5 5) (2 3 1 1 1 1 6 5 2) (2 3 1 1 1 1 1 1 1 4 3 1) (2 2 2 2 1 1 1 1 4 5 2) (1 2 2 1 13 6 5) (1 2 1 1 1 1 1 1 4 4) (1 1 1 2 1 3 8 4 5) (2 2 2 2 3 1 2 3 9) (1 1 1 1 2 2 2 2 1 6) (2 1 2 1 2 2 3 2 4) (2 1 1 3 5) (3 4) (9) ())) (quote #f)) (make-problem "19990831-DAH (42)" (quote ((40) (40) (40) (14 16) (12 12) (10 12 10) (8 16 9) (7 20 8) (6 22 7) (5 24 6) (5 25 5) (4 34) (4 13 2 2 2 4) (3 12 2 2 2 5) (3 12 2 2 2 2 3) (3 32 3) (3 10 2 2 2 4 2) (2 9 2 2 2 6 2) (2 9 2 2 2 7 2) (2 34 2) (2 7 2 2 2 9 2) (2 6 2 2 2 9 2) (2 4 2 2 2 10 3) (3 32 3) (3 2 2 2 2 12 3) (5 2 2 2 12 3) (4 2 2 2 13 4) (34 4) (5 25 5) (6 24 5) (7 22 6) (8 20 7) (9 16 8) (10 12 10) (12 12) (14 14) (40) (40) (40) (40))) (quote ((40) (40) (17 17) (13 4 15) (11 12 13) (9 13 1 11) (8 14 1 10) (7 15 2 9) (6 14 1 3 8) (6 14 3 3 7) (5 13 2 4 6) (5 14 2 5 6) (4 12 1 3 6 5) (4 12 3 1 8 5) (3 11 2 3 6 4) (3 11 2 2 7 4) (3 9 1 3 2 7 4) (3 8 3 1 3 8 4) (3 7 2 3 1 9 4) (3 7 2 2 3 7 4) (3 7 3 2 2 7 4) (3 9 1 3 2 7 4) (3 8 3 1 3 8 4) (3 7 2 3 1 9 4) (4 7 2 2 11 4) (4 6 3 2 11 4) (4 8 1 3 12 5) (4 6 3 1 12 5) (5 5 2 14 6) (5 4 2 13 6) (6 3 3 14 7) (7 3 1 14 7) (8 2 15 8) (9 1 14 9) (10 1 13 10) (12 12 12) (14 4 14) (16 18) (40) (40))) (quote #40(#40(on) #40(on) #40(on on on on on on on on on on on on on on on on on off off off off off off on) #40(on on on on on on on on on on on on on off off off off off on on on on off off off on) #40(on on on on on on on on on on on off off off on on on on on on on on on on on on off on) #40(on on on on on on on on on off off off on on on on on on on on on on on on on off off on off on) #40(on on on on on on on on off off on on on on on on on on on on on on on on off off off on off off on) #40(on on on on on on on off off on on on on on on on on on on on on on on on off off on on off off off on) #40(on on on on on on off off on on on on on on on on on on on on on on off on off on on on off off off off on) #40(on on on on on on off on on on on on on on on on on on on on on off off on on on off on on on off off off on) #40(on on on on on off off on on on on on on on on on on on on on off off off on on off off on on on on off off off on) #40(on on on on on off on on on on on on on on on on on on on on off off on on off off off on on on on on off off on) #40(on on on on off off on on on on on on on on on on on on off on off on on on off off on on on on on on off off off on) #40(on on on on off on on on on on on on on on on on on off off on on on off on off on on on on on on on on off off on) #40(on on on off off on on on on on on on on on on on off off off on on off off on on on off on on on on on on off off off on) #40(on on on off off on on on on on on on on on on on off off on on off off off on on off off on on on on on on on off off on) #40(on on on off off on on on on on on on on on off on off on on on off off on on off off off on on on on on on on off off on) #40(on on on off off on on on on on on on on off off on on on off on off on on on off off on on on on on on on on off off on) #40(on on on off off on on on on on on on off off off on on off off on on on off on off on on on on on on on on on off off on) #40(on on on off off on on on on on on on off off on on off off off on on off off on on on off on on on on on on on off off on) #40(on on on off off on on on on on on on off on on on off off on on off off off on on off off on on on on on on on off off on) #40(on on on off off on on on on on on on on on off on off on on on off off on on off off off on on on on on on on off off on) #40(on on on off off on on on on on on on on off off on on on off on off on on on off off on on on on on on on on off off on) #40(on on on off off on on on on on on on off off off on on off off on on on off on off on on on on on on on on on off off on) #40(on on on on off on on on on on on on off off on on off off off on on off off on on on on on on on on on on on off off on) #40(on on on on off off on on on on on on off on on on off off on on off off off on on on on on on on on on on on off off on) #40(on on on on off off on on on on on on on on off on off on on on off off on on on on on on on on on on on on off on) #40(on on on on off off off on on on on on on off off on on on off on off on on on on on on on on on on on on off off on) #40(on on on on on off off on on on on on off off off on on off off on on on on on on on on on on on on on on off on) #40(on on on on on off off off on on on on off off on on off off off on on on on on on on on on on on on on off off on) #40(on on on on on on off off off on on on off on on on off off on on on on on on on on on on on on on on off on) #40(on on on on on on on off off off off on on on off on off on on on on on on on on on on on on on on off off on) #40(on on on on on on on on off off off on on off off on on on on on on on on on on on on on on on off off on) #40(on on on on on on on on on off off on off off off on on on on on on on on on on on on on on off off on) #40(on on on on on on on on on on off on off off on on on on on on on on on on on on on off off off on) #40(on on on on on on on on on on on on off on on on on on on on on on on on on off off off on) #40(on on on on on on on on on on on on on on off off off on on on on off off off off off on) #40(on on on on on on on on on on on on on on on on off off off off off off on) #40(on) #40(on)))) (make-problem "19990902-TUC (43)" (quote ((19 3 2 12) (19 3 1 12) (18 1 2 1 12) (18 1 2 2 12) (17 2 1 2 12) (17 2 17) (16 3 16) (16 3 16) (15 3 15) (8 3 8) (8 5 3 5 8) (8 5 2 5 8) (3 3 4 2 4 8) (1 1 3 3 1 3 8) (1 1 3 1 1 1 8) (1 3 2 8) (6 3 6) (4 5 4) (2 6 2) (6) (5) (1 5 2) (3 1 5 4) (5 3 2) (7 2 4 3) (8 1 4 1) (8 2 3 4 3) (8 4 4 4) (8 5 1 5 8) (8 5 3 5 8) (8 3 8) (15 3 15) (16 3 16) (16 3 16) (17 2 17) (12 1 2 17) (12 5 1 18) (12 2 1 19) (15 3 19) (12 3 19))) (quote ((12 3 19) (15 3 18) (13 3 1 18) (15 2 1 17) (12 1 2 17) (17 2 1 16) (16 3 16) (16 3 15) (9 3 9) (9 5 3 4 9) (9 4 3 4 9) (9 4 1 3 9) (9 3 3 4 1) (9 2 2 4 1 1) (9 4 1 1) (8 2 3 1) (6 3 6) (4 5 4) (2 6 2) (6) (6) (2 6 3) (4 5 4) (6 5 6) (3 5 8) (1 7 9) (2 6 2 2 9) (4 3 3 9) (9 4 1 4 9) (9 4 3 4 9) (9 5 2 5 9) (9 3 9) (16 2 16) (16 3 16) (17 2 17) (17 2 17) (18 1 1 12) (18 1 1 1 1 12) (19 2 1 1 12) (19 2 3 12))) (quote #40(#40(on on on on on on on on on on on on off off off off on on on off off on) #40(on on on on on on on on on on on on on on on off on on on off off off on) #40(on on on on on on on on on on on on on off off on on on off on off off on) #40(on on on on on on on on on on on on on on on off on on off on off off off on) #40(on on on on on on on on on on on on off off off off on off on on off off off on) #40(on on on on on on on on on on on on on on on on on off on on off off on off on) #40(on on on on on on on on on on on on on on on on off on on on off off off off on) #40(on on on on on on on on on on on on on on on on off on on on off off off off off on) #40(on on on on on on on on on off off off off off off off on on on off off off off off off off off off off off off on) #40(on on on on on on on on on off on on on on on off on on on off off off off off off off on on on on off on) #40(on on on on on on on on on off on on on on off on on on off off off off off off off off on on on on off on) #40(on on on on on on on on on off on on on on off on off off off off off off off off off off off on on on off on) #40(on on on on on on on on on off on on on off off off off off off off off off off off off off off on on on off on on on on off off off on off) #40(on on on on on on on on on off on on off off off off off off off off off off off off off off off off on on off on on on on off on off on off) #40(on on on on on on on on on off off off off off off off off off off off off off off off off off off off off off off on on on on off on off on off) #40(on on on on on on on on off off off off off off off off off off off off off off off off off off off off on on off off on on on off on off) #40(on on on on on on off off off off off off off off off off off off off off off off off off off off off off off on on on off off on) #40(on on on on off off off off off off off off off off off off off off off off off off off off off off off off off on on on on on off off on) #40(on on off off off off off off off off off off off off off off off off off off off off off off off off off off off off on on on on on on off off on) #40(off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off off on on on on on on off) #40(off off on on on on on on off) #40(on on off off on on on on on on off off off off off off off off off off off off off off off off off off off off off off off off off off off on) #40(on on on on off off on on on on on off off off off off off off off off off off off off off off off off off off off off off off off off on) #40(on on on on on on off off on on on on on off off off off off off off off off off off off off off off off off off off off off on) #40(off off off off off on on on off off on on on on on off off off off off off off off off off off off off off off off off on) #40(on off on on on on on on on off off off off off off off off off off off off off off off off off off off off off off on) #40(on on off on on on on on on off on on off off off off off off off off off off off off off off off off on on off on) #40(off off off off off on on on on off on on on off off off off off off off off off off off off off off on on on off on) #40(on on on on on on on on on off on on on on off off off off off off off off off off on off on on on on off on) #40(on on on on on on on on on off on on on on off off off off off off off off on on on off on on on on off on) #40(on on on on on on on on on off on on on on on off off off off off off off on on off on on on on on off on) #40(on on on on on on on on on off off off off off off off off off off off off on on on off off off off off off off on) #40(on on on on on on on on on on on on on on on on off off off off off on on off on) #40(on on on on on on on on on on on on on on on on off off off off on on on off on) #40(on on on on on on on on on on on on on on on on on off off off on on off on) #40(on on on on on on on on on on on on on on on on on off off off on on off on) #40(on on on on on on on on on on on on on on on on on on off off on off on off off off off off on) #40(on on on on on on on on on on on on on on on on on on off off on off on off on off on off on) #40(on on on on on on on on on on on on on on on on on on on off off on on off on off on off on) #40(on on on on on on on on on on on on on on on on on on on off off on on off on on on off on)))) (make-problem "19990905-ARE (44)" (quote ((1) (1) (1 17) (1 19) (1 20) (1 1 3) (1 7 3) (1 5 1 1 3) (1 1 1 1 3) (2 2 1 2 3) (2 3 1 3) (2 5 17 3) (1 5 19 3) (6 21 3) (4 23 3) (2 27) (28) (1 1) (2 23 1) (1 1) (1 2 2 2 2 2 1) (1 2 2 2 2 2 1) (1 2 2 2 2 2 1) (1 2 2 2 2 2 1) (1 2 2 2 2 2 1) (1 2 2 2 2 2 1) (1 2 2 2 2 2 1) (1 2 2 2 2 2 1) (1 2 2 2 2 2 1) (1 2 2 2 2 2 1) (1 2 2 2 2 2 1) (1 2 2 2 2 2 1) (1 1 1 1) (2 31 2) () (4 3 3 1 3 3 3 4) (2 1 1 1 1 1 1 1 1 1 2) (3 1 2 3 3 1 1 1 3) (2 1 1 1 1 1 1 1 1 2) (4 1 3 1 1 1 3 1 4))) (quote ((2 1) (1 3) (5) (3 3 1 1) (3 3 2 2 1 1) (2 4 1 1 1) (1 5 16) (2 5 3 1) (1 5 2 1) (1 4 3 1 12 1 1) (1 1 4 1 12 1 5) (2 1 5 1 1 1) (3 1 6 1 1) (6 6 1 1 5) (3 1 9 1 12 1 1 1 1) (3 1 6 1 12 1 1 1) (3 1 6 1 1) (3 1 1 6 1 1 4) (3 4 6 1 1 1 1) (3 6 1 12 1 4) (3 6 1 12 1) (3 6 1 1 5) (3 6 1 1 1 1) (3 6 1 1 3) (3 6 1 12 1) (3 6 1 12 1 5) (3 6 1 1 1 1) (3 6 1 1 5) (3 6 1 1) (3 5 1 12 1 1) (3 4 1 12 1 5) (3 3 1 1 1) (3 2 1) (12 1) (9 15 1 1) (6 1 1 1) (1 1) (5) (1 3) (2 1))) (quote #f)) (make-problem "19990916aCAR (45)" (quote ((22 8 6) (3 17 6 5) (2 17 6 4) (3 8 15 3) (11 14 3) (12 15 3) (29 4) (7 14 7 5) (6 12 7 6) (7 4 9 17) (13 26) (14 24) (3 12 23) (2 12 13 7) (3 15 11 6) (11 8 11 7) (10 8 18) (11 10 1 15) (24 1 7 4) (22 1 7 3) (24 6 2) (23 2 4 2) (31 1 1 1) (30 2 2 1 1) (5 1 4 14 8) (4 1 3 12 9) (4 2 2 2 8 10) (5 3 3 3 8 11) (6 3 4 3 5 12) (3 1 5 14) (2 2 3 2 6 15) (2 2 3 2 5 12 3) (2 2 3 2 4 3 3 2 2) (3 4 2 4 2 5) (5 6 11 8) (4 1 2 1 23) (1 1 1 3 1 1 23) (4 1 4 1 1 23) (5 1 6 1 23) (4 1 4 1 22))) (quote ((37 2) (36 3) (2 10 16 3 3) (1 8 14 3 2 3) (2 10 11 2 3 1 3) (24 1) (8 15 5) (7 15 2) (8 15 4 5 3) (24 3 5 4) (16 9 5 4) (4 10 12 3 3) (3 3 6 12 3 2 2) (4 5 14 2 3 1 3) (11 12 1) (11 12 5) (12 12 2) (13 15 4 4) (13 15 4 5) (14 11 3 6) (15 10 6 6) (1 6 7 15 6) (4 7 1 11 1 6) (1 6 10 1 8 2 6) (17 1 9 2 6) (19 7 2 7) (18 2 6 3 7) (28 3 7) (3 21 4 7) (2 18 6 6) (1 15 9 5) (5 6 11 5) (4 4 10 6) (5 4 8 7) (1 10 9 7) (2 11 8 8) (3 13 7 8) (20 10 7) (22 9 6) (24 7 6))) (quote #40(#40(on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on off on) #40(on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on off on) #40(on on off on on on on on on on on on on off on on on on on on on on on on on on on on on on off off off on on on off on) #40(on off off off on on on on on on on on off off off on on on on on on on on on on on on on on off on on on off on on off on) #40(on on off on on on on on on on on on on off on on on on on on on on on on on off off on on off on on on off on off on on on off) #40(on on on on on on on on on on on on on on on on on on on on on on on on off off off off on off) #40(on on on on on on on on off on on on on on on on on on on on on on on on off off off off off off off off off off off on) #40(on on on on on on on off off off on on on on on on on on on on on on on on on off off on on off) #40(on on on on on on on on off on on on on on on on on on on on on on on on off on on on on off on on on on on off on on on off) #40(on on on on on on on on on on on on on on on on on on on on on on on on off off on on on off on on on on on off on) #40(on on on on on on on on on on on on on on on on off on on on on on on on on on off off off off on on on on on off on) #40(on on on on off on on on on on on on on on on off off off on on on on on on on on on on on on off off off on on on off on) #40(on on on off off off on on on off on on on on on on off on on on on on on on on on on on on off on on on off on on off off on) #40(on on on on off on on on on on off on on on on on on on on on on on on on on off off on on off on on on off on off on on on off) #40(on on on on on on on on on on on off on on on on on on on on on on on on off off off off on off) #40(on on on on on on on on on on on off on on on on on on on on on on on on off off off off off off off off off off off on) #40(on on on on on on on on on on on on off on on on on on on on on on on on on off off on on off) #40(on on on on on on on on on on on on on off on on on on on on on on on on on on on on on off on on on on off on on on on off) #40(on on on on on on on on on on on on on off on on on on on on on on on on on on on on on off on on on on off on) #40(on on on on on on on on on on on on on on off on on on on on on on on on on on off off off off on on on off on) #40(on on on on on on on on on on on on on on on off on on on on on on on on on on off on on on on on on off on) #40(on off on on on on on on off on on on on on on on off on on on on on on on on on on on on on on on off off on) #40(off off off on on on on off off off on on on on on on on off on off on on on on on on on on on on on off on off on) #40(on off on on on on on on off on on on on on on on on on on off on off on on on on on on on on off on on off on) #40(on on on on on on on on on on on on on on on on on off off on off on on on on on on on on on off on on off on) #40(on on on on on on on on on on on on on on on on on on on off off on on on on on on on off off on on off on) #40(on on on on on on on on on on on on on on on on on on off on on off on on on on on on off on on on off on) #40(on on on on on on on on on on on on on on on on on on on on on on on on on on on on off on on on off on) #40(on on on off off off on on on on on on on on on on on on on on on on on on on on on off on on on on off on) #40(on on off off off off off on on on on on on on on on on on on on on on on on on off off on on on on on on off on) #40(on off off off off off off off on on on on on on on on on on on on on on on off off on on on on on on on on on off on) #40(off off off off off off off off off on on on on on off on on on on on on off off on on on on on on on on on on on off on) #40(off off off off off off off off off on on on on off off off on on on on off off on on on on on on on on on on off off on) #40(off off off off off off off off off on on on on on off on on on on off off off off off on on on on on on on on off on) #40(on off off off off off off off on on on on on on on on on on off off off off off on on on on on on on on on off on) #40(on on off off off off off on on on on on on on on on on on off off off off off on on on on on on on on off on) #40(on on on off off off on on on on on on on on on on on on on off off off off off on on on on on on on off on) #40(on on on on on on on on on on on on on on on on on on on on off off on on on on on on on on on on off on) #40(on on on on on on on on on on on on on on on on on on on on on on off off on on on on on on on on on off on) #40(on on on on on on on on on on on on on on on on on on on on on on on on off off on on on on on on on off on)))) (make-problem "19990927-BBA (46)" (quote ((2 1) (2 2) (2 3) (2 3) (2 4) (2 4) (2 2 4) (2 2 4) (3 2 2 4) (6 2 2 5) (3 3 2 2 5) (2 3 2 2 2 3) (3 2 2 2 2 3) (2 4 2 2 2 4) (2 2 5 2 2 6) (2 3 4 17) (4 2 4 9 7) (5 2 6 2 2 4) (10 8 2 2 4) (9 2 2 4 2 4) (8 2 2 5 4) (7 2 2 5 3) (7 2 2 2 14) (10 2 2 14) (4 4 2 1 3) (3 5 2 2) (4 3 4 2 2) (7 5 3) (8 8 6) (12 6 7) (10 20) (11 4 15) (14 4 8) (14 4 6) (19 6) (24) (21) (18) (14) (10))) (quote ((4) (7) (12) (3 14) (3 15) (2 15) (3 7 8) (2 6 8) (2 8 10) (2 4 13) (3 3 4 9) (2 3 4 8) (3 3 2 10) (3 3 13) (7 4 7) (5 3 7) (24 3 8) (24 12) (2 12) (19 4 7) (16 1 2 6) (4 2 2 3 7) (4 2 1 10) (21 10) (21 10) (5 2 2 3 6) (17 2 5) (15 3 6) (5 2 9) (5 2 8) (5 2 7) (6 3 7) (6 3 6) (2 3 4 5) (2 5 2 5) (2 4 6) (3 4) (2 3) (2 1) (2 1))) (quote #40(#40(off off off off off off off off off off off off off off off off on on on on off) #40(off off off off off off off off off off off off off off on on on on on on on off) #40(off off off off off off off off off off off off on on on on on on on on on on on on off) #40(off off off off off off off off off off off on on on off off on on on on on on on on on on on on on on off) #40(off off off off off off off off off off on on on off off off off on on on on on on on on on on on on on on on off) #40(off off off off off off off off off on on off off off off off off off on on on on on on on on on on on on on on on off) #40(off off off off off off off off on on on off off off off off off off on on on on on on on off on on on on on on on on off) #40(off off off off off off off off on on off off off off off off off off on on on on on on off off off on on on on on on on on off) #40(off off off off off off off off on on off off off off off off off on on on on on on on on off on on on on on on on on on on off) #40(off off off off off off off off off on on off off off off on on on on off off off off on on on on on on on on on on on on on off) #40(off off off off off off off off off on on on off off on on on off off off off off off on on on on off on on on on on on on on on off) #40(off off off off off off off off off off on on off on on on off off off off off off on on on on off off off on on on on on on on on off) #40(off off off off off off off off off off off on on on off off off off off off on on on off off on on off on on on on on on on on on on off) #40(off off off off off off off off off off off off on on on off off off off on on on off off off on on on on on on on on on on on on on off) #40(off off off off off off off off off off off off off on on on on on on on off off off off off off on on on on off on on on on on on on off) #40(off off off off off off off off off off off off off off on on on on on off off off off off off off on on on off off off on on on on on on on off) #40(on on on on on on on on on on on on on on on on on on on on on on on on off off off on on on off on on on on on on on on off) #40(on on on on on on on on on on on on on on on on on on on on on on on on off off off on on on on on on on on on on on on off) #40(off off off off off off off off off off off off off off off off off on on off off off off off off off off off on) #40(on on on on on on on on on on on on on on on on on on on off off off off off off off off off on on on on off on) #40(off on on on on on on on on on on on on on on on on off on off off off off off off off off off off on on off off off on) #40(off off on on on on off off off off off off off off off on on off on on off off off off off off off off off on on on off on) #40(off off off off on on on on off off off off off off off on on off off on off off off off off off off off off off on) #40(off off off off off off on on on on on on on on on on on on on on on on on on on on on off off off on) #40(off off off off off off on on on on on on on on on on on on on on on on on on on on on off off off on) #40(off off off off off off on on on on on off off off off on on off off off on on off off off off off off off off on on on off on) #40(off off off off off off off off on on on on on on on on on on on on on on on on on off off off off off on on off off off on) #40(off off off off off off off off off on on on on on on on on on on on on on on on off off off off off off on on on off on) #40(off off off off off off off off off off off on on on on on off off off off off off on on off off off off off off on on on on on on on on on off) #40(off off off off off off off off off off off off off on on on on on off off off off on on off off off off off off on on on on on on on on off) #40(off off off off off off off off off off off off off off on on on on on off off off on on off off off off off off on on on on on on on off) #40(off off off off off off off off off off off off off off on on on on on on off off on on on off off off off on on on on on on on off) #40(off off off off off off off off off off off off off off off on on on on on on off on on on off off off off on on on on on on off) #40(off off off off off off off off off off off off off off off on on off on on on off on on on on off off off on on on on on off) #40(off off off off off off off off off off off off off off off on on off off on on on on on off on on off on on on on on off) #40(off off off off off off off off off off off off off off off on on off off off on on on on off off on on on on on on off) #40(off off off off off off off off off off off off off off off off off off off off off on on on off off off on on on on off) #40(off off off off off off off off off off off off off off off off off off off off off off on on off off off on on on off) #40(off off off off off off off off off off off off off off off off off off off off off off on on off off off off on off) #40(off off off off off off off off off off off off off off off off off off off off off off on on off off off off on off)))) (make-problem "19991008-LLO (47)" (quote ((6 6 2) (16 1 1) (18 1 4) (5 12 6) (5 14 4) (1 4 15 2) (3 4 15 1 1) (5 4 4 1 1 2) (3 4 2 2 1 3) (2 2 5 1 9 1 1 4) (1 6 3 3 4 1) (1 4 3 2 3 1) (3 2 1 3 2 2 2 1) (5 2 1 2 1 1 2 1 1 2) (4 1 1 2 1 1 2 1 3) (5 4 2 1 2 1 2 1 4) (6 2 3 1 3 4 1) (1 3 1 5 1 1 5 3 1) (5 5 2 5 2 1) (3 2 14 1 2) (4 2 4 4 4 1 3) (8 4 4 1 4) (4 2 12 4 1) (1 3 2 10 3 1) (8 10 2 1) (3 1 2 8 1 2) (4 1 2 6 1 3) (7 1 4) (1 6 1 6 1) (3 1 3 8 1) (3 1 1 1 3 3 4) (7 3 2 2 1) (9 3 2 1 2 1 2) (4 2 2 7 4 4 1 4) (1 3 2 3 7 1 1 2 1 1 1 1) (8 3 1 1 1 1 1) (7 3 2 2 3 1 1 1 3) (8 7 5 1 1 1 1 2 1) (3 8 1 1 1 1 1 1 1) (3 6 6 9))) (quote ((1 1 5 5 5 4 2) (4 5 5 4 5 5) (4 30) (4 7 5 3 10) (1 1 1 5 1 3 3 2 4) (1 5 1 3 4 3) (7 1 6 3 7) (10 2 1 4 3 1 2 1) (13 2 1 2 1 3 2) (13 2 1 2 2 2) (5 3 2 1 1 2) (4 4 1 1 1) (3 6 7 1) (3 4 1 7 3 2) (8 2 7 5 3) (7 1 4 8 3 3 3) (6 2 2 9 2 2 2) (7 1 1 2 6 2 2 2) (7 1 1 2 2 8 2 2) (7 1 1 3 8 2 2) (7 1 1 1 3 9 3 3) (7 1 1 1 2 6 3 5) (7 1 2 2 6 2 3) (6 1 3 9 2 3) (5 2 8 2 2 1) (4 2 7 2 1 1) (2 3 7 7) (2 6 1) (8) (2) (2) (8) (2 20 1 1) (1 2 1 3 3 3 12) (1 4 3 3 3 1 1) (1 4 3 3 3 1 1 1) (4 4 3 3 2 2 3) (2 20 2 2 1) (2 1 1) (7))) (quote #f)) (make-problem "19991011-VAL (48)" (quote ((2) (2) (10) (16) (18) (18) (1 1) (3 6 3) (2 1 2 2 1 2) (1 2 4 2 1) (1 1 6 1 1) (1 6 1) (1 6 1) (1 4 1) (1 1) (3 6 3) (2 1 2 2 1 2) (1 2 4 2 1) (1 1 1 1 1 1) (1 1 1 1) (1 1 1 1) (1 4 1) (1 1) (3 6 3) (2 1 2 2 1 2) (1 2 4 2 1) (1 1 1 1 1 1) (1 1 1 1) (1 1 1 1) (1 4 1) (1 1) (1 1) (18) () () (4 5 4 4) (1 1 1 1 1 1) (4 1 1 1 4) (1 1 1 1 1) (4 1 4 1))) (quote (() () () () () () () (1 1 1) (1 1 1) (1 1 1) (1 1 1 3 1) (29 1 1 1) (3 1 1 1 1) (3 1 1 3) (3 1) (4 2 2 2 1 1) (4 2 2 2 1 1) (4 2 3 2 3 2 3 1 5) (4 1 5 1 1 1 1 1 1 1 1) (6 1 5 1 1 1 1 1 1 1 1) (6 1 5 1 1 1 1 1 1 1) (4 1 5 1 1 1 1 1 1 1 5) (4 2 3 2 3 2 3 1 1 1) (4 2 2 2 1 1 1) (4 2 2 2 1 5) (3 1) (3 1 5) (3 1 1 1) (29 1 1) (1 1 1 3) (1 1 1) (1 1 1) (1 1 1) () () () () () () ())) (quote #f)) (make-problem "19991103-BDH (49)" (quote ((12 23) (11 22) (10 21) (10 20) (9 20) (10 18) (10 11) (11 10) (12 10) (14 5 4) (14 4 4) (9 3 5 4 5) (9 1 9 4) (10 2 1 2) (11 3 7 1) (11 4 9 1) (10 5 9 1) (9 5 10) (8 7 10) (8 8 9) (8 1 5 2 9) (8 2 4 1 1 9) (8 3 4 1 2 10) (8 4 3 2 2 10) (8 5 3 2 2 10) (8 2 2 3 2 3 10) (9 2 1 5 4 10) (9 2 2 3 5 10) (10 2 2 6 10) (10 3 11 11) (11 11 11) (10 15 1 11) (8 13 1 11) (8 5 1 11) (9 3 3 2 1 11) (10 5 2 1 11) (19 2 2 11) (20 2 2 12) (21 4 13) (22 14))) (quote ((40) (40) (40) (40) (40) (40) (40) (40) (18 6 6) (4 6 4 5 4 1 5) (2 5 2 7 1 3 4) (1 4 7 4 4) (3 1 2 2 4 4) (2 1 2 1 3 5) (1 5 2 6) (1 2 3 6) (1 7 4 6) (1 1 10 4 5) (2 1 11 4 1 4) (3 1 12 4 2 3) (5 1 12 4 2 2) (5 1 2 3 4 2 1) (6 1 2 2 4 2) (6 1 2 2 4 1) (6 2 6 5 1) (6 2 2 6 2) (6 2 5 2 1) (6 2 7 6 2) (6 1 2 8 3) (7 3 11) (11 5 18) (11 26) (11 26) (11 26) (10 26) (9 1 25) (13 25) (13 24) (14 23) (40))) (quote #40(#40(on) #40(on) #40(on) #40(on) #40(on) #40(on) #40(on) #40(on) #40(on on on on on on on on on on on on on on on on on on off off off off off off off off on on on on on on off off on) #40(on on on on off on on on on on on off off on on on on off off off on on on on on off off off on on on on off on off on) #40(on on off off off off off on on on on on off off on on off off off off off on on on on on on on off off on off on on on off on) #40(on off off off off off off off on on on on off off off off off off off off off off on on on on on on on off off on on on on off on) #40(off off off off off off off off off on on on off on off off off off off off off off off on on off off off on on off on on on on off on) #40(off off off off off off off off off on on off off on off off off off off off off off off off on on off off off on off on on on off on) #40(off off off off off off off off off off off off on off off off off off off off off off off off off on on on on on off on on off on) #40(off off off off off off off off off off off on off off off off off off off off off off off off off off off on on off on on on off on) #40(off off off off off off off off off off off on off off on on on on on on on off off off off off off off off on on on on off on) #40(on off off off off off off off off off off on off on on on on on on on on on on off off off off off off on on on on off off on) #40(on on off off off off off off off off off on off off on on on on on on on on on on on off off off off on on on on off on off on) #40(on on on off off off off off off off off on off off off on on on on on on on on on on on on off off on on on on off on on off on) #40(on on on on on off off off off off off off on off off off on on on on on on on on on on on on off on on on on off off on on off on) #40(on on on on on off off off off off off off on off off off off off on on off off off off off on on on off on on on on off off off on on off on) #40(on on on on on on off off off off off off on off off off off off on on off off off off off off on on off on on on on off off off off on on off) #40(on on on on on on off off off off off off on off off off off off off on on off off off off on on off on on on on off off off off off off on off) #40(on on on on on on off off off off off on on off off off off off off off on on on on on on off on on on on on off off off off off off on off) #40(on on on on on on off off off off off on on off off off off off off off off off off on on off on on on on on on off off off off off on on off) #40(on on on on on on off off off off off on on off off off off off off off off off off off off on on on on on off off off off off off on on off on) #40(on on on on on on off off off off off on on off off off off off off off off off on on on on on on on off off on on on on on on off on) #40(on on on on on on off off off off off off on off on on off off off off off on on on on on on on on off off off off off off off off on) #40(on on on on on on on off off off off off off off on on on off off off off off off off off off off off off on) #40(on on on on on on on on on on on off off off on on on on on off off off on) #40(on on on on on on on on on on on off off off on) #40(on on on on on on on on on on on off off off on) #40(on on on on on on on on on on on off off off on) #40(on on on on on on on on on on off off off off on) #40(on on on on on on on on on off off on off off off on) #40(on on on on on on on on on on on on on off off on) #40(on on on on on on on on on on on on on off off off on) #40(on on on on on on on on on on on on on on off off off on) #40(on)))) (make-problem "19991109-TMA (50)" (quote ((35) (1 1 1 1 17) (1 4 2 1 4 20) (1 1 1 1 2 1 16 2) (1 2 1 1 2 4 2 19) (1 1 2 1 1 20) (40) (1 20) (40) (14 1 1 1 1 1 1) (14 1 1 1 2 1 2 1 2 1 4) (14 3 1 2 1 2 1 1 2) (14 3 1 2 1 2 1 1 2 4) (7 6 3 1 1 1 2 1 1) (7 32) (6 5 1) (1 1 1 1 1 26) (2 6 1 4 1 2) (1 8 1 6 1 1 1 2) (3 9 2 1 1 1 2) (4 10 4 6 3 2) (1 2 2 1 6 2 4 1 2) (1 1 1 26) (4 2) (1 26) (2 6 2 2 1 3) (3 1 11) (7 9 1 1 3 1 1 2) (7 8 1 1 2 7 3) (7 7 2 2 3 5 4) (13 1 3 3 5) (11 11 1 5) (9 4 1 1 6 5) (7 2 3 1 1 1 10 3) (5 4 2 1 6 2 2) (4 5 5 3 5 2 1) (2 3 4 1 5 3) (1 20 3) () (6 22 5))) (quote ((21 1 2 11 1) (1 1 8 1 3 1 10 1) (1 3 1 9 2 9 1) (1 1 1 1 8 2 9 1) (1 1 1 9 2 8 1) (7 8 7 1) (1 1 7 7) (1 1 3 5 3) (1 1 2 7 6) (1 1 1 8 5 1 1) (7 9 2 5 4 1) (1 1 8 2 4 4 1) (1 1 1 1 9 2 4 5 1) (1 1 1 1 8 1 3 1 3 3 1 1) (1 3 1 1 1 5 1 2 3 1 2 1) (7 1 5 13 3 3 1) (1 1 2 4 12 8 1) (1 3 1 1 5 11 2 7 1) (1 1 1 1 1 1 10 1 1 1 1 1) (1 1 1 7 1 5 1 1 1 1 1 1) (9 1 1 5 1 1 1 1) (9 3 1 1 1 1 2 1 7 1) (9 3 1 1 4 6 1 1 1 1) (9 1 7 1 1 1 1 1 1) (15 1 1 1 2 3 1 1 1) (9 1 1 1 1 1 3 10 1) (9 3 1 1 1 1 1 2 2 5 1) (9 3 1 7 1 3 1 5 1) (9 1 3 3 1 4 7 1) (15 3 3 1 1 3 6 1) (9 1 7 1 1 3 3 1) (9 1 3 1 1 1 3 3 2) (9 1 2 1 1 1 1 1 4 2) (9 1 1 1 1 1 1 1 2) (15 7 4 1) (8 1 1 1 1 3 3 1 1) (2 5 1 1 1 1 1 1 1 2 4 4 1) (6 1 1 1 1 1 1 6 3 1) (6 3 1 9 8 2 1) (20 9 1))) (quote #40(#40(on on on on on on on on on on on on on on on on on on on on on off on off on on off on on on on on on on on on on on off on) #40(on off off off off off on off on on on on on on on on off on off on on on off off off on off on on on on on on on on on on off off on) #40(on off on on on off on off on on on on on on on on on off off on on off off off off off off on on on on on on on on on off off off on) #40(on off on off on off on off on on on on on on on on off off off off on on off off off off off on on on on on on on on on off off off on) #40(on off on off off off on off on on on on on on on on on off off off off on on off off off off on on on on on on on on off off off off on) #40(on on on on on on on off on on on on on on on on off off off off off off off off off off off on on on on on on on off off off off off on) #40(on off off off off off on off on on on on on on on off off off off off off off off off off off off on on on on on on on off) #40(on off on off on on on off on on on on on off off off off off off off off off off off off off off off off off on on on off) #40(on off on off off on on off on on on on on on on off off off off off off off off off off off off on on on on on on off) #40(on off off off on off on off on on on on on on on on off off off off off off off off off off off on on on on on off off off on off off off on) #40(on on on on on on on off on on on on on on on on on off off off off on on off off off off on on on on on off off on on on on off on) #40(on off off off off off on off on on on on on on on on off off off off on on off off off off off on on on on off off off on on on on off on) #40(on off on off on off on off on on on on on on on on on off off on on off off off off off off on on on on off off on on on on on off on) #40(on off on off on off on off on on on on on on on on off on off on on on off off off on off on on on off off off on on on off on off on) #40(on off on on on off on off on off off off off off on off on on on on on off on off on on off on on on off off on off off off on on off on) #40(on on on on on on on off on off on on on on on off on on on on on on on on on on on on on off off on on on off on on on off on) #40(on off off off off off on off on on off on on on on off on on on on on on on on on on on on off off on on on on on on on on off on) #40(on off on on on off on off on off on on on on on off on on on on on on on on on on on off on on off on on on on on on on off on) #40(on off on off on off on off on off off off off off on off on on on on on on on on on on off off off on off on off off off on off on off on) #40(on off on off off off on off on on on on on on on off on off on on on on on off on off off off off off off on off on off on off on off on) #40(on on on on on on on on on off off off off off on off on off on on on on on off on off off off off off off on off off off off off on off on) #40(on on on on on on on on on off on on on off on off on off on off off off on off on on off off off on off on on on on on on on off on) #40(on on on on on on on on on off on on on off on off on off off on on on on off on on on on on on off on off off off on off on off on) #40(on on on on on on on on on off off off off off on off on on on on on on on off on off off off off off off on off on off on off on off on) #40(on on on on on on on on on on on on on on on off on off off off on off on off on on off on on on off on off off off off off on off on) #40(on on on on on on on on on off off off off off on off on off on off on off on off on on on off on on on on on on on on on on off on) #40(on on on on on on on on on off on on on off on off on off on off off off on off on off on on off on on off off on on on on on off on) #40(on on on on on on on on on off on on on off on off on on on on on on on off on off on on on off on off off on on on on on off on) #40(on on on on on on on on on off off off off off on off on on on off on on on off on off on on on on off on on on on on on on off on) #40(on on on on on on on on on on on on on on on off on on on off on on on off on off on off on on on off on on on on on on off on) #40(on on on on on on on on on off off off off off on off on on on on on on on off on off on off on on on off on on on off off off off on) #40(on on on on on on on on on off on off on on on off on off off off on off on off on on on off on on on off on on off) #40(on on on on on on on on on off on off off on on off on off on off on off on off on off on on on on off off on on off) #40(on on on on on on on on on off off off on off on off on off off off off off on off on off on off on off off off on on off) #40(on on on on on on on on on on on on on on on off on on on on on on on off on on on on off off off off off on off) #40(off on on on on on on on on off off off off off on off on off off off on off on off on on on off off off on on on off on off off off off on) #40(off on on off on on on on on off on off on off on off on off on off on off on off on on off off off on on on on off on on on on off on) #40(off off off on on on on on on off on off on off on off on off off off off off on off on off off off on on on on on on off on on on off on) #40(off off off on on on on on on off on on on off on off on on on on on on on on on off off on on on on on on on on off on on off on) #40(off off off off off on on on on on on on on on on on on on on on on on on on on off off on on on on on on on on on off off off on)))) (make-problem "19991118-CIT (51)" (quote ((24 15) (1 17 15) (1 12 3 3 10) (3 8 3 1 1 1 1 3 4) (3 9 1 2 1 1 1 1 2 1 5) (3 10 3 1 1 1 1 3 6) (3 9 1 2 1 1 1 1 2 1 5) (13 3 1 1 1 1 3 4) (1 12 3 3 10) (1 5 3) (3 7 3) (3 14 3 3 10) (1 6 1 1 1 1 3 4) (1 6 3 1 1 1 1 1 2 1 5) (13 3 1 1 1 1 1 3 6) (1 6 3 1 1 1 1 1 2 1 5) (1 6 1 1 1 1 3 4) (1 16 3 3 10) (1 9 3) (1 5 3) (1 12 3 3 10) (13 3 1 1 1 1 4) (14 1 2 1 1 1 1 1 3 4) (15 3 1 1 1 1 1 3 4) (14 1 2 1 1 1 1 1 3 4) (1 6 3 1 1 1 1 4) (1 12 3 3 10) (3 19 15) (3 35) (3 35) (3 35) (40) (1 1 4 1 1 2) (1 1 4 1 1 6) (1 2 1 10 3 2 1 3) (1 1 10 3 2 1 3) (1 1 6 3 1 6) (1 2 1 6 3 1 2) (40) (40))) (quote ((40) (1 5 2 1 4 5 2) (1 5 2 1 4 5 2) (1 1 1 2 4 1 1 3) (1 1 1 2 4 1 1 3) (1 5 2 1 2 4 5 2) (1 5 2 1 2 4 5 2) (40) (32 2) (32 2) (32 2 2) (32 2 2) (9 7 12 2 2) (3 3 1 1 1 1 3 6 2 2) (4 1 2 1 3 1 2 1 15) (5 3 1 3 1 3 16) (4 1 2 1 3 1 2 1 15) (3 3 1 1 1 1 3 14) (9 7 12 6) (2 5 6) (2 5 2) (9 7 12 2) (3 1 1 1 1 6 6) (3 3 1 1 3 1 1 3 6 6) (12) (3 3 1 1 3 1 1 3 6 2) (3 1 1 1 1 6 2) (9 7 12 2 2) (2 5 2 2) (2 5 2) (9 7 12 2) (3 3 1 1 3 1 1 14) (4 1 2 2 1 2 1 3 6 2) (5 3 3 3 1 3 6 2) (4 1 2 2 1 2 1 3 6 1 1 2) (3 3 1 1 3 1 1 6 1 1 2) (9 7 12 1 1 2) (32 4 2) (40) (40))) (quote #40(#40(on) #40(on off off on on on on on off off on on off off on off off off off off off on on on on off off on on on on on off off off off off off on) #40(on off off on on on on on off off on on off off on off off off off off off on on on on off off on on on on on off off off off off off on) #40(on off off off off off off on off off off off off off on off off on on off off on on on on off off off off off off on off off on off off on) #40(on off off off off off off on off off off off off off on off off on on off off on on on on off off off off off off on off off on off off on) #40(on off off on on on on on off off on on off off on off off on on off off on on on on off off on on on on on off off off off off off on) #40(on off off on on on on on off off on on off off on off off on on off off on on on on off off on on on on on off off off off off off on) #40(on) #40(on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on off off off off off off on) #40(on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on off off off off off off on) #40(on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on off off on on off off on) #40(on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on off off on on off off on) #40(on on on on on on on on on off off on on on on on on on off off on on on on on on on on on on on on off off on on off off on) #40(on on on off on on on off on off off on off off off off off on off off on off on on on off on on on on on on off off on on off off on) #40(on on on on off on off on on off off on off on on on off on off off on on off on off on) #40(on on on on on off on on on off off on off on on on off on off off on on on off on) #40(on on on on off on off on on off off on off on on on off on off off on on off on off on) #40(on on on off on on on off on off off on off off off off off on off off on off on on on off on) #40(on on on on on on on on on off off on on on on on on on off off on on on on on on on on on on on on off off on) #40(on on off off off off off off off off off off off off off off off off off off off off off off off off off on on on on on off off on) #40(on on off off off off off off off off off off off off off off off off off off off off off off off off off on on on on on off off off off off off on) #40(on on on on on on on on on off off on on on on on on on off off on on on on on on on on on on on on off off off off off off on) #40(on on on off off off off off on off off on off off off off off on off off on off off off off off on on on on on on off off on) #40(on on on off on on on off on off off on off on on on off on off off on off on on on off on on on on on on off off on) #40(off off off off off off off off off off off off off off off off off off off off off off off off off off off off on) #40(on on on off on on on off on off off on off on on on off on off off on off on on on off on on on on on on off off off off off off on) #40(on on on off off off off off on off off on off off off off off on off off on off off off off off on on on on on on off off off off off off on) #40(on on on on on on on on on off off on on on on on on on off off on on on on on on on on on on on on off off on on off off on) #40(on on off off off off off off off off off off off off off off off off off off off off off off off off off on on on on on off off on on off off on) #40(on on off off off off off off off off off off off off off off off off off off off off off off off off off on on on on on off off off off off off on) #40(on on on on on on on on on off off on on on on on on on off off on on on on on on on on on on on on off off off off off off on) #40(on on on off on on on off on off off on off on on on off on off off on off off off off off on) #40(on on on on off on off on on off off on on off on off on on off off on off on on on off on on on on on on off off off off off off on) #40(on on on on on off on on on off off on on on off on on on off off on off on on on off on on on on on on off off off off off off on) #40(on on on on off on off on on off off on on off on off on on off off on off on on on off on on on on on on off on off off on off on) #40(on on on off on on on off on off off on off on on on off on off off on off off off off off on on on on on on off on off off on off on) #40(on on on on on on on on on off off on on on on on on on off off on on on on on on on on on on on on off on off off on off on) #40(on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on on off on on on on off on) #40(on) #40(on)))) (make-problem "19991119aKHO (52)" (quote ((19 5 8) (11 3 3 7) (10 2 1 5 1 5 6) (9 3 2 2 1 1 2 6) (9 1 2 2 2 2 2 6) (9 2 4 2 2 2 3 7) (5 4 3 2 2 2 3 1 4) (4 4 4 2 2 2 2 2 3) (3 2 2 4 2 1 1 1 2 3 3) (3 2 3 3 1 1 1 3 4 2) (3 4 4 3 1 1 2 4 2 1) (4 4 3 2 1 2 4 4 1) (2 1 4 13 3 2 2 1) (1 5 6 3 5 1) (2 5 1 1 1 2 4 2) (2 3 1 1 3 3 1 1 5 1) (2 5 1 2 2 2 3 1) (1 5 1 1 2 2 1 2 2) (2 4 2 3 1 1 2 3) (2 5 1 1 1 1 1 2 3) (1 4 1 2 2 1 2 1 2 3) (1 3 1 1 2 1 3 2) (1 3 1 3 1 2 1 1 4 2) (4 2 2 1 1 1 5 2) (1 2 2 2 3 2 6 2) (2 1 2 2 3 2 2 2 4 2) (5 1 3 3 2 1 1 1 2 2) (6 1 1 2 3 2 2 2 2 2) (8 2 2 2 2 2 2 4 2) (7 3 3 1 1 1 5 2) (7 2 4 1 2 1 2 6 2) (8 1 3 3 2 2 2 8 2) (9 3 3 2 2 1 9 3) (9 2 1 2 3 1 9 3) (10 1 3 2 2 3 4) (13 2 1 2 3 1 5) (14 5 3 12) (22 3 11) (22 3 9) (21 1 1 1 8))) (quote ((14 4 16) (13 2 15) (12 3 14) (8 1 5 5 14) (7 1 1 2 2 14) (6 3 2 1 2 1 1 13) (6 5 2 2 2 2 12) (6 1 2 2 2 1 2 1 9) (6 1 2 1 1 2 2 2 2 8) (3 3 2 1 1 1 2 3 5 6) (2 2 3 1 1 1 2 2 2 2 5) (1 4 2 1 1 2 1 3 4 5) (1 1 3 1 2 2 2 4 5 6) (1 2 3 2 1 1 1 2 1 4 1 4) (1 4 3 4 2 1 3 2 2 3) (2 3 2 3 5 5 3) (3 3 2 2 1 1 2 2 5 4) (2 4 1 2 2 1 1 3 2 5) (1 2 5 2 6 2 4) (6 2 3 5 4) (1 6 1 1 2 2 4 5) (1 2 2 1 1 2 4 1 2) (1 6 1 1 1 2 3 4) (6 1 1 1 2 1 1) (1 2 2 1 3 4) (2 7 2 2 2 2 2 5) (4 3 2 1 1 1 1 1 1 1 2 1 1 3) (2 2 2 1 3 1 2 1) (1 3 3 3 1 1 1 3 1 1) (1 3 4 2 2 1 6 3) (1 2 4 1 1 1 8 2) (4 4 3 1 8 3) (1 3 1 3 5 2 7 4) (2 1 2 4 5 6 4) (6 15 4 4) (6 2 15 2 5) (7 7 6 6) (9 3 1 3 8) (10 1 24) (16 23))) (quote #f)) (make-problem "19991202-DAN (53)" (quote ((13) (27) (18 21) (18 21) (4 8 4 2 12 5) (4 3 2 4 2 10 5) (4 1 1 4 2 6 6) (4 5 3 6) (4 6 4 7) (4 6 4 7) (5 7 4 6) (5 2 4 3 2 2 5) (11 3 3 1 1 4) (6 2 3 2 3) (6 1 4 2 3 3) (6 5 2 1 4) (5 6 3 1 5) (4 11 4 1 1 1 6) (4 11 5 3 7) (1 4 7) (4 11) (4 12 4 7) (5 12 4 6) (5 12 4 6) (5 11 3 6) (5 11 3 5) (5 11 3 5) (5 11 2 4) (5 10 2 3) (6 10 2 3) (5 10 1 3) (5 10 3) (5 10 3) (3 5 3) (3 4 3) (3 4 3) (4 5 3) (4 4 3) (5 5 3) (5 5 3))) (quote ((15) (28) (17 20) (17 20) (2 9 20) (3 4 11 4) (4 1 4 2) (5 1 2 4) (4 3 2 8) (3 2 2 13) (5 2 2 13) (4 2 2 13 2) (3 3 3 13 4) (3 4 4 20) (11 5 20) (18 20) (18 17) (18 14) (1 12) (18) (19 10) (3 6 4 9) (4 3 3 6) (5 2 3) (5) (6 2) (6 1 1) (7 1 1) (7 5) (7 1 1) (7 1 1) (6 2) (6 2 1) (5 2 3 4) (4 5 4 7) (12 5 19) (20 19) (20 19) (20 6) (13))) (quote #40(#40(off off on on on on on on on on on on on on on on on off) #40(off off on on on on on on on on on on on on on on on on on on on on on on on on on on on on off) #40(off off on on on on on on on on on on on on on on on on on off on) #40(off off on on on on on on on on on on on on on on on on on off on) #40(off off on on off off off off off off on on on on on on on on on off on) #40(off off on on on off off off off off off off on on on on off off off off off off on on on on on on on on on on on off off off on) #40(off off on on on on off off off off off off on off off off off off off off off off off off off off off off off on on on on off off off off off on) #40(off off on on on on on off off off off off on off off off off on on off on on on on off) #40(off off on on on on off off off off off off on on on off off on on off on on on on on on on on off) #40(off off on on on off off off off off off off on on off off off on on off on on on on on on on on on on on on on off) #40(off off on on on on on off off off off on on off off off off on on off on on on on on on on on on on on on on off) #40(off off on on on on off off off off on on off off off off off on on off on on on on on on on on on on on on on off off off off off on) #40(off off on on on off off off on on on off off off off off on on on off on on on on on on on on on on on on on off off off on) #40(off on on on off off off on on on on off off off off on on on on off on) #40(off on on on on on on on on on on on off off on on on on on off on) #40(off on on on on on on on on on on on on on on on on on on off on) #40(off on on on on on on on on on on on on on on on on on on off on on on on on on on on on on on on on on on on on off) #40(off on on on on on on on on on on on on on on on on on on off on on on on on on on on on on on on on on off) #40(off on off off off off off off off off off off off off off off off off off off off on on on on on on on on on on on on off) #40(off on on on on on on on on on on on on on on on on on on off) #40(off on on on on on on on on on on on on on on on on on on on off on on on on on on on on on on off) #40(off on on on off off off on on on on on on off off off on on on on off on on on on on on on on on off) #40(off on on on on off off off on on on off off off off off off on on on off on on on on on on off) #40(off on on on on on off off off off off off off off off off off off on on off on on on off) #40(off on on on on on off) #40(off on on on on on on off off off off on on off) #40(off on on on on on on off off off off on off off off off off on off) #40(on on on on on on on off off off off off off off on off off off on off) #40(on on on on on on on off off off off off off off on on on on on off) #40(on on on on on on on off off off off off off off on off off off on off) #40(on on on on on on on off off off off on off off off off off on off) #40(on on on on on on off off off off off on on off) #40(on on on on on on off off off off off off off off off off off off on on off on off) #40(on on on on on off off off on on off off off off off off off on on on off on on on on off) #40(on on on on off off on on on on on off off off off off on on on on off on on on on on on on off) #40(on on on on on on on on on on on on off off off on on on on on off on) #40(on on on on on on on on on on on on on on on on on on on on off on) #40(on on on on on on on on on on on on on on on on on on on on off on) #40(on on on on on on on on on on on on on on on on on on on on off on on on on on on off) #40(on on on on on on on on on on on on on off)))) (make-problem "19991203-DAN (54)" (quote ((3 3 1 1 4) (1 1 1 2 1 1 1) (1 1 1 1 1 1 1 1 3) (1 1 1 1 2 1 1) (3 3 1 1 4) (5) (4 2 1 1 3 7) (1 1 1 1 1 1 1 2 6) (3 1 1 1 1 3 11) (1 4 1 1 1 1 11) (3 1 1 4 1 1 11) (6) (19 7) (6) (7) (7) (6) (7) (6) (10 6) (14 5) (16 5) (18 5) (26) (25) (25) (24) (24) (23) (24) (23) (22) (5 4 4) (5 4 4) (5 4 4) (6 4 4) (7 4 4) (8 4 4) (7 4 4) ())) (quote ((5 2 1 1 1) (1 1 1 1 1 1 2) (1 1 1 1 1 1 2) (3 1 2 1 3) (1 3) (1 1 4 1 4) (5 1 1 1 4) (1 1 1 1 1 4) (4 1 5) (5 1 6) (1 5 1 7) (1 1 1 8) (1 1 1 11) (5 5 1 11) (1 11) (5 5 1 17) (1 1 1 1 1 19) (1 1 1 1 1 20) (5 1 2 1 20) (13 2) (1 13) (1 13) (1 13) (2 13) (4 13) (5 18) (2 3 20) (6 19) (6 19) (8 11 2) (11 10) (12 8) (13 8) (22) (18) (15) (12) (7) () ())) (quote #f)))))
\ No newline at end of file
diff --git a/collects/games/paint-by-numbers/solution-sets/misc b/collects/games/paint-by-numbers/solution-sets/misc
new file mode 100644
index 0000000000..c7b72ff132
--- /dev/null
+++ b/collects/games/paint-by-numbers/solution-sets/misc
@@ -0,0 +1,61 @@
+(unit/sig
+  paint-by-numbers:problem-set^
+  (import paint-by-numbers:problem^)
+  (define set-name "Misc")
+  (define problems
+    (list (make-problem
+            "Happy Happy Joy Joy"
+            '((5)
+              (9)
+              (2 7)
+              (4 8)
+              (4 7)
+              (6 7)
+              (7 7)
+              (7 6)
+              (7 5)
+              (5 1 4)
+              (4 2 3)
+              (2 4 1)
+              (9)
+              (5))
+            '((4)
+              (8)
+              (10)
+              (12)
+              (1 8 1)
+              (2 5 2)
+              (4 3 3)
+              (5 4)
+              (7 5)
+              (8 3)
+              (9 1)
+              (10 1)
+              (10)
+              (8)
+              (4))
+            '#15(#14(off off off off off on on on on off)
+                 #14(off off off on on on on on on on on off)
+                 #14(off off on on on on on on on on on on off)
+                 #14(off on on on on on on on on on on on on off)
+                 #14(off on off on on on on on on on on off on off)
+                 #14(on on off off off on on on on on off off on)
+                 #14(on on on on off off on on on off off on)
+                 #14(on on on on on off off off off off on)
+                 #14(on on on on on on on off off on)
+                 #14(on on on on on on on on off off off on)
+                 #14(off on on on on on on on on on off off on off)
+                 #14(off on on on on on on on on on on off on off)
+                 #14(off off on on on on on on on on on on off)
+                 #14(off off off on on on on on on on on off)
+                 #14(off off off off off on on on on off)))
+          (make-problem
+            "Solver Breaker"
+            '((1) (2 2) (1) (2) (2 2) (1))
+            '((1) (2 2) (1 1) (1) (2 2) (1))
+            '#6(#6(unknown)
+                #6(unknown)
+                #6(unknown)
+                #6(unknown)
+                #6(unknown)
+                #6(unknown))))))
diff --git a/collects/games/paint-by-numbers/solve.ss b/collects/games/paint-by-numbers/solve.ss
new file mode 100644
index 0000000000..a4c874feeb
--- /dev/null
+++ b/collects/games/paint-by-numbers/solve.ss
@@ -0,0 +1,749 @@
+
+
+(module solve mzscheme
+  
+  (require (lib "list.ss")
+           (lib "etc.ss")
+           (lib "contract.ss"))
+  
+  (provide/contract [solve (-> (listof (listof integer?))  ; row-info
+                               (listof (listof integer?))  ; col-info
+                               (-> number? number? symbol? ; set-entry
+                                   void?)
+                               (-> number? void?)          ; setup-progress
+                               void)])
+  
+  ; filter! : returns a list of all elements in a-list which 
+  ; satisfy the predicate.  
+  ; destructively modifies the input list to produce the output
+  ; ((A -> boolean) (list-of A) -> (list-of A))
+            
+
+  (define (filter! fun a-list)
+    (cond
+     [(null? a-list) a-list]
+     [(fun (car a-list))
+      (let loop ([prev a-list]
+		 [a-list (cdr a-list)])
+	(cond
+	 [(null? a-list) (void)]
+	 [(fun (car a-list))
+	  (loop (cdr prev)
+		(cdr a-list))]
+	 [else (set-cdr! prev (cdr a-list))
+	       (loop prev (cdr a-list))]))
+      a-list]
+     [else (filter! fun (cdr a-list))]))
+
+  '(unless (and (equal? (filter! (lambda (x) #t) '(1 2 3))
+			 '(1 2 3))
+		 (equal? (filter! (lambda (x) (= x 1)) '(1 2 3))
+			 '(1))
+		 (equal? (filter! (lambda (x) (= x 2)) '(1 2 3))
+			 '(2))
+		 (equal? (filter! (lambda (x) (= x 3)) '(1 2 3))
+			 '(3))
+		 (equal? (filter! (lambda (x) #f) '(1 2 3))
+			 '()))
+      (error 'solve.ss "failed filter test"))
+
+  (define (solve row-info col-info set-entry setup-progress)
+    (local (
+	    (define (pause) '(sleep 1/16))
+	    
+	    ; all test cases are commented out.
+	    
+	    ; to work on large lists, we must make filter tail-recursive. 
+	    ; this one reverses.
+            
+            ; filter-rev : returns a list of all elements in a-list which 
+            ; satisfy the predicate.  If a precedes b in a-list, and both
+            ; occur in the result, then b will precede a in the result.
+            ; ((A -> boolean) (list-of A) -> (list-of A))
+            
+	    (define (filter-rev fun a-list)
+	      (foldl (lambda (elt built-list) 
+		       (if (fun elt) 
+			   (cons elt built-list)
+			   built-list))
+		     null
+		     a-list))
+	    
+	    ;(equal? (filter-rev (lambda (x)  (> x 13)) '(2 98 27 1 23 2 09))
+            ;	    '(23 27 98))
+	    
+	    
+	    ; transpose : transposes a matrix represented as a list of lists
+	    ; ((list-of (list-of T)) -> (list-of (list-of T)))
+	    
+	    (define (transpose list-list)
+	      (apply map list list-list))
+	     
+	    ;(equal? (transpose '((a b c d e)
+            ;			 (f g h i j)
+            ;			 (k l m n o)))
+            ;	    '((a f k)
+            ;         (b g l)
+            ;	      (c h m)
+            ;	      (d i n)
+            ;	      (e j o)))
+	    
+
+            ; TYPE-DECLARATIONS:
+            ; there are three kinds of cell-list: the board-row-list, the tally-list, and the try-list.
+	    ;    
+            ; (type: board-row (list-of (union 'off 'on 'unknown)))
+            ; (type: tally-row (list-of (union 'off 'on 'unknown 'maybe-off 'maybe-on 'mixed)))
+            ; (type: try-row (list-of (union 'maybe-off 'maybe-on 'unknown)))
+            (define try-row? (listof (symbols 'maybe-off 'maybe-on 'unknown)))
+            (define try-batch? (listof (union number? (listof try-row?))))
+            
+            ;    
+            ; (type: board (list-of board-row))
+            
+	    ; board-ref : returns the board element in (col,row);
+            ; (board num num -> (union 'on 'off 'unknown))
+            
+	    (define (board-ref board row col)
+              (list-ref (list-ref board row) col))
+            
+            ; board-width : returns the width of the board
+            ; (board -> num)
+            
+            (define (board-width board)
+              (length (car board)))
+            
+            ; board-height : returns the height of the board
+            ; (board -> num)
+            
+            (define (board-height board)
+              (length board))
+	    
+	    ; extract-rows : returns the board as a list of rows
+            ; (board -> board)
+            
+	    (define (extract-rows board)
+	      board)
+	    
+	    ; extract-cols : returns the board as a list of columns
+            ; (board -> board)
+            
+	    (define (extract-cols board)
+	      (transpose board))
+	    
+            ; reassemble-rows : turns a list of rows into a board
+            ; (board -> board)
+            
+	    (define (reassemble-rows board-line-list)
+	      board-line-list)
+	    
+            ; reassemble-cols : turns a list of columns into a board
+            ; (board -> board)
+            
+	    (define (reassemble-cols board-line-list)
+	      (transpose board-line-list))
+            
+            ; entirely-unknown : does this row consist entirely of 'unknown?
+            
+            (define (entirely-unknown row)
+              (andmap (lambda (x) (eq? x 'unknown)) row))
+            
+            ; finished? : does this board contain no unknown squares?
+            
+            (define (finished? board)
+              (not (ormap (lambda (row) (ormap (lambda (cell) (eq? cell 'unknown)) row)) board)))
+	    
+
+            ; threshold info : the threshold is the limit at which
+            ; memoize-tries will simply give up.  
+            
+            (define initial-threshold 2000)
+            
+            (define (next-threshold threshold)
+              (+ threshold 2000))
+            
+            
+            ; procedures to simplify the construction of test cases:
+            
+            ; condensed->long-form : takes a tree of short-form symbols and
+            ; converts them to their long form, following this mapping:
+            ; u -> unknown     |  X -> off
+            ; ? -> maybe-on    |  O -> on
+            ; ! -> maybe-off   |  * -> mixed
+            
+            (define (condensed->long-form symbol-tree)
+              (cond [(cons? symbol-tree)
+                     (cons (condensed->long-form (car symbol-tree))
+                           (condensed->long-form (cdr symbol-tree)))]
+                    [(case symbol-tree
+                       ((u) 'unknown)
+                       ((?) 'maybe-on)
+                       ((!) 'maybe-off)
+                       ((X) 'off)
+                       ((O) 'on)
+                       ((*) 'mixed)
+                       ((()) ())
+                       (else (error 'condensed->long-form "bad input: ~a" symbol-tree)))]))
+            
+            ;(equal? (condensed->long-form '(((? !) u) (* () X O)))
+            ;        '(((maybe-on maybe-off) unknown) (mixed () off on)))
+	    
+	    ; check-changed : check whether a tally-row reveals new information to be added
+            ; to the grid
+            ; (tally-row -> boolean)
+            
+	    (define (check-changed tally-list)
+	      (ormap (lambda (cell)
+		       (case cell
+			 ((off on unknown mixed) #f)
+			 ((maybe-off maybe-on) #t)
+			 (else (error "unknown element found in check-changed: ~a" cell))))
+		     tally-list))
+	    
+            ;(and (equal? (check-changed '(off off on unknown mixed)) #f)
+            ;	    (equal? (check-changed '(off on maybe-off on mixed)) #t)
+            ;       (equal? (check-changed '(off maybe-on on on unknown)) #t))
+	    
+	    ; rectify : transform a tally-row into a board row, by changing maybe-off
+            ; to off and maybe-on to on.
+	    ; (tally-row -> board-row)
+
+	    (define (rectify tally-list)
+	      (map (lambda (cell)
+		     (case cell
+		       ((off on unknown) cell)
+		       ((maybe-off) 'off)
+		       ((maybe-on) 'on)
+		       ((mixed) 'unknown)
+		       (else (error "unknown element in rectified row"))))
+		   tally-list))
+	    
+	    ;(equal? (rectify '(off on maybe-on mixed unknown maybe-off))
+            ;	    '(off on on unknown unknown off))
+	    
+	    ; make-row-formulator:
+	    ; given a set of block lengths, create a function which accepts a 
+	    ; set of pads and formulates a try-row:
+	    ; (num-list -> (num-list num -> (list-of (union 'maybe-off 'maybe-on 'unknown))))
+	    
+	    (define (make-row-formulator blocks)
+	      (lambda (pads)
+                (apply append       
+                       (let loop ([pads pads]
+                                  [blocks blocks])
+                         (cond [(null? (cdr pads)) 
+                                (if (null? blocks)
+                                    (list (build-list (car pads) (lambda (x) 'maybe-off)))
+                                    (list (cons 'maybe-off (build-list (apply + -1 (car pads) blocks) (lambda (x) 'unknown)))))]
+                               [else 
+                                (cons (build-list (car pads) (lambda (x) 'maybe-off))
+                                      (cons (build-list (car blocks) (lambda (x) 'maybe-on))
+                                            (loop (cdr pads) (cdr blocks))))])))))
+	    
+            #|
+	    (equal? ((make-row-formulator '(3 1 1 5)) '(1 2 1 3 3))
+		    '(maybe-off maybe-on maybe-on maybe-on maybe-off maybe-off maybe-on maybe-off maybe-on 
+				maybe-off maybe-off maybe-off maybe-on maybe-on maybe-on maybe-on maybe-on
+				maybe-off maybe-off maybe-off))
+            
+            (equal? ((make-row-formulator '(3 1 1 5)) '(2 4 4))
+                    '(maybe-off maybe-off
+                      maybe-on maybe-on maybe-on
+                      maybe-off maybe-off maybe-off maybe-off
+                      maybe-on
+                      unknown unknown unknown unknown unknown unknown unknown unknown unknown unknown))
+	    |#
+	    
+	    #| check-try : 
+	    see whether a try fits with the existing row information (curried)
+	    (tally-row -> (try-row -> boolean))
+	    |#
+	    
+	    (define (check-try tally-list)
+	      (lambda (try-list)
+		(andmap (lambda (tally try)
+                          (or (eq? try 'unknown)
+                              (case tally
+                                ((off) (eq? try 'maybe-off))
+                                ((on) (eq? try 'maybe-on))
+                                (else #t))))
+			tally-list
+			try-list)))
+	    
+	    #|
+	    (equal? ((check-try '(unknown off on unknown unknown unknown))
+		     '(maybe-on maybe-on maybe-on maybe-off maybe-off maybe-off))
+		    #f)
+	    
+	    (equal? ((check-try '(unknown off on unknown unknown unknown))
+		     '(maybe-off maybe-off maybe-on maybe-on maybe-on maybe-off))
+		    #t)
+            
+            (equal? ((check-try '(unknown off on unknown unknown unknown))
+                     '(unknown unknown unknown unknown unknown unknown))
+                    #t)
+	    |#
+	    
+            #| choose : like math.  as in, "9 choose 3"
+            (num num -> num)
+            |#
+            
+            (define (factorial a)
+              (if (<= a 1)
+                  1
+                  (* a (factorial (- a 1)))))
+            
+            (define (choose a b)
+              (if (> b a)
+                  (error 'choose "(choose ~v ~v): ~v is greater than ~v" a b b a)
+                  (let ([b (max b (- a b))])
+                    (/ (let loop ([x a])
+                         (if (= x (- a b))
+                             1
+                             (* x (loop (- x 1))))) 
+                       (factorial b)))))
+            
+            #|
+            (and
+             (= (choose 0 0) 1)
+             (= (choose 10 10) 1)
+             (= (choose 10 1) 10)
+             (= (choose 10 2) 45)
+             (= (choose 10 8) 45))
+            |#
+            
+            #| initial-num-possibilities :
+            given a list of block lengths, calculate the number of ways they could fit
+            into a row of the given length.  The easiest way to model this is to imagine
+            inserting blocks at given locations in a fixed set of spaces
+            
+            (listof num) num -> num
+            
+            |#
+            
+            (define (initial-num-possibilities blocks size)
+              (choose (+ 1 (- size (apply + blocks))) (length blocks)))
+
+            #|
+            (= (initial-num-possibilities '(2 3 3 4) 40) 
+               (choose 29 4))
+            |#
+            
+	    #| build-possibles:
+	    builds a list of the possible rows.  given a number of spaces, and a number
+	    of bins to put the spaces in, and a row-formulator, and a line-checker predicate,
+	    build-possibles makes a list of every possible row which passes the predicate.
+            If the number of possibilities grows larger than the threshold, the search is
+            aborted.
+	    
+	    (num num ((list-of num) -> try-row) (try-row -> bool) num -> (union (list-of try-row) #f))
+	    |#
+	    
+	    (define (build-possibles things total-bins row-formulator line-checker threshold)
+              (let/ec escape
+                (let* ([built-list null]
+                       [list-length 0]
+                       [add-to-built-list
+                        (lambda (new) 
+                          (if (= list-length threshold)
+                              (escape #f)
+                              (begin (set! built-list (cons new built-list))
+                                     (set! list-length (+ list-length 1)))))])
+                  (let tree-traverse ([things things]
+                                      [bins total-bins]
+                                      [so-far-rev null])
+                    (let* ([this-try-rev (cons things so-far-rev)]
+                           [formulated (row-formulator (reverse this-try-rev))])
+                      ;(when (= debug-counter 0)
+                      ;  (printf "~v\n~v\n" formulated (line-checker formulated)))
+                      (when (or (= bins total-bins) (line-checker formulated))
+                        (if (= bins 1)
+                            (add-to-built-list formulated)
+                            (let try-loop ([in-this-bin (if (= bins total-bins)
+                                                            0
+                                                            1)])
+                              (unless (> (+ in-this-bin (- bins 2)) things)
+                                (tree-traverse (- things in-this-bin)
+                                               (- bins 1)
+                                               (cons in-this-bin so-far-rev))
+                                (try-loop (+ in-this-bin 1))))))))
+                  built-list)))
+                      
+	    
+	   #| 
+	    ;build-possibles test case
+             (let* ([row-formulator-one (make-row-formulator '(2))]
+                    [line-checker (check-try '(unknown unknown unknown on unknown unknown))]
+                    [test-one (build-possibles 4 2 row-formulator-one line-checker 10000)]
+                    [row-formulator-two (make-row-formulator '(1 1))]
+                    [test-two (build-possibles 4 3 row-formulator-two line-checker 10000)])
+               (and 
+                (equal? test-one
+                        '((maybe-off maybe-off maybe-off maybe-on maybe-on maybe-off)
+                          (maybe-off maybe-off maybe-on maybe-on maybe-off maybe-off)))
+                (equal? test-two
+                        '((maybe-off maybe-off maybe-off maybe-on maybe-off maybe-on)
+                          (maybe-off maybe-on maybe-off maybe-on maybe-off maybe-off)
+                          (maybe-on maybe-off maybe-off maybe-on maybe-off maybe-off)))))
+	    |#
+	    
+	    #| spare-spaces:
+	    calculates the number of spare spaces in a line. In other words,
+	    line-length - sum-of-all-blocks
+	    
+	    ((list-of num) num -> num)
+	    |#
+	    
+	    (define (spare-spaces block-list line-length)
+	      (let* ([black-spaces (apply + block-list)]
+		     [spare-spaces (- line-length black-spaces)])
+		spare-spaces))
+	    
+	    ; first-pass:
+	    ; generates the information about row contents which can be inferred directly
+	    ; from the block info and nothing else (i.e., uses no information from an existing
+	    ; board.  
+	    ; ((list-of (list-of num)) num -> (list-of (list-of (union 'on 'unknown))))
+	    
+	    (define (first-pass info-list line-length)
+	      (let ((row-pass
+		     (lambda (block-list)
+		       (let* ([spares (- (spare-spaces block-list line-length) (max 0 (- (length block-list) 1)))]
+			      [shortened-blocks
+			       (map (lambda (block-length) (- block-length spares))
+				    block-list)]
+			      [all-but-start
+			       (foldr append null
+				      (let build-row-loop ([blocks-left shortened-blocks])
+					(if (null? blocks-left)
+					    null
+					    (let ([extra-pad (if (null? (cdr blocks-left)) 0 1)])
+					      (if (> (car blocks-left) 0)
+						  (cons (build-list (car blocks-left) (lambda (x) 'on))
+							(cons (build-list (+ spares extra-pad) (lambda (x) 'unknown))
+							      (build-row-loop (cdr blocks-left))))
+						  (cons (build-list (+ spares extra-pad (car blocks-left))
+								    (lambda (x) 'unknown))
+							(build-row-loop (cdr blocks-left))))))))]
+			      [whole-row (append (build-list spares (lambda (x) 'unknown))
+						 all-but-start)])
+			 whole-row))))
+		(map row-pass info-list)))
+	    
+	    #|
+	    (let ([test-result (first-pass '((4 3) (5 1)) 10)])
+	      (equal? test-result '((unknown unknown on on unknown unknown unknown on unknown unknown)
+				    (unknown unknown unknown on on unknown unknown unknown unknown unknown))))
+	    |#
+	    
+	    #| unify-passes:
+	    unify the result of running first-pass on both the rows and the columns
+	    (let ([BOARD (list-of (list-of (union 'unknown 'on)))])
+	      (BOARD BOARD -> BOARD))
+	    |#
+	    
+	    (define (unify-passes board-a board-b)
+	      (let ([unify-rows
+		     (lambda (row-a row-b)
+		       (map (lambda (cell-a cell-b)
+			      (case cell-a
+				((on) 'on)
+				(else cell-b)))
+			    row-a row-b))])
+		(map unify-rows board-a board-b)))
+	    
+	    #|
+	    (let* ([board-a '((unknown unknown on) (on unknown unknown))]
+		   [board-b '((unknown on unknown) (on on unknown))]
+		   [test-result (unify-passes board-a board-b)])
+	      (equal? test-result '((unknown on on) (on on unknown))))
+	    |#
+	    
+	    #| whole-first-pass:
+	    take a set of row descriptions and the board dimensions and generate the 
+	    merged first-pass info
+	    ((list-of (list-of num)) (list-of (list-of num)) num num -> 
+	     (list-of board-row))
+	    |#
+	    
+	    (define (whole-first-pass row-info col-info width height)
+	      (unify-passes (first-pass row-info width)
+			    (transpose (first-pass col-info height))))
+	    
+	    #| memoize-tries:
+	    given the black block widths and the line length and some initial board
+	    and a progress-bar updater, calculate all possibilities for each row.
+            If skip-unknowns is #t, rows whose content is entirely unknown will be 
+            skipped, and #f returned for that row.
+	    effect: updates the progress bar
+	    ((list-of (list-of num)) num (list-of board-row) (-> void) boolean -> (union (list-of try-row) #f))
+	    |#
+	    
+	    (define (memoize-tries info-list line-length board-rows old-tries threshold)
+              (let* ([unmemoized (filter number? old-tries)])
+                (if (null? unmemoized)
+                    old-tries
+                    (let* ([least-difficult
+                            (apply min unmemoized)])
+                      ;(fprintf (current-error-port) "guessed tries: ~v\n" least-difficult)
+                      (map (lambda (old-try-set block-list board-row)
+                             (cond [(and (number? old-try-set) (= old-try-set least-difficult))
+                                    (let ([spaces (spare-spaces block-list line-length)]
+                                                        [bins (+ (length block-list) 1)]
+                                                        [row-formulator (make-row-formulator block-list)]
+                                                        [line-checker (check-try board-row)])
+                                                    (or (build-possibles spaces bins row-formulator line-checker threshold)
+                                                        (* 2 old-try-set)))]
+                                   [else old-try-set]))
+                           old-tries
+                           info-list
+                           board-rows)))))
+	    
+	    #|
+	    (equal? (memoize-tries '((4) (1 3)) 
+				   6 
+				   '((unknown on unknown unknown unknown unknown)
+				     (unknown off unknown unknown unknown unknown))
+				   void)
+		    '(((maybe-on maybe-on maybe-on maybe-on maybe-off maybe-off)
+		       (maybe-off maybe-on maybe-on maybe-on maybe-on maybe-off))
+		      ((maybe-on maybe-off maybe-on maybe-on maybe-on maybe-off)
+		       (maybe-on maybe-off maybe-off maybe-on maybe-on maybe-on))))
+	    |#
+	    
+	    #| batch-try: 
+	    take a board-line list and a list of possibles, and trim it down by 
+	    checking each try-list against the appropriate board-line
+	    
+	    ((list-of board-row) (list-of (union (list-of try-row) #f)) -> (list-of (union (list-of try-row) #f)))
+	    |#
+	    
+	    (define (batch-try board-line-list try-list-list-list)
+	      (map (lambda (line try-list-list)
+                     (if (not (number? try-list-list))
+                         (filter! ; filter-rev
+                          (let ([f (check-try line)])
+                            (lambda (try-list) (f try-list)))
+                          try-list-list)
+                         try-list-list))
+		   board-line-list
+		   try-list-list-list))
+	    
+	    #|
+	    (equal? (batch-try '((unknown unknown unknown off)
+				 (unknown on unknown unknown))
+			       '(((maybe-on maybe-on maybe-on maybe-off)
+				  (maybe-off maybe-on maybe-on maybe-on))
+				 ((maybe-on maybe-on maybe-off maybe-off)
+				  (maybe-off maybe-on maybe-on maybe-off)
+				  (maybe-off maybe-off maybe-on maybe-on))))
+		    '(((maybe-on maybe-on maybe-on maybe-off))
+		      ((maybe-off maybe-on maybe-on maybe-off)
+		       (maybe-on maybe-on maybe-off maybe-off))))
+	    |#
+	    
+	    ; tabulate-try : take one possibility, and merge it with the row possibles
+	    ; (tally-list try-list) -> tally-list
+	    
+	    (define (tabulate-try tally-list try-list)
+	      (map (lambda (tally try)
+		     (case tally
+		       ((off on mixed) tally)
+		       ((unknown) try)
+		       ((maybe-off maybe-on) (if (eq? try tally)
+						 try
+						 'mixed))
+		       (else (error "unknown cell type during tabulate-try: ~a" tally))))
+		   tally-list
+		   try-list))
+	    
+	    
+	    #|
+	    (equal? (tabulate-try '(on off maybe-off maybe-off maybe-on maybe-on maybe-on)
+				  '(on off mixed maybe-on maybe-on mixed maybe-off))
+		    '(on off mixed mixed maybe-on mixed mixed))
+	     |#
+	    
+	    ; batch-tabulate : take a board-line-list and a list of sets of tries which check with the board
+	    ;  and tabulate them all to produce a new board line list (before rectification)
+	    ; (board-line-list try-list-list-opt-list) -> tally-list
+	    (define (batch-tabulate board-line-list try-list-list-opt-list)
+	      (map (lambda (board-line try-list-list-opt)
+                     (if (not (number? try-list-list-opt))
+                         (foldl (lambda (x y) (tabulate-try y x)) board-line try-list-list-opt)
+                         board-line))
+		   board-line-list
+		   try-list-list-opt-list))
+	    
+	    
+	    ;  (equal? (batch-tabulate '((unknown unknown unknown off)
+	    ;			    (unknown unknown on unknown))
+	    ;			  '(((maybe-on maybe-on maybe-off maybe-off)
+	    ;			     (maybe-off maybe-on maybe-on maybe-off))
+	    ;			    ((maybe-off maybe-on maybe-on maybe-off)
+	    ;			     (maybe-off maybe-off maybe-on maybe-on))))
+	    ;	  '((mixed maybe-on mixed off)
+	    ;	    (maybe-off mixed on mixed)))
+	    
+	    (define (print-board board)
+	      (for-each (lambda (row)
+			  (for-each (lambda (cell)
+				      (printf (case cell
+						((off) " ")
+						((unknown) ".")
+						((on) "#"))))
+				    row)
+			  (printf "~n"))
+			(extract-rows board)))
+	    
+	    ; animate-changes takes a board and draws it on the main screen
+	    (define (animate-changes board draw-thunk outer-size inner-size)
+	      (let outer-loop ([outer-index 0])
+		(if (= outer-index outer-size)
+		    null
+		    (let inner-loop ([inner-index 0])
+		      (if (= inner-index inner-size)
+			  (begin
+			    (pause)
+			    (outer-loop (+ outer-index 1)))
+			  (begin
+			    (draw-thunk board outer-index inner-index)
+			    (inner-loop (+ inner-index 1))))))))
+	    
+	    (define (draw-rows-thunk board row col)
+	      (set-entry col row (board-ref board row col)))
+	    
+	    (define (draw-cols-thunk board col row)
+	      (set-entry col row (board-ref board row col)))
+	    
+	    ;  (print-board '((on on unknown off)
+	    ;		 (on on unknown unknown)
+	    ;		 (unknown unknown on on)
+	    ;		 (off unknown on on)))
+	    
+	    ; do-lines takes a board-line-list and a try-list-list-list and returns two things: a tally-list-list
+	    ; and a new try-list-list-list
+	    ; (board-line-list try-list-list-opt-list) -> (tally-list-list try-list-list-opt-list)
+	    (define do-lines 
+              (contract
+               (->* (any/c try-batch?)
+                    ((listof (listof any/c))  try-batch?))
+               (lambda (board-line-list try-list-list-opt-list)
+                 (let ([new-tries (batch-try board-line-list try-list-list-opt-list)])
+                   (values (batch-tabulate board-line-list new-tries)
+                           new-tries)))
+               'do-lines
+               'caller))
+	    
+	    ; full-set takes a board and a pair of try-list-list-lists and returns a new board, a new pair
+	    ; of try-list-list-lists, and a boolean (whether it's changed)
+	    (define full-set
+              (contract
+               (->* (any/c try-batch? try-batch?)
+                    (any/c try-batch? try-batch? boolean?))
+               (lambda (board row-try-list-list-opt-list col-try-list-list-opt-list)
+                 (let*-values ([(board-rows new-row-tries)
+                                (do-lines (extract-rows board) row-try-list-list-opt-list)]
+                               [(row-changed)
+                                (ormap check-changed board-rows)]
+                               [(new-board)
+                                (reassemble-rows (map rectify board-rows))]
+                               [( _ )
+                                (if row-changed
+                                    (animate-changes new-board draw-rows-thunk 
+                                                     (board-height new-board)
+                                                     (board-width new-board)))]
+                               [(board-cols new-col-tries)
+                                (do-lines (extract-cols new-board) col-try-list-list-opt-list)]
+                               [(col-changed)
+                                (ormap check-changed board-cols)]
+                               [(final-board)
+                                (reassemble-cols (map rectify board-cols))]
+                               [( _ )
+                                (if col-changed
+                                    (animate-changes final-board draw-cols-thunk
+                                                     (board-width final-board)
+                                                     (board-height final-board)))])
+                   (values final-board new-row-tries new-col-tries (or row-changed col-changed))))
+              'full-set
+              'caller))
+	    
+            ; on 2002-10-17, I wrapped another layer of looping around the inner loop.
+            ; the purpose of this outer loop is to allow the solver to ignore rows (or
+            ; columns) about which the solver knows nothing for as long as possible.
+            
+	    (define (local-solve row-info col-info)
+	      (let* ([rows (length row-info)]
+		     [cols (length col-info)]
+		     [initial-board (whole-first-pass row-info col-info cols rows)]
+                     [_ (animate-changes initial-board draw-cols-thunk
+                                         (board-width initial-board)
+                                         (board-height initial-board))])
+                (let outer-loop ([outer-board initial-board]
+                                 [skip-threshold initial-threshold]
+                                 [old-row-tries (map (lambda (info)
+                                                       (initial-num-possibilities info (board-width initial-board))) 
+                                                     row-info)]
+                                 [old-col-tries (map (lambda (info)
+                                                       (initial-num-possibilities info (board-height initial-board))) 
+                                                     col-info)])
+                  (let* ([row-try-list-list-opt-list (memoize-tries row-info cols outer-board old-row-tries skip-threshold)]
+                         [col-try-list-list-opt-list (memoize-tries col-info rows (transpose outer-board) old-col-tries skip-threshold)])
+                    (let loop ([board outer-board] 
+                               [row-tries row-try-list-list-opt-list]
+                               [col-tries col-try-list-list-opt-list]
+                               [changed #t])
+                      (if changed
+                          (call-with-values (lambda () (full-set board row-tries col-tries))
+                                            loop)
+                          (if (finished? board)
+                              board
+                              (if (equal? outer-board board)
+                                  (outer-loop board (next-threshold skip-threshold) row-tries col-tries)
+                                  (outer-loop board skip-threshold row-tries col-tries)))))))))
+
+	    )
+      (local-solve row-info col-info)
+      )))
+
+
+; test case:
+
+;(require solve)
+;
+;(let* ([test-board (build-vector 20 (lambda (x) (make-vector 20 'bad-value)))]
+;       [set-board! (lambda (col row val)
+;                     (vector-set! (vector-ref test-board row) col val))])
+;  (solve `((9 9) (6 10) (5 11) (4 3 5) (2 1 3) (2 4 2) (1 3 6) (5 1 1 1) (2 2 1 3 1) (7 4 1) (7 4 2) (1 3 9) (1 2 4 6) (1 6 9) (1 4 7) (2 1 4 2) (5 3 4) (5 7) (5 10) (5 11))
+;         `((1 8) (2 4 4) (4 1 2 4) (8 2 4) (6 1 3 7) (4 8 4) (3 7 1) (1 2) (1 2) (2 2 2 1) (3 2 1 1 1 2) (7 8 2) (3 7 4 2) (3 1 1 2 3 3) (3 4 6 3) (4 1 4 3) (4 1 4 4) (5 1 4 4) (7 4 5) (7 6 5))
+;         set-board!
+;         (lambda (x) (void)))
+;  (equal? (map (lambda (row) 
+;                 (apply string-append
+;                        (map (lambda (x)
+;                               (case x
+;                                 [(off) " "]
+;                                 [(on) "x"])) 
+;                             row)))
+;               (apply map list (map vector->list (vector->list test-board))))
+;          
+;          `("x       xxxxxxxx    "
+;           "xx     xxxx    xxxx "
+;           "xxxx   x xx     xxxx"
+;           "xxxxxxxx xx     xxxx"
+;           "xxxxxx x xxx xxxxxxx"
+;           "xxxx   xxxxxxxx xxxx"
+;           "xxx     xxxxxxx    x"
+;           "x            xx     "
+;           "x           xx      "
+;           "  xx    xx  xx     x"
+;           " xxx  xx x  x   x xx"
+;           "xxxxxxx  xxxxxxxx xx"
+;           "xxx  xxxxxxx xxxx xx"
+;           "xxx  x  x xx xxx xxx"
+;           "xxx  xxxx xxxxxx xxx"
+;           "xxxx  x    xxxx  xxx"
+;           "xxxx  x    xxxx xxxx"
+;           "xxxxx x    xxxx xxxx"
+;           "xxxxxxx   xxxx xxxxx"
+;           "xxxxxxx xxxxxx xxxxx")))
diff --git a/collects/games/parcheesi/admin-gui.ss b/collects/games/parcheesi/admin-gui.ss
new file mode 100644
index 0000000000..ec754cb313
--- /dev/null
+++ b/collects/games/parcheesi/admin-gui.ss
@@ -0,0 +1,800 @@
+#|
+
+When playing and it's a user's turn, the history has an extra step at the end that 
+corresponds to the unplayed move! that's confusing.
+
+|#
+
+(module admin-gui mzscheme
+  (require "gui.ss"
+           "die.ss"
+           "interfaces.ss"
+           "admin.ss"
+           "board.ss"
+	   "moves.ss"
+           "rules.ss"
+           "best-players.ss"
+	   "../show-help.ss"
+           (lib "framework.ss" "framework")
+           (lib "class.ss")
+           (lib "list.ss")
+           (lib "mred.ss" "mred"))
+  
+  (provide gui-game%)
+  
+  ;; move-candidate = (make-move-candidate coordinate move (listof number))
+  (define-struct move-candidate (move dice) (make-inspector))
+  
+  (define-struct past (board color roll) (make-inspector))
+  (print-struct #t)
+  
+  (define gui-game%
+    (class* object% (game<%>)
+      
+      (define the-game (new game%))
+      (define/public (register o) (send the-game register o))
+      (define/public (start) (send the-game start))
+      (define game-observer
+        (new
+         (class* object% (game-observer<%>)
+           (define/public (introduce . x) (void))
+           (define/public (taking-turn color roll)
+             (queue-callback
+              (lambda ()
+                (set-cdr! (assq color latest-dice) roll)
+                (set! history (append history (list (make-past partial-history color roll))))
+                (update-players-dice color roll))))
+           (define/public (took-turn color board) 
+             (queue-callback
+              (lambda ()
+                (set! partial-history board)
+                (send board-pasteboard set-board board))))
+           (define/public (game-over winner-name color)
+             (queue-callback
+              (lambda ()
+                (if winner-name
+                    (set-bottom-message (format "~a (~s) won!" winner-name color))
+                    (set-bottom-message "everone cheated")))))
+           (super-new))))
+      (send the-game set-observer game-observer)
+      
+      (define gui-player%
+        (class* object% (player<%>)
+          (define color #f)
+          (define/public (start-game _color)
+            (set! color _color)
+            "Human")
+          (define/public (do-move board roll)
+            (let ([chan (make-channel)])
+              (queue-callback
+               (lambda ()
+                 (enable-gui board roll color chan)))
+              (channel-get chan)))
+          (define/public (doubles-penalty) 
+            (let ([sema (make-semaphore 0)])
+              (queue-callback
+               (lambda ()
+                 (message-box "Parcheesi" 
+                              (format 
+                               "~a rolled doubles 3 times, so the front-most piece goes back to the start."
+                               color))
+                 (semaphore-post sema)))
+              (semaphore-wait sema)))
+          (super-new)))
+      
+      (define board-pasteboard (new board-pasteboard% (admin-gui this)))
+      
+      ;; history : (listof past)
+      (define history '())
+      ;; partial-history : board
+      ;; temporary holding variable until a move is complete and history can be updated.
+      (define partial-history (new-board))
+      
+      (define frame (new board-frame% (label "Parcheesi") (style '(metal)) (board-pasteboard board-pasteboard)))
+      (define main-hp (new horizontal-panel% (parent frame)))
+      (define bottom-panel (new horizontal-panel% 
+                                (parent frame)
+                                (stretchable-height #f)))
+      (define bottom-msg (new message% (parent bottom-panel) (stretchable-width #t) (label "")))
+      (define left-vp (new vertical-panel% (parent main-hp) (stretchable-width #f)))
+      (define board-ec (new editor-canvas% 
+                            (style '(no-hscroll no-vscroll))
+                            (parent main-hp)
+                            (editor board-pasteboard)
+                            (min-height 400)
+                            (min-width 400)))
+      (define right-vp (new vertical-panel% (parent main-hp) (stretchable-width #f)))
+      
+      (define blue-player-panel (new vertical-panel% 
+                                     (alignment '(center top))
+                                     (parent left-vp)
+                                     (stretchable-height #f)))
+      (new horizontal-panel% (parent left-vp))
+      (define yellow-player-panel (new vertical-panel% 
+                                       (alignment '(center bottom))
+                                       (parent left-vp)
+                                       (stretchable-height #f)))
+      (define red-player-panel (new vertical-panel% 
+                                    (alignment '(center top))
+                                    (parent right-vp)
+                                    (stretchable-height #f)))
+      (new horizontal-panel% (parent right-vp))
+      (define green-player-panel (new vertical-panel% 
+                                      (alignment '(center bottom))
+                                      (parent right-vp)
+                                      (stretchable-height #f)))
+      
+      (define dice '())
+      
+      (define/private (make-dice color parent)
+        (let* ([p (new horizontal-panel% (parent parent) (stretchable-height #f))]
+               [die-objects (list (new die% (parent p) (dim? #t))
+                                  (new die% (parent p) (dim? #t))
+                                  (new die% (parent p) (dim? #t))
+                                  (new die% (parent p) (dim? #t)))]
+               [dice-in-order
+                (case color
+                  [(yellow blue) (reverse die-objects)]
+                  [else die-objects])])
+          (set! dice (cons (list color dice-in-order) dice))))
+      
+      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;
+      ;;  controlling the players
+      ;;
+      
+      (define/private (add-gui-player-controls color parent-panel)
+        (let* ([accept-move-button (new button%
+                                        (label "Done")
+                                        (parent parent-panel)
+                                        (callback (lambda (x y) (accept-move))))]
+               [reset-move-button (new button%
+                                       (label "Reset")
+                                       (parent parent-panel)
+                                       (callback (lambda (x y) (reset-button-callback))))]
+               [bp-panel (new horizontal-panel% 
+                              (parent parent-panel)
+                              (stretchable-height #f)
+                              (stretchable-width #f))])
+          (send accept-move-button enable #f)
+          (send reset-move-button enable #f)
+          (make-dice color parent-panel)
+          (set! gui-player-accept-move-buttons
+                (cons (cons color accept-move-button) gui-player-accept-move-buttons))
+          (set! gui-player-reset-move-buttons
+                (cons (cons color reset-move-button) gui-player-reset-move-buttons))))
+      
+      (define gui-player-accept-move-buttons '())
+      (define gui-player-reset-move-buttons '())
+      
+      (define/private (go-back)
+        (reset-move)
+        (set! viewing-index 
+              (cond
+                [(eq? viewing-index 'latest) (- (length history) 1)]
+                [(and this-move-color (zero? viewing-index)) 'latest]  ;; only go to latest when its time to show a move
+                [(zero? viewing-index) (- (length history) 1)]
+                [else (- viewing-index 1)]))
+        (update-gui))
+      (define/private (go-forw)
+        (reset-move)
+        (set! viewing-index (cond
+                              [(eq? viewing-index 'latest) 0]
+                              [(and this-move-color (= viewing-index (- (length history) 1)))
+                               'latest]
+                              [(= viewing-index (- (length history) 1))
+                               0]
+                              [else (+ viewing-index 1)]))
+        (update-gui))
+      
+      (define/private (reset-button-callback)
+        (reset-move)
+        (update-gui))
+      
+      (define/private (reset-move)
+        (set! current-moves '())
+        (set! current-board start-board)
+        (set! current-dice start-dice)
+        (set! dice-used '()))
+      
+      (define/private (accept-move)
+        (update-players-dice this-move-color start-dice)
+        (for-each (lambda (die) (send die set-dim #t))
+                  (cadr (assq this-move-color dice)))
+        (let ([accept (cdr (assq this-move-color gui-player-accept-move-buttons))]
+              [reset (cdr (assq this-move-color gui-player-reset-move-buttons))])
+          (send reset enable #f)
+          (send accept enable #f))
+        (channel-put answer-chan current-moves))
+      
+      (define current-moves '())
+      (define answer-chan #f)
+      (define start-board #f)
+      (define current-board #f)
+      (define start-dice #f)
+      (define current-dice '())
+      (define dice-used '())
+      (define this-move-color #f)
+      (define viewing-index 'latest)
+      (define latest-dice '((green . '())
+                            (red . '())
+                            (blue . '())
+                            (yellow . '())))
+      
+      (define/private (enable-gui board roll color _answer-chan)
+        (set! current-board board)
+        (set! start-board board)
+        (set! current-dice roll)
+        (set! start-dice roll)
+        (set! dice-used '())
+        (set! this-move-color color)
+        (set! answer-chan _answer-chan)
+        (set! current-moves '())
+        (set-bottom-message "")
+        (update-gui))
+      
+      (define/public (build-new-board/register-move mc)
+        (let ([new-move (move-candidate-move mc)])
+          (with-handlers ([exn:bad-move? 
+                           (lambda (x) 
+                             ;; call this first, since it calls set-bottom-message
+                             ;; and we don't want that one to survive
+                             (update-gui) 
+                             
+                             (set-bottom-message (exn-message x)))])
+            (let-values ([(new-board total-bonuses) 
+                          (make-moves start-board (append current-moves (list new-move)))])
+              (set-bottom-message "")
+              (set! dice-used (append dice-used (move-candidate-dice mc)))
+              (set! current-board new-board)
+              (set! current-moves (append current-moves (list new-move)))
+              (set! current-dice (foldl remq (append start-dice total-bonuses) dice-used))
+              (update-gui)))))
+      
+      (define/private (update-gui)
+        (cond
+          [(eq? viewing-index 'latest)
+           (dim-dice-except this-move-color)
+           (for-each (lambda (latest-dice-line)
+                       (if (eq? this-move-color (car latest-dice-line))
+                           (update-players-dice this-move-color current-dice)
+                           (update-players-dice (car latest-dice-line) (cdr latest-dice-line))))
+                     latest-dice)
+           (send board-pasteboard set-board current-board)
+           (let-values ([(highlights move-candidates)
+                         (find-roll-coordinates current-board current-dice this-move-color)])
+             (send board-pasteboard set-highlighted-squares highlights move-candidates))]
+          [(number? viewing-index)
+           (let ([past (list-ref history viewing-index)])
+             (clear-dice-except (past-color past))
+             (update-players-dice (past-color past) (past-roll past))
+             (send board-pasteboard set-board (past-board past))
+             (send board-pasteboard set-highlighted-squares '() '()))]
+          [else (error 'update-gui "unknown viewing index ~e\n" viewing-index)])
+        (reset-accept/move-buttons)
+        (reset-forw-back-buttons))
+      
+      (define/private (reset-accept/move-buttons)
+        (when this-move-color
+          (let ([accept (cdr (assq this-move-color gui-player-accept-move-buttons))]
+                [reset (cdr (assq this-move-color gui-player-reset-move-buttons))])
+            (send reset enable (and (eq? viewing-index 'latest) (not (null? current-moves))))
+            (send accept enable 
+                  (and (eq? viewing-index 'latest) 
+                       (with-handlers ([exn:bad-move? (lambda (x) 
+                                                        (set-bottom-message 
+                                                         (string-append 
+                                                          (format "~a is not done: " this-move-color)
+                                                          (exn-message x)))
+                                                        #f)])
+                         (take-turn this-move-color start-board start-dice current-moves)
+                         #t))))))
+      
+      (define/private (reset-forw-back-buttons)
+        (send forw enable (not (null? history)))
+        (send back enable (not (null? history))))
+      
+      (define/private (set-bottom-message msg) (send bottom-msg set-label msg))
+      
+      (define/private (dim-dice-except color)
+        (for-each (lambda (die-roll) 
+                    (cond
+                      [(eq? (car die-roll) color)
+                       (for-each (lambda (die) (send die set-dim #f)) (cadr die-roll))]
+                      [else 
+                       (for-each (lambda (die) (send die set-dim #t)) (cadr die-roll))]))
+                  dice))
+      
+      (define/private (clear-dice-except color)
+        (for-each (lambda (die-roll) 
+                    (cond
+                      [(eq? (car die-roll) color)
+                       (for-each (lambda (die) (send die set-dim #f)) (cadr die-roll))]
+                      [else 
+                       (for-each (lambda (die) (send die set-digit #f)) (cadr die-roll))]))
+                  dice))
+      
+      (define/private (update-players-dice color roll)
+        (let loop ([roll roll]
+                   [dice (cadr (assq color dice))])
+          (cond
+            [(null? dice) (void)]
+            [(null? roll) (send (car dice) set-digit #f)
+                          (loop roll (cdr dice))]
+            [else (send (car dice) set-digit (car roll))
+                  (loop (cdr roll) (cdr dice))])))
+      
+      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;
+      ;;  player choice gui
+      ;;
+
+      (define/private (index->player i) 
+        (case i
+          [(0) best-player%]
+          [(1) polite-player%]
+          [(2) reckless-player%]
+          [(3) gui-player%]))
+      
+      (define players (vector (index->player 0)
+                              (index->player 0)
+                              (index->player 0)
+                              (index->player 0)))
+      
+      (define/private (add-choose-player-controls color parent-panel)
+        (let ([color-order '((green . 0) (red . 1) (blue . 2) (yellow . 3))])
+          (new radio-box%
+               (parent parent-panel)
+               (label #f)
+               (choices '("Amazing Grace"
+                          "Polite Polly"
+                          "Reckless Renee"
+                          "You"))
+               (callback
+                (lambda (rb y)
+                  (vector-set! players
+                               (cdr (assq color color-order))
+                               (index->player
+                                (send rb get-selection))))))))
+      
+      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;
+      ;;  put all the gui elements together
+      ;;
+      
+      (define/private (make-player-control-panel parent color ah aw)
+        (let* ([parent 
+                (new panel:single% 
+                     (stretchable-height #f)
+                     (parent parent))]
+               [choose-player-panel (new vertical-panel% 
+                                         (parent parent)
+                                         (style '(border))
+                                         (alignment `(,aw ,ah))
+                                         (stretchable-width #f)
+                                         (stretchable-height #f))]
+               [control-player-panel (new vertical-panel% 
+                                          (parent parent)
+                                          (style '(border))
+                                          (alignment `(,aw ,ah))
+                                          (stretchable-width #f)
+                                          (stretchable-height #f))])
+          (add-gui-player-controls color control-player-panel)
+          (add-choose-player-controls color choose-player-panel)
+          (list color parent choose-player-panel control-player-panel)))
+      
+      (define gui-player-control-panels
+        (list (make-player-control-panel green-player-panel 'green 'top 'left)
+              (make-player-control-panel red-player-panel 'red 'bottom 'left)
+              (make-player-control-panel yellow-player-panel 'yellow 'top 'right)
+              (make-player-control-panel blue-player-panel 'blue 'bottom 'right)))
+      
+      (define/private (get-player-panel color i)
+        (let ([e (assq color gui-player-control-panels)])
+          (unless e
+            (error 'get-player-panel "bad color ~e" color))
+          (list-ref e i)))
+      (define/private (get-player-parent-panel c) (get-player-panel c 1))
+      (define/private (get-choose-player-panel c) (get-player-panel c 2))
+      (define/private (get-control-player-panel c) (get-player-panel c 3))
+
+      (define sbf-panel (new panel:single% 
+                             (parent bottom-panel) 
+                             (stretchable-width #f)
+                             (stretchable-height #f)
+                             (alignment '(right center))))
+      
+      (define start-button (new button%
+                                (label "Start Game")
+                                (parent sbf-panel)
+                                (callback
+                                 (lambda (x y)
+                                   (for-each (lambda (color)
+                                               (send (get-player-parent-panel color)
+                                                     active-child
+                                                     (get-control-player-panel color)))
+                                             '(red blue green yellow))
+                                   (send sbf-panel active-child bf-panel)
+                                   (start-game)))))
+      (define bf-panel (new horizontal-panel% (parent sbf-panel) (stretchable-width #f) (stretchable-height #f)))
+      (define back (new button%
+                        (label "<")
+                        (parent bf-panel)
+                        (callback (lambda (x y) (go-back)))))
+      (define forw (new button%
+                        (label ">")
+                        (parent bf-panel)
+                        (callback (lambda (x y) (go-forw)))))
+      (define rules-button (new button% (parent bottom-panel) (label "Rules") (callback (lambda (x y) (show-rules)))))
+
+      (super-new)
+      (send frame show #t)
+      
+      ;; start the game
+      (define/private (start-game)
+        (for-each (lambda (player%) (send the-game register (new player%))) (vector->list players))
+        (thread (lambda () (send the-game start))))))
+  
+  (define board-pasteboard%
+    (class pasteboard%
+      (inherit get-admin get-view-size)
+      (init-field admin-gui)
+      (init-field [board (new-board)])
+      
+      (define/public (set-board _board)
+        (set! board _board)
+        (frame-size-changed))
+      
+      ;; highlighted-squares : (listof (cons coordinate (listof coordinate)))
+      ;; the first element in the list is the key and the rest are
+      ;; squares that should be highlighted when the cursor moves over
+      ;; the key square
+      (define highlighted-squares '())
+      ;; move-candidates : (listof (cons coordinate (listof move-candidate)))
+      (define move-candidates '())
+      (define/public (set-highlighted-squares hs mcs)
+        (set! highlighted-squares hs)
+        (set! move-candidates mcs))
+      
+      ;; current-highlight : (listof coordinate)
+      (define current-highlight '())
+      (define current-mouse #f)
+      
+      (define/override (on-paint before? dc left top right bottom dx dy draw-caret)
+        (let ([admin (get-admin)])
+          (when admin
+            (let-values ([(w h) (get-size)])
+              (let ([pen (send dc get-pen)]
+                    [brush (send dc get-brush)])
+                (when before? (draw-board board dc w h dx dy #f))
+                (unless before? (draw-highlighted-squares dc dx dy w h))
+                (send dc set-pen pen)
+                (send dc set-brush brush))))))
+      
+      (define/private (draw-highlighted-squares dc dx dy w h)
+        (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent))
+        (send dc set-brush (send the-brush-list find-or-create-brush "black" 'hilite))
+        (for-each (lambda (highlighted-offset)
+                    (let-values ([(x y cw ch) (coordinate->xywh highlighted-offset w h)])
+                      (send dc draw-rectangle (+ dx x) (+ dy y) cw ch)))
+                  current-highlight))
+      
+      (inherit dc-location-to-editor-location)
+      (define/override (on-event event)
+        (let-values ([(w h) (get-size)])
+          (cond
+            [(and (send event button-up?)
+                  (find-next-selected-snip #f))
+             =>
+             (lambda (snip)
+               (super on-event event)
+               (let ([pawn-id (send snip get-pawn-id)])
+                 (let-values ([(x y) (dc-location-to-editor-location (send event get-x) (send event get-y))])
+                   (let* ([potential-move-line
+                           (memf (lambda (mcl) (in-coord? (car mcl) x y w h))
+                                 move-candidates)])
+                     (if potential-move-line
+                         (let* ([potential-moves (cdar potential-move-line)]
+                                [new-move (ormap (lambda (mc)
+                                                   (and (= pawn-id (get-move-id (move-candidate-move mc)))
+                                                        mc))
+                                                 potential-moves)])
+                           (if new-move
+                               (send admin-gui build-new-board/register-move new-move)
+                               (reset-snips)))
+                         (reset-snips)))))
+               (update-current-mouse (get-mouse-coordinate event w h)))]
+            [else
+             (update-current-mouse (get-mouse-coordinate event w h))
+             (super on-event event)])))
+      
+      (inherit find-next-selected-snip)
+      (define/private (get-mouse-coordinate event w h)
+        (cond
+          [(and (send event dragging?)
+                (find-next-selected-snip #f))
+           =>
+           (lambda (snip) (send snip get-coord))]
+          [else
+           (let-values ([(x y) (dc-location-to-editor-location (send event get-x) (send event get-y))])
+             (let loop ([highlights highlighted-squares])
+               (cond
+                 [(null? highlights) #f]
+                 [else
+                  (let* ([highlight-list (car highlights)]
+                         [highlight (car highlight-list)])
+                    (let-values ([(sx sy cw ch) (coordinate->xywh highlight w h)])
+                      (if (and (<= sx x (+ sx cw))
+                               (<= sy y (+ sy ch)))
+                          highlight
+                          (loop (cdr highlights)))))])))]))
+      
+      (inherit invalidate-bitmap-cache)
+      (define/private (update-current-mouse mse)
+        (unless (equal? current-mouse mse)
+          (set! current-mouse mse)
+          (set! current-highlight 
+                (if mse 
+                    (let ([ent (assoc current-mouse highlighted-squares)])
+                      (if ent 
+                          (cdr ent)
+                          '()))
+                    '()))
+          (invalidate-bitmap-cache)))
+      
+      
+      (inherit insert begin-edit-sequence end-edit-sequence find-first-snip set-min-width set-min-height)
+      (define/public (frame-size-changed) (reset-snips))
+      (define/private (reset-snips)
+        (begin-edit-sequence)
+        (let loop ([s (find-first-snip)])
+          (when s
+            (let ([n (send s next)])
+              (send s release-from-owner)
+              (loop n))))
+        (let-values ([(w h) (get-size)])
+          (let ([pawn-size (get-piece-size w h)])
+            (set-min-width w)
+            (set-min-height h)
+            (for-each-piece/position 
+             board w h
+             (lambda (pawn x y coord)
+               (insert (new coordinate-snip%
+                            (color (pawn-color pawn))
+                            (id (pawn-id pawn))
+                            (coord coord)
+                            (w pawn-size)
+                            (h pawn-size))
+                       x 
+                       y)))))
+        (end-edit-sequence))
+      
+      (define/private (get-size)
+        (let ([wb (box 0)]
+              [hb (box 0)])
+          (get-view-size wb hb)
+          (values (max 10 (- (unbox wb) 3))
+                  (max 10 (- (unbox hb) 3)))))
+      
+      (super-new)
+      (inherit set-selection-visible)
+      (set-selection-visible #f)))
+  
+  (define coordinate-snip%
+    (class snip%
+      (define/override (draw dc x y left top right bottom dx dy draw-caret)
+        (let ([old-pen (send dc get-pen)]
+              [old-brush (send dc get-brush)]
+              [old-smoothing (send dc get-smoothing)])
+          (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
+          (send dc set-brush (send the-brush-list find-or-create-brush (pawn-drawn-color color) 'solid))
+          (send dc set-smoothing 'aligned)
+          (send dc draw-ellipse x y w h)
+          (send dc set-pen old-pen)
+          (send dc set-brush old-brush)
+          (send dc set-smoothing old-smoothing)))
+      (define/override (get-extent dc x y wb hb descent space lspace rspace)
+        (set-box/f! wb w)
+        (set-box/f! hb h)
+        (set-box/f! descent 0)
+        (set-box/f! space 0)
+        (set-box/f! lspace 0)
+        (set-box/f! rspace 0))
+      (init-field id coord color w h)
+      (define/public (get-coord) coord)
+      (define/public (get-pawn-id) id)
+      (super-new)
+      (inherit set-snipclass)
+      (set-snipclass coordinate-snipclass)))
+  
+  (define (set-box/f! b v) (when (box? b) (set-box! b v)))
+  
+  (define coordinate-snipclass
+    (new
+     (class snip-class%
+       (define/override (read in)
+         (let ([id (send in get-fixed)]
+               [coord '???])
+           (new coordinate-snip% (id id) (coord coord))))
+       (super-new))))
+  (send coordinate-snipclass set-classname "parcheesi:coordinate-snipclass")
+  (send coordinate-snipclass set-version 1)
+  (send (get-the-snip-class-list) add coordinate-snipclass)
+  
+  (define board-frame%
+    (class frame%
+      (init-field [board-pasteboard #f])
+      (define/public (set-board-pasteboard bpb) (set! board-pasteboard bpb))
+      (define/override (on-size w h)
+        (when board-pasteboard
+          (send board-pasteboard frame-size-changed)))
+      (define/override (on-superwindow-show shown?)
+        (when board-pasteboard
+          (send board-pasteboard frame-size-changed)))
+      (super-new)))
+  
+  (define (in-coord? coord x y w h)
+    (let-values ([(cx cy cw ch) (coordinate->xywh coord w h)])
+      (and (<= cx x (+ cx cw))
+           (<= cy y (+ cy ch)))))
+  
+  ;; coordinate->xywh : coordinate -> (values number number number number)
+  (define (coordinate->xywh loc w h)
+    (cond
+      [(main-c? loc)
+       (let*-values ([(x y horizontal?) (find-main-coordinates (main-c-count loc) w h)]
+                     [(cw ch) (get-cell-size horizontal? w h)])
+         (values (- x (/ cw 2)) (- y (/ ch 2)) cw ch))]
+      [(home-row-c? loc)
+       (let*-values ([(x y horizontal?) (find-home-row-coordinates (home-row-c-color loc)
+                                                                   (home-row-c-count loc)
+                                                                   w
+                                                                   h)]
+                     [(cw ch) (get-cell-size horizontal? w h)])
+         (values (- x (/ cw 2)) (- y (/ ch 2)) cw ch))]
+      [(home-c? loc)
+       (values (* w 1/3) (* h 1/3) (* w 1/3) (* h 1/3))]
+      [(start-c? loc)
+       (case (start-c-color loc)
+         [(blue) (values 0 0 (* w 1/3) (* h 1/3))]
+         [(red) (values (* w 2/3) 0 (* w 1/3) (* h 1/3))]
+         [(yellow) (values 0 (* h 2/3) (* w 1/3) (* h 1/3))]
+         [(green) (values (* w 2/3) (* h 2/3) (* w 1/3) (* h 1/3))])]
+      [else (error 'coordinate->xywh "unk loc ~e" loc)]))
+  
+  ;; find-roll-coordinates : board
+  ;;                         (listof number) 
+  ;;                         color 
+  ;;                      -> (values (listof (cons coordinate (listof coordinate)))
+  ;;                                 (listof (cons coordinate (listof move-candidate))))
+  ;; finds the coordinates for the moves that the GUI highlights.
+  ;; in the resulting list, the first entry is the place with the
+  ;; piece and subsequent entries are places that it can move to.
+  (define (find-roll-coordinates board roll color)
+    (let-values ([(start-coords start-moves)
+                  (find-start-roll-coordinates board roll color)]
+                 [(main-coords main-moves)
+                  (find-main-roll-coordinates board roll color)]
+                 [(home-coords home-moves)
+                  (find-home-roll-coordinates board roll color)])
+      (values (map (lambda (x) (cons (car x) (eliminate-duplicates (cdr x))))
+                   (append start-coords main-coords home-coords))
+              (collapse-same-coordinates (append start-moves main-moves home-moves)))))
+  
+  ;; eliminate-duplicates : (listof X) -> (listof X)
+  (define (eliminate-duplicates lst)
+    (let ([ht (make-hash-table 'equal)])
+      (for-each (lambda (x) (hash-table-put! ht x #t)) lst)
+      (hash-table-map ht (lambda (x y) x))))
+  
+  ;; collapse-same-coordinates : (listof (cons coordinate (listof move-candidate)))
+  ;;                          -> (listof (cons coordinate (listof move-candidate)))
+  (define (collapse-same-coordinates l)
+    (let ([ht (make-hash-table 'equal)])
+      (for-each (lambda (pr)
+                  (hash-table-put! ht (car pr)
+                                   (append (cdr pr)
+                                           (hash-table-get ht (car pr) (lambda () '())))))
+                l)
+      (hash-table-map ht cons)))
+  
+  ;; like find-roll-coordinates, but only for the main track of the board
+  (define (find-home-roll-coordinates board roll color)
+    (find-move-coordinates board-home-row-size
+                           (lambda (i) (board-home-row-i board color i))
+                           roll
+                           color
+                           (lambda (num) (make-home-row-c num color))
+                           make-move-piece-home
+                           home-row-add))
+  
+  ;; like find-roll-coordinates, but only for the main track of the board
+  (define (find-main-roll-coordinates board roll color)
+    (find-move-coordinates board-main-size
+                           (lambda (i) (board-main-i board i))
+                           roll
+                           color
+                           make-main-c
+                           make-move-piece-main
+                           main-ring-add))
+  
+  ;; find-move-coordinates : number
+  ;;                         (number -> (listof pawn))
+  ;;                         number color
+  ;;                         (number -> coordinate)
+  ;;                         (pawn number number -> move)
+  ;;                         (color number number -> (union #f number))
+  (define (find-move-coordinates len ref roll color make-coordinate make-move-piece find-end-spot)
+    (let loop ([i len]
+               [coords null]
+               [move-candidates null])
+      (cond
+        [(= i 0) (values coords move-candidates)]
+        [else (let* ([pos (- i 1)]
+                     [ent (ref pos)])
+                (if (and (pair? ent)
+                         (eq? (pawn-color (car ent)) color))
+                    (let* ([build-list
+                            (lambda (f)
+                              (foldl
+                               (lambda (die sofar)
+                                 (let ([final-spot (find-end-spot color pos die)])
+                                   (if final-spot
+                                       (cons (f die final-spot) sofar)
+                                       sofar)))
+                               '()
+                               roll))]
+                           
+                           [new-coord (cons (make-coordinate pos) 
+                                            (build-list (lambda (die final-spot) final-spot)))]
+                           [new-moves 
+                            (build-list (lambda (die final-spot)
+                                          (cons final-spot
+                                                (map (lambda (pawn)
+                                                       (make-move-candidate (make-move-piece pawn pos die)
+                                                                            (list die)))
+                                                     ent))))])
+                      (loop (- i 1)
+                            (cons new-coord coords)
+                            (append new-moves move-candidates)))
+                    (loop (- i 1) coords move-candidates)))])))
+  
+  (define (main-ring-add color start dist)
+    (let ([landed (find-end-spot color start dist)])
+      (cond
+        [(eq? landed 'too-far) #f]
+        [(eq? landed 'home) (make-home-c color)]
+        [(eq? (car landed) 'home-row)
+         (make-home-row-c (cdr landed) color)]
+        [(eq? (car landed) 'main)
+         (make-main-c (cdr landed))])))
+  
+  (define (home-row-add color pos die)
+    (let ([final-spot (+ pos die)])
+      (cond
+        [(< final-spot board-home-row-size)
+         (make-home-row-c final-spot color)]
+        [(= final-spot board-home-row-size)
+         (make-home-c color)]
+        [else #f])))
+  
+  ;; like find-roll-coordinates, but only for the start position of the board
+  (define (find-start-roll-coordinates board roll color)
+    (let ([available-pawns (filter (lambda (pawn) (eq? (pawn-color pawn) color)) (board-start board))]
+          [ent (board-main-i board (get-enter-pos color))])
+      (cond
+        [(and (has-entering-roll? roll)
+              (not (null? available-pawns))
+              (or (null? ent)
+                  (null? (cdr ent))))
+         (let ([entry-coord (make-main-c (get-enter-pos color))])
+           (values 
+            (list (list (make-start-c color) entry-coord))
+            (list 
+             (cons entry-coord
+                   (map
+                    (lambda (pawn)
+                      (make-move-candidate (make-enter-piece pawn)
+                                           (if (memq 5 roll) '(5) roll)))
+                    available-pawns)))))]
+        [else (values null null)]))))
diff --git a/collects/games/parcheesi/admin.ss b/collects/games/parcheesi/admin.ss
new file mode 100644
index 0000000000..d601087bde
--- /dev/null
+++ b/collects/games/parcheesi/admin.ss
@@ -0,0 +1,174 @@
+
+(module admin mzscheme
+  (require "board.ss"
+	   "moves.ss"
+           "interfaces.ss"
+           (lib "class.ss")
+           (lib "list.ss"))
+  
+  (provide game%
+           game-observer<%>)
+  
+  (define all-colors '(green red blue yellow))
+  
+  (define game-observer<%>
+    (interface ()
+      introduce ;; color string -> void
+      taking-turn ;; color dice -> void
+      took-turn ;; color board -> void
+      game-over)) ;; (union string #f) (union color #f) -> void
+  
+  (define game%
+    (class* object% (game<%>)      
+      (define die (new die%))
+      (define players '())
+      (define colors all-colors)
+      (define board (new-board))
+      
+      (define observer #f)
+      (define/public (set-observer wf)
+        (unless (is-a? wf game-observer<%>)
+          (error 'set-observer "expected a game-observer<%> object, got ~e" wf))
+        (set! observer wf))
+      
+      (define/public (register player)
+        (when (null? colors)
+          (error 'add-player "cannot add more than four players"))
+        (set! players (append players (list (new splayer% (player player) (color (car colors))))))
+        (set! colors (cdr colors)))
+      
+      ;; -> (union player #f)
+      ;; #f indicates that everyone cheated
+      (define/public (start)
+        (unless (= 4 (length players))
+          (error 'start "expected 4 players to be registered, but there are ~a" (length players)))
+
+        (for-each (lambda (player) (send player start-game observer)) players)
+        
+        (let loop ()
+          (for-each (lambda (player) 
+                      (unless (winner)
+                        (take-player-turn player)))
+                    players)
+          (unless (winner)
+            (loop)))
+        
+        (let ([winner (winner)])
+          (when observer
+            (if (object? winner)
+                (send observer game-over (send winner get-name) (send winner get-color))
+                (send observer game-over #f #f)))
+          (list (if (object? winner)
+                    (send winner get-name)
+                    #f)
+                (map (lambda (x) (send x get-name))
+                     (filter (lambda (x) (send x get-cheated?)) players)))))
+      
+      (define/private (take-player-turn player)
+        (let doubles-loop ([count 1])
+          (let-values ([(doubles? roll) (send die roll board (send player get-color))])
+            (when observer
+              (send observer taking-turn (send player get-color) roll))
+            (cond
+              [(and doubles? (= count 3))
+               (set! board (send player doubles-penalty board))
+               (when observer
+                 (send observer took-turn (send player get-color) board))]
+              [else
+               (set! board (send player do-move board roll))
+               (when observer
+                 (send observer took-turn (send player get-color) board))
+               (when doubles?
+                 (doubles-loop (+ count 1)))]))))
+      
+      (define/private (winner)
+        (cond
+          [(ormap (lambda (player) (and (send player won? board) player))
+                  players)
+           =>
+           (lambda (x) x)]
+          [(andmap (lambda (player) (send player get-cheated?))
+                   players)
+           'everyone-cheated]
+          [else #f]))
+      
+      (super-new)))
+  
+  (define splayer%
+    (class object%
+      (init-field [player player]
+                  [color color])
+      (define name #f)
+      (define cheated? #f) 
+      (define/public (get-cheated?) cheated?)
+      (define/public (get-color) color)
+      (define/public (get-name) name)
+      (define/public (won? board)
+        (equal? 4 (length (filter (lambda (x) (eq? (pawn-color x) color)) (board-home board)))))
+      
+      (define/private (cheated . args)
+        (display (string-append (format "~s cheated! " color)
+                                (apply format args)
+                                "\n"))
+        (set! cheated? #t))
+      
+      (define/public (start-game observer) 
+        (unless cheated?
+          (with-handlers ([exn? (lambda (x) (cheated "start-game error ~a" (exn-message x)))])
+            (let ([res-name (send player start-game color)])
+              (cond
+                [(string? res-name)
+                 (set! name res-name)
+                 (when observer
+                   (send observer introduce color name))
+                 name]
+                [else (cheated "expected a string for the name, got ~s" name)])))))
+      
+      (define/public (do-move board dice)
+        (cond
+          [cheated? board]
+          [else
+           (with-handlers ([exn:bad-move? 
+                            (lambda (x)
+                              (cheated "~s" (exn-message x))
+                              (remove-player board))])
+             (let ([moves (with-handlers ([exn? (lambda (x) (list 'error (exn-message x)))])
+                            (send player do-move board dice))])
+               (cond
+                 [(and (list? moves) (andmap move? moves))
+                  (take-turn color board dice moves)]
+                 [else
+                  (cheated "wrong result ~s" moves)
+                  (remove-player board)])))]))
+      
+      (define/private (remove-player board)
+        (board-doubles-penalty
+         (board-doubles-penalty
+          (board-doubles-penalty
+           (board-doubles-penalty board color)
+           color)
+          color)
+         color))
+                  
+      (define/public (doubles-penalty board)
+        (cond
+          [cheated? board]
+          [else
+           (with-handlers ([exn? (lambda (x) 
+                                   (cheated "doubles-penalty: ~a\n" (exn-message x))
+                                   (void))])
+             (send player doubles-penalty))
+           (board-doubles-penalty board color)]))
+      
+      (super-new)))
+  
+  (define die%
+    (class object%
+      (define/public (roll board color)
+        (let* ([die1 (+ 1 (random 6))]
+               [die2 (+ 1 (random 6))]
+               [doubles? (= die1 die2)])
+          (if (and doubles? (board-all-in? board color))
+              (values doubles? (list die1 die2 (- 7 die1) (- 7 die2)))
+              (values doubles? (list die1 die2)))))
+      (super-new))))
\ No newline at end of file
diff --git a/collects/games/parcheesi/best-players.ss b/collects/games/parcheesi/best-players.ss
new file mode 100644
index 0000000000..350efe3aed
--- /dev/null
+++ b/collects/games/parcheesi/best-players.ss
@@ -0,0 +1,767 @@
+#|
+
+player characteristics
+  - all things being equal, prefer to bop opponents (even if no bonus comes from it)
+  - player that prefers to set himself up to bop opponents
+
+agressive annie
+balanced bob
+careful charlie
+(random ron)
+|#
+
+(module best-players mzscheme
+  (require "board.ss"
+	   "moves.ss"
+           "interfaces.ss"
+           "test.ss"
+           (lib "list.ss")
+           (lib "etc.ss")
+           (lib "class.ss")
+           (lib "pretty.ss"))
+  
+  (provide random-player%
+           agressive-player%
+           careful-player%
+           best-player%
+           polite-player%
+           reckless-player%
+           
+           search
+           (struct state (moves dice board)))
+
+  (define candidates-record '())
+  (provide average-move-count)
+  (define (average-move-count)
+    (if (null? candidates-record)
+	'no-games-played
+	(list (/ (apply + candidates-record) (length candidates-record) 1.0)
+	      (length candidates-record))))
+  
+  ;; moves : (listof move) -- what got us here
+  ;; dice : (listof dice) -- what we have left to use
+  ;; board : board -- the state of the board after taking the moves
+  (define-struct state (moves dice board) (make-inspector))
+  
+  (define base-player%
+    (class* object% (player<%>)
+      (init-field name)
+      (define/public (score board) (error 'score "abstract method"))
+      
+      (field [color #f])
+      (define/public (start-game _color)
+        (set! color _color)
+        name)
+      (define/public (doubles-penalty) (void))
+      
+      (define/public (do-move orig-board unsorted-dice)
+        (let ([dice (quicksort unsorted-dice <)])
+          (let* ([before (current-process-milliseconds)]
+                 [candidates (search orig-board color dice)]
+                 [ms (- (current-process-milliseconds) before)])
+	    (set! candidates-record (cons (length candidates) candidates-record))
+            (when (ms . > . 4000)
+              (printf "\nmsec ~s\n" ms)
+              (printf "candidates ~s (avg moves ~s)\n" 
+                      (length candidates)
+                      (let ([nums (map (lambda (x) (length (state-moves x))) candidates)])
+                        (/ (apply + nums)
+                           (length nums)
+                           1.0)))
+              (print-struct #t)
+              (printf "color ~s dice ~s\n" color dice)
+              (pretty-print orig-board))
+            (find-best candidates))))
+
+      (define/private (find-best moves)
+        (cond
+          [(null? moves) '()]
+          [else
+           (let loop ([states (cdr moves)]
+                      [best (list (car moves))]
+                      [best-score (score (state-board (car moves)))])
+             (cond
+               [(null? states) (state-moves (list-ref best (random (length best))))]
+               [else (let* ([state (car states)]
+                            [this-score (score (state-board state))])
+                       (cond
+                         [(= this-score best-score)
+                          (loop (cdr states)
+                                (cons state best)
+                                best-score)]
+                         [(< this-score best-score) 
+                          (loop (cdr states)
+                                best
+                                best-score)]
+                         [else (loop (cdr states)
+                                     (list state)
+                                     this-score)]))]))]))
+      
+      (super-new)))
+  
+  (define random-player%
+    (class base-player%
+      (init [name "Random Ron"])
+      (define/override (score board) (random 10000))
+      (super-new [name name])))
+  
+  (define agressive-player%
+    (class base-player%
+      (inherit-field color)
+      (define/override (score board) (- 500 (find-distance board color)))
+      (super-new [name "Agressive Annie"])))
+  
+  (define polite-player%
+    (class base-player%
+      (inherit-field color)
+      (define/override (score board) (find-distance board color))
+      (super-new [name "Polite Polly"])))
+  
+  (define best-player%
+    (class base-player%
+      (inherit-field color)
+      (define/override (score board) 
+        (let ([dist (- 500 (find-distance board color))]
+              [bop-chance (- 36 (find-bop-chance board color))])
+          (+ (* dist 100) bop-chance)))
+      (super-new [name "Amazing Grace"])))
+  
+  (define reckless-player%
+    (class base-player%
+      (inherit-field color)
+      (define/override (score board) (find-bop-chance board color))
+      (super-new [name "Reckless Renee"])))
+  
+  (define careful-player%
+    (class base-player%
+      (inherit-field color)
+      (define/override (score board) (- 36 (find-bop-chance board color)))
+      (super-new [name "Careful Charlie"])))
+  
+  ;; search : board color (listof number) -> (listof state)
+  (define (search orig-board color dice)
+    (define candidate-ht (make-hash-table 'equal))
+    (define (move-candidate candidate)
+      (hash-table-put! candidate-ht (state-board candidate) candidate))
+    (define (get-candidates) (hash-table-map candidate-ht (lambda (x y) y)))
+    
+    ;; main : -> void
+    (define (main)
+      ;; ht : board -o> true
+      (let ([ht (make-hash-table 'equal)])
+        (let loop ([state (make-state '() dice orig-board)])
+          (let* ([board (state-board state)]
+                 [dice (state-dice state)]
+                 [key (cons dice board)])
+            (cond
+              [(hash-table-get ht key (lambda () #f))
+               (void)]
+              [else 
+               (hash-table-put! ht key #t)
+               (let* ([possible-moves (find-moves board dice)]
+                      [valid-next-states (find-valid-states state orig-board board possible-moves)])
+                 (cond
+                   [(null? valid-next-states) (move-candidate state)]
+                   [else (for-each loop valid-next-states)]))])))))
+    
+    (define (find-valid-states state orig-board board moves)
+      (let loop ([moves moves])
+        (cond
+          [(null? moves) null]
+          [else (let ([move (car moves)])
+                  (with-handlers ([exn:bad-move? (lambda (x) (loop (cdr moves)))])
+                    (let-values ([(new-board bonus) (make-one-move board move)])
+                      (if (blockade-moved? orig-board new-board color)
+                          (loop (cdr moves))
+                          (let ([removed-dice (remove-used-rolls move (state-dice state))])
+                            (if removed-dice
+                                (cons (make-state (append (state-moves state) (list move))
+                                                  (if bonus (insert bonus removed-dice) removed-dice)
+                                                  new-board)
+                                      (loop (cdr moves)))
+                                (loop (cdr moves))))))))])))
+    
+    (define (remove-used-rolls move dice)
+      (cond
+        [(move-piece-main? move) (mem/rem (move-piece-main-distance move) dice)]
+        [(move-piece-home? move) (mem/rem (move-piece-home-distance move) dice)]
+        [(enter-piece? move)
+         (or (mem/rem 5 dice)
+             (and (memq 3 dice)
+                  (memq 2 dice)
+                  (remq 3 (remq 2 dice)))
+             (and (memq 1 dice)
+                  (memq 4 dice)
+                  (remq 1 (remq 4 dice))))]))
+    
+    (define (mem/rem x ls) (and (memq x ls) (remq x ls)))
+    
+    (define (find-moves board dice)
+      (let ([moves '()])
+        (for-each-pawn/loc
+         board
+         (lambda (pawn loc)
+           (when (eq? (pawn-color pawn) color)
+             (cond
+               [(eq? loc 'start) (set! moves (cons (make-enter-piece pawn) moves))]
+               [(number? loc)
+                (set! moves (append (map (lambda (die) (make-move-piece-main pawn loc die))
+                                         dice)
+                                    moves))]
+               [(home-row-loc? loc)
+                (set! moves (append (map (lambda (die) (make-move-piece-home pawn (home-row-loc-num loc) die))
+                                         dice)
+                                    moves))]
+               [(eq? loc 'home) (void)]))))
+        moves))
+    
+    (define (extend vec i make-move-piece dice)
+      (let ([ent (vector-ref vec i)])
+        (cond
+          [(and (pair? ent)
+                (eq? (pawn-color (car ent)) color))
+           (all-moves make-move-piece ent i dice)]
+          [else '()])))
+    
+    (define (all-moves make-move-piece ent i dice)
+      (let d-loop ([dice dice])
+        (cond
+          [(null? dice) '()]
+          [else   
+           (append
+            (let loop ([ent ent])
+              (cond
+                [(null? ent) null]
+                [else (cons (make-move-piece (car ent) i (car dice))
+                            (loop (cdr ent)))]))
+            (d-loop (cdr dice)))])))
+    
+    (main)
+    (get-candidates))
+  
+  ;; find-bop-chance : board color -> number[0-36]
+  (define (find-bop-chance board color)
+    
+    ;; add-chances : number[distance] -> void
+    (define (add-chances i)
+      (case i
+        [(1)
+         (add-single-roll-chances 1)]
+        [(2) 
+         (add-single-roll-chances 1)
+         (add-chance 1 1)]
+        [(3) 
+         (add-single-roll-chances 1)
+         (add-chance 1 2)]
+        [(4) 
+         (add-single-roll-chances 1)
+         (add-chance 1 3)
+         (add-chance 2 2)]
+        [(5) 
+         (add-single-roll-chances 1)
+         (add-chance 1 4)
+         (add-chance 2 3)]
+        [(6) 
+         (add-single-roll-chances 1)
+         (add-chance 1 5)
+         (add-chance 2 4)
+         (add-chance 3 3)]
+        [(7) 
+         (add-chance 1 6)
+         (add-chance 2 5)
+         (add-chance 3 4)]
+        [(8) 
+         (add-chance 2 6)
+         (add-chance 3 5)
+         (add-chance 4 4)]
+        [(9) 
+         (add-chance 3 6)
+         (add-chance 4 5)]
+        [(10) 
+         (add-chance 4 6)
+         (add-chance 5 5)]
+        [(11) 
+         (add-chance 5 6)]
+        [(12) 
+         (add-chance 6 6)]
+        [else (void)]))
+    
+    (define (add-single-roll-chances i)
+      (add-chance i 1)
+      (add-chance i 2)
+      (add-chance i 3)
+      (add-chance i 4)
+      (add-chance i 5)
+      (add-chance i 6))
+    
+    (define chances (build-vector
+                     6
+                     (lambda (i) (make-vector 6 #f))))
+    (define (add-chance d1 d2)
+      (vector-set! (vector-ref chances (- d1 1)) (- d2 1) #t)
+      (vector-set! (vector-ref chances (- d2 1)) (- d1 1) #t))
+
+    (let ([my-blockades (map blockade-loc (find-blockades/color board color))])
+      (for-each-pawn/loc
+       board
+       (lambda (pawn my-loc)
+         (when (and (eq? (pawn-color pawn) color)
+                    (number? my-loc))
+           (unless (member my-loc my-blockades)
+             (for-each-pawn/loc
+              board
+              (lambda (pawn their-loc)
+                (unless (eq? (pawn-color pawn) color)
+                  (cond
+                    [(eq? their-loc 'start)
+                     (let ([their-enter-spot (get-enter-pos (pawn-color pawn))])
+                       ;; this code assumes that the enter-pos's are not within 6 of
+                       ;; where the board indicies wrap around.
+                       (cond
+                         [(= my-loc their-enter-spot)
+                          (add-single-roll-chances 5)
+                          (add-chance 2 3)
+                          (add-chance 1 4)]
+                         [(= my-loc (+ their-enter-spot 1))
+                          (add-chance 5 1)]
+                         [(= my-loc (+ their-enter-spot 2))
+                          (add-chance 5 2)]
+                         [(= my-loc (+ their-enter-spot 3))
+                          (add-chance 5 3)]
+                         [(= my-loc (+ their-enter-spot 4))
+                          (add-chance 5 4)]
+                         [(= my-loc (+ their-enter-spot 5))
+                          (add-chance 5 5)]
+                         [(= my-loc (+ their-enter-spot 6))
+                          (add-chance 5 6)]))]
+                    [(number? their-loc)
+                     (unless (safety? my-loc)
+                       (unless (find-blockade/between board their-loc my-loc)
+                         (add-chances (dist-from their-loc my-loc))))])))))))))
+    
+    (length (filter values (apply append (map vector->list (vector->list chances))))))
+  
+  (define (dist-from them me)
+    (cond
+      [(< them me) (- me them)]
+      [else (- (+ me board-main-size) them)]))
+  
+  ;; find-distance : board color -> number
+  ;; finds the cumulative distance that the pawns have
+  ;; to travel before they can make it home.
+  (define (find-distance board color)
+    (define distance 0)
+    
+    (for-each-pawn/loc
+     board
+     (lambda (pawn loc)
+       (when (eq? (pawn-color pawn) color)
+         (set! distance (+ (find-loc-distance loc color) distance)))))
+    distance)
+  
+  ;; find-loc-distance : loc color -> number
+  (define (find-loc-distance loc color)
+    (cond
+      [(eq? loc 'start) 100]
+      [(eq? loc 'home) 0]
+      [(number? loc) 
+       (let* ([entry (get-enter-pos color)]
+              [exit (get-exit-pos color)]
+              [sub-from 73]
+              [dist-to-entry
+               (cond
+                 [(<= entry loc) (- loc entry)]
+                 [else (- (+ loc board-main-size) entry)])])
+         (- sub-from dist-to-entry))]
+      [else (- board-home-row-size (home-row-loc-num loc))]))
+    
+  (define (insert x l)
+    (cond
+      [(empty? l) (list x)]
+      [(<= x (first l)) (cons x l)]
+      [else (cons (first l) (insert x (rest l)))]))
+
+  (define everywhere-board
+    (make-board (list (make-pawn 'red 2)
+                      (make-pawn 'blue 0)
+                      (make-pawn 'green 1)
+                      (make-pawn 'yellow 3))
+                `#68(() () () () () (,(make-pawn 'green 0)) () () 
+                        () () () () () () () () 
+                        ()
+                        () () () () () (,(make-pawn 'red 1)) () ()
+                        () () () () () () () () 
+                        ()
+                        () () () () () (,(make-pawn 'blue 3)) () () 
+                        () () () () () () () () 
+                        ()
+                        () () () () () (,(make-pawn 'yellow 2)) () () 
+                        () () () () () () () ())
+                (list (cons 'green `#7((,(make-pawn 'green 2)) ()))
+                      (cons 'red `#7(() (,(make-pawn 'red 3)) ()))
+                      (cons 'blue `#7(() () (,(make-pawn 'blue 1)) ()))
+                      (cons 'yellow `#7(() () () (,(make-pawn 'yellow 0)) ())))
+                (list (make-pawn 'red 0)
+                      (make-pawn 'blue 2)
+                      (make-pawn 'green 3)
+                      (make-pawn 'yellow 1))))
+  
+  (define (run-test)
+    (define (build-state moves dice board)
+      (make-state moves
+                  dice
+                  (let loop ([moves moves]
+                             [board board])
+                    (cond
+                      [(null? moves) board]
+                      [else 
+                       (let-values ([(new-board bonus) (make-one-move board (car moves))])
+                         (loop (cdr moves) new-board))]))))
+    
+    (test-list (search (new-board) 'green (list 2 3))
+               (list (build-state (list (make-enter-piece (make-pawn 'green 0)))
+                                  '()
+                                  (new-board))
+                     (build-state (list (make-enter-piece (make-pawn 'green 1)))
+                                  '()
+                                  (new-board))
+                     (build-state (list (make-enter-piece (make-pawn 'green 2)))
+                                  '()
+                                  (new-board))
+                     (build-state (list (make-enter-piece (make-pawn 'green 3)))
+                                  '()
+                                  (new-board))))
+    
+    (test-list (search (new-board) 'green (list 5 2))
+               (list (build-state (list (make-enter-piece (make-pawn 'green 0))
+                                        (make-move-piece-main (make-pawn 'green 0) 5 2))
+                                  '()
+                                  (new-board))
+                     (build-state (list (make-enter-piece (make-pawn 'green 1))
+                                        (make-move-piece-main (make-pawn 'green 1) 5 2))
+                                  '()
+                                  (new-board))
+                     (build-state (list (make-enter-piece (make-pawn 'green 2))
+                                        (make-move-piece-main (make-pawn 'green 2) 5 2))
+                                  '()
+                                  (new-board))
+                     (build-state (list (make-enter-piece (make-pawn 'green 3))
+                                        (make-move-piece-main (make-pawn 'green 3) 5 2))
+                                  '()
+                                  (new-board))))
+    
+    (test (find-loc-distance 'start 'red) 100)
+    (test (find-loc-distance 'home 'red) 0)
+    (test (find-loc-distance (make-home-row-loc 1 'red) 'red) 6)
+    (test (find-loc-distance (get-enter-pos 'red) 'red) 73)
+    (test (find-loc-distance (get-exit-pos 'red) 'red) (- 73
+                                                          board-main-size 
+                                                          (- (get-exit-pos 'red)
+                                                             (get-enter-pos 'red))))
+
+    (test (find-distance (new-board) 'green)
+          (* 4 100))
+    (test (let-values ([(board bonus) (board-enter-piece (new-board) (make-pawn 'green 0))])
+            (find-distance board 'green))
+          (+ (* 3 100) 73))
+    (test (let-values ([(board bonus) (board-enter-piece (new-board) (make-pawn 'red 0))])
+            (find-distance board 'red))
+          (+ (* 3 100) 73))
+    (test (let-values ([(board bonus) (board-enter-piece (new-board) (make-pawn 'yellow 0))])
+            (find-distance board 'yellow))
+          (+ (* 3 100) 73))
+    (test (let-values ([(board bonus) (board-enter-piece (new-board) (make-pawn 'blue 0))])
+            (find-distance board 'blue))
+          (+ (* 3 100) 73))
+    (test (let-values ([(board bonus) (board-enter-piece (new-board) (make-pawn 'yellow 0))])
+            (let-values ([(board bonus) (board-move-piece-main board (make-pawn 'yellow 0) 56 60)])
+              (let-values ([(board bonus) (board-move-piece-main board (make-pawn 'yellow 0) 48 3)])
+                (find-distance board 'yellow))))
+          (+ (* 3 100) 10))
+    (test (let-values ([(board bonus) (board-enter-piece (new-board) (make-pawn 'yellow 0))])
+            (let-values ([(board bonus) (board-move-piece-main board (make-pawn 'yellow 0) 56 60)])
+              (let-values ([(board bonus) (board-move-piece-main board (make-pawn 'yellow 0) 48 4)])
+                (find-distance board 'yellow))))
+          (+ (* 3 100) 7))
+    (test (let-values ([(board bonus) (board-enter-piece (new-board) (make-pawn 'yellow 0))])
+            (let-values ([(board bonus) (board-move-piece-main board (make-pawn 'yellow 0) 56 60)])
+              (let-values ([(board bonus) (board-move-piece-main board (make-pawn 'yellow 0) 48 11)])
+                (find-distance board 'yellow))))
+          300)
+    (test (let-values ([(board bonus) (board-enter-piece (new-board) (make-pawn 'yellow 0))])
+            (let-values ([(board bonus) (board-move-piece-main board (make-pawn 'yellow 0) 56 60)])
+              (let-values ([(board bonus) (board-move-piece-main board (make-pawn 'yellow 0) 48 10)])
+                (find-distance board 'yellow))))
+          301)
+    (test (let-values ([(board bonus) (board-enter-piece (new-board) (make-pawn 'yellow 0))])
+            (let-values ([(board bonus) (board-move-piece-main board (make-pawn 'yellow 0) 56 40)])
+              (find-distance board 'yellow)))
+          333)
+    
+    (test (let-values ([(board bonus) (board-enter-piece (new-board) (make-pawn 'blue 0))])
+            (let-values ([(board bonus) (board-enter-piece board (make-pawn 'blue 1))])
+              (let-values ([(board bonus) (board-move-piece-main board (make-pawn 'blue 0) 39 1)])
+                (let-values ([(board bonus) (board-move-piece-main board (make-pawn 'blue 1) 39 1)])
+                  (let-values ([(board bonus) (board-enter-piece board (make-pawn 'blue 2))])
+                    (let-values ([(board bonus) (board-enter-piece board (make-pawn 'blue 3))])
+                      (find-distance board 'blue)))))))
+          (+ 73 73 72 72))
+
+    (test (find-bop-chance (mb) 'green) 0)
+    (test (find-bop-chance (mb (make-enter-piece (make-pawn 'green 0))
+                               (make-enter-piece (make-pawn 'red 0))
+                               (make-move-piece-main (make-pawn 'green 0) 5 16))
+                           'green)
+          0)
+    (test (find-bop-chance (mb (make-enter-piece (make-pawn 'green 0))
+                               (make-enter-piece (make-pawn 'green 1))
+                               (make-move-piece-main (make-pawn 'green 0) 5 1))
+                           'green)
+          0)
+    (test (find-bop-chance (mb (make-enter-piece (make-pawn 'green 0))
+                               (make-move-piece-main (make-pawn 'green 0)
+                                                     5
+                                                     17))
+                           'green)
+          15)
+    (test (find-bop-chance (mb (make-enter-piece (make-pawn 'green 0))
+                               (make-move-piece-main (make-pawn 'green 0)
+                                                     5
+                                                     18))
+                           'green)
+          2)
+    (test (find-bop-chance (mb (make-enter-piece (make-pawn 'green 0))
+                               (make-move-piece-main (make-pawn 'green 0)
+                                                     5
+                                                     19))
+                           'green)
+          2)
+    (test (find-bop-chance (mb (make-enter-piece (make-pawn 'green 0))
+                               (make-move-piece-main (make-pawn 'green 0)
+                                                     5
+                                                     20))
+                           'green)
+          2)
+    (test (find-bop-chance (mb (make-enter-piece (make-pawn 'green 0))
+                               (make-move-piece-main (make-pawn 'green 0)
+                                                     5
+                                                     21))
+                           'green)
+          2)
+    (test (find-bop-chance (mb (make-enter-piece (make-pawn 'green 0))
+                               (make-move-piece-main (make-pawn 'green 0)
+                                                     5
+                                                     22))
+                           'green)
+          1)
+    (test (find-bop-chance (mb (make-enter-piece (make-pawn 'green 0))
+                               (make-move-piece-main (make-pawn 'green 0)
+                                                     5
+                                                     23))
+                           'green)
+          2)
+    (test (find-bop-chance (mb (make-enter-piece (make-pawn 'green 0))
+                               (make-move-piece-main (make-pawn 'green 0)
+                                                     5
+                                                     27))
+                           'green)
+          0)
+    (test (find-bop-chance (mb (make-enter-piece (make-pawn 'green 0))
+                               (make-enter-piece (make-pawn 'red 0))
+                               (make-move-piece-main (make-pawn 'green 0) 5 16))
+                           'red)
+          0)
+    (test (find-bop-chance (mb (make-enter-piece (make-pawn 'green 0))
+                               (make-enter-piece (make-pawn 'red 0))
+                               (make-move-piece-main (make-pawn 'green 0) 5 16)
+                               (make-move-piece-main (make-pawn 'red 0) 22 1))
+                           'red)
+          11)
+    
+    (test (find-bop-chance (mb (make-enter-piece (make-pawn 'green 0))
+                               (make-enter-piece (make-pawn 'red 0))
+                               (make-enter-piece (make-pawn 'red 1))
+                               (make-move-piece-main (make-pawn 'green 0) 5 16)
+                               (make-move-piece-main (make-pawn 'red 0) 22 1))
+                           'red)
+          11)
+    
+    (test (find-bop-chance (mb (make-enter-piece (make-pawn 'green 0))
+                               (make-enter-piece (make-pawn 'red 0))
+                               (make-enter-piece (make-pawn 'red 1))
+                               (make-move-piece-main (make-pawn 'green 0) 5 16)
+                               (make-move-piece-main (make-pawn 'red 0) 22 1)
+                               (make-move-piece-main (make-pawn 'red 1) 22 1))
+                           'red)
+          0)
+    
+    (test (find-bop-chance (mb (make-enter-piece (make-pawn 'green 0))
+                               (make-enter-piece (make-pawn 'red 0))
+                               (make-enter-piece (make-pawn 'red 1))
+                               (make-move-piece-main (make-pawn 'green 0) 5 16)
+                               (make-move-piece-main (make-pawn 'red 0) 22 1)
+                               (make-move-piece-main (make-pawn 'red 1) 22 1)
+                               (make-enter-piece (make-pawn 'red 2)))
+                           'red)
+          0)
+    
+    (test (find-bop-chance (mb (make-enter-piece (make-pawn 'green 0))
+                               (make-enter-piece (make-pawn 'red 0))
+                               (make-enter-piece (make-pawn 'red 1))
+                               (make-move-piece-main (make-pawn 'green 0) 5 16)
+                               (make-move-piece-main (make-pawn 'red 0) 22 1)
+                               (make-move-piece-main (make-pawn 'red 1) 22 2)
+                               (make-enter-piece (make-pawn 'red 2))
+                               (make-move-piece-main (make-pawn 'red 2) 22 1))
+                           'red)
+          0)
+    
+    (test-results))
+
+  (define (mb . moves)
+    (let-values ([(board bonus) (make-moves (new-board) moves)])
+      board))
+
+  #;
+  (begin
+    (define problem-board
+      (make-board (list (make-pawn 'yellow 0)
+                        (make-pawn 'blue 2)
+                        (make-pawn 'blue 3)
+                        (make-pawn 'red 3)
+                        (make-pawn 'yellow 3))
+                  `#68(() () () () () () () () () () () () 
+                          (,(make-pawn 'green 2)) () () () () ()
+                          (,(make-pawn 'blue 1)) () 
+                          (,(make-pawn 'green 1)) () () () () () 
+                          (,(make-pawn 'red 2)) () () () () () 
+                          (,(make-pawn 'green 0)) () () () () () 
+                          (,(make-pawn 'green 3)) () () () () () () 
+                          (,(make-pawn 'blue 0)) () () () () () 
+                          (,(make-pawn 'yellow 1)) () 
+                          (,(make-pawn 'red 0)) () () () () 
+                          (,(make-pawn 'red 1))
+                          (,(make-pawn 'yellow 2)) ()) 
+                  '((blue . #7(())) (green . #7(())) (red . #7(())) (yellow . #7(()))) 
+                  '()))
+    
+    #|
+first cut in new board representation
+  cpu time: 42710 real time: 47086 gc time: 1400
+  1353 candidates
+
+blockade move checking optimized:
+  cpu time: 5580 real time: 5828 gc time: 0
+  1353 candidates
+
+use move-piece instead of removing and adding:
+  cpu time: 4700 real time: 4939 gc time: 0
+  1353 candidates
+
+optimize blockade-in-the-way checking and macro-inline matching-pawns
+  cpu time: 2600 real time: 2779 gc time: 0
+  1353 candidates
+
+another new board representation (vector of loc's)
+  cpu time: 1710 real time: 1799 gc time: 0
+  1353 candidates
+|#
+    
+    (let ([candidates (time (search problem-board 'green (list 1 1 6 6)))])
+      (printf "~s candidates\n" (length candidates))))
+
+  
+  ;color green dice (2 2 5 5)
+  ;candidates 2893 (avg moves 6.952298651918424)
+  #;
+  (begin
+    (define problem-board2
+      (let loop ([board (new-board)]
+                 [ents (list
+                        (list (make-pawn 'blue 1) 'start)
+                        (list (make-pawn 'red 2) 'start)
+                        (list (make-pawn 'yellow 0) 'start)
+                        (list (make-pawn 'yellow 1) 'start)
+                        (list (make-pawn 'yellow 3) 'start)
+                        (list (make-pawn 'green 1) 5)
+                        (list (make-pawn 'green 3) 5)
+                        (list (make-pawn 'blue 0) 17)
+                        (list (make-pawn 'green 0) 21)
+                        (list (make-pawn 'red 1) 23)
+                        (list (make-pawn 'red 0) 25)
+                        (list (make-pawn 'red 3) 26)
+                        (list (make-pawn 'green 2) 27)
+                        (list (make-pawn 'blue 3) 45)
+                        (list (make-pawn 'blue 2) 47)
+                        (list (make-pawn 'yellow 2) 63))])
+        (cond
+          [(null? ents) board]
+          [else (loop (move-piece board (car (car ents)) (cadr (car ents)))
+                      (cdr ents))])))
+    
+    #;
+    (require (lib "xml.ss" "xml")
+             "parse.ss")
+    #;
+    (define (dump-out-candidates candidates)
+      (let loop ([i 0]
+                 [candidates candidates])
+        (unless (null? candidates)
+          (let ([candidate (car candidates)])
+            (call-with-output-file (build-path "problem-board-nexts"
+                                               (format "board~a.xml" i))
+              (lambda (port)
+                (write-xml/content (xexpr->xml (unparse-board (state-board candidate))) port))
+              'truncate
+              'text))
+          (loop (+ i 1) (cdr candidates)))))
+  
+    (define candidates2 (time (search problem-board2 'green (list 2 2 5 5))))
+    ;(dump-out-candidates candidates2)
+    (printf "~s candidates\n" (length candidates2)))
+  
+  
+  ;(require "gui.ss") (show-board problem-board)
+  #|
+cpu time: 12680 real time: 13855 gc time: 380
+candidates 2797 (avg moves 6.9878441186986056)
+board #5(struct:board (#3(struct:pawn yellow 0) #3(struct:pawn blue 2) #3(struct:pawn blue 3) #3(struct:pawn red 3) #3(struct:pawn yellow 3)) #68(() () () () () () () () () () () () (#3(struct:pawn green 2)) () () () () () (#3(struct:pawn blue 1)) () (#3(struct:pawn green 1)) () () () () () (#3(struct:pawn red 2)) () () () () () (#3(struct:pawn green 0)) () () () () () (#3(struct:pawn green 3)) () () () () () () (#3(struct:pawn blue 0)) () () () () () (#3(struct:pawn yellow 1)) () (#3(struct:pawn red 0)) () () () () (#3(struct:pawn red 1)) (#3(struct:pawn yellow 2)) ()) ((blue . #7(())) (green . #7(())) (red . #7(())) (yellow . #7(()))) ())
+|#
+
+  #| more problem boards:
+
+msec 5280
+candidates 2441 (avg moves 6.699303564113069)
+color blue dice (1 1 6 6)
+#(struct:board
+  #16(54 63 39 54 start start start 40 start start 14 start 60 15 6 0))
+
+msec 4750
+candidates 2709 (avg moves 6.959025470653378)
+color blue dice (1 1 6 6)
+#(struct:board
+  #16(42 39 53 41 11 25 27 35 start start 40 start start 61 59 60))
+
+msec 4100
+candidates 1492 (avg moves 7.138739946380697)
+color red dice (3 3 4 4)
+#(struct:board
+  #16(39
+      61
+      start
+      58
+      20
+      0
+      62
+      start
+      37
+      37
+      42
+      #(struct:home-row-loc 4 red)
+      57
+      start
+      start
+      41))
+|#
+  )
+  
\ No newline at end of file
diff --git a/collects/games/parcheesi/board.ss b/collects/games/parcheesi/board.ss
new file mode 100644
index 0000000000..b7e7172e32
--- /dev/null
+++ b/collects/games/parcheesi/board.ss
@@ -0,0 +1,348 @@
+
+(module board mzscheme
+  (require (lib "contract.ss")
+           (lib "list.ss")
+           (lib "etc.ss"))
+  
+  ;; color = (symbols 'blue 'green 'red 'yellow)
+  ;; color : color
+  ;; id : (union 0 1 2 3)
+  (define-struct pawn (color id index) (make-inspector))
+  
+  ;; v : (vectorof loc) length is always 16
+  (define-struct board (v) (make-inspector))
+  
+  ;; loc = (union 'start 'home number[main-loc] home-row-loc)
+  (define-struct home-row-loc (num color) (make-inspector))
+  
+  (define color (symbols 'red 'green 'blue 'yellow))
+  
+  (provide/contract 
+   (get-enter-pos (color . -> . number?))
+   (get-exit-pos (color . -> . number?))
+   (pawn-id (pawn? . -> . (integer-in 0 4)))
+   (pawn-color (pawn? . -> . color)))
+  
+  (provide (rename build-pawn make-pawn)
+           pawn?
+           new-board
+           for-each-pawn/loc
+           
+           (rename make-old-style-board make-board)
+           
+           board-start
+           
+           board-main-i
+           board-main-size
+           
+           board-home-row-i
+           board-home-row-size
+           
+           board-home
+           
+           move-piece
+           move-piece2
+           
+           safety?
+           
+           find-blockades/color
+           make-blockade
+           blockade-loc
+           blockade-p1
+           blockade-p2
+           find-blockade/between
+           
+           make-home-row-loc
+           home-row-loc-num
+           home-row-loc-color
+           home-row-loc?)
+  
+  ;; inline with a macro?
+  (define (for-each-pawn/loc/proc board f)
+    (let ([v (board-v board)])
+      (let loop ([i 16])
+        (unless (zero? i)
+          (f (vector-ref all-pawns (- i 1)) (vector-ref v (- i 1)))
+          (loop (- i 1))))))
+  
+  (define-syntax (for-each-pawn/loc stx)
+    (syntax-case stx ()
+      [(_ board (lambda (pawn loc) lam-body))
+       (let loop ([i 0]
+                  [lst '()])
+         (cond
+           [(= i 16) (with-syntax ([(bodies ...) lst])
+                       (syntax
+                        (let ([v (board-v board)])
+                          bodies ...
+                          (void))))]
+           [else (loop (+ i 1)
+                       (cons (with-syntax ([i i])
+                               (syntax (let ([loc (vector-ref v i)]
+                                             [pawn (vector-ref all-pawns i)])
+                                         lam-body)))
+                             lst))]))]
+      [(_ board f) (syntax (for-each-pawn/loc/proc board f))]))
+  
+  (define (make-old-style-board start main home-rows home)
+    (let* ([board (new-board)]
+           [v (board-v board)])
+      ;; can ignore start pawns
+      
+      ;; main pawns
+      (let loop ([i 0])
+        (cond
+          [(= i (vector-length main)) '()]
+          [else (for-each (lambda (pawn) (vector-set! v (pawn-index pawn) i))
+                          (vector-ref main i))
+                (loop (+ i 1))]))
+      
+      ;; home row pawns
+      (for-each
+       (lambda (hr)
+         (let ([vec (cdr hr)])
+           (let loop ([i 0])
+             (cond
+               [(= i (vector-length vec)) (void)]
+               [else 
+                (for-each (lambda (pawn) 
+                            (vector-set! v 
+                                         (pawn-index pawn) 
+                                         (make-home-row-loc i (pawn-color pawn))))
+                          (vector-ref vec i))
+                     (loop (+ i 1))]))))
+       home-rows)
+      
+      ;; home pawns
+      (for-each (lambda (home-pawn) (vector-set! v (pawn-index home-pawn) 'home)) home)
+      board))
+  
+  (define (new-board) (make-board (make-vector 16 'start)))
+  (define board-home-row-size 7)
+  (define board-main-size 68)
+  
+  ; (matching-pawns <board-exp> <pawn-id> <loc-id> <test-exp>)
+  (define-syntax (matching-pawns stx)
+    (syntax-case stx ()
+      [(_ board pawn loc test)
+       (and (identifier? (syntax pawn))
+            (identifier? (syntax loc)))
+       (let loop ([i 16]
+                  [sofar '()])
+         (cond
+           [(zero? i) (with-syntax ([(body ...) sofar])
+                        (syntax
+                         (let ([result '()]
+                               [v (board-v board)])
+                           body ...
+                           result)))]
+           [else (loop (- i 1)
+                       (cons
+                        (with-syntax ([i (- i 1)])
+                          (syntax
+                           (let ([loc (vector-ref v i)]
+                                 [pawn (vector-ref all-pawns i)])
+                             (when test
+                               (set! result (cons pawn result))))))
+                        sofar))]))]))
+
+  (define (board-main-i board i) (matching-pawns board pawn loc (equal? i loc)))
+  (define (board-home-row-i board color i) 
+    (matching-pawns board
+                    pawn
+                    loc
+                    (and (home-row-loc? loc)
+                         (= (home-row-loc-num loc) i)
+                         (eq? (home-row-loc-color loc) color))))
+  (define (board-start board) (matching-pawns board pawn loc (eq? loc 'start)))
+  (define (board-home board) (matching-pawns board pawn loc (eq? loc 'home)))
+  
+  ;; move-piece : board pawn loc -> board
+  (define (move-piece board pawn to)
+    (let ([new-board (copy-board board)])
+      (vector-set! (board-v new-board) (pawn-index pawn) to)
+      new-board))
+  
+  ;; move-piece2 : board pawn loc pawn loc -> board
+  (define (move-piece2 board pawn to pawn2 to2)
+    (let ([new-board (copy-board board)])
+      (vector-set! (board-v new-board) (pawn-index pawn) to)
+      (vector-set! (board-v new-board) (pawn-index pawn2) to2)
+      new-board))
+  
+  ;; copy-board : board -> board
+  (define (copy-board board)
+    (let ([v (board-v board)])
+      (make-board (build-vector 16 (lambda (i) (vector-ref v i))))))
+  
+  ;; entry points for the four colors
+  (define enters '((green . 5)
+                   (red . 22)
+                   (blue . 39)
+                   (yellow . 56)))
+  (define (get-enter-pos color) (cdr (assq color enters)))  
+  
+  ;; the points where the four colors go off into their
+  ;; own sections of the board.
+  (define exits '((green . 0)
+                  (red . 17)
+                  (blue . 34)
+                  (yellow . 51)))
+  (define (get-exit-pos color) (cdr (assq color exits)))
+  
+  (define safeties (append (map cdr enters)
+                           (map cdr exits)
+                           (list 12
+                                 (+ 12 17)
+                                 (+ 12 17 17)
+                                 (+ 12 17 17 17))))
+  (define (safety? i) (memq i safeties))
+  
+  ;; find-blockade/between : board loc loc -> (union loc #f)
+  (define (find-blockade/between board start end)
+    (find-blockade/cases (find-blockades board) start end))
+  
+  ;; find-blockades : board -> (listof loc)
+  (define (find-blockades board)
+    (let ([ht (make-hash-table 'equal)]
+          [blockades '()])
+      (for-each-pawn/loc
+       board
+       (lambda (pawn loc)
+         (when (hash-table-get ht
+                               loc
+                               (lambda ()
+                                 (hash-table-put! ht loc #t)
+                                 #f))
+           (set! blockades (cons loc blockades)))))
+      blockades))
+  
+  ;; find-blockade/cases : (listof loc) loc loc -> (union loc #f)
+  (define (find-blockade/cases blockades start end)
+    (cond
+      [(and (number? start) (number? end))
+       (if (<= start end)
+           (find-blockade/between-main blockades start end)
+           (or (find-blockade/between-main blockades start (- board-main-size 1))
+               (find-blockade/between-main blockades 0 end)))]
+      [(and (number? start) (home-row-loc? end))
+       (or (find-blockade/cases blockades start (get-exit-pos (home-row-loc-color end)))
+           (find-blockade/between-home-row blockades
+                                           (home-row-loc-color end)
+                                           0
+                                           (home-row-loc-num end)))]
+      [(and (home-row-loc? start) (home-row-loc? end))
+       (find-blockade/between-home-row blockades
+                                       (home-row-loc-color start)
+                                       (home-row-loc-num start)
+                                       (home-row-loc-num end))]
+      [(not (loc<=? start end))
+       (error 'find-blockade/between "expected locs in order, got ~e and ~e" start end)]
+      [(or (eq? start 'home) (eq? end 'home))
+       (error 'find-blockade/between "cannot accept 'home as argument, got ~e and ~e" start end)]
+      [(or (eq? start 'start) (eq? end 'start))
+       (error 'find-blockade/between "cannot accept 'start as argument, got ~e and ~e" start end)]
+      [else 
+       (error 'find-blockade/between "unknown arguments ~e and ~e" start end)]))
+  
+  (define (find-blockade/between-main blockades start end)
+    (ormap (lambda (blockade) (and (number? blockade)
+                                   (<= start blockade end)
+                                   blockade))
+           blockades))
+  
+  (define (find-blockade/between-home-row blockades color start end)
+    (ormap (lambda (blockade) (and (home-row-loc? blockade)
+                                   (eq? color (home-row-loc-color blockade))
+                                   (<= start (home-row-loc-num blockade) end)
+                                   blockade))
+           blockades))
+       
+  ;; loc : loc
+  ;; p1 : pawn
+  ;; p2 : pawn
+  ;; (pawn<=? p1 p2) is true
+  (define-struct blockade (loc p1 p2) (make-inspector))
+
+  ;; find-blockades/color : board color -> (listof blockade)
+  (define (find-blockades/color board color)
+    (let ([ht (make-hash-table 'equal)]
+          [v (board-v board)]
+          [offset (find-pawn-index color 0)])
+      (let loop ([i 0]
+                 [blockades null])
+        (cond
+          [(= i 4) blockades]
+          [else
+           (let ([loc (vector-ref v (+ offset i))])
+             (cond
+               [(eq? loc 'start) (loop (+ i 1) blockades)]
+               [(eq? loc 'home) (loop (+ i 1) blockades)]
+               [(hash-table-get ht loc (lambda ()
+                                         (hash-table-put! ht loc i)
+                                         #f))
+                =>
+                (lambda (old-i)
+                  (loop (+ i 1)
+                        (cons (make-blockade loc 
+                                             (vector-ref all-pawns (+ offset old-i))
+                                             (vector-ref all-pawns (+ offset i)))
+                              blockades)))]
+               [else (loop (+ i 1) blockades)]))]))))
+  
+  (define (loc<=? l1 l2) (<= (loc->id l1) (loc->id l2)))
+  
+  (define (loc->id loc)
+    (cond
+      [(eq? loc 'start) 0]
+      [(number? loc) (+ loc 1)]
+      [(eq? loc 'home) 1000]
+      [(home-row-loc? loc) (+ 100
+                              (* (color->int (home-row-loc-color loc))
+                                 100)
+                              (home-row-loc-num loc))]
+      [else (error 'loc->id "expected a loc, got ~e" loc)]))
+  
+  (define (build-pawn color id) (make-pawn color id (find-pawn-index color id)))
+  (define (find-pawn-index color id) (+ (* (color->int color) 4) id))
+  
+  (define (pawn<=? p1 p2)
+    (if (eq? (pawn-color p1) (pawn-color p2))
+        (<= (pawn-id p1) (pawn-id p2))
+        (color<= (pawn-color p1) (pawn-color p2))))
+  
+  (define (color<= c1 c2)
+    (<= (color->int c1) (color->int c2)))
+  
+  (define (color->int c)
+    (case c
+      [(blue) 0]
+      [(green) 1]
+      [(red) 2]
+      [(yellow) 3]
+      [else (error 'color->int "unknown color ~e" c)]))
+  
+  
+  (define all-pawns
+    (vector (build-pawn 'blue 0)
+            (build-pawn 'blue 1)
+            (build-pawn 'blue 2)
+            (build-pawn 'blue 3)
+            (build-pawn 'green 0)
+            (build-pawn 'green 1)
+            (build-pawn 'green 2)
+            (build-pawn 'green 3)
+            (build-pawn 'red 0)
+            (build-pawn 'red 1)
+            (build-pawn 'red 2)
+            (build-pawn 'red 3)
+            (build-pawn 'yellow 0)
+            (build-pawn 'yellow 1)
+            (build-pawn 'yellow 2)
+            (build-pawn 'yellow 3)))
+  
+  (let loop ([i 0])
+    (unless (= i 16)
+      (unless (= i (pawn-index (vector-ref all-pawns i)))
+        (error 'mismatch "~s ~s" i (vector-ref all-pawns i)))
+      (loop (+ i 1)))))
\ No newline at end of file
diff --git a/collects/games/parcheesi/die.ss b/collects/games/parcheesi/die.ss
new file mode 100644
index 0000000000..6eb37739bf
--- /dev/null
+++ b/collects/games/parcheesi/die.ss
@@ -0,0 +1,74 @@
+(module die mzscheme
+  (require (lib "mred.ss" "mred")
+           (lib "class.ss"))
+  
+  (provide die%)
+
+  (define die%
+    (class canvas%
+      (inherit get-dc get-client-size refresh)
+      (init-field [digit #f])
+      (define/public (set-digit d) 
+        (unless (equal? digit d)
+          (set! digit d)
+          (refresh)))
+      (init-field [dim? #f])
+      (define/public (set-dim d)
+        (unless (equal? dim? d)
+          (set! dim? d)
+          (refresh)))
+      (define/override (on-paint)
+        (let ([dc (get-dc)])
+          (let-values ([(w h) (get-client-size)])
+            (when digit
+              (send dc set-pen (send the-pen-list find-or-create-pen (if dim? "dark gray" "black") 1 'solid))
+              (send dc set-brush (send the-brush-list find-or-create-brush "white" 'solid))
+              (send dc draw-rounded-rectangle 0 0 w h)
+              (send dc set-brush (send the-brush-list find-or-create-brush (if dim? "dark gray" "black") 'solid))
+              (let ([draw-circle
+                     (lambda (mx my)
+                       (send dc draw-ellipse
+                             (- (* mx w) (/ w 12)) 
+                             (- (* my h) (/ h 12))
+                             (/ w 6)
+                             (/ h 6)))]
+                    [in (- 1/3 1/24)]
+                    [out (+ 2/3 1/24)]
+                    [draw-text
+                     (lambda (str)
+                       (let-values ([(tw th _1 _2) (send dc get-text-extent str)])
+                         (send dc draw-text 
+                               str
+                               (- (/ w 2) (/ tw 2))
+                               (- (/ h 2) (/ th 2)))))])
+                (case digit
+                  [(1) (draw-circle 1/2 1/2)]
+                  [(2) (draw-circle in in)
+                       (draw-circle out out)]
+                  [(3) (draw-circle in in)
+                       (draw-circle 1/2 1/2)
+                       (draw-circle out out)]
+                  [(4) (draw-circle in in)
+                       (draw-circle in out)
+                       (draw-circle out in)
+                       (draw-circle out out)]
+                  [(5) (draw-circle in in)
+                       (draw-circle in out)
+                       (draw-circle 1/2 1/2)
+                       (draw-circle out in)
+                       (draw-circle out out)]
+                  [(6) (draw-circle in in)
+                       (draw-circle in 1/2)
+                       (draw-circle in out)
+                       (draw-circle out in)
+                       (draw-circle out 1/2)
+                       (draw-circle out out)]
+                  [(10) (draw-text "10")]
+                  [(20) (draw-text "20")]))))))
+      (super-new (style '(transparent)))
+      (send (get-dc) set-smoothing 'aligned)
+      (inherit min-width min-height stretchable-width stretchable-height)
+      (min-width 48)
+      (min-height 48)
+      (stretchable-width #f)
+      (stretchable-height #f))))
\ No newline at end of file
diff --git a/collects/games/parcheesi/doc.txt b/collects/games/parcheesi/doc.txt
new file mode 100644
index 0000000000..9683ad5eb0
--- /dev/null
+++ b/collects/games/parcheesi/doc.txt
@@ -0,0 +1,52 @@
+_Parcheesi_
+
+Parcheesi is a race game for four players. The goal is for
+each player to move their pieces from the starting position
+(the circles in the corners) to the home square (in the
+center of the board), passing a nearly complete loop around
+the board in the counter-clockwise direction and then heads
+up towards the main row. For example, the green player
+enters from the bottom right, travels around the board on
+the light blue squares, passing each of the corners, until
+it reaches the middle of the bottom of the board, where it
+turns off the light blue squares and heads into the central
+region.
+
+On each turn, the player rolls two dice and advances the
+pawn, based on the die rolls. Typically the players may move
+a pawn for each die. The pawn moves by the number of pips
+showing on the die and all of the dice must be used to
+complete a turn.
+
+There are some exceptions, however:
+
+  - you must roll a 5 (either directly or via summing) to
+    enter from the start area to the main ring.
+
+  - if two pieces of the same color occupy a square, no
+    pieces may pass that square.
+
+  - if an opponent's piece lands on your piece, you piece is
+    returned to the starting area and the opponent receives
+    a bonus of 20 (which is treated just as if they had
+    rolled a 20 on the dice)
+
+  - if your piece makes it home (and it must do so by exact
+    count) you get a bonus of 10, to be used as an
+    additional die roll.
+
+These rules induce a number of unexpected corner cases, but
+the GUI only lets you make legal moves. Watch the space
+along the bottom of the board for reasons why a move is
+illegal or why you have not used all of your die rolls.
+
+The automated players are:
+
+ - Reckless Renee, who she tries to maximize the chances
+   that someone else bops her.
+
+ - Polite Polly, who tries to minimize the distance her
+   pawns move ("no, after _you_. I insist."), and
+
+ - Amazing Grace, who tries to minimize the chance she gets
+   bopped while moving as far as possible.
diff --git a/collects/games/parcheesi/gui.ss b/collects/games/parcheesi/gui.ss
new file mode 100644
index 0000000000..445f31f898
--- /dev/null
+++ b/collects/games/parcheesi/gui.ss
@@ -0,0 +1,594 @@
+
+(module gui mzscheme
+  (require "board.ss"
+	   "moves.ss"
+           (lib "mred.ss" "mred")
+           (lib "class.ss")
+           (lib "list.ss")
+           (lib "etc.ss"))
+
+  (provide show-board
+           board-canvas%
+           draw-board
+           for-each-piece/position
+           find-main-coordinates
+           find-home-row-coordinates
+           get-cell-size
+           get-piece-size
+           pawn-drawn-color
+           
+           (struct home-row-c (count color))
+           (struct main-c (count))
+           (struct start-c (color))
+           (struct home-c (color)))
+  
+  ;; a coordinate is either
+  ;;   - (make-home-row-c number color)
+  ;;   - (make-main-c number)
+  ;;   - (make-start-c color)
+  ;;   - (make-home-c color)
+  ;; inspectors are to allow comparison with equal?
+  (define-struct home-row-c (count color) (make-inspector))
+  (define-struct main-c (count) (make-inspector))
+  (define-struct start-c (color) (make-inspector))
+  (define-struct home-c (color) (make-inspector))
+  
+  (define (get-cell-size horizontal? w h)
+    (if horizontal?
+        (values (* w 1/9) (* h 1/24))
+        (values (* w 1/24) (* h 1/9))))
+  
+  (define colors
+    '((green . "limegreen")
+      (red . "red")
+      (yellow . "gold")
+      (blue . "blue")
+      (black . "black")
+      (safety . "purple")
+      (track-background . "light blue")))
+  
+  (define (pawn-drawn-color c)
+    (let* ([clr-str (assq c colors)]
+           [color-obj (make-object color% (cdr clr-str))]
+           [move-up (lambda (x) (+ x (quotient (- 255 x) 3)))]
+           [red (move-up (send color-obj red))]
+           [green (move-up (send color-obj green))]
+           [blue (move-up (send color-obj blue))])
+      (send color-obj set red green blue)
+      color-obj))
+
+  (define circle-gap 1/20)
+  
+  (define (set-color dc color)
+    (send dc set-pen (send the-pen-list find-or-create-pen  (cdr (assq color colors)) 1 'solid))
+    (send dc set-brush (send the-brush-list find-or-create-brush (cdr (assq color colors)) 'solid)))
+  
+  (define draw-board
+    (opt-lambda (board dc w h dx dy draw-pieces?)
+      (let ([smoothing (send dc get-smoothing)])
+        (send dc set-smoothing 'aligned)
+        (set-color dc 'track-background)
+        (send dc draw-rectangle (+ dx 0) (+ dy (* h 1/3)) w (* h 1/3))
+        (send dc draw-rectangle (+ dx (* w 1/3)) (+ dy 0) (* w 1/3) h)
+        
+        (set-color dc 'blue)
+        (send dc draw-ellipse
+              (+ dx (* w circle-gap)) (+ dy (* h circle-gap 1/2))
+              (- (/ w 3) (* w circle-gap)) (- (/ h 3) (* h circle-gap)))
+        (send dc draw-rectangle (+ dx (* w (- 1/2 1/18))) (+ dy 0) (* w 1/9) (/ h 3))
+        (send dc draw-polygon 
+              (list (make-object point% (* w 1/3) (* h 1/3))
+                    (make-object point% (* w 2/3) (* h 1/3))
+                    (make-object point% (* w 1/2) (* h 1/2)))
+              dx
+              dy)
+        
+        (set-color dc 'red)
+        (send dc draw-ellipse 
+              (+ dx (* w 2/3) (* h circle-gap 1/2)) 
+              (+ dy (* h circle-gap))
+              (- (/ w 3) (* w circle-gap)) 
+              (- (/ h 3) (* h circle-gap)))
+        (send dc draw-rectangle (+ dx (* w 2/3)) (+ dy (* h (- 1/2 1/18))) (/ w 3) (* h 1/9))
+        (send dc draw-polygon 
+              (list (make-object point% (* w 2/3) (* h 1/3))
+                    (make-object point% (* w 2/3) (* h 2/3))
+                    (make-object point% (* w 1/2) (* h 1/2)))
+              dx
+              dy)
+        
+        (set-color dc 'yellow)
+        (send dc draw-ellipse 
+              (+ dx (* w circle-gap 1/2)) (+ dy (* h 2/3))
+              (- (/ w 3) (* w circle-gap)) (- (/ h 3) (* h circle-gap)))
+        (send dc draw-rectangle (+ dx 0) (+ dy (* h (- 1/2 1/18))) (/ w 3) (* h 1/9))
+        (send dc draw-polygon 
+              (list (make-object point% (* w 1/3) (* h 1/3))
+                    (make-object point% (* w 1/3) (* h 2/3))
+                    (make-object point% (* w 1/2) (* h 1/2)))
+              dx
+              dy)
+        
+        (set-color dc 'green)
+        (send dc draw-ellipse 
+              (+ dx (* w 2/3)) (+ dy (* h 2/3) (* h circle-gap 1/2))
+              (- (/ w 3) (* w circle-gap)) (- (/ h 3) (* h circle-gap)))
+        (send dc draw-rectangle (+ dx (* w (- 1/2 1/18))) (+ dy (* h 2/3)) (* w 1/9) (/ h 3))
+        (send dc draw-polygon 
+              (list (make-object point% (* w 1/3) (* h 2/3))
+                    (make-object point% (* w 2/3) (* h 2/3))
+                    (make-object point% (* w 1/2) (* h 1/2)))
+              dx
+              dy)
+        
+        (set-color dc 'safety)
+        
+        (send dc draw-rectangle 
+              (+ dx (* w 4/9))
+              (+ dy 0)
+              (* w 1/9)
+              (* h 1/3 1/8))
+        (send dc draw-rectangle 
+              (+ dx (* w 4/9))
+              (+ dy (* h (- 1 (* 1/3 1/8))))
+              (* w 1/9)
+              (* h 1/3 1/8))
+        (send dc draw-rectangle 
+              (+ dx (* w 5/9))
+              (+ dy (* h 1/3 4/8))
+              (* w 1/9)
+              (* h 1/3 1/8))
+        (send dc draw-rectangle 
+              (+ dx (* w 3/9))
+              (+ dy (* h 19/24))
+              (* w 1/9)
+              (* h 1/3 1/8))
+        
+        (send dc draw-rectangle 
+              (+ dx (* w (- 1 (* 1/3 1/8))))
+              (+ dy (* h 4/9))
+              (* w 1/3 1/8)
+              (* h 1/9))
+        (send dc draw-rectangle 
+              (+ dx 0)
+              (+ dy (* h 4/9))
+              (* w 1/3 1/8)
+              (* h 1/9))
+        (send dc draw-rectangle 
+              (+ dx (* w 4/24))
+              (+ dy (* h 1/3))
+              (* w 1/3 1/8)
+              (* h 1/3 1/3))
+        (send dc draw-rectangle 
+              (+ dx (* w 19/24))
+              (+ dy (* h 5/9))
+              (* w 1/3 1/8)
+              (* h 1/3 1/3))
+        
+        ;; blue entry
+        (send dc draw-rectangle 
+              (+ dx (* w 3/9))
+              (+ dy (* h 1/3 4/8))
+              (* w 1/9)
+              (* h 1/3 1/8))
+        
+        ;; green entry
+        (send dc draw-rectangle 
+              (+ dx (* w 5/9))
+              (+ dy (* h 19/24))
+              (* w 1/9)
+              (* h 1/24))
+        
+        ;; yellow entry
+        (send dc draw-rectangle 
+              (+ dx (* w 4/24))
+              (+ dy (* h 5/9))
+              (* w 1/24)
+              (* h 1/9))
+        
+        ;; red entry
+        (send dc draw-rectangle 
+              (+ dx (* w 19/24))
+              (+ dy (* h 1/3))
+              (* w 1/24)
+              (* h 1/9))
+        
+        (set-color dc 'blue)
+        (send dc draw-polygon
+              (list (make-object point% (* w 3/9) (* h 4/24))
+                    (make-object point% (* w 2/9) (* h 5/24))
+                    (make-object point% (* w 4/9) (* h 5/24)))
+              dx
+              dy)
+        
+        (set-color dc 'green)
+        (send dc draw-polygon 
+              (list (make-object point% (* w 5/9) (* h 19/24))
+                    (make-object point% (* w 6/9) (* h 20/24))
+                    (make-object point% (* w 7/9) (* h 19/24)))
+              dx
+              dy)
+        
+        
+        (set-color dc 'yellow)
+        (send dc draw-polygon 
+              (list (make-object point% (* w 4/24) (* h 6/9))
+                    (make-object point% (* w 5/24) (* h 5/9))
+                    (make-object point% (* w 5/24) (* h 7/9)))
+              dx
+              dy)
+        
+        
+        (set-color dc 'red)
+        (send dc draw-polygon
+              (list (make-object point% (* w 20/24) (* h 3/9))
+                    (make-object point% (* w 19/24) (* h 4/9))
+                    (make-object point% (* w 19/24) (* h 2/9)))
+              dx
+              dy)
+        
+        (set-color dc 'black)
+        
+        (let loop ([i 7])
+          (unless (zero? i)
+            (send dc draw-line 
+                  (+ dx (* w 1/3))
+                  (+ dy (+ (* h 2/3) (* (* h 1/3) (/ i 8))))
+                  (+ dx (* w 2/3))
+                  (+ dy (+ (* h 2/3) (* (* h 1/3) (/ i 8)))))
+            (send dc draw-line 
+                  (+ dx (* w 1/3))
+                  (+ dy (* (* h 1/3) (/ i 8)))
+                  (+ dx (* w 2/3))
+                  (+ dy (* (* h 1/3) (/ i 8))))
+            (send dc draw-line 
+                  (+ dx (+ (* w 2/3) (* (* w 1/3) (/ i 8))))
+                  (+ dy (* h 1/3))
+                  (+ dx (+ (* w 2/3) (* (* w 1/3) (/ i 8))))
+                  (+ dy (* h 2/3)))
+            (send dc draw-line 
+                  (+ dx (* (* w 1/3) (/ i 8)))
+                  (+ dy (* h 1/3))
+                  (+ dx (* (* w 1/3) (/ i 8)))
+                  (+ dy (* h 2/3)))
+            (loop (- i 1))))
+        
+        (when draw-pieces?
+          (draw-pieces board dc w h dx dy))
+        
+        (send dc set-smoothing smoothing))))
+  
+  ;; piece : color left top coordinate -> void
+  (define (for-each-piece/position board w h piece)
+    (let* ([piece-size (get-piece-size w h)]
+           [call-out
+            (lambda (ent x y horizontal? coordinate)
+              (let* ([pawn (car ent)])
+                (cond
+                  [(null? (cdr ent))
+                   (piece pawn (- x (/ piece-size 2)) (- y (/ piece-size 2)) coordinate)]
+                  [else 
+                   (let ([pawn2 (cadr ent)])
+                     (cond
+                       [horizontal?
+                        (piece pawn (- x piece-size) (- y (/ piece-size 2)) coordinate)
+                        (piece pawn2 x (- y (/ piece-size 2)) coordinate)]
+                       [else
+                        (piece pawn (- x (/ piece-size 2)) (- y piece-size) coordinate)
+                        (piece pawn2 (- x (/ piece-size 2)) y coordinate)]))])))])
+      
+      ;; main board
+      (let loop ([i board-main-size])
+        (unless (zero? i)
+          (let ([ent (board-main-i board (- i 1))])
+            (unless (null? ent)
+              (let-values ([(x y horizontal?) (find-main-coordinates (- i 1) w h)])
+                (call-out ent x y horizontal? (make-main-c (- i 1)))))
+            (loop (- i 1)))))
+      
+      ;; home row
+      (let ([handle-home-row
+             (lambda (color)
+               (let loop ([i board-home-row-size])
+                 (unless (zero? i)
+                   (let ([ent (board-home-row-i board color (- i 1))])
+                     (unless (null? ent)
+                       (let-values ([(x y horizontal?) (find-home-row-coordinates color (- i 1) w h)])
+                         (call-out ent x y horizontal? (make-home-row-c (- i 1) color)))))
+                   (loop (- i 1)))))])
+        (handle-home-row 'red)
+        (handle-home-row 'green)
+        (handle-home-row 'blue)
+        (handle-home-row 'yellow))
+      
+      ;; home and start
+      (let ([handle-home/start
+             (lambda (color select coordinates coord horiz?)
+               (let* ([pawns (filter (lambda (x) (eq? (pawn-color x) color)) (select board))]
+                      [num (length pawns)])
+                 (let-values ([(mx my) (apply values (cdr (assoc color (coordinates w h piece-size))))])
+                   (let ([do (lambda (pawn fx fy)
+                               (piece pawn
+                                      (+ mx (* piece-size fx))
+                                      (+ my (* piece-size fy))
+                                      coord))])
+                     (cond
+                       [(= num 4)
+                        (do (list-ref pawns 3) 0 0)
+                        (do (list-ref pawns 2) -1 0)
+                        (do (list-ref pawns 1) 0 -1)
+                        (do (list-ref pawns 0) -1 -1)]
+                       [(and horiz? (= num 3))
+                        (do (list-ref pawns 2) 0 -1/2)
+                        (do (list-ref pawns 1) -1 0)
+                        (do (list-ref pawns 0) -1 -1)]
+                       [(= num 3)
+                        (do (list-ref pawns 2) -1/2 0)
+                        (do (list-ref pawns 1) 0 -1)
+                        (do (list-ref pawns 0) -1 -1)]
+                       [(and horiz? (= num 2))
+                        (do (list-ref pawns 1) -1/2 -1)
+                        (do (list-ref pawns 0) -1/2 0)]
+                       [(= num 2)
+                        (do (list-ref pawns 1) -1 -1/2)
+                        (do (list-ref pawns 0) 0 -1/2)]
+                       [(= num 1)
+                        (do (list-ref pawns 0) -1/2 -1/2)])))))])
+        (handle-home/start 'red board-home at-home-coordinates (make-home-c 'red) #t)
+        (handle-home/start 'green board-home at-home-coordinates (make-home-c 'green) #f)
+        (handle-home/start 'blue board-home at-home-coordinates (make-home-c 'blue) #f)
+        (handle-home/start 'yellow board-home at-home-coordinates (make-home-c 'yellow) #t)
+        (handle-home/start 'red board-start at-start-coordinates (make-start-c 'red) #t)
+        (handle-home/start 'green board-start at-start-coordinates (make-start-c 'green) #t)
+        (handle-home/start 'blue board-start at-start-coordinates (make-start-c 'blue) #t)
+        (handle-home/start 'yellow board-start at-start-coordinates (make-start-c 'yellow) #t))))
+  
+  (define (draw-pieces board dc w h dx dy)
+    (for-each-piece/position 
+     board w h
+     (lambda (pawn x y coord)
+       (let ([font (get-number-font (pawn-color pawn) w h)]
+             [str (number->string (pawn-id pawn))]
+             [old-font (send dc get-font)]
+             [old-fore (send dc get-text-foreground)]
+             [size (get-piece-size w h)]
+             [old-pen (send dc get-pen)]
+             [old-brush (send dc get-brush)])
+         (send dc set-pen (send the-pen-list find-or-create-pen  "black" 1 'solid))
+         (send dc set-brush (send the-brush-list find-or-create-brush (pawn-drawn-color (pawn-color pawn)) 'solid))
+         (send dc draw-ellipse (+ dx x) (+ dy y) size size)
+         (send dc set-font font)
+         (send dc set-text-foreground (get-number-color (pawn-color pawn)))
+         (send dc set-pen old-pen)
+         (send dc set-brush old-brush)
+         (send dc set-font old-font)))))
+  
+  (define home-row-coordinates
+    (list (list 'red
+                #f
+                (vector (cons (+ 22/24 1/48) 1/2)
+                        (cons (+ 21/24 1/48) 1/2)
+                        (cons (+ 20/24 1/48) 1/2)
+                        (cons (+ 19/24 1/48) 1/2)
+                        (cons (+ 18/24 1/48) 1/2)
+                        (cons (+ 17/24 1/48) 1/2)
+                        (cons (+ 16/24 1/48) 1/2)))
+          (list 'yellow
+                #f
+                (vector (cons (+ 1/24 1/48) 1/2)
+                        (cons (+ 2/24 1/48) 1/2)
+                        (cons (+ 3/24 1/48) 1/2)
+                        (cons (+ 4/24 1/48) 1/2)
+                        (cons (+ 5/24 1/48) 1/2)
+                        (cons (+ 6/24 1/48) 1/2)
+                        (cons (+ 7/24 1/48) 1/2)))
+          (list 'blue
+                #t
+                (vector (cons 1/2 (+ 1/24 1/48))
+                        (cons 1/2 (+ 2/24 1/48))
+                        (cons 1/2 (+ 3/24 1/48))
+                        (cons 1/2 (+ 4/24 1/48))
+                        (cons 1/2 (+ 5/24 1/48))
+                        (cons 1/2 (+ 6/24 1/48))
+                        (cons 1/2 (+ 7/24 1/48))))
+          (list 'green
+                #t
+                (vector (cons 1/2 (+ 22/24 1/48))
+                        (cons 1/2 (+ 21/24 1/48))
+                        (cons 1/2 (+ 20/24 1/48))
+                        (cons 1/2 (+ 19/24 1/48))
+                        (cons 1/2 (+ 18/24 1/48))
+                        (cons 1/2 (+ 17/24 1/48))
+                        (cons 1/2 (+ 16/24 1/48))))))
+
+  (define (find-home-row-coordinates color index w h)
+    (let ([ent (assq color home-row-coordinates)])
+      (if ent
+          (let ([v (caddr ent)])
+            (if (< index (vector-length v))
+                (let ([crds (vector-ref v index)])
+                  (values (* w (car crds)) (* h (cdr crds)) (cadr ent)))
+                (values 0 0 #f)))
+          (values 0 0 #f))))
+  
+  (define main-coordinates
+    (vector 
+     ;; safety between yellow and green
+     (list 1/2 (+ 23/24 1/48) #t)
+            
+     ;; row to the left of green, going up
+     (list (+ 5/9 1/18) (+ 23/24 1/48) #t)
+     (list (+ 5/9 1/18) (+ 22/24 1/48) #t)
+     (list (+ 5/9 1/18) (+ 21/24 1/48) #t)
+     (list (+ 5/9 1/18) (+ 20/24 1/48) #t)
+     (list (+ 5/9 1/18) (+ 19/24 1/48) #t)
+     (list (+ 5/9 1/18) (+ 18/24 1/48) #t)
+     (list (+ 5/9 1/18) (+ 17/24 1/48) #t)
+     (list (+ 5/9 1/18) (+ 16/24 1/48) #t)
+     
+     ;; row above green, going right
+     (list (+ 16/24 1/48) (+ 5/9 1/18) #f)
+     (list (+ 17/24 1/48) (+ 5/9 1/18) #f)
+     (list (+ 18/24 1/48) (+ 5/9 1/18) #f)
+     (list (+ 19/24 1/48) (+ 5/9 1/18) #f)
+     (list (+ 20/24 1/48) (+ 5/9 1/18) #f)
+     (list (+ 21/24 1/48) (+ 5/9 1/18) #f)
+     (list (+ 22/24 1/48) (+ 5/9 1/18) #f)
+     (list (+ 23/24 1/48) (+ 5/9 1/18) #f)
+     
+     ;; safety between green and red
+     (list (+ 23/24 1/48) 1/2 #f)
+     
+     ;; row below red, going left
+     (list (+ 23/24 1/48) (+ 3/9 1/18) #f)
+     (list (+ 22/24 1/48) (+ 3/9 1/18) #f)
+     (list (+ 21/24 1/48) (+ 3/9 1/18) #f)
+     (list (+ 20/24 1/48) (+ 3/9 1/18) #f)
+     (list (+ 19/24 1/48) (+ 3/9 1/18) #f)
+     (list (+ 18/24 1/48) (+ 3/9 1/18) #f)
+     (list (+ 17/24 1/48) (+ 3/9 1/18) #f)
+     (list (+ 16/24 1/48) (+ 3/9 1/18) #f)
+
+     ;; row to the left of red, going up
+     (list (+ 5/9 1/18) (+ 7/24 1/48) #t)
+     (list (+ 5/9 1/18) (+ 6/24 1/48) #t)
+     (list (+ 5/9 1/18) (+ 5/24 1/48) #t)
+     (list (+ 5/9 1/18) (+ 4/24 1/48) #t)
+     (list (+ 5/9 1/18) (+ 3/24 1/48) #t)
+     (list (+ 5/9 1/18) (+ 2/24 1/48) #t)
+     (list (+ 5/9 1/18) (+ 1/24 1/48) #t)
+     (list (+ 5/9 1/18) (+ 0/24 1/48) #t)
+          
+     ;; safety between red and blue
+     (list 1/2 (+ 0/24 1/48) #t)
+
+     ;; row to the right of blue, going down
+     (list (+ 3/9 1/18) (+ 0/24 1/48) #t)
+     (list (+ 3/9 1/18) (+ 1/24 1/48) #t)
+     (list (+ 3/9 1/18) (+ 2/24 1/48) #t)
+     (list (+ 3/9 1/18) (+ 3/24 1/48) #t)
+     (list (+ 3/9 1/18) (+ 4/24 1/48) #t)
+     (list (+ 3/9 1/18) (+ 5/24 1/48) #t)
+     (list (+ 3/9 1/18) (+ 6/24 1/48) #t)
+     (list (+ 3/9 1/18) (+ 7/24 1/48) #t)
+     
+     ;; row below blue, going left
+     (list (+ 7/24 1/48) (+ 3/9 1/18) #f)
+     (list (+ 6/24 1/48) (+ 3/9 1/18) #f)
+     (list (+ 5/24 1/48) (+ 3/9 1/18) #f)
+     (list (+ 4/24 1/48) (+ 3/9 1/18) #f)
+     (list (+ 3/24 1/48) (+ 3/9 1/18) #f)
+     (list (+ 2/24 1/48) (+ 3/9 1/18) #f)
+     (list (+ 1/24 1/48) (+ 3/9 1/18) #f)
+     (list (+ 0/24 1/48) (+ 3/9 1/18) #f)
+     
+     ;; safety between blue and yellow
+     (list (+ 0/24 1/48) 1/2 #f)
+
+     ;; row above yellow to the right
+     (list (+ 0/24 1/48) (+ 5/9 1/18) #f)
+     (list (+ 1/24 1/48) (+ 5/9 1/18) #f)
+     (list (+ 2/24 1/48) (+ 5/9 1/18) #f)
+     (list (+ 3/24 1/48) (+ 5/9 1/18) #f)
+     (list (+ 4/24 1/48) (+ 5/9 1/18) #f)
+     (list (+ 5/24 1/48) (+ 5/9 1/18) #f)
+     (list (+ 6/24 1/48) (+ 5/9 1/18) #f)
+     (list (+ 7/24 1/48) (+ 5/9 1/18) #f)
+     
+     ;; row to the right of yellow, going down
+     (list (+ 3/9 1/18) (+ 16/24 1/48) #t)
+     (list (+ 3/9 1/18) (+ 17/24 1/48) #t)
+     (list (+ 3/9 1/18) (+ 18/24 1/48) #t)
+     (list (+ 3/9 1/18) (+ 19/24 1/48) #t)
+     (list (+ 3/9 1/18) (+ 20/24 1/48) #t)
+     (list (+ 3/9 1/18) (+ 21/24 1/48) #t)
+     (list (+ 3/9 1/18) (+ 22/24 1/48) #t)
+     (list (+ 3/9 1/18) (+ 23/24 1/48) #t)
+     ))
+            
+  
+  (define (find-main-coordinates index w h)
+    (let ([e (vector-ref main-coordinates index)])
+      (values (* w (car e)) (* h (cadr e)) (caddr e))))
+    
+  (define (at-start-coordinates w h piece-size)
+    `((blue ,(* w (+ 1/6 (* circle-gap 1/2))) ,(* h 1/6))
+      (red ,(* w 5/6) ,(* h (+ 1/6 (* circle-gap 1/2))))
+      (green ,(* w (- 5/6 (* circle-gap 1/2))) ,(* h 5/6))
+      (yellow ,(* w 1/6) ,(* h (- 5/6 (* circle-gap 1/2))))))
+  
+  (define (at-home-coordinates w h piece-size)
+    `((blue ,(* w 1/2) ,(+ (* h 1/3) piece-size))
+      (red ,(- (* w 2/3) piece-size) ,(* h 1/2))
+      (green ,(* w 1/2) ,(- (* h 2/3) piece-size))
+      (yellow ,(+ (* w 1/3) piece-size) ,(* h 1/2))))
+  
+  (define (get-number-font color w h)
+    (send the-font-list find-or-create-font
+          (cond
+            [(or (<= (* w 1/3 1/8) 10)
+                 (<= (* h 1/3 1/8) 10))
+             8]
+            [(or (<= (* w 1/3 1/8) 15)
+                 (<= (* h 1/3 1/8) 15))
+             9]
+            [else
+             12])
+          'default
+          'normal
+          'normal))
+  
+  (define (get-number-color color)
+    (send the-color-database find-color
+          (case color
+            [(red) "white"]
+            [else "black"])))
+ 
+  (define (get-piece-size w h)
+    (min (* w 1/3 1/8)
+         (* h 1/3 1/8)))
+  
+  (define black (make-object color% "black"))
+  
+  (define board-canvas%
+    (class canvas%
+      (init-field [board (new-board)])
+      (inherit get-dc get-client-size)
+      (define/public (set-board b) 
+        (set! board b)
+        (unless buffer (resize-bitmap))
+        (redraw-bitmap)
+        (on-paint))
+      
+      (define buffer #f)
+      (define bdc (make-object bitmap-dc%))
+      
+      (define/override (on-paint)
+        (unless buffer
+          (resize-bitmap))
+        (send (get-dc) draw-bitmap buffer 0 0))
+      
+      (define/override (on-size w h)
+        (resize-bitmap))
+      
+      (define/private (resize-bitmap)
+        (let-values ([(w h) (get-client-size)])
+          (set! buffer (make-object bitmap% w h))
+          (redraw-bitmap)))
+      
+      (define/private (redraw-bitmap)
+        (let-values ([(w h) (get-client-size)])
+          (send bdc set-bitmap buffer)
+          (draw-board board bdc w h 0 0 #t)
+          (send bdc set-bitmap #f)))
+      
+      (super-new)
+     
+      (inherit min-client-width min-client-height)
+      (min-client-height 350)
+      (min-client-width 350)))
+  
+  (define (show-board board)
+    (define f (new frame% (label "") (width 600) (height 600)))
+    (define c (new board-canvas% (parent f) (board board)))
+    (send f show #t)))
diff --git a/collects/games/parcheesi/info.ss b/collects/games/parcheesi/info.ss
new file mode 100644
index 0000000000..5287770f0f
--- /dev/null
+++ b/collects/games/parcheesi/info.ss
@@ -0,0 +1,5 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Parcheesi")
+  (define doc.txt "doc.txt")
+  (define game "parcheesi.ss")
+  (define game-set "Board Games"))
diff --git a/collects/games/parcheesi/interfaces.ss b/collects/games/parcheesi/interfaces.ss
new file mode 100644
index 0000000000..88a1bfb5a6
--- /dev/null
+++ b/collects/games/parcheesi/interfaces.ss
@@ -0,0 +1,22 @@
+(module interfaces mzscheme
+  (require (lib "class.ss"))
+  (provide player<%>
+           game<%>)
+
+  ;; in Java, lists become arrays.
+  
+  ;; the do-move method gets two numbers if no doubles were rolled
+  ;; and gets four numbers if doubles were rolled (and the player has
+  ;; all of the pieces in).
+  (define player<%>
+    (interface ()
+      start-game ;; player-color -> string
+      do-move ;; board (listof number[1-6]) -> move
+      doubles-penalty ;; : -> void
+      ))
+  
+  (define game<%>
+    (interface ()
+      register ;; player<%> -> void
+      start ;; -> void
+      )))
diff --git a/collects/games/parcheesi/make-bitmap.ss b/collects/games/parcheesi/make-bitmap.ss
new file mode 100644
index 0000000000..b7f898c5a0
--- /dev/null
+++ b/collects/games/parcheesi/make-bitmap.ss
@@ -0,0 +1,597 @@
+
+(module make-bitmap mzscheme
+  (require "board.ss"
+	   "moves.ss"
+           (lib "mred.ss" "mred")
+           (lib "class.ss")
+           (lib "list.ss")
+           (lib "etc.ss"))
+
+  (provide show-board
+           board-canvas%
+           draw-board
+           for-each-piece/position
+           find-main-coordinates
+           find-home-row-coordinates
+           get-cell-size
+           get-piece-size
+           
+           (struct home-row-c (count color))
+           (struct main-c (count))
+           (struct start-c (color))
+           (struct home-c (color)))
+  
+  ;; a coordinate is either
+  ;;   - (make-home-row-c number color)
+  ;;   - (make-main-c number)
+  ;;   - (make-start-c color)
+  ;;   - (make-home-c color)
+  ;; inspectors are to allow comparison with equal?
+  (define-struct home-row-c (count color) (make-inspector))
+  (define-struct main-c (count) (make-inspector))
+  (define-struct start-c (color) (make-inspector))
+  (define-struct home-c (color) (make-inspector))
+  
+  (define (get-cell-size horizontal? w h)
+    (if horizontal?
+        (values (* w 1/9) (* h 1/24))
+        (values (* w 1/24) (* h 1/9))))
+  
+  (define colors
+    '((green . "green")
+      (red . "red")
+      (yellow . "gold")
+      (blue . "blue")
+      (black . "black")
+      (safety . "purple")
+      (track-background . "light blue")))
+
+  (define circle-gap 1/20)
+  
+  (define (set-color dc color)
+    (send dc set-pen (send the-pen-list find-or-create-pen  (cdr (assq color colors)) 1 'solid))
+    (send dc set-brush (send the-brush-list find-or-create-brush (cdr (assq color colors)) 'solid)))
+  
+  (define draw-board
+    (opt-lambda (board dc w h dx dy draw-pieces?)
+      (set-color dc 'track-background)
+      (send dc draw-rectangle (+ dx 0) (+ dy (* h 1/3)) w (* h 1/3))
+      (send dc draw-rectangle (+ dx (* w 1/3)) (+ dy 0) (* w 1/3) h)
+      
+      (set-color dc 'blue)
+      (send dc draw-ellipse
+            (+ dx (* w circle-gap)) (+ dy (* h circle-gap 1/2))
+            (- (/ w 3) (* w circle-gap)) (- (/ h 3) (* h circle-gap)))
+      (send dc draw-rectangle (+ dx (* w (- 1/2 1/18))) (+ dy 0) (* w 1/9) (/ h 3))
+      (send dc draw-polygon 
+            (list (make-object point% (* w 1/3) (* h 1/3))
+                  (make-object point% (* w 2/3) (* h 1/3))
+                  (make-object point% (* w 1/2) (* h 1/2)))
+            dx
+            dy)
+      
+      (set-color dc 'red)
+      (send dc draw-ellipse 
+            (+ dx (* w 2/3) (* h circle-gap 1/2)) 
+            (+ dy (* h circle-gap))
+            (- (/ w 3) (* w circle-gap)) 
+            (- (/ h 3) (* h circle-gap)))
+      (send dc draw-rectangle (+ dx (* w 2/3)) (+ dy (* h (- 1/2 1/18))) (/ w 3) (* h 1/9))
+      (send dc draw-polygon 
+            (list (make-object point% (* w 2/3) (* h 1/3))
+                  (make-object point% (* w 2/3) (* h 2/3))
+                  (make-object point% (* w 1/2) (* h 1/2)))
+            dx
+            dy)
+      
+      (set-color dc 'yellow)
+      (send dc draw-ellipse 
+            (+ dx (* w circle-gap 1/2)) (+ dy (* h 2/3))
+            (- (/ w 3) (* w circle-gap)) (- (/ h 3) (* h circle-gap)))
+      (send dc draw-rectangle (+ dx 0) (+ dy (* h (- 1/2 1/18))) (/ w 3) (* h 1/9))
+      (send dc draw-polygon 
+            (list (make-object point% (* w 1/3) (* h 1/3))
+                  (make-object point% (* w 1/3) (* h 2/3))
+                  (make-object point% (* w 1/2) (* h 1/2)))
+            dx
+            dy)
+      
+      (set-color dc 'green)
+      (send dc draw-ellipse 
+            (+ dx (* w 2/3)) (+ dy (* h 2/3) (* h circle-gap 1/2))
+            (- (/ w 3) (* w circle-gap)) (- (/ h 3) (* h circle-gap)))
+      (send dc draw-rectangle (+ dx (* w (- 1/2 1/18))) (+ dy (* h 2/3)) (* w 1/9) (/ h 3))
+      (send dc draw-polygon 
+            (list (make-object point% (* w 1/3) (* h 2/3))
+                  (make-object point% (* w 2/3) (* h 2/3))
+                  (make-object point% (* w 1/2) (* h 1/2)))
+            dx
+            dy)
+      
+      (set-color dc 'safety)
+      
+      (send dc draw-rectangle 
+            (+ dx (* w 4/9))
+            (+ dy 0)
+            (* w 1/9)
+            (* h 1/3 1/8))
+      (send dc draw-rectangle 
+            (+ dx (* w 4/9))
+            (+ dy (* h (- 1 (* 1/3 1/8))))
+            (* w 1/9)
+            (* h 1/3 1/8))
+      (send dc draw-rectangle 
+            (+ dx (* w 5/9))
+            (+ dy (* h 1/3 4/8))
+            (* w 1/9)
+            (* h 1/3 1/8))
+      (send dc draw-rectangle 
+            (+ dx (* w 3/9))
+            (+ dy (* h 19/24))
+            (* w 1/9)
+            (* h 1/3 1/8))
+      
+      (send dc draw-rectangle 
+            (+ dx (* w (- 1 (* 1/3 1/8))))
+            (+ dy (* h 4/9))
+            (* w 1/3 1/8)
+            (* h 1/9))
+      (send dc draw-rectangle 
+            (+ dx 0)
+            (+ dy (* h 4/9))
+            (* w 1/3 1/8)
+            (* h 1/9))
+      (send dc draw-rectangle 
+            (+ dx (* w 4/24))
+            (+ dy (* h 1/3))
+            (* w 1/3 1/8)
+            (* h 1/3 1/3))
+      (send dc draw-rectangle 
+            (+ dx (* w 19/24))
+            (+ dy (* h 5/9))
+            (* w 1/3 1/8)
+            (* h 1/3 1/3))
+      
+      ;; blue entry
+      (send dc draw-rectangle 
+            (+ dx (* w 3/9))
+            (+ dy (* h 1/3 4/8))
+            (* w 1/9)
+            (* h 1/3 1/8))
+      
+      ;; green entry
+      (send dc draw-rectangle 
+            (+ dx (* w 5/9))
+            (+ dy (* h 19/24))
+            (* w 1/9)
+            (* h 1/24))
+      
+      ;; yellow entry
+      (send dc draw-rectangle 
+            (+ dx (* w 4/24))
+            (+ dy (* h 5/9))
+            (* w 1/24)
+            (* h 1/9))
+      
+      ;; red entry
+      (send dc draw-rectangle 
+            (+ dx (* w 19/24))
+            (+ dy (* h 1/3))
+            (* w 1/24)
+            (* h 1/9))
+      
+#|
+      (set-color dc 'blue)
+      (send dc draw-polygon
+            (list (make-object point% (* w 3/9) (* h 4/24))
+                  (make-object point% (* w 2/9) (* h 5/24))
+                  (make-object point% (* w 4/9) (* h 5/24)))
+            dx
+            dy)
+      
+      (set-color dc 'green)
+      (send dc draw-polygon 
+            (list (make-object point% (* w 5/9) (* h 19/24))
+                  (make-object point% (* w 6/9) (* h 20/24))
+                  (make-object point% (* w 7/9) (* h 19/24)))
+            dx
+            dy)
+      
+      
+      (set-color dc 'yellow)
+      (send dc draw-polygon 
+            (list (make-object point% (* w 4/24) (* h 6/9))
+                  (make-object point% (* w 5/24) (* h 5/9))
+                  (make-object point% (* w 5/24) (* h 7/9)))
+            dx
+            dy)
+      
+      
+      (set-color dc 'red)
+      (send dc draw-polygon
+            (list (make-object point% (* w 20/24) (* h 3/9))
+                  (make-object point% (* w 19/24) (* h 4/9))
+                  (make-object point% (* w 19/24) (* h 2/9)))
+            dx
+            dy)
+|#      
+      (set-color dc 'black)
+      
+      #;
+      (let loop ([i 7])
+        (unless (zero? i)
+          (send dc draw-line 
+                (+ dx (* w 1/3))
+                (+ dy (+ (* h 2/3) (* (* h 1/3) (/ i 8))))
+                (+ dx (* w 2/3))
+                (+ dy (+ (* h 2/3) (* (* h 1/3) (/ i 8)))))
+          (send dc draw-line 
+                (+ dx (* w 1/3))
+                (+ dy (* (* h 1/3) (/ i 8)))
+                (+ dx (* w 2/3))
+                (+ dy (* (* h 1/3) (/ i 8))))
+          (send dc draw-line 
+                (+ dx (+ (* w 2/3) (* (* w 1/3) (/ i 8))))
+                (+ dy (* h 1/3))
+                (+ dx (+ (* w 2/3) (* (* w 1/3) (/ i 8))))
+                (+ dy (* h 2/3)))
+          (send dc draw-line 
+                (+ dx (* (* w 1/3) (/ i 8)))
+                (+ dy (* h 1/3))
+                (+ dx (* (* w 1/3) (/ i 8)))
+                (+ dy (* h 2/3)))
+          (loop (- i 1))))
+      
+      (when draw-pieces?
+        (draw-pieces board dc w h dx dy))))
+  
+  ;; piece : color left top coordinate -> void
+  (define (for-each-piece/position board w h piece)
+    (void)
+    #;
+(let* ([piece-size (get-piece-size w h)]
+           [call-out
+            (lambda (ent x y horizontal? coordinate)
+              (let* ([pawn (car ent)])
+                (cond
+                  [(null? (cdr ent))
+                   (piece pawn (- x (/ piece-size 2)) (- y (/ piece-size 2)) coordinate)]
+                  [else 
+                   (let ([pawn2 (cadr ent)])
+                     (cond
+                       [horizontal?
+                        (piece pawn (- x piece-size) (- y (/ piece-size 2)) coordinate)
+                        (piece pawn2 x (- y (/ piece-size 2)) coordinate)]
+                       [else
+                        (piece pawn (- x (/ piece-size 2)) (- y piece-size) coordinate)
+                        (piece pawn2 (- x (/ piece-size 2)) y coordinate)]))])))])
+      
+      ;; main board
+      (let loop ([i board-main-size])
+        (unless (zero? i)
+          (let ([ent (board-main-i board (- i 1))])
+            (unless (null? ent)
+              (let-values ([(x y horizontal?) (find-main-coordinates (- i 1) w h)])
+                (call-out ent x y horizontal? (make-main-c (- i 1)))))
+            (loop (- i 1)))))
+      
+      ;; home row
+      (let ([handle-home-row
+             (lambda (color)
+               (let loop ([i board-home-row-size])
+                 (unless (zero? i)
+                   (let ([ent (board-home-row-i board color (- i 1))])
+                     (unless (null? ent)
+                       (let-values ([(x y horizontal?) (find-home-row-coordinates color (- i 1) w h)])
+                         (call-out ent x y horizontal? (make-home-row-c (- i 1) color)))))
+                   (loop (- i 1)))))])
+        (handle-home-row 'red)
+        (handle-home-row 'green)
+        (handle-home-row 'blue)
+        (handle-home-row 'yellow))
+      
+      ;; home and start
+      (let ([handle-home/start
+             (lambda (color select coordinates coord horiz?)
+               (let* ([pawns (filter (lambda (x) (eq? (pawn-color x) color)) (select board))]
+                      [num (length pawns)])
+                 (let-values ([(mx my) (apply values (cdr (assoc color (coordinates w h piece-size))))])
+                   (let ([do (lambda (pawn fx fy)
+                               (piece pawn
+                                      (+ mx (* piece-size fx))
+                                      (+ my (* piece-size fy))
+                                      coord))])
+                     (cond
+                       [(= num 4)
+                        (do (list-ref pawns 3) 0 0)
+                        (do (list-ref pawns 2) -1 0)
+                        (do (list-ref pawns 1) 0 -1)
+                        (do (list-ref pawns 0) -1 -1)]
+                       [(and horiz? (= num 3))
+                        (do (list-ref pawns 2) 0 -1/2)
+                        (do (list-ref pawns 1) -1 0)
+                        (do (list-ref pawns 0) -1 -1)]
+                       [(= num 3)
+                        (do (list-ref pawns 2) -1/2 0)
+                        (do (list-ref pawns 1) 0 -1)
+                        (do (list-ref pawns 0) -1 -1)]
+                       [(and horiz? (= num 2))
+                        (do (list-ref pawns 1) -1/2 -1)
+                        (do (list-ref pawns 0) -1/2 0)]
+                       [(= num 2)
+                        (do (list-ref pawns 1) -1 -1/2)
+                        (do (list-ref pawns 0) 0 -1/2)]
+                       [(= num 1)
+                        (do (list-ref pawns 0) -1/2 -1/2)])))))])
+        (handle-home/start 'red board-home at-home-coordinates (make-home-c 'red) #t)
+        (handle-home/start 'green board-home at-home-coordinates (make-home-c 'green) #f)
+        (handle-home/start 'blue board-home at-home-coordinates (make-home-c 'blue) #f)
+        (handle-home/start 'yellow board-home at-home-coordinates (make-home-c 'yellow) #t)
+        (handle-home/start 'red board-start at-start-coordinates (make-start-c 'red) #t)
+        (handle-home/start 'green board-start at-start-coordinates (make-start-c 'green) #t)
+        (handle-home/start 'blue board-start at-start-coordinates (make-start-c 'blue) #t)
+        (handle-home/start 'yellow board-start at-start-coordinates (make-start-c 'yellow) #t))))
+  
+  (define (draw-pieces board dc w h dx dy)
+    (for-each-piece/position 
+     board w h
+     (lambda (pawn x y coord)
+       (let ([font (get-number-font (pawn-color pawn) w h)]
+             [str (number->string (pawn-id pawn))]
+             [old-font (send dc get-font)]
+             [old-fore (send dc get-text-foreground)]
+             [size (get-piece-size w h)])
+         (send dc draw-ellipse (+ dx x) (+ dy y) size size)
+         (send dc set-font font)
+         (send dc set-text-foreground (get-number-color (pawn-color pawn)))
+         (send dc set-font old-font)))))
+  
+  (define home-row-coordinates
+    (list (list 'red
+                #f
+                (vector (cons (+ 22/24 1/48) 1/2)
+                        (cons (+ 21/24 1/48) 1/2)
+                        (cons (+ 20/24 1/48) 1/2)
+                        (cons (+ 19/24 1/48) 1/2)
+                        (cons (+ 18/24 1/48) 1/2)
+                        (cons (+ 17/24 1/48) 1/2)
+                        (cons (+ 16/24 1/48) 1/2)))
+          (list 'yellow
+                #f
+                (vector (cons (+ 1/24 1/48) 1/2)
+                        (cons (+ 2/24 1/48) 1/2)
+                        (cons (+ 3/24 1/48) 1/2)
+                        (cons (+ 4/24 1/48) 1/2)
+                        (cons (+ 5/24 1/48) 1/2)
+                        (cons (+ 6/24 1/48) 1/2)
+                        (cons (+ 7/24 1/48) 1/2)))
+          (list 'blue
+                #t
+                (vector (cons 1/2 (+ 1/24 1/48))
+                        (cons 1/2 (+ 2/24 1/48))
+                        (cons 1/2 (+ 3/24 1/48))
+                        (cons 1/2 (+ 4/24 1/48))
+                        (cons 1/2 (+ 5/24 1/48))
+                        (cons 1/2 (+ 6/24 1/48))
+                        (cons 1/2 (+ 7/24 1/48))))
+          (list 'green
+                #t
+                (vector (cons 1/2 (+ 22/24 1/48))
+                        (cons 1/2 (+ 21/24 1/48))
+                        (cons 1/2 (+ 20/24 1/48))
+                        (cons 1/2 (+ 19/24 1/48))
+                        (cons 1/2 (+ 18/24 1/48))
+                        (cons 1/2 (+ 17/24 1/48))
+                        (cons 1/2 (+ 16/24 1/48))))))
+
+  (define (find-home-row-coordinates color index w h)
+    (let ([ent (assq color home-row-coordinates)])
+      (if ent
+          (let ([v (caddr ent)])
+            (if (< index (vector-length v))
+                (let ([crds (vector-ref v index)])
+                  (values (* w (car crds)) (* h (cdr crds)) (cadr ent)))
+                (values 0 0 #f)))
+          (values 0 0 #f))))
+  
+  (define main-coordinates
+    (vector 
+     ;; safety between yellow and green
+     (list 1/2 (+ 23/24 1/48) #t)
+            
+     ;; row to the left of green, going up
+     (list (+ 5/9 1/18) (+ 23/24 1/48) #t)
+     (list (+ 5/9 1/18) (+ 22/24 1/48) #t)
+     (list (+ 5/9 1/18) (+ 21/24 1/48) #t)
+     (list (+ 5/9 1/18) (+ 20/24 1/48) #t)
+     (list (+ 5/9 1/18) (+ 19/24 1/48) #t)
+     (list (+ 5/9 1/18) (+ 18/24 1/48) #t)
+     (list (+ 5/9 1/18) (+ 17/24 1/48) #t)
+     (list (+ 5/9 1/18) (+ 16/24 1/48) #t)
+     
+     ;; row above green, going right
+     (list (+ 16/24 1/48) (+ 5/9 1/18) #f)
+     (list (+ 17/24 1/48) (+ 5/9 1/18) #f)
+     (list (+ 18/24 1/48) (+ 5/9 1/18) #f)
+     (list (+ 19/24 1/48) (+ 5/9 1/18) #f)
+     (list (+ 20/24 1/48) (+ 5/9 1/18) #f)
+     (list (+ 21/24 1/48) (+ 5/9 1/18) #f)
+     (list (+ 22/24 1/48) (+ 5/9 1/18) #f)
+     (list (+ 23/24 1/48) (+ 5/9 1/18) #f)
+     
+     ;; safety between green and red
+     (list (+ 23/24 1/48) 1/2 #f)
+     
+     ;; row below red, going left
+     (list (+ 23/24 1/48) (+ 3/9 1/18) #f)
+     (list (+ 22/24 1/48) (+ 3/9 1/18) #f)
+     (list (+ 21/24 1/48) (+ 3/9 1/18) #f)
+     (list (+ 20/24 1/48) (+ 3/9 1/18) #f)
+     (list (+ 19/24 1/48) (+ 3/9 1/18) #f)
+     (list (+ 18/24 1/48) (+ 3/9 1/18) #f)
+     (list (+ 17/24 1/48) (+ 3/9 1/18) #f)
+     (list (+ 16/24 1/48) (+ 3/9 1/18) #f)
+
+     ;; row to the left of red, going up
+     (list (+ 5/9 1/18) (+ 7/24 1/48) #t)
+     (list (+ 5/9 1/18) (+ 6/24 1/48) #t)
+     (list (+ 5/9 1/18) (+ 5/24 1/48) #t)
+     (list (+ 5/9 1/18) (+ 4/24 1/48) #t)
+     (list (+ 5/9 1/18) (+ 3/24 1/48) #t)
+     (list (+ 5/9 1/18) (+ 2/24 1/48) #t)
+     (list (+ 5/9 1/18) (+ 1/24 1/48) #t)
+     (list (+ 5/9 1/18) (+ 0/24 1/48) #t)
+          
+     ;; safety between red and blue
+     (list 1/2 (+ 0/24 1/48) #t)
+
+     ;; row to the right of blue, going down
+     (list (+ 3/9 1/18) (+ 0/24 1/48) #t)
+     (list (+ 3/9 1/18) (+ 1/24 1/48) #t)
+     (list (+ 3/9 1/18) (+ 2/24 1/48) #t)
+     (list (+ 3/9 1/18) (+ 3/24 1/48) #t)
+     (list (+ 3/9 1/18) (+ 4/24 1/48) #t)
+     (list (+ 3/9 1/18) (+ 5/24 1/48) #t)
+     (list (+ 3/9 1/18) (+ 6/24 1/48) #t)
+     (list (+ 3/9 1/18) (+ 7/24 1/48) #t)
+     
+     ;; row below blue, going left
+     (list (+ 7/24 1/48) (+ 3/9 1/18) #f)
+     (list (+ 6/24 1/48) (+ 3/9 1/18) #f)
+     (list (+ 5/24 1/48) (+ 3/9 1/18) #f)
+     (list (+ 4/24 1/48) (+ 3/9 1/18) #f)
+     (list (+ 3/24 1/48) (+ 3/9 1/18) #f)
+     (list (+ 2/24 1/48) (+ 3/9 1/18) #f)
+     (list (+ 1/24 1/48) (+ 3/9 1/18) #f)
+     (list (+ 0/24 1/48) (+ 3/9 1/18) #f)
+     
+     ;; safety between blue and yellow
+     (list (+ 0/24 1/48) 1/2 #f)
+
+     ;; row above yellow to the right
+     (list (+ 0/24 1/48) (+ 5/9 1/18) #f)
+     (list (+ 1/24 1/48) (+ 5/9 1/18) #f)
+     (list (+ 2/24 1/48) (+ 5/9 1/18) #f)
+     (list (+ 3/24 1/48) (+ 5/9 1/18) #f)
+     (list (+ 4/24 1/48) (+ 5/9 1/18) #f)
+     (list (+ 5/24 1/48) (+ 5/9 1/18) #f)
+     (list (+ 6/24 1/48) (+ 5/9 1/18) #f)
+     (list (+ 7/24 1/48) (+ 5/9 1/18) #f)
+     
+     ;; row to the right of yellow, going down
+     (list (+ 3/9 1/18) (+ 16/24 1/48) #t)
+     (list (+ 3/9 1/18) (+ 17/24 1/48) #t)
+     (list (+ 3/9 1/18) (+ 18/24 1/48) #t)
+     (list (+ 3/9 1/18) (+ 19/24 1/48) #t)
+     (list (+ 3/9 1/18) (+ 20/24 1/48) #t)
+     (list (+ 3/9 1/18) (+ 21/24 1/48) #t)
+     (list (+ 3/9 1/18) (+ 22/24 1/48) #t)
+     (list (+ 3/9 1/18) (+ 23/24 1/48) #t)
+     ))
+            
+  
+  (define (find-main-coordinates index w h)
+    (let ([e (vector-ref main-coordinates index)])
+      (values (* w (car e)) (* h (cadr e)) (caddr e))))
+    
+  (define (at-start-coordinates w h piece-size)
+    `((blue ,(* w (+ 1/6 (* circle-gap 1/2))) ,(* h 1/6))
+      (red ,(* w 5/6) ,(* h (+ 1/6 (* circle-gap 1/2))))
+      (green ,(* w (- 5/6 (* circle-gap 1/2))) ,(* h 5/6))
+      (yellow ,(* w 1/6) ,(* h (- 5/6 (* circle-gap 1/2))))))
+  
+  (define (at-home-coordinates w h piece-size)
+    `((blue ,(* w 1/2) ,(+ (* h 1/3) piece-size))
+      (red ,(- (* w 2/3) piece-size) ,(* h 1/2))
+      (green ,(* w 1/2) ,(- (* h 2/3) piece-size))
+      (yellow ,(+ (* w 1/3) piece-size) ,(* h 1/2))))
+  
+  (define (get-number-font color w h)
+    (send the-font-list find-or-create-font
+          (cond
+            [(or (<= (* w 1/3 1/8) 10)
+                 (<= (* h 1/3 1/8) 10))
+             8]
+            [(or (<= (* w 1/3 1/8) 15)
+                 (<= (* h 1/3 1/8) 15))
+             9]
+            [else
+             12])
+          'default
+          'normal
+          'normal))
+  
+  (define (get-number-color color)
+    (send the-color-database find-color
+          (case color
+            [(red) "white"]
+            [else "black"])))
+ 
+  (define (get-piece-size w h)
+    (min (* w 1/3 1/8)
+         (* h 1/3 1/8)))
+  
+  (define black (make-object color% "black"))
+  
+  (define board-canvas%
+    (class canvas%
+      (init-field [board (new-board)])
+      (inherit get-dc get-client-size)
+      (define/public (set-board b) 
+        (set! board b)
+        (unless buffer (resize-bitmap))
+        (redraw-bitmap)
+        (on-paint))
+      
+      (define buffer #f)
+      (define bdc (make-object bitmap-dc%))
+      
+      (define/override (on-paint)
+        (unless buffer
+          (resize-bitmap))
+        ;(send (get-dc) draw-bitmap buffer 0 0)
+        (let ([dc (get-dc)])
+          (send dc set-anti-alias #t)
+          (draw-board board dc 32 32 0 0 #t)))
+      
+      (define/override (on-size w h)
+        (resize-bitmap))
+      
+      (define/private (resize-bitmap)
+        (let-values ([(w h) (get-client-size)])
+          (set! buffer (make-object bitmap% w h))
+          (redraw-bitmap)))
+      
+      (define/private (redraw-bitmap)
+        (let-values ([(w h) (get-client-size)])
+          (send bdc set-bitmap buffer)
+          (draw-board board bdc w h 0 0 #t)
+          (send bdc set-bitmap #f)))
+      
+      (super-new)
+     
+      (inherit min-client-width min-client-height)
+      (min-client-height 32)
+      (min-client-width 32)))
+
+  (let ()
+    (define board (new-board))
+    (define bm (make-object bitmap% 32 32))
+    (define mask-bm (make-object bitmap% 32 32 #t))
+    (define bdc (make-object bitmap-dc% mask-bm))
+    (send bdc clear)
+    (send bdc set-bitmap bm)
+    (send bm set-loaded-mask mask-bm)
+    ;(send bdc set-anti-alias #t)
+    (draw-board board bdc 32 32 0 0 #f)
+    (send bdc set-bitmap mask-bm)
+    (draw-board board bdc 32 32 0 0 #f)
+    (send bdc set-bitmap #f)
+    (send bm save-file "parcheesi.png" 'png))
+  
+  (define (show-board board)
+    (define f (new frame% (label "")))
+    (define c (new board-canvas% (parent f) (board board)))
+    (send f show #t))
+
+  (show-board (new-board)))
diff --git a/collects/games/parcheesi/moves.ss b/collects/games/parcheesi/moves.ss
new file mode 100644
index 0000000000..0ded421123
--- /dev/null
+++ b/collects/games/parcheesi/moves.ss
@@ -0,0 +1,451 @@
+(module moves mzscheme
+  (require "board.ss"
+           (lib "contract.ss")
+           (lib "list.ss"))
+
+  (provide/contract
+   (struct enter-piece ((pawn pawn?)))
+   (struct move-piece-main ([pawn pawn?] [start number?] [distance number?]))
+   (struct move-piece-home ([pawn pawn?] [start number?] [distance number?])))
+
+  (provide take-turn
+           bad-move
+           make-moves
+           move?
+
+           board-enter-piece
+           board-move-piece-main
+           board-move-piece-home
+           
+           blockade-moved?
+           find-end-spot
+           board-doubles-penalty
+           
+           make-one-move
+           
+           get-move-id
+           get-move-color
+           
+           has-entering-roll?
+           entering-blockade?
+           exn:bad-move?
+           
+           board-all-in?
+           <=/m
+           possible-to-move)
+  
+  (define bop-bonus 20)
+  (define home-bonus 10)
+
+  ;; a move is either:
+  ;;  - (make-enter-piece pawn)
+  ;;  - (make-move-piece-main pawn start distance)
+  ;;  - (make-move-piece-home pawn start distance)
+  (define-struct move () (make-inspector))
+  (define-struct (enter-piece move) (pawn) (make-inspector))
+  (define-struct (move-piece-main move) (pawn start distance) (make-inspector))
+  (define-struct (move-piece-home move) (pawn start distance) (make-inspector))
+         
+  ;; moves-dice : moves -> (listof number)
+  ;; does not return the die moves that correspond to entering pawns
+  (define (moves-dice moves)
+    (let loop ([moves moves]
+               [dice null])
+      (cond
+        [(null? moves) dice]
+        [else 
+         (let ([move (car moves)])
+           (cond
+             [(move-piece-main? move) 
+              (loop (cdr moves) (cons (move-piece-main-distance move) dice))]
+             [(move-piece-home? move) 
+              (loop (cdr moves) (cons (move-piece-home-distance move) dice))]
+             [else (loop (cdr moves) dice)]))])))
+  
+  ;; board-doubles-penalty : board color -> board
+  (define (board-doubles-penalty board color)
+    (let home-row-loop ([i board-home-row-size])
+      (cond
+        [(zero? i)
+         (let main-board-loop ([i (get-enter-pos color)]
+                               [first-time? #t])
+           (cond
+             [(and (not first-time?) (= i (get-enter-pos color)))
+              board]
+             [else
+              (let* ([next-i (modulo (- i 1) board-main-size)]
+                     [ent (board-main-i board next-i)])
+                (if (and (pair? ent)
+                         (eq? (pawn-color (car ent)) color))
+                    (move-piece board (car ent) 'start)
+                    (main-board-loop next-i #f)))]))]
+        [else 
+         (let ([ent (board-home-row-i board color (- i 1))])
+           (if (null? ent)
+               (home-row-loop (- i 1))
+               (move-piece board (car ent) 'start)))])))
+  
+  ;; take-turn : color board (listof number) (listof move) -> board
+  ;; raises an exception if the turn is illegal
+  (define (take-turn color original-board original-dice original-moves)
+    (unless (andmap (lambda (x) (eq? color (get-move-color x))) original-moves)
+      (bad-move "attempted to move two different colors"))
+    (let loop ([moves original-moves]
+               [board original-board]
+               [dice original-dice])
+      (cond
+        [(null? moves) 
+         
+         (when (and (has-entering-roll? dice)
+                    (memf (lambda (pawn) (eq? (pawn-color pawn) color))
+                          (board-start board)) ;; has pieces in start
+                    (not (entering-blockade? board color)))
+           (bad-move "can still enter a pawn"))
+         
+         (let ([used-dice (moves-dice original-moves)])
+           (for-each (lambda (die) 
+                       (let ([potential-board (possible-to-move color board die)])
+                         (when potential-board
+                           (unless (blockade-moved? original-board potential-board color)
+                             (bad-move "die roll ~a can still be used" die)))))
+                     dice)
+           
+           (when (blockade-moved? original-board board color)
+             (bad-move "cannot move blockade together")))
+         
+         board]
+        [else 
+         (let ([move (car moves)])
+           (let-values ([(new-board bonus new-dice)
+                         (make-move/dice board move dice)])
+             (let ([new-new-dice (if bonus
+                                     (cons bonus new-dice)
+                                     new-dice)])
+               (loop (cdr moves)
+                     new-board
+                     new-new-dice))))])))
+  
+  ;; get-move-color : move -> symbol
+  ;; extracts the moved color from the move
+  (define (get-move-color move) (pawn-color (get-move-pawn move)))
+  
+  ;; get-move-id : move -> number
+  (define (get-move-id move) (pawn-id (get-move-pawn move)))
+  
+  (define (get-move-pawn move)
+    (cond
+      [(enter-piece? move) (enter-piece-pawn move)]
+      [(move-piece-main? move) (move-piece-main-pawn move)]
+      [(move-piece-home? move) (move-piece-home-pawn move)]))
+  
+  ;; blocakde-moved? : board board color -> boolean
+  (define (blockade-moved? original-board new-board color)
+    (let ([original-blockades (find-blockades/color original-board color)]
+          [new-blockades (find-blockades/color new-board color)])
+      (ormap (lambda (new-blockade) (memf (same-blockade-different-place? new-blockade) original-blockades))
+             new-blockades)))
+  
+  (define ((same-blockade-different-place? b1) b2)
+    (and (equal? (blockade-p1 b1) (blockade-p1 b2))
+         (equal? (blockade-p2 b1) (blockade-p2 b2))
+         (not (equal? (blockade-loc b1) (blockade-loc b2)))))
+  
+  ;; make-move/dice : board move (listof number) number -> (values board bonus (listof number))
+  ;; makes the given move, removing the used dice from the dice list.
+  ;; raises an error if the move isn't legal.
+  ;; check for: using a five to move when there are pieces to come in
+  ;;            moving without the matching roll
+  (define (make-move/dice board move dice)
+    (cond
+      [(enter-piece? move)
+       (let ([new-dice (cond
+                         [(memq 5 dice) (remq 5 dice)]
+                         [(and (memq 1 dice) (memq 4 dice))
+                          (remq 1 (remq 4 dice))]
+                         [(and (memq 2 dice) (memq 3 dice))
+                          (remq 2 (remq 3 dice))]
+                         [else (bad-move "entered without having a 5")])])
+         (let-values ([(board bonus) (board-enter-piece board (enter-piece-pawn move))])
+           (values board bonus new-dice)))]
+      [(move-piece-main? move)
+       (do-move/dice/moving board dice 
+                            (move-piece-main-distance move)
+                            (move-piece-main-pawn move)
+                            (move-piece-main-start move)
+                            board-move-piece-main)]
+      [(move-piece-home? move)
+       (do-move/dice/moving board dice 
+                            (move-piece-home-distance move)
+                            (move-piece-home-pawn move)
+                            (move-piece-home-start move)
+                            board-move-piece-home)]))
+  
+  ;; helper function to collapse last two cases of make-move/dice
+  (define (do-move/dice/moving board dice die pawn start board-move-piece)
+    (let ([new-dice (remq die dice)])
+      (unless (memq die dice)
+        (bad-move "tried to move ~a squares but dice read ~a" die dice))
+      (let-values ([(new-board bonus)
+                    (board-move-piece board pawn start die)])
+        (values new-board bonus new-dice))))
+  
+  ;; entering-blocade? : board symbol -> boolean
+  (define (entering-blockade? board color) 
+    (let ([ent (board-main-i board (get-enter-pos color))])
+      (and (pair? ent) (pair? (cdr ent)))))
+  
+  (define (no-blockades board start end)
+    (let ([ind (find-blockade/between board start end)])
+      (cond
+        [(not ind) (void)]
+        [(number? ind)
+         (bad-move "there is a blockade at ~a in the main ring" ind)]
+        [(home-row-loc? ind)
+         (bad-move "there is a blockade at ~a in the ~a home row" 
+                   (home-row-loc-num ind)
+                   (home-row-loc-color ind))]
+        [else (bad-move "blockade in the way")])))
+  
+  ;; has-entering-roll? : (listof number) -> boolean
+  (define (has-entering-roll? dice)
+    (or (memq 5 dice)
+        (and (memq 1 dice) (memq 4 dice))
+        (and (memq 2 dice) (memq 3 dice))))
+  
+  ;; possible-to-move : symbol board number -> (union #f board)
+  ;; indicates if there are any moves that could happen with the
+  ;; given die, for the given color in the given board.
+  ;; doesn't consider entering moves
+  (define (possible-to-move color board die)
+    (let/ec k
+      (for-each-pawn/loc
+       board
+       (lambda (pawn loc)
+         (when (and (eq? color (pawn-color pawn))
+                    (not (symbol? loc)))
+           (with-handlers ([exn:bad-move? (lambda (x) #f)])
+             (cond
+               [(number? loc) 
+                (let-values ([(board bonus) (board-move-piece-main board pawn loc die)])
+                  (k board))]
+               [(home-row-loc? loc) 
+                (let-values ([(board bonus) (board-move-piece-home board pawn (home-row-loc-num loc) die)])
+                  (k board))])))))
+      #f))
+    
+  ;; make-moves : board (listof move) -> board (listof number)
+  ;; only checks that each move, in isloation, would be possible
+  (define (make-moves board moves)
+    (let loop ([board board]
+               [bonus '()]
+               [moves moves])
+      (cond
+        [(null? moves) (values board bonus)]
+        [else 
+         (let-values ([(new-board new-bonus) (make-one-move board (car moves))])
+           (loop new-board 
+                 (if new-bonus (cons new-bonus bonus) bonus)
+                 (cdr moves)))])))
+  
+  ;; make-one-move : board move -> board
+  (define (make-one-move board move)
+    (cond
+      [(enter-piece? move) (board-enter-piece board (enter-piece-pawn move))]
+      [(move-piece-main? move) (board-move-piece-main board
+                                                      (move-piece-main-pawn move)
+                                                      (move-piece-main-start move)
+                                                      (move-piece-main-distance move))]
+      [(move-piece-home? move) (board-move-piece-home board
+                                                      (move-piece-home-pawn move)
+                                                      (move-piece-home-start move)
+                                                      (move-piece-home-distance move))]))
+  
+  
+  
+  (define (board-all-in? board color) 
+    (not (memf (lambda (pawn) (eq? (pawn-color pawn) color))
+               (board-start board))))
+  
+  ;; enter-piece : board pawn -> (values board (union #f number))
+  (define (board-enter-piece orig-board pawn)
+    (unless (member pawn (board-start orig-board))
+      (bad-move "~a's pawn ~a is already on the board" (pawn-color pawn) (pawn-id pawn)))
+    ;; move the color out of the starting area
+    (let* ([pos (get-enter-pos (pawn-color pawn))]
+           [old-ent (board-main-i orig-board pos)])
+      (when (= 2 (length old-ent))
+        (bad-move "cannot move out into a blockade"))
+      (cond
+        ;; no bop
+        [(or (null? old-ent)
+             (eq? (pawn-color (car old-ent)) (pawn-color pawn)))
+         (values (move-piece orig-board pawn pos)
+                 #f)]
+        ;; bop
+        [else
+         (values (move-piece2
+                  orig-board
+                  pawn
+                  pos
+                  (car old-ent)
+                  'start)
+                 bop-bonus)])))
+  
+  ;; board-move-piece-home : board pawn number number -> (values board (union #f number))
+  ;; result of #f indicates no bop; result of a color indicates who got bopped
+  (define (board-move-piece-home board pawn start distance)
+    (let* ([color (pawn-color pawn)]
+           [old (board-home-row-i board color start)])
+      (unless (member pawn old)
+        (bad-move "color ~a is not in the home row on ~a" (pawn-color pawn) start))
+      (unless (and (<= 0 start) (< start board-home-row-size))
+        (error 'boad-move-piece-home "bad start argument ~e" start))
+      (unless (<= 0 start (+ start distance) (+ board-home-row-size 1))
+        (bad-move "moved too far, off the end of the board"))
+      
+      (let ([finish (+ start distance)])
+        (cond
+          [(= finish board-home-row-size)
+           (when (< start (- finish 1))
+             ;; if only moving one square, then we don't need to check blockades
+             ;; this lets us satisfy the inputs to no-blockades
+             (no-blockades board
+                           (make-home-row-loc (+ start 1) color)
+                           (make-home-row-loc (- finish 1) color)))
+           (values (move-piece board pawn 'home)
+                   home-bonus)]
+          [(< finish board-home-row-size)
+           (no-blockades board
+                         (make-home-row-loc (+ start 1) color)
+                         (make-home-row-loc finish color))
+           
+           (let ([old-ent (board-home-row-i board color finish)])
+             (cond
+               [(or (null? old-ent)
+                    (null? (cdr old-ent)))
+                (values (move-piece board 
+                                    pawn
+                                    (make-home-row-loc finish color))
+                        #f)]
+               [else
+                (bad-move "moved onto a blockade in the home row")]))]
+          [else
+           (bad-move "moved off of the end of the board")]))))
+  
+  ;; board-move-piece-main : board pawn number number -> (values board (union #f number))
+  ;; result of #f indicates no bop; result of a color indicates who got bopped
+  (define (board-move-piece-main board pawn start distance)
+    (unless (member pawn (board-main-i board start))
+      (bad-move "color ~a (piece #~a) is not on square ~a" 
+                (pawn-color pawn)
+                (pawn-id pawn)
+                start))
+    (let* ([color (pawn-color pawn)]
+           [landed (find-end-spot color start distance)]
+           [exit (get-exit-pos color)])
+      (cond
+        [(eq? landed 'too-far) (bad-move "moved off of the board")]
+        [(eq? landed 'home)
+         (no-blockades board
+                       (modulo (+ start 1) board-main-size)
+                       (make-home-row-loc (- board-home-row-size 1) color))
+         (values (move-piece board
+                             pawn
+                             'home)
+                 10)]
+        [(eq? (car landed) 'home-row)
+         ;; turned onto the exit ramp
+         
+         (let* ([final-spot (cdr landed)])
+           (no-blockades board
+                         (next-pos color start)
+                         (make-home-row-loc final-spot color))
+           
+           (let ([old (board-home-row-i board color final-spot)])
+             (when (and (pair? old)
+                        (pair? (cdr old)))
+               (bad-move "cannot move onto a blockade"))
+             (values (move-piece board pawn (make-home-row-loc final-spot color))
+                     #f)))]
+        [else
+         ;; stayed on the main board
+         (let ([end (cdr landed)])
+           (let ([start+1 (modulo (+ start 1) board-main-size)])
+             (unless (= start+1 end)
+               (no-blockades board start+1 end)))
+           (let ([old-contents (board-main-i board end)])
+         
+             (cond
+               ;; no one there
+               [(null? old-contents)
+                (values (move-piece board pawn end)
+                        #f)]
+               
+               [(and (pair? old-contents)
+                     (pair? (cdr old-contents)))
+                (bad-move "cannot move directly onto a blockade")]
+               
+               ;; already one of the same color on that spot
+               [(eq? (pawn-color (car old-contents)) color)
+                (values (move-piece board
+                                    pawn
+                                    end)
+                        #f)]
+               
+               ;; attempt to bop on a safety -- illegal
+               [(safety? end)
+                (bad-move "cannot move onto a safety if someone else is already there")]
+               
+               ;; succesful bop
+               [else
+                (values
+                 (move-piece2 board
+                              pawn
+                              end
+                              (car old-contents)
+                              'start)
+                 bop-bonus)])))])))
+  
+  ;; next-pos : color number -> (union number home-row-loc)
+  ;; given a position on the main ring, it finds the next position
+  ;; for the given color on the board.
+  (define (next-pos color pos)
+    (cond
+      [(= pos (get-exit-pos color))
+       (make-home-row-loc color 0)]
+      [else
+       (modulo (+ pos 1) board-main-size)]))
+
+  ;; find-end-spot : color number number -> (union 'too-far 'home (cons 'home-row number) (cons 'main number)))
+  (define (find-end-spot color start distance)
+    (let ([exit (get-exit-pos color)]
+          [end (modulo (+ start distance) board-main-size)])
+      (cond
+        [(and (<=/m start exit end)
+              (not (= exit end)))
+         (let* ([distance-to-exit (modulo (- exit start) board-main-size)]
+                [final-spot (- distance distance-to-exit 1)])
+           (cond
+             [(final-spot . = . board-home-row-size)
+              'home]
+             [(final-spot . < . board-home-row-size)
+              (cons 'home-row final-spot)]
+             [else
+              'too-far]))]
+        [else
+         (cons 'main end)])))
+           
+           
+  (define (<=/m one two three)
+    (or (<= one two three)
+        (<= two three one)
+        (<= three one two)))
+  
+  (define-struct (exn:bad-move exn) ())
+  
+  (define bad-move
+    (case-lambda
+      [(str) (raise (make-exn:bad-move (string->immutable-string str)
+                                       (current-continuation-marks)))]
+      [args (raise (make-exn:bad-move (string->immutable-string (apply format args))
+                                      (current-continuation-marks)))])))
\ No newline at end of file
diff --git a/collects/games/parcheesi/parcheesi.png b/collects/games/parcheesi/parcheesi.png
new file mode 100644
index 0000000000..cb6123547f
Binary files /dev/null and b/collects/games/parcheesi/parcheesi.png differ
diff --git a/collects/games/parcheesi/parcheesi.ss b/collects/games/parcheesi/parcheesi.ss
new file mode 100644
index 0000000000..d94e56abae
--- /dev/null
+++ b/collects/games/parcheesi/parcheesi.ss
@@ -0,0 +1,11 @@
+
+(module parcheesi mzscheme
+  (require (lib "unit.ss")
+           (lib "class.ss"))
+  
+  (provide game-unit)
+  (define game-unit
+    (unit (import)
+          (export)
+          (new (dynamic-require '(lib "admin-gui.ss" "games" "parcheesi") 'gui-game%)))))
+
diff --git a/collects/games/parcheesi/play-game.ss b/collects/games/parcheesi/play-game.ss
new file mode 100644
index 0000000000..dae4b21a6a
--- /dev/null
+++ b/collects/games/parcheesi/play-game.ss
@@ -0,0 +1,151 @@
+(module play-game mzscheme
+  (require "gui.ss"
+           "admin.ss"
+           "board.ss"
+	   "moves.ss"
+           "die.ss"
+           (lib "math.ss")
+           (lib "class.ss")
+           (lib "mred.ss" "mred"))
+  
+  (provide play-game)
+  
+  (define animation-frame%
+    (class* frame% (game-observer<%>)
+      (init-field eventspace)
+      (super-new)
+      (define boards (list (new-board)))
+      (define dice '())
+      (define colors '())
+      (define index 0)
+      (define main-hp (new horizontal-panel% (parent this)))
+      (define left-vp (new vertical-panel% (parent main-hp) (stretchable-width #f)))
+      (define blue-name (new name-message% (parent left-vp) (up? #f)))
+      (define unused1 (new vertical-panel% (parent left-vp)))
+      (define yellow-name (new name-message% (parent left-vp) (up? #t)))
+      (define canvas (new board-canvas% (parent main-hp)))
+      (define right-vp (new vertical-panel% (parent main-hp) (stretchable-width #f)))
+      (define red-name (new name-message% (parent right-vp) (up? #f)))
+      (define unused2 (new vertical-panel% (parent right-vp)))
+      (define green-name (new name-message% (parent right-vp) (up? #t)))
+      
+      (define info-panel (new horizontal-panel% 
+                              (parent this)
+                              (alignment '(center center))
+                              (stretchable-height #f)))
+      (define dice-msg (new message% (parent info-panel) (label "")))
+      (define die1 (new die% (parent info-panel)))
+      (define die2 (new die% (parent info-panel)))
+      (send dice-msg stretchable-width #t)
+      (define bp (new horizontal-panel% 
+                      (parent this)
+                      (stretchable-height #f)))
+      (define next (new button% 
+                        (label "next")
+                        (callback
+                         (lambda (x y) 
+                           (set! index (modulo (+ index 1) (length boards)))
+                           (update)))
+                        (parent bp)))
+      (define prev (new button% 
+                        (label "prev")
+                        (callback
+                         (lambda (x y) 
+                           (set! index (modulo (- index 1) (length boards)))
+                           (update)))
+                        (parent bp)))
+      
+      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;
+      ;;  observer methods (not called on the eventspace main thread)
+      ;;
+      
+      (define/public (introduce color name)
+        (queue-callback/sync
+         (lambda ()
+           (case color
+             [(red) (send red-name set-text name)]
+             [(blue) (send blue-name set-text name)]
+             [(green) (send green-name set-text name)]
+             [(yellow) (send yellow-name set-text name)]))))
+      (define/public (game-over winner color) 
+        (queue-callback/sync
+         (lambda ()
+           (new message% 
+                (parent this) 
+                (label (format "Winner ~a (~a)" winner color))))))
+      (define/public (taking-turn color roll)
+        (queue-callback/sync
+         (lambda ()
+           (set! colors (append colors (list color)))
+           (set! dice (append dice (list roll))))))
+      (define/public (took-turn color board)
+        (queue-callback/sync
+         (lambda ()
+           (set! boards (append boards (list board)))
+           (when (= index (- (length boards) 2))
+             (set! index (+ index 1))
+             (update)))))
+      
+      (define/private (update)
+        (send canvas set-board (list-ref boards index))
+        (cond
+          [(< index (length dice))
+           (send dice-msg set-label (format "Turn ~a (~a)" index (list-ref colors index)))
+           (send die1 set-digit (car (list-ref dice index)))
+           (send die2 set-digit (cadr (list-ref dice index)))]
+          [else
+           (send dice-msg set-label (format "Turn ~a" index))
+           (send die1 set-digit #f)
+           (send die2 set-digit #f)]))
+  
+      (define/private (queue-callback/sync t)
+        (parameterize ([current-eventspace eventspace])
+          (let ([s (make-semaphore 0)])
+            (queue-callback
+             (lambda ()
+               (t)
+               (semaphore-post s)))
+            (semaphore-wait s))))))
+  
+  (define name-message%
+    (class canvas%
+      (init-field up?)
+      (inherit min-width min-height get-dc)
+      (define txt "")
+      (define/public (set-text l) 
+        (set! txt l)
+        (update-min-size)
+        (on-paint))
+      (define/override (on-paint)
+        (let ([dc (get-dc)])
+          (let-values ([(w h _1 _2) (send dc get-text-extent txt)])
+            (if up?
+                (send dc draw-text txt 0 w #f 0 (/ pi 2))
+                (send dc draw-text txt h 0 #f 0 (- (/ pi 2)))))))
+      (define/private (update-min-size)
+        (let ([dc (get-dc)])
+          (let-values ([(w h _1 _2) (send dc get-text-extent txt)])
+            (min-width (ceiling (inexact->exact h)))
+            (min-height (ceiling (inexact->exact w))))))
+      (super-new 
+       (stretchable-width #f)
+       (stretchable-height #f))))
+  
+  (define (play-game players)
+    (define game (new game%))
+    (define esp (make-eventspace))
+    (define af (parameterize ([current-eventspace esp])
+                 (new animation-frame% (label "Parcheesi") (eventspace esp))))
+    (send game set-observer af)
+    (for-each (lambda (player) (send game register player)) players)
+    (send af show #t)
+    (send game start))
+
+  #;
+  (begin
+    (require "best-player.ss") 
+    (play-game (list (new first-player%) 
+                     (new last-player%) 
+                     (new first-player%) 
+                     (new last-player%)))))
diff --git a/collects/games/parcheesi/rules.ss b/collects/games/parcheesi/rules.ss
new file mode 100644
index 0000000000..21b78c252e
--- /dev/null
+++ b/collects/games/parcheesi/rules.ss
@@ -0,0 +1,271 @@
+(module rules mzscheme
+  (provide show-rules)
+  
+  (require "board.ss"
+           "moves.ss"
+           "gui.ss"
+
+           (lib "class.ss")
+           (lib "xml.ss" "xml")
+           (lib "htmltext.ss" "browser")
+           (lib "mred.ss" "mred"))
+
+  (define board-size 250)
+  
+  (define (show-rules)
+    (let* ([f (new frame% (label "Parcheesi Rules") (width 600) (height 600))]
+           [t (new (html-text-mixin text%))]
+           [ec (new editor-canvas% (parent f) (editor t) (style '(no-hscroll resize-corner)))])
+      (send f show #t)
+      (send t begin-edit-sequence)
+      (let-values ([(in out) (make-pipe)])
+        (thread
+         (lambda ()
+           (display-xml/content (xexpr->xml (parcheesi-rules)) out)
+           (close-output-port out)))
+        (render-html-to-text in t #t #f))
+      (replace-!!s t)
+      (send t auto-wrap #t)
+      (send t lock #t)
+      (send t hide-caret #t)
+      (send t end-edit-sequence)
+      (send ec focus)))
+  
+  (define (parcheesi-rules)
+    `(div 
+      (p "Parcheesi is a race between four players. Each player moves four pawns "
+         "from their starting point, around the board and then into the center. "
+         "The first player to get all four pawns into the center wins. ")
+      
+      (p "Initially, the board looks like this, with each player's pawns "
+         "in their home circle."
+         (center ,(moves-make-image/link '() "initial")))
+      
+      (p "On each turn, a player rolls two dice and moves their pawns according to these rules: "
+         (ul
+          (li ,(heading "Entering")
+              "If one of the dice has a five, or both dice together sum to five, one of the pieces "
+              "may be moved out of the start area into the main board (moving out consumes the five). "
+              "The entering positions are the positions on the board that are half purple and half "
+              "the color of the player. "
+              "For example, if green rolls 1 and a 4 on the first turn, the board looks like this: "
+              (center
+               ,(moves-make-image/link (list (make-enter-piece (make-pawn 'green 0)))
+                                       "enter")))
+          (li ,(heading "Normal Move")
+              "With the exception of doubles, when a player rolls the dice, the player moves "
+              "their pieces by the numbers indicated by the pips. Pieces move in the "
+              "counter-clockwise direction around the board, on the purple and light blue squares. "
+              "If, for example, green rolls "
+              "a 5 and a 3 on the first move, the board looks like this:"
+              (center
+               ,(moves-make-image/link (list (make-enter-piece (make-pawn 'green 0))
+                                             (make-move-piece-main (make-pawn 'green 0) 5 3))
+                                       "simple-move"))
+              "then, if green rolls a 4 and a 6 on their next move (and the other players don't enter) "
+              "green might first move the 4, resulting in the board on the left "
+              "and then move the 6, resulting in the board on the right."
+              (center
+               ,(moves-make-image/link (list (make-enter-piece (make-pawn 'green 0))
+                                             (make-move-piece-main (make-pawn 'green 0) 5 3)
+                                             (make-move-piece-main (make-pawn 'green 0) 8 4))
+                                       "simple-move2")
+               nbsp nbsp nbsp nbsp
+               ,(moves-make-image/link (list (make-enter-piece (make-pawn 'green 0))
+                                             (make-move-piece-main (make-pawn 'green 0) 5 3)
+                                             (make-move-piece-main (make-pawn 'green 0) 8 4)
+                                             (make-move-piece-main (make-pawn 'green 0) 12 6))
+                                       "simple-move3")))
+          (li ,(heading "Double Bonus")
+              "When a player rolls doubles and all of their pieces are out of the starting area, "
+              "the player moves by the tops and bottoms of the dice. That is, if the player "
+              "rolls double 1s, the player moves two pieces 1 square and two pieces 6 squares "
+              "(of course, this can be all the same piece). The opposite sides of the die always "
+              "sum to seven, so the total number of spaces moved is always 14.")
+          (li ,(heading "Double Repeats")
+              "When a player rolls doubles (no matter if all of the pieces are out or not) "
+              "they take another turn. If they roll doubles a second time, they take a third turn. "
+              "On the third turn, if they roll doubles, their turn is forfeit and the most pawn that is "
+              "furthest along must be moved back to the starting circle. "
+              "If they do not roll doubles on the third turn, "
+              "they take the third turn as normal.")
+          (li ,(heading "Blockades")
+              "Two pawns of the same color on a space form a blockade. "
+              "A blockade cannot be passed by any other pawn (even one of the same color). "
+              "A blockade cannot be moved together (this rule only affects doubles). "
+              "As a simple example, if red were to roll a 2 and a 1 in the following board, "
+              "only the freshly entered pawn could advance. "
+              (center
+               ,(moves-make-image/link (list (make-enter-piece (make-pawn 'green 0))
+                                             (make-enter-piece (make-pawn 'green 1))
+                                             (make-move-piece-main (make-pawn 'green 0) 5 22)
+                                             (make-move-piece-main (make-pawn 'green 1) 5 22)
+                                             (make-enter-piece (make-pawn 'red 0))
+                                             (make-enter-piece (make-pawn 'red 1))
+                                             (make-move-piece-main (make-pawn 'red 0) 22 4))
+                                       "blockade")))
+          
+          (li ,(heading "Individual Die Rolls")
+              "Each die roll should be thought of as an individual \"mini-move\". "
+              "That is, when a player rolls a 1 and a 6, for example, the player may move "
+              "one pawn 1 squares and another pawn 6 squares. This may be the same pawn, but "
+              "this is not the same as moving that pawn 7 squares directly. "
+              "For example, in the following board, if red has a 1 and a 6, red cannot move, "
+              "even though the spot seven spaces away is safe to land on. "
+              (center
+               ,(moves-make-image/link (list (make-enter-piece (make-pawn 'green 0))
+                                             (make-enter-piece (make-pawn 'green 1))
+                                             (make-move-piece-main (make-pawn 'green 0) 5 24)
+                                             (make-move-piece-main (make-pawn 'green 1) 5 29)
+                                             (make-enter-piece (make-pawn 'red 0))
+                                             (make-move-piece-main (make-pawn 'red 0) 22 6))
+                                       "individual-die-rolls")))
+          
+          (li ,(heading "Bop")
+              "If a pawn is by itself on a light blue square "
+              "and a pawn of a different color lands on the square it occupies "
+              "(by an exact count of the dice) the original pawn is bopped, "
+              "which means it is sent back to the "
+              "starting square. The player that bopped now may move any one of its pawns by 20. "
+              "This bonus acts just like an extra \"mini-move\" as described above. "
+              "For example, if red rolls a 1 and a 2 in the board on the left, after moving the board "
+              "looks like on the right."
+              (center
+               ,(moves-make-image/link (list (make-enter-piece (make-pawn 'green 0))
+                                             (make-move-piece-main (make-pawn 'green 0) 5 20)
+                                             (make-enter-piece (make-pawn 'red 0)))
+                                       "bop-before")
+               nbsp nbsp nbsp nbsp
+               ,(moves-make-image/link (list (make-enter-piece (make-pawn 'red 0))
+                                             (make-move-piece-main (make-pawn 'red 0) 22 3)
+                                             (make-move-piece-main (make-pawn 'red 0) 25 20))
+                                       "bop-after")))
+          
+          
+          (li ,(heading "Safety")
+              "Purple squares are safety squares. The only way a pawn can be bopped on a purple "
+              "square is if the bopping pawn is entering from the start. A safety square cannot be "
+              "occupied by two different colored pawns. One pawn on a safety does not constitute a "
+              "blockade, however, so other colors can pass by. "
+              "For example, if red rolls a 2 and a 3 in the situation below, it can take "
+              "the 2 and then the 3, but not the 3 and then the 2."
+              (center
+               ,(moves-make-image/link (list (make-enter-piece (make-pawn 'green 0))
+                                             (make-move-piece-main (make-pawn 'green 0) 5 24)
+                                             (make-enter-piece (make-pawn 'red 0))
+                                             (make-move-piece-main (make-pawn 'red 0) 22 4))
+                                       "no-bop"))
+              "If, however, red rolls a 1 and a 4, in the picture on the left, red bops "
+              "green and we get the picture on the right."
+              (center
+               ,(moves-make-image/link (list (make-enter-piece (make-pawn 'green 0))
+                                             (make-move-piece-main (make-pawn 'green 0) 5 17))
+                                       "bop-enter-before")
+               nbsp nbsp nbsp nbsp
+               ,(moves-make-image/link (list (make-enter-piece (make-pawn 'red 0))
+                                             (make-move-piece-main (make-pawn 'red 0) 22 20))
+                                       "bop-enter-after")))
+          (li ,(heading "Home Row")
+              "When a pawn makes a nearly complete circuit, it turns off into its "
+              "correspondingly colored home row. For example, if "
+              "green, after travelling all the way around the board to "
+              "the bottom left, rolls a 4 and a 3, it moves into the green "
+              "section of the board:"
+              (center
+               ,(moves-make-image/link (list (make-enter-piece (make-pawn 'green 0))
+                                             (make-move-piece-main (make-pawn 'green 0) 5 60))
+                                       "enter-home-before")
+               nbsp nbsp nbsp nbsp
+               ,(moves-make-image/link (list (make-enter-piece (make-pawn 'green 0))
+                                             (make-move-piece-main (make-pawn 'green 0) 5 60)
+                                             (make-move-piece-main (make-pawn 'green 0) 65 7))
+                                       "enter-home-after")))
+          
+          (li ,(heading "Home")
+              "Pawns must enter home by an exact count. "
+              "For example, in the board below, green must roll a 1 "
+              "in order to move the piece home."
+              (center
+               ,(moves-make-image/link (list (make-enter-piece (make-pawn 'green 0))
+                                             (make-move-piece-main (make-pawn 'green 0) 5 60)
+                                             (make-move-piece-main (make-pawn 'green 0) 65 10))
+                                       "going-home")))
+          
+          (li ,(heading "Home Bonus")
+              "When a piece moves home, the player whose piece moved home gets a bonus "
+              "of 10. "
+              "This bonus acts just like an extra \"mini-move\" as described above. "
+              "For example, if green rolls a 1 and a 2 in the board on the left "
+              "the move results in the board on the right."
+              (center
+               ,(moves-make-image/link (list (make-enter-piece (make-pawn 'green 0))
+                                             (make-enter-piece (make-pawn 'green 1))
+                                             (make-move-piece-main (make-pawn 'green 0) 5 60)
+                                             (make-move-piece-main (make-pawn 'green 0) 65 10))
+                                       "home-bonus-before")
+               nbsp nbsp nbsp
+               ,(moves-make-image/link (list (make-enter-piece (make-pawn 'green 0))
+                                             (make-enter-piece (make-pawn 'green 1))
+                                             (make-move-piece-main (make-pawn 'green 0) 5 60)
+                                             (make-move-piece-main (make-pawn 'green 0) 65 10)
+                                             (make-move-piece-home (make-pawn 'green 0) 6 1)
+                                             (make-move-piece-main (make-pawn 'green 1) 5 10)
+                                             (make-move-piece-main (make-pawn 'green 1) 15 2))
+                                       "home-bonus-after")))
+          
+          (li ,(heading "Cell Occupancy")
+              "Each square in the main ring and in the home rows can only have zero, one or two pawns on it. "
+              "If it contains two pawns, those pawns must be the same color (and would form a blockade, as above)")
+          
+          (li ,(heading "Use all Dice")
+              "A player must play as many dice as possible. More precisely, if a player makes a move and "
+              "then finishes their turn, there must not be any further moves possible. "
+              "Parcheesi typically requires a player to enter the board, if possible. That is not required "
+              "here however." )))))
+      
+  (define table (make-hash-table 'equal))
+  
+  (define (replace-!!s t)
+    (let loop ([starts (reverse (send t find-string-all "!!"))]
+               [ends (reverse (send t find-string-all "::"))])
+      (cond
+        [(null? starts) (void)]
+        [else (let* ([start (car starts)]
+                     [end (car ends)]
+                     [name (send t get-text (+ start 2) end)])
+                (send t delete start (+ end 2) #f)
+                (send t insert (new board-snip% (board (hash-table-get table name))) start start #f)
+                (loop (cdr starts) (cdr ends)))])))
+
+  (define scroll-step-pixels 12)
+  
+  (define board-snip%
+    (class snip%
+      (init-field board)
+      (define/override (find-scroll-step y) (inexact->exact (quotient y scroll-step-pixels)))
+      (define/override (get-num-scroll-steps) (quotient board-size scroll-step-pixels))
+      (define/override (get-scroll-step-offset step) (* step scroll-step-pixels))
+      (define/override (get-extent dc x y w h descent space lspace rspace)
+        (set-box/f! w board-size)
+        (set-box/f! h board-size)
+        (set-box/f! descent 0)
+        (set-box/f! space 0)
+        (set-box/f! lspace 0)
+        (set-box/f! rspace 0))
+      (define/override (draw dc x y left top right bottom dx dy draw-caret)
+        (draw-board board dc board-size board-size x y #t))
+      (super-new)
+      (inherit set-snipclass)
+      (set-snipclass dummy-snipclass)))
+  
+  (define (set-box/f! b v) (when (box? b) (set-box! b v)))
+  
+  (define dummy-snipclass (new snip-class%))
+  
+  (define (heading name)
+    `(font ((color "forestgreen") (size "+2")) (b ,name)))
+  
+  (define (moves-make-image/link moves name)
+    (let-values ([(board bonuses) (make-moves (new-board) moves)])
+      (hash-table-put! table name board)
+      (format " !!~a:: " name))))
diff --git a/collects/games/parcheesi/test.ss b/collects/games/parcheesi/test.ss
new file mode 100644
index 0000000000..a0d3d13835
--- /dev/null
+++ b/collects/games/parcheesi/test.ss
@@ -0,0 +1,93 @@
+(module test mzscheme
+  (require (lib "pretty.ss"))
+  (provide test test-list test-err test-results)
+  
+  (define show-tests? #t)
+  
+  (define test-count (box 0))
+  (define failure-count  (box 0))
+  (define (test-results)
+    (cond
+      [(= 0 (unbox failure-count))
+       (fprintf (current-error-port) "All ~a tests passed." (unbox test-count))]
+      [else
+       (fprintf (current-error-port) "~a tests failed, ~a tests total" 
+                (unbox failure-count)
+                (unbox test-count))]))
+  
+  (define-syntax (test-err stx)
+    (syntax-case stx ()
+      [(_ actual pred)
+       (with-syntax ([line (syntax-line (syntax actual))])
+         (syntax
+          (with-handlers ([pred (lambda (x) (void))])
+            (when show-tests? (printf "> running test ~s\n" line))
+            (set-box! test-count (+ (unbox test-count) 1))
+            (fprintf (current-error-port)
+                     "test ~a ~s:\n expected error, got ~a\n\n"
+                     line
+                     'actual
+                     (flatten-list (call-with-values (lambda () actual) list)))
+            (set-box! failure-count (+ (unbox failure-count) 1)))))]))
+  
+  (define-syntax (test stx) 
+    (syntax-case stx ()
+      [(_ actual expecteds ...) (syntax (test/pred equal? actual expecteds ...))]))
+    
+  (define-syntax (test/pred stx)
+    (syntax-case stx ()
+      [(_ equal? actual expecteds ...)
+       (with-syntax ([line (syntax-line (syntax actual))])
+         (syntax
+          (begin
+            (when show-tests? (printf "> running test ~s\n" line))
+            (let ([actual-xs (call-with-values (lambda () actual) list)]
+                  [expect-xs (list expecteds ...)])
+              (set-box! test-count (+ (unbox test-count) 1))
+              (unless (equal? actual-xs expect-xs)
+                (set-box! failure-count (+ (unbox failure-count) 1))
+                (fprintf (current-error-port) "test ~a ~s:\ngot:\n" line 'actual)
+                (for-each (lambda (x) (pretty-print x (current-error-port))) actual-xs)
+                (fprintf (current-error-port) "expected:\n")
+                (for-each (lambda (x) (pretty-print x (current-error-port))) expect-xs))))))]))
+  
+  (define-syntax (test-list stx)
+    (syntax-case stx ()
+      [(_ actual expected)
+       (with-syntax ([line (syntax-line (syntax actual))])
+         (syntax
+          (begin
+            (when show-tests? (printf "> running test ~s\n" line))
+            (let ([actual-x actual]
+                  [expect-x expected]
+                  [show-err
+                   (lambda (in not-in val)
+                     (set-box! failure-count (+ (unbox failure-count) 1))
+                     (fprintf (current-error-port) "test ~a ~s found in ~a but not in ~a:\n" 
+                              line
+                              'actual
+                              in 
+                              not-in)
+                     (pretty-print val (current-error-port)))])
+              (set-box! test-count (+ (unbox test-count) 1))
+              (for-each (lambda (one-actual)
+                          (unless (member one-actual expect-x)
+                            (show-err "actual" "expected" one-actual)))
+                        actual-x)
+              (for-each (lambda (one-expected)
+                          (unless (member one-expected actual-x)
+                            (show-err "expected" "actual" one-expected)))
+                        expect-x)))))]))
+  
+  (define (flatten-list lst)
+    (cond
+      [(null? lst) ""]
+      [else
+       (let loop ([lst (cdr lst)]
+                  [ss (list (format "~e" (car lst)))])
+         (cond
+           [(null? lst) (apply string-append (reverse ss))]
+           [else (loop (cdr lst)
+                       (list* (format "~e" (car lst))
+                              " "
+                              ss))]))])))
\ No newline at end of file
diff --git a/collects/games/pousse/board-size.ss b/collects/games/pousse/board-size.ss
new file mode 100644
index 0000000000..de08802c27
--- /dev/null
+++ b/collects/games/pousse/board-size.ss
@@ -0,0 +1,3 @@
+(module board-size mzscheme
+  (define current-board-size (make-parameter 4))
+  (provide current-board-size))
diff --git a/collects/games/pousse/board.ss b/collects/games/pousse/board.ss
new file mode 100644
index 0000000000..78ec47e1ca
--- /dev/null
+++ b/collects/games/pousse/board.ss
@@ -0,0 +1,106 @@
+(module board mzscheme
+  (require "board-size.ss") ; for n
+  
+  (provide x o none     ; cell values
+	   new-board    ; n => board
+                        ;  where n is the board size
+                        ;  the board is empty
+	   board-cell   ; board col row => cell-value
+	                ;   cols/rows are numbered from 0
+	   push         ; board side index value => board
+	                ;   where side is one of
+	                ;        'top 'bottom 'left 'right
+	                ;   index is a number in [0, n-1]
+                        ;   values is x or o
+	   rotate-cw    ; board turns => board
+	                ;   rotates 90 degrees x turns
+	                ;   rotation affects board-cell and
+                        ;    push, but not find-board-in-history
+
+	   new-history             ; => history
+                                   ;  the history is empty
+	   find-board-in-history   ; board history => board or #f
+	   extend-history          ; board history => history
+	   extend-history!         ; board history => history
+                                   ;   maybe mutates the input history
+           )
+  
+  (define x #\x)
+  (define o #\o)
+  (define none #\space)
+  
+  (define-struct board (str n rotation))
+  
+  (define (new-board n)
+    (make-board (make-string (add1 (* n n)) #\space) n 0))
+  
+  (define (dup b)
+    (make-board (string-copy (board-str b)) (board-n b) (board-rotation b)))
+  
+  (define (unrotate-indices board row col)
+    (let ([n (current-board-size)])
+      (case (board-rotation board)
+        [(0) (values row col)]
+        [(1) (values (- (sub1 n) col) row)]
+        [(2) (values (- (sub1 n) row) (- (sub1 n) col))]
+        [(3) (values col (- (sub1 n) row))])))
+    
+  (define (board-cell board col row)
+    (let-values ([(row col) (unrotate-indices board row col)]
+                 [(n) (current-board-size)])
+      (string-ref (board-str board) (+ col (* row n)))))
+  
+  (define (set-cell! board col row v)
+    (let-values ([(row col) (unrotate-indices board row col)]
+                 [(n) (current-board-size)])
+      (string-set! (board-str board) (+ col (* row n)) v)))
+  
+  (define (xpush board c r inc-c inc-r piece)
+    (let ([board (dup board)]
+          [n (current-board-size)])
+      (let loop ([c c][r r][old piece])
+        (when (and (< -1 c n) (< -1 r n))
+          (let ([v (board-cell board c r)])
+            (set-cell! board c r old)
+            (unless (eq? v none)
+              (loop (inc-c c) (inc-r r) v)))))
+      (string-set! (board-str board) (* n n) piece) ; last move indicator
+      board))
+  
+  (define identity (lambda (x) x))
+  
+  (define push
+    (lambda (board dir i piece)
+      (let ([n (current-board-size)])
+        (case dir
+          [(left) (xpush board 0 i add1 identity piece)]
+          [(right) (xpush board (sub1 n) i sub1 identity piece)]
+          [(top) (xpush board i 0 identity add1 piece)]
+          [(bottom) (xpush board i (sub1 n) identity sub1 piece)]
+          [else (error 'push "bad directrion ~a" dir)]))))
+  
+  (define (rotate-cw board amt)
+    (let* ([b (dup board)]
+           [r (modulo (+ (board-rotation board) amt) 4)]
+           [r2 (if (negative? r)
+                   (+ r 4)
+                   r)])
+      (set-board-rotation! b r2)
+      b))
+  
+  
+  ;; In board.c, history is implemented with hash tables and fast
+  ;; compying. Here we just use an assoc list.
+  
+  (define (new-history) 
+    null)
+  
+  (define (find-board-in-history board h) 
+    (let ([v (assoc (string->symbol (board-str board)) h)])
+      (and v (cdr v))))
+  
+  
+  (define (extend-history board h)
+    (cons (cons (string->symbol (board-str board)) board) h))
+  
+  (define extend-history! extend-history))
diff --git a/collects/games/pousse/counter.ss b/collects/games/pousse/counter.ss
new file mode 100644
index 0000000000..cae56a706e
--- /dev/null
+++ b/collects/games/pousse/counter.ss
@@ -0,0 +1,127 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;  Rate a move by a combination of counting strategies
+;;
+;;  This code benefits greatly from mzc compilation.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(module counter mzscheme
+  (require "board.ss"
+           "utils.ss"
+           (lib "unitsig.ss"))
+  
+  (provide params^
+           counter@)
+  
+  (define-signature params^
+    (US-PIECE-WEIGHT
+     US-MIDDLE-PIECE-WEIGHT
+     US-LINE-PIECE-WEIGHT
+     US-CONNECT-PIECE-WEIGHT
+     
+     THEM-PIECE-WEIGHT
+     THEM-MIDDLE-PIECE-WEIGHT
+     THEM-LINE-PIECE-WEIGHT
+     THEM-CONNECT-PIECE-WEIGHT
+     
+     turn-number))
+  
+  
+  (define counter@
+    (unit/sig ()
+      (import (n) params^)
+      
+      (define (counter-based-goodness board orig-board as-player depth)
+        (let ([usses 0]
+              [thems 0]
+              [middle-usses 0]
+              [middle-thems 0]
+              [us-in-line 0]
+              [them-in-line 0]
+              [us-connect 0]
+              [them-connect 0])
+          (let ([traverse
+                 (lambda (board-cell)
+                   (n-times n (lambda (i)
+                                (let ([start-usses usses]
+                                      [start-thems thems]
+                                      [prev #f])
+                                  (n-times n (lambda (j)
+                                               (let ([v (board-cell board i j)])
+                                                 (cond
+                                                   [(eq? v as-player) (set! usses (add1 usses))
+                                                    (set! middle-usses (+ (min i (- (sub1 n) i)) middle-usses))
+                                                    (when (eq? v prev)
+                                                      (set! us-connect (add1 us-connect)))]
+                                                   [(eq? v none) 'nothing]
+                                                   [else (set! thems (add1 thems))
+                                                         (set! middle-thems (+ (min i (- (sub1 n) i)) middle-thems))
+                                                         (when (eq? v prev)
+                                                           (set! them-connect (add1 them-connect)))])
+                                                 (set! prev v))))
+                                  (set! us-in-line (+ us-in-line (* (- usses start-usses) (- usses start-usses))))
+                                  (set! them-in-line (+ them-in-line (* (- thems start-thems) (- thems start-thems))))))))])
+            ;; Go down columns
+            (traverse board-cell)
+            ;; Go across rows
+            (traverse (lambda (b x y) (board-cell b y x)))
+            ;; Counted usses and thems twice
+            (set! usses (/ usses 2))
+            (set! thems (/ thems 2)))
+          
+          '(when (= depth 2)
+             (fprintf (current-error-port)
+                      "us: ~a them: ~a  u-m:~a t-m: ~a u-l: ~a t-l: ~a u-c: ~a t-c: ~a~n"
+                      usses thems
+                      middle-usses middle-thems
+                      us-in-line them-in-line
+                      us-connect them-connect))
+          
+          (+ 0
+             
+             ;; If it's early in the game, bias towards the middle
+             (* middle-usses US-MIDDLE-PIECE-WEIGHT)
+             (* middle-thems THEM-MIDDLE-PIECE-WEIGHT)
+             
+             ;; We'd prefer to get rid of thems and not get rid of usses
+             (* usses US-PIECE-WEIGHT)
+             (* thems THEM-PIECE-WEIGHT)
+             
+             ;; Working towards a line is good
+             (* us-in-line US-LINE-PIECE-WEIGHT)
+             (* them-in-line THEM-LINE-PIECE-WEIGHT)
+             
+             ;; Working towards connected parts is good
+             (* us-connect US-CONNECT-PIECE-WEIGHT)
+             (* them-connect THEM-CONNECT-PIECE-WEIGHT)
+             
+             
+             ;;;;;;;;;;;;; High-level strategy ;;;;;;;;;;;;;;;;;
+             
+             ;; o: don't start on the same or opposite edge unless X is immediately
+             ;; pushed.
+             (if (and (= turn-number 1) (= usses 1) (= thems 1)
+                      (ormap (lambda (x) x) 
+                             (n-map n (lambda (i) (or (eq? (board-cell board i 0) x)
+                                                      (eq? (board-cell board i (sub1 n)) x))))))
+                 -500
+                 0)
+             
+             ;; x, first reply: always meddle with o's move if it's not in a corner
+             (if (and (= turn-number 2) (= usses 2) (= thems 1)
+                      (not (or (eq? (board-cell orig-board 0 0) o)
+                               (eq? (board-cell orig-board 0 (sub1 n)) o)
+                               (eq? (board-cell orig-board (sub1 n) 0) o)
+                               (eq? (board-cell orig-board (sub1 n) 0) o))))
+                 
+                 (if (ormap (lambda (x) x) (n-map (- n 2) (lambda (i) (eq? (board-cell board (add1 i) 1) o))))
+                     ;; We pushed it
+                     500
+                     
+                     ;; Do a push, instead
+                     -500)
+                 
+                 0)
+             
+             0)))
+      
+      counter-based-goodness)))
diff --git a/collects/games/pousse/doc.txt b/collects/games/pousse/doc.txt
new file mode 100644
index 0000000000..787b702200
--- /dev/null
+++ b/collects/games/pousse/doc.txt
@@ -0,0 +1,50 @@
+To play _Pousse_, run the "Games" application.
+
+Pousse (French for "push", pronounced "poo-ss") is a 2 person game,
+played on an N by N board (usually 4x4).  Initially the board is
+empty, and the players take turns inserting one marker of their color
+(X or O) on the board.  The color X always goes first.  The columns
+and rows are numbered from 1 to N, starting from the top left, as in:
+
+     1 2 3 4
+    +-+-+-+-+
+  1 | | | | |
+    +-+-+-+-+
+  2 | | | | |
+    +-+-+-+-+
+  3 | | | | |
+    +-+-+-+-+
+  4 | | | | |
+    +-+-+-+-+
+
+A marker can only be inserted on the board by sliding it onto a
+particular row from the left or from the right, or onto a particular
+column from the top or from the bottom.  So there are 4*N possible
+"moves" (ways to insert a marker).  They are be named "Li", "Ri",
+"Ti", "Bi" respectively, where "i" is the number of the row or column
+where the insertion takes place.
+
+When a marker is inserted, there may be a marker on the square where
+the insertion takes place.  In this case, all markers on the insertion
+row or column from the insertion square upto the first empty square
+are moved one square further to make room for the inserted marker.
+Note that the last marker of the row or column will be pushed off the
+board (and must be removed from play) if there are no empty squares on
+the insertion row or column.
+
+A row or a column is a "straight" of a given color, if it contains
+N markers of the given color.
+
+The game ends either when an insertion
+
+1) repeats a previous configuration of the board; in this case
+   the player who inserted the marker LOSES.
+
+2) creates a configuration with more straights of one color than
+   straights of the other color; the player whose color is dominant
+   (in number of straights) WINS.
+
+A game always leads to a win by one of the two players.  Draws are
+impossible.
+
+[From the 1998 ICFP programming contest.]
diff --git a/collects/games/pousse/help.txt b/collects/games/pousse/help.txt
new file mode 100644
index 0000000000..e171695835
--- /dev/null
+++ b/collects/games/pousse/help.txt
@@ -0,0 +1,37 @@
+The pousse GUI can
+
+ * play a person against another person,
+ * play a person against a program,
+ * play a program against another program, or
+
+The "Setup..." button opens a dialog for selecting one of the above
+modes, and for adding new program players to the system. Use
+"Setup..." to reset a game or to cancel a game where two programs are
+playing each other.
+
+Person Players 
+--------------
+Watch the status line above the board for information. When it's your
+turn, click on one of the numbers surrounding the board to move.
+
+The left and right arrows above the board undo and redo moves,
+respectively. The right side of the window shows the game played so
+far, including undone moves that have not yet been replaced. The most
+recent move is hilighted in blue.
+
+When a player loses by repeating a previous board configuration, the
+player's pieces turn red and no further moves are allowed (although
+moves can be undone). When a player wins, the player's pieces that
+form straights are turned green.
+
+Players are encouraged to move within 30 or 60 seconds. A beep is
+sounded at 30 and 60 seconds from the start of player's turn.
+
+Program Players
+---------------
+While a program player is ``thinking,'' the cursor changes to a watch
+over the board. When a person plays a program, clicking the left arrow
+while a program is thinking cancels the program and undoes the
+person's most recent move. Clicking the left arrow during the person's
+turn undoes the program's last move, plus the person's previous move
+(i.e., it undoes two moves).
diff --git a/collects/games/pousse/info.ss b/collects/games/pousse/info.ss
new file mode 100644
index 0000000000..bf379e8ccc
--- /dev/null
+++ b/collects/games/pousse/info.ss
@@ -0,0 +1,5 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Pousse")
+  (define doc.txt "doc.txt")
+  (define game "pousse.ss")
+  (define game-set "Board Games"))
diff --git a/collects/games/pousse/left.gif b/collects/games/pousse/left.gif
new file mode 100644
index 0000000000..6f6a5b8a8b
Binary files /dev/null and b/collects/games/pousse/left.gif differ
diff --git a/collects/games/pousse/pousse.png b/collects/games/pousse/pousse.png
new file mode 100644
index 0000000000..39158dba02
Binary files /dev/null and b/collects/games/pousse/pousse.png differ
diff --git a/collects/games/pousse/pousse.ss b/collects/games/pousse/pousse.ss
new file mode 100644
index 0000000000..bc6c2a1692
--- /dev/null
+++ b/collects/games/pousse/pousse.ss
@@ -0,0 +1,800 @@
+(module pousse mzscheme
+  (require "utils.ss"
+           "board.ss"
+           "board-size.ss"
+           (lib "class.ss")
+           (lib "class100.ss")
+           (lib "unit.ss")
+           (lib "mred.ss" "mred")
+           (prefix robot: "robot.ss"))
+  
+  (provide game-unit)
+  
+  (define game-unit
+    (unit
+      (import)
+      (export)
+      
+      ;; Graphical size of a cell in pixels
+      (define cell-size 40)
+      
+      ;; x/o font size (points)
+      (define font-size 24)
+      
+      ;; Automated players
+      (define x-player #f)
+      (define o-player #f)
+      
+      ;; Built-in program players
+      (define-struct robot (name player))
+      (define robots (list (make-robot "Stupid (always B1)" 
+                                       (lambda (n moves) 
+                                         (sleep 1) 
+                                         '(B 1)))
+                           (make-robot "Smart (30-sec strategy)"
+                                       robot:robot)))
+      
+      (define (local-file f)
+        (build-path (collection-path "games" "pousse") f))
+      
+      ;;; Game State ;;;
+      
+      (define board (new-board (current-board-size)))
+      (define history (new-history))
+      
+      (define current-player x)
+      
+      (define playing? #f) ; lock out board clicks when running an automated player
+      
+      (define winner #f)
+      (define loser #f)
+      
+      (define moves null)
+      
+      ;; For moving back and forth in the history:
+      (define past-state null)
+      (define future-state null)
+      
+      (define (convert-move s)
+        (list (string->symbol (string (char-downcase (string-ref s 0))))
+              (string->number (substring s 1 (string-length s)))))
+      
+      ;;; More Utilities ;;;
+      
+      (define (get-state) 
+        (list board moves current-player history winner loser))
+      
+      
+      ;; The move functions
+      (define (mk-push! side side-char)
+        (lambda (i)
+          (send canvas animate-push side i current-player)
+          (set! future-state null)
+          (set! past-state (cons (get-state) past-state))
+          (set! board (push board side i current-player))
+          (set! moves (append moves (list (format "~a~a" side-char (add1 i)))))
+          (set! current-player (other-player current-player))
+          (send clock-timer reset)
+          (send canvas repaint)))
+      (define push-left! (mk-push! 'left #\L))
+      (define push-right! (mk-push! 'right #\R))
+      (define push-top! (mk-push! 'top #\T))
+      (define push-bottom! (mk-push! 'bottom #\B))
+      
+      (define (check-winner)
+        (let ([v (find-winner board)])
+          (when v
+            (set! winner v))))
+      
+      (define (check-loser)
+        (when (find-board-in-history board history)
+          (set! loser (other-player current-player))))
+      
+      (define (in-straight? board v i j)
+        (let ([n (current-board-size)])
+          (or (andmap (lambda (x) x) 
+                      (n-map n (lambda (j) (eq? (board-cell board i j) v))))
+              (andmap (lambda (x) x)
+                      (n-map n (lambda (i) (eq? (board-cell board i j) v)))))))
+      
+      ;; past! and future! rewind or un-rewind the game:
+      (define-values (past! future!)
+        (let ([set-past (lambda (x) (set! past-state x))]
+              [set-future (lambda (x) (set! future-state x))])
+          (values
+           (lambda () (time-travel! (lambda () past-state) (lambda () future-state)
+                                    set-past set-future))
+           (lambda ()
+             (time-travel! (lambda () future-state) (lambda () past-state)
+                           set-future set-past)))))
+      
+      (define (time-travel! get-src get-dest set-src! set-dest!)
+        ;; If it's a person versus a robot, and it's the person's turn, then
+        ;; skip past the robot's turn. Cancel a running robot. If the game
+        ;; is over because a person lost (by repeating a board position)
+        ;; back up just once.
+        (define skip-robot (and (or x-player o-player) 
+                                ; Robot running?
+                                (not (send canvas kill-robot))
+                                ; Person lost?
+                                (not (and loser
+                                          (eq? loser (if x-player o x))))))
+        (set-dest! (cons (get-state) (get-dest)))
+        (when skip-robot
+          (set-dest! (cons (car (get-src)) (get-dest))))
+        (let ([a ((if skip-robot cadr car) (get-src))])
+          (set-src! ((if skip-robot cddr cdr) (get-src)))
+          (set! board (car a))
+          (set! moves (cadr a))
+          (set! current-player (caddr a))
+          (set! history (cadddr a))
+          (set! winner (list-ref a 4))
+          (set! loser (list-ref a 5)))
+        (send canvas repaint)
+        (send canvas refresh-controls))
+      
+      ;; Used to reset a game (via the "Setup..." dialog)
+      (define (init-game size)
+        (current-board-size size)
+        (set! board (new-board size))
+        (set! history (new-history))
+        (set! past-state null)
+        (set! current-player x)
+        (set! winner #f)
+        (set! loser #f)
+        (set! moves null)
+        (set! future-state null)
+        (set-canvas-size))
+      
+      ;; Restart for regular playing mode
+      (define (reset-game size)
+        (init-game size)
+        (send canvas repaint)
+        (send clock-timer reset)
+        (send canvas do-next-action))
+      
+      ;;; GUI ;;;
+      
+      (define animate-step 2/10)
+      (define animate-delay 0.05)
+      
+      (define red (make-object color% "RED"))
+      (define green (make-object color% "GREEN"))
+      (define black (make-object color% "BLACK"))
+      (define gray (make-object color% "GRAY"))
+      (define white (make-object color% "WHITE"))
+      
+      (define the-font (make-object font% font-size 'decorative 'normal 'bold))
+      (define the-pen (send the-pen-list find-or-create-pen "GRAY" 1 'solid))
+      
+      (define transparent-brush (send the-brush-list find-or-create-brush "WHITE" 'transparent))
+      (define solid-brush (send the-brush-list find-or-create-brush "GRAY" 'solid))
+      
+      (define watch-cursor (make-object cursor% 'watch))
+      
+      ; The canvas (drawing/event area) class
+      (define pousse-canvas%
+        (class100 canvas% args
+          (inherit get-dc)
+          (private-field
+           [dc #f]
+           [do-kill-robot (lambda () #f)]) ;; installed by refresh-controls
+          (public
+            [kill-robot (lambda () (do-kill-robot))]
+            [draw-box 
+             ; Draw a string in a box
+             (lambda (i j str)
+               (when str
+                 (let-values ([(w h d s) (send dc get-text-extent str)])
+                   (send dc draw-text str
+                         (+ (* i cell-size) (/ (- cell-size w) 2))
+                         (+ (* j cell-size) (/ (- cell-size h) 2))))))]
+            [do-next-action
+             (lambda ()
+               ;; See if anything interesting happened, then call refresh-controls (below)
+               (check-loser)
+               (check-winner)
+               (set! history (extend-history board history))
+               (refresh-controls))]
+            [refresh-controls
+             ;; Update the GUI to reflect the current game state, and run
+             ;; aa program player if it's time.
+             (lambda ()
+               (send history-text show-moves)
+               (send clock show (not (or winner loser)))
+               (if (or loser winner)
+                   (begin
+                     ;; Game over
+                     (enable-arrows)
+                     (repaint)
+                     (send status set-label
+                           (format "Game over: ~a ~a!" 
+                                   (if (equal? (or winner loser) x) "X" "O")
+                                   (if winner "wins" "loses")))
+                     (send clock show #f))
+                   ;; Check for automated player
+                   (let* ([killed? 'not-yet]
+                          [action void]
+                          [lock (make-semaphore 1)]
+                          [run-player-in-background
+                           ;; Lots of messy stuff for calling the OS to run a player. The
+                           ;; kill-robot method is installed for killing of the player process.
+                           (lambda (player)
+                             (let ([result #f]
+                                   [done (make-semaphore)]
+                                   [player-custodian (make-custodian)])
+                               (parameterize ([current-eventspace 
+                                               (parameterize ([current-custodian player-custodian])
+                                                 (make-eventspace))])
+                                 (queue-callback
+                                  (lambda ()
+                                    (let ([move (player 
+                                                 ;; board size
+                                                 (current-board-size)
+                                                 ;; change move representation:
+                                                 (map convert-move moves))])
+                                      (semaphore-wait lock)
+                                      (set! result move)
+                                      (set! killed? #f)
+                                      (semaphore-post lock)
+                                      (semaphore-post done)))))
+                               ;; Install the process killer. Must return #f
+                               ;;  if the robot is already done.
+                               (set! do-kill-robot (lambda ()
+                                                     (semaphore-wait lock)
+                                                     (begin0
+                                                       (if (eq? killed? 'not-yet)
+                                                           (begin
+                                                             (custodian-shutdown-all player-custodian)
+                                                             (set! killed? #t)
+                                                             (set! result #f)
+                                                             (semaphore-post done))
+                                                           #f)
+                                                       (semaphore-post lock))))
+                               
+                               ;; Wait for a response (or kill)...
+                               (send canvas set-cursor watch-cursor)
+                               (semaphore-wait done)
+                               (custodian-shutdown-all player-custodian) ;; just in case
+                               (send canvas set-cursor #f)
+                               (when result
+                                 (unless (and (list? result)
+                                              (= 2 (length result))
+                                              (symbol? (car result))
+                                              (regexp-match "^[tblrTBLR]$" (symbol->string (car result)))
+                                              (number? (cadr result))
+                                              (<= 1 (cadr result) (current-board-size)))
+                                   (error 'play "unacceptable reply: ~a" result))
+                                 (let* ([d (char-upcase (string-ref (symbol->string (car result)) 0))]
+                                        [p (cadr result)])
+                                   (set! action
+                                         (lambda ()
+                                           (case d
+                                             [(#\T) (push-top! (sub1 p))]
+                                             [(#\B) (push-bottom! (sub1 p))]
+                                             [(#\L) (push-left! (sub1 p))]
+                                             [(#\R) (push-right! (sub1 p))])))))))]
+                          [run-player
+                           ;; A wrapper for monitoring the program player in a MrEd thread.
+                           ;; Also handle the possibility that something goes wrong.
+                           (lambda (robot who)
+                             (send status set-label (format "~a: running ~a"
+                                                            who 
+                                                            (robot-name robot)))
+                             (let ([s (make-semaphore)])
+                               (thread (lambda () 
+                                         (with-handlers ([void (lambda (exn)
+                                                                 (message-box
+                                                                  "Error"
+                                                                  (format
+                                                                   (string-append
+                                                                    "There was an error running the "
+                                                                    "program player for ~a.~n"
+                                                                    "We'll assume a default move, T1.~n"
+                                                                    "Here is the error message:~n~a")
+                                                                   who
+                                                                   (if (exn? exn)
+                                                                       (exn-message exn)
+                                                                       exn))
+                                                                  #f '(ok))
+                                                                 (set! action (lambda () (push-top! 0))))])
+                                           (run-player-in-background (robot-player robot)))
+                                         (semaphore-post s)))
+                               (set! playing? #t)
+                               (enable-arrows)
+                               ;; Handle GUI events while we wait...
+                               (yield s)
+                               (set! playing? #f))
+                             (unless killed?
+                               (send status set-label "")
+                               (action)
+                               (do-next-action)))])
+                     ;; Run a program? Let a person play?
+                     (cond
+                       [(and (eq? current-player x) x-player) (run-player x-player "X")]
+                       [(and (eq? current-player o) o-player) (run-player o-player "O")]
+                       [else (send status set-label (format "~a's turn (click a number)"
+                                                            (if (eq? current-player x) "X" "O")))
+                             (enable-arrows)]))))])
+          ;; Animation state
+          (private-field
+           [tracking-i 0] ;; for tracking mouse clicks
+           [tracking-j 0]
+           [tracking-highlight? #f]
+           
+           [pushpiece #f] ;; piece being pushed onto board, #f for none
+           [pushrow -1]   ;; row being pushed, -1 for none
+           [pushcol -1]   ;; col being pushed, -1 for none
+           [pushdown? #t] ;; left or top push?
+           [amt 0])       ;; displacement for push, between -1 and 1
+          
+          (public
+            [do-draw
+             ;;;;;;;;;;;;;;;;;;;; Draw the Board ;;;;;;;;;;;;;;;;;;;;;;;
+             (lambda ()
+               (let ([n (current-board-size)])
+                 (send dc clear)
+                 (send dc set-pen the-pen)
+                 (send dc set-font the-font)
+                 (send dc set-text-foreground gray)
+                 (n-times (+ n 2) 
+                          (lambda (i)
+                            (when (<= 1 i (add1 n))
+                              (send dc draw-line cell-size (* i cell-size) 
+                                    (* (+ n 1) cell-size) (* i cell-size))
+                              (send dc draw-line (* i cell-size) cell-size 
+                                    (* i cell-size) (* (+ n 1) cell-size)))
+                            (when (<= 1 i n)
+                              (let ([draw-box
+                                     (lambda (i j s)
+                                       (if (and tracking-highlight?
+                                                (= i tracking-i)
+                                                (= j tracking-j))
+                                           (begin
+                                             (send dc set-text-foreground white)
+                                             (send dc set-brush solid-brush)
+                                             (send dc draw-ellipse
+                                                   (+ 2 (* i cell-size))
+                                                   (+ 2 (* j cell-size))
+                                                   (- cell-size 4)
+                                                   (- cell-size 4))
+                                             (draw-box i j s)
+                                             (send dc set-brush transparent-brush)
+                                             (send dc set-text-foreground gray))
+                                           (draw-box i j s)))])
+                                (draw-box i 0 (number->string i))
+                                (draw-box 0 i (number->string i))
+                                (draw-box i (add1 n) (number->string i))
+                                (draw-box (add1 n) i (number->string i))))))
+                 (send dc set-text-foreground black)
+                 (n-times n
+                          (lambda (i)
+                            (n-times n (lambda (j) 
+                                         (let ([v (board-cell board i j)])
+                                           (when (and (eq? winner v)
+                                                      (in-straight? board v i j))
+                                             (send dc set-text-foreground green))
+                                           (when (eq? loser v) 
+                                             (send dc set-text-foreground red))
+                                           (draw-box (+ i 1
+                                                        ;; Need to offset for animation?
+                                                        (if (= j pushrow)
+                                                            (if (let ([step (if pushdown? -1 1)])
+                                                                  (let loop ([i i])
+                                                                    (cond
+                                                                      [(or (= i -1) (= i n)) #t]
+                                                                      [(eq? (board-cell board i j) none) #f]
+                                                                      [else (loop (+ i step))])))
+                                                                amt
+                                                                0)
+                                                            0))
+                                                     (+ j 1
+                                                        ;; Need to offset for animation?
+                                                        (if (= i pushcol)
+                                                            (if (let ([step (if pushdown? -1 1)])
+                                                                  (let loop ([j j])
+                                                                    (cond
+                                                                      [(or (= j -1) (= j n)) #t]
+                                                                      [(eq? (board-cell board i j) none) #f]
+                                                                      [else (loop (+ j step))])))
+                                                                amt
+                                                                0)
+                                                            0))
+                                                     (cond
+                                                       [(eq? v none) #f]
+                                                       [(eq? v x) "x"]
+                                                       [(eq? v o) "o"]))
+                                           (when (or (eq? winner v) (eq? loser v))
+                                             (send dc set-text-foreground black)))))))
+                 (when pushpiece
+                   (draw-box (if (>= pushrow 0)
+                                 (if pushdown?
+                                     amt
+                                     (+ n 1 amt))
+                                 (+ 1 pushcol))
+                             (if (>= pushcol 0)
+                                 (if pushdown?
+                                     amt
+                                     (+ n 1 amt))
+                                 (+ 1 pushrow))
+                             (cond
+                               [(eq? pushpiece x) "x"]
+                               [(eq? pushpiece o) "o"])))))])
+          (private-field
+           [bitmap #f])
+          (public
+            [repaint (lambda ()
+                       (set! pushpiece #f)
+                       (set! pushcol -1)
+                       (set! pushrow -1)
+                       (unless dc
+                         (set! bitmap (make-object bitmap%
+                                        (* (+ (current-board-size) 2) cell-size)
+                                        (* (+ (current-board-size) 2) cell-size)))
+                         (set! dc (make-object bitmap-dc% bitmap)))
+                       (do-draw)
+                       (on-paint))]
+            
+            [new-bitmap (lambda () 
+                          (set! bitmap #f)
+                          (set! dc #f))]
+            
+            [animate-push (lambda (side pos player)
+                            (let ([n (current-board-size)])
+                              (set! pushpiece player)
+                              (set! pushrow (if (memq side '(right left))
+                                                pos
+                                                -1))
+                              (set! pushcol (if (memq side '(top bottom))
+                                                pos
+                                                -1))
+                              (set! pushdown? (memq side '(left top)))
+                              (set! tracking-i (if (memq side '(top bottom))
+                                                   (add1 pushcol)
+                                                   (if pushdown? 0 (add1 n))))
+                              (set! tracking-j (if (memq side '(right left))
+                                                   (add1 pushrow)
+                                                   (if pushdown? 0 (add1 n))))
+                              (set! tracking-highlight? #t)
+                              (let loop ([a 0])
+                                (set! amt ((if pushdown? + -) a))
+                                (do-draw)
+                                (send (get-dc) draw-bitmap bitmap 0 0)
+                                (sleep animate-delay)
+                                (if (= a 1)
+                                    (set! tracking-highlight? #f) ;; expects redraw triggered afterwards...
+                                    (loop (+ a animate-step))))))])
+          
+          (override
+            [on-paint (lambda ()
+                        (when bitmap
+                          (send (get-dc) draw-bitmap bitmap 0 0)))]
+            
+            ;;;;;;;;;;;;;;;;;;;; Handle Clicks ;;;;;;;;;;;;;;;;;;;;;;;
+            [on-event (lambda (e)
+                        ;; There are a lot of reasons why you might not be allowed to click...
+                        (cond
+                          [(and (not winner) (not loser) 
+                                (or (send e button-down?)
+                                    (send e dragging?)
+                                    (send e button-up?))
+                                (not playing?)
+                                (not (if (eq? current-player x) x-player o-player)))
+                           (let ([i (inexact->exact (floor (/ (send e get-x) cell-size)))]
+                                 [j (inexact->exact (floor (/ (send e get-y) cell-size)))])
+                             (cond
+                               [(send e button-down?)
+                                (set! tracking-i i)
+                                (set! tracking-j j)
+                                (set! tracking-highlight? #t)
+                                (repaint)]
+                               [(send e moving?)
+                                (let ([th? tracking-highlight?])
+                                  (set! tracking-highlight? (and
+                                                             (= tracking-i i)
+                                                             (= tracking-j j)))
+                                  (unless (eq? th? tracking-highlight?)
+                                    (repaint)))]
+                               [(send e button-up?)
+                                (if (and (= tracking-i i)
+                                         (= tracking-j j))
+                                    (let ([n (current-board-size)])
+                                      (when (cond
+                                              [(and (= j 0) (<= 1 i n)) (push-top! (sub1 i)) #t]
+                                              [(and (= j (add1 n)) (<= 1 i n)) (push-bottom! (sub1 i)) #t]
+                                              [(and (= i 0) (<= 1 j n)) (push-left! (sub1 j)) #t]
+                                              [(and (= i (add1 n)) (<= 1 j n)) (push-right! (sub1 j)) #t]
+                                              [else #f]) ; not on a number
+                                        ; Check for win/loss, run automated player
+                                        (do-next-action)))
+                                    (when tracking-highlight?
+                                      (set! tracking-highlight? #f)
+                                      (repaint)))]))]
+                          [else
+                           (when tracking-highlight?
+                             (set! tracking-highlight? #f)
+                             (repaint))]))])
+          
+          (sequence (apply super-init args))))
+      
+      ;; Create the GUI interface with the above pieces ;;
+      
+      ; Instantiate the canvas in a frame (= a top-level window)
+      (define frame (new (class frame%
+			   (augment*
+			    [can-close? (lambda () (inner #t can-close?))]
+			    ;; Close the frame => exit the program
+			    ;; No fancy "Quit" menus here!
+			    [on-close (lambda () (inner (void) on-close) (exit))])
+			   (super-new))
+			 [label "Pousse"] [style '(metal no-resize-border)]))
+      
+      ;; Panels are for GUI item layout (auto geometry management)
+      (define h-layout-panel (make-object horizontal-panel% frame))
+      (send h-layout-panel spacing 5)
+      (define game-panel (make-object vertical-panel% h-layout-panel))
+      (send game-panel stretchable-width #f)
+      (define history-panel (make-object vertical-panel% h-layout-panel))
+      
+      ;; Make the left and right arrow buttons
+      (define button-panel (make-object horizontal-panel% game-panel))
+      (send button-panel stretchable-height #f)
+      (define left-panel (make-object vertical-panel% button-panel))
+      (define past-button (make-object button% (make-object bitmap% (local-file "left.gif"))
+                            button-panel (lambda (b e) (past!))))
+      (define future-button (make-object button% (make-object bitmap% (local-file "right.gif"))
+                              button-panel (lambda (b e) (future!))))
+      (define right-panel (make-object vertical-panel% button-panel))
+      (define clock (make-object message% "00:00" right-panel))
+      (send left-panel min-width (send clock min-width)) ; layout trick
+      (send right-panel set-alignment 'right 'bottom)
+      
+      (define clock-timer (make-object
+                              (class100 timer% ()
+                                (private-field [init 0][dinged 0])
+                                (rename [super-start start])
+                                (public [reset (lambda ()
+                                                 (send clock set-label "00:00")
+                                                 (set! dinged 0)
+                                                 (set! init (current-seconds)))])
+                                (override
+                                  [notify 
+                                   (lambda ()
+                                     (let* ([v (- (current-seconds) init)])
+                                       ;; Ring bell once at 30 seconds, twice at 60 seconds
+                                       (when (send clock is-shown?)
+                                         (when (>= v 30)
+                                           (unless (> dinged 0) (bell) (set! dinged 1))
+                                           (when (>= v 60)
+                                             (unless (> dinged 1) (bell) (bell) (set! dinged 2)))))
+                                       (let ([v (if (>= v 3600) ; more than an hour
+                                                    (quotient v 3600)
+                                                    v)])
+                                         (send clock set-label
+                                               (format "~a~a:~a~a"
+                                                       (quotient v 600)
+                                                       (modulo (quotient v 60) 10)
+                                                       (quotient (modulo v 60) 10)
+                                                       (modulo v 10))))))]
+                                  [start (lambda ()
+                                           (set! init (current-seconds))
+                                           (super-start 1000 #f))])
+                                (sequence (super-init)))))
+      (send clock-timer start)
+      
+      ;; This procedure is called to enable/disable the arrow buttons
+      (define (enable-arrows)
+        (let ([ok? (lambda (state)
+                     (and ;; Something to rewind to?
+                      (pair? state)
+                      ;; Is it program vs. program?
+                      (not (and x-player o-player))
+                      ;; If we're playing a program, can we rewind twice?
+                      (or (not (or x-player o-player))
+                          (pair? (cdr state)))))])
+          (send past-button enable (ok? past-state))
+          (send future-button enable (ok? future-state))))
+      
+      ;; Make the status line
+      (define status (make-object message% "Pousse" game-panel))
+      (send status stretchable-width #t)
+      
+      ;; Make the canvas for drawing the game board
+      (define canvas (make-object pousse-canvas% game-panel))
+      
+      ; The canvas should stretch/shrink to fit the board
+      (define (set-canvas-size)
+        (let ([n (current-board-size)])
+          (send canvas min-client-width (* (+ n 2) cell-size))
+          (send canvas min-client-height (* (+ n 2) cell-size))
+          (send canvas new-bitmap)))
+      (set-canvas-size)
+      (send canvas focus)
+      
+      ; Make a text window for showing the board history to the right.
+      ; Uses the built-in text editor in MrEd, adding a show-moves
+      ; method to refresh the window after a move or rewind.
+      (make-object message% "Moves" history-panel)
+      (define history-canvas (make-object editor-canvas% history-panel #f '(no-hscroll)))
+      (define history-text (make-object (class100 text% ()
+                                          (inherit begin-edit-sequence end-edit-sequence
+                                                   erase insert delete change-style hide-caret
+                                                   set-position line-start-position line-end-position)
+                                          ; Ignore all user actions:
+                                          (override [on-char (lambda (e) (void))] [on-event (lambda (e) (void))])
+                                          (public
+                                            [show-moves
+                                             (lambda ()
+                                               (begin-edit-sequence)
+                                               (erase)
+                                               (change-style (make-object style-delta% 'change-normal))
+                                               (change-style (make-object style-delta% 'change-family 'swiss))
+                                               (for-each
+                                                (lambda (m) (insert m) (insert #\newline))
+                                                (if (null? future-state)
+                                                    moves
+                                                    (cadr (list-ref future-state (sub1 (length future-state))))))
+                                               (delete) ; delete that last newline
+                                               (if (null? moves)
+                                                   (set-position 0)
+                                                   (let* ([past-move (sub1 (length moves))]
+                                                          [start (line-start-position past-move)])
+                                                     (change-style (send 
+                                                                    (make-object style-delta% 'change-bold)
+                                                                    set-delta-foreground "BLUE")
+                                                                   start
+                                                                   (line-end-position past-move))
+                                                     (set-position start)))
+                                               (end-edit-sequence))])
+                                          (sequence (super-init) (hide-caret #t)))))
+      (send history-canvas set-editor history-text)
+      (send history-canvas min-client-width 30)
+      
+      ;; Setup and miscellaneous buttons at the bottom
+      
+      (define misc-panel (make-object horizontal-panel% frame))
+      (send misc-panel stretchable-height #f)
+      
+      (make-object button% "Help" misc-panel (lambda (b e) (help #f)))
+      (make-object button% "Setup..." misc-panel (lambda (b e) (setup)))
+      (make-object vertical-pane% misc-panel) ; spacer
+      
+      ;; Makes the setup dialog. Options dialogs are always a pain.
+      (define (make-setup-dialog)
+        (define d (make-object dialog% "Pousse Setup" frame 300 200))
+        (define config-panel (make-object vertical-panel% d))
+        (define game-panel (make-object vertical-panel% config-panel))
+        (define (make-player name)
+          (letrec ([p (make-object vertical-panel% game-panel '(border))]
+                   [m (make-object choice% (format "~a Player:" name) '("Person" "Program") p
+                        (lambda (m e) 
+                          (send l enable (positive? (send m get-selection)))
+                          (enable-ok)))]
+                   [l (make-object list-box% "Programs:" (map robot-name robots) p 
+                        (lambda (l e) (enable-ok)))])
+            (send l enable #f)
+            (values m l)))
+        (define board-size (make-object slider% "Board Size:" 4 20 game-panel void (current-board-size)))
+        (define-values (x-kind x-robot) (make-player "X"))
+        (define-values (o-kind o-robot) (make-player "O"))
+        
+        (define button-panel (make-object horizontal-pane% d))
+        (define load-button (make-object button% "Add a Player Program..." button-panel
+                              (lambda (b e)
+                                (with-handlers ([void
+                                                 (lambda (exn)
+                                                   (message-box "Error"
+                                                                (format "There was an error:~n~a"
+                                                                        (if (exn? exn)
+                                                                            (exn-message exn)
+                                                                            exn))))])
+                                  (let ([f (get-file "Get Player Program" d)])
+                                    (when f
+                                      (let ([player (dynamic-require f 'robot)])
+                                        (let ([name (get-text-from-user "Player Name"
+                                                                        "Player Program Name:"
+                                                                        d
+                                                                        (let-values ([(base name dir?)
+                                                                                      (split-path f)])
+                                                                          (path->string name)))])
+                                          (when name
+                                            (set! robots (append robots
+                                                                 (list (make-robot name player))))
+                                            (send x-robot set (map robot-name robots))
+                                            (send o-robot set (map robot-name robots)))))))))))
+        (define spacer (make-object vertical-pane% button-panel))
+        (define cancel-button (make-object button% "Cancel" button-panel 
+                                (lambda (b e) (send d show #f))))
+        (define ok-button (make-object button% "Start" button-panel 
+                            ;; Callback procedure invoked when the button is hit:
+                            (lambda (b e) 
+                              (send d show #f)
+                              (send canvas kill-robot) ; in case a robot was running
+                              (queue-callback
+                               (lambda ()
+                                 (let ([get-robot
+                                        (lambda (l)
+                                          (list-ref robots
+                                                    (send l get-selection)))]
+                                       [size (send board-size get-value)])
+                                   (if (zero? (send x-kind get-selection))
+                                       (set! x-player #f) ; person player
+                                       (set! x-player (get-robot x-robot)))
+                                   (if (zero? (send o-kind get-selection))
+                                       (set! o-player #f) ; person player
+                                       (set! o-player (get-robot o-robot)))
+                                   (reset-game size)))))
+                            '(border)))
+        
+        (define enable-ok (lambda () (send ok-button enable (and
+                                                             (or (zero? (send x-kind get-selection))
+                                                                 (send x-robot get-selection))
+                                                             (or (zero? (send o-kind get-selection))
+                                                                 (send o-robot get-selection))))))
+        
+        (send button-panel set-alignment 'right 'center)
+        (send button-panel stretchable-height #f)
+        
+        d)
+      
+      (define setup-dialog (make-setup-dialog))
+      (define setup-once? #f)
+      
+      (define (setup) 
+        (unless setup-once?
+          (send setup-dialog center)
+          (set! setup-once? #t))
+        (send setup-dialog show #t))
+      
+      ;; Help or source code window:
+      (define (help code?)
+        (define f (make-object frame% 
+                    (if code? "Pousse GUI Source Code" "Pousse Help")
+                    #f 580 300))
+        (define p (if code?
+                      (void)
+                      (make-object choice% #f '("Rules" "Using the GUI" "Writing Players")
+                        f
+                        (lambda (p ev)
+                          (send e lock #f)
+                          (send e load-file
+                                (local-file (case (send p get-selection)
+                                              [(0) "doc.txt"]
+                                              [(1) "help.txt"]
+                                              [(2) "robots.txt"])))
+			  (when (zero? (send p get-selection))
+			    ;; Delete the "run the Games app" line
+			    (send e delete 0 (send e line-start-position 2)))
+                          (send e lock #t)))))
+        (define c (make-object editor-canvas% f))
+        (define e (make-object text%))
+        (send c set-editor e)
+        (send (send (send e get-style-list) 
+                    find-named-style 
+                    "Standard")
+              set-delta
+              (make-object style-delta% 'change-family 'modern))
+        (send e load-file (local-file "doc.txt"))
+	;; Delete the "run the Games app" line
+	(send e delete 0 (send e line-start-position 2))
+        (send e lock #t)
+        (send f show #t))
+      
+      ; Draw initial board
+      (send canvas repaint)
+      
+      ; Arrow buttons initially enabled?
+      (enable-arrows)
+      
+      ; Don't allowing resizing the frame. Everything fits just right.
+      (send frame stretchable-width #f)
+      (send frame stretchable-height #f)
+      
+      ; Show the frame - we're off and running, now!
+      (send frame show #t)
+      
+      ; Take the first action.
+      (send canvas do-next-action)
+      
+      ; Loop forever (handling events). Frame's on-close callback method will exit.
+      (yield (make-semaphore 0)))))
diff --git a/collects/games/pousse/right.gif b/collects/games/pousse/right.gif
new file mode 100644
index 0000000000..0b2cf3002a
Binary files /dev/null and b/collects/games/pousse/right.gif differ
diff --git a/collects/games/pousse/robot.ss b/collects/games/pousse/robot.ss
new file mode 100644
index 0000000000..467b94cbf6
--- /dev/null
+++ b/collects/games/pousse/robot.ss
@@ -0,0 +1,313 @@
+(module robot mzscheme
+  (require "counter.ss"
+           "board.ss"
+           "utils.ss"
+           (lib "unitsig.ss"))
+  
+  (provide robot)
+  
+  (define robot
+    (lambda (n history-in)
+      
+      ;; Setup ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      
+      (define start-time (current-seconds))
+      
+      (define RUN-TIME 25) ; 5 seconds less, just to be on the safe side
+      
+      (define US-PIECE-WEIGHT 10)
+      (define US-MIDDLE-PIECE-WEIGHT 1)
+      (define US-LINE-PIECE-WEIGHT 1)
+      (define US-CONNECT-PIECE-WEIGHT 2)
+      
+      (define THEM-PIECE-WEIGHT (- US-PIECE-WEIGHT))
+      (define THEM-MIDDLE-PIECE-WEIGHT (- US-MIDDLE-PIECE-WEIGHT))
+      (define THEM-LINE-PIECE-WEIGHT (- US-LINE-PIECE-WEIGHT))
+      (define THEM-CONNECT-PIECE-WEIGHT (- US-CONNECT-PIECE-WEIGHT))
+      
+      (define THREAD-LIMIT 4)
+      (define thread-count 0)
+      
+      ;; Read in the board state and history,
+      ;; converting history to our format
+      (define-values (board history as-player turn-number)
+        (let loop ([history-in history-in][b (new-board n)][h (new-history)][x? #t][t 0])
+          (let ([h (extend-history! b h)])
+            (if (null? history-in)
+                (values b h (if x? x o) t)
+                (begin
+                  (let* ([d (caar history-in)]
+                         [p (cadar history-in)])
+                    (loop (cdr history-in)
+                          (push b
+                                (case d
+                                  [(t) 'top]
+                                  [(b) 'bottom]
+                                  [(l) 'left]
+                                  [(r) 'right])
+                                (sub1 p)
+                                (if x? x o))
+                          h
+                          (not x?)
+                          (add1 t))))))))
+      
+      (define RECURSION-DEPTH 
+        (if (< turn-number 2)
+            1
+            #f))
+      
+      (define WINNER-GOODNESS +inf.0)
+      (define LOSER-GOODNESS -inf.0)
+      (define MEDIUM-GOODNESS 0)
+      
+      (define IMMEDIATE-WINNER-GOODNESS (cons WINNER-GOODNESS 1))
+      (define IMMEDIATE-LOSER-GOODNESS (cons LOSER-GOODNESS 1))
+       
+      (define get-goodness 
+        (invoke-unit/sig counter@ (n) params^))
+      
+      ;;  Pick a move ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      
+      (define (make-get-best-move depth)
+        (lambda (board history as-player min-needed skip-right?)
+          (let* ([futures (n-map (if skip-right? (sub1 n) n)
+                                 (lambda (i) (cons (push board 'top i as-player) i)))]
+                 [winners (map (lambda (f) (cons (find-winner (car f)) (cdr f))) futures)])
+            ;; Can we win??
+            (let ([winning-move (ormap (lambda (w) (and (eq? (car w) as-player) (cdr w))) winners)])
+              (if winning-move
+                  ;; Yea!!
+                  (cons IMMEDIATE-WINNER-GOODNESS winning-move)
+                  
+                  ;; Drop moves where we lose by the other player winning, or we've been
+                  ;;  there before
+                  (let ([futures 
+                         (let loop ([fs futures][ws winners])
+                           (cond
+                             [(null? fs) null]
+                             [(or (caar ws) ; if there's a winner, it's not me!
+                                  (find-board-in-history (caar fs) history))
+                              (loop (cdr fs) (cdr ws))]
+                             [else (cons (car fs) (loop (cdr fs) (cdr ws)))]))])
+                    
+                    (if (null? futures)
+                        ;; No non-losing moves? Pick a default with a very low goodness
+                        (cons IMMEDIATE-LOSER-GOODNESS 0)
+                        
+                        ;; Now for the hard part. 
+                        (let* (;; First, estimate the goodness of the possible moves
+                               [goodnesses (map (lambda (f)
+                                                  (get-goodness (car f) board as-player depth))
+                                                futures)]
+                               
+                               [good-futures (map cons goodnesses futures)]
+                               ; Now we have a list of (cons <goodness> (cons <board> <move>))
+                               
+                               ;; Filter the set of futures to choose a plausible set under the lookahead
+                               ;;   threshold:
+                               [local-good-futures good-futures]
+                               
+                               [good-so-far LOSER-GOODNESS]
+                               
+                               ;; If we're not at depth 0, do a recursive lookahead
+                               [good-futures 
+                                (if (positive? depth)
+                                    (map (lambda (gf)
+                                           (cons (if (>= good-so-far min-needed)
+                                                     ;; We've got something good enough, so just return LOSER
+                                                     IMMEDIATE-LOSER-GOODNESS
+                                                     
+                                                     (let ([move (search-space (cadr gf) 
+                                                                               (extend-history (cadr gf) history)
+                                                                               (make-get-best-move (sub1 depth))
+                                                                               (other-player as-player)
+                                                                               ;; Need something better than what we have...
+                                                                               (- (car gf) good-so-far))])
+                                                       
+                                                       '(when (and (= depth RECURSION-DEPTH))
+                                                          (fprintf (current-error-port) "Returned goodness: ~a~n"  (car move))
+                                                          (print-board (cadr gf) (current-error-port)))
+                                                       
+                                                       (let ([g (car move)])
+                                                         (let* ([new-goodness 
+                                                                 (if (number? g)
+                                                                     ; normal future
+                                                                     (- (car gf) g)
+                                                                     
+                                                                     ; win/lose - try to delay a loss
+                                                                     (cons (- (car g)) (+ 10000 (car gf) (cdr g))))]
+                                                                [new-goodness-val (if (pair? new-goodness)
+                                                                                      (car new-goodness)
+                                                                                      new-goodness)])
+                                                           
+                                                           ;; New best goodness?
+                                                           (when (> new-goodness-val good-so-far)
+                                                             (set! good-so-far new-goodness-val))
+                                                           
+                                                           new-goodness))))
+                                                 (cdr gf)))
+                                         local-good-futures)
+                                    
+                                    ; Use what we have
+                                    local-good-futures)])
+                          
+                          '(when (and (= depth RECURSION-DEPTH))
+                             (for-each (lambda (gf)
+                                         (fprintf (current-error-port) "Goodness: ~a~n"  (car gf))
+                                         (print-board (cadr gf) (current-error-port)))
+                                       good-futures))
+                          
+                          
+                          (let ([r (if (andmap (lambda (x) (and (pair? (car x)) (= (caar x) LOSER-GOODNESS))) good-futures)
+                                       ;; All losers; pick to delay the inevitable
+                                       (let ([m (pick-best (map (lambda (x) (cons (cdar x) (cdr x))) good-futures))])
+                                         (cons (cons LOSER-GOODNESS (car m)) (cdr m)))
+                                       
+                                       ;; Weighted non-losses. Pick one now:
+                                       (pick-best good-futures))])
+                            
+                            ;; Strip the board out, getting just the index
+                            (cons (car r) (cddr r)))))))))))
+      
+      
+      ;; Symmetry ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      
+      ;; search-space is a symmetry helper. Lets you write a move chooser,
+      ;; get-best-move, that only needs to consider top pushes; the results
+      ;; from calling get-best-move four times are filtered down to a single
+      ;; choice. Also uses threads in the hope of exploiting extra
+      ;; processors.
+      
+      (define (search-space board history get-best-move as-player min-needed)
+        ;; get-best-move is called with:
+        ;;        board  history as-player skip-right?
+        ;;  It is actually called four times, once for each rotation of the board, so
+        ;;  get-best-move should only contemplate the space derived from pushing
+        ;;  at the top on the next move. If skip-right is #t, it shouldn't
+        ;;  contemplate pushing into the leftmost column because nothing's there;
+        ;;  a different rotation will catch the possibility.
+        ;; The return value of get-best-move should be
+        ;;   (cons <goodness-rating> <push-position>)
+        ;;  where <goodness-rating> is a number or
+        ;;     (box <aux-goodness>)
+        ;;  the box means loser; if all moves lose, the best <aux-godness> 
+        ;;  is picked.
+        ;; The return values of `search-space' is
+        ;;   (cons <goodness-rating> (cons <side> <push-position>))
+        ;;  where <side> is in '(#\T #\B #\R #\L)
+        
+        (let* ([top-board board]
+               [right-board (rotate-cw top-board 1)]
+               [bottom-board (rotate-cw right-board 1)]
+               [left-board (rotate-cw bottom-board 1)]
+               [moves (make-vector 4)]
+               [win-move #f]
+               [s (make-semaphore 0)]
+               [go (lambda (parallel? board pos transform)
+                     (let ([f (lambda ()
+                                (let ([v (transform 
+                                          (get-best-move board history as-player
+                                                         min-needed
+                                                         (eq? none (board-cell board (sub1 n) 0))))])
+                                  (vector-set! moves pos v)
+                                  (let ([value (if (pair? (car v))
+                                                   (caar v)
+                                                   (car v))])
+                                    (when (>= value min-needed)
+                                      ; Exceeded minimum necessary weight - short-circuit the rest
+                                      (set! win-move v)
+                                      (semaphore-post s)
+                                      (semaphore-post s)
+                                      (semaphore-post s))
+                                    (semaphore-post s))))])
+                       (unless win-move
+                         (if (and parallel? (< thread-count THREAD-LIMIT))
+                             (thread (lambda ()
+                                       ;; No locking on thread-count. It will be a little
+                                       ;;  inaccurate, but who cares?
+                                       (set! thread-count (add1 thread-count))
+                                       (f)
+                                       (set! thread-count (sub1 thread-count))))
+                             (f)))))])
+          (go #t top-board 0 (lambda (x) (cons (car x) (cons #\T (cdr x)))))
+          (go #t bottom-board 1 (lambda (x) (cons (car x) (cons #\B (- n 1 (cdr x))))))
+          (go #t left-board 2 (lambda (x) (cons (car x) (cons #\R (cdr x)))))
+          (go #f right-board 3 (lambda (x) (cons (car x) (cons #\L (- n 1 (cdr x))))))
+          (semaphore-wait s)
+          (semaphore-wait s)
+          (semaphore-wait s)
+          (semaphore-wait s)
+          (if win-move
+              win-move
+              (let ([l (vector->list moves)])
+                (if (andmap (lambda (x) (and (pair? (car x)) (= (caar x) LOSER-GOODNESS))) l)
+                    ;; All losers; pick to delay the inevitable
+                    (let ([m (pick-best (map (lambda (x) (cons (cdar x) (cdr x))) l))])
+                      (cons (cons LOSER-GOODNESS (car m)) (cdr m)))
+                    
+                    ;; Pick a non-losing move
+                    (pick-best l))))))
+      
+      ;; Using up our time ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      
+      ;; Loop, choosing a deeper level of dept-first searching
+      ;;  each time. Kill everything an use the most-recently
+      ;;  computed value if we run out of time. The goodness
+      ;;  cache is reset each time; presumably, each iteration
+      ;;  calculates more precise values, overriding the old ones.
+      
+      (define (use-up-time f)
+        (let ([result (cons (list-ref '(#\T #\B #\L #\R) (random 4)) (random n))] ; worst-case default
+              [c (make-custodian)])
+          (parameterize ([current-custodian c])
+            (thread 
+             (lambda ()
+               (let loop ([iteration 0])
+                 ; (fprintf (current-error-port) "Starting iteration ~a~n" iteration)
+                 (set! result (f iteration))
+                 '(fprintf (current-error-port) " [finished iteration depth ~a: ~a~a]~n" 
+                           iteration (cadr result) (add1 (cddr result)))
+                 (unless (or (pair? (car result)))
+                   (loop (add1 iteration)))))))
+          (let loop ()
+            (let ([sleep-time (- RUN-TIME (- (current-seconds) start-time))])
+              (when (> sleep-time 1) 
+                (sleep 1)
+                (unless (pair? (car result)) ; pair indicates win/lose
+                  (loop)))))
+          result))
+      
+      
+      ;; Result ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      
+      (define (go)
+        '(begin
+           (fprintf (current-error-port) "Start:~n")
+           (print-board board (current-error-port)))
+        (let* ([go (lambda (i) 
+                     (set! RECURSION-DEPTH i)
+                     (search-space board history (make-get-best-move i) as-player WINNER-GOODNESS))]
+               [depth RECURSION-DEPTH]
+               [result (if depth
+                           (go depth)
+                           (use-up-time go))])
+          '(when (pair? (car result))
+             (fprintf (current-error-port) "we ~a~n"
+                      (if (= (caar result) LOSER-GOODNESS)
+                          "lose"
+                          "win")))
+          (output-move (cdr result))))
+      
+      ;; Given (cons <side> <index>), returns the move
+      ;;   <side> is in '(#\T #\B #\R #\L)
+      (define (output-move move)
+        (list (case (car move)
+                [(#\T) 't]
+                [(#\B) 'b]
+                [(#\R) 'r]
+                [(#\L) 'l])
+              (add1 (cdr move))))
+      
+      (go))))
+    
+    
\ No newline at end of file
diff --git a/collects/games/pousse/robots.txt b/collects/games/pousse/robots.txt
new file mode 100644
index 0000000000..1d200dce3b
--- /dev/null
+++ b/collects/games/pousse/robots.txt
@@ -0,0 +1,40 @@
+A player program for Pousse is a module that exports a `robot'
+function. The `robot' function takes two arguments:
+
+ * The first argument is a number for the board size.
+
+ * The second argument is the history of moves as a list (with the
+   first move of the game at the beginning of the list).  Each move is
+   a list of two values: a symbol --- 't, 'l, 'b, or 'r --- and a
+   number.
+
+The result should be a move (a list containing a symbol and a number).
+
+The player program is not given the current board state, but it can be
+derived from the move history. The history is more useful than the
+board state, because a move that repeats a board state is a losing
+move.
+
+The following example player program always mimics the other player,
+choosing T1 if it has to go first:
+
+ ;; In the file my-robot.scm
+ (module my-robot mzscheme
+   (provide robot)
+
+   (define robot
+     (lambda (n moves)
+       (if (null? moves)
+	   ;; first move
+           '(t 1)
+	   ;; otherwise, mimic previous move
+	   (let loop ([moves moves])
+	     (if (null? (cdr moves))
+	         (car moves)
+	         (loop (cdr moves))))))))
+
+A robot should take 30 seconds or less to select a move.
+
+A program player is loaded into the game via the "Setup..." dialog,
+which has an "Add a Program Player..." button for selecting a file
+containing a module.
diff --git a/collects/games/pousse/utils.ss b/collects/games/pousse/utils.ss
new file mode 100644
index 0000000000..107d0baa59
--- /dev/null
+++ b/collects/games/pousse/utils.ss
@@ -0,0 +1,132 @@
+(module utils mzscheme
+  ; See boardsig.ss for the core utilities.
+  (require "board-size.ss"
+           "board.ss")
+  
+  (provide
+   n-times      ; call a procedure with each number in [0, n]
+   n-map        ; call a procedure with each number in [0, n] to make a list
+   print-board  ; pretty-prints a board
+   find-winner  ; checks a board to see if there's a winner
+   other-player ; x -> o   or  o -> x
+
+   quicksort    ; Quicksort
+
+   pick-best    ; takes a list of (cons <num> <val>) and returns pair
+                ;  with the biggest <num>, randomly chossing among
+                ;  equals
+   )
+   
+  ; Call f with each number in [0, n]
+  (define (n-times n f)
+    (let loop ([i 0])
+      (unless (= i n)
+        (f i)
+        (loop (add1 i)))))
+  
+  ; Call f with each number in [0, n] to make a list
+  (define (n-map n f)
+    (let loop ([i 0])
+      (if (= i n)
+          null
+          (cons (f i)
+                (loop (add1 i))))))
+  
+  
+  ; Pretty-prints the board
+  (define print-board
+    (case-lambda
+      [(b) (print-board b (current-output-port))]
+      [(b port)
+       (let ([n (current-board-size)])
+         (n-times n (lambda (j)
+                      (n-times n (lambda (i)
+                                   (fprintf port "~a " (let ([v (board-cell b i j)])
+                                                         (cond
+                                                           [(eq? v none) '-]
+                                                           [(eq? v x) 'x]
+                                                           [(eq? v o) 'o])))))
+                      (newline port))))]))
+  
+  ; Given a player (board cell value), get the other one
+  (define (other-player as-player)
+    (if (eq? as-player x)
+        o
+        x))
+  
+  ; See if the board has a winner; returns o, x, or #f
+  (define (find-winner board)
+    (let ([n (current-board-size)])
+      (let ([row-wins-x (make-vector n 1)]
+            [row-wins-o (make-vector n 1)]
+            [col-wins-x (make-vector n 1)]
+            [col-wins-o (make-vector n 1)])
+        (n-map n (lambda (i)
+                   (n-map n (lambda (j)
+                              (let ([v (board-cell board i j)])
+                                (cond
+                                  [(eq? v x) (vector-set! col-wins-o i 0)
+                                   (vector-set! row-wins-o j 0)]
+                                  [(eq? v o) (vector-set! col-wins-x i 0)
+                                   (vector-set! row-wins-x j 0)]
+                                  [else (vector-set! col-wins-o i 0)
+                                        (vector-set! row-wins-o j 0)
+                                        (vector-set! col-wins-x i 0)
+                                        (vector-set! row-wins-x j 0)]))))))
+        (let ([o-wins (+ (apply + (vector->list row-wins-o))
+                         (apply + (vector->list col-wins-o)))]
+              [x-wins (+ (apply + (vector->list row-wins-x))
+                         (apply + (vector->list col-wins-x)))])
+          (cond
+            [(= o-wins x-wins) #f]
+            [(> o-wins x-wins) o]
+            [else x])))))
+  
+  (define quicksort
+    (lambda (l less-than)
+      (let* ([v (list->vector l)]
+             [count (vector-length v)])
+        (let loop ([min 0][max count])
+          (if (< min (sub1 max))
+              (let ([pval (vector-ref v min)])
+                (let pivot-loop ([pivot min]
+                                 [pos (add1 min)])
+                  (if (< pos max)
+                      (let ([cval (vector-ref v pos)])
+                        (if (less-than cval pval)
+                            (begin
+                              (vector-set! v pos (vector-ref v pivot))
+                              (vector-set! v pivot cval)
+                              (pivot-loop (add1 pivot) (add1 pos)))
+                            (pivot-loop pivot (add1 pos))))
+                      (if (= min pivot)
+                          (loop (add1 pivot) max)
+                          (begin
+                            (loop min pivot)
+                            (loop pivot max))))))))
+        (vector->list v))))
+  
+  ; Compare the values in goodness and pick the biggest element.
+  ; Takes a non-empty list of (cons <goodness> <choice>)
+  ; If <goodness> is a pair, look at the car.
+  ; Return (cons <goodness> <choice>).
+  (define (pick-best choices)
+    (let loop ([l (cdr choices)]
+               [goodness (let ([g (caar choices)])
+                           (if (pair? g)
+                               (car g)
+                               g))]
+               [result (car choices)])
+      (if (null? l)
+          result
+          (let ([v (let ([v (caar l)])
+                     (if (pair? v)
+                         (car v)
+                         v))])
+            (cond
+	      [(> v goodness) (loop (cdr l) v (car l))]
+	      [(and (= v goodness)
+		    ; pick randomly
+		    (zero? (random 2)))
+	       (loop (cdr l) v (car l))]
+	      [else (loop (cdr l) goodness result)]))))))
diff --git a/collects/games/same/doc.txt b/collects/games/same/doc.txt
new file mode 100644
index 0000000000..a195809ccf
--- /dev/null
+++ b/collects/games/same/doc.txt
@@ -0,0 +1,18 @@
+** To play _Same_, run the Games application. **
+
+The object of Same is to score points by removing dots from the
+board. To remove a dot, click on it. As long as there is another dot
+of the same color next to the clicked dot, it will disappear along
+with all adjacent dots of the same color. After the dots disappear,
+dots in the rows above the deleted dots will fall into the vacated
+spaces. If an entire column is wiped out, all of the dots from the
+right will slide left to take up the empty column's space.
+
+Your score increases for each ball removed from the board. The score
+for each click is a function of the number of balls that
+disappeared. The "This Click" label shows how many points you would
+score for clicking the dots underneath the mouse pointer. The score
+varies quadratically with the number of balls, so eliminating many
+balls with one click is advantageous.
+
+Click the New Game button to play again. 
diff --git a/collects/games/same/info.ss b/collects/games/same/info.ss
new file mode 100644
index 0000000000..e6d1238404
--- /dev/null
+++ b/collects/games/same/info.ss
@@ -0,0 +1,6 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Same")
+  (define doc.txt "doc.txt")
+  (define game-set "Puzzle Games")
+  (define game "same.ss"))
+
diff --git a/collects/games/same/same.png b/collects/games/same/same.png
new file mode 100644
index 0000000000..96480a55e9
Binary files /dev/null and b/collects/games/same/same.png differ
diff --git a/collects/games/same/same.ss b/collects/games/same/same.ss
new file mode 100644
index 0000000000..1c508982b7
--- /dev/null
+++ b/collects/games/same/same.ss
@@ -0,0 +1,369 @@
+(module same mzscheme
+  (require (lib "etc.ss")
+           (lib "class.ss")
+           (lib "unit.ss")
+           (lib "mred.ss" "mred")
+           (lib "list.ss")
+           "../show-help.ss")
+  
+  (provide game-unit)
+  
+  (define game-unit
+    (unit
+      (import)
+      (export)
+      
+      (define board-width 20)
+      (define board-height 10)
+      (define cell-size 30)
+      (define colors (map (lambda (x) (make-object color% x)) (list "blue" "red" "magenta" "yellow" "cyan")))
+      (define pens (map (lambda (x) (make-object pen% x 1 'solid)) colors))
+      (define brushes (map (lambda (x) (make-object brush% x 'solid)) colors))
+      (define white-pen (make-object pen% "white" 1 'solid))
+      (define white-brush (make-object brush% "white" 'solid))
+      
+      ;; build-board : (-> (vectorof (vectorof (vector (union num #f) boolean))))
+      ;   this represents the board. Each entry is the color index of
+      ;   the piece and a node to mark for the depth-first traversal.
+      ;   #f for the color index indicates an eliminated piece.
+      (define (build-board)
+        (build-vector
+         board-width
+         (lambda (i)
+           (build-vector
+            board-height
+            (lambda (j)
+              (vector
+               (begin
+                 (if (= j (- board-height 1))
+                     (- (length colors) 1)
+                     (modulo i (- (length colors) 1)))
+                 (random (length colors)))
+               #f))))))
+      
+      (define board (build-board))
+      
+      (define game-over? #f)
+      
+      (define score 0)
+      (define (calc-score n)
+        (cond
+          [(= n 2) 2]
+          [else (- (* (- n 1) (- n 1)) (- n 3))]))
+      
+      (define same-canvas%
+        (class canvas%
+          (inherit get-dc get-client-size)
+          (define/private (get-width) (let-values ([(w h) (get-client-size)]) w))
+          (define/private (get-height) (let-values ([(w h) (get-client-size)]) h))
+          (define/private (get-x-step) (/ (get-width) board-width))
+          (define/private (get-y-step) (/ (get-height) board-height))
+          [define/public draw-cell
+            (lambda (dc highlight? i j)
+              (let ([index (vector-ref (vector-ref (vector-ref board i) j) 0)]
+                    [x (* i (get-x-step))]
+                    [y (* j (get-y-step))])
+		(send dc set-brush white-brush)
+		(send dc set-pen white-pen)
+		(send dc draw-rectangle x y (get-x-step) (get-y-step))
+		(when index
+		  (send dc set-brush (list-ref brushes index))
+		  (send dc set-pen (list-ref pens index))
+		  (cond
+		   [highlight?
+		    (send dc draw-ellipse 
+			  (floor (+ x (/ (get-x-step) 4)))
+			  (floor (+ y (/ (get-y-step) 4)))
+			  (floor (/ (get-x-step) 2))
+			  (floor (/ (get-y-step) 2)))]
+		   [else
+		    (send dc draw-ellipse x y (get-x-step) (get-y-step))]))))]
+          
+          [define/public  draw-line
+            (lambda (dc i)
+              (let ([show-turned? (> (length turned) 1)])
+                (let loop ([j board-height])
+                  (cond
+                    [(zero? j) (void)]
+                    [else
+                     (draw-cell dc (and show-turned? (member (list i (- j 1)) turned)) i (- j 1))
+                     (loop (- j 1))]))))]
+          
+          [define/public find-same-colors
+            (lambda (i j)
+              (let* ([index (vector-ref (vector-ref (vector-ref board i) j) 0)]
+                     [ans
+                      (let loop ([i i]
+                                 [j j]
+                                 [ps null])
+                        (cond
+                          [(not (and (<= 0 i) (< i board-width)
+                                     (<= 0 j) (< j board-height)))
+                           ps]
+                          [(vector-ref (vector-ref (vector-ref board i) j) 1) ps]
+                          [(not (vector-ref (vector-ref (vector-ref board i) j) 0)) ps]
+                          [(= index (vector-ref (vector-ref (vector-ref board i) j) 0))
+                           (let ([v (vector-ref (vector-ref board i) j)])
+                             (vector-set! v 1 #t)
+                             (loop (+ i 1)
+                                   j
+                                   (loop (- i 1)
+                                         j
+                                         (loop i
+                                               (- j 1)
+                                               (loop i
+                                                     (+ j 1)
+                                                     (cons (list v i j) ps))))))]
+                          [else ps]))])
+                (for-each (lambda (p) (vector-set! (first p) 1 #f)) ans)
+                ans))]
+          
+          [define/public get-game-over-size
+            (lambda (dc)
+              (let ([border 5])
+                (let-values ([(text-width text-height d l) (send dc get-text-extent game-over)])
+                  (let ([x (- (/ (get-width) 2) (/ text-width 2))]
+                        [y (- (/ (get-height) 2) (/ text-height 2))])
+                    (values x y text-width text-height border)))))]
+          
+          [define/public paint-game-over
+            (lambda (dc)
+              (send dc set-font font)
+              (let-values ([(x y text-width text-height border) (get-game-over-size dc)])
+                (send dc set-pen white-pen)
+                (send dc set-brush white-brush)
+                (send dc draw-rectangle
+                      (- x border) (- y border)
+                      (+ text-width border border)
+                      (+ text-height border border))
+                (send dc draw-text game-over x y)))]
+          
+          
+          (field
+           [game-over "Game Over"]
+           [font (make-object font% 24 'decorative 'normal 'normal #f)]
+           [turned null])
+          
+          [define/private recalc/draw-turned
+            (lambda (i j)
+              (set! turned (map (lambda (xx) (list (second xx) (third xx))) (find-same-colors i j)))
+              (cond
+                [(> (length turned) 1)
+                 (send this-message set-label (number->string (calc-score (length turned))))
+                 (for-each (lambda (p) (draw-cell (get-dc) #t (first p) (second p))) turned)]
+                [else
+                 (send this-message set-label "")]))]
+          
+          [define/override on-event
+            (lambda (evt)
+              (let+ ([val x (send evt get-x)]
+                     [val y (send evt get-y)]
+                     [val i (inexact->exact (floor (* (/ x (get-width)) board-width)))]
+                     [val j (inexact->exact (floor (* (/ y (get-height)) board-height)))])
+                    (cond
+                      [(or (send evt moving?)
+                           (send evt entering?)
+                           (send evt leaving?))
+                       (cond
+                         [(and (<= 0 i) (< i board-width)
+                               (<= 0 j) (< j board-height))
+                          (unless (member (list i j) turned)
+                            (when (> (length turned) 1)
+                              (for-each (lambda (p) (draw-cell (get-dc) #f (first p) (second p))) turned))
+                            (recalc/draw-turned i j))]
+                         [else
+                          (when (> (length turned) 1)
+                            (for-each (lambda (p) (draw-cell (get-dc) #f (first p) (second p))) turned))
+                          (set! turned null)
+                          (send this-message set-label "")])]
+                      [(send evt button-up?)
+                       (when (and (<= 0 i) (< i board-width)
+                                  (<= 0 j) (< j board-height))
+                         (when (> (length turned) 1)
+                           (for-each (lambda (p) (draw-cell (get-dc) #f (first p) (second p))) turned))
+                         (set! turned null)
+                         (send this-message set-label "")
+                         (let ([same-colors (find-same-colors i j)])
+                           
+                           ;; reset back the marks for the next depth-first traversal
+                           
+                           (when (>= (length same-colors) 2)
+                             
+                             ;; update score
+                             (set! score (+ score (calc-score (length same-colors))))
+                             (send message set-label (number->string score)) 
+                             
+                             ;; slide down empty pieces
+                             (let ([is null])
+                               (for-each
+                                (lambda (p)
+                                  (let ([i (second p)]
+                                        [j (third p)])
+                                    (unless (member i is)
+                                      (set! is (cons i is)))
+                                    (let loop ([x j])
+                                      (cond
+                                        [(<= 1 x)
+                                         (let ([next (vector-ref (vector-ref board i) (- x 1))]
+                                               [this (vector-ref (vector-ref board i) x)])
+                                           (vector-set! this 0 (vector-ref next 0))
+                                           (loop (- x 1)))]
+                                        [else
+                                         (vector-set! (vector-ref (vector-ref board i) x) 0 #f)]))))
+                                (quicksort same-colors
+                                           (lambda (x y) (<= (third x) (third y)))))
+                               
+                               ;; slide empty over empty rows
+                               (set! is (quicksort is >))
+                               (let ([empty-is (filter (lambda (i)
+                                                         (not (vector-ref (vector-ref (vector-ref board i) (- board-height 1)) 0)))
+                                                       is)])
+                                 (let ([is (if (null? empty-is)
+                                               is
+                                               (filter (lambda (x) (< x (car empty-is)))
+                                                       is))])
+                                   (for-each (lambda (empty-i)
+                                               (let loop ([i empty-i])
+                                                 (cond
+                                                   [(<= i (- board-width 2))
+                                                    (vector-set! board i (vector-ref board (+ i 1)))
+                                                    (loop (+ i 1))]
+                                                   [(= i (- board-width 1))
+                                                    (vector-set! board i (build-vector board-height
+                                                                                       (lambda (i) (vector #f #f))))])))
+                                             empty-is)
+                                   
+                                   ;; draw changed lines
+                                   (for-each (lambda (i) (draw-line (get-dc) i)) is)
+                                   (unless (null? empty-is)
+                                     (let loop ([i (car (last-pair empty-is))])
+                                       (cond
+                                         [(= i board-width) (void)]
+                                         [else (draw-line (get-dc) i)
+                                               (loop (+ i 1))])))
+                                   
+                                   ;; update `small' balls
+                                   (recalc/draw-turned i j)
+                                   )))
+                             
+                             (set! game-over?
+                                   (not
+                                    (let loop ([i board-width]
+                                               [continue? #f])
+                                      (cond
+                                        [(zero? i) continue?]
+                                        [else
+                                         (or continue?
+                                             (loop
+                                              (sub1 i)
+                                              (let loop ([j board-height]
+                                                         [continue? continue?])
+                                                (cond
+                                                  [(zero? j) continue?]
+                                                  [else
+                                                   (or continue?
+                                                       (loop
+                                                        (sub1 j)
+                                                        (> (length (find-same-colors (sub1 i) (sub1 j))) 1)))]))))])))) 
+                             (when game-over?
+                               (paint-game-over (get-dc))))))]
+                      
+                      [else (void)])))]
+          
+          [define/override on-paint
+            (lambda ()
+              (let ([dc (get-dc)])
+                (send dc set-pen white-pen)
+                (send dc set-brush white-brush)
+                (let loop ([i board-width])
+                  (cond
+                    [(zero? i) (void)]
+                    [else (draw-line dc (- i 1))
+                          (loop (- i 1))]))
+                (when game-over?
+                  (paint-game-over dc))))]
+          
+          (super-new)
+
+	  (send (get-dc) set-smoothing 'aligned)))
+      
+      (define semaphore (make-semaphore 0))
+      (define same-frame%
+        (class frame%
+          [define/augment on-close
+            (lambda ()
+	      (semaphore-post semaphore)
+              (inner (void) on-close))]
+          (super-new [style '(metal)])))
+      
+      (define find-largest-connected-region
+        (let ([biggest-so-far 0]
+              [tests 0])
+          (lambda ()
+            (let ([answer 0])
+              (let loop ([i 20])
+                (cond
+                  [(zero? i) (void)]
+                  [else
+                   (let loop ([j 10])
+                     (cond
+                       [(zero? j) (void)]
+                       [else (set! answer
+                                   (max
+                                    answer
+                                    (length
+                                     (send canvas find-same-colors
+                                           (- i 1) (- j 1)))))
+                             (loop (- j 1))]))
+                   (loop (- i 1))]))
+              (set! biggest-so-far (max biggest-so-far (calc-score answer)))
+              (set! tests (+ tests 1))
+              (printf "tests: ~a sofar: ~a largest connected region: ~a score ~a~n"
+                      tests
+                      biggest-so-far
+                      answer
+                      (calc-score answer))))))
+      
+      (define (new-game-callback redraw?)
+        (set! game-over? #f)
+        (set! board (build-board))
+        (unless (= score 0)
+          (set! score 0)
+          (send message set-label "0"))
+        (send this-message set-label "")
+        (when redraw?
+          (send canvas on-paint)))
+      
+      (define frame (make-object same-frame% "Same"))
+      (define panel (make-object vertical-panel% frame))
+      (define canvas (make-object same-canvas% panel))
+      (define hp (make-object horizontal-panel% panel))
+      (make-object message% "Total Score: " hp)
+      (define message (make-object message% "0" hp))
+      (make-object message% "This Score: " hp)
+      (define this-message (make-object message% "0" hp))
+      (define button (make-object button% "New Game" hp (lambda x (new-game-callback #t))))
+      '(make-object button% "Run Scores" hp (lambda x
+                                              (let loop ()
+                                                (new-game-callback #f)
+                                                (find-largest-connected-region)
+                                                (loop))))
+      
+      (define help-button (make-object button% "Help"
+                            hp
+                            (let ([show-help
+                                   (show-help
+                                    (list "games" "same")
+                                    "Same Help")])
+                              (lambda (_1 _2)
+                                (show-help)))))
+      
+      (send message stretchable-width #t)
+      (send this-message stretchable-width #t)
+      (send hp stretchable-height #f)
+      (send canvas min-width (* board-width cell-size))
+      (send canvas min-height (* board-height cell-size))
+      
+      (send frame show #t)
+      (yield semaphore))))
+    
\ No newline at end of file
diff --git a/collects/games/show-help.ss b/collects/games/show-help.ss
new file mode 100644
index 0000000000..8901d4637a
--- /dev/null
+++ b/collects/games/show-help.ss
@@ -0,0 +1,74 @@
+(module show-help mzscheme
+  (require (lib "class.ss")
+           (lib "mred.ss" "mred")
+	   (lib "etc.ss"))
+  
+  (provide show-help)
+  
+  (define show-help 
+    (opt-lambda (collections frame-title [verbatim? #f])
+      (let* ([f #f]
+	     [f%
+	      (class frame%
+		(define/augment (on-close)
+		  (set! f #f))
+		(super-instantiate () (label frame-title)))])
+	(lambda ()
+	  (if f
+	      (send f show #t)
+	      (let* ([frame (make-object f%)]
+		     [t (make-object text%)]
+		     [c (new editor-canvas% [parent frame] [editor t] [style '(auto-hscroll)])])
+		(send c min-width 500)
+		(send c min-height 300)
+		(send t auto-wrap (not verbatim?))
+		(call-with-input-file (build-path
+				       (apply collection-path collections)
+				       "doc.txt")
+		  (lambda (p)
+		    (let loop ()
+		      (let ([l (read-line p)])
+			(unless (eof-object? l)
+			  (cond
+			   [verbatim?
+			    (send t insert l)
+			    (send t insert #\newline)]
+			   [(regexp-match #rx"^[*][*].*[*][*]$" l)
+			    ;; Skip
+			    (void)]
+			   [(string=? l "")
+			    (unless (zero? (send t last-position))
+			      (send t insert #\newline)
+			      (send t insert #\newline))]
+			   [(and (regexp-match #rx"^-+$" l)
+				 (= (string-length l) 
+				    (- (send t last-position)
+				       (send t paragraph-start-position (send t last-paragraph))
+				       1)))
+			    ;; Change previous line style to title
+			    (let ([end (send t last-position)])
+			      (send t change-style 
+				    (send (make-object style-delta% 'change-weight 'bold)
+					  set-delta-foreground
+					  "blue")
+				    (- end 1 (string-length l)) (- end 1)))]
+			   [else
+			    (let ([l (regexp-replace #rx" +$" 
+						     (regexp-replace #rx"^ +" l "")
+						     "")])
+			      (send t insert l)
+			      (when (regexp-match #rx"^[*]" l)
+				(send t set-paragraph-margins
+				      (send t position-paragraph (send t last-position))
+				      16 32 0))
+			      (send t insert #\space))])
+			  (loop)))))
+		  'text)
+		(when verbatim?
+		  (send t change-style 
+			(make-object style-delta% 'change-family 'modern)
+			0 (send t last-position)))
+		(send t lock #t)
+		(send t set-position 0 0)
+		(send frame show #t)
+		(set! f frame))))))))
diff --git a/collects/games/slidey/11.jpg b/collects/games/slidey/11.jpg
new file mode 100644
index 0000000000..4e764c5d2c
Binary files /dev/null and b/collects/games/slidey/11.jpg differ
diff --git a/collects/games/slidey/info.ss b/collects/games/slidey/info.ss
new file mode 100644
index 0000000000..3dce20eb38
--- /dev/null
+++ b/collects/games/slidey/info.ss
@@ -0,0 +1,4 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Slidey")
+  (define game-set "Puzzle Games")
+  (define game "slidey.ss"))
diff --git a/collects/games/slidey/slidey.png b/collects/games/slidey/slidey.png
new file mode 100644
index 0000000000..c04c2fe2ff
Binary files /dev/null and b/collects/games/slidey/slidey.png differ
diff --git a/collects/games/slidey/slidey.ss b/collects/games/slidey/slidey.ss
new file mode 100644
index 0000000000..2599c7215f
--- /dev/null
+++ b/collects/games/slidey/slidey.ss
@@ -0,0 +1,358 @@
+
+(module slidey mzscheme
+  (require (lib "etc.ss")
+           (lib "class.ss")
+           (lib "unit.ss")
+           (lib "mred.ss" "mred"))
+  
+  (provide game-unit)
+  
+  (define game-unit
+    (unit
+      (import)
+      (export)
+      
+      (define (get-bitmap bitmap)
+        (define f (make-object dialog% "Choose Size" #f #f #f #f #f '(resize-border)))
+        (define bm-panel (make-object vertical-panel% f))
+        (define bm-message (make-object message% bitmap bm-panel))
+        (define size-message (make-object message% 
+                               (format "Image size: ~a x ~a pixels"
+                                       (send bitmap get-width)
+                                       (send bitmap get-height))
+                               bm-panel))
+        (define wide-panel (make-object vertical-panel% f '(border)))
+        (define sw (make-object slider% "Tiles (width)" 2 30 wide-panel
+                     (lambda (_1 _2)
+                       (update-horizontal-cutoff))))
+        (define tall-panel (make-object vertical-panel% f '(border)))
+        (define sh (make-object slider% "Tiles (height)" 2 30 tall-panel
+                     (lambda (_1 _2)
+                       (update-vertical-cutoff))))
+        (define button-panel (make-object horizontal-panel% f))
+        
+        (define cancelled? #t)
+        
+        (define cancel (make-object button% "Cancel" button-panel (lambda (_1 _2) (send f show #f))))
+        (define ok (make-object button% "OK" button-panel (lambda (_1 _2)
+                                                            (set! cancelled? #f) 
+                                                            (send f show #f)) '(border)))
+        
+        (define vertical-cutoff 0)
+        (define vertical-cutoff-message (make-object message% "" tall-panel))
+        
+        (define horizontal-cutoff 0)
+        (define horizontal-cutoff-message (make-object message% "" wide-panel))
+        
+        (define (update-vertical-cutoff)
+          (set! vertical-cutoff (modulo (send bitmap get-height) (send sh get-value)))
+          (send vertical-cutoff-message set-label 
+                (if (= 0 vertical-cutoff)
+                    ""
+                    (format "Vertical cutoff ~a pixels" vertical-cutoff))))
+        (define (update-horizontal-cutoff) 
+          (set! horizontal-cutoff (modulo (send bitmap get-width) (send sw get-value)))
+          (send horizontal-cutoff-message set-label 
+                (if (= 0 horizontal-cutoff)
+                    ""
+                    (format "Horizontal cutoff ~a pixels" horizontal-cutoff))))
+        
+        (send horizontal-cutoff-message stretchable-width #t)
+        (send vertical-cutoff-message stretchable-width #t)
+        (update-vertical-cutoff)
+        (update-horizontal-cutoff)
+        (send button-panel set-alignment 'right 'center)
+        (send button-panel stretchable-height #f)
+        (send bm-panel set-alignment 'center 'center)
+        (send wide-panel stretchable-height #f)
+        (send tall-panel stretchable-height #f)
+        (make-object grow-box-spacer-pane% button-panel)
+        (send f show #t)
+        
+        (if cancelled? 
+            (values #f #f #f)
+            (let* ([nb (make-object bitmap% 
+                         (- (send bitmap get-width) horizontal-cutoff)
+                         (- (send bitmap get-height) vertical-cutoff))]
+                   [bdc (make-object bitmap-dc% nb)])
+              (send bdc draw-bitmap-section bitmap 0 0 0 0
+                    (- (send bitmap get-width) horizontal-cutoff)
+                    (- (send bitmap get-height) vertical-cutoff))
+              (send bdc set-bitmap #f)
+              (values nb (send sw get-value) (send sh get-value)))))
+      
+      (define-struct loc (x y))
+      ;; board = (vector-of (vector-of (union #f (make-loc n1 n2))))
+      
+      ;; need to make sure that the bitmap divides nicely
+      ;(define bitmap (make-object bitmap% (build-path (collection-path "games" "slidey") "11.jpg")))
+      ;(define board-width 6)
+      ;(define board-height 5)
+      
+      (define (board-for-each board f)
+        (let loop ([i (vector-length board)])
+          (cond
+            [(zero? i) (void)]
+            [else
+             (let ([row (vector-ref board (- i 1))])
+               (let loop ([j (vector-length row)])
+                 (cond
+                   [(zero? j) (void)]
+                   [else
+                    (f (- i 1) (- j 1) (vector-ref row (- j 1)))
+                    (loop (- j 1))])))
+             (loop (- i 1))])))
+      
+      (define (move-one board from-i from-j to-i to-j)
+        (let ([from-save (board-ref board from-i from-j)]
+              [to-save (board-ref board to-i to-j)])
+          (board-set! board from-i from-j to-save)
+          (board-set! board to-i to-j from-save)))
+      
+      (define (board-set! board i j v)
+        (vector-set! (vector-ref board i) j v))
+      (define (board-ref board i j)
+        (vector-ref (vector-ref board i) j))
+      
+      (define (get-board-width board)
+        (vector-length board))
+      (define (get-board-height board)
+        (vector-length (vector-ref board 0)))
+      
+      (define (randomize-board board hole-i hole-j)
+        (let ([board-width (get-board-width board)]
+              [board-height (get-board-height board)])
+          (let loop ([no-good #f]
+                     [i (* 10 board-width board-height)]
+                     [m-hole-i hole-i]
+                     [m-hole-j hole-j])
+            (cond
+              [(zero? i) ;; move hole back to last spot
+               (let ([i-diff (abs (- m-hole-i hole-i))])
+                 (let loop ([i 0])
+                   (unless (= i i-diff)
+                     (move-one  
+                      board
+                      (+ m-hole-i i)
+                      m-hole-j 
+                      (+ m-hole-i i (if (< m-hole-i hole-i) +1 -1))
+                      m-hole-j)
+                     (loop (+ i 1)))))
+               (let ([j-diff (abs (- m-hole-j hole-j))])
+                 (let loop ([j 0])
+                   (unless (= j j-diff)
+                     (move-one
+                      board
+                      hole-i
+                      (+ m-hole-j j)
+                      hole-i
+                      (+ m-hole-j j (if (< m-hole-j hole-j) +1 -1)))
+                     (loop (+ j 1)))))]
+              [else 
+               (let ([this-dir (get-random-number 4 no-good)])
+                 (let-values ([(new-i new-j)
+                               (case this-dir
+                                 ; up
+                                 [(0) (values (- m-hole-i 1) m-hole-j)]
+                                 [(1) (values (+ m-hole-i 1) m-hole-j)]
+                                 [(2) (values m-hole-i (- m-hole-j 1))]
+                                 [(3) (values m-hole-i (+ m-hole-j 1))])])
+                   (if (and (<= 0 new-i)
+                            (< new-i board-width)
+                            (<= 0 new-j)
+                            (< new-j board-height))
+                       (let ([next-no-good
+                              (case this-dir
+                                [(0) 1]
+                                [(1) 0]
+                                [(2) 3]
+                                [(3) 2])])
+                         (move-one board new-i new-j m-hole-i m-hole-j)
+                         (loop next-no-good (- i 1) new-i new-j))
+                       (loop no-good (- i 1) m-hole-i m-hole-j))))]))))
+      
+      (define (get-random-number bound no-good)
+        (let ([raw (random (- bound 1))])
+          (cond
+            [(not no-good) raw]
+            [(< raw no-good) raw]
+            [else (+ raw 1)])))
+      
+      (define line-brush (send the-brush-list find-or-create-brush "black" 'transparent))
+      (define line-pen (send the-pen-list find-or-create-pen "white" 1 'solid))
+      (define mistake-brush (send the-brush-list find-or-create-brush "black" 'transparent))
+      (define mistake-pen (send the-pen-list find-or-create-pen "red" 1 'solid))
+      (define pict-brush (send the-brush-list find-or-create-brush "black" 'solid))
+      (define pict-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
+      (define white-brush (send the-brush-list find-or-create-brush "white" 'solid))
+      (define white-pen (send the-pen-list find-or-create-pen "white" 1 'solid))
+      
+      (define slidey-canvas%
+        (class canvas% 
+          (init-field bitmap board-width board-height)
+          
+          (define show-mistakes? #f)
+          (define/public (show-mistakes nv)
+            (set! show-mistakes? nv)
+            (unless solved?
+              (on-paint)))
+          
+          (define solved? #f)
+          
+          (define board
+            (build-vector
+             board-width
+             (lambda (i)
+               (build-vector
+                board-height
+                (lambda (j)
+                  (make-loc i j))))))
+          (define hole-i (- board-width 1))
+          (define hole-j (- board-height 1))
+          (board-set! board hole-i hole-j #f)
+          
+          (define/override (on-paint)
+            (if solved?
+                (send (get-dc) draw-bitmap bitmap 0 0)
+                (board-for-each
+                 board
+                 (lambda (i j v)
+                   (draw-cell i j)))))
+
+          (define/override (on-event evt)
+            (unless solved?
+              (cond
+                [(send evt button-down? 'left)
+                 (let-values ([(i j) (xy->ij (send evt get-x) (send evt get-y))])
+                   (slide i j))]
+                [else (void)])))
+          (inherit get-client-size get-dc)
+          
+          (define/private (check-end-condition)
+            (let ([answer #t])
+              (board-for-each
+               board
+               (lambda (i j v)
+                 (when v
+                   (unless (and (= i (loc-x v))
+                                (= j (loc-y v)))
+                     (set! answer #f)))))
+              (when answer
+                (set! solved? #t))))
+          
+          (define/private (slide i j)
+            (cond
+              [(= j hole-j)
+               (let loop ([new-hole-i hole-i])
+                 (cond
+                   [(= new-hole-i i) (void)]
+                   [else
+                    (let ([next (if (< i hole-i)
+                                    sub1
+                                    add1)])
+                      (move-one board (next new-hole-i) hole-j new-hole-i hole-j)
+                      (draw-cell new-hole-i hole-j)
+                      (draw-cell (next new-hole-i) hole-j)
+                      (loop (next new-hole-i)))]))
+               (set! hole-i i)
+               (check-end-condition)
+               (when solved?
+                 (on-paint))]
+              [(= i hole-i)
+               (let loop ([new-hole-j hole-j])
+                 (cond
+                   [(= new-hole-j j) (void)]
+                   [else
+                    (let ([next (if (< j hole-j)
+                                    sub1
+                                    add1)])
+                      (move-one board hole-i (next new-hole-j) hole-i new-hole-j)
+                      (draw-cell hole-i new-hole-j)
+                      (draw-cell hole-i (next new-hole-j))
+                      (loop (next new-hole-j)))]))
+               (set! hole-j j)
+               (check-end-condition)
+               (when solved?
+                 (on-paint))]
+              [else (void)]))
+          
+          (define/private (xy->ij x y)
+            (let-values ([(w h) (get-client-size)])
+              (values
+               (inexact->exact (floor (* board-width (/ x w))))
+               (inexact->exact (floor (* board-height (/ y h)))))))
+          
+          (define/private (ij->xywh i j)
+            (let-values ([(w h) (get-client-size)])
+              (let ([cell-w (/ w board-width)]
+                    [cell-h (/ h board-height)])
+                (values (* i cell-w)
+                        (* j cell-h)
+                        cell-w
+                        cell-h))))
+          (define/private (draw-cell draw-i draw-j)
+            (let-values ([(xd yd wd hd) (ij->xywh draw-i draw-j)])
+              (let* ([dc (get-dc)]
+                     [indicies (board-ref board draw-i draw-j)])
+                (if indicies
+                    (let ([bm-i (loc-x indicies)]
+                          [bm-j (loc-y indicies)])
+                      (let-values ([(xs ys ws hs) (ij->xywh bm-i bm-j)])
+                        (send dc set-pen pict-pen)
+                        (send dc set-brush pict-brush)
+                        (send dc draw-bitmap-section bitmap xd yd xs ys wd hd)
+                        (if (and show-mistakes?
+                                 (or (not (= draw-i bm-i))
+                                     (not (= draw-j bm-j))))
+                            (begin
+                              (send dc set-pen mistake-pen)
+                              (send dc set-brush mistake-brush))
+                            (begin
+                              (send dc set-pen line-pen)
+                              (send dc set-brush line-brush)))
+                        (send dc draw-rectangle xd yd wd hd)))
+                    (begin
+                      (send dc set-pen white-pen)
+                      (send dc set-brush white-brush)
+                      (send dc draw-rectangle xd yd wd hd))))))
+          
+          (inherit stretchable-width stretchable-height min-client-width min-client-height)
+          (super-instantiate ())
+          (randomize-board board hole-i hole-j)
+          (stretchable-width #f)
+          (stretchable-height #f)
+          (min-client-width (send bitmap get-width))
+          (min-client-height (send bitmap get-height))))
+      
+      (define f (make-object frame% "Slidey"))
+      (define p (make-object horizontal-panel% f))
+      (send p set-alignment 'center 'center)
+      (define slidey-canvas (make-object slidey-canvas%
+                              (make-object bitmap%
+                                (build-path (collection-path "games" "slidey") "11.jpg"))
+                              6 6 p))
+      (define bp (make-object horizontal-panel% f))
+      (send bp stretchable-height #f)
+      (define show-mistakes
+        (make-object check-box% "Show misplaced pieces" bp 
+          (lambda ___ (send slidey-canvas show-mistakes (send show-mistakes get-value)))))
+      (make-object grow-box-spacer-pane% bp)
+      
+      (define (change-bitmap)
+        (let ([fn (get-file)])
+          (when fn
+            (let ([bm (make-object bitmap% fn)])
+              (cond
+                [(send bm ok?)
+                 (let-values ([(bitmap w h) (get-bitmap bm)])
+                   (when bitmap
+                     (send p change-children (lambda (l) null))
+                     (set! slidey-canvas (make-object slidey-canvas% bitmap w h p))))]
+                [else (message-box "Slidey" (format "Unrecognized image format: ~a" fn))])))))
+      
+      (define mb (make-object menu-bar% f))
+      (define file-menu (make-object menu% "File" mb))
+      (make-object menu-item% "Open Image" file-menu (lambda (_1 _2) (change-bitmap)) #\o)
+      (make-object menu-item% "Close Window" file-menu (lambda (_1 _2) (send f show #f)) #\w)
+      
+      (send f show #t))))
diff --git a/collects/games/spider/doc.txt b/collects/games/spider/doc.txt
new file mode 100644
index 0000000000..c464a529e4
--- /dev/null
+++ b/collects/games/spider/doc.txt
@@ -0,0 +1,46 @@
+** To play _Spider_, run the "Games" application. **
+
+Spider is a solitare card game played with 104 cards. The cards can
+include either a single suit, two suits, or four suites. (Choose your
+variant through the "Options" item in the "Edit" menu.)
+
+Terminology:
+
+ * Tableau: one of the ten stacks of cards in the play area. The game
+   starts with six cards in the first four tableaus, and five cards in
+   the rest; only the topmost card is face up, and others are revealed
+   when they become the topmost card of the tableau.
+
+ * Sequence: a group of cards on the top of a tableau that are in the
+   same suit, and that are in sequence, with the lowest numbered card
+   topmost (i.e., closer to the bottom of the screen). King is high
+   and ace is low.
+
+The object of the game is to create a sequence with ace through king,
+at which point the sequence is removed from play. Create eight such
+sequences to win the game.
+
+On each move, you can either:
+
+ * Move a sequence from any tableau to one whose topmost card (i.e.,
+   closest to the bottom of the screen) has a value that's one more
+   than the sequence's value. Note that if the top card of the target
+   tableau has the same suit as the sequence, a larger sequence is
+   formed, but the target tableau's card is not required to have the
+   same suit.
+
+ * Move a sequence to an empty tableau.
+
+ * Deal ten cards from the deck (in the upper left corder), one to
+   each tableau. This move is allowed only if no tableau is empty.
+
+To move a sequence, either drag it to the target tableau, or click the
+sequence and then click the top card of the target tableau (or the
+place where a single card would be for an empty tableau). Click a
+select card to de-select it. Clicking a card that is not a valid
+target for the currently selected sequence causes the clicked card's
+sequence to be selected (if the card is face up in a sequence).
+
+To deal, click the deck.
+
+To undo a move, use "Undo" from the "Edit" menu.
diff --git a/collects/games/spider/info.ss b/collects/games/spider/info.ss
new file mode 100644
index 0000000000..69cc39ab32
--- /dev/null
+++ b/collects/games/spider/info.ss
@@ -0,0 +1,5 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Spider")
+  (define doc.txt "doc.txt")
+  (define game "spider.ss")
+  (define game-set "Card Games"))
diff --git a/collects/games/spider/spider.png b/collects/games/spider/spider.png
new file mode 100644
index 0000000000..609e5c7672
Binary files /dev/null and b/collects/games/spider/spider.png differ
diff --git a/collects/games/spider/spider.ss b/collects/games/spider/spider.ss
new file mode 100644
index 0000000000..39e726eb28
--- /dev/null
+++ b/collects/games/spider/spider.ss
@@ -0,0 +1,445 @@
+
+(module spider mzscheme
+  
+  (require (lib "cards.ss" "games" "cards")
+           (lib "class.ss")
+	   (lib "mred.ss" "mred")
+	   (lib "list.ss")
+	   (lib "file.ss")
+	   (lib "unit.ss")
+	   "../show-help.ss")
+
+  (define (list-first-n l n)
+    (if (zero? n)
+	null
+	(cons (car l) (list-first-n (cdr l) (sub1 n)))))
+  (define (vector-copy v)
+    (list->vector (vector->list v)))
+
+  (provide game-unit)
+  
+  (define game-unit
+    (unit 
+      (import)
+      (export)
+      
+      (define t (make-table "Spider" 11 6))
+
+      (define num-suits (get-preference 'spider:num-suits (lambda () 2)))
+
+      (define (make-spider-deck)
+	(let-values ([(suits copies)
+		      (case num-suits
+			[(1) (values '(spades) 4)]
+			[(2) (values '(spades hearts) 2)]
+			[(4) (values '(spades hearts clubs diamonds) 1)])])
+	  (let ([l (filter (lambda (c)
+			     (memq (send c get-suit) suits))
+			   (make-deck))])
+	    (let loop ([n (* 2 copies)])
+	      (if (zero? n)
+		  null
+		  (append (map (lambda (c) (send c copy)) l)
+			  (loop (sub1 n))))))))
+
+      (define deck (make-spider-deck))
+
+      (define draw-pile deck)
+
+      (define CARD-WIDTH (send (car deck) card-width))
+      (define CARD-HEIGHT (send (car deck) card-height))
+
+      (define dx (quotient CARD-WIDTH 11))
+      (define dy dx)
+
+      (define stacks (make-vector 10 null))
+      (define dones (make-vector 8 null))
+
+      (define done-count 0)
+
+      (define old-states null)
+
+      (define-struct state (draw-pile stacks dones done-count face-down?s))
+
+      (define mb (make-object menu-bar% t))
+
+      (define file-menu (make-object menu% "&File" mb))
+
+      (new menu-item% 
+	   [label "&Reset Game"]
+	   [parent file-menu]
+	   [callback (lambda (i e)
+		       (when (eq? 'yes (message-box "Reset Game"
+						    "Are you sure you want to reset the game?"
+						    t
+						    '(yes-no)))
+			 (reset-game!)))])
+
+      (new separator-menu-item%  [parent file-menu])
+
+      (new menu-item% 
+	   [label "&Close"]
+	   [parent file-menu]
+	   [shortcut #\W]
+	   [callback (lambda (i e) (send t show #f))])
+
+      (define edit-menu (make-object menu% "&Edit" mb))
+
+      (define undo
+	(new menu-item% 
+	     [label "&Undo"]
+	     [parent edit-menu]
+	     [shortcut #\Z]
+	     [callback (lambda (i e)
+			 (pop-state!))]))
+
+      (new separator-menu-item%  [parent edit-menu])
+
+      (new menu-item% 
+	   [label "&Options"]
+	   [parent edit-menu]
+	   [callback (lambda (i e)
+		       (define d (new dialog% 
+				      [label "Spider Options"]
+				      [parent t]
+				      [stretchable-width #f]
+				      [stretchable-height #f]))
+		       (define suits (new radio-box%
+					  [label #f]
+					  [parent (new group-box-panel%
+						       [parent d]
+						       [label "Number of Suits"]
+						       [stretchable-width #f]
+						       [stretchable-height #f])]
+					  [choices '("1 (easiest)" "2" "4 (hardest)")]))
+		       (define bottom-panel (new horizontal-panel%
+						 [parent d]
+						 [alignment '(right center)]
+						 [stretchable-height #f]))
+		       (new button% 
+			    [parent bottom-panel]
+			    [label "&Cancel"]
+			    [callback (lambda (b e) (send d show #f))])
+		       (new button%
+			    [parent bottom-panel]
+			    [label "&Ok"]
+			    [style '(border)]
+			    [callback (lambda (b e)
+					(let ([n (expt 2 (send suits get-selection))])
+					  (if (not (= n num-suits))
+					      (when (eq? 'yes 
+							 (message-box "Warning"
+								      "Reset the game for new suit count?"
+								      d
+								      '(yes-no)))
+						(set! num-suits n)
+						(put-preferences '(spider:num-suits) (list n))
+						(send d show #f)
+						(reset-game!))
+					      (send d show #f))))])
+		       (send suits set-selection (case num-suits [(1) 0][(2) 1][(4) 2]))
+		       (send d center)
+		       (send d show #t))])
+
+      (define help (show-help '("games" "spider") "Spider Rules" #f))
+      (new menu-item% 
+	   [label "&Rules"]
+	   [parent (make-object menu% "&Help" mb)]
+	   [callback (lambda (i e)
+		       (help))])
+
+      (define (push-state!)
+	(when (null? old-states)
+	  (send undo enable #t))
+	(set! old-states (cons (make-state 
+				draw-pile
+				(vector-copy stacks)
+				(vector-copy dones)
+				done-count
+				(map (lambda (c) (send c face-down?)) deck))
+			       old-states)))
+
+      (define (pop-state!)
+	(let ([state (car old-states)])
+	  (send t begin-card-sequence)
+	  (set! old-states (cdr old-states))
+	  (set! draw-pile (state-draw-pile state))
+	  (set! stacks (state-stacks state))
+	  (set! dones (state-dones state))
+	  (set! done-count (state-done-count state))
+	  (for-each (lambda (c fd?)
+		      (send c user-can-move #f)
+		      (unless (eq? (send c face-down?) fd?)
+			(send c flip)))
+		    deck (state-face-down?s state))
+	  (send t move-cards draw-pile dx dy)
+	  (send t stack-cards draw-pile)
+	  (let loop ([i 0])
+	    (unless (= i (vector-length stacks))
+	      (send t stack-cards (vector-ref stacks i))
+	      (loop (add1 i))))
+	  (let loop ([i 0])
+	    (unless (= i (vector-length dones))
+	      (move-dones i)
+	      (loop (add1 i))))
+	  (shift-stacks)
+	  (when (null? old-states)
+	    (send undo enable #f))
+	  (send t end-card-sequence)))
+
+      (define (find-stack find)
+	(let loop ([i 0])
+	  (if (= i (vector-length stacks))
+	      #f
+	      (let ([l (vector-ref stacks i)])
+		(if (and (pair? l)
+			 (memq find l))
+		    i
+		    (loop (add1 i)))))))
+
+      (define (remove-from-stack! cards)
+	(let* ([i (find-stack (car cards))]
+	       [l (vector-ref stacks i)])
+	  (vector-set! stacks i (list-tail l (length cards)))))
+
+      (define (stacked-cards card)
+	(let ([i (find-stack card)])
+	  (if i
+	      (reverse
+	       (let loop ([l (vector-ref stacks i)])
+		 (cond
+		  [(not (send (car l) user-can-move)) null]
+		  [(eq? (car l) card) (list card)]
+		  [else (cons (car l) (loop (cdr l)))])))
+	      #f)))
+
+      (define (drag-ok? cards i)
+	(let ([c (car cards)]
+	      [l (vector-ref stacks i)])
+	  (and l 
+	       (or (null? l)
+		   (= (send (car l) get-value)
+		      (add1 (send c get-value)))))))
+
+      (let loop ([i 0])
+	(unless (= i (vector-length stacks))
+	  null
+	  (let ([r (make-region (+ dx (* i (+ CARD-WIDTH dx)))
+				(+ dy CARD-HEIGHT dy)
+				CARD-WIDTH
+				(- (* CARD-HEIGHT 5) dy dy)
+				#f
+				(lambda (cards)
+				  (when (drag-ok? cards i)
+				    (move-to-stack cards i))))])
+	    (set-region-interactive-callback! 
+	     r 
+	     (lambda (on? cards)
+	       (let ([ok? (and on? (drag-ok? cards i))])
+		 (for-each (lambda (c)
+			     (send c snap-back-after-move (not ok?)))
+			   cards)
+		 (let ([l (vector-ref stacks i)])
+		   (unless (null? l)
+		     (send (car l) dim ok?))))))
+	    (send t add-region r)
+	    (loop (add1 i)))))
+
+      
+      (define (move-to-stack cards i)
+	(unselect)
+	(let ([l (vector-ref stacks i)])
+	  (unless (null? l)
+	    (send (car l) dim #f)))
+	(push-state!)
+	(remove-from-stack! cards)
+	(vector-set! stacks i 
+		     (append (reverse cards)
+			     (vector-ref stacks i)))
+	(for-each (lambda (c)
+		    (send c snap-back-after-move #t))
+		  cards)
+	(shift-stacks))
+
+      (define selected null)
+
+      (define (select cards)
+	(unselect)
+	(set! selected cards)
+	(for-each (lambda (c) (send c dim #t))
+		  selected))
+
+      (define (unselect)
+	(for-each (lambda (c) (send c dim #f))
+		  selected)
+	(set! selected null))
+
+      (define (move-dones i)
+	(send t move-cards (vector-ref dones i)
+	      (- (* 10 CARD-WIDTH) dx (* i (+ CARD-WIDTH dx)))
+	      dy))
+
+      (define (draw push?)
+	(when push?
+	  (push-state!))
+	(let ([drawn-cards
+	       (let loop ([i 0])
+		 (if (or (= i (vector-length stacks))
+			 (null? draw-pile))
+		     null
+		     (if (vector-ref stacks i)
+			 (let ([a (car draw-pile)])
+			   (vector-set! stacks i (cons a
+						       (vector-ref stacks i)))
+			   (send a flip)
+			   (set! draw-pile (cdr draw-pile))
+			   (cons a (loop (add1 i))))
+			 (loop (add1 i)))))])
+	  (send t card-to-front (car drawn-cards))
+	  (send t stack-cards drawn-cards))
+	(shift-stacks))
+      
+      (define (check-complete)
+	(let loop ([i 0])
+	  (unless (= i (vector-length stacks))
+	    (let ([l (vector-ref stacks i)])
+	      (when (and (pair? l)
+			 (= 1 (send (car l) get-value)))
+		(let ([suit (send (car l) get-suit)])
+		  (let loop ([j 2][a (list (car l))][l (cdr l)])
+		    (cond
+		     [(= j 14)
+		      ;; Complete set - move 13 cards to a done pile
+		      (vector-set! dones done-count a)
+		      (move-dones done-count)
+		      (set! done-count (add1 done-count))
+		      (for-each (lambda (c)
+				  (send c user-can-move #f))
+				a)
+		      (vector-set! stacks i l)]
+		     [(and (pair? l)
+			   (= j (send (car l) get-value))
+			   (equal? suit (send (car l) get-suit)))
+		      (loop (add1 j) (cons (car l) a) (cdr l))]
+		     [else (void)])))))
+	    (loop (add1 i)))))
+
+      (define (shift-stacks)
+	(unselect)
+	(check-complete)
+	(let ([cards (apply append (map reverse (vector->list stacks)))]
+	      [deltas (list->vector
+		       (let loop ([i 0])
+			 (if (= i (vector-length stacks))
+			     null
+			     (append 
+			      (let* ([l (vector-ref stacks i)]
+				     [ddy (min (quotient CARD-HEIGHT 3)
+					       (quotient (- (* CARD-HEIGHT 4)
+							    dy dy dy)
+							 (max 1 (sub1 (length l)))))])
+				(let loop ([l l][dy 0])
+				  (if (null? l)
+				      null
+				      (cons (list (* i (+ CARD-WIDTH dx)) dy)
+					    (loop (cdr l) (+ dy ddy))))))
+			      (loop (add1 i))))))])
+	  (send t move-cards cards dx (+ CARD-HEIGHT dy dy)
+		(lambda (i) (apply values (vector-ref deltas i))))
+	  
+	  (let loop ([i 0])
+	    (unless (= i (vector-length stacks))
+	      (let ([l (vector-ref stacks i)])
+		(when (pair? l)
+		  (when (send (car l) face-down?)
+		    (send t flip-card (car l)))
+		  (send (car l) user-can-move #t)
+		  (let loop ([l (cdr l)][prev (car l)])
+		    (unless (null? l)
+		      (if (and (not (send (car l) face-down?))
+			       (equal? (send prev get-suit)
+				       (send (car l) get-suit))
+			       (= (add1 (send prev get-value))
+				  (send (car l) get-value)))
+			  (begin
+			    (send (car l) user-can-move #t)
+			    (loop (cdr l) (car l)))
+			  (for-each (lambda (c)
+				      (send c user-can-move #f))
+				    l))))))
+	      (loop (add1 i))))))
+      
+      (send t set-double-click-action void)
+
+      (send t set-single-click-action
+	    (lambda (c)
+	      (cond
+	       [(and (pair? draw-pile)
+		     (eq? c (car draw-pile)))
+		(if (ormap null? (vector->list stacks))
+		    (bell)
+		    (draw #t))]
+	       [(and (pair? selected) (eq? c (car selected)))
+		(unselect)]
+	       [(and (pair? selected)
+		     (let ([i (find-stack c)])
+		       (and i
+			    (not (equal? i (find-stack (car selected))))
+			    (drag-ok? selected i)
+			    i)))
+		=> (lambda (i) 
+		     (send t card-to-front (car (last-pair selected)))
+		     (send t stack-cards (reverse selected))
+		     (move-to-stack selected i))]
+	       [(stacked-cards c)
+		=> (lambda (cards) (select cards))])))
+
+      ;; Add a region for each stack to receive clicks when
+      ;;  the stack is empty:
+      (let loop ([i 0])
+	(unless (= i (vector-length stacks))
+	  (send t add-region (make-button-region
+			      (+ dx (* i (+ CARD-WIDTH dx)))
+			      (+ dy CARD-HEIGHT dy)
+			      CARD-WIDTH CARD-HEIGHT
+			      #f
+			      (lambda ()
+				(when (and (null? (vector-ref stacks i))
+					   selected)
+				  (move-to-stack selected i)))))
+	  (loop (add1 i))))
+
+      (send t set-button-action 'left 'drag-raise/above)
+      (send t set-button-action 'middle 'drag-raise/above)
+      (send t set-button-action 'right 'drag-raise/above)
+
+      (define (reset-game!)
+	(send t remove-cards deck)
+	(set! deck (make-spider-deck))
+	(send t add-cards deck dx dy)
+	(send t begin-card-sequence)
+	(unselect)
+	(send undo enable #f)
+	(set! draw-pile (shuffle-list deck 7))
+	(for-each (lambda (c)
+		    (unless (send c face-down?)
+		      (send c flip))
+		    (send c user-can-flip #f)
+		    (send c user-can-move #f)
+		    (send c snap-back-after-move #t))
+		  draw-pile)
+	(set! stacks (make-vector 10 null))
+	(set! dones (make-vector 8 null))
+	(set! done-count 0)
+	(set! old-states null)
+	(send t stack-cards draw-pile)
+	(let loop ([i 0])
+	  (unless (= i (vector-length stacks))
+	    (let ([n (if (< i 4) 5 4)])
+	      (vector-set! stacks i (list-first-n draw-pile n))
+	      (set! draw-pile (list-tail draw-pile n)))
+	    (loop (add1 i))))
+	(draw #f)
+	(send t end-card-sequence))
+      (reset-game!)
+      (send t show #t))))
diff --git a/collects/graphics/graphics-posn-less-unit.ss b/collects/graphics/graphics-posn-less-unit.ss
new file mode 100644
index 0000000000..d412109e3a
--- /dev/null
+++ b/collects/graphics/graphics-posn-less-unit.ss
@@ -0,0 +1,1304 @@
+; graphics.ss
+; Simple graphics routines for MrEd
+; Originally written by Johnathan Franklin
+
+(module graphics-posn-less-unit mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "mred-sig.ss" "mred")
+           (lib "mred.ss" "mred")
+	   (lib "class.ss")
+	   (lib "class100.ss")
+	   (lib "etc.ss")
+	   "graphics-sig.ss")
+  (provide graphics-posn-less@)
+
+  (define-syntax define-do-pixel
+    (syntax-rules ()
+      [(_ name do-it v-name make-do-pixel)
+       (define (name viewport)
+	 (let ([f ((make-do-pixel do-it) viewport)])
+	   ;; Give a nicer name to f:
+	   (let ([v-name
+		  (case-lambda
+		   [(posn) (f posn)]
+		   [(posn color) (f posn color)])])
+	     v-name)))]))
+
+  (define-syntax define-string
+    (syntax-rules ()
+      [(_ name what v-name string-functions)
+       (define name
+	 (let ([finish (lambda (f)
+			 ;; Give a nicer name to f:
+			 (let ([v-name
+				(case-lambda
+				 [(posn text) (f posn text)]
+				 [(posn text color) (f posn text color)])])
+			   v-name))])
+	   (case-lambda
+	    [(viewport font)
+	     (finish ((string-functions 'what) viewport font))]
+	    [(viewport) 
+	     (finish ((string-functions 'what) viewport))])))]))
+
+(define graphics-posn-less@
+
+(unit/sig graphics:posn-less^
+  (import (mred : mred^)
+          graphics:posn^)
+  
+  (define send/proc
+    (lambda (class method . args)
+      (send-generic class (make-generic mred:dc<%> method) . args)))
+
+  (define send/proc2
+    (lambda (class method . args)
+      (send-generic class (make-generic sixlib-canvas% method) . args)))
+
+
+  (define-struct viewport (label canvas))
+  (define-struct sixmouse (x y left? middle? right?))
+  (define-struct sixkey (value))
+  (define graphics-flag #f)
+  (define global-viewport-list '())
+  (define global-color-vector (make-vector 300 #f))
+  (define global-pen-vector (make-vector 300 #f))
+  (define global-brush-vector (make-vector 300 #f))
+  (define default-font (make-object mred:font% 12 'roman 'normal 'normal #f 'unsmoothed))
+  (define black-color (make-object mred:color% "BLACK"))
+
+  (define sixlib-canvas%
+    (class100-asi mred:canvas% 
+      (inherit get-parent
+	       min-client-width min-client-height
+	       stretchable-width stretchable-height)
+      (private-field
+        [current-mouse-posn (make-posn 0 0)]
+	[queue%
+	 (class100 object% ()
+	   (private-field
+	     [queue '()]
+	     [last #f]
+	     [lock (make-semaphore 1)]
+	     [ready (make-semaphore)])
+	   (public
+	     [flush
+	      (lambda ()
+		(semaphore-wait lock)
+		(set! queue '())
+		(set! last #f)
+		(set! ready (make-semaphore))
+		(semaphore-post lock))]
+	     [add
+	      (lambda (v)
+		(semaphore-wait lock)
+		(if last
+		    (begin
+		      (set-cdr! last (cons v '()))
+		      (set! last (cdr last)))
+		    (begin
+		      (set! queue (cons v '()))
+		      (set! last queue)))
+		(semaphore-post ready)
+		(semaphore-post lock))]
+	     [remove
+	      (lambda ()
+		(semaphore-wait lock)
+		(begin0
+		 (if (null? queue)
+		     #f
+		     (begin0
+		      (car queue)
+		      (semaphore-wait ready)
+		      (set! queue (cdr queue))
+		      (if (null? queue)
+			  (set! last #f))))
+		 (semaphore-post lock)))]
+	     [remove/wait
+	      (lambda ()
+		(semaphore-wait ready)
+		(semaphore-post ready)
+		(remove))])
+	   (sequence
+	     (super-init)))]
+	[click-queue (make-object queue%)]
+	[release-queue (make-object queue%)]
+	[press-queue (make-object queue%)])
+      (private
+        [reset-size
+	 (lambda ()
+           (min-client-width width)
+           (min-client-height height)
+           (stretchable-width #f)
+           (stretchable-height #f)
+           (set! bitmap (make-object mred:bitmap% width height))
+           (unless (send bitmap ok?)
+             (error "cannot allocate viewport"))
+           (send buffer-dc set-bitmap bitmap)
+           (send buffer-dc set-brush (send dc get-brush))
+           (send buffer-dc set-pen (send dc get-pen))
+           (let ([f (send dc get-font)])
+             (when f
+               (send buffer-dc set-font f)))
+           (send buffer-dc clear)
+           (send dc clear))])
+      
+      (private-field ; were public
+        viewport
+	[height 0]
+	[width 0]
+	[label 0]
+	[current-pen 'uninitialized-pen]
+	[current-brush 'uninitialized-brush]
+	[bitmap 'uninitalized-bitmap]
+	[dc 'uninitialized-dc]
+	[buffer-dc 'uninitialized-buffer-dc])
+      
+      (public
+        [get-viewport (lambda () viewport)]
+	[set-viewport (lambda (x) (set! viewport x))]
+	[get-sixlib-height (lambda () height)]
+	[get-sixlib-width (lambda () width)]
+	[get-current-pen (lambda () current-pen)]
+	[get-current-brush (lambda () current-brush)]
+	[get-bitmap (lambda () bitmap)]
+	[get-sixlib-dc (lambda () dc)]
+	[get-buffer-dc (lambda () buffer-dc)]
+	[remember-pen (lambda (pen) (set! current-pen pen))]
+	[remember-brush (lambda (brush) (set! current-brush brush))])
+
+      (override
+       [on-paint
+	(lambda ()
+	  (let ([bm (send buffer-dc get-bitmap)])
+	    (send dc draw-bitmap bm 0 0)))]
+       
+       [on-event 
+	(lambda (mouse-event)
+          ;; this does deal with mouse events
+          ;; so let's try and put hooks in here
+          ;; after I know that it is a "good" sixm mouseclick
+	  (let* ([x (send mouse-event get-x)]
+		 [y (send mouse-event get-y)]
+		 [left? (send mouse-event button-down? 'left)]
+		 [middle? (send mouse-event button-down? 'middle)]
+		 [right? (send mouse-event button-down? 'right)]
+		 [sixm (make-sixmouse x y left? middle? right?)])
+	    (set! current-mouse-posn (make-posn x y))
+	    (cond
+	      [(send mouse-event button-down?)
+	       (send click-queue add sixm)]
+	      [(send mouse-event button-up?)
+	       (send release-queue add sixm)]
+	      [else (void)])))]
+       
+       [on-char
+	(lambda (key-event)
+          (let ([the-event (make-sixkey (send key-event get-key-code))])
+            ;; --- timing stuff : MF 4/4/2004
+            (if (procedure? on-char-proc)
+                (on-char-proc the-event)                  
+                (send press-queue add the-event))))])
+      
+      ;; --- timing stuff : MF 4/4/2004
+      (private-field
+        [the-world #f]
+        ;; KeyEvent World -> Void
+        [on-char-proc #f]
+        [__set-up-the-timer__
+         (set! timer-callback 
+               (lambda ()
+                 (set! the-world 
+                       (with-handlers ([exn:break? break-handler]
+                                       [exn? exn-handler])
+                         (on-tick-proc the-world)))))]
+        ;; World -> World 
+        [on-tick-proc void]
+        [exn-handler 
+         (lambda (e)
+           (send the-time stop)
+           (set! on-char-proc #f)
+           (raise e))]
+        [break-handler
+         (lambda _ 
+           (printf "animation stopped")
+           (send the-time stop)
+           (set! on-char-proc #f)
+           the-world)])
+      (public
+        [set-on-char-proc 
+         (lambda (f)
+           (let ([esp (current-eventspace)])
+             (if (procedure? on-char-proc)
+                 (error 'on-event "the event action has been set already")
+                 (set! on-char-proc 
+                       (lambda (e)
+                         (parameterize ([current-eventspace esp])
+                           (queue-callback 
+                            (lambda ()
+                              (set! the-world 
+                                    (with-handlers ([exn:break? break-handler]
+                                                    [exn? exn-handler])
+                                      (f e the-world))))
+                            #t)))))))]
+        [set-on-tick-proc ;; Number [seconds] (World -> World) -> Void
+         (lambda (delta f)
+           (if (eq? on-tick-proc void)
+               (set! on-tick-proc f)
+               (error 'on-tick "the timing action has been set already"))
+           (send the-time start delta))]
+        [stop-tick 
+         (lambda ()
+           (set! on-char-proc #f)
+           (set! on-tick-proc void)
+	   the-world)]
+        [init-world (lambda (w) (set! the-world w))])
+      ;; --- end timing stuff
+      
+      (public 
+	[get-click
+	 (lambda ()
+	   (send click-queue remove))]
+	[get-click-now
+	 (lambda ()
+	   (send click-queue remove/wait))]
+	
+	[get-release
+	 (lambda ()
+	   (send release-queue remove))]
+	[get-release-noew
+	 (lambda ()
+	   (send release-queue remove/wait))]
+	
+	[get-press
+	 (lambda ()
+	   (send press-queue remove))]
+	[get-press-now
+	 (lambda ()
+	   (send press-queue remove/wait))]
+	
+	[get-posn (lambda () current-mouse-posn)]
+	[set-dc (lambda (new-dc) (set! dc new-dc))]
+	[set-buffer-dc (lambda (new-buffer-dc) (set! buffer-dc
+						     new-buffer-dc))]
+	
+	[set-geometry
+	 (lambda (new-width new-height)
+	   (set! height new-height)
+	   (set! width new-width)
+	   (reset-size))]
+	[set-height (lambda (new-height) 
+		      (set! height new-height)
+		      (reset-size))]
+	[set-width (lambda (new-width) 
+		     (set! width new-width)
+		     (reset-size))]
+	
+	
+	[viewport-flush-input
+	 (lambda ()
+	   (send click-queue flush)
+	   (send release-queue flush)
+	   (send press-queue flush))])))
+  
+  (define open-frames-timer (make-object mred:timer%))
+  
+  ;; --- timing events --- MF
+  [define the-time
+    (new timer% [notify-callback (lambda () (timer-callback))])]
+  [define timer-callback void]
+  ;; --- end timing --- 
+
+  (define sixlib-frame%
+    (class mred:frame%
+      (field [canvas #f])
+      (define/public (set-canvas x) (set! canvas x))
+      (define/augment (on-close)        
+	(close-viewport (send canvas get-viewport))
+        (send the-time stop)
+	(inner (void) on-close))
+      (super-instantiate ())))
+  
+  (define repaint
+    (lambda (viewport)
+      (send (viewport-canvas viewport) on-paint)))
+  
+  (define viewport-dc 
+    (lambda (viewport)
+      (send (viewport-canvas viewport) get-sixlib-dc)))
+  
+  (define viewport-buffer-dc
+    (lambda (viewport)
+      (send (viewport-canvas viewport) get-buffer-dc)))
+
+  (define viewport-bitmap
+    (lambda (viewport)
+      (send (viewport-canvas viewport) get-bitmap)))
+  
+  (define viewport-frame
+    (lambda (viewport)
+      (send (send (viewport-canvas viewport) get-parent) get-parent)))
+  
+  (define viewport-height
+    (lambda (viewport)
+      (send (viewport-canvas viewport) get-sixlib-height)))
+  
+  (define viewport-width
+    (lambda (viewport)
+      (send (viewport-canvas viewport) get-sixlib-width)))
+  
+  (define (get-mouse-click viewport)
+    (send (viewport-canvas viewport) get-click-now))
+  
+  (define (init-world viewport)
+    (lambda (w)
+      (send (viewport-canvas viewport) init-world w)))
+  
+  (define (set-on-key-event viewport)
+    (lambda (f)
+      (send (viewport-canvas viewport) set-on-char-proc f)))
+  
+  (define (set-on-tick-event viewport)
+    (lambda (delta f)
+      (send (viewport-canvas viewport) set-on-tick-proc delta f)))
+  
+  (define (stop-tick viewport)
+    (lambda ()
+      (send (viewport-canvas viewport) stop-tick)))
+
+  (define (get-key-press viewport) 
+    (send (viewport-canvas viewport) get-press-now))
+  
+  (define (ready-mouse-click viewport)
+    (send (viewport-canvas viewport) get-click))
+  
+  (define (ready-mouse-release viewport)
+    (send (viewport-canvas viewport) get-release))
+  
+  (define (ready-key-press viewport)
+    (send (viewport-canvas viewport) get-press))
+  
+  (define mouse-click-posn
+    (lambda (mouse-event)
+      (make-posn (sixmouse-x mouse-event) (sixmouse-y mouse-event))))
+  
+  (define query-mouse-posn
+    (lambda (viewport) (send (viewport-canvas viewport) get-posn)))
+  
+  (define viewport-flush-input
+    (lambda (viewport) (send (viewport-canvas viewport) viewport-flush-input)))
+  
+  (define left-mouse-click?
+    (lambda (mouse-event) (sixmouse-left? mouse-event)))
+  
+  (define middle-mouse-click?
+    (lambda (mouse-event) (sixmouse-middle? mouse-event)))
+  
+  (define right-mouse-click?
+    (lambda (mouse-event) (sixmouse-right? mouse-event)))
+  
+  (define key-value sixkey-value)
+  
+  (define clear-viewport
+    (lambda (viewport)
+      (let* ([vdc (viewport-dc viewport)]
+	     [vbdc (viewport-buffer-dc viewport)])
+	(lambda ()
+	  (send vdc clear)
+	  (send vbdc clear)))))
+
+
+  
+  (define draw-viewport
+    (lambda (viewport)
+      (let* ([dc (viewport-dc viewport)]
+	     [buffer-dc (viewport-buffer-dc viewport)]
+	     [w (viewport-width viewport)]
+	     [h (viewport-height viewport)])
+	(rec draw-viewport/color
+	     (case-lambda
+	      [(color)
+	       (let ([new-pen (send mred:the-pen-list find-or-create-pen color 1 'solid)]
+		     [new-brush (send mred:the-brush-list find-or-create-brush color 'solid)]
+		     [old-pen (send dc get-pen)]
+		     [old-brush (send dc get-brush)])
+		 (send dc set-pen new-pen)
+		 (send dc set-brush new-brush)
+		 (send buffer-dc set-pen new-pen)
+		 (send buffer-dc set-brush new-brush)
+		 (send dc draw-rectangle 0 0 w h)
+		 (send buffer-dc draw-rectangle 0 0 w h)
+		 (send dc set-pen old-pen)
+		 (send buffer-dc set-pen old-pen)
+		 (send dc set-brush old-brush)
+		 (send buffer-dc set-brush old-brush))]
+	      [() (draw-viewport/color (make-rgb 0 0 0))])))))
+  
+  (define flip-viewport
+    (lambda (viewport)
+      (let* ([dc (viewport-dc viewport)]
+	     [dc2 (viewport-buffer-dc viewport)]
+	     [w (viewport-width viewport)]
+	     [h (viewport-height viewport)])
+	(lambda ()
+	  (let ([pen (send dc get-pen)]
+		[pen2 (send dc2 get-pen)]
+		[brush (send dc get-brush)]
+		[brush2 (send dc2 get-brush)])
+	    (send dc set-pen xor-pen)
+	    (send dc2 set-pen xor-pen)
+	    (send dc set-brush xor-brush)
+	    (send dc2 set-brush xor-brush)
+	    (send dc draw-rectangle 0 0 w h)
+	    (send dc2 draw-rectangle 0 0 w h)
+	    (send dc set-pen pen)
+	    (send dc2 set-pen pen2)
+	    (send dc set-brush brush)
+	    (send dc2 set-brush brush2))))))
+  
+  (define close-viewport
+    (lambda (viewport)
+      (set! global-viewport-list 
+	    (let loop ([l global-viewport-list])
+	      (cond
+		[(null? l) '()]
+		[(eq? (car l) viewport) (cdr l)]
+		[else (cons (car l) (loop (cdr l)))])))
+      (send (viewport-frame viewport) show #f)
+      (send (viewport-canvas viewport) show #f)
+      (when (null? global-viewport-list)
+	(send open-frames-timer stop))))
+  
+  (define open-graphics 
+    (lambda () 
+      (set! graphics-flag #t)))
+  
+  (define close-graphics 
+    (lambda ()
+      (map close-viewport global-viewport-list)
+      (set! graphics-flag #f)
+      (set! global-viewport-list '())
+      (send open-frames-timer stop)))
+  
+  (define graphics-open? (lambda () graphics-flag))
+  
+  (define make-rgb
+    (lambda (red green blue)
+      (when (or (< red 0.) (< blue 0.) (< green 0.)
+		(> red 1.) (> blue 1.) (> green 1.))
+	(error 'make-rgb
+	       "all color indices should be in [0.0, 1.0]; provided ~s"
+	       (list red green blue)))
+      (let* ([convert (lambda (num) (inexact->exact (round (* 255 num))))]
+	     [nred (convert red)]
+	     [ngreen (convert green)]
+	     [nblue (convert blue)])
+	(make-object mred:color% nred ngreen nblue))))
+  
+  (define make-color make-rgb)
+  
+  (define (rgb-red rgb) (/ (send rgb red) 255))
+  (define (rgb-blue rgb) (/ (send rgb blue) 255))
+  (define (rgb-green rgb) (/ (send rgb green) 255))
+  
+  (define rgb? (lambda (object) (is-a? object mred:color%)))
+  (define (color? x)
+    (or (rgb? x)
+	(not (not (send mred:the-color-database find-color x)))))
+  
+  (define change-color
+    (lambda (index color)
+      (vector-set! global-color-vector index color)
+      (vector-set! global-pen-vector index (get-pen color))
+      (vector-set! global-brush-vector index (get-brush color))))
+  
+  (define (get-color index)
+    (cond
+      [(is-a? index mred:color%) index]
+      [(string? index) (make-object mred:color% index)]
+      [else (vector-ref global-color-vector index)]))
+  
+  (define get-pen
+    (lambda (index)
+      (cond
+	[(is-a? index mred:pen%) index]
+	[(or (string? index) (is-a? index mred:color%))
+	 (send mred:the-pen-list find-or-create-pen index 1 'solid)]
+	[else (vector-ref global-pen-vector index)])))
+  
+  (define get-brush
+    (lambda (index)
+      (cond
+	[(is-a? index mred:brush%) index]
+	[(or (string? index) (is-a? index mred:color%))
+	 (send mred:the-brush-list find-or-create-brush index 'solid)]
+	[else (vector-ref global-brush-vector index)])))
+  
+  (define pen? (lambda (object) (is-a? object mred:pen%)))
+  (define brush? (lambda (object) (is-a? object mred:brush%)))
+  
+  (define display-color-vector
+    (lambda ()
+      (do
+	  ([index 0 (+ index 1)])
+	((eq? index 100))
+	(display (list (/ (rgb-red (get-color index)) 255)
+                       (/ (rgb-green (get-color index)) 255)
+                       (/ (rgb-blue (get-color index)) 255))))))
+  
+  (define make-font
+    (lambda (name)
+      (cond
+	[(eq? name 'large-deco)
+	 (make-object mred:font% 40 'decorative 'normal 'normal)]
+	[(eq? name 'small-roman)
+	 (make-object mred:font% 12 'roman 'normal 'normal)]
+	[(eq? name 'medium-roman)
+	 (make-object mred:font% 24 'roman 'normal 'normal)]
+	[(eq? name 'large-roman)
+	 (make-object mred:font% 32 'roman 'normal 'normal)]
+	[else "no such font ~a; only 'large-deco, 'small-roman, 'medium-roman, and 'large-roman"
+	      name])))
+  
+  (define custom-roman
+    (lambda (size)
+      (make-object mred:font%
+		   size 'roman 'normal 'normal)))
+  
+  (define custom-deco
+    (lambda (size)
+      (make-object mred:font% size 'decorative 'normal 'normal)))
+  
+  (define set-viewport-pen
+    (lambda (viewport pen)
+      (send (viewport-canvas viewport) remember-pen pen)
+      (let ([pen (get-pen pen)])
+	(send (viewport-dc viewport) set-pen pen)
+	(send (viewport-buffer-dc viewport) set-pen pen))))
+  
+  (define set-viewport-brush
+    (lambda (viewport brush)
+      (send (viewport-canvas viewport) remember-brush brush)
+      (let ([brush (get-brush brush)])
+	(send (viewport-dc viewport) set-brush brush)
+	(send (viewport-buffer-dc viewport) set-brush brush))))
+  
+  (define set-text-foreground
+    (lambda (viewport color)
+      (let ([color (get-color color)])
+	(send (viewport-dc viewport) set-text-foreground color)
+	(send (viewport-buffer-dc viewport) set-text-foreground color))))
+  
+  (define set-text-background
+    (lambda (viewport color)
+      (let ([color (get-color color)])
+	(send (viewport-dc viewport) set-text-background color)
+	(send (viewport-buffer-dc viewport) set-text-background color))))
+  
+  (define set-viewport-font
+    (lambda (viewport font)
+      (send (viewport-dc viewport) set-font font)
+      (send (viewport-buffer-dc viewport) set-font font)))
+  
+  (define set-viewport-background
+    (lambda (viewport color)
+      (send (viewport-dc viewport) set-background color)
+      (send (viewport-buffer-dc viewport) set-background color)))
+  
+  (define set-viewport-logical-function
+    (lambda (viewport logical-function)
+      (send (viewport-dc viewport) set-logical-function logical-function)
+      (send (viewport-buffer-dc viewport) set-logical-function
+	    logical-function)))
+
+  (define white (make-rgb 1 1 1))
+  (define black (make-rgb 0 0 0))
+  (define red (make-rgb 1 0 0))
+  (define green (make-rgb 0 1 0))
+  (define blue (make-rgb 0 0 1))
+  (define white-pen (get-pen white))
+  (define black-pen (get-pen black))
+  (define red-pen (get-pen red))
+  (define blue-pen (get-pen blue))
+  (define green-pen (get-pen green))
+  (define white-brush (get-brush white))
+  (define black-brush (get-brush black))
+  (define red-brush (get-brush red))
+  (define green-brush (get-brush green))
+  (define blue-brush (get-brush blue))
+  
+  (define invisi-pen (send mred:the-pen-list find-or-create-pen "WHITE" 0 'transparent))
+  (define invisi-brush (send mred:the-brush-list find-or-create-brush "WHITE" 'transparent))
+  
+  (define xor-pen (send mred:the-pen-list find-or-create-pen "BLACK" 1 'xor))
+  (define xor-brush (send mred:the-brush-list find-or-create-brush "BLACK" 'xor))
+  
+  (define draw-it (lambda (draw flip clear) (draw)))
+  (define flip-it (lambda (draw flip clear) (flip)))
+  (define clear-it (lambda (draw flip clear) (clear)))
+  
+  (define make-draw-proc
+    (lambda (get-pen-name set-pen-name 
+	     get-current-pen-name set-viewport-pen white-pen)
+      (lambda (viewport) 
+	(let* ([vdc (viewport-dc viewport)]
+	       [vbdc (viewport-buffer-dc viewport)])
+	  (lambda (color go)
+	    (let ([orig (and color
+			     (begin0
+			      (send/proc2 (viewport-canvas viewport) 
+					  get-current-pen-name)
+			      (set-viewport-pen viewport (get-color color))))])
+	      (go (lambda (draw)
+		    (let ([pen (send vdc get-pen)]
+			  [brush (send vdc get-brush)])
+		      (send vdc set-brush xor-brush)
+		      (send vbdc set-brush xor-brush)
+		      (send vdc set-pen xor-pen)
+		      (send vbdc set-pen xor-pen)
+		      (draw)
+		      (send vdc set-brush brush)
+		      (send vbdc set-brush brush)
+		      (send vdc set-pen pen)
+		      (send vbdc set-pen pen)))
+		  (lambda (draw)
+		    (let ([pen (send/proc vdc get-pen-name)])
+		      (send/proc vdc set-pen-name white-pen)
+		      (send/proc vbdc set-pen-name white-pen)
+		      (draw)
+		      (send/proc vdc set-pen-name pen)
+		      (send/proc vbdc set-pen-name pen))))
+	      (when orig
+	        (set-viewport-pen viewport orig))))))))
+  
+  (define make-do-line
+    (lambda (go)
+      (let ([f (make-draw-proc 'get-pen 'set-pen 
+			       'get-current-pen set-viewport-pen white-pen)])
+	(lambda (viewport)
+	  (let ([f (f viewport)])
+	    (letrec ([the-function
+		      (case-lambda
+		       [(posn1 posn2) (the-function posn1 posn2 #f)]
+		       [(posn1 posn2 color)
+			(f color
+			   (lambda (flip clear)
+			     (let* ([x1 (posn-x posn1)]
+				    [y1 (posn-y posn1)]
+				    [x2 (posn-x posn2)]
+				    [y2 (posn-y posn2)]
+				    [draw (lambda ()
+					    (send (viewport-dc viewport) 
+						  draw-line 
+						  x1 y1 x2 y2)
+					    (send (viewport-buffer-dc viewport)
+						  draw-line
+						  x1 y1 x2 y2))])
+			       (go draw
+				   (lambda () (flip draw))
+				   (lambda () (clear draw))))))])])
+	      the-function))))))
+  
+  (define draw-line (make-do-line draw-it))
+  (define (clear-line viewport)
+    (let ([f ((make-do-line clear-it) viewport)])
+      (rec clear-line-viewport
+	   (lambda (p1 p2)
+	     (f p1 p2)))))
+  (define (flip-line viewport)
+    (let ([f ((make-do-line flip-it) viewport)])
+      (rec flip-line-viewport
+	   (lambda (p1 p2)
+	     (f p1 p2)))))
+  
+  (define (draw/clear/flip ivar)
+    (lambda (init-dc viewport p width height)
+      (let ([dc (viewport-dc viewport)]
+	    [buffer-dc (viewport-buffer-dc viewport)])
+	(init-dc dc)
+	(init-dc buffer-dc)
+	(send/proc dc ivar (posn-x p) (posn-y p) width height)
+	(send/proc buffer-dc ivar (posn-x p) (posn-y p) width height))))
+  
+  (define draw/clear/flip-rectangle (draw/clear/flip 'draw-rectangle))
+  (define draw/clear/flip-ellipse (draw/clear/flip 'draw-ellipse))
+  
+  (define (draw-rectangle viewport)
+    (check-viewport 'draw-rectangle viewport)
+    (rec draw-rectangle-viewport
+	 (case-lambda 
+	  [(p width height) (draw-rectangle-viewport p width height (make-rgb 0 0 0))]
+	  [(p width height color)
+	   (check 'draw-rectangle
+		  posn? p "posn"
+		  number? width "number"
+		  number? height "number"
+		  (orp color? number?) color "color or index")
+	   (draw/clear/flip-rectangle
+	    (lambda (dc)
+	      (send dc set-pen (send mred:the-pen-list find-or-create-pen (get-color color) 1 'solid))
+	      (send dc set-brush (send mred:the-brush-list find-or-create-brush "BLACK" 'transparent)))
+	    viewport p width height)])))
+    
+  (define (draw-solid-rectangle viewport)
+    (check-viewport 'draw-solid-rectangle viewport)
+    (rec draw-solid-rectangle-viewport
+	 (case-lambda 
+	  [(p width height) (draw-solid-rectangle-viewport p width height (make-rgb 0 0 0))]
+	  [(p width height color)
+	   (check 'draw-solid-rectangle
+		  posn? p "posn"
+		  number? width "number"
+		  number? height "number"
+		  (orp color? number?) color "color or index")
+	   (draw/clear/flip-rectangle
+	    (lambda (dc)
+	      (send dc set-pen (send mred:the-pen-list find-or-create-pen (get-color color) 1 'solid))
+	      (send dc set-brush (send mred:the-brush-list find-or-create-brush (get-color color) 'solid)))
+	    viewport p width height)])))
+  
+  (define (flip-rectangle viewport)
+    (check-viewport 'flip-rectangle viewport)
+    (rec flip-rectangle-viewport
+	 (case-lambda 
+	  [(p width height) (flip-rectangle-viewport p width height (make-rgb 0 0 0))]
+	  [(p width height color)
+	   (check 'flip-rectangle
+		  posn? p "posn"
+		  number? width "number"
+		  number? height "number"
+		  (orp color? number?) color "color or index")
+	   (draw/clear/flip-rectangle
+	    (lambda (dc)
+	      (send dc set-pen (send mred:the-pen-list find-or-create-pen (get-color color) 1 'xor))
+	      (send dc set-brush (send mred:the-brush-list find-or-create-brush "BLACK" 'transparent)))
+	    viewport p width height)])))
+  
+  (define (flip-solid-rectangle viewport)
+    (check-viewport 'flip-solid-rectangle viewport)
+    (rec flip-solid-rectangle-viewport
+	 (case-lambda 
+	  [(p width height) (flip-solid-rectangle-viewport p width height (make-rgb 0 0 0))]
+	  [(p width height color)
+	   (check 'flip-solid-rectangle
+		  posn? p "posn"
+		  number? width "number"
+		  number? height "number"
+		  (orp color? number?) color "color or index")
+	   (draw/clear/flip-rectangle
+	    (lambda (dc)
+	      (send dc set-pen (send mred:the-pen-list find-or-create-pen "BLACK" 1 'transparent))
+	      (send dc set-brush (send mred:the-brush-list find-or-create-brush (get-color color) 'xor)))
+	    viewport p width height)])))
+
+  (define (draw-ellipse viewport)
+    (check-viewport 'draw-ellipse viewport)
+    (rec draw-ellipse-viewport
+	 (case-lambda 
+	  [(p width height) (draw-ellipse-viewport p width height (make-rgb 0 0 0))]
+	  [(p width height color)
+	   (check 'draw-ellipse
+		  posn? p "posn"
+		  number? width "number"
+		  number? height "number"
+		  (orp color? number?) color "color or index")
+	   (draw/clear/flip-ellipse
+	    (lambda (dc)
+	      (send dc set-pen (send mred:the-pen-list find-or-create-pen (get-color color) 1 'solid))
+	      (send dc set-brush (send mred:the-brush-list find-or-create-brush "BLACK" 'transparent)))
+	    viewport p width height)])))
+  
+  (define (draw-solid-ellipse viewport)
+    (check-viewport 'draw-solid-ellipse viewport)
+    (rec draw-solid-ellipse-viewport
+	 (case-lambda 
+	  [(p width height) (draw-solid-ellipse-viewport p width height (make-rgb 0 0 0))]
+	  [(p width height color)
+	   (check 'draw-solid-ellipse
+		  posn? p "posn"
+		  number? width "number"
+		  number? height "number"
+		  (orp color? number?) color "color or index")
+	   (draw/clear/flip-ellipse
+	    (lambda (dc)
+	      (send dc set-pen (send mred:the-pen-list find-or-create-pen (get-color color) 1 'solid))
+	      (send dc set-brush (send mred:the-brush-list find-or-create-brush (get-color color) 'solid)))
+	    viewport p width height)])))
+  
+  (define (flip-ellipse viewport)
+    (check-viewport 'flip-ellipse viewport)
+    (rec flip-ellipse-viewport
+	 (case-lambda 
+	  [(p width height) (flip-ellipse-viewport p width height (make-rgb 0 0 0))]
+	  [(p width height color)
+	   (check 'flip-ellipse
+		  posn? p "posn"
+		  number? width "number"
+		  number? height "number"
+		  (orp color? number?) color "color or index")
+	   (draw/clear/flip-ellipse
+	    (lambda (dc)
+	      (send dc set-pen (send mred:the-pen-list find-or-create-pen (get-color color) 1 'xor))
+	      (send dc set-brush (send mred:the-brush-list find-or-create-brush "BLACK" 'transparent)))
+	    viewport p width height)])))
+  
+  (define (flip-solid-ellipse viewport)
+    (check-viewport 'flip-solid-rectangle viewport)
+    (rec flip-solid-ellipse-viewport
+	 (case-lambda 
+	  [(p width height) (flip-solid-ellipse-viewport p width height (make-rgb 0 0 0))]
+	  [(p width height color)
+	   (check 'flip-solid-ellipse
+		  posn? p "posn"
+		  number? width "number"
+		  number? height "number"
+		  (orp color? number?) color "color or index")
+	   (draw/clear/flip-ellipse
+	    (lambda (dc)
+	      (send dc set-pen (send mred:the-pen-list find-or-create-pen "BLACK" 1 'transparent))
+	      (send dc set-brush (send mred:the-brush-list find-or-create-brush (get-color color) 'xor)))
+	    viewport p width height)])))
+  
+  (define (clear-rectangle viewport)
+    (check-viewport 'clear-rectangle viewport)
+    (rec clear-rectangle-viewport
+	 (lambda (p width height)
+	   (check 'clear-rectangle
+		  posn? p "posn"
+		  number? width "number"
+		  number? height "number")
+	   (draw/clear/flip-rectangle
+	    (lambda (dc)
+	      (send dc set-pen (send mred:the-pen-list find-or-create-pen "WHITE" 1 'solid))
+	      (send dc set-brush (send mred:the-brush-list find-or-create-brush "BLACK" 'transparent)))
+	    viewport p width height))))
+  
+  (define (clear-solid-rectangle viewport)
+    (check-viewport 'clear-solid-rectangle viewport)
+    (rec clear-solid-rectangle-viewport
+	 (lambda (p width height)
+	   (check 'clear-solid-rectangle
+		  posn? p "posn"
+		  number? width "number"
+		  number? height "number")
+	   (draw/clear/flip-rectangle
+	    (lambda (dc)
+	      (send dc set-pen (send mred:the-pen-list find-or-create-pen "WHITE" 1 'solid))
+	      (send dc set-brush (send mred:the-brush-list find-or-create-brush "WHITE" 'solid)))
+	    viewport p width height))))
+  
+  (define (clear-ellipse viewport)
+    (check-viewport 'clear-ellipse viewport)
+    (rec clear-ellipse-viewport
+	 (lambda (p width height)
+	   (check 'clear-ellipse
+		  posn? p "posn"
+		  number? width "number"
+		  number? height "number")
+	   (draw/clear/flip-ellipse
+	    (lambda (dc)
+	      (send dc set-pen (send mred:the-pen-list find-or-create-pen "WHITE" 1 'solid))
+	      (send dc set-brush (send mred:the-brush-list find-or-create-brush "BLACK" 'transparent)))
+	    viewport p width height))))
+  
+  (define (clear-solid-ellipse viewport)
+    (check-viewport 'clear-solid-ellipse viewport)
+    (rec clear-solid-ellipse-viewport
+	 (lambda (p width height)
+	   (check 'clear-solid-ellipse
+		  posn? p "posn"
+		  number? width "number"
+		  number? height "number")
+	   (draw/clear/flip-ellipse
+	    (lambda (dc)
+	      (send dc set-pen (send mred:the-pen-list find-or-create-pen "WHITE" 1 'solid))
+	      (send dc set-brush (send mred:the-brush-list find-or-create-brush "WHITE" 'solid)))
+	    viewport p width height))))
+
+  (define make-do-pointlist
+    (lambda (go name get-pen-name set-pen-name
+		get-current-pen-name set-viewport-pen white-pen
+		get-brush-name set-brush-name invisi-brush)
+      (let ([f (make-draw-proc get-pen-name set-pen-name 
+			       get-current-pen-name set-viewport-pen white-pen)])
+	(lambda (viewport)
+	  (let ([f (f viewport)]
+		[vdc (viewport-dc viewport)]
+		[vbdc (viewport-buffer-dc viewport)])
+	    (letrec ([the-function
+		      (case-lambda
+		       [(posns offset) (the-function posns offset #f)]
+		       [(posns offset color)
+			(f color
+			   (lambda (flip clear)
+			     (let* ([points (map (lambda (p)
+						   (make-object mred:point% (posn-x p) (posn-y p)))
+						 posns)]
+				    [x (posn-x offset)]
+				    [y (posn-y offset)]
+				    [orig (send/proc vdc get-brush-name)]
+				    [draw (lambda ()
+					    (send/proc vdc set-brush-name
+						       invisi-brush)
+					    (send/proc vbdc set-brush-name
+						       invisi-brush)
+					    (send/proc 
+					     (viewport-dc viewport) name
+					     points x y)
+					    (send/proc 
+					     (viewport-buffer-dc viewport) name
+					     points x y)
+					    (send/proc vdc set-brush-name orig)
+					    (send/proc vbdc set-brush-name
+						       orig))])
+			       (go draw
+				   (lambda () (flip draw))
+				   (lambda () (clear draw))))))])])
+	      the-function))))))
+  
+  (define make-do-polygon
+    (lambda (go)
+      (make-do-pointlist go 'draw-polygon 'get-pen 'set-pen 
+			 'get-current-pen set-viewport-pen white-pen
+			 'get-brush 'set-brush invisi-brush)))
+  
+  (define make-do-solid-polygon
+    (lambda (go)
+      (make-do-pointlist go 'draw-polygon 'get-brush 'set-brush  
+			 'get-current-brush set-viewport-brush white-brush
+			 'get-pen 'set-pen invisi-pen)))
+  
+  (define draw-polygon (make-do-polygon draw-it))
+  (define (clear-polygon viewport)
+    (let ([f ((make-do-polygon clear-it) viewport)])
+      (rec clear-polygon-viewport
+	   (lambda (posns offset)
+	     (f posns offset)))))
+  (define (flip-polygon viewport)
+    (let ([f ((make-do-polygon flip-it) viewport)])
+      (rec flip-polygon-viewport
+	   (lambda (posns offset)
+	     (f posns offset)))))
+  
+  (define draw-solid-polygon (make-do-solid-polygon draw-it))
+  (define (clear-solid-polygon viewport)
+    (let ([f ((make-do-solid-polygon clear-it) viewport)])
+      (rec clear-solid-polygon-viewport
+	   (lambda (posns offset)
+	     (f posns offset)))))
+  (define (flip-solid-polygon viewport)
+    (let ([f ((make-do-solid-polygon flip-it) viewport)])
+      (rec flip-solid-polygon-viewport
+	   (lambda (posns offset)
+	     (f posns offset)))))
+  
+  (define make-do-pixel
+    (lambda (go)
+      (let ([f (make-draw-proc 'get-pen 'set-pen  
+			       'get-current-pen set-viewport-pen white-pen)])
+	(lambda (viewport)
+	  (let ([f (f viewport)])
+	    (letrec ([the-function
+		      (case-lambda
+		       [(posn) (the-function posn #f)]
+		       [(posn color)
+			(f color
+			   (lambda (flip clear)
+			     (let* ([x (posn-x posn)]
+				    [y (posn-y posn)]
+				    [draw (lambda ()
+					    (send 
+					     (viewport-dc viewport) draw-point
+					     x y)
+					    (send 
+					     (viewport-buffer-dc viewport)
+					     draw-point 
+					     x y))])
+			       (go draw 
+				   (lambda () (flip draw)) 
+				   (lambda () (clear draw))))))])])
+	      the-function))))))
+
+  (define-do-pixel draw-pixel draw-it draw-pixel-viewport make-do-pixel)
+  (define-do-pixel clear-pixel clear-it clear-pixel-viewport make-do-pixel)
+  (define-do-pixel flip-pixel flip-it flip-pixel-viewport make-do-pixel)
+  
+  (define string-functions
+    (lambda (string-op)
+      (letrec ([outer-function
+		(case-lambda
+		 [(viewport) (outer-function viewport default-font)]
+		 [(viewport font)
+		  (letrec ([the-function
+			    (case-lambda
+			     [(posn text) (the-function posn text #f)]
+			     [(posn text color)
+			      (let*-values ([(dc) (viewport-dc viewport)]
+					    [(x) (posn-x posn)]
+					    [(w h d a) (send dc get-text-extent "X" font)]
+					    [(y) (- (posn-y posn) (- h d))]
+					    [(buffer) (viewport-buffer-dc viewport)]
+					    [(string-create)
+					     (lambda ()
+					       (send dc draw-text text x y)
+					       (send buffer draw-text text x y))])
+				(cond
+				  [(eq? string-op 'draw)
+				   (when color
+				     (set-text-foreground viewport color))
+				   (set-viewport-font viewport font)
+				   (send dc draw-text text x y)
+				   (send buffer draw-text text x y)]
+				  [(eq? string-op 'flip)
+				   (when color
+				     (set-text-foreground viewport color))
+				   (set-viewport-font viewport font)
+				   (string-create)]
+				  [(eq? string-op 'clear)
+				   (set-text-foreground viewport white)
+				   (set-viewport-font viewport font)
+				   (string-create)
+				   (set-text-foreground viewport black)]))])])
+		    the-function)])])
+	outer-function)))
+
+  (define-string draw-string draw draw-string-viewport string-functions)
+  (define-string clear-string clear clear-string-viewport string-functions)
+  (define-string flip-string flip flip-string-viewport string-functions)
+  
+  (define get-string-size
+    (case-lambda
+     [(viewport) (get-string-size viewport default-font)]
+     [(viewport font)
+      (lambda (text)
+	(let-values ([(w h d a) (send (viewport-dc viewport) get-text-extent text font)])
+	  (list w h)))]))
+  
+  (define get-color-pixel 
+    (lambda (viewport)
+      (lambda (posn)
+	(let ([c (make-object mred:color%)]
+	      [x (posn-x posn)]
+	      [y (posn-y posn)])
+	  (unless (send (viewport-buffer-dc viewport) get-pixel x y c)
+	    (error 'get-color-pixel "specified point is out-of-range"))
+	  c))))
+  
+  (define get-pixel 
+    (lambda (viewport)
+      (lambda (posn)
+	(let ([c (make-object mred:color%)]
+	      [x (posn-x posn)]
+	      [y (posn-y posn)])
+	  (unless (send (viewport-buffer-dc viewport) get-pixel x y c)
+	    (error 'get-pixel "specified point is out-of-range"))
+	  (if (or (< (send c blue) 255)
+		  (< (send c red) 255)
+		  (< (send c green) 255))
+	      1
+	      0)))))
+  
+  (define (test-pixel viewport)
+    (lambda (color)
+      (let ([c (make-object mred:color%)])
+	(send (viewport-buffer-dc viewport) try-color color c)
+	c)))
+
+  (define draw-pixmap-posn
+    (opt-lambda (filename [type 'unknown/mask])
+      (check 'draw-pixmap-posn
+	     (andp path-string? file-exists?) filename "filename"
+	     (lambda (x) (memq x '(gif xbm xpm bmp pict unknown unknown/mask gif/mask))) type "file type symbol")
+      (let* ([bitmap (make-object mred:bitmap% filename type)])
+	(lambda (viewport)
+	  (check 'draw-pixmap-posn
+		 viewport? viewport "viewport")
+	  (opt-lambda (posn [color #f])
+	    (check 'draw-pixmap-posn
+		   posn? posn "posn"
+		   (orp not color?) color (format "color or ~e" #f))
+	    (when color
+	      (set-viewport-pen viewport (get-color color)))
+	    (let ([x (posn-x posn)]
+		  [y (posn-y posn)])
+	      (send (viewport-dc viewport) draw-bitmap bitmap x y 'solid black-color (send bitmap get-loaded-mask))
+	      (send (viewport-buffer-dc viewport) draw-bitmap bitmap x y 'solid black-color (send bitmap get-loaded-mask))))))))
+  
+  (define draw-pixmap
+    (lambda (viewport)
+      (check 'draw-pixmap
+	     viewport? viewport "viewport")
+      (opt-lambda (filename p [color #f])
+	(check 'draw-pixmap
+	       (andp path-string? file-exists?) filename "filename"
+	       posn? p "posn"
+	       (orp not color?) color (format "color or ~e" #f))
+	(((draw-pixmap-posn filename 'unknown) viewport) p color))))
+  
+  (define copy-viewport 
+    (lambda (source target)
+      (check 'copy-viewport
+	     viewport? source "viewport"
+	     viewport? target "viewport")
+      (let* ([source-bitmap (viewport-bitmap source)]
+	     [target-dc (viewport-dc target)]
+	     [target-buffer-dc (viewport-buffer-dc target)])
+	(send target-dc draw-bitmap source-bitmap 0 0)
+	(send target-buffer-dc draw-bitmap source-bitmap 0 0))))
+
+  (define save-pixmap
+    (lambda (viewport)
+      (check 'save-pixmap
+	     viewport? viewport "viewport")
+      (opt-lambda (filename [kind 'xpm])
+	(check 'save-pixmap
+	       (andp path-string? (orp relative-path? absolute-path?)) filename "filename"
+	       (lambda (x) (memq x '(xpm xbm bmp pict))) kind "file type symbol")
+	(let ([bm (viewport-bitmap viewport)])
+	  (send bm save-file filename kind)))))
+
+  (define sixlib-eventspace #f)
+  
+  (define make-open-viewport
+    (lambda (name show?)
+      (unless sixlib-eventspace
+	(set! sixlib-eventspace 
+	      (parameterize ([current-exception-handler
+			      (lambda (x)
+				((error-display-handler)
+				 (format "internal error in graphics library: ~a"
+					 (if (exn? x)
+					     (exn-message x)
+					     (format "~e" x))))
+				((error-escape-handler)))])
+		(mred:make-eventspace))))
+      (letrec ([open-viewport
+		(case-lambda
+		 [(label point) 
+		  (cond
+		    [(posn? point) (open-viewport label (posn-x point) (posn-y point))]
+		    [(and (list? point) (= (length point) 2))
+		     (open-viewport label (car point) (cadr point))]
+		    [else (error name "bad argument ~s" point)])]
+		 [(label width height)
+		  (cond
+		    [graphics-flag
+		     (let*
+			 ([frame
+			   (parameterize ([mred:current-eventspace sixlib-eventspace])
+			     (make-object sixlib-frame%
+                               label #f width height))]
+			  [panel (make-object mred:vertical-panel% frame)]
+			  [canvas (make-object sixlib-canvas% panel)]
+			  [_ (begin
+			       (send canvas min-height height)
+			       (send canvas min-width width))]
+			  [dc (send canvas get-dc)]
+			  [buffer-dc (make-object mred:bitmap-dc%)]
+			  [viewport (make-viewport label canvas)])
+		       (send panel set-alignment 'center 'center)
+		       (send frame set-canvas canvas)
+		       (send canvas set-viewport viewport)
+		       (send canvas set-dc dc)
+		       (send canvas set-buffer-dc buffer-dc)
+		       (send canvas set-geometry width height)
+		       (when show? 
+			 (send frame show #t)
+			 (send canvas focus))
+		       (set-text-foreground viewport black)
+		       (set-text-background viewport white)
+		       (set-viewport-background viewport white)
+		       (set-viewport-pen viewport black-pen)
+		       (set-viewport-brush viewport black-brush)
+		       ((clear-viewport viewport))
+		       (when (null? global-viewport-list)
+			 (send open-frames-timer start 100000000))
+		       (set! global-viewport-list (cons viewport global-viewport-list))
+		       viewport)]
+		    [else (error "graphics not open")])])])
+	open-viewport)))
+  
+  (define open-viewport (make-open-viewport 'open-viewport #t))
+  (define open-pixmap (make-open-viewport 'open-pixmap #f))
+  
+  (define (default-display-is-color?) (mred:is-color-display?))
+  
+  (define position-display
+    (lambda (viewport counter)
+      (cond
+	[(equal? counter 0) '()]
+	[else (begin 
+		(display (query-mouse-posn viewport))
+		(position-display viewport (- counter 1)))])))
+  
+  
+  (define create-cmap
+    (lambda ()
+      (do ([index 0 (+ 1 index)])
+	((> index 20))
+	(let* ([r (* 0.05 index)]
+	       [b (- 1 r)]
+	       [g (- 1 r)])
+	  (change-color index (make-rgb r g b))))))
+  
+  (define viewport->snip
+    (lambda (viewport)
+      (let ([orig-bitmap (send (viewport-canvas viewport) get-bitmap)]
+	    [orig-dc (viewport-buffer-dc viewport)])
+	(let* ([h (send orig-bitmap get-height)]
+	       [w (send orig-bitmap get-width)]
+	       [new-bitmap (make-object mred:bitmap% w h)]
+	       [tmp-mem-dc (make-object mred:bitmap-dc%)])
+	  (send tmp-mem-dc set-bitmap new-bitmap)
+	  (send tmp-mem-dc draw-bitmap (send orig-dc get-bitmap) 0 0)
+	  (send tmp-mem-dc set-bitmap #f)
+	  (let ([snip (make-object mred:image-snip%)])
+	    (send snip set-bitmap new-bitmap)
+	    snip)))))
+  
+  (create-cmap)
+
+
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;;                                                             ;;;
+  ;;;                        ERROR CHECKING                       ;;;
+  ;;;                                                             ;;;
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+  ;; check-viewport : symbol TST -> void
+  (define (check-viewport f-name obj)
+    (unless (viewport? obj)
+      (error f-name "expected viewport as first argument, got ~e" obj)))
+
+  ;; (define-type arg/pred/name-list (list* (TST -> bool) TST string arg/pred/name-list))
+  ;; check : (symbol arg/pred/name-list *-> void)
+  (define (check f-name . in-args)
+    (let loop ([args in-args]
+	       [n 0])
+      (cond
+       [(null? args) (void)]
+       [else (let ([pred? (car args)]
+		   [val (cadr args)]
+		   [name (caddr args)])
+	       (unless (pred? val)
+		 (error f-name "expected ~a as arg ~a, got: ~e, all args: ~a"
+			name n val
+			(let loop ([args in-args])
+			  (cond
+			   [(null? args) ""]
+			   [else (string-append (format "~e" (cadr args))
+						" "
+						(loop (cdddr args)))]))))
+	       (loop (cdddr args)
+		     (+ n 1)))])))
+
+  (define (orp . preds)
+    (lambda (TST)
+      (ormap (lambda (p) (p TST)) preds)))
+
+  (define (andp . preds)
+    (lambda (TST)
+      (andmap (lambda (p) (p TST)) preds)))
+  )
+))
diff --git a/collects/graphics/graphics-sig.ss b/collects/graphics/graphics-sig.ss
new file mode 100644
index 0000000000..806b9dfc7c
--- /dev/null
+++ b/collects/graphics/graphics-sig.ss
@@ -0,0 +1,78 @@
+(module graphics-sig mzscheme
+  (require (lib "unitsig.ss"))
+
+  (provide graphics^ graphics:posn-less^ graphics:posn^)
+
+  (define-signature graphics:posn^
+    (make-posn posn? posn-x posn-y))
+
+  (define-signature graphics:posn-less^
+    (viewport?
+
+     open-graphics 
+     close-graphics 
+     graphics-open?
+     
+     get-mouse-click
+     ready-mouse-click
+     ready-mouse-release
+     mouse-click-posn
+     query-mouse-posn
+     viewport-flush-input
+     left-mouse-click?
+     middle-mouse-click?
+     right-mouse-click?
+     
+     set-on-key-event
+     set-on-tick-event
+     stop-tick
+     init-world
+     get-key-press
+     ready-key-press
+     key-value
+     
+     make-rgb
+     rgb-blue rgb-red rgb-green
+     change-color 
+     rgb?
+     
+     open-viewport 
+     open-pixmap
+     close-viewport    
+     
+     clear-viewport draw-viewport flip-viewport
+     
+     draw-line clear-line flip-line 
+     draw-pixel clear-pixel flip-pixel 
+     get-pixel get-color-pixel test-pixel
+     
+     draw-rectangle clear-rectangle flip-rectangle 
+     draw-ellipse clear-ellipse flip-ellipse 
+     draw-polygon clear-polygon flip-polygon 
+     draw-solid-rectangle clear-solid-rectangle flip-solid-rectangle 
+     draw-solid-ellipse clear-solid-ellipse flip-solid-ellipse 
+     draw-solid-polygon clear-solid-polygon flip-solid-polygon 
+     
+     get-string-size
+     
+     draw-string clear-string flip-string 
+     
+     draw-pixmap-posn
+     draw-pixmap
+     save-pixmap
+     
+     copy-viewport 
+     
+     default-display-is-color?
+     
+     viewport->snip
+     
+     viewport-dc viewport-buffer-dc))
+  
+  (define-signature graphics^
+    ((open graphics:posn-less^)
+     (open graphics:posn^)))
+)
+
+
+
diff --git a/collects/graphics/graphics-unit.ss b/collects/graphics/graphics-unit.ss
new file mode 100644
index 0000000000..6cc4f13a70
--- /dev/null
+++ b/collects/graphics/graphics-unit.ss
@@ -0,0 +1,16 @@
+(module graphics-unit mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "mred-sig.ss" "mred")
+	   "graphics-sig.ss"
+	   "graphics-posn-less-unit.ss")
+  (provide graphics@)
+
+  (define graphics@
+    (compound-unit/sig
+      (import [mred : mred^])
+      (link [p : graphics:posn^ 
+	       ((unit/sig graphics:posn^ (import) (define-struct posn (x y))))]
+	    [g : graphics:posn-less^ (graphics-posn-less@ mred p)])
+      (export
+       (open p)
+       (open g)))))
\ No newline at end of file
diff --git a/collects/graphics/graphics.ss b/collects/graphics/graphics.ss
new file mode 100644
index 0000000000..4fb4c885d5
--- /dev/null
+++ b/collects/graphics/graphics.ss
@@ -0,0 +1,9 @@
+(module graphics mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "mred-sig.ss" "mred")
+	   (lib "mred.ss" "mred")
+	   "graphics-sig.ss"
+	   "graphics-unit.ss")
+  (provide-signature-elements graphics^)
+
+  (define-values/invoke-unit/sig graphics^ graphics@ #f mred^))
\ No newline at end of file
diff --git a/collects/graphics/info.ss b/collects/graphics/info.ss
new file mode 100644
index 0000000000..bf8bbf6341
--- /dev/null
+++ b/collects/graphics/info.ss
@@ -0,0 +1,5 @@
+
+(module info (lib "infotab.ss" "setup")
+  (define name "Graphics")
+  (define compile-omit-files '("value-turex.ss" "value-turtle-lib.ss")))
+
diff --git a/collects/graphics/turtle-examples.ss b/collects/graphics/turtle-examples.ss
new file mode 100644
index 0000000000..430302da31
--- /dev/null
+++ b/collects/graphics/turtle-examples.ss
@@ -0,0 +1,310 @@
+(module turtle-examples mzscheme
+  (require (lib "math.ss")
+	   (lib "etc.ss")
+	   "turtles.ss")
+  (provide regular-poly regular-polys radial-turtles spaced-turtles
+	   spokes spyro-gyra neato graphics-bexam serp-size serp serp-nosplit
+	   koch-size koch-split koch-draw lorenz lorenz1 peano-size
+	   peano-position-turtle peano fern-size fern1 fern2 gapped-lines)
+  
+  (define (regular-poly sides radius)
+    (local [(define theta (/ (* 2 pi) sides))
+            (define side-len (* 2 radius (sin (/ theta 2))))
+            (define (draw-sides n)
+              (cond
+                [(zero? n) (void)]
+                [else
+                 (draw side-len)
+                 (turn/radians theta)
+                 (draw-sides (sub1 n))]))]
+      (tprompt (move radius)
+               (turn/radians (/ (+ pi theta) 2))
+               (draw-sides sides))))
+  
+  (define (regular-polys sides s)
+    (local [(define (make-polys n)
+              (cond
+                [(zero? n) (void)]
+                [else
+                 (regular-poly sides (* n 5))
+                 (make-polys (sub1 n))]))]
+      (make-polys sides)))
+  
+  (define (radial-turtles n)
+    (cond
+      [(zero? n) (void)]
+      [else
+       (split (turn/radians (/ pi (expt 2 (sub1 n)))))
+       (radial-turtles (sub1 n))]))
+  
+  (define (spaced-turtles n)
+    (cond
+      [(zero? n) (void)]
+      [else
+       (split (move (expt 2 (+ n 1))))
+       (spaced-turtles (sub1 n))]))
+  
+  (define (spokes)
+    (radial-turtles 4)
+    (spaced-turtles 5)
+    (turn/radians (/ pi 2))
+    (draw 10))
+  
+  (define (spyro-gyra)
+    (radial-turtles 4)
+    (regular-poly 3 100))
+  
+  (define (neato)
+    (local [(define (spiral d t)
+              (cond
+                [(<= 1 d)
+                 (draw d)
+                 (turn/radians t)
+                 (spiral (- d 1) t)]
+                [else (void)]))]
+      (radial-turtles 4)
+      (spiral 30 (/ pi 12))))
+  
+  (define (graphics-bexam)
+    (local [(define (gb d)
+              (cond
+                [(<= d 3)
+                 (draw d)]
+                [else
+                 (local [(define new-d (/ d 3))]
+                   (gb new-d)
+                   (turn/radians (- (/ pi 2)))
+                   (gb new-d)
+                   (turn/radians (/ pi 2))
+                   (gb new-d)
+                   (turn/radians (/ pi 2))
+                   (gb new-d)
+                   (turn/radians (- (/ pi 2)))
+                   (gb new-d))]))
+            (define square-size (expt 3 5))]
+      (split (turn/radians (/ pi 2))
+             (move square-size)
+             (turn/radians (- (/ pi 2)))
+             (move square-size)
+             (turn/radians pi))
+      (split (move square-size)
+             (turn/radians (/ pi 2)))
+      (gb square-size)))
+  
+  (define serp-size 120)
+  
+  (define (serp distance)
+    (local [(define sqrt3 (sqrt 3))
+            (define -2pi/3 (- 0 (/ (* 2 pi) 3)))
+            (define pi/6 (/ pi 6))
+            (define -5pi/6 (- 0 (/ (* 5 pi) 6)))
+            (define pi/2 (/ pi 2))
+            (define (engine distance)
+              (cond
+                [(< distance 1) (void)]
+                [else
+                 (local [(define side-half (* distance sqrt3))
+                         (define side (* 2 side-half))]
+                   (turn/radians -2pi/3)
+                   (move distance)
+                   (split (move distance)
+                          (turn/radians -5pi/6)
+                          (draw side)
+                          (turn/radians -5pi/6)
+                          (move distance)
+                          (turn/radians pi)
+                          (split (turn/radians -5pi/6)
+                                 (move side-half)
+                                 (turn/radians pi/6)))
+                   (engine (/ distance 2)))]))]
+      (move (* 2 distance))
+      (turn/radians (/ (* 5 pi) 6))
+      (draw (* distance 2 (sqrt 3)))
+      (turn/radians (/ (* 2 pi) 3))
+      (move (* distance 2 (sqrt 3)))
+      (turn/radians (/ (* 2 pi) 3))
+      (draw (* distance 2 (sqrt 3)))
+      (turn/radians (/ (* 2 pi) 3))
+      (turn/radians (/ pi 6))
+      (move (* 2 distance))
+      (turn/radians pi)
+      (engine distance)))
+  
+  (define (serp-nosplit distance)
+    (local [(define sqrt3 (sqrt 3))
+            (define -2pi/3 (- 0 (/ (* 2 pi) 3)))
+            (define pi/6 (/ pi 6))
+            (define -5pi/6 (- 0 (/ (* 5 pi) 6)))
+            (define pi/2 (/ pi 2))
+            (define (engine distance)
+              (cond
+                [(< distance 1) (void)]
+                [else
+                 (local [(define side-half (* distance sqrt3))
+                         (define side (* 2 side-half))]
+                   (turn/radians -2pi/3)
+                   (move distance)
+                   (engine (/ distance 2))
+                   (move distance)
+                   (turn/radians -5pi/6)
+                   (draw side)
+                   (turn/radians -5pi/6)
+                   (move distance)
+                   (turn/radians pi)
+                   (engine (/ distance 2))
+                   (turn/radians -5pi/6)
+                   (move side-half)
+                   (turn/radians pi/6)
+                   (engine (/ distance 2))
+                   (move (- distance)))]))]
+      (move (* 2 distance))
+      (turn/radians (/ (* 5 pi) 6))
+      (draw (* distance 2 (sqrt 3)))
+      (turn/radians (/ (* 2 pi) 3))
+      (move (* distance 2 (sqrt 3)))
+      (turn/radians (/ (* 2 pi) 3))
+      (draw (* distance 2 (sqrt 3)))
+      (turn/radians (/ (* 2 pi) 3))
+      (turn/radians (/ pi 6))
+      (move (* 2 distance))
+      (turn/radians pi)
+      (engine distance)))
+  
+  (define koch-size (expt 3 5))
+  
+  (define (koch-split koch-size)
+    (local [(define (build-up-turtles n)
+              (cond
+                [(<= n 3) 'built]
+                [else (local [(define third (/ n 3))]
+                        (split* 'stay-put
+                                (move (* 2 third))
+                                (begin (move third)
+                                       (turn/radians (- (/ pi 3))))
+                                (begin (move third)
+                                       (turn/radians (- (/ pi 3)))
+                                       (move third)
+                                       (turn/radians (* 2 (/ pi 3)))))
+                        (build-up-turtles third))]))]
+      (split* 'stay-put
+              (begin (move koch-size)
+                     (turn/radians (/ (* 2 pi) 3)))
+              (begin (turn/radians (/ pi 3))
+                     (move koch-size)
+                     (turn/radians pi)))
+      (build-up-turtles koch-size)
+      (draw 3)))
+  
+  (define (koch-draw koch-size)
+    (local [(define (side n)
+              (cond
+                [(<= n 3) (draw n)]
+                [else (local [(define third (/ n 3))]
+                        (side third)
+                        (turn/radians (- (/ pi 3)))
+                        (side third)
+                        (turn/radians (* 2 (/ pi 3)))
+                        (side third)
+                        (turn/radians (- (/ pi 3)))
+                        (side third))]))]
+      (split* 'stay-put
+              (begin (move koch-size)
+                     (turn/radians (/ (* 2 pi) 3)))
+              (begin (turn/radians (/ pi 3))
+                     (move koch-size)
+                     (turn/radians pi)))
+      (side koch-size)))
+  
+  (define (lorenz a b c)
+    (local [(define (loop x y z)
+              (local [(define delta 0.01)
+                      (define dx (* delta (* a (- y x))))
+                      (define dy (* delta (- (* x b) y (* x z))))
+                      (define dz (* delta (- (* x y) (* c z))))]
+                (draw-offset dx dz)
+                (sleep 0.05)
+                (erase-offset (- dx) (- dz))
+                (move-offset dx dz)
+                (loop (+ x dx)
+                      (+ y dy)
+                      (+ z dz))))]
+      (loop 1 1 1)))
+  
+  (define (lorenz1) (lorenz 50 60 11))
+  
+  (define peano-size (expt 3 6))
+  (define (peano-position-turtle)
+    (clear)
+    (move -270)
+    (turn/radians (/ pi 2))
+    (move 250)
+    (turn/radians (- (/ (* 3 pi) 4))))
+  
+  (define (peano l)
+    (cond
+      [(<= l 3)
+       (draw l)]
+      [else
+       (local [(define new-l (/ l 3))]
+         (peano new-l)
+         (tprompt (peano new-l)
+                  (split* (turn/radians (/ pi 2))
+                          (turn/radians (- (/ pi 2))))
+                  (peano new-l))
+         (tprompt (split* (turn/radians (/ pi 2))
+                          (turn/radians (- (/ pi 2))))
+                  (peano new-l))
+         (tprompt (split* (move new-l)
+                          (begin (turn/radians (/ pi 2))
+                                 (move new-l)
+                                 (turn/radians (- (/ pi 2))))
+                          (begin (turn/radians (- (/ pi 2)))
+                                 (move new-l)
+                                 (turn/radians (/ pi 2))))
+                  (peano l))
+         (move (* 2 new-l)))]))
+  
+  (define fern-size 30)
+  
+  (define (fern1 n)
+    (cond
+      [(< 1 n)
+       (draw (/ n 2))
+       (tprompt (split* (turn/radians (/ pi 3))
+                        (turn/radians (- (/ pi 3))))
+                (fern1 (/ n 2)))
+       (draw (/ n 2))
+       (turn/radians 0.08)
+       (fern1 (- n 1))]
+      [else (void)]))
+  
+  
+  ;; need to backup a little for this one.
+  (define (fern2 n)
+    (local [(define d 0.04)
+            (define (fernd n sign)
+              (cond
+                [(< 1 n)
+                 (draw (/ n 2))
+                 (tprompt (turn/radians (/ pi 3))
+                          (fernd (/ n 2) -))
+                 (tprompt (turn/radians (- (/ pi 3)))
+                          (fernd (/ n 2) +))
+                 (draw (/ n 2))
+                 (turn/radians (sign d))
+                 (fernd (- n 1) sign)]
+                [else (void)]))]
+      (fernd n +)))
+  
+  (define (gapped-lines)
+    (local [(define gaps 5)
+            (define lines 3)]
+      (tprompt
+       (turn/radians (/ pi 2))
+       (spaced-turtles lines)
+       (turn/radians (- (/ pi 2)))
+       (draw (* 4 (expt 2 gaps))))
+      (tprompt
+       (spaced-turtles gaps)
+       (turn/radians (/ pi 2))
+       (erase (* 4 (expt 2 lines)))))))
\ No newline at end of file
diff --git a/collects/graphics/turtle-sig.ss b/collects/graphics/turtle-sig.ss
new file mode 100644
index 0000000000..2eeda8ff34
--- /dev/null
+++ b/collects/graphics/turtle-sig.ss
@@ -0,0 +1,18 @@
+(module turtle-sig mzscheme
+  (require (lib "unitsig.ss"))
+  (provide turtle^)
+
+  (define-signature turtle^ 
+    (turtles
+     clear
+     turn turn/radians
+     move move-offset
+     draw draw-offset
+     erase erase-offset
+     
+     save-turtle-bitmap
+     
+     splitfn split*fn tpromptfn
+     turtle-window-size
+     
+     display-lines-in-drawing)))
diff --git a/collects/graphics/turtle-test.ss b/collects/graphics/turtle-test.ss
new file mode 100644
index 0000000000..fe508365b6
--- /dev/null
+++ b/collects/graphics/turtle-test.ss
@@ -0,0 +1,45 @@
+(module turtle-test mzscheme
+  (require (lib "mred.ss" "mred")
+           (lib "class.ss")
+           (lib "math.ss")
+           "turtle-examples.ss"
+           "turtles.ss")
+  
+  (define frame (make-object frame% "Turtle Examples"))
+  
+  (define options
+    `(("Triangle" ,(lambda () (regular-poly 3 100)))
+      ("Hexagons" ,(lambda () (regular-polys 6 10)))
+      ("Spokes" ,spokes)
+      ("Spyro Gyra" ,spyro-gyra)
+      ("Neato" ,neato)
+      ("Graphics BExam" ,(lambda () 
+                           (turn/radians (/ pi 4))
+                           (move -150)
+                           (turn/radians (- (/ pi 4)))
+                           (graphics-bexam)))
+      ("Serpinski (split)" ,(lambda () (serp serp-size)))
+      ("Serpinski (no split)" ,(lambda () (serp-nosplit serp-size)))
+      ("Koch (split)" ,(lambda () (koch-split koch-size)))
+      ("Koch (no split)" ,(lambda () (koch-draw koch-size)))
+      ("Lorenz Attractor" ,lorenz1)
+      ("Peano" ,(lambda () (peano-position-turtle) (peano peano-size)))
+      ("Fern" ,(lambda () (turn/radians (/ pi 2)) (move -100) (fern1 fern-size)))
+      ("Gapped Lines" ,(lambda () (gapped-lines)))))
+  
+  (for-each (lambda (test) 
+              (send
+               (make-object button% 
+                 (car test)
+                 frame
+                 (lambda x 
+                   (turtles #t)
+                   (clear)
+                   (yield)
+                   ((cadr test))))
+               stretchable-width #t))
+            options)
+  
+  (make-object grow-box-spacer-pane% frame)	  
+  
+  (send frame show #t))
\ No newline at end of file
diff --git a/collects/graphics/turtle-unit.ss b/collects/graphics/turtle-unit.ss
new file mode 100644
index 0000000000..f5f69fe984
--- /dev/null
+++ b/collects/graphics/turtle-unit.ss
@@ -0,0 +1,467 @@
+(module turtle-unit mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "mred-sig.ss" "mred")
+	   (lib "class.ss")
+	   (lib "class100.ss")
+	   (lib "list.ss")
+	   (lib "etc.ss")
+	   "turtle-sig.ss")
+  (provide turtle@)
+  
+  (define turtle@
+    (unit/sig turtle^
+      (import [mred : mred^])
+      
+      (define turtles:window #f)
+      (define turtles:shown? #f)
+      
+      (define pi 3.141592653589793)
+      (define pi/2 (/ pi 2))
+      
+      (define icon-pen (send mred:the-pen-list find-or-create-pen "SALMON" 1 'xor))
+      (define icon-brush (send mred:the-brush-list find-or-create-brush "SALMON" 'xor))
+      (define blank-pen (send mred:the-pen-list find-or-create-pen "BLACK" 1 'transparent))
+      (define w-pen (send mred:the-pen-list find-or-create-pen "white" 1 'solid))
+      (define b-pen (send mred:the-pen-list find-or-create-pen "black" 1 'solid))
+      
+      (define show-turtle-icons? #t)
+      
+      ;; turtle-style : (union 'triangle 'line 'empty)
+      (define turtle-style 'triangle)
+      
+      (define plot-window%
+        (class100 mred:frame% (name width height)
+          
+          (private-field
+           [bitmap (make-object mred:bitmap% width height #t)])      
+          
+          (inherit show)
+          (private-field
+           [memory-dc (make-object mred:bitmap-dc%)]
+           [pl (make-object mred:point% 0 0)]
+           [pr (make-object mred:point% 0 0)]
+           [ph (make-object mred:point% 0 0)]
+           [points (list pl pr ph)])
+          (public
+            [get-canvas
+             (lambda ()
+               canvas)]
+            [flip-icons
+             (lambda ()
+               (case turtle-style
+                 [(triangle line)
+                  (flatten (lambda (x) x))
+                  (let* ([dc (send canvas get-dc)]
+                         [proc
+                          (if (eq? turtle-style 'line)
+                              (lambda (turtle)
+                                (let ([x (turtle-x turtle)]
+                                      [y (turtle-y turtle)]
+                                      [theta (turtle-angle turtle)]
+                                      [size 2])
+                                  (send dc draw-line
+                                        x y
+                                        (+ x (* size (cos theta)))
+                                        (+ y (* size (sin theta))))))
+                              (lambda (turtle)
+                                (let* ([x (turtle-x turtle)]
+                                       [y (turtle-y turtle)]
+                                       [theta (turtle-angle turtle)]
+                                       [long-size 20]
+                                       [short-size 7]
+                                       [l-theta (+ theta pi/2)]
+                                       [r-theta (- theta pi/2)])
+                                  (send ph set-x (+ x (* long-size (cos theta))))
+                                  (send ph set-y (+ y (* long-size (sin theta))))
+                                  (send pl set-x (+ x (* short-size (cos l-theta))))
+                                  (send pl set-y (+ y (* short-size (sin l-theta))))
+                                  (send pr set-x (+ x (* short-size (cos r-theta))))
+                                  (send pr set-y (+ y (* short-size (sin r-theta))))
+                                  (send dc draw-polygon points))))])
+                    (if (eq? turtle-style 'line)
+                        (send dc set-pen icon-pen)
+                        (begin
+                          (send dc set-pen blank-pen)
+                          (send dc set-brush icon-brush)))
+                    (for-each proc turtles-state)
+                    (send dc set-pen b-pen))]
+                 [else
+                  (void)]))]
+            [clear
+             (lambda () 
+               (send memory-dc clear)
+               (send canvas on-paint))])
+          (sequence
+            (send memory-dc set-bitmap bitmap)
+            (send memory-dc clear)
+            (super-init name #f width height))
+          
+          (public
+            [on-menu-command (lambda (op) (turtles #f))])
+          (private-field
+           [menu-bar (make-object mred:menu-bar% this)]
+           [file-menu (make-object mred:menu% "File" menu-bar)])
+          (sequence 
+            (make-object mred:menu-item%
+              "Print"
+              file-menu
+              (lambda (_1 _2)
+                (print)))
+            (make-object mred:menu-item%
+              "Close"
+              file-menu
+              (lambda (_1 _2)
+                (turtles #f))))
+          
+          (public
+            [save-turtle-bitmap
+             (lambda (fn type)
+               (send bitmap save-file fn type))])
+          
+          (private-field
+           [canvas% 
+            (class100 mred:canvas% args
+              (inherit get-dc)
+              (override
+                [on-paint
+                 (lambda ()
+                   (let ([dc (get-dc)])
+                     (send dc clear)
+                     (send dc draw-bitmap (send memory-dc get-bitmap) 0 0)
+                     (flip-icons)))])
+              (sequence (apply super-init args)))]
+           [canvas (make-object canvas% this)]
+           [dc (send canvas get-dc)])
+          
+          (public
+            [wipe-line (lambda (a b c d)
+                         (send memory-dc set-pen w-pen)
+                         (send dc set-pen w-pen)
+                         (send memory-dc draw-line a b c d)
+                         (send dc draw-line a b c d)
+                         (send memory-dc set-pen b-pen)
+                         (send dc set-pen b-pen))]
+            [draw-line (lambda (a b c d)
+                         (send memory-dc draw-line a b c d)
+                         (send dc draw-line a b c d))])
+          (sequence
+            (send canvas min-width width)
+            (send canvas min-height height)
+            (send this clear))))
+      
+      (define turtle-window-size
+        (let-values ([(w h) (mred:get-display-size)]
+                     [(user/client-offset) 65]
+                     [(default-size) 800])
+          (min default-size
+               (- w user/client-offset)
+               (- h user/client-offset))))
+      
+      (define-struct turtle (x y angle))
+      ; x : int
+      ; y: int
+      ; angle : int
+      
+      (define-struct cached (turtles cache))
+      ; turtles : (list-of turtle)
+      ; cache : turtle -> turtle
+      
+      (define-struct tree (children))
+      ; children : (list-of cached)
+      
+      (define clear-turtle (make-turtle (/ turtle-window-size 2)
+                                        (/ turtle-window-size 2) 0))
+      
+      ;; turtles-state is either a
+      ;;    - (list-of turtle) or
+      ;;    - tree 
+      (define turtles-state (list clear-turtle))
+      
+      ;; the cache contains a turtle-offset, which is represented
+      ;; by a turtle -- but it is a delta not an absolute.
+      (define empty-cache (make-turtle 0 0 0))
+      (define turtles-cache empty-cache)
+      
+      (define init-error (lambda _ (error 'turtles "Turtles not initialized. Evaluate (turtles).")))
+      (define inner-line init-error)
+      (define inner-wipe-line init-error)
+      (define inner-clear-window init-error)
+      (define inner-flip-icons init-error)
+      (define inner-save-turtle-bitmap init-error)
+      
+      (define line
+        (lambda (a b c d)
+          (set! lines-in-drawing (cons (make-draw-line a b c d) lines-in-drawing))
+          (inner-line a b c d)))
+      (define do-wipe-line
+        (lambda (a b c d)
+          (set! lines-in-drawing (cons (make-wipe-line a b c d) lines-in-drawing))
+          (inner-wipe-line a b c d)))
+      (define (flip-icons) (inner-flip-icons))
+      
+      (define clear-window (lambda () (inner-clear-window)))
+      (define save-turtle-bitmap (lambda (x y) (inner-save-turtle-bitmap x y)))
+      
+      (define turtles
+        (case-lambda
+          [() (turtles #t)]
+          [(x)
+           (set! turtles:shown? x)
+           (unless turtles:window
+             (set! turtles:window
+                   (make-object plot-window%
+                     "Turtles"
+                     turtle-window-size
+                     turtle-window-size))
+             (set! inner-line (lambda x (send turtles:window draw-line . x)))
+             (set! inner-wipe-line (lambda x (send turtles:window wipe-line . x)))
+             (set! inner-clear-window (lambda x (send turtles:window clear . x)))
+             (set! inner-save-turtle-bitmap (lambda x (send turtles:window save-turtle-bitmap . x)))
+             (set! flip-icons (lambda x (send turtles:window flip-icons . x))))
+           (send turtles:window show x)
+           (send turtles:window get-canvas)]))
+      
+      (define clear 
+        (lambda ()
+          (set! turtles-cache empty-cache)
+          (set! turtles-state (list clear-turtle))
+          (set! lines-in-drawing null)
+          (clear-window)))
+      
+      ;; cache elements:
+      (define-struct c-forward (distance))
+      (define-struct c-turn (angle))
+      (define-struct c-draw (distance))
+      (define-struct c-offset (x y))
+      
+      ;; combines a cache-element and a turtle-offset.
+      ;; turtle-offsets are represented as turtles, 
+      ;; however they are deltas, not absolutes.
+      (define combine
+        (lambda (entry cache)
+          (cond 
+            [(c-forward? entry)
+             (let* ([n (c-forward-distance entry)]
+                    [angle (turtle-angle cache)]
+                    [x (turtle-x cache)]
+                    [y (turtle-y cache)]
+                    [newx (+ x (* n (cos angle)))]
+                    [newy (+ y (* n (sin angle)))])
+               (make-turtle newx newy angle))]
+            [(c-offset? entry)
+             (let* ([tx (turtle-x cache)]
+                    [ty (turtle-y cache)]
+                    [newx (+ tx (c-offset-x entry))]
+                    [newy (+ ty (c-offset-y entry))])
+               (make-turtle newx newy 
+                            (turtle-angle cache)))]
+            [(c-turn? entry)
+             (make-turtle (turtle-x cache)
+                          (turtle-y cache)
+                          (- (turtle-angle cache)
+                             (c-turn-angle entry)))]
+            [else
+             (error 'turtles-cache "illegal entry in cache: ~a" entry)])))
+      
+      ;; this applies an offset to a turtle.
+      ;; an offset is a turtle, representing what would happen 
+      ;;    if the turtle had started at zero.
+      (define apply-cache
+        (lambda (offset)
+          (let ([x (turtle-x offset)]
+                [y (turtle-y offset)]
+                [offset-angle (turtle-angle offset)])
+            (lambda (turtle)
+              (let* ([angle (turtle-angle turtle)])
+                (let* ([c (cos angle)]
+                       [s (sin angle)]
+                       [rx (- (* x c) (* y s))]
+                       [ry (+ (* y c) (* x s))])
+                  (make-turtle (+ rx (turtle-x turtle))
+                               (+ ry (turtle-y turtle))
+                               (+ offset-angle angle))))))))
+      
+      (define flatten
+        (lambda (at-end)
+          (letrec ([walk-turtles
+                    (lambda (turtles cache list)
+                      (cond
+                        [(tree? turtles)
+                         (let ([children (tree-children turtles)]
+                               [ac (apply-cache cache)])
+                           (foldl (lambda (child list)
+                                    (walk-turtles (cached-turtles child)
+                                                  (ac (cached-cache child))
+                                                  list))
+                                  list
+                                  children))]
+                        [else
+                         (let ([f (compose at-end (apply-cache cache))])
+                           (foldl (lambda (t l) (cons (f t) l)) list turtles))]))])
+            (set! turtles-state (walk-turtles turtles-state turtles-cache null))
+            (set! turtles-cache empty-cache))))
+      
+      (define draw/erase
+        (lambda (doit)
+          (lambda (n)
+            (flip-icons)
+            (flatten
+             (lambda (turtle)
+               (let* ([x (turtle-x turtle)]
+                      [y (turtle-y turtle)]
+                      [angle (turtle-angle turtle)]
+                      [d (if (zero? n) 0 (sub1 (abs n)))]
+                      [res (if (< n 0) (- d) d)]
+                      [c (cos angle)]
+                      [s (sin angle)]
+                      [drawx (+ x (* res c))]
+                      [drawy (+ y (* res s))]
+                      [newx (+ x (* n c))]
+                      [newy (+ y (* n s))])
+                 (unless (zero? n)
+                   (doit x y drawx drawy))
+                 (make-turtle newx newy angle))))
+            (flip-icons))))
+      
+      (define draw (draw/erase (lambda (a b c d) (line a b c d))))
+      (define erase (draw/erase (lambda (a b c d) (do-wipe-line a b c d))))
+      
+      (define move
+        (lambda (n)
+          (flip-icons)
+          (set! turtles-cache (combine (make-c-forward n) turtles-cache))
+          (flip-icons)))
+      
+      (define turn/radians
+        (lambda (d)
+          (flip-icons)
+          (set! turtles-cache (combine (make-c-turn d) turtles-cache))
+          (flip-icons)))
+      
+      (define turn
+        (lambda (c)
+          (turn/radians (* (/ c 360) 2 pi))))
+      
+      (define move-offset
+        (lambda (x y)
+          (flip-icons)
+          (set! turtles-cache (combine (make-c-offset x y) turtles-cache))
+          (flip-icons)))
+      
+      (define erase/draw-offset
+        (lambda (doit)
+          (lambda (x y)
+            (flip-icons)
+            (flatten
+             (lambda (turtle)
+               (let* ([tx (turtle-x turtle)]
+                      [ty (turtle-y turtle)]
+                      [newx (+ tx x)]
+                      [newy (+ ty y)])
+                 (doit tx ty newx newy)
+                 (make-turtle newx newy (turtle-angle turtle)))))
+            (flip-icons))))
+      
+      (define erase-offset (erase/draw-offset (lambda (a b c d) (do-wipe-line a b c d))))
+      (define draw-offset (erase/draw-offset (lambda (a b c d) (line a b c d))))
+      
+      (define splitfn
+        (lambda (e)
+          (let ([t turtles-state]
+                [c turtles-cache])
+            (e)
+            (flip-icons)
+            (set! turtles-state
+                  (make-tree (list (make-cached turtles-state turtles-cache)
+                                   (make-cached t c))))
+            (set! turtles-cache empty-cache)
+            (flip-icons))))
+      
+      (define split*fn
+        (lambda (es)
+          (let ([t turtles-state]
+                [c turtles-cache]
+                [l '()])
+            (for-each (lambda (x)
+                        (x)
+                        (set! l (cons (make-cached turtles-state turtles-cache) l))
+                        (flip-icons)
+                        (set! turtles-state t)
+                        (set! turtles-cache c)
+                        (flip-icons))
+                      es)
+            (flip-icons)
+            (set! turtles-cache empty-cache)
+            (set! turtles-state (make-tree l))
+            (flip-icons))))
+      
+      
+      (define tpromptfn
+        (lambda (thunk)
+          (let ([save-turtles-cache #f]
+                [save-turtles-state #f])
+            (dynamic-wind
+             (lambda ()
+               (set! save-turtles-cache turtles-cache)
+               (set! save-turtles-state turtles-state))
+             (lambda ()
+               (thunk))
+             (lambda ()
+               (flip-icons)
+               (set! turtles-cache save-turtles-cache)
+               (set! turtles-state save-turtles-state)
+               (flip-icons))))))
+      
+      
+      (define-struct drawing-line (x1 y1 x2 y2))
+      (define-struct (wipe-line drawing-line) ())
+      (define-struct (draw-line drawing-line) ())
+      (define lines-in-drawing null)
+      
+      (define (draw-lines-into-dc dc)
+        (for-each (lambda (line)
+                    (cond
+                      [(wipe-line? line) (send dc set-pen w-pen)]
+                      [(draw-line? line) (send dc set-pen b-pen)])
+                    (send dc draw-line
+                          (drawing-line-x1 line)
+                          (drawing-line-y1 line)
+                          (drawing-line-x2 line)
+                          (drawing-line-y2 line)))
+                  lines-in-drawing))
+      
+      ;; used to test printing
+      (define (display-lines-in-drawing)
+        (let* ([lines-in-drawing-canvas%
+                (class100 mred:canvas% (frame)
+                  (inherit get-dc)
+                  (override
+                    [on-paint
+                     (lambda ()
+                       (draw-lines-into-dc (get-dc)))])
+                  (sequence
+                    (super-init frame)))]
+               [frame (make-object mred:frame% "Lines in Drawing")]
+               [canvas (make-object lines-in-drawing-canvas% frame)])
+          (send frame show #t)))
+      
+      
+      (define (print)
+        (case (system-type)
+          [(macos macosx windows)
+           (let ([dc (make-object mred:printer-dc%)])
+             (send dc start-doc "Turtles")
+             (send dc start-page)
+             (draw-lines-into-dc dc)
+             (send dc end-page)
+             (send dc end-doc))]
+          [(unix)
+           (let ([dc (make-object mred:post-script-dc%)])
+             (send dc start-doc "Turtles")
+             (send dc start-page)
+             (draw-lines-into-dc dc)
+             (send dc end-page)
+             (send dc end-doc))]
+          [else
+           (mred:message-box "Turtles"
+                             "Printing is not supported on this platform")])))))
\ No newline at end of file
diff --git a/collects/graphics/turtles.ss b/collects/graphics/turtles.ss
new file mode 100644
index 0000000000..d323dc02f6
--- /dev/null
+++ b/collects/graphics/turtles.ss
@@ -0,0 +1,28 @@
+(module turtles mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "mred-sig.ss" "mred")
+	   (lib "mred.ss" "mred")
+	   "turtle-sig.ss"
+	   "turtle-unit.ss")
+
+  (provide-signature-elements turtle^)
+  (provide split split* tprompt)
+
+  (define-values/invoke-unit/sig turtle^ turtle@ #f mred^)
+ 
+  (define-syntax split
+    (lambda (x)
+      (syntax-case x ()
+        ((_ args ...)
+	 (syntax (splitfn (lambda () args ...)))))))
+
+ (define-syntax split*
+   (syntax-rules ()
+     [(_ e0 e ...)
+      (split*fn (list (lambda () e0) (lambda () e) ...))]))
+
+  (define-syntax tprompt
+    (lambda (x)
+      (syntax-case x ()
+        ((_ e1 ...)
+	 (syntax (tpromptfn (lambda () e1 ...))))))))
\ No newline at end of file
diff --git a/collects/graphics/value-turtles-examples.ss b/collects/graphics/value-turtles-examples.ss
new file mode 100644
index 0000000000..4ff11312a3
--- /dev/null
+++ b/collects/graphics/value-turtles-examples.ss
@@ -0,0 +1,106 @@
+(module value-turtles-examples mzscheme
+  (require "value-turtles.ss"
+           (lib "etc.ss")
+           (lib "math.ss"))
+
+  (provide regular-poly regular-polys radial-turtles spaced-turtles 
+           spokes spyro-gyra neato)
+  
+  (define (regular-poly sides radius tv)
+    (local [(define theta (/ (* 2 pi) sides))
+            (define side-len (* 2 radius (sin (/ theta 2))))
+            (define (draw-sides n tv)
+              (cond
+                [(zero? n) tv]
+                [else
+                 (draw-sides
+                  (sub1 n)
+                  (turn/radians
+                   theta
+                   (draw side-len tv)))]))]
+      (merge
+       (clean
+        (draw-sides
+         sides
+         (turn/radians
+          (/ (+ pi theta) 2)
+          (move
+           radius
+           tv))))
+       tv)))
+  
+  (define (regular-polys sides s tv)
+    (local [(define (make-polys n tv)
+              (cond
+                [(zero? n) tv]
+                [else
+                 (make-polys 
+                  (sub1 n)
+                  (regular-poly 
+                   sides 
+                   (* n 5)
+                   tv))]))]
+      (make-polys sides tv)))
+  
+  (define (radial-turtles n tv)
+    (cond
+      [(zero? n) tv]
+      [else
+       (radial-turtles
+        (sub1 n)
+        (merge 
+         tv
+         (turn/radians 
+          (/ pi (expt 2 (sub1 n)))
+          tv)))]))
+  
+  (define (spaced-turtles n tv)
+    (cond
+      [(zero? n) tv]
+      [else
+       (spaced-turtles 
+        (sub1 n)
+        (merge
+         tv
+         (move 
+          (expt 2 (+ n 1))
+          tv)))]))
+  
+  (define (spokes turtles)
+    (draw 
+     10
+     (turn/radians 
+      (/ pi 2)
+      (spaced-turtles
+       5
+       (radial-turtles 
+        4
+        turtles)))))
+  
+  (define (spyro-gyra turtles)
+    (regular-poly 
+     3
+     100
+     (radial-turtles 
+      4
+      turtles)))
+  
+  (define (neato turtles)
+    (local [(define (spiral d t turtles)
+              (cond
+                [(<= 1 d)
+                 (spiral 
+                  (- d 1)
+                  t               
+                  (turn/radians 
+                   t
+                   (draw 
+                    d
+                    turtles)))]
+                [else turtles]))]
+      (spiral 
+       30 
+       (/ pi 12)
+       (radial-turtles
+        4
+        turtles)))))
\ No newline at end of file
diff --git a/collects/graphics/value-turtles-test.ss b/collects/graphics/value-turtles-test.ss
new file mode 100644
index 0000000000..e59734fbf3
--- /dev/null
+++ b/collects/graphics/value-turtles-test.ss
@@ -0,0 +1,36 @@
+(module value-turtles-test mzscheme
+  (require "value-turtles-examples.ss"
+           "value-turtles.ss"
+           (lib "mred.ss" "mred")
+           (lib "class.ss"))
+  
+  (define-syntax (test stx)
+    (syntax-case stx ()
+      [(_ body)
+       (with-syntax ([body-string (format "~s" (syntax-object->datum (syntax body)))])
+         (syntax
+          (let* ([f (make-object frame% "frame" #f 600 600)]
+                 [t (make-object text%)]
+                 [mb (make-object menu-bar% f)]
+                 [fm (make-object menu% "File" mb)])
+            (send t insert body-string)
+            (send t change-style (make-object style-delta% 'change-family 'modern)
+                  0 (send t last-position))
+            (send t insert #\newline)
+            (make-object menu-item% "Copy" fm (lambda x (send t copy)) #\c)
+            (make-object editor-canvas% f t)
+            (send f show #t)
+            (with-handlers ([exn:fail?
+                             (lambda (x)
+                               (send t insert (exn-message x))
+                               (send t insert #\newline))])
+              (send t insert body)
+              (send t insert #\newline)))))]))
+  
+  (test (regular-poly 5 30 (turtles 150 150)))
+  (test (regular-polys 5 30 (turtles 150 150)))
+  (test (draw 20 (radial-turtles 5 (turtles 150 150))))
+  (test (draw 20 (turn 90 (spaced-turtles 5 (turtles 150 150 10 75 0)))))
+  (test (spokes (turtles 200 200)))
+  (test (spyro-gyra (turtles 200 200)))
+  (test (neato (turtles 400 400))))
\ No newline at end of file
diff --git a/collects/graphics/value-turtles.ss b/collects/graphics/value-turtles.ss
new file mode 100644
index 0000000000..14f72b3c4b
--- /dev/null
+++ b/collects/graphics/value-turtles.ss
@@ -0,0 +1,350 @@
+(module value-turtles mzscheme
+  (require (lib "math.ss")
+           (lib "class.ss")
+           (lib "mred.ss" "mred")
+           (lib "list.ss")
+           (lib "struct.ss"))
+
+  (provide turtles move draw turn turn/radians merge clean)
+
+  ;; a turtle is:
+  ;; - (make-turtle x y theta)
+  ;; where x, y, and theta are numbers
+  (define-struct turtle (x y angle))
+  (define turtle->vector (make-->vector turtle))
+  
+  (define-struct offset (x y angle))
+  (define offset->vector (make-->vector offset))
+
+  ;; a lines is:
+  ;;   - (list-of line)
+  (define-struct line (x1 y1 x2 y2 black?))
+  (define line->vector (make-->vector line))
+  
+  ;; a turtles is either
+  ;;  - (make-tmerge (list-of turtles/offset))
+  ;;  - (list-of turtle)
+  (define-struct tmerge (turtles))
+  (define tmerge->vector (make-->vector tmerge))
+
+  ;; a turtles/offset is
+  ;; - (make-turtles/offset turtles offset)
+  (define-struct turtles/offset (turtles offset))
+  (define turtles/offset->vector (make-->vector turtles/offset))
+
+  (define saved-turtle-snip% #f)
+  (define saved-turtles #f)
+  (define (vec->struc sexp)
+    (cond
+      [(pair? sexp) (cons (vec->struc (car sexp)) (vec->struc (cdr sexp)))]
+      [(vector? sexp)
+       (apply (case (vector-ref sexp 0)
+                [(struct:turtle) make-turtle]
+                [(struct:offset) make-offset]
+                [(struct:line) make-line]
+                [(struct:merge) make-tmerge]
+                [(struct:turtles/offset) make-turtles/offset]
+                [else (error 'vec->struc "unknown structure: ~s~n" sexp)])
+              (map vec->struc (vector-ref sexp 1)))]
+      [else sexp]))
+  
+  (define (struc->vec sexp)
+    (cond
+      [(pair? sexp) (cons (struc->vec (car sexp)) (struc->vec (cdr sexp)))]
+      [(turtle? sexp) (vector 'struct:turtle (map struc->vec (vector->list (turtle->vector sexp))))]
+      [(offset? sexp) (vector 'struct:offset (map struc->vec (vector->list (offset->vector sexp))))]
+      [(line? sexp) (vector 'struct:line (map struc->vec (vector->list (line->vector sexp))))]
+      [(tmerge? sexp) (vector 'struct:tmerge (map struc->vec (vector->list (tmerge->vector sexp))))]
+      [(turtles/offset? sexp) (vector 'struct:turtles/offset (map struc->vec (vector->list (turtles/offset->vector sexp))))]
+      [else sexp]))
+  
+  (define prim-read read)
+  (define prim-write write)
+
+  (define turtle-snip-class%
+    (class snip-class% ()
+      (define/override (read in-stream)
+        (unless saved-turtles
+          (error 'turtles "click execute before running the turtles"))
+        (let ([str (send in-stream get-string #f)])
+          (if (or (not str)
+                  (string=? "" str))
+              (saved-turtles 150 150)
+              (let ([sexp (vec->struc (prim-read (open-input-string str)))])
+                (make-object saved-turtle-snip%
+                  (first sexp)
+                  (second sexp)
+                  (third sexp)
+                  (fourth sexp)
+                  (fifth sexp))))))
+      (super-instantiate ())))
+  
+  (define turtle-snipclass (make-object turtle-snip-class%))
+  
+  (send turtle-snipclass set-classname "drscheme:turtle-snip")
+  (send turtle-snipclass set-version 1)
+  (send (get-the-snip-class-list) add turtle-snipclass)
+  
+  (define pi/2 (/ pi 2))
+  (define (set-box/f b v) (when (box? b) (set-box! b v)))
+  (define icon-color "PURPLE")
+  (define icon-pen (send the-pen-list find-or-create-pen icon-color 1 'xor))
+  (define icon-brush (send the-brush-list find-or-create-brush icon-color 'xor))
+  (define blank-pen (send the-pen-list find-or-create-pen "BLACK" 1 'transparent))
+  (define w-pen (send the-pen-list find-or-create-pen "white" 1 'solid))
+  (define b-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
+  (define w-brush (send the-brush-list find-or-create-brush "WHITE" 'solid))
+  
+  (define empty-cache (make-offset 0 0 0))
+  
+  (define turtle-snip%
+    (class snip% 
+      (init-field width height turtles cache lines)
+      (define/public (get-lines) lines)
+      (define/public (get-turtles) turtles)
+      (define/public (get-cache) cache)
+      (define/public (get-width) width)
+      (define/public (get-height) height)
+      
+      (define turtle-style 'triangle)
+      (define bitmap #f)
+      
+      [define pl (make-object point% 0 0)]
+      [define pr (make-object point% 0 0)]
+      [define ph (make-object point% 0 0)]
+      [define points (list pl pr ph)]
+      (define (flip-icons dc dx dy)
+        (case turtle-style
+          [(triangle line)
+           (let* ([proc
+                   (if (eq? turtle-style 'line)
+                       (lambda (turtle)
+                         (let ([x (turtle-x turtle)]
+                               [y (turtle-y turtle)]
+                               [theta (turtle-angle turtle)]
+                               [size 2])
+                           (send dc draw-line
+                                 (+ dx x)
+                                 (+ dy y)
+                                 (+ dx x (* size (cos theta)))
+                                 (+ dy y (* size (sin theta))))))
+                       (lambda (turtle)
+                         (let* ([x (turtle-x turtle)]
+                                [y (turtle-y turtle)]
+                                [theta (turtle-angle turtle)]
+                                [long-size 20]
+                                [short-size 7]
+                                [l-theta (+ theta pi/2)]
+                                [r-theta (- theta pi/2)])
+                           (send ph set-x (+ dx x (* long-size (cos theta))))
+                           (send ph set-y (+ dy y (* long-size (sin theta))))
+                           (send pl set-x (+ dx x (* short-size (cos l-theta))))
+                           (send pl set-y (+ dy y (* short-size (sin l-theta))))
+                           (send pr set-x (+ dx x (* short-size (cos r-theta))))
+                           (send pr set-y (+ dy y (* short-size (sin r-theta))))
+                           (send dc draw-polygon points))))])
+             (if (eq? turtle-style 'line)
+                 (send dc set-pen icon-pen)
+                 (begin
+                   (send dc set-pen blank-pen)
+                   (send dc set-brush icon-brush)))
+             (for-each proc turtles)
+             (send dc set-pen b-pen))]
+          [else
+           (void)]))
+      
+      (define (construct-bitmap)
+        (unless bitmap
+          (flatten)
+          (set! bitmap (make-object bitmap% width height))
+          (let* ([bitmap-dc (make-object bitmap-dc% bitmap)])
+            (send bitmap-dc clear)
+            (for-each (lambda (line)
+                        (send bitmap-dc set-pen (if (line-black? line) b-pen w-pen))
+                        (send bitmap-dc draw-line
+                              (line-x1 line)
+                              (line-y1 line)
+                              (line-x2 line)
+                              (line-y2 line)))
+                      lines))))
+      
+      (define/override (draw dc x y left top right bottom dx dy draw-caret)
+        (construct-bitmap)
+        (let ([old-pen (send dc get-pen)]
+              [old-brush (send dc get-brush)]
+              [old-clip (send dc get-clipping-region)])
+          (send dc set-pen b-pen)
+          (send dc set-brush w-brush)
+          (send dc draw-rectangle x y (+ width 2) (+ height 2))
+          (send dc set-clipping-rect (+ x 1) (+ y 1) width height)
+          (send dc draw-bitmap bitmap (+ x 1) (+ y 1))
+          (flip-icons dc (+ x 1) (+ y 1))
+          (send dc set-pen old-pen)
+          (send dc set-brush old-brush)
+          (send dc set-clipping-region old-clip)))
+      (define/override (get-extent dc x y w h descent space lspace rspace)
+        (set-box/f w (+ width 2))
+        (set-box/f h (+ height 2))
+        (set-box/f descent 0)
+        (set-box/f space 0)
+        (set-box/f lspace 0)
+        (set-box/f rspace 0))
+      
+      (define/override (copy)
+        (make-object turtle-snip% width height turtles cache lines))
+      (define/override (write stream-out)
+        (let ([p (open-output-string)])
+          (prim-write (struc->vec (list width height turtles cache lines)) p)
+          (send stream-out put (get-output-string p))))
+      
+      (define/public (flatten)
+        (letrec ([walk-turtles
+                  (lambda (turtles offset sofar)
+                    (cond
+                      [(tmerge? turtles)
+                       (let ([turtles/offsets (tmerge-turtles turtles)]
+                             [ac (apply-offset cache)])
+                         (foldl (lambda (turtles/offset sofar)
+                                  (walk-turtles (turtles/offset-turtles turtles/offset)
+                                                (combine-offsets
+                                                 offset
+                                                 (turtles/offset-offset turtles/offset))
+                                                sofar))
+                                sofar
+                                turtles/offsets))]
+                      [else
+                       (let ([f (apply-offset offset)])
+                         (cond
+                           [(null? sofar)
+                            (map f turtles)]
+                           [else
+                            (foldl (lambda (t l) (cons (f t) l)) sofar turtles)]))]))])
+          (set! turtles (walk-turtles turtles cache null))
+          (set! cache empty-cache)))
+
+      (define (move-turtle dist)
+        (lambda (turtle)
+          (let ([x (turtle-x turtle)]
+                [y (turtle-y turtle)]
+                [theta (turtle-angle turtle)])
+            (make-turtle
+             (+ x (* dist (cos theta)))
+             (+ y (* dist (sin theta)))
+             theta))))
+
+      (define/public (draw-op d)
+        (flatten)
+        (let ([build-line
+               (lambda (turtle)
+                 (let ([x (turtle-x turtle)]
+                       [y (turtle-y turtle)]
+                       [theta (turtle-angle turtle)])
+                   (make-line
+                    x
+                    y
+                    (+ x (* d (cos theta)))
+                    (+ y (* d (sin theta)))
+                    #t)))])
+          (make-object turtle-snip%
+            width
+            height
+            (map (move-turtle d) turtles)
+            cache
+            (foldl (lambda (turtle lines) (cons (build-line turtle) lines))
+                   lines
+                   turtles))))
+      (define/public (merge-op tvs)
+        (make-object turtle-snip%
+          width
+          height
+          (make-tmerge (map (lambda (tv) (make-turtles/offset
+                                          (send tv get-turtles)
+                                          (send tv get-cache)))
+                            (cons this tvs)))
+          empty-cache
+          lines))
+
+      (define/public (move-op n)
+        (make-object turtle-snip%
+          width
+          height
+          turtles
+          (let* ([angle (offset-angle cache)]
+                 [x (offset-x cache)]
+                 [y (offset-y cache)]
+                 [newx (+ x (* n (cos angle)))]
+                 [newy (+ y (* n (sin angle)))])
+            (make-offset newx newy angle))
+          lines))
+      (define/public (turn-op d)
+        (make-object turtle-snip%
+          width
+          height
+          turtles
+          (make-offset (offset-x cache)
+                       (offset-y cache)
+                       (- (offset-angle cache)
+                          d))
+          lines))
+      (define/public (clean-op)
+        (flatten)
+        (make-object turtle-snip%
+          width
+          height
+          null
+          empty-cache
+          lines))
+      (super-instantiate ())
+      (inherit set-snipclass)
+      (set-snipclass turtle-snipclass)))
+  
+  (define apply-offset
+    (lambda (offset)
+      (let ([x (offset-x offset)]
+            [y (offset-y offset)]
+            [offset-angle (offset-angle offset)])
+        (lambda (turtle)
+          (let* ([angle (turtle-angle turtle)])
+            (let* ([c (cos angle)]
+                   [s (sin angle)]
+                   [rx (- (* x c) (* y s))]
+                   [ry (+ (* y c) (* x s))])
+              (make-turtle (+ rx (turtle-x turtle))
+                           (+ ry (turtle-y turtle))
+                           (+ offset-angle angle))))))))
+  
+  (define combine-offsets
+    (lambda (offset1 offset2)
+      (let ([answer ((apply-offset offset1)
+                     (make-turtle
+                      (offset-x offset2)
+                      (offset-y offset2)
+                      (offset-angle offset2)))])
+        (make-offset
+         (turtle-x answer)
+         (turtle-y answer)
+         (turtle-angle answer)))))
+  
+  (define turtles
+    (case-lambda
+      [(width height x y theta)
+       (make-object turtle-snip%
+         width height
+         (list (make-turtle x y theta))
+         empty-cache
+         null)]
+      [(width height)
+       (turtles width height 
+                (quotient width 2)
+                (quotient height 2)
+                0)]))
+  
+  (define (move d tv) (send tv move-op d))
+  (define (draw d tv) (send tv draw-op d))
+  (define (turn/radians d tv) (send tv turn-op d))
+  (define (turn d tv) (turn/radians (* (/ d 360) 2 pi) tv))
+  (define (merge tv . tvs) (send tv merge-op tvs))
+  (define (clean tv) (send tv clean-op))
+  
+  (set! saved-turtle-snip% turtle-snip%)
+  (set! saved-turtles turtles))
\ No newline at end of file
diff --git a/collects/guibuilder/base.ss b/collects/guibuilder/base.ss
new file mode 100644
index 0000000000..0fd047c527
--- /dev/null
+++ b/collects/guibuilder/base.ss
@@ -0,0 +1,584 @@
+
+(module base mzscheme
+  (require (prefix mred: (lib "mred.ss" "mred"))
+	   (lib "class.ss")
+	   (lib "file.ss")
+	   (lib "pretty.ss")
+	   (lib "etc.ss")
+	   (lib "list.ss")
+	   "utils.ss")
+
+  (define GB:SNIP-VERSION 5)
+  (define MINOR-VERSION 0)
+
+  ;; Info about the output mode:
+  (define-struct output-mode (as-class? no-free-vars?))
+
+  (define gb:snip%
+    (class mred:snip% 
+      (init-field [lm 5][tm 5][rm 5][bm 5])
+      (inherit get-admin set-snipclass set-count)
+      (private-field
+	(need-recalc? #t)
+	(prev-min-w 0)
+	(prev-min-h 0))
+      (field
+       [x 0]
+       [stable-x 0]
+       [y 0]
+       [stable-y 0]
+       [w (+ lm rm)]
+       [h (+ tm bm)]
+       [spacing 3]
+       [hilited? #f])
+      (public*
+       [spacing-+
+	(lambda args
+	  (+ (apply + args)
+	     (let ([c (let loop ([l args])
+			(cond
+			 [(null? l) 0]
+			 [(zero? (car l)) (loop (cdr l))]
+			 [else (add1 (loop (cdr l)))]))])
+	       (if (positive? c)
+		   (* spacing (sub1 c))
+		   0))))])
+      (public*
+       [init-horizontal-child-alignment (lambda () 2)]
+       [init-vertical-child-alignment (lambda () 2)]
+       [init-name (lambda () (new-name "item"))]
+       [get-classname (lambda () "gb:core")]
+       [container? (lambda () #t)]
+       [init-y-stretch? (lambda () #t)]
+       [init-x-stretch? (lambda () #t)])
+      (field
+       [horizontal-child-alignment (init-horizontal-child-alignment)]
+       [vertical-child-alignment (init-vertical-child-alignment)]
+       [with-border? #f]
+       [dialog #f]
+       [name (init-name)]
+       [id #f]
+       [original-id #f]
+       [original-children-ids #f]
+       (parent #f)
+       (pb #f)
+       (children null)
+       (y-stretch? (init-y-stretch?))
+       (x-stretch? (init-x-stretch?)))
+      (public*
+       (set-id (lambda (x) (set! id x)))
+       (set-horizontal-child-alignment
+	(lambda (v) (set! horizontal-child-alignment v)))
+       (set-vertical-child-alignment
+	(lambda (v) (set! vertical-child-alignment v)))
+       (set-with-border
+	(lambda (v) (set! with-border? v)))
+
+       (get-frame%
+	(lambda ()
+	  (class mred:frame%
+	    (init-field do-on-close)
+	    (inherit show)
+	    (public*
+	      [get-kind (lambda () "Panel")]
+	      [on-main (lambda (x) x)]
+	      [find-control (lambda (tag) #f)])
+	    (super-make-object (format "~a Settings" (get-kind)) #f 200 10)
+	    (private-field
+	      [main (on-main (make-object mred:vertical-panel% this))]
+	      [name-edit (make-one-line/callback-edit main "Scheme Name:"
+						      (lambda (txt)
+							(set! name txt))
+						      name)])
+	    (field
+	      [controls (make-object mred:vertical-panel% main)])
+	    (augment*
+	     [on-close (lambda () (do-on-close))])
+	    (send controls set-alignment 'left 'center)
+	    (let* ([p (make-object mred:vertical-panel% main)]
+		   [make-sc
+		    (lambda (name set)
+		      (make-object mred:check-box% 
+				   name
+				   p
+				   (lambda (c e)
+				     (set (send c get-value))
+				     (gb-need-recalc-size))))]
+		   [xsc (make-sc "Allow Horizontal Stretching"
+				 (lambda (on?) (set! x-stretch? on?)))]
+		   [ysc (make-sc "Allow Vertical Stretching"
+				 (lambda (on?) (set! y-stretch? on?)))])
+	      (send p set-alignment 'left 'center)
+	      (send xsc set-value x-stretch?)
+	      (send ysc set-value y-stretch?)
+	      (let ([p (make-object mred:vertical-panel% p)])
+		(send p stretchable-height #f))))))
+       
+       (gb-add-child 
+	(case-lambda 
+	 [(c) (gb-add-child c (length children))]
+	 [(c pos)
+	  (set! children 
+		(let loop ([l children][p pos])
+		  (cond
+		   [(or (zero? p) (null? l)) (cons c l)]
+		   [else (cons (car l) (loop (cdr l) (sub1 p)))]))) 
+	  (when pb
+	    (send c gb-install pb this)
+	    (send pb insert c x (+ y h)))
+	  (gb-need-recalc-size)]))
+       (gb-remove-child 
+	(lambda (c) 
+	  (set! children (remq c children))
+	  (gb-need-recalc-size)))
+       
+       (gb-need-recalc-size
+	(lambda ()
+	  (set! need-recalc? #t)
+	  (resized)))
+       
+       (gb-install
+	(lambda (pb-in parent-in)
+	  (set! parent parent-in)
+	  (if pb
+	      (when parent
+		(send pb set-before this parent))
+	      (set! pb pb-in))
+	  (set! id (send pb new-id))
+	  (for-each
+	   (lambda (c)
+	     (send pb insert c x (+ y h))
+	     (send c gb-install pb this))
+	   children)))
+       
+       (gb-get-child-x-start
+	(lambda (mw mh w h) 
+	  0))
+       (gb-get-child-y-start
+	(lambda (mw mh w h)
+	  (if (or (= vertical-child-alignment 1)
+		  (ormap (lambda (c) (gb-y-stretch? c)) children))
+	      0
+	      (case vertical-child-alignment
+		[(2) (/ (- h mh) 2)]
+		[(3) (- h mh)]))))
+       (gb-combine-child-width (lambda (a b) (max a b)))
+       (gb-combine-child-height (lambda (a b) (spacing-+ a b)))
+       
+       (gb-compute-child-x-pos
+	(lambda (dc c w)
+	  (if (gb-x-stretch? c)
+	      0
+	      (case horizontal-child-alignment
+		[(2) (let-values ([(cw ch) (send c gb-get-min-size dc)])
+		       (/ (- w cw) 2))]
+		[(1) 0]
+		[(3) (let-values ([(cw ch) (send c gb-get-min-size dc)])
+		       (- w cw))]))))
+       (gb-compute-child-y-pos
+	(lambda (dc c h)
+	  0))
+       (gb-compute-child-width
+	(lambda (dc c w xsc dw)
+	  (if (gb-x-stretch? c)
+	      w
+	      (let-values ([(cw ch) (send c gb-get-min-size dc)])
+		cw))))
+       (gb-compute-child-height
+	(lambda (dc c h ysc dh)
+	  (let-values ([(cw ch) (send c gb-get-min-size dc)])
+	    (if (gb-y-stretch? c)
+		(+ ch (/ dh ysc))
+		ch))))
+       
+       (gb-combine-child-x-offset (lambda (a b) a))
+       (gb-combine-child-y-offset (lambda (a b) (spacing-+ a b)))
+       
+       (gb-get-min-size
+	(lambda (dc)
+	  (let loop ([lw 0][lh 0][l children])
+	    (cond
+	     [(null? l) (let* ([w (+ lw lm rm)]
+			       [h (+ lh tm bm)])
+			  (set! prev-min-h h)
+			  (values w h))]
+	     [else
+	      (let ([c (car l)])
+		(let-values ([(cw ch) (send c gb-get-min-size dc)])
+		  (loop (gb-combine-child-width lw cw) 
+			(gb-combine-child-height lh ch) 
+			(cdr l))))]))))
+       (gb-set-shape
+	(lambda (dc x-in y-in w-in h-in)
+	  (let*-values ([(xsc) (apply + (map 
+					 (lambda (c) (if (gb-x-stretch? c) 1 0))
+					 children))] 
+			[(ysc) (apply + (map 
+					 (lambda (c) (if (gb-y-stretch? c) 1 0))
+					 children))]
+			[(mw mh) (gb-get-min-size dc)]
+			[(ew eh) (values (- w-in lm rm) (- h-in tm bm))]
+			[(dw dh) (values (- w-in mw) (- h-in mh))])
+	    (let loop ([lx (+ lm x-in (gb-get-child-x-start mw mh w-in h-in))]
+		       [ly (+ tm y-in (gb-get-child-y-start mw mh w-in h-in))]
+		       [l children])
+	      (cond
+	       [(null? l) 0]
+	       [else
+		(let ([c (car l)])
+		  (let-values ([(cw ch)
+				(send c gb-set-shape dc
+				      (+ lx (gb-compute-child-x-pos dc c ew))
+				      (+ ly (gb-compute-child-y-pos dc c eh))
+				      (gb-compute-child-width dc c ew xsc dw)
+				      (gb-compute-child-height dc c eh ysc dh))])
+		    (loop (gb-combine-child-x-offset lx cw) 
+			  (gb-combine-child-y-offset ly ch) 
+			  (cdr l))))])))
+	  (unless parent
+	    (when (and pb (not (and (= w w-in) (= h h-in))))
+	      (send pb top-resized this w h w-in h-in)))
+	  (set! x x-in)
+	  (set! y y-in)
+	  (set! w w-in)
+	  (set! h h-in)
+	  (resized)
+	  (when pb
+	    (send pb move-to this x-in y-in))
+	  (values w-in h-in)))
+       
+       (find-position-<
+	(lambda (fx fy cx cy)
+	  (< fy cy)))
+       (gb-find-position
+	(lambda (fx fy)
+	  (let loop ([l children][pos 0])
+	    (if (null? l)
+		pos
+		(let*-values ([(c) (car l)]
+			      [(cx) (send c gb-get-stable-x)]
+			      [(cy) (send c gb-get-stable-y)]
+			      [(w h) (send c gb-get-size)])
+		  (if (find-position-< fx fy (+ cx w) (+ cy h))
+		      pos
+		      (loop (cdr l) (add1 pos))))))))
+       (gb-get-child-pos
+	(lambda (c)
+	  (let loop ([l children][pos 0])
+	    (cond
+	     [(null? l) pos]
+	     [(eq? (car l) c) pos]
+	     [else (loop (cdr l) (add1 pos))]))))
+       
+       (gb-get-saved-min-size
+	(lambda ()
+	  (values prev-min-w prev-min-h)))
+       
+       (gb-recalc-size
+	(lambda (dc)
+	  (if parent
+	      (send parent gb-recalc-size dc)
+	      (let-values ([(mw mh) (gb-get-min-size dc)]
+			   [(xb) (box 0)]
+			   [(yb) (box 0)])
+		(when pb 
+		  (send pb get-snip-location this xb yb #f)
+		  (send pb get-main-location this dc xb yb))
+		(gb-set-shape dc (unbox xb) (unbox yb) 
+			      (if x-stretch? (max w mw) mw)
+			      (if y-stretch? (max h mh) mh))))))
+       
+       (gb-hilite
+	(lambda (on?)
+	  (unless (eq? on? hilited?)
+	    (set! hilited? on?)
+	    (refresh))))
+       
+       (gb-get-parent
+	(lambda () parent))
+       (gb-get-children
+	(lambda () children))
+       (gb-get-size
+	(lambda () (values w h)))
+       (gb-get-x (lambda () x))
+       (gb-get-y (lambda () y))
+       (gb-get-stable-x (lambda () stable-x))
+       (gb-get-stable-y (lambda () stable-y))
+       (gb-get-position-and-size
+	(lambda () (values x y w h)))
+       
+       (gb-set-stable-position
+	(lambda ()
+	  (set! stable-x x)
+	  (set! stable-y y)))
+       
+       (gb-drag-children-along
+	(lambda (new-x new-y)
+	  (when (not (and (= x new-x) (= y new-y)))
+	    (for-each
+	     (lambda (c)
+	       (let ([cx (+ new-x (- (send c gb-get-stable-x) stable-x))]
+		     [cy (+ new-y (- (send c gb-get-stable-y) stable-y))])
+		 (send pb move-to c cx cy)
+		 (send c gb-drag-children-along cx cy)))
+	     children)
+	    (set! x new-x)
+	    (set! y new-y))))
+       
+       (gb-open-dialog
+	(lambda ()
+	  (if dialog
+	      (send dialog show #t)
+	      (let ([f (make-object (get-frame%) (lambda () (set! dialog #f)))])
+		(set! dialog f)
+		(send f show #t)))))
+       
+       (gb-reconnect-to-original-children
+	(lambda ()
+	  (if original-children-ids
+	      (let ([sl (map
+			 (lambda (id) (send pb find-snip-by-original-id id))
+			 original-children-ids)])
+		(set! original-children-ids #f)
+		(for-each
+		 (lambda (s)
+		   (when s
+		     (gb-add-child s)
+		     (send pb remove-selected s)))
+		 sl)
+		#t)
+	      #f)))
+       (gb-forget-original-id
+	(lambda ()
+	  ;; Make unique name
+	  (let ([orig-name name])
+	    (set! name #f)
+	    (let loop ([new-name orig-name])
+	      (if (send pb find-snip-by-name new-name)
+		  (loop (string-append new-name "+"))
+		  (set! name new-name))))
+	  (set! original-id #f)
+	  (set! original-children-ids #f)))
+       
+       (gb-get-instantiate-class-getter
+	(lambda ()
+	  `(,(string->symbol (string-append "get-" name "%")))))
+       (gb-get-style
+	(lambda ()
+	  (if with-border?
+	      '(border)
+	      null)))
+       (gb-local-instantiate
+	(lambda (parent mode)
+	  `(new ,(if (output-mode-as-class? mode)
+		     (gb-get-instantiate-class-getter)
+		     (gb-get-default-class))
+		[parent ,parent]
+		,@(gb-instantiate-arguments))))
+       (gb-instantiate-arguments
+	(lambda () `([style ',(gb-get-style)]
+		     [stretchable-width ,x-stretch?]
+		     [stretchable-height ,y-stretch?])))
+
+       (gb-get-default-class (lambda () 'vertical-panel%))
+       (gb-aux-instantiate
+	(lambda (mode)
+	  (if (output-mode-as-class? mode)
+	      `((public* [,(string->symbol (string-append "get-" name "%"))
+			  (lambda () ,(gb-get-default-class))]))
+	      null)))
+       (gb-instantiate
+	(lambda (parent mode)
+	  (let ([v (gb-local-instantiate parent mode)]
+		[name (string->symbol name)])
+	    `(,@(gb-aux-instantiate mode)
+	      ,(if (output-mode-as-class? mode)
+		   `(field [,name ,v])
+		   `(define ,name ,v))
+	      ,@(apply append
+		       (map (lambda (c) (send c gb-instantiate name mode)) children))))))
+
+       (draw-box
+	(lambda (dc x y w h)
+	  (let* ((xw (sub1 (+ x w)))
+		 (yh (sub1 (+ y h)))
+		 (x (add1 x))
+		 (y (add1 y)))
+	    (send dc draw-line x y xw y)
+	    (send dc draw-line xw y xw yh)
+	    (send dc draw-line x yh xw yh)
+	    (send dc draw-line x y x yh))))
+       
+       (base-setup
+	(lambda (nm xs? ys? nw nh hca vca wb? id children-ids)
+	  (set! name nm)
+	  (set! x-stretch? xs?)
+	  (set! y-stretch? ys?)
+	  (set! w nw)
+	  (set! h nh)
+	  (set! horizontal-child-alignment hca)
+	  (set! vertical-child-alignment vca)
+	  (set! with-border? wb?)
+	  (set! original-id id)
+	  (set! original-children-ids children-ids)))
+
+       [get-tagged-value
+	(lambda (tag) #f)]
+       [set-tagged-value (lambda (t v-in) (void))]
+
+	(refresh
+	 (lambda ()
+	   (let ([admin (get-admin)])
+	     (when admin
+	       (send admin needs-update this 0 0 w h)))))
+	(resized
+	 (lambda ()
+	   (let ([admin (get-admin)])
+	     (when admin
+	       (send admin resized this #t))))))
+
+      (override*
+       (get-extent
+	(lambda (dc x y wbox hbox descentbox spacebox
+		    lspacebox rspacebox)
+	  (when need-recalc?
+	    (set! need-recalc? #f)
+	    (gb-recalc-size dc))
+	  (when hbox
+	    (set-box! hbox h))
+	  (when wbox
+	    (set-box! wbox w))
+	  (when descentbox
+	    (set-box! descentbox 0))
+	  (when spacebox
+	    (set-box! spacebox 0))
+	  (when rspacebox
+	    (set-box! rspacebox 0))
+	  (when lspacebox
+	    (set-box! lspacebox 0))))
+       (draw
+	(lambda (dc x y . other)
+	  (draw-box dc x y w h)
+	  (when (or with-border? hilited?)
+	    (draw-box dc (add1 x) (add1 y) (- w 2) (- h 2)))
+	  (when (and with-border? hilited?)
+	    (draw-box dc (+ 2 x) (+ 2 y) (- w 4) (- h 4)))))
+       (copy
+	(lambda ()
+	  (let ([o (make-object (hash-table-get interface->class-table
+						(object-interface this))
+				lm tm rm bm)])
+	    (send o base-setup 
+		  name
+		  x-stretch? y-stretch? w h 
+		  horizontal-child-alignment
+		  vertical-child-alignment
+		  with-border?
+		  (or original-id id)
+		  (or original-children-ids 
+		      (and (pair? children)
+			   (map (lambda (child) (gb-id child)) children))))
+	    o)))
+       (write
+	(lambda (stream)
+	  (send stream put (string->bytes/utf-8 name))
+	  (send stream put (if x-stretch? 1 0))
+	  (send stream put (if y-stretch? 1 0))
+	  (send stream put (floor (inexact->exact w)))
+	  (send stream put (floor (inexact->exact h)))
+	  (send stream put horizontal-child-alignment)
+	  (send stream put vertical-child-alignment)
+	  (send stream put (if with-border? 1 0))
+	  (send stream put (string->bytes/utf-8 (if id id "BAD")))
+	  (stream-write-list stream (map (lambda (c) (gb-id c)) children)))))
+      (public*
+       (read
+	(lambda (stream version)
+	  (base-setup
+	   ;; name
+	   (if (>= version 3) 
+	       ((get-bytes->string version) (send stream get-bytes))
+	       name)
+	   (positive? (send stream get-exact))
+	   (positive? (send stream get-exact))
+	   (send stream get-exact) ; w
+	   (send stream get-exact) ; h
+	   (if (>= version 2) (send stream get-exact) horizontal-child-alignment) ; hca
+	   (if (>= version 2) (send stream get-exact) vertical-child-alignment) ; vca
+	   (if (>= version 2) (positive? (send stream get-exact)) #f) ; with-border?
+	   ((get-bytes->string version) (send stream get-bytes))
+	   (let ([v (stream-read-list stream version)])
+	     (if (null? v) #f v))))))
+      (override*
+       (resize 
+	(lambda (w-in h-in)
+	  (if (not parent) 
+	      (let-values ([(mw mh) (values prev-min-w prev-min-h)])
+		(if (or (and (> w-in mw) x-stretch?)
+			(and (> h-in mh) y-stretch?))
+		    (begin
+		      (when x-stretch? (set! w (max mw w-in)))
+		      (when y-stretch? (set! h (max mh h-in)))
+		      (gb-need-recalc-size)
+		      #t)
+		    #f))
+	      #f))))
+      (super-new)
+      (set-snipclass (send (mred:get-the-snip-class-list) find (get-classname)))
+      (set-count 1)))
+
+  (define gb:atomic-snip%
+    (class gb:snip%
+      (override*
+       (init-x-stretch? (lambda () #f))
+       (init-y-stretch? (lambda () #f))
+       (container? (lambda () #f)))
+      (super-new)))
+  
+  (define gb-y-stretch? (class-field-accessor gb:snip% y-stretch?))
+  (define gb-x-stretch? (class-field-accessor gb:snip% x-stretch?))
+  (define gb-id (class-field-accessor gb:snip% id))
+  (define gb-original-id (class-field-accessor gb:snip% original-id))
+  (define gb-parent (class-field-accessor gb:snip% parent))
+  (define gb-name (class-field-accessor gb:snip% name))
+  
+  (define interface->class-table (make-hash-table))
+
+  (define register-class
+    (lambda (class% classname)
+      (hash-table-put!
+       interface->class-table
+       (class->interface class%)
+       class%)
+      (let ([snipclass
+	     (make-object 
+	      (class mred:snip-class% ()
+		(inherit set-classname set-version reading-version)
+		(override*
+		  [read
+		   (lambda (stream)
+		     (let ([o (make-object class%)])
+		       (send o read stream (reading-version stream))
+		       o))])
+		(super-new)
+		(set-classname classname)
+		(set-version GB:SNIP-VERSION)))])
+	(send (mred:get-the-snip-class-list) add snipclass))))
+  
+  (register-class gb:snip% "gb:core")
+  
+  (provide gb:snip%
+	   gb:atomic-snip%
+
+	   gb-y-stretch?
+	   gb-x-stretch?
+	   gb-id
+	   gb-original-id
+	   gb-parent
+	   gb-name
+
+	   (struct output-mode (as-class? no-free-vars?))
+	   
+	   interface->class-table
+
+	   register-class))
diff --git a/collects/guibuilder/button.xpm b/collects/guibuilder/button.xpm
new file mode 100644
index 0000000000..cc931e8a84
--- /dev/null
+++ b/collects/guibuilder/button.xpm
@@ -0,0 +1,22 @@
+/* XPM */
+static char * button_xpm[] = {
+"16 16 3 1",
+" 	c #FFFFFFFFFFFF",
+".	c #000000000000",
+"X	c #A0A0A0A0A0A0",
+"                ",
+"                ",
+"                ",
+"                ",
+"   ..........   ",
+"  .          .  ",
+" .   XX  X X  . ",
+" .  X  X XX   . ",
+" .  X  X X X  . ",
+" .   XX  X X  . ",
+"  .          .  ",
+"   ..........   ",
+"                ",
+"                ",
+"                ",
+"                "};
diff --git a/collects/guibuilder/canvas.ss b/collects/guibuilder/canvas.ss
new file mode 100644
index 0000000000..1bcfcc7e97
--- /dev/null
+++ b/collects/guibuilder/canvas.ss
@@ -0,0 +1,155 @@
+
+(module canvas mzscheme
+  (require (prefix mred: (lib "mred.ss" "mred"))
+	   (lib "class.ss")
+	   (lib "file.ss")
+	   (lib "pretty.ss")
+	   (lib "etc.ss")
+	   (lib "list.ss")
+	   "utils.ss"
+	   "base.ss"
+	   "feature.ss")
+
+  (define gb:make-canvas-hscroll-checkable-snip%
+    (lambda (cl)
+      (class (gb:make-boolean-configure-snip% cl 'hscroll "Horizontal Scroll" #t
+					      void void)
+	(inherit get-tagged-value)
+	(public*
+	 [get-hscroll
+	  (lambda () (get-tagged-value 'hscroll))])
+	(super-new))))
+
+  (define gb:make-canvas-vscroll-checkable-snip%
+    (lambda (cl)
+      (class (gb:make-boolean-configure-snip% cl 'vscroll "Vertical Scroll" #t
+					      void void)
+	(inherit get-tagged-value)
+	(public*
+	 [get-vscroll
+	  (lambda () (get-tagged-value 'vscroll))])
+	(super-new))))
+
+  (define gb:make-sb-box-snip%
+    (lambda (cl item-kind)
+      (class cl
+	(inherit-field w h)
+	(inherit get-hscroll get-vscroll)
+	(field
+	  [sb-width 10]
+	  [canvas-min-space 15])
+	(override*
+	 [get-frame%
+	  (lambda ()
+	    (class (super get-frame%)
+	     (override*
+	      [get-kind (lambda () item-kind)])
+	     (super-new)))]
+	 [init-x-stretch? (lambda () #t)]
+	 [init-y-stretch? (lambda () #t)]
+	 [gb-get-min-size
+	  (lambda (dc)
+	    (values (+ sb-width canvas-min-space)
+		    (+ sb-width canvas-min-space)))]
+	 [draw
+	  (lambda (dc x y . other)
+	    (send dc draw-rectangle x y w h)
+	    (when (get-vscroll)
+	      (send dc draw-line 
+		    (+ x w (- sb-width)) y
+		    (+ x w (- sb-width)) (+ y h -1)))
+	    (when (get-hscroll)
+	      (send dc draw-line
+		    x (+ y h (- sb-width))
+		    (+ x w -1) (+ y h (- sb-width)))))])
+	(super-new))))
+
+  (define gb:make-canvas-snip%
+    (lambda (cl cn)
+      (class cl
+	(inherit get-hscroll get-vscroll gb-get-instantiate-class-getter)
+	(override*
+	  [gb-get-style
+	   (lambda ()
+	     (append
+	      (super gb-get-style)
+	      (cond
+	       [(and (get-hscroll) (get-vscroll)) '(hscroll vscroll)]
+	       [(get-hscroll) '(hscroll)]
+	       [(get-vscroll) '(vscroll)]
+	       [else null])))]
+	  [get-classname (lambda () cn)]
+	  [init-name (lambda () (new-name "canvas"))]
+	  
+	  [gb-get-default-class (lambda () 'canvas%)])
+	(super-new))))
+	  
+  (define gb:canvas-snip% (gb:make-canvas-snip%
+			   (gb:make-sb-box-snip%
+			    (gb:make-canvas-vscroll-checkable-snip%
+			     (gb:make-canvas-hscroll-checkable-snip%
+			      gb:atomic-snip%))
+			    "Canvas")
+			   "gb:canvas"))
+  
+  (register-class gb:canvas-snip% "gb:canvas")
+
+  (define gb:make-ecanvas-hscroll-select-snip%
+    (lambda (cl)
+      (class (gb:make-select-configure-snip% cl 'hscroll "Horizontal Scroll"
+					     '("Show" "Hide" "No Scrolling"))
+	(inherit get-tagged-value)
+	(public*
+	  [get-hscroll
+	   (lambda () (zero? (get-hscroll-val)))]
+	  [get-hscroll-val
+	   (lambda () (get-tagged-value 'hscroll))])
+	(super-new))))
+
+  (define gb:make-ecanvas-vscroll-select-snip%
+    (lambda (cl)
+      (class (gb:make-select-configure-snip% cl 'vscroll "Vertical Scroll"
+					     '("Show" "Hide" "No Scrolling"))
+	(inherit get-tagged-value)
+	(public*
+	  [get-vscroll
+	   (lambda () (zero? (get-vscroll-val)))]
+	  [get-vscroll-val
+	   (lambda () (get-tagged-value 'vscroll))])
+	(super-new))))
+
+  (define gb:make-editor-canvas-snip%
+    (lambda (cl cn)
+      (class cl
+	(inherit get-hscroll-val get-vscroll-val)
+	(override*
+	  [get-classname (lambda () cn)]
+	  [init-name (lambda () (new-name "ecanvas"))]
+	  
+	  [gb-get-default-class (lambda () 'editor-canvas%)]
+	  [gb-get-style
+	   (lambda ()
+	     (append
+	      (super gb-get-style)
+	      (case (get-hscroll-val)
+		[(0) null]
+		[(1) '(hide-hscroll)]
+		[(2) '(no-hscroll)])
+	      (case (get-vscroll-val)
+		[(0) ()]
+		[(1) '(hide-vscroll)]
+		[(2) '(no-vscroll)])))])
+	(super-new))))
+	  
+  (define gb:editor-canvas-snip% (gb:make-editor-canvas-snip%
+				 (gb:make-sb-box-snip%
+				  (gb:make-ecanvas-vscroll-select-snip%
+				   (gb:make-ecanvas-hscroll-select-snip%
+				    gb:atomic-snip%))
+				  "Editor Canvas")
+				 "gb:editor-canvas"))
+  
+  (register-class gb:editor-canvas-snip% "gb:editor-canvas")
+
+  (provide gb:canvas-snip%
+	   gb:editor-canvas-snip%))
diff --git a/collects/guibuilder/canvas.xpm b/collects/guibuilder/canvas.xpm
new file mode 100644
index 0000000000..23190d8c73
--- /dev/null
+++ b/collects/guibuilder/canvas.xpm
@@ -0,0 +1,22 @@
+/* XPM */
+static char * canvas_xpm[] = {
+"16 16 3 1",
+" 	c #FFFFFFFFFFFF",
+".	c #A0A0A0A0A0A0",
+"X	c #000000000000",
+"                ",
+" .............. ",
+" . XXX      . . ",
+" .X   X     . . ",
+" .X XXXXX   . . ",
+" .X X X X   . . ",
+" . XXX  X   . . ",
+" .  XXXXX   . . ",
+" .       X  . . ",
+" .       XX . . ",
+" .       XXX. . ",
+" .       XXXX . ",
+" ........XXX... ",
+" .         XX . ",
+" ...........X.. ",
+"                "};
diff --git a/collects/guibuilder/checkbox.xpm b/collects/guibuilder/checkbox.xpm
new file mode 100644
index 0000000000..6c7c069af4
--- /dev/null
+++ b/collects/guibuilder/checkbox.xpm
@@ -0,0 +1,22 @@
+/* XPM */
+static char * checkbox_xpm[] = {
+"16 16 3 1",
+" 	c #FFFFFFFFFFFF",
+".	c #000000000000",
+"X	c #A0A0A0A0A0A0",
+"                ",
+"                ",
+"                ",
+"                ",
+"                ",
+"                ",
+" ....           ",
+" .  . XXXXXXXXX ",
+" .  . XXXXXXXXX ",
+" ....           ",
+"                ",
+"                ",
+"                ",
+"                ",
+"                ",
+"                "};
diff --git a/collects/guibuilder/choice.xpm b/collects/guibuilder/choice.xpm
new file mode 100644
index 0000000000..b35ebcfa40
Binary files /dev/null and b/collects/guibuilder/choice.xpm differ
diff --git a/collects/guibuilder/doc.txt b/collects/guibuilder/doc.txt
new file mode 100644
index 0000000000..dc7fb28b65
--- /dev/null
+++ b/collects/guibuilder/doc.txt
@@ -0,0 +1,12 @@
+
+_GUI builder_
+
+To run the GUI builder, use DrScheme and select "Insert GUI"
+from the "Special" menu.
+
+Though less recommended, you can also run
+
+  (require (lib "guibuilder.ss" "guibuilder"))
+
+to get a stand-alone builder. Save your files with the extension
+".gui" to ensure that they can be re-loaded later.
diff --git a/collects/guibuilder/feature.ss b/collects/guibuilder/feature.ss
new file mode 100644
index 0000000000..64ee77027e
--- /dev/null
+++ b/collects/guibuilder/feature.ss
@@ -0,0 +1,353 @@
+
+(module feature mzscheme
+  (require (prefix mred: (lib "mred.ss" "mred"))
+	   (lib "class.ss")
+	   (lib "file.ss")
+	   (lib "pretty.ss")
+	   (lib "etc.ss")
+	   (lib "list.ss")
+	   "base.ss"
+	   "utils.ss")
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; Mixins for GUI features
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (define gb:make-text-label-snip%
+    (lambda (cl deflabel)
+      (class cl
+	(inherit get-style gb-need-recalc-size)
+	(override*
+	  [get-frame%
+	   (lambda ()
+	     (class (super get-frame%)
+	       (inherit-field controls)
+	       (override*
+		 [get-kind (lambda () deflabel)])
+	       (super-new)
+	       (private-field
+		 [label-buffer (make-one-line/callback-edit controls "Label:"
+							    (lambda (txt)
+							      (set! label txt)
+							      (gb-need-recalc-size))
+							    label)])))]
+	  [gb-instantiate-arguments
+	   (lambda ()
+	     `(,@(super gb-instantiate-arguments)
+	       [label ,(get-label)]))])
+	(field
+	  [label deflabel])
+	(public*
+	  [get-label
+	   (lambda ()
+	     label)]
+	  [get-label-size
+	   (lambda (dc)
+	     (let-values ([(w h d a) (send dc get-text-extent label 
+					   (send (get-style) get-font))])
+	       (values w h)))]
+	  [draw-label
+	   (lambda (dc x y)
+	     (send dc draw-text label x y))]
+	  
+	  [label-install
+	   (lambda (n)
+	     (set! label n))])
+	(override*
+	  [copy
+	   (lambda ()
+	     (let ([o (super copy)])
+	       (send o label-install label)
+	       o))]
+	  [write
+	   (lambda (stream)
+	     (super write stream)
+	     (send stream put (string->bytes/utf-8 label)))]
+	  [read
+	   (lambda (stream version)
+	     (super read stream version)
+	     (label-install ((get-bytes->string version) (send stream get-bytes))))])
+	(super-new))))
+
+  (define gb:make-callback-snip%
+    (lambda (cl)
+      (class cl
+	(inherit-field name)
+	(public*
+	  [get-callback-kinds (lambda () (list "-callback"))]
+	  [get-callback-code (lambda ()
+			       (map (lambda (x) '(lambda (w e) (void))) (get-callback-kinds)))]
+	  [get-callback-names
+	   (lambda ()
+	     (map
+	      (lambda (ct)
+		(string->symbol (string-append name ct)))
+	      (get-callback-kinds)))]
+	  [gb-get-unified-callback
+	   (lambda ()
+	     `(lambda (b e) (,(car (get-callback-names)) b e)))])
+	(override*
+	  [gb-instantiate-arguments
+	   (lambda ()
+	     `(,@(super gb-instantiate-arguments)
+	       [callback ,(gb-get-unified-callback)]))]
+	  [gb-aux-instantiate
+	   (lambda (mode)
+	     (append
+	      (if (or (output-mode-as-class? mode)
+		      (output-mode-no-free-vars? mode))
+		  (map (lambda (n c) 
+			 (if (output-mode-as-class? mode)
+			     `(public* [,n ,c])
+			     `(define ,n ,c)))
+		       (get-callback-names) (get-callback-code))
+		  null)
+	      (super gb-aux-instantiate mode)))])
+	(super-new))))
+  
+  (define gb:make-text-labelled-snip%
+    (lambda (cl deflabel)
+      (class (gb:make-text-label-snip% cl deflabel)
+	(inherit-field w h)
+	(inherit get-label-size draw-label gb-need-recalc-size)
+	(private-field
+	  [hmargin 2]
+	  [vertical-label? (init-vertical-label?)])
+	(public*
+	  [get-label-top-margin (lambda () 0)]
+	  [init-vertical-label? (lambda () #f)]
+
+	  [get-min-body-size
+	   (lambda (dc)
+	     (values 0 0))]
+	  [draw-body
+	   (lambda (dc x y w h)
+	     (void))]
+	  
+	  [labelpos-install
+	   (lambda (vert?)
+	     (set! vertical-label? vert?))])
+	(override*
+	  [get-frame%
+	   (lambda ()
+	     (class (super get-frame%)
+	       (inherit-field controls)
+	       (super-new)
+	       (private-field
+		 [direction-radio
+		  (make-object mred:radio-box% "Label Position:" '("Top" "Left")
+			       controls 
+			       (lambda (r e)
+				 (set! vertical-label? (zero? (send direction-radio get-selection)))
+				 (gb-need-recalc-size))
+			       '(horizontal))])
+	       (send direction-radio set-selection (if vertical-label? 0 1))))]
+	  [gb-get-min-size
+	   (lambda (dc)
+	     (let-values ([(x y) (get-label-size dc)]
+			  [(x2 y2) (get-min-body-size dc)]
+			  [(+x +y) (if vertical-label?
+				       (values max +)
+				       (values (lambda (a b) (+ a b hmargin)) max))])
+	       (values (+x x x2) (+y (+ y (get-label-top-margin)) y2))))]
+	  [draw
+	   (lambda (dc x y . other)
+	     (draw-label dc x (+ y (get-label-top-margin)))
+	     (let*-values ([(lw lh) (get-label-size dc)]
+			   [(dx dy) (if vertical-label?
+					(values 0 lh)
+					(values (+ lw hmargin) 0))])
+	       (with-clipping-region dc (+ x dx) (+ y dy) (- w dx) (- h dy)
+		 (lambda ()
+		   (draw-body dc (+ x dx) (+ y dy) (- w dx) (- h dy))))))]
+	  
+	  [gb-get-style
+	   (lambda ()
+	     (cons (if vertical-label?
+		       'vertical-label
+		       'horizontal-label)
+		   (super gb-get-style)))]
+
+	  [copy
+	   (lambda ()
+	     (let ([o (super copy)])
+	       (send o labelpos-install vertical-label?)
+	       o))]
+	  [write
+	   (lambda (stream)
+	     (super write stream)
+	     (send stream put (if vertical-label? 1 0)))]
+	  [read
+	   (lambda (stream version)
+	     (super read stream version)
+	     (labelpos-install (positive? (send stream get-exact))))])
+	(super-new))))
+
+
+  
+  (define gb:make-layout-snip%
+    (lambda (cl)
+      (class cl
+	(inherit gb-need-recalc-size)
+	(override*
+	  [get-frame%
+	   (lambda ()
+	     (class (super get-frame%)
+	       (inherit-field controls)
+	       (super-new)
+	       (private-field
+		 [layout-direction-radio
+		  (make-object mred:radio-box%
+			       "Layout:"
+			       '("Vertical" "Horizontal")
+			       controls 
+			       (lambda (r e)
+				 (set! vertical-layout? 
+				       (zero? (send layout-direction-radio get-selection)))
+				 (gb-need-recalc-size))
+			       '(horizontal))])
+	       (send layout-direction-radio set-selection (if vertical-layout? 0 1))))])
+	(field
+	  [vertical-layout? (init-vertical-layout?)])
+	(public*
+	  [init-vertical-layout? (lambda () #t)]
+	  [layout-install
+	   (lambda (vert?)
+	     (set! vertical-layout? vert?))])
+	(override*
+	 [gb-get-style
+	  (lambda ()
+	    (cons (if vertical-layout?
+		      'vertical
+		      'horizontal)
+		  (super gb-get-style)))]
+	 [copy
+	  (lambda ()
+	    (let ([o (super copy)])
+	      (send o layout-install vertical-layout?)
+	      o))]
+	 [write
+	  (lambda (stream)
+	    (super write stream)
+	    (send stream put (if vertical-layout? 1 0)))]
+	 [read
+	  (lambda (stream version)
+	    (super read stream version)
+	    (layout-install (positive? (send stream get-exact))))])
+	(super-new))))
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; Mixins for configuration options
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (define gb:make-configure-snip%
+    (lambda (cl tag init)
+      (class cl
+	(private-field
+	  [v init])
+	(override*
+	  [get-tagged-value
+	   (lambda (t)
+	     (if (eq? t tag)
+		 v
+		 (super get-tagged-value t)))]
+	  [set-tagged-value
+	   (lambda (t v-in)
+	     (if (eq? t tag)
+		 (set! v v-in)
+		 (super set-tagged-value t v-in)))]
+
+	  [copy
+	   (lambda ()
+	     (let ([o (super copy)])
+	       (send o set-tagged-value tag v)
+	       o))])
+	(super-new))))
+
+  (define gb:make-boolean-configure-snip%
+    (lambda (cl tag label init change-cb init-cb)
+      (class (gb:make-configure-snip% cl tag init)
+	(inherit gb-need-recalc-size get-tagged-value set-tagged-value)
+	(override*
+	  [get-frame%
+	   (lambda ()
+	     (define this-snip this)
+	     (class (super get-frame%)
+	       (inherit-field controls)
+	       (override*
+		[find-control
+		 (lambda (t)
+		   (if (eq? t tag)
+		       c
+		       (super find-control t)))])
+	       (super-new)
+	       (private-field
+		 [c (make-object mred:check-box% 
+				 label controls
+				 (lambda (c e)
+				   (set-tagged-value tag (send c get-value))
+				   (change-cb this this-snip)
+				   (gb-need-recalc-size)))])
+	       (send c set-value (get-tagged-value tag))
+	       (init-cb this this-snip)))]
+	  [write
+	   (lambda (stream)
+	     (super write stream)
+	     (send stream put (if (get-tagged-value tag) 1 0)))]
+	  [read
+	   (lambda (stream version)
+	     (super read stream version)
+	     (set-tagged-value tag (positive? (send stream get-exact))))])
+	(super-new))))
+
+  (define gb:make-multi-checkable-snip%
+    (lambda (cl)
+      (class (gb:make-boolean-configure-snip% cl 'multi "Multiple Lines" #f
+						  (lambda (f snip)
+						    (send snip multi-changed f))
+						  void)
+	 (inherit get-tagged-value)
+	 (public*
+	  [get-multi
+	   (lambda () (get-tagged-value 'multi))]
+	  [multi-changed
+	   (lambda (f)
+	     (send (send f find-control 'hscroll) enable (get-multi)))])
+	 (super-new))))
+  
+  (define gb:make-select-configure-snip%
+    (lambda (cl tag label choices)
+      (class (gb:make-configure-snip% cl tag 0)
+	(inherit gb-need-recalc-size get-tagged-value set-tagged-value)
+	(override*
+	  [get-frame%
+	   (lambda ()
+	     (class (super get-frame%)
+	       (inherit-field controls)
+	       (super-new)
+	       (private-field
+		 [c (make-object mred:choice% 
+				 label choices controls
+				 (lambda (c e)
+				   (set-tagged-value tag (send c get-selection))
+				   (gb-need-recalc-size)))])
+	       (send c set-selection (get-tagged-value tag))))]
+	  [write
+	   (lambda (stream)
+	     (super write stream)
+	     (send stream put (get-tagged-value tag)))]
+	  [read
+	   (lambda (stream version)
+	     (super read stream version)
+	     (set-tagged-value tag (send stream get-exact)))])
+	(super-new))))
+  
+  (provide gb:make-text-label-snip%
+	   gb:make-callback-snip%
+	   gb:make-text-labelled-snip%
+	   gb:make-layout-snip%
+
+	   gb:make-configure-snip%
+	   gb:make-boolean-configure-snip%
+	   gb:make-multi-checkable-snip%
+	   gb:make-select-configure-snip%))
diff --git a/collects/guibuilder/gauge.xpm b/collects/guibuilder/gauge.xpm
new file mode 100644
index 0000000000..6cf9facade
Binary files /dev/null and b/collects/guibuilder/gauge.xpm differ
diff --git a/collects/guibuilder/guibuilder.ss b/collects/guibuilder/guibuilder.ss
new file mode 100644
index 0000000000..8354a647ab
--- /dev/null
+++ b/collects/guibuilder/guibuilder.ss
@@ -0,0 +1,101 @@
+
+(module guibuilder mzscheme
+  (require (prefix mred: (lib "mred.ss" "mred"))
+	   (lib "class.ss")
+	   (lib "file.ss")
+	   (lib "pretty.ss")
+	   (lib "etc.ss")
+	   (lib "list.ss")
+	   (prefix framework: (lib "framework.ss" "framework"))
+	   "utils.ss"
+	   "top-level.ss"
+	   "toolbar.ss")
+
+  ;; These modules implement snips for the various
+  ;;  kinds of windows and controls.
+  (require "base.ss"
+	   "panel.ss"
+	   "simple-control.ss"
+	   "text-field.ss"
+	   "multiple-choice.ss"
+	   "slider-guage.ss"
+	   "canvas.ss")
+  
+  (define my-base-frame% framework:frame:editor%)
+
+  (define gb:frame%
+    (class my-base-frame% 
+      (init [file #f])
+      (inherit get-editor show get-area-container get-menu-bar)
+
+      (define gb-editor #f)
+      (define (get-gb-editor)
+	gb-editor)
+
+      (override*	
+	[get-editor% (lambda () 
+		       (class framework:text:info%
+			 (inherit insert)
+			 (super-new)
+			 (set! gb-editor (new gb:edit%))
+			 (insert (make-object mred:editor-snip% gb-editor))))])
+      
+      (define toolbar #f)
+      (public*
+	[init-tools
+	 (lambda (mb)
+	   (set! toolbar (make-object toolbar% (get-area-container)))
+	   (send (get-area-container) change-children
+		 (lambda (l)
+		   (cons toolbar (remove toolbar l))))
+	   
+	   (let* ([emenu (make-object mred:menu% "Element" mb)]
+		  [vmenu (make-object mred:menu% "Output" mb)])
+	     (make-object mred:menu-item% "Configure Selected" emenu
+			  (lambda (i e)
+			    (send (get-gb-editor)
+				  for-each-selected-snip
+				  (lambda (s)
+				    (send s gb-open-dialog)))))
+	     (make-object mred:separator-menu-item% emenu)
+	     (add-tools toolbar emenu (lambda (c%) (insert-element c%)))
+
+	     (make-object mred:menu-item% "Configure Output"  vmenu
+			  (lambda (i e) (send (get-gb-editor) open-dialog)))
+	     (make-object mred:separator-menu-item% vmenu)
+	     (make-object mred:menu-item%  "Make Sample Window" vmenu 
+			  (lambda (i e) (send (get-gb-editor) instantiate)))
+	     (make-object mred:menu-item%  "Make Source Code" vmenu 
+			  (lambda (i e) (send (get-gb-editor) view-source)))))]
+	[insert-element
+	 (lambda (c%)
+	   (let ([e (get-gb-editor)])
+	     (send e insert-element c%)))])
+
+      (super-make-object (or file "GUI Builder"))
+
+      (init-tools (get-menu-bar))
+      
+      (let ([file (and file (normalize-path file))])
+	(if (and file (file-exists? file) (send (get-gb-editor) load-file file))
+	    ;; Force title size calc:
+	    (let ([e (get-gb-editor)])
+	      (send e get-main-location 
+		    (send e get-main-panel)
+		    (send (send e get-canvas) get-dc)
+		    (box 0) (box 0)))
+	    (begin
+	      (send (get-gb-editor) create-main-panel)
+	      (when file
+		(send (get-gb-editor) set-filename file)))))
+      
+      (show #t)))
+  
+  (framework:handler:insert-format-handler "GUI Builder" "gui"
+					   (lambda (file)
+					     (make-object gb:frame% file)))
+  
+  (define (new-gui-builder-frame) (new gb:frame% [height 400]))
+					       
+
+  (new-gui-builder-frame))
diff --git a/collects/guibuilder/help.mre b/collects/guibuilder/help.mre
new file mode 100644
index 0000000000..e08669e2f1
--- /dev/null
+++ b/collects/guibuilder/help.mre
@@ -0,0 +1 @@
+(The help document has not been written.)
diff --git a/collects/guibuilder/hpanel.xpm b/collects/guibuilder/hpanel.xpm
new file mode 100644
index 0000000000..06c1d12b5f
--- /dev/null
+++ b/collects/guibuilder/hpanel.xpm
@@ -0,0 +1,22 @@
+/* XPM */
+static char * hpanel_xpm[] = {
+"16 16 3 1",
+" 	c #FFFFFFFFFFFF",
+".	c #000000000000",
+"X	c #A0A0A0A0A0A0",
+"                ",
+"                ",
+"                ",
+" .............. ",
+" .            . ",
+" .            . ",
+" .  X  XX  X  . ",
+" .  X  XX  X  . ",
+" .  X  XX  X  . ",
+" .  X  XX  X  . ",
+" .            . ",
+" .            . ",
+" .............. ",
+"                ",
+"                ",
+"                "};
diff --git a/collects/guibuilder/info.ss b/collects/guibuilder/info.ss
new file mode 100644
index 0000000000..96c788cbd7
--- /dev/null
+++ b/collects/guibuilder/info.ss
@@ -0,0 +1,5 @@
+
+(module info (lib "infotab.ss" "setup")
+  (define doc.txt "doc.txt")
+  (define name "GUI Builder")
+  (define tools (list (list "tool.ss"))))
diff --git a/collects/guibuilder/list.xpm b/collects/guibuilder/list.xpm
new file mode 100644
index 0000000000..1e2f1c089a
--- /dev/null
+++ b/collects/guibuilder/list.xpm
@@ -0,0 +1,22 @@
+/* XPM */
+static char * list_xpm[] = {
+"16 16 3 1",
+" 	c #FFFFFFFFFFFF",
+".	c #000000000000",
+"X	c #A0A0A0A0A0A0",
+"                ",
+"                ",
+"  ............  ",
+"  .        . .  ",
+"  .  XXXX  . .  ",
+"  .        . .  ",
+"  .  XXXX  . .  ",
+"  .        . .  ",
+"  .  XXXX  . .  ",
+"  .        . .  ",
+"  .  XXXX  . .  ",
+"  .        . .  ",
+"  .        . .  ",
+"  ............  ",
+"                ",
+"                "};
diff --git a/collects/guibuilder/mcanvas.xpm b/collects/guibuilder/mcanvas.xpm
new file mode 100644
index 0000000000..3884e01d2d
--- /dev/null
+++ b/collects/guibuilder/mcanvas.xpm
@@ -0,0 +1,22 @@
+/* XPM */
+static char * mcanvas_xpm[] = {
+"16 16 3 1",
+" 	c #FFFFFFFFFFFF",
+".	c #A0A0A0A0A0A0",
+"X	c #000000000000",
+"                ",
+" .............. ",
+" .          . . ",
+" . XXXXX X X. . ",
+" . X X X  X . . ",
+" .   X    X . . ",
+" .   X    X . . ",
+" .  XXX   X . . ",
+" .        X . . ",
+" .        X . . ",
+" .       X X. . ",
+" .          . . ",
+" .............. ",
+" .          . . ",
+" .............. ",
+"                "};
diff --git a/collects/guibuilder/message.xpm b/collects/guibuilder/message.xpm
new file mode 100644
index 0000000000..a9deeccb27
--- /dev/null
+++ b/collects/guibuilder/message.xpm
@@ -0,0 +1,21 @@
+/* XPM */
+static char * message_xpm[] = {
+"16 16 2 1",
+" 	c #FFFFFFFFFFFF",
+".	c #000000000000",
+"                ",
+"                ",
+"                ",
+"                ",
+"                ",
+"     ......     ",
+"     . .. .     ",
+"       ..       ",
+"       ..       ",
+"       ..       ",
+"      ....      ",
+"                ",
+"                ",
+"                ",
+"                ",
+"                "};
diff --git a/collects/guibuilder/multiple-choice.ss b/collects/guibuilder/multiple-choice.ss
new file mode 100644
index 0000000000..acba6222db
--- /dev/null
+++ b/collects/guibuilder/multiple-choice.ss
@@ -0,0 +1,266 @@
+
+(module multiple-choice mzscheme
+  (require (prefix mred: (lib "mred.ss" "mred"))
+	   (lib "class.ss")
+	   (lib "file.ss")
+	   (lib "pretty.ss")
+	   (lib "etc.ss")
+	   (lib "list.ss")
+	   "utils.ss"
+	   "base.ss"
+	   "feature.ss")
+  
+  (define gb:make-item-list-snip%
+    (lambda (cl)
+      (class cl
+	(inherit gb-need-recalc-size)
+	(private*
+	  [delete
+	   (lambda (l p)
+	     (let loop ([l l][p p])
+	       (cond
+		 [(null? l) l]
+		 [(zero? p) (cdr l)]
+		 [else (cons (car l) (loop (cdr l) (sub1 p)))])))])
+	(public*
+	  [get-items
+	   (lambda ()
+	     items)]
+	  [init-items (lambda () null)]
+	  [get-item-height
+	   (lambda (dc)
+	     (let-values ([(w h d a) (send dc get-text-extent "Xj")])
+	       h))]
+	  [get-max-item-width
+	   (lambda (dc)
+	     (let loop ([l items][mw 0])
+	       (if (null? l)
+		   mw
+		   (let-values ([(w h d a) (send dc get-text-extent (car l))])
+		     (loop (cdr l) (max mw w))))))]
+	  
+	  [items-install
+	   (lambda (l)
+	     (set! items l))])
+	(override*
+	 [get-frame%
+	  (lambda ()
+	    (class (super get-frame%)
+	      (inherit-field controls)
+	      (super-new)
+	      (public*
+	       [user-item (lambda (v)
+			    (mred:get-text-from-user "Item name:" "List Item Name" #f v))])
+	      (private-field
+		[items-panel (make-object mred:vertical-panel% controls)]
+		[items-list (make-object mred:list-box%
+					 "Items:" 
+					 items
+					 items-panel 
+					 (lambda (l e)
+					   (when (eq? 'list-box-dclick (send e get-event-type))
+					     (let ([pos (send items-list get-selection)])
+					       (unless (negative? pos)
+						 (let ([v (user-item (list-ref items pos))])
+						   (when v
+						     (send items-list set-string pos v)
+						     (set-car! (list-tail items pos) v)
+						     (gb-need-recalc-size))))))))]
+		[item-buttons-panel (let ([v (make-object mred:horizontal-panel% items-panel)])
+				      (send v stretchable-width #f)
+				      v)]
+		[add-item (make-object mred:button% "Add Item" item-buttons-panel
+				       (lambda (b e)
+					 (let ([v (user-item (format 
+							      "Item~a" 
+							      (send items-list get-number)))])
+					   (when v
+					     (send items-list append v)
+					     (set! items (append items (list v)))
+					     (gb-need-recalc-size)))))]
+		[delete-item (make-object mred:button% "Delete Item" item-buttons-panel
+					  (lambda (b e)
+					    (let loop ([ls (reverse (send items-list get-selections))])
+					      (unless (null? ls)
+						(send items-list delete (car ls))
+						(set! items (delete items (car ls)))
+						(loop (cdr ls))))
+					    (gb-need-recalc-size)))])))]
+	  [gb-instantiate-arguments
+	   (lambda ()
+	     (cons
+	      `[choices ',(get-items)]
+	      (super gb-instantiate-arguments)))]
+	  [copy
+	   (lambda ()
+	     (let ([o (super copy)])
+	       (send o items-install items)
+	       o))]
+	  [write
+	   (lambda (stream)
+	     (super write stream)
+	     (stream-write-list stream items))]
+	  [read
+	   (lambda (stream version)
+	     (super read stream version)
+	     (items-install (stream-read-list stream version)))])
+	(private-field
+	  [items (init-items)])
+	(super-new))))
+   
+  (define gb:make-list-box-snip%
+    (lambda (cl cn)
+      (class cl
+	(inherit-field w h)
+	(inherit get-callback-names get-items get-item-height)
+	(field
+	  [min-body-width 50]
+	  [sb-width 10]
+	  [min-item-count 3])
+	(override*
+	  [get-classname (lambda () cn)]
+	  [init-name (lambda () (new-name "listbox"))]
+	  [init-y-stretch? (lambda () #t)]
+	  [init-x-stretch? (lambda () #t)]
+	  [get-min-body-size
+	   (lambda (dc)
+	     (let ([y (get-item-height dc)])
+	       (values min-body-width (* min-item-count y))))]
+	  [draw-body
+	   (lambda (dc x y w h)
+	     (send dc draw-rectangle x y w h)
+	     (send dc draw-line 
+		   (+ w x (- sb-width)) y
+		   (+ w x (- sb-width)) (+ y h))
+	     (with-clipping-region 
+	      dc x y (- w sb-width) h
+	      (lambda ()
+		(let ([ih (get-item-height dc)])
+		  (let loop ([l (get-items)][iy (add1 y)])
+		    (unless (or (>= iy (+ y h)) (null? l))
+		      (send dc draw-text (car l) (+ 2 x) iy)
+		      (loop (cdr l) (+ iy ih))))))))]
+	  [get-callback-kinds (lambda ()
+				(list "-select-callback" "-double-select-callback"))]
+	  [gb-get-default-class (lambda () 'list-box%)]
+	  [gb-get-style
+	   (lambda ()
+	     (cons 'single
+		   (super gb-get-style)))]
+	  [gb-get-unified-callback
+	   (lambda ()
+	     (let-values ([(sel dbl) (apply values (get-callback-names))])
+	       `(lambda (b e) 
+		  (case (send e get-event-type)
+		    [(list-box) (,sel b e)]
+		    [(list-box-dclick) (,dbl b e)]))))])
+	(super-new))))
+  
+  
+  (define gb:list-box-snip% (gb:make-list-box-snip%
+			     (gb:make-item-list-snip%
+			      (gb:make-callback-snip%
+			       (gb:make-text-labelled-snip% gb:atomic-snip% 
+							    "List")))
+			     "gb:listbox"))
+  
+  (register-class gb:list-box-snip% "gb:listbox")
+  
+  
+  (define gb:make-radio-box-snip%
+    (lambda (cl cn)
+      (class cl
+	(inherit-field w h vertical-layout?)
+	(inherit get-item-height get-max-item-width get-items
+		 gb-need-recalc-size)
+	(private-field
+	  [circle-size 10]
+	  [margin 2])
+	(override*
+	  [get-classname (lambda () cn)]
+	  [init-name (lambda () (new-name "radiobox"))]
+	  [init-items (lambda () (list "First" "Second"))]
+	  [get-min-body-size
+	   (lambda (dc)
+	     (let ([h (max (get-item-height dc) circle-size)]
+		   [w (get-max-item-width dc)]
+		   [l (length (get-items))])
+	       (let-values ([(x-l y-l) (if vertical-layout?
+					   (values 1 l)
+					   (values l 1))])
+		 (values (* (+ circle-size margin w) x-l)
+			 (* h y-l)))))]
+	  [draw-body
+	   (lambda (dc x y w h)
+	     (let ([ih (max (get-item-height dc) circle-size)]
+		   [iw (+ (get-max-item-width dc) circle-size margin)])
+	       (let loop ([l (get-items)][iy y][ix x])
+		 (unless (null? l)
+		   (send dc draw-ellipse ix (+ iy (/ (- ih circle-size) 2)) circle-size circle-size)
+		   (send dc draw-text (car l) (+ circle-size margin ix) iy)
+		   (if vertical-layout?
+		       (loop (cdr l) (+ iy ih) ix)
+		       (loop (cdr l) iy (+ ix iw)))))))]
+	  [gb-get-default-class (lambda () 'radio-box%)])
+	(super-new))))
+  
+  
+  (define gb:radio-box-snip% (gb:make-radio-box-snip%
+			      (gb:make-item-list-snip%
+			       (gb:make-layout-snip%
+				(gb:make-callback-snip%
+				 (gb:make-text-labelled-snip% gb:atomic-snip% 
+							      "Radiobox"))))
+			      "gb:radiobox"))
+  
+  (register-class gb:radio-box-snip% "gb:radiobox")
+  
+  
+  (define gb:make-choice-snip%
+    (lambda (cl cn)
+      (class cl
+	(inherit-field w h)
+	(inherit get-item-height get-max-item-width get-items
+		 gb-need-recalc-size)
+	(field
+	  [arrow-size 10]
+	  [lmargin 2]
+	  [amargin 2]
+	  [rmargin 2]
+	  [arrow (list (make-object mred:point% 0 0)
+		       (make-object mred:point% arrow-size 0)
+		       (make-object mred:point% (quotient arrow-size 2) (quotient arrow-size 2)))])
+	(override*
+	  [get-classname (lambda () cn)]
+	  [init-name (lambda () (new-name "choice"))]
+	  [init-items (lambda () (list "First"))]
+	  [get-min-body-size
+	   (lambda (dc)
+	     (let ([h (get-item-height dc)]
+		   [w (get-max-item-width dc)])
+	       (values (+ lmargin arrow-size amargin w rmargin 3) (+ 3 h))))]
+	  [draw-body
+	   (lambda (dc x y w h)
+	     (send dc draw-rectangle x y (sub1 w) (sub1 h))
+	     (send dc draw-line (sub1 (+ x w)) (add1 y) (sub1 (+ x w)) (+ y h))
+	     (send dc draw-line (add1 x) (sub1 (+ y h)) (+ x w) (sub1 (+ y h)))
+	     (send dc draw-polygon arrow (+ 1 lmargin x) (+ y (/ (- h (/ arrow-size 2)) 2)))
+	     (let ([l (get-items)])
+	       (unless (null? l)
+		 (send dc draw-text (car l) (+ 1 lmargin arrow-size amargin x) (add1 y)))))]
+	  [gb-get-default-class (lambda () 'choice%)])
+	(super-new))))
+  
+  
+  (define gb:choice-snip% (gb:make-choice-snip%
+			   (gb:make-item-list-snip%
+			    (gb:make-callback-snip%
+			     (gb:make-text-labelled-snip% gb:atomic-snip% 
+							  "Choice")))
+			   "gb:choice"))
+  
+  (register-class gb:choice-snip% "gb:choice")
+  
+  (provide gb:list-box-snip%
+	   gb:radio-box-snip%
+	   gb:choice-snip%))
diff --git a/collects/guibuilder/panel.ss b/collects/guibuilder/panel.ss
new file mode 100644
index 0000000000..547c5a49ba
--- /dev/null
+++ b/collects/guibuilder/panel.ss
@@ -0,0 +1,158 @@
+
+(module panel mzscheme
+  (require (prefix mred: (lib "mred.ss" "mred"))
+	   (lib "class.ss")
+	   (lib "file.ss")
+	   (lib "pretty.ss")
+	   (lib "etc.ss")
+	   (lib "list.ss")
+	   "utils.ss"
+	   "base.ss")
+
+  (define gb:make-panel-params-snip%
+    (lambda (cl)
+      (class cl
+	(inherit-field horizontal-child-alignment
+		       vertical-child-alignment
+		       with-border?)
+	(inherit set-horizontal-child-alignment
+		 set-vertical-child-alignment
+		 set-with-border
+		 gb-need-recalc-size)
+	(override*
+	 [get-frame%
+	  (lambda ()
+	    (class (super get-frame%)
+	      (inherit-field controls)
+	      (super-new)
+	      (field
+		[hca-choice
+		 (make-object mred:choice%
+			      "Horizontal Align Children:"
+			      '("Left" "Center" "Right")
+			      controls 
+			      (lambda (r e)
+				(set-horizontal-child-alignment
+				 (add1 (send r get-selection)))
+				(gb-need-recalc-size)))]
+		[vca-choice
+		 (make-object mred:choice% 
+			      "Vertical Align Children:"
+			      '("Top" "Center" "Bottom")
+			      controls 
+			      (lambda (r e)
+				(set-vertical-child-alignment
+				 (add1 (send r get-selection)))
+				(gb-need-recalc-size)))]
+		[border-check
+		 (make-object mred:check-box%
+			      "Show Border" controls
+			      (lambda (c e)
+				(set-with-border (send c get-value))
+				(gb-need-recalc-size)))])
+	      (send hca-choice stretchable-width #f)
+	      (send hca-choice set-selection (sub1 horizontal-child-alignment))
+	      (send vca-choice stretchable-width #f)
+	      (send vca-choice set-selection (sub1 vertical-child-alignment))
+	      (send border-check set-value with-border?)))])
+	(private*
+	  [symbol-append
+	   (lambda (a b) (string->symbol (string-append (symbol->string a) (symbol->string b))))])
+	(override*
+	 [gb-instantiate-arguments
+	  (lambda ()
+	    `(,@(super gb-instantiate-arguments)
+	      [alignment '(,(case horizontal-child-alignment
+			      [(1) 'left]
+			      [(2) 'center]
+			      [(3) 'right])
+			   ,(case horizontal-child-alignment
+			      [(1) 'top]
+			      [(2) 'center]
+			      [(3) 'bottom]))]))])
+	(super-new))))
+
+  (define gb:vertical-panel-snip% 
+    (class (gb:make-panel-params-snip% gb:snip%)
+      (override*
+	[get-classname (lambda () "gb:vertical-panel")]
+	[init-name (lambda () (new-name "vpanel"))])
+      (super-new)))
+  
+  (register-class gb:vertical-panel-snip% "gb:vertical-panel")
+
+  ; Used by top-level panel:
+  (define gb:panel-snip%
+    (class gb:vertical-panel-snip%
+      (override*
+	[get-classname (lambda () "gb:panel")])
+      (super-new)))
+  
+  (register-class gb:panel-snip% "gb:panel")
+  
+  (define gb:horizontal-panel-snip%
+    (class (gb:make-panel-params-snip% gb:snip%)
+      (inherit-field horizontal-child-alignment vertical-child-alignment
+		     children)
+      (inherit spacing-+)
+      (override*
+	[get-classname (lambda () "gb:horizontal-panel")]
+	[init-name (lambda () (new-name "hpanel"))]
+	
+	(gb-get-child-x-start
+	 (lambda (mw mh w h)
+	   (if (or (= horizontal-child-alignment 1)
+		   (ormap (lambda (c) (gb-x-stretch? c)) children))
+	       0
+	       (case horizontal-child-alignment
+		 [(2) (/ (- w mw) 2)]
+		 [(3) (- w mw)]))))
+	(gb-get-child-y-start
+	 (lambda (mw mh w h) 
+	   0))
+
+	(gb-combine-child-width (lambda (a b) (spacing-+ a b)))
+	(gb-combine-child-height (lambda (a b) (max a b)))
+	
+	(gb-compute-child-x-pos
+	 (lambda (dc c w)
+	   0))
+	(gb-compute-child-y-pos
+	 (lambda (dc c h)
+	   (if (gb-y-stretch? c)
+	       0
+	       (case vertical-child-alignment
+		 [(2) (let-values ([(cw ch) (send c gb-get-min-size dc)])
+			 (/ (- h ch) 2))]
+		 [(1) 0]
+		 [(3) (let-values ([(cw ch) (send c gb-get-min-size dc)])
+			 (- h ch))]))))
+	(gb-compute-child-width
+	 (lambda (dc c w xsc dw)
+	   (let-values ([(cw ch) (send c gb-get-min-size dc)])
+	     (if (gb-x-stretch? c)
+		 (+ cw (/ dw xsc))
+		 cw))))
+	(gb-compute-child-height
+	 (lambda (dc c h ysc dh)
+	   (if (gb-y-stretch? c)
+	       h
+	       (let-values ([(cw ch) (send c gb-get-min-size dc)])
+		 ch))))
+	
+	(gb-combine-child-x-offset (lambda (a b) (spacing-+ a b)))
+	(gb-combine-child-y-offset (lambda (a b) a))
+	
+	(find-position-<
+	 (lambda (fx fy cx cy)
+	   (< fx cx)))
+	
+	[gb-get-default-class (lambda () 'horizontal-panel%)])
+      (super-new)))
+
+  (register-class gb:horizontal-panel-snip% "gb:horizontal-panel")
+
+  (provide gb:make-panel-params-snip%
+	   gb:vertical-panel-snip% 
+	   gb:panel-snip%
+	   gb:horizontal-panel-snip%))
diff --git a/collects/guibuilder/radiobox.xpm b/collects/guibuilder/radiobox.xpm
new file mode 100644
index 0000000000..a1d40da9a2
--- /dev/null
+++ b/collects/guibuilder/radiobox.xpm
@@ -0,0 +1,23 @@
+/* XPM */
+static char * radiobox_xpm[] = {
+"16 16 4 1",
+" 	c #FFFFFFFFFFFF",
+".	c #000000000000",
+"X	c #A0A0A0A0A0A0",
+"o	c #A0A0A0A0A0A0",
+"                ",
+"                ",
+"                ",
+"  ..            ",
+" .XX. ooooooooo ",
+" .XX. ooooooooo ",
+"  ..            ",
+"                ",
+"                ",
+"  ..            ",
+" .  . ooooooooo ",
+" .  . ooooooooo ",
+"  ..            ",
+"                ",
+"                ",
+"                "};
diff --git a/collects/guibuilder/readable.ss b/collects/guibuilder/readable.ss
new file mode 100644
index 0000000000..f1f4bba332
--- /dev/null
+++ b/collects/guibuilder/readable.ss
@@ -0,0 +1,54 @@
+
+(module readable mzscheme
+  (require (lib "mred.ss" "mred")
+           (lib "class.ss")
+	   "top-level.ss"
+	   "toolbar.ss")
+
+  (define gui-snip-class%
+    (class snip-class%
+      (inherit set-classname set-version)
+
+      (define/override (read f)
+	(let ([e (make-object gb:edit%)])
+	  (send e prepare-to-load)
+	  (send e read-from-file f)
+	  (send e done-loading #t)
+	  (make-object gui-code-snip% e)))
+
+      (super-new)
+      (set-classname "(lib \"readable.ss\" \"guibuilder\")")
+      (set-version 1)))
+
+  (define gui-snip-class (new gui-snip-class%))
+
+  (send (get-the-snip-class-list) add gui-snip-class)
+
+
+  (define gui-code-snip%
+    (class* editor-snip% (readable-snip<%>)
+      (inherit get-editor set-min-width set-min-height set-snipclass get-admin)
+
+      (define/public (read-special source line column position)
+	(send (get-editor) build-code #f #f))
+
+      (define/override (write f)
+	(send (get-editor) write-to-file f))
+      (define/override (copy)
+	(make-object gui-code-snip% (send (get-editor) copy-self)))
+
+      (define/override (on-event dc x y editorx editory e)
+	(if (send e button-down? 'right)
+	    (let ([tool-menu (make-object popup-menu%)])
+	      (add-tools #f tool-menu (lambda (c%)
+					(send (get-editor) insert-element c%)))
+	      (send (get-admin) popup-menu 
+		    tool-menu this 
+		    (- (send e get-x) x)
+		    (- (send e get-y) y)))
+	    (super on-event dc x y editorx editory e)))
+
+      (super-new)
+      (set-snipclass gui-snip-class)))
+
+  (provide gui-code-snip%))
diff --git a/collects/guibuilder/simple-control.ss b/collects/guibuilder/simple-control.ss
new file mode 100644
index 0000000000..bb54e9d2eb
--- /dev/null
+++ b/collects/guibuilder/simple-control.ss
@@ -0,0 +1,102 @@
+
+(module simple-control mzscheme
+  (require (prefix mred: (lib "mred.ss" "mred"))
+	   (lib "class.ss")
+	   (lib "file.ss")
+	   (lib "pretty.ss")
+	   (lib "etc.ss")
+	   (lib "list.ss")
+	   "utils.ss"
+	   "base.ss"
+	   "feature.ss")
+
+  (define gb:make-message-snip%
+    (lambda (cl cn)
+      (class cl
+	(inherit-field w h)
+	(inherit get-label get-label-size draw-label)
+	(override*
+	  [get-classname (lambda () cn)]
+	  [init-name (lambda () (new-name "message"))]
+	  [gb-get-min-size
+	   (lambda (dc)
+	     (get-label-size dc))]
+	  [draw
+	   (lambda (dc x y . other)
+	     (draw-label dc x y))]
+	  [gb-get-default-class (lambda () 'message%)])
+	(super-new))))
+  
+  (define gb:message-snip% (gb:make-message-snip%
+			    (gb:make-text-label-snip% gb:atomic-snip% 
+						      "Message")
+			    "gb:message"))
+  
+  (register-class gb:message-snip% "gb:message")
+  
+  (define gb:make-button-snip%
+    (lambda (cl cn)
+      (class cl
+	(inherit-field w h)
+	(inherit get-label get-label-size get-callback-names draw-label)
+	(private-field
+	  [m 5])
+	(override*
+	  [get-classname (lambda () cn)]
+	  [init-name (lambda () (new-name "button"))]
+	  [gb-get-min-size
+	   (lambda (dc)
+	     (let-values ([(x y) (get-label-size dc)])
+	       (values (+ (* 2 m) x) (+ (* 2 m) y))))]
+	  [draw
+	   (lambda (dc x y . other)
+	     (send dc draw-rounded-rectangle x y w h 3)
+	     (let-values ([(lw lh) (get-label-size dc)])
+	       (draw-label dc 
+			   (+ (+ x m) (/ (- w lw (* 2 m)) 2))
+			   (+ (+ y m) (/ (- h lh (* 2 m)) 2)))))]
+	  [gb-get-default-class (lambda () 'button%)])
+	(super-new))))
+  
+  (define gb:make-check-box-snip%
+    (lambda (cl cn)
+      (class cl
+	(inherit-field w h)
+	(inherit get-style get-label get-callback-names get-label-size draw-label)
+	(private-field
+	  [hspace 2]
+	  [boxsize 12])
+	(override*
+	  [get-classname (lambda () cn)]
+	  [init-name (lambda () (new-name "checkbox"))]
+	  [gb-get-min-size
+	   (lambda (dc)
+	     (let-values ([(x y) (get-label-size dc)])
+	       (values (+ boxsize hspace x) (max boxsize y))))]
+	  [draw
+	   (lambda (dc x y . other)
+	     (let-values ([(lx ly) (get-label-size dc)])
+	       (send dc draw-rectangle x (+ y (/ (- h boxsize) 2)) boxsize boxsize)
+	       (draw-label dc (+ x boxsize hspace) (+ y (/ (- h ly) 2)))))]
+	  [gb-get-default-class (lambda () 'check-box%)])
+	(super-new))))
+  
+  (define gb:button-snip% (gb:make-button-snip%
+			   (gb:make-callback-snip%
+			    (gb:make-text-label-snip% gb:atomic-snip% 
+						      "Button"))
+			   "gb:button"))
+  
+  (define gb:check-box-snip% (gb:make-check-box-snip%
+			      (gb:make-callback-snip%
+			       (gb:make-text-label-snip% gb:atomic-snip% 
+							 "Checkbox"))
+			      "gb:checkbox"))
+  
+  (register-class gb:button-snip% "gb:button")
+  (register-class gb:check-box-snip% "gb:checkbox")
+  
+
+  (provide gb:message-snip%
+	   gb:button-snip%
+	   gb:check-box-snip%))
diff --git a/collects/guibuilder/slider-guage.ss b/collects/guibuilder/slider-guage.ss
new file mode 100644
index 0000000000..fc587e54eb
--- /dev/null
+++ b/collects/guibuilder/slider-guage.ss
@@ -0,0 +1,193 @@
+
+(module slider-guage mzscheme
+  (require (prefix mred: (lib "mred.ss" "mred"))
+	   (lib "class.ss")
+	   (lib "file.ss")
+	   (lib "pretty.ss")
+	   (lib "etc.ss")
+	   (lib "list.ss")
+	   "utils.ss"
+	   "base.ss"
+	   "feature.ss")
+    
+  (define gb:make-slider-snip%
+    (lambda (cl cn)
+      (class cl
+	(inherit-field vertical-layout?)
+	(inherit get-label get-callback-names gb-need-recalc-size)
+	(field
+	  [init-value 0]
+	  [min-value 0]
+	  [max-value 10]
+	  [arrow-size 10]
+	  [height arrow-size]
+	  [line-height 3]
+	  [min-width 50]
+	  [darrow (list (make-object mred:point% 0 0)
+			(make-object mred:point% arrow-size 0)
+			(make-object mred:point% (quotient arrow-size 2) (quotient arrow-size 2)))]
+	  [rarrow (list (make-object mred:point% 0 0)
+			(make-object mred:point% 0 arrow-size)
+			(make-object mred:point% (quotient arrow-size 2) (quotient arrow-size 2)))])
+	(public*
+	  [slider-install
+	   (lambda (mn mx in)
+	     (set! min-value mn)
+	     (set! max-value mx)
+	     (set! init-value in))])
+	(override*
+	  [get-frame%
+	   (lambda ()
+	     (class (super get-frame%)
+	       (inherit-field controls)
+	       (super-new)
+	       (private-field
+		 [min-val (make-number-control controls "Minimum:" 0 (lambda () -10000) (lambda () 10000) 
+					       (lambda (x) 
+						 (set! min-value x) 
+						 (send max-val check)
+						 (send init-val check)
+						 (gb-need-recalc-size)))]
+		 [max-val (make-number-control controls "Maximum:" 10 (lambda () (send min-val get-val)) (lambda () 10000)
+					       (lambda (x)
+						 (set! max-value x)
+						 (send init-val check)
+						 (gb-need-recalc-size)))]
+		 [init-val (make-number-control controls "Initial:" 0 (lambda () (send min-val get-val)) 
+						(lambda () (send max-val get-val))
+						(lambda (x)
+						  (set! init-value x)
+						  (gb-need-recalc-size)))])))]
+	  [get-classname (lambda () cn)]
+	  [init-name (lambda () (new-name "slider"))]
+	  [init-vertical-layout? (lambda () #f)]
+	  [get-min-body-size
+	   (lambda (dc)
+	     (if vertical-layout?
+		 (values height min-width)
+		 (values min-width height)))]
+	  [draw-body
+	   (lambda (dc x y w h)
+	     (let ([percent (/ (- init-value min-value) (- max-value min-value))])
+	       (if vertical-layout?
+		   (begin
+		     (send dc draw-rectangle 
+			   (+ x (/ arrow-size 2)) (+ y (/ arrow-size 2))
+			   line-height (- h arrow-size))
+		     (send dc draw-polygon rarrow x (+ y (* percent (- h arrow-size)))))
+		   (begin
+		     (send dc draw-rectangle 
+			   (+ x (/ arrow-size 2)) (+ y (/ arrow-size 2)) 
+			   (- w arrow-size) line-height)
+		     (send dc draw-polygon darrow (+ x (* percent (- w arrow-size))) y)))))]
+	  [gb-get-default-class (lambda () 'slider%)]
+	  [gb-instantiate-arguments
+	   (lambda ()
+	     (list*
+	      `[min-value ,min-value]
+	      `[max-value ,max-value]
+	      `[init-value ,init-value]
+	      (super gb-instantiate-arguments)))]
+	  
+	  [copy
+	   (lambda ()
+	     (let ([o (super copy)])
+	       (send o slider-install min-value max-value init-value)
+	       o))]
+	  [write
+	   (lambda (stream)
+	     (super write stream)
+	     (send stream put min-value)
+	     (send stream put max-value)
+	     (send stream put init-value))]
+	  [read
+	   (lambda (stream version)
+	     (super read stream version)
+	     (slider-install (send stream get-exact)
+			     (send stream get-exact)
+			     (send stream get-exact)))])
+	(super-new))))
+  
+  (define gb:slider-snip% (gb:make-slider-snip%
+			   (gb:make-layout-snip%
+			    (gb:make-callback-snip%
+			     (gb:make-text-labelled-snip% gb:atomic-snip% 
+							  "Slider")))
+			   "gb:slider"))
+  
+  (register-class gb:slider-snip% "gb:slider")
+  
+  (define gb:make-gauge-snip%
+    (lambda (cl cn)
+      (class cl
+	(inherit-field vertical-layout?)
+	(inherit get-label gb-need-recalc-size)
+	(field
+	  [max-value 10]
+	  [min-height 10]
+	  [min-width 50])
+	(public*
+	  [gauge-install
+	   (lambda (mx)
+	     (set! max-value mx))])
+	(override*
+	  [get-frame%
+	   (lambda ()
+	     (class (super get-frame%)
+	       (inherit-field controls)
+	       (super-new)
+	       (private-field
+		 [max-val (make-number-control controls "Maximum:" 10 (lambda () 1) (lambda () 10000) 
+					       (lambda (x) 
+						 (set! max-value x) 
+						 (gb-need-recalc-size)))])))]
+	  [get-classname (lambda () cn)]
+	  [init-name (lambda () (new-name "gauge"))]
+	  [init-vertical-layout? (lambda () #f)]
+	  [get-min-body-size
+	   (lambda (dc)
+	     (if vertical-layout?
+		 (values min-height min-width)
+		 (values min-width min-height)))]
+	  [draw-body
+	   (lambda (dc x y w h)
+	     (send dc draw-rectangle x y w h)
+	     (let ([b (send dc get-brush)])
+	       (send dc set-brush (send mred:the-brush-list find-or-create-brush "BLACK" 'solid))
+	       (send dc draw-rectangle 
+		     x (if vertical-layout? (+ y (* 0.75 h)) y)
+		     (if vertical-layout? w (* 0.25 w)) (if vertical-layout? (* 0.25 h) h))
+	       (send dc set-brush b)))]
+	  [gb-get-default-class (lambda () 'gauge%)]
+	  [gb-instantiate-arguments
+	   (lambda ()
+	     (list*
+	      `[range ,max-value]
+	      (super gb-instantiate-arguments)))]
+	  
+	  [copy
+	   (lambda ()
+	     (let ([o (super copy)])
+	       (send o gauge-install max-value)
+	       o))]
+	  [write
+	   (lambda (stream)
+	     (super write stream)
+	     (send stream put max-value))]
+	  [read
+	   (lambda (stream version)
+	     (super read stream version)
+	     (gauge-install (send stream get-exact)))])
+	(super-new))))
+  
+  (define gb:gauge-snip% (gb:make-gauge-snip%
+			  (gb:make-layout-snip%
+			   (gb:make-text-labelled-snip% gb:atomic-snip% 
+							"Gauge"))
+			  "gb:gauge"))
+  
+  (register-class gb:gauge-snip% "gb:gauge")
+
+
+  (provide gb:slider-snip%
+	   gb:gauge-snip%))
diff --git a/collects/guibuilder/slider.xpm b/collects/guibuilder/slider.xpm
new file mode 100644
index 0000000000..7ce320b5ca
Binary files /dev/null and b/collects/guibuilder/slider.xpm differ
diff --git a/collects/guibuilder/text-field.ss b/collects/guibuilder/text-field.ss
new file mode 100644
index 0000000000..b651423c86
--- /dev/null
+++ b/collects/guibuilder/text-field.ss
@@ -0,0 +1,136 @@
+
+(module text-field mzscheme
+  (require (prefix mred: (lib "mred.ss" "mred"))
+	   (lib "class.ss")
+	   (lib "file.ss")
+	   (lib "pretty.ss")
+	   (lib "etc.ss")
+	   (lib "list.ss")
+	   "utils.ss"
+	   "base.ss"
+	   "feature.ss")
+
+  (define gb:make-text-initial-snip%
+    (lambda (cl)
+      (class cl
+	(inherit gb-need-recalc-size get-style)
+	(private-field
+	  [initial "value"])
+	(public*
+	  [get-initial (lambda () initial)]
+	  [get-initial-size
+	   (lambda (dc)
+	     (let-values ([(w h d a) (send dc get-text-extent initial
+					   (send (get-style) get-font))])
+	       (values w h)))]
+
+	  [initial-install
+	   (lambda (i)
+	     (set! initial i))])
+	(override*
+	  [get-frame%
+	   (lambda ()
+	     (class (super get-frame%)
+	       (inherit-field controls)
+	       (super-new)
+	       (private-field
+		 [initial-text
+		  (make-one-line/callback-edit controls "Initial:"
+					       (lambda (txt)
+						 (set! initial txt)
+						 (gb-need-recalc-size))
+					       initial)])))]
+
+	  [copy
+	   (lambda ()
+	     (let ([o (super copy)])
+	       (send o initial-install initial)
+	       o))]
+	  [write
+	   (lambda (stream)
+	     (super write stream)
+	     (send stream put (string->bytes/utf-8 initial)))]
+	  [read
+	   (lambda (stream version)
+	     (super read stream version)
+	     (initial-install ((get-bytes->string version) (send stream get-bytes))))])
+	(super-new))))
+
+  (define gb:make-text-hscroll-checkable-snip%
+    (lambda (cl)
+      (class (gb:make-boolean-configure-snip% cl 'hscroll "Horizontal Scroll" #f 
+					      void
+					      (lambda (f snip)
+						(send (send f find-control 'hscroll)
+						      enable
+						      (send snip get-tagged-value 'multi))))
+	(inherit get-tagged-value)
+	(override*
+	  [gb-get-style
+	   (lambda () 
+	     (append
+	      (if (get-tagged-value 'hscroll)
+		  '(hscroll)
+		  null)
+	      (super gb-get-style)))])
+	(super-new))))
+  
+  (define gb:make-text-snip%
+    (lambda (cl cn)
+      (class cl
+	(inherit-field w h)
+	(inherit get-initial-size get-initial
+		 get-callback-names get-multi
+		 get-label)
+	(private-field
+	  [margin 2])
+	(override*
+	  [get-classname (lambda () cn)]
+	  [init-name (lambda () (new-name "text"))]
+	  [init-x-stretch? (lambda () #t)]
+	  [get-label-top-margin (lambda () margin)]
+	  [get-min-body-size
+	   (lambda (dc)
+	     (let-values ([(w h) (get-initial-size dc)])
+		(values (+ w (* 2 margin))
+			(+ (* h (if (get-multi) 3 1))
+			   (* 2 margin)))))]
+	  [draw-body
+	   (lambda (dc x y w h)
+	     (send dc draw-rectangle x y w h)
+	     (send dc draw-text (get-initial) (+ x margin) (+ y margin)))]
+	  [get-callback-kinds (lambda ()
+				(list "-change-callback" "-return-callback" "-focus-callback"))]
+	  [gb-get-default-class (lambda () 'text-field%)]
+	  [gb-get-style (lambda () (append
+				    (super gb-get-style)
+				    (if (get-multi) '(multiple) '(single))))]
+	  [gb-get-unified-callback
+	   (lambda ()
+	     (let-values ([(change return focus) 
+			   (apply values (get-callback-names))])
+	       `(lambda (b e) 
+		  (let ([t (send e get-event-type)])
+		    (cond 
+		     [(eq? t 'text-field) (,change b e)]
+		     [(eq? t 'text-field-enter) (,return b e)]
+		     [else (,focus b e)])))))]
+	  [gb-instantiate-arguments
+	   (lambda ()
+	     (cons
+	      `[init-value ,(get-initial)]
+	      (super gb-instantiate-arguments)))])
+	(super-new))))
+  
+  (define gb:text-snip% (gb:make-text-snip%
+			 (gb:make-text-hscroll-checkable-snip%
+			  (gb:make-multi-checkable-snip%
+			   (gb:make-text-initial-snip%
+			    (gb:make-callback-snip%
+			     (gb:make-text-labelled-snip% gb:atomic-snip% 
+							  "Text")))))
+			 "gb:text"))
+  
+  (register-class gb:text-snip% "gb:text")
+  
+  (provide gb:text-snip%))
diff --git a/collects/guibuilder/text.xpm b/collects/guibuilder/text.xpm
new file mode 100644
index 0000000000..89c53bcc46
--- /dev/null
+++ b/collects/guibuilder/text.xpm
@@ -0,0 +1,22 @@
+/* XPM */
+static char * text_xpm[] = {
+"16 16 3 1",
+" 	c #FFFFFFFFFFFF",
+".	c #000000000000",
+"X	c #A0A0A0A0A0A0",
+"                ",
+"          . .   ",
+"           .    ",
+"  XXXXXXXXX.XX  ",
+"  X        . X  ",
+"  X ...... . X  ",
+"  X . .. . . X  ",
+"  X   ..   . X  ",
+"  X   ..   . X  ",
+"  X   ..  . .X  ",
+"  X  ....    X  ",
+"  X          X  ",
+"  XXXXXXXXXXXX  ",
+"                ",
+"                ",
+"                "};
diff --git a/collects/guibuilder/tool.ss b/collects/guibuilder/tool.ss
new file mode 100644
index 0000000000..82330fdaf4
--- /dev/null
+++ b/collects/guibuilder/tool.ss
@@ -0,0 +1,69 @@
+
+(module tool mzscheme
+  (require (lib "tool.ss" "drscheme")
+           (lib "mred.ss" "mred")
+           (lib "unitsig.ss")
+           (lib "class.ss")
+	   (lib "string-constant.ss" "string-constants")
+	   "top-level.ss"
+	   "toolbar.ss"
+	   "readable.ss")
+
+  (provide tool@)
+
+  (define tool@
+    (unit/sig drscheme:tool-exports^
+      (import drscheme:tool^)
+      
+      (define (phase1) (void))
+      (define (phase2) 
+	(drscheme:get/extend:extend-unit-frame 
+	 (lambda (drs:frame%)
+	   (class drs:frame%
+	     (inherit get-special-menu get-edit-target-object)
+
+	     (define toolbar #f)
+	     (define toolbar-shown? #f)
+
+	     (define/override (get-definitions/interactions-panel-parent)
+	       (let ([p (super get-definitions/interactions-panel-parent)])
+		 (set! toolbar (new toolbar% [parent p][style '(deleted)]))
+		 (add-tools toolbar #f
+			    (lambda (c%) 
+			      (let ([e (get-edit-target-object)])
+				(if (e . is-a? . gb:edit%)
+				    (send e insert-element c%)
+				    (message-box 
+				     (string-constant gui-tool-heading)
+				     (string-constant gui-tool-before-clicking-message)
+				     this
+				     '(ok stop))))))
+		 (new vertical-panel% (parent p))))
+
+	     (define/override (add-show-menu-items menu)
+	       (super add-show-menu-items menu)
+	       (make-object menu-item% 
+			    (string-constant gui-tool-show-gui-toolbar)
+			    menu
+			    (lambda (i e)
+			      (let ([p (send toolbar get-parent)])
+				(if toolbar-shown?
+				    (send p delete-child toolbar)
+				    (send p change-children (lambda (l)
+							      (cons toolbar l))))
+				(set! toolbar-shown? (not toolbar-shown?))
+				(send i set-label (if toolbar-shown?
+						      (string-constant gui-tool-hide-gui-toolbar)
+						      (string-constant gui-tool-show-gui-toolbar)))))))
+
+	     (super-new)
+
+	     (make-object menu-item% (string-constant gui-tool-insert-gui) (get-special-menu)
+			  (lambda (b e)
+			    (let ([e (get-edit-target-object)])
+			      (when e
+				(let* ([gb (make-object gb:edit%)]
+				       [s (make-object gui-code-snip% gb)])
+				  (send e insert s)
+				  (send gb create-main-panel)
+				  (send gb set-caret-owner #f 'display)))))))))))))
diff --git a/collects/guibuilder/toolbar.ss b/collects/guibuilder/toolbar.ss
new file mode 100644
index 0000000000..2217037201
--- /dev/null
+++ b/collects/guibuilder/toolbar.ss
@@ -0,0 +1,159 @@
+
+(module toolbar mzscheme
+  (require (prefix mred: (lib "mred.ss" "mred"))
+	   (lib "class.ss")
+	   (lib "file.ss")
+	   (lib "pretty.ss")
+	   (lib "etc.ss")
+	   (lib "list.ss")
+	   "utils.ss")
+
+  ;; These modules implement snips for the various
+  ;;  kinds of windows and controls.
+  (require "base.ss"
+	   "panel.ss"
+	   "simple-control.ss"
+	   "text-field.ss"
+	   "multiple-choice.ss"
+	   "slider-guage.ss"
+	   "canvas.ss")
+  
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; Frame
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  
+  (define-struct tool (icon callback active?))
+
+  (define lg-pen (send mred:the-pen-list find-or-create-pen 
+		       (make-object mred:color% 200 200 200) 0 'solid))
+
+  (define dg-pen (send mred:the-pen-list find-or-create-pen 
+		       (make-object mred:color% 140 140 140) 0 'solid))
+
+  (define icons (make-hash-table))
+
+  (define toolbar%
+    (class mred:canvas%
+      (inherit min-height stretchable-height get-dc)
+      (private-field
+       [margin 2]
+       [icon-size 16]
+       [tools null]
+       [active-tool #f])
+      (private*
+       [deactivate-tool
+	(lambda ()
+	  (when active-tool
+		(set-tool-active?! active-tool #f)
+		(set! active-tool #f)
+		(on-paint)))]
+       [activate-tool
+	(lambda (mx my only)
+	  (let ([y 0]
+		[h (+ icon-size (* 2 margin))]
+		[w (+ icon-size (* 2 margin))])
+	    (let loop ([l tools][x 0])
+	      (unless (null? l)
+		 (if (and (<= x mx (+ x w)) (<= y my (+ y h))
+			  (or (not only) (eq? (car l) only)))
+		     (begin
+		       (set! active-tool (car l))
+		       (set-tool-active?! active-tool #t)
+		       (on-paint))
+		     (loop (cdr l) (+ x w)))))))])
+      (private-field
+       [can-drag #f])
+      (override*
+       [on-paint
+	(lambda ()
+	  (let ([dc (get-dc)]
+		[y 0]
+		[h (+ icon-size (* 2 margin))]
+		[w (+ icon-size (* 2 margin))])
+	    (let loop ([l tools][x 0])
+	      (unless (null? l)
+		(let ([tool (car l)])
+		  (let ([p (send dc get-pen)]
+			[on? (tool-active? tool)])
+		    (send dc set-pen (if on? dg-pen lg-pen))
+		    (send dc draw-line x y (+ x w -1) y)
+		    (send dc draw-line x y x (+ y h -1))
+		    (send dc draw-line x (add1 y) (+ x w -2) (add1 y))
+		    (send dc draw-line (add1 x) y (add1 x) (+ y h -2))
+		    (send dc set-pen (if on? lg-pen dg-pen))
+		    (send dc draw-line (+ x 1) (+ y h -1) (+ x w -1) (+ y h -1))
+		    (send dc draw-line (+ x w -1) (+ y 1) (+ x w -1) (+ y h -1))
+		    (send dc draw-line (+ x 2) (+ y h -2) (+ x w -2) (+ y h -2))
+		    (send dc draw-line (+ x w -2) (+ y 2) (+ x w -2) (+ y h -2))
+		    (send dc set-pen p))
+		  (if (tool-icon tool)
+		      (send dc draw-bitmap (tool-icon tool) (+ x margin) margin)
+		      (send dc draw-rectangle (+ x margin) margin icon-size icon-size)))
+		(loop (cdr l) (+ x w))))))]
+       [on-event
+	(lambda (e)
+	  (cond
+	   [(send e button-down?)
+	    (deactivate-tool)
+	    (activate-tool (send e get-x) (send e get-y) #f)
+	    (set! can-drag active-tool)]
+	   [(send e button-up?)
+	    (set! can-drag #f)
+	    (when active-tool
+		  (let ([cb (tool-callback active-tool)])
+		    (deactivate-tool)
+		    (cb #f #f)))]
+	   [(send e dragging?)
+	    (when can-drag
+		  (let ([old-active active-tool])
+		    (set! active-tool #f)
+		    (activate-tool (send e get-x) (send e get-y) can-drag)
+		    (when (and (not active-tool) old-active)
+			  (set-tool-active?! old-active #f)
+			  (on-paint))))]
+	   [else (set! can-drag #f) 
+		 (deactivate-tool)]))])
+      (public*
+       [append-tool
+	(lambda (icon-name cb)
+	  (let* ([name (string->symbol icon-name)]
+		 [icon
+		  (hash-table-get 
+		   icons name
+		   (lambda ()
+		     (let* ([icon (make-object mred:bitmap% 
+					       (build-path (collection-path "guibuilder") 
+							   icon-name))])
+		       (if (send icon ok?) 
+			   icon
+			   #f))))])
+	    (hash-table-put! icons name icon)
+	    (set! tools (append tools (list (make-tool icon cb #f))))))])
+      (super-new)
+      (min-height (+ icon-size (* margin 2)))
+      (stretchable-height #f)))
+
+  (define (add-tools toolbar emenu insert-element)
+    (let* ([append-element-type
+	    (lambda (name icon c%)
+	      (let ([maker (lambda (i e) (insert-element c%))])
+		(when toolbar
+		  (send toolbar append-tool icon maker))
+		(when emenu
+		  (make-object mred:menu-item% name emenu maker))))])
+      (append-element-type "New Vertical Panel" "vpanel.xpm" gb:vertical-panel-snip%)
+      (append-element-type "New Horizontal Panel" "hpanel.xpm" gb:horizontal-panel-snip%)
+      (append-element-type "New Message Label" "message.xpm" gb:message-snip%)
+      (append-element-type "New Button" "button.xpm" gb:button-snip%)
+      (append-element-type "New Checkbox" "checkbox.xpm" gb:check-box-snip%)
+      (append-element-type "New Text Field" "text.xpm" gb:text-snip%)
+      (append-element-type "New List" "list.xpm" gb:list-box-snip%)
+      (append-element-type "New Radiobox" "radiobox.xpm" gb:radio-box-snip%)
+      (append-element-type "New Choice" "choice.xpm" gb:choice-snip%)
+      (append-element-type "New Slider" "slider.xpm" gb:slider-snip%)
+      (append-element-type "New Gauge" "gauge.xpm" gb:gauge-snip%)
+      (append-element-type "New Canvas" "canvas.xpm" gb:canvas-snip%)
+      (append-element-type "New Editor Canvas" "mcanvas.xpm" gb:editor-canvas-snip%)))
+
+  (provide toolbar%
+	   add-tools))
diff --git a/collects/guibuilder/top-level.ss b/collects/guibuilder/top-level.ss
new file mode 100644
index 0000000000..3a34e10af6
--- /dev/null
+++ b/collects/guibuilder/top-level.ss
@@ -0,0 +1,629 @@
+
+(module top-level mzscheme
+  (require (prefix mred: (lib "mred.ss" "mred"))
+	   (lib "class.ss")
+	   (lib "file.ss")
+	   (lib "pretty.ss")
+	   (lib "etc.ss")
+	   (lib "list.ss")
+	   (prefix framework: (lib "framework.ss" "framework"))
+	   "utils.ss"
+	   "base.ss"
+	   "panel.ss")
+  
+  ;; INVARIANT: If a snip is selected, then no ancestor or
+  ;;  decendent of the snip can be selected. Otherwise, the
+  ;;  dragging rules get complicated (perhaps impossible).
+  
+  ;; INVARIANT: a child must be ordered before its parent in the
+  ;;  pasteboard. Not only does this affect drawing, but it also
+  ;;  affects how select-all and rubber-banding work due to the
+  ;;  ancestor/decendent-selection-exclusion rule.
+  
+  (define START-FRAME-WIDTH 100)
+  (define START-FRAME-HEIGHT 100)
+
+  ;; Keep in order of choice items:
+  (define FRAME-MODE 0)
+  (define DIALOG-MODE 1)
+  (define PANEL-MODE 2)
+
+  (define -FIRST-MODE- FRAME-MODE)
+  (define -LAST-MODE- PANEL-MODE)
+
+  (define top-font (send mred:the-font-list find-or-create-font 
+			 12 'default 'normal 'normal #f))
+
+  (define gb:edit%
+    (class mred:pasteboard%
+      (inherit set-selected find-next-selected-snip insert
+	       find-first-snip is-selected? add-selected remove-selected
+	       get-admin find-snip begin-edit-sequence end-edit-sequence
+	       get-snip-location delete erase set-modified resize
+	       invalidate-bitmap-cache
+	       begin-write-header-footer-to-file end-write-header-footer-to-file
+	       get-keymap)
+      (private-field 
+	[dragging? #f]
+	[pasting? #f]
+	[copying? #f]
+	[cur-hilite #f]
+	[cur-hilite-pos 0]
+	[cur-id 1]
+	[last-empty-click -inf.0])
+      (public*
+	[new-id (lambda () 
+		  (begin0 
+		    (number->string cur-id)
+		    (set! cur-id (add1 cur-id))))]
+	[for-each-snip
+	 (lambda (f)
+	   (let loop ([s (find-first-snip)])
+	     (when s
+	       (f s)
+	       (loop (send s next)))))]
+	[for-each-selected-snip
+	 (lambda (f)
+	   (let loop ([s (find-next-selected-snip #f)])
+	     (when s
+	       (f s)
+	       (loop (find-next-selected-snip s)))))]
+	[in-selected-hierarchy?
+	 (lambda (s)
+	   (or (is-selected? s)
+	       (let ([parent (send s gb-get-parent)])
+		 (and parent
+		      (in-selected-hierarchy? parent)))))]
+	[find-unselected-snip
+	 (lambda (x y)
+	   (let ([s (find-snip x y)])
+	     (if (or (not s) (and (not (in-selected-hierarchy? s))
+				  (send s container?)))
+		 s
+		 (let loop ([s (find-first-snip)])
+		   (cond
+		     [(not s) #f]
+		     [(and (send s container?)
+			   (not (in-selected-hierarchy? s)))
+		      (let ([tb (box 0)]
+			    [lb (box 0)]
+			    [bb (box 0)]
+			    [rb (box 0)])
+			(get-snip-location s lb tb #f)
+			(get-snip-location s rb bb #t)
+			(if (and (<= (unbox lb) x (unbox rb))
+				 (<= (unbox tb) y (unbox bb)))
+			    s
+			    (loop (send s next))))]
+		     [else (loop (send s next))])))))]
+	[find-snip-by-XXX
+	 (lambda (id get)
+	   (let/ec found
+	     (for-each-snip
+	      (lambda (s)
+		(when (equal? id (get s))
+		  (found s))))
+	     #f))]
+	[find-snip-by-id
+	 (lambda (id)
+	   (find-snip-by-XXX id (gb-id)))]
+	[find-snip-by-original-id
+	 (lambda (id)
+	   (find-snip-by-XXX id gb-original-id))]
+	[find-snip-by-name
+	 (lambda (id)
+	   (find-snip-by-XXX id gb-name))]
+
+	[top-resized
+	 (lambda (snip old-w old-h w h)
+	   (when (eq? snip main-panel)
+		 (unless (= top-level-type PANEL-MODE)
+			 (invalidate-bitmap-cache 0 0
+						  (+ (max old-w w) (* 2 margin))
+						  (+ (max old-h h) (* 2 margin)
+						     (or frame-label-h 0) 2)))))])
+
+      (augment*
+	[can-move-to?
+	 (lambda (snip x y dragging?)
+	   (or (not (eq? snip main-panel))
+	       (and (= x main-panel-x)
+		    (= y main-panel-y))))]
+	[after-move-to
+	 (lambda (snip x y dragging?)
+	   (when dragging?
+	     (send snip gb-drag-children-along x y)))]
+	[after-resize
+	 (lambda (snip w h did?)
+	   (when (and (eq? snip main-panel) did?)
+		 (unless (= top-level-type PANEL-MODE)
+			 (invalidate-bitmap-cache 
+			  0 0 last-frame-paint-w last-frame-paint-h))))]
+	[on-interactive-move
+	 (lambda (e)
+	   (set! dragging? #t)
+	   (for-each-snip (lambda (s) (send s gb-set-stable-position)))
+	   (inner (void) on-interactive-move e))]
+	[on-select
+	 (lambda (s on?)
+	   (when (and (not copying?) on?)
+	     ; deselect parents:
+	     (let loop ([p (send s gb-get-parent)])
+	       (when p
+		 (if (is-selected? p)
+		     (remove-selected p)
+		     (loop (send p gb-get-parent)))))
+	     ; deselect children:
+	     (for-each
+	      (lambda (c)
+		(when (is-selected? c)
+		  (remove-selected c)))
+	      (send s gb-get-children))))]
+	[after-interactive-move
+	 (lambda (e)
+	   (set! dragging? #f)
+	   
+	   ;; Adjust parent of selected snips & move selected snip's children
+	   (for-each-selected-snip
+	    (lambda (snip)
+	      (when (not (eq? snip main-panel))
+		(let* ([parent (send snip gb-get-parent)]
+		       [pos (if parent
+				(send parent gb-get-child-pos snip)
+				-1)])
+		  (if cur-hilite
+		      (when (or (not (eq? cur-hilite parent))
+				(not (= pos cur-hilite-pos)))
+			(when parent
+			  (send parent gb-remove-child snip))
+			(send cur-hilite gb-add-child snip cur-hilite-pos)
+			(set! cur-hilite-pos (add1 cur-hilite-pos)))
+		      (when parent
+			(send parent gb-remove-child snip)
+			(send snip gb-install this #f))))
+		(send snip gb-need-recalc-size))))
+	   
+	   (when cur-hilite
+	     (send cur-hilite gb-hilite #f)
+	     (set! cur-hilite #f))
+
+	   (inner (void) after-interactive-move e))])
+      (override*
+	[interactive-adjust-move
+	 (lambda (snip x-box y-box)
+	   (super interactive-adjust-move snip x-box y-box)
+	   ;; The following doesn't really work very well.
+	   #;
+	   (let ([parent (send snip gb-get-parent)])
+	     (when parent
+	       (let-values ([(x y w h) 
+			     (send (let loop ([p parent])
+				     (let ([parent (send p gb-get-parent)])
+				       (if parent
+					   (loop parent)
+					   p)))
+				   gb-get-position-and-size)])
+		 (when (and (<= x (unbox x-box) (+ x w))
+			    (<= y (unbox y-box) (+ y h)))
+		   (set-box! x-box (send snip gb-get-stable-x))
+		   (set-box! y-box (send snip gb-get-stable-y)))))))]
+	[interactive-adjust-resize
+	 (lambda (snip wb hb)
+	   (super interactive-adjust-resize snip wb hb)
+	   (let-values ([(x-min y-min) (send snip gb-get-saved-min-size)])
+	     (when (or (not (gb-x-stretch? snip))
+		       (<= (unbox wb) x-min))
+	       (set-box! wb x-min))
+	     (when (or (not (gb-y-stretch? snip))
+		       (<= (unbox hb) y-min))
+	       (set-box! hb y-min))))])
+      (augment*
+	[after-interactive-resize
+	 (lambda (snip)
+	   (inner (void) after-interactive-resize snip)
+	   (send snip gb-need-recalc-size))])
+      (override*
+	[on-default-event
+	 (lambda (e)
+	   (unless dragging?
+	     (when (send e button-down?)
+	       (unless (find-next-selected-snip #f)
+		 (when ((- (send e get-time-stamp) last-empty-click) 
+			. < . 
+			(send (get-keymap) get-double-click-interval))
+		   (open-dialog))
+		 (set! last-empty-click (send e get-time-stamp)))))
+	   (when dragging?
+	     (let ([x (send e get-x)]
+		   [y (send e get-y)]
+		   [xb (box 0)]
+		   [yb (box 0)])
+	       (send (get-admin) get-dc xb yb)
+	       (let ([lx (+ x (unbox xb))]
+		     [ly (+ y (unbox yb))])
+		 (let ([s (find-unselected-snip lx ly)])
+		   (when s
+		     (set! cur-hilite-pos (send s gb-find-position lx ly)))
+		   (when (and (or cur-hilite s)
+			      (not (eq? cur-hilite s)))
+		     (begin-edit-sequence)
+		     (when cur-hilite
+		       (send cur-hilite gb-hilite #f)
+		       (set! cur-hilite #f))
+		     (when s
+		       (set! cur-hilite s)
+		       (send s gb-hilite #t))
+		     (end-edit-sequence))))))
+	   (super on-default-event e))]
+	[on-double-click
+	 (lambda (snip e)
+	   (send snip gb-open-dialog))])
+      (augment*
+	[after-delete
+	 (lambda (snip)
+	   (for-each (lambda (i) (delete i)) (send snip gb-get-children))
+	   (let ([parent (send snip gb-get-parent)])
+	     (when parent
+	       (send parent gb-remove-child snip)))
+	   (inner (void) after-delete snip))]
+	[can-insert?
+	 (lambda (snip before x y)
+	   (is-a? snip gb:snip%))]
+	[after-insert
+	 (lambda (snip behind x y)
+	   (when pasting?
+	     (dynamic-wind
+	      (lambda () (set! pasting? #f))
+	      (lambda () (send snip gb-install this #f))
+	      (lambda () (set! pasting? #t))))
+	   (inner (void) after-insert snip behind x y))])
+      (private*
+        [do-generic-paste
+	 (lambda (time super-call)
+	   (dynamic-wind
+	       (lambda () (set! pasting? #t))
+	       (lambda () (super-call time))
+	       (lambda () (set! pasting? #f)))
+	   (let ([a-paste #f])
+	     (for-each-snip
+	      (lambda (s)
+		(unless a-paste
+		  (let ([oi (gb-original-id s)])
+		    (when oi
+		      (set! a-paste s))))))
+	     (handle-new-arrivals)
+	     (when a-paste
+	       (let ([top-paste (let loop ([a-paste a-paste])
+				  (let ([p (send a-paste gb-get-parent)])
+				    (if p
+					(loop p)
+					a-paste)))])
+		 (send main-panel gb-add-child top-paste)
+		 (set-selected top-paste)))))])
+      (override*
+        [do-paste
+	 (lambda (time)
+	   (do-generic-paste time (lambda (time) (super do-paste time))))]
+	[do-paste-x-selection
+	 (lambda (time)
+	   (do-generic-paste time (lambda (time) (super do-paste-x-selection time))))])
+      (public*
+	[handle-new-arrivals
+	 (lambda ()
+	   (let loop ()
+	     ((let/ec k
+		(for-each-snip 
+		 (lambda (s) 
+		   (when (send s gb-reconnect-to-original-children)
+		     (k loop))))
+		void)))
+	   (for-each-snip (lambda (s) (send s gb-forget-original-id))))])
+      (override*
+	[do-copy
+	 (lambda (time delete?)
+	   (dynamic-wind
+	    (lambda () (set! copying? #t))
+	    (lambda () 
+	      (when (find-next-selected-snip #f)
+		(letrec ([selected
+			  (let loop ([s (find-next-selected-snip #f)])
+			    (let ([next (find-next-selected-snip s)])
+			      (if next
+				  (cons s (loop next))
+				  (list s))))]
+			 [close-selected
+			  (lambda (method)
+			    (lambda (s)
+			      (for-each
+			       (lambda (child)
+				 (method child)
+				 ((close-selected method) child))
+			       (send s gb-get-children))))])
+		  (for-each (close-selected (lambda (x) (add-selected x))) selected)
+		  (super do-copy time delete?)
+		  (for-each (close-selected (lambda (x) (remove-selected x))) selected))))
+	    (lambda () (set! copying? #f))))])
+      (public*
+	[get-selected-snip
+	 (lambda () 
+	   (let ([s (find-next-selected-snip #f)])
+	     (if (or (not s)
+		     (not (find-next-selected-snip s)))
+		 main-panel
+		 s)))]
+	[insert-element
+	 (lambda (c%)
+	   (let* ([i (make-object c%)]
+		  [se (get-selected-snip)]
+		  [s (if (send se container?)
+			 se
+			 (or (gb-parent se)
+			     main-panel))])
+	     (send s gb-add-child i)
+	     (set-selected s)))])
+      (init-field
+       [auto-show? #t]
+       [top-level-type FRAME-MODE]
+       [frame-label "Frame"]
+       [top-name "top"])
+      (private-field
+       [frame-label-w #f]
+       [frame-label-h #f]
+       [last-frame-paint-w 0]
+       [last-frame-paint-h 0]
+       [main-panel-x 0]
+       [main-panel-y 0]
+       [margin 2]
+       [configure-frame #f])
+      (public*
+        [get-top-level-type
+	 (lambda () top-level-type)]
+	[get-auto-show
+	 (lambda () auto-show?)]
+	[get-frame-label
+	 (lambda () frame-label)]
+        [open-dialog
+	 (lambda ()
+	   (unless configure-frame
+	     (set! configure-frame (make-object 
+				    (class mred:frame%
+				       (augment*
+					[on-close
+					 (lambda ()
+					   (set! configure-frame #f)
+					   (inner (void) on-close))])
+				       (super-new))
+				    "Output"))
+	     (let ([p (make-object mred:vertical-panel% configure-frame)])
+	       (send p set-alignment 'left 'center)
+	       (letrec ([update-frame
+			 (lambda ()
+			   (send main-panel gb-need-recalc-size)
+			   (invalidate-bitmap-cache 0 0 'end 'end))]
+			[kind-choice
+			 (make-object mred:choice% 
+				      "Output:" 
+				      '("Frame" "Dialog" "Panel")
+				      p
+				      (lambda (c e)
+					(let ([mode (send c get-selection)])
+					  (set! top-level-type mode)
+					  (send frame-stuff enable (< mode PANEL-MODE))
+					  (update-frame))))]
+			[frame-stuff (make-object mred:vertical-panel% p)]
+			[name-text (make-one-line/callback-edit 
+				    frame-stuff
+				    "Scheme Name:"
+				    (lambda (txt)
+				      (set! top-name txt))
+				    top-name)]
+			[title-text (make-one-line/callback-edit 
+				     frame-stuff
+				     "Frame Title:"
+				     (lambda (txt)
+				       (unless (string=? frame-label txt)
+					       (set! frame-label txt)
+					       (let ([w frame-label-w]
+						     [h frame-label-h])
+						 (set! frame-label-h #f)
+						 (update-frame))))
+				     frame-label)]
+			[auto-show-check (make-object mred:check-box%
+						      "Show Automatically" frame-stuff
+						      (lambda (c e)
+							(set! auto-show? (send c get-value))))])
+		 (send frame-stuff set-alignment 'left 'center)
+		 (send frame-stuff enable (< top-level-type PANEL-MODE))
+		 (send kind-choice stretchable-width #f)
+		 (send kind-choice set-selection top-level-type)
+		 (send auto-show-check set-value auto-show?))))
+	   (send configure-frame show #t))]
+        [get-main-location
+	 (lambda (snip dc dx dy)
+	   (when (eq? snip main-panel)
+		 (if (= top-level-type PANEL-MODE)
+		     (begin
+		       (set! main-panel-x 0)
+		       (set! main-panel-y 0))
+		     (begin
+		       (unless frame-label-h
+			 (let-values ([(w h d a) (send dc get-text-extent
+						       frame-label top-font)])
+			   (set! frame-label-w w)
+			   (set! frame-label-h h)))
+		       (set! main-panel-x margin)
+		       (set! main-panel-y (+ frame-label-h 2 margin))))
+		 (set-box! dx main-panel-x)
+		 (set-box! dy main-panel-y)))])
+      (override*
+	[on-paint
+	 (lambda (pre? dc l t r b dx dy show-caret?)
+	   (unless (or (not pre?) (= top-level-type PANEL-MODE)
+		       (not main-panel))
+	      (let ([tb (box 0)]
+		    [lb (box 0)]
+		    [bb (box 0)]
+		    [rb (box 0)])
+		(get-snip-location main-panel lb tb #f)
+		(get-snip-location main-panel rb bb #t)
+		(let* ([w (- (unbox rb) (unbox lb))]
+		       [h (- (unbox bb) (unbox tb))]
+		       [th (+ (or frame-label-h 0) 2)]
+		       [tw (+ (* 2 margin) w)]
+		       [totalh (+ th (* 2 margin) h)])
+		  (when (and (or (<= 0 l tw) (<= 0 r tw) (<= l 0 tw r))
+			     (or (<= 0 t totalh) (<= 0 b totalh) (<= t 0 totalh b)))
+		    (set! last-frame-paint-w tw)
+		    (set! last-frame-paint-h totalh)
+		    (send dc draw-rectangle dx dy 
+			  tw totalh)
+		    (send dc draw-line dx (+ dy th)
+			  (+ dx tw -1) (+ dy th))
+		    (with-clipping-region 
+		     dc (add1 dx) (add1 dy) 
+		     (+ tw -2) (- th 2)
+		     (lambda ()
+		       (let ([f (send dc get-font)])
+			 (send dc set-font f)
+			 (send dc draw-text frame-label 
+			       (+ dx (/ (- tw (or frame-label-w 0)) 2)) 
+			       (+ dy 1))
+			 (send dc set-font f)))))))))]
+	[write-footers-to-file
+	 (lambda (stream)
+	   (super write-footers-to-file stream)
+	   (let ([out (lambda (name val)
+			(let ([info (box 0)])
+			  (begin-write-header-footer-to-file stream name info)
+			  (send stream put val)
+			  (end-write-header-footer-to-file stream (unbox info))))])
+	     (out "gb:mode" top-level-type)
+	     (out "gb:title-utf8" (string->bytes/utf-8 frame-label))
+	     (out "gb:top-name-utf8" (string->bytes/utf-8 top-name))
+	     (out "gb:show" (if auto-show? 1 0))))]
+	[read-footer-from-file
+	 (lambda (stream kind)
+	   (cond
+	     [(string=? kind "gb:mode") 
+	      (set! top-level-type 
+		    (min -LAST-MODE- 
+			 (max -FIRST-MODE- (send stream get-exact))))]
+	     [(string=? kind "gb:title") 
+	      (set! frame-label (bytes->string/latin-1 (send stream get-bytes)))]
+	     [(string=? kind "gb:title-utf8") 
+	      (set! frame-label (bytes->string/utf-8 (send stream get-bytes)))]
+	     [(string=? kind "gb:top-name-utf8") 
+	      (set! top-name (bytes->string/latin-1 (send stream get-bytes)))]
+	     [(string=? kind "gb:top-name") 
+	      (set! top-name (bytes->string/utf-8 (send stream get-bytes)))]
+	     [(string=? kind "gb:show") 
+	      (set! auto-show? (positive? (send stream get-exact)))]
+	     [else (super read-footer-from-file stream kind)]))]
+	[copy-self-to (lambda (e)
+			(send e prepare-to-load)
+			(super copy-self-to e)
+			(send e done-loading #t))]
+	[copy-self (lambda ()
+		     (let ([e (new gb:edit%
+				   [auto-show? auto-show?]
+				   [top-level-type top-level-type]
+				   [frame-label frame-label]
+				   [top-name top-name])])
+		       (copy-self-to e)
+		       e))])
+      (private-field
+	[main-panel #f])
+      (public*
+	[get-main-panel (lambda () main-panel)]
+	[create-main-panel
+	 (lambda () 
+	   (erase)
+	   (set! main-panel (make-object gb:panel-snip%))
+	   (insert main-panel 0 0)
+	   (resize main-panel START-FRAME-WIDTH START-FRAME-HEIGHT)
+	   (send main-panel gb-install this #f)
+	   (send main-panel set-id "0")
+	   (send main-panel gb-need-recalc-size)
+	   (set-modified #f))])
+      (public*
+	[prepare-to-load
+	 (lambda ()
+	   (set! pasting? #t))]
+	[done-loading
+	 (lambda (ok?)
+	   (set! pasting? #f)
+	   (when ok?
+	     (set! main-panel (find-snip-by-original-id "0"))
+	     (send main-panel set-id "0")
+	     (handle-new-arrivals)
+	     (set-modified #f)))])
+      (augment*
+       [on-load-file
+	(lambda (file mode)
+	  (prepare-to-load))]
+       [after-load-file
+	(lambda (ok?)
+	  (done-loading ok?))])
+
+      ;; Code generation:
+      (public*
+	[instantiate
+	 (lambda ()
+	   (let ([code (build-code #t #f)])
+	     (thread
+	      (lambda ()
+		(parameterize ([mred:current-eventspace (mred:make-eventspace)])
+		   (eval code))))))]
+	[view-source
+	 (lambda ()
+	   (let ([port (open-output-string)])
+	     (pretty-print (build-code #f #f) port)
+	     (let ([f (make-object (framework:frame:text-mixin framework:frame:editor%)
+				   "code.scm")])
+	       (send (send f get-editor) insert (get-output-string port))
+	       (send f show #t))))]
+	[build-code
+	 (lambda (force-frame? as-class?)
+	   (let* ([main (get-main-panel)]
+		  [type (get-top-level-type)]
+		  [frame-label (if (and (= type PANEL-MODE) force-frame?)
+				   "Panel Tester"
+				   (get-frame-label))]
+		  [mode (make-output-mode as-class? force-frame?)]
+		  [top (string->symbol top-name)])
+	     `(,@(cond
+		  [as-class? '(class object%)]
+		  [(and (= type PANEL-MODE)
+			(not force-frame?))
+		   '(lambda (top))]
+		  [else '(begin)])
+		,@(if as-class?
+		      (if (and (= type PANEL-MODE) (not force-frame?))
+			  '((init top))
+			  '())
+		      '())
+		,@(cond
+		   [(or (= type FRAME-MODE) 
+			(and (= type PANEL-MODE) force-frame?))
+		    (if as-class?
+			`((public* [get-top% (lambda () frame%)])
+			  (field [,top (make-object (get-top%) ,frame-label)]))
+			`((define ,top (make-object frame% ,frame-label))))]
+		   [(= type PANEL-MODE) null]
+		   [else
+		    (if as-class?
+			`((public* [get-top% (lambda () dialog%)])
+			  (field [,top (make-object (get-top%) ,frame-label)]))
+			`((define ,top (make-object dialog% ,frame-label))))])
+		,@(send main gb-instantiate 'top mode)
+		,@(if as-class?
+		      '((super-new))
+		      null)
+		,@(if (and (not force-frame?)
+			   (or (= type PANEL-MODE) (not (get-auto-show))))
+		      null
+		      `((send ,top show #t))))))])
+
+      (super-new)))
+
+  (provide gb:edit%))
diff --git a/collects/guibuilder/utils.ss b/collects/guibuilder/utils.ss
new file mode 100644
index 0000000000..c9b9c2f86e
--- /dev/null
+++ b/collects/guibuilder/utils.ss
@@ -0,0 +1,101 @@
+
+(module utils mzscheme
+  (require (prefix mred: (lib "mred.ss" "mred"))
+	   (lib "class.ss")
+	   (lib "etc.ss")
+	   (lib "list.ss"))
+
+  (define-syntax (private-field stx)
+    (syntax-case stx ()
+      [(_ (id val) ...)
+       (syntax/loc stx (begin (define id val) ...))]))
+
+  (define make-one-line/callback-edit
+    (opt-lambda (parent label cb [v ""])
+      (make-object mred:text-field% label parent 
+		   (lambda (t e) (cb (send t get-value))) v)))
+
+  (define make-number-control
+    (lambda (parent label value get-min get-max set-v)
+      (let* ([p (make-object mred:horizontal-panel% parent)]
+	     [l (make-object mred:message% label p)]
+	     [vl (make-object mred:message% "999999" p)]
+	     [set-value
+	      (lambda (n)
+		(set! value n)
+		(send vl set-label (number->string n))
+		(set-v n))]
+	     [b (make-object mred:button%
+			     "Set..."
+			     p
+			     (lambda (b e)
+			       (let ([v (mred:get-text-from-user 
+					 (format "~a, in [~a, ~a]:" label (get-min) (get-max))
+					 label
+					 #f
+					 (number->string value))])
+				 (when v
+				   (let ([n (string->number v)])
+				     (if (and (integer? n) (exact? n) 
+					      (>= n (get-min)) (<= n (get-max)))
+					 (set-value n)
+					 (mred:message-box "Error" "Bad value")))))))])
+	(send vl set-label (number->string value))
+	(make-object (class object% ()
+		       (public*
+			 [get-val (lambda () value)]
+			 [check (lambda () 
+				  (when (< value (get-min))
+				    (set-value (get-min)))
+				  (when (> value (get-max))
+				    (set-value (get-max))))])
+		       (super-new))))))
+  
+  (define new-name (lambda (base) (symbol->string (gensym base))))
+  
+  (define (stream-write-list stream l)
+    (send stream put (length l))
+    (for-each
+     (lambda (i)
+       (send stream put (string->bytes/utf-8 i)))
+     l))
+  
+  (define (get-bytes->string version)
+    (if (version . >= . 5)
+	bytes->string/utf-8
+	bytes->string/latin-1))
+
+  (define (stream-read-list stream version)
+    (let ([n (send stream get-exact)]
+	  [b->s (get-bytes->string version)])
+      (let loop ([n n])
+	(if (zero? n)
+	    null
+	    (cons (b->s (send stream get-bytes)) (loop (sub1 n)))))))
+
+  (define cached-region #f)
+  (define cached-region-dc #f)
+
+  (define (with-clipping-region dc x y w h thunk)
+    (let ([r (send dc get-clipping-region)]
+	  [r2 (if (eq? dc cached-region-dc)
+		  cached-region
+		  (make-object mred:region% dc))])
+      (set! cached-region-dc #f)
+      (send r2 set-rectangle x y w h)
+      (send r2 intersect r)
+      (send dc set-clipping-region r2)
+      (thunk)
+      (send dc set-clipping-region r)
+      (set! cached-region r2)
+      (set! cached-region-dc dc)))
+  
+  (provide private-field
+	   make-one-line/callback-edit
+	   make-number-control
+	   new-name
+	   get-bytes->string	   
+	   stream-write-list
+	   stream-read-list
+	   with-clipping-region))
+
diff --git a/collects/guibuilder/vpanel.xpm b/collects/guibuilder/vpanel.xpm
new file mode 100644
index 0000000000..c5fb5451be
--- /dev/null
+++ b/collects/guibuilder/vpanel.xpm
@@ -0,0 +1,22 @@
+/* XPM */
+static char * vpanel_xpm[] = {
+"16 16 3 1",
+" 	c #FFFFFFFFFFFF",
+".	c #000000000000",
+"X	c #A0A0A0A0A0A0",
+"                ",
+"   ..........   ",
+"   .        .   ",
+"   .        .   ",
+"   .  XXXX  .   ",
+"   .        .   ",
+"   .        .   ",
+"   .  XXXX  .   ",
+"   .  XXXX  .   ",
+"   .        .   ",
+"   .        .   ",
+"   .  XXXX  .   ",
+"   .        .   ",
+"   .        .   ",
+"   ..........   ",
+"                "};
diff --git a/collects/handin-client/client.ss b/collects/handin-client/client.ss
new file mode 100644
index 0000000000..0589680a43
--- /dev/null
+++ b/collects/handin-client/client.ss
@@ -0,0 +1,78 @@
+
+(module client mzscheme
+  (require (lib "mzssl.ss" "openssl"))
+
+  (provide handin-connect
+	   submit-assignment
+	   submit-addition
+	   submit-password-change)
+
+  (define-struct handin (r w))
+
+  (define (handin-connect server port pem)
+    (let ([ctx (ssl-make-client-context)])
+      (ssl-set-verify! ctx #t)
+      (ssl-load-verify-root-certificates! ctx pem)
+      (let-values ([(r w) (ssl-connect server port ctx)])
+	;; Sanity check: server sends "handin", first:
+	(let ([s (read-string 6 r)])
+	  (unless (equal? "handin" s)
+	    (error 'handin-connect "bad handshake from server: ~e" s)))
+	;; Tell server protocol = 'original:
+	(fprintf w "original\n")
+	;; One more sanity check: server recognizes protocol:
+	(let ([s (read r)])
+	  (unless (eq? s 'original)
+	    (error 'handin-connect "bad protocol from server: ~e" s)))
+	;; Return connection and list of active assignments:
+	(values (make-handin r w)
+		(let ([v (read r)])
+		  (unless (and (list? v)
+			       (andmap string? v))
+		    (error 'handin-connect "failed to get active-assignment list from server"))
+		  v)))))
+
+  (define (submit-assignment h username passwd assignment content on-commit)
+    (let ([r (handin-r h)]
+	  [w (handin-w h)])
+      (fprintf w "~s ~s ~s\n" username passwd assignment)
+      (let ([v (read r)])
+	(unless (eq? v 'ok)
+	  (error 'handin-connect "login error: ~a" v)))
+      (fprintf w "~s\n" (string-length content))
+      (let ([v (read r)])
+	(unless (eq? v 'go)
+	  (error 'handin-connect "upload error: ~a" v)))
+      (fprintf w "$")
+      (display content w)
+      (let ([v (read r)])
+	(unless (eq? v 'confirm)
+	  (error 'handin-connect "submit error: ~a" v)))
+      (on-commit)
+      (fprintf w "check\n")
+      (let ([v (read r)])
+	(unless (eq? v 'done)
+	  (error 'handin-connect "commit probably unsucccesful: ~e" v)))
+      (close-input-port r)
+      (close-output-port w)))
+
+
+  (define (submit-addition h username full-name id passwd)
+    (let ([r (handin-r h)]
+	  [w (handin-w h)])
+      (fprintf w "~s create ~s ~s ~s~n" username full-name id passwd)
+      (let ([v (read r)])
+	(unless (eq? v 'ok)
+	  (error 'handin-connect "update error: ~a" v)))
+      (close-input-port r)
+      (close-output-port w)))
+
+  (define (submit-password-change h username old-passwd new-passwd)
+    (let ([r (handin-r h)]
+	  [w (handin-w h)])
+      (fprintf w "~s ~s change ~s~n" username old-passwd new-passwd)
+      (let ([v (read r)])
+	(unless (eq? v 'ok)
+	  (error 'handin-connect "update error: ~a" v)))
+      (close-input-port r)
+      (close-output-port w))))
diff --git a/collects/handin-client/icon.png b/collects/handin-client/icon.png
new file mode 100644
index 0000000000..8876ac78f0
Binary files /dev/null and b/collects/handin-client/icon.png differ
diff --git a/collects/handin-client/info.ss b/collects/handin-client/info.ss
new file mode 100644
index 0000000000..d8abb68c31
--- /dev/null
+++ b/collects/handin-client/info.ss
@@ -0,0 +1,21 @@
+(module info (lib "infotab.ss" "setup")
+  ;; Modify these four definitions to customize the tool.
+  ;; Also replace the "icon.png" and "server-cert.pem" files.
+  (define name "Course Handin")
+  (define collection "handin-client")
+  ;; (define server:port "localhost:7979")
+  ;; --> server:port should be defined here, if it is not defined, not tool
+  ;;     will appear.  To try things, you can set the PLT_HANDIN_SERVER_PORT
+  ;;     environment variable when this is undefined.
+
+  ;; The following are optional. Uncomment and fill in
+  ;; the values to add a menu item under "Help" to open
+  ;; the specified web page (using the user's chosen web
+  ;; browser.)
+  ;(define web-menu-name "Course Homepage")
+  ;(define web-address "http://www.university.edu/course/")
+
+  #;(define tool-icons (list (list "icon.png" collection)))
+  #;(define tools '(("tool.ss")))
+  #;(define tool-names (list name))
+  (define requires '(("mred") ("openssl"))))
diff --git a/collects/handin-client/server-cert.pem b/collects/handin-client/server-cert.pem
new file mode 100644
index 0000000000..bb1cb31e7d
--- /dev/null
+++ b/collects/handin-client/server-cert.pem
@@ -0,0 +1,23 @@
+-----BEGIN CERTIFICATE-----
+MIIDwDCCAymgAwIBAgIBADANBgkqhkiG9w0BAQQFADCBojELMAkGA1UEBhMCVVMx
+DTALBgNVBAgTBFV0YWgxFzAVBgNVBAcTDlNhbHQgTGFrZSBDaXR5MRkwFwYDVQQK
+ExBQTFQgU2NoZW1lLCBJbmMuMQ0wCwYDVQQLEwREZW1vMRswGQYDVQQDExJ3d3cu
+cGx0LXNjaGVtZS5vcmcxJDAiBgkqhkiG9w0BCQEWFXNjaGVtZUBwbHQtc2NoZW1l
+Lm9yZzAeFw0wMzA3MjIxNTA0MTdaFw0wNDA3MjExNTA0MTdaMIGiMQswCQYDVQQG
+EwJVUzENMAsGA1UECBMEVXRhaDEXMBUGA1UEBxMOU2FsdCBMYWtlIENpdHkxGTAX
+BgNVBAoTEFBMVCBTY2hlbWUsIEluYy4xDTALBgNVBAsTBERlbW8xGzAZBgNVBAMT
+End3dy5wbHQtc2NoZW1lLm9yZzEkMCIGCSqGSIb3DQEJARYVc2NoZW1lQHBsdC1z
+Y2hlbWUub3JnMIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQC4/XjGBcwJU/jD
+4cZRe8LcjrJaWh9F8Nh0j97nGv2JgeLYCJp6oClWBvWLfAs/YBDIMogsN48jjA6n
+QExslJ6Dk+oriK92EPLlIuiqrHcTif9lHu2H0BarIme4COTVVPmfETXTrDBNxp/D
+93kzGvXsbxdnO2lSsU3u6hZoj1ZEGwIDAQABo4IBAjCB/zAdBgNVHQ4EFgQU0X7d
+ycn57T16KLOXUwMM35kdhKEwgc8GA1UdIwSBxzCBxIAU0X7dycn57T16KLOXUwMM
+35kdhKGhgaikgaUwgaIxCzAJBgNVBAYTAlVTMQ0wCwYDVQQIEwRVdGFoMRcwFQYD
+VQQHEw5TYWx0IExha2UgQ2l0eTEZMBcGA1UEChMQUExUIFNjaGVtZSwgSW5jLjEN
+MAsGA1UECxMERGVtbzEbMBkGA1UEAxMSd3d3LnBsdC1zY2hlbWUub3JnMSQwIgYJ
+KoZIhvcNAQkBFhVzY2hlbWVAcGx0LXNjaGVtZS5vcmeCAQAwDAYDVR0TBAUwAwEB
+/zANBgkqhkiG9w0BAQQFAAOBgQAJEtqvFtCPszpdUg273+hMC0NMSIINToTqv8+T
+Knl3yfTJtzdcvFBuTRaYVzPz4YyREx8Y46e5dKSk5Qr2dNogn00yOn6nzzumbkqN
+hu9gFV5/J9fJtvaQV/hF4ynhpD0M5TSCILdMJIc1Ls70xEtVFHPT51iZev3zDUuN
+4Xintg==
+-----END CERTIFICATE-----
diff --git a/collects/handin-client/tool.ss b/collects/handin-client/tool.ss
new file mode 100644
index 0000000000..58a0c7ea85
--- /dev/null
+++ b/collects/handin-client/tool.ss
@@ -0,0 +1,527 @@
+(module tool mzscheme
+  (require (lib "mred.ss" "mred")
+	   (lib "class.ss")
+	   (lib "unitsig.ss")
+	   (lib "tool.ss" "drscheme")
+	   (lib "etc.ss")
+	   (lib "file.ss")
+	   (lib "framework.ss" "framework")
+	   (lib "sendurl.ss" "net")
+           (lib "bitmap-label.ss" "mrlib")
+	   "client.ss"
+	   "info.ss"
+	   ;; Temporary hack for test suite in separate window:
+	   (lib "extension.ss" "test-suite"))
+
+  (provide tool@)
+
+  (define uninstalled? #f)
+
+  (define server:port
+    (#%info-lookup 'server:port (lambda () (getenv "PLT_HANDIN_SERVER_PORT"))))
+  (define-values (server port-no)
+    (if server:port
+      (let ([m (regexp-match #rx"^(.+):([0-9]+)$" server:port)])
+        (unless m
+          (error 'handin-client
+                 "Bad configuration ~s, expecting \"server:port\""
+                 server:port))
+        (values (cadr m) (string->number (caddr m))))
+      (values #f #f)))
+
+  (define handin-name (#%info-lookup 'name))
+  (define this-collection (#%info-lookup 'collection))
+  (define web-menu-name (#%info-lookup 'web-menu-name (lambda () #f)))
+  (define web-address (#%info-lookup 'web-address (lambda () #f)))
+
+  (preferences:set-default 'submit:username "" string?)
+  (define (remembered-user)
+    (preferences:get 'submit:username))
+  (define (remember-user user)
+    (preferences:set 'submit:username user))
+
+  (define (connect)
+    (handin-connect server
+		    port-no
+		    (build-path
+		     (collection-path this-collection)
+		     "server-cert.pem")))
+
+  (define handin-frame%
+    (class dialog%
+      (inherit show is-shown?)
+      (super-new [label "Handin"])
+
+      (init-field content)
+
+      (define status (new message%
+			  [label (format "Making secure connection to ~a..." server)]
+			  [parent this]
+			  [stretchable-width #t]))
+      (define username (new text-field%
+			    [label "Username:"]
+			    [init-value (remembered-user)]
+			    [parent this]
+			    [callback (lambda (t e) (activate-ok))]
+			    [stretchable-width #t]))
+      (define passwd (new text-field%
+			  [label "Password:"]
+			  [parent this]
+			  [callback (lambda (t e) (activate-ok))]
+			  [style '(single password)]
+			  [stretchable-width #t]))
+      (define assignment (new choice%
+			      [label "Assignment:"]
+			      [choices null]
+			      [parent this]
+			      [callback void]
+			      [stretchable-width #t]))
+
+      (define button-panel (new horizontal-pane%
+				[parent this]
+				[stretchable-height #f]))
+      (make-object vertical-pane% button-panel) ; spacer
+      (define ok (new button%
+		      [label "Handin"]
+		      [parent button-panel]
+		      [callback (lambda (b e)
+				  (disable-interface)
+				  (send status set-label "Handing in...")
+				  (parameterize ([current-custodian
+						  comm-cust])
+				    (thread
+				     (lambda ()
+				       (with-handlers ([void
+							(lambda (exn)
+							  (report-error
+							   "Handin failed."
+							   exn))])
+					 (remember-user (send username get-value))
+					 (submit-assignment
+					  connection
+					  (send username get-value)
+					  (send passwd get-value)
+					  (send assignment
+						get-string
+						(send assignment get-selection))
+					  content
+					  (lambda ()
+					    (semaphore-wait commit-lock)
+					    (send status set-label "Comitting...")
+					    (set! committing? #t)
+					    (semaphore-post commit-lock)))
+					 (queue-callback
+					  (lambda ()
+					    (when abort-commit-dialog
+					      (send abort-commit-dialog show #f))
+					    (send status set-label "Handin successful.")
+					    (set! committing? #f)
+					    (done-interface))))))))]
+		      [style '(border)]))
+
+      (define ok-can-enable? #f)
+      (define (activate-ok)
+	(send ok enable (and ok-can-enable?
+			     (not (string=? "" (send username get-value)))
+			     (not (string=? "" (send passwd get-value))))))
+
+      (define cancel  (new button%
+			   [label "Cancel"]
+			   [parent button-panel]
+			   [callback (lambda (b e)
+				       (let ([go? (begin
+						    (semaphore-wait commit-lock)
+						    (if committing?
+							(begin
+							  (semaphore-post commit-lock)
+							  (send abort-commit-dialog show #t)
+							  continue-abort?)
+							#t))])
+					 (when go?
+					   (custodian-shutdown-all comm-cust)
+					   (show #f))))]))
+
+      (define continue-abort? #f)
+      (define abort-commit-dialog
+	(let ([d (make-object dialog% "Commit in Progress")])
+	  (make-object message% "The commit action is in progress." d)
+	  (make-object message% "Cancelling now may or may not work." d)
+	  (make-object message% "Cancel anyway?" d)
+	  (let ([b (new horizontal-panel%
+			[parent d]
+			[stretchable-height #f]
+			[alignment '(center center)])])
+	    (make-object button% "Continue Commit" d (lambda (b e) (send d show #f)))
+	    (make-object button% "Try to Cancel" d (lambda (b e)
+						     (set! continue-abort? #t)
+						     (send d show #f))))))
+
+      (define (disable-interface)
+	(send ok enable #f)
+	(send username enable #f)
+	(send passwd enable #f)
+	(send assignment enable #f))
+      (define (enable-interface)
+	(send ok enable #t)
+	(send username enable #t)
+	(send passwd enable #t)
+	(send assignment enable #t)
+        (send passwd focus))
+      (define (done-interface)
+        (send cancel set-label "Close")
+        (send cancel focus))
+
+      (define (report-error tag exn)
+	(queue-callback
+	 (lambda ()
+	   (let* ([msg (if (exn? exn)
+                         (let ([s (exn-message exn)])
+                           (if (string? s)
+                             s
+                             (format "~e" s)))
+                         (format "~e" exn))]
+                  [retry? (regexp-match #rx"bad username or password for" msg)])
+             (custodian-shutdown-all comm-cust)
+             (disable-interface)
+             (send status set-label tag)
+             (when (is-shown?)
+               (message-box "Server Error" msg this)
+               (if retry?
+                 (begin (init-comm) (semaphore-post go-sema) (enable-interface))
+                 (done-interface)))))))
+
+      (define go-sema #f)
+      (define commit-lock #f)
+      (define committing? #f)
+
+      (define connection #f)
+
+      (define comm-cust #f)
+      (define (init-comm)
+        (set! go-sema (make-semaphore 1))
+        (set! commit-lock (make-semaphore 1))
+        (set! comm-cust (make-custodian))
+	(parameterize ([current-custodian comm-cust])
+	  (thread (lambda ()
+		    (let/ec escape
+		      (with-handlers ([void
+				       (lambda (exn)
+					 (report-error
+					  "Connection failed."
+					  exn)
+					 (escape))])
+			(semaphore-wait go-sema)
+			(let-values ([(h l) (connect)])
+			  (when (null? l)
+			    (error 'handin "there are no active assignments"))
+			  (set! connection h)
+			  (for-each (lambda (assign)
+				      (send assignment append assign))
+				    l)
+			  (send assignment enable #t)
+			  (set! ok-can-enable? #t)
+			  (activate-ok)
+			  (send status set-label (format "Connected securely for ~a." handin-name)))))))))
+
+      (define/augment (on-close)
+	(inner (void) on-close)
+	(custodian-shutdown-all comm-cust))
+
+      (send ok enable #f)
+      (send assignment enable #f)
+
+      (init-comm)
+      (send passwd focus)
+      (show #t)))
+
+  (define (manage-handin-account)
+    (new
+     (class dialog%
+       (inherit show is-shown?)
+       (super-new [label "Handin Account"]
+		  [alignment '(left center)])
+
+       (define status (new message%
+			   [label (format "Manage ~a account at ~a." handin-name server)]
+			   [parent this]
+			   [stretchable-width #t]))
+
+       (define tabs (new tab-panel%
+			 [parent this]
+			 [choices '("Change Password"
+				    "New User"
+				    "Uninstall")]
+			 [callback
+			  (lambda (tp e)
+			    (send single active-child
+				  (list-ref 
+				   (list old-user-box
+					 new-user-box
+					 uninstall-box)
+				   (send tabs get-selection))))]))
+
+       (define single (new panel:single%
+			   [parent tabs]))
+
+       (define (mk-txt label parent activate-ok)
+	 (new text-field%
+	      [label label]
+	      [parent parent]
+	      [callback (lambda (t e) (activate-ok))]
+	      [stretchable-width #t]))
+
+       (define (mk-passwd label parent activate-ok)
+	 (new text-field%
+	      [label label]
+	      [parent parent]
+	      [callback (lambda (t e) (activate-ok))]
+	      [style '(single password)]
+	      [stretchable-width #t]))
+
+       (define (non-empty? t)
+	 (not (string=? "" (send t get-value))))
+
+       (define (activate-change)
+	 (send change-button enable
+	       (and (non-empty? old-username)
+		    (non-empty? old-passwd)
+		    (non-empty? new-passwd)
+		    (non-empty? confirm-passwd))))
+       (define old-user-box (new vertical-panel%
+				 [parent single]
+				 [alignment '(center center)]))
+       (define old-username (mk-txt "Username:" old-user-box activate-change))
+       (send old-username set-value (remembered-user))
+
+       (define old-passwd (mk-passwd "Old:" old-user-box activate-change))
+       (define new-passwd (mk-passwd "New:" old-user-box activate-change))
+       (define confirm-passwd (mk-passwd "New again:" old-user-box activate-change))
+       (define change-button (new button%
+				  [label "Set Password"]
+				  [parent old-user-box]
+				  [callback
+				   (lambda (b e)
+				     (do-change/add #f old-username b e))]
+				  [style '(border)]))
+
+       (define (activate-new)
+	 (send new-button enable
+	       (and (non-empty? new-username)
+		    (non-empty? full-name)
+		    (non-empty? student-id)
+		    (non-empty? add-passwd))))
+       (define new-user-box (new vertical-panel%
+				 [parent single]
+				 [alignment '(center center)]))
+       (define new-username (mk-txt "Username:" new-user-box activate-new))
+       (send new-username set-value (remembered-user))
+       (define full-name (mk-txt "Full Name:" new-user-box activate-new))
+       (define student-id (mk-txt "ID:" new-user-box activate-new))
+       (define add-passwd (mk-passwd "Password:" new-user-box activate-new))
+       (define new-button (new button%
+			       [label "Add User"]
+			       [parent new-user-box]
+			       [callback
+				(lambda (b e)
+				  (do-change/add #t new-username b e))]
+			       [style '(border)]))
+
+       (define uninstall-box (new vertical-panel%
+				 [parent single]
+				 [alignment '(center center)]))
+       (define uninstall-button (new button%
+				     [label (format "Uninstall ~a" handin-name)]
+				     [parent uninstall-box]
+				     [callback
+				      (lambda (b e)
+					(let ([dir (collection-path this-collection)])
+					  (with-handlers ([void (lambda (exn)
+								  (report-error
+								   "Uninstall failed."
+								   exn))])
+					    (delete-directory/files dir)
+					    (set! uninstalled? #t)
+					    (send uninstall-button enable #f)
+					    (message-box
+					     "Uninstall"
+					     (format
+					      "The ~a tool has been uninstalled. ~a~a"
+					      handin-name
+					      "The Handin button and associated menu items"
+					      " will not appear after you restart DrScheme.")))))]))
+       (send uninstall-button enable (not uninstalled?))
+
+       (define (report-error tag exn)
+	 (queue-callback
+	  (lambda ()
+	    (custodian-shutdown-all comm-cust)
+	    (send status set-label tag)
+	    (when (is-shown?)
+	      (message-box
+	       "Server Error"
+	       (if (exn? exn)
+		   (let ([s (exn-message exn)])
+		     (if (string? s)
+			 s
+			 (format "~e" s))))
+	       this)
+	      (set! comm-cust (make-custodian))))))
+
+       (define comm-cust (make-custodian))
+       (define/augment (on-close)
+	 (inner (void) on-close)
+	 (custodian-shutdown-all comm-cust))
+
+       (define button-panel (new horizontal-pane%
+				 [parent this]
+				 [stretchable-height #f]))
+       (make-object vertical-pane% button-panel) ; spacer
+       (define cancel  (new button%
+			    [label "Cancel"]
+			    [parent button-panel]
+			    [callback (lambda (b e)
+					(custodian-shutdown-all comm-cust)
+					(show #f))]))
+
+       ;; Too-long fields can't damage the server, but they might
+       ;;  result in confusing errors due to safety cut-offs on
+       ;;  the server side.
+       (define (check-length field size name k)
+	 (when ((string-length (send field get-value)) . > . size)
+	   (message-box "Error"
+			(format "The ~a must be no longer than ~a characters."
+				name size))
+	   (k (void))))
+
+       (define (do-change/add new? username b e)
+	 (let/ec k
+	   (unless new?
+	     (check-length new-passwd 50 "New password" k)
+	     (when (not (string=? (send new-passwd get-value)
+				  (send confirm-passwd get-value)))
+	       (message-box "Password Error"
+			    "The \"New\" and \"New again\" passwords are not the same.")
+	       (k (void))))
+	   (when new?
+	     (check-length username 50 "Username" k)
+	     (check-length full-name 100 "Full Name" k)
+	     (check-length student-id 100 "ID" k)
+	     (check-length add-passwd 50 "Password" k))
+	   (send tabs enable #f)
+	   (parameterize ([current-custodian comm-cust])
+	     (thread
+	      (lambda ()
+		(with-handlers ([void (lambda (exn)
+                                        (send tabs enable #t)
+					(report-error
+					 "Update failed."
+					 exn))])
+		  (remember-user (send username get-value))
+		  (send status set-label "Making secure connection...")
+		  (let-values ([(h l) (connect)])
+		    (send status set-label "Updating server...")
+		    (if new?
+			(submit-addition
+			 h
+			 (send username get-value)
+			 (send full-name get-value)
+			 (send student-id get-value)
+			 (send add-passwd get-value))
+			(submit-password-change
+			 h
+			 (send username get-value)
+			 (send old-passwd get-value)
+			 (send new-passwd get-value))))
+		  (send status set-label "Success.")
+		  (send cancel set-label "Close")))))))
+
+       (send new-user-box show #f)
+       (send uninstall-box show #f)
+       (activate-new)
+       (activate-change)
+       (show #t))))
+
+  (define (scale-by-half file)
+    (let* ([bm (make-object bitmap% file)]
+	   [w (send bm get-width)]
+	   [h (send bm get-height)]
+	   [bm2 (make-object bitmap% (quotient w 2) (quotient h 2))]
+	   [mdc (make-object bitmap-dc% bm2)])
+      (send mdc set-scale 0.5 0.5)
+      (send mdc draw-bitmap bm 0 0)
+      (send mdc set-bitmap #f)
+      bm2))
+
+  (define handin-icon
+    (scale-by-half
+     (build-path (collection-path this-collection) "icon.png")))
+
+  (define (editors->string editors)
+    (let* ([base (make-object editor-stream-out-bytes-base%)]
+	   [stream (make-object editor-stream-out% base)])
+      (write-editor-version stream base)
+      (write-editor-global-header stream)
+      (for-each (lambda (ed)
+		  (send ed write-to-file stream)
+		  (send ed write-to-file stream))
+		editors)
+      (write-editor-global-footer stream)
+      (send base get-string)))
+
+  (add-test-suite-extension
+   "Handin"
+   handin-icon
+   (lambda (parent editor)
+     (let ([content (editors->string (list editor))])
+       (new handin-frame% [parent parent] [content content]))))
+
+  (define tool@
+    (unit/sig drscheme:tool-exports^
+      (import drscheme:tool^)
+
+      (define phase1 void)
+      (define phase2 void)
+
+      (define tool-button-label
+	(bitmap-label-maker
+	 "Handin"
+	 handin-icon))
+
+      (define (make-new-unit-frame% super%)
+	(class super%
+	  (inherit get-button-panel
+		   get-definitions-text
+		   get-interactions-text)
+	  (super-instantiate ())
+
+          (define/override (file-menu:between-open-and-revert file-menu)
+            (new menu-item%
+		 (label (format "Manage ~a..." handin-name))
+		 (parent file-menu)
+		 (callback (lambda (m e) (manage-handin-account))))
+            (super file-menu:between-open-and-revert file-menu))
+
+          (define/override (help-menu:after-about menu)
+	    (when web-menu-name
+	      (new menu-item%
+		   (label web-menu-name)
+		   (parent menu)
+		   (callback (lambda (item evt)
+			       (send-url web-address)))))
+            (super help-menu:after-about menu))
+
+	  (define button
+	    (new button% 
+		 [label (tool-button-label this)]
+		 [parent (get-button-panel)]
+		 [callback (lambda (button evt)
+			     (let ([content (editors->string
+					     (list (get-definitions-text)
+						   (get-interactions-text)))])
+			       (new handin-frame% [parent this] [content content])))]
+		 [style '(deleted)]))
+	  (send (get-button-panel) change-children
+		(lambda (l) (cons button l)))))
+
+      (when (and server port-no)
+        (drscheme:get/extend:extend-unit-frame make-new-unit-frame% #f)))))
diff --git a/collects/handin-server/doc.txt b/collects/handin-server/doc.txt
new file mode 100644
index 0000000000..db7ee9c7cc
--- /dev/null
+++ b/collects/handin-server/doc.txt
@@ -0,0 +1,439 @@
+
+_Handin Server and Client_
+
+The "handin-server" directory contains a server to be run by a course
+instructor for accepting homework assignments and reporting on
+submitted assignments.
+
+The "handin-client" directory contains a client to be customized then
+re-distributed to students in the course. The customized client will
+embed a particular hostname and port where the server is running, as
+well as a server certificate.
+
+With a customized client, students simply install a ".plt" file --- so
+there's no futzing with configuration dialogs and certificates. A
+student can install any number of clients at once (assuming that the
+clients are properly customized, as described below).
+
+The result, on the student's side, is a "Handin" button in DrScheme's
+toolbar. Clicking the "Handin" button allows the student to type a
+password and upload the current content of the definitions and
+interactions window to the course instructor's server. The "File" menu
+is also extended with a "Manage..." menu item for managing a handin
+account (i.e., changing the password, or creating a new account if the
+instructor configures the server to allow new accounts).
+
+On the instructor's side, the handin server can be configured to check
+the student's submission before accepting it. Other configuration of
+the server includes setting the list of currently active assignments
+(i.e., those for which handins are accepted).
+
+The handin process uses SSL, so it is effectively as secure as the
+server and each user's password.
+
+
+Quick Start for a Test Drive:
+============================================
+
+ 1.  Create a new directory.
+
+ 2.  Copy "server-cert.pem" from the "handin-client" collection
+     to the new directory.
+       NOTE: for real use, you need a new certificate.
+       NOTE: see also "Where is the collection?", below
+
+ 3.  Copy "private-key.pem" from the "handin-server" collection
+     to the new directory.
+       NOTE: for real use, you need a new key.
+
+ 4.  Create a file "users.ss" with the following content:
+       ((tester ("8fe4c11451281c094a6578e6ddbf5eed"
+                 "Chester Tester"
+                 "123")))
+
+ 5.  Make an "active" subdirectory in your new directory.
+
+ 6.  Make a "test" subdirectory in "active".
+
+ 7.  In your new directory, run
+        mred -mvqM handin-server
+     
+ 8.  In the "handin-client" collection, edit "info.ss" and
+     uncomment the line
+        (define server:port "localhost:7979")
+
+ 9.  Start DrScheme, click "Handin" to run the client, submit with
+     username "tester" and password "pw".
+
+     The submitted file will be .../active/test/tester/handin.scm.
+ 
+ 10. Check the status of your submission by pointing a web browser at
+        https://localhost:7980/servlets/status.ss
+     Note the "s" in "https". Use the "tester" username and "pw"
+     password, as before.
+
+  -------------------------------------------------------------------
+ | "Where is the collection?"                                        |
+ |- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -|
+ | If you obtained the server and client by installing a .plt file,  |
+ | then the "handin-server" and "handin-client" directories          |
+ | are likely in your PLT addon space:                               |
+ |  Windows:                                                         |
+ |   %USERPROFILE%\Application Data\PLT Scheme\<version>\collects    |
+ |  Unix:                                                            |
+ |   ~/.plt-scheme/<version>/collects                                |
+ |  Mac OS X:                                                        |
+ |   ~/Library/PLT Scheme/<version>/collects                         |
+  -------------------------------------------------------------------
+
+
+Client Customization
+============================================
+
+To customize the client:
+
+  1. Rename (or make a copy of) the "handin-client" collection
+     directory. The new name should describe your class more or less
+     uniquely. For example, "uu-cpsc2010" is a good name for CPSC 2010
+     at the University of Utah.
+
+  2. Edit the first three definitions of "info.ss" in your renamed
+     client collection:
+
+       * For `name', choose a name for the handin tool as it will
+         appear in DrScheme's interface (e.g., the "XXX" for the
+         "Manage XXX..."  menu item). Again, make the name specific to
+         the course, in case a student installs multiple handin tools.
+         It's a good idea to use "Handin" as the last part of the
+         name, as in "2010 Handin", since the button is always named
+         "Handin".
+
+       * For `collection', use the name that you chose for your
+         collection directory (i.e., whatever you changed
+         "handin-client" to).
+
+       * For `server:port', uncomment the line, and use the hostname
+         and port where the server will be running to accept handin
+         submissions.
+
+      Optionally uncomment and edit the next two definitions,
+      `web-menu-name' and `web-address', to add an item to the "Help"
+      menu that opens a (course-specific) web page.
+
+   3. Replace "icon.png" in your renamed directory with a new 32x32
+      icon. This icon is displayed on startup with DrScheme's splash
+      screen, and it is included at half size on the "Handin"
+      button. Again, choose a distinct icon for the benefit of
+      students who install multiple handin tools.
+
+   4. Replace "server-cert.pem" in your renamed directory with a
+      server certificate. The file "server-cert.pem" in
+      "handin-client" collection is ok for testing, but the point of
+      this certificate is to make handins secure, so you should
+      generate a new (self-certifying) certificate and keep its key
+      private. (See server setup, below.)
+
+   5. Run
+           mzc --collection-plt <name>.plt <name>
+      where <name> is the name that you chose for your directory
+      (i.e., whatever you changed "handin-client" to).
+
+   6. Distribute <name>.plt to students for installation into their
+      copies of DrScheme. The students need not have access to the
+      DrScheme installation directory; the tool will be installed on
+      the filesystem in the student's personal space. If you want to
+      install it once on a shared installation, use setup-plt with the
+      --all-users flag.
+
+
+Server Setup
+============================================
+
+The server must be run from a directory that is specially prepared to
+host the server. This directory contains the following files and
+sub-directories:
+
+  * server-cert.pem --- the server's certificate. To create a
+    ceritificate and key with openssl:
+
+     openssl req -new -nodes -x509 -days 365 -out server-cert.pem 
+                 -keyout private-key.pem 
+
+  * private-key.pem --- the private key to go with "server-cert.pem".
+    Whereas "server-cert.pem" gets distributed to students with the
+    handin client, "private-key.pem" is kept private.
+
+  * config.ss (optional) --- configuration options. The file format
+    is 
+
+         ((<key> <val>) ...)
+
+    for the following keys:
+
+      'port-number : the port for the main handin server; the default
+         is 7979
+
+      'https-port-number : the port for the handin-status HTTPS
+         server; the default is one more than the main server's port
+         (so the transitive default is 7980)
+
+      'session-timeout : number of seconds a session can last,
+         including execution of the submit-validation function;
+         the default is 300
+
+      'session-memory-limit : maximum size in bytes of memory allowed
+         for per-session comuptation, if per-session limits are
+         supported (i.e., when using MrEd3m and MzScheme3m with memory
+         accounting); the default is 40000000
+
+      'default-file-name : the default filename that will be saved
+        with the submission contents.  The default is "handin.scm".
+
+      'max-upload : maximum size in bytes of an acceptable submission;
+         the default is 500000
+
+      'max-upload-keep : maximum index of submissions to keep; the
+         most recent submission is "handin.scm" (by default), the next
+         oldest is in "BACKUP-0/handin.scm", next oldest is
+         "BACKUP-1/handin.scm", etc.; the default is 9
+
+      'id-regexp : a regular expression used to validate a "free form"
+         user id (possibly a student id) for a created account; the
+         default is #rx"^.*$"
+
+      'id-desc : a plain-words description of the acceptable format
+         for a "free form" id; the default is "anything"
+
+      'allow-new-users : a boolean indicating whether to allow
+         new-user requests from a client tool; the default is #f
+
+      'master-password : a string for an MD5 hash for a password that
+         allows login as any user; the default is #f, which disables
+         the password
+
+  * users.ss (created if not present if a user is added) --- keeps
+    the list of user accounts, along with the associated password
+    (actually the MD5 hash of the password), full name, and free-form
+    id (perhaps a student id at a university) of the account. The file
+    format is
+
+      ((<username-sym> (<pw-md5-str> <full-name-str> <id-str>)) ...)
+
+    If the 'allow-new-users configuration allows new users, the
+    "users.ss" file can be updated by the server with new users. It
+    can always be updated by the server to change passwords.
+
+    The username "solution" is special. It is used by the HTTPS status
+    server.
+
+  * active/ --- sub-directory for active assignments. A list of active
+    assignments is sent to a client tool when a student clicks
+    "Handin". The student then selects from the list. The list of
+    active assignments is built once by the server when it starts.
+    The assignments are ordered in the student's menu using `string<?',
+    and the first assignment is the default selection.
+
+    Within each directory, the student id is used for a sub-directory
+    name. Within each student sub-directory are "handin.scm" (or some
+    other name if `default-file-name' is set), "BACKUP-0", "BACKUP-1",
+    etc., for each student who submits an assignment. (The most recent
+    handin is in this directory, and "BACKUP-?" directories hold older
+    submission for the same assignment.) A `checker' procedure can
+    replace the name "handin.scm" with something else (possibly
+    sensitive to the content of the submission), and create additional
+    files; see below for more details.
+
+    For submissions from a normal DrScheme frame, a "handin.scm" file
+    contains a copy of the student's definitions and interactions
+    windows. The file is in a binary format (to support non-text
+    code), and opening the file directly in DrScheme shows the
+    definitions part. To get both the defintions and interactions
+    parts, the file can be parsed with `unpack-submission' from
+    "utils.ss" (see below).
+
+    For submissions from a test-suite window, the file is a normal
+    test-suite file.
+
+  * inactive/ --- sub-directory for inactive assignments, used by the
+    HTTPS status web server.
+
+  * active/<assignment>/checker.ss (optional) --- a module that
+    exports a `checker' function. This function receives two
+    strings. The first is a username and the second is the user's
+    submission as a string. (See also `unpack-submission', etc. from
+    "util.ss", below.) To reject the submission, the `checker'
+    function can raise an exception; the exception message will be
+    relayed back to the student. The `checker' function is called when
+    the current directory is active/<assignment>/<user>, and it can
+    create additional files in this directory -- such files will get
+    moved when a backup is done.  If you want to hide some of these
+    files from the web interface, but them in a subdirectory -- it
+    will be properly backed up, and directories are all hidden from
+    the web interface.
+
+    The checker should return a string, such as "handin.scm", to use in
+    naming the submission. For submissions that require both programs
+    and test suites, the checker might use `is-test-suite-submission?'
+    and return "tests" if the string is a test-suite submission or
+    "program" if it is not.
+
+  * log.ss (created if not present, appended otherwise) --- records
+    connections and actions, where each entry is of the form
+        (id time-str msg-str)
+    and `id' is an integer reprsenting the connection (numbered
+    consecutively from 1 when the server starts) or 0 for a message
+    for server without a connection.
+
+  * web-status-log.ss (created if not present, appended otherwise)
+    --- records accesses of the HTTPS status web server.
+
+  * [in]active/<assignment>/<user>/<filename> (if submitted) --- the
+    most recent submission for <assignment> by <user> where <filename>
+    was returned by the checker (or the value of the
+    `default-file-name' configuration option if there's no checker).
+
+  * [in]active/<assignment>/<user>/grade (optional) --- <user>'s grade
+    for <assignment>, to be reported by the HTTPS status web server.
+
+  * [in]active/<assignment>/solution/<assignment>sol.scm --- the
+    solution to the assignment, made available by the status server
+    to any user who logs in.
+
+The server can be run within either MzScheme or MrEd, but "utils.ss"
+requires MrEd (which means that `checker' modules will likely require
+the server to run under MrEd).
+
+The server currently provides no mechanism for a graceful shutdown,
+but terminiating the server is no worse than a network outage. (In
+particular, no data should be lost.) To reconfigure the server (e.g.,
+to change the set of active assignments), stop it and restart it.
+
+The client and server are designed to be robust against network
+problems and timeouts. The client-side tool always provides a "cancel"
+button for any network transaction. For handins, "cancel" is
+guaranteed to work up to the point that the client sends a "commit"
+command; this command is sent only after the server is ready to record
+the submission (having run it through the checker, if any), but before
+the server writes the "handin.scm" file. Also, the server responds to a
+commit with "ok" only after it has written the file. Thus, when the
+client-side tool reports that the handin was successful, the report is
+reliable. Meanwhile, the tool can also report successful cancels most
+of the time. In the (normally brief) time between a commit and an "ok"
+response, the tool gives the student a suitable warning that the
+cancel is unreliable.
+
+To minimize human error, the number of active assignments should be
+limited to 1 whenever possible. When multiple assignments are active,
+design a checker to help ensure that the student has selected the
+correct assignment in the handin dialog.
+
+A student can download his/her own submissions through a web server
+that runs concurrently with the handin server. The starting URL is
+
+  https://SERVER:PORT/servlets/status.ss
+
+to obtain a list of all assingments, or
+
+  https://SERVER:PORT/servlets/status.ss?handin=ASSIGNMENT
+
+to start with a specific assignment (named ASSIGNMENT). The default
+PORT is 7980.
+
+
+Checker Utilities
+============================================
+
+The _utils.ss_ module provides utilities helpful in implementing
+`checker' functions:
+
+> (unpack-submission bytes) - returns two text% objects corresponding
+  to the submitted definitions and interactions windows.
+
+> (unpack-test-suite-submission bytes) - returns a pasteboard%
+  object corresponding to the submitted test-suite window. The
+  pasteboard contains a sequence of editor-snip% objects, each each
+  editor-snip% contains a text% with three embedded editor-snip%s: one
+  for the test expression, one for the expected result, and one for
+  the equality predicate.
+
+> (is-test-suite-submission? bytes) - returns #t if `string' can be
+  read as an old-style test suite, #f otherwise.
+
+
+> (make-evaluator language teachpack-paths program-port) - returns a
+  function of one argument for evaluating expressions in the
+  designated teaching language, one of 'beginner, 'beginner-abbr,
+  'intermediate, 'intermediate-lambda, or 'advanced. The
+  `teachpack-paths' list contains paths to teachpacks to load in the
+  evaluator. The `program-port' is an input port that produces the
+  content of the definitions window; use `(open-input-string "")'
+  for an empty definitions window.
+
+  The actual evaluation of expressions happens in a newly created
+  eventspace and namespace.
+
+> (make-evaluator/submission language teachpack-paths bytes) - like
+  `make-evaluator', but the definitions content is supplied as a
+  submission byte string.
+
+> (call-with-evaluator language teachpack-paths program-port proc) -
+  calls `proc' with an evaluator for the given language, teachpack
+  paths, and initial definition content as supplied by a port. It also
+  sets the current error-value print handler to print values in a way
+  suitable for `lang', it initializes `current-run-status' with
+  "executing your code", and it catches all exceptions to re-raise
+  them in a form suitable as a submission error.
+
+> (call-with-evaluator/submission language teachpack-paths bytes proc) -
+   like `call-with-evaluator', but the definitions content is supplied
+   as a submission string.
+
+
+> (evaluate-all source input-port eval) - like `load' on an input
+  port.
+
+> (evaluate-submission bytes eval) - like `load' on a non-test-suite
+  submission byte string.
+
+
+> (check-proc eval expect-v compare-proc proc-name arg ...) - calls
+  the function named `proc-name' using the evaluator `eval', giving it
+  the (unquoted) arguments `arg'... Let `result-v' be the result of
+  the call; unless `(compare-proc result-v expect-v)' is true, an
+  exception is raised.
+
+  Every exception or result mismatch during the call to `check-proc'
+  phrased suitably for the handin client.
+
+> (check-defined eval name) - checks whether `name' is defined in the
+  evaluator `eval', and raises an error if not (suitably phrased for
+  the handin client).  If it is defined as non-syntax, its value is
+  returned. Warning: in the beginner language level, procedure
+  definitions are bound as syntax.
+
+> (look-for-tests text name n) - inspects the given text% object to
+  determine whether it contains at least `n' tests for the function
+  `name'. The tests must be top-level expressions.
+
+> (user-construct eval name arg ...) - like `check-proc', but with no
+  result checking. This function is often useful for calling a
+  student-defined constructor.
+
+
+> test-history-enabled - parameter that controls how run-time errors
+  are reported to the handin client. If the parameter's value is true,
+  then the complete sequence of tested expressions is reported to the
+  handin client for any test failure. Set this parameter to true when
+  testing programs that use state.
+
+> (current-run-status string-or-#f) - registers information about the
+  current actions of the checker, in case the session is terminated
+  due to excessive memory consumption. For example, a cccchecker might
+  set the status to indicate which instructor-supplied test was being
+  executed when the session ran out of memory. This status is only
+  used when per-session memory limits are supported (i.e., under
+  MrEd3m or MzScheme3m with memory accounting).
+
+> (reraise-exn-as-submission-problem thunk) - calls thunk in a context
+  that catches exceptions and re-raises them in a form suitable as a
+  submission error.
diff --git a/collects/handin-server/handin-server.ss b/collects/handin-server/handin-server.ss
new file mode 100644
index 0000000000..bac3aa75ea
--- /dev/null
+++ b/collects/handin-server/handin-server.ss
@@ -0,0 +1,362 @@
+#cs
+(module handin-server mzscheme
+  (require (lib "thread.ss")
+	   (lib "port.ss")
+	   (lib "mzssl.ss" "openssl")
+	   (lib "file.ss")
+	   (lib "date.ss")
+	   (lib "list.ss")
+	   "md5.ss"
+	   "web-status-server.ss"
+	   "run-status.ss")
+
+  (define log-port (open-output-file "log.ss" 'append))
+
+  (define current-session (make-parameter 0))
+
+  (define (LOG str . args)
+    ;; Assemble log into into a single string, to make
+    ;;  interleaved log lines unlikely:
+    (let ([line
+	   (format "(~a ~s ~s)~n"
+		   (current-session)
+		   (parameterize ([date-display-format 'iso-8601])
+		     (date->string (seconds->date (current-seconds)) #t))
+		   (apply format str args))])
+      (display line log-port)))
+
+  (define (get-config which default)
+    (get-preference which 
+		    (lambda () default)
+		    #f
+		    "config.ss"))
+
+  (define PORT-NUMBER (get-config 'port-number 7979))
+  (define HTTPS-PORT-NUMBER (get-config 'https-port-number (add1 PORT-NUMBER)))
+  (define SESSION-TIMEOUT (get-config 'session-timeout 300))
+  (define SESSION-MEMORY-LIMIT (get-config 'session-memory-limit 40000000))
+  (define DEFAULT-FILE-NAME (get-config 'default-file-name "handin.scm"))
+  (define MAX-UPLOAD (get-config 'max-upload 500000))
+  (define MAX-UPLOAD-KEEP (get-config 'max-upload-keep 9))
+  (define ID-REGEXP (get-config 'id-regexp #rx"^.*$"))
+  (define ID-DESC (get-config 'id-desc "anything"))
+  (define ALLOW-NEW-USERS? (get-config 'allow-new-users #f))
+  (define MASTER-PASSWD (get-config 'master-password #f))
+
+  (define (check-id s)
+    (regexp-match ID-REGEXP s))
+
+  (define orig-custodian (current-custodian))
+
+  ;; On startup, check that the prefs file is not locked:
+  (put-preferences null null 
+		   (lambda (f)
+		     (delete-file f)
+		     (put-preferences null null 
+				      (lambda (f)
+					(error 'handin-server
+					       "unable to clean up lock file: ~s" f))
+				      "users.ss"))
+		   "users.ss")
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (define backup-prefix "BACKUP-")
+  (define backup-dir-re (regexp (format "^~a[0-9]+$" backup-prefix)))
+  (define (backup n) (format "~a~a" backup-prefix n))
+  (define (files+backups)
+    (let* ([files (directory-list)]
+           [backups (filter (lambda (f)
+                              (and (directory-exists? f)
+                                   (regexp-match backup-dir-re f)))
+                            files)])
+      (values (remove* backups files) backups)))
+  (define (do-backups)
+    (let-values ([(files backups) (files+backups)])
+      (define (make-backup-available n)
+        (when (member (backup n) backups)
+          (if (< n MAX-UPLOAD-KEEP)
+            (begin (make-backup-available (add1 n))
+                   (rename-file-or-directory (backup n) (backup (add1 n))))
+            (delete-directory/files (backup n)))))
+      (unless (null? files)
+        (LOG "backing up ~a" files)
+        (make-backup-available 0)
+        (make-directory (backup 0))
+        (for-each (lambda (file)
+                    (rename-file-or-directory file (build-path (backup 0) file)))
+                  files))))
+  (define (undo-backup)
+    ;; It is ok to just move BACKUP-0 to the real directory, the above will
+    ;; just find it available on later backups.
+    (let-values ([(files backups) (files+backups)])
+      (LOG "undoing backup")
+      (for-each delete-directory/files files)
+      (when (member (backup 0) backups)
+        (for-each (lambda (file)
+                    (rename-file-or-directory (build-path (backup 0) file) file))
+                  (directory-list (backup 0)))
+        (delete-directory (backup 0)))))
+
+  (define (save-submission s part)
+    (with-output-to-file part
+      (lambda () (display s))))
+
+  (define (accept-specific-submission user assignment r r-safe w)
+    (parameterize ([current-directory (build-path "active" assignment)])
+      (unless (directory-exists? user)
+	(make-directory user))
+      (parameterize ([current-directory user])
+	(let ([len (read r-safe)])
+	  (unless (and (number? len)
+		       (integer? len)
+		       (positive? len))
+	    (error 'handin "bad length: ~s" len))
+	  (unless (len . < . MAX-UPLOAD)
+	    (error 'handin
+		   "max handin file size is ~s bytes, file to handin is too big (~s bytes)"
+		   MAX-UPLOAD len))
+	  (fprintf w "go\n")
+	  (unless (regexp-match #rx"[$]" r-safe)
+	    (error 'handin
+		   "did not find start-of-content marker"))
+	  (let ([s (read-string len r)])
+	    (unless (and (string? s) (= (string-length s) len))
+	      (error 'handin
+		     "error uploading (got ~s, expected ~s bytes)"
+		     (if (string? s) (string-length s) s)
+		     len))
+            (do-backups)
+	    (LOG "checking ~a for ~a" assignment user)
+	    (with-handlers ([void (lambda (e) (undo-backup) (raise e))])
+              (let ([part
+                     (let ([checker (build-path 'up "checker.ss")])
+                       (if (file-exists? checker)
+			 ((dynamic-require `(file ,(path->complete-path checker)) 'checker)
+			  user s)
+			 DEFAULT-FILE-NAME))])
+                (fprintf w "confirm\n")
+                (let ([v (read (make-limited-input-port r 50))])
+                  (if (eq? v 'check)
+		    (begin
+		      (LOG "saving ~a for ~a" assignment user)
+		      (save-submission s part)
+		      (fprintf w "done\n"))
+		    (error 'handin "upload not confirmed: ~s" v))))))))))
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (define (put-user key val)
+    ;; Although we don't have to worry about trashing the
+    ;;  prefs file, we do have to worry about a thread
+    ;;  getting killed while it locks the pref file.
+    ;; Avoid the problem by using orig-custodian.
+    (call-in-nested-thread
+     (lambda ()
+       (put-preferences (list key)
+			(list val)
+			(lambda (f)
+			  (error 
+			   'handin 
+			   "user database busy; please try again, and alert the adminstrator is problems persist"))
+			"users.ss"))
+     orig-custodian))
+
+  (define (add-new-user username r-safe w)
+    (let ([full-name (read r-safe)]
+	  [id (read r-safe)]
+	  [passwd (read r-safe)])
+      (unless (and (string? full-name)
+		   (string? id)
+		   (string? passwd))
+	(error 'handin "bad user-addition request"))
+      ;; Since we're going to use the username in paths:
+      (when (regexp-match #rx"[/\\:]" username)
+	(error 'handin "username must not contain a slash, backslash, or colon"))
+      (when (regexp-match #rx"^((NUL)|(CON)|(PRN)|(AUX)|(CLOCK[$])|(COM[1-9])|(LPT[1-9]))[.]?" 
+			  (list->string (map char-upcase (string->list username))))
+	(error 'handin "username must not be a Windows special file name"))
+      (when (string=? "solution" username)
+	(error 'handin "the username \"solution\" is reserved"))
+      (unless (check-id id)
+	(error 'handin "id has wrong format: ~a; need ~a for id" id ID-DESC))
+      (put-user (string->symbol username)
+		(list (md5 passwd) id full-name))
+      (fprintf w "ok~n")))
+  
+  (define (change-user-passwd username r-safe w old-user-data)
+    (let ([new-passwd (read r-safe)])
+      (LOG "change passwd for ~a" username)
+      (unless (string? new-passwd)
+	(error 'handin "bad password-change request"))
+      (put-user (string->symbol username)
+		(cons (md5 new-passwd) (cdr old-user-data)))
+      (fprintf w "ok~n")))
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  
+  (define (accept-submission-or-update active-assignments r r-safe w)
+    (fprintf w "~s~n" active-assignments)
+    ;; Get username and password:
+    (let ([username (read r-safe)]
+	  [passwd (read r-safe)])
+      (let ([user-data
+	     (and (string? username)
+		  (get-preference (string->symbol username)
+				  (lambda () #f)
+				  #f
+				  "users.ss"))])
+	(cond
+	 [(eq? passwd 'create)
+	  (when user-data
+	    (error 'handin "username already exists: ~a" username))
+	  (unless ALLOW-NEW-USERS?
+	    (error 'handin "new users not allowed: ~a" username))
+	  (LOG "create user: ~a" username)
+	  (add-new-user username r-safe w)]
+	 [(and user-data
+	       (string? passwd)
+	       (let ([pw (md5 passwd)])
+		 (or (equal? pw (car user-data))
+		     (equal? pw MASTER-PASSWD))))
+	  (LOG "login: ~a" username)
+	  (let ([assignment (read r-safe)])
+	    (LOG "assignment for ~a: ~a" username assignment)
+	    (if (eq? assignment 'change)
+		(change-user-passwd username r-safe w user-data)
+		(if (member assignment active-assignments)
+		    (begin
+		      (fprintf w "ok\n")
+		      (accept-specific-submission username assignment r r-safe w))
+		    (error 'handin "not an active assignment: ~a" assignment))))]
+	 [else
+	  (LOG "failed login: ~a" username)
+	  (error 'handin "bad username or password for ~a" username)]))))
+  
+  (define assignment-list
+    (quicksort (directory-list "active") string<?))
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (define no-limit-warning? #f)
+
+  (define (with-watcher w proc)
+    (if no-limit-warning?
+	;; Already know watcher doesn't work:
+	(proc void)
+	;; Try making a watcher:
+	(let ([session-cust (make-custodian)]
+	      [session-channel (make-channel)]
+	      [status-box (box #f)])
+	  (let ([watcher
+		 (with-handlers ([exn:fail:unsupported? 
+				  (lambda (x) 
+				    (set! no-limit-warning? #t)
+				    (LOG "WARNING: per-session memory limit not supported by MrEd")
+				    #f)])
+		   (custodian-limit-memory session-cust SESSION-MEMORY-LIMIT session-cust)
+		   (parameterize ([current-custodian orig-custodian])
+		     (thread (lambda ()
+			       (let ([session-thread (channel-get session-channel)])
+				 (let loop ()
+				   (if (sync/timeout 3 session-thread)
+				       (begin
+					 (LOG "session killed while ~s" (unbox status-box))
+					 (fprintf w "~s\n"
+						  (format
+						   "handin terminated due to excessive memory computation~a"
+						   (if (unbox status-box)
+						       (format " while ~a" (unbox status-box))
+						       "")))
+					 (close-output-port w)
+					 (channel-put session-channel 'done))
+				       (begin
+					 (collect-garbage)
+					 (LOG "running ~a (~a  ~a)"
+					      (current-memory-use session-cust)
+					      (current-memory-use orig-custodian)
+					      (current-memory-use))
+					 (loop)))))))))])
+	    (if watcher
+		;; Run proc in a thread under session-cust:
+		(let ([session-thread
+		       (parameterize ([current-custodian session-cust]
+				      [current-run-status-box status-box])
+			 (thread
+			  (lambda ()
+			    (proc (lambda ()
+				    ;; Proc has succeeded...
+				    (parameterize ([current-custodian orig-custodian])
+				      (kill-thread watcher))))
+			    (channel-put session-channel 'done-normal))))])
+		  (channel-put session-channel session-thread)
+		  ;; Wait until the proc is done or killed (and kill is reported):
+		  (channel-get session-channel))
+		;; Watcher didn't work:
+		(proc void))))))
+	      
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (LOG "server started ------------------------------")
+
+  (define stop-status (serve-status HTTPS-PORT-NUMBER))
+  
+  (define session-count 0)
+
+  (parameterize ([error-display-handler
+		  (lambda (msg exn)
+		    (LOG msg))])
+    (run-server
+     PORT-NUMBER
+     (lambda (r w)
+       (when ((current-memory-use) . > . SESSION-MEMORY-LIMIT)
+	 (collect-garbage))
+       (parameterize ([current-session (begin
+					 (set! session-count (add1 session-count))
+					 session-count)])
+	 (let-values ([(here there) (ssl-addresses r)])
+	   (LOG "connect from ~a" there))
+	 (with-watcher
+	  w
+	  (lambda (kill-watcher)
+	    (let ([r-safe (make-limited-input-port r 1024)])
+	      (fprintf w "handin\n")
+	      ;; Check protocol:
+	      (with-handlers ([exn:fail?
+			       (lambda (exn)
+				 (let ([msg (if (exn? exn)
+						(exn-message exn)
+						(format "~e" exn))])
+				   (kill-watcher)
+				   (LOG "ERROR: ~a" msg)
+				   (fprintf w "~s\n" msg)
+				   ;; see note on close-output-port below
+				   (close-output-port w)))])
+		(let ([protocol (read r-safe)])
+		  (if (eq? protocol 'original)
+		      (fprintf w "original\n")
+		      (error 'handin "unknown protocol: ~s" protocol)))
+		(accept-submission-or-update assignment-list r r-safe w)
+		(LOG "normal exit")
+		(kill-watcher)
+		;; This close-output-port should not be necessary, and it's
+		;; here due to a deficiency in the SLL binding.
+		;; The problem is that a custodian shutdown of w is harsher
+		;; for SSL output than a normal close. A normal close
+		;; flushes an internal buffer that's not supposed to exist, while
+		;; the shutdown gives up immediately.
+		(close-output-port w)))))))
+     SESSION-TIMEOUT
+     (lambda (exn)
+       (printf "~a~n" (if (exn? exn)
+			  (exn-message exn)
+			  exn)))
+     (lambda (port-k)
+       (let ([l (ssl-listen port-k 5 #t)])
+	 (ssl-load-certificate-chain! l "server-cert.pem")
+	 (ssl-load-private-key! l "private-key.pem")
+	 l))
+     ssl-close
+     ssl-accept
+     ssl-accept/enable-break)))
diff --git a/collects/handin-server/info.ss b/collects/handin-server/info.ss
new file mode 100644
index 0000000000..4b0a0edd76
--- /dev/null
+++ b/collects/handin-server/info.ss
@@ -0,0 +1,3 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Handin Server")
+  (define doc.txt "doc.txt"))
diff --git a/collects/handin-server/md5.ss b/collects/handin-server/md5.ss
new file mode 100644
index 0000000000..faf4f4fae6
--- /dev/null
+++ b/collects/handin-server/md5.ss
@@ -0,0 +1,5 @@
+(module md5 mzscheme
+  (require (prefix mz: (lib "md5.ss")))
+  (define (md5 s)
+    (bytes->string/latin-1 (mz:md5 (string->bytes/utf-8 s))))
+  (provide md5))
diff --git a/collects/handin-server/private-key.pem b/collects/handin-server/private-key.pem
new file mode 100644
index 0000000000..d5b6240f95
--- /dev/null
+++ b/collects/handin-server/private-key.pem
@@ -0,0 +1,15 @@
+-----BEGIN RSA PRIVATE KEY-----
+MIICXQIBAAKBgQC4/XjGBcwJU/jD4cZRe8LcjrJaWh9F8Nh0j97nGv2JgeLYCJp6
+oClWBvWLfAs/YBDIMogsN48jjA6nQExslJ6Dk+oriK92EPLlIuiqrHcTif9lHu2H
+0BarIme4COTVVPmfETXTrDBNxp/D93kzGvXsbxdnO2lSsU3u6hZoj1ZEGwIDAQAB
+AoGBAIAkLIXXPCf1/+sIOQz2ktufCRKnPOSA2h+cDUa/HoMi8tS82O06hoet2Gcf
+rNbgn59dyY//iGqSORBH7OiF5mqG1NBid8VQ7G84NB3/mqf/Ex7XUu9ROFJsELN3
+KDAyIEez5529FGUsCprsYE+WTAv0rZSyMYIxnPpe4/vVrzDRAkEA4hrYzzDkpJRV
+ZI3XIC3ZIOx7J1tezAahn6TZVTfPd15R0yIP6YdOElwR82MbIcuzWGd2cT7qfGcT
+hTH4zoNjyQJBANFy+yQ7LQl+fsFAXFl08Hub7EVeqPSuXReIQ9cy4f+7ZpKMueqK
+FWsDZep3ZD0+ILNuBFYTwhI/kP9oi9OkMsMCQG90DmVrU3lxCPrNFDrvfrVE/Jv0
+5TCrICZiiyL/pMvReYIaqz9RDAHu0oZn1ur8z0YHkhHWkp2J7cxdSqj5iUkCQBsz
+Qng3Eyc7fTydniCj9iMnYay0mV6FUmOe96h33C+45546ll5mJlfqbg7gCG2HpvmG
+XRvMnxR9mtgAfMA0f78CQQCGH8TQySWUkzkIoEKgdExDp/2p28j5Zv90XgcplI3H
+17MyFm0XUzCfCFIKeuSgLfk/Y2YNhyRr1Oxddd+qPj6/
+-----END RSA PRIVATE KEY-----
diff --git a/collects/handin-server/run-status.ss b/collects/handin-server/run-status.ss
new file mode 100644
index 0000000000..94c6d32b71
--- /dev/null
+++ b/collects/handin-server/run-status.ss
@@ -0,0 +1,11 @@
+(module run-status mzscheme
+  (define current-run-status-box (make-parameter #f))
+
+  (define (current-run-status s)
+    (let ([b (current-run-status-box)])
+      (when b
+	(set-box! b s))))
+
+  (provide current-run-status-box
+	   current-run-status))
+
diff --git a/collects/handin-server/status-web-root/conf/forbidden.html b/collects/handin-server/status-web-root/conf/forbidden.html
new file mode 100644
index 0000000000..fcd2eb9032
--- /dev/null
+++ b/collects/handin-server/status-web-root/conf/forbidden.html
@@ -0,0 +1,7 @@
+<html>
+<head><title>Access Denied</title></head>
+<body>
+<p>The server could not verify that you have permissions to access the requested document.</p>
+<p>Powered by <a href="http://www.plt-scheme.org/">PLT</a></p>
+</body>
+</html>
\ No newline at end of file
diff --git a/collects/handin-server/status-web-root/conf/not-found.html b/collects/handin-server/status-web-root/conf/not-found.html
new file mode 100644
index 0000000000..19bc1a0570
--- /dev/null
+++ b/collects/handin-server/status-web-root/conf/not-found.html
@@ -0,0 +1,7 @@
+<html>
+<head><title>Not Found</title></head>
+<body bgcolor='white'>
+<p>The file you were looking for was not found on this server.</p>
+<p>Powered by <a href="http://www.plt-scheme.org/">PLT</a></p>
+</body>
+</html>
diff --git a/collects/handin-server/status-web-root/conf/passwords-refresh.html b/collects/handin-server/status-web-root/conf/passwords-refresh.html
new file mode 100644
index 0000000000..3f283393ab
--- /dev/null
+++ b/collects/handin-server/status-web-root/conf/passwords-refresh.html
@@ -0,0 +1,7 @@
+<html>
+<head><title>Passwords Refreshed</title></head>
+<body bgcolor='white'>
+<p>The Web server is now using the new password file.</p>
+<p>Powered by <a href="http://www.plt-scheme.org/">PLT</a></p>
+</body>
+</html>
diff --git a/collects/handin-server/status-web-root/conf/protocol-error.html b/collects/handin-server/status-web-root/conf/protocol-error.html
new file mode 100644
index 0000000000..122732cc8d
--- /dev/null
+++ b/collects/handin-server/status-web-root/conf/protocol-error.html
@@ -0,0 +1,7 @@
+<html>
+<head><title>Browser Error</title></head>
+<body>
+<p>The browser sent a malformed request.</p>
+<p>Powered by <a href="http://www.plt-scheme.org/">PLT</a></p>
+</body>
+</html>
diff --git a/collects/handin-server/status-web-root/conf/servlet-error.html b/collects/handin-server/status-web-root/conf/servlet-error.html
new file mode 100644
index 0000000000..bf6b698231
--- /dev/null
+++ b/collects/handin-server/status-web-root/conf/servlet-error.html
@@ -0,0 +1,9 @@
+<html>
+<head><title>Servlet Error</title></head>
+<body>
+<p>The servlet terminated abnormally.<br />
+   Please ask the author to fix the problem based on the details in
+   the Web server's log file.</p>
+<p>Powered by <a href="http://www.plt-scheme.org/">PLT</a></p>
+</body>
+</html>
diff --git a/collects/handin-server/status-web-root/conf/servlet-refresh.html b/collects/handin-server/status-web-root/conf/servlet-refresh.html
new file mode 100644
index 0000000000..8db24b53c5
--- /dev/null
+++ b/collects/handin-server/status-web-root/conf/servlet-refresh.html
@@ -0,0 +1,7 @@
+<html>
+<head><title>Servlets Refreshed</title></head>
+<body bgcolor='white'>
+<p>Fresh copies of Servlets will now be (re)loaded from disk.</p>
+<p>Powered by <a href="http://www.plt-scheme.org/">PLT</a></p>
+</body>
+</html>
diff --git a/collects/handin-server/status-web-root/htdocs/index.html b/collects/handin-server/status-web-root/htdocs/index.html
new file mode 100644
index 0000000000..a5dc548987
--- /dev/null
+++ b/collects/handin-server/status-web-root/htdocs/index.html
@@ -0,0 +1,6 @@
+<html>
+<head><title>Handin Status Web Server</title></head>
+<body>
+The handin status server is running.
+</body>
+</html>
diff --git a/collects/handin-server/status-web-root/servlets/status.ss b/collects/handin-server/status-web-root/servlets/status.ss
new file mode 100644
index 0000000000..06f9b02c40
--- /dev/null
+++ b/collects/handin-server/status-web-root/servlets/status.ss
@@ -0,0 +1,268 @@
+
+(module status mzscheme
+  (require (lib "file.ss")
+	   (lib "list.ss")
+	   (lib "date.ss")
+	   (lib "unitsig.ss")
+	   (lib "servlet-sig.ss" "web-server")
+	   (lib "md5.ss" "handin-server"))
+
+  (provide status-servlet)
+  
+  (define TOPICS-PER-PAGE 25)
+
+  (define handin-dir (current-directory))
+  (define active-dir (build-path handin-dir "active"))
+  (define inactive-dir (build-path handin-dir "inactive"))
+
+  (define master-password 
+    (with-handlers ([exn:fail? (lambda (x) #f)])
+      (cadr (assq 'master-password 
+		  (with-input-from-file (build-path handin-dir "config.ss")
+		    read)))))
+  
+  (define (clean-str s)
+    (regexp-replace
+     " *$" 
+     (regexp-replace "^ *" s "")
+     ""))
+
+  (define (update-status status tag val)
+    (let loop ([status status])
+      (cond
+       [(null? status) (list (cons tag val))]
+       [(eq? (caar status) tag) (cons (cons tag val) (cdr status))]
+       [else (cons (car status) (loop (cdr status)))])))
+
+  (define (get-status status tag default)
+    (let ([a (assq tag status)])
+      (if a
+	  (cdr a)
+	  default)))
+
+  (define (make-page title . body)
+    `(html (head (title ,title))
+	   (body ([bgcolor "white"])
+		 (p ((align "center"))
+		    ,title)
+		 ,@body)))
+
+  (define status-servlet
+    (unit/sig ()
+      (import servlet^)
+
+      (define (make-k k tag)
+	(format "~a~atag=~a" k 
+		(if (regexp-match #rx"^[^#]*[?]" k)
+		    "&"
+		    "?")
+		tag))
+      (define (select-k request)
+	(let ([a (assq 'tag (request-bindings request))])
+	  (and a (cdr a))))
+      (define (link-tag k tag label)
+	`(a ((href ,(make-k k tag)))
+	    ,label))
+
+      (define (handin-link k user hi)
+	(let* ([dir (build-path (if (directory-exists? (build-path "active" hi))
+				    "active"
+				    "inactive")
+				hi
+				user)]
+	       [l (with-handlers ([exn:fail? (lambda (x) null)])
+                    (parameterize ([current-directory dir])
+                      (filter (lambda (f)
+                                (and (file-exists? f) (not (equal? f "grade"))))
+                              (directory-list))))])
+	  (if (pair? l)
+	      (cdr
+	       (apply
+		append
+		(map
+		 (lambda (i) `((br) ,i))
+		 (map (lambda (f)
+			 (let ([hi (build-path dir f)])
+			   `(font
+			     ()
+			     (a ((href ,(make-k k hi))) ,f)
+			     " ("
+			     ,(date->string
+			       (seconds->date
+				(file-or-directory-modify-seconds hi))
+			       #t)
+			     ")")))
+		      l))))
+	      (list (format "No handins accepted so far for user ~s, assignment ~s" user hi)))))
+
+      (define (solution-link k hi)
+	(let* ([soln-dir (build-path (if (directory-exists? (build-path "active" hi))
+					 "active"
+					 "inactive")
+				     hi
+				     "solution")]
+	       [soln (let ([f (build-path soln-dir (format "~asol.scm" hi))])
+		       (if (or (file-exists? f)
+			       (not (directory-exists? soln-dir)))
+			   f
+			   (let ([l (directory-list soln-dir)])
+			     (if (= 1 (length l))
+				 (build-path soln-dir (car l))
+				 f))))])
+	  (if (file-exists? soln)
+	      `((a ((href ,(make-k k soln)))
+		   "Solution"))
+	      `((i "Solution not available")))))
+
+      (define (handin-grade user hi)
+	(let* ([dir (build-path (if (directory-exists? (build-path "active" hi))
+				    "active"
+				    "inactive")
+				hi
+				user)]
+	       [grade (let ([filename (build-path dir "grade")])
+			(and (file-exists? filename)
+			     (with-input-from-file filename
+			       (lambda () (read-string (file-size filename))))))])
+	  (if grade
+	      grade
+	      "no grade so far")))
+
+      (define (one-status-page status for-handin)
+	(let ([user (get-status status 'user (lambda () "???"))])
+	  (let ([next
+		 (send/suspend
+		  (lambda (k)
+		    (make-page
+		     (format "User: ~a, Handin: ~a" user for-handin)
+		     `(p ,@(handin-link k user for-handin))
+		     `(p "Grade: " ,(handin-grade user for-handin))
+		     `(p ,@(solution-link k for-handin))
+		     `(p (a ((href ,(make-k k "allofthem")))
+			    ,(format "All handins for ~a" user))))))])
+	    (let ([tag (select-k next)])
+	      (if (string=? tag "allofthem")
+		  (all-status-page status)
+		  (download status tag))))))
+
+      (define re:base "^([a-zA-Z]*)([0-9]+)")
+
+      (define (all-status-page status)
+	(let ([l (quicksort
+		  (append (directory-list "active")
+			  (with-handlers ([exn:fail? (lambda (x) null)])
+			    (directory-list "inactive")))
+		  (lambda (a b)
+		    (let ([am (regexp-match re:base a)]
+			  [bm (regexp-match re:base b)])
+		      (if (and am bm
+			       (string=? (cadr am) (cadr bm)))
+			  (< (string->number (caddr am)) (string->number (caddr bm)))
+			  (string<? a b)))))]
+	      [user (get-status status 'user (lambda () "???"))])
+	  (let ([next
+		 (send/suspend
+		  (lambda (k)
+		    (make-page
+		     (format "All Handins for ~a" user)
+		     `(table
+		       ((bgcolor "#ddddff"))
+		       ,@(map (lambda (hi)
+				`(tr (td ((bgcolor "white")) ,hi)
+				     (td ((bgcolor "white")) ,@(handin-link k user hi))
+				     (td ((bgcolor "white")) ,(handin-grade user hi))
+				     (td ((bgcolor "white")) ,@(solution-link k hi))))
+			      l)))))])
+	    (let ([tag (select-k next)])
+	      (download status tag)))))
+
+      (define (download status tag)
+	;; Make sure the user is allowed to read the requested file:
+	(with-handlers ([exn:fail?
+                         (lambda (exn)
+                           (make-page "Error" "Illegal file access"))])
+	  (let ([who (get-status status 'user (lambda () "???"))])
+	    (let-values ([(base name dir?) (split-path tag)])
+	      ;; Any file name is ok...
+	      (unless (string? name) (error "bad"))
+	      (let-values ([(base name dir?) (split-path base)])
+		;; Directory must be user or "solution"
+		(unless (or (string=? name who)
+			    (string=? name "solution"))
+		  (error "bad"))
+		;; Any dir name is ok...
+		(let-values ([(base name dir?) (split-path base)])
+		  (unless (string? name) (error "bad"))
+		  ;; Base must be active or inactive
+		  (let-values ([(base name dir?) (split-path base)])
+		    (unless (or (string=? name "active") 
+				(string=? name "inactive"))
+		      (error "bad"))
+		    ;; No more to path
+		    (unless (eq? base 'relative)
+		      (error "bad")))))))
+	  ;; Return the downloaded file
+	  (let ([data (with-input-from-file tag
+			(lambda ()
+			  (read-string (file-size tag))))])
+	    (make-response/full 200 "Okay"
+				(current-seconds)
+				"application/data"
+				`((Content-length . ,(string-length data))
+				  (Content-disposition 
+				   .
+				   ,(format "attachment; filename=~s"
+					    (let-values ([(base name dir?) (split-path tag)])
+					      name))))
+				(list data)))))
+
+      (define (status-page status for-handin)
+	(if for-handin
+	    (one-status-page status for-handin)
+	    (all-status-page status)))
+
+      (define (login-page status for-handin errmsg)
+	(let ([request
+	       (send/suspend
+		(lambda (k)
+		  (make-page
+		   "Handin Status Login"
+		   `(form ([action ,k] [method "post"])
+			  (table
+			   ((align "center"))
+			   (tr (td ((colspan "2") (align "center"))
+				   (font ((color "red"))
+					 ,(if errmsg
+					      errmsg
+					      'nbsp))))
+			   (tr (td "Username")
+			       (td (input ([type "text"] [name "user"] [size "20"] [value ""]))))
+			   (tr (td nbsp))
+			   (tr (td "Password")
+			       (td (input ([type "password"] [name "passwd"] [size "20"] [value ""]))))
+			   (td ((colspan "2") (align "center"))
+			       (input ([type "submit"] [name "post"] [value "Login"]))))))))])
+	  (let ([user (clean-str (cdr (assq 'user (request-bindings request))))]
+		[passwd (cdr (assq 'passwd (request-bindings request)))])
+	    (let ([user-data (get-preference (string->symbol user)
+					     (lambda () #f)
+					     #f
+					     "users.ss")])
+	      (cond
+	       [(and user-data
+		     (string? passwd)
+		     (let ([pw (md5 passwd)])
+		       (or (equal? pw (car user-data))
+			   (equal? pw master-password))))
+		(status-page (update-status status 'user user) for-handin)]
+	       [else
+		(login-page status for-handin "Bad username or password")])))))
+
+      (let ([a (assq 'handin (request-bindings initial-request))])
+	(login-page null (and a (cdr a)) #f))
+
+      )))
+
+(require status)
+status-servlet
+
diff --git a/collects/handin-server/utils.ss b/collects/handin-server/utils.ss
new file mode 100644
index 0000000000..7de66253d2
--- /dev/null
+++ b/collects/handin-server/utils.ss
@@ -0,0 +1,333 @@
+(module utils mzscheme
+  (require (lib "class.ss")
+	   (lib "mred.ss" "mred")
+	   (lib "posn.ss" "lang")
+	   "run-status.ss"
+	   (prefix pc: (lib "pconvert.ss"))
+	   (lib "pretty.ss")
+	   (lib "list.ss"))
+
+  (provide unpack-submission
+	   
+	   unpack-test-suite-submission
+	   is-test-suite-submission?
+
+	   make-evaluator
+	   make-evaluator/submission
+	   evaluate-all
+	   evaluate-submission
+
+	   call-with-evaluator
+	   call-with-evaluator/submission
+	   reraise-exn-as-submission-problem
+	   current-run-status
+
+	   check-proc
+	   check-defined
+	   look-for-tests
+	   user-construct
+	   test-history-enabled)
+
+  (define (unpack-submission str)
+    (let* ([base (make-object editor-stream-in-bytes-base% str)]
+	   [stream (make-object editor-stream-in% base)]
+	   [definitions-text (make-object text%)]
+	   [interactions-text (make-object text%)])
+      (read-editor-version stream base #t)
+      (read-editor-global-header stream)
+      (send definitions-text read-from-file stream)
+      (send interactions-text read-from-file stream)
+      (read-editor-global-footer stream)
+      (values definitions-text interactions-text)))
+
+  (define (unpack-test-suite-submission str)
+    (let* ([base (make-object editor-stream-in-bytes-base% str)]
+	   [stream (make-object editor-stream-in% base)]
+	   [ts (make-object ts-load%)])
+      (read-editor-version stream base #t)
+      (read-editor-global-header stream)
+      (send ts read-from-file stream)
+      (read-editor-global-footer stream)
+      ts))
+
+  (define (is-test-suite-submission? str)
+    (send (unpack-test-suite-submission str)
+	  got-program?))
+
+  ;; Test Suite Unpacking ----------------------------------------
+  ;; This code duplicates just enough of the test-suite snips
+  ;;  to make test-suite files readable.
+  
+  (define program-header-field-name "drscheme:test-suite:program")
+
+  (define csc (new
+	       (class snip-class%
+		 (define/override (read f)
+		   (let ([case (new case%)])
+		     (send case read-from-file f)
+		     case))
+		 (super-new))))
+  (send csc set-classname "case%")
+  (send csc set-version 1)
+  (send (get-the-snip-class-list) add csc)
+
+  (define case%
+    (class editor-snip%
+      (inherit set-snipclass get-editor)
+
+      (define call (new text%))
+      (define expected (new text%))
+      (define test (new text%))
+
+      (define/public (read-from-file f)
+	(send call read-from-file f)
+	(send expected read-from-file f)
+	(send test read-from-file f)
+	(send f get-string))
+
+      (super-new)
+
+      (set-snipclass csc)
+      (send (get-editor) insert (make-object editor-snip% call))
+      (send (get-editor) insert (make-object editor-snip% expected))
+      (send (get-editor) insert (make-object editor-snip% test))))
+
+  (define dsc (new
+	       (class snip-class%
+		 (define/override (read f)
+		   (let ([helper (new helper%)])
+		     (send helper read-from-file f)
+		     helper))
+		 (super-new))))
+  (send dsc set-classname "drscheme:test-suite:helper%")
+  (send dsc set-version 1)
+  (send (get-the-snip-class-list) add dsc)
+
+  (define helper%
+    (class editor-snip%
+      (inherit set-snipclass get-editor)
+
+      (define/public (read-from-file f)
+	(send (get-editor) read-from-file f))
+
+      (super-new)
+
+      (set-snipclass dsc)))
+
+  (define ts-load%
+    (class pasteboard%
+      (define program (new text%))
+
+      (define got-p? #f)
+      (define/public (got-program?) got-p?)
+
+      (define/override (read-header-from-file stream name)
+	(if (string=? name program-header-field-name)
+	    (begin
+	      (set! got-p? #t)
+	      (send program read-from-file stream))
+	    (super read-header-from-file stream name)))
+
+      (super-new)))
+
+
+  ;; Execution ----------------------------------------
+
+  (define (make-evaluator language teachpacks program-port)
+    (let ([ns (make-namespace-with-mred)]
+	  [orig-ns (current-namespace)]
+	  [posn-module ((current-module-name-resolver) '(lib "posn.ss" "lang") #f #f)])
+      (parameterize ([current-namespace ns]
+		     [read-case-sensitive #t]
+		     [read-decimal-as-inexact #f]
+		     [current-inspector (make-inspector)])
+	(namespace-attach-module orig-ns posn-module)
+	(parameterize ([current-eventspace (make-eventspace)])
+	  (let ([ch (make-channel)]
+		[result-ch (make-channel)])
+	    (queue-callback
+	     (lambda ()
+	       ;; First read program and evaluate it as a module:
+	       (with-handlers ([void (lambda (exn) (channel-put result-ch (cons 'exn exn)))])
+		 (let ([prog-body
+			(parameterize ([read-case-sensitive #t]
+				       [read-decimal-as-inexact #f])
+			  (let loop ([l null])
+			    (let ([expr (read-syntax 'program program-port)])
+			      (if (eof-object? expr)
+				  (reverse l)
+				  (loop (cons expr l))))))])
+		   (eval `(module m (lib ,(case language
+					    [(beginner) "htdp-beginner.ss"]
+					    [(beginner-abbr) "htdp-beginner-abbr.ss"]
+					    [(intermediate) "htdp-intermediate.ss"]
+					    [(intermediate-lambda) "htdp-intermediate-lambda.ss"]
+					    [(advanced) "htdp-advanced.ss"])
+					 "lang")
+			    ,@(map (lambda (tp)
+				     `(,#'require (file ,tp)))
+				   teachpacks)
+			    ,@prog-body))
+		   (eval `(require m))
+		   (current-namespace (module->namespace 'm)))
+		 (channel-put result-ch 'ok))
+	       ;; Now wait for interaction expressions:
+	       (let loop ()
+		 (let ([expr (channel-get ch)])
+		   (unless (eof-object? expr)
+		     (with-handlers ([void (lambda (exn)
+					     (channel-put result-ch (cons 'exn exn)))])
+		       (channel-put result-ch (cons 'val (eval expr))))
+		     (loop))))
+	       (let loop ()
+		 (channel-put result-ch '(exn . no-more-to-evaluate))
+		 (loop))))
+	    (let ([r (channel-get result-ch)])
+	      (if (eq? r 'ok)
+		  ;; Initial program executed ok, so return an evaluator:
+		  (lambda (expr)
+		    (channel-put ch expr)
+		    (let ([r (channel-get result-ch)])
+		      (if (eq? (car r) 'exn)
+			  (raise (cdr r))
+			  (cdr r))))
+		  ;; Program didn't execute:
+		  (raise (cdr r)))))))))
+      
+  (define (make-evaluator/submission language teachpacks str)
+    (let-values ([(defs interacts) (unpack-submission str)])
+      (make-evaluator language teachpacks (open-input-text-editor defs))))
+
+  (define (evaluate-all source port eval)
+    (let loop ()
+      (let ([expr (parameterize ([read-case-sensitive #t]
+				 [read-decimal-as-inexact #f])
+		    (read-syntax source port))])
+	(unless (eof-object? expr)
+	  (eval expr)
+	  (loop)))))
+
+  (define (evaluate-submission str eval)
+    (let-values ([(defs interacts) (unpack-submission str)])
+      (evaluate-all 'handin (open-input-text-editor defs) eval)))
+
+  (define (reraise-exn-as-submission-problem thunk)
+    (with-handlers ([void (lambda (exn)
+			    (error
+			     (if (exn? exn)
+				 (exn-message exn)
+				 (format "~s" exn))))])
+      (thunk)))
+
+  ;; ----------------------------------------
+  ;;  Auto-test utils
+
+  (define (check-defined e id)
+    (with-handlers ([exn:fail:syntax? void]
+		    [exn:fail:contract:variable?
+		     (lambda (x)
+		       (error
+			(format
+			 "\"~a\" is not defined, but it must be defined for handin"
+			 (exn:fail:contract:variable-id x))))])
+      (e #`(#,namespace-variable-value '#,id #t))))
+
+  (define (mk-args args)
+    (let loop ([l args])
+      (if (null? l)
+	  ""
+	  (string-append " " (format "~e" (car l)) (loop (cdr l))))))
+
+  (define test-history-enabled (make-parameter #f))
+  (define test-history (make-parameter null))
+  
+  (define (format-history one-test)
+    (if (test-history-enabled)
+	(format "(begin~a)"
+		(apply string-append
+		       (map (lambda (s)
+			      (format " ~a" s))
+			    (reverse (test-history)))))
+	one-test))
+
+  (define (check-proc e result equal? f . args)
+    (let ([test (format "(~a~a)" f (mk-args args))])
+      (when (test-history-enabled)
+	(test-history (cons test (test-history))))
+      (current-run-status (format "running instructor-supplied test ~a" 
+				  (format-history test)))
+      (let-values ([(ok? val)
+		    (with-handlers ([void
+				     (lambda (x)
+				       (error
+					(format "instructor-supplied test ~a failed with an error: ~e"
+						(format-history test)
+						(exn-message x))))])
+		      (let ([val (e `(,f ,@(map value-converter args)))])
+			(values (or (eq? 'anything result)
+				    (equal? val result))
+				val)))])
+	(unless ok?
+	  (error
+	   (format "instructor-supplied test ~a should have produced ~e, instead produced ~e"
+		   (format-history test)
+		   result
+		   val)))
+	val)))
+
+  (define (user-construct e func . args)
+    (apply check-proc e func 'anything eq? args))
+
+  (define (look-for-tests t name count)
+    (let ([p (open-input-text-editor t)])
+      (let loop ([found 0])
+	(let ([e (read p)])
+	  (if (eof-object? e)
+	      (when (found . < . count)
+		(error (format "found ~a test~a for ~a, need at least ~a test~a"
+			       found
+			       (if (= found 1) "" "s")
+			       name
+			       count
+			       (if (= count 1) "" "s"))))
+	      (loop (+ found
+		       (if (and (pair? e)
+				(eq? (car e) name))
+			   1
+			   0))))))))
+
+  (define list-abbreviation-enabled (make-parameter #f))
+      
+  (define (value-converter v)
+    (parameterize ([pc:booleans-as-true/false #t]
+		   [pc:abbreviate-cons-as-list (list-abbreviation-enabled)]
+		   [pc:constructor-style-printing #t])
+      (pc:print-convert v)))
+
+  (define (value-printer v)
+    (parameterize ([pretty-print-show-inexactness #t]
+		   [pretty-print-.-symbol-without-bars #t]
+		   [pretty-print-exact-as-decimal #t]
+		   [pretty-print-columns +inf.0]
+		   [read-case-sensitive #t])
+      (let ([p (open-output-string)])
+	(pretty-print (value-converter v) p)
+	(regexp-replace #rx"\n$" (get-output-string p) ""))))
+
+  (define (call-with-evaluator lang teachpacks program-port go)
+    (parameterize ([error-value->string-handler (lambda (v s)
+						  (value-printer v))]
+		   [list-abbreviation-enabled (not (or (eq? lang 'beginner)
+						       (eq? lang 'beginner-abbr)))])
+      (reraise-exn-as-submission-problem
+       (lambda ()
+	 (let ([e (make-evaluator lang teachpacks program-port)])
+	   (current-run-status "executing your code")
+	   (go e))))))
+  
+  (define (call-with-evaluator/submission lang teachpacks str go)
+    (let-values ([(defs interacts) (unpack-submission str)])
+      (call-with-evaluator lang teachpacks (open-input-text-editor defs) go)))
+  
+  )
+
diff --git a/collects/handin-server/web-status-server.ss b/collects/handin-server/web-status-server.ss
new file mode 100644
index 0000000000..62160da4d0
--- /dev/null
+++ b/collects/handin-server/web-status-server.ss
@@ -0,0 +1,69 @@
+
+(module web-status-server mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "web-server-unit.ss" "web-server")
+	   (lib "sig.ss" "web-server")
+           (lib "configuration.ss" "web-server")
+	   (lib "ssl-tcp-unit.ss" "net")
+	   (lib "tcp-sig.ss" "net")
+	   (lib "tcp-unit.ss" "net")
+	   (lib "file.ss"))
+
+  (provide serve-status)
+
+  (define (serve-status port-no)
+    
+    (define config
+      `((port ,port-no)
+	(max-waiting 40)
+	(initial-connection-timeout 30)
+	(default-host-table
+	  (host-table
+	   (default-indices "index.html")
+	   (log-format parenthesized-default)
+	   (messages
+	    (servlet-message "servlet-error.html")
+	    (authentication-message "forbidden.html")
+	    (servlets-refreshed "servlet-refresh.html")
+	    (passwords-refreshed "passwords-refresh.html")
+	    (file-not-found-message "not-found.html")
+	    (protocol-message "protocol-error.html"))
+	   (timeouts
+	    (default-servlet-timeout 120)
+	    (password-connection-timeout 300)
+	    (servlet-connection-timeout 86400)
+	    (file-per-byte-connection-timeout 1/20)
+	    (file-base-connection-timeout 30))
+	   (paths
+	    (configuration-root "conf")
+	    (host-root ,(path->string (build-path (collection-path "handin-server") "status-web-root")))
+	    (log-file-path ,(path->string (build-path (current-directory) "web-status-log.ss")))
+	    (file-root "htdocs")
+	    (servlet-root ,(path->string (build-path (collection-path "handin-server") "status-web-root")))
+	    (password-authentication ,(path->string (build-path (current-directory) "web-status-passwords"))))))
+	(virtual-host-table)))
+
+    (define config@
+      (let ([file (make-temporary-file)])
+	(with-output-to-file file
+	  (lambda ()
+	    (write config))
+	  'truncate)
+	(begin0
+	 (load-configuration file)
+	 (delete-file file))))
+
+    (define-values/invoke-unit/sig web-server^
+      (compound-unit/sig
+       (import)
+       (link
+	[T : net:tcp^ ((make-ssl-tcp@
+			"server-cert.pem" "private-key.pem" #f #f
+			#f #f #f))]
+	[C : web-config^ (config@)]
+	[S : web-server^ (web-server@ T C)])
+       (export (open S)))
+      #f)
+
+    (serve)))
+
diff --git a/collects/help/bug-report.ss b/collects/help/bug-report.ss
new file mode 100644
index 0000000000..46f6cb1f17
--- /dev/null
+++ b/collects/help/bug-report.ss
@@ -0,0 +1,539 @@
+
+(module bug-report mzscheme
+  (require (lib "string-constant.ss" "string-constants")
+           (lib "head.ss" "net")
+           (lib "smtp.ss" "net")
+           (lib "mred.ss" "mred")
+           (lib "framework.ss" "framework")
+           (lib "class.ss")
+           (lib "etc.ss")
+           (lib "url.ss" "net")
+           (lib "uri-codec.ss" "net")
+           (lib "htmltext.ss" "browser")
+           "private/buginfo.ss"
+           "private/manuals.ss")
+  
+  (provide help-desk:report-bug)
+  
+  (define bug-report-recipient "bugs")
+  (define bug-email-server "bugs.plt-scheme.org")
+  (define bug-email-server-port 1025)
+  (define bug-www-server "bugs.plt-scheme.org")
+  (define bug-www-server-port 80)
+  (define bug-report-email-address 
+    (string-append bug-report-recipient "@plt-scheme.org"))
+  
+  ;; this one should be defined by help desk.
+  (define frame-mixin
+    (namespace-variable-value 'help-desk:frame-mixin #f (lambda () (lambda (x) x))))
+  
+  (preferences:set-default 'drscheme:email "" string?)
+  (preferences:set-default 'drscheme:full-name "" string?)
+
+  (define (remove-extra-blanks %)
+    (class %
+      (define/override (edit-menu:between-find-and-preferences menu) (void))
+      (super-instantiate ())))
+
+  (define bug-frame%
+    (class (frame-mixin (remove-extra-blanks (frame:standard-menus-mixin frame:basic%)))
+      (init title)
+
+      (define/override (file-menu:between-print-and-close menu) (void))
+      
+      (field (ok-to-close? #f))
+      (public set-ok-to-close)
+      (define (set-ok-to-close ok?) (set! ok-to-close? #t))
+      (define/augment (can-close?)
+        (or ok-to-close?
+            (ask-yes-or-no (string-constant cancel-bug-report?)
+                           (string-constant are-you-sure-cancel-bug-report?)
+                           this)))
+      
+      (super-make-object title)))
+  
+  
+  (define (help-desk:report-bug)
+    (define bug-frame (instantiate bug-frame% () (title (string-constant bug-report-form))))
+    (define single (new panel:single% (parent (send bug-frame get-area-container))))
+    (define outermost-panel (make-object vertical-panel% single))
+    
+    (define response-panel (new vertical-panel% (parent single)))
+    (define response-text (new (html-text-mixin text%) (auto-wrap #t)))
+    (define response-ec (new editor-canvas% (parent response-panel) (editor response-text)))
+    (define response-button-panel (new horizontal-panel%
+                                       (stretchable-height #f)
+                                       (parent response-panel)
+                                       (alignment '(right center))))
+    (define cancel-kill-thread #f)
+    (define response-reset (new button%
+                                (parent response-button-panel)
+                                (enabled #f)
+                                (label (string-constant wizard-back))
+                                (callback
+                                 (lambda (x y)
+                                   (switch-to-compose-view)))))
+    (define response-abort (new button%
+                                 (parent response-button-panel)
+                                 (enabled #f)
+                                 (callback
+                                  (lambda (x y)
+                                    (kill-thread cancel-kill-thread)
+                                    (switch-to-compose-view)))
+                                 (label (string-constant abort))))
+    (define response-close (new button%
+                                (parent response-button-panel)
+                                (enabled #f)
+                                (callback (lambda (x y) (cleanup-frame)))
+                                (label (string-constant close))))
+    
+    (define top-panel (make-object vertical-panel% outermost-panel))
+    
+    (define (switch-to-respose-view) (send single active-child response-panel))
+    (define (switch-to-compose-view) 
+      (send response-text erase)
+      (send single active-child outermost-panel))
+    
+    (define lps null)
+    
+    ; build/label : ((union string (list-of string))
+    ;                (area-container<%> -> item<%>) 
+    ;                boolean
+    ;                area-container<%>
+    ;             -> item<%>)
+    ; constructs and arranges the gui objects for the bug report form
+    ; effect: updates lps with the new label panel, for future alignment
+    (define build/label
+      (opt-lambda (text make-item top? [stretch? #f] [top-panel top-panel] [vertical? #f])
+        (let*-values ([(hp) (make-object (if vertical?
+                                             vertical-panel%
+                                             horizontal-panel%)
+                              top-panel)]
+                      [(lp) (make-object vertical-panel% hp)]
+                      [(ip) (make-object vertical-panel% hp)]
+                      [(label/s) (if (string? text)
+                                     (make-object message% text lp)
+                                     (map (lambda (s)
+                                            (make-object message% s lp))
+                                          text))]
+                      [(item) (make-item ip)])
+          (set! lps (cons lp lps))
+          (unless stretch? 
+            (send hp stretchable-height #f)
+            (send lp stretchable-height #f)
+            (send ip stretchable-height #f))
+          (send lp stretchable-width #f)
+          (send lp stretchable-height #f)
+          (send lp set-alignment (if vertical? 'left 'right) (if top? 'top 'center))
+          (send ip set-alignment 'left 'top)
+          item)))
+    
+    (define (align-labels)
+      (let ([width (apply max (map (lambda (x) (send (car (send x get-children)) min-width))
+                                   lps))])
+        (for-each (lambda (x) (send x min-width width)) lps))) 
+    
+    (define name
+      (build/label 
+       (string-constant bug-report-field-name)
+       (lambda (panel)
+         (keymap:call/text-keymap-initializer
+          (lambda ()
+            (make-object text-field% #f panel
+              (lambda (text event)
+                (preferences:set 'drscheme:full-name (send text get-value)))
+              (preferences:get 'drscheme:full-name)))))
+       #f))
+    
+    (define email  
+      (build/label
+       (string-constant bug-report-field-email)
+       (lambda (panel)
+         (keymap:call/text-keymap-initializer
+          (lambda ()
+            (make-object text-field% #f panel
+              (lambda (text event)
+                (preferences:set 'drscheme:email (send text get-value)))
+              (preferences:get 'drscheme:email)))))
+       #f))
+    
+    (define summary
+      (build/label
+       (string-constant bug-report-field-summary) 
+       (lambda (panel)
+         (keymap:call/text-keymap-initializer
+          (lambda ()
+            (make-object text-field% #f panel void))))
+       #f))
+    
+    (define severity
+      (build/label 
+       (string-constant bug-report-field-severity) 
+       (lambda (panel)
+         (make-object choice% 
+           #f
+           (list "critical" "serious" "non-critical")
+           panel
+           void))
+       #f))
+    
+    (define bug-classes '(("software bug" "sw-bug")
+                          ("documentation bug" "doc-bug")
+                          ("change request" "change-request")
+                          ("support" "support")))
+    
+    (define bug-class
+      (build/label
+       (string-constant bug-report-field-class)
+       (lambda (panel)
+         (make-object choice%
+           #f
+           (map car bug-classes)
+           panel
+           void))
+       #f))
+    
+    (define (translate-class class)
+      (cadr (assoc class bug-classes)))
+    
+    (define (make-big-text label . args)
+      (let ([canvas 
+             (apply
+              build/label 
+              label 
+              (lambda (panel)
+                (let* ([text (new (editor:standard-style-list-mixin
+				   (editor:keymap-mixin
+				    text:basic%)))]
+                       [canvas (make-object canvas:basic% panel text)])
+                  (send text set-paste-text-only #t)
+                  (send text set-styles-fixed #t)
+                  canvas))
+              #t
+              args)])
+        (send canvas min-width 500)
+        (send canvas min-height 130)
+        (send canvas get-editor)
+        (send canvas allow-tab-exit #t)
+        canvas))
+    
+    (define description (make-big-text (string-constant bug-report-field-description) #t))
+    (define reproduce (make-big-text (list (string-constant bug-report-field-reproduce1)
+                                           (string-constant bug-report-field-reproduce2))
+                                     #t))
+    
+    (define synthesized-dialog (make-object dialog% (string-constant bug-report-synthesized-information)))
+    (define synthesized-panel (make-object vertical-panel% synthesized-dialog))
+    (define synthesized-button-panel (make-object horizontal-panel% synthesized-dialog))
+    (define synthesized-ok-button (make-object button% (string-constant ok) synthesized-button-panel
+					       (lambda (x y)
+						 (send synthesized-dialog show #f))))
+    (define synthesized-info-shown? #t)
+    (define (show-synthesized-info)
+      (send synthesized-dialog show #t))
+    
+    (define version
+      (build/label
+       (string-constant bug-report-field-version)
+       (lambda (panel)
+         (keymap:call/text-keymap-initializer
+          (lambda ()
+            (make-object text-field% #f panel void ""))))
+       #f
+       #f
+       synthesized-panel
+       #f))
+    (define environment
+      (build/label
+       (string-constant bug-report-field-environment)
+       (lambda (panel)
+         (keymap:call/text-keymap-initializer
+          (lambda ()
+            (make-object text-field% #f panel void ""))))
+       #f
+       #f
+       synthesized-panel
+       #f))
+    
+    (define human-language
+      (build/label 
+       (string-constant bug-report-field-human-language)
+       (lambda (panel)            
+         (keymap:call/text-keymap-initializer
+          (lambda ()
+            (make-object text-field% #f panel void ""))))
+       #f
+       #f
+       synthesized-panel))
+    
+    (define docs-installed
+      (make-big-text
+       (string-constant bug-report-field-docs-installed)
+       #t
+       synthesized-panel))
+
+    (define collections
+      (make-big-text 
+       (string-constant bug-report-field-collections)
+       #t
+       synthesized-panel))
+    
+    (define extras
+      (map (lambda (bri)
+             (let ([label (bri-label bri)])
+               (cons
+                label
+                (build/label
+                 label
+                 (lambda (panel)
+                   (let ([field 
+                          (keymap:call/text-keymap-initializer
+                           (lambda ()
+                             (make-object text-field% #f panel void "")))])
+                     (send field set-value (bri-value bri))
+                     field))
+                 #f
+                 #f
+                 synthesized-panel))))
+           (get-bug-report-infos)))
+
+    (define button-panel (make-object horizontal-panel% outermost-panel))
+    (define synthesized-button (make-object button%
+                                 (string-constant bug-report-show-synthesized-info)
+                                 button-panel (lambda x (show-synthesized-info))))
+    (define ok-button (make-object button% (string-constant bug-report-submit) button-panel (lambda x (ok))))
+    (define cancel-button (make-object button% (string-constant cancel) button-panel (lambda x (cancel))))
+    (define grow-box-spacer-pane (make-object grow-box-spacer-pane% button-panel))
+    
+    (define (get-query)
+      (list (cons 'help-desk "true")
+            (cons 'replyto (preferences:get 'drscheme:email))
+            (cons 'originator (preferences:get 'drscheme:full-name))
+            (cons 'subject (send summary get-value))
+            (cons 'severity (send severity get-string-selection))
+            (cons 'class (translate-class (send bug-class get-string-selection)))
+            (cons 'release (send version get-value))
+            (cons 'description (apply string-append (map (lambda (x) (string-append x "\n")) 
+                                                         (get-strings description))))
+            (cons 'how-to-repeat (apply string-append (map (lambda (x) (string-append x "\n")) 
+                                                           (get-strings reproduce))))
+            (cons 'platform (get-environment))))
+    
+    (define (get-environment)
+      (string-append (send environment get-value)
+                     "\n"
+                     "Docs Installed:\n" 
+                     (format "~a" (send (send docs-installed get-editor) get-text))
+                     "\n"
+                     "Collections:\n"
+                     (format "~a" (send (send collections get-editor) get-text))
+                     "\n"
+                     (format "Human Language: ~a\n" (send human-language get-value))
+                     (apply 
+                      string-append
+                      (map (lambda (extra)
+                             (format "~a: ~a\n"
+                                     (car extra)
+                                     (send (cdr extra) get-value)))
+                           extras))))
+        
+    ;; smtp-send-bug-report : -> void
+    (define (smtp-send-bug-report)
+      (smtp-send-message
+       bug-email-server
+       (preferences:get 'drscheme:email)
+       (list bug-report-recipient)
+       (insert-field
+        "X-Mailer"
+        (format "Help Desk ~a (bug report form)" (version:version))
+        (insert-field     
+         "Subject" 
+         (send summary get-value)
+         (insert-field
+          "To"
+          bug-report-email-address
+          (insert-field
+           "From"
+           (format "~a <~a>" 
+                   (preferences:get 'drscheme:full-name)
+                   (preferences:get 'drscheme:email))
+           empty-header))))
+       `(">Category:       all"
+         ,(format ">Synopsis:       ~a" (send summary get-value))
+         ">Confidential:   no"
+         ,(format ">Severity:       ~a" (send severity get-string-selection))
+         ,(format ">Priority:       medium")
+         ,(format ">Class:          ~a" (translate-class (send bug-class get-string-selection)))
+         ">Submitter-Id:   unknown"
+         ,(format ">Originator:     ~a" (preferences:get 'drscheme:full-name))
+         ">Organization:"
+         "titan"
+         ,(format ">Release:        ~a" (send version get-value))
+         ">Environment:"
+         ,(format "~a" (send environment get-value))
+         "Docs Installed:" 
+         ,(format "~a" (send (send docs-installed get-editor) get-text))
+         "Collections: "
+         ,(format "~a" (send (send collections get-editor) get-text))
+         " "
+         ,(format "Human Language: ~a" (send human-language get-value))
+         " "
+         ,@(map (lambda (extra)
+                  (format "~a: ~a"
+                          (car extra)
+                          (send (cdr extra) get-value)))
+                extras)
+         ">Fix: "
+         ">Description:"
+         ,@(get-strings description)
+         ">How-To-Repeat:"
+         ,@(get-strings reproduce))
+       bug-email-server-port))
+    
+    ; send-bug-report : (-> void)
+    ;; initiates sending the bug report and switches the GUI's mode
+    (define (send-bug-report)
+      (letrec ([query (get-query)]
+               [url (make-url "http"
+                              #f
+                              bug-www-server
+                              bug-www-server-port
+                              (list "cgi-bin" "bug-report")
+                              '() ;query
+                              #f)]
+               [post-data 
+                (parameterize ([current-alist-separator-mode 'amp])
+                  (string->bytes/utf-8 (alist->form-urlencoded query)))]
+               [http-thread
+                (parameterize ([current-custodian (make-custodian)])
+                  (thread
+                   (lambda ()
+                     (with-handlers ([(lambda (x) (exn:break? x))
+                                      (lambda (x) (void))]
+                                     [(lambda (x) (not (exn:break? x)))
+                                      (lambda (x)
+                                        (queue-callback
+                                         (lambda ()
+                                           (switch-to-compose-view)
+                                           (message-box 
+                                            (string-constant error-sending-bug-report)
+                                            (format (string-constant error-sending-bug-report-expln)
+                                                    (if (exn? x)
+                                                        (exn-message x)
+                                                        (format "~s" x)))))))])
+                       (parameterize ([current-alist-separator-mode 'amp])
+                         (call/input-url 
+                          url
+                          (case-lambda
+                            [(x) (post-pure-port x post-data)]
+                            [(x y) (post-pure-port x post-data y)])
+                          (lambda (port) (render-html-to-text port response-text #t #f))))
+                       (queue-callback
+                        (lambda ()
+                          (send response-abort enable #f)
+                          (send response-reset enable #t)
+                          (send response-close enable #t)
+                          (set! cancel-kill-thread #f)
+                          (send bug-frame set-ok-to-close #t)))))))])
+        (set! cancel-kill-thread http-thread)
+        (send response-abort enable #t)
+        (switch-to-respose-view)))
+    
+    (define (get-strings canvas)
+      (let ([t (send canvas get-editor)])
+        (let loop ([n 0])
+          (cond
+            [(> n (send t last-paragraph)) null]
+            [else (cons (send t get-text
+                              (send t paragraph-start-position n)
+                              (send t paragraph-end-position n))
+                        (loop (+ n 1)))]))))
+    
+    (define (sanity-checking)
+      (let ([no-value?
+             (lambda (f)
+               (cond
+                 [(is-a? f editor-canvas%)
+                  (= 0 (send (send f get-editor) last-position))]
+                 [else (string=? "" (send f get-value))]))])
+        (let/ec done-checking
+          (for-each
+           (lambda (field field-name)
+             (when (no-value? field)
+               (message-box (string-constant illegal-bug-report)
+                            (format (string-constant pls-fill-in-field) field-name))
+               (done-checking #f)))
+           (list name summary)
+           (list (string-constant bug-report-field-name)
+                 (string-constant bug-report-field-summary)))
+          
+          (when (and (no-value? description)
+                     (no-value? reproduce))
+             (message-box (string-constant illegal-bug-report)
+                          (string-constant pls-fill-in-either-description-or-reproduce))
+             (done-checking #f))
+          
+          (unless (member #\@ (string->list (or (preferences:get 'drscheme:email) "")))
+            (message-box (string-constant illegal-bug-report)
+                         (string-constant malformed-email-address))
+            (done-checking #f))
+          (done-checking #t))))
+    
+    (define (ok)
+      (when (sanity-checking)
+        (send-bug-report)))
+    
+    (define (cancel)
+      (cleanup-frame))
+    
+    (define (cleanup-frame)
+      (send bug-frame close))
+        
+    (send severity set-selection 1)
+    (send version set-value   
+          (format "~a"
+                  (version:version)))
+
+    (send environment set-value   
+          (format "~a ~s (~a) (get-display-depth) = ~a"
+                  (system-type)
+                  (system-type #t)
+                  (system-library-subpath)
+                  (get-display-depth)))
+    
+    (send (send collections get-editor)
+          insert       
+          (format "~s"
+                  (map (lambda (x)
+                         (list x 
+                               (if (directory-exists? x)
+                                   (directory-list x)
+                                   "non-existent path")))
+                       (current-library-collection-paths))))
+    
+    (send human-language set-value (format "~a" (this-language)))
+    
+    (send (send collections get-editor) auto-wrap #t)
+    (send (send docs-installed get-editor) auto-wrap #t)
+    (send synthesized-button-panel set-alignment 'right 'center)
+    
+    (align-labels)
+    (send button-panel set-alignment 'right 'center)
+    (send button-panel stretchable-height #f)
+    (send (if (string=? "" (preferences:get 'drscheme:full-name))
+              name
+              summary)
+          focus)
+    
+    (send (send docs-installed get-editor) insert
+          (format "~s" (find-doc-directories)))
+    
+    (send bug-frame show #t))
+  
+  (define (ask-yes-or-no title msg parent)
+    (gui-utils:get-choice msg 
+                          (string-constant yes)
+                          (string-constant no)
+                          title
+                          #f
+                          parent)))
diff --git a/collects/help/doc.txt b/collects/help/doc.txt
new file mode 100644
index 0000000000..e390fdbb73
--- /dev/null
+++ b/collects/help/doc.txt
@@ -0,0 +1,377 @@
+The `help' collection provides tools for PLT _Help Desk_.
+
+The file help.ss is used to build the Help Desk launcher, which
+uses MrEd.  The file help-bg.ss is used to build a `background' 
+Help Desk launcher, which uses MzScheme.
+
+There are two modules that Help Desk clients may load.
+The file `help-desk-mz.ss' provides a set of functions that 
+use only MzScheme.  The file `help-desk.ss' provides all the 
+functions provided by `help-desk-mz.ss', plus some that rely 
+on MrEd.
+
+The MrEd-dependent functions provided by `help-desk.ss' are:
+
+> search-for-docs : hd-cookie search-string search-type match-type lucky? -> void
+
+The `hd-cookie' argument is returned by `start-help-server', below.
+Searches for `search-string' in the documentation, using `search-type' 
+and `match-type', and displays result in the Help Desk browser.  The 
+`search-type' is one of "keyword", "keyword-index", or "keyword-index-text".
+The `match-type' is one of "exact-match", "containing-match", or 
+"regexp-match".  The `lucky?' parameter indicates whether to do a 
+lucky search or not; it is considered true for any value other than #f.
+Side effect: the `search-type' and `match-type' values are stored as 
+preferences, reflected in the Help Desk search pane as the values  
+of options shown in drop-down lists.
+
+> goto-manual-link : hd-cookie manual index-key -> void
+
+The `hd-cookie' argument is returned by `start-help-server', below.
+The `manual' and `index-key' entries are strings.  The `manual' 
+argument is the string name of a doc collection, or "help"; 
+the second is an index entry in that manual.  When called,
+this procedure starts a Help Desk browser with the appropriate 
+manual page shown in the lower frame, if the requested entry 
+exists.  Otherwise, an error occurs.
+
+> goto-hd-location : hd-cookie sym -> void
+
+The `hd-cookie' argument is returned by `start-help-server',
+below.  The argument `sym' is a symbol in
+
+   '(hd-tour release-notes plt-license front-page)
+
+Sends a Help Desk browser on the page suggested by `sym',
+creating one if necessary.
+
+> help-desk-browser : hd-cookie -> void
+
+Starts the Help Desk browser on the Help Desk home page.  The 
+`hd-cookie' argument is obtained from `start-help-server', described 
+below.  If the user's default browser does not contact the
+Help Desk server within a certain time period, an internal PLT 
+browser is started instead.
+
+The following functions are provided by both `help-desk-mz.ss' and
+`help-desk.ss'.  These functions rely only on MzScheme:
+
+_Server functions_
+------------------
+
+> start-help-server : (browser-frame-mixin . -> . hd-cookie)
+
+Starts the Web server for Help Desk.  The optional argument
+`remote?' indicates whether remote connections should be
+allowed; the default is #f.  The optional argument `port' is
+an exact integer or #f, the default.  If a port number is
+given, the server attempts to use that port; otherwise, the
+server attempts to find an available port.  The optional
+argument browser-frame-mixin is mixed into the internal
+browser's frame class, if one is created.
+
+The return value is a structure that contains instance
+information about the server.  The cookie needs to be passed
+to some other Help Desk functions described here.  If the
+specified port is unavailable, or the server cannot find an
+unused port, an error occurs.
+
+> hd-cookie-port : hd-cookie -> number
+
+Given a Help Desk server cookie, returns the port number
+used by the server.
+
+> hd-cookie-shutdown-server : hd-cookie -> (-> void)
+
+Given a Help Desk server cookie, returns a thunk that 
+shuts down the server when called.
+
+> hd-cookie-find-browser : (hd-cookie?
+                            . -> . 
+                            (-> (union false? (is-a?/c frame%))))
+
+ Returns a procedure that finds a help desk browser
+ window. If none is available, returns #f.
+
+> hd-cookie? : obj -> boolean
+
+Returns #t if `obj' is a Help Desk cookie, #f otherwise. 
+
+> visit-url-in-browser : (hd-cookie? string? . -> . void?)
+
+ Visits the second argument in a browser, creating a
+ browser window if necessary.
+
+> visit-url-in-new-browser : (hd-cookie? string? . -> . void?)
+
+ Visits the second argument in a browser, always creating a
+ new browser window.
+
+_Manual ordering_
+-----------------
+
+> standard-html-doc-position : string -> number
+
+Given a manual name, returns a number (possibly negative)
+that indicates its standard search order position.
+
+> user-defined-doc-position : string -> (union number #f)
+
+Like standard-html-doc-position, but returns a weight 
+only if the user has assigned one using `set-doc-position!',
+described below.  If the user has not set a weight for the
+manual, #f is returned.  If the manual is not among `known-docs' 
+(see below), an error occurs.
+
+> set-doc-position! : string number -> void
+
+Sets the manual, indicated by the string argument, to 
+use the search order position given by the number argument.
+If the manual is not among `known-docs' (see below), an
+error occurs.
+
+> reset-doc-positions! : -> void
+
+Removes all the user-defined document weights that may have
+been set using `set-doc-position!', above.
+
+> known-docs : (listof (cons string string))
+
+A list of pairs, where each pair consists of a short-form name of a
+manual, suitable to pass to `standard-html-doc-position',
+`user-defined-doc-position', or `set-doc-position', and
+a full name for the manual.
+
+_Search functions_
+------------------
+
+> do-search : search-string num bool bool val f1 f2 f3 f4 -> (union string #f)
+
+Peforms a search for `search-string' in the documentation, and returns either 
+a string containing HTML or #f.  More details are provided in the file
+search.ss in the private subdirectory of the help collection.
+
+> doc-collections-changed : -> void
+
+Calling this procedure indicates to the Help Desk search engine that 
+the documentation collections have changed.
+
+_Important Help Desk URLs_
+---------------------------
+
+> make-home-page-url : number -> string
+
+given the port of the help desk server (from the cookie),
+returns a url for the homepage of help desk.
+
+_Manual listing_
+----------------
+
+> (find-manuals)
+
+ Returns HTML showing the installed documentation.
+
+_Manual search functions_
+-------------------------
+
+These functions are used to search for particular portions of
+documentation.
+
+> (finddoc manual index-key label)
+  This procedure accepts three strings. The first is the name of 
+  a doc collection, the second is an index entry in that manual, and 
+  the final is a desriptive string. It returns a string representation 
+  of an anchor (in HTML) that points to that index entry in the manual.
+  If the manual is not found, or the index-key is not in the manual,
+  it returns html code that shows an error. Because the link is
+  a "file:" link, it cannot link to a particular anchor in the target.
+  Note that "help" is not a valid value for `manual', because 
+  Help Desk content is not stored in a doc collection.
+
+> (findreldoc to-doc-path manual index-key label)
+  Like `finddoc', but `to-doc-path' is a Unix-style relative path that
+  reaches the "docs" collection. The resulting link is relative, and
+  it can point to a specific anchor in the target.
+
+> (finddoc-page-anchor manual index-key)
+  This procedure accepts two strings. The `manual' argument is the name 
+  of a doc collection, or "help"; the second is an index entry in that 
+  manual.  It returns a forward-slashed path to the manual or Help Desk 
+  entry, to be passed to the Help Desk web server.  For manuals in the 
+  doc collection, that path is of the form "/doc/manual/page#anchor"; 
+  for Help Desk entries, that path is of the form 
+  "/servlets/<rest-of-path>#anchor".  If the manual is not found, or the 
+  index-key is not in the manual, an error occurs.
+
+> (finddoc-page manual index-key)
+  Like `finddoc-page-anchor', but returns only the page, without
+  an anchor.
+
+_Supplemental Help Desk functions_
+----------------------------------
+
+> (set-bug-report-info! string thunk)
+
+  Adds dynamic information used when submitting a bug
+  report.
+
+  The string is the label for the information and the thunk
+  must return a string that is the current value of the
+  information.
+
+> (help-desk:installed-components)
+
+  It returns a string of XHTML with documentation extracted from the 
+  _'blurb_ fields of the info.ss files in each collection.
+
+_Creating Help Desk Documentation in doc.txt files_
+===================================================
+
+Help Desk reads doc.txt files that are named by info.ss
+files (in PLaneT, or in collections or thier
+subcollections). The info.ss file should have a line:
+
+  (define doc.txt "filename.txt")
+
+directing Help Desk to read the file named "filename.txt"
+(usually, by convention these files are named "doc.txt").
+
+Index Entry Annotations
+- - - - - - - - - - - -
+
+An index entry is specified by surrounding the indexed phrase with
+underscores, as for the current portion of this file.
+
+Keyword Entry Annotations
+- - - - - - - - - - - - -
+
+A keyword entry is specified using
+
+  >
+
+at the beginning of a line. After the ">", put an S-expression that
+contains only symbols. (Spaces between ">" and the S-expression are
+ignored.) The leftmost atom must be a symbol, and this symbol is used
+as the key for the entry, whereas the whole S-expression is displayed
+when the user searches on the key. (Note: the S-expression is read
+with `read-accept-bar-quote' turned off, since | is useful for showing
+alternatives.)
+
+For example, a keyword entry for `cons' might have the following form:
+
+ > (cons v list) - Constructs a new list by ...
+
+When the user searches on "cons", the Help Desk will display a link
+that looks something like
+
+ In mytools collection:
+   (cons v list) in "doc.txt"
+    ^^^^^^^^^^^
+Note that a search on "list" will not reveal this entry, because
+"cons" is used as the key, not the whole S-expression.
+
+To create a keyword entry where the key is *not* the leftmost symbol
+in the S-expression, use the follwing form:
+
+  > keyword :: S-expression
+
+where `keyword' is a Scheme symbol. The special "::" indicator
+instructs the Help Desk to look ahead one more S-expression. For
+example, documentation for a `set-title' method might appear as
+follows:
+
+  > set-title :: (send o set-title string) - sets the title
+
+The "(send o set-title string)" part allows a Help Desk user to learn
+about the calling convention of `set-title' without accessing the
+documentation directly.
+
+_Creating Help Desk Documentation in HTML format_
+===================================================
+
+Help Desk looks for html documentation in two places:
+
+  1) If an info.ss file defines _'html-docs_ to be a list of
+     path strings, Help Desk looks inside those directories
+     for html documentation (the paths are treated as
+     relative to the location of the info.ss file)�
+
+  2) Help Desk aslo looks inside each sub-directory in any
+     `doc' collection (Help Desk searches all doc
+     collections, not just the first one, unlike
+     `collection-path'). For example, the MzScheme manual is
+     in the directory plt/collects/doc/mzscheme. 
+
+The starting point for each manual must be called either:
+
+  index.htm
+  index.html
+  <jobname>.html, where <jobname>-Z-H-1.html
+                  also exists in the directory
+
+The last is to support tex2page generation of manuals.
+
+In addition to HTML files, a manual directory can contain a "keywords"
+file, which maps keywords to HTML pages and labels, and an "hdindex"
+file, which similarly maps index entries HTML pages.
+
+The _"keywords"_ File
+- - - - - - - - - - -
+
+The "keywords" file must contain one S-expression (not evaluated),
+which is a list of keyword entries. Each keyword entry is a list of
+five values:
+
+  * keyword - a string, e.g., "cons"
+
+  * result display - a string to be displayed in the search results
+    window when the user searches on the keyword, e.g., "(cons v
+    list)"
+
+  * HTML file - a file name relative to the manual's directory, e.g.,
+    "node198.htm"
+
+  * HTML label - a string reprsenting a label within the HTML file
+
+  * page title - a string presenting the title of the HTML page, e.g.,
+    "List Procedures"
+
+See plt/collects/doc/mzscheme/keywords for an example.
+
+The _"hdindex"_ File
+- - - - - - - - - -
+
+The "hdindex" file is similar to the "keywords" file; it must contain
+one S-expression (not evaluated), which is a list of index entries.
+Each index entry is a list of four values:
+
+  * indexed item - a string, e.g., "creating help desk documents"
+
+  * HTML file - a file name (represented as a bytes)
+    relative to the manual's directory, e.g., #"node198.htm"
+
+  * HTML label - a string reprsenting a label within the HTML file
+
+  * page title - a string presenting the title of the HTML page, e.g.,
+    "How to Create Help Desk Documents"
+
+See plt/collects/doc/mzscheme/hdindex for an example.
+
+
+The _'blurb field_ of the _info.ss_ file
+- - - - - - - - - - - - - - - - - - - - 
+
+The 'blurb field of the info.txt file should be a list of xexprs (see the
+xml documentation for information on the xexpr datatype) that correspond to
+the html that help desk can parse. If a collection's info.ss file returns
+such a list, the blurb is inserted into the ``installed components'' page
+of the help desk documentation.
+
+The _'help-desk-message field_ of the _info.ss_ file
+- - - - - - - - - - - - - - - - - - - - - - - - - -
+
+This field must be a string that is displayed at the top of the Help Desk
+results window, in green, when the doc.txt file of this collection is displayed. 
+It should be a single line, describing how to load the library with a prefix
+specifing the applicable language levels.
+  
diff --git a/collects/help/help-desk.ss b/collects/help/help-desk.ss
new file mode 100644
index 0000000000..5dc7e1901e
--- /dev/null
+++ b/collects/help/help-desk.ss
@@ -0,0 +1,40 @@
+(module help-desk mzscheme
+  (require 
+   "bug-report.ss" ;; this is require'd here to get the prefs defaults setup done early.
+   
+   "private/manuals.ss"
+   "private/buginfo.ss"
+   "private/standard-urls.ss"
+   
+   "private/link.ss"
+   (lib "contract.ss"))
+  
+  (provide help-desk-frame<%>)
+  
+  (define (goto-hd-location x) (error 'goto-hd-location "no"))
+  
+  (provide/contract 
+   (set-bug-report-info! any/c)
+   (find-doc-names (-> (listof (cons/c path? string?))))
+   (goto-manual-link (any/c string? string? . -> . any))
+   
+   (goto-hd-location (symbol? . -> . any))
+   (new-help-desk (-> (is-a?/c help-desk-frame<%>)))
+   (show-help-desk (-> any))
+   (add-help-desk-mixin (-> mixin-contract void?))
+   (search-for-docs (string?
+                     search-type?
+                     search-how?
+                     any/c
+                     (listof path?) ;; manual names
+                     . -> .
+                     any))
+   (find-help-desk-frame (-> (union false/c (is-a?/c help-desk-frame<%>))))
+   (search-for-docs/in-frame ((is-a?/c help-desk-frame<%>)
+                              string?
+                              search-type?
+                              search-how?
+                              any/c
+                              (listof path?) ;; manual names
+                              . -> .
+                              any))))
diff --git a/collects/help/help.creator b/collects/help/help.creator
new file mode 100644
index 0000000000..9641eb7dfb
--- /dev/null
+++ b/collects/help/help.creator
@@ -0,0 +1,2 @@
+H!D!
+(This code is registered with Apple.)
diff --git a/collects/help/help.icns b/collects/help/help.icns
new file mode 100644
index 0000000000..0a42b952ae
Binary files /dev/null and b/collects/help/help.icns differ
diff --git a/collects/help/help.ico b/collects/help/help.ico
new file mode 100644
index 0000000000..113239a7f1
Binary files /dev/null and b/collects/help/help.ico differ
diff --git a/collects/help/help.ss b/collects/help/help.ss
new file mode 100644
index 0000000000..976bb8df58
--- /dev/null
+++ b/collects/help/help.ss
@@ -0,0 +1,56 @@
+#|
+
+This file contains all of the initialization of the Help Desk application.
+It is only loaded when Help Desk is run by itself (outside DrScheme).
+
+|#
+
+(module help mzscheme 
+  (require "bug-report.ss" ;; load now to init the preferences early
+           (lib "cmdline.ss")
+           (lib "class.ss")
+           (lib "framework.ss" "framework")
+           (lib "external.ss" "browser")
+           "private/link.ss"
+           (lib "string-constant.ss" "string-constants")
+           (lib "mred.ss" "mred"))
+  
+  (command-line
+   "help-desk"
+   (current-command-line-arguments))
+  
+  (preferences:add-panel
+   (list (string-constant font-prefs-panel-title))
+   (lambda (panel)
+     (let* ([hp (new horizontal-panel% (parent panel))]
+            [size (make-object slider% 
+                    (string-constant font-size)
+                    1
+                    72
+                    hp
+                    (lambda (size evt)
+                      (preferences:set 'framework:standard-style-list:font-size (send size get-value)))
+                    (preferences:get 'framework:standard-style-list:font-size))])
+       (preferences:add-callback
+        'framework:standard-style-list:font-size
+        (lambda (p v) (send size set-value v)))
+       hp)))
+  (color-prefs:add-background-preferences-panel)
+  (preferences:add-warnings-checkbox-panel)
+  (install-help-browser-preference-panel)
+  
+   ;; for use by the bug report frame.
+  ;(namespace-set-variable-value! 'help-desk:frame-mixin (make-bug-report/help-desk-mixin 'the-hd-cookie))
+  
+  (handler:current-create-new-window 
+   (lambda (filename) 
+     (let ([browser-frame '((hd-cookie-new-browser the-hd-cookie))])
+       (when (and filename
+                  (file-exists? filename))
+         (send (send (send browser-frame get-hyper-panel) get-canvas) goto-url
+               (string-append "file://" filename)
+               #f))
+       browser-frame)))
+
+  (new-help-desk))
+  
\ No newline at end of file
diff --git a/collects/help/info.ss b/collects/help/info.ss
new file mode 100644
index 0000000000..5c67863dff
--- /dev/null
+++ b/collects/help/info.ss
@@ -0,0 +1,18 @@
+; help collection
+(module info (lib "infotab.ss" "setup")
+  (define name "Help")
+  (define doc.txt "doc.txt")
+  (define compile-subcollections 
+    '(("help" "private")
+      ("help" "servlets")
+      ("help" "servlets" "private")
+      ("help" "servlets" "release")
+      ("help" "servlets" "research")
+      ("help" "servlets" "resources")
+      ("help" "servlets" "scheme")
+      ("help" "servlets" "scheme" "misc")))
+  (define help-desk-message
+    "Mr: (require (lib \"help-desk.ss\" \"help\"))")
+  (define mred-launcher-libraries (list "help.ss"))
+  (define mred-launcher-names (list "Help Desk"))
+  (define install-collection "installer.ss"))
diff --git a/collects/help/installer.ss b/collects/help/installer.ss
new file mode 100644
index 0000000000..83df745d35
--- /dev/null
+++ b/collects/help/installer.ss
@@ -0,0 +1,119 @@
+(module installer mzscheme
+  (provide installer)
+  
+  (require (lib "match.ss")
+	   (lib "file.ss")
+	   (lib "list.ss"))
+  
+  (define installer
+    (lambda (path)   
+      (create-index-file)))
+  
+  (define (create-index-file)
+    (when (file-exists? index-file)
+      (delete-file index-file))
+    (gen-index servlet-dir)
+    (let ([output-port (open-output-file (build-path dest-dir index-file))])
+      (fprintf output-port "(~n")
+      (let loop ([index index])
+	(if (null? index)
+	    (begin
+	      (fprintf output-port ")~n")
+	      (close-output-port output-port))
+	    (begin 
+	      (fprintf output-port "~s~n" (car index))
+	      (loop (cdr index)))))))
+  
+  (define servlet-dir (normalize-path 
+		       (build-path (collection-path "help") "servlets")))
+  (define exploded-servlet-dir-len (length (explode-path servlet-dir)))
+  
+  ;; assume that there is only a single `help' collection and that the
+  ;; original PLT tree help directory is a sibling of that.
+  (define dest-dir (build-path (collection-path "help") 'up "doc" "help"))
+  
+  (unless (directory-exists? dest-dir)
+    (make-directory* dest-dir))
+  (current-directory dest-dir)
+  
+  (define index-file "hdindex")
+  
+  (define (get-servlet-files dir)
+    (let* ([all-files 
+	    (map (lambda (f) (build-path dir f))
+		 (directory-list dir))]
+	   [servlet-files 
+	    (filter 
+	     (lambda (s)
+	       (regexp-match #rx#"[.]ss$" (path->bytes s)))
+	     all-files)]
+	   [dirs 
+	    (filter directory-exists? all-files)])
+      (apply append servlet-files
+	     (map get-servlet-files dirs))))
+  
+  ; path is absolute, and has the servlet dir as a prefix 
+  (define (relativize-and-slashify path)
+    (let* ([exp-path (explode-path path)]
+	   [prefix-len (sub1 exploded-servlet-dir-len)]
+	   [relative-exp-path
+	    (let loop ([p exp-path]
+		       [n 0])
+	      ; leave off prefix up to servlet dir
+	      (if (>= n prefix-len)
+		  p
+		  (loop (cdr p) (add1 n))))])
+      (fold-into-web-path (map path->string relative-exp-path))))
+  
+  ; (listof string) -> string
+  ; result is forward-slashed web path
+  ;  e.g. ("foo" "bar") -> "foo/bar"
+  (define (fold-into-web-path lst)
+    (foldr (lambda (s a)
+             (if a
+                 (bytes-append (path->bytes s) #"/" a)
+                 (path->bytes s)))
+           #f
+           lst))
+  
+  (define index '())
+  
+  (define (add-index-entry! val file name title)
+    (set! index 
+	  (cons
+	   (list val
+                 (bytes-append #"/" (relativize-and-slashify file))
+		 name
+		 title)
+	   index)))
+  
+  (define (gen-index dir)
+    (let* ([all-files (directory-list)]
+           [servlet-files (get-servlet-files dir)])
+      (for-each
+       (lambda (file)
+         (let ([port (open-input-file file)]
+               [title-value file])
+           (let loop ()
+             (let ([sexp (with-handlers ([exn:fail:read?
+                                          (lambda (x) 
+                                            (fprintf (current-error-port)
+                                                     "couldn't read ~a: ~a\n"
+                                                     file
+                                                     (if (exn? x)
+                                                         (exn-message x)
+                                                         (format "~s" x)))
+                                            #f)])
+                           (read port))])
+               (unless (eof-object? sexp)
+                 (let loop ([exp sexp])
+                   (match exp
+                     [`(title ,(? string? title))
+                      (set! title-value title)]
+                     [`(a ((name ,(? string? name)) (value ,(? string? value))))
+                      (add-index-entry! value file name title-value)]
+                     [_ (when (pair? exp)
+                          (begin (loop (car exp))
+                                 (loop (cdr exp))))]))
+                 (loop))))))
+       servlet-files))))
diff --git a/collects/help/private/buginfo.ss b/collects/help/private/buginfo.ss
new file mode 100644
index 0000000000..010524c632
--- /dev/null
+++ b/collects/help/private/buginfo.ss
@@ -0,0 +1,21 @@
+(module buginfo mzscheme
+
+  (provide set-bug-report-info!
+           get-bug-report-infos
+           bri-label
+           bri-value)
+
+  (define-struct bri (label get-value))
+  (define (bri-value bri) ((bri-get-value bri)))
+  
+  ; update with symbol/string assoc list
+  (define bug-report-infos null)
+
+  (define (set-bug-report-info! str thunk)
+    (set! bug-report-infos (cons (make-bri str thunk) bug-report-infos)))
+
+  (define (get-bug-report-infos) bug-report-infos))
+
+
+
+
diff --git a/collects/help/private/colldocs.ss b/collects/help/private/colldocs.ss
new file mode 100644
index 0000000000..442f50ac9b
--- /dev/null
+++ b/collects/help/private/colldocs.ss
@@ -0,0 +1,82 @@
+(module colldocs mzscheme
+  (require (lib "list.ss")
+           (lib "getinfo.ss" "setup")
+           (lib "contract.ss"))
+  
+  (provide/contract 
+   [colldocs (-> (values (listof (list/c path? path?))
+                         (listof string?)))])
+
+  (define (colldocs)
+    (let loop ([dirs (find-relevant-directories '(doc.txt) 'all-available)]
+               [docs null]
+               [names null])
+      (cond
+        [(null? dirs)
+         (values docs names)]
+        [else (let* ([dir (car dirs)]
+                     [info-proc (get-info/full dir)])
+                (if info-proc
+                    (let ([doc.txt-path (info-proc 'doc.txt (lambda () #f))]
+                          [name (info-proc 'name (lambda () #f))])
+                      (if (and (path-string? doc.txt-path)
+                               (string? name))
+                          (loop (cdr dirs)
+                                (cons (list dir
+                                            (string->path doc.txt-path))
+                                      docs)
+                                (cons name names))
+                          (loop (cdr dirs) docs names)))
+                    (loop (cdr dirs) docs names)))])))
+                        
+  
+  ; Gets a list of collections that contain a doc.txt file
+  ; returns two parallel lists.
+  ; the first has the locations of the docs and the second is their names.
+  #;
+  (define (colldocs)
+    (let loop ([collection-paths (current-library-collection-paths)]
+               [docs null]
+               [names null])
+      (cond
+	[(null? collection-paths)
+	 (let* ([collections-docs (map cons docs names)]
+		[l (quicksort collections-docs
+			      (lambda (a b) (string<? (cdr a) (cdr b))))])
+	   (values (map car l) (map cdr l)))]
+	[else (let ([path (car collection-paths)])
+		(let cloop ([l (with-handlers ([exn:fail:filesystem? (lambda (x) null)])
+                                 (directory-list path))]
+			    [path path]
+			    [collpath null]
+			    [docs docs]
+			    [names names])
+                  (cond
+                    [(null? l) (if (null? collpath)
+                                   (loop (cdr collection-paths) docs names)
+                                   (values docs names))]
+                    [else 
+                     (let* ([coll (car l)]
+                            [colldir (build-path path coll)])
+                       (cond
+                         [(and (directory-exists? colldir)
+                               (not (member (path->string coll) names)))
+                          (let* ([lcollpath (append collpath (list coll))]
+                                 [doc-txt-file (list colldir (string->path "doc.txt"))]
+                                 [this? (file-exists? (apply build-path doc-txt-file))])
+                            (let-values ([(sub-docs sub-names)
+                                          (with-handlers ([exn:fail:filesystem?
+                                                           (lambda (x) (values null null))])
+                                            (let ([info-proc/f (get-info lcollpath)])
+                                              (if info-proc/f
+                                                  (let ([l (info-proc/f 'doc-sub-collections (lambda () null))])
+                                                    (cloop (map string->path l) colldir lcollpath null null))
+                                                  (values null null))))])
+                              (let ([sub-names (map (lambda (s) (string-append (path->string coll) " " s)) sub-names)])
+                                (let-values ([(ldocs lnames)
+                                              (if this?
+                                                  (values (cons doc-txt-file sub-docs)
+                                                          (cons (path->string coll) sub-names))
+                                                  (values sub-docs sub-names))])
+                                  (cloop (cdr l) path collpath (append ldocs docs) (append lnames names))))))]
+                         [else (cloop (cdr l) path collpath docs names)]))])))]))))
diff --git a/collects/help/private/config.ss b/collects/help/private/config.ss
new file mode 100644
index 0000000000..392d3a2f93
--- /dev/null
+++ b/collects/help/private/config.ss
@@ -0,0 +1,51 @@
+(module config mzscheme
+  (require (lib "file.ss")
+           (lib "configuration.ss" "web-server")
+           "internal-hp.ss")
+  
+  (provide config)
+  
+  (define config
+    (let* ([build-normal-path
+            (lambda args
+              (normalize-path
+               (apply build-path args)))]
+           [help-path (build-normal-path (collection-path "help"))]
+           [doc-path (build-normal-path help-path 'up "doc")]
+           [host-root (build-normal-path help-path "web-root")]
+           [servlet-root help-path]
+           [make-host-config
+            (λ (file-root)
+              `(host-table
+                (default-indices "index.html" "index.htm")
+                (log-format parenthesized-default)
+                (messages
+                 (servlet-message "servlet-error.html")
+                 (authentication-message "forbidden.html")
+                 (servlets-refreshed "servlet-refresh.html")
+                 (passwords-refreshed "passwords-refresh.html")
+                 (file-not-found-message "not-found.html")
+                 (protocol-message "protocol-error.html"))
+                (timeouts
+                 (default-servlet-timeout 120)
+                 (password-connection-timeout 300)
+                 (servlet-connection-timeout 86400)
+                 (file-per-byte-connection-timeout 1/20)
+                 (file-base-connection-timeout 30))
+                (paths
+                 (configuration-root "conf")
+                 (host-root ,host-root)
+                 (log-file-path "log")
+                 (file-root ,file-root)
+                 (servlet-root ,servlet-root)
+                 (password-authentication "passwords"))))])
+      (build-developer-configuration/vhosts
+       `((port ,internal-port)
+         (max-waiting 40)
+         (initial-connection-timeout 30)
+         (default-host-table
+           ,(make-host-config (build-normal-path doc-path 'up)))
+         (virtual-host-table
+          (,addon-host 
+           ,(make-host-config
+             (build-path (find-system-path 'addon-dir))))))))))
diff --git a/collects/help/private/docpos.ss b/collects/help/private/docpos.ss
new file mode 100644
index 0000000000..e56569baee
--- /dev/null
+++ b/collects/help/private/docpos.ss
@@ -0,0 +1,81 @@
+(module docpos mzscheme
+  (require (lib "list.ss")
+           (lib "contract.ss"))
+
+  (provide/contract
+   [standard-html-doc-position (path? . -> . number?)]
+   [user-defined-doc-position (path? . -> . (union false/c number?))]
+   [known-docs (listof (cons/c path? string?))]
+   [set-doc-position! (path? number? . -> . void?)]
+   [reset-doc-positions! (-> void?)])
+  
+  ;; Define an order on the standard docs.
+  (define (standard-html-doc-position d)
+    (if (equal? d (string->path "help"))
+        -1
+        (let ([line (assoc d docs-and-positions)])
+          (if line
+              (caddr line)
+              100))))
+
+  (define user-doc-positions '())
+
+  (define (set-doc-position! manual weight)
+    (unless (assoc manual known-docs)
+      (error 'set-doc-position! "unknown manual ~s" manual))
+    (set! user-doc-positions
+          (cons (list manual weight)
+                (filter (lambda (x) (not (equal? (car x) manual)))
+                        user-doc-positions))))
+
+  (define (reset-doc-positions!)
+    (set! user-doc-positions '()))
+
+  (define (user-defined-doc-position manual)
+    (let ([result (assoc manual user-doc-positions)])
+      (and result (cadr result))))
+  
+  ;; (listof (list string string number))
+  ;; the first string is the collection name
+  ;; the second string is the title of the the manual
+  ;; the number determines the sorting order for the manuals in the manuals page
+  (define docs-and-positions
+    `(("r5rs" "Revised^5 Report on the Algorithmic Language Scheme" -50)
+      ("mzscheme" "PLT MzScheme: Language Manual" -49)
+      ("mred" "PLT MrEd: Graphical Toolbox Manual" -48)
+            
+      ("beginning" "Beginning Student Language" -19)
+      ("beginning-abbr" "Beginning Student with List Abbreviations Language" -18)
+      ("intermediate" "Intermediate Student Language" -17)
+      ("intermediate-lambda" "Intermediate Student with Lambda Language" -16)
+      ("advanced" "Advanced Student Language" -15)
+      ("teachpack" "Teachpacks for How to Design Programs" -16)
+      
+      ("profj-beginner" "ProfessorJ Beginner Language" -10)
+      ("profj-intermediate" "ProfessorJ Intermediate Language" -9)
+      ("profj-advanced" "ProfessorJ Advanced Language" -8)
+      
+      ("tour" ,(format "A Brief Tour of DrScheme version ~a" (version)) 0)
+      ("drscheme" "PLT DrScheme: Programming Environment Manual" 1)
+      
+      ("srfi" "SRFI documents inside PLT" 3)
+      
+      ("mzlib" "PLT MzLib: Libraries Manual" 5)
+      ("misclib" "PLT Miscellaneous Libraries: Reference Manual" 6)
+      ("mrlib" "PLT MrLib: Graphical Libraries Manual" 7)
+      ("framework" "PLT Framework: GUI Application Framework" 8)
+
+      ("mzc" "PLT mzc: MzScheme Compiler Manual" 10)
+      ("foreign" "PLT Foreign Interface Manual" 10)
+      
+      ("tools" "PLT Tools: DrScheme Extension Manual" 30)
+      ("insidemz" "Inside PLT MzScheme" 50)
+
+      ("swindle"    "Swindle Manual"    60)
+      ("plot"       "PLoT Manual"       61)
+      ("web-server" "Web Server Manual" 62)
+
+      ("t-y-scheme" "Teach Yourself Scheme in Fixnum Days" 100)
+      ("tex2page" "TeX2page" 101)))
+  
+  (define known-docs (map (lambda (x) (cons (string->path (car x)) (cadr x))) docs-and-positions)))
diff --git a/collects/help/private/finddoc.ss b/collects/help/private/finddoc.ss
new file mode 100644
index 0000000000..90aade2191
--- /dev/null
+++ b/collects/help/private/finddoc.ss
@@ -0,0 +1,82 @@
+(module finddoc mzscheme
+  (require "path.ss")
+
+  (provide finddoc
+	   findreldoc
+           finddoc-page
+	   finddoc-page-anchor)
+  
+  ;; Creates a "file:" link into the indicated manual.
+  ;; The link doesn't go to a particular anchor,
+  ;; because "file:" does not support that.
+  (define (finddoc manual index-key label)
+    (let ([m (lookup manual index-key label)])
+      (if (string? m)
+          m
+          (format "<A href=\"file:~a\">~a</A>"
+                  (build-path (car m) (caddr m))
+                    label))))
+
+  ;; Given a Unix-style relative path to reach the "doc"
+  ;; collection, creates a link that can go to a
+  ;; particular anchor.
+  (define (findreldoc todocs manual index-key label)
+    (let ([m (lookup manual index-key label)])
+      (if (string? m)
+          m
+          (format "<A href=\"~a/~a/~a#~a\">~a</A>"
+                  todocs
+                  manual
+                  (caddr m)
+                  (cadddr m)
+                  label))))
+
+  (define (finddoc-page-help manual index-key anchor?)
+    (let ([m (lookup manual index-key "dummy")])
+      (if (string? m)
+          (error (format "Error finding index \"~a\" in manual \"~a\""
+                         index-key manual))
+          (let ([path (if anchor?
+                          (string-append (caddr m) "#" (cadddr m))
+                          (caddr m))])
+            (if (servlet-path? path)
+                path
+                (format "/doc/~a/~a" manual path))))))
+  
+  ; finddoc-page : string string -> string
+  ; returns path for use by PLT Web server
+  ;  path is of form /doc/manual/page, or
+  ;  /servlet/<rest-of-path>
+  (define (finddoc-page manual index-key)
+    (finddoc-page-help manual index-key #f))
+
+  ; finddoc-page-anchor : string string -> string
+  ; returns path (with anchor) for use by PLT Web server
+  ;  path is of form /doc/manual/page#anchor, or
+  ;  /servlet/<rest-of-path>#anchor
+  (define (finddoc-page-anchor manual index-key)
+    (finddoc-page-help manual index-key #t))
+
+  (define ht (make-hash-table))
+  
+  ;; returns either a string (failure) or
+  ;; (list docdir index-key filename anchor title)
+  (define (lookup manual index-key label)
+    (let ([key (string->symbol manual)]
+	  [docdir (build-path (collection-path "doc") manual)])
+      (let ([l (hash-table-get
+		ht
+		key
+		(lambda ()
+		  (let ([f (build-path docdir "hdindex")])
+                    (if (file-exists? f)
+                        (let ([l (with-input-from-file f read)])
+                          (hash-table-put! ht key l)
+                          l)
+                        (error 'finddoc "manual index ~s not installed" manual)))))])
+	(let ([m (assoc index-key l)])
+	  (if m 
+	      (cons docdir m)
+	      (error 'finddoc "index key ~s not found in manual ~s" index-key manual)))))))
+
+
diff --git a/collects/help/private/get-help-url.ss b/collects/help/private/get-help-url.ss
new file mode 100644
index 0000000000..ce6ad76383
--- /dev/null
+++ b/collects/help/private/get-help-url.ss
@@ -0,0 +1,63 @@
+(module get-help-url mzscheme
+  
+  #| Library responsible for turning a path on disk into a URL the help desk can use |#
+  (require (lib "file.ss")
+           "internal-hp.ss"
+           (lib "contract.ss")
+           (lib "etc.ss"))
+  
+  (provide/contract (get-help-url
+                     (((lambda (x)
+                        (or (path? x)
+                            (path-string? x))))
+                      (string?)
+                      . opt-> . string?)))
+  
+  ; given a manual path, convert to absolute Web path
+  ; manual path is an anchored path to a collects/doc manual, never a servlet
+  (define get-help-url
+    (opt-lambda (manual-path [anchor #f])
+      (let ([segments (explode-path (normalize-path manual-path))])
+        (let loop ([candidates manual-path-candidates])
+          (cond
+            ;; shouldn't happen, unless documentation is found outside the user's addon dir
+            ;; and also outside the PLT tree.
+            [(null? candidates) "/cannot-find-docs.html"]
+            [else
+             (let ([candidate (car candidates)])
+               (cond
+                 [(subpath/tail (car candidate) segments)
+                  =>
+                  (λ (l-o-path)
+                     ((cadr candidate) l-o-path anchor))]
+                 [else (loop (cdr candidates))]))])))))
+  
+  (define manual-path-candidates '())
+  (define (maybe-add-candidate candidate host)
+    (with-handlers ([exn:fail? void])
+      (set! manual-path-candidates
+            (cons (list (explode-path (normalize-path candidate))
+                        (λ (segments anchor)
+                           (format "http://~a:~a~a~a"
+                                   host
+                                   internal-port
+                                   (apply string-append (map (λ (x) (format "/~a" (path->string x))) 
+                                                             segments))
+                                   (if anchor
+                                       (string-append "#" anchor)
+                                       ""))))
+                  manual-path-candidates))))
+  (define stupid-internal-define-syntax1
+    (maybe-add-candidate (build-path (collection-path "doc") 'up) internal-host))
+  (define stupid-internal-define-syntax2
+    (maybe-add-candidate (build-path (find-system-path 'addon-dir)) addon-host))
+  
+  (define (subpath/tail short long)
+    (let loop ([short short]
+               [long long])
+      (cond
+        [(null? short) long]
+        [(null? long) #f]
+        [(equal? (car short) (car long))
+         (loop (cdr short) (cdr long))]
+        [else #f]))))
\ No newline at end of file
diff --git a/collects/help/private/gui.ss b/collects/help/private/gui.ss
new file mode 100644
index 0000000000..8d8d73a1e0
--- /dev/null
+++ b/collects/help/private/gui.ss
@@ -0,0 +1,597 @@
+
+(module gui mzscheme
+  (require (lib "framework.ss" "framework")
+           (lib "mred.ss" "mred")
+           
+           (lib "class.ss")
+           (lib "contract.ss")
+           (lib "etc.ss")
+           (lib "unitsig.ss")
+           (lib "list.ss")
+           
+           (lib "string-constant.ss" "string-constants")
+           (lib "external.ss" "browser")
+           
+           (lib "browser-sig.ss" "browser")
+           (lib "url-sig.ss" "net")
+           "sig.ss"
+           "../bug-report.ss"
+           (lib "bday.ss" "framework" "private")
+           
+           "standard-urls.ss"
+           "docpos.ss"
+           "manuals.ss"
+           
+           "internal-hp.ss")
+  
+  (provide gui@)
+  
+  (define gui@
+    (unit/sig gui^
+      (import browser^
+              net:url^)
+      
+      (define help-desk-frame<%>
+        (interface (frame:standard-menus<%>)
+          order-manuals
+          get-language-name
+          change-search-to-status
+          set-search-status-contents
+          change-status-to-search))
+
+      (define bug-report/help-desk-mixin
+        (mixin (frame:standard-menus<%>) ()
+          (define/override (file-menu:create-open-recent?) #f)
+          (define/override (help-menu:about-string)
+            (string-constant plt:hd:about-help-desk))
+          (define/override (help-menu:about-callback i e)
+            (message-box (string-constant plt:hd:about-help-desk)
+                         (format 
+                          (string-constant plt:hd:help-desk-about-string)
+                          (version:version))
+                         this))
+          (define/override (help-menu:create-about?) #t)
+          (define/override (help-menu:after-about menu)
+            (make-object menu-item% (string-constant plt:hd:help-on-help) menu
+              (lambda (i e)
+                (message-box
+                 (string-constant plt:hd:help-on-help)
+                 (string-constant plt:hd:help-on-help-details)
+                 this)))
+            (new menu-item%
+                 (label (string-constant bug-report-submit-menu-item))
+                 (parent menu)
+                 (callback
+                  (lambda (x y)
+                    (help-desk:report-bug)))))
+          (super-new)))
+      
+      (define (browser-scroll-frame-mixin %)
+        (class %
+          (inherit get-hyper-panel)
+          
+          (define/override (on-subwindow-char w e)
+            (or (let ([txt (send (send (get-hyper-panel) get-canvas) get-editor)])
+                  (and txt
+                       (let ([km (send txt get-hyper-keymap)])
+                         (send km handle-key-event txt e))))
+                (super on-subwindow-char w e)))
+          
+          (super-new)))
+      
+      ;; redirect urls to outside pages to external browsers (depending on the preferences settings)
+      ;; also catches links into documentation that isn't installed yet and sends that
+      ;; to the missing manuals page.
+      (define make-catch-url-frame-mixin
+        (let ()
+          (define (catch-url-hyper-panel-mixin %)
+            (class %
+              (define/override (get-canvas%)
+                (catch-url-canvas-mixin (super get-canvas%)))
+              (super-new)))
+          
+          (define (catch-url-canvas-mixin %)
+            (class %
+              
+              (define/override (get-editor%) (hd-editor-mixin (super get-editor%)))
+              
+              (define/override (remap-url url)
+                (cond
+                  [(url? url)
+                   (cond
+                     
+                     ;; .plt files are always internal, no matter where from
+                     ;; they will be caught elsewhere.
+                     [(and (url-path url)
+                           (not (null? (url-path url)))
+                           (regexp-match #rx".plt$" (car (last-pair (url-path url)))))
+                      url]
+                     
+                     ;; files on download.plt-scheme.org in /doc are considered
+                     ;; things that we should view in the browser itself.
+                     [(is-download.plt-scheme.org/doc-url? url)
+                      url]
+                     
+                     ;; on the internal host
+                     [(and (equal? internal-host (url-host url))
+                           (equal? internal-port (url-port url)))
+                      (let* ([path (url-path url)]
+                             [coll (and (pair? path)
+                                        (pair? (cdr path))
+                                        (cadr path))])
+                        ;; check to see if the docs are installed
+                        (if (and coll
+                                 (assoc coll known-docs)
+                                 (not (has-index-installed? (string->path coll))))
+                            (let ([doc-pr (assoc coll known-docs)]
+                                  [url-str (url->string url)])
+                              (make-missing-manual-url  coll (cdr doc-pr) url-str))
+                            url))]
+                     
+                     [(and (equal? addon-host (url-host url))
+                           (equal? internal-port (url-port url)))
+                      url]
+                     
+                     ;; send the url off to another browser
+                     [(or (and (preferences:get 'drscheme:help-desk:ask-about-external-urls)
+                               (ask-user-about-separate-browser))
+                          (preferences:get 'drscheme:help-desk:separate-browser))
+                      (send-url (url->string url))
+                      #f]
+                     
+                     [else url])]
+                  [else url]))
+              (super-new)))
+          
+          ;; has-index-installed? : path -> boolean
+          (define (has-index-installed? doc-coll)
+            (let loop ([docs-dirs (find-doc-directories)])
+              (cond
+                [(null? docs-dirs) #f]
+                [else
+                 (let ([doc-dir (car docs-dirs)])
+                   (let-values ([(base name dir?) (split-path doc-dir)])
+                     (or (and (equal? doc-coll name)
+                              (get-index-file doc-dir))
+                         (loop (cdr docs-dirs)))))])))
+          
+          (define sk-bitmap #f)
+          
+          (define hd-editor-mixin
+            (mixin (hyper-text<%> editor<%>) ()
+              (define/augment (url-allows-evaling? url)
+                (and (equal? internal-host (url-host url))
+                     (equal? internal-port (url-port url))))
+              
+              (define show-sk? #t)
+              
+              (define/override (on-event evt)
+                (cond
+                  [(and show-sk? 
+                        (sk-bday?)
+                        (send evt button-down? 'right))
+                   (let ([admin (get-admin)])
+                     (let ([menu (new popup-menu%)])
+                       (new menu-item% 
+                            (parent menu)
+                            (label (string-constant happy-birthday-shriram))
+                            (callback (lambda (x y)
+                                        (set! show-sk? #f)
+                                        (let ([wb (box 0)]
+                                              [hb (box 0)]
+                                              [xb (box 0)]
+                                              [yb (box 0)])
+                                          (send admin get-view xb yb wb hb)
+                                          (send admin needs-update (unbox xb) (unbox yb) (unbox wb) (unbox hb))))))
+                       (send (get-canvas) popup-menu menu
+                             (+ (send evt get-x) 1)
+                             (+ (send evt get-y) 1))))]
+                  [else (super on-event evt)]))
+              
+              
+              (inherit dc-location-to-editor-location get-admin)
+              (define/override (on-paint before? dc left top right bottom dx dy draw-caret)
+                (super on-paint before? dc left top right bottom dx dy draw-caret)
+                (when before?
+                  (when (and show-sk? (sk-bday?))
+                    (unless sk-bitmap
+                      (set! sk-bitmap (make-object bitmap% (build-path (collection-path "icons") "sk.jpg"))))
+                    
+                    (let ([admin (get-admin)])
+                      (when admin
+                        (let*-values ([(view-w view-h) (get-view-w/h admin)]
+                                      [(view-x view-y)
+                                       (values (- (/ view-w 2) (/ (send sk-bitmap get-width) 2))
+                                               (- view-h (send sk-bitmap get-height)))]
+                                      ;; note: view coordinates are not exactly canvas dc coordinates
+                                      ;; but they are off by a fixed amount (same on all platforms)
+                                      ;; (note: dc-location in this method means canvas dc, which is
+                                      ;;  different from the dc coming in here (offscreen bitmaps))
+                                      [(editor-x editor-y) (dc-location-to-editor-location view-x view-y)]
+                                      [(dc-x dc-y) (values (+ editor-x dx)
+                                                           (+ editor-y dy))])
+                          (send dc draw-bitmap sk-bitmap dc-x dc-y)))))))
+              (define/private (get-view-w/h admin)
+                (let ([wb (box 0)]
+                      [hb (box 0)])
+                  (send admin get-view #f #f wb hb)
+                  (values (unbox wb)
+                          (unbox hb))))
+              
+              (inherit get-canvas)
+              (define/override (init-browser-status-line top-level-window)
+                (send top-level-window change-search-to-status))
+              (define/override (update-browser-status-line top-level-window s) 
+                (send top-level-window set-search-status-contents s))
+              (define/override (close-browser-status-line top-level-window) 
+                (send top-level-window change-status-to-search))
+              
+              (super-new)))
+          
+          (lambda (%)
+            (class %
+              (define/override (get-hyper-panel%)
+                (catch-url-hyper-panel-mixin (super get-hyper-panel%)))
+              (super-new)))))
+      
+      (define (is-download.plt-scheme.org/doc-url? url)
+        (and (equal? "download.plt-scheme.org" (url-host url))
+             (not (null? (url-path url)))
+             (equal? (car (url-path url)) "^/doc")))
+      
+      (define (ask-user-about-separate-browser)
+        (define separate-default? (preferences:get 'drscheme:help-desk:separate-browser))
+
+	(let-values ([(result checked?) 
+		      (message+check-box/custom
+		       (string-constant help-desk)
+		       (string-constant plt:hd:ask-about-separate-browser)
+		       (string-constant dont-ask-again)
+		       (string-constant plt:hd:homebrew-browser)
+		       (string-constant plt:hd:separate-browser)
+		       #f
+		       #f ; no parent
+		       (cons
+			(if separate-default?
+			    'default=2
+			    'default=1)
+			'(no-default disallow-close)))])
+	  (let ([separate? (= result 2)])
+	    (preferences:set 'drscheme:help-desk:separate-browser separate?)
+	    (when checked?
+	      (preferences:set 'drscheme:help-desk:ask-about-external-urls #f))
+	    separate?)))
+      
+      (define make-help-desk-framework-mixin 
+        (mixin (frame:searchable<%> frame:standard-menus<%>) ()
+          (define/override (get-text-to-search)
+            (send (send (send this get-hyper-panel) get-canvas) get-editor))
+          
+          (define/override (file-menu:create-new?) #t)
+          (define/override (file-menu:new-callback x y) (new-help-desk))
+          
+          (define/override (file-menu:create-open-recent?) #f)
+          
+          (define/override (file-menu:create-open?) #f)
+          (define/override (file-menu:create-print?) #t)
+          
+          (define/override (file-menu:print-callback x y)
+            (let ([ed (send (send (send this get-hyper-panel) get-canvas) get-editor)])
+              (and ed
+                   (send ed print))))
+          
+          (define/override (file-menu:between-open-and-revert file-menu)
+            (super file-menu:between-open-and-revert file-menu)
+            (instantiate menu:can-restore-menu-item% ()
+              (parent file-menu)
+              (callback (lambda (_1 _2) (open-url-callback)))
+              (label (string-constant open-url...)))
+            (instantiate menu:can-restore-menu-item% ()
+              (parent file-menu)
+              (label (string-constant reload))
+              (callback (lambda (_1 _2) (send (send this get-hyper-panel) reload)))))
+          
+          (define/private (open-url-callback)
+            (let ([url (get-url-from-user this)])
+              (when url
+                (let* ([hp (send this get-hyper-panel)]
+                       [hc (send hp get-canvas)])
+                  (send hc goto-url url #f)))))
+          
+          (define/override (on-size w h)
+            (preferences:set 'drscheme:help-desk:frame-width w)
+            (preferences:set 'drscheme:help-desk:frame-height h)
+            (super on-size w h))
+          
+          (super-new
+           (width (preferences:get 'drscheme:help-desk:frame-width))
+           (height (preferences:get 'drscheme:help-desk:frame-height)))
+          
+          (frame:reorder-menus this)))
+      
+      (define make-search-button-mixin
+        (mixin (frame:basic<%> hyper-frame<%>) ()
+          (field [search-panel #f])
+          
+          ;; order-manuals : as in drscheme:language:language<%>
+          ;; by default, search in all manuals
+          (define/public (order-manuals x) (values x #t))
+          
+          ;; the name of the language to put in the top of the search results,
+          ;; or #f if nothing is to be put there.
+          (define/public (get-language-name) #f)
+          
+          (define/override (make-root-area-container class parent)
+            (let* ([search-panel-parent (super make-root-area-container vertical-panel% parent)]
+                   [main-panel (make-object class search-panel-parent)])
+              (set! search-panel (instantiate vertical-panel% ()
+                                   (parent search-panel-parent)
+                                   (stretchable-height #f)))
+              main-panel))
+          
+          ;; these methods have the same name as the methods in the browser.
+          ;; they are called during super initialization, so they protect themselves...
+          (define/public (change-search-to-status)
+            (when search/status-panel
+              (send search/status-panel active-child status-panel)))
+          (define/public (set-search-status-contents s)
+            (when status-message
+              (send status-message set-label (trim-string 200 s))))
+          (define/private (trim-string n str)
+            (cond
+              [(<= (string-length str) n) str]
+              [else (string-append (substring str 0 98)
+                                   " ... "
+                                   (substring str (- (string-length str) 
+                                                     97)
+                                              (string-length str)))]))
+          
+          (define/public (change-status-to-search) 
+            (when search/status-panel
+              (send search/status-panel active-child field-panel)
+              (send search-field focus)))
+          
+          (field [search/status-panel #f]
+                 [field-panel #f]
+                 [search-field #f]
+                 [status-panel #f]
+                 [status-message #f]
+                 [choices-panel #f])
+          
+          (super-new (label (string-constant help-desk)))
+          
+          (let ([hp (send this get-hyper-panel)])
+            (send hp set-init-page home-page-url)
+            (send (send hp get-canvas) allow-tab-exit #t))
+          
+          (inherit get-menu-bar get-hyper-panel)
+          (let ()
+            (define search-menu (instantiate menu% ()
+                                  (label (string-constant plt:hd:search))
+                                  (parent (get-menu-bar))))
+            (define search-menu-item (instantiate menu:can-restore-menu-item% ()
+                                       (label (string-constant plt:hd:search))
+                                       (parent search-menu)
+                                       (shortcut #\e)
+                                       (callback
+                                        (lambda (x y) (search-callback #f)))))
+            (define lucky-menu-item (instantiate menu:can-restore-menu-item% ()
+                                      (label (string-constant plt:hd:feeling-lucky))
+                                      (parent search-menu)
+                                      (shortcut #\u)
+                                      (callback
+                                       (lambda (x y) (search-callback #t)))))
+            (define stupid-internal-define-syntax1
+              (set! search/status-panel (new panel:single% 
+                                             (parent search-panel)
+                                             (stretchable-width #t))))
+            (define stupid-internal-define-syntax2
+              (set! field-panel (new horizontal-panel% (parent search/status-panel))))
+            (define stupid-internal-define-syntax3
+              (set! status-panel (new horizontal-panel% (parent search/status-panel))))
+            (define stupid-internal-define-syntax4
+              (set! status-message (new message% 
+                                        (parent status-panel)
+                                        (stretchable-width #t)
+                                        (label ""))))
+            (define stupid-internal-define-syntax5
+              (set! search-field (instantiate text-field% ()
+                                   (label (string-constant plt:hd:find-docs-for))
+                                   (callback (lambda (x y)
+                                               (let ([on? (not (equal? "" (send search-field get-value)))])
+                                                 (send search-button enable on?)
+                                                 (send search-menu enable on?))))
+                                   (parent field-panel))))
+            
+            ;; exposed to derived classes
+            (define stupid-internal-define-syntax6
+              (set! choices-panel (instantiate horizontal-panel% ()
+                                    (parent search-panel)
+                                    (alignment '(center center)))))
+            
+            (define search-button (instantiate button% ()
+                                    (label (string-constant plt:hd:search))
+                                    (parent field-panel)
+                                    (callback (lambda (x y) (search-callback #f)))
+                                    (style '(border))))
+            (define search-where (instantiate choice% ()
+                                   (label #f)
+                                   (parent choices-panel)
+                                   (selection (preferences:get 'drscheme:help-desk:search-where))
+                                   (choices
+                                    (list
+                                     (string-constant plt:hd:search-for-keyword)
+                                     (string-constant plt:hd:search-for-keyword-or-index)
+                                     (string-constant plt:hd:search-for-keyword-or-index-or-text)))
+                                   (callback
+                                    (lambda (x y)
+                                      (preferences:set 'drscheme:help-desk:search-where
+                                                       (send search-where get-selection))))))
+            (define search-how (instantiate choice% ()
+                                 (label #f)
+                                 (parent choices-panel)
+                                 (selection (preferences:get 'drscheme:help-desk:search-how))
+                                 (choices 
+                                  (list
+                                   (string-constant plt:hd:exact-match)
+                                   (string-constant plt:hd:containing-match)
+                                   (string-constant plt:hd:regexp-match)))
+                                 (callback
+                                  (lambda (x y)
+                                    (preferences:set 'drscheme:help-desk:search-how
+                                                     (send search-how get-selection))))))
+            
+            (define grow-box-spacer (make-object grow-box-spacer-pane% choices-panel))
+            (define (search-callback lucky?)
+              (let-values ([(manuals doc.txt?) (order-manuals (map path->bytes (map car (find-doc-names))))])
+                (let ([url (make-results-url
+                            (send search-field get-value)
+                            (case (send search-where get-selection)
+                              [(0) "keyword"]
+                              [(1) "keyword-index"]
+                              [(2) "keyword-index-text"])
+                            (case (send search-how get-selection)
+                              [(0) "exact-match"]
+                              [(1) "containing-match"]
+                              [(2) "regexp-match"])
+                            lucky?
+                            (map bytes->path manuals)
+                            doc.txt?
+                            (get-language-name))])
+                  (send (send (get-hyper-panel) get-canvas) goto-url url #f))))
+            
+            (send search-button enable #f)
+            (send search-menu enable #f)
+            (send search-field focus))))
+      
+      (define help-desk-frame-mixin #f)
+      (define addl-mixins (lambda (x) x))
+      (define (add-help-desk-mixin m)
+        (if help-desk-frame-mixin
+            (error 'add-help-desk-mixin "help desk frame has already been created")
+            (set! addl-mixins (compose m addl-mixins))))
+      (define (make-help-desk-frame-mixin)
+        (or help-desk-frame-mixin
+            (begin
+              (set! help-desk-frame-mixin
+                    (compose
+                     addl-mixins
+                     (lambda (x) (class* x (help-desk-frame<%>) (super-new)))
+                     make-catch-url-frame-mixin
+                     bug-report/help-desk-mixin
+                     make-help-desk-framework-mixin
+                     browser-scroll-frame-mixin
+                     frame:searchable-mixin
+                     frame:standard-menus-mixin
+                     make-search-button-mixin))
+              help-desk-frame-mixin)))
+      
+      (define new-help-desk
+        (opt-lambda ([link home-page-url])
+          (let ([f (new ((make-help-desk-frame-mixin) hyper-no-show-frame%))])
+            (send f show #t)
+            (goto-url link f)
+            f)))
+      
+      (define (goto-hd-location sym) (goto-url (get-hd-location sym)))
+      
+      (define (search-for-docs search-string search-type match-type lucky? docs)
+        (let ([fr (or (find-help-desk-frame)
+                      (new-help-desk))])
+          (search-for-docs/in-frame fr search-string search-type match-type lucky? docs)))
+      
+      (define (search-for-docs/in-frame fr search-string search-type match-type lucky? docs)
+        (send fr show #t)
+        (let-values ([(manuals doc.txt?) (send fr order-manuals (map path->bytes docs))])
+          (goto-url (make-results-url search-string
+                                      search-type 
+                                      match-type
+                                      lucky?
+                                      (map bytes->path manuals)
+                                      doc.txt?
+                                      (send fr get-language-name))
+                    fr)))
+      
+      (define goto-url
+        (opt-lambda (link [fr (find-help-desk-frame)])
+          (if fr
+              (send (send (send fr get-hyper-panel) get-canvas) goto-url link #f)
+              (new-help-desk link))))
+      
+      (define (show-help-desk)
+        (let ([fr (find-help-desk-frame)])
+          (if fr
+              (send fr show #t)
+              (new-help-desk))))
+      
+      (define (find-help-desk-frame)
+        (let loop ([frames (send (group:get-the-frame-group) get-frames)])
+          (cond
+            [(null? frames) #f]
+            [else (let ([frame (car frames)])
+                    (if (is-a? frame help-desk-frame<%>)
+                        frame
+                        (loop (cdr frames))))])))
+      
+      (define (get-url-from-user parent)
+        (define d (make-object dialog% (string-constant open-url) parent 500))
+        (define t
+          (keymap:call/text-keymap-initializer
+           (lambda ()
+             (make-object text-field% (string-constant url:) d
+               (lambda (t e)
+                 (update-ok))))))
+        (define p (make-object horizontal-panel% d))
+        (define browse (make-object button% (string-constant browse...) p
+                         (lambda (b e)
+                           (let ([f (get-file)])
+                             (when f
+                               (send t set-value (string-append "file:" f))
+                               (update-ok))))))
+        (define spacer (make-object vertical-pane% p))
+        (define result #f)
+        (define (ok-callback b e)
+          (let* ([s (send t get-value)]
+                 [done (lambda ()
+                         ;; Might be called twice!
+                         (preferences:set 'drscheme:help-desk:last-url-string s)
+                         (send d show #f))])
+            (with-handlers ([exn:fail?
+                             (lambda (x)
+                               (message-box (string-constant bad-url) 
+                                            (format (string-constant bad-url:this)
+                                                    (exn-message x))
+                                            d))])
+              (let* ([removed-spaces (regexp-replace #rx"^[ \t]*" s "")]
+                     [str (cond
+                            [(regexp-match #rx":" removed-spaces) removed-spaces]
+                            [(regexp-match #rx"^[a-zA-Z][a-zA-Z.]*($|/)" removed-spaces)
+                             (string-append "http://" removed-spaces)]
+                            [else
+                             (string-append "file:" removed-spaces)])]
+                     
+                     ;; just convert the string to test it out; don't use result...
+                     [url (string->url str)])
+                (set! result str)
+                (done)))))
+        (define cancel-callback (lambda (b e) (send d show #f)))
+        (define-values (ok cancel)
+          (gui-utils:ok/cancel-buttons
+           p
+           ok-callback
+           cancel-callback))
+        (define (update-ok)
+          (send ok enable 
+                (positive? (send (send t get-editor) 
+                                 last-position))))
+        (define last-url-string (preferences:get 'drscheme:help-desk:last-url-string))
+        (when last-url-string 
+          (send t set-value last-url-string)
+          (let ([text (send t get-editor)])
+            (send text set-position 0 (send text last-position))))
+        (send p set-alignment 'right 'center)
+        (update-ok)
+        (send d center)
+        (send t focus)
+        (send d show #t)
+        result))))
\ No newline at end of file
diff --git a/collects/help/private/info.ss b/collects/help/private/info.ss
new file mode 100644
index 0000000000..85aca3402a
--- /dev/null
+++ b/collects/help/private/info.ss
@@ -0,0 +1,2 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Help private"))
diff --git a/collects/help/private/installed-components.ss b/collects/help/private/installed-components.ss
new file mode 100644
index 0000000000..3bad466756
--- /dev/null
+++ b/collects/help/private/installed-components.ss
@@ -0,0 +1,120 @@
+(module installed-components mzscheme
+  (require (lib "list.ss")
+           (lib "xml.ss" "xml")
+           (lib "getinfo.ss" "setup")
+	   (lib "util.ss" "help" "servlets" "private"))
+
+  (provide help-desk:installed-components)
+  
+  ;; comp = (make-comp string xexpr)
+  ;; this represents a collection with a blurb field.
+  ;; the name names the collection and the xml is its xexpr blurb
+  (define-struct comp (name xml))
+  
+  ;; help-desk:installed-components url : -> (listof (list string xexpr))
+  ;; represents all of the collections with blurb fields 
+  (define (help-desk:installed-components)
+    (let ([comps 
+           (quicksort
+            (filter (lambda (x) x)
+                    (map (lambda (c) (get-blurb c)) (all-collections)))
+            comp<=?)])
+      (map comp-xml comps)))
+  
+  ;; all-collections : ->  (lisof string)
+  ;; returns a list of the collections from the current-library-collections-path parameter
+  (define (all-collections)
+    (let ([colls (make-hash-table 'equal)])
+      (for-each
+       (lambda (collection-path-dir)
+         (when (directory-exists? collection-path-dir)
+           (for-each
+            (lambda (collection)
+              (when (and (directory-exists? (build-path collection-path-dir collection))
+                         (not (member (path->bytes collection) '(#"CVS" #".svn"))))
+                (hash-table-put! colls collection #t)))
+            (directory-list collection-path-dir))))
+       (current-library-collection-paths))
+      (quicksort (hash-table-map colls (lambda (x v) x))
+                 (lambda (x y) (string<=? (path->string x) (path->string y))))))
+  
+  ;; get-blurb : string url -> xexpr
+  ;; builds the xexpr for a collection, based on its name a blurb
+  (define (get-blurb collection)
+    (let/ec k
+      (let ([proc (with-handlers ([(lambda (x) (not (exn:break? x)))
+                                   (lambda (x) #f)])
+                    (get-info (list collection)))])
+        (unless proc
+          (k #f))
+        (let* ([name (with-handlers ([(lambda (x) #t)
+                                      (lambda (x)
+                                        (k
+                                         (make-comp
+                                          collection
+                                          `(li 
+                                            (font ((color "forestgreen")) (b () ,collection))
+                                            (p
+                                             (font
+                                              ((color "red"))
+                                              (i ,(format "error during 'name: ~a"
+                                                          (if (exn? x)
+                                                              (exn-message x)
+                                                              x)))))))))])
+                       (proc 'name (lambda () (k #f))))]
+               [blurb (with-handlers ([(lambda (x) #t)
+                                       (lambda (x)
+                                         (k
+                                          (make-comp
+                                           collection
+                                           `(li 
+                                             (font ((color "forestgreen")) (b () ,name))
+                                             (br)
+                                             (font ((color "red"))
+                                                   (i
+                                                    ,(format "error during 'blurb: ~a"
+                                                             (if (exn? x)
+                                                                 (exn-message x)
+                                                                 x))))))))])
+                        (proc 'blurb (lambda () (k #f))))]
+               [blurb-ok? (andmap xexpr? blurb)])
+          (make-comp
+           name
+           `(li
+             (font ((color "forest green"))
+                   (b ,name))
+             (br)
+             ,@(append
+                (if blurb-ok?
+                    blurb
+                    (list `(font ((color "red"))
+                                 "blurb was not a list of xexprs")))
+		(let ([fname (build-path (collection-path collection) "doc.txt")])
+		  (if (file-exists? fname)
+		      (list
+		       " See "
+		       `(A ((HREF ,(format 
+				    "/servlets/doc-anchor.ss?file=~a&caption=Documentation for the ~a collection&name=~a" 
+				    (hexify-string (path->string fname))
+			            collection
+			            collection)))
+                         "the documentation")
+                     " for more information.")
+                    null)))))))))
+  
+  ;; build-string-from-comp : comp -> string
+  ;; constructs a string version of the xexpr from a comp
+  (define (build-string-from-comp comp)
+    (let ([blurb (comp-xml comp)]
+          [p (open-output-string)])
+      (write-xml/content
+       (xexpr->xml
+        blurb)
+       p)
+      (newline p)
+      (newline p)
+      (get-output-string p)))
+  
+  ;; comp<=? : comp comp -> boolean
+  ;; compares two comps for sorting
+  (define (comp<=? ca cb) (string<=? (comp-name ca) (comp-name cb))))
diff --git a/collects/help/private/internal-hp.ss b/collects/help/private/internal-hp.ss
new file mode 100644
index 0000000000..79bd120172
--- /dev/null
+++ b/collects/help/private/internal-hp.ss
@@ -0,0 +1,6 @@
+(module internal-hp mzscheme
+  (provide internal-host internal-port addon-host)
+  
+  (define internal-host "helpdesk.plt-scheme.org") ;; should not exist.
+  (define addon-host "addon-helpdesk.plt-scheme.org") ;; ditto
+  (define internal-port 8000))
diff --git a/collects/help/private/link.ss b/collects/help/private/link.ss
new file mode 100644
index 0000000000..4637f65378
--- /dev/null
+++ b/collects/help/private/link.ss
@@ -0,0 +1,55 @@
+(module link mzscheme 
+  (require (lib "web-server-unit.ss" "web-server")
+           (lib "sig.ss" "web-server")
+           
+           (lib "unitsig.ss")
+           
+           (lib "tcp-sig.ss" "net")
+           (lib "url-sig.ss" "net")
+           (lib "url-unit.ss" "net")
+           
+           (lib "browser-sig.ss" "browser")
+           (lib "browser-unit.ss" "browser")
+           
+           (lib "plt-installer-sig.ss" "setup")
+           (lib "plt-installer.ss" "setup")   
+
+           (lib "mred.ss" "mred")
+           (lib "mred-sig.ss" "mred")
+           
+           "tcp-intercept.ss"
+           "sig.ss"
+           
+           "gui.ss"
+           "main.ss"
+           "config.ss")
+  
+  (define help-desk@
+    (compound-unit/sig
+      (import [plt-installer : setup:plt-installer^]
+              [mred : mred^]
+              [real-tcp : net:tcp^])
+      (link
+       [config : web-config^ (config)]
+       [real-url : net:url^ (url@ real-tcp)]
+       [web-server : web-server^ (web-server@ real-tcp config)]
+       
+       [ic-tcp : net:tcp^ (tcp-intercept@ web-server)]
+       [pre-ic-url : net:url^ (url@ ic-tcp)]
+       [ic-url : net:url^ (url-intercept@ pre-ic-url)]
+       [browser : browser^ (browser@ plt-installer mred ic-tcp ic-url)]
+       [gui : gui^ (gui@ browser ic-url)]
+
+       [m : () (main@)])
+      (export (open gui)
+              (open web-server))))
+  
+  (define-values/invoke-unit/sig ((open gui^) (open web-server^))
+                                 help-desk@
+                                 #f
+                                 setup:plt-installer^
+                                 mred^
+                                 net:tcp^)
+  
+  (provide-signature-elements gui^)
+  (provide-signature-elements web-server^))
\ No newline at end of file
diff --git a/collects/help/private/main.ss b/collects/help/private/main.ss
new file mode 100644
index 0000000000..a11a3a25ec
--- /dev/null
+++ b/collects/help/private/main.ss
@@ -0,0 +1,48 @@
+(module main mzscheme
+  (require (lib "unitsig.ss")
+           (lib "sig.ss" "web-server")
+           (lib "framework.ss" "framework")
+           (lib "mred.ss" "mred")
+           (lib "class.ss")
+           (lib "external.ss" "browser")
+           (lib "string-constant.ss" "string-constants")
+           "sig.ss")
+  
+  (provide main@)
+  
+  (define main@
+    (unit/sig ()
+      (import)
+      
+      ;; where should the pref stuff really go?
+      (preferences:set-default 'drscheme:help-desk:last-url-string "" string?)
+      (preferences:set-default 'drscheme:help-desk:frame-width 350 number?)
+      (preferences:set-default 'drscheme:help-desk:frame-height 400 number?)
+      (preferences:set-default 'drscheme:help-desk:search-how 1 (lambda (x) (member x '(0 1 2))))
+      (preferences:set-default 'drscheme:help-desk:search-where 1 (lambda (x) (member x '(0 1 2))))
+      
+      (preferences:set-default 'drscheme:help-desk:separate-browser #t boolean?)
+      (preferences:set-default 'drscheme:help-desk:ask-about-external-urls #t boolean?)
+      
+      (add-to-browser-prefs-panel
+       (lambda (panel)
+         (let* ([cbp (instantiate group-box-panel% ()
+                       (parent panel)
+                       (label (string-constant plt:hd:external-link-in-help))
+                       (alignment '(left center))
+                       (stretchable-height #f)
+                       (style '(deleted)))]
+                [cb (instantiate check-box% ()
+                      (label (string-constant plt:hd:use-homebrew-browser))
+                      (parent cbp)
+                      (value (preferences:get 'drscheme:help-desk:separate-browser))
+                      (callback
+                       (lambda (cb evt)
+                         (preferences:set 'drscheme:help-desk:separate-browser
+                                          (not (send cb get-value))))))])
+           ;; Put checkbox panel at the top:
+           (send panel change-children (lambda (l) (cons cbp l)))
+           (preferences:add-callback 
+            'drscheme:help-desk:separate-browser
+            (lambda (p v) (send cb set-value (not v))))
+           (void)))))))
\ No newline at end of file
diff --git a/collects/help/private/manuals.ss b/collects/help/private/manuals.ss
new file mode 100644
index 0000000000..da38a5131a
--- /dev/null
+++ b/collects/help/private/manuals.ss
@@ -0,0 +1,521 @@
+
+(module manuals mzscheme
+  (require (lib "list.ss")
+           (lib "date.ss")
+           (lib "string-constant.ss" "string-constants")
+	   (lib "xml.ss" "xml")
+           (lib "contract.ss")
+           (lib "getinfo.ss" "setup")
+           "colldocs.ss"
+           "docpos.ss"
+           "path.ss"
+           "standard-urls.ss"
+           "get-help-url.ss"
+           "../servlets/private/util.ss"
+           "../servlets/private/headelts.ss")
+
+  (provide main-manual-page)
+  (provide finddoc
+	   findreldoc
+	   finddoc-page-anchor)
+  
+  (provide/contract [manual-entry (string? string? xexpr? . -> . xexpr?)]
+                    [finddoc-page (string? string? . -> . string?)]
+                    [get-doc-name (path? . -> . string?)]
+                    [find-doc-directories (-> (listof path?))]
+                    [find-doc-directory (path? . -> . (union false/c path?))]
+                    [find-doc-names (-> (listof (cons/c path? string?)))]
+                    
+                    [goto-manual-link (any/c string? string? . -> . any)]
+                    [get-index-file (path? . -> . (union false/c path?))])
+  
+  (provide find-manuals)
+
+  ;; type sec = (make-sec name regexp (listof regexp))
+  (define-struct sec (name reg seps))
+  
+  ;; sections : (listof sec)
+  ;; determines the section breakdown for the manuals
+  ;; elements in the outer list:
+  ;;   string : name of section
+  ;;   predicate : determines if a manual is in the section (based on its title)
+  ;;   breaks -- where to insert newlines
+  (define sections
+    (list (make-sec "Getting started" #rx"(Tour)|(Teach Yourself)" '())
+          (make-sec "Languages"
+                    #rx"Language|MrEd"
+                    '(#rx"Beginning Student" #rx"ProfessorJ Beginner"))
+          (make-sec "Tools" #rx"PLT DrScheme|PLT mzc|TeX2page|Web Server|PLoT" '())
+          (make-sec "Libraries" #rx"SRFI|MzLib|Framework|PLT Miscellaneous|Teachpack|Swindle" '())
+          (make-sec "Writing extensions" #rx"Tools|Inside|Foreign" '())
+          (make-sec "Other" #rx"" '())))
+  
+  (define (goto-manual-link cookie manual index-key)
+    (error 'goto-manual-link "broken ~s ~s ~s\n" cookie manual index-key))
+    
+  ;; Creates a "file:" link into the indicated manual.
+  ;; The link doesn't go to a particular anchor,
+  ;; because "file:" does not support that.
+  (define (finddoc manual index-key label)
+    (let ([m (finddoc-lookup manual index-key label)])
+      (if (string? m)
+          m
+          (format "<A href=\"file:~a\">~a</A>"
+                  (path->string (build-path (car m) (caddr m)))
+                  label))))
+
+  ;; Given a Unix-style relative path to reach the "doc"
+  ;; collection, creates a link that can go to a
+  ;; particular anchor.
+  (define (findreldoc todocs manual index-key label)
+    (let ([m (finddoc-lookup manual index-key label)])
+      (if (string? m)
+          m
+          (format "<A href=\"~a/~a/~a#~a\">~a</A>"
+                  todocs
+                  manual
+                  (caddr m)
+                  (cadddr m)
+                  label))))
+
+  (define (finddoc-page-help manual index-key anchor?)
+    (let ([m (finddoc-lookup manual index-key "dummy")])
+      (if (string? m)
+          (error (format "Error finding index \"~a\" in manual \"~a\""
+                         index-key manual))
+          (let ([path (if anchor?
+                          (string-append (caddr m) "#" (cadddr m))
+                          (caddr m))])
+            (if (servlet-path? (string->path (caddr m)))
+                path
+                (format "/doc/~a/~a" manual path))))))
+  
+  ; finddoc-page : string string -> string
+  ; returns path for use by PLT Web server
+  ;  path is of form /doc/manual/page, or
+  ;  /servlet/<rest-of-path>
+  (define (finddoc-page manual index-key)
+    (finddoc-page-help manual index-key #f))
+
+  ; finddoc-page-anchor : string string -> string
+  ; returns path (with anchor) for use by PLT Web server
+  ;  path is of form /doc/manual/page#anchor, or
+  ;  /servlet/<rest-of-path>#anchor
+  (define (finddoc-page-anchor manual index-key)
+    (finddoc-page-help manual index-key #t))
+
+  ;; returns either a string (failure) or
+  ;; (list docdir index-key filename anchor title)
+  (define finddoc-ht (make-hash-table))
+  (define (finddoc-lookup manual index-key label)
+    (let ([key (string->symbol manual)]
+	  [docdir (find-doc-directory (string->path manual))])
+      (unless docdir
+        (error 'finddoc-lookup "manual ~s not found"  manual))
+      (let ([l (hash-table-get
+		finddoc-ht
+		key
+		(lambda ()
+		  (let ([f (build-path docdir "hdindex")])
+                    (if (file-exists? f)
+                        (let ([l (with-input-from-file f read)])
+                          (hash-table-put! finddoc-ht key l)
+                          l)
+                        (error 'finddoc "manual index ~s not installed" manual)))))])
+	(let ([m (assoc index-key l)])
+	  (if m 
+	      (cons docdir m)
+	      (error 'finddoc "index key ~s not found in manual ~s" index-key manual))))))
+  
+  ; manual is doc collection subdirectory, e.g. "mred"
+  (define (main-manual-page manual)
+    (let* ([entry (assoc manual known-docs)]
+	   [name (or (and entry (cdr entry))
+                     manual)]
+	   [href (string-append "/doc/" manual "/")])
+      `(A ((HREF ,href)) ,name)))
+  
+  ; string string string -> xexpr
+  ; man is manual name
+  ; ndx is index into the manual
+  ; txt is the link text
+  ;; warning: if the index file isn't present, this page
+  (define (manual-entry man ndx txt)
+    (with-handlers ([exn:fail?
+                     (lambda (x)
+                       `(font ((color "red"))
+                              ,txt
+                              " ["
+                              ,(exn-message x)
+                              "]"))])
+      `(A ((HREF ,(finddoc-page man ndx))) ,txt)))
+  
+  (define (find-doc-names)
+    (let* ([dirs (find-doc-directories)]
+           [installed
+            (map (lambda (dir)
+                   (let-values ([(base name dir?) (split-path dir)])
+                     name))
+                 dirs)]
+           [uninstalled
+            (filter (lambda (x) (not (member (car x) installed)))
+                    known-docs)])
+      (append
+       (map (lambda (short-name long-name) (cons short-name (get-doc-name long-name)))
+            installed 
+            dirs)
+       uninstalled)))
+  
+  ;; find-doc-directories : -> (listof path)
+  ;; constructs a list of directories where documentation may reside.
+  (define (find-doc-directories)
+    (append (find-info.ss-doc-directories)
+            (find-doc-directories-in-doc-collection)))
+  
+  (define (find-info.ss-doc-directories)
+    (let ([dirs (find-relevant-directories '(html-docs) 'all-available)])
+      (let loop ([dirs dirs])
+        (cond
+          [(null? dirs) null]
+          [else (let* ([dir (car dirs)]
+                       [info (get-info/full dir)])
+                  (cond
+                    [info
+                     (let ([html-doc-paths (info 'html-docs (lambda () #f))])
+                       (cond
+                         [(and (list? html-doc-paths)
+                               (andmap path-string? html-doc-paths))
+                          (append (map (lambda (x) (build-path dir x)) html-doc-paths)
+                                  (loop (cdr dirs)))]
+                         [else
+                          (loop (cdr dirs))]))]
+                    [else (loop (cdr dirs))]))]))))
+  
+  (define (find-doc-directories-in-doc-collection)
+    (let loop ([paths (current-library-collection-paths)]
+               [acc null])
+      (cond
+        [(null? paths) acc]
+        [else (let* ([path (car paths)]
+                     [doc-path (build-path path "doc")])
+                (if (directory-exists? doc-path)
+                    (let dloop ([doc-contents (directory-list doc-path)]
+                                [acc acc])
+                      (cond
+                        [(null? doc-contents) (loop (cdr paths) acc)]
+                        [else 
+                         (let ([candidate (build-path doc-path (car doc-contents))])
+                           (if (directory-exists? candidate)
+                               (dloop (cdr doc-contents) (cons candidate acc))
+                               (dloop (cdr doc-contents) acc)))]))
+                    (loop (cdr paths) acc)))])))
+  
+  ;; finds the full path of the doc directory, if one exists
+  ;; input is just the short name of the directory (as a path)
+  (define (find-doc-directory doc)
+    (let loop ([dirs (find-doc-directories-in-doc-collection)])
+      (cond
+        [(null? dirs) #f]
+        [else (let ([dir (car dirs)])
+                (let-values ([(base name dir?) (split-path dir)])
+                  (if (equal? name doc)
+                      dir
+                      (loop (cdr dirs)))))])))
+                            
+  
+  (define re:title (regexp "<[tT][iI][tT][lL][eE]>(.*)</[tT][iI][tT][lL][eE]>"))
+
+  (define (find-manuals)
+    (let* ([sys-type (system-type)]
+           [docs (let loop ([l (find-doc-directories)])
+                   (cond
+                     [(null? l) null]
+                     [(get-index-file (car l))
+                      (cons (car l) (loop (cdr l)))]
+                     [else (loop (cdr l))]))]
+           [compare-docs (lambda (a b)
+                           (let-values ([(_1 a-short _2) (split-path a)]
+                                        [(_3 b-short _4) (split-path b)])
+                             (let ([ap (standard-html-doc-position a-short)]
+                                   [bp (standard-html-doc-position b-short)])
+                               (cond
+                                 [(= ap bp) (string<? (path->string a) (path->string b))]
+                                 [else (< ap bp)]))))]
+           [docs (quicksort docs compare-docs)]
+           [names (map get-doc-name docs)]
+           [names+paths (map cons names docs)])
+      (let-values ([(collections-doc-files collection-names) (colldocs)])
+        (apply
+         string-append
+         "<html>"
+         (xexpr->string 
+          `(HEAD
+            ,hd-css
+            ,@hd-links
+            (TITLE "PLT Manuals")))
+         "<body>"
+         
+         (append 
+          
+          (list "<H1>Installed Manuals</H1>")
+          (if (repos-or-nightly-build?)
+              (list 
+               "<b>Subversion:</b> <a mzscheme=\""
+               (to-string/escape-quotes 
+                `((dynamic-require '(lib "refresh-manuals.ss" "help") 'refresh-manuals)))
+               "\">"
+               (string-constant plt:hd:refresh-all-manuals)
+               "</a> &nbsp; &nbsp;"
+               (format "<a href=\"~a\">flush index and keyword cache</a><br>" flush-manuals-url))
+              '())
+
+          (build-known-manuals names+paths)
+          
+          (list "<h3>Doc.txt</h3><ul>")
+          (map
+           (lambda (collection-doc-file name)
+             (format "<LI> <A HREF=\"/servlets/doc-anchor.ss?file=~a&name=~a&caption=Documentation for the ~a collection\">~a collection</A>"
+                     ; escape colons and other junk
+                     (hexify-string
+                      (path->string
+                       (build-path (car collection-doc-file) 
+                                   (cadr collection-doc-file))))
+                     name
+                     name
+                     name))
+           collections-doc-files
+           collection-names)
+          (list "</UL>")
+          (let ([uninstalled (get-uninstalled docs)])
+            (cond
+              [(null? uninstalled)
+               (list "")]
+              [else
+               (list*
+                "<H3>Uninstalled Manuals</H3>"
+                "<UL>"
+                (append
+                 (map
+                  (lambda (doc-pair)
+                    (let* ([manual (car doc-pair)]
+                           [name (cdr doc-pair)]
+                           [manual-path (find-doc-directory manual)])
+                      (string-append
+                       "<LI> Download and install <A mzscheme=\""
+                       (to-string/escape-quotes 
+                        `((dynamic-require '(lib "refresh-manuals.ss" "help") 'refresh-manuals)
+                          (list (cons (bytes->path ,(path->bytes manual))
+                                      ,name))))
+                       (format "\">~a</A>~a"
+                               name
+                               (if (and manual-path
+                                        (or (file-exists? (build-path manual-path "hdindex"))
+                                            (file-exists? (build-path manual-path "keywords"))))
+                                   " (index installed)"
+                                   "")))))
+                  uninstalled)
+                 (list "</UL>")))]))
+          (list "</body></html>"))))))
+  
+  ;; break-between : regexp
+  ;;                (listof (union string (cons string string))) 
+  ;;             -> (listof (union string (cons string string)))
+  ;; adds the para-mark string into the list at the first place
+  ;; that the regexp fails to match (not counting other para-marks
+  ;; in the list)
+  (define (break-between re l)
+    (let ([para-mark "<p>"])
+      (let loop ([l l])
+        (cond
+          [(null? l) null]
+          [else 
+           (let ([fst (car l)])
+             (cond
+               [(pair? fst)
+                (let ([name (car fst)])
+                  (if (regexp-match re name)
+                      (cons para-mark l)
+                      (cons fst (loop (cdr l)))))]
+               [else (cons fst (loop (cdr l)))]))]))))
+
+  ;; build-known-manuals : (listof (cons string[title] string[path])) -> (listof string)
+  (define (build-known-manuals names+paths)
+    (let loop ([sections sections]
+               [manuals names+paths])
+      (cond
+        [(null? sections) null]
+        [else 
+         (let* ([section (car sections)]
+                [in (filter (lambda (x) (regexp-match (sec-reg section) 
+                                                      (car x)))
+                            manuals)]
+                [out (filter (lambda (x) (not (regexp-match (sec-reg section) 
+                                                       (car x))))
+                             manuals)])
+           (cons (build-known-section section in)
+                 (loop (cdr sections) out)))])))
+  
+  ;; build-known-section : sec (listof (cons string[title] string[path]))) -> string
+  (define (build-known-section sec names+paths)
+    (if (null? names+paths)
+        ""
+        (string-append
+         "<h3>" (sec-name sec) "</h3>"
+         "<ul>"
+         (apply 
+          string-append
+          (map (lambda (x) 
+                 (if (string? x)
+                     x
+                     (mk-link (cdr x) (car x))))
+               (let loop ([breaks (sec-seps sec)]
+                          [names+paths names+paths])
+                 (cond
+                   [(null? breaks) names+paths]
+                   [else
+                    (let ([break (car breaks)])
+                      (loop (cdr breaks)
+                            (break-between (car breaks) names+paths)))]))))
+         "</ul>")))
+
+  ;; mk-link : string string -> string
+  (define (mk-link doc-path name)
+    (let* ([manual-name (let-values ([(base manual-name dir?) (split-path doc-path)])
+                          manual-name)]
+           [index-file (get-index-file doc-path)])
+      (format "<LI> <A HREF=\"~a\">~a</A>~a"
+              #;manual-name
+              #;(path->string index-file)
+              (get-help-url (build-path doc-path index-file))  
+                
+                
+              name
+              (if (and (repos-or-nightly-build?)
+                       (file-exists? (build-path doc-path index-file)))
+                  (string-append 
+                   "<BR>&nbsp;&nbsp;"
+                   "<FONT SIZE=\"-1\">"
+                   (if (is-known-doc? doc-path)
+                       (string-append
+                        (format
+                         "[<A mzscheme=\"~a\">~a</a>]"
+                         (to-string/escape-quotes 
+                          `((dynamic-require '(lib "refresh-manuals.ss" "help") 'refresh-manuals)
+                            (list (cons (bytes->path ,(path->bytes manual-name))
+                                        ,name))))
+                         (string-constant plt:hd:refresh))
+                        "&nbsp;")
+                       "")
+                   (format (string-constant plt:hd:manual-installed-date)
+                           (date->string
+                            (seconds->date
+                             (file-or-directory-modify-seconds
+                              (build-path doc-path index-file)))))
+                   "</FONT>")
+                  ""))))
+  
+  (define (to-string/escape-quotes exp)
+    (regexp-replace* #rx"\""
+                     (format "~s" exp)
+                     "|"))
+  
+  ;; get-doc-name : path -> string
+  (define cached-doc-names (make-hash-table 'equal))
+  (define (get-doc-name doc-dir)
+    (hash-table-get
+     cached-doc-names
+     doc-dir
+     (lambda ()
+       (let ([res (compute-doc-name doc-dir)])
+         (hash-table-put! cached-doc-names doc-dir res)
+         res))))
+
+  ;; compute-doc-name : path -> string[title of manual]
+  ;; gets the title either from the known docs list, by parsing the
+  ;; html, or if both those fail, by using the name of the directory
+  ;; Special-cases the help collection. It's not a known doc directory
+  ;; per se, so it won't appear in known-docs, but it's name is always
+  ;; the same.
+  (define (compute-doc-name doc-dir)
+    (let-values ([(_1 doc-short-dir-name _2) (split-path doc-dir)])
+      (if (equal? (string->path "help") doc-short-dir-name)
+          "PLT Help Desk"
+          (or (get-known-doc-name doc-dir)
+              (let ([main-file (get-index-file doc-dir)])
+                (if main-file
+                    (with-input-from-file (build-path doc-dir main-file)
+                      (lambda ()
+                        (let loop ()
+                          (let ([r (read-line)])
+                            (cond
+                              [(eof-object? r) doc-short-dir-name]
+                              [(regexp-match re:title r) => cadr]
+                              [(regexp-match #rx"<[tT][iI][tT][lL][eE]>(.*)$" r)
+                               ;; Append lines until we find it 
+                               (let aloop ([r r])
+                                 (let ([a (read-line)])
+                                   (cond
+                                     [(eof-object? a) (loop)] ; give up
+                                     [else (let ([r (string-append r a)])
+                                             (cond
+                                               [(regexp-match re:title r) => cadr]
+                                               [else (aloop r)]))])))]
+                              [else (loop)])))))
+                    (path->string doc-short-dir-name)))))))
+  
+  ;; is-known-doc? : string[path] -> boolean
+  (define (is-known-doc? doc-path)
+    (let-values ([(base name dir?) (split-path doc-path)])
+      (if (assoc name known-docs)
+          #t
+          #f)))
+  
+  ;; get-known-doc-name : string[full-path] -> (union string #f)
+  (define (get-known-doc-name doc-path)
+    (let-values ([(base name dir?) (split-path doc-path)])
+      (let ([ass (assoc name known-docs)])
+        (if ass
+            (cdr ass)
+            #f))))
+
+  ;; get-uninstalled : (listof path) -> (listof (cons path string[docs-name]))
+  (define (get-uninstalled docs)
+    (let ([ht (make-hash-table 'equal)])
+      (for-each (lambda (known-doc)
+                  (hash-table-put! ht 
+                                   (car known-doc)
+                                   (cdr known-doc)))
+                known-docs)
+      (for-each (lambda (doc)
+                  (let-values ([(base name dir?) (split-path doc)])
+                    (hash-table-remove! ht name)))
+                docs)
+      (hash-table-map ht cons)))
+  
+  ;; get-index-file : path -> (union #f path)
+  ;; returns the name of the main file, if one can be found
+  (define (get-index-file doc-dir)
+    (cond
+      [(file-exists? (build-path doc-dir "index.htm"))
+       (build-path "index.htm")]
+      [(file-exists? (build-path doc-dir "index.html"))
+       (build-path "index.html")]
+      [(tex2page-detected doc-dir)
+       =>
+       (lambda (x) x)]
+      [else #f]))
+  
+  ;; tex2page-detected : string -> (union #f string)
+  (define (tex2page-detected dir)
+    (let loop ([contents (directory-list dir)])
+      (cond
+        [(null? contents) #f]
+        [else (let* ([file (car contents)]
+                     [m (regexp-match #rx#"(.*)-Z-H-1.html" (path->bytes file))])
+                (or (and m
+                         (file-exists? (build-path dir file))
+                         (let ([index-file (bytes->path (bytes-append (cadr m) #".html"))])
+                           (if (file-exists? (build-path dir index-file))
+                               index-file
+                               #f)))
+                    (loop (cdr contents))))]))))
diff --git a/collects/help/private/path.ss b/collects/help/private/path.ss
new file mode 100644
index 0000000000..d5c78564e2
--- /dev/null
+++ b/collects/help/private/path.ss
@@ -0,0 +1,11 @@
+(module path mzscheme
+  (require (lib "contract.ss"))
+  (provide/contract
+   [servlet-path? (path? . -> . boolean?)])
+
+  (define (servlet-path? path)
+    (if (regexp-match #rx#"^/servlets/" 
+                      (path->bytes path))
+        #t
+        #f)))
+
diff --git a/collects/help/private/search.ss b/collects/help/private/search.ss
new file mode 100644
index 0000000000..65ae082c97
--- /dev/null
+++ b/collects/help/private/search.ss
@@ -0,0 +1,552 @@
+(module search mzscheme
+  (require (lib "string-constant.ss" "string-constants")
+           "docpos.ss"
+           "colldocs.ss"
+           "path.ss"
+           "manuals.ss"
+           (lib "list.ss")
+           (lib "plt-match.ss")
+           (lib "contract.ss"))
+  
+  (provide doc-collections-changed)
+  (provide/contract
+   [do-search
+    (string?
+     number?
+     boolean?
+     boolean?
+     (listof path?)
+     boolean? 
+     any/c
+     (-> any)
+     (string? any/c . -> . void?)
+     (string? any/c . -> . void?)
+     (string? string? string? path? (union string? number? false/c) any/c . -> . void?)
+     . -> .
+     (union string? false/c))]
+   
+   (build-string-finds/finds (string? 
+                              boolean?
+                              boolean?
+                              . -> . 
+                              (values (listof string?) 
+                                      (listof (union regexp? string?)))))
+   
+   (non-regexp (string? . -> . string?)))
+
+  (define (html-doc-position x)
+    (or (user-defined-doc-position x)
+	(standard-html-doc-position x)))
+  
+  ; These are set by reset-doc-lists:
+  ; docs, doc-names and doc-kinds are parallel lists. doc-kinds
+  ; distinguishes between the two variants of docs.
+  ; docs : (list-of (union string (list path string)))
+  (define docs null)
+  ; doc-names : (list-of string)
+  (define doc-names null)
+  ; doc-kinds : (list-of symbol)
+  (define doc-kinds null)
+  ; doc-collection-date : (union #f number 'none)
+  (define doc-collection-date #f)
+      
+  (define (reset-doc-lists)
+  ; Locate standard HTML documentation
+    (define-values (std-docs std-doc-names)
+      (let* ([docs (find-doc-directories)]
+             [doc-names (map get-doc-name docs)])
+        ; Order the standard docs:
+        (let ([ordered (quicksort
+                        (map list docs doc-names)
+                        (lambda (a b) ; html-doc-position expects collection name
+                          (let-values ([(_1 a-short _2) (split-path (car a))]
+                                       [(_3 b-short _4) (split-path (car b))])
+                            (< (html-doc-position a-short)
+                               (html-doc-position b-short)))))])
+          (values (map car ordered) (map cadr ordered))))) ; here we want the std title
+    
+    ; Check collections for doc.txt files:
+    (define-values (txt-docs txt-doc-names) (colldocs))
+    
+    (set! docs (append std-docs txt-docs))
+    
+    (set! doc-names (append
+		     std-doc-names
+		     (map (lambda (s) (format "the ~a collection" s))
+			  txt-doc-names)))
+    (set! doc-kinds (append (map (lambda (x) 'html) std-docs) (map (lambda (x) 'text) txt-docs)))
+    
+    (with-handlers ([exn:fail:filesystem? (lambda (x) (set! doc-collection-date 'none))])
+		   (set! doc-collection-date 
+			 (file-or-directory-modify-seconds
+			  (collection-path "doc")))))
+  
+  (define MAX-HIT-COUNT 300)
+  
+  (define (clean-html s)
+    (regexp-replace*
+     "&[^;]*;"
+     (regexp-replace*
+      "<[^>]*>"
+      (regexp-replace* 
+       "&amp;"
+       (regexp-replace* 
+	"&gt;"
+	(regexp-replace*
+	 "&lt;"
+	 s
+	 "<")
+	">")
+       "\\&")
+      "")
+     ""))
+    
+  (define (with-hash-table ht key compute)
+    (hash-table-get
+     ht
+     key
+     (lambda ()
+       (let ([v (compute)])
+         (hash-table-put! ht key v)
+         v))))
+  
+  (define html-keywords (make-hash-table 'equal))
+  (define (load-html-keywords doc)
+    (with-hash-table
+     html-keywords
+     doc
+     (lambda ()
+       (with-handlers ([exn:fail:read? (λ (x) null)]
+                       [exn:fail:filesystem? (λ (x) null)])
+         (transform-keywords
+          (with-input-from-file (build-path doc "keywords")
+            read))))))
+      
+  (define html-indices (make-hash-table 'equal))
+  (define (load-html-index doc)
+    (with-hash-table
+     html-indices
+     doc
+     (lambda ()
+       (with-handlers ([exn:fail:read? (lambda (x) null)]
+                       [exn:fail:filesystem? (lambda (x) null)])
+         (transform-hdindex
+          (with-input-from-file (build-path doc "hdindex")
+            read))))))
+  
+  ;; transform-hdindex : any -> (listof (list string path string string)
+  ;; makes sure the input from the file is well-formed and changes
+  ;; the bytes to paths.
+  (define (transform-hdindex l)
+    (let/ec k
+      (let ([fail (lambda () (k '()))])
+        (unless (list? l) (fail))
+        (map (lambda (l)
+               (match l
+                 [`(,(? string? index)
+                     ,(? string? file)
+                     ,(? string? label)
+                     ,(? string? title))
+                   (list index
+                         file
+                         label 
+                         title)]
+                 [else
+                  (fail)]))
+             l))))
+  
+  ;; transform-keywords : any -> (listof (list string string path string string)
+  ;; as with transform-hdindex
+  (define (transform-keywords l)
+    (let/ec k
+      (let ([fail (lambda () (k '()))])
+        (unless (list? l) (fail))
+        (map (lambda (l)
+               (match l
+                 [`(,(? string? keyword)
+                     ,(? string? result)
+                     ,(? path-string? file)
+                     ,(? string? label)
+                     ,(? string? title))
+                   (list keyword
+                         result
+                         file
+                         label 
+                         title)]
+                 [else (fail)]))
+             l))))
+    
+  (define (parse-txt-file doc ht handle-one)
+    (with-hash-table
+     ht
+     doc
+     (lambda ()
+       (with-handlers ([exn:fail:filesystem? (lambda (x) null)])
+	(with-input-from-file doc
+	  (lambda ()
+	    (let loop ([start 0])
+	      (let* ([r (read-line (current-input-port) 'any)]
+		     [next (if (eof-object? r)
+			       start
+			       (+ start (string-length r) 1))])
+		(cond
+		 [(eof-object? r) null]
+		 [(handle-one r start) => (lambda (vs) (append vs (loop next)))]
+		 [else (loop next)])))))))))
+  
+  (define re:keyword-line (regexp "^>"))
+  (define text-keywords (make-hash-table 'equal))
+  (define (load-txt-keywords doc)
+    (parse-txt-file
+     (apply build-path doc)
+     text-keywords
+     (lambda (r start)
+       (cond
+	[(regexp-match re:keyword-line r)
+         (let/ec k
+           (let* ([p (open-input-string (substring r 1 (string-length r)))]
+                  [entry (parameterize ([read-accept-bar-quote #f])
+                           (with-handlers ([exn:fail:read?
+                                            (lambda (x)
+                                              (k null))])
+                             (read p)))]
+                  [key (let loop ([entry entry])
+                         (cond
+                           [(symbol? entry) entry]
+                           [(pair? entry) (if (and (eq? (car entry) 'quote)
+                                                   (pair? (cdr entry)))
+                                              (loop (cadr entry))
+                                              (loop (car entry)))]
+                           [else (error "bad entry")]))]
+                  [content (if (symbol? entry)
+                               (with-handlers ([exn:fail:read? (lambda (x) #f)])
+                                 (let ([s (read p)])
+                                   (if (eq? s '::)
+                                       (read p)
+                                       #f)))
+                               #f)])
+             (list
+              ; Make the keyword entry:
+              (list (symbol->string key) ; the keyword name
+                    (let ([p (open-output-string)])
+                      (if content
+                          (display content p)
+                          (if (and (pair? entry) 
+                                   (pair? (cdr entry))
+                                   (eq? (car entry) 'quote))
+                              (fprintf p "'~s" (cadr entry))
+                              (display entry p)))
+                      (get-output-string p)) ; the text to display
+                    (cadr doc) ; file
+                    start ; label (a position in this case)
+                    "doc.txt"))))] ; title
+	[else #f]))))
+      
+  (define re:index-line (regexp "_([^_]*)_(.*)"))
+  (define text-indices (make-hash-table 'equal))
+  (define (load-txt-index doc)
+    (parse-txt-file
+     (apply build-path doc)
+     text-indices
+     (lambda (r start)
+       (cond
+	[(regexp-match re:index-line r)
+	 => (lambda (m)
+	      (let loop ([m m])
+		(let ([s (cadr m)])
+		  (cons 
+                   ; Make an index entry:
+		   (cons s start)
+		   (let ([m (regexp-match re:index-line (caddr m))])
+		     (if m
+			 (loop m)
+			 null))))))]
+	[else #f]))))
+  
+  (define re:splitter (regexp "^ *([^ ]+)(.*)"))
+  (define (split-words s)
+    (let ([m (regexp-match re:splitter s)])
+      (if m
+	  (cons (cadr m)
+		(split-words (caddr m)))
+	  null)))
+
+  ;; non-regexp : string -> string
+  (define (non-regexp s)
+    (list->string
+     (apply
+      append
+      (map
+       (lambda (c)
+	 (cond 
+	  [(memq c '(#\$ #\| #\\ #\[ #\] #\. #\* #\? #\+ #\( #\) #\^))
+	   (list #\\ c)]
+	  [(char-alphabetic? c)
+	   (list #\[ (char-upcase c) (char-downcase c) #\])]
+	  [else (list c)]))
+       (string->list s)))))
+      
+  (define (doc-collections-changed)
+    (set! doc-collection-date #f)
+    (set! html-keywords (make-hash-table 'equal))
+    (set! html-indices (make-hash-table 'equal))
+    (set! text-keywords (make-hash-table 'equal))
+    (set! text-indices (make-hash-table 'equal))
+    (reset-doc-positions!))
+
+  (define max-reached #f)
+
+  (define (build-string-finds/finds given-find regexp? exact?)
+    (cond
+      [exact? (values (list given-find)
+                      (list given-find))]
+      [regexp? (values (list given-find)
+                       (list (regexp given-find)))]
+      [else (let ([wl (split-words given-find)])
+              (values wl
+                      (map regexp (map non-regexp wl))))]))
+  
+  ; do-search : (string          ; the search text, unprocessed
+  ;              num          ; 0 = keyword, 1 = keyword+index, 2 = all text
+  ;              boolean      ; #t if string should be used as a regexp
+  ;              boolean      ; #t if the string should match exactly (not just "contains")
+  ;              (listof path) ; the manuals to search
+  ;              boolean      ; #t if the doc.txt files should be searched
+  ;              value        ; arbitrary key supplied to the "add" functions
+  ;              (-> A)       ; called when more than enough are found; must escape
+  ;              (string value -> void) ; called to output a document section header (e.g., a manual name)
+  ;              (symbol value -> void) ; called to output a document-kind section header, 'text or 'html
+  ;              (string string string path (union string #f) value -> void)
+  ;                ^       ^      ^     ^      ^- label within page
+  ;                ^       ^      ^     ^- path to doc page
+  ;                ^       ^      ^- source doc title
+  ;                ^       ^- display label
+  ;                ^- found entry's key 
+  ;              ->
+  ;              (union string #f))
+  (define (do-search given-find search-level regexp? exact? manuals doc-txt?
+                     ckey maxxed-out
+                     add-doc-section add-kind-section add-choice)
+    ; When new docs are installed, the directory's modification date changes:
+    (set! max-reached #f)
+    (unless (eq? doc-collection-date 'none)
+      (when (or (not doc-collection-date)
+                (> (file-or-directory-modify-seconds (collection-path "doc"))
+                   doc-collection-date))
+        (reset-doc-lists)))
+    (let ([hit-count 0])
+      (let-values ([(string-finds finds) (build-string-finds/finds given-find regexp? exact?)]
+                   [(filtered-docs filtered-doc-names filtered-doc-kinds)
+                    (filter-docs manuals doc-txt?)])
+        (for-each
+         (lambda (doc doc-name doc-kind)
+           (define found-one #f)
+           (define (found kind)
+             (unless found-one
+               (add-doc-section doc-name ckey))
+             (unless (equal? found-one kind)
+               (set! found-one kind)
+               (add-kind-section kind ckey))
+             (set! hit-count (add1 hit-count))
+             (unless (< hit-count MAX-HIT-COUNT)
+               (maxxed-out)))
+
+           
+           ; Keyword search
+           (let ([keys (case doc-kind
+                         [(html) (load-html-keywords doc)]
+                         [(text) (load-txt-keywords doc)]
+                         [else null])]
+                 [add-key-choice (lambda (v)
+                                   (when (and (pair? v)
+                                              (pair? (cdr v))
+                                              (pair? (cddr v))
+                                              (pair? (cdddr v))
+                                              (pair? (cddddr v)))
+                                     (found "keyword entries")
+                                     (add-choice
+                                      (car v) ; key
+                                      (cadr v) ; display
+                                      (list-ref v 4) ; title
+                                      (if (eq? 'text doc-kind)
+                                          (apply build-path doc)
+                                          (let ([file (bytes->path 
+                                                       (string->bytes/utf-8
+                                                        (list-ref v 2)))])
+                                            (if (servlet-path? file)
+                                                file
+                                                (build-path doc file))))
+                                      (list-ref v 3) ; label
+                                      ckey)))])
+
+             (unless regexp?
+               (for-each
+                (lambda (v)
+                  (when (string=? given-find (car v))
+                    (add-key-choice v)))
+                keys))
+             (unless (or exact? (null? finds))
+               (for-each
+                (lambda (v)
+                  (when (andmap (lambda (find) (regexp-match find (car v))) finds)
+                    (unless (and (not regexp?) (string=? given-find (car v)))
+                      (add-key-choice v))))
+                keys)))
+           
+           ; Index search
+           (unless (< search-level 1)
+             (let ([index (case doc-kind
+                            [(html) (load-html-index doc)]
+                            [(text) (load-txt-index doc)]
+                            [else null])]
+                   [add-index-choice (lambda (name desc)
+                                       (case doc-kind
+                                         [(html)
+                                          (when (and (pair? desc)
+                                                     (pair? (cdr desc))
+                                                     (pair? (cddr desc)))
+                                            (found "index entries")
+                                            (add-choice 
+                                             "" name
+                                             (list-ref desc 2)
+                                             (let ([filename (bytes->path (string->bytes/utf-8 (list-ref desc 0)))])
+                                               (if (servlet-path? filename)
+                                                   filename
+                                                   (build-path doc filename)))
+                                             (list-ref desc 1)
+                                             ckey))]
+                                         [(text)
+                                          (found "index entries")
+                                          (add-choice 
+                                           "" name
+                                           "indexed content"
+                                           (apply build-path doc)
+                                           desc
+                                           ckey)]))])
+               (when index
+                 (unless regexp?
+                   (for-each
+                    (lambda (v)
+                      (when (string=? given-find (car v))
+                        (add-index-choice (car v) (cdr v))))
+                    index))
+                 (unless (or exact? (null? finds))
+                   (for-each
+                    (lambda (v)
+                      (when (andmap (lambda (find) (regexp-match find (car v))) finds)
+                        (unless (and (not regexp?) (string=? given-find (car v)))
+                          (add-index-choice (car v) (cdr v)))))
+                    index)))))
+           
+           ; Content Search
+           (unless (or (< search-level 2) exact? (null? finds))
+             (let ([files (case doc-kind
+                            [(html) (with-handlers ([exn:fail:filesystem? (lambda (x) null)]) 
+                                      (map (lambda (x) (build-path doc x)) 
+                                           (filter
+                                            (lambda (x) (file-exists? (build-path doc x)))
+                                            (directory-list doc))))]
+                            [(text) (list (apply build-path doc))]
+                            [else null])])
+               (for-each
+                (lambda (f)
+                  (with-handlers ([exn:fail:filesystem? (lambda (x) #f)])
+                    (with-input-from-file f
+                      (lambda ()
+                        (let loop ()
+                          (let ([pos (file-position (current-input-port))]
+                                [r (read-line)])
+                            (unless (eof-object? r)
+                              (let ([m (andmap (lambda (find) (regexp-match find r)) finds)])
+                                (when m
+                                  (found "text")
+                                  (add-choice (car m)
+                                              ; Strip leading space and clean HTML
+                                              (regexp-replace
+                                               "^ [ ]*"
+                                               (if (eq? doc-kind 'html)
+                                                   (clean-html r)
+                                                   r)
+                                               "")
+                                              "content"
+                                              f
+                                              (if (eq? doc-kind 'text) pos "NO TAG")
+                                              ckey)))
+                              (loop))))))))
+                files))))
+         filtered-docs filtered-doc-names filtered-doc-kinds)
+        
+        (if (= 0 hit-count)
+            (format (string-constant plt:hd:nothing-found-for)
+                    (if (null? string-finds)
+                        ""
+                        (apply
+                         string-append
+                         (cons (format "\"~a\"" (car string-finds))
+                               (map (lambda (i) (format " ~a \"~a\"" (string-constant plt:hd:and) i))
+                                    (cdr string-finds))))))
+            #f))))
+  
+  ;; filter-docs : (listof path) boolean -> (values docs[sublist] doc-names[sublist] doc-kinds[sublist])
+  ;; given the list of manuals specified by `manuals', returns the sublists of the global
+  ;; variables docs, doc-names, and doc-kinds that make sense for this search.
+  (define (filter-docs manuals doc-txt?)
+    (let loop ([manuals manuals])
+      (cond
+        [(null? manuals) (if doc-txt?
+                             (extract-doc-txt)
+                             (values null null null))]
+        [else (let ([man (car manuals)])
+                (let-values ([(r-doc r-doc-names r-doc-kinds) (loop (cdr manuals))]
+                             [(t-doc t-doc-names t-doc-kinds) (find-doc man)])
+                  (if t-doc
+                      (values (cons t-doc r-doc)
+                              (cons t-doc-names r-doc-names)
+                              (cons t-doc-kinds r-doc-kinds))
+                      (values r-doc
+                              r-doc-names
+                              r-doc-kinds))))])))
+  
+  ;; find-doc :
+  ;; path -> (values doc[element of docs] doc-name[element of doc-names] doc-kind[element of doc-kinds])
+  (define (find-doc man)
+    (let loop ([x-docs docs]
+               [x-doc-names doc-names]
+               [x-doc-kinds doc-kinds])
+      (cond
+        [(and (null? x-docs) (null? x-doc-names) (null? x-doc-kinds))
+         (values #f #f #f)]
+        [(or (null? x-docs) (null? x-doc-names) (null? x-doc-kinds))
+         (error 'find-doc "mismatched lists\n")]
+        [else
+         (let ([doc (car x-docs)])
+           (cond
+             [(eq? 'html (car x-doc-kinds))
+              (let-values ([(base name dir?) (split-path doc)])
+                (cond
+                  [(equal? man name)
+                   (values doc (car x-doc-names) (car x-doc-kinds))]
+                  [else (loop (cdr x-docs) (cdr x-doc-names) (cdr x-doc-kinds))]))]
+             [else (loop (cdr x-docs) (cdr x-doc-names) (cdr x-doc-kinds))]))])))
+  
+  ;; extract-doc-txt : (listof string) boolean -> (values docs[sublist] doc-names[sublist] doc-kinds[sublist])
+  ;; returns the manuals that are not 'html.
+  (define (extract-doc-txt)
+    (let loop ([x-docs docs]
+               [x-doc-names doc-names]
+               [x-doc-kinds doc-kinds])
+      (cond
+        [(null? x-docs) (values null null null)]
+        [(or (null? x-doc-names) (null? x-doc-kinds))
+         (error 'extract-doc-txt "mismatched lists\n")]
+        [else
+         (if (eq? (car x-doc-kinds) 'html)
+             (loop (cdr x-docs) (cdr x-doc-names) (cdr x-doc-kinds))
+             (let-values ([(r-docs r-doc-names r-doc-kinds) (loop (cdr x-docs) 
+                                                                  (cdr x-doc-names) 
+                                                                  (cdr x-doc-kinds))])
+               (values (cons (car x-docs) r-docs)
+                       (cons (car x-doc-names) r-doc-names)
+                       (cons (car x-doc-kinds) r-doc-kinds))))]))))
+
+
diff --git a/collects/help/private/sig.ss b/collects/help/private/sig.ss
new file mode 100644
index 0000000000..34becea2a2
--- /dev/null
+++ b/collects/help/private/sig.ss
@@ -0,0 +1,12 @@
+(module sig mzscheme
+  (require (lib "unitsig.ss"))
+  (provide gui^)
+  
+  (define-signature gui^
+    (help-desk-frame<%>
+     add-help-desk-mixin
+     new-help-desk
+     find-help-desk-frame
+     show-help-desk
+     search-for-docs
+     search-for-docs/in-frame)))
diff --git a/collects/help/private/standard-urls.ss b/collects/help/private/standard-urls.ss
new file mode 100644
index 0000000000..4d330edb7f
--- /dev/null
+++ b/collects/help/private/standard-urls.ss
@@ -0,0 +1,115 @@
+(module standard-urls mzscheme
+
+  (require "../servlets/private/util.ss"
+           "internal-hp.ss"
+           (lib "contract.ss"))
+  
+  (provide home-page-url)
+  
+  (define (search-type? x)
+    (member x '("keyword" "keyword-index" "keyword-index-text")))
+  
+  (define (search-how? x)
+    (member x '("exact-match" "containing-match" "regexp-match")))
+  
+  (provide search-type? search-how?)
+  (provide/contract 
+   (make-relative-results-url (string? 
+                               search-type? 
+                               search-how?
+                               any/c 
+                               (listof path?)
+                               any/c
+                               (union false/c string?) . -> . string?))
+   (make-results-url (string?
+                      search-type? search-how? any/c 
+                      (listof path?) 
+                      any/c
+                      (union false/c string?)
+                      . -> .
+                      string?))
+   (flush-manuals-url string?)
+   (flush-manuals-path string?)
+   (make-missing-manual-url (string? string? string? string? . -> . string?))
+   (get-hd-location ((lambda (sym) (memq sym hd-location-syms))
+                     . -> . 
+                     string))
+   [make-docs-plt-url (string? . -> . string?)]
+   [make-docs-html-url (string? . -> . string?)])
+
+  (define (make-docs-plt-url manual-name)
+    (format "http://download.plt-scheme.org/doc/~a/bundles/~a-doc.plt"
+            (if (repos-or-nightly-build?)
+                "pre-release"
+                (version))
+            manual-name))
+  
+  (define (make-docs-html-url manual-name)
+    (format "http://download.plt-scheme.org/doc/~a/html/~a/index.htm" 
+            (if (repos-or-nightly-build?)
+                "pre-release"
+                (version))
+            manual-name))
+  
+  (define (prefix-with-server cookie suffix)
+    (format "http://~a:~a~a" internal-host internal-port suffix))
+  
+  (define results-url-prefix (format "http://~a:~a/servlets/results.ss?" internal-host internal-port))
+  (define flush-manuals-path "/servlets/results.ss?flush=yes")
+  (define flush-manuals-url (format "http://~a:~a~a" internal-host internal-port flush-manuals-path))
+  
+  
+  (define relative-results-url-prefix "/servlets/results.ss?")
+
+  (define home-page-url (format "http://~a:~a/servlets/home.ss" internal-host internal-port))
+  
+  (define (make-missing-manual-url cookie coll name link)
+    (format "http://~a:~a/servlets/missing-manual.ss?manual=~a&name=~a&link=~a"
+            internal-host
+            internal-port
+            coll
+            (hexify-string name)
+            (hexify-string link)))
+  
+  (define (make-relative-results-url search-string search-type match-type lucky? manuals doc.txt? lang-name)
+    (string-append
+     relative-results-url-prefix
+     (make-results-url-args search-string search-type match-type lucky? manuals doc.txt? lang-name)))
+
+  (define (make-results-url search-string search-type match-type lucky? manuals doc.txt? lang-name)
+    (string-append
+     results-url-prefix
+     (make-results-url-args search-string search-type match-type lucky? manuals doc.txt? lang-name)))
+  
+  (define (make-results-url-args search-string search-type match-type lucky? manuals doc.txt? language-name)
+    (let ([start
+           (format
+            (string-append "search-string=~a&"
+                           "search-type=~a&"
+                           "match-type=~a&"
+                           "lucky=~a&"
+                           "manuals=~a&"
+                           "doctxt=~a")
+            (hexify-string search-string)
+            search-type
+            match-type
+            (if lucky? "true" "false")
+            (hexify-string (format "~s" (map path->bytes manuals)))
+            (if doc.txt? "true" "false"))])
+      (if language-name
+          (string-append start (format "&langname=~a" (hexify-string language-name)))
+          start)))
+  
+  ; sym, string assoc list
+  (define hd-locations
+    '((hd-tour "/doc/tour/")
+      (release-notes "/servlets/release/notes.ss")
+      (plt-license "/servlets/release/license.ss")
+      (front-page "/servlets/home.ss")))
+  
+  (define hd-location-syms (map car hd-locations))
+
+  (define (get-hd-location sym)
+    ; the assq is guarded by the contract
+    (let ([entry (assq sym hd-locations)])
+      (prefix-with-server (cadr entry)))))
diff --git a/collects/help/private/tcp-intercept.ss b/collects/help/private/tcp-intercept.ss
new file mode 100644
index 0000000000..f7ea6639fd
--- /dev/null
+++ b/collects/help/private/tcp-intercept.ss
@@ -0,0 +1,145 @@
+(module tcp-intercept mzscheme
+  (provide tcp-intercept@ url-intercept@)
+  
+  (require (lib "unitsig.ss")
+           (lib "etc.ss")
+           (lib "sig.ss" "web-server")
+           (lib "tcp-sig.ss" "net")
+           (lib "url-sig.ss" "net")
+           "internal-hp.ss")
+  
+  (define-syntax (redefine stx)
+    (syntax-case stx ()
+      [(_ names ...)
+       (with-syntax ([(defs ...) (map (lambda (x)
+                                        (with-syntax ([orig-name x]
+                                                      [raw-name
+                                                       (datum->syntax-object
+                                                        x
+                                                        (string->symbol
+                                                         (string-append
+                                                          "raw:"
+                                                          (symbol->string (syntax-object->datum x)))))])
+                                          (syntax (define orig-name raw-name))))
+                                      (syntax->list (syntax (names ...))))])
+         (syntax (begin defs ...)))]))
+  
+  (define url-intercept@
+    (unit/sig net:url^
+      (import (raw : net:url^))
+      
+      (define (url->string url)
+        (cond
+          [(and (equal? (url-port url) internal-port)
+                (equal? (url-host url) internal-host))
+           (let* ([long
+                   (raw:url->string 
+                    (raw:make-url ""
+                                  (raw:url-user url)
+                                  ""
+                                  #f
+                                  (raw:url-path url)
+                                  (raw:url-query url)
+                                  (raw:url-fragment url)))])
+             (substring long 3 (string-length long)))]
+          [else (raw:url->string url)]))
+      
+      (redefine make-url
+                struct:url
+                url-scheme set-url-scheme!
+                url-user set-url-user!
+                url-host set-url-host!
+                url-port set-url-port!
+                url-path set-url-path!
+                url-query set-url-query!
+                url-fragment set-url-fragment!
+                url?
+                
+                struct:path/param
+                make-path/param
+                path/param-path set-path/param-path!
+                path/param-param set-path/param-param!
+                path/param?
+                
+                get-pure-port
+                get-impure-port
+                post-pure-port
+                post-impure-port
+                display-pure-port
+                purify-port
+                netscape/string->url
+                string->url
+                call/input-url
+                combine-url/relative
+                url-exception?
+                current-proxy-servers)))
+  
+  (define raw:tcp-abandon-port tcp-abandon-port)
+  (define raw:tcp-accept tcp-accept) 
+  (define raw:tcp-accept-ready? tcp-accept-ready?)
+  (define raw:tcp-addresses tcp-addresses)
+  (define raw:tcp-close tcp-close)
+  (define raw:tcp-connect tcp-connect)
+  (define raw:tcp-connect/enable-break tcp-connect/enable-break)
+  (define raw:tcp-listen tcp-listen)
+  (define raw:tcp-listener? tcp-listener?)
+  
+  ; For tcp-listeners, we use an else branch in the conds since
+  ; (instead of a contract) I want the same error message as the raw
+  ; primitive for bad inputs.
+  
+  ; : (listof nat) -> (unit/sig () -> net:tcp^)
+  (define tcp-intercept@
+    (unit/sig net:tcp^
+      (import web-server^)
+      
+      ; : port -> void
+      (define (tcp-abandon-port tcp-port)
+        (cond
+          [(tcp-port? tcp-port)
+           (raw:tcp-abandon-port tcp-port)]
+          [(input-port? tcp-port)
+           (close-input-port tcp-port)]
+          [(output-port? tcp-port)
+           (close-output-port tcp-port)]
+          [else (void)]))
+      
+      ; : listener -> iport oport
+      (define tcp-accept raw:tcp-accept)
+      
+      ; : tcp-listener -> iport oport
+      (define tcp-accept-ready? raw:tcp-accept-ready?)
+      
+      ; : tcp-port -> str str
+      (define (tcp-addresses tcp-port)
+        (if (tcp-port? tcp-port)
+            (raw:tcp-addresses tcp-port)
+            (values "127.0.0.1" internal-host)))
+      
+      ; : port -> void
+      (define tcp-close raw:tcp-close)
+      
+      ; : (str nat -> iport oport) -> str nat -> iport oport
+      (define (gen-tcp-connect raw)
+        (lambda (hostname-string port)
+          (if (and (or (string=? internal-host hostname-string)
+                       (string=? addon-host hostname-string))
+                   (equal? internal-port port))
+              (let-values ([(req-in req-out) (make-pipe)]
+                           [(resp-in resp-out) (make-pipe)])
+                (parameterize ([current-custodian (make-custodian)])
+                  (serve-ports req-in resp-out))
+                (values resp-in req-out))
+              (raw hostname-string port))))
+      
+      ; : str nat -> iport oport
+      (define tcp-connect (gen-tcp-connect raw:tcp-connect))
+      
+      ; : str nat -> iport oport
+      (define tcp-connect/enable-break (gen-tcp-connect raw:tcp-connect/enable-break))
+      
+      ; FIX - support the reuse? flag.
+      (define tcp-listen raw:tcp-listen)
+      
+      ; : tst -> bool
+      (define tcp-listener? raw:tcp-listener?))))
diff --git a/collects/help/refresh-manuals.ss b/collects/help/refresh-manuals.ss
new file mode 100644
index 0000000000..b47c4db92d
--- /dev/null
+++ b/collects/help/refresh-manuals.ss
@@ -0,0 +1,220 @@
+(module refresh-manuals mzscheme
+  (require "private/docpos.ss"
+           "private/search.ss"
+           "private/manuals.ss"
+           "private/standard-urls.ss"
+           "private/link.ss"
+           (lib "plt-installer.ss" "setup")
+           (lib "url.ss" "net")
+           (lib "mred.ss" "mred")
+           (lib "string-constant.ss" "string-constants")
+           (lib "contract.ss")
+           (lib "port.ss")
+           (lib "thread.ss"))
+  
+  (provide refresh-manuals)
+  
+  (define sc-refreshing-manuals (string-constant plt:hd:refreshing-manuals))
+  (define sc-refresh-downloading... (string-constant plt:hd:refresh-downloading...))
+  (define sc-refresh-deleting... (string-constant plt:hd:refresh-deleting...))
+  (define sc-refresh-installing... (string-constant plt:hd:refresh-installing...))
+  (define sc-finished-installation (string-constant plt:hd:refreshing-manuals-finished))
+  (define sc-clearing-cached-indicies (string-constant plt:hd:refresh-clearing-indicies))
+  
+  (define refresh-manuals
+    (case-lambda
+      [() (refresh-manuals known-docs)]
+      [(docs-to-install)
+       (unless (and (list? docs-to-install)
+                    (andmap (lambda (x) (and (pair? x)
+                                             (path? (car x))
+                                             (string? (cdr x))))
+                            docs-to-install))
+         (error 'refresh-manuals "expected (listof (cons path string)) as argument, got ~e" docs-to-install))
+       (let ([tmp-directory (find/create-temporary-docs-dir)]
+             [success? #f]
+             [thd #f])
+         (with-installer-window
+          (lambda (parent)
+            (set! thd (current-thread))
+            (unless tmp-directory
+              (error 'plt-installer "please clean out ~a" (find-system-path 'temp-dir)))
+            (let ([docs-error (download-docs docs-to-install tmp-directory)])
+              (cond
+                [docs-error
+                 (printf "~a\n" docs-error)]
+                [else
+                 (delete-docs docs-to-install)
+                 (install-docs docs-to-install tmp-directory parent)
+                 (delete-local-plt-files tmp-directory)
+                 (display sc-clearing-cached-indicies)
+                 (newline)
+                 
+                 ;; tell the web-server to visit the url for flushing the cache
+                 ;; this is necc. because the server creates a new namespace for
+                 ;; each servlet, so we have to get the webserver to visit the servlet
+                 ;; in order to flush the cache. We don't, however, want to actually
+                 ;; visit the page, so we just do this for its effect.
+                 (let-values ([(in1 out1) (make-pipe)]
+                              [(in2 out2) (make-pipe)])
+                   (thread (lambda () 
+                             (fprintf out1 "GET ~a HTTP/1.0\r\n" flush-manuals-path)
+                             (close-output-port out1)))
+                   (serve-ports in1 out2) ;; spawns its own thread
+                   (let loop ()
+                     (let ([b (with-handlers ([exn? (lambda (x) eof)])
+                                (read-byte in2))])
+                       (unless (eof-object? b)
+                         (loop))))
+                   (close-input-port in2))])
+              
+              (display sc-finished-installation)
+              (newline)
+              (set! success? #t)))
+          (lambda ()
+            (unless success?
+              (delete-local-plt-files tmp-directory))
+            (kill-thread thd))))]))
+      
+  (define (make-local-doc-filename tmp-dir stub)
+    (build-path tmp-dir (format "~a-doc.plt" stub)))
+
+  ;; if cannot find a suitable directory, #f is returned
+  ;; if okay, returns the path to the directory.
+  (define find/create-temporary-docs-dir
+    ;(-> (union string? false?))
+    (lambda ()
+      (let ([temp-dir (find-system-path 'temp-dir)])
+        (let loop ([n 0])
+          (if (= n 30)
+              #f
+              (let ([candidate (build-path temp-dir (format "help-refresh-docs~a" n))])
+                (if (directory-exists? candidate)
+                    (loop (+ n 1))
+                    (begin
+                      (make-directory candidate)
+                      candidate))))))))
+                  
+
+      
+
+
+                                                        
+    ;;                       ;;;                     ;; 
+     ;                         ;                      ; 
+     ;                         ;                      ; 
+  ;;;;   ;;;  ;;; ;;;; ;;;     ;     ;;;   ;;;;    ;;;; 
+ ;   ;  ;   ;  ;   ;  ;;  ;    ;    ;   ;      ;  ;   ; 
+ ;   ;  ;   ;  ; ; ;  ;   ;    ;    ;   ;   ;;;;  ;   ; 
+ ;   ;  ;   ;  ; ; ;  ;   ;    ;    ;   ;  ;   ;  ;   ; 
+ ;   ;  ;   ;   ; ;   ;   ;    ;    ;   ;  ;   ;  ;   ; 
+  ;;; ;  ;;;    ; ;  ;;;  ;; ;;;;;;  ;;;    ;;; ;  ;;; ;
+                                                        
+                                                        
+                                                        
+
+  ;; download-docs : ... -> (union #f string)
+  ;; downloads the docs to the tmp-dir
+  (define download-docs
+    (lambda (docs-to-install tmp-dir)
+      (let loop ([known-docs docs-to-install])
+        (cond
+          [(null? known-docs) #f]
+          [else (let* ([known-doc (car known-docs)]
+                       [resp (download-doc tmp-dir (car known-doc) (cdr known-doc))])
+                  (if (string? resp)
+                      resp
+                      (loop (cdr known-docs))))]))))
+      
+  ;; download-doc : ... -> (union #f string)
+  ;; stub is the `drscheme' portion of `drscheme-doc.plt'.
+  (define download-doc
+    (lambda (tmp-dir stub full-name)
+      (let ([url (make-docs-plt-url (path->string stub))]
+            [doc-name (make-local-doc-filename tmp-dir stub)])
+        (display (format sc-refresh-downloading... full-name))
+        (newline)
+        (call-with-output-file doc-name
+          (lambda (out-port)
+            (call/input-url (string->url url) 
+                            get-impure-port 
+                            (lambda (in-port)
+                              (let/ec k
+                                (let* ([resp (purify-port in-port)]
+                                       [m (regexp-match #rx"HTTP/[^ ]* ([0-9]+)([^\r\n]*)" resp)])
+                                  (unless m
+                                    (k "malformed response from server ~s" resp))
+                                  (let ([code (string->number (cadr m))])
+                                    (unless (equal? code 200)
+                                      (k (format "error response from server \"~a~a\"" code (caddr m)))))
+                                  (copy-port in-port out-port)
+                                  #f)))))))))
+      
+      
+                                          
+    ;;         ;;;                        
+     ;           ;            ;           
+     ;           ;            ;           
+  ;;;;   ;;;     ;     ;;;   ;;;;;   ;;;  
+ ;   ;  ;   ;    ;    ;   ;   ;     ;   ; 
+ ;   ;  ;;;;;    ;    ;;;;;   ;     ;;;;; 
+ ;   ;  ;        ;    ;       ;     ;     
+ ;   ;  ;   ;    ;    ;   ;   ;   ; ;   ; 
+  ;;; ;  ;;;   ;;;;;;  ;;;     ;;;   ;;;  
+                                          
+                                          
+                                      
+  (define delete-docs
+    (lambda (docs)
+      (for-each (lambda (known-doc) (delete-known-doc (car known-doc) (cdr known-doc)))
+                docs)))
+      
+  (define delete-known-doc
+    (lambda (doc full-name)
+      (let ([doc-dir (find-doc-directory doc)])
+        (when doc-dir
+          (display (format sc-refresh-deleting... full-name))
+          (newline)
+          (delete-directory/r doc-dir)))))
+      
+  (define delete-local-plt-files
+    (lambda (tmp-dir)
+      (delete-directory/r tmp-dir)))
+      
+  ;; deletes the entire subtree underneath this directory
+  ;; (including the dir itself)
+  (define delete-directory/r 
+    (lambda (dir)
+      (when (directory-exists? dir)
+        (let loop ([dir dir])
+          (let ([children (directory-list dir)])
+            (for-each (lambda (f) (when (file-exists? (build-path dir f))
+                                    (delete-file (build-path dir f))))
+                      children)
+            (for-each (lambda (d) (when (directory-exists? (build-path dir d))
+                                    (loop (build-path dir d))))
+                      children)
+            (delete-directory dir))))))
+
+      
+                                                 
+   ;                                ;;;    ;;;   
+                       ;              ;      ;   
+                       ;              ;      ;   
+ ;;;   ; ;;;    ;;;   ;;;;;  ;;;;     ;      ;   
+   ;    ;;  ;  ;   ;   ;         ;    ;      ;   
+   ;    ;   ;   ;;;    ;      ;;;;    ;      ;   
+   ;    ;   ;      ;   ;     ;   ;    ;      ;   
+   ;    ;   ;  ;   ;   ;   ; ;   ;    ;      ;   
+ ;;;;; ;;;  ;;  ;;;     ;;;   ;;; ; ;;;;;; ;;;;;;
+                                                 
+                                                 
+    
+  (define install-docs
+    (lambda (docs-to-install tmp-dir parent)
+      (for-each (lambda (pr) 
+                  (display (format sc-refresh-installing... (cdr pr)))
+                  (newline)
+                  (run-single-installer (make-local-doc-filename tmp-dir (car pr))
+                                        parent))
+                docs-to-install))))
diff --git a/collects/help/servlets/README b/collects/help/servlets/README
new file mode 100644
index 0000000000..d29ac10c07
--- /dev/null
+++ b/collects/help/servlets/README
@@ -0,0 +1,15 @@
+When the doc/help subcollection is installed, the installer creates
+an hdindex file.  See plt/collects/help/doc.txt for information about
+the structure of such files.
+
+To create index entries for Help Desk servlets, put 
+anchor entries of the form
+
+  (A ((NAME "name") (VALUE "Index entry")))
+
+on a single line in the Scheme source.  The NAME attribute
+can be any string that is unique among such anchors in that
+file, though of course it should be mnemonic.  The VALUE
+attribute is used as the index entry that is matched against 
+search strings in Help Desk, and appears again as the 
+link caption in the Help Desk search results.
diff --git a/collects/help/servlets/acknowledge.ss b/collects/help/servlets/acknowledge.ss
new file mode 100644
index 0000000000..5befc6b58c
--- /dev/null
+++ b/collects/help/servlets/acknowledge.ss
@@ -0,0 +1,20 @@
+(module acknowledge mzscheme
+  (require (lib "acks.ss" "drscheme")
+           (lib "servlet.ss" "web-server")
+           "private/util.ss")
+  
+  (provide interface-version timeout start)
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
+  (define (start initial-request)
+    (report-errors-to-browser send/finish)
+    `(HTML 
+      (TITLE "Acknowledgements")
+      (BODY 
+       (A ((NAME "acknowledgements") (VALUE "acknowledgements")))
+       (H1  "Acknowledgements")
+       (P)
+       ,(get-general-acks)
+       (P)
+       ,(get-translating-acks)))))
diff --git a/collects/help/servlets/doc-anchor.ss b/collects/help/servlets/doc-anchor.ss
new file mode 100644
index 0000000000..c230b5feb9
--- /dev/null
+++ b/collects/help/servlets/doc-anchor.ss
@@ -0,0 +1,20 @@
+(module doc-anchor mzscheme
+  (require "private/read-doc.ss")
+  
+  (require (lib "servlet.ss" "web-server"))
+  (provide interface-version timeout start)
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
+  (define (start initial-request)
+    (report-errors-to-browser send/finish)
+    
+    (let* ([bindings (request-bindings initial-request)]
+           [offset (with-handlers
+                       ((void (lambda _ #f)))
+                     (string->number	 
+                      (extract-binding/single 'offset bindings)))])
+      (read-doc (extract-binding/single 'file bindings)
+                (extract-binding/single 'caption bindings)
+                (extract-binding/single 'name bindings)
+                offset))))
\ No newline at end of file
diff --git a/collects/help/servlets/doc-content.ss b/collects/help/servlets/doc-content.ss
new file mode 100644
index 0000000000..ce62e69f13
--- /dev/null
+++ b/collects/help/servlets/doc-content.ss
@@ -0,0 +1,25 @@
+(module doc-content mzscheme
+  
+  (require "private/headelts.ss")
+  (require "private/read-lines.ss")
+  
+  (require (lib "servlet.ss" "web-server"))
+  (provide interface-version timeout start)
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
+  (define (start initial-request)
+    (report-errors-to-browser send/finish)
+    
+    (let* ([bindings (request-bindings initial-request)]
+           [file (extract-binding/single 'file bindings)]
+           [caption (extract-binding/single 'caption bindings)]
+           [offset (with-handlers 
+                       ((void (lambda _ #f)))
+                     (string->number 
+                      (extract-binding/single 'offset bindings)))])
+      `(HTML
+        (HEAD (TITLE "PLT Help Desk") 
+              ,hd-css
+              ,@hd-links)
+        ,(read-lines file caption offset)))))
\ No newline at end of file
diff --git a/collects/help/servlets/doc-message.ss b/collects/help/servlets/doc-message.ss
new file mode 100644
index 0000000000..e8fb6346f8
--- /dev/null
+++ b/collects/help/servlets/doc-message.ss
@@ -0,0 +1,21 @@
+(module doc-message mzscheme
+  (require "private/headelts.ss"
+           "private/util.ss")
+  
+  (require (lib "servlet.ss" "web-server"))
+  (provide interface-version timeout start)
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
+  (define (start initial-request)
+    (report-errors-to-browser send/finish)
+    
+    (let ([bindings (request-bindings initial-request)])
+      `(HTML 
+        (HEAD ,hd-css
+              ,@hd-links
+              (TITLE "PLT collection message"))
+        (BODY 
+         ,(format-collection-message 
+           (extract-binding/single 'msg bindings))
+         (HR))))))
\ No newline at end of file
diff --git a/collects/help/servlets/home.ss b/collects/help/servlets/home.ss
new file mode 100644
index 0000000000..915afe7f23
--- /dev/null
+++ b/collects/help/servlets/home.ss
@@ -0,0 +1,79 @@
+(module home mzscheme
+  (require "private/util.ss"
+           "../private/manuals.ss"
+	   (lib "servlet.ss" "web-server"))
+  
+  (provide interface-version timeout start)
+  
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
+  (define (start initial-request)
+    (report-errors-to-browser send/finish)
+    `(html
+      (head (title "PLT Help Desk"))
+      (BODY
+       (TABLE ((CELLSPACING "0")
+               (CELLPADDING "0"))
+              (TR 
+               (TD
+                (H1 "PLT Help Desk")
+                (UL
+                 (LI
+                  (B
+                   (A ((HREF "/servlets/howtouse.ss")) "Help Desk"))
+                  ":  How to get help"))
+                (UL
+                 (LI
+                  (B
+                   (A ((HREF "/servlets/howtoscheme.ss")) "Software"))
+                  ": How to run programs"
+                  (BR)
+                  'nbsp 'nbsp 'nbsp 'nbsp 'nbsp 'nbsp
+                  (FONT ((SIZE "-2"))
+                        (A ((HREF "/doc/tour/")) "Tour") ", "
+                        (A ((HREF "/servlets/scheme/what.ss")) "Languages") ", "
+                        (A ((HREF "/servlets/manuals.ss")) "Manuals") ", "
+                        (A ((HREF "/servlets/releaseinfo.ss")) "Release") ", "
+                        ,(manual-entry "drscheme"
+                                       "frequently asked questions"
+                                       "FAQ") ", "
+                                              "...")))
+                (UL
+                 (LI
+                  (B
+                   (A ((HREF "/servlets/howtoprogram.ss")) "Program Design"))
+                  ": Learning to program in Scheme"             
+                  (BR) 'nbsp 'nbsp 'nbsp 'nbsp 'nbsp 'nbsp 
+                  (FONT ((SIZE "-2"))
+                        (A ((HREF "/doc/teachpack/")) "Teachpacks") ", "
+                        (A ((HREF "/servlets/research/why.ss")) "Why DrScheme?") ", "
+                        "...")))
+                
+                (UL
+                 (LI
+                  (B 
+                   (A ((HREF "/servlets/resources.ss")) "External Resources")) 
+                  ": Additional information"
+                  
+                  (BR)
+                  'nbsp 'nbsp 'nbsp 'nbsp 'nbsp 'nbsp 
+                  (FONT ((SIZE "-2"))
+                        (A ((HREF "/servlets/resources/teachscheme.ss")) "TeachScheme!") ", "
+                        (A ((HREF "/servlets/resources/libext.ss")) "Libraries") ", "
+                        (A ((HREF "/servlets/resources/maillist.ss")) "Mailing Lists") ", "
+                        "...")))
+                (P)
+                'nbsp 'nbsp 'nbsp
+                (B
+                 (A ((HREF "/servlets/acknowledge.ss"))
+                    (FONT ((COLOR "limegreen"))
+                          "Acknowledgements")))
+                'nbsp 'nbsp 'nbsp 'nbsp
+                (B
+                 (A ((mzscheme
+                      "((dynamic-require '(lib |bug-report.ss| |help|) 'help-desk:report-bug))"))
+                    (FONT ((COLOR "limegreen"))
+                          "Send a bug report")))
+                (P)
+                (I "Version: " ,(plt-version)))))))))
\ No newline at end of file
diff --git a/collects/help/servlets/howtodrscheme.ss b/collects/help/servlets/howtodrscheme.ss
new file mode 100644
index 0000000000..c076971fe8
--- /dev/null
+++ b/collects/help/servlets/howtodrscheme.ss
@@ -0,0 +1,31 @@
+(module howtodrscheme mzscheme
+  (require "private/headelts.ss"
+           "../private/manuals.ss")
+  
+  (require (lib "servlet.ss" "web-server"))
+  (provide interface-version timeout start)
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
+  (define (start initial-request)
+    (report-errors-to-browser send/finish)
+    
+    `(HTML 
+      (TITLE "DrScheme")	
+      (HEAD ,hd-css
+            ,@hd-links)
+      (BODY 
+       (H1 "DrScheme") 
+       "DrScheme is PLT's flagship programming environment. "
+       "See " (A ((HREF "/servlets/scheme/how.ss")) "Software & Components") 
+       " for a guide to the full suite of PLT tools." 
+       (UL  
+        (LI  (B  (A ((HREF "/doc/tour/")) "Tour")) ": An introduction to DrScheme")
+        (LI  (B  ,(manual-entry "drscheme" 
+                                "graphical interface"
+                                "Interface Essentials"))
+             ": Quick-start jump into the user manual")
+        (LI  (B  (A ((HREF "/servlets/scheme/what.ss")) 
+                    "Languages")) 
+             ": Languages supported by DrScheme")
+        (LI  (B  ,(main-manual-page "drscheme")) ": The complete user manual"))))))
\ No newline at end of file
diff --git a/collects/help/servlets/howtoprogram.ss b/collects/help/servlets/howtoprogram.ss
new file mode 100644
index 0000000000..aadea4a72e
--- /dev/null
+++ b/collects/help/servlets/howtoprogram.ss
@@ -0,0 +1,39 @@
+(module howtoprogram mzscheme
+  (require "private/util.ss"
+           "private/headelts.ss"
+           (lib "servlet.ss" "web-server"))
+  
+  (provide interface-version timeout start)
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
+  (define (start initial-request)
+    (report-errors-to-browser send/finish)
+    
+    `(HTML 
+      (TITLE "Program Design")
+      (HEAD ,hd-css
+            ,@hd-links)
+      (BODY 
+       (H1  "Program Design")
+       ,(color-highlight `(H2  "For Students"))
+       "The textbook " (I  "How to Design Programs") 
+       " provides an introduction to programming using the DrScheme environment. "
+       "The book is not distributed with DrScheme, but it is available online at " 
+       (PRE  
+        "   " (A ((HREF "http://www.htdp.org/")
+                  (TARGET "_top")) "http://www.htdp.org/"))  
+       (P)
+       "Help Desk provides the following interactive support for the textbook:"
+       (UL  
+        (LI  (B  (A ((HREF "/doc/teachpack/index.html"))
+                    "Teachpack documentation"))))
+       (P)
+       ,(color-highlight
+         `(H2  "For Experienced Programmers"))
+       (UL  (LI  (B  (A ((HREF "/doc/t-y-scheme/index.htm"))
+                        "Teach Yourself Scheme in Fixnum Days")) 
+                 ": For programmers with lots of experience in other languages"))
+       ,(color-highlight `(H2  "For Teachers and Researchers"))
+       (UL  (LI  (B  (A ((HREF "/servlets/research/why.ss")) "Why DrScheme?"))
+                 ": PLT's vision "))))))
\ No newline at end of file
diff --git a/collects/help/servlets/howtoscheme.ss b/collects/help/servlets/howtoscheme.ss
new file mode 100644
index 0000000000..0878359469
--- /dev/null
+++ b/collects/help/servlets/howtoscheme.ss
@@ -0,0 +1,42 @@
+(module howtoscheme mzscheme
+  (require "../private/manuals.ss")
+  
+  (require "private/headelts.ss")
+  (require (lib "servlet.ss" "web-server"))
+  (provide interface-version timeout start)
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
+  (define (start initial-request)
+    (report-errors-to-browser send/finish)
+    
+    `(HTML 
+      (TITLE "Software")
+      (HEAD ,hd-css
+            ,@hd-links)
+      (BODY 
+       (H1  "Software")  
+       (UL  
+        (LI  (B  (A ((HREF "howtodrscheme.ss")) "DrScheme")) 
+             ": The programming environment")
+        (LI  (B  (A ((HREF "/servlets/scheme/what.ss")) "Languages")) 
+             ": The family of languages supported by PLT Software")
+        (LI  (B  (A ((HREF "/servlets/scheme/how.ss")) "Software & Components")) 
+             ": The full suite of PLT tools " 
+             (BR) 'nbsp 'nbsp 'nbsp 'nbsp
+             (FONT ((SIZE "-2")) 
+                   (A ((HREF "/servlets/scheme/how.ss#installed-components")) "Installed Components") ", ..."))
+        (LI  (B  (A ((href "/servlets/scheme/doc.ss")) "Documentation")) ": Organization and manuals       " 
+             (BR) 'nbsp 'nbsp 'nbsp 'nbsp
+             (FONT ((SIZE "-2")) 
+                   (A ((HREF "/servlets/manuals.ss")) "Manuals") ", ...") )
+        (LI  (B  (A ((HREF "scheme/misc.ss")) "Hints")) 
+             ": How to do things in Scheme " )
+        (LI  (B 
+              ,(manual-entry "drscheme"
+                             "frequently asked questions"
+                             "FAQ"))
+             ": Frequently asked questions")
+        (LI  
+         (B (A ((HREF "releaseinfo.ss")) "Release Information")) 
+         ": License, notes, and known bugs"))))))
\ No newline at end of file
diff --git a/collects/help/servlets/howtouse.ss b/collects/help/servlets/howtouse.ss
new file mode 100644
index 0000000000..31b3b360a1
--- /dev/null
+++ b/collects/help/servlets/howtouse.ss
@@ -0,0 +1,82 @@
+(module howtouse mzscheme
+  (require "private/util.ss"
+           "private/headelts.ss"
+           (lib "string-constant.ss" "string-constants"))
+  
+  (require (lib "servlet.ss" "web-server"))
+  (provide interface-version timeout start)
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
+  (define (start initial-request)
+    (report-errors-to-browser send/finish)
+    
+    `(HTML 
+      (TITLE "Help Desk")
+      (HEAD ,hd-css
+            ,@hd-links)
+      (BODY 
+       (H1 "Help Desk") 
+       (P)
+       (A ((NAME "helpme") (VALUE "Help Desk")))
+       "Help Desk (the program you're currently running) is a "
+       "complete source of information about PLT software, "
+       "including DrScheme, MzScheme, and MrEd."
+       (P)
+       "Use Help Desk to find information in either of two ways:"
+       (P)
+       ,(color-highlight
+         "1) Navigate the Help Desk information pages by "
+         "clicking on hyperlinks.")
+       (UL 
+        (LI  "The " (B  (TT  ,(string-constant home))) " button "
+             "at the top of the page always takes "
+             "you back to the starting page.")
+        (LI  "The " (B  (TT  "Manuals")) " link "
+             " displays a list "
+             " of manuals and other documentation.")
+        (LI  "The " (B  (TT  "Send a bug report")) 
+             " link "
+             "allows you to submit bug reports to PLT."))
+       (P)
+       (A ((NAME "helpsearch") (VALUE "Searching in Help Desk")))
+       (A ((NAME "search")))
+       ,(color-highlight
+         "2) Search for terms using the " 
+         `(B  (TT  "Find docs for"))  
+         " field at the bottom of Help Desk.")
+       (UL  
+        (LI  "Enter one or more terms into the " 
+             (B  (TT  "Find docs for")) " field.")
+        (LI  "Click the " (B  "Search") " button "
+             "(or hit Enter) to start a search, "
+             "or choose the " (B "Feeling Lucky") " menu item.")
+        (LI  "If you click on the " (B "Search") " button, "
+             "Help Desk scans the documentation pages and "
+             "returns a list of hyperlinks for "
+             (I  "keyword") ", "
+             (I  "index entry") ", and "
+             (I  "raw text")  " matches:"
+             (UL 
+              (LI  (I  "Keywords") " are Scheme names, "
+                   "such as " (TT  "define") " and "
+                   (TT  "cons") ".") 
+              (LI  (I  "Index entries")
+                   " are topical phrases, such as \"lists\".")
+              (LI  (I  "Raw text") " results are fragments of "
+                   "text from the documentation pages. "
+                   "(Raw text results are useful only as "
+                   "a last resort.)")))
+        (LI "If you perform a lucky search, "
+            "Help Desk goes directly to the first item of documentation "
+            "that matches the search term, without displaying links to "
+            "all relevant items."))
+       (P)
+       "Help Desk sorts search results according to their source."
+       (p)
+       "If you open Help Desk inside DrScheme, the search results are "
+       "filtered based on the language you are using. Use " 
+            (tt "Choose Language...")
+            " menu item from the "
+            (tt "Language")
+            " menu to change the language."))))
\ No newline at end of file
diff --git a/collects/help/servlets/info.ss b/collects/help/servlets/info.ss
new file mode 100644
index 0000000000..ce5e06e08b
--- /dev/null
+++ b/collects/help/servlets/info.ss
@@ -0,0 +1,2 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Help Servlets"))
diff --git a/collects/help/servlets/manual-section.ss b/collects/help/servlets/manual-section.ss
new file mode 100644
index 0000000000..f90eebd0a5
--- /dev/null
+++ b/collects/help/servlets/manual-section.ss
@@ -0,0 +1,34 @@
+(module manual-section mzscheme
+  (require "../private/manuals.ss"
+           "private/headelts.ss")
+  
+  (require (lib "servlet.ss" "web-server"))
+  (provide interface-version timeout start)
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
+  (define (start initial-request)
+    (report-errors-to-browser send/finish)
+    (let* ([bindings (request-bindings initial-request)]
+           [manual (extract-binding/single 'manual bindings)]
+           [raw-section (extract-binding/single 'section bindings)]
+           ; remove quotes
+           [section (substring raw-section 
+                               1 (sub1 (string-length raw-section)))]
+           [page (with-handlers 
+                     ([void (lambda _
+                              (send/finish
+                               `(HTML 
+                                 (HEAD (TITLE "Can't find manual section")
+                                       ,hd-css
+                                       ,@hd-links)
+                                 (BODY
+                                  "Error looking up PLT manual section" 
+                                  (P)
+                                  "Requested manual: "
+                                  ,manual (BR)
+                                  "Requested section: "
+                                  ,section))))])
+                   (finddoc-page-anchor manual section))])
+      (send/finish
+       (redirect-to page)))))
\ No newline at end of file
diff --git a/collects/help/servlets/manuals.ss b/collects/help/servlets/manuals.ss
new file mode 100644
index 0000000000..34f726522a
--- /dev/null
+++ b/collects/help/servlets/manuals.ss
@@ -0,0 +1,13 @@
+(module manuals mzscheme
+  (require "../private/manuals.ss")
+  
+  (require (lib "servlet.ss" "web-server"))
+  (provide interface-version timeout start)
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
+  (define (start initial-request)
+    (report-errors-to-browser send/finish)
+    (list
+     "text/html"	 
+     (find-manuals))))
\ No newline at end of file
diff --git a/collects/help/servlets/missing-manual.ss b/collects/help/servlets/missing-manual.ss
new file mode 100644
index 0000000000..7da5b99e81
--- /dev/null
+++ b/collects/help/servlets/missing-manual.ss
@@ -0,0 +1,51 @@
+(module missing-manual mzscheme
+  (require (lib "servlet.ss" "web-server"))
+  
+  (require "private/headelts.ss")
+  (require "private/util.ss"
+           "../private/standard-urls.ss")
+  
+  (define (no-manual manual label link)
+    (let* ([html-url (make-docs-html-url manual)]
+           [plt-url (make-docs-plt-url manual)])
+      `(html
+        (head ,hd-css
+              ,@hd-links 
+              (TITLE "Missing PLT manual")) 
+        (body ((bgcolor "white")) 
+              ,(color-with "red" `(h1 "Documentation missing"))
+              (P)
+              "You tried to access documentation for "
+              ,(color-with "blue" `(B ,label)) ". "
+              "The documentation is not installed on this "
+              "machine, probably because it is not part of the "
+              "standard DrScheme distribution."
+              (p)
+              
+              (h2 "Install Locally")
+              (a ((href ,plt-url)) "Download and/or install")
+              " the documentation."
+              (br)
+              "After installing, "
+              (a ((href ,link)) "continue")
+              " to the originally requested page."
+              
+              (br) nbsp (br)
+              
+              (h2 "Read Online")
+              "Read the documentation on "
+              (a ((href ,html-url)) "PLT's servers")
+              "."))))
+  
+  (require (lib "servlet.ss" "web-server"))
+  (provide interface-version timeout start)
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
+  (define (start initial-request)
+    (report-errors-to-browser send/finish)
+    
+    (let ([bindings (request-bindings initial-request)])
+      (no-manual (extract-binding/single 'manual bindings)
+                 (extract-binding/single 'name bindings)
+                 (extract-binding/single 'link bindings)))))
diff --git a/collects/help/servlets/plticon.ico b/collects/help/servlets/plticon.ico
new file mode 100644
index 0000000000..d6abc58646
Binary files /dev/null and b/collects/help/servlets/plticon.ico differ
diff --git a/collects/help/servlets/private/exit.ss b/collects/help/servlets/private/exit.ss
new file mode 100644
index 0000000000..f87bfab857
--- /dev/null
+++ b/collects/help/servlets/private/exit.ss
@@ -0,0 +1,4 @@
+(module exit mzscheme
+  (provide exit-box)
+  (define exit-box (box #f)))
+
diff --git a/collects/help/servlets/private/external.ss b/collects/help/servlets/private/external.ss
new file mode 100644
index 0000000000..cc3e49d8f8
--- /dev/null
+++ b/collects/help/servlets/private/external.ss
@@ -0,0 +1,38 @@
+(module external mzscheme
+
+  (require (lib "servlet.ss" "web-server")
+           (lib "defmacro.ss"))
+
+  (require "headelts.ss")
+
+  (provide external-box
+	   check-external)
+
+  (define external-box (box #f))
+  
+  (define (check-external show url)
+    (when (unbox external-box)
+      (show 
+       `(HTML
+	 (HEAD ,hd-css
+               ,@hd-links
+	       (TITLE "Servlet unavailable"))
+	 (BODY
+	  (H3
+	   (FONT ((COLOR "red"))
+		 "Servlet unavailable"))
+	  (P)
+	  "Because the PLT Help Desk server is "
+	  "accepting external connections, the "
+	  "requested Help Desk servlet"
+	  (BLOCKQUOTE (TT ,url))
+	  "is not available."))))))
+
+
+
+
+
+
+
+
+
diff --git a/collects/help/servlets/private/headelts.ss b/collects/help/servlets/private/headelts.ss
new file mode 100644
index 0000000000..584e535025
--- /dev/null
+++ b/collects/help/servlets/private/headelts.ss
@@ -0,0 +1,67 @@
+; elements to go in HEAD part of HTML document
+
+(module headelts mzscheme
+  (require (lib "list.ss"))
+
+  (provide hd-css
+           hd-links)
+
+  ; cascading style sheet rules for Help Desk
+ 
+  ; (listof (tag attrib+))
+  ;   where attrib is a property name, value pair
+  ;         where a value is a symbol or (listof symbol)
+  (define css-rules
+    '((BODY (background-color white)
+	    (font-family (Helvetica sans-serif)))))
+
+  (define nl (string #\newline))
+
+  (define (css-rules->style)
+    (apply string-append
+     (map
+      (lambda (s)
+	(string-append s nl))
+      (map 
+       (lambda (rule)
+	 (let ([tag (car rule)]
+	       [attribs (cdr rule)])
+	   (string-append 
+	    (symbol->string tag)
+	    " {"
+	    (foldr
+	     (lambda (s a)
+	       (if a
+		   (string-append s "; " a)
+		   s))
+	     #f
+	     (map 
+		(lambda (attrib)
+		  (let ([property (car attrib)]
+			[vals (cadr attrib)])
+		    (string-append (symbol->string property) ":"
+				   (if (pair? vals)
+				       (foldr
+					(lambda (s a)
+					  (if a
+					      (string-append s "," a)
+					      s))
+					#f
+					(map symbol->string vals))
+				       (symbol->string vals)))))
+		attribs))
+	    "}")))
+       css-rules))))
+
+  (define hd-css
+    `(STYLE ((TYPE "text/css"))
+	    ,(css-rules->style)))
+
+  ; LINKs for showing PLT icon
+
+  (define hd-links
+    `((LINK ((REL "icon") (HREF "/help/servlets/plticon.ico") 
+	     (TYPE "image/ico")))
+      (LINK ((REL "SHORTCUT ICON") (HREF "/help/servlets/plticon.ico"))))))
+
+
diff --git a/collects/help/servlets/private/info.ss b/collects/help/servlets/private/info.ss
new file mode 100644
index 0000000000..592c4e457d
--- /dev/null
+++ b/collects/help/servlets/private/info.ss
@@ -0,0 +1,11 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Help Desk servlets private"))
+
+
+
+	
+
+
+	
+
+
diff --git a/collects/help/servlets/private/read-doc.ss b/collects/help/servlets/private/read-doc.ss
new file mode 100644
index 0000000000..3ff668c16e
--- /dev/null
+++ b/collects/help/servlets/private/read-doc.ss
@@ -0,0 +1,40 @@
+(module read-doc mzscheme
+
+  (require (lib "etc.ss"))
+  (require (lib "getinfo.ss" "setup"))
+
+  (require "util.ss")
+  (require "read-lines.ss")
+  (require "headelts.ss")
+
+  (provide read-doc)
+
+  ; extracts help desk message
+  (define (get-message coll)
+    (with-handlers ; collection may not exist
+     ((void (lambda _ #f)))
+     ((get-info (list coll)) 
+      'help-desk-message
+      (lambda () #f))))
+
+  (define no-offset-format "file=~a&caption=~a")
+  (define offset-format (string-append no-offset-format "&offset=~a#temp"))
+
+  (define (build-page file caption coll offset)
+    (let ([msg (get-message coll)])
+      (if msg
+	  `(HTML
+            (HEAD (TITLE "PLT Help Desk") 
+                  ,hd-css)
+            (BODY
+             ,(format-collection-message msg)
+             (HR)
+             ,(read-lines file caption offset)))
+	  `(HTML
+	    (HEAD (TITLE "PLT Help Desk") 
+		  ,hd-css)
+	    ,(read-lines file caption offset)))))
+
+  (define read-doc 
+    (opt-lambda (file caption coll [offset #f])
+      (build-page file caption coll offset))))
diff --git a/collects/help/servlets/private/read-lines.ss b/collects/help/servlets/private/read-lines.ss
new file mode 100644
index 0000000000..f835ce4286
--- /dev/null
+++ b/collects/help/servlets/private/read-lines.ss
@@ -0,0 +1,185 @@
+(module read-lines mzscheme
+
+  (require (lib "etc.ss")
+	   (lib "pregexp.ss")
+	   "util.ss")	
+
+  (provide read-lines)
+
+  (define read-lines
+    (opt-lambda (file caption [offset #f])
+      (template caption (get-the-lines file offset))))
+  
+  (define (semi-flatten lst)
+    (if (null? lst) 
+	'()
+	(cons (caar lst)
+	      (cons (cadar lst)
+		    (semi-flatten (cdr lst))))))
+
+  (define temp-anchor `(A ((NAME "temp")) ""))
+
+  (define (spacify s)
+    (if (and (string? s) (string=? s "")) 
+	" " ; to appease IE
+	s))
+
+  (define (template caption lines) 
+    `(TABLE ((CELLPADDING "0")
+	     (CELLSPACING "0"))
+	    (B ,(color-with "blue" caption))
+	    (P)
+	    (PRE ((STYLE "font-family:monospace"))
+            ; use <BR>'s instead of newlines, for Opera
+            ; don't put in a <BR> for the temp-anchor, which wasn't a line in the source
+		 ,@(semi-flatten 
+		    (map (lambda (ln) 
+			   (if (eq? ln temp-anchor)
+			       `(,ln "")
+			       `(,(spacify ln) (BR)))) lines)))))
+    
+  (define eoregexp
+    "($|\\s|(\\.(\\s|$))|>)")
+
+  (define trailing-regexp
+    (pregexp "[\\s>)(\"]"))
+
+  (define url-regexp-base
+    (string-append "://([^\\s]*)" eoregexp))
+
+  (define (make-url-regexp ty)
+    (pregexp 
+     (string-append 
+      ty
+      url-regexp-base)))
+
+  (define http-regexp (make-url-regexp "http"))
+  (define cheap-http-regexp (regexp "http://"))
+  (define (http-format url)
+    `(A ((HREF ,url)) ,url))
+  (define ftp-regexp (make-url-regexp "ftp"))
+  (define cheap-ftp-regexp (regexp "ftp://"))
+  (define ftp-format http-format) 
+
+  (define email-regexp
+    (let ([chars "[^\\s)(<>\"']"])
+      (pregexp (string-append chars "+" "@" chars "{3,}"))))
+  (define cheap-email-regexp (regexp "@"))
+  (define (email-format addr)
+    `(A ((HREF ,(string-append "mailto:" addr))) ,addr))
+
+  (define (rtrim s)
+    (let* ([presult (pregexp-replace* trailing-regexp s "")]
+	   [plen (string-length presult)]
+	   [qlen (sub1 plen)])
+      (if (and (> qlen 0)
+	       (char=? (string-ref presult qlen)
+		       #\.))
+	  (substring presult 0 qlen)
+	  presult)))
+
+  (define (process-for-urls line)
+    (let loop ([built-line line])
+      (let ([curr-len (string-length built-line)])
+	(let-values 
+	 ([(raw-indices formatter)
+	   (let regexp-loop ([regexps (list http-regexp
+                                            ftp-regexp
+                                            email-regexp)]
+                             [cheap-regexps 
+                              (list cheap-http-regexp
+                                    cheap-ftp-regexp
+                                    cheap-email-regexp)]
+                             [formats (list http-format
+                                            ftp-format
+                                            email-format)])
+	     (if (null? regexps)
+		 (values #f #f)
+		 (let* ([curr-regexp (car regexps)]
+			[curr-cheap-regexp (car cheap-regexps)]
+			[curr-formatter (car formats)]
+			[match-indices
+			 (and (regexp-match-positions
+			       curr-cheap-regexp built-line)
+			      (pregexp-match-positions 
+			       curr-regexp built-line))])
+		   (if match-indices
+		       (values match-indices curr-formatter)
+		       (regexp-loop (cdr regexps) (cdr cheap-regexps)
+				    (cdr formats))))))])
+	 (if raw-indices
+	     (let* ([indices (car raw-indices)]
+		    [string-start (car indices)]
+		    [string-end (cdr indices)]
+		    [raw-item 
+		     (substring built-line 
+				string-start string-end)]
+		    [raw-item-len (string-length raw-item)]
+		    [item (rtrim raw-item)]
+		    [item-len (string-length item)])
+		`(TT
+		  ,(substring built-line 0 string-start)
+		  ,(formatter item)
+		  ,(substring raw-item ; text removed by rtrim
+			      item-len
+			      raw-item-len)
+		  ,(loop (substring built-line string-end 
+				    curr-len))))
+	     built-line)))))
+
+  (define (process-for-keywords line)
+    (let ([len (string-length line)])
+      (if (and (> len 3)
+	       (char=? (string-ref line 0) #\>))
+          (let* ([rest-of-line (substring line 1 len)]
+                 [port (open-input-string rest-of-line)]
+                 [dist
+                  (with-handlers ([exn:fail:read? (lambda (x) #f)])
+                    (read port)
+                    (let-values ([(_1 _2 pos) (port-next-location port)])
+                      pos))])
+            (if dist
+                `(div (b ">" ,(color-highlight (substring line 1 dist)))
+                      ,(substring line dist len))
+                line))
+          #f)))
+
+  ; format line for doc.txt files
+  (define (process-doc-line line)
+    (let ([key-result (process-for-keywords line)])
+      (if key-result
+	  key-result
+	  (process-for-urls line))))
+
+  (define (get-the-lines file offset)
+    (let* ([port (open-input-file file 'text)]
+	   [doc-txt? (let ([len (string-length file)])
+		       (string=? (substring file (- len 7) len)
+				 "doc.txt"))]
+	   [process-line
+	    (if doc-txt?
+		process-doc-line
+		(lambda (x) x))]
+	   [lines (let loop ([lines '()])	
+		    (let ([line (read-line port)])
+		      (if (eof-object? line)
+			  (begin
+			    (close-input-port port)
+			    (reverse lines))
+			  (loop (cons line lines)))))])
+      (if offset
+	  (let loop ([lines lines]
+		     [count 0])
+	    (if (null? lines)
+		'()
+		(let ([len (add1 (string-length (car lines)))])
+	          ; add1 because newline in source omitted
+		  (if (>= count offset)
+		      (cons temp-anchor
+			    (if doc-txt?
+				(map process-doc-line lines)
+				lines))
+		      (cons (process-line (car lines))
+			    (loop (cdr lines)
+				  (+ count len)))))))
+	  (map process-line lines)))))
diff --git a/collects/help/servlets/private/search-util.ss b/collects/help/servlets/private/search-util.ss
new file mode 100644
index 0000000000..bbebd91630
--- /dev/null
+++ b/collects/help/servlets/private/search-util.ss
@@ -0,0 +1,31 @@
+(module search-util mzscheme
+
+  (require (lib "string-constant.ss" "string-constants"))
+
+  (provide 
+    search-types 
+    search-type-default
+    match-types
+    match-type-default
+    kind-types)
+
+  (define search-types
+    `(("keyword" ,(string-constant plt:hd:search-for-keyword))
+      ("keyword-index" ,(string-constant plt:hd:search-for-keyword-or-index))
+      ("keyword-index-text" ,(string-constant plt:hd:search-for-keyword-or-index-or-text))))
+
+  (define search-type-default "keyword-index")
+
+  (define match-types
+    `(("exact-match" ,(string-constant plt:hd:exact-match))
+      ("containing-match" ,(string-constant plt:hd:containing-match))
+      ("regexp-match" ,(string-constant plt:hd:regexp-match))))
+
+  (define match-type-default "containing-match")
+
+  (define kind-types
+    `(("index entries" html)
+      ("keyword entries" text)
+      ("text" text))))
+
+
diff --git a/collects/help/servlets/private/util.ss b/collects/help/servlets/private/util.ss
new file mode 100644
index 0000000000..c8a1cd8276
--- /dev/null
+++ b/collects/help/servlets/private/util.ss
@@ -0,0 +1,157 @@
+(module util mzscheme
+  (require (lib "file.ss")
+	   (lib "list.ss")
+	   (lib "xml.ss" "xml")
+           (lib "string-constant.ss" "string-constants")
+           (lib "contract.ss"))
+
+  (provide/contract
+   [hexify-string (string? . -> . string?)]
+   [fold-into-web-path ((listof string?) . -> . string?)])
+  
+  (provide get-pref/default
+           get-bool-pref/default
+           put-prefs
+           repos-or-nightly-build?
+           search-height-default
+           search-bg-default
+           search-text-default
+           search-link-default
+           color-highlight
+           color-with
+           collection-doc-link
+           home-page
+           format-collection-message
+           nl
+           plt-version
+           make-javascript
+           redir-javascript
+           onload-redir)
+
+  ;; would be nice if this could use version:version from the framework.
+  (define (plt-version)
+    (let ([mz-version (version)]
+          [stamp-collection
+           (with-handlers ([exn:fail:filesystem? (lambda (exn) #f)])
+             (collection-path "repos-time-stamp"))])
+      (if (and stamp-collection (file-exists? (build-path stamp-collection "stamp.ss")))
+          (format "~a-cvs~a" mz-version (dynamic-require '(lib "stamp.ss" "repos-time-stamp") 'stamp))
+          mz-version)))
+  
+  
+  (define home-page 
+    `(A ((HREF "/servlets/home.ss") (TARGET "_top"))
+	,(string-constant plt:hd:home)))
+
+  (define (get-pref/default pref default)
+    (get-preference pref (lambda () default)))
+
+  (define (get-bool-pref/default pref default)
+    (let ([raw-pref (get-pref/default pref default)])
+      (if (string=? raw-pref "false") #f #t)))
+
+  (define (put-prefs names vals)
+    (put-preferences names vals)) 
+
+  (define search-height-default "85")
+  (define search-bg-default "lightsteelblue")
+  (define search-text-default "black")
+  (define search-link-default "darkblue")
+
+  (define *the-highlight-color* "forestgreen")
+
+  ; string xexpr ... -> xexpr
+  (define (color-with color . s)
+    `(FONT ((COLOR ,color)) ,@s))
+
+  ; xexpr ... -> xexpr
+  (define (color-highlight . s)
+    (apply color-with *the-highlight-color* s))
+
+  (define repos-or-nightly-build?
+    (let ([helpdir (collection-path "help")])
+      (lambda ()
+        (or (directory-exists? (build-path helpdir ".svn"))
+            (directory-exists? (build-path helpdir "CVS"))
+            (with-handlers ([exn:fail:filesystem? (lambda (x) #f)])
+              (collection-path "repos-time-stamp"))))))
+  
+  (define hexifiable '(#\: #\; #\? #\& #\% #\# #\< #\> #\+))
+  
+  ; string -> string
+  (define (hexify-string s)
+    (apply string-append 
+	   (map (lambda (c) 
+		  (if (can-keep? c)
+		      (string c)
+		      (format "%~X" (char->integer c))))
+		(string->list s))))
+
+  ;; can-keep? : char -> boolean
+  ;; source rfc 2396
+  (define (can-keep? c)
+    (let ([i (char->integer c)])
+      (or (<= (char->integer #\a) i (char->integer #\z))
+          (<= (char->integer #\A) i (char->integer #\Z))
+          (<= (char->integer #\0) i (char->integer #\9))
+          (memq c '(#\- #\_ #\; #\. #\! #\~ #\* #\' #\( #\))))))
+  
+  ; string string -> xexpr
+  (define (collection-doc-link coll txt)
+    (let ([coll-file (build-path 
+		      (collection-path coll) "doc.txt")])
+      (if (file-exists? coll-file)
+	  `(A ((HREF 
+		,(format 
+		  "/servlets/doc-anchor.ss?file=~a&name=~a&caption=Documentation for the ~a collection"
+		  (hexify-string (path->string coll-file))
+		  coll
+		  coll)))
+	      ,txt)
+	  "")))
+
+  ; (listof string) -> string
+  ; result is forward-slashed web path
+  ;  e.g. ("foo" "bar") -> "foo/bar"
+  (define (fold-into-web-path lst)
+      (foldr (lambda (s a)
+	       (if a
+		   (string-append s "/" a)
+		   s))
+	     #f
+	     lst))
+  
+  ;; ??
+  ;(define (text-frame) "_top")
+
+  (define (format-collection-message s)
+    `(B ((STYLE "color:green")) ,s))
+
+  (define nl (string #\newline))
+
+  (define (make-javascript . ss)
+    `(SCRIPT ((LANGUAGE "Javascript"))
+	     ,(make-comment
+	       (apply string-append 
+		      nl
+		      (map (lambda (s)
+			     (string-append s nl))
+			   ss)))))
+
+  (define (redir-javascript k-url)
+    (make-javascript
+     "function redir() {"
+     (string-append
+       "  document.location.href=\"" k-url "\"") 
+     "}"))
+
+  (define (onload-redir secs)
+    (string-append 
+     "setTimeout(\"redir()\","
+     (number->string (* secs 1000))
+     ")")))
+
+
+
+
+
diff --git a/collects/help/servlets/release/bugs.ss b/collects/help/servlets/release/bugs.ss
new file mode 100644
index 0000000000..6c904ca132
--- /dev/null
+++ b/collects/help/servlets/release/bugs.ss
@@ -0,0 +1,42 @@
+(module bugs mzscheme
+  (require (lib "string.ss"))
+  
+  (require "../private/util.ss")
+  (require "../private/headelts.ss")
+  
+  (require (lib "servlet.ss" "web-server"))
+  (provide interface-version timeout start)
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
+  (define (start initial-request)
+    
+    (define stupid-internal-define-syntax (report-errors-to-browser send/finish))
+    
+    (define (make-bug-link name)
+      (let ([dir (string-copy name)])
+        (string-lowercase! dir)
+        `(LI (A ((HREF ,(string-append 
+                         "/servlets/doc-anchor.ss?file="
+                         (hexify-string
+                          (path->string
+                           (build-path (collection-path "mzlib") 'up 'up "notes" dir "OPENBUGS")))
+                         "&caption=Open " name " bugs"
+                         "&name=" name)))
+                ,name " bugs"))))
+    
+    `(HTML
+      (HEAD ,hd-css
+            ,@hd-links
+            (TITLE "Known Bugs"))
+      (BODY
+       (H1 "Known Bugs in PLT Scheme")
+       (A ((NAME "bugs") (VALUE "Bugs")))
+       "Significant known bugs in the current release (v" ,(version) "):"
+       (UL 
+        ,@(map make-bug-link 
+               '("DrScheme" "MzScheme" "MrEd" "Stepper")))
+       (P)
+       "For an up-to-date list of bug reports, see the "
+       (A ((HREF "http://bugs.plt-scheme.org/query/")
+           (TARGET "_top")) "PLT bug report query page")) ".")))
\ No newline at end of file
diff --git a/collects/help/servlets/release/info.ss b/collects/help/servlets/release/info.ss
new file mode 100644
index 0000000000..d28b061be9
--- /dev/null
+++ b/collects/help/servlets/release/info.ss
@@ -0,0 +1,2 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Help Servlets Release"))
diff --git a/collects/help/servlets/release/license.ss b/collects/help/servlets/release/license.ss
new file mode 100644
index 0000000000..3e208a517a
--- /dev/null
+++ b/collects/help/servlets/release/license.ss
@@ -0,0 +1,93 @@
+(module license mzscheme
+  (require "../private/util.ss")
+  (require "../private/headelts.ss")
+  
+  (require (lib "servlet.ss" "web-server"))
+  (provide interface-version timeout start)
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
+  (define (make-item ss)
+    `(UL
+      (LI
+       ,@(map (lambda (s)
+                `(DIV ,s (BR)))
+              ss))))
+  
+  (define copyright-year 2005)
+  
+  (define (start initial-request)
+    (report-errors-to-browser send/finish)
+    
+    `(HTML
+      (HEAD ,hd-css
+            ,@hd-links
+            (TITLE "License"))
+      (BODY
+       (A ((NAME "lic") (VALUE "License")))
+       (B "PLT Software") (BR)
+       (B ,(format "Copyright (c) ~a PLT Scheme, Inc." copyright-year))
+       (P)
+       "PLT software is distributed under the GNU Library General Public "
+       " License (LGPL).  This means you can link PLT software (such as "
+       "MzScheme or MrEd) into proprietary applications, provided you follow "
+       "the specific rules stated in the LGPL.  You can also modify PLT "
+       "software; if you distribute a modified version, you must distribute it "
+       "under the terms of the LGPL, which in particular means that you must "
+       "release the source code for the modified software. See "
+       (A ((HREF ,(format "/servlets/doc-anchor.ss?name=COPYING.LIB&caption=Copying PLT software&file=~a"
+                          (hexify-string
+                           (path->string
+                            (simplify-path 
+                             (build-path (collection-path "mzlib") 'up 'up "notes" "COPYING.LIB")))))))
+          "COPYING.LIB")
+       " for more information."
+       (P)
+       "PLT software includes or extends the following copyrighted material:"
+       (P)
+       ,@(map make-item 
+              `(("DrScheme"
+                 "Copyright (c) 1995-2003 PLT"
+                 ,(format "Copyright (c) ~a PLT Scheme, Inc." copyright-year)
+                 "All rights reserved.")
+                ("MrEd"
+                 "Copyright (c) 1995-2003 PLT"
+		 ,(format "Copyright (c) ~a PLT Scheme, Inc." copyright-year)
+                 "All rights reserved.")
+                ("MzScheme" 
+                 "Copyright (c) 1995-2003 PLT"
+		 ,(format "Copyright (c) ~a PLT Scheme, Inc." copyright-year)
+                 "All rights reserved.")
+                ("libscheme" 
+                 "Copyright (c) 1994 Brent Benson"
+                 "All rights reserved.")
+                ("wxWindows"
+                 "Copyright (c) 1994 Artificial Intelligence Applications Institute, The University of Edinburgh"
+                 "All rights reserved.")
+                ("wxWindows Xt"
+                 "Copyright (c) 1994 Artificial Intelligence Applications Institute, The University of Edinburgh"
+                 "Copyright (c) 1995 GNU (Markus Holzem)"
+                 "All rights reserved.")
+                ("Conservative garbage collector"
+                 "Copyright (c) 1988, 1989 Hans-J. Boehm, Alan J. Demers"
+                 "Copyright (c) 1991-1996 Xerox Corporation"
+                 "Copyright (c) 1996-1999 Silicon Graphics"
+                 "Copyright (c) 1999-2001 by Hewlett-Packard Company"
+                 "All rights reserved.")
+                ("Collector C++ extension by Jesse Hull and John Ellis"
+                 "Copyright (c) 1994 Xerox Corporation"
+                 "All rights reserved.")
+                ("The A List"
+                 "Copyright (c) 1997-2000 Kyle Hammond."
+                 "All rights reserved.")
+                ("Independent JPEG Group library"
+                 "Copyright (c) 1991-1998 Thomas G. Lane."
+                 "All rights reserved.")
+                ("libpng"
+		 "Copyright (c) 2000-2002 Glenn Randers-Pehrson"
+                 "All rights reserved.")
+		("zlib"
+		 "Copyright (c) 1995-2002 Jean-loup Gailly and Mark Adler"
+		 "All rights reserved.")
+		("GNU Classpath"
+		 "Gnu Public Licence with special exception")))))))
diff --git a/collects/help/servlets/release/notes.ss b/collects/help/servlets/release/notes.ss
new file mode 100644
index 0000000000..92036a4b4e
--- /dev/null
+++ b/collects/help/servlets/release/notes.ss
@@ -0,0 +1,60 @@
+(module notes mzscheme
+  (require (lib "servlet.ss" "web-server"))
+  (require (lib "list.ss"))
+  
+  (require "../private/util.ss")
+  (require "../private/headelts.ss")
+  
+  (define (make-entry s)
+    (let* ([label (car s)]
+           [dir (cadr s)]
+           [filename (caddr s)]
+           [file (build-path (collection-path "mzlib") 'up 'up "notes" dir filename)])
+      (if (file-exists? file)
+          `(LI (A ((HREF ,(format "/servlets/doc-anchor.ss?file=~a&name=~a&caption=~a"
+                                  (hexify-string (path->string file))
+                                  filename
+                                  label)))
+                  ,label))
+          #f)))
+  
+  (require (lib "servlet.ss" "web-server"))
+  (provide interface-version timeout start)
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
+  (define (start initial-request)
+    
+    (report-errors-to-browser send/finish)
+    
+    `(HTML
+      (HEAD ,hd-css
+            ,@hd-links
+            (TITLE "PLT release notes"))
+      (H1 "Release Notes for PLT Scheme version " ,(version))
+      (A ((NAME "relnotes") (VALUE "Release notes")))
+      "Detailed release notes:"
+      (UL
+       ,@(filter 
+          (lambda (x) x) ; delete #f entries
+          (map make-entry
+               '(("DrScheme release notes"
+                  "drscheme" "HISTORY")
+                 ("Teachpack release notes"
+                  "teachpack" "HISTORY")
+                 ("MzScheme version 300 notes"
+                  "mzscheme" "MzScheme_300.txt")
+                 ("MzScheme release notes"
+                  "mzscheme" "HISTORY")
+                 ("MrEd release notes"
+                  "mred" "HISTORY")
+                 ("Stepper release notes"
+                  "stepper" "HISTORY")
+                 ("MrFlow release notes"
+                  "mrflow" "HISTORY")
+                 ("MysterX release notes"
+                  "mysterx" "HISTORY")
+                 ("MzCOM release notes"
+                  "mzcom" "HISTORY")
+                 ("SrPersist release notes"
+                  "srpersist" "HISTORY"))))))))
\ No newline at end of file
diff --git a/collects/help/servlets/release/patches.ss b/collects/help/servlets/release/patches.ss
new file mode 100644
index 0000000000..1243d66bc4
--- /dev/null
+++ b/collects/help/servlets/release/patches.ss
@@ -0,0 +1,26 @@
+(module patches mzscheme
+  (require "../private/headelts.ss"
+           "../private/util.ss")
+  
+  (require (lib "servlet.ss" "web-server"))
+  (provide interface-version timeout start)
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
+  (define (start initial-request)
+    
+    (report-errors-to-browser send/finish)
+    
+    `(HTML
+      (HEAD ,hd-css
+            ,@hd-links
+            (TITLE "Downloadable Patches"))
+      (H1 "Downloadable Patches")
+      (A ((NAME="patches") (VALUE "Downloadable patches")))
+      "The following Web page may contain downloadable patches to fix serious bugs in "
+      "version " ,(version) " of the PLT software:"
+      (P)
+      'nbsp 'nbsp
+      ,(let ([url (format "http://download.plt-scheme.org/patches/~a/" (version))])
+         `(A ((HREF ,url)
+              (TARGET "_top")) ,url)))))
\ No newline at end of file
diff --git a/collects/help/servlets/releaseinfo.ss b/collects/help/servlets/releaseinfo.ss
new file mode 100644
index 0000000000..cae805515b
--- /dev/null
+++ b/collects/help/servlets/releaseinfo.ss
@@ -0,0 +1,35 @@
+(module releaseinfo mzscheme
+  (require "private/util.ss")
+  (require "private/headelts.ss")
+  
+  (define (link-stuff url txt)
+    `(LI (B (A ((HREF ,url)) ,txt))))
+  
+  (require (lib "servlet.ss" "web-server"))
+  (provide interface-version timeout start)
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
+  (define (start initial-request)
+    (report-errors-to-browser send/finish)
+    `(HTML 
+      (HEAD ,hd-css
+            ,@hd-links
+            (TITLE "Release Information"))
+      (BODY 
+       (H1  "Release Information") 
+       (P)
+       (I "Version: " ,(plt-version))
+       (P)
+       (UL  
+        ,(link-stuff "/servlets/release/license.ss" "License")
+        ,(link-stuff "/servlets/release/notes.ss" "Release Notes")
+        ,(link-stuff "/servlets/release/bugs.ss" "Known Bugs")
+        (li (a ((mzscheme "((dynamic-require '(lib |bug-report.ss| |help|) 'help-desk:report-bug))"))
+               (b "Submit a bug report")))
+        ,(link-stuff "/servlets/release/patches.ss" "Downloadable Patches"))
+       (P)
+       "The PLT software is installed on this machine at" (BR)
+       (PRE 'nbsp nbsp
+            ,(let-values ([(base file dir?) (split-path (collection-path "mzlib"))])
+               (path->string base)))))))
\ No newline at end of file
diff --git a/collects/help/servlets/research/info.ss b/collects/help/servlets/research/info.ss
new file mode 100644
index 0000000000..d28b061be9
--- /dev/null
+++ b/collects/help/servlets/research/info.ss
@@ -0,0 +1,2 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Help Servlets Release"))
diff --git a/collects/help/servlets/research/why.ss b/collects/help/servlets/research/why.ss
new file mode 100644
index 0000000000..733a37bc66
--- /dev/null
+++ b/collects/help/servlets/research/why.ss
@@ -0,0 +1,67 @@
+(module why mzscheme
+  (require "../private/headelts.ss"
+           "../private/util.ss")
+  
+  (require (lib "servlet.ss" "web-server"))
+  (provide interface-version timeout start)
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
+  (define (start initial-request)
+    
+    (report-errors-to-browser send/finish)
+    
+    `(HTML 
+      (HEAD ,hd-css
+            ,@hd-links
+            (TITLE "Why DrScheme?"))
+      (BODY 
+       (H1 "Why DrScheme?") 
+       "Teaching introductory computing courses with Scheme, or any other "
+       "functional programming language, facilitates many conceptual tasks "
+       "and greatly enhances the appeal of computer science. Specifically, "
+       "students can implement many interesting programs with just a "
+       "small subset of the language. The execution of a functional program "
+       "can be explained with simple reduction rules that students mostly "
+       "know from secondary school.  Interactive implementations allow "
+       "for quick feedback to the programmers andmake the development of "
+       "small functions a pleasant experience." 
+       (P)
+       "Unfortunately, the poor quality of the available environments "
+       "for functional languages negates these advantages. Typical "
+       "implementations accept too many definitions, that is, definitions "
+       "that are syntactically well-formed in the sense of the full "
+       "language but meaningless for beginners. The results are "
+       "inexplicable behavior, incomprehensible run-time errors, or "
+       "confusing type error messages. The imperative nature of "
+       "read-eval-print loops often introduces subtle bugs into "
+       "otherwise perfect program developments. Scheme, in particular, "
+       "suffers from an adherence to Lisp's output traditions, which "
+       "often produces confusing effects. In many cases students, "
+       "especially those familiar with commercial C++ environments, "
+       "mistake these problems for problems with the functional "
+       "approach and reject the approach itself."
+       (P)
+       "To overcome this obstacle, we have developed a new programming "
+       "environment for Scheme. It fully integrates a (graphics-enriched) "
+       "editor, a multi-lingual parser that can process a hierarchy "
+       "of syntactically restrictive variants of Scheme, a functional "
+       "read-eval-print loop, and an algebraically sensible printer. "
+       "The environment catches the typical syntactic mistakes of "
+       "beginners and pinpoints the exact source location of run-time "
+       "exceptions. The new programming environment also provides "
+       "an algebraic stepper and a static debugger. The former reduces "
+       "Scheme programs, including programs with assignment and "
+       "control effects, to values (and effects). The static debugger "
+       "infers what set of values an expression may produce and how "
+       "values flow from expressions into variables. It exposes potential "
+       "safety violations and, upon demand from the programmer, explains "
+       "its reasoning by drawing value flowgraphs over the program text. "
+       "Preliminary experience with the environment shows that "
+       "students find it helpful and that they greatly prefer it to "
+       "shell-based or Emacs-based systems."
+       (P)
+       "A paper that discusses DrScheme in "
+       "more detail is available in the paper: " 
+       (A ((HREF "http://www.ccs.neu.edu/scheme/pubs#jfp01-fcffksf")
+           (TARGET "_top")) "DrScheme: A Programming Environment for Scheme") "."))))
\ No newline at end of file
diff --git a/collects/help/servlets/resources.ss b/collects/help/servlets/resources.ss
new file mode 100644
index 0000000000..33aee2bb67
--- /dev/null
+++ b/collects/help/servlets/resources.ss
@@ -0,0 +1,40 @@
+(module resources mzscheme
+  (require "private/headelts.ss")
+  
+  (require (lib "servlet.ss" "web-server"))
+  (provide interface-version timeout start)
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
+  (define (start initial-request)
+    
+    (report-errors-to-browser send/finish)
+    
+    `(HTML 
+      (HEAD ,hd-css
+            ,@hd-links
+            (TITLE "External Resources"))
+      (BODY 
+       (H1  "External Resources")
+       (P)
+       "DrScheme is created by "
+       (A ((HREF "http://www.plt-scheme.org/") (TARGET "_top")) "PLT") 
+       ", the Programming Languages Team "
+       "based at Northeastern University, the University of Utah, "
+       "Brown University, and the University of Chicago. "
+       "Here are some links related to our activities."
+       (P)
+       (UL  
+        (LI  (B (A ((HREF "resources/teachscheme.ss"))
+                   "TeachScheme! Workshops"))
+             ": Free summer program")
+        (LI  (B (A ((HREF "resources/libext.ss")) 
+                   "Libraries")) 
+             ": From PLT and contributors")
+        (LI  (B (A ((HREF "resources/maillist.ss")) 
+                   "Mailing Lists")) ": How to subscribe"))
+       (P)
+       "Also, the Schemers.org Web site provides links for "
+       "many Scheme resources, including books, implementations, "
+       "and libraries: " (A ((HREF "http://www.schemers.org/") 
+                             (TARGET "_top")) "http://www.schemers.org/") "."))))
\ No newline at end of file
diff --git a/collects/help/servlets/resources/info.ss b/collects/help/servlets/resources/info.ss
new file mode 100644
index 0000000000..f50b13792a
--- /dev/null
+++ b/collects/help/servlets/resources/info.ss
@@ -0,0 +1,2 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Help Servlets Resources"))
diff --git a/collects/help/servlets/resources/libext.ss b/collects/help/servlets/resources/libext.ss
new file mode 100644
index 0000000000..cba8643656
--- /dev/null
+++ b/collects/help/servlets/resources/libext.ss
@@ -0,0 +1,38 @@
+(module libext mzscheme
+  (require "../private/headelts.ss"
+           "../private/util.ss")
+  
+  (require (lib "servlet.ss" "web-server"))
+  (provide interface-version timeout start)
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
+  (define (start initial-request)
+    (report-errors-to-browser send/finish)
+    
+    `(HTML 
+      (HEAD ,hd-css
+            ,@hd-links
+            (TITLE "Libraries"))
+      (BODY 
+       (H1  "Libraries")
+       (A ((NAME "libraries") (VALUE "extensions")))  
+       (A ((NAME "mrspidey") (VALUE "mrspidey")))
+       (A ((NAME "static debugger") (VALUE "static debugger")))
+       (A ((NAME "mysterx") (VALUE "mysterx")))
+       (A ((NAME "mzcom") (VALUE "mzcom")))
+       (A ((NAME "COM") (VALUE "COM")))
+       (A ((NAME "srpersist") (VALUE "srpersist")))
+       (A ((NAME "ODBC") (VALUE "ODBC")))
+       (A ((NAME "databases") (VALUE "databases")))
+       "Many libraries and extensions are available for PLT software. "
+       "See the " 
+       (A ((HREF "http://www.cs.utah.edu/plt/develop/")
+           (TARGET "_top")) "PLT libraries and extensions")
+       " page for a comprehensive listing." 
+       (P)
+       "If you write a PLT library or extension, we would like to "
+       "hear about it!  Please send a message about it to "
+       "Matthew Flatt at " 
+       (TT "mflatt@cs.utah.edu") " so we can list it. "
+       "Thanks for your efforts!"))))
\ No newline at end of file
diff --git a/collects/help/servlets/resources/maillist.ss b/collects/help/servlets/resources/maillist.ss
new file mode 100644
index 0000000000..2fdb315986
--- /dev/null
+++ b/collects/help/servlets/resources/maillist.ss
@@ -0,0 +1,78 @@
+(module maillist mzscheme
+  (require "../private/headelts.ss")
+  
+  (require (lib "servlet.ss" "web-server"))
+  (provide interface-version timeout start)
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
+  (define (start initial-request)
+    (report-errors-to-browser send/finish)
+    
+    `(HTML 
+      (HEAD ,hd-css
+            ,@hd-links
+            (TITLE "Mailing Lists"))
+      (BODY 
+       (A ((NAME "mail") (VALUE "mailing lists")))
+       (H1  "Mailing Lists")
+       "PLT maintains two English-language mailing lists: one for announcements, "
+       "the other for discussion.  There is a discussion list in Spanish." 
+       (P)
+       (HR)
+       (P)
+       (B "Announcements List") (BR)
+       "The announcement-only list is designed for people who need to "
+       "track releases and patches.  The list is moderated. "
+       "There are a handful of postings a year."
+       (P)
+       "To subscribe to " (TT "plt-announce@list.cs.brown.edu") ", visit the "
+       "Web page "
+       (BLOCKQUOTE
+        (A ((HREF "http://list.cs.brown.edu/mailman/listinfo/plt-announce/")
+            (TARGET "_top")) "http://list.cs.brown.edu/mailman/listinfo/plt-announce/"))
+       " or send email to "
+       (BLOCKQUOTE
+        (A ((HREF "mailto:plt-announce-request@list.cs.brown.edu"))
+           "plt-announce-request@list.cs.brown.edu"))
+       " with the word `help' in the subject or body of the message. "
+       "You'll get back a message with instructions."
+       (P)
+       (HR)
+       (P)
+       (B "Discussion List") (BR)
+       "If you have problems with installation, or questions about "
+       "using PLT Scheme, send mail to the list " 
+       (BLOCKQUOTE 
+        (A ((HREF "mailto:plt-scheme@list.cs.brown.edu")) "plt-scheme@list.cs.brown.edu"))
+       (P)
+       "Only subscribers can post to the list. To subscribe, visit the Web page "
+       (BLOCKQUOTE
+        (A ((HREF "http://list.cs.brown.edu/mailman/listinfo/plt-scheme/")
+            (TARGET "_top")) "http://list.cs.brown.edu/mailman/listinfo/plt-scheme/"))
+       " or send email to "
+       (BLOCKQUOTE
+        (A ((HREF "mailto:plt-scheme-request@list.cs.brown.edu")) "plt-scheme-request@list.cs.brown.edu"))
+       " with the word `help' in the subject or body of the message. "
+       "You'll get back a message with instructions."
+       (P)
+       (HR)
+       (P)
+       (A ((NAME "mail-es") (VALUE "Spanish mailing lists")))
+       (A ((NAME "mail-es2") (VALUE "Lista de Correo")))
+       (B "Lista de Correo") (BR)
+       "Si tienes problemas con la instalación o preguntas sobre el "
+       "uso de PLT Scheme, envía un mensaje a la lista "
+       (BLOCKQUOTE 
+        (A ((HREF "mailto:plt-scheme-es@list.cs.brown.edu")) "plt-scheme-es@list.cs.brown.edu"))
+       "Para reducir la recepción de mensajes no deseados (SPAM), "
+       "hemos adoptado la política de que sólo los suscriptores a la lista "
+       "pueden enviar mensajes. Para suscribirte, visita la página de Web "
+       (BLOCKQUOTE
+        (A ((HREF "http://list.cs.brown.edu/mailman/listinfo/plt-scheme-es/")
+            (TARGET "_top")) "http://list.cs.brown.edu/mailman/listinfo/plt-scheme-es/"))
+       " o envía un mensaje a "
+       (BLOCKQUOTE
+        (A ((HREF "mailto:plt-scheme-es-request@list.cs.brown.edu")) "plt-scheme-es-request@list.cs.brown.edu"))
+       " con la palabra `help' en el asunto o en el cuerpo de tu mensaje. "
+       "Recibirás un mensaje de regreso con instrucciones."))))
diff --git a/collects/help/servlets/resources/teachscheme.ss b/collects/help/servlets/resources/teachscheme.ss
new file mode 100644
index 0000000000..74617bd164
--- /dev/null
+++ b/collects/help/servlets/resources/teachscheme.ss
@@ -0,0 +1,36 @@
+(module teachscheme mzscheme
+  (require "../private/headelts.ss")
+  
+  (require (lib "servlet.ss" "web-server"))
+  (provide interface-version timeout start)
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
+  (define (start initial-request)
+    
+    (report-errors-to-browser send/finish)
+    
+    `(HTML 
+      (HEAD ,hd-css
+            ,@hd-links
+            (TITLE "TeachScheme! Workshops"))
+      (BODY 
+       (H1  "TeachScheme! Workshops")	
+       (A ((NAME "workshops") (VALUE "TeachScheme! workshops")))
+       "TeachScheme! is a free summer workshop for high school teachers. "
+       "Its goal is to bridge the gulf between high school and "
+       "college-level computing curricula.  In the workshop, programming "
+       "is taught as an algebraic problem-solving process, and computing "
+       "is the natural generalization of grade-school level calculating." 
+       (P)
+       "Students who learn to design programs properly learn to "
+       "analyze a problem statement; express its essence, abstractly "
+       "and with examples; formulate statements and comments in a "
+       "precise language; evaluate and revise these activities in "
+       "light of checks and tests; and pay attention to details. "
+       "As a result, all students benefit, those who wish to study computing "
+       "as well as those who just wish to explore the subject."
+       (P)
+       "For more information, see the " 
+       (A ((HREF "http://www.teach-scheme.org/Workshops/")
+           (TARGET "_top")) "TeachScheme! Workshops page") "."))))
\ No newline at end of file
diff --git a/collects/help/servlets/results.ss b/collects/help/servlets/results.ss
new file mode 100644
index 0000000000..1e301e57a3
--- /dev/null
+++ b/collects/help/servlets/results.ss
@@ -0,0 +1,340 @@
+#|
+
+Since the web server is set up to have a separate namespace for each
+servlet, this servlet must be able to both use and flush the documentation
+index cache. Flushing the cache elsewhere will not dump it, since the cache
+is stored in a module top-level and that's namespace-specific.
+
+|#
+
+(module results mzscheme
+  (require (lib "file.ss")
+           (lib "list.ss")
+           (lib "string.ss")
+           (lib "servlet.ss" "web-server")
+           "../private/internal-hp.ss"
+           "../private/path.ss"
+           "../private/docpos.ss"
+           "../private/search.ss"
+           "../private/manuals.ss"
+           "../private/get-help-url.ss"
+           (lib "string-constant.ss" "string-constants"))
+  
+  (require "private/util.ss")
+  (require "private/search-util.ss")
+  (require "private/headelts.ss")
+  
+  (require (lib "servlet.ss" "web-server"))
+  (provide interface-version timeout start)
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
+  (define (start initial-request)
+    (report-errors-to-browser send/finish)
+    (let ()
+      ; doc subcollection name -> boolean
+      
+      (define (search-type->search-level st)
+        (let loop ([n 0]
+                   [lst (map car search-types)])
+          (when (null? lst)
+	    (raise 'bad-search-type))
+          (if (string=? (car lst) st)
+              n
+              (loop (add1 n) (cdr lst)))))
+      
+      (define search-responses #f)
+
+      ;; from what I can tell, this variable doesn't work as intended.
+      ;; I've left it in for now, but this whole file needs to be rewritten.
+      ;; -robby
+      (define current-kind #f)
+
+      (define last-header #f)
+      
+      (define max-reached #f)
+      (define (build-maxxed-out k)
+        (lambda ()
+          (unless max-reached
+            (set! max-reached #t)	    
+            (set! search-responses
+                  (cons `(B ,(color-with 
+                              "red"
+                              (string-constant plt:hd:search-stopped-too-many-matches)))
+                        search-responses)))
+          (k #f)))
+      
+      (define (add-header s key)
+        (unless max-reached
+          (set! last-header s)
+          (set! search-responses
+                (cons `(B ((STYLE "font-family:Verdana,Helvetica,sans-serif")) 
+                          ,s)
+                      (cons `(BR)
+                            search-responses)))))
+      
+      (define (set-current-kind! s key)
+        (set! current-kind
+              (cadr (assoc s kind-types))))
+      
+      (define exp-web-root
+        (explode-path 
+         (normalize-path 
+          (build-path (collection-path "mzlib") 'up))))
+      (define web-root-len (length exp-web-root))
+        
+      (define (keyword-string? ekey)
+        (and (string? ekey)
+             (not (string=? ekey ""))))
+      
+      (define (pretty-label label ekey) 
+        (if (keyword-string? ekey)
+            `(FONT 
+              ((FACE "monospace"))
+              ; boldface keyword occurrences
+              ,@(let ([mpos (regexp-match-positions (non-regexp ekey) label)])
+                  (if mpos
+                      (let* ([item (car mpos)]
+                             [start (car item)]
+                             [stop (cdr item)])
+                        (list
+                         (substring label 0 start)
+                         `(B ,(substring label start stop))
+                         (substring label stop
+                                    (string-length label))))
+                      (list label))))
+            label))
+      
+      (define (maybe-extract-coll s)
+        (let ([len (string-length s)])
+          (if (and (> len 17)
+                   (string=? (substring s 0 4) "the ")
+                   (string=? (substring s (- len 11) len)
+                             " collection"))
+              (substring s 4 (- len 11))
+              s)))
+      
+      (define no-anchor-format 
+        (string-append
+         "/servlets/doc-anchor.ss?"
+         "file=~a&"
+         "caption=~a&"
+         "name=~a"))
+      
+      (define with-anchor-format 
+        (string-append no-anchor-format "&offset=~a#temp"))
+      
+      (define (make-caption coll)
+        (format "Documentation for the ~a collection" coll))
+      
+      (define (make-search-link href label src ekey)
+        `(TABLE ((CELLSPACING "0")
+                 (CELLPADDING "0"))
+                (TR 
+                 (TD
+		  (DIV ((ALIGN "left-outdent"))
+		       (A ((HREF ,href)) ,(pretty-label label ekey))
+		       " in "
+		       "\"" ,src "\"")))))
+      
+      ;; doc-txt? : string -> boolean
+      (define (doc-txt? str) (regexp-match "doc\\.txt$" str))
+      
+      (define (make-html-href page-label path)
+        (let ([anchored-path (make-anchored-path page-label path)])
+          (cond
+            [(servlet-path? path) 
+             anchored-path]
+            [(doc-txt? (path->string path)) ; collection doc.txt
+             (let ([maybe-coll (maybe-extract-coll last-header)])
+               (format 
+                no-anchor-format
+                (hexify-string anchored-path)
+                (hexify-string (make-caption maybe-coll))
+                maybe-coll))]
+            [else ; manual, so have absolute path
+             (get-help-url path page-label)])))
+      
+      ;; make-anchored-path : string path -> string
+      ; page-label is #f or a bytes that labels an HTML anchor
+      ; path is either an absolute pathname (possibly not normalized) 
+      ; in the format of the native OS, or, in the case of Help Desk 
+      ; servlets, a forward-slashified path beginning with "/servlets/"
+      (define (make-anchored-path page-label path)
+        (let ([normal-path 
+               (if (servlet-path? path) 
+                   path
+                   (normalize-path path))])
+          (if (and page-label
+                   (string? page-label)
+                   (not (or (string=? page-label "NO TAG") 
+                            (regexp-match "\\?|&" page-label))))
+              (string-append (path->string normal-path) "#" page-label)
+              (path->string normal-path))))
+      
+
+      
+      ; path is absolute pathname
+      (define (make-text-href page-label path)
+        (let* ([maybe-coll (maybe-extract-coll last-header)]
+               [hex-path (hexify-string (path->string (normalize-path path)))]
+               [hex-caption (if (eq? maybe-coll last-header)
+                                hex-path
+                                (hexify-string (make-caption maybe-coll)))]
+               [offset (or (and (number? page-label)
+                                page-label)
+                           0)])
+          (format 
+           with-anchor-format
+           hex-path
+           hex-caption
+           (hexify-string maybe-coll)
+           offset)))
+      
+      (define (html-entry? path)
+        (and (not (suffixed? path #"doc.txt"))
+             (or (eq? current-kind 'html)
+                 (suffixed? path #".html"))))
+      
+      (define (suffixed? path suffix)
+        (let* ([path-bytes (path->bytes path)]
+               [path-len (bytes-length path-bytes)]
+               [suffix-len (bytes-length suffix)])
+          (and (path-len . >= . suffix-len)
+               (bytes=? (subbytes path-bytes
+                                  (- path-len suffix-len)
+                                  path-len)
+                        suffix))))
+      
+      (define (goto-lucky-entry ekey label src path page-label key)
+        (let* ([href (if (html-entry? path)
+                         (make-html-href page-label path)
+                         (make-text-href page-label path))])
+          (send/finish
+           (redirect-to href))))
+      
+      (define (add-entry ekey label src path page-label key)
+        (let* ([entry (if (html-entry? path)
+                          (make-search-link 
+                           (make-html-href page-label path)
+                           label src ekey)
+                          (make-search-link 
+                           (make-text-href page-label path)
+                           label src ekey))])
+          (set! search-responses
+                (cons entry search-responses))))
+      
+      (define (make-results-page search-string lang-name items regexp? exact?)
+        (let-values ([(string-finds finds) (build-string-finds/finds search-string regexp? exact?)])
+          `(HTML
+            (HEAD ,hd-css
+                  ,@hd-links
+                  (TITLE "PLT Help Desk search results"))
+            (BODY
+             (h1 "Search Results")
+             (h2
+              ,@(if lang-name
+                    (list "Language: " (color-with "firebrick" lang-name) '(br))
+                    '())
+              ,@(let ([single-key
+                       (lambda (sf)
+                         (color-with "firebrick" (format " \"~a\"" sf)))])
+                  (cond
+                    [(null? string-finds) '()]
+                    [(null? (cdr string-finds))
+                     (list "Key: " (single-key (car string-finds)))]
+                    [else 
+                     (cons "Keys: " (map single-key string-finds))])))
+             (BR)
+             ,@items))))
+      
+      (define (search-results lucky? search-string search-type match-type manuals doc-txt? lang-name)
+        (set! search-responses '())
+        (set! max-reached #f)
+        (let* ([search-level (search-type->search-level search-type)]
+               [regexp? (string=? match-type "regexp-match")]
+               [exact-match? (string=? match-type "exact-match")]
+               [key (gensym)]
+               [result (let/ec k
+                         (do-search search-string 
+                                    search-level
+                                    regexp?
+                                    exact-match?
+                                    manuals
+                                    doc-txt?
+                                    key
+                                    (build-maxxed-out k)
+                                    add-header
+                                    set-current-kind!
+                                    (if lucky? goto-lucky-entry add-entry)))]
+               [html (make-results-page
+                      search-string
+                      lang-name
+                      (if (string? result) ; error message
+                          `((H2 ((STYLE "color:red")) ,result))
+                          (reverse search-responses))
+                      regexp? 
+                      exact-match?)])
+          html))
+      
+      (define empty-search-page
+        `(HTML
+          (HEAD
+           (TITLE "Empty search string in PLT Help Desk"))
+          (BODY
+           (H2 "Empty search string"))))
+      
+      (define (lucky-search? bindings)
+        (with-handlers ([exn:fail? (lambda _ #f)])
+          (let ([result (extract-binding/single 'lucky bindings)])
+            (not (string=? result "false")))))
+      
+      (define (maybe-update-box b s)
+        (unless (string=? s "")
+          (set-box! b s)))
+      
+      (define (convert-manuals manuals)
+        (cond
+          [manuals
+           (let ([parsed (read-from-string manuals)])
+             (cond
+               [(and (list? parsed)
+                     (andmap symbol? parsed))
+                (map symbol->string parsed)]
+               [else (map car (find-doc-names))]))]
+          [else (map car (find-doc-names))]))
+      
+      (let* ([bindings (request-bindings initial-request)]
+             [maybe-get (lambda (sym)
+                          (with-handlers ([exn:fail? 
+                                           (lambda (_) #f)])
+                            (extract-binding/single sym bindings)))]
+             [flush (maybe-get 'flush)])
+        (cond
+          [flush 
+           (doc-collections-changed)
+           `(html (head (title "Flush"))
+                  (body (h2 "Flushed documentation cache")))]
+          [else
+           (let ([search-string (maybe-get 'search-string)]
+                 [search-type (maybe-get 'search-type)]
+                 [match-type (maybe-get 'match-type)]
+                 [manuals (maybe-get 'manuals)]
+                 [doc.txt (maybe-get 'doctxt)]
+                 [lang-name (maybe-get 'langname)])
+             (cond
+               [(or (not search-string) (= (string-length search-string) 0))
+                empty-search-page]
+               [else
+                (search-results
+                 (lucky-search? bindings)
+                 search-string
+                 (or search-type "keyword-index")
+                 (or match-type "containing-match")
+                 (convert-manuals manuals)
+                 (cond
+                   [(not doc.txt) #t]
+                   [(equal? doc.txt "false") #f]
+                   [else #t])
+                 lang-name)]))])))))
+
diff --git a/collects/help/servlets/scheme/doc.ss b/collects/help/servlets/scheme/doc.ss
new file mode 100644
index 0000000000..5848a2bcbf
--- /dev/null
+++ b/collects/help/servlets/scheme/doc.ss
@@ -0,0 +1,56 @@
+(module doc mzscheme
+  (require "../private/headelts.ss"
+           "../private/util.ss")
+  
+  (require (lib "servlet.ss" "web-server"))
+  (provide interface-version timeout start)
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
+  (define (start initial-request)
+    
+    (define (make-header-text s)
+      (color-highlight `(H2 () ,s)))
+    
+    (report-errors-to-browser send/finish)
+    
+    `(HTML 
+      (HEAD ,hd-css
+            ,@hd-links
+            (TITLE "Documentation"))
+      (BODY 
+       (H1  "Documentation")
+       (A ((NAME "docs") (VALUE "Documentation")))
+       ,(make-header-text "How to use DrScheme")
+       (A ((HREF "/servlets/howtodrscheme.ss")) "DrScheme") 
+       " provides information about using the DrScheme development "
+       "environment." 
+       ,(make-header-text "Languages and Libraries") 
+       "Language and library documentation is distributed among "
+       "several manuals, plus a number of plain-text files "
+       "describing small library collections." 
+       (P)
+       "When you " (A ((HREF "/servlets/howtouse.ss#search")) "search")
+       ", Help Desk groups the results by manual and collection. "
+       "The manuals are ordered from the most-used documentation "
+       "(e.g., R5RS Scheme) to the least-used (e.g., MzScheme "
+       "internals), and all manuals precede library collections." 
+       (P)
+       "The PLT distribution archive includes a partial set of "
+       "documentation.  A hyperlink in this partial set may refer "
+       "to a manual that is missing from the distribution. "
+       "If you follow such a link, Help Desk provides a special "
+       "page for automatically downloading and installing the "
+       "missing manual. For certain manuals, the PLT distribution "
+       "includes a searchable index file rather than the whole "
+       "manual, so a search result link might refer to a "
+       "missing manual." 
+       (UL  (LI  (B (A ((href "/servlets/manuals.ss")) 
+                       "Manuals")) 
+                 ": List the currently installed and uninstalled manuals"))
+       ,(make-header-text "Searching")
+       (A ((HREF "/servlets/howtouse.ss#search")) "Searching") 
+       " in Help Desk finds documenation from all sources, "
+       "including " 
+       (A ((HREF "/servlets/howtodrscheme.ss")) "DrScheme") 
+       " and the language and library documentation."))))
\ No newline at end of file
diff --git a/collects/help/servlets/scheme/how.ss b/collects/help/servlets/scheme/how.ss
new file mode 100644
index 0000000000..9e9fe97943
--- /dev/null
+++ b/collects/help/servlets/scheme/how.ss
@@ -0,0 +1,125 @@
+(module how mzscheme
+  (require (lib "launcher.ss" "launcher")
+           "../private/util.ss"
+           "../../private/manuals.ss"
+           "../private/headelts.ss"
+           "../../private/installed-components.ss"
+           (lib "servlet.ss" "web-server"))
+  
+  (provide interface-version timeout start)
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
+  (define (start initial-request)
+    (define stupid-internal-define-syntax (report-errors-to-browser send/finish))
+    
+    (define soft-page
+      `(HTML 
+        (HEAD ,hd-css
+              ,@hd-links 
+              (TITLE "Software & Components"))
+        (BODY 
+         (H1  "Software & Components")
+         ,(color-highlight `(H2  "DrScheme"))
+         (A ((NAME "dr2") (VALUE "DrScheme programming environment")))
+         (A ((NAME "dr3") (VALUE "Running Scheme")))
+         (B  "DrScheme") 
+         " is a user-friendly environment for creating and running "
+         "Scheme programs." 
+         (P)
+         "DrScheme's default " 
+         (A ((HREF "/servlets/scheme/what.ss")) "language")
+         " is Beginning Student. To change the language, select "
+         "the " (B  (TT  "Choose Language...")) " item in the " 
+         (B  (TT  "Language")) " menu."
+         (P)
+         "On this machine, the DrScheme program is " 
+         (TT  ,(path->string (mred-program-launcher-path "DrScheme"))) "."
+         (P)
+         "For more information, see " 
+         (A ((HREF "/servlets/howtodrscheme.ss")) "DrScheme") "."
+         (P)
+         ,(color-highlight `(H2  "MzScheme and MrEd"))
+         (A ((NAME "mz") (VALUE "MzScheme interpreter")))
+         (A ((NAME "mr") (VALUE "MrEd interpreter")))
+         "The " (B  "MzScheme") 
+         " and " (B  "MrEd") " executables run programs written "
+         "in the MzScheme and MrEd variants, respectively, of the "
+         "PLT Scheme " (A ((HREF "/servlets/scheme/what.ss")) "language")
+         "." 
+         (P)
+         "Create a MzScheme or MrEd program using the DrScheme "
+         "development environment. Then, use the MzScheme or MrEd "
+         "executable to run the program in its deployed setting."
+         (P)
+         "On this machine, the MzScheme program is at " 
+         (TT  ,(path->string (mzscheme-program-launcher-path "MzScheme"))) ", and "
+         "MrEd is at " 
+         (TT  ,(path->string (mred-program-launcher-path "MrEd"))) "."
+         (P)
+         "For more information, see " 
+         ,(main-manual-page "mzscheme")
+         " and " 
+         ,(main-manual-page "mred")
+         (P)
+         ,(color-highlight `(H2  "mzc"))
+         (A ((NAME "mzc2") (VALUE "mzc compiler")))
+         (A ((NAME "mzc3") (VALUE "Compiling")))
+         "The " (B  "mzc") " executable compiles MzScheme and "
+         "MrEd programs to native code using a C compiler "
+         "(which your system must provide).  The resulting native "
+         "code can be loaded into MrEd or MzScheme.  The mzc "
+         "compiler also provides limited support for building "
+         "stand-alone executables from Scheme code." 
+         (P)
+         "On this machine, the mzc program is at " 
+         (TT  ,(path->string (mzscheme-program-launcher-path "mzc"))) "."
+         (P)
+         "For more information, see " 
+         ,(main-manual-page "mzc") ". "
+         (P)
+         (A ((NAME "help") (VALUE "help-desk")))
+         ,(color-highlight `(H2  "Help Desk"))
+         "Help Desk provides information about PLT Software in a "
+         "user-friendly, searchable environment. "
+         "Help Desk can run by itself, or within DrScheme "
+         "(via the " 
+         (B  (TT  "Help")) " menu)."  
+         "You are currently reading this text in Help Desk."
+         (P)
+         "On this machine, the Help Desk program is at " 
+         (TT  ,(path->string (mred-program-launcher-path "Help Desk"))) "."
+         (P)
+         (A ((NAME "setup-plt"))) 
+         ,(color-highlight `(H2  "Setup PLT"))
+         (A ((NAME "setup") (VALUE "Setup PLT program")))
+         (A ((NAME "setup2") (VALUE "setup-plt program")))
+         (A ((HREF ,(format "/servlets/doc-anchor.ss?file=~a&name=~a&caption=~a"
+                            (hexify-string
+                             (path->string
+                              (simplify-path
+                               (build-path (collection-path "mzlib") 'up "setup" "doc.txt"))))
+                            "Setup PLT"
+                            "Document for the setup collection")))
+            "Setup PLT")
+         " performs certain installation duties, such as compiling "
+         "DrScheme's source code to make DrScheme start faster." 
+         (P)
+         "Setup PLT also unpacks and installs downloadable " 
+         (TT  ".plt") " distributions, such as the MrFlow "
+         "distribution archive. However, Help Desk automatically "
+         "runs Setup PLT when you use it to download a " 
+         (tt  ".plt") " file."
+         (P)
+         "On this machine, the Setup PLT program is at " 
+         (TT  ,(path->string (mzscheme-program-launcher-path "Setup PLT"))) "."
+         (P)
+         (A ((NAME "installed-components") (VALUE "Installed Components")))
+         ,(color-highlight `(H2  "Additional Installed Components"))
+         (A ((NAME "installed-components")))
+         (I  
+          "The list below was generated by searching the set "
+          "of installed libraries.")
+         (UL ,@(help-desk:installed-components)))))
+    
+    (send/finish soft-page)))
\ No newline at end of file
diff --git a/collects/help/servlets/scheme/info.ss b/collects/help/servlets/scheme/info.ss
new file mode 100644
index 0000000000..efb896f554
--- /dev/null
+++ b/collects/help/servlets/scheme/info.ss
@@ -0,0 +1,2 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Help Servlets Scheme"))
diff --git a/collects/help/servlets/scheme/langlevels.ss b/collects/help/servlets/scheme/langlevels.ss
new file mode 100644
index 0000000000..a029967dfe
--- /dev/null
+++ b/collects/help/servlets/scheme/langlevels.ss
@@ -0,0 +1,67 @@
+(module langlevels mzscheme
+  (require "../private/headelts.ss")
+  (require "../../private/manuals.ss")
+  
+  (require (lib "servlet.ss" "web-server"))
+  (provide interface-version timeout start)
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
+  (define (start initial-request)
+    
+    (report-errors-to-browser send/finish)
+    
+    `(HTML 
+      (HEAD ,hd-css
+            ,@hd-links
+            (TITLE "A Note on Language Levels") )
+      (BODY 
+       (H1  "A Note on Language Levels") 
+       (A ((NAME "language levels") (VALUE "language levels")))
+       (P)
+       "DrScheme presents Scheme via a hierarchy of " 
+       ,(manual-entry "drscheme" "languages" "language levels")
+       "."
+       (P)
+       "We designed the teaching languages based upon our observations of " 
+       "students in classes and labs over several years. Beginning students "
+       "tend to make small notational mistakes that produce " 
+       (em  "syntactically legal") " Scheme programs with a " 
+       (em "radically different meaning") " than the one intended. "
+       "Even the best students are then surprised by error messages, "
+       "which might mention concepts not covered in classes, or other "
+       "unexpected behavior."
+       (P)
+       "The teaching levels are not ideal for instructors. "
+       "They are particularly unhelpful for implementing libraries "
+       "to support course material.  But the levels were not designed "
+       "for this purpose. Instead, in order to protect students from "
+       "unwanted mistakes and to provide them with libraries based "
+       "on language constructs outside of their knowledge, DrScheme "
+       "provides an interface designed specially for instructors: " 
+       ,(manual-entry "drscheme" "DrScheme Teachpacks" "Teachpacks") ". "
+       "A Teachpack is a " 
+       ,(manual-entry "mzscheme" "modules" "module")
+       " that is implemented in Full Scheme; it imports the functions "
+       "from the teaching languages and the graphics run-time library. "
+       "The provided values are automatically imported to the run-time "
+       "of the read-eval-print loop when the student clicks the " 
+       ,(manual-entry "drscheme" "Execute button" "Execute") ". "
+       "In short, Teachpacks provide students the best of both worlds: "
+       "protection from wanton error messages and unexpected behavior, "
+       "and powerful support from the instructor."
+       (P)
+       "We strongly encourage instructors to employ language levels and "
+       "Teachpacks. In our experience, the restriction of the teaching "
+       "languages do not interfere with students' programming needs up to, "
+       "and including, junior-level courses on programming languages. "
+       "It gives students a more productive learning experience than "
+       "raw Scheme, and simplifies the interface between library and "
+       "user code."
+       (P)
+       "We also strongly encourage students to point out this page to "
+       "their instructors."
+       (P)
+       "Please follow the links on this page for more information.  "
+       "If you have additional questions or comments, please contact "
+       "us at " (A ((HREF "mailto:scheme@plt-scheme.org")) "scheme@plt-scheme.org") "."))))
\ No newline at end of file
diff --git a/collects/help/servlets/scheme/misc.ss b/collects/help/servlets/scheme/misc.ss
new file mode 100644
index 0000000000..ba2107382d
--- /dev/null
+++ b/collects/help/servlets/scheme/misc.ss
@@ -0,0 +1,60 @@
+(module misc mzscheme
+  (require (lib "servlet.ss" "web-server"))
+  (require "../private/headelts.ss"
+           "../private/util.ss")
+  
+  ; (listof string string) -> xexpr
+  (define (make-link-line url/txt)
+    (let ([url (car url/txt)]
+          [txt (cadr url/txt)])
+      `(LI () (B () (A ((HREF ,(string-append
+                                "/servlets/scheme/misc/"
+				url))) ,txt)))))
+  
+  (define links
+    '(("standalone.ss" 
+       "How to build a stand-alone executable")
+      ("graphics.ss" 
+       "How to write graphics programs")
+      ("script.ss"
+       "How to write Unix shell scripts")
+      ("batch.ss" 
+       "How to write Windows batch files")
+      ("cgi.ss" 
+       "How to write CGI scripts")
+      ("activex.ss" 
+       "How to use ActiveX components")
+      ("database.ss"
+       "How to connect to databases")
+      ("system.ss" 
+       "How to call low-level system routines")))
+  
+  (require (lib "servlet.ss" "web-server"))
+  (provide interface-version timeout start)
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
+  (define (start initial-request)
+    
+    (report-errors-to-browser send/finish)
+    
+    `(HTML 
+      (HEAD ,hd-css
+            ,@hd-links
+            (TITLE "How to do things in Scheme"))  
+      (BODY 
+       (H1 "How to do things in Scheme") 
+       (UL 
+        ,@(map make-link-line links))
+       (P)
+       
+       "If you did't find what you're looking for in the "
+       "list above, try")
+      " "
+      (A ((HREF "/servlets/howtouse.ss#search")) "searching")
+      " "
+      "in Help Desk. "
+      
+      "Also, check "
+      (a ((href "http://www.htus.org/")) (i "How to Use Scheme"))
+      ".")))
\ No newline at end of file
diff --git a/collects/help/servlets/scheme/misc/activex.ss b/collects/help/servlets/scheme/misc/activex.ss
new file mode 100644
index 0000000000..9404deaa69
--- /dev/null
+++ b/collects/help/servlets/scheme/misc/activex.ss
@@ -0,0 +1,29 @@
+(module activex mzscheme
+  (require "../../private/util.ss")
+  (require "../../private/headelts.ss")
+  
+  (require (lib "servlet.ss" "web-server"))
+  (provide interface-version timeout start)
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
+  (define (start initial-request)
+    (report-errors-to-browser send/finish)
+    
+    `(HTML 
+      (HEAD ,hd-css
+            ,@hd-links
+            (TITLE "How to use ActiveX components"))
+      (BODY 
+       (H1  "How to use ActiveX components")
+       (A ((NAME "com") (VALUE "COM")))
+       (A ((NAME "activex") (VALUE "ActiveX")))
+       "If you run Windows, you can use MysterX, a library for "
+       "controlling COM and ActiveX components within DrScheme, "
+       "MzScheme, or MrEd.  MysterX is available from "
+       (PRE 
+        'nbsp 'nbsp  (A ((HREF "http://www.plt-scheme.org/software/mysterx/")
+                         (TARGET "_top")) "http://www.plt-scheme.org/software/mysterx/"))
+       (P)
+       ,(collection-doc-link "mysterx"
+                             "The MysterX collection")))))
\ No newline at end of file
diff --git a/collects/help/servlets/scheme/misc/batch.ss b/collects/help/servlets/scheme/misc/batch.ss
new file mode 100644
index 0000000000..a4a8a3dc37
--- /dev/null
+++ b/collects/help/servlets/scheme/misc/batch.ss
@@ -0,0 +1,52 @@
+(module batch mzscheme
+  (require "../../private/headelts.ss"
+           "../../private/util.ss")
+  
+  (require (lib "servlet.ss" "web-server"))
+  (provide interface-version timeout start)
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
+  (define (start initial-request)
+    
+    (report-errors-to-browser send/finish)
+    
+    `(HTML 
+      (HEAD ,hd-css
+            ,@hd-links
+            (TITLE  "How to write Windows batch files"))
+      (BODY 
+       (H1  "How to write Windows batch files")
+       (A ((NAME "sh") (VALUE "Batch files")))
+       (A ((NAME "sh2") (VALUE ".bat files")))
+       "You can put MzScheme code in a Windows batch file, that is, a "
+       "file with a .BAT extension.  Batch files can be executed "
+       "directly from the command line.  In Windows 95, 98, and Me, "
+       "the batch file looks like:"
+       (PRE 
+        " ; @echo off" (BR)
+        " ; d:\\plt\\mzscheme -r %0 %1 %2 %3 %4 %5 %6 %7 %8 %9" (BR)
+        " ; goto :end" (BR)
+        "   ... " (I  "scheme-program") " ..." (BR)
+        " ; :end")
+       "With this code, your batch file can use as many as nine "
+       "parameters."
+       (P)
+       "In Windows NT, Windows 2000, and Windows XP, you can instead write "
+       (PRE 
+        " ; @echo off" (BR)
+        " ; d:\\plt\\mzscheme -r %0 %*" (BR)
+        " ; goto :end" (BR)
+        "   ... " (I  "scheme-program") " ..." (BR)
+        " ; :end")
+       "This code allows an arbitrary number of parameters to your " 
+       "batch file."
+       (P)
+       "The batch file code works by combining both batch and MzScheme "
+       "syntax in a single file.  When invoked from the command line, "
+       "the semicolons are ignored.  The second line invokes MzScheme "
+       "with the batch file as an argument.  MzScheme interprets the "
+       "lines beginning with semicolons as comments, and runs the "
+       "Scheme code.  When the Scheme program is "
+       "done, control returns to the batch file, and the "
+       (TT  "goto") " jumps around the Scheme code."))))
\ No newline at end of file
diff --git a/collects/help/servlets/scheme/misc/cgi.ss b/collects/help/servlets/scheme/misc/cgi.ss
new file mode 100644
index 0000000000..eb6417f2b0
--- /dev/null
+++ b/collects/help/servlets/scheme/misc/cgi.ss
@@ -0,0 +1,153 @@
+(module cgi mzscheme
+  (require "../../private/headelts.ss")
+  
+  (require (lib "servlet.ss" "web-server"))
+  (provide interface-version timeout start)
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
+  (define (start initial-request)
+    
+    (report-errors-to-browser send/finish)
+    
+    `(HTML 
+      (HEAD ,hd-css
+            ,@hd-links
+            (TITLE  "How to write CGI scripts"))
+      (BODY 
+       (H1  "How to write CGI scripts")
+       (A ((NAME "cgi") (VALUE "CGI scripts")))
+       "Type " (TT  "CGI") " in the " (B  "Search for") " "
+       "field in Help Desk and click on the "
+       (B  (TT  "Search")) " button to get information "
+       "on CGI-related functions."
+       (P)
+       "A CGI script is merely a program with funny inputs and "
+       "outputs.  Input comes either from an environment variable "
+       "or through the standard input port, in a special format. "
+       "Output consists of a MIME header followed by the content.  "
+       "Everything in-between is pure program."
+       (P)
+       "MzScheme comes with a CGI library that is designed to "
+       "make it easy to write such scripts.  In the mini-tutorial "
+       "below, we'll walk you through the "
+       "construction of such a script.  If you have questions or "
+       "comments, send email to "
+       (A ((HREF "mailto:sk@plt-scheme.org"))
+          "sk@plt-scheme.org") "."
+          (P)
+          (HR)
+          (P)
+          "Let's write a simple \"finger server\" in MzScheme. "
+          "The front-end will be a Web form that accepts a username. "
+          "The form should supply a username in the field `name'. "
+          "The CGI script fingers that user."
+          (P)
+          "First, make sure you have MzScheme installed on the host "
+          "where your Web server is located."
+          (P)
+          "A CGI script must be an executable.  Each OS has different "
+          "ways of launching an application.  Under Unix, it's "
+          "probably easiest to make them simple shell scripts.  "
+          "Therefore, place the following magic incantation at the "
+          "top of your script:"
+          (P)
+          (PRE 
+           " #!/bin/sh" (BR)
+           " string=? ; exec /usr/local/bin/mzscheme -r $0 \"$@\"")
+          (P)
+          "Make sure the path to MzScheme is specified correctly."
+          (P)
+          "Now we're in Scheme-land.  First, let's load the Scheme "
+          "CGI library and define where `finger' resides."
+          (P)
+          (PRE 
+           " (require (lib \"cgi.ss\" \"net\"))" (BR)
+           " (define finger-program \"/usr/bin/finger\")")
+          (P)
+          "Next we must get the names bound by the form, and "
+          "extract the username field."
+          (P)
+          (PRE 
+           " (let ((bindings (get-bindings)))" (BR)
+           "   (let ((name (extract-binding/single 'name bindings)))")
+          (P)
+          "We use extract-binding/single to make sure only one name "
+          "field was bound.  (You can bind the same field multiple "
+          "times using check-boxes.  This is just one kind of "
+          "error-checking; a robust CGI script will do more."
+          (P)
+          "Next we invoke the finger program using `process*'.  "
+          "If no username was specified, we just run finger on the host."
+          (P)
+          (PRE 
+           " (let ((results (if (string=? name \"\"))" (BR)
+           "   (process* finger-program)" (BR)
+           "   (process* finger-program name))))")
+          (P)
+          "The `process*' function returns a list of several values. "
+          "The first of these is the output port.  Let's pull this "
+          "out and name it."
+          (P)
+          (PRE 
+           " (let ((proc->self (car results)))")
+          (P)
+          "Now we extract the output of running finger into a "
+          "list of strings."
+          (P)
+          (PRE 
+           " (let ((strings (let loop " (BR)
+           "   (let ((l (read-line proc->self)))" (BR)
+           "     (if (eof-object? l)" (BR)
+           "        null" (BR)
+           "        (cons l (loop))))))))")
+          (P)
+          "All that's left is to print this out to the user.  "
+          "We use the `generate-html-output' procedure to do that, "
+          "which takes care of generating the appropriate MIME header "
+          "(as required of CGI scripts). "
+          "Note that the <PRE> tag of HTML doesn't prevent its "
+          "contents from being processed.  To avoid this "
+          "(i.e., to generate truly verbatim output), "
+          "we use `string->html', which knows about HTML quoting "
+          "conventions."
+          (P)
+          (PRE 
+           " (generate-html-output \"Finger Gateway Output\"" (BR)
+           "   (append " (BR)
+           "    '(\"<PRE>\")" (BR)
+           "    (map string->html strings)" (BR)
+           "    '(\"</PRE>\"))))))))")
+          (P)
+          "That's all!  This program will work irrespective of "
+          "whether the form uses a GET or POST method to send its "
+          "data over, which gives designers additional flexibility "
+          "(GET provides a weak form of persistence, while "
+          "POST is more robust and better suited to large volumes of "
+          "data)."
+          (P)
+          "Here's the entire program, once again:"
+          (P)
+          (PRE 
+           " #!/bin/sh" (BR)
+           " string=? ; exec /usr/local/bin/mzscheme -r $0 "$@"" (BR)
+           "" (BR)
+           " (require (lib \"cgi.ss\" \"net\"))" (BR)
+           " (define finger-program \"/usr/bin/finger\")" (BR)
+           ""  (BR)
+           " (let ((bindings (get-bindings)))" (BR)
+           "   (let ((name (extract-binding/single 'name bindings)))" (BR)
+           "    (let ((results (if (string=? name "")" (BR)
+           "      (process* finger-program)" (BR)
+           "     (process* finger-program name))))" (BR)
+           "     (let ((proc->self (car results)))" (BR)
+           "       (let ((strings (let loop " (BR)
+           "                        (let ((l (read-line proc->self)))" (BR)
+           "                          (if (eof-object? l)" (BR)
+           "                            null" (BR)
+           "                            (cons l (loop)))))))" (BR)
+           "         (generate-html-output \"Finger Gateway Output\"" (BR)
+           "         (append" (BR)
+           "           '(\"<PRE>\")" (BR)
+           "           (map string->html strings)" (BR)
+           "           '(\"</PRE>\"))))))))")))))
\ No newline at end of file
diff --git a/collects/help/servlets/scheme/misc/database.ss b/collects/help/servlets/scheme/misc/database.ss
new file mode 100644
index 0000000000..ebc51029df
--- /dev/null
+++ b/collects/help/servlets/scheme/misc/database.ss
@@ -0,0 +1,34 @@
+(module database mzscheme
+  (require (lib "servlet.ss" "web-server"))
+  (require "../../private/headelts.ss")
+  
+  (require (lib "servlet.ss" "web-server"))
+  (provide interface-version timeout start)
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
+  (define (start initial-request)
+    (report-errors-to-browser send/finish)
+    
+    `(HTML 
+      (HEAD ,hd-css
+            ,@hd-links
+            (TITLE "How to connect to databases"))
+      (BODY 
+       (H1  "How to connect to databases") 
+       (A ((NAME "db") (VALUE "Database connections")))
+       "SrPersist (\"Sister Persist\") is an ODBC interface for "
+       "DrScheme and MzScheme. "
+       "Download SrPersist from "
+       (PRE  
+        " " 
+        (A ((HREF "http://www.plt-scheme.org/software/srpersist/")
+            (TARGET "_top")) "http://www.plt-scheme.org/software/srpersist/") ". ")
+       "ODBC is a very low-level interface. "
+       "Francisco Solsona has built a higher-level interface, "
+       "SchemeQL, that uses SrPersist.  See "
+       (PRE 
+        " " 
+        (A ((HREF "http://schematics.sourceforge.net/schemeql.html")
+            (TARGET "_top")) "http://schematics.sourceforge.net/schemeql.html"))
+       " for more details."))))
\ No newline at end of file
diff --git a/collects/help/servlets/scheme/misc/graphics.ss b/collects/help/servlets/scheme/misc/graphics.ss
new file mode 100644
index 0000000000..c0e833c0bc
--- /dev/null
+++ b/collects/help/servlets/scheme/misc/graphics.ss
@@ -0,0 +1,35 @@
+(module graphics mzscheme
+  (require (lib "servlet.ss" "web-server"))
+  (require "../../private/headelts.ss"
+           "../../../private/manuals.ss")
+  
+  (require (lib "servlet.ss" "web-server"))
+  (provide interface-version timeout start)
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
+  (define (start initial-request)
+    
+    (report-errors-to-browser send/finish)
+    
+    `(HTML 
+      (HEAD ,hd-css
+            ,@hd-links
+            (TITLE "How to write graphics programs"))
+      (BODY 
+       (H1 "How to write graphics programs")
+       (A ((NAME "gfx") (VALUE "Graphics")))
+       (A ((NAME "gui") (VALUE "GUIs")))
+       (A ((NAME "gui2") (VALUE "Graphical User Interfaces")))
+       "To write graphics programs, use DrScheme with the "
+       "Graphical (MrEd) flavor of the PLT " 
+       (A ((HREF "/servlets/scheme/what.ss")) " language") ". "
+       "MrEd provides a complete GUI toolbox that is described "
+       "in " 
+       ,(main-manual-page "mred") ". "
+       (P)
+       "For simple graphics programs, you may also use the "
+       "viewport-based graphics library, which is described in "
+       ,(manual-entry "misclib" "viewport" "Viewport Graphics") ". "
+       "The following declaration loads viewport graphics into MrEd:"
+       (PRE " (require (lib \"graphics.ss\" \"graphics\"))")))))
\ No newline at end of file
diff --git a/collects/help/servlets/scheme/misc/info.ss b/collects/help/servlets/scheme/misc/info.ss
new file mode 100644
index 0000000000..ba8cbb0a66
--- /dev/null
+++ b/collects/help/servlets/scheme/misc/info.ss
@@ -0,0 +1,2 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Help Servlets Scheme Misc"))
diff --git a/collects/help/servlets/scheme/misc/script.ss b/collects/help/servlets/scheme/misc/script.ss
new file mode 100644
index 0000000000..ffb20aedc4
--- /dev/null
+++ b/collects/help/servlets/scheme/misc/script.ss
@@ -0,0 +1,49 @@
+(module script mzscheme
+  (require (lib "servlet.ss" "web-server"))
+  (require "../../private/headelts.ss")
+  
+  (require (lib "servlet.ss" "web-server"))
+  (provide interface-version timeout start)
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
+  (define (start initial-request)
+    
+    (report-errors-to-browser send/finish)
+    
+    `(HTML 
+      (HEAD ,hd-css
+            ,@hd-links
+            (TITLE "How to write Unix shell scripts"))  
+      (BODY 
+       (H1 "How to write Unix shell scripts")  
+       (A ((NAME "sh") (VALUE "Shell scripts")))
+       "When MzScheme is installed as part of the standard Unix "
+       "PLT distribution, " 
+       (TT "plt/bin/mzscheme") " and  " 
+       (TT "plt/bin/mred") " are binary executables." 
+       (P) 
+       "Thus, they can be used with Unix's " (TT  "#!") 
+       " convention as follows:"
+       (PRE  
+        "  #! /usr/local/lib/plt/bin/mzscheme -r  ... " (BR) 
+        " " (I  "scheme-program") " ...")
+       "assuming that the " (TT  "plt") " tree is installed as " 
+       (TT "/usr/local/lib/plt") ". "
+       "To avoid specifying an absolute path, use " 
+       (TT "/usr/bin/env") ":"
+       (PRE  
+        " #! /usr/bin/env mzscheme -r  ... " (BR)
+        " " (I  "scheme-program") " ...")
+       (P)
+       "The above works when " 
+       (TT  "mzscheme") 
+       " is in the user's path. "
+       "The " (TT "mred") " executable can be used in the "
+       "same way for GUI scripts."
+       (P)
+       "Within " (I "scheme-program") ", " 
+       (TT  "(current-command-line-arguments)") 
+       " produces a vector of strings for the arguments "
+       "passed to the script. The vector is also available as " 
+       (TT "argv") "."))))
\ No newline at end of file
diff --git a/collects/help/servlets/scheme/misc/standalone.ss b/collects/help/servlets/scheme/misc/standalone.ss
new file mode 100644
index 0000000000..70251662ad
--- /dev/null
+++ b/collects/help/servlets/scheme/misc/standalone.ss
@@ -0,0 +1,34 @@
+(module standalone mzscheme
+  (require (lib "servlet.ss" "web-server"))
+  (require "../../private/headelts.ss"
+           "../../../private/manuals.ss")
+  
+  (require (lib "servlet.ss" "web-server"))
+  (provide interface-version timeout start)
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
+  (define (start initial-request)
+    
+    (report-errors-to-browser send/finish)
+    
+    `(HTML 
+      (HEAD ,hd-css
+            ,@hd-links
+            (TITLE "How to build a stand-alone executable"))
+      (BODY 
+       (H1 "How to build a stand-alone executable")
+       (A ((NAME "exec") (VALUE "Standalone executables")))
+       (A ((name "exec2") (VALUE "Stand-alone executables")))
+       "To create stand-alone executables, use DrScheme's "
+       (tt "Scheme | Create Executable ...")
+       " menu item. This menu is sensitive to the language levels; "
+       "the " (tt "module") " language permits the most flexibility "
+       "in creating executables."
+       
+       (p)
+       "The mzc compiler provides a more low-level interface "
+       "to stand-alone executables creation. "
+       "See " 
+       ,(main-manual-page "mzc")
+       " for more information."))))
\ No newline at end of file
diff --git a/collects/help/servlets/scheme/misc/system.ss b/collects/help/servlets/scheme/misc/system.ss
new file mode 100644
index 0000000000..b15230c445
--- /dev/null
+++ b/collects/help/servlets/scheme/misc/system.ss
@@ -0,0 +1,26 @@
+(module system mzscheme 
+  (require (lib "servlet.ss" "web-server"))
+  (require "../../private/headelts.ss"
+           "../../../private/manuals.ss")
+  
+  (require (lib "servlet.ss" "web-server"))
+  (provide interface-version timeout start)
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
+  (define (start initial-request)
+    
+    (report-errors-to-browser send/finish)
+    
+    `(HTML
+      (HEAD ,hd-css
+            ,@hd-links
+            (TITLE "How to call low-level system routines")) 
+      (BODY
+       (H1 "How to call low-level system routines") 
+       (A ((NAME "os") (VALUE "Low-level operating system calls")))
+       "To call low-level system routines, you must write "
+       "an extension to MzScheme using the C programming language. "
+       "See " 
+       ,(main-manual-page "insidemz")
+       " for details."))))
\ No newline at end of file
diff --git a/collects/help/servlets/scheme/what.ss b/collects/help/servlets/scheme/what.ss
new file mode 100644
index 0000000000..b03756038c
--- /dev/null
+++ b/collects/help/servlets/scheme/what.ss
@@ -0,0 +1,139 @@
+(module what mzscheme
+  (require "../private/util.ss"
+           "../../private/manuals.ss")
+  (require "../private/headelts.ss")
+  
+  (require (lib "servlet.ss" "web-server"))
+  (provide interface-version timeout start)
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
+  (define (start initial-request)
+    
+    (define stupid-internal-define-syntax (report-errors-to-browser send/finish))
+    
+    (define (standout-text s)
+      (color-with "forestgreen"
+                  `(B ,s)))
+    
+    `(HTML 
+      (HEAD ,hd-css
+            ,@hd-links
+            (TITLE "Scheme Languages"))
+      (BODY 
+       (H1  "Scheme Languages")  
+       (A ((NAME "scheme") (VALUE "Language Family")))
+       (A ((NAME "r5rs") (VALUE "r5rs")))
+       (A ((NAME "language levels") (VALUE "language levels")))
+       "From the introduction of "
+       ,(main-manual-page "r5rs") " (R5RS):" 
+       (P)
+       (DL  
+        (DD  
+         "Scheme is a statically scoped and properly "
+         "tail-recursive dialect of the Lisp programming "
+         "language [...] designed to have an exceptionally "
+         "clear and simple semantics and few different ways "
+         "to form expressions. A wide variety of programming "
+         "paradigms, including imperative, functional, and "
+         "message passing styles, find convenient expression "
+         "in Scheme."))
+       (P)
+       "DrScheme supports many dialects of Scheme. "
+       "The following dialects are specifically designed for "
+       "teaching computer science.  In DrScheme's "
+       (A ((HREF "/servlets/scheme/what.ss#lang-sel")) "language selection menu")
+       ", they are found under the heading " (B (TT "How to Design Programs")) "."
+       (UL  
+        (LI 
+         (A ((NAME "beg") (VALUE "Beginning Student language"))) 
+         ,(standout-text "Beginning Student")
+         " is a pedagogical version of Scheme "
+         "that is tailored for beginning computer "
+         "science students.") 
+        (LI  
+         (A ((NAME "begla") (VALUE "Beginning Student with List Abbreviations language")))
+         ,(standout-text "Beginning Student with List Abbreviations")
+         " extends Beginning Student with convenient "
+         "(but potentially confusing) ways to write lists, "
+         "including quasiquote.") 
+        (LI  
+         (A ((NAME "int") (VALUE "Intermediate Student language")))
+         ,(standout-text "Intermediate Student")
+         " adds local bindings and higher-order functions.") 
+        (LI  
+         (A ((NAME "intlam") (VALUE "Intermediate Student with Lambda language")))
+         ,(standout-text "Intermediate Student with Lambda")
+         " adds anonymous functions.") 
+        (LI  
+         (A ((NAME "adv") (VALUE "Advanced Student language")))
+         ,(standout-text "Advanced Student")
+         " adds mutable state."))
+       "The "
+       ,(standout-text "Essentials of Programming Languages")
+       " language is designed for use with the MIT Press "
+       "textbook with that name."
+       (P)
+       "Other dialects are designed for practicing programmers. " 
+       "The " (A ((NAME "r5rs2") (VALUE "R5RS Scheme language")))
+       ,(standout-text "R5RS")
+       " language is a standard dialect of Scheme that is "
+       "defined by the " 
+       ,(main-manual-page "r5rs") ". "
+       (A ((NAME "full") (VALUE "PLT Scheme language")))
+       "In DrScheme's "
+       (A ((HREF "/servlets/scheme/what.ss#lang-sel")) "language selection menu")
+       ", the following languages "
+       "are found under the heading " (B (TT "PLT")) ":"
+       (UL
+        (LI  
+         ,(standout-text "Textual (MzScheme)")
+         " is a superset of R5RS Scheme. "
+         "In addition to the the base Scheme language, "
+         "PLT Scheme provides exceptions, threads, "
+         "objects, modules, components, regular expressions, "
+         "TCP support, filesystem utilities, and process "
+         "control operations. This language is defined in " 
+         ,(main-manual-page "mzscheme")
+         ". ")
+        (LI
+         ,(standout-text "Graphical (MrEd)")
+         " includes the " (standout-text "Textual (MzScheme)") " language "
+         "and adds a graphical toolbox, "
+         "described in "
+         ,(main-manual-page "mred"))
+        (LI
+         ,(standout-text "Pretty Big")
+         " is a superset of the "
+	 (standout-text "Graphical (MrEd)")
+         " language, and adds forms from the "
+         (standout-text "Pretty Big")
+	 " language."
+	 " For those forms that are in both languages,"
+	 " Pretty Big behaves like Graphical (MrEd)."))
+       "The "
+       (A ((NAME "module") (VALUE "module")))
+       ,(standout-text "module")
+       " language supports development using PLT Scheme's "
+       ,(manual-entry "mzscheme" "modules" `(CODE "module"))
+       " form, where the module's language is explicitly "
+       "declared in the code."
+       (P)
+       "See "
+       ,(manual-entry "drscheme" "language levels" "the DrScheme manual")
+       " for further details on the languages, "
+       "especially the teaching languages." 
+       (P)
+       "DrScheme's set of languages can be extended, "
+       "so the above list mentions only the languages installed "
+       "by default. "
+       "Documentation for all languages is available "
+       "through the " 
+       (A ((HREF "/servlets/manuals.ss")) "manuals page") "."
+       (P)
+       (A ((NAME "lang-sel") (VALUE "language, setting")))
+       "DrScheme's default language is Beginning Student. "
+       "To change the language, select the " 
+       (B (TT  "Set Language...")) 
+       " item in the " 
+       (B (TT "Language")) " menu."))))
\ No newline at end of file
diff --git a/collects/help/web-root/conf/forbidden.html b/collects/help/web-root/conf/forbidden.html
new file mode 100644
index 0000000000..cb921d33dd
--- /dev/null
+++ b/collects/help/web-root/conf/forbidden.html
@@ -0,0 +1,8 @@
+<html>
+<head><title>Access Denied</title></head>
+<body>
+<p>The Help Desk server could not verify that you have permissions to access the requested document.</p>
+<a href="/servlets/home.ss" target="_top">Help Desk home</a>
+<p>Powered by <a href="http://www.plt-scheme.org/"><img width="53" height="19" src="/icons/plt-logo.gif" /></a></p>
+</body>
+</html>
diff --git a/collects/help/web-root/conf/not-found.html b/collects/help/web-root/conf/not-found.html
new file mode 100644
index 0000000000..541fee37d1
--- /dev/null
+++ b/collects/help/web-root/conf/not-found.html
@@ -0,0 +1,8 @@
+<html>
+<head><title>Not Found</title></head>
+<body bgcolor='white'>
+<p>The file you were looking for was not found on the Help Desk server.</p>
+<a href="/servlets/home.ss" target="_top">Help Desk home</a>
+<p>Powered by <a href="http://www.plt-scheme.org/"><img width="53" height="19" src="/icons/plt-logo.gif" /></a></p>
+</body>
+</html>
diff --git a/collects/help/web-root/conf/passwords-refresh.html b/collects/help/web-root/conf/passwords-refresh.html
new file mode 100644
index 0000000000..ab4731ad71
--- /dev/null
+++ b/collects/help/web-root/conf/passwords-refresh.html
@@ -0,0 +1,8 @@
+<html>
+<head><title>Passwords Refreshed</title></head>
+<body bgcolor='white'>
+<p>Passwords will reload for the next authentication request.</p>
+<a href="/servlets/home.ss" target="_top">Help Desk home</a>
+<p>Powered by <a href="http://www.plt-scheme.org/"><img width="53" height="19" src="/icons/plt-logo.gif" /></a></p>
+</body>
+</html>
diff --git a/collects/help/web-root/conf/protocol-error.html b/collects/help/web-root/conf/protocol-error.html
new file mode 100644
index 0000000000..f2eaffc5b6
--- /dev/null
+++ b/collects/help/web-root/conf/protocol-error.html
@@ -0,0 +1,8 @@
+<html>
+<head><title>Browser Error</title></head>
+<body>
+<p>The browser sent a malformed request to the Help Desk server.</p>
+<a href="/servlets/home.ss" target="_top">Help Desk home</a>
+<p>Powered by <a href="http://www.plt-scheme.org/"><img width="53" height="19" src="/icons/plt-logo.gif" /></a></p>
+</body>
+</html>
diff --git a/collects/help/web-root/conf/servlet-error.html b/collects/help/web-root/conf/servlet-error.html
new file mode 100644
index 0000000000..06a05eecc6
--- /dev/null
+++ b/collects/help/web-root/conf/servlet-error.html
@@ -0,0 +1,13 @@
+<html>
+<head><title>Servlet Error</title></head>
+<body>
+<p>A Help Desk servlet terminated abnormally.<br />
+   Please use the bug report link in Help Desk to
+   report the problem.  Alternatively, you may send a 
+   bug report via the Web at 
+   <a href="http://bugs.plt-scheme.org/">http://bugs.plt-scheme.org/</a>.
+   </p>
+<a href="/servlets/home.ss" target="_top">Help Desk home</a>
+<p>Powered by <a href="http://www.plt-scheme.org/"><img width="53" height="19" src="/icons/plt-logo.gif" /></a></p>
+</body>
+</html>
diff --git a/collects/help/web-root/conf/servlet-refresh.html b/collects/help/web-root/conf/servlet-refresh.html
new file mode 100644
index 0000000000..d046d190df
--- /dev/null
+++ b/collects/help/web-root/conf/servlet-refresh.html
@@ -0,0 +1,8 @@
+<html>
+<head><title>Servlets Refreshed</title></head>
+<body bgcolor='white'>
+<p>Fresh copies of Help Desk servlets will now be (re)loaded from disk.</p>
+<a href="/servlets/home.ss" target="_top">Help Desk home</a>
+<p>Powered by <a href="http://www.plt-scheme.org/"><img width="53" height="19" src="/icons/plt-logo.gif" /></a></p>
+</body>
+</html>
diff --git a/collects/hierlist/doc.txt b/collects/hierlist/doc.txt
new file mode 100644
index 0000000000..df72d4ed74
--- /dev/null
+++ b/collects/hierlist/doc.txt
@@ -0,0 +1,212 @@
+
+_Hierarchical List Control_
+
+hierlists.ss defines hierlist^
+hierlistr.ss returns a unit/sig, imports mred^ and 
+mzlib:function^ and exports hierlist^
+hierlist.ss invoke-opens hierlistr.ss
+
+_hierlist_ defines three classes:
+
+--------------------------------------------------
+
+> hierarchical-list%, derived from editor-canvas%
+   
+It accepts two initialization arguments. The first
+specifies the GUI parent for the control and is
+required. The second is the `style' parameter
+passed to the super class (editor-canvas%)
+and defaults to: '(no-hscroll).
+
+
+New methods:
+
+>  get-selected :: (send a-list get-selected) - returns #f or an
+     instance of hierarchical-list-item<%>
+
+>  new-item :: (send a-list new-item) - creates and returns a new
+     (empty) hierarchical-list-item<%>
+
+>  new-item :: (send a-list new-item mixin) - creates and returns
+     a new (empty) hierarchical-list-item<%>, but first, applies
+     `mixin' to a class implemeting hierarchical-list-item<%> and uses
+     the result as the class for the new hierarchical-list-item<%>
+     object.
+
+> set-no-sublists :: (send a-list set-no-sublists no-sublists?) - 
+     avoids space to the left of the list that would normally align
+     non-list items with list items; this method can be called only
+     when the list is empty
+
+>  new-list :: (send a-list new-list) - creates and returns a new
+     (empty) hierarchical-list-compound-item<%>
+
+>  new-list :: (send a-list new-list mixin) - creates and returns
+     a new (empty) hierarchical-list-compound-item<%>, but first,
+     applies `mixin' to a class implemeting
+     hierarchical-list-compound-item<%> and uses the result as the
+     class for the new hierarchical-list-compound-item<%> object.
+
+>  delete-item :: (send a-list delete-item i) - delete
+     hierarchical-list-item<%> i from the list
+
+>  get-items :: (send a-list get-items) - returns a list of the items
+     in the list
+
+>  selectable :: (send a-list selectable) - returns #t if items are
+     selectable, #f otherwise; default is #t
+>  selectable :: (send a-list selectable on?) - sets whether items
+     are selectable
+
+>  on-select :: (send a-list on-select i) - called for new select of
+     `i', hierarchical-list-item<%> or #f, where #f means that no item
+     is selected
+
+>  on-click :: (send a-list on-click i) - called when an item is
+     clicked on, but selection for that item is not allowed.
+     `i' is a hierarchical-list-item<%>.
+
+     selection can be disallowed by the `set-allow-selection' method
+     or by the `selectable' method.
+     
+>  on-double-select :: (send a-list on-double-select i) - called for
+     double-click on hierarchical-list-item<%> `i'
+
+>  on-item-opened :: (send a-list on-item-opened i) - called when the
+     arrow for `i' is turned down
+
+>  on-item-closed :: (send a-list on-item-closed i) - called when the
+     arrow for `i' is turned up
+
+>  sort :: (send a-list sort less-than-proc) - sorts items in the list
+     by calling `less-than-proc' on pairs of items.
+
+>  can-do-edit-operation? :: (send a-list can-do-edit-operation? sym bool)
+     - like the method on editor<%>s; returns #f always
+
+>  do-edit-operation :: (send a-list do-edit-operation sym bool)
+     - like the method on editor<%>s; does nothing
+
+>  select-prev :: (send a-list select-prev)
+>  select-next :: (send a-list select-next)
+>  select-first :: (send a-list select-first)
+>  select-last :: (send a-list select-last)
+>  select-in :: (send a-list select-in)
+>  select-out :: (send a-list select-out)
+>  select :: (send a-list select i)
+>  page-up :: (send a-list page-up)
+>  page-down :: (send a-list page-down)
+     - Move the selection and scroll
+
+--------------------------------------------------
+
+> hierarchical-list-item<%>, instantiate via new-item
+
+  Methods:
+
+>  get-editor :: (send an-item get-editor) - returns text% editor
+     containing the display representation of the item
+
+>  is-selected? :: (send an-item is-selected?) - returns #t or #f
+
+>  select :: (send an-item select on?) - selects or deselects the
+     item; hierarchical-list%'s on-select is called
+
+>  user-data :: (send an-item user-data) - returns user data;
+     initialized to #f
+>  user-data :: (send an-item user-data v) - sets user data to v
+
+>  get-clickable-snip :: (send an-item get-clickable-snip) -
+   returns the snip that (when clicked) selects this element in
+   the list. This is intended for use with the autmatic test
+   suite.
+
+>  get-allow-selection? :: (send an-item get-allow-selection?) -
+
+   returns #t or #f -- dictating if this item is allowed
+   to be selected.
+
+>  set-allow-selection :: (send an-item set-allow-selection boolean) -
+   deteremines if this item is allowed to be selected
+   
+--------------------------------------------------
+
+> hierarchical-list-compound-item<%>, instantiate via new-list
+  extends hierarchical-list-item<%>
+
+  New methods:
+
+>  new-item :: (send a-list-item new-item) - creates and returns a new
+     (empty) hierarchical-list-item<%>
+
+>  new-item :: (send a-list-item new-item mixin) - creates and returns
+     a new (empty) hierarchical-list-item<%>, but first, applies
+     `mixin' to a class implemeting hierarchical-list-item<%> and uses
+     the result as the class for the new hierarchical-list-item<%>
+     object.
+
+> set-no-sublists :: (send a-list set-no-sublists no-sublists?) - 
+     avoids space to the left of the list that would normally align
+     non-list items with list items; this method can be called only
+     when the list is empty
+
+>  new-list :: (send a-list-item new-list) - creates and returns a new
+     (empty) hierarchical-list-compound-item<%>
+
+>  new-list :: (send a-list-item new-list mixin) - creates and returns
+     a new (empty) hierarchical-list-compound-item<%>, but first,
+     applies `mixin' to a class implemeting
+     hierarchical-list-compound-item<%> and uses the result as the
+     class for the new hierarchical-list-compound-item<%> object.
+
+>  delete-item :: (send a-list delete-item i) - delete
+     hierarchical-list-item<%> `i' from the compound item
+
+>  get-items :: (send a-list-item get-items) - returns a list of the
+     items in the compound item
+
+> open :: (send a-list-item open) - displays the children of this list.
+
+> close :: (send a-list-item close) - hides the children of this list.
+
+> toggle-open/closed :: (send a-list-item toggle-open/closed) - 
+     toggles the visible status of the children of this list
+
+> is-open? :: (send a-list-item is-open?) - 
+     returns a boolean indicating if the children of this list are visible.
+
+> get-arrow-snip :: (send a-list-item get-arrow-snip) -
+     returns the arrow snip. intended for test suites to facilitate simulated clicks
+
+
+--------------------------------------------------
+
+If you use the `find-position' and `find-snip' methods of a
+hierarchical-list%, you will get back
+hierarchical-item-snip% and hierarchical-list-snip%
+objects. They support these methods:
+
+> hierarchical-item-snip% derived from editor-snip%
+
+> get-item :: (send a-hl-item-snip get-item) - returns the 
+     hierarchical-list-item<%> corresponding to this snip
+
+> hierarchical-list-snip% derived from editor-snip%
+
+> get-item :: (send a-hl-list-snip get-item) - returns the 
+     hierarchical-list-item<%> corresponding to this snip
+
+> get-content-buffer :: (send a-hl-list-snip get-content-buffer) -
+     returns the text% that contains the sub-items.
+
+--------------------------------------------------
+
+_Hierlist keystrokes_
+
+Hierlists support these keystrokes:
+
+ - down:    move to the next entry at the current level (skipping lower levels)
+ - up:      move to the previous entry at the current level (skipping lower levels)
+ - left:    move to the enclosing level (only valid at embedded levels)
+ - right:   move down in one level (only valid for lists)
+ - return:  open / close the current selected level (only valid for lists)
diff --git a/collects/hierlist/hierlist-sig.ss b/collects/hierlist/hierlist-sig.ss
new file mode 100644
index 0000000000..4542c7377c
--- /dev/null
+++ b/collects/hierlist/hierlist-sig.ss
@@ -0,0 +1,16 @@
+
+(module hierlist-sig mzscheme
+  (require (lib "unitsig.ss"))
+
+  (provide hierlist^)
+  (define-signature hierlist^
+    (hierarchical-list%
+     hierarchical-list-item<%>
+     hierarchical-list-item%
+     hierarchical-list-compound-item<%>
+     hierarchical-list-compound-item%
+     
+     hierarchical-item-snip%
+     hierarchical-list-snip%)))
+
+
diff --git a/collects/hierlist/hierlist-unit.ss b/collects/hierlist/hierlist-unit.ss
new file mode 100644
index 0000000000..10da852df2
--- /dev/null
+++ b/collects/hierlist/hierlist-unit.ss
@@ -0,0 +1,810 @@
+
+(module hierlist-unit mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "class.ss")
+	   (lib "class100.ss")
+	   (lib "mred-sig.ss" "mred")
+	   "hierlist-sig.ss")
+
+  (require (lib "list.ss")
+	   (lib "etc.ss"))
+
+  (provide hierlist@)
+  (define hierlist@
+    (unit/sig hierlist^
+      (import mred^)
+
+      (define-local-member-name 
+	;; In hierarchical-list%
+	ensure-not-selected)
+
+      (define transparent (make-object brush% "WHITE" 'transparent))
+      (define transparent-pen (make-object pen% "WHITE" 1 'transparent))
+      (define black-xor-pen (make-object pen% "BLACK" 1 'hilite))
+      (define red (make-object brush% "RED" 'solid))
+      (define blue (make-object brush% "BLUE" 'solid))
+      (define black-xor (make-object brush% "BLACK" 'hilite))
+      (define arrow-cursor (make-object cursor% 'arrow))
+      
+      (define-values (up-bitmap down-bitmap up-click-bitmap down-click-bitmap)
+	(with-handlers ([exn:fail? (lambda (x)
+				     (values
+				      (make-object bitmap% 10 10)
+				      (make-object bitmap% 10 10)
+				      (make-object bitmap% 10 10)
+				      (make-object bitmap% 10 10)))])
+	  (values
+	   (make-object bitmap% (build-path (collection-path "icons") "turn-up.png"))
+	   (make-object bitmap% (build-path (collection-path "icons") "turn-down.png"))
+	   (make-object bitmap% (build-path (collection-path "icons") "turn-up-click.png"))
+	   (make-object bitmap% (build-path (collection-path "icons") "turn-down-click.png")))))
+
+      ;; Hack for implementing auto-wrapping items:
+      (define arrow-size 0)
+
+      (define orig-size (max (send up-click-bitmap get-width) (send up-click-bitmap get-height)))
+
+      ;; Private arrow snip class:
+      (define arrow-snip-class (make-object snip-class%))
+      (send arrow-snip-class set-classname "hier-arrow")
+      (define arrow-snip%
+	(class100 snip% (callback)
+          (inherit get-admin set-flags get-flags set-count set-snipclass get-style)
+          (rename [super-get-extent get-extent])
+          (private-field 
+           [size-calculated? #f]
+           [size orig-size]
+           [width-fraction 1/2]
+           [on? #f]
+           [click-callback callback]
+           [clicked? #f])
+          (private
+            [set-sizes
+             (lambda (dc)
+               (let* ([s (get-style)]
+                      [h (send s get-text-height dc)]
+                      [d (send s get-text-descent dc)]
+                      [a (send s get-text-space dc)])
+                 (set! size (max orig-size (- h d a)))
+                 (set! size-calculated? #t)
+		 (set! arrow-size size)))]
+            [get-width (lambda () size)]
+            [get-height (lambda () size)]
+            [update
+             (lambda ()
+               (send (get-admin) needs-update this 0 0 (get-width) (get-height)))])
+          (override
+            [get-extent (lambda (dc x y w h descent space lspace rspace)
+                          (super-get-extent dc x y w h descent space lspace rspace)
+                          (unless size-calculated? (set-sizes dc))
+                          (when w (set-box! w (get-width)))
+                          (when h (set-box! h (get-height)))
+                          (when descent (set-box! descent 0))
+                          (when space (set-box! space 0)))]
+            [partial-offset (lambda (dc x y len)
+                              (unless size-calculated? (set-sizes dc))
+                              (if (zero? len)
+                                  0 
+                                  (get-width)))]
+            [draw (lambda (dc x y left top right bottom dx dy draw-caret)
+                    (unless size-calculated? (set-sizes dc))
+                    (let* ([bitmap (if clicked?
+                                       (if on? down-click-bitmap up-click-bitmap)
+                                       (if on? down-bitmap up-bitmap))]
+                           [bw (send bitmap get-width)]
+                           [bh (send bitmap get-height)])
+                      (send dc draw-bitmap-section bitmap 
+                            (+ x (max 0 (- (/ size 2) (/ bw 2))))
+                            (+ y (max 0 (- (/ size 2) (/ bh 2))))
+			    0 0 (min bw (+ size 2)) (min bh (+ size 2)))))]
+            [size-cache-invalid (lambda () (set! size-calculated? #f))]
+            [on-event
+             (lambda (dc x y mediax mediay event)
+               (let ([in-range?
+                      (and (<= 0 (- (send event get-x) x) (get-width))
+                           (<= 0 (- (send event get-y) y) (get-height)))])
+                 (cond
+                   [(send event button-down?)
+                    (when in-range?
+                      (unless clicked?
+                        (set! clicked? #t)
+                        (update)))]
+                   [(send event button-up?)
+                    (when clicked?
+                      (set! clicked? #f)
+                      (update))
+                    (when in-range?
+                      (on (not on?))
+                      (click-callback this))]
+                   [(send event dragging?)
+                    (unless (or (and clicked? in-range?)
+                                (and (not clicked?) (not in-range?)))
+                      (set! clicked? (not clicked?))
+                      (update))]
+                   [else (when clicked?
+                           (set! clicked? #f)
+                           (update))])))]
+            [copy (lambda () (make-object arrow-snip% click-callback))])
+          (public
+            [on (case-lambda 
+                 [(v) (set! on? v) (update)]
+                 [() on?])])
+          (sequence
+            (super-init)
+            (set-snipclass arrow-snip-class)
+            (set-count 1)
+            (set-flags (cons 'handles-events (get-flags))))))
+
+      ;; Hack to get whitespace matching width of arrow: derive a new
+      ;; class that overrides the `draw' method to do nothing. 
+      (define whitespace-snip%
+	(class100 arrow-snip% ()
+	  (override [draw (lambda (dc x y left top right bottom dx dy draw-caret) (void))])
+	  (sequence (super-init void))))
+
+      ;; Keymap to map clicks and double-clicks
+      (define item-keymap (make-object keymap%))
+
+      (send item-keymap add-function "mouse-select"
+	    (lambda (edit event) (when (send event button-down?)
+                                   (send edit select #t)
+					; To handle hypertext clicks:
+				   (send edit on-default-event event))))
+      (send item-keymap add-function "mouse-double-select"
+	    (lambda (edit event) (when (send event button-down?)
+				   (send edit double-select))))
+      
+      (send item-keymap map-function "leftbutton" "mouse-select")
+      (send item-keymap map-function "leftbuttondouble" "mouse-double-select")
+
+      (define hierarchical-list-item<%>
+	(interface ()
+	  get-editor 
+          is-selected?
+          select
+          user-data
+          get-allow-selection?
+          set-allow-selection
+          get-clickable-snip
+          get-parent))
+
+      (define hierarchical-list-item%
+	(class100* object% (hierarchical-list-item<%>) (snp)
+          (private-field
+           [snip snp]
+           [data #f]
+           [allow-selection #t])
+          (public
+            [get-allow-selection? (lambda () allow-selection)]
+            [set-allow-selection (lambda (_a) (set! allow-selection _a))]
+            
+            [get-clickable-snip (lambda () snip)]
+            [get-editor (lambda () (send snip get-item-buffer))]
+            
+            ;; the `get-editor' method is overridden
+            [is-selected? (lambda () (send (get-editor) is-selected?))]
+            
+            [select (lambda (on?) (send snip select on?))]
+            [scroll-to (lambda () (let* ([admin (send snip get-admin)]
+                                         [dc (send admin get-dc)]
+                                         [h-box (box 0.0)])
+                                    (send snip get-extent dc 0 0 #f h-box #f #f #f #f)
+                                    (send admin
+                                          scroll-to
+                                          snip
+                                          0 0 0 (unbox h-box) #t)))]
+            [user-data (case-lambda [() data][(x) (set! data x)])]
+            [get-parent (lambda () 
+                          (let ([parent-of-snip (send snip get-parent)])
+                            (and parent-of-snip
+                                 (let ([parent-snip (send parent-of-snip get-parent-snip)])
+                                   (and parent-snip
+                                        (send parent-snip get-item))))))])
+          (sequence (super-init))))
+
+      (define hierarchical-list-compound-item<%>
+	(interface (hierarchical-list-item<%>)
+	  new-item 
+          new-list
+          delete-item
+          get-items
+          open
+          close
+          toggle-open/closed
+          is-open?
+          get-arrow-snip))
+
+      (define hierarchical-list-compound-item%
+	(class100* hierarchical-list-item% (hierarchical-list-compound-item<%>) (snp)
+          (private-field [snip snp])
+          (override
+            [get-editor (lambda () (send snip get-title-buffer))])
+          (public
+            [get-arrow-snip (lambda () (send snip get-arrow-snip))]
+            [open
+             (lambda ()
+               (send snip open))]
+            [close
+             (lambda ()
+               (send snip close))]
+            [toggle-open/closed
+             (lambda ()
+               (send snip toggle-open/closed))]
+            [is-open?
+             (lambda ()
+               (send snip is-open?))]
+            [new-item 
+             (lambda x
+               (begin0
+                 (send (send snip get-content-buffer) new-item . x)
+                 (send snip not-empty-anymore)))]
+	    [set-no-sublists (lambda x (send (send snip get-content-buffer) set-no-sublists . x))]
+            [new-list 
+             (lambda x
+               (begin0 
+                 (send (send snip get-content-buffer) new-list . x)
+                 (send snip not-empty-anymore)))]
+            [delete-item (lambda (i) (begin0
+                                       (send (send snip get-content-buffer) delete-item i)
+                                       (send snip check-empty-now)))]
+            [get-items (lambda () (send (send snip get-content-buffer) get-items))])
+          (sequence
+            (super-init snip))))
+
+      ;; Buffer for a single list item
+      (define hierarchical-item-text%
+	(class100 text% (tp tp-select itm snp dpth)
+          (inherit set-max-undo-history hide-caret
+                   last-position set-position set-keymap
+                   invalidate-bitmap-cache set-max-width
+                   get-view-size)
+          (rename [super-auto-wrap auto-wrap]
+                  [super-on-default-event on-default-event])
+          (private-field
+           [top tp]
+           [top-select tp-select]
+           [item itm]
+           [snip snp]
+           [depth dpth]
+           [selected? #f])
+          (public
+            [is-selected? (lambda () selected?)]
+            [show-select (lambda (on?)
+                           (set! selected? on?)
+                           (invalidate-bitmap-cache))])
+          (override
+            [auto-wrap (case-lambda
+                        [() (super-auto-wrap)]
+                        [(on?) (super-auto-wrap on?)
+                         (when on?
+                           (let ([wbox (box 0)])
+                             (send (send top get-editor) get-view-size wbox (box 0))
+                             ;; These icky constants should be eliminated
+                             (let ([w (- (unbox wbox) 8 (* depth arrow-size))])
+                               (set-max-width (if (positive? w)
+                                                  w
+                                                  'none)))))])]
+            [on-paint
+             (lambda (pre? dc left top_ right bottom dx dy caret)
+               (when (and (not pre?) selected?)
+                 (let ([b (send dc get-brush)]
+                       [p (send dc get-pen)]
+                       [filled? (or (not (send top show-focus))
+                                    (send top has-focus?))])
+                   (unless filled?
+                     ;; To draw the right outline, we need the display area
+                     (set! left 0)
+                     (set! top_ 0)
+                     (let ([wbox (box 0)]
+                           [hbox (box 0)])
+                       (get-view-size wbox hbox)
+                       (set! right (unbox wbox))
+                       (set! bottom (unbox hbox))))
+                   (send dc set-brush (if filled? black-xor transparent))
+                   (send dc set-pen (if filled? transparent-pen black-xor-pen))
+                   (send dc draw-rectangle (+ dx left) (+ dy top_) (- right left) (- bottom top_))
+		   (unless (or filled? ((- right left) . < . 2) ((- bottom top_) . < . 2))
+		     (send dc draw-rectangle (+ dx left 1) (+ dy top_ 1) (- right left 2) (- bottom top_ 2)))
+                   (send dc set-pen p)
+                   (send dc set-brush b))))])
+          (public
+            [select (lambda (on?)
+                      (unless (eq? (not selected?) 
+                                   (not on?))
+                        (top-select (if on? item #f) snip)))]
+            [double-select (lambda () (send top on-double-select item))]
+            [select-prev (lambda () (send top select-prev))])
+          (override
+            [on-default-char (lambda (x) (void))]
+	    [can-do-edit-operation? (opt-lambda (x [r? #t]) 
+				      (and (super can-do-edit-operation? x r?)
+					   (send top can-do-edit-operation? x r?)))]
+	    [do-edit-operation (opt-lambda (x [r? #t] [time 0]) (send top do-edit-operation x r? time))])
+          (sequence
+            (super-init)
+            (hide-caret #t)
+            (set-max-undo-history 0)
+            (set-keymap item-keymap))))
+      
+      ;; Buffer for a compound list item (and the top-level list)
+      (define (make-hierarchical-list-text% super%)
+	(class100 super% (tp tp-select dpth parent-snp)
+          (inherit set-max-undo-history hide-caret erase
+                   last-position insert delete line-start-position line-end-position
+                   begin-edit-sequence end-edit-sequence get-style-list)
+          (private-field
+           [top tp]
+           [top-select tp-select]
+           [depth dpth]
+           [parent-snip parent-snp]
+           [children null]
+	   [last-child #f]
+	   [no-sublists? #f])
+          (private
+            [make-whitespace (lambda () (make-object whitespace-snip%))]
+            [insert-item 
+             (lambda (mixin snip% whitespace?)
+               (let ([s (make-object snip% this top top-select (add1 depth) mixin)])
+                 (begin-edit-sequence)
+                 (unless (null? children)
+                   (insert #\newline (last-position)))
+                 (when whitespace?
+		   (insert (make-whitespace) (last-position)))
+                 (insert s (last-position))
+                 (end-edit-sequence)
+		 (let ([p (list s)])
+		   (if last-child
+		       (set-cdr! last-child p)
+		       (set! children (append children p)))
+		   (set! last-child p))
+                 (send s get-item)))])
+          (public
+            [get-parent-snip (lambda () parent-snip)]
+            [deselect-all 
+             (lambda () (for-each (lambda (x) (send x deselect-all)) children))]
+            [new-item 
+             (case-lambda
+              [() (new-item (lambda (x) x))]
+              [(mixin)
+               (insert-item mixin hierarchical-item-snip% (not no-sublists?))])]
+            [new-list
+             (case-lambda
+              [() (new-list (lambda (x) x))]
+              [(mixin)
+	       (when no-sublists?
+		 (error 'new-list "this list has been designated with `set-no-sublists' as having no sublists"))
+               (insert-item mixin hierarchical-list-snip% #f)])]
+	    [set-no-sublists
+	     (lambda (no?)
+	       (unless (null? children)
+		 (error 'set-no-sublists "cannot change sublist mode because the list is non-empty"))
+	       (set! no-sublists? (and no? #t)))]
+            [get-items (lambda () (map (lambda (x) (send x get-item)) children))]
+            [delete-item
+             (lambda (i)
+               (let loop ([pos 0][l children][others null])
+                 (cond
+                   [(null? l) (error 'hierarchical-list-compound-item::delete-item "item not found: ~a" i)]
+                   [(eq? (send (car l) get-item) i)
+		    (send top ensure-not-selected i)
+                    (send (car l) deselect-all)
+                    (set! children (append (reverse others) (cdr l)))
+		    (set! last-child #f)
+                    (let ([s (line-start-position pos)]
+                          [e (line-end-position pos)])
+                      (delete (if (zero? s) s (sub1 s)) (if (zero? s) (add1 e) e)))]
+                   [else (loop (add1 pos) (cdr l) (cons (car l) others))])))]
+            [sort (lambda (less-than?)
+                    (let ([l (mergesort children (lambda (a b)
+                                                   (less-than? (send a get-item)
+                                                               (send b get-item))))])
+                      (begin-edit-sequence)
+                      (for-each (lambda (child)
+                                  (when (is-a? child hierarchical-list-snip%)
+                                    (let ([ed (send child get-content-buffer)])
+                                      (when (is-a? ed hierarchical-list-text%)
+                                        (send ed sort less-than?)))))
+                                children)
+                      (erase)
+                      (let ([to-scroll-to #f])
+                        (for-each
+                         (lambda (s)
+                           (unless to-scroll-to
+                             (when (and (is-a? (send s get-item) hierarchical-list-item<%>)
+                                        (send (send s get-item) is-selected?))
+                               (set! to-scroll-to s)))
+                           (unless (or no-sublists?
+				       (is-a? s hierarchical-list-snip%))
+                             (insert (make-whitespace)))
+                           (insert s)
+                           (insert #\newline))
+                         l)
+                        (unless (null? l)
+                          (delete)) ; delete last #\newline
+                        (set! children l)
+			(set! last-child #f)
+                        (when to-scroll-to
+                          (send (send to-scroll-to get-item) scroll-to)))
+                      (end-edit-sequence)))]
+            [reflow-items
+             (lambda ()
+               (for-each
+                (lambda (c)
+                  (send c reflow-item))
+                children))])
+          (override
+            [on-default-char (lambda (x) (void))]
+            [on-default-event (lambda (x) (void))]
+	    [can-do-edit-operation? (opt-lambda (x [r? #t]) 
+				      (and (super can-do-edit-operation? x r?)
+					   (send top can-do-edit-operation? x r?)))]
+	    [do-edit-operation (opt-lambda (x [r? #t] [time 0]) (send top do-edit-operation x r? time))])
+          (sequence
+            (super-init)
+            (hide-caret #t)
+            (set-max-undo-history 0))))
+
+      (define hierarchical-list-text% (make-hierarchical-list-text% text%))
+
+      ;; Snip for a single list item
+      (define hierarchical-item-snip%
+	(class100 editor-snip% (prnt top top-select depth mixin)
+	  (private-field [parent prnt])
+	  (public
+	    [get-parent (lambda () parent)]
+	    [get-item-text% (lambda () hierarchical-item-text%)]
+	    [select (lambda (on?) (send item-buffer select on?))]
+	    [deselect-all (lambda () (select #f))]
+	    [show-select (lambda (on?) (send item-buffer show-select on?))]
+	    [get-item-buffer (lambda () item-buffer)]
+	    [get-item (lambda () item)]
+	    [reflow-item (lambda () 
+			   (when (send item-buffer auto-wrap)
+			     (send item-buffer auto-wrap #t)))])
+	  (private-field
+	    [item (make-object (mixin hierarchical-list-item%) this)]
+	    [item-buffer (make-object (get-item-text%) top top-select item this depth)])
+	  (sequence
+	    (super-init item-buffer #f 0 0 0 0 0 0 0 0))))
+
+      ;; Snip for a compound list item
+      (define hierarchical-list-snip%
+	(class100 editor-snip% (prnt tp top-select depth mixin [title #f][content #f])
+	  (private-field 
+	    [parent prnt]
+	    [top tp])
+	  (public
+	    [get-parent (lambda () parent)]
+	    [get-main-text% (lambda () (class100 text% args
+					 (override
+					   [on-default-char (lambda (x) (void))]
+					   [on-default-event (lambda (x) (void))]
+					   [can-do-edit-operation? (opt-lambda (x [r? #t]) 
+								     (and (super can-do-edit-operation? x r?)
+									  (send top can-do-edit-operation? x r?)))]
+					   [do-edit-operation (opt-lambda (x [r? #t] [time 0]) (send top do-edit-operation x r? time))])
+					 (sequence 
+					   (apply super-init args))))]
+	    [get-title-text% (lambda () hierarchical-item-text%)]
+	    [get-content-text% (lambda () hierarchical-list-text%)]
+	    [get-arrow-snip% (lambda () arrow-snip%)]
+	    [select (lambda (on?)
+		      (if on?
+			  (send title-buffer select #t)
+			  (send title-buffer select #f)))]
+	    [deselect-all (lambda ()
+			    (select #f)
+			    (send content-buffer deselect-all))]
+	    [show-select (lambda (on?) (send title-buffer show-select on?))]
+	    [not-empty-anymore (lambda ()
+				 (when was-empty?
+				   (set! was-empty? #f)
+				   (set! was-non-empty? #t)
+				   (send main-buffer begin-edit-sequence)
+				   (send main-buffer insert #\newline 2)
+				   (send main-buffer insert whitespace 3)
+				   (send main-buffer insert content-snip 4)
+				   (send main-buffer end-edit-sequence)))]
+	    [check-empty-now (lambda ()
+			       (when (and was-non-empty? 
+					  (zero? (send content-buffer last-position)))
+				 (set! was-empty? #t)
+				 (set! was-non-empty? #f)
+				 (send main-buffer delete 2 5)))]
+	    [open (lambda () (handle-open #t))]
+	    [close (lambda () (handle-close #t))]
+	    [is-open? (lambda () open?)]
+	    [toggle-open/closed
+	     (lambda ()
+	       (if open?
+		   (handle-close #t)
+		   (handle-open #t)))]
+	    [on-arrow (lambda (a)
+			(if (send a on)
+			    (handle-open #f)
+			    (handle-close #f)))]
+	    [get-title-buffer (lambda () title-buffer)]
+	    [get-content-buffer (lambda () content-buffer)]
+	    [get-item (lambda () item)]
+	    [reflow-item (lambda () 
+			   (when (send title-buffer auto-wrap)
+			     (send title-buffer auto-wrap #t))
+			   (send (send content-snip get-editor) reflow-items))])
+	  (private-field
+	    [open? #f])
+	  (private
+	    [handle-open
+	     (lambda (update-arrow?)
+	       (unless open?
+		 (set! open? #t)
+		 (when update-arrow? (send arrow on #t))
+		 (send main-buffer begin-edit-sequence)
+		 (send top on-item-opened (get-item))
+		 (if (zero? (send content-buffer last-position))
+		     (set! was-empty? #t)
+		     (begin
+		       (set! was-non-empty? #t)
+		       (send main-buffer insert #\newline 2)
+		       (send main-buffer insert whitespace 3)
+		       (send main-buffer insert content-snip 4)))
+		 (send main-buffer scroll-to-position 0
+		       #f
+		       (send main-buffer last-position)
+		       'start)
+		 (send main-buffer end-edit-sequence)))]
+	    [handle-close
+	     (lambda (update-arrow?)
+	       (when open?
+		 (set! open? #f)
+		 (when update-arrow? (send arrow on #f))
+		 (set! was-empty? #f)
+		 (set! was-non-empty? #f)
+		 (send main-buffer begin-edit-sequence)
+		 (send content-buffer deselect-all)
+		 (send main-buffer delete 2 5)
+		 (send top on-item-closed (get-item))
+		 (send main-buffer end-edit-sequence)))])
+	  (private-field
+	    [was-empty? #f]
+	    [was-non-empty? #f]
+	    [item (make-object (mixin hierarchical-list-compound-item%) this)]
+	    [main-buffer (make-object (get-main-text%))]
+	    [title-buffer (make-object (get-title-text%) top top-select item this depth)]
+	    [content-buffer (make-object (get-content-text%) top top-select depth this)]
+	    [title-snip (make-object editor-snip% title-buffer #f 0 0 0 0 0 0 0 0)]
+	    [content-snip (make-object editor-snip% content-buffer #f 4 0 0 0 0 0 0 0)]
+	    [arrow (make-object (get-arrow-snip%) (lambda (a) (on-arrow a)))]
+	    [whitespace (make-object whitespace-snip%)])
+          (public
+            [get-arrow-snip (lambda () arrow)])
+	  (sequence
+	    (super-init main-buffer #f 0 0 0 0 0 0 0 0)
+	    (send main-buffer set-max-undo-history 0)
+	    (send main-buffer hide-caret #t)
+	    (send main-buffer insert arrow)
+	    (when title (send title-buffer insert title))
+	    (when content (send content-buffer insert content))
+	    (send main-buffer insert title-snip)
+	    (send main-buffer change-style (make-object style-delta% 'change-alignment 'top) 0 2))))
+
+      (define list-keymap (make-object keymap%))
+
+      (send list-keymap add-function "select-in"
+	    (lambda (list event) (send list select-in)))
+      (send list-keymap add-function "select-out"
+	    (lambda (list event) (send list select-out)))
+      (send list-keymap add-function "select-prev"
+	    (lambda (list event) (send list select-prev)))
+      (send list-keymap add-function "select-next"
+	    (lambda (list event) (send list select-next)))
+      (send list-keymap add-function "select-first"
+	    (lambda (list event) (send list select-first)))
+      (send list-keymap add-function "select-last"
+	    (lambda (list event) (send list select-last)))
+      (send list-keymap add-function "page-up"
+	    (lambda (list event) (send list page-up)))
+      (send list-keymap add-function "page-down"
+	    (lambda (list event) (send list page-down)))
+
+      (send list-keymap map-function "right" "select-in")
+      (send list-keymap map-function "left" "select-out")
+      (send list-keymap map-function "up" "select-prev")
+      (send list-keymap map-function "down" "select-next")
+      (send list-keymap map-function "home" "select-first")
+      (send list-keymap map-function "end" "select-last")
+      (send list-keymap map-function "pageup" "page-up")
+      (send list-keymap map-function "pagedown" "page-down")
+
+      (send list-keymap add-function "toggle-open/closed"
+	    (lambda (list event) (send list toggle-open/closed)))
+      (send list-keymap map-function "return" "toggle-open/closed")
+
+      (define hierarchical-list%
+	(class100 editor-canvas% (parent [style '(no-hscroll)])
+          (inherit min-width min-height allow-tab-exit)
+          (rename [super-on-char on-char]
+                  [super-on-focus on-focus])
+          (public
+            [selectable
+             (case-lambda
+              [() selectable?]
+              [(on?) (set! selectable? on?)])]
+            [get-selected (lambda () selected-item)]
+            [on-item-opened (lambda (i) (void))]
+            [on-item-closed (lambda (i) (void))]
+            [on-double-select (lambda (i) (void))]
+            [on-select (lambda (i) (void))]
+            [on-click (lambda (i) (void))]
+            [new-item (lambda x (send top-buffer new-item . x))]
+            [set-no-sublists (lambda x (send top-buffer set-no-sublists . x))]
+            [new-list (lambda x (send top-buffer new-list . x))]
+            [delete-item (lambda (i) (send top-buffer delete-item i))]
+            [sort (lambda (less-than?) (send top-buffer sort less-than?))]
+            [get-items (lambda () (send top-buffer get-items))]
+            [toggle-open/closed
+             (lambda ()
+               (cond
+                 [(and selected (is-a? selected hierarchical-list-snip%))
+                  (send selected toggle-open/closed)]
+                 [else
+                  (void)]))]
+            [select-out (lambda () 
+                          (when selected
+                            (let* ([parent-snip (send (send selected get-parent) get-parent-snip)])
+                              (cond
+                                [parent-snip
+                                 (let ([parent (send parent-snip get-item)])
+                                   (when (send parent get-allow-selection?)
+                                     (send parent select #t)
+                                     (send parent scroll-to)))]
+                                [else
+                                 (void)]))))]
+            [select-in (lambda () 
+                         (cond
+                           [(and selected (is-a? selected hierarchical-list-snip%)) 
+                            (let ([edit-sequence-text (send selected get-editor)])
+                              (send edit-sequence-text begin-edit-sequence)
+                              (send selected open)
+                              (let ([items (send selected-item get-items)])
+                                (unless (null? items)
+                                  (send (car items) select #t)
+                                  (send (car items) scroll-to)))
+                              (send edit-sequence-text end-edit-sequence))]
+                           [else (void)]))]
+            [select-next (lambda () (move +1))]
+            [select-prev (lambda () (move -1))]
+            [select-first (lambda () (let ([l (get-items)])
+                                       (unless (null? l)
+                                         (send (car l) select #t)
+                                         (send (car l) scroll-to))))]
+            [select-last (lambda () (let loop ([l (get-items)])
+                                      (cond
+                                        [(null? l) (void)]
+                                        [(null? (cdr l))
+                                         (send (car l) select #t)
+                                         (send (car l) scroll-to)]
+                                        [else (loop (cdr l))])))]
+	    [select (lambda (i) 
+		      (send i select #t)
+		      (send i scroll-to))]
+            [page-up (lambda () (page 'up))]
+            [page-down (lambda () (page 'down))]
+            [show-focus
+             (case-lambda
+              [() show-focus?]
+              [(on?) (set! show-focus? on?)])]
+	    [can-do-edit-operation? (opt-lambda (x [r? #t]) #f)]
+	    [do-edit-operation (opt-lambda (x [r? #t] [time 0]) (void))])
+	  (public ;; ---- local to this module! ----
+	    [ensure-not-selected (lambda (i)
+				   (when (eq? i selected)
+				     (set! selected #f))
+				   (when (eq? i selected-item)
+				     (set! selected-item #f)))])
+          (override
+            [on-char
+             (lambda (e)
+               (unless (send list-keymap handle-key-event this e)
+                 (super-on-char e)))]
+            [on-size
+             (lambda (w h)
+               (send top-buffer begin-edit-sequence)
+               (send top-buffer reflow-items)
+               (send top-buffer end-edit-sequence))]
+            [on-focus
+             (lambda (on?)
+               (when (and selected show-focus?)
+                 (send selected show-select #t))
+               (super-on-focus on?))])
+          (private
+            [move (lambda (dir) 
+                    (define (find i l)
+                      (let loop ([l l][pos 0])
+                        (if (null? l)
+                            #f
+                            (if (eq? (car l) i)
+                                pos
+                                (loop (cdr l) (add1 pos))))))
+                    (define (find-next-selectable-item i vec)
+                      (let loop ([pos (+ i dir)])
+                        (cond
+                          [(= pos -1)
+                           i]
+                          [(= pos (vector-length vec))
+                           i]
+                          [(send (vector-ref vec pos) get-allow-selection?)
+                           pos]
+                          [else (loop (+ pos dir))])))
+                    ;; Scrolling works differently depending on whether selections
+                    ;;  are involved:
+                    (if selectable?
+                        (let* ([l (if selected
+                                      (send (send selected get-parent) get-items)
+                                      (get-items))]
+                               [vec (list->vector l)]
+                               [pos (let ([found (find selected-item l)])
+                                      (if (and selected-item found)
+                                          (find-next-selectable-item found vec)
+                                          (if (negative? dir)
+                                              (sub1 (length l))
+                                              0)))])
+                          (when (< -1 pos (length l))
+                            (let ([i (vector-ref vec pos)])
+                              (when (send i get-allow-selection?)
+                                (send i select #t)
+                                (send i scroll-to)))))
+                        (let ([y-box (box 0.0)]
+                              [x-box (box 0.0)]
+                              [w-box (box 0.0)]
+                              [h-box (box 0.0)])
+                          (send (send top-buffer get-admin) get-view x-box y-box w-box h-box)
+                          (let ([y (if (negative? dir)
+                                       (- (unbox y-box) 2)
+                                       (+ (unbox y-box) (unbox h-box) 1))])
+                            (send (send top-buffer get-admin) scroll-to
+                                  (unbox x-box) y
+                                  (unbox w-box) 1)))))]
+            [page (lambda (dir)
+                    ;; Scrolling works differently depending on whether selections
+                    ;;  are involved:
+                    (if selectable?
+                        (let ([items (get-items)])
+                          (unless (null? items)
+                            (let ([sbox (box 0)]
+                                  [ebox (box 0)])
+                              (send top-buffer get-visible-line-range sbox ebox)
+                              (let* ([len (max 1 (sub1 (- (unbox ebox) (unbox sbox))))]
+                                     [l (if (eq? dir 'up)
+                                            (max 0 (- (unbox sbox) len))
+                                            (min (sub1 (length items)) (+ (unbox ebox) len)))]
+                                     [i (list-ref items l)])
+                                (send i select #t)
+                                (send i scroll-to)))))
+                        (send top-buffer move-position dir #f 'page)))])
+          (private-field
+           [selectable? #t]
+           [show-focus? #f])
+          (private
+            [do-select (lambda (item s)
+                         (cond
+                           [(and selectable?
+                                 item 
+                                 (send item get-allow-selection?))
+                            (unless (eq? item selected-item)
+                              (when selected (send selected show-select #f))
+                              (set! selected (if item s #f))
+                              (set! selected-item item)
+                              (when selected (send selected show-select #t))
+                              (on-select item))]
+                           [item
+                            (on-click item)]))])
+          (private-field
+           [top-buffer (make-object hierarchical-list-text% this (lambda (i s) (do-select i s)) 0 #f)]
+           [selected #f]
+           [selected-item #f])
+          (sequence
+            (super-init parent top-buffer style)
+	    (allow-tab-exit #t)
+            (send top-buffer set-cursor arrow-cursor) 
+            (min-width 150)
+            (min-height 200)))))))
diff --git a/collects/hierlist/hierlist.ss b/collects/hierlist/hierlist.ss
new file mode 100644
index 0000000000..d817ad5f7c
--- /dev/null
+++ b/collects/hierlist/hierlist.ss
@@ -0,0 +1,71 @@
+
+(module hierlist mzscheme
+  (require (lib "unitsig.ss")
+	  (lib "mred-sig.ss" "mred")
+	  (lib "mred.ss" "mred"))
+
+  (require "hierlist-sig.ss"
+	  "hierlist-unit.ss")
+
+
+  (define-values/invoke-unit/sig hierlist^
+    hierlist@
+    #f
+    mred^)
+
+  (provide-signature-elements hierlist^))
+
+#|
+
+;; Testing
+(define f (make-object frame% "test"))
+(define p (make-object horizontal-panel% f))
+(define c (make-object (class hierarchical-list% args
+			 (override
+			   [on-item-opened
+			    (lambda (i)
+			      (let ([f (send i user-data)])
+				(when f (f i))))]
+			   [on-select
+			    (lambda (i)
+			      (printf "Selected: ~a~n"
+				      (if i 
+					  (send (send i get-editor) get-flattened-text)
+					  i)))]
+			   [on-double-select
+			    (lambda (s)
+			      (printf "Double-click: ~a~n"
+				      (send (send s get-editor) get-flattened-text)))])
+			 (sequence (apply super-init args)))
+		       p))
+
+(define a (send c new-list))
+(send (send a get-editor) insert "First Item: List")
+(send (send (send a new-item) get-editor) insert "Sub1")
+(send (send (send a new-item) get-editor) insert "Sub2")
+(define a.1 (send a new-list))
+(send (send a.1 get-editor) insert "Deeper List")
+(send (send (send a.1 new-item) get-editor) insert "Way Down")
+
+(define b (send c new-item))
+(send (send b get-editor) insert "Second Item")
+
+(define d (send c new-list))
+(send (send d get-editor) insert "dynamic")
+(send d user-data (lambda (d)
+		    (time (let loop ([i 30])
+			    (unless (zero? i)
+				    (send (send (send d new-item) get-editor) insert (number->string i))
+				    (loop (sub1 i)))))))
+
+(define x (send c new-list))
+(send (send x get-editor) insert "x")
+
+(define y (send c new-item))
+(send (send y get-editor) insert "y")
+
+(send f show #t)
+
+(yield (make-semaphore))
+
+|#
diff --git a/collects/hierlist/info.ss b/collects/hierlist/info.ss
new file mode 100644
index 0000000000..299523d8bb
--- /dev/null
+++ b/collects/hierlist/info.ss
@@ -0,0 +1,4 @@
+
+(module info (lib "infotab.ss" "setup")
+  (define doc.txt "doc.txt")
+  (define name "Hierarchical list widget"))
diff --git a/collects/honu-module/doc.txt b/collects/honu-module/doc.txt
new file mode 100644
index 0000000000..96a1054526
--- /dev/null
+++ b/collects/honu-module/doc.txt
@@ -0,0 +1,49 @@
+
+>>> FOR NOW, THIS IS AN EXPERIMENTAL TOY <<<
+    > Everything is subject to change. <
+
+Write a dynamically typed Honu program as
+
+ #honu dynamic
+
+ <defn-or-provide>
+ ...
+
+The syntax of a definition is much like Java, and type positions in
+Java are roughly contract positions in dynamic Honu.
+
+The only supported base "types" right now are
+
+    int     - exact integer
+    obj     - anything
+    string  - character string
+
+and the only "type constructor" is
+
+    (_ -> _)
+
+where "_" is to be replaced with a "type". [Ok, "->" is not very Java
+like...]
+
+Every declaration must have a value, like this:
+
+  #honu dynamic
+
+  int v = 10;
+
+  int f(int x) {
+    return x + 1;
+  }
+
+  (int -> int) g() {
+    return f;
+  }
+
+  provide f, g;
+
+The "return" keyword is optional, but allowed only for expressions in
+tail position.
+
+Assignment: =
+Operators: + - * / %
+Functions: stringToNumber numberToString
diff --git a/collects/honu-module/dynamic.ss b/collects/honu-module/dynamic.ss
new file mode 100644
index 0000000000..c57477ec4f
--- /dev/null
+++ b/collects/honu-module/dynamic.ss
@@ -0,0 +1,1007 @@
+(module dynamic mzscheme
+
+  (require-for-syntax (lib "stx.ss" "syntax")
+		      "private/ops.ss"
+		      "private/util.ss"
+		      (lib "kerncase.ss" "syntax"))
+  
+  (begin-for-syntax
+
+   (define kernel-forms (kernel-form-identifier-list #'here))
+
+   (define (top-block-context? ctx) (memq ctx '(top-block)))
+   (define (return-block-context? ctx) (memq ctx '(return-block)))
+   (define (block-context? ctx) (memq ctx '(top-block block return-block)))
+   (define (expression-context? ctx) (memq ctx '(expression)))
+   (define (type-context? ctx) (memq ctx '(type)))
+
+   (define block-context 'block)
+   (define return-block-context 'return-block)
+   (define top-block-context 'top-block)
+   (define expression-context 'expression)
+   (define type-context 'type)
+
+   ;; --------------------------------------------------------
+   ;; Transformer procedure property and basic struct
+
+   (define-values (prop:honu-transformer honu-transformer? honu-transformer-ref)
+     (make-struct-type-property 'honu-transformer))
+
+
+   (define-values (struct:honu-trans make-honu-trans honu-trans? honu-trans-ref honu-trans-set!)
+     (make-struct-type 'honu-trans #f 1 0 #f 
+		       (list (list prop:honu-transformer #t))
+		       (current-inspector) 0))
+
+   (define (make-honu-transformer proc)
+     (unless (and (procedure? proc)
+		  (procedure-arity-includes? proc 2))
+       (raise-type-error
+	'define-honu-syntax
+	"procedure (arity 2)"
+	proc))
+     (make-honu-trans proc))
+
+   ;; --------------------------------------------------------
+   ;; Type
+
+   (define-values (struct:honu-type make-h-type honu-type? honu-type-ref honu-type-set!)
+     (make-struct-type 'honu-type #f 3 0 #f null (current-inspector) 0))
+
+   (define (honu-type-stx v) (honu-type-ref v 0))
+   (define (honu-type-pred-def-stx v) (honu-type-ref v 1))
+   (define (honu-type-pred-stx v) (honu-type-ref v 2))
+
+   ;; --------------------------------------------------------
+   ;; Parsing blocks
+
+   (define operator? 
+     (let ([sym-chars (string->list "+-_=?:<>.!%^&*/~|")])
+       (lambda (stx)
+	 (and (identifier? stx)
+	      (let ([str (symbol->string (syntax-e stx))])
+		(and (positive? (string-length str))
+		     (memq (string-ref str 0) sym-chars)))))))
+   
+   (define (get-transformer stx)
+     (or (and (stx-pair? stx)
+	      (identifier? (stx-car stx))
+	      (let ([v (syntax-local-value (stx-car stx) (lambda () #f))])
+		(and (honu-transformer? v) v)))
+	 (and (stx-pair? stx)
+	      (let ([first (stx-car stx)])
+		(and (stx-pair? first)
+		     (identifier? (stx-car first))
+		     (module-identifier=? #'#%parens (stx-car first))
+		     ;; If the stx-car is a list with just one operator symbol,
+		     ;;  try using the operator as a transformer
+		     (let ([l (cdr (stx->list first))])
+		       (let loop ([l l])
+			 (cond
+			  [(null? l) #f]
+			  [(operator? (car l))
+			   (if (ormap operator? (cdr l))
+			       #f
+			       (let ([v (syntax-local-value (car l) (lambda () #f))])
+				 (and (honu-transformer? v)
+				      v)))]
+			  [else (loop (cdr l))]))))))))
+   
+   ;; --------------------------------------------------------
+   ;; Parsing blocks
+
+   (define parse-an-expr #f)
+   (define parse-a-tail-expr #f)
+
+   (define (parse-block-one ctx body k done-k)
+     (cond
+      [(stx-null? body) (done-k)]
+      [(get-transformer body)
+       => (lambda (transformer)
+	    (let-values ([(code rest) (transformer body ctx)])
+	      (k code rest)))]
+      [(syntax-case body (#%braces) 
+	 [((#%braces . block) . rest) (cons #'block #'rest)]
+	 [_else #f])
+       => (lambda (b+r)
+	    (k #`(honu-unparsed-block #f void-type #f #,(return-block-context? ctx)
+				      #,@(car b+r))
+	       (cdr b+r)))]
+      [else (let-values ([(expr-stxs after-expr) (extract-until body (list #'\;))])
+	      (unless expr-stxs
+		(raise-syntax-error
+		 #f
+		 "expected a semicolon to terminate form"
+		 (stx-car body)))
+	      (let ([code ((if (return-block-context? ctx)
+			       parse-a-tail-expr
+			       parse-an-expr)
+			   expr-stxs)])
+		(k code (stx-cdr after-expr))))]))
+   
+   (define (parse-block stx ctx)
+     (let loop ([stx stx])
+       (parse-block-one ctx
+			stx 
+			(lambda (code rest)
+			  (cons code (loop rest)))
+			(lambda ()
+			  null))))
+
+   ;; --------------------------------------------------------
+   ;; Parsing expressions
+
+   (define parse-expr
+     (let ()
+       (define (parse-expr-seq stx)
+	 (define (start-expr stx) 
+	   (let ([trans (get-transformer stx)])
+	     (if trans
+		 (let-values ([(expr rest) (trans stx expression-context)])
+		   (if (stx-null? rest)
+		       (list expr)
+		       (cons expr (start-operator rest))))
+		 (syntax-case stx (#%parens #%braces)
+		   [(v)
+		    (or (number? (syntax-e #'v))
+			(identifier? #'v)
+			(string? (syntax-e #'v)))
+		    (if (operator? #'v)
+			(raise-syntax-error
+			 #f
+			 "operator alone is not an expression"
+			 #'v)
+			(list #'v))]
+		   [((#%parens . pexpr))
+		    (if (stx-null? #'pexpr)
+			(raise-syntax-error
+			 #f
+			 "missing expression inside parentheses"
+			 (stx-car stx))
+			(list (parse-expr #'pexpr)))]
+		   [((#%braces . pexpr))
+		    (if (stx-null? #'pexpr)
+			(raise-syntax-error
+			 #f
+			 "missing expression inside braces"
+			 (stx-car stx))
+			(list #'(honu-unparsed-block #f void-type #f #f . pexpr)))]
+		   [(op . more)
+		    (and (identifier? #'op)
+			 (ormap (lambda (uop)
+				  (module-identifier=? #'op uop))
+				unary-prefix-ops))
+		    (cons (make-prefix (stx-car stx)) (start-expr #'more))]
+		   [(expr then . more)
+		    (append (start-expr (list #'expr))
+			    (start-operator #'(then . more)))]
+		   [(bad . rest)
+		    (raise-syntax-error
+		     'expression
+		     "unknown expression form"
+		     #'bad)]))))
+	 (define (start-operator stx)
+	   (unless (or (and (stx-pair? (stx-car stx))
+			    (or (module-identifier=? #'#%brackets (stx-car (stx-car stx)))
+				(module-identifier=? #'#%parens (stx-car (stx-car stx)))))
+		       (and (identifier? (stx-car stx))
+			    (hash-table-get op-table
+					    (syntax-e (stx-car stx))
+					    (lambda () #f))))
+	     (raise-syntax-error
+	      'expression
+	      "expected an operator, but found something else"
+	      (stx-car stx)))
+	   ;; Check for postfix operator, first
+	   (cond
+	    [(stx-pair? (stx-car stx))
+	     ;; Convert vector index or application to a binary operator:
+	     (let ([opl (if (module-identifier=? #'#%brackets (stx-car (stx-car stx)))
+			    (let ([index-expr (parse-expr (stx-cdr (stx-car stx)))])
+			      (list (make-infix (stx-car (stx-car stx)))
+				    index-expr))
+			    (let ([arg-exprs (parse-arg-list (stx-cdr (stx-car stx)))])
+			      (list (make-infix (stx-car (stx-car stx)))
+				    arg-exprs)))])
+	       (if (stx-null? (stx-cdr stx))
+		   opl
+		   (append opl (start-operator (stx-cdr stx)))))]
+	    [(or (module-identifier=? #'++ (stx-car stx))
+		 (module-identifier=? #'-- (stx-car stx)))
+	     (if (null? (stx-cdr stx))
+		 (list (make-postfix (stx-car stx)))
+		 (cons (make-postfix (stx-car stx))
+		       (start-operator (stx-cdr stx))))]
+	    [else
+	     ;; Otherwise, must be infix
+	     (cons (make-infix (stx-car stx))
+		   (start-expr (stx-cdr stx)))]))
+	 (start-expr stx))
+
+       (define (parse-expr stx)
+         (let group ([seq (parse-expr-seq stx)])
+	   ;; seq is a list that mixes exprs with ops.
+	   ;; Find leftmost oper with maximal precedence
+	   (if (null? (cdr seq))
+	       (car seq)
+	       (let loop ([seq seq][before null][op #f][since null])
+		 (cond
+		  [(null? seq)
+		   (cond
+		    [(prefix? op)
+		     (group (append (reverse (cdr before))
+				    (list (quasisyntax/loc (op-id op)
+					    (#,(op-id op) #,(car before))))
+				    (reverse since)))]
+		    [(postfix? op)
+		     (let ([after (reverse since)])
+		       (group (append (reverse before)
+				      (list (quasisyntax/loc (op-id op)
+					      (#,(op-id op) #,(car after))))
+				      (cdr after))))]
+		    [(infix? op)
+		     (let ([after (reverse since)])
+		       (group (append (reverse (cdr before))
+				      (list (quasisyntax/loc (op-id op)
+					      (#,(op-id op) #,(car before) #,(car after))))
+				      (cdr after))))]
+		    [else (error "not an op!: " op)])]
+		  [(not (op? (stx-car seq)))
+		   (loop (cdr seq) before op (cons (car seq) since))]
+		  [(> (hash-table-get precedence-table (prec-key (car seq)) (lambda () 0))
+		      (hash-table-get precedence-table (prec-key op) (lambda () 0)))
+		   (loop (cdr seq) 
+			 (if op
+			     (append since (list op) before)
+			     since)
+			 (car seq) null)]
+		  [else
+		   (loop (cdr seq) before op (cons (car seq) since))])))))
+
+       (define (parse-arg-list stxs)
+	 (if (stx-null? stxs)
+	     stxs
+	     (let-values ([(val-stxs after-expr) (extract-until stxs (list #'\,))])
+	       (when (and val-stxs
+			  (stx-null? (stx-cdr after-expr)))
+		 (raise-syntax-error
+		  'procedure\ call
+		  "missing expression after comma"
+		  (stx-car after-expr)))
+	       (when (null? val-stxs)
+		 (raise-syntax-error
+		  'procedure\ call
+		  "missing expression before token"
+		  (stx-car after-expr)))
+	       (if val-stxs
+		   (cons (parse-expr val-stxs)
+			 (parse-arg-list (stx-cdr after-expr)))
+		   (list (parse-expr stxs))))))
+       
+       parse-expr))
+
+   (define (parse-tail-expr expr-stxs)
+     (syntax-case expr-stxs (honu-return #%parens)
+       [(honu-return expr ...)
+	(let ([exprs #'(expr ...)])
+	  (when (stx-null? exprs)
+	    (raise-syntax-error 
+	     #f
+	     "missing expression"
+	     (stx-car expr-stxs)))
+	  (parse-expr exprs))]
+       [((#%parens expr0 expr ...))
+	(let ([exprs #'(expr0 expr ...)])
+	  (parse-tail-expr exprs))]
+       [_else
+	(parse-expr expr-stxs)]))
+
+   (set! parse-an-expr parse-expr)
+   (set! parse-a-tail-expr parse-tail-expr)
+
+   ;; --------------------------------------------------------
+   ;; Parsing declarations (which always start with a type)
+
+   (define (parse-one-argument proc-id type id k)
+     (cons (list id 
+		 (honu-type-stx type)
+		 (honu-type-pred-def-stx type)
+		 (honu-type-pred-stx type))
+	   (k)))
+
+   (define (parse-arguments orig-args-stx proc-id)
+     (if (stx-null? orig-args-stx)
+	 null
+	 (let loop ([args-stx orig-args-stx]
+		    [where "at start of argument sequence"]
+		    [where-stx orig-args-stx])
+	   (let ([trans (get-transformer args-stx)])
+	     (let-values ([(type rest-stx) (if trans
+					       (trans args-stx type-context)
+					       (values #f #f))])
+	       (unless (honu-type? type)
+		 (raise-syntax-error
+		  '|procedure declaration|
+		    (format "expected a type ~a" where)
+		    where-stx))
+	       (syntax-case rest-stx ()
+		 [(id)
+		  (identifier? #'id)
+		  (parse-one-argument proc-id type #'id
+				      (lambda () null))]
+		 [(id comma . rest)
+		  (and (identifier? #'id)
+		       (identifier? #'comma)
+		       (module-identifier=? #'comma #'\,))
+		  (parse-one-argument proc-id type #'id
+				      (lambda ()
+					(loop #'rest
+					      "after comma"
+					      #'comma)))]
+		 [(id something . rest)
+		  (identifier? #'id)
+		  (raise-syntax-error
+		   'procedure\ declaration
+		   "expected a comma after identifier name"
+		   #'something)]
+		 [_else
+		  (raise-syntax-error
+		   'procedure\ declaration
+		   "expected an argument identifier"
+		   (car rest-stx))]))))))
+   
+   (define (make-honu-type pred-id mk-pred-def)
+     (make-honu-trans
+      (lambda (orig-stx ctx)
+	(let* ([pred-id (or pred-id
+			    (car (generate-temporaries '(type-pred))))]
+	       [pred-def (if mk-pred-def
+			     (mk-pred-def pred-id orig-stx)
+			     #'(begin))])
+	  (cond
+	   [(block-context? ctx)
+	    (with-syntax ([pred-id pred-id]
+			  [type-name (stx-car orig-stx)])
+	      (let loop ([stx (stx-cdr orig-stx)]
+			 [after (stx-car orig-stx)]
+			 [after-what "type name"]
+			 [parens-ok? #t])
+		(syntax-case stx ()
+		  [(id . rest)
+		   (begin
+		     (unless (identifier? #'id)
+		       (raise-syntax-error 'declaration
+					   (format "expected a identifier after ~a" after-what)
+					   (stx-car orig-stx)
+					   #'id))
+		     (if (and (identifier? (stx-car #'rest))
+			      (module-identifier=? #'set! (stx-car #'rest)))
+			 ;; -- Non-procedure declaration
+			 (let-values ([(val-stxs after-expr) (extract-until (stx-cdr #'rest)
+									    (list #'\; #'\,))])
+			   (unless val-stxs
+			     (raise-syntax-error 
+			      'declaration
+			      "missing semicolon or comma after initializing assignment"
+			      (stx-car #'rest)))
+			   (when (null? val-stxs)
+			     (raise-syntax-error 
+			      'declaration
+			      "missing expression initializing assignment"
+			      (stx-car #'rest)))
+			   (let ([def #`(define-typed id #f type-name pred-id 
+					  (check-expr #f 'id type-name pred-id 
+						      (honu-unparsed-expr #,@val-stxs)))])
+			     (if (module-identifier=? #'\; (stx-car after-expr))
+				 (values #`(begin #,pred-def #,def) (stx-cdr after-expr))
+				 (let-values ([(defs remainder kind) (loop (stx-cdr after-expr) (stx-car after-expr) "comma" #f)])
+				   (values #`(begin #,pred-def #,def #,defs) remainder)))))
+			 ;; -- Procedure declaration
+			 (syntax-case #'rest (#%parens \;)
+			   [((#%parens . prest) (#%braces . body) . rest)
+			    parens-ok?
+			    (let ([args (parse-arguments #'prest #'id)])
+			      (with-syntax ([((arg arg-type arg-pred-def arg-pred-id) ...) args]
+					    [(temp-id ...) (generate-temporaries (map car args))])
+				(values #`(begin
+					    #,pred-def
+					    arg-pred-def ...
+					    (define-typed-procedure id 
+					      ((arg arg-type arg-pred-id) ...)
+					      (lambda (temp-id ...)
+						(define-typed arg id arg-type arg-pred-id temp-id) ...
+						(honu-unparsed-block id type-name pred-id #t . body))))
+					#'rest)))]
+			   ;; --- Error handling ---
+			   [((#%parens . prest) . bad-rest)
+			    parens-ok?
+			    (begin
+			      (parse-arguments #'prest #'id)
+			      (raise-syntax-error 
+			       '|procedure declaration|
+				 "braces for function body after parenthesized arguments"
+				 (stx-car #'rest)
+				 #'id))]
+			   [_else
+			    (raise-syntax-error 
+			     '|declaration|
+			       (if parens-ok?
+				   "expected either = (for variable intialization) or parens (for function arguments)"
+				   "expected = (for variable initialization)")
+			       #'id)])))]
+		  [_else
+		   (raise-syntax-error #f 
+				       (format "expected a identifier after ~a" after-what)
+				       after
+				       #'id)])))]
+	   [(type-context? ctx) 
+	    (values (make-h-type (stx-car orig-stx) pred-def pred-id) (stx-cdr orig-stx))]
+	   [(expression-context? ctx)
+	    (raise-syntax-error #f 
+				"illegal in an expression context"
+				(stx-car orig-stx))])))))
+
+   (define (make-proc-predicate name form)
+     ;; Form start with a operator-transformer sequence
+     (let-values ([(args-stx -> result-stx) 
+		   (let loop ([stx (stx-cdr (stx-car form))][args null])
+		     (if (and (identifier? (stx-car stx))
+			      (module-identifier=? #'-> (stx-car stx)))
+			 (values (reverse args) (stx-car stx) (stx-cdr stx))
+			 (loop (stx-cdr stx) (cons (stx-car stx) args))))])
+       (when (stx-null? result-stx)
+	 (raise-type-error
+	  #f
+	  "missing type for result"
+	  ->))
+       (let ([arg-types
+	      (let loop ([args-stx args-stx])
+		(if (stx-null? args-stx)
+		    null
+		    (let ([trans (get-transformer args-stx)])
+		      (unless trans
+			(raise-type-error '->
+					  "non-type within a procedure-type construction"
+					  (stx-car args-stx)))
+		      (let-values ([(type rest-stx) (trans args-stx type-context)])
+			(cons type (loop rest-stx))))))]
+	     [result-type 
+	      (let ([trans (get-transformer result-stx)])
+		(unless trans
+		  (raise-type-error '->
+				    "non-type in result position for procedure-type construction"
+				    (stx-car result-stx)))
+		(let-values ([(type rest-stx) (trans result-stx type-context)])
+		  (unless (stx-null? rest-stx)
+		    (raise-type-error '->
+				      "extra tokens following result for procedure-type construction"
+				      (stx-car rest-stx)))
+		  type))])
+	 (with-syntax ([(arg ...) (generate-temporaries arg-types)]
+		       [(arg-type ...) (map honu-type-stx arg-types)]
+		       [(arg-pred-def ...) (map honu-type-pred-def-stx arg-types)]
+		       [(arg-pred-id ...) (map honu-type-pred-stx arg-types)]
+		       [result-type (honu-type-stx result-type)]
+		       [result-pred-def (honu-type-pred-def-stx result-type)]
+		       [result-pred-id (honu-type-pred-stx result-type)]
+		       [n (length arg-types)])
+	   #`(begin
+	       arg-pred-def ...
+	       result-pred-def
+	       (define (#,name v)
+		 (if (and (procedure? v)
+			  (procedure-arity-includes? v n))
+		     (values #t (lambda (arg ...)
+				  (check-expr
+				   #f #t result-type result-pred-id
+				   (v (check-expr #f #f arg-type arg-pred-id arg) ...))))
+		     (values #f #f))))))))
+       
+   (define (compatible-type? val-expr val-type target-type)
+     (and (identifier? target-type)
+	  (identifier? val-type)
+	  (or (module-identifier=? val-type target-type)
+	      (module-identifier=? #'obj target-type)
+	      (and (number? (syntax-e val-expr))
+		   (module-identifier=? #'num target-type))
+	      (and (integer? (syntax-e val-expr))
+		   (exact? (syntax-e val-expr))
+		   (module-identifier=? #'int target-type))
+	      (and (string? (syntax-e val-expr))
+		   (module-identifier=? #'string-type target-type))))))
+      
+   (define (check proc who type-name pred val)
+     (let-values ([(tst new-val) (pred val)])
+       (unless tst
+	 (raise
+	  (make-exn:fail:contract
+	   (string->immutable-string
+	    (format "~a: expected ~a value for ~a, got something else: ~e"
+		    (or proc (if (eq? who #t) #f who) "procedure")
+		    type-name
+		    (cond
+		     [(eq? who #t) "result"]
+		     [else (if proc 
+			       (format "~a argument" who)
+			       (if who
+				   "initialization"
+				   "argument"))])
+		    val))
+	   (current-continuation-marks))))
+       new-val))
+
+  (define-syntax (check-expr stx)
+    (syntax-case stx ()
+      [(_ proc who type-name pred val)
+       ;; Avoid the check if the static types are consistent
+       (let ([v (local-expand
+		 #'val
+		 'expression
+		 (cons #'honu-typed
+		       kernel-forms))])
+	 (syntax-case v (honu-typed)
+	   [(honu-typed val val-type)
+	    (compatible-type? #'val #'val-type #'type-name)
+	    ;; No run-time check:
+	    #'val]
+	   [_else
+	    ;; Even without a type for v, we might see a literal,
+	    ;;  or maybe the declaration is simply obj
+	    (if (compatible-type? v #'obj #'type-name)
+		;; No run-time check:
+		#'val
+		;; Run-time check:
+		#'(check proc who 'type-name pred val))]))]))
+
+  (define-syntax (define-typed stx)
+    (syntax-case stx ()
+      [(_ id proc-name type-name pred-id val)
+       (with-syntax ([gen-id (car (generate-temporaries (list #'id)))])
+	 #'(begin
+	     (define gen-id val)
+	     (define-syntax id
+	       (make-set!-transformer
+		(lambda (stx)
+		  (syntax-case stx (set!)
+		    [(set! id rhs)
+		     #'(set! gen-id (check-expr set! id type-name pred-id rhs))]
+		    [(id arg (... ...))
+		     #'(#%app (honu-typed gen-id type-name) arg (... ...))]
+		    [id
+		     #'(honu-typed gen-id type-name)]))))))]))
+
+  (define-syntax (define-typed-procedure stx)
+    (syntax-case stx ()
+      [(_ id arg-spec val)
+       (with-syntax ([gen-id (car (generate-temporaries (list #'id)))])
+	 #'(begin
+	     (define gen-id val)
+	     (define-syntax id
+	       (with-syntax ([((arg arg-type pred-id) (... ...)) (quote-syntax arg-spec)])
+		 (make-set!-transformer
+		  (lambda (stx)
+		    (syntax-case stx (set!)
+		      [(set! id rhs)
+		       (raise-syntax-error #f
+					   "cannot assign to procedure name"
+					   stx
+					   #'id)]
+		      [(id actual-arg (... ...))
+		       (let ([actual-args (syntax->list #'(actual-arg (... ...)))]
+			     [formal-args (syntax->list #'(arg (... ...)))])
+			 (unless (= (length actual-args)
+				    (length formal-args))
+			   (raise-syntax-error
+			    'id
+			    (format "expects ~a arguments, provided ~a"
+				    (length formal-args)
+				    (length actual-args))
+			    stx))
+			 #'(#%app (honu-typed gen-id type-name) 
+				  (check-expr 'id 'arg arg-type pred-id actual-arg) 
+				  (... ...)))]
+		      [id
+		       #'(honu-typed (let ([id (lambda (arg (... ...))
+						 (id arg (... ...)))])
+				       id)
+				     type-name)])))))))]))
+
+  (define-syntax honu-typed
+    (syntax-rules ()
+      [(_ expr type) expr]))
+
+  (require-for-syntax (lib "context.ss" "syntax"))
+  (define-syntax (honu-block stx)
+    ;; A block can have mixed exprs and defns. Wrap expressions with
+    ;; `(define-values () ... (values))' as needed, and add a (void)
+    ;; at the end if needed. Also, wrap the final expression with
+    ;; a type check as needed.
+    (let ([proc-id (stx-car (stx-cdr stx))]
+	  [result-type-name (stx-car (stx-cdr (stx-cdr stx)))]
+	  [result-pred-id (stx-car (stx-cdr (stx-cdr (stx-cdr stx))))]
+	  [exprs (let loop ([exprs (cddddr (syntax->list stx))])
+		   (apply 
+		    append
+		    (map (lambda (expr)
+			   (let ([expr (local-expand
+					expr
+					(generate-expand-context)
+					kernel-forms)])
+			     (syntax-case expr (begin)
+			       [(begin . rest)
+				(loop (syntax->list #'rest))]
+			       [else
+				(list expr)])))
+			 exprs)))])
+      #`(let ()
+	  #,@(let loop ([exprs exprs][prev-defns null][prev-exprs null])
+	       (cond
+		[(null? exprs) (append 
+				(reverse prev-defns)
+				(if (and (pair? prev-exprs) 
+					 proc-id 
+					 (syntax-e proc-id))
+				    (reverse (cons
+					      #`(check-expr '#,proc-id #t
+							    #,result-type-name 
+							    #,result-pred-id 
+							    #,(car prev-exprs))
+					      (cdr prev-exprs)))
+				    (begin
+				      (unless (or (not proc-id)
+						  (not (syntax-e proc-id))
+						  (module-identifier=? #'type-name #'void-type))
+					(error "no expression for type check; should have been "
+					       "caught earlier"))
+				      (reverse prev-exprs)))
+				(if (null? prev-exprs)
+				    (list #'(void))
+				    null))]
+		[(and (stx-pair? (car exprs))
+		      (or (module-identifier=? #'define-values (stx-car (car exprs)))
+			  (module-identifier=? #'define-syntaxes (stx-car (car exprs)))))
+		 (loop (cdr exprs)
+		       (cons (car exprs)
+			     (append
+			      (map (lambda (expr)
+				     #`(define-values () (begin #,expr (values))))
+				   prev-exprs)
+			      prev-defns))
+		       null)]
+		[else
+		 (loop (cdr exprs) prev-defns (cons (car exprs) prev-exprs))])))))
+
+  (define-syntax (honu-unparsed-block stx)
+    (syntax-case stx (void)
+      [(_ proc-id result-type-name result-pred-id return-context? . body) 
+       #`(honu-block proc-id result-type-name result-pred-id #,@(parse-block 
+								 #'body
+								 (if (syntax-e #'return-context?)
+								     return-block-context
+								     block-context)))]))
+
+  (define-syntax (honu-unparsed-expr stx)
+    (syntax-case stx ()
+      [(_ v ...) (parse-expr (syntax->list #'(v ...)))]))
+
+  (define-syntax (h-return stx)
+    (syntax-case stx ()
+      [(_ expr) #'expr]))
+
+  (define-syntax (#%parens stx)
+    (syntax-case stx ()
+      [(_ rator (rand ...)) (syntax/loc #'rator (rator rand ...))]))
+
+  ;; --------------------------------------------------------
+  ;; Defining a new transformer or new type
+
+  (require-for-syntax (lib "define.ss" "syntax"))
+  (define-syntax (define-honu-syntax stx)
+    (let-values ([(id rhs) (normalize-definition stx #'lambda #f)])
+      (with-syntax ([id id]
+		    [rhs rhs])
+	#'(define-syntax id (make-honu-transformer rhs)))))
+
+  (define-syntax (define-type stx)
+    (syntax-case stx ()
+      [(_ id pred-expr)
+       (identifier? #'id)
+       (with-syntax ([pred-id (car (generate-temporaries '(pred)))])
+	 #'(begin
+	     (define pred-id (let ([pred pred-expr])
+				(lambda (v)
+				  (values (pred v) v))))
+	     (define-syntax id (make-honu-type #'pred-id #f))))]))
+
+  (define-syntax (define-type-constructor stx)
+    (syntax-case stx ()
+      [(_ id generator-expr)
+       (identifier? #'id)
+       #'(define-syntax id (make-honu-type #f generator-expr))]))
+
+  ;; ----------------------------------------
+  ;;  Pre-defined types and forms
+
+  (define (exact-integer? v)
+    (and (integer? v) (exact? v)))
+
+  (define-type int exact-integer?)
+  (define-type num number?)
+  (define-type obj (lambda (x) #t))
+  (define-type string-type string?)
+
+  (define-type-constructor -> make-proc-predicate)
+
+  (define-for-syntax parse-comma-separated
+    (lambda (body empty-case parse-one combine)
+      (syntax-case body (\;)
+	[(\;) (empty-case)]
+	[_else
+	 (let loop ([body body][accum null][prev-comma #f])
+	   (syntax-case body (\, \;)
+	     [(\, . rest)
+	      (let-values ([(one) (parse-one (reverse accum) prev-comma (stx-car body))]
+			   [(other rest) (loop #'rest null (stx-car body))])
+		(values (combine one other) rest))]
+	     [(\; . rest)
+	      (identifier? #'id)
+	      (values (parse-one (reverse accum) prev-comma (stx-car body)) #'rest)]
+	     [(x . rest)
+	      (loop #'rest (cons #'x accum) #f)]))])))
+
+  (define-honu-syntax honu-provide
+    (lambda (body ctx)
+      (unless (top-block-context? ctx)
+	(raise-syntax-error #f "not allowed outside the top level" (stx-car body)))
+      (parse-comma-separated
+       (stx-cdr body)
+       (lambda () #'(begin))
+       (lambda (stxes prev-comma-stx term-stx)
+	 (syntax-case stxes ()
+	   [(id)
+	    (identifier? #'id)
+	    #`(provide id)]
+	   [else
+	    (raise-syntax-error
+	     #f
+	     "unknown provide form"
+	     (stx-car body)
+	     (car stxes))]))
+       (lambda (p decls)
+	 #`(begin #,p #,decls)))))
+  
+  (define-honu-syntax honu-require
+    (lambda (body ctx)
+      (define (check-empty rest after-what)
+	(unless (stx-null? rest)
+	  (raise-syntax-error
+	   #f
+	   (format "expect a comma or semicolon after ~a" after-what)
+	   (stx-car body)
+	   (stx-car rest))))
+      (unless (top-block-context? ctx)
+	(raise-syntax-error #f "not allowed outside the top level" (stx-car body)))
+      (parse-comma-separated
+       (stx-cdr body)
+       (lambda () #'(begin))
+       (lambda (stxes prev-comma-stx term-stx)
+	 #`(require 
+	    #,(let ()
+		(define (parse-module-name stxes)
+		  (syntax-case stxes (lib file #%parens)
+		    [(fn . rest)
+		     (string? (syntax-e #'fn))
+		     (begin
+		       (check-empty #'rest "path string")
+		       #'fn)]
+		    [(lib (#%parens names ...) . rest)
+		     (let ([names (let loop ([names #'(names ...)])
+				    (syntax-case names (\,)
+				      [() null]
+				      [(name . rest)
+				       (begin
+					 (unless (string? (syntax-e #'name))
+					   (raise-syntax-error
+					    #f
+					    "expected a string for a library path"
+					    (car stxes)
+					    #'name))
+					 (syntax-case #'rest (\,)
+					   [() (list #'name)]
+					   [(\, . rest)
+					    (cons #'name (loop #'rest))]
+					   [else
+					    (raise-syntax-error
+					     #f
+					     "expected a comma"
+					     (stx-car stxes)
+					     (stx-car #'rest))]))]
+				      [(\,)
+				       (raise-syntax-error
+					#f
+					"expected a string before comma"
+					(car stxes)
+					(stx-car names))]
+				      [_else
+				       (raise-syntax-error
+					#f
+					"expected a string for a library path"
+					(car stxes)
+					(stx-car names))]))])
+		       (when (null? names)
+			 (raise-syntax-error
+			  #f
+			  "expected at least one string for the library path"
+			  (cadr stxes)))
+		       (check-empty #'rest "library path")
+		       (syntax-local-introduce #`(lib #,@names)))]
+		    [(lib . rest)
+		     (raise-syntax-error 
+		      #f
+		      "expected a parenthesized sequence of strings after `lib' keyword"
+		      (car stxes)
+		      (stx-car body))]
+		    [(file (#%parens name) . rest)
+		     (string? (syntax-e #'name))
+		     (begin
+		       (check-empty #'rest "file name")
+		       (syntax-local-introduce #`(file name)))]
+		    [(file . rest)
+		     (raise-syntax-error 
+		      #f
+		      "expected a parenthesized string after `file' keyword"
+		      (car stxes)
+		      (stx-car body))]
+		    [(fn)
+		     (identifier? #'fn)
+		     #'fn]
+		    [else
+		     (raise-syntax-error
+		      #f
+		      "unknown require form"
+		      (stx-car body)
+		      (car stxes))]))
+		(define (parse-module-spec stxes)
+		  (syntax-case stxes (rename #%parens \,)
+		    [(rename (#%parens spec0 spec ... \, local-id \, remote-id) . rest)
+		     (begin
+		       (unless (identifier? #'local-id)
+			 (raise-syntax-error
+			  #f
+			  "expected an identifier"
+			  (stx-car stxes)
+			  #'local-id))
+		       (unless (identifier? #'remote-id)
+			 (raise-syntax-error
+			  #f
+			  "expected an identifier"
+			  (stx-car stxes)
+			  #'remote-id))
+		       (begin0
+			#`(rename #,(parse-module-name 
+				     (syntax->list #'(spec0 spec ...))) 
+				  local-id 
+				  remote-id)
+			(check-empty #'rest "rename")))]
+		    [(rename . rest)
+		     (raise-syntax-error 
+		      #f
+		      "expected a parenthesized id, id, and require spec `rename' keyword"
+		      (car stxes)
+		      (stx-car body))]
+		    [_else (parse-module-name stxes)]))
+		(parse-module-spec stxes))))
+       (lambda (p decls)
+	 #`(begin #,p #,decls)))))
+
+  (define-honu-syntax honu-return
+    (lambda (stx ctx)
+      (unless (return-block-context? ctx)
+	(raise-syntax-error #f "allowed only in a tail position" (stx-car stx)))
+      (let-values ([(val-stxs after-expr) (extract-until (stx-cdr stx)
+							 (list #'\;))])
+	(unless val-stxs
+	  (raise-syntax-error 
+	   #f
+	   "missing semicolon"
+	   (stx-car stx)))
+	(when (null? val-stxs)
+	  (raise-syntax-error 
+	   #f
+	   "missing expression"
+	   (stx-car stx)))
+	(with-syntax ([expr (parse-expr val-stxs)])
+	  (unless (stx-null? (stx-cdr after-expr))
+	    (raise-syntax-error 
+	     #f
+	     "not at a block end"
+	     (stx-car stx)))
+	  (values
+	   (syntax/loc (stx-car stx)
+	     (h-return expr))
+	   null)))))
+
+  (define-honu-syntax honu-if
+    (lambda (stx ctx)
+      (define (get-block-or-statement kw rest)
+	(syntax-case rest (#%braces)
+	  [((#%braces then ...) . rest)
+	   (values #`(honu-unparsed-block #f void-type #f #,(return-block-context? ctx) then ...)
+		   #'rest)]
+	  [else
+	   (let-values ([(val-stxs rest) (extract-until rest
+							(list #'\;))])
+	     (unless val-stxs
+	       (raise-syntax-error
+		#f
+		"expected a braced block or a terminating semicolon"
+		kw))
+	     (when (null? val-stxs)
+	       (raise-syntax-error
+		#f
+		"expected an expression before semicolon"
+		kw
+		(stx-car rest)))
+	     (if (return-block-context? ctx)
+		 (values (parse-tail-expr val-stxs) (stx-cdr rest))
+		 (values (parse-expr val-stxs) (stx-cdr rest))))]))
+
+      (syntax-case stx (#%parens)
+	[(_ (#%parens test ...) . rest)
+	 (let ([test-expr (parse-expr (syntax->list #'(test ...)))])
+	   (let-values ([(then-expr rest) (get-block-or-statement (stx-car stx) #'rest)])
+	     (syntax-case rest (else)
+	       [(else . rest2)
+		(let-values ([(else-expr rest) (get-block-or-statement (stx-car rest) #'rest2)])
+		  (values #`(if #,test-expr #,then-expr #,else-expr)
+			  rest))]
+	       [_else
+		(values #`(if #,test-expr #,then-expr) rest)])))]
+	[_else
+	 (raise-syntax-error
+	  #f
+	  "expected a parenthesized test after `if' keyword"
+	  (stx-car stx))])))
+
+  ;; ----------------------------------------
+  ;; Main compiler loop
+
+  (define-syntax (honu-unparsed-begin stx)
+    (syntax-case stx ()
+      [(_) #'(begin)]
+      [(_ . body) (let-values ([(code rest) (parse-block-one top-block-context
+							     #'body 
+							     values
+							     (lambda ()
+							       (values #'(void) null)))])
+		    #`(begin
+			#,code
+			(honu-unparsed-begin #,@rest)))]))
+
+  (define-syntax (#%dynamic-honu-module-begin stx)
+    #`(begin
+	#,(syntax-local-introduce #'(require (lib "dynamic.ss" "honu-module")))
+	(honu-unparsed-begin #,@(stx-cdr stx))))
+  
+  (define-syntax (\; stx) (raise-syntax-error '\; "out of context" stx))
+  
+  (define true #t)
+  (define false #f)
+
+  (provide int obj (rename string-type string) ->
+	   \;
+           (rename set! =)
+	   (rename honu-return return)
+	   (rename honu-if if)
+	   + - * / (rename modulo %)
+	   (rename string->number stringToNumber)
+	   (rename number->string numberToString)
+	   true false
+	   display write newline
+	   #%datum
+	   #%top
+	   #%parens
+	   #%dynamic-honu-module-begin
+	   define-honu-syntax
+           (rename honu-provide provide)
+           (rename honu-require require)))
diff --git a/collects/honu-module/honu-module.ss b/collects/honu-module/honu-module.ss
new file mode 100644
index 0000000000..bedfbf624e
--- /dev/null
+++ b/collects/honu-module/honu-module.ss
@@ -0,0 +1,23 @@
+(module honu-module mzscheme
+  (require (rename "dynamic.ss" #%dynamic-honu-module-begin #%dynamic-honu-module-begin))
+
+  (define-syntax (honu-module-begin stx)
+    (syntax-case stx (dynamic)
+      [(_ dynamic . body)
+       #`(#%module-begin
+	  (#%dynamic-honu-module-begin
+	   . body))]
+      [(_ other . body)
+       (identifier? #'other)
+       (raise-syntax-error
+	#f
+	"unknown Honu dialect"
+	#'other)]
+      [else
+       (raise-syntax-error
+	#f
+	"expected a Honu dialect name before module body"
+	stx)]))
+  
+  (provide (rename honu-module-begin #%module-begin)))
+
diff --git a/collects/honu-module/info.ss b/collects/honu-module/info.ss
new file mode 100644
index 0000000000..15e228c360
--- /dev/null
+++ b/collects/honu-module/info.ss
@@ -0,0 +1,5 @@
+
+(module info (lib "infotab.ss" "setup")
+  (define doc.txt "doc.txt")
+  (define name "Honu"))
+
diff --git a/collects/honu-module/private/ops.ss b/collects/honu-module/private/ops.ss
new file mode 100644
index 0000000000..d770cc2400
--- /dev/null
+++ b/collects/honu-module/private/ops.ss
@@ -0,0 +1,80 @@
+
+(module ops mzscheme
+  (provide unary-prefix-ops
+	   (struct op (id))
+	   (struct prefix ())
+	   (struct infix ())
+	   (struct postfix ())
+	   prec-key
+	   precedence-table
+	   op-table)
+
+  (define unary-prefix-ops (list #'++
+				 #'--
+				 #'+
+				 #'-
+				 #'!
+				 #'~))
+  
+  (define-struct op (id))
+  (define-struct (prefix op) ())
+  (define-struct (infix op) ())
+  (define-struct (postfix op) ())
+
+  (define (prec-key op)
+    (and op
+	 (cons (cond
+		[(prefix? op) 'pre]
+		[(infix? op) 'in]
+		[(postfix? op) 'post])
+	       (syntax-e (op-id op)))))
+  
+  (define precedence-table (make-immutable-hash-table
+			    '(((in . |.|) . 100)
+			      ((in . #%parens) . 100)
+			      ((in . #%brackets) . 100)
+			      ((post . ++) . 100)
+			      ((post . --) . 100)
+			      ((pre . ++) . 95)
+			      ((pre . --) . 95)
+			      ((pre . +) . 95)
+			      ((pre . -) . 95)
+			      ((pre . ~) . 95)
+			      ((pre . !) . 95)
+			      ((in . *) . 90)
+			      ((in . %) . 90)
+			      ((in . /) . 90)
+			      ((in . +) . 85)
+			      ((in . -) . 85)
+			      ((in . >>) . 80)
+			      ((in . <<) . 80)
+			      ((in . >>>) . 80)
+			      ((in . <) . 70)
+			      ((in . >) . 70)
+			      ((in . <=) . 70)
+			      ((in . >=) . 70)
+			      ((in . ==) . 60)
+			      ((in . !=) . 60)
+			      ((in . &) . 55)
+			      ((in . ^) . 50)
+			      ((in . \|) . 45)
+			      ((in . &&) . 40)
+			      ((in . \|\|) . 35)
+			      ((in . =) . 10)
+			      ((in . +=) . 10)
+			      ((in . -=) . 10)
+			      ((in . *=) . 10)
+			      ((in . /=) . 10)
+			      ((in . %=) . 10)
+			      ((in . &=) . 10)
+			      ((in . ^=) . 10)
+			      ((in . \|=) . 10)
+			      ((in . <<=) . 10)
+			      ((in . >>=) . 10)
+			      ((in . >>>=) . 10))
+			    'equal))
+
+(define op-table (make-hash-table))
+(hash-table-for-each precedence-table (lambda (k v)
+					(hash-table-put! op-table (cdr k) #t))))
+
diff --git a/collects/honu-module/private/util.ss b/collects/honu-module/private/util.ss
new file mode 100644
index 0000000000..7bf4d00520
--- /dev/null
+++ b/collects/honu-module/private/util.ss
@@ -0,0 +1,19 @@
+
+(module util mzscheme
+  (provide extract-until)
+
+  (require (lib "stx.ss" "syntax"))
+
+  (define (extract-until r ids)
+     (let loop ([r r][val-stxs null])
+       (cond
+	[(stx-null? r)
+	 (values #f #f)]
+	[(and (identifier? (stx-car r))
+	      (ormap (lambda (id)
+		       (module-identifier=? id (stx-car r)))
+		     ids))
+	 (values (reverse val-stxs) r)]
+	[else
+	 (loop (stx-cdr r) (cons (stx-car r) val-stxs))]))))
+     
diff --git a/collects/honu/ast.ss b/collects/honu/ast.ss
new file mode 100644
index 0000000000..b81526c2ce
--- /dev/null
+++ b/collects/honu/ast.ss
@@ -0,0 +1,67 @@
+(module ast mzscheme
+  
+  (provide (all-defined))
+  
+  (define-struct honu-program (defns))
+  
+  (define-struct honu-ast (src-stx))
+   
+  (define-struct (honu-defn honu-ast) ())
+
+  (define-struct (honu-type honu-ast) ())
+
+  (define-struct (honu-prim-type honu-type) (name))
+  (define-struct (honu-func-type honu-type) (args return))
+  (define-struct (honu-dispatch-type honu-type) (dispatches args return))
+  (define-struct (honu-iface-type honu-type) (name))
+  (define-struct (honu-iface-bottom-type honu-type) ())
+  (define-struct (honu-iface-top-type honu-type) ())
+  (define-struct (honu-bottom-type honu-type) ())
+  (define-struct (honu-top-type honu-type) ())
+
+  (define-struct (honu-function honu-defn) (name type arg-names arg-types body))
+  (define-struct (honu-type-defn honu-defn)  (name supers decls))
+  (define-struct (honu-class honu-defn) (name type final? init-names init-types impls defns exports))
+  (define-struct (honu-mixin honu-defn) (name type arg-type final? init-names init-types impls with-names with-types
+                                          defns-before super-new defns-after exports))
+  (define-struct (honu-subclass honu-defn) (name mixin base))
+  
+  (define-struct (honu-field-decl honu-ast) (name type))
+  (define-struct (honu-method-decl honu-ast) (name type arg-types))
+   
+  (define-struct (honu-init-field honu-ast) (name type value))
+  (define-struct (honu-field honu-ast)      (name type value))
+  (define-struct (honu-method honu-ast)     (name type arg-names arg-types body))
+   
+  (define-struct (honu-super-new honu-ast)  (arg-names arg-vals))
+   
+  (define-struct (honu-export honu-ast)     (type old-names new-names))
+   
+  (define-struct (honu-exp honu-ast)        ())
+
+  (define-struct (honu-null   honu-exp) ())
+  (define-struct (honu-int    honu-exp) (value))
+  (define-struct (honu-float  honu-exp) (value))
+  (define-struct (honu-bool   honu-exp) (value))
+  (define-struct (honu-char   honu-exp) (value))
+  (define-struct (honu-str    honu-exp) (value))
+  (define-struct (honu-lambda honu-exp) (arg-names arg-types body))
+  (define-struct (honu-prim   honu-exp) (op op-stx op-type left right))
+  (define-struct (honu-uprim  honu-exp) (op op-stx op-type body))
+  (define-struct (honu-facc   honu-exp) (obj elab field))
+  (define-struct (honu-fassn  honu-exp) (obj elab field rhs))
+  (define-struct (honu-mcall  honu-exp) (obj elab method args))
+  (define-struct (honu-var    honu-exp) (name builtin?))
+  (define-struct (honu-assn   honu-exp) (name rhs))
+  (define-struct (honu-call   honu-exp) (name args builtin?))
+  (define-struct (honu-this   honu-exp) ())
+  (define-struct (honu-cast   honu-exp) (obj type))
+  (define-struct (honu-isa    honu-exp) (obj type))
+  (define-struct (honu-if     honu-exp) (cond true false))
+  (define-struct (honu-new    honu-exp) (class type arg-names arg-vals))
+  (define-struct (honu-while  honu-exp) (cond body))
+  (define-struct (honu-block  honu-exp) (binds exps))
+  (define-struct (honu-return honu-exp) (body))
+   
+  (define-struct (honu-binding honu-ast) (name type rhs))
+ ) 
diff --git a/collects/honu/base.ss b/collects/honu/base.ss
new file mode 100644
index 0000000000..930614effc
--- /dev/null
+++ b/collects/honu/base.ss
@@ -0,0 +1,62 @@
+(module base mzscheme
+
+  (require (lib "class.ss"))
+
+  (define (printStr s)
+    (display s))
+
+  (define (printLine s)
+    (display s)
+    (newline))
+  
+  (define (readChar)
+    (read-char))
+
+  (define (readLine)
+    (read-line))
+
+  (define (strToInt s)
+    (let ([number (string->number s)])
+      (if (and number (integer? number))
+          number
+          (error (format "Tried to convert \"~a\" to an integer" s)))))
+
+  (define (strToFloat s)
+    (let ([number (string->number s)])
+      (if (and number (inexact? number))
+          number
+          (error (format "Tried to convert \"~a\" to an float" s)))))
+
+  (define (intToStr i)
+    (number->string i))
+
+  (define (floatToStr f)
+    (number->string f))
+  
+  (define (charToStr c)
+    (string c))
+
+  (define (strLen s)
+    (string-length s))
+
+  (define (substr s start end)
+    (cond
+      [(< start 0)
+       (error (format "Start index for substr must be positive, got ~a" start))]
+      [(> start end)
+       (error (format "Start index (~a) must be <= end index (~a)" start end))]
+      [(> end (string-length s))
+       (error (format "End index for substr must be <= strLen(s), got ~a" end))]
+      [else (substring s start end)]))
+
+  (define (charAt s i)
+    (cond
+      [(< i 0)
+       (error (format "Index for charAt must be positive, got ~a" i))]
+      [(> i (- (string-length s) 1))
+       (error (format "Index for charAt must be < strLen(s), got ~a" i))]
+      [else (string-ref s i)]))
+
+  (provide (all-from mzscheme)
+           (all-from (lib "class.ss"))
+           (all-defined)))
diff --git a/collects/honu/compile.ss b/collects/honu/compile.ss
new file mode 100644
index 0000000000..c6508fd835
--- /dev/null
+++ b/collects/honu/compile.ss
@@ -0,0 +1,52 @@
+(module compile mzscheme
+ 
+  (require (lib "contract.ss"))
+ 
+  (require "ast.ss")
+  (require "tenv.ss")
+  (require "tenv-utils.ss")
+  (require "honu-compile-context.ss")
+  (require "private/compiler/honu-translate-utils.ss")
+  (require "private/compiler/honu-translate-program.ss")
+  (require "private/compiler/honu-translate-expression.ss")
+  (require "private/typechecker/honu-typecheck.ss")
+  (require "private/typechecker/honu-typecheck-exp.ss")
+  (require "read-error-with-stx.ss")
+  
+  (provide/contract [compile/complete-program
+                     (tenv? honu-program?
+                      . -> . 
+;                     (listof (syntax/c any/c))]
+                      list?)]
+                    [compile/interaction
+                     ((tenv? 
+                       any/c
+                       (union honu-binding? honu-exp?))
+                      . ->* . 
+;                     (listof (syntax/c any/c))]
+                      (any/c any/c))])
+  (define (compile/complete-program tenv pgm)
+    (add-defns-to-tenv (honu-program-defns pgm) tenv)
+    (let ([checked (honu-typecheck-program tenv pgm)])
+      (parameterize ([current-compile-context honu-compile-context])
+        (honu-translate-program tenv checked))))
+  
+  (define (compile/interaction tenv env ast)
+    (cond
+      [(honu-binding? ast)
+       (if (env (honu-binding-name ast))
+           (raise-read-error-with-stx
+            (format "~a already bound" (printable-key (honu-binding-name ast)))
+            (honu-binding-name ast))
+           (let-values ([(checked new-env)
+                         ((honu-typecheck-binding tenv #f) ast env)])
+             (parameterize ([current-compile-context honu-compile-context])
+               (values (honu-translate-binding tenv #f checked #t)
+                       new-env))))]
+      [(honu-exp? ast)
+       (let-values ([(checked type) ((honu-typecheck-exp tenv env #f) ast #f)])
+         (parameterize ([current-compile-context honu-compile-context])
+           (values (honu-translate-expression tenv #f checked)
+                   env)))]))
+  )
+    
diff --git a/collects/honu/doc.txt b/collects/honu/doc.txt
new file mode 100644
index 0000000000..b3602c540c
--- /dev/null
+++ b/collects/honu/doc.txt
@@ -0,0 +1,296 @@
+_Honu_
+
+_TODO_
+
+  * At the moment you can only apply method references or lexically
+    bound variables to arguments in order to invoke a function or
+    method.  The syntax will be reworked in the extremely near future
+    to allow application of arbitrary expressions (assuming they
+    result in a method or function type) to arguments.
+
+  > Rewrite TODO list in terms of interfaces (not implementations) 
+    The next bullet is a prime example. I have added a second bullet to
+    show what I mean. -- MF
+
+  * Fix up honu-mcall and honu-new in honu-typecheck-exp.ss to use
+    type context argument.
+  
+  * Admit statements as elements of mixin bodies, i.e., 
+
+     struct ExamplesC() : Examples {
+      IStack s0 = new StackC();
+      int d0 = s0.depth();
+      s0.push(s0);
+     }
+
+    should work. -- MF
+
+  * Work out details of standard library, including boxed versions of
+    primitive types.
+
+  * Let's use _string_ for _str_. (In principle we should probably use
+    String eventually, if it becomes a class.) 
+
+  * If you do have a standard library, document it please. -- MF 
+
+  * Let's add arrays. 
+
+  * Add new statement that uses positional initialization arguments.
+
+  * Add autoboxing of primitive types.
+
+  * Add generics (parametric polymorphism and bounded polymorphism).
+    RESEARCH! 
+
+_Primitive types_
+
+  int   - integers
+  float - floating point numbers
+  str   - strings    (double quoted)
+  bool  - booleans   (true, false)
+  char  - characters (single quoted)
+
+_Built-in functions_
+
+Error reporting:
+
+> error(str message) => 'a
+    - Raises an error and prints the string as an error message.
+    - Calls to error() do not return.
+
+Input/output:
+
+> printStr(str message) => void
+    - Takes a string and prints it on the standard output.
+
+> printLine(str message) => void
+    - Like printStr, but prints a newline after printing the string.
+
+> readChar() => char
+    - Reads a single character from the standard input.
+
+> readLine() => str
+    - Reads a line of text from the standard input.
+
+Conversions to string:
+
+> intToStr(int val) => str
+    - Converts an integer to a string.
+
+> floatToStr(float val) => str
+    - Converts a floating point number to a string.
+
+> charToStr(char val) => str
+    - Converts a character to a string.
+
+String conversions:
+
+> strToInt(str val) => int
+    - Converts a string to an integer.
+    - Raises an error if the string cannot be converted.
+
+> strToFloat(str val) => float
+    - Converts a string to a floating point number.
+    - Raises an error if the string cannot be converted.
+
+String operations:
+
+> strLen(str s) => int
+    - Takes a string and returns the string length.
+
+> substr(str s, int start, int end) => str
+    - Takes a string, a start index, and an end index and
+      returns the corresponding substring.
+    - The indexes are zero-based.
+    - The start index cannot be negative or greater than the end index.
+    - The end index must be less than or equal to the string length.
+
+> charAt(str s, int i) => char
+    - Takes a string and an index into the string and returns
+      the corresponding character.
+    - The zero-based index cannot be negative and must be less
+      than the string length.
+
+_Grammar_
+
+NOTE: Since I want to use parentheses to mean "real" parentheses, I use
+      square brackets for grouping inside of rules.
+
+<program>  ::= <defn>*
+
+<defn>     ::= <function>
+             | <type>
+             | <class>
+             | <mixin>
+             | <subclass>
+
+<function> ::= <tid> <id> ( <argdecls> ) <block>
+
+<type>     ::= type <id> <extends> { <mfdecl>* }
+             | interface <id> <extends> { <mfdecl>* }
+
+<tid>      ::= <ifacet>
+             | <primtype>
+             | <funtype>
+
+<funtype>  ::= [ <typetup> ] -> <tid>
+
+NOTE: The above are literal braces as opposed to the meta-braces.
+      This is the only place they occur right now.
+
+<typetup>  ::= <tid> [, <tid>]*
+             |
+
+<ifacet>   ::= id
+             | Any
+
+<primtype> ::= int
+             | float
+             | bool
+             | str
+             | char
+             | void
+
+<extends>  ::= extends <ifacet> [, <ifacet>]*
+             | <: <ifacet> [, <ifacet>]*
+             |
+
+<mfdecl>   ::= <tid> <fdid> ;
+             | <tid> <mdid> ( <argdecls>* ) ;
+
+<argdecls> ::= <argdecl> [, <argdecl>]*
+             |
+
+<argdecl>  ::= <tid>
+             | <tid> <varid>
+
+<struct>   ::= struct <id> <initargs> : <ifacet> <sctbody>
+             | final struct <id> <initargs> : <ifacet> <sctbody>
+
+<class>    ::= class <id> <initargs> : <ifacet> <impls> <clsbody>
+             | final class <initargs> <id> : <ifacet> <impls> <clsbody>
+
+<mixin>    ::= mixin <id> <initargs> : <ifacet> <argtype> <impls> <mixbody>
+             | final mixin <id> <initargs> : <ifacet> <argtype> <impls> <mixbody>
+
+<subclass> ::= subclass <id> = <id> ( <id> ) ;
+             | subclass <id> <initargs> : <ifacet> <scexts> <impls> <mixbody>
+             | final subclass <id> <initargs> : <ifacet> <scexts> <impls> <mixbody>
+
+<initargs> ::= ( <tid> <id> [, <tid> <id>]* )
+             | ( )
+
+<scexts>   ::= extends <id> <argtype>
+
+<argtype>  ::= at <ifacet>
+             | @ <ifacet>
+
+<impls>    ::= implements <ifacet> [, <ifacet>]*
+             | impl <ifacet> [, <ifacet>]*
+             |
+
+<sctbody>  ::= { <mfidefn>* }
+
+<clsbody>  ::= { <mfidefn>* <export>* }
+
+<mixbody>  ::= { <mfidefn>* <supernew> <mfidefn>* <export>* }
+
+<mfidefn>  ::= init <tid> <id> ;
+             | init <tid> <id> = <expr> ;
+             | <tid> <id> = <expr> ;
+             | <tid> <id> ( <argdefns> ) <block>
+
+<supernew> ::= super_new( <newargs> ) ;
+
+<argdefns> ::= <argdefn> [, <argdefn>]* 
+             |
+
+<argdefn>  ::= <tid> <id>
+
+<newargs>  ::= <newarg> [, <newarg>]*
+             |
+
+<newarg>   ::= <id> = <expr>
+
+<export>   ::= export <ifacet> : <renames> ;
+
+<renames>  ::= <rename> [, <rename>]*
+
+<rename>   ::= <id>
+             | <id> as <id>
+
+<expr>     ::= <literal>
+             | <lambda>
+             | <id>
+             | <id> = <expr>
+             | <id> ( <exprs-cd> )
+             | this
+             | <expr> : <ifacet>
+             | <expr> isa <ifacet>
+             | if <expr> <block> else <block>
+             | while <expr> <block>
+             | new <id> : <ifacet> ( <newargs> )
+             | new <id> ( <newargs> )
+             | ! <expr>
+             | - <expr>
+             | <expr> || <expr>
+             | <expr> && <expr>
+             | <expr> == <expr>
+             | <expr> != <expr>
+             | <expr> ==== <expr>
+             | <expr> < <expr>
+             | <expr> > <expr>
+             | <expr> <= <expr>
+             | <expr> >= <expr>
+             | <expr> + <expr>
+             | <expr> - <expr>
+             | <expr> * <expr>
+             | <expr> / <expr>
+             | <expr> % <expr>
+             | <expr> . <id>
+             | <expr> . <id> = <expr>
+             | <expr> . <id> ( <exprs-cd> )
+             | ( <expr> )
+             | <block>
+
+NOTE: Here's the precedence and associativity of things above.
+      Top is most strongly binding, bottom is least.  Things on
+      the same line have same precedence.  The : below refers to
+      casting, and the = is for assignment.  else requires a
+      precedence to avoid shift/reduce errors, even though we
+      don't have the dangling else problem.
+
+   LEFT   |   RIGHT  |  NONASSOC
+----------+----------+-----------
+    .     |          |
+          |  :  isa  |
+          |          | !, - (un)
+   * / %  |          |
+   +  -   |          |
+          |          | < <= > >=
+          |          |   ====
+  ==  !=  |          |
+    &&    |          |
+    ||    |          |
+    =     |          |
+   else   |          |
+
+<lambda>   ::= fun ( <argdecls> ) <block>
+
+<exprs-cd> ::= <expr> [, <expr>]*
+             | <expr>
+
+<literal>  ::= <intlit>
+             | <floatlit>
+             | true
+             | false
+             | <strlit>
+             | <charlit>
+
+<block>    ::= { <vardefn>* <expr-sc>+ }
+
+<vardefn>  ::= <tid> <id> = <expr> ;
+
+<expr-sc>  ::= <expr> ;
+             | return ;
+             | return <expr> ;
diff --git a/collects/honu/examples/Character.honu b/collects/honu/examples/Character.honu
new file mode 100644
index 0000000000..2ef086c625
--- /dev/null
+++ b/collects/honu/examples/Character.honu
@@ -0,0 +1,12 @@
+type Character {
+  char value;
+  String toString();
+}
+
+class CharBox() : Character impl Character {
+  init char value;
+
+  String toString() { return new StrBox(value = charToStr(value)); }
+
+  export Character : value, toString;
+}
diff --git a/collects/honu/examples/Fact-Integer.honu b/collects/honu/examples/Fact-Integer.honu
new file mode 100644
index 0000000000..31cf77bec6
--- /dev/null
+++ b/collects/honu/examples/Fact-Integer.honu
@@ -0,0 +1,78 @@
+type Integer {
+  int value;
+
+  Integer succ();
+  Integer plus(Integer y);
+  Integer times(Integer y);
+}
+
+type IFact {
+    Integer fact();
+}
+
+class Zero() : Integer impl Integer, IFact {
+
+  int value = 0;
+
+  Integer plus(Integer y) {
+    return y;
+  }
+
+  Integer times(Integer y) {
+    return (this : Integer);
+  }
+  
+  Integer succ() {
+    return new Positive : Integer(pred = (this : Integer));
+  }
+
+  Integer fact() {
+    return new Positive : Integer(pred = (this : Integer));
+  }
+
+  export Integer : value, plus, times, succ;
+
+  export IFact : fact;
+}
+
+class Positive() : Integer impl Integer, IFact {
+
+  init Integer pred;
+
+  int value = pred.value + 1;
+
+  Integer plus(Integer y) {
+    return pred.plus(y.succ());
+  }
+
+  Integer times(Integer y) {
+    return pred.times(y).plus(y);
+  }
+
+  Integer succ() {
+    return new Positive : Integer(pred = (this : Integer));
+  }
+
+  Integer fact() {
+      return times((pred : IFact).fact());
+  }
+
+  export Integer : value, plus, times, succ;
+  export IFact : fact;
+}
+
+Integer main(){
+  Integer zero  = new Zero     : Integer();
+  Integer one   = new Positive : Integer(pred = zero);
+  Integer two   = new Positive : Integer(pred = one);
+  Integer three = one.plus(two);
+  Integer four  = two.times(two);
+  Integer five  = four.plus(one);
+  Integer six   = two.plus(four);
+  Integer seven = one.plus(two.plus(four));
+  Integer eight = two.times(two);
+  Integer nine  = three.times(three);
+  Integer ten   = nine.plus(one);
+
+  return (five : IFact).fact();
+}
diff --git a/collects/honu/examples/Fact.honu b/collects/honu/examples/Fact.honu
new file mode 100644
index 0000000000..95a01326a9
--- /dev/null
+++ b/collects/honu/examples/Fact.honu
@@ -0,0 +1,33 @@
+type IFact {
+    int fact(int n);
+}
+
+class FactRec() : IFact impl IFact {
+    int fact(int n) {
+        return factA(n, 1);
+    }
+
+    int factA(int n, int a) {
+        if n == 0 { a; }
+        else { factA(n - 1, a * n); };
+    }
+
+    export IFact : fact;
+}
+
+class FactAcc() : IFact impl IFact {
+    int fact(int n) {
+        int ret = 1;
+        while (n > 1) {
+          ret = ret * n;
+          n   = n - 1;
+        };
+        return ret;
+    }
+
+    export IFact : fact;
+}
+
+int main(){
+    (new FactRec:IFact()).fact(500) + (new FactAcc:IFact()).fact(500);
+}
diff --git a/collects/honu/examples/Float.honu b/collects/honu/examples/Float.honu
new file mode 100644
index 0000000000..d910ecb6a3
--- /dev/null
+++ b/collects/honu/examples/Float.honu
@@ -0,0 +1,13 @@
+type Float {
+  float value;
+
+  String toString();
+}
+
+class FloatBox() : Float impl Float {
+  init float value;
+
+  String toString() { return new StrBox(value = floatToStr(value)); }
+
+  export Float : value, toString;
+}
diff --git a/collects/honu/examples/Integer-box.honu b/collects/honu/examples/Integer-box.honu
new file mode 100644
index 0000000000..b8338fd0f5
--- /dev/null
+++ b/collects/honu/examples/Integer-box.honu
@@ -0,0 +1,13 @@
+type Integer {
+  int value;
+
+  String toString();
+}
+
+class IntBox() : Integer impl Integer {
+  init int value;
+
+  String toString() { return new StrBox(value = intToStr(value)); }
+
+  export Integer : value, toString;
+}
diff --git a/collects/honu/examples/Integer-old.honu b/collects/honu/examples/Integer-old.honu
new file mode 100644
index 0000000000..5f7fa7b655
--- /dev/null
+++ b/collects/honu/examples/Integer-old.honu
@@ -0,0 +1,58 @@
+type Integer {
+  init();
+
+  Integer pred;
+
+  Integer succ();
+  Integer plus(Integer y);
+  Integer times(Integer y);
+}
+
+class Zero : Integer imp Integer {
+  init() {
+    my.pred = this;
+  }
+  
+  Integer pred;
+
+  Integer plus(Integer y) {
+    return y;
+  }
+
+  Integer times(Integer y) {
+    return this;
+  }
+  
+  Integer succ() {
+    Integer that = new Positive : Integer();
+    that.pred = this;
+    return that;
+  }
+
+  export Integer : pred as pred, plus as plus, times as times, succ as succ;
+}
+
+class Positive : Integer imp Integer {
+
+  init() {
+    my.pred = null;
+  }
+
+  Integer pred;
+
+  Integer plus(Integer y) {
+    return pred.plus(y.succ());
+  }
+
+  Integer times(Integer y) {
+    return pred.times(y).plus(y);
+  }
+
+  Integer succ() {
+    Integer that = new Positive : Integer();
+    that.pred = this;
+    return that;
+  }
+
+  export Integer : pred as pred, plus as plus, times as times, succ as succ;
+}
diff --git a/collects/honu/examples/Integer-value.honu b/collects/honu/examples/Integer-value.honu
new file mode 100644
index 0000000000..3de384b31b
--- /dev/null
+++ b/collects/honu/examples/Integer-value.honu
@@ -0,0 +1,62 @@
+type Integer {
+  int value;
+
+  Integer succ();
+  Integer plus(Integer y);
+  Integer times(Integer y);
+}
+
+class Zero() : Integer impl Integer {
+
+  int value = 0;
+
+  Integer plus(Integer y) {
+    return y;
+  }
+
+  Integer times(Integer y) {
+    return (this : Integer);
+  }
+  
+  Integer succ() {
+    return new Positive : Integer(pred = (this : Integer));
+  }
+
+  export Integer : value, plus, times, succ;
+}
+
+class Positive() : Integer impl Integer {
+
+  init Integer pred;
+
+  int value = pred.value + 1;
+
+  Integer plus(Integer y) {
+    return pred.plus(y.succ());
+  }
+
+  Integer times(Integer y) {
+    return pred.times(y).plus(y);
+  }
+
+  Integer succ() {
+    return new Positive : Integer(pred = (this : Integer));
+  }
+
+  export Integer : value, plus, times, succ;
+}
+
+Integer main() {
+  Integer zero  = new Zero     : Integer();
+  Integer one   = new Positive : Integer(pred = zero);
+  Integer two   = new Positive : Integer(pred = one);
+  Integer three = one.plus(two);
+  Integer four  = two.times(two);
+  Integer five  = four.plus(one);
+  Integer six   = two.plus(four);
+  Integer seven = one.plus(two.plus(four));
+  Integer eight = two.times(two);
+  Integer nine  = three.times(three);
+
+  return nine.plus(one);
+}
diff --git a/collects/honu/examples/Integer.honu b/collects/honu/examples/Integer.honu
new file mode 100644
index 0000000000..10ea18cfd9
--- /dev/null
+++ b/collects/honu/examples/Integer.honu
@@ -0,0 +1,56 @@
+type Integer {
+  Integer succ();
+  Integer plus(Integer y);
+  Integer times(Integer y);
+}
+
+class Zero() : Integer impl Integer {
+
+  Integer plus(Integer y) {
+    return y;
+  }
+
+  Integer times(Integer y) {
+    return (this : Integer);
+  }
+  
+  Integer succ() {
+    return new Positive : Integer(pred = (this : Integer));
+  }
+
+  export Integer : plus, times, succ;
+}
+
+class Positive() : Integer impl Integer {
+
+  init Integer pred;
+
+  Integer plus(Integer y) {
+    return pred.plus(y.succ());
+  }
+
+  Integer times(Integer y) {
+    return pred.times(y).plus(y);
+  }
+
+  Integer succ() {
+    return new Positive : Integer(pred = (this : Integer));
+  }
+
+  export Integer : plus, times, succ;
+}
+
+Integer main() {
+  Integer zero  = new Zero     : Integer();
+  Integer one   = new Positive : Integer(pred = zero);
+  Integer two   = new Positive : Integer(pred = one);
+  Integer three = one.plus(two);
+  Integer four  = two.times(two);
+  Integer five  = four.plus(one);
+  Integer six   = two.plus(four);
+  Integer seven = one.plus(two.plus(four));
+  Integer eight = two.times(two);
+  Integer nine  = three.times(three);
+
+  return nine.plus(one);
+}
diff --git a/collects/honu/examples/List-main.honu b/collects/honu/examples/List-main.honu
new file mode 100644
index 0000000000..d2c71434f6
--- /dev/null
+++ b/collects/honu/examples/List-main.honu
@@ -0,0 +1,24 @@
+List iota(int n) {
+  List ret = new MTList : List();
+  while(n > 0) {
+    ret = new ConsList : List(car = new Int : IInt(value = n), cdr = ret);
+    n = n - 1;
+  };
+  return ret;
+}
+
+int main() {
+  List x = iota(100);
+  List y = x.map(fun(Any x) {
+                   if(x isa IInt) {
+                     new Int : IInt(value = (x : IInt).value * 2);
+                   } else {
+                     x;
+                   };
+                 });
+  (y.foldl(fun(Any x, Any i) {
+             if x isa IInt && i isa IInt {
+               new Int : IInt(value = (x : IInt).value + (i : IInt).value);
+             } else { i; } ; 
+           }, new Int : IInt(value = 0)) : IInt).value;
+}
diff --git a/collects/honu/examples/List.cm b/collects/honu/examples/List.cm
new file mode 100644
index 0000000000..f8b019ab9e
--- /dev/null
+++ b/collects/honu/examples/List.cm
@@ -0,0 +1,3 @@
+"List"        ; for List, MTList, ConsList
+"struct-test" ; for Int/IInt
+"List-main"   ; for main
diff --git a/collects/honu/examples/List.honu b/collects/honu/examples/List.honu
new file mode 100644
index 0000000000..5733cf81c0
--- /dev/null
+++ b/collects/honu/examples/List.honu
@@ -0,0 +1,170 @@
+type List {
+
+  List addToFront(Any);
+  List addToEnd(Any);
+
+  Any  first();
+  Any  atIndex(int);
+  Any  last();
+
+  List drop(int);
+  List take(int);
+
+  List appendToEnd(List);
+  List appendToFront(List);
+
+  List reverse();
+
+  int length();
+  bool empty();
+
+  List map([Any] -> Any);
+  Any  foldl([Any, Any] -> Any, Any);
+  Any  foldr([Any, Any] -> Any, Any);
+  List filter([Any] -> bool);
+
+}
+
+class MTList() : List impl List {
+
+  List add(Any elt) {
+    return new ConsList(car = elt, cdr = (this : List));
+  }
+
+  Any no_elts(int n) {
+    error("The empty list has no elements!");
+  }
+
+  Any no_elt() {
+    error("The empty list has no elements!");
+  }
+
+  List drop(int n) {
+    if n == 0 {
+      this : List;
+    } else {
+      error("Attempt to drop elements from an empty list!");
+    };
+  }
+
+  List take(int n) {
+    if n == 0 {
+      this : List;
+    } else {
+      error("Attempt to take elements from an empty list!");
+    };
+  }
+
+  List ret_other(List l) { return l; }
+
+  List reverse() { return (this : List); }
+
+  int length() { return 0; }
+
+  bool empty() { return true; }
+
+  List map([Any] -> Any f) { return (this : List); }
+
+  Any fold([Any, Any] -> Any f, Any i) { return i; }
+
+  List filter([Any] -> bool f) { return (this : List); }
+
+  export List : add as addToFront, add as addToEnd,
+                no_elt as first, no_elts as atIndex, no_elt as last,
+                drop, take, reverse,
+                ret_other as  appendToEnd, ret_other as appendToFront,
+                length, empty,
+                map, fold as foldl, fold as foldr, filter;
+}
+
+class ConsList() : List impl List {
+
+  init Any car;
+  init List cdr;
+
+  Any first() { return car; }
+
+  Any atIndex(int n) {
+    if n == 0 {
+      car;
+    } else {
+      cdr.atIndex(n - 1);
+    };
+  }
+
+  Any last() {
+    if cdr.empty() {
+      car;
+    } else {
+      cdr.last();
+    };
+  }
+
+  List drop(int n) {
+    if n == 0 {
+      this : List;
+    } else {
+      cdr.drop(n - 1);
+    };
+  }
+
+  List take(int n) {
+    if n == 0 {
+      new MTList();
+    } else {
+      new ConsList(car = car, cdr = cdr.take(n - 1));
+    };
+  }
+
+  List addToFront(Any x) {
+    return new ConsList(car = x, cdr = (this : List));
+  }
+
+  List addToEnd(Any x) {
+    return new ConsList(car = car, cdr = cdr.addToEnd(x));
+  }
+
+  List appendToFront(List other) {
+    if other.empty() {
+      this : List;
+    } else {
+      new ConsList(car = other.first(), cdr = other.drop(1));
+    };
+  }
+
+  List appendToEnd(List other) {
+    return new ConsList(car = car, cdr = cdr.appendToEnd(other));
+  }
+
+  List reverse() {
+    return cdr.reverse().addToEnd(car);
+  }
+
+  int length() { return 1 + cdr.length(); }
+
+  bool empty() { return false; }
+
+  List map([Any] -> Any f) {
+    return new ConsList(car = f(car), cdr = cdr.map(f));
+  }
+
+  Any foldl([Any, Any] -> Any f, Any i) {
+    return f(car, cdr.foldl(f, i));
+  }
+
+  Any foldr([Any, Any] -> Any f, Any i) {
+    return cdr.foldr(f, f(car, i));
+  }
+
+  List filter([Any] -> bool f) {
+    if f(car) {
+      new ConsList(car = car, cdr = cdr.filter(f));
+    } else {
+      cdr.filter(f);
+    };
+  }
+
+  export List : addToFront, addToEnd, first, atIndex, last, reverse,
+                drop, take, appendToEnd, appendToFront, length, empty,
+                map, foldl, foldr, filter;
+}
diff --git a/collects/honu/examples/Stack-main.honu b/collects/honu/examples/Stack-main.honu
new file mode 100644
index 0000000000..920c99e1ce
--- /dev/null
+++ b/collects/honu/examples/Stack-main.honu
@@ -0,0 +1,25 @@
+IStack main() {
+  IStack x = new CountedListStack : IStack();
+  IStack y = null;
+
+  x.push(new CharBox : Character(value = '5'));
+  x.push(new IntBox  : Integer(value = 3));
+
+  y = x.copy();
+
+  while(!y.empty()) {
+    Any curr = y.pop();
+
+    if curr isa Character {
+      printLine("Got a character");
+    } else {
+      if curr isa Integer {
+        printLine("Got an integer");
+      } else {
+        printLine("Got something else");
+      };
+    };
+  };
+
+  x;
+}
diff --git a/collects/honu/examples/Stack.cm b/collects/honu/examples/Stack.cm
new file mode 100644
index 0000000000..d0ceada7de
--- /dev/null
+++ b/collects/honu/examples/Stack.cm
@@ -0,0 +1,7 @@
+"List"        ; For IList, MTList, and ConsList
+"Character"   ; For Character and CharBox
+"Integer-box" ; For Integer and IntBox
+"Float"       ; For Float and FloatBox
+"String"      ; For String and StrBox
+"Stack"       ; For IStack, ListStack, and CountedListStack
+"Stack-main"  ; For the main expression
diff --git a/collects/honu/examples/Stack.honu b/collects/honu/examples/Stack.honu
new file mode 100644
index 0000000000..c5c0195034
--- /dev/null
+++ b/collects/honu/examples/Stack.honu
@@ -0,0 +1,80 @@
+type IStack
+{
+    void push (Any elt);
+    Any pop();
+    bool empty();
+    IStack copy();
+}
+
+class ListStack() : IStack impl IStack {
+    List stack = new MTList();
+
+    void push (Any elt) {
+       stack = new ConsList(car = elt, cdr = stack);
+    }
+
+    Any pop() {
+       if stack.empty() {
+         error("The stack is empty!");
+       } else {
+         Any x = stack.first();
+         stack = stack.drop(1);
+         return x;
+       };
+    }
+
+    bool empty() {
+      return stack.empty();
+    }
+
+    IStack copy() {
+      List tocopy = stack.reverse();
+      IStack newStack = new ListStack();
+      while(!tocopy.empty()) {
+        newStack.push(tocopy.first());
+        tocopy = tocopy.drop(1);
+      };
+      return newStack;
+    }
+
+    export IStack : push, pop, empty, copy;
+}
+
+type ICountedStack <: IStack
+{
+    int numElements();
+}
+
+mixin addCount() : ICountedStack at IStack impl ICountedStack
+{
+    int numElts = 0;
+
+    super();
+
+    void countedPush(Any elt)
+    {
+        numElts = numElts + 1;
+        push(elt);
+    }
+
+    Any countedPop()
+    {
+        Any x = pop();
+        numElts = numElts - 1;
+        return x;
+    }
+
+    int getSize()
+    {
+        numElts;
+    }
+
+    export ICountedStack :
+        countedPush as push,
+        countedPop as pop,
+        empty,
+        copy, // but this isn't a countable stack!
+        getSize as numElements;
+}
+
+subclass CountedListStack = addCount(ListStack);
diff --git a/collects/honu/examples/String.honu b/collects/honu/examples/String.honu
new file mode 100644
index 0000000000..0681924813
--- /dev/null
+++ b/collects/honu/examples/String.honu
@@ -0,0 +1,36 @@
+type String {
+  str value;
+
+  void printStr();
+  void printLine();
+  Integer strToInt();
+  Float strToFloat();
+  Integer strLen();
+  String substr(int, int);
+  Character charAt(int);
+}
+
+class StrBox() : String impl String {
+  init str value;
+
+  void printStr() { printStr(value); }
+  
+  void printLine() { printLine(value); }
+
+  Integer strToInt() { return new IntBox(value = strToInt(value)); }
+
+  Float strToFloat() { return new FloatBox(value = strToFloat(value)); }
+
+  Integer strLen() { return new IntBox(value = strLen(value)); }
+
+  String substr(int start, int end) {
+    return new StrBox(value = substr(value, start, end));
+  }
+
+  Character charAt(int i) {
+    return new CharBox(value = charAt(value, i));
+  }
+
+  export String : value, printStr, printLine, strToInt, strToFloat, strLen,
+                  substr, charAt;
+}
diff --git a/collects/honu/examples/Y-new.honu b/collects/honu/examples/Y-new.honu
new file mode 100644
index 0000000000..4c6c2d7e0b
--- /dev/null
+++ b/collects/honu/examples/Y-new.honu
@@ -0,0 +1,15 @@
+int -> int fix(<int -> int> -> int -> int f) {
+  T -> int -> int g = fun(T x) { f(fun(int y) { x.f x y; }); };
+  g (new Y(f = g));
+}
+
+struct Y : T {
+  init T -> int -> int f;
+}
+
+int factorialor(int -> int factorial) (int x) {
+  if(x == 0) 1
+  else       x * factorial(x - 1);
+}
+
+int main(int n) { fix factorialor n; }
diff --git a/collects/honu/examples/Y.honu b/collects/honu/examples/Y.honu
new file mode 100644
index 0000000000..93e34205b1
--- /dev/null
+++ b/collects/honu/examples/Y.honu
@@ -0,0 +1,40 @@
+// compute the fixpoint of f
+[int] -> int fix([[int] -> int] -> [int] -> int f) {
+  [T] -> [int] -> int g = fun(T x) { 
+                            [int] -> int h = fun (int y) { // will become: ((outT(x))(x))(y)
+ 																[T] -> [int] -> int g = outT(x); 
+ 																[int] -> int        i = g(x);
+ 																return i(y);
+ 																};
+      return f(h); 
+      };
+  return g(inT(g)); 
+}
+
+// type T = Y of T -> int -> int
+
+struct Y() : T {
+        init [T] -> [int] -> int f;
+}
+
+[T] -> [int] -> int outT(T x)                  { return x.f; }
+T                   inT([T] -> [int] -> int x) { return new Y(f = x); }
+
+// -----------------------------------------------------------------------------
+
+[int] -> int factorialor([int] -> int factorial) {
+        return
+     fun (int x) { 
+                 if (x == 0) {
+                   return 1; 
+                 }
+                 else {
+                        return x * factorial(x - 1); 
+                 };
+          };
+}
+
+int main(int n) { 
+ [int] -> int factorial = fix(factorialor); 
+ return factorial(n); 
+}
diff --git a/collects/honu/examples/error-prim.honu b/collects/honu/examples/error-prim.honu
new file mode 100644
index 0000000000..5c2cd684f3
--- /dev/null
+++ b/collects/honu/examples/error-prim.honu
@@ -0,0 +1,4 @@
+int main() {
+  int x = if true { 3; } else { error("I shouldn't be here!"); };
+  x + 4;
+}
diff --git a/collects/honu/examples/field-exp-sub.honu b/collects/honu/examples/field-exp-sub.honu
new file mode 100644
index 0000000000..ad77f8660c
--- /dev/null
+++ b/collects/honu/examples/field-exp-sub.honu
@@ -0,0 +1,24 @@
+type t {
+    int x;
+}
+
+type t2 <: t {
+    int y;
+}
+
+type contains_t {
+    t x;
+}
+
+class c() : t2 impl t2 {
+    init int x;
+    init int y;
+
+    export t2 : x, y;
+}
+
+class cct() : contains_t impl contains_t {
+    init t2 x;
+    
+    export contains_t : x;
+}
diff --git a/collects/honu/examples/forgot-init.honu b/collects/honu/examples/forgot-init.honu
new file mode 100644
index 0000000000..13835e393f
--- /dev/null
+++ b/collects/honu/examples/forgot-init.honu
@@ -0,0 +1,12 @@
+type t {
+  int x;
+}
+
+class c(int x) : t impl t {
+  int y = x;
+  export t : y as x; 
+}
+
+t main() {
+  new c:t();
+}
diff --git a/collects/honu/examples/func-test.honu b/collects/honu/examples/func-test.honu
new file mode 100644
index 0000000000..6678dfac29
--- /dev/null
+++ b/collects/honu/examples/func-test.honu
@@ -0,0 +1,12 @@
+int fact(int x) {
+  int ret = 1;
+  while(x > 1) {
+    ret = ret * x;
+    x = x - 1;
+  };
+  return ret;
+}
+
+int main() {
+  fact(5);
+}
diff --git a/collects/honu/examples/interpreter-str.honu b/collects/honu/examples/interpreter-str.honu
new file mode 100644
index 0000000000..719e4721c7
--- /dev/null
+++ b/collects/honu/examples/interpreter-str.honu
@@ -0,0 +1,435 @@
+// -*- java -*-
+
+/*
+ * General Notes:
+ *
+ * 1) we need some sort of error reporting mechanism.  Full exceptions
+ *    would be nice, but even a MzScheme-like error primitive would be
+ *    sufficient for now.
+ * 2) We desperately need some sort of polymorphism -- even Java 1.4
+ *    style would be an improvement!
+ * 3) What did we decide w.r.t typing _this_ again?
+ */
+
+/*
+ * Assumed built-in types, operations
+ *  OCaml-style extensional equality
+ *  null? (or, more generally, intensional equality)
+ *  String (changed to str)
+ *  int
+ *  boolean (changed to bool)
+ */
+
+/*
+**********************************************************************
+* Infrastructure: sets, lists, etc.
+**********************************************************************/
+
+type StringList
+{
+    bool contains(str s);
+
+    // Returns copy of this list with first occurrence of s removed.
+    // If no s, returns copy of this list.
+    StringList remove(str s);
+
+    // fold that produces a set.
+    StringSet setFold(StringSet initial, StringSetOp op);
+
+    bool hasDuplicates();
+}
+
+type StringSetOp
+{
+    // invoke this closure.
+    StringSet run(StringSet accum, str s);
+}
+
+class EmptyStringList() : StringList impl StringList
+{
+    bool contains(str s) { false; }
+    StringList remove(str s) { this : StringList; }
+
+    StringSet setFold(StringSet initial, StringSetOp op) { initial; }
+
+    bool hasDuplicates() { false; }
+
+    export StringList : contains, setFold, remove, hasDuplicates;
+}
+
+class ConsStringList(StringList rest) : StringList impl StringList
+{
+    init str first;
+
+    StringList rest =
+        if rest == null {
+          error("ConsStringList.rest null");
+        } else { rest; };
+
+    bool contains(str s)
+    {
+        (s == first) || rest.contains(s);
+    }
+
+    StringList remove(str s)
+    {
+        if s == first { rest; }
+        else { new ConsStringList : StringList
+                (first = first,
+                 rest = rest.remove(s)); };
+    }
+
+    StringSet setFold(StringSet initial, StringSetOp op)
+    {
+        rest.setFold(op.run(initial, first), op);
+    }
+
+    bool hasDuplicates()
+    {
+        rest.contains(first) || rest.hasDuplicates();
+    }
+
+    export StringList : contains, setFold, remove, hasDuplicates;
+}
+
+class UnionOp() : StringSetOp impl StringSetOp
+{
+    StringSet run(StringSet accum, str s)
+    {
+        accum.singleUnion(s);
+    }
+
+    export StringSetOp : run;
+}
+
+type StringSet
+{
+    StringSet singleUnion(str elt);
+    StringSet union(StringSet rhs);
+    StringSet subElt(str elt);
+}
+
+class StringSetCls() : StringSet impl StringSet
+{
+    init StringList contents = new EmptyStringList : StringList();
+    // this showed up a bug in the parser where I wasn't adding
+    // the default expressions to things.  This caused problems
+    // when relying on them (i.e. not giving a contents init arg).
+    // Fixed.
+
+    // How should this get translated?  You have a default value
+    // for contents so it can't go into the init args in the header,
+    // but you want an additional check later (hasDuplicates()).
+    StringList contents =
+        if contents.hasDuplicates() {
+          error("StringList.contents must be set");
+        } else { contents; };
+
+    StringSet singleUnion(str elt)
+    {
+        if contents.contains(elt) { this : StringSet; }
+        else {
+            new StringSetCls : StringSet
+                (contents = new ConsStringList : StringList(first = elt,
+                                                            rest = contents));
+        };
+    }
+
+    StringSet union(StringSet rhs)
+    {
+        contents.setFold(rhs, new UnionOp : StringSetOp());
+    }
+
+    StringSet subElt(str elt)
+    {
+        new StringSetCls : StringSet(contents = contents.remove(elt));
+    }
+
+    export StringSet : singleUnion, union, subElt;
+    // was export StringSetCls, typechecker caught this.
+}
+
+/*
+**********************************************************************
+* Values
+**********************************************************************/
+
+type Value
+{
+    Value apply(Value arg);
+}
+
+class IntValue() : Value impl Value // was class Constant, typechecker caught this
+                                    // line 359 was the use of IntValue
+{
+    init int n;
+
+    Value apply(Value arg) { error("cannot apply a constant"); }
+
+    export Value : apply;
+}
+
+class Closure(Ast body, Env rho) : Value impl Value
+{
+    init str argName;
+    Ast body =
+        if body == null {
+          error("Closure.body null");
+        } else { body; };
+    Env rho =
+        if rho == null {
+          error("Closure.rho null");
+        } else { rho; }; // was else body, Typechecker caught this
+
+    Value apply(Value arg)
+    {
+        body.getValue(rho.extend(argName, arg));
+        // originally thought this was a bug in the interpreter,
+        // but it was a bug in the typechecker (did supertype
+        // checking on method arguments, not subtype checking).  Fixed.
+    }
+    
+    export Value : apply; // no export statement, typechecker caught this.
+}
+
+/*
+  **********************************************************************
+  * Types
+  **********************************************************************/
+
+type Type
+{
+    Type getRange(Type domain);
+}
+
+class IntType() : Type impl Type
+{
+    Type getRange(Type domain) { error("IntType.getRange"); }
+
+    export Type : getRange;
+}
+
+class ArrowType(Type dom, Type rng) : Type impl Type
+{
+    Type dom =
+        if dom == null {
+          error("ArrowType.dom null");
+        } else { dom; };
+    Type rng =
+        if rng == null {
+          error("ArrowType.rng null");
+        } else { rng; };
+
+    Type getRange(Type domain)
+    {
+        // extensional equality
+        if domain ==== dom { rng; }
+        else { error("arrowType.getRange: domain mismatch"); };
+    }
+
+    export Type : getRange;
+}
+
+/*
+**********************************************************************
+* Environments
+**********************************************************************/
+
+type Env
+{
+    Env extend(str var, Any t);
+    Any lookup(str var);
+}
+
+class EmptyEnv() : Env impl Env
+{
+    Env extend(str var, Any t)
+    {
+        new RibEnv : Env(id = var, bdg = t, rest = this : Env);
+    }
+
+    Any lookup(str var)
+    {
+        error("unbound id");
+    }
+
+    export Env : extend, lookup;
+}
+
+class RibEnv(Any bdg, Env rest) : Env impl Env
+{
+    init str id;
+    Any bdg =
+        if bdg == null {
+          error("RibEnv.bdg null");
+        } else { bdg; };
+    Env rest =
+        if rest == null {
+          error("RibEnv.rest null");
+        } else { rest; };
+
+    Env extend(str var, Any t)
+    {
+        new RibEnv : Env(id = var, bdg = t, rest = this : Env);
+    }
+
+    Any lookup(str var)
+    {
+        if var == id { bdg; } else { rest.lookup(var); };
+    }
+
+    export Env : extend, lookup;
+    // was export TypeEnv, should be Env, typechecker caught this.
+}
+/*
+  **********************************************************************
+  * ASTS
+  **********************************************************************/
+
+type Ast
+{
+    StringSet vars();
+    StringSet freeVars();
+
+    Type getType(Env gamma);
+    Value getValue(Env rho);
+}
+
+class Constant() : Ast impl Ast
+{
+    init int n;
+
+    StringSet vars()
+    {
+        new StringSetCls : StringSet();
+    }
+
+    StringSet fv()
+    {
+        vars();
+    }
+
+    Type getType(Env gamma)
+    {
+        new IntType : Type();
+    }
+
+    Value getValue(Env rho)
+    {
+        new IntValue : Value(n = n);
+    }
+
+    export Ast : vars, fv as freeVars, getType, getValue;
+}
+
+class Variable() : Ast impl Ast
+{
+    init str name;
+
+    StringSet vars()
+    {
+        StringSet result = new StringSetCls : StringSet();
+        result.singleUnion(name);
+    }
+
+    StringSet fv() { vars(); }
+
+    Type getType(Env gamma)
+    {
+        gamma.lookup(name) : Type;
+    }
+
+    Value getValue(Env rho)
+    {
+        rho.lookup(name) : Value;
+    }
+
+    export Ast : vars, fv as freeVars, getType, getValue;
+    // last part was erroneously typed "getName" instead of "getValue",
+    // caught by typechecker.
+}
+
+class Lambda(Ast body, Type argType) : Ast impl Ast
+{
+    init str argName;
+
+    Ast body =
+        if body == null {
+          error("Lambda.body null");
+        } else { body; };
+    Type argType =
+        if argType == null {
+          error("Lambda.argType null");
+        } else { argType; };
+
+    StringSet vars()
+    {
+        body.vars();
+    }
+
+    StringSet freeVars()
+    {
+        body.freeVars().subElt(argName);
+        // was arg (init field) instead of argName (field).
+        // typechecker caught this.
+    }
+
+    Type getType(Env gamma)
+    {
+        body.getType(gamma.extend(argName, argType));
+        // originally thought this was a bug in the interpreter,
+        // but it was a bug in the typechecker (did supertype
+        // checking on method arguments, not subtype checking).  Fixed.
+    }
+
+    Value getValue(Env rho)
+    {
+        return new Closure : Value(argName = argName, body = body, rho = rho);
+    }
+
+    export Ast : vars, freeVars, getType, getValue;
+}
+
+class Application(Ast rator, Ast rand) : Ast impl Ast
+{
+    Ast rator =
+        if rator == null {
+          error("Application.rator null");
+        } else { rator; };
+    Ast rand =
+        if rand == null {
+          error("Application.rand null");
+        } else { rand; };
+
+    StringSet vars()
+    {
+        StringSet ratorVars = rator.vars();
+        ratorVars.union(rand.vars());
+    }
+
+    StringSet fv()
+    {
+        StringSet ratorFv = rator.freeVars();
+        // rator.freeVars (public name)  was rator.fv (private name).
+        // typechecker caught this (happened below also with rand)
+        ratorFv.union(rand.freeVars());
+    }
+
+    Type getType(Env gamma)
+    {
+        Type ratorType = rator.getType(gamma);
+        ratorType.getRange(rand.getType(gamma));
+    }
+
+    Value getValue(Env rho)
+    {
+        Value ratorVal = rator.getValue(rho);
+        ratorVal.apply(rand.getValue(rho));
+        // ratorVal.apply was rator.apply, which gave method not found error
+        // typechecker caught this.
+        // also, rand.getValue was rand.value.  Same error.
+        // typechecker caught this.
+    }
+
+    export Ast : vars, fv as freeVars, getType, getValue;
+}
diff --git a/collects/honu/examples/interpreter.honu b/collects/honu/examples/interpreter.honu
new file mode 100644
index 0000000000..0390d747a9
--- /dev/null
+++ b/collects/honu/examples/interpreter.honu
@@ -0,0 +1,465 @@
+// -*- java -*-
+
+/*
+ * General Notes:
+ *
+ * 1) we need some sort of error reporting mechanism.  Full exceptions
+ *    would be nice, but even a MzScheme-like error primitive would be
+ *    sufficient for now.
+ * 2) We desperately need some sort of polymorphism -- even Java 1.4
+ *    style would be an improvement!
+ * 3) What did we decide w.r.t typing _this_ again?
+ */
+
+/*
+ * Assumed built-in types, operations
+ *  OCaml-style extensional equality
+ *  null? (or, more generally, intensional equality)
+ *  String (changed to str)
+ *  int
+ *  boolean (changed to bool)
+ */
+
+/*
+**********************************************************************
+* Boxing: str -> String
+**********************************************************************/
+
+type String {
+    str val;
+}
+
+/*
+**********************************************************************
+* Infrastructure: sets, lists, etc.
+**********************************************************************/
+
+type StringList
+{
+    bool contains(String s);
+
+    // Returns copy of this list with first occurrence of s removed.
+    // If no s, returns copy of this list.
+    StringList remove(String s);
+
+    // fold that produces a set.
+    StringSet setFold(StringSet initial, StringSetOp op);
+
+    bool hasDuplicates();
+}
+
+type StringSetOp
+{
+    // invoke this closure.
+    StringSet run(StringSet accum, String s);
+}
+
+class EmptyStringList() : StringList impl StringList
+{
+    bool contains(String s) { false; }
+    StringList remove(String s) { this : StringList; }
+
+    StringSet setFold(StringSet initial, StringSetOp op) { initial; }
+
+    bool hasDuplicates() { false; }
+
+    export StringList : contains, setFold, remove, hasDuplicates;
+}
+
+class ConsStringList(String init_first, StringList init_rest) : StringList impl StringList
+{
+    String first =
+        if(init_first == null) {
+          error("ConsStringList.init_first null");
+        } else {
+          init_first;
+        };
+    StringList rest =
+        if init_rest == null {
+          error("ConsStringList.init_rest null");
+        } else { init_rest; };
+
+    bool contains(String s)
+    {
+        (s ==== first) || rest.contains(s);
+    }
+
+    StringList remove(String s)
+    {
+        if s ==== first {
+          rest;
+        } else {
+          new ConsStringList : StringList
+            (init_first = first,
+             init_rest = rest.remove(s));
+        };
+    }
+
+    StringSet setFold(StringSet initial, StringSetOp op)
+    {
+        rest.setFold(op.run(initial, first), op);
+    }
+
+    bool hasDuplicates()
+    {
+        rest.contains(first) || rest.hasDuplicates();
+    }
+
+    export StringList : contains, setFold, remove, hasDuplicates;
+}
+
+class UnionOp() : StringSetOp impl StringSetOp
+{
+    StringSet run(StringSet accum, String s)
+    {
+        accum.singleUnion(s);
+    }
+
+    export StringSetOp : run;
+}
+
+type StringSet
+{
+    StringSet singleUnion(String elt);
+    StringSet union(StringSet rhs);
+    StringSet subElt(String elt);
+}
+
+class StringSetCls() : StringSet impl StringSet
+{
+    init StringList init_contents = new EmptyStringList : StringList();
+    // this showed up a bug in the parser where I wasn't adding
+    // the default expressions to things.  This caused problems
+    // when relying on them (i.e. not giving a contents init arg).
+    // Fixed.
+
+    // How should this get translated?  You have a default value
+    // for contents so it can't go into the init args in the header,
+    // but you want an additional check later (hasDuplicates()).
+    StringList contents =
+        if init_contents.hasDuplicates() {
+          error("StringList.contents must be set");
+        } else { init_contents; };
+
+    StringSet singleUnion(String elt)
+    {
+        if contents.contains(elt) {
+            this : StringSet;
+        } else {
+            new StringSetCls : StringSet
+                (init_contents = new ConsStringList : StringList(init_first = elt,
+                                                            init_rest = contents));
+        };
+    }
+
+    StringSet union(StringSet rhs)
+    {
+        contents.setFold(rhs, new UnionOp : StringSetOp());
+    }
+
+    StringSet subElt(String elt)
+    {
+        new StringSetCls : StringSet(init_contents = contents.remove(elt));
+    }
+
+    export StringSet : singleUnion, union, subElt;
+    // was export StringSetCls, typechecker caught this.
+}
+
+/*
+**********************************************************************
+* Values
+**********************************************************************/
+
+type Value
+{
+    Value apply(Value arg);
+}
+
+class IntValue() : Value impl Value // was class Constant, typechecker caught this
+                                    // line 359 was the use of IntValue
+{
+    init int init_n;
+
+    Value apply(Value arg) { error("cannot apply a constant"); }
+
+    export Value : apply;
+}
+
+class Closure(String init_argName, Ast init_body, Env init_rho) : Value impl Value
+{
+    String argName =
+        if init_argName == null {
+          error("Closure.argName null");
+        } else { init_argName; };
+    Ast body =
+        if init_body == null {
+          error("Closure.body null");
+        } else { init_body; };
+    Env rho =
+        if init_rho == null {
+          error("Closure.rho null") ;
+        } else { init_rho; }; // was else body, Typechecker caught this
+
+    Value apply(Value arg)
+    {
+        body.getValue(rho.extend(argName, arg));
+        // originally thought this was a bug in the interpreter,
+        // but it was a bug in the typechecker (did supertype
+        // checking on method arguments, not subtype checking).  Fixed.
+    }
+    
+    export Value : apply; // no export statement, typechecker caught this.
+}
+
+/*
+  **********************************************************************
+  * Types
+  **********************************************************************/
+
+type Type
+{
+    Type getRange(Type domain);
+}
+
+class IntType() : Type impl Type
+{
+    Type getRange(Type domain) { error("IntType.getRange"); }
+
+    export Type : getRange;
+}
+
+class ArrowType(Type init_dom, Type init_rng) : Type impl Type
+{
+    Type dom =
+        if init_dom == null {
+          error("ArrowType.dom null");
+        } else { init_dom; };
+    Type rng =
+        if init_rng == null {
+          error("ArrowType.rng null");
+        } else { init_rng; };
+
+    Type getRange(Type domain)
+    {
+        // extensional equality
+        if domain ==== dom { rng; }
+        else { error("arrowType.getRange: domain mismatch"); };
+    }
+
+    export Type : getRange;
+}
+
+/*
+**********************************************************************
+* Environments
+**********************************************************************/
+
+type Env
+{
+    Env extend(String var, Any t);
+    Any lookup(String var);
+}
+
+class EmptyEnv() : Env impl Env
+{
+    Env extend(String var, Any t)
+    {
+        new RibEnv : Env(init_id = var, init_bdg = t, init_rest = this : Env);
+    }
+
+    Any lookup(String var)
+    {
+        error("unbound id");
+    }
+
+    export Env : extend, lookup;
+}
+
+class RibEnv(String init_id, Any init_bdg, Env init_rest) : Env impl Env
+{
+
+    String id =
+        if init_id == null {
+          error("RibEnv.id null");
+        } else { init_id; };
+    Any bdg =
+        if init_bdg == null {
+          error("RibEnv.bdg null");
+        } else { init_bdg; };
+    Env rest =
+        if init_rest == null {
+          error("RibEnv.rest null");
+        } else { init_rest; };
+
+    Env extend(String var, Any t)
+    {
+        new RibEnv : Env(init_id = var, init_bdg = t, init_rest = this : Env);
+    }
+
+    Any lookup(String var)
+    {
+        if var ==== id { bdg; }
+        else { rest.lookup(var); };
+    }
+
+    export Env : extend, lookup;
+    // was export TypeEnv, should be Env, typechecker caught this.
+}
+/*
+  **********************************************************************
+  * ASTS
+  **********************************************************************/
+
+type Ast
+{
+    StringSet vars();
+    StringSet freeVars();
+
+    Type getType(Env gamma);
+    Value getValue(Env rho);
+}
+
+class Constant() : Ast impl Ast
+{
+    init int n;
+
+    StringSet vars()
+    {
+        new StringSetCls : StringSet();
+    }
+
+    StringSet fv()
+    {
+        vars();
+    }
+
+    Type getType(Env gamma)
+    {
+        new IntType : Type();
+    }
+
+    Value getValue(Env rho)
+    {
+        new IntValue : Value(init_n = n);
+    }
+
+    export Ast : vars, fv as freeVars, getType, getValue;
+}
+
+class Variable(String init_name) : Ast impl Ast
+{
+    String name =
+        if init_name == null {
+          error("Variable.name null");
+        } else { init_name; };
+
+    StringSet vars()
+    {
+        StringSet result = new StringSetCls : StringSet();
+        result.singleUnion(name);
+    }
+
+    StringSet fv() { vars(); }
+
+    Type getType(Env gamma)
+    {
+        gamma.lookup(name) : Type;
+    }
+
+    Value getValue(Env rho)
+    {
+        rho.lookup(name) : Value;
+    }
+
+    export Ast : vars, fv as freeVars, getType, getValue;
+    // last part was erroneously typed "getName" instead of "getValue",
+    // caught by typechecker.
+}
+
+class Lambda(String init_arg, Ast init_body, Type init_argType) : Ast impl Ast
+{
+    String argName =
+        if init_arg == null {
+          error("Lambda.argName null");
+        } else { init_arg; };
+    Ast body =
+        if init_body == null {
+          error("Lambda.body null");
+        } else { init_body; };
+    Type argType =
+        if init_argType == null {
+          error("Lambda.argType null");
+        } else { init_argType; };
+
+    StringSet vars()
+    {
+        body.vars();
+    }
+
+    StringSet freeVars()
+    {
+        body.freeVars().subElt(argName);
+        // was arg (init field) instead of argName (field).
+        // typechecker caught this.
+    }
+
+    Type getType(Env gamma)
+    {
+        body.getType(gamma.extend(argName, argType));
+        // originally thought this was a bug in the interpreter,
+        // but it was a bug in the typechecker (did supertype
+        // checking on method arguments, not subtype checking).  Fixed.
+    }
+
+    Value getValue(Env rho)
+    {
+        return new Closure : Value(init_argName = argName, init_body = body, init_rho = rho);
+    }
+
+    export Ast : vars, freeVars, getType, getValue;
+}
+
+class Application(Ast init_rator, Ast init_rand) : Ast impl Ast
+{
+    Ast rator =
+        if init_rator == null {
+          error("Application.rator null");
+        } else { init_rator; };
+    Ast rand =
+        if init_rand == null {
+          error("Application.rand null");
+        } else { init_rand; };
+
+    StringSet vars()
+    {
+        StringSet ratorVars = rator.vars();
+        ratorVars.union(rand.vars());
+    }
+
+    StringSet fv()
+    {
+        StringSet ratorFv = rator.freeVars();
+        // rator.freeVars (public name)  was rator.fv (private name).
+        // typechecker caught this (happened below also with rand)
+        ratorFv.union(rand.freeVars());
+    }
+
+    Type getType(Env gamma)
+    {
+        Type ratorType = rator.getType(gamma);
+        ratorType.getRange(rand.getType(gamma));
+    }
+
+    Value getValue(Env rho)
+    {
+        Value ratorVal = rator.getValue(rho);
+        ratorVal.apply(rand.getValue(rho));
+        // ratorVal.apply was rator.apply, which gave method not found error
+        // typechecker caught this.
+        // also, rand.getValue was rand.value.  Same error.
+        // typechecker caught this.
+    }
+
+    export Ast : vars, fv as freeVars, getType, getValue;
+}
diff --git a/collects/honu/examples/lambda-test.honu b/collects/honu/examples/lambda-test.honu
new file mode 100644
index 0000000000..cd4a8e88da
--- /dev/null
+++ b/collects/honu/examples/lambda-test.honu
@@ -0,0 +1,4 @@
+int main() {
+  [int, int] -> int x = fun(int x, int y) { x + y; };
+  x(3, 4);
+}
diff --git a/collects/honu/examples/matthias1.honu b/collects/honu/examples/matthias1.honu
new file mode 100644
index 0000000000..534bb19a49
--- /dev/null
+++ b/collects/honu/examples/matthias1.honu
@@ -0,0 +1,23 @@
+type t {
+  void m();
+}
+
+ class A():t { // no implements necessary
+   t state = null;
+   void m() {
+     state = this;  // do we need coercions here?
+   }
+   export t : m;
+ }
+
+type s <: t { }
+
+ subclass B():s extends A at t {
+    super();
+    // use of m somewhere
+    void m2 { m(); }
+    // .: the type of this is s
+    // .: the assignment of state = this still works
+    //    because s is below t
+    export s : m2 as m;
+ }
diff --git a/collects/honu/examples/matthias2.honu b/collects/honu/examples/matthias2.honu
new file mode 100644
index 0000000000..245f39b202
--- /dev/null
+++ b/collects/honu/examples/matthias2.honu
@@ -0,0 +1,35 @@
+type t {
+  void m();
+}
+
+ class A():t { // no implements necessary
+   t state = null;
+   void m() {
+     state = (this : t);  // do we need coercions here? -- yes!
+   }
+   export t : m;
+ }
+
+type s <: t { }
+
+type u { 
+  void m();
+}
+
+ subclass B():s extends A at t implements u {
+    super();
+    // use of m somewhere
+    void m2() {
+        m();
+    }
+    // .: the type of this is s
+    // .: the assignment of state = this still works
+    //    because s is below t
+    export s : m;
+    export u : m2 as m;
+ }
+
+void main() {
+  u x = new B:u();
+  x.m();
+}
diff --git a/collects/honu/examples/mdcall-test.honu b/collects/honu/examples/mdcall-test.honu
new file mode 100644
index 0000000000..2bb1419293
--- /dev/null
+++ b/collects/honu/examples/mdcall-test.honu
@@ -0,0 +1,8 @@
+type t {
+  int md(int);
+}
+
+int main() {
+  t x = null;
+  x.md(3);
+}
diff --git a/collects/honu/examples/mdcall-test2.honu b/collects/honu/examples/mdcall-test2.honu
new file mode 100644
index 0000000000..77ada1c650
--- /dev/null
+++ b/collects/honu/examples/mdcall-test2.honu
@@ -0,0 +1,15 @@
+type t {
+  int md(int);
+}
+
+class c() : t impl t {
+  int my_md(int x) {
+    return this.md(x);
+  }
+  export t : my_md as md;
+}
+
+int main() {
+  t x = new c:t();
+  x.md(3);
+}
diff --git a/collects/honu/examples/method-exp-sub.honu b/collects/honu/examples/method-exp-sub.honu
new file mode 100644
index 0000000000..aea22af062
--- /dev/null
+++ b/collects/honu/examples/method-exp-sub.honu
@@ -0,0 +1,26 @@
+type t {
+    int x;
+}
+
+type t2 <: t {
+    int y;
+}
+
+type contains_t {
+    t x(t2);
+}
+
+class c() : t2 impl t2 {
+    init int x;
+    init int y;
+
+    export t2 : x, y;
+}
+
+class cct() : contains_t impl contains_t {
+    t2 x(t x) {
+        return new c : t2 (x = x.x, y = x.x);
+    }
+    
+    export contains_t : x;
+}
diff --git a/collects/honu/examples/mixin-init.honu b/collects/honu/examples/mixin-init.honu
new file mode 100644
index 0000000000..f76882dba7
--- /dev/null
+++ b/collects/honu/examples/mixin-init.honu
@@ -0,0 +1,31 @@
+/* should parse & type check. */
+
+type T
+{
+    int x;
+    int y;
+    int get_x();
+}
+
+class BaseCls() : T impl T
+{
+    init int x;
+    init int y;
+    int get_x() { x; }
+    export T : x, y, get_x;
+}
+
+mixin mx() : T at T impl T with int x
+{
+    init int z;
+    super(x = 3);
+    export T : z as x, y as y, get_x as get_x;
+}
+
+subclass DerivedCls = mx(BaseCls);
+
+int main() {
+    T t = new DerivedCls : T (y = 4, z = 5);
+
+    t.get_x() + t.x + t.y;   // should evaluate to 12
+}
diff --git a/collects/honu/examples/old-stack.honu b/collects/honu/examples/old-stack.honu
new file mode 100644
index 0000000000..da6a6d63e3
--- /dev/null
+++ b/collects/honu/examples/old-stack.honu
@@ -0,0 +1,98 @@
+/* Again, should parse and type-check. */
+
+type charList
+{
+    charList cons(char);
+    bool isEmpty();
+    char car();
+    charList cdr();
+}
+
+final class MTCList() : charList impl charList {
+    charList cons(char x) {
+      return new ConsCList : charList (car = x, cdr = (this : charList));
+    }
+    bool isEmpty() { return true; }
+    char car() { error("There are no elements in the empty list!"); }
+    charList cdr() { return (this : charList); }
+    export charList : car, cdr, isEmpty, cons;
+}
+
+final class ConsCList() : charList impl charList {
+    init char car;
+    init charList cdr;
+    charList cons(char x) {
+      return new ConsCList : charList (car = x, cdr = (this : charList));
+    }
+    bool isEmpty() { return false; }
+    char car_func() { return car; }
+    charList cdr_func() { return cdr; }
+    export charList : car_func as car, cdr_func as cdr, isEmpty, cons;
+}
+
+type stack
+{
+    char push (char elt);
+    char pop();
+}
+
+class listStack() : stack impl stack {
+    charList stack = new MTCList : charList();
+
+    char push (char elt) {
+       stack = stack.cons(elt);
+       return elt;
+    }
+    char pop() {
+       if stack.isEmpty() {
+         error("The stack is empty!");
+       } else {
+         char x = stack.car();
+         stack = stack.cdr();
+         return x;
+       };
+    }
+
+    export stack : push, pop;
+}
+
+type countedStack <: stack
+{
+    int numElements();
+}
+
+mixin addCount() : countedStack at stack impl countedStack
+{
+    int numElts = 0;
+
+    super();
+
+    char countedPush(char elt)
+    {
+        numElts = numElts + 1;
+        push(elt);
+    }
+
+    char countedPop()
+    {
+        char x = pop();
+        numElts = numElts - 1;
+        return x;
+    }
+
+    int getSize()
+    {
+        numElts;
+    }
+
+    export countedStack :
+        countedPush as push,
+        countedPop as pop,
+        getSize as numElements;
+}
+
+subclass countedListStack = addCount(listStack);
+
+char main() {
+  (new countedListStack : stack()).push('5');
+}
diff --git a/collects/honu/examples/point.honu b/collects/honu/examples/point.honu
new file mode 100644
index 0000000000..83eb430e75
--- /dev/null
+++ b/collects/honu/examples/point.honu
@@ -0,0 +1,56 @@
+/* Again, should parse and typecheck, though watch out for constructor
+ * syntax.
+ */
+
+type Point
+{
+    int x;
+    int y;
+}
+
+type ColorPoint extends Point
+{
+    int color;
+}
+
+type MovingPoint extends Point
+{
+    float dx;
+    float dy;
+}
+
+class PtClass() : Point implements Point
+{
+    init int x;
+    init int y;
+
+    export Point : x as x, y as y;
+}
+
+class ColorPtClass() : ColorPoint implements Point, ColorPoint
+{
+    /* We should add syntactic sugar for init fields. */
+
+    init int x;
+    init int y;
+    init int color;
+
+    export Point : x as x,  y as y;
+    export ColorPoint : x as x,  y as y, color as color;
+}
+
+mixin makeMovingPoint() : MovingPoint at Point impl MovingPoint
+{
+    init float dx;
+    init float dy;
+    super();
+
+    export MovingPoint : x, y, dx, dy;
+}
+
+subclass MvPtCls = makeMovingPoint(PtClass);
+subclass MvClrPtCls = makeMovingPoint(ColorPtClass);
+
+MovingPoint main() {
+  new MvClrPtCls : MovingPoint(x = 3, y = 4, color = 42, dx = 0.4, dy = -3.2);
+}
diff --git a/collects/honu/examples/rel-not-prim.honu b/collects/honu/examples/rel-not-prim.honu
new file mode 100644
index 0000000000..025b7a9d90
--- /dev/null
+++ b/collects/honu/examples/rel-not-prim.honu
@@ -0,0 +1,17 @@
+type t1 {
+  bool x();
+}
+
+class c() : t1 impl t1 {
+  bool x() { return true; }
+  export t1 : x;
+}
+
+bool main() {
+  t1 x = new c:t1();
+  if (1 < 3) && (2.0 >= 1.5) {
+    !x.x();
+  } else {
+    error("How'd I get here?");
+  };
+}
diff --git a/collects/honu/examples/simple-init.honu b/collects/honu/examples/simple-init.honu
new file mode 100644
index 0000000000..4785778a10
--- /dev/null
+++ b/collects/honu/examples/simple-init.honu
@@ -0,0 +1,12 @@
+type t {
+  int x;
+}
+
+class c(int x) : t impl t {
+  int y = x;
+  export t : y as x; 
+}
+
+t main() {
+  new c:t(x = 5);
+}
diff --git a/collects/honu/examples/square.honu b/collects/honu/examples/square.honu
new file mode 100644
index 0000000000..1e2e6aa88c
--- /dev/null
+++ b/collects/honu/examples/square.honu
@@ -0,0 +1,38 @@
+/* This should parse and type-check correctly.
+   Note the field initialization in unitSquare: the declaration of the
+   field x should shadow the init arg x from that point forward, but
+   of course the RHS of x's declaration should refer to the init arg.
+*/
+
+type shape
+{
+    int x;
+    int y;
+    int area();
+}
+
+type square extends shape
+{
+    int length;
+}
+
+class unitSquare() : shape impl shape, square
+{
+    init int x;
+    init int y;
+
+    int x = x;
+    int y = y;
+    int size = 1;
+
+    int area() { size * size; }
+
+    export shape : x as x,
+                   y as y,
+                   area as area;
+
+    export square : x as x,
+                    y as y,
+                    area as area,
+                    size as length;
+}
diff --git a/collects/honu/examples/str-float-prim.honu b/collects/honu/examples/str-float-prim.honu
new file mode 100644
index 0000000000..dba0ef9ee8
--- /dev/null
+++ b/collects/honu/examples/str-float-prim.honu
@@ -0,0 +1,4 @@
+float main() {
+  if   ("foo" + "bar" == "foobar") { 1.3 + 5.7; }
+  else { error("Oops!"); }
+}
diff --git a/collects/honu/examples/struct-test.honu b/collects/honu/examples/struct-test.honu
new file mode 100644
index 0000000000..1f2c8721af
--- /dev/null
+++ b/collects/honu/examples/struct-test.honu
@@ -0,0 +1,3 @@
+struct Int() : IInt {
+  init int value;
+}
diff --git a/collects/honu/examples/sub-bad-init.honu b/collects/honu/examples/sub-bad-init.honu
new file mode 100644
index 0000000000..2a07005e6a
--- /dev/null
+++ b/collects/honu/examples/sub-bad-init.honu
@@ -0,0 +1,11 @@
+type t {}
+
+class c() : t { init int x; export t; }
+
+mixin mx() : t at t with int x, int y {
+  init int z; 
+  super(x = 1, y = 2);
+  export t;
+}
+
+subclass c2 = mx(c); // should fail thanks to y = 2 above.
diff --git a/collects/honu/examples/sub-final.honu b/collects/honu/examples/sub-final.honu
new file mode 100644
index 0000000000..f3059ed961
--- /dev/null
+++ b/collects/honu/examples/sub-final.honu
@@ -0,0 +1,7 @@
+type t {}
+
+final class c() : t { init int x; export t; }
+
+mixin mx() : t at t with int x { init int z; super(x = 1); export t; }
+
+subclass c2 = mx(c); // should fail because c is final
diff --git a/collects/honu/examples/subclass-ext.honu b/collects/honu/examples/subclass-ext.honu
new file mode 100644
index 0000000000..3228e64ab2
--- /dev/null
+++ b/collects/honu/examples/subclass-ext.honu
@@ -0,0 +1,30 @@
+type t1 {
+   int x;
+   int y;
+}
+
+type t2 <: t1 {
+   int add();
+}
+
+class c1() : t1 implements t1 {
+   init int x;
+   init int y;
+
+   export t1 : x, y;
+}
+
+subclass c2() : t2 extends c1 at t1 implements t2 with int x, int y {
+   init int x;
+   init int y;
+
+   super(x = x, y = y);
+
+   int add() { return x + y; }
+
+   export t2: x, y, add;
+}
+
+int main() {
+  new c2:t2(x = 4, y = 6).add();
+}
diff --git a/collects/honu/examples/uminus.honu b/collects/honu/examples/uminus.honu
new file mode 100644
index 0000000000..aa76e619c8
--- /dev/null
+++ b/collects/honu/examples/uminus.honu
@@ -0,0 +1,13 @@
+type t1 {
+  int x();
+}
+
+class c() : t1 impl t1 {
+  int x() { return 7; }
+  export t1 : x;
+}
+
+int main() {
+  t1 x = new c:t1();
+  -x.x();
+}
diff --git a/collects/honu/honu-compile-context.ss b/collects/honu/honu-compile-context.ss
new file mode 100644
index 0000000000..2e5b7768dc
--- /dev/null
+++ b/collects/honu/honu-compile-context.ss
@@ -0,0 +1,4 @@
+(module honu-compile-context (lib "base.ss" "honu")
+
+  (provide honu-compile-context)
+  (define honu-compile-context #'here))
diff --git a/collects/honu/honu.gif b/collects/honu/honu.gif
new file mode 100644
index 0000000000..948042dc26
Binary files /dev/null and b/collects/honu/honu.gif differ
diff --git a/collects/honu/info.ss b/collects/honu/info.ss
new file mode 100644
index 0000000000..b9f88eeec2
--- /dev/null
+++ b/collects/honu/info.ss
@@ -0,0 +1,5 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Honu")
+  (define doc.txt "doc.txt")
+  (define tools (list (list "tool.ss")))
+  (define tool-icons '(("honu.gif" "honu"))))
diff --git a/collects/honu/parsers/parse.ss b/collects/honu/parsers/parse.ss
new file mode 100644
index 0000000000..a9d16111f3
--- /dev/null
+++ b/collects/honu/parsers/parse.ss
@@ -0,0 +1,828 @@
+(module parse mzscheme
+  (require (lib "lex.ss" "parser-tools")
+           (prefix : (lib "lex-sre.ss" "parser-tools"))
+           (lib "yacc.ss" "parser-tools")
+           (lib "readerr.ss" "syntax")
+           "../ast.ss")
+  
+  (define (make-struct-type-decls mfidefns)
+    (define (convert-to-decl d)
+      (cond
+        [(honu-init-field? d)
+         (make-honu-field-decl (honu-ast-src-stx d)
+                               (honu-init-field-name d)
+                               (honu-init-field-type d))]
+        [(honu-field? d)
+         (make-honu-field-decl (honu-ast-src-stx d)
+                               (honu-field-name d)
+                               (honu-field-type d))]
+        [(honu-method? d)
+         (make-honu-method-decl (honu-ast-src-stx d)
+                                (honu-method-name d)
+                                (honu-method-type d)
+                                (honu-method-arg-types d))]))
+    (map convert-to-decl mfidefns))
+  
+  (define (make-struct-exports typ mfidefns)
+    (define (grab-name d)
+      (cond
+        [(honu-init-field? d) (honu-init-field-name d)]
+        [(honu-field? d)      (honu-field-name d)]
+        [(honu-method? d)     (honu-method-name d)]))
+    (let ((names (map grab-name mfidefns)))
+      (list (make-honu-export #f typ names names))))
+  
+  (define-lex-abbrevs [lex:letter (:or (:/ #\a #\z) (:/ #\A #\Z))]
+    [lex:digit (:/ #\0 #\9)]
+    [lex:whitespace (:or #\newline #\return #\tab #\space #\vtab)])
+  
+  (define-tokens EOF
+    (EOF))
+  
+  (define-empty-tokens for-prec
+    (UMINUS))
+  
+  (define-tokens lex-errors
+    (UNPARSEABLE))
+  
+  (define-tokens keywords
+    (type interface class mixin subclass struct
+          extends final impl implements
+          init export as at with
+          this my null isa
+          int bool str float char Any void
+          if else true false while fun
+          new super cast return))
+  
+  (define-tokens separators
+    (O_CURLY C_CURLY O_BRACE C_BRACE O_PAREN C_PAREN COMMA COLON SEMI_COLON BINDS DOT SUBTYPE ARROW))
+  
+  (define-tokens operators
+    (NOT OR AND NEQ EQUALS LT LE GT GE PLUS MINUS TIMES DIV MOD CLS_EQ))
+  
+  (define-tokens val-tokens
+    (character floatnum string integer id))
+  
+  (define stx-for-original-property (read-syntax #f (open-input-string "original")))
+  
+  (define (create-src-stx val source-name start-pos end-pos)
+    (datum->syntax-object #f val
+                          (list
+                           source-name
+                           (position-line start-pos)
+                           (position-col start-pos)
+                           (position-offset start-pos)
+                           (- (position-offset end-pos)
+                              (position-offset start-pos)))
+                          stx-for-original-property))
+  
+  (define (raise-read-error-with-stx str stx)
+    (raise-read-error str
+                      (syntax-source stx)
+                      (syntax-line stx)
+                      (syntax-column stx)
+                      (syntax-position stx)
+                      (syntax-span stx)))
+  
+  (define-syntax (token stx)
+    (syntax-case stx ()
+      [(_ name val)
+       (identifier? (syntax name))
+       (let ([name (syntax name)])
+         (with-syntax ([token-name (datum->syntax-object
+                                    name
+                                    (string->symbol
+                                     (format "token-~a" (syntax-e name))))]
+                       [source-name (datum->syntax-object name 'source-name)]
+                       [start-pos (datum->syntax-object name 'start-pos)]
+                       [end-pos (datum->syntax-object name 'end-pos)])
+           (syntax 
+            (token-name 
+             (create-src-stx val source-name start-pos end-pos)))))]))
+  
+  (define-syntax (ttoken stx)
+    (syntax-case stx ()
+      [(_ name)
+       (identifier? (syntax name))
+       (syntax (token name 'name))]))
+  
+  
+  (define (generate-honu-lexer source-name)
+    (define honu-lexer 
+      (lexer-src-pos
+       ["type"       (ttoken type)]
+       ["interface"  (ttoken interface)]
+       ["class"      (ttoken class)]
+       ["mixin"      (ttoken mixin)]
+       ["subclass"   (ttoken subclass)]
+       ["struct"     (ttoken struct)]
+       ["extends"    (ttoken extends)]
+       ["final"      (ttoken final)]
+       ["impl"       (ttoken impl)]
+       ["implements" (ttoken implements)]
+       ["init"       (ttoken init)]
+       ["export"     (ttoken export)]
+       ["as"         (ttoken as)]
+       ["at"         (ttoken at)]
+       ["with"       (ttoken with)]
+       ["fun"        (ttoken fun)]
+       ["this"       (ttoken this)]
+       ["my"         (ttoken my)]
+       ["null"       (ttoken null)]
+       ["isa"        (ttoken isa)]
+       ["int"        (ttoken int)]
+       ["bool"       (ttoken bool)]
+       ["str"        (ttoken str)]
+       ["float"      (ttoken float)]
+       ["char"       (ttoken char)]
+       ["Any"        (ttoken Any)]
+       ["void"       (ttoken void)]
+       ["while"      (ttoken while)]
+       ["if"         (ttoken if)]
+       ["else"       (ttoken else)]
+       ["true"       (token true  #t)]
+       ["false"      (token false #f)]
+       ["new"        (ttoken new)]
+       ["super"      (ttoken super)]
+       ["cast"       (ttoken cast)]
+       ["return"     (ttoken return)]
+       ["{"          (ttoken O_CURLY)]
+       ["}"          (ttoken C_CURLY)]
+       ["["          (ttoken O_BRACE)]
+       ["]"          (ttoken C_BRACE)]
+       ["("          (ttoken O_PAREN)]
+       [")"          (ttoken C_PAREN)]
+       [","          (ttoken COMMA)]
+       [":"          (ttoken COLON)]
+       [";"          (ttoken SEMI_COLON)]
+       ["->"         (token ARROW   'arrow)]
+       ["="          (token BINDS   'binds)]
+       ["!="         (token NEQ     'neq)]
+       ["=="         (token EQUALS  'equal)]
+       ["===="       (token CLS_EQ  'cls_eq)]
+       ["!"          (token NOT     'not)]
+       ["&&"         (token AND     'and)]
+       ["||"         (token OR      'or)]
+       ["<"          (token LT      'lt)]
+       ["<="         (token LE      'le)]
+       [">"          (token GT      'gt)]
+       [">="         (token GE      'ge)]
+       ["+"          (token PLUS    'plus)]
+       ["-"          (token MINUS   'minus)]
+       ["*"          (token TIMES   'times)]
+       ["/"          (token DIV     'div)]
+       ["%"          (token MOD     'mod)]
+       ["."          (token DOT     'dot)]
+       ["<:"         (token SUBTYPE 'subtype)]
+       [(:: (:or lex:letter)
+            (:* (:or #\_ lex:letter lex:digit)))
+        (token id (string->symbol lexeme))]
+       [(:: (:? #\-)
+            (:+ lex:digit))
+        (token integer (string->number lexeme))]
+       [(:: (:? #\-)
+            (:: (:+ lex:digit) #\. (:+ lex:digit)))
+        (token floatnum (string->number lexeme))]
+       [(:: #\' any-char #\')
+        (token character (string-ref lexeme 1))]
+       [(:: #\"                           ;; A quoted string starts with a "
+            (:* (:or (:~ #\\ #\")         ;; and has things in it which are
+                     (:: #\\ any-char)))  ;; not "s (but \" is okay)
+            #\")                          ;; and ends with a ".
+        (token string (substring lexeme 1 (- (string-length lexeme) 1)))]
+       [(:: "//"
+            (:* (:~ #\newline)))
+        (return-without-pos (honu-lexer input-port))]
+       [(:: #\/ #\*)
+        (begin (comment-lexer source-name start-pos input-port) ;; Get the rest of the comment...
+               (return-without-pos (honu-lexer input-port)))]   ;; then get the next token.
+       [(:+ lex:whitespace)
+        (return-without-pos (honu-lexer input-port))]
+       [(eof)
+        (ttoken EOF)]
+       [any-char (token UNPARSEABLE (string->symbol lexeme))]))
+    honu-lexer)
+  
+  (define comment-lexer
+    (lambda (source-name first-pos port)
+      (letrec ([lxr (lexer-src-pos
+                     [(:: #\/ #\*)
+                      (begin (lxr input-port)                        ;; once for the nested comment
+                             (return-without-pos (lxr input-port)))] ;; now finish out the current one
+                     [(:: #\* #\/)
+                      #f] ;; This will get ignored by the call to comment-lexer (whether nested or no)
+                     [(eof)
+                      (raise-read-error-with-stx
+                       "Unexpected end of file while inside block comment."
+                       (create-src-stx eof source-name first-pos end-pos))]
+                     [(:~)
+                      (return-without-pos (lxr input-port))])])
+        (lxr port))))
+  
+  (define (generate-honu-parser source-name)
+    (define honu-parser
+      (parser
+       (start program interact)
+       (end EOF)
+       (src-pos)
+       ;; (debug "honu.debug")
+       ;; (yacc-output "honu.yacc")
+       ;; Since we have things that can look like x.y.z.w(...), we need to
+       ;; actually specify a precedence for DOT.  There are 3 shift/reduce
+       ;; conflicts for it, so if that warning is seen, it can be safely
+       ;; ignored.  I don't want to turn off the warnings yet in case this
+       ;; number increases, which means that I've added additional
+       ;; conflicts.
+       (precs (left else)
+              (left BINDS)
+              (left OR)
+              (left AND)
+              (left NEQ EQUALS)
+              (nonassoc CLS_EQ)
+              (nonassoc LT LE GT GE)
+              (left PLUS MINUS)
+              (left TIMES DIV MOD)
+              (nonassoc NOT UMINUS)
+              (right COLON isa)
+              (left DOT))
+       (tokens keywords separators operators val-tokens lex-errors EOF for-prec)
+       (error (lambda (a b stx start end) 
+                (raise-read-error-with-stx
+                 (format "parse error near ~a" (syntax-e stx))
+                 stx)))
+       (grammar
+        (program
+         [(defns)
+          (make-honu-program $1)])
+        (defns
+          [(defn defns)
+           (if (honu-ast? $1)
+               (cons $1 $2)
+               (append $1 $2))]
+          [()
+           (list)])
+        (defn
+          [(fun-defn)
+           $1]
+          [(type-defn)
+           $1]
+          [(class-defn)
+           $1]
+          [(struct-defn)
+           $1]
+          [(mixin-defn)
+           $1]
+          [(subclass-defn)
+           $1])
+        
+        (fun-defn
+         [(any-type id O_PAREN args C_PAREN block)
+          (make-honu-function
+           (create-src-stx 'honu-function source-name $1-start-pos $6-end-pos)
+           $2 $1 (cdr $4) (car $4) $6)])
+        
+        ;; Type definitions and needed parts
+        
+        (type-defn
+         [(type id ext-clause
+                O_CURLY fmdecs C_CURLY)
+          (make-honu-type-defn 
+           (create-src-stx 'honu-type-defn source-name $1-start-pos $6-end-pos) 
+           $2 $3 $5)]
+         [(interface id ext-clause
+            O_CURLY fmdecs C_CURLY)
+          (make-honu-type-defn
+           (create-src-stx 'honu-type-defn source-name $1-start-pos $6-end-pos) 
+           $2 $3 $5)])
+        (type-id
+         [(id)
+          (make-honu-iface-type $1 $1)]
+         [(Any)
+          (make-honu-iface-top-type
+           (create-src-stx 'Any source-name $1-start-pos $1-end-pos))])
+        (any-type
+         [(type-id)
+          $1]
+         [(void)
+          (make-honu-top-type 
+           (create-src-stx 'void source-name $1-start-pos $1-end-pos))]
+         [(int)
+          (make-honu-prim-type $1 'int)]
+         [(bool)
+          (make-honu-prim-type $1 'bool)]
+         [(float)
+          (make-honu-prim-type $1 'float)]
+         [(char)
+          (make-honu-prim-type $1 'char)]
+         [(str)
+          (make-honu-prim-type $1 'str)]
+         [(O_BRACE tup-type C_BRACE ARROW any-type)
+          (make-honu-func-type 
+           (create-src-stx 'honu-func-type source-name $2-start-pos $5-end-pos)
+           $2 $5)])
+        (tup-type
+         [()
+          (list)]
+         [(tup-type+)
+          $1])
+        (tup-type+
+         [(any-type)
+          (list $1)]
+         [(any-type COMMA tup-type+)
+          (cons $1 $3)])
+        (ext-clause
+         [(extends type-ids+)
+          $2]
+         [(SUBTYPE type-ids+)
+          $2]
+         [()
+          '()])
+        (ids+
+         [(id COMMA ids+)
+          (cons $1 $3)]
+         [(id)
+          (list $1)])
+        (type-ids+
+         [(type-id COMMA type-ids+)
+          (cons $1 $3)]
+         [(type-id)
+          (list $1)])
+        (args
+         [(args-cd)
+          $1]
+         [()
+          (cons (list) (list))])
+        (args-cd
+         [(arg COMMA args-cd)
+          (cons (cons (car $1) (car $3)) (cons (cdr $1) (cdr $3)))]
+         [(arg)
+          (cons (list (car $1)) (list (cdr $1)))])
+        (arg
+         [(any-type id)
+          (cons $1 $2)])
+        (fmdecs
+         [(fdec fmdecs)
+          (cons $1 $2)]
+         [(mdec fmdecs)
+          (cons $1 $2)]
+         [()
+          (list)])
+        (fdec
+         [(any-type field-id SEMI_COLON)
+          (make-honu-field-decl
+           (create-src-stx 'honu-field-decl source-name $1-start-pos $3-end-pos)
+           $2 $1)])
+        (field-id
+         [(id)
+          $1])
+        (mdec
+         [(any-type meth-id O_PAREN mdec-args C_PAREN SEMI_COLON)
+          (make-honu-method-decl
+           (create-src-stx 'honu-method-decl source-name $1-start-pos $6-end-pos)
+           $2 $1 $4)])
+        (meth-id
+         [(id)
+          $1])
+        (mdec-args
+         [(mdec-args-cd)
+          $1]
+         [()
+          (list)])
+        (mdec-args-cd
+         [(mdec-arg COMMA mdec-args-cd)
+          (cons $1 $3)]
+         [(mdec-arg)
+          (list $1)])
+        (mdec-arg
+         [(any-type)
+          $1]
+         [(any-type id)
+          $1])
+        
+        
+        (struct-defn
+         [(struct class-id init-args COLON type-id O_CURLY fmidefns C_CURLY)
+          (let ([struct-stx (create-src-stx 'honu-struct source-name $1-start-pos $8-end-pos)])
+            (list (make-honu-type-defn struct-stx (honu-iface-type-name $5) (list) (make-struct-type-decls $7))
+                  (make-honu-class struct-stx $2 $5 #f (cdr $3) (car $3) (list $5) $7
+                                   (make-struct-exports $5 $7))))]
+         [(final struct class-id init-args COLON type-id O_CURLY fmidefns C_CURLY)
+          (let ([struct-stx (create-src-stx 'honu-struct source-name $1-start-pos $9-end-pos)])
+            (list (make-honu-type-defn struct-stx (honu-iface-type-name $6) (list) (make-struct-type-decls $8))
+                  (make-honu-class struct-stx $3 $6 #t (cdr $4) (car $4) (list $6) $8
+                                   (make-struct-exports $6 $8))))])
+        
+        ;; Class definitions and needed parts
+        
+        (class-defn
+         [(class class-id init-args COLON type-id imp-clause
+            O_CURLY fmidefns exports C_CURLY)
+          (make-honu-class 
+           (create-src-stx 'honu-class source-name $1-start-pos $10-end-pos)
+           $2 $5 #f (cdr $3) (car $3) $6 $8 $9)]
+         [(final class class-id init-args COLON type-id imp-clause
+                 O_CURLY fmidefns exports C_CURLY)
+          (make-honu-class
+           (create-src-stx 'honu-class source-name $1-start-pos $11-end-pos)
+           $3 $6 #t (cdr $4) (car $4) $7 $9 $10)])
+        (class-id
+         [(id)
+          $1])
+        (init-args
+         [(O_PAREN args-cd C_PAREN)
+          $2]
+         [(O_PAREN C_PAREN)
+          (cons (list) (list))])
+        (imp-clause
+         [(impl type-ids+)
+          $2]
+         [(implements type-ids+)
+          $2]
+         [()
+          '()])
+        (fmidefns
+         [(fdefn fmidefns)
+          (cons $1 $2)]
+         [(mdefn fmidefns)
+          (cons $1 $2)]
+         [(initdefn fmidefns)
+          (cons $1 $2)]
+         [()
+          (list)])
+        (fdefn
+         [(any-type field-id BINDS expr SEMI_COLON)
+          (make-honu-field
+           (create-src-stx 'honu-field source-name $1-start-pos $5-end-pos)
+           $2 $1 $4)])
+        (mdefn
+         [(any-type meth-id O_PAREN args C_PAREN block)
+          (make-honu-method
+           (create-src-stx 'honu-method source-name $1-start-pos $6-end-pos)
+           $2 $1 (cdr $4) (car $4) $6)])
+        (initdefn
+         [(init any-type field-id SEMI_COLON)
+          (make-honu-init-field
+           (create-src-stx 'honu-init-field source-name $1-start-pos $4-end-pos)
+           $3 $2 #f)]
+         [(init any-type field-id BINDS expr SEMI_COLON)
+          (make-honu-init-field
+           (create-src-stx 'honu-init-field source-name $1-start-pos $4-end-pos)
+           $3 $2 $5)])
+        (exports
+         [(expdefn exports)
+          (cons $1 $2)]
+         [()
+          (list)])
+        (expdefn
+         [(export type-id COLON expdecs SEMI_COLON)
+          (make-honu-export
+           (create-src-stx 'honu-export source-name $1-start-pos $5-end-pos)
+           $2 (car $4) (cdr $4))]
+         [(export type-id SEMI_COLON)
+          (make-honu-export
+           (create-src-stx 'honu-export source-name $1-start-pos $3-end-pos)
+           $2 (list) (list))])
+        (expdecs
+         [(expdec COMMA expdecs)
+          (cons (cons (car $1) (car $3)) (cons (cdr $1) (cdr $3)))]
+         [(expdec)
+          (cons (list (car $1)) (list (cdr $1)))])
+        (expdec
+         [(id as id)
+          (cons $1 $3)]
+         [(id)
+          (cons $1 $1)])
+        
+        ;; Mixin definitions
+        
+        (mixin-defn
+         [(mixin mixin-id init-args COLON type-id at type-id imp-clause with-clause
+            O_CURLY fmidefns supernew fmidefns exports C_CURLY)
+          (make-honu-mixin
+           (create-src-stx 'honu-mixin source-name $1-start-pos $15-end-pos)
+           $2 $5 $7 #f (cdr $3) (car $3) $8 (cdr $9) (car $9) $11 $12 $13 $14)]
+         [(final mixin mixin-id init-args COLON type-id at type-id imp-clause with-clause
+                 O_CURLY fmidefns supernew fmidefns exports C_CURLY)
+          (make-honu-mixin 
+           (create-src-stx 'honu-mixin source-name $1-start-pos $16-end-pos)
+           $3 $6 $8 #t (cdr $4) (car $4) $9 (cdr $10) (car $10) $12 $13 $14 $15)])
+        (mixin-id
+         [(id)
+          $1])
+        (with-clause
+         [(with args-cd)
+          $2]
+         [()
+          (cons (list) (list))])
+        (supernew
+         [(super O_PAREN newargs C_PAREN SEMI_COLON)
+          (make-honu-super-new 
+           (create-src-stx 'honu-super-new source-name $1-start-pos $4-end-pos)
+           (car $3) (cdr $3))])
+        
+        ;; Subclass definitions
+        
+        (subclass-defn
+         [(subclass class-id BINDS mixin-id O_PAREN class-id C_PAREN SEMI_COLON)
+          (make-honu-subclass
+           (create-src-stx 'honu-subclass source-name $1-start-pos $8-end-pos)
+           $2 $4 $6)]
+         [(subclass class-id init-args COLON type-id extends class-id at type-id imp-clause with-clause
+                    O_CURLY fmidefns supernew fmidefns exports C_CURLY)
+          (let ([mixin-name (datum->syntax-object $2 (string->symbol (string-append "$" (symbol->string (syntax-e $2)))) $2)]
+                [subclass-stx (create-src-stx 'honu-subclass source-name $1-start-pos $17-end-pos)])
+            (list (make-honu-mixin subclass-stx mixin-name $5 $9 #f (cdr $3) (car $3) $10 (cdr $11) (car $11) $13 $14 $15 $16)
+                  (make-honu-subclass subclass-stx $2 mixin-name $7)))]
+         [(final subclass class-id init-args COLON type-id extends class-id at type-id imp-clause with-clause
+                 O_CURLY fmidefns supernew fmidefns exports C_CURLY)
+          (let ([mixin-name (datum->syntax-object $3 (string->symbol (string-append "$" (symbol->string (syntax-e $3)))))]
+                [subclass-stx (create-src-stx 'honu-subclass source-name $1-start-pos $18-end-pos)])
+            (list (make-honu-mixin subclass-stx mixin-name $6 $10 #f (cdr $4) (car $4) $11 (cdr $12) (car $12) $14 $15 $16 $17)
+                  (make-honu-subclass subclass-stx $3 mixin-name $8)))])
+        
+        ;; Expressions
+        
+        (block
+         [(O_CURLY bindings expr-sc+ C_CURLY)
+          (make-honu-block
+           (create-src-stx 'honu-block source-name $1-start-pos $4-end-pos)
+           (reverse $2) $3)])
+        (expr-sc+
+         [(expr-sc expr-sc+)
+          (cons $1 $2)]
+         [(expr-sc)
+          (list $1)])
+        (expr-sc
+         [(expr SEMI_COLON)
+          $1]
+         [(return SEMI_COLON)
+          (make-honu-return 
+           (create-src-stx 'honu-return source-name $1-start-pos $2-end-pos)
+           #f)]
+         [(return expr SEMI_COLON)
+          (make-honu-return
+           (create-src-stx 'honu-return source-name $1-start-pos $3-end-pos)
+           $2)])
+        (expr
+         [(MINUS expr)
+          (prec UMINUS)
+          (make-honu-uprim 
+           (create-src-stx 'honu-uprim source-name $1-start-pos $2-end-pos)
+           'minus $1 #f $2)]
+         [(NOT expr)
+          (make-honu-uprim 
+           (create-src-stx 'honu-uprim source-name $1-start-pos $2-end-pos)
+           'not $1 #f $2)]
+         [(expr OR expr)
+          (make-honu-prim
+           (create-src-stx 'honu-prim source-name $1-start-pos $3-end-pos)
+           'or $2 #f $1 $3)]
+         [(expr AND expr)
+          (make-honu-prim
+           (create-src-stx 'honu-prim source-name $1-start-pos $3-end-pos)
+           'and $2 #f $1 $3)]
+         [(expr CLS_EQ expr)
+          (make-honu-prim
+           (create-src-stx 'honu-prim source-name $1-start-pos $3-end-pos)
+           'clseq $2 #f $1 $3)]
+         [(expr NEQ expr)
+          (make-honu-prim
+           (create-src-stx 'honu-prim source-name $1-start-pos $3-end-pos)
+           'neq $2 #f $1 $3)]
+         [(expr EQUALS expr)
+          (make-honu-prim
+           (create-src-stx 'honu-prim source-name $1-start-pos $3-end-pos)
+           'equal $2 #f $1 $3)]
+         [(expr LT expr)
+          (make-honu-prim
+           (create-src-stx 'honu-prim source-name $1-start-pos $3-end-pos)
+           'lt $2 #f $1 $3)]
+         [(expr LE expr)
+          (make-honu-prim
+           (create-src-stx 'honu-prim source-name $1-start-pos $3-end-pos)
+           'le $2 #f $1 $3)]
+         [(expr GT expr)
+          (make-honu-prim
+           (create-src-stx 'honu-prim source-name $1-start-pos $3-end-pos)
+           'gt $2 #f $1 $3)]
+         [(expr GE expr)
+          (make-honu-prim
+           (create-src-stx 'honu-prim source-name $1-start-pos $3-end-pos)
+           'ge $2 #f $1 $3)]
+         [(expr PLUS expr)
+          (make-honu-prim
+           (create-src-stx 'honu-prim source-name $1-start-pos $3-end-pos)
+           'plus $2 #f $1 $3)]
+         [(expr MINUS expr)
+          (make-honu-prim
+           (create-src-stx 'honu-prim source-name $1-start-pos $3-end-pos)
+           'minus $2 #f $1 $3)]
+         [(expr TIMES expr)
+          (make-honu-prim
+           (create-src-stx 'honu-prim source-name $1-start-pos $3-end-pos)
+           'times $2 #f $1 $3)]
+         [(expr DIV expr)
+          (make-honu-prim
+           (create-src-stx 'honu-prim source-name $1-start-pos $3-end-pos)
+           'div $2 #f $1 $3)]
+         [(expr MOD expr)
+          (make-honu-prim
+           (create-src-stx 'honu-prim source-name $1-start-pos $3-end-pos)
+           'mod $2 #f $1 $3)]
+         [(expr DOT field-id)
+          (make-honu-facc
+           (create-src-stx 'honu-facc source-name $1-start-pos $3-end-pos)
+           $1 #f $3)]
+         [(expr DOT field-id BINDS expr)
+          (make-honu-fassn
+           (create-src-stx 'honu-fassn source-name $1-start-pos $5-end-pos)
+           $1 #f $3 $5)]
+         [(expr DOT meth-id O_PAREN exprs C_PAREN)
+          (make-honu-mcall
+           (create-src-stx 'honu-mcall source-name $1-start-pos $6-end-pos)
+           $1 #f $3 $5)]
+         [(my DOT field-id)
+          (make-honu-facc
+           (create-src-stx 'honu-facc source-name $1-start-pos $3-end-pos)
+           'my #f $3)]
+         [(my DOT field-id BINDS expr)
+          (make-honu-fassn
+           (create-src-stx 'honu-fassn source-name $1-start-pos $5-end-pos)
+           'my #f $3 $5)]
+         [(my DOT meth-id O_PAREN exprs C_PAREN)
+          (make-honu-mcall
+           (create-src-stx 'honu-mcall source-name $1-start-pos $6-end-pos)
+           'my #f $3 $5)]
+         [(fun O_PAREN args C_PAREN block)
+          (make-honu-lambda 
+           (create-src-stx 'honu-lambda source-name $1-start-pos $5-end-pos)
+           (cdr $3) (car $3) $5)]
+         [(null)
+          (make-honu-null $1)]
+         [(literal)
+          $1]
+         [(this)
+          (make-honu-this $1)]
+         [(id)
+          (make-honu-var $1 $1 #f)]
+         [(id BINDS expr)
+          (make-honu-assn 
+           (create-src-stx 'honu-assn source-name $1-start-pos $3-end-pos)
+           $1 $3)]
+         [(id O_PAREN exprs C_PAREN)
+          (make-honu-call
+           (create-src-stx 'honu-call source-name $1-start-pos $4-end-pos)
+           $1 $3 #f)]
+         [(new class-id COLON type-id O_PAREN newargs C_PAREN)
+          (make-honu-new 
+           (create-src-stx 'honu-new source-name $1-start-pos $7-end-pos)
+           $2 $4 (car $6) (cdr $6))]
+         [(new class-id O_PAREN newargs C_PAREN)
+          (make-honu-new 
+           (create-src-stx 'honu-new source-name $1-start-pos $5-end-pos)
+           $2 #f (car $4) (cdr $4))]
+         [(expr COLON type-id)
+          (make-honu-cast 
+           (create-src-stx 'honu-cast source-name $1-start-pos $3-end-pos)
+           $1 $3)]
+         [(expr isa type-id)
+          (make-honu-isa 
+           (create-src-stx 'honu-isa source-name $1-start-pos $3-end-pos)
+           $1 $3)]
+         [(if expr block else block)
+          (make-honu-if 
+           (create-src-stx 'honu-if source-name $1-start-pos $5-end-pos)
+           $2 $3 $5)]
+         [(while expr block)
+          (make-honu-while
+           (create-src-stx 'honu-while source-name $1-start-pos $3-end-pos)
+           $2 $3)]
+         [(O_PAREN expr C_PAREN)
+          $2]
+         [(block)
+          $1])
+        (literal
+         [(true)
+          (make-honu-bool $1 (syntax-e $1))]
+         [(false)
+          (make-honu-bool $1 (syntax-e $1))]
+         [(integer)
+          (make-honu-int $1 (syntax-e $1))]
+         [(floatnum)
+          (make-honu-float $1 (syntax-e $1))]
+         [(character)
+          (make-honu-char $1 (syntax-e $1))]
+         [(string)
+          (make-honu-str $1 (syntax-e $1))])
+        (newargs
+         [(newargs-cd)
+          $1]
+         [()
+          (cons (list) (list))])
+        (newargs-cd
+         [(newarg COMMA newargs-cd)
+          (cons (cons (car $1) (car $3))
+                (cons (cdr $1) (cdr $3)))]
+         [(newarg)
+          (cons (list (car $1)) (list (cdr $1)))])
+        (newarg
+         [(id BINDS expr)
+          (cons $1 $3)])
+        (exprs
+         [(exprs-cd)
+          $1]
+         [()
+          '()])
+        (exprs-cd
+         [(expr COMMA exprs-cd)
+          (cons $1 $3)]
+         [(expr)
+          (list $1)])
+        (bindings
+         [(bindings binding)
+          (cons $2 $1)]
+         [()
+          '()])
+        (binding
+         [(any-type id BINDS expr SEMI_COLON)
+          (make-honu-binding
+           (create-src-stx 'honu-binding source-name $1-start-pos $5-end-pos)
+           $2 $1 $4)])
+        (interact
+         [(binding)
+          $1]
+         [(expr)
+          $1]))))
+    honu-parser)
+  
+  (define (parse-interaction port file)
+    (let ([lexer  (generate-honu-lexer file)]
+          [parser (cadr (generate-honu-parser file))])
+      (port-count-lines! port)
+      (parser
+       (lambda ()
+         (lexer port)))))
+  
+  (define (parse-port port file)
+    (let ([lexer  (generate-honu-lexer  file)]
+          [parser (car (generate-honu-parser file))])
+      (port-count-lines! port)
+      (parser
+       (lambda () 
+         (lexer port)))))
+  
+  (define (parse-file file)
+    (with-input-from-file file
+      (lambda ()
+        (parse-port (current-input-port)
+                    (simplify-path (path->complete-path file))))))
+  
+  (define (parse-stdin)
+    (parse-port (current-input-port) #f))
+  
+  (define (parse-string string)
+    (parse-port (open-input-string string) #f))
+  
+  (define (read-cm port)
+    (let loop ((filenames '())
+               (val (read port)))
+      (if (eof-object? val)
+          (reverse filenames)
+          (loop (cons (string-append val ".honu") filenames)
+                (read port)))))
+  
+  (define (parse-group port name)
+    (let ([filenames (read-cm port)])
+      (if (null? filenames)
+          (make-honu-program '())
+          (let loop ((filenames filenames)
+                     (defns     '()))
+            (let ((parsed (parse-file 
+                           (simplify-path
+                            (path->complete-path (car filenames))))))
+              (if (null? (cdr filenames))
+                  (make-honu-program 
+                   (append (honu-program-defns parsed) defns))
+                  (loop (cdr filenames)
+                        (append (honu-program-defns parsed) defns))))))))
+  
+  (define (parse-group-file dirname filename)
+    (let ([filenames (call-with-input-file
+                         (string-append dirname "/" filename)
+                       read-cm)])
+      (if (null? filenames)
+          (make-honu-program '())
+          (let loop ((filenames filenames)
+                     (defns     '()))
+            (let ((parsed (parse-file (string-append dirname "/"
+                                                     (car filenames)))))
+              (if (null? (cdr filenames))
+                  (make-honu-program 
+                   (append (honu-program-defns parsed) defns))
+                  (loop (cdr filenames)
+                        (append (honu-program-defns parsed) defns))))))))
+  
+  (provide parse-file parse-port parse-stdin parse-string parse-group parse-group-file parse-interaction)
+  
+  )
+
diff --git a/collects/honu/private/compiler/honu-translate-class-utils.ss b/collects/honu/private/compiler/honu-translate-class-utils.ss
new file mode 100644
index 0000000000..a17ec7a1d1
--- /dev/null
+++ b/collects/honu/private/compiler/honu-translate-class-utils.ss
@@ -0,0 +1,178 @@
+(module honu-translate-class-utils mzscheme
+  
+  (require (lib "list.ss" "srfi" "1")
+           (prefix list: (lib "list.ss"))
+           (lib "plt-match.ss"))
+  
+  (require "../../ast.ss")
+  (require "../../tenv.ss")
+  (require "../typechecker/honu-type-utils.ss")
+  (require "honu-translate-utils.ss")
+  (require "honu-translate-expression.ss")
+  
+  (provide honu-translate-init-slots)
+  (define (honu-translate-init-slots slot-names)
+    (map (lambda (name)
+           (at name `(init ,(at-ctxt name))))
+         slot-names))
+  
+  (provide honu-translate-slotdefns)
+  (define (honu-translate-slotdefns tenv outer-defn defns)
+    (map (match-lambda
+           [(struct honu-init-field (stx name type value))
+            (if value
+                (at stx `(begin
+                           (init ([,(add-init name) ,(at-ctxt name)]
+                                  ,(honu-translate-expression tenv outer-defn value)))
+                           (define ,(at-ctxt name) ,(add-init name))))
+                (at stx `(begin
+                           (init ([,(add-init name) ,(at-ctxt name)]))
+                           (define ,(at-ctxt name) ,(add-init name)))))]
+           [(struct honu-field (stx name type value))
+            (at stx `(define ,(at-ctxt name)
+                       ,(honu-translate-expression tenv outer-defn value)))]
+           [(struct honu-method (stx name type arg-names arg-types body))
+            (if (honu-top-type? type)
+                (at stx `(define (,(at-ctxt name) ,@arg-names)
+                           ,(honu-translate-expression tenv outer-defn body)
+                           (void)))
+                (at stx `(define (,(at-ctxt name) ,@arg-names)
+                           ,(honu-translate-expression tenv outer-defn body))))])
+         defns))
+  
+  (define (add-init sym)
+    (at sym
+        (string->symbol
+         (string-append "init-" (symbol->string (printable-key sym))))))
+  
+  (define-struct pexp (new-name new-type old-name old-type method?))
+  
+  (provide honu-translate-exports)
+  (define (honu-translate-exports tenv defn prior-impls exports)
+    (let* ((processed-exports (apply append (map (lambda (e)
+                                                   (process-export tenv defn e))
+                                                 exports)))
+           (filtered-exports (filter-exports processed-exports)))
+      (map (lambda (pexp)
+             (generate-export tenv prior-impls pexp))
+           filtered-exports)))
+  
+  (define (check-prior-impls tenv prior-impls typ)
+    (ormap (lambda (t)
+             (<:_P tenv t typ))
+           prior-impls))
+  
+  (define (generate-export tenv prior-impls pexp)
+    (let ([new-name (pexp-new-name pexp)]
+          [new-type (pexp-new-type pexp)]
+          [old-name (pexp-old-name pexp)]
+          [old-type (pexp-old-type pexp)]
+          [method?  (pexp-method?  pexp)])
+      (let ([define-sym (if (check-prior-impls tenv prior-impls new-type)
+                            'define/override
+                            'define/public)])
+        (if method?
+            (if old-type
+                `(,define-sym (,(honu-translate-dynamic-method-name tenv new-name new-type) . args)
+                   (super ,(honu-translate-dynamic-method-name tenv old-name old-type) . args))
+                `(,define-sym (,(honu-translate-dynamic-method-name tenv new-name new-type) . args)
+                   (apply ,(at-ctxt old-name) args)))
+            (if old-type
+                `(begin
+                   (,define-sym (,(honu-translate-dynamic-field-getter tenv new-name new-type))
+                     (super ,(honu-translate-dynamic-field-getter tenv old-name old-type)))
+                   (,define-sym (,(honu-translate-dynamic-field-setter tenv new-name new-type) val)
+                     (super ,(honu-translate-dynamic-field-setter tenv old-name old-type) val)))
+                `(begin
+                   (,define-sym (,(honu-translate-dynamic-field-getter tenv new-name new-type))
+                     ,(at-ctxt old-name))
+                   (,define-sym (,(honu-translate-dynamic-field-setter tenv new-name new-type) val)
+                     (set! ,(at-ctxt old-name) val)
+                     (void))))))))
+  
+  (define (process-export tenv defn e)
+    (map (lambda (old new)
+           (process-names tenv defn (honu-export-type e) old new))
+         (honu-export-old-names e)
+         (honu-export-new-names e)))
+
+  (define (process-names tenv defn typ old new)
+    (let ((slotdefns (cond
+                       [(honu-class? defn)
+                        (honu-class-defns defn)]
+                       [(honu-mixin? defn)
+                        (append (honu-mixin-defns-before defn)
+                                (honu-mixin-defns-after defn))])))
+      (cond
+        [(find (lambda (s)
+                 (tenv-key=? old s))
+               (get-local-fields slotdefns))
+         (make-pexp new (find-type-for-name tenv new typ)
+                    old #f
+                    #f)]
+        [(find (lambda (s)
+                 (tenv-key=? old s))
+               (get-local-methods slotdefns))
+         (make-pexp new (find-type-for-name tenv new typ)
+                    old #f
+                    #t)]
+        [(and (honu-mixin? defn)
+              (find (lambda (s)
+                      (tenv-key=? old s))
+                    (get-field-names-for-type tenv (honu-mixin-arg-type defn))))
+         (make-pexp new (find-type-for-name tenv new typ)
+                    old (find-type-for-name tenv old (honu-mixin-arg-type defn))
+                    #f)]
+        [(and (honu-mixin? defn)
+              (find (lambda (s)
+                      (tenv-key=? old s))
+                    (get-method-names-for-type tenv (honu-mixin-arg-type defn))))
+         (make-pexp new (find-type-for-name tenv new typ)
+                    old (find-type-for-name tenv old (honu-mixin-arg-type defn))
+                    #t)]
+        [else (error (format "Shouldn't reach here!~n~nDefn~n~a~n~nTyp:~n~a~n~nOld:~n~a~n~nNew:~n~a~n~n"
+                             defn 
+                             (printable-key (honu-iface-type-name typ))
+                             (printable-key old)
+                             (printable-key new)))])))
+  
+  (define (pexp<? a b)
+    (or (string<? (symbol->string (printable-key (honu-iface-type-name (pexp-new-type a))))
+                  (symbol->string (printable-key (honu-iface-type-name (pexp-new-type b)))))
+        (and (tenv-key=? (honu-iface-type-name (pexp-new-type a))
+                         (honu-iface-type-name (pexp-new-type b)))
+             (string<? (symbol->string (printable-key (pexp-new-name a)))
+                       (symbol->string (printable-key (pexp-new-name b)))))))
+  
+  (define (pexp=? a b)
+    (and (tenv-key=? (honu-iface-type-name (pexp-new-type a))
+                     (honu-iface-type-name (pexp-new-type b)))
+         (tenv-key=? (pexp-new-name a)
+                     (pexp-new-name b))))
+    
+  (define (filter-exports pexps)
+    (let ((sorted-exports (list:quicksort pexps pexp<?)))
+      (let loop ((pexps sorted-exports)
+                 (acc   '()))
+        (cond
+          [(null? pexps)       (reverse acc)]
+          [(null? (cdr pexps)) (reverse (cons (car pexps) acc))]
+          [(pexp=? (car pexps)
+                   (cadr pexps)) (loop (cdr pexps) acc)]
+          [else (loop (cdr pexps) (cons (car pexps) acc))]))))
+  
+  (define (get-local-fields slotdefns)
+    (filter-map (lambda (d)
+                  (cond
+                    [(honu-init-field? d) (honu-init-field-name d)]
+                    [(honu-field? d) (honu-field-name d)]
+                    [else #f]))
+                slotdefns))
+  
+  (define (get-local-methods slotdefns)
+    (filter-map (lambda (d)
+                  (cond 
+                    [(honu-method? d) (honu-method-name d)]
+                    [else #f]))
+                slotdefns))
+  )
diff --git a/collects/honu/private/compiler/honu-translate-class.ss b/collects/honu/private/compiler/honu-translate-class.ss
new file mode 100644
index 0000000000..be0c63709d
--- /dev/null
+++ b/collects/honu/private/compiler/honu-translate-class.ss
@@ -0,0 +1,25 @@
+(module honu-translate-class mzscheme
+
+  (require (lib "list.ss" "srfi" "1")
+           (lib "plt-match.ss"))
+  
+  (require "../../ast.ss")
+  (require "../../tenv.ss")
+  (require "honu-translate-utils.ss")
+  (require "honu-translate-class-utils.ss")
+  (require "honu-translate-expression.ss")
+  
+  (provide honu-translate-class)
+  (define (honu-translate-class pgm cls)
+    (match cls
+      [(struct honu-class (stx name type final? init-names init-types impls defns exports))
+       (at stx `(define ,(honu-translate-class-name name)
+                  (parameterize ([current-inspector (make-inspector (current-inspector))])
+                    (define ,(honu-translate-class-name name)
+                      (class* object% ,(filter-map honu-translate-type-name impls)
+                        ,@(honu-translate-init-slots (honu-class-init-names cls))
+                        ,@(honu-translate-slotdefns pgm cls (honu-class-defns cls))
+                        ,@(honu-translate-exports pgm cls '() (honu-class-exports cls))
+                        (super-new)))
+                    ,(honu-translate-class-name name))))]))
+  )
diff --git a/collects/honu/private/compiler/honu-translate-expression.ss b/collects/honu/private/compiler/honu-translate-expression.ss
new file mode 100644
index 0000000000..8f9562e317
--- /dev/null
+++ b/collects/honu/private/compiler/honu-translate-expression.ss
@@ -0,0 +1,266 @@
+(module honu-translate-expression mzscheme
+
+  (require (all-except (lib "list.ss" "srfi" "1") any)
+           (lib "contract.ss")
+           (lib "plt-match.ss"))
+
+  (require "../../ast.ss")
+  (require "../../tenv.ss")
+  (require "honu-translate-utils.ss")
+  (require "../../read-error-with-stx.ss")
+  
+  (define (get-builtin-translation name)
+;    (case (printable-key name)
+;      [(println) (at name '(lambda (s) (display s) (newline)))]
+;      [(error) (at name '(lambda (s) (error s)))]))
+    ;; since we can change the context of identifiers, just make
+    ;; sure that the appropriate things are bound in honu-compile-context.
+    (at-ctxt name))
+  
+  (define (field-in-defn? field defn)
+    (or (find (lambda (n)
+                (tenv-key=? n field))
+              (cond
+                [(honu-class? defn) (honu-class-init-names defn)]
+                [(honu-mixin? defn) (honu-mixin-init-names defn)]))
+        (find (match-lambda
+                [(struct honu-field (_ name _ _))
+                 (tenv-key=? name field)]
+                [(struct honu-init-field (_ name _ _))
+                 (tenv-key=? name field)]
+                [_ #f])
+              (cond
+                [(honu-class? defn) (honu-class-defns defn)]
+                [(honu-mixin? defn) (append (honu-mixin-defns-before defn)
+                                            (honu-mixin-defns-after defn))]))))
+
+  (provide/contract [honu-translate-expression
+                     (tenv?
+                      (union false/c
+                             honu-defn?)
+                      honu-exp?
+                      . -> .
+;                      (syntax/c any/c))])
+                      any)])
+  (define (honu-translate-expression tenv defn exp)
+    (match exp
+      [(struct honu-null (stx))
+       (at stx 'null)]
+      
+      [(struct honu-int (stx val))
+       (at stx val)]
+      [(struct honu-float (stx val))
+       (at stx val)]
+      [(struct honu-char (stx val))
+       (at stx val)]
+      [(struct honu-str (stx val))
+       (at stx val)]
+      [(struct honu-bool (stx val))
+       (at stx val)]
+      
+      [(struct honu-var (stx name builtin?))
+       (if builtin?
+           (get-builtin-translation name)
+           name)]
+      [(struct honu-this (stx))
+       (at stx 'this)]
+      
+      [(struct honu-uprim (stx op op-stx op-type body))
+       (let ((body-exp (honu-translate-expression tenv defn body)))
+         (case op
+           [(not)
+            (at stx `(,(at op-stx 'not) ,body-exp))]
+           [(minus)
+            (at stx `(,(at op-stx '-) ,body-exp))]))]
+      [(struct honu-prim (stx op op-stx op-type left right))
+       (let ((left-exp (honu-translate-expression tenv defn left))
+             (right-exp (honu-translate-expression tenv defn right)))
+         (case op
+           [(plus)  
+            (if (eqv? 'str (honu-prim-type-name op-type))
+                (at stx `(,(at op-stx 'string-append) ,left-exp ,right-exp))
+                (at stx `(,(at op-stx '+) ,left-exp ,right-exp)))]
+           [(minus)
+            (at stx `(,(at op-stx '-) ,left-exp ,right-exp))]
+           [(times)
+            (at stx `(,(at op-stx '*) ,left-exp ,right-exp))]
+           [(div)   
+            (if (eqv? 'float (honu-prim-type-name op-type))
+                (at stx `(,(at op-stx '/) ,left-exp ,right-exp))
+                (at stx `(,(at op-stx 'quotient) ,left-exp ,right-exp)))]
+           [(mod)
+            (at stx `(,(at op-stx 'modulo) ,left-exp ,right-exp))]
+           [(lt)
+            (case (honu-prim-type-name op-type)
+              [(int float) 
+               (at stx `(,(at op-stx '<) ,left-exp ,right-exp))]
+              [(string)
+               (at stx `(,(at op-stx 'string<?) ,left-exp ,right-exp))]
+              [(char)
+               (at stx `(,(at op-stx 'char<?) ,left-exp ,right-exp))])]
+           [(le)
+            (case (honu-prim-type-name op-type)
+              [(int float) 
+               (at stx `(,(at op-stx '<=) ,left-exp ,right-exp))]
+              [(string)
+               (at stx `(,(at op-stx 'string<=?) ,left-exp ,right-exp))]
+              [(char)
+               (at stx `(,(at op-stx 'char<=?) ,left-exp ,right-exp))])]
+           [(gt)
+            (case (honu-prim-type-name op-type)
+              [(int float) 
+               (at stx `(,(at op-stx '>) ,left-exp ,right-exp))]
+              [(string)
+               (at stx `(,(at op-stx 'string>?) ,left-exp ,right-exp))]
+              [(char)
+               (at stx `(,(at op-stx 'char>?) ,left-exp ,right-exp))])]
+           [(ge)
+            (case (honu-prim-type-name op-type)
+              [(int float) 
+               (at stx `(,(at op-stx '>=) ,left-exp ,right-exp))]
+              [(string)
+               (at stx `(,(at op-stx 'string>=?) ,left-exp ,right-exp))]
+              [(char)
+               (at stx `(,(at op-stx 'char>=?) ,left-exp ,right-exp))])]
+           [(and)   
+            (at stx `(,(at op-stx 'and) ,left-exp ,right-exp))]
+           [(or)
+            (at stx `(,(at op-stx 'or) ,left-exp ,right-exp))]
+           [(clseq)
+            (at stx `(,(at op-stx 'equal?) ,left-exp ,right-exp))]
+           [(equal) 
+            (if (and (honu-prim-type? op-type)
+                     (eqv? 'str (honu-prim-type-name op-type)))
+                (at stx `(,(at op-stx 'string=?) ,left-exp ,right-exp))
+                (at stx `(,(at op-stx 'eqv?) ,left-exp ,right-exp)))]
+           [(neq) 
+            (if (and (honu-prim-type? op-type)
+                     (eqv? 'str (honu-prim-type-name op-type)))
+                (at stx `(,(at op-stx 'not) (,(at op-stx 'string=?) ,left-exp ,right-exp)))
+                (at stx `(,(at op-stx 'not) (,(at op-stx 'eqv?) ,left-exp ,right-exp))))]))]
+       
+      [(struct honu-lambda (stx arg-names _ body))
+       (at stx `(lambda ,(map (lambda (n) (at-ctxt n)) arg-names)
+                  ,(honu-translate-expression tenv defn body)))]
+      
+      [(struct honu-assn (stx name rhs))
+       (at stx `(set! ,(at-ctxt name)
+                      ,(honu-translate-expression tenv defn rhs)))]
+      [(struct honu-call (stx name args builtin?))
+       (let ([f (if builtin?
+                    (get-builtin-translation name)
+                    (at-ctxt name))])
+         (at stx (cons f (map (lambda (e)
+                                (honu-translate-expression tenv defn e))
+                              args))))]
+      
+      [(struct honu-facc (stx obj elab field))
+       (if (eqv? obj 'my)
+           (if (field-in-defn? field defn)
+               (at stx field)
+               (at stx `(super ,(honu-translate-dynamic-field-getter tenv 
+                                                                     field
+                                                                     (honu-mixin-arg-type defn)))))
+           (at stx `(send ,(honu-translate-expression tenv defn obj)
+                          ,(honu-translate-dynamic-field-getter tenv field elab))))]
+      [(struct honu-fassn (stx obj elab field rhs))
+       (if (eqv? (honu-fassn-obj exp) 'my)
+           (if (field-in-defn? field defn)
+               (at stx `(set! ,(at-ctxt field)
+                              ,(honu-translate-expression tenv defn rhs)))
+               (at stx `(super ,(honu-translate-dynamic-field-setter tenv
+                                                                     field
+                                                                     (honu-mixin-arg-type defn))
+                               ,(honu-translate-expression tenv defn rhs))))
+           (at stx `(send ,(honu-translate-expression tenv defn obj)
+                          ,(honu-translate-dynamic-field-setter tenv field elab)
+                          ,(honu-translate-expression tenv defn rhs))))]
+      [(struct honu-mcall (stx obj elab method args))
+       (if (eqv? obj 'my)
+           (if (find (match-lambda
+                       [(struct honu-method (_ name _ _ _ _))
+                        (tenv-key=? name method)]
+                       [_ #f])
+                     (cond
+                       [(honu-class? defn) (honu-class-defns defn)]
+                       [(honu-mixin? defn) (append (honu-mixin-defns-before defn)
+                                                   (honu-mixin-defns-after defn))]))
+               (at stx `(,(at-ctxt method)
+                          ,@(map (lambda (e)
+                                   (honu-translate-expression tenv defn e))
+                                 args)))
+               (at stx `(super ,(honu-translate-dynamic-method-name tenv
+                                                                    method
+                                                                    (honu-mixin-arg-type defn))
+                               ,@(map (lambda (e)
+                                        (honu-translate-expression tenv defn e))
+                                      args))))
+           (at stx `(send ,(honu-translate-expression tenv defn obj)
+                          ,(honu-translate-dynamic-method-name tenv method elab)
+                          ,@(map (lambda (e)
+                                   (honu-translate-expression tenv defn e))
+                                 args))))]
+      
+      [(struct honu-cast (stx obj type))
+       (let ([cast-type (honu-translate-type-name type)])
+         (if cast-type
+             (at stx `(let ((cast-obj ,(honu-translate-expression tenv defn obj)))
+                        (if (is-a? cast-obj ,cast-type)
+                            cast-obj
+                            (error "Cast failed!"))))
+             (honu-translate-expression tenv defn obj)))]
+      [(struct honu-isa (stx obj type))
+       (let ([isa-type (honu-translate-type-name type)])
+         (if isa-type
+             (at stx `(is-a? ,(honu-translate-expression tenv defn obj)
+                             ,isa-type))
+             (honu-translate-expression tenv defn (make-honu-bool stx #t))))]
+      
+      [(struct honu-new (stx class type arg-names arg-vals))
+       (at stx `(new ,(honu-translate-class-name class)
+                     ,@(map (lambda (a b) (list a (honu-translate-expression tenv defn b)))
+                            arg-names
+                            arg-vals)))]
+      
+      [(struct honu-if (stx cond true false))
+       (at stx `(if ,(honu-translate-expression tenv defn cond)
+                    ,(honu-translate-expression tenv defn true)
+                    ,(honu-translate-expression tenv defn false)))]
+      
+      [(struct honu-while (stx cond body))
+       (at stx `(let loop ()
+                  (if ,(honu-translate-expression tenv defn cond)
+                      (begin ,(honu-translate-expression tenv defn body)
+                             (loop)))))]
+      
+      [(struct honu-return (stx body))
+       (at stx (if body
+                   (honu-translate-expression tenv defn body)
+                   `(void)))]
+      [(struct honu-block (stx binds exps))
+       (at stx `(let* ,(map (lambda (b)
+                              (honu-translate-binding tenv defn b #f))
+                            binds)
+                  ,@(map (lambda (e)
+                           (honu-translate-expression tenv defn e))
+                         exps)))]))
+  
+  (provide/contract [honu-translate-binding
+                     (tenv?
+                      (union false/c
+                             honu-defn?)
+                      honu-binding?
+                      (union false/c
+                             (lambda (b) (eq? #t b)))
+                      . -> .
+;                      (syntax/c any/c))])
+                      any)])
+  (define (honu-translate-binding tenv defn bnd top-level?)
+    (match bnd
+      [(struct honu-binding (stx name _ rhs))
+       (if top-level?
+           (at stx `(define ,name 
+                      ,(honu-translate-expression tenv defn rhs)))
+           (at stx `[,(at-ctxt name) ,(honu-translate-expression tenv defn rhs)]))]))
+  )
+  
diff --git a/collects/honu/private/compiler/honu-translate-function.ss b/collects/honu/private/compiler/honu-translate-function.ss
new file mode 100644
index 0000000000..c5a3e5bf59
--- /dev/null
+++ b/collects/honu/private/compiler/honu-translate-function.ss
@@ -0,0 +1,14 @@
+(module honu-translate-function mzscheme
+  (require (lib "plt-match.ss"))
+  
+  (require "../../ast.ss")
+  (require "honu-translate-utils.ss")
+  (require "honu-translate-expression.ss")
+  
+  (provide honu-translate-function)
+  (define (honu-translate-function pgm defn)
+    (match defn
+      [(struct honu-function (stx name _ arg-names _ body))
+       (at stx `(define ,(cons (at-ctxt name) (map at-ctxt arg-names))
+                  ,(honu-translate-expression pgm defn body)))]))
+  )
diff --git a/collects/honu/private/compiler/honu-translate-program.ss b/collects/honu/private/compiler/honu-translate-program.ss
new file mode 100644
index 0000000000..bcfdbe7667
--- /dev/null
+++ b/collects/honu/private/compiler/honu-translate-program.ss
@@ -0,0 +1,41 @@
+(module honu-translate-program mzscheme
+
+  (require (all-except (lib "list.ss" "srfi" "1") any)
+           (lib "contract.ss"))
+  
+  (require "../../ast.ss")
+  (require "../../tenv.ss")
+  (require "honu-translate-type-defn.ss")
+  (require "honu-translate-function.ss")
+  (require "honu-translate-class.ss")
+  (require "honu-translate-subclass.ss")
+  (require "honu-translate-utils.ss")
+  
+  (provide/contract [honu-translate-program
+                     (tenv?
+                      honu-program?
+                      . -> .
+;                      (listof (syntax/c any/c))])
+                      list?)])
+  (define (honu-translate-program tenv pgm)
+    (map (lambda (d)
+           (honu-translate-defn tenv pgm d))
+         (filter (lambda (d)
+                   (not (honu-mixin? d)))
+                 (honu-program-defns pgm))))
+             
+  (define (honu-translate-defn tenv pgm defn)
+    (cond
+      [(honu-function? defn) (honu-translate-function tenv defn)]
+      [(honu-type-defn? defn) (honu-translate-type-defn tenv defn)]
+      [(honu-class? defn) (honu-translate-class tenv defn)]
+ ;     [(honu-mixin? defn) (honu-translate-mixin pgm defn)]
+      [(honu-subclass? defn) 
+       (let ([mixin (find (lambda (d)
+                            (and (honu-mixin? d)
+                                 (tenv-key=? (honu-mixin-name d)
+                                             (honu-subclass-mixin defn))))
+                          (honu-program-defns pgm))])
+         (honu-translate-subclass tenv mixin defn))]))
+  
+  )
diff --git a/collects/honu/private/compiler/honu-translate-subclass.ss b/collects/honu/private/compiler/honu-translate-subclass.ss
new file mode 100644
index 0000000000..d15ff516bc
--- /dev/null
+++ b/collects/honu/private/compiler/honu-translate-subclass.ss
@@ -0,0 +1,59 @@
+(module honu-translate-subclass mzscheme
+
+  (require (lib "list.ss" "srfi" "1")
+           (lib "plt-match.ss"))
+  
+  (require "../../ast.ss")
+  (require "../../utils.ss")
+  (require "../../tenv.ss")
+  (require "honu-translate-utils.ss")
+  (require "honu-translate-class-utils.ss")
+  (require "honu-translate-expression.ss")
+  
+  (define (get-prior-ifaces tenv cname)
+    (match-let ([(struct tenv-class (stx sub-type impls _ _ super))
+                 (get-class-entry cname tenv)])
+      (if super
+          (cons sub-type (append impls (get-prior-ifaces tenv super)))
+          (cons sub-type impls))))
+  
+  (define (honu-translate-super-new tenv mxn sup-new)
+    (match sup-new
+      [(struct honu-super-new (stx arg-names arg-vals))
+       (at stx `(super-new
+                 ,@(map (lambda (name exp)
+                          (list name (honu-translate-expression tenv mxn exp)))
+                        arg-names
+                        arg-vals)))]))
+  
+  (provide honu-translate-subclass)
+  
+  (define (honu-translate-subclass tenv mxn defn)
+    ;; I would think the below is equivalent to:
+    
+;    (match-let ([(struct honu-subclass (stx subc-name mixin base)) defn]
+;                [(struct honu-mixin (stx mxn-name _ _ _ init-names init-types impls
+;                                     _ _ defns-before super-new defns-after exports)) mxn])
+    
+    ;; but it gave me errors, so I separated them out appropriately.  Check into this later.
+    
+    (match defn
+      [(struct honu-subclass (stx subc-name mixin base))
+       (match mxn
+         [(struct honu-mixin (stx mxn-name _ _ _ init-names init-types impls
+                                  _ _ defns-before super-new defns-after exports))
+      (let ([prior-impls (get-prior-ifaces tenv base)])
+         (at stx `(define ,(honu-translate-class-name subc-name)
+                    (parameterize ([current-inspector (make-inspector (current-inspector))])
+                      (define ,(honu-translate-class-name subc-name)
+                        (class* ,(honu-translate-class-name base)
+                          ,(filter-map honu-translate-type-name impls)
+                          ,@(honu-translate-init-slots init-names)
+                          ,@(honu-translate-slotdefns tenv mxn defns-before)
+                          ,(honu-translate-super-new tenv mxn super-new)
+                          ,@(honu-translate-slotdefns tenv mxn defns-after)
+                          ,@(honu-translate-exports tenv mxn prior-impls exports)))
+                      ,(honu-translate-class-name subc-name)))))
+      ])]))
+  
+  )
diff --git a/collects/honu/private/compiler/honu-translate-type-defn.ss b/collects/honu/private/compiler/honu-translate-type-defn.ss
new file mode 100644
index 0000000000..136e554edc
--- /dev/null
+++ b/collects/honu/private/compiler/honu-translate-type-defn.ss
@@ -0,0 +1,35 @@
+(module honu-translate-type-defn mzscheme
+  
+  (require (lib "list.ss" "srfi" "1")
+           (lib "plt-match.ss"))
+  
+  (require "../../ast.ss")
+  (require "../../tenv.ss")
+  (require "../typechecker/honu-type-utils.ss")
+  (require "honu-translate-utils.ss")
+  
+  (provide honu-translate-type-defn)
+  (define (honu-translate-type-defn tenv defn)
+    (match defn
+      [(struct honu-type-defn (stx name supers decls))
+       (let ([typ (make-honu-iface-type name name)]
+             [method-names (filter-map (match-lambda
+                                        [(struct honu-method-decl (_ name _ _)) name]
+                                        [_ #f])
+                                       decls)]
+             [field-names (filter-map (match-lambda
+                                        [(struct honu-field-decl (_ name _)) name]
+                                        [_ #f])
+                                      decls)])
+         (at stx `(define ,(honu-translate-type-name typ)
+                    (interface ,(filter-map honu-translate-type-name supers)
+                      ,@(map (lambda (m)
+                               (honu-translate-dynamic-method-name tenv m typ))
+                             method-names)
+                      ,@(map (lambda (f)
+                               (honu-translate-dynamic-field-getter tenv f typ))
+                             field-names)
+                      ,@(map (lambda (f)
+                               (honu-translate-dynamic-field-setter tenv f typ))
+                             field-names)))))]))
+  )
diff --git a/collects/honu/private/compiler/honu-translate-utils.ss b/collects/honu/private/compiler/honu-translate-utils.ss
new file mode 100644
index 0000000000..aebb045201
--- /dev/null
+++ b/collects/honu/private/compiler/honu-translate-utils.ss
@@ -0,0 +1,83 @@
+(module honu-translate-utils mzscheme
+  
+  (require (lib "list.ss" "srfi" "1"))
+
+  (require "../../ast.ss")
+  (require "../../tenv.ss")
+  
+  (provide current-compile-context)
+  (define current-compile-context (make-parameter #f))
+
+;  (provide/contract [at      ((syntax/c any/c) any/c . -> . (syntax/c any/c))]
+;                    [at-ctxt ((syntax/c any/c)       . -> . (syntax/c any/c))])
+  (provide at at-ctxt)
+  (define (at stx expr)
+    (datum->syntax-object (current-compile-context) expr stx))
+  (define (at-ctxt stx)
+    (datum->syntax-object (current-compile-context) (syntax-e stx) stx))
+  
+  (provide honu-translate-class-name)
+  (define (honu-translate-class-name sym)
+    (at sym
+        (string->symbol 
+           (string-append "honu-" (symbol->string (printable-key sym)) "%"))))
+        
+  (provide honu-translate-type-name)
+  (define (honu-translate-type-name typ)
+    (if (honu-iface-top-type? typ) #f
+        (at (honu-ast-src-stx typ)
+            (string->symbol 
+             (string-append "honu-" (symbol->string (printable-key (honu-iface-type-name typ))) "<%>")))))
+  
+  (provide honu-translate-mixin-name)
+  (define (honu-translate-mixin-name mixin)
+   (at mixin
+       (string->symbol
+        (string-append "honu-" (symbol->string (printable-key mixin)) "-mixin"))))
+
+  (provide honu-translate-field-getter)
+  (define (honu-translate-field-getter sym)
+    (at sym
+        (string->symbol (string-append "get-" (symbol->string (printable-key sym))))))
+
+  (provide honu-translate-field-setter)
+  (define (honu-translate-field-setter sym)
+    (at sym
+        (string->symbol (string-append "set-" (symbol->string (printable-key sym)) "!"))))
+
+  (provide find-type-for-name)
+  (define (find-type-for-name tenv name typ)
+    (let ([type-defn (get-type-entry (honu-iface-type-name typ) tenv)])
+      (if (ormap (lambda (d)
+                   (cond
+                     [(honu-field-decl? d) (tenv-key=? (honu-field-decl-name d) name)]
+                     [(honu-method-decl? d) (tenv-key=? (honu-method-decl-name d) name)]))
+                 (tenv-type-members type-defn))
+          typ
+          (find (lambda (t)
+                  (find-type-for-name tenv name t))
+                (tenv-type-supers type-defn)))))
+
+  (provide honu-translate-dynamic-field-getter)
+  (define (honu-translate-dynamic-field-getter tenv sym typ)
+    (at sym
+        (string->symbol (string-append "get-"
+                                       (symbol->string (printable-key (honu-translate-type-name (find-type-for-name tenv sym typ))))
+                                       "-"
+                                       (symbol->string (printable-key sym))))))
+
+  (provide honu-translate-dynamic-field-setter)
+  (define (honu-translate-dynamic-field-setter tenv sym typ)
+    (at sym
+        (string->symbol (string-append "set-" 
+                                       (symbol->string (printable-key (honu-translate-type-name (find-type-for-name tenv sym typ))))
+                                       "-"
+                                       (symbol->string (printable-key sym)) "!"))))
+
+  (provide honu-translate-dynamic-method-name)
+  (define (honu-translate-dynamic-method-name tenv name typ)
+    (at name
+        (string->symbol (string-append (symbol->string (printable-key (honu-translate-type-name (find-type-for-name tenv name typ))))
+                                       "-"
+                                       (symbol->string (printable-key name))))))
+  )
diff --git a/collects/honu/private/typechecker/honu-convert-static.ss b/collects/honu/private/typechecker/honu-convert-static.ss
new file mode 100644
index 0000000000..3a0770809a
--- /dev/null
+++ b/collects/honu/private/typechecker/honu-convert-static.ss
@@ -0,0 +1,204 @@
+(module honu-convert-static mzscheme
+  
+  (require (lib "list.ss" "srfi" "1")
+           (lib "struct.ss")
+           "../../ast.ss"
+           "../../tenv.ss"
+           "honu-type-utils.ss"
+           "../../read-error-with-stx.ss")
+  
+  (define (tenv-filter-map tenv p)
+    (filter values (tenv-map tenv p)))
+  
+  (define (default-bindings tenv)
+    (append '(printStr printLine error readChar readLine strToInt strToFloat
+              intToStr floatToStr charToStr strLen substr charAt)
+            (tenv-filter-map tenv
+               (lambda (k v)
+                 (if (tenv-func? v) (printable-key k) #f)))))
+  
+  (define default-class-bindings '())
+  
+  (define (get-static-bindings defn)
+    (define (get-slotdefn-name d)
+      (cond
+        [(honu-field? d) (printable-key (honu-field-name d))]
+        [(honu-method? d) (printable-key (honu-method-name d))]
+        [(honu-init-field? d) (printable-key (honu-init-field-name d))]))
+    (cond
+      [(honu-class? defn)
+       (append default-class-bindings
+               (map printable-key (honu-class-init-names defn))
+               (filter-map get-slotdefn-name (honu-class-defns defn)))]
+      [(honu-mixin? defn)
+       (append default-class-bindings
+               (map printable-key (honu-mixin-init-names defn))
+               (filter-map get-slotdefn-name 
+                           (append (honu-mixin-defns-before defn)
+                                   (honu-mixin-defns-after defn))))]
+      [else '()]))
+  
+  (provide honu-convert-static)
+  (define (honu-convert-static tenv pgm)
+    (let* ((env (default-bindings tenv))
+           (defns (map (lambda (defn)
+                         (honu-convert-defn tenv env defn))
+                       (honu-program-defns pgm))))
+      (copy-struct honu-program pgm
+                   (honu-program-defns defns))))
+  
+  (define (honu-convert-defn tenv env defn)
+    (cond
+      [(honu-class? defn)
+       (let* ((cenv (get-static-bindings defn))
+              (new-mdidefns (map (lambda (d)
+                                   (honu-convert-mdidefn d env cenv)) (honu-class-defns defn))))
+         (copy-struct honu-class defn
+                      (honu-class-defns new-mdidefns)))]
+      [(honu-mixin? defn)
+       (let* ((cenv (append (get-static-bindings defn)
+                            ;; get-fields-and-methods returns (name . type) pairs, so map car
+                            (map (lambda (p)
+                                   (printable-key (car p)))
+                                 (get-fields-and-methods tenv (honu-mixin-arg-type defn)))))
+              (new-befores (map (lambda (d)
+                                  (honu-convert-mdidefn d env cenv))
+                                (honu-mixin-defns-before defn)))
+              (new-super-new (honu-convert-super-new (honu-mixin-super-new defn) env cenv))
+              (new-afters (map (lambda (d)
+                                 (honu-convert-mdidefn d env cenv))
+                               (honu-mixin-defns-after defn))))
+         (copy-struct honu-mixin defn
+                      (honu-mixin-defns-before new-befores)
+                      (honu-mixin-super-new new-super-new)
+                      (honu-mixin-defns-after new-afters)))]
+      [else defn]))
+
+  (define (honu-convert-mdidefn defn env cenv)
+    (cond
+      [(honu-init-field? defn)
+       (if (not (honu-init-field-value defn))
+           (copy-struct honu-init-field defn
+                        (honu-init-field-value (honu-convert-exp (honu-init-field-value defn)
+                                                                 env cenv)))
+           defn)]
+      [(honu-field? defn)
+       (copy-struct honu-field defn
+                    (honu-field-value (honu-convert-exp (honu-field-value defn) env cenv)))]
+      [(honu-method? defn)
+       (copy-struct honu-method defn
+                    (honu-method-body (honu-convert-exp (honu-method-body defn)
+                                                        (append (map printable-key (honu-method-arg-names defn))
+                                                                env)
+                                                        cenv)))]))
+
+  (define (honu-convert-super-new defn env cenv)
+    (let ((new-vals (map (lambda (e)
+                           (honu-convert-exp e env cenv))
+                         (honu-super-new-arg-vals defn))))
+      (copy-struct honu-super-new defn
+                   (honu-super-new-arg-vals new-vals))))
+  
+  ;; I should consider changing this to allowing through all names that aren't bound in the
+  ;; cenv (those should be converted to my.foo).  The typechecker will already give appropriate
+  ;; error messages for unbound variables.
+  (define (honu-convert-exp exp bound-vars cenv)
+    (cond
+      [(honu-var? exp)
+       (cond
+         [(member (printable-key (honu-var-name exp)) bound-vars) exp]
+         [(member (printable-key (honu-var-name exp)) cenv)
+          (make-honu-facc (honu-ast-src-stx exp)
+                          'my #f (honu-var-name exp))]
+         [else (raise-read-error-with-stx
+                (format "Unbound variable name ~a" (printable-key (honu-var-name exp)))
+                (honu-var-name exp))])]
+      [(honu-assn? exp)
+       (let ((new-rhs (honu-convert-exp (honu-assn-rhs exp) bound-vars cenv)))
+         (cond
+           [(member (printable-key (honu-assn-name exp)) bound-vars)
+            (copy-struct honu-assn exp (honu-assn-rhs new-rhs))]
+           [(member (printable-key (honu-assn-name exp)) cenv)
+            (make-honu-fassn (honu-ast-src-stx exp)
+                             'my #f (honu-assn-name exp) new-rhs)]
+           [else (raise-read-error-with-stx
+                  (format "Unbound variable name ~a" (printable-key (honu-assn-name exp)))
+                  (honu-assn-name exp))]))]
+           
+      [(honu-call? exp)
+       (let ((new-args (map (lambda (e)
+                              (honu-convert-exp e bound-vars cenv))
+                            (honu-call-args exp))))
+         (cond
+           [(member (printable-key (honu-call-name exp)) bound-vars)
+            (copy-struct honu-call exp (honu-call-args new-args))]
+           [(member (printable-key (honu-call-name exp)) cenv)
+            (make-honu-mcall (honu-ast-src-stx exp)
+                             'my #f (honu-call-name exp) new-args)]
+           [else (raise-read-error-with-stx
+                  (format "Unbound function name ~a" (printable-key (honu-call-name exp)))
+                  (honu-call-name exp))]))]
+      [(honu-prim? exp)
+       (copy-struct honu-prim exp
+                    (honu-prim-left (honu-convert-exp (honu-prim-left exp) bound-vars cenv))
+                    (honu-prim-right (honu-convert-exp (honu-prim-right exp) bound-vars cenv)))]
+      [(honu-facc? exp)
+       (if (eqv? (honu-facc-obj exp) 'my)
+           exp
+           (copy-struct honu-facc exp
+                        (honu-facc-obj (honu-convert-exp (honu-facc-obj exp) bound-vars cenv))))]
+      [(honu-fassn? exp)
+       (copy-struct honu-fassn exp
+                    (honu-fassn-obj (if (eqv? (honu-fassn-obj exp) 'my) 'my
+                             (honu-convert-exp (honu-fassn-obj exp) bound-vars cenv)))
+                    (honu-fassn-rhs (honu-convert-exp (honu-fassn-rhs exp) bound-vars cenv)))]
+      [(honu-mcall? exp)
+       (copy-struct honu-mcall exp
+                    (honu-mcall-obj (if (eqv? (honu-mcall-obj exp) 'my) 'my
+                             (honu-convert-exp (honu-mcall-obj exp) bound-vars cenv)))
+                    (honu-mcall-args (map (lambda (e)
+                                 (honu-convert-exp e bound-vars cenv))
+                               (honu-mcall-args exp))))]
+      [(honu-cast? exp)
+       (copy-struct honu-cast exp
+                    (honu-cast-obj (honu-convert-exp (honu-cast-obj exp) bound-vars cenv)))]
+      [(honu-isa? exp)
+       (copy-struct honu-isa exp
+                    (honu-isa-obj (honu-convert-exp (honu-isa-obj exp) bound-vars cenv)))]
+      [(honu-if? exp)
+       (copy-struct honu-if exp
+                    (honu-if-cond (honu-convert-exp (honu-if-cond exp) bound-vars cenv))
+                    (honu-if-true (honu-convert-exp (honu-if-true exp) bound-vars cenv))
+                    (honu-if-false (honu-convert-exp (honu-if-false exp) bound-vars cenv)))]
+      [(honu-new? exp)
+       (copy-struct honu-new exp
+                    (honu-new-arg-vals (map (lambda (e)
+                                     (honu-convert-exp e bound-vars cenv))
+                                   (honu-new-arg-vals exp))))]
+      [(honu-lambda? exp)
+       (copy-struct honu-lambda exp
+         (honu-lambda-body (honu-convert-exp (honu-lambda-body exp)
+                                             (append (map printable-key (honu-lambda-arg-names exp))
+                                                     bound-vars)
+                                             cenv)))]
+      [(honu-block? exp)
+       (let loop ((binds (honu-block-binds exp))
+                  (new-binds null)
+                  (bound-vars bound-vars))
+         (if (null? binds)
+             (copy-struct honu-block exp
+                          (honu-block-binds (reverse new-binds))
+                          (honu-block-exps (map (lambda (e)
+                                       (honu-convert-exp e bound-vars cenv))
+                                     (honu-block-exps exp))))
+             (let ((bind (car binds)))
+               (loop (cdr binds)
+                     (cons (copy-struct honu-binding bind
+                            (honu-binding-rhs (honu-convert-exp (honu-binding-rhs bind) bound-vars cenv)))
+                           new-binds)
+                     (cons (printable-key (honu-binding-name bind)) bound-vars)))))]
+      [(honu-return? exp)
+       (copy-struct honu-return exp
+                    (honu-return-body (honu-convert-exp (honu-return-body exp) bound-vars cenv)))]
+      [else exp]))
+  )
diff --git a/collects/honu/private/typechecker/honu-type-utils.ss b/collects/honu/private/typechecker/honu-type-utils.ss
new file mode 100644
index 0000000000..abe55351cd
--- /dev/null
+++ b/collects/honu/private/typechecker/honu-type-utils.ss
@@ -0,0 +1,399 @@
+(module honu-type-utils mzscheme
+  
+  (require (all-except (lib "list.ss" "srfi" "1") any)
+           (lib "plt-match.ss")
+           (lib "contract.ss")
+           "../../ast.ss"
+           "../../tenv.ss"
+           "../../read-error-with-stx.ss")
+  
+  (provide honu-bool-type honu-str-type honu-int-type honu-float-type
+           honu-char-type 
+           honu-null-type honu-error-type honu-any-type honu-void-type
+           honu-func-type-from-exp)
+
+  (define (honu-error-type exp)
+    (if (syntax? exp)
+        (make-honu-bottom-type exp)
+        (make-honu-bottom-type (honu-ast-src-stx exp))))
+  
+  (define (honu-func-type-from-exp args return exp)
+    (if (syntax? exp)
+        (make-honu-func-type exp args return)
+        (make-honu-func-type (honu-ast-src-stx exp)
+                             args return)))
+  
+  (define (honu-dispatch-type-from-exp dispatches args return exp)
+    (if (syntax? exp)
+        (make-honu-dispatch-type exp dispatches args return)
+        (make-honu-dispatch-type (honu-ast-src-stx exp)
+                               dispatches args return)))
+  
+  (define (honu-null-type exp)
+    (if (syntax? exp)
+        (make-honu-iface-bottom-type exp)
+        (make-honu-iface-bottom-type (honu-ast-src-stx exp))))
+
+  (define (honu-any-type exp)
+    (if (syntax? exp)
+        (make-honu-iface-top-type exp)
+        (make-honu-iface-top-type (honu-ast-src-stx exp))))
+
+  (define (honu-void-type exp)
+    (if (syntax? exp)
+        (make-honu-top-type exp)
+        (make-honu-top-type (honu-ast-src-stx exp))))
+  
+  (define (honu-int-type exp)
+    (create-honu-prim-type exp 'int))
+  (define (honu-bool-type exp)
+    (create-honu-prim-type exp 'bool))
+  (define (honu-str-type exp)
+    (create-honu-prim-type exp 'str))
+  (define (honu-float-type exp)
+    (create-honu-prim-type exp 'float))
+  (define (honu-char-type exp)
+    (create-honu-prim-type exp 'char))
+
+  (define (create-honu-prim-type exp name)
+    (if (syntax? exp)
+        (make-honu-prim-type exp name)
+        (make-honu-prim-type (honu-ast-src-stx exp) name)))
+  
+  (provide printable-type)
+  (define (printable-type typ)
+    (match typ
+      [(struct honu-bottom-type       (stx))          "<any type>"]
+      [(struct honu-top-type          (stx))          "void"]
+      [(struct honu-iface-bottom-type (stx))          "<interface type>"]
+      [(struct honu-iface-top-type    (stx))          "Any"]
+      [(struct honu-iface-type        (stx name))     (symbol->string (printable-key name))]
+      [(struct honu-prim-type         (stx name))     (symbol->string name)]
+      [(struct honu-func-type         (stx args ret)) 
+       (if (null? args)
+           (string-append "[]->" (printable-type ret))
+           (string-append "[" (fold-right (lambda (t s)
+                                            (string-append s ", " (printable-type t)))
+                                          (printable-type (car args))
+                                          (cdr args)) 
+                          "]->" (printable-type ret)))]
+      [(struct honu-dispatch-type         (stx dispatches args ret)) 
+       (string-append "[" (fold-right (lambda (t s)
+                                        (string-append s ", " (printable-type t)))
+                                      (string-append "("
+                                                     (fold-right (lambda (t s)
+                                                                   (string-append s ", " (printable-type t)))
+                                                                 (printable-type (car dispatches))
+                                                                 (cdr dispatches))
+                                                     ")")
+                                      args)
+                      "]->" (printable-type ret))]))
+
+  (provide/contract [raise-type-error-with-stx (honu-type? honu-type? any/c . -> . any)])
+  (define (raise-type-error-with-stx t1 t2 stx)
+    (raise-read-error-with-stx
+     (format "Expected type ~a, got type ~a"
+             (printable-type t1)
+             (printable-type t2))
+     stx))
+  
+  (provide honu-type-equal? honu-iface-type-in-tenv? honu-type-in-tenv?)
+  
+  (define (honu-type-equal? t1 t2)
+    (cond
+      [(and (honu-bottom-type? t1)
+            (honu-bottom-type? t2)) #t]
+      [(and (honu-top-type? t1)
+            (honu-top-type? t2)) #t]
+      [(and (honu-iface-bottom-type? t1)
+            (honu-iface-bottom-type? t2)) #t]
+      [(and (honu-iface-top-type? t1)
+            (honu-iface-top-type? t2)) #t]
+;      [(and (honu-void-type? t1)
+;            (honu-void-type? t2)) #t]
+      [(and (honu-prim-type? t1)
+            (honu-prim-type? t2))
+       (eqv? (honu-prim-type-name t1)
+             (honu-prim-type-name t2))]
+      [(and (honu-iface-type? t1)
+            (honu-iface-type? t2))
+       (eq? (printable-key (honu-iface-type-name t1))
+            (printable-key (honu-iface-type-name t2)))]
+      [(and (honu-func-type? t1)
+            (honu-func-type? t2))
+       (and (honu-type-equal? (honu-func-type-return t1)
+                              (honu-func-type-return t2))
+            (equal? (length (honu-func-type-args t1))
+                    (length (honu-func-type-args t2)))
+            (andmap honu-type-equal?
+                    (honu-func-type-args t1)
+                    (honu-func-type-args t2)))]
+      [(and (honu-dispatch-type? t1)
+            (honu-dispatch-type? t2))
+       (and (honu-type-equal? (honu-dispatch-type-return t1)
+                              (honu-dispatch-type-return t2))
+            (equal? (length (honu-dispatch-type-dispatches t1))
+                    (length (honu-dispatch-type-dispatches t2)))
+            (andmap honu-type-equal?
+                    (honu-dispatch-type-dispatches t1)
+                    (honu-dispatch-type-dispatches t2))
+            (equal? (length (honu-dispatch-type-args t1))
+                    (length (honu-dispatch-type-args t2)))
+            (andmap honu-type-equal?
+                    (honu-dispatch-type-args t1)
+                    (honu-dispatch-type-args t2)))]
+      [else #f]))
+
+  (define (honu-iface-type-in-tenv? tenv t)
+    (or (honu-iface-top-type? t)
+        (and (honu-iface-type? t)
+             (get-type-entry (honu-iface-type-name t) tenv))))
+  
+  (define (honu-prim-type-in-honu? t)
+    (member (honu-prim-type-name t) '(int bool str float char)))
+  
+  (define (honu-func-type-in-tenv? tenv t)
+    (and (or (honu-top-type? (honu-func-type-return t)) ;; take care of void here
+             (honu-type-in-tenv? tenv (honu-func-type-return t)))
+         (andmap (lambda (t)
+                   (honu-type-in-tenv? tenv t))
+                 (honu-func-type-args t))))
+
+  (define (honu-dispatch-type-in-tenv? tenv t)
+    (and (or (honu-top-type? (honu-dispatch-type-return t)) ;; take care of void here
+             (honu-type-in-tenv? tenv (honu-dispatch-type-return t)))
+         (andmap (lambda (t)
+                   (honu-type-in-tenv? tenv t))
+                 (honu-dispatch-type-dispatches t))
+         (andmap (lambda (t)
+                   (honu-type-in-tenv? tenv t))
+                 (honu-dispatch-type-args t))))
+
+  (define (honu-type-in-tenv? tenv t)
+    (cond
+      [(honu-dispatch-type? t) (honu-dispatch-type-in-tenv? tenv t)]
+      [(honu-func-type? t)   (honu-func-type-in-tenv? tenv t)]
+      [(honu-prim-type? t)   (honu-prim-type-in-honu? t)]
+      [else                  (honu-iface-type-in-tenv? tenv t)]))
+  
+  (provide get-field-type get-method-type)
+
+  (define (get-field-type tenv typ fd)
+    (if (honu-iface-top-type? typ)
+        (raise-read-error-with-stx
+         "The Any type has no fields."
+         fd))
+    (if (not (honu-iface-type? typ))
+        (raise-read-error-with-stx
+         "Attempt to get field of a type that is not an interface type."
+         fd))
+    (let* ([type-def (get-type-entry (honu-iface-type-name typ) tenv)]
+           [field-decl (find (lambda (d)
+                               (and (honu-field-decl? d)
+                                    (tenv-key=? (honu-field-decl-name d) fd)))
+                             (tenv-type-members type-def))])
+      (if field-decl
+          (honu-field-decl-type field-decl)
+          (let loop ([supers (tenv-type-supers type-def)])
+            (cond
+             ((null? supers) #f)
+             ((get-field-type tenv (car supers) fd) => values)
+             (else (loop (cdr supers))))))))
+
+  (define (get-method-type tenv typ md)
+    (if (honu-iface-top-type? typ)
+        (raise-read-error-with-stx
+         "The Any type has no methods."
+         md))
+    (if (not (honu-iface-type? typ))
+        (raise-read-error-with-stx
+         "Attempt to get method of a type that is not an interface type."
+         md))
+    (let* ([type-def (get-type-entry (honu-iface-type-name typ) tenv)]
+           [method-decl (find (lambda (d)
+                                (and (honu-method-decl? d)
+                                     (tenv-key=? (honu-method-decl-name d) md)))
+                              (tenv-type-members type-def))])
+      (if method-decl
+          (honu-dispatch-type-from-exp
+           (list typ)
+           (honu-method-decl-arg-types method-decl)
+           (honu-method-decl-type method-decl)
+           method-decl)
+          (let loop ([supers (tenv-type-supers type-def)])
+            (cond
+             ((null? supers) #f)
+             ((get-method-type tenv (car supers) md) => values)
+             (else (loop (cdr supers))))))))
+  
+  (provide <:_P Implements_P)
+  
+  (define (Subtype_P tenv t1 t2)
+    (if (and (honu-iface-type? t1)
+             (honu-iface-type? t2))
+        (let ([t1-def (get-type-entry (honu-iface-type-name t1) tenv)])
+          (ormap (lambda (t)
+                   (honu-type-equal? t t2))
+                 (tenv-type-supers t1-def)))
+        #f))
+  
+  (define (<:_P tenv t1 t2)
+    (cond
+      [(honu-type-equal? t1 t2) #t] ; Reflexive
+      [(honu-bottom-type? t1) #t] ; bottom is a subtype of all
+      [(honu-top-type? t2) #t] ; top is a supertype of all
+      [(and (honu-iface-bottom-type? t1)
+            (or (honu-iface-top-type? t2)
+                (honu-iface-type? t2))) #t] ; iface bottom type <: any iface type
+      [(and (honu-iface-top-type? t2)
+            (or (honu-iface-bottom-type? t1)
+                (honu-iface-type? t1))) #t] ; any iface type <: iface top type 
+      [(Subtype_P tenv t1 t2) #t] ; Direct subtype is <:
+      [(and (honu-iface-type? t1)
+            (honu-iface-type? t2))
+       (let ([t1-def (get-type-entry (honu-iface-type-name t1) tenv)])
+         (ormap (lambda (t)
+                  (<:_P tenv t t2))
+              (tenv-type-supers t1-def)))]
+      [(and (honu-func-type? t1)
+            (honu-func-type? t2))
+       (and (<:_P tenv
+                  (honu-func-type-return t1)
+                  (honu-func-type-return t2))
+            (equal? (length (honu-func-type-args t1))
+                    (length (honu-func-type-args t2)))
+            (andmap (lambda (at bt)
+                      (<:_P tenv bt at))
+                    (honu-func-type-args t1)
+                    (honu-func-type-args t2)))]
+      [(and (honu-dispatch-type? t1)
+            (honu-dispatch-type? t2))
+       (and (<:_P tenv ;; return covariant
+                  (honu-dispatch-type-return t1)
+                  (honu-dispatch-type-return t2))
+            (equal? (length (honu-dispatch-type-dispatches t1))
+                    (length (honu-dispatch-type-dispatches t2)))
+            (andmap (lambda (at bt) ;; dispatched args covariant
+                      (<:_P tenv at bt))
+                    (honu-dispatch-type-dispatches t1)
+                    (honu-dispatch-type-dispatches t2))
+            (equal? (length (honu-dispatch-type-args t1))
+                    (length (honu-dispatch-type-args t2)))
+            (andmap (lambda (at bt) ;; non-dispatched args contravariant
+                      (<:_P tenv bt at))
+                    (honu-dispatch-type-args t1)
+                    (honu-dispatch-type-args t2)))]
+      [else #f]))
+  
+  (define (Implements_P tenv c t)
+    (let ([defn (get-class-entry c tenv)])
+      (ormap (lambda (t1)
+                  (<:_P tenv t1 t))
+                (tenv-class-impls defn))))
+
+  (provide get-init-names-and-types)
+  (define (get-init-names-and-types tenv c)
+    (let ((defn (get-class-entry c tenv)))
+      (tenv-class-inits defn)))
+  
+  (provide check-init-type-for-name)
+  (define (check-init-type-for-name tenv inits name type)
+    (if (null? inits)
+        (raise-read-error-with-stx
+         "Initialization argument name not found in list of initialization field names."
+         name)
+        (let ((current (car inits)))
+          (if (eq? (printable-key (tenv-init-name current)) (printable-key name))
+              ;; The name matches, so check the types.
+              (if (<:_P tenv type (tenv-init-type current))
+                  ;; The types matched, so we're good so far.  Return the unused init args.
+                  (cdr inits)
+                  ;; The types didn't match, so we need to do some further checking.
+                  (if (tenv-init-optional? current)
+                      ;; This field had to be initialized, so this is a type error.
+                      (raise-read-error-with-stx
+                       "Type for initialization value does not match declared type."
+                       name)
+                      ;; It doesn't have to be initialized, so we assume that it was left
+                      ;; out and continue with the rest of the list, dropping it.
+                      (check-init-type-for-name tenv (cdr inits) name type)))
+              ;; The current initialization argument doesn't match, so keep checking as they
+              ;; can be ordered differently.
+              (cons current (check-init-type-for-name tenv (cdr inits) name type))))))
+  
+  (provide get-field-names-for-type)
+  (define (get-field-names-for-type tenv t)
+    (if (honu-iface-top-type? t) '()
+        (let ([type-defn (get-type-entry (honu-iface-type-name t) tenv)])
+          (apply append (cons (filter-map (lambda (d)
+                                            (cond
+                                              [(honu-field-decl? d) (honu-field-decl-name d)]
+                                              [else #f]))
+                                          (tenv-type-members type-defn))
+                              (map (lambda (t)
+                                     (get-field-names-for-type tenv t))
+                                   (tenv-type-supers type-defn)))))))
+                 
+  (provide get-method-names-for-type)
+  (define (get-method-names-for-type tenv t)
+    (if (honu-iface-top-type? t) '()
+        (let ([type-defn (get-type-entry (honu-iface-type-name t) tenv)])
+          (apply append (cons (filter-map (lambda (d)
+                                            (cond
+                                              [(honu-method-decl? d) (honu-method-decl-name d)]
+                                              [else #f]))
+                                          (tenv-type-members type-defn))
+                              (map (lambda (t)
+                                     (get-method-names-for-type tenv t))
+                                   (tenv-type-supers type-defn)))))))
+
+  (provide get-fields-and-methods)
+  (define (get-fields-and-methods tenv t)
+    (if (honu-iface-top-type? t) '() ; Any has no inherent fields or methods.
+        (let ([type-defn (get-type-entry (honu-iface-type-name t) tenv)])
+          (apply append
+                 (cons (append (map (lambda (d)
+                                      (cons (honu-field-decl-name d)
+                                            (honu-field-decl-type d)))
+                                    (filter honu-field-decl?
+                                            (tenv-type-members type-defn)))
+                               (map (lambda (d)
+                                      (cons (honu-method-decl-name d)
+                                            (honu-dispatch-type-from-exp
+                                             (list t)
+                                             (honu-method-decl-arg-types d)
+                                             (honu-method-decl-type d)
+                                             d)))
+                                    (filter honu-method-decl?
+                                            (tenv-type-members type-defn))))
+                       (map (lambda (t)
+                              (get-fields-and-methods tenv t))
+                            (tenv-type-supers type-defn)))))))             
+  
+  (define (get-function-names tenv)
+    (filter values
+            (tenv-map tenv (lambda (k v)
+                             (if (tenv-func? v) k #f)))))
+  
+  (provide get-initial-env)
+  (define (get-initial-env tenv)
+    (let ([function-names (get-function-names tenv)])
+      (fold (lambda (f e)
+              (let ([func-entry (get-func-entry f tenv)])
+                (extend-env e
+                            f
+                            (honu-func-type-from-exp (tenv-func-arg-types func-entry)
+                                                     (tenv-func-return-type func-entry)
+                                                     (tenv-entry-src-stx func-entry)))))
+            (empty-env)
+            function-names)))
+  
+  (provide empty-env extend-env)
+  
+  (define (empty-env) (lambda (id) #f))
+  
+  (define (extend-env env name val)
+    (lambda (id) 
+      (if (eqv? (printable-key name) (printable-key id)) val (env id))))
+
+  )
diff --git a/collects/honu/private/typechecker/honu-typecheck-class-utils.ss b/collects/honu/private/typechecker/honu-typecheck-class-utils.ss
new file mode 100644
index 0000000000..97354ebb8d
--- /dev/null
+++ b/collects/honu/private/typechecker/honu-typecheck-class-utils.ss
@@ -0,0 +1,236 @@
+(module honu-typecheck-class-utils mzscheme
+  
+  (require (lib "struct.ss")
+           (lib "plt-match.ss")
+           (lib "list.ss" "srfi" "1")
+           (prefix list: (lib "list.ss")))
+  
+  (require "../../ast.ss")
+  (require "../../utils.ss")
+  (require "../../tenv.ss")
+  (require "honu-type-utils.ss")
+  (require "honu-typecheck-exp.ss")
+  
+  (require "../../read-error-with-stx.ss")
+
+  (provide honu-typecheck-slotdefns)
+  (define (honu-typecheck-slotdefns tenv env cenv init-cenv defns)
+    (honu-typecheck-slotdefns-helper tenv env cenv init-cenv defns (list)))
+  
+  (define (honu-typecheck-slotdefns-helper tenv env cenv init-cenv defns new-defns)
+    (cond
+      [(null? defns) (values (reverse new-defns) env cenv init-cenv)]
+      [(honu-init-field? (car defns))
+       (let-values (((new-defn new-env new-cenv new-init-cenv)
+                     (honu-typecheck-init-field tenv env cenv init-cenv (car defns))))
+         (honu-typecheck-slotdefns-helper tenv new-env new-cenv 
+                                          new-init-cenv (cdr defns) (cons new-defn new-defns)))]
+      [(honu-field? (car defns))
+       (let-values (((new-defn new-env new-cenv new-init-cenv)
+                     (honu-typecheck-field tenv env cenv init-cenv (car defns))))
+         (honu-typecheck-slotdefns-helper tenv new-env new-cenv 
+                                          new-init-cenv (cdr defns) (cons new-defn new-defns)))]
+      [(honu-method? (car defns))
+       (let loop ((mdefns (list (car defns)))
+                  (rest-defns (cdr defns)))
+         (if (or (null? rest-defns)
+                 (not (honu-method? (car rest-defns))))
+             (let-values (((new-mdefns new-env new-cenv new-init-cenv)
+                           (honu-typecheck-methods tenv env cenv init-cenv mdefns)))
+               (honu-typecheck-slotdefns-helper tenv new-env new-cenv new-init-cenv rest-defns
+                                                (append (reverse new-mdefns) new-defns)))
+             (loop (cons (car rest-defns) mdefns) (cdr rest-defns))))]
+      [else (raise-read-error-with-stx
+             "Unexpected type of slotdefn."
+             (honu-ast-src-stx (car defns)))]))
+  
+  (define (honu-typecheck-init-field tenv env cenv init-cenv defn)
+    (match-let ([(struct honu-init-field (stx name type value)) defn])
+      (if (honu-type-in-tenv? tenv type)
+          (if value
+              (let-values ([(e1 t1) ((honu-typecheck-exp tenv env init-cenv)
+                                     value type)])
+                (values (copy-struct honu-init-field defn
+                          (honu-init-field-value e1))
+                        env
+                        (extend-env cenv name type)
+                        (extend-env init-cenv name type)))
+              (values defn env
+                      (extend-env cenv name type)
+                      (extend-env init-cenv name type)))
+          (raise-read-error-with-stx
+           "Type of init field not found in program."
+           (honu-ast-src-stx type)))))
+  
+  (define (honu-typecheck-field tenv env cenv init-cenv defn)
+    (match-let ([(struct honu-field (stx name type value)) defn])
+      (if (honu-type-in-tenv? tenv (honu-field-type defn))
+          (let-values ([(e1 t1) ((honu-typecheck-exp tenv env init-cenv)
+                                 value type)])
+            (values (copy-struct honu-field defn
+                      (honu-field-value e1))
+                    env
+                    (extend-env cenv name type)
+                    (extend-env init-cenv name type)))
+          (raise-read-error-with-stx
+           "Type of field not found in program."
+           (honu-ast-src-stx type)))))
+
+  (define (honu-typecheck-methods tenv env cenv init-cenv mdefns)
+    (let* ((new-cenv (fold (lambda (d i)
+                             (extend-env i (honu-method-name d)
+                                         (make-honu-dispatch-type (honu-ast-src-stx d)
+                                                                (list (env #'this))
+                                                                (honu-method-arg-types d)
+                                                                (honu-method-type d))))
+                           cenv mdefns))
+           (new-init-cenv (fold (lambda (d i)
+                                  (extend-env i (honu-method-name d)
+                                              (make-honu-dispatch-type (honu-ast-src-stx d)
+                                                                     (list (env #'this))
+                                                                     (honu-method-arg-types d)
+                                                                     (honu-method-type d))))
+                                init-cenv mdefns))
+           (new-mdefns (map (lambda (d)
+                              (honu-typecheck-method tenv env new-cenv d))
+                            mdefns)))
+      (values new-mdefns env new-cenv new-init-cenv)))
+
+  (define (honu-typecheck-method tenv env cenv defn)
+    (match-let ([(struct honu-method (stx name type arg-names arg-types body)) defn])
+      (if (or (honu-top-type? type) ;; we allow void only in method return types
+              (honu-type-in-tenv? tenv type))
+          (let ([new-env (fold (lambda (n t env)
+                                 (extend-env env n t))
+                               env arg-names arg-types)])
+            (check-arg-types tenv arg-types) ;; will raise exception if one fails
+            (let-values (((e1 t1) ((honu-typecheck-exp tenv new-env cenv) body (if (honu-top-type? type) #f type))))
+              (if (<:_P tenv t1 type)
+                  (copy-struct honu-method defn
+                               (honu-method-body e1))
+                  (raise-read-error-with-stx
+                   "Body of method's type does not match declared return type"
+                   (honu-ast-src-stx body)))))
+          (raise-read-error-with-stx
+           "Return type of method does not exist in program."
+           (honu-ast-src-stx type)))))
+  
+  (define (check-arg-types tenv types)
+    (cond
+      [(null? types) #t]
+      [(not (honu-type-in-tenv? tenv (car types)))
+       (raise-read-error-with-stx
+        "Argument type of method does not exist in program."
+        (honu-ast-src-stx (car types)))]
+      [else (check-arg-types tenv (cdr types))]))
+
+  (provide check-init-slots)
+  (define (check-init-slots tenv names types)
+    (cond
+      [(null? types) #t]
+      [(not (honu-type-in-tenv? tenv (car types)))
+       (raise-read-error-with-stx
+        (format "Type for init slot ~a does not exist in program."
+                (printable-key (car names)))
+        (honu-ast-src-stx (car types)))]
+      [else (check-init-slots tenv (cdr names) (cdr types))]))
+
+  (provide check-impl-types)
+  (define (check-impl-types tenv types)
+    (cond
+      [(null? types) #t]
+      [(not (honu-iface-type-in-tenv? tenv (car types)))
+       (raise-read-error-with-stx
+        "Type in implements list does not exist in program."
+        (honu-ast-src-stx (car types)))]
+      [else (check-impl-types tenv (cdr types))]))
+  
+  (provide honu-typecheck-export)
+  (define (honu-typecheck-export tenv cenv expdec)
+    (define (check-export-name old new)
+      (let ((old-type (cenv old)))
+        (if old-type
+            (let ((new-type
+                   (cond
+                     [(honu-prim-type? old-type)
+                      (get-field-type tenv (honu-export-type expdec) new)]
+                     [(honu-iface-type? old-type)
+                      (get-field-type tenv (honu-export-type expdec) new)]
+                     [(honu-func-type? old-type)
+                      (get-field-type tenv (honu-export-type expdec) new)]
+                     [(honu-dispatch-type? old-type)
+                      (get-method-type tenv (honu-export-type expdec) new)]
+                     [else (raise-read-error-with-stx
+                            "Unexpected class of type in check-export-name."
+                            (honu-ast-src-stx old-type))])))
+              (cond
+                [(not new-type)
+                 (raise-read-error-with-stx
+                  "Public name to be exported to not found in class/mixin type."
+                  new)]
+                [(and (honu-dispatch-type? old-type)
+                      (not (<:_P tenv old-type new-type)))
+                 (raise-read-error-with-stx
+                  "Method to be exported is not a subtype of the public type."
+                  old)]
+                [(and (not (honu-dispatch-type? old-type))
+                      (not (honu-type-equal? old-type new-type)))
+                 (raise-read-error-with-stx
+                  "Field to be exported is not an exact type match for the public type."
+                  old)]
+                [else (void)])) ; The current one checks, we won't have to alter anything.
+            (raise-read-error-with-stx
+             "Local name to be exported not found in class/mixin."
+             old))))
+    ;; yes, in the check to make sure they're all exported, I convert to symbols and
+    ;; then run the sorting thing, then just use equal?.  I really should make a
+    ;; version that tells you _WHICH_ wasn't exported.
+    (let ([sorted-type-fields-and-methods
+           (sort-names (map (lambda (p) (printable-key (car p)))
+                            (get-fields-and-methods tenv (honu-export-type expdec))))]
+          [sorted-new-names (sort-names (map printable-key 
+                                             (honu-export-new-names expdec)))])
+      (if (not (equal? sorted-type-fields-and-methods sorted-new-names))
+                 (raise-read-error-with-stx
+                  "Not all fields and methods in export type exported."
+                  (honu-ast-src-stx expdec))))
+    (for-each check-export-name
+              (honu-export-old-names expdec)
+              (honu-export-new-names expdec)))
+
+  ;; symbol list -> symbol list (sorted)
+  (define (sort-names list)
+    (list:quicksort list
+                    (lambda (a b)
+                      (string<? (symbol->string a)
+                                (symbol->string b)))))
+          
+  (provide check-impls-and-exports)
+  (define (check-impls-and-exports tenv cenv sub-type impl-types exports)
+    (for-each (lambda (i)
+                (if (ormap (lambda (t)
+                             (honu-type-equal? t i))
+                           (map honu-export-type exports))
+                    (void)
+                    (raise-read-error-with-stx
+                     "No export statement for implemented type."
+                     (honu-ast-src-stx i))))
+              impl-types)
+    (if (ormap (lambda (t)
+                 (honu-type-equal? t sub-type))
+               (map honu-export-type exports))
+        (void)
+        (raise-read-error-with-stx
+         "No export statement for type of this."
+         (honu-ast-src-stx sub-type)))
+    (for-each (lambda (e)
+                (if (or (ormap (lambda (t)
+                                 (honu-type-equal? t (honu-export-type e)))
+                               impl-types)
+                        (honu-type-equal? sub-type (honu-export-type e)))
+                    (honu-typecheck-export tenv cenv e)
+                    (raise-read-error-with-stx
+                     "Export statement for type that is not implemented or type of this."
+                     (honu-ast-src-stx e))))
+              exports))
+  )
diff --git a/collects/honu/private/typechecker/honu-typecheck-class.ss b/collects/honu/private/typechecker/honu-typecheck-class.ss
new file mode 100644
index 0000000000..168288bc6e
--- /dev/null
+++ b/collects/honu/private/typechecker/honu-typecheck-class.ss
@@ -0,0 +1,31 @@
+(module honu-typecheck-class mzscheme
+  
+  (require (lib "list.ss" "srfi" "1"))
+  (require (lib "struct.ss"))
+  
+  (require "../../ast.ss")
+  (require "../../utils.ss")
+  (require "honu-type-utils.ss")
+  (require "honu-typecheck-class-utils.ss")
+  
+  (provide honu-typecheck-class)
+  (define (honu-typecheck-class tenv cls)
+    (check-impl-types tenv (honu-class-impls cls))
+    (check-init-slots tenv (honu-class-init-names cls) (honu-class-init-types cls))
+    (let-values (((new-defns new-env new-cenv new-init-cenv)
+                  (honu-typecheck-slotdefns tenv
+                                            (extend-env (get-initial-env tenv) #'this (honu-class-type cls))
+                                            (empty-env)
+                                            (fold (lambda (n t e)
+                                                    (extend-env e n t))
+                                                  (empty-env)
+                                                  (honu-class-init-names cls)
+                                                  (honu-class-init-types cls))
+                                            (honu-class-defns cls))))
+      (check-impls-and-exports tenv new-cenv
+                               (honu-class-type cls)
+                               (honu-class-impls cls)
+                               (honu-class-exports cls))
+      (copy-struct honu-class cls
+        (honu-class-defns new-defns))))
+  )
diff --git a/collects/honu/private/typechecker/honu-typecheck-exp.ss b/collects/honu/private/typechecker/honu-typecheck-exp.ss
new file mode 100644
index 0000000000..4cb84b4ebe
--- /dev/null
+++ b/collects/honu/private/typechecker/honu-typecheck-exp.ss
@@ -0,0 +1,930 @@
+(module honu-typecheck-exp mzscheme
+
+  (require (lib "struct.ss")
+           (lib "contract.ss")
+           (lib "plt-match.ss")
+           (all-except (lib "list.ss" "srfi" "1") any))
+  
+  (require "../../ast.ss")
+  (require "../../utils.ss")
+  (require "../../tenv.ss")
+  (require "honu-type-utils.ss")
+  (require "../../read-error-with-stx.ss")
+
+  ;; expects a symbol syntax, returns a type for that builtin
+  (define (get-builtin-type stx)
+    (case (printable-key stx)
+      [(printStr)
+       (honu-func-type-from-exp
+        (list (honu-str-type stx))
+        (honu-void-type stx)
+        stx)]
+      [(printLine)
+       (honu-func-type-from-exp
+        (list (honu-str-type stx))
+        (honu-void-type stx)
+        stx)]
+      [(error)
+       (honu-func-type-from-exp
+        (list (honu-str-type stx))
+        (honu-error-type stx)
+        stx)]
+      [(readChar)
+       (honu-func-type-from-exp
+        (list)
+        (honu-char-type stx)
+        stx)]
+      [(readLine)
+       (honu-func-type-from-exp
+        (list)
+        (honu-str-type stx)
+        stx)]
+      [(strToInt)
+       (honu-func-type-from-exp
+        (list (honu-str-type stx))
+        (honu-int-type stx)
+        stx)]
+      [(strToFloat)
+       (honu-func-type-from-exp
+        (list (honu-str-type stx))
+        (honu-float-type stx)
+        stx)]
+      [(intToStr)
+       (honu-func-type-from-exp
+        (list (honu-int-type stx))
+        (honu-str-type stx)
+        stx)]
+      [(floatToStr)
+       (honu-func-type-from-exp
+        (list (honu-float-type stx))
+        (honu-str-type stx)
+        stx)]
+      [(charToStr)
+       (honu-func-type-from-exp
+        (list (honu-char-type stx))
+        (honu-str-type stx)
+        stx)]
+      [(strLen)
+       (honu-func-type-from-exp
+        (list (honu-str-type stx))
+        (honu-int-type stx)
+        stx)]
+      [(substr)
+       (honu-func-type-from-exp
+        (list (honu-str-type stx)
+              (honu-int-type stx)
+              (honu-int-type stx))
+        (honu-str-type stx)
+        stx)]
+      [(charAt)
+       (honu-func-type-from-exp
+        (list (honu-str-type stx)
+              (honu-int-type stx))
+        (honu-char-type stx)
+        stx)]
+      [else #f]))
+  
+  (define (check-prim-type exp typ type-func)
+    (let* ([stx (honu-ast-src-stx exp)]
+           [new-typ (type-func stx)])
+      (if (and typ (not (honu-type-equal? typ new-typ)))
+          (raise-type-error-with-stx typ new-typ stx)
+          (values exp new-typ))))
+  
+  ;; honu-typecheck-exp : HPgm * Env * CEnv -> HExp * Typ -> HExp * Typ
+  ;;
+  ;; honu-typecheck-exp typechecks a honu expression given the honu
+  ;; program in which it appears along with the current local
+  ;; environment and class environment.  Now it also takes an expected
+  ;; type (if one is known), so we can do some minor type inference in
+  ;; the case of new statements, plus give better error messages.
+  ;;
+  ;; Note that we curry the expression out to the right -- we do this
+  ;; because for most expressions, nothing will change except for
+  ;; running the typechecker recursively on subexpressions.
+  ;;
+  ;; We could likewise curry the program out to the left similarly
+  ;; since the program will never change for a given program (haha),
+  ;; but there would be better ways of handling that in either a
+  ;; functional and imperative style such as either having a
+  ;; global/parameterized "current-program" variable or by currying
+  ;; out to the left and then writing one function that given a
+  ;; program, applies the curried functions to it once, returning the
+  ;; partially applied functions.  I should get things working before
+  ;; getting that silly though.
+;  (provide honu-typecheck-exp)
+  (provide/contract [honu-typecheck-exp
+                     (tenv?
+                      any/c
+                      any/c
+                      . -> .
+                      ((honu-exp? (union false/c honu-type?))
+                       . ->* .
+                       (honu-exp? honu-type?)))]) 
+  (define (honu-typecheck-exp tenv env cenv)
+    (define (f exp typ)
+      (match exp
+       ;;            P |- t
+       ;; ----------------------------
+       ;; P, G, D |- null |=> null : t
+       ;;
+       ;; Since there's no easy way to do the above in this style of
+       ;; typechecker, we'll create a "null" type that for every
+       ;; type t such that P |- t, null <: t.
+       [(struct honu-null (stx))
+        (if typ
+            (if (<:_P tenv (honu-null-type stx) typ)
+                (values exp typ)
+                (raise-read-error-with-stx
+                 "Attempt to use null in a non-interface type context."
+                 stx))
+            (values exp (honu-null-type stx)))]
+       ;; P, G, D |- n |=> n : int
+       [(struct honu-int (stx n))
+        (check-prim-type exp typ honu-int-type)]
+       ;; P, G, D |- f |=> f : float
+       [(struct honu-float (stx f))
+        (check-prim-type exp typ honu-float-type)]
+       ;; P, G, D |- b |=> b : bool
+       [(struct honu-bool (stx b))
+        (check-prim-type exp typ honu-bool-type)]
+       ;; P, G, D |- s |=> s : str
+       [(struct honu-str (stx s))
+        (check-prim-type exp typ honu-str-type)]
+       ;; P, G, D |- c |=> c : char
+       [(struct honu-char (stx c))
+        (check-prim-type exp typ honu-char-type)]
+       [(struct honu-uprim (stx op op-stx op-type body))
+        (case op
+          [(minus)
+           (let-values (((e1 t1) (f body #f)))
+             (cond
+               [(honu-type-equal? t1 (honu-int-type (honu-uprim-body exp)))
+                (values (copy-struct honu-uprim exp
+                          (honu-uprim-op-type t1)
+                          (honu-uprim-body  e1))
+                        (honu-int-type exp))]
+               [(honu-type-equal? t1 (honu-float-type (honu-uprim-body exp)))
+                (values (copy-struct honu-uprim exp
+                          (honu-uprim-op-type t1)
+                          (honu-uprim-body  e1))
+                        (honu-float-type exp))]
+             [else
+              (raise-read-error-with-stx
+               "Unary minus takes an integer or floating point argument."
+               (honu-ast-src-stx (honu-uprim-body exp)))]))]
+          [(not)
+           (let-values (((e1 t1) (f body (honu-bool-type body))))
+             (values (copy-struct honu-uprim exp
+                       (honu-uprim-op-type t1)
+                       (honu-uprim-body  e1))
+                     (honu-bool-type exp)))]
+          [else (raise-read-error-with-stx
+                 "Unknown unary primitive operation."
+                 (honu-uprim-op-stx exp))])]
+       [(struct honu-prim (stx op op-stx op-type left right))
+        (case (honu-prim-op exp)
+            ;; +, -, *, /, and % are int * int -> int operators.
+            ;;
+            ;;  P, G, D |- e1 |=> e1' : int  P, G, D |- e2 |=> e2' : int
+            ;;  --------------------------------------------------------
+            ;;           P, G, D |- e1 op e2 |=> e1' op e2' : int
+          [(plus)
+           ;; we can just pass typ to the two sides (if it's an appropriate type)
+           ;; because it's always the case that + returns the same type as its
+           ;; operands.  Similar for minus, times, divide.
+           (if typ
+               (cond
+                 ;; this should work because we should never be passing a
+                 ;; void type as typ (#f should be passed instead).
+                 [(not (honu-prim-type? typ))
+                  (raise-read-error-with-stx
+                   "Cannot use primitive operators in a object context."
+                   stx)]
+                 [(not (member (honu-prim-type-name typ) '(int float str)))
+                  (raise-read-error-with-stx
+                   "The result of + must be used as either an int, float, or str."
+                   stx)]))
+           (let-values (((e1 t1) (f left typ))
+                        ((e2 t2) (f right typ)))
+             (cond
+               [typ ;; if we knew the correct context, then checking has already been done.
+                (values (copy-struct honu-prim exp
+                          (honu-prim-op-type t1)
+                          (honu-prim-left  e1)
+                          (honu-prim-right e2))
+                        typ)]
+               [(and (honu-type-equal? t1 (honu-int-type left))
+                     (honu-type-equal? t2 (honu-int-type right)))
+                (values (copy-struct honu-prim exp
+                               (honu-prim-op-type t1)
+                               (honu-prim-left  e1)
+                               (honu-prim-right e2))
+                             (honu-int-type exp))]
+               [(and (honu-type-equal? t1 (honu-float-type left))
+                     (honu-type-equal? t2 (honu-float-type right)))
+                (values (copy-struct honu-prim exp
+                               (honu-prim-op-type t1)
+                               (honu-prim-left  e1)
+                               (honu-prim-right e2))
+                             (honu-float-type exp))]
+               [(and (honu-type-equal? t1 (honu-str-type left))
+                     (honu-type-equal? t2 (honu-str-type right)))
+                (values (copy-struct honu-prim exp
+                               (honu-prim-op-type t1)
+                               (honu-prim-left  e1)
+                               (honu-prim-right e2))
+                             (honu-str-type exp))]
+               [else
+                (raise-read-error-with-stx
+                 "Operands are of different types or an incompatible type."
+                 stx)]))]
+          [(minus times div)
+           (if typ
+               (cond
+                 [(not (honu-prim-type? typ))
+                  (raise-read-error-with-stx
+                   "Cannot use primitive operators in a object context."
+                   stx)]
+                 [(not (member (honu-prim-type-name typ) '(int float)))
+                  (raise-read-error-with-stx
+                   (format "~a must be used in either an int or float context."
+                           (case op [(minus) '-] [(times) '*] [(div) '/]))
+                   stx)]))
+           (let-values (((e1 t1) (f left typ))
+                        ((e2 t2) (f right typ)))
+             (cond
+               [typ
+                (values (copy-struct honu-prim exp
+                               (honu-prim-op-type t1)
+                               (honu-prim-left  e1)
+                               (honu-prim-right e2))
+                        typ)]
+               [(and (honu-type-equal? t1 (honu-int-type left))
+                     (honu-type-equal? t2 (honu-int-type right)))
+                (values (copy-struct honu-prim exp
+                               (honu-prim-op-type t1)
+                               (honu-prim-left  e1)
+                               (honu-prim-right e2))
+                             (honu-int-type exp))]
+               [(and (honu-type-equal? t1 (honu-float-type left))
+                     (honu-type-equal? t2 (honu-float-type right)))
+                (values (copy-struct honu-prim exp
+                               (honu-prim-op-type t1)
+                               (honu-prim-left  e1)
+                               (honu-prim-right e2))
+                             (honu-float-type exp))]
+               [else
+                (raise-read-error-with-stx
+                 "Operands are of different types or an incompatible type."
+                 stx)]))]
+          [(mod)
+           ;; mod is only defined on ints, so check left and right side appropriately.
+           (let-values (((e1 t1) (f left (honu-int-type left)))
+                        ((e2 t2) (f right (honu-int-type right))))
+             ;; if we made it here, both must have been ints
+             (values (copy-struct honu-prim exp
+                       (honu-prim-op-type t1)
+                       (honu-prim-left  e1)
+                       (honu-prim-right e2))
+                     (honu-int-type exp)))]
+            [(lt le gt ge)
+             ;; relational operators don't tell us about their operands, so must use #f
+             (let-values (((e1 t1) (f left #f))
+                          ((e2 t2) (f right #f)))
+             (cond
+               [(and (honu-type-equal? t1 (honu-int-type left))
+                     (honu-type-equal? t2 (honu-int-type right)))
+                (values (copy-struct honu-prim exp
+                               (honu-prim-op-type t1)
+                               (honu-prim-left  e1)
+                               (honu-prim-right e2))
+                             (honu-bool-type exp))]
+               [(and (honu-type-equal? t1 (honu-float-type left))
+                     (honu-type-equal? t2 (honu-float-type right)))
+                (values (copy-struct honu-prim exp
+                               (honu-prim-op-type t1)
+                               (honu-prim-left  e1)
+                               (honu-prim-right e2))
+                             (honu-bool-type exp))]
+               [(and (honu-type-equal? t1 (honu-str-type left))
+                     (honu-type-equal? t2 (honu-str-type right)))
+                (values (copy-struct honu-prim exp
+                               (honu-prim-op-type t1)
+                               (honu-prim-left  e1)
+                               (honu-prim-right e2))
+                             (honu-bool-type exp))]
+               [(and (honu-type-equal? t1 (honu-char-type left))
+                     (honu-type-equal? t2 (honu-char-type right)))
+                (values (copy-struct honu-prim exp
+                               (honu-prim-op-type t1)
+                               (honu-prim-left  e1)
+                               (honu-prim-right e2))
+                             (honu-bool-type exp))]
+               [else
+                (raise-read-error-with-stx
+                 "Types of operands do not match or are not of appropriate types."
+                 (honu-ast-src-stx exp))]))]
+            ;; && and || are bool * bool -> bool operators.
+            ;;
+            ;;  P, G, D |- e1 |=> e1' : bool  P, G, D |- e2 |=> e2' : bool
+            ;;  ----------------------------------------------------------
+            ;;           P, G, D |- e1 op e2 |=> e1' op e2' : bool
+            [(and or)
+             (if (and typ (not (honu-type-equal? typ (honu-bool-type stx))))
+                 (raise-type-error-with-stx typ (honu-bool-type stx) stx))
+             (let-values (((e1 t1) (f left (honu-bool-type left)))
+                          ((e2 t2) (f right (honu-bool-type right))))
+               (values (copy-struct honu-prim exp
+                         (honu-prim-op-type t1)
+                         (honu-prim-left  e1)
+                         (honu-prim-right e2))
+                       (honu-bool-type exp)))]
+            ;; For now we just have that the operands to an equality
+            ;; operator can be of any type and that the types of the
+            ;; operands do not need to be equal.  Might it be the
+            ;; case that we want to check if we're comparing two
+            ;; primitives and reject if they're not the same type?
+            ;;
+            ;; Yes, and so we do below.
+            ;;
+            ;; (old type rule)
+            ;;  == is a 'a * 'b -> bool operator.
+            ;;
+            ;;  P, G, D |- e1 |=> e1' : t1    P, G, D |- e2 |=> e2' : t2
+            ;;  --------------------------------------------------------
+            ;;          P, G, D |- e1 == e2 |=> e1' == e2' : bool
+          [(neq equal)
+           (if (and typ (not (honu-type-equal? typ (honu-bool-type stx))))
+               (raise-type-error-with-stx typ (honu-bool-type stx) stx))
+           ;; there's no telling what the operands should be here.
+           (let-values (((e1 t1) (f left #f))
+                        ((e2 t2) (f right #f)))
+             (cond
+               [(and (<:_P tenv t1 (honu-any-type left))
+                     (<:_P tenv t2 (honu-any-type right)))
+                (values (copy-struct honu-prim exp
+                          (honu-prim-op-type (honu-any-type left))
+                          (honu-prim-left  e1)
+                          (honu-prim-right e2))
+                        (honu-bool-type exp))]
+               [(honu-type-equal? t1 t2)
+                (values (copy-struct honu-prim exp
+                          (honu-prim-op-type t1)
+                          (honu-prim-left  e1)
+                          (honu-prim-right e2))
+                        (honu-bool-type exp))]
+               [else (raise-read-error-with-stx
+                      "Attempt to check two unrelated types for (in)equality."
+                      stx)]))]
+          [(clseq)
+           (if (and typ (not (honu-type-equal? typ (honu-bool-type stx))))
+               (raise-type-error-with-stx typ (honu-bool-type stx) stx))
+           ;; here at least we know they should be class types.
+           (let-values (((e1 t1) (f left (honu-any-type left)))
+                        ((e2 t2) (f right (honu-any-type right))))
+             (values (copy-struct honu-prim exp
+                       (honu-prim-op-type (honu-any-type left))
+                       (honu-prim-left e1)
+                       (honu-prim-right e2))
+                     (honu-bool-type exp)))]
+          [else (raise-read-error-with-stx
+                 "Unknown binary primitive operation."
+                 op-stx)])]
+       [(struct honu-lambda (stx arg-names arg-types body))
+        (cond
+          [(not typ)
+           (let ([env (fold (lambda (n t e)
+                              (extend-env e n t))
+                            env arg-names arg-types)])
+             (let-values (((e1 t1) ((honu-typecheck-exp tenv env cenv) body #f)))
+               (values (copy-struct honu-lambda exp
+                                    (honu-lambda-body e1))
+                       (honu-func-type-from-exp (honu-lambda-arg-types exp) t1 exp))))]
+            ;; if typ is not #f, then it should be a func type, and the return
+            ;; type of the func should be the same as the lambda body.
+          [else
+           (if (and typ (not (honu-func-type? typ)))
+               (raise-read-error-with-stx
+                "Found lambda in non-function type context."
+                stx))
+           (let ([typ-args (honu-func-type-args typ)]
+                 [typ-ret  (honu-func-type-return typ)])
+             (if (not (= (length typ-args)
+                         (length arg-types)))
+                 (raise-read-error-with-stx
+                  "Number of arguments in lambda do not match number of arguments expected."
+                  stx))
+             ;; for a function to be a subtype, its arguments must be
+             ;; supertypes
+             (for-each (lambda (t1 t2)
+                         (if (not (<:_P tenv t2 t1))
+                             (raise-read-error-with-stx
+                              (format "Type ~a is not a supertype of ~a"
+                                      (printable-type t1)
+                                      (printable-type t2))
+                              (honu-ast-src-stx t1))))
+                       arg-types typ-args)
+             (let ([env (fold (lambda (n t e)
+                           (extend-env e n t))
+                         env arg-names arg-types)])
+               ;; we'll use typ-ret as the expected type for the body
+               (let-values (((e1 t1) ((honu-typecheck-exp tenv env cenv) body typ-ret)))
+                 (values (copy-struct honu-lambda exp
+                           (honu-lambda-body e1))
+                         (honu-func-type-from-exp arg-types t1 exp)))))])]
+       [(struct honu-facc (stx obj elab field))
+        (if (eqv? obj 'my)
+            ;;            D(fd) = t
+            ;; ------------------------------
+            ;; P, G, D |- my.fd |=> my.fd : t
+            (let ([cenv-typ (cenv field)])
+              (if cenv-typ
+                  (if (and typ (not (<:_P tenv cenv-typ typ)))
+                      (raise-type-error-with-stx typ cenv-typ stx)
+                      (values exp cenv-typ))
+                  (if (env #'this)
+                      ;; We're inside a class or mixin, so this is just an invalid name.
+                      ;; We do also have the extra case that if we're inside a method, this
+                      ;; may have been an init field's name (which are not contained in the
+                      ;; class environment passed to honu-typecheck-exp for method bodies).
+                      (raise-read-error-with-stx
+                       "No local field with this name or attempt to use init field in method."
+                       field)
+                      (raise-read-error-with-stx
+                       "Attempt to use static field access outside of class or mixin body."
+                       stx))))
+            ;; P, G, D |- e |=> e' : t'  <fd, t> in t'
+            ;; ---------------------------------------
+            ;;     P, G, D |- e.fd |=> e'.fd : t
+            (let-values (((e1 t1) (f obj (honu-any-type obj))))
+              (let ((field-type (get-field-type tenv t1 field)))
+                (if field-type
+                    (if (and typ (not (<:_P tenv field-type typ)))
+                        (raise-type-error-with-stx typ field-type stx)
+                        (values (copy-struct honu-facc exp
+                                  ;; Make sure to elaborate the type
+                                  (honu-facc-elab t1)
+                                  (honu-facc-obj e1))
+                                field-type))
+                    (raise-read-error-with-stx
+                     "Field not found in type of object."
+                     (honu-facc-field exp))))))]
+       [(struct honu-fassn (stx obj elab field rhs))
+        (if (and typ (not (honu-type-equal? typ (honu-void-type stx))))
+            (raise-read-error-with-stx
+             "Assignment used in non-void context."
+             stx))
+        (if (eqv? obj 'my)
+            ;; D(fd) = t  P, G, D |- e |=> e' : t'  t' <: t
+            ;; --------------------------------------------
+            ;;  P, G, D |- my.fd = e |=> my.fd = e' : void
+            (let ([cenv-typ (cenv field)])
+              (if cenv-typ
+                  (let-values (((e2 t2) (f rhs cenv-typ)))
+                    (values (copy-struct honu-fassn exp
+                              (honu-fassn-rhs e2))
+                            (honu-void-type exp)))
+                  (if (env #'this)
+                      ;; We're inside a class or mixin, so this is just an invalid name.
+                      ;; We do also have the extra case that if we're inside a method, this
+                      ;; may have been an init field's name (which are not contained in the
+                      ;; class environment passed to honu-typecheck-exp for method bodies).
+                      (raise-read-error-with-stx
+                       "No local field with this name or attempt to use init field in method."
+                       field)
+                      (raise-read-error-with-stx
+                       "Attempt to use static field assignment outside of class or mixin body."
+                       stx))))
+            ;; P, G, D |- e1 |=> e1' : t'        <fd, t> in t'
+            ;; P, G, D |- e2 |=> e2' : t''            t'' <: t
+            ;; -----------------------------------------------
+            ;;  P, G, D |- e1.fd = e2 |=> e1'.fd = e2' : void
+            (let-values (((e1 t1) (f obj (honu-any-type obj))))
+              (let ((field-type (get-field-type tenv t1 field)))
+                (if field-type
+                    (let-values (((e2 t2) (f rhs field-type)))
+                      (values (copy-struct honu-fassn exp
+                                (honu-fassn-obj e1)
+                                ;; Make sure to elaborate the type
+                                (honu-fassn-elab t1)
+                                (honu-fassn-rhs e2))
+                              (honu-void-type exp)))
+                    (raise-read-error-with-stx
+                     "Field not found in type of object."
+                     field)))))]
+       [(struct honu-mcall (stx obj elab method args))
+        ;; FIXME : need to change to use typ appropriately!
+        
+        ;; We need the arg elaborations and types no matter what, so...
+        (let-values ([(new-args new-types)
+                      ;; obviously eventually we'll want to use the
+                      ;; real method arg types instead of the map below.
+                      (map-two-values f args (map (lambda (_) #f) args))])
+          (if (eqv? (honu-mcall-obj exp) 'my)
+              ;; D(md) = t_1 ... t_n -> t
+              ;; P, G, D |- e_i |=> e_i' : t_i'   t_i' <: t_i  (NOT t_i <: t_i')
+              ;; --------------------------------------------
+              ;; P, G, D |- my.md(e_1, ..., e_n) |=>
+              ;;            my'.md(e_1', ..., e_n') : t
+              (if (cenv (honu-mcall-method exp))
+                  (let ((method-type (cenv (honu-mcall-method exp))))
+                    (if method-type
+                        (let loop ((n 0)
+                                   (dec-types (honu-dispatch-type-args method-type))
+                                   (calc-types new-types))
+                          (cond
+                            ((null? dec-types)
+                             (if (null? calc-types)
+                                 ;; We reached the end of both lists, so return
+                                 ;; the new expression and the return type.
+                                 (values (copy-struct honu-mcall exp
+                                                      (honu-mcall-args new-args))
+                                         (honu-dispatch-type-return method-type))
+                                 ;; calc-types isn't null, so too many arguments
+                                 ;; were given in the mcall expression.
+                                 (raise-read-error-with-stx
+                                  "Too many arguments for method."
+                                  (honu-ast-src-stx exp))))
+                            ;; dec-types isn't null, so we have too few arguments.
+                            ((null? calc-types)
+                             (raise-read-error-with-stx
+                              "Not enough arguments for method."
+                              (honu-ast-src-stx exp)))
+                            ;; t_i' <: t_i, so check the next one.
+                            ((<:_P tenv (car calc-types) (car dec-types))
+                             (loop (+ n 1) (cdr dec-types) (cdr calc-types)))
+                            ;; t_i was _not_ <: t_i', so blame the appropriate
+                            ;; expression.
+                            (else
+                             (raise-read-error-with-stx
+                              "Argument type is not subtype of declared type."
+                              (honu-ast-src-stx (list-ref (honu-mcall-args exp) n))))))
+                        ;; method-type was #f, so it couldn't be found in D.
+                        (raise-read-error-with-stx
+                         "Method not found in current class or mixin."
+                         (honu-mcall-method exp))))
+                  (if (env 'this)
+                      (raise-read-error-with-stx
+                       "No local method with this name."
+                       (honu-mcall-method exp))
+                      (raise-read-error-with-stx
+                       "Attempt to use static method call outside of class or mixin body."
+                       (honu-ast-src-stx exp))))
+              ;; P, G, D |- e |=> e' : t'  <md, t_1 ... t_n -> t> in t'
+              ;; P, G, D |- e_i |=> e_i' : t_i'             t_i' <: t_i  (NOT t_i <: t_i')
+              ;; ------------------------------------------------------
+              ;; P, G, D |- e.md(e_1, ..., e_n) |=>
+              ;;            e'.md(e_1', ..., e_n') : t
+              (let-values (((e0 t0) (f obj (honu-any-type obj))))
+                (let ((method-type (get-method-type tenv t0
+                                                    (honu-mcall-method exp))))
+                  (if method-type
+                      (let loop ((n 0)
+                                 (dec-types (honu-dispatch-type-args method-type))
+                                 (calc-types new-types))
+                        (cond
+                         ((null? dec-types)
+                          (if (null? calc-types)
+                              ;; We reached the end of both lists, so return
+                              ;; the new expression and the return type.
+                              (values (copy-struct honu-mcall exp
+                                        (honu-mcall-obj e0)
+                                        (honu-mcall-elab t0)
+                                        (honu-mcall-args new-args))
+                                      (honu-dispatch-type-return method-type))
+                              ;; calc-types isn't null, so too many arguments
+                              ;; were given in the mcall expression.
+                              (raise-read-error-with-stx
+                               "Too many arguments for method."
+                               (honu-ast-src-stx exp))))
+                         ;; dec-types isn't null, so we have too few arguments.
+                         ((null? calc-types)
+                          (raise-read-error-with-stx
+                           "Not enough arguments for method."
+                           (honu-ast-src-stx exp)))
+                         ;; t_i' <: t_i, so check the next one.
+                         ((<:_P tenv (car calc-types) (car dec-types))
+                          (loop (+ n 1) (cdr dec-types) (cdr calc-types)))
+                         ;; t_i was _not_ <: t_i', so blame the appropriate
+                         ;; expression.
+                         (else
+                          (raise-read-error-with-stx
+                           "Argument type is not subtype of declared type."
+                           (honu-ast-src-stx (list-ref (honu-mcall-args exp) n))))))
+                      ;; method-type was #f, so it couldn't be found in t1.
+                      (raise-read-error-with-stx
+                       "Method not found in type of object."
+                       (honu-mcall-method exp)))))))]
+       ;; P, G, D |- id |=> id : G(id)
+       [(struct honu-var (stx name builtin?))
+        (cond
+          [(env name)
+           =>
+           (lambda (t)
+             (if (and typ (not (<:_P tenv t typ)))
+                 (raise-type-error-with-stx typ t stx)
+                 (values exp t)))]
+          [(get-builtin-type name)
+           =>
+           (lambda (t)
+             (if (and typ (not (<:_P tenv t typ)))
+                 (raise-type-error-with-stx typ t stx)
+                 (values (copy-struct honu-var exp
+                           (honu-var-builtin? #t))
+                         t)))]
+          [else (raise-read-error-with-stx
+                 "Variable not bound in local environment."
+                 name)])]
+       ;; E(id) = t   P, G, D |- e |=> e' : t'   t' <: t
+       ;; ----------------------------------------------
+       ;;      P, G, D |- id = e |=> id = e' : void
+       [(struct honu-assn (stx name rhs))
+        (if (and typ (not (honu-type-equal? typ (honu-void-type stx))))
+            (raise-read-error-with-stx
+             "Assignment found in non-void context."
+             stx))
+        (let ((var-type (env (honu-assn-name exp))))
+          (if (not var-type)
+              (raise-read-error-with-stx
+               "Variable not bound in local environment."
+               name)
+              (let-values (((e1 t1) (f rhs var-type)))
+                (values (copy-struct honu-assn exp
+                          (honu-assn-rhs e1))
+                        (honu-void-type exp)))))]
+       [(struct honu-call (stx name args builtin?))
+        (cond
+          [(env name)
+           =>
+           (lambda (t)
+             (honu-typecheck-call tenv f exp t typ #f))]
+          [(get-builtin-type name)
+           =>
+           (lambda (t)
+             (honu-typecheck-call tenv f exp t typ #t))]
+          [else 
+           (raise-read-error-with-stx
+            (format "Function ~a not found" (printable-key name))
+            name)])]
+       ;; P, G, D |- this |=> this : G(this)
+       [(struct honu-this (stx))
+        (let ([this-type (env #'this)])
+          (if this-type
+              (if (and typ (not (<:_P tenv this-type typ)))
+                  (raise-type-error-with-stx typ this-type stx)
+                  (values exp this-type))
+              (raise-read-error-with-stx
+               "Use of this outside of a class or mixin body."
+               stx)))]
+       ;; P, G, D |- e1 |=> e1' : t'       P |- t  
+       ;; ---------------------------------------
+       ;; P, G, D |- cast e1 t |=> cast e1' t : t
+       ;;
+       ;; Note that we don't check for primitive types (fuller
+       ;; explanation under isa below), and also we don't do any
+       ;; checking of how t' relates to t -- that's not the point
+       ;; of a cast.  At runtime it will be checked that the object
+       ;; that e1 results in is of a class that implements t.
+       [(struct honu-cast (stx obj type))
+        ;; since we're casting, object can be of any (interface) type
+        (let-values (((e1 t1) (f obj (honu-any-type obj))))
+          (if (honu-iface-type-in-tenv? tenv type)
+              (values (copy-struct honu-cast exp
+                        (honu-cast-obj e1))
+                      (honu-cast-type exp))
+              (raise-read-error-with-stx
+               "Attempt to cast to invalid type."
+               (honu-ast-src-stx type))))]
+       ;; P, G, D |- e1 |=> e1' : t'        P |- t
+       ;; ----------------------------------------
+       ;; P, G, D |- e1 isa t |=> e1' isa t : bool
+       ;;
+       ;; Note that we don't check to see if e1's type is a primitive
+       ;; type and fail with an appropriate message if so.  How
+       ;; primitive do we want to treat primitives?  Might they stay
+       ;; "primitives", or might they eventually be changed into
+       ;; classes?
+       [(struct honu-isa (stx obj type))
+        ;; since we're checking isa, the object can be any (interface) stype
+        (let-values (((e1 t1) (f obj (honu-any-type obj))))
+          (if (honu-iface-type-in-tenv? tenv type)
+              (values (copy-struct honu-isa exp
+                        (honu-isa-obj e1))
+                      (honu-bool-type exp))
+              (raise-read-error-with-stx
+               "Attempt to check isa against invalid type."
+               (honu-ast-src-stx type))))]
+       ;; P, G, D |- e0 |=> e0' : bool  P, G, D |- e1 |=> e1' : t
+       ;;               P, G, D |- e2 |=> e2' : t
+       ;; -------------------------------------------------------
+       ;;  P, G, D |- if e0  then e1  else e2  |=>
+       ;;             if e0' then e1' else e2' : t
+       ;;
+       ;; We can make this a weaker rule by only requiring either
+       ;;   a) t1 <: t2; or
+       ;;   b) t2 <: t1
+       ;; and returning the supertype as the type of the if expression.
+       ;; Would this cause any problems (other than complicating the
+       ;; type rule/code)?
+       [(struct honu-if (stx test true false))
+        (let-values (((e0 t0) (f test (honu-bool-type test)))
+                     ((e1 t1) (f true typ))
+                     ((e2 t2) (f false typ)))
+          (cond
+            [(<:_P tenv t1 t2)
+             (values (copy-struct honu-if exp
+                       (honu-if-cond  e0)
+                       (honu-if-true  e1)
+                       (honu-if-false e2))
+                     t2)]
+            [(<:_P tenv t2 t1)
+             (values (copy-struct honu-if exp
+                       (honu-if-cond  e0)
+                       (honu-if-true  e1)
+                       (honu-if-false e2))
+                     t1)]
+            [else
+             (raise-read-error-with-stx
+              "Branches of if expression are of unrelated types."
+              stx)]))]
+       [(struct honu-while (stx cond body))
+        (let-values (((e1 t1) (f cond (honu-bool-type cond)))
+                     ((e2 t2) (f body #f)))
+          (values (copy-struct honu-while exp
+                    (honu-while-cond e1)
+                    (honu-while-body e2))
+                  (honu-void-type exp)))]
+       ;; P, G, D |- e_i |=> e_i' : t_i                     c [= t
+       ;; each init arg corresponding to id_i has type t_i' where
+       ;; t_i <: t_i'
+       ;; --------------------------------------------------------
+       ;; P, G, D |- new c : t (id_1 = e_1, ..., id_n = e_n) |=>
+       ;;            new c : t (id_1 = e_1', ..., id_n = e_n') : t
+       ;;
+       [(struct honu-new (stx class type arg-names arg-vals))
+        (cond
+          [(and typ type (not (<:_P tenv type typ)))
+           (raise-type-error-with-stx typ type stx)]
+          [(not (get-class-entry class tenv))
+           (raise-read-error-with-stx
+            "Undefined class"
+            class)]
+          [(and type (not (honu-iface-type-in-tenv? tenv type)))
+           (raise-read-error-with-stx
+            "Undefined type or non-interface type"
+            (honu-ast-src-stx type))]
+          [(and (not type) (not typ))
+           (raise-read-error-with-stx
+            "Type to create in new statement needs to be explicitly stated."
+            stx)]
+          ;; if there was no explicit type given...
+          [(not type)
+           (if (Implements_P tenv class typ)
+                (let-values ([(new-args new-types)
+                              (map-two-values f arg-vals (map (lambda (_) #f) arg-vals))])
+                  (let ((remainder (fold (lambda (n t i)
+                                           (check-init-type-for-name tenv i n t))
+                                         (get-init-names-and-types tenv class)
+                                         (honu-new-arg-names exp)
+                                         new-types)))
+                    (if (or (null? remainder)
+                            (not (ormap tenv-init-optional? remainder))) ; checks to see if all optional
+                        (values (copy-struct honu-new exp
+                                  (honu-new-type typ)
+                                  (honu-new-arg-vals new-args))
+                                typ)
+                        (raise-read-error-with-stx
+                         "Too few initialization arguments in new expression."
+                         stx))))
+                (raise-read-error-with-stx
+                 (format "Class for new expression does not implement type ~a."
+                         (printable-type typ))
+                 stx))]
+          ;; FIXME: still need to do appropriate things with typ in here
+          [type
+            (if (Implements_P tenv class type)
+                (let-values ([(new-args new-types)
+                              (map-two-values f arg-vals (map (lambda (_) #f) arg-vals))])
+                  (let ((remainder (fold (lambda (n t i)
+                                           (check-init-type-for-name tenv i n t))
+                                         (get-init-names-and-types tenv class)
+                                         (honu-new-arg-names exp)
+                                         new-types)))
+                    (if (or (null? remainder)
+                            (not (ormap tenv-init-optional? remainder))) ; checks to see if all optional
+                        (values (copy-struct honu-new exp
+                                  (honu-new-arg-vals new-args))
+                                (honu-new-type exp))
+                        (raise-read-error-with-stx
+                         "Too few initialization arguments in new expression."
+                         stx))))
+                (raise-read-error-with-stx
+                 "Class for new expression does not implement type in new expression."
+                 stx))])]
+       ;; P, G_i, D |- tid_i id_i = rhs_i |=> tid_i id_i = rhs_i', G_(i+1)
+       ;; P, G_(m+1), D |- e_i |=> e_i' : t_i
+       ;; ----------------------------------------------------------------
+       ;; P, G_0, D |- { tid_0 id_0 = rhs_0; ...; tid_m id_m = rhs_m;
+       ;;                e_0; ...; e_n; } |=>
+       ;;              { tid_0 id_0 = rhs_0'; ...; tid_m id_m = rhs_m';
+       ;;                e_0'; ...; e_n'; } : t_n
+       [(struct honu-block (stx binds exps))
+        (let*-values ([(new-bind-f) (honu-typecheck-binding tenv cenv)]
+                      [(new-binds new-env)
+                       (map-and-fold new-bind-f env binds)]
+                      [(new-f) (honu-typecheck-exp tenv new-env cenv)]
+                      [(new-exps last-type)
+                       (let loop ([exps exps]
+                                  [new-exps '()]
+                                  [new-types '()])
+                         ;; we know we must have at least one expression,
+                         ;; so here's our base case.
+                         (if (null? (cdr exps))
+                             ;; type of last expression should fit block context.
+                             (let-values ([(e1 t1) (new-f (car exps) typ)])
+                               (values (reverse (cons e1 new-exps))
+                                       ;; just need the last expression's type
+                                       t1))
+                             ;; since we don't care about the types of any but the
+                             ;; last expression in a block, just pass in #f
+                             (let-values ([(e1 t1) (new-f (car exps) #f)])
+                               (loop (cdr exps)
+                                     (cons e1 new-exps)
+                                     (cons t1 new-types)))))])
+          (values (copy-struct honu-block exp
+                    (honu-block-binds new-binds)
+                    (honu-block-exps  new-exps))
+                  last-type))]
+       ;;       P, G, D |- e |=> e' : t
+       ;; -------------------------------------
+       ;; P, G, D |- return e |=> return e' : t
+       [(struct honu-return (stx body))
+        (if body
+            (let-values ([(e1 t1) (f body typ)])
+              (values (copy-struct honu-return exp
+                        (honu-return-body e1))
+                      t1))
+            (if typ
+                (raise-read-error-with-stx
+                 "Found void return in non-void context"
+                 stx)
+                (values exp (honu-void-type exp))))]
+       [else
+        (raise-read-error-with-stx
+         "Unexpected type of Honu expression."
+         (honu-ast-src-stx exp))]))
+    f)
+
+  ;;       P, G, D |- rhs |=> rhs' : t'    t' <: t
+  ;; --------------------------------------------------
+  ;; P, G, D |- t id = rhs |=> t id = rhs', G[id |-> t]
+;  (provide honu-typecheck-binding)
+  (provide/contract [honu-typecheck-binding
+                     (tenv?
+                      any/c
+                      . -> .
+                      ((honu-binding? any/c)
+                       . ->* .
+                       (honu-binding? any/c)))]) 
+  (define (honu-typecheck-binding tenv cenv)
+    (lambda (bind env)
+      (match-let ([(struct honu-binding (ast name type rhs)) bind])
+        (let-values (((e1 t1) ((honu-typecheck-exp tenv env cenv) rhs type)))
+          (values (copy-struct honu-binding bind
+                    (honu-binding-rhs e1))
+                  (extend-env env name type))))))
+
+  (define (honu-typecheck-call tenv f exp t typ builtin?)
+    (match-let ([(struct honu-call (stx name args builtin?)) exp])
+      (if (not (honu-func-type? t))
+          (raise-read-error-with-stx
+           "Expression is not a function."
+           name))
+      (if (and typ (not (<:_P tenv (honu-func-type-return t) typ)))
+          (raise-type-error-with-stx typ (honu-func-type-return t) stx))
+      (let-values ([(arg-exps arg-types)
+                    (map-two-values (lambda (e t) (f e t))
+                                    args (honu-func-type-args t))])
+        (let ([formals-length (length (honu-func-type-args t))]
+              [actuals-length (length arg-types)])
+          (cond
+            [(< formals-length actuals-length)
+             (raise-read-error-with-stx
+              (format "~a function got ~a more argument~a than expected"
+                      (if builtin? "Built-in" "Declared")
+                      (- actuals-length formals-length)
+                      (if (= (- actuals-length formals-length) 1) "" "s"))
+              stx)]
+            [(> formals-length actuals-length)
+             (raise-read-error-with-stx
+              (format "~a function got ~a fewer argument~a than expected"
+                      (if builtin? "Built-in" "Declared")
+                      (- formals-length actuals-length)
+                      (if (= (- formals-length actuals-length) 1) "" "s"))
+              stx)]
+            [else (values (copy-struct honu-call exp
+                            (honu-call-args arg-exps)
+                            (honu-call-builtin? builtin?))
+                          (honu-func-type-return t))])))))
+  )
diff --git a/collects/honu/private/typechecker/honu-typecheck-function.ss b/collects/honu/private/typechecker/honu-typecheck-function.ss
new file mode 100644
index 0000000000..7bd8a97937
--- /dev/null
+++ b/collects/honu/private/typechecker/honu-typecheck-function.ss
@@ -0,0 +1,26 @@
+(module honu-typecheck-function mzscheme
+  (require (lib "struct.ss")
+           (lib "plt-match.ss")
+           (lib "list.ss" "srfi" "1"))
+  
+  (require "../../ast.ss")
+  (require "honu-type-utils.ss")
+  (require "honu-typecheck-exp.ss")
+  (require "../../read-error-with-stx.ss")
+    
+  (provide honu-typecheck-function)
+  (define (honu-typecheck-function tenv defn)
+    (match-let ([(struct honu-function (stx name type arg-names arg-types body)) defn])
+      (let ((env (fold (lambda (n t e)
+                         (extend-env e n t))
+                       (get-initial-env tenv)
+                       arg-names
+                       arg-types)))
+        (let-values ([(e1 t1) ((honu-typecheck-exp tenv env (empty-env)) body (if (honu-top-type? type) #f type))])
+          (if (<:_P tenv t1 type)
+              (copy-struct honu-function defn
+                (honu-function-body e1))
+              (raise-read-error-with-stx
+               "Body of function's type does not match declared return type"
+               (honu-ast-src-stx body)))))))
+  )
diff --git a/collects/honu/private/typechecker/honu-typecheck-mixin.ss b/collects/honu/private/typechecker/honu-typecheck-mixin.ss
new file mode 100644
index 0000000000..f601daa1e3
--- /dev/null
+++ b/collects/honu/private/typechecker/honu-typecheck-mixin.ss
@@ -0,0 +1,98 @@
+(module honu-typecheck-mixin mzscheme
+  
+  (require (lib "list.ss" "srfi" "1")
+           (prefix list: (lib "list.ss"))
+           (lib "struct.ss"))
+  
+  (require "../../ast.ss")
+  (require "../../utils.ss")
+  (require "../../tenv.ss")
+  (require "honu-type-utils.ss")
+  (require "honu-typecheck-class-utils.ss")
+  (require "honu-typecheck-exp.ss")
+  
+  (require "../../read-error-with-stx.ss")
+  
+  (provide honu-typecheck-mixin)
+  (define (honu-typecheck-mixin tenv mixin)
+    (if (not (honu-iface-type-in-tenv? tenv (honu-mixin-type mixin)))
+        (raise-read-error-with-stx
+         "Type of this within mixin not defined in program."
+         (honu-ast-src-stx (honu-mixin-type mixin))))
+    (if (not (honu-iface-type-in-tenv? tenv (honu-mixin-arg-type mixin)))
+        (raise-read-error-with-stx
+         "Type mixin takes as argument not defined in program."
+         (honu-ast-src-stx (honu-mixin-type mixin))))
+    (if (not (<:_P tenv (honu-mixin-type mixin) (honu-mixin-arg-type mixin)))
+        (raise-read-error-with-stx
+         "Type of this within mixin not subtype of argument class."
+         (honu-ast-src-stx (honu-mixin-type mixin))))
+    (check-impl-types tenv (honu-mixin-impls mixin))
+    (check-init-slots tenv (honu-mixin-init-names mixin) (honu-mixin-init-types mixin))
+    (let*-values (((new-befores new-env new-cenv new-init-cenv)
+                   (honu-typecheck-slotdefns tenv
+                                             (extend-env (get-initial-env tenv) #'this (honu-mixin-type mixin))
+                                             (empty-env)
+                                             (fold (lambda (n t e)
+                                                     (extend-env e n t))
+                                                   (empty-env)
+                                                   (honu-mixin-init-names mixin)
+                                                   (honu-mixin-init-types mixin))
+                                             (honu-mixin-defns-before mixin)))
+                  ((new-super-new)
+                   (honu-typecheck-super-new tenv new-env new-cenv new-init-cenv
+                                             (honu-mixin-super-new mixin)
+                                             (honu-mixin-with-names mixin)
+                                             (honu-mixin-with-types mixin)))
+                  ((new-cenv new-init-cenv)
+                   (extend-cenvs new-cenv new-init-cenv
+                                 (get-fields-and-methods tenv (honu-mixin-arg-type mixin))))
+                  ((new-afters new-env new-cenv new-init-cenv)
+                   (honu-typecheck-slotdefns tenv new-env new-cenv new-init-cenv
+                                             (honu-mixin-defns-after mixin))))
+      (check-impls-and-exports tenv new-cenv
+                               (honu-mixin-type mixin)
+                               (honu-mixin-impls mixin)
+                               (honu-mixin-exports mixin))
+      (copy-struct honu-mixin mixin
+        (honu-mixin-defns-before new-befores)
+        (honu-mixin-super-new new-super-new)
+        (honu-mixin-defns-after  new-afters))))
+
+  (define (sort-by-names names vals)
+    (let ((sorted (list:quicksort (map cons names vals)
+                                  (lambda (a b)
+                                    (string<? (symbol->string (printable-key (car a)))
+                                              (symbol->string (printable-key (car b))))))))
+      (values (map car sorted) (map cdr sorted))))
+  
+  (define (honu-typecheck-super-new tenv env cenv init-cenv snew with-names with-types)
+    (let-values (((arg-names arg-vals)
+                  (sort-by-names (honu-super-new-arg-names snew)
+                                 (honu-super-new-arg-vals  snew)))
+                 ((with-names with-types)
+                  (sort-by-names with-names with-types)))
+      (begin
+        (if (not (andmap tenv-key=? arg-names with-names))
+            (raise-read-error-with-stx
+             "Arguments to super_new do not match declared names in with clause."
+             (honu-ast-src-stx snew)))
+        (copy-struct honu-super-new snew
+          (honu-super-new-arg-vals
+           (map (lambda (dec-type val)
+                             (let-values (((e1 t1)
+                                           ((honu-typecheck-exp tenv env init-cenv) val)))
+                               (if (<:_P tenv t1 dec-type)
+                                   e1
+                                   (raise-read-error-with-stx
+                                    "Argument to super_new does not match declared type for name."
+                                    (honu-ast-src-stx val)))))
+                with-types arg-vals))))))
+                                
+  (define (extend-cenvs cenv init-cenv new-stuff)
+    (if (null? new-stuff)
+        (values cenv init-cenv)
+        (extend-cenvs (extend-env cenv (caar new-stuff) (cdar new-stuff))
+                      (extend-env init-cenv (caar new-stuff) (cdar new-stuff))
+                      (cdr new-stuff))))
+  )
diff --git a/collects/honu/private/typechecker/honu-typecheck-postchecks.ss b/collects/honu/private/typechecker/honu-typecheck-postchecks.ss
new file mode 100644
index 0000000000..4c2dbcfed0
--- /dev/null
+++ b/collects/honu/private/typechecker/honu-typecheck-postchecks.ss
@@ -0,0 +1,93 @@
+(module honu-typecheck-postchecks mzscheme
+  
+  (require "../../ast.ss")
+  (require "honu-type-utils.ss")
+  (require "../../read-error-with-stx.ss")
+  
+  (provide check-type-elaborations)
+  (define (check-type-elaborations ast)
+    (cond
+      [(honu-program? ast)
+       (for-each check-type-elaborations (honu-program-defns ast))]
+      
+      [(honu-type-defn? ast) (void)]
+      [(honu-class? ast)
+       (for-each check-type-elaborations (honu-class-defns ast))]
+      [(honu-mixin? ast)
+       (for-each check-type-elaborations (honu-mixin-defns-before ast))
+       (check-type-elaborations (honu-mixin-super-new ast))
+       (for-each check-type-elaborations (honu-mixin-defns-after ast))]
+      [(honu-subclass? ast) (void)]
+   
+      [(honu-init-field? ast)
+       (if (honu-init-field-value ast)
+           (check-type-elaborations (honu-init-field-value ast)))]
+      [(honu-field? ast)
+       (check-type-elaborations (honu-field-value ast))]
+      [(honu-method? ast)
+       (check-type-elaborations (honu-method-body ast))]
+      
+      [(honu-super-new? ast)
+       (for-each check-type-elaborations (honu-super-new-arg-vals ast))]
+
+      [(honu-null? ast) (void)]
+      [(honu-int? ast) (void)]
+      [(honu-float? ast) (void)]
+      [(honu-bool? ast) (void)]
+      [(honu-char? ast) (void)]
+      [(honu-str? ast) (void)]
+      [(honu-prim? ast)
+       (check-type-elaborations (honu-prim-left ast))
+       (check-type-elaborations (honu-prim-right ast))]
+      [(honu-facc? ast)
+       (if (not (eqv? (honu-facc-obj ast) 'my))
+           (begin
+             (check-type-elaborations (honu-facc-obj ast))
+             (if (not (honu-iface-type? (honu-facc-elab ast)))
+                 (raise-read-error-with-stx
+                  "Found a non-static field access without a type elaboration."
+                  (honu-ast-src-stx ast)))))]
+      [(honu-fassn? ast)
+       (if (not (eqv? (honu-fassn-obj ast) 'my))
+           (begin
+             (check-type-elaborations (honu-fassn-obj ast))
+             (if (not (honu-iface-type? (honu-fassn-elab ast)))
+                 (raise-read-error-with-stx
+                  "Found a non-static field assignment without a type elaboration."
+                  (honu-ast-src-stx ast)))))
+       (check-type-elaborations (honu-fassn-rhs ast))]
+      [(honu-mcall? ast)
+       (if (not (eqv? (honu-mcall-obj ast) 'my))
+           (begin
+             (check-type-elaborations (honu-mcall-obj ast))
+             (if (not (honu-iface-type? (honu-mcall-elab ast)))
+                 (raise-read-error-with-stx
+                  "Found non-static method call without a type elaboration."
+                  (honu-ast-src-stx ast)))))
+       (for-each check-type-elaborations (honu-mcall-args ast))]
+      [(honu-var? ast) (void)]
+      [(honu-assn? ast)
+       (check-type-elaborations (honu-assn-rhs ast))]
+      [(honu-call? ast)
+       (for-each check-type-elaborations (honu-call-args ast))]
+      [(honu-this? ast) (void)]
+      [(honu-cast? ast)
+       (check-type-elaborations (honu-cast-obj ast))]
+      [(honu-isa? ast)
+       (check-type-elaborations (honu-isa-obj ast))]
+      [(honu-if? ast)
+       (check-type-elaborations (honu-if-cond  ast))
+       (check-type-elaborations (honu-if-true  ast))
+       (check-type-elaborations (honu-if-false ast))]
+      [(honu-new? ast)
+       (for-each check-type-elaborations (honu-new-arg-vals ast))]
+      [(honu-block? ast)
+       (for-each check-type-elaborations (honu-block-binds ast))
+       (for-each check-type-elaborations (honu-block-exps ast))]
+      [(honu-return? ast)
+       (check-type-elaborations (honu-return-body ast))]
+      
+      [(honu-binding? ast)
+       (check-type-elaborations (honu-binding-rhs ast))]))
+
+      )
diff --git a/collects/honu/private/typechecker/honu-typecheck-prechecks.ss b/collects/honu/private/typechecker/honu-typecheck-prechecks.ss
new file mode 100644
index 0000000000..0abd9b465e
--- /dev/null
+++ b/collects/honu/private/typechecker/honu-typecheck-prechecks.ss
@@ -0,0 +1,88 @@
+(module honu-typecheck-prechecks mzscheme
+  
+  (require (lib "list.ss" "srfi" "1"))
+  (require "../../ast.ss")
+  (require "../../read-error-with-stx.ss")
+  
+  (provide check-uses-of-this)
+  (define (check-uses-of-this ast)
+    (cond
+      [(honu-program? ast)
+       (for-each check-uses-of-this (honu-program-defns ast))]
+      
+      [(honu-type-defn? ast) (void)]
+      [(honu-class? ast)
+       (for-each check-uses-of-this (honu-class-defns ast))]
+      [(honu-mixin? ast)
+       (for-each check-uses-of-this (honu-mixin-defns-before ast))
+       (check-uses-of-this (honu-mixin-super-new ast))
+       (for-each check-uses-of-this (honu-mixin-defns-after ast))]
+      [(honu-subclass? ast) (void)]
+   
+      [(honu-init-field? ast)
+       (if (honu-init-field-value ast)
+           (check-uses-of-this (honu-init-field-value ast)))]
+      [(honu-field? ast)
+       (check-uses-of-this (honu-field-value ast))]
+      [(honu-method? ast)
+       (check-uses-of-this (honu-method-body ast))]
+      
+      [(honu-super-new? ast)
+       (for-each check-uses-of-this (honu-super-new-arg-vals ast))]
+
+      [(honu-null? ast) (void)]
+      [(honu-int? ast) (void)]
+      [(honu-float? ast) (void)]
+      [(honu-bool? ast) (void)]
+      [(honu-char? ast) (void)]
+      [(honu-str? ast) (void)]
+      [(honu-prim? ast)
+       (check-uses-of-this (honu-prim-left ast))
+       (check-uses-of-this (honu-prim-right ast))]
+      [(honu-facc? ast)
+       (if (and (not (eqv? (honu-facc-obj ast) 'my))
+                (not (honu-this? (honu-facc-obj ast))))  ; this on the left side of a dot is okay
+           (check-uses-of-this (honu-facc-obj ast)))]
+      [(honu-fassn? ast)
+       (if (and (not (eqv? (honu-fassn-obj ast) 'my))
+                (not (honu-this? (honu-fassn-obj ast)))) ; this on the left side of a dot is okay
+           (check-uses-of-this (honu-fassn-obj ast)))
+       (check-uses-of-this (honu-fassn-rhs ast))]
+      [(honu-mcall? ast)
+       (if (and (not (eqv? (honu-mcall-obj ast) 'my))
+                (not (honu-this? (honu-mcall-obj ast)))) ; this on the left side of a dot is okay
+           (check-uses-of-this (honu-mcall-obj ast)))
+       (for-each check-uses-of-this (honu-mcall-args ast))]
+      [(honu-var? ast) (void)]
+      [(honu-assn? ast)
+       (check-uses-of-this (honu-assn-rhs ast))]
+      [(honu-call? ast)
+       (for-each check-uses-of-this (honu-call-args ast))]
+      [(honu-this? ast)
+       ;; we reached a case where this is not okay, so we throw an exception
+       (raise-read-error-with-stx
+        "Unprotected use of this in possible client context."
+        (honu-ast-src-stx ast))]
+      [(honu-cast? ast)
+       (if (not (honu-this? (honu-cast-obj ast))) ; this in a cast is okay.
+           (check-uses-of-this (honu-cast-obj ast)))]
+      [(honu-isa? ast)
+       (if (not (honu-this? (honu-isa-obj ast))) ; this in an isa is okay.
+           (check-uses-of-this (honu-isa-obj ast)))]
+      [(honu-if? ast)
+       (check-uses-of-this (honu-if-cond  ast))
+       (check-uses-of-this (honu-if-true  ast))
+       (check-uses-of-this (honu-if-false ast))]
+      [(honu-new? ast)
+       (for-each check-uses-of-this (honu-new-arg-vals ast))]
+      [(honu-block? ast)
+       (for-each check-uses-of-this (honu-block-binds ast))
+       (for-each check-uses-of-this (honu-block-exps ast))]
+      [(honu-return? ast)
+       (check-uses-of-this (honu-return-body ast))]
+      
+      [(honu-binding? ast)
+       (check-uses-of-this (honu-binding-rhs ast))]))
+
+      
+  )
diff --git a/collects/honu/private/typechecker/honu-typecheck-type-defn.ss b/collects/honu/private/typechecker/honu-typecheck-type-defn.ss
new file mode 100644
index 0000000000..98300513d2
--- /dev/null
+++ b/collects/honu/private/typechecker/honu-typecheck-type-defn.ss
@@ -0,0 +1,73 @@
+(module honu-typecheck-type-defn mzscheme
+  
+  (require (lib "list.ss" "srfi" "1"))
+  
+  (require "../../ast.ss")
+  (require "../../utils.ss")
+  (require "honu-type-utils.ss")
+  (require "../../read-error-with-stx.ss")
+  
+  (provide honu-typecheck-type-defn)
+  
+  ;; P |- t_i   P |- t'_i   P |- mdec_i
+  ;; ------------------------------------
+  ;; P, J |- type t <: t_1 ... t_m {
+  ;;           t'_1 fd_1; ...; t'_k fd_k;
+  ;;           mdec_1; ...; mdec_n;
+  ;;         }
+  ;;      |=> type t <: t_1 ... t_m
+  ;;            t'_1 fd_1; ...; t'_k fd_k;
+  ;;            mdec_1; ...; mdec_n;
+  ;;          }, J
+  ;;
+  ;; Neither the type definition nor the init-arg environment
+  ;; are modified by the type definition typechecker.
+  (define (honu-typecheck-type-defn tenv defn)
+    (begin (check-supers tenv (honu-type-defn-supers defn))
+           (check-field-decls tenv (filter (lambda (d)
+                                            (honu-field-decl? d))
+                                          (honu-type-defn-decls defn)))
+           (check-method-decls tenv (filter (lambda (d)
+                                             (honu-method-decl? d))
+                                           (honu-type-defn-decls defn)))
+           defn))
+  
+  (define (check-supers tenv super-list)
+    (cond
+      [(null? super-list) #t]
+      [(not (honu-iface-type-in-tenv? tenv (car super-list)))
+       (raise-read-error-with-stx
+        "Type declared as supertype not found in program."
+        (honu-ast-src-stx (car super-list)))]
+      [else (check-supers tenv (cdr super-list))]))
+  
+  (define (check-field-decls tenv field-list)
+    (cond
+      [(null? field-list) #t]
+      [(not (honu-type-in-tenv? tenv (honu-field-decl-type (car field-list))))
+       (raise-read-error-with-stx
+        "Type of field not found in program."
+        (honu-ast-src-stx (honu-field-decl-type (car field-list))))]
+      [else (check-field-decls tenv (cdr field-list))]))
+
+  ;; P |- t          P |- t_i
+  ;; ------------------------
+  ;; P |- t md(t_1, ..., t_n)
+  (define (check-method-decls tenv method-list)
+    (cond
+      [(null? method-list) #t]
+      [(not (or (honu-top-type? (honu-method-decl-type (car method-list))) ; allow void for return type of method
+                (honu-type-in-tenv? tenv (honu-method-decl-type (car method-list)))))
+       (raise-read-error-with-stx
+        "Return type of method not found in program."
+        (honu-ast-src-stx (honu-method-decl-type (car method-list))))]
+      [else (let loop ((arg-types (honu-method-decl-arg-types (car method-list))))
+              (cond
+                [(null? arg-types)
+                 (check-method-decls tenv (cdr method-list))]
+                [(not (honu-type-in-tenv? tenv (car arg-types)))
+                 (raise-read-error-with-stx
+                  "Type of argument for method not found in program."
+                  (honu-ast-src-stx (car arg-types)))]
+                [else (loop (cdr arg-types))]))]))
+  )
diff --git a/collects/honu/private/typechecker/honu-typecheck.ss b/collects/honu/private/typechecker/honu-typecheck.ss
new file mode 100644
index 0000000000..a3774c9f18
--- /dev/null
+++ b/collects/honu/private/typechecker/honu-typecheck.ss
@@ -0,0 +1,51 @@
+(module honu-typecheck mzscheme
+  (require (lib "struct.ss")
+           (lib "contract.ss"))
+  
+  (require "../../ast.ss")
+  (require "../../tenv.ss")
+  (require "honu-type-utils.ss")
+  (require "honu-convert-static.ss")
+  (require "honu-typecheck-function.ss")
+  (require "honu-typecheck-type-defn.ss")
+  (require "honu-typecheck-class.ss")
+  (require "honu-typecheck-mixin.ss")
+  (require "honu-typecheck-prechecks.ss")
+  (require "../../read-error-with-stx.ss")
+
+;  (provide honu-typecheck-program)
+  (provide/contract [honu-typecheck-program
+                     (tenv?
+                      honu-program?
+                      . -> .
+                      honu-program?)])
+  (define (honu-typecheck-program tenv pgm)
+    (let ((pgm (honu-convert-static tenv pgm)))
+      (check-uses-of-this pgm)
+      (let-values (((new-defns)
+                    (map (lambda (d)
+                           (honu-typecheck-defn tenv d))
+                         (honu-program-defns pgm))))
+        (let ((new-pgm (copy-struct honu-program pgm
+                         (honu-program-defns new-defns))))
+          new-pgm))))
+  
+  (define (honu-typecheck-defn tenv defn)
+    (cond
+      [(honu-function? defn)
+       (honu-typecheck-function tenv defn)]
+      [(honu-type-defn? defn)
+       (honu-typecheck-type-defn tenv defn)]
+      [(honu-subclass? defn)
+       ;; we don't need to check this anymore, because it's checked in add-defns-to-tenv
+       ;       (honu-typecheck-subclass pgm defn)]
+       defn]
+      [(honu-mixin? defn)
+       (honu-typecheck-mixin tenv defn)]
+      [(honu-class? defn)
+       (honu-typecheck-class tenv defn)]
+      [else
+       (raise-read-error-with-stx
+        "Unknown type of top-level definition."
+        (honu-ast-src-stx defn))]))
+  )
diff --git a/collects/honu/read-error-with-stx.ss b/collects/honu/read-error-with-stx.ss
new file mode 100644
index 0000000000..e1efae1af0
--- /dev/null
+++ b/collects/honu/read-error-with-stx.ss
@@ -0,0 +1,20 @@
+(module read-error-with-stx mzscheme
+  
+  (require (lib "readerr.ss" "syntax"))
+  
+  (provide raise-read-error-with-stx)
+  ;; Yes, this is misleading for now.  I'll rename it later.
+  ;; (define (raise-read-error-with-stx str stx)
+  ;;   (raise-syntax-error #f str stx))
+
+  ;; Forget it, this gives you less extra crap with your error message.
+  ;; I'd need to decide what to put in those places instead, so at the
+  ;; moment we'll keep it a read error.
+  (define (raise-read-error-with-stx str stx)
+    (raise-read-error str
+                      (syntax-source stx)
+                      (syntax-line stx)
+                      (syntax-column stx)
+                      (syntax-position stx)
+                      (syntax-span stx)))
+  )
diff --git a/collects/honu/tenv-utils.ss b/collects/honu/tenv-utils.ss
new file mode 100644
index 0000000000..53b369acf9
--- /dev/null
+++ b/collects/honu/tenv-utils.ss
@@ -0,0 +1,118 @@
+(module tenv-utils mzscheme
+
+  (require "read-error-with-stx.ss"
+           "ast.ss"
+           "tenv.ss"
+           "private/typechecker/honu-type-utils.ss"
+           (lib "plt-match.ss")
+           (lib "list.ss" "srfi" "1"))
+
+  (provide add-defns-to-tenv add-defn-to-tenv)
+  (define (add-defns-to-tenv defns tenv)
+    (for-each (lambda (d)
+                (add-defn-to-tenv d tenv))
+              defns))
+
+  (define (add-defn-to-tenv defn tenv)
+    (match defn
+      [(struct honu-function (src-stx name t _ arg-types _))
+       (extend-tenv name (make-tenv-func src-stx arg-types t) tenv)]
+      [(struct honu-type-defn (src-stx name supers decls))
+       (extend-tenv name (make-tenv-type src-stx supers decls) tenv)]
+      [(struct honu-class (src-stx name t f? i-names i-types impls defns _))
+       (extend-tenv name (make-tenv-class src-stx t impls
+                                          (get-inits i-names i-types defns)
+                                          f? #f) tenv)]
+      [(struct honu-mixin (src-stx name type arg-type final? init-names init-types
+               impls with-names with-types defns-before _ defns-after _))
+       (extend-tenv name (make-tenv-mixin src-stx arg-type type impls
+                                          (get-inits init-names init-types
+                                                     (append defns-before 
+                                                             defns-after))
+                                          with-names with-types final?) tenv)]
+      [(struct honu-subclass (src-stx name mixin base))
+       (if (tenv-class-final? (get-class-entry base tenv))
+           (raise-read-error-with-stx
+            (format "Cannot apply mixin to final class ~a"
+                    (printable-key base))
+            base))
+       (extend-tenv name (generate-subclass-tenv defn tenv) tenv)]))
+
+  (define (get-inits init-names init-types defns)
+    (let ([init-fields (filter (lambda (d)
+                                 (honu-init-field? d))
+                               defns)])
+      (append (map (lambda (n t)
+                     (make-tenv-init n t #t))
+                   init-names init-types)
+              (map (lambda (d)
+                     (if (not (honu-init-field-value d))
+                         (make-tenv-init (honu-init-field-name d)
+                                         (honu-init-field-type d)
+                                         #t)
+                         (make-tenv-init (honu-init-field-name d)
+                                         (honu-init-field-type d)
+                                         #f)))
+                   init-fields))))
+
+  (define (generate-subclass-tenv defn tenv)
+    (let ([base  (get-class-entry (honu-subclass-base defn)  tenv)]
+          [mixin (get-mixin-entry (honu-subclass-mixin defn) tenv)])
+      (if (not (<:_P tenv (tenv-class-sub-type base) (tenv-mixin-arg-type mixin)))
+          (raise-read-error-with-stx
+           (format "Class ~a is not of an appropriate type for mixin ~a"
+                   (printable-key (honu-subclass-base defn))
+                   (printable-key (honu-subclass-mixin defn)))
+           (honu-subclass-base defn)))
+      (let ([new-inits (remove-used-inits tenv defn
+                                          (tenv-class-inits base)
+                                          (tenv-mixin-used-names mixin)
+                                          (tenv-mixin-used-types mixin))])
+        (make-tenv-class (honu-ast-src-stx defn)
+                         (tenv-mixin-sub-type mixin)
+                         (tenv-mixin-impls mixin)
+                         (append (tenv-mixin-inits mixin)
+                                 new-inits)
+                         (tenv-mixin-final? mixin)
+                         (honu-subclass-base defn)))))
+
+  (define (remove-used-inits tenv defn old-inits used-names used-types)
+    (let loop ([old-inits  old-inits]
+               [used-names used-names]
+               [used-types used-types]
+               [new-inits  '()])
+      (if (null? old-inits)
+          (if (not (null? used-names))
+              (raise-read-error-with-stx
+               (format "Class ~a does not have an init arg ~a with the correct type"
+                       (printable-key (honu-subclass-base defn))
+                       (printable-key (car used-names)))
+               (honu-subclass-base defn))
+              (reverse new-inits))
+          (let* ([curr (car old-inits)]
+                 [index (list-index (lambda (n)
+                                      (tenv-key=? n (tenv-init-name curr)))
+                                    used-names)])
+            (if index
+                (if (<:_P tenv (list-ref used-types index) (tenv-init-type curr))
+                    (loop (cdr old-inits)
+                          (append (take used-names index)
+                                  (drop used-names (+ index 1)))
+                          (append (take used-types index)
+                                  (drop used-types (+ index 1)))
+                          new-inits)
+                    (if (tenv-init-optional? curr)
+                        (loop (cdr old-inits)
+                              used-names
+                              used-types
+                              (cons curr new-inits))
+                        (raise-read-error-with-stx
+                         (format "Mixin ~a needs an incompatible type for init arg ~a"
+                                 (printable-key (honu-subclass-mixin defn))
+                                 (printable-key (car used-names)))
+                         (honu-subclass-mixin defn))))
+                (loop (cdr old-inits)
+                      used-names
+                      used-types
+                      (cons curr new-inits)))))))
+  )
diff --git a/collects/honu/tenv.ss b/collects/honu/tenv.ss
new file mode 100644
index 0000000000..65d805a78a
--- /dev/null
+++ b/collects/honu/tenv.ss
@@ -0,0 +1,119 @@
+(module tenv mzscheme
+  
+  (require (lib "boundmap.ss" "syntax")
+           (lib "contract.ss"))
+  
+  (require "ast.ss")
+  (require "read-error-with-stx.ss")
+  
+  (provide (struct tenv-entry (src-stx))
+           (struct tenv-init  (name type optional?))
+           (struct tenv-type  (supers members))
+           (struct tenv-class (sub-type impls inits final? super))
+           (struct tenv-mixin (arg-type sub-type impls inits
+                                      used-names used-types final?))
+           (struct tenv-func  (arg-types return-type)))
+  
+  (define-struct tenv-entry (src-stx))
+
+  (define-struct tenv-init (name type optional?))
+ 
+  ;; members will be a hashtable from member names to types
+  (define-struct (tenv-type  tenv-entry) (supers members))
+  (define-struct (tenv-class tenv-entry) (sub-type impls inits final? super))
+  (define-struct (tenv-mixin tenv-entry) (arg-type sub-type impls inits
+                                           used-names used-types final?))
+  (define-struct (tenv-func  tenv-entry) (arg-types return-type))
+   
+  (provide tenv?)
+  (define tenv? bound-identifier-mapping?)
+
+  (provide/contract [printable-key (identifier? . -> . symbol?)]
+                    [tenv-key=?    (identifier? identifier? . -> . any)]
+                    [tenv-map      (tenv?
+                                    (identifier? tenv-entry? . -> . any)
+                                    . -> .
+                                    list?)])
+  (define printable-key syntax-e)
+  (define tenv-key=? bound-identifier=?)
+  (define tenv-map bound-identifier-mapping-map)
+
+  (provide/contract [empty-tenv (-> tenv?)]
+                    [extend-tenv (identifier? tenv-entry? tenv? . -> . void?)]
+                    [create-tenv ((listof identifier?)
+                                  (listof tenv-entry?)
+                                  . -> .
+                                  tenv?)])
+  (define (empty-tenv) (make-bound-identifier-mapping))
+  (define (extend-tenv key val tenv)
+    (if (get-tenv-entry key tenv)
+        (raise-read-error-with-stx
+         (format "~a already bound by top-level definition" (printable-key key))
+         key)
+        (bound-identifier-mapping-put! tenv key val)))
+  (define (create-tenv keys vals)
+    (let ((table (empty-tenv)))
+      (begin (for-each extend-tenv table keys vals)
+             table)))
+
+  ;(provide get-tenv-entry get-tenv-member-entry)
+  (define (get-tenv-entry key tenv)
+    (bound-identifier-mapping-get tenv key (lambda () #f)))
+  (define (get-tenv-member-entry type member tenv)
+    (bound-identifier-mapping-get (tenv-type-members (get-tenv-entry type tenv))
+                                  member
+                                  (lambda () #f)))
+  
+  (provide/contract [get-type-entry  (identifier? tenv? . -> . tenv-type?)]
+                    [get-class-entry (identifier? tenv? . -> . tenv-class?)]
+                    [get-mixin-entry (identifier? tenv? . -> . tenv-mixin?)]
+                    [get-func-entry  (identifier? tenv? . -> . tenv-func?)])
+  (define (get-type-entry name tenv)
+    (let ([entry (get-tenv-entry name tenv)])
+      (cond
+        [(not entry)
+         (raise-read-error-with-stx
+          (format "No type defined with name ~a" (printable-key name))
+          name)]
+        [(not (tenv-type? entry))
+         (raise-read-error-with-stx
+          (format "Definition of ~a is not a type" (printable-key name))
+          name)]
+        [else entry])))
+  (define (get-class-entry name tenv)
+    (let ([entry (get-tenv-entry name tenv)])
+      (cond
+        [(not entry)
+         (raise-read-error-with-stx
+          (format "No class defined with name ~a" (printable-key name))
+          name)]
+        [(not (tenv-class? entry))
+         (raise-read-error-with-stx
+          (format "Definition of ~a is not a class" (printable-key name))
+          name)]
+        [else entry])))
+  (define (get-mixin-entry name tenv)
+    (let ([entry (get-tenv-entry name tenv)])
+      (cond
+        [(not entry)
+         (raise-read-error-with-stx
+          (format "No mixin defined with name ~a" (printable-key name))
+          name)]
+        [(not (tenv-mixin? entry))
+         (raise-read-error-with-stx
+          (format "Definition of ~a is not a mixin" (printable-key name))
+          name)]
+        [else entry])))
+  (define (get-func-entry name tenv)
+    (let ([entry (get-tenv-entry name tenv)])
+      (cond
+        [(not entry)
+         (raise-read-error-with-stx
+          (format "No function defined with name ~a" (printable-key name))
+          name)]
+        [(not (tenv-func? entry))
+         (raise-read-error-with-stx
+          (format "Definition of ~a is not a function" (printable-key name))
+          name)]
+        [else entry])))
+  )
diff --git a/collects/honu/tool.ss b/collects/honu/tool.ss
new file mode 100644
index 0000000000..8b1d42b65c
--- /dev/null
+++ b/collects/honu/tool.ss
@@ -0,0 +1,189 @@
+(module tool mzscheme
+  (require (lib "tool.ss" "drscheme")
+           (lib "mred.ss" "mred")
+           (lib "framework.ss" "framework")
+           (lib "unitsig.ss")
+           (lib "etc.ss")
+           (lib "class.ss")
+           "parsers/parse.ss"
+           "ast.ss"
+           "tenv.ss"
+           "private/typechecker/honu-type-utils.ss"
+           "compile.ss"
+           "honu-compile-context.ss"
+	   (lib "string-constant.ss" "string-constants"))
+
+  (provide tool@)
+
+  (define tool@
+    (unit/sig drscheme:tool-exports^
+      (import drscheme:tool^)
+      
+      (define (phase1) (void))
+      (define (phase2) 
+        (drscheme:language-configuration:add-language
+         (make-object ((drscheme:language:get-default-mixin) (honu-lang-mixin 'single))))
+        (drscheme:language-configuration:add-language
+         (make-object ((drscheme:language:get-default-mixin) (honu-lang-mixin 'group)))))
+      
+      (define (honu-lang-mixin level)
+        (class* object% (drscheme:language:language<%>)
+          (define/public (config-panel parent)
+            (case-lambda
+              [() null]
+              [(x) (void)]))
+          (define/public (get-comment-character) (values "//" #\*))
+          (define/public (default-settings) null)
+          (define/public (default-settings? x) #t)
+          (define tenv (empty-tenv))
+          (define env (empty-env))
+          (define level-parser
+            (case level
+              [(single) parse-port]
+              [(group)  parse-group]))
+          (define/public (front-end/complete-program port settings teachpack-cache)
+            (set! tenv (empty-tenv))
+            (let ([name (object-name port)])
+              (lambda ()
+                (if (eof-object? (peek-char-or-special port))
+                    eof
+                    (let* ([parsed (level-parser port name)]
+                           [compiled-defns (compile/complete-program tenv parsed)])
+                      (set! env (get-initial-env tenv))
+                      (datum->syntax-object #f `(run-honu-full-program ,compiled-defns) #f))))))
+          (define/public (front-end/interaction port settings teachpack-cache)
+            (let ([name (object-name port)])
+              (lambda ()
+                (if (eof-object? (peek-char-or-special port))
+                    eof
+                    (let ([parsed (parse-interaction port name)])
+                      (let-values ([(compiled-expr new-env)
+                                    (compile/interaction tenv env parsed)])
+                        (begin (set! env new-env)
+                               (datum->syntax-object #f `(run-honu-interaction ,compiled-expr) #f))))))))
+          (define/public (get-style-delta) #f)
+          (define/public (get-language-position)
+	    (list (string-constant experimental-languages)
+		  "Honu"
+                  (case level
+                    [(single) "Single File"]
+                    [(group)  "Group File"])))
+          (define/public (order-manuals x) 
+            (values 
+             (list #"drscheme" #"tour" #"help")
+             #f))
+          (define/public (get-language-name)
+            (case level
+              [(single) "Honu (single)"]
+              [(group)  "Honu (group)"]))
+          (define/public (get-language-url) #f)
+          (define/public (get-language-numbers)
+            (case level
+              [(single) (list 1000 10 1)]
+              [(group)  (list 1000 10 2)]))
+          (define/public (get-teachpack-names) null)
+          (define/public (marshall-settings x) x)
+          (define/private (syntax-as-top s)
+            (if (syntax? s) (namespace-syntax-introduce s) s))
+          (define/public (on-execute settings run-in-user-thread)
+            (dynamic-require '(lib "base.ss" "honu") #f)
+            (let ([path ((current-module-name-resolver) '(lib "base.ss" "honu") #f #f)]
+                  [n (current-namespace)])
+              (run-in-user-thread
+               (lambda ()
+		 (error-display-handler 
+		  (drscheme:debug:make-debug-error-display-handler (error-display-handler)))
+		 (let ([old-current-eval (drscheme:debug:make-debug-eval-handler (current-eval))])
+                   (current-eval
+                    (with-handlers ([(lambda (x) #t) (lambda (x) (printf "~a~n" (exn-message x)))])
+                      (lambda (exp)
+                      (syntax-case exp (run-honu-full-program run-honu-interaction)
+                        [(run-honu-full-program defns)
+                         (let loop ([defns (syntax->list #'defns)])
+                           (if (null? defns)
+                               (void)
+                               (begin (old-current-eval (syntax-as-top (car defns)))
+                                      (loop (cdr defns)))))]
+                        [(run-honu-interaction ex)
+                         (old-current-eval (syntax-as-top #'ex))]
+                        [(_) (old-current-eval exp)])))))
+                 (with-handlers ([(lambda (x) #t) (lambda (x) (printf "~a~n" (exn-message x)))])
+                   (namespace-attach-module n path)
+                   (namespace-require path))))))
+          (define/public (render-value value settings port) (write value port))
+          (define/public (render-value/format value settings port width) (write value port))
+          (define/public (unmarshall-settings x) x)
+	  (define/public (create-executable settings parent src-file teachpacks)
+	    (message-box "Unsupported"
+			 "Sorry - executables are not supported for Honu at this time"
+			 parent))
+	  (define/public (get-one-line-summary)
+            (case level
+              [(single) "Honu (also not Scheme at all!)"]
+              [(group)  "List of Honu files to run together"]))
+          
+          (super-instantiate ())))
+      
+      ;; The following copies the Java mode to make one for Honu, but it's better right now than using
+      ;; the Scheme mode.  Ugh.
+      
+      ;; matches-language : (union #f (listof string)) -> boolean
+      (define (matches-language l)
+        (and l (pair? l) (pair? (cdr l)) (equal? (cadr l) "Honu")))
+
+      ;Create the Honu editing mode
+      (define mode-surrogate
+        (new color:text-mode%
+             (matches (list (list '|{| '|}|)
+                            (list '|(| '|)|)
+                            (list '|[| '|]|)))))
+            
+      ;repl-submit: text int -> bool
+      ;Determines if the reple should submit or not
+      (define (repl-submit text prompt-position)
+        (let ((is-if? #f)
+              (is-string? #f)
+              (open-parens 0)
+              (open-braces 0)
+              (open-curlies 0))
+          (let loop ((index 1) (char (send text get-character prompt-position)))
+            (unless (eq? char #\nul)
+              (cond 
+                ;beginning of if statement
+                ((and (= index 1) 
+                      (eq? char #\i) 
+                      (eq? (send text get-character (add1 prompt-position)) #\f)
+                      (eq? (send text get-character (+ 2 prompt-position)) #\space))
+                 (set! is-if? #t)
+                 (loop 3 (send text get-character (+ 3 prompt-position))))
+                ((eq? char #\()
+                 (unless is-string? (set! open-parens (add1 open-parens)))
+                 (loop (add1 index) (send text get-character (+ index prompt-position))))
+                ((eq? char #\))
+                 (unless is-string? (set! open-parens (sub1 open-parens)))
+                 (loop (add1 index) (send text get-character (+ index prompt-position))))
+                ((eq? char #\{)
+                 (unless is-string? (set! open-curlies (add1 open-curlies)))
+                 (loop (add1 index) (send text get-character (+ index prompt-position))))
+                ((eq? char #\})
+                 (unless is-string? (set! open-curlies (sub1 open-curlies)))
+                 (loop (add1 index) (send text get-character (+ index prompt-position))))
+                ((eq? char #\[)
+                 (unless is-string? (set! open-braces (add1 open-braces)))
+                 (loop (add1 index) (send text get-character (+ index prompt-position))))
+                ((eq? char #\])
+                 (unless is-string? (set! open-braces (sub1 open-braces)))
+                 (loop (add1 index) (send text get-character (+ index prompt-position))))
+                ;beginning of string
+                ((eq? char #\")
+                 (set! is-string? (not is-string?))
+                 (loop (add1 index) (send text get-character (+ index prompt-position))))
+                (else
+                 (loop (add1 index) (send text get-character (+ index prompt-position)))))))
+          (not (or (not (= open-parens 0))
+                   (not (= open-braces 0))
+                   (not (= open-curlies 0))
+                   is-if?))))
+      
+      (drscheme:modes:add-mode "Honu mode" mode-surrogate repl-submit matches-language)
+      )))
diff --git a/collects/honu/utils.ss b/collects/honu/utils.ss
new file mode 100644
index 0000000000..fc90104040
--- /dev/null
+++ b/collects/honu/utils.ss
@@ -0,0 +1,47 @@
+(module utils mzscheme
+  (require "ast.ss")
+  (require (lib "list.ss" "srfi" "1"))
+
+  (provide fold-with-rest)
+  (define (fold-with-rest f init l)
+    (if (null? l)
+        init
+        (fold-with-rest f (f (car l) (cdr l) init) (cdr l))))
+  
+  (provide unique?)
+  (define (unique? cs)
+    (fold-with-rest (lambda (c cs acc)
+                      (and acc
+                           (not (member c cs))))
+                    #t cs))
+  
+  (define (get-names ds p f)
+    (filter-map (lambda (defn)
+                  (and (p defn)
+                       (f defn)))
+                ds))    
+  
+  (provide map-and-fold)
+  (define (map-and-fold f i l)
+    (let loop ((l l)
+               (mapped '())
+               (folded i))
+      (if (null? l)
+          (values (reverse mapped) folded)
+          (let-values ([(res folded) (f (car l) folded)])
+            (loop (cdr l)
+                  (cons res mapped)
+                  folded)))))
+  
+  (provide map-two-values)
+  (define (map-two-values f . lists)
+    (let loop ((lists lists)
+               (map1  '())
+               (map2  '()))
+      (if (any null? lists)
+          (values (reverse map1) (reverse map2))
+          (let-values ([(m1 m2) (apply f (map car lists))])
+            (loop (map cdr lists)
+                  (cons m1 map1)
+                  (cons m2 map2))))))
+    )
diff --git a/collects/htdch/draw/Black.java b/collects/htdch/draw/Black.java
new file mode 100644
index 0000000000..1cf5043d13
--- /dev/null
+++ b/collects/htdch/draw/Black.java
@@ -0,0 +1,3 @@
+package draw;
+
+public class Black extends Color { }
diff --git a/collects/htdch/draw/Blue.java b/collects/htdch/draw/Blue.java
new file mode 100644
index 0000000000..5887478e76
--- /dev/null
+++ b/collects/htdch/draw/Blue.java
@@ -0,0 +1,3 @@
+package draw;
+
+public class Blue extends Color { }
diff --git a/collects/htdch/draw/Color.java b/collects/htdch/draw/Color.java
new file mode 100644
index 0000000000..d3116457e4
--- /dev/null
+++ b/collects/htdch/draw/Color.java
@@ -0,0 +1,3 @@
+package draw;
+
+public abstract class Color { }
\ No newline at end of file
diff --git a/collects/htdch/draw/Green.java b/collects/htdch/draw/Green.java
new file mode 100644
index 0000000000..b58f1b8e18
--- /dev/null
+++ b/collects/htdch/draw/Green.java
@@ -0,0 +1,3 @@
+package draw;
+
+public class Green extends Color { }
diff --git a/collects/htdch/draw/Posn.java b/collects/htdch/draw/Posn.java
new file mode 100644
index 0000000000..1328dffa94
--- /dev/null
+++ b/collects/htdch/draw/Posn.java
@@ -0,0 +1,10 @@
+package draw;
+
+public class Posn {
+  public int x, y;
+
+  public Posn( int x, int y ) {
+    this.x = x;
+    this.y = y;
+  }
+}
\ No newline at end of file
diff --git a/collects/htdch/draw/Red.java b/collects/htdch/draw/Red.java
new file mode 100644
index 0000000000..db44213b34
--- /dev/null
+++ b/collects/htdch/draw/Red.java
@@ -0,0 +1,3 @@
+package draw;
+
+public class Red extends Color { }
\ No newline at end of file
diff --git a/collects/htdch/draw/White.java b/collects/htdch/draw/White.java
new file mode 100644
index 0000000000..a583bec9d7
--- /dev/null
+++ b/collects/htdch/draw/White.java
@@ -0,0 +1,3 @@
+package draw;
+
+public class White extends Color { }
diff --git a/collects/htdch/draw/World-native-methods.ss b/collects/htdch/draw/World-native-methods.ss
new file mode 100644
index 0000000000..3dbf671719
--- /dev/null
+++ b/collects/htdch/draw/World-native-methods.ss
@@ -0,0 +1,121 @@
+#cs
+(module World-native-methods mzscheme
+  (require (lib "draw.ss" "htdp")
+           (lib "posn.ss" "lang")
+           (lib "class.ss")
+	   (lib "String.ss" "profj" "libs" "java" "lang"))
+  ;(require "Posn.ss")
+  
+  (define-syntax (define/provide stx)
+    (syntax-case stx ()
+      [(_ id val)
+       (identifier? #'id)
+       #'(begin
+	   (define id val)
+	   (provide id))]
+      [(_ (id . formals) . rest)
+       #'(begin
+	   (define (id . formals) . rest)
+	   (provide id))]))
+  
+  (define Posn-x-get (dynamic-require '(lib "Posn.ss" "htdch" "draw") 'Posn-x-get))
+  (define Posn-y-get (dynamic-require '(lib "Posn.ss" "htdch" "draw") 'Posn-y-get))
+  
+  (define (build-posn posnO)
+    (make-posn (Posn-x-get posnO) (Posn-y-get posnO)))
+  (define (color->symbol colorO)
+    (string->symbol (to-lower-case (send colorO my-name))))
+  
+  (define (to-lower-case s)
+    (letrec ((lower 
+              (lambda (s)
+                (cond
+                  ((null? s) s)
+                  (else (cons (char-downcase (car s))
+                              (lower (cdr s))))))))
+      (list->string (lower (string->list s)))))
+  
+  (define/provide (start-int-int-native this accs gets privates x y)
+     (start x y))
+  
+  (define/provide (stop-native this accs gets privates) (stop))
+  
+  (define/provide (drawCircle-draw.Posn-int-draw.Color-native this accs gets privates posn r c)
+     (draw-circle (build-posn posn) r (color->symbol c)))
+  
+  (define/provide (drawDisk-draw.Posn-int-draw.Color-native this accs gets privates posn r c)
+     (draw-solid-disk (build-posn posn) r (color->symbol c)))
+  
+  (define/provide (drawRect-draw.Posn-int-int-draw.Color-native this accs gets privates posn w h c)
+     (draw-solid-rect (build-posn posn) w h (color->symbol c)))
+
+  (define/provide (drawLine-draw.Posn-draw.Posn-draw.Color-native this accs gets privates p0 p1 c)
+     (draw-solid-line (build-posn p0) (build-posn p1) (color->symbol c)))
+
+  (define/provide (drawString-draw.Posn-java.lang.String-native this accs gets privates p s)
+     (draw-solid-string (build-posn p) (send s get-mzscheme-string)))
+
+  (define/provide (clearCircle-draw.Posn-int-draw.Color-native this accs gets privates p r c)
+     (clear-circle (build-posn p) r (color->symbol c)))
+
+  (define/provide (clearDisk-draw.Posn-int-draw.Color-native this accs gets privates p r c)
+     (clear-solid-disk (build-posn p) r (color->symbol c)))
+
+  (define/provide (clearRect-draw.Posn-int-int-draw.Color-native this accs gets privates p w h c)
+     (clear-solid-rect (build-posn p) w h (color->symbol c)))
+
+  (define/provide (clearLine-draw.Posn-draw.Posn-draw.Color-native this accs gets privates p0 p1 c)
+     (clear-solid-line (build-posn p0) (build-posn p1) (color->symbol c)))
+
+  (define/provide (sleepForAWhile-int-native this accs gets privates s)
+    (sleep-for-a-while s))
+  
+  (define/provide (bigBang-double-native this accs gets privates i)
+    (big-bang i this)
+    (on-tick-event
+      (lambda (world)
+	(set! last-world world)
+	(let ([next-world (send world onTick)])
+	  (send last-world erase)
+	  (send next-world draw)
+	  next-world)))
+    (on-key-event
+      (lambda (ke world)
+	(set! last-world world)
+	(let ([next-world (send world onKeyEvent-java.lang.String
+			   (make-java-string (keyevent->string ke)))])
+	  (send last-world erase)
+	  (send next-world draw)
+	  next-world)))
+    #t)
+
+  ;; (union Char Symbol) -> String
+  (define (keyevent->string ke)
+    (if (char? ke) (string ke) (symbol->string ke)))
+  
+  (define/provide (draw-native this accs gets privates)
+    #t)
+
+  (define/provide (erase-native this accs gets privates)
+    #t)
+
+  (define/provide (onTick-native this accs gets privates)
+     this)
+
+  (define/provide (onKeyEvent-java.lang.String-native this accs gets privates ke)
+     this)
+
+  (define last-world #f)
+  
+  (define/provide (endOfTime-native this accs gets privates)
+    (set! last-world (end-of-time))
+    #t)
+
+  (define/provide (endOfWorld-native this accs gets privates)
+    (set! last-world (end-of-time))
+    last-world)
+
+  (define/provide (lastWorld-native this accs gets privates)
+    (if last-world last-world this))
+)
+
diff --git a/collects/htdch/draw/World.java b/collects/htdch/draw/World.java
new file mode 100644
index 0000000000..fe96488c43
--- /dev/null
+++ b/collects/htdch/draw/World.java
@@ -0,0 +1,44 @@
+package draw;
+        
+public class World {
+
+     public native boolean start(int width, int height);
+
+     public native boolean stop();
+
+     public native boolean drawCircle(Posn p, int r, Color c);
+
+     public native boolean drawDisk(Posn p, int r, Color c);
+
+     public native boolean drawRect(Posn p, int width, int height, Color c);
+
+     public native boolean drawLine(Posn p0, Posn p1, Color c);
+
+     public native boolean drawString(Posn p, String s);
+
+     public native boolean clearCircle(Posn p, int r, Color c);
+
+     public native boolean clearDisk(Posn p, int r, Color c);
+
+     public native boolean clearRect(Posn p, int width, int height, Color c);
+
+     public native boolean clearLine(Posn p0, Posn p1, Color c);
+
+     public native boolean sleepForAWhile(int s);
+
+     public native boolean bigBang(double s); 
+
+     public native World onTick();
+
+     public native World onKeyEvent(String ke); 
+
+     public native boolean draw();
+
+     public native boolean erase();
+
+     public native boolean endOfTime();
+
+     public native World endOfWorld();
+
+     public native World lastWorld();
+}    
diff --git a/collects/htdch/draw/Yellow.java b/collects/htdch/draw/Yellow.java
new file mode 100644
index 0000000000..b14bcd80db
--- /dev/null
+++ b/collects/htdch/draw/Yellow.java
@@ -0,0 +1,3 @@
+package draw;
+
+public class Yellow extends Color { }
diff --git a/collects/htdch/draw/doc.txt b/collects/htdch/draw/doc.txt
new file mode 100644
index 0000000000..6d4893c6d0
--- /dev/null
+++ b/collects/htdch/draw/doc.txt
@@ -0,0 +1,86 @@
+This `draw' package provides libraries for modeling in a visual world. It
+consists of two sets of classes: 
+
+ - World and Posn 
+
+ - Color with five subclasses: 
+   + Blue 
+   + Green 
+   + Red 
+   + White 
+   + Yellow 
+
+		     +-------+
+		     | Color |
+		     +-------+
+			/ \
+			---
+			 |
+    ------------------------------------------
+    |          |         |         |         |     
++-------+  +-------+ +-------+ +-------+ +-------+  
+| Blue  |  | Green | | Red   | | White | | Yellow| 
++-------+  +-------+ +-------+ +-------+ +-------+ 
+
+
+The _World_ class has the following class interface: 
+
+     // create the visual aspect 
+     boolean start(int width, int height)
+
+     // tear down the canvas and shut down the program
+     boolean stop()
+
+     // draw a circle at p, paint circle c
+     boolean drawCircle(Posn p, int r, Color c)
+
+     // draw a solid disk at p, fill with color c
+     boolean drawDisk(Posn p, int r, Color c)
+
+     // draw a width x height rectangle at p, fill with color c
+     boolean drawRect(Posn p, int width, int height, Color c)
+
+     // draw a line from p0 to p1, use color c
+     boolean drawLine(Posn p0, Posn p1, Color c)
+
+     // draw a string at position p
+     boolean drawString(Posn p, String s)
+
+     // clear a circle at p, paint circle c
+     boolean clearCircle(Posn p, int r, Color c)
+
+     // clear a solid disk at p, fill with color c
+     boolean clearDisk(Posn p, int r, Color c)
+
+     // clear a width x height rectangle at p, fill with color c
+     boolean clearRect(Posn p, int width, int height, Color c)
+
+     // clear a line from p0 to p1, use color c
+     boolean clearLine(Posn p0, Posn p1, Color c)
+
+     // wait for s seconds (roughly)
+     boolean sleepForAWhile(int s)
+
+     // start the clock and make this world the current one
+     boolean bigBang(double s) 
+
+     // process a tick of the clock in this world
+     World onTick() 
+
+     // process a keystroke event in this world
+     World onKeyEvent(String ke) 
+
+     // stop this world's clock
+     World endOfWorld() 
+
+     // draw this world
+     boolean draw() 
+
+     // erase this world
+     boolean erase() 
+
+     // view the last World that onTick or onKeyEvent or bigBang created
+     World lastWorld()
+
+_Posn_ is the usual class: it combines two integers, x and y, and makes the
+ available via the selectors Posn.x and Posn.y. 
diff --git a/collects/htdch/draw/info.ss b/collects/htdch/draw/info.ss
new file mode 100644
index 0000000000..f80048e9c1
--- /dev/null
+++ b/collects/htdch/draw/info.ss
@@ -0,0 +1,4 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Draw Teachpack")
+  (define install-collection "installer.ss")
+  #;(define pre-install-collection "pre-installer.ss"))
\ No newline at end of file
diff --git a/collects/htdch/draw/installer.ss b/collects/htdch/draw/installer.ss
new file mode 100644
index 0000000000..ad420074aa
--- /dev/null
+++ b/collects/htdch/draw/installer.ss
@@ -0,0 +1,23 @@
+(module installer mzscheme
+  (require (lib "compile.ss" "profj"))
+  (provide installer)
+  
+  (define (installer plthome)
+    (let ((draw-path (build-path (collection-path "htdch" "draw"))))
+      (let ((javac
+             (lambda (file)
+               (parameterize ([current-load-relative-directory draw-path])
+                 (compile-java 'file 'file 'full
+                               (build-path draw-path file)
+                               #f #f)))))
+        (javac "Posn.java")
+        (javac "Color.java")
+;        (javac "ICanvas.java")
+        (javac "World.java")
+        (javac "Red.java")
+        (javac "White.java")
+        (javac "Blue.java")
+        (javac "Black.java")
+        (javac "Green.java")
+        (javac "Yellow.java")))))
+           
diff --git a/collects/htdch/draw/pre-installer.ss b/collects/htdch/draw/pre-installer.ss
new file mode 100644
index 0000000000..edda477da3
--- /dev/null
+++ b/collects/htdch/draw/pre-installer.ss
@@ -0,0 +1,15 @@
+(module pre-installer mzscheme
+  (require (lib "compile.ss" "profj"))
+  (provide pre-installer)
+  
+  (define (pre-installer plthome)
+    (let ((draw-path (build-path (collection-path "htdch" "draw"))))
+      (let ((javac
+             (lambda (file)
+               (parameterize ([current-load-relative-directory draw-path])
+                 (compile-java 'file 'file 'full
+                               (build-path draw-path file)
+                               #f #f)))))
+        (javac "Posn.java")
+        ))))
+           
\ No newline at end of file
diff --git a/collects/htdch/info.ss b/collects/htdch/info.ss
new file mode 100644
index 0000000000..f9960ea5bd
--- /dev/null
+++ b/collects/htdch/info.ss
@@ -0,0 +1,5 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "htdch")
+  (define compile-subcollections (list (list "htdch" "draw")
+                                       ))
+  )
\ No newline at end of file
diff --git a/collects/htdp/HtDPv0/ping-play-unit.ss b/collects/htdp/HtDPv0/ping-play-unit.ss
new file mode 100644
index 0000000000..81167a550d
--- /dev/null
+++ b/collects/htdp/HtDPv0/ping-play-unit.ss
@@ -0,0 +1,108 @@
+#cs(module ping-play-unit mzscheme
+     (require "pingp-sig.ss"
+	      (lib "posn.ss" "lang")
+              (lib "unitsig.ss"))
+     (provide ping-play-U)
+     
+     (define ping-play-U
+       (unit/sig ppu-S
+         (import pingpS)
+         
+         ;; ---------------------------------------------------------------------------
+         ;; To test: set library to pingp-lib.ss and uncomment the last line.
+         ;; The file tests the function play from pingp-lib.ss. 
+         ;; The file is used to build pinpgp-play-lib.ss.
+         
+         ;; Speed and its relationship to positions
+         ;; ---------------------------------------
+         (define-struct speed (x y))
+         
+         ;; posn+ : posn vec -> vec 
+         (define (posn+ p v)
+           (make-posn (+ (posn-x p) (speed-x v)) (+ (posn-y p) (speed-y v))))
+         
+         ;; posn*s : number vec -> posn
+         (define (posn*s f p)
+           (make-speed (* f (speed-x p)) (* f (speed-y p))))
+         
+         ;; vec* : vec vec -> vec
+         (define (vec* v1 v2) 
+           (make-speed (* (speed-x v1) (speed-x v2)) (* (speed-y v1) (speed-y v2))))
+         
+         ;; The ball representation and some basic primitives:
+         ;; ---------------------------------------------------
+         (define-struct ball (posn speed))
+         
+         ;; make-direction : (speed -> num) X Y -> (ball -> (union X Y))
+         (define (make-direction access dir1 dir2)
+           (lambda (ball)
+             (cond
+               ((< (access (ball-speed ball)) 0) dir1)
+               ((> (access (ball-speed ball)) 0) dir2)
+               (else (error 'make-direction "can't happen")))))
+         
+         ;; ns-direction : ball -> {'NORTH, 'SOUTH}
+         (define ns-direction (make-direction speed-y 'NORTH 'SOUTH))
+         
+         ;; ew-direction : ball -> {'EAST, 'WEST}
+         (define ew-direction (make-direction speed-x 'WEST 'EAST))
+         
+         ;; make-distance : (posn -> num) (ball -> sym) sym num num -> (ball -> num)
+         (define (make-distance direction access dir bound1 bound2)
+           (lambda (ball)
+             (if (eq? (direction ball) dir) 
+                 (- (access (ball-posn ball)) bound1)
+                 (- bound2 (access (ball-posn ball))))))
+         
+         ;; make-time : (ball -> num) (speed -> num) -> (ball -> number)
+         (define (make-time distance access)
+           (lambda (ball) 
+             (/ (distance ball) (abs (access (ball-speed ball))))))
+         
+         ;; ns-time-to-wall : ball -> number (time before ns wall is hit)
+         (define ns-time-to-wall 
+           (make-time (make-distance ns-direction posn-y 'NORTH NORTH SOUTH) speed-y))
+         
+         ;; ew-time-to-wall : ball -> number (time before ew wall is hit)
+         (define ew-time-to-wall 
+           (make-time (make-distance ew-direction posn-x 'WEST WEST EAST) speed-x))
+         
+         ;; Moving a Ball
+         ;; -------------
+         ;; move-in-box : ball number -> ball
+         (define (move-in-box ball t)
+           (case (bounces-from ball t)
+             ((NORTH SOUTH) (bouncing-move ns-bounce (ns-time-to-wall ball) t ball))
+             ((EAST WEST) (bouncing-move ew-bounce (ew-time-to-wall ball) t ball))
+             (else (move-ball ball t))))
+         
+         ;; bouncing-move : (ball -> ball) num num ball -> ball
+         (define (bouncing-move bounce t-bounce t ball)
+           (move-in-box (bounce (move-ball ball t-bounce)) (- t t-bounce)))
+         
+         ;; bounces-from : ball number -> {'NORTH, 'SOUTH, 'EAST, 'WEST, 'none}
+         (define (bounces-from ball t)
+           (cond
+             ((<= (ns-time-to-wall ball) (min t (ew-time-to-wall ball))) (ns-direction ball))
+             ((<= (ew-time-to-wall ball) (min t (ns-time-to-wall ball)))
+              (cond 
+                ((landed-on-paddle? (ball-posn (move-ball ball (ew-time-to-wall ball))))
+                 (ew-direction ball))
+                (else 'none)))
+             (else 'none)))
+         
+         ;; move : ball number -> ball
+         (define (move-ball ball t)
+           (make-ball (posn+ (ball-posn ball) (posn*s t (ball-speed ball))) (ball-speed ball)))
+         
+         ;; make-bounce : speed -> (ball -> ball)
+         (define (make-bounce bounceV)
+           (lambda (ball)
+             (make-ball (ball-posn ball) (vec* (ball-speed ball) bounceV))))  
+         
+         ;; ns-bounce : ball -> ball
+         (define ns-bounce (make-bounce (make-speed 1 -1)))
+         
+         ;; ew-bounce-west : ball -> ball
+         (define ew-bounce (make-bounce (make-speed -1 1)))
+         )))
diff --git a/collects/htdp/HtDPv0/pingp-play.ss b/collects/htdp/HtDPv0/pingp-play.ss
new file mode 100644
index 0000000000..530debc0d3
--- /dev/null
+++ b/collects/htdp/HtDPv0/pingp-play.ss
@@ -0,0 +1,23 @@
+#cs(module pingp-play mzscheme
+     
+     (require "pingp-sig.ss"
+              "pingp.ss"
+              (lib "unitsig.ss")
+              "ping-play-unit.ss")
+     
+     (provide pingp-play@)  
+     (define pingp-play@
+       (compound-unit/sig 
+         (import)
+         (link
+          [PINGP : pingpS (pingpU)]
+          [BALL  : ballS  (ping-play-U PINGP)]
+          (GO : goS ((unit/sig goS (import ballS pingpS)
+                       (define (go s)
+                         (printf "Have fun playing, ~a~n" s)
+                         (play make-ball make-speed ball-posn move-in-box)))
+                     BALL
+                     (PINGP : pingpS))))
+         (export (var (PINGP change-speed))
+                 (var (PINGP change-wind))
+                 (open GO)))))
diff --git a/collects/htdp/HtDPv0/pingp-sig.ss b/collects/htdp/HtDPv0/pingp-sig.ss
new file mode 100644
index 0000000000..42793c4090
--- /dev/null
+++ b/collects/htdp/HtDPv0/pingp-sig.ss
@@ -0,0 +1,69 @@
+#cs(module pingp-sig mzscheme
+     (require "draw-sig.ss"
+              (lib "unitsig.ss"))
+     (provide pingpS
+              ping-protS-core
+              ping-protS-extr
+              ballS
+              ping-protS
+              ppu-S
+              protectS
+              goS
+              pingp-play^
+              protect-play^)
+     
+;; to be provided to student
+(define-signature pingpS
+  ( play
+     ; ((posn posn -> ball) (ball -> posn) (ball -> posn) (ball -> ball) -> void)
+     ;  make-ball           ball-posn      ball-speed     move/move-in-box
+    landed-on-paddle?
+    protect
+     ; ((balls: (listof ball)
+     ;  (move-balls : (listof ball) -> (listof posn))
+     ;  (balls-posns :(listof ball) -> (listof ball))
+     ;  (balls-destroyed : (listof ball) -> (listof ball))) -> void)
+    trace
+    trace-ball
+    ;change-width
+    ;change-height
+    change-speed
+    change-wind
+    NORTH SOUTH EAST WEST FAR-WEST 
+    PADDLE-X
+    PADDLE-Y
+    ))
+
+;; needed from ping-play-unit for playing ping-pong
+(define-signature ping-protS-core
+  (make-ball make-speed ball-posn))
+(define-signature ping-protS-extr
+  (ns-bounce ns-time-to-wall ew-time-to-wall move-ball))
+(define-signature ballS
+  ((open ping-protS-core) move-in-box))
+
+;; needed from ping-play-unit for playing protect-the-wall
+(define-signature ping-protS
+  ((open ping-protS-core) (open ping-protS-extr)))
+
+;; provided by ping-play-unit
+(define-signature ppu-S
+  ((open ping-protS-core) (open ping-protS-extr) move-in-box))
+
+;; provided by protect-play-unit
+(define-signature protectS
+  (mk-balls move-balls remove-balls-hit-paddle remove-outside-balls balls-posn))
+
+;; provided by the glue units
+(define-signature goS
+  (go))
+     
+     (define-signature pingp-play^
+       ((open goS)
+        change-speed
+        change-wind))
+     (define-signature protect-play^
+       ((open goS)
+        change-speed
+        change-wind))
+)
\ No newline at end of file
diff --git a/collects/htdp/HtDPv0/pingp.ss b/collects/htdp/HtDPv0/pingp.ss
new file mode 100644
index 0000000000..1329429b0b
--- /dev/null
+++ b/collects/htdp/HtDPv0/pingp.ss
@@ -0,0 +1,284 @@
+#cs(module pingp mzscheme
+     (require  "error.ss"
+               "pingp-sig.ss"
+               "big-draw.ss"
+               (lib "unitsig.ss")
+	       (lib "posn.ss" "lang"))
+
+     (provide pingpU)
+
+(define pingpU
+  (unit/sig pingpS
+    (import)
+
+    ;; Exported Functions
+    ;; ------------------
+
+    ;; trace : posn S (posn S num -> posn) num -> #t
+    (define (trace pos speed f e)
+      ; --- error checking: redo
+      (check-arg  'trace (posn? pos) 'posn '1st pos)
+      ; the second arg is polymorphic
+      (check-proc 'trace f 3 '3rd "3 arguments")
+      (check-arg  'trace (and (number? e) (> e 0)) "positive number" '4th e)
+      ; --- 
+      (TT (make-bb pos speed)
+	  bb-p
+	  (lambda (b t) (let ((s (bb-s b))) (make-bb (f (bb-p b) s t) s)))
+	  e))
+
+    (define-struct bb (p s))
+
+    ;; trace-ball : X (X -> posn) (X num -> X) number -> #t
+    (define (trace-ball ball ball-posn f e)
+      ; --- error checking
+      ; the first arg is polymorphic
+      (check-proc 'trace-ball ball-posn 1 '2nd "1 argument")
+      (check-proc 'trace-ball f         2 '3rd "2 arguments")
+      (check-arg  'trace-ball (and (number? e) (> e 0)) "positive number" '4th e)
+      ; ---
+      (TT ball ball-posn f e))
+
+    ;; play : (posn X -> B) (num num -> S) (B -> posn) (B num -> B) -> #t
+    (define (play make-ball make-speed ball-posn move)
+      (check-proc 'play make-ball  2 '1st "2 arguments")
+      (check-proc 'play make-speed 2 '2nd "2 arguments")
+      (check-proc 'play ball-posn  1 '3rd "1 argument")
+      (check-proc 'play move       2 '4th "2 arguments")
+      (set-pad)
+      (unset-trace)
+      (play2 make-ball make-speed ball-posn move))
+
+    ;; landed-on-paddle? : posn -> bool
+    (define (%landed-on-paddle? x)
+      (error 'landed-on-paddle? "can't happen"))
+    (define (landed-on-paddle? aposn)
+      (%landed-on-paddle? aposn))
+
+    ;; change-speed : int[> 0] -> void
+    (define (change-speed s)
+      (check-arg 'change-speed (and (integer? s) (> s 0)) "positive integer" '1st s)
+      (set! SLEEP (/ 10 s)))
+
+    ;; change-wind : int[> 0] -> void
+    (define (change-wind s)
+      (check-arg 'change-wind (and (integer? s) (> s 0)) "positive integer" '1st s)
+      (set! SWITCH s))
+
+;    ;; change-width : int[> 200] -> void
+;    (define (change-width s)
+;      (check-arg 'change-width (and (integer? s) (> s 200)) "integer [> 200]" '1st s)
+;      (set! EAST s))
+;
+;    ;; change-height : int[> 200] -> void
+;    (define (change-height s)
+;      (check-arg 'change-height (and (integer? s) (> s 200)) "integer [> 200]" '1st s)
+;      (set! SOUTH s))
+
+    (define NORTH 0)
+    (define SOUTH 400)
+    (define WEST  0)
+    (define EAST  400)
+    (define FAR-WEST (* -1 EAST))
+
+    ;; protect : (listof ball)
+    ;;           ((listof ball) -> (listof ball))
+    ;;           ((listof ball) -> (listof ball))
+    ;;           ((listof ball) -> (listof ball))
+    ;;           ((listof ball) -> (listof posn))
+    ;;           -> void
+    (define (protect objs move-objs remove-objs-hit-paddle remove-outside-objs objs-posn)
+      ; --- error checking
+      (check-arg 'protect (list? objs) 'list        '1st objs)
+      (check-proc 'protect move-objs              1 '2nd "1 argument")
+      (check-proc 'protect remove-objs-hit-paddle 1 '3rd "1 argument")
+      (check-proc 'protect remove-outside-objs    1 '4th "1 argument")
+      (check-proc 'protect objs-posn              1 '5th "1 argument")
+      ; --- 
+      (ready-to-go?)
+      (let* ((objs#  (length objs))
+	     (PAD_Y0 (- (quotient SOUTH 2) (quotient PAD_LENGTH 2)))
+	     (west   (box (make-posn 0 0)));; fake: to reuse move-paddle and make-landed
+	     (east   (box (make-posn (- EAST (+ PAD_WIDTH PAD_DIST_WALL)) PAD_Y0))))
+	(set! %landed-on-paddle? (make-landed-on-paddle east west))
+	(draw-paddle (unbox east))
+	;; --- the loop
+	(let PLAY ((ball0 objs) (p0 (objs-posn objs)) (hits 0))
+	  (if (null? ball0)
+	      (cond
+		[(= hits 0) (printf "You didn't catch any balls.")]
+		[(= hits 1) (printf "You caught one ball. All others hit the wall.")]
+		[else 
+		 (printf "You caught ~s balls, ~s hit the wall." hits (- objs# hits))])
+	      (begin
+		(for-each draw-ball p0)
+		(sleep SLEEP)
+		(for-each clear-ball p0)
+		(let* ((ball1 (move-objs ball0))
+		       (ball2 (remove-objs-hit-paddle ball1))
+		       (ball3 (remove-outside-objs ball2))
+		       (p1    (objs-posn ball3)))
+		  (move-paddle east west (ready-mouse-click (get-@VP)))
+		  (PLAY ball3 p1 (+ hits (- (length ball1) (length ball2))))))))
+	;; --- clean up
+	(stop)))
+
+    ;; Hidden Definitions
+    ;; ==================
+
+    ;; Hidden Functions: Tracing and Playing
+    ;; -------------------------------------
+
+    ;; TT : X (X -> posn) (X -> X) num[n] -> #t
+    ;; effect: trace X's movement for n steps on canvas
+    (define (TT ball ball-posn f e)
+      (start2 EAST SOUTH)
+      (let dl ((ball0 ball) (s 1))
+	(if (> s e) #t
+	  (let ((ball1 (f ball0 1)))
+	    (and
+	      (draw-solid-disk (ball-posn ball1) 3 'red)
+	      (draw-solid-line (ball-posn ball0) (ball-posn ball1))
+	      (dl ball1 (+ s 1)))))))
+
+;    (define (check s make-ball ball-posn move)
+;      (check-proc s make-ball  2 '1st "2 arguments")
+;      (check-proc s ball-posn  1 '2nd "1 argument")
+;      (check-proc s move       2 '3rd "2 arguments"))
+
+    (define (play2 make-ball make-speed ball-posn move)
+      (ready-to-go?)
+      (let* ((rn-10-10 (lambda ()
+			 (let ((n (random 20)))
+			   (if (< n 10) (- n 10) (- n  9)))))
+	     (posn0 (make-posn (quotient EAST 2) (quotient SOUTH 2)))
+	     (PAD_Y0 (- (quotient SOUTH 2) (quotient PAD_LENGTH 2)))
+	     (west (box (make-posn PAD_DIST_WALL                        PAD_Y0)))
+	     (east (box (make-posn (- EAST (+ PAD_WIDTH PAD_DIST_WALL)) PAD_Y0)))
+	     (start-time (current-seconds)))
+	(set! %landed-on-paddle? (make-landed-on-paddle east west))
+	(draw-paddle (unbox west))
+	(draw-paddle (unbox east))
+	;; --- the loop
+	(let play ((ball0 (make-ball posn0 (make-speed (rn-10-10) (rn-10-10)))) (p0 posn0) (i 1))
+	  (unless (or (< (posn-x p0) 0) (< EAST (posn-x p0)))
+	    (draw-ball p0) (sleep SLEEP) (clear-ball p0)
+	    (let* ((ball1 (move ball0 1)) (p1 (ball-posn ball1)))
+	      (draw-solid-line p0 p1 TRACE-COLOR)
+	      (move-paddle east west (ready-mouse-click (get-@VP)))
+	      (if (zero? (modulo i SWITCH))
+		  (play (make-ball p1 (make-speed (rn-10-10) (rn-10-10))) p1 1)
+		  (play ball1 p1 (add1 i))))))
+	;; --- clean up
+	(printf "You kept the ball in play for ~s seconds.\n" (- (current-seconds) start-time))
+	(stop)))
+
+    ;; move-paddle : (box posn) (box posn) (union #f mouse-click) -> void
+    ;; effect: modify the appropriate box, if mouse was clicked
+    (define (move-paddle east west mc)
+      (let ((new-posn (and mc (center-paddle (mouse-click-posn mc)))))
+	(cond
+	  ((not new-posn) (void))
+	  ((in-west-zone? new-posn) (move-one-paddle west new-posn))
+	  ((in-east-zone? new-posn) (move-one-paddle east new-posn)))))
+
+    ;; move-one-paddle : (box posn) -> void
+    ;; effect: modify the boxe, re-draw at appropriate place
+    (define (move-one-paddle a-paddle a-posn)
+      (clear-paddle (unbox a-paddle))
+      (set-box! a-paddle (new-paddle (unbox a-paddle) (posn-y a-posn)))
+      (draw-paddle (unbox a-paddle)))
+
+    ;; ready-to-go? : -> void
+    ;; effect: set up window, make announcement, wait for user to start the game
+    (define (ready-to-go?)
+      (start2 EAST SOUTH)
+      (draw-solid-rect   (make-posn (- (quotient EAST 2) 100) 10) 200 20 BG-COLOR)
+      ((draw-string (get-@VP)) (make-posn (- (quotient EAST 2)  65) 20)
+       "Click anywhere when ready!")
+      (let loop () (unless (ready-mouse-click (get-@VP)) (loop)))
+      (draw-solid-rect   (make-posn (- (quotient EAST 2) 100) 10) 200 20 BG-COLOR))
+ 
+    (define (start2 x y)
+      (start x y)
+      (draw-solid-rect (make-posn 0 0) EAST SOUTH BG-COLOR))
+
+    ;; The Graphical Ball Representation
+    ;; ---------------------------------
+    (define BALL-RADIUS 5)
+    (define (draw-ball p) (draw-solid-disk p BALL-RADIUS 'red))
+    (define (clear-ball p) (draw-solid-disk p BALL-RADIUS 'white))
+
+    ;(define (draw-ball p)
+    ;  (set! draw-ball ((draw-pixmap-posn "Gifs/redball.gif") (get-@VP)))
+    ;  (draw-ball p))
+    ;(define (clear-ball p)
+    ;  (set! clear-ball ((clear-pixmap-posn "Gifs/redball.gif") (get-@VP)))
+    ;  (clear-ball p))
+
+
+    ;; Global Properties (initialized by set-up!)
+    ;; ------------------------------------------
+
+    (define BG-COLOR   'green)
+    (define BALL-COLOR 'red)
+    (define PAD-COLOR  'blue)
+    (define (set-pad)   (set! PAD-COLOR 'blue)) 
+    (define (unset-pad) (set! PAD-COLOR 'white)) 
+    (define TRACE-COLOR 'white)
+    (define (set-trace) (set! TRACE-COLOR 'green)) 
+    (define (unset-trace) (set! TRACE-COLOR 'white)) 
+
+    (define SLEEP .15)
+    (define SWITCH 10000)
+    (define CENTER (quotient EAST 2))
+    (define PADDLE-X EAST)
+    (define PADDLE-Y (quotient SOUTH 2))
+
+    ;; The Graphical Paddle Representation
+    ;; ------------------------------------
+    (define PAD_WIDTH  3)
+    (define PAD_LENGTH 50)
+    (define PAD_DIST_WALL  0)
+
+    (define (draw-paddle paddle) 
+      (draw-solid-rect paddle PAD_WIDTH PAD_LENGTH PAD-COLOR))
+    (define (clear-paddle paddle)
+      (draw-solid-rect paddle PAD_WIDTH PAD_LENGTH BG-COLOR))
+
+    ;; center-paddle : posn -> posn
+    (define (center-paddle p)
+      (make-posn (posn-x p) (- (posn-y p) (quotient PAD_LENGTH 2))))
+	
+    (define (new-paddle paddle new-y)
+      (make-posn (posn-x paddle) new-y))
+
+    (define (in-west-zone? p) (<= 0 (posn-x p) CENTER))
+    (define (in-east-zone? p) (<= CENTER (posn-x p) EAST))
+
+    ;; make-landed-on-paddle :
+    ;;   (box posn) (box posn) -> ( ball -> boolean )
+    ;; to set up landed on paddle 
+    (define (make-landed-on-paddle east west)
+      (lambda (pball)
+	(let ((y-pad (posn-y
+		       (unbox
+			 (cond
+			   ((= EAST (posn-x pball)) east)
+			   ((= WEST (posn-x pball)) west)
+			   (else (error 'landed-on-paddle
+				   "this ball has not reached a wall: ~s" pball)))))))
+	  (<= y-pad (posn-y pball) (+ y-pad PAD_LENGTH)))))
+
+    ;; landed-on-paddle : the paddles are initially in the middle of the
+    ;; two walls
+    (set! %landed-on-paddle?
+      (make-landed-on-paddle
+	(box (make-posn
+	       (- PAD_DIST_WALL WEST)
+	       (- (quotient SOUTH 2) (quotient PAD_LENGTH 2))))
+	(box (make-posn
+	       (- EAST (+ PAD_WIDTH PAD_DIST_WALL))
+	       (- (quotient SOUTH 2) (quotient PAD_LENGTH 2))))))
+
+    )))
diff --git a/collects/htdp/HtDPv0/protect-play-unit.ss b/collects/htdp/HtDPv0/protect-play-unit.ss
new file mode 100644
index 0000000000..072e0b749a
--- /dev/null
+++ b/collects/htdp/HtDPv0/protect-play-unit.ss
@@ -0,0 +1,103 @@
+#cs(module protect-play-unit mzscheme
+     (provide protect-play-U)
+     (require (lib "unitsig.ss")
+              "pingp-sig.ss"
+              (lib "list.ss")
+	      (lib "posn.ss" "lang"))
+
+     (define protect-play-U
+       (unit/sig protectS
+         (import ping-protS pingpS)
+         
+         ;; Adapting the relevant functions from the pingp game
+         ;; ---------------------------------------------------
+         
+         ;; move-in-box : ball number -> ball or #f (if the ball gets destroyed)
+         (define (move-in-box ball t)
+           (case (bounces-off ball t)
+             ((NORTH-SOUTH)
+              (move-in-box
+               (ns-bounce
+                (move-ball ball (ns-time-to-wall ball)))
+               (- t (ns-time-to-wall ball))))
+             ((PADDLE) #f)
+             (else (move-ball ball t))))
+         
+         ;; bounces-off : ball number -> {'NORTH-SOUTH,'PADDLE,'none}
+         (define (bounces-off ball t)
+           (cond
+             ((<= (ns-time-to-wall ball) (min (ew-time-to-wall ball) t)) 'NORTH-SOUTH)
+             ((<= (ew-time-to-wall ball) (min (ns-time-to-wall ball) t))
+              (cond
+                [(landed-on-paddle? (ball-posn (move-ball ball (ew-time-to-wall ball))))
+                 'PADDLE]
+                [else 'none]))
+             (else 'none)))
+         
+         
+         ;; Dealing with collections of balls
+         ;; ---------------------------------
+         
+         ;; mk-balls : natnum -> list-of-balls
+         (define (mk-balls a-nn)
+           (cond
+             ((zero? a-nn) null)
+             (else
+              (cons 
+               (make-ball (make-posn (random-between FAR_WEST EAST) (random SOUTH))
+                          (make-speed (random-between MIN-X-SPEED MAX-X-SPEED) 
+                                      (random-between MIN-Y-SPEED MAX-Y-SPEED)))
+               (mk-balls (- a-nn 1))))))
+         
+         ;; random-between : int int -> int (randomly in betweeen he two inputs)
+         (define (random-between low high)
+           (+ low (random (+ (abs low) (abs high)))))
+         
+         ;; move-balls : list-of-balls -> list-of-balls 
+         (define (move-balls loballs)
+           (cond
+             ((null? loballs) null)
+             (else (cons (move-in-box (first loballs) 1) (move-balls (rest loballs))))))
+         
+         ;; remove-balls-hit-paddle : list-of-balls/#f -> list-of-balls 
+         ;;  (those that hit paddle during a move or are outside after a move)
+         (define (remove-balls-hit-paddle loballs)
+           (cond
+             ((null? loballs) null)
+             (else (cond
+                     ((boolean? (first loballs))
+                      (remove-balls-hit-paddle (rest loballs)))
+                     (else
+                      (cons (first loballs) (remove-balls-hit-paddle (rest loballs))))))))
+         
+         ;; remove-outside-balls : list-of-balls -> list-of-balls 
+         ;;  (those that hit paddle during a move or are outside after a move)
+         (define (remove-outside-balls loballs)
+           (cond
+             ((null? loballs) null)
+             (else (cond
+                     ((inside? (first loballs))
+                      (cons (first loballs) (remove-outside-balls (rest loballs))))
+                     (else
+                      (remove-outside-balls (rest loballs)))))))
+         
+         ;; inside? : ball -> boolean (is the ball inside the user-defined space)
+         (define (inside? aball)
+           (and (<= FAR_WEST (posn-x (ball-posn aball)) EAST)
+                (<= NORTH    (posn-y (ball-posn aball)) SOUTH)))
+         
+         ;; balls-posn : list-of-balls -> list-of-posn (a projection)
+         (define (balls-posn l)
+           (cond
+             ((null? l) null)
+             (else (cons (ball-posn (first l)) (balls-posn (rest l))))))
+         
+         ;; the true extent of the space
+         (define FAR_WEST (* -1 EAST))
+         
+         (define MIN-X-SPEED 05)
+         (define MAX-X-SPEED 15)
+         (define MIN-Y-SPEED 1)
+         (define MAX-Y-SPEED 4)
+         
+         )))
diff --git a/collects/htdp/HtDPv0/protect-play.ss b/collects/htdp/HtDPv0/protect-play.ss
new file mode 100644
index 0000000000..bf35c4d0b5
--- /dev/null
+++ b/collects/htdp/HtDPv0/protect-play.ss
@@ -0,0 +1,30 @@
+#cs(module protect-play mzscheme
+     (require "pingp-sig.ss"
+              "protect-play-unit.ss"
+              "ping-play-unit.ss"
+              "pingp.ss"
+              (lib "unitsig.ss"))
+     
+     (provide protect-play@)
+     (define protect-play@
+       (compound-unit/sig 
+         (import)
+         (link
+          [PINGP : pingpS (pingpU)]
+          [BALL  : ping-protS (ping-play-U PINGP)]
+          [PROT  : protectS   (protect-play-U BALL PINGP)]
+          (GO : goS ((unit/sig goS (import protectS pingpS)
+                       (define n (+ 10 (random 10)))
+                       (define (go s)
+                         (set! n (+ 10 (random 10)))
+                         (printf "You're facing ~a balls. Have fun playing, ~a~n" n s)
+                         (protect (mk-balls n)
+                                  move-balls
+                                  remove-balls-hit-paddle
+                                  remove-outside-balls
+                                  balls-posn)))
+                     PROT
+                     (PINGP : pingpS))))
+         (export (var (PINGP change-speed))
+                 (var (PINGP change-wind))
+                 (open GO)))))
\ No newline at end of file
diff --git a/collects/htdp/HtDPv0/rectangle.ss b/collects/htdp/HtDPv0/rectangle.ss
new file mode 100644
index 0000000000..3e853defbf
--- /dev/null
+++ b/collects/htdp/HtDPv0/rectangle.ss
@@ -0,0 +1,51 @@
+(module rectangle mzscheme
+  (require (lib "error.ss" "htdp")
+	   (lib "draw-sig.ss" "htdp")
+	   (lib "big-draw.ss" "htdp")
+           (lib "unitsig.ss")
+           (lib "list.ss")
+	   (lib "posn.ss" "lang"))
+  
+  (provide show)
+  
+  (define-primitive show show/proc)
+  
+  ;; do we really need this? Can't they load draw as well instead?
+  (provide-signature-elements draw^)
+  
+  ;; show : rectangle -> #t
+  (define (show/proc rect)
+    (check-arg 'show
+               (and (list? rect) (andmap (lambda (l) (and (list? l) (andmap rgb? l))) rect))
+               "rectangle (list of list of colors)" "" rect)
+    
+    (clear-all)
+    
+    (let ((x 0) (y 0))
+      (for-each (lambda (line)
+                  (for-each (lambda (color) 
+                              (draw-square x y color)
+                              (set! x (+ x LENGTH-SQUARE)))
+                            line)
+                  (set! x 0)
+                  (set! y (+ y LENGTH-SQUARE)))
+                rect)
+      #t))
+  
+  ;; could be done by students -- after they learn about accumulators
+  (define (show2 rect)
+    (let OL ((rect rect) (y 0))
+      (cond
+        ((null? rect) #t)
+        (else (let IL ((line (first rect)) (x 0))
+                (cond
+                  ((null? line) (void))
+                  (else (and (draw-square x y (first line))
+                             (IL (rest line) (+ x LENGTH-SQUARE))))))
+              (OL (rest rect) (+ y LENGTH-SQUARE))))))
+  
+  ;; draw-square : number number symbol -> #t
+  (define (draw-square y x c)
+    (draw-solid-rect (make-posn y x) LENGTH-SQUARE LENGTH-SQUARE c))
+  
+  (define LENGTH-SQUARE 10))
diff --git a/collects/htdp/Test/TEST b/collects/htdp/Test/TEST
new file mode 100644
index 0000000000..4669131705
--- /dev/null
+++ b/collects/htdp/Test/TEST
@@ -0,0 +1,28 @@
+TEST: 
+----
+
+* arrow.ss
+* arrow-gui.ss
+* convert.ss
+* dir.ss 
+* docs.ss
+* draw.ss
+* elevator.ss
+* graphing.ss
+* guess.ss
+* guess2.ss
+* guess3.ss
+* gui.ss
+* lkup-gui.ss
+* hangman.ss : changed, docs
+* master.ss : changed, docs
+* pingp.ss 
+* - pingp-test-play.ss : play with a ping-pong
+* - pingp-test-trace.ss : test the two tracer interfaces
+* protect.ss
+* pingp-play.ss 
+* protect-play.ss 
+ - both are tested with pingp-play-test.ss
+ rectangle.ss
+
+Mon Oct 18 16:56:38 CDT 1999: re-organization into teachpacks
diff --git a/collects/htdp/Test/TODO b/collects/htdp/Test/TODO
new file mode 100644
index 0000000000..5285f9e4d1
--- /dev/null
+++ b/collects/htdp/Test/TODO
@@ -0,0 +1,28 @@
+teachpack/htdp
+collects/htdp
+ cvs commit -m. 
+
+-----------------------------------------------------------------------------------
+
+docs: 
+
+-----------------------------------------------------------------------------------
+code: 
+
+General comment: 
+ the word repl should disappear
+
+guess.ss: repl, repl3,
+  check that the result is a symbol gives bad error message 
+
+master.ss 
+  add close? button 
+
+hangman.ss
+  error messages: can we do better? 
+  (test-error (hangman-list (lambda (x y z) x) first))
+  (test-error (hangman-list (lambda (x y z) x) list))
+  
+  the game should be "start-once only"
+
+-----------------------------------------------------------------------------------
diff --git a/collects/htdp/Test/arrow-gui.ss b/collects/htdp/Test/arrow-gui.ss
new file mode 100644
index 0000000000..ce9bcded35
--- /dev/null
+++ b/collects/htdp/Test/arrow-gui.ss
@@ -0,0 +1,27 @@
+;; TeachPack : arrow-gui.ss, gui.ss
+
+(define msg (make-message (make-string 22 #\space)))
+(create-window (list (list msg)))
+
+#| Language: Intermediate with Lambda 
+;; make-model : sym -> (button% event% -> void)
+(define (make-model2 dir)
+  (lambda (b e)
+    (local ([define _ (view dir)])
+      (draw-message msg (format "~a ~n" (control))))))
+
+(connect 
+ (make-model "left")
+ (make-model "right")
+ (make-model "up")
+ (make-model "down"))
+|#
+
+#| Language: Beginner |#
+
+(define (left b e) (draw-message msg "left"))
+(define (right b e) (draw-message msg "right"))
+(define (up b e) (draw-message msg "up"))
+(define (down b e) (draw-message msg "down"))
+
+(connect left right up down)
diff --git a/collects/htdp/Test/arrow.ss b/collects/htdp/Test/arrow.ss
new file mode 100644
index 0000000000..0868284b62
--- /dev/null
+++ b/collects/htdp/Test/arrow.ss
@@ -0,0 +1,56 @@
+; (load "tester.ss")
+
+;; TeachPack : arrow.ss, draw.ss
+;; Language: Beginner
+
+;; ---------------------------------------------------------------------
+;; 
+
+;; A shape is a structure: 
+;;   (make-posn num num)
+
+;; RAD : the radius of the simple disk moving across a canvas
+(define RAD 10)
+
+;; move : number shape   -> shape or false 
+;; to move a shape by delta according to translate 
+;; effect: to redraw it 
+(define (move delta sh)
+  (cond
+    [(and (clear-solid-disk sh RAD)
+          (draw-solid-disk (translate sh delta) RAD))
+     (translate sh delta)]
+    [else false]))
+
+;; translate : shape number -> shape 
+;; to translate a shape by delta in the x direction 
+(define (translate sh delta)
+  (make-posn (+ (posn-x sh) delta) (posn-y sh)))
+
+;; draw-it : shape -> true
+;; to draw a shape on the canvas: a disk with radius
+(define (draw-it sh)
+  (draw-solid-disk sh RAD))
+
+;; TESTS: 
+
+;; this creates the canvas
+(start 100 50)
+
+;; this creates the controller GUI
+(control-left-right (make-posn 10 20) 10 move draw-it)
+
+; (load "tester.ss")
+
+; (test-error (control-left-right 'aa 10 move))
+
+;; cannot raise an exception:
+;(control-left-right 'aa 10 move draw-it)
+;; shape is polymorphic!!
+
+; (test-error (control-left-right 'aa 'bb move draw-it))
+; (control-left-right 'aa 'bb move draw-it)
+; (test-error (control-left-right 'aa 10 'cc draw-it))
+; (control-left-right 'aa 10 'cc draw-it)
+; (test-error (control-left-right 'aa 10 move 'cc))
+; (control-left-right 'aa 10 move 'cc)
diff --git a/collects/htdp/Test/convert.ss b/collects/htdp/Test/convert.ss
new file mode 100644
index 0000000000..44dce8761b
--- /dev/null
+++ b/collects/htdp/Test/convert.ss
@@ -0,0 +1,73 @@
+;; test errors by hand in GUI
+(load "tester.ss")
+
+;; f2c : num -> num
+;; to convert a Fahrenheit temperature into a Celsius temperature 
+(define (f2c f)
+  (* 5/9 (- f 32)))
+
+(define (fx y) 
+  'xyz)
+
+#| Tests: with teach-pack convert.ss |#
+
+(= (f2c 212) 100)
+(= (f2c 32) 0)
+(= (f2c -40) -40)
+
+;; ----------------------------------------------------------------------------
+(define IN "convert-in.dat")
+(define OUT "convert-out.dat")
+
+(define (create-convert-in)
+  (printf "212 32~n-40~n"))
+
+(define (check-convert-out)
+  (and (= (read) 100)
+       (= (read) 0)
+       (= (read) -40)))
+
+(when (file-exists? IN) (delete-file IN))
+(with-output-to-file IN create-convert-in)
+(when (file-exists? OUT) (delete-file OUT))
+(convert-file IN f2c OUT)
+(with-input-from-file OUT check-convert-out)
+    
+(test-error (convert-file IN list OUT))
+;; convert-file: procedure of one argument expected as "convert-gui" argument;
+;; given procedure ...
+
+(test-error (convert-file IN first OUT))
+;; first: expects argument of type <non-empty list>; given 212
+
+(test-error (convert-file IN fx OUT))
+;; convert: The conversion function must produce a number; result: 'xyz
+
+(test-error (convert-file IN f2c 10))
+;; convert-file: expected <string> as third argument, given: 10
+
+;; ----------------------------------------------------------------------------
+;; convert by repl: 
+(convert-repl f2c) 
+;; type in 0 212 40 into the repl 
+
+(test-error (convert-repl first))
+;; hilight first 
+
+(test-error (convert-repl fx))
+;; signal an error about not returning a number
+
+;; ----------------------------------------------------------------------------
+;; convert by GUI 
+
+(convert-gui f2c) 
+
+(define (f2x x) (* x x x x))
+;; (convert-gui f2x)
+;; must result in an error 
+
+;; TEST BY HAND: (convert-gui first)
+;; first is blamed but not nicely 
+
+;; TEST BY HAND: (convert-gui fx)
+;; signal an error about not returning a number
diff --git a/collects/htdp/Test/dir.ss b/collects/htdp/Test/dir.ss
new file mode 100644
index 0000000000..e2b97c2895
--- /dev/null
+++ b/collects/htdp/Test/dir.ss
@@ -0,0 +1,15 @@
+;; TeachPack: dir.ss
+;; Language: Intermediate with Lambda 
+
+(define current (create-dir "."))
+(define teachps (create-dir (string-append "/Users/matthias/plt/" "/teachpack/htdp")))
+
+(define current-files (map file-name (dir-files current)))
+(define teachps-files (map file-name (dir-files teachps)))
+
+(append
+ (map (lambda (x) (format "in Teachpacks, not in Test: ~s" x))
+      (filter (lambda (x) (boolean? (member x current-files))) teachps-files))
+ (map (lambda (x) (format "in Test, not in  Teachpacks: ~s" x))
+      (filter (lambda (x) (boolean? (member x teachps-files))) current-files)))
+
diff --git a/collects/htdp/Test/docs.ss b/collects/htdp/Test/docs.ss
new file mode 100644
index 0000000000..941cbdb018
--- /dev/null
+++ b/collects/htdp/Test/docs.ss
@@ -0,0 +1,12 @@
+;; TeachPack: docs.ss
+;; Language: Beginner 
+
+(annotation? '<html>)
+(not (annotation? 'html))
+(annotation? '<p>)
+
+(eq? '</html> (end-annotation '<html>))
+
+(write-file
+ (list '<p> 'hello 'world 'is 'the 'most 'stupid 'program 'in 'the 'world '</p>
+       "so let's test this" 'with "How's that"))
\ No newline at end of file
diff --git a/collects/htdp/Test/draw.ss b/collects/htdp/Test/draw.ss
new file mode 100644
index 0000000000..ab8966e3b4
--- /dev/null
+++ b/collects/htdp/Test/draw.ss
@@ -0,0 +1,80 @@
+;; This tests a good portion but needs some more 
+;; This needs some tests for error behavior of functions ... 
+
+;; draw-next-part : symbol -> true
+;; consumes one of the seven body-part symbols and draws that part.
+
+(define (draw-next-part body-part)
+  (cond 
+    [(eq? body-part 'body)
+     (draw-solid-line (make-posn 100 60)
+                      (make-posn 100 130)
+                      'black)]
+    [(eq? body-part 'right-leg)
+     (draw-solid-line (make-posn 100 130)
+                      (make-posn 30 170)
+                      'black)]
+    [(eq? body-part 'left-leg)
+     (draw-solid-line (make-posn 100 130)
+                      (make-posn 170 170)
+                      'black)]
+    [(eq? body-part 'right-arm)
+     (draw-solid-line (make-posn 100 75)
+                      (make-posn 40 65)
+                      'black)]
+    [(eq? body-part 'left-arm)
+     (draw-solid-line (make-posn 100 75)
+                      (make-posn 160 65)
+                      'black)]
+    [(eq? body-part 'head)
+     (draw-solid-disk (make-posn 100 50) 10 'black)]
+    [(eq? body-part 'noose)
+     (and
+      (draw-solid-disk (make-posn 120 50) 30 'red)
+      (draw-solid-line (make-posn 100 30)
+                       (make-posn 100 10)
+                       'black)
+      (draw-solid-line (make-posn 100 10)
+                       (make-posn 0 10)
+                       'black)
+      (draw-solid-line (make-posn 115 35)
+                       (make-posn 123 43)
+                       'black)
+      (draw-solid-line (make-posn 123 35)
+                       (make-posn 115 43)
+                       'black)
+      (draw-solid-line (make-posn 131 40)
+                       (make-posn 139 48)
+                       'black)
+      (draw-solid-line (make-posn 139 40)
+                       (make-posn 131 48)
+                       'black))]))
+
+#| Tests ----------------------------------------------------------
+|#
+
+
+(start 200 400)
+(sleep-for-a-while 1)
+(draw-next-part 'noose)
+(sleep-for-a-while 1)
+(draw-next-part 'head)
+(sleep-for-a-while 1)
+(draw-next-part 'left-arm)
+(sleep-for-a-while 1)
+(draw-next-part 'right-arm)
+(sleep-for-a-while 1)
+(draw-next-part 'body)
+(sleep-for-a-while 1)
+(draw-next-part 'left-leg)
+(sleep-for-a-while 1)
+(draw-next-part 'right-leg)
+"please click on the canvas"
+(posn? (wait-for-mouse-click))
+(stop)
+
+#|
+(load "tester.ss")
+(start 200 400)
+(test-error (draw-solid-line 'a 'b 'c))
+|#
\ No newline at end of file
diff --git a/collects/htdp/Test/elevator.ss b/collects/htdp/Test/elevator.ss
new file mode 100644
index 0000000000..4b11a03cf3
--- /dev/null
+++ b/collects/htdp/Test/elevator.ss
@@ -0,0 +1,14 @@
+;; TeachPack: elevator.ss
+;; Language: Beginner 
+
+;; next3 : (union 'up 'down) N X -> N
+;; always sends elevator to next floor up or down, 
+;; switches direction at either end 
+(define (next3 x y z)
+  (cond
+    ((and (eq? 'up x) (< y 8)) (+ y 1))
+    ((eq? 'up x) 7) ; anything down
+    ((and (eq? 'down x) (> y 1)) (- y 1))
+    (else 2))) ; anything up
+
+(run next3)
\ No newline at end of file
diff --git a/collects/htdp/Test/graphing.ss b/collects/htdp/Test/graphing.ss
new file mode 100644
index 0000000000..9e125b8477
--- /dev/null
+++ b/collects/htdp/Test/graphing.ss
@@ -0,0 +1,16 @@
+;; TeachPack: graphing.ss
+;; Language: Beginner
+
+;; ------------------------------------------------------------------------
+
+(define (fun1 x) (+ (* x x) 1))
+(graph-fun fun1 'red)
+
+(define (fun2 x) (+ (* -1 x x) 1))
+(graph-fun fun2 'blue)
+
+(define (line1 x) (+ (* +1 x) 10))
+(graph-line line1 'black)
+
+(define (line2 x) (+ (* -1 x) 10))
+(graph-line line2 'green)
diff --git a/collects/htdp/Test/graphing2.ss b/collects/htdp/Test/graphing2.ss
new file mode 100644
index 0000000000..a2039bbd75
--- /dev/null
+++ b/collects/htdp/Test/graphing2.ss
@@ -0,0 +1,17 @@
+;; TeachPack: graphing2.ss
+;; Language: Beginner
+
+;; ------------------------------------------------------------------------
+
+(define (fun1 x) (+ (* x x) 1))
+(graph-fun fun1 'red)
+
+(define (fun2 x) (+ (* -1 x x) 1))
+(graph-fun fun2 'blue)
+
+(define (line1 x) (* +1 x))
+(graph-line line1 'black)
+
+(define (line2 x) (* -1 x))
+(graph-line line2 'green)
+
diff --git a/collects/htdp/Test/guess-gui.ss b/collects/htdp/Test/guess-gui.ss
new file mode 100644
index 0000000000..313dec3b06
--- /dev/null
+++ b/collects/htdp/Test/guess-gui.ss
@@ -0,0 +1,21 @@
+;; TeachPack : guess-gui.ss
+;; Language: Beginning 
+
+;; ------------------------------------------------------------------------
+;; model : button% event% -> true
+(define (model x y)
+  (view (convert (list (control 0) (control 1) (control 2)))))
+
+;; convert : (listof DIGIT) -> number 
+;; to convert a list of digits into a number 
+;; the leading digit is the least signifcant one
+(define (convert alod)
+  (cond
+    [(empty? alod) 0]
+    [else (+ (first alod) (* 10 (convert (rest alod))))]))
+
+;; TEST: 
+(connect model)
+
+
+
diff --git a/collects/htdp/Test/guess1.ss b/collects/htdp/Test/guess1.ss
new file mode 100644
index 0000000000..40acd88ada
--- /dev/null
+++ b/collects/htdp/Test/guess1.ss
@@ -0,0 +1,23 @@
+;; ------------------------------------------------------------------------
+;; language: beginner 
+;; teachpack: guess.ss
+
+;; check-guess : number number -> symbol 
+;; to determine how guess and target relate to each other 
+(define (check-guess guess target)
+  (cond
+    ((< target guess) 'TooLarge)
+    ((= target guess) 'Perfect)
+    ((> target guess) 'TooSmall)))
+
+;; Tests: 
+(eq? (check-guess 5000 5631) 'TooSmall)
+(eq? (check-guess 6000 5631) 'TooLarge)
+(eq? (check-guess 5631 5631) 'Perfect)
+
+;; Test with GUI lib: set lib to guess-lib.ss
+(guess-with-gui check-guess)
+
+; (guess-with-gui list)
+; (define (foo x) x) (guess-with-gui foo)
+; (guess-with-gui first)
diff --git a/collects/htdp/Test/guess2.ss b/collects/htdp/Test/guess2.ss
new file mode 100644
index 0000000000..3afa125d5b
--- /dev/null
+++ b/collects/htdp/Test/guess2.ss
@@ -0,0 +1,40 @@
+; (load "tester.ss")
+;; by hand, bottom
+
+;; ------------------------------------------------------------------------
+;; testing repl3
+;; teachpack: guess.ss
+
+;; check-guess3 : digit digit digit number -> symbol
+;; to determine how three guess digits and target relate to each other 
+(define (check-guess3 d0 d1 d2 target)
+  (check-guess (convert3 d0 d1 d2) target))
+
+;; convert3: digit digit digit -> number
+;; to convert three digits, from right to left, into a number 
+(define (convert3 d0 d1 d2) 
+  (+ (* 100 d2)(+ (* 10 d1) d0)))
+
+;; check-guess : number number -> symbol 
+;; to determine how guess and target relate to each other 
+(define (check-guess guess target)
+  (cond
+    ((< target guess) 'TooLarge)
+    ((= target guess) 'Perfect)
+    ((> target guess) 'TooSmall)))
+
+;; Tests for check-guess3:
+(= (convert3 0 0 5) 500)
+(= (convert3 1 2 3) 321)
+
+;; Tests for check-guess3:
+(eq? (check-guess3 0 0 5 631) 'TooSmall)
+(eq? (check-guess3 0 0 7 631) 'TooLarge)
+(eq? (check-guess3 1 3 6 631) 'Perfect)
+
+;; Test with GUI: set lib to guess-lib.ss
+(guess-with-gui-3 check-guess3)
+
+; (define (foo x) x) (guess-with-gui-3 foo) 
+; (guess-with-gui-3 'a)
+       
diff --git a/collects/htdp/Test/guess3.ss b/collects/htdp/Test/guess3.ss
new file mode 100644
index 0000000000..6353cd9b9c
--- /dev/null
+++ b/collects/htdp/Test/guess3.ss
@@ -0,0 +1,41 @@
+; (load "tester.ss")
+;; by hand, bottom
+
+;; ------------------------------------------------------------------------
+;; testing repl-list
+;; teachpack: guess.ss
+
+;; check-guess-for-list : (listof DIGIT) number -> symbol
+;; to determine how guess digits and target relate to each other 
+(define (check-guess-for-list guess-list target)
+  (check-guess (convert guess-list)target))
+
+;; check-guess : number number -> symbol 
+;; to determine how guess and target relate to each other 
+(define (check-guess guess target)
+  (cond
+    ((< target guess) 'TooLarge)
+    ((= target guess) 'Perfect)
+    ((> target guess) 'TooSmall)))
+
+;; convert : (listof DIGIT) -> number
+;; to convert a vector of digits into a number 
+;; 0-th digit is right-most digit in number, 
+;; N-th digit is left-most digit in number
+(define (convert digits)
+  (cond
+    ((empty? digits) 0)
+    (else (+ (first digits) (* (convert (rest digits)) 10)))))
+
+;; EXAMPLES/TESTS for convert:
+(= (convert (cons 1 (cons 2 (cons 3 empty)))) 321)
+(= (convert (cons 4 (cons 5 (cons 6 empty)))) 654)
+
+;; EXAMPLES/TESTS for check-guess-for-list:
+(eq? (check-guess-for-list (cons 0 (cons 0 (cons 5 empty))) 631) 'TooSmall)
+(eq? (check-guess-for-list (cons 6 (cons 0 (cons 7 empty))) 631) 'TooLarge)
+(eq? (check-guess-for-list (cons 1 (cons 3 (cons 6 empty))) 631) 'Perfect)
+
+;; Test with GUI: set lib to guess-lib.ss
+(guess-with-gui-list 2 check-guess-for-list)
+
diff --git a/collects/htdp/Test/gui.ss b/collects/htdp/Test/gui.ss
new file mode 100644
index 0000000000..dcc26bcf30
--- /dev/null
+++ b/collects/htdp/Test/gui.ss
@@ -0,0 +1,24 @@
+;; TeachPack: gui.ss
+;; Language Level: Advanced 
+
+;; type in text, choose, click okay, watch message field change, close
+
+(define msg (make-message "Hello World"))
+
+(define txt (make-text "Enter your password please"))
+
+(define chc (make-choice (list "Choose something" "Or other")))
+
+(define call-back
+  (lambda (x)
+    (begin
+      (draw-message msg (format "~s ~s~n" (choice-index chc) (text-contents txt)))
+      (draw-message msg "Bye World"))))
+
+(define (destroy x) (hide-window x))
+
+(create-window
+ (list (list txt msg chc)
+       (list (make-button "Okay?" call-back))
+       (list (make-button "Close" hide-window))))
+
diff --git a/collects/htdp/Test/hangman1.ss b/collects/htdp/Test/hangman1.ss
new file mode 100644
index 0000000000..cca1a13c43
--- /dev/null
+++ b/collects/htdp/Test/hangman1.ss
@@ -0,0 +1,50 @@
+;; Language: Advanced
+
+; (load "tester.ss")
+;; by hand, Beginner for plain, Full for errors 
+
+
+(define-struct word (a b c))
+;; A word is a structure: (make-word letter letter letter)
+
+;; DEFINITION: 
+(define (reveal chosen status guess)
+  (make-word (reveal1 (word-a chosen) (word-a status) guess)
+             (reveal1 (word-b chosen) (word-b status) guess)
+             (reveal1 (word-c chosen) (word-c status) guess)))
+
+;; EXAMPLES:
+;; reveal1: 'a 'a 'x => 'a 
+;; reveal1: 'x '_ 'x => 'x
+;; reveal1: 'x '_ 'y => '_
+
+;; The inputs are atomic, which means we need domain knowledge.
+;; The domain knowledge is given in the problem statement. 
+
+;; DEFINITION: 
+(define (reveal1 ch st gu) 
+  (cond
+    ((eq? ch st) ch)
+    ((eq? ch gu) gu)
+    (else st)))
+
+
+
+#| -------------------------------------------------------------------------
+   TESTS:
+|#
+  
+(eq? (reveal1 'a 'a 'x) 'a)
+(eq? (reveal1 'x '_ 'x) 'x)
+(eq? (reveal1 'x '_ 'y) '_)
+
+(equal? (reveal (make-word 'd 'e 'r) (make-word '_ '_ '_) 'd)
+        (make-word 'd '_ '_))
+(equal? (reveal (make-word 'd 'e 'r) (make-word '_ '_ '_) 'f)
+        (make-word '_ '_ '_))
+
+;; check errors 
+; (hangman make-word)
+; (hangman (make-word 'a 'b 'c) reveal draw-next-part)
+; (hangman make-word (reveal (make-word 'd 'e 'r) (make-word '_ '_ '_) 'd) draw-next-part)
+; (hangman make-word reveal 100)
diff --git a/collects/htdp/Test/hangman2.ss b/collects/htdp/Test/hangman2.ss
new file mode 100644
index 0000000000..0d80cddb14
--- /dev/null
+++ b/collects/htdp/Test/hangman2.ss
@@ -0,0 +1,50 @@
+(load "tester.ss")
+
+#| ------------------------------------------------------------------------
+draw-next-part :
+{ 'noose 'head 'right-arm 'left-arm 'body 'right-leg 'left-leg } -> #t
+result: #t if things went okay
+effect: to draw the specified body part in a canvas of size W x H
+credit: John Clements 
+|#
+(define (draw-next-part body-part)
+  (cond ((eq? body-part 'body)
+	 (draw-solid-line (make-posn 100 60) (make-posn 100 130) BLACK))
+    ((eq? body-part 'right-leg)
+     (draw-solid-line (make-posn 100 130) (make-posn 30 170) BLACK))
+    ((eq? body-part 'left-leg)
+     (draw-solid-line (make-posn 100 130) (make-posn 170 170) BLACK))
+    ((eq? body-part 'right-arm)
+     (draw-solid-line (make-posn 100 75) (make-posn 40 65) BLACK))
+    ((eq? body-part 'left-arm)
+     (draw-solid-line (make-posn 100 75) (make-posn 160 65) BLACK))
+    ((eq? body-part 'head)
+     (draw-circle (make-posn 100 50) 10 BLACK))
+    ((eq? body-part 'noose)
+     (and
+       (draw-solid-line (make-posn 100 30) (make-posn 100 10) BLACK)
+       (draw-solid-line (make-posn 100 10) (make-posn 0 10) BLACK)
+       (draw-solid-line (make-posn 115 35) (make-posn 123 43) BLACK)
+       (draw-solid-line (make-posn 123 35) (make-posn 115 43) BLACK)
+       (draw-solid-line (make-posn 131 40) (make-posn 139 48) BLACK)
+       (draw-solid-line (make-posn 139 40) (make-posn 131 48) BLACK)
+       (draw-circle (make-posn 120 50) 30 RED)))))
+
+;; reveal-list : list-of-letters list-of-letters letter -> list-of-letters
+(define (reveal-list word1 word2 letter)
+  (cond
+    ((empty? word1) empty)
+    (else (cons (reveal1 (first word1) (first word2) letter)
+                (reveal-list (rest word1) (rest word2) letter)))))
+
+
+;; TESTS: 
+
+;(start 200 400)
+;(hangman-list reveal-list draw-next-part)
+;
+; (hangman-list reveal-list)
+; (hangman-list reveal-list 1)
+; (hangman-list 1 reveal-list)
+; (hangman-list cons first)
+
diff --git a/collects/htdp/Test/lkup-gui.ss b/collects/htdp/Test/lkup-gui.ss
new file mode 100644
index 0000000000..cd5149f8cd
--- /dev/null
+++ b/collects/htdp/Test/lkup-gui.ss
@@ -0,0 +1,6 @@
+;; TeachPack: lkup-gui.ss
+;; Language: Advanced
+
+(connect 
+ (lambda (e b)
+   (view (control))))
\ No newline at end of file
diff --git a/collects/htdp/Test/master-play.ss b/collects/htdp/Test/master-play.ss
new file mode 100644
index 0000000000..682ebf2bc4
--- /dev/null
+++ b/collects/htdp/Test/master-play.ss
@@ -0,0 +1,40 @@
+(define-signature masterTS (go))
+
+(define (masterT N)
+  (unit/sig masterTS (import (m : masterS) plt:userspace^)
+    ;; check-guess-two : sym sym sym sym -> sym
+    ;; to determine whether targetI and guessI are the same
+    ;; or whether at least some of guessI occur in targetI 
+    (define (check-guess-two target1 target2 guess1 guess2)
+      (cond
+	((and (eq? target1 guess1) (eq? target2 guess2))
+	 'perfect_guess)
+	((or (eq? target1 guess1) (eq? target2 guess2))
+	 'one_color_at_correct_position)
+	((or (eq? target2 guess1) (eq? target1 guess2))
+	 'the_colors_occur)
+	(else 'nothing_correct)))
+
+    ;; check-guess-multiple : (listof sym) (listof sym) -> sym
+    ;; to determine whether guesses and choices are the same
+    ;; or whether at least some of guesses occur in choices
+    (define (check-guess-multiple choices guesses)
+      (cond
+	((equal? choices guesses) 'perfect_guess)
+	(else (let* ((same-position (filter identity (map eq? choices guesses)))
+		     (common (filter (lambda (x) (memq x choices)) guesses)))
+		(cond
+		  ((pair? same-position) 'some_colors_are_in_proper_position)
+		  ((pair? common) 'some_colors_occur_in_chosen_sequence)
+		  (else 'all_wrong))))))
+
+    (define (go)
+      (m:repl (if (= N 2) check-guess-two check-guess-multiple)))))
+
+(compound-unit/sig (import (PLT : plt:userspace^))
+  (link
+    (TEST : masterTS  ((masterT 3) MASTER PLT))
+    (MASTER : masterS ((masterU 3) ERR PLT))
+    (ERR  : errorS    (errorU)))
+  (export (open TEST)))
+	  
diff --git a/collects/htdp/Test/master.ss b/collects/htdp/Test/master.ss
new file mode 100644
index 0000000000..9dcef544f5
--- /dev/null
+++ b/collects/htdp/Test/master.ss
@@ -0,0 +1,23 @@
+; (load "tester.ss")
+
+;; check-guess : color color color color -> symbol
+
+(define (check-guess target1 target2 guess1 guess2)
+  (cond
+    ((and (eq? target1 guess1) (eq? target2 guess2))
+     'perfect)
+    ((or  (eq? target1 guess1) (eq? target2 guess2))
+     'one_color-at_correct_position)
+    ((or  (eq? target1 guess2) (eq? target2 guess1))
+     'the_colors_occur)
+    (else 'nothing_correct)))
+
+;; Tests: 
+(eq? (check-guess 'white 'blue 'white 'blue) 'perfect)
+(eq? (check-guess 'white 'blue 'red 'blue) 'one_color-at_correct_position)
+(eq? (check-guess 'white 'blue 'blue 'red) 'the_colors_occur)
+(eq? (check-guess 'white 'blue 'red 'green) 'nothing_correct)
+
+(master check-guess)
+; (master 1)
+; (master first)
\ No newline at end of file
diff --git a/collects/htdp/Test/pingp-play.ss b/collects/htdp/Test/pingp-play.ss
new file mode 100644
index 0000000000..b168aa1261
--- /dev/null
+++ b/collects/htdp/Test/pingp-play.ss
@@ -0,0 +1,6 @@
+;; TeachPack:
+;;  1. pingp-play.ss
+;;  2. protect-play.ss
+;; Language: Beginner
+
+(go 'Matthias)
diff --git a/collects/htdp/Test/pingp-trace.ss b/collects/htdp/Test/pingp-trace.ss
new file mode 100644
index 0000000000..34eec186ed
--- /dev/null
+++ b/collects/htdp/Test/pingp-trace.ss
@@ -0,0 +1,101 @@
+;; TeachPack: pingp.ss
+;; Language: Advanced
+
+;; This file tests the trace functions. It is not used anywhere else. 
+
+;; Speed and its relationship to positions
+;; ---------------------------------------
+(define-struct speed (x y))
+
+;; posn+ : posn vec -> vec 
+(define (posn+ p v)
+  (make-posn (+ (posn-x p) (speed-x v)) (+ (posn-y p) (speed-y v))))
+
+;; posn*s : number vec -> posn
+(define (posn*s f p)
+  (make-speed (* f (speed-x p)) (* f (speed-y p))))
+
+;; vec* : vec vec -> vec
+(define (vec* v1 v2) 
+  (make-speed (* (speed-x v1) (speed-x v2)) (* (speed-y v1) (speed-y v2))))
+
+;; The ball representation and some basic primitives:
+;; ---------------------------------------------------
+(define-struct ball (posn speed))
+
+;; make-direction : (speed -> num) X Y -> (ball -> (union X Y))
+(define (make-direction access dir1 dir2)
+  (lambda (ball)
+    (cond
+      ((< (access (ball-speed ball)) 0) dir1)
+      ((> (access (ball-speed ball)) 0) dir2)
+      (else (error 'make-direction "can't happen")))))
+
+;; ns-direction : ball -> {'NORTH, 'SOUTH}
+(define ns-direction (make-direction speed-y 'NORTH 'SOUTH))
+
+;; ew-direction : ball -> {'EAST, 'WEST}
+(define ew-direction (make-direction speed-x 'WEST 'EAST))
+
+;; make-distance : (posn -> num) (ball -> sym) sym num num -> (ball -> num)
+(define (make-distance direction access dir bound1 bound2)
+  (lambda (ball)
+    (if (eq? (direction ball) dir) 
+	(- (access (ball-posn ball)) bound1)
+	(- bound2 (access (ball-posn ball))))))
+
+;; make-time : (ball -> num) (speed -> num) -> (ball -> number)
+(define (make-time distance access)
+  (lambda (ball) 
+    (/ (distance ball) (abs (access (ball-speed ball))))))
+
+;; ns-time-to-wall : ball -> number (time before ns wall is hit)
+(define ns-time-to-wall 
+  (make-time (make-distance ns-direction posn-y 'NORTH NORTH SOUTH) speed-y))
+
+;; ew-time-to-wall : ball -> number (time before ew wall is hit)
+(define ew-time-to-wall 
+  (make-time (make-distance ew-direction posn-x 'WEST WEST EAST) speed-x))
+
+;; Moving a Ball
+;; -------------
+;; move-in-box : ball number -> ball
+(define (move-in-box ball t)
+  (case (bounces-from ball t)
+    ((NORTH SOUTH) (bouncing-move ns-bounce (ns-time-to-wall ball) t ball))
+    ((EAST WEST) (bouncing-move ew-bounce (ew-time-to-wall ball) t ball))
+    (else (move-ball ball t))))
+
+;; bouncing-move : (ball -> ball) num num ball -> ball
+(define (bouncing-move bounce t-bounce t ball)
+  (move-in-box (bounce (move-ball ball t-bounce)) (- t t-bounce)))
+
+;; bounces-from : ball number -> {'NORTH, 'SOUTH, 'EAST, 'WEST, 'none}
+(define (bounces-from ball t)
+  (cond
+    ((<= (ns-time-to-wall ball) (min (ew-time-to-wall ball) t)) (ns-direction ball))
+    ((<= (ew-time-to-wall ball) (min t (ns-time-to-wall ball))) (ew-direction ball))
+    (else 'none)))
+
+;; move : ball number -> ball
+(define (move-ball ball t)
+  (make-ball (posn+ (ball-posn ball) (posn*s t (ball-speed ball))) (ball-speed ball)))
+
+;; make-bounce : speed -> (ball -> ball)
+(define (make-bounce bounceV)
+  (lambda (ball)
+    (make-ball (ball-posn ball) (vec* (ball-speed ball) bounceV))))  
+
+;; ns-bounce : ball -> ball
+(define ns-bounce (make-bounce (make-speed 1 -1)))
+
+;; ew-bounce-west : ball -> ball
+(define ew-bounce (make-bounce (make-speed -1 1)))
+
+;; mover : posn speed number -> posn
+(define (mover p s t) 
+  (posn+ p (posn*s t s)))
+
+(trace-ball (make-ball (make-posn 100 100) (make-speed 8 -2)) ball-posn move-in-box 222)
+
+(trace (make-posn 100 100) (make-speed 8 -2) mover 222)
diff --git a/collects/htdp/Test/pingp.ss b/collects/htdp/Test/pingp.ss
new file mode 100644
index 0000000000..166ead5e12
--- /dev/null
+++ b/collects/htdp/Test/pingp.ss
@@ -0,0 +1,103 @@
+; (require-library "core.ss")
+;; TeachPack: pingp.ss
+;; Language:  Full
+
+;; ---------------------------------------------------------------------------
+;; To test: uncomment the last line.
+;; The file tests the function play from pingp.ss. 
+;; The file is used to build protect-text.ss. 
+
+;; Speed and its relationship to positions
+;; ---------------------------------------
+(define-struct speed (x y))
+
+;; posn+ : posn vec -> vec 
+(define (posn+ p v)
+  (make-posn (+ (posn-x p) (speed-x v)) (+ (posn-y p) (speed-y v))))
+
+;; posn*s : number vec -> posn
+(define (posn*s f p)
+  (make-speed (* f (speed-x p)) (* f (speed-y p))))
+
+;; vec* : vec vec -> vec
+(define (vec* v1 v2) 
+  (make-speed (* (speed-x v1) (speed-x v2)) (* (speed-y v1) (speed-y v2))))
+
+;; The ball representation and some basic primitives:
+;; ---------------------------------------------------
+(define-struct ball (posn speed))
+
+;; make-direction : (speed -> num) X Y -> (ball -> (union X Y))
+(define (make-direction access dir1 dir2)
+  (lambda (ball)
+    (cond
+      ((< (access (ball-speed ball)) 0) dir1)
+      ((> (access (ball-speed ball)) 0) dir2)
+      (else (error 'make-direction "can't happen")))))
+
+;; ns-direction : ball -> {'NORTH, 'SOUTH}
+(define ns-direction (make-direction speed-y 'NORTH 'SOUTH))
+
+;; ew-direction : ball -> {'EAST, 'WEST}
+(define ew-direction (make-direction speed-x 'WEST 'EAST))
+
+;; make-distance : (posn -> num) (ball -> sym) sym num num -> (ball -> num)
+(define (make-distance direction access dir bound1 bound2)
+  (lambda (ball)
+    (if (eq? (direction ball) dir) 
+	(- (access (ball-posn ball)) bound1)
+	(- bound2 (access (ball-posn ball))))))
+
+;; make-time : (ball -> num) (speed -> num) -> (ball -> number)
+(define (make-time distance access)
+  (lambda (ball) 
+    (/ (distance ball) (abs (access (ball-speed ball))))))
+
+;; ns-time-to-wall : ball -> number (time before ns wall is hit)
+(define ns-time-to-wall 
+  (make-time (make-distance ns-direction posn-y 'NORTH NORTH SOUTH) speed-y))
+
+;; ew-time-to-wall : ball -> number (time before ew wall is hit)
+(define ew-time-to-wall 
+  (make-time (make-distance ew-direction posn-x 'WEST WEST EAST) speed-x))
+
+;; Moving a Ball
+;; -------------
+;; move-in-box : ball number -> ball
+(define (move-in-box ball t)
+  (case (bounces-from ball t)
+    ((NORTH SOUTH) (bouncing-move ns-bounce (ns-time-to-wall ball) t ball))
+    ((EAST WEST) (bouncing-move ew-bounce (ew-time-to-wall ball) t ball))
+    (else (move-ball ball t))))
+
+;; bouncing-move : (ball -> ball) num num ball -> ball
+(define (bouncing-move bounce t-bounce t ball)
+  (move-in-box (bounce (move-ball ball t-bounce)) (- t t-bounce)))
+
+;; bounces-from : ball number -> {'NORTH, 'SOUTH, 'EAST, 'WEST, 'none}
+(define (bounces-from ball t)
+  (cond
+    ((<= (ns-time-to-wall ball) (min t (ew-time-to-wall ball))) (ns-direction ball))
+    ((<= (ew-time-to-wall ball) (min t (ns-time-to-wall ball)))
+     (cond 
+       ((landed-on-paddle? (ball-posn (move-ball ball (ew-time-to-wall ball))))
+	(ew-direction ball))
+       (else 'none)))
+    (else 'none)))
+
+;; move : ball number -> ball
+(define (move-ball ball t)
+  (make-ball (posn+ (ball-posn ball) (posn*s t (ball-speed ball))) (ball-speed ball)))
+
+;; make-bounce : speed -> (ball -> ball)
+(define (make-bounce bounceV)
+  (lambda (ball)
+    (make-ball (ball-posn ball) (vec* (ball-speed ball) bounceV))))  
+
+;; ns-bounce : ball -> ball
+(define ns-bounce (make-bounce (make-speed 1 -1)))
+
+;; ew-bounce-west : ball -> ball
+(define ew-bounce (make-bounce (make-speed -1 1)))
+
+(play make-ball make-speed ball-posn move-in-box)
diff --git a/collects/htdp/Test/protect.ss b/collects/htdp/Test/protect.ss
new file mode 100644
index 0000000000..409d94ded0
--- /dev/null
+++ b/collects/htdp/Test/protect.ss
@@ -0,0 +1,113 @@
+(load "pingp.ss")
+;; ---------------------------------------------------------------------------
+;; TeachPack: pingp.ss
+;; Language: Advanced
+
+;; To test: uncomment the block at the bottom.
+;; The file tests the function protect from pingp.ss.
+;; The file is used to build protect-play.ss.
+
+(define (test-go x) (void))
+
+
+(define (test-go x)
+  (protect (mk-balls 10)
+	   ; (list (make-ball (make-posn 100 100) (make-speed 8 -16)))
+	   move-balls
+	   remove-balls-hit-paddle
+	   remove-outside-balls
+	   balls-posn))
+
+
+;; Adapting the relevant functions from the pingp game
+;; ---------------------------------------------------
+
+;; move-in-box : ball number -> ball or #f (if the ball gets destroyed)
+(define (move-in-box ball t)
+  (case (bounces-off ball t)
+    ((NORTH-SOUTH)
+     (move-in-box
+       (ns-bounce
+	 (move-ball ball (ns-time-to-wall ball)))
+       (- t (ns-time-to-wall ball))))
+    ((PADDLE) #f)
+    (else (move-ball ball t))))
+
+;; bounces-off : ball number -> {'NORTH-SOUTH,'PADDLE,'none}
+(define (bounces-off ball t)
+  (cond
+    ((<= (ns-time-to-wall ball) (min (ew-time-to-wall ball) t)) 'NORTH-SOUTH)
+    ((<= (ew-time-to-wall ball) (min (ns-time-to-wall ball) t))
+     (cond
+       [(landed-on-paddle? (ball-posn (move-ball ball (ew-time-to-wall ball))))
+	'PADDLE]
+       [else 'none]))
+    (else 'none)))
+
+
+;; Dealing with collections of balls
+;; ---------------------------------
+
+;; mk-balls : natnum -> list-of-balls
+(define (mk-balls a-nn)
+  (cond
+    ((zero? a-nn) null)
+    (else
+     (cons 
+      (make-ball (make-posn (random-between FAR_WEST EAST) (random SOUTH))
+		 (make-speed (random-between MIN-X-SPEED MAX-X-SPEED) 
+		             (random-between MIN-Y-SPEED MAX-Y-SPEED)))
+      (mk-balls (- a-nn 1))))))
+
+;; random-between : int int -> int (randomly in betweeen he two inputs)
+(define (random-between low high)
+  (+ low (random (+ (abs low) (abs high)))))
+
+;; move-balls : list-of-balls -> list-of-balls 
+(define (move-balls loballs)
+  (cond
+    ((null? loballs) null)
+    (else (cons (move-in-box (first loballs) 1) (move-balls (rest loballs))))))
+
+;; remove-balls-hit-paddle : list-of-balls/#f -> list-of-balls 
+;;  (those that hit paddle during a move or are outside after a move)
+(define (remove-balls-hit-paddle loballs)
+  (cond
+    ((null? loballs) null)
+    (else (cond
+	    ((boolean? (first loballs))
+	     (remove-balls-hit-paddle (rest loballs)))
+	    (else
+	     (cons (first loballs) (remove-balls-hit-paddle (rest loballs))))))))
+
+;; remove-outside-balls : list-of-balls -> list-of-balls 
+;;  (those that hit paddle during a move or are outside after a move)
+(define (remove-outside-balls loballs)
+  (cond
+    ((null? loballs) null)
+    (else (cond
+	    ((inside? (first loballs))
+	     (cons (first loballs) (remove-outside-balls (rest loballs))))
+	    (else
+	     (remove-outside-balls (rest loballs)))))))
+
+;; inside? : ball -> boolean (is the ball inside the user-defined space)
+(define (inside? aball)
+  (and (<= FAR_WEST (posn-x (ball-posn aball)) EAST)
+       (<= NORTH    (posn-y (ball-posn aball)) SOUTH)))
+
+;; balls-posn : list-of-balls -> list-of-posn (a projection)
+(define (balls-posn l)
+  (cond
+    ((null? l) null)
+    (else (cons (ball-posn (first l)) (balls-posn (rest l))))))
+
+;; the true extent of the space
+(define FAR_WEST (* -1 EAST))
+
+(define MIN-X-SPEED 05)
+(define MAX-X-SPEED 15)
+(define MIN-Y-SPEED 1)
+(define MAX-Y-SPEED 4)
+
+(test-go 'x)
\ No newline at end of file
diff --git a/collects/htdp/Test/rectangle.ss b/collects/htdp/Test/rectangle.ss
new file mode 100644
index 0000000000..7cabfcd7b8
--- /dev/null
+++ b/collects/htdp/Test/rectangle.ss
@@ -0,0 +1,12 @@
+;; TeachPack: rectangle.ss
+;; LanguageLevel: beginner 
+
+(start 100 100)
+
+(show (list
+       (list RED RED)))
+
+(show (list 
+       (list BLUE BLUE BLUE BLUE)
+       (list GREEN RED RED GREEN)
+       (list BLUE BLUE BLUE BLUE)))
\ No newline at end of file
diff --git a/collects/htdp/Test/tester.ss b/collects/htdp/Test/tester.ss
new file mode 100644
index 0000000000..210d744111
--- /dev/null
+++ b/collects/htdp/Test/tester.ss
@@ -0,0 +1,16 @@
+(define-syntax test-error 
+  (lambda (stx)
+    (syntax-case stx ()
+      [(_ form ...)
+       (syntax
+        (with-handlers ([exn? (lambda (e) 
+                                (printf "~a~n" (exn-message e))
+                                #t)])
+          form ...
+          #f))])))
+
+
+#| Tests: 
+(not (test-error 1 2 3))
+(test-error (/ 1 0) 2 3)
+|#
\ No newline at end of file
diff --git a/collects/htdp/arrow-gui.ss b/collects/htdp/arrow-gui.ss
new file mode 100644
index 0000000000..e6a1b520e9
--- /dev/null
+++ b/collects/htdp/arrow-gui.ss
@@ -0,0 +1,86 @@
+#cs(module arrow-gui mzscheme
+  
+  (require (lib "error.ss" "htdp")
+           (lib "big-draw.ss" "htdp")
+           (lib "etc.ss")
+           (lib "class.ss")
+           (lib "mred.ss" "mred")
+           (lib "prim.ss" "lang"))
+  
+  (provide
+   control ; modelT modelT modelT modelT -> true 
+   view    ; X -> true
+   connect ; -> Symbol
+   )
+  
+  (define-higher-order-primitive connect connect/proc (left right up down))
+  (define-primitive control control/proc)
+  (define-primitive view view/proc)
+  
+  ;; CONSTANTS ---------------------------------------------------------------
+  (define MY-ICONS "/home/matthias/icons/")
+  (define TITLE "Controller")
+  (define COLLECT (collection-path "icons"))
+  (define ARR "arrow.blue.~a.gif")
+  
+  ;; LAYOUT CONSTRUCTION ----------------------------------------------------
+  
+  
+  ;; mk-image-constant : str (button% event% -> true) -> (panel% -> button%)
+  ;; to create a panel-parameterized button with a picture and a specific call-back 
+  (define (mk-image-constant kind model)
+    (local ([define an-item
+              (make-object bitmap% (build-path COLLECT (format ARR kind)) 'gif)])
+      (lambda (panel)
+        (make-object button% an-item panel model))))
+  
+  ;; make-button-table : 
+  ;;   panel% layout -> (listof (listof (union panel% button%)))
+  ;; to translate a layout table into a button table 
+  ;;   each button is controled by (control a-bitmap)
+  (define (make-button-table panel layout)
+    (local ((define (make-row a-row)
+              (local ((define row-panel (make-object horizontal-panel% panel))
+                      (define (make-item an-item)
+                        (if an-item (an-item row-panel)
+			    (let ([panel (make-object horizontal-panel% row-panel)])
+			      (send panel min-width 30)))))
+                (map make-item a-row))))
+      (map make-row layout)))
+  
+  (define frame (make-object frame% TITLE #f 10 10))
+  (define panel (make-object vertical-panel% frame))
+  (define hor (make-object horizontal-panel% panel '(border)))
+  (define lab (make-object message% "Going where?" hor))
+  (define msg (make-object message% "Nowhere" hor))
+  
+  ;; X -> true
+  ;; to display s in the msg panel 
+  (define (view/proc s)
+    (send msg set-label (format "~a" s))
+    true)
+  
+  ;; WIRING THINGS UP    ----------------------------------------------------
+  ;; -> symbol
+  ;; to read out the current state of the msg field 
+  (define (control/proc)
+    (string->symbol (send msg get-label)))
+  
+  ;; modelT = (button% event% -> true)
+  ;; connect/proc : modelT modelT modelT modelT -> true
+  (define (connect/proc left right up down)
+    (check-proc 'connect left 2 "'left' argument" "two arguments")
+    (check-proc 'connect right 2 "'right' argument" "two arguments")
+    (check-proc 'connect up 2 "'up' argument" "two arguments")
+    (check-proc 'connect down 2 "'down' argument" "two arguments")  
+    (local ((define LEFT-ARROW  (mk-image-constant "left"  left))
+            (define RIGHT-ARROW (mk-image-constant "right" right))
+            (define UP-ARROW    (mk-image-constant "up"    up))
+            (define DOWN-ARROW  (mk-image-constant "down"  down))
+            (define FOUR 
+              `( (,#f         ,UP-ARROW   ,#f)
+                 (,LEFT-ARROW ,#f         ,RIGHT-ARROW)
+                 (,#f         ,DOWN-ARROW ,#f) ))
+            (define layout (make-button-table frame FOUR)))
+      (send frame show true)
+      true)))
diff --git a/collects/htdp/arrow.ss b/collects/htdp/arrow.ss
new file mode 100644
index 0000000000..2a854df88a
--- /dev/null
+++ b/collects/htdp/arrow.ss
@@ -0,0 +1,134 @@
+#cs(module arrow mzscheme
+  
+  (require (lib "error.ss" "htdp")
+           (lib "big-draw.ss" "htdp")
+           (lib "etc.ss")
+           (lib "class.ss")
+           (lib "mred.ss" "mred")
+           (lib "prim.ss" "lang"))
+  
+  (provide
+   control
+   control-up-down
+   control-left-right
+   )
+
+  (define-higher-order-primitive control-up-down control-up-down/proc 
+                                 (_ _ up-down draw))
+
+  (define-higher-order-primitive control-left-right control-left-right/proc 
+                                 (_ _ left-right draw))
+
+  (define-higher-order-primitive control control/proc 
+                                 (_ _ left-right up-down draw))  
+
+  
+  ;; CONSTANTS ---------------------------------------------------------------
+  (define MY-ICONS "/home/matthias/icons/")
+  (define TITLE "Controller")
+  
+  (define (mk-image-constant kind)
+    (make-object bitmap%
+      (build-path (collection-path "icons") (format "arrow.~a.gif" kind)) 'gif))
+  
+  ;(define LEFT-ARROW  (mk-image-constant "marble.left"))
+  ;(define RIGHT-ARROW (mk-image-constant "marble.right"))
+  ;(define UP-ARROW    (mk-image-constant "marble.up"))
+  ;(define DOWN-ARROW  (mk-image-constant "marble.down"))
+  
+  (define LEFT-ARROW  (mk-image-constant "blue.left"))
+  (define RIGHT-ARROW (mk-image-constant "blue.right"))
+  (define UP-ARROW    (mk-image-constant "blue.up"))
+  (define DOWN-ARROW  (mk-image-constant "blue.down"))
+  
+  ;; LAYOUT ------------------------------------------------------------------
+  
+  ;; layout = (listof (listof (union #f bitmap%)))  
+  
+  (define FOUR 
+    `( (,#f         ,UP-ARROW   ,#f)
+       (,LEFT-ARROW ,#f         ,RIGHT-ARROW)
+       (,#f         ,DOWN-ARROW ,#f) ))
+  
+  (define UP-DOWN
+    `( (,UP-ARROW   )
+       (,DOWN-ARROW ) ))
+  
+  (define LEFT-RIGHT
+    `( (,LEFT-ARROW ,RIGHT-ARROW ) ))
+  
+  ;; make-button-table : 
+  ;;   panel% layout (bitmap% -> (_ _ -> X))
+  ;;   -> 
+  ;;   (listof (listof (union panel% button%)))
+  ;; to translate a layout table into a button table 
+  ;;   each button is controled by (control a-bitmap)
+  (define (make-button-table panel control layout)
+    (define (make-row a-row)
+      (define row-panel (make-object horizontal-panel% panel))
+      (define (make-item an-item)
+        (if an-item
+            (make-object button% an-item row-panel (control an-item))
+            (let ([panel (make-object horizontal-panel% row-panel)])
+              (send panel min-width 30))))
+      ;; --- 
+      (map make-item a-row))
+    ;; --- 
+    (map make-row layout))
+  
+  ;; GUI ---------------------------------------------------------------------
+  
+  ;; make-controller :
+  ;;   symbol layout number X (number X -> true) (number X -> true) (X -> true)-> void
+  ;; effect: create a left-right controller that invokes move on delta
+  (define (make-controller tag layout shape delta left-right-action up-down-action draw-shape)
+    (check-arg  tag
+                (and (number? delta) (integer? delta) (>= delta 1))
+                "positive integer"
+                '2nd
+                delta)
+    (check-proc tag left-right-action 2 "move-left-right" "two arguments")
+    (check-proc tag up-down-action 2 "move-up-down" "two arguments")
+    (check-proc tag draw-shape 1 "draw" "one argument")
+    ;; --- 
+    (local ((define frame (make-object frame% TITLE #f 10 10))
+            (define panel (make-object vertical-panel% frame))
+            ;; control : bitmap% -> (_ _ -> void)
+            ;; to check which button was clicked 
+            (define (control an-item)
+              (lambda (x y)
+                ;; DESIGN DECISION:
+                ;; by handing over the number first, nesting the moves becomes easier
+                (evcase an-item
+                        (UP-ARROW
+                         (set! shape (up-down-action (- delta) shape)))
+                        (DOWN-ARROW
+                         (set! shape (up-down-action delta shape)))
+                        (LEFT-ARROW
+                         (set! shape (left-right-action (- delta) shape)))
+                        (RIGHT-ARROW
+                         (set! shape (left-right-action delta shape))))
+                (draw-shape shape))))
+      (make-button-table panel control layout)
+      (send frame show #t)
+      #t))
+  
+  ;; EXPORTS:
+  
+  (define (void2 x y) (void))
+  
+  ;; control-left-right/proc : XShape number (number XShape -> XShape) (XShape -> true) -> true
+  ;; effect: create a window from which a user can control L/R moves
+  (define (control-left-right/proc shape delta lr draw)
+    (make-controller 'control-left-right LEFT-RIGHT shape delta lr void2 draw))
+  
+  ;; control-up-down : X number (number X -> true) (X -> true) -> true
+  ;; effect: create a window from which a user can control U/D moves      
+  (define (control-up-down/proc shape delta ud draw)
+    (make-controller 'control-up-down UP-DOWN shape delta void2 ud draw))
+  
+  ;; control/proc : X number (number X -> true) (number X -> true) (X -> true) -> true
+  ;; effect: create a window from which a user can control moves
+  (define (control/proc shape delta lr ud draw)
+    (make-controller 'control FOUR shape delta lr ud draw))
+  )
diff --git a/collects/htdp/big-draw.ss b/collects/htdp/big-draw.ss
new file mode 100644
index 0000000000..849af01d05
--- /dev/null
+++ b/collects/htdp/big-draw.ss
@@ -0,0 +1,294 @@
+#cs
+(module big-draw mzscheme
+  (require "error.ss"
+           "draw-sig.ss"
+           (lib "etc.ss")
+           (lib "posn.ss" "lang")
+           (lib "prim.ss" "lang")           
+           (lib "unitsig.ss")
+           (prefix mred: (lib "mred.ss" "mred"))
+           (lib "class.ss")
+           (lib "mred-sig.ss" "mred")
+           (lib "graphics-sig.ss" "graphics")
+           (lib "graphics-posn-less-unit.ss" "graphics"))
+  
+  (define-values/invoke-unit/sig graphics:posn-less^
+                                 graphics-posn-less@ #f 
+                                 (mred : mred^)
+                                 graphics:posn^)
+  
+  (provide-signature-elements graphics:posn-less^)
+  
+  (define-primitive draw-solid-disk draw-solid-disk/proc)
+  (define-primitive draw-circle draw-circle/proc)
+  (define-primitive draw-solid-rect draw-solid-rect/proc)
+  (define-primitive draw-solid-line draw-solid-line/proc)  
+  
+  (define-primitive clear-solid-disk clear-solid-disk/proc)
+  (define-primitive clear-circle clear-circle/proc)
+  (define-primitive clear-solid-rect clear-solid-rect/proc)
+  (define-primitive clear-solid-line clear-solid-line/proc)  
+  (define-primitive clear-all clear-all/proc)
+  
+  ;   (provide draw-solid-string clear-solid-string)
+  
+  (define-primitive draw-solid-string draw-string/proc)
+  (define-primitive clear-solid-string clear-string/proc)
+  
+  (define-primitive sleep-for-a-while sleep-for-a-while/proc)
+  (define-primitive wait-for-mouse-click wait-for-mouse-click/proc)
+  (define-primitive get-mouse-event get-mouse-event/proc)
+  (define-primitive get-key-event get-key-event/proc)  
+  
+  (define-higher-order-primitive on-key-event on-key-event/proc (handle-event))
+  (define-higher-order-primitive on-tick-event on-tick-event/proc (handle-tick))
+  (define-primitive big-bang big-bang/proc)
+  (define-primitive end-of-time end-of-time/proc)
+  
+  (define the-error (lambda x (error "evaluate (start <num> <num>) first")))
+  (define-syntax (define-hook stx)
+    (syntax-case stx ()
+      [(_ name)
+       (let* ([stuff (symbol->string (syntax-e (syntax name)))]
+              [fools (lambda (x) (datum->syntax-object #'name (string->symbol x)))]
+              [%name (fools (format "%~a" stuff))]
+              [proc  (fools (format "~a/proc" stuff))])
+         #`(define-values (#,%name #,proc)
+             (values the-error
+                     (lambda a (apply #,%name a)))))]))
+  
+  (define-syntax (define-hook-draw/clear stx)
+    (syntax-case stx () 
+      [(_ name)
+       (let* ([stuff (symbol->string (syntax-e (syntax name)))]
+              [fools (lambda (x) (datum->syntax-object #'name (string->symbol x)))]
+              [clear (fools (format "clear-~a" stuff))]
+              [draw  (fools (format "draw-~a" stuff))])
+         #`(begin
+             (define-hook #,clear)
+             (define-hook #,draw)))]))
+  
+  (define-hook-draw/clear solid-disk) 
+  (define-hook-draw/clear circle)
+  (define-hook-draw/clear string)
+  (define-hook-draw/clear solid-rect)
+  (define-hook-draw/clear solid-line)  
+  
+  (define-hook clear-all)
+  
+  (define-hook get-key-event)
+  (define-hook get-mouse-event)
+  (define-hook wait-for-mouse-click)
+  
+  (define-hook big-bang)     
+  (define-hook on-key-event)
+  (define-hook on-tick-event)
+  (define-hook end-of-time)
+  
+  (define (make-true f) (lambda x (apply f x) #t))
+  (define sleep-for-a-while/proc (make-true mred:sleep/yield))
+  
+  (define-syntax (define-make stx)
+    (syntax-case stx ()
+      [(_ tag procedure)
+       (identifier? (syntax tag))
+       (let* ([stuff (symbol->string (syntax-e (syntax tag)))]
+              [fools (lambda (x) (datum->syntax-object stx (string->symbol x)))]
+              [make- (fools (format "make-~a" stuff))]
+              [name  (fools "name")]
+              [ffff  (fools "f")]
+              [x     (fools "x")])
+         #`(define (#,make- #,name #,ffff)
+             (make-true (lambda #,x (apply procedure #,x)))))]))
+  
+  (define-make line 
+    (lambda (p1 p2 . c)
+      (check-arg name (posn? p1) "posn" "first" p1)
+      (check-arg name (posn? p2) "posn" "second" p2)
+      (f p1 p2 (check-optional name 3 c "third" x))))
+  
+  (define-make rect
+    (lambda (p w h . c)
+      (check-arg name (posn? p) "posn" "first" p)
+      (check-arg name (and (integer? w) (> w 0)) "positive integer" "second" w)
+      (check-arg name (and (integer? h) (> h 0)) "positive integer" "third" h)
+      (f p w h (check-optional name 4 c "fourth" x))))
+  
+  (define-make %string 
+    (lambda (p s)
+      (check-arg name (posn? p) "posn" "first" p)
+      (check-arg name (string? s) "string" "second" s)
+      (f p s)))
+  
+  (define-make circle
+    (lambda (p r . c)
+      (check-arg name (posn? p) "posn" "first" p)
+      (check-arg name (and (integer? r) (> r 0)) "positive integer" "second" r)
+      ((ellipsis-2-circle f) p r (check-optional name 3 c "third" x))))
+  
+  ;; Local function for make-circle 
+  ;; (Posn Number Symbol[color] -> void) -> (Posn Number Symbol[color] -> void)
+  (define (ellipsis-2-circle f)
+    (lambda (p r c)
+      (let ((d (* r 2)))
+        (f (make-posn (- (posn-x p) r) (- (posn-y p) r)) d d c))))
+  
+  ;; (Listof _) String (Listof _) -> Symbol[color]
+  ;; contract: c is shared suffix of all
+  ;; check whether c contains a single color symbol and all has proper length
+  (define (check-optional name n c position x)
+    (if (pair? c)
+        (begin
+          (check-arity name n x)
+          (check-arg name (symbol? (car c)) "symbol" position (car c)))
+        (check-arity name (- n 1) x))
+    (symbol->color (if (null? c) 'black (car c))))
+  
+  (define (start WIDTH HEIGHT)
+    (check-arg 'start (and (integer? WIDTH) (> WIDTH 0)) "positive integer" "first" WIDTH)
+    (check-arg 'start (and (integer? HEIGHT) (> HEIGHT 0)) "positive integer" "second" HEIGHT)
+    ;; --- 
+    (open-graphics)
+    (let ((current-window (open-viewport "Canvas" WIDTH HEIGHT))
+          (*delta* 0))
+      (set! @vp current-window)
+      (set! %clear-all (clear-viewport current-window))
+      
+      (set! %draw-solid-line
+            (make-line 'draw-solid-line (draw-line current-window)))
+      
+      (set! %clear-solid-line
+            (make-line 'clear-solid-line
+                       (lambda (p1 p2 c)
+                         ((clear-line current-window) p1 p2))))
+      
+      (set! %draw-solid-rect (make-rect 'draw-solid-rect (draw-solid-rectangle current-window)))
+      (set! %clear-solid-rect
+            (make-rect 'clear-solid-rect
+                       (lambda (p w h c)
+                         ((clear-solid-rectangle current-window) p w h))))
+      
+      (set! %draw-solid-disk (make-circle 'draw-solid-disk (draw-solid-ellipse current-window)))
+      (set! %clear-solid-disk
+            (make-circle 'clear-solid-disk
+                         (lambda (p r1 r2 c)
+                           ((clear-solid-ellipse current-window) p r1 r2))))
+      
+      (set! %draw-circle (make-circle 'draw-circle (draw-ellipse current-window)))
+      (set! %clear-circle
+            (make-circle 'clear-circle
+                         (lambda (p r1 r2 c)
+                           ((clear-ellipse current-window) p r1 r2))))
+      
+      
+      (set! %draw-string (make-%string 'draw-string (draw-string current-window)))
+      (set! %clear-string (make-%string 'clear-string (clear-string current-window)))
+      
+      
+      (set! %wait-for-mouse-click
+            (lambda ()
+              (mouse-click-posn
+               (get-mouse-click @vp))))
+      
+      (set! %get-key-event
+            (lambda ()
+              (cond
+                [(ready-key-press @vp) => key-value]
+                [else false])))
+      
+      (set! %on-key-event
+            (lambda (f)
+              (check-proc 'on-key-event f 2 'first 'two)
+              ((set-on-key-event @vp) 
+               (lambda (x y) (f (key-value x) y)))
+              #t))
+      
+      (set! %on-tick-event
+            (lambda (f)
+              (let* ([w (ceiling (* 1000 *delta*))]
+                     [w (if (exact? w) w (inexact->exact w))])
+                (check-proc 'on-key-event f 1 'first 'one)
+                ((set-on-tick-event @vp) w f)
+                #t)))
+      
+      (set! %big-bang 
+            (lambda (delta w)
+              (check-arg 'big-bang
+                         (and (number? delta) (>= delta 0))
+                         "number [of seconds] between 0 and 1000000"
+                         "first"
+                         delta)
+              (set! *delta* delta)
+              ((init-world @vp) w) #t))
+      
+      (set! %end-of-time (lambda () ((stop-tick @vp))))
+      
+      (set! %get-mouse-event
+            (lambda ()
+              (cond
+                [(ready-mouse-click @vp) => mouse-click-posn]
+                [else false])))
+      #t))
+  
+  (define (stop)
+    (close-graphics)
+    (set! @vp #f)
+    (set! %clear-all the-error)
+    
+    (set! %draw-solid-line the-error)
+    (set! %clear-solid-line the-error)
+    
+    (set! %draw-solid-rect the-error)
+    (set! %clear-solid-rect the-error)
+    
+    (set! %draw-solid-disk the-error)
+    (set! %clear-solid-disk the-error)
+    
+    (set! %draw-circle the-error)
+    (set! %clear-circle the-error)
+    
+    (set! %wait-for-mouse-click the-error)
+    
+    (set! %get-key-event the-error)
+    (set! %on-key-event the-error)
+    (set! %big-bang the-error)
+    
+    (set! %get-mouse-event the-error)
+    #t)
+  
+  
+  
+  ;; start/cartesian-plane : Number Number -> true
+  ;; start up a canvas of size width x height  and draw a centered cartesian coordinate
+  (define (start/cartesian-plane width height)
+    (check-arg 'start/cartesian-plane
+               (and (integer? width) (> width 0)) "positive integer" "first" width)
+    (check-arg 'start/cartesian-plane
+               (and (integer? height) (> height 0)) "positive integer" "second" height)    
+    (local ((define trash  (start width height))
+            (define mid-x  (quotient width 2))
+            (define mid-y  (quotient height 2)))
+      (and (draw-solid-line (make-posn mid-x 0) (make-posn mid-x height))
+           (draw-solid-line (make-posn 0 mid-y) (make-posn width mid-y)))))
+  
+  (define @vp #f)
+  #cs(define (get-@VP) @vp)
+  
+  (provide-signature-elements draw^)
+  
+  ;; symbol->color : symbol -> color
+  ;; to convert symbol to 
+  (define (symbol->color s)
+    (check-arg 'draw.ss (symbol? s) "symbol" "first" s)
+    (case s 
+      ((white)   (make-rgb 1 1 1))
+      ((yellow)  (make-rgb 1 1 0))
+      ((red)     (make-rgb 1.0 0 0))
+      ((green)   (make-rgb 0 1.0 0))
+      ((blue)    (make-rgb 0 0 1.0))
+      ((black)   (make-rgb 0 0 0))
+      (else
+       (let ([x (send mred:the-color-database find-color (symbol->string s))])
+         (if (rgb? x)
+             x
+             (error 'draw.ss "The symbol ~e is not a legal color in draw.ss." s)))))))
\ No newline at end of file
diff --git a/collects/htdp/convert.ss b/collects/htdp/convert.ss
new file mode 100644
index 0000000000..6918e5f3ce
--- /dev/null
+++ b/collects/htdp/convert.ss
@@ -0,0 +1,261 @@
+#cs
+(module convert mzscheme
+  (require (lib "unitsig.ss")
+           (lib "etc.ss")
+           (lib "class.ss")
+           (lib "mred.ss" "mred")
+           (lib "error.ss" "htdp")
+           (lib "prim.ss" "lang"))
+  
+  (provide-higher-order-primitive convert-gui (f2c))
+  (provide-higher-order-primitive convert-repl (f2c))
+  (provide-higher-order-primitive convert-file (_ f2c _))
+  
+  (define black-pen  (send the-pen-list find-or-create-pen "BLACK" 2 'solid))
+  (define red-brush  (send the-brush-list find-or-create-brush "RED" 'solid))
+  (define white-brush  (send the-brush-list find-or-create-brush "WHITE" 'solid))
+  
+  ;; scale% : (union false (num -> str)) frame% -> scale<%>
+  ;; scale<%> : set-current-x + canvas<%>
+  (define scale%
+    (class canvas%
+      (inherit get-dc get-size get-client-size)    
+      
+      (define value  0)
+      
+      (define (draw-something)
+        (let ([dc (get-dc)])
+          (send dc clear)
+          (let-values ([(width height) (get-client-size)])
+            (send dc set-pen black-pen)
+            (send dc set-brush white-brush)
+            (send dc draw-rectangle 0 0 width height)
+            (send dc set-brush red-brush)
+            (send dc draw-rectangle 0 0
+                  (* width (max 0 (min 1 (/ (- value SLI-MIN) (- SLI-MAX SLI-MIN))))) height)
+            (let*-values ([(cw ch) (get-client-size)]
+                          [(number) value])
+              (when (and (number? number)
+                         (exact? number)
+                         (real? number))
+                (let* ([whole (if (number . < . 0)
+                                  (ceiling number)
+                                  (floor number))]
+                       [fractional-part (- (abs number) (floor (abs number)))]
+                       [num (numerator fractional-part)]
+                       [den (denominator fractional-part)]
+                       [wholes (if (and (zero? whole) (not (zero? number)))
+                                   ""
+                                   (number->string whole))]
+                       [nums (number->string num)]
+                       [dens (number->string den)])
+                  (let-values ([(ww wh wa wd) (send dc get-text-extent wholes)]
+                               [(nw nh na nd) (send dc get-text-extent nums)]
+                               [(dw dh da dd) (send dc get-text-extent dens)])
+                    (let ([w (if (integer? number) (+ ww (max nw dw)) ww)]
+                          [h (if (integer? number)
+                                 wh
+                                 (+ nh dh))])
+                      (cond
+                        [(integer? number) 
+                         (send dc draw-text
+                               wholes
+                               (- (/ cw 2) (/ w 2))
+                               (- (/ ch 2) (/ wh 2)))]
+                        [else
+                         (send dc draw-text
+                               wholes
+                               (- (/ cw 2) (/ w 2))
+                               (- (/ ch 2) (/ wh 2)))
+                         (send dc draw-text
+                               nums
+                               (+ ww (- (/ cw 2) (/ w 2)))
+                               (- (/ ch 2) (/ h 2)))
+                         (send dc draw-text
+                               dens
+                               (+ ww (- (/ cw 2) (/ w 2)))
+                               (+ nh (- (/ ch 2) (/ h 2))))
+                         (send dc draw-line
+                               (+ ww (- (/ cw 2) (/ w 2)))
+                               (/ ch 2)
+                               (+ ww (max nw dw) (- (/ cw 2) (/ w 2)))
+                               (/ ch 2))])))))))))
+      (override on-paint)
+      (define (on-paint) (draw-something))
+      (public set-value)
+      (define (set-value v) 
+        (set! value v)
+        (draw-something))
+      (inherit min-width min-height)
+      (super-instantiate ())
+      (let-values ([(w h a d) (send (get-dc) get-text-extent "100100100")])
+        (min-width (+ 4 (inexact->exact w)))
+        (min-height (+ 4 (inexact->exact (* 2 h)))))))
+  
+  ;; ------------------------------------------------------------------------
+  (define OUT-ERROR
+    "The conversion function must produce a number; result: ~e")
+  
+  ;; ============================================================================
+  ;; MODEL
+  ;; 2int : num -> int
+  ;; to convert a real number into an exact number 
+  (define (2int x)
+    (if (and (real? x) (number? x))
+        (inexact->exact x)
+        (error 'convert OUT-ERROR x)))
+  
+  ;; f2c : num -> num
+  ;; to convert a Fahrenheit temperature into a Celsius temperature 
+  (define (f2c f)
+    (2int (* 5/9 (- f 32))))
+  
+  ;; fahr->cel : num -> num 
+  ;; student-supplied function for converting F to C
+  (define (fahr->cel f)
+    (error 'convert "not initialized"))
+  
+  ;; slider-cb : slider% event% -> void
+  ;; to use fahr->cel to perform the conversion 
+  (define (slider-cb c s)
+    (send sliderC set-value
+          ((compose in-slider-range 2int fahr->cel)
+           (send sliderF get-value))))
+  
+  ;; in-slider-range : number -> number 
+  ;; to check and to convert the new temperature into an appropriate scale 
+  (define (in-slider-range x)
+    (cond
+      [(<= SLI-MIN x SLI-MAX) x]
+      [else (error 'convert-gui "result out of range for Celsius display")]))
+  
+  
+  #| --------------------------------------------------------------------
+  
+  view  (exports sliderF sliderC SLI-MIN SLI-MAX) (imports f2c slider-cb)   
+  
+  model (imports sliderF sliderC SLI-MIN SLI-MAX) (exports f2c slider-cb)   
+  
+  ----------------------------------------------------------------------- |#
+  
+  ;; ============================================================================
+  ;; VIEW
+  
+  (define frame (make-object frame% "Fahrenheit to Celsius Conversion"))
+  (send frame set-alignment 'center 'center)
+  (define main-panel (instantiate horizontal-panel% () (parent frame)
+                       (stretchable-height #f)))
+  
+  ;; create labels; aligned with sliders 
+  (define mpanel (make-object vertical-panel% main-panel))
+  (begin
+    (make-object message% "Fahrenheit" mpanel)
+    (make-object message% "" mpanel)
+    (make-object message% "Celsius" mpanel))
+  (send mpanel stretchable-width #f)
+  
+  (define panel (make-object vertical-panel% main-panel))
+  (send panel set-alignment 'center 'center)
+  
+  (define F-SLI-MIN -50)
+  (define F-SLI-MAX 250)
+  (define F-SLI-0 32)    
+  (define SLI-MIN (f2c F-SLI-MIN))
+  (define SLI-MAX (f2c F-SLI-MAX))
+  
+  ;; sliderF : slider% 
+  ;; to display the Fahrenheit temperature 
+  (define sliderF (make-object slider% #f F-SLI-MIN F-SLI-MAX panel void F-SLI-0))
+  (send sliderF min-width (- F-SLI-MAX F-SLI-MIN))
+  
+  ;; sliderC : slider% 
+  ;; to display the Celsius temperature 
+  (define sliderC (make-object scale% panel))
+  (define _set-sliderC (send sliderC set-value (in-slider-range (f2c F-SLI-0))))
+  
+  
+  (define button-panel (instantiate vertical-panel% () 
+                         (stretchable-width #f)
+                         (stretchable-height #f)
+                         (parent main-panel)))
+  
+  ;; convert : button%
+  ;; to convert fahrenheit to celsius 
+  (define convert (make-object button% "Convert" button-panel slider-cb))
+  
+  (define close (make-object button% "Close" button-panel
+                  (lambda (x e) (send frame show #f))))
+  
+  ;; convert-gui : (num -> num) -> void
+  ;; to install f as the temperature converter 
+  ;; effect: to create a window with two rulers for converting F to C
+  (define (convert-gui f)
+    (check-proc 'convert-gui f 1 "convert-gui" "one argument")
+    (set! fahr->cel f)
+    ;; only initialize the slider based on the user's program 
+    ;; when there aren't any exceptions.
+    ;; if there are exceptions, wait for the user to click
+    ;; "convert" to see an error.
+    (with-handlers ([exn:fail? (lambda (x) (void))])
+      (send sliderC set-value (in-slider-range (fahr->cel F-SLI-0))))
+    (send frame show #t))
+  
+  ;; ============================================================================
+  ;; convert-repl : (num -> num) -> void
+  ;; to start a read-eval-print loop that reads numbers [temp in F], applies f, and prints 
+  ;; the result; effects: read and write; 
+  ;; exit on x as input
+  (define (convert-repl f)
+    (check-proc 'convert-repl f 1 "convert-repl" "one argument")
+    (let repl ()
+      (begin
+        (printf "Enter Fahrenheit temperature and press <enter> [to exit, type x]: ")
+        (flush-output)
+        (let* ([ans (read)])
+          (cond
+            [(or (eof-object? ans) (eq? ans 'x)) (void)]
+            [(not (number? ans))
+             (printf "The input must be a number. Given: ~s~n" ans) (repl)]
+            [(number? ans) 
+             (let ([res (f ans)])
+               (if (number? res)
+                   (printf "~sF corresponds to ~sC~n" ans res) 
+                   (error 'convert OUT-ERROR res))
+               (repl))]
+            [else (error 'convert "can't happen")])))))
+  
+  ;; ============================================================================
+  
+  ;; make-reader-for-f : (number -> number) -> ( -> void)
+  ;; make-reader-for-f creates a function that reads numbers from a file
+  ;; converts them accoring to f, and prints the results
+  ;; effect: if any of the S-expressions in the file aren't numbers or
+  ;;         if any of f's results aren't numbers,
+  ;;         the function signals an error
+  (define (make-reader-for f)
+    (local ((define (read-until-eof)
+              (let ([in (read)])
+                (cond
+                  [(eof-object? in) (void)]
+                  [(number? in) (begin (check-and-print (f in)) (read-until-eof))]
+                  [else (error 'convert "The input must be a number. Given: ~e~n" in)])))
+            (define (check-and-print out)
+              (cond
+                [(number? out) (printf "~s~n" out)]
+                [else (error 'convert OUT-ERROR out)])))
+      read-until-eof))
+  
+  ;; convert-file : str (num -> num) str -> void
+  ;; to read a number from file in, to convert it with f, and to write it to out
+  (define (convert-file in f out)
+    (check-arg 'convert-file (string? in) "string" "first" in)
+    (check-arg 'convert-file (file-exists? in) 
+               (format "name of existing file in ~a" (current-directory))
+               "first" in)
+    (check-proc 'convert-file f 1 "convert-file" "one argument")
+    (check-arg 'convert-file (string? out) "string" "third" out)
+    (when (file-exists? out)
+      (delete-file out))
+    (with-output-to-file out
+      (lambda () (with-input-from-file in (make-reader-for f)))))
+  )
diff --git a/collects/htdp/dir.ss b/collects/htdp/dir.ss
new file mode 100644
index 0000000000..a27d414a15
--- /dev/null
+++ b/collects/htdp/dir.ss
@@ -0,0 +1,80 @@
+#cs(module dir mzscheme
+  (require (lib "error.ss" "htdp")
+           (lib "list.ss")
+           (lib "prim.ss" "lang"))
+  
+  (provide
+   create-dir ; path -> Directory
+   
+   ; structure 
+   dir?
+   make-dir
+   dir-name
+   dir-dirs
+   dir-files
+   
+   ; structure 
+   file?
+   make-file
+   file-name
+   file-content
+   (rename file--size file-size)
+   )
+  
+  ;; Structures: 
+  (define-struct dir (name dirs files))
+  (define-struct file (name -size content))
+  
+  (define-primitive create-dir create-dir/proc)
+  
+  ;; Data:
+  ;; Directory  = (make-dir Symbol (listof Dir) (listof File))
+  ;; File       = (make-file Symbol Number (union '() X))
+  
+  (define (create-dir/proc a-path)
+    (check-arg 'create-dir (string? a-path) "string" "first" a-path)
+    (if (directory-exists? a-path)
+        (car (explore (list a-path)))
+        (error 'create-dir "not a directory: ~e" a-path)))
+  
+  ;; explore : (listof String[directory-names]) -> (listof Directory)
+  (define (explore dirs)
+    (map (lambda (d) 
+           (let-values ([(fs ds) (pushd d directory-files&directories)]) 
+             (make-dir
+              (string->symbol (my-split-path d))
+              (explore (map (lambda (x) (build-path d x)) ds))
+              (map make-file
+                   (map string->symbol fs)
+                   (map (lambda (x) (if (file-exists? x) (file-size x) 0))
+			(map (lambda (x) (build-path d x)) fs))
+                   (map (lambda (x) (if (link-exists? x) 'link null)) fs)))))
+         dirs))
+  
+  ;; String -> String
+  (define (my-split-path d)
+    (let-values ([(base name mbd?) (split-path d)])
+      (if (string? base) name d)))
+  
+  ;; pushd : String[directory-name] (-> X) -> X
+  (define (pushd d f)
+    (parameterize ([current-directory d])
+      (f)))
+  
+  ;; directory-files&directories : 
+  ;;  (-> (values (listof String[file-names]) (listof String[directory-names])))
+  (define (directory-files&directories)
+    (let ((contents (directory-list)))
+      (values
+       (filter (lambda (x) (or (file-exists? x) (link-exists? x))) contents)
+       (filter (lambda (x) (and (directory-exists? x) (not (link-exists? x))))
+               contents))))
+  
+  ;; get-file-content : file -> (int -> string)
+  ;; to read a file on demand as a string
+  ;; option to expand the library ... 
+  ;; cache it ... 
+  (define (get-file-content f)
+    (read-string (file--size f) 
+                 (open-input-file (symbol->string (file-name f)))))
+  )
diff --git a/collects/htdp/docs.ss b/collects/htdp/docs.ss
new file mode 100644
index 0000000000..48cafb1e63
--- /dev/null
+++ b/collects/htdp/docs.ss
@@ -0,0 +1,104 @@
+#cs(module docs mzscheme
+  (require (lib "error.ss" "htdp")
+           (lib "list.ss")
+	   (lib "prim.ss" "lang"))
+  
+  (provide
+   atom?
+   annotation?
+   end-annotation
+   write-file
+   )
+  
+  (define-primitive atom? atom?/proc)
+  (define-primitive annotation? annotation?/proc)  
+  (define-primitive end-annotation? end-annotation?/proc)
+  (define-primitive write-file write-file/proc)
+
+  ;; mk-annotation : 
+  ;;  (str number[str-lenght] -> bool) -> (any-value -> bool)
+  (define (mk-annotation test)
+    (lambda (val)
+      (and (symbol? val) 
+           (let ((str (symbol->string val)))
+             (test str (sub1 (string-length str)))))))
+  
+  ;; annotation? : any-value -> bool
+  (define annotation?/proc
+    (mk-annotation (lambda (str E);; str : string, E : integer
+                     (and (> E 1) 
+                          (eqv? (string-ref str 0) #\<)
+                          (eqv? (string-ref str E) #\>)))))
+  
+  ;; end-annotation? : any-value -> bool
+  (define end-annotation?/proc
+    (mk-annotation (lambda (str E);; str : string, E : integer 
+                     (and (> E 2)
+                          (eqv? (string-ref str 0) #\<)
+                          (eqv? (string-ref str 1) #\/)
+                          (eqv? (string-ref str E) #\>)))))
+  
+  ;; end-annotation : annotation -> end-annotation
+  (define (end-annotation ann)
+    (check-arg 'end-annotation (annotation? ann) "annotation (str)" "first" ann)
+    (let ((str (symbol->string ann))) 
+      (string->symbol
+       (string-append "</" (substring str 1 (string-length str))))))
+  
+  ;; line-breaking? : any-value -> bool
+  (define (line-breaking? x)
+    (and (annotation? x) (memq x LNBRK) #t))
+  
+  (define LNBRK 
+    (let ((x '(<html> <title> <body> <table> <ol> <li> <tr>)))
+      (append x (map end-annotation x))))
+  
+  ;; where to break lines in write-file
+  (define MAX-COLUMN 80)
+  
+  ;; atom? : TSV -> boolean
+  ;; to determine whether x is a symbol, number, or string
+  (define (atom?/proc x)
+    (or (symbol? x) (number? x) (string? x)))
+  
+  ;; write-file : list-of-atom [file-name] -> void
+  ;; effect: write los to file-name, in small column width
+  ;;   delete file-name if it exists
+  (define (write-file/proc  los . file-name)
+    ;; the-port : an output port, 
+    ;;   determined from the optional second argument
+    (define the-port
+      (if (null? file-name)
+          (current-output-port)
+          (let ((the-name (car file-name)))
+            (check-arg 'write-file 
+                       (string? the-name)
+                       "string" "(optional) second" 
+                       the-name)
+            (when (file-exists? the-name)
+              (delete-file the-name))
+            (open-output-file the-name))))
+    
+    (check-arg 'write-file
+               (and (list? los) (andmap atom? los)) "list of symbols" "first" los)
+    ;; --- the LOOP ---
+    (let loop ((i 0) (los los))
+      (if (null? los) (newline the-port)
+	  (let* ((wrd (first los))
+		 (str (format "~a" wrd))
+		 (j   (+ i (string-length str) 1)))
+	    (cond
+	      ((> i MAX-COLUMN)      (newline the-port) 
+	       (loop 0 los))
+	      ((line-breaking? wrd)  (newline the-port) 
+               (display wrd the-port) 
+               (newline the-port)
+               (loop j (rest los)))
+              
+	      (else                  (display wrd the-port)
+                                     (display #\SPACE the-port)
+                                     (loop j (rest los)))))))
+    (when (cons? file-name)
+      (close-output-port the-port)))
+  
+  )
diff --git a/collects/htdp/draw-sig.ss b/collects/htdp/draw-sig.ss
new file mode 100644
index 0000000000..acb9a0e41b
--- /dev/null
+++ b/collects/htdp/draw-sig.ss
@@ -0,0 +1,29 @@
+#cs(module draw-sig mzscheme
+  (provide core-draw^ draw^)
+  (require (lib "unitsig.ss"))
+  
+;; xxx-solid-rect cannot be called xxx-solid-rectangle because that
+;; interferes with the existing xxx-solid-rectangle name in our unit
+;; calculus -- mf 
+
+  (define-signature core-draw^
+       (start 
+        start/cartesian-plane
+        stop 
+        draw-circle draw-solid-disk draw-solid-rect draw-solid-line
+	draw-solid-string
+        clear-circle clear-solid-disk clear-solid-rect clear-solid-line
+	clear-solid-string
+        clear-all
+        sleep-for-a-while
+        wait-for-mouse-click ; -> posn
+        get-key-event   ; -> (union #f char symbol)
+	get-mouse-event ; -> (union #f posn)
+        get-@VP        
+        big-bang        ; World -> true
+        on-key-event    ; (union char symbol) World -> World 
+        on-tick-event   ; World -> World 
+        end-of-time     ; -> World
+        ))
+  
+  (define-signature draw^ core-draw^))
diff --git a/collects/htdp/draw.ss b/collects/htdp/draw.ss
new file mode 100644
index 0000000000..452e44ea80
--- /dev/null
+++ b/collects/htdp/draw.ss
@@ -0,0 +1,23 @@
+#cs(module draw mzscheme
+  (require (lib "big-draw.ss" "htdp")
+           (lib "draw-sig.ss" "htdp")
+           (lib "unitsig.ss"))
+
+     (define-syntax (draw s)
+       (syntax-case s (produce)
+         [(_ stmt ... produce exp) (syntax (begin (and stmt ...) exp))]
+         [(_ stmt ... produce) 
+          (raise-syntax-error #f "produce must be followed by an expression" s)]
+         [(_ stmt ... produce exp exp2)
+          (raise-syntax-error #f "produce must be followed by exactly one expression" s)]
+         [(_ stmt ... produce exp exp2 exp3)
+          (raise-syntax-error #f "produce must be followed by exactly one expression" s)]
+         [(_ stmt ...)
+          (raise-syntax-error #f "use drawing instructions between _draw_ and _produce_ and an expression behind produce" s)]
+         ))
+     
+     (provide 
+      draw ;; (draw <expression> ... produce <expression>)
+      )
+
+     (provide-signature-elements draw^))
diff --git a/collects/htdp/elevator.ss b/collects/htdp/elevator.ss
new file mode 100644
index 0000000000..ed9524f15e
--- /dev/null
+++ b/collects/htdp/elevator.ss
@@ -0,0 +1,818 @@
+#cs(module elevator mzscheme
+  (require (lib "big-draw.ss" "htdp")
+	   (lib "error.ss" "htdp")
+	   (lib "posn.ss" "lang")
+           (lib "etc.ss")
+           (lib "mred.ss" "mred")
+           (lib "prim.ss" "lang"))
+
+  ;; Implementation:
+  ;;   Stephanie Weirich (1994),
+  ;;   Mark Krentel (1995),
+  ;;   Matthias Felleisen (1996)
+
+  (provide run)
+  
+  (define-higher-order-primitive run run/proc (elevator-controller))
+
+    ;;  There are really  three distinct levels: graphics, hardware,
+    ;;  and software. Don't mix them!
+
+    ;;
+    ;;  HARDWARE/GRAPHICS level for Elevator.
+    ;;  This level provides the basic primitives for writing an elevator.
+    ;;  The hardware level are the guards for the graphics level.
+    ;;
+    ;;  Hardware functions:
+    ;;
+    ;;     make-elevator  max-floor
+    ;;     current-floor  move-up-floor    move-down-floor
+    ;;     update-input   wait-for-input
+    ;;     open?          open-doors       close-doors
+    ;;     up-call?       down-call?       demand?
+    ;;     clear-up-call  clear-down-call  clear-demand
+    ;;     busy-wait      info
+    ;;
+
+    ;;  Compute the layout and draw the window.
+
+    (define  init-graphics
+      (lambda  ()
+	(init-layout-and-window)
+	(init-shaft)
+	(init-calls)
+	(init-info)
+	(init-demands)
+	(init-stop)
+	(init-car)
+	(busy-wait  800)
+	(draw-open-doors)))
+
+    ;;
+    ;;  Overall layout for the window.
+    ;;  Currently need max-floor >= 4.
+    ;;
+
+    (define  BORDER  100)
+    (define  SHAFT-INFO-GAP   40)
+    (define  STOP-DEMAND-GAP  50)
+
+    (define  init-layout-and-window
+      (lambda  ()
+	(let* 
+	  ([shaft  (make-posn  BORDER  BORDER)]
+	   [call   (add-hv  shaft  SHAFT-WIDTH  0)]
+	   [top    (add-hv  call  CALL-WIDTH  0)]
+	   [bot    (add-hv  top  0  (* (max-floor) FLOOR-SIZE))]
+	   [info   (add-hv  top  SHAFT-INFO-GAP  0)]
+	   [stop   (add-hv  bot  SHAFT-INFO-GAP  (- STOP-HEIGHT))]
+	   [demand (add-hv  stop  0  (- 0 STOP-DEMAND-GAP DEMAND-HEIGHT))]
+	   [horiz  (+  (posn-x info)  STOP-WIDTH  BORDER)]
+	   [vert   (+  (posn-y bot)  BORDER)])
+	  (set!  SHAFT-ORIGIN   shaft)
+	  (set!  CALL-ORIGIN    call)
+	  (set!  INFO-ORIGIN    info)
+	  (set!  STOP-ORIGIN    stop)
+	  (set!  DEMAND-ORIGIN  demand)
+	  (init-window  horiz  vert))))
+
+    ;;
+    ;;  Window primitives for lines, strings, mouse clicks.
+    ;;  These should be the only functions that use elev-win.
+    ;;
+
+    (define  elev-win  #f)
+    (define  d-line    #f)
+    (define  c-line    #f)
+    (define  d-string  #f)
+    (define  c-string  #f)
+    (define  mouse-click?    (lambda () (ready-mouse-click elev-win)))
+    (define  wait-for-click  (lambda () (get-mouse-click elev-win)))
+
+    (define  init-window
+      (lambda  (horiz  vert)
+	(set!  elev-win  (open-viewport "Elevator Simulation" horiz vert))
+	(set!  d-line  (draw-line  elev-win))
+	(set!  c-line  (clear-line  elev-win))
+	(set!  d-string  (draw-string  elev-win))
+	(set!  c-string  (clear-string  elev-win))))
+
+    (define  d-string-bf
+      (lambda  (posn  string)
+	(d-string  posn  string)
+	(d-string  (add-hv posn 1 0)  string)))
+
+    (define  c-string-bf
+      (lambda  (posn  string)
+	(c-string  posn  string)
+	(c-string  (add-hv posn 1 0)  string)))
+
+    ;;
+    ;;  Helper functions for position, offsets, etc.
+    ;;  SIXLib should provide better primitives here.
+    ;;
+
+    (define  under?   (lambda  (p1  p2)  (>  (posn-y p1)  (posn-y p2))))
+
+    (define  add-posn
+      (lambda  (p1  p2)
+	(make-posn  (+  (posn-x p1)  (posn-x p2))
+	  (+  (posn-y p1)  (posn-y p2)))))
+
+    (define  add-hv
+      (lambda  (p  horiz  vert)
+	(make-posn  (+  (posn-x p)  horiz) 
+	  (+  (posn-y p)  vert))))
+
+    ;;
+    ;;  Low-level primitives for lines, rectangles, etc.
+    ;;
+        
+    (define  paint-rect
+      (lambda  (origin  horiz  vert)
+	(when  (>= vert 0)
+	  (let ([right  (add-hv origin horiz 0)]
+		[next   (add-hv origin 0 +1)])
+	    (d-line  origin  right)
+	    (paint-rect  next  horiz  (- vert 1))))))
+
+    (define  outline-rect
+      (lambda  (origin  horiz  vert  thick)
+	(let* ([x0  (posn-x origin)]  [y0  (posn-y origin)])
+	  (recur  loop  ([lf   x0]  [rt   (+ x0 horiz thick -1)]
+			 [top  y0]  [bot  (+ y0 vert  thick -1)]
+			 [n  thick])
+	    (when  (> n 0)
+	      (d-line  (make-posn lf top)  (make-posn rt top))
+	      (d-line  (make-posn rt top)  (make-posn rt bot))
+	      (d-line  (make-posn rt bot)  (make-posn lf bot))
+	      (d-line  (make-posn lf bot)  (make-posn lf top))
+	      (loop  (+ lf 1)  (- rt 1)  (+ top 1)  (- bot 1)  (- n 1)))))))
+
+    (define  clear-inside-rect
+      (lambda  (origin  horiz  vert  thick)
+	(recur  loop  ([lf  (add-hv origin thick thick)]
+		       [rt  (add-hv origin (- horiz 1) thick)]
+		       [n  thick])
+	  (when  (< n vert)
+	    (c-line  lf  rt)
+	    (loop  (add-hv lf 0 +1)  (add-hv rt 0 +1) (+ n 1))))))
+
+    ;;
+    ;;  Elevator Shaft and Car 
+    ;;
+
+    (define  SHAFT-ORIGIN #f)
+    (define  STOP-ORIGIN  #f)
+    (define  SHAFT-WIDTH  64)
+    (define  FLOOR-SIZE   64)
+    (define  CAR-WIDTH    44)
+    (define  CAR-HEIGHT   44)
+    (define  MIN-DOOR-SEP  3)
+    (define  NUMBER-POSN  (make-posn -22 (floor (/ FLOOR-SIZE 2))))
+
+    (define  init-shaft
+      (lambda  ()
+	(let ([height  (* (max-floor) FLOOR-SIZE)])
+	  (outline-rect  SHAFT-ORIGIN  SHAFT-WIDTH  height  2)
+	  (recur  loop  ([p  (add-posn SHAFT-ORIGIN NUMBER-POSN)]
+			 [n  (max-floor)])
+	    (when  (>= n 1)
+	      (d-string-bf  p  (number->string n))
+	      (loop  (add-hv p 0 FLOOR-SIZE)  (- n 1)))))))
+
+    (define  init-car
+      (lambda  ()
+	(let* ([origin  (car-posn 1)])
+	  (outline-rect  origin  CAR-WIDTH  CAR-HEIGHT  1)
+	  (outline-rect  origin  (floor (/ CAR-WIDTH 2))  CAR-HEIGHT  1))))
+
+    (define  car-posn
+      (lambda  (n)
+	(add-hv  SHAFT-ORIGIN
+	  (floor (/ (- SHAFT-WIDTH CAR-WIDTH) 2))
+	  (+  (floor (/ (- FLOOR-SIZE  CAR-HEIGHT) 2))
+	     (*  (- (max-floor) n)  FLOOR-SIZE)))))
+
+    (define  move-car-door
+      (lambda  (horiz  delta)
+	(let* ([origin   (car-posn (current-floor))]
+	       [old-top  (add-hv origin horiz +1)]
+	       [old-bot  (add-hv origin horiz (- CAR-HEIGHT 1))]
+	       [new-top  (add-hv old-top delta 0)]
+	       [new-bot  (add-hv old-bot delta 0)])
+	  (d-line  new-top  new-bot)
+	  (c-line  old-top  old-bot))))
+
+    (define  draw-open-doors
+      (lambda  ()
+	(recur  loop  ([lf  (floor   (/ CAR-WIDTH 2))]
+		       [rt  (ceiling (/ CAR-WIDTH 2))])
+	  (when  (<  MIN-DOOR-SEP  lf)
+	    (move-car-door  lf  -1)
+	    (move-car-door  rt  +1)
+	    (busy-wait)
+	    (loop  (- lf 1)  (+ rt 1))))
+	(draw-little-man)))
+
+    (define  draw-close-doors
+      (lambda  ()
+	(recur  loop  ([lf  MIN-DOOR-SEP]
+		       [rt  (- CAR-WIDTH MIN-DOOR-SEP)])
+	  (when  (>=  (- rt lf)  2)
+	    (move-car-door  lf  +1)
+	    (move-car-door  rt  -1)
+	    (busy-wait)
+	    (loop  (+ lf 1)  (- rt 1))))))
+
+    (define  move-fwd-edge
+      (lambda  (origin  delta)
+	(let* ([new-lf  (add-hv origin 0 delta)]
+	       [new-rt  (add-hv origin CAR-WIDTH delta)]
+	       [old-1-lf  (add-hv origin +1 0)]
+	       [old-1-rt  (add-hv origin (- (floor (/ CAR-WIDTH 2)) 1) 0)]
+	       [old-2-lf  (add-hv origin (+ (ceiling (/ CAR-WIDTH 2)) 1) 0)]
+	       [old-2-rt  (add-hv origin (- CAR-WIDTH 1) 0)])
+	  (d-line  new-lf  new-rt)
+	  (c-line  old-1-lf  old-1-rt)
+	  (c-line  old-2-lf  old-2-rt))))
+
+    (define  move-back-edge
+      (lambda  (origin  delta)
+	(let*  ([new-lf  (add-hv origin 0 delta)]
+		[new-rt  (add-hv origin CAR-WIDTH delta)]
+		[old-lf  origin]
+		[old-rt  (add-hv origin CAR-WIDTH 0)])
+	  (d-line  new-lf  new-rt)
+	  (c-line  old-lf  old-rt))))
+
+    (define  draw-up-floor
+      (lambda  ()
+	(let ([goal  (car-posn (+ (current-floor) 1))])
+	  (recur  loop  ([cur  (car-posn (current-floor))])
+	    (when  (under?  cur  goal)
+	      (move-fwd-edge  cur  -1)
+	      (move-back-edge  (add-hv cur 0 CAR-HEIGHT)  -1)
+	      (busy-wait)
+	      (loop  (add-hv cur 0 -1)))))))
+
+    (define  draw-down-floor
+      (lambda  ()
+	(let ([goal  (car-posn (- (current-floor) 1))])
+	  (recur  loop  ([cur  (car-posn (current-floor))])
+	    (when  (under?  goal  cur)
+	      (move-fwd-edge  (add-hv cur 0 CAR-HEIGHT)  +1)
+	      (move-back-edge  cur  +1)
+	      (busy-wait)
+	      (loop  (add-hv cur 0 +1)))))))
+
+    ;;  This is probably going too far ...
+    ;;  But he's more than just a list of lines!
+
+    (define  MAN-POSN  (make-posn 18 14))
+
+    (define  LITTLE-MAN
+      (list  (make-posn 5 0)   (make-posn 9 0)    ; head
+	(make-posn 9 0)   (make-posn 9 4)
+	(make-posn 9 4)   (make-posn 5 4)
+	(make-posn 5 4)   (make-posn 5 0)
+	(make-posn 7 4)   (make-posn 7 12)   ; body
+	(make-posn 7 12)  (make-posn 2 23)   ; legs
+	(make-posn 7 12)  (make-posn 12 23)
+	(make-posn 0 23)  (make-posn 2 23)   ; feet
+	(make-posn 12 23) (make-posn 14 23)
+	(make-posn 1 8)   (make-posn 13 8)   ; arms
+	(make-posn 0 9)   (make-posn 1 8)    ; hands
+	(make-posn 13 8)  (make-posn 14 7)))
+
+    (define  draw-little-man
+      (lambda  ()
+	(let ([origin  (add-posn (car-posn (current-floor)) MAN-POSN)])
+	  (recur  loop  ([l  LITTLE-MAN])
+	    (unless  (null? l)
+	      (d-line  (add-posn  origin  (car l))  
+		(add-posn  origin  (cadr l)))
+	      (loop  (cddr l)))))))
+
+    ;;
+    ;;  Call Buttons 
+    ;;
+
+    (define  CALL-ORIGIN  #f)
+    (define  CALL-WIDTH   50)
+    (define  CALL-HEIGHT  (floor (/ FLOOR-SIZE 2)))
+
+    (define  UP-CALL-SHAPE  
+      (list  (make-posn 13 28)  (make-posn 25 4)   (make-posn 37 28)))
+    (define  DOWN-CALL-SHAPE
+      (list  (make-posn 13 4)   (make-posn 25 28)  (make-posn 37 4)))
+
+    (define  UP-CALL-POSN
+      (lambda  (floor)
+	(add-hv  CALL-ORIGIN  0  (* FLOOR-SIZE (- (max-floor) floor)))))
+
+    (define  DOWN-CALL-POSN
+      (lambda  (floor)  
+	(add-hv  (UP-CALL-POSN floor)  0  CALL-HEIGHT)))
+
+    (define  init-calls
+      (lambda  ()
+	(recur  loop  ([n  1])
+	  (when  (<=  n  (max-floor))
+	    (outline-rect  (UP-CALL-POSN n)  CALL-WIDTH  FLOOR-SIZE  2)
+	    (outline-call  (UP-CALL-POSN n)  UP-CALL-SHAPE)
+	    (outline-call  (DOWN-CALL-POSN n)  DOWN-CALL-SHAPE)
+	    (loop  (+ n 1))))))
+
+    (define  draw-clear-up
+      (lambda  (floor)
+	(clear-call    (UP-CALL-POSN floor)  UP-CALL-SHAPE)
+	(outline-call  (UP-CALL-POSN floor)  UP-CALL-SHAPE)))
+
+    (define  draw-clear-down
+      (lambda  (floor)
+	(clear-call    (DOWN-CALL-POSN floor)  DOWN-CALL-SHAPE)
+	(outline-call  (DOWN-CALL-POSN floor)  DOWN-CALL-SHAPE)))
+
+    (define  paint-up-call
+      (lambda  (floor)
+	(paint-call  (UP-CALL-POSN floor)  UP-CALL-SHAPE)))
+
+    (define  paint-down-call
+      (lambda  (floor)
+	(paint-call  (DOWN-CALL-POSN floor)  DOWN-CALL-SHAPE)))
+
+    (define  outline-call
+      (lambda  (origin  l)
+	(let* ([p  (add-posn origin (car l))]
+	       [q  (add-posn origin (cadr l))] 
+	       [r  (add-posn origin (caddr l))])
+	  (d-line  p  q)
+	  (d-line  q  r)
+	  (d-line  r  p))))
+
+    (define  clear-call
+      (lambda  (origin  l)
+	(let* ([p  (add-posn origin (car l))]
+	       [q  (add-posn origin (cadr l))] 
+	       [r  (add-posn origin (caddr l))]
+	       [top  (min (posn-y p) (posn-y q))]
+	       [bot  (max (posn-y p) (posn-y q))])
+	  (recur  loop  ([y  (+ top 1)])
+	    (when  (< y bot)
+	      (let ([lf  (ceiling (x-val p q y))]
+		    [rt  (floor   (x-val q r y))])
+		(c-line  (make-posn lf y)  (make-posn rt y))
+		(loop  (+ y 1))))))))
+
+    (define  paint-call
+      (lambda  (origin  l)
+	(let* ([p  (add-posn origin (car l))]
+	       [q  (add-posn origin (cadr l))] 
+	       [r  (add-posn origin (caddr l))]
+	       [top  (min (posn-y p) (posn-y q))]
+	       [bot  (max (posn-y p) (posn-y q))])
+	  (recur  loop  ([y  (+ top 1)])
+	    (when  (< y bot)
+	      (let ([lf  (ceiling (x-val p q y))]
+		    [rt  (floor   (x-val q r y))])
+		(d-line  (make-posn lf y)  (make-posn rt y))
+		(loop  (+ y 1))))))))
+
+    (define  x-val
+      (lambda  (a  b  y)
+	(let ([ax  (posn-x a)]  [ay  (posn-y a)]
+	      [bx  (posn-x b)]  [by  (posn-y b)])
+	  (+  ax  (*  (/  (-  y  ay)  (-  by  ay))
+		     (-  bx  ax))))))
+
+    ;;
+    ;;  Demand Buttons
+    ;;
+
+    (define  DEMAND-ORIGIN  #f)
+    (define  DEMAND-WIDTH   40)
+    (define  DEMAND-HEIGHT  40)
+    (define  DEMAND-TEXT  (make-posn 18 25))
+
+    (define  DEMAND-POSN
+      (let ([HORIZ  (+ DEMAND-WIDTH 20)]  
+	    [VERT   (+ DEMAND-HEIGHT 20)])
+	(lambda  (i)
+	  (let ([x  (remainder (sub1 i) 2)]
+		[y  (quotient  (sub1 i) 2)])
+	    (add-hv  DEMAND-ORIGIN  (* x HORIZ)  (* -1 y VERT))))))
+
+    (define  init-demands
+      (lambda  ()
+	(recur  loop  ([n  1])
+	  (when  (<= n (max-floor))
+	    (outline-rect  (DEMAND-POSN n)  DEMAND-WIDTH  DEMAND-HEIGHT  2) 
+	    (d-string-bf  (add-posn (DEMAND-POSN n) DEMAND-TEXT)  (number->string n))
+	    (loop  (+ n 1))))))
+
+    (define  paint-demand
+      (lambda  (k)
+	(let ([nw  (DEMAND-POSN k)])
+	  (paint-rect  nw  DEMAND-WIDTH  DEMAND-HEIGHT)
+	  (c-string-bf  (add-posn nw DEMAND-TEXT)  (number->string k)))))
+
+    (define  draw-clear-demand
+      (lambda  (k)
+	(clear-inside-rect  (DEMAND-POSN k)  DEMAND-WIDTH  DEMAND-HEIGHT  2)
+	(d-string-bf  (add-posn (DEMAND-POSN k) DEMAND-TEXT)  (number->string k))))
+
+    ;;
+    ;;  "Stop Program" Button
+    ;;
+
+    (define  STOP-WIDTH  100)
+    (define  STOP-HEIGHT  40)
+    (define  STOP-TEXT  (make-posn 15 25))
+
+    (define  init-stop
+      (lambda  ()
+	(outline-rect  STOP-ORIGIN  STOP-WIDTH  STOP-HEIGHT  2)
+	(d-string  (add-posn STOP-ORIGIN STOP-TEXT)  "Stop Program")))
+
+    ;;
+    ;;  Mouse Clicks
+    ;;  Look for up/down calls, demands and stop-program button.
+    ;;  If you can get access to a real-time clock, then change the
+    ;;  delay loop to use sleep-for or real-time.
+    ;;  The units are (fake) milliseconds.
+    ;;  SCALE is the multiplier for waiting time.
+    ;;  SCALE > 1 slows down the simulation.
+    ;;
+
+    (define  DEFAULT-WAIT    25) 
+    (define  SCALE  0.75)
+
+    (define  busy-wait
+      (lambda  l
+	(let* ([cur-time   (current-milliseconds)]
+	       [wait-time  (if (null? l) DEFAULT-WAIT (car l))]
+	       [new-time   (+ cur-time (* SCALE wait-time))])
+	  (recur  loop  ()
+	    (check-buttons)
+	    (yield)
+	    (when (< (current-milliseconds) new-time)
+	      (loop))))))
+      
+    (define  check-buttons
+      (lambda  ()
+	(let ([click  (mouse-click?)])
+	  (when  click
+	    (process-click  click)
+	    (check-buttons)))))
+
+    (define  wait-for-button
+      (lambda  ()
+	(let ([click  (wait-for-click)])
+	  (process-click  click)
+	  (check-buttons))))
+
+    (define  process-click
+      (lambda  (click)
+	(recur  loop  ([n  1])
+	  (cond
+	    [(>  n  (max-floor))  (void)]
+	    [(click-here? click (UP-CALL-POSN n) CALL-WIDTH CALL-HEIGHT)
+	     (push-up-call  n)]
+	    [(click-here? click (DOWN-CALL-POSN n) CALL-WIDTH CALL-HEIGHT)
+	     (push-down-call  n)]
+	    [(click-here? click (DEMAND-POSN n) DEMAND-WIDTH DEMAND-HEIGHT)
+	     (push-demand  n)]
+	    [(click-here? click STOP-ORIGIN STOP-WIDTH STOP-HEIGHT)
+	     (push-stop)]
+	    [else  (loop (+ n 1))]))))
+
+    (define  click-here?
+      (lambda  (click  origin  horiz  vert)
+	(let* ([x0  (posn-x origin)]
+	       [y0  (posn-y origin)]
+	       [x   (posn-x (mouse-click-posn click))]
+	       [y   (posn-y (mouse-click-posn click))])
+	  (and  (<= x0 x (+ x0 horiz))
+            (<= y0 y (+ y0 vert))))))
+
+    ;;
+    ;;  Info
+    ;;  Just floor, goal, dir. 
+    ;;
+
+    (define  INFO-ORIGIN  #f)
+    (define-struct einfo  (sym  posn  label  prev))
+
+    (define  INFO-LIST
+      (list  (make-einfo  'floor  (make-posn 0 12)   "floor = "  #f)
+	(make-einfo  'goal   (make-posn 0 28)  "goal = "   #f)
+	(make-einfo  'dir    (make-posn 0 44)  "dir = "    #f)))
+
+    (define  init-info
+      (lambda  ()
+	(let  loop  ([l  INFO-LIST])
+	  (unless  (null? l)
+	    (set-einfo-prev!  (car l)  "")
+	    (loop  (cdr l))))
+	(info  'floor  1)
+	(info  'goal  1)
+	(info  'dir  'none)))
+
+    (define  my-lookup
+      (lambda  (sym)
+	(let  loop  ([l  INFO-LIST])
+	  (cond
+	    [(null? l)  (error 'info "Unknown info type: ~e" sym)]
+	    [(eq? sym (einfo-sym (car l)))  (car l)]
+	    [else  (loop  (cdr l))]))))
+
+    (define  info
+      (lambda  (sym  obj)
+	(let* ([item  (my-lookup sym)]
+	       [posn  (add-posn  INFO-ORIGIN  (einfo-posn item))]
+	       [str   (if (string? obj) obj (format "~s" obj))]
+	       [full-str  (string-append (einfo-label item) str)])
+	  (unless  (string=?  full-str  (einfo-prev item))
+	    (c-string  posn  (einfo-prev item))
+	    (d-string  posn  full-str)
+	    (set-einfo-prev!  item  full-str)))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    ;;                                           ;;
+    ;;  Functions to show to the outside world.  ;;
+    ;;                                           ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+    ;;  This is really the (virtual) elevator hardware level.
+    ;;  This includes state and the basic elevator operations.
+    ;;  You write an elevator from these primitives.
+    ;;
+    ;;  This could be a separate module, but you'd just write all of
+    ;;  these functions twice.  Also, they make nice guards for the
+    ;;  graphics functions.
+
+    ;;  Elevator State
+    ;;
+    ;;  the-floor = integer 1..THE-MAX-FLOOR
+    ;;  the-doors = 'open, 'closed
+    ;;  up-call-vec, down-call-vec, demand-vec = vectors 1..THE-MAX-FLOOR
+    ;;     for buttons, #t = pushed, #f = not pushed
+
+    (define  max-floor  #f)
+    (define  the-floor  #f)
+    (define  the-doors  #f)
+    (define  up-call-vec  #f)
+    (define  down-call-vec  #f)
+    (define  demand-vec  #f)
+    (define  exit-continuation  #f)
+
+    ;;  Initialize the hardware state and draw the picture.
+    ;;  f = THE-MAX-FLOOR,  k = exit continuation
+
+    (define  make-elevator
+      (lambda  (f  k)
+	(let ([n  (add1 f)])
+	  (set!  max-floor  (lambda () f))
+	  (set!  exit-continuation  k)
+	  (set!  the-floor  1)
+	  (set!  the-doors  'open)
+	  (set!  up-call-vec    (build-vector n (lambda (i) #f)))
+	  (set!  down-call-vec  (build-vector n (lambda (i) #f)))
+	  (set!  demand-vec     (build-vector n (lambda (i) #f)))
+	  (init-graphics))))
+
+    (define  push-stop  
+      (lambda  ()  (exit-continuation  'game-over)))
+
+    ;;  Functions that use the-floor.
+    ;;  Only (move-up-floor) and (move-down-floor) are allowed to use
+    ;;  the-floor and THE-MAX-FLOOR directly.
+
+    (define  current-floor  (lambda  ()  the-floor))
+
+    (define  move-up-floor
+      (lambda  ()
+	(if  (=  the-floor  (max-floor))
+	  (error  'move-up-floor  "Elevator already at MAX-FLOOR")
+	  (begin  (info  'dir  'up)
+	    ;;  (info  'floor  (format "~s~s" the-floor '+))
+	    (when  (open?)  (close-doors))
+	    (draw-up-floor)
+	    (set!  the-floor  (add1 the-floor))
+	    (info  'floor  the-floor)))))
+
+    (define  move-down-floor
+      (lambda  ()
+	(if  (=  the-floor  1)
+	  (error  'move-down-floor  "Elevator already at ground floor")
+	  (begin  (info  'dir  'down)
+	    ;;  (info  'floor  (format "~s~s" the-floor '-))
+	    (when  (open?)  (close-doors))
+	    (draw-down-floor)
+	    (set!  the-floor  (sub1 the-floor))
+	    (info  'floor  the-floor)))))
+
+    ;;  Functions that use the-doors.
+    ;;  Again, only (open-doors) and (close-doors) are allowed to use
+    ;;  the-doors directly.
+
+    (define  open?  (lambda  ()  (eq? the-doors 'open)))
+
+    (define  open-doors
+      (lambda  ()
+	(unless  (open?)
+	  (draw-open-doors)
+	  (set!  the-doors  'open))))
+
+    (define  close-doors
+      (lambda  ()
+	(when  (open?)
+	  (draw-close-doors)
+	  (set!  the-doors  'closed))))
+
+    ;;  Functions that use buttons: up/down-calls, demands.
+    ;;  Again, these are the only functions that are allowed to use
+    ;;  up/down-calls and demands directly.
+
+    (define  up-call?    (lambda  (floor)  (vector-ref up-call-vec floor)))
+    (define  down-call?  (lambda  (floor)  (vector-ref down-call-vec floor)))
+    (define  demand?     (lambda  (floor)  (vector-ref demand-vec floor)))
+
+    (define  update-input  check-buttons)
+    (define  wait-for-input  wait-for-button)
+
+    (define  clear-up-call
+      (lambda  (floor)
+	(when  (up-call?  floor)
+	  (draw-clear-up  floor)
+	  (vector-set!  up-call-vec  floor  #f))))
+
+    (define  clear-down-call
+      (lambda  (floor)
+	(when  (down-call?  floor)
+	  (draw-clear-down  floor)
+	  (vector-set!  down-call-vec  floor  #f))))
+
+    (define  clear-demand
+      (lambda  (floor)
+	(when  (demand?  floor)
+	  (draw-clear-demand  floor)
+	  (vector-set!  demand-vec  floor  #f))))
+
+    ;;  The push functions are not visible outside, but they need to
+    ;;  be here because graphics calls them.
+
+    (define  push-up-call
+      (lambda  (floor)
+	(when  (not  (up-call? floor))
+	  (paint-up-call  floor)
+	  (vector-set!  up-call-vec  floor  #t))))
+
+    (define  push-down-call
+      (lambda  (floor)
+	(when  (not  (down-call? floor))
+	  (paint-down-call  floor)
+	  (vector-set!  down-call-vec  floor  #t))))
+
+    (define  push-demand
+      (lambda  (floor)
+	(when  (not  (demand? floor))
+	  (paint-demand  floor)
+	  (vector-set!  demand-vec  floor  #t))))
+
+
+    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    ;;                                     ;;
+    ;;  SOFTWARE level for elevator.       ;;
+    ;;                                     ;;
+    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+    ;;  Here, you design your own elevator, using the primitives from
+    ;;  the graphics-module and the user's Control function.
+
+    (define  THE-MAX-FLOOR  8)
+
+    (define  start-program
+      (lambda  ()
+	(dynamic-wind
+	  (lambda ()
+	    (unless  (graphics-open?)  (open-graphics)))
+	  (lambda ()
+	    (call/cc
+	      (lambda  (k)
+		(make-elevator  THE-MAX-FLOOR  k)
+		(elevator  'open  #f  'up))))
+	  close-graphics)
+	(void)))
+
+    ;;
+    ;;  Main Loop.
+    ;;
+    ;;  This version gives the user complete control.
+    ;;  All we do is ask the user for a goal, move one floor closer,
+    ;;  check to see if we're at the goal (stop and open doors if so),
+    ;;  and ask for another goal. 
+    ;;  Any kind of fairness or ignoring the down-calls when moving up
+    ;;  is totally up to Control.
+    ;;
+    ;;  floor, goal = integer 1..THE-MAX-FLOOR
+    ;;  state = 'arrive, 'open, 'wait, 'move
+    ;;    'arrive = just arrived at this floor, check if it's the goal
+    ;;    'open = open doors, wait, ignore goal, get new one
+    ;;    'wait = no requests, wait until there is one
+    ;;    'move = start moving toward the goal
+    ;;  dir = 'up, 'down
+    ;;
+    ;;  We call new-goal at each floor.
+    ;;
+
+    (define  OPEN-DOOR-WAIT-TIME  1500)
+
+    (define  elevator
+      (lambda  (state  goal  dir)
+	(let ([floor  (current-floor)])
+	  (cond
+	    [(eq?  state  'arrive)
+	     (if  (=  floor  goal)
+	       (elevator  'open  goal  dir)
+	       (elevator  'move  (new-goal dir)  dir))]
+	    [(eq?  state  'open) 
+	     (begin
+	       (open-doors)
+	       (clear-all-buttons  floor)
+	       (busy-wait  OPEN-DOOR-WAIT-TIME)
+	       (update-input)
+	       (clear-all-buttons  floor)
+	       (elevator  'wait  (new-goal dir)  dir))]
+	    [(eq?  state  'wait)
+	     (if  (=  floor  goal)
+	       (begin
+		 (update-input)
+		 (clear-all-buttons  floor)
+		 (wait-for-request)
+		 (elevator  'wait  (new-goal dir)  dir))
+	       (elevator  'move  goal  dir))]
+	    [(=  goal  floor)  
+	     (elevator  'open  goal  dir)]
+	    [(<  goal  floor)
+	     (begin  
+	       (move-down-floor)
+	       (elevator  'arrive  goal  'down))]
+	    [(>  goal  floor)
+	     (begin  
+	       (move-up-floor)
+	       (elevator  'arrive  goal  'up))]
+	    [else  (error 'elevator "Internal error in main loop")]))))
+
+    ;;  Don't get stuck on the same floor forever.
+
+    (define  clear-all-buttons
+      (lambda  (floor) 
+	(clear-up-call  floor)
+	(clear-down-call  floor) 
+	(clear-demand  floor)))
+
+    ;;  Don't return until at least one button is pushed.
+
+    (define  wait-for-request
+      (lambda  ()
+	(recur  loop  ([n  1])
+	  (cond
+	    [(> n (max-floor))  (wait-for-input)]
+	    [(or  (up-call? n)  (down-call? n)  (demand? n))  #t]
+	    [else  (loop  (add1 n))]))))
+
+    ;;  Call the user's function Control and check that the floor is valid.
+
+    (define  list-of-floors
+      (lambda  ()
+	(recur  loop  ([f  (max-floor)]  [l  null])
+	  (cond
+	    [(= f 0)  l]
+	    [(or (up-call? f) (down-call? f) (demand? f))
+	     (loop  (sub1 f)  (cons f l))]
+	    [else  (loop  (sub1 f)  l)]))))
+
+    (define  new-goal
+      (lambda  (dir)
+	(update-input)
+	(let 
+	  ([ans  (Next-Floor  dir (current-floor)  (list-of-floors))]) 
+	  (if  (and  (integer? ans)  (exact? ans)  (<= 1 ans (max-floor)))
+	    (begin  (info  'goal  ans)  ans)
+	    (error 'Next-Floor "~e is not a valid floor number" ans)))))
+
+    ;;  Functions to show the user.
+    ;;  Remember, the elevator calls Next-Floor, not the other way.
+
+    (define Next-Floor (lambda x (error 'Next-Floor "undefined")))
+  
+    (define  run/proc 
+      (lambda (f)
+	(check-proc 'run f 3 'first "3 arguments")
+	(set! Next-Floor f)
+	(start-program)))
+
+    )
diff --git a/collects/htdp/error.ss b/collects/htdp/error.ss
new file mode 100644
index 0000000000..ceb6e6cb92
--- /dev/null
+++ b/collects/htdp/error.ss
@@ -0,0 +1,71 @@
+#cs(module error mzscheme
+  (require (lib "etc.ss") (lib "list.ss"))
+  ;; --------------------------------------------------------------------------
+  (provide check-arg check-arity check-proc check-result check-list-list find-non
+           tp-exn? number->ord)
+
+  ;; (_ -> Boolean) (listof X) -> (union X false)
+  (define (find-non pred? l)
+    (let ([r (filter (compose not pred?) l)])
+      (if (null? r) #f (car r))))
+
+  #| Tests ------------------------------------------------------------------
+  (not (find-non list? '((1 2 3) (a b c))))
+  (symbol? (find-non number? '(1 2 3 a)))
+  (symbol? (find-non list? '((1 2 3) a (b c))))
+  |#
+
+  (define-struct (tp-exn exn) ())
+     
+  (define (tp-error name fmt . args)
+    (raise (make-tp-exn (string->immutable-string (string-append (format "~a: " name) (apply format fmt args)))
+                        (current-continuation-marks))))
+
+  (define (number->ord i)
+    (if (= i 0)
+        "zeroth"
+        (case (modulo i 10)
+          [(0 4 5 6 7 8 9) (format "~ath" i)]
+          [(1) (format "~ast" i)]
+          [(2) (format "~and" i)]
+          [(3) (format "~ard" i)])))
+     
+  ;; Symbol (union true String) String X -> void
+  (define (check-list-list pname condition pred given)
+    (when (string? condition)
+      (tp-error pname (string-append condition (format "~nin ~e" given)))))
+
+  ;; Symbol (_ -> Boolean) String X -> X 
+  (define (check-result pname pred? expected given)
+    (if (pred? given)
+	given
+	(tp-error pname "expected ~a result, given: ~e" expected given)))
+
+  ;; check-arg : sym bool str str TST -> void
+  (define (check-arg pname condition expected arg-posn given)
+    (unless condition
+      (tp-error pname "expected <~a> as ~a argument, given: ~e"
+	expected arg-posn given)))
+  
+  ;; check-arity : sym num (list-of TST) -> void
+  (define (check-arity name arg# args)
+    (if (= (length args) arg#)
+        (void)
+        (tp-error name "expects ~a arguments, given ~e" arg# (length args))))
+  
+  ;; check-proc :
+  ;;   sym (... *->* ...) num (union sym str) (union sym str) -> void
+  (define (check-proc proc f exp-arity arg# arg-err)
+    (unless (procedure? f)
+      (tp-error proc "procedure expected as ~s argument; given ~e" arg# f))
+    (unless (procedure-arity-includes? f exp-arity)
+      (let ([arity-of-f (procedure-arity f)])
+        (tp-error proc "procedure of ~a expected as ~a argument; given procedure of ~a "
+	  arg-err arg# 
+	  (cond
+	    [(number? arity-of-f)
+	     (if (= arity-of-f 1)
+		 (format "1 argument")
+		 (format "~s arguments" arity-of-f))]
+	    [(arity-at-least? arity-of-f) (format "at least ~s arguments" (arity-at-least-value arity-of-f))]
+	    [else (format "multiple arities (~s)" arity-of-f)]))))))
diff --git a/collects/htdp/graphing.ss b/collects/htdp/graphing.ss
new file mode 100644
index 0000000000..1874e36b3c
--- /dev/null
+++ b/collects/htdp/graphing.ss
@@ -0,0 +1,84 @@
+#cs(module graphing mzscheme
+  (require (lib "error.ss" "htdp")
+	   (lib "unitsig.ss")
+	   (lib "draw-sig.ss" "htdp")
+	   (lib "big-draw.ss" "htdp")
+	   (lib "posn.ss" "lang")
+           (lib "prim.ss" "lang"))
+  
+  (provide-signature-elements draw^)
+  
+  (provide 
+   graph-fun
+   graph-line
+   )
+  
+  (define-higher-order-primitive graph-line graph-line/proc (f _))
+  (define-higher-order-primitive graph-fun graph-fun/proc (f _))
+  
+  ;; --------------------------------------------------------------------------
+  
+  ;; make-graph : sym -> void
+  ;; effect: set up pasteboard for drawing functions 
+  ;;   between [0,10] and [0,10] on x/y axis 
+  (define (make-graph name)
+    (start EAST SOUTH)
+    (draw-solid-line ORIGIN X-AXIS 'blue)
+    ((draw-string #cs(get-@VP)) (make-posn (+ OFFSET 10) (+ OFFSET 10)) "Y-AXIS")
+    (draw-solid-line ORIGIN Y-AXIS 'blue)
+    ((draw-string #cs(get-@VP)) (make-posn (- EAST 100) (- SOUTH 15)) "X-AXIS"))
+  
+  ;; (num -> num) symbol -> true
+  ;; effect: draw function graph for x in [0,10] at delta = .1
+  (define (graph-line/proc f color)
+    (check 'graph-line f color)
+    (let ((p1 (translate (make-posn 0 (f 0))))
+          (p2 (translate (make-posn 10 (f 10)))))
+      (draw-solid-line p1 p2 color)))
+  
+  ;; (num -> num) symbol -> true
+  ;; effect: draw function graph for x in [0,10] at delta = .1
+  (define (graph-fun/proc f color)
+    (check 'graph-fun f color)
+    (draw-tab (map translate (tabulate f 0 10 DELTA)) color))
+  
+  ;; check : tst tst tst -> void
+  (define (check tag f color)
+    (check-proc tag f 1 '1st "one argument")
+    (check-arg tag (symbol? color) 'symbol '2nd color))
+  
+  ;; tabulate : (num -> num) num num num -> (list-of (make-posn num num))
+  (define (tabulate f left right delta)
+    (if (> left right) null
+	(cons (make-posn left (f left))
+              (tabulate f (+ left delta) right delta))))
+  
+  ;; translate : posn -> posn
+  (define (translate p)
+    (make-posn (+ (* FACT (/ 1 DELTA) (posn-x p)) OFFSET) 
+               (- (- SOUTH (* FACT (/ 1 DELTA) (posn-y p))) OFFSET)))
+  
+  ;; draw-tab : (list-of (make-posn num num)) symbol -> true
+  (define (draw-tab lop color)
+    (for-each (lambda (p) (draw-solid-disk p DOT color)) lop)
+    (unless (or (null? lop) (null? (cdr lop)))
+      (let loop ([f (car lop)][r (cdr lop)])
+        (unless (null? r) 
+          (let ([next (car r)])
+            (draw-solid-line f next color)
+            (loop next (cdr r))))))
+    #t)
+  
+  (define EAST  400)
+  (define SOUTH EAST)
+  (define FACT  (/ (- EAST 100) 100))
+  (define OFFSET   10.)
+  (define ORIGIN (make-posn OFFSET          (- SOUTH OFFSET)))
+  (define X-AXIS (make-posn OFFSET OFFSET))
+  (define Y-AXIS (make-posn (- EAST OFFSET) (- SOUTH OFFSET)))
+  (define GRAPH-COLOR 'red)
+  
+  (define DELTA .1)
+  (define DOT   1)
+  
+  (make-graph 'ok))
diff --git a/collects/htdp/guess-gui.ss b/collects/htdp/guess-gui.ss
new file mode 100644
index 0000000000..c0af5448a4
--- /dev/null
+++ b/collects/htdp/guess-gui.ss
@@ -0,0 +1,79 @@
+#cs(module guess-gui mzscheme
+  (require (lib "error.ss" "htdp")
+	   (lib "mred.ss" "mred")
+	   (lib "class.ss")
+           (lib "list.ss")
+           (lib "etc.ss")
+           (lib "prim.ss" "lang"))
+  
+  (provide
+   connect ; (button% event% -> true) -> true 
+   control ; N -> DIGIT 
+   view    ; X -> true
+   )
+  
+  (define-primitive control control/proc)
+  (define-primitive view view/proc)
+  (define-higher-order-primitive connect connect/proc (call-back))
+
+  ;; ------------------------------------------------------------------------
+  ;; Basic constants: 
+  (define TITLE "Number Guessing")
+  (define WIDTH 100)
+  (define HIGHT 80)
+  (define GUESS 3)
+  
+  ;; DIGIT = (union 0 1 2 3 4 5 6 7 8 9)
+  (define DIGITS (build-list 10 (lambda (i) (number->string i))))
+  
+  ;; ------------------------------------------------------------------------
+  ;; GUI LAYOUT 
+  (define frame (make-object frame% TITLE #f WIDTH HIGHT))
+  (define verti (make-object vertical-panel% frame))
+  (define panel (make-object horizontal-panel% verti))
+  (send panel set-alignment 'center 'center)
+  
+  ;; ------------------------------------------------------------------------
+  ;; guess : handle CONTROL
+  (define guess-panel (make-object horizontal-panel% verti '(border)))
+  (define (make-choices n)
+    (cons (make-object choice% #f DIGITS guess-panel void)
+          (cond
+            [(= n 0) empty]
+            [else (make-choices (sub1 n))])))
+  
+  (define guess-choices (make-choices (sub1 GUESS)))
+  
+  ;; control : N -> DIGIT
+  ;; to read out the i-th guess choice, starting with 0
+  (define (control/proc i)
+    (check-arg 'control
+               (and (number? i) (integer? i) (exact? i) (<= 0 i (sub1 GUESS))) 
+               (format "number in 0 ...~s" GUESS) "first" i)
+    '(if (and (number? i) (integer? i) (exact? i) (<= 0 i (sub1 GUESS)))
+         ...  
+         (printf "control: improper index, expected 0 ... ~s~n" GUESS))
+    (send (list-ref guess-choices (- GUESS i 1)) get-selection))
+  
+  ;; connect : (button% control-event% -> true) -> true
+  ;; effect: to add a check button with call-back to frame and to show frame 
+  (define check-button #f)
+  (define (connect/proc call-back)
+    (check-proc 'connect call-back 2 '1st "2 arguments")
+    (if check-button
+        (printf "connect: called a second time~n")
+        (begin
+          (set! check-button 
+                (make-object button% "Check" guess-panel call-back '(border)))
+          (send frame show #t))))
+  
+  ;; ------------------------------------------------------------------------
+  ;; message : display VIEW 
+  (define VIEW-fmt "View the result: ~a")
+  (define VIEW0 (format VIEW-fmt (make-string (* 2 GUESS) #\space)))
+  (define message-field (make-object message%  VIEW0 verti))
+  
+  ;; view : X -> void
+  ;; effect: to display n in the message panel 
+  (define (view/proc n) (send message-field set-label (format VIEW-fmt n)))
+  )
diff --git a/collects/htdp/guess.ss b/collects/htdp/guess.ss
new file mode 100644
index 0000000000..6069b16f1d
--- /dev/null
+++ b/collects/htdp/guess.ss
@@ -0,0 +1,217 @@
+#cs#cs(module guess mzscheme
+     (require (lib "error.ss" "htdp")
+              (lib "unitsig.ss")
+              (lib "etc.ss")
+              (lib "class.ss")
+              (lib "list.ss")
+              (lib "mred.ss" "mred")
+              (lib "prim.ss" "lang"))
+     
+     (provide 
+      guess-with-gui
+      guess-with-gui-3
+      guess-with-gui-list
+      )
+     
+     (define-higher-order-primitive guess-with-gui guess-with-gui/proc 
+                                    (check-guess))
+     (define-higher-order-primitive guess-with-gui-3 guess-with-gui-3/proc 
+                                    (check-guess))
+     (define-higher-order-primitive guess-with-gui-list guess-with-gui-list/proc 
+                                    (_ check-guess-list))
+     
+     
+     ;                                                                  
+     ;                                                                  
+     ;                                                                  
+     ;     ;;;;                                                         
+     ;    ;    ;                                                        
+     ;   ;                               ;                   ;          
+     ;   ;         ;;;;   ; ;;;    ;;;; ;;;;   ;;;   ; ;;;  ;;;;   ;;;; 
+     ;   ;        ;    ;  ;;   ;  ;      ;    ;   ;  ;;   ;  ;    ;     
+     ;   ;        ;    ;  ;    ;  ;      ;        ;  ;    ;  ;    ;     
+     ;   ;        ;    ;  ;    ;   ;;;   ;     ;;;;  ;    ;  ;     ;;;  
+     ;   ;        ;    ;  ;    ;      ;  ;    ;   ;  ;    ;  ;        ; 
+     ;    ;    ;  ;    ;  ;    ;      ;  ;    ;   ;  ;    ;  ;        ; 
+     ;     ;;;;    ;;;;   ;    ;  ;;;;    ;;   ;;;;; ;    ;   ;;  ;;;;  
+     ;                                                                  
+     ;                                                                  
+     ;                                                                  
+     
+     (define TITLE "Bobby's Game")
+
+     (define WELCOME "Welcome to Bobby's Game") 
+     
+     (define DIGITS (build-list 10 (lambda (i) (number->string i))))
+     
+     (define BUT-SIZE 10)
+     
+     (define WIDTH BUT-SIZE) ; (* 5 BUT-SIZE)
+     
+     (define HIGHT BUT-SIZE)
+     
+     (define STOPS (list 'Perfect 'perfect 'perfect! 'perfect_guess))
+     
+     (define TRUMPET
+       (make-object bitmap% 
+         (build-path (collection-path "icons") "trumpet.xbm")
+         'xbm))
+     
+   
+;                                     
+;                                     
+;                                     
+;     ;;;;                            
+;    ;    ;                           
+;   ;                                 
+;   ;         ;;;   ; ;;; ;;     ;;;  
+;   ;        ;   ;  ;;  ;;  ;   ;   ; 
+;   ;            ;  ;   ;   ;   ;   ; 
+;   ;     ;   ;;;;  ;   ;   ;   ;;;;; 
+;   ;     ;  ;   ;  ;   ;   ;   ;     
+;    ;    ;  ;   ;  ;   ;   ;   ;     
+;     ;;;;;   ;;;;; ;   ;   ;    ;;;; 
+;                                     
+;                                     
+;                                     
+
+     
+     
+     #| ------------------------------------------------------------------------
+     
+     ------------------------------------------------------------------
+     |       
+     |   CB1  CB2   CB3   CB4   .......   CB*   CB*   CB*   CB*   CB* 
+     | 
+     |          CB-GUESS1    ...    CB-GUESS*
+     | 
+     |                     ONE-MESSAGE
+     ------------------------------------------------------------------
+
+     Two horizontal panels: 
+       the first one with all the colors (as buttons)
+       the second is a sequence of colored buttons 
+     |#
+     
+     ;; ------------------------------------------------------------------------
+     ;; Setting up the buttons
+     
+     (define (init-game number-of-digits convert check-guess)
+       (local ((define GUESS number-of-digits)
+
+               ;; layout
+               (define frame (make-object frame% TITLE #f WIDTH HIGHT))
+
+               (define verti (make-object vertical-panel% frame))
+
+               (define panel
+                 (let ([panel (make-object horizontal-panel% verti)])
+                   (send panel set-alignment 'center 'center)
+                   panel))
+               
+               (define guess-panel
+                 (let ([guess-panel (make-object horizontal-panel% verti)])
+                   (send guess-panel set-alignment 'center 'center)
+                   guess-panel))
+               
+               (define message-panel
+                 (let ([message-panel (make-object horizontal-panel% verti)])
+                   (send message-panel set-alignment 'center 'center)
+                   message-panel))
+               
+               ;; message : a field for displaying basic messages about state of game 
+               (define message  (make-object message% WELCOME message-panel))
+               
+               ;; guesses: status vector, record the choice of digit when set
+               (define guesses (make-vector GUESS 0))
+               
+               ;; the-number : randomly chosen 
+               (define the-number 0)
+
+               ;; new-game : -> void
+               ;; effect: set up new target number, send message that game's ready 
+               (define (new-game) 
+                 (set! the-number (random (expt 10 GUESS)))
+                 (send message-panel change-children (lambda (x) (list message)))
+                 (send message set-label WELCOME))
+
+               ;; call-back : _ _ -> void
+               ;; check status and announce result, possibly set winner
+               (define (call-back x y)
+                 (let ((response (check-guess (convert guesses) the-number)))
+                   (send message set-label (symbol->string response))
+                   (when (memq response STOPS)
+                     ;; announce winner and set up new game
+                     (send message-panel change-children (lambda (x) empty))
+                     (make-object message% TRUMPET message-panel)
+                     (make-object button% "New Game?" message-panel 
+                       (lambda (x y) (new-game)))
+                     (make-object button% "CLOSE?" message-panel
+                       (lambda (x y) (send frame show #f)))))))
+         
+         ;; making the menu choices 
+         (for-each (lambda (i)
+                     (local ((define n (- GUESS i 1)))
+                       (make-object choice% #f DIGITS panel 
+                         (lambda (x y)
+                           (vector-set! guesses n (send x get-selection))))))
+                   (build-list GUESS identity))
+         
+         (new-game)
+         (make-object button% "Check" guess-panel call-back)
+         (send frame show #t)
+         #t))
+     
+     
+     ;                                                  
+     ;                                                  
+     ;                                                  
+     ;   ;;;;;                                          
+     ;   ;                                              
+     ;   ;                                   ;          
+     ;   ;     ;     ;  ; ;;;    ;;;;   ; ;;;;;;   ;;;; 
+     ;   ;;;;   ;   ;   ;;   ;  ;    ;  ;;   ;    ;     
+     ;   ;       ; ;    ;    ;  ;    ;  ;    ;    ;     
+     ;   ;        ;     ;    ;  ;    ;  ;    ;     ;;;  
+     ;   ;       ; ;    ;    ;  ;    ;  ;    ;        ; 
+     ;   ;      ;   ;   ;;   ;  ;    ;  ;    ;        ; 
+     ;   ;;;;; ;     ;  ; ;;;    ;;;;   ;     ;;  ;;;;  
+     ;                  ;                               
+     ;                  ;                               
+     ;                  ;                               
+     
+     
+     ;; convert : (vector DIGIT) -> number
+     ;; to convert a vector of digits into a number 
+     ;; 0-th digit is right-most digit in number, 
+     ;; N-th digit is left-most digit in number
+     (define (convert guesses:vec)
+       (local ((define (convert digits)
+                 (cond
+                   ((empty? digits) 0)
+                   (else (+ (first digits) (* (convert (rest digits)) 10))))))
+         (convert (vector->list guesses:vec))))
+     
+     ;; guess-with-gui : (num num -> num) -> void
+     ;; effect: init target, init frame, set the check-guess function and show the frame
+     (define (guess-with-gui/proc cg)
+       (check-proc 'guess-with-gui cg 2 'first "two arguments")
+       (init-game 5 convert cg))
+     
+     ;; guess-with-gui-3 : (digit digit digit num -> num) -> void
+     ;; effect: init target, init frame, set the check-guess function and show the frame
+     (define (guess-with-gui-3/proc cg)
+       (check-proc 'guess-with-gui-3 cg (+ 3 1) 'first "four arguments")
+       (init-game 3 vector->list
+                  (lambda (lod target) (apply cg (append lod (list target))))))
+     
+     ;; guess-with-gui-list : num ((listof digit) num -> num) -> void
+     ;; effect: init target, init frame, set the check-guess function and show the frame
+     (define (guess-with-gui-list/proc n cg)
+       (check-arg  'guess-with-gui-list
+                   (and (number? n) (integer? n) (>= n 1)) "positive integer" '1st n)
+       (check-proc 'guess-with-gui-list cg 2 'first "two arguments")
+       (unless  (<= (expt 10 n) 2147483647)
+         (error 'guess-with-gui-list "the given number of digits (~a) is too large" n))
+       (init-game n vector->list cg)))
+   
diff --git a/collects/htdp/gui.ss b/collects/htdp/gui.ss
new file mode 100644
index 0000000000..10fa8178a9
--- /dev/null
+++ b/collects/htdp/gui.ss
@@ -0,0 +1,194 @@
+
+;; This is a modified version of the original "gui.ss" teachpack:
+;;   - Instead of having one window, each call to "create-window"
+;;     returns a window
+;;   - Message items stretch horizontally to fill the window, 
+;;     avoiding the need for long initialization messages
+
+#cs
+(module gui mzscheme
+  (require (lib "error.ss" "htdp")
+           (lib "mred.ss" "mred")
+           (lib "class.ss")
+           (lib "list.ss")
+           (lib "etc.ss")
+           (lib "prim.ss" "lang"))
+  
+  (provide-primitives
+   create-window ; (listof (listof GUI-ITEM)) -> window
+   show-window   ; window -> true
+   hide-window   ; window -> true
+   make-text     ; Str -> GUI-ITEM
+   text-contents ; GUI-ITEM[text%] -> Str
+   make-choice   ; (listof Str) -> GUI-ITEM
+   choice-index  ; GUI-ITEM[choice%] -> Str
+   ; make-button ; Str (Event% -> Boolean) -> GUI-ITEM
+   make-message  ; Str -> GUI-ITEM
+   draw-message  ; GUI-ITEM[message%] Str -> true
+   )
+  
+  (provide-higher-order-primitive make-button (_ call-back))
+
+  #| ------------------------------------------------------------------
+  Students build a window from a "matrix" list of GUI-ITEMS. 
+  To build GUI-ITEMs, they need to use make-text, make-choice, 
+  make-button, make-choice, or make-message. A GUI-ITEM can be 
+  added to the window only once. 
+  
+  |#
+  
+  ;; INFRASTRUCTURE OPERATIONS:
+  ;; ------------------------------------------------------------------
+
+  (define-struct window (get-frame))
+  
+  ;; show-window : -> true
+  ;; effect: to show the window
+  (define (show-window w)
+    (check-arg 'show-window (window? w) "window" "its" w)
+    (send ((window-get-frame w)) show true)
+    true)
+  
+  ;; hide-window : X -> true
+  ;; effect: to hide the window 
+  (define (hide-window w)
+    (check-arg 'hide-window (window? w) "window" "its" w)
+    (send ((window-get-frame w)) show false)
+    true)
+  
+  ;; MAKING ITEMS:
+  ;; ------------------------------------------------------------------
+  
+  (define-struct gui-item (builder))
+  ;; A gui-item[C < control%] is a structure: (make-gui-item f)
+  ;; where f is a function: (panel% -> C)
+  
+  ;; create-gui-item : ((union panel% #f) -> C[< control%])
+  ;; to create a memoizing gui-item
+  ;; create-window is the only caller that can pass in a panel
+  ;; exceptions: ;; if the gui-item is already "panel'ed", error
+  ;; all other callers must pass in #f
+  (define (create-gui-item builder)
+    (let ([C false])
+      (make-gui-item
+       (lambda (p)
+         (cond
+           [(and p C)
+            (error 'create-window "item added to window twice")]
+           [(and p (not C)) (set! C (builder p)) C]
+           [(and (not p) C) C]
+           [(and (not p) (not C))
+            (error 'gui "gui-items must be added to window before use (see create-window)")])))))
+  
+  ;; create-window : (listof (listof gui-item)) -> true
+  ;; to add gui-items to the window and to show window
+  (define (create-window loi)
+    (check-list-list 'create-window (listoflistof? gui-item? "gui-item" loi) "gui-items" loi)
+
+    (let ([the-frame (make-object frame% "GUI" false 10 10)])
+      (for-each (lambda (loi)
+		  (let ((p (make-object horizontal-pane% the-frame)))
+		    (send p set-alignment 'center 'center)
+		    (for-each (lambda (i) ((gui-item-builder i) p)) loi)))
+		loi)
+      (let ([w (make-window (lambda () the-frame))])
+	(show-window w)
+	w)))
+  
+  ;; (_ -> Boolean) String X -> (union String true)
+  (define (listoflistof? pred? pred given)
+    (cond
+      [(not (list? given)) (format NONLIST given)]
+      [(find-non list? given)
+       => (lambda (non-list)
+	    (format NONLISTLIST non-list))]
+      [(ormap identity (map (lambda (ll) (find-non pred? ll)) given))
+       => (lambda (non-x)
+	    (format NONX pred non-x))]
+      [else #t]))
+  
+  (define NONLIST "list expected, given: ~e")
+  (define NONLISTLIST "list of lists expected, given list with ~e")
+  (define NONX "list of lists of ~a expected, given list of lists with ~e")
+  
+  
+  #| Tests ------------------------------------------------------------------
+  (listoflistof? number? "number" '((1 2 3) (4 5 6)))
+  
+  (string=? (format NONX "number" 'a)
+            (listoflistof? number? "number" '((1 2 3) (4 a 6))))
+  
+  (string=? (format NONLISTLIST 1)
+            (listoflistof? number? "number" '(1 (2 3) (4 5 6))))
+  |#
+  
+  ;; make-text : str -> gui-item
+  ;; to create a text-item with label lbl
+  (define (make-text lbl)
+    (check-arg 'make-text (string? lbl) "string" "first" lbl)
+    (create-gui-item
+     (lambda (the-panel) 
+       (make-object text-field% lbl the-panel void))))
+  
+  ;; make-message : str -> gui-item
+  ;; to create a message-item with current contents txt
+  (define (make-message txt)
+    (check-arg 'make-message (string? txt) "string" "first" txt)
+    (create-gui-item 
+     (lambda (the-panel)
+       (new message% [label txt] [parent the-panel] [stretchable-width #t]))))
+  
+  ;; make-button : str (event% -> boolean) -> gui-item
+  ;; to create a button-item with label and call-back function 
+  (define (make-button label call-back)
+    (check-arg 'make-button (string? label) "string" 'first label)
+    (check-proc 'make-button call-back 1 'second "1 argument")
+    (create-gui-item 
+     (lambda (the-panel)
+       (make-object button% label
+         the-panel
+         (lambda (b e)
+           (check-result 'button-callback boolean? "Boolean" (call-back e)))))))
+  
+  ;; make-choice : (listof str) -> gui-item
+  ;; to create a choice-item that permits users to choose from the
+  ;; alternatives on loc
+  (define (make-choice loc)
+    (check-arg 'make-choice (and (list? loc) (andmap string? loc)) "list of strings" "first" loc)
+    (create-gui-item 
+     (lambda (the-panel)
+       (make-object choice% "" loc the-panel void))))
+  
+  ;; DISPLAYING MESSAGES:
+  ;; ------------------------------------------------------------------
+  
+  ;; draw-message : gui-item[message%] str -> true
+  ;; to change the current contents of a message field 
+  (define (draw-message msg txt)
+    (check-arg 'draw-message (gui-item? msg) "gui-item" "first" msg)
+    (check-arg 'draw-message (string? txt) "string" "second" txt)   
+    (let* ([o ((gui-item-builder msg) #f)])
+      (when (<= (send o min-width) (string-length txt))
+        (let*-values ;; MF: I couldn't think of a better way of doing this
+            ([(m) (new message% [parent (new frame% [label "hello"])][label txt])]
+             [(x y) (send m get-graphical-min-size)])
+          (send o min-width x)))
+      (send o set-label txt)
+      true))
+  
+  ;; PROBING ITEMS:
+  ;; ------------------------------------------------------------------
+  
+  ;; text-contents : gui-item[text-field%] -> str
+  ;; to determine the contents of a text-item 
+  (define (text-contents a-text-gui)
+    (check-arg 'text-contents (gui-item? a-text-gui) "gui-item" "first" a-text-gui)
+    (send ((gui-item-builder a-text-gui) #f) get-value))
+  
+  ;; choice-index : gui-item[choice%] -> number
+  ;; to determine which choice is currently selected in a choice-item 
+  (define (choice-index a-choice)
+    (check-arg 'choice-index (gui-item? a-choice) "gui-item" "first" a-choice)      
+    (send ((gui-item-builder a-choice) #f) get-selection))
+  
+  )
diff --git a/collects/htdp/hangman-play.ss b/collects/htdp/hangman-play.ss
new file mode 100644
index 0000000000..6643381073
--- /dev/null
+++ b/collects/htdp/hangman-play.ss
@@ -0,0 +1,52 @@
+(module hangman-play mzscheme
+  (require "hangman.ss"
+           "big-draw.ss"
+           (lib "prim.ss" "lang")
+	   (lib "posn.ss" "lang"))
+  
+  (provide go)
+  
+  (define-primitive go go/proc)
+  
+  #| ------------------------------------------------------------------------
+  draw-next-part :
+  { 'noose 'head 'right-arm 'left-arm 'body 'right-leg 'left-leg } -> #t
+  result: #t if things went okay
+  effect: to draw the specified body part in a canvas of size W x H
+  credit: John Clements 
+  |#
+  (define (draw-next-part body-part)
+    (cond ((eq? body-part 'body)
+           (draw-solid-line (make-posn 100 60) (make-posn 100 130) 'black))
+          ((eq? body-part 'right-leg)
+           (draw-solid-line (make-posn 100 130) (make-posn 30 170) 'black))
+          ((eq? body-part 'left-leg)
+           (draw-solid-line (make-posn 100 130) (make-posn 170 170) 'black))
+          ((eq? body-part 'right-arm)
+           (draw-solid-line (make-posn 100 75) (make-posn 40 65) 'black))
+          ((eq? body-part 'left-arm)
+           (draw-solid-line (make-posn 100 75) (make-posn 160 65) 'black))
+          ((eq? body-part 'head)
+           (draw-circle (make-posn 100 50) 10 'black))
+          ((eq? body-part 'noose)
+           (and
+            (draw-solid-line (make-posn 100 30) (make-posn 100 10) 'black)
+            (draw-solid-line (make-posn 100 10) (make-posn 0 10) 'black)
+            (draw-solid-line (make-posn 115 35) (make-posn 123 43) 'black)
+            (draw-solid-line (make-posn 123 35) (make-posn 115 43) 'black)
+            (draw-solid-line (make-posn 131 40) (make-posn 139 48) 'black)
+            (draw-solid-line (make-posn 139 40) (make-posn 131 48) 'black)
+            (draw-circle (make-posn 120 50) 30 'red)))))
+  
+  ;; reveal-list : list-of-letters list-of-letters letter -> list-of-letters
+  (define (reveal-list l1 l2 gu)
+    (map (lambda (x1 x2)
+           (cond
+             [(eq? x1 gu) gu]
+             [else x2]))
+         l1 l2))
+  
+  (define (go/proc x)
+    (start 200 400)
+    (hangman-list reveal-list draw-next-part))    
+  )
diff --git a/collects/htdp/hangman.ss b/collects/htdp/hangman.ss
new file mode 100644
index 0000000000..f22a55459c
--- /dev/null
+++ b/collects/htdp/hangman.ss
@@ -0,0 +1,281 @@
+#cs(module hangman mzscheme
+  (require "error.ss"
+	   "draw-sig.ss"
+	   "big-draw.ss"
+	   (lib "class.ss")
+           (lib "unitsig.ss")
+           (lib "etc.ss")
+           (lib "prim.ss" "lang")
+	   (lib "mred.ss" "mred"))
+  
+  (provide
+   hangman
+   hangman-list
+   )
+  
+  (define-higher-order-primitive hangman hangman/proc (make-word reveal draw-next))
+  (define-higher-order-primitive hangman-list hangman-list/proc (reveal-list draw-next))
+
+  (provide-signature-elements draw^)
+  
+  #| ------------------------------------------------------------------------
+  The Basic Constants |#
+  
+  (define TITLE "Hangman")
+  (define WELCOME "Welcome to Hangman") 
+  (define WINNER  "We have a winner!") 
+  (define LOSER   "This is the end, my friend. The word was ~a.") 
+  
+  (define SMALL_A (char->integer #\a))
+  (define LETTERS
+    (build-list 26 (lambda (i) (format "~a" (integer->char (+ SMALL_A i))))))
+  
+  (define TRUMPET
+    (make-object bitmap% 
+      (build-path (collection-path "icons") "trumpet.xbm")
+      'xbm))
+  
+  (define PARTS (vector 'right-leg 'left-leg 'left-arm 'right-arm 'body 'head 'noose))
+  
+  (define NUMBER-OF-GUESSES (vector-length PARTS))
+  
+  ;; char->symbol : char -> symbol 
+  (define (char->symbol c)
+    (string->symbol (format "~a" c)))
+  
+  ;; word->list : symbol -> (listof letter)
+  (define (word->list sym)
+    (map char->symbol (string->list (symbol->string sym))))
+  
+  ;; WORDS : (listof (list letter letter letter))
+  (define WORDS
+    (map word->list
+         '(and
+	   are
+	   but
+	   cat
+	   cow
+	   dog
+	   eat
+	   fee
+	   gal
+	   hat
+	   inn
+	   jam
+	   kit
+	   lit
+	   met
+	   now
+	   owl
+	   pet
+	   rat
+	   sea
+	   the
+	   usa
+	   vip
+	   was
+	   zoo)))
+  
+  ;; WORDS2 : (listof (listof letter))
+  (define WORDS2
+    (append (map word->list
+                 '(apple
+		   bottle
+		   cattle
+		   drscheme
+		   elephant
+		   folder
+		   gift
+		   hangman
+		   idle
+		   jet
+		   knowledge
+		   length
+		   macintosh
+		   north
+		   ottoman
+		   public
+		   queue
+		   rattlesnake
+		   snow
+		   toddler
+		   under
+		   virus
+		   xylaphon
+		   yellow
+		   zombie))
+            WORDS))	    
+  
+  ;; ------------------------------------------------------------------------
+  ;; The GUI
+  
+  ;; two communication channels to GUI; init with setup-gui
+  (define status-message #f)
+  (define message-panel #f)
+  
+  ;; setup-gui : str ->* message% panel%
+  ;; to produce a status message and a panel where winning/losing can be announced
+  ;; effect: set up a new frame, arrange the GUI, and display (blank) status word 
+  (define (setup-gui status)
+    (local (#| --------------------------------------------------------------
+             The GUI Layout: (computed as a function of constants)
+             
+             ------------------------------------------------
+             |                                              |
+             |   a ... z    "Check"  "Status"   word	     |
+             |   choice%     button%  message%  message%    |
+             | 					     |
+             |         Welcome/Winner/Loser                 |
+             |            message%             	     |
+             ------------------------------------------------
+             |#
+             
+             (define frame (make-object frame% TITLE #f 100 50))
+             (define verti (make-object vertical-panel% frame))
+             
+             (define panel (make-object horizontal-panel% verti))
+             (define _1 (send panel set-alignment 'center 'center))
+             
+             (define choice (make-object choice% "Guess:" LETTERS panel void))    
+             
+             ; (make-object message% "  " panel);; added for looks
+             (define check (make-object button% "Check" panel 
+                             (lambda (x y)
+                               (check-guess
+                                (char->symbol
+                                 (list-ref LETTERS
+                                           (send choice get-selection)))))))
+             
+             (define _2 (make-object message% " Status: " panel))
+             (define m (make-object message% (uncover status) panel))
+             
+             (define p (make-object horizontal-panel% verti))
+             (define _3 (send p set-alignment 'center 'center))
+             (define _4 (make-object message% WELCOME p)))
+      (set! status-message m)
+      (set! message-panel p)
+      (send frame show #t)))
+  
+  ;; ------------------------------------------------------------------------
+  ;; The functions for communicating with the GUI
+  
+  ;; a-winner! : -> void
+  ;; effect: signal win and disable game 
+  (define (a-winner!)
+    (send message-panel change-children (lambda (x) null))
+    (make-object message% WINNER message-panel)
+    (make-object message% TRUMPET message-panel))
+  
+  ;; a-loser! : -> void
+  ;; effect: signal loss and disable game 
+  (define (a-loser!)
+    (send message-panel change-children (lambda (x) null))
+    (make-object message% (format LOSER (uncover chosen)) message-panel))
+  
+  ;; ------------------------------------------------------------------------
+  ;; The functions for playing the game
+  
+  ;; check-guess : symbol -> word 
+  ;; to check whether guess occurs in the chosen word, using reveal 
+  ;; effect: update the status word 
+  (define (check-guess guess)
+    (let ((result (reveal chosen status guess)))
+      (cond
+        [(equal? result chosen) 
+         (send status-message set-label (uncover chosen))
+         (a-winner!)]
+        [(equal? result status) 
+         (draw-next-part (select-piece!))
+         (when (the-end?) (a-loser!))]
+        [else
+         (set! status result)
+         (send status-message set-label (uncover status))])))
+  
+  ;; uncover : word -> string
+  ;; to translate the current word into a string, 
+  ;; using abstraction breaking struct-ref
+  (define (uncover a-word)
+    (error 'hangman "impossible"))
+  
+  ;; pieces-left : index into PARTS 
+  (define pieces-left NUMBER-OF-GUESSES)
+  (define (init-guesses)
+    (set! pieces-left NUMBER-OF-GUESSES))
+  
+  ;; select-piece! : -> void
+  ;; effect: to decrease pieces-left and to pick the next thing to be drawn 
+  (define (select-piece!)
+    (when (> pieces-left 0)
+      (set! pieces-left (sub1 pieces-left))
+      (vector-ref PARTS pieces-left)))
+  ;; the-end? : -> boolean
+  ;; to check whether the hangman is complet 
+  (define (the-end?) (zero? pieces-left))
+  
+  ;; USER INTERFACE to student
+  
+  ;; chosen : word 
+  (define chosen 10)
+  ;; status : word 
+  (define status 10)
+  ;; reveal :  (word word letter -> word)
+  (define (reveal chosen status guess)
+    (error 'hangman "appply hangman first!"))
+  ;; draw-next-part :  (symbol -> #t)
+  (define (draw-next-part s)
+    (error 'hangman "appply hangman first!"))
+  
+  ;; hangman :
+  ;;   (letter letter letter -> word)
+  ;;   (word word letter -> word)
+  ;;   (symbol -> true)
+  ;;   ->
+  ;;   true
+  ;; effects: set up game status, draw noose, show frame
+  ;; depends on: words are structures 
+  (define (hangman/proc mw rv dr)
+    (check-proc 'hangman mw 3 '1st "3 arguments")
+    (check-proc 'hangman rv 3 '2nd "3 arguments")
+    (check-proc 'hangman dr 1 '3rd "1 argument")
+    (set! chosen (apply mw (list-ref WORDS (random (length WORDS)))))
+    (set! status (mw '_ '_ '_))
+    ;; make uncover work for structs
+    (set! uncover
+          (lambda (a-word)
+            ;; abstraction breaking hack.
+            (parameterize ([current-inspector (dynamic-require 'drscheme-secrets 'drscheme-inspector)])
+              (unless (struct? a-word)
+                (error 'hangman "expected a struct, got: ~e" a-word))
+              (let ([word-vec (struct->vector a-word)])
+                (unless (= (vector-length word-vec) 4)
+                  (error 'hangman "expected words to be structures with three fields, found ~a fields"
+                         (- (vector-length word-vec) 1)))
+                (format "~a~a~a" 
+                        (vector-ref word-vec 1)
+                        (vector-ref word-vec 2)
+                        (vector-ref word-vec 3))))))
+    (initialize rv dr status))
+  
+  ;; word2 = (listof letter)
+  ;; hangman-list : (word2 word2 letter -> word2) (symbol -> #t) -> void
+  ;; effects: set up game status, draw noose, show frame
+  (define (hangman-list/proc rv dr)
+    (check-proc 'hangman-list rv 3 '1st "3 arguments")
+    (check-proc 'hangman-list dr 1 '2nd "1 argument")
+    (set! chosen (list-ref WORDS2 (random (length WORDS2))))
+    (set! status (build-list (length chosen) (lambda (x) '_)))
+    ;; make uncover work for lists
+    (set! uncover
+          (lambda (word)
+            (apply string-append (map (lambda (x) (format "~a" x)) word))))
+    (initialize rv dr status))
+  
+  ;; initialize : as it says ...
+  ;; the gui, the guess, the picture, the reveal function the draw-next function
+  (define (initialize rv dr status)
+    (init-guesses)
+    (set! reveal rv)
+    (set! draw-next-part dr)
+    (setup-gui status)
+    (draw-next-part (select-piece!)))
+  )
diff --git a/collects/htdp/image.ss b/collects/htdp/image.ss
new file mode 100644
index 0000000000..e37ac76e01
--- /dev/null
+++ b/collects/htdp/image.ss
@@ -0,0 +1,841 @@
+#|
+
+The test suite for this code is in
+plt/collects/tests/mzscheme/image-test.ss
+
+|#
+
+(module image mzscheme
+
+  (require (lib "mred.ss" "mred")
+	   (lib "class.ss")
+           (lib "cache-image-snip.ss" "mrlib")
+           (lib "math.ss")
+	   (lib "posn.ss" "lang")
+           (lib "imageeq.ss" "lang" "private")
+           "error.ss")
+
+  (provide image-width
+	   image-height
+	   overlay
+	   overlay/xy
+           
+           pinhole-x
+           pinhole-y
+           move-pinhole
+           put-pinhole
+           
+           rectangle
+           circle
+           ellipse
+           triangle
+           line
+           add-line
+           text
+           
+           shrink
+           shrink-tl
+           shrink-tr
+           shrink-bl
+           shrink-br
+           
+	   image-inside?
+	   find-image
+           
+	   image->color-list
+	   color-list->image
+           
+           image->alpha-color-list
+           alpha-color-list->image
+           
+           image-color?
+           make-color
+           color-red
+           color-green
+           color-blue
+           color?
+           make-alpha-color
+           alpha-color-alpha
+           alpha-color-red
+           alpha-color-green
+           alpha-color-blue
+           alpha-color?)
+
+  ;; ----------------------------------------
+           
+  (define (color-list? l)
+      (and (list? l) (andmap color? l)))
+  (define (alpha-color-list? l)
+    (and (list? l) (andmap alpha-color? l)))
+
+  (define-struct color (red green blue) (make-inspector))
+  (define-struct alpha-color (alpha red green blue) (make-inspector))
+
+  ;; ----------------------------------------
+
+  (define (check name p? v desc arg-posn) (check-arg name (p? v) desc arg-posn v))
+
+  (define (check-coordinate name val arg-posn) (check name number? val "number" arg-posn))
+  (define (check-size name val arg-posn) (check name posi? val "positive exact integer" arg-posn))
+  (define (check-size/0 name val arg-posn) (check name nnosi? val "non-negative exact integer" arg-posn))
+  (define (check-image name val arg-posn) (check name image? val "image" arg-posn))
+  (define (check-image-color name val arg-posn) (check name image-color? val "image-color" arg-posn))
+  (define (check-mode name val arg-posn) (check name mode? val mode-str arg-posn))
+  
+  (define (posi? i) (and (number? i) (integer? i) (positive? i) (exact? i)))
+  (define (nnosi? i) (and (number? i) (integer? i) (exact? i) (or (zero? i) (positive? i))))
+
+  
+  (define (check-sizes who w h)
+    (unless (and (< 0 w 10000) (< 0 h 10000))
+      (error (format "cannot make ~a x ~a image" w h))))
+  
+  (define (mode? x)
+    (or (eq? x 'solid)
+        (eq? x 'outline)))
+  
+  (define mode-str "'solid or 'outline")
+  
+  (define (mode->brush-symbol m)
+    (case m
+      [(solid) 'solid]
+      [(outline) 'transparent]))
+  
+  (define (mode->pen-symbol m)
+    (case m
+      [(solid) 'transparent]
+      [(outline) 'solid]))
+  
+  
+  (define (make-color% c)
+    (cond
+      [(string? c) (send the-color-database find-color c)]
+      [(symbol? c) (send the-color-database find-color (symbol->string c))]
+      [(color? c) (make-object color%
+                    (color-red c)
+                    (color-green c)
+                    (color-blue c))]
+      [else #f]))
+  
+  (define (image-color? c) 
+    (cond
+      [(color? c) #t]
+      [(string? c) (and (send the-color-database find-color c) #t)]
+      [(symbol? c) (and (send the-color-database find-color (symbol->string c)) #t)]
+      [else #f]))
+  
+  (define (image-width a)
+    (check-image 'image-width a "first")
+    (let-values ([(w h) (snip-size a)])
+      (inexact->exact (ceiling w))))
+
+  (define (image-height a)
+    (check-image 'image-height a "first")
+    (let-values ([(w h) (snip-size a)])
+      (inexact->exact (ceiling h))))
+  
+  (define (pinhole-x a)
+    (check-image 'pinhole-x a "first")
+    (let-values ([(x y) (send (coerce-to-cache-image-snip a) get-pinhole)])
+      x))
+  
+  (define (pinhole-y a)
+    (check-image 'pinhole-y a "first")
+    (let-values ([(x y) (send (coerce-to-cache-image-snip a) get-pinhole)])
+      y))
+  
+  (define (move-pinhole raw-i dx dy)
+    (check-image 'move-pinhole raw-i "first")
+    (check-coordinate 'move-pinhole dx "second")
+    (check-coordinate 'move-pinhole dy "third")
+    (let ([i (coerce-to-cache-image-snip raw-i)])
+      (let-values ([(px py) (send i get-pinhole)]
+                   [(w h) (send i get-size)])
+        (new cache-image-snip%
+             (dc-proc (send i get-dc-proc))
+             (argb-proc (send i get-argb-proc))
+             (width w)
+             (height h)
+             (argb (send i get-argb/no-compute))
+             (px (+ px dx))
+             (py (+ py dy))))))
+  
+  (define (put-pinhole raw-i px py)
+    (check-image 'put-pinhole raw-i "first")
+    (check-coordinate 'put-pinhole px "second")
+    (check-coordinate 'put-pinhole py "third")
+    (let ([i (coerce-to-cache-image-snip raw-i)])
+      (let-values ([(w h) (send i get-size)])
+        (new cache-image-snip%
+             (dc-proc (send i get-dc-proc))
+             (argb-proc (send i get-argb-proc))
+             (width w)
+             (height h)
+             (argb (send i get-argb/no-compute))
+             (px (floor px))
+             (py (floor py))))))
+        
+  (define (overlay a b . cs)
+    (check-image 'overlay a "first")
+    (check-image 'overlay b "second")
+    (let loop ([cs cs]
+               [i 3])
+      (unless (null? cs)
+        (check-image 'overlay (car cs) (number->ord i))))
+    (let ([all-imgs (reverse (list* a b cs))])
+      (let loop ([imgs (cdr all-imgs)]
+                 [acc (car all-imgs)])
+        (cond
+          [(null? imgs) acc]
+          [else (loop (cdr imgs)
+                      (real-overlay/xy 'overlay (car imgs) 0 0 acc))]))))
+
+  (define (overlay/xy a dx dy b)
+    (check-image 'overlay/xy a "first")
+    (check-coordinate 'overlay/xy dx "second")
+    (check-coordinate 'overlay/xy dy "third")
+    (check-image 'overlay/xy b "fourth")
+    (real-overlay/xy 'overlay/xy a dx dy b))
+
+  (define (real-overlay/xy name raw-a raw-delta-x raw-delta-y raw-b)
+    (let ([a (coerce-to-cache-image-snip raw-a)]
+          [b (coerce-to-cache-image-snip raw-b)])
+      (let-values ([(a-w a-h) (snip-size a)]
+                   [(b-w b-h) (snip-size b)]
+                   [(a-px a-py) (send a get-pinhole)]
+                   [(b-px b-py) (send b get-pinhole)])
+        (let* ([delta-x (+ raw-delta-x a-px (- b-px))]
+               [delta-y (+ raw-delta-y a-py (- b-py))]
+               [left (min 0 delta-x)]
+               [top (min 0 delta-y)]
+               [right (max (+ delta-x b-w) a-w)]
+               [bottom (max (+ delta-y b-h) a-h)]
+               [new-w (ceiling (- right left))]
+               [new-h (ceiling (- bottom top))]
+               [a-dx (- left)]
+               [a-dy (- top)]
+               [b-dx (- delta-x left)]
+               [b-dy (- delta-y top)]
+               [new-px (- a-px left)]
+               [new-py (- a-py top)]
+               [combine (lambda (a-f b-f)
+                          (lambda (dc dx dy)
+                            (a-f dc (+ dx a-dx) (+ dy a-dy))
+                            (b-f dc (+ dx b-dx) (+ dy b-dy))))])
+          (check-sizes name new-w new-h)
+          (new cache-image-snip%
+               [dc-proc (combine (send a get-dc-proc)
+                                 (send b get-dc-proc))]
+               [argb-proc (combine (send a get-argb-proc)
+                                   (send b get-argb-proc))]
+               [width new-w]
+               [height new-h]
+               [px new-px]
+               [py new-py])))))
+  ;; ------------------------------------------------------------
+  
+  (define (shrink raw-img left up right down)
+    (check-image 'shrink raw-img "first")
+    (check-size/0 'shrink left "second")
+    (check-size/0 'shrink up "third")
+    (check-size/0 'shrink right "fourth")
+    (check-coordinate 'shrink down "fifth")
+    (let ([img (coerce-to-cache-image-snip raw-img)])
+      (let-values ([(i-px i-py) (send img get-pinhole)]
+                   [(i-width i-height) (send img get-size)])
+        (let* ([dc-proc (send img get-dc-proc)]
+               [argb-proc (send img get-argb-proc)]
+               [delta-w (- i-px left)]
+               [delta-h (- i-py up)]
+               [width (+ left right 1)]
+               [height (+ up down 1)])
+          (new cache-image-snip%
+               [px left]
+               [py up]
+               [dc-proc (lambda (dc dx dy)
+                          (let ([clip (send dc get-clipping-region)])
+                            (send dc set-clipping-rect dx dy width height)
+                            (dc-proc dc (- dx delta-w) (- dy delta-h))
+                            (send dc set-clipping-region clip)))]
+               [argb-proc (lambda (argb dx dy) (argb-proc argb (- dx delta-w) (- dy delta-h)))]
+               [width width]
+               [height height])))))
+  
+  (define (shrink-tl raw-img x y)
+    (check-image 'shrink-tl raw-img "first")
+    (check-size 'shrink-tl x "second")
+    (check-size 'shrink-tl y "third")
+    (put-pinhole (shrink (put-pinhole raw-img 0 0) 0 0 (- x 1) (- y 1)) (/ x 2) (/ y 2)))
+  
+  (define (shrink-tr raw-img x y)
+    (check-image 'shrink-tr raw-img "first")
+    (check-size 'shrink-tr x "second")
+    (check-size 'shrink-tr y "third")
+    (put-pinhole (shrink (put-pinhole raw-img (- (image-width raw-img) 1) 0) (- x 1) 0 0 (- y 1))
+                 (/ x 2)
+                 (/ y 2)))
+  
+  (define (shrink-bl raw-img x y)
+    (check-image 'shrink-bl raw-img "first")
+    (check-size 'shrink-bl x "second")
+    (check-size 'shrink-bl y "third")
+    (put-pinhole (shrink (put-pinhole raw-img 0 (- (image-height raw-img) 1)) 0 (- y 1) (- x 1) 0) 
+                 (/ x 2)
+                 (/ y 2)))
+  
+  (define (shrink-br raw-img x y)
+    (check-image 'shrink-br raw-img "first")
+    (check-size 'shrink-br x "second")
+    (check-size 'shrink-br y "third")
+    (put-pinhole (shrink (put-pinhole raw-img (- (image-width raw-img) 1) (- (image-height raw-img) 1))
+                         (- x 1)
+                         (- y 1)
+                         0
+                         0)
+                 (/ x 2)
+                 (/ y 2)))
+
+
+  ;; ------------------------------------------------------------
+
+  (define (line x y color)
+    (check-coordinate 'line x "first")
+    (check-coordinate 'line y "second")
+    (check-image-color 'line color "third")
+    (check-sizes 'line (+ x 1) (+ y 1))
+    (let ([draw-proc 
+           (make-color-wrapper
+            color 'transparent 'solid
+            (lambda (dc dx dy)
+              (send dc draw-line dx dy (+ dx x) (+ dy y))))]
+          [mask-proc
+           (make-color-wrapper
+            'black 'transparent 'solid
+            (lambda (dc dx dy)
+              (send dc draw-line dx dy (+ dx x) (+ dy y))))])
+      (make-simple-cache-image-snip (+ x 1) (+ y 1) 0 0 draw-proc mask-proc)))
+  
+  ;; test what happens when the line moves out of the box.
+  (define (add-line raw-i pre-x1 pre-y1 pre-x2 pre-y2 color-in)
+    (check-image 'add-line raw-i "first")
+    (check-coordinate 'add-line pre-x1 "second")
+    (check-coordinate 'add-line pre-y1 "third")
+    (check-coordinate 'add-line pre-x2 "fourth")
+    (check-coordinate 'add-line pre-y2 "fifth")
+    (check-image-color 'add-line color-in "sixth")
+    (let ([i (coerce-to-cache-image-snip raw-i)])
+      (let-values ([(px py) (send i get-pinhole)]
+                   [(iw ih) (send i get-size)]
+                   [(x1 y1 x2 y2)
+                    (if (<= pre-x1 pre-x2)
+                        (values pre-x1 pre-y1 pre-x2 pre-y2)
+                        (values pre-x2 pre-y2 pre-x1 pre-y1))])
+        (let* ([line-w (+ (abs (- x2 x1)) 1)]
+               [line-h (+ (abs (- y2 y1)) 1)])
+          (if (y1 . <= . y2)
+              (let* ([do-draw
+                      (lambda (dc dx dy)
+                        (send dc draw-line 
+                              dx
+                              dy
+                              (+ dx (- x2 x1))
+                              (+ dy (- y2 y1))))]
+                     [draw-proc 
+                      (make-color-wrapper color-in 'transparent 'solid do-draw)]
+                     [mask-proc
+                      (make-color-wrapper 'black 'transparent 'solid do-draw)]
+                     [line
+                      (make-simple-cache-image-snip line-w line-h px py draw-proc mask-proc)])
+                (real-overlay/xy 'add-line i (+ px x1) (+ py y1) line))
+              (let* ([do-draw
+                      (lambda (dc dx dy)
+                        (send dc draw-line 
+                              dx
+                              (+ dy (- line-h 1))
+                              (+ dx (- line-w 1))
+                              dy))]
+                     [draw-proc 
+                      (make-color-wrapper color-in 'transparent 'solid do-draw)]
+                     [mask-proc
+                      (make-color-wrapper 'black 'transparent 'solid do-draw)]
+                     [line
+                      (make-simple-cache-image-snip line-w line-h px py draw-proc mask-proc)])
+                (real-overlay/xy 'add-line i (+ px x1) (+ py y2) line)))))))
+
+  (define (text str size color-in)
+    (check 'text string? str "string" "first")
+    (check 'text (lambda (x) (and (integer? x) (<= 1 x 255))) size "integer between 1 and 255" "second")
+    (check-image-color 'text color-in "third")
+    (let ([color (make-color% color-in)])
+      (let-values ([(tw th) (get-text-size size str)])
+        (let ([draw-proc
+               (lambda (txt-color mode dc dx dy)
+                 (let ([old-mode (send dc get-text-mode)]
+                       [old-fore (send dc get-text-foreground)]
+                       [old-font (send dc get-font)])
+                   (send dc set-text-mode mode)
+                   (send dc set-text-foreground txt-color)
+                   (send dc set-font (get-font size))
+                   (send dc draw-text str dx dy)
+                   (send dc set-text-mode old-mode)
+                   (send dc set-text-foreground old-fore)
+                   (send dc set-font old-font)))])
+          (new cache-image-snip%
+               [dc-proc (lambda (dc dx dy) (draw-proc color 'transparent dc dx dy))]
+               [argb-proc 
+                (lambda (argb dx dy)
+                  (let ([bm-color
+                         (build-bitmap
+                          (lambda (dc)
+                            (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent))
+                            (send dc set-brush (send the-brush-list find-or-create-brush color 'solid))
+                            (send dc draw-rectangle 0 0 tw th))
+                          tw
+                          th)]
+                        [bm-mask
+                         (build-bitmap
+                          (lambda (dc)
+                            (draw-proc 
+                             (send the-color-database find-color "black")
+                             'solid dc 0 0))
+                          tw
+                          th)])
+                    (overlay-bitmap argb dx dy bm-color bm-mask)))]
+               [width tw]
+               [height th]
+               [px 0]
+               [py 0])))))
+                    
+  (define (get-text-size size string)
+    (let* ([bm (make-object bitmap% 1 1)]
+           [dc (make-object bitmap-dc% bm)])
+      (let-values ([(w h _1 _2) (send dc get-text-extent string (get-font size))])
+        (values (inexact->exact (ceiling w)) 
+                (inexact->exact (ceiling h))))))
+  
+  (define (get-font size)
+    (send the-font-list find-or-create-font size
+          'default 'normal 'normal #f
+          (case (system-type)
+            [(macosx) 'partly-smoothed]
+            [else 'smoothed])))
+
+  (define (a-rect/circ who do-draw w h color brush pen)
+    (check-sizes who w h)
+    (let* ([dc-proc (make-color-wrapper color brush pen do-draw)]
+           [mask-proc (make-color-wrapper 'black brush pen do-draw)])
+      (make-simple-cache-image-snip w h (floor (/ w 2)) (floor (/ h 2)) dc-proc mask-proc)))
+  
+  (define (rectangle w h mode color)
+    (check-size 'rectangle w "first")
+    (check-size 'rectangle h "second")
+    (check-mode 'rectangle mode "third")
+    (check-image-color 'rectangle color "fourth")
+    (a-rect/circ 'rectangle
+                 (lambda (dc dx dy) (send dc draw-rectangle dx dy w h))
+                 w h color (mode->brush-symbol mode) (mode->pen-symbol mode)))
+  
+  (define (ellipse w h mode color)
+    (check-size 'ellipse w "first")
+    (check-size 'ellipse h "second")
+    (check-mode 'ellipse mode "third")
+    (check-image-color 'ellipse color "fourth")
+    (a-rect/circ 'ellipse
+                 (lambda (dc dx dy) (send dc draw-ellipse dx dy w h))
+                 w h color (mode->brush-symbol mode) (mode->pen-symbol mode)))
+  
+  (define (circle r mode color)
+    (check-size 'circle r "first")
+    (check-mode 'circle mode "second")
+    (check-image-color 'circle color "third")
+    (a-rect/circ 'circle
+                 (lambda (dc dx dy) (send dc draw-ellipse dx dy (* 2 r) (* 2 r)))
+                 (* 2 r) (* 2 r) color (mode->brush-symbol mode) (mode->pen-symbol mode)))
+  
+  (define (triangle size mode color)
+    (check 'triangle
+           (lambda (x) (and (real? x) (< 2 x 10000)))
+           size 
+           "positive real number bigger than 2"
+           "first")
+    (check-mode 'triangle mode "second")
+    (check-image-color 'triangle color "third")
+    (let* ([right (- size 1)]
+           [bottom (inexact->exact (ceiling (* size (sin (* 2/3 pi)))))]
+           [points (list (make-object point% 0 bottom)
+                         (make-object point% right bottom)
+                         (make-object point% (/ size 2) 0))])
+      (let ([draw (make-color-wrapper
+                   color (mode->brush-symbol mode) 'solid
+                   (lambda (dc dx dy)
+                     (send dc draw-polygon points dx dy)))]
+            [mask-draw (make-color-wrapper
+                        'black (mode->brush-symbol mode) 'solid
+                        (lambda (dc dx dy)
+                          (send dc draw-polygon points dx dy)))]
+            [w size]
+            [h (+ bottom 1)])
+        (make-simple-cache-image-snip w h (floor (/ w 2)) (floor (/ h 2)) draw mask-draw))))
+        
+  (define (make-simple-cache-image-snip w h px py dc-proc mask-proc)
+    (let ([argb-proc 
+           (lambda (argb-vector dx dy)
+             (let ([c-bm (build-bitmap (lambda (dc) (dc-proc dc 0 0)) w h)]
+                   [m-bm (build-bitmap (lambda (dc) (mask-proc dc 0 0)) w h)])
+               (overlay-bitmap argb-vector dx dy c-bm m-bm)))])
+      (new cache-image-snip%
+           [dc-proc dc-proc]
+           [argb-proc argb-proc]
+           [width w]
+           [height h]
+           [px px]
+           [py py])))
+  
+  (define (make-color-wrapper color-in brush pen rest)
+    (let ([color (make-color% color-in)])
+      (lambda (dc dx dy)
+        (let ([old-brush (send dc get-brush)]
+              [old-pen (send dc get-pen)])
+          (send dc set-brush (send the-brush-list find-or-create-brush color brush))
+          (send dc set-pen (send the-pen-list find-or-create-pen color 1 pen))
+          (rest dc dx dy)
+          (send dc set-pen old-pen)
+          (send dc set-brush old-brush)))))
+  
+  ;; ------------------------------------------------------------
+
+  (define (image-inside? i a)
+    (and (locate-image 'image-inside? 
+                       (coerce-to-cache-image-snip i)
+                       (coerce-to-cache-image-snip a))
+         #t))
+  
+  (define (find-image i a)
+    (or (locate-image 'find-image 
+                      (coerce-to-cache-image-snip i)
+                      (coerce-to-cache-image-snip a))
+	(error 'find-image
+	       "the second image does not appear within the first image")))
+  
+  (define (locate-image who i a)
+    (check-image who i "first")
+    (check-image who a "second")
+    (let-values ([(iw ih) (snip-size i)]
+                 [(ipx ipy) (send i get-pinhole)]
+                 [(aw ah) (snip-size a)]
+                 [(apx apy) (send a get-pinhole)])
+      (and (iw . >= . aw)
+           (ih . >= . ah)
+           (let ([i-argb-vector (argb-vector (send i get-argb))]
+                 [a-argb-vector (argb-vector (send a get-argb))])
+             (let ([al (let loop ([offset 0])
+                         (cond
+                           [(= offset (* ah aw 4)) null]
+                           [else (cons (subvector a-argb-vector offset (+ offset (* 4 aw)))
+                                       (loop (+ offset (* 4 aw))))]))])
+               (let yloop ([dy 0])
+                 (and (dy . <= . (- ih ah))
+                      (let xloop ([dx 0])
+                        (if (dx . <= . (- iw aw))
+                            (if (let loop ([al al][dd 0])
+                                  (or (null? al)
+                                      (and (first-in-second?
+                                            i-argb-vector 
+                                            (car al)
+                                            (* 4 (+ (* (+ dy dd) iw) dx)))
+                                           (loop (cdr al) (add1 dd)))))
+                                (make-posn (+ dx (- apx ipx)) (+ dy (- apy ipy)))
+                                (xloop (add1 dx)))
+                            (yloop (add1 dy)))))))))))
+  
+  (define (subvector orig i j)
+    (let ([v (make-vector (- j i) #f)])
+      (let loop ([x i])
+        (when (< x j)
+          (vector-set! v (- x i) (vector-ref orig x))
+          (loop (+ x 1))))
+      v))
+#|
+(initial inequalities thanks to Matthew (thanks!!))
+
+We know that, for a combination:
+  m3 = (m1+m2-m1*m2) and 
+  b3 = (m1*b1*(1-m2) + m2*b2)/m3
+
+So, we need to figure out what m1 & m2 might have been, 
+given the other values.
+
+Check m3:
+
+   m3 = m2 when m1 = 0
+   m3 = 1 when m1 = 1
+
+   [deriv of m3 with respect to m1 = 1 - m2, which is positive]
+
+    so check that m3 is between m2 and 1
+
+Then check m3*b3:
+
+   b3*m3 = m2*b2  when m1 = 0 or b1 = 0
+   b3*m3 = (1 - m2) + m2*b2 when m1 = b1 = 1
+
+   [deriv with respect to m1 is b1*(1-m2), which is positive]
+   [deriv with respect to b1 is m1*(1-m2), which is positive]
+
+    So check that m3*b3 is between m2*b2 and (1 - m2) + m2*b2
+
+This is all in alphas from 0 to 1 and needs to be from 255 to 0.
+Converting (but using the same names) for the alpha test, we get:
+
+(<= (- 1 (/ m2 255))
+    (- 1 (/ m3 255))
+    1)
+
+sub1 to each:
+
+(<= (- (/ m2 255))
+    (- (/ m3 255))
+    0)
+
+mult by 255:
+
+(<= (- m2)
+    (- m3)
+    0)
+
+negate and flip ineq:
+
+
+(>= m2 m3 0)
+
+flip ineq back:
+
+(<= 0 m3 m2)
+
+
+Here's the original scheme expression for the second check:
+
+(<= (* m2 b2) 
+    (* m3 b3)
+    (+ (- 1 m2) (* m2 b2))
+
+converting from the computer's coordinates, we get:
+
+
+(<= (* (- 1 (/ m2 255)) (- 1 (/ b2 255)))
+    (* (- 1 (/ m3 255)) (- 1 (/ b3 255)))
+    (+ (- 1 (- 1 (/ m2 255)))
+       (* (- 1 (/ m2 255)) (- 1 (/ b2 255)))))
+
+;; multiplying out the binomials:
+
+(<= (+ 1
+       (- (/ m2 255)) 
+       (- (/ b2 255)) 
+       (/ (* m2 b2) (* 255 255)))
+    (+ 1
+       (- (/ m3 255)) 
+       (- (/ b3 255)) 
+       (/ (* m3 b3) (* 255 255)))
+    (+ (- 1 (- 1 (/ m2 255)))
+       (+ 1
+          (- (/ m2 255)) 
+          (- (/ b2 255)) 
+          (/ (* m2 b2) (* 255 255)))))
+
+;; simplifying the last term
+  
+(<= (+ 1
+       (- (/ m2 255)) 
+       (- (/ b2 255)) 
+       (/ (* m2 b2) (* 255 255)))
+    (+ 1
+       (- (/ m3 255)) 
+       (- (/ b3 255)) 
+       (/ (* m3 b3) (* 255 255)))
+    (+ 1
+       (- (/ b2 255)) 
+       (/ (* m2 b2) (* 255 255))))
+  
+;; multiply thru by 255:
+
+(<= (+ 255
+       (- m2) 
+       (- b2) 
+       (* m2 b2 1/255))
+    (+ 255
+       (- m3)
+       (- b3)
+       (* m3 b3 1/255))
+    (+ 255
+       (- b2) 
+       (* m2 b2 1/255)))
+  
+;; subtract out 255 from each:
+
+(<= (+ (- m2) 
+       (- b2) 
+       (* m2 b2 1/255))
+    (+ (- m3)
+       (- b3)
+       (* m3 b3 1/255))
+    (+ (- b2) 
+       (* m2 b2 1/255)))
+
+;; negate them all, and reverse the inequality
+
+(>= (+ m2 b2 (* m2 b2 -1/255))
+    (+ m3 b3 (* m3 b3 -1/255))
+    (+ b2 (* m2 b2 -1/255)))
+
+;; aka
+
+(<= (+ b2 (* m2 b2 -1/255))
+    (+ m3 b3 (* m3 b3 -1/255))
+    (+ m2 b2 (* m2 b2 -1/255)))
+
+|#
+  
+  ;; in the above, m3 & b3 come from iv
+  ;; and m2 & b2 come from av
+  (define (first-in-second? iv av xd)
+    (let loop ([i (vector-length av)])
+      (or (zero? i)
+	  (let ([a (- i 4)]
+                [r (- i 3)]
+		[g (- i 2)]
+		[b (- i 1)])
+            (let* ([m2 (vector-ref av a)]
+                   [m3 (vector-ref iv (+ xd a))]
+                   [test
+                    (lambda (b2 b3)
+                      (<= (+ b2 (* m2 b2 -1/255))
+                          (+ m3 b3 (* m3 b3 -1/255))
+                          (+ m2 b2 (* m2 b2 -1/255))))])
+              (and (<= 0 m3 m2)
+                   (test (vector-ref av r) (vector-ref iv (+ xd r)))
+                   (test (vector-ref av g) (vector-ref iv (+ xd g)))
+                   (test (vector-ref av b) (vector-ref iv (+ xd b)))
+                   (loop (- i 4))))))))
+
+  ;; ----------------------------------------
+
+  (define (image->color-list i-raw)
+    (check-image 'image->color-list i-raw "first")
+    (let* ([cis (coerce-to-cache-image-snip i-raw)]
+           [i (send cis get-bitmap)]
+           [iw (send i get-width)]
+           [ih (send i get-height)]
+           [new-bitmap (make-object bitmap% iw ih)]
+           [bdc (make-object bitmap-dc% new-bitmap)])
+      (send bdc clear)
+      (send bdc draw-bitmap i 0 0 'solid 
+            (send the-color-database find-color "black")
+            (send i get-loaded-mask))
+      (let ([is (make-bytes (* 4 iw ih))]
+            [cols (make-vector (* iw ih))])
+        (send bdc get-argb-pixels 0 0 iw ih is)
+        (let yloop ([y 0][pos 0])
+          (unless (= y ih)
+            (let xloop ([x 0][pos pos])
+              (if (= x iw)
+                  (yloop (add1 y) pos)
+                  (begin
+                    (vector-set! cols (+ x (* y iw))
+                                 (make-color (bytes-ref is (+ 1 pos))
+                                             (bytes-ref is (+ 2 pos))
+                                             (bytes-ref is (+ 3 pos))))
+                    (xloop (add1 x) (+ pos 4)))))))
+        (send bdc set-bitmap #f)
+        (vector->list cols))))
+  
+  (define (image->alpha-color-list i)
+    (check-image 'image->alpha-color-list i "first")
+    (let* ([argb (cond
+                   [(is-a? i image-snip%) 
+                    (send (coerce-to-cache-image-snip i) get-argb)]
+                   [(is-a? i cache-image-snip%) (send i get-argb)])]
+           [v (argb-vector argb)])
+      (let loop ([i (vector-length v)]
+                 [a null])
+        (cond
+          [(zero? i) a]
+          [else (loop (- i 4)
+                      (cons (make-alpha-color
+                             (vector-ref v (- i 4))
+                             (vector-ref v (- i 3))
+                             (vector-ref v (- i 2))
+                             (vector-ref v (- i 1)))
+                            a))]))))
+
+  (define (color-list->image cl w h px py)
+    (check 'color-list->image color-list? cl "list-of-colors" "first")
+    (check-size 'color-list->image w "second")
+    (check-size 'color-list->image h "third")
+    (check-coordinate 'color-list->image px "fourth")
+    (check-coordinate 'color-list->image py "fifth")
+    (unless (and (< 0 w 10000) (< 0 h 10000))
+      (error (format "cannot make ~a x ~a image" w h)))
+    (unless (= (* w h) (length cl))
+      (error (format "given width times given height is ~a, but the given color list has ~a items"
+		     (* w h) (length cl))))
+    (let* ([bm (make-object bitmap% w h)]
+           [mask-bm (make-object bitmap% w h)]
+	   [dc (make-object bitmap-dc% bm)]
+           [mask-dc (make-object bitmap-dc% mask-bm)])
+      (unless (send bm ok?)
+	(error (format "cannot make ~a x ~a image" w h)))
+      (let ([is (make-bytes (* 4 w h) 0)]
+            [mask-is (make-bytes (* 4 w h) 0)]
+	    [cols (list->vector cl)])
+	(let yloop ([y 0][pos 0])
+	  (unless (= y h)
+	    (let xloop ([x 0][pos pos])
+	      (if (= x w)
+		  (yloop (add1 y) pos)
+		  (let* ([col (vector-ref cols (+ x (* y w)))]
+                         [r (pk color-red col)]
+                         [g (pk color-green col)]
+                         [b (pk color-blue col)])
+		    (bytes-set! is (+ 1 pos) r)
+		    (bytes-set! is (+ 2 pos) g)
+		    (bytes-set! is (+ 3 pos) b)
+                    (when (= 255 r g b)
+                      (bytes-set! mask-is (+ 1 pos) 255)
+                      (bytes-set! mask-is (+ 2 pos) 255)
+                      (bytes-set! mask-is (+ 3 pos) 255))
+                    (xloop (add1 x) (+ pos 4)))))))
+	(send dc set-argb-pixels 0 0 w h is)
+        (send mask-dc set-argb-pixels 0 0 w h mask-is))
+      (send dc set-bitmap #f)
+      (send mask-dc set-bitmap #f)
+      (bitmaps->cache-image-snip bm mask-bm px py)))
+  
+  (define (pk sel col) (min 255 (max 0 (sel col))))
+  
+  (define (alpha-color-list->image cl w h px py)
+    (check 'alpha-color-list->image alpha-color-list? cl "list-of-alpha-colors" "first")
+    (check-size 'alpha-color-list->image w "second")
+    (check-size 'alpha-color-list->image h "third")
+    (check-coordinate 'alpha-color-list->image px "fourth")
+    (check-coordinate 'alpha-color-list->image py "fifth")
+    (unless (and (< 0 w 10000) (< 0 h 10000))
+      (error (format "cannot make ~a x ~a image" w h)))
+    (unless (= (* w h) (length cl))
+      (error (format "given width times given height is ~a, but the given color list has ~a items"
+		     (* w h) (length cl))))
+    (let ([index-list (alpha-colors->ent-list cl)])
+      (argb->cache-image-snip (make-argb (list->vector index-list) w) px py)))
+  
+  ;; alpha-colors->ent-list : (listof alpha-color) -> (listof number)
+  (define (alpha-colors->ent-list cl)
+    (let loop ([cl cl])
+      (cond
+        [(null? cl) null]
+        [else 
+         (let ([ac (car cl)])
+           (list* (alpha-color-alpha ac)
+                  (alpha-color-red ac)
+                  (alpha-color-green ac)
+                  (alpha-color-blue ac)
+                  (loop (cdr cl))))]))))
diff --git a/collects/htdp/info.ss b/collects/htdp/info.ss
new file mode 100644
index 0000000000..38b3d85364
--- /dev/null
+++ b/collects/htdp/info.ss
@@ -0,0 +1,2 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "HtDP Teachpacks"))
diff --git a/collects/htdp/lkup-gui.ss b/collects/htdp/lkup-gui.ss
new file mode 100644
index 0000000000..020b006b04
--- /dev/null
+++ b/collects/htdp/lkup-gui.ss
@@ -0,0 +1,62 @@
+#cs(module lkup-gui mzscheme
+  (require (lib "error.ss" "htdp")
+	   (lib "class.ss")
+           (lib "prim.ss" "lang")
+	   (lib "mred.ss" "mred"))
+  
+  (provide control view connect)
+  
+  (define-primitive control control/proc)
+  (define-primitive view view/proc)
+  (define-higher-order-primitive connect connect/proc (call-back))
+  
+  ;; ------------------------------------------------------------------------
+  ;; Basic constants: 
+  (define TITLE "LOOKUP")
+  (define WIDTH 100)
+  (define HIGHT 50)
+  
+  ;; ------------------------------------------------------------------------
+  ;; GUI LAYOUT 
+  (define frame (make-object frame% TITLE #f WIDTH HIGHT))
+  (define panel (make-object horizontal-panel% frame))
+  (send panel set-alignment 'left 'top)
+  (define vert1 (make-object vertical-panel% panel)) 
+  (send vert1 set-alignment 'left 'top)
+  (make-object message% "Name:" vert1)
+  (make-object message% "Number:" vert1)
+  (define vert2 (make-object vertical-panel% panel))
+  
+  ;; ------------------------------------------------------------------------
+  ;; guess : handle CONTROL
+  (define query-tf (make-object text-field% "" vert2
+                     (lambda (x y) (send result set-label ""))))
+  
+  ;; control : -> symbol
+  ;; to supply the name that a user typed into the query text-field
+  (define (control/proc)
+    (string->symbol (send query-tf get-value)))
+  
+  ;; connect : (button% control-event% -> true) -> void
+  ;; effect: to add a check button with call-back to frame and to show frame 
+  ;; the button is "border" style, so <CR> in query-tf will use call-back
+  (define button #f)
+  (define (connect/proc call-back)
+    (check-proc 'connect call-back 2 '1st "2 arguments")
+    (if button
+        (printf "connect: called a second time~n")
+        (begin 
+          (set! button (make-object button% "LookUp" panel call-back '(border)))
+          (send query-tf focus)
+          (send frame show #t))))
+  
+  ;; ------------------------------------------------------------------------
+  ;; message : display VIEW 
+  (define result (make-object message% "ddd.ddd.dddd" vert2))
+  
+  ;; view : symbol -> void
+  ;; effect: to display the phone number n in the message panel 
+  (define (view/proc n)
+    (check-arg 'view (symbol? n) "symbol" "first" n)
+    (send result set-label (symbol->string n)))
+  )
diff --git a/collects/htdp/master-play.ss b/collects/htdp/master-play.ss
new file mode 100644
index 0000000000..090f6888be
--- /dev/null
+++ b/collects/htdp/master-play.ss
@@ -0,0 +1,22 @@
+#cs(module master-play mzscheme
+  (require 
+   "master.ss"
+   (lib "prim.ss" "lang"))
+  
+  (provide go)
+  (define-primitive go go/proc)
+  
+  (define (compare choice1 choice2 guess1 guess2)
+    (cond
+      [(and (eq? choice1 guess1) (eq? choice2 guess2))
+       'perfect!]
+      [(or (eq? choice1 guess1) (eq? choice2 guess2))
+       'one_color_is_at_proper_place]
+      [(or (eq? choice2 guess1) (eq? choice1 guess2))
+       'one_color_occurs]
+      [else
+       'sorry_all_wrong]))
+
+  (define (go/proc s)
+    (printf "Have fun playing, ~a~n" s)
+    (master compare)))
diff --git a/collects/htdp/master.ss b/collects/htdp/master.ss
new file mode 100644
index 0000000000..1f0c7010a2
--- /dev/null
+++ b/collects/htdp/master.ss
@@ -0,0 +1,175 @@
+#cs(module master mzscheme
+  (provide master)
+  
+  (require "error.ss"
+           (lib "class.ss")
+           (lib "class100.ss")
+           (lib "mred.ss" "mred")
+           (lib "prim.ss" "lang")
+           (lib "etc.ss"))
+  
+  (define-higher-order-primitive master master/proc (compare-guess))
+  
+  #| ---------------------------------------------------------------------------
+  The Basic Constants |#
+  
+  (define TITLE "TeachScheme Color Guessing")
+  
+  (define WELCOME "Welcome to the TeachScheme Color-Guessing Game") 
+  
+  (define COLORS
+    (list 'black 'white 'red 'blue 'green 'gold 'pink 'orange 'purple 'navy))
+  
+  (define COL# (length COLORS))
+  
+  (define GUESSES# 2) 
+  
+  (define BUT-SIZE 30)
+  (define WIDTH (* COL# BUT-SIZE))
+  (define HIGHT BUT-SIZE)
+  
+  (define STOPS 
+    (list 'PerfectGuess 'perfect_guess 'perfect! 'perfect 'Perfect 'perfekt 'Perfekt))
+  
+  (define TRUMPET
+    (make-object bitmap% (build-path (collection-path "icons") "trumpet.xbm") 'xbm))
+  
+  #|
+  cd ~.../plt/collects/icons 
+  cp where/ever/trumpet.xbm .
+  cvs update -A 
+  cvs add -kb trumpet.xbm 
+  cvs commit -m "added trumpet image"
+  cvs tag -F exp trumpet.xbm
+  cvs update -r exp
+  |#
+  
+  #| ------------------------------------------------------------------------
+  The Layout: (computed as a function of constants)
+  
+  ------------------------------------------------------------------
+  |       
+  |   CB1  CB2   CB3   CB4   .......   CB*   CB*   CB*   CB*   CB* 
+  | 
+  |          CB-GUESS1    ...    CB-GUESS*
+  | 
+  |                     ONE-MESSAGE
+  ------------------------------------------------------------------
+  
+  Two horizontal panels: 
+  the first one with all the colors (as buttons)
+  the second is a sequence of colored buttons 
+  |#
+  
+  (define frame (make-object frame% TITLE #f WIDTH HIGHT))
+  
+  (define verti (make-object vertical-panel% frame))
+  
+  (define panel (make-object horizontal-panel% verti))
+  
+  (define guess-panels
+    (let ((p (make-object horizontal-panel% verti)))
+      (build-list GUESSES# (lambda (i) (make-object horizontal-panel% p)))))
+  
+  (for-each (lambda (p) (send p set-alignment 'center 'center)) guess-panels)
+  
+  (define message-panel (make-object horizontal-panel% verti))
+  (send message-panel set-alignment 'center 'center)
+  
+  (define message #f)
+  (define (add-message!)
+    (send message-panel change-children (lambda (x) null))
+    (set! message (make-object message% WELCOME message-panel)))
+  (define (add-winner!)
+    (send message-panel change-children (lambda (x) null))
+    (make-object message% TRUMPET message-panel)
+    (make-object button% "New Game?" message-panel new-game))
+  
+  #| ------------------------------------------------------------------------
+  Some additional functionality |#
+  
+  (define colored-button%
+    (class100 button% (color:str parent call-back [_width BUT-SIZE] [_height BUT-SIZE])
+      (private-field (width _width)
+                     (height _height))
+      (private
+        (make-colored-bm
+         (lambda (color:str)
+           (let* ([bm (make-object bitmap% width height)]
+                  [dc (make-object bitmap-dc% bm)])
+             (send dc set-brush (make-object brush% color:str 'solid))
+             (send dc draw-rectangle 0 0 width height)
+             (send dc set-bitmap #f)
+             bm))))
+      (public
+        (change-color
+         (lambda (color:str)
+           (send this set-label (make-colored-bm color:str))))) 
+      (sequence
+        (super-init (make-colored-bm color:str) parent call-back))
+      ))
+  
+  
+  (define (make-color-button color:sym)
+    (let ((color:str (symbol->string color:sym)))
+      (letrec ((this
+                (lambda (x y)
+                  (let* ((guess-button (pop!)))
+                    (send guess-button change-color color:str)
+                    (add-a-guess! color:sym)
+                    (if (pair? guesses)
+                        (send message set-label "Another guess, please!")
+                        (let ((response (check-now!)))
+                          (initialize-guesses)
+                          (send message set-label (symbol->string response))
+                          (when (memq response STOPS) (add-winner!))))))))
+        (make-object colored-button% color:str panel this))))
+  
+  ;; master : (color-symbol color-symbol color-symbol color-symbol -> symbol) -> ???
+  (define (master/proc cg)
+    (check-proc 'master cg 4 'first 'arguments)
+    (set! check-guess cg)
+    (send frame show #t))
+  
+  #| ------------------------------------------------------------------------
+  Setting up the buttons |#
+  
+  (for-each make-color-button COLORS)
+  
+  (define guess-buttons
+    (map (lambda (p) (make-object colored-button% "gray" p void)) guess-panels))
+  
+  ;; ------------------------------------------------------------------------
+  ;; State of Game
+  
+  (define choices null)
+  (define (new-game . x)
+    (add-message!)
+    (set! choices
+          (build-list GUESSES# (lambda (i) (list-ref COLORS (random COL#))))))
+  (new-game)
+  
+  (define guesses null)
+  (define (initialize-guesses)
+    (set! guesses guess-buttons))
+  (define (pop!)
+    (when (null? guesses) (error 'TeachMind "can't happen"))
+    (let ((g (car guesses)))
+      (set! guesses (cdr guesses))
+      g))
+  (initialize-guesses)
+  
+  (define guessed-colors null)
+  (define (add-a-guess! color:sym)
+    (set! guessed-colors (cons color:sym guessed-colors)))
+  (define (check-now!)
+    (begin0
+      (if (= GUESSES# 2)
+          (apply check-guess (append choices (reverse! guessed-colors)))
+          (check-guess choices (reverse! guessed-colors)))
+      (set! guessed-colors null)))
+  
+  ;; ------------------------------------------------------------------------
+  ;; Student Contribution
+  
+  (define check-guess #f))
diff --git a/collects/htdp/show-queen.ss b/collects/htdp/show-queen.ss
new file mode 100644
index 0000000000..1349b09ed7
--- /dev/null
+++ b/collects/htdp/show-queen.ss
@@ -0,0 +1 @@
+(module show-queen mzscheme (require (lib "encode-decode.ss" "framework" "private")) (decode ad56db8ee3360cfd15368b05eca6eecc60fbb05834cd1f14e81714b2cd444a65c923cbb9ec43bfbda464d97226b3e8167db2c5cb21451d512c6a3c2a0385c3d751398442ab1a369dc3f6e761d8c4bf4d39891b2d8681e525497a67cfaa4518a4bd54af23a221618b0765107a876765c7a13a38d1217c382caae6231401071a61ce62a0e541a16ea13857b515ae850fcf05e30fea2bc273397b3ef563ad55038532ca4330652bf43f40f2a42c075ffd76c6c65b0745277a5849a25399dc428422ea2a8de6e86582621b6baa5e28e3f3149c3a0b4f4e47f4a0e054ceee0e0fabff94922ac9aae4a4253aca9b1cab462b34be0ae179dd36e55c844ec56a7527fe2e91ed199de372735a78267fc0b3277d630db915bcdf01e997a4d0d1c998e3becc44e440f159c88749d9170589af99056772652d2d6e77f21bcb0f76346d650deea7d40eb457148dac06dab7b2c4222dbaba15b45b38c1156ee0a51aaa4bfc48f2b848242bc119ffba238b98c296fea225a392e20631876d8290cba1e559f0fe47a391c8144189c442efe9643a55ceab1374a7d99deaabe6ff5338c1e59c439409308bb38e61ac8ff0e167851c4e2e4187c51df652558d229d512c0a1d202174a7ef817bc48da84f67dc3681ab4cb1ff766203f3d56aeb0620ac4dad45f317b505ad8ed21f9db86d12c948db3a7121f2375e98a3c66f1060b93d8a6e8d970ee952196cabfab68f5598d4ef449f7ad23b5aeb283e6ecafbcc506bd50f18f9563ca5dc3eb321332d896414fd980c3e3dfdb22c6558962b2ec78c8b5de2dd2ea7dca30c8f8ebae59bcafdaff9ad0832b7ad37e77f884ca9ce428f480c2f8a0bf039ddb5a972e91a976af0d843f13a5acf7ab840b48042deab24ac9cb5b5a425aa3d93e04a1df740809d6d476d33946b6cfae9ce7155832a2530ed3a50e72b3abb870855424a6d9bfe5ecafbd8a710fbb68e2de7d8b7fbd8a707b1651efb36c596736cb98a7d80f76e56cc684bda97f211e23314d5b460b0bb6e586608ea0ee19a235c57084ba34d1419c61e5d65f09211e69eb87df8853a7c32dab255cfb72008bc445e55fce402c150f7745513ee76b09a505e22416870b05aa5d778c1abdd38c80c31ac1f6246cb98d43d66b6956fb497ecf232c42ebd0ebbf434ecb882d1b69ada73946e27e93649f3900f869e30eaac44c53237cdc3cca4fa934a348d65ab97878bb09f8d49c403cedcc1afe5caecba98d4d6d27363584659cef30d3d1a59e1b2296e83d79efa03b620c2fc04f6307f27ac01683bcaf4a3ff098ed67f81bf71b320c7d66846ad9774df8f46a71ca1a01b29488d14360e4f17451399088f2547e7425293dc64cd48f17ee3e4b60c7759d1de546807b94f56907f550f4e7572a55af0ca8e3457c5ea780b9df08d04eeb049cfd6d20f69a98c99cc87b785cbbaac41a26b1874c3981118b5bc3a9936ce448170e47489bf1f79cf356ad8fc0e7ff01e067e6c68e394f7a767ee8012f9010f8b798099481a60784aef85e3269e62a77b3a99ada6f0b7599161cc8a0bc9931afb9f6db89cff00))
\ No newline at end of file
diff --git a/collects/htdp/world.ss b/collects/htdp/world.ss
new file mode 100644
index 0000000000..55807ebb1e
--- /dev/null
+++ b/collects/htdp/world.ss
@@ -0,0 +1,245 @@
+#| TODO
+   I need
+    color? ;; Symbol -> Boolean 
+|#
+(module world mzscheme
+  (require ; (lib "unitsig.ss")
+   (lib "etc.ss")
+   (lib "class.ss")
+   (lib "mred.ss" "mred")
+   (lib "error.ss" "htdp")
+   (lib "image.ss" "htdp")
+   (prefix beg: (lib "htdp-beginner.ss" "lang"))
+   (lib "prim.ss" "lang"))
+  
+  ;; --- provide ---------------------------------------------------------------
+  (provide (all-from (lib "image.ss" "htdp")))
+  
+  (provide     ;; forall(World):
+   big-bang    ;; Number Number Number World -> true 
+   end-of-time ;; -> World
+
+   nw:rectangle ;; Number Number Mode Color -> Image
+   place-image  ;; Image Number Number Scence -> Scene
+   empty-scene  ;; Number Number -> Scene 
+   run-movie    ;; (Listof Image) -> true 
+   )
+  
+  (provide
+   update produce ;; (update <exp> produce <exp>)
+   )
+  
+  (provide-higher-order-primitive
+   on-tick-event (tock) ;; (World -> World) -> true
+   )
+  
+  (provide-higher-order-primitive ;; (KeyEvent World -> World) -> true 
+   on-key-event 
+   (tock)
+   )
+  ;; ---------------------------------------------------------------------------
+
+  ;; Symbol Any String -> Void
+  (define (check-pos tag c rank)
+    (check-arg tag (and (number? c) (>= c 0)) "positive number" rank c))
+  
+  ;; Symbol Any String [String] -> Void
+  (define (check-image tag i rank . other-message)
+    (if (and (pair? other-message) (string? (car other-message)))
+        (check-arg tag (beg:image? i) (car other-message) rank i)
+        (check-arg tag (beg:image? i) "image" rank i)))
+  
+  ;; Symbol Any String -> Void
+  (define (check-color tag width rank)
+    (check-arg tag (symbol? width) "color symbol" rank width))
+  
+  (define (check-mode tag s rank)
+    (check-arg tag (or (eq? s 'solid) (eq? s 'outline)) "'solid or 'outline" rank s))
+
+  (define (nw:rectangle width height mode color)
+    (check-pos 'rectangle width "first")
+    (check-pos 'rectangle height "second")
+    (check-mode 'rectangle mode "third")
+    (check-color 'rectangle color "fourth")
+    (move-pinhole (rectangle width height mode color) (/ width -2) (/ height -2)))
+  
+  (define (place-image image x y scene)
+    (check-image 'place-image image "first")
+    (check-pos 'place-image x "second")
+    (check-pos 'place-image y "third")
+    (check-image 'place-image scene "fourth" "scene")
+    (overlay/xy scene x y image))
+  
+  (define (empty-scene width height)
+    (check-pos 'empty-scene width "first")
+    (check-pos 'empty-scene height "second")    
+    (move-pinhole 
+     (rectangle width height 'outline 'black)
+     (/ width -2) (/ height -2))
+   )
+  
+  ;; display all images in list in the canvas
+  (define (run-movie movie)
+    (check-arg 'run-movie (list? movie) "list (of images)" "first" movie)
+    (for-each (lambda (cand) (check-image 'run-movie cand "first" "list of images"))
+              movie)
+    (let run-movie ([movie movie])
+      (cond [(null? movie) #t]
+            [(pair? movie)
+             (update (car movie) produce #t)
+             (sleep/yield .05)
+             (run-movie (cdr movie))])))
+  
+  ;; ---------------------------------------------------------------------------
+  
+  ;; The One and Only Visible World
+  (define the-frame #f)
+  (define txt (new text%))
+  
+  ;; World (type parameter)
+  (define the-world0 (cons 1 1))
+  [define the-world the-world0]
+  
+  (define (check-world tag)
+    (when (eq? the-world0 the-world) (error tag SEQUENCE-ERROR)))
+  
+  ;; Number > 0
+  [define the-delta 1000]
+
+  ;; Number Number Number World -> true
+  ;; create the visible world (canvas)
+  (define (big-bang w h delta world)
+    (check-arg 'big-bang (and (integer? w) (> w 0)) "positive integer" "first" w)
+    (check-arg 'big-bang (and (integer? h) (> h 0)) "positive integer" "second" h)
+    (check-arg 'big-bang
+               (and (number? delta) (>= delta 0))
+               "number [of seconds] between 0 and 1000000"
+               "first"
+               delta)
+    (when the-frame (error 'big-bang "big-bang already called once"))
+    (set! the-delta delta) 
+    (set! the-world world)
+    (set! the-frame
+          (new (class frame%
+                 (super-new)
+                 (define/augment (on-close)        
+                   ;; shut down the timer when the window is destroyed
+                   (send the-time stop)
+                   (inner (void) on-close)))
+               (label "DrScheme")))
+    (send 
+     (new (class editor-canvas%
+            (super-new)
+            (define/override (on-char e)
+              (on-char-proc (send e get-key-code))))
+          (parent the-frame) 
+          (editor txt)
+          (style '(no-hscroll no-vscroll))
+          ;; this 20 stuff is a hack, for now
+          (min-width (+ w 20))
+          (min-height (+ h 20)))
+     focus)
+    (send txt hide-caret #t)
+    (send the-frame show #t)
+    #t)
+  
+  ;; --- time events 
+  [define the-time (new timer% [notify-callback (lambda () (timer-callback))])]
+  
+  ;; (World -> World)
+  [define timer-callback void]
+  
+  ;; (World -> World) -> true
+  ;; set the click handler 
+  [define (on-tick-event f)
+    (check-proc 'on-tick-event f 1 "on-tick-event" "one argument")
+    (check-world 'on-tick-event)
+    (if (eq? timer-callback void)
+        (set! timer-callback 
+              (lambda ()
+                (with-handlers ([exn:break? break-handler]
+                                [exn? exn-handler])
+                  (set! the-world (f the-world)))))
+        (error 'on-tick "the timing action has been set already"))
+    (send the-time start
+          (let* ([w (ceiling (* 1000 the-delta))])
+            (if (exact? w) w (inexact->exact w))))
+    #t]
+  
+  ;; --- key events 
+  ;; KeyEvent = (union Symbol Char)
+  
+  ;; KeyEvent -> Void
+  [define on-char-proc void]
+  
+  ;; (KeyEvent World -> World) -> true
+  ;; effect: set on-char-proc so that it deals with keyboard events
+  [define (on-key-event f)
+    (check-proc 'on-key-event f 2 "on-key-event" "two arguments")
+    (check-world 'on-key-event)
+    (let ([esp (current-eventspace)])
+      (if (eq? on-char-proc void)
+          (begin 
+            (set! on-char-proc 
+                  (lambda (e)
+                    (parameterize ([current-eventspace esp])
+                      (queue-callback 
+                       (lambda ()
+                         (with-handlers ([exn:break? break-handler]
+                                         [exn? exn-handler])
+                           (set! the-world (f e the-world))))
+                       #t))))
+            #t)
+          (error 'on-event "the event action has been set already")))]
+  
+  [define (end-of-time)
+    (printf "end of time~n")
+    (stop-it)
+    the-world]
+  
+  ;; --- library 
+  [define (exn-handler e)
+    (send the-time stop)
+    (set! on-char-proc void)
+    (set! timer-callback void)
+    (raise e)]
+  
+  [define (break-handler . _) 
+    (printf "animation stopped")
+    (stop-it)
+    the-world]
+  
+  ;; -> Void
+  (define (stop-it)
+    (send the-time stop)
+    (set! on-char-proc void)
+    (set! timer-callback void))
+  
+  ;; --- putting images into the canvas
+  (define-syntax (produce stx) 
+    (raise-syntax-error 'produce "produce must be inside a use of update" stx))
+  
+  (define-syntax (update s)
+    (syntax-case s (produce)
+      [(_ pict produce exp) (syntax (begin (update-frame pict) exp))]
+      [(_ pict pict2 ... produce exp)
+       (raise-syntax-error 'update "you can place only one picture in the canvas" s)]
+      [(_ stmt produce) 
+       (raise-syntax-error 'update "produce must be followed by an expression" s)]
+      [(_ stmt produce exp exp2 ...)
+       (raise-syntax-error 'update "produce must be followed by exactly one expression" s)]
+      [_
+       (raise-syntax-error 'update "use as (update <image> produce <expression>)")]))
+  
+  (define (update-frame pict)
+    (unless the-frame (error 'update SEQUENCE-ERROR))
+    (send txt begin-edit-sequence)
+    (send txt lock #f)
+    (send txt delete 0 (send txt last-position) #f)
+    (send txt insert (send pict copy) 0 0 #f)
+    (send txt lock #t)
+    (send txt end-edit-sequence))
+  
+  (define SEQUENCE-ERROR "evaluate (big-bang Number Number Number World) first")
+  )
+
diff --git a/collects/html/case.ss b/collects/html/case.ss
new file mode 100644
index 0000000000..f7ce69c141
--- /dev/null
+++ b/collects/html/case.ss
@@ -0,0 +1,489 @@
+;;This file was generated by genrate-code.ss on Friday, September 1st, 2000 11:09:43am
+
+;; xml-single-content->html : Content (listof Html-content) -> (listof Html-content)
+(define (xml-single-content->html x acc)
+  (cond
+   ((element? x)
+    (case (element-name x)
+      ((basefont) (cons (make-basefont (element-attributes x)) acc))
+      ((br) (cons (make-br (element-attributes x)) acc))
+      ((area) (cons (make-area (element-attributes x)) acc))
+      ((link) (cons (make-link (element-attributes x)) acc))
+      ((img) (cons (make-img (element-attributes x)) acc))
+      ((param) (cons (make-param (element-attributes x)) acc))
+      ((hr) (cons (make-hr (element-attributes x)) acc))
+      ((input) (cons (make-input (element-attributes x)) acc))
+      ((col) (cons (make-col (element-attributes x)) acc))
+      ((isindex) (cons (make-isindex (element-attributes x)) acc))
+      ((base) (cons (make-base (element-attributes x)) acc))
+      ((meta) (cons (make-meta (element-attributes x)) acc))
+      ((mzscheme)
+       (cons
+        (make-mzscheme
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((html)
+       (cons
+        (make-html
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((div)
+       (cons
+        (make-div
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((center)
+       (cons
+        (make-center
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((blockquote)
+       (cons
+        (make-blockquote
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((ins)
+       (cons
+        (make-ins
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((del)
+       (cons
+        (make-del
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((dd)
+       (cons
+        (make-dd
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((li)
+       (cons
+        (make-li
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((th)
+       (cons
+        (make-th
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((td)
+       (cons
+        (make-td
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((iframe)
+       (cons
+        (make-iframe
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((noframes)
+       (cons
+        (make-noframes
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((noscript)
+       (cons
+        (make-noscript
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((style)
+       (cons
+        (make-style
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((script)
+       (cons
+        (make-script
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((option)
+       (cons
+        (make-option
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((textarea)
+       (cons
+        (make-textarea
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((title)
+       (cons
+        (make-title
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((head)
+       (cons
+        (make-head
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((tr)
+       (cons
+        (make-tr
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((colgroup)
+       (cons
+        (make-colgroup
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((thead)
+       (cons
+        (make-thead
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((tfoot)
+       (cons
+        (make-tfoot
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((tbody)
+       (cons
+        (make-tbody
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((tt)
+       (cons
+        (make-tt
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((i)
+       (cons
+        (make-i
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((b)
+       (cons
+        (make-b
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((u)
+       (cons
+        (make-u
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((s)
+       (cons
+        (make-s
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((strike)
+       (cons
+        (make-strike
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((big)
+       (cons
+        (make-big
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((small)
+       (cons
+        (make-small
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((em)
+       (cons
+        (make-em
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((strong)
+       (cons
+        (make-strong
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((dfn)
+       (cons
+        (make-dfn
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((code)
+       (cons
+        (make-code
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((samp)
+       (cons
+        (make-samp
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((kbd)
+       (cons
+        (make-kbd
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((var)
+       (cons
+        (make-var
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((cite)
+       (cons
+        (make-cite
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((abbr)
+       (cons
+        (make-abbr
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((acronym)
+       (cons
+        (make-acronym
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((sub)
+       (cons
+        (make-sub
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((sup)
+       (cons
+        (make-sup
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((span)
+       (cons
+        (make-span
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((bdo)
+       (cons
+        (make-bdo
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((font)
+       (cons
+        (make-font
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((p)
+       (cons
+        (make-p
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((h1)
+       (cons
+        (make-h1
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((h2)
+       (cons
+        (make-h2
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((h3)
+       (cons
+        (make-h3
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((h4)
+       (cons
+        (make-h4
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((h5)
+       (cons
+        (make-h5
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((h6)
+       (cons
+        (make-h6
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((q)
+       (cons
+        (make-q
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((dt)
+       (cons
+        (make-dt
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((legend)
+       (cons
+        (make-legend
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((caption)
+       (cons
+        (make-caption
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((table)
+       (cons
+        (make-table
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((button)
+       (cons
+        (make-button
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((fieldset)
+       (cons
+        (make-fieldset
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((optgroup)
+       (cons
+        (make-optgroup
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((select)
+       (cons
+        (make-select
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((label)
+       (cons
+        (make-label
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((form)
+       (cons
+        (make-form
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((ol)
+       (cons
+        (make-ol
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((ul)
+       (cons
+        (make-ul
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((dir)
+       (cons
+        (make-dir
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((menu)
+       (cons
+        (make-menu
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((dl)
+       (cons
+        (make-dl
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((pre)
+       (cons
+        (make-pre
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((object)
+       (cons
+        (make-object (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((applet)
+       (cons
+        (make-applet
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((map)
+       (cons
+        (make--map
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((a)
+       (cons
+        (make-a
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((address)
+       (cons
+        (make-address
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      ((body)
+       (cons
+        (make-body
+          (element-attributes x)
+          (xml-contents->html (element-content x)))
+        acc))
+      (else acc)))
+   ((or (pcdata? x) (entity? x)) (cons x acc))
+   (else acc)))
diff --git a/collects/html/doc.txt b/collects/html/doc.txt
new file mode 100644
index 0000000000..64bdc9be00
--- /dev/null
+++ b/collects/html/doc.txt
@@ -0,0 +1,460 @@
+_HTML_ Library, _html.ss_
+=========================
+
+(require (lib "html.ss" "html")) will provide functions to read
+html documents and structures to represent them.
+
+Functions:
+==========
+
+> read-xhtml : [Input-port] -> Html
+
+> read-html : [Input-port] -> Html
+
+> read-html-as-xml : [Input-port] -> (listof Content)
+  See the XML library for the definition of Content
+
+HTML Structures:
+================
+
+Pcdata, Entity, and Attribute are defined in the XML documentation.
+
+> Html-content = Html-element | Pcdata | Entity
+
+> Html-element = any of the structures below which all inherit from
+  (define-struct html-element (attributes)).  Any html tag that may
+  include content also inherits from
+  (define-struct (html-full struct:html-element) (content))
+  without adding any additional fields.
+
+A Html is
+(make-html (listof Attribute) (listof Contents-of-html))
+
+A Contents-of-html is either
+  - Body
+  - Head
+
+A Div is
+(make-div (listof Attribute) G2)
+
+A Center is
+(make-center (listof Attribute) G2)
+
+A Blockquote is
+(make-blockquote (listof Attribute) G2)
+
+An Ins is
+(make-ins (listof Attribute) G2)
+
+A Del is
+(make-del (listof Attribute) G2)
+
+A Dd is
+(make-dd (listof Attribute) G2)
+
+A Li is
+(make-li (listof Attribute) G2)
+
+A Th is
+(make-th (listof Attribute) G2)
+
+A Td is
+(make-td (listof Attribute) G2)
+
+An Iframe is
+(make-iframe (listof Attribute) G2)
+
+A Noframes is
+(make-noframes (listof Attribute) G2)
+
+A Noscript is
+(make-noscript (listof Attribute) G2)
+
+A Style is
+(make-style (listof Attribute) Cdata)
+
+A Script is
+(make-script (listof Attribute) Cdata)
+
+A Basefont is
+(make-basefont (listof Attribute))
+
+A Br is
+(make-br (listof Attribute))
+
+An Area is
+(make-area (listof Attribute))
+
+A Link is
+(make-link (listof Attribute))
+
+An Img is
+(make-img (listof Attribute))
+
+A Param is
+(make-param (listof Attribute))
+
+A Hr is
+(make-hr (listof Attribute))
+
+An Input is
+(make-input (listof Attribute))
+
+A Col is
+(make-col (listof Attribute))
+
+An Isindex is
+(make-isindex (listof Attribute))
+
+A Base is
+(make-base (listof Attribute))
+
+A Meta is
+(make-meta (listof Attribute))
+
+An Option is
+(make-option (listof Attribute) Pcdata)
+
+A Textarea is
+(make-textarea (listof Attribute) Pcdata)
+
+A Title is
+(make-title (listof Attribute) Pcdata)
+
+A Head is
+(make-head (listof Attribute) (listof Contents-of-head))
+
+A Contents-of-head is either
+  - Base
+  - Isindex
+  - Link
+  - Meta
+  - Object
+  - Script
+  - Style
+  - Title
+
+A Tr is
+(make-tr (listof Attribute) (listof Contents-of-tr))
+
+A Contents-of-tr is either
+  - Td
+  - Th
+
+A Colgroup is
+(make-colgroup (listof Attribute) Col)
+
+A Thead is
+(make-thead (listof Attribute) Tr)
+
+A Tfoot is
+(make-tfoot (listof Attribute) Tr)
+
+A Tbody is
+(make-tbody (listof Attribute) Tr)
+
+A Tt is
+(make-tt (listof Attribute) G5)
+
+An I is
+(make-i (listof Attribute) G5)
+
+A B is
+(make-b (listof Attribute) G5)
+
+An U is
+(make-u (listof Attribute) G5)
+
+A S is
+(make-s (listof Attribute) G5)
+
+A Strike is
+(make-strike (listof Attribute) G5)
+
+A Big is
+(make-big (listof Attribute) G5)
+
+A Small is
+(make-small (listof Attribute) G5)
+
+An Em is
+(make-em (listof Attribute) G5)
+
+A Strong is
+(make-strong (listof Attribute) G5)
+
+A Dfn is
+(make-dfn (listof Attribute) G5)
+
+A Code is
+(make-code (listof Attribute) G5)
+
+A Samp is
+(make-samp (listof Attribute) G5)
+
+A Kbd is
+(make-kbd (listof Attribute) G5)
+
+A Var is
+(make-var (listof Attribute) G5)
+
+A Cite is
+(make-cite (listof Attribute) G5)
+
+An Abbr is
+(make-abbr (listof Attribute) G5)
+
+An Acronym is
+(make-acronym (listof Attribute) G5)
+
+A Sub is
+(make-sub (listof Attribute) G5)
+
+A Sup is
+(make-sup (listof Attribute) G5)
+
+A Span is
+(make-span (listof Attribute) G5)
+
+A Bdo is
+(make-bdo (listof Attribute) G5)
+
+A Font is
+(make-font (listof Attribute) G5)
+
+A P is
+(make-p (listof Attribute) G5)
+
+A H1 is
+(make-h1 (listof Attribute) G5)
+
+A H2 is
+(make-h2 (listof Attribute) G5)
+
+A H3 is
+(make-h3 (listof Attribute) G5)
+
+A H4 is
+(make-h4 (listof Attribute) G5)
+
+A H5 is
+(make-h5 (listof Attribute) G5)
+
+A H6 is
+(make-h6 (listof Attribute) G5)
+
+A Q is
+(make-q (listof Attribute) G5)
+
+A Dt is
+(make-dt (listof Attribute) G5)
+
+A Legend is
+(make-legend (listof Attribute) G5)
+
+A Caption is
+(make-caption (listof Attribute) G5)
+
+A Table is
+(make-table (listof Attribute) (listof Contents-of-table))
+
+A Contents-of-table is either
+  - Caption
+  - Col
+  - Colgroup
+  - Tbody
+  - Tfoot
+  - Thead
+
+A Button is
+(make-button (listof Attribute) G4)
+
+A Fieldset is
+(make-fieldset (listof Attribute) (listof Contents-of-fieldset))
+
+A Contents-of-fieldset is either
+  - Legend
+  - G2
+
+An Optgroup is
+(make-optgroup (listof Attribute) Option)
+
+A Select is
+(make-select (listof Attribute) (listof Contents-of-select))
+
+A Contents-of-select is either
+  - Optgroup
+  - Option
+
+A Label is
+(make-label (listof Attribute) G6)
+
+A Form is
+(make-form (listof Attribute) G3)
+
+An Ol is
+(make-ol (listof Attribute) Li)
+
+An Ul is
+(make-ul (listof Attribute) Li)
+
+A Dir is
+(make-dir (listof Attribute) Li)
+
+A Menu is
+(make-menu (listof Attribute) Li)
+
+A Dl is
+(make-dl (listof Attribute) (listof Contents-of-dl))
+
+A Contents-of-dl is either
+  - Dd
+  - Dt
+
+A Pre is
+(make-pre (listof Attribute) (listof Contents-of-pre))
+
+A Contents-of-pre is either
+  - G9
+  - G11
+
+An Object is
+(make-object (listof Attribute) (listof Contents-of-object-applet))
+
+An Applet is
+(make-applet (listof Attribute) (listof Contents-of-object-applet))
+
+A Contents-of-object-applet is either
+  - Param
+  - G2
+
+A Map is
+(make-map (listof Attribute) (listof Contents-of-map))
+
+A Contents-of-map is either
+  - Area
+  - Fieldset
+  - Form
+  - Isindex
+  - G10
+
+An A is
+(make-a (listof Attribute) (listof Contents-of-a))
+
+A Contents-of-a is either
+  - Label
+  - G7
+
+An Address is
+(make-address (listof Attribute) (listof Contents-of-address))
+
+A Contents-of-address is either
+  - P
+  - G5
+
+A Body is
+(make-body (listof Attribute) (listof Contents-of-body))
+
+A Contents-of-body is either
+  - Del
+  - Ins
+  - G2
+
+A G12 is either
+  - Button
+  - Iframe
+  - Input
+  - Select
+  - Textarea
+
+A G11 is either
+  - A
+  - Label
+  - G12
+
+A G10 is either
+  - Address
+  - Blockquote
+  - Center
+  - Dir
+  - Div
+  - Dl
+  - H1
+  - H2
+  - H3
+  - H4
+  - H5
+  - H6
+  - Hr
+  - Menu
+  - Noframes
+  - Noscript
+  - Ol
+  - P
+  - Pre
+  - Table
+  - Ul
+
+A G9 is either
+  - Abbr
+  - Acronym
+  - B
+  - Bdo
+  - Br
+  - Cite
+  - Code
+  - Dfn
+  - Em
+  - I
+  - Kbd
+  - Map
+  - Pcdata
+  - Q
+  - S
+  - Samp
+  - Script
+  - Span
+  - Strike
+  - Strong
+  - Tt
+  - U
+  - Var
+
+A G8 is either
+  - Applet
+  - Basefont
+  - Big
+  - Font
+  - Img
+  - Object
+  - Small
+  - Sub
+  - Sup
+  - G9
+
+A G7 is either
+  - G8
+  - G12
+
+A G6 is either
+  - A
+  - G7
+
+A G5 is either
+  - Label
+  - G6
+
+A G4 is either
+  - G8
+  - G10
+
+A G3 is either
+  - Fieldset
+  - Isindex
+  - G4
+  - G11
+
+A G2 is either
+  - Form
+  - G3
+
diff --git a/collects/html/dtd-ast.ss b/collects/html/dtd-ast.ss
new file mode 100644
index 0000000000..f318342cff
--- /dev/null
+++ b/collects/html/dtd-ast.ss
@@ -0,0 +1,23 @@
+;; copyright by Paul Graunke June 2000 AD
+(module dtd-ast mzscheme
+  (provide (struct dtd-item ())
+           (struct element-def (name start-optional stop-optional content))
+           (struct att-list (name junk))
+           (struct entity-def (name value))
+           (struct thingy (uh whatever)))
+  
+  
+  ;; Dtd ::= (listof Dtd-item)
+  ;; Dtd-item ::= (make-element-def (listof Symbol) Bool Bool Content-model)
+  ;;           |  (make-att-list (listof Symbol) String) ;; more here - parse the String
+  ;;           |  (make-entity-def Symbol String)
+  ;;           |  (make-thingy String String) ;; more here - what is <![ foo [ bar baz...]]> this?
+  (define-struct dtd-item ())
+  (define-struct (element-def struct:dtd-item) (name start-optional stop-optional content))
+  (define-struct (att-list struct:dtd-item) (name junk))
+  (define-struct (entity-def struct:dtd-item) (name value))
+  (define-struct (thingy struct:dtd-item) (uh whatever))
+  
+  ;; Content-model ::= String
+  ;; more here - parse content-models
+  )
diff --git a/collects/html/dtd.ss b/collects/html/dtd.ss
new file mode 100644
index 0000000000..83f50e7e0b
--- /dev/null
+++ b/collects/html/dtd.ss
@@ -0,0 +1,205 @@
+; copyright by Paul Graunke June 2000 AD
+(module dtd mzscheme
+  (require "dtd-ast.ss" "entity-expander.ss"
+           (lib "list.ss")
+           (lib "string.ss"))
+  
+  (provide read-sgml-dtd summarize-dtd)
+  
+  ; Note: this library only supports a the subset of SGML used for HTML as descibed in
+  ; http://www.w3.org/TR/html401/intro/sgmltut.html
+  
+  ; Spec = (listof (cons (listof Symbol) (listof Symbol)))
+  
+  ; read-sgml-dtd : Input-port -> Dtd
+  (define (read-sgml-dtd in)
+    (parameterize ([read-case-sensitive #t])
+      (let ([in (filter-comments in)])
+        (let read-items ()
+          (let skip-entity-refs ()
+            (skip-whitespace in)
+            (when (eq? (peek-char in) #\%)
+              (skip-until (lambda (c) (eq? c #\;)) in)
+              (skip-entity-refs)))
+          (cond
+            [(eof-object? (peek-char in)) null]
+            [else
+             (unless (and (eq? (read-char in) #\<)
+                          (eq? (read-char in) #\!))
+               (error 'read-sgml-dtd "unknown junk in dtd at ~a" (file-position in)))
+             (case (peek-char in)
+               [(#\>) (read-char in) (read-items)]
+               [(#\[) (read-char in)
+                (skip-whitespace in)
+                (let ([uh (read-id in)])
+                  (skip-until (lambda (c) (eq? c #\[)) in)
+                  (cons (begin0 (make-thingy uh (read-until (lambda (c) (eq? c #\])) in))
+                                (unless (and (eq? (read-char in) #\]) (eq? (read-char in) #\>))
+                                  (error 'read-sgml-dtd "Invalid <![ uh [ whatever ]]> thingy.")))
+                        (read-items)))]
+               [else (cons (let ([name (read-id in)])
+                             (case name
+                               [(entity) (skip-until (lambda (c) (eq? c #\%)) in)
+                                (skip-whitespace in)
+                                (begin0 (make-entity-def (read-until char-whitespace? in); more here check case sensitivity ; (read-id in)
+                                                         (begin (skip-until quote? in) (read-until quote? in)))
+                                        (skip-until gt? in))]
+                               [(element)
+                                (make-element-def (read-names in)
+                                                  (read-required/optional in)
+                                                  (read-required/optional in)
+                                                  (read-until gt? in))]
+                               [(attlist)
+                                (make-att-list (read-names in) (read-until gt? in))]
+                               [else (error 'read-sgml-dtd "Unknown name: <!~s ...>" name)]))
+                           (read-items))])])))))
+  
+  ; quote? : Char -> Bool
+  (define (quote? c) (eq? c #\"))
+  ; gt? : Char -> Bool
+  (define (gt? c) (eq? c #\>))
+  
+  ; read-names : Input-port -> (listof Symbol)
+  (define (read-names in)
+    (skip-whitespace in)
+    (case (peek-char in)
+      [(#\() (read-char in)
+       (skip-whitespace in)
+       (cons (read-id in)
+             (let loop ()
+               (skip-whitespace in)
+               (case (read-char in)
+                 [(#\| #\,) (skip-whitespace in) (cons (read-id in) (loop))]
+                 [(#\)) null]               
+                 [else (error 'read-names "unexpected character in element names '~a'" (read-line in))])))]
+      [else (list (read-id in))]))
+  
+  ; read-required/optional : Input-port -> Bool
+  (define (read-required/optional in)
+    (skip-whitespace in)
+    (eq? (char-downcase (read-char in)) #\o))
+  
+  ; read-id : Input-port -> Symbol
+  (define (read-id in)
+    (string->symbol
+     (list->string
+      (let loop ()
+        (let ([c (peek-char in)])
+          (if (and (not (eof-object? c))
+                   (or (char-id? c)
+                       ; this is a hack - allowing % and ; characters accepts parameter entities.
+                       (memq c '(#\% #\;))))
+              (cons (char-downcase c) (begin (read-char in) (loop)))
+              null))))))
+  
+  ; char-id? : Char -> Bool
+  ; Note: the & is not legal, really, but SEC's Edgar format uses it. Yuck.
+  ; Nope. & messes up SGML dtds - remove it.
+  (define (char-id? c)
+    (or (char-alphabetic? c) (char-numeric? c) (memq c '(#\_ #\- #\: #\.))))
+  
+  ; skip-whitespace : Input-port -> Void
+  (define (skip-whitespace in) (skip-past char-whitespace? in))
+  
+  ; skip-past : (Char -> Bool) Input-port -> Void
+  (define (skip-past skip? in)
+    (let loop ()
+      (when (let ([c (peek-char in)])
+              (and (not (eof-object? c)) (skip? c)))
+        (read-char in)
+        (loop))))
+  
+  ; skip-until : (Char -> Bool) Input-port -> Void
+  (define (skip-until delimiter? in)
+    (let loop ()
+      (unless (delimiter? (read-char in))
+        (loop))))
+  
+  ; read-until : (Char -> Bool) Input-port -> String
+  ; skips delimiter
+  (define (read-until delimiter? in)
+    (list->string
+     (let loop ()
+       (let ([c (read-char in)])
+         (if (delimiter? c)
+             null
+             (cons c (loop)))))))
+  
+  ; filter-comments : Input-port -> Input-port
+  ; Note: <!-- blah --> comments come out <!>, which need to be removed later.
+  (define (filter-comments in)
+    (make-input-port
+     (lambda ()
+       (let ([char (read-char in)])
+         (if (and (eq? char #\-) (eq? (peek-char in) #\-))
+             (let loop ()
+               (if (and (eq? (read-char in) #\-) (eq? (read-char in) #\-))
+                   (read-char in)
+                   (loop)))
+             char)))
+     (lambda ()
+       ; more here - this is broken if the next char is #\- and starts a comment and more chars
+       ; aren't ready after the comment.
+       (char-ready? in))
+     (lambda () (close-input-port in))))
+  
+  ; summarize-dtd : Dtd -> Spec
+  (define (summarize-dtd dtd)
+    (let ([expander
+           (foldr (lambda (x acc)
+                    (extend-entity-expander (entity-def-name x) (entity-def-value x) acc))
+                  empty-entity-expander
+                  (filter entity-def? dtd))]
+          [hack-content ;: String -> (listof Symbol)
+           (lambda (content)
+             (let* ([stripped (filter (lambda (x) (not (char-whitespace? x))) (string->list content))]
+                    [cludged (map (lambda (c)
+                                    (cond
+                                      [(char-id? c) c]
+                                      [else #\space]))
+                                  stripped)]
+                    [symbols (read-from-string-all (list->string cludged))]
+                    [nix (memq '- symbols)])
+               (cond
+                 [nix (filter (lambda (s) (not (memq s nix))) symbols)]
+                 [(and (pair? symbols) (null? (cdr symbols)) (eq? (car symbols) 'empty)) null]
+                 [else symbols])))])
+      (merge-contents 
+       (map (lambda (x)
+              (cons (foldr (lambda (s acc)
+                             (let ([in (open-input-string 
+                                        (format "(~a)" (expand-entities expander (symbol->string s))))])
+                               (append (read-names in) acc)))
+                           null
+                           (element-def-name x))
+                    (quicksort (hack-content (expand-entities expander (element-def-content x)))
+                               (lambda (a b)
+                                 (string<=? (symbol->string a)
+                                            (symbol->string b))))))
+            (filter element-def? dtd)))))
+  
+  ; merge-contents : Spec -> Spec
+  (define merge-contents
+    (letrec ([comb
+              (lambda (x rst)
+                (cond
+                  [(null? rst) (list x)]
+                  [else (cond
+                          [(equal? (cdr x) (cdar rst))
+                           (cons (cons (append (car x) (caar rst))
+                                       (cdr x))
+                                 (cdr rst))]
+                          [else (cons (car rst) (comb x (cdr rst)))])]))])
+      (lambda (lst)
+        (cond
+          [(null? lst) null]
+          [else (comb (car lst)
+                      (merge-contents (cdr lst)))])))))
+
+
+
+; loosedtd.txt is from www.w3c.org's html4.0.1 spec.
+;(define dtd (call-with-input-file "/home/ptg/world/junk/loosedtd.txt" read-sgml-dtd))
+;(call-with-output-file "html-spec"
+;  (lambda (out) (write (cons '((mzscheme) pcdata) (summarize-dtd dtd)) out))
+;  'truncate)
\ No newline at end of file
diff --git a/collects/html/dtdr.ss b/collects/html/dtdr.ss
new file mode 100644
index 0000000000..866a2b7355
--- /dev/null
+++ b/collects/html/dtdr.ss
@@ -0,0 +1,192 @@
+;; copyright by Paul Graunke June 2000 AD
+(unit/sig dtd^
+  (import dtd-ast^ entity-expander^ mzlib:function^ mzlib:string^)
+  ;; Note: this library only supports a the subset of SGML used for HTML as descibed in
+  ;; http://www.w3.org/TR/html401/intro/sgmltut.html
+  
+  ;; Spec = (listof (cons (listof Symbol) (listof Symbol)))
+  
+  ;; read-sgml-dtd : Input-port -> Dtd
+  (define (read-sgml-dtd in)
+    (parameterize ([read-case-sensitive #t])
+      (let ([in (filter-comments in)])
+        (let read-items ()
+          (let skip-entity-refs ()
+            (skip-whitespace in)
+            (when (eq? (peek-char in) #\%)
+              (skip-until (lambda (c) (eq? c #\;)) in)
+              (skip-entity-refs)))
+          (cond
+            [(eof-object? (peek-char in)) null]
+            [else
+             (unless (and (eq? (read-char in) #\<)
+                          (eq? (read-char in) #\!))
+               (error 'read-sgml-dtd "unknown junk in dtd at ~a" (file-position in)))
+             (case (peek-char in)
+               [(#\>) (read-char in) (read-items)]
+               [(#\[) (read-char in)
+                (skip-whitespace in)
+                (let ([uh (read-id in)])
+                  (skip-until (lambda (c) (eq? c #\[)) in)
+                  (cons (begin0 (make-thingy uh (read-until (lambda (c) (eq? c #\])) in))
+                                (unless (and (eq? (read-char in) #\]) (eq? (read-char in) #\>))
+                                  (error 'read-sgml-dtd "Invalid <![ uh [ whatever ]]> thingy.")))
+                        (read-items)))]
+               [else (cons (let ([name (read-id in)])
+                             (case name
+                               [(entity) (skip-until (lambda (c) (eq? c #\%)) in)
+                                (skip-whitespace in)
+                                (begin0 (make-entity-def (read-until char-whitespace? in); more here check case sensitivity ; (read-id in)
+                                                         (begin (skip-until quote? in) (read-until quote? in)))
+                                        (skip-until gt? in))]
+                               [(element)
+                                (make-element-def (read-names in)
+                                                  (read-required/optional in)
+                                                  (read-required/optional in)
+                                                  (read-until gt? in))]
+                               [(attlist)
+                                (make-att-list (read-names in) (read-until gt? in))]
+                               [else (error 'read-sgml-dtd "Unknown name: <!~s ...>" name)]))
+                           (read-items))])])))))
+  
+  ;; quote? : Char -> Bool
+  (define (quote? c) (eq? c #\"))
+  ;; gt? : Char -> Bool
+  (define (gt? c) (eq? c #\>))
+  
+  ;; read-names : Input-port -> (listof Symbol)
+  (define (read-names in)
+    (skip-whitespace in)
+    (case (peek-char in)
+      [(#\() (read-char in)
+       (skip-whitespace in)
+       (cons (read-id in)
+             (let loop ()
+               (skip-whitespace in)
+               (case (read-char in)
+                 [(#\| #\,) (skip-whitespace in) (cons (read-id in) (loop))]
+                 [(#\)) null]               
+                 [else (error 'read-names "unexpected character in element names '~a'" (read-line in))])))]
+      [else (list (read-id in))]))
+  
+  ;; read-required/optional : Input-port -> Bool
+  (define (read-required/optional in)
+    (skip-whitespace in)
+    (eq? (char-downcase (read-char in)) #\o))
+  
+  ;; read-id : Input-port -> Symbol
+  (define (read-id in)
+    (string->symbol
+     (list->string
+      (let loop ()
+        (let ([c (peek-char in)])
+          (if (and (not (eof-object? c))
+                   (or (char-id? c)
+                       ;; this is a hack - allowing % and ; characters accepts parameter entities.
+                       (memq c '(#\% #\;))))
+              (cons (char-downcase c) (begin (read-char in) (loop)))
+              null))))))
+  
+  ;; char-id? : Char -> Bool
+  ;; Note: the & is not legal, really, but SEC's Edgar format uses it. Yuck.
+  ;; Nope. & messes up SGML dtds - remove it.
+  (define (char-id? c)
+    (or (char-alphabetic? c) (char-numeric? c) (memq c '(#\_ #\- #\: #\.))))
+  
+  ;; skip-whitespace : Input-port -> Void
+  (define (skip-whitespace in) (skip-past char-whitespace? in))
+  
+  ;; skip-past : (Char -> Bool) Input-port -> Void
+  (define (skip-past skip? in)
+    (let loop ()
+      (when (let ([c (peek-char in)])
+              (and (not (eof-object? c)) (skip? c)))
+        (read-char in)
+        (loop))))
+  
+  ;; skip-until : (Char -> Bool) Input-port -> Void
+  (define (skip-until delimiter? in)
+    (let loop ()
+      (unless (delimiter? (read-char in))
+        (loop))))
+  
+  ;; read-until : (Char -> Bool) Input-port -> String
+  ;; skips delimiter
+  (define (read-until delimiter? in)
+    (list->string
+     (let loop ()
+       (let ([c (read-char in)])
+         (if (delimiter? c)
+             null
+             (cons c (loop)))))))
+  
+  ;; filter-comments : Input-port -> Input-port
+  ;; Note: <!-- blah --> comments come out <!>, which need to be removed later.
+  (define (filter-comments in)
+    (make-input-port
+     (lambda ()
+       (let ([char (read-char in)])
+         (if (and (eq? char #\-) (eq? (peek-char in) #\-))
+             (let loop ()
+               (if (and (eq? (read-char in) #\-) (eq? (read-char in) #\-))
+                   (read-char in)
+                   (loop)))
+             char)))
+     (lambda ()
+       ;; more here - this is broken if the next char is #\- and starts a comment and more chars
+       ;; aren't ready after the comment.
+       (char-ready? in))
+     (lambda () (close-input-port in))))
+  
+  ;; summarize-dtd : Dtd -> Spec
+  (define (summarize-dtd dtd)
+    (let ([expander
+           (foldr (lambda (x acc)
+                    (extend-entity-expander (entity-def-name x) (entity-def-value x) acc))
+                  empty-entity-expander
+                  (filter entity-def? dtd))]
+          [hack-content ;: String -> (listof Symbol)
+           (lambda (content)
+             (let* ([stripped (filter (lambda (x) (not (char-whitespace? x))) (string->list content))]
+                    [cludged (map (lambda (c)
+                                    (cond
+                                      [(char-id? c) c]
+                                      [else #\space]))
+                                  stripped)]
+                    [symbols (read-from-string-all (list->string cludged))]
+                    [nix (memq '- symbols)])
+               (cond
+                 [nix (filter (lambda (s) (not (memq s nix))) symbols)]
+                 [(and (pair? symbols) (null? (cdr symbols)) (eq? (car symbols) 'empty)) null]
+                 [else symbols])))])
+      (merge-contents 
+       (map (lambda (x)
+              (cons (foldr (lambda (s acc)
+                             (let ([in (open-input-string 
+                                        (format "(~a)" (expand-entities expander (symbol->string s))))])
+                               (append (read-names in) acc)))
+                           null
+                           (element-def-name x))
+                    (quicksort (hack-content (expand-entities expander (element-def-content x)))
+                               (lambda (a b)
+                                 (string<=? (symbol->string a)
+                                            (symbol->string b))))))
+            (filter element-def? dtd)))))
+  
+  ;; merge-contents : Spec -> Spec
+  (define merge-contents
+    (letrec ([comb
+              (lambda (x rst)
+                (cond
+                  [(null? rst) (list x)]
+                  [else (cond
+                          [(equal? (cdr x) (cdar rst))
+                           (cons (cons (append (car x) (caar rst))
+                                       (cdr x))
+                                 (cdr rst))]
+                          [else (cons (car rst) (comb x (cdr rst)))])]))])
+      (lambda (lst)
+        (cond
+          [(null? lst) null]
+          [else (comb (car lst)
+                      (merge-contents (cdr lst)))])))))
diff --git a/collects/html/dtds.ss b/collects/html/dtds.ss
new file mode 100644
index 0000000000..439d7d02ba
--- /dev/null
+++ b/collects/html/dtds.ss
@@ -0,0 +1,13 @@
+;; copyright by Paul Graunke June 2000 AD
+(define-signature dtd-ast^
+  ((struct dtd-item ())
+   (struct element-def (name start-optional stop-optional content))
+   (struct att-list (name junk))
+   (struct entity-def (name value))
+   (struct thingy (uh whatever))))
+
+(define-signature dtd^ (read-sgml-dtd summarize-dtd))
+(define-signature entity-expander^ (empty-entity-expander extend-entity-expander expand-entities))
+
+(require-library "functios.ss")
+(require-library "strings.ss")
diff --git a/collects/html/entity-expander.ss b/collects/html/entity-expander.ss
new file mode 100644
index 0000000000..177fafee94
--- /dev/null
+++ b/collects/html/entity-expander.ss
@@ -0,0 +1,27 @@
+;; copyright by Paul Graunke June 2000 AD
+(module entity-expander mzscheme
+  (provide empty-entity-expander extend-entity-expander expand-entities)
+  ;; warning - this is a really inefficient implementation of a nice interface.
+  ;; building one dfa would be much better
+  
+  ;; Entity-expander : String -> String
+  
+  ;; empty-entity-expander : Entity-expander
+  (define (empty-entity-expander x) x)
+  
+  ;; extend-entity-expander : Symbol String Entity-expander -> Entity-expander
+  (define extend-entity-expander
+    (let ([fix-rhs (regexp "&")])
+      (lambda (name rhs to-extend)
+        (let ([pattern (regexp (format "%~a;?" name))]
+              [rhs (regexp-replace* fix-rhs rhs "\\\\&")])
+          (lambda (input)
+            (to-extend (regexp-replace* pattern input rhs)))))))
+  
+  ;; expand-entities : Entity-expander String -> String
+  (define (expand-entities expander string)
+    (let loop ([prev string])
+      (let ([new (expander prev)])
+        (if (string=? new prev)
+            new
+            (loop new))))))
diff --git a/collects/html/generate-code.ss b/collects/html/generate-code.ss
new file mode 100644
index 0000000000..b1e4751b45
--- /dev/null
+++ b/collects/html/generate-code.ss
@@ -0,0 +1,72 @@
+; copyright by Paul Graunke June 2000 AD
+(require (lib "pretty.ss")
+         (lib "date.ss")
+         (lib "list.ss")
+         (lib "etc.ss"))
+
+; date-string : -> String
+(define (date-string) (date->string (seconds->date (current-seconds)) 'seconds-please))
+
+(define html-spec (call-with-input-file (build-path (collection-path "html") "html-spec") read))
+
+(define (empty-name? x) (null? (cdr x)))
+
+(define empty-names
+  (apply append (map car (filter empty-name? html-spec))))
+
+(define non-empty-names 
+  (apply append (map car (filter (compose not empty-name?) html-spec))))
+
+; generate-structs : -> Void
+(define (generate-structs)
+  (let ([file (build-path (collection-path "html") "html-structs.ss")])
+    (printf "building ~a~n" file)
+    (call-with-output-file file
+      (lambda (out)
+        (fprintf out "; This code was machine generated by generate-code.ss ~a~n" (date-string))
+        (for-each
+         (lambda (x) (pretty-print x  out))
+         (append
+          (list
+           '(define-struct html-element (attributes))
+           `(define-struct (html-full html-element) (content)))
+          (map (lambda (x) `(define-struct (,x html-full) ()))
+               non-empty-names)
+          (map (lambda (x)
+                 `(define-struct (,x html-element) ()))
+               empty-names))))
+      'text 'truncate)))
+
+; generate-case : -> Void
+(define (generate-case)
+  (let ([file (build-path (collection-path "html") "case.ss")])
+    (printf "building ~a~n" file)
+    (call-with-output-file file
+      (lambda (out)
+        (fprintf out ";This file was generated by genrate-code.ss on ~a~n" (date-string))
+        (fprintf out "~n; xml-single-content->html : Content (listof Html-content) -> (listof Html-content)~n")
+        (pretty-print
+         `(define (xml-single-content->html x acc)
+            (cond
+              [(element? x)
+               (case (element-name x)
+                 ,@(append
+                    (map (lambda (name)
+                           `[(,name) (cons (,(string->symbol (string-append "make-" (symbol->string name)))
+                                            (element-attributes x))
+                                           acc)])
+                         empty-names)
+                    (map (lambda (name)
+                           `[(,name) (cons (,(string->symbol (string-append "make-" (symbol->string name)))
+                                            (element-attributes x)
+                                            (xml-contents->html (element-content x)))
+                                           acc)])
+                         non-empty-names))
+                 [else acc])]
+              [(or (pcdata? x) (entity? x)) (cons x acc)]
+              [else acc]))
+         out))
+      'truncate 'text)))
+
+(generate-structs)
+(generate-case)
diff --git a/collects/html/html-sig.ss b/collects/html/html-sig.ss
new file mode 100644
index 0000000000..d1a4f2e8ed
--- /dev/null
+++ b/collects/html/html-sig.ss
@@ -0,0 +1,11 @@
+;; copyright by Paul Graunke June 2000 AD
+
+(module html-sig mzscheme
+  (require (lib "unitsig.ss"))
+
+  (define-signature html-structs^ ((struct html-element (attributes)) (struct html-full (content)) (struct html ()) (struct div ()) (struct center ()) (struct blockquote ()) (struct ins ()) (struct del ()) (struct dd ()) (struct li ()) (struct th ()) (struct td ()) (struct iframe ()) (struct noframes ()) (struct noscript ()) (struct style ()) (struct script ()) (struct basefont ()) (struct br ()) (struct area ()) (struct link ()) (struct img ()) (struct param ()) (struct hr ()) (struct input ()) (struct col ()) (struct isindex ()) (struct base ()) (struct meta ()) (struct option ()) (struct textarea ()) (struct title ()) (struct head ()) (struct tr ()) (struct colgroup ()) (struct thead ()) (struct tfoot ()) (struct tbody ()) (struct tt ()) (struct i ()) (struct b ()) (struct u ()) (struct s ()) (struct strike ()) (struct big ()) (struct small ()) (struct em ()) (struct strong ()) (struct dfn ()) (struct code ()) (struct samp ()) (struct kbd ()) (struct var ()) (struct cite ()) (struct abbr ()) (struct acronym ()) (struct sub ()) (struct sup ()) (struct span ()) (struct bdo ()) (struct font ()) (struct p ()) (struct h1 ()) (struct h2 ()) (struct h3 ()) (struct h4 ()) (struct h5 ()) (struct h6 ()) (struct q ()) (struct dt ()) (struct legend ()) (struct caption ()) (struct table ()) (struct button ()) (struct fieldset ()) (struct optgroup ()) (struct select ()) (struct label ()) (struct form ()) (struct ol ()) (struct ul ()) (struct dir ()) (struct menu ()) (struct dl ()) (struct pre ()) (struct object ()) (struct applet ()) (struct -map ()) (struct a ()) (struct address ()) (struct body ())))
+
+  (define-signature html^ (read-xhtml read-html read-html-as-xml (open html-structs^)
+				      use-html-spec))  
+
+  (provide html^))
diff --git a/collects/html/html-spec b/collects/html/html-spec
new file mode 100644
index 0000000000..cc3d423352
--- /dev/null
+++ b/collects/html/html-spec
@@ -0,0 +1 @@
+(((mzscheme) pcdata) ((html) body head) ((div center blockquote ins del dd li th td iframe noframes noscript) a abbr acronym address applet b basefont bdo big blockquote br button center cite code dfn dir div dl em fieldset font form h1 h2 h3 h4 h5 h6 hr i iframe img input isindex kbd label map menu noframes noscript object ol p pcdata pre q s samp script select small span strike strong sub sup table textarea tt u ul var) ((style script) cdata) ((basefont br area link img param hr input col isindex base meta)) ((option textarea title) pcdata) ((head) base isindex link meta object script style title) ((tr) td th) ((colgroup) col) ((thead tfoot tbody) tr) ((tt i b u s strike big small em strong dfn code samp kbd var cite abbr acronym sub sup span bdo font p h1 h2 h3 h4 h5 h6 q dt legend caption) a abbr acronym applet b basefont bdo big br button cite code dfn em font i iframe img input kbd label map object pcdata q s samp script select small span strike strong sub sup textarea tt u var) ((table) caption col colgroup tbody tfoot thead) ((button) abbr acronym address applet b basefont bdo big blockquote br center cite code dfn dir div dl em font h1 h2 h3 h4 h5 h6 hr i img kbd map menu noframes noscript object ol p pcdata pre q s samp script small span strike strong sub sup table tt u ul var) ((fieldset) a abbr acronym address applet b basefont bdo big blockquote br button center cite code dfn dir div dl em fieldset font form h1 h2 h3 h4 h5 h6 hr i iframe img input isindex kbd label legend map menu noframes noscript object ol p pcdata pcdata pre q s samp script select small span strike strong sub sup table textarea tt u ul var) ((optgroup) option) ((select) optgroup option) ((label) a abbr acronym applet b basefont bdo big br button cite code dfn em font i iframe img input kbd map object pcdata q s samp script select small span strike strong sub sup textarea tt u var) ((form) a abbr acronym address applet b basefont bdo big blockquote br button center cite code dfn dir div dl em fieldset font h1 h2 h3 h4 h5 h6 hr i iframe img input isindex kbd label map menu noframes noscript object ol p pcdata pre q s samp script select small span strike strong sub sup table textarea tt u ul var) ((ol ul dir menu) li) ((dl) dd dt) ((pre) a abbr acronym b bdo br button cite code dfn em i iframe input kbd label map pcdata q s samp script select span strike strong textarea tt u var) ((object applet) a abbr acronym address applet b basefont bdo big blockquote br button center cite code dfn dir div dl em fieldset font form h1 h2 h3 h4 h5 h6 hr i iframe img input isindex kbd label map menu noframes noscript object ol p param pcdata pre q s samp script select small span strike strong sub sup table textarea tt u ul var) ((map) address area blockquote center dir div dl fieldset form h1 h2 h3 h4 h5 h6 hr isindex menu noframes noscript ol p pre table ul) ((a) abbr acronym applet b basefont bdo big br button cite code dfn em font i iframe img input kbd label map object pcdata q s samp script select small span strike strong sub sup textarea tt u var) ((address) a abbr acronym applet b basefont bdo big br button cite code dfn em font i iframe img input kbd label map object p pcdata q s samp script select small span strike strong sub sup textarea tt u var) ((body) a abbr acronym address applet b basefont bdo big blockquote br button center cite code del dfn dir div dl em fieldset font form h1 h2 h3 h4 h5 h6 hr i iframe img input ins isindex kbd label map menu noframes noscript object ol p pcdata pre q s samp script select small span strike strong sub sup table textarea tt u ul var))
\ No newline at end of file
diff --git a/collects/html/html-structs.ss b/collects/html/html-structs.ss
new file mode 100644
index 0000000000..09e2eff4cc
--- /dev/null
+++ b/collects/html/html-structs.ss
@@ -0,0 +1,93 @@
+;; This code was machine generated by generate-code.ss Friday, September 1st, 2000 11:09:43am
+(define-struct html-element (attributes))
+(define-struct (html-full html-element) (content))
+(define-struct (mzscheme html-full) ())
+(define-struct (html html-full) ())
+(define-struct (div html-full) ())
+(define-struct (center html-full) ())
+(define-struct (blockquote html-full) ())
+(define-struct (ins html-full) ())
+(define-struct (del html-full) ())
+(define-struct (dd html-full) ())
+(define-struct (li html-full) ())
+(define-struct (th html-full) ())
+(define-struct (td html-full) ())
+(define-struct (iframe html-full) ())
+(define-struct (noframes html-full) ())
+(define-struct (noscript html-full) ())
+(define-struct (style html-full) ())
+(define-struct (script html-full) ())
+(define-struct (option html-full) ())
+(define-struct (textarea html-full) ())
+(define-struct (title html-full) ())
+(define-struct (head html-full) ())
+(define-struct (tr html-full) ())
+(define-struct (colgroup html-full) ())
+(define-struct (thead html-full) ())
+(define-struct (tfoot html-full) ())
+(define-struct (tbody html-full) ())
+(define-struct (tt html-full) ())
+(define-struct (i html-full) ())
+(define-struct (b html-full) ())
+(define-struct (u html-full) ())
+(define-struct (s html-full) ())
+(define-struct (strike html-full) ())
+(define-struct (big html-full) ())
+(define-struct (small html-full) ())
+(define-struct (em html-full) ())
+(define-struct (strong html-full) ())
+(define-struct (dfn html-full) ())
+(define-struct (code html-full) ())
+(define-struct (samp html-full) ())
+(define-struct (kbd html-full) ())
+(define-struct (var html-full) ())
+(define-struct (cite html-full) ())
+(define-struct (abbr html-full) ())
+(define-struct (acronym html-full) ())
+(define-struct (sub html-full) ())
+(define-struct (sup html-full) ())
+(define-struct (span html-full) ())
+(define-struct (bdo html-full) ())
+(define-struct (font html-full) ())
+(define-struct (p html-full) ())
+(define-struct (h1 html-full) ())
+(define-struct (h2 html-full) ())
+(define-struct (h3 html-full) ())
+(define-struct (h4 html-full) ())
+(define-struct (h5 html-full) ())
+(define-struct (h6 html-full) ())
+(define-struct (q html-full) ())
+(define-struct (dt html-full) ())
+(define-struct (legend html-full) ())
+(define-struct (caption html-full) ())
+(define-struct (table html-full) ())
+(define-struct (button html-full) ())
+(define-struct (fieldset html-full) ())
+(define-struct (optgroup html-full) ())
+(define-struct (select html-full) ())
+(define-struct (label html-full) ())
+(define-struct (form html-full) ())
+(define-struct (ol html-full) ())
+(define-struct (ul html-full) ())
+(define-struct (dir html-full) ())
+(define-struct (menu html-full) ())
+(define-struct (dl html-full) ())
+(define-struct (pre html-full) ())
+(define-struct (object html-full) ())
+(define-struct (applet html-full) ())
+(define-struct (-map html-full) ())
+(define-struct (a html-full) ())
+(define-struct (address html-full) ())
+(define-struct (body html-full) ())
+(define-struct (basefont html-element) ())
+(define-struct (br html-element) ())
+(define-struct (area html-element) ())
+(define-struct (link html-element) ())
+(define-struct (img html-element) ())
+(define-struct (param html-element) ())
+(define-struct (hr html-element) ())
+(define-struct (input html-element) ())
+(define-struct (col html-element) ())
+(define-struct (isindex html-element) ())
+(define-struct (base html-element) ())
+(define-struct (meta html-element) ())
diff --git a/collects/html/html-unit.ss b/collects/html/html-unit.ss
new file mode 100644
index 0000000000..bb14136536
--- /dev/null
+++ b/collects/html/html-unit.ss
@@ -0,0 +1,141 @@
+;; copyright by Paul Graunke June 2000 AD
+
+(module html-unit mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "file.ss")
+	   (lib "list.ss")
+	   (lib "etc.ss")
+	   (lib "include.ss")
+	   "html-sig.ss"
+	   "sgml-reader-sig.ss"
+	   (lib "xml-sig.ss" "xml"))
+
+  (provide html@)
+
+  (define html@
+    (unit/sig html^
+      (import xml^ (sgml : sgml-reader^))
+      
+      ;; Html-content = Html-element | Pc-data | Entity   
+      
+      (include "html-structs.ss")
+      (include "case.ss")
+      
+      ;; xml->html : Document -> Html
+      (define (xml->html doc)
+	(let ([root (document-element doc)])
+	  (unless (eq? 'html (element-name root))
+	    (error 'xml->html "This is not an html document.  Expected 'html, given ~a" (element-name root)))
+	  (make-html (element-attributes root) (xml-contents->html (element-content root)))))
+      
+      
+      ;; xml-content->html : (listof Content) -> (listof Html-element)
+      (define (xml-contents->html contents)
+	(foldr xml-single-content->html
+	       null
+	       contents))
+      
+      ;; read-xhtml : [Input-port] -> Html
+      (define read-xhtml (compose xml->html read-xml))
+      
+      ;; peel-f : (Html-content -> Bool) (listof Html-content) (listof Html-content) -> (listof Html-content)
+      (define (peel-f toss? to-toss acc0)
+	(foldr (lambda (x acc)
+		 (if (toss? x)
+		     (append (html-full-content x) acc)
+		     (cons x acc)))
+	       acc0
+	       to-toss))
+      
+      ;; repackage-html : (listof Html-content) -> Html
+      (define (repackage-html contents)
+	(let* ([html (memf html? contents)]
+	       [peeled (peel-f html? contents null)]
+	       [body (memf body? peeled)])
+	  (make-html (if html
+			 (html-element-attributes (car html))
+			 null)
+		     (append (filter head? peeled)
+			     (list (make-body (if body
+						  (html-element-attributes (car body))
+						  null)
+					      (filter (compose not head?) (peel-f body? peeled null))))))))
+      
+      ;; clean-up-pcdata : (listof Content) -> (listof Content)
+      ;; Each pcdata inside a tag that isn't supposed to contain pcdata is either
+      ;; a) appended to the end of the previous subelement, if that subelement may contain pcdata
+      ;; b) prepended to the front of the next subelement, if that subelement may contain pcdata
+      ;; c) discarded
+      ;; unknown tags may contain pcdata
+      ;; the top level may contain pcdata
+      (define clean-up-pcdata
+	;; clean-up-pcdata : (listof Content) -> (listof Content)
+	(letrec ([clean-up-pcdata
+		  (lambda (content)
+		    (map (lambda (to-fix)
+			   (cond
+			    [(element? to-fix)
+			     (recontent-xml to-fix
+					    (let ([possible (may-contain (element-name to-fix))]
+						  [content (element-content to-fix)])
+					      (if (or (not possible) (memq 'pcdata possible))
+						  (clean-up-pcdata content)
+						  (eliminate-pcdata content))))]
+			    [else to-fix]))
+			 content))]
+		 [eliminate-pcdata
+					;: (listof Content) -> (listof Content)
+		  (lambda (content)
+		    (let ([non-elements (first-non-elements content)]
+			  [more (memf element? content)])
+		      (if more
+			  (let* ([el (car more)]
+				 [possible (may-contain (element-name el))])
+			    (if (or (not possible) (memq 'pcdata possible))
+				(cons (recontent-xml el (append non-elements (clean-up-pcdata (element-content el)) (eliminate-pcdata (first-non-elements (cdr more)))))
+				      (or (memf element? (cdr more)) null))
+				(cons (recontent-xml el (eliminate-pcdata (element-content el)))
+				      (eliminate-pcdata (cdr more)))))
+			  null)))])
+	  clean-up-pcdata))
+      
+      ;; first-non-elements : (listof Content) -> (listof Content)
+      (define (first-non-elements content)
+	(cond
+	 [(null? content) null]
+	 [else (if (element? (car content))
+		   null
+		   (cons (car content) (first-non-elements (cdr content))))]))
+      
+      ;; recontent-xml : Element (listof Content) -> Element
+      (define (recontent-xml e c)
+	(make-element (source-start e) (source-stop e) (element-name e) (element-attributes e) c))
+      
+      ;; implicit-starts : Symbol Symbol -> (U #f Symbol)
+      (define (implicit-starts parent child)
+	(or (and (eq? child 'tr) (eq? parent 'table) 'tbody)
+	    (and (eq? child 'td) (memq parent '(table tbody tfoot thead)) 'tr)))
+      
+      ;; may-contain : Kid-lister
+      (define may-contain
+	(sgml:gen-may-contain (call-with-input-file (find-library "html-spec" "html") read)))
+
+      (define may-contain-anything
+	(sgml:gen-may-contain null))
+
+      (define use-html-spec (make-parameter #t))
+      
+      ;; read-html-as-xml : [Input-port] -> (listof Content)
+      (define read-html-as-xml
+	(case-lambda 
+	 [(port)
+	  ((if (use-html-spec) clean-up-pcdata values)
+	   ((sgml:gen-read-sgml (if (use-html-spec)
+				    may-contain 
+				    may-contain-anything)
+				implicit-starts) port))]
+	 [() (read-html-as-xml (current-input-port))]))
+      
+      ;; read-html : [Input-port] -> Html
+      (define read-html
+	(compose repackage-html xml-contents->html read-html-as-xml)))))
diff --git a/collects/html/html.ss b/collects/html/html.ss
new file mode 100644
index 0000000000..82a5461c60
--- /dev/null
+++ b/collects/html/html.ss
@@ -0,0 +1,30 @@
+;; copyright by Paul Graunke June 2000 AD
+
+(module html mzscheme
+  (require (lib "unitsig.ss")
+	   "html-sig.ss" 
+	   "html-unit.ss"
+	   "sgml-reader-sig.ss"
+	   "sgml-reader-unit.ss"
+	   (lib "xml.ss" "xml")
+	   (lib "xml-sig.ss" "xml")
+	   (lib "sig.ss" "xml" "private")
+	   (lib "xml-unit.ss" "xml"))
+
+  ;; To get read-comments from sgml-reader, we have to
+  ;;  avoid the read-comments from XML, so we rename it
+  ;;  to read-html-comments.
+
+  (define-values/invoke-unit/sig
+    ((open html^) read-html-comments)
+    (compound-unit/sig
+     (import [x : xml^])
+     (link
+      [s : sgml-reader^ (sgml-reader@ (x : xml-structs^))]
+      [h : html^ (html@ x s)])
+     (export (open h) (var (s read-comments) read-html-comments)))
+    #f
+    xml^)
+
+  (provide-signature-elements html^)
+  (provide read-html-comments))
diff --git a/collects/html/info.ss b/collects/html/info.ss
new file mode 100644
index 0000000000..b8a8fbcc24
--- /dev/null
+++ b/collects/html/info.ss
@@ -0,0 +1,9 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "HTML")
+  (define doc.txt "doc.txt")
+  (define compile-omit-files
+    '("dtd.ss" "dtdr.ss" "dtds.ss" "dtd-ast.ss"
+	       "case.ss" "html-structs.ss"
+	       "entity-expander.ss" "generate-code.ss"
+	       "sgml.ss")))
+
diff --git a/collects/html/sgml-reader-sig.ss b/collects/html/sgml-reader-sig.ss
new file mode 100644
index 0000000000..2628518cd8
--- /dev/null
+++ b/collects/html/sgml-reader-sig.ss
@@ -0,0 +1,8 @@
+;; copyright by Paul Graunke June 2000 AD
+
+(module sgml-reader-sig mzscheme
+  (require (lib "unitsig.ss"))
+
+  (define-signature sgml-reader^ (read-comments trim-whitespace gen-may-contain gen-read-sgml))
+  
+  (provide sgml-reader^))
diff --git a/collects/html/sgml-reader-unit.ss b/collects/html/sgml-reader-unit.ss
new file mode 100644
index 0000000000..cd6f755523
--- /dev/null
+++ b/collects/html/sgml-reader-unit.ss
@@ -0,0 +1,437 @@
+;; copyright by Paul Graunke June 2000 AD
+;; warning - this was copied from the XML collection.
+;; It needs to be abstracted back in.
+
+(module sgml-reader-unit mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "list.ss")
+	   (lib "string.ss")
+	   "sgml-reader-sig.ss"
+	   (lib "sig.ss" "xml" "private"))
+
+  (provide sgml-reader@)
+
+  (define sgml-reader@
+    (unit/sig sgml-reader^
+      (import xml-structs^)
+      
+      ;; Start-tag ::= (make-start-tag Location Location Symbol (listof Attribute))
+      (define-struct (start-tag source) (name attrs))
+      
+      ;; End-tag ::= (make-end-tag Location Location Symbol)
+      (define-struct (end-tag source) (name))
+      
+      ;; Token ::= Contents | Start-tag | End-tag | Eof
+      
+      (define read-comments (make-parameter #f))
+      (define trim-whitespace (make-parameter #f))
+      
+      ;; Kid-lister : (Symbol -> (U (listof Symbol) #f))
+      
+      ;; gen-may-contain : Spec -> Kid-lister
+      (define (gen-may-contain spec)
+	(let ([table (make-hash-table)])
+	  (for-each (lambda (def)
+		      (let ([rhs (cdr def)])
+			(for-each (lambda (name) (hash-table-put! table name rhs))
+				  (car def))))
+		    spec)
+	  (lambda (name)
+	    (hash-table-get table name (lambda () #f)))))
+      
+      ;; gen-read-sgml : Kid-lister (Symbol Symbol -> (U #f Symbol)) -> [Input-port] -> (listof Content)
+      (define (gen-read-sgml may-contain auto-insert)
+	(case-lambda
+	 [(in) (read-from-port may-contain auto-insert in)]
+	 [() (read-from-port may-contain auto-insert (current-input-port))]))
+      
+      ;; read-from-port : Kid-lister (Symbol Symbol -> (U #f Symbol)) Input-port -> (listof Content)
+      (define (read-from-port may-contain auto-insert in)
+	(let loop ([tokens (let read-tokens ()
+			     (let ([tok (lex in)])
+			       (cond
+				[(eof-object? tok) null]
+				[else (cons tok (read-tokens))])))])
+	  (cond
+	   [(null? tokens) null]
+	   [else
+	    (let ([tok (car tokens)] [rest-tokens (cdr tokens)])
+	      (cond
+	       [(start-tag? tok)
+		(let-values ([(el more-tokens) (read-element tok null may-contain auto-insert rest-tokens)])
+		  (cons el (loop more-tokens)))]
+	       [(end-tag? tok) (loop rest-tokens)]
+	       [else (let ([rest-contents (loop rest-tokens)])
+		       (expand-content tok rest-contents))]))])))
+      
+      ;; read-element : Start-tag (listof Symbol) Kid-lister (Symbol Symbol -> (U #f Symbol)) (listof Token) -> Element (listof Token)
+      ;; Note: How elements nest depends on their content model.
+      ;;   If a kind of element can't contain anything, then its start tags are implicitly ended, and
+      ;;   end tags are implicitly started.
+      ;;   Unknown elements can contain anything and can go inside anything.
+      ;;   Otherwise, only the subelements listed in the content model can go inside an element.
+      ;; more here - may-contain shouldn't be used to decide if an element is known or not.
+      ;;             The edgar dtd puts tags in may-contain's range that aren't in its domain.
+      ;; more here (or not) - the (memq name context) test leaks for a worst case of O(n^2) in the
+      ;;                      tag nesting depth.  However, this only should be a problem when the tag is there,
+      ;;                      but far back.  That shouldn't happen often.  I'm guessing n will be about 3.
+      (define (read-element start-tag context may-contain auto-insert tokens)
+	(let read-el ([start-tag start-tag] [context (cons (start-tag-name start-tag) context)] [tokens tokens])
+	  (let* ([start-name (start-tag-name start-tag)]
+		 [ok-kids (may-contain start-name)])
+	    (let-values ([(content remaining)
+			  (cond
+			   [(null? ok-kids) (values null tokens)]
+			   [else 
+			    ;; read-content : (listof Token) -> (listof Content) (listof Token)
+			    (let read-content ([tokens tokens])
+			      (cond
+			       [(null? tokens) (values null tokens)]
+			       [else
+				(let ([tok (car tokens)] [next-tokens (cdr tokens)])
+				  (cond
+				   [(start-tag? tok)
+				    (let* ([name (start-tag-name tok)]
+					   [auto-start (auto-insert start-name name)])
+				      (if auto-start
+					  (read-content (cons (make-start-tag (source-start tok) (source-stop tok) auto-start null) tokens))
+					  (if (and ok-kids
+						   (not (memq name ok-kids))
+						   (may-contain name))
+					      (values null tokens)
+					      (let*-values ([(element post-element)
+							     (read-el tok (cons name context) next-tokens)]
+							    [(more-contents left-overs) (read-content post-element)])
+						(values (cons element more-contents) left-overs)))))]
+				   [(end-tag? tok)
+				    (let ([name (end-tag-name tok)])
+				      (if (eq? name start-name)
+					  (values null next-tokens)
+					  (if (memq name context)
+					      (values null tokens)
+					      (read-content next-tokens))))]
+				   [else ;; content
+				    (let-values ([(more-contents left-overs) (read-content next-tokens)])
+				      (values
+				       (expand-content tok more-contents)
+				       left-overs))]))]))])])
+	      (values (make-element (source-start start-tag)
+				    (source-stop start-tag)
+				    start-name
+				    (start-tag-attrs start-tag)
+				    content)
+		      remaining)))))
+      
+      ;; expand-content : Content (listof Content) -> (listof Content)
+      (define (expand-content x lst)
+	(cond
+	 [(entity? x) (cons (expand-entity x) lst)]
+	 [(comment? x) (if (read-comments)
+			   (cons x lst)
+			   lst)]
+	 [else (cons x lst)]))
+      
+      ;; expand-entity : Entity -> (U Entity Pcdata)
+      ;; more here - allow expansion of user defined entities
+      (define (expand-entity x)
+	(let ([expanded (default-entity-table (entity-text x))])
+	  (if expanded
+	      (make-pcdata (source-start x) (source-stop x) expanded)
+	      x)))
+      
+      ;; default-entity-table : Symbol -> (U #f String)
+      (define (default-entity-table name)
+	(case name
+	  [(amp) "&"]
+	  [(lt) "<"]
+	  [(gt) ">"]
+	  [(quot) "\""]
+	  [(apos) "'"]
+	  [else #f]))
+      
+      ;; lex : Input-port -> Token
+      (define (lex in)
+	(when (trim-whitespace)
+	  (skip-space in))
+	(let ([c (peek-char in)])
+	  (cond
+	   [(eof-object? c) c]
+	   [(eq? c #\&) (lex-entity in)]
+	   [(eq? c #\<) (lex-tag-cdata-pi-comment in)]
+	   [else (lex-pcdata in)])))
+      
+      ;; lex-entity : Input-port -> Token
+      ;; This might not return an entity if it doesn't look like one afterall.
+      (define (lex-entity in)
+	(let ([start (file-position in)])
+	  (read-char in)
+	  (case (peek-char in)
+	    ;; more here - read while it's numeric (or hex) not until #\;
+	    [(#\#)
+	     (read-char in)
+	     (let* ([hex? (if (equal? #\x (peek-char in))
+			      (and (read-char in) #t)
+			      #f)]
+		    [str (read-until #\; in)]
+		    [n (cond
+			[hex?
+			 (string->number str 16)]
+			[else (string->number str)])])
+	       (if (number? n)
+		   (make-entity start (file-position in) n)
+		   (make-pcdata start (file-position in) (string-append "&#" str))))]
+	    [else
+	     (let ([name (lex-name/case-sensitive in)]
+		   [c (peek-char in)])
+	       (if (eq? c #\;)
+		   (begin (read-char in) (make-entity start (file-position in) name))
+		   (make-pcdata start (file-position in) (format "&~a" name))))])))
+      
+      ;; lex-tag-cdata-pi-comment : Input-port -> Start-tag | Element | End-tag | Pcdata | Pi | Comment
+      (define (lex-tag-cdata-pi-comment in)
+	(let ([start (file-position in)])
+	  (read-char in)
+	  (case (peek-char in)
+	    [(#\!)
+	     (read-char in)
+	     (case (peek-char in)
+	       [(#\-) (read-char in)
+		(let ([c (read-char in)])
+		  (cond
+		   [(eq? c #\-)
+		    (let ([data (lex-comment-contents in)])
+		      (make-comment data))]
+		   [else (make-pcdata start (file-position in) (format "<!-~a" c))]))]
+	       [(#\[) (read-char in)
+		(let ([s (read-string 6 in)])
+		  (if (string=? s "CDATA[")
+		      (let ([data (lex-cdata-contents in)])
+			(make-pcdata start (file-position in) data))
+		      (make-pcdata start (file-position in) (format "<[~a" s))))]
+	       [else (skip-dtd in) (lex in)])]
+	    [(#\?) (read-char in)
+	     (let ([name (lex-name in)])
+	       (skip-space in)
+	       (let ([data (lex-pi-data in)])
+		 (make-pi start (file-position in) name data)))]
+	    [(#\/) (read-char in)
+	     (let ([name (lex-name in)])
+	       (skip-space in)
+	       (read-char in) ;; skip #\> or whatever else is there
+	       (make-end-tag start (file-position in) name))]
+	    [else
+	     (let ([name (lex-name in)]
+		   [attrs (lex-attributes in)])
+	       (skip-space in)
+	       (case (read-char in)
+		 [(#\/)
+		  (read-char in) ;; skip #\> or something
+		  (make-element start (file-position in) name attrs null)]
+		 [else (make-start-tag start (file-position in) name attrs)]))])))
+      
+      
+      ;; lex-attributes : Input-port -> (listof Attribute)
+      (define (lex-attributes in)
+	(quicksort (let loop ()
+		     (skip-space in)
+		     (cond
+		      [(name-start? (peek-char in))
+		       (cons (lex-attribute in) (loop))]
+		      [else null]))
+		   (lambda (a b)
+		     (string<? (symbol->string (attribute-name a))
+			       (symbol->string (attribute-name b))))))
+      
+      ;; lex-attribute : Input-port -> Attribute
+      ;; Note: entities in attributes are ignored, since defacto html uses & in them for URL syntax
+      (define (lex-attribute in)
+	(let ([start (file-position in)]
+	      [name (lex-name in)])
+	  (skip-space in)
+	  (cond
+	   [(eq? (peek-char in) #\=)
+	    (read-char in)
+	    (skip-space in)
+	    (let* ([delimiter (read-char in)]
+		   [value (list->string
+			   (case delimiter
+			     [(#\' #\")
+			      (let read-more ()
+				(let ([c (read-char in)])
+				  (cond
+				   [(or (eq? c delimiter) (eof-object? c)) null]
+				   [else (cons c (read-more))])))]
+			     [else (cons delimiter (read-up-to (lambda (c) (or (char-whitespace? c) (eq? c #\>))) in))]))])
+	      (make-attribute start (file-position in) name value))]
+	   [else (make-attribute start (file-position in) name (symbol->string name))])))
+      
+      ;; skip-space : Input-port -> Void
+      ;; deviation - should sometimes insist on at least one space
+      (define (skip-space in)
+	(let loop ()
+	  (let ([c (peek-char in)])
+	    (when (and (not (eof-object? c)) (char-whitespace? c))
+	      (read-char in)
+	      (loop)))))
+
+      ;; lex-pcdata : Input-port -> Pcdata
+      ;; deviation - disallow ]]> "for compatability" with SGML, sec 2.4 XML spec 
+      (define (lex-pcdata in)
+	(let ([start (file-position in)])
+	  ;; The following regexp match must use bytes, not chars, because
+	  ;; `in' might not be a well-formed UTF-8 sequence. If it isn't,
+	  ;; and it goes wrong with the first byte sequence, then a char-based
+	  ;; pattern would match 0 characters. Meanwhile, the caller of this function
+	  ;; expects characters to be read.
+	  (let ([s (regexp-match #rx#"^[^&<]*" in)])
+	    (make-pcdata start
+			 (file-position in)
+			 (bytes->string/utf-8
+			  (if (trim-whitespace)
+			      (regexp-replace* #rx#"[ \t\v\r\n]+" (car s) #"")
+			      (car s))
+			  #\?)))))
+#|
+      ;; Original slow version:
+      (define (lex-pcdata in)
+	(let ([start (file-position in)]
+	      [data (let loop ([c (read-char in)])
+		      (let ([next (peek-char in)])
+			(cond
+			 [(or (eof-object? next) (eq? next #\&) (eq? next #\<))
+			  (list c)]
+			 [(and (char-whitespace? next) (trim-whitespace))
+			  (skip-space in)
+			  (let ([lst (loop #\space)])
+			    (cond
+			     [(null? (cdr lst)) (list c)]
+			     [else (cons c lst)]))]
+			 [else (cons c (loop (read-char in)))])))])
+	  (make-pcdata start
+		       (file-position in)
+		       (list->string data))))
+  |#
+  
+
+      ;; lex-name : Input-port -> Symbol
+      (define (lex-name in)
+	(let ([s (bytes->string/utf-8 (car (regexp-match #rx"^[a-zA-Z_:0-9&.-]*" in)))])
+	  (string->symbol
+	   ;; Common case: string is already lowercased
+	   (if (regexp-match-positions #rx"[A-Z]" s)
+	       (begin
+		 (string-lowercase! s)
+		 s)
+	       s))))
+      ;; lex-name/case-sensitive : Input-port -> Symbol
+      (define (lex-name/case-sensitive in)
+	(let ([s (bytes->string/utf-8 (car (regexp-match #rx"^[a-zA-Z_:0-9&.-]*" in)))])
+	  (string->symbol s)))
+#|
+      (define (lex-name in)
+        (string->symbol
+         (list->string
+          (let lex-rest ()
+            (cond
+             [(name-char? (peek-char in))
+              (cons (char-downcase (read-char in)) (lex-rest))]
+             [else null])))))
+|#
+
+    
+      ;; skip-dtd : Input-port -> Void
+      (define (skip-dtd in)
+	(let skip ()
+	  (let ([c (read-char in)])
+	    (if (eof-object? c)
+		(void)
+		(case c
+		  [(#\') (read-until #\' in) (skip)]
+		  [(#\") (read-until #\" in) (skip)]
+		  [(#\<)
+		   (case (read-char in)
+		     [(#\!) (case (read-char in)
+			      [(#\-) (read-char in) (lex-comment-contents in) (skip)]
+			      [else (skip) (skip)])]
+		     [(#\?) (lex-pi-data in) (skip)]
+		     [else (skip) (skip)])]
+		  [(#\>) (void)]
+		  [else (skip)])))))
+      
+      ;; name-start? : TST -> Bool
+      (define (name-start? ch)
+	(and (char? ch) (char-name-start? ch)))
+      
+      ;; char-name-start? : Char -> Bool
+      (define (char-name-start? ch)
+	(or (char-alphabetic? ch) 
+	    (eq? ch #\_)
+	    (eq? ch #\:)))
+      
+      ;; name-char? : TST -> Bool
+      (define (name-char? ch)
+	(and (char? ch)
+	     (or (char-name-start? ch)
+		 (char-numeric? ch)
+		 (eq? ch #\&) ; ugly illegal junk for SEC's EDGAR database
+		 (eq? ch #\.)
+		 (eq? ch #\-))))
+      
+      ;; read-up-to : (Char -> Bool) Input-port -> (listof Char)
+      ;; abstract this with read-until
+      (define (read-up-to p? in)
+	(let loop ()
+	  (let ([c (peek-char in)])
+	    (cond
+	     [(or (eof-object? c) (p? c)) null]
+	     [else (cons (read-char in) (loop))]))))
+      
+      ;; read-until : Char Input-port -> String
+      ;; discards the stop character, too
+      (define (read-until char in)
+	(list->string
+	 (let read-more ()
+	   (let ([c (read-char in)])
+	     (cond
+	      [(or (eof-object? c) (eq? c char)) null]
+	      [else (cons c (read-more))])))))
+      
+      ;; gen-read-until-string : String -> Input-port -> String
+      ;; uses Knuth-Morris-Pratt from
+      ;; Introduction to Algorithms, Cormen, Leiserson, and Rivest, pages 869-876
+      ;; discards stop from input
+      (define (gen-read-until-string stop)
+	(let* ([len (string-length stop)]
+	       [prefix (make-vector len 0)]
+	       [fall-back
+		(lambda (k c)
+		  (let ([k (let loop ([k k])
+			     (cond
+			      [(and (> k 0) (not (eq? (string-ref stop k) c)))
+			       (loop (vector-ref prefix (sub1 k)))]
+			      [else k]))])
+		    (if (eq? (string-ref stop k) c)
+			(add1 k)
+			k)))])
+	  (let init ([k 0] [q 1])
+	    (when (< q len)
+	      (let ([k (fall-back k (string-ref stop q))])
+		(vector-set! prefix q k)
+		(init k (add1 q)))))
+	  ;; (vector-ref prefix x) = the longest suffix that matches a prefix of stop
+	  (lambda (in)
+	    (list->string
+	     (let/ec out
+	       (let loop ([matched 0] [out out])
+		 (let* ([c (read-char in)]
+			[matched (fall-back matched c)])
+		   (cond
+		    [(or (eof-object? c) (= matched len)) (out null)]
+		    [(zero? matched) (cons c (let/ec out (loop matched out)))]
+		    [else (cons c (loop matched out))]))))))))
+      
+      ;; "-->" makes more sense, but "--" follows the spec, but this isn't XML anymore.
+      (define lex-comment-contents (gen-read-until-string "-->"))
+      (define lex-pi-data (gen-read-until-string "?>"))
+      (define lex-cdata-contents (gen-read-until-string "]]>")))))
+
diff --git a/collects/html/sgml.ss b/collects/html/sgml.ss
new file mode 100644
index 0000000000..59c89cbfad
--- /dev/null
+++ b/collects/html/sgml.ss
@@ -0,0 +1,14 @@
+;; copyright by Paul Graunke June 2000 AD
+(require-library "sgmls.ss" "html")
+(require-library "xmls.ss" "xml")
+(require-library "invoke.ss")
+
+(define-values/invoke-unit/sig
+ ((open xml^) (unit sgml : sgml-reader^))
+ (compound-unit/sig
+   (import)
+   (link
+    (FUN : mzlib:function^ ((require-library "functior.ss")))
+    (X : xml^ ((require-library "xmlr.ss" "xml") FUN))
+    (S : sgml-reader^ ((require-library "sgml-reader.ss" "html") (X : xml-structs^) FUN)))
+   (export (open X) (unit S sgml))))
diff --git a/collects/icons/PLT-206-larval.png b/collects/icons/PLT-206-larval.png
new file mode 100644
index 0000000000..ed68404b36
Binary files /dev/null and b/collects/icons/PLT-206-larval.png differ
diff --git a/collects/icons/PLT-206-mars.jpg b/collects/icons/PLT-206-mars.jpg
new file mode 100644
index 0000000000..3fc90bfe8c
Binary files /dev/null and b/collects/icons/PLT-206-mars.jpg differ
diff --git a/collects/icons/PLT-206.png b/collects/icons/PLT-206.png
new file mode 100644
index 0000000000..694baa647a
Binary files /dev/null and b/collects/icons/PLT-206.png differ
diff --git a/collects/icons/PLT-pumpkin.png b/collects/icons/PLT-pumpkin.png
new file mode 100644
index 0000000000..4ceb2aa702
Binary files /dev/null and b/collects/icons/PLT-pumpkin.png differ
diff --git a/collects/icons/PLTnolarval.jpg b/collects/icons/PLTnolarval.jpg
new file mode 100644
index 0000000000..960b2d3fee
Binary files /dev/null and b/collects/icons/PLTnolarval.jpg differ
diff --git a/collects/icons/PLTylarval.jpg b/collects/icons/PLTylarval.jpg
new file mode 100644
index 0000000000..d378aefe42
Binary files /dev/null and b/collects/icons/PLTylarval.jpg differ
diff --git a/collects/icons/anchor.gif b/collects/icons/anchor.gif
new file mode 100644
index 0000000000..1dd1ca3615
Binary files /dev/null and b/collects/icons/anchor.gif differ
diff --git a/collects/icons/animate1.gif b/collects/icons/animate1.gif
new file mode 100644
index 0000000000..5cbf5cc0fa
Binary files /dev/null and b/collects/icons/animate1.gif differ
diff --git a/collects/icons/animate2.gif b/collects/icons/animate2.gif
new file mode 100644
index 0000000000..8dec520ba3
Binary files /dev/null and b/collects/icons/animate2.gif differ
diff --git a/collects/icons/animate3.gif b/collects/icons/animate3.gif
new file mode 100644
index 0000000000..44ce87cf68
Binary files /dev/null and b/collects/icons/animate3.gif differ
diff --git a/collects/icons/arrow.blue.down.gif b/collects/icons/arrow.blue.down.gif
new file mode 100644
index 0000000000..a6461cbae6
Binary files /dev/null and b/collects/icons/arrow.blue.down.gif differ
diff --git a/collects/icons/arrow.blue.left.gif b/collects/icons/arrow.blue.left.gif
new file mode 100644
index 0000000000..6c7bd94dbd
Binary files /dev/null and b/collects/icons/arrow.blue.left.gif differ
diff --git a/collects/icons/arrow.blue.right.gif b/collects/icons/arrow.blue.right.gif
new file mode 100644
index 0000000000..b44632b8fc
Binary files /dev/null and b/collects/icons/arrow.blue.right.gif differ
diff --git a/collects/icons/arrow.blue.up.gif b/collects/icons/arrow.blue.up.gif
new file mode 100644
index 0000000000..82aa8ccc68
Binary files /dev/null and b/collects/icons/arrow.blue.up.gif differ
diff --git a/collects/icons/bb-sm-bw.bmp b/collects/icons/bb-sm-bw.bmp
new file mode 100644
index 0000000000..fabbf56b76
Binary files /dev/null and b/collects/icons/bb-sm-bw.bmp differ
diff --git a/collects/icons/bb-small.bmp b/collects/icons/bb-small.bmp
new file mode 100644
index 0000000000..cb8a635f78
Binary files /dev/null and b/collects/icons/bb-small.bmp differ
diff --git a/collects/icons/bb.gif b/collects/icons/bb.gif
new file mode 100644
index 0000000000..4d5051d66f
Binary files /dev/null and b/collects/icons/bb.gif differ
diff --git a/collects/icons/book.gif b/collects/icons/book.gif
new file mode 100644
index 0000000000..589ed50771
Binary files /dev/null and b/collects/icons/book.gif differ
diff --git a/collects/icons/break.png b/collects/icons/break.png
new file mode 100644
index 0000000000..af1568c0f1
Binary files /dev/null and b/collects/icons/break.png differ
diff --git a/collects/icons/bug09.gif b/collects/icons/bug09.gif
new file mode 100644
index 0000000000..ed177855a4
Binary files /dev/null and b/collects/icons/bug09.gif differ
diff --git a/collects/icons/checksyn.jpg b/collects/icons/checksyn.jpg
new file mode 100644
index 0000000000..eeb5c18420
Binary files /dev/null and b/collects/icons/checksyn.jpg differ
diff --git a/collects/icons/eli-purple.jpg b/collects/icons/eli-purple.jpg
new file mode 100644
index 0000000000..0438d59be6
Binary files /dev/null and b/collects/icons/eli-purple.jpg differ
diff --git a/collects/icons/eof.gif b/collects/icons/eof.gif
new file mode 100644
index 0000000000..f5cb90b63f
Binary files /dev/null and b/collects/icons/eof.gif differ
diff --git a/collects/icons/execute.bmp b/collects/icons/execute.bmp
new file mode 100644
index 0000000000..5ca90c725b
Binary files /dev/null and b/collects/icons/execute.bmp differ
diff --git a/collects/icons/file.gif b/collects/icons/file.gif
new file mode 100644
index 0000000000..25a3f0d690
Binary files /dev/null and b/collects/icons/file.gif differ
diff --git a/collects/icons/foot-up.png b/collects/icons/foot-up.png
new file mode 100644
index 0000000000..909c255bf8
Binary files /dev/null and b/collects/icons/foot-up.png differ
diff --git a/collects/icons/foot.png b/collects/icons/foot.png
new file mode 100644
index 0000000000..8205339f16
Binary files /dev/null and b/collects/icons/foot.png differ
diff --git a/collects/icons/help.bmp b/collects/icons/help.bmp
new file mode 100644
index 0000000000..8f12ea5d2f
Binary files /dev/null and b/collects/icons/help.bmp differ
diff --git a/collects/icons/help16x16.xbm b/collects/icons/help16x16.xbm
new file mode 100644
index 0000000000..3f0d3b78b4
--- /dev/null
+++ b/collects/icons/help16x16.xbm
@@ -0,0 +1,6 @@
+#define mred_width 16
+#define mred_height 16
+static char mred_bits[] = {
+ 0xe0,0x07,0xf8,0x1f,0xfc,0x3f,0xfe,0x7f,0xfe,0x7f,0xff,0xff,0xff,0xff,0xff,
+ 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xfe,0x7f,0xfe,0x7f,0xfc,0x3f,0xf8,0x1f,
+ 0xe0,0x07};
diff --git a/collects/icons/help16x16.xpm b/collects/icons/help16x16.xpm
new file mode 100644
index 0000000000..73bbe672fc
--- /dev/null
+++ b/collects/icons/help16x16.xpm
@@ -0,0 +1,23 @@
+/* XPM */
+static char * mred[] = {
+"16 16 4 1",
+" 	c #000000",
+".	c #0000ff",
+"X	c #ffffff",
+"o	c #ff0000",
+"                ",
+"     .XXXX.     ",
+"   ooXXXXXX..   ",
+"  ooXXXooXXX..  ",
+"  ooXXooooXX..  ",
+" oooooooooXX... ",
+" ooooooooXXX... ",
+" oooooooXXX.... ",
+" ooooooXXX..... ",
+" ooooooXX...... ",
+" ooooooXX...... ",
+"  oooooXX.....  ",
+"  oooooo......  ",
+"   ooooXX....   ",
+"     ooXX..     ",
+"                "};
diff --git a/collects/icons/help32x32.xbm b/collects/icons/help32x32.xbm
new file mode 100644
index 0000000000..ff4fbac68a
--- /dev/null
+++ b/collects/icons/help32x32.xbm
@@ -0,0 +1,12 @@
+#define mred_width 32
+#define mred_height 32
+static char mred_bits[] = {
+ 0x00,0xf8,0x1f,0x00,0x00,0xfe,0x7f,0x00,0x80,0xff,0xff,0x01,0xc0,0xff,0xff,
+ 0x03,0xe0,0xff,0xff,0x07,0xf0,0xff,0xff,0x0f,0xf8,0xff,0xff,0x1f,0xfc,0xff,
+ 0xff,0x3f,0xfc,0xff,0xff,0x3f,0xfe,0xff,0xff,0x7f,0xfe,0xff,0xff,0x7f,0xff,
+ 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
+ 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
+ 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xfe,0xff,0xff,0x7f,0xfe,0xff,
+ 0xff,0x7f,0xfc,0xff,0xff,0x3f,0xfc,0xff,0xff,0x3f,0xf8,0xff,0xff,0x1f,0xf0,
+ 0xff,0xff,0x0f,0xe0,0xff,0xff,0x07,0xc0,0xff,0xff,0x03,0x80,0xff,0xff,0x01,
+ 0x00,0xfe,0x7f,0x00,0x00,0xfc,0x1f,0x00};
diff --git a/collects/icons/help32x32.xpm b/collects/icons/help32x32.xpm
new file mode 100644
index 0000000000..744dbb45df
--- /dev/null
+++ b/collects/icons/help32x32.xpm
@@ -0,0 +1,39 @@
+/* XPM */
+static char * mred[] = {
+"32 32 4 1",
+" 	c #000000",
+".	c #ff0000",
+"X	c #0000ff",
+"o	c #ffffff",
+"                                ",
+"          ..       XX           ",
+"        ..  ooooooo  XX         ",
+"       .. ooooooooooo XXX       ",
+"      .. ooooooooooooo XXX      ",
+"     .. ooooooooooooooo XXX     ",
+"    .. ooooo       ooooo XXX    ",
+"   ... oooo ....... oooo XXXX   ",
+"   ... oooo ....... oooo XXXX   ",
+"  .... oooo ....... oooo XXXXX  ",
+"  .....    ........ oooo XXXXX  ",
+" ................. ooooo XXXXXX ",
+" ................ oooooo XXXXXX ",
+" ............... oooooo XXXXXXX ",
+" .............. oooooo XXXXXXXX ",
+" ............. oooooo XXXXXXXXX ",
+" ............ oooooo XXXXXXXXXX ",
+" ............ ooooo XXXXXXXXXXX ",
+" ............ oooo XXXXXXXXXXXX ",
+" ............ oooo XXXXXXXXXXXX ",
+" ............ oooo XXXXXXXXXXXX ",
+"  ........... oooo XXXXXXXXXXX  ",
+"  ............ oo XXXXXXXXXXXX  ",
+"   ............  XXXXXXXXXXXX   ",
+"   .............XXXXXXXXXXXXX   ",
+"    ...........  XXXXXXXXXXX    ",
+"     ........  oo  XXXXXXXX     ",
+"      ...... oooooo XXXXXX      ",
+"        .... oooooo XXXX        ",
+"         ....  oo  XXXX         ",
+"           ....  XXXX           ",
+"                                "};
diff --git a/collects/icons/htdp-icon.gif b/collects/icons/htdp-icon.gif
new file mode 100644
index 0000000000..0b136ece9f
Binary files /dev/null and b/collects/icons/htdp-icon.gif differ
diff --git a/collects/icons/j.gif b/collects/icons/j.gif
new file mode 100644
index 0000000000..c9cdf51d0d
Binary files /dev/null and b/collects/icons/j.gif differ
diff --git a/collects/icons/java-interactions-box.gif b/collects/icons/java-interactions-box.gif
new file mode 100644
index 0000000000..ca4a4ca0f0
Binary files /dev/null and b/collects/icons/java-interactions-box.gif differ
diff --git a/collects/icons/left-right-cursor.xbm b/collects/icons/left-right-cursor.xbm
new file mode 100644
index 0000000000..25ba9c934a
--- /dev/null
+++ b/collects/icons/left-right-cursor.xbm
@@ -0,0 +1,6 @@
+#define left_right_cursor_xbm_width 16
+#define left_right_cursor_xbm_height 16
+static char left_right_cursor_xbm_bits[] = {
+   0x00, 0x00, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x88, 0x11,
+   0x8C, 0x31, 0xFE, 0x7F, 0x8C, 0x31, 0x88, 0x11, 0x80, 0x01, 0x80, 0x01,
+   0x80, 0x01, 0x80, 0x01, 0x00, 0x00, 0x00, 0x00 };
diff --git a/collects/icons/left-right-mask.xbm b/collects/icons/left-right-mask.xbm
new file mode 100644
index 0000000000..21e2aa0611
--- /dev/null
+++ b/collects/icons/left-right-mask.xbm
@@ -0,0 +1,6 @@
+#define left_right_mask_xbm_width 16
+#define left_right_mask_xbm_height 16
+static char left_right_mask_xbm_bits[] = {
+   0xC0, 0x03, 0xC0, 0x03, 0xC0, 0x03, 0xC0, 0x03, 0xD8, 0x1B, 0xDC, 0x3B,
+   0xFE, 0x7F, 0xFF, 0xFF, 0xFE, 0x7F, 0xDC, 0x3B, 0xD8, 0x1B, 0xC0, 0x03,
+   0xC0, 0x03, 0xC0, 0x03, 0xC0, 0x03, 0x00, 0x00 };
diff --git a/collects/icons/lock.gif b/collects/icons/lock.gif
new file mode 100644
index 0000000000..57d01e6ea1
Binary files /dev/null and b/collects/icons/lock.gif differ
diff --git a/collects/icons/medium-plt.jpg b/collects/icons/medium-plt.jpg
new file mode 100644
index 0000000000..9f27eafd7b
Binary files /dev/null and b/collects/icons/medium-plt.jpg differ
diff --git a/collects/icons/mf.gif b/collects/icons/mf.gif
new file mode 100644
index 0000000000..ada14512c0
Binary files /dev/null and b/collects/icons/mf.gif differ
diff --git a/collects/icons/mini-plt.gif b/collects/icons/mini-plt.gif
new file mode 100644
index 0000000000..3bda50155f
Binary files /dev/null and b/collects/icons/mini-plt.gif differ
diff --git a/collects/icons/mini-plt.xbm b/collects/icons/mini-plt.xbm
new file mode 100644
index 0000000000..a0bbabadbc
--- /dev/null
+++ b/collects/icons/mini-plt.xbm
@@ -0,0 +1,5 @@
+#define mini-plt_width 15
+#define mini-plt_height 14
+static char mini-plt_bits[] = {
+ 0xe0,0x03,0xf8,0x0f,0xcc,0x1f,0xde,0x3f,0x9e,0x3f,0x3f,0x7f,0x7f,0x7f,0x7f,
+ 0x7e,0x7f,0x7c,0x3e,0x3d,0x9e,0x39,0xcc,0x13,0xf8,0x0f,0xe0,0x03};
diff --git a/collects/icons/mini-plt.xpm b/collects/icons/mini-plt.xpm
new file mode 100644
index 0000000000..a6ea1c5aa4
Binary files /dev/null and b/collects/icons/mini-plt.xpm differ
diff --git a/collects/icons/mred.gif b/collects/icons/mred.gif
new file mode 100644
index 0000000000..008931b346
Binary files /dev/null and b/collects/icons/mred.gif differ
diff --git a/collects/icons/mred.xbm b/collects/icons/mred.xbm
new file mode 100644
index 0000000000..9e42c634e0
--- /dev/null
+++ b/collects/icons/mred.xbm
@@ -0,0 +1,41 @@
+#define mred_width 70
+#define mred_height 62
+static char mred_bits[] = {
+ 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0x00,0x00,0x00,0x00,0x00,0x00,
+ 0x00,0x00,0xc0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0x00,0x00,0x00,
+ 0x00,0x00,0x00,0x80,0x00,0xc0,0x00,0xe0,0x00,0x00,0x00,0x00,0x80,0x01,0xc0,
+ 0x00,0x70,0x00,0x00,0x00,0x00,0x80,0x03,0xc0,0x00,0x30,0x00,0x00,0x00,0x00,
+ 0x00,0x03,0xc0,0x00,0x38,0x00,0x00,0x00,0x00,0x00,0x07,0xc0,0x00,0x18,0x00,
+ 0x00,0x00,0x00,0x00,0x0e,0xc0,0x00,0x1c,0x00,0x00,0x00,0x00,0x00,0x0e,0xc0,
+ 0x00,0x0e,0x00,0x00,0x00,0x1d,0x00,0x1c,0xc0,0x00,0x0e,0x00,0x00,0xfc,0xf7,
+ 0x00,0x1c,0xc0,0x00,0x07,0x00,0x00,0x28,0xc0,0x00,0x38,0xc0,0x00,0x07,0x00,
+ 0x00,0x00,0xc0,0x00,0x38,0xc0,0x80,0x07,0x00,0x00,0x00,0xc0,0x00,0x78,0xc0,
+ 0x80,0x03,0x00,0x00,0x00,0x60,0x00,0x70,0xc0,0xc0,0x03,0x00,0x00,0x00,0x70,
+ 0x00,0xf0,0xc0,0xc0,0x01,0x00,0x00,0x00,0x30,0x00,0xe0,0xc0,0xc0,0x01,0x00,
+ 0x00,0x00,0x18,0x00,0xe0,0xc0,0xe0,0x01,0x00,0x00,0x03,0x08,0x00,0xe0,0xc1,
+ 0xe0,0x01,0x00,0x80,0x01,0x0c,0x00,0xe0,0xc1,0xe0,0x00,0x00,0xc0,0x00,0x06,
+ 0x00,0xe0,0xc1,0xe0,0x01,0x00,0x60,0x00,0x03,0x00,0xc0,0xc1,0xf0,0x00,0x00,
+ 0x20,0x00,0x01,0x00,0xc0,0xc3,0xf0,0x00,0x00,0x30,0x80,0x00,0x00,0xc0,0xc3,
+ 0xf0,0x00,0x00,0x18,0x40,0x00,0x00,0xc0,0xc3,0xf0,0x00,0x00,0x0c,0x00,0x00,
+ 0x00,0xc0,0xc3,0xf0,0x00,0x00,0x04,0x00,0x00,0x00,0xc0,0xc3,0x70,0x00,0x00,
+ 0x8c,0xda,0x2f,0x00,0xc0,0xc3,0xf0,0x00,0x00,0xfc,0xff,0xff,0x07,0xc0,0xc3,
+ 0xf0,0x00,0x00,0xf0,0x05,0x80,0x0e,0x80,0xc3,0xf0,0x00,0x00,0x00,0x00,0x00,
+ 0x18,0xc0,0xc3,0xf0,0x00,0x00,0x00,0x00,0x00,0x18,0xc0,0xc3,0x70,0x00,0x00,
+ 0x00,0x00,0x00,0x18,0xc0,0xc3,0xf0,0x00,0x00,0x00,0x00,0x00,0x18,0xc0,0xc3,
+ 0xf0,0x00,0x00,0x00,0x00,0x00,0x18,0xc0,0xc3,0xf0,0x00,0x00,0x00,0x00,0x00,
+ 0x08,0xc0,0xc3,0xf0,0x00,0x00,0x00,0x00,0x00,0x0c,0xc0,0xc3,0xf0,0x00,0x00,
+ 0x00,0xfe,0x03,0x0c,0xc0,0xc1,0xe0,0x00,0xff,0xff,0xff,0x07,0x06,0xc0,0xc3,
+ 0xe0,0x01,0xfe,0x57,0x00,0x00,0x06,0xe0,0xc1,0xe0,0x01,0x00,0x00,0x00,0x00,
+ 0x03,0xc0,0xc1,0xe0,0x01,0x00,0x00,0x00,0x00,0x03,0xe0,0xc1,0xc0,0x01,0x00,
+ 0x00,0x00,0x80,0x01,0xe0,0xc0,0xc0,0x01,0x00,0x00,0x00,0x80,0x01,0xe0,0xc0,
+ 0xc0,0x03,0x00,0x00,0x00,0xc0,0x00,0xf0,0xc0,0x80,0x03,0x00,0x00,0x00,0xc0,
+ 0x00,0x70,0xc0,0x80,0x03,0x00,0x00,0x00,0x60,0x00,0x70,0xc0,0x80,0x07,0x00,
+ 0x00,0x00,0x70,0x00,0x78,0xc0,0x00,0x07,0x00,0x00,0x00,0x30,0x00,0x38,0xc0,
+ 0x00,0x07,0x00,0x00,0x80,0x19,0x00,0x38,0xc0,0x00,0x0e,0x00,0x00,0x00,0x1f,
+ 0x00,0x1c,0xc0,0x00,0x0e,0x00,0x00,0x00,0x0f,0x00,0x1c,0xc0,0x00,0x1c,0x00,
+ 0x00,0x00,0x06,0x00,0x0e,0xc0,0x00,0x18,0x00,0x00,0x00,0x00,0x00,0x06,0xc0,
+ 0x00,0x38,0x00,0x00,0x00,0x00,0x00,0x07,0xc0,0x00,0x30,0x00,0x00,0x00,0x00,
+ 0x00,0x03,0xc0,0x00,0x60,0x00,0x00,0x00,0x00,0x80,0x03,0xc0,0x00,0xe0,0x00,
+ 0x00,0x00,0x00,0x80,0x01,0xc0,0x00,0x40,0x00,0x00,0x00,0x00,0x40,0x00,0xc0,
+ 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0x00,0x00,0x00,0x00,0x00,0x00,
+ 0x00,0x00,0xc0};
diff --git a/collects/icons/mrf.jpg b/collects/icons/mrf.jpg
new file mode 100644
index 0000000000..460e305556
Binary files /dev/null and b/collects/icons/mrf.jpg differ
diff --git a/collects/icons/mrflow-small.bmp b/collects/icons/mrflow-small.bmp
new file mode 100644
index 0000000000..085fbae09f
Binary files /dev/null and b/collects/icons/mrflow-small.bmp differ
diff --git a/collects/icons/mrflow.gif b/collects/icons/mrflow.gif
new file mode 100644
index 0000000000..cb96547b17
Binary files /dev/null and b/collects/icons/mrflow.gif differ
diff --git a/collects/icons/mrspidey.bmp b/collects/icons/mrspidey.bmp
new file mode 100644
index 0000000000..6d289766b8
Binary files /dev/null and b/collects/icons/mrspidey.bmp differ
diff --git a/collects/icons/paren.bmp b/collects/icons/paren.bmp
new file mode 100644
index 0000000000..4e2ca23ad4
Binary files /dev/null and b/collects/icons/paren.bmp differ
diff --git a/collects/icons/paren.xbm b/collects/icons/paren.xbm
new file mode 100644
index 0000000000..f0581812dc
--- /dev/null
+++ b/collects/icons/paren.xbm
@@ -0,0 +1,4 @@
+#define paren_width 8
+#define paren_height 8
+static char paren_bits[] = {
+ 0x11,0x00,0x44,0x00,0x11,0x00,0x44,0x00};
diff --git a/collects/icons/plt-flat.gif b/collects/icons/plt-flat.gif
new file mode 100644
index 0000000000..5df03e5998
Binary files /dev/null and b/collects/icons/plt-flat.gif differ
diff --git a/collects/icons/plt-logo-no-hole.gif b/collects/icons/plt-logo-no-hole.gif
new file mode 100644
index 0000000000..120a0feb7e
Binary files /dev/null and b/collects/icons/plt-logo-no-hole.gif differ
diff --git a/collects/icons/plt-logo.gif b/collects/icons/plt-logo.gif
new file mode 100644
index 0000000000..99c0e15928
Binary files /dev/null and b/collects/icons/plt-logo.gif differ
diff --git a/collects/icons/plt-old.gif b/collects/icons/plt-old.gif
new file mode 100644
index 0000000000..7f74708194
Binary files /dev/null and b/collects/icons/plt-old.gif differ
diff --git a/collects/icons/plt-small-shield.gif b/collects/icons/plt-small-shield.gif
new file mode 100644
index 0000000000..0421e77465
Binary files /dev/null and b/collects/icons/plt-small-shield.gif differ
diff --git a/collects/icons/plt.gif b/collects/icons/plt.gif
new file mode 100644
index 0000000000..652dacbc73
Binary files /dev/null and b/collects/icons/plt.gif differ
diff --git a/collects/icons/plt.jpg b/collects/icons/plt.jpg
new file mode 100644
index 0000000000..6f2e488d62
Binary files /dev/null and b/collects/icons/plt.jpg differ
diff --git a/collects/icons/plt.xpm b/collects/icons/plt.xpm
new file mode 100644
index 0000000000..40bc0d4287
Binary files /dev/null and b/collects/icons/plt.xpm differ
diff --git a/collects/icons/pltbw.gif b/collects/icons/pltbw.gif
new file mode 100644
index 0000000000..23944521a8
Binary files /dev/null and b/collects/icons/pltbw.gif differ
diff --git a/collects/icons/recycle.gif b/collects/icons/recycle.gif
new file mode 100644
index 0000000000..403673fd7a
Binary files /dev/null and b/collects/icons/recycle.gif differ
diff --git a/collects/icons/red-arrow.bmp b/collects/icons/red-arrow.bmp
new file mode 100644
index 0000000000..0d1c1ebdee
Binary files /dev/null and b/collects/icons/red-arrow.bmp differ
diff --git a/collects/icons/reset.xbm b/collects/icons/reset.xbm
new file mode 100644
index 0000000000..954f790ed3
--- /dev/null
+++ b/collects/icons/reset.xbm
@@ -0,0 +1,6 @@
+#define reset_width 16
+#define reset_height 16
+static unsigned char reset_bits[] = {
+  0x01, 0x80, 0x03, 0x00, 0x06, 0x00, 0x0c, 0x00, 0x18, 0x00, 0x30, 0x00,
+  0x60, 0x00, 0xc0, 0x00, 0x80, 0x01, 0x00, 0x03, 0x00, 0x06, 0x00, 0x0c,
+  0x00, 0x18, 0x00, 0x30, 0x00, 0x60, 0x00, 0xc0, };
diff --git a/collects/icons/return.xbm b/collects/icons/return.xbm
new file mode 100644
index 0000000000..7285ce88b7
--- /dev/null
+++ b/collects/icons/return.xbm
@@ -0,0 +1,4 @@
+#define return_width 6
+#define return_height 9
+static char return_bits[] = {
+ 0x1e,0x3e,0x30,0x30,0x39,0x1f,0x0f,0x0f,0x1f};
diff --git a/collects/icons/run.png b/collects/icons/run.png
new file mode 100644
index 0000000000..dc02195f4d
Binary files /dev/null and b/collects/icons/run.png differ
diff --git a/collects/icons/save.png b/collects/icons/save.png
new file mode 100644
index 0000000000..c2d4410c30
Binary files /dev/null and b/collects/icons/save.png differ
diff --git a/collects/icons/scheme-box.jpg b/collects/icons/scheme-box.jpg
new file mode 100644
index 0000000000..470895c071
Binary files /dev/null and b/collects/icons/scheme-box.jpg differ
diff --git a/collects/icons/scheme-splice-box.jpg b/collects/icons/scheme-splice-box.jpg
new file mode 100644
index 0000000000..7e2fb2c730
Binary files /dev/null and b/collects/icons/scheme-splice-box.jpg differ
diff --git a/collects/icons/schemedoc.ico b/collects/icons/schemedoc.ico
new file mode 100644
index 0000000000..4d8c753acc
Binary files /dev/null and b/collects/icons/schemedoc.ico differ
diff --git a/collects/icons/semicolon.gif b/collects/icons/semicolon.gif
new file mode 100644
index 0000000000..e67a0f0481
Binary files /dev/null and b/collects/icons/semicolon.gif differ
diff --git a/collects/icons/sk.jpg b/collects/icons/sk.jpg
new file mode 100644
index 0000000000..8c0c23d82e
Binary files /dev/null and b/collects/icons/sk.jpg differ
diff --git a/collects/icons/slash-slash.gif b/collects/icons/slash-slash.gif
new file mode 100644
index 0000000000..f3dbfc8c57
Binary files /dev/null and b/collects/icons/slash-slash.gif differ
diff --git a/collects/icons/syncheck.png b/collects/icons/syncheck.png
new file mode 100644
index 0000000000..be07bc9cbc
Binary files /dev/null and b/collects/icons/syncheck.png differ
diff --git a/collects/icons/texas-plt-bw.gif b/collects/icons/texas-plt-bw.gif
new file mode 100644
index 0000000000..a93eadacf1
Binary files /dev/null and b/collects/icons/texas-plt-bw.gif differ
diff --git a/collects/icons/touch.bmp b/collects/icons/touch.bmp
new file mode 100644
index 0000000000..d4e7ad4931
Binary files /dev/null and b/collects/icons/touch.bmp differ
diff --git a/collects/icons/trumpet.xbm b/collects/icons/trumpet.xbm
new file mode 100644
index 0000000000..1e7addae32
--- /dev/null
+++ b/collects/icons/trumpet.xbm
@@ -0,0 +1,8 @@
+#define trumpet_width 24
+#define trumpet_height 24
+static unsigned char trumpet_bits[] = {
+ 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x40,0x00,0x00,0x40,0x00,0x00,0x60,
+ 0x00,0x00,0x50,0x00,0x00,0x68,0x00,0x00,0x76,0x06,0xe0,0x7d,0xfa,0x4f,0x7f,
+ 0xa6,0xbf,0x7f,0xfe,0x7f,0x7f,0x86,0xfa,0x7e,0xc0,0xe7,0x78,0xa0,0xc1,0x71,
+ 0xe0,0xc0,0x61,0xe0,0x40,0x41,0xe0,0x40,0x41,0xc0,0xa1,0x00,0xc0,0xff,0x00,
+ 0x80,0x7f,0x00,0x00,0x1e,0x00,0x00,0x00,0x00,0x00,0x00,0x00};
diff --git a/collects/icons/turn-down-click.png b/collects/icons/turn-down-click.png
new file mode 100644
index 0000000000..2e91127976
Binary files /dev/null and b/collects/icons/turn-down-click.png differ
diff --git a/collects/icons/turn-down.png b/collects/icons/turn-down.png
new file mode 100644
index 0000000000..e163ec5466
Binary files /dev/null and b/collects/icons/turn-down.png differ
diff --git a/collects/icons/turn-up-click.png b/collects/icons/turn-up-click.png
new file mode 100644
index 0000000000..df807d9648
Binary files /dev/null and b/collects/icons/turn-up-click.png differ
diff --git a/collects/icons/turn-up.png b/collects/icons/turn-up.png
new file mode 100644
index 0000000000..a38a83b60a
Binary files /dev/null and b/collects/icons/turn-up.png differ
diff --git a/collects/icons/unlock.gif b/collects/icons/unlock.gif
new file mode 100644
index 0000000000..2c56f154a1
Binary files /dev/null and b/collects/icons/unlock.gif differ
diff --git a/collects/icons/up-down-cursor.xbm b/collects/icons/up-down-cursor.xbm
new file mode 100644
index 0000000000..3789879c6e
--- /dev/null
+++ b/collects/icons/up-down-cursor.xbm
@@ -0,0 +1,6 @@
+#define up_down_cursor_xbm_width 16
+#define up_down_cursor_xbm_height 16
+static char up_down_cursor_xbm_bits[] = {
+   0x00, 0x00, 0x00, 0x01, 0x80, 0x03, 0xC0, 0x07, 0x00, 0x01, 0x00, 0x01,
+   0x00, 0x01, 0xFC, 0x7F, 0xFC, 0x7F, 0x00, 0x01, 0x00, 0x01, 0x00, 0x01,
+   0xC0, 0x07, 0x80, 0x03, 0x00, 0x01, 0x00, 0x00 };
diff --git a/collects/icons/up-down-mask.xbm b/collects/icons/up-down-mask.xbm
new file mode 100644
index 0000000000..3fdd7c4044
--- /dev/null
+++ b/collects/icons/up-down-mask.xbm
@@ -0,0 +1,6 @@
+#define up_down_mask_xbm_width 16
+#define up_down_mask_xbm_height 16
+static char up_down_mask_xbm_bits[] = {
+   0x00, 0x01, 0x80, 0x03, 0xC0, 0x07, 0xE0, 0x0F, 0xE0, 0x0F, 0x80, 0x03,
+   0xFE, 0xFF, 0xFE, 0xFF, 0xFE, 0xFF, 0xFE, 0xFF, 0x80, 0x03, 0xE0, 0x0F,
+   0xE0, 0x0F, 0xC0, 0x07, 0x80, 0x03, 0x00, 0x01 };
diff --git a/collects/icons/wizard-image.jpg b/collects/icons/wizard-image.jpg
new file mode 100644
index 0000000000..3b12c48a10
Binary files /dev/null and b/collects/icons/wizard-image.jpg differ
diff --git a/collects/icons/xml-box-open.jpg b/collects/icons/xml-box-open.jpg
new file mode 100644
index 0000000000..275b4cfeeb
Binary files /dev/null and b/collects/icons/xml-box-open.jpg differ
diff --git a/collects/icons/xml-box.jpg b/collects/icons/xml-box.jpg
new file mode 100644
index 0000000000..385e936016
Binary files /dev/null and b/collects/icons/xml-box.jpg differ
diff --git a/collects/lang/doc.txt b/collects/lang/doc.txt
new file mode 100644
index 0000000000..74e44c43aa
--- /dev/null
+++ b/collects/lang/doc.txt
@@ -0,0 +1,74 @@
+
+The "lang" collection defines a number of modules that can serve as
+languages for other modules (i.e., as the initial import):
+
+ * _r5rs.ss_ - provides R5RS Scheme, plus _#%provide_ (instead of
+   `provide'), _#%require_ (instead of `#%require'), `#%app',
+   `%datum', etc.  The `letrec' of this language is defined exactly as
+   in R5RS, and not as in MzScheme.
+
+ * _plt-pretty-big-text.ss_ - provides MzScheme plus the
+   following MzLib libraries: etc.ss, file.ss, list.ss,
+   class.ss, unit.ss, unitsig.ss, include.ss, defmacro.ss,
+   pretty.ss, string.ss, thread.ss, math.ss, match.ss, and
+   shared.ss. It also provides the posn, color, and image
+   functions of Beginning Student.
+
+ * _plt-pretty-big.ss_ - provides plt-pretty-big-text.ss
+    plus the MrEd classes. This corresponds to the
+    _Pretty Big Scheme_ language in DrScheme.
+
+ * _htdp-beginner.ss_ - provides Beginning Student
+
+ * _htdp-beginner-abbr.ss_ - provides Beginning Student with List Abbreviations
+
+ * _htdp-intermediate.ss_ - provides Intermediate Student
+
+ * _htdp-intermediate-lambda.ss_ - provides Intermediate Student with Lambda
+
+ * _htdp-advanced.ss_ - provides Advanced Student
+
+In addition, the "lang" collection defines two modules that supply
+special teaching functions:
+
+ * _posn.ss_ - provides the `posn' structure
+
+ * _imageeq.ss_ - provides the `image=?' function
+
+----------------------------------------
+
+_Teachpacks, Beginner_
+_Teachpacks, Higher-order Primitives_
+
+The _prim.ss_ module defines two syntactic forms for use by the
+implementors of teachpacks, which the teachpack is to be used with the
+Beginner Student languages. In Beginner Student, primitive names (for
+built-in procedures) are distinguished from other types of
+expressions, so that they can be syntactically restricted to
+application positions.
+
+> (define-higher-order-procedure id proc-id (arg ...)) - defines `id'
+  to be a primitive operator whose implementation is
+  `proc-id'. Normally, `id' is exported from the teachpack and
+  `proc-id' is not.
+
+  For each non-procedure argument, the corresponding `arg' should be
+  an underscore. For each procedure argument, the corresponding `arg'
+  should be the usual name of the procedure.
+
+  Example: 
+   (define-higher-order-primitive convert-gui convert-gui/proc (f2c))
+
+> (provide-higher-order-procedure id (arg ...)) - like above, but the
+  function `id' is exported as the primitive operator named `id'.
+
+> (define-primitive id proc-id) - defines `id' to be a primitive
+  operator whose implementation is `proc-id', and which takes no
+  procedures as arguments. Normally, `id' is exported from the
+  teachpack and `proc-id' is not.
+
+> (provide-primitive id) - like above, but the function `id' is
+  exported as the primitive operator named `id'.
+
+> (provide-primitives id ...) - multi-provide version of
+  `provide-primitive'.
diff --git a/collects/lang/error.ss b/collects/lang/error.ss
new file mode 100644
index 0000000000..f5f2cb9117
--- /dev/null
+++ b/collects/lang/error.ss
@@ -0,0 +1,78 @@
+(module error mzscheme
+  (require (lib "etc.ss") (lib "list.ss"))
+  ;; --------------------------------------------------------------------------
+  (provide
+   check-arg
+   check-arity
+   check-proc
+   check-result
+   check-list-list
+   find-non
+   ;; --- error constants 
+   result-error ; String[format: String[expected], Any[given]]
+   arg-error    ; String [format: String[expected], String[position] Any[given]]
+   arity-error  ; String [format: String[expected] Any[given]]
+   proc-error   ; String [format: String[expected] Any[given]]
+   arity-error2 ; String [format: String[expected], String[position] Number[given]]
+   )
+
+  ;; (_ -> Boolean) (listof X) -> (union X false)
+  (define (find-non pred? l)
+    (let ([r (filter (compose not pred?) l)])
+      (if (null? r) #f (car r))))
+
+  #| Tests ------------------------------------------------------------------
+  (not (find-non list? '((1 2 3) (a b c))))
+  (symbol? (find-non number? '(1 2 3 a)))
+  (symbol? (find-non list? '((1 2 3) a (b c))))
+  |#
+
+  ;; Symbol (union true String) String X -> void
+  (define (check-list-list pname condition pred given)
+    (when (string? condition)
+      (error pname (string-append condition (format "~nin ~e" given)))))
+
+  ;; Symbol (_ -> Boolean) String X -> X 
+  (define (check-result pname pred? expected given)
+    (if (pred? given) given (error pname result-error expected given)))
+
+  ;; String[format: String[expected], Any[given]
+  (define result-error "expected ~a result, given: ~e")
+
+  ;; check-arg : sym bool str str TST -> void
+  (define (check-arg pname condition expected arg-posn given)
+    (unless condition (error pname arg-error expected arg-posn given)))
+  
+  ;; String [format: String[expected], String[position] Any[given]
+  (define arg-error "expected <~a> as ~a argument, given: ~e")
+
+  ;; check-arity : sym num (list-of TST) -> void
+  (define (check-arity name arg# args)
+    (let ([x (length args)])
+      (if (>= x arg#) (void) (error name arity-error arg# x))))
+
+  ;; String [format: String[expected] Any[given]
+  (define arity-error "expects at least ~a arguments, given ~e")
+  
+  ;; String [format: String[expected] Any[given]
+  (define proc-error "procedure expected as ~s argument, given ~e")
+  
+  ;; check-proc :
+  ;;   sym (... *->* ...) num (union sym str) (union sym str) -> void
+  (define (check-proc proc f exp-arity arg# arg-err)
+    (unless (procedure? f) (error proc proc-error arg# f))
+    (unless (procedure-arity-includes? f exp-arity)
+      (let ([arity-of-f (procedure-arity f)])
+        (error proc arity-error2
+	  arg-err arg# 
+	  (cond
+	    [(number? arity-of-f)
+	     (if (= arity-of-f 1)
+		 (format "1 argument")
+		 (format "~s arguments" arity-of-f))]
+	    [(arity-at-least? arity-of-f) (format "at least ~s arguments" (arity-at-least-value arity-of-f))]
+	    [else (format "multiple arities (~s)" arity-of-f)])))))
+
+  ;; String [format: String[expected], String[position] Number[given]  
+  (define arity-error2 "procedure of ~a expected as ~s argument, given procedure of ~a ")
+  )
diff --git a/collects/lang/htdp-advanced.ss b/collects/lang/htdp-advanced.ss
new file mode 100644
index 0000000000..89beeea203
--- /dev/null
+++ b/collects/lang/htdp-advanced.ss
@@ -0,0 +1,123 @@
+
+(module htdp-advanced mzscheme
+  (require "private/teach.ss"
+	   "private/teachprims.ss"
+	   "private/contract-forms.ss"
+	   (lib "etc.ss")
+	   (lib "list.ss")
+	   (lib "pretty.ss")
+	   (lib "docprovide.ss" "syntax")
+	   "posn.ss")
+
+  ;; syntax:
+  (provide (rename advanced-define define)
+	   (rename advanced-define-struct define-struct)
+	   (rename advanced-lambda lambda)
+	   (rename advanced-app #%app)
+	   (rename beginner-top #%top)
+	   (rename intermediate-local local)
+	   (rename advanced-let let)
+	   (rename intermediate-let* let*)
+	   (rename intermediate-letrec letrec)
+	   (rename advanced-recur recur)
+	   (rename beginner-cond cond)
+	   (rename beginner-else else)
+	   (rename beginner-if if)
+	   (rename beginner-and and)
+	   (rename beginner-or or)
+	   (rename intermediate-quote quote)
+	   (rename intermediate-quasiquote quasiquote)
+	   (rename intermediate-unquote unquote)
+	   (rename intermediate-unquote-splicing unquote-splicing)
+	   (rename intermediate-time time)
+	   (rename advanced-begin begin)
+	   (rename advanced-begin0 begin0)
+	   (rename advanced-shared shared)
+	   (rename advanced-set! set!)
+	   (rename advanced-when when)
+	   (rename advanced-unless unless)
+	   (rename advanced-case case)
+	   (rename advanced-delay delay)
+	   (rename advanced-module-begin #%module-begin)
+	   (rename advanced-contract contract)
+	   (rename advanced-define-data define-data)
+	   #%datum
+	   empty true false)
+
+  ;; procedures:
+  (provide-and-document
+   procedures
+
+   (all-from-except intermediate: (lib "htdp-intermediate-lambda.ss" "lang") procedures
+		    cons list* append)
+
+   ("Reading and Printing"
+    (print (any -> void)
+	   "to print the argument as a value to stdout")
+    (display (any -> void)
+	     "to print the argument to stdout (without quotes on symbols and strings, etc.)")
+    (write (any -> void)
+	   "to print the argument to stdout (in a traditional style that is somewhere between print and display)")
+    (pretty-print (any -> void)
+	   "like write, but with standard newlines and indentation")
+    (printf (string any ... -> void)
+	    "to format the rest of the arguments according to the first argument and print it to stdout")
+    (newline (-> void)
+	     "to print a newline to stdout")
+    (read (-> sexp) "to read input from the user"))
+   
+   ("Lists"
+     (list? (any -> boolean)
+       "to determine whether some value is a list")
+
+    ((advanced-cons cons) (X (listof X) -> (listof X))
+			  "to construct a list")
+
+    (set-first! ((cons Y (listof X)) Y -> void)
+		"to update the first item of a non-empty list")
+    ((advanced-set-rest! set-rest!) ((cons Y (listof X)) (listof X) -> void)
+	       "to update the rest of a non-empty list")
+    (set-car! ((cons Y (listof X)) Y -> void)
+	      "to update the first item of a non-empty list")
+    ((advanced-set-cdr! set-cdr!) ((cons Y (listof X)) (listof X) -> void)
+				  "to update the rest of a non-empty list")
+    ((advanced-append append) ((listof any) ... -> (listof any))
+			      "to create a single list from several, by updating the lists")
+    ((advanced-append! append!) ((listof any) ... -> (listof any))
+				"to create a single list from several, by updating the lists"))
+   
+   ("Misc"
+    (force (delay -> any) "to find the delayed value; see also delay")
+    (promise? (any -> boolean) "to determine if a value is delayed")
+    (void (-> void) "produces a void value")
+    (void? (any -> boolean) "to determine if a value is void"))
+
+   ("Posns"
+    (set-posn-x! (posn number -> void) "to update the x component of a posn")
+    (set-posn-y! (posn number -> void) "to update the x component of a posn"))
+
+   ("Vectors"
+    (vector (X ... -> (vector X ...))
+	    "to construct a vector")
+    (make-vector (number X -> (vectorof X))
+		 "to construct a vector")
+    (build-vector (nat (nat -> X)  -> (vectorof X))
+		  "to construct a vector")	
+    (vector-ref ((vector X) nat -> X)
+		"to extract an element from a vector")
+    (vector-length ((vector X) -> nat)
+		   "to determine the length of a vector")	
+    (vector-set! ((vectorof X) nat X -> void)
+		 "to update a vector")
+    (vector? (any -> boolean)
+	     "to determine if a value is a vector"))
+
+   ("Boxes"
+    (box (any -> box)
+	 "to construct a box")
+    (unbox (box -> any)
+	   "to extract the boxed value")
+    (set-box! (box any -> void)
+	      "to update a box")
+    (box? (any -> boolean)
+	  "to determine if a value is a box"))))
diff --git a/collects/lang/htdp-beginner-abbr.ss b/collects/lang/htdp-beginner-abbr.ss
new file mode 100644
index 0000000000..7ba4e9c1bf
--- /dev/null
+++ b/collects/lang/htdp-beginner-abbr.ss
@@ -0,0 +1,34 @@
+
+(module htdp-beginner-abbr mzscheme
+  (require (lib "etc.ss")
+	   (lib "list.ss")
+	   (lib "math.ss")
+	   (lib "docprovide.ss" "syntax"))
+
+  ;; Implements the forms:
+  (require "private/teach.ss"
+	   "private/teachprims.ss")
+
+  ;; syntax:
+  (provide (rename beginner-define define)
+	   (rename beginner-define-struct define-struct)
+	   (rename beginner-lambda lambda)
+	   (rename beginner-app #%app)
+	   (rename beginner-top #%top)
+	   (rename beginner-cond cond)
+	   (rename beginner-else else)
+	   (rename beginner-if if)
+	   (rename beginner-and and)
+	   (rename beginner-or or)
+	   (rename intermediate-quote quote)
+	   (rename intermediate-quasiquote quasiquote)
+	   (rename intermediate-unquote unquote)
+	   (rename intermediate-unquote-splicing unquote-splicing)
+	   (rename #%plain-module-begin #%module-begin)
+	   #%datum
+	   empty true false)
+
+  ;; procedures:
+  (provide-and-document
+   procedures
+   (all-from beginner: (lib "htdp-beginner.ss" "lang") procedures)))
diff --git a/collects/lang/htdp-beginner.ss b/collects/lang/htdp-beginner.ss
new file mode 100644
index 0000000000..c1b2908d2d
--- /dev/null
+++ b/collects/lang/htdp-beginner.ss
@@ -0,0 +1,73 @@
+
+;; Implements the Beginner Scheme language, at least in terms of the
+;; forms and procedures. The reader-level aspects of the language
+;; (e.g., case-sensitivity) are not implemented here.
+
+(module htdp-beginner mzscheme
+  (require (lib "etc.ss")
+	   (lib "list.ss")
+	   (lib "docprovide.ss" "syntax"))
+  
+  ;; Implements the forms:
+  (require "private/teach.ss"
+	   "private/contract-forms.ss")
+  
+  ;; syntax:
+  (provide (rename beginner-define define)
+	   (rename beginner-define-struct define-struct)
+	   (rename beginner-lambda lambda)
+	   (rename beginner-app #%app)
+	   (rename beginner-top #%top)
+	   (rename beginner-cond cond)
+	   (rename beginner-else else)
+	   (rename beginner-if if)
+	   (rename beginner-and and)
+	   (rename beginner-or or)
+	   (rename beginner-quote quote)
+	   (rename beginner-module-begin #%module-begin)
+	   (rename beginner-contract contract)
+	   (rename beginner-define-data define-data)
+	   #%datum
+	   empty true false)
+  
+  (define-syntax (in-rator-position-only stx)
+    (syntax-case stx ()
+      [(_ new-name orig-name)
+       (let ([new (syntax new-name)]
+             [orig (syntax orig-name)])
+         ;; Some things are not really functions:
+         (if (memq (syntax-e orig) '(beginner:pi beginner:e beginner:null beginner:eof))
+             #'(define new-name orig-name)
+	     (with-syntax ([(what something)
+			    (case (syntax-e orig)
+			      [(beginner:make-posn)
+			       #'("constructor"
+				  "called with values for the structure fields")]
+			      [(beginner:posn-x beginner:posn-y)
+			       #'("selector"
+				  "applied to a structure to get the field value")]
+			      [(beginner:posn?)
+			       #'("predicate"
+				  "applied to an argument")]
+			      [else
+			       #'("primitive operator"
+				  "applied to arguments")])])
+	       #'(define-syntax (new-name stx)
+		   (syntax-case stx ()
+		     [(id . args)
+		      (syntax/loc stx (beginner-app orig-name . args))]
+		     [_else
+		      (raise-syntax-error
+		       #f
+		       (format
+			"this ~a must be ~a; expected an open parenthesis before the ~a name"
+			what
+			something
+			what)
+		       stx)])))))]))
+  
+  ;; procedures:
+  (provide-and-document/wrap
+   procedures
+   in-rator-position-only
+   (all-from beginner: (lib "beginner-funs.ss" "lang" "private") procedures)))
diff --git a/collects/lang/htdp-intermediate-lambda.ss b/collects/lang/htdp-intermediate-lambda.ss
new file mode 100644
index 0000000000..883c76ae18
--- /dev/null
+++ b/collects/lang/htdp-intermediate-lambda.ss
@@ -0,0 +1,36 @@
+
+(module htdp-intermediate-lambda mzscheme
+  (require "private/teach.ss"
+	   (lib "etc.ss")
+	   (lib "list.ss")
+	   (lib "docprovide.ss" "syntax"))
+
+  ;; syntax:
+  (provide (rename intermediate-define define)
+	   (rename intermediate-define-struct define-struct)
+	   (rename intermediate-lambda lambda)
+	   (rename advanced-app #%app)
+	   (rename beginner-top #%top)
+	   (rename intermediate-local local)
+	   (rename intermediate-let let)
+	   (rename intermediate-let* let*)
+	   (rename intermediate-letrec letrec)
+	   (rename intermediate-recur recur)
+	   (rename beginner-cond cond)
+	   (rename beginner-else else)
+	   (rename beginner-if if)
+	   (rename beginner-and and)
+	   (rename beginner-or or)
+	   (rename intermediate-quote quote)
+	   (rename intermediate-quasiquote quasiquote)
+	   (rename intermediate-unquote unquote)
+	   (rename intermediate-unquote-splicing unquote-splicing)
+	   (rename intermediate-time time)
+	   (rename #%plain-module-begin #%module-begin)
+	   #%datum
+	   empty true false)
+
+  ;; procedures:
+  (provide-and-document
+   procedures
+   (all-from beginner: (lib "htdp-intermediate.ss" "lang") procedures)))
diff --git a/collects/lang/htdp-intermediate.ss b/collects/lang/htdp-intermediate.ss
new file mode 100644
index 0000000000..d10b6eb059
--- /dev/null
+++ b/collects/lang/htdp-intermediate.ss
@@ -0,0 +1,74 @@
+
+(module htdp-intermediate mzscheme
+  (require "private/teach.ss"
+           "private/teachprims.ss"
+	   "private/contract-forms.ss"
+	   (lib "etc.ss")
+	   (lib "list.ss")
+	   (lib "docprovide.ss" "syntax"))
+
+  ;; syntax:
+  (provide (rename intermediate-define define)
+	   (rename intermediate-define-struct define-struct)
+	   (rename beginner-lambda lambda)
+	   (rename intermediate-app #%app)
+	   (rename beginner-top #%top)
+	   (rename intermediate-local local)
+	   (rename intermediate-let let)
+	   (rename intermediate-let* let*)
+	   (rename intermediate-letrec letrec)
+	   ; (rename intermediate-recur recur)
+	   (rename beginner-cond cond)
+	   (rename beginner-else else)
+	   (rename beginner-if if)
+	   (rename beginner-and and)
+	   (rename beginner-or or)
+	   (rename intermediate-quote quote)
+	   (rename intermediate-quasiquote quasiquote)
+	   (rename intermediate-unquote unquote)
+	   (rename intermediate-unquote-splicing unquote-splicing)
+	   (rename intermediate-time time)
+	   (rename intermediate-module-begin #%module-begin)
+	   (rename intermediate-contract contract)
+	   (rename intermediate-define-data define-data)
+	   #%datum
+	   empty true false)
+
+  ;; procedures:
+  (provide-and-document
+   procedures
+   (all-from beginner: (lib "beginner-funs.ss" "lang" "private") procedures)
+
+   ("Higher-Order Functions"
+    (map ((X ... -> Z) (listof X) ... -> (listof Z))
+	 "to construct a new list by applying a function to each item on one or more existing lists") 
+    (for-each ((any ... -> any) (listof any) ... -> void)
+	      "to apply a function to each item on one or more lists for effect only")
+    (filter ((X -> boolean) (listof X) -> (listof X))
+	    "to construct a list from all those items on a list for which the predicate holds")
+    (foldr ((X Y -> Y) Y (listof X) -> Y)
+	   "(foldr f base (list x-1 ... x-n)) = (f x-1 ... (f x-n base))")
+    (foldl ((X Y -> Y) Y (listof X) -> Y)
+	   "(foldl f base (list x-1 ... x-n)) = (f x-n ... (f x-1 base))")
+    (build-list (nat (nat -> X) -> (listof X))
+		"(build-list n f) = (list (f 0) ... (f (- n 1)))")
+    (build-string (nat (nat -> char) -> string)
+		  "(build-string n f) = (string (f 0) ... (f (- n 1)))")
+    ((intermediate-quicksort quicksort) ((listof X) (X X -> boolean) -> (listof X))
+	       "to construct a list from all items on a list in an order according to a predicate")
+    (andmap ((X -> boolean) (listof X) -> boolean)
+	    "(andmap p (list x-1 ... x-n)) = (and (p x-1) (and ... (p x-n)))")
+    (ormap ((X -> boolean) (listof X) -> boolean)
+	   "(ormap p (list x-1 ... x-n)) = (or (p x-1) (or ... (p x-n)))")
+
+    (memf ((X -> boolean) (listof X) -> (union false (listof X)))
+	  "to determine whether the first argument produces true for some value in the second argument")
+    (assf ((X -> boolean) (listof (cons X Y)) -> (union false (cons X Y)))
+	  "to determine whether the first argument produces true for some value in the second argument")
+    
+    (apply ((X-1 ... X-N -> Y) X-1 ... X-i (list X-i+1 ... X-N) -> Y)
+	      "to apply a function using items from a list as the arguments")
+    (compose ((Y-1 -> Z) ... (Y-N -> Y-N-1) (X-1 ... X-N -> Y-N) -> (X-1 ... X-N -> Z))
+	     "to compose a sequence of procedures into a single procedure")
+    (procedure? (any -> boolean)
+	     "to determine if a value is a procedure"))))
diff --git a/collects/lang/htdp-langs.ss b/collects/lang/htdp-langs.ss
new file mode 100644
index 0000000000..60f7e7c840
--- /dev/null
+++ b/collects/lang/htdp-langs.ss
@@ -0,0 +1,967 @@
+#|
+
+tracing todo:
+ - shorten lines
+
+;; we don't use the built in debugging, use our own
+;; version here that has no bug icon and only
+;; annotates code that comes from editors.
+
+|#
+
+(module htdp-langs mzscheme
+  (require (lib "string-constant.ss" "string-constants")
+           (lib "framework.ss" "framework")
+           (prefix et: (lib "stacktrace.ss" "errortrace"))
+           (prefix tr: (lib "stacktrace.ss" "trace"))
+           (lib "pretty.ss")
+           (prefix pc: (lib "pconvert.ss"))
+           (lib "unitsig.ss")
+           (lib "class.ss")
+           (lib "list.ss")
+           (lib "file.ss")
+           (lib "tool.ss" "drscheme")
+           (lib "mred.ss" "mred")
+           (lib "bday.ss" "framework" "private")
+           (lib "moddep.ss" "syntax")
+           (lib "cache-image-snip.ss" "mrlib"))
+  
+  (provide tool@)
+  
+  (define sc-tracing (string-constant tracing-enable-tracing))
+  (define sc-show-tracing-window (string-constant tracing-show-tracing-window))
+  (define sc-hide-tracing-window (string-constant tracing-hide-tracing-window))
+  (define sc-tracing-nothing-to-show (string-constant tracing-tracing-nothing-to-show))
+  
+  (define ellipses-cutoff 200)
+  
+  (define o (current-output-port))
+  (define (oprintf . args) (apply fprintf o args))
+  
+  (define init-eventspace (current-eventspace))
+  
+  (define tool@
+    (unit/sig drscheme:tool-exports^
+      (import drscheme:tool^)
+
+      (define-local-member-name
+        get-tracing-text
+        show-tracing
+        tracing:add-line
+        tracing:rest)
+      (define tab-tracing<%>
+        (interface ()
+          get-tracing-text
+          get-any-results?
+          tracing:add-line
+          tracing:reset))
+      
+      
+      (define drs-eventspace (current-eventspace))
+      
+      (define-struct (htdp-lang-settings drscheme:language:simple-settings) (tracing?))
+      
+      (define image-string "<image>")
+      
+      (define htdp-language<%>
+        (interface ()
+          get-module
+          get-language-position
+          get-sharing-printing
+          get-abbreviate-cons-as-list
+          get-allow-sharing?
+          get-use-function-output-syntax?
+          get-accept-quasiquote?
+          get-read-accept-dot))
+      
+      ;; module-based-language-extension :    (implements drscheme:language:module-based-language<%>) 
+      ;;                                   -> (implements drscheme:language:module-based-language<%>)
+      ;; changes the default settings and sets a few more paramters during `on-execute'
+      (define (module-based-language-extension super%)
+        (class* super% ()
+          
+          (inherit get-sharing-printing get-abbreviate-cons-as-list)
+          
+          (define/override (default-settings)
+            (make-htdp-lang-settings 
+             #t
+             'constructor
+             'repeating-decimal
+             (get-sharing-printing)
+             #t
+             'none
+             #f))
+          
+          (define/override (default-settings? s)
+            (and (super default-settings? s)
+                 (not (htdp-lang-settings-tracing? s))))
+          
+          (define/override (marshall-settings x)
+            (list (super marshall-settings x)
+                  (htdp-lang-settings-tracing? x)))
+          
+          (define/override (unmarshall-settings x)
+            (if (and (pair? x)
+                     (pair? (cdr x))
+                     (null? (cddr x))
+                     (boolean? (cadr x)))
+                (let ([drs-settings (super unmarshall-settings (first x))])
+                  (make-htdp-lang-settings
+                   (drscheme:language:simple-settings-case-sensitive drs-settings)
+                   (drscheme:language:simple-settings-printing-style  drs-settings)
+                   (drscheme:language:simple-settings-fraction-style  drs-settings)
+                   (drscheme:language:simple-settings-show-sharing  drs-settings)
+                   (drscheme:language:simple-settings-insert-newlines  drs-settings)
+                   (drscheme:language:simple-settings-annotations drs-settings)
+                   (cadr x)))
+                (default-settings)))
+          
+          (inherit get-allow-sharing? get-use-function-output-syntax? 
+                   get-accept-quasiquote? get-read-accept-dot)
+          (define/override (config-panel parent)
+            (sharing/not-config-panel (get-allow-sharing?) parent))
+          
+          (define/override (on-execute settings run-in-user-thread)
+            (let ([drs-namespace (current-namespace)])
+              (run-in-user-thread
+               (lambda ()
+                 (read-accept-quasiquote (get-accept-quasiquote?))
+                 (namespace-attach-module drs-namespace 'drscheme-secrets)
+                 (error-display-handler teaching-languages-error-display-handler)
+                 (current-eval (add-annotation (htdp-lang-settings-tracing? settings) (current-eval)))
+                 (error-print-source-location #f)
+                 (read-decimal-as-inexact #f)
+                 (read-accept-dot (get-read-accept-dot)))))
+            (super on-execute settings run-in-user-thread))
+
+	  ;; set-printing-parameters : settings ( -> TST) -> TST
+	  ;; is implicitly exposed to the stepper.  watch out!  --  john
+          (define/public (set-printing-parameters settings thunk)
+            (parameterize ([pc:booleans-as-true/false #t]
+                           [pc:abbreviate-cons-as-list (get-abbreviate-cons-as-list)]
+                           [pretty-print-show-inexactness #t]
+                           [pretty-print-exact-as-decimal #t]
+                           [pc:use-named/undefined-handler
+                            (lambda (x)
+                              (and (get-use-function-output-syntax?)
+                                   (procedure? x)
+                                   (object-name x)))]
+                           [pc:named/undefined-handler
+                            (lambda (x)
+                              (string->symbol
+                               (format "function:~a" (object-name x))))])
+              (thunk)))
+          
+          (define/override (render-value/format value settings port width)
+            (set-printing-parameters
+             settings
+             (lambda ()
+               (super render-value/format value settings port width))))
+          
+          (define/override (render-value value settings port)
+            (set-printing-parameters
+             settings
+             (lambda ()
+               (super render-value value settings port))))
+          
+          (super-instantiate ())))
+      
+      ;; sharing/not-config-panel :  boolean parent -> (case-> (-> settings) (settings -> void))
+      ;; constructs the config-panel for a language without a sharing option.
+      (define (sharing/not-config-panel allow-sharing-config? _parent)
+        (let* ([parent (make-object vertical-panel% _parent)]
+               
+               [input-panel (instantiate group-box-panel% ()
+                              (parent parent)
+                              (label (string-constant input-syntax))
+                              (alignment '(left center)))]
+               
+               [output-panel (instantiate group-box-panel% ()
+                               (parent parent)
+                               (label (string-constant output-syntax))
+                               (alignment '(left center)))]
+               
+               [case-sensitive (make-object check-box%
+                                 (string-constant case-sensitive-label)
+                                 input-panel
+                                 void)]
+               [output-style (make-object radio-box%
+                               (string-constant output-style-label)
+                               (list (string-constant constructor-printing-style)
+                                     (string-constant quasiquote-printing-style)
+                                     (string-constant write-printing-style))
+                               output-panel
+                               void)]
+               [fraction-style
+                (make-object radio-box% (string-constant fraction-style)
+                  (list (string-constant use-mixed-fractions)
+                        (string-constant use-repeating-decimals))
+                  output-panel
+                  void)]
+               [show-sharing #f]
+               [insert-newlines (make-object check-box%
+                                  (string-constant use-pretty-printer-label)
+                                  output-panel
+                                  void)]
+               [tracing (new check-box%
+                             (parent output-panel)
+                             (label sc-tracing)
+                             (callback void))])
+          
+          (when allow-sharing-config?
+            (set! show-sharing
+                  (instantiate check-box% ()
+                    (parent output-panel)
+                    (label (string-constant sharing-printing-label))
+                    (callback void))))
+          
+          ;; set the characteristics of the GUI
+          (send _parent set-alignment 'center 'center)
+          (send parent stretchable-height #f)
+          (send parent stretchable-width #f)
+          (send parent set-alignment 'center 'center)
+          
+          (case-lambda
+            [()
+             (make-htdp-lang-settings
+              (send case-sensitive get-value)
+              (case (send output-style get-selection)
+                [(0) 'constructor]
+                [(1) 'quasiquote]
+                [(2) 'write])
+              (case (send fraction-style get-selection)
+                [(0) 'mixed-fraction]
+                [(1) 'repeating-decimal])
+              (and allow-sharing-config? (send show-sharing get-value))
+              (send insert-newlines get-value)
+              'none
+              (send tracing get-value))]
+            [(settings)
+             (send case-sensitive set-value (drscheme:language:simple-settings-case-sensitive settings))
+             (send output-style set-selection
+                   (case (drscheme:language:simple-settings-printing-style settings)
+                     [(constructor) 0]
+                     [(quasiquote) 1]
+                     [(write) 2]
+                     [(print) 2]))
+             (send fraction-style set-selection
+                   (case (drscheme:language:simple-settings-fraction-style settings)
+                     [(mixed-fraction) 0]
+                     [(repeating-decimal) 1]))
+             (when allow-sharing-config?
+               (send show-sharing set-value (drscheme:language:simple-settings-show-sharing settings)))
+             (send insert-newlines set-value 
+                   (drscheme:language:simple-settings-insert-newlines settings))
+             (send tracing set-value (htdp-lang-settings-tracing? settings))])))
+      
+      (define simple-htdp-language%
+        (class* drscheme:language:simple-module-based-language% (htdp-language<%>)
+          (init-field sharing-printing
+                      abbreviate-cons-as-list
+                      allow-sharing?
+                      manual
+                      (use-function-output-syntax? #f)
+                      (accept-quasiquote? #t)
+                      (read-accept-dot #f)
+                      (style-delta #f))
+          (define/public (get-sharing-printing) sharing-printing)
+          (define/public (get-abbreviate-cons-as-list) abbreviate-cons-as-list)
+          (define/public (get-allow-sharing?) allow-sharing?)
+          (define/public (get-manual) manual)
+          (define/public (get-use-function-output-syntax?) use-function-output-syntax?)
+          (define/public (get-accept-quasiquote?) accept-quasiquote?)
+          (define/public (get-read-accept-dot) read-accept-dot)
+          ;(define/override (get-one-line-summary) one-line-summary)
+          (define/public (get-htdp-style-delta) style-delta)
+          
+          (super-instantiate ()
+            (language-url "http://www.htdp.org/"))))
+      
+      (define (language-extension %)
+        (class %
+          (inherit get-manual)
+          (define/override (order-manuals x) 
+            (values (list (get-manual) #"teachpack" #"drscheme" #"help") #f))
+          
+          (inherit get-module get-transformer-module get-init-code
+                   use-namespace-require/copy?)
+          (define/override (create-executable setting parent program-filename teachpack-cache)
+            (let ([executable-filename
+		   (drscheme:language:put-executable
+		    parent program-filename
+		    #f 
+		    #t
+		    (string-constant save-a-mred-stand-alone-executable))])
+              (when executable-filename
+                (let ([wrapper-filename (make-temporary-file "drs-htdp-lang-executable~a.ss")]
+                      [teachpack-specs
+                       (map (lambda (x) `(file ,x))
+                            (drscheme:teachpack:teachpack-cache-filenames teachpack-cache))])
+                  (call-with-output-file wrapper-filename
+                    (lambda (outp)
+                      (write
+                       `(module #%htdp-lang-language mzscheme
+                          (require (prefix #%htdp: ,(get-module)))
+                          (provide ,@(map (lambda (x) `(rename ,(symbol-append '#%htdp: x) ,x))
+                                          (get-export-names (get-module))))
+                          (require ,@teachpack-specs)
+                          ,@(map (lambda (x) `(provide ,@(get-export-names x)))
+                                 teachpack-specs))
+                       outp)
+                      (newline outp)
+                      (newline outp)
+                      (fprintf outp "(module #%htdp-lang-executable #%htdp-lang-language\n")
+                      (call-with-input-file program-filename
+                        (lambda (inp)
+                          (let loop ()
+                            (let ([c (read-char inp)])
+                              (unless (eof-object? c)
+                                (display c outp)
+                                (loop))))))
+                      (fprintf outp "\n)\n\n")
+                      (write `(require #%htdp-lang-executable) outp)
+                      (newline outp))
+                    'truncate)
+                  (drscheme:language:create-module-based-stand-alone-executable
+                   wrapper-filename
+                   executable-filename
+                   (get-module)
+                   (get-transformer-module)
+                   (get-init-code setting teachpack-cache)
+                   #t
+                   (use-namespace-require/copy?))
+                  (delete-file wrapper-filename)))))
+          
+          (define/private (get-export-names sexp)
+            (let* ([sym-name ((current-module-name-resolver) sexp #f #f)]
+                   [no-ext-name (substring (symbol->string sym-name)
+                                           1
+                                           (string-length (symbol->string sym-name)))]
+                   [full-name
+                    (cond
+                      [(file-exists? (string-append no-ext-name ".ss"))
+                       (string-append no-ext-name ".ss")]
+                      [(file-exists? (string-append no-ext-name ".scm"))
+                       (string-append no-ext-name ".scm")]
+                      [(file-exists? no-ext-name)
+                       no-ext-name]
+                      [else (error 'htdp-lang.ss "could not find language filename ~s" no-ext-name)])]
+                   [base-dir (let-values ([(base _1 _2) (split-path full-name)]) base)]
+                   [stx
+                    (call-with-input-file full-name
+                      (lambda (port)
+                        (read-syntax full-name port)))]
+                   [code
+                    (parameterize ([current-load-relative-directory base-dir]
+                                   [current-directory base-dir])
+                      (expand stx))]
+                   [find-name
+                    (lambda (p)
+                      (cond
+                        [(symbol? p) p]
+                        [(and (pair? p) (pair? (cdr p)))
+                         (cadr p)]
+                        [else (car p)]))])
+              (append
+               (map find-name (syntax-property code 'module-variable-provides))
+               (map find-name (syntax-property code 'module-syntax-provides)))))
+
+          (define/private (symbol-append x y)
+            (string->symbol
+             (string-append
+              (symbol->string x)
+              (symbol->string y))))
+          
+          (inherit get-htdp-style-delta)
+          (define/override (get-style-delta)
+            (get-htdp-style-delta))
+          
+          (inherit get-reader set-printing-parameters)
+          
+          (define/override (front-end/complete-program port settings teachpacks)
+             (let ([state 'init]
+                   ;; state : 'init => 'require => 'done
+                   [reader (get-reader)])
+               
+               (lambda ()
+                 (case state
+                   [(init)
+                    (set! state 'require)
+                    (let ([body-exps 
+                           (let loop ()
+                             (let ([result (reader (object-name port) port)])
+                               (if (eof-object? result)
+                                   null
+                                   (cons result (loop)))))]
+                          [language-module (get-module)]
+                          [require-specs 
+                           (drscheme:teachpack:teachpack-cache-require-specs teachpacks)])
+                      (rewrite-module 
+                       (expand
+                        (datum->syntax-object
+                         #f
+                         `(,#'module #%htdp ,language-module 
+                            (,#'require ,@require-specs)
+                            ,@body-exps)))))]
+                   [(require) 
+                    (set! state 'done)
+                    (syntax
+                     (let ([done-already? #f])
+                       (dynamic-wind
+                        void
+                        (lambda () 
+                          ;(dynamic-require '#%htdp #f)
+                          (eval #'(require #%htdp)))  ;; work around a bug in dynamic-require
+                        (lambda () 
+                          (unless done-already?
+                            (set! done-already? #t)
+                            (current-namespace (module->namespace '#%htdp)))))))]
+                   [(done) eof]))))
+
+          (super-new)))
+
+      ;; rewrite-module : syntax -> syntax
+      ;; rewrites te module to provide all definitions and 
+      ;; print out all results.
+      (define (rewrite-module stx)
+        (syntax-case stx (module #%plain-module-begin)
+          [(module name lang (#%plain-module-begin bodies ...))
+           (with-syntax ([(rewritten-bodies ...) 
+                          (rewrite-bodies (syntax->list (syntax (bodies ...))))])
+             (syntax (module name lang
+                       (#%plain-module-begin 
+                        rewritten-bodies ...))))]
+          [else
+           (raise-syntax-error 'htdp-languages "internal error .1")]))
+      
+      ;; rewrite-bodies : (listof syntax) -> syntax
+      (define (rewrite-bodies bodies)
+        (let loop ([bodies bodies])
+          (cond
+            [(null? bodies) null]
+            [else
+             (let ([body (car bodies)])
+               (syntax-case body (require define-values define-syntaxes require-for-syntax provide)
+                 [(define-values (new-vars ...) e)
+                  (cons body (loop (cdr bodies)))]
+                 [(define-syntaxes (new-vars ...) e)
+                  (cons body (loop (cdr bodies)))]
+                 [(require specs ...)
+                  (cons body (loop (cdr bodies)))]
+                 [(require-for-syntax specs ...)
+                  (cons body (loop (cdr bodies)))]
+                 [(provide specs ...)
+                  (loop (cdr bodies))]
+                 [else 
+                  (let ([new-exp
+                         (with-syntax ([body body]
+                                       [print-results
+                                        (lambda results
+                                          (let ([rep (drscheme:rep:current-rep)])
+                                            (when rep
+                                              (send rep display-results results))))])
+                           (syntax 
+                            (call-with-values
+                             (lambda () body)
+                             print-results)))])
+                    (cons new-exp (loop (cdr bodies))))]))])))
+      
+      ;; filter/hide-ids : syntax[list] -> listof syntax
+      (define (filter/hide-ids ids)
+        ;; When a `define-values' or `define-syntax' declaration
+        ;; is macro-generated, if the defined name also originates
+        ;; from a macro, then the name is hidden to anything
+        ;; that wasn't generated by the same macro invocation. This
+        ;; hiding relies on renaming at the symbol level, and it's
+        ;; exposed by the fact that `syntax-e' of the identifier 
+        ;; returns a different name than `identifier-binding'.
+        (filter
+         (lambda (id)
+           (let ([ib (identifier-binding id)])
+             ;; ib should always be a 4-elem list, but
+             ;; check, just in case:
+             (or (not (pair? ib)) 
+                 (eq? (syntax-e id)
+                      (cadr ib)))))
+         (syntax->list ids)))
+                 
+      
+      ;                                                                                              
+      ;                                                                                              
+      ;                                                                                              
+      ;   ;                                                             ;                     ;      
+      ;   ;                                                             ;                     ;      
+      ;   ;                                                             ;                     ;      
+      ;   ; ;;    ;;;    ; ;;     ;; ;   ; ;;  ;;    ;;;    ; ;;        ; ;;    ;;;     ;;;   ;   ;  
+      ;   ;;  ;  ;   ;   ;;  ;   ;  ;;   ;;  ;;  ;  ;   ;   ;;  ;       ;;  ;  ;   ;   ;   ;  ;  ;   
+      ;   ;   ;      ;   ;   ;  ;    ;   ;   ;   ;      ;   ;   ;       ;   ;      ;  ;       ; ;    
+      ;   ;   ;   ;;;;   ;   ;  ;    ;   ;   ;   ;   ;;;;   ;   ;       ;   ;   ;;;;  ;       ;;;    
+      ;   ;   ;  ;   ;   ;   ;  ;    ;   ;   ;   ;  ;   ;   ;   ;       ;   ;  ;   ;  ;       ;  ;   
+      ;   ;   ;  ;   ;   ;   ;   ;  ;;   ;   ;   ;  ;   ;   ;   ;       ;   ;  ;   ;   ;   ;  ;   ;  
+      ;   ;   ;   ;;;;;  ;   ;    ;; ;   ;   ;   ;   ;;;;;  ;   ;       ;   ;   ;;;;;   ;;;   ;    ; 
+      ;                              ;                                                               
+      ;                         ;    ;                                                               
+      ;                          ;;;;                                                                
+      
+
+      ;; this inspector should be powerful enough to see
+      ;; any structure defined in the user's namespace
+      (define drscheme-inspector (current-inspector))
+      
+      (eval `(module drscheme-secrets mzscheme
+               (provide drscheme-inspector)
+               (define drscheme-inspector ,drscheme-inspector)))
+      (namespace-require 'drscheme-secrets)
+      
+      
+      
+      ;                                                               
+      ;                                                               
+      ;                                                               
+      ;                                                               
+      ;                                                               
+      ;                                 ;                             
+      ;    ;;;   ; ;  ; ;   ;;;    ; ; ;;;;  ; ;  ;;;     ;;;    ;;;  
+      ;   ;   ;  ;;   ;;   ;   ;   ;;   ;    ;;  ;   ;   ;   ;  ;   ; 
+      ;  ;    ;  ;    ;   ;     ;  ;    ;    ;       ;  ;      ;    ; 
+      ;  ;;;;;;  ;    ;   ;     ;  ;    ;    ;    ;;;;  ;      ;;;;;; 
+      ;  ;       ;    ;   ;     ;  ;    ;    ;   ;   ;  ;      ;      
+      ;   ;      ;    ;    ;   ;   ;    ;    ;   ;   ;   ;   ;  ;     
+      ;    ;;;;  ;    ;     ;;;    ;     ;;  ;    ;;;;;   ;;;    ;;;; 
+      ;                                                               
+      ;                                                               
+      ;                                                               
+      
+      
+      
+      
+      ;; cm-key : symbol
+      ;; the key used to put information on the continuation
+      (define cm-key (gensym 'teaching-languages-continuation-mark-key))
+      
+      (define mf-note
+        (let ([bitmap
+               (make-object bitmap%
+                 (build-path (collection-path "icons") "mf.gif"))])
+          (and (send bitmap ok?)
+               (make-object image-snip% bitmap))))
+      
+      ;; teaching-languages-error-display-handler : 
+      ;;    (string (union TST exn) -> void) -> string exn -> void
+      ;; adds in the bug icon, if there are contexts to display
+      (define (teaching-languages-error-display-handler msg exn)
+          
+          (if (exn? exn)
+              (display (exn-message exn) (current-error-port))
+              (fprintf (current-error-port) "uncaught exception: ~e" exn))
+          (fprintf (current-error-port) "\n")
+          
+          ;; need to flush here so that error annotations inserted in next line
+          ;; don't get erased if this output were to happen after the insertion
+          (flush-output (current-error-port))
+          
+          (let ([rep (drscheme:rep:current-rep)])
+            (when (and (is-a? rep drscheme:rep:text<%>)
+                       (eq? (send rep get-err-port) (current-error-port)))
+              (let ([to-highlight 
+                     (cond
+                       [(exn:srclocs? exn) 
+                        ((exn:srclocs-accessor exn) exn)]
+                       [(exn? exn) 
+                        (let ([cms (continuation-mark-set->list (exn-continuation-marks exn) cm-key)])
+                          (if cms
+                              (let loop ([cms cms])
+                                (cond
+                                  [(null? cms) '()]
+                                  [else (let* ([cms (car cms)]
+                                               [source (car cms)]
+                                               [pos (cadr cms)]
+                                               [span (cddr cms)])
+                                          (if (is-a? source text%)
+                                              (list (make-srcloc source #f #f pos span))
+                                              (loop (cdr cms))))]))
+                              '()))]
+                       [else '()])])
+                
+                (parameterize ([current-eventspace init-eventspace])
+                  (queue-callback
+                   (lambda ()
+                     ;; need to make sure that the user's eventspace is still the same
+                     ;; and still running here?
+                     (send rep highlight-errors to-highlight #f))))))))
+      
+      ;; with-mark : syntax syntax -> syntax
+      ;; a member of stacktrace-imports^
+      ;; guarantees that the continuation marks associated with cm-key are
+      ;; members of the debug-source type
+      (define (with-mark source-stx expr)
+        (let ([source (syntax-source source-stx)]
+              [start-position (syntax-position source-stx)]
+              [span (syntax-span source-stx)])
+          (if (and (is-a? source text:basic<%>)
+                   (number? start-position)
+                   (number? span))
+              (with-syntax ([expr expr]
+                            [mark (list* source start-position span)]
+                            [cm-key cm-key])
+                #`(with-continuation-mark 'cm-key
+                    'mark
+                    expr))
+              expr)))
+      
+      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;
+      ;;  profiling infrastructure. Not used.
+      ;;
+      
+      (define profile-key (gensym))
+      (define (profiling-enabled) #f)
+      (define (initialize-profile-point . x) (void))
+      (define (register-profile-start . x) #f)
+      (define (register-profile-done . x) (void))
+      
+      
+      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;
+      ;;  test coverage
+      ;;
+      
+      (define test-coverage-enabled (make-parameter #t))
+      (define current-test-coverage-info (make-thread-cell #f))
+      
+      (define (initialize-test-coverage-point key expr)
+        (unless (thread-cell-ref current-test-coverage-info)
+          (let ([ht (make-hash-table)])
+            (thread-cell-set! current-test-coverage-info ht)
+            (let ([rep (drscheme:rep:current-rep)])
+              (when rep
+                (send rep set-test-coverage-info
+                      ht
+                      (let ([s (make-object style-delta%)])
+                        (send s set-delta-foreground "black")
+                        s)
+                      (let ([s (make-object style-delta%)])
+                        (send s set-delta-foreground "firebrick")
+                        s)
+                      #f)))))
+        (hash-table-put! (thread-cell-ref current-test-coverage-info)
+                         key
+                         (list #f expr)))
+      
+      (define (test-covered key)
+        (let ([v (hash-table-get (thread-cell-ref current-test-coverage-info) key)])
+          (set-car! v #t)))
+      
+      (define-values/invoke-unit/sig et:stacktrace^ et:stacktrace@ et et:stacktrace-imports^)
+
+      (define calltrace-key #`(quote #,(gensym 'drscheme-calltrace-key)))
+      
+      (define (print-call-trace inferred-name original? src args improper? depth)
+        (when inferred-name
+          (let ([name (cond
+                        [(identifier? inferred-name) (syntax-e inferred-name)]
+                        [else (object-name inferred-name)])]
+                [rep (drscheme:rep:current-rep)])
+            (when (and name rep)
+              (let ([canvas (send rep get-canvas)])
+                (when canvas
+                  (let* ([frame (send canvas get-top-level-window)]
+                         [tab (send frame get-current-tab)])
+                    (when (is-a? tab tab-tracing<%>)
+                      (let ([sp (open-output-string)])
+                        (let loop ([i depth])
+                          (unless (zero? i)
+                            (display " " sp)
+                            (loop (- i 1))))
+                        (fprintf sp "(")
+                        (fprintf sp "~a" name)
+                        (let loop ([args args])
+                          (cond
+                            [(null? args) (void)]
+                            [(and (null? (cdr args)) improper?)
+                             (fprintf sp " . ")
+                             (fprintf sp "~v" (car args))]
+                            [else
+                             (let ([arg (car args)])
+                               (fprintf sp " ")
+                               (fprintf sp "~v" arg))
+                             (loop (cdr args))]))
+                        (fprintf sp ")")
+                        (parameterize ([current-eventspace drs-eventspace])
+                          (queue-callback
+                           (lambda ()
+                             (send tab tracing:add-line (get-output-string sp))))))))))))))
+
+      (define-values/invoke-unit/sig tr:stacktrace^ tr:stacktrace@ tr tr:stacktrace-imports^)
+      
+      ;; add-annotation : boolean (sexp -> value) -> sexp -> value
+      ;; adds debugging and test coverage information to `sexp' and calls `oe'
+      (define (add-annotation tracing? oe)
+        (let ([teaching-language-eval-handler
+               (lambda (exp)
+                 (let* ([is-compiled? (compiled-expression? (if (syntax? exp) (syntax-e exp) exp))]
+                        [annotated
+                         (if is-compiled?
+                             exp
+                             (let* ([et-annotated (et:annotate-top (expand exp) #f)]
+                                    [tr-annotated
+                                     (if tracing?
+                                         (tr:annotate (expand et-annotated))
+                                         et-annotated)])
+                               tr-annotated))])
+                   (oe annotated)))])
+          teaching-language-eval-handler))
+      
+      (define tab-tracing-mixin
+        (mixin (drscheme:unit:tab<%> drscheme:rep:context<%>) (tab-tracing<%>)
+          (inherit get-frame)
+          
+          (define tracing-visible? #f)
+          (define/public (set-tracing-visible? v?) (set! tracing-visible? v?))
+          (define/public (get-tracing-visible?) tracing-visible?)
+          
+          (define/augment (clear-annotations)
+            (tracing:reset)
+            (inner (void) clear-annotations))
+          
+          (define any-results? #f)
+          (define/public (get-any-results?) any-results?)
+          (define/public (tracing:reset)
+            (set! any-results? #f)
+            (send show-tracing-text lock #f)
+            (send show-tracing-text erase)
+            (send show-tracing-text lock #t))
+          
+          (define show-tracing-text (new text:hide-caret/selection%))
+          (define/public (get-tracing-text) show-tracing-text)
+          (send show-tracing-text lock #t)
+          
+          (define/public (tracing:add-line s)
+            (let ([old-any? any-results?])
+              (set! any-results? #t)
+              (unless old-any?
+                (send (get-frame) show-tracing))
+              (send show-tracing-text begin-edit-sequence)
+              (send show-tracing-text lock #f)
+              (let ([insert
+                     (lambda (s)
+                       (send show-tracing-text insert s (send show-tracing-text last-position) 'same #f))])
+                (cond
+                  [(<= (string-length s) ellipses-cutoff)
+                   (insert s)
+                   (insert "\n")]
+                  [else
+                   (insert (substring s 0 ellipses-cutoff))
+                   (insert " ")
+                   (let ([ell-start (send show-tracing-text last-position)])
+                     (insert "...")
+                     (let ([ell-end (send show-tracing-text last-position)])
+                       (let ([para (send show-tracing-text last-paragraph)])
+                         (insert "\n")
+                         (send show-tracing-text change-style clickback-delta ell-start ell-end)
+                         (send show-tracing-text set-clickback ell-start ell-end 
+                               (lambda (t x y)
+                                 (send show-tracing-text begin-edit-sequence)
+                                 (send show-tracing-text lock #f)
+                                 (let ([line-start (send show-tracing-text paragraph-start-position para)]
+                                       [line-end (send show-tracing-text paragraph-end-position para)])
+                                   (send show-tracing-text delete line-start line-end #f)
+                                   (send show-tracing-text insert s line-start 'same #f))
+                                 (send show-tracing-text lock #t)
+                                 (send show-tracing-text end-edit-sequence))))))]))
+              (send show-tracing-text lock #t)
+              (send show-tracing-text end-edit-sequence)))
+          
+          (super-new)))
+          
+      
+      (define frame-tracing-mixin 
+        (mixin (drscheme:frame:<%> drscheme:unit:frame<%>) ()
+          (inherit get-current-tab)
+          (define show-tracing-menu-item #f)
+          (define tracing-visible? #f)
+          
+          (define/augment (on-tab-change old new)
+            (inner (void) on-tab-change old new)
+            (send show-tracing-canvas set-editor (send new get-tracing-text))
+            (cond
+              [(eq? tracing-visible? (send new get-tracing-visible?))
+               (void)]
+              [(send new tracing-visible?)
+               (show-tracing)]
+              [else
+               (hide-tracing)]))
+          
+          (define/override (add-show-menu-items show-menu)
+            (super add-show-menu-items show-menu)
+            (set! show-tracing-menu-item
+                  (new menu-item%
+                       (parent show-menu)
+                       (label sc-show-tracing-window)
+                       (callback (lambda (x y) (toggle-tracing))))))
+          
+          (define/public (show-tracing)
+            (set! tracing-visible? #t)
+            (send show-tracing-menu-item set-label sc-hide-tracing-window)
+            (send dragable-parent change-children
+                  (lambda (l)
+                    (let ([without (remq show-tracing-canvas l)])
+                      (append without (list show-tracing-canvas)))))
+            (send dragable-parent set-percentages '(3/4 1/4)))
+          
+          (define/private (hide-tracing)
+            (cond
+              [(not (send (get-current-tab) get-any-results?))
+               (message-box (string-constant drscheme)
+                            sc-tracing-nothing-to-show
+                            this
+                            '(ok stop))]
+              [else
+               (set! tracing-visible? #f)
+               (send show-tracing-menu-item set-label sc-show-tracing-window)
+               (send dragable-parent change-children
+                     (lambda (l)
+                       (remq show-tracing-canvas l)))]))
+          
+          (define/private (toggle-tracing)
+            (if tracing-visible?
+                (hide-tracing)
+                (show-tracing)))
+          
+          (define dragable-parent #f)
+          (define show-tracing-parent-panel #f)
+          (define show-tracing-canvas #f)
+          
+          (define/override (make-root-area-container cls parent)
+            (set! dragable-parent (super make-root-area-container panel:horizontal-dragable% parent))
+            (let ([root (make-object cls dragable-parent)])
+              (set! show-tracing-canvas (new editor-canvas% 
+                                             (parent dragable-parent)
+                                             (editor (send (get-current-tab) get-tracing-text))))
+              (send dragable-parent change-children (lambda (l) (remq show-tracing-canvas l)))
+              root))
+          
+          (super-new)))
+      
+      (define clickback-delta (make-object style-delta%))
+      (send clickback-delta set-delta-foreground "BLUE")
+      (send clickback-delta set-delta 'change-underline #t)
+
+      
+;                                                                                                                
+;                                                                                                                
+;                                                                                                                
+;                            ;                   ;   ;                                        ;                  
+;                                                ;   ;                                        ;                  
+;                   ;            ;               ;   ;       ;                           ;    ;                  
+;   ; ;;    ;   ;  ;;;;      ;  ;;;;      ;;;    ;   ;      ;;;;   ;;;     ;; ;    ;;;  ;;;;  ; ;;     ;;;   ; ; 
+;   ;;  ;   ;   ;   ;        ;   ;       ;   ;   ;   ;       ;    ;   ;   ;  ;;   ;   ;  ;    ;;  ;   ;   ;  ;;  
+;   ;    ;  ;   ;   ;        ;   ;           ;   ;   ;       ;   ;     ; ;    ;  ;    ;  ;    ;   ;  ;    ;  ;   
+;   ;    ;  ;   ;   ;        ;   ;        ;;;;   ;   ;       ;   ;     ; ;    ;  ;;;;;;  ;    ;   ;  ;;;;;;  ;   
+;   ;    ;  ;   ;   ;        ;   ;       ;   ;   ;   ;       ;   ;     ; ;    ;  ;       ;    ;   ;  ;       ;   
+;   ;;  ;   ;  ;;   ;        ;   ;       ;   ;   ;   ;       ;    ;   ;   ;  ;;   ;      ;    ;   ;   ;      ;   
+;   ; ;;     ;; ;    ;;      ;    ;;      ;;;;;  ;   ;        ;;   ;;;     ;; ;    ;;;;   ;;  ;   ;    ;;;;  ;   
+;   ;                                                                         ;                                  
+;   ;                                                                    ;    ;                                  
+;   ;                                                                     ;;;;                                   
+      
+      
+      ;; add-htdp-language : (instanceof htdp-language<%>) -> void
+      (define (add-htdp-language o)
+        (drscheme:language-configuration:add-language o))
+      
+      (define (phase1) (void))
+
+      ;; phase2 : -> void
+      (define (phase2)
+        (define htdp-language%
+          ((drscheme:language:get-default-mixin)
+           (language-extension
+            (drscheme:language:module-based-language->language-mixin
+             (module-based-language-extension
+              (drscheme:language:simple-module-based-language->module-based-language-mixin
+               simple-htdp-language%))))))
+        
+        (add-htdp-language
+         (instantiate htdp-language% ()
+           (one-line-summary (string-constant advanced-one-line-summary))
+           (module '(lib "htdp-advanced.ss" "lang"))
+           (manual #"advanced")
+           (language-position
+            (list (string-constant teaching-languages)
+                  (string-constant how-to-design-programs)
+                  (string-constant advanced-student)))
+           (language-numbers '(-500 -500 5))
+           (sharing-printing #t)
+           (abbreviate-cons-as-list #t)
+           (allow-sharing? #t)))
+        
+        (add-htdp-language
+         (instantiate htdp-language% ()
+           (one-line-summary (string-constant intermediate/lambda-one-line-summary))
+           (module '(lib "htdp-intermediate-lambda.ss" "lang"))
+           (manual #"intermediate-lambda")
+           (language-position
+            (list (string-constant teaching-languages)
+                  (string-constant how-to-design-programs)
+                  (string-constant intermediate-student/lambda)))
+           (style-delta (let ([match (regexp-match-positions
+                                      "lambda"
+                                      (string-constant intermediate-student/lambda))])
+                          (if match
+                              (let ([pos (car match)])
+                                (list (list (make-object style-delta% 'change-family 'modern)
+                                            (car pos)
+                                            (cdr pos))))
+                              #f)))
+           (language-numbers '(-500 -500 4))
+           (sharing-printing #f)
+           (abbreviate-cons-as-list #t)
+           (allow-sharing? #f)))
+        
+        (add-htdp-language
+         (instantiate htdp-language% ()
+           (one-line-summary (string-constant intermediate-one-line-summary))
+           (module '(lib "htdp-intermediate.ss" "lang"))
+           (manual #"intermediate")
+           (language-position
+            (list (string-constant teaching-languages)
+                  (string-constant how-to-design-programs)
+                  (string-constant intermediate-student)))
+           (language-numbers '(-500 -500 3))
+           (sharing-printing #f)
+           (abbreviate-cons-as-list #t)
+           (allow-sharing? #f)
+           (use-function-output-syntax? #t)))
+        
+        (add-htdp-language
+         (instantiate htdp-language% ()
+           (one-line-summary (string-constant beginning/abbrev-one-line-summary))
+           (module '(lib "htdp-beginner-abbr.ss" "lang"))
+           (manual #"beginning-abbr")
+           (language-position
+            (list (string-constant teaching-languages)
+                  (string-constant how-to-design-programs)
+                  (string-constant beginning-student/abbrev)))
+           (language-numbers '(-500 -500 2))
+           (sharing-printing #f)
+           (abbreviate-cons-as-list #t)
+           (allow-sharing? #f)))
+        
+        (add-htdp-language
+         (instantiate htdp-language% ()
+           (one-line-summary (string-constant beginning-one-line-summary))
+           (module '(lib "htdp-beginner.ss" "lang"))
+           (manual #"beginning")
+           (language-position
+            (list (string-constant teaching-languages)
+                  (string-constant how-to-design-programs)
+                  (string-constant beginning-student)))
+           (language-numbers '(-500 -500 1))
+           (sharing-printing #f)
+           (abbreviate-cons-as-list #f)
+           (allow-sharing? #f)
+           (accept-quasiquote? #f)))
+        
+        (drscheme:get/extend:extend-unit-frame frame-tracing-mixin)
+        (drscheme:get/extend:extend-tab tab-tracing-mixin)))))
diff --git a/collects/lang/imageeq.ss b/collects/lang/imageeq.ss
new file mode 100644
index 0000000000..612363f0f8
--- /dev/null
+++ b/collects/lang/imageeq.ss
@@ -0,0 +1,46 @@
+(module imageeq mzscheme
+
+  (define op (current-output-port))
+  
+  ;; Flag to indicate whether we've tried to load
+  ;;  the MrEd-using image functions
+  (define tried? #f)
+
+  ;; This macro is used once to export all functions
+  ;;  from "private/image.ss":
+  (define-syntax (re-export stx)
+    (syntax-case stx ()
+      [(_ (id . impl) ...) 
+       (with-syntax ([(got-id ...) (generate-temporaries #'(id ...))])
+         #'(begin 
+             (provide id ...)
+             (re-export-one get-procs! id got-id . impl) ...
+             (define got-id #f) ...
+             (define (get-procs!)
+               (unless tried?
+                 (set! tried? #t)
+                 (with-handlers ([exn:fail? (lambda (x) #f)])
+                   (set! got-id (dynamic-require '(lib "imageeq.ss" "lang" "private") 'id))
+                   ...)))))]))
+
+  ;; This macro is used once for each individual function,
+  ;;  and the use is generated by `re-export':
+  (define-syntax (re-export-one stx)
+    (syntax-case stx ()
+      [(_ get-procs! id got-id args alt ...)
+       (with-syntax ([alt (if (null? (syntax-e #'(alt ...)))
+                              #'(raise-type-error 'id "image" 0 . args)
+                              #'(alt ... . args))])
+                              
+         #'(define (id . args)
+             (get-procs!)
+             (if got-id
+                 (got-id . args)
+                 alt)))]))
+
+  ;; Each re-export is the name, formals for the argument,
+  ;;  and if the first argument isn't required to be an image,
+  ;;  a function to apply when the real version is unavailable
+  ;;  (i.e., because there's no MrEd)
+  (re-export (image? (x) (lambda (x) #f))
+             (image=? (a b))))
diff --git a/collects/lang/info.ss b/collects/lang/info.ss
new file mode 100644
index 0000000000..6cbf8c7488
--- /dev/null
+++ b/collects/lang/info.ss
@@ -0,0 +1,7 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "HtDP Languages")
+  (define doc.txt "doc.txt")
+  (define tools (list "htdp-langs.ss"))
+  (define tool-icons (list '("htdp-icon.gif" "icons")))
+  (define tool-names (list "How to Design Programs"))
+  (define tool-urls (list "http://www.htdp.org/")))
\ No newline at end of file
diff --git a/collects/lang/plt-mred.ss b/collects/lang/plt-mred.ss
new file mode 100644
index 0000000000..cb53850dcd
--- /dev/null
+++ b/collects/lang/plt-mred.ss
@@ -0,0 +1,12 @@
+(module plt-mred mzscheme
+  (require (lib "mred.ss" "mred")
+           (lib "class.ss"))
+  
+  (define argv #())
+  (define program "mred")
+  
+  (provide argv 
+           program
+           (all-from mzscheme)
+           (all-from (lib "class.ss"))
+	   (all-from (lib "mred.ss" "mred"))))
diff --git a/collects/lang/plt-mzscheme.ss b/collects/lang/plt-mzscheme.ss
new file mode 100644
index 0000000000..afcd69f17a
--- /dev/null
+++ b/collects/lang/plt-mzscheme.ss
@@ -0,0 +1,6 @@
+(module plt-mzscheme mzscheme
+  (define argv #())
+  (define program "mzscheme")
+  (provide argv 
+           program
+           (all-from mzscheme)))
diff --git a/collects/lang/plt-pretty-big-text.ss b/collects/lang/plt-pretty-big-text.ss
new file mode 100644
index 0000000000..f35f909ad1
--- /dev/null
+++ b/collects/lang/plt-pretty-big-text.ss
@@ -0,0 +1,34 @@
+
+(module plt-pretty-big-text mzscheme
+  (require (lib "etc.ss")
+	   (lib "file.ss")
+	   (lib "list.ss")
+	   (lib "class.ss")
+	   (lib "unit.ss")
+	   (lib "unitsig.ss")
+	   (lib "include.ss")
+	   (lib "defmacro.ss")
+	   (lib "pretty.ss")
+	   (lib "string.ss")
+	   (lib "thread.ss")
+	   (lib "math.ss")
+	   (lib "match.ss")
+	   (lib "shared.ss")
+	   "posn.ss")
+
+  (provide (all-from mzscheme)
+	   (all-from (lib "etc.ss"))
+	   (all-from (lib "file.ss"))
+	   (all-from (lib "list.ss"))
+	   (all-from (lib "class.ss"))
+	   (all-from (lib "unit.ss"))
+	   (all-from (lib "unitsig.ss"))
+	   (all-from (lib "include.ss"))
+	   (all-from (lib "defmacro.ss"))
+	   (all-from (lib "pretty.ss"))
+	   (all-from (lib "string.ss"))
+	   (all-from (lib "thread.ss"))
+	   (all-from (lib "math.ss"))
+	   (all-from (lib "match.ss"))
+	   (all-from (lib "shared.ss"))
+	   (all-from "posn.ss")))
diff --git a/collects/lang/plt-pretty-big.ss b/collects/lang/plt-pretty-big.ss
new file mode 100644
index 0000000000..2add0e679c
--- /dev/null
+++ b/collects/lang/plt-pretty-big.ss
@@ -0,0 +1,9 @@
+
+(module plt-pretty-big "plt-pretty-big-text.ss"
+  (require (lib "mred.ss" "mred")
+           "private/imageeq.ss")
+
+  (provide (all-from "plt-pretty-big-text.ss")
+	   (all-from (lib "mred.ss" "mred"))
+           (all-from "private/imageeq.ss")))
+
diff --git a/collects/lang/posn.ss b/collects/lang/posn.ss
new file mode 100644
index 0000000000..333637c2fe
--- /dev/null
+++ b/collects/lang/posn.ss
@@ -0,0 +1,5 @@
+
+;; The posn struct for the teaching languages
+(module posn mzscheme
+  (define-struct posn (x y) (make-inspector)) ; transparent
+  (provide (struct posn (x y))))
diff --git a/collects/lang/prim.ss b/collects/lang/prim.ss
new file mode 100644
index 0000000000..5d32aa503a
--- /dev/null
+++ b/collects/lang/prim.ss
@@ -0,0 +1,149 @@
+
+;; Provides `define-primitive' and `define-higher-order-primitive'
+;; for use in teachpacks for Beginner, especially those that
+;; define a primitive operator that consumes a procedure.
+;; See doc.txt for more information.
+
+(module prim mzscheme
+  (require (lib "error.ss" "lang")
+	   (rename (lib "htdp-beginner.ss" "lang") beginner-app #%app))
+  (require-for-syntax "private/firstorder.ss")
+  
+  (provide define-primitive
+	   define-higher-order-primitive
+	   provide-primitive
+	   provide-higher-order-primitive
+	   provide-primitives)
+
+  (define-syntax (define-primitive stx)
+    (syntax-case stx ()
+      [(_ name implementation)
+       (with-syntax ([impl #'(let ([name (lambda argv
+                                           (apply implementation argv))])
+                               name)])
+	 #'(define-syntax (name stx)
+             (with-syntax ([tagged-impl (syntax-property
+                                         (syntax-property (quote-syntax impl) 'stepper-skip-completely #t)
+                                         'stepper-prim-name
+                                         (quote-syntax name))])
+	     (syntax-case stx ()
+	       [(__ . ___)
+		;; HACK: we disable all checks if #%app is not beginner-app
+		(not (module-identifier=? #'beginner-app (datum->syntax-object stx '#%app)))
+                (syntax/loc stx (tagged-impl . ___))]
+	       [__
+		;; HACK: see above
+		(not (module-identifier=? #'beginner-app (datum->syntax-object stx '#%app)))
+                (syntax/loc stx tagged-impl)]
+	       [(id . args)
+                (syntax/loc stx (#%app tagged-impl . args))]
+	       [_else
+		(raise-syntax-error
+		 #f
+		 (string-append
+		  "this primitive operator must be applied to arguments; "
+		  "expected an open parenthesis before the operator name")
+		 stx)]))))]))
+
+  (define-syntax (define-higher-order-primitive stx)
+    (define (is-proc-arg? arg)
+      (not (eq? '_ (syntax-e arg))))
+    (syntax-case stx ()
+      [(_ name implementation (arg ...))
+       (let ([args (syntax->list (syntax (arg ...)))])
+         (for-each (lambda (id)
+                     (unless (identifier? id)
+                       (raise-syntax-error #f "not an identifier" stx id)))
+                   (cons (syntax name)
+                         args))
+	 (let ([new-args (generate-temporaries args)])
+	   (with-syntax ([(new-arg ...) new-args]
+			 [(checks ...)
+			  (map (lambda (arg new-arg)
+				 (if (not (is-proc-arg? arg))
+				     #'(void)
+				     #`(unless (identifier? (#,#'syntax #,new-arg))
+					 (raise-syntax-error
+					  #f
+					  (format
+					   "primitive operator ~a expects a defined procedure name (usually `~a') in this position"
+					   'name
+					   '#,arg)
+					  s
+					  (#,#'syntax #,new-arg)))))
+			       args new-args)]
+			 [(wrapped-arg ...)
+			  (map (lambda (arg new-arg)
+				 (cond
+				  [(not (is-proc-arg? arg)) new-arg]
+				  [else #`(fo->ho #,new-arg)]))
+			       args new-args)]
+			 [num-arguments (length args)])
+	     (with-syntax ([impl #'(let ([name (lambda (new-arg ...)
+                                                 (implementation new-arg ...))])
+                                     name)])
+	       (syntax/loc stx
+		   (define-syntax (name s)
+		     (with-syntax ([tagged-impl (syntax-property
+                                                 (syntax-property (quote-syntax impl) 'stepper-skip-completely #t)
+                                                 'stepper-prim-name
+                                                 (quote-syntax name))])
+                         (syntax-case s ()
+		       [(__ . ___)
+			;; HACK: see above
+			(not (module-identifier=? #'beginner-app (datum->syntax-object s '#%app)))
+                        (syntax/loc s (tagged-impl . ___))]
+		       [__
+			;; HACK: see above
+			(not (module-identifier=? #'beginner-app (datum->syntax-object s '#%app)))
+                        (syntax/loc s tagged-impl)]
+		       [(__ new-arg ...)
+                        (begin
+			  checks ...
+			  ;; s is a well-formed use of the primitive;
+			  ;; generate the primitive implementation
+                          (syntax/loc s (tagged-impl wrapped-arg ...))
+                          )]
+		       [(__ . rest)
+			(raise-syntax-error
+			 #f
+			 (format
+			  "primitive operator requires ~a arguments"
+			  num-arguments)
+			 s)]
+		       [_else
+			(raise-syntax-error
+			 #f
+			 (string-append
+			  "this primitive operator must be applied to arguments; "
+			  "expected an open parenthesis before the operator name")
+			 s)]))))))))]))
+
+  (define-syntax (fo->ho stx)
+    (syntax-case stx ()
+      [(_ id) (first-order->higher-order #'id)]))
+
+  (define-syntax (provide-primitive stx)
+    (syntax-case stx ()
+      [(_ name)
+       (with-syntax ([ex-name ((make-syntax-introducer) #'name)])
+	 #'(begin
+	     (define-primitive ex-name name)
+	     (provide ex-name)))]))
+
+  (define-syntax (provide-primitives stx)
+    (syntax-case stx ()
+      [(_ name ...)
+       #'(begin
+	   (provide-primitive name)
+	   ...)]))
+
+  (define-syntax (provide-higher-order-primitive stx)
+    (syntax-case stx ()
+      [(_ name (arg ...))
+       (with-syntax ([ex-name ((make-syntax-introducer) #'name)])
+	 #'(begin
+	     (define-higher-order-primitive ex-name name (arg ...))
+	     (provide ex-name)))])))
+
+
diff --git a/collects/lang/private/beginner-funs.ss b/collects/lang/private/beginner-funs.ss
new file mode 100644
index 0000000000..644c4d4ccb
--- /dev/null
+++ b/collects/lang/private/beginner-funs.ss
@@ -0,0 +1,455 @@
+
+(module beginner-funs mzscheme
+  (require (lib "etc.ss")
+    (lib "list.ss")
+    (lib "math.ss")
+    (lib "docprovide.ss" "syntax"))
+
+  ;; Implements the procedures:
+  (require "teachprims.ss"
+	   "../posn.ss"
+	   "../imageeq.ss")
+
+  ;; Test-suite support (require is really an effect
+  ;;  to make sure that it's loaded)
+  (require (lib "test-case.ss" "test-suite" "private"))
+
+  ;; procedures with documentation:
+  (provide-and-document
+    procedures
+
+    ("Numbers: Integers, Rationals, Reals, Complex, Exacts, Inexacts"
+      (number? (any -> boolean)
+	"to determine whether some value is a number")
+      (= (num num num ... -> boolean)
+	 "to compare numbers for equality")
+      (< (real real real ... -> boolean)
+	 "to compare real numbers for less-than")
+      (> (real real real ... -> boolean)
+	 "to compare real numbers for greater-than")
+      (<= (real real real ... -> boolean)
+	  "to compare real numbers for less-than or equality")
+      (>= (real real ... -> boolean)
+	  "to compare real numbers for greater-than or equality")
+    
+      ((beginner-+ +) (num num num ... -> num)
+       "to compute the sum of the input numbers")
+      (- (num num ... -> num)
+	 "to subtract the second (and following) number(s) from the first; negate the number if there is only one argument")
+      ((beginner-* *) (num num num ... -> num)
+       "to compute the product of all of the input numbers")
+      ((beginner-/ /) (num num num ... -> num)
+       "to divide the first by the second (and all following) number(s)"
+       "None but the first number can be zero.")
+      (max (real real ... -> real)
+	"to determine the largest number")
+      (min (real real ... -> real)
+	"to determine the smallest number")       
+      (quotient (int int -> int)
+	"to compute the quotient of two integers")
+      (remainder (int int -> int)
+	"to compute the remainder of dividing the first by the second integer")
+      (modulo (int int -> int)
+	"to compute first number modulo second number")    
+      (sqr (num -> num)
+	"to compute the square of a number")
+      (sqrt (num -> num)
+	"to compute the square root of a number")    
+      (expt (num num -> num)
+	"to compute the power of the first to the second number")
+      (abs (real -> real)
+	"to compute the absolute value of a real number")
+      (sgn (real -> (union 1 |#i1.0| 0 |#i0.0| -1 |#i-1.0|))
+	"to compute the sign of a real number")
+    
+      ;; fancy numeric 
+      (exp (num -> num)
+	"to compute e raised to a number")
+      (log (num -> num)
+	"to compute the base-e logarithm of a number")
+    
+      ;; trigonometry
+      (sin (num -> num)
+	"to compute the sine of a number (radians)")
+      (cos (num -> num)
+	"to compute the cosine of a number (radians)")
+      (tan (num -> num)
+	"to compute the tangent of a number (radians)")
+      (asin (num -> num)
+	"to compute the arcsine (inverse of sin) of a number")
+      (acos (num -> num)
+	"to compute the arccosine (inverse of cos) of a number")
+      (atan (num -> num)
+	"to compute the arctan (inverse of tan) of a number")    
+    
+      (sinh (num -> num)
+	"to compute the hyperbolic sine of a number")
+      (cosh (num -> num)
+	"to compute the hyperbolic cosine of a number")
+    
+      (exact? (num -> bool)
+	"to determine whether some number is exact")
+    
+      (integer? (any -> bool)
+	"to determine whether some value is an integer (exact or inexact)")
+    
+      (zero? (number -> bool)
+	"to determine if some value is zero or not") 
+      (positive? (number -> bool)
+	"to determine if some value is strictly larger than zero")
+      (negative? (number -> bool)
+	"to determine if some value is strictly smaller than zero")      
+      (odd? (integer -> bool)
+	"to determine if some value is odd or not")
+      (even? (integer -> bool)
+	"to determine if some value is even or not")
+
+      (add1 (number -> number)
+	"to compute a number one larger than a given number")
+      (sub1 (number -> number)
+	"to compute a number one smaller than a given number")
+
+      (lcm (int int ... -> int)
+	"to compute the least common multiple of two integers")
+    
+      (gcd (int int ... -> int)
+	"to compute the greatest common divisior")
+    
+      (rational? (any -> bool)
+	"to determine whether some value is rational number")
+    
+      (numerator (rat -> int)
+	"to compute the numerator of a rational")
+    
+      (denominator (rat -> int)
+	"to compute the denominator of a rational")
+    
+      (inexact? (num -> bool)
+	"to determine whether some number is inexact")
+    
+      (real? (any -> bool)
+	"to determine whether some value is a real number")
+    
+      (floor (real -> int)
+	"to determine the closest integer below a real number")
+    
+      (ceiling (real -> int)
+	"to determine the closest integer above a real number")
+    
+      (round (real -> int)
+	"to round a real number to an integer (rounds to even to break ties)")
+    
+      (complex? (any -> bool)
+	"to determine whether some value is complex")
+    
+      (make-polar (real real -> num)
+	"to create a complex from a magnitude and angle")
+    
+      (real-part (num -> real)
+	"to extract the real part from a complex number")
+    
+      (imag-part (num -> real)
+	"to extract the imaginary part from a complex number")
+    
+      (magnitude (num -> real)
+	"to determine the magnitude of a complex number")
+    
+      (angle (num -> real)
+	"to extract the angle from a complex number")
+    
+      (conjugate (num -> num)
+	"to compute the conjugate of a complex number")
+    
+      (exact->inexact (num -> num)
+	"to convert an exact number to an inexact one")
+    
+      (inexact->exact (num -> num)
+	"to approximate an inexact number by an exact one")
+    
+					;    "Odds and ends"
+    
+      (number->string (num -> string)
+	"to convert a number to a string")
+    
+      (integer->char (int -> char)
+	"to lookup the character that corresponds to the given integer in the ASCII table (if any)")
+    
+      (random (int -> int)
+	"to generate a random natural number less than some given integer")
+    
+      (current-seconds (-> int)
+	"to compute the current time in seconds elapsed"
+	"(since a platform-specific starting date)")
+    
+      (e real
+	 "Euler's number")
+      (pi real
+	  "the ratio of a circle's circumference to its diameter"))
+   
+    ("Booleans" 
+      (boolean? (any -> boolean)
+	"to determine whether some value is a boolean")
+    
+      (boolean=? (boolean boolean -> boolean)
+	"to determine whether two booleans are equal")
+    
+      ((beginner-not not) (boolean -> boolean)
+	"to compute the negation of a boolean value"))
+   
+    ("Symbols"
+      (symbol? (any -> boolean)
+	"to determine whether some value is a symbol")
+    
+      (symbol=? (symbol symbol -> boolean)
+	"to determine whether two symbols are equal")
+
+      (symbol->string (symbol -> string)
+	"to convert a symbol to a string")      )
+
+    ("Lists"
+      (cons? (any -> boolean)
+	"to determine whether some value is a constructed list")
+      (pair? (any -> boolean)
+	"to determine whether some value is a constructed list")	
+      (empty? (any -> boolean)
+	"to determine whether some value is the empty list")
+      (null? (any -> boolean)
+	"to determine whether some value is the empty list")
+
+      ((beginner-cons cons) (X (listof X) -> (listof X))
+       "to construct a list")
+
+      (null empty
+	"the empty list")
+
+      (first ( (cons Y (listof X)) -> Y )
+	"to select the first item of a non-empty list")
+      (car ( (cons Y (listof X)) -> Y )
+	"to select the first item of a non-empty list")       
+      (rest ((cons Y (listof X)) -> (listof X))
+	"to select the rest of a non-empty list")
+      (cdr ((cons Y (listof X)) -> (listof X))
+	"to select the rest of a non-empty list")       
+    
+      (second ( (cons Z (cons Y (listof X))) -> Y )
+	"to select the second item of a non-empty list")
+      (cadr ( (cons Z (cons Y (listof X))) -> Y )
+	"to select the second item of a non-empty list")	  
+      (cdar ( (cons (cons Z (listof Y)) (listof X)) -> (listof Y) )
+	"to select the rest of a non-empty list in a list") 
+      (caar ( (cons (cons Z (listof Y)) (listof X)) -> Z )
+	"to select the first item of the first list in a list")
+      (cddr ( (cons Z (cons Y (listof X))) -> (listof X) )
+	"to select the rest of the rest of a list")
+      (third ( (cons W (cons Z (cons Y (listof X)))) -> Y )
+	"to select the third item of a non-empty list")
+      (caddr ( (cons W (cons Z (cons Y (listof X)))) -> Y )
+	"to select the third item of a non-empty list")	  
+      (caadr ( (cons (cons (cons W (listof Z)) (listof Y)) (listof X)) -> (listof Z) )
+	"to select the rest of the first list in the first list of a list")
+      (caaar ( (cons (cons (cons W (listof Z)) (listof Y)) (listof X)) -> W )
+	"to select the first item of the first list in the first list of a list")
+      (cdaar ( (cons (cons (cons W (listof Z)) (listof Y)) (listof X)) -> (listof Z) )
+	"to select the rest of the first list in the first list of a list")
+      (cdadr ( (cons W (cons (cons Z (listof Y)) (listof X))) -> (listof Y) )
+	"to select the rest of the first list in the rest of a list")
+      (cadar ( (cons (cons W (cons Z (listof Y))) (listof X)) -> Z )
+	"to select the second item of the first list of a list")
+      (cddar ( (cons (cons W (cons Z (listof Y))) (listof X)) -> (listof Y) )
+	"to select the rest of the rest of the first list of a list")
+      (cdddr ( (cons W (cons Z (cons Y (listof X)))) -> (listof X) )
+	"to select the rest of the rest of the rest of a list")
+      (fourth ( (listof Y)  -> Y ) ; domain: (cons V (cons W (cons Z (cons Y (listof X)))))
+	"to select the fourth item of a non-empty list")
+      (cadddr ( (listof Y)  -> Y ) ;  domain: (cons V (cons W (cons Z (cons Y (listof X)))))
+	"to select the fourth item of a non-empty list")
+      (fifth ( (listof Y) -> Y ) ; domain: (cons U (cons V (cons W (cons Z (cons Y (listof X))))))
+	"to select the fifth item of a non-empty list")
+      (sixth ( (listof Y) -> Y ) ;  domain: (cons T (cons U (cons V (cons W (cons Z (cons Y (listof X)))))))
+	"to select the sixth item of a non-empty list")
+      (seventh ( (listof Y) -> Y ) ;  domain: (cons S (cons T (cons U (cons V (cons W (cons Z (cons Y (listof X))))))))
+	"to select the seventh item of a non-empty list")
+      (eighth ( (listof Y) -> Y ) ;  domain: (cons R (cons S (cons T (cons U (cons V (cons W (cons Z (cons Y (listof X)))))))))
+	"to select the eighth item of a non-empty list")    
+    
+      (list-ref ((listof X) natural-number -> X )
+	"to extract the indexed item from the list")
+    
+      (list (any ... -> (listof any)) "to construct a list of its arguments")
+
+      (list (any ... (listof any) -> (listof any)) 
+	"to construct a list of its arguments, building on the last argument")
+
+      ((beginner-list* list*) (any ... (listof any) -> (listof any)) 
+       "to construct a list by adding multiple items to a list")
+
+      ((beginner-append append) ((listof any) ... -> (listof any))
+       "to create a single list from several, by juxtaposition of the items")
+      (length (list -> number)
+	"to compute the number of items on a list")
+      (memq (any list -> (union false list))
+	"to determine whether some value is on some list"
+	"(comparing values with eq?)")
+      (memv (any list -> (union false list))
+	"to determine whether some value is on the list"
+	"(comparing values with eqv?)")
+      ((beginner-member member) (any list -> (union false list))
+	"to determine whether some value is on the list"
+	"(comparing values with equal?)")
+      (reverse (list -> list)
+	"to create a reversed version of a list")
+      (assq (X (listof (cons X Y)) -> (union false (cons X Y)))
+	"to determine whether some item is the first item of a pair"
+	"in a list of pairs"))
+
+    ("Posns"
+      (make-posn (number number -> posn) "to construct a posn")
+      (posn? (anything -> boolean) "to determine if its input is a posn")
+      (posn-x (posn -> number) "to extract the x component of a posn")
+      (posn-y (posn -> number) "to extract the y component of a posn"))
+
+    ("Characters"
+      (char? (any -> boolean)
+	" ")
+      (char=? (char char ... -> boolean)
+	"to determine whether two characters are equal")
+      (char<? (char char ... -> boolean)
+	"to determine whether a character precedes another")
+      (char>? (char char ... -> boolean)
+	"to determine whether a character succeeds another")
+      (char<=? (char char ... -> boolean)
+	"to determine whether a character precedes another"
+	"(or is equal to it)")
+      (char>=? (char char ... -> boolean)
+	"to determine whether a character succeeds another"
+	"(or is equal to it)")
+    
+      (char-ci=? (char char ... -> boolean)
+	"to determine whether two characters are equal"
+	"in a case-insensitive manner")
+      (char-ci<? (char char ... -> boolean)
+	"to determine whether a character precedes another"
+	"in a case-insensitive manner")
+      (char-ci>? (char char ... -> boolean)
+	"to determine whether a character succeeds another"
+	"in a case-insensitive manner")
+      (char-ci<=? (char char ... -> boolean)
+	"to determine whether a character precedes another"
+	"(or is equal to it) in a case-insensitive manner")
+      (char-ci>=? (char char ... -> boolean)
+	"to determine whether a character succeeds another"
+	"(or is equal to it) in a case-insensitive manner")
+    
+      (char-numeric? (char -> boolean)
+	"to determine whether a character represents a digit")
+      (char-alphabetic? (char -> boolean)
+	"to determine whether a character represents"
+	" an alphabetic character")
+      (char-whitespace? (char -> boolean)
+	"to determine whether a character represents space")
+      (char-upper-case? (char -> boolean)
+	"to determine whether a character is an"
+	"upper-case character")
+      (char-lower-case? (char -> boolean)
+	"to determine whether a character is a"
+	"lower-case character")
+      (char-upcase (char -> char)
+	"to determine the equivalent upper-case character")
+      (char-downcase (char -> char)
+	"to determine the equivalent lower-case character")
+      (char->integer (char -> integer)
+	"to lookup the number that corresponds to the"
+	"given character in the ASCII table (if any)"))
+    ("Strings"
+      (string? (any -> boolean)
+	"to determine whether a value is a string")
+      (string-length (string -> nat)
+	"to determine the length of a string")
+      (make-string (nat char -> string)
+	"to produce a string of given length"
+	"from a single given character")
+      (string-ref (string nat -> char)
+	"to extract the i-the character from a string")
+    
+      (substring (string nat nat -> string)
+	"to extract the substring starting at a 0-based index"
+	" up to the second 0-based index (exclusive)")
+      (string-copy (string -> string)
+	"to copy a string")
+      (string-append (string ... -> string)
+	"to juxtapose the characters of several strings")
+    
+      (string=? (string string ... -> boolean)
+	"to compare two strings character-wise")
+      (string<? (string string ... -> boolean)
+	"to determine whether one string alphabetically"
+	"precedes another")
+      (string>? (string string ... -> boolean)
+	"to determine whether one string alphabetically"
+	"succeeds another")
+      (string<=? (string string ... -> boolean)
+	"to determine whether one string alphabetically"
+	"precedes another (or is equal to it)")
+      (string>=? (string string ... -> boolean)
+	"to determine whether one string alphabetically"
+	"succeeds another (or is equal to it)")
+    
+      (string-ci=? (string string ... -> boolean)
+	"to compare two strings character-wise"
+	"in a case-insensitive manner")
+      (string-ci<? (string string ... -> boolean)
+	"to determine whether one string alphabetically"
+	"precedes another in a case-insensitive manner")
+      (string-ci>? (string string ... -> boolean)
+	"to determine whether one string alphabetically"
+	"succeeds another in a case-insensitive manner")
+      (string-ci<=? (string string ... -> boolean)
+	"to determine whether one string alphabetically"
+	"precedes another (or is equal to it)"
+	"in a case-insensitive manner")
+      (string-ci>=? (string string ... -> boolean)
+	"to determine whether one string alphabetically"
+	"succeeds another (or is equal to it)"
+	"in a case-insensitive manner")
+    
+      (string->symbol (string -> symbol)
+	"to convert a string into symbol")
+      (string->number (string -> (union number false))
+	"to convert a string into a number,"
+	"produce false if impossible")
+      (string->list (string -> (listof char))
+	"to convert a string into a list of characters")
+      (list->string ((listof char) -> string)
+	"to convert a s list of characters into a string")
+
+      (format (string any ... -> string)
+	"to format a string, possibly embedding values"))
+
+    ("Images"
+     (image? (any -> boolean)
+       "to determine whether a value is an image")
+     (image=? (image image -> boolean)
+       "to determine whether two images are equal"))
+
+    ("Misc"
+      (identity (any -> any)
+	"to return the argument unchanged")
+      ((beginner-error error) (symbol string -> void) "to signal an error")
+      ((beginner-struct? struct?) (any -> boolean)
+       "to determine whether some value is a structure")
+      ((beginner-equal? equal?) (any any -> boolean)
+	"to determine whether two values are structurally equal")
+      (eq? (any any -> boolean)
+	"to compare two values")
+      (eqv? (any any -> boolean)
+	"to compare two values")
+      ((beginner-=~ =~) (real real non-negative-real -> boolean)
+	"to check whether two real numbers are within some amount (the third argument) of either other")
+      ((beginner-equal~? equal~?) (any any non-negative-real -> boolean)
+	"to compare like equal? on the first two arguments, except using =~ in the case of real numbers")
+      (eof eof
+	"the end-of-file value")
+      (eof-object? (any -> boolean)
+	"to determine whether some value is the end-of-file value")
+      ((beginner-exit exit) ( -> void)
+       "to exit the running program"))))
diff --git a/collects/lang/private/contract-forms.ss b/collects/lang/private/contract-forms.ss
new file mode 100644
index 0000000000..e2a456847e
--- /dev/null
+++ b/collects/lang/private/contract-forms.ss
@@ -0,0 +1,17 @@
+(module contract-forms mzscheme
+  
+  (require "contracts/contracts-module-begin.ss"
+	   "contracts/contracts.ss"
+	   "contracts/define-data.ss")
+  
+  (provide beginner-contract 
+           beginner-define-data 
+           beginner-module-begin
+
+	   intermediate-contract 
+           intermediate-define-data 
+           intermediate-module-begin
+
+	   advanced-contract 
+           advanced-define-data 
+           advanced-module-begin))
diff --git a/collects/lang/private/contracts/advanced-contracts.ss b/collects/lang/private/contracts/advanced-contracts.ss
new file mode 100644
index 0000000000..e1c02921cd
--- /dev/null
+++ b/collects/lang/private/contracts/advanced-contracts.ss
@@ -0,0 +1,7 @@
+(module advanced-contracts mzscheme
+  (require "contracts-helpers.ss")
+  (require (lib "list.ss"))
+  
+  (provide void-contract)
+  
+  (define void-contract (lambda (stx) (build-flat-contract void? 'void stx))))
\ No newline at end of file
diff --git a/collects/lang/private/contracts/beginner-contracts.ss b/collects/lang/private/contracts/beginner-contracts.ss
new file mode 100644
index 0000000000..24be9e5225
--- /dev/null
+++ b/collects/lang/private/contracts/beginner-contracts.ss
@@ -0,0 +1,26 @@
+(module beginner-contracts mzscheme
+  
+  (require "contracts-helpers.ss"
+           (lib "posn.ss" "lang")
+           (lib "teach.ss" "lang" "private")
+           (lib "list.ss"))  
+  
+  (provide (all-defined))
+  
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;  flat type contracts for beginner language
+  
+  (define any-contract (lambda (stx) (build-flat-contract (lambda (x) #t) 'any stx)))
+  (define symbol-contract (lambda (stx) (build-flat-contract symbol? 'symbol stx)))
+  (define number-contract (lambda (stx) (build-flat-contract number? 'number stx)))
+  (define integer-contract (lambda (stx) (build-flat-contract integer? 'integer stx)))
+  (define exact-number-contract (lambda (stx)  (build-flat-contract exact? 'exact-number stx)))
+  (define inexact-number-contract (lambda (stx) (build-flat-contract inexact? 'inexact-number stx)))
+  (define boolean-contract (lambda (stx) (build-flat-contract boolean? 'boolean stx)))
+  (define true-contract (lambda (stx) (build-flat-contract (lambda (x) (eq? x #t)) 'true stx)))
+  (define false-contract (lambda (stx)  (build-flat-contract (lambda (x) (eq? x #f)) 'false stx)))
+  (define string-contract (lambda (stx) (build-flat-contract string? 'string stx)))
+  (define posn-contract (lambda (stx) (build-flat-contract posn? 'posn stx)))
+  (define empty-contract (lambda (stx) (build-flat-contract null? 'empty stx)))
+  (define list-contract (lambda (stx) (build-flat-contract pair? 'list stx))))
\ No newline at end of file
diff --git a/collects/lang/private/contracts/contract-transformers.ss b/collects/lang/private/contracts/contract-transformers.ss
new file mode 100644
index 0000000000..fb852ae305
--- /dev/null
+++ b/collects/lang/private/contracts/contract-transformers.ss
@@ -0,0 +1,202 @@
+(module contract-transformers mzscheme
+  (require-for-template mzscheme
+			"contracts-helpers.ss" 
+			"beginner-contracts.ss" 
+			"intermediate-contracts.ss" 
+			"advanced-contracts.ss")
+
+  (provide (all-defined))
+  
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; COMMON STUFF- Translators
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  ;; We really should compare with module-identifier=", 
+  ;; but importing the right identifiers here is a pain.
+  ;; As it happens, the teaching languages disable shadowing,
+  ;; so we can safely use symbol equality.
+  (define (contract-id=? a b)
+    (eq? (syntax-e a) (syntax-e b)))
+
+  ;; a translator is a function that translates syntax for contracts
+  ;; (like:  number, (number -> string), (number -> (number -> boolean)) )
+  ;; and converts it into the necesary function calls to enforce those contracts
+
+  ;; translate-arrow-contract : syntax (syntax -> syntax) -> syntax
+  ;; parses contracts for (domain ... -> range) type contracts
+  ;; the first argument is the syntax object to parse
+  ;; the second argument is translator that should be used for recursive calls
+  (define translate-arrow-contract
+    (lambda (stx translator)
+      (syntax-case stx (->)
+	[(domain ... -> range)
+	 (with-syntax 
+	     ([(parsed-domain ...) (map translator (syntax-e (syntax (domain ...))))]
+	      [parsed-range (translator (syntax range))]
+	      [ret stx])
+	   (syntax (->-contract (list parsed-domain ...) parsed-range #'ret)))]
+	[else-stx (raise-syntax-error 'contracts "unknown contract" (syntax else-stx))])))
+
+  ;; beginners cant use higher order contracts, so only allow func contracts in the top level
+  (define beginner-translate-contract
+    (case-lambda
+     [(stx) (beginner-translate-contract stx beginner-translate-flat-contract)]
+     [(stx recur)
+      (syntax-case stx (->)
+	[(domain ... -> range) (translate-arrow-contract stx recur)]
+	[_else-stx (beginner-translate-flat-contract stx recur)])]))
+
+
+  ;; syntax definitions for beginner language contracts (from beginner-contracts.scm)
+  (define beginner-translate-flat-contract
+    (case-lambda 
+     [(stx) (beginner-translate-flat-contract stx beginner-translate-flat-contract)]
+     [(stx recur)
+      
+      (syntax-case* stx (-> add1 quote cons number any integer 
+			    exact-number inexact-number posn boolean 
+			    true false 
+			    string empty symbol list)
+		    contract-id=?
+	[(cons a b) (with-syntax ([car-contract (recur (syntax a))]
+				  [cdr-contract (recur (syntax b))]
+				  [ret stx])
+		      (syntax/loc stx (cons-contract car-contract cdr-contract #'ret)))]
+	[(list a ...) (with-syntax ([(translated ...) (map recur (syntax-e (syntax/loc stx (a ...))))]
+				    [ret stx])
+			(syntax/loc stx (args-contract (list translated ...) #'ret)))]
+	[(add1 a) (with-syntax ([translated (recur (syntax/loc stx a))]
+				[ret stx])
+		    (syntax/loc stx (add1-contract translated #'ret)))]
+	[empty (with-syntax ([ret stx]) 
+		 (syntax/loc stx (empty-contract #'ret)))]
+	[(quote n) (with-syntax ([ret stx]) 
+		     (syntax/loc stx (build-flat-contract (lambda (x) (eq? x 'n)) 'n #'ret)))]
+	[number (with-syntax ([ret stx]) 
+		  (syntax/loc stx (number-contract #'ret)))]
+	[any (with-syntax ([ret stx]) 
+	       (syntax/loc stx (any-contract #'ret)))]
+	[symbol (with-syntax ([ret stx]) 
+		  (syntax/loc stx (symbol-contract #'ret)))]
+	[integer (with-syntax ([ret stx]) 
+		   (syntax/loc stx (integer-contract #'ret)))]
+	[exact-number (with-syntax ([ret stx]) 
+			(syntax/loc stx (exact-number-contract #'ret)))]
+	[inexact-number (with-syntax ([ret stx]) 
+			  (syntax/loc stx (inexact-number-contract #'ret)))]
+	[boolean (with-syntax ([ret stx]) 
+		   (syntax/loc stx (boolean-contract #'ret)))]
+	[true (with-syntax ([ret stx]) 
+		(syntax/loc stx (true-contract #'ret)))]
+	[false (with-syntax ([ret stx]) 
+		 (syntax/loc stx (false-contract #'ret)))]
+	[string(with-syntax ([ret stx]) 
+		 (syntax/loc stx (string-contract #'ret)))]
+	[posn (with-syntax ([ret stx]) 
+		(syntax/loc stx (posn-contract #'ret)))]
+	[(domain ... -> range) 
+	 (raise-syntax-error 'contracts "functions in the beginner language can't take other functions as input" stx)]
+	[(make-struct e1 e2 ...)
+	 (pair? (regexp-match "make-(.*)" (symbol->string (syntax-object->datum (syntax make-struct)))))
+	 (let ([make (regexp-match "make-(.*)" (symbol->string (syntax-object->datum (syntax make-struct))))])
+	   (let ([struct (datum->syntax-object stx (string->symbol (cadr make)))])
+	     (if (define-struct? struct)
+		 (with-syntax ([pred (get-predicate-from-struct struct)]
+			       [(accessors ...) (reverse (get-accessors-from-struct struct))]
+			       [name (syntax-object->datum struct)]
+			       [(translated ...) (map recur (syntax-e (syntax (e1 e2 ...))))]
+			       [ret stx])                  ; we wrap with lambdas so that beginner doesnt complain about using them without a (
+		   (syntax/loc stx (struct-contract 'name (lambda (x) (pred x)) (list (lambda (x) (accessors x)) ...) (list translated ...) #'ret)))
+		 (raise-syntax-error 'contracts (format "unknown structure type: ~e" 
+							(syntax-object->datum struct)) stx))))]
+	
+	[-> (raise-syntax-error 'contracts "found a lone '->', check your parentheses!" stx)]
+	
+	[name
+	 (number? (syntax-object->datum (syntax name)))
+	 (with-syntax ([num (syntax-object->datum (syntax name))]
+		       [ret stx])
+	   (syntax/loc stx (build-flat-contract (lambda (x) (eq? num x)) num #'ret)))]
+	
+	[name 
+	 (define-data? (syntax name)) ; things from a define data
+	 (with-syntax ([cnt (get-cnt-from-dd (syntax name))])
+	   (syntax/loc stx cnt))]
+	
+	[name
+	 (define-struct? (syntax name)) ; generic structs
+	 (with-syntax ([pred (get-predicate-from-struct (syntax name))]
+		       [type-name (get-name-from-struct (syntax name))]
+		       [ret stx])
+	   (syntax/loc stx (build-flat-contract (lambda (x) (pred x)) 'type-name #'ret)))]
+	
+	[name (raise-syntax-error 'contracts "unknown contract" (syntax name))])]))
+
+  ;; stx definitions for intermediate language contracts (intermediate-contracts.scm)
+  (define intermediate-translate-contract
+    (case-lambda 
+     [(stx) (intermediate-translate-contract stx intermediate-translate-contract)]
+     [(stx recur)
+      (syntax-case* stx (-> listof quote vectorof boxof)
+		    contract-id=?
+	[(listof type) (with-syntax ([ret stx]
+				     [trans-type (recur (syntax type))])  
+			 (syntax/loc stx (listof-contract trans-type #'ret)))]
+	[(vectorof type) (with-syntax ([ret stx]
+				       [trans-type (recur (syntax type))]) 
+			   (syntax/loc stx (vectorof-contract trans-type #'ret)))]
+	[(boxof type) (with-syntax ([ret stx]
+				    [trans-type (recur (syntax type))]) 
+			(syntax/loc stx (boxof-contract trans-type #'ret)))]
+	[(quote n) (with-syntax ([ret stx]) 
+		     (syntax/loc stx (build-flat-contract (lambda (x) (eq? x 'n)) 'n #'ret)))]
+	[(domain ... -> range) (translate-arrow-contract stx intermediate-translate-contract)]
+	[else-stx (beginner-translate-contract (syntax else-stx) intermediate-translate-contract)])]))
+
+  ;; stx definitions for advanced language contracts (advanced-contracts.scm)
+  (define advanced-translate-contract
+    (case-lambda 
+     [(stx) (advanced-translate-contract stx advanced-translate-contract)]
+     [(stx recur) 
+      (syntax-case* stx (-> void) contract-id=?
+	[void (with-syntax ([ret stx]) 
+		(syntax/loc stx (void-contract #'ret)))]
+	[(domain ... -> range) (translate-arrow-contract stx advanced-translate-contract)]
+	[else-stx (intermediate-translate-contract (syntax else-stx))])]))
+
+  ;; helper functions for these 
+
+  ;;get-predicate-from-struct : stx -> stx
+  ;;returns the predicate for the given stx, which needs to be an object defined via define-struct/define-data
+  (define (get-predicate-from-struct stx) 
+    (caddr (syntax-local-value stx)))
+
+  ;;get-cnt-from-dd : stx -> stx
+  ;;returns the syntax contract that corresponds to the current define-data object
+  (define (get-cnt-from-dd stx)
+    (if (define-data? stx)
+	(caddr (syntax-local-value stx))))
+
+  ;;get-name-from-struct : stx -> stx
+  ;;returns the name for the given stx, which needs to be an object defined via define-struct/define-data
+  (define (get-name-from-struct stx) 
+    (car (syntax-local-value stx)))
+
+  ;;get-accessors-from-struct : stx -> list of stx
+  ;;returns the name for the given stx, which needs to be an object defined via define-struct/define-data
+  (define (get-accessors-from-struct stx) 
+    (cadddr (syntax-local-value stx)))
+
+  ;;define-struct? : stx -> boolean
+					; was this thing defined in a define-struct? 
+  (define (define-struct? stx)
+    (and (identifier? stx) (pair? (syntax-local-value stx (lambda () #f)))))
+
+  ;;define-data? : stx -> boolean
+					; was this thing defined in a define-data? 
+  (define (define-data? stx)
+    (and (identifier? stx)
+	 (let ([data (syntax-local-value stx (lambda () #f))])
+	   (and data (pair? data) (eq? (cadr data) 'define-data)))))
+
+  )
diff --git a/collects/lang/private/contracts/contracts-helpers.ss b/collects/lang/private/contracts/contracts-helpers.ss
new file mode 100644
index 0000000000..47753f3a3f
--- /dev/null
+++ b/collects/lang/private/contracts/contracts-helpers.ss
@@ -0,0 +1,429 @@
+(module contracts-helpers mzscheme
+  
+  (require "hilighters.ss")
+  (require (lib "etc.ss"))
+           
+  (provide (all-defined))
+  
+  #| 
+contract : 
+  enforcer: function (x -> x) that enforces the contract
+  hilighter: a function that given a path to a contract violation, 
+             returns the content of the contract with the expression 
+             denoted by the path hilighted.
+  source,line,column,pos,span: source location data for where the contract was defined
+                               correspond to same fields in defining syntax object
+|#
+  (define-struct contract (enforcer hilighter source line column position span))
+  
+  #|
+flat-contract : contract
+  predicate: a predicate that can be used to verify this contract.
+|#
+  (define-struct (flat-contract contract) (predicate))
+  
+  ; build-flat-contract: short cut for making flat-contracts
+  ; (any -> bool) symbol syntax -> flat-contract
+  ; returns contract that enforces given predicate
+  (define build-flat-contract
+    (lambda (predicate name stx)
+      (letrec ([me (make-flat-contract
+                    
+                    (lambda (x) 
+                      (if (predicate x) 
+                          x 
+                          (contract-error x me '())))
+                    
+                    (mk-flat-hilighter name)
+                    
+                    (syntax-source stx)
+                    (syntax-line stx)
+                    (syntax-column stx)
+                    (syntax-position stx)
+                    (syntax-span stx)
+                    
+                    predicate)])
+        me)))
+  
+  ;; ->-contract: list-of-contracts contract syntax -> contract
+  ;; translates domain and range contracts into a single contract
+  ;; that represents the contract of a function that takes in values that 
+  ;; satisfy domain contract and returns values that satisfies range contract
+  ;; the domain contract is defined by the list,
+  (define ->-contract
+    (lambda (domain-contracts-list range-contract stx)
+      (letrec ([me (make-contract
+                    (lambda (f)
+                      (cond [(not (procedure? f))
+                             (error 'contracts (format "~e is not a function" f))]
+                            [(procedure-arity-includes? f (length domain-contracts-list))
+                             (apply-contract f domain-contracts-list range-contract me stx)]
+                            [else
+                             (parameterize ([print-struct true])
+                               (error 'contracts (format "~e expects ~e arguments, not ~e" 
+                                                         f 
+                                                         (procedure-arity f) 
+                                                         (length domain-contracts-list))))]))
+                   
+                    (let ([dom-hilighter-list (map (lambda (x) (contract-hilighter x)) domain-contracts-list)]) 
+                      (mk-arrow-hilighter dom-hilighter-list (contract-hilighter range-contract)))
+                    
+                    (syntax-source stx)
+                    (syntax-line stx)
+                    (syntax-column stx)
+                    (syntax-position stx)
+                    (syntax-span stx))])
+        
+        me)))
+  
+  ;; args-contract: (contract ...) stx -> contract
+  ;; takes in a list of contracts, and returns a contract that checks for a
+  ;; list (a b c ...) where each member satisfies the corresponding contract in the input
+  ;; useful for function arguments
+  (define (args-contract cnt-list stx)
+    (letrec ([me (make-flat-contract
+                  (lambda (values) 
+                    (if (pair? values)
+                        (verify-contracts me cnt-list values)
+                        (contract-error values me '())))
+                  (mk-list-hilighter (map (lambda (c) (contract-hilighter c)) cnt-list))
+                  (syntax-source stx)
+                  (syntax-line stx)
+                  (syntax-column stx)
+                  (syntax-position stx)
+                  (syntax-span stx)
+                  
+                  (lambda (values)
+                    (if (not (andmap flat-contract? cnt-list))
+                        (error 'args-contract 
+                               "not all subcontracts of ~e are flat contracts, so predicate is undefined"
+                               ((contract-hilighter me) #f))
+                        (and (list? values) 
+                             (andmap (lambda (c x) ((flat-contract-predicate c) x)) cnt-list values)))))])
+      me))
+  
+  
+  ;; apply-contract: (any ... -> any) list of contracts contract -> (any ... -> any)
+  ;; returns a function that identical to the given one, except that it enforces contracts
+  ;; since functions can take in multiple values, the full domain contract is given as a list of 
+  ;; contracts.
+  (define (apply-contract function domain-contracts-list range-contract func-cnt stx)
+    (let ([dom-list-contract (args-contract domain-contracts-list stx)]
+          [range-composer 
+           (lambda (values)
+             (lambda (error) 
+               (let ([name (object-name function)])
+                 (if (regexp-match #rx"[0-9]+:[0-9]+" (symbol->string name)) 
+                     ; cant infer a good name (higher order things)
+                     (format "function defined on line ~e (called with: ~a) failed the assertion ~e"
+                             name 
+                             (format-list-with-spaces values)
+                             error)
+                     ; have func name
+                     (format "function ~e (called with: ~a) failed the assertion ~e"
+                             name
+                             (format-list-with-spaces values)
+                             error)))))]
+          [domain-composer
+           (lambda (values)
+             (lambda (error)
+               (let ([name (object-name function)])
+                 (if (regexp-match #rx"[0-9]+:[0-9]+" (symbol->string name)) 
+                     (format "the arguments to the function defined on line ~e (~e) failed the assertion ~e"
+                             name values error)
+                     (format "function ~e's arguments ~a failed the assertion ~e" 
+                             name
+                             (format-list-with-spaces values)
+                             error)))))])
+      
+      (lambda values
+        (let* ([checked-values (catch-contract-error (domain-composer values)
+                                                     'car
+                                                     func-cnt
+                                                     ((contract-enforcer dom-list-contract) values))]
+               [return-value (apply function checked-values)]
+               [range-enforcer (contract-enforcer range-contract)])
+          (catch-contract-error (range-composer values) 'cdr func-cnt (range-enforcer return-value))))))
+  
+  ;; format-list-with-spaces : (listof any) -> string
+  (define (format-list-with-spaces args)
+    (cond
+      [(null? args) ""]
+      [else 
+       (apply
+        string-append
+        (let loop ([fst (car args)]
+                   [rst (cdr args)])
+          (cond
+            [(null? rst) (list (format "~e" fst))]
+            [else (cons (format "~e " fst)
+                        (loop (car rst)
+                              (cdr rst)))])))]))
+              
+  
+  ; verify-contracts: contract contracts values
+  ; contracts and values are two lists of equal length
+  ; uses the hilighter from the first argument. enforcer for args-contract
+  (define (verify-contracts cnt cnt-list values)
+    (if (not (eq? (length cnt-list) (length values)))
+        (error 'verify-contracts 
+               (format "~e and ~e dont have same length (~e and ~e)" 
+                       cnt-list
+                       values
+                       (length cnt-list)
+                       (length values))))
+    (let loop ([path-to-add (cons 'car '())]
+               [curr-cnt cnt-list]
+               [curr-val values]
+               [ret-val '()])
+      
+      (if (or (null? curr-val) (null? curr-cnt))
+          (reverse ret-val)   
+          
+          (let ([curr-ret (catch-contract-error path-to-add
+                                                cnt
+                                                ((contract-enforcer (car curr-cnt)) (car curr-val)))])  
+            (loop (cons 'cdr path-to-add)
+                  (cdr curr-cnt)
+                  (cdr curr-val)
+                  (cons curr-ret ret-val))))))
+  
+  ; cons-contract: contract contract -> contract
+  ; given two contracts, returns a contract that accepts lists where the car satisfies the first
+  ; and the cdr satisfies the second
+  (define (cons-contract car-contract cdr-contract stx)
+    (if (not (and (flat-contract? car-contract) (flat-contract? cdr-contract)))
+        (error 'contracts "(cons <a> <b>) type contracts can only take flat contracts")
+        (letrec ([cons-hilighter (mk-cons-hilighter (contract-hilighter car-contract) (contract-hilighter cdr-contract))]
+                 [me (make-flat-contract 
+                      (lambda (l)
+                        
+                        (if (pair? l) 
+                            (let ([composer (lambda (h) (format "~s didnt satisfy the contract ~s" l h))]) 
+                              (catch-contract-error composer 'car me ((contract-enforcer car-contract) (car l)))
+                              (catch-contract-error composer 'cdr me ((contract-enforcer cdr-contract) (cdr l)))
+                              l)
+                            (contract-error l me '())))
+                      
+                      cons-hilighter
+                      
+                      (syntax-source stx)
+                      (syntax-line stx)
+                      (syntax-column stx)
+                      (syntax-position stx)
+                      (syntax-span stx)
+                      
+                      (lambda (l) (and (pair? l) ((flat-contract-predicate car-contract) (car l)) 
+                                       ((flat-contract-predicate cdr-contract) (cdr l)))))])
+          me)))
+  
+  
+  ;; add1-contract: flat-contract syntax -> flat-contract
+  ;; implements checker for (add1 <cnt>) style contracts
+  (define (add1-contract cnt stx)
+    (if (flat-contract? cnt) 
+        (letrec ([me (make-flat-contract
+                      
+                      (lambda (x) 
+                        (if (and (number? x) (>= x 0))
+                            (catch-contract-error 'car me ((contract-enforcer cnt) (- x 1)))
+                            (contract-error x me '())))
+                      
+                      (mk-add1-hilighter (contract-hilighter cnt))
+                      
+                      (syntax-source stx)
+                      (syntax-line stx)
+                      (syntax-column stx)
+                      (syntax-position stx)
+                      (syntax-span stx)
+                      
+                      (lambda (x) (and (number? x) (>= x 0) ((flat-contract-predicate cnt) (- x 1)))))])
+          me)
+        (error 'contracts "add1 can only be used with flat contracts")))
+  
+  ; struct contract: symbol (any -> boolean) (struct -> any) flat-contracts -> flat-contract
+  ; returns a contract that enforces the contract (make-<blah> cnt cnt cnt ...)
+  (define (struct-contract name predicate accessors field-contracts stx)
+    (letrec ([hilighter (mk-struct-hilighter name (map contract-hilighter field-contracts))]
+             [not-struct-composer 
+              (lambda (value) 
+                (lambda (error)
+                  (format "~e is not a structure of type ~e, so didnt satisfy contract ~e" value name error)))]
+             [me (make-flat-contract
+                  (lambda (x) (if (predicate x) 
+                                  (let ([field-values (map (lambda (accessor) (accessor x)) accessors)]
+                                        [field-composer (lambda (error) 
+                                                          (format "the fields of structure ~e did not satisfy the assertion ~e" 
+                                                                  x error))])
+                                    (catch-contract-error field-composer #f me 
+                                                          (verify-contracts me field-contracts field-values)))
+                                  (contract-error x me '() #f (not-struct-composer x))))
+                  hilighter
+                  (syntax-source stx)
+                  (syntax-line stx)
+                  (syntax-column stx)
+                  (syntax-position stx)
+                  (syntax-span stx)
+                  (lambda (x) 
+                    (and (predicate x) 
+                         (andmap 
+                          (lambda (a b) 
+                            (and (flat-contract? b) 
+                                 ((flat-contract-predicate b) (a x)))) 
+                          accessors field-contracts))))])
+      me))
+  
+  ; define-data-enforcer: contract any listof contracts -> any
+  (define (define-data-enforcer me value list-of-cnts)
+    (if ((flat-contract-predicate me) value)
+        value
+        (define-data-error me value list-of-cnts)))
+  
+  ;; define-data-error: define-data-contract any list-of-flat-contracts -> void
+  ;; raises the contract exception with a good error message
+  (define (define-data-error me value list-of-cnts)
+    (let loop ([contract-list list-of-cnts]
+               [max-depth 0]
+               [best-cnt #f])
+      
+      (if (null? contract-list) 
+          (if (or (eq? max-depth 0) (not best-cnt)) ; all contracts failed at top level, so just give standard report
+              (contract-error value me '())
+              (define-data-report me value best-cnt))) ; there was a contract that failed deeper than others, 
+      
+      ; give this as the failed part
+      (let ([current-depth (get-error-depth (car contract-list) value)])
+        (if (> current-depth max-depth)
+            (loop (cdr contract-list)
+                  current-depth
+                  (car contract-list))
+            
+            (loop (cdr contract-list)
+                  max-depth
+                  best-cnt)))))
+  
+  ;; get-error-depth: flat-contract any -> number
+  ;; returns how 'deep' the contract checker had to go to find a violation
+  ;; used as a guess as to which contract was the best match for a define-data
+  (define (get-error-depth cnt value)
+    (with-handlers ([exn:contract-violation?
+                     (lambda (e)
+                       (length (exn:contract-violation-trace e)))])
+      ((contract-enforcer cnt) value)
+      (error 'define-data 
+             (format "major internal error: ~e didnt fail ~e, but define-data-error said it did."
+                     value
+                     ((contract-hilighter cnt) #f)))))
+  
+  
+  ;; define-data-report: define-data-contract any flat-contract -> void
+  ;; generates the correct error report for a define data. 
+  ;; the first argument is the define-data contract being checked,
+  ;; the second is the value being checked
+  ;; and the third is the contract (one of the flats that was used in the define-data) that will be
+  ;; reported as the best failure match
+  (define (define-data-report me value best-cnt)  
+    (with-handlers ([exn:contract-violation? 
+                     (lambda (e) 
+                       (raise 
+                        (make-exn:contract-violation 
+                         (string->immutable-string
+			  (format "contract violation: ~e is not a ~e [failed part: ~e]" 
+                                 value 
+                                 ((contract-hilighter me) '()) 
+                                 ((contract-hilighter best-cnt) (exn:contract-violation-path e))))
+                         (current-continuation-marks)
+                         value
+                         '()
+                         me 
+                         (exn:contract-violation-trace e))))])
+      
+      ((contract-enforcer best-cnt) value))
+    
+    (error 'define-data 
+           (format "major internal error: ~e didnt fail ~e, but define-data-error said it did."
+                   value
+                   ((contract-hilighter best-cnt) #f))))
+  
+  ;;;;;;;;;;;;;;;;;;  ERROR HANDLING
+  
+  ; exn:contract-violation
+  ; exception used for contract violations.
+  ; full fields: 
+  ; - message
+  ; - continuation-marks
+  ; - value
+  ; - path: a list of 'car 'cdr that describes which component of the contract failed
+  ; - failed-cnt: the contract that failed
+  ; - trace: a list of exn:contract-violation that describe the whole path of contract exceptions thrown
+  (define-struct (exn:contract-violation exn) (value path failed-cnt trace))
+  
+  ; contract-error-display-handler: outputs of the information from a contract exception
+  (define contract-error-display-handler 
+    (lambda (msg e)
+      (if (exn:contract-violation? e)
+          
+          (let ([failed (exn:contract-violation-failed-cnt e)])
+            (begin 
+              (printf "~s (source: ~e, line: ~e, col: ~e, pos: ~e, span: ~e)\n" 
+                      (exn-message e)
+                      (contract-source failed)
+                      (contract-line failed)
+                      (contract-column failed)
+                      (contract-position failed)
+                      (contract-span failed))
+
+              (printf "current path: ~e\n" (exn:contract-violation-path e))) 
+
+              (unless (null? (exn:contract-violation-trace e))
+                (printf "trace:\n")
+                (map (lambda (x) 
+                       (printf "\t~s ~s\n" (exn-message x) (exn:contract-violation-path x)))
+                     (exn:contract-violation-trace e)))))
+          
+          (display msg)))
+  
+  ; contract-error : value failed-contract path [exn:contract-violation message-composer] -> void
+  ; produces a nice error message.
+  ; if exn-to-pass is given, its tacked on in the front of the new exception's trace. if not given, trace is emptied
+  ; a message composer is a function that takes in an S-Expression that represents the failed contract
+  ; and returns a string that will be used as the error message
+  (define contract-error
+    (opt-lambda (value cnt path [exn-to-pass #f] [message-composer #f])
+       (let ([cnt-hilighted ((contract-hilighter cnt) path)])
+         (raise (make-exn:contract-violation 
+                 (string->immutable-string
+		  (if message-composer
+                      (format "contract violation: ~a" (message-composer cnt-hilighted))
+                      (format "contract violation: ~e didnt satisfy the contract ~e" value cnt-hilighted)))
+                 (current-continuation-marks)
+                 value
+                 path
+                 cnt
+                 (if (and (boolean? exn-to-pass) (not exn-to-pass))
+                     '()
+                     (cons exn-to-pass (exn:contract-violation-trace exn-to-pass))))))))
+  
+  
+  ; shorthand for catching a contract-violation and passing up a new exception with modified paths and hilighters
+  ; (catch-contract-error ('car|'cdr) hilighter expr1 expr2 ...)
+  (define-syntax catch-contract-error
+    (lambda (stx)
+      (syntax-case stx ()
+        [(_ path-to-add cnt e1)
+         (syntax 
+          (catch-contract-error #f path-to-add cnt e1))]
+        
+        ;; this version takes a message-composer, as in contract-error
+        [(_ message-composer path-to-add cnt e1)
+         (syntax 
+          (with-handlers 
+              ([exn:contract-violation? 
+                (lambda (e) 
+                  (let ([val (exn:contract-violation-value e)]
+                        [new-path (cond
+                                    [(not path-to-add) (exn:contract-violation-path e)]
+                                    [(pair? path-to-add) (append path-to-add (exn:contract-violation-path e))]
+                                    [else (cons path-to-add (exn:contract-violation-path e))])])
+                    (contract-error val cnt new-path e message-composer)))])
+            e1))]))))
diff --git a/collects/lang/private/contracts/contracts-module-begin.ss b/collects/lang/private/contracts/contracts-module-begin.ss
new file mode 100644
index 0000000000..67a6146c68
--- /dev/null
+++ b/collects/lang/private/contracts/contracts-module-begin.ss
@@ -0,0 +1,199 @@
+(module contracts-module-begin mzscheme
+  
+  (require "contracts.ss")
+  
+  (require-for-syntax (lib "list.ss"))
+  
+  (provide beginner-module-begin intermediate-module-begin advanced-module-begin)
+  
+  (define-syntaxes (beginner-module-begin intermediate-module-begin advanced-module-begin)
+    (let ()
+      (define (parse-contracts language-level-contract language-level-define-data)
+	;; takes a list of syntax objects (the result of syntax-e) and returns all the syntax objects that correspond to
+	;; a contract declaration. Syntax: (contract function-name (domain ... -> range))
+	(define extract-contracts
+	  (lambda (lostx) 
+	    (filter contract-stx? lostx)))
+	
+					; negate previous
+	(define extract-not-contracts
+	  (lambda (stx-list) 
+	    (filter (lambda (x) (not (contract-stx? x))) stx-list)))
+	
+					; predicate: is this syntax object a contract expr?
+	(define contract-stx?
+	  (lambda (stx) 
+	    (syntax-case stx () 
+	      [(contract function cnt) 
+	       (and (identifier? #'contract)
+		    (module-identifier=? #'contract language-level-contract))]
+	      [_ #f])))
+	
+					; pred: is this syntax obj a define-data?
+	(define define-data-stx?
+	  (lambda (stx)
+	    (syntax-case stx ()
+	      [(define-data name e1 e2 ...)
+	       (and (identifier? #'define-data)
+		    (module-identifier=? #'define-data language-level-define-data))]
+	      [_ #f])))
+	
+	;; takes a list of contract stx and a definitions stx and tells you if there is a contract defined for this function
+	(define contract-defined?
+	  (lambda (cnt-list item)
+	    (cond 
+	     [(null? cnt-list) #f]
+	     [(fn=? (get-function-from-contract (car cnt-list)) (get-function-from-def item)) #t]
+	     [else (contract-defined? (cdr cnt-list) item)])))
+	
+	;; returns the name of the function in a given contract-syntax
+	(define get-function-from-contract
+	  (lambda (stx) 
+	    (if (contract-stx? stx)
+		(syntax-case stx () 
+		  [(contract function cnt ...) (syntax function)]
+                  [_ (raise-syntax-error 'contract "internal error.1")])
+		(raise-syntax-error 'contract "this is not a valid contract" stx))))  
+	
+	;; used to match up contract definitions with function definitions
+					; should just be bound-identifier=?, but since beginner does some funny things
+					; with hygiene, we have to do this
+	(define (fn=? a b)
+	  (string=? (symbol->string (syntax-object->datum a)) 
+		    (symbol->string (syntax-object->datum b))))
+	
+	;; search in the cnt-list for the contract that matches the given definition
+	(define get-contract
+	  (lambda (cnt-list def-stx)
+	    (cond
+	     [(null? cnt-list) (error 'get-contract "contract not found")]
+	     [(fn=? (get-function-from-contract (car cnt-list)) (get-function-from-def def-stx)) (car cnt-list)]
+	     [else (get-contract (cdr cnt-list) def-stx)])))
+	
+	;; returns the name of the function in a given definition-syntax
+	(define get-function-from-def
+	  (lambda (stx) 
+	    (if (definition-stx? stx)
+		(syntax-case stx (begin define-values define-syntaxes) 
+		  [(define-values (f) e1 ...) (syntax f)]
+                  [_ (raise-syntax-error 'contract "internal error.2")])
+		(raise-syntax-error 'defs "this is not a valid definition" stx))))
+	
+	;; given a syntax object, tells you whether or not this is a definition.
+	(define definition-stx? 
+	  (lambda (stx) 
+	    (syntax-case stx (begin define-values)
+	      [(define-values (f) e1 ...) #t]
+	      [_ #f])))
+	
+	;;transform-definiton
+	(define (transform-definition def)
+	  (syntax-case def (define-values)
+	    [(define-values (func) exp)
+	     (with-syntax ([new-name (rename-func def)]
+			   [expr-infname (syntax-property (syntax exp) 'inferred-name 
+							  (syntax-object->datum (syntax func)))])
+	       (syntax/loc def (define-values (new-name) expr-infname)))]
+            [_ (raise-syntax-error 'contract "internal error.3")]))
+	
+	(define (rename-func def)
+	  (let ([name (get-function-from-def def)])
+	    (syntax-case def (define-values)
+	      [(define-values (f) e1)
+	       (datum->syntax-object (syntax f) 
+				     (string->symbol (string-append (symbol->string (syntax-object->datum name)) "-con")))]
+              [_ (raise-syntax-error 'contract "internal error.4")])))
+	
+
+	;; transform-contract : syntax syntax -> syntax
+	;; takes in two syntax objects: one representing a contract, and another representing a definition, 
+	;; returns a syntax object that returns the correct language level contract wrapping
+	(define transform-contract
+	  (lambda (language-level-contract cnt-stx def-stx)
+	    (syntax-case cnt-stx ()
+	      [(contract function cnt) 
+	       (with-syntax ([ll-contract language-level-contract]
+			     [name-to-bind (get-function-from-def def-stx)]
+			     [func-to-wrap (rename-func def-stx)])
+		 (syntax/loc cnt-stx (ll-contract 'name-to-bind 'func-to-wrap cnt)))]
+              [_ (raise-syntax-error 'contract "internal error.5")])))
+	
+	(define local-expand-stop-list 
+          (list 'contract 'define-values 'define-syntaxes 'require 'require-for-syntax 
+                'provide 'define-data '#%app '#%datum 'define-struct 'begin))
+	
+	;; parse-contract-expressions 
+	;; takes in a list of top level expressions and a list of contracts, and outputs the correct transformation. 
+	;; 1. expand until we find a definition or a contract
+	;; 2. if its a definition, and it has a contract, transform and output
+	;; 3. else just output it
+	(define (parse-contract-expressions ll-contract ll-define-data contract-list expressions)
+
+	  (let loop ([cnt-list contract-list]
+		     [exprs expressions])
+
+	    (cond
+              [(null? exprs)
+               (if (null? cnt-list)
+                   (syntax (begin ))
+                   (raise-syntax-error 'contracts "this contract has no corresponding def" (car cnt-list)))]
+              [else
+               ;      (let ([expanded (local-expand (car exprs) (syntax-local-context) local-expand-stop-list)])
+               (let ([expanded (local-expand (car exprs) 'module local-expand-stop-list)])
+                 (syntax-case expanded (begin define-values define-data)
+                   [(define-values (func) e1 ...)
+                    (contract-defined? cnt-list expanded)
+                    (let ([cnt (get-contract cnt-list expanded)])
+                      (quasisyntax/loc (car exprs)
+                        (begin
+                          #,(transform-definition expanded)
+                          #,(transform-contract ll-contract cnt expanded)
+                          #,(loop (remove cnt cnt-list) (cdr exprs)))))]
+                   [(define-data name c1 c2 ...)
+                    (identifier? #'name)
+                    (quasisyntax/loc (car exprs)
+                      (begin
+                        (#,ll-define-data name c1 c2 ...)
+                        #,(loop cnt-list (cdr exprs))))]
+                   [(begin e1 ...)
+                    (loop cnt-list (append (syntax-e (syntax (e1 ...)))(cdr exprs)))]
+                   [_else 
+                    (quasisyntax/loc (car exprs)
+                      (begin
+                        #,(car exprs)
+                        #,(loop cnt-list (cdr exprs))))]))])))
+	
+
+
+	;; contract transformations!
+	;; this is the macro, abstracted over which language level we are using. 
+	;; parse-contracts : 
+	;; given transformers that handle the actual contract parsing (depends on language level.. see contracts.scm and define-data.scm
+	;; this returns a big wrapper macro that translates calls to 
+	;; (contract f (number -> number)) (define f ...)
+	;; ====>>>> (lang-lvl-contract f (number -> number) ...)
+	;; where ll-contract is either beginner-contract, intermediate-contract, or advanced-contract
+	;; and (define-data name ....) to (lang-lvl-define-data name ...)
+	
+        (lambda (stx)
+	  (syntax-case stx ()
+	    [(_ e1 ...)
+	     (let* ([top-level (syntax-e (syntax (e1 ...)))]
+		    [cnt-list (extract-contracts top-level)]
+		    [expr-list (extract-not-contracts top-level)])
+	       (with-syntax ([rest (parse-contract-expressions language-level-contract
+                                                               language-level-define-data
+                                                               cnt-list
+                                                               expr-list)])
+		 (syntax/loc stx (#%plain-module-begin rest))))])))
+      
+      (define parse-beginner-contract/func 
+        (parse-contracts #'beginner-contract #'beginner-define-data))
+      (define parse-intermediate-contract/func 
+        (parse-contracts #'intermediate-contract  #'intermediate-define-data))
+      (define parse-advanced-contract/func
+        (parse-contracts #'advanced-contract #'advanced-define-data))
+    
+      (values parse-beginner-contract/func
+              parse-intermediate-contract/func
+              parse-advanced-contract/func))))
diff --git a/collects/lang/private/contracts/contracts.ss b/collects/lang/private/contracts/contracts.ss
new file mode 100644
index 0000000000..e74a69029e
--- /dev/null
+++ b/collects/lang/private/contracts/contracts.ss
@@ -0,0 +1,40 @@
+(module contracts mzscheme
+  
+  (provide beginner-contract intermediate-contract advanced-contract)
+  
+  (require "contracts-helpers.ss")
+
+  (require-for-syntax "contract-transformers.ss")
+  
+  ;; contract function <contract> code)
+  ;; <contract> = flat-contract || arrow-contract, in syntax understood by contract-transformers.scm
+  ;; wraps the value code with a contract enforcer function for the given contract
+  
+  (define-syntaxes (beginner-contract intermediate-contract advanced-contract)
+    (let ()
+      
+      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ; CONTRACT MACRO
+      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      
+      ; contract-template: (syntax -> syntax) -> (syntax -> syntax)
+      ; returns a contract parser. uses the translator given as an argument
+      (define contract-template
+        (lambda (translator)
+          (lambda (stx)
+            (syntax-case stx (-> quote)
+              ((_ 'name-to-bind 'func-to-wrap cnt)
+               (with-syntax ([parsed-contract (translator (syntax cnt))])
+			    (syntax 
+			     (define-values (name-to-bind) 
+			       ((contract-enforcer parsed-contract) func-to-wrap)))))
+              [_ (raise-syntax-error 'contracts.ss "internal error.1")]))))
+      
+      
+      (define beginner-contract/func (contract-template beginner-translate-contract))
+      (define intermediate-contract/func (contract-template intermediate-translate-contract))
+      (define advanced-contract/func (contract-template advanced-translate-contract))
+      
+      (values beginner-contract/func
+              intermediate-contract/func
+              advanced-contract/func))))
diff --git a/collects/lang/private/contracts/define-data.ss b/collects/lang/private/contracts/define-data.ss
new file mode 100644
index 0000000000..7896650a8b
--- /dev/null
+++ b/collects/lang/private/contracts/define-data.ss
@@ -0,0 +1,94 @@
+(module define-data mzscheme
+  
+  (require-for-syntax "advanced-contracts.ss" 
+                      "hilighters.ss"
+		      "contract-transformers.ss")
+  (require "contracts-helpers.ss"
+	   "hilighters.ss")
+  
+  (provide beginner-define-data
+           intermediate-define-data 
+           advanced-define-data
+           
+           beginner-dd-builder
+           intermediate-dd-builder
+           advanced-dd-builder)
+  
+  ;;;;;;;;;;;;;;;;;; define-data
+ #|
+ 
+execution is broken into two parts to support recursive definitions: first we bind all the names we need, and then define them.
+
+*-define-data binds the name if the definition as syntax as a list that has three items: the name of the data definition, the 
+symbol 'define-data (just to distinguish what it is), and a syntax object that represents the name of the contract structure
+that enforces this definition (called <name>-contract). also expands into the definition of this contract-struct.
+
+the second stage actually runs the transformations on the given contracts. since all other names from define-datas have been bound by now, 
+it allows for recursion. the contract enforcer is defined in contracts-helpers.scm
+
+|#
+
+  (define-syntaxes (beginner-dd-builder intermediate-dd-builder advanced-dd-builder) 
+    (let ()
+      
+      (define dd-builder-template
+        (lambda (translator) 
+          (lambda (stx)
+           
+            (syntax-case stx ()
+              [(_ name src e1 e2 ...)
+               
+		 (with-syntax  ([(translated-cnts ...) (map translator (syntax-e (syntax (e1 e2 ...))))])
+	     
+                 (syntax
+                    (letrec ([me (make-flat-contract
+                                  
+                                  ;enforcer
+                                  (lambda (value) 
+                                    (define-data-enforcer me value (list translated-cnts ...)))
+                                  
+                                  ;hilighter
+                                  (lambda (path)
+                                    (let ([hilighter (mk-define-data-hilighter 'name (map contract-hilighter (list translated-cnts ...)))])
+                                      (hilighter path)))
+                                  
+                                  ;stx locations
+                                  (syntax-source src)
+                                  (syntax-line src)
+                                  (syntax-column src)
+                                  (syntax-position src)
+                                  (syntax-span src)
+                                  
+                                  ;predicate
+                                  (lambda (x)
+                                    (ormap (lambda (c) ((flat-contract-predicate c) x)) (list translated-cnts ...))))])
+                      me)))]))))
+      
+      
+      (values (dd-builder-template beginner-translate-contract)
+              (dd-builder-template intermediate-translate-contract)
+              (dd-builder-template advanced-translate-contract))))
+  
+  
+  (define-syntaxes (beginner-define-data intermediate-define-data advanced-define-data)
+    (let ()
+      
+      (define define-data-template
+        (lambda (builder)
+          (lambda (stx)
+            (syntax-case stx ()
+              [(_ name cnt1 cnt2 ...)
+               (with-syntax 
+                   ([cnt-builder builder]
+                    [contract-name 
+                     (datum->syntax-object (syntax name) (string->symbol (string-append (symbol->string (syntax-object->datum (syntax name))) "-contract")))]
+                    [ret stx])
+                 (syntax 
+                  (begin
+                    (define-syntax name (list #'name 'define-data #'contract-name))
+                    (define contract-name (cnt-builder name #'ret cnt1 cnt2 ...)))
+                  ))]))))
+      
+      (values (define-data-template #'beginner-dd-builder)
+              (define-data-template #'intermediate-dd-builder)
+              (define-data-template #'advanced-dd-builder)))))
\ No newline at end of file
diff --git a/collects/lang/private/contracts/hilighters.ss b/collects/lang/private/contracts/hilighters.ss
new file mode 100644
index 0000000000..868d694962
--- /dev/null
+++ b/collects/lang/private/contracts/hilighters.ss
@@ -0,0 +1,108 @@
+(module hilighters mzscheme
+  
+  (provide (all-defined))
+  
+  ;; a path is a 
+  ;;         list of symbols 'car 'cdr (or empty list)
+  ;;         or  #f 
+  ;;that give instructions to a hilighter function to find a certain subexpression in an S-exp.
+  
+  ;; a highlighter function is a function that takes a path and maybe other hilighters and returns an 
+  ;; s-expression with the sub-exp denoted by the path hilighted
+  
+  ;; error message. invalid path
+  (define (path-error type p) 
+    (error 'paths (format "something bad happened: invalid ~e path at ~e" type p)))
+  
+  ;;hilighter for (add1 ... ) contracts
+  (define (mk-add1-hilighter type-hilighter)
+    (lambda (p)
+      (cond 
+       [(not p) `(add1 ,(type-hilighter #f))]
+       [(null? p) `(xxx (add1 ,(type-hilighter #f)))]
+       [(eq? (car p) 'car) `(add1 ,(type-hilighter (cdr p)))]
+       [else (path-error 'add1 p)])))
+  
+  
+  ;;hilighter for (somethingof type) contract
+  (define (mk-somethingof-hilighter thing type-hilighter)
+    (lambda (p) 
+      (cond 
+       [(not p) `(,thing ,(type-hilighter #f))]
+       [(null? p) `(xxx (,thing ,(type-hilighter #f)))]
+       [(eq? (car p) 'car) `(,thing ,(type-hilighter (cdr p)))]
+       [else (path-error thing p)])))
+
+  ;;hilighter for (listof type) contracts
+  (define (mk-listof-hilighter type-hilighter)
+    (mk-somethingof-hilighter 'listof type-hilighter))
+
+  ;;hilighter for (vectorof type) contracts
+  (define (mk-vectorof-hilighter type-hilighter)
+    (mk-somethingof-hilighter 'vectorof type-hilighter))
+
+  ;;hilighter for (vectorof type) contracts
+  (define (mk-boxof-hilighter type-hilighter)
+    (mk-somethingof-hilighter 'boxof type-hilighter))
+  
+  ;;hilighter function for (define-data a cnt1 cnt2 ...)
+  (define (mk-define-data-hilighter name cnt-hilighters)
+    (lambda (p)
+      (let ([list-hl (mk-list-hilighter cnt-hilighters)])
+        (cond
+         [(not p) name]
+         [(null? p) `(xxx ,name)]
+         [(or (eq? (car p) 'car) (eq? (car p) 'cdr)) `(define-data ,name ,@(list-hl p))]
+         [else (path-error name p)]))))
+  
+  ;;returns a hilighter function for (make-<blah> a b c ...) style contracts
+  (define (mk-struct-hilighter name field-hilighters)
+    (lambda (p)
+      (let ([constructor (string->symbol (string-append "make-" (symbol->string name)))])
+        (cond 
+         [(not p) `(,constructor ,@(map (lambda (f) (f #f)) field-hilighters))]
+         [(null? p) `(xxx (,constructor ,@(map (lambda (f) (f #f)) field-hilighters)))]
+         [(eq? (car p) 'car) `(,constructor ,((car field-hilighters) (cdr p)) ,@(map (lambda (f) (f #f)) (cdr field-hilighters)))]
+         [(eq? (car p) 'cdr) `(,constructor ,((car field-hilighters) #f) ,@((mk-list-hilighter (cdr field-hilighters)) (cdr p)))]
+         [else (path-error name p)]))))
+  
+  
+  ;; returns a hilighter function for (cons a b) style contracts
+  (define (mk-cons-hilighter car-hilighter cdr-hilighter) 
+    (lambda (p)
+      (cond
+       [(not p) `(cons ,(car-hilighter #f) ,(cdr-hilighter #f))]
+       [(null? p) `(xxx (cons ,(car-hilighter #f) ,(cdr-hilighter #f)))]
+       [(eq? (car p) 'cdr) `(cons ,(car-hilighter #f) ,(cdr-hilighter (cdr p)))]
+       [(eq? (car p) 'car) `(cons ,(car-hilighter (cdr p)) ,(cdr-hilighter #f))]
+       [else (path-error 'cons p)])))
+  
+  ;; returns a hilighter function for a (a b c -> d) style contract
+  (define (mk-arrow-hilighter domain-hilighter-list range-hilighter)
+    (lambda (p)
+      (let ([list-hilighter (mk-list-hilighter domain-hilighter-list)])
+        (cond
+         [(not p) `( ,@(list-hilighter #f) -> ,(range-hilighter #f))]
+         [(null? p) `(xxx (,@(list-hilighter #f) -> ,(range-hilighter #f)))]
+         [(eq? (car p) 'car) `( ,@(list-hilighter (cdr p)) -> , (range-hilighter #f))]
+         [(eq? (car p) 'cdr) `( ,@(list-hilighter #f) -> ,(range-hilighter (cdr p)))]
+         [else (path-error 'arrow p)]))))
+  
+  ;; returns a hilighter for a list (a b c)
+  (define (mk-list-hilighter lhilighters) 
+    (lambda (p)
+      (let ([false-func (lambda (f) (f #f))])
+        (cond
+         [(not p) `( ,@(map false-func lhilighters))]
+         [(null? p) `(xxx ,@(map false-func lhilighters))]
+         [(eq? (car p) 'car) `( ,@(cons ((car lhilighters) (cdr p)) (map false-func (cdr lhilighters))))]
+         [(eq? (car p) 'cdr) `( ,@(cons ((car lhilighters) #f) ((mk-list-hilighter (cdr lhilighters)) (cdr p))))]
+         [else (path-error 'list p)]))))
+  
+  ;; returns a hilighter for a flat name
+  (define (mk-flat-hilighter name)
+    (lambda (p)
+      (cond 
+       [(not p) name]
+       [(or (null? p)(eq? (car p) 'car))  `(xxx ,name)]
+       [else (path-error 'flat p)]))))
\ No newline at end of file
diff --git a/collects/lang/private/contracts/intermediate-contracts.ss b/collects/lang/private/contracts/intermediate-contracts.ss
new file mode 100644
index 0000000000..c8f5305d60
--- /dev/null
+++ b/collects/lang/private/contracts/intermediate-contracts.ss
@@ -0,0 +1,76 @@
+(module intermediate-contracts mzscheme
+  
+  (require "hilighters.ss"
+           "contracts-helpers.ss"
+           (lib "etc.ss"))
+  
+  (require (lib "list.ss"))
+  
+  (provide vector-contract 
+           listof-contract 
+           vectorof-contract
+           boxof-contract)
+  
+  (define vector-contract (lambda (stx) (build-flat-contract vector? 'vector stx)))
+
+  (define (somethingof-contract thing enforcer predicate cnt stx) 
+    (if (not (flat-contract? cnt))
+        (error 'contracts "~a contracts can only be created with flat values!" thing)
+        (make-flat-contract
+         enforcer
+         (mk-listof-hilighter (contract-hilighter cnt))
+         (syntax-source stx)
+         (syntax-line stx)
+         (syntax-column stx)
+         (syntax-position stx)
+         (syntax-span stx)
+         predicate)))
+
+  (define (listof-contract cnt stx) 
+    (rec me
+         (somethingof-contract 
+          'listof
+          (lambda (l) 
+            (if (null? l) l
+                (if (pair? l)
+                    (let loop ([list l])  
+                      (catch-contract-error 'car me ((contract-enforcer cnt) (car list)))
+                      (if (null? (cdr list))
+                          l
+                          (loop (cdr list))))
+                    (contract-error l me '()))))
+
+          (lambda (x) (or (null? x) (and (pair? x) (andmap (flat-contract-predicate cnt) x))))
+          cnt
+          stx)))
+  
+  (define (vectorof-contract cnt stx)
+    (rec me
+         (somethingof-contract
+          'vectorof
+          (lambda (v)
+            (if (vector? v)
+                (let loop ([i 0])  
+                  (catch-contract-error 'car me ((contract-enforcer cnt) (vector-ref v i)))
+                  (if (< (+ 1 i) (vector-length v))
+                      (loop (+ i 1))
+                      v))
+                (contract-error v me '())))
+
+          (lambda (x) (and (vector? x) (andmap (flat-contract-predicate cnt) (vector->list x))))
+          cnt 
+          stx)))
+
+  (define (boxof-contract cnt stx)
+    (rec me
+         (somethingof-contract
+          'boxof
+          (lambda (v)
+            (if (box? v)
+                (begin 
+                  (catch-contract-error 'car me ((contract-enforcer cnt) (unbox v)))
+                  v)
+                (contract-error v me '())))
+          (lambda (v) (and (box? v) ((flat-contract-predicate cnt) (unbox v))))
+          cnt
+          stx))))
diff --git a/collects/lang/private/firstorder.ss b/collects/lang/private/firstorder.ss
new file mode 100644
index 0000000000..64aaa4e19f
--- /dev/null
+++ b/collects/lang/private/firstorder.ss
@@ -0,0 +1,19 @@
+(module firstorder mzscheme
+
+  (provide make-first-order
+	   first-order->higher-order)
+
+  (define-values (struct:fo make-first-order fo? fo-get fo-set!)
+    (make-struct-type 'procedure #f 2 0 #f null (current-inspector) 0))  
+
+  (define fo-proc-id (make-struct-field-accessor fo-get 1))
+
+  (define (first-order->higher-order id)
+    (let ([v (syntax-local-value id (lambda () #f))])
+      (if (and (set!-transformer? v)
+	       (fo? (set!-transformer-procedure v)))
+	  (syntax-local-introduce 
+	   (fo-proc-id (set!-transformer-procedure v)))
+	  id))))
+
+
diff --git a/collects/lang/private/imageeq.ss b/collects/lang/private/imageeq.ss
new file mode 100644
index 0000000000..200d554cfc
--- /dev/null
+++ b/collects/lang/private/imageeq.ss
@@ -0,0 +1,131 @@
+(module imageeq mzscheme
+  (require (lib "mred.ss" "mred")
+           (lib "cache-image-snip.ss" "mrlib")
+           (lib "class.ss"))
+  
+  (provide image? image=? 
+           coerce-to-cache-image-snip
+           snip-size
+           bitmaps->cache-image-snip)
+
+  (define (image? a)
+    (or (is-a? a image-snip%)
+        (is-a? a cache-image-snip%)))
+  
+  (define (snip-size a)
+    (cond
+      [(is-a? a cache-image-snip%)
+       (send a get-size)]
+      [else
+       (let ([dc (make-object bitmap-dc% (make-object bitmap% 1 1))]
+             [wb (box 0)]
+             [hb (box 0)])
+         (send a get-extent dc 0 0 wb hb #f #f #f #f)
+         (values (unbox wb) 
+                 (unbox hb)))]))
+         
+  (define (image=? a-raw b-raw)
+    (unless (image? a-raw) (raise-type-error 'image=? "image" 0 a-raw b-raw))
+    (unless (image? b-raw) (raise-type-error 'image=? "image" 1 a-raw b-raw))
+    (let ([a (coerce-to-cache-image-snip a-raw)]
+          [b (coerce-to-cache-image-snip b-raw)])
+      (let-values ([(aw ah) (snip-size a)]
+                   [(bw bh) (snip-size b)])
+        (and (= aw bw)
+             (= ah bh)
+             (same/alpha? (argb-vector (send a get-argb))
+                          (argb-vector (send b get-argb)))))))
+  
+  (define (same/alpha? v1 v2)
+    (let loop ([i (vector-length v1)])
+      (or (zero? i)
+          (let ([a1 (vector-ref v1 (- i 4))]
+                [a2 (vector-ref v2 (- i 4))])
+            (and (or (= a1 a2 255)
+                     (and (= a1 a2)
+                          (= (vector-ref v1 (- i 3)) (vector-ref v2 (- i 3)))
+                          (= (vector-ref v1 (- i 2)) (vector-ref v2 (- i 2)))
+                          (= (vector-ref v1 (- i 1)) (vector-ref v2 (- i 1)))))
+                 (loop (- i 4)))))))
+  
+    ;; coerce-to-cache-image-snip : image -> (is-a?/c cache-image-snip%)
+  (define (coerce-to-cache-image-snip snp)
+    (cond
+      [(is-a? snp image-snip%)
+       (let ([bmp (send snp get-bitmap)])
+         (if bmp
+             (let ([bmp-mask (or (send bmp get-loaded-mask)
+                                 (send snp get-bitmap-mask)
+                                 (bitmap->mask bmp))])
+               (bitmaps->cache-image-snip (copy-bitmap bmp)
+                                          (copy-bitmap bmp-mask)
+                                          (floor (/ (send bmp get-width) 2))
+                                          (floor (/ (send bmp get-height) 2))))
+             (let-values ([(w h) (snip-size snp)])
+               (let* ([bmp (make-object bitmap% 
+                             (inexact->exact (floor w))
+                             (inexact->exact (floor h)))]
+                      [bdc (make-object bitmap-dc% bmp)])
+                 (send snp draw bdc 0 0 0 0 w h 0 0 'no-caret)
+                 (send bdc set-bitmap #f)
+                 (bitmaps->cache-image-snip bmp 
+                                            (bitmap->mask bmp)
+                                            (floor (/ w 2))
+                                            (floor (/ h 2)))))))]
+      [else snp]))
+    
+  ;; copy-bitmap : bitmap -> bitmap
+  ;; does not copy the mask.
+  (define (copy-bitmap bitmap)
+    (let* ([w (send bitmap get-width)]
+           [h (send bitmap get-height)]
+           [copy (make-object bitmap% w h)]
+           [a-dc (make-object bitmap-dc% copy)])
+      (send a-dc clear)
+      (send a-dc draw-bitmap bitmap 0 0)
+      (send a-dc set-bitmap #f)
+      copy))
+  
+  ;; bitmap->mask : bitmap -> bitmap
+  (define (bitmap->mask bitmap)
+    (let* ([w (send bitmap get-width)]
+           [h (send bitmap get-height)]
+           [s (make-bytes (* 4 w h))]
+           [new-bitmap (make-object bitmap% w h)]
+           [dc (make-object bitmap-dc% new-bitmap)])
+      (send dc clear)
+      (send dc draw-bitmap bitmap 0 0)
+      (send dc get-argb-pixels 0 0 w h s)
+      (let loop ([i (* 4 w h)])
+        (unless (zero? i)
+          (let ([r (- i 3)]
+                [g (- i 2)]
+                [b (- i 1)])
+            (unless (and (eq? 255 (bytes-ref s r))
+                         (eq? 255 (bytes-ref s g))
+                         (eq? 255 (bytes-ref s b)))
+              (bytes-set! s r 0)
+              (bytes-set! s g 0)
+              (bytes-set! s b 0))
+            (loop (- i 4)))))
+      (send dc set-argb-pixels 0 0 w h s)
+      (begin0
+        (send dc get-bitmap)
+        (send dc set-bitmap #f))))
+  
+  (define (bitmaps->cache-image-snip color mask px py)
+    (let ([w (send color get-width)]
+          [h (send color get-height)])
+      (new cache-image-snip%
+           [width w]
+           [height h]
+           [dc-proc
+            (lambda (dc dx dy)
+              (send dc draw-bitmap color dx dy 'solid 
+                    (send the-color-database find-color "black")
+                    mask))]
+           [argb-proc
+            (lambda (argb-vector dx dy)
+              (overlay-bitmap argb-vector dx dy color mask))]
+           [px px]
+           [py py]))))
diff --git a/collects/lang/private/info.ss b/collects/lang/private/info.ss
new file mode 100644
index 0000000000..5f7cddcb6a
--- /dev/null
+++ b/collects/lang/private/info.ss
@@ -0,0 +1,3 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "HtDP Languages Private"))
+
diff --git a/collects/lang/private/teach.ss b/collects/lang/private/teach.ss
new file mode 100644
index 0000000000..fd36528c2a
--- /dev/null
+++ b/collects/lang/private/teach.ss
@@ -0,0 +1,2076 @@
+
+;; Implements the Teaching languages, at least in terms of the
+;; forms. The reader-level aspects of the language (e.g.,
+;; case-sensitivity) are not implemented here, and the procedures are
+;; in a separate module. Also, the "reference to uninitialized module
+;; identifier" message must be replaced with an "identifier used before
+;; its definition was evaluated" error that omits the name.
+
+;; To a first approximation, this module is one big error-checking
+;; routine. In other words, most of the syntax implementations are
+;; straightforward, but error-checking is complex.
+
+;; Error-message conventions:
+;;  - Report errors, somewhat anthropomorphically, in terms of "expected"
+;;    versus "found" syntax.
+;;  - Report errors according to a left-to-right reading; e.g., the
+;;    error in `(define 1 2 3)' is "expected an identifier, found 1",
+;;    not "expected two parts after `define', but found three".
+;;  - Left-to-right reporting sometimes requires an explicit expression
+;;    check (via `local-expand') before reporting some other error. For
+;;    example, in the expression (define (f x) + 1 2), the reported
+;;    error should be for a misuse of "+", not that there are two extra
+;;    parts in the definition. Avoid using `local-expand' if there's
+;;    no error, however.
+
+(module teach mzscheme
+  (require (lib "etc.ss")
+	   (lib "list.ss")
+	   (lib "math.ss"))
+  (require-for-syntax "teachhelp.ss"
+		      (lib "kerncase.ss" "syntax")
+		      (lib "stx.ss" "syntax")
+		      (lib "struct.ss" "syntax")
+		      (lib "context.ss" "syntax")
+		      (lib "include.ss"))
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; run-time helpers
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  ;; verify-boolean is inserted to check for boolean results:
+  (define (verify-boolean b where)
+    (if (or (eq? b #t) (eq? b #f))
+	b
+	(raise
+	 (make-exn:fail:contract
+	  (string->immutable-string
+	   (format "~a: question result is not true or false: ~e" where b))
+	  (current-continuation-marks)))))
+
+  ;; Wrapped around uses of local-bound variables:
+  (define (check-not-undefined name val)
+    (if (eq? val undefined)
+	(raise
+	 (make-exn:fail:contract:variable
+	  (string->immutable-string
+	   (format "local variable used before its definition: ~a" name))
+	  (current-continuation-marks)
+	  name))
+	val))
+  (define undefined (letrec ([x x]) x))
+
+  ;; Wrapped around top-level definitions to disallow re-definition:
+  (define (check-top-level-not-defined who id)
+    (when (let ([b (identifier-binding id)])
+	    ;; if it's not top-level, raise an exn
+	    (if b
+		#t
+		;; At top-level, might be bound to syntax or value:
+		(with-handlers ([exn:fail:contract:variable? (lambda (exn) #f)]
+				[exn:fail:syntax? (lambda (exn) #t)])
+		  (namespace-variable-value (syntax-e id) #t)
+		  #t)))
+      (error who "cannot redefine name: ~a" (syntax-e id))))
+
+  ;; For quasiquote and shared:
+  (require (rename "teachprims.ss" the-cons advanced-cons))
+  (require (rename "teachprims.ss" cyclic-list? cyclic-list?))
+
+  ;; Referenced to ensure that evaluating `lambda' always
+  ;; produces a new closure (instead of using a closure
+  ;; that's allocated once)
+  (define make-lambda-generative 5)
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; syntax implementations
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (define-syntax define-syntax-set/provide
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ (id ...) defn ...)
+	 (with-syntax ([(plain-id ...)
+			(map (lambda (id)
+			       (if (identifier? id)
+				   id
+				   (stx-car (stx-cdr id))))
+			     (syntax->list (syntax (id ...))))]
+		       [provided-identifiers
+			(datum->syntax-object stx 'provided-identifiers)])
+	   (syntax
+	    (begin
+	      (provide plain-id ...)
+	      (define-syntax-set (id ...) 
+		(define provided-identifiers (quote-syntax (id ...)))
+		defn ...))))])))
+
+  ;; The implementation of form X is defined below as X/proc. The
+  ;; reason for this is to allow the implementation of Y to re-use the
+  ;; implementation of X (expanding to a use of X would mangle syntax
+  ;; error messages), while preserving the binding of X as the one for
+  ;; the syntax definition (so that quasiquote can regonzie unquote,
+  ;; etc.).
+
+  (define-syntax-set/provide (beginner-define
+			      beginner-define-struct
+			      beginner-lambda
+			      beginner-app     beginner-app-continue
+			      beginner-top     beginner-top-continue
+			      beginner-cond
+			      beginner-else
+			      beginner-if
+			      beginner-and
+			      beginner-or
+			      beginner-quote
+			      
+			      intermediate-define
+			      intermediate-define-struct
+			      intermediate-local
+			      intermediate-letrec
+			      intermediate-let
+			      intermediate-let*
+			      intermediate-recur
+			      intermediate-lambda
+			      intermediate-app
+			      intermediate-quote
+			      intermediate-quasiquote
+			      intermediate-unquote
+			      intermediate-unquote-splicing
+			      intermediate-time
+
+			      advanced-define
+			      advanced-lambda
+			      advanced-app
+			      advanced-set!  advanced-set!-continue
+			      advanced-when
+			      advanced-unless
+			      advanced-define-struct
+			      advanced-let
+			      advanced-recur
+			      advanced-begin
+			      advanced-begin0
+			      advanced-case
+			      advanced-shared
+			      advanced-delay)
+
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    ;; compile-time helpers
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+    ;; Raise a syntax error:
+    (define (teach-syntax-error form stx detail msg . args)
+      (let ([form (if (eq? form '|function call|)
+		      form
+		      #f)] ; extract name from stx
+	    [msg (apply format msg args)])
+	(if detail
+	    (raise-syntax-error form msg stx detail)
+	    (raise-syntax-error form msg stx))))
+    
+    ;; The syntax error when a form's name doesn't follow a "("
+    (define (bad-use-error name stx)
+      (teach-syntax-error
+       name
+       stx
+       #f
+       "found a use of `~a' that does not follow an open parenthesis"
+       name))
+
+    ;; Use for messages "expected ..., found <something else>"
+    (define (something-else v)
+      (let ([v (syntax-e v)])
+	(cond
+	 [(number? v) "a number"]
+	 [(string? v) "a string"]
+	 [else "something else"])))
+    
+    (define (ordinal n)
+      (cond
+       [(or (<= 11 n 13)
+	    (zero? (modulo n 10))
+	    (<= 4 (modulo n 10) 9))
+	(format "~ath" n)]
+       [(= 1 (modulo n 10))
+	(format "~ast" n)]
+       [(= 2 (modulo n 10))
+	(format "~and" n)]
+       [(= 3 (modulo n 10))
+	(format "~ard" n)]))
+
+    ;; At the top level, wrap `defn' to first check for
+    ;; existing definitions of the `names'. The `names'
+    ;; argument is a syntax list of identifiers.
+    (define (check-definitions-new who stx names defn)
+      (cond
+       [(eq? (syntax-local-context) 'top-level)
+	(with-syntax ([defn defn]
+		      [who who])
+	  (with-syntax ([(check ...)
+			 (map (lambda (name)
+				(with-syntax ([name name])
+				  ;; Make sure each check has the
+				  ;; source location of the original
+				  ;; expression:
+				  (syntax/loc stx
+				    (check-top-level-not-defined 'who #'name))))
+			      (stx->list names))])
+	    (syntax-property
+	     (syntax/loc stx
+	       (begin
+		 check ...
+		 defn))
+	     'stepper-skipto
+	     (list syntax-e cdr syntax-e cdr car))))]
+       [(eq? (syntax-local-context) 'module)
+	(for-each (lambda (name)
+		    (let ([b (identifier-binding name)])
+		      (when b
+			(teach-syntax-error
+			 'duplicate
+			 name
+			 #f
+			 (if (binding-in-this-module? b)
+			     "this name was defined previously and cannot be re-defined"
+			     "this name has a built-in meaning and cannot be re-defined")))))
+		  names)
+	defn]
+       [else defn]))
+
+    ;; Same as above, but for one name
+    (define (check-definition-new who stx name defn)
+      (check-definitions-new who stx (list name) defn))
+
+    (define (binding-in-this-module? b)
+      (and (list? b)
+	   (module-path-index? (car b))
+	   (let-values ([(path base) (module-path-index-split (car b))])
+	     (and (not path) (not base)))))
+    
+    ;; Check context for a `define' before even trying to
+    ;; expand
+    (define-struct expanding-for-intermediate-local ())
+    (define (ok-definition-context)
+      (let ([ctx (syntax-local-context)])
+	(or (memq ctx '(top-level module module-begin))
+	    (and (pair? ctx)
+		 (expanding-for-intermediate-local? (car ctx))))))
+
+    ;; Use to generate nicer error messages than direct pattern
+    ;; matching. The `where' argument is an English description
+    ;; of the portion of the larger expression where a single
+    ;; sub-expression was expected.
+    (define (check-single-expression who where stx exprs will-bind)
+      (when (null? exprs)
+	(teach-syntax-error
+	 who
+	 stx
+	 #f
+	 "expected an expression ~a, but nothing's there"
+	 where))
+      (unless (null? (cdr exprs))
+	;; In case it's erroneous, to ensure left-to-right reading, let's
+	;;  try expanding the first expression. We have to use
+	;;  `will-bind' to avoid errors for unbound ids that will actually
+	;;  be bound. Since they're used as stopping points, we may miss
+	;;  some errors after all. It's worth a try, though. We also
+	;;  have to stop at advanced-set!, in case it's used with
+	;;  one of the identifiers in will-bind.
+	(when will-bind
+	  (local-expand (car exprs) 'expression (cons #'advanced-set!
+						      will-bind)))
+	;; First expression seems ok, report an error for 2nd and later:
+	(teach-syntax-error
+	 who
+	 stx
+	 (cadr exprs)
+	 "expected only one expression ~a, but found ~a extra part"
+	 where
+	 (if (null? (cddr exprs))
+	     "one"
+	     "at least one"))))
+
+    (define (check-single-result-expr exprs where enclosing-expr will-bind)
+      (check-single-expression where
+			       "for the function body"
+			       enclosing-expr
+			       exprs
+			       will-bind))
+
+    (define keyword-list
+      (append (syntax->list provided-identifiers)
+	      (syntax->list (quote-syntax 
+			     (#%datum
+			      #%top
+			      empty true false)))))
+
+    (define (identifier/non-kw? stx)
+      (and (identifier? stx)
+	   (not (ormap (lambda (x) (module-identifier=? stx x))
+		       keyword-list))))
+
+    (define (something-else/kw stx)
+      (if (identifier? stx)
+	  "a keyword"
+	  (something-else stx)))
+
+    (define (make-name-inventer)
+      ;; Normally we'd use (make-syntax-introducer) because gensyming makes
+      ;;  identifiers that play badly with exporting. But we don't have
+      ;;  to worry about exporting in the teaching languages, while we do
+      ;;  have to worry about mangled names.
+      (lambda (id)
+	(datum->syntax-object id 
+			      (string->uninterned-symbol (symbol->string (syntax-e id)))
+			      id)))
+
+    (define (wrap-func-definitions first-order? kinds names argcs k)
+      (if first-order?
+	  (let ([name2s (map (make-name-inventer) names)])
+	    (quasisyntax
+	     (begin
+	       #,@(map
+		   (lambda (name name2 kind argc)
+		     #`(define-syntax #,name 
+			 (make-first-order-function '#,kind 
+						    #,argc
+						    (quote-syntax #,name2) 
+						    (quote-syntax #%app))))
+		   names name2s kinds argcs)
+	       #,(k name2s))))
+	  (k names)))
+
+      
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    ;; define (beginner)
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+    (define (beginner-or-intermediate-define/proc first-order? stx)
+
+      (define (wrap-func-definition name argc k)
+	(wrap-func-definitions first-order? 
+			       '(procedure) (list name) (list argc)
+			       (lambda (names)
+				 (k (car names)))))
+
+      (define (check-function-defn-ok stx)
+	(when first-order?
+	  (when (eq? 'top-level (syntax-local-context))
+	    (teach-syntax-error
+	     'define
+	     stx
+	     #f
+	     "function definitions are not allowed in the interactions window; ~
+              they must be in the definitions window"))))
+
+      (unless (or (ok-definition-context)
+		  (identifier? stx))
+	(teach-syntax-error
+	 'define
+	 stx
+	 #f
+	 "found a definition that is not at the top level"))
+
+      (syntax-case stx ()
+	;; Constant or lambda def:
+	[(_ name expr)
+	 (identifier/non-kw? (syntax name))
+	 (let ([lam (syntax expr)])
+	   (check-defined-lambda lam)
+	   (syntax-case (syntax expr) (beginner-lambda)
+	     ;; Well-formed lambda def:
+	     [(beginner-lambda arg-seq lexpr ...)
+	      (begin
+		(check-function-defn-ok stx)
+		(check-definition-new
+		 'define
+		 stx
+		 #'name
+		 (wrap-func-definition
+		  #'name
+		  (length (syntax->list #'arg-seq))
+		  (lambda (name)
+		    (with-syntax ([name name])
+		      (quasisyntax/loc 
+		       stx 
+		       (define name
+			 #,(syntax-property
+			    #`(lambda arg-seq #,(syntax-property #`make-lambda-generative 'stepper-skip-completely #t) lexpr ...)
+			    'stepper-define-type
+			    'lambda-define))))))))]
+	     ;; Constant def
+	     [_else
+              (check-definition-new
+                'define
+                stx
+                (syntax name)
+                (quasisyntax/loc stx (define name expr)))]))]
+	;; Function definition:
+	[(_ name-seq expr ...)
+	 (syntax-case (syntax name-seq) () [(name ...) #t][_else #f])
+	 ;; name-seq is at least a sequence
+	 (let ([names (syntax->list (syntax name-seq))])
+	   (check-function-defn-ok stx)
+	   (when (null? names)
+	     (teach-syntax-error
+	      'define
+	      stx
+	      names
+	      "expected a function name for a definition, but the name is missing"))
+	   (let loop ([names names][pos 0])
+	     (unless (null? names)
+	       (unless (identifier/non-kw? (car names))
+		 (teach-syntax-error
+		  'define
+		  stx
+		  (car names)
+		  "expected a name for ~a, but found ~a"
+		  (cond
+		   [(zero? pos) "a function"]
+		   [else (format "the function's ~a argument" (ordinal pos))])
+		  (something-else/kw (car names))))
+	       (loop (cdr names) (add1 pos))))
+	   (when (null? (cdr names))
+	     (teach-syntax-error
+	      'define
+	      stx
+	      (syntax name-seq)
+	      "expected at least one argument name after the function name, but found none"))
+	   (let ([dup (check-duplicate-identifier (cdr names))])
+	     (when dup
+	       (teach-syntax-error
+		'define
+		stx
+		dup
+		"found an argument name that was used more than once: ~a"
+		(syntax-e dup))))
+	   (check-single-result-expr (syntax->list (syntax (expr ...)))
+				     #f
+				     stx
+				     names)
+	   
+           (check-definition-new 
+            'define
+            stx
+            (car names)
+	    (wrap-func-definition
+	     (car (syntax-e #'name-seq))
+	     (length (cdr (syntax->list #'name-seq)))
+	     (lambda (fn)
+	       (with-syntax ([fn fn]
+			     [args (cdr (syntax-e #'name-seq))])
+		 (quasisyntax/loc stx (define fn #,(syntax-property
+						    (syntax-property
+						     #`(lambda args expr ...)
+						     'stepper-define-type
+						     'shortened-proc-define)
+						    'stepper-proc-define-name
+						    #`fn))))))))]
+	;; Constant/lambda with too many or too few parts:
+	[(_ name expr ...)
+	 (identifier/non-kw? (syntax name))
+	 (let ([exprs (syntax->list (syntax (expr ...)))])
+	   (check-single-expression 'define
+				    (format "after the defined name ~a"
+					    (syntax-e (syntax name)))
+				    stx
+				    exprs
+				    (list (syntax name))))]
+	;; Bad name/header:
+	[(_ non-name expr ...)
+	 (teach-syntax-error
+	  'define
+	  stx
+	  (syntax non-name)
+	  "expected a function name, constant name, or function header for `define', but found ~a"
+	  (something-else/kw (syntax non-name)))]
+	;; Missing name:
+	[(_)
+	 (teach-syntax-error
+	  'define
+	  stx
+	  #f
+	  "expected a function name, constant name, or function header after `define', ~
+         but nothing's there")]
+	[_else
+	 (bad-use-error 'define stx)]))
+
+    (define (beginner-define/proc stx)
+      (beginner-or-intermediate-define/proc #t stx))
+
+    (define (intermediate-define/proc stx)
+      (beginner-or-intermediate-define/proc #f stx))
+
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    ;; lambda (beginner; only works with define)
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+    (define (beginner-lambda/proc stx)
+      (syntax-case stx ()
+	[(_ . rest)
+	 (teach-syntax-error
+	  'lambda
+	  stx
+	  #f
+	  "found a `lambda' expression that is not a function definition")]
+	[_else
+	 (bad-use-error 'lambda stx)]))
+
+
+    (define (check-defined-lambda lam)
+      (syntax-case lam (beginner-lambda)
+	[(beginner-lambda arg-seq lexpr ...)
+	 (syntax-case (syntax arg-seq) () [(arg ...) #t][_else #f])
+	 (let ([args (syntax->list (syntax arg-seq))])
+	   (for-each (lambda (arg)
+		       (unless (identifier/non-kw? arg)
+			 (teach-syntax-error
+			  'lambda
+			  lam
+			  arg
+			  "expected a name for a function argument, but found ~a"
+			  (something-else/kw arg))))
+		     args)
+	   (when (null? args)
+	     (teach-syntax-error
+	      'lambda
+	      lam
+	      (syntax arg-seq)
+	      "expected at least one argument name in the sequence after `lambda', but found none"))
+	   (let ([dup (check-duplicate-identifier args)])
+	     (when dup
+	       (teach-syntax-error
+		'lambda
+		lam
+		dup
+		"found an argument name that was used more than once: ~a"
+		(syntax-e dup))))
+	   (check-single-result-expr (syntax->list (syntax (lexpr ...)))
+				     #f
+				     lam
+				     args)
+	   'ok)]
+	;; Bad lambda because bad args:
+	[(beginner-lambda args . _)
+	 (teach-syntax-error
+	  'lambda
+	  lam
+	  (syntax args)
+	  "expected a sequence of function arguments after `lambda', but found ~a"
+	  (something-else (syntax args)))]
+	;; Bad lambda, no args:
+	[(beginner-lambda)
+	 (teach-syntax-error
+	  'lambda
+	  lam
+	  (syntax args)
+	  "expected a sequence of function arguments after `lambda', but nothing's there")]
+	[_else 'ok]))
+
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    ;; define-struct (beginner)
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    
+    (define (do-define-struct stx first-order? setters? struct-info-is-useful?)
+      
+      (unless (or (ok-definition-context)
+		  (identifier? stx))
+	(teach-syntax-error
+	 'define-struct
+	 stx
+	 #f
+	 "found a definition that is not at the top level"))
+      
+      (syntax-case stx ()
+	;; First, check for a struct name:
+	[(_ name . __)
+	 (not (identifier/non-kw? (syntax name)))
+	 (teach-syntax-error
+	  'define-struct
+	  stx
+	  (syntax name)
+	  "expected a structure type name after `define-struct', but found ~a"
+	  (something-else/kw (syntax name)))]
+	;; Main case (`rest' is for nice error messages):
+	[(_ name_ (field_ ...) . rest)
+	 (let ([name (syntax name_)]
+	       [fields (syntax->list (syntax (field_ ...)))]
+	       [ht (make-hash-table)])
+	   (for-each
+	    (lambda (field)
+	      (unless (identifier? field)
+		(teach-syntax-error
+		 'define-struct
+		 stx
+		 field
+		 "expected a structure field name, found ~a"
+		 (something-else field)))
+	      (let ([sym (syntax-e field)])
+		(when (hash-table-get ht sym (lambda () #f))
+		  (teach-syntax-error
+		   'define-struct
+		   stx
+		   field
+		   "found a field name that was used more than once: ~a"
+		   sym))
+		(hash-table-put! ht sym #t)))
+	    fields)
+	   (let ([rest (syntax->list (syntax rest))])
+	     (unless (null? rest)
+	       (teach-syntax-error
+		'define-struct
+		stx
+		(car rest)
+		"expected nothing after the field name sequence in `define-struct', ~
+               but found ~a extra part"
+		(if (null? (cdr rest))
+		    "one"
+		    "at least one"))))
+	   (let* ([to-define-names (let ([l (build-struct-names name fields #f (not setters?) stx)])
+				     (if struct-info-is-useful?
+					 ;; All names:
+					 l
+					 ;; Skip `struct:' name:
+					 (cdr l)))]
+		  [proc-names (if struct-info-is-useful?
+				  (cdr to-define-names)
+				  to-define-names)])
+	     (with-syntax ([compile-info (if struct-info-is-useful?
+					     (build-struct-expand-info name fields #f (not setters?) #t null null)
+					     (syntax
+					      (lambda (stx)
+						(raise-syntax-error
+						 #f
+						 "expected an expression, but found a structure name"
+						 stx))))])
+	       (let ([defn
+                      (quasisyntax/loc stx
+			 (begin
+                           #,(syntax-property #`(define-syntaxes (name_) compile-info)
+                                              'stepper-skip-completely
+                                              #t)
+			   #,(wrap-func-definitions 
+			      first-order? 
+			      (list* 'constructor 
+				     'predicate
+				     (map (lambda (x) 'selector) (cddr proc-names)))
+			      proc-names
+			      (list* (- (length proc-names) 2)
+				     1
+				     (map (lambda (x) 1) (cddr proc-names)))
+			      (lambda (def-proc-names)
+				(with-syntax ([(def-proc-name ...) def-proc-names]
+					      [(proc-name ...) proc-names])
+				  (syntax-property #`(define-values (def-proc-name ...)
+						       (let ()
+							 (define-struct name_ (field_ ...) (make-inspector))
+							 (values proc-name ...)))
+						   'stepper-define-struct-hint
+						   stx))))))])
+                 (check-definitions-new 'define-struct
+                                        stx 
+					(cons #'name_ to-define-names)
+					defn)))))]
+	[(_ name_ something . rest)
+	 (teach-syntax-error
+	  'define-struct
+	  stx
+	  (syntax something)
+	  "expected a sequence of field names after the structure type name in `define-struct', ~
+         but found ~a"
+	  (something-else (syntax something)))]
+	[(_ name_)
+	 (teach-syntax-error
+	  'define-struct
+	  stx
+	  (syntax something)
+	  "expected a sequence of field names after the structure type name in `define-struct', ~
+         but nothing's there")]
+	[(_)
+	 (teach-syntax-error
+	  'define-struct
+	  stx
+	  #f
+	  "expected a structure type name after `define-struct', but nothing's there")]
+	[_else (bad-use-error 'define-struct stx)]))
+
+    (define (beginner-define-struct/proc stx)
+      (do-define-struct stx #t #f #t))
+
+    (define (intermediate-define-struct/proc stx)
+      (do-define-struct stx #f #f #t))
+
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    ;; application (beginner and intermediate)
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+    ;; For beginner:
+
+    ;; #%app should never happen in beginner. Primitive operations and
+    ;; defined functions turn into syntax that handle application
+    ;; forms.  The only vaguely legitimate application would involve a
+    ;; poorly implemented teachpack that exports functions instead of
+    ;; primitive operators. Also, #%app is unavoidable in the REPL.
+
+    ;; An #%app might happen "temporarily" if it appears at the top
+    ;; level before the corresponding function definition. To provide
+    ;; a good error message, we need to wait, and that's what
+    ;; beginner-app-delay does.
+
+    ;; For intermediate:
+
+    ;; This application form disallows rator expressions that aren't
+    ;; top-level identifiers or of the form `(check-not-undefined ...)'.
+
+    ;; The latter is probably surprising. It turns out that every use of
+    ;; a `local'-bound identifier gets converted to an undefined check,
+    ;; and the call to `check-not-undefined' can't be forged by the
+    ;; programmer. So the pattern-match effectively recognizes uses of
+    ;; `local'-bound identifiers, which are legal as rator
+    ;; expressions. (`let' and `letrec' get converted to `local'.)
+
+    (define-values (beginner-app/proc intermediate-app/proc)
+      (let ([mk-app
+	     (lambda (lex-ok?)
+	       (lambda (stx)
+		 (syntax-case stx ()
+		   [(_ rator rand ...)
+		    (let* ([fun (syntax rator)]
+			   [undef-check? (syntax-case fun (check-not-undefined)
+					   [(check-not-undefined id)
+					    #t]
+					   [_else #f])]
+			   [binding (and (identifier? fun)
+					 (identifier-binding fun))]
+			   [lex? (eq? 'lexical binding)]
+			   [bad-app (lambda (what)
+				      (teach-syntax-error
+				       '|function call|
+					 stx
+					 fun
+					 "expected a ~a after an open parenthesis, but found ~a"
+					 (if lex-ok?
+					     "name"
+					     "defined name or a primitive operation name")
+					 what))])
+		      (unless (and (identifier? fun) (or lex-ok? undef-check? (not lex?)))
+			(bad-app (if lex?
+				     "a function argument name"
+				     (something-else fun))))
+		      ;; The following check disallows calling thunks.
+		      ;; It's disabled because we need to allow calls to
+		      ;; primitive thunks.
+		      '(when (null? (syntax->list (syntax (rand ...))))
+			 (teach-syntax-error
+			  '|function call|
+			    stx
+			    #f
+			    "expected an argument after the function name for a function call, ~
+                             but nothing's there"))
+		      (cond
+		       [(and (not lex-ok?) (binding-in-this-module? binding))
+			;; An application of something defined as a constant
+			(bad-app "something else")]
+		       [(or lex-ok? (and binding (not (binding-in-this-module? binding))))
+			(syntax/loc stx (#%app rator rand ...))]
+		       [else
+			;; We don't know what rator is, yet, and it might be local:
+			(quasisyntax/loc 
+			 stx 
+			 (#%app values #,(quasisyntax/loc
+					  stx
+					  (beginner-app-continue rator rand ...))))]))]
+		   [(_)
+		    (teach-syntax-error
+		     '|function call|
+		       stx
+		       #f
+		       (format
+			"expected a ~a after an open parenthesis, but nothing's there"
+			(if lex-ok?
+			    "name"
+			    "defined name or a primitive operation name")))]
+		   [_else (bad-use-error '#%app stx)])))])
+	(values (mk-app #f) (mk-app #t))))
+
+    (define (beginner-app-continue/proc stx)
+      (syntax-case stx ()
+	[(_ rator rand ...)
+	 (let* ([fun #'rator]
+		[binding (identifier-binding fun)])
+	   (if binding
+	       ;; Now defined in the module:
+	       (if (set!-transformer? (syntax-local-value fun (lambda () #f)))
+		   ;; Something that takes care of itself:
+		   (syntax/loc stx (rator rand ...))
+		   ;; Something for which we probably need to report an error,
+		   ;;  but let beginner-app take care of it:
+		   (syntax/loc stx (beginner-app rator rand ...)))
+	       ;; Something undefined; let beginner-top take care of it:
+	       (syntax/loc stx (#%app rator rand ...))))]))
+
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    ;; top-level variables (beginner)
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+    ;; Report errors for undefined names (but only in modules)
+
+    (define (beginner-top/proc stx)
+      (syntax-case stx ()
+        [(_ . id)
+	 ;; If we're in a module, we'll need to check that the name
+	 ;;  is bound....
+	 (if (and (not (identifier-binding #'id))
+		  (syntax-source-module #'id))
+	     ;; ... but it might be defined later in the module, so
+	     ;; delay the check.
+	     (syntax/loc stx (#%app values (beginner-top-continue id)))
+	     (syntax/loc stx (#%top . id)))]))
+
+    (define (beginner-top-continue/proc stx)
+      (syntax-case stx ()
+        [(_ id)
+	 ;; If there's still no binding, it's an "unknown name" error.
+	 (if (not (identifier-binding #'id))
+	     (teach-syntax-error
+	      'unknown
+	      #'id
+	      #f
+	      "name is not defined, not an argument, and not a primitive name")
+	     ;; Don't use #%top here; id might have become bound to something
+	     ;;  that isn't a value.
+	     #'id)]))
+
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    ;; cond
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+    (define (beginner-cond/proc stx)
+      (syntax-case stx ()
+	[(_)
+	 (teach-syntax-error
+	  'cond
+	  stx
+	  #f
+	  "expected a question--answer clause after `cond', but nothing's there")]
+	[(_ clause ...)
+	 (let* ([clauses (syntax->list (syntax (clause ...)))]
+		[check-preceding-exprs
+		 (lambda (stop-before)
+		   (let/ec k
+		     (for-each (lambda (clause)
+				 (if (eq? clause stop-before)
+				     (k #t)
+				     (syntax-case clause ()
+				       [(question answer)
+					(begin
+					  (unless (and (identifier? (syntax question))
+						       (module-identifier=? (syntax question) #'beginner-else))
+					    (local-expand (syntax question) 'expression null))
+					  (local-expand (syntax answer) 'expression null))])))
+			       clauses)))])
+	   (let ([checked-clauses
+		  (map
+		   (lambda (clause)
+		     (syntax-case clause (beginner-else)
+		       [(beginner-else answer)
+			(let ([lpos (memq clause clauses)])
+			  (when (not (null? (cdr lpos)))
+			    (teach-syntax-error
+			     'cond
+			     stx
+			     clause
+			     "found an `else' clause that isn't the last clause ~
+                                    in its `cond' expression"))
+                          (with-syntax ([new-test (syntax-property (syntax #t) 'stepper-else #t)])
+                            (syntax/loc clause (new-test answer))))]
+		       [(question answer)
+                        (with-syntax ([verified (syntax-property (syntax (verify-boolean question 'cond)) 
+								 'stepper-skipto 
+								 (list syntax-e cdr syntax-e cdr car))])
+                          (syntax/loc clause (verified answer)))]
+		       [()
+			(check-preceding-exprs clause)
+			(teach-syntax-error
+			 'cond
+			 stx
+			 clause
+			 "expected a question--answer clause, but found an empty clause")]
+		       [(question?)
+			(check-preceding-exprs clause)
+			(teach-syntax-error
+			 'cond
+			 stx
+			 clause
+			 "expected a clause with a question and answer, but found a clause with only one part")]
+		       [(question? answer? ...)
+			(check-preceding-exprs clause)
+			(let ([parts (syntax->list clause)])
+			  ;; to ensure the illusion of left-to-right checking, make sure 
+			  ;; the question and first answer (if any) are ok:
+			  (unless (and (identifier? (car parts))
+				       (module-identifier=? (car parts) #'beginner-else))
+			    (local-expand (car parts) 'expression null))
+			  (unless (null? (cdr parts))
+			    (local-expand (cadr parts) 'expression null))
+			  ;; question and answer (if any) are ok, raise a count-based exception:
+			  (teach-syntax-error
+			   'cond
+			   stx
+			   clause
+			   "expected a clause with one question and one answer, but found a clause with ~a parts"
+			   (length parts)))]
+		       [_else
+			(teach-syntax-error
+			 'cond
+			 stx
+			 clause
+			 "expected a question--answer clause, but found ~a"
+			 (something-else clause))]))
+		   clauses)])
+             ;; Add `else' clause for error (always):
+             (let ([clauses (append checked-clauses 
+                                    (list 
+                                     (with-syntax ([error-call (syntax/loc stx (error 'cond "all question results were false"))])
+                                       (syntax [else error-call]))))])
+	       (with-syntax ([clauses clauses])
+		 (syntax/loc stx (cond . clauses))))))]
+	[_else (bad-use-error 'cond stx)]))
+
+    (define beginner-else/proc
+      (make-set!-transformer
+       (lambda (stx)
+	 (define (bad expr)
+	   (teach-syntax-error
+	    'else
+	    expr
+	    #f
+	    "not allowed here, because this is not an immediate question in a `cond' clause"))
+	 (syntax-case stx (set! x)
+	   [(set! e expr) (bad #'e)]
+	   [(e . expr) (bad #'e)]
+	   [e (bad stx)]))))
+
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    ;; if
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+    (define (beginner-if/proc stx)
+      (syntax-case stx ()
+	[(_ test then else)
+         (with-syntax ([new-test (syntax-property (syntax (verify-boolean test 'if)) 'stepper-skipto (list syntax-e cdr syntax-e cdr car))])
+           (syntax/loc stx
+             (if new-test
+                 then
+                 else)))]
+	[(_ . rest)
+	 (let ([n (length (syntax->list (syntax rest)))])
+	   (teach-syntax-error
+	    'if
+	    stx
+	    #f
+	    "expected one question expression and two answer expressions, but found ~a expression~a"
+	    (if (zero? n) "no" n)
+	    (if (= n 1) "" "s")))]
+	[_else (bad-use-error 'if stx)]))
+    
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    ;; or, and
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+    (define-values (beginner-or/proc beginner-and/proc)
+      (let ([mk
+	     (lambda (where)
+               (let ([stepper-tag (case where
+                                    [(or) 'comes-from-or]
+                                    [(and) 'comes-from-and])])
+	       (with-syntax ([swhere where])
+		 (lambda (stx)
+		   (syntax-case stx ()
+		     [(_ . clauses)
+		      (let ([n (length (syntax->list (syntax clauses)))])
+			(when (n . < . 2)
+			  (teach-syntax-error
+			   where
+			   stx
+			   #f
+			   "expected at least two expressions after `~a', but found ~a"
+			   where
+                           (if (zero? n) "no expressions" "only one expression")))
+                        (let loop ([clauses-consumed 0]
+                                   [remaining (syntax->list #`clauses)])
+                          (if (null? remaining)
+                              (case where
+                                [(or) #`#f]
+                                [(and) #`#t])
+                              (syntax-property
+                               (syntax-property
+                                (quasisyntax/loc 
+                                 stx
+                                 (if #,(syntax-property (quasisyntax/loc stx (verify-boolean #,(car remaining) 'swhere))
+                                                        `stepper-skipto
+                                                        (list syntax-e cdr syntax-e cdr car))
+                                     #,@(case where
+                                          [(or) #`(#t
+                                                   #,(loop (+ clauses-consumed 1) (cdr remaining)))]
+                                          [(and) #`(#,(loop (+ clauses-consumed 1) (cdr remaining))
+                                                     #f)])))
+                                'stepper-hint
+                                stepper-tag)
+                               'stepper-and/or-clauses-consumed
+                               clauses-consumed))))]
+		     [_else (bad-use-error where stx)])))))])
+	(values (mk 'or) (mk 'and))))
+
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    ;; quote (symbols)
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+    (define (beginner-quote/proc stx)
+      (syntax-case stx ()
+	[(_ expr)
+	 (let ([sym (syntax expr)])
+	   (unless (identifier? sym)
+	     (teach-syntax-error
+	      'quote
+	      stx
+	      #f
+	      "expected a name after a ', found ~a"
+	      (something-else sym)))
+	   (syntax/loc stx (quote expr)))]
+	[_else (bad-use-error 'quote stx)]))
+
+
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    ;; local
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+    (define (intermediate-local/proc stx)
+      (syntax-case stx ()
+	[(_ (definition ...) . exprs)
+	 (let ([defns (syntax->list (syntax (definition ...)))]
+	       ;; The following context value lets teaching-language definition
+	       ;;  forms know that it's ok to expand in this internal
+	       ;;  definition context.
+	       [int-def-ctx (build-expand-context (make-expanding-for-intermediate-local))])
+	   (let* ([partly-expanded-defns 
+		   (map (lambda (d)
+			  (local-expand
+			   d
+			   int-def-ctx
+			   (kernel-form-identifier-list (quote-syntax here))))
+			defns)]
+		  [flattened-defns
+		   (let loop ([l partly-expanded-defns][origs defns])
+		     (apply
+		      append
+		      (map (lambda (d orig)
+			     (syntax-case d (begin define-values define-syntaxes)
+			       ;; we don't have to check for ill-formed `define-values'
+			       ;; or `define-syntaxes', because only macros can generate
+			       ;; them
+			       [(begin defn ...)
+				(let ([l (syntax->list (syntax (defn ...)))])
+				  (loop l l))]
+			       [(define-values . _)
+				(list d)]
+			       [(define-syntaxes . _)
+				(list d)]
+			       [_else
+				(teach-syntax-error
+				 'local
+				 stx
+				 orig
+				 "expected only definitions within the definition sequence, but found ~a"
+				 (something-else orig))]))
+			   l origs)))]
+		  [val-defns
+		   (apply
+		    append
+		    (map (lambda (partly-expanded)
+			   (syntax-case partly-expanded (define-values)
+			     [(define-values (id ...) expr)
+			      (list partly-expanded)]
+			     [_else
+			      null]))
+			 flattened-defns))]
+		  [stx-defns
+		   (apply
+		    append
+		    (map (lambda (partly-expanded)
+			   (syntax-case partly-expanded (define-syntaxes)
+			     [(define-syntaxes (id ...) expr)
+			      (list partly-expanded)]
+			     [_else
+			      null]))
+			 flattened-defns))]
+		  [get-ids (lambda (l)
+			     (apply
+			      append
+			      (map (lambda (partly-expanded)
+				     (syntax-case partly-expanded ()
+				       [(_ (id ...) expr)
+					(syntax->list (syntax (id ...)))]))
+				   l)))]
+		  [val-ids (get-ids val-defns)]
+		  [stx-ids (get-ids stx-defns)])
+	     (let ([dup (check-duplicate-identifier (append val-ids stx-ids))])
+	       (when dup
+		 (teach-syntax-error
+		  'local
+		  stx
+		  dup
+		  "found a name that was defined locally more than once: ~a"
+		  (syntax-e dup)))
+	       (let ([exprs (syntax->list (syntax exprs))])
+		 (check-single-expression 'local
+					  "after the local definition sequence"
+					  stx
+					  exprs
+					  (append val-ids stx-ids)))
+	       (with-syntax ([((d-v (def-id ...) def-expr) ...) val-defns]
+			     [(stx-def ...) stx-defns])
+		 (with-syntax ([(((tmp-id def-id/prop) ...) ...)
+				;; Generate tmp-ids that at least look like the defined
+				;;  ids, for the purposes of error reporting, etc.:
+				(map (lambda (def-ids)
+				       (map (lambda (def-id)
+					      (list
+					       (syntax-property
+						(datum->syntax-object
+						 #f
+						 (string->uninterned-symbol
+						  (symbol->string (syntax-e def-id))))
+						'stepper-orig-name
+						def-id)
+					       (syntax-property
+						def-id
+						'bind-as-variable
+						#t)))
+					    (syntax->list def-ids)))
+				     (syntax->list (syntax ((def-id ...) ...))))])
+                   (with-syntax ([(mapping ...)
+				  (let ([mappers
+					 (syntax->list
+					  (syntax
+					   ((define-syntaxes (def-id/prop ...)
+					      (values
+					       (make-undefined-check
+						(quote-syntax check-not-undefined)
+						(quote-syntax tmp-id))
+					       ...))
+					    ...)))])
+				    (map syntax-track-origin
+					 mappers
+					 val-defns
+					 (syntax->list (syntax (d-v ...)))))])
+                     (syntax-property
+                      (quasisyntax/loc stx
+                        (let ()
+                          (define #,(gensym) 1) ; this ensures that the expansion of 'local' looks
+                                                ; roughly the same, even if the local has no defs.
+                          mapping ...
+                          stx-def ...
+                          (define-values (tmp-id ...) def-expr)
+                          ...
+                          . exprs))
+                      'stepper-hint
+                      'comes-from-local)))))))]
+	[(_ def-non-seq . __)
+	 (teach-syntax-error
+	  'local
+	  stx
+	  (syntax def-non-seq)
+	  "expected a parenthesized definition sequence after `local', but found ~a"
+	  (something-else (syntax def-non-seq)))]
+	[(_)
+	 (teach-syntax-error
+	  'local
+	  stx
+	  #f
+	  "expected a parenthesized definition sequence after `local', but nothing's there")]
+	[_else (bad-use-error 'local stx)]))
+
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    ;; letrec and let (intermediate)
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+    ;; For the `let' forms, match the definitely correct patterns, and
+    ;; put all error checking in `bad-let-form'.
+
+    (define (intermediate-letrec/proc stx)
+      (syntax-case stx ()
+	[(_ ([name rhs-expr] ...) expr)
+	 (let ([names (syntax->list (syntax (name ...)))])
+	   (and (andmap identifier/non-kw? names)
+		(not (check-duplicate-identifier names))))
+	 (with-syntax ([(tmp-id ...)
+                          ;; Generate tmp-ids that at least look like the defined
+                          ;;  ids, for the purposes of error reporting, etc.:
+                          (map (lambda (name)
+                                 (syntax-property
+                                  (datum->syntax-object
+                                   #f
+                                   (string->uninterned-symbol
+                                    (symbol->string (syntax-e name))))
+                                  'stepper-orig-name
+                                  name))
+                               (syntax->list #`(name ...)))]
+                       [(rhs-expr ...) (map allow-local-lambda 
+					    (syntax->list (syntax (rhs-expr ...))))])
+           (quasisyntax/loc stx
+             (letrec-syntaxes+values ([(name) (make-undefined-check
+                                               (quote-syntax check-not-undefined)
+                                               (quote-syntax tmp-id))]
+                                      ...)
+                                     ([(tmp-id) rhs-expr] 
+                                      ...)
+                                     expr)))]
+	[_else (bad-let-form 'letrec stx stx)]))
+    
+    (define (intermediate-let/proc stx)
+      (syntax-case stx ()
+	[(_ ([name rhs-expr] ...) expr)
+	 (let ([names (syntax->list (syntax (name ...)))])
+	   (and (andmap identifier/non-kw? names)
+		(not (check-duplicate-identifier names))))
+         (with-syntax ([(tmp-id ...)
+                          ;; Generate tmp-ids that at least look like the defined
+                          ;;  ids, for the purposes of error reporting, etc.:
+                          (map (lambda (name)
+                                 (syntax-property
+                                  (datum->syntax-object
+                                   #f
+                                   (string->uninterned-symbol
+                                    (symbol->string (syntax-e name))))
+                                  'stepper-orig-name
+                                  name))
+                               (syntax->list #`(name ...)))]
+                         [(rhs-expr ...) (map allow-local-lambda 
+                                              (syntax->list (syntax (rhs-expr ...))))])
+           (quasisyntax/loc stx
+             (let-values ([(tmp-id) rhs-expr] ...)
+               (let-syntaxes ([(name) (make-undefined-check
+                                            (quote-syntax check-not-undefined)
+                                            (quote-syntax tmp-id))]
+                                   ...)
+                      expr))))]
+	[_else (bad-let-form 'let stx stx)]))
+
+    (define (intermediate-let*/proc stx)
+      (syntax-case stx ()
+	[(_ () expr)
+         (syntax-property
+          #`(let () expr)
+          'stepper-skipto
+          (list syntax-e cdr cdr car))]
+	[(_ ([name0 rhs-expr0] [name rhs-expr] ...) expr)
+	 (let ([names (syntax->list (syntax (name0 name ...)))])
+	   (andmap identifier/non-kw? names))
+	 (with-syntax ([rhs-expr0 (allow-local-lambda (syntax rhs-expr0))])
+           (syntax-property
+            (quasisyntax/loc stx
+              (intermediate-let ([name0 rhs-expr0])
+                                #,(quasisyntax/loc stx 
+                                    (intermediate-let* ([name rhs-expr]
+                                                        ...)
+                                                       expr))))
+            'stepper-hint
+            'comes-from-let*))]
+	[_else (bad-let-form 'let* stx stx)]))
+
+    ;; Helper function: allows `beginner-lambda' instead
+    ;; of rejecting it:
+    (define (allow-local-lambda stx)
+      (syntax-case stx (beginner-lambda)
+	[(beginner-lambda . rest)
+	 (begin
+	   (check-defined-lambda stx)
+	   ;; pattern-match again to pull out the formals:
+	   (syntax-case stx ()
+	     [(_ formals . rest)
+	      (quasisyntax/loc stx (lambda formals #,(syntax-property
+                                                    #`make-lambda-generative
+                                                    'stepper-skip-completely
+                                                    #t) 
+                                     . rest))]))]
+	[_else stx]))
+
+    ;; Helper function:
+    (define (bad-let-form who stx orig-stx)
+      (syntax-case stx ()
+	[(_ (binding ...) . exprs)
+	 (let ([bindings (syntax->list (syntax (binding ...)))])
+	   (for-each (lambda (binding)
+		       (syntax-case binding ()
+			 [(name expr)
+			  (let ([name (syntax name)])
+			    (unless (identifier/non-kw? name)
+			      (teach-syntax-error
+			       who
+			       orig-stx
+			       name
+			       "expected a name for a local binding, but found ~a"
+			       (something-else/kw name))))]
+			 [(name . exprs)
+			  (identifier/non-kw? (syntax name))
+			  (check-single-expression who
+						   (format "after the name `~a'"
+							   (syntax-e (syntax name)))
+						   binding
+						   (syntax->list (syntax exprs))
+						   #f)]
+			 [(something . exprs)
+			  (teach-syntax-error
+			   who
+			   orig-stx
+			   (syntax something)
+			   "expected a name after the parenthesis for a ~a local definition, but found ~a"
+			   who
+			   (something-else/kw (syntax something)))]
+			 [_else
+			  (teach-syntax-error
+			   who
+			   orig-stx
+			   binding
+			   "expected a parenthesized name and expression for a ~a local definition, but found ~a"
+			   who
+			   (something-else binding))]))
+		     bindings)
+	   (unless (eq? who 'let*)
+	     (let ([dup (check-duplicate-identifier (map (lambda (binding)
+							   (syntax-case binding ()
+							     [(name . _) (syntax name)]))
+							 bindings))])
+	       (when dup
+		 (teach-syntax-error
+		  who
+		  orig-stx
+		  dup
+		  "found a name that was defined locally more than once: ~a"
+		  (syntax-e dup)))))
+	   (let ([exprs (syntax->list (syntax exprs))])
+	     (check-single-expression who 
+				      "after the name-defining sequence"
+				      orig-stx
+				      exprs
+				      #f)))]
+	[(_ binding-non-seq . __)
+	 (teach-syntax-error
+	  who
+	  orig-stx
+	  (syntax binding-non-seq)
+	  "expected a parenthesized sequence of local name definitions after `~a', but found ~a"
+	  who
+	  (something-else (syntax binding-non-seq)))]
+	[(_)
+	 (teach-syntax-error
+	  who
+	  orig-stx
+	  #f
+	  "expected a sequence of local name definitions after `~a', but nothing's there"
+	  who)]
+	[_else
+	 (bad-use-error who stx)]))
+
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    ;; recur (intermediate and advanced)
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+    ;; We can defer some error reporting to `bad-let-form',
+    ;; but not all of it.
+
+    (define-values (intermediate-recur/proc advanced-recur/proc)
+      (let ([mk
+	     (lambda (empty-ok?)
+	       (lambda (stx)
+		 (syntax-case stx ()
+		   [(_ fname ([name rhs-expr] ...) expr)
+		    (and (identifier/non-kw? (syntax fname))
+			 (let ([names (syntax->list (syntax (name ...)))])
+			   (and (andmap identifier/non-kw? names)
+				(or empty-ok? (pair? names))
+				(not (check-duplicate-identifier names)))))
+		    (syntax-property
+                     (quasisyntax/loc stx
+		      ((intermediate-letrec ([fname
+					      #,(syntax-property
+                                                 (syntax-property 
+                                                  #`(lambda (name ...)
+                                                      expr)
+                                                  'stepper-define-type
+                                                  'shortened-proc-define)
+                                                 'stepper-proc-define-name
+                                                 #`fname)])
+					    fname)
+		       rhs-expr ...))
+                     'stepper-hint
+                     'comes-from-recur)]
+		   [(_form fname empty-seq . rest)
+		    (and (not empty-ok?)
+			 (identifier/non-kw? (syntax fname))
+			 (null? (syntax-e (syntax empty-seq))))
+		    (teach-syntax-error
+		     'recur
+		     stx
+		     (syntax empty-seq)
+		     "expected a non-empty sequence of bindings after the function name, ~
+                    but found an empty sequence")]
+		   [(_form fname . rest)
+		    (identifier/non-kw? (syntax fname))
+		    (bad-let-form 'recur (syntax (_form . rest)) stx)]
+		   [(_form fname . rest)
+		    (teach-syntax-error
+		     'recur
+		     stx
+		     #f
+		     "expected a function name after `recur', but found ~a"
+		     (something-else/kw (syntax fname)))]
+		   [(_form)
+		    (teach-syntax-error
+		     'recur
+		     stx
+		     #f
+		     "expected a function name after `recur', but nothing's there")]
+		   [_else
+		    (bad-use-error 'recur stx)])))])
+	(values (mk #f) (mk #t))))
+
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    ;; lambda (intermediate)
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+    (define (intermediate-lambda/proc stx)
+      (syntax-case stx ()
+	[(_ arg-seq lexpr ...)
+	 (syntax-case (syntax arg-seq) () [(arg ...) #t][_else #f])
+	 (let ([args (syntax->list (syntax arg-seq))])
+	   (for-each (lambda (arg)
+		       (unless (identifier/non-kw? arg)
+			 (teach-syntax-error
+			  'lambda
+			  stx
+			  arg
+			  "expected a name for a function argument, but found ~a"
+			  (something-else/kw arg))))
+		     args)
+	   (when (null? args)
+	     (teach-syntax-error
+	      'lambda
+	      stx
+	      (syntax arg-seq)
+	      "expected at least one argument name in the sequence after `lambda', but found none"))
+	   (let ([dup (check-duplicate-identifier args)])
+	     (when dup
+	       (teach-syntax-error
+		'lambda
+		stx
+		dup
+		"found an argument name that is used more than once: ~a"
+		(syntax-e dup))))
+	   (check-single-expression 'lambda
+				    "within lambda"
+				    stx
+				    (syntax->list (syntax (lexpr ...)))
+				    args)
+	   (syntax/loc stx (lambda arg-seq lexpr ...)))]
+	;; Bad lambda because bad args:
+	[(_ args . __)
+	 (teach-syntax-error
+	  'lambda
+	  stx
+	  (syntax args)
+	  "expected a sequence of function arguments after `lambda', but found ~a"
+	  (something-else (syntax args)))]
+	[(_)
+	 (teach-syntax-error
+	  'lambda
+	  stx
+	  #f
+	  "expected a sequence of argument names after `lambda', but nothing's there")]
+	[_else
+	 (bad-use-error 'lambda stx)]))
+
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    ;; quote (intermediate)
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+    (define intermediate-quote/proc
+      (lambda (stx)
+	(syntax-case stx ()
+	  [(_ expr ...)
+	   (begin
+	     (check-single-expression 'quote
+				      "after the `quote' keyword"
+				      stx
+				      (syntax->list (syntax (expr ...)))
+				      null)
+	     (syntax (quote expr ...)))]
+	  [_else (bad-use-error 'quote stx)])))
+
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    ;; quasiquote (intermediate)
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+    ;; This quasiquote uses the right cons, and perhaps provides more
+    ;; suitable error messages. The "right" cons is actually advanced-cons,
+    ;; because it works with shared:
+
+    (define (intermediate-quasiquote/proc stx)
+      (let loop ([stx (syntax-case stx ()
+			[(_ stx) (syntax stx)]
+			[(_ . any)
+			 (teach-syntax-error
+			  'quasiquote
+			  stx
+			  #f
+			  "misuse of `quasiquote'")]
+			[_else (bad-use-error 'quasiquote stx)])]
+		 [depth 0])
+	(syntax-case stx (intermediate-unquote intermediate-unquote-splicing intermediate-quasiquote)
+	  [(intermediate-unquote x)
+	   (if (zero? depth)
+	       (syntax x)
+	       (with-syntax ([x (loop (syntax x) (sub1 depth))]
+			     [uq (stx-car stx)])
+		 (syntax/loc stx (list (quote uq) x))))]
+	  [intermediate-unquote
+	   (teach-syntax-error
+	    'quasiquote
+	    stx
+	    #f
+	    "misuse of `unquote' within a quasiquoting backquote")]
+	  [((intermediate-unquote-splicing x) . rest)
+	   (if (zero? depth)
+	       (with-syntax ([rest (loop (syntax rest) depth)])
+		 (syntax (append x rest)))
+	       (with-syntax ([x (loop (syntax x) (sub1 depth))]
+			     [rest (loop (syntax rest) depth)]
+			     [uq-splicing (stx-car (stx-car stx))])
+		 (syntax-property (syntax/loc stx (the-cons (list (quote uq-splicing) x) rest))
+                                  'stepper-hint
+                                  'quasiquote-the-cons-application)))]
+	  [intermediate-unquote-splicing
+	   (teach-syntax-error
+	    'quasiquote
+	    stx
+	    #f
+	    "misuse of ,@ or `unquote-splicing' within a quasiquoting backquote")]
+	  [(intermediate-quasiquote x)
+	   (with-syntax ([x (loop (syntax x) (add1 depth))]
+			 [qq (stx-car stx)])
+	     (syntax/loc stx (list (quote qq) x)))]
+	  [(a . b)
+	   (with-syntax ([a (loop (syntax a) depth)]
+			 [b (loop (syntax b) depth)])
+	     (syntax-property (syntax/loc stx (the-cons a b))
+                              'stepper-hint
+                              'quasiquote-the-cons-application))]
+	  [any
+	   (syntax/loc stx (quote any))])))
+
+    (define (intermediate-unquote/proc stx)
+      (teach-syntax-error
+       'unquote
+       stx
+       #f
+       "misuse of a comma or `unquote', not under a quasiquoting backquote"))
+    
+    (define (intermediate-unquote-splicing/proc stx)
+      (teach-syntax-error
+       'unquote-splicing
+       stx
+       #f
+       "misuse of ,@ or `unquote-splicing', not under a quasiquoting backquote"))
+    
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    ;; time
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+    (define (intermediate-time/proc stx)
+      (syntax-case stx ()
+	[(_ . exprs)
+	 (check-single-expression 'time 
+				  "after `time'"
+				  stx
+				  (syntax->list (syntax exprs))
+				  null)
+	 (syntax-property 
+          (syntax/loc stx (time . exprs))
+          'stepper-skipto
+          (list syntax-e cdr car syntax-e car syntax-e cdr car syntax-e cdr syntax-e cdr car syntax-e cdr cdr car))]
+	[_else
+	 (bad-use-error 'time stx)]))
+
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    ;; define (advanced)
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+    (define (advanced-define/proc stx)
+      ;; Handle the case that doesn't fit into beginner, then dispatch to beginner
+      (syntax-case stx ()
+	[(_ (name) expr)
+	 (and (identifier/non-kw? (syntax name))
+	      (ok-definition-context))
+	 (check-definition-new
+	  'define
+	  stx
+	  (syntax name)
+	  (syntax/loc stx (define (name) expr)))]
+	[(_ (name) expr ...)
+	 (check-single-result-expr (syntax->list (syntax (expr ...)))
+				   #f
+				   stx
+				   (list #'name))]
+	[(_ . rest)
+	 ;; Call transformer beginner-define/proc.
+	 ;; Note that we call the transformer instead of producing
+	 ;; new syntax object that is a `beginner-define' form;
+	 ;; that's important for syntax errors, so that they
+	 ;; report `advanced-define' as the source.
+	 (intermediate-define/proc stx)]
+	[_else
+	 (bad-use-error 'define stx)]))
+
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    ;; lambda (advanced)
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+    (define (advanced-lambda/proc stx)
+      (syntax-case stx ()
+	[(_  (name ...) . exprs)
+	 (let ([names (syntax->list (syntax (name ...)))])
+	   (for-each (lambda (name)
+		       (unless (identifier/non-kw? name)
+			 (teach-syntax-error
+			  'lambda
+			  stx
+			  name
+			  "expected a name for an argument, but found ~a"
+			  (something-else/kw name))))
+		     names)
+	   (let ([dup (check-duplicate-identifier names)])
+	     (when dup
+	       (teach-syntax-error
+		'lambda
+		stx
+		dup
+		"found an argument name that is used more than once: ~a"
+		(syntax-e dup))))
+	   (check-single-expression 'lambda 
+				    "after the argument-name sequence"
+				    stx
+				    (syntax->list (syntax exprs))
+				    names)
+	   (syntax/loc stx (lambda (name ...) . exprs)))]
+	[(_ arg-non-seq . exprs)
+	 (teach-syntax-error
+	  'lambda
+	  stx
+	  (syntax arg-non-seq)
+	  "expected a parenthesized sequence of argument names after `lambda', but found ~a"
+	  (something-else (syntax arg-non-seq)))]
+	[(_)
+	 (teach-syntax-error
+	  'lambda
+	  stx
+	  #f
+	  "expected a sequence of argument names after `lambda', but nothing's there")]
+	[_else
+	 (bad-use-error 'lambda stx)]))
+
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    ;; application (advanced)
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+    (define (advanced-app/proc stx)
+      (syntax-case stx ()
+	[(_ rator rand ...)
+	 (syntax/loc stx (#%app rator rand ...))]
+	[(_)
+	 (teach-syntax-error
+	  '|function call|
+	    stx
+	    #f
+	    "expected a defined name or a primitive operation name after an ~
+         open parenthesis, but nothing's there")]
+	[_else (bad-use-error '#%app stx)]))
+
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    ;; set! (advanced)
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+    ;; We disallow set!s on lambda-bound variables, which we recognize
+    ;; as lexically-bound variables that are not bound to
+    ;; set!-transformer syntax values.
+
+    (define-values (advanced-set!/proc advanced-set!-continue/proc)
+      (let ([proc
+	     (lambda (continuing?)
+	       (lambda (stx)
+		 (syntax-case stx ()
+		   [(_ id expr ...)
+		    (identifier? (syntax id))
+		    (let ([exprs (syntax->list (syntax (expr ...)))])
+		      ;; Check that id isn't syntax, and not lexical.
+		      (when ((with-handlers ([exn:fail? (lambda (exn) (lambda () #t))])
+			       ;; First try syntax:
+			       (let ([binding (syntax-local-value (syntax id))])
+				 ;; If it's a transformer binding, then it can take care of itself...
+				 (if (set!-transformer? binding)
+				     (lambda () #f) ;; no lex check wanted
+				     (lambda ()
+				       (teach-syntax-error
+					'set!
+					stx
+					(syntax id)
+					"expected a defined name after `set!', but found a keyword"))))))
+			;; Now try lexical:
+			(when (eq? 'lexical (identifier-binding (syntax id)))
+			  (teach-syntax-error
+			   'set!
+			   stx
+			   (syntax id)
+			   "expected a defined name after `set!', but found a function argument name")))
+		      ;; If we're in a module, we'd like to check here whether
+		      ;;  the identier is bound, but we need to delay that check
+		      ;;  in case the id is defined later in the module. So only
+		      ;;  do this in continuing mode:
+		      (when continuing?
+			(let ([binding (identifier-binding #'id)])
+			  (cond
+			   [(and (not binding)
+				 (syntax-source-module #'id))
+			    (teach-syntax-error
+			     'unknown
+			     #'id
+			     #f
+			     "name is not defined")]
+			   [(and (list? binding)
+				 (or (not (module-path-index? (car binding)))
+				     (let-values ([(path rel) (module-path-index-split (car binding))])
+				       path)))
+			    (teach-syntax-error
+			     'unknown
+			     #'id
+			     #f
+			     "cannot set a primitive name")])))
+		      ;; Check the RHS
+		      (check-single-expression 'set!
+					       "for the new value"
+					       stx
+					       exprs
+					       null)
+		      (if continuing?
+			  (syntax/loc stx (set! id expr ...))
+			  (syntax/loc stx (#%app values (advanced-set!-continue id expr ...)))))]
+		   [(_ id . __)
+		    (teach-syntax-error
+		     'set!
+		     stx
+		     (syntax id)
+		     "expected a defined name after `set!', but found ~a"
+		     (something-else (syntax id)))]
+		   [(_)
+		    (teach-syntax-error
+		     'set!
+		     stx
+		     (syntax id)
+		     "expected a defined name after `set!', but nothing's there")]
+		   [_else (bad-use-error 'set! stx)])))])
+	(values (proc #f)
+		(proc #t))))
+    
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    ;; when and unless (advanced)
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    
+    (define-values (advanced-when/proc advanced-unless/proc)
+      (let ([mk
+	     (lambda (who target-stx)
+	       (lambda (stx)
+		 (syntax-case stx ()
+		   [(_ q expr ...)
+		    (let ([exprs (syntax->list (syntax (expr ...)))])
+		      (check-single-expression who
+					       (format "for the answer in `~a'"
+						       who)
+					       stx
+					       exprs
+					       null)
+		      (with-syntax ([who who]
+				    [target target-stx])
+			(syntax/loc stx (target (verify-boolean q 'who) expr ...))))]
+		   [(_)
+		    (teach-syntax-error
+		     who
+		     stx
+		     #f
+		     "expected a question expression after `~a', but nothing's there"
+		     who)]
+		   [_else
+		    (bad-use-error who stx)])))])
+	(values (mk 'when (quote-syntax when))
+		(mk 'unless (quote-syntax unless)))))
+
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    ;; define-struct (advanced)
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+    (define (advanced-define-struct/proc stx)
+      (do-define-struct stx #f #t #t))
+
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    ;; let (advanced)       >> mz errors in named case <<
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+    (define (advanced-let/proc stx)
+      (syntax-case stx ()
+	[(_ name ids body)
+	 (identifier/non-kw? (syntax name))
+	 (syntax/loc stx (let name ids body))]
+	[(_ name . rest)
+	 (identifier/non-kw? (syntax name))
+	 (teach-syntax-error
+	  'let
+	  stx
+	  #f
+	  "bad syntax for named `let'")]
+	[(_ . rest)
+	 (syntax/loc stx (intermediate-let . rest))]
+	[_else
+	 (bad-use-error 'let stx)]))
+
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    ;; begin (advanced)
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    
+    ;; Mask out the top-level begin
+    (define (advanced-begin/proc stx)
+      (syntax-case stx ()
+	[(_)
+	 (teach-syntax-error
+	  'begin
+	  stx
+	  #f
+	  "expected a sequence of expressions after `begin', but nothing's there")]
+	[(_ e ...)
+	 (syntax/loc stx (let () e ...))]
+	[_else
+	 (bad-use-error 'begin stx)]))
+
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    ;; begin0 (advanced)
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    
+    (define (advanced-begin0/proc stx)
+      (syntax-case stx ()
+	[(_)
+	 (teach-syntax-error
+	  'begin
+	  stx
+	  #f
+	  "expected a sequence of expressions after `begin0', but nothing's there")]
+	[(_ e ...)
+	 (syntax/loc stx (begin0 e ...))]
+	[_else
+	 (bad-use-error 'begin0 stx)]))
+
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    ;; case
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+    (define (advanced-case/proc stx)
+      (syntax-case stx ()
+	[(_)
+	 (teach-syntax-error
+	  'case
+	  stx
+	  #f
+	  "expected an expression after `case', but nothing's there")]
+	[(_ expr)
+	 (teach-syntax-error
+	  'case
+	  stx
+	  #f
+	  "expected a choices--answer clause after the expression following `case', but nothing's there")]
+	[(_ v-expr clause ...)
+	 (let ([clauses (syntax->list (syntax (clause ...)))])
+	   (for-each
+	    (lambda (clause)
+	      (syntax-case clause (beginner-else)
+		[(beginner-else answer ...)
+		 (let ([lpos (memq clause clauses)])
+		   (when (not (null? (cdr lpos)))
+		     (teach-syntax-error
+		      'case
+		      stx
+		      clause
+		      "found an `else' clause that isn't the last clause ~
+                                    in its `case' expression"))
+		   (let ([answers (syntax->list (syntax (answer ...)))])
+		     (check-single-expression 'case
+					      "for the answer in a case clause"
+					      clause
+					      answers
+					      null)))]
+		[(choices answer ...)
+		 (let ([choices (syntax choices)]
+		       [answers (syntax->list (syntax (answer ...)))])
+		   (syntax-case choices ()
+		     [(elem ...)
+		      (let ([elems (syntax->list (syntax (elem ...)))])
+			(for-each (lambda (e)
+				    (let ([v (syntax-e e)])
+				      (unless (or (number? v)
+						  (symbol? v))
+					(teach-syntax-error
+					 'case
+					 stx
+					 e
+					 "expected a name (for a symbol) or a number as a choice value, but found ~a"
+					 (something-else e)))))
+				  elems))]
+		     [_else (teach-syntax-error
+			     'case
+			     stx
+			     choices
+			     "expected a parenthesized sequence of choice values, but found ~a"
+			     (something-else choices))])
+		   (when (stx-null? choices)
+		     (teach-syntax-error
+		      'case
+		      stx
+		      choices
+		      "expected at least once choice in a parenthesized sequence of choice values, but nothing's there"))
+		   (check-single-expression 'case
+					    "for the answer in a `case' clause"
+					    clause
+					    answers
+					    null))]
+		[()
+		 (teach-syntax-error
+		  'case
+		  stx
+		  clause
+		  "expected a choices--answer clause, but found an empty clause")]
+		[_else
+		 (teach-syntax-error
+		  'case
+		  stx
+		  clause
+		  "expected a choices--answer clause, but found ~a"
+		  (something-else clause))]))
+	    clauses)
+	   ;; Add `else' clause for error, if necessary:
+	   (let ([clauses (let loop ([clauses clauses])
+			    (cond
+			     [(null? clauses)
+			      (list
+			       (syntax/loc stx
+				 [else (error 'cases "the expression matched none of the choices")]))]
+			     [(syntax-case (car clauses) (beginner-else)
+				[(beginner-else . _) (syntax/loc (car clauses) (else . _))]
+				[_else #f])
+			      => 
+			      (lambda (x) (cons x (cdr clauses)))]
+			     [else (cons (car clauses) (loop (cdr clauses)))]))])
+	     (with-syntax ([clauses clauses])
+	       (syntax/loc stx (case v-expr . clauses)))))]
+	[_else (bad-use-error 'case stx)]))
+
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    ;; delay (advanced)
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+    (define advanced-delay/proc
+      (lambda (stx)
+	(syntax-case stx ()
+	  [(_ expr ...)
+	   (begin
+	     (check-single-expression 'delay
+				      "after the `delay' keyword"
+				      stx
+				      (syntax->list (syntax (expr ...)))
+				      null)
+	     (syntax (delay expr ...)))]
+	  [_else (bad-use-error 'delay stx)])))
+
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    ;; shared (advanced)
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+    ;; We do all the initial syntax checks, and otherwise
+    ;; let "shared-body.ss" implement the form.
+
+    (define advanced-shared/proc
+      (lambda (stx)
+	;; Helper for the main implementation
+	(define (make-check-cdr name)
+	  (with-syntax ([name name])
+	    (syntax (unless (cyclic-list? (cdr name))
+		      (raise-type-error
+		       'cons
+		       "list or cyclic list"
+		       1
+		       (car name)
+		       (cdr name))))))
+
+	;; Check the syntax before letting the main implementation go:
+	(syntax-case stx ()
+	  [(_ (binding ...) . exprs)
+	   (let ([bindings (syntax->list (syntax (binding ...)))])
+	     (for-each
+	      (lambda (binding)
+		(syntax-case binding ()
+		  [(id . exprs)
+		   (identifier/non-kw? (syntax id))
+		   (check-single-expression 'shared
+					    "after the binding name"
+					    binding
+					    (syntax->list (syntax exprs))
+					    #f)]
+		  [(a . rest)
+		   (not (identifier/non-kw? (syntax a)))
+		   (teach-syntax-error
+		    'shared
+		    stx
+		    (syntax a)
+		    "expected a name for the binding, but found ~a"
+		    (something-else/kw (syntax a)))]
+		  [()
+		   (teach-syntax-error
+		    'shared
+		    stx
+		    (syntax a)
+		    "expected a name for a binding, but nothing's there")]
+		  [_else
+		   (teach-syntax-error
+		    'shared
+		    stx
+		    binding
+		    "expected a name--expression pair for a binding, but found ~a"
+		    (something-else binding))]))
+	      bindings)
+	     (check-single-expression 'shared
+				      "after the bindings"
+				      stx
+				      (syntax->list (syntax exprs))
+				      #f))]
+	  [(_ bad-bind . exprs)
+	   (teach-syntax-error
+	    'shared
+	    stx
+	    (syntax bad-bind)
+	    "expected a sequence of bindings after `shared', but found ~a"
+	    (something-else (syntax bad-bind)))]
+	  [(_)
+	   (teach-syntax-error
+	    'shared
+	    stx
+	    (syntax bad-bind)
+	    "expected a sequence of bindings after `shared', but nothing's there")]
+	  [_else (bad-use-error 'shared stx)])
+
+	;; The main implementation
+	(include (build-path up up "mzlib" "private" "shared-body.ss"))))))
diff --git a/collects/lang/private/teachhelp.ss b/collects/lang/private/teachhelp.ss
new file mode 100644
index 0000000000..1485a70b2b
--- /dev/null
+++ b/collects/lang/private/teachhelp.ss
@@ -0,0 +1,82 @@
+
+(module teachhelp mzscheme
+  (require "firstorder.ss")
+  
+  (provide make-undefined-check 
+	   make-first-order-function)
+  
+  (define (make-undefined-check check-proc tmp-id)
+    (let ([set!-stx (datum->syntax-object check-proc 'set!)])
+      (make-set!-transformer
+       (lambda (stx)
+	 (syntax-case stx ()
+	   [(set! id expr)
+	    (module-identifier=? (syntax set!) set!-stx)
+	    (with-syntax ([tmp-id tmp-id])
+	      (syntax/loc stx (set! tmp-id expr)))]
+	   [(id . args)
+	    (datum->syntax-object
+	     check-proc
+	     (cons (syntax-property
+		    (datum->syntax-object
+		     check-proc
+		     (list check-proc 
+			   (list 'quote (syntax id))
+			   tmp-id))
+		    'stepper-skipto
+		    (list syntax-e cdr syntax-e cdr cdr car))
+		   (syntax args))
+	     stx)]
+	   [id
+	    (syntax-property
+	     (datum->syntax-object
+	      check-proc
+	      (list check-proc 
+		    (list 'quote (syntax id))
+		    tmp-id)
+	      stx)
+             'stepper-skipto
+             (list syntax-e cdr syntax-e cdr cdr car))]))))) ; this may make other stepper-skipto annotations obsolete.
+
+  (define (appropriate-use what)
+    (case what
+     [(constructor)
+      "called with values for the structure fields"]
+     [(selector) 
+      "applied to a structure to get the field value"]
+     [(predicate procedure)
+      "applied to arguments"]))
+
+  (define (make-first-order-function what arity orig-id app)
+    (make-set!-transformer
+     (make-first-order
+      (lambda (stx)
+	(syntax-case stx (set!)
+	  [(set! . _) (raise-syntax-error 
+		       #f stx #f 
+		       "internal error: assignment to first-order function")]
+	  [id
+	   (identifier? #'id)
+	   (raise-syntax-error
+	    #f
+	    (format "this is a ~a, so it must be ~a (which requires using a parenthesis before the name)"
+		    what
+		    (appropriate-use what))
+	    stx
+	    #f)]
+	  [(id . rest)
+	   (let ([l (length (syntax->list #'rest))])
+	     (unless (= l arity)
+	       (raise-syntax-error
+		#f
+		(format "this ~a expects ~a argument~a, here it is provided ~a argument~a"
+			what 
+			arity (if (= 1 arity) "" "s")
+			l (if (= 1 l) "" "s"))
+		stx
+		#f))
+	     (datum->syntax-object
+	      app
+	      (list* app (datum->syntax-object orig-id (syntax-e orig-id) #'id #'id) #'rest)
+	      stx stx))]))
+      (syntax-local-introduce orig-id)))))
diff --git a/collects/lang/private/teachprims.ss b/collects/lang/private/teachprims.ss
new file mode 100644
index 0000000000..a236932bbc
--- /dev/null
+++ b/collects/lang/private/teachprims.ss
@@ -0,0 +1,322 @@
+
+(module teachprims mzscheme
+
+  (require "../imageeq.ss" 
+           (lib "list.ss"))
+  
+  (define-syntax (define-teach stx)
+    (syntax-case stx ()
+      [(_ level id expr)
+       (with-syntax ([level-id (datum->syntax-object
+				(syntax id)
+				(string->symbol
+				 (format "~a-~a"
+					 (syntax-object->datum (syntax level))
+					 (syntax-object->datum (syntax id))))
+				(syntax id))])
+	 (syntax (define level-id
+		   (let ([id expr])
+		     id))))]))
+
+  (define-teach beginner list?
+    (lambda (x)
+      (or (null? x) (pair? x))))
+		    
+  ;; Don't need this anymore, since we just check for pairs:
+  #;
+  (define cyclic-list?
+    (lambda (l)
+       (or (list? l)
+	   (and (pair? l)
+		(let loop ([hare (cdr l)][turtle l])
+		  (cond
+		   [(eq? hare turtle) #t]
+		   [(not (pair? hare)) #f]
+		   [(eq? (cdr hare) turtle) #t]
+		   [(not (pair? (cdr hare))) #f]
+		   [else (loop (cddr hare) (cdr turtle))]))))))
+
+  (define cyclic-list? beginner-list?)
+
+  (define (build-arg-list args)
+    (let loop ([args args][n 0])
+      (cond
+       [(null? args) ""]
+       [(= n 5) " ..."]
+       [else
+	(format " ~e~a" (car args) (loop (cdr args) (add1 n)))])))
+
+  (define (mk-check-second ok? type)
+    (lambda (prim-name a b)
+      (unless (ok? b)
+	(raise
+	 (make-exn:fail:contract
+	  (string->immutable-string
+	   (format "~a: second argument must be of type <~a>, given ~e and ~e"
+		   prim-name type
+		   a b))
+	  (current-continuation-marks))))))
+
+  (define check-second 
+    (mk-check-second beginner-list? "list"))
+
+  (define check-second/cycle
+    (mk-check-second cyclic-list? "list or cyclic list"))
+
+  (define (mk-check-last ok? type)
+    (lambda (prim-name args)
+      (let loop ([l args])
+	(cond
+	 [(null? l) (void)]
+	 [(null? (cdr l))
+	  (let ([last (car l)])
+	    (unless (ok? last)
+	      (raise
+	       (make-exn:fail:contract
+		(string->immutable-string
+		 (format "~a: last argument must be of type <~a>, given ~e; other args:~a"
+			 prim-name type
+			 last
+			 (build-arg-list
+			  (let loop ([args args])
+			    (cond
+			     [(null? (cdr args)) null]
+			     [else (cons (car args) (loop (cdr args)))])))))
+		(current-continuation-marks)))))]
+	 [else (loop (cdr l))]))))
+
+  (define check-last 
+    (mk-check-last beginner-list? "list"))
+
+  (define check-last/cycle
+    (mk-check-last cyclic-list? "list or cyclic list"))
+
+  (define (check-three a b c prim-name ok1? 1type ok2? 2type ok3? 3type)
+    (let ([bad
+	   (lambda (v which type)
+	     (raise
+	      (make-exn:fail:contract
+	       (string->immutable-string
+		(format "~a: ~a argument must be of type <~a>, given ~e, ~e, and ~e"
+			prim-name which type
+			a b c))
+	       (current-continuation-marks))))])
+      (unless (ok1? a)
+	(bad a "first" 1type))
+      (unless (ok2? b)
+	(bad b "second" 2type))
+      (unless (ok3? c)
+	(bad c "second" 3type))))
+
+  (define (positive-real? v)
+    (and (real? v) (>= v 0)))
+
+  (define-teach beginner not
+    (lambda (a)
+      (unless (boolean? a)
+	(raise
+	 (make-exn:fail:contract
+	  (string->immutable-string
+	   (format "not: expected either true or false; given ~e"
+		   a))
+	  (current-continuation-marks))))
+      (not a)))
+
+  (define-teach beginner +
+    (lambda (a b . args)
+      (apply + a b args)))
+
+  (define-teach beginner /
+    (lambda (a b . args)
+      (apply / a b args)))
+  
+  (define-teach beginner *
+    (lambda (a b . args)
+      (apply * a b args)))
+  
+  (define-teach beginner member 
+    (lambda (a b)
+      (check-second 'member a b)
+      (not (boolean? (member a b)))))
+
+  (define-teach beginner cons 
+    (lambda (a b)
+      (check-second 'cons a b)
+      (cons a b)))
+  
+  (define-teach beginner list*
+    (lambda x
+      (check-last 'list* x)
+      (apply list* x)))
+  
+  (define-teach beginner append
+    (lambda x
+      (check-last 'append x)
+      (apply append x)))
+  
+  (define-teach beginner error
+    (lambda (sym str)
+      (unless (and (symbol? sym)
+		   (string? str))
+	(raise
+	 (make-exn:fail:contract
+	  (string->immutable-string
+	   (format "error: expected a symbol and a string, got ~e and ~e"
+		   sym str))
+	  (current-continuation-marks))))
+      (error sym "~a" str)))
+
+  (define-teach beginner struct?
+    (lambda (x)
+      (not (or (number? x)
+	       (boolean? x)
+	       (pair? x)
+	       (symbol? x)
+	       (string? x)
+	       (procedure? x)
+	       (vector? x)
+	       (char? x)
+	       (port? x)
+	       (eof-object? x)
+	       (void? x)))))
+
+  (define-teach beginner exit
+    (lambda () (exit)))
+  
+  ;; This equality predicate doesn't handle hash tables.
+  ;; (It could, but there are no hash tables in the teaching
+  ;;  languages.)
+  (define (tequal? a b epsilon)
+    (let ? ([a a][b b])
+      (or (equal? a b)
+	  (cond
+	   [(box? a)
+	    (and (box? b)
+		 (? (unbox a) (unbox b)))]
+	   [(pair? a)
+	    (and (pair? b)
+		 (? (car a) (car b))
+		 (? (cdr a) (cdr b)))]
+	   [(vector? a)
+	    (and (vector? b)
+		 (= (vector-length a) (vector-length b))
+		 (andmap ?
+			 (vector->list a)
+			 (vector->list b)))]
+	   [(image? a)
+	    (and (image? b)
+		 (image=? a b))]
+	   [(real? a)
+	    (and epsilon
+		 (real? b)
+		 (beginner-=~ a b epsilon))]
+	   [(struct? a)
+	    (and (struct? b)
+		 (let-values ([(ta sa?) (struct-info a)]
+			      [(tb sb?) (struct-info b)])
+		   (and (not sa?)
+			(not sb?)
+			(eq? ta tb)
+			(? (struct->vector a)
+			   (struct->vector b)))))]
+	   [(hash-table? a)
+	    (and (hash-table? b)
+		 (eq? (immutable? a) (immutable? b))
+		 (eq? (hash-table? a 'weak) (hash-table? b 'weak))
+		 (eq? (hash-table? a 'equal) (hash-table? b 'equal))
+		 (let ([al (hash-table-map a cons)]
+		       [bl (hash-table-map b cons)])
+		   (and (= (length al) (length bl))
+			(for-each 
+			 (lambda (ai)
+			   (? (hash-table-get b (car ai) (lambda () (not (cdr ai))))
+			      (cdr ai)))
+			 al))))]
+	   [else #f]))))
+
+  (define-teach beginner equal?
+    (lambda (a b)
+      (tequal? a b #f)))
+
+  (define-teach beginner =~
+    (lambda (a b c)
+      (check-three a b c '=~ real? 'real real? 'real positive-real? 'non-negative-real)
+      (<= (- a c) b (+ a c))))
+
+  (define-teach beginner equal~?
+    (lambda (a b c)
+      (check-three a b c 'equal~? values 'any values 'any positive-real? 'non-negative-real)
+      (tequal? a b c)))
+
+  (define (qcheck fmt-str x)
+    (raise
+     (make-exn:fail:contract
+      (string->immutable-string
+       (string-append "quicksort: " (format fmt-str x)))
+      (current-continuation-marks))))
+    
+  (define-teach intermediate quicksort
+    (lambda (l cmp?)
+      (unless (beginner-list? l) 
+        (qcheck "first argument must be of type <list>, given ~e" l))
+      (unless (and (procedure? cmp?) (procedure-arity-includes? cmp? 2))
+        (qcheck "second argument must be a <procedure> that accepts two arguments, given ~e" cmp?))
+      (quicksort l (lambda (x y) 
+                     (define r (cmp? x y))
+                     (unless (boolean? r)
+                       (qcheck "the results of the procedure argument must be of type <boolean>, produced ~e" r))
+                     r))))
+  
+  (define-teach advanced cons 
+    (lambda (a b)
+      (check-second/cycle 'cons a b)
+      (cons a b)))
+  
+  (define-teach advanced set-cdr!
+    (lambda (a b)
+      (check-second/cycle 'set-cdr! a b)
+      (set-cdr! a b)))
+  
+  (define-teach advanced set-rest!
+    (lambda (a b)
+      (check-second/cycle 'set-rest! a b)
+      (set-cdr! a b)))
+  
+  (define-teach advanced list*
+    (lambda x
+      (check-last/cycle 'list* x)
+      (apply list* x)))
+  
+  (define-teach advanced append
+    (lambda x
+      (check-last/cycle 'append x)
+      (apply append x)))
+  
+  (define-teach advanced append!
+    (lambda x
+      (check-last/cycle 'append! x)
+      (apply append! x)))
+
+  (provide beginner-not
+	   beginner-+
+	   beginner-/
+	   beginner-*
+	   beginner-list?
+           beginner-member
+	   beginner-cons
+	   beginner-list*
+	   beginner-append
+	   beginner-error
+	   beginner-struct?
+	   beginner-exit
+	   beginner-equal?
+	   beginner-equal~?
+	   beginner-=~
+           intermediate-quicksort
+	   advanced-cons
+	   advanced-set-cdr!
+	   advanced-set-rest!
+	   advanced-list*
+	   advanced-append
+	   advanced-append!
+	   cyclic-list?))
diff --git a/collects/lang/r5rs.ss b/collects/lang/r5rs.ss
new file mode 100644
index 0000000000..125966cd33
--- /dev/null
+++ b/collects/lang/r5rs.ss
@@ -0,0 +1,97 @@
+
+(module r5rs mzscheme
+
+  ;; values
+  (provide car cdr caar cadr cdar cddr
+	   caaar caadr cadar caddr cdaar cdadr cddar cdddr
+	   caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
+	   cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
+	   map = < > <= >= max min + - * / 
+	   abs gcd lcm exp log sin cos tan not eq?
+	   call-with-current-continuation make-string
+	   symbol->string string->symbol make-rectangular 
+	   exact->inexact inexact->exact number->string string->number 
+	   rationalize output-port? current-input-port current-output-port current-error-port 
+	   open-input-file open-output-file close-input-port close-output-port
+	   with-output-to-file transcript-on transcript-off flush-output
+	   string-length string-ci<=? string-ci>=? string-append 
+	   string->list list->string string-fill! 
+	   vector-length vector->list list->vector vector-fill!
+	   char-alphabetic? char-numeric? char-whitespace? 
+	   char-upper-case? char-lower-case? char->integer integer->char char-downcase
+	   call-with-output-file call-with-input-file with-input-from-file
+	   apply for-each symbol? pair? cons set-car! set-cdr! null? list? list length append reverse
+	   list-tail list-ref memq memv member assq assv assoc procedure?
+	   number? complex? real? rational? integer? exact? inexact? zero?
+	   positive?  negative? odd? even? 
+	   quotient remainder modulo floor ceiling truncate round 
+	   numerator denominator asin acos atan sqrt
+	   expt make-polar real-part imag-part angle magnitude input-port?
+	   read read-char peek-char eof-object?
+	   char-ready? write display newline write-char load 
+	   string? string string-ref string-set! string=? substring string-copy
+	   string-ci=? string<? string>? string<=? string>=? string-ci<? string-ci>?
+	   vector? make-vector vector vector-ref vector-set! 
+	   char? char=? char<? char>? char<=? char>=? 
+	   char-ci=? char-ci<? char-ci>? char-ci<=? char-ci>=? 
+	   char-upcase boolean? eqv? equal? force
+	   call-with-values values eval port? scheme-report-environment null-environment 
+	   interaction-environment dynamic-wind)
+
+  ;; Copied from R5rS:
+  (define undefined (letrec ([u u]) u))
+  (define-syntax r5rs:letrec
+    (syntax-rules ()
+      ((r5rs:letrec ((var1 init1) ...) body ...)
+       (r5rs:letrec "generate_temp_names"
+	 (var1 ...)
+	 ()
+	 ((var1 init1) ...)
+	 body ...))
+      ((r5rs:letrec "generate_temp_names"
+	 ()
+	 (temp1 ...)
+	 ((var1 init1) ...)
+	 body ...)
+       (let ((var1 undefined) ...)
+	 (let ((temp1 init1) ...)
+	   (set! var1 temp1)
+	   ...
+	   body ...)))
+      ((r5rs:letrec "generate_temp_names"
+	 (x y ...)
+	 (temp ...)
+	 ((var1 init1) ...)
+	 body ...)
+       (r5rs:letrec "generate_temp_names"
+	 (y ...)
+	 (newtemp temp ...)
+	 ((var1 init1) ...)
+	 body ...))))
+
+  ;; syntax
+  (provide quasiquote unquote unquote-splicing 
+	   if let and or cond case define delay do
+	   (rename r5rs:letrec letrec)
+	   let* begin lambda quote set!
+	   define-syntax let-syntax letrec-syntax
+
+	   ;; We have to include the following MzScheme-isms to do anything,
+	   ;; but they're not legal R5RS names, anyway.
+	   #%app #%datum #%top 
+	   (rename synrule-in-stx-module-begin #%module-begin)
+	   (rename require #%require)
+	   (rename provide #%provide))
+	   
+
+  (define-syntax synrule-in-stx-module-begin
+    (lambda (stx)
+      (datum->syntax-object
+       (quote-syntax here)
+       (list* (quote-syntax #%plain-module-begin)
+	      (list 'require-for-syntax 
+		    (datum->syntax-object
+		     stx
+		     '(rename mzscheme syntax-rules syntax-rules)))
+	      (cdr (syntax-e stx)))
+       stx))))
diff --git a/collects/launcher/doc.txt b/collects/launcher/doc.txt
new file mode 100644
index 0000000000..c5207b7a81
--- /dev/null
+++ b/collects/launcher/doc.txt
@@ -0,0 +1,193 @@
+
+The _launcherr.ss_ library in the "launcher" collection imports
+mzlib:file^, dynext:compile^, and dynext:link^, and exports the
+following procedures for creating MzScheme and MrEd launcher
+executables.
+
+===== Launcher creation ========================================
+
+> (make-mred-launcher args dest [aux]) - Creates the launcher
+   `dest'. The `dest' executable (for the current OS platform) will
+   start MrEd with the command-line arguments specified as strings in
+   the list `args'. Extra arguments passed to the launcher at run-time
+   will be appended (modulo special X flag handling, as described
+   below) to this list and passed on to MrEd. If `dest' exists
+   already (as a file or directory), it is replaced.
+
+   `make-mred-launcher' transforms `args' as necessary to avoid
+   mutations caused by passing the strings through the
+   platform-specific launching mechanism (e.g, as /bin/sh arguments),
+   so the strings in `flags' arrive to MrEd intact.
+
+   The optional `aux' argument is an association list for
+   platform-specific options (i.e., it is a list of pairs where the
+   first element of the pair is a key symbol and the second element is
+   the value for that key). The currently supported keys are as
+   follows:
+
+      _'icns_ (Mac OS X) - an icon file path (suffix ".icns") to
+              use for the executable's desktop icon
+
+      _'ico_ (Windows) - an icon file path (suffix ".ico") to
+              use for the executable's desktop icon; the executable
+              will have 16x16, 32x32, and 48x48 icons at 4-bit,
+              8-bit, and 32-bit (RBBA) depths; the icons are
+              copied and generated from any 16x16, 32x32, and 48x48
+              icons in the ".ico" file
+ 
+      _'independent?_  (Windows) - a boolean; #t creates an old-style
+              launcher that is independent of the MzScheme or MrEd
+              binary, like "Setup PLT.exe"
+
+      -'exe-name_ (Mac OS X, MrEd 'script[-3m] variant) - provides the
+              base name for a 'normal variant launcher, which the
+              script will call ignoring `args'; if this name is not
+              provided, the script will go through the MrEd executable
+
+      _'creator_ (Mac OS X) - provides a 4-character string to use as
+              the application signature.
+
+      _'file-types_ (Mac OS X) - provides a list of association lists,
+              one for each type of file handled by the application;
+              each association is a 2-element list, where the first (key)
+              element is a string recognized by Finder, and the second
+              element is a plist value (see doc.tx in the "xml" collection);
+              see plt/collects/drscheme/drscheme.filetypes for an example.
+
+      -'resource-files_ (Mac OS X) - extra files to copy into the
+              "Resources" directory of the generated executable
+
+      _'forget-exe?_ (Windows, Mac OS X) - a boolean; #t does not 
+              preserve the original executable name for
+              `(find-system-path 'exec-file)'; the main consequence is
+              that library collections will be found relative to the
+              launcher instead of the original executable
+
+   See also `build-aux-from-path' below. The default `aux' is `null'.
+
+   For Unix/X, the script created by `make-mred-launcher' detects and
+   handles X flags specially when they appear as the initial arguments
+   to the script. Instead of appending these arguments to the end of
+   `args', they are spliced in after any X Windows flags already
+   listed listed in `args'. The remaining arguments (i.e., all script
+   flags and arguments after the last X Windows flag or argument) are
+   then appended after the spliced `args'.
+
+   For Mac OS Classic, the creation of launchers requires the
+   (one-time) use of an extension, starter-setup.so.  This extension
+   is distributed with DrScheme bundles, and can also be built
+   automatically from the source if necessary (and if the user has a
+   copy of Codewarrior 5).  The creation of launchers on 68k platforms
+   is significantly more fragile than on PPC platforms.  In
+   particular, any launcher created on a 68k platform (or using a 68k
+   binary) must be invoked at least once while that launcher is in the
+   same folder as the MrEd copy it is to be linked to. Note also that
+   once created, these launchers are bound in a truly tenacious way to
+   MrEd; short of deleting MrEd entirely, it's nearly impossible to
+   disconnect them.
+   
+> (make-mzscheme-launcher args dest [aux]) - Same as
+   `make-mred-launcher', but for starting MzScheme. (No special Unix/X
+   handling.)
+
+
+> (make-mred-program-launcher file collection dest) - Calls
+   `make-mred-launcher' with arguments that start the MrEd program
+   implemented by `collection': (list "-mvL-" file collection).
+   The aux argument is generated by stripping the suffix from `file',
+   adding it to the path of `collection', and passing the result to
+   `build-aux-from-path'.
+
+> (make-mzscheme-program-launcher file collection dest) - Calls
+   `make-mzscheme-launcher' with arguments that start the MzScheme
+   program implemented by `file' in `collection': (list "-mvL-" file
+   collection). The aux argument is generated by stripping the suffix
+   from `file', adding it to the path of `collection', and passing the
+   result to `build-aux-from-path'.
+
+
+> (install-mred-program-launcher file collection name) - Calls
+   `make-mred-launcher' with the destintation returned by
+   (mred-program-launcher-path name); the `file' and `collection'
+   arguments are passed on to `make-mred-launcher'.
+
+> (install-mzscheme-program-launcher file collection name) - Calls
+   `make-mzscheme-launcher' with the destintation returned by
+   (mzscheme-program-launcher-path name); the `file' and `collection'
+   arguments are passed on to `make-mzscheme-launcher'.
+
+===== Launcher paths and platform conventions ============================
+
+> (mred-program-launcher-path name) returns a pathname for an executable
+   in the current PLT home directory called `name'.  For Windows, the
+   ".exe" suffix is automatically appended to `name'. For Unix, `name'
+   is changed to lowercase, whitespace is changed to `-', and the path
+   includes the bin subdirectory of the PLT home directory. For Mac OS
+   X, the ".app" suffix is appened to `name'.
+
+> (mzscheme-program-launcher-path name) returns the same pathname as
+   (mred-program-launcher-path name) for Unix, Windows, and Mac OS Classic.
+   For Mac OS X, the result is the same as for Unix.
+
+
+> (mred-launcher-is-directory?) - Returns #t if MrEd launchers for the
+  current platform correspond to directories (as on Mac OS X).
+
+> (mzscheme-launcher-is-directory?) - Returns #t if MzScheme launchers
+  for the current platform correspond to directories.
+
+
+> (mred-launcher-add-suffix path) - Returns a path with a suitable
+  executable suffix added, if it's not present already.
+
+> (mzscheme-launcher-add-suffix path) - Like
+  `mred-launcher-add-suffix', but for MzScheme launchers.
+
+
+> (mred-launcher-put-file-extension+style+filters) - Returns three
+  values suitable for use as the `extension', `style', and `filters'
+  arguments to `put-file', respectively. If MrEd launchers for this
+  platform are directories, the `style' result is suitable for use
+  with `get-directory', and the `extension' result may be a string
+  indicating a required extension for the directory name (e.g., ".app"
+  for Mac OS X).
+
+> (mzscheme-launcher-put-file-extension+style+filters) - Like
+  `mred-launcher-get-file-extension+style+filters', but for MzScheme
+  launchers.
+
+===== Miscellaneous ========================================
+
+> (mred-launcher-up-to-date? dest [aux]) - Returns #t if the
+    launcher `dest' does not need to be updated, assuming
+    that `dest' is a launcher and its arguments have not changed.
+
+> (mzscheme-launcher-up-to-date? dest [aux]) - Analogous to
+    `mred-launcher-up-to-date?'.
+
+
+> (build-aux-from-path path) - Creates an `aux' association list
+    by a suffix to the path, such as ".icns", and checking whether
+    such a file exists. The recognized suffixes are as follows:
+
+       * .icns => 'icns file
+       * .ico  => 'ico file
+       * .lch  => 'independent? as #t (file content is ignored)
+       * .creator => 'creator as initial 4-characters in the file
+       * .filetypes => 'file-types as read content (a single S-expr),
+                       and 'resource-files as a list constructed by
+                       finding "CFBundleTypeIconFile" entries in
+                       'file-types
+
+> (current-launcher-variant [symbol]) - Gets or sets a symbol
+   parameter that indicates a variant of MzScheme or MrEd to use for
+   launcher creation and for generating launcher names. The 'normal
+   variant is usually available. For Unix platforms, the only other
+   possibility is '3m. For Mac OS X, the '3m variant is available, and
+   the 'script and 'script-3m variants are available for MrEd.
+
+> (available-mred-variants) - Returns a list of symbols
+  corresponding to available variants of MrEd.
+
+> (available-mzscheme-variants) - Returns a list of symbols
+  corresponding to available variants of MrEd.
diff --git a/collects/launcher/info.ss b/collects/launcher/info.ss
new file mode 100644
index 0000000000..8abdd80c54
--- /dev/null
+++ b/collects/launcher/info.ss
@@ -0,0 +1,9 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Launcher")
+  (define doc.txt "doc.txt")
+  (define blurb
+    (list "Lets you run your program as a stand-alone program, "
+	  "with out starting up DrScheme first."))
+  (define help-desk-message
+    "Mz/Mr: (require (lib \"launcher.ss\" \"launcher\"))"))
+
diff --git a/collects/launcher/launcher-sig.ss b/collects/launcher/launcher-sig.ss
new file mode 100644
index 0000000000..bd643a46bf
--- /dev/null
+++ b/collects/launcher/launcher-sig.ss
@@ -0,0 +1,35 @@
+
+(module launcher-sig mzscheme
+  (require (lib "unitsig.ss"))
+  
+  (provide launcher^)
+
+  (define-signature launcher^
+    (make-mred-launcher
+     make-mzscheme-launcher
+
+     make-mred-program-launcher
+     make-mzscheme-program-launcher
+
+     mred-program-launcher-path
+     mzscheme-program-launcher-path
+
+     install-mred-program-launcher
+     install-mzscheme-program-launcher
+
+     mred-launcher-up-to-date?
+     mzscheme-launcher-up-to-date?
+
+     mred-launcher-is-directory?
+     mzscheme-launcher-is-directory?
+
+     mred-launcher-add-suffix
+     mzscheme-launcher-add-suffix
+
+     mred-launcher-put-file-extension+style+filters
+     mzscheme-launcher-put-file-extension+style+filters
+
+     build-aux-from-path
+     current-launcher-variant
+     available-mred-variants
+     available-mzscheme-variants)))
diff --git a/collects/launcher/launcher-unit.ss b/collects/launcher/launcher-unit.ss
new file mode 100644
index 0000000000..3bad13862e
--- /dev/null
+++ b/collects/launcher/launcher-unit.ss
@@ -0,0 +1,588 @@
+
+(module launcher-unit mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "file.ss")
+	   (lib "string.ss")
+	   (lib "etc.ss")
+
+	   (lib "compile-sig.ss" "dynext")
+	   (lib "link-sig.ss" "dynext")
+	   (lib "embed.ss" "compiler")
+	   (lib "plthome.ss" "setup")
+
+	   "launcher-sig.ss")
+
+  (provide launcher@)
+
+  (define launcher@
+    (unit/sig launcher^
+      (import [c : dynext:compile^]
+	      [l : dynext:link^])
+
+      (define current-launcher-variant
+	(make-parameter 'normal
+			(lambda (v)
+			  (unless (memq v '(normal 3m script script-3m))
+			    (raise-type-error
+			     'current-launcher-variant
+			     "variant symbol"
+			     v))
+			  v)))
+
+      (define (available-variants kind)
+	(let* ([3m (cond
+		    [(or (eq? 'unix (system-type))
+			 (and (eq? 'macosx (system-type))
+			      (eq? kind 'mzscheme)))
+		     (if (and plthome
+			      (file-exists? (build-path plthome "bin" (format "~a3m" kind))))
+			 '(3m)
+			 null)]
+		    [(eq? 'macosx (system-type))
+		     ;; kind must be mred, because mzscheme case caught above
+		     (if (directory-exists? (build-path plthome "MrEd3m.app"))
+			 '(3m)
+			 null)]
+		    [(eq? 'windows (system-type))
+		     (if (file-exists? (build-path plthome (format "~a3m.exe" kind)))
+			 '(3m)
+			 null)]
+		    [else
+		     ;; 3m launchers not yet supported for other platforms:
+		     null])]
+	       [normal (if (eq? kind 'mzscheme)
+			   '(normal) ; MzScheme is always available
+			   (if (and plthome
+				    (cond
+				     [(eq? 'unix (system-type))
+				      (file-exists? (build-path plthome "bin" (format "~a" kind)))]
+				     [(eq? 'macosx (system-type))
+				      (directory-exists? (build-path plthome "MrEd.app"))]
+				     [(eq? 'windows (system-type))
+				      (file-exists? (build-path plthome (format "~a.exe" kind)))]
+				     [else #t]))
+			       '(normal)
+			       null))]
+	       [script (if (and (eq? 'macosx (system-type))
+				(eq? kind 'mred)
+				(pair? normal))
+			   '(script)
+			   null)]
+	       [script-3m (if (and (memq '3m 3m)
+				   (memq 'script script))
+			      '(script-3m)
+			      null)])
+	  (append 3m normal script script-3m)))
+
+      (define (available-mred-variants)
+	(available-variants 'mred))
+
+      (define (available-mzscheme-variants)
+	(available-variants 'mzscheme))
+
+      (define (install-template dest kind mz mr)
+	(define src (build-path (collection-path "launcher")
+				(if (eq? kind 'mzscheme) mz mr)))
+	(when (or (file-exists? dest)
+		  (directory-exists? dest)
+		  (link-exists? dest))
+	  (delete-directory/files dest))
+	(copy-file src dest))
+
+      (define (variant-suffix variant)
+	(case variant
+	  [(normal script) ""]
+	  [(3m script-3m) "3m"]))
+
+      (define (add-file-suffix path variant)
+	(let ([s (variant-suffix variant)])
+	  (if (string=? "" s)
+	      path
+	      (if (and (eq? 'windows (system-type))
+		       (regexp-match #rx#"[.]exe$" (path->bytes path)))
+		  (path-replace-suffix path (string->bytes/utf-8
+					     (format "~a.exe" s)))
+		  (path-replace-suffix path (string->bytes/utf-8 s))))))
+      
+      (define (string-append/spaces f flags)
+	(if (null? flags)
+	    ""
+	    (string-append
+	     (f (car flags))
+	     " "
+	     (string-append/spaces f (cdr flags)))))
+      
+      (define (str-list->sh-str flags)
+	(letrec ([trans
+		  (lambda (s)
+		    (cond
+		     [(regexp-match "(.*)'(.*)" s)
+		      => (lambda (m)
+			   (string-append (trans (cadr m))
+					  "\"'\""
+					  (trans (caddr m))))]
+		     [else (format "'~a'" s)]))])
+	  (string-append/spaces trans flags)))
+      
+      (define (str-list->dos-str flags)
+	(letrec ([trans
+		  (lambda (s)
+		    (if (or (regexp-match (string #\[ #\space #\newline #\tab #\return #\vtab #\]) s)
+			    (regexp-match "\"" s)
+			    (regexp-match "\\\\" s))
+			(list->string
+			 (let loop ([l (string->list s)][wrote-slash 0])
+			   (cond
+			    [(null? l) null]
+			    [(char-whitespace? (car l))
+			     (append
+			      (string->list (make-string wrote-slash #\\))
+			      (list #\" (car l) #\")
+			      (loop (cdr l) 0))]
+			    [else
+			     (case (car l)
+			       [(#\\) (cons #\\ (loop (cdr l) (add1 wrote-slash)))]
+			       [(#\") (append
+				       (string->list (make-string wrote-slash #\\))
+				       `(#\" #\\ #\" #\")
+				       (loop (cdr l) 0))]
+			       [else (cons (car l) (loop (cdr l) 0))])])))
+			s))])
+	  (string-append/spaces trans flags)))
+
+      (define one-arg-x-flags '((xa "-display")
+				(xb "-geometry")
+				(xc "-bg" "-background") 
+				(xd "-fg" "-foregound") 
+				(xe "-font")
+				(xf "-name")
+				(xg "-selectionTimeout")
+				(xh "-title")
+				(xi "-xnllanguage")
+				(xj "-xrm")))
+      (define no-arg-x-flags '((xk "-iconic") 
+			       (xl "-rv" "-reverse") 
+			       (xm "+rv") 
+			       (xn "-synchronous")))
+
+      (define (skip-x-flags flags)
+	(let ([xfmem (lambda (flag) (lambda (xf) (member flag (cdr xf))))])
+	  (let loop ([f flags])
+	    (if (null? f)
+		null
+		(if (ormap (xfmem (car f)) one-arg-x-flags)
+		    (if (null? (cdr f))
+			null
+			(loop (cddr f)))
+		    (if (ormap (xfmem (car f)) no-arg-x-flags)
+			(loop (cdr f))
+			f))))))
+
+      (define (output-x-arg-getter exec args)
+	(let* ([newline (string #\newline)]
+	       [or-flags
+		(lambda (l)
+		  (if (null? (cdr l))
+		      (car l)
+		      (string-append
+		       (car l)
+		       (apply
+			string-append
+			(map (lambda (s) (string-append " | " s)) (cdr l))))))])
+	  (apply
+	   string-append
+	   (append
+	    (list "# Find X flags and shift them to the front" newline
+		  "findxend()" newline
+		  "{" newline
+		  " oneargflag=''" newline
+		  " case \"$1\" in" newline)
+	    (map
+	     (lambda (f)
+	       (format (string-append
+			"  ~a)" newline
+			"     oneargflag=\"$1\"" newline
+			"     ~a=\"$2\"" newline
+			"   ;;" newline)
+		       (or-flags (cdr f))
+		       (car f)))
+	     one-arg-x-flags)
+	    (map
+	     (lambda (f)
+	       (format "  ~a)~n    ~a=yes~n  ;;~n" (or-flags (cdr f)) (car f)))
+	     no-arg-x-flags)
+	    (list
+	     (format (string-append
+		      "  *)~n    ~a~a~a  ;;~n"
+		      " esac~n"
+		      " shift~n"
+		      " if [ \"$oneargflag\" != '' ] ; then~n"
+		      "   if [ \"${1+n}\" != 'n' ] ; then echo $0: missing argument for standard X flag $oneargflag ; exit 1 ; fi~n"
+		      "   shift~n"
+		      " fi~n"
+		      " findxend ${1+\"$@\"}~n"
+		      "}~nfindxend ${1+\"$@\"}~n")
+		     exec 
+		     (apply
+		      string-append
+		      (append
+		       (map
+			(lambda (f) (format " ${~a+\"~a\"} ${~a+\"$~a\"}" (car f) (cadr f) (car f) (car f)))
+			one-arg-x-flags)
+		       (map
+			(lambda (f) (format " ${~a+\"~a\"}" (car f) (cadr f)))
+			no-arg-x-flags)))
+		     args))))))
+
+      (define (make-unix-launcher kind variant flags dest aux)
+	(install-template dest kind "sh" "sh") ; just for something that's executable
+	(let* ([newline (string #\newline)]
+	       [alt-exe (let ([m (and (eq? kind 'mred)
+				      (memq variant '(script script-3m))
+				      (assq 'exe-name aux))])
+			  (and m
+			       (format "~a~a.app/Contents/MacOS/~a~a" 
+				       (cdr m) (variant-suffix variant)
+				       (cdr m) (variant-suffix variant))))]
+	       [post-flags (if (and (eq? kind 'mred)
+				    (not (memq variant '(script script-3m))))
+			       (skip-x-flags flags)
+			       null)]
+	       [pre-flags (cond
+			   [alt-exe null]
+			   [(null? post-flags) flags]
+			   [else
+			    (let loop ([f flags])
+			      (if (eq? f post-flags)
+				  null
+				  (cons (car f) (loop (cdr f)))))])]
+	       [pre-str (str-list->sh-str pre-flags)]
+	       [post-str (str-list->sh-str post-flags)]
+	       [header (format
+			(string-append
+			 "#!/bin/sh" newline
+			 "# This script was created by make-~a-launcher" newline
+			 newline
+			 "if [ \"$PLTHOME\" = '' ] ; then" newline
+			 "  PLTHOME=\"~a\"" newline
+			 "  export PLTHOME" newline
+			 "fi" newline
+			 newline)
+			kind (regexp-replace* "\"" 
+					      (path->string plthome)
+					      "\\\\\""))]
+	       [exec (format
+		      "exec \"${PLTHOME}/~a~a~a\" ~a"
+		      (if alt-exe "" "bin/")
+		      (or alt-exe kind)
+		      (if alt-exe "" (variant-suffix variant)) pre-str)]
+	       [args (format
+		      " ~a ${1+\"$@\"}~n"
+		      post-str)]
+	       [assemble-exec (if (and (eq? kind 'mred)
+				       (not (memq variant '(script scrip-3m)))
+				       (not (null? post-flags)))
+				  output-x-arg-getter
+				  string-append)])
+	  (unless plthome
+	    (error 'make-unix-launcher "unable to locate PLTHOME"))
+	  (let ([p (open-output-file dest 'truncate)])
+	    (fprintf p "~a~a"
+		     header
+		     (assemble-exec exec args))
+	    (close-output-port p))))
+      
+      (define (make-windows-launcher kind variant flags dest aux)
+	(if (not (and (let ([m (assq 'independent? aux)])
+			(and m (cdr m)))))
+	    ;; Normal launcher: 
+	    (make-embedding-executable dest (eq? kind 'mred) #f
+				       null null null
+				       flags
+				       aux
+				       #t
+				       variant)
+	    ;; Independent launcher (needed for Setup PLT):
+	    (begin
+	      (install-template dest kind "mzstart.exe" "mrstart.exe")
+	      (let ([bstr (string->bytes/utf-8 (str-list->dos-str flags))]
+		    [p (open-input-file dest)]
+		    [m #rx#"<Command Line: Replace This[^>]*>"]
+		    [x #rx#"<Executable Directory: Replace This[^>]*>"]
+		    [v #rx#"<Executable Variant: Replace This>"])
+		(let* ([exedir (bytes-append
+				(path->bytes plthome)
+				;; null character marks end of executable directory
+				#"\0")]
+		       [find-it ; Find the magic start
+			(lambda (magic s)
+			  (file-position p 0)
+			  (let ([m (regexp-match-positions magic p)])
+			    (if m
+				(car m)
+				(begin
+				  (close-input-port p)
+				  (when (file-exists? dest)
+				    (delete-file dest))
+				  (error 
+				   'make-windows-launcher 
+				   (format
+				    "Couldn't find ~a position in template" s))))))]
+		       [exedir-poslen (find-it x "executable path")]
+		       [command-poslen (find-it m "command-line")]
+		       [variant-poslen (find-it v "variant")]
+		       [pos-exedir (car exedir-poslen)]
+		       [len-exedir (- (cdr exedir-poslen) (car exedir-poslen))]
+		       [pos-command (car command-poslen)]
+		       [len-command (- (cdr command-poslen) (car command-poslen))]
+		       [pos-variant (car variant-poslen)]
+		       [space (char->integer #\space)]
+		       [write-magic
+			(lambda (p s pos len)
+			  (file-position p pos)
+			  (display s p)
+			  (display (make-bytes (- len (bytes-length s)) space) p))]
+		       [check-len
+			(lambda (len s es)
+			  (when (> (bytes-length s) len)
+				(when (file-exists? dest)
+				  (delete-file dest))
+				(error
+				 (format
+				  "~a exceeds limit of ~a characters with ~a characters: ~a"
+				  es len (string-length s) s))))])
+		  (close-input-port p)
+		  (check-len len-exedir exedir "executable home directory")
+		  (check-len len-command bstr "collection/file name")
+		  (let ([p (open-output-file dest 'update)])
+		    (write-magic p exedir pos-exedir len-exedir)   
+		    (write-magic p bstr pos-command len-command)   
+		    (when (eq? '3m (current-launcher-variant))
+		      (write-magic p #"3" pos-variant 1))
+		    (close-output-port p)))))))
+      
+      ;; OS X launcher code:
+     
+      ; make-macosx-launcher : symbol (listof str) pathname ->  
+      (define (make-macosx-launcher kind variant flags dest aux)
+	(if (or (eq? kind 'mzscheme) 
+		(eq? variant 'script) 
+		(eq? variant 'script-3m))
+	    ;; MzScheme or script launcher is the same as for Unix
+	    (make-unix-launcher kind variant flags dest aux)
+	    ;; MrEd "launcher" is a stand-alone executable
+	    (make-embedding-executable dest (eq? kind 'mred) #f
+				       null null null
+				       flags
+				       aux
+				       #t
+				       variant)))
+        
+      
+      (define (make-macos-launcher kind variant flags dest aux)
+	(install-template dest kind "GoMr" "GoMr")
+	(let ([p (open-input-file dest)])
+	  (let ([m (regexp-match-positions "<Insert offset here>" p)])
+	    ;; fast-forward to the end:
+	    (let ([s (make-bytes 4096)])
+	      (let loop ()
+		(if (eof-object? (read-bytes! s p))
+		    (file-position p)
+		    (loop))))
+	    (let ([data-fork-size (file-position p)])
+	      (close-input-port p)
+	      (let ([p (open-output-file dest 'update)]
+		    [str (str-list->sh-str (append
+					    (if (eq? kind 'mred)
+						null
+						'("-Z"))
+					    flags))])
+		(file-position p (caar m))
+		(display (integer->integer-bytes (string-length str) 4 #t #t) p)
+		(display (integer->integer-bytes data-fork-size 4 #t #t) p)
+		(file-position p data-fork-size)
+		(display str p)
+		(close-output-port p))))))
+      
+      (define (get-maker)
+	(case (system-type)
+	  [(unix) make-unix-launcher]
+	  [(windows) make-windows-launcher]
+	  [(macos) make-macos-launcher]
+	  [(macosx) make-macosx-launcher]))
+      
+      (define make-mred-launcher
+	(opt-lambda (flags dest [aux null])
+	  (let ([variant (current-launcher-variant)])
+	    ((get-maker) 'mred variant flags dest aux))))
+      
+      (define make-mzscheme-launcher
+	(opt-lambda (flags dest [aux null])
+	  (let ([variant (current-launcher-variant)])
+	    ((get-maker) 'mzscheme variant flags dest aux))))
+      
+      (define (strip-suffix s)
+	(path-replace-suffix s #""))
+
+      (define (build-aux-from-path aux-root)
+	(let ([aux-root (if (string? aux-root)
+			    (string->path aux-root)
+			    aux-root)])
+	  (let ([try (lambda (key suffix)
+		       (let ([p (path-replace-suffix aux-root suffix)])
+			 (if (file-exists? p)
+			     (list (cons key p))
+			     null)))])
+	    (append
+	     (try 'icns #".icns")
+	     (try 'ico #".ico")
+	     (try 'independent? #".lch")
+	     (let ([l (try 'creator #".creator")])
+	       (if (null? l)
+		   l
+		   (with-handlers ([exn:fail:filesystem? (lambda (x) null)])
+		     (with-input-from-file (cdar l)
+		       (lambda () 
+			 (let ([s (read-string 4)])
+			   (if s
+			       (list (cons (caar l) s))
+			       null)))))))
+	     (let ([l (try 'file-types #".filetypes")])
+	       (if (null? l)
+		   l
+		   (with-handlers ([exn:fail:filesystem? (lambda (x) null)])
+		     (with-input-from-file (cdar l)
+		       (lambda () 
+			 (let ([d (read)])
+			   (let-values ([(local-dir base dir?) (split-path aux-root)])
+			     (let ([icon-files
+				    (apply
+				     append
+				     (map (lambda (spec)
+					    (let ([m (assoc "CFBundleTypeIconFile" spec)])
+					      (if m
+						  (list (build-path 
+							 (path->complete-path local-dir)
+							 (format "~a.icns" (cadr m))))
+						  null)))
+					  d))])
+			       (list
+				(cons 'file-types d)
+				(cons 'resource-files icon-files))))))))))))))
+
+      (define (make-mred-program-launcher file collection dest)
+	(make-mred-launcher (list "-mqvL" file collection "--") 
+			    dest
+			    (build-aux-from-path
+			     (build-path (collection-path collection)
+					 (strip-suffix file)))))
+      
+      (define (make-mzscheme-program-launcher file collection dest)
+	(make-mzscheme-launcher (list "-mqvL" file collection "--") 
+				dest
+				(build-aux-from-path
+				 (build-path (collection-path collection)
+					     (strip-suffix file)))))
+      
+      (define l-home (if (memq (system-type) '(unix))
+			 (build-path plthome "bin")
+			 plthome))
+
+      (define l-home-macosx-mzscheme (build-path plthome "bin"))
+
+      (define (unix-sfx file)
+	(list->string
+	 (map
+	  (lambda (c)
+	    (if (char-whitespace? c)
+		#\-
+		(char-downcase c)))
+	  (string->list file))))
+
+      (define (sfx file) (case (system-type) 
+			   [(unix) (unix-sfx file)]
+			   [(windows) (string-append file ".exe")]
+			   [else file]))
+
+      (define (mred-program-launcher-path name)
+	(let* ([variant (current-launcher-variant)]
+	       [mac-script? (and (eq? (system-type) 'macosx) 
+				 (memq variant '(script script-3m)))])
+	  (let ([p (add-file-suffix 
+		    (build-path 
+		     (if mac-script?
+			 l-home-macosx-mzscheme
+			 l-home)
+		     ((if mac-script? unix-sfx sfx) name))
+		    variant)])
+	   (if (and (eq? (system-type) 'macosx) 
+		    (not (memq variant '(script script-3m))))
+	       (path-replace-suffix p #".app")
+	       p))))
+      
+      (define (mzscheme-program-launcher-path name)
+	(case (system-type)
+	  [(macosx) (add-file-suffix 
+		     (build-path l-home-macosx-mzscheme (unix-sfx name))
+		     (current-launcher-variant))]
+	  [else (mred-program-launcher-path name)]))
+      
+      (define (mred-launcher-is-directory?)
+	(and (eq? 'macosx (system-type))
+	     (not (memq (current-launcher-variant) '(script script-3m)))))
+      (define (mzscheme-launcher-is-directory?)
+	#f)
+
+      ;; Helper:
+      (define (put-file-extension+style+filters type)
+	(case type
+	  [(windows) (values ".exe" null '(("Executable" "*.exe")))]
+	  [(macosx) (values ".app" '(enter-packages) #f)]
+	  [else (values #f null null)]))
+      
+      (define (mred-launcher-add-suffix path)
+	(embedding-executable-add-suffix path #t))
+
+      (define (mzscheme-launcher-add-suffix path)
+	(embedding-executable-add-suffix path #f))
+
+      (define (mred-launcher-put-file-extension+style+filters)
+	(put-file-extension+style+filters 
+	 (if (and (eq? 'macosx (system-type))
+		  (memq (current-launcher-variant) '(script script-3m)))
+	     'unix
+	     (system-type))))
+
+      (define (mzscheme-launcher-put-file-extension+style+filters)
+	(put-file-extension+style+filters 
+	 (if (eq? 'macosx (system-type))
+	     'unix
+	     (system-type))))
+
+      (define mred-launcher-up-to-date?
+	(opt-lambda (dest [aux null])
+          (mzscheme-launcher-up-to-date? dest aux)))
+
+      (define mzscheme-launcher-up-to-date?
+	(opt-lambda (dest [aux null])
+           (cond
+	    ;; When running Setup PLT under Windows, the
+	    ;;  launcher process stays running until MzScheme
+	    ;;  completes, which means that it cannot be
+	    ;;  overwritten at that time. So we assume
+	    ;;  that a Setup-PLT-style independent launcher
+	    ;;  is always up-to-date.
+	    [(eq? 'windows (system-type))
+	     (and (let ([m (assq 'independent? aux)])
+		    (and m (cdr m)))
+		  (file-exists? dest))]
+	    ;; For any other setting, we could implement
+	    ;;  a fancy check, but for now always re-create
+	    ;;  launchers.
+	    [else #f])))
+
+      (define (install-mred-program-launcher file collection name)
+	(make-mred-program-launcher file collection (mred-program-launcher-path name)))
+      
+      (define (install-mzscheme-program-launcher file collection name)
+	(make-mzscheme-program-launcher file collection (mzscheme-program-launcher-path name))))))
diff --git a/collects/launcher/launcher.ss b/collects/launcher/launcher.ss
new file mode 100644
index 0000000000..981b0b9087
--- /dev/null
+++ b/collects/launcher/launcher.ss
@@ -0,0 +1,19 @@
+
+(module launcher mzscheme
+  (require (lib "unitsig.ss"))
+
+  (require (lib "compile-sig.ss" "dynext")
+	   (lib "compile.ss" "dynext")
+	   (lib "link-sig.ss" "dynext")
+	   (lib "link.ss" "dynext"))
+  
+  (require "launcher-sig.ss"
+	   "launcher-unit.ss")
+  
+  (define-values/invoke-unit/sig launcher^ 
+    launcher@
+    #f
+    dynext:compile^
+    dynext:link^)
+
+  (provide-signature-elements launcher^))
diff --git a/collects/launcher/sh b/collects/launcher/sh
new file mode 100755
index 0000000000..e69de29bb2
diff --git a/collects/make/collection-sig.ss b/collects/make/collection-sig.ss
new file mode 100644
index 0000000000..f15a615701
--- /dev/null
+++ b/collects/make/collection-sig.ss
@@ -0,0 +1,9 @@
+
+(module collection-sig mzscheme
+  (require (lib "unitsig.ss"))
+
+  (provide make:collection^)
+
+  (define-signature make:collection^
+    (make-collection)))
+
diff --git a/collects/make/collection-unit.ss b/collects/make/collection-unit.ss
new file mode 100644
index 0000000000..13e7642824
--- /dev/null
+++ b/collects/make/collection-unit.ss
@@ -0,0 +1,109 @@
+
+(module collection-unit mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "list.ss")
+	   (lib "file.ss"))
+
+  (require "collection-sig.ss")
+  (require "make-sig.ss")
+
+  (require (lib "sig.ss" "compiler")
+	   (lib "file-sig.ss" "dynext"))
+
+  (provide make:collection@)
+
+  (define make:collection@
+    (unit/sig
+	make:collection^
+      (import make^
+	      dynext:file^
+	      (compiler:option : compiler:option^)
+	      compiler^)
+
+      (define (make-collection
+	       collection-name
+	       collection-files
+	       argv)
+	(printf "building collection ~a: ~a~n" collection-name collection-files)
+	(let* ([zo-compiler #f]
+	       [ext-compiler #f]
+	       [dest-dir (build-path "compiled" "native" (system-library-subpath))]
+	       [src-dir (current-directory)]
+	       [sses (quicksort collection-files (lambda (a b)
+						   (string-ci<? (path->string a) (path->string b))))]
+	       [bases (map (lambda (src)
+			     (extract-base-filename/ss src 'make-collection-extension))
+			   sses)]
+	       [cs (map 
+		    (lambda (base)
+		      (build-path
+		       "compiled"
+		       "native"
+		       (append-c-suffix base)))
+		    bases)]
+	       [zos (map 
+		     (lambda (base)
+		       (build-path
+			"compiled"
+			(append-zo-suffix base)))
+		     bases)]
+	       [kps (map 
+		     (lambda (base)
+		       (build-path
+			"compiled"
+			"native"
+			(append-constant-pool-suffix base)))
+		     bases)]
+	       [objs (map
+		      (lambda (base)
+			(build-path
+			 dest-dir
+			 (append-object-suffix base)))
+		      bases)]
+	       [ss->zo-list
+		(map (lambda (ss zo)
+		       `(,zo (,ss)
+			     ,(lambda ()
+				(unless zo-compiler
+				  (set! zo-compiler (compile-zos #f)))
+				(zo-compiler (list ss) "compiled"))))
+		     sses zos)]
+	       [ss->c-list
+		(map (lambda (ss c)
+		       `(,c (,ss)
+			    ,(lambda ()
+			       (unless ext-compiler
+				 (set! ext-compiler (compile-extension-parts-to-c #f)))
+			       (parameterize ([compiler:option:setup-prefix 
+					       (string-append "_" collection-name)])
+				 (ext-compiler (list ss) (build-path "compiled" "native"))))))
+		     sses cs)]
+	       [c->o-list
+		(map (lambda (c obj)
+		       `(,obj (,c)
+			      ,(lambda ()
+				 (parameterize ([compiler:option:setup-prefix 
+						 (string-append "_" collection-name)])
+				   (compile-c-extension-parts (list c) dest-dir)))))
+		     cs objs)]
+	       [o->so
+		`(,(build-path dest-dir (append-extension-suffix "_loader"))
+		  ,objs
+		  ,(lambda ()
+		     (parameterize ([compiler:option:setup-prefix (string-append "_" collection-name)])
+		       (link-extension-parts
+			(append objs kps)
+			dest-dir))))])
+	  (unless (directory-exists? "compiled") (make-directory "compiled"))
+	  (unless (or (equal? argv #("zo"))
+		      (directory-exists? dest-dir))
+	    (make-directory* dest-dir))
+	  (make/proc
+	   (append
+	    (list o->so)
+	    `(("zo" ,zos))
+	    ss->zo-list
+	    ss->c-list
+	    c->o-list)
+	   argv))))))
+
diff --git a/collects/make/collection.ss b/collects/make/collection.ss
new file mode 100644
index 0000000000..72b3fc257d
--- /dev/null
+++ b/collects/make/collection.ss
@@ -0,0 +1,24 @@
+
+(module collection mzscheme
+  (require (lib "unitsig.ss"))
+
+  (require (lib "file-sig.ss" "dynext")
+	  (lib "file.ss" "dynext")
+	  (lib "sig.ss" "compiler")
+	  (lib "compiler.ss" "compiler")
+	  (lib "option.ss" "compiler"))
+
+  (require "make-sig.ss"
+	  "make.ss"
+	  "collection-sig.ss"
+	  "collection-unit.ss")
+  
+  (define-values/invoke-unit/sig make:collection^ 
+    make:collection@
+    #f
+    make^
+    dynext:file^
+    compiler:option^
+    compiler^)
+
+  (provide-signature-elements make:collection^))
diff --git a/collects/make/doc.txt b/collects/make/doc.txt
new file mode 100644
index 0000000000..df7abdb086
--- /dev/null
+++ b/collects/make/doc.txt
@@ -0,0 +1,279 @@
+_Overview of make_
+------------------
+
+This library provides a Scheme version of the standard unix
+`make' utility. Its syntax is intended to simulate regular
+unix make in Scheme.
+
+If you are already familiar with make, skip down the precise
+details of the make collection. This section contains a
+brief overview of make. The idea is to explain how to
+generate some project you have from a collection of source
+files that go through several stages of processing.
+
+For example, lets say that you are writing soem project that
+has three input files (that you create and maintain) called
+a.input, b.input, and c.input. Further, there are two stages
+of processing -- first you run a particular tool
+"make-output" that takes an input file and produces and
+output file, and second you combine the input files into a
+single file using "output". Using make, you might write
+this:
+
+a.output: a.input
+	make-output a.input a.output
+b.output: b.input
+	make-output b.input b.output
+c.output: c.input
+	make-output c.input c.output 
+total: a.output b.output c.output
+	combine a.output b.output c.output 
+
+Once you've put those above lines in a file called
+"Makefile", you can issue the command:
+
+  make total 
+
+that builds your entire project. The Makefile consists of
+several lines that tell `make' how to create each piece. The
+first two lines say that a.output depends on a.input and the
+command for making a.output from a.input is 
+
+  make-output a.input a.ouput
+
+The point of this exercise is that the `make' utility looks
+at the file creation dates of the various files and only
+re-builds what is necessary.  Make is based on building
+things with shell programs. If, on the other hand, you want
+to build similar things with various Scheme programs, you
+can use the make collection.
+
+Here's the equivalent Scheme program: 
+
+(require (lib "make.ss" "make"))
+
+(define (make-output in out)
+   ...)
+
+(define (combine-total . args)
+  ...)
+
+(make
+  (("a.ouput" ("a.input") (make-output "a.output" "a.input"))
+   ("b.ouput" ("b.input") (make-output "b.output" "b.input"))
+   ("c.ouput" ("c.input") (make-output "c.output" "c.input"))
+   ("total" ("a.output" "b.output" "c.output")
+            (combine-total "a.output" "b.output" "c.output")))
+
+If you were to fill in the ellipses above with calls to
+`system', you'd have the exact same thing as the original
+Makefile. In addition, if you use `make/proc', you can
+abstract over the various make lines (for example, the
+a.output, b.output, and c.output lines are very similar and
+it would be good to write a program to generate those
+lines).
+			      
+_make.ss_
+---------
+
+The make.ss library in the `make' collection provides a
+`make' macro and a `make/proc' procedure.
+
+> (make ((target (depend ...) command ...) ...) argv)
+
+expands to
+
+  (make/proc
+    (list (list target (list depend ...) (lambda () command ...)) ...)
+    argv)
+
+> (make/proc spec argv) performs a make according to `spec'
+and using `argv' as command-line arguments selecting one
+or more targets.  `argv' can either be a string or a
+vector of strings.
+
+`spec' is a MAKE-SPEC:
+
+  MAKE-SPEC = (list-of MAKE-LINE)
+  MAKE-LINE = (list TARGET (list-of DEPEND-STRING) COMMAND-THUNK)
+  TARGET = (union string (list-of string)) ; either a string or a list of strings
+  DEPEND-STRING = string
+  COMMAND-THUNK = (-> void)
+
+To make a target, make/proc is first called on each of the
+target's dependencies. If a target is not in the spec and it
+exists, then the target is considered made. If a target is
+older than any of its dependencies, the corresponding
+COMMAND-THUNK is invoked. The COMMAND-THUNK is optional; a
+MAKE-LINE without a COMMAND-THUNK is useful as a target for
+making a number of other targets (the dependencies).
+
+`make/proc' catches any exceptions raised by a COMMAND-THUNK
+and wraps them in an exn:fail:make structure, and raises the
+wrapped exn. exn:fail:make structures are defined with:
+
+  (define-struct (exn:fail:make exn:fail) (target orig-exn))
+
+The `target' field is a string or a list of strings naming
+the target(s), and the `orig-exn' field is the original
+exception.
+
+The maker.ss library is a signed unit that requires no
+imports and provdes `make/proc'.
+
+make.ss also provides the following parameters:
+
+> (make-print-checking [on?]) - If #f, make only prints when
+it is making a target. Otherwise, it prints when it is
+checking the dependancies of a target. Defaultly #t.
+
+> (make-print-dep-no-line [on?]) - If #f, make only prints
+"checking..."  lines for dependancies that have a
+corresponding make line.  Defaultly #f.
+
+> (make-print-reasons [on?]) If #t, make prints the reason
+for each dependancy that fires. Defaultly #t.
+
+_collection.ss_
+---------------
+
+ [index entry: _collections, compiling_]
+
+The collection.ss library in the make collection provides a
+`make-collection' procedure.
+
+> (make-collection collection-name collection-files argv) constructs
+and performs a make to compile a collection of Scheme files into a
+multi-file extension. `collection-name' is used as a name that is
+embedded into publicly visible names in the extension (choosing a
+unique `collection-name' for each extension helps avoid conflicts
+among different extensions for certain operating
+systems). `collection-files' is a list of Scheme source files to be
+compiled. `argv' is passed on to `make'.
+
+The resulting extension "_loader" is compiled to the current
+directory's "compiled/native/PLATFORM" subdirectory, where `PLATFORM'
+is replaced by the system name of the current platform. Intermediate
+.c amd .kp files are placed into "compiled/native", and intermediate
+object files are also placed into "compiled/native/PLATFORM".  The .c
+and .kp files are preserved so that thay can be generated once for
+compiling across multiple platforms with the same filesystem.
+
+Make rules are also generated for compiling .zo files, placed in the
+"compiled" directory. The make target "zo" makes all of the .zo
+files. (In other words, pass #("zo") as `argv' to compile .zo files.)
+
+The "compiled", "compiled/native", etc. directories are automatically
+created if they do not already exist. Currently, `make-collection'
+does not try to infer sophisticated file dependencies. Each .c/.kp/.zo
+is dependent just on the .ss source file, each object file is depend
+only on its .c file, and the extension is dependent only on the
+object files.
+
+_setup-extension.ss_
+--------------------
+
+ [index entry: _Setup PLT compile extension_]
+
+The "setup-extension.ss" library helps compile C code via Setup PLT's
+"pre-install" phase (triggered by a `pre-installer' item in "info.ss";
+see the "setup" collection for further information).
+
+The `pre-install' function takes a number of arguments that describe
+how the C code is compiled, mainly the libraries that it depends
+on. It then drives a C compiler via the "dynext" collection functions.
+
+Many issues can complicate C compilation, and the `pre-install'
+function helps with a few:
+
+   * finding non-standard libraries and header files,
+
+   * taming to some degree the differing conventions of Unix and
+     Windows, 
+
+   * setting up suitable dependencies on MzScheme headers, and
+
+   * using a pre-compiled binary when a "precompiled" directory
+     is present.
+
+Many extension installers will have to sort out addition platform
+issues manually, however. For example, the "readline" installer picks
+whether to link to "libcurses" or "libncurses" heuristically by
+inspecting "/usr/lib". More generally, the "last chance" argument to
+`pre-install' allows an installer to patch compiler and linker options
+(see "dynext") before the C code is compiled or linked.
+
+
+> (pre-install plthome-dir
+               collection-dir
+               file.c
+               default-lib-dir
+               include-subdirs
+               find-unix-libs
+               find-windows-libs
+               unix-libs
+               windows-libs
+	       extra-depends
+               last-chance-k)
+
+The arguments are as follows:
+
+  * plthome-dir --- the directory provided to a `pre-installer'
+    function.
+
+  * collection-dir --- a directory to use as the current directory
+    while building.
+
+  * file.c --- the name of the source file (relative to
+    `collection-dir'). The output file will be the same, except with a
+    ".c" suffix replaced with ".so" or ".dll" (depending on the
+    platform) and the path changed to "compiled/native/<platform>".
+
+    If "precompiled/native/<platform>/file.{so,dll} exists", then
+    `file.c' is not used at all, and the file in the "precompiled"
+    directory is simply copied.
+
+  * default-lib-dir --- a default directory for finding supporting
+    libraries, often a subdirectory of `collection-dir'. The user
+    can supplement this path by setting the PLT_EXTENSION_LIB_PATHS
+    environment variable. [Index entry: _PLT_EXTENSION_LIB_PATHS_]
+    This one environment variable applies to all extensions manged
+    by `pre-install'.
+
+  * include-subdirs --- a list of relative paths in which incldue
+    files will be found; the path of the path will be determined
+    through a search, in case it's not in a standard place like
+    /usr/include.
+
+    For example, the list is '("openssl") for the "openssl"
+    collection, because the source uses "#include <openssl/ssl.h>" and
+    "#include <openssl/err.h>".
+
+  * find-unix-libs --- like `include-subdirs', but a list of library
+    bases. Leave off the "lib" prefix and any suffix (such as ".a" or
+    ".zo"). For "openssl", the list is '("ssl" "crypto"). This name
+    will get a "-l" prefix on the link line.
+
+  * find-windows-libs --- like `find-unix-libs', but for Windows.  The
+    library name will be suffixed with ".lib" and supplied directly to
+    the linker.
+
+  * unix-libs --- like `find-unix-libs', except that the installer
+    makes no attempt to find the libraries in a non-standard
+    place. For example, the "readline" installer supplies '("curses").
+
+  * windows-libs --- like `unix-libs', but for Windows. For example,
+    the "openssl" installer supplies '("wsock32").
+
+  * extra-depends --- a list of relative paths to treat as
+    dependencies for compiling `file.c'. Often this list will include
+    `file.c' with the ".c" suffix replaced by ".ss" or ".scm". For
+    example, the "openssl" installer supplies '("mzssl.ss") to ensure
+    that the stub module "mzssl.ss" is never used when the true
+    extension can be built.
+
+  * last-chance-k --- a procedure of one argument, which is a thunk.
+    this procedure should invoke the thunk to make the file, but may
+    add parameterizations before the final build. For example, the
+    "readline" installer adds an AIX-specific compile flag in this
+    step when under AIX.
diff --git a/collects/make/info.ss b/collects/make/info.ss
new file mode 100644
index 0000000000..be6b662916
--- /dev/null
+++ b/collects/make/info.ss
@@ -0,0 +1,4 @@
+
+(module info (lib "infotab.ss" "setup")
+  (define doc.txt "doc.txt")
+  (define name "Make"))
diff --git a/collects/make/make-sig.ss b/collects/make/make-sig.ss
new file mode 100644
index 0000000000..4c52780ab1
--- /dev/null
+++ b/collects/make/make-sig.ss
@@ -0,0 +1,14 @@
+
+(module make-sig mzscheme
+  (require (lib "unitsig.ss"))
+
+  (provide make^)
+
+  (define-signature make^
+    (make/proc
+     make-print-checking
+     make-print-dep-no-line
+     make-print-reasons
+     make-notify-handler
+     (struct exn:fail:make (target orig-exn)))))
+
diff --git a/collects/make/make-unit.ss b/collects/make/make-unit.ss
new file mode 100644
index 0000000000..f79ec3bf3f
--- /dev/null
+++ b/collects/make/make-unit.ss
@@ -0,0 +1,170 @@
+
+(module make-unit mzscheme
+  (require (lib "unitsig.ss"))
+  
+  (require "make-sig.ss")
+
+  (provide make@)
+
+  (define make@
+    (unit/sig make^
+      (import)
+
+      (define-struct (exn:fail:make exn:fail) (target orig-exn))
+      
+      (define make-print-checking (make-parameter #t))
+      (define make-print-dep-no-line (make-parameter #t))
+      (define make-print-reasons (make-parameter #t))
+      (define make-notify-handler (make-parameter void))
+
+      ;(define-type line (list (union path-string (list-of path-string)) (list-of path-string) thunk))
+      ;(define-type spec (list-of line))
+
+      (define (path-string=? a b)
+	(equal? (if (string? a) (string->path a) a)
+		(if (string? b) (string->path b) b)))
+      (define (path-string->string s)
+	(if (string? s)
+            s 
+            (path->string s)))
+
+      ; find-matching-line : path-string spec -> (union line #f)
+      (define (find-matching-line str spec)
+	(let ([match? (lambda (s) (path-string=? s str))])
+	  (let loop ([lines spec])
+	    (cond
+	     [(null? lines) #f]
+	     [else (let* ([line (car lines)]
+			  [names (if (path-string? (car line))
+				     (list (car line))
+				     (car line))])
+		     (if (ormap match? names)
+			 line
+			 (loop (cdr lines))))]))))
+
+      ; form-error : TST TST -> a 
+      (define (form-error s p) (error 'make/proc "~a: ~s" s p))
+
+      ; line-error : TST TST TST -> a 
+      (define (line-error s p n) (error 'make/proc "~a: ~s for line: ~a" s p n))
+
+      ; check-spec : TST -> #t
+      ; effect : calls error if input is not a spec
+      (define (check-spec spec)
+	(and (or (list? spec) (form-error "specification is not a list" spec))
+	     (or (pair? spec) (form-error "specification is an empty list" spec))
+	     (andmap
+	      (lambda (line)
+		(and (or (and (list? line) (<= 2 (length line) 3))
+			 (form-error "list is not a list with 2 or 3 parts" line))
+		     (or (or (path-string? (car line))
+			     (and (list? (car line))
+				  (andmap path-string? (car line))))
+			 (form-error "line does not start with a path/string or list of paths/strings" line))
+		     (let ([name (car line)])
+		       (or (list? (cadr line))
+			   (line-error "second part of line is not a list" (cadr line) name)
+			   (andmap (lambda (dep)
+				     (or (path-string? dep)
+					 (form-error "dependency item is not a path/string" dep name)))
+				   (cadr line)))
+		       (or (null? (cddr line))
+			   (and (procedure? (caddr line))
+				(procedure-arity-includes? (caddr line) 0))
+			   (line-error "command part of line is not a thunk" (caddr line) name)))))
+	      spec)))
+
+      ; check-spec : TST -> #t
+      ; effect : calls error if input is not a (union path-string (vector-of path-string))
+      (define (check-argv argv)
+	(or (path-string? argv)
+	    (and (vector? argv)
+		 (andmap path-string? (vector->list argv)))
+	    (raise-type-error 'make/proc "path/string or path/string vector" argv)))
+
+      ; make/proc/helper : spec (union path-string (vector-of path-string)) -> void
+      ; effect : make, according to spec and argv. See doc.txt for details
+      (define (make/proc/helper spec argv)
+	(check-spec spec)
+	(check-argv argv)
+
+	(letrec ([made null]
+		 [make-file
+		  (lambda (s indent)
+		    (let ([line (find-matching-line s spec)]
+			  [date (and (or (directory-exists? s)
+					 (file-exists? s))
+				     (file-or-directory-modify-seconds s))])
+
+		      (when (and (make-print-checking)
+				 (or line
+				     (make-print-dep-no-line)))
+			(printf "make: ~achecking ~a~n" indent s))
+
+		      (if line
+			  (let ([deps (cadr line)])
+			    (for-each (let ([new-indent (string-append " " indent)])
+					(lambda (d) (make-file d new-indent)))
+				      deps)
+			    (let ([reason
+				   (or (not date)
+				       (ormap (lambda (dep)
+						(unless (or (file-exists? dep)
+							    (directory-exists? dep))
+						  (error 'make "dependancy ~a was not made~n" dep))
+						(and (> (file-or-directory-modify-seconds dep) date)
+						     dep))
+					      deps))])
+			      (when reason
+				(let ([l (cddr line)])
+				  (unless (null? l)
+				    (set! made (cons s made))
+				    ((make-notify-handler) s)
+				    (printf "make: ~amaking ~a~a~n"
+					    (if (make-print-checking) indent "")
+					    (path-string->string s)
+					    (if (make-print-reasons)
+						(cond
+						 [(not date)
+						  (string-append " because " (path-string->string s) " does not exist")]
+						 [(path-string? reason)
+						  (string-append " because " (path-string->string reason) " changed")]
+						 [else
+						  (string-append 
+						   (format " because (reason: ~a date: ~a)" 
+							   reason date))])
+						""))
+				    (with-handlers ([exn:fail?
+						     (lambda (exn)
+						       (raise (make-exn:fail:make 
+							       (string->immutable-string
+								(format "make: Failed to make ~a; ~a"
+									(let ([fst (car line)])
+                                                                          (if (pair? fst)
+                                                                              (map path-string->string fst)
+                                                                              (path-string->string fst)))
+									(if (exn? exn)
+									    (exn-message exn)
+									    exn)))
+							       (if (exn? exn)
+								   (exn-continuation-marks exn)
+								   (current-continuation-marks))
+							       (car line)
+							       exn)))])
+				      ((car l))))))))
+			  (unless date
+			    (error 'make "don't know how to make ~a" (path-string->string s))))))])
+	  (cond
+	   [(path-string? argv) (make-file argv "")]
+	   [(equal? argv #()) (make-file (caar spec) "")]
+	   [else (for-each (lambda (f) (make-file f "")) (vector->list argv))])
+
+	  (for-each (lambda (item)
+		      (printf "make: made ~a~n" (path-string->string item)))
+		    (reverse made))))
+
+      (define make/proc
+	(case-lambda
+	 [(spec) (make/proc/helper spec #())]
+	 [(spec argv) (make/proc/helper spec argv)])))))
+
diff --git a/collects/make/make.ss b/collects/make/make.ss
new file mode 100644
index 0000000000..4e016e9eb5
--- /dev/null
+++ b/collects/make/make.ss
@@ -0,0 +1,45 @@
+
+(module make mzscheme
+  (require (lib "unitsig.ss"))
+
+  (require "make-sig.ss"
+	  "make-unit.ss")
+  
+  (define-values/invoke-unit/sig make^ make@)
+
+  (provide-signature-elements make^)
+
+  (define-syntax make
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ spec)
+	 (syntax (make spec #()))]
+	[(_ spec argv)
+	 (let ([form-error (lambda (s . p) 
+			     (apply raise-syntax-error 'make s stx p))])
+	   (let ([sl (syntax->list (syntax spec))])
+	     (unless (list? sl)
+	       (form-error "illegal specification (not a sequence)"))
+	     (unless (pair? sl)
+	       (form-error "empty specification"))
+	     (andmap
+	      (lambda (line)
+		(let ([ll (syntax->list line)])
+		  (unless (and (list? ll) (>= (length ll) 2))
+		    (form-error "clause does not have at least 2 parts" line))
+		  (let ([name (car ll)])
+		    (unless (syntax->list (cadr ll))
+		      (form-error "second part of clause is not a sequence" (cadr ll))))))
+	      sl)
+	     (with-syntax ([(line ...)
+			    (map (lambda (line)
+				   (syntax-case line () 
+				     [(target deps) (syntax (list target (list . deps)))]
+				     [(target deps . c) (syntax (list target (list . deps)
+								      (lambda () . c)))]))
+				 sl)])
+	       (syntax (make/proc 
+			(list line ...)
+			argv)))))])))
+
+  (provide make))
diff --git a/collects/make/setup-extension.ss b/collects/make/setup-extension.ss
new file mode 100644
index 0000000000..3adf483208
--- /dev/null
+++ b/collects/make/setup-extension.ss
@@ -0,0 +1,197 @@
+
+(module setup-extension mzscheme
+  (require (lib "make.ss" "make")
+	   (lib "link.ss" "dynext")
+	   (lib "compile.ss" "dynext")
+	   (lib "file.ss" "dynext")
+	   (lib "file.ss")
+	   (lib "list.ss")
+	   (lib "process.ss")
+	   (rename (lib "plthome.ss" "setup") plthome* plthome))
+
+  (provide pre-install
+	   with-new-flags)
+
+  ;; Syntax used to add a command-line flag:
+  (define-syntax with-new-flags
+    (syntax-rules ()
+      [(_ param flags body0 body ...)
+       (parameterize ([param (append
+			      (param)
+			      flags)])
+	 body0 body ...)]))
+
+  (define (extract-base-filename file.c)
+    (let-values ([(base name dir?) (split-path (extract-base-filename/c file.c 'pre-install))])
+      name))
+
+  (define (string-path->string s)
+    (if (string? s) s (path->string s)))
+
+  (define (pre-install plthome collection-dir file.c . rest)
+    (let* ([base-dir (build-path collection-dir
+				 "precompiled"
+				 "native"
+				 (system-library-subpath #f))]
+	   [variant-dir (case (link-variant)
+			  [(3m) (build-path base-dir "3m")]
+			  [else base-dir])]
+	   [base-file (extract-base-filename file.c)]
+	   [file.so (build-path variant-dir (append-extension-suffix base-file))])
+      (if (file-exists? file.so)
+	  ;; Just copy pre-compiled file:
+	  (let* ([base-dir (build-path collection-dir
+				       "compiled"
+				       "native"
+				       (system-library-subpath #f))]
+		 [variant-dir (case (link-variant)
+				[(3m) (build-path base-dir "3m")]
+				[else base-dir])]
+		 [dest-file.so (build-path variant-dir (append-extension-suffix base-file))])
+	    (make-directory* variant-dir)
+	    (printf "  Copying ~a~n       to ~a~n" file.so dest-file.so)
+	    (when (file-exists? dest-file.so) 
+	      (delete-file dest-file.so))
+	    (copy-file file.so dest-file.so))
+	  ;; Normal build...
+	  (apply pre-install/normal plthome collection-dir file.c rest))))
+
+  (define (pre-install/normal plthome
+			      collection-dir
+			      file.c
+			      default-lib-dir
+			      include-subdirs
+			      find-unix-libs
+			      find-windows-libs
+			      unix-libs
+			      windows-libs
+			      extra-depends
+			      last-chance-k)
+    (parameterize ([current-directory collection-dir])
+      (define mach-id (string->symbol (path->string (system-library-subpath #f))))
+      (define is-win? (eq? mach-id 'win32\\i386))
+
+      ;; We look for libraries and includes in the 
+      ;;  following places:
+      (define search-path
+	(append
+	 (let ([v (getenv "PLT_EXTENSION_LIB_PATHS")])
+	   (if v 
+	       (path-list-string->path-list v (list default-lib-dir))
+	       (list default-lib-dir)))
+	 (list "/usr"
+	       "/usr/local"
+	       "/usr/local/gnu"
+	       ;; OS X fink location:
+	       "/sw"
+	       ;; Hack for NU PLT's convenience:
+	       "/arch/gnu/packages/readline-4.2")))
+      
+      (define sys-path
+	(ormap (lambda (x)
+		 (and (andmap
+		       (lambda (sub)
+			 (directory-exists? (build-path x "include" sub)))
+		       include-subdirs)
+		      (andmap (lambda (lib)
+				(ormap (lambda (suffix)
+					 (file-exists? 
+					  (build-path x 
+						      "lib"
+						      (format "~a~a.~a" 
+							      (if is-win? 
+								  ""
+								  "lib")
+							      lib 
+							      suffix))))
+				       '("a" "so" "dylib" "lib")))
+			      (if is-win?
+				  find-windows-libs
+				  find-unix-libs))
+		      (if (string? x)
+			  (string->path x)
+			  x)))
+	       search-path))
+
+      (unless sys-path
+	(error 'extension-installer
+	       "can't find needed include files and/or library; try setting the environment variable PLT_EXTENSION_LIB_PATHS"))
+
+      (parameterize ([make-print-checking #f])
+
+	;; Used as make dependencies:
+	(define mz-inc-dir (build-path plthome* "include"))
+	(define headers (map (lambda (name)
+			       (build-path mz-inc-dir name))
+			     '("scheme.h" "schvers.h" "schemef.h" "sconfig.h" "stypes.h")))
+	
+	(define dir (let ([std (build-path "compiled" "native" (system-library-subpath #f))])
+		      (case (link-variant)
+			[(3m) (build-path std "3m")]
+			[else std])))
+	(define base-file (extract-base-filename file.c))
+	(define file.so (build-path dir (append-extension-suffix base-file)))
+	(define file.o (build-path dir (append-object-suffix base-file)))
+
+	(with-new-flags 
+	 current-extension-compiler-flags
+	 (list (format "-I~a" (path->string (build-path sys-path "include"))))
+	  
+	 ;; Add -L and -l for Unix:
+	 (with-new-flags
+	  current-extension-linker-flags 
+	  (if is-win?
+	      null
+	      (list (format "-L~a/lib" (path->string sys-path))))
+	  
+	  ;; Add libs for Windows:
+	  (with-new-flags
+	   current-standard-link-libraries
+	   (if is-win?
+	       (append (map 
+			(lambda (l)
+			  (build-path sys-path "lib" (format "~a.lib" l)))
+			find-windows-libs)
+		       windows-libs)
+	       null)
+
+	   ;; Extra stuff:
+	   (with-new-flags
+	    current-extension-linker-flags 
+	    (case mach-id
+	      [(rs6k-aix) (list "-lc")]
+	      [else null])
+	    
+	    (define (delete/continue x)
+	      (with-handlers ([(lambda (x) #t) void])
+		(delete-file x)))
+	    
+	    (make-directory* dir)
+	    
+	    (last-chance-k
+	     (lambda ()
+	       (make/proc
+		(list (list file.so 
+			    (list file.o)
+			    (lambda ()
+			      (link-extension #f (append (list file.o) 
+							 (if is-win?
+							     null
+							     (map (lambda (l)
+								    (string-append "-l" (string-path->string l)))
+								  (append find-unix-libs unix-libs))))
+					      file.so)))
+		      
+		      (list file.o 
+			    (append (list file.c)
+				    (filter (lambda (x)
+					      (regexp-match #rx#"mzdyn[a-z0-9]*[.]o" 
+							    (if (string? x)
+								x
+								(path->string x))))
+					    (expand-for-link-variant (current-standard-link-libraries)))
+				    headers
+				    extra-depends)
+			    (lambda ()
+			      (compile-extension #f file.c file.o ()))))
+		#())))))))))))
diff --git a/collects/mred/doc.txt b/collects/mred/doc.txt
new file mode 100644
index 0000000000..3ecb6b1932
--- /dev/null
+++ b/collects/mred/doc.txt
@@ -0,0 +1,29 @@
+
+_edit-main.ss_
+
+The edit-main.ss module does not export anything, but invoking the
+module opens an _editor_ frame or frames, based on the
+`current-command-line-arguments' parameter.
+
+In particular, from a command line
+
+   mred -mvqL edit-main.ss <filename> ...
+
+runs a simple editor program. If <filename> is an image file (suffix
+.gif, .xpm, .xbm, .bmp, or .jpg), the editor window display the image.
+
+-----------------------------------------------------------------
+
+_edit.ss_
+
+The edit.ss module exports the following function.
+
+> (new-text-frame file)
+   Creates an editor text frame, initially loading `file' if is it a
+   string. Supply #f as `file' for an initially empty editor.
+
+> (new-pasteboard-frame file)
+  Like `new-text-frame', but for a pasteboard editor.
+
+> (new-frame editor% file)
+  Takes the editor class.
diff --git a/collects/mred/edit-main.ss b/collects/mred/edit-main.ss
new file mode 100644
index 0000000000..2abb1f22e6
--- /dev/null
+++ b/collects/mred/edit-main.ss
@@ -0,0 +1,14 @@
+
+;; Uses editor.ss to open a frame for each argument
+
+(module edit-main mzscheme
+  (require "edit.ss"
+	   (lib "cmdline.ss"))
+
+  (command-line
+   "Edit"
+   (current-command-line-arguments)
+   [args files
+	 (if (null? files)
+	     (new-text-frame #f)
+	     (for-each new-text-frame files))]))
diff --git a/collects/mred/edit.ss b/collects/mred/edit.ss
new file mode 100644
index 0000000000..25d6c48d8b
--- /dev/null
+++ b/collects/mred/edit.ss
@@ -0,0 +1,157 @@
+
+;; Simple editor implementation; provides new-text-frame
+;; and new-pasteboard-frame
+
+(module edit mzscheme
+  (require (lib "class.ss")
+	   (lib "mred.ss" "mred")
+	   (lib "etc.ss"))
+
+  (provide new-text-frame
+	   new-pasteboard-frame
+	   new-frame)
+
+  (define (new-text-frame file) (new-frame text% file))
+  (define (new-pasteboard-frame file) (new-frame pasteboard% file))
+
+  (define new-frame
+    (opt-lambda (editor% file [editor-canvas% editor-canvas%])
+      (define f (make-object (class frame%
+			       (inherit modified)
+			       (define/augment (can-close?)
+				 (and (or (not (modified))
+					  (let ([r (message-box/custom
+						    "Editor Modified"
+						    "The editor has been modified. Really close it?"
+						    "Close"
+						    "Cancel"
+						    "Save and Close"
+						    this
+						    '(default=2 disallow-close))])
+					    (or (and (= r 3)
+						     (send e save-file))
+						(= r 1))))
+				      (inner #t can-close?)))
+			       (super-new))
+			     "MrEdIt" #f 620 450))
+      (define c (make-object editor-canvas% f))
+      (define e (make-object (class editor%
+			       (define/override (set-modified mod?)
+				 (send f modified mod?)
+				 (super set-modified mod?))
+			       (super-new))))
+      (define mb (make-object menu-bar% f))
+
+      (define file-menu (make-object menu% "File" mb))
+      (define edit-menu (make-object menu% "Edit" mb))
+      (define font-menu (make-object menu% "Font" mb))
+      (define para-menu (make-object menu% "Paragraph" mb))
+
+      (make-object menu-item% "New Text Frame" file-menu
+		   (lambda (item event) 
+		     (new-text-frame #f))
+		   #\N)
+      (make-object menu-item% "New Pasteboard Frame" file-menu
+		   (lambda (item event) 
+		     (new-pasteboard-frame #f)))
+
+      (make-object menu-item% "Open..." file-menu
+		   (lambda (item event) 
+		     (send e load-file ""))
+		   #\O)
+      (make-object menu-item% "Save As..." file-menu
+		   (lambda (item event) 
+		     (send e save-file ""))
+		   #\S)
+      (when (eq? editor% text%)
+	(make-object menu-item% "Save As Text..." file-menu
+		     (lambda (item event) 
+		       (send e save-file "" 'text))))
+      (make-object separator-menu-item% file-menu)
+      (make-object menu-item% "Print..." file-menu
+		   (lambda (item event)
+		     (send e print))
+		   #\P)
+      (make-object separator-menu-item% file-menu)
+      (make-object menu-item% "Close" file-menu
+		   (lambda (item event)
+		     (when (send f can-close?)
+		       (send f on-close)
+		       (send f show #f)))
+		   #\Q)
+
+      (append-editor-operation-menu-items edit-menu #f)
+      (when (eq? editor% text%)
+	(make-object separator-menu-item% edit-menu)
+	(make-object checkable-menu-item% "Wrap Lines" edit-menu
+		     (lambda (item event)
+		       (send e auto-wrap (send item is-checked?)))))
+
+      (append-editor-font-menu-items font-menu)
+      (let ([m (make-object menu% "Smoothing" font-menu)])
+	(let ([mk (lambda (name v)
+		    (make-object menu-item% name m
+				 (lambda (i e)
+				   (let* ([o (send f get-edit-target-object)])
+				     (and o
+					  (o . is-a? . editor<%>)
+					  (send o change-style 
+						(make-object style-delta% 'change-smoothing v)))))))])
+	  (mk "Default" 'default)
+	  (mk "Partly Smoothed" 'partly-smoothed)
+	  (mk "Smoothed" 'smoothed)
+	  (mk "Not Smoothed" 'unsmoothed)))
+
+      (make-object menu-item% "Set Margins..." para-menu
+		   (lambda (i ev)
+		     (let* ([d (make-object dialog% "Margins" f)]
+			    [mk-txt (lambda (label) (make-object 
+						     text-field%
+						     label
+						     d
+						     void
+						     "0.0"))]
+			    [first-left (mk-txt "First Left")]
+			    [rest-left (mk-txt "Rest Left")]
+			    [right (mk-txt "Right")]
+			    [button-panel (new horizontal-pane% 
+					       [parent d]
+					       [alignment '(right center)])]
+			    [ok (make-object button% "Ok" button-panel
+					     (lambda (b ev)
+					       (let* ([get (lambda (field)
+							     (let ([n (string->number (send field get-value))])
+							       (and n (real? n) (not (negative? n)) n)))]
+						      [first-left (get first-left)]
+						      [rest-left (get rest-left)]
+						      [right (get right)])
+						 (if (and first-left
+							  rest-left
+							  right)
+						     (let ([start (send e position-paragraph
+									(send e get-start-position))]
+							   [end  (send e position-paragraph
+								       (send e get-end-position))])
+						       (let loop ([i start])
+							 (unless (i . > . end)
+							   (send e set-paragraph-margins 
+								 i first-left rest-left right)
+							   (loop (add1 i)))
+							 (send d show #f)))
+						     (bell))))
+					     '(border))]
+			    [cancel (make-object button% "Cancel" button-panel
+						 (lambda (b e)
+						   (send d show #f)))])
+		       (send d show #t))))
+
+      ((current-text-keymap-initializer) (send e get-keymap))
+      (send c set-editor e)
+
+      (when file
+	(if (regexp-match "[.](gif|bmp|jpe?g|xbm|xpm|png)$" file)
+	    (send e insert (make-object image-snip% file))
+	    (send e load-file file)))
+      
+      (send f show #t)
+      f)))
diff --git a/collects/mred/info.ss b/collects/mred/info.ss
new file mode 100644
index 0000000000..fce016c789
--- /dev/null
+++ b/collects/mred/info.ss
@@ -0,0 +1,6 @@
+
+(module info (lib "infotab.ss" "setup")
+  (define doc.txt "doc.txt")
+  (define name "MrEd")
+  (define version '(200))
+  (define post-install-collection "script-installer.ss"))
diff --git a/collects/mred/mred-sig.ss b/collects/mred/mred-sig.ss
new file mode 100644
index 0000000000..13e677f7e2
--- /dev/null
+++ b/collects/mred/mred-sig.ss
@@ -0,0 +1,208 @@
+
+(module mred-sig mzscheme
+  (require (lib "unitsig.ss"))
+
+  (provide mred^)
+  (define-signature
+    mred^
+    (add-color<%>
+     add-editor-keymap-functions
+     add-pasteboard-keymap-functions
+     add-text-keymap-functions
+     append-editor-font-menu-items
+     append-editor-operation-menu-items
+     application-about-handler
+     application-file-handler
+     application-preferences-handler
+     application-quit-handler
+     area-container-window<%>
+     area-container<%>
+     area<%>
+     begin-busy-cursor
+     bell
+     bitmap%
+     bitmap-dc%
+     brush%
+     brush-list%
+     button%
+     can-get-page-setup-from-user?
+     canvas%
+     canvas<%>
+     check-box%
+     check-for-break
+     checkable-menu-item%
+     choice%
+     clipboard-client%
+     clipboard<%>
+     color%
+     color-database<%>
+     combo-field%
+     control-event%
+     control<%>
+     current-eventspace
+     current-eventspace-has-standard-menus?
+     current-ps-afm-file-paths
+     current-ps-cmap-file-paths
+     current-ps-setup
+     current-text-keymap-initializer
+     cursor%
+     dc<%>
+     dc-path%
+     dialog%
+     editor-admin%
+     editor-canvas%
+     editor-data%
+     editor-data-class%
+     editor-data-class-list<%>
+     editor-set-x-selection-mode
+     editor-snip%
+     editor-snip-editor-admin<%>
+     editor-stream-in%
+     editor-stream-in-base%
+     editor-stream-in-bytes-base%
+     editor-stream-out%
+     editor-stream-out-base%
+     editor-stream-out-bytes-base%
+     editor-wordbreak-map%
+     editor<%>
+     end-busy-cursor
+     event%
+     event-dispatch-handler
+     eventspace-handler-thread
+     eventspace-shutdown?
+     eventspace?
+     file-creator-and-type
+     find-graphical-system-path
+     flush-display
+     font%
+     font-list%
+     font-name-directory<%>
+     frame%
+     gauge%
+     get-choices-from-user
+     get-color-from-user
+     get-directory
+     get-display-depth
+     get-display-left-top-inset
+     get-display-size
+     get-face-list
+     get-family-builtin-face
+     get-file
+     get-file-list
+     get-font-from-user
+     get-page-setup-from-user
+     get-panel-background
+     get-ps-setup-from-user
+     get-resource
+     get-text-from-user
+     get-the-editor-data-class-list
+     get-the-snip-class-list
+     get-top-level-edit-target-window
+     get-top-level-focus-window
+     get-top-level-windows
+     get-window-text-extent
+     gl-config%
+     gl-context<%>
+     graphical-read-eval-print-loop
+     group-box-panel%
+     grow-box-spacer-pane%
+     hide-cursor-until-moved
+     horizontal-pane%
+     horizontal-panel%
+     tab-panel%
+     image-snip%
+     is-busy?
+     is-color-display?
+     key-event%
+     keymap%
+     label->plain-label
+     labelled-menu-item<%>
+     list-box%
+     list-control<%>
+     make-eventspace
+     make-namespace-with-mred
+     menu%
+     menu-bar%
+     menu-control-font
+     menu-item%
+     menu-item-container<%>
+     menu-item<%>
+     message%
+     message-box
+     message+check-box
+     message-box/custom
+     message+check-box/custom
+     mouse-event%
+     ;; mred@
+     mult-color<%>
+     normal-control-font
+     open-input-graphical-file
+     open-input-text-editor
+     pane%
+     panel%
+     pasteboard%
+     pen%
+     pen-list%
+     play-sound
+     point%
+     popup-menu%
+     post-script-dc%
+     printer-dc%
+     ps-setup%
+     put-file
+     queue-callback
+     radio-box%
+     readable-snip<%>
+     read-editor-global-footer
+     read-editor-global-header
+     read-editor-version
+     region%
+     register-collecting-blit
+     scroll-event%
+     selectable-menu-item<%>
+     send-event
+     send-message-to-window
+     separator-menu-item%
+     sleep/yield
+     slider%
+     small-control-font
+     snip%
+     snip-admin%
+     snip-class%
+     snip-class-list<%>
+     special-control-key
+     special-option-key
+     string-snip%
+     style-delta%
+     style-list%
+     style<%>
+     subarea<%>
+     subwindow<%>
+     tab-snip%
+     text%
+     text-editor-load-handler
+     text-field%
+     the-brush-list
+     the-clipboard
+     the-color-database
+     the-editor-wordbreak-map
+     the-font-list
+     the-font-name-directory
+     the-pen-list
+     the-style-list
+     the-x-selection-clipboard
+     timer%
+     tiny-control-font
+     top-level-window<%>
+     unregister-collecting-blit
+     vertical-pane%
+     vertical-panel%
+     view-control-font
+     window<%>
+     write-editor-global-footer
+     write-editor-global-header
+     write-editor-version
+     write-resource
+     yield
+     )))
+
diff --git a/collects/mred/mred.ss b/collects/mred/mred.ss
new file mode 100644
index 0000000000..4428422598
--- /dev/null
+++ b/collects/mred/mred.ss
@@ -0,0 +1,294 @@
+(module mred mzscheme
+  (require (lib "etc.ss")
+	   (prefix wx: "private/kernel.ss")
+	   "private/wxtop.ss"
+	   "private/app.ss"
+	   "private/misc.ss"
+	   "private/mrwindow.ss"
+	   "private/mrcontainer.ss"
+	   "private/mrtop.ss"
+	   "private/mrpanel.ss"
+	   "private/mrcanvas.ss"
+	   "private/mritem.ss"
+	   "private/mrtextfield.ss"
+	   "private/mrmenuintf.ss"
+	   "private/mrmenu.ss"
+	   "private/mrpopup.ss"
+	   "private/editor.ss"
+	   "private/messagebox.ss"
+	   "private/filedialog.ss"
+	   "private/fontdialog.ss"
+	   "private/moredialogs.ss"
+	   "private/gdi.ss"
+	   "private/snipfile.ss"
+	   "private/repl.ss"
+	   "private/afm.ss")
+
+  ;; Initialize AFM/PS:
+  (wx:set-ps-procs
+   afm-draw-text
+   afm-get-text-extent
+   afm-expand-name
+   afm-glyph-exists?)
+  
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (wx:set-dialogs get-file put-file get-ps-setup-from-user message-box)
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  
+  (define mred-module-name ((current-module-name-resolver)
+			    '(lib "mred.ss" "mred") #f #f))
+  (define class-module-name ((current-module-name-resolver)
+			     '(lib "class.ss") #f #f))
+
+  (define make-namespace-with-mred
+    (opt-lambda ([flag 'mred])
+      (unless (memq flag '(initial mred empty))
+	(raise-type-error 'make-namespace-with-mred
+			  "flag symbol, one of 'mred, 'initial, or 'empty"
+			  flag))
+      (let ([orig (current-namespace)]
+	    [ns (make-namespace (if (eq? flag 'empty) 'empty 'initial))])
+	(parameterize ([current-namespace ns])
+	  (namespace-attach-module orig mred-module-name)
+	  (when (eq? flag 'mred)
+	    (namespace-require mred-module-name)
+	    (namespace-require class-module-name)))
+	ns)))
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (define-syntax propagate
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ n ...)
+	 (let ([ns (syntax->list (syntax (n ...)))])
+	   (with-syntax ([(k:n ...)
+			  (map
+			   (lambda (n)
+			     (datum->syntax-object
+			      n
+			      (string->symbol
+			       (format 
+				"wx:~a"
+				(syntax-e n)))
+			      #f))
+			   ns)])
+	     (syntax (begin
+		       ;; We can't just re-export, because kernel.ss's
+		       ;;  exports are protected.
+		       (define n k:n) ...
+		       (provide n ...)))))])))
+
+  (propagate add-color<%>
+	     add-editor-keymap-functions
+	     add-text-keymap-functions
+	     add-pasteboard-keymap-functions
+	     begin-busy-cursor
+	     bell
+	     bitmap%
+	     brush%
+	     brush-list%
+	     editor-data%
+	     editor-data-class%
+	     editor-data-class-list<%>
+	     check-for-break
+	     clipboard<%>
+	     clipboard-client%
+	     color%
+	     color-database<%>
+	     control-event%
+	     current-eventspace
+	     current-ps-setup
+	     cursor%
+	     dc<%>
+	     dc-path%
+	     get-display-depth
+	     end-busy-cursor
+	     event%
+	     event-dispatch-handler
+	     eventspace?
+	     find-graphical-system-path
+	     flush-display
+	     font%
+	     font-list%
+	     font-name-directory<%>
+	     get-face-list
+	     get-resource
+	     get-the-editor-data-class-list
+	     get-the-snip-class-list
+	     image-snip%
+	     is-busy?
+	     is-color-display?
+	     key-event%
+	     keymap%
+	     make-eventspace
+	     editor-admin%
+	     editor-set-x-selection-mode
+	     editor-snip-editor-admin<%>
+	     editor-stream-in%
+	     editor-stream-in-base%
+	     editor-stream-in-bytes-base%
+	     editor-stream-out%
+	     editor-stream-out-base%
+	     editor-stream-out-bytes-base%
+	     editor-wordbreak-map%
+	     mouse-event%
+	     mult-color<%>
+	     pen%
+	     pen-list%
+	     point%
+	     ps-setup%
+	     read-editor-global-footer
+	     read-editor-global-header
+	     read-editor-version
+	     region%
+	     scroll-event%
+	     snip%
+	     snip-admin%
+	     snip-class%
+	     snip-class-list<%>
+	     special-control-key
+	     special-option-key
+	     label->plain-label
+	     string-snip%
+	     style<%>
+	     style-delta%
+	     style-list%
+	     tab-snip%
+	     write-editor-global-footer
+	     write-editor-global-header
+	     write-editor-version
+	     write-resource
+	     queue-callback
+	     yield
+	     eventspace-shutdown?
+	     get-panel-background
+	     send-event
+	     gl-context<%>
+	     gl-config%)
+
+  (define the-color-database (wx:get-the-color-database))
+  (define the-font-name-directory (wx:get-the-font-name-directory))
+  (define the-clipboard (wx:get-the-clipboard))
+  (define the-x-selection-clipboard (wx:get-the-x-selection))
+  (define the-font-list (wx:get-the-font-list))
+  (define the-pen-list (wx:get-the-pen-list))
+  (define the-brush-list (wx:get-the-brush-list))
+  (define the-style-list (wx:get-the-style-list))
+  (define the-editor-wordbreak-map (wx:get-the-editor-wordbreak-map))
+
+  (provide button%
+	   canvas%
+	   check-box%
+	   choice%
+	   dialog%
+	   frame%
+	   gauge%
+	   tab-panel%
+	   group-box-panel%
+	   list-box%
+	   editor-canvas%
+	   message%
+	   pane%
+	   horizontal-pane%
+	   vertical-pane%
+	   grow-box-spacer-pane%
+	   panel%
+	   horizontal-panel%
+	   vertical-panel%
+	   radio-box%
+	   slider%
+	   text-field%
+	   combo-field%
+	   window<%>
+	   area<%>
+	   top-level-window<%>
+	   subarea<%>
+	   subwindow<%>
+	   area-container<%>
+	   area-container-window<%>
+	   canvas<%>
+	   control<%>
+	   list-control<%>
+	   menu-item<%>
+	   separator-menu-item%
+	   selectable-menu-item<%>
+	   labelled-menu-item<%>
+	   menu-item%
+	   checkable-menu-item%
+	   menu-item-container<%>
+	   menu%
+	   menu-bar%
+	   popup-menu%
+	   get-top-level-windows
+	   editor-snip%
+	   editor<%>
+	   text%
+	   pasteboard%
+	   graphical-read-eval-print-loop
+	   message-box
+	   message+check-box
+	   message-box/custom
+	   message+check-box/custom
+	   get-file
+	   get-file-list
+	   put-file
+	   get-directory
+	   get-choices-from-user
+	   get-text-from-user
+	   get-ps-setup-from-user
+	   get-page-setup-from-user
+	   can-get-page-setup-from-user?
+	   play-sound
+	   get-display-size
+	   get-display-left-top-inset
+	   get-color-from-user
+	   get-font-from-user
+	   append-editor-operation-menu-items
+	   append-editor-font-menu-items
+	   get-top-level-focus-window
+	   get-top-level-edit-target-window
+	   register-collecting-blit
+	   unregister-collecting-blit
+	   bitmap-dc%
+	   post-script-dc%
+	   printer-dc%
+	   current-text-keymap-initializer
+	   sleep/yield
+	   get-window-text-extent
+	   get-family-builtin-face
+	   send-message-to-window
+	   the-clipboard
+	   the-x-selection-clipboard
+	   the-editor-wordbreak-map
+	   the-brush-list
+	   the-color-database
+	   the-font-name-directory
+	   the-pen-list
+	   the-font-list
+	   the-style-list
+	   normal-control-font
+	   small-control-font
+	   tiny-control-font
+	   view-control-font
+	   menu-control-font
+	   timer%
+	   readable-snip<%>
+	   open-input-text-editor
+	   open-input-graphical-file
+	   open-output-text-editor
+	   text-editor-load-handler
+	   application-about-handler
+	   application-preferences-handler
+	   application-quit-handler
+	   application-file-handler
+	   current-eventspace-has-standard-menus?
+	   current-eventspace-has-menu-root?
+	   eventspace-handler-thread
+	   make-namespace-with-mred
+	   file-creator-and-type
+	   current-ps-afm-file-paths
+	   current-ps-cmap-file-paths
+	   hide-cursor-until-moved))
diff --git a/collects/mred/private/afm.ss b/collects/mred/private/afm.ss
new file mode 100644
index 0000000000..35b516ee78
--- /dev/null
+++ b/collects/mred/private/afm.ss
@@ -0,0 +1,632 @@
+(module afm mzscheme
+  (require (lib "file.ss")
+	   (lib "list.ss"))
+
+  (provide (protect afm-draw-text
+		    afm-get-text-extent
+		    afm-expand-name
+		    afm-glyph-exists?)
+	   current-ps-afm-file-paths
+	   current-ps-cmap-file-paths)
+
+  (define orig-err (current-error-port))
+  (define (report-exn exn)
+    (fprintf orig-err "PostScript/AFM error: ~a~n"
+	     (if (exn? exn)
+		 (exn-message exn)
+		 exn)))
+
+  (define bytes->number
+    (case-lambda
+     [(s) (bytes->number s 10)]
+     [(s r) (string->number (bytes->string/latin-1 s) r)]))
+
+  ;; ------------------------------------------------------------
+  ;; Paths
+
+  (define (check-paths who)
+    (lambda (l)
+      (unless (and (list? l)
+		   (andmap path-string? l))
+	(raise-type-error who "list of paths/strings" l))
+      (apply list-immutable
+	     (map (lambda (i)
+		    (if (string? i) (string->path i) i))
+		  l))))
+
+  ;; Paths that users can set
+  ;;  Location of .afm files:
+  (define afm-home
+    (with-handlers ([exn:fail:filesystem? (lambda (x) (current-directory))])
+      (collection-path "afm")))
+  (define current-ps-afm-file-paths
+    (make-parameter (path-list-string->path-list 
+		     (or (getenv "PLTAFMPATHS") "")
+		     (list afm-home))
+		    (check-paths 'current-post-script-afm-file-paths)))
+  ;;  Location of CMap files (for CID fonts)
+  (define current-ps-cmap-file-paths
+    (make-parameter (path-list-string->path-list 
+		     (or (getenv "PLTCMAPPATHS") "")
+		     (list (build-path afm-home "CMap")))
+		    (check-paths 'current-post-script-cmap-file-paths)))
+
+  (define (find-path l f)
+    (or (ormap (lambda (d)
+		 (let ([f (build-path d f)])
+		   (and (file-exists? f)
+			f)))
+	       l)
+	(error 'find-path "file not found: ~e in dirs: ~e" f l)))
+
+  ;; ------------------------------------------------------------
+  ;; Adobe <-> Unicode
+
+  ;; Table mapping PS char names (as bytes) to Unicode integers.
+  ;;  It's loaded on demand.
+  (define adobe-name-to-code-point #f)
+  ;; In fact, we load a small table at first, and
+  ;;  only load the full PS char name table if needed;
+  ;;  the following flag indicated whether the full
+  ;;  table has been loaded.
+  (define got-long-name-list? #f)
+
+  ;; Reads the Adobe char name -> Unicode table
+  (define (read-names! gl.txt long?)
+    (let ([ht (make-hash-table 'equal)])
+      (with-handlers ([exn:fail? report-exn])
+	(call-with-input-file* 
+	 (find-path (current-ps-afm-file-paths) gl.txt)
+	 (lambda (i)
+	   (let loop ()
+	     (let ([l (read-bytes-line i)])
+	       (unless (eof-object? l)
+		 (let ([m (regexp-match #rx#"^([a-zA-Z0-9_-]+);([0-9a-fA-F][0-9a-fA-F][0-9a-fA-F][0-9a-fA-F])$"
+					l)])
+		   (when m
+		     (hash-table-put! ht
+				      (cadr m)
+				      (bytes->number (caddr m) 16))))
+		 (loop)))))))
+      (set! adobe-name-to-code-point ht)
+      (set! got-long-name-list? long?)))
+
+  ;; Maps Adbobe char name to Unicode, loading the table as necesary
+  (define (find-unicode name)
+    (unless adobe-name-to-code-point
+      (read-names! "glyphshortlist.txt" #f))
+    (hash-table-get adobe-name-to-code-point
+		    name
+		    (lambda ()
+		      (if got-long-name-list?
+			  #f
+			  (begin
+			    (read-names! "glyphlist.txt" #t)
+			    (find-unicode name))))))
+
+  
+  ;; ------------------------------------------------------------
+  ;; CMap
+
+  ;; read-cmap : path hash-table-or-false -> hash-table[int->int]
+  ;;  A CMap file maps from one character encoding (e.g., Adobe-CNS1-0)
+  ;;  to another (e.g., UTF-16). We'll always have to read one
+  ;;  UTF-32 -> Adobe-CNS table (invert it), and then use that
+  ;;  when reading any other XXX -> Adobe-CNS to generate an 
+  ;;  XXX -> UTF-32 table.
+  (define (read-cmap file to-unicode)
+    (let* ([ht (make-hash-table 'equal)]
+	   [put! (if to-unicode
+		     (lambda (c cns)
+		       (hash-table-put! ht 
+					c
+					(hash-table-get to-unicode cns
+							(lambda () #f))))
+		     (lambda (c cns)
+		       (hash-table-put! ht cns c)))])
+      (with-handlers ([exn:fail? report-exn])
+	(call-with-input-file* 
+	 file
+	 (lambda (i)
+	   (let loop ()
+	     (let ([l (read-bytes-line i)])
+	       (cond
+		[(eof-object? l) (void)]
+		[(regexp-match #rx#"begincidchar" l)
+		 (let char-loop ()
+		   (let ([l (read-bytes-line i)])
+		     (cond
+		      [(regexp-match #rx#"endcidchar" l)
+		       (loop)]
+		      [(regexp-match #rx#"^<([0-9A-Fa-f]*)> *([0-9]+)$" l)
+		       => (lambda (m)
+			    (put! (bytes->number (cadr m) 16)
+				  (bytes->number (caddr m)))
+			    (char-loop))]
+		      [else
+		       ;; parse error
+		       (char-loop)])))]
+		[(regexp-match #rx#"begincidrange" l)
+		 (let range-loop ()
+		   (let ([l (read-bytes-line i)])
+		     (cond
+		      [(regexp-match #rx#"endcidrange" l)
+		       (loop)]
+		      [(regexp-match #rx#"^<([0-9A-Fa-f]+)> <([0-9A-Fa-f]+)> *([0-9]+)$" l)
+		       => (lambda (m)
+			    (let* ([end (bytes->number (caddr m) 16)])
+			      (let loop ([start (bytes->number (cadr m) 16)]
+					 [v (bytes->number (cadddr m))])
+				(put! start v)
+				(unless (= start end)
+				  (loop (add1 start) (add1 v)))))
+			    (range-loop))]
+		      [else
+		       ;; parse error
+		       (range-loop)])))]
+		[else (loop)]))))))
+      ht))
+
+  (define cns->unicode-table #f)
+  (define (read-cns->unicode!)
+    (set! cns->unicode-table
+	  (read-cmap
+	   (find-path (current-ps-cmap-file-paths) "UniCNS-UTF32-H")
+	   #f)))
+  
+  (define cmap-table (make-hash-table 'equal))
+  (define (get-cmap name)
+    (unless cns->unicode-table
+      (read-cns->unicode!))
+    (hash-table-get
+     cmap-table
+     name
+     (lambda ()
+       (let ([t (read-cmap
+		 (find-path (current-ps-cmap-file-paths) (bytes->path name))
+		 cns->unicode-table)])
+	 (hash-table-put! cmap-table name t)
+	 t))))
+
+  ;; ----------------------------------------
+  ;; AFM
+
+  ;; An achar is either
+  ;;  - (cons num-or-bytes num)
+  ;;  - (list num-or-bytes num ligature-assoc kern-assoc)
+
+  (define make-achar
+    (case-lambda
+     [(enc width ligatures)
+      (if (null? ligatures)
+	  (cons enc width)
+	  (list enc width ligatures null))]
+     [(enc width) (cons enc width)]))
+  (define achar-enc car)   ; Number (unicode or CID) or bytes (Adobe char name)
+  (define achar-width ; Integer, 0 to 1000
+    (lambda (x)
+      (if (pair? (cdr x))
+	  (cadr x)
+	  (cdr x))))
+  (define achar-ligatures
+    (lambda (x)
+      (if (pair? (cdr x))
+	  (caddr x)
+	  null)))
+  (define achar-kerns
+    (lambda (x)
+      (if (pair? (cdr x))
+	  (cadddr x)
+	  null)))
+  (define (strip-ligatures-and-kerning achar)
+    (make-achar (achar-enc achar) (achar-width achar)))
+  (define (achar-add-kern! achar v amt)
+    (when (not (pair? (cdr achar)))
+      (set-cdr! achar (list (cdr achar) null null)))
+    (set-car! (cdddr achar) (cons (cons v amt) (cadddr achar))))
+
+  (define-struct font (descent ascent achars is-cid? char-set-name))
+
+  (define re:hex #rx#"^<[0-9a-fA-F]>$")
+
+  (define (parse-afm file)
+    (let ([descender #f]
+	  [bbox-down #f]
+	  [cap-height #f]
+	  [achars (make-hash-table 'equal)]
+	  [kern-pairs null]
+	  [char-set #f]
+	  [char-set-name #f]
+	  [is-cid? #f])
+      (parameterize ([read-case-sensitive #f])
+	(call-with-input-file*
+	 file
+	 (lambda (i)
+	   (let loop ()
+	     (let ([n (read i)])
+	       (unless (eof-object? n)
+		 (case n
+		   [(descender) (set! descender (read i))]
+		   [(fontbbox) (let ([l (read i)]
+				     [t (read i)]
+				     [r (read i)]
+				     [b (read i)])
+				 (set! bbox-down t))]
+		   [(capheight) (set! cap-height (read i))]
+		   [(characterset) (let ([m (regexp-match #rx#"[a-zA-Z_0-9-]+" (read-bytes-line i))])
+				     (when m
+				       (set! char-set-name (car m))
+				       (set! char-set (get-cmap char-set-name))))]
+		   [(iscidfont) (set! is-cid?
+				      (regexp-match #rx#"true" (read-bytes-line i)))]
+		   [(startcharmetrics)
+		    (let ([cnt (read i)])
+		      (let loop ()
+			(let ([n (read i)])
+			  (when (or (eq? n 'c)
+				    (eq? n 'ch))
+			    (let ([v (read i)]
+				  [rest (read-bytes-line i)])
+			      (let ([nm (regexp-match #rx#"; *N +([a-zA-Z0-9]+) *;" rest)]
+				    [wm (regexp-match #rx#"; *W.?X +([0-9]+) *;" rest)])
+				(when (or (and (eq? n 'c)
+					       (integer? v))
+					  (and (eq? n 'ch)
+					       (symbol? v)
+					       (regexp-match #rx#"^<[0-9a-fA-F]>$" (symbol->string v))))
+				  (let ([name (or (and nm 
+						       (if is-cid?
+							   (bytes->number (cadr nm))
+							   (cadr nm)))
+						  0)])
+				    (hash-table-put!
+				     achars
+				     (if (and char-set is-cid?)
+					 (hash-table-get char-set name (lambda () 0))
+					 (find-unicode name))
+				     (make-achar
+				      (let ([v (if (eq? n 'c)
+						   v
+						   (let ([s (symbol->string v)])
+						     (string->number (substring s 1 (sub1 (string-length s))) 16)))])
+					(if (= v -1)
+					    name
+					    v))
+				      (or (and wm (bytes->number (cadr wm))) 500)
+				      (extract-ligatures rest)))))))
+			    (loop)))))]
+		   [(startkernpairs)
+		    (let ([cnt (read i)])
+		      (let loop ()
+			(let ([kp (read i)])
+			  (when (or (eq? kp 'kp)
+				    (eq? kp 'kpx))
+			    (let ([v1 (parameterize ([read-case-sensitive #t])
+					(read i))]
+				  [v2 (parameterize ([read-case-sensitive #t])
+					(read i))]
+				  [amt (read i)])
+			      (read-bytes-line i)
+			      (let ([v1 (find-unicode (string->bytes/utf-8 (symbol->string v1)))]
+				    [v2 (find-unicode (string->bytes/utf-8 (symbol->string v2)))])
+				(set! kern-pairs (cons (list v1 v2 amt) kern-pairs))))
+			    (loop)))))]
+		   [else (read-bytes-line i)])
+		 (loop)))))))
+      (for-each (lambda (kp)
+		  (let ([c1 (car kp)]
+			[c2 (cadr kp)]
+			[amt (caddr kp)])
+		    (let ([achar (hash-table-get achars c1 (lambda () (make-achar 0 0)))])
+		      (achar-add-kern! achar c2 amt))))
+		kern-pairs)
+      (make-font (- (or descender bbox-down 0))
+		 (or cap-height 1000)
+		 achars
+		 (and char-set #t)
+		 char-set-name)))
+
+  (define (extract-ligatures rest)
+    (let ([m (regexp-match #rx#"; *L +([a-zA-Z0-9-]+) +([a-zA-Z0-9-]+)(.*)$" rest)])
+      (if m
+	  (let ([next (cadr m)]
+		[ligature (caddr m)]
+		[rest (cadddr m)])
+	    (cons (cons (find-unicode next)
+			(find-unicode ligature))
+		  (extract-ligatures rest)))
+	  null)))
+
+  (define fonts (make-hash-table 'equal))
+
+  (define (get-font name)
+    (hash-table-get fonts name
+		    (lambda ()
+		      (hash-table-put! fonts
+				       name
+				       (with-handlers ([void (lambda (exn)
+							       (report-exn exn)
+							       #f)])
+					 (parse-afm 
+					  (find-path (current-ps-afm-file-paths)
+						     (format "~a.afm" name)))))
+		      (get-font name))))
+
+  ;; ----------------------------------------
+
+  (define font-list #f)
+  (define (get-all-fonts)
+    (or font-list
+	(begin
+	  (set! font-list
+		(apply append (map (lambda (dir)
+				     (map (lambda (s)
+					    (path->string (path-replace-suffix s #"")))
+					  (filter (lambda (s)
+						    (regexp-match #rx"[.][aA][fF][mM]$" (path->string s)))
+						  (directory-list dir))))
+				   (current-ps-afm-file-paths))))
+	  font-list)))
+
+  ;; ----------------------------------------
+
+  (define symbol-map
+    #(0 0 0 0 0 0 0 0
+	0 0 0 0 0 0 0 0
+	0 0 0 0 0 0 0 0
+	0 0 0 0 0 0 0 0
+	0 0 8704 0 8707 0 0 8717
+	0 0 8727 0 0 8722 0 0
+	0 0 0 0 0 0 0 0
+	0 0 0 0 0 0 0 0
+	8773 913 914 935 916 917 934 915
+	919 921 977 922 923 924 925 927
+	928 920 929 931 932 933 962 937
+	926 936 918 0 8756 0 8869 0
+	0 945 946 967 948 949 966 947
+	951 953 981 954 955 956 957 959
+	960 952 961 963 964 965 982 969
+	958 968 950 0 0 0 8764 0
+	0 0 0 0 0 0 0 0
+	0 0 0 0 0 0 0 0
+	0 0 0 0 0 0 0 0
+	0 0 0 0 0 0 0 0
+	0 978 8242 8804 8260 8734 402 9827
+	9830 9829 9824 8596 8592 8593 8594 8595
+	0 177 8243 8805 215 8733 8706 8729
+	247 8800 8801 8776 8230 9168 8212 8629
+	8501 8465 8476 8472 8855 8853 8709 8745
+	8746 8835 8839 8836 8834 8838 8712 8713
+	8736 8711 174 169 8482 8719 8730 8901
+	172 8743 8744 8660 8656 8657 8658 8659
+	9674 9001 174 169 8482 8721 9115 9116
+	9117 9121 9122 9123 9127 9128 9129 9130
+	8364 9002 8747 8992 9134 8993 9118 9119
+	9120 9124 9125 9126 9131 9132 9133 0))
+
+  (define (map-symbols sym-map? l)
+    (if sym-map?
+	(map (lambda (c)
+	       (let ([v (char->integer c)])
+		 (if (<= 0 v 255)
+		     (integer->char (vector-ref symbol-map v))
+		     c)))
+	     l)
+	l))
+
+  ;; ----------------------------------------
+  ;; Draw/measure text
+
+  (define (afm-get-text-extent font-name size string kern? sym-map?)
+    (let* ([font (or (get-font font-name)
+		     (make-font 0 1000 #hash() #f #f))]
+	   [scale (/ size 1000.0)]
+	   [descent (* scale (font-descent font))])
+      (values (* scale
+		 (let loop ([cl (map-symbols sym-map? (string->list string))][width 0])
+		   (cond
+		    [(empty? cl) width]
+		    [else (let ([achar (hash-table-get 
+					(font-achars font)
+					(char->integer (car cl))
+					(lambda ()
+					  (find-substitute 
+					   (car cl)
+					   (lambda (name font achar)
+					     (strip-ligatures-and-kerning achar))
+					   (lambda ()
+					     (make-achar 0 500)))))])
+			    (cond
+			     [(and kern?
+				   (pair? (cdr cl))
+				   (assoc (char->integer (cadr cl))
+					  (achar-ligatures achar)))
+			      => (lambda (p)
+				   ;; Replace the first two characters with a
+				   ;; ligature and try again
+				   (loop (cons (integer->char (cdr p)) (cddr cl)) 
+					 width))]
+			     [(and kern?
+				   (pair? (cdr cl))
+				   (assoc (char->integer (cadr cl))
+					  (achar-kerns achar)))
+			      => (lambda (p)
+				   ;; Reduce width by kerning amount
+				   (loop (cdr cl)
+					 (+ width (achar-width achar) (cdr p))))]
+			     [else
+			      (loop (cdr cl) (+ width (achar-width achar)))]))])))
+	      (+ size descent)
+	      descent
+	      (* scale (- 1000 (font-ascent font))))))
+
+  (define (afm-draw-text font-name size string out kern? sym-map?)
+    (let* ([l (map-symbols sym-map? (string->list string))]
+	   [font (or (get-font font-name)
+		     (make-font 0 0 #hash() #f #f))]
+	   [show-simples (lambda (simples special-font-name special-font)
+			   (unless (null? simples)
+			     (when special-font
+			       (fprintf out "currentfont~n/~a findfont~n~a scalefont setfont~n"
+					(afm-expand-name special-font-name)
+					size))
+			     (if (font-is-cid? (or special-font font))
+				 (fprintf out "<~a> show\n"
+					  (apply
+					   string-append
+					   (map (lambda (s)
+						  (let ([s (format "000~x" s)])
+						    (substring s (- (string-length s) 4))))
+						(reverse simples))))
+				 (let loop ([bytes (list->bytes (reverse simples))])
+				   (unless (bytes=? #"" bytes)
+				     (if ((bytes-length bytes) . > . 100)
+					 ;; > 100, so break up the string to avoid over-long lines:
+					 (begin
+					   (loop (subbytes bytes 0 100))
+					   (loop (subbytes bytes 100)))
+					 ;; <= 100, so try to write it, but look for unsafe chars
+					 (let ([m (regexp-match-positions #rx#"[^-a-z A-Z0-9!@#$%^&*_=+,.<>:;'\"`~|/?]+" 
+									  bytes)])
+					   (if m
+					       ;; Encode the unsafe chars in hex
+					       (begin
+						 (loop (subbytes bytes 0 (caar m)))
+						 (fprintf out "<~a> show\n" 
+							  (apply string-append
+								 (map
+								  (lambda (c)
+								    (let ([s (format "0~x" c)])
+								      (substring s (- (string-length s) 2))))
+								  (bytes->list (subbytes bytes (caar m) (cdar m))))))
+						 (loop (subbytes bytes (cdar m))))
+					       ;; All safe - write directly
+					       (fprintf out "(~a) show\n" bytes)))))))
+			     (when special-font
+			       ;; Uses result of currentfont above:
+			       (fprintf out "setfont~n"))))])
+      (let loop ([l l][simples null][special-font-name #f][special-font #f])
+	(cond
+	 [(null? l)
+	  (show-simples simples special-font-name special-font)]
+	 [(hash-table-get (font-achars font) (char->integer (car l))
+			  (lambda () #f))
+	  => (lambda (achar)
+	       (if (integer? (achar-enc achar))
+		   ;; It's simple...
+		   (if special-font
+		       ;; Flush simples using special font
+		       (begin
+			 (show-simples simples special-font-name special-font)
+			 (loop (cdr l) (list (achar-enc achar)) #f #f))
+		       ;; Continue simple chain. Look ahead for ligatures and kerning:
+		       (cond
+			[(and kern?
+			      (pair? (cdr l))
+			      (assoc (char->integer (cadr l))
+				     (achar-ligatures achar)))
+			 => (lambda (p)
+			      ;; Substitute ligature
+			      (loop (cons (integer->char (cdr p)) (cddr l))
+				    simples
+				    #f
+				    #f))]
+			[(and kern?
+			      (pair? (cdr l))
+			      (assoc (char->integer (cadr l))
+				     (achar-kerns achar)))
+			 => (lambda (p)
+			      ;; Output result so far
+			      (show-simples (cons (achar-enc achar) simples)
+					    special-font-name special-font)
+			      ;; Kern
+			      (fprintf out "~a 0 rmoveto\n" (* size (/ (cdr p) 1000.0)))
+			      ;; Continue
+			      (loop (cdr l) null #f #f))]
+			[else
+			 ;; Normal additional character
+			 (loop (cdr l) 
+			       (cons (achar-enc achar) simples)
+			       #f
+			       #f)]))
+		   ;; Not simple... use glyphshow
+		   (begin
+		     (show-simples simples special-font-name special-font)
+		     (fprintf out "/~a glyphshow\n" (achar-enc achar))
+		     (loop (cdr l) null #f #f))))]
+	 [else
+	  (find-substitute
+	   (car l)
+	   (lambda (this-font-name this-font achar)
+	     ;; Found a substitute font. (Don't try to kern, though.)
+	     (if (and (equal? special-font-name this-font-name)
+		      (integer? (achar-enc achar)))
+		 ;; Continue special-font simple chain:
+		 (loop (cdr l)
+		       (cons (achar-enc achar) simples)
+		       special-font-name
+		       special-font)
+		 ;; End current simples, etc.
+		 (begin
+		   (show-simples simples special-font-name special-font)
+		   (if (integer? (achar-enc achar))
+		       (loop (cdr l)
+			     (list (achar-enc achar))
+			     this-font-name
+			     this-font)
+		       (begin
+			 ;; Not simple... use glyphshow
+			 (fprintf out "gsave~n/~a findfont~n~a scalefont setfont~n"
+				  (afm-expand-name this-font-name)
+				  size)
+			 (fprintf out "/~a glyphshow\n" (achar-enc achar))
+			 (fprintf out "grestore~n")
+			 (loop (cdr l) null #f #f))))))
+	   (lambda ()
+	     ;; No mapping for the character anywhere.
+	     (show-simples simples special-font-name special-font)
+	     ;; Future work: a box. For now, we just skip some space.
+	     (fprintf out "~a 0 rmoveto\n" (/ size 2))
+	     (loop (cdr l) null #f #f)))]))))
+
+  ;; ----------------------------------------
+  ;; Name expansion
+
+  ;; Adds a char-set to the name, if necessary
+  (define (afm-expand-name font-name)
+    (let ([f (get-font font-name)])
+      (if (and f (font-char-set-name f))
+	  (string-append font-name "-" (bytes->string/latin-1 (font-char-set-name f)))
+	  font-name)))
+
+  ;; ----------------------------------------
+  ;; Font substitution
+
+  (define (find-substitute char find-k none-k)
+    (let ([v (afm-glyph-exists? #f (char->integer char) #f)])
+      (if v
+	  (apply find-k v)
+	  (none-k))))
+
+  (define (afm-glyph-exists?* font-name char-val)
+    (let ([f (get-font font-name)])
+      (and f 
+	   (let ([achar (hash-table-get (font-achars f) 
+					char-val
+					(lambda () #f))])
+	     (and achar
+		  (list font-name f achar))))))
+  
+  (define (afm-glyph-exists? font-name char-val sym-map?)
+    (let ([char-val (if (and sym-map?
+			     (<= 0 char-val 255))
+			(vector-ref symbol-map char-val)
+			char-val)])
+      (or (and font-name
+	       (afm-glyph-exists?* font-name char-val))
+	  (ormap (lambda (fn)
+		   (afm-glyph-exists?* fn char-val))
+		 (get-all-fonts))))))
+
+
+
diff --git a/collects/mred/private/app.ss b/collects/mred/private/app.ss
new file mode 100644
index 0000000000..dbc04ff393
--- /dev/null
+++ b/collects/mred/private/app.ss
@@ -0,0 +1,171 @@
+(module app mzscheme
+  (require (lib "class.ss")
+	   (lib "class100.ss")
+	   (prefix wx: "kernel.ss")
+	   "lock.ss"
+	   "helper.ss"
+	   "wx.ss"
+	   "wxtop.ss")
+
+  (provide application-preferences-handler
+	   application-about-handler
+	   application-quit-handler
+	   application-file-handler
+	   current-eventspace-has-standard-menus?
+	   current-eventspace-has-menu-root?
+	   eventspace-handler-thread)
+
+  ;; An app-handler record keeps a wrapped procedure with
+  ;; its original wrappee.
+  (define-values (struct:app-handler
+		  make-app-handler
+		  app-handler?
+		  app-handler-ref
+		  app-handler-set!)
+    (make-struct-type 'app-handler
+		      #f 2 0
+		      #f null (current-inspector)
+		      0))
+  (define (app-handler-orig ah)
+    (app-handler-ref ah 1))
+
+  (let* ([running-quit? #f]
+	 [f (entry-point
+	     (lambda ()
+	       (unless running-quit?
+		 (let ([af (weak-box-value active-main-frame)])
+		   (when af
+		     (set! running-quit? #t)
+		     (queue-window-callback
+		      af
+		      (entry-point
+		       (lambda ()
+			 (dynamic-wind
+			     void
+			     (lambda ()
+			       (send af on-exit)
+			       (unless (null? (wx:get-top-level-windows))
+				 (wx:cancel-quit)))
+			     (lambda () 
+			       (set! running-quit? #f)))))))))))])
+    (wx:application-quit-handler (make-app-handler f f)))
+
+  (define (set-handler! who proc param arity result-filter)
+    (when proc
+      (unless (and (procedure? proc)
+		   (procedure-arity-includes? proc arity))
+	(raise-type-error who
+			  (format "procedure (arity ~a) or #f" arity)
+			  proc)))
+    (let ([e (wx:current-eventspace)])
+      (when (wx:main-eventspace? e)
+	(param (make-app-handler
+		(lambda args
+		  (parameterize ([wx:current-eventspace e])
+		    (wx:queue-callback
+		     (lambda () (result-filter (apply proc args)))
+		     wx:middle-queue-key)))
+		proc)))))
+
+  (define application-preferences-handler
+    (case-lambda
+     [() (and (wx:main-eventspace? (wx:current-eventspace))
+	      (app-handler-orig (wx:application-pref-handler)))]
+     [(proc)
+      (set-handler! 'application-preferences-handler proc
+		    wx:application-pref-handler
+		    0
+		    values)]))
+
+  (define application-about-handler
+    (case-lambda
+     [() (or (and (wx:main-eventspace? (wx:current-eventspace))
+		  (app-handler-orig (wx:application-about-handler)))
+	     void)]
+     [(proc)
+      (set-handler! 'application-about-handler proc
+		    wx:application-about-handler
+		    0
+		    values)]))
+
+  (define application-quit-handler
+    (case-lambda
+     [() (or (and (wx:main-eventspace? (wx:current-eventspace))
+		  (app-handler-orig (wx:application-quit-handler)))
+	     void)]
+     [(proc)
+      (set-handler! 'application-quit-handler proc
+		    wx:application-quit-handler
+		    0
+		    (lambda (v) (unless v (wx:cancel-quit)) v))]))
+
+  (define default-application-file-handler
+    (entry-point
+     (lambda (f)
+       (let ([af (weak-box-value active-main-frame)])
+	 (when af
+	   (queue-window-callback
+	    af
+	    (entry-point
+	     (lambda () (when (send af accept-drag?)
+			  (send af on-drop-file f))))))))))
+
+  (define (install-defh)
+    (wx:application-file-handler (make-app-handler
+				  default-application-file-handler
+				  default-application-file-handler)))
+  (install-defh)
+
+  (define application-file-handler
+    (case-lambda
+     [() (or (and (wx:main-eventspace? (wx:current-eventspace))
+		  (app-handler-orig (wx:application-file-handler)))
+	     void)]
+     [(proc)
+      ;; Special case for default-application-file-handler,
+      ;; because it need not be constrained to the main eventspace:
+      (if (eq? proc default-application-file-handler)
+	  (install-defh)
+	  (set-handler! 'application-file-handler proc
+			wx:application-file-handler
+			1
+			values))]))
+
+
+  (define (current-eventspace-has-standard-menus?)
+    (and (eq? 'macosx (system-type))
+	 (wx:main-eventspace? (wx:current-eventspace))))
+
+  (define (current-eventspace-has-menu-root?)
+    (and (memq (system-type) '(macos macosx))
+	 (wx:main-eventspace? (wx:current-eventspace))))
+
+  (define (eventspace-handler-thread e)
+    (let ([t (wx:eventspace-handler-thread e)])
+      (or t
+	  ;; eventspace dead, or just no thread, yet?
+	  (with-handlers ([exn:fail?
+			   (lambda (x)
+			     (if (wx:eventspace-shutdown? e)
+				 (raise-mismatch-error
+				  'eventspace-handler-thread
+				  "eventspace is shutdown: "
+				  e)
+				 (raise x)))])
+	    (let ([done (make-semaphore)]
+		  [t #f])
+	      (parameterize ([wx:current-eventspace e])
+		(wx:queue-callback
+		 (lambda () 
+		   (set! t (current-thread))
+		   (semaphore-post done))
+		 #t)
+		(if (sync/timeout 1.0 done)
+		    t
+		    ;; Weird - no response after 1 second.  Maybe
+		    ;; someone killed the handler thread before it could
+		    ;; do our work? Or shutdown the eventspace? Or the
+		    ;; thread is busy? In any of those cases, we'll
+		    ;; succeed on the next iteration.
+		    (eventspace-handler-thread e)))))))))
+
diff --git a/collects/mred/private/check.ss b/collects/mred/private/check.ss
new file mode 100644
index 0000000000..8449b7d397
--- /dev/null
+++ b/collects/mred/private/check.ss
@@ -0,0 +1,177 @@
+(module check mzscheme
+  (require (lib "class.ss")
+	   (prefix wx: "kernel.ss")
+	   "wx.ss"
+	   "const.ss")
+  (provide (protect (all-defined)))
+
+  (define (who->name who)
+    (cond
+     [(symbol? who) who]
+     [(eq? (car who) 'method) (string->symbol (format "~a in ~a" (caddr who) (cadr who)))]
+     [(eq? (car who) 'iconstructor) (iconstructor-name (cadr who))]
+     [else (constructor-name (cadr who))]))
+
+  (define (label-string? s)
+    (and (string? s) 
+	 (let ([l (string-length s)])
+	   (and l
+		(<= 0 l 200)))))
+
+  (define (constructor-name who)
+    (string->symbol (format "initialization for ~a%" who)))
+
+  (define (iconstructor-name who)
+    (string->symbol (format "initialization for a class that implements ~a<%>" who)))
+
+  (define (check-orientation cwho l)
+    (check-style cwho '(vertical horizontal) '(vertical-label horizontal-label deleted) l))
+
+  (define (check-container-ready cwho p)
+    (when p
+      (let ([wx (mred->wx p)])
+	(unless wx
+	  (raise-mismatch-error (who->name cwho)
+				"container is not yet fully initialized: " 
+				p)))))
+
+  (define (check-instance who class class-name false-ok? v)
+    (unless (or (and false-ok? (not v)) (is-a? v class))
+      (raise-type-error (who->name who) (format "~a object~a" class-name (if false-ok? " or #f" "")) v)))
+
+  (define (check-string/false who str)
+    (unless (or (not str) (string? str))
+      (raise-type-error (who->name who) "string or #f" str)))
+
+  (define (check-path/false who str)
+    (unless (or (not str) (path-string? str))
+      (raise-type-error (who->name who) "path, string, or #f" str)))
+
+  (define (check-string who str)
+    (unless (string? str)
+      (raise-type-error (who->name who) "string" str)))
+
+  (define (check-label-string who str)
+    (unless (label-string? str)
+      (raise-type-error (who->name who) "string (up to 200 characters)" str)))
+
+  (define (check-label-string/false who str)
+    (unless (or (not str) (label-string? str))
+      (raise-type-error (who->name who) "string  (up to 200 characters) or #f" str)))
+
+  (define (check-char/false who c)
+    (unless (or (not c) (char? c))
+      (raise-type-error (who->name who) "character or #f" c)))
+
+  (define (check-callback who callback)
+    (unless (and (procedure? callback)
+		 (procedure-arity-includes? callback 2))
+      (raise-type-error (who->name who) "procedure of arity 2" callback)))
+
+  (define (check-callback1 who callback)
+    (unless (and (procedure? callback)
+		 (procedure-arity-includes? callback 1))
+      (raise-type-error (who->name who) "procedure of arity 1" callback)))
+
+  (define (check-bounded-integer min max false-ok?)
+    (lambda (who range)
+      (unless (or (and false-ok? (not range))
+		  (and (integer? range) (exact? range) (<= min range max)))
+	(raise-type-error (who->name who) 
+			  (format "exact integer in [~a, ~a]~a"
+				  min max
+				  (if false-ok? " or #f" ""))
+			  range))))
+
+  (define check-range-integer (check-bounded-integer 0 10000 #f))
+
+  (define check-slider-integer (check-bounded-integer -10000 10000 #f))
+
+  (define check-init-pos-integer (check-bounded-integer -10000 10000 #t))
+
+  (define check-margin-integer (check-bounded-integer 0 1000 #f))
+
+  (define check-gauge-integer (check-bounded-integer 1 10000 #f))
+
+  (define (check-wheel-step cwho wheel-step)
+    (when (and wheel-step
+	       (not (and (integer? wheel-step)
+			 (exact? wheel-step)
+			 (<= 1 wheel-step 10000))))
+      (raise-type-error (who->name cwho)
+			"#f or exact integer in [1,10000]"
+			wheel-step)))
+
+  (define (check-fraction who x)
+    (unless (and (real? x) (<= 0.0 x 1.0))
+      (raise-type-error (who->name who) 
+			"real number in [0.0, 1.0]"
+			x)))
+
+  (define (-check-non-negative-integer who i false-ok?)
+    (when (or i (not false-ok?))
+      (unless (and (integer? i) (exact? i) (not (negative? i)))
+	(raise-type-error (who->name who) 
+			  (if false-ok?
+			      "non-negative exact integeror #f" 
+			      "non-negative exact integer" )
+			  i))))
+
+  (define (check-non-negative-integer who i)
+    (-check-non-negative-integer who i #f))
+
+  (define (check-non-negative-integer/false who i)
+    (-check-non-negative-integer who i #t))
+
+  (define check-dimension (check-bounded-integer 0 10000 #t))
+  (define check-non#f-dimension (check-bounded-integer 0 10000 #f))
+
+  (define (check-label-string-or-bitmap who label)
+    (unless (or (label-string? label) (is-a? label wx:bitmap%))
+      (raise-type-error (who->name who) "string (up to 200 characters) or bitmap% object" label)))
+
+  (define (check-label-string-or-bitmap/false who label)
+    (unless (or (not label) (label-string? label) (is-a? label wx:bitmap%))
+      (raise-type-error (who->name who) "string (up to 200 characters), bitmap% object, or #f" label)))
+
+  (define (check-label-string/bitmap/iconsym who label)
+    (unless (or (label-string? label) (is-a? label wx:bitmap%)
+		(memq label '(app caution stop)))
+      (raise-type-error (who->name who) "string (up to 200 characters), bitmap% object, or icon symbol" label)))
+
+  (define (check-font who f)
+    (unless (or (eq? f no-val) (f . is-a? . wx:font%))
+      (raise-type-error (who->name who) "font% object" f)))
+
+  (define (check-style who reqd other-allowed style)
+    (unless (and (list? style) (andmap symbol? style))
+      (raise-type-error (who->name who) "list of style symbols" style))
+    (when reqd
+      (letrec ([or-together (lambda (l)
+			      (if (= (length l) 2)
+				  (format "~a or ~a" (car l) (cadr l))
+				  (let loop ([l l])
+				    (if (null? (cdr l))
+					(format "or ~a" (car l))
+					(format "~a, ~a" (car l) (loop (cdr l)))))))])
+	(unless (ormap (lambda (i) (memq i reqd)) style)
+	  (raise-type-error (who->name who)
+			    (format "style list, missing ~a"
+				    (if (= (length reqd) 1)
+					(car reqd)
+					(string-append
+					 "one of "
+					 (or-together reqd))))
+			    style))))
+    (if (and (not reqd) (null? other-allowed))
+	(unless (null? style)
+	  (raise-type-error (who->name who) "empty style list" style))
+	(let* ([l (append (or reqd null) other-allowed)]
+	       [bad (ormap (lambda (x) (if (memq x l) #f x)) style)])
+	  (when bad
+	    (raise-type-error (who->name who) (format "style list, ~e not allowed" bad) style))
+	  (let loop ([l style])
+	    (unless (null? l)
+	      (when (memq (car l) (cdr l))
+		(raise-type-error (who->name who) (format "style list, ~e allowed only once" (car l)) style))
+	      (loop (cdr l))))))))
diff --git a/collects/mred/private/const.ss b/collects/mred/private/const.ss
new file mode 100644
index 0000000000..d19fee2138
--- /dev/null
+++ b/collects/mred/private/const.ss
@@ -0,0 +1,74 @@
+(module const mzscheme
+  (require (lib "class.ss")
+	   (lib "file.ss")
+	   (prefix wx: "kernel.ss"))
+  (provide (protect (all-defined)))
+
+  ;; default spacing between items.
+  (define const-default-spacing 0)
+  
+  ;; default margins:
+  (define const-default-x-margin 2)
+  (define const-default-y-margin 2)
+
+  ;; default spacing around edge of panel
+  (define const-default-border 0)
+  
+  ;; the maximum hard-min-width of a gauge
+  (define const-max-gauge-length 150)
+  
+  ;; maximum reasonable minimum width/height
+  (define max-min 10000)
+
+  (define side-combo-width (case (system-type)
+			     [(windows) 20]
+			     [(macosx) 18]
+			     [else 16]))
+  
+  ;; message-box, etc.:
+  (define box-width 300)
+  
+  (define err (current-error-port))
+  
+  ;; indicates init arg not supplied
+  (define no-val (gensym))
+  (define (no-val->#f v) (if (eq? v no-val) #f v))
+
+  (define ibeam (make-object wx:cursor% 'ibeam))
+  (define arrow-cursor (make-object wx:cursor% 'arrow))
+
+  (define default-x-prefix (if (eq? 'unix (system-type))
+			       (let ([v (get-preference '|MrEd:defaultMenuPrefix| (lambda () 'ctl))])
+				 (if (memq v '(meta ctl alt ctl-m))
+				     v
+				     'ctl))
+			       'ctl))
+
+  (define (menu-shortcut-in-label?)
+    (case (system-type)
+      [(unix) (not (memq default-x-prefix '(alt meta)))]
+      [else (wx:shortcut-visible-in-label? #t)]))
+
+  (define bg-color (wx:get-panel-background))
+
+  (define (scale-color c f)
+    (make-object wx:color% 
+		 (min 255 (floor (* f (send c red)))) 
+		 (min 255 (floor (* f (send c green)))) 
+		 (min 255 (floor (* f (send c blue))))))
+
+  (define black-color (make-object wx:color% 0 0 0))
+  (define disabled-color (make-object wx:color% 150 150 150))
+
+  (define trans-pen (send (wx:get-the-pen-list) find-or-create-pen "white" 0 'transparent))
+  (define light-pen (send (wx:get-the-pen-list) find-or-create-pen (scale-color bg-color #e1.35) 0 'solid))
+  (define border-pen (send (wx:get-the-pen-list) find-or-create-pen (scale-color bg-color #e0.85) 0 'solid)) 
+  (define dark-pen (send (wx:get-the-pen-list) find-or-create-pen (scale-color bg-color #e0.6) 0 'solid)) 
+  (define dark-brush (send (wx:get-the-brush-list) find-or-create-brush (scale-color bg-color #e0.8) 'solid))
+  
+  (define wx-tab-group<%> (interface ()))
+  (define wx-group-box<%> (interface ()))
+  (define wx-text-editor-canvas<%> (interface ()))
+  (define wx-basic-panel<%> (interface ()))
+  (define internal-editor<%> (interface ()))
+  (define internal-menu<%> (interface ())))
diff --git a/collects/mred/private/cycle.ss b/collects/mred/private/cycle.ss
new file mode 100644
index 0000000000..a0e90588fd
--- /dev/null
+++ b/collects/mred/private/cycle.ss
@@ -0,0 +1,20 @@
+(module cycle mzscheme
+
+  ;; There are a few cycles that we can't eliminate without
+  ;;  using state. This module implements that state
+
+  (provide (protect get-get-file
+		    set-get-file!
+		    get-get-font-from-user
+		    set-get-font-from-user!))
+  
+  (define get-file #f)
+  (define (get-get-file) get-file)
+  (define (set-get-file! f) (set! get-file f))
+
+  (define get-font-from-user #f)
+  (define (get-get-font-from-user) get-font-from-user)
+  (define (set-get-font-from-user! f) (set! get-font-from-user f)))
+
+
+  
diff --git a/collects/mred/private/editor.ss b/collects/mred/private/editor.ss
new file mode 100644
index 0000000000..b4241a8f5f
--- /dev/null
+++ b/collects/mred/private/editor.ss
@@ -0,0 +1,629 @@
+(module editor mzscheme
+  (require (lib "class.ss")
+	   (lib "class100.ss")
+	   (lib "etc.ss")
+	   (lib "list.ss")
+	   (lib "file.ss")
+	   (prefix wx: "kernel.ss")
+	   "seqcontract.ss"
+	   "lock.ss"
+	   "check.ss"
+	   "const.ss"
+	   "helper.ss"
+	   "cycle.ss"
+	   "wx.ss"
+	   "wxtop.ss"
+	   "wxitem.ss"
+	   "wxcanvas.ss"
+	   "mrwindow.ss"
+	   "mrtop.ss"
+	   "mrcanvas.ss"
+	   "mrpopup.ss"
+	   "mrmenuintf.ss"
+	   "mrmenu.ss")
+
+  (provide editor<%>
+	   text%
+	   pasteboard%
+	   editor-snip%
+	   current-text-keymap-initializer
+	   append-editor-operation-menu-items
+	   append-editor-font-menu-items)
+
+  (define editor<%> 
+    (interface (wx:editor<%>)
+      get-canvases
+      get-active-canvas set-active-canvas
+      get-canvas
+      add-canvas remove-canvas
+      auto-wrap get-max-view-size))
+
+  (define-local-member-name 
+    -format-filter
+    -get-current-format
+    -get-file-format
+    -set-file-format
+    -set-format)
+
+  (define-syntax (augmentize stx)
+    (syntax-case stx ()
+      [(_ (result id arg ...) ...)
+       #'(begin
+	   (define/overment (id arg ...)
+	     (and (super id arg ...)
+		  (inner result id arg ...)))
+	   ...)]))
+  
+  (define (make-editor-buffer% % can-wrap? get-editor%)
+					; >>> This class is instantiated directly by the end-user <<<
+    (class* % (editor<%> internal-editor<%>)
+	    (init-rest args)
+	    (rename-super [super-get-view-size get-view-size]
+			  [super-begin-edit-sequence begin-edit-sequence]
+			  [super-end-edit-sequence end-edit-sequence]
+			  [super-insert-port insert-port]
+			  [super-erase erase]
+			  [super-clear-undos clear-undos]
+			  [super-get-load-overwrites-styles get-load-overwrites-styles]
+			  [super-get-filename get-filename])
+	    (inherit get-max-width set-max-width get-admin
+		     get-keymap get-style-list
+		     set-modified set-filename)
+	    (define canvases null)
+	    (define active-canvas #f)
+	    (define auto-set-wrap? #f)
+	    (private*
+	     [max-view-size
+	      (lambda ()
+		(let ([wb (box 0)]
+		      [hb (box 0)])
+		  (super-get-view-size wb hb)
+		  (unless (or (null? canvases) (null? (cdr canvases)))
+		    (for-each
+		     (lambda (canvas)
+		       (send canvas call-as-primary-owner
+			     (lambda ()
+			       (let ([wb2 (box 0)]
+				     [hb2 (box 0)])
+				 (super-get-view-size wb2 hb2)
+				 (set-box! wb (max (unbox wb) (unbox wb2)))
+				 (set-box! hb (max (unbox hb) (unbox hb2)))))))
+		     canvases))
+		  (values (unbox wb) (unbox hb))))])
+	    (public*
+	     [-format-filter (lambda (f) f)]
+	     [-set-file-format (lambda (f) (void))]
+	     [-get-file-format (lambda () 'standard)])
+	    
+	    (override*
+	     [insert-file
+	      (opt-lambda ([file #f] [format 'guess] [show-errors? #t])
+		(dynamic-wind
+		    (lambda () (super-begin-edit-sequence))
+		    (lambda () (super-insert-port file format #f))
+		    (lambda () (super-end-edit-sequence))))]
+
+	     [load-file
+	      (opt-lambda ([file #f] [format 'guess] [show-errors? #t])
+		(let* ([temp-filename?-box (box #f)]
+		       [old-filename (super-get-filename temp-filename?-box)])
+		  (let* ([file (cond
+				[(or (not (path-string? file))
+				     (equal? file ""))
+				 (if (or (equal? file "") (not old-filename) (unbox temp-filename?-box))
+				     (let ([path (if old-filename
+						     (path-only old-filename)
+						     #f)])
+				       ((get-get-file) path))
+				     old-filename)]
+				[(path? file) file]
+				[else (string->path file)])])
+		    (and 
+		     file
+		     (can-load-file? file (-format-filter format))
+		     (begin
+		       (on-load-file file (-format-filter format))
+		       (let ([port (open-input-file file)]
+			     [finished? #f])
+			 (dynamic-wind
+			     void
+			     (lambda ()
+			       (wx:begin-busy-cursor)
+			       (super-begin-edit-sequence)
+			       (dynamic-wind
+				   void
+				   (lambda ()
+				     (super-erase)
+				     (unless (and (not (unbox temp-filename?-box))
+						  (equal? file old-filename))
+				       (set-filename file #f))
+				     (let ([format (if (eq? format 'same)
+						       (-get-file-format)
+						       format)])
+				       (let ([new-format 
+					      (with-handlers ([values (lambda (x)
+									(set-filename #f #f)
+									(raise x))])
+						(super-insert-port port 
+								   (-format-filter format) 
+								   (super-get-load-overwrites-styles)))])
+					 (close-input-port port) ; close as soon as possible
+					 (-set-file-format new-format)))) ; text% only
+				   (lambda ()
+				     (super-end-edit-sequence)
+				     (wx:end-busy-cursor)))
+			       (super-clear-undos)
+			       (set-modified #f)
+			       (set! finished? #t)
+			       #t)
+			     (lambda ()
+			       (after-load-file finished?)
+			       ;; In case it wasn't closed before:
+			       (close-input-port port)))))))))])
+
+	    (public*
+	     [get-canvases (entry-point (lambda () (map wx->mred canvases)))]
+	     [get-active-canvas (entry-point (lambda () (and active-canvas (wx->mred active-canvas))))]
+	     [get-canvas
+	      (entry-point
+	       (lambda ()
+		 (let ([c (or active-canvas
+			      (and (not (null? canvases))
+				   (car canvases)))])
+		   (and c (wx->mred c)))))]
+	     [set-active-canvas
+	      (entry-point
+	       (lambda (new-canvas)
+		 (check-instance '(method editor<%> set-active-canvas) editor-canvas% 'editor-canvas% #t new-canvas)
+		 (set! active-canvas (mred->wx new-canvas))))]
+
+	     [add-canvas
+	      (entry-point
+	       (lambda (new-canvas)
+		 (check-instance '(method editor<%> add-canvas) editor-canvas% 'editor-canvas% #f new-canvas)
+		 (let ([new-canvas (mred->wx new-canvas)])
+		   (unless (memq new-canvas canvases)
+		     (set! canvases (cons new-canvas canvases))))))]
+
+	     [remove-canvas
+	      (entry-point
+	       (lambda (old-canvas)
+		 (check-instance '(method editor<%> remove-canvas) editor-canvas% 'editor-canvas% #f old-canvas)
+		 (let ([old-canvas (mred->wx old-canvas)])
+		   (when (eq? old-canvas active-canvas)
+		     (set! active-canvas #f))
+		   (set! canvases (remq old-canvas canvases)))))]
+
+	     [auto-wrap (case-lambda
+			 [() auto-set-wrap?]
+			 [(on?) (as-entry
+				 (lambda ()
+				   (set! auto-set-wrap? (and on? #t))
+				   (as-exit
+				    (lambda ()
+				      (if on?
+					  (on-display-size)
+					  (set-max-width 'none))))))])]
+	     [get-max-view-size (entry-point (lambda () (max-view-size)))])
+	    (override*
+	     [copy-self
+	      (lambda () (let ([e (make-object (get-editor%))])
+			   (copy-self-to e)
+			   e))]
+	     [copy-self-to
+	      (lambda (e)
+		(super copy-self-to e)
+		(send e auto-wrap auto-set-wrap?))])
+	    
+	    (overment*
+	     [on-display-size
+	      (entry-point
+	       (lambda ()
+		 (as-exit (lambda () (super on-display-size)))
+		 (when (as-exit (lambda () (get-admin)))
+		   (when (and can-wrap? auto-set-wrap?)
+		     (let-values ([(current-width) (as-exit (lambda () (get-max-width)))]
+				  [(new-width new-height) (max-view-size)])
+		       (when (and (not (= current-width new-width))
+				  (< 0 new-width))
+			 (as-exit (lambda () (set-max-width new-width)))))))
+		 (as-exit (lambda () (inner (void) on-display-size)))))])
+	    
+	    (augmentize ((void) on-change)
+			((void) on-snip-modified snip x)
+			(#t can-save-file? p t)
+			((void) on-save-file p t)
+			((void) after-save-file t)
+			(#t can-load-file? p t)
+			((void) on-load-file p t)
+			((void) after-load-file t)
+			((void) on-edit-sequence)
+			((void) after-edit-sequence))
+
+	    (private*
+	     [sp (lambda (x y z f b?)
+		   ;; let super method report z errors:
+		   (let ([zok? (memq z '(standard postscript))])
+		     (when zok?
+		       (check-top-level-parent/false '(method editor<%> print) f))
+		     (let ([p (and zok? f (mred->wx f))])
+		       (as-exit (lambda () (super print x y z p b?))))))])
+
+	    (override*
+	     [print
+	      (entry-point
+	       (case-lambda 
+		[() (sp #t #t 'standard #f #t)]
+		[(x) (sp x #t 'standard #f #t)]
+		[(x y) (sp x y 'standard #f #t)]
+		[(x y z) (sp x y z #f #t)]
+		[(x y z f) (sp x y z f #t)]
+		[(x y z f b?) (sp x y z f b?)]))]
+
+	     [on-new-box
+	      (entry-point
+	       (lambda (type)
+		 (unless (memq type '(text pasteboard))
+		   (raise-type-error (who->name '(method editor<%> on-new-box)) "symbol: text or pasteboard" type))
+		 (make-object editor-snip%
+			      (let ([e (make-object (cond
+						     [(eq? type 'pasteboard) pasteboard%]
+						     [else text%]))])
+				(send e set-keymap (get-keymap))
+				(send e set-style-list (get-style-list))
+				e))))])
+
+	    (apply super-make-object args)))
+
+  (define text%
+    (class (lock-contract-mixin
+	    (es-contract-mixin
+	     (make-editor-buffer% wx:text% #t  (lambda () text%))))
+      (init [line-spacing 1.0] 
+	    [tab-stops null]
+	    [(aw? auto-wrap) #f])
+      (rename-super [super-get-file-format get-file-format]
+		    [super-set-file-format set-file-format]
+		    [super-set-position set-position]
+		    [super-auto-wrap auto-wrap])
+      (override*
+       [-get-file-format (lambda ()
+			   (super-get-file-format))]
+       [-set-file-format (lambda (format)
+			   (super-set-file-format format)
+			   (super-set-position 0 0))])
+
+      (augmentize (#t can-insert? s e)
+		  ((void) on-insert s e)
+		  ((void) after-insert s e)
+		  (#t can-delete? s e)
+		  ((void) on-delete s e)
+		  ((void) after-delete s e)
+		  (#t can-change-style? s e)
+		  ((void) on-change-style s e)
+		  ((void) after-change-style s e)
+		  ((void) after-set-position)
+		  (#t can-set-size-constraint?)
+		  ((void) on-set-size-constraint)
+		  ((void) after-set-size-constraint)
+		  ((void) after-split-snip s)
+		  ((void) after-merge-snips s))
+      
+      (super-make-object line-spacing tab-stops)
+      (when aw?
+	(super-auto-wrap #t))))
+  
+  (define pasteboard%
+    (class (es-contract-mixin (make-editor-buffer% wx:pasteboard% #f (lambda () pasteboard%))) ()
+	   (override*
+	    [-format-filter (lambda (f) 'standard)])
+	   (augmentize (#t can-insert? s s2 x y)
+		       ((void) on-insert s s2 x y)
+		       ((void) after-insert s s2 x y)
+		       (#t can-delete? s)
+		       ((void) on-delete s)
+		       ((void) after-delete s)
+		       (#t can-move-to? s x y ?)
+		       ((void) on-move-to s x y ?)
+		       ((void) after-move-to s x y ?)
+		       (#t can-resize? s x y)
+		       ((void) on-resize s x y)
+		       ((void) after-resize s x y ?)
+		       (#t can-reorder? s s2 ?)
+		       ((void) on-reorder s s2 ?)
+		       ((void) after-reorder s s2 ?)
+		       (#t can-select? s ?)
+		       ((void) on-select s ?)
+		       ((void) after-select s ?)
+		       
+		       (#t can-interactive-move? e)
+		       ((void) on-interactive-move e)
+		       ((void) after-interactive-move e)
+		       (#t can-interactive-resize? s)
+		       ((void) on-interactive-resize s)
+		       ((void) after-interactive-resize s))
+	   (super-new)))
+
+  (define editor-snip% (class100 wx:editor-snip% ([editor #f]
+						  [with-border? #t]
+						  [left-margin 5]
+						  [top-margin 5]
+						  [right-margin 5]
+						  [bottom-margin 5]
+						  [left-inset 1]
+						  [top-inset 1]
+						  [right-inset 1]
+						  [bottom-inset 1]
+						  [min-width 'none]
+						  [max-width 'none]
+						  [min-height 'none]
+						  [max-height 'none])
+			 (sequence
+			   (super-init (or editor (make-object text%))
+				       with-border?
+				       left-margin
+				       top-margin
+				       right-margin
+				       bottom-margin
+				       left-inset
+				       top-inset
+				       right-inset
+				       bottom-inset
+				       min-width
+				       max-width
+				       min-height
+				       max-height))))
+
+  (wx:set-editor-snip-maker (lambda args (apply make-object editor-snip% args)))
+  (wx:set-text-editor-maker (lambda () (make-object text%)))
+  (wx:set-pasteboard-editor-maker (lambda () (make-object pasteboard%)))
+
+  ;; ----------------------- Keymap ----------------------------------------
+
+  (define std-keymap (make-object wx:keymap%))
+
+  (let* ([k std-keymap]
+	 [mouse-paste (lambda (edit event) 
+			(when (send event button-down?)
+			  (cond
+			   [(is-a? edit wx:text%)
+			    (let ([x-box (box (send event get-x))]
+				  [y-box (box (send event get-y))]
+				  [eol-box (box #f)])
+			      (send edit global-to-local x-box y-box)
+			      (let ([click-pos (send edit find-position 
+						     (unbox x-box)
+						     (unbox y-box)
+						     eol-box)])
+				(send edit set-position click-pos)))]
+			   [else (void)])
+			  (send edit paste-x-selection)))]
+	 [mouse-popup-menu (lambda (edit event)
+			     (when (send event button-up?)
+			       (let ([a (send edit get-admin)])
+				 (when a
+				   (let ([m (make-object popup-menu%)])
+				     (append-editor-operation-menu-items m)
+				     ;; Remove shortcut indicators (because they might not be correct)
+				     (for-each
+				      (lambda (i)
+					(when (is-a? i selectable-menu-item<%>)
+					  (send i set-shortcut #f)))
+				      (send m get-items))
+				     (let-values ([(x y) (send edit
+							       dc-location-to-editor-location
+							       (send event get-x)
+							       (send event get-y))])
+				       (send a popup-menu m (+ x 5) (+ y 5))))))))])
+    (wx:add-text-keymap-functions k)
+    (send k add-function "mouse-paste" mouse-paste)
+    (send k add-function "mouse-popup-menu" mouse-popup-menu)
+    (map
+     (lambda (key func) (send k map-function key func))
+     (append
+      (case (system-type)
+	[(windows) '(":c:c" ":c:x" ":c:v" ":c:k" ":c:z" ":c:a")]
+	[(macos macosx) '(":d:c" ":d:x" ":d:v" ":d:k" ":d:z" ":d:a")]
+	[(unix) '(":m:w" ":c:w" ":c:y" ":c:k" ":c:s:_" ":m:a")])
+      '(":middlebutton"))
+     '("copy-clipboard" "cut-clipboard" "paste-clipboard" "delete-to-end-of-line" 
+       "undo" "select-all" "mouse-paste"))
+    (send k map-function ":rightbuttonseq" "mouse-popup-menu")
+    (when (eq? (system-type) 'unix)
+      (send k map-function ":c:a" "beginning-of-line")
+      (send k map-function ":c:e" "end-of-line")))
+
+  (define (check-installer who)
+    (lambda (p)
+      (unless (and (procedure? p)
+		   (procedure-arity-includes? p 1))
+	(raise-type-error who
+			  "procedure of arity 1"
+			  p))
+      p))
+
+  (define current-text-keymap-initializer
+    (make-parameter (let ([default-text-keymap-initializer
+			    (lambda (k)
+			      (check-instance 'default-text-keymap-initializer wx:keymap% 'keymap% #f k)
+			      ;; Level of indirection to protect std-keymap:
+			      (let ([naya (make-object wx:keymap%)])
+				(send naya chain-to-keymap std-keymap #f)
+				(send k chain-to-keymap naya #f)))])
+		      default-text-keymap-initializer)
+		    (check-installer 'default-text-keymap-initializer)))
+
+  (define (find-item-editor item)
+  (let ([o (let loop ([i item])
+	     (let ([p (send i get-parent)])
+	       (cond
+		[(not p) #f]
+		[(is-a? p popup-menu%)
+		 (let ([p (send p get-popup-target)])
+		   (if (is-a? p window<%>)
+		       (let ([f (send p get-top-level-window)])
+			 (and f (send f get-edit-target-object)))
+		       p))]
+		[(is-a? p menu%) (loop p)]
+		[else (let ([f (send p get-frame)])
+			(and f (send f get-edit-target-object)))])))])
+    (and (is-a? o wx:editor<%>)
+	 o)))
+
+  ;; ------------------------- Menus ----------------------------------------
+
+  (define append-editor-operation-menu-items
+    (case-lambda
+     [(m) (append-editor-operation-menu-items m #t)]
+     [(m text-only?)
+      (menu-parent-only 'append-editor-operation-menu-items m)
+      (let* ([mk (lambda (name key op)
+		   (make-object (class100 menu-item% ()
+				  (inherit enable)
+				  (override
+				    [on-demand
+				     (lambda ()
+				       (let ([o (find-item-editor this)])
+					 (enable (and o
+						      (send o can-do-edit-operation? op)))))])
+				  (sequence
+				    (super-init
+				     name m
+				     (lambda (i e)
+				       (let* ([o (find-item-editor i)])
+					 (and o
+					      (send o do-edit-operation op))))
+				     key)))))]
+	     [mk-sep (lambda () (make-object separator-menu-item% m))])
+	(mk "&Undo" #\z 'undo)
+	(mk "Redo" #f 'redo)
+	(mk-sep)
+	(mk "&Copy" #\c 'copy)
+	(mk "Cu&t" #\x 'cut)
+	(mk "&Paste" #\v 'paste)
+	(if (eq? (system-type) 'windows)
+	    (mk "Delete" #f 'clear)
+	    (mk "Clear" #f 'clear))
+	(mk "Select &All" #\a 'select-all)
+	(unless text-only?
+	  (mk-sep)
+	  (mk "Insert Text Box" #f 'insert-text-box)
+	  (mk "Insert Pasteboard Box" #f 'insert-pasteboard-box)
+	  (mk "Insert Image..." #f 'insert-image))
+	(void))]))
+
+  (define (append-editor-font-menu-items m)
+    (menu-parent-only 'append-editor-font-menu-items m)
+    (let ([mk (lambda (name m cb)
+		(make-object menu-item% name m
+			     (lambda (i e)
+			       (let* ([o (find-item-editor i)])
+				 (and o (cb o))))))]
+	  [mk-sep (lambda (m) (make-object separator-menu-item% m))]
+	  [mk-menu (lambda (name) (make-object menu% name m))])
+      (let ([family (mk-menu "Font")]
+	    [size (mk-menu "Size")]
+	    [style (mk-menu "Style")]
+	    [weight (mk-menu "Weight")]
+	    [underline (mk-menu "Underline")]
+	    [alignment (mk-menu "Alignment")]
+	    [color (mk-menu "Color")]
+	    [background (mk-menu "Background")])
+	
+					; Font menu 
+	(for-each (lambda (l f)
+		    (mk l family 
+			(lambda (e)
+			  (send e change-style (make-object wx:style-delta% 'change-family f)))))
+		  '("Standard" "Decorative" "Roman" "Script" "Swiss" "Fixed" "Symbol")
+		  '(default decorative roman script swiss modern symbol))
+	(mk-sep family)
+	(mk "Choose..." family (lambda (e) (let ([f ((get-get-font-from-user))])
+					     (when f
+					       (send e change-style (font->delta f))))))
+
+					; Size menu
+	(let ([bigger (make-object menu% "Bigger" size)]
+	      [smaller (make-object menu% "Smaller" size)]
+	      [add-change-size
+	       (lambda (m ls dss xss)
+		 (for-each (lambda (l ds xs)
+			     (mk l m (lambda (e)
+				       (let ([d (make-object wx:style-delta%)])
+					 (send d set-size-add ds)
+					 (send d set-size-mult xs)
+					 (send e change-style d)))))
+			   ls dss xss))])
+	  (add-change-size bigger
+			   '("+1" "+2" "+4" "+8" "+16" "+32")
+			   '(1 2 4 8 16 32)
+			   '(1 1 1 1 1  1))
+	  (mk-sep bigger)
+	  (add-change-size bigger
+			   '("x2" "x3" "x4" "x5")
+			   '(0    0    0    0)
+			   '(2    3    4    5))
+
+	  (add-change-size smaller
+			   '("-1" "-2" "-4" "-8" "-16" "-32")
+			   '(1 -2 -4 -8 -16 -32)
+			   '(1 1   1  1  1  1))
+	  (mk-sep smaller)
+	  (add-change-size smaller
+			   '("/2" "/3" "/5" "/5")
+			   '(0    0    0    0)
+			   '(#i1/2 #i1/3 #i1/4 #i1/5))
+	  
+	  (for-each (lambda (s)
+		      (mk (number->string s) size (lambda (e)
+						    (let ([d (make-object wx:style-delta%)])
+						      (send d set-size-add s)
+						      (send d set-size-mult 0)
+						      (send e change-style d)))))
+		    '(9 10 12 14 16 24 32 48)))
+
+	
+	(let ([mk-cg (lambda (cmd arg)
+		       (lambda (e) (send e change-style (make-object wx:style-delta% cmd arg))))])
+
+					; Style
+	  (for-each (lambda (name s)
+		      (mk name style (mk-cg 'change-style s)))
+		    '("Normal" "Italic" "Slant")
+		    '(normal italic slant))
+	  
+					; Weight
+	  (for-each (lambda (name s)
+		      (mk name weight (mk-cg 'change-weight s)))
+		    '("Normal" "Bold" "Light")
+		    '(normal bold light))
+	  
+					; Underline
+	  (mk "No Underline" underline (mk-cg 'change-underline #f))
+	  (mk "Underline" underline (mk-cg 'change-underline #t))
+	  (mk "Toggle" underline (lambda (e) (send e change-style (make-object wx:style-delta% 'change-toggle-underline))))
+
+					; Alignment
+	  (for-each (lambda (name s)
+		      (mk name alignment (mk-cg 'change-alignment s)))
+		    '("Top" "Center" "Bottom")
+		    '(top center bottom))
+
+	  (let ([colors '("Black" "White" "Red" "Orange" "Yellow" "Green" "Blue" "Purple" "Cyan" "Magenta" "Grey")])
+
+					; Colors
+	    (for-each (lambda (c)
+			(mk c color (lambda (e) (let ([d (make-object wx:style-delta%)])
+						  (send d set-delta-foreground c)
+						  (send e change-style d)))))
+		      colors)
+
+					; Background
+	    (mk "Transparent" background (lambda (e) (let ([d (make-object wx:style-delta%)])
+						       (send d set-transparent-text-backing-on #t)
+						       (send e change-style d))))
+	    (for-each (lambda (c)
+			(mk c background (lambda (e) (let ([d (make-object wx:style-delta%)])
+						       (send d set-delta-background c)
+						       (send e change-style d)))))
+		      colors)))))))
diff --git a/collects/mred/private/filedialog.ss b/collects/mred/private/filedialog.ss
new file mode 100644
index 0000000000..34085447d0
--- /dev/null
+++ b/collects/mred/private/filedialog.ss
@@ -0,0 +1,322 @@
+(module filedialog mzscheme
+  (require (lib "class.ss")
+	   (lib "class100.ss")
+	   (lib "etc.ss")
+	   (lib "list.ss")
+	   (prefix wx: "kernel.ss")
+	   "lock.ss"
+	   "wx.ss"
+	   "cycle.ss"
+	   "check.ss"
+	   "helper.ss"
+	   "editor.ss"
+	   "mrtop.ss"
+	   "mrcanvas.ss"
+	   "mrpopup.ss"
+	   "mrmenu.ss"
+	   "mritem.ss"
+	   "mrpanel.ss"
+	   "mrtextfield.ss"
+	   "messagebox.ss")
+
+  (provide get-file
+	   get-file-list
+	   put-file
+	   get-directory)
+
+  (define last-visted-directory #f)
+
+  (define (files->list s)
+    (let ([s (open-input-bytes s)])
+      (let loop ()
+	(let ([n (read s)])
+	  (if (eof-object? n)
+	      null
+	      (begin
+		(read-byte s) ; drop space
+		(cons (read-bytes n s)
+		      (loop))))))))
+
+  (define (mk-file-selector who put? multi? dir? force-unix?)
+    (lambda (message parent directory filename extension style filters)
+      ;; Calls from C++ have wrong kind of window:
+      (when (is-a? parent wx:window%)
+	(set! parent (as-entry (lambda () (wx->mred parent)))))
+
+      (check-label-string/false who message)
+      (check-top-level-parent/false who parent)
+      (check-path/false who directory) (check-path/false who filename) (check-string/false who extension)
+      (check-style who #f (cond
+			   [put? null]
+			   [dir? '(enter-packages)]
+			   [else '(packages enter-packages)]) style)
+      (unless (and (list? filters)
+		   (andmap (lambda (p)
+			     (and (list? p)
+				  (= (length p) 2)
+				  (string? (car p))
+				  (string? (cadr p))))
+			   filters))
+	(raise-type-error who "list of 2-string lists" filters))
+      (if (not (or (eq? (system-type) 'unix)
+		   force-unix?))
+	  (let ([s (wx:file-selector message directory filename extension 
+				     ;; file types:
+				     (apply string-append
+					    (map (lambda (s) (format "~a|~a|" (car s) (cadr s)))
+						 filters))
+				     ;; style:
+				     (cons
+				      (cond
+				       [dir? 'dir]
+				       [put? 'put]
+				       [multi? 'multi]
+				       [else 'get])
+				      style)
+				     ;; parent:
+				     (and parent (mred->wx parent)))])
+	    (if (and multi? s)
+		(map bytes->path (files->list (path->bytes s)))
+		s))
+	  (letrec ([ok? #f]
+		   [typed-name #f]
+		   [dir (or (and directory (if (string? directory)
+					       (string->path directory)
+					       directory))
+			    last-visted-directory 
+			    (current-directory))]
+		   [f (make-object dialog% (if dir? "Select Directory" (if put? "Save" "Open")) parent 500 300)]
+		   [__ (when message
+			 (let ([p (make-object vertical-pane% f)])
+			   (send p stretchable-height #f)
+			   (make-object message% (protect& message) p)))]
+		   [dir-pane (instantiate horizontal-pane% (f) (stretchable-height #f))]
+		   [m (make-object message% (protect& (path->string dir)) dir-pane)]
+		   [lp (make-object horizontal-pane% f)]
+		   [change-dir (lambda (d) (let ([sd (send d get-string-selection)])
+					     (when sd
+					       (set! dir (simplify-path (build-path dir sd)))
+					       (reset-directory))))]
+		   [dirs (make-object (class list-box%
+					(define/override (on-subwindow-char w e)
+					  (cond
+					   [(and (send e get-meta-down)
+						 (eq? (send e get-key-code) 'down))
+					    (change-dir w)]
+					   [(and (send e get-meta-down)
+						 (eq? (send e get-key-code) 'up))
+					    (send dirs set-selection 0)
+					    (change-dir dirs)]
+					   [else
+					    (super on-subwindow-char w e)]))
+					(super-instantiate ()))
+				      #f null lp (lambda (d e)
+						   (update-ok)
+						   (when (eq? (send e get-event-type) 'list-box-dclick)
+						     (change-dir d))))]
+		   [dir-paths null]
+		   [files (make-object list-box% #f null lp (lambda (d e)
+							      (update-ok)
+							      (when (eq? (send e get-event-type) 'list-box-dclick)
+								(done)))
+				       (if multi? '(multiple) '(single)))]
+		   [file-paths null]
+		   [do-text-name (lambda ()
+				   (let ([v (send dir-text get-value)])
+				     (if (or dir? (directory-exists? v))
+					 (begin
+					   (set! dir (string->path v))
+					   (reset-directory))
+					 ;; Maybe specifies a file:
+					 (let-values ([(super file) 
+						       (with-handlers ([void #f])
+							 (let-values ([(base name dir?) (split-path v)])
+							   (let ([super (and (not dir?) 
+									     (or (and (path? base) 
+										      (directory-exists? base)
+										      base)
+										 (and (eq? base 'relative) 
+										      (directory-exists? dir) dir)))])
+							     (if super
+								 (values super name)
+								 (values #f #f)))))])
+					   (if super
+					       (begin
+						 (set! dir super)
+						 (set! typed-name file)
+						 (done))
+					       (begin
+						 (set! dir (string->path v))
+						 (reset-directory)))))))]
+		   [dir-text (make-object text-field% #f f (lambda (t e)
+							     (if (eq? (send e get-event-type) 'text-field-enter)
+								 (do-text-name)
+								 (begin
+					; typing in the box; disable the lists and enable ok
+								   (send dirs enable #f)
+								   (send files enable #f)
+								   (when create-button
+								     (send create-button enable #t))
+								   (send ok-button enable #t)))))]
+		   [bp (make-object horizontal-pane% f)]
+		   [dot-check (make-object check-box% "Show files/directories that start with \".\"" bp (lambda (b e) (reset-directory)))]
+		   [spacer (make-object vertical-pane% bp)]
+		   [create-button (and dir? (make-object button% "Create" bp
+							 (lambda (b e)
+							   (with-handlers ([void
+									    (lambda (exn)
+									      (message-box "Error"
+											   (exn-message exn)
+											   f
+											   '(ok stop)))])
+							     (make-directory (send dir-text get-value))
+							     (do-text-name)))))]
+		   [cancel-button (make-object button% "Cancel" bp (lambda (b e) (set! ok? #f) (send f show #f)))]
+		   [ok-button (make-object button% 
+					   (if dir? "Goto" "OK")
+					   bp (lambda (b e) 
+						(if (send (if dir? dirs files) is-enabled?)
+						    ;; normal mode
+						    (if dir?
+							(change-dir dirs)
+							(done))
+						    ;; handle typed text
+						    (do-text-name))) 
+					   '(border))]
+		   [update-ok (lambda () (send ok-button enable (not (null? (send (if dir? dirs files) get-selections)))))]
+		   [select-this-dir (and dir?
+					 (make-object button% "<- &Select" dir-pane
+						      (lambda (b e)
+							(send f show #f)
+							(done))))]
+		   [path-string-locale<? (lambda (p1 p2)
+					   (string-locale<? (path->string p1) (path->string p2)))]
+		   [reset-directory (lambda ()
+				      (wx:begin-busy-cursor)
+				      (let ([dir-exists? (directory-exists? dir)])
+					(send m set-label (protect&
+							   (if dir-exists?
+							       (begin
+								 (unless directory
+								   (set! last-visted-directory dir))
+								 (path->string dir))
+							       (string-append "BAD DIRECTORY: " (path->string dir)))))
+					(when select-this-dir
+					  (send select-this-dir enable dir-exists?))
+					(when create-button
+					  (send create-button enable (not dir-exists?))))
+				      (send dir-text set-value (path->string dir))
+				      (let ([l (with-handlers ([void (lambda (x) null)])
+						 (directory-list dir))]
+					    [dot? (send dot-check get-value)])
+					(let-values ([(ds fs)
+						      (let loop ([l l][ds null][fs null])
+							(cond
+							 [(null? l) (values (cons (string->path "..")
+										  (quicksort ds path-string-locale<?)) 
+									    (quicksort fs path-string-locale<?))]
+							 [(and (not dot?) 
+							       (char=? (string-ref (path->string (car l)) 0) #\.)) 
+							  (loop (cdr l) ds fs)]
+							 [(file-exists? (build-path dir (car l))) (loop (cdr l) ds (cons (car l) fs))]
+							 [else (loop (cdr l) (cons (car l) ds) fs)]))])
+					  (set! dir-paths ds)
+					  (send dirs set (map path->string ds))
+					  (set! file-paths fs)
+					  (send files set (map path->string fs))
+					  (send dirs enable #t)
+					  (unless dir?
+					    (send files enable #t))
+					  (update-ok)
+					  (wx:end-busy-cursor))))]
+		   [get-filename (lambda () 
+				   (if dir?
+				       dir
+				       (let ([mk (lambda (f) (simplify-path (build-path dir f)))])
+					 (let ([l (map mk (if typed-name
+							      (list typed-name)
+							      (map (lambda (p) (list-ref (if dir? dir-paths file-paths) p))
+								   (send (if dir? dirs files) get-selections))))])
+					   (if multi? l (car l))))))]
+		   [done (lambda ()
+			   (let ([name (get-filename)])
+			     (unless (and put? (file-exists? name)
+					  (eq? (message-box "Warning" 
+							    (format "Replace ~s?" (path->string name) )
+							    f '(yes-no)) 
+					       'no)
+					  (set! typed-name #f))
+			       (set! ok? #t)
+			       (send f show #f))))])
+	    (send bp stretchable-height #f)
+	    (send m stretchable-width #t)
+	    (reset-directory)
+	    (when filename
+	      (when (string? filename)
+		(set! filename (string->path filename)))
+	      (let ([d (send dir-text get-value)])
+		(send dir-text set-value (path->string (build-path d filename)))
+		(set! typed-name filename)
+		(send ok-button enable #t)))
+	    (when put?
+	      (send dir-text focus))
+	    (when dir?
+	      (send files enable #f))
+	    (send f center)
+	    (send f show #t)
+	    (and ok? (get-filename))))))
+
+					; We duplicate the case-lambda for `get-file', `get-file-list', and `put-file' so that they have the
+					;   right arities and names
+
+  (define default-filters '(("Any" "*.*")))
+
+  (define get-file
+    (case-lambda
+     [() (get-file #f #f #f #f #f null)]
+     [(message) (get-file message #f #f #f #f null)]
+     [(message parent) (get-file message parent #f #f #f null)]
+     [(message parent directory) (get-file message parent directory #f #f null)]
+     [(message parent directory filename) (get-file message parent directory filename #f null)]
+     [(message parent directory filename extension) (get-file message parent directory filename extension null)]
+     [(message parent directory filename extension style)
+      (get-file message parent directory filename extension style default-filters)]
+     [(message parent directory filename extension style filters)
+      ((mk-file-selector 'get-file #f #f #f #f) message parent directory filename extension style filters)]))
+
+  (define get-file-list
+    (case-lambda
+     [() (get-file-list #f #f #f #f #f null)]
+     [(message) (get-file-list message #f #f #f #f null)]
+     [(message parent) (get-file-list message parent #f #f #f null)]
+     [(message parent directory) (get-file-list message parent directory #f #f null)]
+     [(message parent directory filename) (get-file-list message parent directory filename #f null)]
+     [(message parent directory filename extension) (get-file-list message parent directory filename extension null)]
+     [(message parent directory filename extension style)
+      (get-file-list message parent directory filename extension style default-filters)]
+     [(message parent directory filename extension style filters)
+      ((mk-file-selector 'get-file-list #f #t #f #f) message parent directory filename extension style filters)]))
+
+  (define put-file
+    (case-lambda
+     [() (put-file #f #f #f #f #f null)]
+     [(message) (put-file message #f #f #f #f null)]
+     [(message parent) (put-file message parent #f #f #f null)]
+     [(message parent directory) (put-file message parent directory #f #f null)]
+     [(message parent directory filename) (put-file message parent directory filename #f null)]
+     [(message parent directory filename extension) (put-file message parent directory filename extension null)]
+     [(message parent directory filename extension style)
+      (put-file message parent directory filename extension style default-filters)]
+     [(message parent directory filename extension style filters)
+      ((mk-file-selector 'put-file #t #f #f #f) message parent directory filename extension style filters)]))
+
+  (define get-directory
+    (case-lambda
+     [() (get-directory #f #f #f null)]
+     [(message) (get-directory message #f #f null)]
+     [(message parent) (get-directory message parent #f null)]
+     [(message parent directory) (get-directory message parent directory null)]
+     [(message parent directory style)
+      ((mk-file-selector 'get-directory #f #f #t #f) message parent directory #f #f style null)]))
+
+  (set-get-file! get-file))
diff --git a/collects/mred/private/fontdialog.ss b/collects/mred/private/fontdialog.ss
new file mode 100644
index 0000000000..d2aa036090
--- /dev/null
+++ b/collects/mred/private/fontdialog.ss
@@ -0,0 +1,134 @@
+(module fontdialog mzscheme
+  (require (lib "class.ss")
+	   (lib "class100.ss")
+	   (lib "etc.ss")
+	   (lib "list.ss")
+	   (prefix wx: "kernel.ss")
+	   "lock.ss"
+	   "wx.ss"
+	   "cycle.ss"
+	   "check.ss"
+	   "helper.ss"
+	   "gdi.ss"
+	   "editor.ss"
+	   "mrtop.ss"
+	   "mrcanvas.ss"
+	   "mrpopup.ss"
+	   "mrmenu.ss"
+	   "mritem.ss"
+	   "mrpanel.ss"
+	   "mrtextfield.ss")
+
+  (provide get-font-from-user)
+
+  (define get-font-from-user 
+    (case-lambda
+     [() (get-font-from-user #f #f #f null)]
+     [(message) (get-font-from-user message #f #f null)]
+     [(message parent) (get-font-from-user message parent #f null)]
+     [(message parent font) (get-font-from-user message parent font null)]
+     [(message parent font style)
+      (check-label-string/false 'get-font-from-user message)
+      (check-top-level-parent/false 'get-font-from-user parent)
+      (check-instance 'get-font-from-user wx:font% 'font% #t font)
+      (check-style 'get-font-from-user #f null style)
+      (letrec ([ok? #f]
+	       [f (make-object dialog% "Choose Font" parent 500 300)]
+	       [refresh-sample (lambda (b e) (let ([f (get-font)])
+					       (send ok-button enable f)
+					       (when f
+						 (let ([s (send (send edit get-style-list) find-named-style "Standard")])
+						   (send s set-delta (font->delta f))))))]
+	       [p (make-object horizontal-pane% f)]
+	       [face (make-object list-box% #f
+				  (let ([l (wx:get-face-list)]
+					[ugly? (lambda (a)
+						 (and (positive? (string-length a))
+						      (not (or (char-alphabetic? (string-ref a 0))
+							       (char-numeric? (string-ref a 0))
+							       (char=? #\- (string-ref a 0))))))])
+				    ;; Sort space-starting first (for Xft), and
+				    ;;  otherwise push names that start with an
+				    ;;  ASCII non-letter/digit/hyphen to the end
+				    (quicksort l (lambda (a b)
+						   (let ([a-sp? (char=? #\space (string-ref a 0))]
+							 [b-sp? (char=? #\space (string-ref b 0))]
+							 [a-ugly? (ugly? a)]
+							 [b-ugly? (ugly? b)])
+						     (cond
+						      [(eq? a-sp? b-sp?)
+						       (cond
+							[(eq? a-ugly? b-ugly?)
+							 (string-locale-ci<? a b)]
+							[else
+							 b-ugly?])]
+						      [else a-sp?])))))
+				  p refresh-sample)]
+	       [p2 (make-object vertical-pane% p)]
+	       [p3 (instantiate horizontal-pane% (p2) [stretchable-width #f])]
+	       [style (let ([pnl (instantiate group-box-panel% ("Style" p3) [stretchable-height #f] [stretchable-width #f])])
+			(make-object radio-box% #f '("Normal" "Italic" "Slant") pnl refresh-sample))]
+	       [weight (let ([pnl (instantiate group-box-panel% ("Weight" p3) [stretchable-height #f] [stretchable-width #f])])
+			 (make-object radio-box% #f '("Normal" "Bold" "Light") pnl refresh-sample))]
+	       [p4 (instantiate vertical-pane% (p3) [alignment '(left center)])]
+	       [underlined (make-object check-box% "Underlined" p4 refresh-sample)]
+	       [smoothing (make-object choice% "Smoothing:" '("Default" "Some" "Full" "None") p4 refresh-sample)]
+	       [sip (make-object check-box% "Size in Pixels" p4 refresh-sample)]
+	       [sym (make-object check-box% "Map as Symbol" p4 refresh-sample)]
+	       [size (make-object slider% "Size:" 4 127 p2 refresh-sample 12)]
+	       [sample (make-object text-field% "Sample" f void "The quick brown fox jumped over the lazy dog" '(multiple))]
+	       [edit (send sample get-editor)]
+	       [done (lambda (ok) (lambda (b e) (set! ok? ok) (send f show #f)))]
+	       [get-font (lambda () (let ([face (send face get-string-selection)])
+				      (and face
+					   (make-object wx:font% (send size get-value) face 
+							(if (send sym get-value)
+							    'symbol
+							    'default)
+							(case (send style get-selection) [(0) 'normal] [(1) 'italic] [(2) 'slant])
+							(case (send weight get-selection) [(0) 'normal] [(1) 'bold] [(2) 'light])
+							(send underlined get-value)
+							(case (send smoothing get-selection) 
+							  [(0) 'default] 
+							  [(1) 'partly-smoothed]
+							  [(2) 'smoothed]
+							  [(3) 'unsmoothed])
+							(send sip get-value)))))]
+	       [bp (instantiate horizontal-pane% (f) [stretchable-height #f])]
+	       [ms-button (if (eq? (system-type) 'windows)
+			      (begin0
+			       (make-object button% "Use System Dialog..." bp
+					    (lambda (b e)
+					      (let ([new-font (wx:get-font-from-user 
+							       message 
+							       (mred->wx f)
+							       (get-font))])
+						(when new-font
+						  (reset-font new-font)))))
+			       ;; Spacer:
+			       (make-object pane% bp))
+			      (void))]
+	       [cancel-button (make-object button% "Cancel" bp (done #f))]
+	       [ok-button (make-object button% "OK" bp (done #t) '(border))]
+	       [reset-font 
+		(lambda (font)
+		  (let* ([facen (if font
+				    (send font get-face)
+				    (get-family-builtin-face 'default))]
+			 [f (and facen (send face find-string facen))])
+		    (and f (>= f 0) (send face set-selection f)))
+		  (when font
+		    (send style set-selection (case (send font get-style) [(normal) 0] [(italic) 1] [(slant) 2]))
+		    (send weight set-selection (case (send font get-weight) [(normal) 0] [(bold) 1] [(light) 2]))
+		    (send underlined set-value (send font get-underlined))
+		    (send size set-value (send font get-point-size))
+		    (send sip set-value (send font get-size-in-pixels)))
+		  (refresh-sample (void) (void)))])
+	(send bp set-alignment 'right 'center)
+	(send face min-width (max 200 (let-values ([(w h) (send face get-graphical-min-size)]) w)))
+	(reset-font font)
+	(send f center)
+	(send f show #t)
+	(and ok? (get-font)))]))
+
+  (set-get-font-from-user! get-font-from-user))
diff --git a/collects/mred/private/gdi.ss b/collects/mred/private/gdi.ss
new file mode 100644
index 0000000000..f9dd070ced
--- /dev/null
+++ b/collects/mred/private/gdi.ss
@@ -0,0 +1,166 @@
+(module gdi mzscheme
+  (require (lib "class.ss")
+	   (lib "class100.ss")
+	   (prefix wx: "kernel.ss")
+	   "lock.ss"
+	   "check.ss"
+	   "wx.ss"
+	   "mrtop.ss"
+	   "mrcanvas.ss")
+
+  (provide register-collecting-blit
+	   unregister-collecting-blit
+	   bitmap-dc%
+	   post-script-dc%
+	   printer-dc%
+	   get-window-text-extent
+	   get-family-builtin-face
+	   normal-control-font
+	   small-control-font
+	   tiny-control-font
+	   view-control-font
+	   menu-control-font)
+
+  (define register-collecting-blit
+    (case-lambda
+     [(canvas x y w h on off) (register-collecting-blit canvas x y w h on off 0 0 0 0)]
+     [(canvas x y w h on off on-x) (register-collecting-blit canvas x y w h on off on-x 0 0 0)]
+     [(canvas x y w h on off on-x on-y) (register-collecting-blit canvas x y w h on off on-x on-y 0 0)]
+     [(canvas x y w h on off on-x on-y off-x) (register-collecting-blit canvas x y w h on off on-x on-y off-x 0)]
+     [(canvas x y w h on off on-x on-y off-x off-y)
+      (check-instance 'register-collecting-blit canvas% 'canvas% #f canvas)
+      (wx:register-collecting-blit (mred->wx canvas) x y w h on off on-x on-y off-x off-y)]))
+
+  (define unregister-collecting-blit
+    (lambda (canvas)
+      (check-instance 'unregister-collecting-blit canvas% 'canvas% #f canvas)
+      (wx:unregister-collecting-blit (mred->wx canvas))))
+
+  (define bitmap-dc%
+    (class100 wx:bitmap-dc% ([bitmap #f])
+      (inherit set-bitmap)
+      (sequence
+	(super-init)
+	(when bitmap
+	  (set-bitmap bitmap)))))
+
+  (define post-script-dc%
+    (class100 wx:post-script-dc% ([interactive #t][parent #f][use-paper-bbox #f][as-eps #t])
+      (sequence
+	(check-top-level-parent/false '(constructor post-script-dc) parent)
+	(as-entry
+	 (lambda ()
+	   (let ([p (and parent (mred->wx parent))])
+	     (as-exit (lambda () (super-init interactive p use-paper-bbox as-eps)))))))))
+
+  (define printer-dc%
+    (class100 wx:printer-dc% ([parent #f])
+      (sequence
+	(check-top-level-parent/false '(constructor printer-dc) parent)
+	(as-entry
+	 (lambda ()
+	   (let ([p (and parent (mred->wx parent))])
+	     (as-exit (lambda () (super-init p)))))))))
+
+  (define get-window-text-extent
+    (let ([bm #f][dc #f])
+      (case-lambda
+       [(string font)
+	(check-string 'get-window-text-extent string)
+	(check-instance 'get-window-text-extent wx:font% 'font% #f font)
+	(unless bm
+	  (set! bm (make-object wx:bitmap% 2 2))
+	  (set! dc (make-object wx:bitmap-dc%))
+	  (send dc set-bitmap bm))
+	(unless (send bm ok?)
+	  (error 'get-window-text-extent "couldn't allocate sizing bitmap"))
+	(let-values ([(w h d a) (send dc get-text-extent string font)])
+	  (values (inexact->exact w) (inexact->exact h)))])))
+
+  (define x-has-xft? 'unknown)
+  (define mswin-system #f)
+  (define mswin-default #f)
+  (define (look-for-font name)
+    (if (ormap (lambda (n) (string-ci=? name n)) (wx:get-face-list))
+	name
+	"MS San Serif"))
+
+  (define (get-family-builtin-face family)
+    (unless (memq family '(default decorative roman script swiss modern system symbol))
+      (raise-type-error 'get-family-builtin-face "family symbol" family))
+    (case (system-type)
+      [(unix)
+       ;; Detect Xft by looking for a font with a space in front of its name:
+       (when (eq? x-has-xft? 'unknown)
+	 (set! x-has-xft? (ormap (lambda (s) (regexp-match #rx"^ " s)) (wx:get-face-list))))
+       (if x-has-xft?
+	   (case family
+	     [(system) " Sans"]
+	     [(default) " Sans"]
+	     [(roman) " Serif"]
+	     [(decorative) " Nimbus Sans L"]
+	     [(modern) " Monospace"]
+	     [(swiss) " Nimbus Sans L"]
+	     [(script) " URW Chancery L"]
+	     [(symbol) " Standard Symbols L,Nimbus Sans L"])
+	   (case family
+	     [(system) "-b&h-lucida"]
+	     [(default) "-b&h-lucida"]
+	     [(roman) "-adobe-times"]
+	     [(decorative) "-adobe-helvetica"]
+	     [(modern) "-adobe-courier"]
+	     [(swiss) "-b&h-lucida"]
+	     [(script) "-itc-zapfchancery"]
+	     [(symbol) "-adobe-symbol"]))]
+      [(windows)
+       (case family
+	 [(system) 
+	  (unless mswin-system 
+	    (set! mswin-system (look-for-font "Tahoma")))
+	  mswin-system]
+	 [(default) 
+	  (unless mswin-default 
+	    (set! mswin-default (look-for-font "Microsoft Sans Serif")))
+	  mswin-default]
+	 [(default) "MS Sans Serif"]
+	 [(roman) "Times New Roman"]
+	 [(decorative) "Arial"]
+	 [(modern) "Courier New"]
+	 [(swiss) "Arial"]
+	 [(script) "Arial"]
+	 [(symbol) "Symbol"])]
+      [(macos)
+       (case family
+	 [(system) "systemfont"]
+	 [(default) "applicationfont"]
+	 [(roman) "Times"]
+	 [(decorative) "Geneva"]
+	 [(modern) "Monaco"]
+	 [(swiss) "Helvetica"]
+	 [(script) "Zaph Chancery"]
+	 [(symbol) "Symbol"])]
+      [(macosx)
+       (case family
+	 [(system) "systemfont"]
+	 [(default) "applicationfont"]
+	 [(roman) "Times"]
+	 [(decorative) "Arial"]
+	 [(modern) "Courier New"]
+	 [(swiss) "Helvetica"]
+	 [(script) "Apple Chancery"]
+	 [(symbol) "Symbol"])]))
+
+  (define small-delta (case (system-type)
+			[(windows) 0]
+			[(macosx) 2]
+			[else 1]))
+
+  (define normal-control-font (make-object wx:font% (wx:get-control-font-size) 'system))
+  (define small-control-font (make-object wx:font% (- (wx:get-control-font-size) small-delta) 'system))
+  (define tiny-control-font (make-object wx:font% (- (wx:get-control-font-size) 2 small-delta) 'system))
+  (define view-control-font (if (eq? 'macosx (system-type))
+				(make-object wx:font% (- (wx:get-control-font-size) 1) 'system)
+				normal-control-font))
+  (define menu-control-font (if (eq? 'macosx (system-type))
+				(make-object wx:font% (+ (wx:get-control-font-size) 1) 'system)
+				normal-control-font)))
diff --git a/collects/mred/private/helper.ss b/collects/mred/private/helper.ss
new file mode 100644
index 0000000000..b938d13892
--- /dev/null
+++ b/collects/mred/private/helper.ss
@@ -0,0 +1,321 @@
+(module helper mzscheme
+  (require (lib "class.ss")
+	   (prefix wx: "kernel.ss")
+	   "lock.ss")
+
+  (provide (protect (struct child-info (x-min y-min x-margin y-margin x-stretch y-stretch))
+		    get-two-int-values
+		    non-negative-number?
+		    same-dimension?
+		    list-diff
+		    key-regexp
+		    do-command
+		    double-boxed
+		    queue-window-callback
+		    param
+		    protect&
+		    find-pos
+		    no-stretch
+		    font->delta
+		    traverse
+		    object->position
+		    container->children
+		    filter-overlapping))
+
+  ;; this structure holds the information that a child will need to send
+  ;; to its parent when the parent must resize itself.
+  (define-struct child-info (x-min y-min           ; includes margins!
+				   x-margin y-margin     ; requested margin space
+				   x-stretch y-stretch)) ; booleans indicating strechability
+
+  ;; get-two-int-values: a wrapper around functions that need to return
+  ;;   two results.
+  ;; input: function: a function which takes two boxes and returns results
+  ;;          in them.
+  ;; returns: the contents of the two boxes (as multiple values)
+  (define get-two-int-values
+    (lambda (function)
+      (let ([a (box 0)]
+	    [b (box 0)])
+	(function a b)
+	(values (unbox a) (unbox b)))))
+
+  (define non-negative-number?
+    (lambda (n)
+      (and (real? n) (not (negative? n)))))
+
+  (define same-dimension?
+    (lambda (new-dim current-dim)
+      (or (= new-dim current-dim)
+	  (= new-dim -1))))
+  
+  ;; list-diff: computes the difference between two lists
+  ;; input: l1, l2: two lists
+  ;; returns:  a list of all elements in l1 which are not in l2.
+  (define list-diff
+    (lambda (l1 l2)
+      (let ([table (make-hash-table)])
+	(for-each
+	 (lambda (item)
+	   (hash-table-put! table item #t))
+	 l2)
+	(let loop ([l l1])
+	  (cond
+	   [(null? l) null]
+	   [(hash-table-get table (car l) (lambda () #f))
+	    (loop (cdr l))]
+	   [else (cons (car l) (loop (cdr l)))])))))
+
+  (define (key-regexp c)
+    (regexp (format "(^|[^&])&[~a~a]" (char-downcase c) (char-upcase c))))
+  
+  (define (do-command c e)
+    (as-exit (lambda () (send c command e))))
+
+  (define double-boxed
+    (lambda (x y f)
+      (let ([x (box x)][y (box y)])
+	(f x y)
+	(values (unbox x) (unbox y)))))
+
+  (define (queue-window-callback w cb)
+    (parameterize ([wx:current-eventspace (send (send w get-top-level) get-eventspace)])
+      (wx:queue-callback cb wx:middle-queue-key)))
+
+  (define-syntax (param stx)
+    (syntax-case stx ()
+      [(_ get-obj method)
+       (syntax/loc stx
+	 (entry-point
+	  (case-lambda
+	   [() (send (get-obj) method)]
+	   [(v) (send (get-obj) method v)])))]))
+
+  (define (font->delta f)
+    (define d (make-object wx:style-delta%))
+    (let ([v (send f get-face)]
+	  [m (send f get-family)])
+      (if v
+	  (send d set-delta-face v m)
+	  (send d set-delta 'change-family m)))
+    (send d set-delta 'change-size (send f get-point-size))
+    (send d set-delta 'change-style (send f get-style))
+    (send d set-delta 'change-weight (send f get-weight))
+    (send d set-delta 'change-underline (send f get-underlined))
+    (send d set-delta 'change-smoothing (send f get-smoothing))
+    (send d set-delta 'change-size-in-pixels (send f get-size-in-pixels))
+    d)
+
+  (define protect&
+    (lambda (s)
+      (regexp-replace* #rx"&" s "\\&\\&")))
+
+  (define (find-pos l i eq?)
+    (let loop ([l l][n 0])
+      (cond
+       [(null? l) #f]
+       [(eq? (car l) i) n]
+       [else (loop (cdr l) (add1 n))])))
+
+  (define (no-stretch a) 
+    (send a stretchable-width #f) (send a stretchable-height #f))
+  
+  ;; ;;;;;;;;;;;;; Focus-tabbing helpers ;;;;;;;;;;;;;;;;;;;;
+
+  (define (traverse x y w h dir dests)
+    ;; x, y : real = starting positions
+    ;; dir : one of 'left, 'right, 'up, 'next, 'prev = desried move
+    ;; dests : list of (cons key x y w h) = destinations
+    ;; returns key or #f
+    (case dir
+      [(next prev)
+       (letrec ([get-x cadr]
+		[get-w cadddr]
+		[get-y caddr]
+		[get-h (lambda (x) (caddr (cddr x)))]
+		[backward? (eq? dir 'prev)]
+		[fail-start (if backward?
+				1000000000
+				0)]
+		[find-stripe (lambda (t stripes)
+			       (let loop ([s stripes])
+				 (cond
+				  [(null? s) #f]
+				  [(and (<= (caar s) t) (< t (cdar s)))
+				   (car s)]
+				  [else (loop (cdr s))])))]
+		[mk-stripes
+		 (lambda (get-y get-h stripes dests)
+		   (let loop ([l (append (map (lambda (x) (cons (car x) (- (cdr x) (car x))))
+					      stripes)
+					 (map (lambda (x) 
+						(cons (get-y x) (get-h x)))
+					      dests))])
+		     (if (null? l)
+			 null
+			 ;; Find longest top-most
+			 (let* ([top (let loop ([l (cdr l)][best (car l)])
+				       (cond
+					[(null? l) best]
+					[(or (< (caar l) (car best)) ; topmost
+					     (and (= (caar l) (car best)) ; at least as top
+						  (> (cdar l) (cdr best)))) ; longer
+					 (loop (cdr l) (car l))]
+					[else (loop (cdr l) best)]))]
+				[t (car top)]
+				[b (+ t (cdr top))])
+			   ;; Stripe is anything that starts before the end of `top'
+			   (let ([remaining (let loop ([l l])
+					      (cond
+					       [(null? l) null]
+					       [(find-stripe (caar l) (list (cons t b)))
+						(loop (cdr l))]
+					       [else (cons (car l) (loop (cdr l)))]))])
+			     (cons (cons t b) (loop remaining)))))))]
+		[in-stripe (lambda (stripe dests get-y get-h)
+			     (let loop ([l dests])
+			       (cond
+				[(null? l) null]
+				[(find-stripe (get-y (car l)) (list stripe))
+				 (cons (car l) (loop (cdr l)))]
+				[else (loop (cdr l))])))]
+		[next-stripe (lambda (stripe stripes)
+			       (let loop ([s stripes][best #f])
+				 (cond
+				  [(null? s) best]
+				  [(and (or (not stripe)
+					    (if backward?
+						(<= (cdar s) (car stripe))
+						(>= (caar s) (cdr stripe))))
+					(or (not best)
+					    (if backward?
+						(> (cdar s) (cdr best))
+						(< (caar s) (cdr best)))))
+				   (loop (cdr s) (car s))]
+				  [else (loop (cdr s) best)])))]
+		[find (lambda (get-x get-w get-y get-h use-x? x w use-y? y h dests fail)
+			;; find's variable names correspond to an h-stripe view, but everything is
+			;;  flipped to v-stripes if the args are flipped
+			(let ([h-stripes (mk-stripes get-y get-h 
+						     (if use-y? (list (cons y (+ y h))) null)
+						     dests)])
+
+			  ;; find the initial h-stripe
+			  (let sel-h-stripe-loop ([init-h-stripe (if use-y?
+								     (find-stripe y h-stripes)
+								     (next-stripe #f h-stripes))]
+						  [x x][w w][use-x? use-x?])
+			    
+			    ;; find items in the initial stripe
+			    (let ([in-init-h-stripe (in-stripe init-h-stripe dests get-y get-h)]
+				  [next (lambda ()
+					  (let ([s (next-stripe init-h-stripe h-stripes)])
+					    (if s
+						(sel-h-stripe-loop s fail-start fail-start #f)
+						(fail))))])
+
+			      (if (null? in-init-h-stripe)
+
+				  ;; no items in this stripe; try the next one
+				  (next)
+				  
+				  ;; Non-empty h-stripe; now look for items in the same or later v-stripe
+				  (if (null? (cdr in-init-h-stripe))
+				      
+				      ;; one item in the stripe; take it unless we're using x and it's
+				      ;;  before x:
+				      (if (or (not use-x?)
+					      ((if backward? < >) (get-x (car in-init-h-stripe)) x))
+					  (car in-init-h-stripe)
+					  
+					  ;; Only item is no good; try the next stripe
+					  (next))
+				      
+				      ;; Recur to work with v-stripes
+				      (find get-y get-h get-x get-w use-y? y h use-x? x w in-init-h-stripe next)))))))])
+	 (if (null? dests)
+	     #f
+	     (car (find get-x get-w get-y get-h #t x w #t y h dests
+			(lambda ()
+			  (find get-x get-w get-y get-h 
+				#f fail-start fail-start 
+				#f fail-start fail-start 
+				dests void))))))]
+      [else
+       (let ([v (let loop ([d dests])
+		  (if (null? d)
+		      #f
+		      (let* ([best (loop (cdr d))]
+			     [this (car d)]
+			     [diff (lambda (v l x w)
+				     (cond
+				      [(< (+ v l) x) (- x (+ v l))]
+				      [(< (+ x w) v) (- (+ x w) v)]
+				      [else 0]))])
+			(let* ([get-x cadr]
+			       [get-w cadddr]
+			       [get-y caddr]
+			       [get-h (lambda (x) (caddr (cddr x)))]
+			       [tdx (diff x w (get-x this) (get-w this))]
+			       [tdy (diff y h (get-y this) (get-h this))]
+			       [bdx (and best (diff x w (get-x best) (get-w best)))]
+			       [bdy (and best (diff y h (get-y best) (get-h best)))]
+			       [better (lambda (tdx tdy bdy negative?)
+					 (if (and (zero? tdx) (negative? tdy)
+						  (or (not best) 
+						      (< (abs tdy) (abs bdy))))
+					     this
+					     best))])
+			  (case dir
+			    [(up) (better tdx tdy bdy negative?)]
+			    [(down) (better tdx tdy bdy positive?)]
+			    [(left) (better tdy tdx bdx negative?)]
+			    [(right) (better tdy tdx bdx positive?)])))))])
+	 (and v (car v)))]))
+
+  (define (object->position o)
+    (let-values ([(x y) (double-boxed 0 0 (lambda (x y) (send o client-to-screen x y)))]
+		 [(w h) (double-boxed 0 0 (lambda (x y) (send o get-client-size x y)))])
+      (send o tabbing-position x y w h)))
+
+  (define (container->children f except must-focus?)
+    (apply
+     append
+     (map
+      (lambda (i)
+	(cond
+	 [(send i has-tabbing-children?)
+	  (if (send i is-shown-to-root?)
+	      (container->children i except must-focus?)
+	      null)]
+	 [(or (eq? i except) 
+	      (and must-focus? (not (send i gets-focus?)))
+	      (not (send i is-enabled-to-root?))
+	      (not (send i is-shown-to-root?)))
+	  null]
+	 [else (list i)]))
+      (send f get-children))))
+
+  (define (filter-overlapping l)
+    (if (null? l)
+	null
+	(let* ([rest (filter-overlapping (cdr l))]
+	       [first (car l)]
+	       [f (cdr first)]
+	       [x (car f)]
+	       [y (cadr f)]
+	       [x2 (+ x (caddr f))]
+	       [y2 (+ y (cadddr f))])
+	  (if (ormap (lambda (other)
+		       (let* ([p (cdr other)]
+			      [px (car p)]
+			      [py (cadr p)]
+			      [px2 (+ px (caddr p))]
+			      [py2 (+ py (cadddr p))])
+			 (and (or (<= x px x2) (<= x px2 x2)
+				  (<= px x px2) (<= px x2 px2))
+			      (or (<= y py y2) (<= y py2 y2)
+				  (<= py y py2) (<= py y2 py2)))))
+		     rest)
+	      rest
+	      (cons first rest))))))
diff --git a/collects/mred/private/info.ss b/collects/mred/private/info.ss
new file mode 100644
index 0000000000..ab5e60127e
--- /dev/null
+++ b/collects/mred/private/info.ss
@@ -0,0 +1,3 @@
+
+(module info (lib "infotab.ss" "setup")
+  (define name "MrEd private"))
diff --git a/collects/mred/private/kernel.ss b/collects/mred/private/kernel.ss
new file mode 100644
index 0000000000..88a83ab16d
--- /dev/null
+++ b/collects/mred/private/kernel.ss
@@ -0,0 +1,1557 @@
+
+;; The parts of kernel.ss are generated by xctocc.
+;; kernel.ss is generated by a target in <builddir>/mred/wxs/Makefile.
+
+(module kernel mzscheme
+  (require (all-except (lib "class.ss") object%))
+
+  ;; Pull pieces out of #%mred-kernel dynamically, so that
+  ;;  the library compiles with setup-plt in mzscheme.
+  
+  (define kernel:initialize-primitive-object
+    (dynamic-require '#%mred-kernel 'initialize-primitive-object))
+  (define kernel:primitive-class-find-method
+    (dynamic-require '#%mred-kernel 'primitive-class-find-method))
+  (define kernel:primitive-class-prepare-struct-type!
+    (dynamic-require '#%mred-kernel 'primitive-class-prepare-struct-type!))
+
+  (define-syntax define-constant
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ name)
+	 (with-syntax ([kernel:name (datum->syntax-object
+				     (syntax name)
+				     (string->symbol
+				      (format 
+				       "kernel:~a"
+				       (syntax-e (syntax name))))
+				     #f)])
+	   (syntax
+	    (begin
+	      (define kernel:name (dynamic-require '#%mred-kernel 'name))
+	      (provide (protect (rename kernel:name name))))))])))
+
+  (define-syntax define-function
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ name)
+	 (syntax (define-constant name))])))
+
+  (define-syntax define-functions
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ name ...)
+	 (syntax (begin (define-function name) ...))])))
+
+  (define-syntax define-a-class
+    (let ([defined null])
+      (lambda (stx)
+	(syntax-case stx ()
+	  [(_ name print-name super args id ...)
+	   (let ([nm (syntax-e (syntax name))]
+		 [sn (syntax-e (syntax super))]
+		 [ids (map syntax-e (syntax->list (syntax (id ...))))])
+	     ;; find superclass
+	     (let ([sup (assoc sn defined)])
+	       (unless (or sup (not sn))
+		 (raise-syntax-error
+		  'class
+		  "class not yet defined"
+		  stx
+		  (syntax super)))
+	       ;; add this class to the list:
+	       (set! defined (cons (cons nm (append (if sup
+							(cdr sup)
+							null)
+						    ids))
+				   defined))
+	       (let-values ([(old new)
+			     (let loop ([l ids][o null][n null])
+			       (cond
+				[(null? l) (values o n)]
+				[(memq (car l) (cdr sup))
+				 (loop (cdr l) (cons (car l) o) n)]
+				[else
+				 (loop (cdr l) o (cons (car l) n))]))])
+		 (with-syntax ([(old ...) (datum->syntax-object #f old #f)]
+			       [(new ...) (datum->syntax-object #f new #f)])
+		   (syntax
+		    (define name (let ([c (dynamic-require '#%mred-kernel 'name)])
+				   (make-primitive-class
+				    (lambda (class prop:object preparer dispatcher)
+				      (kernel:primitive-class-prepare-struct-type! 
+				       c prop:object class preparer dispatcher))
+				    kernel:initialize-primitive-object
+				    'print-name super 'args
+				    '(old ...)
+				    '(new ...)
+				    (list
+				     (kernel:primitive-class-find-method c 'old)
+				     ...)
+				    (list
+				     (kernel:primitive-class-find-method c 'new)
+				     ...)))))))))]))))
+
+  (define-syntax define-class
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ name super args id ...)
+	 (syntax
+	  (begin 
+	    (define-a-class name name super args id ...)
+	    (provide (protect name))))])))
+
+  (define-syntax define-private-class
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ name intf super args id ...)
+	 (syntax
+	  (begin 
+	    (define-a-class name intf super args id ...)
+	    (define intf (class->interface name))
+	    (provide (protect intf))))])))
+  (define-class object% #f #f)
+  (define-class window% object% #f
+    on-drop-file
+    pre-on-event
+    pre-on-char
+    on-size
+    on-set-focus
+    on-kill-focus
+    get-handle
+    is-enabled-to-root?
+    is-shown-to-root?
+    set-phantom-size
+    get-y
+    get-x
+    get-width
+    get-height
+    popup-menu
+    center
+    get-text-extent
+    get-parent
+    refresh
+    screen-to-client
+    client-to-screen
+    drag-accept-files
+    enable
+    get-position
+    get-client-size
+    get-size
+    fit
+    is-shown?
+    show
+    set-cursor
+    move
+    set-size
+    set-focus
+    gets-focus?
+    centre)
+  (define-class item% window% #f
+    set-label
+    get-label
+    command)
+  (define-class message% item% #f
+    get-font
+    set-label
+    on-drop-file
+    pre-on-event
+    pre-on-char
+    on-size
+    on-set-focus
+    on-kill-focus)
+  (define-private-class editor% editor<%> object% #f
+    dc-location-to-editor-location
+    editor-location-to-dc-location
+    set-inactive-caret-threshold
+    get-inactive-caret-threshold
+    get-focus-snip
+    end-write-header-footer-to-file
+    begin-write-header-footer-to-file
+    print
+    insert-image
+    insert-box
+    get-filename
+    is-modified?
+    is-locked?
+    lock
+    set-cursor
+    get-paste-text-only
+    set-paste-text-only
+    get-load-overwrites-styles
+    set-load-overwrites-styles
+    set-style-list
+    get-style-list
+    get-keymap
+    set-keymap
+    can-do-edit-operation?
+    do-edit-operation
+    get-max-undo-history
+    set-max-undo-history
+    add-undo
+    clear-undos
+    redo
+    undo
+    select-all
+    clear
+    get-view-size
+    get-dc
+    local-to-global
+    global-to-local
+    locked-for-flow?
+    locked-for-write?
+    locked-for-read?
+    set-admin
+    get-admin
+    print-to-dc
+    find-scroll-line
+    num-scroll-lines
+    scroll-line-location
+    get-snip-location
+    locations-computed?
+    in-edit-sequence?
+    refresh-delayed?
+    end-edit-sequence
+    begin-edit-sequence
+    style-has-changed
+    set-min-height
+    set-max-height
+    get-min-height
+    get-max-height
+    set-min-width
+    set-max-width
+    get-min-width
+    get-max-width
+    insert-file
+    load-file
+    insert-port
+    save-file
+    get-flattened-text
+    put-file
+    get-file
+    after-edit-sequence
+    on-edit-sequence
+    after-load-file
+    on-load-file
+    can-load-file?
+    after-save-file
+    on-save-file
+    can-save-file?
+    on-new-box
+    on-new-image-snip
+    invalidate-bitmap-cache
+    on-paint
+    write-footers-to-file
+    write-headers-to-file
+    read-footer-from-file
+    read-header-from-file
+    write-to-file
+    read-from-file
+    set-filename
+    release-snip
+    on-snip-modified
+    set-modified
+    set-snip-data
+    get-snip-data
+    needs-update
+    resized
+    set-caret-owner
+    scroll-to
+    on-display-size-when-ready
+    on-display-size
+    on-change
+    on-focus
+    on-default-char
+    on-default-event
+    on-local-char
+    on-local-event
+    find-first-snip
+    get-space
+    get-descent
+    get-extent
+    blink-caret
+    own-caret
+    refresh
+    adjust-cursor
+    on-char
+    on-event
+    copy-self-to
+    copy-self
+    kill
+    paste-x-selection
+    paste
+    copy
+    cut
+    insert
+    change-style)
+  (define-function get-the-editor-data-class-list)
+  (define-function get-the-snip-class-list)
+  (define-function editor-set-x-selection-mode)
+  (define-function add-pasteboard-keymap-functions)
+  (define-function add-text-keymap-functions)
+  (define-function add-editor-keymap-functions)
+  (define-function write-editor-global-footer)
+  (define-function write-editor-global-header)
+  (define-function read-editor-global-footer)
+  (define-function read-editor-global-header)
+  (define-function read-editor-version)
+  (define-function write-editor-version)
+  (define-function set-editor-print-margin)
+  (define-function get-editor-print-margin)
+  (define-class bitmap% object% #f
+    get-gl-config
+    set-gl-config
+    set-loaded-mask
+    get-loaded-mask
+    save-file
+    load-file
+    is-color?
+    ok?
+    get-width
+    get-height
+    get-depth)
+  (define-class button% item% #f
+    set-border
+    set-label
+    on-drop-file
+    pre-on-event
+    pre-on-char
+    on-size
+    on-set-focus
+    on-kill-focus)
+  (define-class choice% item% #f
+    set-selection
+    get-selection
+    number
+    clear
+    append
+    on-drop-file
+    pre-on-event
+    pre-on-char
+    on-size
+    on-set-focus
+    on-kill-focus)
+  (define-function set-combo-box-font)
+  (define-class check-box% item% #f
+    set-label
+    set-value
+    get-value
+    on-drop-file
+    pre-on-event
+    pre-on-char
+    on-size
+    on-set-focus
+    on-kill-focus)
+  (define-class canvas% window% #f
+    on-drop-file
+    pre-on-event
+    pre-on-char
+    on-size
+    on-set-focus
+    on-kill-focus
+    get-canvas-background
+    set-canvas-background
+    set-background-to-gray
+    on-scroll
+    set-scroll-page
+    set-scroll-range
+    set-scroll-pos
+    get-scroll-page
+    get-scroll-range
+    get-scroll-pos
+    scroll
+    warp-pointer
+    view-start
+    set-resize-corner
+    show-scrollbars
+    set-scrollbars
+    get-virtual-size
+    get-dc
+    on-char
+    on-event
+    on-paint)
+  (define-private-class dc% dc<%> object% #f
+    glyph-exists?
+    end-page
+    end-doc
+    start-page
+    start-doc
+    ok?
+    get-gl-context
+    get-size
+    get-text-foreground
+    get-text-background
+    get-pen
+    get-font
+    get-brush
+    get-text-mode
+    get-background
+    get-origin
+    get-scale
+    set-origin
+    set-scale
+    set-text-mode
+    try-color
+    draw-bitmap
+    draw-bitmap-section
+    get-char-width
+    get-char-height
+    get-text-extent
+    get-smoothing
+    set-smoothing
+    set-text-foreground
+    set-text-background
+    set-brush
+    set-pen
+    set-font
+    set-background
+    get-clipping-region
+    set-clipping-region
+    set-clipping-rect
+    draw-polygon
+    draw-lines
+    draw-path
+    draw-ellipse
+    draw-arc
+    draw-text
+    draw-spline
+    draw-rounded-rectangle
+    draw-rectangle
+    draw-point
+    draw-line
+    clear)
+  (define-function draw-tab)
+  (define-function draw-tab-base)
+  (define-class bitmap-dc% dc% ()
+    get-bitmap
+    set-bitmap
+    draw-bitmap-section-smooth
+    set-argb-pixels
+    get-argb-pixels
+    set-pixel
+    get-pixel)
+  (define-class post-script-dc% dc% ([interactive #t] [parent #f] [use-paper-bbox #f] [eps #t]))
+  (define-class printer-dc% dc% ([parent #f]))
+  (define-private-class gl-context% gl-context<%> object% #f
+    call-as-current
+    swap-buffers
+    ok?)
+  (define-class gl-config% object% #f
+    get-double-buffered
+    set-double-buffered
+    get-stereo
+    set-stereo
+    get-stencil-size
+    set-stencil-size
+    get-accum-size
+    set-accum-size
+    get-depth-size
+    set-depth-size
+    get-multisample-size
+    set-multisample-size)
+  (define-class event% object% ([time-stamp 0])
+    get-time-stamp
+    set-time-stamp)
+  (define-class control-event% event% (event-type [time-stamp 0])
+    get-event-type
+    set-event-type)
+  (define-class popup-event% control-event% #f
+    get-menu-id
+    set-menu-id)
+  (define-class scroll-event% event% ([event-type thumb] [direction vertical] [position 0] [time-stamp 0])
+    get-event-type
+    set-event-type
+    get-direction
+    set-direction
+    get-position
+    set-position)
+  (define-class key-event% event% ([key-code #\nul] [shift-down #f] [control-down #f] [meta-down #f] [alt-down #f] [x 0] [y 0] [time-stamp 0])
+    get-key-code
+    set-key-code
+    get-key-release-code
+    set-key-release-code
+    get-shift-down
+    set-shift-down
+    get-control-down
+    set-control-down
+    get-meta-down
+    set-meta-down
+    get-alt-down
+    set-alt-down
+    get-x
+    set-x
+    get-y
+    set-y)
+  (define-class mouse-event% event% (event-type [left-down #f] [middle-down #f] [right-down #f] [x 0] [y 0] [shift-down #f] [control-down #f] [meta-down #f] [alt-down #f] [time-stamp 0])
+    moving?
+    leaving?
+    entering?
+    dragging?
+    button-up?
+    button-down?
+    button-changed?
+    get-event-type
+    set-event-type
+    get-left-down
+    set-left-down
+    get-middle-down
+    set-middle-down
+    get-right-down
+    set-right-down
+    get-shift-down
+    set-shift-down
+    get-control-down
+    set-control-down
+    get-meta-down
+    set-meta-down
+    get-alt-down
+    set-alt-down
+    get-x
+    set-x
+    get-y
+    set-y)
+  (define-class frame% window% #f
+    on-drop-file
+    pre-on-event
+    pre-on-char
+    on-size
+    on-set-focus
+    on-kill-focus
+    on-toolbar-click
+    on-menu-click
+    on-menu-command
+    enforce-size
+    on-close
+    on-activate
+    designate-root-frame
+    system-menu
+    set-modified
+    create-status-line
+    maximize
+    status-line-exists?
+    iconized?
+    set-status-text
+    get-menu-bar
+    set-menu-bar
+    set-icon
+    iconize
+    set-title)
+  (define-class gauge% item% #f
+    get-value
+    set-value
+    get-range
+    set-range
+    on-drop-file
+    pre-on-event
+    pre-on-char
+    on-size
+    on-set-focus
+    on-kill-focus)
+  (define-class font% object% #f
+    screen-glyph-exists?
+    get-font-id
+    get-size-in-pixels
+    get-underlined
+    get-smoothing
+    get-weight
+    get-point-size
+    get-style
+    get-face
+    get-family)
+  (define-class font-list% object% #f
+    find-or-create-font)
+  (define-class color% object% #f
+    blue
+    green
+    red
+    set
+    ok?
+    copy-from)
+  (define-private-class color-database% color-database<%> object% #f
+    find-color)
+  (define-class point% object% #f
+    get-x
+    set-x
+    get-y
+    set-y)
+  (define-class brush% object% #f
+    set-style
+    get-style
+    set-stipple
+    get-stipple
+    set-color
+    get-color)
+  (define-class brush-list% object% #f
+    find-or-create-brush)
+  (define-class pen% object% #f
+    set-style
+    get-style
+    set-stipple
+    get-stipple
+    set-color
+    get-color
+    set-join
+    get-join
+    set-cap
+    get-cap
+    set-width
+    get-width)
+  (define-class pen-list% object% #f
+    find-or-create-pen)
+  (define-class cursor% object% #f
+    ok?)
+  (define-class region% object% (dc)
+    in-region?
+    is-empty?
+    get-bounding-box
+    xor
+    subtract
+    intersect
+    union
+    set-path
+    set-arc
+    set-polygon
+    set-ellipse
+    set-rounded-rectangle
+    set-rectangle
+    get-dc)
+  (define-class dc-path% object% #f
+    get-bounding-box
+    append
+    reverse
+    rotate
+    scale
+    translate
+    lines
+    ellipse
+    rounded-rectangle
+    rectangle
+    curve-to
+    arc
+    line-to
+    move-to
+    open?
+    close
+    reset)
+  (define-private-class font-name-directory% font-name-directory<%> object% #f
+    find-family-default-font-id
+    find-or-create-font-id
+    get-family
+    get-face-name
+    get-font-id
+    set-post-script-name
+    set-screen-name
+    get-post-script-name
+    get-screen-name)
+  (define-function get-control-font-size)
+  (define-function get-the-font-name-directory)
+  (define-function get-the-font-list)
+  (define-function get-the-pen-list)
+  (define-function get-the-brush-list)
+  (define-function get-the-color-database)
+  (define-function cancel-quit)
+  (define-function fill-private-color)
+  (define-function flush-display)
+  (define-function yield)
+  (define-function write-resource)
+  (define-function get-resource)
+  (define-function label->plain-label)
+  (define-function display-origin)
+  (define-function display-size)
+  (define-function bell)
+  (define-function hide-cursor)
+  (define-function end-busy-cursor)
+  (define-function is-busy?)
+  (define-function begin-busy-cursor)
+  (define-function get-display-depth)
+  (define-function is-color-display?)
+  (define-function file-selector)
+  (define-class list-box% item% #f
+    get-label-font
+    set-string
+    set-first-visible-item
+    set
+    get-selections
+    get-first-item
+    number-of-visible-items
+    number
+    get-selection
+    set-data
+    get-data
+    selected?
+    set-selection
+    select
+    delete
+    clear
+    append
+    on-drop-file
+    pre-on-event
+    pre-on-char
+    on-size
+    on-set-focus
+    on-kill-focus)
+  (define-class editor-canvas% canvas% #f
+    on-char
+    on-event
+    on-paint
+    on-drop-file
+    pre-on-event
+    pre-on-char
+    on-size
+    on-set-focus
+    on-kill-focus
+    popup-for-editor
+    call-as-primary-owner
+    get-canvas-background
+    set-canvas-background
+    set-y-margin
+    set-x-margin
+    get-y-margin
+    get-x-margin
+    scroll-to
+    set-lazy-refresh
+    get-lazy-refresh
+    scroll-with-bottom-base
+    allow-scroll-to-last
+    force-display-focus
+    is-focus-on?
+    on-scroll-on-change
+    get-editor
+    set-editor
+    get-wheel-step
+    set-wheel-step)
+  (define-class editor-admin% object% #f
+    modified
+    refresh-delayed?
+    popup-menu
+    update-cursor
+    needs-update
+    resized
+    grab-caret
+    scroll-to
+    get-max-view
+    get-view
+    get-dc)
+  (define-private-class editor-snip-editor-admin% editor-snip-editor-admin<%> editor-admin% #f
+    get-snip)
+  (define-class snip-admin% object% #f
+    modified
+    popup-menu
+    update-cursor
+    release-snip
+    needs-update
+    recounted
+    resized
+    set-caret-owner
+    scroll-to
+    get-view
+    get-view-size
+    get-dc
+    get-editor)
+  (define-class snip-class% object% #f
+    reading-version
+    write-header
+    read-header
+    read
+    get-classname
+    set-classname
+    get-version
+    set-version)
+  (define-private-class snip-class-list% snip-class-list<%> object% #f
+    nth
+    number
+    add
+    find-position
+    find)
+  (define-class keymap% object% #f
+    remove-chained-keymap
+    chain-to-keymap
+    set-break-sequence-callback
+    call-function
+    remove-grab-mouse-function
+    set-grab-mouse-function
+    remove-grab-key-function
+    set-grab-key-function
+    add-function
+    map-function
+    break-sequence
+    handle-mouse-event
+    handle-key-event
+    set-double-click-interval
+    get-double-click-interval)
+  (define-class editor-wordbreak-map% object% #f
+    get-map
+    set-map)
+  (define-function get-the-editor-wordbreak-map)
+  (define-class text% editor% #f
+    call-clickback
+    remove-clickback
+    set-clickback
+    set-wordbreak-func
+    set-autowrap-bitmap
+    on-new-tab-snip
+    on-new-string-snip
+    caret-hidden?
+    hide-caret
+    get-wordbreak-map
+    set-wordbreak-map
+    find-wordbreak
+    set-region-data
+    get-region-data
+    get-revision-number
+    after-merge-snips
+    after-split-snip
+    after-set-size-constraint
+    on-set-size-constraint
+    can-set-size-constraint?
+    after-set-position
+    after-change-style
+    on-change-style
+    can-change-style?
+    after-delete
+    on-delete
+    can-delete?
+    after-insert
+    on-insert
+    can-insert?
+    set-tabs
+    get-tabs
+    set-overwrite-mode
+    get-overwrite-mode
+    set-file-format
+    get-file-format
+    write-to-file
+    read-from-file
+    get-character
+    get-text
+    find-next-non-string-snip
+    get-snip-position
+    get-snip-position-and-location
+    find-snip
+    find-string-all
+    find-string
+    set-styles-sticky
+    get-styles-sticky
+    set-line-spacing
+    get-line-spacing
+    set-paragraph-alignment
+    set-paragraph-margins
+    last-paragraph
+    paragraph-end-line
+    paragraph-start-line
+    line-paragraph
+    paragraph-end-position
+    paragraph-start-position
+    position-paragraph
+    last-line
+    last-position
+    line-length
+    line-end-position
+    line-start-position
+    line-location
+    position-location
+    position-line
+    set-between-threshold
+    get-between-threshold
+    find-position-in-line
+    find-line
+    find-position
+    split-snip
+    change-style
+    do-paste-x-selection
+    do-paste
+    do-copy
+    kill
+    paste-next
+    paste-x-selection
+    paste
+    copy
+    cut
+    erase
+    delete
+    insert
+    get-top-line-base
+    flash-off
+    flash-on
+    get-anchor
+    set-anchor
+    get-visible-line-range
+    get-visible-position-range
+    scroll-to-position
+    move-position
+    set-position-bias-scroll
+    set-position
+    get-end-position
+    get-start-position
+    get-position
+    get-flattened-text
+    put-file
+    get-file
+    after-edit-sequence
+    on-edit-sequence
+    after-load-file
+    on-load-file
+    can-load-file?
+    after-save-file
+    on-save-file
+    can-save-file?
+    on-new-box
+    on-new-image-snip
+    invalidate-bitmap-cache
+    on-paint
+    write-footers-to-file
+    write-headers-to-file
+    read-footer-from-file
+    read-header-from-file
+    set-filename
+    release-snip
+    on-snip-modified
+    set-modified
+    set-snip-data
+    get-snip-data
+    needs-update
+    resized
+    set-caret-owner
+    scroll-to
+    on-display-size-when-ready
+    on-display-size
+    on-change
+    on-focus
+    on-default-char
+    on-default-event
+    on-local-char
+    on-local-event
+    find-first-snip
+    get-space
+    get-descent
+    get-extent
+    blink-caret
+    own-caret
+    refresh
+    adjust-cursor
+    on-char
+    on-event
+    copy-self-to
+    copy-self)
+  (define-class menu% object% #f
+    select
+    get-font
+    set-width
+    set-title
+    set-label
+    set-help-string
+    number
+    enable
+    check
+    checked?
+    append-separator
+    delete-by-position
+    delete
+    append)
+  (define-class menu-bar% object% #f
+    set-label-top
+    number
+    enable-top
+    delete
+    append)
+  (define-class menu-item% object% #f
+    id)
+  (define-function id-to-menu-item)
+  (define-class editor-stream-in-base% object% #f
+    read
+    bad?
+    skip
+    seek
+    tell)
+  (define-class editor-stream-out-base% object% #f
+    write
+    bad?
+    seek
+    tell)
+  (define-class editor-stream-in-bytes-base% editor-stream-in-base% #f)
+  (define-class editor-stream-out-bytes-base% editor-stream-out-base% #f
+    get-bytes)
+  (define-class editor-stream-in% object% #f
+    ok?
+    jump-to
+    tell
+    skip
+    remove-boundary
+    set-boundary
+    get-inexact
+    get-exact
+    get-fixed
+    get-unterminated-bytes
+    get-bytes
+    get)
+  (define-class editor-stream-out% object% #f
+    ok?
+    jump-to
+    tell
+    put-fixed
+    put)
+  (define-class timer% object% ()
+    stop
+    start
+    notify
+    interval)
+  (define-private-class clipboard% clipboard<%> object% #f
+    get-clipboard-bitmap
+    set-clipboard-bitmap
+    get-clipboard-data
+    get-clipboard-string
+    set-clipboard-string
+    set-clipboard-client)
+  (define-function get-the-x-selection)
+  (define-function get-the-clipboard)
+  (define-class clipboard-client% object% ()
+    get-types
+    add-type
+    get-data
+    on-replaced)
+  (define-class ps-setup% object% ()
+    copy-from
+    set-margin
+    set-editor-margin
+    set-level-2
+    set-paper-name
+    set-translation
+    set-scaling
+    set-orientation
+    set-mode
+    set-preview-command
+    set-file
+    set-command
+    get-margin
+    get-editor-margin
+    get-level-2
+    get-paper-name
+    get-translation
+    get-scaling
+    get-orientation
+    get-mode
+    get-preview-command
+    get-file
+    get-command)
+  (define-function show-print-setup)
+  (define-function can-show-print-setup?)
+  (define-class pasteboard% editor% #f
+    set-scroll-step
+    get-scroll-step
+    set-selection-visible
+    get-selection-visible
+    set-dragable
+    get-dragable
+    after-interactive-resize
+    on-interactive-resize
+    can-interactive-resize?
+    after-interactive-move
+    on-interactive-move
+    can-interactive-move?
+    interactive-adjust-resize
+    interactive-adjust-move
+    interactive-adjust-mouse
+    on-double-click
+    after-select
+    on-select
+    can-select?
+    after-reorder
+    on-reorder
+    can-reorder?
+    after-resize
+    on-resize
+    can-resize?
+    after-move-to
+    on-move-to
+    can-move-to?
+    after-delete
+    on-delete
+    can-delete?
+    after-insert
+    on-insert
+    can-insert?
+    find-next-selected-snip
+    is-selected?
+    find-snip
+    get-center
+    remove-selected
+    no-selected
+    add-selected
+    set-selected
+    change-style
+    set-after
+    set-before
+    lower
+    raise
+    resize
+    move
+    move-to
+    remove
+    erase
+    do-paste-x-selection
+    do-paste
+    do-copy
+    delete
+    insert
+    get-flattened-text
+    put-file
+    get-file
+    after-edit-sequence
+    on-edit-sequence
+    after-load-file
+    on-load-file
+    can-load-file?
+    after-save-file
+    on-save-file
+    can-save-file?
+    on-new-box
+    on-new-image-snip
+    invalidate-bitmap-cache
+    on-paint
+    write-footers-to-file
+    write-headers-to-file
+    read-footer-from-file
+    read-header-from-file
+    write-to-file
+    read-from-file
+    set-filename
+    release-snip
+    on-snip-modified
+    set-modified
+    set-snip-data
+    get-snip-data
+    needs-update
+    resized
+    set-caret-owner
+    scroll-to
+    on-display-size-when-ready
+    on-display-size
+    on-change
+    on-focus
+    on-default-char
+    on-default-event
+    on-local-char
+    on-local-event
+    find-first-snip
+    get-space
+    get-descent
+    get-extent
+    blink-caret
+    own-caret
+    refresh
+    adjust-cursor
+    on-char
+    on-event
+    copy-self-to
+    copy-self
+    kill
+    paste-x-selection
+    paste
+    copy
+    cut)
+  (define-class panel% window% #f
+    get-label-position
+    set-label-position
+    on-char
+    on-event
+    on-paint
+    on-drop-file
+    pre-on-event
+    pre-on-char
+    on-size
+    on-set-focus
+    on-kill-focus
+    set-item-cursor
+    get-item-cursor)
+  (define-class dialog% window% #f
+    system-menu
+    set-title
+    on-drop-file
+    pre-on-event
+    pre-on-char
+    on-size
+    on-set-focus
+    on-kill-focus
+    enforce-size
+    on-close
+    on-activate)
+  (define-class radio-box% item% #f
+    button-focus
+    enable
+    set-selection
+    number
+    get-selection
+    on-drop-file
+    pre-on-event
+    pre-on-char
+    on-size
+    on-set-focus
+    on-kill-focus)
+  (define-class slider% item% #f
+    set-value
+    get-value
+    on-drop-file
+    pre-on-event
+    pre-on-char
+    on-size
+    on-set-focus
+    on-kill-focus)
+  (define-class snip% object% #f
+    previous
+    next
+    set-unmodified
+    get-scroll-step-offset
+    find-scroll-step
+    get-num-scroll-steps
+    set-admin
+    resize
+    write
+    match?
+    can-do-edit-operation?
+    do-edit-operation
+    blink-caret
+    own-caret
+    adjust-cursor
+    on-char
+    on-event
+    size-cache-invalid
+    copy
+    get-text!
+    get-text
+    merge-with
+    split
+    draw
+    partial-offset
+    get-extent
+    release-from-owner
+    is-owned?
+    set-style
+    set-flags
+    set-count
+    get-admin
+    get-count
+    get-flags
+    get-style
+    get-snipclass
+    set-snipclass)
+  (define-class string-snip% snip% #f
+    read
+    insert
+    set-unmodified
+    get-scroll-step-offset
+    find-scroll-step
+    get-num-scroll-steps
+    set-admin
+    resize
+    write
+    match?
+    can-do-edit-operation?
+    do-edit-operation
+    blink-caret
+    own-caret
+    adjust-cursor
+    on-char
+    on-event
+    size-cache-invalid
+    copy
+    get-text!
+    get-text
+    merge-with
+    split
+    draw
+    partial-offset
+    get-extent)
+  (define-class tab-snip% string-snip% #f
+    set-unmodified
+    get-scroll-step-offset
+    find-scroll-step
+    get-num-scroll-steps
+    set-admin
+    resize
+    write
+    match?
+    can-do-edit-operation?
+    do-edit-operation
+    blink-caret
+    own-caret
+    adjust-cursor
+    on-char
+    on-event
+    size-cache-invalid
+    copy
+    get-text!
+    get-text
+    merge-with
+    split
+    draw
+    partial-offset
+    get-extent)
+  (define-class image-snip% snip% #f
+    set-offset
+    get-bitmap-mask
+    get-bitmap
+    set-bitmap
+    get-filetype
+    get-filename
+    load-file
+    set-unmodified
+    get-scroll-step-offset
+    find-scroll-step
+    get-num-scroll-steps
+    set-admin
+    resize
+    write
+    match?
+    can-do-edit-operation?
+    do-edit-operation
+    blink-caret
+    own-caret
+    adjust-cursor
+    on-char
+    on-event
+    size-cache-invalid
+    copy
+    get-text!
+    get-text
+    merge-with
+    split
+    draw
+    partial-offset
+    get-extent)
+  (define-class editor-snip% snip% #f
+    get-inset
+    set-inset
+    get-margin
+    set-margin
+    border-visible?
+    show-border
+    set-align-top-line
+    get-align-top-line
+    set-tight-text-fit
+    get-tight-text-fit
+    get-min-height
+    get-min-width
+    set-min-height
+    set-min-width
+    get-max-height
+    get-max-width
+    set-max-height
+    set-max-width
+    set-unmodified
+    get-scroll-step-offset
+    find-scroll-step
+    get-num-scroll-steps
+    set-admin
+    resize
+    write
+    match?
+    can-do-edit-operation?
+    do-edit-operation
+    blink-caret
+    own-caret
+    adjust-cursor
+    on-char
+    on-event
+    size-cache-invalid
+    copy
+    get-text!
+    get-text
+    merge-with
+    split
+    draw
+    partial-offset
+    get-extent
+    set-editor
+    get-editor)
+  (define-class editor-data-class% object% #f
+    read
+    get-classname
+    set-classname)
+  (define-private-class editor-data-class-list% editor-data-class-list<%> object% #f
+    nth
+    number
+    add
+    find-position
+    find)
+  (define-class editor-data% object% #f
+    set-next
+    write
+    get-dataclass
+    set-dataclass
+    get-next)
+  (define-private-class mult-color% mult-color<%> object% #f
+    set
+    get
+    get-r
+    set-r
+    get-g
+    set-g
+    get-b
+    set-b)
+  (define-private-class add-color% add-color<%> object% #f
+    set
+    get
+    get-r
+    set-r
+    get-g
+    set-g
+    get-b
+    set-b)
+  (define-class style-delta% object% #f
+    copy
+    collapse
+    equal?
+    set-delta-foreground
+    set-delta-background
+    set-delta-face
+    set-delta
+    get-family
+    set-family
+    get-face
+    set-face
+    get-size-mult
+    set-size-mult
+    get-size-add
+    set-size-add
+    get-weight-on
+    set-weight-on
+    get-weight-off
+    set-weight-off
+    get-smoothing-on
+    set-smoothing-on
+    get-smoothing-off
+    set-smoothing-off
+    get-style-on
+    set-style-on
+    get-style-off
+    set-style-off
+    get-underlined-on
+    set-underlined-on
+    get-underlined-off
+    set-underlined-off
+    get-size-in-pixels-on
+    set-size-in-pixels-on
+    get-size-in-pixels-off
+    set-size-in-pixels-off
+    get-transparent-text-backing-on
+    set-transparent-text-backing-on
+    get-transparent-text-backing-off
+    set-transparent-text-backing-off
+    get-foreground-mult
+    get-background-mult
+    get-foreground-add
+    get-background-add
+    get-alignment-on
+    set-alignment-on
+    get-alignment-off
+    set-alignment-off)
+  (define-private-class style% style<%> object% #f
+    switch-to
+    set-shift-style
+    get-shift-style
+    is-join?
+    set-delta
+    get-delta
+    set-base-style
+    get-base-style
+    get-text-width
+    get-text-space
+    get-text-descent
+    get-text-height
+    get-transparent-text-backing
+    get-alignment
+    get-background
+    get-foreground
+    get-font
+    get-size-in-pixels
+    get-underlined
+    get-smoothing
+    get-style
+    get-weight
+    get-size
+    get-face
+    get-family
+    get-name)
+  (define-class style-list% object% #f
+    forget-notification
+    notify-on-change
+    style-to-index
+    index-to-style
+    convert
+    replace-named-style
+    new-named-style
+    find-named-style
+    find-or-create-join-style
+    find-or-create-style
+    number
+    basic-style)
+  (define-function get-the-style-list)
+  (define-class tab-group% item% #f
+    button-focus
+    set
+    set-label
+    delete
+    append
+    enable
+    set-selection
+    number
+    get-selection
+    on-drop-file
+    pre-on-event
+    pre-on-char
+    on-size
+    on-set-focus
+    on-kill-focus)
+  (define-class group-box% item% #f
+    on-drop-file
+    pre-on-event
+    pre-on-char
+    on-size
+    on-set-focus
+    on-kill-focus)
+
+  ;; Functions defined in wxscheme.cxx
+  (define-functions
+    special-control-key
+    special-option-key
+    application-file-handler
+    application-quit-handler
+    application-about-handler
+    application-pref-handler
+    get-color-from-user
+    get-font-from-user
+    get-face-list
+    get-panel-background
+    play-sound
+    make-eventspace
+    current-eventspace
+    event-dispatch-handler
+    eventspace?
+    current-ps-setup
+    queue-callback
+    middle-queue-key
+    check-for-break
+    find-graphical-system-path
+    get-top-level-windows
+    register-collecting-blit
+    unregister-collecting-blit
+    shortcut-visible-in-label?
+    eventspace-shutdown?
+    in-atomic-region
+    set-editor-snip-maker
+    set-text-editor-maker
+    set-pasteboard-editor-maker
+    set-menu-tester
+    location->window
+    set-dialogs
+    set-executer
+    send-event
+    file-creator-and-type
+    set-snip-class-getter
+    set-editor-data-class-getter
+    set-ps-procs
+    main-eventspace?
+    eventspace-handler-thread)
+
+)
+;; end
diff --git a/collects/mred/private/kw.ss b/collects/mred/private/kw.ss
new file mode 100644
index 0000000000..e0831d241d
--- /dev/null
+++ b/collects/mred/private/kw.ss
@@ -0,0 +1,65 @@
+(module kw mzscheme
+  (require (lib "class100.ss"))
+
+  (provide (protect define-keywords
+		    class100*/kw))
+
+  ;; ---------------- Keyword propagation macros -------------------
+
+  ;; Since we use class100 to construct the classes that users see,
+  ;; keywords are not propagated by position automatically. So we use
+  ;; the class100*/kw macro for every class exported to the user; it
+  ;; explicitly includes all keywords supported through superclasses.
+  ;; To avoid writing the same keyword sets over and over, we have
+  ;; a define-keywords form.
+
+  ;; Arguably, this is making a problem (using `class100' instead of
+  ;; `class') worse as much as it solves the problem. Or maybe the
+  ;; problem is trying to hard to make by-position and by-name
+  ;; initialization work.
+
+  (define-syntax (define-keywords stx)
+    (syntax-case stx ()
+      [(_ name kw ...)
+       (with-syntax ([(kw2 ...)
+		      (apply
+		       append
+		       (map (lambda (kw)
+			      (if (identifier? kw)
+				  (syntax-local-value kw)
+				  (list kw)))
+			    (syntax->list #'(kw ...))))])
+	 #'(define-syntax name '(kw2 ...)))]))
+
+  (define-syntax (class100*/kw stx)
+    (syntax-case stx ()
+      [(_ base (intf ...) ((base-init ...) keywords) . rest)
+       (let ([kws (syntax-local-value #'keywords)])
+	 (with-syntax ([super-init (datum->syntax-object 
+				    stx
+				    'super-init
+				    stx)]
+		       [(new-keyword ...) (map car kws)]
+		       [(new-init ...) (datum->syntax-object 
+					stx
+					kws)])
+	   #'(let-syntax ([super-init
+			   (lambda (sstx)
+			     (syntax-case sstx ()
+			       [(_ arg (... ...))
+				(with-syntax ([super-instantiate
+					       (datum->syntax-object 
+						sstx
+						'super-instantiate
+						sstx)]
+					      [(new-kw (... ...))
+					       (map (lambda (x)
+						      (datum->syntax-object 
+						       sstx
+						       x))
+						    '(new-keyword ...))])
+				  #'(super-instantiate (arg (... ...))
+						       [new-kw new-kw] (... ...)))]))])
+	       (class100*
+		   base (intf ...) (base-init ... new-init ...)
+		   . rest))))])))
diff --git a/collects/mred/private/lock.ss b/collects/mred/private/lock.ss
new file mode 100644
index 0000000000..e63d9aff5a
--- /dev/null
+++ b/collects/mred/private/lock.ss
@@ -0,0 +1,116 @@
+(module lock mzscheme
+  (require (prefix wx: "kernel.ss"))
+  (provide (protect as-entry
+		    as-exit
+		    entry-point
+		    mk-param))
+
+  ;; ;;;;;;;;;;;;; Thread Safety ;;;;;;;;;;;;;;;;;;;;
+  
+  ;; When the user creates an object or calls a method, or when the
+  ;; system invokes a callback, many steps may be required to initialize
+  ;; or reset fields to maintain invariants. To ensure that other
+  ;; threads do not call methods during a time when invariants do not
+  ;; hold, we force all of the following code to be executed in a single
+  ;; threaded manner, and we temporarily disable breaks. This accompiled
+  ;; with a single monitor: all entry points into the code use
+  ;; `entry-point' or `as-entry', and all points with this code that
+  ;; call back out to user code uses `as-exit'.
+
+  ;; If an exception is raised within an `enter'ed area, control is
+  ;; moved back outside by the exception handler, and then the exception
+  ;; is re-raised. The user can't tell that the exception was caught an
+  ;; re-raised. But without the catch-and-reraise, the user's exception
+  ;; handler might try to use GUI elements from a different thread,
+  ;; leading to deadlock.
+
+  (define monitor-sema (make-semaphore 1))
+  (define monitor-owner #f)
+
+  ;; An exception may be constructed while we're entered:
+  (define entered-err-string-handler
+    (lambda (s n)
+      (as-exit
+       (lambda ()
+	 ((error-value->string-handler) s n)))))
+
+  (define old-paramz #f)
+  (define old-break-paramz #f)
+
+  (define (as-entry f)
+    (cond
+     [(eq? monitor-owner (current-thread))
+      (f)]
+     [else
+      ((let/ec k
+	 (dynamic-wind
+	     (lambda () 
+	       (wx:in-atomic-region monitor-sema)	     
+	       (set! monitor-owner (current-thread)))
+	     (lambda () 
+	       (set! old-paramz (current-parameterization))
+	       (set! old-break-paramz (current-break-parameterization))
+	       (parameterize ([error-value->string-handler entered-err-string-handler]
+			      [current-exception-handler
+			       (lambda (exn)
+				 ;; Get out of atomic region before letting
+				 ;;  an exception handler work
+				 (k (lambda () (raise exn))))])
+		 (parameterize-break #f
+		   (call-with-values 
+		       f 
+		     (lambda args (lambda () (apply values args)))))))
+	     (lambda ()
+	       (set! monitor-owner #f)
+	       (semaphore-post monitor-sema)
+	       (wx:in-atomic-region #f)))))]))
+
+					; entry-point macros in macros.ss
+
+  (define (as-exit f)
+    ;; (unless (eq? monitor-owner (current-thread)) (error 'monitor-exit "not in monitored area"))
+    (let ([paramz old-paramz]
+	  [break-paramz old-break-paramz])
+      (call-with-parameterization
+       paramz
+       (lambda ()
+	 (call-with-break-parameterization
+	  break-paramz
+	  (lambda ()
+	    (dynamic-wind
+		(lambda ()		
+		  (set! monitor-owner #f)	 
+		  (semaphore-post monitor-sema)
+		  (wx:in-atomic-region #f))
+		f
+		(lambda ()
+		  (set! old-paramz paramz)
+		  (set! old-break-paramz break-paramz)
+		  (wx:in-atomic-region monitor-sema)
+		  (set! monitor-owner (current-thread))))))))))
+
+  (define-syntax entry-point 
+    (lambda (stx)
+      (syntax-case stx (lambda case-lambda)
+	[(_ (lambda args body1 body ...))
+	 (syntax (lambda args (as-entry (lambda () body1 body ...))))]
+	[(_ (case-lambda [vars body1 body ...] ...))
+	 (syntax (case-lambda 
+		  [vars (as-entry (lambda () body1 body ...))]
+		  ...))])))
+
+  (define-syntax mk-param
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ val filter check force-redraw)
+	 (syntax
+	  (case-lambda
+	   [() val]
+	   [(v) (check v)
+	    (let ([v2 (filter v)])
+	      (unless (eq? v2 val)
+		(set! val v2)
+		(force-redraw)))]))]))))
+
+  
+  
diff --git a/collects/mred/private/messagebox.ss b/collects/mred/private/messagebox.ss
new file mode 100644
index 0000000000..903c83af52
--- /dev/null
+++ b/collects/mred/private/messagebox.ss
@@ -0,0 +1,273 @@
+(module messagebox mzscheme
+  (require (lib "class.ss")
+	   (lib "class100.ss")
+	   (lib "etc.ss")
+	   (prefix wx: "kernel.ss")
+	   "const.ss"
+	   "check.ss"
+	   "helper.ss"
+	   "editor.ss"
+	   "mrtop.ss"
+	   "mrcanvas.ss"
+	   "mrpopup.ss"
+	   "mrmenu.ss"
+	   "mritem.ss"
+	   "mrpanel.ss")
+
+  (provide message-box
+	   message-box/custom
+	   message+check-box
+	   message+check-box/custom)
+
+  (define do-message-box/custom
+    (lambda (who title message
+		 button1 button2 button3
+		 parent style close-result
+		 check? two-results? check-message)
+      (check-label-string who title)
+      (check-string/false who message)
+      (when check?
+	(check-label-string who check-message))
+      (check-label-string-or-bitmap/false who button1)
+      (check-label-string-or-bitmap/false who button2)
+      (check-label-string-or-bitmap/false who button3)
+      (check-top-level-parent/false who parent)
+      (check-style who 
+		   '(default=1 default=2 default=3 no-default) 
+		   (let ([l '(disallow-close number-order caution stop)])
+		     (if check?
+			 (cons 'checked l)
+			 l))
+		   style)
+
+      (let* ([strings (let loop ([s message])
+			(let ([m (regexp-match #rx"([^\n]*)[\n](.*)" s)])
+			  (if m
+			      (cons (cadr m) (loop (caddr m)))
+			      (list s))))]
+	     [single? (and (< (length strings) 10) 
+			   (andmap (lambda (s) (< (string-length s) 60)) strings))]
+	     [f (make-object (class100 dialog% ()
+			       (public
+				 [get-message
+				  (lambda () message)])
+			       (augment
+				[can-close? (lambda ()
+					      (if (memq 'disallow-close style)
+						  (begin
+						    (wx:bell)
+						    #f)
+						  #t))])
+			       (override
+				 [on-subwindow-event 
+				  (lambda (w e)
+				    (if (send e button-down?)
+					(if (is-a? w button%)
+					    #f
+					    (if (or (is-a? w message%)
+						    (and
+						     (is-a? w editor-canvas%)
+						     (let-values ([(w h) (send w get-client-size)])
+						       (< (send e get-x) w))))
+						(begin
+						  (send w popup-menu
+							(let ([m (make-object popup-menu%)])
+							  (make-object menu-item%
+								       "Copy Message"
+								       m
+								       (lambda (i e)
+									 (send (wx:get-the-clipboard)
+									       set-clipboard-string
+									       message
+									       (send e get-time-stamp))))
+							  m)
+							(send e get-x)
+							(send e get-y))
+						  #t)
+						#f))
+					#f))])
+			       (sequence
+				 (super-init title parent box-width))))]
+	     [result close-result]
+	     [icon-id (cond
+		       [(memq 'stop style) 'stop]
+		       [(memq 'caution style) 'caution]
+		       [else 'app])])
+	(let-values ([(msg-pnl btn-pnl extra-width btn-h-align msg-h-align msg-v-align)
+		      (case (system-type)
+			[(macosx) (let ([p (make-object horizontal-pane% f)])
+				    (send f min-width 300)
+				    (send p set-alignment 'center 'top)
+				    (let ([m (make-object message% icon-id p)])
+				      (send m horiz-margin 16)
+				      (send m vert-margin 16))
+				    (let* ([rhs-pnl (make-object vertical-pane% p)]
+					   [msg-pnl (make-object vertical-pane% rhs-pnl)]
+					   [btn-pnl (make-object vertical-pane% rhs-pnl)])
+				      (send msg-pnl vert-margin 16)
+				      (when single?
+					(send msg-pnl horiz-margin 8))
+				      (send btn-pnl vert-margin 8)
+				      (send msg-pnl min-height 64)
+				      (send btn-pnl stretchable-height #f)
+				      (values msg-pnl btn-pnl 96 'right 'left 'top)))]
+			[else (let ([p (instantiate horizontal-pane% (f) [alignment '(center top)])])
+				(make-object message% icon-id p)
+				(values (make-object vertical-pane% p) f 0 'center 'center 'center))])])
+	  (if single?
+	      (begin
+		(send msg-pnl set-alignment (if (= (length strings) 1) msg-h-align 'left) msg-v-align)
+		(for-each (lambda (s) (make-object message% (protect& s) msg-pnl)) strings)
+		(send f stretchable-width #f)
+		(send f stretchable-height #f))
+	      ;; Try without scrollbar, then add one if necessary:
+	      (let loop ([scroll? #f])
+		(let* ([e (make-object text%)]
+		       [c (make-object editor-canvas% msg-pnl e (if scroll?
+								    '(no-hscroll)
+								    '(no-hscroll no-vscroll transparent no-border)))])
+		  (send c min-width 400)
+		  (send c set-line-count 5)
+		  (send c allow-tab-exit #t)
+		  (send f reflow-container)
+		  (send e auto-wrap #t)
+		  (send e insert message)
+		  (send e set-position 0)
+		  (send e hide-caret #t)
+		  (send e set-cursor (make-object wx:cursor% 'arrow) #t)
+		  (send e lock #t)
+		  (when (not scroll?)
+		    ;; Check whether it actually fits
+		    (let ([vh (box 0)]
+			  [eh (box 0)])
+		      (send e get-view-size #f vh)
+		      (send e get-extent #f eh)
+		      (unless ((unbox eh) . <= . (unbox vh))
+			(send c show #f)
+			(send msg-pnl delete-child c)
+			(loop #t)))))))
+	  (let ([check (and check?
+			    (let ([p (new horizontal-pane% [parent btn-pnl]
+					  [stretchable-height #f]
+					  [alignment '(left center)])])
+			      (new check-box% 
+				   [label check-message]
+				   [parent p]
+				   [callback void]
+				   [value (memq 'checked style)])))])
+	    (let* ([p (make-object horizontal-pane% btn-pnl)]
+		   [mk-button (lambda (title v default?) 
+				(let ([b (make-object button% title p (lambda (b e) (set! result v) (send f show #f))
+						      (if default? '(border) null))])
+				  (when default? (send b focus))))])
+	      (send p set-alignment btn-h-align 'center)
+	      (send p stretchable-height #f)
+	      (send p stretchable-width #t) ; to get panel's centering
+	      (let ([mk-1 (lambda () 
+			    (when button1
+			      (mk-button button1 1 (memq 'default=1 style))))]
+		    [mk-2 (lambda ()
+			    (when button2
+			      (mk-button button2 2 (memq 'default=2 style))))]
+		    [mk-3 (lambda ()
+			    (when button3
+			      (mk-button button3 3 (memq 'default=3 style))))])
+		(cond 
+		 [(or (memq 'number-order style)
+		      (not (memq (system-type) '(macos macosx)))) 
+		  (mk-1)
+		  (mk-2)
+		  (mk-3)]
+		 [else
+		  (mk-3)
+		  (make-object horizontal-pane% p)
+		  (mk-2)
+		  (mk-1)])))
+	    (send f center)
+	    (send f show #t)
+	    (if two-results?
+		(values result (and check? (send check get-value)))
+		result))))))
+
+  (define message-box/custom
+    (opt-lambda (title message 
+		       button1
+		       button2
+		       button3
+		       [parent #f]
+		       [style '(no-default)]
+		       [close-result #f])
+      (do-message-box/custom 'message-box/custom
+			     title message button1 button2 button3
+			     parent style close-result
+			     #f #f #f)))
+
+  (define do-message-box
+    (opt-lambda (who title message parent style check? check-message)
+      (check-label-string who title)
+      (check-string/false who message)
+      (when check?
+	(check-label-string who check-message))
+      (check-top-level-parent/false who parent)
+      (check-style who
+		   '(ok ok-cancel yes-no) 
+		   (let ([l '(caution stop)])
+		     (if check?
+			 (cons 'checked l)
+			 l))
+		   style)
+
+      (let-values ([(one two one-v two-v close-val default)
+		    (cond
+		     [(memq 'ok style) 
+		      (values "OK" #f 'ok #f 1 'default=1)]
+		     [(memq 'ok-cancel style)
+		      (values "OK" "Cancel" 'ok 'cancel 2 'default=1)]
+		     [(memq 'yes-no style)
+		      (values "&Yes" "&No" 'yes 'no #f 'no-default)])])
+	(let-values ([(result checked?)
+		      (do-message-box/custom who
+					     title message
+					     one two #f
+					     parent
+					     (append
+					      (cond
+					       [(memq 'checked style) '(checked)]
+					       [else null])
+					      (cond
+					       [(memq 'stop style) '(stop)]
+					       [(memq 'caution style) '(caution)]
+					       [else null])
+					      (if close-val
+						  (list default)
+						  (list default 'disallow-close)))
+					     close-val
+					     check? #t check-message)])
+	  (let ([result (case result
+			  [(1) one-v]
+			  [(2) two-v])])
+	    (if check?
+		(values result checked?)
+		result))))))
+
+  (define message-box
+    (opt-lambda (title message [parent #f] [style '(ok)])
+      (do-message-box 'message-box title message parent style #f #f)))
+
+  (define message+check-box/custom
+    (opt-lambda (title message 
+		       checkbox-message
+		       button1
+		       button2
+		       button3
+		       [parent #f]
+		       [style '(no-default)]
+		       [close-result #f])
+      (do-message-box/custom 'message+check-box/custom
+			     title message button1 button2 button3
+			     parent style close-result
+			     #t #t checkbox-message)))
+
+  (define message+check-box
+    (opt-lambda (title message check-message [parent #f] [style '(ok)])
+      (do-message-box 'message-box title message parent style #t check-message))))
diff --git a/collects/mred/private/misc.ss b/collects/mred/private/misc.ss
new file mode 100644
index 0000000000..acc10480cb
--- /dev/null
+++ b/collects/mred/private/misc.ss
@@ -0,0 +1,100 @@
+(module misc mzscheme
+  (require (lib "class.ss")
+	   (lib "file.ss")
+	   (lib "process.ss")
+	   (prefix wx: "kernel.ss"))
+
+  (provide file-creator-and-type
+	   hide-cursor-until-moved
+	   sleep/yield
+	   play-sound
+	   timer%)
+
+  ;; Currently only used for PS print and preview
+  (wx:set-executer
+   (let ([orig-err (current-error-port)])
+     (lambda (prog . args)
+       (let ([cmd (string-append
+		   prog 
+		   (let loop ([args args])
+		     (if (null? args)
+			 ""
+			 (format " ~s~a" (car args) (loop (cdr args))))))])
+	 (let-values ([(in out pid err x) (apply values (process cmd))])
+	   (close-output-port out)
+	   (let ([echo (lambda (p)
+			 (thread (lambda ()
+				   (dynamic-wind
+				       void
+				       (lambda ()
+					 (let loop ()
+					   (let ([l (read-line p)])
+					     (unless (eof-object? l)
+					       (fprintf orig-err "~a~n" l)
+					       (loop)))))
+				       (lambda () (close-input-port p))))))])
+	     (echo in)
+	     (echo err)
+	     (void)))))))
+
+  (define (sleep/yield secs)
+    (unless (and (real? secs) (not (negative? secs)))
+      (raise-type-error 'sleep/yield "non-negative real number" secs))
+    (wx:yield (alarm-evt (+ (current-inexact-milliseconds)
+			    (* secs 1000))))
+    (void))
+
+  (define file-creator-and-type
+    (case-lambda
+     [(fn) (wx:file-creator-and-type fn)]
+     [(fn c t) (wx:file-creator-and-type fn c t)]))
+  
+  (define (hide-cursor-until-moved) 
+    (wx:hide-cursor))
+
+  (define (play-sound f async?)
+    (if (not (eq? (system-type) 'unix))
+	(wx:play-sound f async?)
+	(begin
+	  (unless (string? f)
+	    (raise-type-error 'play-sound "string" f))
+	  (let* ([subpath (system-library-subpath)]
+		 [make-pattern (lambda (s) (string-append ".*" s ".*"))]
+		 [b (box 
+		     (cond 
+		      [(regexp-match (make-pattern "linux") subpath)
+		       ;; use play interface to sox
+		       "play ~s"]
+		      [(regexp-match (make-pattern "solaris") subpath)
+		       "audioplay ~s"]
+		      [else
+		       (raise-mismatch-error
+			'play-sound
+			"not supported by default on this platform"
+			subpath)]))])
+					; see if user has overridden defaults 		  
+	    (let ([r (get-preference '|MrEd:playcmd| (lambda () #f))])
+	      (when (and r (string? r))
+		(set-box! b r)))
+	    ((if async? (lambda (x) (process x) #t) system)
+	     (format (unbox b) (expand-path f)))))))
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; Timers:
+
+  (define timer%
+    (class wx:timer%
+      (init [notify-callback void]
+	    [interval #f]
+	    [just-once? #f])
+      
+      (inherit start)
+      
+      (define -notify-callback notify-callback)
+      
+      (define/override (notify) (-notify-callback))
+      
+      (super-make-object)
+
+      (when interval
+	(start interval just-once?)))))
diff --git a/collects/mred/private/moredialogs.ss b/collects/mred/private/moredialogs.ss
new file mode 100644
index 0000000000..46e6589236
--- /dev/null
+++ b/collects/mred/private/moredialogs.ss
@@ -0,0 +1,294 @@
+(module moredialogs mzscheme
+  (require (lib "class.ss")
+	   (lib "class100.ss")
+	   (lib "etc.ss")
+	   (lib "list.ss")
+	   (prefix wx: "kernel.ss")
+	   "lock.ss"
+	   "const.ss"
+	   "check.ss"
+	   "wx.ss"
+	   "helper.ss"
+	   "editor.ss"
+	   "mrtop.ss"
+	   "mrcanvas.ss"
+	   "mrpopup.ss"
+	   "mrmenu.ss"
+	   "mritem.ss"
+	   "mrpanel.ss"
+	   "mrtextfield.ss")
+
+  (provide get-ps-setup-from-user
+	   get-page-setup-from-user
+	   can-get-page-setup-from-user?
+	   get-text-from-user
+	   get-choices-from-user
+	   get-color-from-user)
+
+  (define (number->string* n)
+    (let ([s (number->string n)])
+      (regexp-replace #rx"[.]([0-9][0-9][0-9])[0-9]*$"
+		      s
+		      ".\\1")))
+
+  (define get-ps-setup-from-user
+    (case-lambda
+     [() (get-ps-setup-from-user #f #f #f null)]
+     [(message) (get-ps-setup-from-user message #f #f null)]
+     [(message parent) (get-ps-setup-from-user message parent #f null)]
+     [(message parent pss) (get-ps-setup-from-user message parent pss null)]
+     [(message parent pss-in style)
+      (define _
+	(begin
+	  ;; Calls from C++ have wrong kind of window:
+	  (when (is-a? parent wx:window%)
+	    (set! parent (as-entry (lambda () (wx->mred parent)))))
+
+	  (check-label-string/false 'get-ps-setup-from-user message)
+	  (check-top-level-parent/false 'get-ps-setup-from-user parent)
+	  (check-instance 'get-ps-setup-from-user wx:ps-setup% 'ps-setup% #t pss-in)
+	  (check-style 'get-ps-setup-from-user #f null style)))
+      
+      (define pss (or pss-in (wx:current-ps-setup)))
+      (define f (make-object dialog% "PostScript Setup" parent))
+      (define papers 
+	'("A4 210 x 297 mm" "A3 297 x 420 mm" "Letter 8 1/2 x 11 in" "Legal 8 1/2 x 14 in"))
+      (define p (make-object horizontal-pane% f))
+      (define paper (make-object choice% #f papers p void))
+      (define _0 (make-object vertical-pane% p))
+      (define cancel (make-object button% "Cancel" p (lambda (b e) (done #f))))
+      (define ok (make-object button% "OK" p (lambda (b e) (done #t)) '(border)))
+      (define unix? (eq? (system-type) 'unix))
+      (define dp (make-object horizontal-pane% f))
+      (define orientation (make-object radio-box% "Orientation:" '("Portrait" "Landscape") dp void))
+      (define destination (and unix? (make-object radio-box% "Destination:" 
+						  '("Printer" "Preview" "File") dp void)))
+      (define ssp (make-object horizontal-pane% f))
+      (define sp (make-object vertical-pane% ssp))
+      (define def-scale "0100.000")
+      (define def-offset "0000.000")
+      (define xscale (make-object text-field% "Horizontal Scale:" sp void def-scale))
+      (define xoffset (make-object text-field% "Horizontal Translation:" sp void def-offset))
+      (define sp2 (make-object vertical-pane% ssp))
+      (define yscale (make-object text-field% "Vertical Scale:" sp2 void def-scale))
+      (define yoffset (make-object text-field% "Vertical Translation:" sp2 void def-offset))
+
+      (define l2 (make-object check-box% "PostScript Level 2" f void))
+
+      (define cp (and unix? (make-object horizontal-pane% f)))
+      (define command (and unix? (make-object text-field% "Print Command:" cp void)))
+      (define vcommand (and unix? (make-object text-field% "Preview Command:" f void)))
+
+      (define ok? #f)
+      (define (done ?)
+	(send f show #f)
+	(set! ok? ?))
+
+      (define-values (xsb ysb xtb ytb) (values (box 0) (box 0) (box 0) (box 0)))
+
+      (send paper set-selection (or (find-pos papers (send pss get-paper-name) equal?) 0))
+      (send orientation set-selection (if (eq? (send pss get-orientation) 'landscape) 1 0))
+      (when unix?
+	(send destination set-selection (case (send pss get-mode)
+					  [(printer) 0] [(preview) 1] [(file) 2]))
+	(send command set-value (send pss get-command))
+	(send vcommand set-value (send pss get-preview-command)))
+
+      (send sp set-alignment 'right 'top)
+      (send sp2 set-alignment 'right 'top)
+      (send pss get-scaling xsb ysb)
+      (send xscale set-value (number->string* (unbox xsb)))
+      (send yscale set-value (number->string* (unbox ysb)))
+      (send pss get-translation xtb ytb)
+      (send xoffset set-value (number->string* (unbox xtb)))
+      (send yoffset set-value (number->string* (unbox ytb)))
+      (send xscale stretchable-width #f)
+      (send yscale stretchable-width #f)
+      (send xoffset stretchable-width #f)
+      (send yoffset stretchable-width #f)
+
+      (send l2 set-value (send pss get-level-2))
+
+      (send f set-alignment 'center 'top)
+
+      (map no-stretch (list f xscale yscale xoffset yoffset dp))
+
+      (send f center)
+
+      (send f show #t)
+
+      (if ok?
+	  (let ([s (make-object wx:ps-setup%)]
+		[gv (lambda (c b)
+		      (or (string->number (send c get-value)) (unbox b)))])
+	    (send s set-paper-name (send paper get-string-selection))
+	    (send s set-orientation (if (positive? (send orientation get-selection))
+					'landscape
+					'portrait))
+	    (when unix?
+	      (send s set-mode (case (send destination get-selection)
+				 [(0) 'printer]
+				 [(1) 'preview]
+				 [(2) 'file])))
+	    (send s set-scaling (gv xscale xsb) (gv yscale ysb))
+	    (send s set-translation (gv xoffset xtb) (gv yoffset ytb))
+	    (send s set-level-2 (send l2 get-value))
+	    
+	    (when (eq? (system-type) 'unix)
+	      (send s set-command (send command get-value))
+	      (send s set-preview-command (send vcommand get-value)))
+
+	    s)
+	  #f)]))
+
+  (define get-page-setup-from-user
+    (case-lambda
+     [() (get-page-setup-from-user #f #f #f null)]
+     [(message) (get-page-setup-from-user message #f #f null)]
+     [(message parent) (get-page-setup-from-user message parent #f null)]
+     [(message parent pss) (get-page-setup-from-user message parent pss null)]
+     [(message parent pss-in style)
+      (check-label-string/false 'get-page-setup-from-user message)
+      (check-top-level-parent/false 'get-page-setup-from-user parent)
+      (check-instance 'get-page-setup-from-user wx:ps-setup% 'ps-setup% #t pss-in)
+      (check-style 'get-page-setup-from-user #f null style)
+
+      (and (wx:can-show-print-setup?)
+	   (let ([s (make-object wx:ps-setup%)])
+	     (send s copy-from (or pss-in (wx:current-ps-setup)))
+	     (and (parameterize ([wx:current-ps-setup s])
+		    (wx:show-print-setup parent))
+		  s)))]))
+
+  (define (can-get-page-setup-from-user?)
+    (wx:can-show-print-setup?))
+
+  (define get-text-from-user
+    (case-lambda
+     [(title message) (get-text-from-user title message #f "" null)]
+     [(title message parent) (get-text-from-user title message parent "" null)]
+     [(title message parent init-val) (get-text-from-user title message parent init-val null)]
+     [(title message parent init-val style)
+      (check-label-string 'get-text-from-user title)
+      (check-label-string/false 'get-text-from-user message)
+      (check-top-level-parent/false 'get-text-from-user parent)
+      (check-string 'get-text-from-user init-val)
+      (check-style 'get-text-from-user #f '(password) style)
+      (let* ([f (make-object dialog% title parent box-width)]
+	     [ok? #f]
+	     [done (lambda (?) (lambda (b e) (set! ok? ?) (send f show #f)))])
+	(let ([t (make-object text-field% message f (lambda (t e) (when (eq? (send e get-event-type) 'text-field-enter)
+								    ((done #t) #f #f)))
+			      init-val (list* 'single 'vertical-label style))]
+	      [p (make-object horizontal-pane% f)])
+	  (send p set-alignment 'right 'center)
+	  (send f stretchable-height #f)
+	  (make-object button% "Cancel" p (done #f))
+	  (make-object button% "OK" p (done #t) '(border))
+	  (send (send t get-editor) select-all)
+	  (send t focus)
+	  (send f center)
+	  (send f show #t)
+	  (and ok? (send t get-value))))]))
+
+  (define get-choices-from-user
+    (case-lambda
+     [(title message choices) (get-choices-from-user title message choices #f null '(single))]
+     [(title message choices parent) (get-choices-from-user title message choices parent null '(single))]
+     [(title message choices parent init-vals) (get-choices-from-user title message choices parent init-vals '(single))]
+     [(title message choices parent init-vals style)
+      (check-label-string 'get-choices-from-user title)
+      (check-label-string/false 'get-choices-from-user message)
+      (unless (and (list? choices) (andmap label-string? choices))
+	(raise-type-error 'get-choices-from-user "list of strings (up to 200 characters)" choices))
+      (check-top-level-parent/false 'get-choices-from-user parent)
+      (unless (and (list? init-vals) (andmap (lambda (x) (and (integer? x) (exact? x) (not (negative? x)))) init-vals))
+	(raise-type-error 'get-choices-from-user "list of exact non-negative integers" init-vals))
+      (check-style 'get-choices-from-user '(single multiple extended) null style)
+      (when (and (memq 'single style) (> (length init-vals) 1))
+	(raise-mismatch-error 'get-choices-from-user 
+			      (format "multiple initial-selection indices provided with ~e style: " 'single)
+			      init-vals))
+      (let* ([f (make-object dialog% title parent box-width (min 300 (max 150 (* 14 (length choices)))))]
+	     [ok-button #f]
+	     [update-ok (lambda (l) (send ok-button enable (not (null? (send l get-selections)))))]
+	     [ok? #f]
+	     [done (lambda (?) (lambda (b e) (set! ok? ?) (send f show #f)))])
+	(let ([l (make-object list-box% message choices f
+			      (lambda (l e)
+				(update-ok l)
+				(when (eq? (send e get-event-type) 'list-box-dclick)
+				  ((done #t) #f #f)))
+			      (cons 'vertical-label style))]
+	      [p (make-object horizontal-pane% f)])
+	  (for-each (lambda (i) 
+		      (when (>= i (send l get-number))
+			(raise-mismatch-error 
+			 'get-choices-from-user 
+			 (format "inital-selection list specifies an out-of-range index (~e choices provided): "
+				 (send l get-number))
+			 i))
+		      (send l select i #t)) init-vals)
+	  (send p set-alignment 'right 'center)
+	  (send p stretchable-height #f)
+	  (make-object button% "Cancel" p (done #f))
+	  (set! ok-button (make-object button% "OK" p (done #t) '(border)))
+	  (update-ok l)
+	  (send f center)
+	  (when (and (pair? init-vals)
+		     ((car init-vals) . > . 1))
+	    ;; Make sure initial selection is visible:
+	    (send f reflow-container)
+	    (send l set-first-visible-item (sub1 (car init-vals))))
+	  (send f show #t)
+	  (and ok? (send l get-selections))))]))
+
+  (define get-color-from-user 
+    (case-lambda
+     [() (get-color-from-user #f #f #f null)]
+     [(message) (get-color-from-user message #f #f null)]
+     [(message parent) (get-color-from-user message parent #f null)]
+     [(message parent color) (get-color-from-user message parent color null)]
+     [(message parent color style)
+      (check-label-string/false 'get-color-from-user message)
+      (check-top-level-parent/false 'get-color-from-user parent)
+      (check-instance 'get-color-from-user wx:color% 'color% #t color)
+      (check-style 'get-color-from-user #f null style)
+      (if (not (eq? (system-type) 'unix))
+	  (wx:get-color-from-user message (and parent (mred->wx parent)) color)
+	  (letrec ([ok? #f]
+		   [f (make-object dialog% "Choose Color" parent)]
+		   [done (lambda (ok) (lambda (b e) (set! ok? ok) (send f show #f)))]
+		   [canvas (make-object (class100 canvas% ()
+					  (override
+					    [on-paint (lambda () (repaint #f #f))])
+					  (sequence (super-init f))))]
+		   [p (make-object vertical-pane% f)]
+		   [repaint (lambda (s e)
+			      (let ([c (make-object wx:color% 
+						    (send red get-value)
+						    (send green get-value)
+						    (send blue get-value))])
+				(wx:fill-private-color (send canvas get-dc) c)))]
+		   [make-color-slider (lambda (l) (make-object slider% l 0 255 p repaint))]
+		   [red (make-color-slider "Red:")]
+		   [green (make-color-slider "Green:")]
+		   [blue (make-color-slider "Blue:")]
+		   [bp (make-object horizontal-pane% f)])
+	    (when color
+	      (send red set-value (send color red))
+	      (send green set-value (send color green))
+	      (send blue set-value (send color blue)))
+	    (make-object button% "Cancel" bp (done #f))
+	    (send (make-object button% "OK" bp (done #t) '(border)) focus)
+	    (send bp set-alignment 'right 'center)
+	    (send p set-alignment 'right 'center)
+	    (send p stretchable-height #f)
+	    (send canvas min-height 50)
+	    (send f center)
+	    (send f show #t)
+	    (and ok?
+		 (make-object wx:color% 
+			      (send red get-value)
+			      (send green get-value)
+			      (send blue get-value)))))])))
diff --git a/collects/mred/private/mrcanvas.ss b/collects/mred/private/mrcanvas.ss
new file mode 100644
index 0000000000..03fd9ea95e
--- /dev/null
+++ b/collects/mred/private/mrcanvas.ss
@@ -0,0 +1,352 @@
+(module mrcanvas mzscheme
+  (require (lib "class.ss")
+	   (lib "class100.ss")
+	   (lib "list.ss")
+	   (prefix wx: "kernel.ss")
+	   "lock.ss"
+	   "const.ss"
+	   "kw.ss"
+	   "helper.ss"
+	   "check.ss"
+	   "wx.ss"
+	   "wxcanvas.ss"
+	   "mrwindow.ss"
+	   "mrcontainer.ss"
+	   "mrtop.ss")
+
+  (provide canvas<%>
+	   canvas%
+	   editor-canvas%)
+
+  (define canvas-default-size 20) ; a default size for canvases tht fits borders without losing client sizes
+  (define canvas-scroll-size 10)
+  (define canvas-control-border-extra (case (system-type)
+					[(windows) 2]
+					[else 0]))
+
+  (define canvas<%>
+    (interface (subwindow<%>)
+      min-client-width min-client-height
+      on-char on-event on-paint on-scroll on-tab-in
+      warp-pointer get-dc
+      set-canvas-background get-canvas-background
+      set-resize-corner))
+
+  (define-keywords canvas%-keywords
+    window%-keywords
+    subarea%-keywords
+    area%-keywords)
+
+  (define basic-canvas%
+    (class100* (make-window% #f (make-subarea% area%)) (canvas<%>) (mk-wx mismatches parent)
+      (public
+	[on-char (lambda (e) (send wx do-on-char e))]
+	[on-event (lambda (e) (send wx do-on-event e))]
+	[on-paint (lambda () (when wx (send wx do-on-paint)))]
+	[on-scroll (lambda (e) (send wx do-on-scroll e))]
+	[on-tab-in (lambda () (void))]
+	
+	[min-client-width (param (lambda () wx) min-client-width)]
+	[min-client-height (param (lambda () wx) min-client-height)]
+
+	[warp-pointer (entry-point (lambda (x y) (send wx warp-pointer x y)))]
+
+	[get-dc (entry-point (lambda () (send wx get-dc)))]
+
+	[set-canvas-background
+	 (entry-point
+	  (lambda (c)
+	    (unless (c . is-a? . wx:color%)
+	      (raise-type-error (who->name '(method canvas<%> set-canvas-background))
+				"color% object"
+				c))
+	    (unless (send wx get-canvas-background)
+	      (raise-mismatch-error (who->name '(method canvas<%> set-canvas-background))
+				    "cannot set a transparent canvas's background color: "
+				    c))
+	    (send wx set-canvas-background c)))]
+	[get-canvas-background
+	 (entry-point
+	  (lambda ()
+	    (send wx get-canvas-background)))]
+
+	[set-resize-corner (lambda (on?)
+			     (send wx set-resize-corner on?))])
+      (private-field
+       [wx #f])
+      (sequence
+	(as-entry
+	 (lambda ()
+	   (super-init (lambda () (set! wx (mk-wx)) wx) (lambda () wx) mismatches #f parent #f))))))
+
+  (define default-paint-cb (lambda (canvas dc) (void)))
+
+  (define canvas%
+    (class100*/kw basic-canvas% ()
+		  [(parent [style null] [paint-callback default-paint-cb] [label #f] [gl-config #f])
+		   canvas%-keywords]
+      (private-field [paint-cb paint-callback]
+		     [has-x? (memq 'hscroll style)]
+		     [has-y? (memq 'vscroll style)])
+      (inherit get-client-size get-dc set-label)
+      (rename [super-on-paint on-paint])
+      (sequence 
+	(let ([cwho '(constructor canvas)])
+	  (check-container-parent cwho parent)
+	  (check-style cwho #f '(border hscroll vscroll gl deleted control-border combo no-autoclear transparent resize-corner) 
+		       style)
+	  (check-callback cwho paint-callback)
+	  (check-label-string/false cwho label)))
+      (public
+	[swap-gl-buffers (lambda () (send (send (send wx get-dc) get-gl-context) swap-buffers))]
+	[with-gl-context (lambda (thunk) 
+			   (send (send (send wx get-dc) get-gl-context) call-as-current thunk))]
+	[accept-tab-focus (entry-point
+			   (case-lambda
+			    [() (send wx get-tab-focus)]
+			    [(on?) (send wx set-tab-focus (and on? #t))]))]
+	[get-virtual-size (entry-point
+			   (lambda () (double-boxed
+				       0 0
+				       (lambda (x y) (send wx get-virtual-size x y)))))]
+	[get-view-start (entry-point
+			 (lambda () (double-boxed
+				     0 0
+				     (lambda (x y) (send wx view-start x y)))))]
+
+	[scroll (entry-point (lambda (x y) 
+			       (when x (check-fraction '(method canvas% scroll) x))
+			       (when y (check-fraction '(method canvas% scroll) y))
+			       (send wx scroll (or x -1) (or y -1))))]
+
+	[init-auto-scrollbars
+	 (lambda (w h x y)
+	   (when w (check-gauge-integer '(method canvas% init-auto-scrollbars) w))
+	   (when h (check-gauge-integer '(method canvas% init-auto-scrollbars) h))
+	   (check-fraction '(method canvas% init-auto-scrollbars) x)
+	   (check-fraction '(method canvas% init-auto-scrollbars) y)
+	   (let-values ([(cw ch) (get-client-size)])
+	     (send wx set-scrollbars (if w 1 0) (if h 1 0)
+		   (or w 0) (or h 0) 1 1
+		   (if w (inexact->exact (floor (* x (max 0 (- w cw))))) 0)
+		   (if h (inexact->exact (floor (* y (max 0 (- h ch))))) 0)
+		   #t)))]
+	
+	[init-manual-scrollbars 
+	 (lambda (x-len y-len x-page y-page x-val y-val)
+	   (let ([who '(method canvas% init-auto-scrollbars)])
+	     (when x-len (check-range-integer who x-len))
+	     (when y-len (check-range-integer who y-len))
+	     (check-gauge-integer who x-page)
+	     (check-gauge-integer who y-page)
+	     (check-range-integer who x-val)
+	     (check-range-integer who y-val)
+	     (when (and x-len (< x-len x-val))
+	       (raise-mismatch-error (who->name who)
+				     (format "horizontal value: ~e larger than the horizontal range: "
+					     x-val)
+				     x-len))
+	     (when (and y-len (< y-len y-val))
+	       (raise-mismatch-error (who->name who)
+				     (format "vertical value: ~e larger than the vertical range: "
+					     y-val)
+				     y-len)))
+	   (send wx set-scrollbars (if x-len 1 0) (if y-len 1 0)
+		 (or x-len 0) (or y-len 0) x-page y-page x-val y-val #f))]
+
+	[show-scrollbars
+	 (lambda (x-on? y-on?)
+	   (let ([bad (lambda (which what)
+			(raise-mismatch-error 
+			 (who->name '(method canvas% show-scrollbars))
+			 (format
+			  "cannot show ~a scrollbars, because the canvas style did not include ~a: "
+			  which
+			  what)
+			 this))])
+	     (when x-on? (unless has-x? (bad "horizontal" 'hscroll)))
+	     (when y-on? (unless has-y? (bad "vertical" 'vscroll)))
+	     (send wx show-scrollbars x-on? y-on?)))]
+
+	[get-scroll-pos (entry-point (lambda (d) (send wx get-scroll-pos d)))]
+	[set-scroll-pos (entry-point (lambda (d v) (send wx set-scroll-pos d v)))]
+	[get-scroll-range (entry-point (lambda (d) (send wx get-scroll-range d)))]
+	[set-scroll-range (entry-point (lambda (d v) (send wx set-scroll-range d v)))]
+	[get-scroll-page (entry-point (lambda (d) (send wx get-scroll-page d)))]
+	[set-scroll-page (entry-point (lambda (d v) (send wx set-scroll-page d v)))])
+      (override
+	[on-paint (lambda () 
+		    (if (eq? paint-cb default-paint-cb)
+			(super-on-paint)
+			(paint-cb this (get-dc))))])
+      (private-field
+       [wx #f])
+      (sequence
+	(super-init (lambda () 
+		      (let ([ds (+ (cond
+				    [(memq 'control-border style) (+ 4 canvas-control-border-extra)]
+				    [(memq 'border style) 4]
+				    [else 0])
+				   (if (or has-x? has-y?)
+				       canvas-default-size
+				       1))])
+			(set! wx (make-object wx-canvas% this this
+					      (mred->wx-container parent)
+					      -1 -1 
+					      (+ ds (if (memq 'combo style) side-combo-width 0)) ds
+					      style
+					      gl-config)))
+		      wx)
+		    (lambda ()
+		      (let ([cwho '(constructor canvas)])
+			(check-container-ready cwho parent)))
+		    parent)
+	(when label
+	  (set-label label))
+	(send parent after-new-child this))))
+  
+  (define editor-canvas%
+    (class100*/kw basic-canvas% ()
+		  [(parent [editor #f] [style null] [scrolls-per-page 100] [label #f]
+			   [wheel-step no-val] [line-count no-val]
+			   [horizontal-inset 5] [vertical-inset 5])
+		   canvas%-keywords]
+      (sequence 
+	(let ([cwho '(constructor editor-canvas)])
+	  (check-container-parent cwho parent)
+	  (check-instance cwho internal-editor<%> "text% or pasteboard%" #t editor)
+	  (check-style cwho #f '(hide-vscroll hide-hscroll no-vscroll no-hscroll auto-vscroll auto-hscroll
+					      deleted control-border combo transparent no-border resize-corner)
+		       style)
+	  (check-gauge-integer cwho scrolls-per-page)
+	  (check-label-string/false cwho label)
+	  (unless (eq? wheel-step no-val)
+	    (check-wheel-step cwho wheel-step))
+	  (unless (or (not line-count) (eq? line-count no-val))
+	    ((check-bounded-integer 1 1000 #t) cwho line-count))
+	  (unless (eq? horizontal-inset 5)
+	    (check-margin-integer cwho horizontal-inset))
+	  (unless (eq? vertical-inset 5)
+	    (check-margin-integer cwho vertical-inset))))
+      (inherit set-label)
+      (private-field
+       [force-focus? #f]
+       [scroll-to-last? #f]
+       [scroll-bottom? #f])
+      (public
+	[call-as-primary-owner (lambda (f) (send wx call-as-primary-owner f))]
+	[allow-scroll-to-last
+	 (entry-point 
+	  (case-lambda
+	   [() scroll-to-last?]
+	   [(on?) (set! scroll-to-last? (and on? #t))
+	    (send wx allow-scroll-to-last on?)]))]
+	[scroll-with-bottom-base
+	 (entry-point
+	  (case-lambda
+	   [() scroll-bottom?]
+	   [(on?) (set! scroll-bottom? (and on? #t))
+	    (send wx scroll-with-bottom-base on?)]))]
+	[lazy-refresh
+	 (entry-point
+	  (case-lambda
+	   [() (send wx get-lazy-refresh)]
+	   [(on?) (send wx set-lazy-refresh on?)]))]
+	[force-display-focus
+	 (entry-point
+	  (case-lambda
+	   [() force-focus?]
+	   [(on?) (set! force-focus? (and on? #t))
+	    (send wx force-display-focus on?)]))]
+
+	[allow-tab-exit (entry-point
+			 (case-lambda
+			  [() (send wx is-tabable?)]
+			  [(on?) (send wx set-tabable (and on? #t))]))]
+
+	[set-line-count
+	 (entry-point
+	  (lambda (n)
+	    ((check-bounded-integer 1 1000 #t) '(method editor-canvas% set-line-count) n)
+	    (send wx set-line-count n)))]
+	[get-line-count
+	 (entry-point
+	  (lambda ()
+	    (send wx get-line-count)))]
+
+	[scroll-to (case-lambda 
+		    [(x y w h refresh?) (send wx scroll-to x y w h refresh?)]
+		    [(x y w h refresh? bias) (send wx scroll-to x y w h refresh? bias)])]
+
+	[get-editor (entry-point (lambda () (send wx get-editor)))]
+	[set-editor (entry-point 
+		     (case-lambda 
+		      [(m) (send wx set-editor m)]
+		      [(m upd?) (send wx set-editor m upd?)]))]
+	[(ws wheel-step)
+	 (case-lambda 
+	  [() (let ([v (send wx get-wheel-step)])
+		(if (zero? v) #f v))]
+	  [(wheel-step)
+	   (check-wheel-step '(method editor-canvas% wheel-step) wheel-step)
+	   (send wx set-wheel-step (or wheel-step 0))])]
+	[(vi vertical-inset)
+	 (entry-point
+	  (case-lambda
+	   [() (send wx get-y-margin)]
+	   [(m) 
+	    (check-margin-integer '(method editor-canvas% vertical-inset) m)
+	    (as-exit (lambda () (send wx set-y-margin m)))]))]
+	[(hi horizontal-inset)
+	 (entry-point
+	  (case-lambda
+	   [() (send wx get-x-margin)]
+	   [(m) 
+	    (check-margin-integer '(method editor-canvas% horizontal-inset) m)
+	    (as-exit (lambda () (send wx set-x-margin m)))]))])
+      (private-field
+       [wx #f])
+      (sequence
+	(super-init (lambda () 
+		      (let* ([no-h? (or (memq 'no-vscroll style)
+					(memq 'hide-vscroll style))]
+			     [no-v? (or (memq 'no-hscroll style)
+					(memq 'hide-hscroll style))]
+			     [get-ds (lambda (no-this? no-other?)
+				       (+ (if (memq 'control-border style)
+					      canvas-control-border-extra
+					      0)
+					  (cond
+					   [(and no-this? no-other?) 14]
+					   [no-this? canvas-default-size]
+					   [else (+ canvas-scroll-size canvas-default-size)])))])
+			(set! wx (make-object wx-editor-canvas% this this
+					      (mred->wx-container parent) -1 -1
+					      (+ (get-ds no-h? no-v?) (if (memq 'combo style) side-combo-width 0))
+					      (get-ds no-v? no-h?)
+					      #f 
+					      (append
+					       (if (memq 'no-border style)
+						   null
+						   '(border))
+					       (remq 'no-border style))
+					      scrolls-per-page #f))
+			wx))
+		    (lambda () 
+		      (let ([cwho '(constructor editor-canvas)])
+			(check-container-ready cwho parent)))
+		    parent)
+	(unless (eq? wheel-step no-val)
+	  (ws wheel-step))
+	(when label
+	  (set-label label))
+	(when editor
+	  (set-editor editor))
+	(send parent after-new-child this)
+	(unless (or (not line-count) (eq? line-count no-val))
+	  (set-line-count line-count))
+	(unless (or (eq? vertical-inset 5))
+	  (vi vertical-inset))
+	(unless (or (eq? horizontal-inset 5))
+	  (hi horizontal-inset))))))
+
diff --git a/collects/mred/private/mrcontainer.ss b/collects/mred/private/mrcontainer.ss
new file mode 100644
index 0000000000..21f38ce65e
--- /dev/null
+++ b/collects/mred/private/mrcontainer.ss
@@ -0,0 +1,139 @@
+(module mrcontainer mzscheme
+  (require (lib "class.ss")
+	   (lib "class100.ss")
+	   (lib "list.ss")
+	   (prefix wx: "kernel.ss")
+	   "lock.ss"
+	   "helper.ss"
+	   "const.ss"
+	   "wx.ss"
+	   "kw.ss"
+	   "check.ss"
+	   "wxcontainer.ss"
+	   "mrwindow.ss")
+
+  (provide area-container<%>
+	   (protect internal-container<%>
+		    check-container-parent
+		    container%-keywords
+		    make-container%)
+	   area-container-window<%>
+	   (protect make-area-container-window%))
+
+  (define area-container<%> 
+    (interface (area<%>) 
+      reflow-container container-flow-modified begin-container-sequence end-container-sequence
+      container-size
+      get-children change-children place-children
+      after-new-child
+      add-child delete-child
+      border spacing 
+      set-alignment get-alignment))
+
+  (define internal-container<%> (interface ()))
+
+  (define (check-container-parent who p)
+    (unless (is-a? p internal-container<%>)
+      (raise-type-error (who->name who) "built-in container<%> object" p)))
+  
+  (define-keywords container%-keywords
+    [border no-val]
+    [spacing no-val]
+    [alignment no-val])
+
+  (define (make-container% %) ; % implements area<%>
+    (class100* % (area-container<%> internal-container<%>) (mk-wx get-wx-pan mismatches parent
+								  ;; for keyword use
+								  [border no-val]
+								  [spacing no-val]
+								  [alignment no-val])
+      (sequence
+	(let ([cwho '(iconstructor area-container)])
+	  (unless (eq? border no-val) (check-margin-integer cwho border))
+	  (unless (eq? spacing no-val) (check-margin-integer cwho spacing))
+	  (unless (eq? alignment no-val)
+	    (unless (and (list? alignment)
+			 (= 2 (length alignment))
+			 (memq (car alignment) '(left center right))
+			 (memq (cadr alignment) '(top center bottom)))
+	      (raise-type-error (who->name cwho) "alignment list" alignment)))))
+      (private-field [get-wx-panel get-wx-pan])
+      (public
+	[after-new-child (lambda (c) 
+			   (check-instance '(method area-container<%> after-new-child) subarea<%> 'subarea<%> #f c)
+			   (void))]
+	[reflow-container (entry-point (lambda () (send (send (get-wx-panel) get-top-level) force-redraw)))]
+	[container-flow-modified (entry-point (lambda () 
+						(let ([p (get-wx-panel)])
+						  (send p need-move-children)
+						  (send p force-redraw))))]
+	[begin-container-sequence (entry-point (lambda () (send (send (get-wx-panel) get-top-level) begin-container-sequence)))]
+	[end-container-sequence (entry-point (lambda () (send (send (get-wx-panel) get-top-level) end-container-sequence)))]
+	[get-children (entry-point (lambda () (map wx->proxy 
+						   (let ([l (send (get-wx-panel) get-children)]
+							 [h (send (get-wx-panel) get-hidden-child)])
+						     (if h (remq h l) l)))))]
+	[(bdr border) (param get-wx-panel border)]
+	[(spc spacing) (param get-wx-panel spacing)]
+	[set-alignment (entry-point (lambda (h v) (send (get-wx-panel) alignment h v)))]
+	[get-alignment (entry-point (lambda () (send (get-wx-panel) get-alignment)))]
+	[change-children (entry-point
+			  (lambda (f)
+			    (unless (and (procedure? f)
+					 (procedure-arity-includes? f 1))
+			      (raise-type-error (who->name '(method container<%> change-children))
+						"procedure or arity 1"
+						f))
+			    (send (get-wx-panel) change-children
+				  (lambda (kids)
+				    (let* ([hidden (send (get-wx-panel) get-hidden-child)]
+					   [mred-kids (map wx->proxy (remq hidden kids))]
+					   [l (as-exit (lambda () (f mred-kids)))])
+				      (unless (and (list? l)
+						   (andmap (lambda (x) (is-a? x internal-subarea<%>)) l))
+					(raise-mismatch-error 'change-children
+							      "result of given procedure was not a list of subareas: "
+							      l))
+				      (append
+				       (if hidden (list hidden) null)
+				       (map mred->wx l)))))))]
+	[container-size (entry-point
+			 (lambda (l) 
+					; Check l, even though we don't use it
+			   (unless (and (list? l) 
+					(andmap
+					 (lambda (l)
+					   (and (list? l) (= (length l) 4)
+						(integer? (car l)) (exact? (car l)) (<= 0 (car l) 10000)
+						(integer? (cadr l)) (exact? (cadr l)) (<= 0 (cadr l) 10000)))
+					 l))
+			     (raise-type-error (who->name '(method area-container<%> container-size))
+					       "list of lists containing two exact integers in [0, 10000] and two booleans"
+					       l))
+			   (let ([l (send (get-wx-panel) do-get-graphical-min-size)])
+			     (apply values l))))]
+	[place-children (entry-point (lambda (l w h) (send (get-wx-panel) do-place-children l w h)))]
+	[add-child (entry-point
+		    (lambda (c) 
+		      (check-instance '(method area-container<%> add-child) subwindow<%> 'subwindow<%> #f c)
+		      (send (get-wx-panel) add-child (mred->wx c))))]
+	[delete-child (entry-point
+		       (lambda (c) 
+			 (check-instance '(method area-container<%> delete-child) subwindow<%> 'subwindow<%> #f c)
+			 (send (get-wx-panel) delete-child (mred->wx c))))])
+      (sequence
+	(super-init mk-wx get-wx-panel mismatches parent)
+	(unless (eq? border no-val) (bdr border))
+	(unless (eq? spacing no-val) (spc spacing))
+	(unless (eq? alignment no-val) (set-alignment . alignment)))))
+
+  (define area-container-window<%>
+    (interface (window<%> area-container<%>)))
+
+  (define (make-area-container-window% %) ; % implements window<%> (and area-container<%>)
+    (class100* % (area-container-window<%>) (mk-wx get-wx-pan mismatches label parent cursor) 
+      (private-field [get-wx-panel get-wx-pan])
+      (sequence
+	(super-init mk-wx get-wx-panel mismatches label parent cursor)))))
+
+
diff --git a/collects/mred/private/mrgroupbox.ss b/collects/mred/private/mrgroupbox.ss
new file mode 100644
index 0000000000..f556dc0a4c
--- /dev/null
+++ b/collects/mred/private/mrgroupbox.ss
@@ -0,0 +1,35 @@
+(module mrgroupbox mzscheme
+  (require (lib "class.ss")
+	   (lib "class100.ss")
+	   (prefix wx: "kernel.ss")
+	   "lock.ss"
+	   "const.ss"
+	   "check.ss"
+	   "helper.ss"
+	   "wx.ss"
+	   "wxgroupbox.ss"
+	   "mrcontainer.ss"
+	   "mritem.ss")
+
+  (provide (protect group-box%))
+
+  ;; Not exported from MrEd:
+  (define group-box%
+    (class100 basic-control% (label parent [style null] [font #f])
+      (override
+	[hidden-child? (lambda () #t)])
+      (sequence
+	(let ([cwho '(constructor group-box)])
+	  (check-label-string cwho label)
+	  (check-container-parent cwho parent)
+	  (check-style cwho #f '(deleted) style))
+	(super-init (lambda () (make-object wx-group-box% this this
+					    style
+					    (mred->wx-container parent)
+					    label
+					    style
+					    (no-val->#f font)))
+		    (lambda ()
+		      (let ([cwho '(constructor group-box)])
+			(check-container-ready cwho parent)))
+		    label parent void #f)))))
diff --git a/collects/mred/private/mritem.ss b/collects/mred/private/mritem.ss
new file mode 100644
index 0000000000..32f0042fa0
--- /dev/null
+++ b/collects/mred/private/mritem.ss
@@ -0,0 +1,536 @@
+(module mritem mzscheme
+  (require (lib "class.ss")
+	   (lib "class100.ss")
+	   (lib "list.ss")
+	   (prefix wx: "kernel.ss")
+	   "lock.ss"
+	   "const.ss"
+	   "kw.ss"
+	   "check.ss"
+	   "helper.ss"
+	   "wx.ss"
+	   "wxitem.ss"
+	   "mrwindow.ss"
+	   "mrcontainer.ss")
+
+  (provide control<%>
+	   (protect control%-keywords
+		    basic-control%)
+	   message%
+	   button%
+	   check-box%
+	   radio-box%
+	   slider%
+	   gauge%
+
+	   list-control<%>
+	   choice%
+	   list-box%
+
+	   (protect wrap-callback
+		    check-list-control-args
+		    check-list-control-selection
+		    
+		    ;; Local methods:
+		    hidden-child?
+		    label-checker))
+
+  (define control<%>
+    (interface (subwindow<%>)
+      command
+      get-font))
+
+  (define-local-member-name hidden-child? label-checker)
+
+  (define-keywords control%-nofont-keywords
+    window%-keywords
+    subarea%-keywords
+    area%-keywords)
+
+  (define-keywords control%-keywords
+    [font no-val]
+    control%-nofont-keywords)
+
+  (define basic-control%
+    (class100* (make-window% #f (make-subarea% area%)) (control<%>) (mk-wx mismatches lbl parent cb cursor
+									   ;; for keyword use
+									   [font no-val])
+      (rename [super-set-label set-label])
+      (private-field [label lbl][callback cb])
+      (override
+	[get-label (lambda () label)]
+	[get-plain-label (lambda () (and (string? label) (wx:label->plain-label label)))]
+	[set-label (entry-point
+		    (lambda (l)
+		      ((label-checker)
+		       '(method control<%> set-label) l)
+		      (let ([l (if (string? l) 
+				   (string->immutable-string l)
+				   l)])
+			(send wx set-label l)
+			(set! label l))))])
+      (public
+	[hidden-child? (lambda () #f)] ; module-local method
+	[label-checker  (lambda () check-label-string/false)] ; module-local method
+	[command (lambda (e) (void (callback this e)))] ; no entry/exit needed
+	[get-font (lambda (e) (send wx get-font))]) ; no entry/exit needed
+      (private-field
+       [wx #f])
+      (sequence
+	(when (string? label)
+	  (set! label (string->immutable-string label)))
+	(super-init (lambda () (set! wx (mk-wx)) wx) (lambda () wx) mismatches label parent cursor)
+	(unless (hidden-child?)
+	  (as-exit (lambda () (send parent after-new-child this)))))))
+
+  (define (wrap-callback cb)
+    (if (and (procedure? cb)
+	     (procedure-arity-includes? cb 2))
+	(lambda (w e) (if (or (eq? 'windows (system-type))
+			      (and (memq (system-type) '(macos macosx))
+				   (eq? (send e get-event-type) 'slider)))
+			  ;; Mac OS slider and Windows (all): need trampoline
+			  (wx:queue-callback
+			   (lambda ()
+			     (cb (wx->proxy w) e))
+			   wx:middle-queue-key)
+			  (cb (wx->proxy w) e)))
+	cb))
+
+  (define message%
+    (class100*/kw basic-control% () [(label parent [style null]) control%-keywords]
+      (override
+	[label-checker  (lambda () check-label-string-or-bitmap)]) ; module-local method
+      (sequence
+	(let ([cwho '(constructor message)])
+	  (check-label-string/bitmap/iconsym cwho label)
+	  (check-container-parent cwho parent)
+	  (check-style cwho #f '(deleted) style)
+	  (check-font cwho font))
+	(as-entry
+	 (lambda ()
+	   (super-init (lambda () (make-object wx-message% this this
+					       (mred->wx-container parent)
+					       label -1 -1 style (no-val->#f font)))
+		       (lambda () 
+			 (let ([cwho '(constructor message)])
+			   (check-container-ready cwho parent)))
+		       label parent void #f))))))
+
+  (define button%
+    (class100*/kw basic-control% () [(label parent [callback (lambda (b e) (void))] [style null]) control%-keywords]
+      (override
+	[label-checker  (lambda () check-label-string-or-bitmap)]) ; module-local method
+      (sequence
+	(let ([cwho '(constructor button)])
+	  (check-label-string-or-bitmap cwho label)
+	  (check-container-parent cwho parent)
+	  (check-callback cwho callback)
+	  (check-style cwho #f '(border deleted) style)
+	  (check-font cwho font))
+	(as-entry
+	 (lambda ()
+	   (super-init (lambda () (make-object wx-button% this this
+					       (mred->wx-container parent) (wrap-callback callback)
+					       label -1 -1 -1 -1 style (no-val->#f font)))
+		       (lambda () 
+			 (let ([cwho '(constructor button)])
+			   (check-container-ready cwho parent)))
+		       label parent callback #f))))))
+
+  (define check-box%
+    (class100*/kw basic-control% () [(label parent [callback (lambda (b e) (void))] [style null] [value #f]) control%-keywords]
+      (sequence
+	(let ([cwho '(constructor check-box)])
+	  (check-label-string-or-bitmap cwho label)
+	  (check-container-parent cwho parent)
+	  (check-callback cwho callback)
+	  (check-style cwho #f '(deleted) style)
+	  (check-font cwho font)))
+      (override
+	[label-checker  (lambda () check-label-string-or-bitmap)]) ; module-local method
+      (private-field
+       [wx #f])
+      (public
+	[get-value (entry-point (lambda () (send wx get-value)))]
+	[set-value (entry-point (lambda (v) (send wx set-value v)))])
+      (sequence
+	(as-entry
+	 (lambda ()
+	   (super-init (lambda () 
+			 (set! wx (make-object wx-check-box% this this
+					       (mred->wx-container parent) (wrap-callback callback)
+					       label -1 -1 -1 -1 style (no-val->#f font)))
+			 wx)
+		       (lambda ()
+			 (let ([cwho '(constructor check-box)])
+			   (check-container-ready cwho parent)))
+		       label parent callback #f)))
+	(when value (set-value #t)))))
+
+  (define radio-box%
+    (class100*/kw basic-control% () 
+		  [(label choices parent [callback (lambda (b e) (void))] [style '(vertical)] [selection 0]) control%-keywords]
+      (private-field [chcs choices])
+      (sequence 
+	(let ([cwho '(constructor radio-box)])
+	  (check-label-string/false cwho label)
+	  (unless (and (list? chcs) (pair? chcs)
+		       (or (andmap label-string? chcs)
+			   (andmap (lambda (x) (is-a? x wx:bitmap%)) chcs)))
+	    (raise-type-error (who->name cwho) "non-empty list of strings (up to 200 characters) or bitmap% objects" chcs))
+	  (check-container-parent cwho parent)
+	  (check-callback cwho callback)
+	  (check-orientation cwho style)
+	  (check-non-negative-integer cwho selection)))
+      (private-field
+       [wx #f])
+      (private
+	[check-button
+	 (lambda (method n)
+	   (check-non-negative-integer `(method radio-box% ,method) n)
+	   (unless (< n (length chcs))
+	     (raise-mismatch-error (who->name `(method radio-box% ,method)) "no such button: " n)))])
+      (override
+	[enable (entry-point
+		 (case-lambda
+		  [(on?) (send wx enable on?)]
+		  [(which on?) (check-button 'enable which)
+		   (send wx enable which on?)]))]
+	[is-enabled? (entry-point
+		      (case-lambda
+		       [() (send wx is-enabled?)]
+		       [(which) (check-button 'is-enabled? which)
+			(send wx is-enabled? which)]))])
+      (public
+	[get-number (lambda () (length chcs))]
+	[get-item-label (lambda (n) 
+			  (check-button 'get-item-label n)
+			  (list-ref chcs n))]
+	[get-item-plain-label (lambda (n) 
+				(check-button 'get-item-plain-label n)
+				(wx:label->plain-label (list-ref chcs n)))]
+	
+	[get-selection (entry-point (lambda () (send wx get-selection)))]
+	[set-selection (entry-point
+			(lambda (v) 
+			  (check-button 'set-selection v)
+			  (send wx set-selection v)))])
+      (sequence
+	(as-entry
+	 (lambda ()
+	   (when (andmap string? chcs)
+	     (set! chcs (map string->immutable-string chcs)))
+	   (super-init (lambda () 
+			 (set! wx (make-object wx-radio-box% this this
+					       (mred->wx-container parent) (wrap-callback callback)
+					       label -1 -1 -1 -1 chcs 0 style (no-val->#f font)))
+			 wx)
+		       (lambda ()
+			 (let ([cwho '(constructor radio-box)])
+			   (check-container-ready cwho parent)
+			   (unless (< selection (length choices))
+			     (raise-mismatch-error (who->name cwho)
+						   (format "initial selection is too large, given only ~a choices: "
+							   (length choices))
+						   selection))))
+		       label parent callback #f)))
+	(when (positive? selection)
+	  (set-selection selection)))))
+
+  (define slider%
+    (class100*/kw basic-control% ()
+		  [(label min-value max-value parent [callback (lambda (b e) (void))] [init-value min-value] [style '(horizontal)])
+		   control%-keywords]
+      (private-field [minv min-value][maxv max-value])
+      (sequence 
+	(let ([cwho '(constructor slider)])
+	  (check-label-string/false cwho label)
+	  (check-slider-integer cwho minv)
+	  (check-slider-integer cwho maxv)
+	  (check-container-parent cwho parent) 
+	  (check-callback cwho callback)
+	  (check-slider-integer cwho init-value)
+	  (check-style cwho '(vertical horizontal) '(plain vertical-label horizontal-label deleted) style)
+	  (check-font cwho font)))
+      (private-field
+       [wx #f])
+      (public
+	[get-value (entry-point (lambda () (send wx get-value)))]
+	[set-value (entry-point
+		    (lambda (v)
+		      (check-slider-integer '(method slider% set-value) v)
+		      (unless (<= minv v maxv)
+			(raise-mismatch-error (who->name '(method slider% set-value))
+					      (format "slider's range is ~a to ~a; cannot set the value to: "
+						      minv maxv)
+					      v))
+		      (send wx set-value v)))])
+      (sequence
+	(as-entry
+	 (lambda ()
+	   (super-init (lambda () 
+			 (set! wx (make-object wx-slider% this this
+					       (mred->wx-container parent) (wrap-callback callback)
+					       label init-value minv maxv style (no-val->#f font)))
+			 wx)
+		       (lambda () 
+			 (let ([cwho '(constructor slider)])
+			   (check-container-ready cwho parent)))
+		       label parent callback #f))))))
+
+  (define gauge%
+    (class100*/kw basic-control% ()
+		  [(label range parent [style '(horizontal)]) control%-keywords]
+      (sequence 
+	(let ([cwho '(constructor gauge)])
+	  (check-label-string/false cwho label)
+	  (check-container-parent cwho parent) 
+	  (check-gauge-integer cwho range)
+	  (check-orientation cwho style)))
+      (private-field
+       [wx #f])
+      (public
+	[get-value (entry-point (lambda () (send wx get-value)))]
+	[set-value (entry-point
+		    (lambda (v)
+		      (check-range-integer '(method gauge% set-value) v)
+		      (when (> v (send wx get-range))
+			(raise-mismatch-error (who->name '(method gauge% set-value))
+					      (format "gauge's range is 0 to ~a; cannot set the value to: "
+						      (send wx get-range))
+					      v))
+		      (send wx set-value v)))]
+	[get-range (entry-point (lambda () (send wx get-range)))]
+	[set-range (entry-point
+		    (lambda (v)
+		      (check-gauge-integer '(method gauge% set-range) v)
+		      (send wx set-range v)))])
+      (sequence
+	(as-entry
+	 (lambda ()
+	   (super-init (lambda () 
+			 (set! wx (make-object wx-gauge% this this
+					       (mred->wx-container parent)
+					       label range style (no-val->#f font)))
+			 wx)
+		       (lambda ()
+			 (let ([cwho '(constructor gauge)])
+			   (check-container-ready cwho parent)))
+		       label parent void #f))))))
+
+  ;; List controls ----------------------------------------
+
+  (define list-control<%>
+    (interface (control<%>)
+      clear append
+      get-number
+      get-string find-string
+      get-selection
+      get-string-selection
+      set-selection
+      set-string-selection))
+
+  (define (-1=>false v) (if (negative? v) #f v))
+
+  (define-local-member-name 
+    -append-list-string
+    -set-list-strings
+    -set-list-string
+    -delete-list-item)
+
+  (define basic-list-control%
+    (class100* basic-control% (list-control<%>) (mk-wx mismatches label parent selection callback init-choices)
+      (private-field
+       [content (map string->immutable-string init-choices)])
+      (public
+	[(-append append) (entry-point (lambda (i) 
+					 (check-label-string '(method list-control<%> append) i)
+					 (-append-list-string i)
+					 (send wx append i)))]
+	[clear (entry-point (lambda () (send wx clear) (set! content null)))]
+	[get-number (entry-point (lambda () (send wx number)))]
+	[get-string (entry-point (lambda (n) (check-item 'get-string n) (list-ref content n)))]
+	[get-selection (entry-point (lambda () (and (positive? (send wx number)) (-1=>false (send wx get-selection)))))]
+	[get-string-selection (entry-point (lambda () (and (positive? (send wx number)) 
+							   (let ([v (send wx get-selection)])
+							     (if (= v -1)
+								 #f
+								 (list-ref content v))))))]
+	[set-selection (entry-point (lambda (s) (check-item 'set-selection s) (send wx set-selection s)))]
+	[set-string-selection (entry-point
+			       (lambda (s)
+				 (check-label-string '(method list-control<%> set-string-selection) s)
+				 (let ([pos (do-find-string s)])
+				   (if pos
+				       (send wx set-selection pos)
+				       (raise-mismatch-error (who->name '(method list-control<%> set-string-selection))
+							     "no item matching the given string: " s)))))]
+	[find-string (entry-point (lambda (x)
+				    (check-label-string '(method list-control<%> find-string) x)
+				    (do-find-string x)))]
+	
+	[-append-list-string (lambda (i)
+			       (set! content (append content (list i))))]
+	[-set-list-string (lambda (i s)
+			    (set-car! (list-tail content i) (string->immutable-string s)))]
+	[-delete-list-item (lambda (pos)
+			     (if (zero? pos)
+				 (set! content (cdr content))
+				 (set-cdr! (list-tail content (sub1 pos)) 
+					   (list-tail content (add1 pos)))))]
+	[-set-list-strings (lambda (l)
+			     (set! content (map string->immutable-string l)))])
+      (private-field
+       [wx #f])
+      (private
+	[do-find-string
+	 (lambda (s)
+	   (let loop ([l content][pos 0])
+	     (cond
+	      [(null? l) #f]
+	      [(string=? s (car l)) pos]
+	      [else (loop (cdr l) (add1 pos))])))]
+	[check-item
+	 (lambda (method n)
+	   (check-non-negative-integer `(method list-control<%> ,method) n)
+	   (let ([m (send wx number)])
+	     (unless (< n m)
+	       (raise-mismatch-error (who->name `(method list-control<%> ,method)) 
+				     (if (zero? m)
+					 "control has no items; given index: " 
+					 (format "control has only ~a items, indexed 0 to ~a; given out-of-range index: " 
+						 m (sub1 m)))
+				     n))))])
+      (sequence
+	(as-entry
+	 (lambda ()
+	   (super-init (lambda () (set! wx (mk-wx)) wx) mismatches label parent callback #f)))
+	(when selection
+	  (set-selection selection)))))
+
+  (define (check-list-control-args cwho label choices parent callback)
+    (check-label-string/false cwho label)
+    (unless (and (list? choices) (andmap label-string? choices))
+      (raise-type-error (who->name cwho) "list of strings (up to 200 characters)" choices))
+    (check-container-parent cwho parent)
+    (check-callback cwho callback))
+
+  (define (check-list-control-selection cwho choices selection)
+    (unless (< selection (length choices))
+      (raise-mismatch-error (who->name cwho)
+			    (format "initial selection is too large, given only ~a choices: "
+				    (length choices))
+			    selection)))
+
+  (define choice%
+    (class100*/kw basic-list-control% ()
+		  [(label choices parent [callback (lambda (b e) (void))] [style null] [selection 0])
+		   control%-keywords]
+      (sequence
+	(let ([cwho '(constructor choice)])
+	  (check-list-control-args cwho label choices parent callback)
+	  (check-style cwho #f '(vertical-label horizontal-label deleted) style)
+	  (check-non-negative-integer cwho selection)
+	  (check-font cwho font))
+	(super-init (lambda () (make-object wx-choice% this this
+					    (mred->wx-container parent) (wrap-callback callback)
+					    label -1 -1 -1 -1 choices style (no-val->#f font)))
+		    (lambda ()
+		      (let ([cwho '(constructor choice)])
+			(check-container-ready cwho parent)
+			(unless (= 0 selection)
+			  (check-list-control-selection cwho choices selection))))
+		    label parent 
+		    (and (positive? selection) selection)
+		    callback
+		    choices))))
+
+  (define list-box%
+    (class100*/kw basic-list-control%  ()
+		  [(label choices parent [callback (lambda (b e) (void))] [style '(single)] [selection #f] [font no-val] [label-font no-val])
+		   control%-nofont-keywords]
+      (sequence 
+	(let ([cwho '(constructor list-box)])
+	  (check-list-control-args cwho label choices parent callback)
+	  (check-style cwho '(single multiple extended) '(vertical-label horizontal-label deleted) style)
+	  (check-non-negative-integer/false cwho selection)
+	  (check-font cwho font)
+	  (check-font cwho label-font)))
+      (rename [super-append append])
+      (override
+	[append (entry-point
+		 (case-lambda
+		  [(i) 
+		   (super-append i)]
+		  [(i d) 
+		   (check-label-string '(method list-control<%> append) i)
+		   (send this -append-list-string i)
+		   (send wx append i d)]))])
+      (public
+	[delete (entry-point (lambda (n) 
+			       (check-item 'delete n) 
+			       (send this -delete-list-item n)
+			       (send wx delete n)))]
+	[get-data (entry-point (lambda (n) (check-item 'get-data n) (send wx get-data n)))]
+	[get-label-font (lambda () (send wx get-label-font))]
+	[get-selections (entry-point (lambda () (send wx get-selections)))]
+	[number-of-visible-items (entry-point (lambda () (send wx number-of-visible-items)))]
+	[is-selected? (entry-point (lambda (n) (check-item 'is-selected? n) (send wx selected? n)))]
+	[set (entry-point (lambda (l) 
+			    (unless (and (list? l) (andmap label-string? l))
+			      (raise-type-error (who->name '(method list-box% set)) 
+						"list of strings (up to 200 characters)" l))
+			    (send this -set-list-strings l)
+			    (send wx set l)))]
+	[set-string (entry-point
+		     (lambda (n d)
+		       (check-non-negative-integer '(method list-box% set-string) n) ; int error before string
+		       (check-label-string '(method list-box% set-string) d) ; string error before range mismatch
+		       (check-item 'set-string n)
+		       (send this -set-list-string n d)
+		       (send wx set-string n d)))]
+	[set-data (entry-point (lambda (n d) (check-item 'set-data n) (send wx set-data n d)))]
+	[get-first-visible-item (entry-point (lambda () (send wx get-first-item)))]
+	[set-first-visible-item (entry-point (lambda (n) 
+					       (check-item 'set-first-visible-item n) 
+					       (send wx set-first-visible-item n)))]
+	[select (entry-point 
+		 (case-lambda 
+		  [(n) (check-item 'select n) (send wx select n #t)]
+		  [(n on?) (check-item 'select n) (send wx select n on?)]))])
+      (private-field
+       [wx #f])
+      (private
+	[check-item
+	 (entry-point
+	  (lambda (method n)
+	    (check-non-negative-integer `(method list-box% ,method) n)
+	    (let ([m (send wx number)])
+	      (unless (< n m)
+		(raise-mismatch-error (who->name `(method list-box% ,method))
+				      (if (zero? m)
+					  "list has no items; given index: " 
+					  (format "list has only ~a items, indexed 0 to ~a; given out-of-range index: "
+						  m (sub1 m)))
+				      n)))))])
+      (sequence
+	(super-init (lambda () 
+		      (let-values ([(kind style)
+				    (cond
+				     [(memq 'single style) (values 'single (remq 'single style))]
+				     [(memq 'multiple style) (values 'multiple (remq 'multiple style))]
+				     [else (values 'extended (remq 'extended style))])])
+			(set! wx (make-object wx-list-box% this this
+					      (mred->wx-container parent) (wrap-callback callback)
+					      label kind
+					      -1 -1 -1 -1 choices style 
+					      (no-val->#f font) (no-val->#f label-font))))
+		      wx)
+		    (lambda ()
+		      (let ([cwho '(constructor list-box)])
+			(check-container-ready cwho parent)
+			(when selection
+			  (check-list-control-selection cwho choices selection))))
+		    label parent (and (pair? choices) selection) callback
+		    choices)))))
diff --git a/collects/mred/private/mrmenu.ss b/collects/mred/private/mrmenu.ss
new file mode 100644
index 0000000000..27a765f70f
--- /dev/null
+++ b/collects/mred/private/mrmenu.ss
@@ -0,0 +1,372 @@
+(module mrmenu mzscheme
+  (require (lib "class.ss")
+	   (lib "class100.ss")
+	   (lib "list.ss")
+	   (prefix wx: "kernel.ss")
+	   "lock.ss"
+	   "const.ss"
+	   "helper.ss"
+	   "check.ss"
+	   "wx.ss"
+	   "app.ss"
+	   "wxmenu.ss"
+	   "mrtop.ss"
+	   "mrmenuintf.ss"
+	   "mrpopup.ss")
+
+  (provide separator-menu-item%
+	   menu-item%
+	   checkable-menu-item%
+	   menu%
+	   menu-bar%
+	   (protect menu-parent-only
+		    menu-or-bar-parent))
+
+  ;; Most of the work is in the item. Anything that appears in a menubar or
+  ;;  menu has an item. Submenus are created as instances of menu%, but
+  ;;  menu% has a get-item method for manipulating the menu w.r.t. the parent
+  ;;  (e.g., changing the title or enabled state). A popup menu, created
+  ;;  as an instance of popup-menu%, has no item.
+  ;;
+  ;; A menu bar is created as a menu-bar%, given a frame as its parent. The
+  ;;  frame must not already have a menu bar.
+  ;;
+  ;;  Plain labeled items are created as instances of menu-item% or
+  ;;   checkable-menu-item%. The parent must be a menu-item-container<%>,
+  ;;   which is a menu%, popup-menu%, or menu-bar%
+
+  (define separator-menu-item%
+    (class100* mred% (menu-item<%>) (parent)
+      (sequence (menu-parent-only 'separator-menu-item parent))
+      (private-field
+       [prnt parent]
+       [wx #f]
+       [shown? #f]
+       [wx-parent #f])
+      (public
+	[get-parent (lambda () prnt)]
+	[restore (entry-point
+		  (lambda ()
+		    (unless shown?
+		      (send wx-parent append-separator)
+		      (send wx-parent append-item this wx)
+		      (set! shown? #t))))]
+	[delete (entry-point
+		 (lambda ()
+		   (when shown?
+		     (send wx-parent delete-sep this wx)
+		     (set! shown? #f))))]
+	[is-deleted? (lambda () (not shown?))])
+      (sequence
+	(as-entry
+	 (lambda ()
+	   (set! wx (make-object wx-menu-item% this #f #f))
+	   (set! wx-parent (send (mred->wx prnt) get-container))
+	   (super-init wx)))
+	(restore))))
+
+  (define strip-tab 
+    (if (menu-shortcut-in-label?)
+	(lambda (s) 
+	  (car (regexp-match #rx"^[^\t]*" s)))
+	(lambda (s) 
+	  (regexp-replace* "&"
+			   (regexp-replace* "&(.)" (car (regexp-match #rx"^[^\t]*" s)) "\\1")
+			   "\\&\\&"))))
+
+  (define basic-labelled-menu-item%
+    (class100* mred% (labelled-menu-item<%>) (prnt lbl help-str wx-sub chkble? keymap set-wx demand-callback)
+      (private-field
+       [parent prnt]
+       [label lbl]
+       [help-string help-str]
+       [wx-submenu wx-sub]
+       [checkable? chkble?]
+       [callback demand-callback]
+       [wx #f]
+       [wx-parent #f]
+       [plain-label (string->immutable-string (wx:label->plain-label label))]
+       [in-menu? (is-a? parent internal-menu<%>)]
+       [shown? #f]
+       [enabled? #t])
+      (private
+	[do-enable (lambda (on?)
+		     (when shown?
+		       (if in-menu?
+			   (send wx-parent enable wx (send wx id) on?)
+			   (send wx-parent enable-top (send wx-parent position-of this) on?)))
+		     (set! enabled? (and on? #t)))])
+      (public
+	[on-demand (lambda () (callback this))]
+	[get-parent (lambda () parent)]
+	[get-label (lambda () label)]
+	[set-label (entry-point
+		    (lambda (l)
+		      (check-label-string '(method labelled-menu-item<%> set-label) l)
+		      (set! label (string->immutable-string l))
+		      (set-car! (send wx get-menu-data) l)  ; for meta-shortcuts
+		      (set! plain-label (string->immutable-string (wx:label->plain-label l)))
+		      (when shown?
+			(if in-menu?
+			    (send wx-parent set-label (send wx id) l)
+			    (send wx-parent set-label-top (send wx-parent position-of this) label)))))]
+	[get-plain-label (lambda () plain-label)]
+	[get-help-string (lambda () help-string)]
+	[set-help-string (entry-point
+			  (lambda (s) 
+			    (check-label-string/false '(method labelled-menu-item<%> set-help-string) s)
+			    (set! help-string (and s (string->immutable-string s)))
+			    (when in-menu?
+			      (send wx-parent set-help-string (send wx id) help-string))))]
+	[enable (lambda (on?) (do-enable on?))]
+	[is-enabled? (lambda () enabled?)]
+	[restore (entry-point
+		  (lambda ()
+		    (unless shown?
+		      (if in-menu?
+			  (begin
+			    (if wx-submenu
+				(send wx-parent append (send wx id) label wx-submenu help-string)
+				(send wx-parent append (send wx id) label help-string checkable?))
+			    (send wx-parent append-item this wx))
+			  (send wx-parent append-item this wx-submenu (strip-tab label)))
+		      (set! shown? #t)
+		      (do-enable enabled?))))]
+	[delete (entry-point
+		 (lambda ()
+		   (when shown?
+		     (if in-menu?
+			 (send wx-parent delete (send wx id) this)
+			 (send wx-parent delete-item this))
+		     (set! shown? #f))))]
+	[is-deleted? (lambda () (not shown?))])
+      (sequence
+	(as-entry
+	 (lambda ()
+	   (when help-string
+	     (set! help-string (string->immutable-string help-string)))
+	   (set! wx (set-wx (make-object wx-menu-item% this (cons label #f) #t)))
+	   (set! wx-parent (send (mred->wx parent) get-container))
+	   (super-init wx)
+	   (when keymap (send wx set-keymap keymap))))
+	(restore))))
+
+  (define (char-name c print?)
+    (case c
+      [(#\return) (if (eq? (system-type) 'macos) "Return" "Enter")]
+      [(#\tab) "Tab"]
+      [(#\space) "Space"]
+      [(#\backspace) "Backspace"]
+      [(#\rubout) "Delete"]
+      [(#\:) (if print? ":" "Colon")]
+      [(#\;) (if print? ";" "Semicolon")]
+      [else c]))
+
+  (define basic-selectable-menu-item%
+    (class100* basic-labelled-menu-item% (selectable-menu-item<%>) (lbl checkable? mnu cb shrtcut help-string set-wx demand-callback)
+      (inherit is-enabled?)
+      (rename [super-restore restore] [super-set-label set-label]
+	      [super-is-deleted? is-deleted?]
+	      [super-is-enabled? is-enabled?]
+	      [super-get-label get-label])
+      (private-field
+       [menu mnu]
+       [callback cb]
+       [label lbl]
+       [shortcut shrtcut]
+       [wx #f])
+      (public
+	[command (lambda (e)
+		   (check-instance '(method selectable-menu-item<%> command) wx:control-event% 'control-event% #f e)
+		   (void (callback this e)))])
+      (private-field
+       [x-prefix default-x-prefix])
+      (private
+	[calc-labels (lambda (label)
+		       (let* ([new-label (if shortcut
+					     (string-append
+					      (strip-tab label)
+					      (case (system-type)
+						[(unix) (format "~a~a~a" #\tab 
+								(case x-prefix
+								  [(meta) "Meta+"]
+								  [(alt) "Alt+"]
+								  [(ctl-m) "Ctl+M "]
+								  [(ctl) "Ctl+"])
+								(char-name
+								 (char-upcase shortcut)
+								 #t))]
+						[(windows) (format "~aCtl+~a" #\tab 
+								   (char-name (char-upcase shortcut) #t))]
+						[(macos macosx) (format "~aCmd+~a" #\tab 
+									(char-name (char-upcase shortcut) #t))]))
+					     (strip-tab label))]
+			      [key-binding (and shortcut
+						(case (system-type)
+						  [(unix) (format "~a~a" 
+								  (case x-prefix
+								    [(meta) ":m:"]
+								    [(alt) ":m:"]
+								    [(ctl-m) ":c:m;:"]
+								    [(ctl) ":c:"])
+								  (char-name (char-downcase shortcut) #f))]
+						  [(windows) (format ":c:~a" (char-name (char-downcase shortcut) #f))]
+						  [(macos macosx) (format ":d:~a" (char-name (char-downcase shortcut) #f))]))]
+			      [keymap (and key-binding
+					   (let ([keymap (make-object wx:keymap%)])
+					     (send keymap add-function "menu-item" 
+						   ;; keymap function callback already in exit mode:
+						   (lambda (edit event)
+						     (when (is-enabled?)
+						       (callback this (make-object wx:control-event% 'menu)))))
+					     (send keymap map-function key-binding "menu-item")
+					     keymap))])
+			 (values new-label keymap)))])
+      (private
+	[do-set-label (entry-point
+		       (lambda (l)
+			 (check-label-string '(method labelled-menu-item<%> set-label) l)
+			 (let-values ([(new-label keymap) (calc-labels l)])
+			   (set! label (string->immutable-string l))
+			   (super-set-label new-label)
+			   (if (or (super-is-deleted?)
+				   (not (super-is-enabled?)))
+			       (send wx set-keymap keymap)
+			       (send wx swap-keymap menu keymap)))))])
+      (override
+	[get-label (lambda () label)]
+	[set-label (lambda (s) (do-set-label s))])
+      (public
+	[set-shortcut (lambda (c) 
+			(check-char/false '(method selectable-menu-item<%> set-shortcut) c)
+			(unless (equal? shortcut c)
+			  (set! shortcut c) 
+			  (do-set-label label)))]
+	[get-shortcut (lambda () shortcut)]
+	[get-x-shortcut-prefix (lambda () x-prefix)]
+	[set-x-shortcut-prefix (lambda (p) 
+				 (unless (memq p '(meta alt ctl-m ctl))
+				   (raise-type-error (who->name '(method selectable-menu-item<%> set-x-shortcut-prefix))
+						     "symbol: meta, alt, ctl-m, or ctl" p))
+				 (set! x-prefix p) (do-set-label label))])
+      (sequence
+	(set! label (string->immutable-string label))
+	(let-values ([(new-label keymap) (calc-labels label)])
+	  (super-init menu new-label help-string #f checkable? keymap (lambda (x) (set! wx x) (set-wx x)) demand-callback)))))
+
+  (define (check-shortcut-args who label menu callback shortcut help-string demand-callback)
+    (let ([cwho `(constructor ,who)])
+      (check-label-string cwho label)
+      (menu-parent-only who menu)
+      (check-callback cwho callback)
+      (check-char/false cwho shortcut)
+      (check-label-string/false cwho help-string)
+      (check-callback1 cwho demand-callback)))
+
+  (define menu-item%
+    (class100 basic-selectable-menu-item% (label parent callback [shortcut #f] [help-string #f] [demand-callback void])
+      (sequence 
+	(check-shortcut-args 'menu-item label parent callback shortcut help-string demand-callback)
+	(super-init label #f parent callback shortcut help-string (lambda (x) x) demand-callback))))
+
+  (define checkable-menu-item%
+    (class100 basic-selectable-menu-item% (label parent callback [shortcut #f] [help-string #f] [demand-callback void] [checked #f])
+      (sequence
+	(check-shortcut-args 'checkable-menu-item label parent callback shortcut help-string demand-callback))
+      (private-field
+       [mnu parent]
+       [wx #f])
+      (public
+	[check (entry-point (lambda (on?) (send (send (mred->wx mnu) get-container) check (send wx id) on?)))]
+	[is-checked? (entry-point (lambda () (send (send (mred->wx mnu) get-container) checked? (send wx id))))])
+      (sequence
+	(super-init label #t mnu callback shortcut help-string (lambda (x) (set! wx x) x) demand-callback)
+	(when checked (check #t)))))
+
+  (define menu%
+    (class100* basic-labelled-menu-item% (menu-item-container<%> internal-menu<%>) (label parent [help-string #f] [demand-callback void])
+      (private-field 
+       [callback demand-callback])
+      (sequence 
+	(check-label-string '(constructor menu) label)
+	(menu-or-bar-parent 'menu parent)
+	(check-label-string/false '(constructor menu) help-string)
+	(check-callback1 '(constructor menu) demand-callback))
+      (public
+	[get-items (entry-point (lambda () (send wx-menu get-items)))])
+      (override
+	[on-demand (lambda ()
+		     (callback this)
+		     (for-each
+		      (lambda (i) 
+			(when (is-a? i labelled-menu-item<%>)
+			  (send i on-demand)))
+		      (send wx-menu get-items)))])
+      (private-field
+       [wx-menu #f])
+      (sequence
+	(as-entry
+	 (lambda () 
+	   (set! wx-menu (make-object wx-menu% this #f void #f))
+	   (super-init parent label help-string wx-menu #f (send wx-menu get-keymap) (lambda (x) x) void)
+	   (let ([wx-item (mred->wx this)])
+	     (set-cdr! (send wx-item get-menu-data) wx-menu) ; for meta-shortcuts
+	     (send wx-item set-wx-menu wx-menu)))))))
+
+  (define menu-bar%
+    (class100* mred% (menu-item-container<%>) (parent [demand-callback void])
+      (sequence 
+	(unless (or (is-a? parent frame%) (eq? parent 'root))
+	  (raise-type-error (constructor-name 'menu-bar) "frame% object or 'root" parent))
+	(check-callback1 '(constructor menu-bar) demand-callback)
+	(if (eq? parent 'root)
+	    (unless (current-eventspace-has-menu-root?)
+	      (raise-mismatch-error (constructor-name 'menu-bar) "no menu bar allowed in the current eventspace for: " parent))
+	    (when (as-entry (lambda () (send (mred->wx parent) get-the-menu-bar)))
+	      (raise-mismatch-error (constructor-name 'menu-bar) "the specified frame already has a menu bar: " parent))))
+      (private-field 
+       [callback demand-callback]
+       [prnt (if (eq? parent 'root)
+		 (let ([f (make-object (class frame%
+					 (define/override (on-exit)
+					   (exit))
+					 (super-make-object "Root")))])
+		   (as-entry
+		    (lambda ()
+		      (when root-menu-frame
+			(raise-mismatch-error (constructor-name 'menu-bar) "already has a menu bar: " parent))
+		      (send (mred->wx f) designate-root-frame)
+		      (set-root-menu-frame! f)))
+		   f)
+		 parent)]
+       [wx #f]
+       [wx-parent #f]
+       [shown? #f])
+      (public
+	[get-frame (lambda () prnt)]
+	[get-items (entry-point (lambda () (send wx get-items)))]
+	[enable (entry-point (lambda (on?) (send wx enable-all on?)))]
+	[is-enabled? (entry-point (lambda () (send wx all-enabled?)))]
+	[on-demand (lambda ()
+		     (callback this)
+		     (for-each
+		      (lambda (i) (send i on-demand))
+		      (send wx get-items)))])
+      (sequence
+	(as-entry
+	 (lambda ()
+	   (set! wx (make-object wx-menu-bar% this))
+	   (set! wx-parent (mred->wx prnt))
+	   (super-init wx)
+	   (send wx-parent set-menu-bar wx)
+	   (send wx-parent self-redraw-request))))))
+
+  (define (menu-parent-only who p)
+    (unless (is-a? p internal-menu<%>)
+      (raise-type-error (constructor-name who) "parent menu% or popup-menu% object" p)))
+
+  (define (menu-or-bar-parent who p)
+    (unless (or (is-a? p internal-menu<%>) (is-a? p menu-bar%))
+      (raise-type-error (constructor-name who) "built-in menu-item-container<%> object" p)))
+  
+  (wx:set-menu-tester (lambda (m) (is-a? m popup-menu%))))
diff --git a/collects/mred/private/mrmenuintf.ss b/collects/mred/private/mrmenuintf.ss
new file mode 100644
index 0000000000..943fc76778
--- /dev/null
+++ b/collects/mred/private/mrmenuintf.ss
@@ -0,0 +1,36 @@
+(module mrmenuintf mzscheme
+  (require (lib "class.ss"))
+
+  (provide menu-item<%>
+	   labelled-menu-item<%>
+	   submenu-item<%>
+	   menu-item-container<%>
+	   selectable-menu-item<%>)
+
+  (define menu-item<%>
+    (interface ()
+      get-parent
+      delete restore is-deleted?))
+
+  (define labelled-menu-item<%>
+    (interface (menu-item<%>)
+      get-label set-label get-plain-label
+      get-help-string set-help-string
+      enable is-enabled?
+      on-demand))
+
+  (define submenu-item<%>
+    (interface (labelled-menu-item<%>) 
+      get-menu))
+
+  (define selectable-menu-item<%>
+    (interface (labelled-menu-item<%>)
+      command
+      get-shortcut set-shortcut
+      get-x-shortcut-prefix set-x-shortcut-prefix))
+  
+  (define menu-item-container<%> 
+    (interface () 
+      get-items on-demand)))
+
+  
\ No newline at end of file
diff --git a/collects/mred/private/mrpanel.ss b/collects/mred/private/mrpanel.ss
new file mode 100644
index 0000000000..11d327b60f
--- /dev/null
+++ b/collects/mred/private/mrpanel.ss
@@ -0,0 +1,218 @@
+(module mrpanel mzscheme
+  (require (lib "class.ss")
+	   (lib "class100.ss")
+	   (prefix wx: "kernel.ss")
+	   "lock.ss"
+	   "const.ss"
+	   "check.ss"
+	   "helper.ss"
+	   "wx.ss"
+	   "kw.ss"
+	   "wxpanel.ss"
+	   "mrwindow.ss"
+	   "mrcontainer.ss"
+	   "mrtabgroup.ss"
+	   "mrgroupbox.ss")
+
+  (provide pane%
+	   vertical-pane%
+	   horizontal-pane%
+	   grow-box-spacer-pane%
+	   panel%
+	   vertical-panel%
+	   horizontal-panel%
+	   tab-panel%
+	   group-box-panel%)
+
+  (define-keywords pane%-keywords
+    subarea%-keywords
+    container%-keywords
+    area%-keywords)
+
+  (define pane%
+    (class100*/kw (make-subarea% (make-container% area%)) ()
+		  [(parent) pane%-keywords]
+      (private-field [wx #f])
+      (sequence 
+	(let* ([who (cond ; yuck! - we do this to make h-p and v-p subclasses of p
+		     [(is-a? this vertical-pane%) 'vertical-pane]
+		     [(is-a? this horizontal-pane%) 'horizontal-pane]
+		     [(is-a? this grow-box-spacer-pane%) 'grow-box-spacer-pane]
+		     [else 'pane])]
+	       [cwho `(constructor ,who)])
+	  (check-container-parent cwho parent)
+	  (as-entry
+	   (lambda ()
+	     (super-init (lambda () (set! wx (make-object (case who
+							    [(vertical-pane) wx-vertical-pane%]
+							    [(horizontal-pane) wx-horizontal-pane%]
+							    [(grow-box-spacer-pane) wx-grow-box-pane%]
+							    [else wx-pane%])
+							  this this (mred->wx-container parent) null)) wx)
+			 (lambda () wx) 
+			 (lambda ()
+			   (check-container-ready cwho parent))
+			 parent)
+	     (send (send wx area-parent) add-child wx)))
+	  (send parent after-new-child this)))))
+
+  (define vertical-pane% (class100*/kw pane% () [(parent) pane%-keywords] (sequence (super-init parent))))
+  (define horizontal-pane% (class100*/kw pane% () [(parent) pane%-keywords] (sequence (super-init parent))))
+  (define grow-box-spacer-pane% (class100*/kw pane% () [(parent) pane%-keywords] (sequence (super-init parent))))
+
+  (define-keywords panel%-keywords
+    window%-keywords
+    subarea%-keywords
+    container%-keywords
+    area%-keywords)
+
+  (define panel%
+    (class100*/kw (make-area-container-window% (make-window% #f (make-subarea% (make-container% area%)))) (subwindow<%>) 
+		  [(parent [style null]) panel%-keywords]
+      (private-field [wx #f])
+      (sequence 
+	(let* ([who (cond ; yuck! - we do this to make h-p and v-p subclasses of p
+		     [(is-a? this tab-panel%) 'tab-panel]
+		     [(is-a? this group-box-panel%) 'group-box-panel]
+		     [(is-a? this vertical-panel%) 'vertical-panel]
+		     [(is-a? this horizontal-panel%) 'horizontal-panel]
+		     [else 'panel])]
+	       [cwho `(constructor ,who)])
+	  (check-container-parent cwho parent)
+	  (check-style cwho #f '(border deleted) style)
+	  (as-entry
+	   (lambda ()
+	     (super-init (lambda () (set! wx (make-object (case who
+							    [(vertical-panel tab-panel group-box-panel) wx-vertical-panel%]
+							    [(horizontal-panel) wx-horizontal-panel%]
+							    [else wx-panel%])
+							  this this (mred->wx-container parent) style)) wx)
+			 (lambda () wx) 
+			 (lambda () (check-container-ready cwho parent))
+			 #f parent #f)
+	     (unless (memq 'deleted style)
+	       (send (send wx area-parent) add-child wx))))
+	  (send parent after-new-child this)))))
+
+  (define vertical-panel% (class100*/kw panel% () [(parent [style null]) panel%-keywords] (sequence (super-init parent style))))
+  (define horizontal-panel% (class100*/kw panel% () [(parent [style null]) panel%-keywords] (sequence (super-init parent style))))
+
+  (define list-append append)
+
+  (define tab-panel%
+    (class100*/kw vertical-panel% ()
+		  [(choices parent [callback (lambda (b e) (void))] [style null] [font no-val]) panel%-keywords]
+      (sequence
+	(let ([cwho '(constructor tab-panel)])
+	  (unless (and (list? choices) (andmap label-string? choices))
+	    (raise-type-error (who->name cwho) "list of strings (up to 200 characters)" choices))
+	  (check-callback cwho callback)
+	  (check-container-parent cwho parent)
+	  (check-style cwho #f '(deleted no-border) style)
+	  (check-font cwho font))
+	(super-init parent (if (memq 'deleted style)
+			       '(deleted)
+			       null)))
+
+      (private-field
+       [tabs (make-object tab-group% #f choices this (lambda (c e) (callback this e)) 
+			  (if (memq 'no-border style)
+			      null
+			      '(border))
+			  font)])
+      (sequence
+	(send (mred->wx this) set-first-child-is-hidden))
+
+      (private-field
+       [save-choices (map string->immutable-string choices)]
+       [hidden-tabs? #f])
+
+      (public
+	[get-number (lambda () (length save-choices))]
+	[append (entry-point
+		 (lambda (n) 
+		   (check-label-string '(method tab-panel% append) n)
+		   (let ([n (string->immutable-string n)])
+		     (set! save-choices (list-append save-choices (list n)))
+		     (send (mred->wx tabs) append n))))]
+	[get-selection (lambda () (and (pair? save-choices)
+				       (send (mred->wx tabs) get-selection)))]
+	[set-selection (entry-point
+			(lambda (i)
+			  (check-item 'set-selection i)
+			  (send (mred->wx tabs) set-selection i)))]
+	[delete (entry-point
+		 (lambda (i)
+		   (check-item 'delete i)
+		   (set! save-choices (let loop ([p 0][l save-choices])
+					(if (= p i)
+					    (cdr l)
+					    (cons (car l) (loop (add1 p) (cdr l))))))
+		   (send (mred->wx tabs) delete i)))]
+	[set-item-label (entry-point
+			 (lambda (i s)
+			   (check-item 'set-item-label i)
+			   (check-label-string '(method tab-panel% set-item-label) s)
+			   (let ([s (string->immutable-string s)])
+			     (set-car! (list-tail save-choices i) s)
+			     (send (mred->wx tabs) set-label i s))))]
+	[set
+	 (entry-point (lambda (l) 
+			(unless (and (list? l) (andmap label-string? l))
+			  (raise-type-error (who->name '(method tab-panel% set)) 
+					    "list of strings (up to 200 characters)" l))
+			(set! save-choices (map string->immutable-string l))
+			(send (mred->wx tabs) set l)))]
+	[get-item-label (entry-point
+			 (lambda (i)
+			   (check-item 'get-item-label i)
+			   (list-ref save-choices i)))])
+      
+      (private
+	[check-item
+	 (lambda (method n)
+	   (check-non-negative-integer `(method tab-panel% ,method) n)
+	   (let ([m (length save-choices)])
+	     (unless (< n m)
+	       (raise-mismatch-error (who->name `(method tab-panel% ,method)) 
+				     (if (zero? m)
+					 "panel has no tabs; given index: " 
+					 (format "panel has only ~a tabs, indexed 0 to ~a; given out-of-range index: " 
+						 m (sub1 m)))
+				     n))))])))
+
+
+  (define group-box-panel%
+    (class100*/kw vertical-panel% ()
+		  [(label parent [style null] [font no-val]) panel%-keywords]
+      (sequence
+	(let ([cwho '(constructor group-box-panel)])
+	  (check-label-string cwho label)
+	  (check-container-parent cwho parent)
+	  (check-style cwho #f '(deleted) style)
+	  (check-font cwho font))
+
+	;; Technically a bad way to change margin defaults, since it's
+	;;  implemented with an update after creation:
+	(when (eq? horiz-margin no-val) (set! horiz-margin 2))
+	(when (eq? vert-margin no-val) (set! vert-margin 2))
+
+	(super-init parent (if (memq 'deleted style)
+			       '(deleted)
+			       null)))
+
+      (private-field
+       [gbox (make-object group-box% label this null font)]
+       [lbl label])
+      (sequence
+	(send (mred->wx this) set-first-child-is-hidden))
+
+      (override
+	[set-label (entry-point
+		    (lambda (s)
+		      (check-label-string '(method group-box-panel% set-label) s)
+		      (set! lbl (if (immutable? s)
+				    s
+				    (string->immutable-string s)))
+		      (send gbox set-label s)))]
+	[get-label (lambda () lbl)]))))
diff --git a/collects/mred/private/mrpopup.ss b/collects/mred/private/mrpopup.ss
new file mode 100644
index 0000000000..dfa3d2ffbf
--- /dev/null
+++ b/collects/mred/private/mrpopup.ss
@@ -0,0 +1,66 @@
+(module mrpopup mzscheme
+  (require (lib "class.ss")
+	   (lib "class100.ss")
+	   (lib "list.ss")
+	   (prefix wx: "kernel.ss")
+	   "lock.ss"
+	   "const.ss"
+	   "helper.ss"
+	   "check.ss"
+	   "wx.ss"
+	   "wxmenu.ss"
+	   "mrmenuintf.ss")
+
+  (provide popup-menu%)
+
+  (define popup-menu%
+    (class100* mred% (menu-item-container<%> internal-menu<%>) ([title #f][popdown-callback void][demand-callback void][font no-val])
+      (private-field 
+       [callback demand-callback])
+      (public
+	[get-popup-target
+	 (lambda ()
+	   (send wx get-popup-grabber))]
+	[get-items (entry-point (lambda () (send wx get-items)))]
+	[on-demand (lambda ()
+		     (callback this)
+		     (for-each
+		      (lambda (i) 
+			(when (is-a? i labelled-menu-item<%>)
+			  (send i on-demand)))
+		      (send wx get-items)))]
+	[set-min-width (lambda (n)
+			 (check-range-integer '(method popup-menu% set-min-width) n)
+			 (send wx set-width n))]
+	[get-font (lambda ()
+		    (send wx get-font))])
+      (private-field
+       [wx #f])
+      (sequence
+	(let ([cwho '(constructor popup-menu)])
+	  (check-label-string/false cwho title)
+	  (check-callback cwho popdown-callback)
+	  (check-callback1 cwho demand-callback)
+	  (check-font cwho font))
+	(as-entry 
+	 (lambda ()
+	   (set! wx (make-object wx-menu% this title
+				 (lambda (mwx e)
+				   (let ([go
+					  (lambda ()
+					    (let ([wx (wx:id-to-menu-item (send e get-menu-id))])
+					      (when wx
+						(send (wx->mred wx) command (make-object wx:control-event% 'menu)))
+					      (dynamic-wind
+						  void
+						  (lambda ()
+						    (popdown-callback this (make-object wx:control-event% 
+											(if wx 
+											    'menu-popdown
+											    'menu-popdown-none))))
+						  (lambda () (send mwx popup-release)))))])
+				     (if (eq? 'windows (system-type))
+					 (wx:queue-callback go wx:middle-queue-key)
+					 (go))))
+				 (no-val->#f font)))
+	   (super-init wx)))))))
diff --git a/collects/mred/private/mrtabgroup.ss b/collects/mred/private/mrtabgroup.ss
new file mode 100644
index 0000000000..2483e1418b
--- /dev/null
+++ b/collects/mred/private/mrtabgroup.ss
@@ -0,0 +1,39 @@
+(module mrtabgroup mzscheme
+  (require (lib "class.ss")
+	   (lib "class100.ss")
+	   (prefix wx: "kernel.ss")
+	   "lock.ss"
+	   "const.ss"
+	   "check.ss"
+	   "helper.ss"
+	   "wx.ss"
+	   "wxtabgroup.ss"
+	   "mritem.ss")
+
+  (provide (protect tab-group%))
+
+  ;; Not exported from MrEd:
+  (define tab-group%
+    (class100 basic-control% (label choices parent callback [style null] [font #f])
+      (override
+	[hidden-child? (lambda () #t)])
+      (sequence
+	(let ([cwho '(constructor tab-group)])
+	  (check-list-control-args cwho label choices parent callback)
+	  (check-style cwho #f '(deleted border) style))
+	(super-init (lambda () (make-object (if (and (eq? 'macosx (system-type))
+						     (not (memq 'border style)))
+						canvas-based-tab-group%
+						wx-tab-group%)
+					    this this
+					    style
+					    (mred->wx-container parent)
+					    (wrap-callback callback)
+					    label
+					    choices
+					    style
+					    (no-val->#f font)))
+		    (lambda ()
+		      (let ([cwho '(constructor tab-group)])
+			(check-container-ready cwho parent)))
+		    label parent callback #f)))))
diff --git a/collects/mred/private/mrtextfield.ss b/collects/mred/private/mrtextfield.ss
new file mode 100644
index 0000000000..2769a55f99
--- /dev/null
+++ b/collects/mred/private/mrtextfield.ss
@@ -0,0 +1,128 @@
+(module mrtextfield mzscheme
+  (require (lib "class.ss")
+	   (lib "class100.ss")
+	   (lib "list.ss")
+	   (prefix wx: "kernel.ss")
+	   "lock.ss"
+	   "const.ss"
+	   "check.ss"
+	   "helper.ss"
+	   "wx.ss"
+	   "kw.ss"
+	   "wxtextfield.ss"
+	   "mrcontainer.ss"
+	   "mritem.ss"
+	   "mrmenu.ss"
+	   "mrpopup.ss")
+
+  (provide text-field%
+	   combo-field%)
+
+  (define combo-flag (gensym))
+
+  (define (check-text-field-args cwho
+				 label
+				 choices? choices
+				 parent
+				 callback
+				 init-value
+				 style req-styles
+				 font)
+    (check-label-string/false cwho label)
+    (when choices?
+      (unless (and (list? choices) (andmap label-string? choices))
+	(raise-type-error (who->name cwho) "list of strings (up to 200 characters)" choices)))
+    (check-container-parent cwho parent)
+    (check-callback cwho callback)
+    (check-string cwho init-value)
+    (check-style cwho 
+		 req-styles 
+		 (append
+		  (if choices? null '(hscroll password))
+		  '(vertical-label horizontal-label deleted))
+		 (remq combo-flag style))
+    (check-font cwho font))
+
+  (define text-field%
+    (class100*/kw basic-control% () 
+		  [(label parent [callback (lambda (b e) (void))] [init-value ""] [style '(single)])
+		   control%-keywords]
+      (sequence 
+	(check-text-field-args '(constructor text-field)
+			       label 
+			       #f #f
+			       parent callback init-value
+			       style '(single multiple)
+			       font))
+      (private-field
+       [wx #f])
+      (public
+	[get-editor (entry-point (lambda () (send wx get-editor)))]
+	[get-value (lambda () (send wx get-value))] ; note: wx method doesn't expect as-entry
+	[set-value (entry-point 
+		    (lambda (v) 
+		      (check-string '(method text-control<%> set-value) v)
+		      (send wx set-value v)))])
+      (sequence
+	;; Technically a bad way to change margin defaults, since it's
+	;;  implemented with an update after creation:
+	(when (eq? horiz-margin no-val) (set! horiz-margin 2))
+	(when (eq? vert-margin no-val) (set! vert-margin 2))
+	(as-entry
+	 (lambda ()
+	   (super-init (lambda () 
+			 (set! wx (make-object wx-text-field% this this
+					       (mred->wx-container parent) (wrap-callback callback)
+					       label init-value 
+					       (if (memq combo-flag style)
+						   (cons 'combo (remq combo-flag style))
+						   style)
+					       (no-val->#f font)))
+			 wx)
+		       (lambda ()
+			 (let ([cwho '(constructor text-field)])
+			   (check-container-ready cwho parent)))
+		       label parent callback ibeam))))))
+
+  (define combo-field%
+    (class100*/kw text-field% () 
+		  [(label choices parent [callback (lambda (b e) (void))] [init-value ""] [style '()])
+		   control%-keywords]
+      (inherit set-value popup-menu get-size focus get-editor)
+      (sequence 
+	(check-text-field-args '(constructor combo-field)
+			       label 
+			       #f choices
+			       parent callback init-value
+			       style #f 
+			       font))
+      (public
+	[on-popup (lambda (e)
+		    (let-values ([(w h) (get-size)]
+				 [(cw) (send (mred->wx this) get-canvas-width)])
+		      (send menu set-min-width cw)
+		      (popup-menu menu (- w cw) h)))]
+	[get-menu (lambda () menu)]
+	[append (lambda (item)
+		  (check-label-string '(method combo-field% append) item)
+		  (make-object menu-item% item menu 
+			       (lambda (i e)
+				 (focus)
+				 (set-value item)
+				 (let ([e (get-editor)])
+				   (send e set-position 0 (send e last-position))))))])
+      (override
+	[on-subwindow-event (lambda (w e)
+			      (and (send e button-down?)
+				   (let-values ([(cw) (send (mred->wx this) get-canvas-width)])
+				     (and ((send e get-x) . >= . (- cw side-combo-width))
+					  (begin
+					    (on-popup e)
+					    #t)))))])
+      (private-field
+       [menu (new popup-menu% [font font])])
+      (sequence
+	(for-each (lambda (item) 
+		    (append item))
+		  choices)
+	(super-init label parent callback init-value (list* combo-flag 'single style))))))
diff --git a/collects/mred/private/mrtop.ss b/collects/mred/private/mrtop.ss
new file mode 100644
index 0000000000..f7287d9dbf
--- /dev/null
+++ b/collects/mred/private/mrtop.ss
@@ -0,0 +1,274 @@
+(module mrtop mzscheme
+  (require (lib "class.ss")
+	   (lib "class100.ss")
+	   (lib "etc.ss")
+	   (lib "list.ss")
+	   (prefix wx: "kernel.ss")
+	   "lock.ss"
+	   "helper.ss"
+	   "const.ss"
+	   "kw.ss"
+	   "check.ss"
+	   "wx.ss"
+	   "wxtop.ss"
+	   "wxpanel.ss"
+	   "mrwindow.ss"
+	   "mrcontainer.ss")
+
+  (provide top-level-window<%>
+	   frame%
+	   dialog%
+	   (protect root-menu-frame
+		    set-root-menu-frame!)
+	   get-top-level-windows
+	   get-top-level-focus-window
+	   get-top-level-edit-target-window
+	   send-message-to-window
+	   (protect check-top-level-parent/false
+		    check-frame-parent/false))
+
+  (define top-level-window<%>
+    (interface (area-container-window<%>)
+      get-eventspace
+      on-activate on-traverse-char on-system-menu-char
+      can-close? on-close
+      can-exit? on-exit
+      get-focus-window get-edit-target-window
+      get-focus-object get-edit-target-object
+      center move resize
+      on-message))
+
+  (define-keywords top-level-window%-keywords
+    window%-keywords container%-keywords area%-keywords)
+
+  (define basic-top-level-window%
+    (class100* (make-area-container-window% (make-window% #t (make-container% area%))) (top-level-window<%>) 
+	       (mk-wx mismatches label parent)
+      (inherit show)
+      (rename [super-set-label set-label])
+      (private
+	[wx-object->proxy
+	 (lambda (o)
+	   (if (is-a? o wx:window%)
+	       (wx->proxy o)
+	       o))])
+      (override
+	[set-label (entry-point
+		    (lambda (l)
+		      (check-label-string/false '(method top-level-window<%> set-label) l)
+		      (send wx set-title (or l ""))
+		      (super-set-label l)))])
+      (public
+	[on-traverse-char (entry-point
+			   (lambda (e)
+			     (check-instance '(method top-level-window<%> on-traverse-char)
+					     wx:key-event% 'key-event% #f e)
+			     (send wx handle-traverse-key e)))]
+	[on-system-menu-char (entry-point
+			      (lambda (e)
+				(check-instance '(method top-level-window<%> on-system-menu-char) 
+						wx:key-event% 'key-event% #f e)
+				(and (eq? #\space (send e get-key-code))
+				     (send e get-meta-down)
+				     (eq? 'windows (system-type))
+				     (send wx system-menu) #t)))]
+	[get-eventspace (entry-point (lambda () (send wx get-eventspace)))])
+      (pubment
+	[can-close? (lambda () (inner #t can-close?))]
+	[on-close (lambda () (inner (void) on-close))])
+      (public
+	[can-exit? (lambda () (can-close?))]
+	[on-exit (lambda () (on-close) (show #f))]
+	[on-activate (lambda (x) (void))]
+	[center (entry-point
+		 (case-lambda
+		  [() (send wx center 'both)]
+		  [(dir) (send wx center dir)]))]
+	[move (entry-point
+	       (lambda (x y)
+		 (check-slider-integer '(method top-level-window<%> move) x)
+		 (check-slider-integer '(method top-level-window<%> move) y)
+		 (send wx move x y)))]
+	[resize (entry-point
+		 (lambda (w h)
+		   (check-range-integer '(method top-level-window<%> resize) w)
+		   (check-range-integer '(method top-level-window<%> resize) h)
+		   (send wx set-size -1 -1 w h)))]
+
+	[get-focus-window (entry-point
+			   (lambda () (let ([w (send wx get-focus-window)])
+					(and w (wx->proxy w)))))]
+	[get-edit-target-window (entry-point
+				 (lambda () (let ([w (send wx get-edit-target-window)])
+					      (and w (wx->proxy w)))))]
+	[get-focus-object (entry-point
+			   (lambda () (let ([o (send wx get-focus-object)])
+					(and o (wx-object->proxy o)))))]
+	[get-edit-target-object (entry-point
+				 (lambda () (let ([o (send wx get-edit-target-object)])
+					      (and o (wx-object->proxy o)))))]
+
+	[on-message (lambda (m) (void))])
+      (private-field
+       [wx #f]
+       [wx-panel #f]
+       [finish (entry-point
+		(lambda (top-level hide-panel?)
+		  (set! wx-panel (make-object wx-vertical-panel% #f this top-level null))
+		  (send (send wx-panel area-parent) add-child wx-panel)
+		  (send top-level set-container wx-panel)
+		  (when hide-panel?
+		    (send wx-panel show #f))
+		  top-level))])
+      (sequence 
+	(super-init (lambda () (set! wx (mk-wx finish)) wx) (lambda () wx-panel) mismatches label parent arrow-cursor))))
+
+
+  (define frame%
+    (class100*/kw basic-top-level-window% ()
+		  [(label [parent #f] [width #f] [height #f] [x #f] [y #f] [style null])
+		   top-level-window%-keywords]
+      (inherit on-traverse-char on-system-menu-char)
+      (sequence
+	(let ([cwho '(constructor frame)])
+	  (check-label-string cwho label)
+	  (check-frame-parent/false cwho parent)
+	  (check-dimension cwho width)
+	  (check-dimension cwho height)
+	  (check-init-pos-integer cwho x)
+	  (check-init-pos-integer cwho y)
+	  (check-style cwho #f '(no-resize-border no-caption no-system-menu mdi-parent mdi-child toolbar-button hide-menu-bar float metal) 
+		       style)
+	  (when (memq 'mdi-child style)
+	    (when (memq 'mdi-parent style)
+	      (raise-type-error (who->name cwho) 
+				"style list, 'mdi-child and 'mdi-parent are mutually exclusive" 
+				style)))))
+      (rename [super-on-subwindow-char on-subwindow-char])
+      (private-field
+       [wx #f]
+       [status-line? #f]
+       [modified? #f])
+      (override
+	[on-subwindow-char (lambda (w event)
+			     (super-on-subwindow-char w event)
+			     (or (on-menu-char event)
+				 (on-system-menu-char event)
+				 (on-traverse-char event)))])
+      (public
+	[on-menu-char (entry-point
+		       (lambda (e)
+			 (check-instance '(method frame% on-menu-char) wx:key-event% 'key-event% #f e)
+			 (send wx handle-menu-key e)))]
+	[on-toolbar-button-click (lambda () (void))]
+	[create-status-line (entry-point (lambda () (unless status-line? (send wx create-status-line) (set! status-line? #t))))]
+	[set-status-text (lambda (s) (send wx set-status-text s))]
+	[has-status-line? (lambda () status-line?)]
+	[iconize (entry-point (lambda (on?) (send wx iconize on?)))]
+	[is-iconized? (entry-point (lambda () (send wx iconized?)))]
+	[set-icon (case-lambda 
+		   [(i) (send wx set-icon i)]
+		   [(i b) (send wx set-icon i b)]
+		   [(i b l?) (send wx set-icon i b l?)])]
+	[maximize (entry-point (lambda (on?) (send wx maximize on?)))]
+	[get-menu-bar (entry-point (lambda () (let ([mb (send wx get-the-menu-bar)])
+						(and mb (wx->mred mb)))))]
+	[modified (entry-point
+		   (case-lambda
+		    [() modified?]
+		    [(m) 
+		     (set! modified? m)
+		     (send wx set-modified m)]))])
+      (sequence
+	(as-entry
+	 (lambda ()
+	   (super-init 
+	    (lambda (finish) 
+	      (set! wx (finish (make-object wx-frame% this this
+					    (and parent (mred->wx parent)) label
+					    (or x -11111) (or y -11111)
+					    (or width -1) (or height -1)
+					    style)
+			       (memq 'mdi-parent style)))
+	      (send wx set-mdi-parent (memq 'mdi-parent style))
+	      wx)
+	    (lambda ()
+	      (let ([cwho '(constructor frame)])
+		(check-container-ready cwho parent)
+		(when (memq 'mdi-child style)
+		  (let ([pwx (and parent (mred->wx parent))])
+		    (unless (and pwx (send pwx get-mdi-parent))
+		      (raise-mismatch-error (who->name cwho) "parent for 'mdi-child frame is not an 'mdi-parent frame: " parent))))))
+	    label parent))))))
+
+  (define dialog%
+    (class100*/kw basic-top-level-window% ()
+		  [(label [parent #f] [width #f] [height #f] [x #f] [y #f] [style null])
+		   top-level-window%-keywords]
+      (inherit on-traverse-char on-system-menu-char)
+      (sequence
+	(let ([cwho '(constructor dialog)])
+	  (check-label-string cwho label)
+	  (check-top-level-parent/false cwho parent)
+	  (for-each (lambda (x) (check-dimension cwho x)) (list width height x y))
+	  (check-style cwho #f '(no-caption resize-border) style)))
+      (rename [super-on-subwindow-char on-subwindow-char])
+      (private-field [wx #f])
+      (override
+	[on-subwindow-char (lambda (w event)
+			     (super-on-subwindow-char w event)
+			     (or (on-system-menu-char event)
+				 (on-traverse-char event)))])
+      (sequence
+	(as-entry
+	 (lambda ()
+	   (super-init (lambda (finish) 
+			 (set! wx (finish (make-object wx-dialog% this this
+						       (and parent (mred->wx parent)) label #t
+						       (or x -1) (or y -1) (or width 0) (or height 0)
+						       style)
+					  #f))
+			 wx)
+		       (lambda () 
+			 (let ([cwho '(constructor dialog)])
+			   (check-container-ready cwho parent)))
+		       label parent))))))
+
+  (define root-menu-frame #f)
+  (define (set-root-menu-frame! f) (set! root-menu-frame f))
+  
+  (define (get-top-level-windows)
+    (remq root-menu-frame (map wx->mred (wx:get-top-level-windows))))
+
+  (define (get-top-level-focus-window)
+    (ormap (lambda (f) (and (send f is-act-on?) (wx->mred f))) (wx:get-top-level-windows)))
+
+  (define (get-top-level-edit-target-window)
+    (let loop ([l (wx:get-top-level-windows)][f #f][s 0][ms 0])
+      (if (null? l)
+	  (and f (wx->mred f))
+	  (let* ([f2 (car l)]
+		 [s2 (send f2 get-act-date/seconds)]
+		 [ms2 (send f2 get-act-date/milliseconds)])
+	    (if (or (not f)
+		    (> s2 s)
+		    (and (= s2 s) (> ms2 ms)))
+		(loop (cdr l) f2 s2 ms2)
+		(loop (cdr l) f s ms))))))
+
+  (define (send-message-to-window x y m)
+    (check-slider-integer 'send-message-to-window x)
+    (check-slider-integer 'send-message-to-window y)
+    (let ([w (wx:location->window x y)])
+      (and w (let ([f (wx->proxy w)])
+	       (and f 
+		    (not (eq? f root-menu-frame))
+		    (send f on-message m))))))
+
+  (define (check-top-level-parent/false who p)
+    (unless (or (not p) (is-a? p frame%) (is-a? p dialog%))
+      (raise-type-error (who->name who) "frame% or dialog% object or #f" p)))
+
+  (define (check-frame-parent/false who p)
+    (unless (or (not p) (is-a? p frame%))
+      (raise-type-error (who->name who) "frame% object or #f" p))))
diff --git a/collects/mred/private/mrwindow.ss b/collects/mred/private/mrwindow.ss
new file mode 100644
index 0000000000..63b466d957
--- /dev/null
+++ b/collects/mred/private/mrwindow.ss
@@ -0,0 +1,232 @@
+(module mrwindow mzscheme
+  (require (lib "class.ss")
+	   (lib "class100.ss")
+	   (prefix wx: "kernel.ss")
+	   "lock.ss"
+	   "helper.ss"
+	   "const.ss"
+	   "check.ss"
+	   "wx.ss"
+	   "kw.ss"
+	   "wxwindow.ss"
+	   "mrpopup.ss")
+
+  (provide area<%>
+	   (protect area%-keywords)
+	   area%
+	   (protect internal-subarea<%>)
+	   subarea<%>
+	   (protect subarea%-keywords
+		    make-subarea%)
+	   window<%>
+	   (protect window%-keywords)
+	   subwindow<%>
+	   (protect make-window%))
+
+  (define area<%>
+    (interface ()
+      get-parent get-top-level-window
+      min-width min-height
+      get-graphical-min-size
+      stretchable-width stretchable-height))
+
+  (define-keywords area%-keywords 
+    [min-width no-val]
+    [min-height no-val]
+    [stretchable-width no-val]
+    [stretchable-height no-val])
+
+  (define area%
+    (class100* mred% (area<%>) (mk-wx get-wx-pan mismatches prnt
+				      ;; for keyword use:
+				      [min-width no-val]
+				      [min-height no-val]
+				      [stretchable-width no-val]
+				      [stretchable-height no-val])
+      (sequence
+	(let ([cwho '(iconstructor area)])
+	  (unless (eq? min-width no-val) (check-non#f-dimension cwho min-width))
+	  (unless (eq? min-height no-val) (check-non#f-dimension cwho min-height)))
+	(mismatches))
+      (private-field 
+       [get-wx-panel get-wx-pan]
+       [parent prnt])
+      (public
+	[get-parent (lambda () parent)]
+	[get-top-level-window (entry-point (lambda () (wx->mred (send wx get-top-level))))]
+	[(minw min-width) (param get-wx-panel min-width)]
+	[(minh min-height) (param get-wx-panel min-height)]
+	[(sw stretchable-width) (param get-wx-panel stretchable-in-x)]
+	[(sh stretchable-height) (param get-wx-panel stretchable-in-y)]
+	[get-graphical-min-size (entry-point (lambda () 
+					       (if (wx . is-a? . wx-basic-panel<%>)
+						   (apply values (send wx get-graphical-min-size))
+						   (send wx get-hard-minimum-size))))])
+      (private-field
+       [wx (mk-wx)])
+      (sequence
+	(super-init wx)
+	(unless (eq? min-width no-val) (minw min-width))
+	(unless (eq? min-height no-val) (minh min-height))
+	(unless (eq? stretchable-width no-val) (sw stretchable-width))
+	(unless (eq? stretchable-height no-val) (sh stretchable-height)))))
+
+  (define internal-subarea<%> (interface ()))
+
+  (define subarea<%> 
+    (interface (area<%> internal-subarea<%>)
+      horiz-margin vert-margin))
+
+  (define-keywords subarea%-keywords
+    [horiz-margin no-val]
+    [vert-margin no-val])
+
+  (define (make-subarea% %) ; % implements area<%>
+    (class100* % (subarea<%>) (mk-wx get-wx-pan mismatches parent
+				     ;; for keyword use
+				     [horiz-margin no-val]
+				     [vert-margin no-val])
+      (sequence
+	(let ([cwho '(iconstructor subarea)])
+	  (unless (eq? horiz-margin no-val) (check-margin-integer cwho horiz-margin))
+	  (unless (eq? vert-margin no-val) (check-margin-integer cwho vert-margin))))
+      (private-field [get-wx-panel get-wx-pan])
+      (public
+	[(hm horiz-margin) (param get-wx-panel x-margin)]
+	[(vm vert-margin) (param get-wx-panel y-margin)])
+      (sequence 
+	(super-init mk-wx get-wx-panel mismatches parent)
+	(unless (eq? horiz-margin no-val) (hm horiz-margin))
+	(unless (eq? vert-margin no-val) (vm vert-margin)))))
+
+  (define window<%>
+    (interface (area<%>)
+      on-focus focus has-focus?
+      on-size on-move
+      accept-drop-files on-drop-file
+      on-subwindow-char on-subwindow-event
+      client->screen screen->client
+      enable is-enabled? on-superwindow-enable
+      get-label set-label get-plain-label
+      get-client-size get-size get-width get-height get-x get-y
+      get-cursor set-cursor popup-menu
+      show is-shown? on-superwindow-show refresh
+      get-handle))
+
+  (define-keywords window%-keywords [enabled #t])
+
+  (define subwindow<%> 
+    (interface (window<%> subarea<%>)))
+
+  (define (make-window% top? %) ; % implements area<%>
+    (class100* % (window<%>) (mk-wx get-wx-panel mismatches lbl parent crsr
+				    ;; for keyword use
+				    [enabled #t])
+      (private-field [label lbl][cursor crsr])
+      (public
+	[popup-menu (entry-point 
+		     (lambda (m x y)
+		       (check-instance '(method window<%> popup-menu) popup-menu% 'popup-menu% #f m)
+		       (check-range-integer '(method window<%> popup-menu) x)
+		       (check-range-integer '(method window<%> popup-menu) y)
+		       (let ([mwx (mred->wx m)])
+			 (and (send mwx popup-grab this)
+			      (as-exit
+			       (lambda ()
+				 (send m on-demand)
+				 (send wx popup-menu mwx x y)))))))]
+	[on-focus (lambda (x) (void))]
+	[on-size (lambda (w h)
+		   (check-range-integer '(method window<%> on-size) w)
+		   (check-range-integer '(method window<%> on-size) h))]
+	[on-move (lambda (x y)
+		   (check-slider-integer '(method window<%> on-move) x)
+		   (check-slider-integer '(method window<%> on-move) y))]
+	[on-subwindow-char (lambda (w e)
+			     (check-instance '(method window<%> on-subwindow-char) window<%> 'window<%> #f w)
+			     (check-instance '(method window<%> on-subwindow-char) wx:key-event% 'key-event% #f e)
+			     #f)]
+	[on-subwindow-event (lambda (w e)
+			      (check-instance '(method window<%> on-subwindow-event) window<%> 'window<%> #f w)
+			      (check-instance '(method window<%> on-subwindow-event) wx:mouse-event% 'mouse-event% #f e)
+			      #f)]
+	[on-drop-file (lambda (s)
+			(unless (path-string? s)
+			  (raise-type-error (who->name '(method window<%> on-drop-file)) "pathname string" s)))]
+
+	[focus (entry-point (lambda () (send wx set-focus)))]
+	[has-focus? (entry-point (lambda () (send wx has-focus?)))]
+	[enable (entry-point (lambda (on?) (send wx enable on?)))]
+	[is-enabled? (entry-point (lambda () (send wx is-enabled?)))]
+	
+	[get-label (lambda () label)]
+	[set-label (lambda (l)
+		     (check-label-string/false '(method window<%> set-label) l)
+		     (set! label (if (string? l)
+				     (string->immutable-string l)
+				     l)))]
+	[get-plain-label (lambda () (and (string? label) (wx:label->plain-label label)))]
+
+	[get-handle (lambda () (send wx get-handle))]
+
+	[accept-drop-files
+	 (entry-point
+	  (case-lambda
+	   [() (send wx accept-drag?)]
+	   [(on?) (send wx drag-accept-files on?)]))]
+	
+	[client->screen (entry-point
+			 (lambda (x y)
+			   (check-slider-integer '(method window<%> client->screen) x)
+			   (check-slider-integer '(method window<%> client->screen) y)
+			   (double-boxed
+			    x y
+			    (lambda (x y) (send wx client-to-screen x y)))))]
+	[screen->client (entry-point
+			 (lambda (x y)
+			   (check-slider-integer '(method window<%> screen->client) x)
+			   (check-slider-integer '(method window<%> screen->client) y)
+			   (double-boxed
+			    x y
+			    (lambda (x y) (send wx screen-to-client x y)))))]
+	[get-client-size (entry-point
+			  (lambda ()
+			    (double-boxed
+			     0 0
+			     (lambda (x y) (send wx get-client-size x y)))))]
+	[get-size (entry-point
+		   (lambda ()
+		     (double-boxed
+		      0 0
+		      (lambda (x y) (send wx get-size x y)))))]
+	
+	[get-width (entry-point (lambda () (send wx get-width)))]
+	[get-height (entry-point (lambda () (send wx get-height)))]
+	[get-x (entry-point (lambda () (- (send wx get-x) (if top? 0 (send (send wx get-parent) ext-dx)))))]
+	[get-y (entry-point (lambda () (- (send wx get-y) (if top? 0 (send (send wx get-parent) ext-dy)))))]
+	
+	[get-cursor (lambda () cursor)]
+	[set-cursor (entry-point
+		     (lambda (x)
+		       (send wx set-cursor x)
+		       (set! cursor x)))]
+
+	[show (entry-point (lambda (on?) 
+			     (when on?
+			       (unless top?
+				 (unless (memq wx (send (send wx area-parent) get-children))
+				   (raise-mismatch-error 
+				    (who->name '(method window<%> show))
+				    "cannot show a subwindow that is not active in its parent: "
+				    this))))
+			     (send wx show on?)))]
+	[is-shown? (entry-point (lambda () (send wx is-shown?)))]
+	[on-superwindow-show (lambda (visible?) (void))]
+	[on-superwindow-enable (lambda (active?) (void))]
+
+	[refresh (entry-point (lambda () (send wx refresh)))])
+      (private-field
+       [wx #f])
+      (sequence
+	(super-init (lambda () (set! wx (mk-wx)) wx) get-wx-panel mismatches parent)
+	(unless enabled (enable #f))))))
diff --git a/collects/mred/private/repl.ss b/collects/mred/private/repl.ss
new file mode 100644
index 0000000000..b9476bfbb7
--- /dev/null
+++ b/collects/mred/private/repl.ss
@@ -0,0 +1,179 @@
+(module repl mzscheme
+  (require (lib "class.ss")
+	   (lib "class100.ss")
+	   (prefix wx: "kernel.ss")
+	   "editor.ss"
+	   "app.ss"
+	   "mrtop.ss"
+	   "mrcanvas.ss"
+	   "mrmenu.ss"
+	   "filedialog.ss")
+
+  (provide graphical-read-eval-print-loop)
+
+  (define (-graphical-read-eval-print-loop user-esp override-ports?)
+    ;; The REPL buffer class
+    (define esq:text%
+      (class100 text% ()
+	(inherit insert last-position get-text erase change-style clear-undos)
+	(rename [super-on-char on-char])
+	(private-field [prompt-pos 0] [locked? #f])
+	(augment
+	 [can-insert? (lambda (start end) (and (>= start prompt-pos) (not locked?)))]
+	 [can-delete? (lambda (start end) (and (>= start prompt-pos) (not locked?)))])
+	(override
+	  [on-char (lambda (c)
+		     (super-on-char c)
+		     (when (and (memq (send c get-key-code) '(#\return #\newline #\003))
+				(not locked?))
+		       (set! locked? #t)
+		       (evaluate (get-text prompt-pos (last-position)))))])
+	(public
+	  [new-prompt (lambda ()
+			(output "> ")
+			(set! prompt-pos (last-position))
+			(set! locked? #f)
+			(clear-undos))]
+	  [output (lambda (str)
+		    (let ([l? locked?])
+		      (set! locked? #f)
+		      (insert str)
+		      (set! locked? l?)))]
+	  [reset (lambda ()
+		   (set! locked? #f)
+		   (set! prompt-pos 0)
+		   (erase)
+		   (new-prompt))])
+	(sequence 
+	  (super-init)
+	  (let ([s (last-position)]
+		[m (regexp-match #rx"^(.*), (Copyright.*)$" (banner))])
+	    (insert (format "Welcome to ~a." (cadr m)))
+	    (let ([e (last-position)])
+	      (insert #\newline)
+	      (change-style (send (make-object wx:style-delta% 'change-bold) set-delta-foreground "BLUE") s e))
+	    (output (caddr m)))
+	  (insert "This is a simple window for evaluating MrEd Scheme expressions.") (insert #\newline)
+	  (let ([s (last-position)])
+	    (insert "Quit now and run DrScheme to get a better window.")
+	    (let ([e (last-position)])
+	      (insert #\newline)
+	      (change-style
+	       (send (make-object wx:style-delta% 'change-italic) set-delta-foreground "RED")
+	       s e)))
+	  (insert "The current input port always returns eof.") (insert #\newline)
+	  (new-prompt))))
+
+    ;; GUI creation
+    (define frame (make-object (class100 frame% args
+				 (inherit accept-drop-files)
+				 (augment
+				  [on-close (lambda () 
+					      (custodian-shutdown-all user-custodian)
+					      (semaphore-post waiting))])
+				 (override
+				   [on-drop-file (lambda (f) (evaluate (format "(load ~s)" (path->string f))))])
+				 (sequence 
+				   (apply super-init args) (accept-drop-files #t)))
+			       "MrEd REPL" #f 500 400))
+    (define repl-buffer (make-object esq:text%))
+    (define repl-display-canvas (new editor-canvas% [parent frame] [style '(no-border auto-hscroll resize-corner)]))
+
+    (define esq-eventspace (wx:current-eventspace))
+    (define (queue-output proc)
+      (parameterize ((wx:current-eventspace esq-eventspace))
+	(wx:queue-callback proc #f)))
+    
+    ;; User space initialization
+    (define user-custodian (make-custodian))
+    
+    (define user-output-port
+      (let ([leftover #""]
+	    [cvt (bytes-open-converter "UTF-8-permissive" "UTF-8")])
+	(make-output-port
+	 'console
+	 always-evt
+	 (lambda (s start end flush? breakable?) 
+	   (queue-output (lambda () 
+			   ;; s might end in the middle of a UTF-8 encoding.
+			   ;;  Get a complete prefix, and save the rest.
+			   (let ([s (bytes-append leftover (subbytes s start end))])
+			     (let-values ([(res used status) (bytes-convert cvt s)])
+			       (send repl-buffer output (bytes->string/utf-8 res))
+			       (set! leftover (subbytes s used))))))
+	   (- end start))
+	 void))) ; no close action
+    
+    (define user-eventspace
+      (or user-esp
+	  (parameterize ((current-custodian user-custodian))
+	    (wx:make-eventspace))))
+
+    ;; Evaluation
+    
+    (define (evaluate expr-str)
+      (parameterize ((wx:current-eventspace user-eventspace))
+	(wx:queue-callback
+	 (lambda ()
+	   (dynamic-wind
+	       void
+	       (lambda () 
+		 (call-with-values
+		     (lambda () (eval (read (open-input-string expr-str))))
+		   (lambda results
+		     (for-each 
+		      (lambda (v) 
+			(parameterize ([current-output-port user-output-port])
+			  (print v) 
+			  (newline)))
+		      results))))
+	       (lambda ()
+		 (queue-output (lambda () (send repl-buffer new-prompt)))))))))
+
+    (define waiting (make-semaphore 0))
+
+    (let ([mb (make-object menu-bar% frame)])
+      (let ([m (make-object menu% "&File" mb)])
+	(make-object menu-item% "Load File..." m (lambda (i e) (let ([f (get-file #f frame)]) 
+								 (and f 
+								      (evaluate (format "(load ~s)" (path->string f)))))))
+	(unless (current-eventspace-has-standard-menus?)
+	  (make-object menu-item% 
+		       (if (eq? (system-type) 'windows)
+			   "E&xit"
+			   "&Quit")
+		       m (lambda (i e) (send frame on-close) (send frame show #f)) #\q)))
+      (let ([m (make-object menu% "&Edit" mb)])
+	(append-editor-operation-menu-items m #f)))
+
+    ;; Just a few extra key bindings:
+    ((current-text-keymap-initializer) (send repl-buffer get-keymap))
+    (send repl-buffer auto-wrap #t)
+
+    ;; Go
+    (when override-ports?
+      (parameterize ((wx:current-eventspace user-eventspace))
+	(wx:queue-callback
+	 (lambda ()
+	   (current-output-port user-output-port)
+	   (current-error-port user-output-port)
+	   (current-input-port (open-input-bytes #"")))
+	 #t)))
+
+    (send repl-display-canvas set-editor repl-buffer)
+
+    (send frame show #t)
+    
+    (send repl-display-canvas focus)
+
+    (wx:yield waiting))
+
+  (define graphical-read-eval-print-loop
+    (case-lambda
+     [() (-graphical-read-eval-print-loop #f #t)]
+     [(esp)
+      (graphical-read-eval-print-loop esp (not esp))]
+     [(esp override-ports?)
+      (unless (or (not esp) (wx:eventspace? esp))
+	(raise-type-error 'graphical-read-eval-print-loop "eventspace or #f" esp))
+      (-graphical-read-eval-print-loop esp override-ports?)])))
diff --git a/collects/mred/private/seqcontract.ss b/collects/mred/private/seqcontract.ss
new file mode 100644
index 0000000000..4ca0aa68d6
--- /dev/null
+++ b/collects/mred/private/seqcontract.ss
@@ -0,0 +1,415 @@
+(module seqcontract mzscheme
+  (require (lib "class.ss"))
+  (provide (protect es-contract-mixin lock-contract-mixin))
+  
+  (require-for-syntax (lib "stx.ss" "syntax")
+                      (lib "boundmap.ss" "syntax"))
+
+  (define-syntax (sequence-contract-mixin stx)
+    (syntax-case stx (state-machine)
+      [(_ (state-machine
+           [name exp (method-name aritiess states ...) ...] ...)
+          clauses ...)
+       (and (andmap identifier? (syntax->list (syntax (name ...))))
+            (andmap (lambda (x) (andmap identifier? (syntax->list x)))
+                    (syntax->list (syntax ((method-name ...) ...))))
+            (andmap (lambda (xs) 
+                      (andmap (lambda (x) (andmap identifier? (syntax->list x)))
+                              (syntax->list xs)))
+                    (syntax->list (syntax (((states ...) ...) ...)))))
+       (let ()
+         (define state-names (syntax->list (syntax (name ...))))
+         (define predicate-names (generate-temporaries (syntax (name ...))))
+         
+         (define state-name->predicate-name
+           (let ([mapping (make-bound-identifier-mapping)])
+             (for-each (lambda (state-name predicate-name)
+                         (bound-identifier-mapping-put! mapping state-name predicate-name))
+                       state-names
+                       predicate-names)
+             (lambda (state-name)
+               (bound-identifier-mapping-get mapping state-name))))
+         
+         (define-struct state-desc (method-name arities predicate-name state-name result-predicates) (make-inspector))
+         
+         ;; -> mapping[state-name-symbol -o> state-desc]
+         (define (build-table)
+           (let ([mapping (new-mapping)])
+             (for-each 
+              (lambda (state-name-stx predicate-name-stx method-names aritiess state-namess)
+                (for-each
+                 (lambda (method-name arities state-names-stx)
+                   (extend-mapping/at-end
+                    mapping
+                    method-name
+                    (make-state-desc method-name
+                                     arities
+                                     predicate-name-stx
+                                     state-name-stx
+                                     (syntax->list state-names-stx))))
+                 (syntax->list method-names)
+                 (syntax->list aritiess)
+                 (syntax->list state-namess)))
+              (syntax->list (syntax (name ...)))
+              predicate-names
+              (syntax->list (syntax ((method-name ...) ...)))
+              (syntax->list (syntax ((aritiess ...) ...)))
+              (syntax->list (syntax (((states ...) ...) ...))))
+             mapping))
+         
+         (define (build-overriding-method mapping state-descs)
+           (with-syntax ([method-name (state-desc-method-name (car state-descs))]
+                         [super-method-name (build-super-name (state-desc-method-name (car state-descs)))]
+                         [(predicate-name ...) (map state-desc-predicate-name state-descs)]
+                         [(predicate-result-name ...)
+                          (generate-temporaries
+                           (map state-desc-predicate-name state-descs))]
+                         [(state-name ...) (map state-desc-state-name state-descs)]
+                         [((result-predicate-state ...) ...)
+                          (map state-desc-result-predicates state-descs)]
+                         [((result-predicate-name ...) ...)
+                          (map 
+                           (lambda (state-desc)
+                             (map state-name->predicate-name
+                                  (state-desc-result-predicates state-desc)))
+                           state-descs)])
+             (with-syntax ([(cases ...)
+                            (map (lambda (arity)
+                                   (with-syntax ([formals arity])
+                                     (with-syntax ([call (if (identifier? arity)
+                                                             (syntax (super-method-name . formals))
+                                                             (with-syntax ([(x ...) arity])
+                                                               (syntax (super-method-name x ...))))]
+                                                   [args-as-list
+                                                    (if (identifier? arity)
+                                                        arity
+                                                        (with-syntax ([(x ...) arity])
+                                                          (syntax (list x ...))))])
+                                       (syntax
+                                        [formals
+                                         (let ([predicate-result-name (predicate-name)] ...)
+                                           (cond
+                                             [predicate-result-name
+                                              call
+                                              
+                                              ;; Doesn't do post-condition checking,
+                                              ;; since it isn't thread safe
+                                              #;
+                                              (begin0
+                                                call
+                                                (unless (or (result-predicate-name) ...)
+                                                  (sequence-contract-violation 
+                                                   'positive 
+                                                   "expected one of states ~s after calling ~s in state ~s"
+                                                   '(result-predicate-state ...)
+                                                   'method-name
+                                                   'state-name)))
+                                              ]
+                                             ...
+                                             [else
+                                              (sequence-contract-violation 
+                                               'negative
+                                               "method ~s cannot be called, except in states ~s~a"
+                                               'method-name
+                                               '(state-name ...)
+                                               (format-args args-as-list))]))]))))
+                                 (syntax->list (state-desc-arities (car state-descs))))])
+               (syntax
+                (begin
+                  (rename-super [super-method-name method-name])
+                  (define/override method-name
+                    (case-lambda cases ...)))))))
+         
+         ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+         ;;
+         ;; finite mapping code
+         ;;
+         
+         (define (new-mapping) (make-hash-table))
+         (define (set-mapping mapping key-stx val)
+           (hash-table-put! mapping (syntax-e key-stx) val))
+         (define get-mapping
+           (case-lambda
+             [(mapping key-stx) (get-mapping mapping key-stx (lambda () (error 'get-mapping "ack!")))]
+             [(mapping key-stx fail)
+              (hash-table-get mapping (syntax-e key-stx) fail)]))
+         (define (extend-mapping/at-end mapping key-stx ele)
+           (set-mapping mapping key-stx 
+                        (append
+                         (get-mapping mapping key-stx (lambda () null))
+                         (list ele))))
+         (define (mapping-map f mapping)
+           (hash-table-map mapping f))
+         
+         ;;
+         ;;
+         ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+         
+         (define (build-super-name name)
+           (datum->syntax-object
+            name
+            (string->symbol
+             (format 
+              "super-~a"
+              (syntax-object->datum name)))))
+         
+         (define table (build-table))
+         (with-syntax ([(predicate-names ...) predicate-names]
+                       [(overriding-method ...) (mapping-map
+                                                 (lambda (k vs) (build-overriding-method table vs))
+                                                 table)])
+           
+           (syntax
+            (lambda (%)
+              (class* % ()
+                (define/private predicate-names (lambda () exp)) ...
+                overriding-method ... 
+                clauses ...)))))]))
+  
+  (define (format-args l)
+    (cond
+      [(null? l) ""]
+      [else
+       (string-append
+        ", args "
+        (let loop ([fst (car l)]
+                   [rst (cdr l)])
+          (cond
+            [(null? rst) (format "~e" fst)]
+            [else (string-append
+                   (format "~e" fst)
+                   " "
+                   (loop (car rst) (cdr rst)))])))]))
+
+  (define (sequence-contract-violation dir fmt . args)
+    (apply error
+           'sequence-contract-violation 
+           (string-append (format "~a: " dir) fmt)
+           args))
+
+  (define es-contract-mixin 
+    (sequence-contract-mixin
+     (state-machine
+      [in-edit-sequence
+       (in-edit-sequence?)
+       (begin-edit-sequence [() (x) (x y)] in-edit-sequence)
+       (end-edit-sequence [()] in-edit-sequence out-of-edit-sequence)]
+      [out-of-edit-sequence
+       (not (in-edit-sequence?))
+       (begin-edit-sequence [() (x) (x y)] in-edit-sequence)])
+     
+     (inherit in-edit-sequence?)
+     (super-new)))
+
+#|
+
+  (define (test t)
+    (send t begin-edit-sequence)
+    (send t end-edit-sequence)
+    (send t end-edit-sequence))
+  
+  (test (new text%))
+  (test (new (es-contract-mixin text%)))
+  
+Matthew writes:
+
+> Underscore tends to mean "internal". Many variants of
+> Insert(), for example, call the main _Insert() method.
+
+So, double check the methods to make sure that a flag check
+in an underscore method means the flag is checked in the
+non-underscore methods.
+
+At Sun, 29 Jun 2003 09:26:02 -0500, Robby Findler wrote:
+> Is there some kind of invariant or ordering on these
+> flags? That is, if a method only checks the flowLocked flag,
+> is that effectively the same as checking the flowLocked flag
+> or the writeLocked flag or something like that?
+
+Yes: readLocked => flowLocked, and flowLocked => writeLocked.
+
+Matthew
+
+  |#
+  
+  ;; need to figure out
+  ;; line-start-position and friends 
+  ;; (line-start-position not valid in readlock)
+  
+  (define lock-contract-mixin
+    (sequence-contract-mixin
+     (state-machine
+      [unlocked
+       (and (not (locked-for-write?))
+            (not (locked-for-flow?))
+            (not (locked-for-read?)))
+       (set-position [(x) (x y) (x y z) (x y z p) (x y z p q)] unlocked)
+       (set-autowrap-bitmap [(bitmap)] unlocked)
+       (print-to-dc [(dc)] unlocked)
+       (move-position [(code?) (code? extend) (code? extend kind)] unlocked)
+       (split-snip [(pos)] unlocked)
+       (set-line-spacing [(space)] unlocked)
+       (set-max-width [(width)] unlocked)
+       (set-min-width [(width)] unlocked)
+       (set-min-height [(width)] unlocked)
+       (set-max-height [(width)] unlocked)
+       (set-tabs [(tabs) (tabs tab-width) (tabs tab-width units?)] unlocked)
+       (print [()
+               (interactive?)
+               (interactive? fit-on-page?)
+               (interactive? fit-on-page? output-mode)
+               (interactive? fit-on-page? output-mode parent)
+               (interactive? fit-on-page? output-mode parent force-ps-page-bbox?)]
+              unlocked)
+       
+       (get-text [() (x) (x y) (x y z) (x y z p)] unlocked)
+       (get-character [(start)] unlocked)
+       (find-wordbreak [(start end reason)] unlocked)
+       (save-file [() (filename) (filename format) (filename format show-errors?)] unlocked)
+       (write-to-file [(stream) (stream start end)]  unlocked)
+       (find-position [(x y) (x y at-eol?) (x y at-eol? on-it?) (x y at-eol? on-it? edge-close?)] unlocked)
+       (scroll-line-location [(pos)] unlocked)
+       (num-scroll-lines [()] unlocked)
+       (find-scroll-line [(location)] unlocked)
+       (style-has-changed [(style)] unlocked)
+       
+       (change-style [(x) (x y) (x y z) (x y z w)] unlocked)
+       (insert [(x) (x y) (x y z) (x y z p) (x y z p q)] unlocked)
+       (delete [() (start) (start end) (start end scroll-ok?)] unlocked)
+       (insert-port [(port) (port format show-errors?)] unlocked)
+       (read-from-file [(x) (x y) (x y z)] unlocked)
+       (set-style-list [(style-list)] unlocked)]
+      
+      [write-lock
+       (and (locked-for-write?)
+            (not (locked-for-flow?))
+            (not (locked-for-read?)))
+
+       (set-position [(x) (x y) (x y z) (x y z p) (x y z p q)] write-lock)
+       (set-autowrap-bitmap [(bitmap)] write-lock)
+       (print-to-dc [(dc)] write-lock)
+       (move-position [(code?) (code? extend) (code? extend kind)] write-lock)
+       (split-snip [(pos)] write-lock)
+       (set-line-spacing [(space)] write-lock)
+       (set-max-width [(width)] write-lock)
+       (set-min-width [(width)] write-lock)
+       (set-min-height [(width)] write-lock)
+       (set-max-height [(width)] write-lock)
+       (set-tabs [(tabs) (tabs tab-width) (tabs tab-width units?)] write-lock)
+       (print [()
+               (interactive?)
+               (interactive? fit-on-page?)
+               (interactive? fit-on-page? output-mode)
+               (interactive? fit-on-page? output-mode parent)
+               (interactive? fit-on-page? output-mode parent force-ps-page-bbox?)]
+              write-lock)
+       
+       (get-text [() (x) (x y) (x y z) (x y z p)] write-lock)
+       (get-character [(start)] write-lock)
+       (find-wordbreak [(start end reason)] write-lock)
+       (save-file [() (filename) (filename format) (filename format show-errors?)] write-lock)
+       (write-to-file [(stream) (stream start end)]  write-lock)
+       (find-position [(x y) (x y at-eol? on-it? edge-close?)] write-lock)
+       (scroll-line-location [(pos)] write-lock)
+       (num-scroll-lines [()] write-lock)
+       (find-scroll-line [(location)] write-lock)
+       (style-has-changed [(style)] write-lock)]
+      
+      [flow-lock
+       (and (locked-for-flow?)
+            (not (locked-for-read?)))
+
+       (get-text [() (x) (x y) (x y z) (x y z p)] flow-lock)
+       (get-character [(start)] flow-lock)
+       (find-wordbreak [(start end reason)] flow-lock)
+       (save-file [() (filename) (filename format) (filename format show-errors?)] flow-lock)
+       (write-to-file [(stream) (stream start end)]  flow-lock)
+       (find-position [(x y) (x y at-eol? on-it? edge-close?)] flow-lock)
+       (scroll-line-location [(pos)] flow-lock)
+       (num-scroll-lines [()] flow-lock)
+       (find-scroll-line [(location)] flow-lock)
+       (style-has-changed [(style)] flow-lock)]
+
+      [read-lock
+       (locked-for-read?)])
+
+     (inherit locked-for-flow?
+              locked-for-write?
+              locked-for-read?)
+     (super-new))))
+
+  #|
+     ;; flowLocked in wx_mpriv
+     set-position ; _SetPosition
+     CheckRecalc  (only if graphicMaybeInvalid aka locations-computed?)
+     set-autowrap-bitmap ; SetAutowrapBitmap
+     Redraw 
+     BeginPrint
+     EndPrint
+     HasPrintPage
+     print-to-dc ; PrintToDC
+     
+     ;; flowlocked in wx_media.cxx
+     move-position ; MovePosition
+     split-snip ; SplitSnip
+     set-line-spacing ; SetLineSpacing
+     set-max-width ; SetMaxWidth
+     set-min-width ; SetMinWidth
+     set-min-height ; SetMinHeight
+     set-max-height ; SetMaxHeight
+     set-tabs ; SetTabs
+     resized ; Resized ;; uses the flag, but not to abort
+     
+     ;; methods that consider
+     ;; the readLocked variable,
+     ;; at the C level; they just
+     ;; return if it is set.
+     get-text ; GetText
+     get-character ; GetCharacter
+     find-wordbreak ; FindWorkbreak
+     save-file ; SaveFile
+     write-to-file ; WriteToFile
+     _FindPositionInSnip
+     find-position ; FindPosition
+     scroll-line-location ; ScrollLineLocation
+     num-scroll-lines ; NumScrollLines
+     find-scroll-line ; FindScrollLine
+     style-has-changed ; StyleHasChanged ;; maybe need to expand this to include style lists?
+
+     FindFirstVisiblePosition ;; LineStartPosition?
+     FindLastVisiblePosition
+     CheckRecalc
+     
+     ;; methods that consider the writeLocked variable,
+     ;; at the C level
+     _ChangeStyle
+     _Insert
+     _Delete
+     insert-port ; InsertPort
+     read-from-file ; ReadFromFile
+     set-style-list ; SetStyleList
+     ; Recounted
+     ReallyCanEdit -- only when op != wxEDIT_COPY
+     
+     ;; in wx_mpbrd.cxx
+     insert ; Insert
+     delete ; Delete
+     erase ; Erase
+     delete ; Delete ;; -- with arg
+     remove ; Remove
+     move-to ; MoveTo
+     move ; Move, also with arg
+     change-style ; _ChangeStyle
+     set-before ;SetBefore
+     set-after ;SetAfter
+     ;ReallyCanEdit -- only when op != wxEDIT_COPY
+     ;Refresh has wierd code checking writeLocked -- what does < 0 mean?
+     do-paste ; DoPaste
+     paste ; Paste
+     insert-port ; InsertPort
+     insert-file ; InsertFile
+     read-from-file ; ReadFromFile
+     ; BeginEditSequence ;; -- wierd flag check
+     ; EndEditSequence ;; -- wierd flag check, like BeginEditSequence
+  
+  |#
diff --git a/collects/mred/private/snipfile.ss b/collects/mred/private/snipfile.ss
new file mode 100644
index 0000000000..9bb56198fe
--- /dev/null
+++ b/collects/mred/private/snipfile.ss
@@ -0,0 +1,315 @@
+(module snipfile mzscheme
+  (require (lib "class.ss")
+	   (lib "etc.ss")
+	   (lib "port.ss")
+	   (lib "moddep.ss" "syntax")
+	   (prefix wx: "kernel.ss")
+	   "check.ss"
+	   "editor.ss")
+		
+  (provide readable-snip<%>
+	   open-input-text-editor 
+	   open-input-graphical-file
+	   text-editor-load-handler
+	   open-output-text-editor )
+
+  ;; snip-class% and editor-data-class% loaders
+
+  (let ([load-one
+	 (lambda (str id %)
+	   (let ([m (with-handlers ([void (lambda (x) #f)])
+		      (and (regexp-match #rx"^[(].*[)]$" str)
+			   (read (open-input-string str))))])
+	     (if (and (list? m)
+		      (eq? 'lib (car m))
+		      (andmap string? (cdr m)))
+		 (let ([result (dynamic-require m id)])
+		   (if (is-a? result %)
+		       result
+		       (error 'load-class "not a ~a% instance" id)))
+		 #f)))])
+    ;; install the getters:
+    (wx:set-snip-class-getter 
+     (lambda (name)
+       (load-one name 'snip-class wx:snip-class%)))
+    (wx:set-editor-data-class-getter 
+     (lambda (name)
+       (load-one name 'editor-data-class wx:editor-data-class%))))
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (define readable-snip<%>
+    (interface ()
+      read-special))
+
+  (define empty-string (make-bytes 0))
+  
+  ;; open-input-text-editor : (instanceof text%) num num -> input-port
+  ;; creates a user port whose input is taken from the text%,
+  ;; starting at position `start-in'
+  ;; and ending at position `end'.
+  (define open-input-text-editor 
+    (opt-lambda (text [start 0] [end 'end] [snip-filter values] [port-name text] [expect-to-read-all? #f])
+      ;; Check arguments:
+      (unless (text . is-a? . text%)
+	(raise-type-error 'open-input-text-editor "text% object" text))
+      (check-non-negative-integer 'open-input-text-editor start)
+      (unless (or (eq? end 'end)
+		  (and (integer? end) (exact? end) (not (negative? end))))
+	(raise-type-error 'open-input-text-editor "non-negative exact integer or 'end" end))
+      (let ([last (send text last-position)])
+	(when (start . > . last)
+	  (raise-mismatch-error 'open-input-text-editor
+				(format "start index outside the range [0,~a]: " last)
+				start))
+	(unless (eq? end 'end)
+	  (unless (<= start end last)
+	    (raise-mismatch-error 'open-input-text-editor
+				  (format "end index outside the range [~a,~a]: " start last)
+				  end))))
+      (let ([end (if (eq? end 'end) (send text last-position) end)]
+	    [snip (send text find-snip start 'after-or-none)])
+	;; If the region is small enough, and if the editor contains
+	;; only string snips, then it's probably better to move
+	;; all of the text into a string port:
+	(if (or (not snip)
+		(and (is-a? snip wx:string-snip%)
+		     (let ([s (send text find-next-non-string-snip snip)])
+		       (or (not s)
+			   ((send text get-snip-position s) . >= . end)))))
+	    (if (or expect-to-read-all?
+		    ((- end start) . < . 4096))
+		;; It's all text, and it's short enough: just read it into a string
+		(open-input-string (send text get-text start end) port-name)
+		;; It's all text, so the reading process is simple:
+		(let ([start start])
+		  (let-values ([(pipe-r pipe-w) (make-pipe)])
+		    (make-input-port/read-to-peek
+		     port-name
+		     (lambda (s)
+		       (let ([v (read-bytes-avail!* s pipe-r)])
+			 (if (eq? v 0)
+			     (let ([n (min 4096 (- end start))])
+			       (if (zero? n)
+				   (begin
+				     (close-output-port pipe-w)
+				     eof)
+				   (begin
+				     (write-string (send text get-text start (+ start n)) pipe-w)
+				     (set! start (+ start n))
+				     (read-bytes-avail!* s pipe-r))))
+			     v)))
+		     (lambda (s skip general-peek)
+		       (let ([v (peek-bytes-avail!* s skip #f pipe-r)])
+			 (if (eq? v 0)
+			     (general-peek s skip)
+			     v)))
+		     void))))
+	    ;; General case, which handles non-text context:
+	    (with-method ([gsp (text get-snip-position)]
+			  [grn (text get-revision-number)])
+	      (let-values ([(pipe-r pipe-w) (make-pipe)])
+		(let* ([get-text-generic (generic wx:snip% get-text)]
+		       [get-count-generic (generic wx:snip% get-count)]
+		       [next-generic (generic wx:snip% next)]
+		       [revision (grn)]
+		       [next? #f]
+		       [update-str-to-snip
+			(lambda (to-str)
+			  (if snip
+			      (let ([snip-start (gsp snip)])
+				(cond
+				 [(snip-start . >= . end)
+				  (set! snip #f)
+				  (set! next? #f)
+				  0]
+				 [(is-a? snip wx:string-snip%)
+				  (set! next? #t)
+				  (let ([c (min (send-generic snip get-count-generic) (- end snip-start))])
+				    (write-string (send-generic snip get-text-generic 0 c) pipe-w)
+				    (read-bytes-avail!* to-str pipe-r))]
+				 [else
+				  (set! next? #f)
+				  0]))
+			      (begin
+				(set! next? #f)
+				0)))]
+		       [next-snip
+			(lambda (to-str)
+			  (unless (= revision (grn))
+			    (raise-mismatch-error 
+			     'text-input-port 
+			     "editor has changed since port was opened: "
+			     text))
+			  (set! snip (send-generic snip next-generic))
+			  (update-str-to-snip to-str))]
+		       [read-chars (lambda (to-str)
+				     (cond
+				      [next?
+				       (next-snip to-str)]
+				      [snip
+				       (let ([the-snip (snip-filter snip)])
+					 (next-snip empty-string)
+					 (lambda (file line col ppos)
+					   (if (is-a? the-snip wx:snip%)
+					       (if (is-a? the-snip readable-snip<%>)
+						   (send the-snip read-special file line col ppos)
+						   (send the-snip copy))
+					       the-snip)))]
+				      [else eof]))]
+		       [close (lambda () (void))]
+		       [port (make-input-port/read-to-peek
+			      port-name
+			      (lambda (s)
+				(let ([v (read-bytes-avail!* s pipe-r)])
+				  (if (eq? v 0)
+				      (read-chars s)
+				      v)))
+			      (lambda (s skip general-peek)
+				(let ([v (peek-bytes-avail!* s skip #f pipe-r)])
+				  (if (eq? v 0)
+				      (general-peek s skip)
+				      v)))
+			      close)])
+		  (if (is-a? snip wx:string-snip%)
+		      ;; Special handling for initial snip string in
+		      ;; case it starts too early:
+		      (let* ([snip-start (gsp snip)]
+			     [skip (- start snip-start)]
+			     [c (min (- (send-generic snip get-count-generic) skip)
+				     (- end snip-start))])
+			(set! next? #t)
+			(display (send-generic snip get-text-generic skip c) pipe-w))
+		      (update-str-to-snip empty-string))
+		  port)))))))
+
+  (define (text-editor-load-handler filename expected-module)
+    (unless (path? filename)
+      (raise-type-error 'text-editor-load-handler "path" filename))
+    (let-values ([(in-port src) (build-input-port filename)])
+      (dynamic-wind
+	  (lambda () (void))
+	  (lambda ()
+	    (parameterize ([read-accept-compiled #t])
+	      (if expected-module
+		  (with-module-reading-parameterization 
+		   (lambda ()
+		     (let* ([first (read-syntax src in-port)]
+			    [module-ized-exp (check-module-form first expected-module filename)]
+			    [second (read in-port)])
+		       (unless (eof-object? second)
+			 (raise-syntax-error
+			  'text-editor-load-handler
+			  (format "expected only a `module' declaration for `~s', but found an extra expression"
+				  expected-module)
+			  second))
+		       (eval module-ized-exp))))
+		  (let loop ([last-time-values (list (void))])
+		    (let ([exp (read-syntax src in-port)])
+		      (if (eof-object? exp)
+			  (apply values last-time-values)
+			  (call-with-values (lambda () (eval exp))
+			    (lambda x (loop x)))))))))
+	  (lambda ()
+	    (close-input-port in-port)))))
+
+
+  ;; build-input-port : string -> (values input any)
+  ;; constructs an input port for the load handler. Also
+  ;; returns a value representing the source of code read from the file.
+  ;; if the file's first lines begins with #!, skips the first chars of the file.
+  (define (build-input-port filename)
+    (let ([p (open-input-file filename)])
+      (port-count-lines! p)
+      (let ([p (cond
+		[(regexp-match-peek #rx#"^WXME01[0-9][0-9] ## " p)
+		 (let ([t (make-object text%)])
+		   (send t insert-file p 'standard)
+		   (close-input-port p)
+		   (open-input-text-editor t))]
+		[else p])])
+	(port-count-lines! p) ; in case it's new
+	(let loop ()
+	  ;; Wrap regexp check with `with-handlers' in case the file
+	  ;;  starts with non-text input
+	  (when (with-handlers ([exn:fail? (lambda (x) #f)])
+		  (regexp-match-peek #rx"^#!" p))
+	    ;; Throw away chars/specials up to eol,
+	    ;;  and continue if line ends in backslash
+	    (let lloop ([prev #f])
+	      (let ([c (read-char-or-special p)])
+		(if (or (eof-object? c)
+			(eq? c #\return)
+			(eq? c #\newline))
+		    (when (eq? prev #\\)
+		      (loop))
+		    (lloop c))))))
+	(values p filename))))
+
+  (define (open-input-graphical-file filename)
+    (let-values ([(p name) (build-input-port filename)])
+      p))
+
+  (define open-output-text-editor 
+    (opt-lambda (text [start 'end] [special-filter values] [port-name text])
+      (define pos (if (eq? start 'end)
+		      (send text last-position)
+		      (min start
+			   (send text last-position))))
+      (define-values (in out) (make-pipe))
+      (define cvt (bytes-open-converter "UTF-8-permissive" "UTF-8"))
+      (define raw-buffer (make-bytes 128))
+      (define utf8-buffer (make-bytes 128))
+      (define (show s)
+	(send text insert s pos)
+	(set! pos (+ (string-length s) pos)))
+      (define (flush-text)
+	(let ([cnt (peek-bytes-avail!* raw-buffer 0 #f in)])
+	  (when (positive? cnt)
+	    (let-values ([(got used status) (bytes-convert cvt raw-buffer 0 cnt utf8-buffer)])
+	      (cond
+	       [(positive? got) 
+		(read-bytes-avail!* raw-buffer in 0 used)
+		(show (bytes->string/utf-8 utf8-buffer #\? 0 got))
+		(flush-text)]
+	       [(eq? status 'error) 
+		(read-byte in)
+		(show "?")
+		(flush-text)])))))
+      (define (force-text)
+	(when (byte-ready? in)
+	  (show "?")
+	  (read-byte in)
+	  (flush-text)
+	  (force-text)))
+      (define port
+	(make-output-port
+	 text
+	 always-evt
+	 (lambda (s start end nonblock? breakable?)
+	   ;; Put bytes into pipe:
+	   (write-bytes s out start end)
+	   ;; Extract as many string characters as are ready:
+	   (flush-text)
+	   (- end start))
+	 (lambda ()
+	   (force-text))
+	 (lambda (special nonblock? breakable?)
+	   (let ([special (special-filter special)])
+	     (cond
+	      [(special . is-a? . wx:snip%)
+	       (force-text)
+	       (send text insert special pos)
+	       (set! pos (+ pos (send special get-count)))]
+	      [else
+	       (display special port)]))
+	   #t)
+	 #f #f
+	 (lambda ()
+	   (let ([line (send text position-line pos)])
+	     (values (add1 line)
+		     (- pos (send text line-start-position line))
+		     (add1 pos))))
+	 void
+	 (add1 pos)))
+      port)))
diff --git a/collects/mred/private/wx.ss b/collects/mred/private/wx.ss
new file mode 100644
index 0000000000..dda7ef3fd3
--- /dev/null
+++ b/collects/mred/private/wx.ss
@@ -0,0 +1,52 @@
+(module wx mzscheme
+  (require (lib "class.ss")
+	   (lib "class100.ss")
+	   (prefix wx: "kernel.ss")
+	   "lock.ss"
+	   "helper.ss")
+
+  (provide (protect wx<%>
+		    wx/proxy<%>
+		    make-glue%
+		    wx->mred
+		    wx->proxy
+		    mred%
+		    mred->wx
+		    mred->wx-container))
+
+  ;; The windowing wx classes are not exposed directly.
+  ;; Instead, we expose wrapper classes that have wx instances.
+  ;; The `make-glue%' mixin adds fields and methods to map 
+  ;; wx (internal) objects to mred (external) objects.
+  ;; Sometimes, multiple wx instances have one mred instance;
+  ;; hance proxies.
+
+  (define wx<%> (interface () get-mred))
+  (define wx/proxy<%> (interface (wx<%>) get-proxy))
+  
+  (define (make-glue% %)
+    (class100* % (wx/proxy<%>) (mr prxy . args)
+	       (private-field [mred mr]
+			      [proxy prxy])
+	       (public
+		 [get-mred (lambda () mred)]
+		 [get-proxy (lambda () proxy)])
+	       (sequence (apply super-init args))))
+
+  (define wx-get-mred/gen (make-generic wx<%> 'get-mred))
+  (define wx-get-proxy/gen (make-generic wx/proxy<%> 'get-proxy))
+
+  (define (wx->mred w) (send-generic w wx-get-mred/gen))
+  (define (wx->proxy w) (send-generic w wx-get-proxy/gen))
+
+
+  (define-local-member-name private-wx)
+  
+  (define mred%
+    (class object%
+      (init-field private-wx)
+      (super-make-object)))
+  
+  (define mred->wx (class-field-accessor mred% private-wx))
+  
+  (define (mred->wx-container w) (send (mred->wx w) get-container)))
diff --git a/collects/mred/private/wxcanvas.ss b/collects/mred/private/wxcanvas.ss
new file mode 100644
index 0000000000..f9b7f88042
--- /dev/null
+++ b/collects/mred/private/wxcanvas.ss
@@ -0,0 +1,205 @@
+(module wxcanvas mzscheme
+  (require (lib "class.ss")
+	   (lib "class100.ss")
+	   (prefix wx: "kernel.ss")
+	   "lock.ss"
+	   "helper.ss"
+	   "wx.ss"
+	   "wxwindow.ss"
+	   "wxitem.ss")
+
+  (provide (protect make-canvas-glue%
+		    wx-canvas%
+		    wx-editor-canvas%))
+
+  (define (make-canvas-glue% %) ; implies make-window-glue%
+    (class100 (make-window-glue% %) (mred proxy . args)
+      (inherit get-mred get-top-level)
+      (public
+	[do-on-char (lambda (e) (super on-char e))]
+	[do-on-event (lambda (e) (super on-event e))]
+	[do-on-scroll (lambda (e) (super on-scroll e))]
+	[do-on-paint (lambda () (super on-paint))])
+      (override
+	[on-char (entry-point
+		  (lambda (e)
+		    (let ([mred (get-mred)])
+		      (if mred
+			  (as-exit (lambda () (send mred on-char e)))
+			  (super on-char e)))))]
+	[on-event (entry-point
+		   (lambda (e)
+		     (let ([mred (get-mred)])
+		       (if mred
+			   (as-exit (lambda () (send mred on-event e)))
+			   (as-exit (lambda () (super on-event e)))))))]
+	[on-scroll (entry-point
+		    (lambda (e)
+		      (let ([mred (get-mred)])
+			(if mred
+			    ;; Delay callback for Windows scrollbar 
+			    ;; and Windows/Mac trampoiline
+			    (queue-window-callback
+			     this
+			     (lambda () (send mred on-scroll e)))
+			    (as-exit (lambda () (super on-scroll e)))))))]
+	[on-paint (entry-point
+		   (lambda ()
+		     (let ([mred (get-mred)])
+		       (if mred
+			   (if (and (eq? 'windows (system-type))
+				    (not (eq? (wx:current-eventspace)
+					      (send (get-top-level) get-eventspace))))
+			       ;; Windows circumvented the event queue; delay
+			       (queue-window-callback
+				this
+				(lambda () (send mred on-paint)))
+			       (as-exit (lambda () (send mred on-paint))))
+			   (as-exit (lambda () (super on-paint)))))))])
+      (sequence (apply super-init mred proxy args))))
+
+  (define wx-canvas% 
+    (make-canvas-glue%
+     (class100 (make-control% wx:canvas% 0 0 #t #t) (parent x y w h style gl-config)
+       (private-field
+	[tabable? #f])
+       (public
+	 [on-tab-in (lambda () (send (wx->mred this) on-tab-in))]
+	 [get-tab-focus (lambda () tabable?)]
+	 [set-tab-focus (lambda (v) (set! tabable? v))])
+       (override
+	 [gets-focus? (lambda () tabable?)]
+	 [handles-key-code
+	  (lambda (code alpha? meta?)
+	    (or meta? (not tabable?)))])
+       (sequence
+	 (super-init style parent x y w h style "canvas" gl-config)))))
+
+  (define (make-editor-canvas% %)
+    (class100 % (parent x y w h name style spp init-buffer)
+      (inherit get-editor force-redraw
+	       call-as-primary-owner min-height get-size
+	       get-hard-minimum-size set-min-height)
+      (private-field
+       [fixed-height? #f]
+       [fixed-height-lines 0]
+       [orig-hard #f]
+       [single-line-canvas? #f]
+       [tabable? #f])
+      (override
+	[on-container-resize (lambda ()
+			       (let ([edit (get-editor)])
+				 (when edit
+				   (as-exit (lambda () (send edit on-display-size-when-ready))))))]
+	[on-scroll-on-change (lambda ()
+			       (queue-window-callback
+				this
+				(lambda ()
+				  (let ([edit (get-editor)])
+				    (when edit
+				      (send edit on-display-size-when-ready))))))]
+	[on-set-focus
+	 (entry-point
+	  (lambda ()
+	    (as-exit (lambda () (super on-set-focus)))
+	    (let ([m (get-editor)])
+	      (when m 
+		(let ([mred (wx->mred this)])
+		  (when mred
+		    (as-exit (lambda () (send m set-active-canvas mred)))))))))]
+	[set-editor
+	 (letrec ([l (case-lambda
+		      [(edit) (l edit #t)]
+		      [(edit redraw?)
+		       (let ([old-edit (get-editor)])
+			 (super set-editor edit redraw?)
+			 
+			 (let ([mred (wx->mred this)])
+			   (when mred
+			     (when old-edit
+			       (as-exit
+				(lambda () (send old-edit remove-canvas mred))))
+			     (when edit
+			       (as-exit
+				(lambda () (send edit add-canvas mred))))))
+
+			 (update-size)
+			 
+			 ;; force-redraw causes on-container-resize to be called,
+			 ;;  but only when the size of the canvas really matters
+			 ;;  (i.e., when it is shown)
+			 (force-redraw))])])
+	   l)]
+	[handles-key-code 
+	 (lambda (x alpha? meta?)
+	   (case x
+	     [(#\tab #\return escape) (and (not tabable?)
+					   (not single-line-canvas?))]
+	     [else (not meta?)]))]
+
+
+	[popup-for-editor (entry-point
+			   (lambda (e m)
+			     (let ([mwx (mred->wx m)])
+			       (and (send mwx popup-grab e)
+				    (as-exit (lambda () (send m on-demand) #t))
+				    mwx))))])
+      (public
+	[set-tabable (lambda (on?) (set! tabable? on?))]
+	[is-tabable? (lambda () tabable?)]
+	[on-tab-in (lambda () 
+		     (let ([mred (wx->mred this)])
+		       (when mred
+			 (send mred on-tab-in))))]
+	[set-single-line (lambda () (set! single-line-canvas? #t))]
+	[is-single-line? (lambda () single-line-canvas?)]
+	[set-line-count (lambda (n)
+			  (if n
+			      (begin
+				(unless orig-hard
+				  (let-values ([(hmw hmh) (get-hard-minimum-size)])
+				    (set! orig-hard hmh)))
+				(set! fixed-height? #t)
+				(set! fixed-height-lines n))
+			      (when orig-hard
+				(set! fixed-height? #f)
+				(set-min-height orig-hard)))
+			  (update-size))]
+	[get-line-count (lambda () (and fixed-height? fixed-height-lines))]
+	[update-size
+	 (lambda ()
+	   (let ([edit (get-editor)])
+	     (when (and edit fixed-height?)
+	       (let* ([top (if (is-a? edit wx:text%)
+			       (send edit line-location 0 #t)
+			       0)]
+		      [bottom (if (is-a? edit wx:text%)
+				  (send edit line-location 0 #f)
+				  14)]
+		      [height (- bottom top)])
+		 (let* ([ch (box 0)]
+			[h (box 0)])
+		   (call-as-primary-owner
+		    (lambda ()
+		      (send (send edit get-admin) 
+			    get-view #f #f #f ch)))
+		   (get-size (box 0) h)
+		   (let ([new-min-height (+ (* fixed-height-lines height) 
+					    (- (unbox h) (unbox ch)))])
+		     (set-min-height (inexact->exact (round new-min-height)))
+		     (force-redraw)))))))])
+      (override
+	[set-y-margin (lambda (m)
+			(super set-y-margin m)
+			(when fixed-height? (update-size)))])
+      
+      (sequence
+	(super-init style parent x y w h (or name "") style spp init-buffer)
+	(when init-buffer
+	  (let ([mred (wx->mred this)])
+	    (when mred
+	      (as-exit (lambda () (send init-buffer add-canvas mred)))))))))
+
+  (define wx-editor-canvas% (make-canvas-glue%
+			     (make-editor-canvas% (make-control% wx:editor-canvas%
+								 0 0 #t #t)))))
diff --git a/collects/mred/private/wxcontainer.ss b/collects/mred/private/wxcontainer.ss
new file mode 100644
index 0000000000..bb823a26ea
--- /dev/null
+++ b/collects/mred/private/wxcontainer.ss
@@ -0,0 +1,40 @@
+(module wxcontainer mzscheme
+  (require (lib "class.ss")
+	   (lib "class100.ss")
+	   (lib "list.ss")
+	   (prefix wx: "kernel.ss")
+	   "lock.ss"
+	   "helper.ss"
+	   "wx.ss")
+
+  (provide (protect make-container-glue%
+		    wx-make-container%))
+
+  (define (make-container-glue% %)
+    (class100 % (mr prxy . args)
+      (inherit do-place-children do-get-graphical-min-size get-children-info get-hidden-child)
+      (private-field [mred mr][proxy prxy])
+      (override
+	[get-graphical-min-size (lambda () 
+				  (cond
+				   [mred (let ([info
+						(map (lambda (i)
+						       (list (child-info-x-min i) (child-info-y-min i)
+							     (child-info-x-stretch i) (child-info-y-stretch i)))
+						     (get-children-info))])
+					   (let-values ([(w h) (as-exit (lambda () (send mred container-size 
+											 (if (get-hidden-child)
+											     (cdr info) ; hidden child is first
+											     info))))])
+					     (list w h)))]
+				   [else (do-get-graphical-min-size)]))]
+	[place-children (lambda (l w h) 
+			  (cond
+			   [(null? l) null]
+			   [mred (as-exit (lambda () (send mred place-children l w h)))]
+			   [else (do-place-children l w h)]))])
+      (sequence
+	(apply super-init mred proxy args))))
+
+  ;; make-container% - for panels and top-level windows
+  (define (wx-make-container% %) %))
diff --git a/collects/mred/private/wxgroupbox.ss b/collects/mred/private/wxgroupbox.ss
new file mode 100644
index 0000000000..d8b9d95d4a
--- /dev/null
+++ b/collects/mred/private/wxgroupbox.ss
@@ -0,0 +1,102 @@
+(module wxgroupbox mzscheme
+  (require (lib "class.ss")
+	   (lib "class100.ss")
+	   (prefix wx: "kernel.ss")
+	   "lock.ss"
+	   "wx.ss"
+	   "const.ss"
+	   "gdi.ss"
+	   "helper.ss"
+	   "wxwindow.ss"
+	   "wxitem.ss"
+	   "wxcanvas.ss")
+
+  (provide (protect wx-group-box%))
+
+  (define group-right-inset 4)
+
+  (define canvas-based-group-box%
+    (class* wx-canvas%  (wx-group-box<%>)
+      (init mred proxy style parent label style-again _font)
+
+      (define font (or _font small-control-font))
+      
+      (inherit get-dc get-client-size get-mred
+	       set-min-width set-min-height
+	       set-tab-focus
+	       set-background-to-gray
+	       is-enabled-to-root?)
+      
+      (define lbl label)
+
+      (define lbl-w 0)
+      (define lbl-h 0)
+
+      (define/private (compute-sizes)
+	(let ([dc (get-dc)])
+	  (let-values ([(w h d a) (send dc get-text-extent lbl font)])
+	    (set! lbl-w w)
+	    (set! lbl-h h))))
+
+      (define/override (on-char e) (void))
+      (define/override (on-event e) (void))
+      
+      (define/override on-paint
+	(entry-point
+	 (lambda ()
+	   (let ([dc (get-dc)])
+	     (send dc set-background bg-color)
+	     (send dc set-font font)
+	     (send dc clear)
+	     (send dc set-text-foreground
+		   (if (is-enabled-to-root?)
+		       black-color
+		       disabled-color))
+	     (send dc draw-text lbl group-right-inset 0)
+	     (send dc set-pen light-pen)
+	     (let-values ([(w h) (my-get-client-size)]
+			  [(tw th ta td) (send dc get-text-extent lbl)])
+	       (send dc draw-line 
+		     1 (/ lbl-h 2)
+		     (- group-right-inset 2) (/ lbl-h 2))
+	       (send dc draw-line
+		     1 (/ lbl-h 2)
+		     1 (- h 2))
+	       (send dc draw-line
+		     1 (- h 2)
+		     (- w 2) (- h 2))
+	       (send dc draw-line
+		     (- w 2) (- h 2)
+		     (- w 2) (/ lbl-h 2))
+	       (send dc draw-line
+		     (- w 2) (/ lbl-h 2)
+		     (min (- w 2)
+			  (+ group-right-inset 4 tw))
+		     (/ lbl-h 2)))))))
+
+      (define/private (my-get-client-size)
+	(get-two-int-values (lambda (a b) (get-client-size a b))))
+
+      (define/override (handles-key-code code alpha? meta?) 
+	#f)
+
+      (define/public (set-label l)
+	(set! lbl l)
+	(on-paint))
+
+      (super-instantiate (mred proxy parent -1 -1 -1 -1 '(transparent) #f))
+
+      (set-background-to-gray)
+
+      (compute-sizes)
+      (set-min-width (inexact->exact (ceiling (+ lbl-w group-right-inset 4))))
+      (set-min-height (inexact->exact (ceiling (+ lbl-h 6))))
+      (set-tab-focus #f)))
+
+  (define wx-group-box%
+    (if (eq? 'unix (system-type))
+	canvas-based-group-box%
+	(class* (make-window-glue%
+		 (make-control% wx:group-box% 0 0 #t #t)) (wx-group-box<%>)
+	  (define/override (gets-focus?) #f)
+	  (super-instantiate ())))))
diff --git a/collects/mred/private/wxitem.ss b/collects/mred/private/wxitem.ss
new file mode 100644
index 0000000000..aa1688d1db
--- /dev/null
+++ b/collects/mred/private/wxitem.ss
@@ -0,0 +1,405 @@
+(module wxitem mzscheme
+  (require (lib "class.ss")
+	   (lib "class100.ss")
+	   (lib "etc.ss")
+	   (lib "file.ss")
+	   (prefix wx: "kernel.ss")
+	   "lock.ss"
+	   "helper.ss"
+	   "const.ss"
+	   "wx.ss"
+	   "check.ss"
+	   "wxwindow.ss")
+
+  (provide (protect make-item%
+		    make-control%
+		    make-simple-control%
+		    wx-button%
+		    wx-check-box%
+		    wx-choice%
+		    wx-message%
+		    wx-gauge%
+		    wx-list-box%
+		    wx-radio-box%
+		    wx-slider%))
+
+  ;; make-item%: creates items which are suitable for placing into
+  ;;  containers.
+  ;; input: item%: a wx:item% descendant (but see below) from which the
+  ;;          new class will be derived.
+  ;;        stretch-x/stretch-y: booleans which specify the default
+  ;;          stretchability behavior for the new class.
+  ;; returns: a class, descended from wx:item%, which is suitable for
+  ;;            placing in a container.
+  ;; Note: the item% parameter does not necessarily HAVE to be a
+  ;; descendant of wx:item%, so long as it contains the identifiers in the
+  ;; inherit section below.  You will note below that I ran wx:panel%
+  ;; through this function to create panel%.
+
+  (define make-item%
+    (lambda (item% x-margin-w y-margin-h stretch-x stretch-y)
+      (class100 (wx-make-window% item% #f) (window-style . args)
+	(inherit get-width get-height get-x get-y
+		 get-parent get-client-size)
+	(private-field [enabled? #t])
+	(override
+	  [enable
+	   (lambda (b)
+	     (set! enabled? (and b #t))
+	     (super enable b))]
+
+	  ;; set-size: caches calls to set-size to avoid unnecessary work,
+	  ;;           and works with windowsless panels
+	  ;; input: x/y: new position for object
+	  ;;        width/height: new size for object
+	  ;; returns: nothing
+	  ;; effect: if arguments mark a different geometry than the object's
+	  ;;   current geometry, passes args to super-class's set-size.
+	  ;;   Otherwise, does nothing.
+	  [set-size
+	   (lambda (x y width height)
+	     (set! x (+ x (send (area-parent) dx)))
+	     (set! y (+ y (send (area-parent) dy)))
+	     (unless (and (same-dimension? x (get-x))
+			  (same-dimension? y (get-y))
+			  (same-dimension? width (get-width))
+			  (same-dimension? height (get-height)))
+	       (super set-size x y width height)))])
+
+	(public
+	  [is-enabled?
+	   (lambda () enabled?)])
+
+	(private-field
+	 ;; Store minimum size of item.  
+	 ;; This will never change after the item is created.
+	 hard-min-width
+	 hard-min-height)
+	(public
+	  [set-min-height (lambda (v) (set! hard-min-height v) (min-height v))]
+	  [set-min-width (lambda (v) (set! hard-min-width v) (min-width v))]
+	  [get-hard-minimum-size (lambda () (values hard-min-width hard-min-height))]
+	  
+	  [client-inset
+	   (lambda (h?)
+	     (let ([h #f][w #f])
+	       (unless h
+		 (let ([w-box (box 0)]
+		       [h-box (box 0)])
+		   (get-client-size w-box h-box)
+		   (set! h (- (get-height) (unbox h-box)))
+		   (set! w (- (get-width) (unbox w-box)))))
+	       (if h? h w)))]
+
+	  ;; gets/sets user's requirement for minimum width.  Errors out
+	  ;; if new value is not a non-negative real number.  Forces a
+	  ;; redraw upon a set.
+	  [min-client-width
+	   (case-lambda 
+	    [() (- (min-width) (client-inset #f))]
+	    [(new-width)
+	     (check-range-integer '(method canvas<%> min-client-width) new-width)
+	     (min-width (+ new-width (client-inset #f)))])]
+	  [min-client-height
+	   (case-lambda 
+	    [() (- (min-height) (client-inset #t))]
+	    [(new-height) 
+	     (check-range-integer '(method canvas<%> min-client-height) new-height)
+	     (min-height (+ new-height (client-inset #t)))])])
+
+	(private-field [-mw 0]
+		       [-mh 0]
+		       [-xm x-margin-w]
+		       [-ym y-margin-h]
+		       [-sx stretch-x]
+		       [-sy stretch-y]
+		       [first-arg (car args)])
+
+	(public
+	  [min-width
+	   (mk-param
+	    -mw identity
+	    (lambda (v)
+	      (check-range-integer '(method area<%> min-width) v))
+	    force-redraw)]
+	  [min-height
+	   (mk-param
+	    -mh identity
+	    (lambda (v)
+	      (check-range-integer '(method area<%> min-height) v))
+	    force-redraw)]
+	  
+	  [x-margin
+	   (mk-param
+	    -xm identity
+	    (lambda (v)
+	      (check-margin-integer '(method subarea<%> horiz-margin) v)
+	      v)
+	    force-redraw)]
+	  [y-margin
+	   (mk-param
+	    -ym identity
+	    (lambda (v) 
+	      (check-margin-integer '(method subarea<%> vert-margin) v)
+	      v)
+	    force-redraw)]
+
+	  [stretchable-in-x
+	   (mk-param -sx (lambda (x) (and x #t)) void force-redraw)]
+	  [stretchable-in-y
+	   (mk-param -sy (lambda (x) (and x #t)) void force-redraw)]
+	  
+	  ;; get-info: passes necessary info up to parent.
+	  ;; input: none
+	  ;; returns: child-info struct containing the info about this
+	  ;;   item.
+	  ;; intended to be called by item's parent upon resize.
+	  [get-info
+	   (lambda ()
+	     (let* ([min-size (get-min-size)]
+		    [result (make-child-info (car min-size) (cadr min-size)
+					     (x-margin) (y-margin)
+					     (stretchable-in-x)
+					     (stretchable-in-y))])
+	       result))]
+	  
+	  [area-parent (lambda () first-arg)]
+
+	  ;; force-redraw: unconditionally trigger redraw.
+	  ;; input: none
+	  ;; returns: nothing
+	  ;; effects: forces the item's parent (if it exists) to redraw
+	  ;;   itself. This will recompute the min-size cache if it is
+	  ;;   invalid.
+	  [force-redraw
+	   (lambda ()
+	     (let ([parent (area-parent)])
+	       (when parent
+		 (send parent child-redraw-request this))))]
+	  
+	  [on-container-resize (lambda () (void))] ; This object doesn't contain anything
+
+	  [init-min (lambda (x) x)]
+	  
+	  ;; get-min-size: computes the minimum size the item can
+	  ;;   reasonably assume.
+	  ;; input: none
+	  ;; returns: a list containing the minimum width & height.
+	  [get-min-size
+	   (lambda ()
+	     (let ([w (+ (* 2 (x-margin)) (max hard-min-width (min-width)))]
+		   [h (+ (* 2 (y-margin)) (max hard-min-height (min-height)))])
+	       (list w h)))])
+	
+	(sequence
+	  (apply super-init (send (car args) get-window) (cdr args))
+	  (set-min-width (init-min (get-width)))
+	  (set-min-height (init-min (get-height)))
+
+	  (unless (memq 'deleted window-style)
+	    ;; For a pane[l], the creator must call the equivalent of the following,
+	    ;;  delaying to let the panel's wx field get initialized before
+	    ;;  panel-sizing methods are called
+	    (unless (is-a? this wx-basic-panel<%>)
+	      (send (area-parent) add-child this)))))))
+
+  ;; make-control% - for non-panel items
+  (define (make-control% item% x-margin y-margin
+			 stretch-x stretch-y)
+    (class100 (make-item% item% x-margin y-margin stretch-x stretch-y) args
+      (inherit get-parent)
+      (sequence
+	(apply super-init args)
+	(send (get-parent) set-item-cursor 0 0))))
+
+  (define (make-simple-control% item%)
+    (make-control% item%
+		   const-default-x-margin const-default-y-margin 
+		   #f #f))
+
+  (define wx-button% (make-window-glue% 
+		      (class100 (make-simple-control% wx:button%) (parent cb label x y w h style font)
+			(inherit command set-border get-top-level)
+			(private-field 
+			 [border? (memq 'border style)]
+			 [border-on? border?])
+			(public 
+			  [defaulting (lambda (on?)
+					(set! border-on? on?)
+					(set-border border-on?))] 
+			  [has-border? (lambda () border-on?)])
+			(override
+			  [char-to (lambda ()
+				     (as-exit
+				      (lambda ()
+					(command (make-object wx:control-event% 'button)))))])
+			(sequence (super-init style parent cb label x y w h style font)
+				  (when border?
+				    (send (get-top-level) add-border-button this))))))
+  (define wx-check-box% (class100 (make-window-glue% (make-simple-control% wx:check-box%)) (mred proxy parent cb label x y w h style font)
+			  (inherit set-value get-value command)
+			  (override
+			    [char-to (lambda ()
+				       (as-exit
+					(lambda ()
+					  (set-value (not (get-value)))
+					  (command (make-object wx:control-event% 'check-box)))))])
+			  (sequence (super-init mred proxy style parent cb label x y w h style font))))
+  (define wx-choice% (class100 (make-window-glue% (make-simple-control% wx:choice%)) (mred proxy parent cb label x y w h choices style font)
+		       (override 
+			 [handles-key-code 
+			  (lambda (x alpha? meta?) 
+			    (or (memq x '(up down))
+				(and alpha? (not meta?))))])
+		       (sequence (super-init mred proxy style parent cb label x y w h choices style font))))
+  (define wx-message% (class100 (make-window-glue% (make-simple-control% wx:message%)) (mred proxy parent label x y style font)
+			(override [gets-focus? (lambda () #f)])
+			(sequence (super-init mred proxy style parent label x y style font))))
+
+  (define wx-gauge%
+    (make-window-glue% 
+     (class100 (make-control% wx:gauge% 
+			      const-default-x-margin const-default-y-margin 
+			      #f #f)
+	 (parent label range style font)
+       (inherit get-client-size get-width get-height set-size 
+		stretchable-in-x stretchable-in-y set-min-height set-min-width
+		get-parent)
+       (override [gets-focus? (lambda () #f)])
+       (private-field
+	;; # pixels per unit of value.
+	[pixels-per-value 1])
+       (sequence
+	 (super-init style parent label range -1 -1 -1 -1 style font)
+
+	 (let-values ([(client-width client-height) (get-two-int-values 
+						     (lambda (a b) (get-client-size a b)))])
+	   (let ([delta-w (- (get-width) client-width)]
+		 [delta-h (- (get-height) client-height)]
+		 [vertical-labels? (eq? (send (send (get-parent) get-window) get-label-position) 'vertical)]
+		 [horizontal? (memq 'horizontal style)])
+	     (set-min-width (if horizontal?
+				(let ([cw (min const-max-gauge-length
+					       (* range pixels-per-value))])
+				  (max (if vertical-labels?
+					   cw
+					   (+ cw delta-w))
+				       (get-width)))
+				;; client-height is the default
+				;; dimension in the minor direction.
+				(+ client-width delta-w)))
+	     (set-min-height (if horizontal?
+				 (+ client-height delta-h)
+				 (let ([ch (min const-max-gauge-length
+						(* range pixels-per-value))])
+				   (max (if vertical-labels?
+					    (+ ch delta-h)
+					    ch)
+					(get-height)))))))
+
+	 (if (memq 'horizontal style)
+	     (begin
+	       (stretchable-in-x #t)
+	       (stretchable-in-y #f))
+	     (begin
+	       (stretchable-in-x #f)
+	       (stretchable-in-y #t)))))))
+
+  (define list-box-wheel-step #f)
+
+  (define wx-list-box%
+    (make-window-glue% 
+     (class100 (make-control% wx:list-box%
+			      const-default-x-margin const-default-y-margin 
+			      #t #t) (parent cb label kind x y w h choices style font label-font)
+       (inherit get-first-item
+		set-first-visible-item)
+       (private
+	 [scroll (lambda (dir)
+		   (unless list-box-wheel-step
+		     (set! list-box-wheel-step (get-preference '|MrEd:wheelStep| (lambda () 3)))
+		     (unless (and (number? list-box-wheel-step)
+				  (exact? list-box-wheel-step)
+				  (integer? list-box-wheel-step)
+				  (<= 1 list-box-wheel-step 100))
+		       (set! list-box-wheel-step 3)))
+		   (let ([top (get-first-item)])
+		     (set-first-visible-item (+ top (* list-box-wheel-step dir)))))])
+       (override
+	 [handles-key-code (lambda (x alpha? meta?)
+			     (case x
+			       [(up down) #t]
+			       [else (and alpha? (not meta?))]))]
+	 [pre-on-char (lambda (w e)
+			(or (super pre-on-char w e)
+			    (case (send e get-key-code)
+			      [(wheel-up) (scroll -1) #t]
+			      [(wheel-down) (scroll 1) #t]
+			      [else #f])))])
+       (sequence (super-init style parent cb label kind x y w h choices style font label-font)))))
+
+  (define wx-radio-box%
+    (make-window-glue% 
+     (class100 (make-simple-control% wx:radio-box%) (parent cb label x y w h choices major style font)
+       (inherit number orig-enable set-selection command)
+       (override
+	 [enable
+	  (case-lambda
+	   [(on?) (super enable on?)]
+	   [(which on?) (when (< -1 which (number))
+			  (vector-set! enable-vector which (and on? #t))
+			  (orig-enable which on?))])]
+	 [is-enabled?
+	  (case-lambda
+	   [() (super is-enabled?)]
+	   [(which) (and (< -1 which (number))
+			 (vector-ref enable-vector which))])])
+
+       (private-field [is-vertical? (memq 'vertical style)])
+       (public
+	 [vertical? (lambda () is-vertical?)]
+	 [char-to-button (lambda (i)
+			   (as-exit
+			    (lambda ()
+			      (set-selection i)
+			      (command (make-object wx:control-event% 'radio-box)))))])
+
+       (sequence (super-init style parent cb label x y w h choices major style font))
+
+       (private-field [enable-vector (make-vector (number) #t)]))))
+
+  (define wx-slider%
+    (make-window-glue% 
+     (class100 (make-control% wx:slider% 
+			      const-default-x-margin const-default-y-margin 
+			      #f #f)
+	 (parent func label value min-val max-val style font)
+       (inherit set-min-width set-min-height stretchable-in-x stretchable-in-y
+		get-client-size get-width get-height get-parent)
+       (private-field
+	;; # pixels per possible setting.
+	[pixels-per-value 3])
+       ;; 3 is good because with horizontal sliders under Xt, with 1 or 2
+       ;; pixels per value, the thumb is too small to display the number,
+       ;; which looks bad.
+       
+       (sequence
+	 (super-init style parent func label value min-val max-val -1 -1 -1 style font)
+	 
+	 (let-values ([(client-w client-h) (get-two-int-values (lambda (a b)
+								 (get-client-size a b)))])
+	   (let* ([horizontal? (memq 'horizontal style)]
+		  [vertical-labels? (eq? (send (send (get-parent) get-window) get-label-position) 'vertical)]
+		  [range (+ (* pixels-per-value (add1 (- max-val min-val)))
+			    (cond
+			     [(and horizontal? (not vertical-labels?)) (- (get-width) client-w)]
+			     [(and (not horizontal?) vertical-labels?) (- (get-height) client-h)]
+			     [else 0]))])
+	     ((if horizontal? (lambda (v) (set-min-width v)) (lambda (v) (set-min-height v)))
+	      (max ((if horizontal? (lambda () (get-width)) (lambda () (get-height))))
+		   (min const-max-gauge-length range)))
+	     (stretchable-in-x horizontal?)
+	     (stretchable-in-y (not horizontal?))))))))
+
+  )
+
diff --git a/collects/mred/private/wxmenu.ss b/collects/mred/private/wxmenu.ss
new file mode 100644
index 0000000000..dd06f528d2
--- /dev/null
+++ b/collects/mred/private/wxmenu.ss
@@ -0,0 +1,170 @@
+(module wxmenu mzscheme
+  (require (lib "class.ss")
+	   (lib "class100.ss")
+	   (lib "list.ss")
+	   (prefix wx: "kernel.ss")
+	   "lock.ss"
+	   "const.ss"
+	   "helper.ss"
+	   "wx.ss")
+  
+  (provide (protect wx-menu-item%
+		    wx-menu-bar%
+		    wx-menu%))
+
+  (define wx-menu-item%
+    (class100* wx:menu-item% (wx<%>) (mr mn-dat can-enable?)
+      (private-field 
+       [menu-data mn-dat]
+       [mred mr]
+       [keymap #f]
+       [wx-menu #f]
+       [enabled? #t]
+       [ever-enabled? can-enable?])
+      (public
+	[get-keymap (lambda () keymap)]
+	[set-keymap (lambda (k) (set! keymap k))]
+	[swap-keymap (lambda (parent k) 
+		       (send (send (mred->wx parent) get-container) swap-item-keymap keymap k) 
+		       (set-keymap k))]
+	[get-mred (lambda () mred)]
+	[get-menu-data (lambda () menu-data)]  ; for meta-shortcuts
+	[get-container (lambda () wx-menu)]
+	[set-wx-menu (lambda (wx) (set! wx-menu wx))]
+	[is-enabled? (lambda () enabled?)]
+	[set-enabled (lambda (on?) (set! enabled? on?))]
+	[ignore-enabled? (lambda () (not ever-enabled?))])
+      (sequence
+	(super-init))))
+
+  (define wx-menu-bar%
+    (class100* wx:menu-bar% (wx<%>) (mr)
+      (inherit delete)
+      (rename [super-append append]
+	      [super-enable-top enable-top])
+      (private-field
+       [mred mr]
+       [items null]
+       [disabled null]
+       [disabled? #f]
+       [keymap (make-object wx:keymap%)])
+      (public
+	[get-container (lambda () this)]
+	[handle-key (lambda (event) 
+		      (as-exit 
+		       (lambda () 
+			 (or (send keymap handle-key-event this event)
+			     (and (menu-shortcut-in-label?)
+				  (send event get-meta-down)
+				  (char? (send event get-key-code))
+				  (let ([c (send event get-key-code)])
+				    (and (or (char-alphabetic? c)
+					     (char-numeric? c))
+					 (let ([re (key-regexp c)])
+					   (ormap
+					    (lambda (i)
+					      (let* ([data (send (mred->wx i) get-menu-data)]
+						     [label (car data)]
+						     [menu (cdr data)])
+						(if (regexp-match re label)
+						    (begin
+						      (send menu select this)
+						      #t)
+						    #f)))
+					    items)))))))))]
+	[on-demand (lambda () (as-exit (lambda () (send mred on-demand))))]
+	[get-mred (lambda () mred)]
+	[get-items (lambda () items)]
+	[append-item (lambda (item menu title)
+		       (super-append menu title)
+		       (when disabled?
+			 (super-enable-top (length items) #f))
+		       (set! items (append items (list item)))
+		       (send keymap chain-to-keymap (send (mred->wx item) get-keymap) #f))]
+	[all-enabled? (lambda () (not disabled?))]
+	[enable-all (lambda (on?)
+		      (set! disabled? (not on?))
+		      (let loop ([n (sub1 (length items))])
+			(unless (negative? n)
+			  (if on?
+			      (unless (memq (list-ref items n) disabled)
+				(super-enable-top n #t))
+			      (super-enable-top n #f))
+			  (loop (sub1 n)))))]
+	[delete-item (lambda (i)
+		       (let ([p (position-of i)])
+			 (set! items (remq i items))
+			 (set! disabled (remq i disabled))
+			 (delete #f p)
+			 (send keymap remove-chained-keymap (send (mred->wx i) get-keymap))))]
+	[position-of (lambda (i) (find-pos items i eq?))])
+      (override
+	[enable-top (lambda (p on?)
+		      (let ([i (list-ref items p)])
+			(if on?
+			    (when (memq i disabled)
+			      (set! disabled (remq i disabled))
+			      (unless disabled?
+				(super-enable-top p #t)))
+			    (unless (memq i disabled)
+			      (set! disabled (cons i disabled))
+			      (super-enable-top p #f)))))])
+      (sequence
+	(super-init))))
+
+  (define wx-menu%
+    (class100* wx:menu% (wx<%>) (mr popup-label popup-callback font)
+      (private-field
+       [mred mr]
+       [items null]
+       [keymap (make-object wx:keymap%)]
+       [popup-grabber #f])
+      (inherit delete-by-position)
+      (rename [super-delete delete]
+	      [super-enable enable])
+      (public
+	[get-container (lambda () this)]
+	[get-keymap (lambda () keymap)]
+	[get-mred (lambda () mred)]
+	[get-items (lambda () items)]
+	[append-item (lambda (i iwx) 
+		       (set! items (append items (list i)))
+		       (unless (or (send iwx ignore-enabled?)
+				   (not (send iwx is-enabled?)))
+			 (let ([k (send iwx get-keymap)])
+			   (when k
+			     (send keymap chain-to-keymap k #f)))))]
+	[delete-sep (lambda (i iwx)
+		      (delete-by-position (find-pos items i eq?))
+		      (set! items (remq i items)))]
+	[swap-item-keymap (lambda (old-k new-k)
+			    (when old-k (send keymap remove-chained-keymap old-k))
+			    (when new-k (send keymap chain-to-keymap new-k #f)))]
+
+	[popup-grab (lambda (c)
+		      (if popup-grabber
+			  #f
+			  (begin
+			    (set! popup-grabber c)
+			    #t)))]
+	[popup-release (lambda () (set! popup-grabber #f))]
+	[get-popup-grabber (lambda () popup-grabber)])
+      (override
+	[delete (lambda (id i) 
+		  (super-delete id) 
+		  (set! items (remq i items))
+		  (let ([k (send (mred->wx i) get-keymap)])
+		    (when k
+		      (send keymap remove-chained-keymap k))))]
+	[enable (lambda (iwx id on?)
+		  ;; Only called if the item is not deleted
+		  (unless (eq? (send iwx is-enabled?) (and on? #t))
+		    (send iwx set-enabled (and on? #t))
+		    (let ([k (send iwx get-keymap)])
+		      (when k
+			(if on?
+			    (send keymap chain-to-keymap k #f)
+			    (send keymap remove-chained-keymap k))))
+		    (super-enable id on?)))])
+      (sequence
+	(super-init popup-label popup-callback font)))))
diff --git a/collects/mred/private/wxpanel.ss b/collects/mred/private/wxpanel.ss
new file mode 100644
index 0000000000..bcc04f9820
--- /dev/null
+++ b/collects/mred/private/wxpanel.ss
@@ -0,0 +1,738 @@
+(module wxpanel mzscheme
+  (require (lib "class.ss")
+	   (lib "class100.ss")
+	   (lib "list.ss")
+	   (prefix wx: "kernel.ss")
+	   "lock.ss"
+	   "const.ss"
+	   "helper.ss"
+	   "check.ss"
+	   "wx.ss"
+	   "wxwindow.ss"
+	   "wxitem.ss"
+	   "wxcontainer.ss")
+
+  (provide (protect wx-panel%
+		    wx-vertical-panel%
+		    wx-horizontal-panel%
+		    wx-pane%
+		    wx-vertical-pane%
+		    wx-horizontal-pane%
+		    wx-grow-box-pane%))
+
+  (define wx:windowless-panel%
+    (class100 object% (prnt x y w h style)
+      (private-field
+       [pos-x 0] [pos-y 0] [width 1] [height 1]
+       [parent prnt])
+      (public
+	[drag-accept-files (lambda () (void))]
+	[on-drop-file (lambda () (void))]
+	[on-set-focus (lambda () (void))]
+	[on-kill-focus (lambda () (void))]
+	[set-focus (lambda () (void))]
+	[on-size (lambda () (void))]
+	[enable (lambda () (void))]
+	[show (lambda (on?) (void))]
+	[is-shown-to-root? (lambda () (send parent is-shown-to-root?))]
+	[is-enabled-to-root? (lambda () (send parent is-enabled-to-root?))]
+	[get-parent (lambda () parent)]
+	[get-client-size (lambda (wb hb)
+			   (when wb (set-box! wb width))
+			   (when hb (set-box! hb height)))]
+	[set-size (lambda (x y w h) 
+		    (unless (negative? x) (set! pos-x x))
+		    (unless (negative? y) (set! pos-y y))
+		    (unless (negative? w) (set! width w))
+		    (unless (negative? h) (set! height h)))]
+	[get-x (lambda () pos-x)]
+	[get-y (lambda () pos-y)]
+	[get-width (lambda () width)]
+	[get-height (lambda () height)])
+      (sequence (super-init))))
+
+  (define tab-h-border (if (eq? (system-type) 'unix)
+			   2
+			   3))
+  (define tab-v-bottom-border (if (memq (system-type) '(macosx macos))
+				  0
+				  2))
+
+  (define (wx-make-basic-panel% wx:panel% stretch?)
+    (class100* (wx-make-container% (make-item% wx:panel% 0 0 stretch? stretch?)) (wx-basic-panel<%>) (parent style)
+	       (inherit get-x get-y get-width get-height
+			min-width min-height set-min-width set-min-height
+			x-margin y-margin
+			get-client-size area-parent
+			get-hard-minimum-size
+			get-top-level)
+	       
+	       (rename [super-set-focus set-focus])
+	       
+	       (private-field
+		;; cache to prevent on-size from recomputing its result every
+		;; time. when curr-width is #f, cache invalid.
+		curr-width
+		curr-height
+		
+		;; list of child-info structs corresponding to the children.  (#f
+		;;  if no longer valid.)
+		[children-info null]
+		
+		;; Not used by linear panels
+		[h-align 'center] [v-align 'center]
+
+		;; Needed for windowless panes
+		[move-children? #f]
+
+		[ignore-redraw-request? #f])
+	       
+	       (override
+		 [has-tabbing-children? (lambda () #t)]
+
+		 [set-focus ; dispatch focus to a child panel
+		  (lambda ()
+		    (if (null? children)
+			(super-set-focus)
+			(send (car children) set-focus)))]
+
+		 [ext-dx (lambda () (if hidden-child
+					tab-h-border
+					0))]
+		 [ext-dy (lambda () (if hidden-child
+					(let-values ([(mw mh) (get-hard-minimum-size)])
+					  (- mh tab-v-bottom-border 1))
+					0))])
+	       
+	       (private-field
+		;; list of panel's contents.
+		[children null]
+		[hidden-child #f]
+		[curr-border const-default-border]
+		[border? (memq 'border style)])
+	       
+	       (public
+		 [need-move-children (lambda () (set! move-children? #t))]
+
+		 [get-children (lambda () children)]
+		 [get-hidden-child (lambda () hidden-child)]
+		 [set-first-child-is-hidden (lambda ()
+					      (set! hidden-child (car children))
+					      (let ([i (send hidden-child get-info)])
+						(set-min-width (child-info-x-min i))
+						(set-min-height (child-info-y-min i))))]
+
+		 [border
+		  (case-lambda
+		   [() curr-border]
+		   [(new-val)
+		    (check-margin-integer '(method area-container<%> border) new-val)
+		    (set! curr-border new-val)
+		    (force-redraw)])]
+
+		 ;; add-child: adds an existing child to the panel.
+		 ;; input: new-child: item% descendant to add
+		 ;; returns: nothing
+		 ;; effects: adds new-child to end of list of children.
+		 [add-child
+		  (lambda (new-child)
+		    (unless (eq? this (send new-child area-parent))
+		      (raise-mismatch-error 'add-child 
+					    "not a child of this container: "
+					    (wx->proxy new-child)))
+		    (when (memq new-child children)
+		      (raise-mismatch-error 'add-child "child already active: "
+					    (wx->proxy new-child)))
+		    (change-children
+		     (lambda (l)
+		       (append l (list new-child)))))]
+		 
+		 ;; change-children: changes the list of children.
+		 ;; input: f is a function which takes the current list of children
+		 ;;   and returns a new list of children.
+		 ;; returns: nothing
+		 ;; effects: sets the list of children to the value of applying f.
+		 [change-children
+		  (lambda (f)
+		    (let ([new-children (f children)]) ;; hidden child, if any , must be first!
+		      (unless (andmap (lambda (child)
+					(eq? this (send child area-parent)))
+				      new-children)
+			(raise-mismatch-error 'change-children
+					      (format
+					       (string-append 
+						"not all members of the returned list are "
+						"children of the container ~e; list: ")
+					       (wx->proxy this))
+					      (map wx->proxy (remq hidden-child new-children))))
+		      (let loop ([l new-children])
+			(unless (null? l)
+			  (if (memq (car l) (cdr l))
+			      (raise-mismatch-error 'change-children 
+						    "child in the returned list twice: " 
+						    (wx->proxy (car l)))
+			      (loop (cdr l)))))
+		      ;; show all new children, hide all deleted children.
+		      (let ([added-children (list-diff new-children children)]
+			    [removed-children (list-diff children new-children)])
+			(let ([non-window (ormap (lambda (child)
+						   (and (not (is-a? child wx:window%))
+							child))
+						 removed-children)])
+			  (when non-window
+			    (raise-mismatch-error 'change-children
+						  (format "cannot delete non-window area in ~e: "
+							  (wx->proxy this))
+						  non-window)))
+
+			;; Newly-added children may have been removed when
+			;;  disabled, or now added into a disabled panel:
+			(for-each (lambda (child) (send child queue-active))
+				  added-children)
+
+			(let ([top (get-top-level)])
+			  (for-each (lambda (child) (send top show-child child #f))
+				    removed-children)
+			  (set! children new-children)
+			  (force-redraw)
+			  (for-each (lambda (child) (send top show-child child #t))
+				    added-children)))))]
+		 
+		 ;; delete-child: removes a child from the panel.
+		 ;; input: child: child to delete.
+		 ;; returns: nothing
+		 ;; effects: removes child from list; forces redraw.
+		 [delete-child
+		  (lambda (child)
+		    (unless (memq child children)
+		      (raise-mismatch-error 'delete-child 
+					    "not a child of this container or child is not active: " 
+					    (wx->proxy child)))
+		    (change-children (lambda (child-list)
+				       (remq child child-list))))]
+		 
+		 ;; get-children-info: returns children info list, recomputing it
+		 ;;   if needed.
+		 ;; input: none
+		 ;; returns: list of child-info structs.
+		 ;; effects: upon exit, children-info is eq? to result.
+		 [get-children-info
+		  (lambda ()
+		    (unless children-info
+		      (let* ([childs children]
+			     [info (map (lambda (child)
+					  (send child get-info))
+					childs)])
+			(if (and (= (length childs) (length children))
+				 (andmap eq? childs children))
+			    ;; Got the info for the right set of children
+			    (set! children-info info)
+			    
+			    ;; During the call to some get-info, the set of children changed;
+			    ;; try again
+			    (get-children-info))))
+		    children-info)]
+		 
+		 [child-redraw-request
+		  (lambda (from)
+		    (unless (or ignore-redraw-request?
+				(not (memq from children)))
+		      (force-redraw)))]
+		 
+		 ;; do-graphical-size: creates a function which returns the minimum
+		 ;;   possible size for a horizontal-panel% or vertical-panel% object.
+		 ;; input: compute-x/compute-y: functions which take the current x/y
+		 ;;          location, the amount of spacing which will come after the
+		 ;;          current object, and the list of child-info structs beginning
+		 ;;          with the current object, and return the new x/y locations.
+		 ;; returns: a thunk which returns the minimum possible size of the
+		 ;;   entire panel (not just client) as a list of two elements:
+		 ;;   (min-x min-y). 
+		 [do-graphical-size
+		  (lambda (compute-x compute-y)
+		    (letrec ([gms-help
+			      (lambda (kid-info x-accum y-accum first?)
+				(if (null? kid-info)
+				    (list x-accum y-accum)
+				    (gms-help
+				     (cdr kid-info)
+				     (compute-x x-accum kid-info (and hidden-child first?))
+				     (compute-y y-accum kid-info (and hidden-child first?))
+				     #f)))])
+		      (let-values ([(client-w client-h)
+				    (get-two-int-values (lambda (a b) (get-client-size a b)))])
+			(let* ([border (border)]
+			       [min-client-size
+				(gms-help (get-children-info)
+					  (* 2 border) (* 2 border)
+					  #t)]
+			       [delta-w (- (get-width) client-w)]
+			       [delta-h (- (get-height) client-h)])
+			  (list (+ delta-w (car min-client-size) (if hidden-child (* 2 tab-h-border) 0))
+				(+ delta-h (cadr min-client-size)))))))]
+		 
+		 ;; do-get-min-graphical-size: poll children and return minimum possible
+		 ;;   size, as required by the graphical representation of the tree,
+		 ;;   of the panel.
+		 ;; input: none
+		 ;; returns: minimum full size (as a list, width & height) of the
+		 ;;   container.
+		 ;; effects: none
+		 [get-graphical-min-size (lambda () (void))]
+		 [do-get-graphical-min-size
+		  (lambda ()
+		    (do-graphical-size 
+		     (lambda (x-accum kid-info first?)
+		       (max x-accum (+ (* 2 (border))
+				       (child-info-x-min (car kid-info)))))
+		     (lambda (y-accum kid-info first?)
+		       (max y-accum (+ (* 2 (border))
+				       (child-info-y-min (car kid-info)))))))])
+	       
+	       (override
+		 [force-redraw
+		  (lambda ()
+		    (set! children-info #f)
+		    (set! curr-width #f)
+		    (let ([parent (area-parent)])
+		      (send parent child-redraw-request this)))]
+
+		 ;; get-min-size: poll children and return minimum possible size
+		 ;;   for the container which considers the user min sizes.
+		 ;; input: none
+		 ;; returns: minimum full size (as a list, width & height) of
+		 ;;   container.
+		 ;; effects: none.
+		 [get-min-size
+		  (lambda ()
+		    (let ([graphical-min-size (get-graphical-min-size)])
+		      (list (+ (* 2 (x-margin))
+			       (max (car graphical-min-size) (min-width)))
+			    (+ (* 2 (y-margin))
+			       (max (cadr graphical-min-size) (min-height))))))]
+		 
+		 [on-container-resize
+		  (lambda ()
+		    (let-values ([(client-width client-height)
+				  (get-two-int-values (lambda (a b) (get-client-size a b)))])
+		      (unless (and (number? curr-width)
+				   (number? curr-height)
+				   (= curr-width client-width)
+				   (= curr-height client-height)
+				   (not move-children?))
+			(set! curr-width client-width)
+			(set! curr-height client-height)
+			(set! move-children? #f)
+			(redraw client-width client-height))))]
+
+		 [init-min (lambda (x) (if border? 8 0))])
+	       
+	       (public
+		 ;; place-children: determines where each child of panel should be
+		 ;; placed.
+		 ;; input: children-info: list of (int int bool bool)
+		 ;;        width/height: size of panel's client area.
+		 ;; returns: list of placement info for children; each item in list
+		 ;;   is a list of 4 elements, consisting of child's x-posn,
+		 ;;   y-posn, x-size, y-size (including margins).  Items are in same 
+		 ;;   order as children-info list.
+		 [place-children (lambda (l w h) (void))]
+		 [check-place-children
+		  (lambda (children-info width height)
+		    (unless (and (list? children-info)
+				 (andmap (lambda (x) (and (list? x)
+							  (= 4 (length x))
+							  (integer? (car x)) (not (negative? (car x))) (exact? (car x))
+							  (integer? (cadr x)) (not (negative? (cadr x))) (exact? (cadr x))))
+					 children-info))
+		      (raise-type-error (who->name '(method area-container-window<%> place-children))
+					"list of (list of non-negative-integer non-negative-integer boolean boolean)"
+					children-info))
+		    (check-non-negative-integer '(method area-container-window<%> place-children) width)
+		    (check-non-negative-integer '(method area-container-window<%> place-children) height))]
+		 [do-place-children
+		  (lambda (children-info width height)
+		    (check-place-children children-info width height)
+		    (let loop ([children-info children-info])
+		      (if (null? children-info)
+			  null
+			  (let ([curr-info (car children-info)])
+			    (cons
+			     (list
+			      0 0
+			      (car curr-info) ; child-info-x-min
+			      (cadr curr-info)) ; child-info-y-min
+			     (loop (cdr children-info)))))))])
+
+	       (private-field
+		[curr-spacing const-default-spacing])
+	       
+	       (public
+		 [spacing ; does nothing!
+		  (case-lambda
+		   [() curr-spacing]
+		   [(new-val)
+		    (check-margin-integer '(method area-container<%> spacing) new-val)
+		    (set! curr-spacing new-val)])]
+
+		 [do-align (lambda (h v set-h set-v)
+			     (unless (memq h '(left center right))
+			       (raise-type-error 'set-alignment "horizontal alignment symbol: left, center, or right" h))
+			     (unless (memq v '(top center bottom))
+			       (raise-type-error 'set-alignment "vertical alignment symbol: top, center, or bottom" v))
+			     (set-h h)
+			     (set-v (case v [(top) 'left] [(center) 'center] [(bottom) 'right])))]
+		 [alignment (lambda (h v) 
+			      (do-align h v (lambda (h) (set! h-align h)) (lambda (h) (set! v-align v)))
+			      (force-redraw))]
+		 [get-alignment (lambda () (values h-align v-align))]
+
+		 ;; redraw: redraws panel and all children
+		 ;; input: width, height: size of area area in panel.
+		 ;; returns: nothing
+		 ;; effects: places children at default positions in panel.
+		 [redraw
+		  (lambda (width height)
+		    (let ([children-info (get-children-info)]
+			  [children children]) ; keep list of children matching children-info
+		      (let ([l (place-children (map (lambda (i)
+						      (list (child-info-x-min i) (child-info-y-min i)
+							    (child-info-x-stretch i) (child-info-y-stretch i)))
+						    (if hidden-child
+							(cdr children-info)
+							children-info))
+					       (if hidden-child
+						   (- width (* 2 tab-h-border))
+						   width)
+					       (if hidden-child
+						   (- height (child-info-y-min (car children-info))) ;; 2-pixel border here, too
+						   height))])
+			(unless (and (list? l)
+				     (= (length l) (- (length children-info) (if hidden-child 1 0)))
+				     (andmap (lambda (x) (and (list? x)
+							      (= 4 (length x))
+							      (andmap (lambda (x) (and (integer? x) (exact? x))) x)))
+					     l))
+			  (raise-mismatch-error 'container-redraw 
+						"result from place-children is not a list of 4-integer lists with the correct length: "
+						l))
+			(when hidden-child
+			  ;; This goes with the hack for macos and macosx below
+			  (send hidden-child set-phantom-size width height))
+			(panel-redraw children children-info (if hidden-child
+								 (cons (list 0 0 width 
+									     (if (memq (system-type) '(macos macosx)) ;; Yucky hack
+										 (child-info-y-min (car children-info)) 
+										 height))
+								       (let ([dy (child-info-y-min (car children-info))])
+									 (map (lambda (i)
+										(list (+ (car i) tab-h-border)
+										      (+ dy (cadr i) (- tab-v-bottom-border) -1)
+										      (caddr i)
+										      (cadddr i)))
+									      l)))
+								 l)))))]
+		 [panel-redraw
+		  (lambda (childs child-infos placements)
+		    (for-each
+		     (lambda (child info placement)
+		       (let-values ([(x y w h) (apply values placement)])
+			 (let ([minw (child-info-x-min info)]
+			       [minh (child-info-y-min info)]
+			       [xm (child-info-x-margin info)]
+			       [ym (child-info-y-margin info)])
+			   (dynamic-wind
+			       (lambda () (set! ignore-redraw-request? #t))
+			       (lambda ()
+				 (send child set-size
+				       (max 0 (+ x xm)) (max 0 (+ y ym))
+				       (- (max minw w) (* 2 xm))
+				       (- (max minh h) (* 2 ym))))
+			       (lambda () (set! ignore-redraw-request? #f)))
+			   (send child on-container-resize))))
+		     childs
+		     child-infos
+		     placements))])
+	       (sequence
+		 (super-init style parent -1 -1 0 0 style))))
+
+  (define (wx-make-pane% wx:panel% stretch?)
+    (class100 (make-container-glue% (make-glue% (wx-make-basic-panel% wx:panel% stretch?))) args
+      (inherit get-parent get-x get-y need-move-children get-children)
+      (rename [super-set-size set-size])
+      (override
+	[on-visible
+	 (lambda ()
+	   (for-each (lambda (c) (send c queue-visible)) (get-children)))]
+	[on-active
+	 (lambda ()
+	   (for-each (lambda (c) (send c queue-active)) (get-children)))]
+
+	[get-window (lambda () (send (get-parent) get-window))]
+	[set-size (lambda (x y w h) 
+		    (super-set-size x y w h)
+		    (need-move-children))]
+	[dx (lambda () (get-x))]
+	[dy (lambda () (get-y))])
+      (sequence
+	(apply super-init args))))
+
+  (define (wx-make-panel% wx:panel%)
+    (class100 (make-container-glue% (make-window-glue% (wx-make-basic-panel% wx:panel% #t))) args
+      (rename [super-on-visible on-visible]
+	      [super-on-active on-active])
+      (inherit get-children)
+      (override 
+	[on-visible
+	 (lambda ()
+	   (for-each (lambda (c) (send c queue-visible)) (get-children))
+	   (super-on-visible))]
+	[on-active
+	 (lambda ()
+	   (for-each (lambda (c) (send c queue-active)) (get-children))
+	   (super-on-active))])
+      (sequence (apply super-init args))))
+
+  (define (wx-make-linear-panel% wx-panel%)
+    (class100 wx-panel% args
+      (private-field
+       [major-align-pos 'left]
+       [minor-align-pos 'center])
+      
+      (inherit force-redraw border get-width get-height
+	       get-graphical-min-size)
+      (private-field [curr-spacing const-default-spacing])
+      (override
+	[spacing
+	 (case-lambda
+	  [() curr-spacing]
+	  [(new-val)
+	   (check-margin-integer '(method area-container<%> spacing) new-val)
+	   (set! curr-spacing new-val)
+	   (force-redraw)])])
+      (public
+	[minor-align (lambda (a) (set! minor-align-pos a) (force-redraw))]
+	[major-align (lambda (a) (set! major-align-pos a) (force-redraw))]
+	[major-offset (lambda (space)
+			(case major-align-pos
+			  [(center) (quotient space 2)]
+			  [(left) 0]
+			  [(right) space]))]
+	[minor-offset (lambda (width size)
+			(case minor-align-pos
+			  [(center) (quotient (- width size) 2)]
+			  [(left) 0]
+			  [(right) (- width size)]))]
+	
+	[do-get-alignment (lambda (pick) (values (pick major-align-pos minor-align-pos)
+						 (case (pick minor-align-pos major-align-pos)
+						   [(left) 'top] [(center) 'center] [(right) 'bottom])))]
+
+	;; place-linear-children: implements place-children functions for
+	;; horizontal-panel% or vertical-panel% classes.
+	;; input: child-major-size: function which takes a child-info struct
+	;;          and returns the child's minimum size in the major direction
+	;;          of the panel.
+	;;        child-major-stretch: function which takes a child-info
+	;;          struct and returns the child's stretchability in the major
+	;;          direction of the panel.
+	;;        child-minor-size/child-minor-stretch: see above.
+	;;        major-dim/minor-dim: functions which take the width and the
+	;;          height of the panel and return the panel's major and minor
+	;;          dimensions, respectively.
+	;;        get-h-info/get-v-info: functions which take info lists
+	;;          describing the major and minor directions and select the
+	;;          appropriate one.
+	;; returns: a function which takes the children info, the width and the
+	;;   height of the panel's client and returns a list which contains
+	;;   posn&size info for each child. 
+	[place-linear-children
+	 (lambda (kid-info width height
+			   child-major-size
+			   child-major-stretch
+			   child-major-offset
+			   child-minor-size
+			   child-minor-stretch
+			   child-minor-position
+			   major-dim minor-dim
+			   get-x-info get-y-info)
+	   (letrec ([count-stretchable
+		     (lambda (kid-info)
+		       (if (null? kid-info)
+			   0
+			   (let ([curr-info (car kid-info)])
+			     (if (child-major-stretch curr-info)
+				 (add1 (count-stretchable (cdr kid-info)))
+				 (count-stretchable (cdr kid-info))))))])
+	     (let* ([spacing (spacing)]
+		    [border (border)]
+		    [full-w (get-width)]
+		    [full-h (get-height)]
+		    [delta-list (list
+				 (- full-w width)
+				 (- full-h height))]
+		    [num-stretchable (count-stretchable kid-info)]
+		    [extra-space (- (major-dim width height)
+				    (- (apply 
+					major-dim
+					(get-graphical-min-size))
+				       (apply major-dim delta-list)))]
+		    [extra-per-stretchable (if (zero? num-stretchable)
+					       0
+					       (inexact->exact
+						(floor
+						 (/ extra-space
+						    num-stretchable))))]
+		    [leftover (- extra-space (* extra-per-stretchable num-stretchable))]
+		    [num-children (length kid-info)]
+		    [major-offset (if (= num-stretchable 0)
+				      (child-major-offset extra-space)
+				      0)])
+	       (letrec
+		   ([pc-help
+		     (lambda (kid-info left-edge leftover)
+		       (if (null? kid-info)
+			   null
+			   (let* ([curr-info (car kid-info)]
+				  [rest (cdr kid-info)]
+				  [major-posn left-edge]
+				  [next-leftover (if (zero? leftover)
+						     0
+						     (- leftover 1))]
+				  [extra-this-stretchable (if (zero? leftover)
+							      extra-per-stretchable
+							      (+ extra-per-stretchable 1))]
+				  [major-size
+				   (if (child-major-stretch curr-info)
+				       (+ extra-this-stretchable
+					  (child-major-size curr-info))
+				       (child-major-size curr-info))]
+				  [minor-posn (if (child-minor-stretch
+						   curr-info)
+						  border
+						  (inexact->exact
+						   (round
+						    (child-minor-position 
+						     (minor-dim width height) 
+						     (child-minor-size curr-info)))))]
+				  [minor-size (if (child-minor-stretch
+						   curr-info)
+						  (- (minor-dim width height)
+						     (* 2 border))
+						  (child-minor-size
+						   curr-info))])
+			     (cons
+			      (list
+			       (get-x-info major-posn minor-posn)
+			       (get-y-info major-posn minor-posn)
+			       (get-x-info major-size minor-size)
+			       (get-y-info major-size minor-size))
+			      (pc-help rest
+				       (+ major-size major-posn spacing)
+				       next-leftover)))))])
+		 (pc-help kid-info (+ border major-offset) leftover)))))])
+      
+      (sequence (apply super-init args))))
+
+  ;; horizontal-panel%: a panel which arranges its children in an evenly
+  ;; spaced horizontal row.  Items are vertically centered (or stretched
+  ;; to fit the dialog box if they are stretchable).  The items are evenly
+  ;; spaced horizontally, with any extra space divided evenly among the
+  ;; stretchable items. 
+  (define (wx-make-horizontal-panel% wx-linear-panel%)
+    (class100 wx-linear-panel% args
+      (inherit major-align minor-align do-align do-get-alignment major-offset minor-offset
+	       spacing border do-graphical-size place-linear-children check-place-children)
+      (override
+	[alignment (lambda (h v) (do-align h v 
+					   (lambda (x) (major-align x)) 
+					   (lambda (x) (minor-align x))))]
+	[get-alignment (lambda () (do-get-alignment (lambda (x y) x)))]
+	
+	[do-get-graphical-min-size
+	 (lambda ()
+	   (do-graphical-size 
+	    (lambda (x-accum kid-info hidden?)
+	      (+ x-accum (child-info-x-min (car kid-info))
+		 (if (or hidden? (null? (cdr kid-info)))
+		     0
+		     (spacing))))
+	    (lambda (y-accum kid-info hidden?)
+	      (max y-accum
+		   (+ (child-info-y-min (car kid-info))
+		      (* 2 (border)))))))]
+	[do-place-children
+	 (lambda (l w h)
+	   (check-place-children l w h)
+	   (place-linear-children l w h
+				  car    ; child-info-x-min
+				  caddr  ; child-info-x-stretch
+				  (lambda (s) (major-offset s))
+				  cadr   ; child-info-y-min
+				  cadddr ; child-info-y-stretch
+				  (lambda (s t) (minor-offset s t))
+				  (lambda (width height) width)
+				  (lambda (width height) height)
+				  (lambda (major minor) major)
+				  (lambda (major minor) minor)))])
+      (sequence (apply super-init args))))
+
+  ;; vertical-panel%.  See horizontal-panel%, but reverse
+  ;; "horizontal" and "vertical."
+  (define (wx-make-vertical-panel% wx-linear-panel%)
+    (class100 wx-linear-panel% args
+      (inherit major-align minor-align do-align do-get-alignment major-offset minor-offset
+	       spacing border do-graphical-size place-linear-children check-place-children)
+      (override
+	[alignment (lambda (h v) (do-align h v 
+					   (lambda (x) (minor-align x)) 
+					   (lambda (x) (major-align x))))]
+	[get-alignment (lambda () (do-get-alignment (lambda (x y) y)))]
+
+	[do-get-graphical-min-size
+	 (lambda ()
+	   (do-graphical-size
+	    (lambda (x-accum kid-info hidden?)
+	      (max x-accum
+		   (+ (child-info-x-min (car kid-info))
+		      (* 2 (border)))))
+	    (lambda (y-accum kid-info hidden?)
+	      (+ y-accum (child-info-y-min (car kid-info))
+		 (if (or (null? (cdr kid-info)) hidden?)
+		     0
+		     (spacing))))))]
+	
+	[do-place-children
+	 (lambda (l w h)
+	   (check-place-children l w h)
+	   (place-linear-children l w h
+				  cadr   ; child-info-y-min
+				  cadddr ; child-info-y-stretch
+				  (lambda (s) (major-offset s))
+				  car    ; child-info-x-min
+				  caddr  ; child-info-x-stretch
+				  (lambda (s t) (minor-offset s t))
+				  (lambda (width height) height)
+				  (lambda (width height) width)
+				  (lambda (major minor) minor)
+				  (lambda (major minor) major)))])
+      (sequence (apply super-init args))))
+
+  (define wx-panel% (wx-make-panel% wx:panel%))
+  (define wx-linear-panel% (wx-make-linear-panel% wx-panel%))
+  (define wx-horizontal-panel% (wx-make-horizontal-panel% wx-linear-panel%))
+  (define wx-vertical-panel% (wx-make-vertical-panel% wx-linear-panel%))
+
+  (define wx-pane% (wx-make-pane% wx:windowless-panel% #t))
+  (define wx-grow-box-pane%
+    (class100 (wx-make-pane% wx:windowless-panel% #f) (mred proxy parent style)
+      (override
+	[init-min (lambda (x) (if (or (eq? (system-type) 'macos)
+				      (eq? (system-type) 'macosx))
+				  15
+				  0))])
+      (sequence
+	(super-init mred proxy parent style))))
+  (define wx-linear-pane% (wx-make-linear-panel% wx-pane%))
+  (define wx-horizontal-pane% (wx-make-horizontal-panel% wx-linear-pane%))
+  (define wx-vertical-pane% (wx-make-vertical-panel% wx-linear-pane%)))
diff --git a/collects/mred/private/wxtabgroup.ss b/collects/mred/private/wxtabgroup.ss
new file mode 100644
index 0000000000..0381e3a079
--- /dev/null
+++ b/collects/mred/private/wxtabgroup.ss
@@ -0,0 +1,425 @@
+(module wxtabgroup mzscheme
+  (require (lib "class.ss")
+	   (lib "class100.ss")
+	   (prefix wx: "kernel.ss")
+	   "lock.ss"
+	   "wx.ss"
+	   "const.ss"
+	   "gdi.ss"
+	   "helper.ss"
+	   "wxwindow.ss"
+	   "wxitem.ss"
+	   "wxcanvas.ss")
+
+  (provide (protect wx-tab-group%
+		    canvas-based-tab-group%))
+
+  (define mac-tab? (eq? 'macosx (system-type)))
+
+  (define tab-v-space 2)
+  (define raise-h (if mac-tab? 0 2))
+
+  (define canvas-based-tab-group%
+    (class* wx-canvas% (wx-tab-group<%>)
+      (init mred proxy style parent call-back label tab-labels style-again _font)
+      
+      (define callback call-back)
+
+      (define tabs (map wx:label->plain-label tab-labels))
+      (define tab-widths #f)
+      (define tab-height #f)
+
+      (define current-focus-tab 0)
+      
+      (define font (or _font normal-control-font))
+      
+      (inherit get-dc get-client-size get-mred
+	       set-min-width set-min-height
+	       set-tab-focus set-focus has-focus?
+	       set-background-to-gray refresh
+	       get-top-level is-enabled-to-root?)
+      
+      (define selected 0)
+      (define tracking-pos #f)
+      (define tracking-hit? #f)
+      
+      (define regions #f)
+      (define redo-regions? #f)
+
+      (define border? (memq 'border style))
+
+      (define/private (compute-sizes)
+	(let ([dc (get-dc)])
+	  (let ([w+hs (map (lambda (lbl)
+			     (let-values ([(w h d a) (send dc get-text-extent lbl font)])
+			       (cons w h)))
+			   tabs)])
+	    (set! tab-widths (map car w+hs))
+	    (if mac-tab?
+		(set! tab-height (+ 27 (send font get-point-size) -13))
+		(let-values ([(sw sh sd sa) (send dc get-text-extent " " font)])
+		  (let ([th (ceiling (+ (* 2 tab-v-space) (apply max 0 sh (map cdr w+hs))))])
+		    (set! tab-height (if (even? th) th (add1 th)))))))))
+      
+      (define/private (get-total-width)
+	(compute-sizes)
+	(apply + 
+	       (if mac-tab? 0 tab-height)
+	       (* (length tabs) (+ raise-h raise-h tab-height)) 
+	       tab-widths))
+      
+      (define/private (get-init-x)
+	(if border?
+	    (let-values ([(w h) (my-get-client-size)]
+			 [(tw) (get-total-width)])
+	      (/ (- w tw) 2))
+	    (if mac-tab?
+		2
+		0)))
+
+      (define/override (on-char e) (void))
+
+      (define/override on-event
+	(entry-point
+	 (lambda (e)
+	   (cond
+	    [(and (send e button-down?) tab-widths)
+	     (set! tracking-pos (find-click (send e get-x) (send e get-y)))
+	     (when tracking-pos
+	       (set! current-focus-tab tracking-pos)
+	       (set! tracking-hit? #t)
+	       (update-tracking))]
+	    [(and (send e dragging?) tracking-pos)
+	     (let ([hit? (equal? tracking-pos (find-click (send e get-x) (send e get-y)))])
+	       (unless (eq? tracking-hit? hit?)
+		 (set! tracking-hit? hit?)
+		 (update-tracking)))]
+	    [(and (send e button-up?) tracking-pos
+		  (equal? tracking-pos (find-click (send e get-x) (send e get-y)))
+		  (not (= tracking-pos selected)))
+	     ;; Button released for final selection
+	     (let ([new tracking-pos])
+	       (set! tracking-pos #f)
+	       (set! tracking-hit? #f)
+	       (set-selection new)
+	       (as-exit
+		(lambda ()
+		  (callback this (make-object wx:control-event% 'tab-panel)))))]
+	    ;; otherwise, turn off tracking...
+	    [else
+	     (when tracking-hit?
+	       (set! tracking-hit? #f)
+	       (update-tracking))
+	     (set! tracking-pos #f)]))))
+      
+      (define/private (update-tracking)
+	(if mac-tab?
+	    (refresh)
+	    (let ([dc (get-dc)])
+	      (send dc set-clipping-region (list-ref regions tracking-pos))
+	      (on-paint)
+	      (send dc set-clipping-region #f))))
+	
+      (define tmp-rgn #f)
+
+      (define/public (button-focus n)
+	(if (< n 0)
+	    current-focus-tab
+	    (begin
+	      (set! current-focus-tab n)
+	      (refresh)
+	      (set-focus)
+	      current-focus-tab)))
+
+      (define/override on-set-focus
+	(lambda ()
+	  (refresh)
+	  (super on-set-focus)))
+      (define/override on-kill-focus
+	(lambda ()
+	  (refresh)
+	  (super on-kill-focus)))
+      
+      (define/private (find-click x y)
+	(ready-regions)
+	(unless tmp-rgn
+	  (set! tmp-rgn (make-object wx:region% (get-dc))))
+	(let loop ([rl regions][pos 0])
+	  (if (null? rl)
+	      #f
+	      (begin
+		(send tmp-rgn set-rectangle x y 1 1)
+		(send tmp-rgn intersect (car rl))
+		(if (send tmp-rgn is-empty?)
+		    (loop (cdr rl) (add1 pos))
+		    pos)))))
+      
+      (define/private (setup-regions)
+	(let ([dc (get-dc)])
+	  (set! regions
+		(map (lambda (tpl r)
+		       (let ([points (map (lambda (p) (make-object wx:point% (car p) (+ 2 raise-h (cadr p))))
+					  tpl)])
+			 (send r set-polygon points))
+		       r)
+		     (draw-once #f 0 #f #f 0 #f)
+		     (if regions
+			 regions
+			 (map (lambda (x)
+				(make-object wx:region% dc))
+			      tabs))))
+	  (set! redo-regions? #f)))
+
+      (define/private (ready-regions)
+	(compute-sizes)
+	(unless (and regions (not redo-regions?)) 
+	  (setup-regions)))
+
+      (define/override (gets-focus?) #t)    
+      (define/override (tabbing-position x y w h)
+	(list this (+ x (get-init-x)) y (get-total-width) tab-height))
+      (define/public (number) (length tabs))
+      
+      ;; Returns a list of point lists, which define polygons for hit-testing
+      ;;  and updating
+      (define/private (draw-once dc w light? dark? inset active?)
+	(let ([init-x (get-init-x)])
+	  (let loop ([x init-x][l tabs][wl tab-widths][pos 0])
+	    (if (null? l)
+		null
+		(let ([next-x (+ x tab-height (car wl))]
+		      [-sel-d (if (= pos selected) (- raise-h) 0)])
+		  (cons
+		   (if mac-tab?
+		       ;; ----- Mac drawing -----
+		       (let ([w (+ tab-height (car wl))]
+			     [h tab-height])
+			 (when dc
+			   (when (eq? dark? (= pos selected))
+			     (wx:draw-tab 
+			      dc
+			      (car l) x 3 w (- tab-height 3)
+			      (+ (if (and (has-focus?)
+					  (= pos current-focus-tab))
+				     ;; Adding 100 means "draw focus ring"
+				     100
+				     ;; No focus
+				     0)
+				 ;; Pick the style: active and front, etc.
+				 (if (and light?
+					  (eq? pos tracking-pos))
+				     1
+				     (if active?
+					 (if dark? 3 0)
+					 (if dark? 4 2)))))))
+			 (list (list x 3) (list (+ x w) 3)
+			       (list (+ x w) (- tab-height 6)) (list x (- tab-height 6))))
+		       ;; ----- X-style drawing -----
+		       (append
+			;; start point
+			(list (list (+ x tab-height -sel-d inset) (+ 2 tab-height (- inset))))
+			;; left line
+			(begin
+			  (when (= pos selected)
+			    (when light?
+			      (send dc set-pen border-pen)
+			      (send dc draw-line 0 tab-height (sub1 x) tab-height)
+			      (send dc set-pen light-pen)
+			      (send dc draw-line 0 (add1 tab-height) (sub1 x) (add1 tab-height))))
+			  (let ([short (if (or (= pos 0) (= pos selected))
+					   0
+					   (+ (/ tab-height 2) 
+					      (if (= selected (sub1 pos))
+						  raise-h
+						  0)))])
+			    (when light?
+			      (send dc set-pen border-pen)
+			      (send dc draw-line (+ x short -sel-d) (- tab-height short) (+ x tab-height) -sel-d)
+			      (send dc set-pen light-pen)
+			      (send dc draw-line (+ x short -sel-d 1) (- tab-height short) (+ x tab-height 1) -sel-d))
+			    (list (list (+ x short -sel-d -2 inset) (- tab-height short -2 inset))
+				  (list (+ x tab-height inset) (+ -sel-d inset)))))
+			;; top line
+			(begin
+			  (when light?
+			    (send dc set-pen border-pen)
+			    (send dc draw-line (+ x tab-height) -sel-d next-x -sel-d)
+			    (send dc set-pen light-pen)
+			    (send dc draw-line (+ x tab-height) (+ 1 -sel-d) next-x (+ 1 -sel-d)))
+			  (list (list (+ 1 next-x (- inset)) (+ inset -sel-d))))
+			;; right line
+			(let* ([short (if (= (add1 pos) selected)
+					  (+ (/ tab-height 2) (sub1 raise-h))
+					  0)]
+			       [short-d (if (zero? short) 0 -1)])
+			  (when dark?
+			    (send dc set-pen border-pen)
+			    (send dc draw-line next-x (+ -sel-d 1) 
+				  (- (+ next-x tab-height) short 2 -sel-d short-d) (- tab-height short 1 short-d))
+			    (send dc set-pen dark-pen)
+			    (send dc draw-line (+ 1 next-x) (+ -sel-d 1) (- (+ next-x tab-height) short 1 -sel-d) (- tab-height short 1)))
+			  (list (list (- (+ next-x tab-height) -sel-d short (- short-d) -2 inset) (- tab-height short -2 inset))))
+			;; end point
+			(begin
+			  (when light?
+			    (when (= pos selected)
+			      (send dc set-pen border-pen)
+			      (send dc draw-line (+ next-x tab-height) tab-height w tab-height)
+			      (send dc set-pen light-pen)
+			      (send dc draw-line (+ next-x tab-height) (add1 tab-height) w (add1 tab-height)))
+			    (let ([x (+ x tab-height)]
+				  [y (- tab-v-space (if (= pos selected) raise-h 0))])
+			      (send dc set-text-foreground
+				    (if (is-enabled-to-root?)
+					black-color
+					disabled-color))
+			      (send dc draw-text (car l) x y)
+			      (when (and (has-focus?)
+					 (= pos current-focus-tab))
+				(let ([p (send dc get-pen)])
+				  (send dc set-pen "black" 1 'hilite)
+				  (let ([x (- x 1)]
+					[y (+ y 2)]
+					[w (+ (car wl) 2)]
+					[h (- tab-height (* 2 tab-v-space) 2)])
+				    (send dc draw-line (+ x 0) (+ y -1) (+ x w -1) (+ y -1))
+				    (send dc draw-line (+ x 0) (+ y h) (+ x w -1) (+ y h))
+				    (send dc draw-line (+ x -1) (+ y 0) (+ x -1) (+ y h -1))
+				    (send dc draw-line (+ x w) (+ y 0) (+ x w) (+ y h -1)))
+				  (send dc set-pen p)))))
+			  (list (list (+ next-x inset (if (= selected (add1 pos)) -2 0)) (+ 2 tab-height (- inset)))))))
+		   (loop next-x (cdr l) (cdr wl) (add1 pos))))))))
+
+      
+      (define/override on-paint
+	(entry-point
+	 (lambda ()
+	   (compute-sizes)
+	   (let ([dc (get-dc)]
+		 [active? (and (is-enabled-to-root?)
+			       (send (get-top-level) is-act-on?))])
+	     (send dc set-background bg-color)
+	     (send dc set-font font)
+	     (unless mac-tab?
+	       (send dc clear)
+	       (send dc set-origin 0 (+ 2 raise-h))
+	       (when (and tracking-pos tracking-hit?)
+		 (let ([b (send dc get-brush)])
+		   (send dc set-brush dark-brush)
+		   (send dc set-pen trans-pen)
+		   (send dc draw-polygon (map (lambda (x) (make-object wx:point% (car x) (cadr x)))
+					      (list-ref (draw-once #f 0 #f #f 1 #f) tracking-pos)))
+		   (send dc set-brush b))))
+	     (let-values ([(w h) (my-get-client-size)])
+	       (unless mac-tab?
+		 (send dc set-pen light-pen))
+	       (draw-once dc w #t #f 0 active?)
+	       (when mac-tab?
+		 (wx:draw-tab-base dc 0 (- tab-height 3) w 6 (if active? 1 0)))
+	       (when border?
+		 (when (> h tab-height)
+		   (send dc draw-line 1 (add1 tab-height) 1 h)
+		   (send dc set-pen border-pen)
+		   (send dc draw-line 0 tab-height 0 h)))
+	       (unless mac-tab?
+		 (send dc set-pen dark-pen))
+	       (draw-once dc w #f #t 0 active?)
+	       (when border?
+		 (when (> h tab-height)
+		   (send dc draw-line (- w 2) (+ 1 tab-height) (- w 2) (- h raise-h))
+		   (send dc draw-line 1 (- h 4 raise-h) w (- h 4 raise-h))
+		   (send dc set-pen border-pen)
+		   (send dc draw-line (- w 1) tab-height (- w 1) (- h raise-h))
+		   (send dc draw-line 0 (- h 3 raise-h) w (- h 3 raise-h)))))
+	     (send dc set-origin 0 0)))))
+
+      (define/override (on-size w h)
+	(set! redo-regions? #t)
+	(super on-size w h))
+
+      (define/private (my-get-client-size)
+	(get-two-int-values (lambda (a b) (get-client-size a b))))
+      
+      (define/public (get-selection)
+	selected)
+
+      (define/public (set-selection i)
+	(ready-regions)
+	(when (< -1 i (length regions))
+	  (let* ([dc (get-dc)]
+		 [r (make-object wx:region% dc)]
+		 [old-rgn (list-ref regions selected)])
+	    (set! selected i)
+	    (send r union old-rgn)
+	    (setup-regions)
+	    (if mac-tab?
+		(refresh) ;; but we need an immediate refresh!
+		(let ([new-rgn (list-ref regions selected)])
+		  ;; Union the new and old regions and repaint:
+		  (send r union new-rgn)
+		  (send dc set-clipping-region r)
+		  (on-paint)
+		  (send dc set-clipping-region #f))))))
+
+      (define/public (set-label i s)
+	(set-car! (list-tail tabs i) (wx:label->plain-label s))
+	(set! tab-widths #f)
+	(set! regions #f)
+	(refresh))
+
+      (define/public (set tab-labels)
+	(set! tabs (map wx:label->plain-label tab-labels))
+	(set! tab-widths #f)
+	(set! regions #f)
+	(set! selected (max 0 (min selected (sub1 (length tabs)))))
+	(refresh))
+
+      (define (-append s)
+	(set! tabs (append tabs (list (wx:label->plain-label s))))
+	(set! tab-widths #f)
+	(set! regions #f)
+	(refresh))
+      (public (-append append))
+
+      (define/public (delete i)
+	(set! tabs (let loop ([pos 0][tabs tabs])
+		     (if (= i pos)
+			 (cdr tabs)
+			 (cons (car tabs) (loop (add1 pos) (cdr tabs))))))
+	(set! selected (min (if (selected . <= . i)
+				selected
+				(sub1 selected))
+			    (max 0 (sub1 (length tabs)))))
+	(set! regions #f)
+	(set! tab-widths #f)
+	(refresh))
+      
+      (define/override (handles-key-code code alpha? meta?) 
+	#f)
+
+      (super-instantiate (mred proxy parent -1 -1 -1 -1 '(transparent) #f))
+      
+      (let ([focus-ok? 
+	     ;; For Mac OS X, this method indicates that the
+	     ;;  canvas should not necessarily get the focus
+	     ;;  on a click, and the result indicates whether
+	     ;;  it should accept tab focus in general
+	     (set-background-to-gray)])
+
+	(compute-sizes)
+	(set-min-width (inexact->exact (ceiling (get-total-width))))
+	(set-min-height (inexact->exact (ceiling (+ tab-height (if mac-tab? 6 9) raise-h))))
+	(when mac-tab?
+	  (send (get-top-level) add-activate-update this))
+	(set-tab-focus focus-ok?))))
+
+  (define wx-tab-group% 
+    (if (eq? 'unix (system-type))
+	canvas-based-tab-group%
+	(class* (make-window-glue%
+		 (make-control% wx:tab-group% 0 0 #t #t)) (wx-tab-group<%>)
+	  (inherit min-height)
+	  (define/override (tabbing-position x y w h)
+	    (list this x y w (min-height)))
+	  (define/override (handles-key-code code alpha? meta?) #f)
+	  (super-instantiate ())))))
diff --git a/collects/mred/private/wxtextfield.ss b/collects/mred/private/wxtextfield.ss
new file mode 100644
index 0000000000..bd95079330
--- /dev/null
+++ b/collects/mred/private/wxtextfield.ss
@@ -0,0 +1,233 @@
+(module wxtextfield mzscheme
+  (require (lib "class.ss")
+	   (lib "class100.ss")
+	   (prefix wx: "kernel.ss")
+	   "lock.ss"
+	   "const.ss"
+	   "check.ss"
+	   "helper.ss"
+	   "gdi.ss"
+	   "wx.ss"
+	   "wxwindow.ss"
+	   "wxitem.ss"
+	   "wxcanvas.ss"
+	   "wxpanel.ss"
+	   "editor.ss"
+	   "mrpopup.ss")
+
+  (provide (protect wx-text-field%))
+
+  (define text-field-text% 
+    (class100 text% (cb ret-cb control set-cb-mgrs!)
+      (rename [super-on-char on-char])
+      (inherit get-text last-position)
+      (private-field
+       [return-cb ret-cb])
+      (private-field
+       [block-callback 1]
+       [callback
+	(lambda (type)
+	  (when (zero? block-callback)
+	    (let ([e (make-object wx:control-event% type)])
+	      (as-exit (lambda ()
+			 (cb control e))))))])
+      (override
+	[on-char
+	 (entry-point
+	  (lambda (e)
+	    (let ([c (send e get-key-code)])
+	      (unless (and (or (eq? c #\return) (eq? c #\newline))
+			   return-cb
+			   (return-cb (lambda () (callback 'text-field-enter) #t)))
+		(as-exit (lambda () (super-on-char e)))))))])
+      (augment
+       [after-insert
+	(lambda args
+	  (as-entry
+	   (lambda ()
+	     (callback 'text-field))))]
+       [after-delete
+	(lambda args
+	  (as-entry
+	   (lambda ()
+	     (callback 'text-field))))])
+      (sequence
+	(set-cb-mgrs!
+	 (lambda (thunk)
+	   (dynamic-wind
+	       (lambda () (set! block-callback (add1 block-callback)))
+	       thunk
+	       (lambda () (set! block-callback (sub1 block-callback)))))
+	 (lambda () 
+	   (set! block-callback 0)))
+	(super-init))))
+  
+  (define wx-text-editor-canvas% 
+    (class100* wx-editor-canvas% (wx-text-editor-canvas<%>) (mred proxy control parent style)
+      (sequence
+	(super-init mred proxy parent -1 -1 100 30 #f style 100 #f))))
+
+  (define wx-text-field%
+    (class100 wx-horizontal-panel% (mred proxy parent fun label value style _font)
+      ;; Make text field first because we'll have to exit
+      ;;  for keymap initializer
+      (private-field
+       [func fun]
+       [font (or _font normal-control-font)]
+       [without-callback #f]
+       [callback-ready #f]
+       [e (make-object text-field-text%
+		       func
+		       (lambda (do-cb)
+			 (if multi?
+			     #f
+			     (do-cb)))
+		       this
+		       (lambda (wc cr)
+			 (set! without-callback wc)
+			 (set! callback-ready cr)))])
+      (sequence
+	(as-exit
+	 (lambda ()
+	   ((current-text-keymap-initializer) (send e get-keymap)))))
+      (inherit alignment stretchable-in-y area-parent
+	       get-min-size set-min-width set-min-height)
+      (rename [super-place-children place-children])
+      (public
+	[command (lambda (e)  ; No entry/exit needed
+		   (check-instance '(method text-field% command) wx:control-event% 'control-event% #f e)
+		   (func this e)
+		   (void))]
+
+	[get-editor (lambda () e)]
+	
+	[get-value (lambda () (send e get-text))] ; note: not as-entry when called
+	[set-value (lambda (v) (without-callback
+				(lambda () (send e insert v 0 (send e last-position)))))]
+
+	[set-label (lambda (str) (when l (send l set-label str)))]
+	[get-canvas-width (lambda ()
+			    (let ([tw (box 0)])
+			      (send c get-size tw (box 0))
+			      (unbox tw)))])
+      (override
+	;; These might be called before we are fully initialized
+
+	[set-cursor (lambda (c) (send e set-cursor c #t))]
+	[set-focus (lambda () (when (object? c) (send c set-focus)))]
+	
+	[place-children
+	 (lambda (children-info width height)
+	   (if (null? children-info)
+	       null
+	       (let ([r (super-place-children children-info width height)])
+		 (if horiz?
+		     ;; Line up label right with text:
+		     (cons (list* (caar r) (+ (cadar r) dy) (cddar r))
+			   (cdr r))
+		     r))))])
+      (sequence
+	(super-init #f proxy parent (if (memq 'deleted style) '(deleted) null))
+	(unless (memq 'deleted style)
+	  (send (area-parent) add-child this)))
+      (private-field
+       [multi? (memq 'multiple style)]
+       [horiz? (cond
+		[(memq 'vertical-label style) #f]
+		[(memq 'horizontal-label style) #t]
+		[else (eq? (send (send parent get-window) get-label-position) 'horizontal)])]
+       [dy 0]
+       [p (if horiz?
+	      this
+	      (let ([p (make-object wx-vertical-pane% #f proxy this null)])
+		(send (send p area-parent) add-child p)
+		p))])
+      (sequence
+	(alignment 'left 'top)
+	(unless horiz? (send p alignment 'left 'top))
+	(unless multi? (stretchable-in-y #f))
+	;; For Windows:
+	(wx:set-combo-box-font font))
+      (private-field
+       [l (and label
+	       (make-object wx-message% #f proxy p label -1 -1 null font))]
+       [c (make-object wx-text-editor-canvas% #f proxy this p
+		       (append
+			'(control-border)
+			(if (memq 'combo style)
+			    '(combo)
+			    null)
+			(if multi?
+			    (if (memq 'hscroll style)
+				null
+				'(hide-hscroll))
+			    '(hide-vscroll hide-hscroll))))])
+      (sequence
+	(when l
+	  (send l x-margin 0))
+	(send c set-x-margin 2)
+	(send c set-y-margin 2)
+	(send e set-line-spacing 0)
+	(send e set-paste-text-only #t)
+	(send e auto-wrap (and multi? (not (memq 'hscroll style))))
+	(let ([f font]
+	      [s (send (send e get-style-list) find-named-style "Standard")])
+	  (send s set-delta (let ([d (font->delta f)])
+			      (if (memq 'password style)
+				  (begin
+				    (send d set-face #f)
+				    (send d set-family 'modern)
+				    (send d set-delta-foreground "darkgray")
+				    (send d set-delta-background "darkgray"))
+				  d))))
+	(send c set-editor e)
+	(send c set-line-count (if multi? 3 1))
+	(unless multi? (send c set-single-line))
+
+	(when (and l horiz?)
+	  ;; Minimize vertical space around the label:
+	  (send l y-margin 0)
+	  ;; Find amount to drop label down to line up the baselines:
+	  (let ([wbox (box 0)]
+		[hbox (box 0)]
+		[ybox (box 0)]
+		[abox (box 0)])
+	    ;; To bottom of first line
+	    (send (send e get-admin) get-dc #f ybox)
+	    (set! dy (+ (abs (unbox ybox)) (send e line-location 0 #f)))
+	    
+	    ;; Add diff for client size
+	    (send c get-client-size wbox hbox)
+	    (let ([d (- (send c get-height) (unbox hbox))])
+	      (set! dy (+ dy (quotient d 2))))
+	    
+	    ;; Subtract descent of canvas-drawn text
+	    (let ([font (send (send (send e get-style-list) find-named-style "Standard") get-font)])
+	      (send c get-text-extent "hi" wbox hbox ybox #f font)
+	      (set! dy (- dy (unbox ybox))))
+	    
+	    ;; Subtract ascent of label
+	    (send l get-text-extent "hi" wbox hbox ybox abox)
+	    (set! dy (- dy (- (unbox hbox) (unbox ybox))))
+	    
+	    ;; Subtract space above label
+	    (set! dy (- dy (quotient (- (send l get-height) (unbox hbox)) 2)))
+
+	    ;; Exact
+	    (set! dy (inexact->exact dy))))
+	
+	(when value
+	  (set-value value)
+	  (unless (string=? value "")
+	    (let* ([ew (box 0)]
+		   [cw (box 0)]
+		   [tw (box 0)])
+	      (send e get-extent ew #f)
+	      (send (send e get-admin) get-view #f #f cw #f)
+	      (send c get-size tw (box 0))
+	      (let ([new-min-width (+ (unbox ew) (- (unbox tw) (unbox cw)))])
+		(send c set-min-width (inexact->exact new-min-width))))))
+	(let ([min-size (get-min-size)])
+	  (set-min-width (car min-size))
+	  (set-min-height (cadr min-size)))
+	(callback-ready)))))
diff --git a/collects/mred/private/wxtop.ss b/collects/mred/private/wxtop.ss
new file mode 100644
index 0000000000..80bcfcf12f
--- /dev/null
+++ b/collects/mred/private/wxtop.ss
@@ -0,0 +1,651 @@
+(module wxtop mzscheme
+  (require (lib "class.ss")
+	   (lib "class100.ss")
+	   (lib "etc.ss")
+	   (lib "list.ss")
+	   (prefix wx: "kernel.ss")
+	   "lock.ss"
+	   "helper.ss"
+	   "const.ss"
+	   "kw.ss"
+	   "check.ss"
+	   "wx.ss"
+	   "wxwindow.ss"
+	   "wxcontainer.ss")
+
+  (provide (protect active-main-frame)
+	   get-display-size
+	   get-display-left-top-inset
+	   (protect make-top-container%
+		    make-top-level-window-glue%
+		    wx-frame%
+		    wx-dialog%))
+
+  ;; Weak boxed:
+  (define active-main-frame (make-weak-box #f))
+
+  (define get-display-size
+    (opt-lambda ([full-screen? #f])
+      (let ([xb (box 0)]
+	    [yb (box 0)])
+	(wx:display-size xb yb (if full-screen? 1 0))
+	(values (unbox xb) (unbox yb)))))
+
+  (define (get-display-left-top-inset)
+    (let ([xb (box 0)]
+	  [yb (box 0)])
+      (wx:display-origin xb yb)
+      (values (unbox xb) (unbox yb))))
+  
+  (define top-x 1)
+  (define top-y 1)
+  (define top-level-windows (make-hash-table 'weak))
+  
+  ;; make-top-container%: adds the necessary functionality to wx:frame% and 
+  ;; wx:dialog%.
+  ;; input: base%: the base class from which to descend the new class.
+  ;;          Intended to be either wx:frame% or wx:dialog%, but can
+  ;;          be anything which contains all methods in the inherit section
+  ;;          below.
+  ;; returns: a new class, descended from base%, which possesses the added
+  ;;            capabilities necessary to serve as the frame/dialog which
+  ;;            contains container classes.
+  (define (make-top-container% base% dlg?)
+    (class100 (wx-make-container% (wx-make-window% base% #t)) (parent . args)
+      (inherit get-x get-y get-width get-height set-size
+	       get-client-size is-shown? on-close enforce-size)
+      (private-field
+       ;; have we had any redraw requests while the window has been
+       ;; hidden?
+       [pending-redraws? #t]
+
+       [perform-updates? #t]
+       [seq-count 0]
+       
+       [ignore-redraw-request? #f]
+       
+       [already-trying? #f]
+       [was-bad? #f] ; hack around min-frame-size limitations
+       [last-width -1]
+       [last-height -1]
+       
+       ;; pointer to panel in the frame for use in on-size
+       [panel #f]
+
+       [use-default-position? (and (= -11111 (list-ref args 2))
+				   (= -11111 (list-ref args (if dlg? 3 1))))]
+       
+       [enabled? #t]
+       [focus #f]
+       [target #f]
+
+       [border-buttons null]
+
+       [show-ht (make-hash-table)])
+      
+      (override
+	[enable
+	 (lambda (b)
+	   (set! enabled? (and b #t))
+	   (super enable b))])
+      (private-field
+       [eventspace (if parent
+		       (send parent get-eventspace)
+		       (wx:current-eventspace))])
+
+      (public
+	[get-eventspace (lambda () eventspace)]
+
+	[is-enabled?
+	 (lambda () enabled?)]
+
+	[set-focus-window
+	 (lambda (w)
+	   (unless (eq? 'macosx (system-type))
+	     (set! border-buttons (filter weak-box-value border-buttons))
+	     (if (not w)
+		 ;; Non-border button losing focus?
+		 (when (and (focus . is-a? . wx:button%)
+			    (not (memq focus (map weak-box-value border-buttons))))
+		   (send focus defaulting #f))
+		 ;; Something gaining focus... adjust border buttons
+		 (begin
+		   (for-each (lambda (bb)
+			       (let ([b (weak-box-value bb)])
+				 (when b
+				   (send b defaulting (or (not (w . is-a? . wx:button%))
+							  (eq? b w))))))
+			     border-buttons)
+		   (when (w . is-a? . wx:button%)
+		     (send w defaulting #t)))))
+	   (set! focus w)
+	   (when w
+	     (set! target w)))]
+	
+	[get-focus-window
+	 (lambda () focus)]
+	[get-edit-target-window
+	 (lambda () (and target (send (wx->proxy target) is-shown?) target))]
+	[get-focus-object
+	 (lambda ()
+	   (window->focus-object focus))]
+	[get-edit-target-object
+	 (lambda ()
+	   (window->focus-object target))]
+
+	[window->focus-object
+	 (lambda (w)
+	   (and w
+		(if (is-a? w wx:editor-canvas%)
+		    (let loop ([m (send w get-editor)]
+			       [prev w])
+		      (if m
+			  (let ([snip (send m get-focus-snip)])
+			    (if (and snip (is-a? snip wx:editor-snip%))
+				(loop (send snip get-editor) m)
+				m))
+			  w))
+		    focus)))]
+
+	[add-border-button
+	 (lambda (b)
+	   (set! border-buttons (filter weak-box-value border-buttons))
+	   (set! border-buttons (cons (make-weak-box b) border-buttons)))]
+
+	;; add-child: update panel pointer.
+	;; input: new-panel: panel in frame (descendant of
+	;;   panel%) 
+	;; returns: nothing
+	;; effects: sets panel to new-panel
+	;;          if new-panel is not a descendant of
+	;;            panel%, calls error; panel not updated.
+	[add-child
+	 (lambda (new-panel)
+	   (set! panel new-panel)
+	   (set! pending-redraws? #t)
+	   (let-values ([(client-w client-h)
+			 (get-two-int-values (lambda (a b) (get-client-size a b)))])
+	     (send panel set-size 0 0 client-w client-h))
+	   (self-redraw-request))]
+
+	[area-parent (lambda () #f)]
+	
+	[get-top-panel
+	 (lambda ()
+	   panel)]
+
+	[delay-updates
+	 (case-lambda
+	  [() (not perform-updates?)]
+	  [(f) 
+	   (set! perform-updates? (not f))
+	   (when perform-updates?
+	     (when pending-redraws?
+	       (force-redraw))
+	     (when (positive? (hash-table-count show-ht))
+	       (let ([t show-ht])
+		 (set! show-ht (make-hash-table))
+		 (hash-table-for-each
+		  t
+		  (lambda (win v?)
+		    (send win show v?))))))])]
+	[begin-container-sequence
+	 (lambda ()
+	   (when (zero? seq-count)
+	     (delay-updates #t))
+	   (set! seq-count (add1 seq-count)))]
+	[end-container-sequence
+	 (lambda ()
+	   (set! seq-count (sub1 seq-count))
+	   (when (zero? seq-count)
+	     (delay-updates #f)))]
+
+	[show-child
+	 (lambda (child show?)
+	   (if perform-updates?
+	       (send child show show?)
+	       (hash-table-put! show-ht child show?)))]
+
+	;; force-redraw: receives a message from to redraw the
+	;; entire frame.
+	;; input: none
+	;; returns: nothing
+	;; effects: redraws the frame at its current size (changing size
+	;;            as necessary).
+	[child-redraw-request
+	 ;; since there's only one panel, we assume that `from' is the
+	 ;; panel and the request should be granted
+	 (lambda (from) 
+	   (unless ignore-redraw-request?
+	     (self-redraw-request)))]
+	[self-redraw-request
+	 (lambda ()
+	   (if (and (is-shown?) perform-updates?)
+	       (force-redraw)
+	       (set! pending-redraws? #t)))]
+	[force-redraw
+	 (lambda ()
+	   (if panel
+	       (dynamic-wind
+		   (lambda () (set! ignore-redraw-request? #t))
+		   (lambda () (resized))
+		   (lambda () (set! ignore-redraw-request? #f)))
+	       
+	       (set! pending-redraws? #f)))]
+
+	[correct-size
+	 (lambda (frame-w frame-h)
+	   (if (not panel)
+	       (values frame-w frame-h)
+	       (let-values ([(f-client-w f-client-h) (get-two-int-values 
+						      (lambda (a b) (get-client-size a b)))])
+		 (let* ([panel-info (send panel get-info)]
+			
+			;; difference between panel's full size & 
+			;; frame's full size
+			[delta-w (max 0 (- (get-width) f-client-w))]
+			[delta-h (max 0 (- (get-height) f-client-h))]
+
+			;; minimum frame size:
+			[min-w (+ delta-w (child-info-x-min panel-info))]
+			[min-h (+ delta-h (child-info-y-min panel-info))]
+			
+			;; correct size for frame
+			[new-w
+			 (cond
+			  [(< frame-w min-w) min-w]
+			  [(and (> frame-w min-w) (not (child-info-x-stretch panel-info))) min-w]
+			  [else frame-w])]
+			[new-h
+			 (cond
+			  [(< frame-h min-h) min-h]
+			  [(and (> frame-h min-h) (not (child-info-y-stretch panel-info))) min-h]
+			  [else frame-h])])
+		   (values (max new-w 1) (max new-h 1)
+			   (max min-w 1) (max min-h 1)
+			   (child-info-x-stretch panel-info) (child-info-y-stretch panel-info))))))]
+
+	[set-panel-size
+	 (lambda ()
+	   (when panel
+	     (let-values ([(f-client-w f-client-h) (get-two-int-values 
+						    (lambda (a b) (get-client-size a b)))]
+			  [(panel-info) (send panel get-info)]
+			  [(sel) (lambda (nsize psize stretch?)
+				   (if stretch?
+				       (max nsize psize)
+				       psize))])
+	       (send panel set-size 0 0 
+		     (sel f-client-w (child-info-x-min panel-info)
+			  (child-info-x-stretch panel-info))
+		     (sel f-client-h (child-info-y-min panel-info)
+			  (child-info-y-stretch panel-info)))
+	       (set! pending-redraws? #f)
+	       (send panel on-container-resize))))]
+
+
+	[resized
+	 (entry-point
+	  (lambda ()
+	    (unless already-trying?
+	      (let ([new-width (get-width)]
+		    [new-height (get-height)])
+		(let-values ([(correct-w correct-h min-w min-h sx? sy?) (correct-size new-width new-height)])
+		  (cond
+		   [(and (= new-width correct-w) (= new-height correct-h))
+		    ;; Good size; do panel
+		    (set! was-bad? #f)
+		    (enforce-size min-w min-h
+				  (if sx? -1 min-w) (if sy? -1 min-h)
+				  1 1)
+		    (set-panel-size)]
+		   [(and (= last-width correct-w) (= last-height correct-h)
+			 was-bad?)
+		    ;; We give up; do panel
+		    (set-panel-size)]
+		   [else
+		    ;; Too large/small; try to fix it, but give up after a while
+		    (set! was-bad? #t)
+		    (set! last-width correct-w)
+		    (set! last-height correct-h)
+		    (set! already-trying? #t)
+		    (enforce-size -1 -1 -1 -1 1 1)
+		    (set-size -1 -1 correct-w correct-h)
+		    (enforce-size min-w min-h
+				  (if sx? -1 min-w) (if sy? -1 min-h)
+				  1 1)
+		    (set! already-trying? #f)
+		    (resized)]))))))])
+      
+      (override
+	;; show: add capability to set perform-updates
+	;; input: now : boolean
+	;; returns: nothing
+	;; effects: if we're showing for the first time, unblock updates
+	;;            and force an update.  If we're hiding, block updates.
+	;;          pass now to superclass's show.
+	[show
+	 (lambda (on?)
+	   (when (and on? pending-redraws?)
+	     (force-redraw))
+	   (when (and on? use-default-position?)
+	     (set! use-default-position? #f)
+	     (let*-values ([(w) (get-width)]
+			   [(h) (get-height)]
+			   [(sw sh) (get-display-size)]
+			   [(x x-reset?) (if (< (+ top-x w) sw)
+					     (values top-x #f)
+					     (values (max 0 (- sw w 10)) #t))]
+			   [(y y-reset?) (if (< (+ top-y h) sh)
+					     (values top-y #f)
+					     (values (max 0 (- sh h 20)) #t))])
+	       (move x y)
+	       (set! top-x (if x-reset? 0 (+ top-x 10)))
+	       (set! top-y (if y-reset? 0 (+ top-y 20)))))
+	   (if on?
+	       (hash-table-put! top-level-windows this #t)
+	       (hash-table-remove! top-level-windows this))
+	   (as-exit ; as-exit because there's an implicit wx:yield for dialogs
+	    (lambda () (super show on?))))]
+
+	[on-visible
+	 (lambda ()
+	   (send panel queue-visible)
+	   (super on-visible))]
+	[on-active
+	 (lambda ()
+	   (send panel queue-active)
+	   (super on-active))]
+	
+	[move (lambda (x y) (set! use-default-position? #f) (super move x y))]
+	[center (lambda (dir)
+		  (when pending-redraws? (force-redraw))
+		  (set! use-default-position? #f)
+		  (super center dir))]
+	
+	;; on-size: ensures that size of frame matches size of content
+	;; input: new-width/new-height: new size of frame
+	;; returns: nothing
+	;; effects: if new size is smaller than allowed size of
+	;;            contents, frame resized to smallest possible size.
+	;;            If frame is larger than contents and contents
+	;;            aren't stretchable, frame resized to size of
+	;;            contents.  Each direction is handled
+	;;            independently.
+	[on-size
+	 (lambda (bad-width bad-height)
+	   (unless (and already-trying? (not (eq? 'unix (system-type))))
+	     (parameterize ([wx:current-eventspace eventspace])
+	       (wx:queue-callback (lambda () (resized)) #t))))])
+
+      (public
+	[handle-traverse-key
+	 (lambda (e)
+	   (and panel
+		(let ([code (send e get-key-code)])
+		  (case code
+		    [(#\return) 
+		     (let ([o (get-focus-window)])
+		       (if (and o (send o handles-key-code code #f #f))
+			   #f
+			   (let ([objs (container->children panel #f #f)])
+			     (or (ormap
+				  (lambda (x)
+				    (and (is-a? x wx:button%)
+					 (send x has-border?)
+					 (let ([v (make-object wx:control-event% 'button)])
+					   (do-command x v)
+					   #t)))
+				  objs)
+				 (not (is-a? o wx:editor-canvas%))))))]
+		    [(escape #\.)
+		     (and (is-a? this wx:dialog%)
+			  (or (eq? code 'escape)
+			      (and (memq (system-type) '(macos macosx))
+				   (send e get-meta-down)))
+			  (let ([o (get-focus-window)])
+			    (if (and o (send o handles-key-code code #f (send e get-meta-down)))
+				#f
+				(begin
+				  (when (on-close)
+				    (show #f))
+				  #t))))]
+		    [(#\space)
+		     (let ([o (get-focus-window)])
+		       (cond
+			[(is-a? o wx:button%)
+			 (do-command o (make-object wx:control-event% 'button))
+			 #t]
+			[(is-a? o wx:check-box%) 
+			 (send o set-value (not (send o get-value)))
+			 (do-command o (make-object wx:control-event% 'check-box))
+			 #t]
+			[(is-a? o wx:radio-box%)
+			 (let ([s (send o button-focus -1)])
+			   (unless (negative? s)
+			     (send o set-selection s)
+			     (do-command o (make-object wx:control-event% 'radio-box))))
+			 #t]
+			[(is-a? o wx-tab-group<%>)
+			 (let ([s (send o button-focus -1)])
+			   (unless (negative? s)
+			     (send o set-selection s)
+			     (do-command (wx->mred o) (make-object wx:control-event% 'tab-panel))))
+			 #t]
+			[else #f]))]
+		    [(#\tab left up down right) 
+		     (let ([o (get-focus-window)])
+		       (if (and o (send o handles-key-code code #f #f))
+			   #f
+			   (let* ([shift? (send e get-shift-down)]
+				  [forward? (or (and (eq? code #\tab) (not shift?))
+						(memq code '(right down)))]
+				  [normal-move
+				   (lambda ()
+				     (let* ([o (if (or (is-a? o wx:canvas%) (is-a? o wx:item%)) 
+						   (if (is-a? o wx-group-box<%>)
+						       #f
+						       o)
+						   #f)]
+					    [candidates 
+					     (map object->position (container->children panel o #t))]
+					    [dests (filter-overlapping candidates)]
+					    [pos (if o (object->position o) (list 'x 0 0 1 1))]
+					    [o (traverse (cadr pos) (caddr pos) (cadddr pos) (list-ref pos 4)
+							 (case code
+							   [(#\tab) (if shift? 'prev 'next)]
+							   [else code])
+							 dests)])
+				       (when o
+					 (if (or (is-a? o wx:radio-box%)
+						 (is-a? o wx-tab-group<%>))
+					     (send o button-focus (max 0 (send o button-focus -1)))
+					     (begin
+					       (send o set-focus)
+					       (if (and (is-a? o wx-text-editor-canvas<%>)
+							(send o is-single-line?))
+						   (let ([e (send o get-editor)])
+						     (as-exit
+						      (lambda ()
+							(send e set-position 0 (send e last-position) #f #t 'local))))
+						   ;; Not a text field; a canvas?
+						   (when (or (is-a? o wx:canvas%)
+							     (is-a? o wx:editor-canvas%))
+						     (as-exit (lambda () (send o on-tab-in))))))))))])
+			     (if (and (not (eqv? code #\tab))
+				      (or (is-a? o wx:radio-box%)
+					  (is-a? o wx-tab-group<%>)))
+				 (let ([n (send o number)]
+				       [s (send o button-focus -1)]
+				       [v-move? (memq code '(up down))]
+				       [h-move? (memq code '(left right))]
+				       [v? (and (is-a? o wx:radio-box%)
+						(send o vertical?))])
+				   (cond
+				    [(or (negative? s) 
+					 (and v? h-move?) 
+					 (and (not v?) v-move?))
+				     (normal-move)]
+				    [(and forward? (< s (sub1 n)))
+				     (send o button-focus (add1 s))]
+				    [(and (not forward?) (positive? s))
+				     (send o button-focus (sub1 s))]
+				    [else (normal-move)]))
+				 (normal-move))
+			     #t)))]
+		    [else (if (and (wx:shortcut-visible-in-label?)
+				   (char? code)
+				   (or (char-alphabetic? code)
+				       (char-numeric? code))
+				   (not (send e get-shift-down))
+				   (not (send e get-control-down))
+				   (not (send e get-alt-down)))
+			      (let ([o (get-focus-window)]
+				    [meta? (send e get-meta-down)])
+				(if (and o (send o handles-key-code code #t meta?))
+				    #f
+				    ;; Move selection/hit control based on & shortcuts
+				    (let* ([objs (container->children panel #f #t)]
+					   [re (key-regexp code)])
+				      (ormap
+				       (lambda (o)
+					 (let* ([win (wx->proxy o)]
+						[l (send win get-label)])
+					   (cond
+					    [(and (string? l)
+						  (regexp-match re l))
+					     (send o set-focus)
+					     (send o char-to)
+					     #t]
+					    [(is-a? o wx:radio-box%)
+					     (let ([n (send o number)])
+					       (let loop ([i 0])
+						 (if (= i n)
+						     #f
+						     (let ([l (send o get-string i)])
+						       (if (and (string? l)
+								(regexp-match re l))
+							   (begin
+							     (send o button-focus i)
+							     (send o char-to-button i)
+							     #t)
+							   (loop (add1 i)))))))]
+					    [else #f])))
+				       objs))))
+			      #f)]))))])
+      
+      (sequence
+	(apply super-init parent args))))
+
+  (define (make-top-level-window-glue% %) ; implies make-window-glue%
+    (class100 (make-window-glue% %) (mred proxy . args)
+      (inherit is-shown? get-mred queue-visible get-eventspace)
+      (private-field 
+       [act-date/seconds 0] [act-date/milliseconds 0] [act-on? #f]
+       [activate-refresh-wins null])
+      (public 
+	[on-exit (entry-point
+		  (lambda ()
+		    (and (is-shown?)
+			 (let ([mred (get-mred)])
+			   (and (and mred (as-exit (lambda () (send mred can-exit?))))
+				(as-exit (lambda () (send mred on-exit))))))))])
+      (override
+	[on-close (entry-point
+		   (lambda ()
+		     (let ([mred (get-mred)])
+		       (if mred
+			   (if (as-exit (lambda () (send mred can-close?)))
+			       (begin
+				 (as-exit (lambda () (send mred on-close)))
+				 (queue-visible)
+				 #t)
+			       #f)
+			   #t))))]
+	[on-activate (entry-point
+		      (lambda (on?)
+			(set! act-on? on?)
+			(when on?
+			  (set! act-date/seconds (current-seconds))
+			  (set! act-date/milliseconds (current-milliseconds))
+			  (when (wx:main-eventspace? (get-eventspace))
+			    (set! active-main-frame (make-weak-box this))))
+			;; Send refresh to subwindows that need it
+			(set! activate-refresh-wins (filter weak-box-value activate-refresh-wins))
+			(for-each (lambda (b)
+				    (let ([win (weak-box-value b)])
+				      (when win
+					(send win refresh))))
+				  activate-refresh-wins)
+			;; Windows needs trampoline:
+			(queue-window-callback
+			 this
+			 (lambda () (send (get-mred) on-activate on?)))
+			(as-exit
+			 (lambda ()
+			   (super on-activate on?)))))])
+      (public
+	[is-act-on? (lambda () act-on?)]
+	[add-activate-update (lambda (win) (set! activate-refresh-wins  
+						 (cons (make-weak-box win)
+						       activate-refresh-wins)))]
+	[get-act-date/seconds (lambda () act-date/seconds)]
+	[get-act-date/milliseconds (lambda () act-date/milliseconds)])
+      (sequence (apply super-init mred proxy args))))
+
+  (define wx-frame%
+    (make-top-level-window-glue% 
+     (class100 (make-top-container% wx:frame% #f) args
+       (private-field
+	[menu-bar #f]
+	[is-mdi-parent? #f])
+       (public
+	 [get-the-menu-bar (lambda () menu-bar)]
+	 [get-mdi-parent (lambda () is-mdi-parent?)]
+	 [set-mdi-parent (lambda (x) (and (set! is-mdi-parent? x) #t))])
+       (override
+	 [set-menu-bar
+	  (lambda (mb)
+	    (when mb (set! menu-bar mb))
+	    (super set-menu-bar mb))]
+	 [on-menu-command
+	  (entry-point
+	   (lambda (id)
+	     (let ([wx (wx:id-to-menu-item id)])
+	       (let ([go (lambda ()
+			   (do-command (wx->mred wx) (make-object wx:control-event% 'menu)))])
+		 (if (eq? 'windows (system-type))
+		     ;; Windows: need trampoline
+		     (wx:queue-callback 
+		      (entry-point (lambda () (go)))
+		      wx:middle-queue-key)
+		     (go))))))]
+	 [on-menu-click
+	  (entry-point
+	   (lambda ()
+	     ;; Windows: no trampoline needed
+	     (and menu-bar (send menu-bar on-demand))))]
+	 [on-toolbar-click 
+	  (entry-point
+	   (lambda ()
+	     (as-exit (lambda () (send (wx->mred this) on-toolbar-button-click)))))])
+       (public
+	 [handle-menu-key
+	  (lambda (event)
+	    (and menu-bar 
+		 ;; It can't be a menu event without a
+		 ;; control, meta, or alt key...
+		 (or (send event get-control-down)
+		     (send event get-meta-down)
+		     (send event get-alt-down))
+		 (begin
+		   (send menu-bar on-demand)
+		   (send menu-bar handle-key event))))])
+       (sequence
+	 (apply super-init args)))))
+
+  (define wx-dialog%
+    (make-top-level-window-glue% 
+     (class100 (make-top-container% wx:dialog% #t) args
+       (sequence
+	 (apply super-init args))))))
\ No newline at end of file
diff --git a/collects/mred/private/wxwindow.ss b/collects/mred/private/wxwindow.ss
new file mode 100644
index 0000000000..1d838645a9
--- /dev/null
+++ b/collects/mred/private/wxwindow.ss
@@ -0,0 +1,212 @@
+(module wxwindow mzscheme
+  (require (lib "class.ss")
+	   (lib "class100.ss")
+	   (prefix wx: "kernel.ss")
+	   "lock.ss"
+	   "helper.ss"
+	   "wx.ss")
+
+  (provide (protect wx-make-window%
+		    make-window-glue%))
+
+  (define wx-make-window%
+    (lambda (% top?)
+      (class100 % args
+	(inherit is-shown-to-root? is-enabled-to-root?)
+	(private-field
+	 [top-level #f]
+	 [focus? #f]
+	 [container this]
+	 [visible? #f]
+	 [active? #f])
+	(public
+	  [on-visible
+	   (lambda ()
+	     (let ([vis? (is-shown-to-root?)])
+	       (unless (eq? vis? visible?)
+		 (set! visible? vis?)
+		 (as-exit
+		  (lambda ()
+		    (send (wx->proxy this) on-superwindow-show vis?))))))]
+	  [queue-visible
+	   (lambda ()
+	     (parameterize ([wx:current-eventspace (send (get-top-level) get-eventspace)])
+	       (wx:queue-callback (entry-point (lambda () (on-visible))) wx:middle-queue-key)))])
+	(public
+	  [on-active
+	   (lambda ()
+	     (let ([act? (is-enabled-to-root?)])
+	       (unless (eq? act? active?)
+		 (set! active? act?)
+		 (as-exit
+		  (lambda ()
+		    (send (wx->proxy this) on-superwindow-enable act?))))))]
+	  [queue-active
+	   (lambda ()
+	     (parameterize ([wx:current-eventspace (send (get-top-level) get-eventspace)])
+	       (wx:queue-callback (entry-point (lambda () (on-active))) wx:middle-queue-key)))]
+
+	  ;; Needed for radio boxes:
+	  [orig-enable
+	   (lambda args (super-enable . args))])
+	(rename [super-enable enable])
+	
+	(private-field
+	 [can-accept-drag? #f])
+
+	(public
+	  [accept-drag? (lambda () can-accept-drag?)]
+	  [get-container (lambda () container)]
+	  [set-container (lambda (c) (set! container c))]
+	  [get-window (lambda () this)]
+	  [tabbing-position (lambda (x y w h) (list this x y w h))]
+	  [has-tabbing-children? (lambda () #f)]
+	  [dx (lambda () 0)]
+	  [dy (lambda () 0)]
+	  [ext-dx (lambda () (dx))]
+	  [ext-dy (lambda () (dy))]
+	  [handles-key-code (lambda (x alpha? meta?) #f)]
+	  [char-to (lambda () (void))]
+	  [get-top-level
+	   (lambda ()
+	     (unless top-level
+	       (let loop ([window this])
+		 (cond
+		  [(or (is-a? window wx:frame%)
+		       (is-a? window wx:dialog%)) 
+		   (set! top-level window)]
+		  [else (loop (send window get-parent))])))
+	     top-level)])
+	(override
+	  [show
+	   (lambda (on?)
+	     (queue-visible)
+	     (super show on?))]
+	  [enable
+	   (lambda (on?)
+	     (queue-active)
+	     (super enable on?))]
+
+	  [drag-accept-files
+	   (lambda (on?)
+	     (set! can-accept-drag? (and on? #t))
+	     (super drag-accept-files on?))]
+	  [on-set-focus
+	   (entry-point
+	    (lambda ()
+	      (send (get-top-level) set-focus-window this)
+	      (set! focus? #t)
+	      (as-exit (lambda () (super on-set-focus)))))]
+	  [on-kill-focus
+	   (entry-point
+	    (lambda ()
+	      (send (get-top-level) set-focus-window #f)
+	      (set! focus? #f)
+	      (as-exit (lambda () (super on-kill-focus)))))])
+	(public
+	  [has-focus? (lambda () focus?)])
+	(sequence 
+	  (apply super-init args)
+	  (unless top?
+	    (set! visible? (is-shown-to-root?))
+	    (set! active? (is-enabled-to-root?)))))))
+
+  (define (make-window-glue% %)  ; implies make-glue%
+    (class100 (make-glue% %) (mred proxy . args)
+      (inherit get-x get-y get-width get-height area-parent get-mred get-proxy)
+      (private-field
+       [pre-wx->proxy (lambda (orig-w e k)
+			;; MacOS: w may not be something the user knows
+			;; Look for a parent, and shift coordinates
+			(let loop ([w orig-w])
+			  (if w
+			      (if (is-a? w wx/proxy<%>)
+				  (if (eq? w orig-w)
+				      (k (wx->proxy w) e)
+				      (let ([bx (box (send e get-x))]
+					    [by (box (send e get-y))])
+					(send orig-w client-to-screen bx by)
+					(send w screen-to-client bx by)
+					(let ([new-e (if (e . is-a? . wx:key-event%)
+							 (instantiate wx:key-event% ()
+								      [key-code (send e get-key-code)])
+							 (instantiate wx:mouse-event% ()
+								      [event-type (send e get-event-type)]
+								      [left-down (send e get-left-down)]
+								      [right-down (send e get-right-down)]
+								      [middle-down (send e get-middle-down)]))])
+					  (when (e . is-a? . wx:key-event%)
+					    (send new-e set-key-release-code (send e get-key-release-code)))
+					  (send new-e set-time-stamp (send e get-time-stamp))
+					  (send new-e set-alt-down (send e get-alt-down))
+					  (send new-e set-control-down (send e get-control-down))
+					  (send new-e set-meta-down (send e get-meta-down))
+					  (send new-e set-shift-down (send e get-shift-down))
+					  (send new-e set-x (unbox bx))
+					  (send new-e set-y (unbox by))
+					  (k (wx->proxy w) new-e))))
+				  (loop (send w get-parent)))
+			      #f)))]
+       [old-w -1]
+       [old-h -1]
+       [old-x -1]
+       [old-y -1])
+      (override
+	[on-drop-file (entry-point
+		       (lambda (f)
+			 (as-exit
+			  (lambda ()
+			    (send (get-proxy) on-drop-file f)))))]
+	[on-size (lambda (bad-w bad-h)
+		   (super on-size bad-w bad-h)
+		   ;; Delay callback to make sure X structures (position) are updated, first.
+		   ;; Also, Windows needs a trampoline.
+		   (queue-window-callback
+		    this
+		    (entry-point
+		     (lambda ()
+		       (let ([mred (get-mred)])
+			 (when mred 
+			   (let* ([w (get-width)]
+				  [h (get-height)])
+			     (when (not (and (= w old-w) (= h old-h)))
+			       (set! old-w w)
+			       (set! old-h h)
+			       (as-exit (lambda () (send mred on-size w h)))))
+			   (let* ([p (area-parent)]
+				  [x (- (get-x) (or (and p (send p dx)) 0))]
+				  [y (- (get-y) (or (and p (send p dy)) 0))])
+			     (when (not (and (= x old-x) (= y old-y)))
+			       (set! old-x x)
+			       (set! old-y y)
+			       (as-exit (lambda () (send mred on-move x y)))))))))))]
+	[on-set-focus (entry-point
+		       (lambda ()
+					; Windows circumvents the event queue to call on-focus
+					;  when you click on the window's icon in the task bar.
+			 (queue-window-callback
+			  this 
+			  (lambda () (send (get-proxy) on-focus #t)))
+			 (as-exit (lambda () (super on-set-focus)))))]
+	[on-kill-focus (entry-point
+			(lambda ()
+					; see on-set-focus:
+			  (queue-window-callback
+			   this
+			   (lambda () (send (get-proxy) on-focus #f)))
+			  (as-exit (lambda () (super on-kill-focus)))))]
+	[pre-on-char (lambda (w e)
+		       (or (super pre-on-char w e)
+			   (as-entry
+			    (lambda ()
+			      (pre-wx->proxy w e
+					     (lambda (m e)
+					       (as-exit (lambda () 
+							  (send (get-proxy) on-subwindow-char m e)))))))))]
+	[pre-on-event (entry-point
+		       (lambda (w e)
+			 (pre-wx->proxy w e
+					(lambda (m e) 
+					  (as-exit (lambda () 
+						     (send (get-proxy) on-subwindow-event m e)))))))])
+      (sequence (apply super-init mred proxy args)))))
diff --git a/collects/mred/script-installer.ss b/collects/mred/script-installer.ss
new file mode 100644
index 0000000000..0000b3489f
--- /dev/null
+++ b/collects/mred/script-installer.ss
@@ -0,0 +1,18 @@
+;; This installer module just adds a bin/mred script
+;;  under OS X
+(module script-installer mzscheme
+  (provide post-installer)
+  (require (lib "launcher.ss" "launcher"))
+
+  (define post-installer
+    (lambda (path)
+      (when (eq? 'macosx (system-type))	
+	(let ([install
+	       (lambda (variant)
+		 (parameterize ([current-launcher-variant variant])
+		   (make-mred-launcher null 
+				       (mred-program-launcher-path "MrEd")
+				       '((exe-name . "MrEd")))))])
+	  (install 'script)
+	  (when (memq 'script-3m (available-mred-variants))
+	    (install 'script-3m)))))))
diff --git a/collects/mrflow/assoc-set-exn.ss b/collects/mrflow/assoc-set-exn.ss
new file mode 100644
index 0000000000..99332bcce7
--- /dev/null
+++ b/collects/mrflow/assoc-set-exn.ss
@@ -0,0 +1,32 @@
+; Exceptions for associative sets
+; This file is required by both assoc-set-hash.ss and assoc-set-list.ss
+; so we can't use contracts here because the assoc-sets are not always the same.
+
+(module assoc-set-exn mzscheme
+  (provide
+   (struct exn:assoc-set:key-not-found (assoc-set key))
+   (struct exn:assoc-set:duplicate-key (assoc-set key))
+   exn:assoc-set?
+   raise-key-not-found-exn
+   raise-duplicate-key-exn
+   )
+  
+  (define-struct (exn:assoc-set exn) ())
+  (define-struct (exn:assoc-set:key-not-found exn:assoc-set) (assoc-set key))
+  (define-struct (exn:assoc-set:duplicate-key exn:assoc-set) (assoc-set key))
+  
+  ; string assoc-set value -> void
+  (define (raise-key-not-found-exn fct-name assoc-set key)
+    (raise (make-exn:assoc-set:key-not-found
+            (format "~a: key ~a not found in associative set ~a" fct-name key assoc-set)
+            (current-continuation-marks)
+            assoc-set key)))
+  
+  ; string assoc-set value -> void
+  (define (raise-duplicate-key-exn fct-name assoc-set key)
+    (raise (make-exn:assoc-set:duplicate-key
+            (format "~a: key ~a already in associative set ~a" fct-name key assoc-set)
+            (current-continuation-marks)
+            assoc-set key)))
+  
+  )
diff --git a/collects/mrflow/assoc-set-hash.ss b/collects/mrflow/assoc-set-hash.ss
new file mode 100644
index 0000000000..3a51681d3d
--- /dev/null
+++ b/collects/mrflow/assoc-set-hash.ss
@@ -0,0 +1,257 @@
+; associative sets implementation, using hash tables.
+; - key equality based on eq? by default, uses equal? if given the 'equal flag
+; - raises exn:assoc-set:key-not-found if key not in associative set when trying
+;   to remove a key or when trying to get a value and no default thunk is given.
+; - raise exn:assoc-set:duplicate-key by default when trying to add a key to a
+;   set where it already exists
+; - strange things might happen if you use assoc-set-union, assoc-set-intersection,
+;   or assoc-set-difference with two sets that don't use the same comparaison
+;   function: you might end up with duplicate keys in some sets.
+
+(module assoc-set-hash (lib "mrflow.ss" "mrflow")
+  (require
+   (lib "etc.ss") ; for opt-lambda
+   "assoc-set-exn.ss" ; no prefix so we can re-provide
+   (prefix cst: "constants.ss")
+   )
+  
+  ; table = (hashtableof value value)
+  (define-struct assoc-set (cardinality table))
+  
+  (provide/contract
+   (exn:assoc-set? (any/c . -> . boolean?))
+   (struct exn:assoc-set:key-not-found ((assoc-set assoc-set?) (key any/c)))
+   (struct exn:assoc-set:duplicate-key ((assoc-set assoc-set?) (key any/c)))
+   (assoc-set-make (() ((symbols 'equal)) . opt-> . assoc-set?))
+   (assoc-set-reset (assoc-set? . -> . assoc-set?))
+   (assoc-set? (any/c . -> . boolean?))
+   (assoc-set-set ((assoc-set? any/c any/c) (boolean?) . opt-> . assoc-set?))
+   (assoc-set-get ((assoc-set? any/c) ((-> any)) . opt-> . any))
+   (assoc-set-in? (assoc-set? any/c . -> . boolean?))
+   (assoc-set-remove ((assoc-set? any/c) (boolean?) . opt-> . assoc-set?))
+   (assoc-set-cardinality (assoc-set? . -> . non-negative-exact-integer?))
+   (assoc-set-empty? (assoc-set? . -> . boolean?))
+   (assoc-set-copy (assoc-set? . -> . assoc-set?))
+   (assoc-set-map (assoc-set? (any/c any/c . -> . any) . -> . (listof any/c)))
+   (assoc-set-fold (assoc-set? (any/c any/c any/c . -> . any) any/c . -> . any))
+   (assoc-set-for-each (assoc-set? (any/c any/c . -> . any) . -> . assoc-set?))
+   (assoc-set-for-each! (assoc-set? (any/c any/c . -> . any) . -> . assoc-set?))
+   (assoc-set-filter ((assoc-set? (any/c any/c . -> . boolean?)) ((symbols 'new 'same)) . opt-> . assoc-set?))
+   (assoc-set-union ((assoc-set? assoc-set? (any/c any/c . -> . any)) ((symbols 'new 'first 'second)) . opt-> . assoc-set?))
+   (assoc-set-intersection ((assoc-set? assoc-set? (any/c any/c . -> . any)) ((symbols 'new 'first 'second)) . opt-> . assoc-set?))
+   (assoc-set-difference ((assoc-set? assoc-set?) ((symbols 'new 'first 'second)) . opt-> . assoc-set?))
+   )
+  
+  ; (opt 'equal) -> assoc-set
+  ; we test the optional argument ourselves to preserve data abstraction even in the
+  ; presence of an exception
+  (define assoc-set-make
+    (case-lambda
+      [() (make-assoc-set 0 (make-hash-table))]
+      [(flag) (make-assoc-set 0 (make-hash-table 'equal))]))
+  
+  ; assoc-set -> assoc-set
+  (define (assoc-set-reset assoc-set)
+    (set-assoc-set-table! assoc-set (make-hash-table))
+    (set-assoc-set-cardinality! assoc-set 0)
+    assoc-set)
+  
+  ; value -> boolean
+  ; assoc-set? comes from the structure definition
+  
+  ; assoc-set value value (opt boolean) -> assoc-set
+  (define assoc-set-set
+    (opt-lambda (assoc-set key value (exn? #t))
+      (if (assoc-set-in? assoc-set key)
+          (if exn?
+              (raise-duplicate-key-exn "assoc-set-set" assoc-set key)
+              ; silently replace
+              (hash-table-put! (assoc-set-table assoc-set) key value))
+          (begin
+            (set-assoc-set-cardinality! assoc-set (add1 (assoc-set-cardinality assoc-set)))
+            (hash-table-put! (assoc-set-table assoc-set) key value)))
+      assoc-set))
+  
+  ; assoc-set value (-> value) -> value
+  (define assoc-set-get
+    (opt-lambda (assoc-set key (not-found-thunk (lambda () (raise-key-not-found-exn "assoc-set-get" assoc-set key))))
+      (hash-table-get (assoc-set-table assoc-set) key not-found-thunk)))
+  
+  ; assoc-set value -> boolean
+  (define assoc-set-in? 
+    (let ([sym (gensym)])
+      (lambda (assoc-set key)
+        (not (eq? sym (hash-table-get (assoc-set-table assoc-set) key (lambda () sym)))))))
+  
+  ; assoc-set value (opt boolean) -> assoc-set
+  (define assoc-set-remove
+    (opt-lambda (assoc-set key (exn? #t))
+      (if (assoc-set-in? assoc-set key)
+          (begin
+            (set-assoc-set-cardinality! assoc-set (sub1 (assoc-set-cardinality assoc-set)))
+            (hash-table-remove! (assoc-set-table assoc-set) key))
+          (when exn?
+            (raise-key-not-found-exn "assoc-set-remove" assoc-set key)))
+      assoc-set))
+  
+  ; assoc-set -> exact-non-negative-integer
+  ; assoc-set-cardinality comes from the structure definition
+  
+  ; assoc-set -> boolean
+  (define (assoc-set-empty? assoc-set)
+    (= 0 (assoc-set-cardinality assoc-set)))
+  
+  ; assoc-set -> assoc-set
+  (define (assoc-set-copy assoc-set)
+    (let ([new-table (make-hash-table)])
+      (hash-table-for-each (assoc-set-table assoc-set)
+                           (lambda (key value)
+                             (hash-table-put! new-table key value)))
+      (make-assoc-set (assoc-set-cardinality assoc-set)
+                      new-table)))
+  
+  ; assoc-set (value value -> value) -> (listof value)
+  (define (assoc-set-map assoc-set f)
+    (hash-table-map (assoc-set-table assoc-set) f))
+  
+  ; assoc-set (value value value -> value) value -> value
+  (define (assoc-set-fold assoc-set f acc)
+    (let ([acc acc])
+      (hash-table-for-each (assoc-set-table assoc-set)
+                           (lambda (key value)
+                             (set! acc (f key value acc))))
+      acc))
+  
+  ; assoc-set (value value -> value) -> assoc-set
+  (define (assoc-set-for-each assoc-set f)
+    (hash-table-for-each (assoc-set-table assoc-set) f)
+    assoc-set)
+  
+  ; assoc-set (value value -> value) -> assoc-set
+  ; we need a new table because of the "Caveat concerning concurrent access" for hash tables
+  ; in the help desk.
+  (define (assoc-set-for-each! assoc-set f)
+    (let ([new-table (make-hash-table)])
+      (hash-table-for-each (assoc-set-table assoc-set)
+                           (lambda (key value)
+                             (hash-table-put! new-table key (f key value))))
+      (set-assoc-set-table! assoc-set new-table))
+    assoc-set)
+  
+  ; assoc-set (value value -> boolean) (opt (union 'new 'same)) -> assoc-set
+  (define assoc-set-filter
+    (let (; assoc-set (value value -> boolean) -> assoc-set
+          [filter-set-into-new-assoc-set
+           (lambda (assoc-set tester)
+             (let ([table (make-hash-table)]
+                   [count 0])
+               (hash-table-for-each (assoc-set-table assoc-set)
+                                    (lambda (key value)
+                                      (when (tester key value)
+                                        (hash-table-put! table key value)
+                                        (set! count (add1 count)))))
+               (make-assoc-set count table)))])
+      (opt-lambda (assoc-set tester (which-set 'new))
+        (let ([new-assoc-set (filter-set-into-new-assoc-set assoc-set tester)])
+          (case which-set
+            [(new) new-assoc-set]
+            [(same)
+             (set-assoc-set-table! assoc-set (assoc-set-table new-assoc-set))
+             (set-assoc-set-cardinality! assoc-set (assoc-set-cardinality new-assoc-set))
+             assoc-set]
+            ;[else (argexn:raise-arg-mismatch-exn "assoc-set-filter" '(union new same) which-set)]
+            )))))
+  
+  ; assoc-set assoc-set (value value -> value) (opt (union 'new 'first 'second)) -> assoc-set
+  (define assoc-set-union
+    (let (; assoc-set assoc-set (value value -> value) -> assoc-set
+          [union-second-set-into-first
+           (lambda (assoc-set1 assoc-set2 merge-values)
+             (let ([table (assoc-set-table assoc-set1)]
+                   [count (assoc-set-cardinality assoc-set1)])
+               (hash-table-for-each (assoc-set-table assoc-set2)
+                                    (lambda (key value)
+                                      (if (assoc-set-in? assoc-set1 key)
+                                          (hash-table-put! table key
+                                                           (merge-values (hash-table-get table key cst:dummy)
+                                                                         value))
+                                          (begin
+                                            (set! count (add1 count))
+                                            (hash-table-put! table key value)))))
+               (set-assoc-set-cardinality! assoc-set1 count))
+             assoc-set1)])
+      (opt-lambda (assoc-set1 assoc-set2 merge-values (which-set 'new))
+        (case which-set
+          [(new)
+           ; copying is presumably faster than testing
+           (if (< (assoc-set-cardinality assoc-set1) (assoc-set-cardinality assoc-set2))
+               (union-second-set-into-first (assoc-set-copy assoc-set2) assoc-set1)
+               (union-second-set-into-first (assoc-set-copy assoc-set1) assoc-set2))]
+          [(first) (union-second-set-into-first assoc-set1 assoc-set2)]
+          [(second) (union-second-set-into-first assoc-set2 assoc-set1)]
+          ;[else (argexn:raise-arg-mismatch-exn "assoc-set-union" '(union new first second) which-set)]
+          ))))
+  
+  ; assoc-set assoc-set (value value -> value) (opt (union 'new 'first 'second)) -> assoc-set
+  (define assoc-set-intersection
+    (let (; assoc-set assoc-set (value value -> value) -> assoc-set
+          [intersect-into-new-assoc-set
+           (lambda (assoc-set1 assoc-set2 merge-values)
+             (let ([assoc-set2-table (assoc-set-table assoc-set2)]
+                   [table (make-hash-table)]
+                   [count 0])
+               (hash-table-for-each (assoc-set-table assoc-set1)
+                                    (lambda (key value)
+                                      (when (assoc-set-in? assoc-set2 key)
+                                        (hash-table-put! table key
+                                                         (merge-values value
+                                                                       (hash-table-get assoc-set2-table key cst:dummy)))
+                                        (set! count (add1 count)))))
+               (make-assoc-set count table)))])
+      (opt-lambda (assoc-set1 assoc-set2 merge-values (which-set 'new))
+        (let ([new-assoc-set
+               (if (< (assoc-set-cardinality assoc-set1) (assoc-set-cardinality assoc-set2))
+                   (intersect-into-new-assoc-set assoc-set1 assoc-set2 merge-values)
+                   (intersect-into-new-assoc-set assoc-set2 assoc-set1 merge-values))])
+          (case which-set
+            [(new) new-assoc-set]
+            [(first)
+             (set-assoc-set-table! assoc-set1 (assoc-set-table new-assoc-set))
+             (set-assoc-set-cardinality! assoc-set1 (assoc-set-cardinality new-assoc-set))
+             assoc-set1]
+            [(second)
+             (set-assoc-set-table! assoc-set2 (assoc-set-table new-assoc-set))
+             (set-assoc-set-cardinality! assoc-set2 (assoc-set-cardinality new-assoc-set))
+             assoc-set2]
+            ;[else (argexn:raise-arg-mismatch-exn "assoc-set-intersection" '(union new first second) which-set)]
+            )))))
+  
+  ; assoc-set assoc-set (opt (union 'new 'first 'second)) -> assoc-set
+  (define assoc-set-difference
+    (let (; assoc-set assoc-set -> assoc-set
+          [difference-into-new-assoc-set
+           (lambda (assoc-set1 assoc-set2)
+             (let ([table (make-hash-table)]
+                   [count 0])
+               (hash-table-for-each (assoc-set-table assoc-set1)
+                                    (lambda (key value)
+                                      (unless (assoc-set-in? assoc-set2 key)
+                                        (hash-table-put! table key value)
+                                        (set! count (add1 count)))))
+               (make-assoc-set count table)))])
+      (opt-lambda (assoc-set1 assoc-set2 (which-set 'new))
+        (let ([new-assoc-set (difference-into-new-assoc-set assoc-set1 assoc-set2)])
+          (case which-set
+            [(new) new-assoc-set]
+            [(first) 
+             (set-assoc-set-table! assoc-set1 (assoc-set-table new-assoc-set))
+             (set-assoc-set-cardinality! assoc-set1 (assoc-set-cardinality new-assoc-set))
+             assoc-set1]
+            [(second)
+             (set-assoc-set-table! assoc-set2 (assoc-set-table new-assoc-set))
+             (set-assoc-set-cardinality! assoc-set2 (assoc-set-cardinality new-assoc-set))
+             assoc-set2]
+            ;[else (argexn:raise-arg-mismatch-exn "assoc-set-difference" '(union new first second) which-set)]
+            )))))
+  
+  )
diff --git a/collects/mrflow/assoc-set-list.ss b/collects/mrflow/assoc-set-list.ss
new file mode 100644
index 0000000000..b7d9f50de5
--- /dev/null
+++ b/collects/mrflow/assoc-set-list.ss
@@ -0,0 +1,354 @@
+; associative sets implementation, using lists.
+; - key equality based on eq? by default, uses equal? if given the 'equal flag
+; - raises exn:assoc-set:key-not-found if key not in associative set when trying
+;   to remove a key or when trying to get a value and no default thunk is given.
+; - raise exn:assoc-set:duplicate-key by default when trying to add a key to a
+;   set where it already exists
+; - strange things might happen if you use assoc-set-union, assoc-set-intersection,
+;   or assoc-set-difference with two sets that don't use the same comparaison
+;   function: you might end up with duplicate keys in some sets.
+;
+; Note: lots of set! and tail-recursive loops in this code, for speed
+
+(module assoc-set-list (lib "mrflow.ss" "mrflow")
+  (require
+   (lib "list.ss") ; for foldr
+   (lib "etc.ss") ; for opt-lambda
+   "assoc-set-exn.ss" ; no prefix so we can re-provide
+   )
+  
+  ; table = (listof (cons value value))
+  (define-struct assoc-set (=? cardinality table))
+  
+  (provide/contract
+   (exn:assoc-set? (any/c . -> . boolean?))
+   (struct exn:assoc-set:key-not-found ((assoc-set assoc-set?) (key any/c)))
+   (struct exn:assoc-set:duplicate-key ((assoc-set assoc-set?) (key any/c)))
+   (assoc-set-make (() ((symbols 'equal)) . opt-> . assoc-set?))
+   (assoc-set-reset (assoc-set? . -> . assoc-set?))
+   (assoc-set? (any/c . -> . boolean?))
+   (assoc-set-set ((assoc-set? any/c any/c) (boolean?) . opt-> . assoc-set?))
+   (assoc-set-get ((assoc-set? any/c) ((-> any)) . opt-> . any))
+   (assoc-set-in? (assoc-set? any/c . -> . boolean?))
+   (assoc-set-remove ((assoc-set? any/c) (boolean?) . opt-> . assoc-set?))
+   (assoc-set-cardinality (assoc-set? . -> . non-negative-exact-integer?))
+   (assoc-set-empty? (assoc-set? . -> . boolean?))
+   (assoc-set-copy (assoc-set? . -> . assoc-set?))
+   (assoc-set-map (assoc-set? (any/c any/c . -> . any) . -> . (listof any/c)))
+   (assoc-set-fold (assoc-set? (any/c any/c any/c . -> . any) any/c . -> . any))
+   (assoc-set-for-each (assoc-set? (any/c any/c . -> . any) . -> . assoc-set?))
+   (assoc-set-for-each! (assoc-set? (any/c any/c . -> . any) . -> . assoc-set?))
+   (assoc-set-filter ((assoc-set? (any/c any/c . -> . boolean?)) ((symbols 'new 'same)) . opt-> . assoc-set?))
+   (assoc-set-union ((assoc-set? assoc-set? (any/c any/c . -> . any)) ((symbols 'new 'first 'second)) . opt-> . assoc-set?))
+   (assoc-set-intersection ((assoc-set? assoc-set? (any/c any/c . -> . any)) ((symbols 'new 'first 'second)) . opt-> . assoc-set?))
+   (assoc-set-difference ((assoc-set? assoc-set?) ((symbols 'new 'first 'second)) . opt-> . assoc-set?))
+   )
+  
+  ; (opt 'equal) -> assoc-set
+  ; we test the optional argument ourselves to preserve data abstraction even in the
+  ; presence of an exception
+  (define assoc-set-make
+    (case-lambda
+      [() (make-assoc-set eq? 0 '())]
+      [(flag) (make-assoc-set equal? 0 '())]))
+  
+  ; assoc-set -> assoc-set
+  ; doesn't change =?
+  (define (assoc-set-reset assoc-set)
+    (set-assoc-set-table! assoc-set '())
+    (set-assoc-set-cardinality! assoc-set 0)
+    assoc-set)
+  
+  ; value -> boolean
+  ; assoc-set? comes from the structure definition
+  
+  ; assoc-set value value (opt boolean) -> assoc-set
+  (define assoc-set-set
+    (opt-lambda (assoc-set key value (exn? #t))
+      (let ([=? (assoc-set-=? assoc-set)]
+            [original-table (assoc-set-table assoc-set)])
+        (set-assoc-set-table! assoc-set (let loop ([table original-table])
+                                          (if (null? table)
+                                              (begin
+                                                (set-assoc-set-cardinality! assoc-set (add1 (assoc-set-cardinality assoc-set)))
+                                                (cons (cons key value) original-table))
+                                              (let ([key-value-pair (car table)])
+                                                (if (=? (car key-value-pair) key)
+                                                    (if exn?
+                                                        (raise-duplicate-key-exn "assoc-set-set" assoc-set key)
+                                                        (begin
+                                                          ; silently replace
+                                                          (set-cdr! key-value-pair value)
+                                                          original-table))
+                                                    (loop (cdr table)))))))
+        assoc-set)))
+  
+  ; assoc-set value (-> value) -> value
+  (define assoc-set-get
+    (opt-lambda (assoc-set key (not-found-thunk (lambda () (raise-key-not-found-exn "assoc-set-get" assoc-set key))))
+      (let ([=? (assoc-set-=? assoc-set)])
+        (let loop ([table (assoc-set-table assoc-set)])
+          (if (null? table)
+              (not-found-thunk)
+              (let ([key-value-pair (car table)])
+                (if (=? (car key-value-pair) key)
+                    (cdr key-value-pair)
+                    (loop (cdr table)))))))))
+  
+  ; assoc-set value -> boolean
+  (define (assoc-set-in? assoc-set key)
+    (let ([=? (assoc-set-=? assoc-set)])
+      (ormap (lambda (key-value-pair)
+               (=? (car key-value-pair) key))
+             (assoc-set-table assoc-set))))
+  
+  ; assoc-set value (opt boolean) -> assoc-set
+  (define assoc-set-remove
+    (opt-lambda (assoc-set key (exn? #t))
+      (let ([=? (assoc-set-=? assoc-set)]
+            [original-table (assoc-set-table assoc-set)])
+        (set-assoc-set-table! assoc-set
+                              (let loop ([table original-table]
+                                         [previous #f])
+                                (if (null? table)
+                                    (if exn?
+                                        (raise-key-not-found-exn "assoc-set-remove" assoc-set key)
+                                        ; silently ignore
+                                        original-table)
+                                    (let ([key-value-pair (car table)])
+                                      (if (=? (car key-value-pair) key)
+                                          (begin
+                                            (set-assoc-set-cardinality! assoc-set (sub1 (assoc-set-cardinality assoc-set)))
+                                            (if previous
+                                                (begin
+                                                  ; return shortened table
+                                                  (set-cdr! previous (cdr table))
+                                                  original-table)
+                                                (cdr original-table)))
+                                          (loop (cdr table) table)))))))
+      assoc-set))
+  
+  ; assoc-set -> exact-non-negative-integer
+  ; assoc-set-cardinality comes from the structure definition
+  
+  ; assoc-set -> boolean
+  (define (assoc-set-empty? assoc-set)
+    (= 0 (assoc-set-cardinality assoc-set)))
+  
+  ; (listof (cons value value)) (listof (cons value value)) -> (listof (cons value value))
+  ; creates a (reversed) copy of l1 (to prevent list sharing between sets) and prefixes l2 with it
+  (define (copy-reverse-and-prefix-assoc-lists l1 l2)
+    (let loop ([l1 l1]
+               [l2 l2])
+      (if (null? l1)
+          l2
+          (loop (cdr l1) (cons (cons (caar l1) (cdar l1)) l2)))))
+  
+  ; (listof (cons value value)) -> (listof (cons value value))
+  (define (copy-assoc-list l)
+    (copy-reverse-and-prefix-assoc-lists l '()))
+  
+  ; assoc-set -> assoc-set
+  (define (assoc-set-copy assoc-set)
+    (make-assoc-set (assoc-set-=? assoc-set)
+                         (assoc-set-cardinality assoc-set)
+                         (copy-assoc-list (assoc-set-table assoc-set))))
+  
+  ; assoc-set (value value -> value) -> (listof value)
+  (define (assoc-set-map assoc-set f)
+    (let ([unary-f (lambda (key-value-pair)
+                     (f (car key-value-pair) (cdr key-value-pair)))])
+      (map unary-f (assoc-set-table assoc-set))))
+  
+  ; assoc-set (value value value -> value) value -> value
+  (define (assoc-set-fold assoc-set f acc)
+    (foldr (lambda (key-value-pair acc)
+             (f (car key-value-pair) (cdr key-value-pair) acc))
+           acc
+           (assoc-set-table assoc-set)))
+  
+  ; assoc-set (value value -> value) -> assoc-set
+  (define (assoc-set-for-each assoc-set f)
+    (let ([unary-f (lambda (key-value-pair)
+                     (f (car key-value-pair) (cdr key-value-pair)))])
+      (for-each unary-f (assoc-set-table assoc-set)))
+    assoc-set)
+  
+  ; assoc-set (value value -> value) -> assoc-set
+  ; we know lists are never shared between sets, so we can set-cdr!
+  (define (assoc-set-for-each! assoc-set f)
+    (for-each (lambda (key-value-pair)
+                (set-cdr! key-value-pair (f (car key-value-pair) (cdr key-value-pair))))
+              (assoc-set-table assoc-set))
+    assoc-set)
+  
+  ; assoc-set (value value -> boolean) (opt (union 'new 'same)) -> assoc-set
+  (define assoc-set-filter
+    (let (; assoc-set (value value -> boolean) -> assoc-set
+          [filter-into-new-assoc-set
+           (lambda (assoc-set tester)
+             (let ([table '()]
+                   [count 0])
+               (for-each (lambda (key value)
+                           (when (tester key value)
+                             (set! table (cons (cons key value) table))
+                             (set! count (add1 count))))
+                         (assoc-set-table assoc-set))
+               (make-assoc-set (assoc-set-=? assoc-set) count table)))])
+      (opt-lambda (assoc-set tester (which-assoc-set 'new))
+        (let ([new-assoc-set (filter-into-new-assoc-set assoc-set tester)])
+          (case which-assoc-set
+            [(new) new-assoc-set]
+            [(same)
+             (set-assoc-set-table! assoc-set (assoc-set-table new-assoc-set))
+             (set-assoc-set-cardinality! assoc-set (assoc-set-cardinality new-assoc-set))
+             assoc-set])))))
+  
+  ; assoc-set assoc-set (value value -> value) (opt (union 'new 'first 'second)) -> assoc-set
+  (define assoc-set-union
+    (opt-lambda (assoc-set1 assoc-set2 merge-values (which-assoc-set 'new))
+      (let* ([=? (assoc-set-=? assoc-set1)]
+             [new-assoc-set
+              (let loop ([table1 (assoc-set-table assoc-set1)]
+                         ; we shouldn't modify the original list
+                         [table2 (copy-assoc-list (assoc-set-table assoc-set2))]
+                         [count1 (assoc-set-cardinality assoc-set1)]
+                         [count2 (assoc-set-cardinality assoc-set2)]
+                         [acc '()]
+                         [count 0])
+                (if (null? table1)
+                    ; we have already copied table2, so we can destructively modify it
+                    (make-assoc-set =? (+ count count2)
+                                         (append! table2 acc))
+                    (if (null? table2)
+                        (make-assoc-set =? (+ count count1)
+                                             (copy-reverse-and-prefix-assoc-lists table1 acc))
+                        (let ([key1 (caar table1)])
+                          ; search table2 for same key
+                          (let loop-assoc-set2 ([t2 table2]
+                                                [previous #f])
+                            (if (null? t2)
+                                (begin
+                                  (set! acc (cons (cons key1 (cdar table1)) acc))
+                                  (set! count (add1 count))
+                                  (set! table1 (cdr table1))
+                                  (set! count1 (sub1 count1)))
+                                (if (=? key1 (caar t2))
+                                    (begin
+                                      (set! acc (cons (cons key1 (merge-values (cdar table1) (cdar t2))) acc))
+                                      (set! count (add1 count))
+                                      (set! table1 (cdr table1))
+                                      (set! count1 (sub1 count1))
+                                      (if previous
+                                          (set-cdr! previous (cdr t2))
+                                          (set! table2 (cdr table2)))
+                                      (set! count2 (sub1 count2)))
+                                    (loop-assoc-set2 (cdr t2) t2))))
+                          (loop table1 table2 count1 count2 acc count)))))])
+        (case which-assoc-set
+          [(new) new-assoc-set]
+          [(first)
+           (set-assoc-set-cardinality! assoc-set1 (assoc-set-cardinality new-assoc-set))
+           (set-assoc-set-table! assoc-set1 (assoc-set-table new-assoc-set))
+           assoc-set1]
+          [(second)
+           (set-assoc-set-cardinality! assoc-set2 (assoc-set-cardinality new-assoc-set))
+           (set-assoc-set-table! assoc-set2 (assoc-set-table new-assoc-set))
+           assoc-set2]))))
+  
+  ; assoc-set assoc-set (value value -> value) (opt (union 'new 'first 'second)) -> assoc-set
+  (define assoc-set-intersection
+    (opt-lambda (assoc-set1 assoc-set2 merge-values (which-assoc-set 'new))
+      (let* ([=? (assoc-set-=? assoc-set1)]
+             [new-assoc-set
+              (let loop ([table1 (assoc-set-table assoc-set1)]
+                         ; we shouldn't modify the original list
+                         [table2 (copy-assoc-list (assoc-set-table assoc-set2))]
+                         [count1 (assoc-set-cardinality assoc-set1)]
+                         [count2 (assoc-set-cardinality assoc-set2)]
+                         [acc '()]
+                         [count 0])
+                (if (null? table1)
+                    (make-assoc-set =? count acc)
+                    (if (null? table2)
+                        (make-assoc-set =? count acc)
+                        (let ([key1 (caar table1)])
+                          ; search table2 for same key
+                          (let loop-assoc-set2 ([t2 table2]
+                                                [previous #f])
+                            (if (null? t2)
+                                (begin
+                                  (set! table1 (cdr table1))
+                                  (set! count1 (sub1 count1)))
+                                (if (=? key1 (caar t2))
+                                    (begin
+                                      (set! acc (cons (cons key1 (merge-values (cdar table1) (cdar t2))) acc))
+                                      (set! count (add1 count))
+                                      (set! table1 (cdr table1))
+                                      (set! count1 (sub1 count1))
+                                      (if previous
+                                          (set-cdr! previous (cdr t2))
+                                          (set! table2 (cdr table2)))
+                                      (set! count2 (sub1 count2)))
+                                    (loop-assoc-set2 (cdr t2) t2))))
+                          (loop table1 table2 count1 count2 acc count)))))])
+        (case which-assoc-set
+          [(new) new-assoc-set]
+          [(first)
+           (set-assoc-set-cardinality! assoc-set1 (assoc-set-cardinality new-assoc-set))
+           (set-assoc-set-table! assoc-set1 (assoc-set-table new-assoc-set))
+           assoc-set1]
+          [(second)
+           (set-assoc-set-cardinality! assoc-set2 (assoc-set-cardinality new-assoc-set))
+           (set-assoc-set-table! assoc-set2 (assoc-set-table new-assoc-set))
+           assoc-set2]))))
+  
+  ; assoc-set assoc-set (opt (union 'new 'first 'second)) -> assoc-set
+  (define assoc-set-difference
+    (opt-lambda (assoc-set1 assoc-set2 (which-assoc-set 'new))
+      (let* ([=? (assoc-set-=? assoc-set1)]
+             [new-assoc-set
+              (let loop ([table1 (assoc-set-table assoc-set1)]
+                         ; we shouldn't modify the original list
+                         [table2 (copy-assoc-list (assoc-set-table assoc-set2))]
+                         [count1 (assoc-set-cardinality assoc-set1)]
+                         [count2 (assoc-set-cardinality assoc-set2)]
+                         [acc '()]
+                         [count 0])
+                (if (null? table1)
+                    (make-assoc-set =? count acc)
+                    (if (null? table2)
+                        (make-assoc-set =? (+ count count1)
+                                             (copy-reverse-and-prefix-assoc-lists table1 acc))
+                        (let ([key1 (caar table1)])
+                          ; search table2 for same key
+                          (let loop-assoc-set2 ([t2 table2]
+                                                [previous #f])
+                            (if (null? t2)
+                                (begin
+                                  (set! acc (cons (cons key1 (cdar table1)) acc))
+                                  (set! count (add1 count))
+                                  (set! table1 (cdr table1))
+                                  (set! count1 (sub1 count1)))
+                                (if (=? key1 (caar t2))
+                                    (begin
+                                      (set! table1 (cdr table1))
+                                      (set! count1 (sub1 count1))
+                                      (if previous
+                                          (set-cdr! previous (cdr t2))
+                                          (set! table2 (cdr table2)))
+                                      (set! count2 (sub1 count2)))
+                                    (loop-assoc-set2 (cdr t2) t2))))
+                          (loop table1 table2 count1 count2 acc count)))))])
+        (case which-assoc-set
+          [(new) new-assoc-set]
+          [(first)
+           (set-assoc-set-cardinality! assoc-set1 (assoc-set-cardinality new-assoc-set))
+           (set-assoc-set-table! assoc-set1 (assoc-set-table new-assoc-set))
+           assoc-set1]
+          [(second)
+           (set-assoc-set-cardinality! assoc-set2 (assoc-set-cardinality new-assoc-set))
+           (set-assoc-set-table! assoc-set2 (assoc-set-table new-assoc-set))
+           assoc-set2]))))
+  
+  )
diff --git a/collects/mrflow/constants.ss b/collects/mrflow/constants.ss
new file mode 100644
index 0000000000..fa42218b47
--- /dev/null
+++ b/collects/mrflow/constants.ss
@@ -0,0 +1,36 @@
+
+(module constants mzscheme
+  (provide
+   dummy
+   dummy-thunk
+   undefined
+   thunk-empty
+   thunk-false
+   test-true
+   test-false
+   id
+   (rename void-cst void)
+   select-right
+   select-left
+   ;car!
+   ;cdr!
+   )
+  
+  (define dummy (void))
+  (define dummy-thunk (lambda () dummy))
+  (define undefined (letrec ([x x]) x))
+  (define thunk-empty (lambda () '()))
+  (define thunk-false (lambda () #f))
+  (define test-true (lambda (x) #t))
+  (define test-false (lambda (x) #f))
+  (define id (lambda (x) x))
+  (define void-cst (void))
+  (define select-right (lambda (x y) y))
+  (define select-left (lambda (x y) x))
+  ;(define car! (case-lambda
+  ;               [(pair) (car pair)]
+  ;               [(pair val) (set-car! pair val)]))
+  ;(define cdr! (case-lambda
+  ;               [(pair) (cdr pair)]
+  ;               [(pair val) (set-cdr! pair val)]))
+  )
diff --git a/collects/mrflow/constraints-gen-and-prop.ss b/collects/mrflow/constraints-gen-and-prop.ss
new file mode 100644
index 0000000000..905480bc81
--- /dev/null
+++ b/collects/mrflow/constraints-gen-and-prop.ss
@@ -0,0 +1,4924 @@
+; The first label is the origin label (the origin of the arrow), the second label in the one
+; flowing along the arrow. The destination of the arrow is embedded in the edge. The third
+; label is used for tunneling (see create-simple-edge below).
+; (define-type edge (label label label -> boolean))
+
+(module constraints-gen-and-prop (lib "mrflow.ss" "mrflow")
+  (require (prefix kern: (lib "kerncase.ss" "syntax"))
+           (prefix list: (lib "list.ss"))
+           (prefix etc: (lib "etc.ss"))
+           
+           (lib "match.ss")
+           
+           "labels.ss"
+           "types.ss"
+           "set-hash.ss"
+           (prefix util: "util.ss")
+           (prefix hc: "hashcons.ss")
+           (prefix cst: "constants.ss")
+           ;(prefix types: "types.ss")
+           (prefix err: "sba-errors.ss")
+           )
+  (provide
+   make-sba-state
+   initialize-primitive-type-schemes
+   create-label-from-term
+   check-primitive-types
+   get-type-from-label
+   pp-type
+   
+   get-mzscheme-position-from-label
+   is-label-atom?
+   get-span-from-label
+   get-errors-from-label
+   get-source-from-label
+   get-parents-from-label
+   get-children-from-label
+   get-arrows-from-labels
+   )
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; MISC
+  
+  (define-struct arrows (in out tunnel) (make-inspector))
+  
+  ; type-scheme label
+  (define-struct prim-data (type-scheme label))
+  
+  (define-struct sba-state (; label -> void
+                            register-label-with-gui
+                            ; error-table
+                            errors
+                            ; (hash-tableof symbol label)
+                            top-level-name->label
+                            ; (hash-tableof label (cons type (hash-table-of type-flow-var (cons label type))))
+                            label->types
+                            ; non-negative-exact-integer
+                            type-var-counter
+                            ; (hash-tableof (cons symbol type-scheme))
+                            primitive-types-table
+                            ; hashcons-table
+                            hashcons-tbl
+                            ))
+  
+  ; label -> boolean
+  ; is the term associated with a label registerable (i.e. does it have
+  ; an actual term associated with it in the user's code)?
+  (define (gui-registerable? label)
+    (let ([term (label-term label)])
+      (or (syntax-original? term)
+          (syntax-property term 'origin))))
+  
+  (set! make-sba-state
+        (let ([real-make-sba-state make-sba-state])
+          (lambda (register-label-with-gui)
+            (real-make-sba-state (lambda (label)
+                                   (when (gui-registerable? label)
+                                     (register-label-with-gui label)))
+                                 (err:error-table-make)
+                                 (make-hash-table)
+                                 (make-hash-table)
+                                 0
+                                 (make-hash-table)
+                                 (hc:make-hashcons-table)))))
+  
+  
+  ; length of list composed of label-cons
+  (define (label-list-length start-label)
+    (letrec ([count-length
+              (lambda (label count)
+                (if (label-cons? label)
+                    (count-length (label-cons-cdr label) (add1 count))
+                    (if (and (label-cst? label)
+                             (null? (label-cst-value label)))
+                        count
+                        ;(error 'label-list-length
+                        ;       "not a label list: ~a ~a ~a"
+                        ;       (syntax-object->datum
+                        ;        (label-term start-label))
+                        ;       (pp-type sba-state (get-type-from-label sba-state start-label) 'label-list-length)
+                        ;       label))))])
+                        ; the assumption is that we'll never call this function
+                        ; for something not a list. So if what we have doesn't
+                        ; look like a list, then it's an infinite list.
+                        +inf.0)))])
+      (count-length start-label 0)))
+  
+  ; transform a label-based list into a cons-based list
+  ; sba-state (label-listof top)  -> (listof top)
+  (define (label-list->list sba-state start-label)
+    (letrec ([ll->l
+              (lambda (label)
+                (cond
+                  [(label-cons? label) (cons (label-cons-car label) (ll->l (label-cons-cdr label)))]
+                  [(and (label-cst? label) (null? (label-cst-value label))) '()]
+                  [else (error 'label-list->list
+                               "not a label list: ~a"
+                               (pp-type sba-state (get-type-from-label sba-state start-label) 'label-list->list))]))])
+      (ll->l start-label)))
+  
+  ; like ormap, except that it continues processing the list even after the first non-#f
+  ; is encountered
+  (define ormap-strict
+    (letrec ([ormap-strict-1-acc
+              (lambda (f l acc)
+                (if (null? l)
+                    acc
+                    (if (f (car l))
+                        (ormap-strict-1-acc f (cdr l) #t)
+                        (ormap-strict-1-acc f (cdr l) acc))))])
+      (lambda (f l)
+        (if (null? l)
+            #t
+            (ormap-strict-1-acc f (cdr l) (f (car l)))))))
+  
+  (define ormap2-strict
+    (letrec ([ormap-strict-1-acc
+              (lambda (f l1 l2 acc)
+                (if (null? l1)
+                    acc
+                    (if (f (car l1) (car l2))
+                        (ormap-strict-1-acc f (cdr l1) (cdr l2) #t)
+                        (ormap-strict-1-acc f (cdr l1) (cdr l2) acc))))])
+      (lambda (f l1 l2)
+        (if (null? l1)
+            #t
+            (ormap-strict-1-acc f (cdr l1) (cdr l2) (f (car l1) (car l2)))))))
+
+  ; like ormap, except that it continues processing the list even after the first non-#f
+  ; is encountered
+  ; l1 is a label-cons based list, l1 and l2 have the same length
+  (define label-ormap-strict
+    (letrec ([ormap-strict-2-acc
+              (lambda (f l1 l2 acc)
+                (if (null? l2)
+                    acc
+                    (if (f (label-cons-car l1) (car l2))
+                        (ormap-strict-2-acc f (label-cons-cdr l1) (cdr l2) #t)
+                        (ormap-strict-2-acc f (label-cons-cdr l1) (cdr l2) acc))))])
+      (lambda (f l1 l2)
+        (if (null? l2)
+            #t
+            (ormap-strict-2-acc f (label-cons-cdr l1) (cdr l2) (f (label-cons-car l1) (car l2)))))))
+  
+  ; (listof top) (listof top) -> (listof top)
+  ; This is O(n^2) but we expect the lists to be small, otherwise use a hash table... It's only
+  ; used in the GUI part anyway.
+  ; Note that neither l1 nor l2 contains duplicates, because of the test in create-simple-edge
+  (define (merge-lists l1 l2)
+    (cond
+      [(null? l1) l2]
+      [else (let ([elt-l1 (car l1)])
+              (if (memq elt-l1 l2)
+                  (merge-lists (cdr l1) l2)
+                  (cons elt-l1 (merge-lists (cdr l1) l2))))]))
+  
+  ; pretty-print code (represented as sexp)
+  (define (unexpand t)
+    (if (pair? t)
+        (let ([kw (car t)])
+          (if (list? t)
+              (cond
+                [(eq? kw '#%app) (map unexpand (cdr t))]
+                [else (map unexpand t)])
+              (cond
+                [(eq? kw '#%datum) (cdr t)]
+                [(eq? kw '#%top) (cdr t)]
+                [else t])))
+        t))
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; LOCAL ENVIRONMENT
+  
+  ; (listof (cons symbol label)) (listof syntax-objects) (listof label)
+  ; -> (listof (cons symbol label))
+  ; the syntax objects in args are all atomic syntax objects for argument names
+  ; the labels in args-labels are all simple labels (not pseudo-labels)
+  (define (extend-env env args args-labels)
+    ; doesn't matter whether we foldl or foldr
+    (list:foldl
+     (lambda (arg arg-label env)
+       (cons (cons (syntax-e arg) arg-label)
+             env))
+     env args args-labels))
+  
+  ; syntax-object (listof (cons symbol label)) -> (union label #f)
+  (define (lookup-env var env)
+    (let ([name-label-pair (assq (syntax-e var) env)])
+      (if name-label-pair
+          (cdr name-label-pair)
+          #f)))
+  
+  ; (listof (cons symbol label)) symbol label -> boolean
+  (define (search-and-replace env arg label)
+    (if (null? env)
+        #f
+        (if (eq? arg (caar env))
+            (begin
+              (set-cdr! (car env) label)
+              #t)
+            (search-and-replace (cdr env) arg label))))
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; TOP LEVEL ENVIRONMENT
+  
+  ; sba-state syntax-object label -> void
+  (define (add-top-level-name sba-state term label)
+    (hash-table-put! (sba-state-top-level-name->label sba-state) (syntax-object->datum term) label))
+  
+  ; sba-state symbol -> (union label #f)
+  ; finds the label for a top level var.
+  (define (lookup-top-level-name sba-state name)
+    (hash-table-get (sba-state-top-level-name->label sba-state) name cst:thunk-false))
+  
+  ; sba-state (listof label) term -> boolean
+  ; Note that we make sure that all free variables are bound before
+  ; creating the edges, and we check all free variables even if we
+  ; already know some of them are unbound.
+  ; Note also that a free variable can not be captured by a lexical
+  ; binding, it has to be a top level binding.
+  (define (lookup-and-bind-top-level-vars sba-state free-vars-labels-in term)
+    (for-each
+     (lambda (free-var-label-in)
+       ; we do the top level lookup first, so we allow primitives to be redefined
+       (let* ([free-var-name-in (syntax-e (label-term free-var-label-in))]
+              [free-var-edge (extend-edge-for-values sba-state (create-simple-edge free-var-label-in))]
+              [binding-label-in
+               (let ([top-label (lookup-top-level-name sba-state free-var-name-in)])
+                 (if top-label
+                     top-label
+                     (let ([primitive-data (lookup-primitive-data sba-state free-var-name-in)])
+                       (if primitive-data
+                           ; no polyvariance for primitives here...
+                           ; but we need to make sure set! works for primitives by having
+                           ; a flow from a label simulating the primitive's definition
+                           (let* ([result-label (reconstruct-graph-from-type-scheme
+                                                 sba-state
+                                                 (prim-data-type-scheme primitive-data) (make-hash-table)
+                                                 free-var-label-in)]
+                                  [prim-def-label (prim-data-label primitive-data)]
+                                  [result-edge (create-simple-edge result-label)])
+                             (add-edge-and-propagate-set-through-edge prim-def-label result-edge)
+                             result-label)
+                           (cond
+                             [(eq? free-var-name-in 'make-struct-type)
+                              (create-make-struct-type-label sba-state term)]
+                             ; we will process these two after the one above, for a given struct
+                             ; definition, because, after program expansion,
+                             ; make-struct-field-accessor/mutator appear in the body of a letrec-values
+                             ; with make-struct-type being used in one of the letrec-values clauses.
+                             [(eq? free-var-name-in 'make-struct-field-accessor)
+                              (create-make-struct-field-accessor-label sba-state term)]
+                             [(eq? free-var-name-in 'make-struct-field-mutator)
+                              (create-make-struct-field-mutator-label sba-state term)]
+                             [(eq? free-var-name-in 'set-car!)
+                              (create-2args-mutator sba-state
+                                                    label-cons?
+                                                    cst:test-true
+                                                    label-cons-car
+                                                    cst:id
+                                                    "pair"
+                                                    "internal error 1: all types must be a subtype of top"
+                                                    term)]
+                             [(eq? free-var-name-in 'set-cdr!)
+                              (create-2args-mutator sba-state
+                                                    label-cons?
+                                                    cst:test-true
+                                                    label-cons-cdr
+                                                    cst:id
+                                                    "pair"
+                                                    "internal error 2: all types must be a subtype of top"
+                                                    term)]
+                             ; we just inject the string type into the first arg
+                             [(eq? free-var-name-in 'string-set!)
+                              (create-3args-mutator sba-state
+                                                    (lambda (inflowing-label)
+                                                      (subtype-type sba-state
+                                                                    (get-type-from-label sba-state inflowing-label)
+                                                                    (make-type-cst 'string)
+                                                                    'lookup-and-bind-top-level-vars1
+                                                                    #f #f))
+                                                    (lambda (inflowing-label)
+                                                      (subtype-type sba-state
+                                                                    (get-type-from-label sba-state inflowing-label)
+                                                                    (make-type-cst 'exact-integer)
+                                                                    'lookup-and-bind-top-level-vars2
+                                                                    #f #f))
+                                                    (lambda (inflowing-label)
+                                                      (subtype-type sba-state
+                                                                    (get-type-from-label sba-state inflowing-label)
+                                                                    (make-type-cst 'char)
+                                                                    'lookup-and-bind-top-level-vars3
+                                                                    #f #f))
+                                                    cst:id
+                                                    (lambda (inflowing-label)
+                                                      (let ([label (make-label-cst
+                                                                    #f #f #f #f #f
+                                                                    (label-term inflowing-label)
+                                                                    (make-hash-table)
+                                                                    (make-hash-table)
+                                                                    'string)])
+                                                        (initialize-label-set-for-value-source label)
+                                                        label))
+                                                    "string"
+                                                    "exact-integer"
+                                                    "char"
+                                                    term)]
+                             [(eq? free-var-name-in 'string-fill!)
+                              (create-2args-mutator sba-state
+                                                    (lambda (inflowing-label)
+                                                      (subtype-type sba-state
+                                                                    (get-type-from-label sba-state inflowing-label)
+                                                                    (make-type-cst 'string)
+                                                                    'lookup-and-bind-top-level-vars4
+                                                                    #f #f))
+                                                    (lambda (inflowing-label)
+                                                      (subtype-type sba-state
+                                                                    (get-type-from-label sba-state inflowing-label)
+                                                                    (make-type-cst 'char)
+                                                                    'lookup-and-bind-top-level-vars5
+                                                                    #f #f))
+                                                    cst:id
+                                                    (lambda (inflowing-label)
+                                                      (let ([label (make-label-cst
+                                                                    #f #f #f #f #f
+                                                                    (label-term inflowing-label)
+                                                                    (make-hash-table)
+                                                                    (make-hash-table)
+                                                                    'string)])
+                                                        (initialize-label-set-for-value-source label)
+                                                        label))
+                                                    "string"
+                                                    "char"
+                                                    term)]
+                             ; inject third arg into first
+                             [(eq? free-var-name-in 'vector-set!)
+                              (create-3args-mutator sba-state
+                                                    (lambda (inflowing-label)
+                                                      (subtype-type sba-state
+                                                                    (get-type-from-label sba-state inflowing-label)
+                                                                    (make-type-vector (make-type-cst 'top))
+                                                                    'lookup-and-bind-top-level-vars6
+                                                                    #f #f))
+                                                    (lambda (inflowing-label)
+                                                      (subtype-type sba-state
+                                                                    (get-type-from-label sba-state inflowing-label)
+                                                                    (make-type-cst 'exact-integer)
+                                                                    'lookup-and-bind-top-level-vars7
+                                                                    #f #f))
+                                                    cst:test-true
+                                                    label-vector-element
+                                                    cst:id
+                                                    "vector"
+                                                    "exact-integer"
+                                                    "internal error 3: all types must be a subtype of top"
+                                                    term)]
+                             [(eq? free-var-name-in 'vector-fill!)
+                              (create-2args-mutator sba-state
+                                                    (lambda (inflowing-label)
+                                                      (subtype-type sba-state
+                                                                    (get-type-from-label sba-state inflowing-label)
+                                                                    (make-type-vector (make-type-cst 'top))
+                                                                    'lookup-and-bind-top-level-vars8
+                                                                    #f #f))
+                                                    cst:test-true
+                                                    label-vector-element
+                                                    cst:id
+                                                    "vector"
+                                                    "internal error 4: all types must be a subtype of top"
+                                                    term)]
+                             [else
+                              (begin
+                                (set-error-for-label sba-state
+                                                     free-var-label-in
+                                                     'red
+                                                     ;(format "reference to undefined identifier: ~a in function ~a"
+                                                     ;        free-var-name-in
+                                                     ;        (unexpand (syntax-object->datum term))))
+                                                     (format "reference to undefined identifier: ~a"
+                                                             (syntax-object->datum (label-term free-var-label-in))))
+                                #f)])))))])
+         (when binding-label-in
+           (add-edge-and-propagate-set-through-edge
+            binding-label-in
+            (extend-edge-for-values sba-state (create-simple-edge free-var-label-in))))))
+     free-vars-labels-in)
+    ; we act as if all the lookups always work, so we propagate as much as possible
+    ; and find as many errors as possible.
+    #t)
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; PROPAGATION
+  
+  ; label boolean -> edge
+  ; creates simple edge function that just propagates labels into in-label's set
+  ; and propagates down the flow, taking cycles into account.
+  ; note that the out-label is not a parameter of create-simple-edge, but a parameter of
+  ; the resulting edge. This is both because it makes for nicer edges and edge creation code
+  ; (since the edges are origin independant), and for historical reasons (because we used to
+  ; create fake top level variables for lambdas and the edges that were added to these fake
+  ; labels were moved to the label for the actual lambda when the enclosing lambda was applied
+  ; - having to move edges meant they had to be origin independant). This also means that we
+  ; can nicely re-use the same edge over and over when dealing with multiple values (see
+  ; extend-edge-for-values below).
+  (define (create-simple-edge in-label)
+    (let ([in-set (label-set in-label)])
+      (cons
+       (if (label-prim? in-label)
+           (lambda (out-label inflowing-label tunnel-label)
+             ; entering tunnel => initialize tunnel entrance
+             (unless tunnel-label
+               ;(when (or (label-cons? inflowing-label)
+               ;          (and (label-cst? inflowing-label)
+               ;               (number? (label-cst-value inflowing-label))
+               ;               (or (= 1 (label-cst-value inflowing-label))
+               ;                   (= 2 (label-cst-value inflowing-label)))))
+               ;  (printf "starting tunnel for ~a: ~a~n" inflowing-label out-label);)
+               (set! tunnel-label out-label))
+             ; Note: we assume that primitives don't have internal cycles, so we
+             ; don't have to keep track of in/out edges. We still have to put the
+             ; inflowing-label in the set, because otherwise nothing is going to be
+             ; propagated when we add a new edge to the in-label.
+             (let ([arrows (hash-table-get in-set inflowing-label cst:thunk-false)])
+               (if arrows
+                   (if (memq tunnel-label (arrows-tunnel arrows))
+                       ; we have seen this inflowing-label before, and we already know about
+                       ; this tunnel entrance => do nothing.
+                       #t
+                       ; we have seen this inflowing label before, but not from the same tunnel
+                       ; entrance, so add the new entrance and propagate further down, so other
+                       ; labels down the flow will know about the new tunnel entrance too...
+                       (begin
+                         (set-arrows-tunnel! arrows (cons tunnel-label (arrows-tunnel arrows)))
+                         (ormap-strict (lambda (edge)
+                                         (edge in-label inflowing-label tunnel-label))
+                                       (hash-table-map (label-edges in-label)
+                                                       cst:select-right))))
+                   ; first time we see this inflowing-label
+                   (begin
+                     (hash-table-put! in-set inflowing-label (make-arrows '() '() (list tunnel-label)))
+                     (ormap-strict (lambda (edge)
+                                     (edge in-label inflowing-label tunnel-label))
+                                   (hash-table-map (label-edges in-label)
+                                                   cst:select-right))))))
+           ;(when (or (label-cons? inflowing-label)
+           ;          (and (label-cst? inflowing-label)
+           ;               (number? (label-cst-value inflowing-label))
+           ;               (or (= 1 (label-cst-value inflowing-label))
+           ;                   (= 1 (label-cst-value inflowing-label)))))
+           ;(printf "propagate ~a from ~a to ~a (type ~a)~n"
+           ;        (pp-type sba-state (get-type-from-label sba-state inflowing-label) 'create-simpled-edge1)
+           ;        (syntax-object->datum (label-term out-label))
+           ;        (syntax-object->datum (label-term in-label))
+           ;        (label-type-var in-label))
+           ;  )
+           ;(ormap-strict (lambda (edge)
+           ;                (edge in-label inflowing-label tunnel-label))
+           ;              (hash-table-map (label-edges in-label)
+           ;                              cst:select-right)))
+           (lambda (out-label inflowing-label tunnel-label)
+             (when tunnel-label
+               ; coming out of tunnel, so set the out-label to the entrance of tunnel,
+               ; and reset tunneling.
+               ;(when (or (label-cons? inflowing-label)
+               ;          (and (label-cst? inflowing-label)
+               ;               (number? (label-cst-value inflowing-label))
+               ;               (or (= 1 (label-cst-value inflowing-label))
+               ;                   (= 2 (label-cst-value inflowing-label)))))
+               ;  (printf "resetting tunnel for ~a: ~a~n" inflowing-label out-label);)
+               (set! out-label tunnel-label))
+             (let* ([out-set (label-set out-label)]
+                    [arrows-in-set
+                     (hash-table-get in-set inflowing-label cst:thunk-false)]
+                    [arrows-out-set
+                     (hash-table-get out-set inflowing-label cst:thunk-false)])
+               (if arrows-in-set
+                   ; the value has already flown before into this set, which means it has
+                   ; already been propagated further down. So we just need to update the
+                   ; in/out edges. Note that a side effect of this is that we never loop
+                   ; indefinitely inside a cycle, which is mandatory if we generate things
+                   ; like (listof number) as a recursive type.
+                   (begin
+                     (hash-table-put! in-set inflowing-label
+                                      (make-arrows (cons out-label (arrows-in arrows-in-set))
+                                                   (arrows-out arrows-in-set)
+                                                   (list #f)))
+                     (hash-table-put! out-set inflowing-label
+                                      (make-arrows (arrows-in arrows-out-set)
+                                                   (cons in-label (arrows-out arrows-out-set))
+                                                   (list #f)))
+                     #t)
+                   ; first time this inflowing label is propagated to in-label, so update the
+                   ; in/out edges and propagate further down.
+                   (begin
+                     (hash-table-put! in-set inflowing-label
+                                      (make-arrows (list out-label)
+                                                   '()
+                                                   (list #f)))
+                     (hash-table-put! out-set inflowing-label
+                                      (make-arrows (arrows-in arrows-out-set)
+                                                   (cons in-label (arrows-out arrows-out-set))
+                                                   (list #f)))
+                     ;(when (or (label-cons? inflowing-label)
+                     ;          (and (label-cst? inflowing-label)
+                     ;               (number? (label-cst-value inflowing-label))
+                     ;               (or (= 1 (label-cst-value inflowing-label))
+                     ;                   (= 2 (label-cst-value inflowing-label)))))
+                     ;  (printf "propagate ~a from ~a to ~a (type ~a)~n"
+                     ;          (pp-type sba-state (get-type-from-label sba-state inflowing-label) 'create-simple-edge2)
+                     ;          (syntax-object->datum (label-term out-label))
+                     ;          (syntax-object->datum (label-term in-label))
+                     ;          (label-type-var in-label))
+                     ;  )
+                     (ormap-strict (lambda (edge)
+                                     (edge in-label inflowing-label #f))
+                                   (hash-table-map (label-edges in-label)
+                                                   cst:select-right)))))))
+       in-label)))
+  
+  ; label edge -> void
+  ; creates an edge from out-label to in-label and start the propagation for all the labels
+  ; in out-label's set.
+  ; Note: an edge is a function that updates the set of the in-label (and propagates further down
+  ; the flow), so there's no need to have the in-label appear here explicitely as an argument.
+  ; Note: if a function refers to a top level variable, and the function is applied twice and
+  ; the top level variable refers both times to the same binding, we dont' want to end up with
+  ; two parallel edges, so we have to test that.
+  (define (add-edge-and-propagate-set-through-edge out-label new-edge)
+    (let ([existing-edges-table (label-edges out-label)]
+          [edge-func (car new-edge)]
+          [in-label (cdr new-edge)])
+      (unless (hash-table-get existing-edges-table in-label cst:thunk-false)
+        (hash-table-put! existing-edges-table in-label edge-func)
+        ; note: no need to return a boolean, because we never check this result in union-
+        (hash-table-for-each (label-set out-label)
+                             (lambda (label arrows)
+                               (for-each (lambda (tunnel-label)
+                                           (edge-func out-label label tunnel-label))
+                                         (arrows-tunnel arrows)))))))
+  
+  ; sba-state edge label -> edge
+  ; We must be able to take care of all the following different cases:
+  ; (define-values (x) a)
+  ; (define-values (x) (values a))
+  ; (define-values (x) (values (values a)))
+  ; (define-values (x) (values (values (values a))))
+  ; ...
+  ; with all the call to "values" being possibly inside functions...
+  ; So we define extend-edge-for-values that recursively unpacks nested "values" by adding new
+  ; unpacking edges on the fly when a label-values flows into a label that has an unpacking edge.
+  ; The unpacking edge is created as a wrapper around a simple label-to-label edge simple-edge that
+  ; we use for direct propagation of non-values labels.
+  ; This is used in processing all values related forms (define-values, let-values, etc...)
+  ; Note that for values, we only ever wrap the in-edges, not the out-edges (i.e. the edges
+  ; that point towards a subexpression, not towards a context).
+  (define (extend-edge-for-values sba-state simple-edge)
+    (cons
+     (lambda (out-label inflowing-label tunnel-label)
+       (if (label-values? inflowing-label)
+           ; we have something like (values a) flowing in. Now what flows into a is a list
+           ; that contains the labels for the multiples values, so we have to extract that.
+           (let ([label-list (hash-table-map (label-set (label-values-label inflowing-label))
+                                             (lambda (label arrows)
+                                               label))])
+             (if (= (length label-list) 1)
+                 (let ([values-label (car label-list)])
+                   ; we do not expect an infinite list here, and even if we receive one it's
+                   ; okay to flag an error and not propagate (even if originally the list
+                   ; was of length one and we lost that information through, say, using apply)
+                   ; because we try to prevent values from flowing in, not flowing out
+                   ; (unlike what happens when we check for the number of values in the case
+                   ; define-values, let-values, or letrec-values).
+                   (if (= (label-list-length values-label) 1)
+                       ; we have something like (define-values (x) (... (values a) ...)), so we add a
+                       ; new direct edge from a to x. Of course this new edge has to be itself a recursive
+                       ; unpacking edge, since some (values b) could later flow into a. Note that, since
+                       ; our edges are independant of their origin, we can re-use the same simple edge.
+                       ; Watch then the nice infinitely-looking recursion. We are just creating a
+                       ; potentialy infinite number of unpacking edges, lazily. Also, since our edges
+                       ; are closures already containing the target label (the one for x),
+                       ; extend-edge-for-values doesn't need the target label as an explicit parameter.
+                       ; Only the origin label (the one corresponding to some use of "values") ever
+                       ; changes. This is just plain beautiful.
+                       (let ([new-origin-label (label-cons-car values-label)])
+                         (add-edge-and-propagate-set-through-edge
+                          new-origin-label
+                          (extend-edge-for-values sba-state simple-edge)))
+                       ; (define-values (x) (... (values a b ...) ...))
+                       (begin
+                         (set-error-for-label sba-state
+                                              inflowing-label
+                                              'red
+                                              (format "context expected 1 value, received ~a values"
+                                                      (label-list-length values-label)))
+                         #f)))
+                 ; values contains more than one thing.  This is either an internal error,
+                 ; or we have somehow ended up with an infinite list.  Since we trust ourselves,
+                 ; we decide that it's an infinite list, and since we can't determine the
+                 ; original length of the list we have to signal an error.
+                 ; Question: do we still propagate or not?  After all, the length of the original
+                 ; list might have been 1, in which case it would be correct to propagate.  On
+                 ; the other hand most of the cases here can be expected to be error cases
+                 ; (things like (apply values (list 1)) are not very common...) so propagating
+                 ; would just trigger many more errors...  We flag an error anyway so we should
+                 ; be fine.
+                 (set-error-for-label sba-state
+                                      inflowing-label
+                                      'red
+                                      (format "context expected 1 value, can't determine how many received"))
+                 ;(error 'extend-edge-for-values "values didn't contain list: ~a"
+                 ;       (pp-type sba-state (get-type-from-label sba-state inflowing-label) 'extend-edge-for-values)
+                 ;       ;(map (lambda (label)
+                 ;       ;       (list (pp-type sba-state (get-type-from-label sba-state label) 'extend-edge-for-values)
+                 ;       ;             (syntax-position (label-term label))
+                 ;       ;             (syntax-object->datum (label-term label))))
+                 ;       ;     label-list)
+                 ;       )
+                 ))
+           ; (define-values (x) a) or equivalent (e.g. the result of analysing something like
+           ; (define-values (x) (values (values (values a)))), after three levels of recursion).
+           ((car simple-edge) out-label inflowing-label tunnel-label)))
+     (cdr simple-edge)))
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; DERIVATION
+  
+  ; sba-state syntax-object -> label
+  ; create simple, basic label. Used directly during graph reconstruction for primitives, since
+  ; only the outer label will be associated with the term position, not all the internal labels.
+  (define (create-simple-label sba-state term)
+    (let ([label (make-label #f #f #f #f #f term (make-hash-table) (make-hash-table))])
+      ((sba-state-register-label-with-gui sba-state) label)
+      label))
+  
+  (define (create-dummy-label term)
+    (make-label #f #f #f #f #f term (make-hash-table) (make-hash-table)))
+  
+  ; create-simple-label is seldom used in the graph reconstruction from primitive type part
+  ; of the code but used a lot in the graph derivation code, so rather than add a second
+  ; argument to create-simple-label everywhere, it's easier to have this little specialized
+  ; function for primitives...
+  ; Note that such a label has prim? set to #t and that the associated term will, in practice,
+  ; be the term into which the primitive label will initially flow.
+  (define (create-simple-prim-label term)
+    (make-label #f #f #f #f #t term (make-hash-table) (make-hash-table)))
+  
+  ; label -> void
+  ; put a label in it's own set, for terms that are value sources
+  (define (initialize-label-set-for-value-source label)
+    (hash-table-put! (label-set label) label (make-arrows '() '() (list #f))))
+  
+  ; sba-state (listof booleans) (listof integer) (listof (listof label)) (listof label) label boolean -> edge
+  ; The four first parameters simulate the surrounding case-lambda specification. We could
+  ; wrap it inside a real case-lambda label, but we would have to create fake values for the
+  ; other components of the structure...
+  ; Note: we always create the args edges from left to right. We *need* this when we do
+  ; the black magic for structures (see the create-make-struct-type-label function)
+  (define (create-case-lambda-edge sba-state
+                                   rest-arg?s-around req-args-around
+                                   argss-labelss-around exps-labels-around
+                                   label contra-union?)
+    (cons
+     (lambda (out-label inflowing-case-lambda-label tunnel-label)
+       ; inflowing-case-lambda-label doesn't go anywhere, it's components are just connected to
+       ; the rest of the graph (around), so out-label (which will be the op-label from which
+       ; the case-lambda label is flowing out) is not used. I.e. op-label (out-label)
+       ; is a sink for functions.
+       (if (label-case-lambda? inflowing-case-lambda-label)
+           (let ([top-around-thunk
+                  (let loop-clauses-around
+                    (; one thunk wrapped around this one for each around clause that's been
+                     ; matched. If there's a matchinf error, it will be #f, and the test below
+                     ; will be false, stopping the loop-clauses-around loop.
+                     [around-thunk cst:dummy-thunk]
+                     [rest-arg?s-around rest-arg?s-around]
+                     [req-args-around req-args-around]
+                     [argss-labelss-around argss-labelss-around]
+                     [exps-labels-around exps-labels-around])
+                    (if (null? rest-arg?s-around)
+                        around-thunk
+                        (let ([top-in-thunk
+                               ; search match for current around clause, returning a thunk that
+                               ; creates all the right edges, or #f.
+                               (let loop-clauses-in
+                                 ([rest-arg?s-in (label-case-lambda-rest-arg?s inflowing-case-lambda-label)]
+                                  [req-args-in (label-case-lambda-req-args inflowing-case-lambda-label)]
+                                  [argss-labelss-in (label-case-lambda-argss inflowing-case-lambda-label)]
+                                  [exps-labels-in (label-case-lambda-exps inflowing-case-lambda-label)]
+                                  [effects-in (label-case-lambda-effects inflowing-case-lambda-label)])
+                                 (if (null? rest-arg?s-in)
+                                     ; No match found.
+                                     (begin
+                                       (set-error-for-label
+                                        sba-state
+                                        label
+                                        'red
+                                        (format "procedure application: arity mismatch, given: ~a; ~a required arguments were given"
+                                                (if (label-prim? inflowing-case-lambda-label)
+                                                    ; this won't work if we use a primitive
+                                                    ; in a higer-order way, but they can
+                                                    ; always trace the case-lambda back,
+                                                    ; so that should be good enough.
+                                                    (unexpand (syntax-object->datum (label-term label)))
+                                                    (unexpand
+                                                     (syntax-object->datum
+                                                      (label-term inflowing-case-lambda-label))))
+                                                (car req-args-around)))
+                                       #f)
+                                     (let ([rest-arg?-in (car rest-arg?s-in)]
+                                           [req-arg-in (car req-args-in)]
+                                           [rest-arg?-around (car rest-arg?s-around)]
+                                           [req-arg-around (car req-args-around)])
+                                       ; case 2 is similiar to case 5 and case 3 similar to case 4,
+                                       ; except that both case 4 and 5 don't go till they reach null.
+                                       (cond
+                                         [(and (or (and (not rest-arg?-in) (not rest-arg?-around))
+                                                   (and rest-arg?-in rest-arg?-around))
+                                               (= req-arg-in req-arg-around))
+                                          ; exact one-to-one match between in and around, with or without
+                                          ; rest args, it's the same
+                                          (lambda ()
+                                            ;(when (lookup-and-bind-top-level-vars
+                                            ;       (car effects-in) (label-term term))
+                                            ; make internal apps flow and top level vars looked up
+                                            ((car effects-in))
+                                            ;(set-car! app-thunks-in *dummy-thunk*)
+                                            (let args-loop-in
+                                              ([args-labels-in (car argss-labelss-in)]
+                                               [args-labels-around (car argss-labelss-around)])
+                                              (unless (null? args-labels-in)
+                                                (add-edge-and-propagate-set-through-edge
+                                                 (car args-labels-around)
+                                                 (extend-edge-for-values
+                                                  sba-state
+                                                  (create-simple-edge (car args-labels-in))))
+                                                (args-loop-in (cdr args-labels-in)
+                                                              (cdr args-labels-around))))
+                                            ; edge from body of clause to app term itself
+                                            ; note that we do not detect multiple values here
+                                            (add-edge-and-propagate-set-through-edge
+                                             (car exps-labels-in)
+                                             (create-simple-edge (car exps-labels-around))))]
+                                         [(and rest-arg?-in (not rest-arg?-around)
+                                               (<= req-arg-in req-arg-around))
+                                          ; fixed number of args around and the in function can
+                                          ; take them all. So we just have to create a label list for
+                                          ; the rest argument.
+                                          (lambda ()
+                                            ;(when (lookup-and-bind-top-level-vars
+                                            ;       (car effects-in) (label-term term))
+                                            ; make internal apps flow
+                                            ((car effects-in))
+                                            ;(set-car! app-thunks-in *dummy-thunk*)
+                                            (let args-loop-in
+                                              ([args-labels-in (car argss-labelss-in)]
+                                               [args-labels-around (car argss-labelss-around)])
+                                              ; we know we have a rest arg, so the list is not null
+                                              (if (null? (cdr args-labels-in))
+                                                  ; create list for rest arg
+                                                  (let* ([rest-arg-label (car args-labels-in)]
+                                                         [rest-arg-term (label-term rest-arg-label)]
+                                                         [args-labels-around-in-labellist
+                                                          (let rest-loop-around ([args-labels-around
+                                                                                  args-labels-around])
+                                                            (if (null? args-labels-around)
+                                                                (let ([null-label
+                                                                       (make-label-cst
+                                                                        #f #f #f #f #t
+                                                                        rest-arg-term
+                                                                        (make-hash-table)
+                                                                        (make-hash-table)
+                                                                        '())])
+                                                                  (initialize-label-set-for-value-source
+                                                                   null-label)
+                                                                  ;(register-label-with-gui
+                                                                  ; null-label)
+                                                                  null-label)
+                                                                (let ([cons-label
+                                                                       (make-label-cons
+                                                                        #f #f #f #f #t
+                                                                        rest-arg-term
+                                                                        (make-hash-table)
+                                                                        (make-hash-table)
+                                                                        (car args-labels-around)
+                                                                        (rest-loop-around
+                                                                         (cdr args-labels-around)))])
+                                                                  (initialize-label-set-for-value-source
+                                                                   cons-label)
+                                                                  ;(register-label-with-gui
+                                                                  ; cons-label)
+                                                                  cons-label)))])
+                                                    ; we know args-label-around-inlabellist is not
+                                                    ; a multiple value...
+                                                    (add-edge-and-propagate-set-through-edge
+                                                     args-labels-around-in-labellist
+                                                     (create-simple-edge rest-arg-label)))
+                                                  ; normal args
+                                                  (begin
+                                                    (add-edge-and-propagate-set-through-edge
+                                                     (car args-labels-around)
+                                                     (extend-edge-for-values
+                                                      sba-state
+                                                      (create-simple-edge (car args-labels-in))))
+                                                    (args-loop-in (cdr args-labels-in)
+                                                                  (cdr args-labels-around)))))
+                                            ; edge from body of clause to app term itself
+                                            ; note that we do not detect multiple values here
+                                            (add-edge-and-propagate-set-through-edge
+                                             (car exps-labels-in)
+                                             (create-simple-edge (car exps-labels-around))))]
+                                         [(and (not rest-arg?-in) rest-arg?-around
+                                               (>= req-arg-in req-arg-around))
+                                          ; in fct takes a fixed number of args and there's some of
+                                          ; them around in the rest argument => distribute  what
+                                          ; is in the rest arg around by creating cons-distributing
+                                          ; labels/edges. The problem is that we don't want to add
+                                          ; any edges between in and around as long as we aren't sure
+                                          ; we have the right number of arguments flowing into the
+                                          ; rest argument. So we use a separate inner thunk to delay
+                                          ; the creation of the edges for the regular arguments
+                                          ; until we know the right number of args is actually flowing
+                                          ; into the rest arg...
+                                          (let ([inner-thunk
+                                                 ; edge from body of clause to app term itself
+                                                 ; note that we do not detect multiple values here
+                                                 (lambda ()
+                                                   (add-edge-and-propagate-set-through-edge
+                                                    (car exps-labels-in)
+                                                    (create-simple-edge (car exps-labels-around))))])
+                                            (let args-loop-around
+                                              ([args-labels-in (car argss-labelss-in)]
+                                               [args-labels-around (car argss-labelss-around)])
+                                              ; we know we have a rest arg, so the list is not null
+                                              (if (null? (cdr args-labels-around))
+                                                  ; distribute list for rest arg, if we can
+                                                  ; note: we can create all the edges here in the let
+                                                  ; directly, because nothing will flow into them
+                                                  ; unless we add the arg-number-checking-edge to
+                                                  ; rest-arg-label, i.e. not until the lambda in the
+                                                  ; body of this let is applied (which will itself
+                                                  ; only happen when the top level loop terminates).
+                                                  (let* ([rest-arg-label (car args-labels-around)]
+                                                         [rest-arg-term (label-term rest-arg-label)]
+                                                         [splitting-rest-arg-label
+                                                          (let rest-loop-in
+                                                            ([args-labels-in args-labels-in])
+                                                            (if (null? args-labels-in)
+                                                                (let ([null-label
+                                                                       (make-label-cst
+                                                                        #f #f #f #f #t
+                                                                        rest-arg-term
+                                                                        (make-hash-table)
+                                                                        (make-hash-table)
+                                                                        '())])
+                                                                  ; note that there's no need to type
+                                                                  ; check here, because the only thing
+                                                                  ; that ever flows in is '(), since we
+                                                                  ; already checked the length below.
+                                                                  ; (except in the case of an infinite
+                                                                  ; list flowing in, in which case we don't
+                                                                  ; want to type check anything anyway).
+                                                                  ;(associate-label-with-type
+                                                                  ; null-checking-label
+                                                                  ; (make-type-cst '()))
+                                                                  null-label)
+                                                                (let* ([car-label (car args-labels-in)]
+                                                                       [car-edge (create-simple-edge car-label)]
+                                                                       [cdr-label (rest-loop-in (cdr args-labels-in))]
+                                                                       [cdr-edge (create-simple-edge cdr-label)]
+                                                                       [cons-label (create-simple-prim-label (label-term label))]
+                                                                       [cons-edge
+                                                                        (cons
+                                                                         (lambda (out-label inflowing-label tunnel-label)
+                                                                           ; cons sink => no use for
+                                                                           ; out-label here.
+                                                                           ; Note: we still have to test
+                                                                           ; that we actually have a
+                                                                           ; label-cons, in case the
+                                                                           ; inflowing list is infinite,
+                                                                           ; because then '() will flow in
+                                                                           ; too.
+                                                                           (when (label-cons? inflowing-label)
+                                                                             (and 
+                                                                              (add-edge-and-propagate-set-through-edge
+                                                                               (label-cons-car inflowing-label)
+                                                                               car-edge)
+                                                                              (add-edge-and-propagate-set-through-edge
+                                                                               (label-cons-cdr inflowing-label)
+                                                                               cdr-edge))))
+                                                                         ; cons sink
+                                                                         (gensym))])
+                                                                  ;(associate-label-with-type cons-label
+                                                                  ;                           (make-type-cons
+                                                                  ;                            (make-type-cst 'top) 
+                                                                  ;                            (make-type-cst 'top)))
+                                                                  (add-edge-and-propagate-set-through-edge
+                                                                   cons-label cons-edge)
+                                                                  cons-label)))]
+                                                         [splitting-rest-arg-edge
+                                                          (create-simple-edge splitting-rest-arg-label)]
+                                                         [arg-number-checking-edge
+                                                          (let ([inner-thunk inner-thunk])
+                                                            (cons
+                                                             (lambda (out-label inflowing-label tunnel-label)
+                                                               (let ([rest-list-length (label-list-length inflowing-label)])
+                                                                 (if (or (= rest-list-length +inf.0) ; infinite list
+                                                                         (= (+ rest-list-length req-arg-around)
+                                                                            req-arg-in))
+                                                                     (begin
+                                                                       ;(when (lookup-and-bind-top-level-vars
+                                                                       ;       (car effects-in) (label-term term))
+                                                                       ; make internal apps flow
+                                                                       ((car effects-in))
+                                                                       ;(set-car! app-thunks-in *dummy-thunk*)
+                                                                       (add-edge-and-propagate-set-through-edge
+                                                                        inflowing-label
+                                                                        splitting-rest-arg-edge)
+                                                                       (inner-thunk))
+                                                                     (begin
+                                                                       (set-error-for-label
+                                                                        sba-state
+                                                                        inflowing-case-lambda-label
+                                                                        'red
+                                                                        (format "possible arity error (might be a side effect of generating an infinite list): function ~a expected ~a arguments, received ~a"
+                                                                                ; this would underline the primitive that generated the list
+                                                                                ;(syntax-object->datum
+                                                                                ; (label-term 
+                                                                                ;  inflowing-label))
+                                                                                (syntax-object->datum
+                                                                                 (label-term
+                                                                                  inflowing-case-lambda-label))
+                                                                                req-arg-in
+                                                                                (+ rest-list-length req-arg-around)
+                                                                                ))
+                                                                       #f))))
+                                                             ; sink
+                                                             (gensym)))])
+                                                    (lambda ()
+                                                      ; that's the only thing the top level loop will
+                                                      ; have to do for this clause if all the clauses are
+                                                      ; matched. Everything else will be done when args
+                                                      ; flow into the rest arg.
+                                                      (add-edge-and-propagate-set-through-edge
+                                                       rest-arg-label
+                                                       arg-number-checking-edge)))
+                                                  ; normal args
+                                                  (begin
+                                                    (set! inner-thunk
+                                                          (let ([inner-thunk inner-thunk])
+                                                            (lambda ()
+                                                              (add-edge-and-propagate-set-through-edge
+                                                               (car args-labels-around)
+                                                               (extend-edge-for-values
+                                                                sba-state
+                                                                (create-simple-edge (car args-labels-in))))
+                                                              (inner-thunk))))
+                                                    (args-loop-around (cdr args-labels-in)
+                                                                      (cdr args-labels-around))))))]
+                                         [(and rest-arg?-in rest-arg?-around
+                                               (> req-arg-in req-arg-around))
+                                          ; same problem here as in the previous case...
+                                          (let ([inner-thunk
+                                                 ; edge from body of clause to app term itself
+                                                 ; note that we do not detect multiple values here
+                                                 (lambda ()
+                                                   (add-edge-and-propagate-set-through-edge
+                                                    (car exps-labels-in)
+                                                    (create-simple-edge (car exps-labels-around))))])
+                                            (let args-loop-around
+                                              ([args-labels-in (car argss-labelss-in)]
+                                               [args-labels-around (car argss-labelss-around)])
+                                              ; we know we have a rest arg, so the list is not null
+                                              (if (null? (cdr args-labels-around))
+                                                  ; distribute list for rest arg, if we can
+                                                  ; note: we can create all the edges here in the let
+                                                  ; directly, because nothing will flow into them
+                                                  ; unless we add the arg-number-checking-edge to
+                                                  ; rest-arg-label, i.e. not until the lambda in the
+                                                  ; body of this let is applied (which will itself
+                                                  ; only happen when the top level loop terminates).
+                                                  (let* ([rest-arg-label (car args-labels-around)]
+                                                         [rest-arg-term (label-term rest-arg-label)]
+                                                         [splitting-rest-arg-label
+                                                          (let rest-loop-in
+                                                            ([args-labels-in args-labels-in])
+                                                            (if (null? (cdr args-labels-in))
+                                                                ; all the remaining values in the list of rest-arg-around
+                                                                ; flow into rest-arg-in
+                                                                (car args-labels-in)
+                                                                (let* ([car-label (car args-labels-in)]
+                                                                       [car-edge (create-simple-edge car-label)]
+                                                                       [cdr-label (rest-loop-in (cdr args-labels-in))]
+                                                                       [cdr-edge (create-simple-edge cdr-label)]
+                                                                       [cons-label (create-simple-prim-label (label-term label))]
+                                                                       [cons-edge
+                                                                        (cons
+                                                                         (lambda (out-label inflowing-label tunnel-label)
+                                                                           ; cons sink => no use for
+                                                                           ; out-label here.
+                                                                           ; Note: we still have to test
+                                                                           ; that we actually have a
+                                                                           ; label-cons, in case the
+                                                                           ; inflowing list is infinite.
+                                                                           ; because then '() will flow in
+                                                                           ; too.
+                                                                           (when (label-cons? inflowing-label)
+                                                                             (and 
+                                                                              (add-edge-and-propagate-set-through-edge
+                                                                               (label-cons-car inflowing-label)
+                                                                               car-edge)
+                                                                              (add-edge-and-propagate-set-through-edge
+                                                                               (label-cons-cdr inflowing-label)
+                                                                               cdr-edge))))
+                                                                         ; cons sink
+                                                                         (gensym))])
+                                                                  ;(associate-label-with-type cons-label
+                                                                  ;                           (make-type-cons
+                                                                  ;                            (make-type-cst 'top) 
+                                                                  ;                            (make-type-cst 'top)))
+                                                                  (add-edge-and-propagate-set-through-edge
+                                                                   cons-label cons-edge)
+                                                                  cons-label)))]
+                                                         [splitting-rest-arg-edge
+                                                          (create-simple-edge splitting-rest-arg-label)]
+                                                         [arg-number-checking-edge
+                                                          (let ([inner-thunk inner-thunk])
+                                                            (cons
+                                                             (lambda (out-label inflowing-label tunnel-label)
+                                                               (let ([rest-list-length (label-list-length inflowing-label)])
+                                                                 (if (or (= rest-list-length +inf.0) ; infinite list
+                                                                         (= (+ rest-list-length req-arg-around)
+                                                                            req-arg-in))
+                                                                     (begin
+                                                                       ;(when (lookup-and-bind-top-level-vars
+                                                                       ;       (car effects-in) (label-term term))
+                                                                       ; make internal apps flow
+                                                                       ((car effects-in))
+                                                                       ;(set-car! app-thunks-in *dummy-thunk*)
+                                                                       (add-edge-and-propagate-set-through-edge
+                                                                        inflowing-label
+                                                                        splitting-rest-arg-edge)
+                                                                       (inner-thunk))
+                                                                     (begin
+                                                                       (set-error-for-label
+                                                                        sba-state
+                                                                        inflowing-case-lambda-label
+                                                                        'red
+                                                                        (format "possible arity error (might be a side effect of generating an infinite list): function ~a expected ~a arguments, received ~a"
+                                                                                ; this would underline the primitive that generated the list
+                                                                                ;(syntax-object->datum
+                                                                                ; (label-term 
+                                                                                ;  inflowing-label))
+                                                                                (syntax-object->datum
+                                                                                 (label-term
+                                                                                  inflowing-case-lambda-label))
+                                                                                req-arg-in
+                                                                                (+ rest-list-length req-arg-around)
+                                                                                ))
+                                                                       #f))))
+                                                             ; sink
+                                                             (gensym)))])
+                                                    (lambda ()
+                                                      ; that's the only thing the top level loop will
+                                                      ; have to do for this clause if all the clauses are
+                                                      ; matched. Everything else will be done when args
+                                                      ; flow into the rest arg.
+                                                      (add-edge-and-propagate-set-through-edge
+                                                       rest-arg-label
+                                                       arg-number-checking-edge)))
+                                                  ; normal args
+                                                  (begin
+                                                    (set! inner-thunk
+                                                          (let ([inner-thunk inner-thunk])
+                                                            (lambda ()
+                                                              (add-edge-and-propagate-set-through-edge
+                                                               (car args-labels-around)
+                                                               (extend-edge-for-values
+                                                                sba-state
+                                                                (create-simple-edge (car args-labels-in))))
+                                                              (inner-thunk))))
+                                                    (args-loop-around (cdr args-labels-in)
+                                                                      (cdr args-labels-around))))))]
+                                         [(and rest-arg?-in rest-arg?-around
+                                               (< req-arg-in req-arg-around))
+                                          (lambda ()
+                                            ;(when (lookup-and-bind-top-level-vars
+                                            ;       (car effects-in) (label-term term))
+                                            ; make internal apps flow
+                                            ((car effects-in))
+                                            ;(set-car! app-thunks-in *dummy-thunk*)
+                                            (let args-loop-in
+                                              ([args-labels-in (car argss-labelss-in)]
+                                               [args-labels-around (car argss-labelss-around)])
+                                              ; we know we have a rest arg, so the list is not null
+                                              (if (null? (cdr args-labels-in))
+                                                  ; create list for rest arg
+                                                  (let* ([rest-arg-label (car args-labels-in)]
+                                                         [rest-arg-term (label-term rest-arg-label)]
+                                                         [args-labels-around-in-labellist
+                                                          (let rest-loop-around ([args-labels-around
+                                                                                  args-labels-around])
+                                                            (if (null? (cdr args-labels-around))
+                                                                ; everything in rest-arg-around will flow
+                                                                ; into rest-arg-in, plus some other stuff
+                                                                ; around the list.
+                                                                (car args-labels-around)
+                                                                (let ([cons-label
+                                                                       (make-label-cons
+                                                                        #f #f #f #f #t
+                                                                        rest-arg-term
+                                                                        (make-hash-table)
+                                                                        (make-hash-table)
+                                                                        (car args-labels-around)
+                                                                        (rest-loop-around
+                                                                         (cdr args-labels-around)))])
+                                                                  (initialize-label-set-for-value-source
+                                                                   cons-label)
+                                                                  ;(register-label-with-gui
+                                                                  ; cons-label)
+                                                                  cons-label)))])
+                                                    ; we know args-label-around-inlabellist is not
+                                                    ; a multiple value...
+                                                    (add-edge-and-propagate-set-through-edge
+                                                     args-labels-around-in-labellist
+                                                     (create-simple-edge rest-arg-label)))
+                                                  ; normal args
+                                                  (begin
+                                                    (add-edge-and-propagate-set-through-edge
+                                                     (car args-labels-around)
+                                                     (extend-edge-for-values
+                                                      sba-state
+                                                      (create-simple-edge (car args-labels-in))))
+                                                    (args-loop-in (cdr args-labels-in)
+                                                                  (cdr args-labels-around)))))
+                                            ; edge from body of clause to app term itself
+                                            ; note that we do not detect multiple values here
+                                            (add-edge-and-propagate-set-through-edge
+                                             (car exps-labels-in)
+                                             (create-simple-edge (car exps-labels-around))))]
+                                         [else ; keep looking for a matching clause
+                                          (loop-clauses-in
+                                           (cdr rest-arg?s-in) (cdr req-args-in)
+                                           (cdr argss-labelss-in) (cdr exps-labels-in)
+                                           (cdr effects-in))]))))])
+                          (if top-in-thunk
+                              (loop-clauses-around (lambda ()
+                                                     ; connect the current around clause
+                                                     (top-in-thunk)
+                                                     ; and all the other ones before it
+                                                     (around-thunk))
+                                                   (cdr rest-arg?s-around)
+                                                   (cdr req-args-around)
+                                                   (cdr argss-labelss-around)
+                                                   (cdr exps-labels-around))
+                              #f))))])
+             (when top-around-thunk
+               (top-around-thunk)))
+           ; trying to apply something not a function
+           ; Note: nothing was done, so there's nothing to undo
+           (begin
+             (set-error-for-label sba-state
+                                  label
+                                  'red
+                                  (format "procedure application: expected procedure, given: ~a"
+                                          (unexpand (syntax-object->datum
+                                                     (label-term inflowing-case-lambda-label)))))
+             #f)))
+     ; function value sink => unique, fake destination
+     (gensym)))
+  
+  
+  ; (label -> boolean) label label edge -> edge
+  ; The returned edge simulates an "if" based on the result of pred.
+  ; our edges are origin-independant, so we can use the same one for both true and false.
+  (define (create-self-modifying-edge pred true-label false-label join-edge)
+    (letrec ([edge-fake-destination (gensym)]
+             [dummy-edge (cons
+                          (lambda (out-label inflowing-label tunnel-label)
+                            ; sink edge, so no need for out-label
+                            #t)
+                          ; test value sink
+                          edge-fake-destination)]
+             [self-modifying-edge
+              (cons
+               (lambda (out-label inflowing-label tunnel-label)
+                 ; sink edge, so no need for out-label
+                 (if (pred inflowing-label)
+                     (begin
+                       (set! self-modifying-edge
+                             (cons
+                              (lambda (out-label inflowing-label tunnel-label)
+                                ; sink edge, so no need for out-label
+                                (when (not (pred inflowing-label))
+                                  ; it would be more efficient to directly remove the edge.
+                                  (set! self-modifying-edge dummy-edge)
+                                  (add-edge-and-propagate-set-through-edge
+                                   false-label join-edge)))
+                              ; test value sink
+                              edge-fake-destination))
+                       (add-edge-and-propagate-set-through-edge
+                        true-label join-edge))
+                     (begin
+                       (set! self-modifying-edge
+                             (cons
+                              (lambda (out-label inflowing-label tunnel-label)
+                                ; sink edge, so no need for out-label
+                                (when (pred inflowing-label)
+                                  ; it would be more efficient to directly remove the edge.
+                                  (set! self-modifying-edge dummy-edge)
+                                  (add-edge-and-propagate-set-through-edge
+                                   true-label join-edge)))
+                              ; test value sink
+                              edge-fake-destination))
+                       (add-edge-and-propagate-set-through-edge
+                        false-label join-edge))))
+               ; test value sink
+               edge-fake-destination)])
+      self-modifying-edge))
+  
+  ; label label-struct-type -> boolean
+  ; is a struct value a subtype of a struct type ?
+  (define (is-subtype? label struct-type-label)
+    (and (label-struct-value? label)
+         (let loop ([type (label-struct-value-type label)])
+           (if type
+               (if (eq? type struct-type-label)
+                   #t
+                   (loop (label-struct-type-parent type)))
+               ; no more parent
+               #f))))
+  
+  ; sba-state syntax-object -> label
+  ; create a label in which a case-lambda label flows, which, when applied, creates
+  ; struct function labels of the right type.
+  ; Note that we will return a case-lambda label that does strange things when something
+  ; flows into it, in the sense that it will gather its different arguments using
+  ; struct-label, and then create new case-lambda labels on the fly.
+  ; Note also that we know that no multiple values can flow into the case-lambda label
+  ; for make-struct-type, or any other for that matter, so we don't have to worry about that.
+  ; (define-struct (bar foo) (d e f)) expands into
+  ; (begin
+  ;   (define-values
+  ;     (struct:bar make-bar bar? bar-d set-bar-d! bar-e set-bar-e! bar-f set-bar-f!)
+  ;     (let-values
+  ;         (((type maker pred access mutate)
+  ;           (#%app make-struct-type
+  ;                  'bar
+  ;                  (#%top . struct:foo)
+  ;                  (#%datum . 3)
+  ;                  (#%datum . 0)
+  ;                  (#%datum . #f)
+  ;                  null
+  ;                  (#%datum . #f))))
+  ;       (#%app values
+  ;              type
+  ;              maker
+  ;              pred
+  ;              (#%app make-struct-field-accessor access (#%datum . 0) 'd)
+  ;              (#%app make-struct-field-mutator mutate (#%datum . 0) 'd)
+  ;              (#%app make-struct-field-accessor access (#%datum . 1) 'e)
+  ;              (#%app make-struct-field-mutator mutate (#%datum . 1) 'e)
+  ;              (#%app make-struct-field-accessor access (#%datum . 2) 'f)
+  ;              (#%app make-struct-field-mutator mutate (#%datum . 2) 'f))))
+  ;   (define-syntaxes ...))
+  ; which explains most of the names below...
+  ; We only explicitely deal here with the
+  ;           (#%app make-struct-type
+  ;                  'bar
+  ;                  (#%top . struct:foo)
+  ;                  (#%datum . 3)
+  ;                  (#%datum . 0)
+  ;                  (#%datum . #f)
+  ;                  null
+  ;                  (#%datum . #f))))
+  ; part, and let the rest of the anlysis deal with values, let-values, variable bindings, etc...
+  (define (create-make-struct-type-label sba-state term)
+    (let* (; We really use this label as a type shared between the different instances
+           ; of the structure. It's also what we use to differentiate between two kinds of
+           ; structures with the same name. The only reason it's a label instead of a type
+           ; is because mzscheme treats it as a first class value and have it bound
+           ; to struct:blablabla, so it needs to be a label to be able to flow...
+           [struct-type-label (make-label-struct-type
+                               #f #f #f #f #t
+                               term
+                               (make-hash-table)
+                               (make-hash-table)
+                               'uninitialized ; struct has no name (yet)
+                               #f ; no parent by default
+                               0 ; parent has no fields by default
+                               0 ; struct has no fields by default
+                               #f)]
+           [maker-label (create-simple-prim-label term)]
+           [maker-edge (create-simple-edge maker-label)]
+           [pred-label (create-simple-prim-label term)]
+           [pred-edge (create-simple-edge pred-label)]
+           [access-label (create-simple-prim-label term)]
+           [access-edge (create-simple-edge access-label)]
+           [mutate-label (create-simple-prim-label term)]
+           [mutate-edge (create-simple-edge mutate-label)]
+           [null-label (make-label-cst #f #f #f #f #t term (make-hash-table) (make-hash-table) '())]
+           [cons-label1 (make-label-cons #f #f #f #f #t term (make-hash-table) (make-hash-table)
+                                         mutate-label null-label)]
+           [cons-label2 (make-label-cons #f #f #f #f #t term (make-hash-table) (make-hash-table)
+                                         access-label cons-label1)]
+           [cons-label3 (make-label-cons #f #f #f #f #t term (make-hash-table) (make-hash-table)
+                                         pred-label cons-label2)]
+           [cons-label4 (make-label-cons #f #f #f #f #t term (make-hash-table) (make-hash-table)
+                                         maker-label cons-label3)]
+           [cons-label5 (make-label-cons #f #f #f #f #t term (make-hash-table) (make-hash-table)
+                                         struct-type-label cons-label4)]
+           [values-label (make-label-values #f #f #f #f #t term (make-hash-table) (make-hash-table)
+                                            cons-label5)]
+           [name-label (create-simple-prim-label term)]
+           [name-edge
+            (cons
+             (lambda (out-label inflowing-label tunnel-label)
+               ; name sink => no use for out-label
+               ; only symbol should flow in here
+               (if (and (label-cst? inflowing-label)
+                        (symbol? (label-cst-value inflowing-label)))
+                   (begin
+                     (set-label-struct-type-name! struct-type-label
+                                                  (label-cst-value inflowing-label))
+                     #t)
+                   (begin
+                     (set-error-for-label sba-state
+                                          inflowing-label
+                                          'red
+                                          "make-struct-type expected symbol")
+                     (set-label-struct-type-error?! struct-type-label #t)
+                     #f)))
+             (gensym))]
+           [parent-label (create-simple-prim-label term)]
+           [parent-edge
+            (cons
+             (lambda (out-label inflowing-label tunnel-label)
+               ; name sink => no use for out-label
+               ; if anything flows in here, it should be the struct label for the
+               ; parent struct, or #f
+               (if (or (label-struct-type? inflowing-label)
+                       (and (label-cst? inflowing-label)
+                            (not (label-cst-value inflowing-label))))
+                   (begin
+                     (when (label-struct-type? inflowing-label)
+                       (set-label-struct-type-parent! struct-type-label
+                                                      inflowing-label))
+                     #t)
+                   (begin
+                     (set-error-for-label sba-state
+                                          inflowing-label
+                                          'red
+                                          "make-struct-type expected structure type")
+                     (set-label-struct-type-error?! struct-type-label #t)
+                     #f)))
+             (gensym))]
+           [field-label (create-simple-prim-label term)]
+           [field-edge
+            (cons
+             (lambda (out-label inflowing-label tunnel-label)
+               ; name sink => no use for out-label
+               ; inflowing label will tell use how many fields the struct will have
+               (if (and (label-cst? inflowing-label)
+                        (number? (label-cst-value inflowing-label)))
+                   (begin
+                     (let* ([parent (label-struct-type-parent struct-type-label)]
+                            [parent-fields-nbr (if parent
+                                                   (label-struct-type-total-fields-nbr
+                                                    (label-struct-type-parent struct-type-label))
+                                                   0)])
+                       (set-label-struct-type-parent-fields-nbr! struct-type-label parent-fields-nbr)
+                       (set-label-struct-type-total-fields-nbr! struct-type-label
+                                                                (+ (label-cst-value inflowing-label)
+                                                                   parent-fields-nbr)))
+                     #t)
+                   (begin
+                     (set-error-for-label sba-state
+                                          inflowing-label
+                                          'red
+                                          "make-struct-type expected number")
+                     (set-label-struct-type-error?! struct-type-label #t)
+                     #f)))
+             (gensym))]
+           [auto-field-label (create-simple-prim-label term)]
+           [auto-field-edge
+            (cons
+             (lambda (out-label inflowing-label tunnel-label)
+               ; name sink => no use for out-label
+               ; only 0 should flow in here
+               (if (and (label-cst? inflowing-label)
+                        (let ([value (label-cst-value inflowing-label)])
+                          (and (number? value) (zero? value))))
+                   #t
+                   (begin
+                     (set-error-for-label sba-state
+                                          inflowing-label
+                                          'red
+                                          "auto-initialized structure fields not yet supported: expected 0")
+                     (set-label-struct-type-error?! struct-type-label #t)
+                     #f)))
+             (gensym))]
+           [auto-field-value-label (create-simple-prim-label term)]
+           [auto-field-value-edge
+            (cons
+             (lambda (out-label inflowing-label tunnel-label)
+               ; name sink => no use for out-label
+               ; only #f should flow in here
+               (if (and (label-cst? inflowing-label)
+                        (not (label-cst-value inflowing-label)))
+                   #t
+                   (begin
+                     (set-error-for-label sba-state
+                                          inflowing-label
+                                          'red
+                                          "auto-initialized structure fields not yet supported: expected #f")
+                     (set-label-struct-type-error?! struct-type-label #t)
+                     #f)))
+             (gensym))]
+           [properties-label (create-simple-prim-label term)]
+           [properties-edge
+            (cons
+             (lambda (out-label inflowing-label tunnel-label)
+               ; name sink => no use for out-label
+               ; only '() should flow in here
+               (if (and (label-cst? inflowing-label)
+                        (null? (label-cst-value inflowing-label)))
+                   #t
+                   (begin
+                     (set-error-for-label sba-state
+                                          inflowing-label
+                                          'red
+                                          "structure properties not yet supported: expected ()")
+                     (set-label-struct-type-error?! struct-type-label #t)
+                     #f)))
+             (gensym))]
+           [inspector-label (create-simple-prim-label term)]
+           [inspector-edge
+            (cons
+             (lambda (out-label inflowing-label tunnel-label)
+               ; name sink => no use for out-label
+               ; only #f should flow in here
+               (if (and (label-cst? inflowing-label)
+                        (not (label-cst-value inflowing-label)))
+                   ; now, at this point, and since edges from actual to formal arguments
+                   ; are created left to right when a function is applied, we know struct-label
+                   ; has been complitely filled out. So we can do the black magic part, which
+                   ; consists in creating case-lambdas on the fly, that will become the maker,
+                   ; pred, access and mutate functions, and gather them in the multiple value
+                   ; label.
+                   (if (label-struct-type-error? struct-type-label)
+                       ; nothing created, so nothing ever propagates down to
+                       ; make-struct-field-accessor or make-struct-field-mutator
+                       #f
+                       (let* ([total-fields-nbr (label-struct-type-total-fields-nbr struct-type-label)]
+                              ; maker
+                              [maker-body-label (make-label-struct-value
+                                                 #f #f #f #f #t
+                                                 term
+                                                 (make-hash-table)
+                                                 (make-hash-table)
+                                                 struct-type-label
+                                                 (etc:build-list total-fields-nbr
+                                                                 (lambda (_)
+                                                                   (create-simple-prim-label term))))]
+                              [maker-case-lambda-label (make-label-case-lambda
+                                                        #f #f #f #f #t
+                                                        term
+                                                        (make-hash-table)
+                                                        (make-hash-table)
+                                                        struct-type-label ; never used
+                                                        (list #f)
+                                                        (list total-fields-nbr)
+                                                        (list (label-struct-value-fields
+                                                               maker-body-label))
+                                                        (list maker-body-label)
+                                                        (list cst:dummy-thunk))]
+                              ; pred
+                              [pred-true-label (make-label-cst #f #f #f #f #t
+                                                               term
+                                                               (make-hash-table)
+                                                               (make-hash-table)
+                                                               #t)]
+                              [pred-false-label (make-label-cst #f #f #f #f #t
+                                                                term
+                                                                (make-hash-table)
+                                                                (make-hash-table)
+                                                                #f)]
+                              [pred-body-label (create-simple-prim-label term)]
+                              [pred-body-edge (create-simple-edge pred-body-label)]
+                              [pred-arg-label (create-simple-prim-label term)]
+                              [pred-arg-edge
+                               (create-self-modifying-edge (lambda (label)
+                                                             (is-subtype? label struct-type-label))
+                                                           pred-true-label pred-false-label
+                                                           pred-body-edge)]
+                              [pred-case-lambda-label (make-label-case-lambda
+                                                       #f #f #f #f #t
+                                                       term
+                                                       (make-hash-table)
+                                                       (make-hash-table)
+                                                       struct-type-label ; never used
+                                                       (list #f)
+                                                       (list 1)
+                                                       (list (list pred-arg-label))
+                                                       (list pred-body-label)
+                                                       (list cst:dummy-thunk))]
+                              ; access is a bit tricky: make-struct-field-accessor will
+                              ; manually link access's second arg and wrap access inside another
+                              ; case-lambda with one arg less. We just have to remember which
+                              ; structure type access is about by setting the struct field to
+                              ; struct-type-label (something we didn't really have to do for the
+                              ; maker and pred, because the maker-body-label and pred-arg-edge
+                              ; already explicitely refer to it, but we did it anyway, above,
+                              ; just for consistency).
+                              ; Note: no error checking on the input is done here. It will be done
+                              ; by the wrapper.
+                              [access-first-arg-label (create-simple-prim-label term)]
+                              [access-second-arg-label (create-simple-prim-label term)]
+                              [access-case-lambda-label (make-label-case-lambda
+                                                         #f #f #f #f #t
+                                                         term
+                                                         (make-hash-table)
+                                                         (make-hash-table)
+                                                         struct-type-label
+                                                         (list #f)
+                                                         (list 2)
+                                                         (list (list access-first-arg-label
+                                                                     access-second-arg-label))
+                                                         (list (create-simple-prim-label term))
+                                                         (list cst:dummy-thunk))]
+                              ; same problem with mutate
+                              [mutate-first-arg-label (create-simple-prim-label term)]
+                              [mutate-second-arg-label (create-simple-prim-label term)]
+                              [mutate-third-arg-label (create-simple-prim-label term)]
+                              [mutate-case-lambda-label (make-label-case-lambda
+                                                         #f #f #f #f #t
+                                                         term
+                                                         (make-hash-table)
+                                                         (make-hash-table)
+                                                         struct-type-label
+                                                         (list #f)
+                                                         (list 2)
+                                                         (list (list mutate-first-arg-label
+                                                                     mutate-second-arg-label
+                                                                     mutate-third-arg-label))
+                                                         (list (create-simple-prim-label term))
+                                                         (list cst:dummy-thunk))])
+                         ; XXX should all the add-edge-and-propagate-set-through-edge be and-ed ?
+                         ; maker
+                         (initialize-label-set-for-value-source maker-body-label)            
+                         (initialize-label-set-for-value-source maker-case-lambda-label)
+                         (add-edge-and-propagate-set-through-edge
+                          maker-case-lambda-label maker-edge)
+                         ; pred
+                         (initialize-label-set-for-value-source pred-true-label)
+                         (initialize-label-set-for-value-source pred-false-label)
+                         (add-edge-and-propagate-set-through-edge
+                          pred-arg-label pred-arg-edge)
+                         (initialize-label-set-for-value-source pred-case-lambda-label)
+                         (add-edge-and-propagate-set-through-edge
+                          pred-case-lambda-label pred-edge)
+                         ; access
+                         (initialize-label-set-for-value-source access-case-lambda-label)
+                         (add-edge-and-propagate-set-through-edge
+                          access-case-lambda-label access-edge)
+                         ; mutate
+                         (initialize-label-set-for-value-source mutate-case-lambda-label)
+                         (add-edge-and-propagate-set-through-edge
+                          mutate-case-lambda-label mutate-edge)
+                         #t))
+                   (begin
+                     (set-error-for-label sba-state
+                                          inflowing-label
+                                          'red
+                                          "structure inspectors not yet supported: expected #f")
+                     (set-label-struct-type-error?! struct-type-label #t)
+                     #f)))
+             (gensym))]
+           [make-struct-type-label (make-label-case-lambda
+                                    #f #f #f #f #t term (make-hash-table) (make-hash-table) #f
+                                    (list #f)
+                                    (list 7)
+                                    (list (list name-label
+                                                parent-label
+                                                field-label
+                                                auto-field-label
+                                                auto-field-value-label
+                                                properties-label
+                                                inspector-label))
+                                    (list values-label)
+                                    (list cst:dummy-thunk))])
+      ; make-struct-type args
+      (add-edge-and-propagate-set-through-edge name-label name-edge)
+      (add-edge-and-propagate-set-through-edge parent-label parent-edge)
+      (add-edge-and-propagate-set-through-edge field-label field-edge)
+      (add-edge-and-propagate-set-through-edge auto-field-label auto-field-edge)
+      (add-edge-and-propagate-set-through-edge auto-field-value-label auto-field-value-edge)
+      (add-edge-and-propagate-set-through-edge properties-label properties-edge)
+      (add-edge-and-propagate-set-through-edge inspector-label inspector-edge)
+      (initialize-label-set-for-value-source struct-type-label)
+      ; multiple values list
+      (initialize-label-set-for-value-source null-label)
+      (initialize-label-set-for-value-source cons-label1)
+      (initialize-label-set-for-value-source cons-label2)
+      (initialize-label-set-for-value-source cons-label3)
+      (initialize-label-set-for-value-source cons-label4)
+      (initialize-label-set-for-value-source cons-label5)
+      (initialize-label-set-for-value-source values-label)
+      (initialize-label-set-for-value-source make-struct-type-label)
+      make-struct-type-label))
+  
+  ; sba-state syntax-object -> label
+  ; Here again we rely heavily on the order in which actual arguments are connected
+  ; to formal arguments (i.e. left to right). Note that the first arg of
+  ; make-struct-field-accessor will be access, which is bound to the access defined
+  ; by make-struct-type. This means that, if the define-struct is inside a lambda,
+  ; we should make sure that, when the lambda is applied, make-struct-type is applied
+  ; before make-struct-field-accessor. Hence the order in which the thunks are built
+  ; in the #%app rule of create-label-from-term.
+  (define (create-make-struct-field-accessor-label sba-state term)
+    (let* (; WARNING: we assume that each occurence of make-struct-field-accessor is
+           ; only used once in the program being analyzed, so set!-ing struct-label, access,
+           ; and field-index is ok. This *will* break if the user starts using a
+           ; function like:
+           ; (lambda (index name)
+           ;   (make-struct-field-accessor access index name))
+           ; to create the different accessors, because the state will then be shared
+           ; between several call places.
+           ; Note that we could get back the struct-label and field-index when needed
+           ; by fishing them out of the sets of the first and second args, but it's
+           ; less painful to do it that way, and doing the fishing would still break
+           ; the same way anyway...
+           [struct-type-label #f]
+           [access #f]
+           [field-index #f]
+           [body-label (create-simple-prim-label term)]
+           [body-edge (create-simple-edge body-label)]
+           [first-arg-label (create-simple-prim-label term)]
+           [first-arg-edge
+            (cons
+             (lambda (out-label inflowing-label tunnel-label)
+               ; name sink => no use for out-label
+               ; only a case-lambda for a struct with a single arity-2 clause
+               ; should flow in here. Note that, as in create-make-struct-type-label,
+               ; we do the type checking as stuff flows in, instead of doing it
+               ; post-analysis, just to make sure we don't screw our invariants when
+               ; we finally run third-arg-edge...
+               (if (and (label-case-lambda? inflowing-label)
+                        (label-case-lambda-struct inflowing-label)
+                        (= (length (label-case-lambda-rest-arg?s inflowing-label)) 1)
+                        (= (length (car (label-case-lambda-argss inflowing-label))) 2))
+                   (begin
+                     (set! struct-type-label (label-case-lambda-struct inflowing-label))
+                     (set! access inflowing-label)
+                     #t)
+                   (begin
+                     (set-error-for-label sba-state
+                                          inflowing-label
+                                          'red
+                                          (format "make-struct-field-accessor: expects type <accessor procedure that requires a field index> as 1st argument, given: ~a"
+                                                  (pp-type sba-state (get-type-from-label sba-state inflowing-label) 'create-make-struct-field-accessor-label1)))
+                     #f)))
+             (gensym))]
+           [second-arg-label (create-simple-prim-label term)]
+           [second-arg-edge
+            (cons
+             (lambda (out-label inflowing-label tunnel-label)
+               ; name sink => no use for out-label
+               ; only a number in the right range should flow in here
+               (if struct-type-label
+                   (if (and (label-cst? inflowing-label)
+                            (let ([value (label-cst-value inflowing-label)])
+                              (and (number? value)
+                                   (exact? value)
+                                   (<= 0 value))))
+                       (let ([value (label-cst-value inflowing-label)])
+                         (if (< value (- (label-struct-type-total-fields-nbr struct-type-label)
+                                         (label-struct-type-parent-fields-nbr struct-type-label)))
+                             (begin
+                               (set! field-index
+                                     (+ value (label-struct-type-parent-fields-nbr struct-type-label)))
+                               #t)
+                             (begin
+                               (set-error-for-label
+                                sba-state
+                                inflowing-label
+                                'red
+                                (format "make-struct-field-accessor: slot index for ~a not in [0, ~a]: ~a"
+                                        (pp-type sba-state (get-type-from-label sba-state struct-type-label) 'create-make-struct-field-accessor-label2)
+                                        (- (label-struct-type-total-fields-nbr struct-type-label)
+                                           (label-struct-type-parent-fields-nbr struct-type-label))
+                                        (pp-type sba-state (get-type-from-label sba-state inflowing-label) 'create-make-struct-field-accessor-label3)))
+                               #f)))
+                       (begin
+                         (set! struct-type-label #f)
+                         (set! access #f)
+                         (set-error-for-label
+                          sba-state
+                          inflowing-label
+                          'red
+                          (format "make-struct-field-accessor: expects type <non-negative exact integer> as 2nd argument, given: ~a"
+                                  (pp-type sba-state (get-type-from-label sba-state inflowing-label) 'create-make-struct-field-accessor-label4)))
+                         #f))
+                   #f))
+             (gensym))]
+           [third-arg-label (create-simple-prim-label term)]
+           [third-arg-edge
+            (cons
+             (lambda (out-label inflowing-label tunnel-label)
+               ; name sink => no use for out-label
+               ; only a symbol should flow in here
+               (if field-index ; is not set if struct-label is not set...
+                   (if (and (label-cst? inflowing-label)
+                            (symbol? (label-cst-value inflowing-label)))
+                       ; ready to wrap access... accessor is the result of applying
+                       ; make-struct-field-accessor to access (i.e. it's the accessor
+                       ; that will be bound to foo-a...)
+                       (let* ([access-args (car (label-case-lambda-argss access))]
+                              [access-body-edge (create-simple-edge (car (label-case-lambda-exps access)))]
+                              [accessor-body-label (create-simple-prim-label term)]
+                              [accessor-body-edge (create-simple-edge accessor-body-label)]
+                              [accessor-arg-label (create-simple-prim-label term)]
+                              [accessor-arg-edge
+                               (cons
+                                (lambda (out-label inflowing-label tunnel-label)
+                                  ; name sink => no use for out-label
+                                  (if (is-subtype? inflowing-label struct-type-label)
+                                      (let ([result-label
+                                             (list-ref (label-struct-value-fields
+                                                        inflowing-label)
+                                                       field-index)])
+                                        ; we make the result flow into both the result of access and the result
+                                        ; of the accessor
+                                        (add-edge-and-propagate-set-through-edge
+                                         result-label access-body-edge)
+                                        (add-edge-and-propagate-set-through-edge
+                                         result-label accessor-body-edge)
+                                        #t)
+                                      (begin
+                                        (set-error-for-label
+                                         sba-state
+                                         ; we know we are inside a primitive, so we
+                                         ; flag the entrance of the tunnel as the error.
+                                         tunnel-label
+                                         'red
+                                         (format "accessor expects type ~a as 1st argument, given: ~a"
+                                                 (pp-type sba-state (get-type-from-label sba-state struct-type-label) 'create-make-struct-field-accessor-label5)
+                                                 (pp-type sba-state (get-type-from-label sba-state inflowing-label) 'create-make-struct-field-accessor-label6)))
+                                        #f)))
+                                (gensym))]
+                              [accessor-case-lambda-label (make-label-case-lambda
+                                                           #f #f #f #f #t term (make-hash-table) (make-hash-table) #f
+                                                           (list #f)
+                                                           (list 1)
+                                                           (list (list accessor-arg-label))
+                                                           (list accessor-body-label)
+                                                           (list cst:dummy-thunk))])
+                         ; this is just to get the type for access right...
+                         ; the structure flowing into the accessor flows into access's first arg
+                         (add-edge-and-propagate-set-through-edge
+                          accessor-arg-label
+                          (create-simple-edge (car access-args)))
+                         ; the index given to make-struct-field-accessor flows into the second arg
+                         (add-edge-and-propagate-set-through-edge
+                          second-arg-label
+                          (create-simple-edge (cadr access-args)))
+                         ; accessor
+                         (add-edge-and-propagate-set-through-edge accessor-arg-label accessor-arg-edge)
+                         (initialize-label-set-for-value-source accessor-case-lambda-label)
+                         (add-edge-and-propagate-set-through-edge
+                          accessor-case-lambda-label body-edge)
+                         #t)
+                       (begin
+                         (set! struct-type-label #f)
+                         (set! access #f)
+                         (set! field-index #f)
+                         (set-error-for-label
+                          sba-state
+                          inflowing-label
+                          'red
+                          (format "make-struct-field-accessor: expects type <symbol> as 3rd argument, given: ~a"
+                                  (pp-type sba-state (get-type-from-label sba-state inflowing-label) 'create-make-struct-field-accessor-label7)))
+                         #f))
+                   #f))
+             (gensym))]
+           [make-struct-field-accessor-label (make-label-case-lambda
+                                              #f #f #f #f #t term (make-hash-table) (make-hash-table) #f
+                                              (list #f)
+                                              (list 3)
+                                              (list (list first-arg-label
+                                                          second-arg-label
+                                                          third-arg-label))
+                                              (list body-label)
+                                              (list cst:dummy-thunk))])
+      (add-edge-and-propagate-set-through-edge first-arg-label first-arg-edge)
+      (add-edge-and-propagate-set-through-edge second-arg-label second-arg-edge)
+      (add-edge-and-propagate-set-through-edge third-arg-label third-arg-edge)
+      (initialize-label-set-for-value-source make-struct-field-accessor-label)
+      make-struct-field-accessor-label))
+  
+  ; sba-state syntax-object -> label
+  ; Here again we rely heavily on the order in which actual arguments are connected
+  ; to formal arguments (i.e. left to right)
+  (define (create-make-struct-field-mutator-label sba-state term)
+    (let* (; WARNING: we assume that each occurence of make-struct-field-mutator is
+           ; only used once in the program being analyzed, so set!-ing struct-label
+           ; and field-index is ok. This *will* break if the user starts using a
+           ; function like:
+           ; (lambda (index name)
+           ;   (make-struct-field-mutator mutate index name))
+           ; to create the different mutators...
+           ; Note that we could get back the struct-label and field-index when needed
+           ; by fishing them out of the sets of the first and second args, but it's
+           ; less painful to do it that way, and doing the fishing would still break
+           ; the same way anyway...
+           [struct-type-label #f]
+           [mutate #f]
+           [field-index #f]
+           [body-label (create-simple-prim-label term)]
+           [body-edge (create-simple-edge body-label)]
+           [first-arg-label (create-simple-prim-label term)]
+           [first-arg-edge
+            (cons
+             (lambda (out-label inflowing-label tunnel-label)
+               ; name sink => no use for out-label
+               ; only a case-lambda for a struct with a single arity-3 clause
+               ; should flow in here. Note that, as in create-make-struct-type-label,
+               ; we do the type checking as stuff flows in, instead of doing it
+               ; post-analysis, just to make sure we don't screw our invariants when
+               ; we finally run third-arg-edge...
+               (if (and (label-case-lambda? inflowing-label)
+                        (label-case-lambda-struct inflowing-label)
+                        (= (length (label-case-lambda-rest-arg?s inflowing-label)) 1)
+                        (= (length (car (label-case-lambda-argss inflowing-label))) 3))
+                   (begin
+                     (set! struct-type-label (label-case-lambda-struct inflowing-label))
+                     (set! mutate inflowing-label)
+                     #t)
+                   (begin
+                     (set-error-for-label
+                      sba-state
+                      inflowing-label
+                      'red
+                      (format "make-struct-field-mutator: expects type <mutator procedure that requires a field index> as 1st argument, given: ~a"
+                              (pp-type sba-state (get-type-from-label sba-state inflowing-label) 'create-make-struct-field-mutator-label1)))
+                     #f)))
+             (gensym))]
+           [second-arg-label (create-simple-prim-label term)]
+           [second-arg-edge
+            (cons
+             (lambda (out-label inflowing-label tunnel-label)
+               ; name sink => no use for out-label
+               ; only a number in the right range should flow in here
+               (if struct-type-label
+                   (if (and (label-cst? inflowing-label)
+                            (let ([value (label-cst-value inflowing-label)])
+                              (and (number? value)
+                                   (exact? value)
+                                   (<= 0 value))))
+                       (let ([value (label-cst-value inflowing-label)])
+                         (if (< value (- (label-struct-type-total-fields-nbr struct-type-label)
+                                         (label-struct-type-parent-fields-nbr struct-type-label)))
+                             (begin
+                               (set! field-index 
+                                     (+ value (label-struct-type-parent-fields-nbr struct-type-label)))
+                               #t)
+                             (begin
+                               (set-error-for-label
+                                sba-state
+                                inflowing-label
+                                'red
+                                (format "make-struct-field-mutator: slot index for ~a not in [0, ~a]: ~a"
+                                        (pp-type sba-state (get-type-from-label sba-state (struct-type-label)) 'create-make-struct-field-mutator-label2)
+                                        (- (label-struct-type-total-fields-nbr struct-type-label)
+                                           (label-struct-type-parent-fields-nbr struct-type-label))
+                                        (pp-type sba-state (get-type-from-label sba-state inflowing-label) 'create-make-struct-field-mutator-label3)))
+                               #f)))
+                       (begin
+                         (set! struct-type-label #f)
+                         (set! mutate #f)
+                         (set-error-for-label
+                          sba-state
+                          inflowing-label
+                          'red
+                          (format "make-struct-field-mutator: expects type <non-negative exact integer> as 2nd argument, given: ~a"
+                                  (pp-type sba-state (get-type-from-label sba-state inflowing-label) 'create-make-struct-field-mutator-label4)))
+                         #f))
+                   #f))
+             (gensym))]
+           [third-arg-label (create-simple-prim-label term)]
+           [third-arg-edge
+            (cons
+             (lambda (out-label inflowing-label tunnel-label)
+               ; name sink => no use for out-label
+               ; only a symbol should flow in here
+               (if field-index ; is not set if struct-label is not set...
+                   (if (and (label-cst? inflowing-label)
+                            (symbol? (label-cst-value inflowing-label)))
+                       ; ready to wrap mutate... mutator is the result of applying
+                       ; make-struct-field-mutator to mutate (i.e. it's the mutator
+                       ; that will be bound to set-foo-a!...)
+                       (let* ([mutate-args (car (label-case-lambda-argss mutate))]
+                              [mutate-body-edge (create-simple-edge (car (label-case-lambda-exps mutate)))]
+                              [mutator-case-lambda-label
+                               (create-2args-mutator
+                                sba-state
+                                (lambda (inflowing-label)
+                                  (is-subtype? inflowing-label struct-type-label))
+                                cst:test-true
+                                (lambda (inflowing-label)
+                                  (list-ref (label-struct-value-fields
+                                             inflowing-label)
+                                            field-index))
+                                cst:id
+                                (pp-type sba-state (get-type-from-label sba-state struct-type-label) 'create-make-struct-field-mutator-label5)
+                                "internal error 5: all types must be a subtype of top"
+                                term)]
+                              ; a mutator has only one clause
+                              [mutator-args (car (label-case-lambda-argss mutator-case-lambda-label))])
+                         ; this is just to get the type for mutate right...
+                         ; the structure flowing into the mutator's first arg flows into
+                         ; mutate's first arg
+                         (add-edge-and-propagate-set-through-edge
+                          (car mutator-args)
+                          (create-simple-edge (car mutate-args)))
+                         ; the index given to make-struct-field-mutator flows into mutate's second arg
+                         (add-edge-and-propagate-set-through-edge
+                          second-arg-label
+                          (create-simple-edge (cadr mutate-args)))
+                         ; the value flowing into the mutator's second args flows into
+                         ; mutate's third arg
+                         (add-edge-and-propagate-set-through-edge
+                          (cadr mutator-args)
+                          (create-simple-edge (caddr mutate-args)))
+                         ; body
+                         (add-edge-and-propagate-set-through-edge
+                          (car (label-case-lambda-exps mutator-case-lambda-label))
+                          mutate-body-edge)
+                         ; mutator
+                         (add-edge-and-propagate-set-through-edge
+                          mutator-case-lambda-label body-edge)
+                         #t)
+                       (begin
+                         (set! struct-type-label #f)
+                         (set! mutate #f)
+                         (set! field-index #f)
+                         (set-error-for-label
+                          sba-state
+                          inflowing-label
+                          'red
+                          (format "make-struct-field-mutator: expects type <symbol> as 3rd argument, given: ~a"
+                                  (pp-type sba-state (get-type-from-label sba-state inflowing-label) 'create-make-struct-field-mutator-label7)))
+                         #f))
+                   #f))
+             (gensym))]
+           [make-struct-field-mutator-label (make-label-case-lambda
+                                             #f #f #f #f #t term (make-hash-table) (make-hash-table) #f
+                                             (list #f)
+                                             (list 3)
+                                             (list (list first-arg-label
+                                                         second-arg-label
+                                                         third-arg-label))
+                                             (list body-label)
+                                             (list cst:dummy-thunk))])
+      (add-edge-and-propagate-set-through-edge first-arg-label first-arg-edge)
+      (add-edge-and-propagate-set-through-edge second-arg-label second-arg-edge)
+      (add-edge-and-propagate-set-through-edge third-arg-label third-arg-edge)
+      (initialize-label-set-for-value-source make-struct-field-mutator-label)
+      make-struct-field-mutator-label))
+  
+  ; sba-state (label -> boolean) (label -> boolean) (label -> label) (label -> label)  string string
+  ; -> case-lambda-label
+  ; creates a case-lambda label for a 2 args mutator.
+  (define (create-2args-mutator sba-state
+                                pred-first-arg pred-second-arg
+                                accessor-first-arg accessor-second-arg
+                                error-first-arg error-second-arg
+                                term)
+    (let* ([void-label (make-label-cst #f #f #f #f #f
+                                       term
+                                       (make-hash-table)
+                                       (make-hash-table)
+                                       cst:void)]
+           [state-label (create-simple-prim-label term)]
+           [state-edge (create-simple-edge state-label)]
+           [mutator-body-label (create-simple-prim-label term)]
+           [mutator-body-edge (create-simple-edge mutator-body-label)]
+           [mutator-first-arg-label (create-simple-prim-label term)]
+           [mutator-second-arg-label (create-simple-prim-label term)]
+           [mutator-first-arg-edge
+            (cons
+             (lambda (out-label inflowing-label tunnel-label)
+               ; name sink => no use for out-label
+               (if (pred-first-arg inflowing-label)
+                   (add-edge-and-propagate-set-through-edge
+                    state-label
+                    (create-simple-edge (accessor-first-arg inflowing-label)))
+                   (begin
+                     (set-error-for-label
+                      sba-state
+                      ; we know we are inside a primitive, so we
+                      ; flag the entrance of the tunnel as the error.
+                      tunnel-label
+                      'red
+                      (format "mutator expects type ~a as 1st argument, given: ~a"
+                              error-first-arg
+                              (pp-type sba-state (get-type-from-label sba-state inflowing-label) 'create-2args-mutator1)))
+                     #f)))
+             (gensym))]
+           [mutator-second-arg-edge
+            (cons
+             (lambda (out-label inflowing-label tunnel-label)
+               ; name sink => no use for out-label
+               (if (pred-second-arg inflowing-label)
+                   (add-edge-and-propagate-set-through-edge
+                    (accessor-second-arg inflowing-label)
+                    state-edge)
+                   (begin
+                     (set-error-for-label
+                      sba-state
+                      ; we know we are inside a primitive, so we
+                      ; flag the entrance of the tunnel as the error.
+                      tunnel-label
+                      'red
+                      (format "mutator expects type ~a as 2nd argument, given: ~a"
+                              error-second-arg
+                              (pp-type sba-state (get-type-from-label sba-state inflowing-label) 'create-2args-mutator2)))
+                     #f)))
+             (gensym))]
+           [mutator-case-lambda-label (make-label-case-lambda
+                                       #f #f #f #f #t term (make-hash-table) (make-hash-table) #f
+                                       (list #f)
+                                       (list 2)
+                                       (list (list mutator-first-arg-label
+                                                   mutator-second-arg-label))
+                                       (list mutator-body-label)
+                                       (list cst:dummy-thunk))])
+      (initialize-label-set-for-value-source void-label)
+      (add-edge-and-propagate-set-through-edge void-label mutator-body-edge)
+      (add-edge-and-propagate-set-through-edge
+       mutator-first-arg-label mutator-first-arg-edge)
+      (add-edge-and-propagate-set-through-edge
+       mutator-second-arg-label mutator-second-arg-edge)
+      (initialize-label-set-for-value-source mutator-case-lambda-label)
+      mutator-case-lambda-label))
+  
+  ; sba-state (label -> boolean) (label -> boolean) (label -> label) (label -> label)  string string string
+  ; -> case-lambda-label
+  ; creates a case-lambda label for a 3 args mutator.
+  (define (create-3args-mutator sba-state
+                                pred-first-arg pred-second-arg pred-third-arg
+                                accessor-first-arg accessor-third-arg
+                                error-first-arg error-second-arg error-third-arg
+                                term)
+    (let* ([void-label (make-label-cst #f #f #f #f #f
+                                       term
+                                       (make-hash-table)
+                                       (make-hash-table)
+                                       cst:void)]
+           [state-label (create-simple-prim-label term)]
+           [state-edge (create-simple-edge state-label)]
+           [mutator-body-label (create-simple-prim-label term)]
+           [mutator-body-edge (create-simple-edge mutator-body-label)]
+           [mutator-first-arg-label (create-simple-prim-label term)]
+           [mutator-second-arg-label (create-simple-prim-label term)]
+           [mutator-third-arg-label (create-simple-prim-label term)]
+           [mutator-first-arg-edge
+            (cons
+             (lambda (out-label inflowing-label tunnel-label)
+               ; name sink => no use for out-label
+               (if (pred-first-arg inflowing-label)
+                   (add-edge-and-propagate-set-through-edge
+                    state-label
+                    (create-simple-edge (accessor-first-arg inflowing-label)))
+                   (begin
+                     (set-error-for-label
+                      sba-state
+                      ; we know we are inside a primitive, so we
+                      ; flag the entrance of the tunnel as the error.
+                      tunnel-label
+                      'red
+                      (format "mutator expects type ~a as 1st argument, given: ~a"
+                              error-first-arg
+                              (pp-type sba-state (get-type-from-label sba-state inflowing-label) 'create-3args-mutator1)))
+                     #f)))
+             (gensym))]
+           [mutator-second-arg-edge
+            (cons
+             (lambda (out-label inflowing-label tunnel-label)
+               ; name sink => no use for out-label
+               (if (pred-second-arg inflowing-label)
+                   #t
+                   (begin
+                     (set-error-for-label
+                      sba-state
+                      ; we know we are inside a primitive, so we
+                      ; flag the entrance of the tunnel as the error.
+                      tunnel-label
+                      'red
+                      (format "mutator expects type ~a as 2nd argument, given: ~a"
+                              error-second-arg
+                              (pp-type sba-state (get-type-from-label sba-state inflowing-label) 'create-3args-mutator2)))
+                     #f)))
+             (gensym))]
+           [mutator-third-arg-edge
+            (cons
+             (lambda (out-label inflowing-label tunnel-label)
+               ; name sink => no use for out-label
+               (if (pred-third-arg inflowing-label)
+                   (add-edge-and-propagate-set-through-edge
+                    (accessor-third-arg inflowing-label)
+                    state-edge)
+                   (begin
+                     (set-error-for-label
+                      sba-state
+                      ; we know we are inside a primitive, so we
+                      ; flag the entrance of the tunnel as the error.
+                      tunnel-label
+                      'red
+                      (format "mutator expects type ~a as 3rd argument, given: ~a"
+                              error-third-arg
+                              (pp-type sba-state (get-type-from-label sba-state inflowing-label) 'create-3args-mutator3)))
+                     #f)))
+             (gensym))]
+           [mutator-case-lambda-label (make-label-case-lambda
+                                       #f #f #f #f #t term (make-hash-table) (make-hash-table) #f
+                                       (list #f)
+                                       (list 3)
+                                       (list (list mutator-first-arg-label
+                                                   mutator-second-arg-label
+                                                   mutator-third-arg-label))
+                                       (list mutator-body-label)
+                                       (list cst:dummy-thunk))])
+      (initialize-label-set-for-value-source void-label)
+      (add-edge-and-propagate-set-through-edge void-label mutator-body-edge)
+      (add-edge-and-propagate-set-through-edge
+       mutator-first-arg-label mutator-first-arg-edge)
+      (add-edge-and-propagate-set-through-edge
+       mutator-second-arg-label mutator-second-arg-edge)
+      (add-edge-and-propagate-set-through-edge
+       mutator-third-arg-label mutator-third-arg-edge)
+      (initialize-label-set-for-value-source mutator-case-lambda-label)
+      mutator-case-lambda-label))
+  
+  ; sba-state (listof (syntax-object-listof syntax-object)) (listof (syntax-object-listof syntax-object))
+  ; syntax-object (listof (cons symbol label)) -> case-lambda-label
+  (define (create-case-lambda-label sba-state argss expss term gamma)
+    (let* ([label (make-label-case-lambda
+                   #f #f #f #f #f
+                   term
+                   (make-hash-table)
+                   (make-hash-table)
+                   #f
+                   cst:dummy
+                   cst:dummy
+                   cst:dummy
+                   cst:dummy
+                   '())]
+           [all-labels
+            (list:foldr
+             (lambda (args exps other-clauses-labels)
+               (let ([rest-arg?s (vector-ref other-clauses-labels 0)]
+                     [req-args (vector-ref other-clauses-labels 1)]
+                     [argss-labels (vector-ref other-clauses-labels 2)]
+                     [exps-labels (vector-ref other-clauses-labels 3)]
+                     ; scheme list of syntax objects for body exps
+                     [exps (syntax-e exps)])
+                 ; we add one new element to each list each time we process a new clause,
+                 ; so that the element for the current clause is always at the start of the
+                 ; list, so we know where to find this element when we need it (we need to
+                 ; update the top free vars for the current clause in the #%top case, and
+                 ; the application thunk for the current clause in the #%app case).
+                 (set-label-case-lambda-effects!
+                  label
+                  (cons cst:dummy-thunk (label-case-lambda-effects label)))
+                 (kern:kernel-syntax-case
+                  args #f
+                  [(args ...)
+                   (let* (; proper scheme list of syntax objects for arguments
+                          [args (syntax-e (syntax (args ...)))]
+                          [args-labels (map (lambda (term) (create-simple-label sba-state term)) args)]
+                          [gamma-extended (extend-env gamma args args-labels)])
+                     (vector (cons #f rest-arg?s)
+                             (cons (length args) req-args)
+                             (cons args-labels argss-labels)
+                             (cons (list:foldl
+                                    (lambda (exp _)
+                                      (create-label-from-term sba-state exp gamma-extended label))
+                                    cst:dummy
+                                    exps)
+                                   exps-labels)))]
+                  [(first-arg . other-args-including-rest-arg)
+                   (let* (; (syntax other-args-including-rest-arg) is either a (syntax
+                          ; version of a) list of syntax objects (if there's strictly more
+                          ; than one required argument), or a single syntax object (if
+                          ; there's only one required argument). In both cases we want to
+                          ; construct an improper list of syntax objects. syntax-e takes
+                          ; care of that in the list case, cons takes care of that in the
+                          ; other case.
+                          [args (cons (syntax first-arg)
+                                      (let* ([syntax-obj (syntax other-args-including-rest-arg)]
+                                             [symbol-or-list-of-syntax-obj (syntax-e syntax-obj)])
+                                        (if (symbol? symbol-or-list-of-syntax-obj)
+                                            syntax-obj
+                                            symbol-or-list-of-syntax-obj)))]
+                          ; convert the improper list into a proper one.
+                          [args (let loop ([args args])
+                                  (if (pair? args)
+                                      (cons (car args)
+                                            (loop (cdr args)))
+                                      (list args)))]
+                          [args-labels (map (lambda (term) (create-simple-label sba-state term)) args)]
+                          [gamma-extended (extend-env gamma args args-labels)])
+                     (vector (cons #t rest-arg?s)
+                             (cons (sub1 (length args)) req-args)
+                             (cons args-labels argss-labels)
+                             (cons (list:foldl
+                                    (lambda (exp _)
+                                      (create-label-from-term sba-state exp gamma-extended label))
+                                    cst:dummy
+                                    exps)
+                                   exps-labels)))]
+                  [rest-arg
+                   (let* (; one syntax object for rest-arg
+                          [rest-arg (syntax rest-arg)]
+                          [rest-arg-label-list (list (create-simple-label sba-state rest-arg))]
+                          [gamma-extended (extend-env gamma (list rest-arg) rest-arg-label-list)])
+                     (vector (cons #t rest-arg?s)
+                             (cons 0 req-args)
+                             (cons rest-arg-label-list argss-labels)
+                             (cons (list:foldl
+                                    (lambda (exp _)
+                                      (create-label-from-term sba-state exp gamma-extended label))
+                                    cst:dummy
+                                    exps)
+                                   exps-labels)))]
+                  )))
+             (vector '()'()'()'())
+             argss
+             expss
+             )])
+      (set-label-case-lambda-rest-arg?s! label (vector-ref all-labels 0))
+      (set-label-case-lambda-req-args! label (vector-ref all-labels 1))
+      (set-label-case-lambda-argss! label (vector-ref all-labels 2))
+      (set-label-case-lambda-exps! label (vector-ref all-labels 3))
+      (initialize-label-set-for-value-source label)
+      ((sba-state-register-label-with-gui sba-state) label)
+      label))
+  
+  ; sba-state syntax-object (listof (cons symbol label)) label (listof label) -> label
+  (define (create-top-level-label sba-state identifier gamma enclosing-lambda-label)
+    (let* ([identifier-name (syntax-e identifier)]
+           ; note that bound-label doesn't contain the #%top, but they have the same
+           ; syntax source/line/column/position, so arrows and underlining will work
+           ; the same, but it will make things a little bit simpler when doing a
+           ; lookup-top-level-name in the #%app case (if we have to).
+           [bound-label (create-simple-label sba-state identifier)])
+      (if enclosing-lambda-label
+          ; free var inside a lambda, so add it to the list of free variables, don't do
+          ; any lookup now (will be done when the enclosing lambda is applied)
+          (let* ([enclosing-lambda-effects (label-case-lambda-effects enclosing-lambda-label)]
+                 [current-thunk (car enclosing-lambda-effects)])
+            (set-car! enclosing-lambda-effects
+                      (lambda ()
+                        (current-thunk)
+                        (lookup-and-bind-top-level-vars sba-state (list bound-label) identifier)
+                        )))
+          ; top level
+          (lookup-and-bind-top-level-vars sba-state (list bound-label) identifier))
+      bound-label))
+  
+  
+  ; sba-state syntax-object (listof (cons symbol label)) label (listof label) -> label
+  (define (create-label-from-quote sba-state quoted-term gamma enclosing-lambda-label)
+    (let ([sexp-e (syntax-e quoted-term)])
+      (cond
+        [(list? sexp-e)
+         (let loop ([sexp-e sexp-e])
+           (if (null? sexp-e)
+               (let ([null-label
+                      (make-label-cst
+                       #f #f #f #f #t
+                       quoted-term
+                       (make-hash-table)
+                       (make-hash-table)
+                       '())])
+                 (initialize-label-set-for-value-source null-label)
+                 null-label)
+               (let ([cons-label
+                      (make-label-cons
+                       #f #f #f #f #t
+                       quoted-term
+                       (make-hash-table)
+                       (make-hash-table)
+                       (create-label-from-quote sba-state (car sexp-e) gamma enclosing-lambda-label)
+                       (loop (cdr sexp-e)))])
+                 (initialize-label-set-for-value-source cons-label)
+                 cons-label)))]
+        [(pair? sexp-e)
+         (let ([cons-label
+                (make-label-cons
+                 #f #f #f #f #t
+                 quoted-term
+                 (make-hash-table)
+                 (make-hash-table)
+                 (create-label-from-quote sba-state (car sexp-e) gamma enclosing-lambda-label)
+                 (create-label-from-quote sba-state (cdr sexp-e) gamma enclosing-lambda-label))])
+           (initialize-label-set-for-value-source cons-label)
+           cons-label)]
+        [else (let ([label (make-label-cst
+                            #f #f #f #f #f
+                            quoted-term
+                            (make-hash-table)
+                            (make-hash-table)
+                            sexp-e)])
+                (initialize-label-set-for-value-source label)
+                ((sba-state-register-label-with-gui sba-state) label)
+                label)])))
+  
+  ; Builds a list of labels of length n, with all labels being the same.
+  ; This function should be seldom called, so it's not being made tail recursive...
+  (define (build-label-list label n)
+    (if (<= n 0)
+        '()
+        (cons label (build-label-list label (sub1 n)))))
+  
+  ; given a label representing multiple values, connect the label for the different
+  ; values to the different variables.  The tricky part is that the multiple values
+  ; are potentially infinite, because of approximations.  E.g.
+  ; (let-values ([(a b) (apply values (list 1 2))]) b)
+  ; Because of the "apply", we can't actually determine how many multiple values
+  ; we receive, so we have to try our best.
+  ; sba-state label (listof label) integer symbol -> void
+  (define (connect-value-labels-to-var-labels sba-state inflowing-label vars-labels vars-length term-name)
+    (let ([values-labels
+           (let* ([value-label-list (hash-table-map (label-set (label-values-label inflowing-label))
+                                                    (lambda (label arrows) label))]
+                  [value-label-list-length (length value-label-list)])
+             (cond
+               [(= value-label-list-length 1) (label-list->list sba-state (car value-label-list))]
+               ; check for infinite list.  If we have an infinite list, then it's something
+               ; like x = (union null (cons y x)) or x = (union (cons y x) null).  In either
+               ; case (this case and the one below), we find y and create a list (list y y ...)
+               ; with the right length so y (most likely a union of all the possible multiple
+               ; values that flowed together when we lost track of the exact length of the
+               ; list of multiple values) will flow in all vars-labels (therefore being *very*
+               ; conservative since all possible values will flow into all possible bindings).
+               ; Note that we don't actually check that the list is infinite (i.e. that the
+               ; cons labels form a loop).  We could check that the cdr of the cons is eq? to
+               ; (label-values-label inflowing-label) for example, but that doesn't always
+               ; work because of loop unfolding (we does occur in practice).  So we just check
+               ; that we have something vaguely resembling a loop at the outermost level and
+               ; then we trust that the rest of the analysis and the primitive type
+               ; descriptions are correct enough that we never end up here with something that
+               ; resembles a list without being one.  In fact if the analysis is correct we
+               ; should only ever see finite lists and infinite lists and nothing else, so
+               ; since the first case above takes care of finite lists we can normally
+               ; safely assume that in the two cases below we are dealing with infinite lists,
+               ; even though we have no simple way to check that.  The last case is for extra
+               ; checking so that if something goes really wrong we might at least learn about it...
+               ; One good question is: should we propagate at all when we don't know whether
+               ; we have an error or not?
+               ; Note that we also assume that the car we get from the infinite list is all
+               ; the possible cars we'll ever get, even in the presence of other cars in the
+               ; infinite list that might come from loop unrolling!
+               [(and (= value-label-list-length 2)
+                     (let ([first-value-label (car value-label-list)]
+                           [second-value-label (cadr value-label-list)])
+                       (and (label-cst? first-value-label)
+                            (null? (label-cst-value first-value-label))
+                            (label-cons? second-value-label))))
+                (set-error-for-label
+                 sba-state
+                 inflowing-label
+                 'red
+                 (format "~a: context expected ~a values, can't determine how many received"
+                         term-name
+                         vars-length))
+                (build-label-list (label-cons-car (cadr value-label-list)) vars-length)]
+               [(and (= value-label-list-length 2)
+                     (let ([first-value-label (car value-label-list)]
+                           [second-value-label (cadr value-label-list)])
+                       (and (label-cst? second-value-label)
+                            (null? (label-cst-value second-value-label))
+                            (label-cons? first-value-label))))
+                (set-error-for-label
+                 sba-state
+                 inflowing-label
+                 'red
+                 (format "~a: context expected ~a values, can't determine how many received"
+                         term-name
+                         vars-length))
+                (build-label-list (label-cons-car (car value-label-list)) vars-length)]
+               [else (error term-name "values didn't contain list: ~a"
+                            (pp-type sba-state (get-type-from-label sba-state inflowing-label) 'let-values)
+                            ;(map (lambda (label)
+                            ;       (pp-type sba-state (get-type-from-label sba-state label)
+                            ;                term-name))
+                            ;     label-list)
+                            )]))])
+      (if (= (length values-labels) vars-length)
+          ; we have something like
+          ; (let-values ([(x y) (... (values a b) ...)]...) ...),
+          ; so we add a new direct edge from a to x and b to y.
+          ; Of course these new edges have to be themselves
+          ; recursive unpacking edges, since some (values c)
+          ; could later flow into either a or b.
+          (ormap2-strict
+           (lambda (new-origin-label var-label)
+             (add-edge-and-propagate-set-through-edge
+              new-origin-label
+              (extend-edge-for-values
+               sba-state
+               (create-simple-edge var-label)))
+             #t)
+           values-labels vars-labels)
+          ; (let-values ([(x y) (... (values a b c ...) ...)]
+          ;             ...) ...)
+          (begin
+            (set-error-for-label
+             sba-state
+             inflowing-label
+             'red
+             (format "~a: context expected ~a values, received ~a values"
+                     term-name
+                     vars-length
+                     (length values-labels)))
+            #f))))
+  
+  ; sba-state syntax-object (listof (cons symbol label)) label -> label
+  ; gamma is the binding-variable-name-to-label environment
+  ; enclosing-lambda-label is the label for the enclosing lambda, if any. We
+  ; need it to update its list of free variables if we find any. This means
+  ; we have to create the label for a lambda before analyzing its body...
+  (define (create-label-from-term sba-state term gamma enclosing-lambda-label)
+    (kern:kernel-syntax-case
+     term #f
+     ; lambda and case-lambda are currently both core forms. This might change (dixit Matthew)
+     [(lambda args exps ...)
+      (let (; scheme lists of syntax object lists of syntax objects
+            [argss (list (syntax args))]
+            [expss (list (syntax (exps ...)))])
+        (create-case-lambda-label sba-state argss expss term gamma))]
+     [(case-lambda . ((args exps ...) ...))
+      (let (; scheme lists of syntax object lists of syntax objects
+            [argss (syntax-e (syntax (args ...)))]
+            [expss (syntax-e (syntax ((exps ...) ...)))])
+        (create-case-lambda-label sba-state argss expss term gamma))]
+     [(#%app op actual-args ...)
+      (let* ([app-label (create-simple-label sba-state term)]
+             [op-term (syntax op)]
+             [op-label (create-label-from-term sba-state op-term gamma enclosing-lambda-label)]
+             [stx-actual-args (syntax (actual-args ...))]
+             [actual-args-labels
+              (map (lambda (actual-arg)
+                     (create-label-from-term sba-state actual-arg gamma enclosing-lambda-label))
+                   (syntax-e stx-actual-args))]
+             [actual-args-length (length actual-args-labels)]
+             [edge (create-case-lambda-edge
+                    sba-state
+                    (list #f)
+                    (list actual-args-length)
+                    (list actual-args-labels)
+                    (list app-label)
+                    op-label
+                    #f)])
+        ; If the app is inside a lambda, we delay the addition of the edge until the enclosing
+        ; lambda is itself applied.
+        (if enclosing-lambda-label
+            (let* ([enclosing-lambda-effects (label-case-lambda-effects enclosing-lambda-label)]
+                   ; has to be evaluated now, not inside the thunk, otherwise we might have an
+                   ; infinite loop (if there's only one clause in the lambda) or complete
+                   ; non-sense (if there's several clauses).
+                   [current-thunk (car enclosing-lambda-effects)])
+              (set-car! enclosing-lambda-effects
+                        (lambda ()
+                          ; the order in which we evaluate the thunks here is normally
+                          ; insignificant, but it is *very* important to have it in this
+                          ; order when we start having structs. Otherwise, if a define-struct
+                          ; is inside a lambda, the application of make-struct-type might
+                          ; occur after the application of make-struct-field-accessor, which
+                          ; means access won't have been created by the time
+                          ; make-struct-field-accessor is applied, which will make the
+                          ; assumption (that args flow into make-struct-field-accessor in order,
+                          ; from left to right) we made in create-make-struct-field-accessor-label
+                          ; break.
+                          (current-thunk)
+                          (add-edge-and-propagate-set-through-edge op-label edge)
+                          )))
+            (add-edge-and-propagate-set-through-edge op-label edge))
+        app-label)]
+     [(#%datum . datum)
+      (let ([label (make-label-cst
+                    #f #f #f #f #f
+                    term
+                    (make-hash-table)
+                    (make-hash-table)
+                    (syntax-object->datum (syntax datum)))])
+        (initialize-label-set-for-value-source label)
+        ((sba-state-register-label-with-gui sba-state) label)
+        label)]
+     [(quote sexp)
+      (create-label-from-quote sba-state (syntax sexp) gamma enclosing-lambda-label)]
+     [(define-values vars exp)
+      (let* (; scheme list of syntax objects
+             [vars (syntax-e (syntax vars))]
+             [vars-length (length vars)]
+             [exp-label (create-label-from-term sba-state (syntax exp) gamma enclosing-lambda-label)]
+             [vars-labels (map (lambda (term) (create-simple-label sba-state term)) vars)]
+             [define-label (make-label-cst
+                            #f #f #f #f #f
+                            term
+                            (make-hash-table)
+                            (make-hash-table)
+                            'dummy-define-values)])
+        ; don't add to top level before analysing exp-label, otherwise (define x x) will work.
+        (for-each (lambda (var var-label)
+                    (add-top-level-name sba-state var var-label))
+                  vars vars-labels)
+        ; We must be able to take care of all the following different cases:
+        ; (define-values (x) a)
+        ; (define-values (x) (values a))
+        ; (define-values (x) (values (values a)))
+        ; (define-values (x) (values (values (values a))))
+        ; ...
+        ; (define-values (x y) (values a b))
+        ; (define-values (x y) (values (values a) (values b)))
+        ; (define-values (x y) (values (values (values a)) (values (values b))))
+        ; ...
+        ; with all the call to "values" being possibly inside functions...
+        ; So we use extend-edge-for-values that recursively unpacks nested "values" by adding
+        ; new unpacking edges on the fly when a label-values flows into a label that has an
+        ; unpacking edge.
+        ; Note that when define-values defines more than one variable, we must first unpack
+        ; the top level of "values", then start the recursion for each variable separately.
+        (if (= vars-length 1)
+            ; we have something like (define-values (x) (values (values (values a)))) so we
+            ; can directly start the recursion.
+            (let ([var-label (car vars-labels)])
+              (add-edge-and-propagate-set-through-edge
+               exp-label
+               (extend-edge-for-values sba-state (create-simple-edge var-label))))
+            ; we have something like (define-values (x y) (values (values (values a))
+            ; (values (values b)))) so we first have to manually unpack the top-most "values",
+            ; then start a recursion for each of the defined variables. So in effect we end
+            ; up doing something equivalent to analysing
+            ; (define-values (x) (values (values a)))
+            ; (define-values (y) (values (values b)))
+            ; in parallel.
+            (let ([distributive-unpacking-edge
+                   (cons
+                    (lambda (out-label inflowing-label tunnel-label)
+                      ; inflowing-label (the label corresponding to the top "values") doesn't
+                      ; flow anywhere, it's just taken apart and its elements are connected to
+                      ; the different variables. I.e. it's a sink for multiple values. So we
+                      ; have no need for out-label here.
+                      (if (label-values? inflowing-label)
+                          (connect-value-labels-to-var-labels sba-state inflowing-label vars-labels vars-length 'define-values)
+                          ; (define-values (x y) (... 1 ...))
+                          (begin
+                            (set-error-for-label
+                             sba-state
+                             define-label
+                             'red
+                             (format "define-values: context expected ~a values, received 1 non-multiple-values value"
+                                     vars-length))
+                            #f)))
+                    ; multiple values sink => unique, fake destination
+                    (gensym))])
+              (add-edge-and-propagate-set-through-edge
+               exp-label
+               distributive-unpacking-edge)))
+        ;(initialize-label-set-for-value-source define-label)
+        ((sba-state-register-label-with-gui sba-state) define-label)
+        define-label)]
+     [(let-values ((vars exp) ...) body-exps ...)
+      (let* ([let-values-label (create-simple-label sba-state term)]
+             [gamma-extended
+              (list:foldl
+               ; syntax-obj syntax-obj -> (listof (cons symbol label))
+               ; loop on each binding clause of the let-values, returning the corresponding
+               ; extended environment
+               (lambda (vars exp new-gamma)
+                 (let* (; scheme list of syntax objects
+                        [vars (syntax-e vars)]
+                        [vars-length (length vars)]
+                        [vars-labels (map (lambda (term) (create-simple-label sba-state term)) vars)]
+                        ; analyse exp of clause in gamma, not gamma-extended...
+                        [exp-label (create-label-from-term sba-state exp gamma enclosing-lambda-label)])
+                   ; We must be able to take care of all the following different cases:
+                   ; (let-values ([(x) a] ...) ...)
+                   ; (let-values ([(x) (values a)] ...) ...)
+                   ; (let-values ([(x) (values (values a))] ...) ...)
+                   ; (let-values ([(x) (values (values (values a)))] ...) ...)
+                   ; ...
+                   ; (let-values ([(x y) (values a b)] ...) ...)
+                   ; (let-values ([(x y) (values (values a) (values b))] ...) ...)
+                   ; (let-values ([(x y) (values (values (values a)) (values (values b)))] ...) ...)
+                   ; ...
+                   ; with all the call to "values" being possibly inside functions...
+                   ; So we use extend-edge-for-values that recursively unpacks nested "values" by
+                   ; adding new unpacking edges on the fly when a label-values flows into a label
+                   ; that has an unpacking edge.
+                   ; Note that when let-values defines more than one variable, we must first
+                   ; unpack the top level of "values", then start the recursion for each
+                   ; variable separately.
+                   (if (= vars-length 1)
+                       ; we have something like
+                       ; (let-values ([(x) (values (values (values a)))]) ...) so we can
+                       ; directly start the recursion.
+                       (let ([var-label (car vars-labels)])
+                         (add-edge-and-propagate-set-through-edge
+                          exp-label
+                          (extend-edge-for-values sba-state (create-simple-edge var-label))))
+                       ; we have something like
+                       ; (let-values ([(x y) (values (values (values a)) (values (values b)))] ...) ...)
+                       ; so we first have to manually unpack the top-most "values", then start a
+                       ; recursion for each of the defined variables. So in effect we end up
+                       ; doing something equivalent to analysing
+                       ; (let-values ([(x) (values (values a))]
+                       ;               (y) (values (values b))] ...) ...)
+                       ; in parallel.
+                       (let ([distributive-unpacking-edge
+                              (cons
+                               (lambda (out-label inflowing-label tunnel-label)
+                                 ; inflowing-label (the label corresponding to the top "values")
+                                 ; doesn't flow anywhere, it's just taken apart and its elements
+                                 ; are connected to the different variables. I.e. it's a sink for
+                                 ; multiple values. So we have no need for out-label here.
+                                 (if (label-values? inflowing-label)
+                                     (connect-value-labels-to-var-labels sba-state inflowing-label vars-labels vars-length 'let-values)
+                                     ; (let-values ([(x y) (... 1 ...)] ...) ...)
+                                     (begin
+                                       (set-error-for-label
+                                        sba-state
+                                        let-values-label
+                                        'red
+                                        (format "let-values: context expected ~a values, received 1 non-multiple-values value"
+                                                vars-length))
+                                       #f)))
+                               ; multiple values sink
+                               (gensym))])
+                         (add-edge-and-propagate-set-through-edge
+                          exp-label
+                          distributive-unpacking-edge)))
+                   (extend-env new-gamma vars vars-labels)))
+               gamma
+               ; Scheme lists of syntax objects, one for each list of vars and one for each exp
+               (syntax-e (syntax (vars ...)))
+               (syntax-e (syntax (exp ...))))]
+             [last-body-exp-label
+              (list:foldl
+               (lambda (exp _)
+                 (create-label-from-term sba-state exp gamma-extended enclosing-lambda-label))
+               cst:dummy
+               (syntax-e (syntax (body-exps ...))))])
+        (add-edge-and-propagate-set-through-edge
+         last-body-exp-label
+         (create-simple-edge let-values-label))
+        let-values-label)]
+     [(letrec-values ((vars exp) ...) body-exps ...)
+      ; we simulate letrec by doing a let followed by a set!, except that we have to do that
+      ; clause after clause.
+      (let* ([letrec-values-label (create-simple-label sba-state term)]
+             [varss-stx (map syntax-e (syntax-e (syntax (vars ...))))]
+             [varss-labelss (map (lambda (single-clause-vars-stx)
+                                   (map (lambda (var-stx)
+                                          (let ([undefined-label (make-label-cst #f #f #f #f #f
+                                                                                 var-stx
+                                                                                 (make-hash-table)
+                                                                                 (make-hash-table)
+                                                                                 cst:undefined)]
+                                                ;[binding-label (create-simple-label sba-state var-stx)]
+                                                )
+                                            (initialize-label-set-for-value-source undefined-label)
+                                            ;(add-edge-and-propagate-set-through-edge
+                                            ; undefined-label
+                                            ; (create-simple-edge binding-label))
+                                            ;binding-label
+                                            undefined-label))
+                                        single-clause-vars-stx))
+                                 varss-stx)]
+             [gamma-extended (list:foldl
+                              (lambda (vars-stx vars-labels current-gamma)
+                                (extend-env current-gamma vars-stx vars-labels))
+                              gamma
+                              varss-stx
+                              varss-labelss)]
+             [_
+              ; process the clauses expressions, creating new labels for the vars and set!-ing
+              ; gamma-extended as we go along, since the current labels for var contain the
+              ; undefined value. We need to do that before analyzing the body.
+              (let loop ([varss-stx varss-stx]
+                         [exps (syntax-e (syntax (exp ...)))])
+                (unless (null? exps)
+                  ; process current clause
+                  (let* ([exp-label (create-label-from-term sba-state (car exps) gamma-extended enclosing-lambda-label)]
+                         [vars-stx (car varss-stx)]
+                         [vars-length (length vars-stx)])
+                    (if (= vars-length 1)
+                        ; we have a clause like [(x) (values (values (values a)))] so we
+                        ; can directly start the recursion.
+                        (let* ([var-stx (car vars-stx)]
+                               [var-label (create-simple-label sba-state var-stx)]
+                               [var-name (syntax-e var-stx)])
+                          (add-edge-and-propagate-set-through-edge
+                           exp-label
+                           (extend-edge-for-values sba-state (create-simple-edge var-label)))
+                          (search-and-replace gamma-extended var-name var-label))
+                        ; we have a clause like [(x y) (values (values (values a)) (values (values b)))]
+                        ; so we first have to manually unpack the top-most "values", then start a
+                        ; recursion for each of the defined variables. So in effect we end up doing
+                        ; something equivalent to analysing the clauses
+                        ; [(x) (values (values a))]
+                        ; [(y) (values (values b))]
+                        ; in parallel.
+                        (let ([distributive-unpacking-edge
+                               (cons
+                                (lambda (out-label inflowing-label tunnel-label)
+                                  ; inflowing-label (the label corresponding to the top "values") doesn't
+                                  ; flow anywhere, it's just taken apart and its elements are connected to
+                                  ; the different variables. I.e. it's a sink for multiple values. So we
+                                  ; have no need for out-label here.
+                                  (if (label-values? inflowing-label)
+                                      (let ([vars-labels (map (lambda (var-stx) (create-simple-label sba-state var-stx)) vars-stx)])
+                                        (connect-value-labels-to-var-labels sba-state inflowing-label vars-labels vars-length 'let-values)
+                                        (for-each (lambda (var-stx var-label)
+                                                    (search-and-replace gamma-extended (syntax-e var-stx) var-label))
+                                                  vars-stx vars-labels))
+                                      ; [(x y) (... 1 ...))]
+                                      (begin
+                                        (set-error-for-label
+                                         sba-state
+                                         letrec-values-label
+                                         'red
+                                         (format "letrec-values: context expected ~a values, received 1 non-multiple-values value"
+                                                 vars-length))
+                                        #f)))
+                                ; multiple values sink => unique, fake destination
+                                (gensym))])
+                          (add-edge-and-propagate-set-through-edge
+                           exp-label
+                           distributive-unpacking-edge))))
+                  ; process remaining clauses
+                  (loop (cdr varss-stx) (cdr exps))))]
+             [last-body-exp-label
+              (list:foldl
+               (lambda (exp _)
+                 (create-label-from-term sba-state exp gamma-extended enclosing-lambda-label))
+               cst:dummy
+               (syntax-e (syntax (body-exps ...))))])
+        (add-edge-and-propagate-set-through-edge
+         last-body-exp-label
+         (create-simple-edge letrec-values-label))
+        letrec-values-label)]
+     [(if test then else)
+      (let*-values
+          ([(test) (syntax test)]
+           [(test-label) (create-label-from-term sba-state test gamma enclosing-lambda-label)]
+           [(then-label else-label)
+            (if (symbol? (syntax-e test))
+                (let* ([test-name (syntax-e test)]
+                       [binding-label (lookup-env test gamma)]
+                       [new-then-binding-label (create-simple-prim-label term)]
+                       [new-else-binding-label (create-simple-prim-label term)]
+                       [new-then-gamma (extend-env gamma (list test) (list new-then-binding-label))]
+                       [new-else-gamma (extend-env gamma (list test) (list new-else-binding-label))]
+                       [then-normal-edge (create-simple-edge new-then-binding-label)]
+                       [else-normal-edge (create-simple-edge new-else-binding-label)]
+                       ; discards #f, passes the rest to then-normal-edge
+                       [then-filtering-edge
+                        (cons
+                         (lambda (out-label inflowing-label tunnel-label)
+                           (when (or (not (label-cst? inflowing-label))
+                                     (label-cst-value inflowing-label))
+                             ((car then-normal-edge) out-label inflowing-label tunnel-label)))
+                         (cdr then-normal-edge))]
+                       ; discards everything but #f and passes it to else-normal-edge
+                       [else-filtering-edge
+                        (cons
+                         (lambda (out-label inflowing-label tunnel-label)
+                           (when (and (label-cst? inflowing-label)
+                                      (not (label-cst-value inflowing-label)))
+                             ((car else-normal-edge) out-label inflowing-label tunnel-label)))
+                         (cdr else-normal-edge))])
+                  (if binding-label
+                      (begin
+                        (add-edge-and-propagate-set-through-edge binding-label then-filtering-edge)
+                        (add-edge-and-propagate-set-through-edge binding-label else-filtering-edge)
+                        (values
+                         (create-label-from-term sba-state (syntax then) new-then-gamma enclosing-lambda-label)
+                         (create-label-from-term sba-state (syntax else) new-else-gamma enclosing-lambda-label)))
+                      (values
+                       (create-label-from-term sba-state (syntax then) gamma enclosing-lambda-label)
+                       (create-label-from-term sba-state (syntax else) gamma enclosing-lambda-label))))
+                (values
+                 (create-label-from-term sba-state (syntax then) gamma enclosing-lambda-label)
+                 (create-label-from-term sba-state (syntax else) gamma enclosing-lambda-label)))]
+           ; because of the (if test then) case below, else-label might be associated with
+           ; the same position as the whole term, so we have to create the if-label after
+           ; the else-label, so that the wrong label/position association created by the
+           ; else-label is overwritten.
+           [(if-label) (create-simple-label sba-state term)]
+           [(if-edge) (create-simple-edge if-label)]
+           ; that does the outgoing flow sensitivity
+           [(test-edge) (create-self-modifying-edge (lambda (label)
+                                                      ; XXX subtping should be used here
+                                                      (or (not (label-cst? label))
+                                                          (label-cst-value label)))
+                                                    then-label else-label if-edge)])
+        (add-edge-and-propagate-set-through-edge test-label test-edge)
+        if-label)]
+     [(if test then)
+      (let* ([test (syntax test)]
+             [test-label (create-label-from-term sba-state test gamma enclosing-lambda-label)]
+             [then-label
+              (if (symbol? (syntax-e test))
+                  (let* ([test-name (syntax-e test)]
+                         [binding-label (lookup-env test gamma)]
+                         [new-then-binding-label (create-simple-prim-label term)]
+                         [new-then-gamma (extend-env gamma (list test) (list new-then-binding-label))]
+                         [then-normal-edge (create-simple-edge new-then-binding-label)]
+                         ; discards #f, passes the rest to then-normal-edge
+                         [then-filtering-edge
+                          (cons
+                           (lambda (out-label inflowing-label tunnel-label)
+                             (when (or (not (label-cst? inflowing-label))
+                                       (label-cst-value inflowing-label))
+                               ((car then-normal-edge) out-label inflowing-label tunnel-label)))
+                           (cdr then-normal-edge))])
+                    (if binding-label
+                        (begin
+                          (add-edge-and-propagate-set-through-edge binding-label then-filtering-edge)
+                          (create-label-from-term sba-state (syntax then) new-then-gamma enclosing-lambda-label))
+                        (create-label-from-term sba-state (syntax then) gamma enclosing-lambda-label)))
+                  (create-label-from-term sba-state (syntax then) gamma enclosing-lambda-label))]
+             [else-label (let ([void-label (make-label-cst
+                                            #f #f #f #f #t
+                                            term
+                                            (make-hash-table)
+                                            (make-hash-table)
+                                            cst:void)])
+                           (initialize-label-set-for-value-source void-label)
+                           ;(register-label-with-gui void-label)
+                           void-label)]
+             ; because of the (if test then) case below, else-label might be associated with
+             ; the same position as the whole term, so we have to create the if-label after
+             ; the else-label, so that the wrong label/position association created by the
+             ; else-label is overwritten.
+             [if-label (create-simple-label sba-state term)]
+             [if-edge (create-simple-edge if-label)]
+             [test-edge (create-self-modifying-edge (lambda (label)
+                                                      (or (not (label-cst? label))
+                                                          (label-cst-value label)))
+                                                    then-label else-label if-edge)])
+        (add-edge-and-propagate-set-through-edge test-label test-edge)
+        if-label)]
+     [(begin exp exps ...)
+      (let ([begin-label (create-simple-label sba-state term)]
+            [last-body-exp-label (list:foldl
+                                  (lambda (exp _)
+                                    (create-label-from-term sba-state exp gamma enclosing-lambda-label))
+                                  cst:dummy
+                                  (cons (syntax exp) (syntax-e (syntax (exps ...)))))])
+        (add-edge-and-propagate-set-through-edge
+         last-body-exp-label
+         (create-simple-edge begin-label))
+        begin-label)]
+     [(begin0 exp exps ...)
+      (let ([begin0-label (create-simple-label sba-state term)]
+            [first-body-exp-label
+             (create-label-from-term sba-state (syntax exp) gamma enclosing-lambda-label)])
+        (for-each (lambda (exp)
+                    (create-label-from-term sba-state exp gamma enclosing-lambda-label))
+                  (syntax-e (syntax (exps ...))))
+        (add-edge-and-propagate-set-through-edge
+         first-body-exp-label
+         (create-simple-edge begin0-label))
+        begin0-label)]
+     [(#%top . identifier)
+      (let ([identifier (syntax identifier)])
+        (create-top-level-label sba-state identifier gamma enclosing-lambda-label))]
+     [(set! var exp)
+      (let* ([var-stx (syntax var)]
+             [var-name (syntax-e var-stx)]
+             [var-label (create-simple-label sba-state var-stx)]
+             [var-edge (create-simple-edge var-label)]
+             [binding-label (lookup-env var-stx gamma)]
+             [exp-label
+              (create-label-from-term sba-state (syntax exp) gamma enclosing-lambda-label)]
+             [set!-label (create-simple-label sba-state term)]
+             [set!-edge (create-simple-edge set!-label)]
+             [void-label (make-label-cst #f #f #f #f #f
+                                         term
+                                         (make-hash-table)
+                                         (make-hash-table)
+                                         cst:void)])
+        (initialize-label-set-for-value-source void-label)
+        (if binding-label
+            ; lexical variable
+            (let* ([binding-edge (create-simple-edge binding-label)]
+                   [effect
+                    (lambda ()
+                      ;(search-and-replace gamma var-name var-label)
+                      (add-edge-and-propagate-set-through-edge
+                       exp-label var-edge)
+                      (add-edge-and-propagate-set-through-edge
+                       var-label binding-edge)
+                      (add-edge-and-propagate-set-through-edge
+                       void-label set!-edge)
+                      )])
+              (if enclosing-lambda-label
+                  (let* ([enclosing-lambda-effects (label-case-lambda-effects enclosing-lambda-label)]
+                         [current-thunk (car enclosing-lambda-effects)])
+                    (set-car! enclosing-lambda-effects
+                              (lambda ()
+                                (current-thunk)
+                                (effect))))
+                  (effect)))
+            (let ([effect
+                   (lambda ()
+                     ; delay the lookup until the effect takes place
+                     ; if the name we want to set! is a primitive, we set! the label that
+                     ; simulates the primitive's definition.
+                     (let ([binding-label (or (lookup-top-level-name sba-state var-name)
+                                              (let ([primitive-data
+                                                     (lookup-primitive-data sba-state var-name)])
+                                                (if primitive-data
+                                                    (prim-data-label primitive-data)
+                                                    #f)))])
+                       (if (or binding-label
+                               (eq? var-name 'make-struct-type)
+                               (eq? var-name 'make-struct-field-accessor)
+                               (eq? var-name 'make-struct-field-mutator)
+                               (eq? var-name 'set-car!)
+                               (eq? var-name 'set-cdr!)
+                               (eq? var-name 'string-set!)
+                               (eq? var-name 'string-fill!)
+                               (eq? var-name 'vector-set!)
+                               (eq? var-name 'vector-fill!))
+                           ; top level var
+                           (let ([binding-edge (create-simple-edge binding-label)]) 
+                             ;(add-top-level-name var-stx var-label)
+                             (add-edge-and-propagate-set-through-edge
+                              exp-label var-edge)
+                             (add-edge-and-propagate-set-through-edge
+                              var-label binding-edge)
+                             (add-edge-and-propagate-set-through-edge
+                              void-label set!-edge)
+                             )
+                           (set-error-for-label sba-state
+                                                set!-label
+                                                'red
+                                                (format "set!: cannot set undefined identifier: ~a" var-name)))))])
+              (if enclosing-lambda-label
+                  (let* ([enclosing-lambda-effects (label-case-lambda-effects enclosing-lambda-label)]
+                         [current-thunk (car enclosing-lambda-effects)])
+                    (set-car! enclosing-lambda-effects
+                              (lambda ()
+                                (current-thunk)
+                                (effect))))
+                  (effect))))
+        set!-label)]
+     [(quote-syntax foo ...)
+      (let ([label (create-simple-label sba-state term)])
+        (set-error-for-label sba-state
+                             label
+                             'red
+                             (format "quote-syntax not yet implemented"))
+        label)]
+     [(with-continuation-mark foo ...)
+      (let ([label (create-simple-label sba-state term)])
+        (set-error-for-label sba-state
+                             label
+                             'red
+                             (format "with-continuation-mark not yet implemented"))
+        label)]
+     [(define-syntaxes foo ...)
+      (let ([label (create-simple-label sba-state term)])
+        (set-error-for-label sba-state
+                             label
+                             'red
+                             (format "define-syntaxes not yet implemented"))
+        label)]
+     [(module foo ...)
+      (let ([label (create-simple-label sba-state term)])
+        (set-error-for-label sba-state
+                             label
+                             'red
+                             (format "module not yet implemented"))
+        label)]
+     [(require foo ...)
+      (let ([label (create-simple-label sba-state term)])
+        (set-error-for-label sba-state
+                             label
+                             'red
+                             (format "require not yet implemented"))
+        label)]
+     [(require-for-syntax foo ...)
+      (let ([label (create-simple-label sba-state term)])
+        (set-error-for-label sba-state
+                             label
+                             'red
+                             (format "require-for-syntax not yet implemented"))
+        label)]
+     [(provide foo ...)
+      (let ([label (create-simple-label sba-state term)])
+        (set-error-for-label sba-state
+                             label
+                             'red
+                             (format "provide not yet implemented"))
+        label)]
+     [(#%plain-module-begin foo ...)
+      (let ([label (create-simple-label sba-state term)])
+        (set-error-for-label sba-state
+                             label
+                             'red
+                             (format "#%plain-module-begin not yet implemented"))
+        label)]
+     [var
+      ; we cannot directly return the binding label, because, even though it makes for a
+      ; simpler graph and simpler types, it screws up the arrows
+      (let* ([var-stx (syntax var)]
+             ;[var-name (syntax-e var-stx)]
+             [binding-label (lookup-env var-stx gamma)])
+        (if binding-label
+            ; lexical variable
+            (let ([bound-label (create-simple-label sba-state term)])
+              (if enclosing-lambda-label
+                  ; we have to delay the binding, because there might be a set! in between the
+                  ; analysis of the enclosing lambda and the time the lambda is applied.
+                  ; Note that this means we have to redo a lookup later to get the right binder,
+                  ; which will have changed if a set! has occured (explicitely, or because
+                  ; the lambda is in a letrec clause (see letrec))
+                  (let* ([enclosing-lambda-effects
+                          (label-case-lambda-effects enclosing-lambda-label)]
+                         [current-thunk (car enclosing-lambda-effects)])
+                    (set-car! enclosing-lambda-effects
+                              (lambda ()
+                                (current-thunk)
+                                (let ([binding-label (lookup-env var-stx gamma)])
+                                  (add-edge-and-propagate-set-through-edge
+                                   binding-label
+                                   (extend-edge-for-values sba-state (create-simple-edge bound-label)))))))
+                  (add-edge-and-propagate-set-through-edge
+                   binding-label
+                   (extend-edge-for-values sba-state (create-simple-edge bound-label))))
+              bound-label)
+            ; probably a top level var (like a primitive name) but without #%top (if it comes
+            ; from a macro, or some strange stuff like that.
+            (create-top-level-label sba-state var-stx gamma enclosing-lambda-label)
+            ))]
+     ))
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; TYPES
+  
+  ; each entry is of the form (type-name (listof direct-subtypes) scheme-predicate)
+  ; top should appear first (see the subtype function below)
+  ; note also that exact? and inexact? can only be used for numbers, so we have to do
+  ; tests like complex? first.
+  (define *basic-types* `((top (undefined void null boolean char symbol string eof-object env number port)
+                               ,(lambda (_) #t))
+                          (undefined () ,(lambda (v) (eq? v cst:undefined)))
+                          (void () ,void?)
+                          (null () ,null?)
+                          (boolean () ,boolean?)
+                          (char (letter) ,char?)
+                          ; approximation
+                          (letter () ,char?)
+                          (symbol () ,symbol?)
+                          (string () ,string?)
+                          (eof-object () ,eof-object?)
+                          ; no r5rs predicate, but no subtype anyway...
+                          (env () ,(lambda (_) #f))
+                          (number (exact-number inexact-number complex) ,number?)
+                          (exact-number (exact-complex) ,(lambda (n) (and (number? n) (exact? n))))
+                          (inexact-number (inexact-complex) ,(lambda (n) (and (number? n) (inexact? n))))
+                          (complex (exact-complex inexact-complex real) ,complex?)
+                          (exact-complex (exact-real) ,(lambda (n) (and (complex? n) (exact? n))))
+                          (inexact-complex (inexact-real) ,(lambda (n) (and (complex? n) (inexact? n))))
+                          (real (exact-real inexact-real rational) ,real?)
+                          (exact-real (exact-rational) ,(lambda (n) (and (real? n) (exact? n))))
+                          (inexact-real (inexact-rational) ,(lambda (n) (and (real? n) (inexact? n))))
+                          (rational (exact-rational inexact-rational integer) ,rational?)
+                          (exact-rational (exact-integer) ,(lambda (n) (and (rational? n) (exact? n))))
+                          (inexact-rational (inexact-integer) ,(lambda (n) (and (rational? n) (inexact? n))))
+                          (integer (exact-integer inexact-integer) ,integer?)
+                          (exact-integer () ,(lambda (n) (and (integer? n) (exact? n))))
+                          (inexact-integer () ,(lambda (n) (and (integer? n) (inexact? n))))
+                          (port (input-port) ,port?)
+                          (input-port () ,input-port?)
+                          (output-port () ,output-port?)
+                          (bottom () ,(lambda (_) #f))
+                          ))
+  
+  (define *type-constructors* '(forall
+                                cons listof
+                                vector union values
+                                case-lambda -> *-> rest
+                                promise
+                                rec-type
+                                ))
+  (define *all-type-keywords* (append (map car *basic-types*) *type-constructors*))
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; PRIMITIVE TYPE PARSER AND LOOKUP
+  
+  ; sba-state symbol -> (union prim-data #f)
+  (define (lookup-primitive-data sba-state name)
+    (hash-table-get (sba-state-primitive-types-table sba-state) name cst:thunk-false))
+  
+  ; sba-state string -> void
+  (define (initialize-primitive-type-schemes sba-state filename)
+    ; XXX should check for errors
+    (let ([sexp (call-with-input-file filename read 'text)]
+          [primitive-types-table (sba-state-primitive-types-table sba-state)])
+      (unless (list? sexp)
+        (raise-syntax-error
+         'initialize-primitive-type-schemes
+         (format "expected list at top level in file ~a, got: ~a"
+                 filename sexp)))
+      (for-each (lambda (prim-entry) 
+                  (unless (and (list? prim-entry)
+                               (= 2 (length prim-entry))
+                               (symbol? (car prim-entry)))
+                    (raise-syntax-error
+                     'initialize-primitive-type-schemes
+                     (format "expected `(,symbol type-scheme) entry in file ~a, got: ~a"
+                             filename prim-entry))))
+                sexp)
+      (for-each (lambda (prim-entry)
+                  (let ([primitive-name (car prim-entry)]
+                        [primitive-type (cadr prim-entry)])
+                    (when (hash-table-get primitive-types-table
+                                          primitive-name cst:thunk-false)
+                      (raise-syntax-error
+                       'initialize-primitive-type-schemes
+                       (format "found duplicate for primitive ~a in file ~a"
+                               primitive-name filename)))
+                    (hash-table-put! primitive-types-table primitive-name
+                                     (make-prim-data (parse&check-type-scheme
+                                                      primitive-type primitive-name filename)
+                                                     (create-simple-prim-label #f)))))
+                sexp)))
+  
+  ; sexp symbol tring -> type
+  (define (parse&check-type-scheme sexp primitive-name filename)
+    (if (and (list? sexp)
+             (not (null? sexp))
+             (eq? (car sexp) 'forall))
+        (if (= (length sexp) 3)
+            (let ([delta-flow (make-hash-table)]
+                  [flow-vars&type^cs (cadr sexp)]
+                  [type (caddr sexp)])
+              (for-each
+               (lambda (flow-var&type^C)
+                 (if (and (list? flow-var&type^C)
+                          (= (length flow-var&type^C) 2)
+                          (symbol? (car flow-var&type^C)))
+                     (let ([flow-var (car flow-var&type^C)]
+                           [type^C (cadr flow-var&type^C)])
+                       (when (memq flow-var *all-type-keywords*)
+                         (raise-syntax-error
+                          'parse&check-type-scheme
+                          (format "flow variable ~a is already the name of a basic type or type constructor, in type scheme for primitive ~a in file ~a"
+                                  flow-var primitive-name filename)))
+                       (when (hash-table-get delta-flow flow-var cst:thunk-false)
+                         (raise-syntax-error
+                          'parse&check-type-scheme
+                          (format "duplicate flow variable ~a in type scheme for primitive ~a in file ~a"
+                                  flow-var primitive-name filename)))
+                       (hash-table-put! delta-flow
+                                        flow-var
+                                        (cons (list #t #t (make-type-flow-var flow-var))
+                                              ; type^cs do not contain flow vars, so we give an
+                                              ; empty delta. If this function returns, we know
+                                              ; the result is a constant type.
+                                              (parse&check-type type^C
+                                                                (make-hash-table)
+                                                                '()
+                                                                #t
+                                                                primitive-name filename))))
+                     (raise-syntax-error
+                      'parse&check-type-scheme
+                      (format "malformed type scheme clause for primitive ~a in file ~a: expected (symbol type), got ~a"
+                              primitive-name filename flow-var&type^C))))
+               flow-vars&type^cs)
+              (let ([type (parse&check-type type delta-flow '() #t primitive-name filename)])
+                (hash-table-for-each
+                 delta-flow
+                 (lambda (flow-var type-info)
+                   (let ([no-contra-use (caar type-info)]
+                         [no-co-use (cadar type-info)])
+                     (cond
+                       [(and no-contra-use no-co-use)
+                        (raise-syntax-error
+                         'parse&check-type-scheme
+                         (format "unused flow variable ~a in type scheme for primitive ~a in file ~a"
+                                 flow-var primitive-name filename))]
+                       [no-contra-use
+                        (raise-syntax-error
+                         'parse&check-type-scheme
+                         (format "no contravariant in-flow for flow variable ~a in type scheme for primitive ~a in file ~a"
+                                 flow-var primitive-name filename))]
+                       [no-co-use
+                        (raise-syntax-error
+                         'parse&check-type-scheme
+                         (format "no covariant out-flow for flow variable ~a in type scheme for primitive ~a in file ~a"
+                                 flow-var primitive-name filename))]
+                       [else #t]))))
+                (if (null? flow-vars&type^cs)
+                    type
+                    (make-type-scheme
+                     (hash-table-map delta-flow (lambda (flow-var type-info) (caddar type-info)))
+                     (hash-table-map delta-flow (lambda (flow-var type-info) (cdr type-info)))
+                     type))))
+            (raise-syntax-error 'parse&check-type-scheme
+                                (format "malformed type scheme for primitive ~a in file ~a: expected (forall (flow-var-clause ...) type), got ~a"
+                                        primitive-name filename sexp)))
+        (parse&check-type sexp (make-hash-table) '() #t primitive-name filename)))
+  
+  ; sexp (hash-table-of symbol (cons (list boolean boolean type-var) type))
+  ; (listof (cons symbol type-var))) boolean symbol string -> type
+  (define (parse&check-type sexp delta-flow delta-type covariant? primitive-name filename)
+    (if (list? sexp)
+        (if (null? sexp)
+            (make-type-cst '())
+            (let ([type-kw (car sexp)])
+              (cond
+                [(eq? type-kw 'forall)
+                 (raise-syntax-error
+                  'parse&check-type
+                  (format "type scheme inside type or other type scheme for primitive ~a in file ~a: ~a"
+                          primitive-name filename sexp))]
+                [(eq? type-kw 'case-lambda)
+                 (let ([all-types            
+                        (list:foldr
+                         (lambda (clause other-clauses-types)
+                           (if (and (list? clause)
+                                    (= (length clause) 2))
+                               (let* ([args (car clause)]
+                                      [exp (cadr clause)]
+                                      [exp-type (parse&check-type exp delta-flow delta-type
+                                                                  covariant?
+                                                                  primitive-name filename)]
+                                      [rest-arg?s (vector-ref other-clauses-types 0)]
+                                      [req-args (vector-ref other-clauses-types 1)]
+                                      [argss-typess (vector-ref other-clauses-types 2)]
+                                      [exps-types (vector-ref other-clauses-types 3)])
+                                 (if (list? args)
+                                     (let ([args-length (length args)])
+                                       (if (and (pair? args) ; could be empty
+                                                (eq? (car args) 'rest))
+                                           ; list of (possibly complex) args with (possibly complex) rest arg
+                                           (if (> args-length 1)
+                                               (vector (cons #t rest-arg?s)
+                                                       (cons (- args-length 2) req-args)
+                                                       (cons (map (lambda (arg)
+                                                                    (parse&check-type arg delta-flow delta-type
+                                                                                      (not covariant?)
+                                                                                      primitive-name filename))
+                                                                  (cdr args))
+                                                             argss-typess)
+                                                       (cons exp-type exps-types))
+                                               (raise-syntax-error
+                                                'parse&check-type
+                                                (format "missing rest argument in argument list for clause in case-lambda type in type scheme for primitive ~a in file ~a: expected (rest arg-type args-types ...), got ~a"
+                                                        primitive-name filename args)))
+                                           ; normal (possibly empty) list of (possibly complex) args
+                                           (vector (cons #f rest-arg?s)
+                                                   (cons args-length req-args)
+                                                   (cons (map (lambda (arg)
+                                                                (parse&check-type arg delta-flow delta-type
+                                                                                  (not covariant?)
+                                                                                  primitive-name filename))
+                                                              args)
+                                                         argss-typess)
+                                                   (cons exp-type exps-types))))
+                                     (raise-syntax-error
+                                      'parse&check-type
+                                      (format "malformed argument list for clause in case-lambda type in type scheme for primitive ~a in file ~a: expected (args-types ...), got ~a"
+                                              primitive-name filename args))))
+                               (raise-syntax-error
+                                'parse&check-type
+                                (format "malformed clause in case-lambda type in type scheme for primitive ~a in file ~a: expected (args-types exp-type), got ~a"
+                                        primitive-name filename clause))))
+                         (vector '()'()'()'())
+                         (cdr sexp))])
+                   (make-type-case-lambda (vector-ref all-types 0)
+                                          (vector-ref all-types 1)
+                                          (vector-ref all-types 2)
+                                          (vector-ref all-types 3)))]
+                [(eq? type-kw 'cons)
+                 (if (= (length sexp) 3)
+                     (make-type-cons (parse&check-type (cadr sexp) delta-flow delta-type covariant?
+                                                       primitive-name filename)
+                                     (parse&check-type (caddr sexp) delta-flow delta-type covariant?
+                                                       primitive-name filename))
+                     (raise-syntax-error
+                      'parse&check-type
+                      (format "malformed cons type in type scheme for primitive ~a in file ~a: ~a"
+                              primitive-name filename sexp)))]
+                [(eq? type-kw 'union)
+                 (make-type-union (map (lambda (elt-sexp)
+                                         (parse&check-type
+                                          elt-sexp delta-flow delta-type covariant?
+                                          primitive-name filename))
+                                       (cdr sexp)))]
+                [(eq? type-kw 'values)
+                 (if (= (length sexp) 2)
+                     (make-type-values (parse&check-type
+                                        (cadr sexp) delta-flow delta-type covariant?
+                                        primitive-name filename))
+                     (raise-syntax-error
+                      'parse&check-type
+                      (format "malformed values type in type scheme for primitive ~a in file ~a: expected (values type), got ~a"
+                              primitive-name filename sexp)))]
+                [(eq? type-kw 'rec-type)
+                 (if (= (length sexp) 3)
+                     (let* ([clauses (cadr sexp)]
+                            [clauses-type-vars-names&types
+                             (map
+                              (lambda (clause)
+                                (if (and (list? clause)
+                                         (= (length clause) 2))
+                                    (let ([type-var-name (car clause)])
+                                      (if (or (assq type-var-name delta-type)
+                                              (hash-table-get delta-flow sexp cst:thunk-false))
+                                          (raise-syntax-error
+                                           'parse&check-type
+                                           (format "recursive type variable ~a used twice or conflicts with flow variable name in type scheme for primitive ~a in file ~a"
+                                                   type-var-name primitive-name filename))
+                                          (cons type-var-name (make-type-var type-var-name #f #f))))))
+                              clauses)]
+                            [all-type-vars (append clauses-type-vars-names&types delta-type)]
+                            [clauses-types
+                             (map
+                              (lambda (clause)
+                                (parse&check-type
+                                 (cadr clause) delta-flow all-type-vars covariant?
+                                 primitive-name filename))
+                              clauses)])
+                       (make-type-rec (map cdr clauses-type-vars-names&types) clauses-types
+                                      (parse&check-type
+                                       (caddr sexp) delta-flow all-type-vars covariant?
+                                       primitive-name filename)))
+                     (raise-syntax-error
+                      'parse&check-type
+                      (format "malformed recursive type in type scheme primitive ~a in file ~a: ~a"
+                              primitive-name filename sexp)))]
+                [(eq? type-kw 'listof)
+                 (if (= (length sexp) 2)
+                     ; (listof T) = (rec ([alpha (union '() (cons T alpha))]) alpha)
+                     (let ([listof-type-var (gensym)])
+                       (parse&check-type
+                        `(rec-type ([,listof-type-var (union () (cons ,(cadr sexp) ,listof-type-var))])
+                                   ,listof-type-var)
+                        delta-flow delta-type
+                        covariant?
+                        primitive-name filename))
+                     (raise-syntax-error
+                      'parse&check-type
+                      (format "malformed listof type in type scheme for primitive ~a in file ~a: expected (listof type), got ~a"
+                              primitive-name filename sexp)))]
+                [(eq? type-kw 'vector)
+                 (if (= (length sexp) 2)
+                     (make-type-vector (parse&check-type
+                                        (cadr sexp) delta-flow delta-type covariant?
+                                        primitive-name filename))
+                     (raise-syntax-error
+                      'parse&check-type
+                      (format "malformed vector type in type scheme for primitive ~a in file ~a: expected (vector type), got ~a"
+                              primitive-name filename sexp)))]
+                [(eq? type-kw 'promise)
+                 (if (= (length sexp) 2)
+                     (make-type-promise (parse&check-type
+                                         (cadr sexp) delta-flow delta-type covariant?
+                                         primitive-name filename))
+                     (raise-syntax-error
+                      'parse&check-type
+                      (format "malformed promise type in type scheme for primitive ~a in file ~a: expected (promise type), got ~a"
+                              primitive-name filename sexp)))]
+                [(eq? type-kw 'rest)
+                 (raise-syntax-error
+                  'parse&check-type
+                  (format "illegal use of rest in type scheme for primitive ~a in file ~a: ~a"
+                          primitive-name filename sexp))]
+                [else
+                 (let* ([sexp-length (length sexp)]
+                        [sexp-length-1 (sub1 sexp-length)]
+                        [sexp-length-2 (sub1 sexp-length-1)]
+                        [sexp-length-3 (sub1 sexp-length-2)])
+                   (cond
+                     [(and (>= sexp-length-2 0)
+                           (eq? (list-ref sexp sexp-length-2) '->))
+                      (let ([exp-sexp (list-ref sexp sexp-length-1)]
+                            [list-head (list-head! sexp sexp-length-2
+                                                   primitive-name filename)])
+                        (parse&check-type
+                         `(case-lambda [,list-head ,exp-sexp])
+                         delta-flow delta-type covariant? primitive-name filename))]
+                     [(and (>= sexp-length-3 0)
+                           (eq? (list-ref sexp sexp-length-2) '*->))
+                      (let ([exp-sexp (list-ref sexp sexp-length-1)]
+                            [rest-sexp (list `(listof ,(list-ref sexp sexp-length-3)))]
+                            [list-head (list-head! sexp sexp-length-3
+                                                   primitive-name filename)])
+                        (parse&check-type
+                         `(case-lambda [,(cons 'rest (set-list-tail-cdr! list-head rest-sexp))
+                                         ,exp-sexp])
+                         delta-flow delta-type covariant? primitive-name filename))]
+                     [else
+                      (raise-syntax-error
+                       'parse&check-type
+                       (format "malformed constructed type in type scheme for primitive ~a in file ~a: ~a"
+                               primitive-name filename sexp))]))]
+                )))
+        (cond
+          [(pair? sexp)
+           ; improper list
+           (raise-syntax-error
+            'parse&check-type
+            (format "improper list found in type scheme for primitive ~a in file ~a: ~a"
+                    primitive-name filename sexp))]
+          [(memq sexp *type-constructors*)
+           =>
+           (lambda (_)
+             (raise-syntax-error
+              'parse&check-type-scheme
+              (format "type variable ~a is already the name of a type constructor, in type scheme for primitive ~a in file ~a"
+                      sexp primitive-name filename)))]
+          [(hash-table-get delta-flow sexp cst:thunk-false)
+           =>
+           (lambda (type-info)
+             (if covariant?
+                 (set-car! (cdar type-info) #f)
+                 (if (caar type-info)
+                     (set-car! (car type-info) #f)
+                     ; already used this flow variable in contravariant position
+                     (raise-syntax-error
+                      'parse&check-type
+                      (format "flow variable ~a used several times in contravariant position in type scheme for primitive ~a in file ~a"
+                              sexp primitive-name filename))))
+             (caddar type-info))]
+          [(assq sexp delta-type)
+           =>
+           ; gets (cons type-var-name type-var) => returns type-var
+           cdr]
+          ; [(memq sexp *basic-types*);XXX definition of *basic-types* has changed...
+          ;  (make-type-cst sexp)]
+          ; the following works for both basic types and any atomic value (which is
+          ; then considered a basic type too). We know that flow var names and basic
+          ; type names are disjoint, so there's no confusion between this case and
+          ; the previous one.
+          [else
+           (cond
+             [(eq? sexp 'boolean)
+              (make-type-union (list (make-type-cst #t) (make-type-cst #f)))]
+             [(eq? sexp 'void)
+              (make-type-cst cst:void)]
+             [(eq? sexp 'bottom)
+              (make-type-empty)]
+             [(eq? sexp 'undefined)
+              (make-type-cst cst:undefined)]
+             [else (make-type-cst sexp)])])))
+  
+  ; (listof alpha) number sexp symbol string -> (listof alpha)
+  ; returns first n elements of l. We know from the way the function is called that we
+  ; must always have n >= 0 and (length l) >= n.
+  (define (list-head! l n primitive-name filename)
+    (letrec ([chop (lambda (l n)
+                     (if (= n 1)
+                         (set-cdr! l '())
+                         (chop (cdr l) (sub1 n))))])
+      (cond
+        [(zero? n) '()]
+        [(>= n 1) (chop l n) l]
+        [else (raise-syntax-error
+               'list-head!
+               (format "internal error 6 in type scheme for primitive ~a in file ~a"
+                       primitive-name filename))])))
+  
+  ; (listof top) top -> improper-list
+  ; glues rest-sexp as the cdr of the last element of list-head
+  (define (set-list-tail-cdr! list-head rest-sexp)
+    (letrec ([glue (lambda (l)
+                     (if (null? (cdr l))
+                         (set-cdr! l rest-sexp)
+                         (glue (cdr l))))])
+      (if (null? list-head)
+          rest-sexp
+          (begin
+            (glue list-head)
+            list-head))))
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; TYPE ENVIRONMENT & MISC
+  
+  ; (hash-table-of symbol label) type-flow-var label -> label
+  (define (add-flow-var-to-env env flow-var label)
+    (hash-table-put! env flow-var label)
+    env)
+  
+  ; (hash-table-of symbol label) type-flow-var -> label
+  ; the type parser guarantees that the lookup will be succesfull
+  (define (lookup-flow-var-in-env env flow-var)
+    (hash-table-get env flow-var))
+  
+  ; like map, but over a list made of label-cons instead of cons
+  (define (type-list-map f tl)
+    (if (type-cons? tl)
+        (cons (f (type-cons-car tl))
+              (type-list-map f (type-cons-cdr tl)))
+        (if (and (type-cst? tl)
+                 (eq? (type-cst-type tl) '()))
+            '()
+            (error 'type-list-map "not a type list: ~a" tl))))
+  
+  ; symmetric of list-tail
+  (define (list-head l n)
+    (if (zero? n)
+        '()
+        (if (null? l)
+            (error 'list-head "list too short")
+            (cons (car l)
+                  (list-head (cdr l) (sub1 n))))))
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; GRAPH RECONSTRUCTION FROM TYPE
+  
+  ; sba-state type (hash-table-of symbol label) label -> label
+  ; analyse type scheme and creates flow var environment
+  ; label is the label into which the final result will flow into. We need that
+  ; mainly to report errors correctly.
+  (define (reconstruct-graph-from-type-scheme sba-state type delta-flow label)
+    (let ([term (label-term label)])
+      (if (type-scheme? type)
+          (begin
+            (for-each (lambda (flow-var type^C)
+                        (let ([label (create-simple-prim-label term)])
+                          ;(associate-label-with-type label type^C)
+                          (add-flow-var-to-env delta-flow flow-var (cons label type^C))))
+                      (type-scheme-flow-vars type)
+                      (type-scheme-type^cs type))
+            (reconstruct-graph-from-type sba-state (type-scheme-type type) delta-flow '() label term #t #f))
+          (reconstruct-graph-from-type sba-state type delta-flow '() label term #t #f))))
+  
+  ; sba-state type (hash-table-of type-flow-var (cons label type)) (listof (cons type-var label))
+  ; label term boolean label -> label
+  ; reconstructs a graph from type representing the primitive represented by label,
+  ; using environment delta.
+  ; delta-flow is the flow-var->label environment, delta-type is the type-var->label one.
+  ; label is the label for the primitive whose type we are analyzing. It's just used for underlining
+  ; errors. Same for term. covariant? is self-explanatory...
+  ; contra-union? is a boolean telling whether the parent label we are dealing
+  ; with is a union in contravariant position: since the flows are not filtered by types,
+  ; everything that flows into a union will normally flow into the different componants
+  ; of the union. We don't want that, because then things might flow into a label were they
+  ; should flow into and trigger a false error. The best example is this is with lists: it's
+  ; a recursive type that contains a union of the empty list and of a recursive cons. If a
+  ; cons flows into a list label, the cons will flow in both parts of the union, and trigger
+  ; an error when it flows into the empty label. So we have to do some filtering. This means
+  ; that we are not going to create a simple edge between the union label and the empty label
+  ; when we analyze the union type, but we are going to create a filtering edge between the
+  ; union label and the empty label when we analyze the empty type. To do that we need to
+  ; keep track of the parent union label.
+  ; Note how we use associate-label-with-type to memorize type checking only in the contravariant
+  ; case. The type to check in the covariant case is always top, since we assume internal
+  ; correctness of the graph generation from a primitive type.
+  (define (reconstruct-graph-from-type sba-state type delta-flow delta-type label term covariant? contra-union?)
+    (if covariant?
+        ; covariant cases
+        (cond
+          [(type-case-lambda? type)
+           (let* ([all-labels
+                   (list:foldr
+                    (lambda (args-types exp-type other-clauses-labels)
+                      (let ([argss-labelss (car other-clauses-labels)]
+                            [exps-labels (cdr other-clauses-labels)])
+                        (cons (cons (map (lambda (arg-type)
+                                           (reconstruct-graph-from-type
+                                            sba-state
+                                            arg-type delta-flow delta-type label term #f #f))
+                                         args-types)
+                                    argss-labelss)
+                              (cons (reconstruct-graph-from-type
+                                     sba-state
+                                     exp-type delta-flow delta-type label term #t #f)
+                                    exps-labels))))
+                    (cons '()'())
+                    (type-case-lambda-argss type)
+                    (type-case-lambda-exps type))]
+                  [label (make-label-case-lambda
+                          #f #f #f #f #t
+                          term
+                          (make-hash-table)
+                          (make-hash-table)
+                          #f
+                          (type-case-lambda-rest-arg?s type)
+                          (type-case-lambda-req-args type)
+                          (car all-labels)
+                          (cdr all-labels)
+                          ;(map (lambda (_) '()) all-labels)
+                          (map (lambda (_) cst:dummy-thunk) all-labels))])
+             (initialize-label-set-for-value-source label)
+             label)]
+          [(type-cons? type)
+           (let ([label (make-label-cons
+                         #f #f #f #f #t
+                         term
+                         (make-hash-table)
+                         (make-hash-table)
+                         (reconstruct-graph-from-type
+                          sba-state
+                          (type-cons-car type) delta-flow delta-type label term #t #f)
+                         (reconstruct-graph-from-type
+                          sba-state
+                          (type-cons-cdr type) delta-flow delta-type label term #t #f))])
+             (initialize-label-set-for-value-source label)
+             label)]
+          [(type-vector? type)
+           (let ([label (make-label-vector
+                         #f #f #f #f #t
+                         term
+                         (make-hash-table)
+                         (make-hash-table)
+                         (reconstruct-graph-from-type
+                          sba-state
+                          (type-vector-element type) delta-flow delta-type label term #t #f))])
+             (initialize-label-set-for-value-source label)
+             label)]
+          [(type-promise? type)
+           (let ([label (make-label-promise
+                         #f #f #f #f #t
+                         term
+                         (make-hash-table)
+                         (make-hash-table)
+                         (reconstruct-graph-from-type
+                          sba-state
+                          (type-promise-value type) delta-flow delta-type label term #t #f))])
+             (initialize-label-set-for-value-source label)
+             label)]
+          [(type-flow-var? type)
+           (car (lookup-flow-var-in-env delta-flow type))]
+          [(type-var? type)
+           (cdr (assq type delta-type))]
+          [(type-cst? type)
+           (let ([label (make-label-cst
+                         #f #f #f #f #t
+                         term
+                         (make-hash-table)
+                         (make-hash-table)
+                         ; the type parser ensures that type-cst is only created for
+                         ; non-list (i.e. atomic) types => 3, 'foo, 'int
+                         (type-cst-type type))])
+             (initialize-label-set-for-value-source label)
+             label)]
+          [(type-union? type)
+           (let* ([elt-labels (map (lambda (elt-type)
+                                     (reconstruct-graph-from-type
+                                      sba-state
+                                      elt-type delta-flow delta-type label term #t #f))
+                                   (type-union-elements type))]
+                  [union-label (create-simple-prim-label term)]
+                  ; can return multiple values
+                  [union-edge (create-simple-edge union-label)])
+             (for-each (lambda (elt-label)
+                         (add-edge-and-propagate-set-through-edge elt-label union-edge))
+                       elt-labels)
+             union-label)]
+          [(type-values? type)
+           (let* ([values-content-label (reconstruct-graph-from-type
+                                         sba-state
+                                         (type-values-type type) delta-flow delta-type label term #t #f)]
+                  [values-label (make-label-values
+                                 #f #f #f #f #t
+                                 term
+                                 (make-hash-table)
+                                 (make-hash-table)
+                                 values-content-label)])
+             (initialize-label-set-for-value-source values-label)
+             values-label)]
+          [(type-rec? type)
+           (let* ([clauses-vars-types&labels (map (lambda (type-var)
+                                                    (cons type-var (create-simple-prim-label term)))
+                                                  (type-rec-vars type))]
+                  [all-var-labels (append clauses-vars-types&labels delta-type)]
+                  [clauses-types-labels (map (lambda (clause-type)
+                                               (reconstruct-graph-from-type
+                                                sba-state
+                                                clause-type delta-flow all-var-labels label term #t #f))
+                                             (type-rec-types type))])
+             ; note: we never check whether all clauses are used. If they are not, they'll be
+             ; garbage collected after we return from here.
+             (for-each (lambda (clause-var-type&label clause-type-label)
+                         (add-edge-and-propagate-set-through-edge
+                          clause-type-label
+                          (create-simple-edge (cdr clause-var-type&label))))
+                       clauses-vars-types&labels clauses-types-labels)
+             (reconstruct-graph-from-type sba-state (type-rec-body type) delta-flow all-var-labels label term #t #f))]
+          [(type-empty? type)
+           (create-simple-prim-label term)]
+          [else (error 'reconstruct-graph-from-type "unknown covariant type for primitive ~a: ~a"
+                       (syntax-e term) type)]
+          )
+        ;
+        ; contravariant cases
+        ;
+        (cond
+          [(type-case-lambda? type)
+           (let* ([rest-arg?s-around (type-case-lambda-rest-arg?s type)]
+                  [req-args-around (type-case-lambda-req-args type)]
+                  [argss-labelss-around (map (lambda (args-types)
+                                               (map (lambda (arg-type)
+                                                      (reconstruct-graph-from-type
+                                                       sba-state
+                                                       arg-type delta-flow delta-type label term #t #f))
+                                                    args-types))
+                                             (type-case-lambda-argss type))]
+                  [exps-labels-around (map (lambda (exp-type)
+                                             (reconstruct-graph-from-type
+                                              sba-state
+                                              exp-type delta-flow delta-type label term #f #f))
+                                           (type-case-lambda-exps type))]
+                  [case-lambda-label (create-simple-prim-label term)]
+                  [case-lambda-edge (create-case-lambda-edge
+                                     sba-state
+                                     rest-arg?s-around
+                                     req-args-around
+                                     argss-labelss-around
+                                     exps-labels-around
+                                     case-lambda-label
+                                     contra-union?)])
+             (unless contra-union?
+               (associate-label-with-type
+                sba-state
+                case-lambda-label 
+                (make-type-case-lambda
+                 rest-arg?s-around
+                 req-args-around
+                 (map (lambda (args-labels rest-arg?)
+                        (if rest-arg?
+                            (list:foldr
+                             (lambda (arg-label other-args)
+                               (if (null? other-args)
+                                   ; rest arg => listof
+                                   (let ([fake-type-var (make-type-var (gensym) #f #f)])
+                                     (cons (make-type-rec
+                                            (list fake-type-var)
+                                            (list (make-type-union
+                                                   (list
+                                                    (make-type-cst '())
+                                                    (make-type-cons
+                                                     (make-type-empty)
+                                                     fake-type-var))))
+                                            fake-type-var)
+                                           '()))
+                                   (cons (make-type-empty)
+                                         other-args)))
+                             '()
+                             args-labels)
+                            (map (lambda (arg-label)
+                                   (make-type-empty))
+                                 args-labels)))
+                      argss-labelss-around rest-arg?s-around)
+                 (map (lambda (exp-label)
+                        (make-type-cst 'top))
+                      exps-labels-around))
+                delta-flow))
+             (add-edge-and-propagate-set-through-edge case-lambda-label case-lambda-edge)
+             case-lambda-label)]
+          [(type-cons? type)
+           (let* ([car-label (reconstruct-graph-from-type
+                              sba-state
+                              (type-cons-car type) delta-flow delta-type label term #f #f)]
+                  [car-edge (create-simple-edge car-label)]
+                  [cdr-label (reconstruct-graph-from-type
+                              sba-state
+                              (type-cons-cdr type) delta-flow delta-type label term #f #f)]
+                  [cdr-edge (create-simple-edge cdr-label)]
+                  [cons-label (create-simple-prim-label term)]
+                  [cons-edge
+                   (cons
+                    (if contra-union?
+                        ; non-error-checking edge
+                        (lambda (out-label inflowing-label tunnel-label)
+                          ; cons sink => no use for out-label here
+                          (if (label-cons? inflowing-label)
+                              (and (add-edge-and-propagate-set-through-edge
+                                    (label-cons-car inflowing-label)
+                                    car-edge)
+                                   (add-edge-and-propagate-set-through-edge
+                                    (label-cons-cdr inflowing-label)
+                                    cdr-edge))
+                              #f))
+                        ; error checking edge
+                        (lambda (out-label inflowing-label tunnel-label)
+                          ; cons sink => no use for out-label here
+                          (if (label-cons? inflowing-label)
+                              (and (add-edge-and-propagate-set-through-edge
+                                    (label-cons-car inflowing-label)
+                                    car-edge)
+                                   (add-edge-and-propagate-set-through-edge
+                                    (label-cons-cdr inflowing-label)
+                                    cdr-edge))
+                              ; XXX should we do this here because we can, or in check-primitive-types
+                              ; because that's where it should be done... ? We don't have access to
+                              ; term anymore in check-primitive-types (yet)... See the commented call to
+                              ; associate-label-with-type below.
+                              (begin
+                                (set-error-for-label sba-state
+                                                     label
+                                                     'red
+                                                     (format "primitive expects argument of type <pair>; given ~a"
+                                                             (pp-type sba-state (get-type-from-label
+                                                                                 sba-state
+                                                                                 inflowing-label)
+                                                                      'type-cons)))
+                                #f))))
+                    ; cons sink
+                    (gensym))])
+             (unless contra-union?
+               (associate-label-with-type sba-state
+                                          cons-label
+                                          (make-type-cons
+                                           (make-type-cst 'top)
+                                           (make-type-cst 'top))
+                                          delta-flow))
+             (add-edge-and-propagate-set-through-edge cons-label cons-edge)
+             cons-label)]
+          [(type-vector? type)
+           (let* ([element-label (reconstruct-graph-from-type
+                                  sba-state
+                                  (type-vector-element type) delta-flow delta-type label term #f #f)]
+                  [element-edge (create-simple-edge element-label)]
+                  [vector-label (create-simple-prim-label term)]
+                  [vector-edge
+                   (cons
+                    (if contra-union?
+                        ; non-error-checking edge
+                        (lambda (out-label inflowing-label tunnel-label)
+                          ; vector sink => no use for out-label here
+                          (if (label-vector? inflowing-label)
+                              (add-edge-and-propagate-set-through-edge
+                               (label-vector-element inflowing-label)
+                               element-edge)
+                              #f))
+                        ; error checking edge
+                        (lambda (out-label inflowing-label tunnel-label)
+                          ; vector sink => no use for out-label here
+                          (if (label-vector? inflowing-label)
+                              (add-edge-and-propagate-set-through-edge
+                               (label-vector-element inflowing-label)
+                               element-edge)
+                              ; XXX should we do this here because we can, or in check-primitive-types
+                              ; because that's where it should be done... ? We don't have access to
+                              ; term anymore in check-primitive-types (yet)... See the commented call to
+                              ; associate-label-with-type below.
+                              (begin
+                                (set-error-for-label sba-state
+                                                     label
+                                                     'red
+                                                     (format "primitive expects argument of type <vector>; given ~a"
+                                                             (pp-type sba-state (get-type-from-label
+                                                                                 sba-state inflowing-label)
+                                                                      'type-vector)))
+                                #f))))
+                    ; vector sink
+                    (gensym))])
+             (unless contra-union?
+               (associate-label-with-type sba-state
+                                          vector-label
+                                          (make-type-vector (make-type-cst 'top))
+                                          delta-flow))
+             (add-edge-and-propagate-set-through-edge vector-label vector-edge)
+             vector-label)]
+          [(type-promise? type)
+           (let* ([element-label (reconstruct-graph-from-type
+                                  sba-state
+                                  (type-promise-value type) delta-flow delta-type label term #f #f)]
+                  [element-edge (create-simple-edge element-label)]
+                  [promise-label (create-simple-prim-label term)]
+                  [promise-edge
+                   (cons
+                    (if contra-union?
+                        ; non-error-checking edge
+                        (lambda (out-label inflowing-label tunnel-label)
+                          ; promise sink => no use for out-label here
+                          (if (label-promise? inflowing-label)
+                              (add-edge-and-propagate-set-through-edge
+                               (label-promise-value inflowing-label)
+                               element-edge)
+                              #f))
+                        ; error checking edge
+                        (lambda (out-label inflowing-label tunnel-label)
+                          ; promise sink => no use for out-label here
+                          (if (label-promise? inflowing-label)
+                              (add-edge-and-propagate-set-through-edge
+                               (label-promise-value inflowing-label)
+                               element-edge)
+                              ; XXX should we do this here because we can, or in check-primitive-types
+                              ; because that's where it should be done... ? We don't have access to
+                              ; term anymore in check-primitive-types (yet)... See the commented call to
+                              ; associate-label-with-type below.
+                              (begin
+                                (set-error-for-label sba-state
+                                                     label
+                                                     'red
+                                                     (format "primitive expects argument of type <promise>; given ~a"
+                                                             (pp-type sba-state (get-type-from-label
+                                                                                 sba-state inflowing-label)
+                                                                      'type-promise)))
+                                #f))))
+                    ; promise sink
+                    (gensym))])
+             (unless contra-union?
+               (associate-label-with-type sba-state
+                                          promise-label
+                                          (make-type-promise (make-type-cst 'top))
+                                          delta-flow))
+             (add-edge-and-propagate-set-through-edge promise-label promise-edge)
+             promise-label)]
+          [(type-flow-var? type)
+           (let* ([label&type^C (lookup-flow-var-in-env delta-flow type)]
+                  [label (car label&type^C)])
+             (unless contra-union?
+               (associate-label-with-type sba-state label (cdr label&type^C) delta-flow))
+             label)]
+          [(type-var? type)
+           (cdr (assq type delta-type))]
+          [(type-cst? type)
+           (let* ([cst-label (make-label-cst
+                              #f #f #f #f #t
+                              term
+                              (make-hash-table)
+                              (make-hash-table)
+                              ; the type parser ensures that type-cst is only created for
+                              ; non-list (i.e. atomic) types => 3, 'foo, 'int
+                              (type-cst-type type))])
+             ; propagation to such a label always works, so post checking is necessary
+             ; note that propagation always works because we don't do any type-based
+             ; filtering. This means that if the cst is inside a union, the propagation to
+             ; the union will always work, and the error detection will only happen after
+             ; the fact (which might be ok, since a label flowing into a cst doesn't go
+             ; anywhere else) XXX ?
+             (unless contra-union?
+               (associate-label-with-type sba-state cst-label type delta-flow))
+             cst-label)]
+          [(type-values? type)
+           (let* ([values-content-label (reconstruct-graph-from-type
+                                         sba-state
+                                         (type-values-type type) delta-flow delta-type label term #f #f)]
+                  [values-content-edge (create-simple-edge values-content-label)]
+                  [values-label (create-simple-prim-label term)]
+                  [values-edge
+                   (cons
+                    (if contra-union?
+                        ; non-error-checking edge
+                        (lambda (out-label inflowing-label tunnel-label)
+                          ; values sink => no use for out-label here
+                          (if (label-values? inflowing-label)
+                              ; the label-list of multiple values that might flow in might contain
+                              ; more than one value, but that's ok.
+                              (add-edge-and-propagate-set-through-edge
+                               (label-values-label inflowing-label)
+                               values-content-edge)
+                              ; we are in contravariant position, so the value x that flows out
+                              ; is unique and equivalent to (values x). So we simulate that. Note
+                              ; that multiple values are in fact label-lists of labels inside a
+                              ; values label, so we have to simulate the label-list part...
+                              (let* ([null-label (make-label-cst #f #f #f #f #t
+                                                                 term
+                                                                 (make-hash-table)
+                                                                 (make-hash-table)
+                                                                 '())]
+                                     [cons-label (make-label-cons #f #f #f #f #t
+                                                                  term
+                                                                  (make-hash-table)
+                                                                  (make-hash-table)
+                                                                  inflowing-label
+                                                                  null-label)])
+                                (initialize-label-set-for-value-source null-label)
+                                (initialize-label-set-for-value-source cons-label)
+                                (add-edge-and-propagate-set-through-edge
+                                 cons-label
+                                 values-content-edge))))
+                        ; error checking edge
+                        (lambda (out-label inflowing-label tunnel-label)
+                          ; values sink => no use for out-label here
+                          (if (label-values? inflowing-label)
+                              (add-edge-and-propagate-set-through-edge
+                               (label-values-label inflowing-label)
+                               values-content-edge)
+                              (let* ([null-label (make-label-cst #f #f #f #f #t
+                                                                 term
+                                                                 (make-hash-table)
+                                                                 (make-hash-table)
+                                                                 '())]
+                                     [cons-label (make-label-cons #f #f #f #f #t
+                                                                  term
+                                                                  (make-hash-table)
+                                                                  (make-hash-table)
+                                                                  inflowing-label
+                                                                  null-label)])
+                                (initialize-label-set-for-value-source null-label)
+                                (initialize-label-set-for-value-source cons-label)
+                                (add-edge-and-propagate-set-through-edge
+                                 cons-label
+                                 values-content-edge)))))
+                    ; vector sink
+                    (gensym))])
+             ; useless, when you think about it...
+             ;(unless contra-union?
+             ;  (associate-label-with-type values-label
+             ;                             (make-type-values (make-type-cst 'top))
+             ;                             delta-flow))
+             (add-edge-and-propagate-set-through-edge values-label values-edge)
+             values-label)]
+          [(type-union? type)
+           (let* ([elt-labels (map (lambda (elt-type)
+                                     ; reconstruct without error checking
+                                     ; XXX this does not work in the case of a flow var,
+                                     ; because associate-label-with-type has already been done.
+                                     (reconstruct-graph-from-type
+                                      sba-state
+                                      elt-type delta-flow delta-type label term #f #t))
+                                   (type-union-elements type))]
+                  [union-label (create-simple-prim-label term)]
+                  [union-label-in-between (create-simple-prim-label term)]
+                  [simple-non-error-checking-edge (create-simple-edge union-label-in-between)]
+                  [error-checking-edge
+                   (cons
+                    (lambda (out-label inflowing-label tunnel-label)
+                      (if ((car simple-non-error-checking-edge) out-label inflowing-label tunnel-label)
+                          (begin
+                            #t)
+                          (begin
+                            (set-error-for-label sba-state
+                                                 label
+                                                 'red
+                                                 (format "value ~a not a subtype of union ~a inside application of ~a"
+                                                         (pp-type sba-state (get-type-from-label
+                                                                             sba-state inflowing-label)
+                                                                  'type-union1)
+                                                         ;(syntax-object->datum
+                                                         ; (label-term inflowing-label))
+                                                         (pp-type sba-state type 'type-union2)
+                                                         (syntax-object->datum term)))
+                            ; stop error up-propagation
+                            #t)))
+                    (cdr simple-non-error-checking-edge))])
+             ; edges can't propagate multiple values
+             (for-each (lambda (elt-label)
+                         (add-edge-and-propagate-set-through-edge
+                          union-label-in-between
+                          (extend-edge-for-values sba-state (create-simple-edge elt-label))))
+                       elt-labels)
+             (if contra-union?
+                 ; union inside a union, so forget about checking at this level
+                 union-label-in-between
+                 (begin
+                   (add-edge-and-propagate-set-through-edge
+                    union-label
+                    (extend-edge-for-values sba-state error-checking-edge))
+                   union-label)))]
+          [(type-rec? type)
+           (let* ([clauses-vars&labels (map (lambda (type-var)
+                                              (cons type-var (create-simple-prim-label term)))
+                                            (type-rec-vars type))]
+                  [all-var-labels (append clauses-vars&labels delta-type)]
+                  [clauses-types-labels (map (lambda (clause-type)
+                                               (reconstruct-graph-from-type
+                                                sba-state
+                                                clause-type delta-flow all-var-labels label term #f #f))
+                                             (type-rec-types type))]
+                  [rec-body-label (reconstruct-graph-from-type
+                                   sba-state
+                                   (type-rec-body type) delta-flow all-var-labels label term #f #f)]
+                  [rec-label (create-simple-prim-label term)])
+             ; note: we never check whether all clauses are used. If they are not, they'll be
+             ; garbage collected after we return from here.
+             (for-each (lambda (clause-var-type&label clause-type-label)
+                         (add-edge-and-propagate-set-through-edge
+                          (cdr clause-var-type&label)
+                          (create-simple-edge clause-type-label)))
+                       clauses-vars&labels clauses-types-labels)
+             (unless contra-union?
+               (associate-label-with-type sba-state rec-body-label type delta-flow))
+             ; note: if type is the type corresponding, say, to a list, then if (list 1 2 3)
+             ; flows into rec-label, then rec-body-label will contain (list 1 2 3), (list 2 3),
+             ; (list 3), and ().
+             (add-edge-and-propagate-set-through-edge
+              rec-label
+              (extend-edge-for-values sba-state (create-simple-edge rec-body-label)))
+             rec-label)]
+          [(type-empty? type)
+           (let ([empty-label (create-simple-prim-label term)])
+             ; propagation to such a label always works, so post checking is necessary
+             ; note that propagation always works because we don't do any type-based
+             ; filtering.
+             (unless contra-union?
+               (associate-label-with-type sba-state empty-label type delta-flow))
+             empty-label)]
+          [else (error 'reconstruct-graph-from-type "unknown contravariant type for primitive ~a: ~a"
+                       (syntax-e term) type)]
+          )))
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; POST ANALYSIS TYPE CHECKING FOR PRIMITIVES
+  
+  ; sba-state label type (hash-table-of type-flow-var (cons label type)) -> void
+  ; Note that we don't store the type but only the handle.
+  (define (associate-label-with-type sba-state label type delta-flow)
+    (hash-table-put! (sba-state-label->types sba-state)
+                     label
+                     (cons (hc:hashcons-type (sba-state-hashcons-tbl sba-state)
+                                             (subst-vals/flow-vars type delta-flow))
+                           delta-flow)))
+  
+  ; sba-state -> void
+  ; post analysis checking of primitives inputs and outputs
+  (define (check-primitive-types sba-state)
+    (hash-table-for-each
+     (sba-state-label->types sba-state)
+     (lambda (label expected-type&delta)
+       (subtype sba-state
+                (get-type-from-label sba-state label)
+                (car expected-type&delta)
+                (cdr expected-type&delta) #t label))))
+  
+  ; (hashtableof symbol (cons (listof symbol) (top -> boolean)) symbol -> (listof symbol)
+  ; computes the complete (closed) list of subtypes for type-entry
+  (define (close-subtypes table type-name)
+    (let ([new-type-entry (hash-table-get table type-name cst:thunk-false)])
+      (if new-type-entry
+          (car new-type-entry)
+          (let* ([original-type-entry (cdr (assq type-name *basic-types*))]
+                 [new-type-entry
+                  (cons (list:foldl
+                         (lambda (type-name type-names-list-so-far)
+                           (merge-lists (close-subtypes table type-name)
+                                        type-names-list-so-far))
+                         ; not strickly necessary for the way we use the function later
+                         (list type-name)
+                         (car original-type-entry))
+                        (cadr original-type-entry))])
+            (hash-table-put! table type-name new-type-entry)
+            (car new-type-entry)))))
+  
+  (define/contract subt
+    (sba-state? hc:hashcons-table? handle? handle? any/c set? ;(listof (cons/p handle? handle?))
+                . -> . boolean?)
+    (let ([subtyping-table
+           (let ([table (make-hash-table)])
+             ; the entry for 'top should appear first. Everything will get
+             ; put into the table as we process this one.
+             (close-subtypes table (caar *basic-types*))
+             table)]
+          [memo-table (make-hash-table 'equal)])
+      (lambda (sba-state hashcons-tbl t1-handle t2-handle delta-flow trace)
+        (let* ([t1 (hc:get-type hashcons-tbl t1-handle)]
+               [t2 (hc:get-type hashcons-tbl t2-handle)]
+               [subt (lambda (handle1 handle2)
+                       (set-set trace (cons t1-handle t2-handle))
+                       ;		       (subt sba-state hashcons-tbl handle1 handle2 delta-flow (cons (cons t1-handle t2-handle) trace)))
+                       (let ([v (subt sba-state hashcons-tbl handle1 handle2 delta-flow trace)])
+                         (set-remove trace (cons t1-handle t2-handle))
+                         v))]
+               [get-list-of-handle
+                (lambda (handle)
+                  (let* ([fake-type-var (make-type-var (gensym) #f #f)]
+                         [type (make-type-rec  (list fake-type-var)
+                                               (list (make-type-union (list (make-type-cst '())
+                                                                            (make-type-cons handle fake-type-var))))
+                                               fake-type-var)])
+                    (hc:hashcons-type hashcons-tbl type)))])
+          (if (hash-table-get memo-table (cons t1-handle t2-handle) cst:thunk-false)
+              (hash-table-get memo-table (cons t1-handle t2-handle) cst:thunk-false)
+              (let ([subtype-value
+                     (or
+                      ; basic cases
+                      (or (= t1-handle t2-handle)
+                          (and (type-cst? t2) (eq? (type-cst-type t2) 'top))
+                          ;(and (type-cst? t1) (eq? (type-cst-type t1) 'bottom))
+                          (type-empty? t1) ; bottom
+                          (set-in? trace (cons t1-handle t2-handle)))
+                      ; constants
+                      (and (type-cst? t1) (type-cst? t2)
+                           (let* ([t1 (type-cst-type t1)]
+                                  [t2 (type-cst-type t2)]
+                                  [t2-entry (hash-table-get subtyping-table t2 cst:thunk-false)])
+                             (if t2-entry
+                                 ; t2 is a symbolic type (like number)
+                                 (if (or (memq t1 (car t2-entry)) ; for symbolic t1: real <= number
+                                         ((cdr t2-entry) t1))     ; for scheme t1: 3 <= number
+                                     #t #f)
+                                 ; t2 is an immediate type (like 5), and we already know t1 is not bottom
+                                 ; so t1 and t2 have to be equal
+                                 (eq? t1 t2))))
+                      ; cons
+                      (and (type-cons? t1) (type-cons? t2)
+                           (subt (type-cons-car t1) (type-cons-car t2))
+                           (subt (type-cons-cdr t1) (type-cons-cdr t2)))
+                      ; vector
+                      (and (type-vector? t1) (type-vector? t2)
+                           (subt (type-vector-element t1) (type-vector-element t2)))
+                      ; case-lambda
+                      (and (type-case-lambda? t1) (type-case-lambda? t2)
+                           (util:ormap4-vector
+                            (lambda (t1-rest-arg? t1-req-arg t1-args t1-exp)
+                              (if t1-rest-arg?
+                                  (util:andmap4-vector
+                                   (lambda (t2-rest-arg? t2-req-arg t2-args t2-exp)
+                                     (if t2-rest-arg?
+                                         ; both t1 and t2 have rest args
+                                         (or (and (< t1-req-arg t2-req-arg)
+                                                  (subt t1-exp t2-exp)
+                                                  ; contravariant
+                                                  (util:andmap2-vector-interval subt t2-args t1-args 0 t1-req-arg)
+                                                  (let ([t1-rest-arg (vector-ref t1-args t1-req-arg)])
+                                                    (and
+                                                     (util:andmap-vector-interval
+                                                      (lambda (t2-arg)
+                                                        ; contravariant
+                                                        (subt (get-list-of-handle t2-arg) t1-rest-arg))
+                                                      t2-args t1-req-arg t2-req-arg)
+                                                     (subt (vector-ref t2-args t2-req-arg) ; t2-rest-arg
+                                                           t1-rest-arg))))
+                                             (and (= t1-req-arg t2-req-arg)
+                                                  (subt t1-exp t2-exp)
+                                                  ; contravariant
+                                                  (util:andmap2-vector subt t2-args t1-args))
+                                             (and (> t1-req-arg t2-req-arg)
+                                                  (subt t1-exp t2-exp)
+                                                  ; contravariant
+                                                  (util:andmap2-vector-interval subt t2-args t1-args 0 t2-req-arg)
+                                                  (let ([t2-rest-arg (vector-ref t2-args t2-req-arg)])
+                                                    (and
+                                                     (util:andmap-vector-interval
+                                                      (lambda (t1-arg)
+                                                        (subt t2-rest-arg (get-list-of-handle t1-arg)))
+                                                      t1-args t2-req-arg t1-req-arg)
+                                                     (subt t2-rest-arg
+                                                           (vector-ref t1-args t1-req-arg) ; t1-rest-arg
+                                                           )))))
+                                         ;; t1 has rest-args, t2 has NO rest-args
+                                         (and (<= t1-req-arg t2-req-arg)
+                                              (subt t1-exp t2-exp)
+                                              ; t1 has a rest arg, t2 has a fixed number of args
+                                              ; so we need to check all the required args, and
+                                              ; check the rest arg specially, since the rest arg
+                                              ; of t1 is automatically wrapped inside a list.
+                                              ; contravariant
+                                              (util:andmap2-vector-interval subt t2-args t1-args 0 t1-req-arg)
+                                              ; contravariant
+                                              (subt (hc:hashcons-type hashcons-tbl
+                                                                      (list:foldr make-type-cons
+                                                                                  (make-type-cst '())
+                                                                                  (util:interval->list t2-args t1-req-arg
+                                                                                                       (vector-length t2-args))))
+                                                    (vector-ref t1-args t1-req-arg) ; rest arg
+                                                    ))))
+                                   (type-case-lambda-rest-arg?s t2)
+                                   (type-case-lambda-req-args t2)
+                                   (type-case-lambda-argss t2)
+                                   (type-case-lambda-exps t2))
+                                  ; t1 has no rest-args
+                                  (util:andmap4-vector
+                                   (lambda (t2-rest-arg? t2-req-arg t2-args t2-exp)
+                                     (if t2-rest-arg?
+                                         (and (>= t1-req-arg t2-req-arg)
+                                              (subt t1-exp t2-exp)
+                                              ; t1 has a fixed number of args, t2 has a rest arg
+                                              ; so we need to check all the required args, and
+                                              ; check the rest arg specially, since the rest arg
+                                              ; of t2 is automatically wrapped inside a list.
+                                              ; contravariant
+                                              (util:andmap2-vector-interval subt t2-args t1-args 0 t2-req-arg)
+                                              ; contravariant
+                                              (let ([t2-rest-arg (vector-ref t2-args t2-req-arg)])
+                                                (util:andmap-vector-interval
+                                                 (lambda (t1-arg)
+                                                   (subt t2-rest-arg (get-list-of-handle t1-arg)))
+                                                 t1-args t2-req-arg (vector-length t1-args))))
+                                         ; t1 and t2 have a fixed number of args
+                                         (and (= t1-req-arg t2-req-arg)
+                                              (subt t1-exp t2-exp)
+                                              ; contravariant
+                                              (util:andmap2-vector subt t2-args t1-args))))
+                                   (type-case-lambda-rest-arg?s t2)
+                                   (type-case-lambda-req-args t2)
+                                   (type-case-lambda-argss t2)
+                                   (type-case-lambda-exps t2))))
+                            (type-case-lambda-rest-arg?s t1)
+                            (type-case-lambda-req-args t1)
+                            (type-case-lambda-argss t1)
+                            (type-case-lambda-exps t1)))
+                      ; the order of the following two rules matters, because, for
+                      ; example: (union 1 2) is a subtype of (union 1 2 3), but is
+                      ; not a subtype of either 1, 2 or 3. On the other hand both 1
+                      ; and 2 are subtypes of (union 1 2 3), so if both t1 and t2
+                      ; are unions, we have to split t1 first.
+                      (and (type-union? t1)
+                           (andmap (lambda (t1-elt) (subt t1-elt t2-handle)) (type-union-elements t1)))
+                      (and (type-union? t2)
+                           (ormap (lambda (t2-elt) (subt t1-handle t2-elt)) (type-union-elements t2)))
+                      ; multiple values
+                      (and (type-values? t1) (type-values? t2)
+                           (subt (type-values-type t1) (type-values-type t2)))
+                      (and (type-promise? t1) (type-promise? t2)
+                           (subt (type-promise-value t1) (type-promise-value t2)))
+                      (and (type-struct-type? t1) (type-struct-type? t2)
+                           ; can't use strutural equivalence here because of genericity
+                           (or (eq? (type-struct-type-type-label t1) (type-struct-type-type-label t2))
+                               (let ([t1-parent-label (label-struct-type-parent
+                                                       (type-struct-type-type-label t1))])
+                                 (if t1-parent-label
+                                     (subt (get-type-from-label sba-state t1-parent-label)
+                                           t2-handle)
+                                     #f))))
+                      (and (type-struct-value? t1) (type-struct-type? t2)
+                           (subt (get-type-from-label sba-state (type-struct-value-type-label t1))
+                                 t2-handle))
+                      (and (type-flow-var? t2)
+                           (let ([label&type (lookup-flow-var-in-env delta-flow t2)])
+                             (subt t1 (hc:hashcons-type hashcons-tbl (cdr label&type)))))
+                      ;; Subt works on previously hashcons values,
+                      ;; i.e. all cycles are implicit in the table
+                      (and (or (type-flow-var? t1) (type-flow-var? t2)
+                               (type-var? t1) (type-var? t2)
+                               (type-rec? t1) (type-rec? t2)
+                               (type-scheme? t1) (type-scheme? t2))
+                           (error 'subt "Unexpected non-hashconsed types: ~a ~a" t1 t2)))])
+                (hash-table-put! memo-table (cons t1-handle t2-handle) subtype-value)
+                subtype-value))))))
+  
+  ; called when t2 is a (flow var free) type instead of a handle
+  (define/contract subtype-type
+    (sba-state? handle? hc:hashcons-type? any/c boolean? (union false/c label?) . -> . boolean?)
+    (lambda (sba-state t1-handle t2 delta-flow error? label)
+      (subtype sba-state t1-handle
+               (hc:hashcons-type (sba-state-hashcons-tbl sba-state) t2)
+               delta-flow error? label)))
+  
+  (define/contract subtype
+    (sba-state? handle? handle? any/c boolean? (union false/c label?) . -> . boolean?)
+    (lambda (sba-state t1-handle t2-handle delta-flow error? label)
+      (if (subt sba-state (sba-state-hashcons-tbl sba-state) t1-handle t2-handle delta-flow (set-make 'equal))
+          #t
+          (begin
+            (when error?
+              (set-error-for-label sba-state
+                                   label
+                                   'red
+                                   (format "~a not a subtype of ~a"
+                                           (pp-type sba-state t1-handle 'subtype)
+                                           (pp-type sba-state t2-handle delta-flow))))
+            #f))))
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; GUI INTERFACE
+  
+  ; sba-state -> symbol
+  (define (create-type-var-name sba-state)
+    (let ([new-counter (sba-state-type-var-counter sba-state)])
+      (set-sba-state-type-var-counter! sba-state (add1 new-counter))
+      (string->symbol (string-append "a" (number->string new-counter)))))
+  
+  ; label -> positive-int
+  ; returns start location of term associated with label
+  (define (get-mzscheme-position-from-label label)
+    (syntax-position (label-term label)))
+  
+  ; label -> boolean
+  (define (is-label-atom? label)
+    (let ([stx-l (syntax-e (label-term label))])
+      (or (not (pair? stx-l)) ; identifier
+          (let ([term-type (syntax-e (car stx-l))])
+            (or (eq? term-type '#%datum)
+                (eq? term-type '#%top)
+                (eq? term-type 'quote))))))
+  
+  ; label -> (union number #f)
+  (define (get-span-from-label label)
+    (syntax-span (label-term label)))
+  
+  ; sba-state label (union 'red 'green 'orange) string -> void
+  (define (set-error-for-label sba-state label gravity message)
+    (err:error-table-set (sba-state-errors sba-state)
+                         (list label)
+                         gravity
+                         message))
+  
+  ; sba-state label -> (listof sba-error)
+  ; extracts error messages.
+  (define (get-errors-from-label sba-state label)
+    (err:error-table-get (sba-state-errors sba-state) label))
+  
+  ; label -> exact-non-negative-integer
+  (define (get-source-from-label label)
+    (syntax-source (label-term label)))
+  
+  ; label sba-state -> void
+  (define (add-type-var-to-label label sba-state)
+    (unless (label-type-var label)
+      (set-label-type-var! label (make-type-var (create-type-var-name sba-state) #f #f))))
+  
+  ; label set -> void
+  ; if the reachable set has already been computed, re-use it, otherwise compute it
+  ; (unless we detected a cycle).
+  (define (reachL label set)
+    (if (and (label-type-var label)
+             (type-var-reach (label-type-var label)))
+        (set-union set (type-var-reach (label-type-var label)) 'first)
+        (unless (set-in? set label)
+          (set-set set label)
+          (reachU label set))))
+  
+  ; label set -> void
+  ; a label for a value constructor has itself in its own value set, so reachL above might
+  ; already have put that label in set, but a simple label does not appear in its own set
+  ; so we still have to add the content of its set to set.  Hence the #f below.
+  (define (reachU label set)
+    (hash-table-for-each (label-set label)
+                         (lambda (value-label arrows)
+                           (set-set set value-label #f)
+                           (reachT value-label set))))
+  ; label set -> void
+  (define (reachT label set)
+    (cond
+      ;[(label-cst? label) cst:void]
+      [(label-cons? label) (begin (reachL (label-cons-car label) set)
+                                  (reachL (label-cons-cdr label) set))]
+      [(label-vector? label) (reachL (label-vector-element label) set)]
+      [(label-promise? label) (reachL (label-promise-value label) set)]
+      [(label-values? label) (reachL (label-values-label label) set)]
+      [(label-case-lambda? label) (for-each (lambda (args-labels exp-label)
+                                              (for-each (lambda (l) (reachL l set)) args-labels)
+                                              (reachL exp-label set))
+                                            (label-case-lambda-argss label)
+                                            (label-case-lambda-exps label))]
+      [(label-struct-value? label) (begin (reachL (label-struct-value-type label) set)
+                                          (for-each (lambda (l) (reachL l set)) (label-struct-value-fields label)))]
+      ;[(label-struct-type? label) cst:void]
+      ;[else cst:void]
+      ))
+  
+  ; label sba-state -> (set-of label)
+  ; reachable lables from a given label
+  ; we know the label has a type var because add-type-var-to-label has been called
+  ; already in get-type-from-label.
+  ; Note that this is the only place where we set the type-var-reach, so if reachL above
+  ; find a set, we know that set already contains everything we need.
+  (define (reachable-labels-from-label label)
+    (let ([set (type-var-reach (label-type-var label))])
+      (if set
+          set
+          (let ([set (set-make)])
+            (reachL label set)
+            (set-type-var-reach! (label-type-var label) set)
+            set))))
+  
+  ; label -> (union type-var handle)
+  ; the label better have a type-var...
+  (define (get-handle-or-type-var label)
+    (let* ([type-var (label-type-var label)]
+           [handle (type-var-handle type-var)])
+      (if handle
+          ;(begin (printf ".")
+          handle
+          ;)
+          type-var)))
+  
+  ; label (listof labels) -> type-rec
+  (define (typeL label reachable-labels)
+    (make-type-rec (map label-type-var reachable-labels)
+                   (map typeU reachable-labels)
+                   (get-handle-or-type-var label)))
+  
+  ; label -> type-union
+  ; label-set should move from a hash-table to an assoc-set, then we can use
+  ; assoc-set-cardinality instead of going through the list twice.
+  (define (typeU label)
+    (let* ([union-content (hash-table-map (label-set label) (lambda (label arrows) (typeT label)))]
+           [union-length (length union-content)])
+      (cond
+        [(= union-length 0) (make-type-empty)]
+        [(= union-length 1) (car union-content)]
+        [else (make-type-union union-content)])))
+  
+  ; label -> type
+  (define (typeT label)
+    (cond
+      [(label-cst? label) (make-type-cst (label-cst-value label))]
+      [(label-cons? label) (make-type-cons (get-handle-or-type-var (label-cons-car label))
+                                           (get-handle-or-type-var (label-cons-cdr label)))]
+      [(label-vector? label) (make-type-vector (get-handle-or-type-var (label-vector-element label)))]
+      [(label-promise? label) (make-type-promise (get-handle-or-type-var (label-promise-value label)))]
+      [(label-values? label) (make-type-values (get-handle-or-type-var (label-values-label label)))]
+      [(label-case-lambda? label) (make-type-case-lambda (label-case-lambda-rest-arg?s label)
+                                                         (label-case-lambda-req-args label)
+                                                         (map (lambda (args)
+                                                                (map get-handle-or-type-var args))
+                                                              (label-case-lambda-argss label))
+                                                         (map get-handle-or-type-var (label-case-lambda-exps label)))]
+      [(label-struct-value? label) (make-type-struct-value (label-struct-value-type label)
+                                                           (map get-handle-or-type-var (label-struct-value-fields label)))]
+      [(label-struct-type? label) (make-type-struct-type label)]
+      [else (error 'typeT "unknown label: ~a" label)]))
+  
+  ; sba-state label -> type
+  ; computes type for label, computes the corresponding handle, and memoize it
+  (define (get-type-from-label sba-state label)
+    (add-type-var-to-label label sba-state)
+    (or (type-var-handle (label-type-var label))
+        (let* (;[_ (begin (print-struct #t)(printf "T: ~a ~a ~a " (type-var-name (label-type-var label))
+               ;                                   (syntax-position (label-term label))
+               ;                                   (syntax-object->datum (label-term label))))]
+               ;[start (current-milliseconds)]
+               [reachable-labels (set-map (reachable-labels-from-label label)
+                                          (lambda (l) (add-type-var-to-label l sba-state) l))]
+               ;[_ (begin (print-struct #t)(printf "R: ~a~n" (map (lambda (l) (type-var-name (label-type-var l))) reachable-labels)))]
+               ;[_ (printf "~a " (- (current-milliseconds) start))]
+               ;[start (current-milliseconds)]
+               [reconstructed-type (typeL label reachable-labels)]
+               ;[_ (begin (print-struct #t)(printf "T: ~a~n" (ppp-type reconstructed-type 'blah)))]
+               ;[_ (printf " ~a~n" (- (current-milliseconds) start))]
+               ;[start (current-milliseconds)]
+               [handle (hc:hashcons-type (sba-state-hashcons-tbl sba-state) reconstructed-type)]
+               ;[_ (printf "HC-Time= ~a~n" (- (current-milliseconds) start))]
+               )
+          ; XXX memoization
+          (set-type-var-handle! (label-type-var label) handle)
+          handle)))
+  
+  ; type (union (hash-table-of type-flow-var (cons label type)) symbol) -> string
+  ; type pretty printer
+  ; delta-flow is the flow variable environment, or a symbol if no flow environment
+  ; was available at the time of the call.
+  (define (pp-type sba-state type delta-flow)
+    (let ([pretty-string (hc:handle->string (sba-state-hashcons-tbl sba-state) type
+                                            (lambda (h1 h2)
+                                              (subtype sba-state h1 h2 #f #f #f)))
+                         ])
+      ;(printf "H: ~a~nP: ~a~n~n" type foo)
+      pretty-string))
+  
+  ;  (require (prefix string: (lib "string.ss")))
+  ;  (define (ppp-type type delta-flow)
+  ;      (cond
+  ;        [(type-empty? type) "_"]
+  ;        [(type-cst? type)
+  ;         ; can be a complex sexp if (quote sexp) is in the input
+  ;         (string:expr->string (type-cst-type type))]
+  ;        ;      (let ([val (type-cst-type type)])
+  ;        ;        (cond
+  ;        ;          [(number? val) (number->string val)]
+  ;        ;          [(symbol? val) (symbol->string val)]
+  ;        ;          [(string? val) (string-append "\"" val "\"")]
+  ;        ;          [(void? val) "void"]
+  ;        ;          [else (error 'ppp-type "unknown datum: ~a" val)]))]
+  ;        [(type-cons? type)
+  ;         (string-append "(cons "
+  ;                        (ppp-type (type-cons-car type) delta-flow) " "
+  ;                        (ppp-type (type-cons-cdr type) delta-flow) ")")]
+  ;        [(type-vector? type)
+  ;         (string-append "(vector " (ppp-type (type-vector-element type) delta-flow) ")")]
+  ;        [(type-promise? type)
+  ;         (string-append "(promise "
+  ;                        ; skipping the thunk inside the promise (we know it's always a
+  ;                        ; thunk because delay is a macro...) Note that the promise might
+  ;                        ; be empty, for now, so we have to test that...
+  ;                        (let ([promise-value-type (type-promise-value type)])
+  ;                          (if (type-case-lambda? promise-value-type)
+  ;                              (ppp-type (car (type-case-lambda-exps promise-value-type)) delta-flow)
+  ;                              (ppp-type promise-value-type delta-flow)))
+  ;                        ")")]
+  ;        [(type-case-lambda? type)
+  ;         (string-append
+  ;          "(case-lambda "
+  ;          (list:foldr
+  ;           (lambda (rest-arg? formal-args-types body-exp-type str)
+  ;             (string-append
+  ;              "["
+  ;              (list:foldr
+  ;               (lambda (formal-arg-type str)
+  ;                 (string-append
+  ;                  (ppp-type formal-arg-type delta-flow)
+  ;                  " "
+  ;                  str))
+  ;               ""
+  ;               formal-args-types)
+  ;              (if rest-arg?
+  ;                  "*-> "
+  ;                  "-> ")
+  ;              (ppp-type body-exp-type delta-flow)
+  ;              "]"
+  ;              ;(if (string=? str "")
+  ;              ;  ""
+  ;              ;  " ")
+  ;              str))
+  ;           ""
+  ;           (type-case-lambda-rest-arg?s type)
+  ;           (type-case-lambda-argss type)
+  ;           (type-case-lambda-exps type))
+  ;          ")")]
+  ;        [(type-var? type)
+  ;         (symbol->string (type-var-name type))]
+  ;        [(type-flow-var? type)
+  ;         (error 'ppp-type "flow var: ~a~n" (type-flow-var-name type))
+  ;         (ppp-type (cdr (lookup-flow-var-in-env delta-flow type)) delta-flow)]
+  ;        [(type-union? type)
+  ;         (string-append
+  ;          "(union "
+  ;          (list:foldr
+  ;           (lambda (union-element str)
+  ;             (string-append
+  ;              (ppp-type union-element delta-flow)
+  ;              (if (string=? str ")")
+  ;                  ""
+  ;                  " ")
+  ;              str))
+  ;           ")"
+  ;           (type-union-elements type)))]
+  ;        [(type-values? type)
+  ;         (let ([values-type (type-values-type type)])
+  ;           (cond
+  ;             [(type-empty? values-type)
+  ;              (ppp-type values-type delta-flow)]
+  ;             [(and (type-cst? values-type) (eq? (type-cst-type values-type) 'top))
+  ;              (ppp-type values-type delta-flow)]
+  ;             [else
+  ;              (let* ([values-types-list (type-list-map cst:id (type-values-type type))]
+  ;                     [values-types-list-length (length values-types-list)])
+  ;                (cond
+  ;                  [(zero? values-types-list-length)
+  ;                   (ppp-type (make-type-empty) delta-flow)]
+  ;                  [(= values-types-list-length 1)
+  ;                   (ppp-type (car values-types-list) delta-flow)]
+  ;                  [else (string-append
+  ;                         "(values "
+  ;                         (list:foldr
+  ;                          (lambda (type str)
+  ;                            (string-append (ppp-type type delta-flow)
+  ;                                           (if (string=? str ")")
+  ;                                               ""
+  ;                                               " ")
+  ;                                           str))
+  ;                          ")"
+  ;                          values-types-list))]))]))]
+  ;        [(type-rec? type)
+  ;         (string-append
+  ;          "(rec-type ("
+  ;          (list:foldr
+  ;           (lambda (var type str)
+  ;             (string-append
+  ;              "["
+  ;              (symbol->string (type-var-name var))
+  ;              " "
+  ;              ; poor man's type beautifier
+  ;              (if (and (type-union? type)
+  ;                       (= (length (type-union-elements type)) 2)
+  ;                       (or (and (type-cst? (car (type-union-elements type)))
+  ;                                (null? (type-cst-type (car (type-union-elements type))))
+  ;                                (type-cons? (cadr (type-union-elements type)))
+  ;                                (type-var? (type-cons-cdr (cadr (type-union-elements type))))
+  ;                                (eq? (type-var-name (type-cons-cdr (cadr (type-union-elements type))))
+  ;                                     (type-var-name var)))
+  ;                           (and (type-cst? (cadr (type-union-elements type)))
+  ;                                (null? (type-cst-type (cadr (type-union-elements type))))
+  ;                                (type-cons? (car (type-union-elements type)))
+  ;                                (type-var? (type-cons-cdr (car (type-union-elements type))))
+  ;                                (eq? (type-var-name (type-cons-cdr (car (type-union-elements type))))
+  ;                                     (type-var-name var)))))
+  ;                  (string-append
+  ;                   "(listof "
+  ;                   (ppp-type (if (type-cst? (car (type-union-elements type)))
+  ;                                (type-cons-car (cadr (type-union-elements type)))
+  ;                                (type-cons-car (car (type-union-elements type))))
+  ;                            delta-flow)
+  ;                   ")")
+  ;                  (ppp-type type delta-flow))
+  ;              (if (string=? str ") ")
+  ;                  "]"
+  ;                  "] ")
+  ;              str))
+  ;           ") "
+  ;           (type-rec-vars type)
+  ;           (type-rec-types type))
+  ;          (ppp-type (type-rec-body type) delta-flow)
+  ;          ")")]
+  ;        [(type-struct-value? type)
+  ;         (string-append
+  ;          "#(struct:"
+  ;          (symbol->string (label-struct-type-name (type-struct-value-type-label type)))
+  ;          " "
+  ;          (list:foldr
+  ;           (lambda (elt-type str)
+  ;             (string-append
+  ;              (ppp-type elt-type delta-flow)
+  ;              (if (string=? str ")")
+  ;                  ""
+  ;                  " ")
+  ;              str))
+  ;           ")"
+  ;           (type-struct-value-types type)))]
+  ;        [(type-struct-type? type)
+  ;         (string-append
+  ;          "#<struct-type:"
+  ;          (symbol->string (label-struct-type-name (type-struct-type-type-label type)))
+  ;          ">")]
+  ;        [else (error 'ppp-type "unknown type: ~a" type)]))
+  
+  
+  ; label (listof label) -> (listof label)
+  ; returns list of labels from which labels in label's set went in
+  ; the trace is necessary to prevent the search for original parents to loop forever when
+  ; inside recursive code generated by a macro. Despite that the search might still use
+  ; exponential time when only using the trace because it explores all possibles paths at
+  ; all possible labels when exploring the graph recursively. The running time is tremendously
+  ; helped by adding the memoization: we compute the result set for a given label only once
+  ; and always reuse that result in the future without ever searching the piece of graph
+  ; behind the label again.
+  ; Note: could probably be made even faster if the trace was a set and we kept it around
+  ; until the final result is computed, so as not to re-explore pieces of graphs we have
+  ; just seen but are reaching through another path.  Should be good enough for noe since
+  ; we memoize the final result anyway.
+  (define (get-parents-from-label label trace)
+    (if (label-parents label)
+        (label-parents label)
+        (if (memq label trace)
+            '()
+            (let ([result (set-make)])
+              (for-each
+               (lambda (unfiltered-parents-for-current-set-element)
+                 (let* ([direct-parents-without-primitive-labels
+                         (list:filter (lambda (label)
+                                        (not (label-prim? label)))
+                                      unfiltered-parents-for-current-set-element)]
+                        [direct-or-indirect-original-parents
+                         (list:foldr
+                          (lambda (direct-parent original-parents-so-far)
+                            (if (gui-registerable? direct-parent)
+                                (cons direct-parent original-parents-so-far)
+                                (merge-lists (get-parents-from-label direct-parent (cons label trace))
+                                             original-parents-so-far)))
+                          '()
+                          direct-parents-without-primitive-labels)])
+                   (for-each (lambda (parent)
+                               (set-set result parent #f))
+                             direct-or-indirect-original-parents)))
+               (hash-table-map (label-set label)
+                               (lambda (label arrows)
+                                 (arrows-in arrows))))
+              (let ([final-result (set-map result cst:id)])
+                (set-label-parents! label final-result)
+                final-result)))))
+  
+  ; label (listof label) -> (listof label)
+  ; should be abstracted with the above...
+  ; differences are arrows-in vs arrows-out and
+  ; label-parents/set-label-parents! vs label-children/set-label-children!
+  (define (get-children-from-label label trace)
+    (if (label-children label)
+        (label-children label)
+        (if (memq label trace)
+            '()
+            (let ([result (set-make)])
+              (for-each
+               (lambda (unfiltered-children-for-current-set-element)
+                 (let* ([direct-children-without-primitive-labels
+                         (list:filter (lambda (label)
+                                        (not (label-prim? label)))
+                                      unfiltered-children-for-current-set-element)]
+                        [direct-or-indirect-original-children
+                         (list:foldr
+                          (lambda (direct-child original-children-so-far)
+                            (if (gui-registerable? direct-child)
+                                (cons direct-child original-children-so-far)
+                                (merge-lists (get-children-from-label direct-child (cons label trace))
+                                             original-children-so-far)))
+                          '()
+                          direct-children-without-primitive-labels)])
+                   (for-each (lambda (child)
+                               (set-set result child #f))
+                             direct-or-indirect-original-children)))
+               (hash-table-map (label-set label)
+                               (lambda (label arrows)
+                                 (arrows-out arrows))))
+              (let ([final-result (set-map result cst:id)])
+                (set-label-children! label final-result)
+                final-result)))))
+  
+  
+  ; (listof label) -> (listof (list label label string))
+  ; not really fast but good enough for now.
+  ; XXX should combine this with the above get-parents/children
+  (define (get-arrows-from-labels labels)
+    (delete-duplicates
+     (append! (apply append! (map (lambda (label)
+                                    (map (lambda (parent)
+                                           (list parent label "blue"))
+                                         (list:filter (lambda (parent)
+                                                        (not (memq parent labels)))
+                                                      (get-parents-from-label label '()))))
+                                  labels))
+              (apply append! (map (lambda (label)
+                                    (map (lambda (child)
+                                           (list label child "blue"))
+                                         (list:filter (lambda (child)
+                                                        (not (memq child labels)))
+                                                      (get-children-from-label label '()))))
+                                  labels)))))
+  
+  ; (listof (cons top (cons top (listof top)))) -> (listof (cons top (cons top (listof top))))
+  (define (delete-duplicates l)
+    (if (null? l)
+        l
+        (let ([elt (car l)])
+          (cons elt
+                (delete-duplicates
+                 (let ([elt-s (car elt)]
+                       [elt-e (cadr elt)])
+                   (list:filter (lambda (other-elt)
+                                  (or (not (eq? elt-s (car other-elt)))
+                                      (not (eq? elt-e (cadr other-elt)))))
+                                (cdr l))))))))
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; DRIVER
+  
+  ;    ; port value -> void
+  ;    (define (sba-driver port source)
+  ;      (let ([start (current-milliseconds)])
+  ;        (read-and-analyze port source)
+  ;        (check-primitive-types)
+  ;        (printf "time: ~a ms~n" (- (current-milliseconds) start)))
+  ;      )
+  ;  
+  ;    ; port value -> void
+  ;    ; read and analyze, one syntax object at a time
+  ;    (define (read-and-analyze port source)
+  ;      (let ([stx-obj (read-syntax source port)])
+  ;        ;(unless (eof-object? stx-obj)
+  ;        ;  (begin (printf "sba-driver in: ~a~n" (syntax-object->datum stx-obj))
+  ;        ;         (printf "sba-driver analyzed: ~a~n~n" (syntax-object->datum (expand stx-obj)))
+  ;        ;         (printf "sba-driver out: ~a~n~n" (create-label-from-term sba-state (expand stx-obj) '() #f)))
+  ;        ;  (read-and-analyze port source))))
+  ;        (if (eof-object? stx-obj)
+  ;          '()
+  ;          (cons (create-label-from-term sba-state (expand stx-obj) '() #f)
+  ;                (read-and-analyze port source)))))
+  ;    
+  ;    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; PERFORMANCE TEST
+  ;    
+  ;    ; (: test-i (nothing -> void))
+  ;    ; parse expression interactively
+  ;    (define (test-i)
+  ;      (sba-driver (current-input-port) 'interactive))
+  ;    
+  ;    ; (: test-f (string -> (listof Ast)))
+  ;    (define (test-f filename)
+  ;      (let ([port (open-input-file filename)])
+  ;        (sba-driver port filename)
+  ;        (close-input-port port)))
+  ;    
+  ;  (let* ([path (build-path (collection-path "mrflow") "tests")]
+  ;         [files (list:filter (lambda (file)
+  ;                               (and (> (string-length file) 3)
+  ;                                    (string=? "test-real"
+  ;                                              (substring file 0 9))
+  ;                                    (string=? "test-realbig"
+  ;                                              (substring file 0 12))))
+  ;                             (list:quicksort 
+  ;                              (directory-list path)
+  ;                              string<=?)
+  ;                             )]
+  ;         )
+  ;    (initialize-primitive-type-schemes XXX)
+  ;    (for-each (lambda (file)
+  ;                (printf "~a: " file)
+  ;                (test-f (build-path path file))
+  ;                ;		  (test-f file)
+  ;                )
+  ;              files))
+  
+  (define/contract subst-vals/flow-vars (type? any/c . -> . type?)
+    (lambda (type delta-flow)
+      (let subst ([type type])
+        (match type
+          [(? handle? type) type]
+          [($ type-case-lambda rest-arg?s req-args argss exps)
+           (let* ([argss ((if (list? argss) util:map2deep util:for-each-vov!) subst argss)]
+                  [exps ((if (list? exps) map util:for-each-vector!) subst exps)])
+             (make-type-case-lambda rest-arg?s req-args argss exps))]
+          [($ type-cons hd tl)
+           (make-type-cons (subst hd) (subst tl))]
+          [($ type-cst ty) type]
+          [($ type-empty) type]
+          [($ type-promise value)
+           (make-type-promise (subst value))]
+          [($ type-rec vars types body)
+           (make-type-rec vars (map subst types) (subst body))]
+          [($ type-struct-type label) type]
+          [($ type-struct-value label types)
+           (make-type-struct-value label (map subst types))]
+          [($ type-union elements)
+           (make-type-union (map subst elements))]
+          [($ type-values type)
+           (make-type-values (subst type))]
+          [($ type-var name reach handle) type]
+          [($ type-vector element)
+           (make-type-vector (subst element))]
+          [($ type-flow-var name) (cdr (lookup-flow-var-in-env delta-flow type))]
+          [_ (error 'subst-vals/flow-vars "Unmatched type ~a" type)]))))
+  
+  ) ; end module constraints-gen-and-prop
diff --git a/collects/mrflow/dfa.ss b/collects/mrflow/dfa.ss
new file mode 100644
index 0000000000..faa53e6fa4
--- /dev/null
+++ b/collects/mrflow/dfa.ss
@@ -0,0 +1,1024 @@
+(module dfa (lib "mrflow.ss" "mrflow")
+  (require (lib "match.ss")
+           (lib "pretty.ss")
+           (lib "etc.ss")
+           (prefix list: (lib "list.ss"))
+           (prefix cst: "constants.ss")
+           
+           "set-hash.ss"
+           "types.ss"
+           "util.ss"
+           "env.ss"
+           
+           (lib "class.ss"))
+  
+  (provide
+   (struct dfa (stnum->state))
+   
+   (struct state (number))
+   
+   ;; All base types i.e. type-cst, type-empty, struct-type-states are always handle states
+   (struct handle-state (handle))
+   (struct cons-state (car cdr))
+   (struct case-lambda-state (rest-arg?s req-args argss exps))
+   (struct promise-state (value))
+   (struct struct-value-state (label types))
+   (struct union-state (elements))
+   (struct values-state (type))
+   (struct vector-state (element))
+   
+   state-number?   
+   dfa-state->list
+   dfa->list
+   
+   greatest-handle
+   get-ordered-states
+   get-state-numbers
+   get-states
+   get-dfa-size
+   
+   create-dfa-from-type
+   minimize-dfa
+   
+   ;; debug
+   all-handles-referenced?
+   )
+  
+  ;; 
+  ;; States
+  ;;
+  (define state-number? natural?)
+  
+  (define-struct state (number) (make-inspector))
+  
+  ;; All base types i.e. type-cst, type-empty, struct-type-states are always handle states
+  (define-struct (handle-state state) (handle) (make-inspector))
+  (define-struct (cons-state state) (car cdr) (make-inspector))
+  ; case-lambda-states has vectors for all fields, in contrast union-states and 
+  ;   struct-value-states both use lists.
+  (define-struct (case-lambda-state state)
+    (rest-arg?s   ; (vectorof boolean)
+     req-args     ; (vectorof natural)
+     argss        ; (vectorof (vectorof any))
+     exps)        ; (vectorof any)
+    (make-inspector))
+  (define-struct (promise-state state) (value) (make-inspector))
+  (define-struct (struct-value-state state) (label types) (make-inspector))
+  (define-struct (union-state state) (elements) (make-inspector))
+  (define-struct (values-state state) (type) (make-inspector))
+  (define-struct (vector-state state) (element) (make-inspector))
+  
+  ;;
+  ;; DFAs
+  ;;
+  (define-struct dfa (stnum->state canonical-ordering))
+  (set! make-dfa
+        (let ([old-make-dfa make-dfa])
+          (opt-lambda ([ordering #f]) (old-make-dfa (make-hash-table) ordering))))
+  
+  (define/contract make-ordered-dfa ((listof state?) . -> . dfa?)
+    (lambda (states)
+      (let* ([dfa (make-dfa)]
+             [stnum->state (dfa-stnum->state dfa)]
+             [ordered-stnums (map (lambda (state)
+                                    (let ([stnum (state-number state)])
+                                      (hash-table-put! stnum->state stnum state)
+                                      stnum))
+                                  states)])
+        (set-dfa-canonical-ordering! dfa ordered-stnums)
+        dfa)))
+  
+  (define/contract get-dfa-size (dfa? . -> . natural?)
+    (lambda (dfa)
+      (let ([size 0])
+        (hash-table-for-each (dfa-stnum->state dfa) (lambda (stnum state) (set! size (add1 size))))
+        size)))
+  
+  (define/contract has-state-number? (dfa? state-number? . -> . boolean?)
+    (lambda (dfa state-number)
+      (if (hash-table-get (dfa-stnum->state dfa) state-number cst:thunk-false) #t #f)))
+  
+  (define/contract maybe-add-state! (dfa? state? . -> . void?)
+    (lambda (dfa state)
+      (let ([stnum->state (dfa-stnum->state dfa)]
+            [stnum (state-number state)])
+        (unless (hash-table-has-key? stnum->state stnum)
+          (hash-table-put! stnum->state stnum state)))))
+  
+  (define/contract lookup (dfa? state-number? . -> . state?)
+    (lambda (dfa state-number)
+      (hash-table-get (dfa-stnum->state dfa) state-number)))
+  
+  (define/contract greatest-handle (dfa? . -> . (union false/c handle?))
+    (lambda (dfa)
+      (let ([greatest-handle -1])
+        (hash-table-for-each (dfa-stnum->state dfa)
+                             (lambda (stnum state)
+                               (when (and (handle-state? state) (> (handle-state-handle state) greatest-handle))
+                                 (set! greatest-handle (handle-state-handle state)))))
+        (if (= greatest-handle -1) #f greatest-handle))))
+  
+  (define/contract get-ordered-states (dfa? . -> . (listof state?))
+    (lambda (dfa)
+      (map (lambda (stnum) (lookup dfa stnum)) (dfa-canonical-ordering dfa))))
+  
+  (define/contract get-states (dfa? . -> . (listof state?))
+    (lambda (dfa)
+      (hash-table-map (dfa-stnum->state dfa) (lambda (stnum state) state))))
+  
+  (define/contract get-state-numbers (dfa? . -> . (listof state-number?))
+    (lambda (dfa)
+      (hash-table-map (dfa-stnum->state dfa) (lambda (stnum state) stnum))))
+  
+  ;; When this function is called all of the label types in present
+  ;; must belong to a strongly connected graph.  This works by first
+  ;; annotating all label types with a state number, variables and
+  ;; base types are not given a state number. Then the graph is
+  ;; traversed again with a type environment. When a rec-type is
+  ;; encountered the variable/state bindings are added to the type
+  ;; environment. When a variable is encountered its state looked up.
+  ;; Labeled states are created w/ the states of their children and
+  ;; added to the DFA.
+  ;;
+  ;; tenv : tvar -> handle ... if have a handle it may not have a state in the dfa
+  ;; senv : tvar -> state
+  (define/contract create-dfa-from-type
+    ((type-rec? tenv?) . ->d* .
+                       (lambda (type tenv)
+                         (unless (type-var? (type-rec-body type))
+                           (error 'create-dfa-from-type
+                                  "type-rec should have type-var for body"))
+                         (for-each (lambda (type)
+                                     (when (type-var? type)
+                                       (error 'create-dfa-from-type "DFA has variable on right side of binder"))
+                                     (when (and (type-union? type) (andmap type-var? (type-union-elements type)))
+                                       (error 'create-dfa-from-type "DFA has union with only variables on right side of binder")))
+                                   (type-rec-types type))
+                         (values dfa? (listof state-number?))))
+    (lambda (type var->handle)
+      (let* ([dfa (make-dfa)]
+             [annotations (make-hash-table 'equal)]
+             [add-annotation!
+              (let ([ann -1])
+                (lambda (type)
+                  (set! ann (add1 ann))
+                  (hash-table-put! annotations type ann)))]
+             [add-state! (lambda (state)
+                           (maybe-add-state! dfa state)
+                           (state-number state))]
+             [get-annotation
+              (lambda (type) (hash-table-get annotations type))]
+             [maybe-get-annotation
+              (lambda (type) (hash-table-get annotations type cst:thunk-false))])
+        (letrec ([annotate
+                  (lambda (type)
+                    (unless (maybe-get-annotation type)
+                      (cond
+                        [(handle? type)
+                         (add-annotation! type)]
+                        [(type-cons? type)
+                         (annotate (type-cons-car type))
+                         (annotate (type-cons-cdr type))
+                         (add-annotation! type)]
+                        [(type-case-lambda? type)
+                         (for-each-vov (lambda (ty) (annotate ty)) (type-case-lambda-argss type))
+                         (for-each-vector (lambda (ty) (annotate ty)) (type-case-lambda-exps type))
+                         (add-annotation! type)]
+                        [(type-promise? type)
+                         (annotate (type-promise-value type))
+                         (add-annotation! type)]    
+                        [(type-rec? type) 
+                         (for-each (lambda (var ty)
+                                     (or (maybe-lookup-symbol var->handle (type-var-name var)) (annotate ty)))
+                                   (type-rec-vars type) (type-rec-types type))
+                         (annotate (type-rec-body type))]
+                        [(type-struct-value? type)
+                         (for-each annotate (type-struct-value-types type))
+                         (add-annotation! type)]
+                        [(type-union? type)
+                         (for-each annotate (type-union-elements type))
+                         (add-annotation! type)]
+                        [(type-var? type)
+                         (let ([handle (maybe-lookup-symbol var->handle (type-var-name type))])
+                           (when handle
+                             (add-annotation! type)))]
+                        [(type-values? type)
+                         (annotate (type-values-type type))
+                         (add-annotation! type)]
+                        [(type-vector? type)
+                         (annotate (type-vector-element type))
+                         (add-annotation! type)]
+                        [else
+                         (error 'create-dfa-from-type "Type ~a should already have been hashconsed" type)])))]
+                 [create-dfa
+                  (lambda (type var->state)
+                    (cond
+                      [(handle? type)
+                       (add-state! (make-handle-state (get-annotation type) type))]
+                      [(type-cons? type)
+                       (let* ([hd (create-dfa (type-cons-car type) var->state)]
+                              [tl (create-dfa (type-cons-cdr type) var->state)]
+                              [state (make-cons-state (get-annotation type) hd tl)])
+                         (add-state! state))]
+                      [(type-case-lambda? type) ; rest-arg?s req-args argss exps)
+                       (let* ([argss (map-vector-of-vector (lambda (type) (create-dfa type var->state)) (type-case-lambda-argss type))]
+                              [exps (map-vector (lambda (type) (create-dfa type var->state)) (type-case-lambda-exps type))]
+                              [state-number (get-annotation type)]
+                              [state (make-case-lambda-state state-number
+                                                             (type-case-lambda-rest-arg?s type)
+                                                             (type-case-lambda-req-args type)
+                                                             argss exps)])
+                         (add-state! state)
+                         state-number)]
+                      [(type-promise? type)
+                       (let* ([value (create-dfa (type-promise-value type) var->state)]
+                              [state-number (get-annotation type)])
+                         (add-state! (make-promise-state state-number value)))]
+                      [(type-rec? type) ; vars types body)
+                       (let* ([vars (type-rec-vars type)]
+                              [types (type-rec-types type)]
+                              [body (type-rec-body type)]
+                              [binder-states (map (lambda (v ty)
+                                                    (or (maybe-get-annotation v)
+                                                        (get-annotation ty)))
+                                                  vars types)]
+                              [new-env (extend-tenv var->state (map type-var-name vars) binder-states)])
+                         (for-each (lambda (var type)
+                                     (if (maybe-get-annotation var)
+                                         (create-dfa var new-env)
+                                         (create-dfa type new-env)))
+                                   vars types)
+                         binder-states)]
+                      [(type-struct-value? type) 
+                       (let ([types (map (lambda (ty) (create-dfa ty var->state)) (type-struct-value-types type))]
+                             [label (type-struct-value-type-label type)])
+                         (add-state! (make-struct-value-state (get-annotation type) label types)))]
+                      [(type-union? type)
+                       (let* ([elements (map (lambda (ty) (create-dfa ty var->state)) (type-union-elements type))])
+                         (add-state! (make-union-state (get-annotation type) (min-list-numbers elements))))]
+                      [(type-vector? type)
+                       (let ([element (create-dfa (type-vector-element type) var->state)])
+                         (add-state! (make-vector-state (get-annotation type) element)))]
+                      [(type-var? type)
+                       (let ([state-number (maybe-get-annotation type)]
+                             [name (type-var-name type)])
+                         (if state-number
+                             (add-state! (make-handle-state state-number (lookup-symbol var->state name)))
+                             (lookup-symbol var->state name)))]
+                      [(type-values? type)
+                       (let ([ty (create-dfa (type-values-type type) var->state)])
+                         (add-state! (make-values-state (get-annotation type) ty)))]
+                      [else
+                       (error 'create-dfa-from-type "Type ~a should already have been hashconsed" type)]))])
+          (annotate type)
+          (values dfa (create-dfa type (create-tenv)))))))
+  
+  ;;
+  ;; Printing functions
+  ;;
+  
+  (define/contract dfa-state-number->list (opt-> (state-number?) (dfa?) list?)
+    (opt-lambda (stnum [dfa #f])
+      (dfa-state->list (lookup dfa stnum) dfa)))
+  
+  (define/contract dfa-state->list (opt-> (state?) (dfa?) list?)
+    (opt-lambda (dfa-state [dfa #f])
+      (letrec
+          ([state->var (make-hash-table)]
+           [state->binding (make-hash-table)]
+           [get-next-var! (let ([i 0]) (lambda (state)
+                                         (let ([str (string->symbol (format "a~a" i))])
+                                           (set! i (add1 i))
+                                           (hash-table-put! state->var state str)
+                                           str)))]
+           [statify
+            (lambda (sym state) ;((union symbol? list?) state-number? . -> . (union symbol? list?))
+              (let* ([first (if (list? sym) (car sym) sym)]
+                     [first (string->symbol
+                             (string-append (symbol->string first) ":" (number->string state)))])
+                (if (list? sym) (cons-immutable first (cdr sym)) first)))]
+           [to-list
+            (lambda (dfa-state ancest) ;(state? (listof state-number?) . -> . list?)
+              (letrec ([expand
+                        (if dfa
+                            (lambda (x) (loop x ancest))
+                            (lambda (x) x))])
+                (match dfa-state
+                  [($ handle-state state handle)
+                   (list 'handle handle)]
+                  [($ cons-state state car cdr)
+                   (list 'cons (expand car) (expand cdr))]
+                  [($ case-lambda-state state rest-arg?s req-args argss exps)
+                   (list 'case-lambda
+                         (foldr-case-lambda-vector
+                          (lambda (rest-arg? req-arg args exp acc)
+                            (cons (list (map expand (vector->list args))
+                                        (if rest-arg? '*-> '->)
+                                        (expand exp))
+                                  acc))
+                          null
+                          rest-arg?s req-args argss exps))]
+                  [($ promise-state state value) 
+                   (list 'promise (expand value))]
+                  [($ struct-value-state state label types)
+                   (list 'struct (map expand types))]
+                  [($ union-state state elements)
+                   (cons 'union (map expand elements))]
+                  [($ values-state state type)
+                   (list 'values (expand type))]
+                  [($ vector-state state type)
+                   (list 'vector (expand type))]
+                  [x (error 'dfa-state->string "Unmatched type ~a\n" x)])))]
+           [loop (lambda (stnum ancest)
+                   (if (memq stnum ancest)
+                       (if (hash-table-has-key? state->var stnum)
+                           (hash-table-get state->var stnum)
+                           (get-next-var! stnum))
+                       (let* ([state (lookup dfa stnum)]
+                              [l (to-list state (cons stnum ancest))])
+                         (if (hash-table-has-key? state->var stnum)
+                             (begin
+                               (hash-table-put! state->binding stnum (statify l stnum))
+                               (hash-table-get state->var stnum))
+                             (statify l stnum)))))])
+        (if dfa (let ([rec-body (loop (state-number dfa-state) null)]
+                      [var-bindings
+                       (hash-table-map state->var (lambda (s v)
+                                                    (list v (hash-table-get state->binding s))))])
+                  (if (null? var-bindings) rec-body
+                      (list (statify 'rec-state (state-number dfa-state))
+                            var-bindings
+                            rec-body)))
+            (statify (to-list dfa-state null) (state-number dfa-state))))))
+  
+  
+  (define/contract dfa->list (dfa? . -> . any)
+    (lambda (dfa)
+      (list
+       (list:mergesort (hash-table-map (dfa-stnum->state dfa) (lambda (k v) (list k '-> (dfa-state->list v dfa))))
+                       (lambda (x y) (> (car x) (car y))))
+       (dfa-canonical-ordering dfa)
+       )))
+  
+  (define print-dfa
+    (lambda (dfa)
+      (pretty-display (dfa->list dfa))))
+  
+  ;;
+  ;; Minimization
+  ;;
+  
+  ;; Should equiv-class and block should be merged
+  (define-struct equiv-class (type number length classes) (make-inspector))
+  
+  ;; A non-empty list of dfa-states, representing an equivalence class
+  (define block? (listof state?))
+  
+  ;; A list of disjoint blocks
+  (define partition? (listof block?))
+  
+  (define make-state->equiv-class
+    (lambda (num-states)
+      (make-vector num-states #f)))
+  
+  ;; Used only for debugging, make each handle state in the dfa is
+  ;; referenced by a label state
+  (define all-handles-referenced?
+    (lambda (dfa)
+      (letrec
+          ([tbl (make-hash-table)]
+           [seen (make-hash-table)]
+           [loop
+            (lambda (stnum)
+              (unless (hash-table-get seen stnum cst:thunk-false)
+                (hash-table-put! seen stnum #t)
+                (match (lookup dfa stnum)
+                  [($ handle-state state handle)
+                   (hash-table-put! tbl handle #t)]
+                  [($ cons-state state car cdr)
+                   (loop car) (loop cdr)]
+                  [($ case-lambda-state state rest-arg?s req-args argss exps)
+                   (for-each-vov loop argss)
+                   (for-each-vector loop exps)]
+                  [($ promise-state state value) 
+                   (loop value)]
+                  [($ struct-value-state state label types)
+                   (for-each loop types)]
+                  [($ union-state state elements)
+                   (for-each loop elements)]
+                  [($ values-state state type)
+                   (loop type)]
+                  [($ vector-state state type)
+                   (loop type)])))]
+           [state (car (list:filter (lambda (x) (not (handle-state? x))) (get-ordered-states dfa)))]
+           [handle-states (list:filter handle-state? (get-ordered-states dfa))])
+        (loop (state-number state))
+        (andmap (lambda (hs) (hash-table-get tbl (handle-state-handle hs) cst:thunk-false)) handle-states))))
+  
+  ; Minimize DFA sets up the partition table and the gross equivalence
+  ; classes for hopcrofts algorithm, as well as replacing the states
+  ; numbers with their equivalence classes after minimization.
+  (define/contract minimize-dfa ((dfa? (listof state-number?)) . ->* .
+                                                               (dfa? (listof state-number?)))
+    (lambda (dfa original-states)
+      (let* ([highest-equiv-class (new counter%)]
+             [get-matching-states
+              (let ([states (get-states dfa)])
+                (lambda (pred)
+                  (list:filter pred states)))]
+             [state-numbers (get-state-numbers dfa)]
+             [stnum->ecnum (make-stnum->ecnum% (apply max state-numbers))]
+             [partitions (make-partitions% (get-dfa-size dfa))]
+             
+             [add-minimum-dfa-state!
+              (let ([min '()])
+                (lambda (state)
+                  (when (member state min)
+                    (error 'add-minimum-dfa-state! "Should never add the same state ~a to minimal DFA" state))
+                  (set! min (cons-immutable state min))))]
+             
+             [make-minimized-state
+              (match-lambda
+                [($ handle-state state handle)
+                 (make-handle-state (send stnum->ecnum lookup state) handle)]
+                [($ case-lambda-state state  rest-arg?s req-args argss exps)
+                 (make-case-lambda-state (send stnum->ecnum lookup state)
+                                         rest-arg?s req-args
+                                         (for-each-vov! (lambda (arg) (send stnum->ecnum lookup arg)) argss)
+                                         (for-each-vector! (lambda (exp) (send stnum->ecnum lookup exp)) exps))]
+                [($ cons-state state car cdr)
+                 (make-cons-state (send stnum->ecnum lookup state)
+                                  (send stnum->ecnum lookup car)
+                                  (send stnum->ecnum lookup cdr))]
+                [($ promise-state state value)
+                 (make-promise-state (send stnum->ecnum lookup state)
+                                     (send stnum->ecnum lookup value))]
+                [($ struct-value-state state label types)
+                 (make-struct-value-state (send stnum->ecnum lookup state)
+                                          label
+                                          (map (lambda (ty) (send stnum->ecnum lookup ty)) types))]
+                [($ union-state state elements)
+                 (make-union-state (send stnum->ecnum lookup state)
+                                   (min-list-numbers (map (lambda (el)
+                                                            (send stnum->ecnum lookup el))
+                                                          elements)))]
+                [($ values-state state type)
+                 (make-values-state (send stnum->ecnum lookup state)
+                                    (send stnum->ecnum lookup type))]
+                [($ vector-state state element)
+                 (make-vector-state (send stnum->ecnum lookup state)
+                                    (send stnum->ecnum lookup element))]
+                [x (error 'make-minimized-state "Unmatched type ~a" x)])]
+             [case-lambda-partition
+              (split-case-lambda-states (get-matching-states case-lambda-state?))]
+             [struct-value-partition
+              (split-struct-value-states (get-matching-states struct-value-state?))]
+             [union-partition
+              (split-union-states (get-matching-states union-state?))]
+             [handle-partition
+              (map list (list:mergesort (get-matching-states handle-state?)
+                                        (lambda (x y) (< (handle-state-handle x) (handle-state-handle y)))))]
+             [setup-equiv-class
+              (lambda (type)
+                (lambda(states)
+                  (if (null? states) #f
+                      (let* ([equiv-class-number (send highest-equiv-class next!)]
+                             [equiv-class (make-equiv-class type equiv-class-number (length states) states)])
+                        (send partitions place-new-equiv-class equiv-class)
+                        (send stnum->ecnum set-states! equiv-class states)
+                        equiv-class-number))))]
+             
+             [handle-partition-numbers (map (setup-equiv-class 'handle) handle-partition)]
+             [cl-partition-numbers (map (setup-equiv-class 'case-lambda) case-lambda-partition)]
+             [struct-value-numbers (map (setup-equiv-class 'struct-value) struct-value-partition)]
+             [union-numbers (map (setup-equiv-class 'union) union-partition)]
+             
+	     [cons-number ((setup-equiv-class 'cons) (get-matching-states cons-state?))]
+             [promise-number ((setup-equiv-class 'promise) (get-matching-states promise-state?))]
+             [values-number ((setup-equiv-class 'values) (get-matching-states values-state?))]
+             [vector-number ((setup-equiv-class 'vector) (get-matching-states vector-state?))])
+        ;; There is no position ordering on the elements of a union so we
+        ;; impose one on the equivalence classes of the elements
+        (for-each (lambda (block)
+                    (for-each (lambda (state)
+                                (set-union-state-elements!
+                                 state
+                                 (list:mergesort (union-state-elements state)
+                                                 (lambda (a b)
+                                                   (> (send stnum->ecnum lookup a)
+                                                      (send stnum->ecnum lookup b))))))
+                              block))
+                  union-partition)
+        (hopcroft state-numbers
+                  (list:filter cst:id
+                               (append handle-partition-numbers cl-partition-numbers struct-value-numbers union-numbers
+                                       (list cons-number promise-number values-number vector-number)))
+                  partitions stnum->ecnum highest-equiv-class)
+	(let* ([_  ; (void)
+                ;; ensure unions with only one state when minimized are not added to the dfa
+                (send partitions for-each
+                      (lambda (partition)
+                        (when (and partition (eq? (equiv-class-type partition) 'union))
+                          (let* ([block (equiv-class-classes partition)]
+                                 [representative (car block)]
+                                 [elements (union-state-elements representative)]
+                                 [min-stnums (min-list-numbers (map (lambda (stnum)
+                                                                      (send stnum->ecnum lookup stnum))
+                                                                    elements))])
+                            (when (length-one? min-stnums)
+                              (for-each (lambda (state)
+                                          (send stnum->ecnum set!
+                                                (send partitions get-equiv-class (car min-stnums))
+                                                state))
+                                        block))))))]
+               
+               [states (send partitions fold
+                             (lambda (p acc)
+                               (let ([min-state (make-minimized-state (car (equiv-class-classes p)))])
+                                 (if (and (union-state? min-state) (length-one? (union-state-elements min-state)))
+                                     acc
+                                     (cons-immutable min-state acc))))
+                             null)]
+               [min-binder-states
+                (map (lambda (stnum) (send stnum->ecnum lookup stnum)) original-states)]
+               [min-dfa (make-ordered-dfa states)]
+               [has-useless-union (ormap (lambda (state) (and (union-state? state)
+                                                              (length-one? (union-state-elements state))))
+                                         states)])
+          (if has-useless-union
+              (minimize-dfa min-dfa min-binder-states)
+              (values min-dfa min-binder-states)))
+        )))
+  
+  (define stnum->ecnum%
+    (class object%
+      (init-field highest-state)
+      
+      (define stnum->ecnum (make-vector (add1 highest-state) #f))
+      
+      (define/public lookup
+        (lambda (stnum)
+          (vector-ref stnum->ecnum stnum)))
+      
+      (define/public set!
+        (lambda (equiv-class state)
+          (vector-set! stnum->ecnum
+                       (if (state? state)
+                           (state-number state) state)
+                       (equiv-class-number equiv-class))))
+      
+      (define/public set-states!
+        (lambda (equiv-class states)
+          (for-each (lambda (state)
+                      (vector-set! stnum->ecnum
+                                   (state-number state)
+                                   (equiv-class-number equiv-class)))
+                    states)))
+      
+      (super-new)))
+  
+  (define make-stnum->ecnum%
+    (lambda (k)
+      (let ()
+        (define/contract stnum->ecnum 
+          (object-contract (lookup (natural? . -> . natural?))
+                           (set! (equiv-class? (union state? natural?) . -> . void?))
+                           (set-states! (equiv-class? (listof state?) . -> . void?)))
+          (new stnum->ecnum% (highest-state k)))
+        stnum->ecnum)))
+  
+  (define partitions%
+    (class object%
+      (init-field number-states)
+      
+      ; Each element of the partitions table contains either an equivalence class,
+      ; or false if it has not been used or the equivalence class it contains has
+      ; been split. 
+      ;
+      ; We split at most num-states - 1 times, but we never reuse the
+      ; states in an old partition so allocate twice the number of states.
+      (define partitions (make-vector (* 2 number-states) #f))
+      
+      (define/public place-new-equiv-class
+        (lambda (eq-class)
+          (vector-set! partitions (equiv-class-number eq-class) eq-class)))
+      
+      (define/public split
+        (lambda (k)
+          (vector-set! partitions k #f)))
+      
+      (define/public get-equiv-class
+        (lambda (i) (vector-ref partitions i)))
+      
+      (define/public fold
+        (lambda (f init)
+          (foldr-vector (lambda (x acc)
+                          (if x (f x acc) acc))
+                        init partitions)))
+      
+      (define/public for-each
+        (lambda (f)
+          (send this fold (lambda (x acc) (f x)) (void))))
+      
+      (super-new)
+      ))
+  
+  (define make-partitions%
+    (lambda (k)
+      (let ()
+        (define/contract p 
+          (object-contract (place-new-equiv-class (equiv-class? . -> . any))
+                           (split (natural? . -> . void?))
+                           (get-equiv-class (natural? . -> . equiv-class?))
+                           (fold ((equiv-class? any/c . -> . any) any/c . -> . any))
+                           (for-each ((equiv-class? . -> . any) . -> . any)))
+          (new partitions% (number-states k)))
+        p)))
+  
+  
+  
+  ; Hopcrofts DFA minimization algorithm. First generate letters for each
+  ; partition individually as the have different types and shapes. Next while
+  ; there are still letters which may split an equivalence class, try to split
+  ; each equivalence class by the letter. Most times the split will fail, but if
+  ; it succeeds then replace the old equivalence class with the new split
+  ; equivalence classes.  The letter/equiv class pairs will need to be changed
+  ; to point to the new equivalence classes
+  (define/contract hopcroft
+    ((listof natural?) (listof natural?) (is-a?/c partitions%) (is-a?/c stnum->ecnum%) (is-a?/c counter%) . -> . any)
+    (lambda (states 
+             partition-nums 
+             partitions 
+             state->equiv-class 
+             get-next-equiv-class)
+      (if (null? partition-nums) (void)
+          (let* ([l (set-make 'equal)]
+                 [largest-number-cl-exps -1]
+                 [largest-number-cl-args -1]
+                 [largest-number-union-elements -1]
+                 [largest-number-struct-value-types -1]
+                 [_ (send partitions for-each
+                          (lambda (ec)
+                            (cond [(eq? 'case-lambda (equiv-class-type ec))
+                                   (let* ([cl (car (equiv-class-classes ec))]
+                                          [argss (case-lambda-state-argss cl)]
+                                          [exps (case-lambda-state-exps cl)])
+                                     (when (> (vector-length exps) largest-number-cl-exps)
+                                       (set! largest-number-cl-exps (vector-length exps)))
+                                     (when (> (foldr-vector (lambda (c acc) (max (vector-length c) acc)) -1 argss)
+                                              largest-number-cl-args)
+                                       (set! largest-number-cl-args (vector-length exps))))]
+                                  [(eq? 'union (equiv-class-type ec))
+                                   (let* ([union (car (equiv-class-classes ec))]
+                                          [len (length (union-state-elements union))])
+                                     (when (> len largest-number-union-elements)
+                                       (set! largest-number-union-elements len)))]
+                                  [(eq? 'struct-value (equiv-class-type ec))
+                                   (let* ([struct-value (car (equiv-class-classes ec))]
+                                          [len (length (struct-value-state-types struct-value))])
+                                     (when (> len largest-number-struct-value-types)
+                                       (set! largest-number-struct-value-types len)))])))]
+                 [letters
+                  (let* ([letters
+                          (list:foldr
+                           (lambda (equiv-class-num letters)
+                             (let* ([equiv-class (send partitions get-equiv-class equiv-class-num)]
+                                    [state (car (equiv-class-classes equiv-class))])
+                               (cond [(cons-state? state)
+                                      (cons '(cons car) (cons '(cons cdr) letters))]
+                                     [(promise-state? state)
+                                      (cons '(promise) letters)]
+                                     [(values-state? state)
+                                      (cons '(values) letters)]
+                                     [(vector-state? state)
+                                      (cons '(vector) letters)]
+                                     [else
+                                      letters])))
+                           '() partition-nums)]
+                         [letters   ;; add letters for case-lambda
+                          (if (= largest-number-cl-args -1) letters
+                              (let ([w-argss
+                                     (list:foldr (lambda (row acc)
+                                                   (coalesce-lists (list:foldr (lambda (col acc)
+                                                                                 (cons (list 'case-lambda 'argss row col) acc))
+                                                                               '()
+                                                                               (iota largest-number-cl-args))
+                                                                   acc))
+                                                 letters
+                                                 (iota largest-number-cl-exps))])
+                                (coalesce-lists
+                                 (map (lambda (row) (list 'case-lambda 'exps row)) (iota largest-number-cl-exps))
+                                 w-argss)))]
+                         [letters ;; add letters for unions
+                          (if (= largest-number-union-elements -1) letters
+                              ;(unfold-onto (lambda (x) (= x largest-number-union-elements))
+                              ;             (lambda (i) (list 'union i))
+                              ;             add1
+                              ;             0
+                              (cons '(union) letters))])
+                    (if (= largest-number-struct-value-types -1) letters
+                        (coalesce-lists 
+                         (map (lambda (i) (list 'struct-value i)) (iota largest-number-struct-value-types))
+                         letters)))]
+                 ; This is a cheesy way to remove a random element from the set.  XXX ?
+                 [get-next! (lambda ()
+                              (let ([eq&letter (let/ec return (set-for-each l (lambda (elem) (return elem))) #f)])
+                                (when eq&letter
+                                  (set-remove l eq&letter))
+                                eq&letter))]
+                 [add-to-L!
+                  (lambda (eq letter)
+                    (set-set l (cons eq letter)))]
+                 [print-L
+                  (lambda ()
+                    (printf "(L=") (set-for-each l display)(printf ")"))]
+                 [remove! (lambda (eq-class-num letter)
+                            (set-remove l (cons eq-class-num letter)))]
+                 [number-states (length states)]
+                 [eq&letter-present? (lambda (eq-class-num letter)
+                                       (set-in? l (cons eq-class-num letter)))])
+            (for-each (lambda (eq&letter)
+                        (set-set l eq&letter))
+                      (cross2 partition-nums letters))
+            (let while-letters ([eq&letter (get-next!)] [partition-nums partition-nums])
+              (when eq&letter
+                (let* ([q1 (car eq&letter)]
+                       [a (cdr eq&letter)]
+                       [number-partitions 0]
+                       [new-partition-nums '()]
+                       [add-equiv-class (lambda (ec)
+                                          (begin
+                                            (set! new-partition-nums (cons ec new-partition-nums))
+                                            (set! number-partitions (add1 number-partitions))))])
+                  (for-each
+                   (lambda (q0)
+                     (let-values ([(equiv-class-a equiv-class-b)
+                                   (split q0 q1 a partitions state->equiv-class get-next-equiv-class)])
+                       (if equiv-class-a ;; when the split is successful
+                           (begin
+                             (add-equiv-class equiv-class-b)
+                             (add-equiv-class equiv-class-a)
+                             (for-each (lambda (b)
+                                         (if (eq&letter-present? q0 b)
+                                             (begin
+                                               (remove! q0 b)
+                                               (add-to-L! equiv-class-a b)
+                                               (add-to-L! equiv-class-b b))
+                                             (begin
+                                               (add-to-L!
+                                                (if (< (equiv-class-length (send partitions get-equiv-class equiv-class-a))
+                                                       (equiv-class-length (send partitions get-equiv-class equiv-class-b)))
+                                                    equiv-class-a
+                                                    equiv-class-b)
+                                                b))))
+                                       letters))
+                           (add-equiv-class q0))))
+                   partition-nums)
+                  (when (< number-partitions number-states)
+                    (while-letters (get-next!) new-partition-nums)))))))))
+  
+  ;;
+  ;; Utility functions
+  ;;
+  
+  (define cross2
+    (lambda (xs ys)
+      (list:foldl (lambda (x xacc)
+                    (list:foldl (lambda (y yacc) (cons-immutable (cons-immutable x y) yacc)) xacc ys))
+                  null xs)))
+  
+  (define coalesce-lists
+    (lambda xs
+      (letrec ([reverse-onto
+                (lambda (xs ys)
+                  (if (null? xs) ys
+                      (reverse-onto (cdr xs) (cons (car xs) ys))))])
+        (if (null? xs) '()
+            (list:foldl reverse-onto (car xs) (cdr xs))))))
+  
+  
+  ;;
+  ;; Equivalence class utilities
+  ;;
+  
+  (define/contract set-equiv-class-of-state-number! 
+    ((vectorof (union false/c natural?)) equiv-class? state-number? . -> . void?)
+    (lambda (classes equiv-class stnum)
+      (vector-set! classes stnum (equiv-class-number equiv-class))))
+  
+  ;; A function extracting some value from a dfa-state. Discriminators
+  ;; are used when comparing two states
+  (define discriminator? (state? . -> . (union integer? boolean?)))
+  
+  (define/contract block->partition (block? . -> . partition?)
+    list-immutable)
+  
+  ; split q0 into 2 equivalence classes, those which transitions to q1 from
+  ; letter b and those which don't transition to q1
+  ;
+  ; The 'letter' b depends on the type of partiton we're splitting. A letter
+  ; consists of a place within the type E.g. A type-cons letter has a 'position'
+  ; indicator of 'car or 'cdr to distinguish which position in a partition of
+  ; type-cons we're going to split by.
+  (define/contract split
+    (natural? natural? list? (is-a?/c partitions%) (is-a?/c stnum->ecnum%) (is-a?/c counter%) . -> . any)
+    (lambda (q0-num q1-num b partitions stnum->ecnum highest-equiv-class)
+      (let* ([q0 (send partitions get-equiv-class q0-num)]
+             [type1 (equiv-class-type q0)]
+             [transition-on-letter
+              (lambda (q0 b)
+                (cond
+                  [(eq? b 'handle) #f]
+                  [(and (eq? (car b) 'case-lambda)
+                        (eq? (cadr b) 'exps))
+                   (let ([row (caddr b)])
+                     (and (case-lambda-state? q0)
+                          (< row (vector-length (case-lambda-state-exps q0)))
+                          (send stnum->ecnum lookup
+                                (vector-ref (case-lambda-state-exps q0) row))))]
+                  [(and (eq? (car b) 'case-lambda) (eq? (cadr b) 'argss))
+                   (let ([row (caddr b)]
+                         [col (cadddr b)])
+                     (and (case-lambda-state? q0)
+                          (let ([argss (case-lambda-state-argss q0)])
+                            (and (< row (vector-length argss))
+                                 (< col (vector-length (vector-ref argss row)))
+                                 (send stnum->ecnum lookup
+                                       (vector-ref (vector-ref argss row) col))))))]
+                  [(eq? 'cons (car b))
+                   (let ([pos (cadr b)])
+                     (and (cons-state? q0)
+                          (send stnum->ecnum lookup
+                                ((if (eq? pos 'car) cons-state-car cons-state-cdr) q0))))]
+                  [(eq? 'promise (car b))
+                   (and (promise-state? q0)
+                        (send stnum->ecnum lookup (promise-state-value q0)))]
+                  [(eq? 'struct-value (car b))
+                   (let ([pos (cadr b)])
+                     (and (struct-value-state? q0)
+                          (< (length (struct-value-state-types q0)) pos)
+                          (send stnum->ecnum lookup (list-ref (struct-value-state-types q0) pos))))]
+                  [(eq? 'union (car b))
+                   (error 'transition-on-letter "Should have already handled union case")]
+                  [(eq? 'values (car b))
+                   (and (type-values? q0)
+                        (send stnum->ecnum lookup (type-values-type q0)))]
+                  [(eq? 'vector (car b))
+                   (and (type-vector? q0)
+                        (send stnum->ecnum lookup (type-vector-element q0)))]))]
+             [any-union-element-transitions-to
+              (lambda (q0 q1-num)
+                (and (union-state? q0)
+                     (ormap (lambda (x)
+                              (= (send stnum->ecnum lookup x) q1-num))
+                            (union-state-elements q0))))])
+        ; this always makes a new list, even if not splittable. probably
+        ; faster to switch to new list midway through
+        (if (eq? (equiv-class-type q0) (car b)) 
+            (let loop ([q0 (equiv-class-classes q0)]
+                       [to-q1 '()] [to-q1-length 0]
+                       [not-to-q1 '()] [not-to-q1-length 0])
+              (cond [(null? q0)
+                     (if (and (not (null? to-q1)) (not (null? not-to-q1)))
+                         (let* ([to-q1-num (send highest-equiv-class next!)]
+                                [to-q1 (make-equiv-class type1 to-q1-num to-q1-length to-q1)]
+                                [not-to-q1-num (send highest-equiv-class next!)]
+                                [not-to-q1 (make-equiv-class type1 not-to-q1-num
+                                                             not-to-q1-length not-to-q1)])
+                           (send partitions place-new-equiv-class to-q1)
+                           (send partitions place-new-equiv-class not-to-q1)
+                           (send stnum->ecnum set-states! to-q1 (equiv-class-classes to-q1))
+                           (send stnum->ecnum set-states! not-to-q1 (equiv-class-classes not-to-q1))
+                           (send partitions split q0-num)
+                           (values to-q1-num not-to-q1-num))
+                         (values #f #f))]
+                    [(eq? 'union (car b))
+                     (if (any-union-element-transitions-to (car q0) q1-num)
+                         (loop (cdr q0) (cons (car q0) to-q1) (add1 to-q1-length) not-to-q1 not-to-q1-length)
+                         (loop (cdr q0) to-q1 to-q1-length (cons (car q0) not-to-q1) (add1 not-to-q1-length)))]
+                    [(eq? (transition-on-letter (car q0) b) q1-num)
+                     (loop (cdr q0) (cons (car q0) to-q1) (add1 to-q1-length) not-to-q1 not-to-q1-length)]
+                    ;; q0 does not transition on b
+                    [else
+                     (loop (cdr q0) to-q1 to-q1-length (cons (car q0) not-to-q1) (add1 not-to-q1-length))]))
+            (values #f #f)))))
+  
+  ;; To split a block of dfa-states, use the value projected from a
+  ;; dfa-state as a hashtable-key which is associated with the list of
+  ;; dfa-states with identical values
+  (define/contract split-set (discriminator? block? . -> . partition?)
+    (lambda (f xs)
+      (if (length-one? xs) (block->partition xs)
+          (let ([accs (make-hash-table)])
+            (for-each (lambda (x) (hash-table-prepend! accs (f x) x)) xs)
+            (let ([keys (hash-table-map accs (lambda (k v) k))])
+              (if (null? keys) '()
+                  (let* ([gt (cond [(boolean? (car keys))
+                                    (lambda (a b) (cond [(eq? a b) #f] [a #f] [b #t]))]
+                                   [(integer? (car keys)) >]
+                                   [else (error 'split-set "Unknown type ~a" (car keys))])]
+                         [keys (list:mergesort keys gt)])
+                    (map (lambda (k) (hash-table-get accs k)) keys))))))))
+  
+  ;; list list list -> list list
+  (define unnest
+    (lambda (xsss)   ;; there is probably a better way of doing this, but its not a big time hit
+      (let loop ([xsss xsss] [acc '()])
+        (if (null? xsss) acc (loop (cdr xsss) (append acc (car xsss)))))))
+  
+  ; Split each a partition by a block splitter
+  (define/contract split-partition-by
+    ((block? . -> . partition?) partition? . -> . partition?)
+    (lambda (partition-block partition)
+      (unnest (map (lambda (block) (partition-block block)) partition))))
+  
+  ; Split each a partition by a discriminator
+  (define/contract split-partition (discriminator? partition? . -> . partition?)
+    (lambda (f xss)
+      (unnest (map (lambda (xs) (split-set f xs)) xss))))
+  
+  ; Split a block by the values  
+  (define/contract split-by-vector-values
+    ((state? . -> . vector?) (integer? . -> . discriminator?) . -> . (block? . -> . partition?))
+    (lambda (list-accessor discriminator)
+      (lambda (block)
+        (list:foldr (lambda (i xss) (split-partition (discriminator i) xss))
+                    (block->partition block)                          ; initial partition
+                    (iota (vector-length (list-accessor (car block))))))))   ; split for each member in the list
+  
+  (define/contract split-by-vector-vector-values
+    ((state? . -> . (vectorof vector?))
+     (state? . -> . vector?)
+     (integer? integer? . -> . discriminator?)
+     . -> . (block? . -> . partition?))
+    (lambda (vector-accessor vector-vector-accessor discriminator)
+      (lambda (type-list)
+        (list:foldr (lambda (row acc)
+                      (list:foldr (lambda (col acc2)
+                                    (split-partition (discriminator row col) acc2))
+                                  acc
+                                  (iota (vector-length (vector-vector-accessor (car type-list))))))
+                    (list type-list)
+                    (iota (vector-length (vector-accessor (car type-list))))))))
+  
+  ;; Split a block of unions into a paritions with each union in a
+  ;; block has the same number of elements.
+  (define/contract split-union-states ((listof union-state?) . -> . (listof (listof union-state?)))
+    (lambda (unions)
+      (let* ([number-elements-discriminator
+              (lambda (union) (length (type-union-elements union)))])
+        ;; TBD Spliting by number of elements in a union cannot possibly be right
+        ;(split-set number-elements-discriminator unions))))
+        (list unions))))
+  
+  (define/contract split-struct-value-states ((listof struct-value-state?) . -> . (listof (listof struct-value-state?)))
+    (lambda (structs)
+      (let ([number-elements-discriminator
+             (lambda (struct) (length (type-struct-value-types struct)))])
+        ; a total ordering must be imposed on labels
+        (split-partition (lambda (sv) (eq-hash-code (type-struct-value-type-label sv)))
+                         (split-set number-elements-discriminator structs)))))
+  
+  ;; Split a block of case-lambda-states into a partition with each
+  ;; block having the same number of expressions, each parameter list
+  ;; having the same length, each rest and req arg lists have the same
+  ;; length and values.
+  (define/contract split-case-lambda-states
+    ((listof case-lambda-state?) . -> . (listof (listof case-lambda-state?)))
+    (lambda (cls)
+      (letrec
+          ([get-number-args
+            ;(lambda (i) (lambda (cl) (vector-length (vector-ref (type-case-lambda-argss cl) i))))]
+            (lambda (i) (lambda (cl) (vector-length (vector-ref (case-lambda-state-argss cl) i))))]
+           [get-number-exps
+            ;(lambda (cl) (vector-length (type-case-lambda-exps cl)))]
+            (lambda (cl) (vector-length (case-lambda-state-exps cl)))]
+           [get-rest-arg
+            ;(lambda (i) (lambda (cl) (vector-ref (type-case-lambda-rest-arg?s cl) i)))]
+            (lambda (i) (lambda (cl) (vector-ref (case-lambda-state-rest-arg?s cl) i)))]
+           [get-req-arg
+            ;(lambda (i) (lambda (cl) (vector-ref (type-case-lambda-req-args cl) i)))]
+            (lambda (i) (lambda (cl) (vector-ref (case-lambda-state-req-args cl) i)))]
+           [req-arg-gt (lambda (xs ys)
+                         (cond [(and (null? xs) (null? ys)) #f]
+                               [(= (car xs) (car ys)) (req-arg-gt (cdr xs) (cdr ys))]
+                               [(> (car xs) (car ys)) #t]
+                               [(< (car xs) (car ys)) #f]
+                               [else (error 'lex "Differing lengths")]))]
+           [rest-arg-gt (lambda (xs ys)
+                          (cond [(and (null? xs) (null? ys)) #f]
+                                [(= (car xs) (car ys)) (rest-arg-gt (cdr xs) (cdr ys))]
+                                [(car xs) #t]
+                                [else #f]))])
+        (split-partition-by
+         (split-by-vector-values case-lambda-state-req-args get-req-arg)
+         (split-partition-by
+          (split-by-vector-values case-lambda-state-rest-arg?s get-rest-arg)
+          (split-partition-by
+           (split-by-vector-values         ; block -> partition
+            case-lambda-state-argss        ; (any/c . -> . list?)  ;  case-lambda -> args
+            get-number-args)               ; (integer? . -> . (any/c . -> . any))
+           (split-set get-number-exps cls)))) )))
+  
+  )
+
diff --git a/collects/mrflow/doc.txt b/collects/mrflow/doc.txt
new file mode 100644
index 0000000000..0ff0c79e4c
--- /dev/null
+++ b/collects/mrflow/doc.txt
@@ -0,0 +1,325 @@
+
+[index entries: _snip_ _arrow_ _label_ ]
+
+_snips_ and _arrows_ library
+============================
+
+Collection: mrflow
+Files: snips-and-arrows.ss snips-and-arrows-view.ss snips-and-arrows-model.ss
+
+This library allows a programmer to display information about terms in
+a DrScheme text editor and its embedded sub-editors.  Textual
+information about a given term can be displayed using snips inserted
+in the editor next to the term.  Each snip is colored according to a
+programmer specified type.  Several snips can exist for a given term
+and type.  A relation between two terms can be displayed by drawing an
+arrow between the two terms.  Each arrow is colored using a programmer
+specified color.  Arrows do not carry any textual information with
+them.
+
+The library is fundamentally based on terms.  It is not possible to
+display snips or arrows that are not directly related to terms.
+However the library does not require terms to be represented by
+MzScheme syntax objects.  Terms can be represented by any user-defined
+data structure, called hereafter _labels_.  A label represents exactly
+one term and the library user is responsible for keeping track of
+which term is represented by a given label (by, say, keeping a
+reference to the syntax object in the label's data structure), but a
+term in an editor can be represented by one or more labels and the
+user doesn't have to keep track of that.  This asymmetry between terms
+and labels is necessary because macro expansions might duplicate some
+terms.
+
+With each label can be associated a number of snips containing textual
+information.  Each snip has a user-defined type that determines the
+color of the snip.  A label can have several snips for a given type,
+and snips of different types associated with it.  Mouse menus are
+available to show or hide all snips of a given type for all labels
+corresponding to a given term.  The snips are inserted on the left of
+the corresponding term, in an order that is determined by the user
+(see the snip-types-and-colors argument of the
+init-snips-and-arrows-gui function below for details).
+
+The library defines two mixins that augment the text editors with
+various methods, and two functions that are used to initialize the
+library.  Both functions return one function to register labels with
+the library and one function to change terms in the editors.  A term
+in an editor will be recognized and colored by the library only if at
+least one of its corresponding labels has been registered with the
+library.
+
+All terms corresponding to registered labels must, either directly or
+indirectly through embedded sub-editors, be contained in a single
+editor called hereafter the top editor.  In the case of the DrScheme
+definitions window and its embedded sub-editors (if any), the top
+editor will be the definitions window itself.
+
+
+Usage
+=====
+
+(require (lib "snips-and-arrows.ss" "mrflow"))
+
+This will import two mixins:
+
+extend-all-editors-mixin and
+extend-top-editor-mixin
+
+and two functions:
+
+init-snips-and-arrows-gui and
+init-snips-and-arrows-gui-for-syntax-objects
+
+See the example at the end of this document for a quick how-to.
+
+
+All text% classes that will be used to create editors that will
+contain, either directly or indirectly through embedded editors, terms
+to be colored by the library, must be extended using the
+_extend-all-editors-mixin_ mixin.  In the case of the DrScheme
+definitions window and its embedded sub-editors (if any) this is
+simply done by giving this mixin as argument to the
+drscheme:unit:add-to-program-editor-mixin function during phase1 of
+DrScheme.
+
+The text% class that will be used to create the top editor that will
+contain, either directly or indirectly through embedded sub-editors,
+all the terms to be colored must be extended using the
+_extend-top-editor-mixin_ mixin.  This must be done even if all the
+terms to be colored are contained in embedded sub-editors and the top
+editor doesn't itself directly contain any terms to be colored. The
+mixin extends that text% class with two methods of no arguments:
+- _color-registered-labels_, to be called once all labels have been
+  registered (see below) in order to color the corresponding terms, to
+  start the automatic display of arrows as well as to make the snips
+  and arrows related mouse menus available to the user.
+- _remove-all-snips-and-arrows-and-colors_, to be called to terminate
+  the automatic display of arrows, make the snips and arrows related
+  mouse menus unavailable to the user, remove all inserted snips, and
+  optionally clear all colors (see below the last argument to
+  init-snips-and-arrows-gui and the last optional argument to
+  init-snips-and-arrows-gui-for-syntax-objects for details about this
+  last point).
+In the case of the DrScheme definitions window, using this mixin is
+simply done by giving it as argument to the
+drscheme:get/extend:extend-definitions-text function.
+
+
+The init-snips-and-arrows-gui and
+init-snips-and-arrows-gui-for-syntax-objects functions are used to
+initialize the library.  Exactly one of them must be called before
+trying to use the library.  The
+init-snips-and-arrows-gui-for-syntax-objects function is a simplified
+version of init-snips-and-arrows-gui.
+
+The _init-snips-and-arrows-gui_ function has eleven arguments in the
+following order (with a mnemonic name and a type between parenthesis):
+1)  the top editor (top-editor: text%), the editor that, either
+    directly or indirectly through embedded sub-editors, contains all
+    terms that are to be colored by the library.
+2)  a function from label to editor (get-editor-from-label: label ->
+    text%) returning the editor that directly contains the term
+    corresponding to the label.  This function must return the same
+    editor for all the labels corresponding to a given term.
+3)  a function from label to term position
+    (get-mzscheme-position-from-label: label ->
+    non-negative-exact-integer) returning the MzScheme position of the
+    term corresponding to the label in the editor that directly
+    contains it (the editor that would be returned by the
+    get-editor-from-label function described just above).  This
+    function must return the same position for all the labels
+    corresponding to a given term.
+4)  a function from label to term color span (get-span-from-label:
+    label -> non-negative-exact-integer) indicating the number of
+    characters of the term corresponding to the label that should be
+    colored.  Coloring of a term starts with the leftmost character of
+    the term and continues towards the right for that number of
+    characters.  This applies to all terms for which at least one
+    label has been registered with the library, regardless of whether
+    they are atomic or not, so care must be exercised when computing
+    the span for a term containing sub-terms that also have to be
+    colored.  Arrows starting or ending at a given term will be
+    anchored at half the span of the term, so again care must be taken
+    when specifying the span of non-atomic terms.  This function must
+    return the same span for all labels corresponding to a given term.
+5)  a function from label to a list of arrows data
+    (get-arrows-from-label: label -> (listof (list label label
+    string))) indicating what arrows should be drawn when the mouse
+    pointer is placed over the term corresponding to the label.  Each
+    sublist in the list represents one arrow, and must contain, in
+    that order, a label corresponding to the starting term for the
+    arrow, a label corresponding to the ending term for the arrow, and
+    a string representing the arrow color (see color-database<%> in
+    the help-desk for a list of color names).
+6)  a function from label to style delta (get-style-delta-from-label:
+    label -> style-delta%) indicating how the term corresponding to
+    the label should be colored.  This function must return the same
+    style delta for all the labels corresponding to a given term.
+7)  a function from popup menu and a list of labels to void
+    (extend-menu-for-labels: popup-menu% (listof label) -> void) that
+    can be used to add menu-item% objects to the menu that pops up
+    when the user clicks with the right mouse button on a term.  All
+    the labels in the list correspond to that term (there might be
+    several labels in the list because of macro expansions).  The
+    callbacks for the added menu items must not directly modify the
+    content of any editor that directly contains colored terms but
+    must instead use a function like the first one returned by the
+    call to init-snips-and-arrows-gui (see below for details).
+8)  a function from snip type (see snip-types-and-colors below) and
+    action symbol to string (get-menu-text-from-snip-type: symbol
+    symbol -> string) that takes as input a snip type represented as a
+    symbol as well as one of the two symbols 'show or 'hide
+    representing a user command and returns a string that will be used
+    as the text for the menu entry that will allow the user to perform
+    said command for the snips of that given type.
+9)  a function from snip type and label to a list of strings
+    (get-snip-text-from-snip-type-and-label: symbol label -> (listof
+    string)) that returns the content of all the snips of the given
+    type that will be inserted next to the term corresponding to the
+    label when the user uses the snip-related mouse menu entries
+    described just above.
+10) a list of snip types and colors (snip-types-and-colors: (listof
+    (cons symbol string))) that describes all possible types of snips
+    and their associated color.  Each sub-list in the list must
+    contain two elements: a snip type name represented as a symbol,
+    and a corresponding snip color (see color-database<%> in the
+    help-desk for a list of color names).  For a given term, snips of
+    different types will be inserted from left to right on the left of
+    the corresponding term in the order in which their types appear in
+    this list.
+11) a boolean (clear-colors-immediately?: (union #t #f)) that
+    indicates whether, once the user starts modifying the content of
+    the editors, the terms colored by the library should be uncolored
+    immediately or should be uncolored only the next time a DrScheme
+    tool is run or the program executed.
+The init-snips-and-arrows-gui then returns two values: a function to
+change terms and a function to register a label.  The function to
+change terms has type ((listof (cons label string)) -> void).  Each
+pair in the function's argument consists of a label representing a
+term to be changed and a string that will be used to replace that
+term.  It is only necessary to give one label per term to be changed.
+It is an error to give two pairs with labels representing the same
+term but with different strings.  The function to register a label has
+type (label -> void) and is used to indicate to the library that the
+corresponding term has to be colored.  The same label can safely be
+registered several times.  Unspeakable things involving nasty crawling
+bugs will happen to you, and your descendants will be cursed to the
+seventh generation if you dare to call this function after having
+already called the color-registered-labels method described above.
+
+The init-snips-and-arrows-gui-for-syntax-objects function is a
+simplified (yes, really) version of init-snips-and-arrows-gui that
+assumes labels are in fact MzScheme syntax objects, and also provides
+default values for all the menu and snip related functions that simply
+assume that no snips are used at all.  Also, the terms represented by
+the syntax objects are assumed to be atomic, meaning they will be
+colored in whole and arrows will be anchored at half the terms' spans.
+Seemingly unanchored arrows and overlapping colors may result if you
+try to use this function with non-atomic terms (i.e. terms containing
+sub-terms).  The function has only three required arguments, and five
+optional arguments.  The three required arguments are, in that order,
+using the mnemonic names from the description of
+init-snips-and-arrows-gui above, and with updated types in
+parenthesis:
+- top-editor (text%)
+- get-arrows-from-label (syntax-object -> (listof (list syntax-object
+  syntax-object string)))
+- get-style-delta-from-label (syntax-object -> style-delta%)
+The five optional arguments are as follows, in that order, with their
+default value in brackets:
+- extend-menu-for-labels (popup-menu% (listof syntax-object) -> void)
+  [(lambda (m l) (void)))]
+- get-menu-text-from-snip-type (symbol symbol -> string) [internal
+  error function]
+- get-snip-text-from-snip-type-and-label (symbol syntax-object ->
+  (listof string)) [internal error function]
+- snip-types-and-colors (listof (cons symbol string)) ['()]
+- clear-colors-immediately? (union #t #f) [#f]
+The init-snips-and-arrows-gui-for-syntax-objects returns the same two
+functions as the init-snips-and-arrows-gui function.
+
+
+Example
+=======
+
+This example assumes that this library is used by a DrScheme tool.
+The skeleton for the tool would then look like this:
+
+(module my-tool
+  ...
+  (require (lib "snips-and-arrows.ss" "mrflow"))
+  ...
+  (define tool@
+    (unit/sig drscheme:tool-exports^
+      (import drscheme:tool^)
+      ...
+      (define (phase1)
+        ...
+        (drscheme:unit:add-to-program-editor-mixin extend-all-editors-mixin)
+        ...)
+      ...
+      (drscheme:get/extend:extend-definitions-text extend-top-editor-mixin)
+      ...
+      (drscheme:get/extend:extend-unit-frame
+       (lambda (super%)
+         (class super%
+           (inherit get-definitions-text)
+           (rename [super-clear-annotations clear-annotations])
+           ; -> void
+           (define/override (clear-annotations)
+             ...
+             (super-clear-annotations)
+             (send (get-definitions-text) remove-all-snips-and-arrows-and-colors)
+             ...)
+           ...
+           (define my-tool-button
+             (instantiate button%
+               ...
+               (callback
+                (lambda (button event)
+                  ...
+                  (letrec-values ([(user-change-terms register-label-with-gui)
+                                   ; use init-snips-and-arrows-gui-for-syntax-objects
+                                   ; if you only deal with syntax objects
+                                   (init-snips-and-arrows-gui
+                                    (get-definitions-text)
+                                    ...
+                                    ; for extend-menu-for-labels, if necessary -
+                                    ; basically a callback to library-user code
+                                    (lambda (popup-menu labels)
+                                      ...
+                                      (make-object menu-item%
+                                        "change stuff"
+                                        popup-menu
+                                        ; menu callback
+                                        (lambda (item event)
+                                          ...
+                                          (let ([label-and-new-term-pairs
+                                                 (my-tool-get-stuff-to-change labels)])
+                                            ...
+                                            ; callback to the library from within callback to
+                                            ; library-user code
+                                            (user-change-terms label-and-new-term-pairs)
+                                            ...)
+                                          ...)
+                                        ...)
+                                      ...)
+                                    ...)])
+                    ...
+                    ; call to super's method to clean other tools' annotations
+                    (super-clear-annotations)
+                    ...
+                    (drscheme:eval:expand-program
+                     ...
+                     (lambda (syntax-object-or-eof iter)
+                       (if (eof-object? syntax-object-or-eof)
+                           (begin
+                             ...
+                             (send definitions-text color-registered-labels)
+                             ...)
+                           (begin
+                             ...
+                             (my-tool-process-syntax-object ... register-label-with-gui ...)
+                             ...
+                             (iter)))))))))))))))
+  ...)
diff --git a/collects/mrflow/env.ss b/collects/mrflow/env.ss
new file mode 100644
index 0000000000..c5c01b0738
--- /dev/null
+++ b/collects/mrflow/env.ss
@@ -0,0 +1,56 @@
+(module env (lib "mrflow.ss" "mrflow")
+  (require "util.ss")
+  
+  (provide (all-defined))
+  
+  (define create-env (lambda () '()))
+  (define create-tenv (lambda () '()))
+  
+  (define (env-of? domain range)
+    (list-immutable/c (cons-immutable/c (list-immutable/c domain)
+                                        (vector-immutable/c range))))
+  (define tenv? (listof (cons/c (listof symbol?) (vectorof any/c))))
+  
+  (define/contract extend-tenv
+    (tenv? (listof symbol?) (listof any/c) . ->d .
+           (lambda (env vars binders)
+             (unless (= (length vars) (length binders))
+               (error 'extend-tenv "Must have one handle for each var~n~a~n~a" vars binders))
+             tenv?))
+    (lambda (env vars binders)
+      (cons (cons vars (list->vector binders)) env)))
+  
+  (define/contract extend-env
+    ((env-of? symbol? any/c) (list-immutable/c symbol?) (list-immutable/c any/c) . ->d .
+                             (lambda (env vars binders)
+                               (unless (= (length vars) (length binders))
+                                 (error 'extend-tenv "Must have one handle for each var~n~a~n~a" vars binders))
+                               tenv?))
+    (lambda (env vars binders)
+      (cons (cons vars (list->immutable-vector binders)) env)))
+  
+  (define/contract generic-lookup-symbol
+    ((any/c . -> . any) . -> . (tenv? any/c . -> . any))
+    (lambda (not-found-function)
+      (lambda (tenv var)
+        (let loop-env ([env tenv])
+          (if (null? env)
+              (not-found-function var)
+              (let* ([rib (car env)]
+                     [syms (car rib)]
+                     [types (cdr rib)])
+                (let loop-rib ([syms syms] [i 0])
+                  (cond
+                    [(null? syms) (loop-env (cdr env))]
+                    [(equal? (car syms) var) (vector-ref types i)]
+                    [else
+                     (loop-rib (cdr syms) (+ i 1))]))))))))
+  
+  (define/contract lookup-symbol (tenv? symbol? . -> . any)
+    (generic-lookup-symbol
+     (lambda (var)
+       (error 'get-state "Unknown type variable in environment: ~a " var))))
+  
+  (define/contract maybe-lookup-symbol (tenv? symbol? . -> . any)
+    (generic-lookup-symbol (lambda (_) #f)))
+  )
\ No newline at end of file
diff --git a/collects/mrflow/gui.ss b/collects/mrflow/gui.ss
new file mode 100644
index 0000000000..bd736d88f5
--- /dev/null
+++ b/collects/mrflow/gui.ss
@@ -0,0 +1,325 @@
+
+(module gui mzscheme
+  
+  (require
+   (lib "tool.ss" "drscheme")
+   (lib "unitsig.ss")
+   (lib "list.ss")
+   (lib "class.ss")
+   (lib "mred.ss" "mred")
+   (prefix fw: (lib "framework.ss" "framework"))
+   (prefix strcst: (lib "string-constant.ss" "string-constants"))
+   (prefix bit: (lib "bitmap-label.ss" "mrlib"))
+   
+   (prefix cst: "constants.ss")
+   (prefix sba: "constraints-gen-and-prop.ss")
+   (prefix err: "sba-errors.ss")
+   (prefix saa: "snips-and-arrows.ss")
+   )
+  
+  (provide tool@)
+  
+  (define tool@
+    (unit/sig drscheme:tool-exports^
+      (import drscheme:tool^)
+      
+      ; INTERFACE WITH LANGUAGES
+      (define mrflow-language-extension-interface<%>
+        (interface ()
+          render-value-set
+          get-mrflow-primitives-filename))
+      
+      (define (mrflow-default-implementation-mixin super%)
+        (class* super% (mrflow-language-extension-interface<%>)
+          
+          ; type -> string
+          ; Language implementors are responsible for providing a type pretty-printer.
+          ; XXX NOT CURRENTLY USED
+          (define/public (render-value-set val) "render-value-set-mixin not implemented")
+          
+          ; -> string
+          ; Language implementors are responsible for providing the name of the file
+          ; that contains the types of the primitives for their language. If they don't,
+          ; we give a warning, use R5RS, and hope for the best.
+          (define/public (get-mrflow-primitives-filename)
+            (message-box (strcst:string-constant mrflow-using-default-language-title)
+                         (strcst:string-constant mrflow-using-default-language)
+                         #f '(ok))
+            (build-path (collection-path "mrflow")
+                        "primitives"
+                        "r5rs.ss"))
+          
+          (super-instantiate ())))
+      
+      (define (phase1) 
+        (drscheme:language:extend-language-interface mrflow-language-extension-interface<%>
+                                                     mrflow-default-implementation-mixin)
+        (drscheme:unit:add-to-program-editor-mixin saa:extend-all-editors-mixin))
+      
+      (define (phase2) cst:void)
+      
+      
+      (define mrflow-bitmap
+        (bit:bitmap-label-maker
+         (strcst:string-constant mrflow-button-title)
+         (build-path (collection-path "icons") "mrflow-small.bmp")))
+      
+      
+      ; TERM AND SNIP STYLES
+      (define can-click-style-delta (make-object style-delta% 'change-weight 'bold))
+      (send can-click-style-delta set-delta-foreground "purple")
+      
+      (define green-style-delta (make-object style-delta% 'change-weight 'bold))
+      (send green-style-delta set-delta-foreground "green")
+      (send green-style-delta set-underlined-on #t)
+      
+      (define orange-style-delta (make-object style-delta% 'change-weight 'bold))
+      (send orange-style-delta set-delta-foreground "orange")
+      (send orange-style-delta set-underlined-on #t)
+      
+      (define red-style-delta (make-object style-delta% 'change-weight 'bold))
+      (send red-style-delta set-delta-foreground "red")
+      (send red-style-delta set-underlined-on #t)
+      
+      ; symbol style-delta% -> style-delta%
+      ; compares two style-deltas (one represented as a color/severity name, the other one as
+      ; an actual style-delta) and returns the most "urgent" one.
+      ; red > orange > green
+      (define (max-style-delta-by-name style-delta-name style-delta)
+        (case style-delta-name
+          [(red) red-style-delta]
+          [(orange) (if (eq? style-delta red-style-delta) style-delta orange-style-delta)]
+          [(green) style-delta]
+          [else (error 'max-style-delta-by-name
+                       "MrFlow internal error; incomparable style-delta ~a"
+                       style-delta-name)]))
+      
+      ; sba-state  label -> style-delta%
+      ; If the label has errors associated with it, we color the term with the color
+      ; of the worst error, otherwise we color it with the normal clickable style-delta.
+      (define (get-style-delta-from-label sba-state label)
+        (let ([errors (sba:get-errors-from-label sba-state label)])
+          (if (null? errors)
+              can-click-style-delta
+              (foldl (lambda (sba-error current-max-style-delta)
+                       (max-style-delta-by-name (err:sba-error-gravity sba-error) current-max-style-delta))
+                     green-style-delta
+                     errors))))
+      
+      ; sba-state label -> exact-non-negative-integer
+      ; span conversation: for all graphical purposes, the span of a compound expression is 1,
+      ; to highlight only the opening parenthesis. Otherwise we might highlight subexpressions
+      ; with the wrong color.
+      (define (get-span-from-label sba-state label)
+        (if (or (sba:is-label-atom? label)
+                );(not (null? (sba:get-errors-from-label sba-state label))))
+            (sba:get-span-from-label label)
+            1))
+      
+      ; (listof (cons symbol string))
+      ; Lists the possible snip types and their corresponding colors.
+      ; For a given term that has snips of several different types, the snips will be
+      ; ordered from left to right in the editor in the same order as their types appear
+      ; in this list.
+      (define snip-types-and-colors
+        '((type . "blue")
+          (error . "red")))
+      
+      
+      ; INTERFACE FOR MENUS
+      ; symbol symbol -> string
+      ; given a snip type and a menu action for snips (show/hide), return the corresponding
+      ; menu text
+      (define (get-menu-text-from-snip-type type action)
+        (case type
+          [(type)
+           (case action
+             [(show) (strcst:string-constant mrflow-popup-menu-show-type)]
+             [(hide) (strcst:string-constant mrflow-popup-menu-hide-type)]
+             [else (error 'get-menu-text-from-type "MrFlow internal error; unknown type action: ~a" action)])]
+          [(error)
+           (case action
+             [(show) (strcst:string-constant mrflow-popup-menu-show-errors)]
+             [(hide) (strcst:string-constant mrflow-popup-menu-hide-errors)]
+             [else (error 'get-menu-text-from-type "MrFlow internal error; unknown error action: ~a" action)])]
+          [else (error 'get-menu-text-from-type "MrFlow internal error; unknown type: ~a" type)]))
+      
+      ; sba-state symbol label -> (listof string)
+      ; given a snip type and a lable, returns the content of the snips to be
+      ; added for that type and label.
+      (define (get-snip-text-from-snip-type sba-state type label)
+        (case type
+          [(type) (list (sba:pp-type sba-state (sba:get-type-from-label sba-state label) 'gui))]
+          [(error) (map err:sba-error-message (sba:get-errors-from-label sba-state label))]))
+      
+      
+      ; DEFINITION WINDOW MIXIN
+      (drscheme:get/extend:extend-definitions-text saa:extend-top-editor-mixin)
+      
+      (drscheme:get/extend:extend-tab
+       (mixin (drscheme:rep:context<%> drscheme:unit:tab<%>) ()
+         (inherit get-defs)
+         (define/augment (clear-annotations)
+           (inner (void) clear-annotations)
+           (send (get-defs) remove-all-snips-and-arrows-and-colors))
+         (super-new)))
+      
+      ; UNIT FRAME MIXIN
+      (drscheme:get/extend:extend-unit-frame
+       (lambda (super%)
+         (class super%
+           (inherit get-definitions-text get-current-tab)
+           ; -> void
+           
+           ; -> void
+           (define/augment (enable-evaluation)
+             (inner cst:void enable-evaluation)
+             (send analyze-button enable #t))
+           
+           ; -> void
+           (define/augment (disable-evaluation)
+             (inner cst:void disable-evaluation)
+             (send analyze-button enable #f))
+           
+           (super-instantiate ())
+           
+           
+           (inherit get-button-panel get-interactions-text)
+           (define analyze-button
+             (instantiate
+                 button% ()
+               (label (mrflow-bitmap this))
+               (parent (get-button-panel))
+               (callback
+                (lambda (button event)
+                  (let ([start-time (current-milliseconds)]
+                        [definitions-text (get-definitions-text)]
+                        [drs-eventspace (current-eventspace)]
+                        [interactions-text (get-interactions-text)]
+                        [language-settings
+                         (fw:preferences:get
+                          (drscheme:language-configuration:get-settings-preferences-symbol))])
+                    (letrec-values
+                        ([(user-change-terms register-label-with-gui)
+                          (saa:init-snips-and-arrows-gui
+                           definitions-text
+                           sba:get-source-from-label
+                           sba:get-mzscheme-position-from-label
+                           (lambda (label) (get-span-from-label sba-state label))
+                           sba:get-arrows-from-labels
+                           (lambda (label) (get-style-delta-from-label sba-state label))
+                           (lambda (menu labels) cst:void)
+                           get-menu-text-from-snip-type
+                           (lambda (type label) (get-snip-text-from-snip-type sba-state type label))
+                           snip-types-and-colors
+                           #t)
+                          ; snips-and-arrows library testing...
+;                          (saa:init-snips-and-arrows-gui
+;                           definitions-text
+;                           sba:get-source-from-label
+;                           sba:get-mzscheme-position-from-label
+;                           (lambda (label) (get-span-from-label sba-state label))
+;                           sba:get-arrows-from-label
+;                           (lambda (label) (get-style-delta-from-label sba-state label))
+;                           (lambda (menu labels)
+;                             (let* ([new-name-callback
+;                                     (lambda (item event)
+;                                       (let ([new-name
+;                                              (fw:keymap:call/text-keymap-initializer
+;                                               (lambda ()
+;                                                 (get-text-from-user
+;                                                  "rename"
+;                                                  "rename")))]
+;                                             [terms (append
+;                                                     (map
+;                                                      (lambda (arrow-info)
+;                                                        (cons (car arrow-info) "foo"))
+;                                                      (sba:get-arrows-from-labels labels))
+;                                                     (map
+;                                                      (lambda (arrow-info)
+;                                                        (cons (cadr arrow-info) "foo"))
+;                                                      (sba:get-arrows-from-labels labels))
+;                                                     )])
+;                                         (user-change-terms terms)))])
+;                               (make-object menu-item%
+;                                 (strcst:string-constant cs-rename-id)
+;                                 menu
+;                                 new-name-callback)))
+;                           get-menu-text-from-snip-type
+;                           (lambda (type label) (get-snip-text-from-snip-type sba-state type label))
+;                           snip-types-and-colors
+;                           #f)
+                          ]
+                         [(sba-state) (sba:make-sba-state register-label-with-gui)])
+                      ; disable-evaluation will lock the editor, so hopefully all the other tools
+                      ; unlock the editor to clear their crap (note that the second call below
+                      ; is a call to the superclass, so remove-all-snips-and-arrows-and-colors
+                      ; is not called here, but is called internally inside
+                      ; init-snips-and-arrows-gui
+                      (disable-evaluation)
+                      (send (get-current-tab) clear-annotations)
+                      
+                      ; note: we have to do this each time, because the user might have changed
+                      ; the language between analyses.
+                      (let* ([language-object (drscheme:language-configuration:language-settings-language
+                                               language-settings)]
+                             [primitive-table-file (send language-object get-mrflow-primitives-filename)])
+                        (if (file-exists? primitive-table-file)
+                            (begin
+                              (sba:initialize-primitive-type-schemes sba-state primitive-table-file)
+                              (drscheme:eval:expand-program
+                               (drscheme:language:make-text/pos definitions-text
+                                                                0
+                                                                (send definitions-text last-position))
+                               language-settings
+                               #t
+                               ; set current-directory and current-load-relative-directory before expansion
+                               (lambda ()
+                                 (let* ([tmp-b (box #f)]
+                                        [fn (send definitions-text get-filename tmp-b)])
+                                   (unless (unbox tmp-b)
+                                     (when fn
+                                       (let-values ([(base name dir?) (split-path fn)])
+                                         (current-directory base)
+                                         (current-load-relative-directory base))))))
+                               void
+                               (lambda (syntax-object-or-eof iter)
+                                 (if (eof-object? syntax-object-or-eof)
+                                     (parameterize ([current-eventspace drs-eventspace])
+                                       (queue-callback
+                                        (lambda () ; =drs=
+                                          (let ([sba-end-time (current-milliseconds)])
+                                            ;(printf "sba time: ~a ms~n" (- (current-milliseconds) start-time))
+                                            (sba:check-primitive-types sba-state)
+                                            ;(printf "check time: ~a ms~n" (- (current-milliseconds) sba-end-time))
+                                            )
+                                          ; color everything right before re-enabling buttons
+                                          (send definitions-text color-registered-labels)
+                                          (enable-evaluation)
+                                          )))
+                                     (begin
+                                       (parameterize ([current-eventspace drs-eventspace])
+                                         (queue-callback
+                                          (lambda () ; =drs=
+                                            ;(printf "syntax: ~a~n" (syntax-object->datum syntax-object-or-eof))
+                                            (sba:create-label-from-term sba-state syntax-object-or-eof '() #f))))
+                                       ; must be outside the parameterize so the next expansion occurs
+                                       ; in the right eventspace...
+                                       (iter))))))
+                            ; get-mrflow-primitives-filename defaults to R5RS
+                            ; (see mrflow-default-implementation-mixin above), so if we arrive here,
+                            ; we know we are in trouble because it means no primitive table is
+                            ; defined for the current language and we couldn't even find the table
+                            ; for the R5RS primitives.
+                            (error 'analyze-button-callback
+                                   "MrFlow internal error; R5RS primitive types file ~a doesn't exist."
+                                   primitive-table-file)))))))))
+           
+           (send (get-button-panel) change-children
+                 (lambda (button-list)
+                   (cons analyze-button (remq analyze-button button-list))))
+           ) ; class
+         )) ; drscheme:get/extend:extend-unit-frame
+      
+      )) ; tool@ unit/sig
+  ); module
diff --git a/collects/mrflow/hashcons.ss b/collects/mrflow/hashcons.ss
new file mode 100644
index 0000000000..1750c4cbed
--- /dev/null
+++ b/collects/mrflow/hashcons.ss
@@ -0,0 +1,1322 @@
+(module hashcons (lib "mrflow.ss" "mrflow")
+  (require (prefix list: (lib "list.ss"))
+           (lib "match.ss")
+           (lib "pretty.ss")
+           (lib "etc.ss")
+           (prefix string: (lib "string.ss"))
+           
+           (prefix cst: "constants.ss")
+           "dfa.ss"
+           "trie.ss"
+           "labels.ss"
+           "types.ss"
+           "set-hash.ss"
+           "env.ss"
+           "util.ss")
+  
+  (provide
+   ;; Create a new hashcons table
+   make-hashcons-table
+   
+   ;; Convert a type to a handle
+   hashcons-type
+   ;; Get the type of a handle
+   get-type
+   
+   ;; Get a pretty string from a handle
+   handle->string
+   handle->list
+   
+   hashcons-table->list
+   hashcons-table->dot
+   handles->dot
+   
+   ;; contract functions
+   hashcons-table?
+   hashcons-type?
+   
+   ;; functions used in testing
+   ;hashcons-table-size
+   
+   ;; debug functions
+   ;hashcons-acyclic-subtrees
+   )
+  
+  ;; Debugging settings
+  ;(print-struct #t)
+  ;(print-hash-table #t)
+  ;(pretty-print-columns 105)
+  
+  ;; Some predicates for contracts
+  (define label-type? (union type-case-lambda? type-cons? type-promise?
+                             type-struct-value? type-union? type-values? type-vector?))
+  (define base-type? (union type-empty? type-cst? type-struct-type?))
+  (define hashcons-type? (union label-type? base-type? type-rec?))
+  
+  ;;
+  ;; Hashcons tables
+  ;;
+  (define-struct hashcons-table
+    (from-handle     ;; handle -> (union dfa label base-type)
+     from-dfa        ;; dfa -> handle
+     from-label      ;; label -> handle
+     from-base-type  ;; base-type -> handle
+     dfa-trie        ;; type -> trie, handle -> handle
+     number-handles)
+    (make-inspector))
+  
+  (set! make-hashcons-table
+	(let ([old-make-hashcons-table make-hashcons-table])
+	  (lambda ()
+	    (old-make-hashcons-table
+	     (make-hash-table)
+	     (make-hash-table 'equal) 
+	     (make-hash-table 'equal) 
+	     (make-hash-table 'equal)
+	     (make-trie)
+	     0))))
+  
+  (define list-of-handles? (lambda (xs) (and (list? xs) (andmap handle? xs))))
+  
+  (define get-next-handle
+    (lambda (tbl)
+      (let ([x (hashcons-table-number-handles tbl)])
+        (set-hashcons-table-number-handles! tbl (+ x 1))
+        x)))
+  
+  (define hashcons-table-size
+    (lambda (tbl)
+      (hashcons-table-number-handles tbl)))
+  
+  (define get-type-handle
+    (lambda (tbl type)
+      (hash-table-get
+       (hashcons-table-from-base-type tbl) type
+       (lambda ()
+         (hash-table-get
+          (hashcons-table-from-label tbl) type
+          (lambda () (hash-table-get (hashcons-table-from-dfa tbl) type
+                                     (lambda ()
+				       (error 'get-type-handle "Type ~a not in hashcons table: ~a"
+                                              type (hashcons-table->list tbl))))))))))
+  
+  (define/contract get-type (hashcons-table? handle? . -> . hashcons-type?)
+    (lambda (tbl handle)
+      (hash-table-get (hashcons-table-from-handle tbl) handle
+                      (lambda () (error 'get-type "Handle: ~a not in hashcons table" handle)))))
+  
+  (define has-handle?
+    (lambda (tbl handle)
+      (hash-table-get (hashcons-table-from-handle tbl) handle cst:thunk-false)))
+  
+  (define has-base-type?
+    (lambda (tbl base-type)
+      (hash-table-get (hashcons-table-from-base-type tbl) base-type cst:thunk-false)))
+  
+  (define has-label-type?
+    (lambda (tbl label-type)
+      (hash-table-get (hashcons-table-from-label tbl) label-type cst:thunk-false)))
+  
+  (define has-dfa-type?
+    (lambda (tbl dfa-type)
+      (hash-table-get (hashcons-table-from-dfa tbl) dfa-type cst:thunk-false)))
+  
+  (define has-type?
+    (lambda (tbl type)
+      (or (has-base-type? tbl type) (has-label-type? tbl type) (has-dfa-type? tbl type))))
+  
+  (define/contract add-base-type
+    (hashcons-table? base-type? . ->d .
+                     (lambda (tbl base-type)
+                       (when (has-base-type? tbl base-type)
+                         (error 'add-base-type "Already have hashconsed ~a" base-type))
+                       handle?))
+    (lambda (tbl base-type)
+      (let ([h (get-next-handle tbl)])
+        (hash-table-put! (hashcons-table-from-handle tbl) h base-type)
+        (hash-table-put! (hashcons-table-from-base-type tbl) base-type h)
+        h)))
+  
+  (define/contract add-label-type
+    (hashcons-table? label-type? . ->d . 
+                     (lambda (tbl label-type)
+                       (when (has-label-type? tbl label-type)
+                         (error 'add-label-type "Label Type ~a already present in hashcons table" label-type))
+                       (when (has-dfa-type? tbl label-type)
+                         (error 'add-label-type "Label Type ~a is equivalent to DFA type" label-type))
+                       handle?))
+    (lambda (tbl label-type)
+      (let ([h (get-next-handle tbl)])
+        (hash-table-put! (hashcons-table-from-handle tbl) h label-type)
+        (hash-table-put! (hashcons-table-from-label tbl) label-type h)
+        h)))
+  
+  ;; add-dfa-type is slightly different from add-label-type and
+  ;; and-base-type in that it needs to take its handle as an argument.
+  ;; This is because we need to substitute all state numbers for
+  ;; handle numbers in all states of the DFA prior to adding it to
+  ;; them hashcons table.
+  (define/contract add-dfa-type
+    (hashcons-table? label-type? handle? . ->d . 
+                     (lambda (tbl dfa-type handle)
+                       (when (has-dfa-type? tbl dfa-type)
+                         (error 'add-dfa-type "DFA Type ~a already present in ~a" dfa-type (hashcons-table->list tbl)))
+                       handle?))
+    (lambda (tbl dfa-type handle)
+      (hash-table-put! (hashcons-table-from-handle tbl) handle dfa-type)
+      (hash-table-put! (hashcons-table-from-dfa tbl) dfa-type handle)
+      handle))
+  
+  (define/contract recall-base-type (hashcons-table? type? . -> . handle?)
+    (lambda (tbl base-type)
+      (if (has-base-type? tbl base-type)
+          (hash-table-get (hashcons-table-from-base-type tbl) base-type)
+          (add-base-type tbl base-type))))
+  
+  (define/contract recall-label-type (hashcons-table? label-type? . -> . handle?)
+    (lambda (tbl label-type)
+      (cond
+        [(has-dfa-type? tbl label-type) (hash-table-get (hashcons-table-from-dfa tbl) label-type)]
+        [(has-label-type? tbl label-type) (hash-table-get (hashcons-table-from-label tbl) label-type)]
+        [else (add-label-type tbl label-type)])))
+  
+  ; Hashcons-type is the main function.
+  ; 
+  ; Hashconsing proceedings in two main stages. We first hashcons as
+  ; much as possible in a straight forward, bottom up fashion.  If
+  ; there is no recursive types, then we are done and just return the
+  ; handle. If there is a recursive type, then it is necessary to
+  ; hashcons the recursive type in a bottom up fashion whenever a
+  ; type has no free variables.
+  (define/contract hashcons-type (hashcons-table? hashcons-type? . -> . handle?)
+    (lambda (tbl type)
+      (let ([size (hashcons-table-size tbl)]
+            [v (let ([type (hashcons-acyclic-subtrees tbl type)])
+                 (if (handle? type) type
+                     (bottom-up-hashcons tbl type)))])
+        v)))
+  
+  ; Hashcons all subtrees in a type containing no variables. Returns
+  ; a type where all subtrees w/o variables are replaced by the
+  ; corresponding handle. All label types which remain, have at least
+  ; one children which contain a variable.
+  ;
+  ; After hashconsing all of the children of a type, if there is a
+  ; child which has not been replaced by a handle then we have a
+  ; recursive type and we do not hashcons the label. If the children
+  ; are all handles, we hashcons this label and return its handle in
+  ; place of the label.
+  (define hashcons-acyclic-subtrees
+    (lambda (tbl type)
+      ((fold-type
+        (lambda (handle) handle)                   ;; handle       :: handle -> b
+        (lambda (rest-args req-args argss exps)    ;; case-lambda  :: [bool] [nat] [[b]] [b] -> b
+          (let ([new-case-lambda (make-type-case-lambda
+                                  (if (list? rest-args) (list->vector rest-args) rest-args)
+                                  (if (list? req-args) (list->vector req-args) req-args)
+                                  argss exps)])
+            (if (and (vector-of-vector-of? handle? argss) (vector-of? handle? exps))
+                (recall-label-type tbl new-case-lambda)
+                new-case-lambda)))
+        (lambda (hd tl)                            ;; cons         :: b b -> b
+          (let ([new-type-cons (make-type-cons hd tl)])
+            (if (and (handle? hd) (handle? tl))
+                (recall-label-type tbl new-type-cons)
+                new-type-cons)))
+        (lambda (ty)                               ;; cst          :: any/c -> b
+          (recall-base-type tbl (make-type-cst ty)))
+        (let ((empty (make-type-empty)))           ;; empty        :: -> b
+          (lambda ()
+            (recall-base-type tbl empty)))
+        (lambda (type)                             ;; promise      :: b -> b
+          (let ([new-type-promise (make-type-promise type)])
+            (if (handle? type)
+                (recall-label-type tbl new-type-promise)
+                new-type-promise)))
+        (lambda (vars types body)                  ;; rec          :: [b] [b] b -> b
+          (let* ([new-type-rec (make-type-rec vars types body)])
+            (if (and (list-of-handles? types) (handle? body))
+                body
+                new-type-rec)))
+        (lambda (label)                            ;; struct-type  :: label -> b
+          (recall-base-type tbl (make-type-struct-type label)))
+        (lambda (label types)                      ;; label        :: [b] -> b
+          (let ([new-type (make-type-struct-value label types)])
+            (if (list-of-handles? types)
+                (recall-label-type tbl new-type)
+                new-type)))
+        (lambda (elements)                         ;; union        :: [b] -> b
+	  (cond [(null? elements) (recall-base-type tbl (make-type-empty))]
+		[(length-one? elements) (car elements)]
+		[(list-of-handles? elements)
+		 (let* ([elements (min-list-numbers elements)])
+		   (cond
+                     [(length-one? elements) (car elements)]
+                     [else
+                      (recall-label-type tbl (make-type-union elements))]))]
+		[else (make-type-union elements)]))
+        (lambda (type)                             ;; values       :: b -> b
+          (let ([new-type-values (make-type-values type)])
+            (if (handle? type)
+                (recall-label-type tbl new-type-values)
+                new-type-values)))
+        make-type-var                              ;; var          :: name boolean boolean -> b
+        (lambda (type)                             ;; vector       :: b -> b
+          (let ([new-type-vector (make-type-vector type)])
+            (if (handle? type)
+                (recall-label-type tbl new-type-vector)
+                new-type-vector))))
+       type)))
+  
+  ;; After we've hashconsed a recursive type this does the final job
+  ;; of adding it to the hashcons table.
+  (define/contract hashcons-rec-type-body (hashcons-table? (union type? handle?) . -> . (union type? handle?))
+    (lambda (tbl type)
+      (let ([recall-type (lambda (type) (if (has-type? tbl type)
+                                            (get-type-handle tbl type)
+                                            (recall-label-type tbl type)))])
+        ((fold-type
+          (lambda (handle) handle)                   ;; handle       :: handle -> b
+          (lambda (rest-args req-args argss exps)    ;; case-lambda  :: [bool] [bool] [[b]] [b] -> b
+            (recall-type (make-type-case-lambda rest-args req-args argss exps)))
+          (lambda (hd tl)                            ;; cons         :: b b -> b
+            (recall-type (make-type-cons hd tl)))
+          (lambda (ty)                               ;; cst          :: any/c -> b
+            (error 'hashcons-rec-type-body "type-cst should have been previously hashconsed"))
+          (lambda ()                                 ;; empty        :: -> b
+            (error 'hashcons-rec-type-body "type-empty should have been previously hashconsed"))
+          (lambda (type)                             ;; promise      :: b -> b
+            (recall-type (make-type-promise type)))
+          (lambda (vars types body)                  ;; rec          :: [b] [b] b -> b
+            (error 'hashcons-rec-type-body "Should not have a type-rec DFA at this point"))
+          (lambda (label)                            ;; struct-type
+            (error 'hashcons-rec-type-body "struct-type should have been hashcons already"))
+          (lambda (label types)                      ;; struct-value
+            (recall-type (make-type-struct-value label types)))
+          (lambda (elements)                         ;; type-union [b] -> b
+	    (let ([elements (min-list-numbers elements)])
+	      (cond [(length-one? elements) 
+                     ;; TBD seems suspiscious
+                     ;; if there is only one element then the union
+                     ;; containing it was redundant and perhaps the
+                     ;; type should be reconsidered
+                     (car elements)]
+		    [else
+		     (recall-type (make-type-union elements))])))
+          (lambda (type)                             ;; type-values       ;; b -> b
+            (recall-type (make-type-values type)))
+          (lambda (name reach handle)                ;; type-var          ;; b -> b
+            (error 'hashcons-rec-type-body "Should not have type-var at this point"))
+          (lambda (type)                             ;; type-vector       ;; b -> b
+            (recall-type (make-type-vector type))))
+         type))))
+  
+  ;; Almost the same as acyclic hashcons except when we reach a
+  ;; rec-type with no free variables we hashcons it.
+  ;; 
+  ;; Perhaps this could be merged w/ acyclic hashcons. The code is
+  ;; almost identical
+  (define/contract bottom-up-hashcons
+    (hashcons-table? hashcons-type? . ->d . (lambda (tbl type) handle?))
+    (lambda (tbl type)
+      (let
+          ([hashcons
+            (fold-type
+             (lambda (handle) handle)                 ;; handle       :: handle -> b
+             (lambda (rest-args req-args argss exps)  ;; case-lambda  :: [bool] [bool] [[b]] [b] -> b
+               (let ([new-case-lambda (make-type-case-lambda rest-args req-args argss exps)])
+                 (if (and (vector-of-vector-of? handle? argss)
+                          (vector-of? handle? exps))
+                     (recall-label-type tbl new-case-lambda)
+                     new-case-lambda)))
+             (lambda (hd tl)                          ;; cons         :: b b -> b
+               (let ([new-type-cons (make-type-cons hd tl)])
+                 (if (and (handle? hd) (handle? tl))
+                     (recall-label-type tbl new-type-cons)
+                     new-type-cons)))
+             (lambda (type)                           ;; cst          :: any/c -> b
+               (recall-base-type tbl type))
+             (lambda ()                               ;; empty        :: -> b
+               (recall-base-type tbl (make-type-empty)))
+             (lambda (value)                          ;; promise      :: b -> b
+               (let ((new-type-promise (make-type-promise value)))
+                 (if (handle? value)
+                     (recall-label-type tbl new-type-promise)
+                     new-type-promise)))
+             (bottom-up-hashcons-rec-type tbl)
+             (lambda (label)                            ;; type-struct-type 
+               (recall-base-type tbl (make-type-struct-type label)))
+             (lambda (label types)                      ;; type-struct-value
+               (let ([new-type (make-type-struct-value label types)])
+                 (if (list-of-handles? types)
+                     (recall-label-type tbl new-type)
+                     new-type)))
+             (lambda (elements)           ;; type-union [b] -> b
+               (if (list-of-handles? elements)
+                   (let* ([elements (min-list-numbers elements)])
+                     (cond
+                       [(null? elements) (recall-base-type tbl (make-type-empty))]
+                       [(length-one? elements) (car elements)]
+                       [else
+                        (recall-label-type tbl (make-type-union elements))]))
+                   (make-type-union elements)))
+             (lambda (type)               ;; type-values       ;; b -> b
+               (let ((new-type-values (make-type-values type)))
+                 (if (handle? type)
+                     (recall-label-type tbl new-type-values)
+                     new-type-values)))
+             make-type-var
+             (lambda (element)            ;; type-vector      ;; b -> b
+               (let ((new-type-vector (make-type-vector element)))
+                 (if (handle? element)
+                     (recall-label-type tbl new-type-vector)
+                     new-type-vector))))])
+        (hashcons type))))
+  
+  (define/contract bottom-up-hashcons-rec-type
+    (hashcons-table? . -> . ((listof type-var?) (listof (union type? handle?)) (union type? handle?) . ->d .
+                                                (lambda (vars types body)
+                                                  (when (has-free-vars? (make-type-rec vars types body))
+                                                    (error 'bottom-up-hashcons "~a has free type variables~n" (make-type-rec vars types body)))
+                                                  handle?)))
+    (lambda (tbl)
+      (lambda (vars types body)                ;; rec          :: [b] [b] b -> b
+        (let*-values
+            ([(vars types body)
+              (if (type-var? body)
+                  (values vars types body)
+                  (let ([newvar (make-type-var (gensym) #f #f)])
+                    (values (cons newvar vars) (cons body types) newvar)))]
+             [(graph bindings)
+              (let ([graph (make-hash-table)]
+                    [bindings (make-hash-table)])
+                (for-each (lambda (var type)
+                            (hash-table-put! graph (type-var-name var) (get-referenced-vars type))
+                            (hash-table-put! bindings (type-var-name var) type))
+                          vars types)
+                (values graph bindings))]
+             [(sccs) (strongly-connected-components graph)]
+             [(env)
+              (list:foldl (lambda (scc env)
+                            (hashcons-scc tbl scc graph bindings env))
+                          (create-tenv)
+                          sccs)])
+          (lookup-symbol env (type-var-name body))))))
+  
+  (define/contract hashcons-scc (hashcons-table? (listof any/c) hash-table? hash-table? tenv? . -> . tenv?)
+    (lambda (tbl scc graph bindings env)
+      (cond
+        ;; The SCC is actually a recursive type
+        [(and (length-one? scc) (memq (car scc) (hash-table-get graph (car scc))))
+         (let*-values ([(ty) (make-type-rec (list (make-type-var (car scc) #f #f))
+                                            (list (hash-table-get bindings (car scc)))
+                                            (make-type-var (car scc) #f #f))]
+                       [(ty) (subst-handles/vars-if-possible ty env)]
+                       [(ty) (hashcons-acyclic-subtrees tbl ty)]                       
+                       [(dfa binder-states) (create-dfa-from-type ty env)]
+                       [(min-dfa min-binder-stnums) (minimize-dfa dfa binder-states)]
+                       [(min-stnum->handle)
+                        (let ([greatest-handle (greatest-handle min-dfa)])
+                          (if greatest-handle
+                              (recursive-with-handle tbl min-dfa
+                                                     (map state-number
+                                                          (list:filter
+                                                           (lambda (s)
+                                                             (not (handle-state? s)))
+                                                           (get-ordered-states min-dfa)))
+                                                     greatest-handle)
+                              #f))]
+                       [(binder-handles)
+                        (if min-stnum->handle
+                            (map (lambda (stnum)
+                                   (hash-table-get min-stnum->handle stnum))
+                                 min-binder-stnums)
+                            (let ([min-stnum->handle (recall-entire-dfa tbl min-dfa)])
+                              (map (lambda (minstnum)
+                                     (hash-table-get min-stnum->handle minstnum))
+                                   min-binder-stnums)))]
+                       ;(let* ([min-states (get-ordered-states min-dfa)]
+                       ;       [all-handles (recall-entire-dfa tbl min-dfa)])
+                       ;  (let loop ([all-states min-states]
+                       ;             [all-handles all-handles])
+                       ;    (if (= (state-number (car all-states)) (car min-binder-stnums))
+                       ;        (list (car all-handles))
+                       ;        (loop (cdr all-states) (cdr all-handles))))))]
+                       )
+           (extend-tenv env scc binder-handles))]
+        
+        [(length-one? scc)
+         (let* ([var (car scc)]
+                [ty (hash-table-get bindings var)]
+                [ty-no-vars (subst-handles/vars ty env)]
+                [handle (hashcons-rec-type-body tbl ty-no-vars)])
+           (extend-tenv env (list var) (list handle)))]
+        
+        [else
+         (let*-values
+             ([(ty) (make-type-rec (map (lambda (v) (make-type-var v #f #f)) scc)
+                                   (map (lambda (v) (hash-table-get bindings v)) scc)
+                                   (make-type-var (car scc) #f #f))]
+              [(ty) (subst-handles/vars-if-possible ty env)]
+              [(ty) (hashcons-acyclic-subtrees tbl ty)]
+              [(dfa binder-stnums) (create-dfa-from-type ty env)]
+              [(min-dfa min-binder-stnums) (minimize-dfa dfa binder-stnums)]
+              [(min-states) (get-ordered-states min-dfa)]
+              [(stnum->handle)
+               (let* ([greatest-handle (greatest-handle min-dfa)])
+                 (if greatest-handle
+                     (recursive-with-handle tbl min-dfa
+                                            (map state-number
+                                                 (list:filter
+                                                  (lambda (s)
+                                                    (not (handle-state? s)))
+                                                  min-states))
+                                            greatest-handle)
+                     #f))]
+              [(binder-handles) (if stnum->handle
+                                    (map (lambda (stnum) (hash-table-get stnum->handle stnum)) min-binder-stnums)
+                                    (let ([stnum->handle (recall-entire-dfa tbl min-dfa)])
+                                      (map (lambda (stnum)
+                                             (hash-table-get stnum->handle stnum))
+                                           min-binder-stnums)))]
+              ;[(handles) (if stnum->handle #f (recall-entire-dfa tbl min-dfa))]
+              ;[(binder-handles)
+              ; (if handles
+              ;     (letrec ([position
+              ;               (lambda (state-num xs counter)
+              ;                 (cond [(null? xs) (error 'not-found)]
+              ;                       [(= (state-number (car xs)) state-num) counter]
+              ;                       [else (position state-num (cdr xs) (add1 counter))]))])
+              ;       (map (lambda (pos) (list-ref handles pos))
+              ;            (map (lambda (state) (position state min-states 0)) min-binder-stnums)))
+              ;     (map (lambda (stnum) (hash-table-get stnum->handle stnum)) min-binder-stnums))]
+              )
+           (extend-tenv env scc binder-handles))])))
+  
+  ;; If this DFA has been hashconsed return its handle, otherwise add it to the
+  ;; hashcons table and the trie.
+  (define/contract recall-entire-dfa
+    (hashcons-table? dfa? . ->d .
+                     (lambda (tbl dfa)
+                       (lambda (ht)
+                         (when (hash-table? ht)
+                           (unless (= (get-dfa-size dfa) (hash-table-size ht))
+                             (error 'recall-entire-dfa "Missing or extra states in state->handle map~ndfa=~a~nstate->handle=~a" dfa ht))
+                           (for-each (lambda (st) (unless (hash-table-get ht (state-number st) cst:thunk-false)
+                                                    (error 'recall-entire-dfa
+                                                           "No matching state ~s  map~ndfa=~a~nstate->handle=~a" st (dfa->list dfa)
+                                                           (hash-table-map ht (lambda (k v) (cons k v))))))
+                                     (get-ordered-states dfa)))
+                         #t)))
+    (lambda (hashcons-table dfa)
+      (let* ([states (get-ordered-states dfa)]
+             [trie (hashcons-table-dfa-trie hashcons-table)]
+             [maybe-handles (dfa-present? trie states)])
+        (or (and maybe-handles
+                 (make-immutable-hash-table (map (lambda (state handle)
+                                                   (cons-immutable (state-number state) handle))
+                                                 states maybe-handles)))
+            (let* ([new-handles
+                    (map (lambda (state) (if (handle-state? state)
+                                             (handle-state-handle state)
+                                             (get-next-handle hashcons-table)))
+                         states)]
+                   [stnum->handle
+                    (letrec ([tbl (make-hash-table)]
+                             [stnum->state (dfa-stnum->state dfa)]
+                             [close (lambda (st ancest)
+                                      (if (and (union-state? st)
+                                               (length-one? (union-state-elements st)))
+                                          (if (memq (state-number st) ancest)
+                                              (error 'cycle-of-empty-unions-detected)
+                                              (close (hash-table-get stnum->state (car (union-state-elements st)))
+                                                     (cons (state-number st) ancest)))
+                                          st))])
+                      (for-each (lambda (state handle)
+                                  (hash-table-put! tbl (state-number state) handle))
+                                states new-handles)
+                      (for-each (lambda (state)
+                                  (hash-table-put! tbl (state-number state)
+                                                   (hash-table-get tbl (state-number (close state null)))))
+                                states)
+                      
+                      ;; This is mildly funky, if there is a union of length one, we will close it
+                      ;; and the state will point to the handle of its single element, but the union
+                      ;; will still be a state in the dfa (and therefore a key in the trie, although
+                      ;; it will never be refered to in the types representing the dfa i.e. an
+                      ;; unused handle)
+                      
+                      tbl)]
+                   [lookup
+                    (lambda (stnum) (hash-table-get stnum->handle stnum))]
+                   [subst-handle/state
+                    (match-lambda
+                      [($ cons-state state hd tl)
+                       (make-type-cons (lookup hd) (lookup tl))]
+                      [($ case-lambda-state state rest-arg?s req-args argss exps)
+                       (make-type-case-lambda rest-arg?s
+                                              req-args
+                                              (map-vector-of-vector lookup argss)
+                                              (map-vector lookup exps))]
+                      [($ union-state state elements)
+                       (let ([handles (min-list-numbers (map lookup elements))])
+                         (if (length-one? handles) (car handles)
+                             (make-type-union handles)))]  ;; double check this 
+                      [($ promise-state state value)
+                       (make-type-promise (lookup value))]
+                      [($ struct-value-state state label types)
+                       (make-type-struct-value label (map lookup types))]
+                      [($ values-state state types)
+                       (make-type-values (lookup types))]
+                      [($ vector-state state element)
+                       (make-type-vector (lookup element))]
+                      [x (error 'recall-entire-dfa "Unmatched type ~a" x)])])
+              (add-dfa-states trie states new-handles)
+              (for-each (lambda (dfa-state handle)
+                          (unless (handle-state? dfa-state)
+                            (let ([handle-or-state (subst-handle/state dfa-state)])
+                              (unless (handle? handle-or-state)
+                                (add-dfa-type hashcons-table handle-or-state handle)))))
+                        states new-handles)
+              stnum->handle)))))
+  
+  ;; Almost a fold, with the exception of the type-rec-type binding variables which we do not
+  ;; recurse on. 
+  (define fold-type
+    (lambda (handlef       ;; handle -> b
+             case-lambdaf  ;; [bool] [int] [[b]] [b] -> b
+             consf         ;; b b -> b
+             cstf          ;; any/c -> b
+             emptyf        ;; -> b
+             promisef      ;; b -> b
+             recf          ;; [b] [b] b -> b
+             struct-typef  ;; label -> b
+             struct-valuef ;; label [b] -> b
+             unionf        ;; [b] -> b
+             valuesf       ;; b -> b
+             varf          ;; name bool -> b
+             vectorf)      ;; b -> b
+      (lambda (type)
+        (letrec ([foldt (fold-type handlef case-lambdaf consf cstf emptyf
+                                   promisef recf struct-typef struct-valuef
+                                   unionf valuesf varf vectorf)])
+          (cond
+            [(handle? type)
+             (handlef type)]
+            [(type-case-lambda? type)
+             ;; When we first get a case-lambda its arguments may be lists,
+             ;; so convert them to vectors once and for all here.  This is
+             ;; a hack until case-lambda uses vectors in all cases.
+             (let* ([rest-arg?s (type-case-lambda-rest-arg?s type)]
+                    [req-args (type-case-lambda-req-args type)]
+                    [argss (type-case-lambda-argss type)]
+                    [exps (type-case-lambda-exps type)]
+                    [argss (if (list? argss) (lol->vov argss) argss)]
+                    [exps (if (list? exps) (list->vector exps) exps)]
+                    [argss (for-each-vov! foldt argss)]
+                    [exps (for-each-vector! foldt exps)])
+               (case-lambdaf  rest-arg?s req-args argss exps))]
+            [(type-cons? type)
+             (consf (foldt (type-cons-car type)) (foldt (type-cons-cdr type)))]
+            [(type-cst? type)
+             (cstf (type-cst-type type))]
+            [(type-empty? type)
+             (emptyf)]
+            [(type-promise? type)
+             (promisef (foldt (type-promise-value type)))]
+            [(type-rec? type)
+             (let ([vars (type-rec-vars type)]    ; <-- Do not recur on variables being bound
+                   [types (map foldt (type-rec-types type))]
+                   [body (foldt (type-rec-body type))])
+               (recf vars types body))]
+            [(type-struct-type? type)
+             (struct-typef (type-struct-type-type-label type))]
+            [(type-struct-value? type) 
+             (let ([label (type-struct-value-type-label type)]
+                   [types (map foldt (type-struct-value-types type))])
+               (struct-valuef label types))]
+            [(type-union? type)
+             (unionf (map foldt (type-union-elements type)))]
+            [(type-values? type)
+             (valuesf (foldt (type-values-type type)))]
+            [(type-var? type)
+             (varf (type-var-name type) (type-var-reach type) (type-var-handle type))]
+            [(type-vector? type)
+             (vectorf (foldt (type-vector-element type)))]
+            [else (error 'fold-type "Unmatched type ~a" type)])))))
+  
+  ;; Return a type with handles replacing variables
+  (define/contract subst-handles/vars ((union label-type? handle? type-var?) tenv? . -> . (union type? handle?))
+    (lambda (type tenv)
+      (let subst ([type type])
+        (cond
+          [(handle? type) type]
+          [(type-case-lambda? type); rest-arg?s req-args argss exps)
+           (let* ([rest-arg?s (type-case-lambda-rest-arg?s type)]
+                  [req-args (type-case-lambda-req-args type)]
+                  [argss (for-each-vov! subst (type-case-lambda-argss type))]
+                  [exps (for-each-vector! subst (type-case-lambda-exps type))])
+             (make-type-case-lambda rest-arg?s req-args argss exps))]
+          [(type-cons? type)
+           (make-type-cons (subst (type-cons-car type)) (subst (type-cons-cdr type)))]
+          [(type-promise? type)
+           (make-type-promise (subst (type-promise-value type)))]
+          [(type-rec? type) ; vars handle-list body)
+           (let ([vars (type-rec-vars type)]
+                 [handle-list (type-rec-types type)]
+                 [body (type-rec-body type)])
+             (for-each (lambda (handle) (unless (handle? handle)
+                                          (pretty-print (make-type-rec vars handle-list body))
+                                          (error 'type-rec-var-no-handle)))
+                       handle-list)
+             (subst-handles/vars body
+                                 (extend-tenv tenv (map type-var-name vars) handle-list)))]
+          [(type-struct-value? type)
+           (make-type-struct-value (type-struct-value-type-label type) (map subst (type-struct-value-types type)))]
+          [(type-union? type)
+           (make-type-union (map subst (type-union-elements type)))]
+          [(type-values? type)
+           (make-type-values (subst (type-values-type type)))]
+          [(type-var? type)
+           (lookup-symbol tenv (type-var-name type))]
+          [(type-vector? type)
+           (make-type-vector (subst (type-vector-element type)))]
+          [else (error 'subst-handles/vars "Unmatched type ~a" type)]))))
+  
+  (define/contract subst-handles/vars-if-possible
+    ((union hashcons-type? handle? type-var?) tenv? . -> . (union type? handle?))
+    (lambda (type tenv)
+      (let subst ([type type])
+        (match type
+          [(? handle? type) type]
+          [($ type-case-lambda rest-arg?s req-args argss exps)
+           (let* ([argss (for-each-vov! subst argss)]
+                  [exps (for-each-vector! subst exps)])
+             ; for-each-vector set! args and exps in place
+             type)]
+          [($ type-cons hd tl)
+           (set-type-cons-car! type (subst hd))
+           (set-type-cons-cdr! type (subst tl))
+           type]
+          [($ type-promise value)
+           (set-type-promise-value! type (subst value))
+           type]
+          [($ type-rec vars types body)
+           ;; maybe we should add the vars/types to the scope iff the type is a handle
+           (set-type-rec-types! type (map subst types))
+           (set-type-rec-body! type (subst body))
+           type]
+          [($ type-struct-value label types)
+           (set-type-struct-value-types! type (map subst types))
+           type]
+          [($ type-union elements)
+           (set-type-union-elements! type (map subst elements))
+           type]
+          [($ type-values ty)
+           (set-type-values-type! type (subst ty))
+           type]
+          [($ type-var name reach handle)
+           (or (maybe-lookup-symbol tenv name) type)]
+          [($ type-vector element)
+           (set-type-vector-element! type (subst element))
+           type])
+        )))
+  
+  (define/contract has-free-vars? ((union type? handle?) . -> . boolean?)
+    (lambda (type)
+      (let* ([bound-vars (make-hash-table)]
+             [bind (lambda (var)
+                     (let ([cv (hash-table-get bound-vars var cst:thunk-false)])
+                       (hash-table-put! bound-vars var (if cv (add1 cv) 1))))]
+             [unbind (lambda (var)
+                       (let ([cv (hash-table-get bound-vars var
+                                                 (lambda () (error 'unbind "Cannot unbind unbound variable ~a" var)))])
+                         (when (= cv 0)
+                           (error 'unbind "Cannot unbind variable ~a more times than its bound" var))
+                         (hash-table-put! bound-vars var (sub1 cv))))]
+             [bound? (lambda (var)
+                       (let ([cv (hash-table-get bound-vars var cst:thunk-false)])
+                         (and cv (> cv 0))))])
+        (let/ec k
+          (letrec
+              ([list-has-free-vars? (lambda (args) (ormap has-free-vars? args))]
+               [has-free-vars?
+                (match-lambda
+                  [(? handle? type) #f]
+                  [($ type-case-lambda rest-arg?s req-args argss exps)
+                   (or (vector-of-vector-has? has-free-vars? argss)
+                       (vector-has? has-free-vars? exps))]
+                  [($ type-cons hd tl)
+                   (or (has-free-vars? hd) (has-free-vars? tl))]
+                  [($ type-promise value)
+                   (has-free-vars? value)]
+                  [($ type-rec vars types body)
+                   (let* ([vnames (map type-var-name vars)]
+                          [_ (for-each bind vnames)]
+                          [fv (or (list-has-free-vars? types) (has-free-vars? body))])
+                     (for-each unbind vnames)
+                     fv)]
+                  [($ type-struct-value label types)
+                   (list-has-free-vars? types)]
+                  [($ type-union elements)
+                   (list-has-free-vars? elements)]
+                  [($ type-values type)
+                   (has-free-vars? type)]
+                  [($ type-var name reach handle)
+                   (if (bound? name) #f (k #t))]
+                  [($ type-vector element)
+                   (has-free-vars? element)]
+                  [_ (error 'has-free-vars? "Unmatched type ~a" type)])])
+            (has-free-vars? type))))))
+  
+  (define/contract get-referenced-vars ((union type? handle?) . -> . (listof symbol?))
+    (lambda (type)
+      (let ([refed (make-hash-table)])
+        (let loop ([type type])
+          (match type
+            [(? handle? type) cst:void]
+            [($ type-case-lambda rest-arg?s req-args argss exps)
+             (for-each-vov loop argss)
+             (for-each-vector loop exps)]
+            [($ type-cons hd tl)
+             (loop hd) (loop tl)]
+            [($ type-promise value)
+             (loop value)]
+            [($ type-rec vars handle-list body)
+             (error 'get-referenced-vars "Nested type-rec found")]
+            [($ type-struct-value label types)
+             (for-each loop types)]
+            [($ type-union elements)
+             (for-each loop elements)]
+            [($ type-values type)
+             (loop  type)]
+            [($ type-var name reach handle)
+             (hash-table-put! refed name #t)]
+            [($ type-vector element)
+             (loop element)])
+          (hash-table-map refed (lambda (v _) v))))))
+  
+  (define/contract same-label-type?
+    (hashcons-table? state? (union type? handle?) . -> . boolean?)
+    (lambda (tbl state type)
+      (or (and (handle-state? state) (handle? type) (= (handle-state-handle state) type))
+          (and (handle-state? state) (equal? (get-type tbl (handle-state-handle state)) type))
+          
+          (and (cons-state? state) (type-cons? type))
+          (and (union-state? state) (type-union? type))
+          (and (vector-state? state) (type-vector? type))
+          (and (case-lambda-state? state) (type-case-lambda? type))
+          (and (union-state? state) (type-union? type))
+          (and (promise-state? state) (type-promise? type))
+          (and (struct-value-state? state) (type-struct-value? type))
+          )))
+  
+  (define/contract for-each-child
+    (any/c state? type? . -> . any)
+    (lambda (f state type)
+      (cond [(handle-state? state)
+             (void)]
+            [(cons-state? state)
+             (f (cons-state-car state) (type-cons-car type))
+             (f (cons-state-cdr state) (type-cons-cdr type))]
+            [(case-lambda-state? state)
+             (let* ([sargss (case-lambda-state-argss state)]
+                    [targss (type-case-lambda-argss type)]
+                    [argss-length (vector-length sargss)])
+               (let argss-loop ([argss-i 0])
+                 (when (< argss-i argss-length)
+                   (let* ([sargs (vector-ref sargss argss-i)]
+                          [targs (vector-ref targss argss-i)]
+                          [args-length (vector-length sargs )])
+                     (let args-loop ([i 0])
+                       (when (< i args-length)
+                         (f (vector-ref sargs i) (vector-ref targs i))
+                         (args-loop (add1 i)))))  
+                   (argss-loop (add1 argss-i)))))
+             (let* ([texps (type-case-lambda-exps type)]
+                    [sexps (case-lambda-state-exps state)]
+                    [len (vector-length texps)])
+               (let loop ([i 0])
+                 (when (< i len)
+                   (f (vector-ref sexps i) (vector-ref texps i))
+                   (loop (add1 i)))))]
+            [(promise-state? state)
+             (f (promise-state-value state) (type-promise-value type))]
+            [(struct-value-state? state)
+             (for-each f (struct-value-state-types state) (type-struct-value-types type))]
+            [(union-state? state)
+             (error 'union-states-not-sequential)]
+            [(values-state? state)
+             (f (values-state-type state) (type-values-type type))]
+            [(vector-state? state)
+             (f (vector-state-element state) (type-vector-element type))]
+            [else
+             (error 'for-each-child "Unmatched type")])))
+  
+  ;; See if any of the states in a minimized DFA is recursive with the
+  ;; greatest handle in the DFA.
+  (define/contract recursive-with-handle
+    (hashcons-table? dfa? (nonempty-list-of? state-number?) handle? . ->d .
+                     (lambda (hc dfa dfa-stnums handle)
+                       (lambda (state->handle)
+                         (when state->handle
+                           (if (= (hash-table-size state->handle) (length (get-state-numbers dfa)))
+                               (or (hash-table? state->handle) (boolean? state->handle))
+                               (pretty-error 'missing-state->handles
+                                             (list (cons 'dfa->list (dfa->list dfa))
+                                                   (cons 'dfa-stnums dfa-stnums)
+                                                   (cons 'handle handle)
+                                                   (cons 'state->handle state->handle))))))))
+    (lambda (hc dfa dfa-stnums handle)
+      (define stnum->state (dfa-stnum->state dfa))
+      
+      (define/contract state-number->state (state-number? . -> . state?)
+        (lambda (stnum)
+          (hash-table-get stnum->state stnum)))
+      
+      ;; Return the handle a state is recursive with or false
+      (define (state-recursive-with-handle stnum handle acc return-with stnum->handle)
+        (if (member (cons stnum handle) acc) stnum->handle
+            (let* ([type (get-type hc handle)]
+                   [state (state-number->state stnum)]
+                   ;; TBD new
+                   ; [state (if (and (union-state? state) (length-one? (union-state-elements state)))
+                   ;           (state-number->state (car (union-state-elements state)))
+                   ;           state)]
+                   )
+              (if (or 
+                   (and (same-label-type? hc state type)
+                        (let ([acc (cons (cons stnum handle) acc)])
+                          (if (union-state? state)
+                              ;; return #f is there exists a dfa state w/o a union element
+                              ;; should this be checked for all elements in both the
+                              ;; type-union-elements and the union-state-elements?
+                              (unless (andmap    
+                                       (lambda (stnum) 
+                                         (ormap (lambda (handle)
+                                                  (state-recursive-with-handle stnum handle acc return-with stnum->handle))
+                                                (type-union-elements type)))
+                                       (union-state-elements state))
+                                (return-with #f))
+                              (for-each-child
+                               (lambda (state handle)
+                                 (unless (state-recursive-with-handle state handle acc return-with stnum->handle)
+                                   (return-with #f)))
+                               state type))
+                          #t))
+                   ;; imagine we have a case like
+                   ;;   (rec-type:1 ((a0 (cons:1 _ a0))))
+                   ;;   (rec-state ((a0 (union:A handle:1 (cons:B a0)))))
+                   ;;  the graphs are the same modulo the union, the
+                   ;;  following makes sure the state is recursive
+                   ;;  with the union
+                   (and (union-state? state)
+                        (andmap (lambda (stnum) (state-recursive-with-handle stnum handle
+                                                                             (cons (cons (state-number state) handle) acc)
+                                                                             return-with stnum->handle))
+                                (union-state-elements state))))
+                  (begin
+                    (hash-table-put! stnum->handle stnum handle)
+                    stnum->handle)
+                  #f))))
+      
+      (ormap  (lambda (stnum)
+                (let/ec escape
+                  (state-recursive-with-handle stnum handle null escape (make-hash-table))))
+              dfa-stnums)))
+  
+  ;;
+  ;; Printing Functions
+  ;;
+  
+  (define hashcons-table->list
+    (lambda (tbl)
+      (list 'hashcons-table
+            (list:mergesort
+             (hash-table-map (hashcons-table-from-handle tbl)
+                             (lambda (h _) (list 'Handle: h  '-> (handle->list tbl h void #t))))
+             (lambda (x y) (> (cadr x) (cadr y)))))))
+  
+  (define/contract hashcons-table->dot (hashcons-table? output-port? . -> . void?)
+    (lambda (tbl out)
+      (handles->dot tbl
+                    (hash-table-map (hashcons-table-from-handle tbl) (lambda (handle type) handle))
+                    out)))
+  
+  (define/contract handles->dot (hashcons-table? (listof handle?) output-port? . -> . void?)
+    (lambda (tbl handles out)
+      (letrec
+          ([type->dot
+            (lambda (handle type ancest)
+              (match type
+                [($ type-empty)
+                 (fprintf out "node~a[label = \"<f0>mt ~a\"];\n" handle handle)]
+                [($ type-cst type)
+                 (fprintf out "node~a[label = \"<f0>~a ~a\"];\n" handle (string:expr->string type) handle)]
+                [($ type-struct-type label)
+                 (fprintf out "node~a[label = \"<f0>struct ~a\"];\n" handle handle)]
+                [($ type-cons hd tl)
+                 (fprintf out "node~a[label = \"<f0>cons~a | <f1> | <f2>\"];\n" handle handle)
+                 (fprintf out "node~a:f1 -> node~a;\n" handle hd)
+                 (fprintf out "node~a:f2 -> node~a;\n" handle tl)
+                 (loop hd ancest)
+                 (loop tl ancest)]
+                [($ type-case-lambda rest-arg?s req-args argss exps)
+                 (fprintf out "node~a[label = \"<f0>lambda ~a | {" handle handle)
+                 (for-each-vector (lambda (rest-arg) (fprintf out "| ~a" rest-arg)) rest-arg?s)
+                 (fprintf out "} | {")
+                 (for-each-vector (lambda (req-arg) (fprintf out "| ~a" req-arg)) req-args)
+                 (fprintf out "} | {")
+                 (for-each (lambda (args i)
+                             (fprintf out "| {")
+                             (for-each (lambda (arg j)
+                                         (fprintf out "| <argr~ac~a> ~a" i j arg))
+                                       (vector->list args) (iota (vector-length args)))
+                             (fprintf out "}"))
+                           (vector->list argss) (iota (vector-length argss)))
+                 (fprintf out "} | {")
+                 (for-each (lambda (exp i) (fprintf out "| <exp~a> ~a" i exp)) (vector->list exps) (iota (vector-length exps)))
+                 (fprintf out "}\"];\n")
+                 
+                 (for-each (lambda (args i)
+                             (for-each (lambda (arg j)
+                                         (fprintf out "node~a:argr~ac~a -> node~a;\n" handle i j arg))
+                                       (vector->list args) (iota (vector-length args))))
+                           (vector->list argss) (iota (vector-length argss)))
+                 (for-each (lambda (exp i)
+                             (fprintf out "node~a:exp~a -> node~a;\n" handle i exp))
+                           (vector->list exps) (iota (vector-length exps)))
+                 
+                 (for-each-vov (lambda (arg) (loop arg ancest)) argss)
+                 (for-each-vector (lambda (exp) (loop exp ancest)) exps)]
+                [($ type-promise value)
+                 (fprintf out "node~a:[label = <f0>promise ~a];\n" handle handle)
+                 (fprintf out "node~a:f0 -> node~a;\n" handle value)
+                 (loop value ancest)]
+                [($ type-struct-value label types)
+                 (fprintf out "node~a[label = \"<f0>struct-value ~a\"];\n" handle handle)
+                 (for-each (lambda (i)
+                             (fprintf out "node~a:f -> node~a;\n" handle i)) types)
+                 (for-each (lambda (i)
+                             (loop i ancest)) types)]
+                [($ type-values values-type)
+                 (fprintf out "node~a[label = \"<f0>values ~a\"];\n" handle handle)
+                 (fprintf out "node~a:f -> node~a;\n" handle values-type)
+                 (loop values-type ancest)]
+                [($ type-vector element)
+                 (fprintf out "node~a[label = \"<f0>vector ~a\"];\n" handle handle)
+                 (fprintf out "node~a:f -> node~a;\n" handle element)
+                 (loop element ancest)]
+                [($ type-union elements)
+                 (fprintf out "node~a[label = \"<f0>union ~a\"];\n" handle handle)
+                 (for-each (lambda (el i)
+                             (fprintf out "node~a:f~a -> node~a;\n" handle i el)) elements (iota (length elements)))
+                 (for-each (lambda (el)
+                             (loop el ancest)) elements)]
+                [else (error 'hashcons-type-string "~a Not implemented yet" type)]))]
+           [loop (lambda (handle ancest)
+                   (unless (set-in? ancest handle) ;; if we've already come across this node
+                     (let* ([type (get-type tbl handle)]
+                            [str (type->dot handle type (set-set ancest handle))])
+                       str
+                       ; (set-remove ancest handle) ;; imperative sets
+                       )))])
+        (fprintf out "digraph g {\n")
+        (fprintf out "node[shape = record];\n")
+        (fprintf out "/* Hashtable size = ~a */\n" (hashcons-table-size tbl))
+        (let ([set (set-make)]) (for-each (lambda (h) (loop h set)) handles))
+        (fprintf out "}\n"))))
+  
+  (define/contract handle->string
+    (hashcons-table? handle? (handle? handle? . -> . boolean?) . -> . string?)
+    (lambda (tbl handle union-elements-equal?)
+      (let ([out (open-output-string)])
+        ; the following gets rid of the newline at the end of the type, but
+        ; it also prevents newlines *inside* the type...  This can probably be
+        ; fixed using a custom pretty-print-print-line that uses the default
+        ; liner except for the last line.  Should be good enough for now.
+        (pretty-print-columns 'infinity)
+        (pretty-display (handle->list tbl handle union-elements-equal?
+                                      #f) ;; #t to show handles
+                        out)
+        (get-output-string out))))
+  
+  (define/contract handle->string-old
+    (hashcons-table? handle? (handle? handle? . -> . boolean?) . -> . string?)
+    (lambda (tbl handle union-elements-equal?)
+      (letrec
+          ([handle->var (make-hash-table)]
+           [handle->binding (make-hash-table)]
+           [get-next-var! (let ([*i* 0]) (lambda (handle)
+                                           (let ([new-i (+ *i* 1)]
+                                                 [str (format "a~a" *i*)])
+                                             (set! *i* (+ *i* 1))
+                                             (hash-table-put! handle->var handle str)
+                                             str)))]
+           [type->string
+            (lambda (type ancest)
+              (match type
+                [($ type-empty)
+                 "_"]
+                [($ type-cst type)
+                 (string:expr->string type)]
+                [($ type-struct-type label)
+                 (string-append "#<struct-type:" (symbol->string (label-struct-type-name label)) ">")]
+                [($ type-cons hd tl)
+                 (string-append "(cons " (loop hd ancest) " " (loop tl ancest) ")")]
+                [($ type-case-lambda rest-arg?s req-args argss exps)
+                 (string-append "(case-lambda "
+                                (foldr-case-lambda-vector (lambda (rest-arg? req-arg args exp acc)
+                                                            (string-append
+                                                             "["
+                                                             (foldr-vector (lambda (arg acc)
+                                                                             (string-append (loop arg ancest) " " acc))
+                                                                           (if rest-arg? "*-> " "-> ")
+                                                                           args)
+                                                             (loop exp ancest) "]" acc))
+                                                          ")"
+                                                          rest-arg?s req-args argss exps))]
+                [($ type-promise value)
+                 (string-append "(promise " (loop value ancest) ")")]
+                [($ type-struct-value label types)
+                 (string-append "#(struct:"
+                                (symbol->string (if (label-struct-type? label)  (label-struct-type-name label) label))
+                                " "
+                                (list:foldr
+                                 (lambda (elt-type str)
+                                   (string-append
+                                    (loop elt-type ancest)
+                                    (if (string=? str ")") ""  " ")
+                                    str))
+                                 ")"
+                                 types))]
+                [($ type-values values-type)
+                 (cond
+                   [(type-empty? values-type)
+                    (loop values-type ancest)]
+                   [(and (type-cst? values-type) (eq? (type-cst-type values-type) 'top))
+                    (loop values-type ancest)]
+                   [else
+                    (string-append "(values " (loop values-type ancest) ")")])]
+                [($ type-vector element)
+                 (string-append "(vector " (loop element ancest) ")")]
+                [($ type-union elements)
+                 (let* ([els (list:foldr (lambda (x ys)
+                                           (if (ormap (lambda (y)
+                                                        (union-elements-equal? x y)) ys)
+                                               ys
+                                               (cons x ys)))
+                                         '()
+                                         elements)]
+                        [els (list:foldl (lambda (x ys)
+                                           (if (ormap (lambda (y)
+                                                        (union-elements-equal? x y)) ys)
+                                               ys
+                                               (cons x ys)))
+                                         '()
+                                         els)])
+                   (if (length-one? els)
+                       (loop (car els) ancest)
+                       (string-append "(union"
+                                      (list:foldr (lambda (el acc)
+                                                    (string-append " " (loop el ancest) acc))
+                                                  ")"
+                                                  elements))))]
+                [else (error 'hashcons-type-string "~a Not implemented yet" type)]))]
+           [loop (lambda (handle ancest)
+                   (if (set-in? ancest handle) ;; if we've already come across this node
+                       ;; Add a back reference
+                       (if (hash-table-get handle->var handle cst:thunk-false)
+                           (hash-table-get handle->var handle)
+                           (get-next-var! handle))
+                       (let* ([type (get-type tbl handle)]
+                              [str (type->string type (set-set ancest handle))])
+                         (set-remove ancest handle) ;; imperative sets
+                         (if (hash-table-has-key? handle->var handle)
+                             (begin
+                               (hash-table-put! handle->binding handle str)
+                               (hash-table-get handle->var handle))
+                             str))))])
+        (let* ([rec-body (loop handle (set-make))]
+               [var-bindings
+                (list:foldr
+                 (lambda (cur acc) (string-append cur (if (string=? acc "") "" "\n") acc)) ""
+                 (hash-table-map handle->var
+                                 (lambda (handle var)
+                                   (string-append (number->string handle) "[" var " "
+                                                  (hash-table-get handle->binding handle
+                                                                  (lambda () (error 'handle->string
+                                                                                    "No binding for var handle ~a" handle)))
+                                                  "]"))))])
+          (format "~s:~a" handle
+                  (if (string=? "" var-bindings) rec-body
+                      (string-append "(rec-type (" var-bindings ") " rec-body ")")))))))
+  
+  (define handle->list 
+    (opt-lambda (tbl handle union-elements-equal? [show-handles #t])
+      (letrec
+          ([handle->var (make-hash-table)]
+           [handle->binding (make-hash-table)]
+           [get-next-var! (let ([i 0]) (lambda (handle)
+                                         (let ([str (string->symbol (format "a~a" i))])
+                                           (set! i (add1 i))
+                                           (hash-table-put! handle->var handle str)
+                                           str)))]
+           [handlify
+            (lambda (str handle) ;(any/c handle? . -> . (union symbol? (cons/p symbol? any/c)))
+              (let* ([first (if (list? str) (car str) str)]
+                     [first-handle
+                      (string->symbol
+                       (let ([str (cond [(string? first) first]
+                                        [else (string:expr->string first)])])
+                         (if show-handles
+                             (string-append str ":" (string:expr->string handle))
+                             str)))])
+                (if (list? str) (cons first-handle (cdr str)) first-handle)))]
+           [type->list
+            (lambda (type ancest)
+              (match type
+                [($ type-empty) '_]
+                [($ type-cst type)
+                 (cond [(null? type) 'null]
+                       [(symbol? type) type]
+                       [(boolean? type) type]
+                       [(number? type) type]
+                       [else (string->symbol (string:expr->string type))])]
+                [($ type-struct-type label)
+                 (string->symbol (string-append
+                                  "#<struct-type:"
+                                  (symbol->string (label-struct-type-name label)) ">"))]
+                [($ type-cons hd tl)
+                 (list 'cons (loop hd ancest) (loop tl ancest))]
+                [($ type-case-lambda rest-arg?s req-args argss exps)
+                 (list 'case-lambda 
+                       (foldr-case-lambda-vector
+                        (lambda (rest-arg? req-arg args exp acc)
+                          (cons
+                           (append
+                            (map (lambda (arg) (loop arg ancest)) (vector->list args))
+                            (list (if rest-arg? '*-> '->)
+                                  (loop exp ancest)))
+                           acc))
+                        null
+                        rest-arg?s req-args argss exps))]
+                [($ type-promise value)
+                 (list 'promise (loop value ancest))]
+                [($ type-struct-value label types)
+                 (list (string->symbol
+                        (string-append
+                         "#(struct:"
+                         (symbol->string
+                          (if (label-struct-type? label)  (label-struct-type-name label) label))))
+                       (map (lambda (ty) (loop ty ancest)) types))]
+                [($ type-values values-type)
+                 (cond
+                   [(type-empty? values-type)
+                    (loop values-type ancest)]
+                   [(and (type-cst? values-type) (eq? (type-cst-type values-type) 'top))
+                    (loop values-type ancest)]
+                   [else
+                    (list 'values (loop values-type ancest))])]
+                [($ type-vector element)
+                 (list 'vector (loop element ancest))]
+                [($ type-union elements)
+                 (let* ([simplify
+                         (lambda (x ys)
+                           (let ([can-drop-x-for?
+                                  (lambda (y)
+                                    (if (= x y)
+                                        #f 
+                                        (union-elements-equal? x y)))])
+                             (if (ormap can-drop-x-for? ys) ys (cons x ys))))]
+                        [els (list:foldr simplify null elements)]
+                        [els (list:foldl simplify null els)])
+                   (let ([retme
+                          (cond
+                            [show-handles
+                             (cons 'union (map (lambda (x) (loop x ancest)) els))]
+                            [(> (length els) 1)
+                             (cons 'union (map (lambda (x) (loop x ancest)) els))]
+                            [(= 1 (length els))
+                             (loop (car els) ancest)]
+                            [else (error 'union-without-elemetns
+                                         "elements=~a els=~a" elements els)])])
+                     retme)
+                   )]
+                [else (error 'handle->list "Unmatched type: ~a" type)]))]
+           [loop (lambda (handle ancest) ;(handle? any/c . -> . any)
+                   (if (memq handle ancest) ;; if we've already come across this node
+                       ;; Add a back reference
+                       (if (hash-table-has-key? handle->var handle)
+                           (hash-table-get handle->var handle)
+                           (get-next-var! handle))
+                       (let* ([type (get-type tbl handle)]
+                              [str (type->list type (cons handle ancest))])
+                         (if (hash-table-has-key? handle->var handle)
+                             (begin
+                               (hash-table-put! handle->binding handle (handlify str handle))
+                               (hash-table-get handle->var handle))
+                             (handlify str handle)))))]) ;; changed here
+        (let* ([rec-body (loop handle null)]
+               [var-bindings
+                (hash-table-map handle->var
+                                (lambda (handle var)
+                                  (list var (hash-table-get handle->binding handle))))])
+          (if (null? var-bindings) rec-body
+              (list (handlify 'rec-type handle) var-bindings rec-body))))))
+  
+  
+  ;;
+  ;; Graph algorithms
+  ;;
+  
+  ;; get a list of strongly connected components in reverse
+  ;; topological order, taken from CLR
+  (define/contract strongly-connected-components
+    (hash-table? . ->d .
+                 (lambda (h)
+                   (lambda (list-of-sccs)
+                     (= (hash-table-size h) (apply + (map length list-of-sccs))))))
+    (lambda (graph)
+      (letrec
+          ;; finished nodes from most recently finished to first finished
+          ([finished-nodes (box ())]  
+           [color (make-hash-table)]
+           
+           [transpose-graph
+            (lambda (graph)
+              (let ([new-graph (make-hash-table)])
+                (hash-table-for-each graph (lambda (node adj-list)
+                                             (hash-table-put! new-graph node null)))
+                (hash-table-for-each graph (lambda (node adj-list)
+                                             (for-each (lambda (adj-node)
+                                                         (hash-table-put! new-graph adj-node
+                                                                          (cons node (hash-table-get new-graph adj-node))))
+                                                       adj-list)))
+                new-graph))]
+           [dfs-visit (lambda (graph u visited-nodes)
+                        (hash-table-put! color u 'gray)
+                        (let* ([adj (hash-table-get graph u)]
+                               [new-nodes
+                                (list:foldl (lambda (v visited)
+                                              (if (eq? (hash-table-get color v) 'white)
+                                                  (dfs-visit graph v visited)
+                                                  visited))
+                                            visited-nodes
+                                            adj)])
+                          (hash-table-put! color u 'black)
+                          (set-box! finished-nodes (cons u (unbox finished-nodes)))
+                          (cons u new-nodes)))]
+           [dfs (lambda (graph nodes-to-visit)
+                  (hash-table-for-each graph
+                                       (lambda (u _) (hash-table-put! color u 'white)))
+                  (let ([sccs (list:foldl (lambda (u sccs)
+                                            (if (eq? (hash-table-get color u) 'white)
+                                                (cons (dfs-visit graph u null) sccs)
+                                                sccs))
+                                          '()
+                                          nodes-to-visit)])
+                    sccs))])
+        (dfs graph (hash-table-map graph (lambda (k adj) k)))
+        (dfs (transpose-graph graph) (unbox finished-nodes)))))
+  )
\ No newline at end of file
diff --git a/collects/mrflow/info.ss b/collects/mrflow/info.ss
new file mode 100644
index 0000000000..c8f768de66
--- /dev/null
+++ b/collects/mrflow/info.ss
@@ -0,0 +1,14 @@
+
+(module info (lib "infotab.ss" "setup")
+        
+  ; for mzc
+  (define compile-omit-files '("test.ss" "tests.ss" "primitives.ss"))
+  
+  ; for DrScheme
+  (define name "MrFlow")
+  (define tools '(("gui.ss")))
+  (define tool-icons '(("mrflow.gif" "icons")))
+  ; this name shows up in the "About Drscheme" menu
+  (define tool-names '("MrFlow Static Debugger"))
+  (define tool-urls '("http://www.plt-scheme.org/software/mrflow/"))
+  )
diff --git a/collects/mrflow/labels.ss b/collects/mrflow/labels.ss
new file mode 100644
index 0000000000..2f87c22be0
--- /dev/null
+++ b/collects/mrflow/labels.ss
@@ -0,0 +1,91 @@
+
+(module labels mzscheme
+
+  ; XXX labels contain types and types contain labels, so we will need another layer for
+  ; the contracts once the types are extracted from cgp.ss
+  
+  (provide
+   (struct label (parents children type-var trace prim? term set edges)) 
+   (struct label-cst (value))
+   (struct label-cons (car cdr))
+   (struct label-vector (element))
+   (struct label-promise (value))
+   (struct label-case-lambda (struct rest-arg?s req-args argss exps effects))
+   (struct label-values (label))
+   (struct label-struct-value (type fields))
+   (struct label-struct-type (name parent parent-fields-nbr total-fields-nbr error?))
+   )
+  
+  ; parents = children = (listof label)
+  ; type-var = (union type-var #f), trace = boolean, prim? = boolean
+  ; term = syntax-object, set = (hash-table-of label (make-arrows (listof label) (listof label) (listof label)),
+  ; edges = (hashtableof symbol edge))
+  ; a flow graph label/node type-var is a type variable name used when reconstructing recursive
+  ; types.
+  ; trace is used to detect cycles in the graph during type reconstruction.
+  ; prim? tells whether the label was created during graph reconstruction from a primitive
+  ; type. We need this to detect the entrance of a tunnel.
+  ; Note that the only reason we need to have this tunneling stuff is to keep the GUI arrows right.
+  ; term: the source program term (or a fake version of it, in the case of "null" when we have
+  ; a rest argument)
+  ; set: contains label structures (see below) for all the values that flow into this term.
+  ; Each label in the set has two lists of in and out edges pointing back and forth to the nodes
+  ; from which this label has flowed in (or '() if the label is the source of the label) and
+  ; flowed out to. The in edges (which need to be checked each time a propagation is done, to 
+  ; revent cycles) are in a list, and not in an hash-table, because we assume that the same
+  ; label is not going to flow very often into this term through several paths. The out-edge
+  ; list is only used to draw arrows, so it doesn't have to be implemented very efficiently.
+  ; Note that, since constants are represented by label structs, the same constant can appear
+  ; several times in the set, even symbols.
+  ; edges: functions that take two labels as argument and either propagate the second one to
+  ; another label, using the first label as the source, or transform the graph accordingly (if
+  ; the inflowing label is a function pseudo-label and the label into which it flows corresponds
+  ; to the operator in an application, for example).
+  ; parent and children are used to memoize the parent and children arrows for all the values
+  ; in the label's value set.  Computing these when the code contains huge amounts of macro-
+  ; generated recurisve code is quite expensive.
+  (define-struct label (parents children type-var trace prim? term set edges))
+  
+  ; a constant...
+  (define-struct (label-cst label) (value))
+  
+  ; car = label, cdr = label
+  (define-struct (label-cons label) (car cdr))
+  
+  (define-struct (label-vector label) (element))
+  (define-struct (label-promise label) (value))
+  
+  ; struct = label-struct
+  ; rest-arg?s = (listof boolean), req-args = (listof number), argss = (listof (listof label)),
+  ; exps = (listof label), app-thunks = (listof (-> void))
+  ; Each "level" of the six lists represents the args and body labels of a given clause in the
+  ; case-lambda. At a given level, rest-arg? tells whether this clause has a rest argument,
+  ; and req-args gives the number of required arguments, so it only has to be computed once.
+  ; top-free-varss are the labels of the top level free variables in the corresponding clause.
+  ; This field is updated as a side effect when analyzing top level variable references inside
+  ; the body of a lambda. Edges flowing into these free variables must be created when the
+  ; clause is applied. app-thunk is a thunk that is used to delay the transformation of the
+  ; graph when a function flows into an application, until the clause around the application
+  ; is itself applied. The two are merged, because one of the delayed app could set! a top level
+  ; variable, and the top level variable can be referenced both before and after the application,
+  ; so lookups and applications have to be done in exactly the right order.
+  ; struct is just a placeholder to tell the type of structure a given structure-processing
+  ; function is supposed to deal with.
+  (define-struct (label-case-lambda label)
+                 (struct rest-arg?s req-args argss exps effects))
+  
+  ; label = label (a label-cons based list of labels)
+  ; used to simulate multiple values. So this label is going to flow around and work pretty
+  ; much like a cons label. the problem is that multiple values are not first-class in Scheme,
+  ; so we have to be careful to only propagate them through edges that correspond to the result
+  ; of applications, never through edges that correspond to arguments of applications. Hence
+  ; the reason for the complication in create-simple-edge. Note that define-struct expands
+  ; into a define-values, so we need all that stuff.
+  (define-struct (label-values label) (label))
+  
+  ; symbol symbol label number (listof label)
+  (define-struct (label-struct-value label) (type fields))
+  (define-struct (label-struct-type label)
+                 (name parent parent-fields-nbr total-fields-nbr error?))
+  
+  )
diff --git a/collects/mrflow/mrflow.ss b/collects/mrflow/mrflow.ss
new file mode 100644
index 0000000000..4a9658b01e
--- /dev/null
+++ b/collects/mrflow/mrflow.ss
@@ -0,0 +1,49 @@
+(module mrflow mzscheme
+  (require (lib "pretty.ss")
+           (lib "contract.ss")
+           (lib "mred.ss" "mred"))
+
+  (provide (all-from mzscheme)
+           ;(all-from-except mzscheme vector-ref)
+           ;(rename dbg-vector-ref vector-ref)
+           
+           (all-from-except (lib "contract.ss") provide/contract define/contract)
+           ; one or the other
+           provide/contract define/contract
+           ;(rename dbg-provide/contract provide/contract)(rename dbg-define-contract define/contract)
+           
+           non-negative-exact-integer?
+           text%?
+           style-delta%?
+           )
+  
+  (define-syntax (dbg-provide/contract stx)
+    (syntax-case stx (struct)
+      [(_) #'(provide)]
+      [(_ (id contract) other ...)
+       #'(begin (provide id) (dbg-provide/contract other ...))]
+      [(_ (struct id ((field contract) ...)) other ...)
+       #'(begin (provide (struct id (field ...))) (dbg-provide/contract other ...))])
+    )
+  
+  (define-syntax (dbg-define/contract stx)
+    (syntax-case stx ()
+      [(_ name contract body) #'(define name body)]))
+  
+  (define-syntax dbg-vector-ref
+    (lambda (stx)
+      (syntax-case stx ()
+        [(_ args ...)
+         #`(begin
+             (printf "~a ~a ~a ~a~n"
+                     #,(syntax-source stx)
+                     #,(syntax-line stx)
+                     #,(syntax-column stx)
+                     #,(syntax-original? stx))
+             (#,#'vector-ref args ...))])))
+
+  (define non-negative-exact-integer? (and/c integer? exact? (>=/c 0)))  
+  (define text%? (is-a?/c text%))
+  (define style-delta%? (is-a?/c style-delta%))
+  
+  )
diff --git a/collects/mrflow/primitives/algol60.ss b/collects/mrflow/primitives/algol60.ss
new file mode 100644
index 0000000000..8a217a88b5
--- /dev/null
+++ b/collects/mrflow/primitives/algol60.ss
@@ -0,0 +1,87 @@
+; Algol 60 primitives and runtime support
+(
+ ; primitives
+ 
+ (!= (number number -> boolean))
+ (! (boolean -> boolean))
+ (& (boolean boolean -> boolean))
+ (\| (boolean boolean -> boolean))
+ (=> (boolean boolean -> boolean))
+ (== (boolean boolean -> boolean))
+ 
+ (sign (forall ([a top])
+               ((real -> a) (-> real) -> a)))
+ (entier (forall ([a top])
+                 ((real -> a) (-> real) -> a)))
+ 
+ (a60:sin (forall ([a top])
+                  ((real -> a) (-> real) -> a)))
+ (a60:cos (forall ([a top])
+                  ((real -> a) (-> real) -> a)))
+ (a60:arctan (forall ([a top])
+                     ((real -> a) (-> real) -> a)))
+ (a60:sqrt (forall ([a top])
+                   ((real -> a) (-> real) -> a)))
+ (a60:abs (forall ([a top])
+                  ((real -> a) (-> real) -> a)))
+ (a60:ln (forall ([a top])
+                 ((real -> a) (-> real) -> a)))
+ (a60:exp (forall ([a top])
+                  ((real -> a) (-> real) -> a)))
+
+ (prints (forall ([a top])
+                 ((void -> a) (-> top) -> a)))
+ (printn (forall ([a top])
+                 ((void -> a) (-> top) -> a)))
+ (printsln (forall ([a top])
+                   ((void -> a) (-> top) -> a)))
+ (printnln (forall ([a top])
+                   ((void -> a) (-> top) -> a)))
+ 
+ ; Algol60 runtime support
+ 
+ ;(a60:array (struct a60:array (dependant type)))
+ ;(a60:switch (struct a60:switch (choices))
+ 
+ (undefined undefined)
+ 
+ (check-boolean (forall ([a top]) (a -> a)))
+ (goto (forall ([a top]) ((-> a) -> a)))
+ (get-value (forall ([a top]) ((-> a) -> a)))
+ (set-target! (forall ([a top][b top])
+                      ((a -> b) a -> b)))
+ ;make-array
+ ;array-ref
+ ;array-set!
+ ;make-switch
+ ;switch-ref
+ 
+ (coerce (forall ([a top])
+                 (symbol a -> a)))
+ 
+ 
+ ; R5RS runtime support
+ 
+ (void (-> void))
+ 
+ (= (real real -> boolean))
+ (< (real real -> boolean))
+ (> (real real -> boolean))
+ (<= (real real -> boolean))
+ (>= (real real -> boolean))
+
+ (+ (real real -> real)) 
+ (* (real real -> real)) 
+ (- (real real -> real))
+ (/ (real real -> real))
+ 
+ (quotient (integer integer -> integer))
+ (remainder (integer integer -> integer))
+ (modulo (integer integer -> integer))
+ 
+ (values (forall ([a_values top])
+                 (case-lambda
+                   [(rest a_values) (values a_values)]
+                   )))
+
+ )
\ No newline at end of file
diff --git a/collects/mrflow/primitives/r5rs.ss b/collects/mrflow/primitives/r5rs.ss
new file mode 100644
index 0000000000..d9ad5014b0
--- /dev/null
+++ b/collects/mrflow/primitives/r5rs.ss
@@ -0,0 +1,884 @@
+; R5RS
+; When are we going to be able to compute all this directly from an S-exp version of R5RS ?
+(
+ ; 4.2.6 quasiquotation
+ 
+ ; not part of r5rs, but the expansion of ,@ uses qq-append
+ (qq-append (forall ([b_append top][c_append top])
+                    (case-lambda
+                      [((listof b_append) c_append)
+                       (union c_append
+                              (rec-type
+                               ([improper-list
+                                 (union ()
+                                        (cons b_append
+                                              (union c_append improper-list)))])
+                               improper-list))])))
+ 
+ ; 6.1 Equivalence predicates
+ 
+ (eqv? (top top -> boolean))
+ (eq? (top top -> boolean))
+ (equal? (top top -> boolean))
+ 
+ 
+ ; 6.2.5 Numerical operations
+ 
+ ; in Scheme it seems that positive = strictly positive and
+ ; negative = strictly negative
+ 
+ (number? (top -> boolean))
+ (complex? (top -> boolean))
+ (real? (top -> boolean))
+ (rational? (top -> boolean))
+ (integer? (top -> boolean))
+ 
+ (exact? (complex -> boolean))
+ (inexact? (complex -> boolean))
+ 
+ (= (complex complex complex *-> boolean))
+ (< (real real real *-> boolean))
+ (> (real real real *-> boolean))
+ (<= (real real real *-> boolean))
+ (>= (real real real *-> boolean))
+ 
+ (zero? (complex -> boolean))
+ (positive? (real -> boolean))
+ (negative? (real -> boolean))
+ (odd? (integer -> boolean))
+ (even? (integer -> boolean))
+ 
+ ; if any arg inexact => result inexact
+ (max (forall ([x_max real])
+              (case-lambda
+                [(x_max) x_max]
+                [(rest real (listof real)) real])))
+ ; if any arg inexact => result inexact
+ (min (forall ([x_min real])
+              (case-lambda
+                [(x_min) x_min]
+                [(rest real (listof real)) real])))
+ 
+ ; no arg => 0
+ ; z => z
+ (+ (forall ([z_+ complex])
+            (case-lambda
+              [(rest complex complex (listof complex)) complex]
+              [() 0]
+              [(z_+) z_+]
+              )))
+ ; no arg => 1
+ ; z => z
+ (* (forall ([z_* complex])
+            (case-lambda
+              [(rest complex complex (listof complex)) complex]
+              [() 1]
+              [(z_*) z_*]
+              )))
+ 
+ ; z => -z
+ (- (complex complex *-> complex))
+ ; z => 1/z
+ (/ (complex complex *-> complex))
+ 
+ ; returns non-negative real
+ (abs (real -> real))
+ 
+ ; second arg non-zero
+ (quotient (integer integer -> integer))
+ ; second arg non-zero
+ ; result has same sign as first arg
+ (remainder (integer integer -> integer))
+ ; second arg non-zero
+ ; result has same sign as second arg
+ (modulo (integer integer -> integer))
+ 
+ ; no arg => 0
+ ; n => n (from math)
+ ; result is non-negative integer
+ (gcd (forall ([n_gcd integer])
+              (case-lambda
+                [(rest integer integer (listof integer)) integer]
+                [() 0]
+                [(n_gcd) n_gcd]
+                )))
+ ; no arg => 1
+ ; n => n (from math)
+ ; result is non-negative integer
+ (lcm (forall ([n_lcm integer])
+              (case-lambda
+                [(rest integer integer (listof integer)) integer]
+                [() 1]
+                [(n_lcm) n_lcm]
+                )))
+ 
+ (numerator (rational -> integer))
+ ; result always positive
+ ; 0 => 1
+ (denominator (rational -> integer))
+ 
+ (floor (real -> integer))
+ (ceiling (real -> integer))
+ (truncate (real -> integer))
+ (round (real -> integer))
+ 
+ (rationalize (real real -> rational))
+ 
+ (exp (complex -> complex))
+ (log (complex -> complex))
+ (sin (complex -> complex))
+ (cos (complex -> complex))
+ (tan (complex -> complex))
+ (asin (complex -> complex))
+ (acos (complex -> complex))
+ (atan (case-lambda
+         [(complex) complex]
+         [(real real) complex]))
+ 
+ ; positive real part, or zero real part and non-negative imaginary part
+ (sqrt (complex -> complex))
+ 
+ ; (expt 0 0) = 1
+ ; (expt 0 z) = 0
+ (expt (complex complex -> complex))
+ 
+ (make-rectangular (real real -> complex))
+ (make-polar (real real -> complex))
+ (real-part (complex -> real))
+ (imag-part (complex -> real))
+ ; returns non-negative real
+ (magnitude (complex -> real))
+ (angle (complex -> real))
+ 
+ (exact->inexact (complex -> inexact-complex))
+ (inexact->exact (complex -> exact-complex))
+ 
+ 
+ ; 6.2.6 Numerical input and output
+ 
+ ; this really ougth to be called complex->string and string->complex,
+ ; especially since R5RS explicitely uses a "z" as the first argument
+ ; name... R5RS seems to actually confuse complex and number quite a lot,
+ ; despite the second note in section 6.2.5, page 21.
+ 
+ ; radix is either 2, 8, 10, or 16
+ (number->string (case-lambda
+                   [(complex) string]
+                   [(complex exact-integer) string]))
+ 
+ ; radix is either 2, 8, 10, or 16
+ (string->number (case-lambda
+                   [(string) (union complex #f)]
+                   [(string exact-integer) (union complex #f)]))
+ 
+ 
+ ; 6.3.1 Booleans
+ 
+ (not (boolean -> boolean))
+ 
+ (boolean? (top -> boolean))
+ 
+ 
+ ; 6.3.2 Pairs and lists
+ 
+ (pair? (top -> boolean))
+ 
+ (cons (forall ([a_cons top]
+                [b_cons top])
+               (a_cons b_cons -> (cons a_cons b_cons))))
+ 
+ (car (forall ([a_car top])
+              ((cons a_car top) -> a_car)))
+ 
+ (cdr (forall ([a_cdr top])
+              ((cons top a_cdr) -> a_cdr)))
+ 
+ ; b can't be twice in contra-variant position...
+ ;(set-car! (forall ([a top][b top][c top])
+ ;                  (cons (union a b) c) b -> void
+ 
+ ;(set-cdr! (forall ([a top][b top][c top])
+ ;                  (cons a (union b c)) b -> void
+ 
+ (caar (forall ([a_caar top])
+               ((cons (cons a_caar top) top) -> a_caar)))
+ (cdar (forall ([a_cdar top])
+               ((cons (cons top a_cdar) top) -> a_cdar)))
+ (cadr (forall ([a_cadr top])
+               ((cons top (cons a_cadr top)) -> a_cadr)))
+ (cddr (forall ([a_cddr top])
+               ((cons top (cons top a_cddr)) -> a_cddr)))
+ (caaar (forall ([a_caaar top])
+                ((cons (cons (cons a_caaar top) top) top) -> a_caaar)))
+ (cdaar (forall ([a_cdaar top])
+                ((cons (cons (cons top a_cdaar) top) top) -> a_cdaar)))
+ (cadar (forall ([a_cadar top])
+                ((cons (cons top (cons a_cadar top)) top) -> a_cadar)))
+ (cddar (forall ([a_cddar top])
+                ((cons (cons top (cons top a_cddar)) top) -> a_cddar)))
+ (caadr (forall ([a_caadr top])
+                ((cons top (cons (cons a_caadr top) top)) -> a_caadr)))
+ (cdadr (forall ([a_cdadr top])
+                ((cons top (cons (cons top a_cdadr) top)) -> a_cdadr)))
+ (caddr (forall ([a_caddr top])
+                ((cons top (cons top (cons a_caddr top))) -> a_caddr)))
+ (cdddr (forall ([a_cdddr top])
+                ((cons top (cons top (cons top a_cdddr))) -> a_cdddr)))
+ (caaaar (forall ([a_caaaar top])
+                 ((cons (cons (cons (cons a_caaaar top) top) top) top) -> a_caaaar)))
+ (cdaaar (forall ([a_cdaaar top])
+                 ((cons (cons (cons (cons top a_cdaaar) top) top) top) -> a_cdaaar)))
+ (cadaar (forall ([a_cadaar top])
+                 ((cons (cons (cons top (cons a_cadaar top)) top) top) -> a_cadaar)))
+ (cddaar (forall ([a_cddaar top])
+                 ((cons (cons (cons top (cons top a_cddaar)) top) top) -> a_cddaar)))
+ (caadar (forall ([a_caadar top])
+                 ((cons (cons top (cons (cons a_caadar top) top)) top) -> a_caadar)))
+ (cdadar (forall ([a_cdadar top])
+                 ((cons (cons top (cons (cons top a_cdadar) top)) top) -> a_cdadar)))
+ (caddar (forall ([a_caddar top])
+                 ((cons (cons top (cons top (cons a_caddar top))) top) -> a_caddar)))
+ (cdddar (forall ([a_cdddar top])
+                 ((cons (cons top (cons top (cons top a_cdddar))) top) -> a_cdddar)))
+ (caaadr (forall ([a_caaadr top])
+                 ((cons top (cons (cons (cons a_caaadr top) top) top)) -> a_caaadr)))
+ (cdaadr (forall ([a_cdaadr top])
+                 ((cons top (cons (cons (cons top a_cdaadr) top) top)) -> a_cdaadr)))
+ (cadadr (forall ([a_cadadr top])
+                 ((cons top (cons (cons top (cons a_cadadr top)) top)) -> a_cadadr)))
+ (cddadr (forall ([a_cddadr top])
+                 ((cons top (cons (cons top (cons top a_cddadr)) top)) -> a_cddadr)))
+ (caaddr (forall ([a_caaddr top])
+                 ((cons top (cons top (cons (cons a_caaddr top) top))) -> a_caaddr)))
+ (cdaddr (forall ([a_cdaddr top])
+                 ((cons top (cons top (cons (cons top a_cdaddr) top))) -> a_cdaddr)))
+ (cadddr (forall ([a_cadddr top])
+                 ((cons top (cons top (cons top (cons a_cadddr top)))) -> a_cadddr)))
+ (cddddr (forall ([a_cddddr top])
+                 ((cons top (cons top (cons top (cons top a_cddddr)))) -> a_cddddr)))
+ 
+ (null? (top -> boolean))
+ 
+ (list? (top -> boolean))
+ 
+ ; the rest argument does all the work
+ (list (forall ([a_list top])
+               (case-lambda
+                 [(rest a_list) a_list])))
+ 
+ (length ((listof top) -> exact-integer))
+ 
+ (append (forall ([a_append top]
+                  [b_append top][c_append top]
+                  [d_append top][e_append top][f_append top]
+                  [g_append top][h_append top][i_append top][j_append top]
+                  [k_append top][l_append top][m_append top][n_append top][o_append top]
+                  [p_append top][q_append top][r_append top][s_append top][t_append top][u_append top])
+                 (case-lambda
+                   [() ()]
+                   [(a_append) a_append]
+                   [((listof b_append) c_append)
+                    (union c_append
+                           (rec-type
+                            ([improper-list
+                              (union ()
+                                     (cons b_append
+                                           (union c_append improper-list)))])
+                            improper-list))]
+                   [((listof d_append) (listof e_append) f_append)
+                    (union f_append
+                           (rec-type
+                            ([improper-list
+                              (union ()
+                                     (cons (union d_append e_append)
+                                           (union f_append improper-list)))])
+                            improper-list))]
+                   [((listof g_append) (listof h_append) (listof i_append) j_append)
+                    (union j_append
+                           (rec-type
+                            ([improper-list
+                              (union ()
+                                     (cons (union g_append h_append i_append)
+                                           (union j_append improper-list)))])
+                            improper-list))]
+                   [((listof k_append) (listof l_append) (listof m_append) (listof n_append) o_append)
+                    (union o_append
+                           (rec-type
+                            ([improper-list
+                              (union ()
+                                     (cons (union k_append l_append m_append n_append)
+                                           (union o_append improper-list)))])
+                            improper-list))]
+                   [((listof p_append) (listof q_append) (listof r_append) (listof s_append) (listof t_append) u_append)
+                    (union u_append
+                           (rec-type
+                            ([improper-list
+                              (union ()
+                                     (cons (union p_append q_append r_append s_append t_append)
+                                           (union u_append improper-list)))])
+                            improper-list))])))
+ ; the last element could be not a list => improper list
+ ; this doesn't work because it doesn't enforce the listness of args beyond
+ ; the first one but before the last one...
+ ;[(rest (listof b_append) (listof c_append))
+ ; (rec-type ([improper-list (union ()
+ ;                                  (cons (union b_append c_append)
+ ;                                        (union c_append improper-list)))])
+ ;           improper-list)]
+ ;(union c_append (listof b_append))]
+ ;)))
+ 
+ (reverse (forall ([a_reverse top])
+                  ((listof a_reverse) -> (listof a_reverse))))
+ 
+ ; exact-integer should be non-negative...
+ (list-tail (forall ([a_list-tail top])
+                    ((listof a_list-tail) exact-integer -> (listof a_list-tail))))
+ 
+ (list-ref (forall ([a_list-ref top])
+                   ((listof a_list-ref) exact-integer -> a_list-ref)))
+ 
+ (memq (forall ([a_memq top]
+                [b_memq top])
+               (a_memq (listof b_memq) -> (union #f (cons a_memq (listof b_memq))))))
+ (memv (forall ([a_memv top]
+                [b_memv top])
+               (a_memv (listof b_memv) -> (union #f (cons a_memv (listof b_memv))))))
+ (member (forall ([a_member top]
+                  [b_member top])
+                 (a_member (listof b_member) -> (union #f (cons a_member (listof b_member))))))
+ 
+ (assq (forall ([a_assq top]
+                [b_assq top])
+               (a_assq (listof (cons top b_assq)) -> (union #f (cons a_assq b_assq)))))
+ (assv (forall ([a_assv top]
+                [b_assv top])
+               (a_assv (listof (cons top b_assv)) -> (union #f (cons a_assv b_assv)))))
+ (assoc (forall ([a_assoc top]
+                 [b_assoc top])
+                (a_assoc (listof (cons top b_assoc)) -> (union #f (cons a_assoc b_assoc)))))
+ 
+ 
+ ; 6.3.3. Symbols
+ 
+ (symbol? (top -> boolean))
+ 
+ (symbol->string (symbol -> string))
+ 
+ (string->symbol (string -> symbol))
+ 
+ 
+ ; 6.3.4 Characters
+ 
+ (char? (top -> boolean))
+ 
+ (char=? (char char -> boolean))
+ (char<? (char char -> boolean))
+ (char>? (char char -> boolean))
+ (char<=? (char char -> boolean))
+ (char>=? (char char -> boolean))
+ 
+ (char-ci=? (char char -> boolean))
+ (char-ci<? (char char -> boolean))
+ (char-ci>? (char char -> boolean))
+ (char-ci<=? (char char -> boolean))
+ (char-ci>=? (char char -> boolean))
+ 
+ (char-alphabetic? (char -> boolean))
+ (char-numeric? (char -> boolean))
+ (char-whitespace? (char -> boolean))
+ (char-upper-case? (letter -> boolean))
+ (char-lower-case? (letter -> boolean))
+ 
+ ; R5RS doesn't say the integer has to be positive...
+ (char->integer (char -> exact-integer))
+ (integer->char (exact-integer -> char))
+ 
+ (char-upcase (char -> char))
+ (char-downcase (char -> char))
+ 
+ 
+ ; 6.3.5 Strings
+ 
+ (string? (top -> boolean))
+ 
+ ; integer should be non-negative
+ (make-string (case-lambda
+                [(exact-integer) string]
+                [(exact-integer char) string]))
+ 
+ (string (case-lambda
+           [(rest char (listof char)) string]
+           [() ""]
+           ))
+ 
+ ; exact positive integer ? exact integer ? integer ? 
+ (string-length (string -> exact-integer))
+ 
+ (string-ref (string exact-integer -> char))
+ 
+ ; should inject string into the first arg
+ ;(string-set! (string exact-integer char -> void))
+ 
+ (string=? (string string -> boolean))
+ (string-ci=? (string string -> boolean))
+ 
+ (string<? (string string -> boolean))
+ (string>? (string string -> boolean))
+ (string<=? (string string -> boolean))
+ (string>=? (string string -> boolean))
+ (string-ci<? (string string -> boolean))
+ (string-ci>? (string string -> boolean))
+ (string-ci<=? (string string -> boolean))
+ (string-ci>=? (string string -> boolean))
+ 
+ (substring (string exact-integer exact-integer -> string))
+ 
+ (string-append (forall ([a_string-append string])
+                        (case-lambda
+                          [(rest string string (listof string)) string]
+                          [() ""]
+                          [(a_string-append) a_string-append]
+                          )))
+ 
+ (string->list (string -> (listof char)))
+ (list->string ((listof char) -> string))
+ 
+ ; (string-copy (forall ([a string]) (a -> a))) works only if we don't have string-set!
+ (string-copy (string -> string))
+ 
+ ; should inject string into first arg
+ ;(string-fill! (string char -> void))
+ 
+ 
+ ; 6.3.6 Vectors
+ 
+ (vector? (top -> boolean))
+ 
+ ; integer should be non-negative
+ (make-vector (forall ([a_make-vector top])
+                      (case-lambda
+                        [(exact-integer) (vector top)]
+                        [(exact-integer a_make-vector) (vector a_make-vector)])))
+ 
+ (vector (forall ([a_vector top])
+                 (a_vector *-> (vector a_vector))))
+ 
+ (vector-length ((vector top) -> exact-integer))
+ 
+ (vector-ref (forall ([a_vector-ref top])
+                     ((vector a_vector-ref) exact-integer -> a_vector-ref)))
+ 
+ ; should  inject third arg into first
+ ;(vector-set! (vector exact-integer top -> void))
+ 
+ (vector->list (forall ([a_vector->list top])
+                       ((vector a_vector->list) -> (listof a_vector->list))))
+ (list->vector (forall ([a_list->vector top])
+                       ((listof a_list->vector) -> (vector a_list->vector))))
+ 
+ ; second arg shoould flow into first
+ ;(vector-fill! (vector top -> void))
+ 
+ 
+ ; 6.4 Control features
+ 
+ (procedure? (top -> boolean))
+ 
+ (apply (forall ([a_apply top][b_apply top]
+                 [c_apply top][d_apply top][e_apply top]
+                 [f_apply top][g_apply top][h_apply top][i_apply top]
+                 [j_apply top][k_apply top][l_apply top][m_apply top][n_apply top]
+                 [o_apply top][p_apply top][q_apply top][r_apply top][s_apply top][t_apply top]
+                 [u_apply top][v_apply top][w_apply top][x_apply top][y_apply top][z_apply top][aa_apply top]
+                 ;[ab_apply top][ac_apply top]
+                 )
+                (case-lambda
+                  [((case-lambda [(rest (listof a_apply)) b_apply])
+                    (listof a_apply)) b_apply]
+                  [((case-lambda [(rest (listof (union c_apply d_apply))) e_apply])
+                    c_apply (listof d_apply)) e_apply]
+                  [((case-lambda [(rest (listof (union f_apply g_apply h_apply))) i_apply])
+                    f_apply g_apply (listof h_apply)) i_apply]
+                  [((case-lambda [(rest (listof (union j_apply k_apply l_apply m_apply))) n_apply])
+                    j_apply k_apply l_apply (listof m_apply)) n_apply]
+                  [((case-lambda [(rest (listof (union o_apply p_apply q_apply r_apply s_apply))) t_apply])
+                    o_apply p_apply q_apply r_apply (listof s_apply)) t_apply]
+                  [((case-lambda [(rest (listof (union u_apply v_apply w_apply x_apply y_apply z_apply))) aa_apply])
+                    u_apply v_apply w_apply x_apply y_apply (listof z_apply)) aa_apply]
+                  ; this would almost work, except for the last argument, that would
+                  ; show up as a list in the result
+                  ;[(rest (case-lambda
+                  ;        [(rest a) b])
+                  ;       a)
+                  ; b])))
+                  ; so we have to deconstruct everything, and be *very* conservative.
+                  ; This *will* raise errors about possible infinite lists, but that's the
+                  ; best we can if we want to cover all the possible cases.
+                  ; this will not work because it doesn't allow for the first args to not
+                  ; be lists
+                  ;[(rest (case-lambda
+                  ;         [(rest (listof ab_apply)) ac_apply])
+                  ;       (listof (listof ab_apply)))
+                  ; ac_apply])))
+                  ; and this doesn't work either because it allows for the last arg
+                  ; to not be a list
+                  ;[(rest (case-lambda
+                  ;         [(rest (listof (union a_apply (listof b_apply)))) c_apply])
+                  ;       (listof (union a_apply (listof b_apply))))
+                  ; c_apply])))
+                  )))
+ 
+ (map (forall ([a_map top][b_map top]
+               [c_map top][d_map top][e_map top]
+               [f_map top][g_map top][h_map top][i_map top]
+               [j_map top][k_map top][l_map top][m_map top][n_map top]
+               [o_map top][p_map top][q_map top][r_map top][s_map top][t_map top]
+               )
+              (case-lambda
+                [((a_map -> b_map) (listof a_map)) 
+                 (listof b_map)]
+                [((c_map d_map -> e_map) (listof c_map) (listof d_map))
+                 (listof e_map)]
+                [((f_map g_map h_map -> i_map) (listof f_map) (listof g_map) (listof h_map))
+                 (listof i_map)]
+                [((j_map k_map l_map m_map -> n_map) (listof j_map) (listof k_map) (listof l_map) (listof m_map))
+                 (listof n_map)]
+                [((o_map p_map q_map r_map s_map -> t_map) (listof o_map) (listof p_map) (listof q_map) (listof r_map) (listof s_map)) 
+                 (listof t_map)]
+                ; use at your own risks: you'll loose arity checking and get spurious errors
+                ; about '() not being a pair or about infinite lists (but the result of map
+                ; will be properly conservative, so if you ignore the errors for map itself
+                ; and make sure the arity of the function given to map is correct, then you
+                ; might be able to use the output of map to detect errors down the flow - except
+                ; that the output of map will be a list => using car on it or stuff like that
+                ; will trigger another error...)
+                ; The whole problem is that map needs a dependent type...
+                ;[(rest
+                ;  (case-lambda
+                ;   [(rest o p q r (listof s)) t])
+                ;  (listof o) (listof p) (listof q) (listof r) (listof (listof s)))
+                ; (listof t)]
+                )))
+ 
+ (for-each (forall ([a_for-each top];[b top]
+                    [c_for-each top][d_for-each top];[e top]
+                    [f_for-each top][g_for-each top][h_for-each top];[i top]
+                    [j_for-each top][k_for-each top][l_for-each top][m_for-each top];[n top]
+                    [o_for-each top][p_for-each top][q_for-each top][r_for-each top][s_for-each top];[t top]
+                    )
+                   (case-lambda
+                     [((a_for-each -> top) (listof a_for-each))
+                      void]
+                     [((c_for-each d_for-each -> top) (listof c_for-each) (listof d_for-each))
+                      void]
+                     [((f_for-each g_for-each h_for-each -> top) (listof f_for-each) (listof g_for-each) (listof h_for-each))
+                      void]
+                     [((j_for-each k_for-each l_for-each m_for-each -> top) (listof j_for-each) (listof k_for-each) (listof l_for-each) (listof m_for-each))
+                      void]
+                     [((o_for-each p_for-each q_for-each r_for-each s_for-each -> top) (listof o_for-each) (listof p_for-each) (listof q_for-each) (listof r_for-each) (listof s_for-each)) 
+                      void]
+                     ; use at your own risks: you'll loose arity checking and get spurious errors
+                     ; about '() not being a pair or about infinite lists (but the result of for-each
+                     ; will be properly conservative)
+                     ; The whole problem is that for-each needs a dependent type...
+                     ;[(rest
+                     ;  (case-lambda
+                     ;   [(rest o p q r (listof s)) top])
+                     ;  (listof o) (listof p) (listof q) (listof r) (listof (listof s)))
+                     ; void]
+                     )))
+ 
+ ; (delay expr) => (#%app make-promise (lambda () expr))
+ ; if we have the arrow type in the argument of make-promise, then the application
+ ; will happen immediately, which we don't want. So instead
+ ; a will be the thunk, and having the arrow type for this thunk in the type for force
+ ; will force the application of the thunk inside force.
+ ; pp-type for promises just "forgets" to show the enclosing thunk part of the type.
+ ; It's ugly, but it works, and it works well enough to approximate memoization.
+ (make-promise (forall ([a_make-promise top])
+                       (a_make-promise -> (promise a_make-promise))))
+ (force (forall ([a_force top])
+                ((promise (-> a_force)) -> a_force)))
+ 
+ (call-with-current-continuation (forall ([a_call/cc top]
+                                          [b_call/cc top])
+                                         (((a_call/cc -> bottom) -> b_call/cc)
+                                          -> (union a_call/cc b_call/cc))))
+ 
+ ; correct, but currently triggers a bug.
+ ;(call-with-current-continuation (forall ([a top]
+ ;                                         [b top])
+ ;                                        ((; continuation
+ ;                                          (case-lambda [(rest a) bottom])
+ ;                                          ;result of body of lambda that
+ ;                                          ;receives the continuation
+ ;                                          -> b)
+ ;                                         ; result of call/cc
+ ;                                         -> (union (values a) b))))
+ 
+ ; multiple values are simulated internally as a list...
+ (values (forall ([a_values top])
+                 (case-lambda
+                   [(rest a_values) (values a_values)]
+                   )))
+ 
+ (call-with-values (forall ([a_call/vals top] ; one or multiple values
+                            [b_call/vals top])
+                           (case-lambda
+                             [((case-lambda
+                                 [() (values a_call/vals)])
+                               (case-lambda
+                                 [(rest a_call/vals) b_call/vals]))
+                              b_call/vals])))
+ 
+ ; this limited values works fine, but then call-with-values doesnt', because all the clauses
+ ; in call-with-values would have only two arguments, making discrimination between the different
+ ; cases impossible.
+ ;(values (forall ([a top]
+ ;                 [b top][c top]
+ ;                 [d top][e top][f top]
+ ;                 [g top][h top][i top][j top]
+ ;                 [k top][l top][m top][n top][o top])
+ ;                (case-lambda
+ ;                 [() (values)]
+ ;                 [(a) (values a)]
+ ;                 [(b c) (values b c)]
+ ;                 [(d e f) (values d e f)]
+ ;                 [(g h i j) (values g h i j)]
+ ;                 [(k l m n o) (values k l m n o)])))
+ ;
+ ;(call-with-values (forall ([a top][b top]
+ ;                           [c top][d top][e top])
+ ;                          (case-lambda
+ ;                           [((case-lambda [() (values a)]) (case-lambda [(a) b])) b]
+ ;                           [((case-lambda [() (values c d)]) (case-lambda [(c d) e])) e]
+ ;                           )))
+ 
+ (dynamic-wind (forall ([a_dyn/w top])
+                       ((-> top) (-> a_dyn/w) (-> top) -> a_dyn/w)))
+ 
+ 
+ ; 6.5 Eval
+ 
+ ; letter is a subtype of char, all the number types are subtypes of number
+ ; see section 7.1.2 of R5RS for the complete definition of datum
+ (eval ((rec-type ([datum (union simple-datum compound-datum)]
+                   [simple-datum (union boolean number char string symbol)]
+                   ;[compound-datum (union list-datum vector-datum)]
+                   [compound-datum (union list-datum (vector datum))]
+                   [list-datum (union ()
+                                      (cons datum list-datum)
+                                      (cons datum datum))]
+                   ;[vector-datum (vector datum)]
+                   )
+                  datum) env -> (union top #f))) 
+ 
+ (scheme-report-environment (5 -> env))
+ (null-environment (5 -> env))
+ 
+ (interaction-environment (-> env))
+ 
+ 
+ ; 6.6.1 Ports
+ 
+ ; R5RS doesn't always explicitely differentiate between input and output ports...
+ 
+ (call-with-input-file (forall ([a_call/if top])
+                               (string (input-port -> a_call/if) -> a_call/if)))
+ (call-with-output-file (forall ([a_call/of top])
+                                (string (output-port -> a_call/of) -> a_call/of)))
+ 
+ (input-port? (top -> boolean))
+ (output-port? (top -> boolean))
+ 
+ (current-input-port (-> input-port))
+ (current-output-port (-> output-port))
+ 
+ (with-input-from-file (forall ([a_with/if top])
+                               (string (-> a_with/if) -> a_with/if)))
+ (with-output-to-file (forall ([a_with/of top])
+                              (string (-> a_with/of) -> a_with/of)))
+ 
+ (open-input-file (string -> input-port))
+ 
+ (open-output-file (string -> output-port))
+ 
+ (close-input-port (input-port -> void))
+ (close-output-port (output-port -> void))
+ 
+ 
+ ; 6.6.2 Input
+ 
+ ; eof is included in top, but #f needs to be included explicitely
+ ; because of the simplistic way if-dependency is done
+ (read (case-lambda
+         [() (union top #f)]
+         [(input-port) (union top #f)]))
+ 
+ (read-char (case-lambda
+              [() char]
+              [(input-port) char]))
+ 
+ (peek-char (case-lambda
+              [() char]
+              [(input-port) char]))
+ 
+ (eof-object? (top -> boolean))
+ 
+ (char-ready? (case-lambda
+                [() boolean]
+                [(input-port) boolean]))
+ 
+ 
+ ; 6.6.3 Output
+ 
+ (write (case-lambda
+          [(top) void]
+          [(top output-port) void]))
+ 
+ (display (case-lambda
+            [(top) void]
+            [(top output-port) void]))
+ 
+ (newline (case-lambda
+            [() void]
+            [(output-port) void]))
+ 
+ (write-char (case-lambda
+               [(char) void]
+               [(char output-port) void]))
+ 
+ 
+ ; 6.6.4 System interface
+ 
+ (load (string -> (union top #f)))
+ 
+ (transcript-on (string -> void))
+ (transcript-off (-> void))
+ 
+ 
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; not R5RS, just for testing
+
+ ; (if test then) macro-expanded into (if test then (void))
+ (void (-> void))
+ 
+ (null ())
+ 
+; (id (forall ([a_id top]) (a_id -> a_id)))
+; (make-func (-> (-> 1)))
+; (foo (cons 1 2))
+; (pi 3.1)
+; ; one required argument that has to be a list, the elements are then extracted
+; (gather-one1 (forall ([a_go1 top])
+;                      ((listof a_go1) -> a_go1)))
+; (gather-one2 (forall ([a_go2 top])
+;                      (case-lambda
+;                        [((listof a_go2)) a_go2])))
+; ; unknown number of arguments that are converted into a list by the rest argument,
+; ; then extracted
+; (gather-many1 (forall ([a_gm1 top])
+;                       (a_gm1 *-> a_gm1)))
+; (gather-many2 (forall ([a_gm2 top])
+;                       (case-lambda
+;                         [(rest (listof a_gm2)) a_gm2])))
+; ; don't try this at home
+; ;(gather-other (forall ([a top])
+; ;                      ((a) *-> a)))
+; 
+; (gen-nums (-> (listof number)))
+; 
+; (apply-gen (forall ([a_app/gen top]
+;                     [b_app/gen top])
+;                    (case-lambda
+;                      [((case-lambda [(rest a_app/gen) b_app/gen]) a_app/gen) b_app/gen])))
+; 
+; (lnum (forall ([a_lnum top])
+;               ((listof a_lnum) -> a_lnum)))
+ 
+; ; ALGOL60 primitives and runtime, to be able to analyze the expanded version
+; 
+; (!= (number number -> boolean))
+; (! (boolean -> boolean))
+; (& (boolean boolean -> boolean))
+; (\| (boolean boolean -> boolean))
+; (=> (boolean boolean -> boolean))
+; (== (boolean boolean -> boolean))
+; 
+; (sign (forall ([a top])
+;               ((real -> a) (-> real) -> a)))
+; (entier (forall ([a top])
+;                 ((real -> a) (-> real) -> a)))
+; 
+; (a60:sin (forall ([a top])
+;                  ((real -> a) (-> real) -> a)))
+; (a60:cos (forall ([a top])
+;                  ((real -> a) (-> real) -> a)))
+; (a60:arctan (forall ([a top])
+;                     ((real -> a) (-> real) -> a)))
+; (a60:sqrt (forall ([a top])
+;                   ((real -> a) (-> real) -> a)))
+; (a60:abs (forall ([a top])
+;                  ((real -> a) (-> real) -> a)))
+; (a60:ln (forall ([a top])
+;                 ((real -> a) (-> real) -> a)))
+; (a60:exp (forall ([a top])
+;                  ((real -> a) (-> real) -> a)))
+;
+; (prints (forall ([a top])
+;                 ((void -> a) (-> top) -> a)))
+; (printn (forall ([a top])
+;                 ((void -> a) (-> top) -> a)))
+; (printsln (forall ([a top])
+;                   ((void -> a) (-> top) -> a)))
+; (printnln (forall ([a top])
+;                   ((void -> a) (-> top) -> a)))
+; 
+; ; Algol60 runtime support
+; 
+; ;(a60:array (struct a60:array (dependant type)))
+; ;(a60:switch (struct a60:switch (choices))
+; 
+; (undefined undefined)
+; 
+; (check-boolean (forall ([a top]) (a -> a)))
+; (goto (forall ([a top]) ((-> a) -> a)))
+; (get-value (forall ([a top]) ((-> a) -> a)))
+; (set-target! (forall ([a top][b top])
+;                      ((a -> b) a -> b)))
+; ;make-array
+; ;array-ref
+; ;array-set!
+; ;make-switch
+; ;switch-ref
+; 
+; (coerce (forall ([a top])
+;                 (symbol a -> a)))
+; 
+; 
+; ; R5RS runtime support
+; 
+; (void (-> void))
+; 
+; (= (real real -> boolean))
+; (< (real real -> boolean))
+; (> (real real -> boolean))
+; (<= (real real -> boolean))
+; (>= (real real -> boolean))
+;
+; (+ (real real -> real)) 
+; (* (real real -> real)) 
+; (- (real real -> real))
+; (/ (real real -> real))
+; 
+; (quotient (integer integer -> integer))
+; (remainder (integer integer -> integer))
+; (modulo (integer integer -> integer))
+; 
+; (values (forall ([a_values top])
+;                 (case-lambda
+;                   [(rest a_values) (values a_values)]
+;                   )))
+
+
+ )
diff --git a/collects/mrflow/sba-errors.ss b/collects/mrflow/sba-errors.ss
new file mode 100644
index 0000000000..0472965835
--- /dev/null
+++ b/collects/mrflow/sba-errors.ss
@@ -0,0 +1,61 @@
+
+(module sba-errors (lib "mrflow.ss" "mrflow")
+  (require
+   (prefix cst: "constants.ss")
+   (prefix lab: "labels.ss")
+   ;"assoc-set-list.ss"
+   "assoc-set-hash.ss"
+   )
+  
+  ; (listof label) symbol string
+  ; need this before the contracts because of sba-error?
+  (define-struct sba-error (labels gravity message) (make-inspector))
+  
+  ; (assoc-setof label (listof sba-error))
+  ; we use a list instead of a set for the sba-errors, because that's what error-table-get
+  ; has to return anyway
+  (define-struct error-table (assoc-set))
+  
+  (provide/contract
+   (sba-error-gravity (sba-error? . -> . (symbols 'red 'orange 'green)))
+   (sba-error-message (sba-error? . -> . string?))
+   (error-table-make  (-> error-table?))
+   (error-table? (any/c . -> . boolean?))
+   (error-table-set (error-table? (listof lab:label?) (symbols 'red 'orange 'green) string? . -> . void?))
+   (error-table-get (error-table? lab:label? . -> . (listof sba-error?)))
+   )
+  
+  ; -> error-table
+  (define (error-table-make)
+    (make-error-table (assoc-set-make)))
+  
+  ; top -> boolean
+  ; error-table? comes from the structure definition
+  
+  ; error-table (listof label) (union 'red 'orange 'green) string -> void
+  ; adds error to the error list for each label
+  ; we use terms instead of labels as the key, because a primitive will have several labels
+  ; associated with it (one created from the program text, and at least one created from the
+  ; type for that primitive), so we need to use as key something unique about the primitive.
+  (define (error-table-set error-table labels gravity message)
+    (let ([assoc-set (error-table-assoc-set error-table)]
+          [error (make-sba-error labels gravity message)])
+      (for-each (lambda (label)
+                  (let ([term (lab:label-term label)])
+                    (if (syntax-position term)
+                        (assoc-set-set 
+                         assoc-set
+                         term
+                         (cons error (assoc-set-get assoc-set term cst:thunk-empty))
+                         #f)
+                        (printf "~a error detected for term ~a: ~a~n"
+                                gravity
+                                (syntax-object->datum term)
+                                message))))
+                labels)))
+  
+  ; error-table label -> (listof sba-error)
+  (define (error-table-get error-table label)
+    (assoc-set-get (error-table-assoc-set error-table) (lab:label-term label) cst:thunk-empty))
+  
+  )
diff --git a/collects/mrflow/set-exn.ss b/collects/mrflow/set-exn.ss
new file mode 100644
index 0000000000..d85304f213
--- /dev/null
+++ b/collects/mrflow/set-exn.ss
@@ -0,0 +1,33 @@
+; exceptions for sets
+; This file is required by both set-hash.ss and set-list.ss
+; so we can't use contracts here because the sets are not always the same.
+
+(module set-exn mzscheme
+  
+  (provide
+   exn:set?
+   (struct exn:set:value-not-found (set value))
+   (struct exn:set:duplicate-value (set value))
+   raise-value-not-found-exn
+   raise-duplicate-value-exn
+   )
+  
+  (define-struct (exn:set exn) ())
+  (define-struct (exn:set:value-not-found exn:set) (set value))
+  (define-struct (exn:set:duplicate-value exn:set) (set value))
+  
+  ; string set value -> void
+  (define (raise-value-not-found-exn fct-name set value)
+    (raise (make-exn:set:value-not-found
+            (format "~a: value ~a not found in set ~a" fct-name value set)
+            (current-continuation-marks)
+            set value)))
+  
+  ; string set value -> void
+  (define (raise-duplicate-value-exn fct-name set value)
+    (raise (make-exn:set:duplicate-value
+            (format "~a: value ~a already in set ~a" fct-name value set)
+            (current-continuation-marks)
+            set value)))
+  
+  )
diff --git a/collects/mrflow/set-hash.ss b/collects/mrflow/set-hash.ss
new file mode 100644
index 0000000000..36c32c4ba3
--- /dev/null
+++ b/collects/mrflow/set-hash.ss
@@ -0,0 +1,239 @@
+; sets implementation, using hash tables.
+; - value equality based on eq? by default, uses equal? if given the 'equal flag
+; - raises exn:set:value-not-found if value not in set when trying
+;   to remove a value.
+; - raise exn:set:duplicate-value by default when trying to add a value to a
+;   set where it already exists
+; - strange things might happen if you use set-union, set-intersection,
+;   or set-difference with two sets that don't use the same comparaison
+;   function: you might end up with duplicate values in some sets.
+
+(module set-hash (lib "mrflow.ss" "mrflow")
+  (require
+   (lib "etc.ss") ; for opt-lambda
+   "set-exn.ss" ; no prefix so we can re-provide
+   )
+  
+  ; table = (hashtableof value value)
+  (define-struct set (cardinality table))
+  
+  (provide/contract
+   (exn:set? (any/c . -> . boolean?))
+   (struct exn:set:value-not-found ((set set?) (value any/c)))
+   (struct exn:set:duplicate-value ((set set?) (value any/c)))
+   (set-make (() ((symbols 'equal)) . opt-> . set?))
+   (set-reset (set? . -> . set?))
+   (set? (any/c . -> . boolean?))
+   (set-set ((set? any/c) (boolean?) . opt-> . set?))
+   (set-in? (set? any/c . -> . boolean?))
+   (set-remove ((set? any/c) (boolean?) . opt-> . set?))
+   (set-cardinality (set? . -> . non-negative-exact-integer?))
+   (set-empty? (set? . -> . boolean?))
+   (set-copy (set? . -> . set?))
+   (set-map (set? (any/c . -> . any) . -> . (listof any/c)))
+   (set-fold (set? (any/c any/c . -> . any) any/c . -> . any))
+   (set-for-each (set? (any/c . -> . any) . -> . set?))
+   (set-for-each! (set? (any/c . -> . any) . -> . set?))
+   (set-filter ((set? (any/c . -> . boolean?)) ((symbols 'new 'same)) . opt-> . set?))
+   (set-union ((set? set?) ((symbols 'new 'first 'second)) . opt-> . set?))
+   (set-intersection ((set? set?) ((symbols 'new 'first 'second)) . opt-> . set?))
+   (set-difference ((set? set?) ((symbols 'new 'first 'second)) . opt-> . set?))
+   )
+  
+  ; (opt 'equal) -> set
+  ; we test the optional argument ourselves to preserve data abstraction even in the
+  ; presence of an exception
+  (define set-make
+    (case-lambda
+      [() (make-set 0 (make-hash-table))]
+      [(flag) (make-set 0 (make-hash-table 'equal))]))
+  
+  ; set -> set
+  (define (set-reset set)
+    (set-set-table! set (make-hash-table))
+    (set-set-cardinality! set 0)
+    set)
+  
+  ; value -> boolean
+  ; set? comes from the structure definition
+  
+  ; set value (opt boolean) -> set
+  (define set-set
+    (let ([dummy (gensym)])
+      (opt-lambda (set value (exn? #t))
+        (if (set-in? set value)
+            (when exn?
+              (raise-duplicate-value-exn "set-set" set value))
+            (begin
+              (set-set-cardinality! set (add1 (set-cardinality set)))
+              (hash-table-put! (set-table set) value dummy)))
+        set)))
+  
+  ; set value -> boolean
+  (define set-in? 
+    (let* ([sym (gensym)]
+           [sym-thunk (lambda () sym)])
+      (lambda (set value)
+        (not (eq? sym (hash-table-get (set-table set) value sym-thunk))))))
+  
+  ; set value (opt boolean) -> set
+  (define set-remove
+    (opt-lambda (set value (exn? #t))
+      (if (set-in? set value)
+          (begin
+            (set-set-cardinality! set (sub1 (set-cardinality set)))
+            (hash-table-remove! (set-table set) value))
+          (when exn?
+            (raise-value-not-found-exn "set-remove" set value)))
+      set))
+  
+  ; set -> exact-non-negative-integer
+  ; set-cardinality comes from the structure definition
+  
+  ; set -> boolean
+  (define (set-empty? set)
+    (= 0 (set-cardinality set)))
+  
+  ; set -> set
+  (define (set-copy set)
+    (let ([new-table (make-hash-table)])
+      (hash-table-for-each (set-table set)
+                           (lambda (key value)
+                             (hash-table-put! new-table key value)))
+      (make-set (set-cardinality set)
+                new-table)))
+  
+  ; set (value -> value) -> (listof value)
+  (define (set-map set f)
+    (let ([binary-f (lambda (value dummy)
+                      (f value))])
+      (hash-table-map (set-table set) binary-f)))
+  
+  ; set (value value -> value) value -> value
+  (define (set-fold set f acc)
+    (let ([acc acc])
+      (hash-table-for-each (set-table set)
+                           (lambda (value dummy)
+                             (set! acc (f value acc))))
+      acc))
+  
+  ; set (value -> value) -> set
+  (define (set-for-each set f)
+    (let ([binary-f (lambda (value dummy)
+                      (f value))])
+      (hash-table-for-each (set-table set) binary-f))
+    set)
+  
+  ; set (value -> value) -> set
+  ; it's up to the user to make sure f is injective. Otherwise we might end up with
+  ; a smaller set and the wrong cardinality.
+  (define (set-for-each! set f)
+    (let ([new-table (make-hash-table)])
+      (hash-table-for-each (set-table set)
+                           (lambda (value dummy)
+                             (hash-table-put! new-table (f value) dummy)))
+      (set-set-table! set new-table))
+    set)
+  
+  ; set (value -> boolean) (opt (union 'new 'same)) -> set
+  (define set-filter
+    (let (; set (value -> boolean) -> set
+          [filter-into-new-set
+           (lambda (set tester)
+             (let ([table (make-hash-table)]
+                   [count 0])
+               (hash-table-for-each (set-table set)
+                                    (lambda (value dummy)
+                                      (when (tester value)
+                                        (hash-table-put! table value dummy)
+                                        (set! count (add1 count)))))
+               (make-set count table)))])
+      (opt-lambda (set tester (which-set 'new))
+        (let ([new-set (filter-into-new-set set tester)])
+          (case which-set
+            [(new) new-set]
+            [(same)
+             (set-set-table! set (set-table new-set))
+             (set-set-cardinality! set (set-cardinality new-set))
+             set])))))
+  
+  ; set set (opt (union 'new 'first 'second)) -> set
+  (define set-union
+    (let (; set set -> set
+          [union-second-set-into-first
+           (lambda (set1 set2)
+             (let ([table (set-table set1)]
+                   [count (set-cardinality set1)])
+               (hash-table-for-each (set-table set2)
+                                    (lambda (value dummy)
+                                      (unless (set-in? set1 value)
+                                        (hash-table-put! table value dummy)
+                                        (set! count (add1 count)))))
+               (set-set-cardinality! set1 count))
+             set1)])
+      (opt-lambda (set1 set2 (which-set 'new))
+        (case which-set
+          [(new)
+           ; copying is presumably faster than testing
+           (if (< (set-cardinality set1) (set-cardinality set2))
+               (union-second-set-into-first (set-copy set2) set1)
+               (union-second-set-into-first (set-copy set1) set2))]
+          [(first) (union-second-set-into-first set1 set2)]
+          [(second) (union-second-set-into-first set2 set1)]))))
+  
+  ; set set (opt (union 'new 'first 'second)) -> set
+  (define set-intersection
+    (let (; set set -> set
+          [intersect-into-new-set
+           (lambda (set1 set2)
+             (let ([table (make-hash-table)]
+                   [count 0])
+               (hash-table-for-each (set-table set1)
+                                    (lambda (value dummy)
+                                      (when (set-in? set2 value)
+                                        (hash-table-put! table value dummy)
+                                        (set! count (add1 count)))))
+               (make-set count table)))])
+      (opt-lambda (set1 set2 (which-set 'new))
+        (let ([new-set
+               (if (< (set-cardinality set1) (set-cardinality set2))
+                   (intersect-into-new-set set1 set2)
+                   (intersect-into-new-set set2 set1))])
+          (case which-set
+            [(new) new-set]
+            [(first)
+             (set-set-table! set1 (set-table new-set))
+             (set-set-cardinality! set1 (set-cardinality new-set))
+             set1]
+            [(second)
+             (set-set-table! set2 (set-table new-set))
+             (set-set-cardinality! set2 (set-cardinality new-set))
+             set2])))))
+  
+  ; set set (opt (union 'new 'first 'second)) -> set
+  (define set-difference
+    (let (; set set -> set
+          [difference-into-new-set
+           (lambda (set1 set2)
+             (let ([table (make-hash-table)]
+                   [count 0])
+               (hash-table-for-each (set-table set1)
+                                    (lambda (value dummy)
+                                      (unless (set-in? set2 value)
+                                        (hash-table-put! table value dummy)
+                                        (set! count (add1 count)))))
+               (make-set count table)))])
+      (opt-lambda (set1 set2 (which-set 'new))
+        (let ([new-set (difference-into-new-set set1 set2)])
+          (case which-set
+            [(new) new-set]
+            [(first) 
+             (set-set-table! set1 (set-table new-set))
+             (set-set-cardinality! set1 (set-cardinality new-set))
+             set1]
+            [(second)
+             (set-set-table! set2 (set-table new-set))
+             (set-set-cardinality! set2 (set-cardinality new-set))
+             set2])))))
+  
+  )
diff --git a/collects/mrflow/set-list.ss b/collects/mrflow/set-list.ss
new file mode 100644
index 0000000000..fd45a5c3ef
--- /dev/null
+++ b/collects/mrflow/set-list.ss
@@ -0,0 +1,334 @@
+; sets implementation, using lists.
+; - value equality based on eq? by default, uses equal? if given the 'equal flag
+; - raises exn:set:value-not-found if value not in set when trying
+;   to remove a value.
+; - raise exn:set:duplicate-value by default when trying to add a value to a
+;   set where it already exists
+; - strange things might happen if you use set-union, set-intersection,
+;   or set-difference with two sets that don't use the same comparaison
+;   function: you might end up with duplicate values in some sets.
+;
+; Note: lots of set! and tail-recursive loops in this code, for speed
+
+(module set-list (lib "mrflow.ss" "mrflow")
+  (require
+   (lib "list.ss") ; for foldr
+   (lib "etc.ss") ; for opt-lambda
+   "set-exn.ss" ; no prefix so we can re-provide
+   )
+  
+  ; table = (listof (cons value value))
+  (define-struct set (=? cardinality table))
+  
+  (provide/contract
+   (exn:set? (any/c . -> . boolean?))
+   (struct exn:set:value-not-found ((set set?) (value any/c)))
+   (struct exn:set:duplicate-value ((set set?) (value any/c)))
+   (set-make (() ((symbols 'equal)) . opt-> . set?))
+   (set-reset (set? . -> . set?))
+   (set? (any/c . -> . boolean?))
+   (set-set ((set? any/c) (boolean?) . opt-> . set?))
+   (set-in? (set? any/c . -> . boolean?))
+   (set-remove ((set? any/c) (boolean?) . opt-> . set?))
+   (set-cardinality (set? . -> . non-negative-exact-integer?))
+   (set-empty? (set? . -> . boolean?))
+   (set-copy (set? . -> . set?))
+   (set-map (set? (any/c . -> . any) . -> . (listof any/c)))
+   (set-fold (set? (any/c any/c . -> . any) any/c . -> . any))
+   (set-for-each (set? (any/c . -> . any) . -> . set?))
+   (set-for-each! (set? (any/c . -> . any) . -> . set?))
+   (set-filter ((set? (any/c . -> . boolean?)) ((symbols 'new 'same)) . opt-> . set?))
+   (set-union ((set? set?) ((symbols 'new 'first 'second)) . opt-> . set?))
+   (set-intersection ((set? set?) ((symbols 'new 'first 'second)) . opt-> . set?))
+   (set-difference ((set? set?) ((symbols 'new 'first 'second)) . opt-> . set?))
+   )
+  
+  ; (opt 'equal) -> set
+  ; we test the optional argument ourselves to preserve data abstraction even in the
+  ; presence of an exception
+  (define set-make
+    (case-lambda
+      [() (make-set eq? 0 '())]
+      [(flag) (make-set equal? 0 '())]))
+  
+  ; set -> set
+  ; doesn't change =?
+  (define (set-reset set)
+    (set-set-table! set '())
+    (set-set-cardinality! set 0)
+    set)
+  
+  ; value -> boolean
+  ; set? comes from the structure definition
+  
+  ; set value (opt boolean) -> set
+  (define set-set
+    (opt-lambda (set value (exn? #t))
+      (let ([=? (set-=? set)]
+            [original-table (set-table set)])
+        (set-set-table! set (let loop ([table original-table])
+                              (if (null? table)
+                                  (begin
+                                    (set-set-cardinality! set (add1 (set-cardinality set)))
+                                    (cons value original-table))
+                                  (if (=? (car table) value)
+                                      (if exn?
+                                          (raise-duplicate-value-exn "set-set" set value)
+                                          ; silently ignore
+                                          original-table)
+                                      (loop (cdr table)))))))
+      set))
+  
+  ; set value -> boolean
+  (define (set-in? set value)
+    (let ([=? (set-=? set)])
+      (ormap (lambda (current-value)
+               (=? current-value value))
+             (set-table set))))
+  
+  ; set value (opt boolean) -> set
+  (define set-remove
+    (opt-lambda (set value (exn? #t))
+      (let ([=? (set-=? set)]
+            [original-table (set-table set)])
+        (set-set-table! set
+                        (let loop ([table original-table]
+                                   [previous #f])
+                          (if (null? table)
+                              (if exn?
+                                  (raise-value-not-found-exn "set-remove" set value)
+                                  ; silently ignore
+                                  original-table)
+                              (if (=? (car table) value)
+                                  (begin
+                                    (set-set-cardinality! set (sub1 (set-cardinality set)))
+                                    (if previous
+                                        (begin
+                                          ; return shortened table
+                                          (set-cdr! previous (cdr table))
+                                          original-table)
+                                        (cdr original-table)))
+                                  (loop (cdr table) table))))))
+      set))
+  
+  ; set -> exact-non-negative-integer
+  ; set-cardinality comes from the structure definition
+  
+  ; set -> boolean
+  (define (set-empty? set)
+    (= 0 (set-cardinality set)))
+  
+  ; (listof value) (listof value) -> (listof value)
+  ; creates a (reversed) copy of l1 (to prevent list sharing between sets) and prefixes l2 with it
+  (define (copy-reverse-and-prefix-lists l1 l2)
+    (let loop ([l1 l1]
+               [l2 l2])
+      (if (null? l1)
+          l2
+          (loop (cdr l1) (cons (car l1) l2)))))
+  
+  ; (listof value) -> (listof value)
+  (define (copy-list l)
+    (copy-reverse-and-prefix-lists l '()))
+  
+  ; set -> set
+  (define (set-copy set)
+    (make-set (set-=? set)
+              (set-cardinality set)
+              (copy-list (set-table set))))
+  
+  ; set (value -> value) -> (listof value)
+  (define (set-map set f)
+    (map f (set-table set)))
+  
+  ; set (value value -> value) value -> value
+  (define (set-fold set f acc)
+    (foldr f acc (set-table set)))
+  
+  ; set (value -> value) -> set
+  (define (set-for-each set f)
+    (for-each f (set-table set))
+    set)
+  
+  ; set (value -> value) -> set
+  ; it's up to the user to make sure f is injective. Otherwise we might end up with
+  ; duplicates in the set.
+  ; we know lists are never shared between sets, so we can set-cdr!
+  (define (set-for-each! set f)
+    (let loop ([table (set-table set)])
+      (unless (null? table)
+        (set-car! table (f (car table)))
+        (loop (cdr table))))
+    set)
+  
+  ; set (value -> boolean) (opt (union 'new 'same)) -> set
+  (define set-filter
+    (let (; set (value -> boolean) -> set
+          [filter-into-new-set
+           (lambda (set tester)
+             (let loop ([table (set-table set)]
+                        [new-table '()]
+                        [count 0])
+               (if (null? table)
+                   (make-set (set-=? set) count new-table)
+                   (let ([value (car table)])
+                     (if (tester value)
+                         (loop (cdr table) (cons value new-table) (add1 count))
+                         (loop (cdr table) new-table count))))))])
+      (opt-lambda (set tester (which-set 'new))
+        (let ([new-set (filter-into-new-set set tester)])
+          (case which-set
+            [(new) new-set]
+            [(same)
+             (set-set-table! set (set-table new-set))
+             (set-set-cardinality! set (set-cardinality new-set))
+             set])))))
+  
+  ; set set (opt (union 'new 'first 'second)) -> set
+  (define set-union
+    (opt-lambda (set1 set2 (which-set 'new))
+      (let* ([=? (set-=? set1)]
+             [new-set
+              (let loop ([table1 (set-table set1)]
+                         ; we shouldn't modify the original list
+                         [table2 (copy-list (set-table set2))]
+                         [count1 (set-cardinality set1)]
+                         [count2 (set-cardinality set2)]
+                         [acc '()]
+                         [count 0])
+                (if (null? table1)
+                    ; we have already copied table2, so we can destructively modify it
+                    (make-set =? (+ count count2)
+                              (append! table2 acc))
+                    (if (null? table2)
+                        (make-set =? (+ count count1)
+                                  (copy-reverse-and-prefix-lists table1 acc))
+                        (let ([value1 (car table1)])
+                          ; search table2 for same value
+                          (let loop-set2 ([t2 table2]
+                                          [previous #f])
+                            (if (null? t2)
+                                (begin
+                                  (set! acc (cons value1 acc))
+                                  (set! count (add1 count))
+                                  (set! table1 (cdr table1))
+                                  (set! count1 (sub1 count1)))
+                                (if (=? value1 (car t2))
+                                    (begin
+                                      (set! acc (cons value1 acc))
+                                      (set! count (add1 count))
+                                      (set! table1 (cdr table1))
+                                      (set! count1 (sub1 count1))
+                                      (if previous
+                                          (set-cdr! previous (cdr t2))
+                                          (set! table2 (cdr table2)))
+                                      (set! count2 (sub1 count2)))
+                                    (loop-set2 (cdr t2) t2))))
+                          (loop table1 table2 count1 count2 acc count)))))])
+        (case which-set
+          [(new) new-set]
+          [(first)
+           (set-set-cardinality! set1 (set-cardinality new-set))
+           (set-set-table! set1 (set-table new-set))
+           set1]
+          [(second)
+           (set-set-cardinality! set2 (set-cardinality new-set))
+           (set-set-table! set2 (set-table new-set))
+           set2]))))
+  
+  ; set set (opt (union 'new 'first 'second)) -> set
+  (define set-intersection
+    (opt-lambda (set1 set2 (which-set 'new))
+      (let* ([=? (set-=? set1)]
+             [new-set
+              (let loop ([table1 (set-table set1)]
+                         ; we shouldn't modify the original list
+                         [table2 (copy-list (set-table set2))]
+                         [count1 (set-cardinality set1)]
+                         [count2 (set-cardinality set2)]
+                         [acc '()]
+                         [count 0])
+                (if (null? table1)
+                    (make-set =? count acc)
+                    (if (null? table2)
+                        (make-set =? count acc)
+                        (let ([value1 (car table1)])
+                          ; search table2 for same value
+                          (let loop-set2 ([t2 table2]
+                                          [previous #f])
+                            (if (null? t2)
+                                (begin
+                                  (set! table1 (cdr table1))
+                                  (set! count1 (sub1 count1)))
+                                (if (=? value1 (car t2))
+                                    (begin
+                                      (set! acc (cons value1 acc))
+                                      (set! count (add1 count))
+                                      (set! table1 (cdr table1))
+                                      (set! count1 (sub1 count1))
+                                      (if previous
+                                          (set-cdr! previous (cdr t2))
+                                          (set! table2 (cdr table2)))
+                                      (set! count2 (sub1 count2)))
+                                    (loop-set2 (cdr t2) t2))))
+                          (loop table1 table2 count1 count2 acc count)))))])
+        (case which-set
+          [(new) new-set]
+          [(first)
+           (set-set-cardinality! set1 (set-cardinality new-set))
+           (set-set-table! set1 (set-table new-set))
+           set1]
+          [(second)
+           (set-set-cardinality! set2 (set-cardinality new-set))
+           (set-set-table! set2 (set-table new-set))
+           set2]))))
+  
+  ; set set (opt (union 'new 'first 'second)) -> set
+  (define set-difference
+    (opt-lambda (set1 set2 (which-set 'new))
+      (let* ([=? (set-=? set1)]
+             [new-set
+              (let loop ([table1 (set-table set1)]
+                         ; we shouldn't modify the original list
+                         [table2 (copy-list (set-table set2))]
+                         [count1 (set-cardinality set1)]
+                         [count2 (set-cardinality set2)]
+                         [acc '()]
+                         [count 0])
+                (if (null? table1)
+                    (make-set =? count acc)
+                    (if (null? table2)
+                        (make-set =? (+ count count1)
+                                  (copy-reverse-and-prefix-lists table1 acc))
+                        (let ([value1 (car table1)])
+                          ; search table2 for same value
+                          (let loop-set2 ([t2 table2]
+                                          [previous #f])
+                            (if (null? t2)
+                                (begin
+                                  (set! acc (cons value1 acc))
+                                  (set! count (add1 count))
+                                  (set! table1 (cdr table1))
+                                  (set! count1 (sub1 count1)))
+                                (if (=? value1 (car t2))
+                                    (begin
+                                      (set! table1 (cdr table1))
+                                      (set! count1 (sub1 count1))
+                                      (if previous
+                                          (set-cdr! previous (cdr t2))
+                                          (set! table2 (cdr table2)))
+                                      (set! count2 (sub1 count2)))
+                                    (loop-set2 (cdr t2) t2))))
+                          (loop table1 table2 count1 count2 acc count)))))])
+        (case which-set
+          [(new) new-set]
+          [(first)
+           (set-set-cardinality! set1 (set-cardinality new-set))
+           (set-set-table! set1 (set-table new-set))
+           set1]
+          [(second)
+           (set-set-cardinality! set2 (set-cardinality new-set))
+           (set-set-table! set2 (set-table new-set))
+           set2]))))
+  
+  )
diff --git a/collects/mrflow/snips-and-arrows-model.ss b/collects/mrflow/snips-and-arrows-model.ss
new file mode 100644
index 0000000000..6cf60a3d3c
--- /dev/null
+++ b/collects/mrflow/snips-and-arrows-model.ss
@@ -0,0 +1,842 @@
+; DrScheme starts counting positions at 0, MzScheme starts counting positions at 1.
+; Syntax objects use MzScheme positions, all the positions in this file use DrScheme
+; positions. In all cases positions are exact non-negative integer.
+; Among DrScheme positions, some are so-called new positions "new-pos" and some are
+; old positions "old-pos". An old position is a position in the editor before any snip
+; was inserted. A new position is the same position in the editor, but after snips
+; might have been inserted.
+; (define-type position exact-non-negative-integer)
+; DrScheme also has locations, which are real x and y coordinates in the editor.
+; (define-type location real) these are not used here but are used in the view part.
+;
+; This whole module can only deal with snips that are on the left of the label (see
+; new-pos->old-pos and old-pos->new-pos for example).
+
+(module snips-and-arrows-model (lib "mrflow.ss" "mrflow")
+  (require
+   (prefix lst: (lib "list.ss"))
+   
+   (prefix cst: "constants.ss")
+   ;"set-list.ss"
+   "set-hash.ss"
+   ;"assoc-set-list.ss"
+   "assoc-set-hash.ss"
+   "labels.ss"
+   )
+  
+  ; DATA STRUCTURES
+  ; label label boolean
+  (define-struct arrow (start-label end-label tacked? color))
+  
+  ; exact-non-negative-integer
+  (define-struct snip-group (size))
+  
+  ; We could recompute left-new-pos on the fly (from the MzScheme
+  ; pos from the label itself and old-pos->new-pos) each time we needed to repaint,
+  ; but in practice we repaint much more often then we add snips, so we keep the pos
+  ; here as a cache which is computed once from scratch when we add the label to
+  ; displayed-arrows and which is then just updated each time we add a new snip.
+  ; Likewise, total-number-of-snips could be recomputed on the fly from snip-groups-by-type,
+  ; but is used as a cache to speed up old-pos->new-pos and new-pos->old-pos, which are used
+  ; pretty often.
+  ; Note that the data structure for a single arrow will be shared between two
+  ; label-gui-data structures: it will appear once in the "starting-arrows"
+  ; set for its start label, and once in the "ending-arrows" set for its end label.
+  ; We need this because we need to be able to click at the end of an arrow and
+  ; remove it if necessary.
+  (define-struct label-gui-data (; position
+                                 left-new-pos
+                                 ; exact-integer
+                                 span-change
+                                 ; exact-non-negative-integer
+                                 total-number-of-snips
+                                 ; (assoc-setof symbol snip-group)
+                                 snip-groups-by-type
+                                 ; (setof arrow)
+                                 starting-arrows
+                                 ; (setof arrow)
+                                 ending-arrows))
+  
+  ; Note that several labels might have a given position (due to macros) and we use a list
+  ; instead of a set because we expect the sets to be very small (i.e. only one label is
+  ; normally registered for a given position, maybe two or three if there are macros, so
+  ; we do expect the list to be very short) but we expect a great number of them (i.e. we
+  ; expect pretty much all terms in a program to be registered).  Sets have an better asymptotic
+  ; access time but onyl for big sets compared to lists, and they consumme much more memory than
+  ; lists (since we usually use the hash-table-based implementation of sets), so using lists
+  ; here for labels-by-mzscheme-position is probably the fastest and most memory efficient
+  ; solution here given our assumptions.
+  (define-struct source-gui-data (; (assoc-setof label label-gui-data)
+                                  label-gui-data-by-label
+                                  ; (assoc-setof non-negative-exact-integer (non-empty-listof label))
+                                  labels-by-mzscheme-position
+                                  ; exact-non-negative-integer
+                                  total-number-of-snips))
+  
+  (define-struct gui-model-state (; (assoc-setof source source-gui-data)
+                                  source-gui-data-by-source
+                                  ; (label -> top)
+                                  get-source-from-label
+                                  ; (label -> non-negative-exact-integer)
+                                  get-mzscheme-position-from-label
+                                  ; (label -> non-negative-exact-integer)
+                                  get-original-span-from-label
+                                  ; (label -> non-negative-exact-integer)
+                                  get-span-from-label
+                                  ; (listof symbol)
+                                  snip-type-list
+                                  ))
+  
+  (provide/contract
+   (make-gui-model-state ((label? . -> . any)
+                          (label? . -> . non-negative-exact-integer?)
+                          (label? . -> . non-negative-exact-integer?)
+                          (listof symbol?)
+                          . -> . gui-model-state?))
+   (rename get-related-labels-from-drscheme-new-pos-and-source
+           get-related-labels-from-drscheme-pos-and-source
+           (gui-model-state? non-negative-exact-integer? any/c . -> . (listof label?)))
+   (rename gui-model-state-get-span-from-label
+           make-get-span-from-label-from-model-state
+           (gui-model-state? . -> . (label? . -> . non-negative-exact-integer?)))
+   
+   (for-each-source (gui-model-state? (any/c . -> . void?) . -> .void?))
+   (register-source-with-gui (gui-model-state? any/c . -> . any))
+   (is-source-registered? (gui-model-state? any/c . -> . boolean?))
+   
+   (register-label-with-gui (gui-model-state? label? . -> . any))
+   (get-position-from-label (gui-model-state? label? . -> . non-negative-exact-integer?))
+   (user-change-terms (gui-model-state?
+                       (listof label?)
+                       any/c
+                       non-negative-exact-integer?
+                       . -> . (values non-negative-exact-integer? non-negative-exact-integer?)))
+   (for-each-label-in-source (gui-model-state? any/c (label? . -> . void?) . -> . void?))
+   
+   (add-arrow (gui-model-state? (list/c label? label? string?) boolean? . -> . void?))
+   (remove-arrows (gui-model-state? label? (union symbol? boolean?) boolean? . -> . void?))
+   (remove-all-arrows (gui-model-state? . -> . void?))
+   (for-each-arrow (gui-model-state? (non-negative-exact-integer? non-negative-exact-integer? non-negative-exact-integer? non-negative-exact-integer? any/c any/c boolean? string? . -> . void?) . -> . void?))
+   (get-tacked-arrows-from-label (gui-model-state? label? . -> . non-negative-exact-integer?))
+   
+   (for-each-snip-type (gui-model-state? (symbol? . -> . void?) . -> . void?))
+   (label-has-snips-of-this-type? (gui-model-state? label? symbol? . -> . boolean?))
+   (snips-currently-displayed-in-source? (gui-model-state? any/c . -> . boolean?))
+   (add-snips (gui-model-state? label? symbol? any/c non-negative-exact-integer? . -> . non-negative-exact-integer?))
+   (remove-inserted-snips (gui-model-state? label? symbol? any/c . -> . (values non-negative-exact-integer? non-negative-exact-integer?)))
+   )
+  
+  ; (label -> top)
+  ; (label -> non-negative-exact-integer)
+  ; (label -> non-negative-exact-integer)
+  ; (listof symbol)
+  ; -> gui-model-state
+  (set! make-gui-model-state
+        (let ([real-make-gui-model-state make-gui-model-state])
+          (lambda (get-source-from-label
+                   get-mzscheme-position-from-label
+                   get-span-from-label
+                   snip-type-list)
+            (let ([source-gui-data-by-source (assoc-set-make)])
+              (real-make-gui-model-state
+               source-gui-data-by-source
+               get-source-from-label
+               get-mzscheme-position-from-label
+               get-span-from-label
+               (lambda (label)
+                 (let* ([span (get-span-from-label label)]
+                        [source-gui-data
+                         (assoc-set-get source-gui-data-by-source (get-source-from-label label))]
+                        [label-gui-data
+                         (assoc-set-get (source-gui-data-label-gui-data-by-label source-gui-data)
+                                        label cst:thunk-false)])
+                   (if label-gui-data
+                       (+ span (label-gui-data-span-change label-gui-data))
+                       span)))
+               snip-type-list)))))
+  
+  
+  ; DRSCHEME / MZSCHEME CONVERSIONS
+  ; non-negative-exact-integer -> non-negative-exact-integer
+  (define drscheme-pos->mzscheme-pos add1)
+  
+  ; non-negative-exact-integer -> non-negative-exact-integer
+  (define mzscheme-pos->drscheme-pos sub1)
+  
+  
+  ; SOURCES
+  ; gui-model-state top -> top
+  (define (register-source-with-gui gui-model-state source)
+    (assoc-set-set (gui-model-state-source-gui-data-by-source gui-model-state)
+                   source
+                   (make-source-gui-data (assoc-set-make)
+                                         (assoc-set-make)
+                                         0))
+    source)
+  
+  ; gui-model-state top -> boolean
+  (define (is-source-registered? gui-model-state source)
+    (assoc-set-in? (gui-model-state-source-gui-data-by-source gui-model-state) source))
+  
+  ; gui-model-state (top -> void) -> void
+  ; applies f to each source
+  (define (for-each-source gui-model-state f)
+    (assoc-set-for-each (gui-model-state-source-gui-data-by-source gui-model-state)
+                        (lambda (source source-gui-data)
+                          (f source)))
+    cst:void)
+  
+  ; gui-model-state top -> boolean
+  ; are we currently displaying some snips in the source?
+  (define (snips-currently-displayed-in-source? gui-model-state source)
+    (let ([source-gui-data
+           (assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state)
+                          source cst:thunk-false)])
+      (if source-gui-data
+          (< 0 (source-gui-data-total-number-of-snips source-gui-data))
+          #f)))
+  
+  
+  ; LABELS
+  ; gui-model-state label -> exact-non-negative-integer
+  ; returns the left position of the expression.  The computation is done from scratch,
+  ; so only use this function if the position hasn't been yet cached in the label's gui data.
+  (define (get-new-pos-from-label gui-model-state label)
+    (old-pos->new-pos
+     gui-model-state
+     (mzscheme-pos->drscheme-pos
+      ((gui-model-state-get-mzscheme-position-from-label gui-model-state) label))
+     ((gui-model-state-get-source-from-label gui-model-state) label)))
+  
+  ; gui-model-state label -> exact-non-negative-integer
+  ; returns the left position of the expression represented by the label
+  (define (get-position-from-label gui-model-state label)
+    (let* ([source ((gui-model-state-get-source-from-label gui-model-state) label)]
+           [source-gui-data
+            (assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state) source)]
+           [label-gui-data-by-label
+            (source-gui-data-label-gui-data-by-label source-gui-data)]
+           [label-gui-data
+            (assoc-set-get label-gui-data-by-label label cst:thunk-false)])
+      (if label-gui-data
+          (label-gui-data-left-new-pos label-gui-data)
+          (get-new-pos-from-label gui-model-state label))))
+  
+  ; gui-model-state label -> (union top #f)
+  ; we register the source of the label and the label by its position,
+  ; but we don't associate any label-gui-data with it yet, to save memory.
+  ; We'll associate some label-gui-data with it on the fly, as needed (when
+  ; needing to remember some arrows or snips for that label, not before).
+  ; We return the source only the first time a label is registered for it
+  ; (the view part uses this to initialize the state of the source).
+  (define (register-label-with-gui gui-model-state label)
+    (let* ([source-gui-data-by-source
+            (gui-model-state-source-gui-data-by-source gui-model-state)]
+           [source
+            ((gui-model-state-get-source-from-label gui-model-state) label)]
+           [source-gui-data
+            (assoc-set-get source-gui-data-by-source source cst:thunk-false)]
+           [mzscheme-pos
+            ((gui-model-state-get-mzscheme-position-from-label gui-model-state) label)])
+      (if source-gui-data
+          (let ([labels-by-mzscheme-position
+                 (source-gui-data-labels-by-mzscheme-position source-gui-data)])
+            ; So, in the good old days I used to check whether a given label was already registered
+            ; for the given position, and gave an error when such was the case.  But macros can
+            ; duplicate terms, so in the good not-so-old days I added a test such that an error
+            ; would show up only if the labels didn't represent the same original term.  But Matthew
+            ; then told me that a given term that's duplicated by a macro might be represented by
+            ; two syntax objects that are not eq?.  So at that point I had the choice between
+            ; converting the two syntax-objects into sexprs and using equal? to check whether
+            ; they actually represented the same term (and that would have been only a heurisitc,
+            ; since it would not have detected bugs in a macro that gave the same position to
+            ; two identical source terms), or what I do now: just register all the labels no
+            ; matter what.  This solution also means I don't have to have a get-term-from-label
+            ; function in my interface.
+            ; Note that we still make sure the exact same label is not already registered with
+            ; the gui, otherwise we'll try to add the same arrows twice which will lead to error
+            ; messages in add-one-arrow-end
+            (let ([currently-registered-labels-for-this-position
+                   (assoc-set-get labels-by-mzscheme-position
+                                  mzscheme-pos
+                                  cst:thunk-empty)])
+              (unless (memq label currently-registered-labels-for-this-position)
+                (assoc-set-set labels-by-mzscheme-position
+                               mzscheme-pos
+                               (cons label currently-registered-labels-for-this-position)
+                               #f))
+              #f))
+          (begin
+            ; source unknown: register it and try again
+            (register-source-with-gui gui-model-state source)
+            (register-label-with-gui gui-model-state label)
+            source))))
+  
+  ; gui-model-state (listof label) text% exact-integer -> (values non-negative-exact-integer non-negative-exact-integer)
+  ; Modify the span of the labels and move snips on the right, returning the interval
+  ; that has to be deleted and the new interval that has to be colored (for a total of
+  ; three numbers, since both intervals start at the same position)
+  ; We know from saav:user-change-terms that all the labels represent the same term
+  (define (user-change-terms gui-model-state labels source new-span)
+    (let* ([source-gui-data-by-source (gui-model-state-source-gui-data-by-source gui-model-state)]
+           [source-gui-data (assoc-set-get source-gui-data-by-source source)]
+           [label-gui-data-by-label (source-gui-data-label-gui-data-by-label source-gui-data)]
+           [label (car labels)]
+           [old-span ((gui-model-state-get-span-from-label gui-model-state) label)]
+           [change (- new-span old-span)]
+           [left-new-pos (get-position-from-label gui-model-state label)])
+      (for-each
+       (lambda (label)
+         (let ([label-gui-data (assoc-set-get label-gui-data-by-label label cst:thunk-false)])
+           (if label-gui-data
+               (set-label-gui-data-span-change!
+                label-gui-data
+                (+ change (label-gui-data-span-change label-gui-data)))
+               (assoc-set-set label-gui-data-by-label
+                              label
+                              (make-label-gui-data left-new-pos
+                                                   change
+                                                   0
+                                                   (assoc-set-make)
+                                                   (set-make)
+                                                   (set-make))))))
+       labels)
+      (move-poss gui-model-state source left-new-pos change + >)
+      (values (+ left-new-pos old-span) (+ left-new-pos new-span))))
+  
+  ; gui-model-state top (label -> void) -> void
+  ; apply f to all registered labels
+  (define (for-each-label-in-source gui-model-state source f)
+    (let ([source-gui-data
+           (assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state) source)])
+      (when source-gui-data
+        (assoc-set-for-each
+         (source-gui-data-labels-by-mzscheme-position source-gui-data)
+         (lambda (mzscheme-pos labels)
+           (for-each f labels)))))
+    cst:void)
+  
+  
+  ; POS AND SOURCE TO LABEL CONVERSIONS
+  ; gui-model-state non-negative-exact-integer top -> (listof label)
+  ; finds the labels corresponding to a given new-pos in a given source
+  (define (get-related-labels-from-drscheme-new-pos-and-source gui-model-state new-pos source)
+    (get-related-labels-from-drscheme-old-pos-and-source
+     gui-model-state
+     (new-pos->old-pos gui-model-state new-pos source)
+     source))
+  
+  ; gui-model-state non-negative-exact-integer top -> (listof label)
+  ; we loop down starting from old-pos, until we find a label. Then we have to check
+  ; that the original old-pos falls within the original span of that label.
+  (define (get-related-labels-from-drscheme-old-pos-and-source gui-model-state old-pos source)
+    (let ([get-original-span-from-label
+           (gui-model-state-get-original-span-from-label gui-model-state)]
+          [source-gui-data
+           (assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state)
+                          source cst:thunk-false)])
+      (if source-gui-data
+          (let ([labels-by-mzscheme-position (source-gui-data-labels-by-mzscheme-position source-gui-data)]
+                [starting-mzscheme-pos (drscheme-pos->mzscheme-pos old-pos)])
+            (let loop ([current-mzscheme-pos starting-mzscheme-pos])
+              (if (> 0 current-mzscheme-pos)
+                  '()
+                  (let ([labels (assoc-set-get labels-by-mzscheme-position current-mzscheme-pos cst:thunk-false)])
+                    (if labels
+                        ; Note that if the label's span is too small, we stop looping.
+                        ; This means that in an expression like (abc def), if the mouse
+                        ; pointer points at the space character, #f will be returned,
+                        ; not the label for the whole expression.
+                        (let ([mouse-distance (- starting-mzscheme-pos current-mzscheme-pos)])
+                          (lst:filter (lambda (label)
+                                        (< mouse-distance (get-original-span-from-label label)))
+                                      labels))
+                        (loop (sub1 current-mzscheme-pos)))))))
+          '())))
+  
+  
+  ; OLD-POS / NEW-POS CONVERSIONS
+  ; gui-model-state exact-non-negative-integer top -> exact-non-negative-integer
+  ; converts an old position (before insertion of any snip) to a new position
+  ; (after insertion of all the currently inserted snips).
+  ; Note: the test is "<=", which means the new position is to the right of all
+  ; the current snips that have positions corresponding to the same old position
+  ; (i.e. to the right of all the snips that have already been inserted for that label).
+  (define (old-pos->new-pos gui-model-state old-pos source)
+    (let ([new-pos old-pos]
+          [get-mzscheme-position-from-label
+           (gui-model-state-get-mzscheme-position-from-label gui-model-state)]
+          [get-original-span-from-label
+           (gui-model-state-get-original-span-from-label gui-model-state)]
+          [get-span-from-label
+           (gui-model-state-get-span-from-label gui-model-state)]
+          [source-gui-data
+           (assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state)
+                          source cst:thunk-false)])
+      (when source-gui-data
+        (assoc-set-for-each
+         (source-gui-data-label-gui-data-by-label source-gui-data)
+         (lambda (label label-gui-data)
+           (let ([label-left-old-pos (mzscheme-pos->drscheme-pos (get-mzscheme-position-from-label label))])
+             (cond
+               ; the order of the clauses is important here
+               ; old-pos is on the right of the original expression represented by the label
+               [(<= (+ label-left-old-pos (get-original-span-from-label label)) old-pos)
+                (set! new-pos (+ new-pos
+                                 (label-gui-data-span-change label-gui-data)
+                                 (label-gui-data-total-number-of-snips label-gui-data)))]
+               ; old-pos is somewhere in the middle of the expression represented by the label
+               ; then we have to take care of the case when the current expression is smaller than
+               ; the original expression (because an identifier was changed)
+               [(<= label-left-old-pos old-pos)
+                (if (<= (+ label-left-old-pos (get-span-from-label label)) old-pos)
+                    ; expression has shrinked, and old-pos was in the part that disappeared,
+                    ; so we make sure the new-pos is at least within the current expression
+                    ; by acting as if old-pos were label-left-old-pos (i.e. moving old-pos
+                    ; to the left end of the expression). Note that this makes old-pos->new-pos
+                    ; not bijective anymore.
+                    (set! new-pos (+ new-pos
+                                     (- label-left-old-pos old-pos)
+                                     (label-gui-data-total-number-of-snips label-gui-data)))
+                    ; either expression has not shrinked, or if it has, old-pos is sufficiently
+                    ; in the left part that we don't have to worry about it
+                    (set! new-pos (+ new-pos
+                                     (label-gui-data-total-number-of-snips label-gui-data))))]
+               ; old-pos is on the left of the expression => do nothing
+               )))))
+      new-pos))
+  
+  ; gui-model-state exact-non-negative-integer top -> exact-non-negative-integer
+  ; Note: the test is "<", because there might a snip that has the exact same
+  ; position as new-pos, so, since a snip at position n is shown graphically
+  ; between position n and n+1, we don't want to take that snip into account
+  ; (i.e. that snip is on the right of the cursor or mouse pointer, not on the
+  ; left).
+  ; Note also that we have to be carefull: in old-pos->new-pos we add all the snips
+  ; to the new-pos when the label has an old-pos to the left of or at the cursor.
+  ; But here the cursor might be between two snips. So we have to consider each snip
+  ; separately, we can't consider them group by group anymore.
+  (define (new-pos->old-pos gui-model-state new-pos source)
+    (let ([old-pos new-pos]
+          [get-original-span-from-label
+           (gui-model-state-get-original-span-from-label gui-model-state)]
+          [get-span-from-label
+           (gui-model-state-get-span-from-label gui-model-state)]
+          [source-gui-data
+           (assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state)
+                          source cst:thunk-false)])
+      (when source-gui-data
+        (assoc-set-for-each
+         (source-gui-data-label-gui-data-by-label source-gui-data)
+         (lambda (label label-gui-data)
+           (let ([label-left-new-pos (label-gui-data-left-new-pos label-gui-data)]
+                 [total-number-of-snips (label-gui-data-total-number-of-snips label-gui-data)])
+             (cond
+               ; the order of the clauses is important here
+               ; new-pos is on the right of the expression represented by the label
+               [(<= (+ label-left-new-pos (get-span-from-label label)) new-pos)
+                (set! old-pos (- old-pos
+                                 (label-gui-data-span-change label-gui-data)
+                                 (label-gui-data-total-number-of-snips label-gui-data)))]
+               ; new-pos is somewhere in the middle of the expression represented by the label
+               ; then we have to take care of the case when the current expression is bigger than
+               ; the original expression (because an identifier was changed)
+               [(<= label-left-new-pos new-pos)
+                (if (<= (+ label-left-new-pos (get-original-span-from-label label)) new-pos)
+                    ; expression has expanded, and new-pos was in the part that was added,
+                    ; so we make sure the old-pos is at least within the current expression
+                    ; by acting as if new-pos were label-left-new-pos (i.e. moving new-pos
+                    ; to the left end of the expression). Note that this makes new-pos->old-pos
+                    ; not bijective anymore.
+                    (set! old-pos (- old-pos
+                                     (- new-pos label-left-new-pos)
+                                     (label-gui-data-total-number-of-snips label-gui-data)))
+                    ; either expression has not expanded, or if it has, new-pos is sufficiently
+                    ; in the left part that we don't have to worry about it
+                    (set! old-pos (- old-pos
+                                     (label-gui-data-total-number-of-snips label-gui-data))))]
+               ; new-pos is on the left of the expression but in the middle of the snips
+               ; at that point we could either loop over the snips groups one by one and test
+               ; them using their left-new-pos, or we can directly compute the total number of
+               ; snips on the left of new-pos using the label's left-new-pos and
+               ; total-number-of-snips. Since the second method is easier, we do it that way.
+               [(<= (- label-left-new-pos total-number-of-snips) new-pos)
+                (set! old-pos (- old-pos
+                                 (- total-number-of-snips (- label-left-new-pos new-pos))))]
+               ; new-pos is on the left of the expression and the snips => do nothing
+               )))))
+      old-pos))
+  
+  ; gui-model-state top exact-non-negative-integer exact-integer
+  ; (exact-non-negative-integer exact-integer -> exact-integer)
+  ; (exact-non-negative-integer exact-integer -> boolean) -> void
+  ; moves all snips and arrows that are after start, by len. start is a new position (i.e. after
+  ; insertion of snips). We need to do all that so that old-pos->new-pos and new-pos->old-pos
+  ; and the arrow display keep working correctly when we add new snips in the middle of others.
+  (define (move-poss gui-model-state source start len add comp)
+    (let ([move-pos (lambda (pos) (if (comp pos start) (add pos len) pos))]
+          [source-gui-data
+           (assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state) source)])
+      (assoc-set-for-each
+       (source-gui-data-label-gui-data-by-label source-gui-data)
+       (lambda (label label-gui-data)
+         (set-label-gui-data-left-new-pos!
+          label-gui-data (move-pos (label-gui-data-left-new-pos label-gui-data))))))
+    cst:void)
+  
+  
+  ; ARROWS
+  ; gui-model-state (list label label string) boolean -> void
+  ; add one arrow going from start-label to end-label, duh.
+  (define (add-arrow gui-model-state arrow-info tacked?)
+    (let* ([start-label (car arrow-info)]
+           [end-label (cadr arrow-info)]
+           [new-arrow (make-arrow start-label end-label tacked? (caddr arrow-info))])
+      (add-one-arrow-end gui-model-state
+                         new-arrow
+                         start-label
+                         end-label
+                         arrow-end-label
+                         label-gui-data-starting-arrows
+                         (lambda () (set-set (set-make) new-arrow))
+                         set-make)
+      (add-one-arrow-end gui-model-state
+                         new-arrow
+                         end-label
+                         start-label
+                         arrow-start-label
+                         label-gui-data-ending-arrows
+                         set-make
+                         (lambda () (set-set (set-make) new-arrow)))))
+  
+  ; gui-model-state arrow label label (arrow -> label) (label-gui-data -> (setof arrow)
+  ; (-> (setof arrow)) (-> (setof arrow)) -> void
+  ; adds arrow structure to the label's gui data, for one end of the arrow
+  (define (add-one-arrow-end gui-model-state new-arrow this-end-label other-end-label
+                             arrow-other-end-label-selector label-gui-data-this-end-arrow-set-selector
+                             make-starting-arrow-set make-ending-arrow-set)
+    (let* ([this-end-source
+            ((gui-model-state-get-source-from-label gui-model-state) this-end-label)]
+           [this-end-source-gui-data
+            (assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state) this-end-source)]
+           [this-end-label-gui-data-by-label
+            (source-gui-data-label-gui-data-by-label this-end-source-gui-data)]
+           [this-end-label-gui-data
+            (assoc-set-get this-end-label-gui-data-by-label this-end-label cst:thunk-false)])
+      (if this-end-label-gui-data
+          (let* ([this-end-arrow-set
+                  (label-gui-data-this-end-arrow-set-selector this-end-label-gui-data)]
+                 [same-arrow-set (set-filter this-end-arrow-set
+                                             (lambda (arrow)
+                                               (eq? other-end-label
+                                                    (arrow-other-end-label-selector arrow))))])
+            (if (set-empty? same-arrow-set)
+                ; the arrow doesn't already exist, so add the arrow to the start set
+                (set-set this-end-arrow-set new-arrow)
+                ; the arrow already exists
+                (let* ([new-arrow-tacked? (arrow-tacked? new-arrow)]
+                       [old-arrow (if (= (set-cardinality same-arrow-set) 1)
+                                      (car (set-map same-arrow-set cst:id))
+                                      (error 'add-one-arrow-end "duplicate arrows"))]
+                       [old-arrow-tacked? (arrow-tacked? old-arrow)])
+                  (if new-arrow-tacked?
+                      (if old-arrow-tacked?
+                          (error 'add-one-arrow-end "tacked arrow already exists")
+                          (error 'add-one-arrow-end "can't tack arrow over untacked one"))
+                      (if old-arrow-tacked?
+                          cst:void ; happens when moving mouse over label with tacked arrows
+                          (error 'add-one-arrow-end "untacked arrow already exists"))))))
+          (assoc-set-set this-end-label-gui-data-by-label
+                         this-end-label
+                         (make-label-gui-data (get-new-pos-from-label gui-model-state this-end-label)
+                                              0
+                                              0
+                                              (assoc-set-make)
+                                              (make-starting-arrow-set)
+                                              (make-ending-arrow-set)))))
+    cst:void)
+  
+  ; gui-model-state label (union symbol boolean) boolean -> void
+  ; remove arrows starting at given label AND arrows ending at same given label
+  ; Note that assoc-set-get will fail if we try to remove non-existant arrows...
+  (define (remove-arrows gui-model-state start-label tacked? exn?)
+    (let* ([source-gui-data-by-source
+            (gui-model-state-source-gui-data-by-source gui-model-state)]
+           [get-source-from-label (gui-model-state-get-source-from-label gui-model-state)]
+           [source (get-source-from-label start-label)]
+           [source-gui-data (assoc-set-get source-gui-data-by-source source)]
+           [label-gui-data-by-label
+            (source-gui-data-label-gui-data-by-label source-gui-data)]
+           [start-label-gui-data
+            (if exn?
+                (assoc-set-get label-gui-data-by-label start-label)
+                (assoc-set-get label-gui-data-by-label start-label cst:thunk-false))])
+      ; at this point, if the key was not found, either exn? was true and an exception
+      ; was raised, or it was false and start-label-gui-data is false
+      (when start-label-gui-data
+        (remove-both-ends source-gui-data-by-source
+                          (label-gui-data-starting-arrows start-label-gui-data)
+                          tacked?
+                          arrow-end-label
+                          label-gui-data-ending-arrows
+                          get-source-from-label)
+        (remove-both-ends source-gui-data-by-source
+                          (label-gui-data-ending-arrows start-label-gui-data)
+                          tacked?
+                          arrow-start-label
+                          label-gui-data-starting-arrows
+                          get-source-from-label)))
+    cst:void)
+  
+  ; (assoc-setof top source-gui-data) (setof arrow) (union symbol boolean)
+  ; (arrow -> label) (label-gui-data -> (setof arrow))
+  ; (label -> top)
+  ; -> (setof arrow)
+  ; remove arrows starting at given label OR arrows ending at given
+  ; label (depending on selectors/settors)
+  ; the result is thrown away by the caller...
+  (define (remove-both-ends source-gui-data-by-source set tacked?
+                            arrow-other-end-label-selector label-gui-data-other-end-arrow-set-selector
+                            get-source-from-label)
+    (if (eq? tacked? 'all)
+        ; remove all the other ends and reset this end
+        ; we could do without this case and use the set-filter way used in the "else" case
+        ; of this if, but doing it that way here is faster because we don't bother testing
+        ; and removing each arrow from the set one by one, we just reset the whole thing.
+        (begin
+          (set-for-each set (lambda (arrow)
+                              (remove-other-end source-gui-data-by-source arrow
+                                                arrow-other-end-label-selector label-gui-data-other-end-arrow-set-selector
+                                                get-source-from-label)))
+          (set-reset set))
+        ; remove other end while filtering this set
+        (set-filter set
+                    (lambda (arrow)
+                      (if (eq? tacked? (arrow-tacked? arrow))
+                          (begin
+                            (remove-other-end source-gui-data-by-source arrow
+                                              arrow-other-end-label-selector label-gui-data-other-end-arrow-set-selector
+                                              get-source-from-label)
+                            #f)
+                          #t))
+                    'same)))
+  
+  ; (assoc-setof top source-gui-data) arrow (arrow -> label) (label-gui-data -> (setof arrow))
+  ; (label -> top) -> (setof arrow)
+  ; removes one arrow structure reference corresponding to the remote end of the arrow we
+  ; are removing in remove-both-ends above.  We know the arrow is there, so no need to test
+  ; whether label-gui-data-by-source-and-label and label-gui-data-by-label are false or not.
+  ; the result is thrown away by the caller...
+  (define (remove-other-end source-gui-data-by-source arrow
+                            arrow-other-end-label-selector label-gui-data-other-end-arrow-set-selector
+                            get-source-from-label)
+    (let* ([other-end-label (arrow-other-end-label-selector arrow)]
+           [other-end-source (get-source-from-label other-end-label)]
+           [other-end-source-gui-data
+            (assoc-set-get source-gui-data-by-source other-end-source)]
+           [other-end-label-gui-data
+            (assoc-set-get (source-gui-data-label-gui-data-by-label other-end-source-gui-data)
+                           other-end-label)]
+           [other-end-arrow-set (label-gui-data-other-end-arrow-set-selector other-end-label-gui-data)])
+      (set-remove other-end-arrow-set arrow)))
+  
+  ; gui-model-state -> void
+  ; remove all arrows in all sources
+  ; This is faster than looping over each source and then each label in each source and
+  ; then removing each arrow one by one for each label using remove-arrows.
+  (define (remove-all-arrows gui-model-state)
+    (let ([source-gui-data-by-source (gui-model-state-source-gui-data-by-source gui-model-state)])
+      (assoc-set-for-each
+       source-gui-data-by-source
+       (lambda (source source-gui-data)
+         (assoc-set-for-each
+          (source-gui-data-label-gui-data-by-label source-gui-data)
+          (lambda (label label-gui-data)
+            (set-reset (label-gui-data-starting-arrows label-gui-data))
+            (set-reset (label-gui-data-ending-arrows label-gui-data)))))))
+    cst:void)
+  
+  ; gui-model-state
+  ; (non-negative-exact-integer non-negative-exact-integer non-negative-exact-integer non-negative-exact-integer top top boolean string -> void)
+  ; -> void
+  ; applies f to each arrow. The args for f are: the left new-pos of the start label, the
+  ; left new-pos of the end label, the corresponding spans, the start and end sources,
+  ; whether the arrow is tacked or not, and the color.
+  (define (for-each-arrow gui-model-state f)
+    (let ([get-span-from-label (gui-model-state-get-span-from-label gui-model-state)]
+          [get-source-from-label (gui-model-state-get-source-from-label gui-model-state)]
+          [source-gui-data-by-source (gui-model-state-source-gui-data-by-source gui-model-state)])
+      (assoc-set-for-each
+       source-gui-data-by-source
+       (lambda (start-source start-source-gui-data)
+         (let ([label-gui-data-by-label (source-gui-data-label-gui-data-by-label start-source-gui-data)])
+           (assoc-set-for-each
+            label-gui-data-by-label
+            (lambda (start-label start-label-gui-data)
+              (set-for-each (label-gui-data-starting-arrows start-label-gui-data)
+                            (lambda (arrow)
+                              (let* ([end-label (arrow-end-label arrow)]
+                                     [end-source (get-source-from-label end-label)]
+                                     [end-source-gui-data ; the arrow exists, so this is not #f
+                                      (assoc-set-get source-gui-data-by-source end-source)]
+                                     [end-label-gui-data-by-label
+                                      (source-gui-data-label-gui-data-by-label end-source-gui-data)]
+                                     [end-label-gui-data
+                                      (assoc-set-get end-label-gui-data-by-label end-label)])
+                                (f (label-gui-data-left-new-pos start-label-gui-data)
+                                   (label-gui-data-left-new-pos end-label-gui-data)
+                                   (get-span-from-label start-label)
+                                   (get-span-from-label end-label)
+                                   start-source
+                                   end-source
+                                   (arrow-tacked? arrow)
+                                   (arrow-color arrow)))))))))))
+    cst:void)
+  
+  ; (gui-model-state label -> non-negative-exact-integer)
+  ; counts how many arrows starting or ending at a given label are tacked
+  (define (get-tacked-arrows-from-label gui-model-state label)
+    (let ([source-gui-data
+           (assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state)
+                          ((gui-model-state-get-source-from-label gui-model-state) label)
+                          cst:thunk-false)])
+      (if source-gui-data
+          (let* ([label-gui-data-by-label (source-gui-data-label-gui-data-by-label source-gui-data)]
+                 [label-gui-data (assoc-set-get label-gui-data-by-label label cst:thunk-false)])
+            (if label-gui-data
+                (+ (set-cardinality (set-filter (label-gui-data-starting-arrows label-gui-data) arrow-tacked?))
+                   (set-cardinality (set-filter (label-gui-data-ending-arrows label-gui-data) arrow-tacked?)))
+                0))
+          0)))
+  
+  
+  ; SNIPS
+  ; gui-model-state (symbol -> void) -> void
+  ; applies f to each type of snips (not the snips themselves, just the types).
+  (define (for-each-snip-type gui-model-state f)
+    (for-each f (gui-model-state-snip-type-list gui-model-state)))
+  
+  ; gui-model-state label symbol -> boolean
+  ; does the label have snips of a given type currently displayed by the gui?
+  (define (label-has-snips-of-this-type? gui-model-state label type)
+    (let ([source-gui-data
+           (assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state)
+                          ((gui-model-state-get-source-from-label gui-model-state) label)
+                          cst:thunk-false)])
+      (if source-gui-data
+          (let ([label-gui-data
+                 (assoc-set-get (source-gui-data-label-gui-data-by-label source-gui-data)
+                                label cst:thunk-false)])
+            (if label-gui-data
+                (assoc-set-in? (label-gui-data-snip-groups-by-type label-gui-data) type)
+                #f))
+          #f)))
+  
+  ; (assoc-setof symbol snip-group) symbol (listof symbol) -> non-negative-exact-integer
+  ; counts how many snips are currently displayed on the right of the position where
+  ; the snips of the given type currently are or would be displayed
+  (define (get-number-of-snips-on-right-from-type snip-groups-by-type type snip-type-list)
+    (let ([snip-types-on-right 
+           (let ([types (memq type snip-type-list)])
+             (if types
+                 types
+                 (error 'get-number-of-snips-on-right-from-type
+                        "unknown snip type: ~a" type)))])
+      (let loop ([snip-types-on-right (cdr snip-types-on-right)]
+                 [number-of-snips-on-right 0])
+        (if (null? snip-types-on-right)
+            number-of-snips-on-right
+            (loop (cdr snip-types-on-right)
+                  (+ number-of-snips-on-right
+                     (let ([snip-group (assoc-set-get snip-groups-by-type (car snip-types-on-right) cst:thunk-false)])
+                       (if snip-group
+                           (snip-group-size snip-group)
+                           0))))))))
+  
+  ; gui-model-state label symbol top non-negative-exact-integer -> non-negative-exact-integer
+  ; updates state (move existing snips and add new ones) and returns the position where
+  ; the snips should be inserted in the text
+  (define (add-snips gui-model-state label type source number-of-snips)
+    (let* ([source-gui-data
+            (assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state)
+                           source cst:thunk-false)]
+           [label-gui-data-by-label (source-gui-data-label-gui-data-by-label source-gui-data)]
+           [label-gui-data (assoc-set-get label-gui-data-by-label label cst:thunk-false)])
+      (set-source-gui-data-total-number-of-snips!
+       source-gui-data (+ (source-gui-data-total-number-of-snips source-gui-data) number-of-snips))
+      (if label-gui-data
+          ; the label might already have some snips attached to it.
+          (let* ([snip-groups-by-type (label-gui-data-snip-groups-by-type label-gui-data)]
+                 [label-starting-pos (label-gui-data-left-new-pos label-gui-data)]
+                 [insertion-starting-pos
+                  (- label-starting-pos
+                     (get-number-of-snips-on-right-from-type
+                      snip-groups-by-type type (gui-model-state-snip-type-list gui-model-state)))])
+            (move-poss gui-model-state source insertion-starting-pos number-of-snips + >=)
+            (if (assoc-set-in? snip-groups-by-type type)
+                ; type already present, but, for a given label and type, we can have only one
+                ; group of snips
+                (error 'add-snips gui-model-state
+                       "snips-and-arrows internal error; label ~a has already a snip group of type ~a"
+                       label type)
+                ; new snip type for this label
+                (begin
+                  (assoc-set-set snip-groups-by-type type (make-snip-group number-of-snips))
+                  (set-label-gui-data-total-number-of-snips!
+                   label-gui-data
+                   (+ (label-gui-data-total-number-of-snips label-gui-data) number-of-snips))))
+            insertion-starting-pos)
+          ; create new label-gui-data for that label
+          (let ([label-starting-pos (get-new-pos-from-label gui-model-state label)])
+            (move-poss gui-model-state source label-starting-pos number-of-snips + >=)
+            (assoc-set-set label-gui-data-by-label
+                           label
+                           (make-label-gui-data (+ label-starting-pos number-of-snips)
+                                                0
+                                                number-of-snips
+                                                (assoc-set-set (assoc-set-make)
+                                                               type
+                                                               (make-snip-group number-of-snips))
+                                                (set-make)
+                                                (set-make)))
+            label-starting-pos))))
+  
+  ; gui-model-state label symbol top -> (value non-negative-exact-integer non-negative-exact-integer)
+  ; removes all snips for a given label and type, move remaining snips, and returns the interval
+  ; to delete in the editor
+  (define (remove-inserted-snips gui-model-state label type source)
+    (let* ([source-gui-data
+            (assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state)
+                           source cst:thunk-false)]
+           [label-gui-data
+            (assoc-set-get (source-gui-data-label-gui-data-by-label source-gui-data)
+                           label cst:thunk-false)])
+      (if label-gui-data
+          (let* ([snip-groups-by-type (label-gui-data-snip-groups-by-type label-gui-data)]
+                 [snip-group (assoc-set-get snip-groups-by-type type cst:thunk-false)])
+            (if snip-group
+                (let* ([size (snip-group-size snip-group)]
+                       [label-starting-pos (label-gui-data-left-new-pos label-gui-data)]
+                       [deletion-ending-pos
+                        (- label-starting-pos
+                           (get-number-of-snips-on-right-from-type
+                            snip-groups-by-type type (gui-model-state-snip-type-list gui-model-state)))])
+                  (assoc-set-remove snip-groups-by-type type)
+                  (move-poss gui-model-state source deletion-ending-pos size - >=)
+                  (set-label-gui-data-total-number-of-snips!
+                   label-gui-data
+                   (- (label-gui-data-total-number-of-snips label-gui-data)
+                      size))
+                  (set-source-gui-data-total-number-of-snips!
+                   source-gui-data
+                   (- (source-gui-data-total-number-of-snips source-gui-data)
+                      size))
+                  (values (- deletion-ending-pos size) deletion-ending-pos))
+                (error 'remove-inserted-snips
+                       "label ~a has no snip group of type ~a"
+                       label type)))
+          (error 'remove-inserted-snips
+                 "label ~a has no snip groups at all, let alone of type ~a"
+                 label type))))
+  
+  )
diff --git a/collects/mrflow/snips-and-arrows-view.ss b/collects/mrflow/snips-and-arrows-view.ss
new file mode 100644
index 0000000000..4abc4c6a18
--- /dev/null
+++ b/collects/mrflow/snips-and-arrows-view.ss
@@ -0,0 +1,588 @@
+
+(module snips-and-arrows-view (lib "mrflow.ss" "mrflow")
+  (require
+   (lib "class.ss")
+   (lib "mred.ss" "mred")
+   (prefix arrow: (lib "arrow.ss" "drscheme"))
+   (prefix lst: (lib "list.ss"))
+   (prefix strcst: (lib "string-constant.ss" "string-constants"))
+   
+   (prefix cst: "constants.ss")
+   (prefix saam: "snips-and-arrows-model.ss")
+   ;"set-list.ss"
+   "set-hash.ss"
+   ;"assoc-set-list.ss"
+   "assoc-set-hash.ss"
+   "labels.ss"
+   )
+  
+  (define-struct gui-view-state (; gui-model-state
+                                 gui-model-state
+                                 ; test%
+                                 top-editor
+                                 ; (label -> text%)
+                                 get-editor-from-label
+                                 ; boolean
+                                 ; so we can differenciate between actions done by the analysis and actions
+                                 ; done by the user. Also prevents an infinite loop when deleting: if the user
+                                 ; deletes something, it triggers a call to after-delete, which deletes all the
+                                 ; snips, which triggers calls to after-delete, etc... so after-delete needs to
+                                 ; be wrapped to prevent an infinite loop.
+                                 analysis-currently-modifying?
+                                 ; (symbol label -> (listof string))
+                                 get-snip-text-from-snip-type-and-label
+                                 ; (label -> style-delta%)
+                                 get-style-delta-from-label
+                                 ; (listof (cons symbol style-delta%))
+                                 snip-types-and-colors
+                                 ; boolean
+                                 clear-colors-immediately?
+                                 ))
+  
+  (provide/contract
+   (make-gui-view-state (text%?
+                         (label? . -> . text%?)
+                         (label? . -> . non-negative-exact-integer?)
+                         (label? . -> . non-negative-exact-integer?)
+                         (symbol? label? . -> . (listof string?))
+                         (label? . -> . style-delta%?)
+                         (listof (cons/c symbol? string?))
+                         boolean?
+                         . -> . gui-view-state?))
+   
+   (rename gui-view-state-analysis-currently-modifying?
+           analysis-currently-modifying?
+           (gui-view-state? . -> . boolean?))
+   (color-registered-labels (gui-view-state? (box/c (listof text%?)) . -> . void?))
+   (after-user-action (gui-view-state? . -> . void?))
+   
+   (register-label-with-gui (gui-view-state? label? (text%? . -> . void?) . -> . void?))
+   (register-editor-with-gui (gui-view-state? text%? (text%? . -> . void?) . -> . void?))
+   (is-editor-registered? (gui-view-state? text%? . -> . boolean?))
+   (get-related-labels-from-drscheme-pos-and-editor (gui-view-state? non-negative-exact-integer? text%? . -> . (listof label?)))
+   (user-change-terms (gui-view-state? (listof (cons/c label? string?)) . -> . void?))
+   
+   (add-arrow (gui-view-state? (list/c label? label? string?) boolean? . -> . void?))
+   (get-tacked-arrows-from-label (gui-view-state? label? . -> . non-negative-exact-integer?))
+   (remove-arrows (gui-view-state? label? (union symbol? boolean?) boolean? . -> . void?))
+   (redraw-arrows (gui-view-state? (is-a?/c dc<%>) real? real? . -> . void?))
+   
+   (invalidate-bitmap-cache (gui-view-state? . -> . void?))
+   
+   (label-has-snips-of-this-type? (gui-view-state? label? symbol? . -> . boolean?))
+   (snips-currently-displayed-in-editor? (gui-view-state? text%? . -> . boolean?))
+   (for-each-snip-type (gui-view-state? (symbol? . -> . void?) . -> . void?))
+   (run-thunk-without-snips (gui-view-state? (-> any) . -> . any))
+   (add-snips (gui-view-state? label? symbol? text%? . -> . void?))
+   (remove-inserted-snips (gui-view-state? label? symbol? text%? . -> . void?))
+   (remove-all-snips-in-editor (gui-view-state? text%? . -> . void?))
+   (remove-all-snips-in-all-editors (gui-view-state? . -> . void?))
+   (remove-all-colors ((box/c (listof text%?)) . -> . void?))
+   (remove-all-snips-and-arrows-and-colors (gui-view-state? . -> . void?))
+   )
+  
+  ; text%
+  ; (label -> text%)
+  ; (label -> non-negative-exact-integer)
+  ; (label -> non-negative-exact-integer)
+  ; (symbol label -> (listof string))
+  ; (label -> style-delta%)
+  ; (listof (cons symbol style-delta%))
+  ; boolean
+  ; -> gui-view-state
+  (set! make-gui-view-state
+        (let ([real-make-gui-view-state make-gui-view-state])
+          (lambda (top-editor
+                   get-editor-from-label
+                   get-mzscheme-position-from-label
+                   get-span-from-label
+                   get-snip-text-from-snip-type-and-label
+                   get-style-delta-from-label
+                   snip-types-and-colors
+                   clear-colors-immediately?)
+            (real-make-gui-view-state (saam:make-gui-model-state get-editor-from-label
+                                                                 get-mzscheme-position-from-label
+                                                                 get-span-from-label
+                                                                 (map car snip-types-and-colors))
+                                      top-editor
+                                      get-editor-from-label
+                                      #f
+                                      get-snip-text-from-snip-type-and-label
+                                      get-style-delta-from-label
+                                      (map (lambda (snip-type-and-color)
+                                             (cons (car snip-type-and-color)
+                                                   (send (make-object style-delta%) set-delta-foreground (cdr snip-type-and-color))))
+                                           snip-types-and-colors)
+                                      clear-colors-immediately?))))
+  
+  ; INTERFACE BETWEEN MODEL AND TOP MODULE
+  ; gui-view-state non-negative-exact-integer text% -> (listof label)
+  (define (get-related-labels-from-drscheme-pos-and-editor gui-view-state pos editor)
+    (saam:get-related-labels-from-drscheme-pos-and-source
+     (gui-view-state-gui-model-state gui-view-state) pos editor))
+  
+  ; gui-view-state label (text% -> void) -> void
+  ; registers a label with the gui. We also need to initialize the editor's state the first time
+  ; we see that editor, to make sure all editors are sharing the same state.
+  ; Note that we could color the label as we go, thereby having incremental coloring as we
+  ; analyze terms, but that turns out to be *very* slow, because the editor has to be unlocked
+  ; (because of disable-evalution), the style changed, the editor re-lock and the bitmap cache
+  ; invalidated for each label in turn.  It would also possibly not show all the arrows for a
+  ; given label while the analysis is still going on.
+  (define (register-label-with-gui gui-view-state label init-editor)
+    (let ([editor (saam:register-label-with-gui (gui-view-state-gui-model-state gui-view-state) label)])
+      (when editor (init-editor editor)))
+    cst:void)
+  
+  ; gui-view-state text% (text% -> void) -> void
+  ; Same as above, except that we register an editor instead of a label.  We use this to always
+  ; register the top editor (see comment in make-register-label-with-gui in
+  ; snips-and-arrows.ss).
+  (define (register-editor-with-gui gui-view-state editor init-editor)
+    (let ([editor (saam:register-source-with-gui (gui-view-state-gui-model-state gui-view-state) editor)])
+      (when editor (init-editor editor)))
+    cst:void)
+  
+  ; gui-view-state text% -> boolean
+  (define (is-editor-registered? gui-view-state editor)
+    (saam:is-source-registered? (gui-view-state-gui-model-state gui-view-state) editor))
+  
+  ; gui-view-state (symbol -> void) -> void
+  (define (for-each-snip-type gui-view-state f)
+    (saam:for-each-snip-type (gui-view-state-gui-model-state gui-view-state) f))
+  
+  ; gui-view-state label symbol -> boolean
+  (define (label-has-snips-of-this-type? gui-view-state label type)
+    (saam:label-has-snips-of-this-type? (gui-view-state-gui-model-state gui-view-state) label type))
+  
+  ; gui-view-state text% -> boolean
+  (define (snips-currently-displayed-in-editor? gui-view-state editor)
+    (saam:snips-currently-displayed-in-source? (gui-view-state-gui-model-state gui-view-state) editor))
+  
+  ; gui-view-state label -> non-negative-exact-integer
+  (define (get-tacked-arrows-from-label gui-view-state label)
+    (saam:get-tacked-arrows-from-label (gui-view-state-gui-model-state gui-view-state) label))
+  
+  ; gui-view-state (list label label string) boolean -> void
+  (define (add-arrow gui-view-state arrow-info tacked?)
+    (saam:add-arrow (gui-view-state-gui-model-state gui-view-state) arrow-info tacked?))
+  
+  ; gui-view-state label (union symbol boolean) boolean -> void
+  (define (remove-arrows gui-view-state start-label tacked? exn?)
+    (saam:remove-arrows (gui-view-state-gui-model-state gui-view-state) start-label tacked? exn?))
+  
+  
+  ; COLORING / CLEARING
+  ; gui-view-state (box (listof text%)) -> void
+  ; Color all registered labels.  Note that we know that no user modifications will be
+  ; possible while we color (snips-and-arrows.ss takes care of that through can-insert?
+  ; can-delete?) so there's no need to lock the editors.
+  ; We remember all the editors in known-editors, because we might need that later, once
+  ; the state has been resetted, to correctly clear the colors in all editors.
+  (define (color-registered-labels gui-view-state known-editors)
+    (let* ([gui-model-state (gui-view-state-gui-model-state gui-view-state)]
+           [get-span-from-label (saam:make-get-span-from-label-from-model-state gui-model-state)]
+           [get-style-delta-from-label (gui-view-state-get-style-delta-from-label gui-view-state)])
+      (saam:for-each-source
+       gui-model-state
+       (lambda (editor)
+         (when editor
+           (set-box! known-editors (cons editor (unbox known-editors)))
+           (let ([locked? (send editor is-locked?)])
+             (send editor begin-edit-sequence #f)
+             (send editor lock #f)
+             (saam:for-each-label-in-source
+              gui-model-state
+              editor
+              (lambda (label)
+                (let ([label-left-pos (saam:get-position-from-label gui-model-state label)])
+                  (send editor change-style (get-style-delta-from-label label)
+                        label-left-pos (+ label-left-pos (get-span-from-label label)) #f))))
+             (send editor lock locked?)
+             (send editor end-edit-sequence)))))
+      (invalidate-bitmap-cache gui-view-state)))
+  
+  ; text% -> void
+  ; resets all colors to original style
+  (define (reset-editor-style editor)
+    (when editor
+      (let ([locked? (send editor is-locked?)])
+        (send editor begin-edit-sequence #f)
+        (send editor lock #f)
+        ; comment this out if you want to keep all the pretty colors
+        (let* ([style-list (send editor get-style-list)]
+               [standard-style (send style-list find-named-style "Standard")])
+          (when standard-style
+            (send editor change-style
+                  standard-style
+                  0 (send editor last-position) #f)))
+        (send editor lock locked?)
+        (send editor end-edit-sequence))))
+  
+  ; (box (listof text%)) -> void
+  (define (remove-all-colors known-editors)
+    (for-each reset-editor-style (unbox known-editors))
+    (set-box! known-editors '()))
+  
+  ; gui-view-state -> void
+  (define (remove-all-colors-using-state gui-view-state)
+    (saam:for-each-source (gui-view-state-gui-model-state gui-view-state) reset-editor-style))
+  
+  ; gui-view-state -> void
+  ; remove arrows and all snips, editor by editor.
+  (define (remove-all-snips-and-arrows gui-view-state)
+    (set-gui-view-state-analysis-currently-modifying?! gui-view-state #t)
+    (saam:remove-all-arrows (gui-view-state-gui-model-state gui-view-state))
+    (invalidate-bitmap-cache gui-view-state)
+    (remove-all-snips-in-all-editors gui-view-state)
+    (set-gui-view-state-analysis-currently-modifying?! gui-view-state #f))
+  
+  ; gui-view-state text% -> void
+  ; Remove all snips in a given editor.  We loop over each label and then loop over each
+  ; snip type and remove the corresponding snip group.  It would probably be much faster
+  ; to first get the positions of the groups of all snips for each label (since for a given
+  ; label all the groups of snips of different types are next to each other), sort them
+  ; by decreasing position (so that removing a group of snip doesn't require recomputing
+  ; the positions of the remaining groups), then remove them in that order.  I might do
+  ; that one day if people complain of slowness...
+  (define (remove-all-snips-in-editor gui-view-state editor)
+    (let ([gui-model-state (gui-view-state-gui-model-state gui-view-state)])
+      (saam:for-each-label-in-source
+       gui-model-state
+       editor
+       (lambda (label)
+         (saam:for-each-snip-type
+          gui-model-state
+          (lambda (type)
+            (when (saam:label-has-snips-of-this-type? gui-model-state label type)
+              (remove-inserted-snips gui-view-state label type editor))))))))
+  
+  ; gui-view-state -> void
+  ; remove all snips
+  (define (remove-all-snips-in-all-editors gui-view-state)
+    (saam:for-each-source (gui-view-state-gui-model-state gui-view-state)
+                          (lambda (editor)
+                            (remove-all-snips-in-editor gui-view-state editor))))
+  
+  ; gui-view-state -> void
+  ; clear all and reset all
+  (define (remove-all-snips-and-arrows-and-colors gui-view-state)
+    (remove-all-snips-and-arrows gui-view-state)
+    (remove-all-colors-using-state gui-view-state)
+    (reset-all-editors-state gui-view-state))
+  
+  ; gui-view-state -> void
+  ; invalidates the bitmap cache of the top editor, which will call the overridden
+  ; on-paint method of the top editor and redraw the arrows.
+  (define (invalidate-bitmap-cache gui-view-state)
+    (send (gui-view-state-top-editor gui-view-state) invalidate-bitmap-cache))
+  
+  ; gui-view-state -> void
+  ; Resets the state of all editors we know about.  Last nail in the coffin for
+  ; this analysis round.
+  (define (reset-all-editors-state gui-view-state)
+    (saam:for-each-source (gui-view-state-gui-model-state gui-view-state)
+                          (lambda (editor)
+                            (send editor reset-snips-and-arrows-state))))  
+  
+  
+  ; EDITOR EVENTS INTERACTION
+  ; gui-view-state -> void
+  ; the user has started modifying stuff, so we just remove all snips (in other editors only,
+  ; since we know a user modification is only allowed if the current editor doesn't have
+  ; any snips - the current editor is currently locked anyway) and all arrows (in all editors),
+  (define (after-user-action gui-view-state)
+    (remove-all-snips-and-arrows gui-view-state)
+    (when (gui-view-state-clear-colors-immediately? gui-view-state)
+      (remove-all-colors-using-state gui-view-state))
+    (reset-all-editors-state gui-view-state))
+  
+  ; gui-view-state dc% real real -> void
+  ; redraws arrows during on-paint
+  (define (redraw-arrows gui-view-state dc dx dy)
+    (let ([top-editor (gui-view-state-top-editor gui-view-state)]
+          [untacked-arrow-brush (send the-brush-list find-or-create-brush "white" 'solid)]
+          [old-pen (send dc get-pen)]
+          [old-brush (send dc get-brush)])
+      (saam:for-each-arrow (gui-view-state-gui-model-state gui-view-state)
+                           (lambda (start-label-pos-left end-label-pos-left
+                                                         start-label-span end-label-span
+                                                         start-editor end-editor
+                                                         tacked? color)
+                             (send dc set-pen (send the-pen-list find-or-create-pen color 1 'solid))
+                             (if tacked?
+                                 (send dc set-brush (send the-brush-list find-or-create-brush color 'solid))
+                                 (send dc set-brush untacked-arrow-brush))
+                             (draw-arrow start-label-pos-left
+                                         (+ start-label-pos-left start-label-span)
+                                         end-label-pos-left
+                                         (+ end-label-pos-left end-label-span)
+                                         top-editor
+                                         start-editor
+                                         end-editor
+                                         dc dx dy)))
+      (send dc set-pen old-pen)
+      (send dc set-brush old-brush)))
+  
+  ; TEXT
+  ; gui-view-state (listof (cons label string)) -> void
+  ; Resize and re-color the terms corresponding to all the labels.
+  ; We know there's at least one label in the list for each term to be changed,
+  ; but there might be several labels in the list for the same term.  We need
+  ; to update *all* known labels for all term to be changed, and modify the
+  ; corresponding term only once.  So we do it in two steps:
+  ; - we sort the new terms by editor and position, throwing away all the labels
+  ;   (we only needed them to get the positions)
+  ; - from the positions and the editors, get all the labels (sounds redundant?
+  ;   the idea is that we then know that we have *all* the labels for all the
+  ;   terms to be changed, and we know that we have each label only once) and
+  ;   actually do the changes, modifying all the labels for a given term and
+  ;   modifying the content of the corresponding editor only once for a given
+  ;   term, for all terms, by decreasing position in each editor.
+  ; At least we know that all labels for a given term have the same editor (unless
+  ; the user of this library really screwed up get-editor-from-label but then it's
+  ; not our problem if the user can't read the docs...)
+  (define (user-change-terms gui-view-state labels-and-new-terms)
+    (if (null? labels-and-new-terms)
+        (error 'user-change-terms "internal error: can't resize no labels~n")
+        (let ([get-editor-from-label (gui-view-state-get-editor-from-label gui-view-state)]
+              [get-style-delta-from-label (gui-view-state-get-style-delta-from-label gui-view-state)]
+              [new-terms-by-positions-by-editor (assoc-set-make)]
+              [gui-model-state (gui-view-state-gui-model-state gui-view-state)])
+          (set-gui-view-state-analysis-currently-modifying?! gui-view-state #t)
+          ; first we sort the terms to be modified by editor and by position
+          ; at the end we throw away the labels, because we don't know whether we have
+          ; all of them, so since we'll have to get all of them ourselves, we might just
+          ; as well throw away all the onces the user gave us, at least we won't have to
+          ; do any sorting to make sure we don't have duplicates.
+          (for-each
+           (lambda (label-and-new-term)
+             (let* ([label (car label-and-new-term)]
+                    [new-term (cdr label-and-new-term)]
+                    [editor (get-editor-from-label label)]
+                    [new-terms-by-position
+                     (assoc-set-get new-terms-by-positions-by-editor
+                                    editor
+                                    (lambda ()
+                                      (let ([new-terms-by-position (assoc-set-make)])
+                                        (assoc-set-set new-terms-by-positions-by-editor
+                                                       editor
+                                                       new-terms-by-position)
+                                        new-terms-by-position)))]
+                    [position (saam:get-position-from-label gui-model-state label)]
+                    [current-new-term
+                     (assoc-set-get new-terms-by-position
+                                    position
+                                    (lambda ()
+                                      (assoc-set-set new-terms-by-position
+                                                     position
+                                                     new-term)
+                                      new-term))])
+               (unless (string=? new-term current-new-term)
+                 (error 'user-change-terms "two different terms specified for same position: ~a and ~a"
+                        new-term current-new-term))))
+           labels-and-new-terms)
+          ; then for each editor and each position we have found, we update all the labels
+          ; by changing their span in the model, and modify the editor at the right place (note
+          ; that we need to sort the positions of the labels in decreasing order for a given
+          ; editor, otherwise modifying one term would change the actual positions of the
+          ; remaining terms to change...)
+          ;
+          ; These changes can be undone only when the editor doesn't contain any snips,
+          ; otherwise the undo will undo at the wrong place.  Even if we were to force
+          ; the change without undo, it would still not work because any previous action
+          ; could later be undone at the wrong place.  The only way out it to put the
+          ; whole thing inside run-thunk-without-snips (which will make it undoable
+          ; from DrScheme's point of view) and provide our own undoer to undo the change.
+          ; XXX to be done later... same thing with user modifications (insert / delete):
+          ; use run-thunk-without-snips and provide our own undoer with add-undo.
+          ; In the meantime we just forbid the change.  Note that we must test all the editors
+          ; for snips before doing any change, because otherwise we might change terms in one
+          ; editor and not in another and break the semantics of the change.
+          (let ([abort? #f])
+            (assoc-set-for-each
+             new-terms-by-positions-by-editor
+             (lambda (editor new-terms-by-positions)
+               (when (snips-currently-displayed-in-editor? gui-view-state editor)
+                 (set! abort? #t))))
+            (if abort?
+                (message-box (strcst:string-constant snips-and-arrows-user-action-disallowed-title)
+                             (strcst:string-constant snips-and-arrows-user-action-disallowed)
+                             #f '(ok caution))
+                ; the "save" button will show up...
+                (assoc-set-for-each
+                 new-terms-by-positions-by-editor
+                 (lambda (editor new-terms-by-positions)
+                   (when editor
+                     (let ([locked? (send editor is-locked?)])
+                       (send editor begin-edit-sequence #t)
+                       (send editor lock #f)
+                       (for-each
+                        (lambda (position-and-new-term-pair)
+                          (let* ([position (car position-and-new-term-pair)]
+                                 [new-term (cdr position-and-new-term-pair)]
+                                 [labels (get-related-labels-from-drscheme-pos-and-editor gui-view-state position editor)])
+                            (let-values ([(old-ending-pos new-ending-pos)
+                                          (saam:user-change-terms gui-model-state
+                                                                  labels editor
+                                                                  (string-length new-term))])
+                              (send editor insert new-term position old-ending-pos)
+                              ; the styles for the different labels are hopefully the same...
+                              (send editor change-style
+                                    (get-style-delta-from-label (car labels))
+                                    position new-ending-pos #f))))
+                        (lst:quicksort (assoc-set-map new-terms-by-positions cons)
+                                       (lambda (pos&term-pair1 pos&term-pair2)
+                                         (> (car pos&term-pair1) (car pos&term-pair2)))))
+                       (send editor lock locked?)
+                       (send editor end-edit-sequence)))))))
+          (set-gui-view-state-analysis-currently-modifying?! gui-view-state #f))))
+  
+  
+  ; SNIPS
+  ; gui-view-state label symbol text% -> void
+  ; Adds snips of given type to given label.
+  ; We could get the editor from the label, but there's no reason to bother...
+  (define (add-snips gui-view-state label type editor)
+    (when editor
+      (let ([snips-content
+             ((gui-view-state-get-snip-text-from-snip-type-and-label gui-view-state) type label)])
+        (unless (null? snips-content)
+          (set-gui-view-state-analysis-currently-modifying?! gui-view-state #t)
+          (let ([snip-style
+                 (cdr (assq type (gui-view-state-snip-types-and-colors gui-view-state)))]
+                [starting-pos (saam:add-snips (gui-view-state-gui-model-state gui-view-state)
+                                              label type editor (length snips-content))]
+                [locked? (send editor is-locked?)]
+                [modified? (send editor is-modified?)])
+            (send editor begin-edit-sequence #f)
+            (send editor lock #f)
+            (for-each (lambda (snip-content)
+                        (let* ([snip-text (make-object text%)]
+                               [snip (make-object editor-snip% snip-text)])
+                          (send snip-text insert snip-content)
+                          (send snip-text lock #t)
+                          (send editor insert snip starting-pos starting-pos)
+                          ; XXX bug here on Solaris, can be worked around
+                          ; (invalidate-bitmap-cache gui-view-state)
+                          ; see collects/test/tool2.ss
+                          (send editor change-style snip-style
+                                starting-pos (add1 starting-pos) #f)))
+                      snips-content)
+            (send editor set-modified modified?)
+            (send editor lock locked?)
+            (send editor end-edit-sequence))
+          (invalidate-bitmap-cache gui-view-state)
+          (set-gui-view-state-analysis-currently-modifying?! gui-view-state #f)))))
+  
+  ; gui-view-state label symbol text% -> void
+  ; Remove snips for a given label and type.
+  ; We could get the editor from the label, but there's no reason to bother...
+  (define (remove-inserted-snips gui-view-state label type editor)
+    (when editor
+      (set-gui-view-state-analysis-currently-modifying?! gui-view-state #t)
+      (let-values ([(starting-pos ending-pos)
+                    (saam:remove-inserted-snips (gui-view-state-gui-model-state gui-view-state)
+                                                label type editor)]
+                   [(locked?) (send editor is-locked?)]
+                   [(modified?) (send editor is-modified?)])
+        ; all the snips for a given label and type are contiguous and deleted at once.
+        (send editor begin-edit-sequence #f)
+        (send editor lock #f)
+        (send editor delete starting-pos ending-pos #f)
+        (send editor set-modified modified?)
+        (send editor lock locked?)
+        (send editor end-edit-sequence))
+      (invalidate-bitmap-cache gui-view-state)
+      (set-gui-view-state-analysis-currently-modifying?! gui-view-state #f)))
+  
+  ; gui-view-state (-> top) -> top
+  ; removes all the snips (and remembers them), runs the thunk, then puts all the snips back in...
+  ; remove-inserted-snips and add-snips take care of is-locked? and is-modified?, but even
+  ; though they also take care of begin/end-edit-sequence, we still need to wrap everything
+  ; in a sequence here otherwise the user would see the snips suddenly disappear and reappear...
+  (define (run-thunk-without-snips gui-view-state thunk)
+    (let ([gui-model-state (gui-view-state-gui-model-state gui-view-state)]
+          [snip-types-by-label-by-editor (assoc-set-make)])
+      (saam:for-each-source
+       gui-model-state
+       (lambda (editor)
+         (send editor begin-edit-sequence #f)
+         (let ([snip-types-by-label (assoc-set-make)])
+           (assoc-set-set snip-types-by-label-by-editor editor snip-types-by-label)
+           (saam:for-each-label-in-source
+            gui-model-state
+            editor
+            (lambda (label)
+              (saam:for-each-snip-type
+               gui-model-state
+               (lambda (type)
+                 (when (saam:label-has-snips-of-this-type? gui-model-state label type)
+                   (set-set (assoc-set-get snip-types-by-label label
+                                           (lambda ()
+                                             (let ([set (set-make)])
+                                               (assoc-set-set snip-types-by-label label set)
+                                               set)))
+                            type)
+                   (remove-inserted-snips gui-view-state label type editor)))))))))
+      (let ([result (thunk)])
+        (assoc-set-for-each
+         snip-types-by-label-by-editor
+         (lambda (editor snip-types-by-label)
+           (assoc-set-for-each
+            snip-types-by-label
+            (lambda (label types-set)
+              (set-for-each
+               types-set
+               (lambda (type)
+                 (add-snips gui-view-state label type editor)))))
+           (send editor end-edit-sequence)))
+        result)))
+  
+  
+  ; ARROWS
+  ; (box number) (box number) -> number
+  (define (average box1 box2)
+    (/ (+ (unbox box1) (unbox box2)) 2))
+  
+  ; non-negative-exact-integer non-negative-exact-integer non-negative-exact-integer non-negative-exact-integer
+  ; text% text% text% dc% real real -> void
+  ; Computes actual locations for arrow and draws it.
+  ; Note that we don't do anything to prevent arrows of length zero from being drawn - these
+  ; might show up when using macros that duplicate terms, so arrows of length zero are then
+  ; the correct thing to do as far as I am concerned).
+  (define (draw-arrow start-label-pos-left start-label-pos-right
+                      end-label-pos-left end-label-pos-right
+                      top-editor start-editor end-editor
+                      dc dx dy)
+    (let ([start-sub-ed-left-x-loc (box 0)]
+          [start-sub-ed-top-y-loc (box 0)]
+          [start-sub-ed-right-x-loc (box 0)]
+          [start-sub-ed-bot-y-loc (box 0)]
+          [end-sub-ed-left-x-loc (box 0)]
+          [end-sub-ed-top-y-loc (box 0)]
+          [end-sub-ed-right-x-loc (box 0)]
+          [end-sub-ed-bot-y-loc (box 0)])
+      (send start-editor position-location start-label-pos-left start-sub-ed-left-x-loc start-sub-ed-top-y-loc #t)
+      (send start-editor position-location start-label-pos-right start-sub-ed-right-x-loc #f #f)
+      (send start-editor position-location (sub1 start-label-pos-right) #f start-sub-ed-bot-y-loc #f)
+      (send end-editor position-location end-label-pos-left end-sub-ed-left-x-loc end-sub-ed-top-y-loc #t)
+      (send end-editor position-location end-label-pos-right end-sub-ed-right-x-loc #f #f)
+      (send end-editor position-location (sub1 end-label-pos-right) #f end-sub-ed-bot-y-loc #f)
+      (let*-values
+          ([(start-sub-ed-x-loc) (average start-sub-ed-left-x-loc start-sub-ed-right-x-loc)]
+           [(start-sub-ed-y-loc) (average start-sub-ed-top-y-loc start-sub-ed-bot-y-loc)]
+           [(end-sub-ed-x-loc) (average end-sub-ed-left-x-loc end-sub-ed-right-x-loc)]
+           [(end-sub-ed-y-loc) (average end-sub-ed-top-y-loc end-sub-ed-bot-y-loc)]
+           [(start-dc-x-loc start-dc-y-loc)
+            (send start-editor editor-location-to-dc-location start-sub-ed-x-loc start-sub-ed-y-loc)]
+           [(end-dc-x-loc end-dc-y-loc)
+            (send end-editor editor-location-to-dc-location end-sub-ed-x-loc end-sub-ed-y-loc)]
+           [(start-top-ed-x-loc start-top-ed-y-loc)
+            (send top-editor dc-location-to-editor-location start-dc-x-loc start-dc-y-loc)]
+           [(end-top-ed-x-loc end-top-ed-y-loc)
+            (send top-editor dc-location-to-editor-location end-dc-x-loc end-dc-y-loc)])
+        (arrow:draw-arrow
+         dc start-top-ed-x-loc start-top-ed-y-loc end-top-ed-x-loc end-top-ed-y-loc dx dy))))
+  
+  )
diff --git a/collects/mrflow/snips-and-arrows.ss b/collects/mrflow/snips-and-arrows.ss
new file mode 100644
index 0000000000..47e905e999
--- /dev/null
+++ b/collects/mrflow/snips-and-arrows.ss
@@ -0,0 +1,616 @@
+
+(module snips-and-arrows (lib "mrflow.ss" "mrflow")
+  
+  (require
+   (lib "etc.ss")
+   (lib "class.ss")
+   (lib "mred.ss" "mred")
+   (prefix strcst: (lib "string-constant.ss" "string-constants"))
+   
+   (prefix cst: "constants.ss")
+   (prefix saav: "snips-and-arrows-view.ss")
+   "labels.ss"
+   )
+  
+  (provide/contract
+   (extend-all-editors-mixin mixin-contract)
+   (extend-top-editor-mixin mixin-contract)
+   (init-snips-and-arrows-gui (text%?
+                               (label? . -> . text%?)
+                               (label? . -> . non-negative-exact-integer?)
+                               (label? . -> . non-negative-exact-integer?)
+                               ((listof label?) . -> . (listof (list/c label? label? string?)))
+                               (label? . -> . style-delta%?)
+                               ((is-a?/c popup-menu%) (listof label?) . -> . void?)
+                               (symbol? symbol? . -> . string?)
+                               (symbol? label? . -> . (listof string?))
+                               (listof (cons/c symbol? string?))
+                               boolean?
+                               . -> .
+                               (values ((listof (cons/c label? string?)) . -> . void?)
+                                       (label? . -> . void?))))
+   (init-snips-and-arrows-gui-for-syntax-objects (text%?
+                                                  ((listof syntax?) . -> . (listof (list/c syntax? syntax? string?)))
+                                                  (syntax? . -> . style-delta%?)
+                                                  ((is-a?/c popup-menu%) (listof syntax?) . -> . void?)
+                                                  (symbol? symbol? . -> . string?)
+                                                  (symbol? syntax? . -> . (listof string?))
+                                                  (listof (cons/c symbol? string?))
+                                                  boolean?
+                                                  . -> .
+                                                  (values ((listof (cons/c syntax? string?)) . -> . void?)
+                                                          (syntax? . -> . void?))))
+   )
+  
+  (define-struct gui-state (; gui-view-state
+                            gui-view-state
+                            ; ((listof label) -> (listof (list label label string)))
+                            get-arrows-from-labels
+                            ; (symbol symbol -> string)
+                            get-menu-text-from-snip-type
+                            ; (symbol label -> (listof string))
+                            get-snip-text-from-snip-type-and-label
+                            ; (popup-menu% (listof label) -> void)
+                            extend-menu-for-labels
+                            ; (union #f (listof label))
+                            previous-labels
+                            ; boolean
+                            ; we need this one to prevent arrows and menus to show up
+                            ; before the real analysis part is over, because as long as
+                            ; the analysis is not finished we might not have all arrows
+                            ; and not all errors (so wrong menus).
+                            term-analysis-done?
+                            ))
+  
+  ; MENUS
+  ; gui-state menu% (listof labels) symbol text% -> void
+  ; creates a menu entry for a given snip type
+  ; all labels correspond to the same term (because of macros)
+  (define (create-snips-menu-item-by-type gui-state menu labels type editor)
+    (let ([gui-view-state (gui-state-gui-view-state gui-state)]
+          [get-menu-text-from-snip-type (gui-state-get-menu-text-from-snip-type gui-state)]
+          [get-snip-text-from-snip-type-and-label
+           (gui-state-get-snip-text-from-snip-type-and-label gui-state)])
+      (if (ormap (lambda (label)
+                   (saav:label-has-snips-of-this-type? gui-view-state label type))
+                 labels)
+          ; at least one label has snips displayed => delete menu entry
+          (make-object menu-item%
+            (get-menu-text-from-snip-type type 'hide)
+            menu
+            (lambda (item event)
+              (for-each (lambda (label)
+                          (when (saav:label-has-snips-of-this-type? gui-view-state label type)
+                            (saav:remove-inserted-snips gui-view-state label type editor)))
+                        labels)))
+          ; no label has snips displayed => show menu entry if one of them has snips associated
+          ; with it
+          (unless (andmap (lambda (label)
+                            (null? (get-snip-text-from-snip-type-and-label type label)))
+                          labels)
+            (make-object menu-item%
+              (get-menu-text-from-snip-type type 'show)
+              menu
+              (lambda (item event)
+                (for-each (lambda (label)
+                            (saav:add-snips gui-view-state label type editor))
+                          labels))))))
+    cst:void)
+  
+  ; gui-state menu% (listof label) -> menu-item%
+  ; create menu entries for arrows
+  ; all labels correspond to the same term (because of macros)
+  (define (create-arrow-menu-items gui-state menu labels)
+    (let* ([gui-view-state (gui-state-gui-view-state gui-state)]
+           [arrows-info ((gui-state-get-arrows-from-labels gui-state) labels)]
+           [max-arrows (length arrows-info)]
+           [tacked-arrows (apply + (map (lambda (label)
+                                          (saav:get-tacked-arrows-from-label gui-view-state label))
+                                        labels))])
+      (when (< tacked-arrows max-arrows)
+        (make-object menu-item%
+          (strcst:string-constant snips-and-arrows-popup-menu-tack-all-arrows)
+          menu
+          (lambda (item event)
+            ; remove all (possibly untacked) arrows and add all arrows, tacked.
+            ; we could just add the untacked ones, but what we do here is simple
+            ; and efficient enough
+            (for-each (lambda (label)
+                        (saav:remove-arrows gui-view-state label 'all #t))
+                      labels)
+            (for-each
+             (lambda (arrow-info)
+               (saav:add-arrow gui-view-state arrow-info #t))
+             arrows-info)
+            (saav:invalidate-bitmap-cache gui-view-state))))
+      (when (> tacked-arrows 0)
+        (make-object menu-item%
+          (strcst:string-constant snips-and-arrows-popup-menu-untack-all-arrows)
+          menu
+          (lambda (item event)
+            (for-each (lambda (label)
+                        (saav:remove-arrows gui-view-state label 'all #t))
+                      labels)
+            (saav:invalidate-bitmap-cache gui-view-state))))))
+  
+  
+  ; gui-view-state -> boolean
+  ; User insertions cause problems: a user might insert something while our snips
+  ; are present.  That would force us to remove all the snips, since as soon as
+  ; the user changes the program the results of the analysis become invalid.  So
+  ; we would have to keep track of the user insertion (which is possible), update
+  ; the position of all our snips accordingly (which is possible too), then delete
+  ; all the snips because they would not be valid anymore (which is very possible).
+  ; In fact we used to do all that.  The reason we got rid of it is because it does
+  ; not interact well with the undo feature:  if, after the user insertion and the
+  ; automatic removal of snips, the user does an undo, the undo might delete random
+  ; stuff at the position where the user insertion initially occured, but that might
+  ; not be the position where that user-inserted stuff currently is, because removing
+  ; the snips between the insertion and the undo might have moved around the stuff
+  ; that was inserted...
+  ;
+  ; Note that it's not possible to delete our snips just right before the user action
+  ; is effected in the window (e.g. during a call to the on-insert method),
+  ; because the editor is locked at that time (and with reason: if we were to remove
+  ; the snips right after the user acts (which is the thing that decides we must
+  ; get rid of all our snips) but just before the action actually takes place in the
+  ; editor, then after removing the snips the user action would actually be effected
+  ; at the wrong position in the editor - i.e. we can't sweep the rug under DrScheme's
+  ; own insertion mechanism, and I don't think Matthew would be willing to add a mechanism
+  ; whereby one could notify DrScheme that the rug is being swept...)
+  ;
+  ; Same problem with trying to remove the snips inside can-insert? : the editor is
+  ; locked.
+  ;
+  ; Note also that things get even worse if the user tries to delete stuff instead of
+  ; inserting stuff: the user might try to delete one of our own snips!  We could
+  ; check the stuff the user wants to delete and only allow the delete if the stuff
+  ; didn't contain one of our snips, but this still wouldn't solve the undo problem
+  ; (which exists in reverse: deleting and undoing would re-insert the deleted stuff
+  ; at the wrong place - I tried it!).
+  ;
+  ; Conclusion: it's impossible to solve the problem of user insertion and deletion
+  ; while snips are present, because the undo then becomes buggy.  So we simply
+  ; completely disallow user insertions and deletions while snips are present (in
+  ; this editor - there's no problem with undo if the user action happens in another
+  ; editor that doesn't contain snips, and then we just use that as a signal to delete
+  ; all snips in all editors using the after-user-action fucntion).
+  ;
+  ; So this is what this function is doing: disallow user modifications to an editor
+  ; when the editor contains snips (or while the analysis is still running).
+  (define (is-action-allowed? gui-view-state editor)
+    (or (saav:analysis-currently-modifying? gui-view-state)
+        (if (saav:snips-currently-displayed-in-editor? gui-view-state editor)
+            (begin
+              (message-box (strcst:string-constant snips-and-arrows-user-action-disallowed-title)
+                           (strcst:string-constant snips-and-arrows-user-action-disallowed)
+                           #f '(ok caution))
+              #f)
+            #t)))
+  
+  
+  ; MIXINS
+  ; to be applied to all editors and sub-editors containing registered labels
+  (define extend-all-editors-mixin
+    (lambda (super%)
+      (class super%
+        
+        ; State initialization and resetting
+        ; The state is created by the call to init-snips-and-arrows-gui in the callback
+        ; of the tool's button.  The state is hidden inside the register-label-with-gui function
+        ; returned by the call.  That means a new instance of the state is created each time
+        ; the user uses the tool.  Then, each time the user uses register-label-with-gui,
+        ; the function checks whether the editor has been seen before or not, and if it hasn't
+        ; it calls the editor's initialize-snips-and-arrows-gui-state method to initialize the
+        ; editor's state.  That ensures that all editors where coloring has to happen share the
+        ; same state.  Note that the top editor has both extend-all-editors-mixin and
+        ; extend-top-editor-mixin applied to it, so the initialize-snips-and-arrows-gui-state
+        ; method is define/public in one case and define/override in the other case.
+        ; Note also that the initialization of the top editor is always done
+        ; as a special case inside init-snips-and-arrows-gui (see this function below)
+        ; because that editor still needs to have access to the state to redraw arrows even if
+        ; no label is registered for it.
+        ;
+        ; The state is reset in two cases:
+        ; - the user inserts or deletes something in an editor (see the comment for
+        ;   is-action-allowed? above for details about when this is allowed), and
+        ;   clear-colors-immediately? is true
+        ; - the gui makes a direct call to remove-all-snips-and-arrows-and-colors (probably inside
+        ;   the clear-annotations method for the unit frame)
+        ; The state is reseted by calling the reset-snips-and-arrows-state method of each editor
+        ; for which a label has been registred.  Since the unit frame has no direct reference to
+        ; the state but only through the register-label-with-gui function, and since the editors
+        ; don't have any reference to the state after their reset-snips-and-arrows-state method
+        ; is called, the state can be garbage collected as soon as the register-label-with-gui
+        ; function is not referenced by the unit frame anymore.
+        ; Note that it would be possible for the unit frame to re-use the state (and indeed that's
+        ; how it was working for a while) but it makes testing whether the analysis is currently
+        ; running a bit more difficult and doesn't make anything else any simpler.  Besides, it
+        ; might also be a source of subtle errors if everything is not correctly reseted from one
+        ; run of the analysis to the next one.
+        
+        ; (union gui-state symbol)
+        (define gui-state 'uninitialized-gui-state-in-extend-all-editors-mixin)
+        
+        ; (union gui-view-state 'symbol)
+        (define gui-view-state 'uninitialized-gui-view-state-in-extend-all-editors-mixin)
+        
+        ; gui-state -> void
+        ; see the same method below for explanation
+        (define/public (initialize-snips-and-arrows-gui-state new-gui-state)
+          (set! gui-state new-gui-state)
+          (set! gui-view-state (gui-state-gui-view-state new-gui-state)))
+        
+        ; -> void
+        (define/public (reset-snips-and-arrows-state)
+          (set! gui-state 'reinitialized-gui-state-in-extend-all-editors-mixin)
+          (set! gui-view-state 'reinitialized-gui-view-state-in-extend-all-editors-mixin))
+        
+        ; exact-non-negative-integer exact-non-negative-integer -> boolean
+        (define/augment (can-insert? start len)
+          (and (or (symbol? gui-state)
+                   (and (gui-state-term-analysis-done? gui-state)
+                        (is-action-allowed? gui-view-state this)))
+               (inner #t can-insert? start len)))
+        
+        ; exact-non-negative-integer exact-non-negative-integer -> boolean
+        (define/augment (can-delete? start len)
+          (and (or (symbol? gui-state)
+                   (and (gui-state-term-analysis-done? gui-state)
+                        (is-action-allowed? gui-view-state this)))
+               (inner #t can-delete? start len)))
+        
+        ; exact-non-negative-integer exact-non-negative-integer -> void
+        (define/augment (after-insert start len)
+          (unless (or (symbol? gui-state)
+                      (saav:analysis-currently-modifying? gui-view-state))
+            (saav:after-user-action gui-view-state))
+          (inner cst:void after-insert start len))
+        
+        ; exact-non-negative-integer exact-non-negative-integer -> void
+        (define/augment (after-delete start len)
+          (unless (or (symbol? gui-state)
+                      (saav:analysis-currently-modifying? gui-view-state))
+            (saav:after-user-action gui-view-state))
+          (inner cst:void after-delete start len))
+        
+        (super-instantiate ()))))
+  
+  ; to apply to the top editor
+  (define extend-top-editor-mixin
+    (lambda (super%)
+      (class super%
+        
+        ; (union gui-state symbol)
+        (define gui-state 'uninitialized-gui-state-in-extend-top-editor-mixin)
+        
+        ; (union gui-view-state symbol)
+        (define gui-view-state 'uninitialized-gui-view-state-in-extend-top-editor-mixin)
+        
+        ; (box (listof text%))
+        (define known-editors (box '()))
+        
+        ; gui-state -> void
+        ; init-snips-and-arrows-gui creates register-label-with-gui, which will call
+        ; saav:register-label-with-gui, which will in turn find the editor for the label
+        ; and call this method (if necessary) to initialize the editor's state, thereby
+        ; allowing all the editors for a single analysis to share the same state (see
+        ; the same method above too).
+        (define/override (initialize-snips-and-arrows-gui-state new-gui-state)
+          (super initialize-snips-and-arrows-gui-state new-gui-state)
+          (set! gui-state new-gui-state)
+          (set! gui-view-state (gui-state-gui-view-state new-gui-state)))
+        
+        ; -> void
+        (define/override (reset-snips-and-arrows-state)
+          (super reset-snips-and-arrows-state)
+          (set! gui-state 'reinitialized-gui-state-in-extend-top-editor-mixin)
+          (set! gui-view-state 'reinitialized-gui-view-state-in-extend-top-editor-mixin))
+        
+        ; string symbol -> boolean
+        ; We forbid saving if the analysis is in the middle of running or in the middle
+        ; of modifying the content of the editor
+        (define/augment (can-save-file? filename format)
+          (if (symbol? gui-state)
+              (inner #t can-save-file? filename format)
+              (if (and (gui-state-term-analysis-done? gui-state)
+                       (not (saav:analysis-currently-modifying? gui-view-state)))
+                  (inner #t can-save-file? filename format)
+                  #f)))
+        
+        (define/override (save-file . args)
+          (if (symbol? gui-state)
+              (super save-file . args)
+              (saav:run-thunk-without-snips gui-view-state
+               (lambda () (super save-file . args)))))
+                  
+        ; -> void
+        ; colors all registered labels
+        ; The analysis proper is only officially done after we've colored everything, otherwise
+        ; user insertions might occur before we have time to finish coloring and we will color
+        ; the wrong stuff...
+        (define/public (color-registered-labels)
+          (unless (symbol? gui-view-state)
+            (saav:color-registered-labels gui-view-state known-editors)
+            (set-gui-state-term-analysis-done?! gui-state #t)))
+        
+        ; -> void
+        ; remove all snips and arrows, and resets text style in all editors
+        (define/public (remove-all-snips-and-arrows-and-colors)
+          (if (symbol? gui-view-state)
+              (saav:remove-all-colors known-editors)
+              (saav:remove-all-snips-and-arrows-and-colors gui-view-state)))
+        
+        ; boolean dc% real real real real real real symbol -> void
+        (define/override (on-paint before? dc left top right bottom dx dy draw-caret)
+          (super on-paint before? dc left top right bottom dx dy draw-caret)
+          (when (and (not (symbol? gui-state))
+                     (not before?)
+                     (gui-state-term-analysis-done? gui-state))
+            (saav:redraw-arrows gui-view-state dc dx dy)))
+        
+        (inherit find-position dc-location-to-editor-location)
+        ; mouse-event% -> (values (union #f exact-non-negative-integer) (union #f text%))
+        ; finds the editor in which a mouse-event% has occured, going down recursively
+        ; if there are embedded editors, but not going down the embedded editors when they
+        ; have been introduced by the analysis itself (e.g. type snips).
+        (define (get-drscheme-pos-and-editor event)
+          (let ([dc-x (send event get-x)]
+                [dc-y (send event get-y)]
+                [on-it? (box #f)])
+            (let loop ([previous-pos #f]
+                       [previous-editor #f]
+                       [editor this])
+              (let-values ([(ed-x ed-y) (send editor dc-location-to-editor-location dc-x dc-y)])
+                (let ([pos (send editor find-position ed-x ed-y #f on-it?)])
+                  (if (not (unbox on-it?))
+                      (values #f #f)
+                      (let ([snip (send editor find-snip pos 'after-or-none)])
+                        (if (and snip (is-a? snip editor-snip%))
+                            (let ([sub-editor (send snip get-editor)])
+                              (if (saav:is-editor-registered? gui-view-state sub-editor)
+                                  (loop pos editor sub-editor)
+                                  (values pos editor)))
+                            (values pos editor)))))))))
+
+        (inherit get-admin)
+        ; mouse-event% -> void
+        (define/override (on-event event)
+          (cond
+            [(or (symbol? gui-state)
+                 (not (gui-state-term-analysis-done? gui-state)))
+             (super on-event event)]
+            [(and (send event button-down? 'right)
+                  (let-values ([(pos editor) (get-drscheme-pos-and-editor event)])
+                    (if pos
+                        (let ([labels (saav:get-related-labels-from-drscheme-pos-and-editor
+                                       gui-view-state pos editor)])
+                          (if (null? labels)
+                              #f
+                              (cons labels editor))) ; no "=>-values" so use cons...
+                        #f)))
+             =>
+             (lambda (labels&editor)
+               (let ([menu (make-object popup-menu%)]
+                     [labels (car labels&editor)]
+                     [editor (cdr labels&editor)])
+                 ; SNIPS
+                 (let ([create-snips-menu-item
+                        (lambda (snip-type)
+                          (create-snips-menu-item-by-type gui-state menu labels snip-type editor))])
+                   (saav:for-each-snip-type gui-view-state create-snips-menu-item))
+                 ; ARROWS
+                 (create-arrow-menu-items gui-state menu labels)
+                 ; HIDE ALL SNIPS
+                 (when (saav:snips-currently-displayed-in-editor? gui-view-state editor)
+                   (make-object menu-item%
+                     (strcst:string-constant snips-and-arrows-hide-all-snips-in-editor)
+                     menu
+                     (lambda (item event)
+                       (saav:remove-all-snips-in-editor gui-view-state editor))))
+                 ; OTHER
+                 ((gui-state-extend-menu-for-labels gui-state) menu labels)
+                 
+                 (when (not (null? (send menu get-items)))
+                   (let-values ([(x y) (dc-location-to-editor-location (send event get-x) (send event get-y))])
+                     (send (get-admin) popup-menu menu x y)))
+                 ))]
+            [(and (send event button-down? 'middle)
+                  (let-values ([(pos editor) (get-drscheme-pos-and-editor event)])
+                    (if pos
+                        (let ([labels (saav:get-related-labels-from-drscheme-pos-and-editor
+                                       gui-view-state pos editor)])
+                          (if (null? labels)
+                              #f
+                              (cons labels editor))) ; no "=>-values" so use cons...
+                        #f)))
+             =>
+             (lambda (labels&editor)
+               (let ([menu (make-object popup-menu%)]
+                     [labels (car labels&editor)]
+                     [editor (cdr labels&editor)]
+                     [get-snip-text-from-snip-type-and-label
+                      (gui-state-get-snip-text-from-snip-type-and-label gui-state)])
+                 (saav:for-each-snip-type
+                  gui-view-state
+                  (lambda (snip-type)
+                    (unless (andmap (lambda (label)
+                                      (null? (get-snip-text-from-snip-type-and-label snip-type label)))
+                                    labels)
+                      ; at least one label has snips of this type
+                      (for-each (lambda (label)
+                                  (let ([snip-strings (get-snip-text-from-snip-type-and-label snip-type label)])
+                                    (unless (null? snip-strings)
+                                      (for-each
+                                       (lambda (snip-string)
+                                         (make-object menu-item%
+                                           (if (<= (string-length snip-string) 200)
+                                               snip-string
+                                               (string-append
+                                                (substring snip-string 0 197)
+                                                "..."))
+                                           menu
+                                           (lambda (item event) cst:void)))
+                                       snip-strings))))
+                                labels)
+                      (make-object separator-menu-item% menu))))
+                 (when (not (null? (send menu get-items)))
+                   (let-values ([(x y) (dc-location-to-editor-location (send event get-x) (send event get-y))])
+                     (send (get-admin) popup-menu menu x y)))
+                 ))]
+            [(send event leaving?)
+             (let ([previous-labels (gui-state-previous-labels gui-state)])
+               (when previous-labels
+                 (for-each (lambda (previous-label)
+                             (saav:remove-arrows gui-view-state previous-label #f #f))
+                           previous-labels)
+                 (set-gui-state-previous-labels! gui-state #f)
+                 (saav:invalidate-bitmap-cache gui-view-state)))]
+            [(or (send event moving?)
+                 (send event entering?))
+             (if (or (send event get-left-down)
+                     (send event get-middle-down)
+                     (send event get-right-down))
+                 (super on-event event)
+                 (let*-values ([(pos editor) (get-drscheme-pos-and-editor event)]
+                               [(labels)
+                                (if pos
+                                    (saav:get-related-labels-from-drscheme-pos-and-editor
+                                     gui-view-state pos editor)
+                                    #f)]
+                               [(previous-labels) (gui-state-previous-labels gui-state)]
+                               [(not-same-labels) (not (equal? labels previous-labels))])
+                   (when (and previous-labels not-same-labels)
+                     (for-each (lambda (previous-label)
+                                 (saav:remove-arrows gui-view-state previous-label #f #f))
+                               previous-labels))
+                   (when (and labels not-same-labels)
+                     (for-each (lambda (arrow-info)
+                                 (saav:add-arrow gui-view-state arrow-info #f))
+                               ((gui-state-get-arrows-from-labels gui-state) labels)))
+                   (when not-same-labels
+                     (when (or (not (null? previous-labels))
+                               (not (null? labels)))
+                       ; something has changed, and we might have either removed some arrows or
+                       ; added some (or both), so we redraw
+                       (saav:invalidate-bitmap-cache gui-view-state))
+                     (set-gui-state-previous-labels! gui-state labels))))]
+            [else (super on-event event)]))
+        
+        (super-instantiate ()))))
+  
+  
+  ; ... see below ... -> (label -> void)
+  ; Ouch...  The returned function can be used to register labels with this gui
+  (define (init-snips-and-arrows-gui
+           ; % text%
+           top-editor
+           ; (label -> text%)
+           get-editor-from-label
+           ; (label -> non-negative-exact-integer)
+           get-mzscheme-position-from-label
+           ; (label -> non-negative-exact-integer)
+           get-span-from-label
+           ; ((listof label) -> (listof (list label label string)))
+           get-arrows-from-labels
+           ; (label -> style-delta%)
+           get-style-delta-from-label
+           ; (popup-menu% (listof label) -> void)
+           extend-menu-for-labels
+           ; (symbol symbol -> string)
+           get-menu-text-from-snip-type
+           ; (symbol label -> (listof string))
+           get-snip-text-from-snip-type-and-label
+           ; (listof (cons symbol string))
+           snip-types-and-colors
+           ; boolean
+           clear-colors-immediately?)
+    (let* ([gui-view-state (saav:make-gui-view-state
+                            top-editor
+                            get-editor-from-label
+                            get-mzscheme-position-from-label
+                            get-span-from-label
+                            get-snip-text-from-snip-type-and-label
+                            get-style-delta-from-label
+                            snip-types-and-colors
+                            clear-colors-immediately?)]
+           [gui-state (make-gui-state
+                       gui-view-state
+                       get-arrows-from-labels
+                       get-menu-text-from-snip-type
+                       get-snip-text-from-snip-type-and-label
+                       extend-menu-for-labels
+                       #f
+                       #f)])
+      ; just make sure everything is clear before assigning a new state
+      (send top-editor remove-all-snips-and-arrows-and-colors)
+      
+      ; we need this to force the registration of the top editor, to make sure
+      ; on-paint and on-event work correctly even when no label has been registered for
+      ; the top editor itself.
+      (saav:register-editor-with-gui
+       gui-view-state top-editor
+       (lambda (editor)
+         (send editor initialize-snips-and-arrows-gui-state gui-state)))
+      
+      (values
+       ; (listof (cons label string)) -> void
+       (lambda (labels-and-new-terms)
+         (saav:user-change-terms gui-view-state labels-and-new-terms))
+       
+       ; label -> void
+       ; to register a label with the gui
+       (lambda (label)
+         (saav:register-label-with-gui
+          gui-view-state label
+          (lambda (editor)
+            (send editor initialize-snips-and-arrows-gui-state gui-state))))
+       )))
+  
+  ; SIMPLIFIED INTERFACE
+  ; symbol -> void
+  ; default function for snip handling
+  (define error-no-snips
+    (case-lambda
+      [(_) (error-no-snips 'dummy 'dummy)]
+      [(_1 _2) (error 'snips-and-arrows "no snip info was provided when snips-and-arrows library was initialized")]))
+  
+  ; ... see below ... -> (values gui-state (label -> void))
+  ; simplified version of make-snips-and-arrows-state, specialized for syntax objects,
+  ; and with default handling of snips
+  (define init-snips-and-arrows-gui-for-syntax-objects
+    (opt-lambda (; text%
+                 top-editor
+                 ; ((listof syntax-object) -> (listof (list syntax-object syntax-object string)))
+                 get-arrows-from-syntax-objects
+                 ; (syntax-object -> style-delta%)
+                 get-style-delta-from-syntax-object
+                 
+                 ; OPTIONAL menu stuff
+                 ; (popup-menu% (listof syntax-object) -> void)
+                 (extand-menu-for-syntax-objects (lambda (menu stxs) cst:void))
+                 
+                 ; OPTIONAL snip stuff
+                 ; (symbol symbol -> string)
+                 (get-menu-text-from-snip-type error-no-snips)
+                 ; (symbol syntax-object -> (listof string))
+                 (get-snip-text-from-snip-type-and-syntax-object error-no-snips)
+                 ; (listof (cons symbol string))
+                 (snip-types-and-colors '())
+                 
+                 ; boolean
+                 (clear-colors-immediately? #f))
+      (init-snips-and-arrows-gui
+       top-editor
+       syntax-source
+       syntax-position
+       syntax-span
+       get-arrows-from-syntax-objects
+       get-style-delta-from-syntax-object
+       extand-menu-for-syntax-objects
+       get-menu-text-from-snip-type
+       get-snip-text-from-snip-type-and-syntax-object
+       snip-types-and-colors
+       clear-colors-immediately?)))
+  
+  )
diff --git a/collects/mrflow/trie.ss b/collects/mrflow/trie.ss
new file mode 100644
index 0000000000..9029077efa
--- /dev/null
+++ b/collects/mrflow/trie.ss
@@ -0,0 +1,124 @@
+
+(module trie (lib "mrflow.ss" "mrflow")
+  (require (prefix list: (lib "list.ss"))
+           (prefix cst: "constants.ss")
+           
+           "dfa.ss"
+           "types.ss"
+           "util.ss")
+  
+  ;; DFA Tries - Allows for testing of a DFA being previously hashconsed
+  ;;             in Theta(|DFA|) time. 
+  (provide (struct trie ())
+           add-dfa-states
+           dfa-present?)
+  
+  ; DFA states are analogous to letters and at a node we have map of handles
+  ; indexed by the DFA representative (the handle of the last DFA state in a DFA
+  ; canonically ordered by minimization).
+  ;
+  ; Two equivalent (minimal, strongly connected) DFAs will yield the same
+  ; canonically ordered DFAs regardless of the start state picked.
+  ;
+  ; An association list and hash-table are used to store the maps, but perhaps
+  ; there is a better choice of data structures.
+  (define-struct trie (dfa-representative->handle dfa-state->trie))
+  (set! make-trie
+	(let ([old-make-trie make-trie])
+	  (lambda ()
+	    (old-make-trie '() (make-hash-table 'equal)))))
+  
+  ; Get the trie on the edge labeled by the DFA state
+  (define/contract get-trie-child (trie? state? . -> . (union trie? false/c))
+    (lambda (trie letter)
+      (hash-table-get (trie-dfa-state->trie trie) letter cst:thunk-false)))
+  
+  ; Each DFA state added to the trie must map to a unique handle. 
+  (define/contract add-trie-state-handle!
+    (trie? handle? handle? . ->d .
+           (lambda (trie representative-handle state-handle)
+             (let ([dfa->handle (trie-dfa-representative->handle trie)])
+               (when (assq representative-handle dfa->handle)
+                 (error 'add-trie-state-handle!
+                        "Mapping ~a to ~a, but trie already has mapping from DFA representative ~a to handle ~a"
+                        representative-handle state-handle
+                        representative-handle (cdr (assq representative-handle dfa->handle))))
+               trie?)))
+    (lambda (trie representative-handle state-handle)
+      (let ([dfa->handle (trie-dfa-representative->handle trie)])
+        (set-trie-dfa-representative->handle! trie (cons (cons representative-handle state-handle) dfa->handle))
+        trie)))
+  
+  (define/contract get-state-handle (trie? handle? . -> . handle?)
+    (lambda (trie representative-handle)
+      (let ([dfa-representative->handle (trie-dfa-representative->handle trie)])
+        (cdr (assq representative-handle dfa-representative->handle)))))
+  
+  (define/contract get-handle-from-representative
+    (trie? . ->d .
+           (lambda (trie)
+             (let ([dfa->handle (trie-dfa-representative->handle trie)])
+               (unless (length-one? dfa->handle)
+                 (error 'get-handle-from-representative
+                        "~a (!= 1) representatives present: ~a" (length dfa->handle) dfa->handle))
+               (unless (= (caar dfa->handle) (cdar dfa->handle))
+                 (error 'get-handle-from-representative "Representative handle ~a not equal to representative handle ~a"
+                        (caar dfa->handle) (cdar dfa->handle)))
+               handle?)))
+    (lambda (trie)
+      (caar (trie-dfa-representative->handle trie))))
+  
+  ; Return a handle of the DFAs start state if the DFA has already
+  ; been hasconsed.  For each of the ordered DFA states we descend one
+  ; level in the trie until we reach the last state (the
+  ; representative).  As we are descending we note which of the tries
+  ; contains the start state.  Getting the representative handle, we
+  ; can lookup the handle of the start state in this noted trie.
+  (define/contract dfa-present?
+    (trie? (nonempty-list-of? state?) . -> . (union false/c (listof handle?)))
+    (lambda (trie nstates) 
+      (let/ec return-with
+        (let* ([rev-tries (list:foldl (lambda (state tries)
+                                        (let ([trie (get-trie-child (car tries) state)])
+                                          (if trie
+                                              (cons trie tries)
+                                              (return-with #f))))
+                                      (list trie)
+                                      nstates)]
+               [rep-handle (get-handle-from-representative (car rev-tries))])
+          ;; get the handles for each state, in reverse order from the (reversed) list of tries
+          (list:foldr (lambda (trie states) (cons (get-state-handle trie rep-handle) states))
+                      '() (cdr (reverse rev-tries)))))))
+  
+  ; Add a list of DFA states and their corresponding handles to the trie
+  (define/contract add-dfa-states
+    (trie? (nonempty-list-of? state?) (listof handle?) . ->d .
+           (lambda (trie states handles)
+             (unless (= (length states) (length handles))
+               (error 'add "length of list of types ~a != length of DFA handle list ~a"
+                      (length states) (length handles)))
+             (lambda (_)
+               (let loop ([trie trie] [states states])
+                 (if (null? states)
+                     (begin
+                       (unless (hash-table-empty? (trie-dfa-state->trie trie))
+                         (error 'add-dfa-states "Representative node has a child node"))
+                       (unless (length-one? (trie-dfa-representative->handle trie))
+                         (error 'add-dfa-states "Representative node has more than one representative handle")))
+                     (loop (get-trie-child trie (car states)) (cdr states)))))))
+    (lambda (trie states handles)
+      (let ([add-child (lambda (trie letter representative-handle dfa-handle)
+                         (add-trie-state-handle!
+                          (if (get-trie-child trie letter) (get-trie-child trie letter)
+                              (let ([child-trie (make-trie)])
+                                (hash-table-put! (trie-dfa-state->trie trie) letter child-trie)
+                                child-trie))
+                          representative-handle dfa-handle))]
+            [representative-handle (list-ref handles (sub1 (length handles)))])
+        (let loop ([trie trie] [states states] [handles handles])
+          (unless (null? states)
+            (loop (add-child trie (car states) representative-handle (car handles))
+                  (cdr states)
+                  (cdr handles)))))))
+  
+  ) ;; end module trie
\ No newline at end of file
diff --git a/collects/mrflow/types.ss b/collects/mrflow/types.ss
new file mode 100644
index 0000000000..5f4e191d91
--- /dev/null
+++ b/collects/mrflow/types.ss
@@ -0,0 +1,122 @@
+(module types mzscheme
+  (provide (all-defined))
+  
+  (define-struct type () (make-inspector))
+  
+  ; (make-type-empty) is the same as (make-type-cst 'bottom) for now. The reason we
+  ; *never* use (make-type-cst 'bottom) is because it would trigger the propagation of
+  ; bottom everywhere, thus slowing down the analysis. There's two solutions to that:
+  ; - not use initialize-label-set-for-value-source when using (make-type-cst 'bottom)
+  ; - use a separate (make-type-empty), which is more correct anyway (note that there's
+  ;   currently no way to define the type for a primitive that returns the symbol 'bottom
+  ;   (or 'number, or 'null, etc...))
+  (define-struct (type-empty type) () (make-inspector))
+
+  (define-struct (type-cst type) (type) (make-inspector))
+  (define-struct (type-cons type) (car cdr) (make-inspector))
+  (define-struct (type-vector type) (element) (make-inspector))
+  (define-struct (type-case-lambda type) (rest-arg?s req-args argss exps) (make-inspector))
+  (define-struct (type-var type) (name reach handle) (make-inspector))
+  (define-struct (type-union type) (elements) (make-inspector))
+  (define-struct (type-rec type) (vars types body) (make-inspector))
+  (define-struct (type-values type) (type) (make-inspector))
+  (define-struct (type-promise type) (value) (make-inspector))
+
+  ; note: we have to keep the type label around, because that's the only thing
+  ; that allows us to differentiate structurally equivalent structure that have
+  ; the same name (i.e. the only way to have subtyping work in the presence of generative
+  ; structures). The reason for type-struct-type is because structure types are first
+  ; class values in mzscheme. Also, by keeping the type-label around, we avoid the need
+  ; to duplicate the type hierarchy all the way up to the root each time we compute the
+  ; type of a structure.
+  (define-struct (type-struct-value type) (type-label types) (make-inspector))
+  (define-struct (type-struct-type type) (type-label) (make-inspector))
+
+  (define-struct (type-flow-var type) (name) (make-inspector))
+  (define-struct (type-scheme type) (flow-vars type^cs type) (make-inspector))
+  
+
+  ;;
+  ;; Printing
+  ;; 
+
+  (require (lib "match.ss")
+           (prefix string: (lib "string.ss"))
+           "util.ss"
+           "labels.ss")
+
+  (define type->list
+    (lambda (type)
+      (letrec
+          ([loop (lambda (type) 
+             (match type
+               [($ type-empty) '_]
+               [($ type-cst type)
+                (if (null? type)
+                    'null 
+                    (string->symbol (string:expr->string type)))]
+               [($ type-struct-type label)
+                (string->symbol (string-append "#<struct-type:"
+                                               (symbol->string (label-struct-type-name label))
+                                               ">"))]
+               [($ type-cons hd tl)
+                (list 'cons (loop hd) (loop tl))]
+               [($ type-case-lambda rest-arg?s req-args argss exps)
+                (list 'case-lambda
+                      (foldr-case-lambda-vector
+                       (lambda (rest-arg? req-arg args exp acc)
+                         (cons (list args (if rest-arg? '*-> '->) exp) acc))
+                       null
+                       rest-arg?s req-args argss exps))]
+               [($ type-promise value)
+                (list 'promise (loop value))]
+               [($ type-struct-value label types)
+                (list  (string->symbol
+                        (string-append "#(struct:"
+                                       (symbol->string (if (label-struct-type? label)
+                                                           (label-struct-type-name label)
+                                                           label))))
+                       (map loop types))]
+               [($ type-values values-type)
+                (cond
+                 [(type-empty? values-type)
+                  (loop values-type)]
+                 [(and (type-cst? values-type) (eq? (type-cst-type values-type) 'top))
+                  (loop values-type)]
+                 [else
+                  (list 'values (loop values-type))])]
+               [($ type-vector element)
+                (list 'vector (loop element))]
+               [($ type-union elements)
+                (list 'union (map loop elements))]
+               [($ type-rec vars binders body)
+                (list 'rec-type
+                      (map (lambda (v b)
+                             (list (loop  v) (loop b)))
+                           vars binders)
+                      (loop body))]
+               [($ type-var name r h)
+                name]
+               [(? natural?) (string->symbol (string-append "h:" (number->string type)))]))])
+        (loop type))))
+
+  (define handle? natural?)
+
+  ;; Is there a better place for this?
+  (define foldr-case-lambda-vector
+    (lambda (f init rest-arg?s req-args argss exps)
+      (let* ([v-to-l (lambda (x) (if (list? x) (list->vector x) x))]
+             [rest-arg?s (v-to-l rest-arg?s)]
+             [req-args (v-to-l req-args)]
+             [argss (if (list? argss) (lol->vov argss) argss)]
+             [exps (v-to-l exps)]
+             [len (vector-length rest-arg?s)])
+        (let loop ([i 0])
+          (if (= i len) init
+              (f (vector-ref rest-arg?s i)
+                 (vector-ref req-args i)
+                 (vector-ref argss i)
+                 (vector-ref exps i)
+                 (loop (add1 i))))))))
+
+)
diff --git a/collects/mrflow/util.ss b/collects/mrflow/util.ss
new file mode 100644
index 0000000000..8a82f6497e
--- /dev/null
+++ b/collects/mrflow/util.ss
@@ -0,0 +1,269 @@
+
+(module util  (lib "mrflow.ss" "mrflow")
+  (require (prefix list: (lib "list.ss"))
+           (lib "pretty.ss")
+           (lib "class.ss")
+           (prefix cst: "constants.ss"))
+  
+  (provide (all-defined))
+  
+  ;;
+  ;; Number functions
+  ;;
+  (define natural? (lambda (n) (and (integer? n) (>= n 0))))
+  
+  
+  ;;
+  ;; List functions
+  ;;
+  (define length-one?
+    (lambda (x) (and (pair? x) (null? (cdr x)))))
+  
+  (define nonempty-list-of?
+    (lambda (p) (lambda (xs) (and (pair? xs) (andmap p xs)))))
+  
+  (define unfold-onto
+    (lambda (p f g seed onto)
+      (if (p seed) onto
+          (cons (f seed) (unfold-onto p f g (g seed) onto)))))
+  
+  (define unfold
+    (lambda (p f g seed)
+      (unfold-onto p f g seed '())))
+  
+  ;; int -> list int
+  (define iota
+    (lambda (n)
+      (unfold (lambda (x) (= x n)) (lambda (x) x) add1 0)))
+  
+  (define min-list-numbers
+    (let ([remove-duplicates              ;; remove duplicate numbers from a sorted list
+           (lambda (xs)                   ;; of numbers, returned list is reversed
+             (if (null? xs) '()
+                 (let loop ((xs (cdr xs)) (acc (list (car xs))))
+                   (if (null? xs) acc
+                       (if (< (car xs) (car acc))
+                           (loop (cdr xs) (cons (car xs) acc))
+                           (loop (cdr xs) acc))))))])
+      (lambda (nums)
+        (remove-duplicates (list:mergesort nums >)))))
+  
+  (define/contract lol->vov ((listof (listof any/c)) . -> . vector?)
+    (lambda (xss) (list->vector (map list->vector xss))))
+  
+  (define map2deep
+    (lambda (f xss)
+      (map (lambda (xs) (map f xs)) xss)))
+  
+  (define no-duplicates?/c
+    (flat-named-contract "List without duplicates"
+                         (lambda (xs)
+                           (let ([tbl (make-hash-table)])
+                             (let/ec return-with
+                               (for-each (lambda (x)
+                                           (when (hash-table-get tbl x cst:thunk-false)
+                                             (return-with #f))
+                                           (hash-table-put! tbl x #t))
+                                         xs)
+                               #t)))))
+  
+  ;;
+  ;; Vector functions
+  ;;
+  (define foldr-vector
+    (lambda (f init v)
+      (let loop ([i 0])
+        (if (= i (vector-length v)) init
+            (f (vector-ref v i) (loop (add1 i)))))))
+  
+  (define interval->list
+    (lambda (v lo hi)
+      (let loop ([i lo])
+        (if (= i hi) '()
+            (cons (vector-ref v i) (loop (add1 i)))))))
+  
+  (define list->immutable-vector
+    (lambda xs
+      (apply vector-immutable xs)))
+  
+  (define/contract map-vector ((any/c . -> . any) vector? . -> . vector?)
+    (lambda (f v)
+      (let* ([len (vector-length v)]
+             [new-v (make-vector len #f)])
+        (let loop ([i 0])
+          (when (< i len)
+            (vector-set! new-v i (f (vector-ref v i)))
+            (loop (add1 i))))
+        new-v)))
+  
+  (define/contract map-vector-of-vector ((any/c . -> . any) (vectorof vector?) . -> . (vectorof vector?))
+    (lambda (f vov)
+      (map-vector (lambda (v) (map-vector f v)) vov)))
+  
+  (define/contract for-each-vector ((any/c . -> . any) vector? . -> . void?)
+    (lambda (f v)
+      (let ([len (vector-length v)])
+        (let loop ([i 0])
+          (when (< i len)
+            (f (vector-ref v i))
+            (loop (add1 i)))))
+      cst:void))
+  
+  ; Replace each element e in a vector with (f e)
+  (define/contract for-each-vector! ((any/c . -> . any) vector? . -> . vector?)
+    (lambda (f v)
+      (let ([len (vector-length v)])
+        (let loop ([i 0])
+          (when (< i len)
+            (vector-set! v i (f (vector-ref v i)))            
+            (loop (add1 i)))))
+      v))
+  
+  (define/contract for-each-vov ((any/c . -> . any) (vectorof (vectorof any/c)) . -> . void?)
+    (lambda (f vov)
+      (for-each-vector (lambda (v) (for-each-vector f v) v) vov)))
+  
+  ; Replace each element in a vector of vectors with (f e)
+  (define/contract for-each-vov! ((any/c . -> . any) (vectorof (vectorof any/c)) . -> . any)
+    (lambda (f vov)
+      (for-each-vector! (lambda (v) (for-each-vector! f v) v) vov)
+      vov))
+  
+  (define vector-of?
+    (lambda (pred v)
+      (let/ec escape
+        (let loop ([i 0])
+          (if (= i (vector-length v)) #t
+              (if (pred (vector-ref v i))
+                  (loop (add1 i))
+                  (escape #f)))))))
+  
+  (define vector-of-vector-of?
+    (lambda (pred vov)
+      (vector-of? (lambda (v) (vector-of? pred v)) vov)))
+  
+  (define vector-has?
+    (lambda (pred v)
+      (let/ec escape
+        (let loop ([i 0])
+          (if (= i (vector-length v)) #f
+              (if (pred (vector-ref v i))
+                  (escape #t)
+                  (loop (add1 i))))))))
+  
+  (define vector-of-vector-has?
+    (lambda (pred vov)
+      (vector-has? (lambda (v) (vector-has? pred v)) vov)))
+  
+  
+  ;;
+  ;; Hash functions
+  ;;
+  
+  (define hash-table-size
+    (lambda (h)
+      (let ([size 0])
+        (hash-table-for-each h (lambda (_ _2) (set! size (add1 size))))
+        size)))
+  
+  (define hash-table-empty?
+    (lambda (h)
+      (let/ec escape
+        (hash-table-for-each h (lambda (k v) (escape #f)))
+        #t)))
+  
+  (define/contract hash-table-has-key? (hash-table? any/c . -> . boolean?)
+    (lambda (hash-table key)
+      (if (hash-table-get hash-table key cst:thunk-false) #t #f)))
+  
+  ;; (hash-table key (list value)) key value -> (hash-table key (list value))
+  (define/contract hash-table-prepend! (hash-table? any/c any/c . -> . any)
+    (lambda (hash-table key value)
+      (hash-table-put! hash-table key
+                       (if (hash-table-has-key? hash-table key)
+                           (cons value (hash-table-get hash-table key
+                                                       (lambda () (error 'hash-table-prepend! "Could not prepend"))))
+                           (list value)))))
+  
+  ;;
+  ;; Function functions
+  ;; 
+  (define (curry f)
+    (lambda (x) (f x)))
+  
+  ;;
+  ;; Boolean functions
+  ;;
+  (define true?
+    (lambda (x) (eq? x #t)))
+  
+  ;;
+  ;; Random functions
+  ;; 
+  
+  (define/contract numberify-symbol (symbol? integer? . -> . symbol?)
+    (lambda (sym x)
+      (string->symbol (string-append (symbol->string sym) ":" (number->string x)))))
+  
+  (define/contract numberify-list ((cons/c symbol? (listof any/c)) integer? . -> . (cons/c symbol? (listof any/c)))
+    (lambda (syms x)
+      (cons (numberify-symbol (car syms)) (cdr syms))))
+  
+  (define/contract pretty-error (symbol? any/c . -> . any)
+    (lambda (sym v)
+      (let ([out (open-output-string)])
+        (pretty-print v out)
+        (error sym (get-output-string out)))))
+  
+  (define andmap4-vector
+    (lambda (f v0 v1 v2 v3)
+      (let loop ([i 0])
+        (if (= i (vector-length v0)) #t
+            (and (f (vector-ref v0 i) (vector-ref v1 i) (vector-ref v2 i) (vector-ref v3 i))
+                 (loop (add1 i)))))))
+  
+  (define andmap2-vector-interval
+    (lambda (f v0 v1 lo high)
+      (let loop ([i lo])
+        (if (= i high) #t
+            (and (f (vector-ref v0 i) (vector-ref v1 i))
+                 (loop (add1 i)))))))
+  
+  (define andmap2-vector
+    (lambda (f v0 v1)
+      (andmap2-vector-interval f v0 v1 0 (vector-length v0))))
+  
+  ; return #t if the p(i) = # for all i in the half-open interval lo <= i < hi 
+  (define andmap-vector-interval
+    (lambda (f v0 lo high)
+      (let loop ([i lo])
+        (if (= i high) #t
+            (and (f (vector-ref v0 i))
+                 (loop (add1 i)))))))
+  
+  (define andmap-vector
+    (lambda (f v0)
+      (andmap-vector-interval f v0 0 (vector-length v0))))
+  
+  (define ormap4-vector
+    (lambda (f v0 v1 v2 v3)
+      (let loop ([i 0])
+        (if (= i (vector-length v0)) #f
+            (or (f (vector-ref v0 i) (vector-ref v1 i) (vector-ref v2 i) (vector-ref v3 i))
+                (loop (add1 i)))))))
+  
+  
+  ;; Classes
+  
+  (define counter%
+    (class object%
+      (init-field [start 0])
+      (define count start)
+      
+      (define/public get
+        (lambda () count))
+      
+      (define/public next!
+        (lambda () (set! count (add1 count)) count))
+      (super-new)))
+  )
\ No newline at end of file
diff --git a/collects/mrlib/aligned-pasteboard.ss b/collects/mrlib/aligned-pasteboard.ss
new file mode 100644
index 0000000000..a6c1e084fd
--- /dev/null
+++ b/collects/mrlib/aligned-pasteboard.ss
@@ -0,0 +1,16 @@
+(module aligned-pasteboard mzscheme
+  (require
+    "private/aligned-pasteboard/aligned-pasteboard.ss"
+    "private/aligned-pasteboard/aligned-editor-container.ss"
+    "private/aligned-pasteboard/interface.ss"
+    "private/aligned-pasteboard/stretchable-editor-snip.ss")
+  (provide
+    vertical-pasteboard%
+    horizontal-pasteboard%
+    aligned-editor-snip%
+    aligned-editor-canvas%
+    aligned-pasteboard<%>
+    aligned-pasteboard-parent<%>
+    stretchable-snip<%>
+    stretchable-editor-snip%
+    stretchable-editor-snip-mixin))
diff --git a/collects/mrlib/bitmap-label.ss b/collects/mrlib/bitmap-label.ss
new file mode 100644
index 0000000000..2ca2450e1b
--- /dev/null
+++ b/collects/mrlib/bitmap-label.ss
@@ -0,0 +1,94 @@
+(module bitmap-label mzscheme
+  (require (lib "mred.ss" "mred")
+	   (lib "class.ss")
+	   (lib "contract.ss"))
+
+  (provide/contract
+   [bitmap-label-maker (string?
+			(union path-string?
+			       (is-a?/c bitmap%))
+			. -> .
+			(any/c . -> . (is-a?/c bitmap%)))])
+  
+  (define bitmap-label-maker
+    (case-lambda 
+     [(text filename-or-bitmap)
+      (lambda (area-container-window)
+	(let*-values ([(outside-margin) 2]
+		      [(font) normal-control-font]
+		      [(img-bitmap-dc img-bitmap img-width img-height)
+		       (let ([mdc (make-object bitmap-dc%)]
+			     [q (if (filename-or-bitmap . is-a? . bitmap%)
+				    filename-or-bitmap
+				    (make-object bitmap% filename-or-bitmap 'unknown/mask))])
+			 (if (send q ok?)
+			     (begin (send mdc set-bitmap q)
+				    (values mdc
+					    q
+					    (send q get-width)
+					    (send q get-height)))
+			     (let ([b (make-object bitmap% 1 1)])
+			       (send mdc set-bitmap b)
+			       (send mdc clear)
+			       (values mdc q 0 0))))]
+		      [(width height descent leading)
+		       (send img-bitmap-dc get-text-extent text font)]
+		      [(middle-margin) (if (and (zero? img-width)
+						(zero? img-height))
+					   0
+					   3)]
+		      [(new-width) (inexact->exact
+				    (floor
+				     (+ outside-margin
+					img-width
+					middle-margin
+					width
+					outside-margin)))]
+		      [(new-height) (inexact->exact
+				     (floor (+ outside-margin
+					       (max img-height height)
+					       outside-margin)))]
+		      [(bitmap-dc) (make-object bitmap-dc%)]
+		      [(new-bitmap) (make-object bitmap% new-width new-height)]
+		      [(new-bitmap-mask) (make-object bitmap% new-width new-height)])
+	  (send new-bitmap set-loaded-mask new-bitmap-mask)
+	  (send img-bitmap-dc set-bitmap #f)
+	  (send bitmap-dc set-bitmap new-bitmap-mask)
+	  
+	  (send bitmap-dc set-font font)
+	  (send bitmap-dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
+	  (send bitmap-dc set-brush (send the-brush-list find-or-create-brush "black" 'solid))
+	  
+	  
+	  (send bitmap-dc clear)
+	  (send bitmap-dc draw-text text 
+		(+ outside-margin img-width middle-margin)
+		(- (/ new-height 2) (/ height 2)))
+	  
+	  (cond
+	   [(send img-bitmap get-loaded-mask)
+	    (send bitmap-dc draw-bitmap
+		  (send img-bitmap get-loaded-mask)
+		  outside-margin
+		  (- (/ new-height 2) (/ img-height 2)))]
+	   [else
+	    (send bitmap-dc draw-rectangle 
+		  outside-margin
+		  (- (/ new-height 2) (/ img-height 2))
+		  img-width
+		  img-height)])
+	  
+	  (send bitmap-dc set-bitmap new-bitmap)
+	  (send bitmap-dc clear)
+	  (send bitmap-dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
+	  (send bitmap-dc set-brush (send the-brush-list find-or-create-brush "black" 'solid))
+	  (send bitmap-dc draw-rectangle 
+		(+ outside-margin img-width middle-margin)
+		(- (/ new-height 2) (/ height 2))
+		width height)
+	  (send bitmap-dc draw-bitmap
+		img-bitmap
+		outside-margin
+		(- (/ new-height 2) (/ img-height 2)))
+	  (send bitmap-dc set-bitmap #f)
+	  new-bitmap))])))
diff --git a/collects/mrlib/cache-image-snip.ss b/collects/mrlib/cache-image-snip.ss
new file mode 100644
index 0000000000..7b294b107f
--- /dev/null
+++ b/collects/mrlib/cache-image-snip.ss
@@ -0,0 +1,644 @@
+(module cache-image-snip mzscheme
+  (require (lib "mred.ss" "mred")
+           (lib "class.ss")
+           (lib "string.ss")
+	   (lib "contract.ss")
+           (lib "list.ss"))
+  
+  (provide cache-image-snip%
+           snip-class)
+           
+  ;; type argb = (make-argb (vectorof rational[between 0 & 255]) int)
+  (define-struct argb (vector width))
+  
+  #|
+
+    The true meaning of an image is a vector of rationals,
+    between 0 & 255, representing color and alpha channel
+    information. The vector's contents are analagous to
+    the last argument to the get-argb-pixels method. That is,
+    there are (* 4 w h) entries in the vector for an image
+    of width w and height h, and the entries represent the
+    alpha, red, green, & blue channels, resp.
+
+    When drawn to the screen, the rationals are rounded to
+    their nearest integer, but the true meaning is kept inside
+    the image.
+
+  note to self:
+    mask of zero means this image dominates
+    mask of 255 means this image contributes nothing
+
+    black is 0
+    white is 255
+
+    a cleared out bitmap is full of 255s (white)
+
+    an alpha of 1 means the pixel value is 0
+    an alpha of 0 means the pixel value is 255
+ |#
+  
+  (define cache-image-snip%
+    (class snip%
+      
+      ;; dc-proc : (union #f ((is-a?/c dc<%>) int[dx] int[dy] -> void))
+      ;; used for direct drawing
+      (init-field dc-proc)
+      (define/public (get-dc-proc) dc-proc)
+      
+      ;; argb-proc : ((vectorof rational[0 <= x <= 255]) int[dx] int[dy] -> void)
+      ;; used for drawing into a bitmap
+      (init-field argb-proc)
+      (define/public (get-argb-proc) argb-proc)
+      
+      ;; the pinhole's coordinates
+      (init-field px py)
+      (define/public (get-pinhole) (values px py))
+
+      (init-field (width #f)
+                  (height #f))
+      (define/public (get-size)
+        (values width height))
+      
+      ;; argb : (union #f argb)
+      (init-field [argb #f])
+
+      
+      ;; bitmap : (union #f (is-a?/c bitmap%))
+      ;; the way that this image is be drawn, on its own
+      (define bitmap #f)
+      
+      (define/override (copy)
+        (new cache-image-snip% 
+             (dc-proc dc-proc)
+             (argb-proc argb-proc)
+             (width width)
+             (height height)
+             (argb argb)
+             (px px)
+             (py py)))
+      
+      ;; get-bitmap : -> bitmap
+      ;; returns a bitmap showing what the image would look like, 
+      ;; if it were drawn
+      (define/public (get-bitmap)
+        (unless bitmap
+          (set! bitmap (argb->bitmap (get-argb))))
+        bitmap)
+      
+      ;; get-argb : -> argb
+      (define/public (get-argb)
+        (unless argb
+          (set! argb (make-argb (make-vector (* 4 width height) 255) width))
+          (argb-proc argb 0 0))
+        argb)
+      
+      ;; get-argb/no-compute : -> (union #f argb)
+      (define/public (get-argb/no-compute)
+        argb)
+      
+      (define/override (get-extent dc x y w h descent space lspace rspace)
+        (set-box/f! w width)
+        (set-box/f! h height)
+        (set-box/f! descent 0)
+        (set-box/f! space 0)
+        (set-box/f! lspace 0)
+        (set-box/f! rspace 0))
+      
+      (define/override (draw dc x y left top right bottom dx dy draw-caret)
+        (cond
+          [argb (let ([bitmap (get-bitmap)])
+                  (send dc draw-bitmap bitmap x y 'solid 
+                        (send the-color-database find-color "black")
+                        (send bitmap get-loaded-mask)))]
+          [dc-proc (dc-proc dc x y)]
+          [else (void)]))
+      
+      (define/override (write f)
+        (let ([str (string->bytes/utf-8
+                    (format "~s"
+                            (list (argb-vector (get-argb))
+                                  width
+                                  px 
+                                  py)))])
+          (send f put str)))
+      
+      (define/override (get-num-scroll-steps) (inexact->exact (+ (quotient height 20) 1)))
+      (define/override (find-scroll-step y) (inexact->exact (floor (/ y 20))))
+      (define/override (get-scroll-step-offset offset) (* offset 20))
+      
+      (super-new)
+      (inherit set-snipclass)
+      (set-snipclass snip-class)))
+
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;
+  ;; snip-class
+  ;;
+  
+  (define cache-image-snip-class%
+    (class snip-class%
+      (define/override (read f)
+        (let ([data (read-from-string (bytes->string/utf-8 (send f get-bytes))
+                                      void
+                                      (lambda (x) #f))])
+          (if data
+              (argb->cache-image-snip (make-argb (first data) (second data)) (third data) (fourth data))
+              (make-null-cache-image-snip))))
+      (super-new)))
+  
+  (define snip-class (new cache-image-snip-class%))
+  (send snip-class set-version 1)
+  (send snip-class set-classname (format "~s" `(lib "cache-image-snip.ss" "mrlib")))
+  (send (get-the-snip-class-list) add snip-class)
+  
+  (define (make-null-cache-image-snip)
+    (define size 10)
+    (define (draw dc dx dy)
+      (with-pen/brush
+       dc
+       "black" 'solid
+       "black" 'transparent
+       (send dc draw-ellipse dx dy size size)
+       (send dc draw-line dx (+ dy size -1) (+ dx size -1) dy)))
+    (define bm (build-bitmap (lambda (dc) (draw dc 0 0))
+                             size
+                             size))
+    (new cache-image-snip%
+         (width size)
+         (height size)
+         (draw-proc draw)
+         (px (/ size 2))
+         (py (/ size 2))
+         (argb-proc 
+          (lambda (argb dx dy)
+            (overlay-bitmap argb size size dx dy bm bm)))))
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;
+  ;; misc. utilities
+  ;;
+  
+  ;; takes a bitmap with a mask and flattens the colors and the mask
+  ;; drawing them as they would appear on the screen.
+  (define (flatten-bitmap bm)
+    (let* ([w (send bm get-width)]
+           [h (send bm get-height)]
+           [new-bm (make-object bitmap% w h)]
+           [bdc (make-object bitmap-dc% new-bm)])
+      (send bdc draw-bitmap bm 0 0 'solid 
+            (send the-color-database find-color "black")
+            (send bm get-loaded-mask))
+      (send bdc set-bitmap #f)
+      new-bm))
+  
+  ;; build-bitmap : (dc -> void) number number -> bitmap
+  (define (build-bitmap draw w h)
+    (let* ([bm (make-object bitmap% w h)]
+           [bdc (make-object bitmap-dc% bm)])
+      (send bdc clear)
+      (draw bdc)
+      (send bdc set-bitmap #f)
+      bm))
+
+  (define-syntax (with-pen/brush stx)
+    (syntax-case stx ()
+      [(_ dc pen-color pen-style brush-color brush-style code ...)
+       (syntax
+        (let ([old-pen (send dc get-pen)]
+              [old-brush (send dc get-brush)])
+          (send dc set-pen (send the-pen-list find-or-create-pen pen-color 1 pen-style))
+          (send dc set-brush (send the-brush-list find-or-create-brush brush-color brush-style))
+          code ...
+          (send dc set-pen old-pen)
+          (send dc set-brush old-brush)))]))
+  
+  (define (set-box/f! b v) (when (box? b) (set-box! b v)))
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;
+  ;; argb vector utilties
+  ;;
+  
+  ;; argb->cache-image-snip : argb number number -> cache-image-snip
+  (define (argb->cache-image-snip argb px py)
+    (let* ([width (argb-width argb)]
+           [argb-vector (argb-vector argb)]
+           [height (quotient (vector-length argb-vector) (* 4 width))]
+           [bitmap (argb->bitmap argb)]
+           [mask (send bitmap get-loaded-mask)])
+      (new cache-image-snip%
+           (width width)
+           (height height)
+           (argb argb)
+           (px px)
+           (py py)
+           (argb-proc 
+            (lambda (argb dx dy)
+              (overlay-bitmap argb dx dy bitmap mask)))
+           (dc-proc (lambda (dc dx dy)
+                      (send dc draw-bitmap bitmap dx dy 'solid 
+                            (send the-color-database find-color "black")
+                            mask))))))
+  
+  ;; argb-vector->bitmap : argb -> bitmap
+  ;; flattens the argb vector into a bitmap
+  (define (argb->bitmap argb)
+    (let* ([argb-vector (argb-vector argb)]
+           [w (argb-width argb)]
+           [h (quotient (vector-length argb-vector) (* w 4))]
+           [bm (make-object bitmap% w h)]
+           [mask-bm (make-object bitmap% w h)]
+           [bdc (new bitmap-dc% (bitmap bm))]
+           [bytes (make-bytes (vector-length argb-vector) 255)]
+           [mask-bytes (make-bytes (vector-length argb-vector) 255)])
+      (let loop ([i (- (vector-length argb-vector) 1)])
+        (cond
+          [(zero? (modulo i 4))
+           (let ([av (round (vector-ref argb-vector i))])
+             (bytes-set! mask-bytes (+ i 1) av)
+             (bytes-set! mask-bytes (+ i 2) av)
+             (bytes-set! mask-bytes (+ i 3) av))]
+          [else
+           (bytes-set! bytes i (round (vector-ref argb-vector i)))])
+        (unless (zero? i)
+          (loop (- i 1))))
+      (send bdc set-argb-pixels 0 0 w h bytes)
+      (send bdc set-bitmap mask-bm)
+      (send bdc set-argb-pixels 0 0 w h mask-bytes)
+      (send bdc set-bitmap #f)
+      (send bm set-loaded-mask mask-bm)
+      bm))
+  
+  ;; overlay-bitmap : argb int int bitmap bitmap -> void
+  ;; assumes that the mask bitmap only has greyscale in it
+  ;; (ie, that looking at the red component of the mask is enough)
+  (define (overlay-bitmap argb dx dy color mask)
+    (let* ([argb-vector (argb-vector argb)]
+           [argb-w (argb-width argb)]
+           [w (send color get-width)]
+           [h (send color get-height)]
+           [color-bytes (make-bytes (* w h 4) 0)]
+           [mask-bytes (make-bytes (* w h 4) 0)]
+           [dc (make-object bitmap-dc%)])
+      (send dc set-bitmap color)
+      (send dc get-argb-pixels 0 0 w h color-bytes)
+      (send dc set-bitmap #f) ;; in case mask and color are the same bitmap....
+      (send dc set-bitmap mask)
+      (send dc get-argb-pixels 0 0 w h mask-bytes)
+      (send dc set-bitmap #f)
+      (let yloop ([y 0]
+                  [str-i 0])
+        (unless (= y h)
+          (let xloop ([x 0]
+                      [str-i str-i])
+            (if (= x w)
+                (yloop (add1 y) str-i)
+                (begin
+                  (when (and (<= 0 (+ x dx))
+                             (< (+ x dx) argb-w))
+                    (let ([argb-i (* 4 (+ (+ dx x) (* (+ dy y) argb-w)))])
+                      (when (and (<= 0 argb-i)
+                                 (< argb-i (vector-length argb-vector)))
+                        (let* ([m1 (vector-ref argb-vector argb-i)]
+                               [m2 (bytes-ref mask-bytes (+ str-i 1))] ;; get red coordinate
+                               [m3 (build-m3 m1 m2)]
+                               [do-b
+                                (lambda (off)
+                                  (vector-set! argb-vector
+                                               (+ argb-i off)
+                                               (build-b3 m1
+                                                         (vector-ref argb-vector (+ argb-i off))
+                                                         m2
+                                                         (bytes-ref color-bytes (+ str-i off))
+                                                         m3)))])
+                          (vector-set! argb-vector argb-i m3)
+                          (do-b 1)
+                          (do-b 2)
+                          (do-b 3)))))
+                  (xloop (+ x 1) (+ str-i 4)))))))))
+  
+#|
+From Matthew's computation in PR 6930:
+> m3 is (m1+m2-m1*m2) and 
+> b3 is (m1*b1*(1-m2) + m2*b2)/m3
+
+but that's for values between 0 and 1 and we
+need values between 0 and 255. Worse, the values
+sense are reversed. That is,
+1 above corresponds to 0 in pixel values and
+0 above corresponds to 255.
+
+;; the spec
+(define (build-m3-0 big-m1 big-m2)
+  (let ([m1 (- 1 (/ big-m1 255))]
+        [m2 (- 1 (/ big-m2 255))])
+    (let ([m3 (+ m1 m2 (- (* m1 m2)))])
+      (* 255 (- 1 m3)))))
+
+; = substitute in lets
+(define (build-m3-1 m1 m2)
+  (* 255 (- 1 (+ (- 1 (/ m1 255))
+                 (- 1 (/ m2 255))
+                 (- (* (- 1 (/ m1 255))
+                       (- 1 (/ m2 255))))))))
+
+;= multiply out last product
+(define (build-m3-2 m1 m2)
+  (* 255 (- 1 (+ (- 1 (/ m1 255))
+                 (- 1 (/ m2 255))
+                 (- (+ 1 
+                       (- (/ m1 255))
+                       (- (/ m2 255))
+                       (* (- (/ m1 255)) (- (/ m2 255)))))))))
+
+; = lift out the neagtives into topmost sum
+(define (build-m3-3 m1 m2)
+  (* 255 (- 1 (+ (- (/ m1 255))
+                 1
+                 (- (/ m2 255))
+                 1
+                 -1
+                 (/ m1 255)
+                 (/ m2 255)
+                 (- (* (/ m1 255) (/ m2 255)))))))
+
+; = push in topmost subtraction
+(define (build-m3-4 m1 m2)
+  (* 255 (+ 1
+            (/ m1 255)
+            -1
+            (/ m2 255)
+            -1
+            1
+            (- (/ m1 255))
+            (- (/ m2 255))
+            (* (/ m1 255) (/ m2 255)))))
+
+; = simplify sum:
+
+(define (build-m3-5 m1 m2)
+  (* 255 (* (/ m1 255) (/ m2 255))))
+
+; = distribute 255
+
+(define (build-m3-6 m1 m2) (* m1 m2 1/255))
+
+(define (test-m3 m1 m2)
+  (values (build-m3-0 m1 m2)
+          (build-m3-1 m1 m2)
+          (build-m3-2 m1 m2)
+          (build-m3-3 m1 m2)
+          (build-m3-4 m1 m2)
+          (build-m3-5 m1 m2)
+          (build-m3-6 m1 m2)))
+
+(test-m3 0 0)
+(test-m3 255 255)
+(test-m3 100 200)
+
+for b3, we have:
+
+(define (build-m3-6 m1 m2) (* m1 m2 1/255))
+
+;; the spec
+(define (build-b3-0 big-m1 big-b1 big-m2 big-b2 big-m3)
+  (let ([m1 (- 1 (/ big-m1 255))]
+        [b1 (- 1 (/ big-b1 255))]
+        [m2 (- 1 (/ big-m2 255))]
+        [b2 (- 1 (/ big-b2 255))]
+        [m3 (- 1 (/ big-m3 255))])
+    (let ([ans (/ (+ (* m1 b1 (- 1 m2)) (* m2 b2)) m3)])
+      (* 255 (- 1 ans)))))
+
+;; = substitute in for let.
+(define (build-b3-1 m1 b1 m2 b2 m3)
+  (* 255 (- 1 (/ (+ (* (- 1 (/ m1 255)) (- 1 (/ b1 255)) (- 1 (- 1 (/ m2 255)))) 
+                    (* (- 1 (/ m2 255)) (- 1 (/ b2 255))))
+                 (- 1 (/ m3 255))))))
+
+;; = simple substitution
+(define (build-b3-2 m1 b1 m2 b2 m3)
+  (* 255 (- 1 (/ (+ (* (- 1 (/ m1 255)) (- 1 (/ b1 255)) (/ m2 255))
+                    (* (- 1 (/ m2 255)) (- 1 (/ b2 255))))
+                 (- 1 (/ m3 255))))))
+
+;; = multiply out first part of first *
+(define (build-b3-3 m1 b1 m2 b2 m3)
+  (* 255 (- 1 (/ (+ (* (+ 1
+                          (- (/ m1 255))
+                          (- (/ b1 255))
+                          (* (/ m1 255) (/ b1 255))) 
+                       (/ m2 255))
+                    (* (- 1 (/ m2 255)) (- 1 (/ b2 255))))
+                 (- 1 (/ m3 255))))))
+
+;; = distribute out newly created product 
+(define (build-b3-4 m1 b1 m2 b2 m3)
+  (* 255 (- 1 (/ (+ (/ m2 255)
+                    (* (- (/ m1 255)) (/ m2 255))
+                    (* (- (/ b1 255)) (/ m2 255))
+                    (* (/ m1 255) (/ b1 255) (/ m2 255))
+                    (* (- 1 (/ m2 255)) (- 1 (/ b2 255))))
+                 (- 1 (/ m3 255))))))
+
+;; = multiply out product of sum
+(define (build-b3-5 m1 b1 m2 b2 m3)
+  (* 255 (- 1 (/ (+ (/ m2 255)
+                    (* (- (/ m1 255)) (/ m2 255))
+                    (* (- (/ b1 255)) (/ m2 255))
+                    (* (/ m1 255) (/ b1 255) (/ m2 255))
+                    (+ 1
+                       (- (/ m2 255))
+                       (- (/ b2 255))
+                       (* (/ m2 255) (/ b2 255))))
+                 (- 1 (/ m3 255))))))
+
+;; = flatten out sum of sum & simplify
+(define (build-b3-6 m1 b1 m2 b2 m3)
+  (* 255 (- 1 (/ (+ (* (- (/ m1 255)) (/ m2 255))
+                    (* (- (/ b1 255)) (/ m2 255))
+                    (* (/ m1 255) (/ b1 255) (/ m2 255))
+                    1
+                    (- (/ b2 255))
+                    (* (/ m2 255) (/ b2 255)))
+                 (- 1 (/ m3 255))))))
+
+;; = rearrange denom
+(define (build-b3-7 m1 b1 m2 b2 m3)
+  (* 255 (- 1 (/ (+ (* (- (/ m1 255)) (/ m2 255))
+                    (* (- (/ b1 255)) (/ m2 255))
+                    (* (/ m1 255) (/ b1 255) (/ m2 255))
+                    1
+                    (- (/ b2 255))
+                    (* (/ m2 255) (/ b2 255)))
+                 (/ (- 255 m3) 255)))))
+
+;; = move 255 to numerator
+(define (build-b3-8 m1 b1 m2 b2 m3)
+  (* 255 (- 1 (/ (* 255 (+ (* (- (/ m1 255)) (/ m2 255))
+                           (* (- (/ b1 255)) (/ m2 255))
+                           (* (/ m1 255) (/ b1 255) (/ m2 255))
+                           1
+                           (- (/ b2 255))
+                           (* (/ m2 255) (/ b2 255))))
+                 (- 255 m3)))))
+
+;; cancel out 255s in numerator
+(define (build-b3-9 m1 b1 m2 b2 m3)
+  (* 255 (- 1 (/ (+ (* (- m1) (/ m2 255))
+                    (* (- b1) (/ m2 255))
+                    (* m1 (/ b1 255) (/ m2 255))
+                    255
+                    (- b2)
+                    (* m2 (/ b2 255)))
+                 (- 255 m3)))))
+
+;; rearrange numerator
+(define (build-b3-10 m1 b1 m2 b2 m3)
+  (* 255 (- 1 (/ (+ (/ (* (- m1) m2) 255)
+                    (/ (* (- b1) m2) 255)
+                    (/ (* m1 b1 (/ m2 255)) 255)
+                    (/ (* 255 255) 255)
+                    (/ (* 255 (- b2)) 255)
+                    (/ (* m2 b2) 255))
+                 (- 255 m3)))))
+
+;; pull out 255 in num
+(define (build-b3-11 m1 b1 m2 b2 m3)
+  (* 255 (- 1 (/ (/ (+ (* (- m1) m2)
+                       (* (- b1) m2)
+                       (* m1 b1 (/ m2 255))
+                       (* 255 255)
+                       (* 255 (- b2))
+                       (* m2 b2))
+                    255)
+                 (- 255 m3)))))
+
+;; push 255 into denom
+(define (build-b3-12 m1 b1 m2 b2 m3)
+  (* 255 (- 1 (/ (+ (* (- m1) m2)
+                    (* (- b1) m2)
+                    (* m1 b1 (/ m2 255))
+                    (* 255 255)
+                    (* 255 (- b2))
+                    (* m2 b2))
+                 (* 255 (- 255 m3))))))
+
+;; turn 1 into (/ (* 255 (- 255 m3)) (* 255 (- 255 m3)))
+;; and add into numerator
+(define (build-b3-13 m1 b1 m2 b2 m3)
+  (* 255 (/ (- (* 255 (- 255 m3))
+               (+ (* (- m1) m2)
+                  (* (- b1) m2)
+                  (* m1 b1 (/ m2 255))
+                  (* 255 255)
+                  (* 255 (- b2))
+                  (* m2 b2)))
+            (* 255 (- 255 m3)))))
+
+;; cancel out outer 255
+(define (build-b3-14 m1 b1 m2 b2 m3)
+  (/ (- (* 255 (- 255 m3))
+        (+ (* (- m1) m2)
+           (* (- b1) m2)
+           (* m1 b1 (/ m2 255))
+           (* 255 255)
+           (* 255 (- b2))
+           (* m2 b2)))
+     (- 255 m3)))
+
+;; push negative thru to make big sum in numerator
+(define (build-b3-15 m1 b1 m2 b2 m3)
+  (/ (+ (* 255 (- 255 m3))
+        (* m1 m2)
+        (* b1 m2)
+        (- (* m1 b1 (/ m2 255)))
+        (- (* 255 255))
+        (* 255 b2)
+        (- (* m2 b2)))
+     (- 255 m3)))
+
+;; distribute 255 in first num term
+(define (build-b3-16 m1 b1 m2 b2 m3)
+  (/ (+ (* 255 255)
+        (- (* 255 m3))
+        (* m1 m2)
+        (* b1 m2)
+        (- (* m1 b1 (/ m2 255)))
+        (- (* 255 255))
+        (* 255 b2)
+        (- (* m2 b2)))
+     (- 255 m3)))
+
+;; simplify num
+(define (build-b3-17 m1 b1 m2 b2 m3)
+  (/ (+ (* m1 m2)
+        (* b1 m2)
+        (- (* m2 b2))
+        (- (* m1 b1 m2 1/255))
+        (* 255 b2)
+        (- (* 255 m3)))
+     (- 255 m3)))
+
+;; simplify num, some more
+(define (build-b3-18 m1 b1 m2 b2 m3)
+  (/ (+ (* (+ m1 b1 (- b2)) m2) 
+        (* m1 b1 m2 -1/255)
+        (* 255 b2)
+        (* -255 m3))
+     (- 255 m3)))
+
+(define (test-b3 m1 b1 m2 b2)
+  (let ([m3 (build-m3-6 m1 m2)])
+    (values (build-b3-0 m1 b1 m2 b2 m3)
+            (build-b3-1 m1 b1 m2 b2 m3)
+            (build-b3-2 m1 b1 m2 b2 m3)
+            (build-b3-3 m1 b1 m2 b2 m3)
+            (build-b3-4 m1 b1 m2 b2 m3)
+            (build-b3-5 m1 b1 m2 b2 m3)
+            (build-b3-6 m1 b1 m2 b2 m3)
+            (build-b3-7 m1 b1 m2 b2 m3)
+            (build-b3-8 m1 b1 m2 b2 m3)
+            (build-b3-9 m1 b1 m2 b2 m3)
+            (build-b3-10 m1 b1 m2 b2 m3)
+            (build-b3-11 m1 b1 m2 b2 m3)
+            (build-b3-12 m1 b1 m2 b2 m3)
+            (build-b3-13 m1 b1 m2 b2 m3)
+            (build-b3-14 m1 b1 m2 b2 m3)
+            (build-b3-15 m1 b1 m2 b2 m3)
+            (build-b3-16 m1 b1 m2 b2 m3)
+            (build-b3-17 m1 b1 m2 b2 m3)
+            (build-b3-18 m1 b1 m2 b2 m3)
+            )))
+
+(test-b3 255 100 0 250)
+(test-b3 0 150 255 100)
+(test-b3 100 200 75 150)
+
+
+|#
+  
+  (define (build-m3 m1 m2) (* m1 m2 1/255))
+  
+  (define (build-b3 m1 b1 m2 b2 m3)
+    (if (= m3 255)
+        0
+        (/ (+ (* (+ m1 b1 (- b2)) m2) 
+              (* m1 b1 m2 -1/255)
+              (* 255 b2)
+              (* -255 m3))
+           (- 255 m3))))
+
+  (provide/contract
+   [overlay-bitmap (argb? number? number? (is-a?/c bitmap%) (is-a?/c bitmap%) . -> . any)]
+   [build-bitmap (((is-a?/c dc<%>) . -> . any) number? number? . -> . (is-a?/c bitmap%))]
+   [flatten-bitmap ((is-a?/c bitmap%) . -> . (is-a?/c bitmap%))]
+
+   [argb->cache-image-snip (argb? number? number? . -> . (is-a?/c cache-image-snip%))]
+   [argb->bitmap (argb? . -> . (is-a?/c bitmap%))]
+           
+   [argb? (any/c . -> . boolean?)]
+   [make-argb ((vectorof (integer-in 0 255)) integer? . -> . argb?)]
+   [argb-vector (argb? . -> . (vectorof (integer-in 0 255)))]
+   [argb-width (argb? . -> . integer?)]))
\ No newline at end of file
diff --git a/collects/mrlib/click-forwarding-editor.ss b/collects/mrlib/click-forwarding-editor.ss
new file mode 100644
index 0000000000..eaedaa8783
--- /dev/null
+++ b/collects/mrlib/click-forwarding-editor.ss
@@ -0,0 +1,52 @@
+(module click-forwarding-editor mzscheme
+  
+  (require
+   (lib "class.ss")
+   (lib "contract.ss")
+   (lib "etc.ss")
+   (lib "mred.ss" "mred"))
+  
+  (provide/contract
+   (click-forwarding-editor-mixin mixin-contract))
+  
+  ;; mixin to forward clicks to children snips within the editor
+  (define (click-forwarding-editor-mixin super%)
+    (class super%
+      (inherit get-snip-location global-to-local local-to-global
+               find-snip get-dc set-caret-owner)
+      
+      ;; on-event ((is-a?/c mouse-event%) . -> . void?)
+      ;; overridden to give focus to child snips when clicked
+      (define/override (on-event event)
+        (if (memq (send event get-event-type)
+                  '(left-down left-up middle-down middle-up right-down right-up))
+            (let ([snip (find-snip/global (send event get-x) (send event get-y))])
+              (if (is-a? snip snip%)
+                  (forward-event snip event)
+                  (super on-event event)))
+            (super on-event event)))
+      
+      ;; forward-event ((is-a?/c snip%) (is-a?/c mouse-event%) . -> . void?)
+      ;; send the event to the snip
+      (define/private (forward-event snip event)
+        (let ([editorx (box 0)]
+              [editory (box 0)])
+          (get-snip-location snip editorx editory false)
+          (let ([x (box (unbox editorx))]
+                [y (box (unbox editory))])
+            (local-to-global x y)
+            (send snip on-event (get-dc) (unbox x) (unbox y)
+                  (unbox editorx) (unbox editory) event)
+            (set-caret-owner snip 'display))))
+      
+      ;; find-snip/global (number? number? . -> . (union (is-a?/c snip%) false?))
+      ;; finds the snip in the pasteboard that is at x y in the global display
+      (define/private (find-snip/global x y)
+        (let ([new-x (box x)]
+              [new-y (box y)])
+          (global-to-local new-x new-y)
+          (find-snip (unbox new-x) (unbox new-y))))
+      
+      (super-instantiate ())
+      ))
+  )
diff --git a/collects/mrlib/doc.txt b/collects/mrlib/doc.txt
new file mode 100644
index 0000000000..401d5c713d
--- /dev/null
+++ b/collects/mrlib/doc.txt
@@ -0,0 +1,142 @@
+[][][][][][][][][][][][][][][][][][][][][][][][][][][][][][]
+
+                     _name-message.ss_
+
+[][][][][][][][][][][][][][][][][][][][][][][][][][][][][][]
+
+
+The _name-message%_ class is derived from canvas%. It
+overrides the on-paint and on-event methods to draw the name
+of a file and handle clicks to popup a menu for choosing a
+directory.
+
+> (send a-name-message set-message file-name? msg)
+
+  file-name? : boolean
+  msg : string
+
+If file-name? is #t, msg is treated like a pathname and
+clicks on the name message objects popup a menu that opens a
+get-file dialog.
+
+If file-name is #f, msg is treated as a regular
+string. Clicking on the name message pops up a dialog saying
+that there is no file name until the file is saved.
+      
+> (send a-name-message on-choose-directory dir)
+
+  dir : string
+
+This method is called when one of the popup menu items is
+chosen. The argument is a string representing the specified
+directory.
+
+============================================================
+
+> (calc-button-min-sizes dc string) 
+
+Calculates the minimum width and height of a button label
+(when drawn with draw-button-label). Returns two values: the
+width and height.
+
+============================================================
+
+> (draw-frame-button-label dc label width height inverted)
+
+Draws a button label like the one for the (define ...) and
+filename buttons in the top-left corner of the DrScheme
+
+frame. Use this function to draw similar buttons. The basic
+idea is to create a canvas object whose on-paint method is
+overridden to call this function.  The dc should be canvas's
+dc object, the label should be the string to display on the
+button.  The width and height arguments should be the width
+and height of the button and inverted? should be #t when the
+button is being depressed.
+
+See calc-button-min-sizes for help calculating the min sizes
+of the button.
+
+
+
+[][][][][][][][][][][][][][][][][][][][][][][][][][][][][][]
+
+                     _plot.ss_
+
+[][][][][][][][][][][][][][][][][][][][][][][][][][][][][][]
+
+plot.ss provides a simple tool for plotting data values to a 
+device context.
+
+
+Two structures are provided:
+===========================================================
+> (struct data-set ((points (listof (is-a?/c point%)))
+		    (connected? any?)
+		    (pen (is-a?/c pen%))
+		    (min-x number?)
+		    (max-x number?)   
+		    (min-y number?)   
+		    (max-y number?)))
+
+points: the list of data values.
+connected: determines whether the points are connected by a line or not.
+pen: the pen% to draw the points/lines with.
+min-x, max-x, min-y, max-y: indicate the window coordinates that the
+data should be drawn in.
+
+===========================================================
+
+> (struct plot-setup ((axis-label-font (is-a?/c font%))
+		      (axis-number-font (is-a?/c font%))
+		      (axis-pen (is-a?/c pen%))
+		      (grid? any?)
+		      (grid-pen (is-a?/c pen%))
+		      (x-axis-marking (listof number?))
+		      (y-axis-marking (listof number?))
+		      (x-axis-label string?)
+		      (y-axis-label string?)))
+
+axis-label-font: the font% the axis-labels is drawn with.
+axis-number-font: the font% the numbering on the axes is
+drawn with.
+axis-pen: the pen% the axis is drawn with.
+grid?: whether a grid should be drawn in at each axis marking.
+grid-pen: the pen% to draw the grid with.
+x-axis-marking: where marks should be placed on the x-axis.
+y-axis-marking: where marks should be placed on the y-axis.
+x-axis-label-string: the x-axis label.
+y-axis-label-string: the y-axis label.
+
+===========================================================
+
+One function is provided:
+===========================================================
+> (plot (is-a?/c dc<%>) (listof data-set?) plot-setup?)
+
+Draws the data-sets on the dc<%> configured by the setup.
+Uses window coordinates that will accommodate all of the
+data sets.
+
+[][][][][][][][][][][][][][][][][][][][][][][][][][][][][][]
+
+                  _include-bitmap.ss_
+
+[][][][][][][][][][][][][][][][][][][][][][][][][][][][][][]
+
+The include-bitmap.ss library provides a `include-bitmap form that
+takes a filename containing a bitmap and "inlines" the bitmap into the
+program. The advantage of "inlining" the bitmap is that a stand-alone
+executable can be created that contains the bitmap and does not refer
+to the original image file.
+
+> (include-bitmap file-spec)                       SYNTAX
+
+The `file-spec' is the same as for MzLib's `include': a path string, a
+`build-path' form, or a `lib' form.
+
+> (include-bitmap/relative-to source file-spec)    SYNTAX
+
+Analogous to `include-at/relative-to', though only a source is needed
+(no context).
+
diff --git a/collects/mrlib/graph.ss b/collects/mrlib/graph.ss
new file mode 100644
index 0000000000..5451b08503
--- /dev/null
+++ b/collects/mrlib/graph.ss
@@ -0,0 +1,894 @@
+
+(module graph mzscheme
+  (require (lib "class.ss")
+           (lib "list.ss")
+           (lib "math.ss")
+           (lib "mred.ss" "mred")
+	   (lib "contract.ss"))
+  
+  (provide graph-snip<%>
+           graph-snip-mixin
+           graph-pasteboard-mixin)
+  
+  (define graph-snip<%>
+    (interface ()
+      get-children 
+      add-child
+      remove-child
+      
+      get-parents
+      add-parent
+      remove-parent
+      
+      find-shortest-path))
+  
+  (define-local-member-name get-parent-links)
+  
+  (provide/contract (add-links
+		     (case->
+		      ((is-a?/c graph-snip<%>)
+		       (is-a?/c graph-snip<%>)
+		       . -> .
+		       void?)
+		      ((is-a?/c graph-snip<%>)
+		       (is-a?/c graph-snip<%>)
+		       (union false/c (is-a?/c pen%))
+		       (union false/c (is-a?/c pen%))
+		       (union false/c (is-a?/c brush%))
+		       (union false/c (is-a?/c brush%))
+		       . -> .
+		       void?)
+                      ((is-a?/c graph-snip<%>)
+		       (is-a?/c graph-snip<%>)
+		       (union false/c (is-a?/c pen%))
+		       (union false/c (is-a?/c pen%))
+		       (union false/c (is-a?/c brush%))
+		       (union false/c (is-a?/c brush%))
+		       number?
+                       number?
+                       . -> .
+		       void?))))
+  
+  (define self-offset 10)
+  
+  ;; (or-2v arg ...)
+  ;; like `or', except each `arg' returns two values. The
+  ;; truth value of each arg is #t if both args are #t and
+  ;; #f otherwise
+  (define-syntax (or-2v stx)
+    (syntax-case stx ()
+      [(_ arg)
+       (syntax arg)]
+      [(_ arg args ...)
+       (syntax
+        (let-values ([(one two) arg])
+          (if (and one two)
+              (values one two)
+              (or-2v args ...))))]))
+  
+  (define snipclass (make-object snip-class%))
+  
+  (define default-dark-pen (send the-pen-list find-or-create-pen "blue" 1 'solid))
+  (define default-light-pen (send the-pen-list find-or-create-pen "light blue" 1 'solid))
+  (define default-dark-brush (send the-brush-list find-or-create-brush "light blue" 'solid))
+  (define default-light-brush (send the-brush-list find-or-create-brush "white" 'solid))
+  
+  (define-struct link (snip dark-pen light-pen dark-brush light-brush dx dy))
+  
+  ;; add-links : (is-a?/c graph-snip<%>) (is-a?/c graph-snip<%>) -> void
+  ;;           : (is-a?/c graph-snip<%>) (is-a?/c graph-snip<%>) pen pen brush brush -> void
+  (define add-links 
+    (case-lambda
+      [(parent child) (add-links parent child #f #f #f #f)]
+      [(parent child dark-pen light-pen dark-brush light-brush)
+       (add-links parent child dark-pen light-pen dark-brush light-brush 0 0)]
+      [(parent child dark-pen light-pen dark-brush light-brush dx dy)
+       (send parent add-child child)
+       (send child add-parent parent dark-pen light-pen dark-brush light-brush dx dy)]))
+  
+  (define (graph-snip-mixin %)
+    (class* % (graph-snip<%>)
+      (field (children null))
+      (define/public (get-children) children)
+      (define/public (add-child child)
+        (unless (memq child children)
+          (set! children (cons child children))))
+      (define/public (remove-child child)
+        (when (memq child children)
+          (set! children (remq child children))))
+      
+      (field (parent-links null))
+      (define/public (get-parent-links) parent-links)
+      (define/public (get-parents) (map link-snip parent-links))
+      (define/public add-parent
+        (case-lambda
+          [(parent) (add-parent parent #f #f #f #f)]
+          [(parent dark-pen light-pen dark-brush light-brush)
+           (add-parent parent dark-pen light-pen dark-brush light-brush 0 0)]
+          [(parent dark-pen light-pen dark-brush light-brush dx dy)
+           (unless (memf (lambda (parent-link) (eq? (link-snip parent-link) parent)) parent-links)
+             (set! parent-links 
+                   (cons (make-link parent
+                                    (or dark-pen default-dark-pen)
+                                    (or light-pen default-light-pen)
+                                    (or dark-brush default-dark-brush)
+                                    (or light-brush default-light-brush)
+                                    dx 
+                                    dy)
+                         parent-links)))]))
+      (define/public (remove-parent parent) 
+        (when (memf (lambda (parent-link) (eq? (link-snip parent-link) parent)) parent-links)
+          (set! parent-links
+                (remove
+                 parent
+                 parent-links
+                 (lambda (parent parent-link) (eq? (link-snip parent-link) parent))))))
+      
+      (define/public (find-shortest-path other)
+        (define visited-ht (make-hash-table))
+        (define (first-view? n) 
+          (hash-table-get visited-ht n (lambda () 
+                                         (hash-table-put! visited-ht n #f)
+                                         #t)))
+        (let loop ((horizon (list (list this))))
+          (cond
+            [(null? horizon) #f]
+            [(assq other horizon) => (lambda (winner) winner)]
+            [else
+             (let inner-loop ((paths horizon)
+                              (acc '()))
+               (cond
+                 [(null? paths) (loop (apply append acc))]
+                 [else
+                  (let ((path (car paths)))
+                    (inner-loop 
+                     (cdr paths)
+                     (cons 
+                      (map (lambda (child) (cons child path)) (filter first-view? (send (car path) get-children)))
+                      acc)))]))])))
+      
+      (super-instantiate ())
+      
+      (inherit set-snipclass)
+      (set-snipclass snipclass)))
+  
+  (define graph-pasteboard<%>
+    (interface ()
+      on-mouse-over-snips
+      set-arrowhead-params))
+  
+  (define-struct rect (left top right bottom))
+  
+  (define graph-pasteboard-mixin
+    (mixin ((class->interface pasteboard%)) (graph-pasteboard<%>)
+      (inherit find-first-snip find-next-selected-snip)
+    
+      (define arrowhead-angle-width (* 1/4 pi))
+      (define arrowhead-short-side 8)
+      (define arrowhead-long-side 12)
+      
+      (define/public (set-arrowhead-params angle-width long-side short-side)
+        (set! arrowhead-angle-width angle-width)
+        (set! arrowhead-short-side short-side)
+        (set! arrowhead-long-side long-side))
+      (define/public (get-arrowhead-params)
+        (values arrowhead-angle-width
+                arrowhead-long-side
+                arrowhead-short-side))
+    
+      (inherit dc-location-to-editor-location get-canvas)
+      (field (currently-overs null))
+      (define/override (on-event evt)
+        (cond
+          [(send evt leaving?)
+           (change-currently-overs null)
+           (super on-event evt)]
+          [(or (send evt entering?)
+               (send evt moving?))
+           (let ([ex (send evt get-x)]
+                 [ey (send evt get-y)])
+             (let-values ([(x y) (dc-location-to-editor-location ex ey)])
+               (change-currently-overs (find-snips-under-mouse x y))))
+           (super on-event evt)]
+          [else 
+           (super on-event evt)]))
+      
+      (define/augment (on-interactive-move evt)
+        (invalidate-selected-snips)
+        #;(super on-interactive-move evt)
+        )
+      
+      (define/augment (after-interactive-move evt)
+        (invalidate-selected-snips)
+        #;(super on-interactive-move evt))
+      
+      (define/override (interactive-adjust-move snip x y)
+        (invalidate-to-children/parents snip)
+        (super interactive-adjust-move snip x y))
+      
+      (define/augment (after-insert snip before x y)
+        (invalidate-to-children/parents snip)
+        #;(super after-insert snip before x y))
+      
+      ;; invalidate-selected-snips : -> void
+      ;; invalidates the region around the selected
+      ;; snips and their parents and children
+      (define/private (invalidate-selected-snips)
+        (let loop ([snip (find-next-selected-snip #f)])
+          (when snip
+            (invalidate-to-children/parents snip)
+            (loop (find-next-selected-snip snip)))))
+      
+      (define/private (add-to-rect from to rect)
+        (let-values ([(xf yf wf hf) (get-position from)]
+                     [(xt yt wt ht) (get-position to)])
+          (make-rect
+           (if rect 
+               (min xf xt (rect-left rect))
+               (min xf xt))
+           (if rect
+               (min yf yt (rect-top rect))
+               (min yf yt))
+           (if rect
+               (max (+ xf wf) (+ xt wt) (rect-right rect))
+               (max (+ xf wf) (+ xt wt)))
+           (if rect
+               (max (+ yf hf) (+ yt ht) (rect-bottom rect))
+               (max (+ yf hf) (+ yt ht))))))
+      
+      
+      ;; find-snips-under-mouse : num num -> (listof graph-snip<%>)
+      (define/private (find-snips-under-mouse x y)
+        (let loop ([snip (find-first-snip)])
+          (cond
+            [snip
+             (let-values ([(sx sy sw sh) (get-position snip)])
+               (if (and (<= sx x (+ sx sw))
+                        (<= sy y (+ sy sh))
+                        (is-a? snip graph-snip<%>))
+                   (cons snip (loop (send snip next)))
+                   (loop (send snip next))))]
+            [else null])))
+      
+      ;; change-currently-overs : (listof snip) -> void
+      (define/private (change-currently-overs new-currently-overs)
+        (unless (set-equal new-currently-overs currently-overs)
+          (let ([old-currently-overs currently-overs])
+            (set! currently-overs new-currently-overs)
+            
+	    (on-mouse-over-snips currently-overs)
+            (for-each 
+             (lambda (old-currently-over)
+               (invalidate-to-children/parents old-currently-over))
+             old-currently-overs)
+            (for-each
+             (lambda (new-currently-over)
+               (invalidate-to-children/parents new-currently-over))
+             new-currently-overs))))
+
+      (define/public (on-mouse-over-snips snips)
+	(void))
+        
+      ;; set-equal : (listof snip) (listof snip) -> boolean
+      ;; typically lists will be small (length 1),
+      ;; so use andmap/memq rather than hash-tables
+      (define/private (set-equal los1 los2)
+        (and (andmap (lambda (s1) (memq s1 los2)) los1)
+             (andmap (lambda (s2) (memq s2 los1)) los2)
+             #t))
+      
+      ;; invalidate-to-children/parents : snip -> void
+      ;; invalidates the region containing this snip and
+      ;; all of its children and parents.
+      (inherit invalidate-bitmap-cache)
+      (define/private (invalidate-to-children/parents snip)
+        (when (is-a? snip graph-snip<%>)
+          (let* ([parents-and-children (append (get-all-parents snip)
+                                               (get-all-children snip))]
+                 [rects (eliminate-redundancies (get-rectangles snip parents-and-children))]
+                 [union (union-rects rects)]
+                 [invalidate-rect
+                  (lambda (rect)
+                    (invalidate-bitmap-cache (rect-left rect)
+                                             (rect-top rect)
+                                             (- (rect-right rect)
+                                                (rect-left rect))
+                                             (- (rect-bottom rect)
+                                                (rect-top rect))))])
+            (cond
+              [(< (rect-area union)
+                  (apply + (map (lambda (x) (rect-area x)) rects)))
+               (invalidate-rect union)]
+              [else
+               (for-each invalidate-rect rects)]))))
+      
+      ;; (listof rect) -> (listof rect)
+      (define/private (eliminate-redundancies rects)
+        (let loop ([rects rects]
+                   [acc null])
+          (cond
+            [(null? rects) acc]
+            [else (let ([r (car rects)])
+                    (cond
+                      [(or (ormap (lambda (other-rect) (rect-included-in? r other-rect))
+                                  (cdr rects))
+                           (ormap (lambda (other-rect) (rect-included-in? r other-rect))
+                                  acc))
+                       (loop (cdr rects)
+                             acc)]
+                      [else 
+                       (loop (cdr rects) 
+                             (cons r acc))]))])))
+      
+      ;; rect-included-in? : rect rect -> boolean
+      (define/private (rect-included-in? r1 r2)
+        (and ((rect-left r1) . >= . (rect-left r2))
+             ((rect-top r1) . >= . (rect-top r2))
+             ((rect-right r1) . <= . (rect-right r2))
+             ((rect-bottom r1) . <= . (rect-bottom r2))))
+
+      ;; get-rectangles : snip (listof snip) -> rect
+      ;; computes the rectangles that need to be invalidated for connecting 
+      (define/private (get-rectangles main-snip c/p-snips)
+        (let ([main-snip-rect (snip->rect main-snip)])
+          (let loop ([c/p-snips c/p-snips])
+            (cond
+              [(null? c/p-snips) null]
+              [else 
+               (let* ([c/p (car c/p-snips)]
+                      [rect
+                       (if (eq? c/p main-snip)
+                           (let-values ([(sx sy sw sh) (get-position c/p)])
+                             (make-rect (- sx self-offset)
+                                        sy
+                                        (+ (+ sx sw) self-offset)
+                                        (+ (+ sy sh) self-offset)))
+                           (union-rects (list main-snip-rect
+                                              (snip->rect c/p))))])
+                 (cons rect (loop (cdr c/p-snips))))]))))
+
+      (define/private (snip->rect snip)
+        (let-values ([(sx sy sw sh) (get-position snip)])
+          (make-rect sx sy (+ sx sw) (+ sy sh))))
+
+      
+      (define/private (rect-area rect)
+        (* (- (rect-right rect)
+              (rect-left rect))
+           (- (rect-bottom rect)
+              (rect-top rect))))
+      
+      (define/private (union-rects rects)
+        (cond
+          [(null? rects) (make-rect 0 0 0 0)]
+          [else
+           (let loop ([rects (cdr rects)]
+                      [l (rect-left (car rects))]
+                      [t (rect-top (car rects))]
+                      [r (rect-right (car rects))]
+                      [b (rect-bottom (car rects))])
+             (cond
+               [(null? rects) (make-rect l t r b)]
+               [else
+                (let ([rect (car rects)])
+                  (loop (cdr rects)
+                        (min l (rect-left rect))
+                        (min t (rect-top rect))
+                        (max r (rect-right rect))
+                        (max b (rect-bottom rect))))]))]))
+            
+      ;; on-paint : ... -> void
+      ;; see docs, same as super
+      ;; draws all of the lines and then draws all of the arrow heads
+      (define/private (old-on-paint before? dc left top right bottom dx dy draw-caret)
+        (let ()
+          ;; draw-connection : link snip boolean boolean -> void
+          ;; sets the drawing context (pen and brush)
+          ;; determines if the connection is between a snip and itself or two different snips
+          ;;  and calls draw-self-connection or draw-non-self-connection
+          (define (draw-connection from-link to dark-lines?)
+            (let ([from (link-snip from-link)])
+              (when (send from get-admin)
+                (let ([dx (+ dx (link-dx from-link))]
+                      [dy (+ dy (link-dy from-link))])
+                  (cond
+                    [(eq? from to)
+                     (set-pen/brush from-link dark-lines?)
+                     (draw-self-connection dx dy (link-snip from-link))]
+                    [else
+                     (draw-non-self-connection dx dy from-link dark-lines? to)])))))
+          
+          (define (draw-self-connection dx dy snip)
+            (let*-values ([(sx sy sw sh) (get-position snip)]
+                          [(s1x s1y) (values (+ sx sw) (+ sy (* sh 1/2)))]
+                          [(s2x s2y) (values (+ sx sw self-offset) (+ sy (* 3/4 sh) (* 1/2 self-offset)))]
+                          [(s3x s3y) (values (+ sx sw) (+ sy sh self-offset))]
+                          [(b12x b12y) (values s2x s1y)]
+                          [(b23x b23y) (values s2x s3y)]
+                          
+                          [(s4x s4y) (values (- sx arrowhead-short-side)
+                                             (+ sy (* sh 1/2)))]
+                          [(s5x s5y) (values (- sx arrowhead-short-side self-offset)
+                                             (+ sy (* 3/4 sh) (* 1/2 self-offset)))]
+                          [(s6x s6y) (values (- sx arrowhead-short-side)
+                                             (+ sy sh self-offset))]
+                          [(b45x b45y) (values s5x s4y)]
+                          [(b56x b56y) (values s5x s6y)])
+              
+              (update-polygon s4x s4y sx s4y)
+              (send dc draw-spline (+ dx s1x) (+ dy s1y) (+ dx b12x) (+ dy b12y) (+ dx s2x) (+ dy s2y))
+              (send dc draw-spline (+ dx s2x) (+ dy s2y) (+ dx b23x) (+ dy b23y) (+ dx s3x) (+ dy s3y))
+              (send dc draw-line (+ dx s3x) (+ dy s3y) (+ dx s6x) (+ dy s6y))
+              (send dc draw-spline (+ dx s4x) (+ dy s4y) (+ dx b45x) (+ dy b45y) (+ dx s5x) (+ dy s5y))
+              (send dc draw-spline (+ dx s5x) (+ dy s5y) (+ dx b56x) (+ dy b56y) (+ dx s6x) (+ dy s6y))
+              (send dc draw-polygon points dx dy)))
+          
+          (define (draw-non-self-connection dx dy from-link dark-lines? to)
+            (let ([from (link-snip from-link)])
+              (let*-values ([(xf yf wf hf) (get-position from)]
+                            [(xt yt wt ht) (get-position to)]
+                            [(lf tf rf bf) (values xf yf (+ xf wf) (+ yf hf))]
+                            [(lt tt rt bt) (values xt yt (+ xt wt) (+ yt ht))])
+                (let ([x1 (+ xf (/ wf 2))]
+                      [y1 (+ yf (/ hf 2))]
+                      [x2 (+ xt (/ wt 2))]
+                      [y2 (+ yt (/ ht 2))])
+                  
+                  (unless (or (and (x1 . <= . left)
+                                   (x2 . <= . left))
+                              (and (x1 . >= . right)
+                                   (x2 . >= . right))
+                              (and (y1 . <= . top)
+                                   (y2 . <= . top))
+                              (and (y1 . >= . bottom)
+                                   (y2 . >= . bottom)))
+                    (set-pen/brush from-link dark-lines?)
+                    (let-values ([(from-x from-y)
+                                  (or-2v (find-intersection x1 y1 x2 y2 
+                                                            lf tf rf tf)
+                                         (find-intersection x1 y1 x2 y2 
+                                                            lf bf rf bf)
+                                         (find-intersection x1 y1 x2 y2 
+                                                            lf tf lf bf)
+                                         (find-intersection x1 y1 x2 y2 
+                                                            rf tf rf bf))]
+                                 [(to-x to-y)
+                                  (or-2v (find-intersection x1 y1 x2 y2 
+                                                            lt tt rt tt)
+                                         (find-intersection x1 y1 x2 y2 
+                                                            lt bt rt bt)
+                                         (find-intersection x1 y1 x2 y2 
+                                                            lt tt lt bt)
+                                         (find-intersection x1 y1 x2 y2 
+                                                            rt tt rt bt))])
+                      (when (and from-x from-y to-x to-y)
+                        (let ()
+                          (define (arrow-point-ok? point-x point-y)
+                            (and (in-rectangle? point-x point-y
+                                                (min lt rt lf rf) (min tt bt tf bf)
+                                                (max lt rt lf rf) (max tt bt tf bf))
+                                 (not (strict-in-rectangle? point-x point-y 
+                                                            (min lt rt) (min tt bt) 
+                                                            (max lt rt) (max tt bt)))
+                                 (not (strict-in-rectangle? point-x point-y
+                                                            (min lf rf) (min tf bf)
+                                                            (max lf rf) (max tf bf)))))
+                          (cond
+                            [(or (in-rectangle? from-x from-y lt tt rt bt)
+                                 (in-rectangle? to-x to-y lf tf rf bf))
+                             ;; the snips overlap, draw nothing
+                             (void)]
+                            [else
+                             (send dc draw-line
+                                   (+ dx from-x) (+ dy from-y) 
+                                   (+ dx to-x) (+ dy to-y))
+                             (update-polygon from-x from-y to-x to-y)
+                             (when (and (arrow-point-ok? (send point1 get-x) (send point1 get-y))
+                                        (arrow-point-ok? (send point2 get-x) (send point2 get-y))
+                                        (arrow-point-ok? (send point3 get-x) (send point3 get-y))
+                                        (arrow-point-ok? (send point4 get-x) (send point4 get-y)))
+                               ;; the arrowhead is not overlapping the snips, so draw it
+                               ;; (this is only an approximate test, but probably good enough)
+                               (send dc draw-polygon points dx dy))])))))))))
+          
+          (define (set-pen/brush from-link dark-lines?)
+            (send dc set-brush 
+                  (if dark-lines?
+                      (link-dark-brush from-link)
+                      (link-light-brush from-link)))
+            (send dc set-pen
+                  (if dark-lines?
+                      (link-dark-pen from-link)
+                      (link-light-pen from-link))))
+          
+          ;;; body of on-paint
+          (when before?
+            (let ([old-pen (send dc get-pen)]
+                  [old-brush (send dc get-brush)]
+                  [os (send dc get-smoothing)])
+              (send dc set-smoothing 'aligned)
+              
+              (let loop ([snip (find-first-snip)])
+                (when snip
+                  (when (and (send snip get-admin)
+                             (is-a? snip graph-snip<%>))
+                    (for-each (lambda (parent-link)
+                                (draw-connection parent-link snip #f))
+                              (send snip get-parent-links)))
+                  (loop (send snip next))))
+              
+              (for-each
+               (lambda (currently-over)
+                 (for-each
+                  (lambda (child)
+                    (let ([parent-link-f
+                           (memf (lambda (parent-link) (eq? currently-over (link-snip parent-link)))
+                                 (send child get-parent-links))])
+                      (when parent-link-f
+                        (draw-connection (car parent-link-f) child #t))))
+                  (send currently-over get-children))
+                 (for-each
+                  (lambda (parent-link)
+                    (draw-connection parent-link currently-over #t))
+                  (send currently-over get-parent-links)))
+               currently-overs)
+              
+              (send dc set-smoothing os)
+              (send dc set-pen old-pen)
+              (send dc set-brush old-brush)))
+          
+          (super on-paint before? dc left top right bottom dx dy draw-caret)))
+      
+      (define/override (on-paint before? dc left top right bottom dx dy draw-caret)
+        (let ()
+          ;; draw-connection : link snip boolean boolean -> void
+          ;; sets the drawing context (pen and brush)
+          ;; determines if the connection is between a snip and itself or two different snips
+          ;;  and calls draw-self-connection or draw-non-self-connection
+          (define (draw-connection from-link to dark-lines?)
+            (let ([from (link-snip from-link)])
+              (when (send from get-admin)
+                (let ([dx (+ dx (link-dx from-link))]
+                      [dy (+ dy (link-dy from-link))])
+                  (cond
+                    [(eq? from to)
+                     (set-pen/brush from-link dark-lines?)
+                     (draw-self-connection dx dy (link-snip from-link))]
+                    [else
+                     (draw-non-self-connection dx dy from-link dark-lines? to)])))))
+          
+          (define (draw-self-connection dx dy snip)
+            (let*-values ([(sx sy sw sh) (get-position snip)]
+                          [(s1x s1y) (values (+ sx sw) (+ sy (* sh 1/2)))]
+                          [(s2x s2y) (values (+ sx sw self-offset) (+ sy (* 3/4 sh) (* 1/2 self-offset)))]
+                          [(s3x s3y) (values (+ sx sw) (+ sy sh self-offset))]
+                          [(b12x b12y) (values s2x s1y)]
+                          [(b23x b23y) (values s2x s3y)]
+                          
+                          [(s4x s4y) (values (- sx arrowhead-short-side)
+                                             (+ sy (* sh 1/2)))]
+                          [(s5x s5y) (values (- sx arrowhead-short-side self-offset)
+                                             (+ sy (* 3/4 sh) (* 1/2 self-offset)))]
+                          [(s6x s6y) (values (- sx arrowhead-short-side)
+                                             (+ sy sh self-offset))]
+                          [(b45x b45y) (values s5x s4y)]
+                          [(b56x b56y) (values s5x s6y)])
+              
+              (update-polygon s4x s4y sx s4y)
+              (send dc draw-spline (+ dx s1x) (+ dy s1y) (+ dx b12x) (+ dy b12y) (+ dx s2x) (+ dy s2y))
+              (send dc draw-spline (+ dx s2x) (+ dy s2y) (+ dx b23x) (+ dy b23y) (+ dx s3x) (+ dy s3y))
+              (send dc draw-line (+ dx s3x) (+ dy s3y) (+ dx s6x) (+ dy s6y))
+              (send dc draw-spline (+ dx s4x) (+ dy s4y) (+ dx b45x) (+ dy b45y) (+ dx s5x) (+ dy s5y))
+              (send dc draw-spline (+ dx s5x) (+ dy s5y) (+ dx b56x) (+ dy b56y) (+ dx s6x) (+ dy s6y))
+              (send dc draw-polygon points dx dy)))
+          
+          (define (draw-non-self-connection dx dy from-link dark-lines? to)
+            (let ([from (link-snip from-link)])
+              (let*-values ([(xf yf wf hf) (get-position from)]
+                            [(xt yt wt ht) (get-position to)]
+                            [(lf tf rf bf) (values xf yf (+ xf wf) (+ yf hf))]
+                            [(lt tt rt bt) (values xt yt (+ xt wt) (+ yt ht))])
+                (let ([x1 (+ xf (/ wf 2))]
+                      [y1 (+ yf (/ hf 2))]
+                      [x2 (+ xt (/ wt 2))]
+                      [y2 (+ yt (/ ht 2))])
+                  
+                  (set-pen/brush from-link dark-lines?)
+                  (let-values ([(from-x from-y)
+                                (or-2v (find-intersection x1 y1 x2 y2 
+                                                          lf tf rf tf)
+                                       (find-intersection x1 y1 x2 y2 
+                                                          lf bf rf bf)
+                                       (find-intersection x1 y1 x2 y2 
+                                                          lf tf lf bf)
+                                       (find-intersection x1 y1 x2 y2 
+                                                          rf tf rf bf))]
+                               [(to-x to-y)
+                                (or-2v (find-intersection x1 y1 x2 y2 
+                                                          lt tt rt tt)
+                                       (find-intersection x1 y1 x2 y2 
+                                                          lt bt rt bt)
+                                       (find-intersection x1 y1 x2 y2 
+                                                          lt tt lt bt)
+                                       (find-intersection x1 y1 x2 y2 
+                                                          rt tt rt bt))])
+                    (when (and from-x from-y to-x to-y)
+                      (let ()
+                        (define (arrow-point-ok? point-x point-y)
+                          (and (in-rectangle? point-x point-y
+                                              (min lt rt lf rf) (min tt bt tf bf)
+                                              (max lt rt lf rf) (max tt bt tf bf))
+                               (not (strict-in-rectangle? point-x point-y 
+                                                          (min lt rt) (min tt bt) 
+                                                          (max lt rt) (max tt bt)))
+                               (not (strict-in-rectangle? point-x point-y
+                                                          (min lf rf) (min tf bf)
+                                                          (max lf rf) (max tf bf)))))
+                        (cond
+                          [(or (in-rectangle? from-x from-y lt tt rt bt)
+                               (in-rectangle? to-x to-y lf tf rf bf))
+                           ;; the snips overlap, draw nothing
+                           (void)]
+                          [else
+                           (send dc draw-line
+                                 (+ dx from-x) (+ dy from-y) 
+                                 (+ dx to-x) (+ dy to-y))
+                           (update-polygon from-x from-y to-x to-y)
+                           (when (and (arrow-point-ok? (send point1 get-x) (send point1 get-y))
+                                      (arrow-point-ok? (send point2 get-x) (send point2 get-y))
+                                      (arrow-point-ok? (send point3 get-x) (send point3 get-y))
+                                      (arrow-point-ok? (send point4 get-x) (send point4 get-y)))
+                             ;; the arrowhead is not overlapping the snips, so draw it
+                             ;; (this is only an approximate test, but probably good enough)
+                             (send dc draw-polygon points dx dy))]))))))))
+          
+          (define (set-pen/brush from-link dark-lines?)
+            (send dc set-brush 
+                  (if dark-lines?
+                      (link-dark-brush from-link)
+                      (link-light-brush from-link)))
+            (send dc set-pen
+                  (if dark-lines?
+                      (link-dark-pen from-link)
+                      (link-light-pen from-link))))
+          
+          ;;; body of on-paint
+          (when before?
+            (let ([old-pen (send dc get-pen)]
+                  [old-brush (send dc get-brush)]
+                  [os (send dc get-smoothing)])
+              (send dc set-smoothing 'aligned)
+              
+              (let ([pairs '()])
+                (for-each-to-redraw 
+                 left top right bottom 
+                 (lambda (from-link to)
+                   (let ([from (link-snip from-link)])
+                     (cond
+                       [(or (memq from currently-overs)
+                            (memq to currently-overs))
+                        (set! pairs (cons (cons from-link to) pairs))]
+                       [else
+                        (draw-connection from-link to #f)]))))
+                (for-each (lambda (pr)
+                            (draw-connection (car pr) (cdr pr) #t))
+                          pairs))
+              
+              (send dc set-smoothing os)
+              (send dc set-pen old-pen)
+              (send dc set-brush old-brush)))
+          
+          (super on-paint before? dc left top right bottom dx dy draw-caret)))
+      
+        ;; for-each-to-redraw : number number number number (link snip -> void)
+      (define/private (for-each-to-redraw left top right bottom f)
+        (let ()
+          ;; draw-connection : link snip boolean boolean -> void
+          ;; sets the drawing context (pen and brush)
+          ;; determines if the connection is between a snip and itself or two different snips
+          ;;  and calls draw-self-connection or draw-non-self-connection
+          (define (maybe-call-f from-link to)
+            (let ([from (link-snip from-link)])
+              (when (send from get-admin)
+                (cond
+                  [(eq? from to)
+                   (f from-link to)]
+                  [else
+                   (let*-values ([(xf yf wf hf) (get-position from)]
+                                 [(xt yt wt ht) (get-position to)]
+                                 [(lf tf rf bf) (values xf yf (+ xf wf) (+ yf hf))]
+                                 [(lt tt rt bt) (values xt yt (+ xt wt) (+ yt ht))])
+                     (let ([x1 (+ xf (/ wf 2))]
+                           [y1 (+ yf (/ hf 2))]
+                           [x2 (+ xt (/ wt 2))]
+                           [y2 (+ yt (/ ht 2))])
+                       
+                       (unless (or (and (x1 . <= . left)
+                                        (x2 . <= . left))
+                                   (and (x1 . >= . right)
+                                        (x2 . >= . right))
+                                   (and (y1 . <= . top)
+                                        (y2 . <= . top))
+                                   (and (y1 . >= . bottom)
+                                        (y2 . >= . bottom)))
+                         (f from-link to))))]))))
+          
+          (let loop ([snip (find-first-snip)])
+            (when snip
+              (when (and (send snip get-admin)
+                         (is-a? snip graph-snip<%>))
+                (for-each (lambda (parent-link) (maybe-call-f parent-link snip))
+                          (send snip get-parent-links)))
+              (loop (send snip next))))))
+      
+      
+      (field 
+       [point1 (make-object point% 0 0)]
+       [point2 (make-object point% 0 0)]
+       [point3 (make-object point% 0 0)]
+       [point4 (make-object point% 0 0)]
+       [points (list point1 point2 point3 point4)])
+      
+      ;; update-polygon : number^4 -> void
+      ;; updates points1, 2, and 3 with the arrow head's
+      ;; points. Use a turtle-like movement to find the points.
+      ;; point3 is the point where the line should end.
+      (define/private (update-polygon from-x from-y to-x to-y)
+        (define (move tx ty ta d) (values (+ tx (* d (cos ta)))
+                                          (+ ty (* d (sin ta)))
+                                          ta))
+        (define (turn tx ty ta a) (values tx
+                                          ty
+                                          (+ ta a)))
+        (define init-angle 
+          (cond
+            [(and (from-x . = . to-x)
+                  (from-y . < . to-y))
+             (* pi 3/2)]
+            [(from-x . = . to-x)
+             (* pi 1/2)]
+            [(from-x . < . to-x)
+             (+ pi (atan (/ (- from-y to-y) (- from-x to-x))))]
+            [else
+             (atan (/ (- from-y to-y) (- from-x to-x)))]))
+        (let*-values ([(t1x t1y t1a) (values to-x to-y init-angle)]
+                      [(t2x t2y t2a) (turn t1x t1y t1a (/ arrowhead-angle-width 2))]
+                      [(t3x t3y t3a) (move t2x t2y t2a arrowhead-long-side)]
+                      [(t4x t4y t4a) (turn t1x t1y t1a (- (/ arrowhead-angle-width 2)))]
+                      [(t5x t5y t5a) (move t4x t4y t4a arrowhead-long-side)]
+                      [(t6x t6y t6a) (move t1x t1y t1a arrowhead-short-side)])
+          (send point1 set-x t1x)
+          (send point1 set-y t1y)
+          (send point2 set-x t3x)
+          (send point2 set-y t3y)
+          (send point3 set-x t6x)
+          (send point3 set-y t6y)
+          (send point4 set-x t5x)
+          (send point4 set-y t5y)))
+      
+      (define/private (should-hilite? snip)
+        (let ([check-one-way
+               (lambda (way)
+                 (let loop ([snip snip])
+                   (or (memq snip currently-overs)
+                       (and (is-a? snip graph-snip<%>)
+                            (loop (car (way snip)))))))])
+          (or (check-one-way (lambda (snip) (send snip get-children)))
+              (check-one-way (lambda (snip) (send snip get-parents))))))
+      
+      (inherit get-snip-location)
+      (field [lb (box 0)]
+             [tb (box 0)]
+             [rb (box 0)]
+             [bb (box 0)])
+      (define/private (get-position snip)
+        (get-snip-location snip lb tb #f)
+        (get-snip-location snip rb bb #t)
+        (values (unbox lb)
+                (unbox tb)
+                (- (unbox rb) (unbox lb))
+                (- (unbox bb) (unbox tb))))
+      
+      (super-new)))
+  
+  ;; in-rectangle? : number^2 number^2 number^2 -> boolean
+  ;; determines if (x,y) is in the rectangle described
+  ;; by (p1x,p1y) and (p2x,p2y).
+  (define (in-rectangle? x y p1x p1y p2x p2y)
+    (and (<= (min p1x p2x) x (max p1x p2x))
+         (<= (min p1y p2y) y (max p1y p2y))))
+  
+  ;; strict-in-rectangle? : number^2 number^2 number^2 -> boolean
+  ;; determines if (x,y) is in the rectangle described
+  ;; by (p1x,p1y) and (p2x,p2y), but not on the border
+  (define (strict-in-rectangle? x y p1x p1y p2x p2y)
+    (and (< (min p1x p2x) x (max p1x p2x))
+         (< (min p1y p2y) y (max p1y p2y))))
+  
+  ;; find-intersection : number^8 -> (values (union #f number) (union #f number))
+  ;; calculates the intersection between two line segments, 
+  ;; described as pairs of points. Returns #f if they do not intersect
+  (define (find-intersection x1 y1 x2 y2 x3 y3 x4 y4)
+    (let-values ([(m1 b1) (find-mb x1 y1 x2 y2)]
+                 [(m2 b2) (find-mb x3 y3 x4 y4)])
+      (let-values ([(int-x int-y)
+                    (cond
+                      [(and m1 m2 b1 b2
+                            (= m1 0)
+                            (= m2 0))
+                       (values #f #f)]
+                      [(and m1 m2 b1 b2
+                            (= m1 0))
+                       (let* ([y y1]
+                              [x (/ (- y b2) m2)])
+                         (values x y))]
+                      [(and m1 m2 b1 b2
+                            (= m2 0))
+                       (let* ([y y3]
+                              [x (/ (- y b1) m1)])
+                         (values x y))]
+                      [(and m1 m2 b1 b2
+                            (not (= m1 m2)))
+                       (let* ([y (/ (- b2 b1) (- m1 m2))]
+                              [x (/ (- y b1) m1)])
+                         (values x y))]
+                      [(and m1 b1)
+                       (let* ([x x3]
+                              [y (+ (* m1 x) b1)])
+                         (values x y))]
+                      [(and m2 b2)
+                       (let* ([x x1]
+                              [y (+ (* m2 x) b2)])
+                         (values x y))]
+                      [else 
+                       (values #f #f)])])
+        
+        (if (and int-x
+                 int-y
+                 (<= (min x1 x2) int-x (max x1 x2))
+                 (<= (min y1 y2) int-y (max y1 y2))
+                 (<= (min x3 x4) int-x (max x3 x4))
+                 (<= (min y3 y4) int-y (max y3 y4)))
+            (values int-x int-y)
+            (values #f #f)))))
+  
+  ;; find-mb : number number number number -> (values (union #f number) (union #f number))
+  ;; finds the "m" and "b" constants that describe the
+  ;; lines from (x1, y1) to (x2, y2)
+  (define (find-mb x1 y1 x2 y2)
+    (if (= x1 x2)
+        (values #f #f)
+        (let-values ([(xl yl xr yr)
+                      (if (x1 . <= . x2)
+                          (values x1 y1 x2 y2)
+                          (values x2 y2 x1 y1))])
+          (let* ([m (/ (- yr yl) (- xr xl))]
+                 [b (- y1 (* m x1))])
+            (values m b)))))
+  
+  ;; get-all-relatives : (snip -> (listof snip)) snip -> (listof snip)
+  ;; returns all editor-snip relatives (of a particular sort), including
+  ;; any regular snip relatives along the way.
+  (define (get-all-relatives get-relatives snip)
+    (let loop ([flat-relatives (get-relatives snip)]
+               [relatives null])
+      (cond
+        [(null? flat-relatives) relatives]
+        [else
+         (let i-loop ([dummy (car flat-relatives)]
+                      [acc relatives])
+           (cond
+             [(is-a? dummy graph-snip<%>)
+              (loop (cdr flat-relatives) (cons dummy acc))]
+             [else
+              (i-loop (car (get-relatives dummy))
+                      (cons dummy acc))]))])))
+  
+  ;; get-all-children : snip -> (listof snip)
+  (define (get-all-children snip)
+    (get-all-relatives (lambda (snip) (send snip get-children)) snip))
+  
+  ;; get-all-parents : snip -> (listof snip)
+  (define (get-all-parents snip)
+    (get-all-relatives (lambda (snip) (send snip get-parents)) snip)))
+  
diff --git a/collects/mrlib/include-bitmap.ss b/collects/mrlib/include-bitmap.ss
new file mode 100644
index 0000000000..6b7d07f3e2
--- /dev/null
+++ b/collects/mrlib/include-bitmap.ss
@@ -0,0 +1,64 @@
+(module include-bitmap mzscheme
+  (require (lib "mred.ss" "mred")
+	   (lib "class.ss")
+	   (lib "file.ss"))
+  (require-for-syntax (lib "path-spec.ss" "syntax")
+		      (lib "cm-accomplice.ss"))
+
+  (provide include-bitmap
+           include-bitmap/relative-to)
+  
+  (define-syntax (-include-bitmap stx)
+    (syntax-case stx ()
+      [(_ orig-stx source path-spec)
+       (let* ([c-file (resolve-path-spec #'path-spec #'source #'orig-stx #'build-path)]
+	      [content
+	       (with-handlers ([exn:fail?
+				(lambda (exn)
+				  (error 'include-bitmap
+					 "could not load ~e: ~a"
+					 c-file
+					 (if (exn? exn)
+					     (exn-message exn)
+					     (format "~e" exn))))])
+		 (with-input-from-file c-file
+		   (lambda ()
+		     (read-bytes (file-size c-file)))))])
+	 (register-external-file c-file)
+	 (with-syntax ([content content]
+		       [c-file (path->bytes c-file)])
+	   (syntax/loc stx
+	     (get-or-load-bitmap content c-file))))]))
+
+  (define-syntax (include-bitmap/relative-to stx)
+    (syntax-case stx ()
+      [(_ source path-spec) #`(-include-bitmap #,stx source path-spec)]))
+
+  (define-syntax (include-bitmap stx)
+    (syntax-case stx ()
+      [(_ path-spec) #`(-include-bitmap #,stx #,stx path-spec)]))
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; Run-time support
+
+  (define cached (make-hash-table 'equal))
+
+  (define (get-or-load-bitmap content orig)
+    (hash-table-get cached content
+		    (lambda ()
+		      (let ([bm (let ([fn (make-temporary-file)])
+				  (dynamic-wind
+				      void
+				      (lambda ()
+					(with-output-to-file fn
+					  (lambda () (display content))
+					  'truncate)
+					(make-object bitmap% fn 'unknown/mask))
+				      (lambda ()
+					(delete-file fn))))])
+			(unless (send bm ok?)
+			  (error 'include-bitmap
+				 "unable to parse image, originated from: ~a"
+				 (path->string (bytes->path orig))))
+			(hash-table-put! cached content bm)
+			bm)))))
diff --git a/collects/mrlib/info.ss b/collects/mrlib/info.ss
new file mode 100644
index 0000000000..776a4c0cd9
--- /dev/null
+++ b/collects/mrlib/info.ss
@@ -0,0 +1,4 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "MrLib")
+  (define doc.txt "doc.txt"))
+
diff --git a/collects/mrlib/interactive-value-port.ss b/collects/mrlib/interactive-value-port.ss
new file mode 100644
index 0000000000..1808171ce2
--- /dev/null
+++ b/collects/mrlib/interactive-value-port.ss
@@ -0,0 +1,67 @@
+
+(module interactive-value-port mzscheme
+  (require (lib "pretty.ss")
+           (lib "mred.ss" "mred")
+           (lib "class.ss")
+           "syntax-browser.ss")
+  (provide set-interactive-display-handler
+           set-interactive-write-handler
+           set-interactive-print-handler)
+
+  (define op (current-output-port))
+  (define (oprintf . x) (apply fprintf op x))
+  
+  (define (set-interactive-display-handler port)
+    (let ([original-port-display-handler (port-display-handler port)])
+      (port-display-handler
+       port
+       (λ (val port)
+         (cond
+           [(string? val) (original-port-display-handler val port)]
+           [else
+            (do-printing pretty-display val port)])))))
+  
+  (define (set-interactive-write-handler port)
+    (port-write-handler
+     port
+     (λ (val port)
+       (do-printing pretty-print val port))))
+  
+  (define (set-interactive-print-handler port)
+    (port-print-handler
+     port
+     (λ (val port)
+       (do-printing pretty-print val port))))
+            
+  (define (use-number-snip? x)
+    (and #f
+         (number? x)
+         (exact? x)
+         (real? x)
+         (not (integer? x))))
+  
+  (define (do-printing pretty value port)
+    (parameterize ([pretty-print-columns 'infinity]
+                   [pretty-print-size-hook
+                    (λ (value display? port)
+                      (cond
+                        [(is-a? value snip%) 1]
+                        ;[(use-number-snip? value) 1]
+                        [(syntax? value) 1]
+                        [else #f]))]
+                   [pretty-print-print-hook
+                    (λ (value display? port)
+                      (cond
+                        [(is-a? value snip%)
+                         (write-special value port)
+                         1]
+                        #;
+                        [(use-number-snip? value)
+                         (write-special
+                          (number-snip:make-repeating-decimal-snip value #f)
+                          port)
+                         1]
+                        [(syntax? value)
+                         (write-special (render-syntax/snip value))]
+                        [else (void)]))])
+      (pretty value port))))
diff --git a/collects/mrlib/name-message.ss b/collects/mrlib/name-message.ss
new file mode 100644
index 0000000000..81a3c91b96
--- /dev/null
+++ b/collects/mrlib/name-message.ss
@@ -0,0 +1,258 @@
+
+(module name-message mzscheme
+  (require (lib "string-constant.ss" "string-constants")
+           (lib "class.ss")
+           (lib "file.ss")
+           (lib "list.ss")
+           (lib "mred.ss" "mred")
+           (lib "contract.ss"))
+  
+  ;; min-w, min-h : number -> contract
+  ;; determines if the widths and heights are suitable
+  (define (min-w h) (flat-named-contract "draw-button-label-width" (lambda (w) (w . > . (- h (* 2 border-inset))))))
+  (define (min-h w) (flat-named-contract "draw-button-label-height" (lambda (h) (h . > . (* 2 border-inset)))))
+  
+  (provide/contract
+   (pad-xywh (number? number? (>=/c 0) (>=/c 0) . -> . (values number? number? (>=/c 0) (>=/c 0))))
+   (draw-button-label
+    (->r ([dc (is-a?/c dc<%>)]
+          [label (union false/c string?)]
+          [x number?]
+          [y number?]
+          [w (and/c number? (min-w h))]
+          [h (and/c number? (min-h w))]
+          [mouse-over? boolean?]
+          [grabbed? boolean?])
+         void?))
+
+   (calc-button-min-sizes
+    (->*
+     ((is-a?/c dc<%>) string?)
+     (number? number?))))
+  
+  (provide name-message%)
+  
+  (define name-message%
+    (class canvas% 
+      (inherit popup-menu get-dc get-size get-client-size min-width min-height
+               stretchable-width stretchable-height
+               get-top-level-window refresh)
+      
+      (define paths #f)
+      
+      ;; label : string
+      (init-field [label (string-constant untitled)])
+      
+      (define full-name-window #f)
+      
+      (define mouse-grabbed? #f)
+      (define mouse-over? #f)
+
+      (define/public (on-choose-directory dir)
+        (void))
+            
+      ;; set-message : boolean (union #f path string) -> void
+      ;; if file-name? is #t, path-name should be a path (or #f)
+      ;; if file-name? is #f, path-name should be a string (or #f)
+      (define/public (set-message file-name? path-name)
+        (set! paths (if (and file-name? 
+                             path-name 
+                             (file-exists? path-name))
+                        (map path->string (explode-path (normalize-path path-name)))
+                        #f))
+        (let ([new-label (cond
+                           [(and paths (not (null? paths)))
+                            (car (last-pair paths))]
+                           [path-name path-name]
+                           [else (string-constant untitled)])])
+          (unless (equal? label new-label)
+            (set! label new-label)
+            (update-min-sizes)
+            (refresh))))
+
+      (define/public (fill-popup menu reset)
+	(if (and paths (not (null? paths)))
+	    (let loop ([paths (cdr (reverse paths))])
+	      (cond
+	       [(null? paths) (void)]
+	       [else 
+		(make-object menu-item% (car paths) menu
+			     (lambda (evt item)
+			       (reset)
+			       (on-choose-directory (apply build-path (reverse paths)))))
+		(loop (cdr paths))]))
+	    (let ([i (make-object menu-item% 
+				  (string-constant no-full-name-since-not-saved)
+				  menu void)])
+	      (send i enable #f))))
+	
+      (define/override (on-event evt)
+	(let-values ([(max-x max-y) (get-size)])
+	  (let ([inside? (and (not (send evt leaving?))
+			      (<= 0 (send evt get-x) max-x)
+			      (<= 0 (send evt get-y) max-y))])
+	    (unless (eq? inside? mouse-over?)
+	      (set! mouse-over? inside?)
+	      (refresh))))
+	
+	(cond
+	 [(send evt button-down?)
+	  (let-values ([(width height) (get-size)]
+		       [(reset) (lambda ()
+				  (set! mouse-grabbed? #f)
+				  (set! mouse-over? #f)
+				  (refresh))])
+	    (set! mouse-over? #t)
+	    (set! mouse-grabbed? #t)
+	    (let ([menu (make-object popup-menu% #f
+				     (lambda x
+				       (reset)))])
+	      (fill-popup menu reset)
+	      
+	      ;; Refresh the screen (wait for repaint)
+	      (set! paint-sema (make-semaphore))
+	      (refresh) 
+	      (yield paint-sema)
+	      (set! paint-sema #f)
+
+	      ;; Popup menu
+	      (popup-menu menu
+			  0
+			  height)))]))
+
+      (define paint-sema #f)
+      
+      (inherit get-parent)
+      (define/private (update-min-sizes)
+        (let-values ([(w h) (calc-button-min-sizes (get-dc) label)])
+          (min-width w)
+          (min-height h)
+          (send (get-parent) reflow-container)))
+      
+      (define/override (on-paint)
+	(when paint-sema
+	  (semaphore-post paint-sema))
+        (let ([dc (get-dc)])
+          (let-values ([(w h) (get-client-size)])
+            (when (and (> w 5) (> h 5))
+              (draw-button-label dc label 0 0 w h mouse-over? mouse-grabbed?)))))
+      
+      (super-new [style '(transparent)])
+      (update-min-sizes)
+      (stretchable-width #f)
+      (stretchable-height #f)))
+  
+  (define button-label-font small-control-font)
+  
+  (define button-label-inset 1)
+  (define black-color (make-object color% "BLACK"))
+  
+  (define triangle-width 10)
+  (define triangle-height 14)
+  (define triangle-color (make-object color% 50 50 50))
+  
+  (define border-inset 1)
+  (define triangle-space 0)
+  (define circle-spacer 4)
+  (define rrect-spacer 3)
+  
+  (define (offset-color color offset-one)
+    (make-object color%
+      (offset-one (send color red))
+      (offset-one (send color green))
+      (offset-one (send color blue))))
+  
+  (define mouse-over-color (case (system-type)
+			     [(macosx) "darkgray"]
+			     [else (make-object color% 230 230 230)]))
+  (define mouse-grabbed-color (make-object color% 100 100 100))
+  (define grabbed-fg-color (make-object color% 220 220 220))
+  
+  (define (calc-button-min-sizes dc label)
+    (let-values ([(w h a d) (send dc get-text-extent label button-label-font)])
+      (let-values ([(px py pw ph) (pad-xywh 0 0 w h)])
+        (values pw ph))))
+  
+  (define (pad-xywh tx ty tw th)
+    (let* ([ans-h
+            (+ button-label-inset
+               (max 0 
+                    (+ 2 (inexact->exact (ceiling th)))
+                    (+ 2 triangle-height))
+               button-label-inset)]
+           [ans-w
+            (max
+             (+ ans-h ans-h)
+             (+ circle-spacer
+                button-label-inset
+                1 ;; becuase "(define ...)" has the wrong size under windows
+                (max 0 (inexact->exact (ceiling tw)))
+                triangle-space
+                triangle-width
+                circle-spacer 
+                button-label-inset))])
+      (values 
+       (- tx (quotient (- ans-w tw) 2))
+       (- ty (quotient (- ans-h th) 2))
+       ans-w
+       ans-h)))
+  
+  (define (draw-button-label dc label dx dy w h mouse-over? grabbed?)
+    (when (or mouse-over? grabbed?)
+      (let ([color (if grabbed?
+		       mouse-grabbed-color
+		       mouse-over-color)]
+	    [xh (- h (* 2 border-inset))])
+	(case (system-type)
+	  [(macosx)
+           (send dc set-pen (send the-pen-list find-or-create-pen color 1 'solid))
+           (send dc set-brush (send the-brush-list find-or-create-brush color 'solid))
+           
+           (let ([old-smooth (send dc get-smoothing)])
+             (send dc set-smoothing 'aligned)
+             (send dc draw-ellipse (+ dx border-inset) (+ dy border-inset) xh xh)
+             (send dc draw-ellipse (+ dx (- w xh)) (+ dy border-inset) xh xh)
+             (send dc set-smoothing old-smooth))
+           
+           (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent))
+           (send dc draw-rectangle (+ dx (quotient xh 2)) (+ dy border-inset) (- w xh) xh)
+           (send dc set-pen (send the-pen-list find-or-create-pen color 1 'solid))
+           (send dc draw-line 
+                 (+ dx (quotient xh 2))
+                 (+ dy border-inset)
+                 (+ dx (- w (quotient xh 2)))
+                 (+ dy border-inset))
+           (send dc draw-line 
+                 (+ dx (quotient xh 2))
+                 (+ dy (- h 1 border-inset))
+                 (+ dx (- w (quotient xh 2)))
+                 (+ dy (- h 1 border-inset)))]
+	  [else
+	   (send dc set-pen (send the-pen-list find-or-create-pen triangle-color 1 'solid))
+	   (send dc set-brush (send the-brush-list find-or-create-brush color 'solid))
+	   (send dc draw-rounded-rectangle (+ dx rrect-spacer) (+ dy border-inset) (- w border-inset rrect-spacer) xh 2)])))
+    
+    (when label
+      (send dc set-text-foreground (if grabbed? grabbed-fg-color black-color))
+      (send dc set-font button-label-font)
+      (let-values ([(tw th _1 _2) (send dc get-text-extent label)])
+        (send dc draw-text label
+              (+ dx (+ circle-spacer button-label-inset))
+              (+ dy (- (/ h 2) (/ th 2)))
+	      #t)))
+
+    (send dc set-pen (send the-pen-list find-or-create-pen 
+			   (if grabbed? grabbed-fg-color triangle-color)
+			   1 'solid))
+    (let ([x (- w triangle-width circle-spacer)]
+	  [y (- (/ h 2) (/ triangle-height 2))])
+      (let loop ([x-off 0][off-y 5])
+	(unless (= 5 x-off)
+	  (send dc draw-line 
+		(+ dx (+ x 1 x-off))
+                (+ dy (+ y off-y))
+		(+ dx (+ x (- triangle-width 1 x-off)))
+                (+ dy (+ y off-y)))
+	  (loop (+ x-off 1) (+ off-y 1)))))
+
+    (void)))
diff --git a/collects/mrlib/plot.ss b/collects/mrlib/plot.ss
new file mode 100644
index 0000000000..379c6c4268
--- /dev/null
+++ b/collects/mrlib/plot.ss
@@ -0,0 +1,178 @@
+(module plot mzscheme
+  (require (lib "mred.ss" "mred")
+           (lib "class.ss")
+           (lib "contract.ss"))
+
+  
+  (define-struct data-set (points connected? pen min-x max-x min-y max-y))
+  
+  (define-struct plot-setup (axis-label-font axis-number-font axis-pen grid? grid-pen
+                             x-axis-marking y-axis-marking x-axis-label y-axis-label))
+
+  (provide/contract
+   (struct data-set ((points (listof (is-a?/c point%)))
+                     (connected? any/c)
+                     (pen (is-a?/c pen%))
+                     (min-x number?)
+                     (max-x number?)
+                     (min-y number?)
+                     (max-y number?)))
+   (struct plot-setup ((axis-label-font (is-a?/c font%))
+                       (axis-number-font (is-a?/c font%))
+                       (axis-pen (is-a?/c pen%))
+                       (grid? any/c)
+                       (grid-pen (is-a?/c pen%))
+                       (x-axis-marking (listof number?))
+                       (y-axis-marking (listof number?))
+                       (x-axis-label string?)
+                       (y-axis-label string?)))
+   (plot ((is-a?/c dc<%>) (listof data-set?) plot-setup? . -> . void?)))
+
+  (define (draw-text-sideways dc text x y font big-chars? offset)
+    (let-values (((width height bot-dist top-dist)
+                  (send (make-object bitmap-dc% (make-object bitmap% 1 1 #f))
+                        get-text-extent text font big-chars? offset)))
+      (let* ((width (inexact->exact (ceiling width)))
+             (height (inexact->exact (ceiling (+ height bot-dist top-dist))))
+             (bc (make-object bitmap-dc% (make-object bitmap% width height #f)))
+             (new-bc (make-object bitmap-dc% (make-object bitmap% height width #f)))
+             (c (make-object color%)))
+        (send bc set-font font)
+        (send bc clear)
+        (send new-bc clear)
+        (send bc draw-text text 0 0 big-chars? offset)
+        (let loop ((i 0)
+                   (j 0))
+          (cond
+            ((>= i (+ height top-dist bot-dist))
+             (send dc draw-bitmap (send new-bc get-bitmap) x y))
+            ((>= j width) (loop (add1 i) 0))
+            (else
+             (send bc get-pixel j i c)
+             (send new-bc set-pixel i (- width j) c)
+             (loop i (add1 j))))))))
+  
+  
+  
+  #cs
+  (define (plot dc data-sets ps)
+    (let-values (((canvas-width canvas-height) (send dc get-size))
+                 ((_ label-height label-bottom-dist label-top-dist)
+                  (send dc get-text-extent "" (plot-setup-axis-label-font ps) #f 0))
+                 ((number-width number-height number-bottom-dist number-top-dist)
+                  (send dc get-text-extent "00.00e-10" (plot-setup-axis-number-font ps) #f 0)))
+      (let* ((label-height (+ label-height label-bottom-dist label-top-dist))
+             (number-height (+ number-height number-bottom-dist number-top-dist))
+             (bottom-space (+ (* 1.5 number-height) label-height))
+             (side-space (+ number-width (* .5 number-height) label-height)))
+        (cond
+          ((not (null? data-sets))
+           (let* ((mx (apply min (map data-set-min-x data-sets)))
+                  (my (apply min (map data-set-min-y data-sets)))
+                  (Mx (apply max (map data-set-max-x data-sets)))
+                  (My (apply max (map data-set-max-y data-sets)))
+                  (w-scale (/ (- canvas-width side-space) (- Mx mx)))
+                  (h-scale (/ (- canvas-height bottom-space) (- my My)))
+                  (transform-point
+                   (lambda (p)
+                     (make-object point%
+                       (+ side-space (* (- (send p get-x) mx) w-scale))
+                       (* (- (send p get-y) My) h-scale)))))
+             
+             ;; Draw axes
+             (send dc set-pen (plot-setup-axis-pen ps))
+             (send dc draw-lines
+                   (map transform-point 
+                        (list (make-object point% mx my)
+                              (make-object point% Mx my))))
+             (send dc draw-lines
+                   (map transform-point 
+                        (list (make-object point% mx my)
+                              (make-object point% mx My))))
+             
+             ;; draw axis markings
+             (send dc set-font (plot-setup-axis-number-font ps))
+             (for-each 
+              (lambda (x)
+                (let* ((p (transform-point (make-object point% x my)))
+                       (draw-x (send p get-x))
+                       (draw-y-start (+ (send p get-y) (* .5 number-height)))
+                       (draw-y-stop (- (send p get-y) (* .5 number-height)))
+                       (str (number->string x)))
+                  (send dc draw-line draw-x draw-y-start draw-x draw-y-stop)
+                  (let-values (((number-width x1 x2 x3)
+                                (send dc get-text-extent
+                                      str (plot-setup-axis-number-font ps) #f 0)))
+                    (let ((start-x (- draw-x (* .5 number-width))))
+                      (send dc draw-text str start-x (+ 2 draw-y-start))))))
+              (plot-setup-x-axis-marking ps))
+             (for-each 
+              (lambda (y)
+                (let* ((p (transform-point (make-object point% mx y)))
+                       (draw-y (send p get-y))
+                       (draw-x-start (- (send p get-x) (* .5 number-height)))
+                       (draw-x-stop (+ (send p get-x) (* .5 number-height)))
+                       (str (number->string y)))
+                  (send dc draw-line draw-x-start draw-y draw-x-stop draw-y)
+                  (let-values (((number-width x1 x2 x3)
+                                (send dc get-text-extent
+                                      str (plot-setup-axis-number-font ps) #f 0)))
+                    (let ((start-x (- draw-x-start 2 number-width))
+                          (start-y (- draw-y (* .5 number-height))))
+                      (send dc draw-text str start-x start-y)))))
+              (plot-setup-y-axis-marking ps))
+             
+             ;; draw axis labels
+             (send dc set-font (plot-setup-axis-label-font ps))
+             (let-values (((x-label-width x1 x2 x3)
+                           (send dc get-text-extent
+                                 (plot-setup-x-axis-label ps)
+                                 (plot-setup-axis-label-font ps) #f 0)))
+               (send dc draw-text
+                     (plot-setup-x-axis-label ps)
+                     (- (+ side-space (* .5 (- canvas-width side-space))) (* .5 x-label-width))
+                     (- canvas-height label-height)))
+             (let-values (((y-label-width y1 y2 y3)
+                           (send dc get-text-extent
+                                 (plot-setup-y-axis-label ps)
+                                 (plot-setup-axis-label-font ps) #f 0)))
+               (draw-text-sideways dc (plot-setup-y-axis-label ps)
+                                   0
+                                   (- (* .5 (- canvas-height bottom-space))
+                                      (* .5 y-label-width))
+                                   (plot-setup-axis-label-font ps)
+                                   #f
+                                   0))
+             
+             ;; draw-grid
+             (cond
+               ((plot-setup-grid? ps)
+                (send dc set-pen (plot-setup-grid-pen ps))
+                (for-each (lambda (x)
+                            (send dc draw-lines
+                                  (map transform-point
+                                       (list (make-object point% x my)
+                                             (make-object point% x My)))))
+                          (plot-setup-x-axis-marking ps))
+                (for-each (lambda (y)
+                            (send dc draw-lines
+                                  (map transform-point
+                                       (list (make-object point% mx y)
+                                             (make-object point% Mx y)))))
+                          (plot-setup-y-axis-marking ps))))
+             
+             ;; draw data
+             (for-each
+              (lambda (data)
+                (send dc set-pen (data-set-pen data))
+                (cond
+                  ((data-set-connected? data)
+                   (send dc draw-lines (map transform-point (data-set-points data))))
+                  (else
+                   (for-each
+                    (lambda (p)
+                      (let ((tp (transform-point p)))
+                        (send dc draw-point (send tp get-x) (send tp get-y))))
+                    (data-set-points data)))))
+              data-sets)))))))
+  )
\ No newline at end of file
diff --git a/collects/mrlib/private/aligned-pasteboard/aligned-editor-container.ss b/collects/mrlib/private/aligned-pasteboard/aligned-editor-container.ss
new file mode 100644
index 0000000000..e813d4f31a
--- /dev/null
+++ b/collects/mrlib/private/aligned-pasteboard/aligned-editor-container.ss
@@ -0,0 +1,193 @@
+(module aligned-editor-container mzscheme
+  
+  (require
+   (lib "class.ss")
+   (lib "mred.ss" "mred")
+   (lib "etc.ss")
+   (lib "list.ss")
+   "snip-lib.ss"
+   "interface.ss"
+   "constants.ss")
+  
+  (provide
+   aligned-editor-canvas%
+   aligned-editor-snip%)
+  
+  ;; a canvas that can contain an aligned-pasteboard<%>
+  ;; STATUS: When both min-width and min-height change the size of the canvas
+  ;;         I might be getting two on-size method invocations inside
+  ;;         set-aligned-min-sizes.
+  ;;           Also, I might not need to call realign-to-alloted in
+  ;;         set-aligned-min-sizes of the canvas because realign is called from
+  ;;         within on-size. This is true if and only if realignment needs to
+  ;;         be called only when the canvas size changes.
+  (define aligned-editor-canvas%
+    (class* editor-canvas% (aligned-pasteboard-parent<%>)
+      (inherit get-editor get-size min-width min-height)
+      (init-field (style empty))
+      
+      (field
+       (width-diff 0)
+       (height-diff 0))
+      
+      ;; set-aligned-min-size (-> (void))
+      ;; sets the aligned min width and height of all aligned children
+      (define/public (aligned-min-sizes-invalid)
+        (let ([editor (get-editor)])
+          (when (memq 'no-hscroll style)
+            (min-width
+             (+ (inexact->exact
+                 (send editor get-aligned-min-width))
+                machenrys-constant width-diff)))
+          (when (memq 'no-vscroll style)
+            (min-height
+             (+ (inexact->exact
+                 (send editor get-aligned-min-height))
+                machenrys-constant height-diff)))
+          ;; I might need to call realign not realign-to-alloted, but with what values?
+          (send editor realign-to-alloted)))
+      
+      ;; on-size (number? number? . -> . (void))
+      ;; called when the canvas's parent size changes
+      (define/override (on-size width height)
+        (super on-size width height)
+        (let ([w (- width width-diff machenrys-constant)]
+              [h (- height height-diff machenrys-constant)])
+          (when (and (positive? w) (positive? h))
+            (send* (get-editor)
+              (set-aligned-min-sizes)
+              (realign w h)))))
+      
+      ;; calc-view-client-diff (-> (void))
+      ;; calculates and sets the difference between client-size and view-size of the editor
+      (define/private (calc-view-client-diff)
+        (let-values ([(width height) (get-size)])
+          (let ([view-width (box 0)]
+                [view-height (box 0)])
+            (send (get-editor) get-view-size
+                  view-width view-height)
+            (set! width-diff
+                  (- width
+                     (inexact->exact
+                      (unbox view-width))))
+            (set! height-diff
+                  (- height
+                     (inexact->exact
+                      (unbox view-height)))))))
+      
+      (super-new (style style))
+      (calc-view-client-diff)))
+  
+  ;; a snip that can contain an aligned-pasteboard<%> and also be stretched within an aligned-pasteboard<%>
+  (define aligned-editor-snip%
+    (class* editor-snip% (aligned-pasteboard-parent<%> stretchable-snip<%>)
+      (inherit get-editor get-margin set-min-width set-min-height)
+      
+      (init
+       (stretchable-width true)
+       (stretchable-height true))
+      
+      (field
+       (stretchable-width-field stretchable-width)
+       (stretchable-height-field stretchable-height))
+      
+      (public (stretchable-width-method stretchable-width)
+              (stretchable-height-method stretchable-height))
+      
+      ;; stretchable-width (case-> (Boolean . -> . (void)) (-> Boolean))
+      ;; get or set the stretchablity of the pasteboards width
+      (define stretchable-width-method
+        (case-lambda
+          [(value) (set! stretchable-width-field value)]
+          [() stretchable-width-field]))
+      
+      ;; stretchable-height (case-> (Boolean . -> .(void)) (-> Boolean))
+      ;; get or set the stretchablity of the pasteboards height
+      (define stretchable-height-method
+        (case-lambda
+          [(value) (set! stretchable-height-field value)]
+          [() stretchable-height-field]))
+      
+      ;; (positive? positive? . -> . void?)
+      ;; called to resize the snip to a given size without effecting its alignd-min-sizes
+      ;; STATUS: Do I need to override resize and have it set the aligned-min-sizes?
+      (inherit resize)
+      (define/public (stretch width height)
+        (resize width height)
+        (let ([left (box 0)]
+              [top (box 0)]
+              [right (box 0)]
+              [bottom (box 0)])
+          (get-margin left top right bottom)
+          (let ([w (- width (unbox left) (unbox right))]
+                [h (- height (unbox top) (unbox bottom))])
+            (when (and (positive? w) (positive? h))
+              (send (get-editor) realign w h)))))
+      
+      ;; get-aligned-min-width (-> number?)
+      ;; the minimum width of the snip based on the children
+      (define/public (get-aligned-min-width)
+        (let ([left (box 0)]
+              [top (box 0)]
+              [right (box 0)]
+              [bottom (box 0)])
+          (get-margin left top right bottom)
+          (+ (unbox left)
+             (unbox right)
+             (send (get-editor) get-aligned-min-width)
+             machenrys-constant)))
+      
+      ;; get-aligned-min-height (-> number?)
+      ;; the minimum height of the snip based on the children
+      (define/public (get-aligned-min-height)
+        (let ([left (box 0)]
+              [top (box 0)]
+              [right (box 0)]
+              [bottom (box 0)])
+          (get-margin left top right bottom)
+          (+ (unbox top)
+             (unbox bottom)
+             (send (get-editor) get-aligned-min-height)
+             machenrys-constant)))
+      
+      ;; (-> void?)
+      ;; sets the aligned-min-sizes of all the editors and snips in this snip
+      (define/public (set-aligned-min-sizes)
+        (send (get-editor) set-aligned-min-sizes))
+      
+      ;; (-> void?)
+      ;; calculates and stores the minimum height and width of the snip
+      ;; note: more efficient to check for parent ahead of time and not
+      ;; calculate the margins when I don't have one.
+      (define/public (aligned-min-sizes-invalid)
+        (let ([parent (snip-parent this)])
+          (cond
+            [(not parent) (void)]
+            [(is-a? parent aligned-pasteboard<%>)
+             (send parent aligned-min-sizes-invalid)]
+            [else (align-to-min)])))
+      
+      ;; This code is needed to probe the tree of editors for their real sizes when they
+      ;; finally know them. This happens when the top level snip gets an admin.
+      (define/override (set-admin admin)
+        (super set-admin admin)
+        (let ([parent (snip-parent this)])
+          (when (and parent (not (is-a? parent aligned-pasteboard<%>)))
+            (set-aligned-min-sizes)
+            (align-to-min))))
+      
+      (define (align-to-min)
+        ;; Note: Not setting the min-width might improve efficientcy and
+        ;;       may not be necessary since snips grow to the size of
+        ;;       the things they contain. I'm going to try it so the
+        ;;       following two lines are commented out.
+        ;(set-min-width aligned-min-width)
+        ;(set-min-height aligned-min-height)
+        (let* ([ed (get-editor)]
+               [w (send ed get-aligned-min-width)]
+               [h (send ed get-aligned-min-height)])
+          (when (and (positive? w) (positive? h))
+            (send ed realign w h))))
+      
+      (super-new)))
+  )
diff --git a/collects/mrlib/private/aligned-pasteboard/aligned-pasteboard.ss b/collects/mrlib/private/aligned-pasteboard/aligned-pasteboard.ss
new file mode 100644
index 0000000000..92d2628a36
--- /dev/null
+++ b/collects/mrlib/private/aligned-pasteboard/aligned-pasteboard.ss
@@ -0,0 +1,22 @@
+(module aligned-pasteboard mzscheme
+  
+  (require
+   (lib "click-forwarding-editor.ss" "mrlib")
+   "geometry-managed-pasteboard.ss"
+   "locked-pasteboard.ss")
+  
+  (provide
+   vertical-pasteboard%
+   horizontal-pasteboard%)
+  
+  ;; contruct the basic mixin that both pasteboards will be created from
+  (define (click/lock type)
+    (click-forwarding-editor-mixin
+     (locked-pasteboard-mixin
+      (make-aligned-pasteboard type))))
+  
+  (define vertical-pasteboard%
+    (click/lock 'vertical))
+  
+  (define horizontal-pasteboard%
+    (click/lock 'horizontal)))
diff --git a/collects/mrlib/private/aligned-pasteboard/alignment.ss b/collects/mrlib/private/aligned-pasteboard/alignment.ss
new file mode 100644
index 0000000000..c839cdb9a0
--- /dev/null
+++ b/collects/mrlib/private/aligned-pasteboard/alignment.ss
@@ -0,0 +1,164 @@
+#|
+This code computes the sizees for the rectangles in the space using the on dimention
+off dimention method of referencing sizes. This means for example instead of saying
+width we say off dimention for vertical alignment. Inorder to consume and return
+the values in terms of width and height manipulation had to be done. I chose to create
+a struct abs-rect (abstract rectangle) and have code map horizontal and vertical rect
+stucts on to them. This code is a bit long but more readable than the other two options
+I came up with.
+  1) define all functions to be letrec bound functions inside align. align then take
+     accessors for the rect struct. The caller of align swaps the order of ondimention
+     and off dimention accessors for vertical or horizontal code. This method does not
+     allow the use of the readable, short, consis pattern matching code. As some of the
+     matching code is easily removed this may be a good option but a large letrec
+     is harder to write tests for.
+  2) define a pattern matcher syntax that will match the struct rect but swap the fields
+     based on wich on is the on or off dimention. This would have been shorter but much
+     more confusing.
+The current implementation requires align to map over the rects and allocate new stucts
+for each one on both passing into and returning from stretch-to-fit; This is not a bottle
+neck and it is the most readable solution.
+|#
+
+(module alignment mzscheme
+  
+  (require
+   (lib "match.ss")
+   (lib "contract.ss")
+   (lib "etc.ss")
+   (lib "list.ss"))
+  
+  (define-struct rect (x y))
+  (define-struct abs-rect (ondim offdim))
+  (define-struct dim (pos size stretchable?))
+  
+  (define (nonnegative? n)
+    (and (number? n)
+         (or (positive? n)
+             (zero? n))))
+  
+  (provide/contract
+   (struct rect ((x dim?) (y dim?)))
+   (struct abs-rect ((ondim dim?) (offdim dim?)))
+   (struct dim ((pos nonnegative?) (size nonnegative?) (stretchable? boolean?)))
+   (align ((symbols 'horizontal 'vertical)
+           positive? positive? (listof rect?)
+           . -> . (listof rect?)))
+   (rect-print ((listof rect?) . -> . void?)))
+  
+  ;; align the rectangles within the given space
+  (define (align type width height rects)
+    (cond
+      [(symbol=? type 'horizontal)
+       (map abs->horiz (stretch-to-fit width height (map horiz->abs rects)))]
+      [(symbol=? type 'vertical)
+       (map abs->vert (stretch-to-fit height width (map vert->abs rects)))]))
+  
+  ;; abs->horiz (abs-rect? . -> . rect?)
+  ;; convert an abstract rect to a horizontal rect
+  (define abs->horiz
+    (match-lambda
+      [($ abs-rect ondim offdim)
+       (make-rect ondim offdim)]))
+  
+  ;; abs->vert (abs-rect? . -> . rect?)
+  ;; convert an abstract rect to a vertical rect
+  (define abs->vert
+    (match-lambda
+      [($ abs-rect ondim offdim)
+       (make-rect offdim ondim)]))
+  
+  ;; horiz->abs (rect? . -> . abs-rect?)
+  ;; convert a horizontal rect to an abstract rect
+  (define horiz->abs
+    (match-lambda
+      [($ rect x y)
+       (make-abs-rect x y)]))
+  
+  ;; vert->abs (rect? . -> . abs-rect?)
+  ;; convert a vertical rect to an abstract rect
+  (define vert->abs
+    (match-lambda
+      [($ rect x y)
+       (make-abs-rect y x)]))
+  
+  ;; stretch-to-fit (positive? positive? (listof abs-rect?) . -> (listof abs-rect?))
+  ;; stretch the rectangles to fit with the given space
+  (define (stretch-to-fit onsize offsize rects)
+    (let-values ([(total-unstretchable-size stretchable-sizes)
+                  (get-onsizes rects)])
+      (let-values ([(extra-div extra-mod)
+                    (get-extra/rect
+                     (- onsize total-unstretchable-size)
+                     (quicksort stretchable-sizes >))])
+        (allocate-evenly/position extra-div extra-mod offsize rects))))
+  
+  ;; get-onsizes (((listof rect?)) . ->* . (nonnegative? (listof nonnegative?)))
+  ;; gets the unstretchable total size and a list of the stretchable sizes
+  (define (get-onsizes init-rects)
+    (let loop ([extra 0]
+               [stretchables empty]
+               [rects init-rects])
+      (match rects
+        [() (values extra stretchables)]
+        [(($ abs-rect ($ dim _ onsize #f) _) rest-rects ...)
+         (loop (+ onsize extra) stretchables rest-rects)]
+        [(($ abs-rect ($ dim _ onsize #t) _) rest-rects ...)
+         (loop extra (cons onsize stretchables) rest-rects)])))
+  
+  ;; get-extra/rect ((nonnegative? (listof nonnegative?)) . ->* . (nonnegative? nonnegative?))
+  ;; get the space that each stretchable snip will have
+  (define (get-extra/rect init-extra init-sizes)
+    (let loop ([sizes init-sizes]
+               [extra init-extra]
+               [count (length init-sizes)])
+      (cond
+        [(empty? sizes) (values 0 0)]
+        [else
+         (let ([extra/rect (quotient (floor extra) count)]
+               [onsize (first sizes)])
+           (if (> onsize extra/rect)
+               (loop (rest sizes) (- extra onsize) (sub1 count))
+               (values extra/rect (modulo (floor extra) count))))])))
+  
+  ;; allocate-evenly/position ((cons/p nonnegative? nonnegative?) positive? (listof abs-rect?) . -> .
+  ;;                           (listof abs->rect?))
+  ;; allocate the extra per rectangle to the stretchable rects and move them to their positions
+  (define (allocate-evenly/position extra-div extra-mod offsize init-rects)
+    (let ([mod (waner extra-mod)])
+      (let loop ([rects init-rects]
+                 [onpos 0])
+        (match rects
+          [() empty]
+          [(($ abs-rect ($ dim _ min-onsize onstretch?)
+               ($ dim _ min-offsize offstretch?)) rest-rects ...)
+           (let ([onsize (if (and onstretch?
+                                  (< min-onsize extra-div))
+                             (+ extra-div (mod)) min-onsize)]
+                 [offsize (if offstretch? offsize min-offsize)])
+             (cons (make-abs-rect (make-dim onpos onsize onstretch?)
+                                  (make-dim 0 offsize offstretch?))
+                   (loop rest-rects (+ onpos onsize))))]))))
+  
+  ;; waner (natural-number? . -> . (-> (union 1 0)))
+  ;; makes a thunk that returns 1 for it's first n applications, zero otherwise
+  (define (waner n)
+    (lambda ()
+      (if (zero? n)
+          0
+          (begin
+            (set! n (sub1 n))
+            1))))
+  
+  (define rect-print
+    (match-lambda
+      [() (void)]
+      [(($ rect
+           ($ dim x width stretchable-width?)
+           ($ dim y height stretchable-height?))
+        others ...)
+       (printf "(make-rect (make-dim ~s ~s ~s) (make-dim ~s ~s ~s))~n"
+               x width stretchable-width?
+               y height stretchable-height?)
+       (rect-print others)]))
+  )
diff --git a/collects/mrlib/private/aligned-pasteboard/constants.ss b/collects/mrlib/private/aligned-pasteboard/constants.ss
new file mode 100644
index 0000000000..b84051c266
--- /dev/null
+++ b/collects/mrlib/private/aligned-pasteboard/constants.ss
@@ -0,0 +1,7 @@
+(module constants mzscheme
+  (provide machenrys-constant)
+  
+  ;; machenrys-constant nonnegative?
+  ;; the differents between the size a pasteboard is alloted by
+  ;; get-view-size and the size it needs to avoid scollbars
+  (define machenrys-constant 2))
\ No newline at end of file
diff --git a/collects/mrlib/private/aligned-pasteboard/geometry-managed-pasteboard.ss b/collects/mrlib/private/aligned-pasteboard/geometry-managed-pasteboard.ss
new file mode 100644
index 0000000000..f27ab4daba
--- /dev/null
+++ b/collects/mrlib/private/aligned-pasteboard/geometry-managed-pasteboard.ss
@@ -0,0 +1,181 @@
+(module geometry-managed-pasteboard mzscheme
+  
+  (require
+   (lib "class.ss")
+   (lib "contract.ss")
+   (lib "list.ss")
+   (lib "etc.ss")
+   (lib "match.ss")
+   (lib "mred.ss" "mred")
+   "aligned-editor-container.ss"
+   "interface.ss"
+   "alignment.ss"
+   "snip-lib.ss"
+   "pasteboard-lib.ss")
+  
+  (provide/contract (make-aligned-pasteboard ((symbols 'vertical 'horizontal) . -> . class?)))
+  
+  ;;  mixin to add geometry management to pasteboard with the give type of alignement
+  (define (make-aligned-pasteboard type)
+    (class* pasteboard% (aligned-pasteboard<%>)
+      
+      (inherit resize move-to find-first-snip refresh-delayed?
+               begin-edit-sequence end-edit-sequence is-locked? lock)
+      
+      (field
+       [needs-realign? false]
+       [ignore-resizing? false]
+       [alloted-width false]
+       [alloted-height false]
+       [aligned-min-width 0]
+       [aligned-min-height 0]
+       [aligned-rects empty])
+      
+      ;; get-aligned-min-width (-> number?)
+      ;; the aligned-min-width of the pasteboard
+      (define/public (get-aligned-min-width) aligned-min-width)
+      
+      ;; get-aligned-min-height (-> number?)
+      ;; the aligned-min-height of the pasteboard
+      (define/public (get-aligned-min-height) aligned-min-height)
+      
+      (define/public (set-aligned-min-sizes)
+        (dynamic-let ([ignore-resizing? true])
+          (for-each-snip
+           (lambda (s)
+             (if (is-a? s aligned-editor-snip%)
+                 (send s set-aligned-min-sizes)))
+           (find-first-snip))
+          (set!-values (aligned-min-width aligned-min-height)
+                       (get-aligned-min-sizes type (find-first-snip)))))
+      
+      ;; set-algined-min-sizes (-> void?)
+      ;; set the aligned min width and height of the pasteboard based on it's children snips
+      (inherit in-edit-sequence?)
+      (define/public (aligned-min-sizes-invalid)
+        ;; This in-edit-sequence? is not sound. It causes me to percollate invalidation
+        ;; up the spin of my tree even when it is not visible (which refresh-delayed?
+        ;; checks for. However, for some types of refreshed-delayed? blocks, like a
+        ;; parent editor's edit-sequence, I have not yet figured out a way to reshedule
+        ;; an alignment. With in-edit-sequence? blocking, I know I'll always get the
+        ;; after-edit-sequence call where I can invoke alignment.
+        (if (in-edit-sequence?) ;(refresh-delayed?)
+            (set! needs-realign? true)
+            (begin
+              (set! needs-realign? false)
+              (set!-values (aligned-min-width aligned-min-height)
+                           (get-aligned-min-sizes type (find-first-snip)))
+              (let ([parent (pasteboard-parent this)])
+                (when parent (send parent aligned-min-sizes-invalid))))))
+      
+      ;; realign (case-> (-> void?) (positive? positive? . -> . void?))
+      ;; called by the parent to realign the pasteboard's children
+      (define/public (realign width height)
+        (set! alloted-width width)
+        (set! alloted-height height)
+        (realign-to-alloted))
+      
+      ;; realign-to-alloted (-> void?)
+      ;; realign the snips to fill the alloted width and height
+      (define/public (realign-to-alloted)
+        (when (and alloted-width alloted-height)
+          (when (not (and (positive? alloted-width) (positive? alloted-height)))
+            (error 'here "I am"))
+          (dynamic-let ([ignore-resizing? true])
+            (let* ([first-snip (find-first-snip)]
+                   [aligned-rects
+                    (align type alloted-width alloted-height
+                           (map-snip build-rect first-snip))])
+              (begin-edit-sequence)
+              (let ([was-locked? (is-locked?)])
+                (lock false)
+                (for-each-snip move/resize first-snip aligned-rects)
+                (lock was-locked?))
+              (end-edit-sequence)))))
+      
+      ;;move/resize (snip-pos? rect? . -> . void?)
+      ;;moves and resizes the snips with in pasteboard
+      (define move/resize
+        (match-lambda*
+          [(snip ($ rect
+                    ($ dim x width stretchable-width?)
+                    ($ dim y height stretchable-height?)))
+           (move-to snip x y)
+           (when (is-a? snip stretchable-snip<%>)
+             (send snip stretch width height))]))
+      
+      ;;;;;;;;;;
+      ;; Events
+      
+      ;; after-insert ((is-a?/c snip%) (is-a?/c snip%) number? number? . -> . void?)
+      ;; called after a snip is inserted to the pasteboard
+      (define/augment (after-insert snip before x y)
+        (aligned-min-sizes-invalid)
+        (inner (void) after-insert snip before x y))
+      
+      ;; after-delete ((is-a?/c snip%) . -> . void?)
+      ;; called after a snip is deleted from the pasteboard%
+      (define/augment (after-delete snip)
+        (aligned-min-sizes-invalid)
+        (inner (void) after-delete snip))
+      
+      ; after-reorder ((is-a?/c snip%) (is-a?/c snip%) boolean? . -> . void?)
+      ;; called after a snip is moved in the front to back snip order
+      (define/augment (after-reorder snip to-snip before?)
+        (realign-to-alloted)
+        (inner (void) after-reorder snip to-snip before?))
+      
+      ;; resized ((is-a?/c snip%) . -> . void?)
+      ;; called when a snip inside the editor is resized
+      (define/override (resized snip redraw-now?)
+        (super resized snip redraw-now?)
+        (unless ignore-resizing?
+          (aligned-min-sizes-invalid)))
+      
+      ;; after-edit-sequence (-> void?)
+      ;; called after an edit-sequence ends
+      (define/augment (after-edit-sequence)
+        (when needs-realign? (aligned-min-sizes-invalid))
+        (inner (void) after-edit-sequence))
+      
+      (super-new)))
+  
+  ;; build-rect ((is-a?/c snip%) . -> . rect?)
+  ;; makes a new default rect out of a snip
+  (define (build-rect snip)
+    (make-rect
+     (make-dim 0 (snip-min-width snip) (stretchable-width? snip))
+     (make-dim 0 (snip-min-height snip) (stretchable-height? snip))))
+  
+  ;; get-aligned-min-sizes (((symbols 'horizontal vertical) (is-a?/c snip%)) . ->* . (number? number?))
+  ;; calculate the aligned min sizes for the pasteboard containing the given snips
+  (define (get-aligned-min-sizes type init-snip)
+    (let-values ([(x-func y-func)
+                  (if (symbol=? type 'horizontal)
+                      (values + max)
+                      (values max +))])
+      (let loop ([snip init-snip]
+                 [width 0]
+                 [height 0])
+        (cond
+          [(boolean? snip) (values width height)]
+          [else
+           (loop (send snip next)
+                 (x-func (snip-min-width snip) width)
+                 (y-func (snip-min-height snip) height))]))))
+  
+  ;; dynamic-let is just like fluid-let but is less expensive and not safe over continuations
+  (define-syntax (dynamic-let stx)
+    (syntax-case stx ()
+      [(_ ((x y) ...) body body2 ...)
+       (andmap identifier? (syntax-e #'(x ...)))
+       (with-syntax ([(old-x ...) (generate-temporaries #'(x ...))])
+         #'(let ((old-x x) ...)
+             (begin
+               (set! x y) ...
+               (begin0
+                 (begin
+                   body
+                   body2 ...)
+                 (set! x old-x) ...))))]))
+  )
diff --git a/collects/mrlib/private/aligned-pasteboard/interface.ss b/collects/mrlib/private/aligned-pasteboard/interface.ss
new file mode 100644
index 0000000000..c783ad351d
--- /dev/null
+++ b/collects/mrlib/private/aligned-pasteboard/interface.ss
@@ -0,0 +1,95 @@
+(module interface mzscheme
+  
+  (require
+   (lib "class.ss")
+   (lib "mred.ss" "mred"))
+  
+  (provide
+    aligned-pasteboard<%>
+    aligned-pasteboard-parent<%>
+    stretchable-snip<%>)
+  
+  ;; the interface that must be implemented for a pasteboard to be contained in an aligned-pasteboard-parent<%>
+  (define aligned-pasteboard<%>
+    (interface (editor<%>)
+      
+      ;; (positive? positive? -> void?)
+      ;; called by the parent to resize and position the pasteboard's children
+      realign
+      
+      ;; (-> void?)
+      ;; called to realign a pasteboard to the already alloted width and height
+      realign-to-alloted
+   
+      ;; (-> void?)
+      ;; calculates the minimum width and height of the of the pasteboard
+      set-aligned-min-sizes
+      
+      ;; (-> void?)
+      ;; Called by a child snip to alert the parent that it's is now invalid due
+      ;; to a change in its own minimum size.
+      aligned-min-sizes-invalid
+      
+      ;; get-aligned-min-width: (-> number?)
+      ;; the minimum width of the pasteboard determined by its children
+      get-aligned-min-width
+      
+      ;; get-aligned-min-height: (-> number?)
+      ;; the minimum width of the pasteboard determined by its children
+      get-aligned-min-height
+      
+      ;; get-alignment (-> (values symbol? symbol?))
+      ;; get the pasteboards current alignment specification
+      ;; status: possible future feature
+      ;get-alignment
+      
+      ;; set-alignment (symbol? symbol? . -> . (void))
+      ;; sets the alignement which determines how children are placed in the pasteboard
+      ;; status: possible future feature
+      ;set-alignment
+      
+      ;; spacing (case-> (number? . -> .(void)) (-> number?))
+      ;; get or set the spacing in pixels placed between each child snip of the pasteboard
+      ;; status: possible future feature
+      ;spacing
+      ))
+  
+  ;; the interface that must be implemented by a class to be the parent of an aligned-pasteboard<%>
+  (define aligned-pasteboard-parent<%>
+    (interface ()
+      ;; (-> void?)
+      ;; sets the aligned min width and height of all aligned children
+      aligned-min-sizes-invalid
+      
+      ;; (-> void?)
+      ;; sets the aligned min sizes of this snip and its child editor
+      ;; required only for the aligned-editor-snip%
+      ;set-aligned-min-sizes
+      ))
+  
+  ;; the interface that must be implemented by a class to be inserted into an aligned-pasteboard<%> and
+  ;; be stretched and shrunk according to the geometry managment. note: any snip may be insert... those
+  ;; that do not implement stretchable-snip<%> will simply not be stretched.
+  (define stretchable-snip<%>
+    (interface ()
+      ;; (positive? positive? . ->  . void?)
+      ;; called by the parent editor to stretch the snip to an specific size
+      stretch
+      
+      ;; get-aligned-min-width (-> positive?)
+      ;; get the minimum width of the snip
+      get-aligned-min-width
+      
+      ;; get-aligned-min-height (-> positive?)
+      ;; get the minmum height of the snip
+      get-aligned-min-height
+      
+      ;; stretchable-width (case-> (boolean . -> . void?) (-> boolean?))
+      ;; get or set the stretchablity of the pasteboards width
+      stretchable-width
+      
+      ;; stretchable-height (case-> (boolean . -> . void?) (-> boolean?))
+      ;; get or set the stretchablity of the pasteboards height
+      stretchable-height
+      ))
+  )
\ No newline at end of file
diff --git a/collects/mrlib/private/aligned-pasteboard/locked-pasteboard.ss b/collects/mrlib/private/aligned-pasteboard/locked-pasteboard.ss
new file mode 100644
index 0000000000..365aa7340d
--- /dev/null
+++ b/collects/mrlib/private/aligned-pasteboard/locked-pasteboard.ss
@@ -0,0 +1,30 @@
+;; This module provides a mixin that locks a pasteboard to all mouse interaction. This
+;; means that there is no interactive dragging, no keyboard deletion, no handles drawn
+;; at the corners of the snips for dragging, and anything else that must be added.
+
+(module locked-pasteboard mzscheme
+  
+  (require
+   (lib "class.ss")
+   (lib "mred.ss" "mred")
+   (lib "etc.ss")
+   (lib "contract.ss"))
+  
+  (provide/contract
+   (locked-pasteboard-mixin mixin-contract))
+  
+  ;; mixin to remove interactive movement of snips from pasteboards
+  ;; STATUS: Look into and make sure I don't need to deal with the following.
+  ;;           interactive-adjust-mouse, interactive-adjust-move, on-default-event
+  ;;           interactive-adjust-resize
+  (define locked-pasteboard-mixin
+    (mixin ((class->interface pasteboard%)) ()
+      (define/override (on-default-event event) (void))
+      ;; The rest of the methods I believe to be redundant but
+      ;; are overriden anyway for consistancy.
+      (define/augment (can-interactive-move? event) false)
+      (define/augment (can-interactive-resize? snip) false)
+      (define/override (get-dragable) false)
+      (define/override (get-selection-visible) false)
+      (super-new)))
+  )
\ No newline at end of file
diff --git a/collects/mrlib/private/aligned-pasteboard/pasteboard-lib.ss b/collects/mrlib/private/aligned-pasteboard/pasteboard-lib.ss
new file mode 100644
index 0000000000..c4d20bffbf
--- /dev/null
+++ b/collects/mrlib/private/aligned-pasteboard/pasteboard-lib.ss
@@ -0,0 +1,39 @@
+(module pasteboard-lib mzscheme
+  
+  (require
+   (lib "class.ss")
+   (lib "mred.ss" "mred")
+   (lib "contract.ss")
+   (lib "etc.ss")
+   "interface.ss"
+   "snip-lib.ss")
+  
+  (provide/contract
+   (pasteboard-root ((is-a?/c aligned-pasteboard<%>) . -> . (is-a?/c aligned-pasteboard<%>)))
+   (pasteboard-parent
+    ((is-a?/c pasteboard%) . -> . (union (is-a?/c editor-canvas%) (is-a?/c editor-snip%) false/c))))
+  
+  ;; gets the top most aligned pasteboard in the tree of pasteboards and containers
+  (define (pasteboard-root pasteboard)
+    (let ([parent (pasteboard-parent pasteboard)])
+      (cond
+        [(is-a? parent canvas%)
+         pasteboard]
+        [(is-a? parent snip%)
+         (let ([grand-parent (snip-parent parent)])
+           (if (is-a? grand-parent aligned-pasteboard<%>)
+               (pasteboard-root grand-parent)
+               pasteboard))]
+        [else pasteboard])))
+
+  ;; gets the canvas or snip that the pasteboard is displayed in
+  ;; status: what if there is more than one canvas? should this be allowed? probablly not.
+  (define (pasteboard-parent pasteboard)
+    (let ([admin (send pasteboard get-admin)])
+      (cond
+        [(is-a? admin editor-snip-editor-admin<%>)
+         (send admin get-snip)]
+        [(is-a? admin editor-admin%)
+         (send pasteboard get-canvas)]
+        [else false])))
+  )
diff --git a/collects/mrlib/private/aligned-pasteboard/snip-lib.ss b/collects/mrlib/private/aligned-pasteboard/snip-lib.ss
new file mode 100644
index 0000000000..d32eef28fd
--- /dev/null
+++ b/collects/mrlib/private/aligned-pasteboard/snip-lib.ss
@@ -0,0 +1,117 @@
+(module snip-lib mzscheme
+  
+  (require
+   (lib "class.ss")
+   (lib "etc.ss")
+   (lib "mred.ss" "mred")
+   (lib "list.ss")
+   (lib "contract.ss")
+   "interface.ss")
+  
+  ;; a snip
+  (define snip? (is-a?/c snip%))
+  ;; a snip to act as the varying argument to a recursive functions
+  (define linked-snip? (union snip? false/c))
+  ;; a function to act on snips being mapped
+  (define snip-visitor? any/c #;((snip?) (listof any/c) . ->* . (void)))
+  ;; the rest of the lists passed to a snip mapping function
+  (define rest-lists? (listof (listof any/c)))
+  ;; a class that contains a snip
+  (define editor? (is-a?/c editor<%>))
+  
+  (provide/contract
+   (snip-width (snip? . -> . number?))
+   (snip-height (snip? . -> . number?))
+   (snip-min-width (snip? . -> . number?))
+   (snip-min-height (snip? . -> . number?))
+   (snip-parent (snip? . -> . (union editor? false/c)))
+   (fold-snip ((snip? any/c . -> . any/c) any/c linked-snip? . -> . any/c))
+   (for-each-snip any/c #;((snip-visitor? linked-snip?) rest-lists? . ->* . (void)))
+   (map-snip any/c #;((snip-visitor? linked-snip?) rest-lists? . ->* . ((listof any/c))))
+   (stretchable-width? (snip? . -> . boolean?))
+   (stretchable-height? (snip? . -> . boolean?)))
+  
+  ;; the width of a snip in the parent pasteboard
+  (define (snip-width snip)
+    (let ([left (box 0)]
+          [right (box 0)]
+          [pasteboard (snip-parent snip)])
+      (send pasteboard get-snip-location snip left (box 0) false)
+      (send pasteboard get-snip-location snip right (box 0) true)
+      (- (unbox right) (unbox left))))
+    
+  ;; the height of a snip in the parent pasteboard
+  (define (snip-height snip)
+    (let ([top (box 0)]
+          [bottom (box 0)]
+          [pasteboard (snip-parent snip)])
+      (send pasteboard get-snip-location snip (box 0) top false)
+      (send pasteboard get-snip-location snip (box 0) bottom true)
+      (- (unbox bottom) (unbox top))))
+  
+  ;; the minimum width of the snip
+  (define (snip-min-width snip)
+    (cond
+      [(is-a? snip stretchable-snip<%>)
+       (send snip get-aligned-min-width)]
+      [else (snip-width snip)]))
+  
+  ;; the minimum height of the snip
+  (define (snip-min-height snip)
+    (cond
+      [(is-a? snip stretchable-snip<%>)
+       (send snip get-aligned-min-height)]
+      [else (snip-height snip)]))
+  
+  ;; the pasteboard that contains the snip
+  (define (snip-parent snip)
+    (let ([admin (send snip get-admin)])
+      (if admin
+          (send admin get-editor)
+          false)))
+  
+  ;; the application of f on all snips from snip to the end in a foldl foldr mannor
+  (define (fold-snip f init-acc snip)
+    (let loop ([snip snip]
+               [acc init-acc])
+      (cond
+        [(is-a? snip snip%)
+         (loop (send snip next) (f snip acc))]
+        [else acc])))
+  
+  ;; applies the function to all the snips
+  (define (for-each-snip f first-snip . init-lists)
+    (let loop ([snip first-snip]
+               [lists init-lists])
+      (cond
+        [(is-a? snip snip%)
+         (apply f (cons snip (map first lists)))
+         (loop (send snip next)
+               (map rest lists))]
+        [else (void)])))
+  
+  ;; a list of f applied to each snip
+  (define (map-snip f first-snip . init-lists)
+    (let loop ([snip first-snip]
+               [lists init-lists])
+      (cond
+        [(is-a? snip snip%)
+         (cons (apply f (cons snip (map first lists)))
+               (loop (send snip next)
+                     (map rest lists)))]
+        [else empty])))
+  
+  ;; true if the snip can be resized in the x dimention
+  (define (stretchable-width? snip)
+    (cond
+      [(is-a? snip stretchable-snip<%>)
+       (send snip stretchable-width)]
+      [else false]))
+  
+  ;; true if the snip can be resized in the y dimention
+  (define (stretchable-height? snip)
+    (cond
+      [(is-a? snip stretchable-snip<%>)
+       (send snip stretchable-height)]
+      [else false]))
+  )
diff --git a/collects/mrlib/private/aligned-pasteboard/stretchable-editor-snip.ss b/collects/mrlib/private/aligned-pasteboard/stretchable-editor-snip.ss
new file mode 100644
index 0000000000..06bfccf1f5
--- /dev/null
+++ b/collects/mrlib/private/aligned-pasteboard/stretchable-editor-snip.ss
@@ -0,0 +1,109 @@
+(module stretchable-editor-snip mzscheme
+  
+  (provide
+   stretchable-editor-snip%
+   stretchable-editor-snip-mixin)
+  
+  (require
+   (lib "class.ss")
+   (lib "mred.ss" "mred")
+   (lib "etc.ss")
+   "snip-lib.ss"
+   "interface.ss")
+  
+  (define (stretchable-editor-snip-mixin super%)
+    (class* super% (stretchable-snip<%>)
+      
+      (init
+       (stretchable-width true)
+       (stretchable-height true))
+      
+      (field
+       (aligned-min-width 0)
+       (aligned-min-height 0)
+       (stretchable-width-field stretchable-width)
+       (stretchable-height-field stretchable-height))
+      
+      (public (stretchable-width-method stretchable-width)
+              (stretchable-height-method stretchable-height))
+      
+      ;; stretchable-width (case-> (Boolean . -> . (void)) (-> Boolean))
+      ;; get or set the stretchablity of the pasteboards width
+      (define stretchable-width-method
+        (case-lambda
+          [(value) (set! stretchable-width-field value)]
+          [() stretchable-width-field]))
+      
+      ;; stretchable-height (case-> (Boolean . -> .(void)) (-> Boolean))
+      ;; get or set the stretchablity of the pasteboards height
+      (define stretchable-height-method
+        (case-lambda
+          [(value) (set! stretchable-height-field value)]
+          [() stretchable-height-field]))
+      
+      (define/public (get-aligned-min-width) aligned-min-width)
+      (define/public (get-aligned-min-height) aligned-min-height)
+      
+      (inherit get-margin get-editor get-admin)
+      (define/override (resize w h)
+        (set! aligned-min-width w)
+        (set! aligned-min-height h)
+        (super-resize w h))
+        
+      (define/public (stretch w h)
+        (super-resize w h))
+      
+      (define/override (get-extent dc x y w h descent space lspace rspace)
+        (super get-extent dc x y w h descent space lspace rspace)
+        (when (is-a? (get-editor) text%)
+          (set-box! w (sub1 (unbox w))))
+        (go))
+      
+      (define/override (set-min-width w)
+        ;; account for margin !!!!!!
+        (send (get-editor) set-min-width w))
+      
+      (define/override (set-min-height h)
+        ;; account for margin !!!!!!
+        (send (get-editor) set-min-height h))
+      
+      (define/public (super-resize w h)
+        (let ((top (box 0))
+              (bot (box 0))
+              (lef (box 0))
+              (rit (box 0)))
+          (get-margin top bot lef rit)
+          (let ((w (max (- w (unbox lef) (unbox rit)) 0))
+                (h (max (- h (unbox top) (unbox bot)) 0))
+                (e (get-editor))
+                (a (get-admin)))
+            ;; subtracting 1 from W seems to make it act more like the editor-snip
+            ;; because the C code has a hack to sub1 to make it look better. I am not
+            ;; sure if this change here is sound and works for every part of this
+            ;; class.
+            (super set-min-width w)
+            (super set-min-height h)
+            (when a (send a resized this #t)))))
+      
+      ;; call this from within get extent and use the values it produces by subtracting the
+      ;; margin instead of calling the editors get-extent and adding the margin.
+      (define (go)
+        (let ([w (box 0)]
+              [h (box 0)]
+              (top (box 0))
+              (bot (box 0))
+              (lef (box 0))
+              (rit (box 0)))
+          (get-margin top bot lef rit)
+          (send (get-editor) get-extent w h)
+          (set! aligned-min-width (+ (unbox w) (unbox lef) (unbox rit)))
+          (set! aligned-min-height (+ (unbox h) (unbox top) (unbox rit)))))
+            
+      (super-new)
+      (inherit get-min-width get-min-height)
+      (set-min-width (get-min-width))
+      (set-min-height (get-min-height))))
+  
+  (define stretchable-editor-snip%
+    (stretchable-editor-snip-mixin
+     editor-snip%)))
\ No newline at end of file
diff --git a/collects/mrlib/private/aligned-pasteboard/tests/README b/collects/mrlib/private/aligned-pasteboard/tests/README
new file mode 100644
index 0000000000..53c66449e9
--- /dev/null
+++ b/collects/mrlib/private/aligned-pasteboard/tests/README
@@ -0,0 +1 @@
+These tests are not yet checkec in.
diff --git a/collects/mrlib/private/aligned-pasteboard/tests/actual-bigger.ss b/collects/mrlib/private/aligned-pasteboard/tests/actual-bigger.ss
new file mode 100644
index 0000000000..8c53b228b5
--- /dev/null
+++ b/collects/mrlib/private/aligned-pasteboard/tests/actual-bigger.ss
@@ -0,0 +1,38 @@
+(require
+ (lib "class.ss")
+ (lib "list.ss")
+ (lib "mred.ss" "mred")
+ (lib "etc.ss")
+ "../aligned-editor-container.ss"
+ "../aligned-pasteboard.ss"
+ "../snip-lib.ss")
+
+(define f (new frame% (label "test") (width 200) (height 200)))
+(define e (new text%))
+(define c (new editor-canvas% (editor e) (parent f)))
+
+(define vpb1 (new vertical-pasteboard%))
+(define aes1 (new aligned-editor-snip% (editor vpb1)))
+
+(define vpb2 (new vertical-pasteboard%))
+(define aes2 (new aligned-editor-snip% (editor vpb2)))
+
+(define t (new text%))
+(define es (new editor-snip% (editor t)))
+
+(send vpb1 insert aes2 false)
+(send vpb2 insert es)
+(send e insert aes1)
+(send f show #t)
+(send f show #f)
+
+(send t begin-edit-sequence)
+(send e begin-edit-sequence)
+(send t insert "1\n")
+(send t insert "1")
+(send e end-edit-sequence)
+(send t end-edit-sequence)
+
+(>= (send vpb1 get-aligned-min-height)
+    (send vpb2 get-aligned-min-height)
+    (snip-height es))
\ No newline at end of file
diff --git a/collects/mrlib/private/aligned-pasteboard/tests/debug.ss b/collects/mrlib/private/aligned-pasteboard/tests/debug.ss
new file mode 100644
index 0000000000..d13734ea9f
--- /dev/null
+++ b/collects/mrlib/private/aligned-pasteboard/tests/debug.ss
@@ -0,0 +1,80 @@
+(module debug mzscheme
+  (require
+   (lib "class.ss"))
+  
+  (provide
+   debug-snip
+   debug-pasteboard
+   debug-canvas)
+  
+  ;;debug-snip: -> (void)
+  ;;get the relevant info about the snip that contains the two others pasteboards
+  (define debug-snip
+    (lambda (snip)
+      (printf "--- aligned-editor-snip% --\n")
+      (let ((l (box 0))
+            (t (box 0))
+            (r (box 0))
+            (b (box 0)))
+        (send snip get-inset l t r b)
+        (printf "get-inset: ~sX~s  ~sX~s\n" (unbox l) (unbox r) (unbox t) (unbox b)))
+      
+      (let ((l (box 0))
+            (t (box 0))
+            (r (box 0))
+            (b (box 0)))
+        (send snip get-margin l t r b)
+        (printf "get-margin: ~sX~s  ~sX~s\n" (unbox l) (unbox r) (unbox t) (unbox b)))
+      
+      (printf "get-max-height: ~s~n" (send snip get-max-height))
+      (printf "get-max-width: ~s~n" (send snip get-max-width))
+      (printf "get-min-height: ~s~n" (send snip get-min-height))
+      (printf "get-min-width: ~s~n" (send snip get-min-width))
+      ;(printf "snip-width: ~s~n" (send pasteboard snip-width snip))
+      ;(printf "snip-height: ~s~n" (send pasteboard snip-height snip))
+      ))
+  
+  ;;debug-pasteboard: -> (void)
+  ;;displays to the repl the sizes i'm interested in
+  (define debug-pasteboard
+    (lambda (pasteboard)
+      (printf "--- aligned-pasteboard% ---\n")
+      (let ((tmp1 (box 0))
+            (tmp2 (box 0)))
+        (send pasteboard get-extent tmp1 tmp2)
+        (printf "get-extent: ~sX~s\n" (unbox tmp1) (unbox tmp2)))
+      (printf "get-max-height: ~s\n" (send pasteboard get-max-height))
+      (let ((tmp (call-with-values (lambda () (send pasteboard get-max-view-size)) cons)))
+        (printf "get-max-view-size: ~sX~s\n" (car tmp) (cdr tmp)))
+      (printf "get-max-width: ~s\n" (send pasteboard get-max-width))
+      (printf "get-min-height: ~s\n" (send pasteboard get-min-height))
+      (printf "get-min-width: ~s\n" (send pasteboard get-min-width))
+      (let ((tmp1 (box 0))
+            (tmp2 (box 0)))
+        (send pasteboard get-view-size tmp1 tmp2)
+        (printf "get-view-size: ~sX~s\n" (unbox tmp1) (unbox tmp2)))
+      ))
+  
+  ;;debug-canvas: -> (void)
+  ;;just some help counting pixels
+  (define debug-canvas
+    (lambda (canvas)
+      (printf "--- aligned-editor-canvas% ---\n")
+      ;;values
+      (let ((tmp (call-with-values (lambda () (send canvas get-client-size)) cons)))
+        (printf "~a: ~sX~s\n" (symbol->string (quote get-client-size)) (car tmp) (cdr tmp)))
+      (let ((tmp (call-with-values (lambda () (send canvas get-graphical-min-size)) cons)))
+        (printf "~a: ~sX~s\n" (symbol->string (quote get-graphical-min-size)) (car tmp) (cdr tmp)))
+      (let ((tmp (call-with-values (lambda () (send canvas get-size)) cons)))
+        (printf "~a: ~sX~s\n" (symbol->string (quote get-size)) (car tmp) (cdr tmp)))
+      ;;1 value
+      (printf "~a: ~s\n" (symbol->string (quote get-height)) (send canvas get-height))
+      (printf "~a: ~s\n" (symbol->string (quote get-width)) (send canvas get-width))
+      (printf "~a: ~s\n" (symbol->string (quote horiz-margin)) (send canvas horiz-margin))
+      (printf "~a: ~s\n" (symbol->string (quote min-client-height)) (send canvas min-client-height))
+      (printf "~a: ~s\n" (symbol->string (quote min-client-width)) (send canvas min-client-width))
+      (printf "~a: ~s\n" (symbol->string (quote min-height)) (send canvas min-height))
+      (printf "~a: ~s\n" (symbol->string (quote min-width)) (send canvas min-width))
+      (printf "~a: ~s\n" (symbol->string (quote vert-margin)) (send canvas vert-margin))
+      ))
+  )
\ No newline at end of file
diff --git a/collects/mrlib/private/aligned-pasteboard/tests/edit-sequence-loop.ss b/collects/mrlib/private/aligned-pasteboard/tests/edit-sequence-loop.ss
new file mode 100644
index 0000000000..767bc4da76
--- /dev/null
+++ b/collects/mrlib/private/aligned-pasteboard/tests/edit-sequence-loop.ss
@@ -0,0 +1,16 @@
+(require
+ "../aligned-pasteboard.ss"
+ "../aligned-editor-container.ss")
+
+(define (converges? x) #t)
+
+(converges?
+ (let* ((f (new frame% (label "test")))
+        (e (new text%))
+        (c (new editor-canvas% (editor e) (parent f)))
+        (pb (new vertical-pasteboard%))
+        (actual (new text%))
+        (act-line (new aligned-editor-snip% (editor (new vertical-pasteboard%))))
+        (t (new aligned-editor-snip% (editor pb))))
+   (send e insert t)
+   (send* pb (begin-edit-sequence) (insert act-line #f) (end-edit-sequence))))
\ No newline at end of file
diff --git a/collects/mrlib/private/aligned-pasteboard/tests/example-min.ss b/collects/mrlib/private/aligned-pasteboard/tests/example-min.ss
new file mode 100644
index 0000000000..84ac771cdd
--- /dev/null
+++ b/collects/mrlib/private/aligned-pasteboard/tests/example-min.ss
@@ -0,0 +1,16 @@
+(require
+ (lib "class.ss")
+ (lib "mred.ss" "mred")
+ (lib "etc.ss")
+ "../aligned-pasteboard.ss"
+ "../aligned-editor-container.ss")
+
+(define f (new frame% (label "") (width 400) (height 400)))
+(define e (new horizontal-pasteboard%))
+(define c (new aligned-editor-canvas% (parent f) (editor e)))
+(define vp1 (new vertical-pasteboard%))
+(define ae-snip1 (new aligned-editor-snip% (editor vp1)))
+(define t-snip1 (new editor-snip% (editor (new text%))))
+(send e insert ae-snip1 false)
+(send vp1 insert t-snip1 false)
+(send f show true)
\ No newline at end of file
diff --git a/collects/mrlib/private/aligned-pasteboard/tests/example.ss b/collects/mrlib/private/aligned-pasteboard/tests/example.ss
new file mode 100644
index 0000000000..d9fe843e5d
--- /dev/null
+++ b/collects/mrlib/private/aligned-pasteboard/tests/example.ss
@@ -0,0 +1,87 @@
+(require
+ (lib "class.ss")
+ (lib "mred.ss" "mred")
+ (lib "etc.ss")
+ "../aligned-pasteboard.ss"
+ "../aligned-editor-container.ss")
+
+;                                                          
+;                                                          
+;                                       ;;                 
+;                                        ;                 
+;                                        ;                 
+;    ;;;;; ;;  ;;  ;;;;;;;;;;;;;; ;;;    ;     ;;;;;  ;;;; 
+;   ;    ;  ;;;;      ; ;  ;  ; ;;  ;;   ;    ;    ; ;   ; 
+;   ;;;;;;   ;;    ;;;; ;  ;  ; ;    ;   ;    ;;;;;; ;;;;  
+;   ;        ;;   ;   ; ;  ;  ; ;    ;   ;    ;          ; 
+;   ;;   ;  ;  ;  ;   ; ;  ;  ; ;;  ;;   ;    ;;   ; ;   ; 
+;    ;;;;  ;;  ;;  ;;;;;;; ;; ;;; ;;;  ;;;;;   ;;;;  ;;;;  
+;                               ;                          
+;                              ;;;                         
+;                                                          
+
+(define frame
+  (instantiate frame% ()
+    (label "Frame")
+    (width 400)
+    (height 400)))
+
+(define pasteboard
+  (instantiate horizontal-pasteboard% ()))
+
+(define canvas
+  (instantiate aligned-editor-canvas% ()
+    (parent frame)
+    (editor pasteboard)))
+
+(define vp1
+  (instantiate vertical-pasteboard% ()))
+
+(define ae-snip1
+  (instantiate aligned-editor-snip% ()
+    (editor vp1)))
+
+(define vp2
+  (instantiate vertical-pasteboard% ()))
+
+(define ae-snip2
+  (instantiate aligned-editor-snip% ()
+    (editor vp2)))
+
+(define vp3
+  (instantiate vertical-pasteboard% ()))
+
+(define ae-snip3
+  (instantiate aligned-editor-snip% ()
+    (editor vp3)))
+
+(define vp4
+  (instantiate vertical-pasteboard% ()))
+
+(define ae-snip4
+  (instantiate aligned-editor-snip% ()
+    (editor vp4)))
+
+(define vp5
+  (instantiate vertical-pasteboard% ()))
+
+(define ae-snip5
+  (instantiate aligned-editor-snip% ()
+    (editor vp5)))
+
+(define t-snip1
+  (instantiate editor-snip% ()
+    (editor (instantiate text% ()))))
+
+(define t-snip2
+  (instantiate editor-snip% ()
+    (editor (instantiate text% ()))))
+
+(send pasteboard insert ae-snip1 false)
+(send pasteboard insert ae-snip2 false)
+(send pasteboard insert ae-snip5 false)
+(send vp2 insert ae-snip3 false)
+(send vp2 insert ae-snip4 false)
+(send vp1 insert t-snip1 false)
+(send vp5 insert t-snip2 false)
+(send frame show true)
\ No newline at end of file
diff --git a/collects/mrlib/private/aligned-pasteboard/tests/insertion-without-display.ss b/collects/mrlib/private/aligned-pasteboard/tests/insertion-without-display.ss
new file mode 100644
index 0000000000..9092532aee
--- /dev/null
+++ b/collects/mrlib/private/aligned-pasteboard/tests/insertion-without-display.ss
@@ -0,0 +1,4 @@
+(require (lib "aligned-pasteboard.ss" "mrlib"))
+(with-handlers ([exn? (lambda (x) #f)])
+  (send (new pasteboard%) insert (new aligned-editor-snip% (editor (new horizontal-pasteboard%))))
+  #t)
\ No newline at end of file
diff --git a/collects/mrlib/private/aligned-pasteboard/tests/minimal.ss b/collects/mrlib/private/aligned-pasteboard/tests/minimal.ss
new file mode 100644
index 0000000000..9a5ac83aed
--- /dev/null
+++ b/collects/mrlib/private/aligned-pasteboard/tests/minimal.ss
@@ -0,0 +1,13 @@
+(require
+ "../aligned-editor-container.ss"
+ "../aligned-pasteboard.ss")
+
+(define f (new frame% (label "test") (width 200) (height 200)))
+(define e (new vertical-pasteboard%))
+(define c (new aligned-editor-canvas% (editor e) (parent f)))
+(define pb (new vertical-pasteboard%))
+(define s (new aligned-editor-snip% (editor pb) (stretchable-height #f) (stretchable-width #f)))
+(send pb insert (make-object string-snip% "Long snip"))
+(send pb insert (make-object string-snip% "Longer snip"))
+(send e insert s)
+(send f show #t)
diff --git a/collects/mrlib/private/aligned-pasteboard/tests/more-tests-margin-aligned.ss b/collects/mrlib/private/aligned-pasteboard/tests/more-tests-margin-aligned.ss
new file mode 100644
index 0000000000..1e4dda3050
--- /dev/null
+++ b/collects/mrlib/private/aligned-pasteboard/tests/more-tests-margin-aligned.ss
@@ -0,0 +1,28 @@
+(require
+ "../aligned-editor-container.ss"
+ "../aligned-pasteboard.ss")
+
+(define pb (new horizontal-pasteboard%))
+(send* pb
+  (insert (make-object string-snip% "Call") #f)
+  (insert (new editor-snip% (editor (new text%))) #f))
+(define z (new aligned-editor-snip% (editor pb) (stretchable-height #f) (stretchable-width #f)))
+(define f (new frame% (label "more-tests-text") (width 200) (height 200)))
+(define e (new vertical-pasteboard%))
+(define c (new aligned-editor-canvas% (editor e) (parent f)))
+(send e insert z)
+(send f show #t)
+
+;;;;;;;;;;
+;; exploration
+(require "../snip-lib.ss")
+(define (margin snip)
+  (let ([left (box 0)]
+        [top (box 0)]
+        [right (box 0)]
+        [bottom (box 0)])
+    (send snip get-margin left top right bottom)
+    (list (cons 'left (unbox left))
+          (cons 'right (unbox right))
+          (cons 'top (unbox top))
+          (cons 'bottom (unbox bottom)))))
\ No newline at end of file
diff --git a/collects/mrlib/private/aligned-pasteboard/tests/more-tests-margin.ss b/collects/mrlib/private/aligned-pasteboard/tests/more-tests-margin.ss
new file mode 100644
index 0000000000..5c46153a2f
--- /dev/null
+++ b/collects/mrlib/private/aligned-pasteboard/tests/more-tests-margin.ss
@@ -0,0 +1,28 @@
+(require
+ "../aligned-editor-container.ss"
+ "../aligned-pasteboard.ss")
+
+(define pb (new horizontal-pasteboard%))
+(send* pb
+  (insert (make-object string-snip% "Call") #f)
+  (insert (new editor-snip% (editor (new text%))) #f))
+(define z (new aligned-editor-snip% (editor pb)))
+(define f (new frame% (label "more-tests-text") (width 200) (height 200)))
+(define e (new pasteboard%))
+(define c (new editor-canvas% (editor e) (parent f)))
+(send e insert z)
+(send f show #t)
+
+;;;;;;;;;;
+;; exploration
+(require "../snip-lib.ss")
+(define (margin snip)
+  (let ([left (box 0)]
+        [top (box 0)]
+        [right (box 0)]
+        [bottom (box 0)])
+    (send snip get-margin left top right bottom)
+    (list (cons 'left (unbox left))
+          (cons 'right (unbox right))
+          (cons 'top (unbox top))
+          (cons 'bottom (unbox bottom)))))
\ No newline at end of file
diff --git a/collects/mrlib/private/aligned-pasteboard/tests/more-tests-min-stretchable.ss b/collects/mrlib/private/aligned-pasteboard/tests/more-tests-min-stretchable.ss
new file mode 100644
index 0000000000..49d76997a2
--- /dev/null
+++ b/collects/mrlib/private/aligned-pasteboard/tests/more-tests-min-stretchable.ss
@@ -0,0 +1,40 @@
+(require
+ "../aligned-editor-container.ss"
+ "../aligned-pasteboard.ss")
+
+(define editor (new vertical-pasteboard%))
+(define pb (new horizontal-pasteboard%))
+(send* pb
+  (insert (make-object string-snip% "Call") #f)
+  (insert (new editor-snip% (editor (new text%))) #f))
+(send editor insert (new aligned-editor-snip% (editor pb)))
+(define f (new frame% (label "more-test-jacob") (width 200) (height 200)))
+(define e (new vertical-pasteboard%))
+(define c (new aligned-editor-canvas% (editor e) (parent f)))
+(define t (new aligned-editor-snip%
+               (editor editor)))
+(send e insert t)
+(send f show #t)
+
+;;;;;;;;;;
+;; exploration
+(require "../snip-lib.ss")
+(define t-e (send t get-editor))
+(send t-e get-aligned-min-width)
+(send t get-aligned-min-width)
+(define fs (send t-e find-first-snip))
+(define fs (send t-e find-first-snip))
+(define fs-e (send fs get-editor))
+(send fs-e find-first-snip)
+(send fs-e get-aligned-min-width)
+(send fs get-aligned-min-width)
+(define (margin snip)
+  (let ([left (box 0)]
+        [top (box 0)]
+        [right (box 0)]
+        [bottom (box 0)])
+    (send snip get-margin left top right bottom)
+    (list (cons 'left (unbox left))
+          (cons 'right (unbox right))
+          (cons 'top (unbox top))
+          (cons 'bottom (unbox bottom)))))
\ No newline at end of file
diff --git a/collects/mrlib/private/aligned-pasteboard/tests/more-tests-min.ss b/collects/mrlib/private/aligned-pasteboard/tests/more-tests-min.ss
new file mode 100644
index 0000000000..eb99c34a4f
--- /dev/null
+++ b/collects/mrlib/private/aligned-pasteboard/tests/more-tests-min.ss
@@ -0,0 +1,42 @@
+(require
+ "../aligned-editor-container.ss"
+ "../aligned-pasteboard.ss")
+
+(define editor (new vertical-pasteboard%))
+(define pb (new horizontal-pasteboard%))
+(send* pb
+  (insert (make-object string-snip% "Call") #f)
+  (insert (new editor-snip% (editor (new text%))) #f))
+(send editor insert (new aligned-editor-snip% (editor pb)))
+(define f (new frame% (label "more-test-jacob") (width 200) (height 200)))
+(define e (new vertical-pasteboard%))
+(define c (new aligned-editor-canvas% (editor e) (parent f)))
+(define t (new aligned-editor-snip%
+               (editor editor)
+               (stretchable-height #f)
+               (stretchable-width #f)))
+(send e insert t)
+(send f show #t)
+
+;;;;;;;;;;
+;; exploration
+(require "../snip-lib.ss")
+(define t-e (send t get-editor))
+(send t-e get-aligned-min-width)
+(send t get-aligned-min-width)
+(define fs (send t-e find-first-snip))
+(define fs (send t-e find-first-snip))
+(define fs-e (send fs get-editor))
+(send fs-e find-first-snip)
+(send fs-e get-aligned-min-width)
+(send fs get-aligned-min-width)
+(define (margin snip)
+  (let ([left (box 0)]
+        [top (box 0)]
+        [right (box 0)]
+        [bottom (box 0)])
+    (send snip get-margin left top right bottom)
+    (list (cons 'left (unbox left))
+          (cons 'right (unbox right))
+          (cons 'top (unbox top))
+          (cons 'bottom (unbox bottom)))))
\ No newline at end of file
diff --git a/collects/mrlib/private/aligned-pasteboard/tests/more-tests-text.ss b/collects/mrlib/private/aligned-pasteboard/tests/more-tests-text.ss
new file mode 100644
index 0000000000..65693b1ae6
--- /dev/null
+++ b/collects/mrlib/private/aligned-pasteboard/tests/more-tests-text.ss
@@ -0,0 +1,42 @@
+;; Note this test case fails when the snip 'y' is stretchable. There is lots of extra space. Finding out
+;; why will probably fix the test case's extra space.
+(require
+ "../aligned-editor-container.ss"
+ "../aligned-pasteboard.ss")
+
+(define editor (new vertical-pasteboard%))
+(define pb (new horizontal-pasteboard%))
+(define z (new editor-snip% (editor (new text%))))
+(send* pb
+  (insert (make-object string-snip% "Call") #f)
+  (insert z #f))
+(define y (new aligned-editor-snip%
+               (editor pb)
+               (stretchable-width #t)
+               (stretchable-height #t)))
+(send editor insert y)
+(define f (new frame% (label "more-tests-text") (width 200) (height 200)))
+(define e (new pasteboard%))
+(define c (new editor-canvas% (editor e) (parent f)))
+(define t (new aligned-editor-snip%
+               (editor editor)
+               (stretchable-height #f)
+               (stretchable-width #f)))
+(send e insert t)
+(send f show #t)
+
+;;;;;;;;;;
+;; exploration
+(eq-hash-code y)
+(eq-hash-code t)
+(require "../snip-lib.ss")
+(define (margin snip)
+  (let ([left (box 0)]
+        [top (box 0)]
+        [right (box 0)]
+        [bottom (box 0)])
+    (send snip get-margin left top right bottom)
+    (list (cons 'left (unbox left))
+          (cons 'right (unbox right))
+          (cons 'top (unbox top))
+          (cons 'bottom (unbox bottom)))))
\ No newline at end of file
diff --git a/collects/mrlib/private/aligned-pasteboard/tests/more-tests.ss b/collects/mrlib/private/aligned-pasteboard/tests/more-tests.ss
new file mode 100644
index 0000000000..a30f7b9c3c
--- /dev/null
+++ b/collects/mrlib/private/aligned-pasteboard/tests/more-tests.ss
@@ -0,0 +1,95 @@
+;; some more advanced aligned-pasteboard tests take from the test-case-boxes
+
+(require
+ (lib "class.ss")
+ (lib "mred.ss" "mred")
+ (lib "etc.ss")
+ "../aligned-editor-container.ss"
+ "../aligned-pasteboard.ss")
+
+;; a text-case snip
+(define test-case-box%
+  (class aligned-editor-snip%
+    
+    ;; these edit-sequences are looping
+    (define/public (hide-entries)
+      (send* editor
+        (begin-edit-sequence)
+        (release-snip call-line)
+        (release-snip exp-line)
+        (release-snip act-line)
+        (end-edit-sequence)))
+    
+    ;; these edit-sequences are looping
+    (define/public (show-entries)
+      (send* editor
+        (begin-edit-sequence)
+        (insert call-line false)
+        (insert exp-line false)
+        (insert act-line false)
+        (end-edit-sequence)))
+    
+    (field
+     [editor (new vertical-pasteboard%)]
+     [turn-button (new image-snip%)]
+     [comment (new text%)]
+     [result (new image-snip%)]
+     [call (new text%)]
+     [expected (new text%)]
+     [actual (new text%)]
+     [top-line (make-top-line turn-button comment result)]
+     [call-line (make-line "Call" call)]
+     [exp-line (make-line "Expected" expected)]
+     [act-line (make-line "Actual" actual)])
+    
+    (send editor insert top-line)
+    (show-entries)
+    
+    (super-new
+     (editor editor)
+     (stretchable-height #f)
+     (stretchable-width #f))))
+
+;; the top line of the test-case
+(define (make-top-line turn-snip comment result-snip)
+  (let ([pb (new horizontal-pasteboard%)])
+    (send* pb
+      (insert turn-snip false)
+      (insert (text-field comment) false)
+      (insert result-snip false))
+    (new aligned-editor-snip%
+         (stretchable-height false)
+         (editor pb))))
+
+;; a line labeled with the given string and containing a given text
+(define (make-line str text)
+  (let ([pb (new horizontal-pasteboard%)])
+    (send* pb
+      (insert (make-object string-snip% str) false)
+      (insert (text-field text) false))
+    (new aligned-editor-snip% (editor pb))))
+
+;; a text field fit to be in a test-case (no borders or margins etc.)
+;;STATUS: this should really return a stretchable-snip<%> not an editor-snip% of fixed size.
+(define (text-field text)
+  (new editor-snip% (editor text)))
+
+;; To make case 3 work, I need to send the forward set-aligned-min-sizes
+;; from the snip. Currently that call only originates in the on-size of
+;; the canvas but in case 3 the canvas does not belong to the aligned-*
+;; collection. I think the place to call this forward set-aligned-min-sizes
+;; is from within size-cache-invalid of the aligned-editor-snip
+(define top
+  (case 3
+    [(1) (cons vertical-pasteboard% aligned-editor-canvas%)]
+    [(2) (cons text% editor-canvas%)]
+    [(3) (cons pasteboard% editor-canvas%)]))
+
+(define f (new frame% (label "test") (width 200) (height 250)))
+(define e (new (car top)))
+(define c (new (cdr top) (editor e) (parent f)))
+(define t (new test-case-box%))
+(send e insert t)
+(send f show #t)
+;(send t hide-entries)
+;(send t show-entries)
\ No newline at end of file
diff --git a/collects/mrlib/private/aligned-pasteboard/tests/snip-dumper.ss b/collects/mrlib/private/aligned-pasteboard/tests/snip-dumper.ss
new file mode 100644
index 0000000000..8fdd8f68e4
--- /dev/null
+++ b/collects/mrlib/private/aligned-pasteboard/tests/snip-dumper.ss
@@ -0,0 +1,70 @@
+(module snip-dumper mzscheme
+  
+  (require
+   (lib "class.ss")
+   (lib "mred.ss" "mred"))
+  
+  (provide
+   dump-children
+   (struct snip-dump (left top right bottom children))
+   dump=?)
+  
+  ;;dump=?: ((union snip-dump? (listof snip-dump?)) . -> . boolean?)
+  (define (dump=? dump1 dump2)
+    (cond
+      [(and (list? dump1) (list? dump2)
+            (eq? (length dump1) (length dump2)))
+       (andmap dump=? dump1 dump2)]
+      [(and (snip-dump? dump1) (snip-dump? dump2))
+       (and
+        (dump=? (snip-dump-left dump1)
+                (snip-dump-left dump2))
+        (dump=? (snip-dump-top dump1)
+                (snip-dump-top dump2))
+        (dump=? (snip-dump-right dump1)
+                (snip-dump-right dump2))
+        (dump=? (snip-dump-bottom dump1)
+                (snip-dump-bottom dump2))
+        (dump=? (snip-dump-children dump1)
+                (snip-dump-children dump2)))]
+      [else (equal? dump1 dump2)]))
+  
+  ;; type snip-dump =
+  ;;   (make-single number number number number (union #f (listof snip-dump)))
+  ;; if children is #f, this indicates that the snip was not an
+  ;; editor-snip. In contrast, if it is null, this indicates that
+  ;; the snip is an editor-snip, but has no children.
+  (define-struct snip-dump (left top right bottom children))
+  
+  ;; dump-pb : snip -> snip-dump
+  (define (dump-snip snip)
+    (let ([outer-pb (send (send snip get-admin) get-editor)]
+          [bl (box 0)]
+          [bt (box 0)]
+          [br (box 0)]
+          [bb (box 0)])
+      (send outer-pb get-snip-location snip bl bt #t)
+      (send outer-pb get-snip-location snip br bb #f)
+      (make-snip-dump
+       (unbox bl)
+       (unbox bt)
+       (unbox br)
+       (unbox bb)
+       (dump-snips snip))))
+  
+  ;; dump-snips : snip -> (union #f (listof snip-dump))
+  (define (dump-snips snip)
+    (cond
+      [(is-a? snip editor-snip%)
+       (dump-children (send snip get-editor))]
+      [else #f]))
+  
+  ;; dump-children : editor<%> -> (listof snip-dump)
+  (define (dump-children editor)
+    (let loop ([snip (send editor find-first-snip)])
+      (cond
+        [snip
+         (cons (dump-snip snip)
+               (loop (send snip next)))]
+        [else null])))
+  )
\ No newline at end of file
diff --git a/collects/mrlib/private/aligned-pasteboard/tests/stretchable-editor-snip-test-min.ss b/collects/mrlib/private/aligned-pasteboard/tests/stretchable-editor-snip-test-min.ss
new file mode 100644
index 0000000000..eb61d4c62e
--- /dev/null
+++ b/collects/mrlib/private/aligned-pasteboard/tests/stretchable-editor-snip-test-min.ss
@@ -0,0 +1,25 @@
+(require
+ "../aligned-pasteboard.ss"
+ "../aligned-editor-container.ss"
+ "../stretchable-editor-snip.ss"
+ "../snip-lib.ss")
+
+(define f (new frame% (label "") (width 500) (height 500)))
+(define e (new vertical-pasteboard%))
+(define c (new aligned-editor-canvas% (parent f) (editor e)))
+
+(define pb (new vertical-pasteboard%))
+(define aes (new aligned-editor-snip%
+                 (editor pb)
+                 (stretchable-width #f)
+                 (stretchable-height #f)))
+(define t2 (new text%))
+(define ses (new stretchable-editor-snip%
+                 (editor t2)
+                 (min-width 100)
+                 (stretchable-width #t)
+                 (stretchable-height #f)))
+(send e insert aes)
+(send pb insert ses)
+
+(send f show #t)
\ No newline at end of file
diff --git a/collects/mrlib/private/aligned-pasteboard/tests/stretchable-editor-snip-test.ss b/collects/mrlib/private/aligned-pasteboard/tests/stretchable-editor-snip-test.ss
new file mode 100644
index 0000000000..f6eaad3195
--- /dev/null
+++ b/collects/mrlib/private/aligned-pasteboard/tests/stretchable-editor-snip-test.ss
@@ -0,0 +1,30 @@
+(require
+ "../aligned-pasteboard.ss"
+ "../aligned-editor-container.ss"
+ "../stretchable-editor-snip.ss"
+ "../snip-lib.ss")
+
+(define f (new frame% (label "") (width 500) (height 500)))
+(define e (new vertical-pasteboard%))
+(define c (new aligned-editor-canvas% (parent f) (editor e)))
+
+(define pb (new vertical-pasteboard%))
+(define aes (new aligned-editor-snip%
+                 (editor pb)
+                 (stretchable-width #f)
+                 (stretchable-height #f)))
+(define t1 (new text%))
+(define es (new editor-snip% (editor t1)))
+(define t2 (new text%))
+(define ses (new stretchable-editor-snip%
+                 (editor t2)
+                 (stretchable-width #t)
+                 (stretchable-height #f)))
+
+(send t1 insert "String")
+(send e insert aes)
+(send pb insert es)
+(send pb insert ses)
+
+(send f show #t)
+(equal? (snip-width es) (snip-width ses))
\ No newline at end of file
diff --git a/collects/mrlib/private/aligned-pasteboard/tests/test-alignment.ss b/collects/mrlib/private/aligned-pasteboard/tests/test-alignment.ss
new file mode 100644
index 0000000000..bd68233e65
--- /dev/null
+++ b/collects/mrlib/private/aligned-pasteboard/tests/test-alignment.ss
@@ -0,0 +1,250 @@
+(require
+ (lib "etc.ss")
+ (lib "list.ss")
+ (lib "match.ss")
+ "../alignment.ss"
+ "test-macro.ss")
+
+;;los-equal? ((listof rect?) (listof rect?) . -> . boolean?)
+;;tests the equality of the list of structures
+(define (los-equal? a b)
+  (equal?
+   (map rect->list a)
+   (map rect->list b)))
+
+;;rect->list (rect? . -> . vector?)
+;;a vector of the fields in the rect
+(define rect->list
+  (match-lambda
+    [($ rect ($ dim x width stretchable-width?) ($ dim y height stretchable-height?))
+     (list x width stretchable-width? y height stretchable-height?)]))
+
+;;empty pasteboard
+(test
+ los-equal?
+ (align 'vertical 100 100 empty)
+ empty)
+
+;;empty pasteboard
+(test
+ los-equal?
+ (align 'horizontal 100 100 empty)
+ empty)
+
+;;one unstretchable snip
+(test
+ los-equal?
+ (align 'vertical
+        100 100
+        (list (make-rect (make-dim 0 10 false)
+                         (make-dim 0 10 false))))
+ (list (make-rect (make-dim 0 10 false)
+                  (make-dim 0 10 false))))
+
+(test
+ los-equal?
+ (align 'horizontal
+        100 100
+        (list (make-rect (make-dim 0 10 false)
+                         (make-dim 0 10 false))))
+ (list (make-rect (make-dim 0 10 false)
+                  (make-dim 0 10 false))))
+
+;;one stretchable snip
+(test
+ los-equal?
+ (align 'vertical
+        100 100
+        (list (make-rect (make-dim 0 10 true)
+                         (make-dim 0 10 true))))
+ (list (make-rect (make-dim 0 100 true)
+                  (make-dim 0 100 true))))
+
+;;two stretchable snips
+(test
+ los-equal?
+ (align 'vertical
+        10
+        10
+        (list
+         (make-rect (make-dim 0 0 true)
+                    (make-dim 0 0 true))
+         (make-rect (make-dim 0 0 true)
+                    (make-dim 0 0 true))))
+ (list
+  (make-rect (make-dim 0 10 true)
+             (make-dim 0 5 true))
+  (make-rect (make-dim 0 10 true)
+             (make-dim 5 5 true))))
+
+;;three stretchable, one too big
+(test
+ los-equal?
+ (align 'vertical
+        50 100
+        (list (make-rect (make-dim 0 0 true)
+                         (make-dim 0 50 true))
+              (make-rect (make-dim 0 0 true)
+                         (make-dim 0 0 true))
+              (make-rect (make-dim 0 0 true)
+                         (make-dim 0 0 true))))
+ (list (make-rect (make-dim 0 50 true)
+                  (make-dim 0 50 true))
+       (make-rect (make-dim 0 50 true)
+                  (make-dim 50 25 true))
+       (make-rect (make-dim 0 50 true)
+                  (make-dim 75 25 true))))
+
+;;three stetchable, one too big, and an unstetchable
+(test
+ los-equal?
+ (align 'vertical
+        50 100
+        (list (make-rect (make-dim 0 0 true)
+                         (make-dim 0 50 true))
+              (make-rect (make-dim 0 0 true)
+                         (make-dim 0 0 true))
+              (make-rect (make-dim 0 0 true)
+                         (make-dim 0 0 true))
+              (make-rect (make-dim 0 50 false)
+                         (make-dim 0 10 false))))
+ (list (make-rect (make-dim 0 50 true)
+                  (make-dim 0 50 true))
+       (make-rect (make-dim 0 50 true)
+                  (make-dim 50 20 true))
+       (make-rect (make-dim 0 50 true)
+                  (make-dim 70 20 true))
+       (make-rect (make-dim 0 50 false)
+                  (make-dim 90 10 false))))
+
+;;failure from test-suite frame
+;;wrong answer given was (list (make-rect 0 0 335.0 10 #t))
+(test
+ los-equal?
+ (align 'vertical
+        335.0
+        563.0
+        (list
+         (make-rect (make-dim 0 10.0 #t)
+                    (make-dim 0 10.0 #t))))
+ (list (make-rect (make-dim 0 335.0 true)
+                  (make-dim 0 563.0 true))))
+
+;;sort of like the previous failed test but with a nonsizable snip
+(test
+ los-equal?
+ (align 'vertical
+        563.0
+        335.0
+        (list
+         (make-rect (make-dim 0 10.0 #t)
+                    (make-dim 0 10.0 #t))
+         (make-rect (make-dim 0 10.0 false)
+                    (make-dim 0 10.0 false))))
+ (list (make-rect (make-dim 0 563.0 true)
+                  (make-dim 0 325.0 true))
+       (make-rect (make-dim 0 10.0 false)
+                  (make-dim 325.0 10.0 false))))
+
+;;something that requires a little modulo in division
+(test
+ los-equal?
+ (align 'vertical
+        10
+        10
+        (list
+         (make-rect (make-dim 0 0 true)
+                    (make-dim 0 0 true))
+         (make-rect (make-dim 0 0 true)
+                    (make-dim 0 0 true))
+         (make-rect (make-dim 0 0 true)
+                    (make-dim 0 0 true))))
+ (list (make-rect (make-dim 0 10 true)
+                  (make-dim 0 4 true))
+       (make-rect (make-dim 0 10 true)
+                  (make-dim 4 3 true))
+       (make-rect (make-dim 0 10 true)
+                  (make-dim 7 3 true))))
+
+;; 1 snip only stretches in off dimention
+(test
+ los-equal?
+ (align 'vertical
+        100
+        400
+        (list
+         (make-rect (make-dim 0 10 true)
+                    (make-dim 0 30 false))))
+ (list (make-rect (make-dim 0 100 true)
+                  (make-dim 0 30 false))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; The following examples of usage were taken from the test-suite tool and turned into test cases ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(test
+ los-equal?
+ (align 'vertical 563.0 335.0 (list))
+ empty)
+
+(test
+ los-equal?
+ (align 'vertical 563.0 335.0
+        (list (make-rect (make-dim 0 241 #t) (make-dim 0 114 #f))))
+ (list (make-rect (make-dim 0 563.0 #t) (make-dim 0 114 #f))))
+
+(test
+ los-equal?
+ (align 'vertical 551.0 102.0
+        (list (make-rect (make-dim 0 34 #t) (make-dim 0 47 #t))
+              (make-rect (make-dim 0 231 #t) (make-dim 0 57 #t))))
+ (list (make-rect (make-dim 0 551.0 #t) (make-dim 0 47 #t))
+       (make-rect (make-dim 0 551.0 #t) (make-dim 47 57 #t))))
+
+(test
+ los-equal?
+ (align 'vertical 539.0 35.0
+        (list (make-rect (make-dim 0 24 #f) (make-dim 0 13 #f))
+              (make-rect (make-dim 0 11 #f) (make-dim 0 24 #f))))
+ (list (make-rect (make-dim 0 24 #f) (make-dim 0 13 #f))
+       (make-rect (make-dim 0 11 #f) (make-dim 13 24 #f))))
+
+(test
+ los-equal?
+ (align 'horizontal 539.0 45.0
+        (list (make-rect (make-dim 0 65 #t) (make-dim 0 47 #t))
+              (make-rect (make-dim 0 48 #t) (make-dim 0 47 #t))
+              (make-rect (make-dim 0 63 #t) (make-dim 0 47 #t))
+              (make-rect (make-dim 0 45 #f) (make-dim 0 44 #f))))
+ (list
+  (make-rect (make-dim 0 165.0 true) (make-dim 0 45.0 true))
+  (make-rect (make-dim 165.0 165.0 true) (make-dim 0 45.0 true))
+  (make-rect (make-dim 330.0 164.0 true) (make-dim 0 45.0 true))
+  (make-rect (make-dim 494.0 45 false) (make-dim 0 44 false))))
+
+(test
+ los-equal?
+ (align 'vertical 153.0 33.0
+        (list (make-rect (make-dim 0 55 #f) (make-dim 0 13 #f))
+              (make-rect (make-dim 0 11 #f) (make-dim 0 24 #f))))
+ (list
+  (make-rect (make-dim 0 55 false) (make-dim 0 13 false))
+  (make-rect (make-dim 0 11 false) (make-dim 13 24 false))))
+
+(test
+ los-equal?
+ (align 'vertical 153.0 33.0
+        (list (make-rect (make-dim 0 38 #f) (make-dim 0 13 #f))
+              (make-rect (make-dim 0 11 #f) (make-dim 0 24 #f))))
+ (list
+  (make-rect (make-dim 0 38 false) (make-dim 0 13 false))
+  (make-rect (make-dim 0 11 false) (make-dim 13 24 false))))
+
+(test
+ los-equal?
+ (align 'vertical 152.0 33.0
+        (list (make-rect (make-dim 0 26 #f) (make-dim 0 13 #f))
+              (make-rect (make-dim 0 53 #f) (make-dim 0 24 #f))))
+ (list
+  (make-rect (make-dim 0 26 false) (make-dim 0 13 false))
+  (make-rect (make-dim 0 53 false) (make-dim 13 24 false))))
\ No newline at end of file
diff --git a/collects/mrlib/private/aligned-pasteboard/tests/test-locked-pasteboard.ss b/collects/mrlib/private/aligned-pasteboard/tests/test-locked-pasteboard.ss
new file mode 100644
index 0000000000..a385380478
--- /dev/null
+++ b/collects/mrlib/private/aligned-pasteboard/tests/test-locked-pasteboard.ss
@@ -0,0 +1,19 @@
+(require
+ "../locked-pasteboard.ss"
+ (lib "click-forwarding-editor.ss" "mrlib"))
+
+(define f (new frame% (width 400) (height 500) (label "test")))
+(define e (new (click-forwarding-editor-mixin (locked-pasteboard-mixin pasteboard%))))
+(define c (new editor-canvas% (parent f) (editor e)))
+(define t (new text%))
+(define s (new editor-snip% (editor t)))
+(send e insert s 0 100)
+(define t2 (new text%))
+(define s2 (new editor-snip% (editor t2)))
+(send e insert s2 100 0)
+(send f show #t)
+;; This test is not automated. To test it try to use the pasteboard that appears.
+;(test:mouse-click 'left 0 100)
+;(test:keystroke #\A)
+;(string=? (send s get-text) "A")
+;(send f show #f)
\ No newline at end of file
diff --git a/collects/mrlib/private/aligned-pasteboard/tests/test-macro.ss b/collects/mrlib/private/aligned-pasteboard/tests/test-macro.ss
new file mode 100644
index 0000000000..16dc24bca7
--- /dev/null
+++ b/collects/mrlib/private/aligned-pasteboard/tests/test-macro.ss
@@ -0,0 +1,16 @@
+(module test-macro mzscheme
+  
+  (provide test)
+  
+  ;; test: (lambda (a?) ((a? a? . -> . boolean?) a? a? . -> . (void))
+  ;; tests to see if the expression is true and prints and error if it's not
+  (define-syntax test
+    (syntax-rules (identity)
+      ((_ test actual expected)
+       (let ([result
+              (with-handlers
+                  ([exn? identity])
+                actual)])
+         (and (not (exn? result))
+              (test result expected))))))
+  )
\ No newline at end of file
diff --git a/collects/mrlib/private/aligned-pasteboard/tests/test-pasteboard-lib.ss b/collects/mrlib/private/aligned-pasteboard/tests/test-pasteboard-lib.ss
new file mode 100644
index 0000000000..ef99509f1e
--- /dev/null
+++ b/collects/mrlib/private/aligned-pasteboard/tests/test-pasteboard-lib.ss
@@ -0,0 +1,204 @@
+(require
+ (lib "etc.ss")
+ (lib "class.ss")
+ "test-macro.ss"
+ (lib "mred.ss" "mred")
+ "../pasteboard-lib.ss"
+ "../aligned-pasteboard.ss"
+ "../aligned-editor-container.ss")
+
+(printf "running tests for pasteboard-lib.ss~n")
+
+;;pasteboard-root: ((is-a?/c aligned-pasteboard<%>) -> (is-a?/c aligned-pasteboard<%>))
+;;gets the top most aligned pasteboard in the tree of pasteboards and containers
+
+(let*
+    ([pb1 (instantiate aligned-vertical-pasteboard% ())]
+     [pb2 (instantiate aligned-horizontal-pasteboard% ())]
+     [pb3 (instantiate aligned-vertical-pasteboard% ())]
+     [es2 (instantiate aligned-editor-snip% () (editor pb2))]
+     [es3 (instantiate aligned-editor-snip% () (editor pb3))]
+     
+     [frame (instantiate frame% () (label "l") (width 10) (height 10))]
+     [canvas (instantiate aligned-editor-canvas% () (parent frame) (editor pb1))])
+  
+  (send pb1 insert es2)
+  (send pb2 insert es3)
+  
+  (test
+   equal?
+   (pasteboard-root pb3)
+   pb1)
+  
+  (test
+   equal?
+   (pasteboard-root pb2)
+   pb1)
+  
+  (test
+   equal?
+   (pasteboard-root pb1)
+   pb1)
+  )
+
+(let*
+    ([pb1 (instantiate aligned-vertical-pasteboard% ())]
+     [pb2 (instantiate aligned-horizontal-pasteboard% ())]
+     [pb3 (instantiate aligned-vertical-pasteboard% ())]
+     [es1 (instantiate aligned-editor-snip% () (editor pb1))]
+     [es3 (instantiate aligned-editor-snip% () (editor pb3))]
+     
+     [frame (instantiate frame% () (label "l") (width 10) (height 10))]
+     [canvas (instantiate aligned-editor-canvas% () (parent frame) (editor pb2))])
+  
+  (send pb2 insert es1)
+  (send pb2 insert es3)
+  
+  (test
+   equal?
+   (pasteboard-root pb3)
+   pb2)
+  
+  (test
+   equal?
+   (pasteboard-root pb2)
+   pb2)
+  
+  (test
+   equal?
+   (pasteboard-root pb1)
+   pb2)
+  )
+
+;;pasteboard-parent: ((is-a?/c pasteboard%) . -> . (is-a?/c aligned-editor-container<%>))
+;;gets the canvas or snip that the pasteboard is displayed in
+(let*
+    ([pb1 (instantiate aligned-vertical-pasteboard% ())]
+     [pb2 (instantiate aligned-horizontal-pasteboard% ())]
+     [pb3 (instantiate aligned-vertical-pasteboard% ())]
+     [es2 (instantiate aligned-editor-snip% () (editor pb2))]
+     [es3 (instantiate aligned-editor-snip% () (editor pb3))]
+     
+     [frame (instantiate frame% () (label "l") (width 10) (height 10))]
+     [canvas (instantiate aligned-editor-canvas% () (parent frame) (editor pb1))])
+  
+  (send pb1 insert es2)
+  (send pb2 insert es3)
+  
+  (test
+   equal?
+   (pasteboard-parent pb1)
+   canvas)
+  
+  (test
+   equal?
+   (pasteboard-parent pb2)
+   es2)
+  
+  (test
+   equal?
+   (pasteboard-parent pb3)
+   es3)
+  )
+
+(let*
+    ([pb1 (instantiate aligned-vertical-pasteboard% ())]
+     [pb2 (instantiate aligned-horizontal-pasteboard% ())]
+     [pb3 (instantiate aligned-vertical-pasteboard% ())]
+     [es2 (instantiate aligned-editor-snip% () (editor pb2))]
+     [es3 (instantiate aligned-editor-snip% () (editor pb3))]
+     
+     [frame (instantiate frame% () (label "l") (width 10) (height 10))]
+     [canvas (instantiate aligned-editor-canvas% () (parent frame) (editor pb1))])
+  
+  (send pb1 insert es2)
+  (send pb1 insert es3)
+  
+  (test
+   equal?
+   (pasteboard-parent pb1)
+   canvas)
+  
+  (test
+   equal?
+   (pasteboard-parent pb2)
+   es2)
+  
+  (test
+   equal?
+   (pasteboard-parent pb3)
+   es3)
+  )
+
+;;num-sizeable: ((is-a?/c aligned-pasteboard<%>) . -> . number?)
+;;the number of snips in the pasteboard that can be resized
+(let*
+    ([pb1 (instantiate aligned-vertical-pasteboard% ())]
+     [es1 (instantiate editor-snip% () (editor (instantiate text% ())))]
+     [es2 (instantiate editor-snip% () (editor (instantiate text% ())))]
+     [es3 (instantiate editor-snip% () (editor (instantiate text% ())))]
+     [es4 (instantiate editor-snip% () (editor (instantiate text% ())))]
+     
+     [frame (instantiate frame% () (label "l") (width 10) (height 10))]
+     [canvas (instantiate aligned-editor-canvas% () (parent frame) (editor pb1))])
+  (send frame show true)
+  
+  (send pb1 insert es1)
+  (send pb1 insert es2)
+  (send pb1 insert es3)
+  (send pb1 insert es4)
+  
+  (test
+   =
+   (num-sizeable pb1)
+   0)
+  
+  (send pb1 delete es1)
+  
+  (test
+   =
+   (num-sizeable pb1)
+   0)
+  
+  (send frame show false)
+  )
+
+(let*
+    ([pb1 (instantiate aligned-vertical-pasteboard% ())]
+     [es1 (instantiate aligned-editor-snip% () (editor (instantiate aligned-vertical-pasteboard% ())))]
+     [es2 (instantiate aligned-editor-snip% () (editor (instantiate aligned-vertical-pasteboard% ())))]
+     [es3 (instantiate aligned-editor-snip% () (editor (instantiate aligned-vertical-pasteboard% ())))]
+     [es4 (instantiate aligned-editor-snip% () (editor (instantiate aligned-vertical-pasteboard% ())))]
+     
+     [frame (instantiate frame% () (label "l") (width 10) (height 10))]
+     [canvas (instantiate aligned-editor-canvas% () (parent frame) (editor pb1))])
+  (send frame show true)
+  
+  (send pb1 insert es1)
+  (send pb1 insert es2)
+  (send pb1 insert es3)
+  (send pb1 insert es4)
+  
+  (test
+   =
+   (num-sizeable pb1)
+   4)
+  
+  (send pb1 delete es1)
+  
+  (test
+   =
+   (num-sizeable pb1)
+   3)
+  
+  (send pb1 erase)
+  
+  (test
+   =
+   (num-sizeable pb1)
+   0)
+  
+  (send frame show false)
+  )
+
+(printf "tests done~n")
\ No newline at end of file
diff --git a/collects/mrlib/private/aligned-pasteboard/tests/test-snip-lib.ss b/collects/mrlib/private/aligned-pasteboard/tests/test-snip-lib.ss
new file mode 100644
index 0000000000..0eb51b2ca8
--- /dev/null
+++ b/collects/mrlib/private/aligned-pasteboard/tests/test-snip-lib.ss
@@ -0,0 +1,207 @@
+(require
+ (lib "etc.ss")
+ (lib "class.ss")
+ (lib "mred.ss" "mred")
+ "../snip-lib.ss"
+ "../aligned-pasteboard.ss"
+ "../aligned-editor-container.ss"
+ "test-macro.ss")
+
+(printf "running tests for snip-lib.ss~n")
+
+;;snip-width: ((is-a?/c aligned-pasteboard<%>) (is-a?/c snip%) . -> . number?)
+;;the width of a snip in the given pasteboard
+(let*
+    ([pb1 (instantiate aligned-vertical-pasteboard% ())]
+     [es1 (instantiate editor-snip% () (editor pb1))]
+     [pb2 (instantiate aligned-vertical-pasteboard% ())]
+     
+     [frame (instantiate frame% () (label "l") (width 10) (height 10))]
+     [canvas (instantiate aligned-editor-canvas% () (parent frame) (editor pb2))])
+  (send frame show true)
+  
+  (send pb2 insert es1)
+  (send es1 resize 20 20)
+  (sleep/yield 1)
+  (test
+   equal?
+   (snip-width pb2 es1)
+   20)
+  
+  (send es1 resize 200 90)
+  (sleep/yield 1)
+  (test
+   equal?
+   (snip-width pb2 es1)
+   200)
+  
+  (send frame show false)
+  )
+
+;;snip-height: ((is-a?/c aligned-pasteboard<%>) (is-a?/c snip%) . -> . number?)
+;;the height of a snip in the given pasteboard
+(let*
+    ([pb1 (instantiate aligned-vertical-pasteboard% ())]
+     [es1 (instantiate editor-snip% () (editor pb1))]
+     [pb2 (instantiate aligned-vertical-pasteboard% ())]
+     
+     [frame (instantiate frame% () (label "l") (width 10) (height 10))]
+     [canvas (instantiate aligned-editor-canvas% () (parent frame) (editor pb2))])
+  (send frame show true)
+  
+  (send pb2 insert es1)
+  (send es1 resize 20 20)
+  (sleep/yield 1)
+  (test
+   equal?
+   (snip-height pb2 es1)
+   20)
+  
+  (send es1 resize 200 90)
+  (sleep/yield 1)
+  (test
+   equal?
+   (snip-height pb2 es1)
+   90)
+  
+  (send frame show false)
+  )
+
+;;snip-min-width: ((is-a?/c snip%) . -> . number?)
+;;the minimum width of the snip
+
+;;snip-min-height: ((is-a?/c snip%) . -> . number?)
+;;the minimum height of the snip
+
+;;snip-parent: ((is-a?/c snip%) . -> . (is-a?/c editor<%>))
+;;the pasteboard that contains the snip
+(let*
+    ([pb1 (instantiate pasteboard% ())]
+     [es1 (instantiate editor-snip% () (editor pb1))]
+     [pb2 (instantiate pasteboard% ())]
+     
+     [frame (instantiate frame% () (label "l") (width 10) (height 10))]
+     [canvas (instantiate editor-canvas% () (parent frame) (editor pb2))])
+  (send frame show true)
+  
+  (send pb2 insert es1)
+  
+  (test
+   equal?
+   (snip-parent es1)
+   pb2)
+  
+  (send frame show false)
+  )
+
+(let*
+    ([pb1 (instantiate aligned-horizontal-pasteboard% ())]
+     [pb2 (instantiate aligned-horizontal-pasteboard% ())]
+     [pb3 (instantiate aligned-horizontal-pasteboard% ())]
+     [pb4 (instantiate aligned-horizontal-pasteboard% ())]
+     [pb5 (instantiate aligned-horizontal-pasteboard% ())]
+     [es2 (instantiate aligned-editor-snip% () (editor pb2))]
+     [es3 (instantiate aligned-editor-snip% () (editor pb3))]
+     [es4 (instantiate aligned-editor-snip% () (editor pb4))]
+     [es5 (instantiate aligned-editor-snip% () (editor pb5))]
+     
+     [frame (instantiate frame% () (label "l") (width 10) (height 10))]
+     [canvas (instantiate aligned-editor-canvas% () (parent frame) (editor pb1))])
+  (send frame show true)
+  (send pb1 insert es2)
+  (send pb2 insert es3)
+  (send pb3 insert es4)
+  (send pb4 insert es5)
+  
+  (test
+   equal?
+   (snip-parent es2)
+   pb1)
+  
+  (test
+   equal?
+   (snip-parent es3)
+   pb2)
+  
+  (test
+   equal?
+   (snip-parent es4)
+   pb3)
+  
+  (test
+   equal?
+   (snip-parent es5)
+   pb4)
+  
+  (send frame show false)
+  )
+
+;;fold-snip: (lambda (b?) ((any? b? . -> . b?) b? (is-a?/c snip%) . -> . b?))
+;;the application of f on all snips from snip to the end in a foldl foldr mannor
+(let*
+    ([pb1 (instantiate aligned-vertical-pasteboard% ())]
+     [es1 (instantiate editor-snip% () (editor (instantiate text% ())))]
+     [es2 (instantiate editor-snip% () (editor (instantiate text% ())))]
+     [es3 (instantiate editor-snip% () (editor (instantiate text% ())))]
+     [es4 (instantiate editor-snip% () (editor (instantiate text% ())))]
+     
+     [frame (instantiate frame% () (label "l") (width 10) (height 10))]
+     [canvas (instantiate aligned-editor-canvas% () (parent frame) (editor pb1))])
+  (send frame show true)
+  
+  (send pb1 insert es1)
+  (send pb1 insert es2)
+  (send pb1 insert es3)
+  (send pb1 insert es4)
+  
+  (send es1 resize 100 100)
+  (send es2 resize 100 100)
+  (send es3 resize 100 100)
+  (send es4 resize 100 100)
+  
+  (test
+   =
+   (fold-snip
+    (lambda (snip total-height)
+      (+ (snip-height pb1 snip)
+         total-height))
+    0
+    es4)
+   400)
+  
+  (send frame show false)
+  )
+
+  
+;;for-each-snip: (((is-a?/c snip%) . -> . (void)) (is-a/c? snip%) . -> . (void))
+;;applies the function to all the snips
+(let*
+    ([pb1 (instantiate aligned-vertical-pasteboard% ())]
+     [es1 (instantiate editor-snip% () (editor (instantiate text% ())))]
+     [es2 (instantiate editor-snip% () (editor (instantiate text% ())))]
+     [es3 (instantiate editor-snip% () (editor (instantiate text% ())))]
+     [es4 (instantiate editor-snip% () (editor (instantiate text% ())))]
+     
+     [frame (instantiate frame% () (label "l") (width 10) (height 10))]
+     [canvas (instantiate aligned-editor-canvas% () (parent frame) (editor pb1))]
+     [count 0])
+  (send frame show true)
+  
+  (send pb1 insert es1)
+  (send pb1 insert es2)
+  (send pb1 insert es3)
+  (send pb1 insert es4)
+  
+  (for-each-snip
+   (lambda (snip)
+     (set! count (add1 count)))
+   es4)
+  
+  (test
+   =
+   count
+   4)
+  
+  (send frame show false)
+  )
+(printf "tests done~n")
diff --git a/collects/mrlib/private/aligned-pasteboard/tests/test.ss b/collects/mrlib/private/aligned-pasteboard/tests/test.ss
new file mode 100644
index 0000000000..168701cfa8
--- /dev/null
+++ b/collects/mrlib/private/aligned-pasteboard/tests/test.ss
@@ -0,0 +1,231 @@
+(require
+ (lib "class.ss")
+ (lib "mred.ss" "mred")
+ (lib "etc.ss")
+ (lib "list.ss")
+ "../aligned-pasteboard.ss"
+ "../aligned-editor-container.ss"
+ "snip-dumper.ss")
+
+                                                        
+                                                        
+;                                     ;;                 
+;                                      ;                 
+;                                      ;                 
+;  ;;;;; ;;  ;;  ;;;;;;;;;;;;;; ;;;    ;     ;;;;;  ;;;; 
+; ;    ;  ;;;;      ; ;  ;  ; ;;  ;;   ;    ;    ; ;   ; 
+; ;;;;;;   ;;    ;;;; ;  ;  ; ;    ;   ;    ;;;;;; ;;;;  
+; ;        ;;   ;   ; ;  ;  ; ;    ;   ;    ;          ; 
+; ;;   ;  ;  ;  ;   ; ;  ;  ; ;;  ;;   ;    ;;   ; ;   ; 
+;  ;;;;  ;;  ;;  ;;;;;;; ;; ;;; ;;;  ;;;;;   ;;;;  ;;;;  
+;                             ;                          
+;                            ;;;                         
+                                                        
+(printf "running test1.ss~n")
+
+(define frame
+  (instantiate frame% ()
+    (label "Frame")
+    (width 400)
+    (height 400)))
+
+(define pasteboard
+  (instantiate horizontal-pasteboard% ()))
+
+(define canvas
+  (instantiate aligned-editor-canvas% ()
+    (parent frame)
+    (editor pasteboard)))
+
+(define insider
+  (instantiate vertical-pasteboard% ()))
+
+(define insider2
+  (instantiate vertical-pasteboard% ()))
+
+(define insider3
+  (instantiate vertical-pasteboard% ()))
+
+(define insider4
+  (instantiate vertical-pasteboard% ()))
+
+(define insider5
+  (instantiate vertical-pasteboard% ()))
+
+(define insider6
+  (instantiate vertical-pasteboard% ()))
+
+(define insider7
+  (instantiate vertical-pasteboard% ()))
+
+(define pb-snip
+  (instantiate aligned-editor-snip% ()
+    (editor insider)))
+
+(define pb-snip2
+  (instantiate aligned-editor-snip% ()
+    (editor insider2)))
+
+(define pb-snip3
+  (instantiate aligned-editor-snip% ()
+    (editor insider3)))
+
+(define pb-snip4
+  (instantiate aligned-editor-snip% ()
+    (editor insider4)))
+
+(define pb-snip5
+  (instantiate aligned-editor-snip% ()
+    (editor insider5)))
+
+(define pb-snip6
+  (instantiate aligned-editor-snip% ()
+    (editor insider6)))
+
+(define pb-snip7
+  (instantiate aligned-editor-snip% ()
+    (editor insider7)))
+
+(define t-snip
+  (instantiate editor-snip% ()
+    (editor
+     (instantiate text% ()))))
+
+(define i-snip
+  (instantiate image-snip% ()))
+
+(define i-snip2
+  (instantiate image-snip% ()))
+
+(define t-snip2
+  (instantiate editor-snip% ()
+    (editor
+     (instantiate text% ()))))
+(define t-snip3
+  (instantiate editor-snip% ()
+    (editor
+     (instantiate text% ()))))
+
+(send pasteboard begin-edit-sequence)
+(send frame show true)
+(send pasteboard insert pb-snip)
+(send pasteboard insert t-snip)
+(send pasteboard insert i-snip)
+(send pasteboard insert i-snip2)
+(send pasteboard insert pb-snip2)
+(send pasteboard insert t-snip2)
+(send insider insert t-snip3)
+(send insider2 insert pb-snip3)
+(send insider2 insert pb-snip4)
+(send pasteboard insert pb-snip5)
+(send pasteboard insert pb-snip6)
+(send pasteboard insert pb-snip7)
+(send pasteboard end-edit-sequence)
+
+
+
+
+; ;                    ;            
+; ;                    ;            
+;;;;;;;   ;;;;;  ;;;; ;;;;;    ;;;; 
+; ;      ;    ; ;   ;  ;      ;   ; 
+; ;      ;;;;;; ;;;;   ;      ;;;;  
+; ;      ;          ;  ;          ; 
+; ;      ;;   ; ;   ;  ;      ;   ; 
+; ;;;;;   ;;;;  ;;;;   ;;;;;  ;;;;  
+
+
+
+
+(dump=?
+ (dump-children pasteboard)
+ (list
+  (make-snip-dump 57.0 368.0 0.0 0.0 empty)
+  (make-snip-dump 114.0 368.0 57.0 0.0 empty)
+  (make-snip-dump 171.0 368.0 114.0 0.0 empty)
+  (make-snip-dump 182.0 24.0 171.0 0.0 empty)
+  (make-snip-dump
+   249.0
+   368.0
+   182.0
+   0.0
+   (list (make-snip-dump 55.0 178.0 0.0 0.0 empty) (make-snip-dump 55.0 356.0 0.0 178.0 empty)))
+  (make-snip-dump 269.0 20.0 249.0 0.0 false)
+  (make-snip-dump 289.0 20.0 269.0 0.0 false)
+  (make-snip-dump 300.0 24.0 289.0 0.0 empty)
+  (make-snip-dump 368.0 368.0 300.0 0.0 (list (make-snip-dump 11.0 24.0 0.0 0.0 empty))))
+ )
+
+(send frame resize 0 0)
+(sleep/yield 1)
+
+(dump=?
+ (dump-children pasteboard)
+ (list
+  (make-snip-dump 10.0 34.0 0.0 0.0 empty)
+  (make-snip-dump 20.0 34.0 10.0 0.0 empty)
+  (make-snip-dump 30.0 34.0 20.0 0.0 empty)
+  (make-snip-dump 41.0 24.0 30.0 0.0 empty)
+  (make-snip-dump
+   61.0
+   34.0
+   41.0
+   0.0
+   (list (make-snip-dump 10.0 11.0 0.0 0.0 empty) (make-snip-dump 10.0 22.0 0.0 11.0 empty)))
+  (make-snip-dump 81.0 20.0 61.0 0.0 false)
+  (make-snip-dump 101.0 20.0 81.0 0.0 false)
+  (make-snip-dump 112.0 24.0 101.0 0.0 empty)
+  (make-snip-dump 133.0 34.0 112.0 0.0 (list (make-snip-dump 11.0 24.0 0.0 0.0 empty))))
+ )
+
+(send frame resize 800 600)
+(sleep/yield 1)
+
+(dump=?
+ (dump-children pasteboard)
+ (list
+  (make-snip-dump 137.0 568.0 0.0 0.0 empty)
+  (make-snip-dump 274.0 568.0 137.0 0.0 empty)
+  (make-snip-dump 411.0 568.0 274.0 0.0 empty)
+  (make-snip-dump 422.0 24.0 411.0 0.0 empty)
+  (make-snip-dump
+   569.0
+   568.0
+   422.0
+   0.0
+   (list (make-snip-dump 135.0 278.0 0.0 0.0 empty) (make-snip-dump 135.0 556.0 0.0 278.0 empty)))
+  (make-snip-dump 589.0 20.0 569.0 0.0 false)
+  (make-snip-dump 609.0 20.0 589.0 0.0 false)
+  (make-snip-dump 620.0 24.0 609.0 0.0 empty)
+  (make-snip-dump 768.0 568.0 620.0 0.0 (list (make-snip-dump 11.0 24.0 0.0 0.0 empty))))
+ )
+
+(send frame resize 400 400)
+(send pasteboard delete i-snip)
+(send pasteboard delete i-snip2)
+
+(dump=?
+ (dump-children pasteboard)
+ (list
+  (make-snip-dump 65.0 368.0 0.0 0.0 empty)
+  (make-snip-dump 130.0 368.0 65.0 0.0 empty)
+  (make-snip-dump 195.0 368.0 130.0 0.0 empty)
+  (make-snip-dump 206.0 24.0 195.0 0.0 empty)
+  (make-snip-dump
+   281.0
+   368.0
+   206.0
+   0.0
+   (list (make-snip-dump 63.0 178.0 0.0 0.0 empty) (make-snip-dump 63.0 356.0 0.0 178.0 empty)))
+  (make-snip-dump 292.0 24.0 281.0 0.0 empty)
+  (make-snip-dump 368.0 368.0 292.0 0.0 (list (make-snip-dump 11.0 24.0 0.0 0.0 empty))))
+ )
+
+(send pasteboard erase)
+(dump=?
+ (dump-children pasteboard)
+ empty
+ )
+
+(send frame show false)
+(printf "done~n")
\ No newline at end of file
diff --git a/collects/mrlib/private/aligned-pasteboard/tests/test2.ss b/collects/mrlib/private/aligned-pasteboard/tests/test2.ss
new file mode 100644
index 0000000000..6d81df05b0
--- /dev/null
+++ b/collects/mrlib/private/aligned-pasteboard/tests/test2.ss
@@ -0,0 +1,189 @@
+(require
+ (lib "class.ss")
+ (lib "mred.ss" "mred")
+ (lib "etc.ss")
+ (lib "list.ss")
+ "../aligned-pasteboard.ss"
+ "../aligned-editor-container.ss"
+ "snip-dumper.ss")
+
+;                                                          
+;                                                          
+;                                       ;;                 
+;                                        ;                 
+;                                        ;                 
+;    ;;;;; ;;  ;;  ;;;;;;;;;;;;;; ;;;    ;     ;;;;;  ;;;; 
+;   ;    ;  ;;;;      ; ;  ;  ; ;;  ;;   ;    ;    ; ;   ; 
+;   ;;;;;;   ;;    ;;;; ;  ;  ; ;    ;   ;    ;;;;;; ;;;;  
+;   ;        ;;   ;   ; ;  ;  ; ;    ;   ;    ;          ; 
+;   ;;   ;  ;  ;  ;   ; ;  ;  ; ;;  ;;   ;    ;;   ; ;   ; 
+;    ;;;;  ;;  ;;  ;;;;;;; ;; ;;; ;;;  ;;;;;   ;;;;  ;;;;  
+;                               ;                          
+;                              ;;;                         
+;                                                          
+
+(printf "running test2.ss~n")
+
+(define frame
+  (instantiate frame% ()
+    (label "Frame")
+    (width 400)
+    (height 400)))
+
+(define pasteboard
+  (instantiate horizontal-pasteboard% ()))
+
+(define canvas
+  (instantiate aligned-editor-canvas% ()
+    (parent frame)
+    (editor pasteboard)))
+
+(define vp1
+  (instantiate vertical-pasteboard% ()))
+
+(define ae-snip1
+  (instantiate aligned-editor-snip% ()
+    (editor vp1)))
+
+(define vp2
+  (instantiate vertical-pasteboard% ()))
+
+(define ae-snip2
+  (instantiate aligned-editor-snip% ()
+    (editor vp2)))
+
+(define vp3
+  (instantiate vertical-pasteboard% ()))
+
+(define ae-snip3
+  (instantiate aligned-editor-snip% ()
+    (editor vp3)))
+
+(define vp4
+  (instantiate vertical-pasteboard% ()))
+
+(define ae-snip4
+  (instantiate aligned-editor-snip% ()
+    (editor vp4)))
+
+(define vp5
+  (instantiate vertical-pasteboard% ()))
+
+(define ae-snip5
+  (instantiate aligned-editor-snip% ()
+    (editor vp5)))
+
+(send pasteboard insert ae-snip1)
+(send pasteboard insert ae-snip2)
+(send pasteboard insert ae-snip5)
+(send vp2 insert ae-snip3)
+(send vp2 insert ae-snip4)
+(send frame show true)
+
+;                                     
+;                                     
+;                                     
+;   ;                    ;            
+;   ;                    ;            
+;  ;;;;;    ;;;;;  ;;;; ;;;;;    ;;;; 
+;   ;      ;    ; ;   ;  ;      ;   ; 
+;   ;      ;;;;;; ;;;;   ;      ;;;;  
+;   ;      ;          ;  ;          ; 
+;   ;      ;;   ; ;   ;  ;      ;   ; 
+;   ;;;;;   ;;;;  ;;;;   ;;;;;  ;;;;  
+;                                     
+;                                     
+;                                     
+
+(sleep/yield 1)
+(dump=?
+ (dump-children pasteboard)
+ (list
+  (make-snip-dump 120.0 368.0 0.0 0.0 empty)
+  (make-snip-dump
+   249.0
+   368.0
+   120.0
+   0.0
+   (list (make-snip-dump 117.0 178.0 0.0 0.0 empty) (make-snip-dump 117.0 356.0 0.0 178.0 empty)))
+  (make-snip-dump 368.0 368.0 249.0 0.0 empty))
+ )
+
+(send frame resize 0 0)
+(sleep/yield 1)
+(dump=?
+ (dump-children pasteboard)
+ (list
+  (make-snip-dump 10.0 30.0 0.0 0.0 empty)
+  (make-snip-dump
+   30.0
+   30.0
+   10.0
+   0.0
+   (list (make-snip-dump 10.0 10.0 0.0 0.0 empty) (make-snip-dump 10.0 19.0 0.0 9.0 empty)))
+  (make-snip-dump 40.0 30.0 30.0 0.0 empty))
+ )
+
+(send frame resize 800 600)
+(sleep/yield 1)
+(dump=?
+ (dump-children pasteboard)
+ (list
+  (make-snip-dump 253.0 568.0 0.0 0.0 empty)
+  (make-snip-dump
+   516.0
+   568.0
+   253.0
+   0.0
+   (list (make-snip-dump 251.0 278.0 0.0 0.0 empty) (make-snip-dump 251.0 556.0 0.0 278.0 empty)))
+  (make-snip-dump 768.0 568.0 516.0 0.0 empty))
+ )
+
+(send pasteboard delete ae-snip5)
+(dump=?
+ (dump-children pasteboard)
+ (list
+  (make-snip-dump
+   389.0
+   568.0
+   0.0
+   0.0
+   (list (make-snip-dump 377.0 278.0 0.0 0.0 empty) (make-snip-dump 377.0 556.0 0.0 278.0 empty)))
+  (make-snip-dump 768.0 568.0 389.0 0.0 empty))
+ )
+
+(send pasteboard insert ae-snip5)
+(dump=?
+ (dump-children pasteboard)
+ (list
+  (make-snip-dump 253.0 568.0 0.0 0.0 empty)
+  (make-snip-dump
+   516.0
+   568.0
+   253.0
+   0.0
+   (list (make-snip-dump 251.0 278.0 0.0 0.0 empty) (make-snip-dump 251.0 556.0 0.0 278.0 empty)))
+  (make-snip-dump 768.0 568.0 516.0 0.0 empty))
+ )
+
+(send pasteboard delete ae-snip5)
+(send pasteboard delete ae-snip1)
+(dump=?
+ (dump-children pasteboard)
+ (list
+  (make-snip-dump
+   768.0
+   568.0
+   0.0
+   0.0
+   (list (make-snip-dump 756.0 278.0 0.0 0.0 empty) (make-snip-dump 756.0 556.0 0.0 278.0 empty))))
+ )
+
+(send pasteboard erase)
+(dump=?
+ (dump-children pasteboard)
+ empty
+ )
+
+(send frame show false)
+(printf "done~n")
diff --git a/collects/mrlib/private/info.ss b/collects/mrlib/private/info.ss
new file mode 100644
index 0000000000..96f8d1d235
--- /dev/null
+++ b/collects/mrlib/private/info.ss
@@ -0,0 +1,2 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "MrLib private"))
diff --git a/collects/mrlib/syntax-browser.ss b/collects/mrlib/syntax-browser.ss
new file mode 100644
index 0000000000..ac1274bcdb
--- /dev/null
+++ b/collects/mrlib/syntax-browser.ss
@@ -0,0 +1,594 @@
+#|
+
+needed to really make this work:
+
+  - marshallable syntax objects (compile and write out the compiled form)
+  - support for generic ports that are editors
+
+|#
+
+(module syntax-browser mzscheme
+  (require (lib "pretty.ss")
+           (lib "list.ss")
+           (lib "class.ss")
+           (lib "mred.ss" "mred")
+           (lib "match.ss")
+           (lib "string.ss"))
+  
+  (provide render-syntax/snip render-syntax/window snip-class)
+  
+  (define (render-syntax/window syntax)
+    (let ([es (render-syntax/snip syntax)])
+      (define f (make-object frame% "frame" #f 850 500))
+      (define mb (make-object menu-bar% f))
+      (define edit-menu (make-object menu% "Edit" mb))
+      (define t (make-object text%))
+      (define ec (make-object editor-canvas% f t))
+      (append-editor-operation-menu-items edit-menu)
+      (send t insert es)
+      (send f show #t)))
+
+  (define (render-syntax/snip stx) (make-object syntax-snip% stx))
+  
+  (define syntax-snipclass%
+    (class snip-class%
+      (define/override (read stream)
+        (let ([str (send stream get-bytes)])
+          (make-object syntax-snip% (unmarshall-syntax (read-from-string (bytes->string/utf-8 str))))))
+      (super-instantiate ())))
+  
+  (define snip-class (make-object syntax-snipclass%))
+  (send snip-class set-version 1)
+  (send snip-class set-classname (format "~s" '(lib "syntax-browser.ss" "mrlib")))
+  (send (get-the-snip-class-list) add snip-class)
+  
+  (define-struct range (obj start end))
+
+  (define syntax-snip%
+    (class editor-snip%
+      (init-field main-stx)
+      
+      (unless (syntax? main-stx)
+        (error 'syntax-snip% "got non-syntax object"))
+      
+      (define/public (get-syntax) main-stx)
+      
+      (define/override (copy) (make-object syntax-snip% main-stx))
+      (define/override (write stream)
+        (send stream put (string->bytes/utf-8 (format "~s" (marshall-syntax main-stx)))))
+      
+      (define-values (datum stx-ht) (syntax-object->datum/ht main-stx))
+      
+      (define output-text (make-object text%))
+      (define output-port (make-text-port output-text))
+      (define info-text (make-object text%))
+      (define info-port (make-text-port info-text))
+      
+      ;; assume that there aren't any eq? sub structures, only eq? flat stuff (symbols, etc)
+      ;; this is guaranteed by syntax-object->datum/ht
+      
+      ;; range-start-ht : hash-table[obj -o> number]
+      (define range-start-ht (make-hash-table))
+
+      ;; range-ht : hash-table[obj -o> (listof (cons number number))]
+      (define range-ht (make-hash-table))
+      
+      (define/private (make-modern text)
+        (send text change-style
+              (make-object style-delta% 'change-family 'modern)
+              0
+              (send text last-position)))
+      
+      (let ([range-pretty-print-pre-hook 
+             (λ (x v)
+               (hash-table-put! range-start-ht x (send output-text last-position)))]
+            [range-pretty-print-post-hook 
+             (λ (x port)
+               (let ([range-start (hash-table-get range-start-ht x (λ () #f))])
+                 (when range-start
+                   (hash-table-put! range-ht x 
+                                    (cons
+                                     (cons
+                                      range-start
+                                      (send output-text last-position))
+                                     (hash-table-get range-ht x (λ () null)))))))])
+        (parameterize ([current-output-port output-port]
+                       [pretty-print-pre-print-hook range-pretty-print-pre-hook]
+                       [pretty-print-post-print-hook range-pretty-print-post-hook]
+                       [pretty-print-columns 30])
+          (pretty-print datum)
+          (make-modern output-text)))
+      
+      (define/private (show-info stx)
+        (insert/big "General Info\n")
+        (piece-of-info "Source" (syntax-source stx))
+        (piece-of-info "Source module" (syntax-source-module stx))
+        (piece-of-info "Position" (syntax-position stx))
+        (piece-of-info "Line" (syntax-line stx))
+        (piece-of-info "Column" (syntax-column stx))
+        (piece-of-info "Span" (syntax-span stx))
+        (piece-of-info "Original?" (syntax-original? stx))
+        (when (identifier? stx)
+          (piece-of-info "Identifier-binding" (identifier-binding stx))
+          (piece-of-info "Identifier-transformer-binding" (identifier-transformer-binding stx)))
+        
+	(let ([properties (syntax-property-symbol-keys stx)])
+	  (unless (null? properties)
+	    (insert/big "Known properties\n")
+	    (for-each
+	     (λ (prop) (show-property stx prop))
+	     properties))))
+      
+      (define/private (render-mpi mpi)
+        (string-append
+         "#<module-path-index "
+         (let loop ([mpi mpi])
+           (cond
+             [(module-path-index? mpi)
+              (let-values ([(x y) (module-path-index-split mpi)])
+                (string-append
+                 "("
+                 (format "~s" x)
+                 " . "
+                 (loop y)
+                 ")"))]
+             [else (format "~s" mpi)]))
+         ">"))
+      
+      (define/private (show-property stx prop)
+        (piece-of-info (format "'~a" prop) (syntax-property stx prop)))
+      
+      (define/private (piece-of-info label info)
+        (let ([small-newline 
+               (λ (port text)
+                 (let ([before-newline (send text last-position)])
+                   (newline port)
+                   (send info-text change-style small-style before-newline (+ before-newline 1))))])
+          
+          (insert/bold label)
+          (newline info-port)
+          
+          ;; should just be using generic `print'
+          ;; but won't work without built-in support for
+          ;; editors as output ports
+          (parameterize ([pretty-print-size-hook
+                          (λ (val d/p port)
+                            (if (is-a? val syntax-snip%)
+                                (+ (string-length (format "~a" (send val get-syntax))) 2)
+                                #f))]
+                         [pretty-print-print-hook
+                          (λ (val d/p port)
+                            (send info-text insert (send val copy) 
+                                  (send info-text last-position)
+                                  (send info-text last-position)))])
+            (pretty-print (replace-syntaxes info) info-port))
+          
+          (optional-newline)
+          (small-newline info-port info-text)))
+      
+      (define/private (replace-syntaxes obj)
+        (cond
+          [(cons? obj) (cons (replace-syntaxes (car obj))
+                             (replace-syntaxes (cdr obj)))]
+          [(syntax? obj) (make-object syntax-snip% obj)]
+          [else obj]))
+      
+      (define/private (insert/bold str)
+        (let ([pos (send info-text last-position)])
+          (send info-text insert str 
+                (send info-text last-position)
+                (send info-text last-position))
+          (send info-text change-style
+                (make-object style-delta% 'change-bold)
+                pos 
+                (send info-text last-position))))
+      
+      (define/private (insert/big str)
+        (let ([sd (make-object style-delta% 'change-bold)])
+          (send sd set-delta-foreground "Navy")
+          (let ([pos (send info-text last-position)])
+            (send info-text insert str 
+                  (send info-text last-position)
+                  (send info-text last-position))
+            (send info-text change-style
+                  sd
+                  pos 
+                  (send info-text last-position)))))
+      
+      (define/private (optional-newline)
+        (unless (equal?
+                 (send info-text get-character (- (send info-text last-position) 1))
+                 #\newline)
+          (send info-text insert "\n" (send info-text last-position))))
+      
+      (define/private (show-range stx start end)
+        (send output-text begin-edit-sequence)
+        (send output-text lock #f)
+        (send output-text change-style black-style-delta 0 (send output-text last-position))
+        (send output-text change-style green-style-delta start end)
+        (send output-text lock #t)
+        (send output-text end-edit-sequence)
+        
+        (send info-text begin-edit-sequence)
+        (send info-text lock #f)
+        (send info-text erase)
+        (show-info stx)
+        (make-modern info-text)
+        (send info-text lock #t)
+        (send info-text end-edit-sequence))
+      
+      (define outer-t (make-object text%))
+      
+      (super-instantiate ()
+        (editor outer-t)
+        (with-border? #f)
+        (left-margin 3)
+        (top-margin 0)
+        (right-margin 0)
+        (bottom-margin 0)
+        (left-inset 1)
+        (top-inset 0)
+        (right-inset 0)
+        (bottom-inset 0))
+      
+      (define inner-t (make-object text%))
+      (define inner-es (instantiate editor-snip% ()
+                         (editor inner-t)
+                         (with-border? #f)
+                         (left-margin 0)
+                         (top-margin 0)
+                         (right-margin 0)
+                         (bottom-margin 0)
+                         (left-inset 0)
+                         (top-inset 0)
+                         (right-inset 0)
+                         (bottom-inset 0)))
+      
+      (define details-shown? #t)
+      
+      (inherit show-border set-tight-text-fit)
+      (define/private (hide-details)
+        (when details-shown?
+          (send outer-t lock #f)
+          (show-border #f)
+          (set-tight-text-fit #t)
+          (send outer-t release-snip inner-es)
+          (send outer-t delete (send outer-t last-position))
+          (send outer-t lock #t)
+          (set! details-shown? #f)))
+      
+      (define/private (show-details)
+        (unless details-shown?
+          (send outer-t lock #f)
+          (show-border #t)
+          (set-tight-text-fit #f)
+          (send outer-t insert #\newline
+                (send outer-t last-position)
+                (send outer-t last-position))
+          (send outer-t insert inner-es
+                (send outer-t last-position)
+                (send outer-t last-position))
+          (send outer-t lock #t)
+          (set! details-shown? #t)))
+      
+      (let ([ranges
+             (quicksort 
+              (apply append 
+                     (hash-table-map
+                      range-ht
+                      (λ (k vs)
+                        (map 
+                         (λ (v) (make-range k (car v) (cdr v)))
+                         vs))))
+              (λ (x y)
+                (>= (- (range-end x) (range-start x))
+                    (- (range-end y) (range-start y)))))])
+        (for-each
+         (λ (range)
+           (let* ([obj (range-obj range)]
+                  [stx (hash-table-get stx-ht obj (λ () #f))]
+                  [start (range-start range)]
+                  [end (range-end range)])
+             (when (syntax? stx)
+               (send output-text set-clickback start end 
+                     (λ (_1 _2 _3)
+                       (show-range stx start end))))))
+         ranges)
+        
+        (send outer-t insert (new turn-snip% 
+                                  [on-up (λ () (hide-details))]
+                                  [on-down (λ () (show-details))]))
+        (send outer-t insert (format "~s\n" main-stx))
+        (send outer-t insert inner-es)
+        (make-modern outer-t)
+        
+        (send inner-t insert (instantiate editor-snip% ()
+                               (editor output-text)
+                               (with-border? #f)
+                               (left-margin 0)
+                               (top-margin 0)
+                               (right-margin 0)
+                               (bottom-margin 0)
+                               (left-inset 0)
+                               (top-inset 0)
+                               (right-inset 0)
+                               (bottom-inset 0)))
+        (send inner-t insert (make-object editor-snip% info-text))
+        (send inner-t change-style (make-object style-delta% 'change-alignment 'top) 0 2)
+        
+        (send info-text auto-wrap #t)
+        (send info-text set-styles-sticky #f)
+        (let/ec k
+          (when (null? ranges)
+            (k (void)))
+          (let* ([rng (car ranges)]
+                 [obj (hash-table-get stx-ht (range-obj rng) 
+                                      (λ ()
+                                        (k (void))))])
+            (show-range obj (range-start rng) (range-end rng)))))
+      
+      (send output-text hide-caret #t)
+      (send info-text hide-caret #t)
+      (send inner-t hide-caret #t)
+      (send outer-t hide-caret #t)
+      (send output-text lock #t)
+      (send info-text lock #t)
+      (send inner-t lock #t)
+      (send outer-t lock #t)
+      
+      (hide-details)
+      
+      (inherit set-snipclass)
+      (set-snipclass snip-class)))
+  
+  (define black-style-delta (make-object style-delta% 'change-normal-color))
+  (define green-style-delta (make-object style-delta%))
+  (send green-style-delta set-delta-foreground "forest green")
+  (define small-style (make-object style-delta% 'change-size 4))
+  
+  (define turn-snip%
+    (class snip%
+      
+      (init-field on-up on-down)
+      
+      ;; state : (union 'up 'down 'up-click 'down-click))
+      (init-field [state 'up])
+      
+      (define/override (copy)
+        (instantiate turn-snip% ()
+          (on-up on-up)
+          (on-down on-down)
+          (state state)))
+      
+      (define/override (draw dc x y left top right bottom dx dy draw-caret)
+        (let ([bitmap (case state
+                        [(up) up-bitmap]
+                        [(down) down-bitmap]
+                        [(up-click) up-click-bitmap]
+                        [(down-click) down-click-bitmap])])
+          (cond
+            [(send bitmap ok?)
+             (send dc draw-bitmap bitmap x y)]
+            [(send dc draw-rectangle x y 10 10)
+             (send dc drawline x y 10 10)])))
+             
+
+      (define/override (get-extent dc x y w h descent space lspace rspace)
+        (set-box/f! descent 0)
+        (set-box/f! space 0)
+        (set-box/f! lspace 0)
+        (set-box/f! rspace 0)
+        (set-box/f! w arrow-snip-width)
+        (set-box/f! h arrow-snip-height))
+      
+      (define/override (on-event dc x y editorx editory evt)
+        (let ([snip-evt-x (- (send evt get-x) x)]
+              [snip-evt-y (- (send evt get-y) y)])
+          (cond
+            [(send evt button-down? 'left)
+             (set-state (case state
+                          [(up) 'up-click]
+                          [(down) 'down-click]
+                          [else 'down-click]))]
+            [(and (send evt button-up? 'left)
+                  (<= 0 snip-evt-x arrow-snip-width)
+                  (<= 0 snip-evt-y arrow-snip-height))
+             (set-state (case state
+                          [(up up-click) 
+                           (on-down)
+                           'down]
+                          [(down down-click)
+                           (on-up)
+                           'up]
+                          [else 'down]))]
+            [(send evt button-up? 'left)
+             (set-state (case state
+                          [(up up-click) 'up]
+                          [(down down-click) 'down]
+                          [else 'up]))]
+            [(and (send evt get-left-down)
+                  (send evt dragging?)
+                  (<= 0 snip-evt-x arrow-snip-width)
+                  (<= 0 snip-evt-y arrow-snip-height))
+             (set-state (case state
+                          [(up up-click) 'up-click]
+                          [(down down-click) 'down-click]
+                          [else 'up-click]))]
+            [(and (send evt get-left-down)
+                  (send evt dragging?))
+             (set-state (case state
+                          [(up up-click) 'up]
+                          [(down down-click) 'down]
+                          [else 'up-click]))]
+            [else
+             (super on-event dc x y editorx editory evt)])))
+
+      (inherit get-admin)
+      (define/private (set-state new-state)
+        (unless (eq? state new-state)
+          (set! state new-state)
+          (let ([admin (get-admin)])
+            (when admin
+              (send admin needs-update this 0 0 arrow-snip-width arrow-snip-height)))))
+      
+      (define/override (adjust-cursor dc x y editorx editory event) arrow-snip-cursor)
+      
+      (super-instantiate ())
+      
+      (inherit get-flags set-flags)
+      (set-flags (cons 'handles-events (get-flags)))))
+  
+  (define (set-box/f! b v) (when (box? b) (set-box! b v)))
+  
+  (define down-bitmap (make-object bitmap% (build-path (collection-path "icons") "turn-down.png")))
+  (define up-bitmap (make-object bitmap% (build-path (collection-path "icons") "turn-up.png")))
+  (define down-click-bitmap (make-object bitmap% (build-path (collection-path "icons") "turn-down-click.png")))
+  (define up-click-bitmap (make-object bitmap% (build-path (collection-path "icons") "turn-up-click.png")))
+  (define arrow-snip-height
+    (max 10
+         (send up-bitmap get-height)
+         (send down-bitmap get-height)
+         (send up-click-bitmap get-height)
+         (send down-click-bitmap get-height)))
+  (define arrow-snip-width
+    (max 10
+         (send up-bitmap get-width)
+         (send down-bitmap get-width)
+         (send up-click-bitmap get-width)
+         (send down-click-bitmap get-width)))
+  (define arrow-snip-cursor (make-object cursor% 'arrow))
+  
+  ;; syntax-object->datum/ht : stx -> (values any hash-table[any -o> syntax])
+  ;; the resulting hash-table maps from the each sub-object's to it's syntax.
+  (define (syntax-object->datum/ht stx)
+    (let ([ht (make-hash-table)])
+      (values (let loop ([obj stx])
+                (cond
+                  [(syntax? obj)
+                   (let ([lp-datum (loop (syntax-e obj))])
+                     (hash-table-put! ht lp-datum obj)
+                     lp-datum)]
+                  [(pair? obj) 
+                   (cons (loop (car obj))
+                         (loop (cdr obj)))]
+                  [(vector? obj) 
+                   (list->vector (map loop (vector->list obj)))]
+                  [else 
+                   obj]))
+              ht)))
+  
+  (define (syntax-properties stx)
+    (let ([is-property? (λ (prop) (syntax-property stx prop))])
+      (filter is-property?
+              '(inferred-name
+                bound-in-source
+                origin
+                disappeared-binding
+                disappeared-use
+                bind-as-variable
+                module-variable-provides
+                module-syntax-provides
+                module-indirect-provides
+                module-kernel-reprovide-hint
+                module-self-path-index))))
+
+  ;; make-text-port : text -> port
+  ;; builds a port from a text object.  
+  (define (make-text-port text)
+    (make-output-port #f
+                      always-evt
+                      (λ (s start end flush? breaks?) 
+                        (send text insert (bytes->string/utf-8 (subbytes s start end))
+                              (send text last-position)
+                              (send text last-position))
+                        (- end start))
+                      void))
+  
+  ;; marshall-syntax : syntax -> printable
+  (define (marshall-syntax stx)
+    (unless (syntax? stx)
+      (error 'marshall-syntax "not syntax: ~s\n" stx))
+    `(syntax
+      (source ,(marshall-object (syntax-source stx)))
+      (source-module ,(marshall-object (syntax-source-module stx)))
+      (position ,(syntax-position stx))
+      (line ,(syntax-line stx))
+      (column ,(syntax-column stx))
+      (span ,(syntax-span stx))
+      (original? ,(syntax-original? stx))
+      (properties 
+       ,@(map (λ (x) `(,x ,(marshall-object (syntax-property stx x))))
+              (syntax-property-symbol-keys stx)))
+      (contents
+       ,(marshall-object (syntax-e stx)))))
+
+  ;; marshall-object : any -> printable
+  ;; really only intended for use with marshall-syntax
+  (define (marshall-object obj)
+    (cond
+      [(syntax? obj) (marshall-syntax obj)]
+      [(pair? obj) 
+       `(pair ,(cons (marshall-object (car obj))
+                     (marshall-object (cdr obj))))]
+      [(or (symbol? obj)
+	   (char? obj)
+	   (number? obj)
+           (string? obj)
+	   (boolean? obj)
+           (null? obj))
+       `(other ,obj)]
+      [else (string->symbol (format "unknown-object: ~s" obj))]))
+  
+  (define (unmarshall-syntax stx)
+    (match stx
+      [`(syntax
+         (source ,src)
+         (source-module ,source-module) ;; marshalling
+         (position ,pos)
+         (line ,line)
+         (column ,col)
+         (span ,span)
+         (original? ,original?)
+         (properties ,@(properties ...))
+         (contents ,contents))
+       (foldl
+        add-properties
+        (datum->syntax-object
+         #'here ;; ack
+         (unmarshall-object contents)
+         (list (unmarshall-object src)
+               line
+               col
+               pos
+               span))
+        properties)]
+      [else #'unknown-syntax-object]))
+
+  ;; add-properties : syntax any -> syntax
+  (define (add-properties prop-spec stx)
+    (match prop-spec
+      [`(,(and sym (? symbol?))
+         ,prop)
+       (syntax-property stx sym (unmarshall-object prop))]
+      [else stx]))
+  
+  (define (unmarshall-object obj)
+    (let ([unknown (λ () (string->symbol (format "unknown: ~s" obj)))])
+      (if (and (pair? obj)
+               (symbol? (car obj)))
+          (case (car obj)
+            [(pair) 
+             (if (pair? (cdr obj))
+                 (let ([raw-obj (cadr obj)])
+                   (if (pair? raw-obj)
+                       (cons (unmarshall-object (car raw-obj))
+                             (unmarshall-object (cdr raw-obj)))
+                       (unknown)))
+                 (unknown))]
+            [(other) 
+             (if (pair? (cdr obj))
+                 (cadr obj)
+                 (unknown))]
+            [(syntax) (unmarshall-syntax obj)]
+            [else (unknown)])
+          (unknown)))))
diff --git a/collects/mrlib/text-string-style-desc.ss b/collects/mrlib/text-string-style-desc.ss
new file mode 100644
index 0000000000..a1929ef62c
--- /dev/null
+++ b/collects/mrlib/text-string-style-desc.ss
@@ -0,0 +1,90 @@
+(module text-string-style-desc mzscheme
+  (provide get-string/style-desc)
+  (require (lib "mred.ss" "mred")
+           (lib "etc.ss")
+           (lib "class.ss"))
+  
+  ;; get-string/style-desc : text -> (listof str/ann)
+  (define get-string/style-desc
+    (opt-lambda (text [start 0] [end (send text last-position)])
+      (let* ([snips (get-snips text start end)]
+             [str/ann (map snip->str/ann snips)]
+             [joined-str/ann (join-like str/ann)])
+        joined-str/ann)))
+  
+  ;; get-snips : text -> (listof snip)
+  ;; extracts the snips from a text
+  (define (get-snips text start end)
+    (send text split-snip start)
+    (send text split-snip end)
+    (let loop ([snip (send text find-snip start 'after-or-none)])
+      (cond
+        [(not snip) null]
+        [(< (send text get-snip-position snip) end)
+         (cons snip (loop (send snip next)))]
+        [else null])))
+  
+  ;; snip->str/ann : snip -> str/ann
+  ;; extracts the style type from the snip
+  (define (snip->str/ann snip)
+    (let* ([str (cond
+                  [(is-a? snip string-snip%)
+                   (send snip get-text 0 (send snip get-count))]
+                  [(is-a? snip image-snip%)
+                   'image]
+                  [else 'unknown])]
+           [style (send snip get-style)]
+           [style-name (send style get-name)]
+           [style-desc (if style-name
+                           (translate-name style-name)
+                           (describe-style style))])
+      (list str style-desc)))
+  
+  ;; describe-style : style -> (listof symbol)
+  (define (describe-style style)
+    (list
+     'alignment (send style get-alignment)
+     'background (symbolic-color (send style get-background))
+     'face (send style get-face)
+     'family (send style get-family)
+     'foreground (symbolic-color (send style get-foreground))
+     'size (send style get-size)
+     'underlined (send style get-underlined)))
+  
+  (define (symbolic-color color)
+    (list (send color red)
+          (send color green)
+          (send color blue)))
+
+  ;; translate-name : (union #f string) -> symbol
+  ;; translates the style name to a symbol
+  (define (translate-name str)
+    (and str
+         (let ([m (regexp-match re:translate-name str)])
+           (and m
+                (string->symbol (cadr m))))))
+  
+  ;; re:translate-name : regexp
+  (define re:translate-name (regexp "^.*:([^:]*)$"))
+  
+  ;; join-like : (listof str/ann) -> (listof str/ann)
+  ;; joins same styles to form largest groups
+  (define (join-like str/anns)
+    (cond
+      [(null? str/anns) null]
+      [else 
+       (let loop ([first (car str/anns)]
+                  [rest (cdr str/anns)])
+         (cond
+           [(null? rest) (list first)]
+           [else
+            (let ([second (car rest)])
+              (if (and (equal? (cadr first) (cadr second))
+                       (string? (car first))
+                       (string? (car second)))
+                  (loop (list (string-append (car first) (car second))
+                              (cadr first))
+                        (cdr rest))
+                  (cons first
+                        (loop second
+                              (cdr rest)))))]))])))
\ No newline at end of file
diff --git a/collects/mysterx/doc.txt b/collects/mysterx/doc.txt
new file mode 100644
index 0000000000..93bf2a6a8c
--- /dev/null
+++ b/collects/mysterx/doc.txt
@@ -0,0 +1,3020 @@
+
+_MysterX_
+=========
+
+ MysterX is a toolkit for building Windows
+ applications from ActiveX and COM components,
+ using Scheme as glue code.  Dynamic HTML is used
+ for component presentation and event-handling.
+ MysterX requires Internet Explorer 4, 5, or 6 (IE) to
+ be installed.  Distributed COM (DCOM) for your
+ version of Windows is also required.  Recent versions 
+ of Windows come with DCOM; DCOM packages for Windows 95 and 98 
+ are made available separately.  IE is available for download 
+ from Microsoft at
+
+   http://www.microsoft.com/windows/ie/downloads/default.asp
+
+ while DCOM is available at
+
+   http://www.microsoft.com/com/resources/downloads.asp
+
+ Installation
+ ------------
+
+ Three Windows .DLL's support low-level operations
+ in MysterX.  Two of them, myspage.dll and
+ myssink.dll, may need to be installed in the
+ Registry, by entering `REGSVR32 <name-of-DLL>'.
+ REGSVR32 is a Windows utility usually found in
+ the Windows System directory.  The .DLL's are
+ found in the dlls subdirectory of the MysterX
+ collection.  Ordinarily, the PLT installation
+ program registers these .DLL's, but if the files
+ are copied, or Windows is installed in an unusual
+ disk location, manual registration becomes
+ necessary.  The third .DLL, mxmain.dll, is loaded
+ as a MzScheme extension by the file `mysterx.ss'
+ in the mysterx collection.
+
+ Loading
+ -------
+
+ As of PLT Scheme 200, MysterX is a module.
+ Load the MysterX module with 
+
+  (require (lib "mysterx.ss" "mysterx"))
+
+ Because some MysterX code relies on the PLT 
+ Scheme class system, you will likely need to
+ run 
+
+  (require (lib "class.ss"))
+
+ Using the xml collection
+ ------------------------
+
+ Several MysterX procedures take HTML strings as
+ input.  The xml collection provides procedures
+ that convert Scheme syntax into XML strings.  You
+ may find using these procedures useful in
+ creating HTML strings for use by MysterX.
+
+ Version
+ -------
+
+> (mx-version)
+
+ Returns a string indicating the version of MysterX.
+
+ Browsers
+ --------
+
+ A MysterX application consists of one or more
+ browsers, which are instances of the class
+ mx-browser%.
+
+> (block-while-browsers) 
+ 
+ Blocks until all browser windows have been closed or hidden,
+ using the show method of mx-browser%.  This is useful when
+ a MysterX program file is run as a script, to prevent MzScheme 
+ or MrEd from closing prematurely.
+
+> mx-browser% :: (make-object mx-browser% [label] [width] [height] [x] [y] [style-list])
+
+  Creates an instance of a MysterX browser.
+  `label' is a string for the document caption,
+  with default "MysterX".  The parameters `width', 
+  `height', `x', and `y' give the size and placement 
+  of the browser window on the desktop, with defaults
+  provided by Windows if omitted; the symbol 'default
+  may be used explicitly.  `style-list' may contain 
+  any of the symbols 'iconize, 'maximize, 'no-system-menu,
+  'no-thick-border, and 'scrollbars.  The vertical scrollbar 
+  is disabled if scrolling is unnecessary; the horizontal 
+  scrollbar disappears if scrolling is unnecessary.  
+
+  Although the browser window cannot be hidden initially,
+  it can be iconized.  The `restore' method of mx-browser% 
+  can be used to restore an iconized browser to an ordinary 
+  window.
+
+> current-document :: (send an-mx-browser current-document)
+
+ Returns the current document in the browser, an instance
+ of mx-document%.
+
+> print-document :: (send an-mx-browser print-document)
+
+ Prints the document displayed by the browser to the default
+ printer.  As an unintentional side-effect, the browser 
+ window is minimized.
+
+> show :: (send an-mx-browser show b)
+
+  If `b' is #f, the browser window is hidden.
+  Otherwise, the window is shown.
+
+> navigate :: (send an-mx-browser navigate url)
+
+  Navigates the browser to the URL given by `url', a string.
+  Any DHTML changes to the page associated with the URL 
+  are not shown.  Returns a string that is the actual URL 
+  navigated to.
+
+> navigate/status :: (send an-mx-browser navigate/status url)
+
+  Navigates the browser to the URL given by `url', a string.
+  Any DHTML changes to the page associated with the URL 
+  are not shown.  Returns a list, whose first element string that 
+  is the actual URL navigated to, and whose second element is
+  a status code, one of: #f, indicating no status could be 
+  obtained; a number, such as 200 or 404, indicating the 
+  http status; or 'no-status, indicating that `url' does not 
+  denote a URL with the `http' scheme.
+
+> go-back :: (send an-mx-browser go-back)
+
+  Navigates the browser back to a URL within its history list.
+  Any DHTML changes to the page associated with the URL 
+  are not shown.  Returns a string that is the actual URL 
+  navigated to.
+
+> go-forward :: (send an-mx-browser go-forward)
+
+  Navigates the browser forward to a URL within its history list.  
+  Any DHTML changes to the page associated with the URL are 
+  not shown.  Returns a string that is the actual URL 
+  navigated to.
+
+> refresh :: (send an-mx-browser refresh)
+
+  Refreshes the document in the browser.  Returns #t
+  if the refresh is successful, #f otherwise.
+
+> iconize :: (send an-mx-browser iconize)
+
+  Iconizes the browser window.
+
+> restore :: (send an-mx-browser restore)
+
+  Restores the browser window, if it has been iconized.
+
+> current-url :: (send an-mx-browser current-url)
+
+  Returns a string indicating the currently displayed URL. 
+
+> register-event-handler :: (send an-mx-browser register-event-handler an-mx-element f)
+
+  Registers an event handler `f', a procedure that
+  takes an <mx-event>, for the HTML element
+  `an-mx-element'. `f' may have any output type,
+  though its result is discarded.
+  
+> unregister-event-handler :: (send an-mx-browser unregister-event-handler an-mx-element)
+
+  Unregisters an event handler for an HTML element
+  in the browser.
+
+> handle-events :: (send an-mx-browser handle-events)
+
+  Handles events using the registered event
+  handlers.  The event handlers are called in a
+  thread separate from the main MzScheme REPL.
+
+> stop-handling-events :: (send an-mx-browser stop-handling-events)
+
+  Kills the thread currently handling events for
+  the browser.
+
+ Documents
+ ---------
+
+ A browser contains one document at a time.  If 
+ hyperlinks are clicked, or the navigation methods
+ (navigate, go-forward, go-back) are used, the 
+ document changes.  A document is an instance of
+ mx-document%.
+
+> insert-html :: (send an-mx-document insert-html html)
+
+  Inserts the specified HTML string at the
+  beginning of the document.
+
+> append-html :: (send an-mx-document append-html html)
+
+  Appends the specified HTML string at the end of
+  the document.
+
+> replace-html :: (send an-mx-document replace-html html)
+
+  Replace the current HTML in the document with
+  the specified HTML string.
+
+> objects :: (send an-mx-document objects)
+
+  Returns a list of COM objects, including ActiveX
+  controls, that occur in the document.  The order
+  of the objects is the same as in the document.
+
+> insert-object-from-coclass :: (send an-mx-document insert-object coclass width height [size])
+
+  Inserts a COM object with class `coclass' at the
+  beginning of the document.  `width' and `height'
+  are exact integers.  The optional `size'
+  argument gives an interpretation for the width
+  and height.  By default, size is 'pixels, but
+  may also be 'percent, indicating that the width
+  and height are a fixed percentage of the
+  document window size.  An instance of
+  <com-object> is returned.
+
+> insert-object-from-progid :: (send an-mx-document insert-object progid width height [size])
+
+  Inserts a COM object with ProgID `progid' at the
+  beginning of the document.  `width' and `height'
+  are exact integers.  The optional `size'
+  argument gives an interpretation for the width
+  and height.  By default, size is 'pixels, but
+  may also be 'percent, indicating that the width
+  and height are a fixed percentage of the
+  document window size.  An instance of
+  <com-object> is returned.
+
+> append-object-from-coclasss :: (send an-mx-document append-object coclass [size])
+
+  Append a COM object with class `coclass' to the
+  end of the document.  `width' and `height' are
+  exact integers.  The optional `size' argument
+  gives an interpretation for the width and
+  height.  By default, size is 'pixels, but may
+  also be 'percent, indicating that the width and
+  height are a fixed percentage of the document
+  window size.  An instance of <com-object> is
+  returned.
+
+> append-object-from-progid :: (send an-mx-document append-object progid [size])
+
+  Append a COM object with ProgID `progid' to the
+  end of the document.  `width' and `height' are
+  exact integers.  The optional `size' argument
+  gives an interpretation for the width and
+  height.  By default, size is 'pixels, but may
+  also be 'percent, indicating that the width and
+  height are a fixed percentage of the document
+  window size.  An instance of <com-object> is
+  returned.
+
+> title :: (send an-mx-document title)
+
+  Returns a string indicating the document's title, that is,
+  the text that appears within HTML TITLE tags.  If the document 
+  has no title, the empty string is returned.
+
+> find-element :: (send an-mx-document find-element tag id [index])
+
+  Returns an instance of mx-element%, an object
+  that encapsulates an HTML element.  `tag' is a
+  string naming an HTML tag, and `id' is a string
+  naming the id attribute of the HTML element.
+  `index' is a nonnegative integer indicating the 
+  zero-based index of the element among all elements 
+  with the same tag and id.  By default, index is 0.
+  The ordering of elements is defined by Internet Explorer.
+  The requested element must be within the document's BODY
+  tags, or the BODY element itself.
+
+> find-element-by-id-or-name :: (send an-mx-document find-element-by-id-or-name id [index])
+
+  Returns an instance of mx-element%, an object
+  that encapsulates an HTML element.  `id' is a 
+  string naming either the id or name attribute of the 
+  HTML element.  `index' is a nonnegative integer indicating 
+  the zero-based index of the element among all elements 
+  with the same id or name.  By default, index is 0.
+  The ordering of elements is defined by Internet Explorer.
+  The requested element must be within the document's BODY
+  tags, or the BODY element itself.
+
+> elements-with-tag :: (send an-mx-document elements-with-tag tag)
+
+  Returns a list of mx-element% instances with the HTML tag given by
+  `tag', a string.  The requested elements must be within the document's BODY
+  tags, or the BODY element itself.
+
+
+  HTML events
+  -----------
+
+  MysterX HTML events are generated by mouse and
+  keyboard interaction with HTML elements in a
+  document.  HTML events are instances of the
+  class mx-event%.  The action that generated an
+  event can be determined by the following
+  predicates, only one of which may hold:
+
+> keypress? :: (send an-mx-event keypress?)
+> keydown? :: (send an-mx-event event-keydown?) 
+> keyup? :: (send an-mx-event keyup?)
+> mousedown? :: (send an-mx-event mousedown?)
+> mousemove? :: (send an-mx-event mousemove?)
+> mouseover? :: (send an-mx-event mouseover?)
+> mouseout? :: (send an-mx-event mouseout?)
+> mouseup? :: (send an-mx-event mouseup?)
+> click? :: (send an-mx-event click?)
+> dblclick? :: (send an-mx-event dblclick?)
+> error? :: (send an-mx-event error?)
+  
+  Events have attributes that give detail about
+  the event.
+
+> alt-key :: (send an-mx-event alt-key)
+
+  Returns #t if the Alt key was pressed when the 
+  event was generated, #f otherwise.
+
+> ctrl-key :: (send an-mx-event ctrl-key)
+
+  Returns #t if the Ctrl key was pressed when the 
+  event was generated, #f otherwise. 
+
+> from-tag :: (send an-mx-event from-tag)
+
+  Returns a string indicating the tag of the HTML
+  element where the mouse is being moved from.
+  Return value is valid only for events for which
+  `mouseover?' or `mouseout?' hold.
+
+> from-id :: (send an-mx-event from-id)
+
+  Returns a string indicating the identifier of
+  the HTML element where the mouse is being moved
+  from.  Return value is valid only for events for
+  which `mouseover?' or `mouseout?' hold.
+
+> id :: (send an-mx-event id)
+
+  Returns a string indicating the identifier of
+  the HTML element where the event occurred.
+
+> keycode :: (send an-mx-event keycode)
+
+  Returns a number indicating the keycode for the
+  key that generated the event.  Return value is 
+  valid only for events for which `keypress?',
+  `keydown', or `keyup?' hold.
+
+> shift-key :: (send an-mx-event shift-key)
+
+  Returns #t if the Shift key was pressed when the 
+  event was generated, #f otherwise.
+
+> tag :: (send an-mx-event tag)
+
+  Returns a string indicating the HTML tag of the
+  element where the event occurred.
+
+> to-tag :: (send an-mx-event to-tag)
+
+  Returns a string indicating the tag of the
+  target HTML element where the mouse is being
+  moved to.  Return value is valid only for events
+  for which `mouseover?' or `mouseout?' hold.
+
+> to-id :: (send an-mx-event to-id)
+
+  Returns a string indicating the identifier of
+  the target HTML element where the mouse is being
+  moved from.  Return value is valid only for
+  events for which `mouseover?' or `mouseout?' hold.
+
+> x :: (send an-mx-event x)
+
+  Returns an integer indicating the x-coordinate 
+  within the document where the event occurred.
+
+> y :: (send an-mx-event y)
+
+  Returns an integer indicating the y-coordinate 
+  within the document where the event occurred.
+
+  COM types
+  ---------
+
+> (com-object-type a-com-object)
+
+  Returns a <com-type> value for `a-com-object', a <com-object>.
+
+> (com-is-a? a-com-object a-com-type)
+
+  Return #t if `a-com-object', a <com-object>, is of the
+  type `a-com-type', a <com-type>.
+
+  COM methods and properties
+  --------------------------
+
+  MysterX allows scripting of most COM components
+  from Scheme.  A COM component can be scripted in
+  MysterX if 1) it supports OLE Automation, that
+  is, the IDispatch interface, and 2) publishes
+  type information using the ITypeInfo interface.
+
+> (com-all-coclasses)
+
+  Returns a list of strings for all COM classes
+  registered on a system.
+
+> (com-all-controls)
+
+  Returns a list of strings for all COM classes
+  registered on a system that have the "Control"
+  subkey.
+
+> (cocreate-instance-from-coclass a-coclass [where])
+> (cci/coclass a-coclass [where])
+
+  `a-coclass` is the name of a COM class.  Returns
+  an instance of the class, of type <com-object>.
+  Useful for COM classes without a visual
+  representation, or when a visual representation
+  is not needed.
+
+  The optional argument `where' indicates a for
+  running the instance, and may be 'local (the
+  default), 'remote, or a string indicating a
+  machine name.  See "Running remote COM servers",
+  below, for more information.
+
+> (cocreate-instance-from-progid a-progid [where])
+> (cci/progid a-progid [where])
+
+  `a-progid` is the ProgID for a COM class.
+  Returns an instance of the class, of type
+  <com-object>.  Useful for COM classes without a
+  visual representation, or when a visual
+  representation is not needed.
+
+  The optional argument `where' indicates a for
+  running the instance, and may be 'local (the
+  default), 'remote, or a string indicating a
+  machine name.  See "Running remote COM servers",
+  below, for more information.
+
+> (coclass a-com-object)
+
+  Given a <com-object>, returns a string that is
+  the name of the COM class instantiated by the
+  object.  Raises an error if the COM class is not
+  known.
+
+> (progid a-com-object)
+
+  Given a <com-object>, returns a string that is
+  the ProgID for the COM class instantiated by the
+  object.  Raises an error if the COM class is not
+  known.
+
+> (set-coclass! a-com-object coclass)
+
+  Sets the COM class for a <com-object> to be
+  `coclass', a string.  This is useful when
+  MysterX COM event-handling procedures can only
+  obtain ambiguous information about the object's
+  COM class.
+
+> (set-coclass-from-progid! a-com-object progid)
+
+  Sets the COM class for a <com-object> to be the
+  class denoted by `progid', a string.  This is
+  useful when MysterX COM event-handling
+  procedures can only obtain ambiguous information
+  about the object's COM class.
+
+> (com-methods a-com-object)
+> (com-methods a-com-type)
+
+  `a-com-object' is a <com-object>.  `a-com-type'
+   is a <com-type>.  Returns a list of strings
+   indicating the names of methods.
+
+> (com-method-type a-com-object method-name)
+> (com-method-type a-com-type method-name)
+
+  `a-com-object' is a <com-object>.  `a-com-type'
+  is a <com-type>.  `method-name' is a string.
+  Returns a list of symbols indicating the type of
+  the specified method.
+
+> (com-invoke a-com-object method-name ...)
+
+  `a-com-object' is a <com-object>, and
+  `method-name' is a string.  Invokes the
+  requested method using the arguments given.  The
+  special value `com-omit' may be used for
+  optional arguments, useful when values are
+  supplied for arguments to the right of the
+  omitted argument(s).
+
+> (com-get-properties a-com-object)
+> (com-get-properties a-com-type)
+
+  `a-com-object' has type <com-object>.
+  `a-com-type' is a <com-type>.  Returns a list of
+  strings indicating the names of readable
+  properties in the object.
+
+> (com-get-property-type a-com-object property-name)
+> (com-get-property-type a-com-type property-name)
+
+  `a-com-object' is a <com-object>, `a-com-type'
+  is a <com-type>, and `property-name' is a
+  string.  Returns a list of symbols indicating
+  the type of the specified property.
+
+> (com-get-property a-com-object property property ...)
+
+  `a-com-object' is a <com-object>, and each 
+  `property' is a string, or a list whose first element is a string,
+  and whose remaining elements are Scheme values (an "indexed" 
+  property).  Returns the value of the final property 
+  by following the indicated path of properties, where each 
+  intermediate property is a <com-object>. 
+
+> (com-set-properties a-com-object)
+> (com-set-properties a-com-type)
+
+  `a-com-object' has type <com-object>.
+  `a-com-type' is a <com-type>.  Returns a list of
+  strings indicating the names of writable
+  properties in the object.
+
+> (com-set-property-type a-com-object pptyroperty-name)
+> (com-set-property-type a-com-type property-name)
+
+  `a-com-object' is a <com-object>, `a-com-type'
+  is a <com-type>, and `property-name' is a
+  string.  Returns a list of symbols indicating
+  the type of the specified property.
+
+> (com-set-property! a-com-object property property ... val)
+
+  `a-com-object' is a <com-object>, each `property' is a 
+   string, or a list whose first element is a string and whose
+   remaining elements are Scheme values (indicating an "indexed"
+   property); `val' is a Scheme value.  Sets the value of the final 
+   property by following the indicated path of properties, where 
+   each intermediate property is a <com-object>. 
+
+> (com-help a-com-object [topic])
+> (com-help a-com-type [topic])
+
+  Starts the Window Help system with help about
+  the COM object or COM type.  `a-com-object' is a
+  <com-object>, `a-com-type' is a <com-type>, and
+  `topic' is an optional string, typically a
+  method or property name.
+
+> (com-object-eq? a-com-object a-com-object)
+
+  Returns #t if the two COM objects are the same,
+  #f otherwise.
+
+> (com-object? a-com-object)
+
+  Returns #t if the argument is a COM object, #f
+  otherwise.
+
+> (com-add-ref a-com-object)
+ 
+  Increments the reference count for a COM object.
+  This procedure should only be called when system-level 
+  errors occur due to a mismanaged COM object.  Ordinarily,
+  MysterX handles all COM reference-counting automatically.
+  See also `com-ref-count'.
+
+> (com-ref-count a-com-object)
+
+  Returns a number indicating the current reference count
+  for a COM object.  See also `com-add-ref'.
+
+_DCOM_
+======
+_Remote COM servers_
+====================
+
+  Running remote COM servers
+  --------------------------
+
+  For the MysterX procedures
+  cocreate-instance-from-coclass and
+  cocreate-instance-from-progid, the optional
+  `where' argument may be 'remote.  In that case,
+  the server instance is run at the location given
+  by the Registry key
+
+    HKEY_CLASSES_ROOT\AppID\<CLSID>\RemoteServerName
+
+  where <CLSID> is the CLSID of the application.
+  This key may be set using the DCOMCNFG utility.
+  From DCOMCNFG, pick the application to be run on
+  the Applications tab, then click on the
+  Properties button.  On the Location tab, choose
+  "Run application on the following computer", and
+  enter the machine name.
+
+  In order to run a COM remote server, the Registry on the 
+  client machine must contain an entry at 
+
+    HKEY_CLASSES_ROOT\CLSID\<CLSID>
+
+  where <CLSID> is the CLSID for the server.  The server 
+  application itself need not be installed on the client
+  machine.
+
+  There are a number of configuration issues relating to 
+  DCOM, which MysterX uses to invoke remote COM servers.
+  The Web page 
+
+    http://www.distribucon.com/dcom95.html 
+
+  discusses how to setup client and server machines for 
+  DCOM.
+
+  COM events
+  -----------
+
+  COM events are generated by COM objects.  Unlike
+  HTML events, there is no fixed set of COM
+  events, though there are "stock" events that
+  many COM objects support.  MysterX allows the
+  programmer to write handlers for both stock and
+  custom events.
+
+> (com-events a-com-object)
+> (com-events a-com-type)
+
+  Returns a list of strings naming the events
+  supported by the COM object `a-com-object' or
+  the COM type `a-com-type'.  If calling this
+  procedure results in an error indicating that
+  the COM object's coclass is ambiguous, try using
+  either `set-coclass!' or
+  `set-coclass-from-progid!', then retry the
+  procedure.
+
+> (com-event-type a-com-object ev)
+> (com-event-type a-com-type ev)
+
+  Returns the type of an event handler for the
+  event ev, a string, generated by the particular
+  COM object `a-com-object', or by COM objects
+  that have type `a-com-type'.  The return type of
+  all COM event handlers is void.  If calling this
+  procedure results in an error indicating that
+  the COM object's coclass is ambiguous, try using
+  either `set-coclass!' or
+  `set-coclass-from-progid!', then retry the
+  procedure.
+
+> (com-register-event-handler a-com-object ev fn)
+
+  Registers the event handler fn, a procedure, to
+  handle the event ev, a string, when generated by
+  the COM object `a-com-object'.  The input type
+  of `fn' depends on the event.  `fn' may have any
+  output type, though its output is always
+  discarded.  If calling this procedure results in
+  an error indicating that the COM object's
+  coclass is ambiguous, try using either
+  `set-coclass!' or `set-coclass-from-progid',
+  then retry the procedure.
+
+> (com-unregister-event-handler a-com-object ev)
+
+  Unregisters any event handler for the event ev,
+  a string, that is generated by the COM object
+  `a-com-object'.
+
+  MysterX types
+  -------------
+
+  There are a few special types that appear in the
+  types of COM component methods and properties.
+  We describe those types and, in some cases, operations
+  involving those types.
+
+> boolean
+
+  A boolean.  When a boolean is required in
+  argument position, MysterX will interpret #f as
+  false, and any other value as true.
+
+> short-int
+
+  A 16-bit integer, with value -32768 <= n <= 32767.
+
+> com-currency
+
+  A currency value.
+
+> (com-currency? a-val)
+
+  Returns #t if `a-val' has type com-currency, #f otherwise.
+
+> (com-currency->number a-com-curr)
+
+  Returns a number given `a-com-curr', a value of type
+  com-currency.
+
+> (number->com-currency a-num)
+
+  Returns a value of type com-currency given `a-num', a number.
+  The com-currency value stores a 64-bit two's-complement integer,
+  though `a-num' may contain decimal digits.  If the number is
+  too large, an error occurs.
+  
+> com-date
+
+  A date value.
+  
+> (com-date? a-val)
+
+  Returns #t if `a-val' has type com-date, #f otherwise.
+
+> (com-date->date a-com-date)
+
+  Returns an instance of the date structure, given `a-com-date',
+  a com-date.  In the returned structure, the dst? field is
+  always #f and the time-zone-offset field is 0.
+
+> (date->com-date a-date)
+
+  Returns a com-date value, given `a-date', an instance of the date
+  structure.
+
+> com-scode
+
+  An error value.
+  
+> (com-scode? a-val)
+
+  Returns #t if `a-val' has type com-scode, #f otherwise.
+  
+> (com-scode->number an-scode)
+
+  Returns a number, given `an-scode', a value of type com-scode.
+
+> (number->com-scode a-num)
+
+  Returns a com-scode value, given the number `a-num'.
+  The number must be representable as a 32-bit two's-complement
+  number, else an error occurs.
+
+> com-iunknown
+
+  An interface pointer for a COM object.
+  Currently, there is no way to construct such
+  values, though they may be returned by COM
+  objects.
+  
+> (com-iunknown? a-val)
+
+  Returns #t if `a-val' has type com-iunknown, #f otherwise.
+  
+> mx-any
+
+  A method or property requiring a value of mx-any
+  will accept values of any of these Scheme types:
+  char, int, float, real, and string, as well as
+  the values #t and #f, as well as values of the
+  COM-specific types <mx-currency>, <mx-date>,
+  <mx-scode>, and <mx-unknown-com-object>.
+
+  HTML and Dynamic HTML support
+  -----------------------------
+
+> (coclass->html name width height [size])
+
+  Returns a string containing HTML which when
+  inserted into a document loads the COM object
+  with the COM class given by `name'.  This
+  procedure is suitable for placing ActiveX
+  controls within complex HTML.  `width' and
+  `height' are exact integers.  The optional
+  `size' argument gives an interpretation for the
+  width and height.  By default, size is 'pixels,
+  but may also be 'percent, indicating that the
+  width and height are a fixed percentage of the
+  document window size.  See also `progid->html'.
+
+> (progid->html name width height [size])
+
+  Returns a string containing HTML which when
+  inserted into a document loads the COM object
+  with the ProgID given by `name'.  This procedure
+  is suitable for placing ActiveX controls within
+  complex HTML.  `width' and `height' are exact
+  integers.  The optional `size' argument gives an
+  interpretation for the width and height.  By
+  default, size is 'pixels, but may also be
+  'percent, indicating that the width and height
+  are a fixed percentage of the document window
+  size.  See also `coclass->html'.
+
+  HTML elements 
+  -------------
+
+  The mx-element% class encapsulates HTML
+  elements.  By calling the methods of this class,
+  you can change the appearance of elements, and
+  place new HTML before or after the element.
+  While the methods are described here, a good
+  DHTML reference, such as D. Goodman, "Dynamic
+  HTML" will have more complete information.
+
+  Many of the mx-element% methods have two
+  variants, a version that takes or returns Scheme
+  data, and another "native" version that takes or
+  returns a string.  In versions of MysterX up to
+  v101, only the native methods were available,
+  though they were not labeled as such.  Older
+  MysterX code can usually be ported by simply
+  adding "-native" to the names of those
+  mx-element% methods that have a native version.
+  For methods that return values of element
+  properties, we assume two characteristics, which
+  we do not mention in the methods' documentation:
+  1) Native methods return the empty string for
+  properties that have not been set, and 2)
+  non-native methods raise an error for properties
+  that have not been set.
+
+  In the following method descriptions, "CSS"
+  refers to the Cascading Style Sheets
+  specification.  A CSS length is string
+  consisting of a decimal integer number followed
+  by one of the units "px" (pixels), "em" (font
+  height), "ex" (height of an "x"), "in" (inches),
+  "cm" (centimeters), "mm" (millimeters), "pc"
+  (picas), or "pt" (points).  A CSS percentage is
+  a string consisting of a decimal real number
+  followed by "%".  When using "-native" methods,
+  CSS lengths and percentages are given as
+  strings.  For use by non-native methods, the
+  following structures have been defined:
+
+    (define-struct css-percentage (num))
+    (define-struct css-length (num units))
+
+ where num is a number, and units is a symbol.
+ The valid symbols for the units field are those
+ in '(em ex cm mm in pt pc px).
+ 
+ Colors
+ ------
+
+ Many element properties represent colors.  In
+ HTML, colors may be represented by an RGB string,
+ which contains 7 characters.  The first character
+ is #, the rest are hexadecimal digits (0-9 and
+ A-F).  The first two digits are for the red
+ component of the color, the middle two for the
+ green component, and the last two for the blue
+ component.  For example, "#FFFFFF" is white,
+ "#000000" is black, and "#00FF00" is green.
+
+ There are also predefined color names.  The
+ "-native" methods use these names in strings,
+ while their nonnative counterpart methods use the
+ names as symbols.  The predefined color names are:
+
+  aliceblue antiquewhite aqua aquamarine azure
+  beige bisque black blanchedalmond blue
+  blueviolet brown burlywood cadetblue chartreuse
+  chocolate coral cornflower cornsilk crimson cyan
+  darkblue darkcyan darkgoldenrod darkgray
+  darkgreen darkkhaki darkmagenta darkolivegreen
+  darkorange darkorchid darkred darksalmon
+  darkseagreen darkslateblue darkslategray
+  darkturquoise darkviolet deeppink deepskyblue
+  dimgray dodgerblue firebrick floralwhite
+  forestgreen fuchsia gainsboro ghostwhite gold
+  goldenrod gray green greenyellow honeydew
+  hotpink indianred indigo ivory khaki lavender
+  lavenderblush lawngreen lemonchiffon lightblue
+  lightcoral lightcyan lightgoldenrodyellow
+  lightgreen lightgray lightpink lightsalmon
+  lightseagreen lightskyblue lightslategray
+  lightsteelblue lightyellow lime limegreen linen
+  magenta maroon mediumaquamarine mediumblue
+  mediumorchid mediumpurple mediumseagreen
+  mediumslateblue mediumspringgreen
+  mediumturquoise mediumvioletred midnightblue
+  mintcream mistyrose moccasin navajowhite navy
+  oldlace olive olivedrab orange orangered orchid
+  palegoldenrod palegreen paleturquoise
+  palevioletred papayawhip peachpuff peru pink
+  plum powderblue purple red rosybrown royalblue
+  saddlebrown salmon sandybrown seagreen seashell
+  sienna silver skyblue slateblue slategray snow
+  springgreen steelblue tan teal thistle tomato
+  turquoise violet wheat white whitesmoke yellow
+  yellowgreen
+
+> get-html :: (send an-mx-element get-html)
+
+  Returns a string containing all the HTML between the pair of 
+  tags represented by the element.
+
+> get-text :: (send an-mx-element get-text)
+
+  Returns a string containing just the text between the pair of 
+  tags represented by the element.  Any nested HTML tags 
+  are not contained in the returned string.
+
+> insert-html :: (send an-mx-element insert-html html)
+
+  Places the HTML given by the string `html' before the element.
+
+> append-html :: (send an-mx-element append-html html)
+
+  Places the HTML given by the string `html' after the element.
+
+> replace-html :: (send an-mx-element replace-html html)
+
+  Replaces the HTML in the element with the string `html'.  You must 
+  use the `find-element' or `find-element-by-id-or-name' methods of 
+  mx-document% to retrieve the updated element.
+  
+> insert-text :: (send an-mx-element insert-text txt)
+
+  Places the text given by the string `txt' before the HTML element.
+  
+> append-text :: (send an-mx-element append-text txt)
+
+  Places the text given by the string `txt' after the HTML element.
+  
+> insert-object-from-coclass :: (send an-mx-element insert-object coclass width height [size])
+
+  Inserts a COM object with class `coclass' before the HTML element.
+  `width' and `height' are exact integers.  The optional `size' argument 
+  gives an interpretation for the width and height.  By default, size 
+  is 'pixels, but may also be 'percent, indicating that the width and 
+  height are a fixed percentage of the document window size.
+  An instance of <com-object> is returned.
+
+> insert-object-from-progid :: (send an-mx-element insert-object progid width height [size])
+
+  Inserts a COM object with ProgID `progid' before the HTML element.
+  `width' and `height' are exact integers.  The optional `size' argument 
+  gives an interpretation for the width and height.  By default, size 
+  is 'pixels, but may also be 'percent, indicating that the width and 
+  height are a fixed percentage of the document window size.
+  An instance of <com-object> is returned.
+
+> append-object-from-coclass :: (send an-mx-element append-object coclass width height [size])
+
+  Places a COM object with class `coclass' after the HTML element.  
+  `width' and `height' are exact integers.  The optional `size' argument 
+  gives an interpretation for the width and height.  By default, size 
+  is 'pixels, but may also be 'percent, indicating that the width and 
+  height are a fixed percentage of the document window size.
+  An instance of <com-object> is returned.
+
+> append-object-from-progid :: (send an-mx-element append-object progid width height [size])
+
+  Places a COM object with ProgID `progid' after the HTML element.  
+  `width' and `height' are exact integers.  The optional `size' argument 
+  gives an interpretation for the width and height.  By default, size 
+  is 'pixels, but may also be 'percent, indicating that the width and 
+  height are a fixed percentage of the document window size.
+  An instance of <com-object> is returned.
+
+> focus :: (send an-mx-element focus)
+
+  Sets the focus to the element.  This method works only with
+  Internet Explorer 5 and later.
+
+> selection :: (send an-mx-element selection)
+
+  If the element has the SELECT tag, returns a string indicating
+  the value of the current selection.  Otherwise, an error
+  occurs.  The value of the selection may be different from
+  the string visible in the dropdown list.
+
+> set-selection! :: (send an-mx-element set-selection! val)
+
+  If the element has the SELECT tag, sets the selection to 
+  the entry with the value `val', a string.  Otherwise, an error
+  occurs.  The value of the selection may be different from
+  the string visible in the dropdown list.
+
+> attribute :: (send an-mx-element attribute attr)
+
+  Retrieves the attribute named by the string `attr'.  The return
+  value has a type that depends on the attribute.
+
+> set-attribute! :: (send an-mx-element set-attribute! attr val)
+
+  Sets the attribute named by the string `attr'.  The new
+  value `val' has a type that depends on the attribute,
+  but must be either a string, an integer, a float, #t, or #f.
+  
+> click :: (send an-mx-element click)
+
+  Simulates a mouse click on the element. 
+
+> tag :: (send an-mx-element tag)
+
+  Retrieves the element's HTML tag, which is a string.
+
+> font-family :: (send an-mx-element font-family)
+
+  Returns a list of strings representing a priority list of 
+  font families for the element.  
+
+> font-family-native :: (send an-mx-element font-family-native)
+
+  Returns a comma-delimited string representing a priority list of 
+  font families for the element.
+
+> set-font-family! :: (send an-mx-element set-font-family! ff)
+
+  Sets the list of font families to the list of strings `ff',
+  representing a priority list.  List items may include the generic 
+  families "serif", "sans-serif", "cursive", "fantasy", and "monospace".
+
+> set-font-family-native! :: (send an-mx-element set-font-family-native! ff)
+
+  Sets the list of font families to the string `ff', which is 
+  a comma-delimited priority list.  List items may include 
+  the generic families `serif', `sans-serif', `cursive', 
+  `fantasy', and `monospace'.
+
+> font-style :: (send an-mx-element font-style)
+
+  Retrieves a symbol indicating the element's font style,
+  which is one of 'normal, 'italic, and 'oblique. 
+
+> font-style-native :: (send an-mx-element font-style-native)
+
+  Retrieves a string indicating the element's font style,
+  which is one of "normal", "italic", and "oblique". 
+
+> set-font-style! :: (send an-mx-element set-font-style! fs)
+
+  Sets the element's font style to the string `fs', which 
+  should be one of "normal", "italic", or "oblique". 
+
+> font-variant :: (send an-mx-element font-variant)
+
+  Retrieves a symbol indicating the element's font variation,
+  which is either 'normal or 'small-caps.  
+
+> font-variant-native :: (send an-mx-element font-variant-native)
+
+  Retrieves a string indicating the element's font variation,
+  which is either "normal", "small-caps", or the empty string.
+
+> set-font-variant! :: (send an-mx-element set-font-variant! fv)
+
+  Sets the element's font variation to the symbol `fv', which should 
+  be either 'normal or 'small-caps.
+
+> set-font-variant-native! :: (send an-mx-element set-font-variant-native! fv)
+
+  Sets the element's font variation to the string `fv', which should 
+  be either "normal", "small-caps", or the empty string.
+
+> font-weight :: (send an-mx-element font-weight)
+
+  Retrieves a value indicating the element's font weight,
+  which is either one of the following symbols: 'normal, 'bold,  
+  'bolder, 'lighter, or one of the numbers 100, 200, 300, 
+  400, 500, 600, 700", 800, or 900.
+
+> font-weight-native :: (send an-mx-element font-weight-native)
+
+  Retrieves a string indicating the element's font weight,
+  which is one of the following strings: "normal", "bold",  
+  "bolder", "lighter", "100", "200", "300", "400", "500", 
+  "600", "700", "800", or "900".
+
+> set-font-weight! :: (send an-mx-element set-font-weight! fw)
+
+  Sets the element's font weight using the value `fw', 
+  which is either one of the symbols 'normal, 'bold,  
+  'bolder, 'lighter, or one of the numbers 100, 200, 300, 400, 
+  500, 600, 700, 800, or 900.
+
+> set-font-weight-native! :: (send an-mx-element set-font-weight-native! fw)
+
+  Sets the element's font weight using the string `fw', 
+  which is one of the following strings: "normal", "bold",  
+  "bolder", "lighter", "100", "200", "300", "400", "500", 
+  "600", "700", "800", or "900".
+
+> font-native :: (send an-mx-element font-native)
+
+  Retrieves a string indicating the CSS font-style, font-variant, 
+  font-weight, font-size, line-height, and font-family. 
+
+> set-font-native! :: (send an-mx-element set-font-native! f)
+
+  Sets the CSS font-style, font-variant, font-weight, font-size, 
+  line-height, and font-family for the element from the string `f',
+  which has the format:
+
+  [font-style | font-variant | font-weight] font-size / 
+  [line-height] font-family
+
+  See the "-native" versions of the methods of these properties
+  for syntax of the constituent substrings.
+
+> font-size :: (send an-mx-element font-size)
+
+  Retrieves the CSS font-size for the element.  See
+  `set-font-size!' for possible values.  Raises an
+  error if the property has not been set.
+
+> font-size-native :: (send an-mx-element font-size-native)
+
+  Retrieves the CSS font-size for the element.  See
+  `set-font-size!' for possible values.  Raises an
+  error if the property has not been set.
+
+> set-font-size! :: (send an-mx-element set-font-size! fs)
+
+  Sets the element's CSS font-size using `fs', which may 
+  be any of 1) an symbol in the list '(xx-small x-small small medium 
+  large x-large xx-large); 2) a symbol in the list '(larger smaller), 
+  indicating a size relative to a parent element; 3) an instance
+  of the css-length structure, or 4) an instance of the css-percentage
+  structure, where the perecentage is relative to the parent element's
+  font-size.
+
+> set-font-size-native! :: (send an-mx-element set-font-size-native! fs)
+
+  Sets the element's CSS font-size using `fs', which may 
+  be any of 1) a string indicating an absolute size, one
+  of "xx-small", "x-small", "small", "medium", "large", "x-large", or 
+  "xx-large"; 2) a string indicating a size relative to a parent
+  element, either "larger" or "smaller"; 3) a CSS length; or
+  4) a CSS percentage, considered relative to the parent element's
+  font-size.
+
+> background-native :: (send an-mx-element background-native)   
+
+  Retrieves a string indicating the CSS background-color, 
+  background-image, background-repeat, background-attachment, and 
+  background-position for the element.
+
+> set-background-native! :: (send an-mx-element set-background-native! b)   
+
+  Sets the element's CSS background-color, background-image,
+  background-repeat, background-attachment, and background-position
+  using the string `b'.  See the "-native" versions of the methods
+  for those properties for the syntax of the substrings.
+
+> background-image :: (send an-mx-element background-image)   
+
+  Retrieves a value indicating the CSS background-image for the
+  element, either 'none or a string representing a URL.
+
+> background-image-native :: (send an-mx-element background-image-native)   
+
+  Retrieves a string indicating the CSS background-image for the
+  element.  The string may be "none", the empty string, or 
+  of the form "url(url-string)", indicating a URL.
+
+> set-background-image! :: (send an-mx-element set-background-image! bi)   
+
+  Sets the element's CSS background-image using the value `bi',
+  which is either 'none, or of the form "url(url-string)".
+
+> set-background-image-native! :: (send an-mx-element set-background-image-native! bi)   
+
+  Sets the element's CSS background-image using the string `bi',
+  which is either "none", or of the form "url(url-string)".
+
+> background-repeat :: (send an-mx-element background-repeat)   
+
+  Retrieves a symbol indicating the CSS background-repeat for the 
+  element.  See set-background-repeat! for possible values of that
+  symbol.
+
+> background-repeat-native :: (send an-mx-element background-repeat-native)   
+
+  Retrieves a string indicating the CSS background-repeat for the element.
+  See set-background-repeat-native! for possible values of that
+  string.
+
+> set-background-repeat! :: (send an-mx-element set-background-repeat! br)
+
+  Sets the element's CSS background-repeat using the symbol `br',
+  which must be from the list '(no-repeat repeat repeat-x repeat-y).
+
+> set-background-repeat-native! :: (send an-mx-element set-background-repeat-native! br)
+
+  Sets the element's CSS background-repeat using the string `br',
+  which must be from the list '("no-repeat" "repeat" "repeat-x" "repeat-y").
+
+> background-position :: (send an-mx-element background-position)   
+
+  Retrieves a string indicating the CSS background-position for the
+  element.
+
+> background-position-native :: (send an-mx-element background-position-native)   
+
+  Retrieves a string indicating the CSS background-position for the
+  element.
+
+> set-background-position! :: (send an-mx-element set-background-position! bp)
+
+  Sets the element's CSS background-position using `bp',
+  which either 1) a single css-length, a css-percentage, or a 
+  symbol from the list '(left center right), in which case the 
+  property applies to the horizontal position; or 2) a two-element 
+  list, where either element may be a css-length or css-percentage, 
+  the first element may be a symbol from '(left center right), and 
+  the second element may be from '(top center bottom), in which
+  case the first element applies horizontally, and the second 
+  vertically.
+
+> set-background-position-native! :: (send an-mx-element set-background-position-native! bp)
+
+  Sets the element's CSS background-position using the string `bp',
+  which may be either 1) a CSS percentage, a CSS length
+  or a string from '("left" "center" "right") or 2) two substrings
+  separated by spaces, where either substring may be a CSS percentage
+  or CSS length, the first substring may be one of 
+  '("left" "center" "right"), and the second substring may be one of 
+  '("top" "center" "bottom").  When one value is specified, it 
+  applies to the horizontal position; when two are given, the
+  first applies to the horizontal position, the second applies to 
+  the vertical position.
+
+> text-decoration :: (send an-mx-element text-decoration)
+
+  Retrieves a list drawn from the symbols in 
+  '(none underline overline line-through blink), indicating the 
+  CSS text-decoration for the element.  
+
+> text-decoration-native :: (send an-mx-element text-decoration-native)
+
+  Retrieves a string indicating the CSS text-decoration for the
+  element.  The string contains substrings drawn from 
+  '("none" "underline" "overline" "line-through" "blink").
+
+> set-text-decoration! :: (send an-mx-element set-text-decoration! td)
+
+  Sets the element's CSS text-decoration using the list `td',
+  which contains symbols drawn from 
+  '(none underline overline line-through blink).
+
+> set-text-decoration-native! :: (send an-mx-element set-text-decoration-native! td)
+
+  Sets the element's CSS text-decoration using the string `td',
+  which contains space-separated substrings drawn from 
+  '("none" "underline" "overline" "line-through" "blink").
+
+> text-transform :: (send an-mx-element text-transform)
+
+  Retrieves a symbol indicating the CSS text-transform for the
+  element, from the list '(none capitalize uppercase lowercase).
+
+> text-transform-native :: (send an-mx-element text-transform-native)
+
+  Retrieves a string indicating the CSS text-transform for the
+  element, from the list '("none" "capitalize" "uppercase" "lowercase").
+
+> set-text-transform! :: (send an-mx-element set-text-transform! tt)
+
+  Sets the element's CSS text-transform using the symbol `tt',
+  which is from the list '(none capitalize lowercase uppercase).
+
+> set-text-transform-native! :: (send an-mx-element set-text-transform-native! tt)
+
+  Sets the element's CSS text-transform using the string `tt',
+  which is one of "none", "capitalize", "lowercase", or "uppercase".
+
+> text-align :: (send an-mx-element text-align)
+
+  Retrieves a symbol indicating the CSS text-align for the
+  element, from the list '(left right center justify).
+
+> text-align-native :: (send an-mx-element text-align-native)
+
+  Retrieves a string indicating the CSS text-align for the
+  element, from the list '("left" "right" "center" "justify").
+
+> set-text-align! :: (send an-mx-element set-text-align! ta)
+
+  Sets the element's CSS text-transform using the symbol `ta',
+  which is from the list '(left right center justify).
+
+> set-text-align-native! :: (send an-mx-element set-text-align-native! ta)
+
+  Sets the element's CSS text-transform using the string `ta',
+  which is from the list '("left" "right" "center" "justify").
+
+> margin :: (send an-mx-element margin)
+
+  Retrieves a list indicating the CSS margin for the
+  element.  The list contains one to four elements,
+  each either 'auto, a css-length, or a css-percentage.
+
+> margin-native :: (send an-mx-element margin-native)
+
+  Retrieves a string indicating the CSS margin for the
+  element.  The string contains one to four substrings, each
+  either "auto", a CSS length, or a CSS percentage.
+
+> set-margin! :: (send an-mx-element set-margin! marg)
+
+  Sets the element's CSS margin using the list `marg', which
+  consists of a list of one to four entries, each of 
+  which is a css-length, css-percentage, or 'auto.
+
+> set-margin-native! :: (send an-mx-element set-margin-native! marg)
+
+  Sets the element's CSS margin using the string `marg', which
+  consists of one to four space-separated entries, each of 
+  which is a CSS length, CSS percentage, or "auto".
+
+> padding :: (send an-mx-element padding)
+
+  Retrieves a list indicating the CSS padding for the
+  element.  The list contains one to four elements, each
+  a css-length or a css-percentage.
+
+> padding-native :: (send an-mx-element padding-native)
+
+  Retrieves a string indicating the CSS padding for the
+  element.  The string consists of one to four CSS lengths
+  or CSS percentages, separated by spaces.
+
+> set-padding! :: (send an-mx-element set-padding! pad)
+
+  Sets the element's CSS padding using the list `pad'.  Each
+  element of the list is either a css-length or a css-percentage.
+
+> set-padding-native! :: (send an-mx-element set-padding-native! pad)
+
+  Sets the element's CSS padding using the string `pad', which
+  consists of one to four space-separated entries, each of 
+  which is a CSS length or percentage.
+
+> border :: (send an-mx-element border)
+
+  Retrieves a list describing the CSS border for the element.
+  Each element of the list describes a width, style, or color.
+  A width may be in '(medium thin thick) or a css-length.  
+  A style is in '(none dotted dashed solid double groove 
+  ridge inset outset).  A color is a symbol indicating a
+  color or an RGB string.
+
+> border-native :: (send an-mx-element border-native)
+
+  Retrieves a string describing the CSS border for
+  the element.  The string may contain
+  space-separated values indicating a width,
+  style, and color.  A width may be in '("medium"
+  "thin" "thick") or a CSS length.  A style is in
+  '("none" "dotted" "dashed" "solid" "double"
+  "groove" "ridge" "inset" "outset").  A color is
+  an HTML color or RGB string.
+
+> set-border! :: (send an-mx-element set-border! border)
+
+  Sets the element's CSS border using the list
+  `border', which may contain a width, a style,
+  and a color.  The width may be in '(medium thin
+  thick) or a css-length.  The style is in '(none
+  dotted dashed solid double groove ridge inset
+  outset).  A color is a symbol indicating an HTML
+  color or an RGB string.
+
+> set-border-native! :: (send an-mx-element set-border-native! border)
+
+  Sets the element's CSS border using the string
+  `border', which may contain a width, style, and
+  color.  The string may contain space-separated
+  values indicating a width, style, and color.  A
+  width may be in '("medium" "thin" "thick") or a
+  CSS length.  A style is in '("none" "dotted"
+  "dashed" "solid" "double" "groove" "ridge"
+  "inset" "outset").  A color is an HTML color
+  symbol or RGB string.
+
+> border-top :: (send an-mx-element border-top)
+
+  Retrieves a list describing the CSS border-top
+  for the element.  See the method `border' for a
+  description of the list.
+
+> border-top-native :: (send an-mx-element border-top-native)
+
+  Retrieves a string describing the CSS border-top
+  for the element.  See the method `border-native'
+  for a description of the string.
+
+> set-border-top! :: (send an-mx-element set-border-top! bt)
+
+  Sets the element's CSS border-top using the list
+  `bt'.  See the method `set-border!' for a
+  description of the list.
+
+> set-border-top-native! :: (send an-mx-element set-border-top-native! bt)
+
+  Sets the element's CSS border-top using the
+  string `bt'.  See the method
+  `set-border-native!' for a description of the
+  list.
+
+> border-bottom :: (send an-mx-element border-bottom)
+
+  Retrieves a list describing the CSS
+  border-bottom for the element.  See the method
+  `border' for a description of the list.
+
+> border-bottom-native :: (send an-mx-element border-bottom-native)
+
+  Retrieves a string describing the CSS
+  border-bottom for the element.  See the method
+  `border-native' for a description of the string.
+
+> set-border-bottom! :: (send an-mx-element set-border-bottom! bb)
+
+  Sets the element's CSS border-bottom using the
+  list `bb'.  See the method `set-border!' for a
+  description of the list.
+
+> set-border-bottom-native! :: (send an-mx-element set-border-bottom-native! bb)
+
+  Sets the element's CSS border-bottom using the
+  string `bb'.  See the method
+  `set-border-native!' for a description of the
+  list.
+
+> border-left :: (send an-mx-element border-left)
+
+  Retrieves a list describing the CSS border-left
+  for the element.  See the method `border' for a
+  description of the list.
+
+> border-left-native :: (send an-mx-element border-left-native)
+
+  Retrieves a string describing the CSS
+  border-left for the element.  See the method
+  `border-native' for a description of the string.
+
+> set-border-left! :: (send an-mx-element set-border-left! bl)
+
+  Sets the element's CSS border-left using the
+  list `bl'.  See the method `set-border!' for a
+  description of the list.
+
+> set-border-left-native! :: (send an-mx-element set-border-left-native! bl)
+
+  Sets the element's CSS border-left using the
+  string `bl'.  See the method
+  `set-border-native!' for a description of the
+  list.
+
+> border-right :: (send an-mx-element border-right)
+
+  Retrieves a list describing the CSS border-right
+  for the element.  See the method `border' for a
+  description of the list.
+
+> border-right-native :: (send an-mx-element border-right-native)
+
+  Retrieves a string describing the CSS
+  border-right for the element.  See the method
+  `border-native' for a description of the string.
+
+> set-border-right! :: (send an-mx-element set-border-right! br)
+
+  Sets the element's CSS border-right using the
+  list `br'.  See the method `set-border!' for a
+  description of the list.
+
+> set-border-right-native! :: (send an-mx-element set-border-right-native! br)
+
+  Sets the element's CSS border-right using the
+  string `br'.  See the method
+  `set-border-native!' for a description of the
+  list.
+
+> border-color :: (send an-mx-element border-color)
+
+  Retrieves a list of one to four elements in
+  which each element is either a symbol indicating
+  an HTML color or an RGB string.  If the list
+  contains just one element, it applies to all
+  four sides.  If there are two, the first is for
+  top and bottom, the other for left and right.
+  If there are three, they are for top, left and
+  right, and bottom.
+
+> border-color-native :: (send an-mx-element border-color-native)
+
+  Retrieves a string in which describing the CSS
+  border-color for the element.  The string
+  contains one to four space-separated substrings
+  indicating a color.  If there is just one color,
+  it applies to all four sides.  If there are two,
+  the first is for top and bottom, the other for
+  left and right.  If there are three, they are
+  for top, left and right, and bottom.
+
+> set-border-color! :: (send an-mx-element set-border-color! bc)
+
+  Sets the element's CSS border-color using the
+  list `bc', which has one to four elements, each
+  of which is either a symbol indicating an HTML
+  color, or an RGB string.  If there is just one
+  element, it applies to all four sides.  If there
+  are two, the first is for top and bottom, the
+  second for left and right.  If there are three,
+  they are for top, left and right, and bottom.
+
+> set-border-color-native! :: (send an-mx-element set-border-color-native! bc)
+
+  Sets the element's CSS border-color using the
+  string `bc', which consists of one to four HTML
+  colors, separated by spaces.  If there is just
+  one color, it applies to all four sides.  If
+  there are two, the first is for top and bottom,
+  the second for left and right.  If there are
+  three, they are for top, left and right, and
+  bottom.
+
+> border-width :: (send an-mx-element border-width)
+
+  Retrieves a list of one to four elements, each
+  of which is either a css-length, or a symbol
+  from '(medium thin thick).  If only one width is
+  given, it applies to all four sides.  If two are
+  given, the first is for top and bottom, the
+  second for left and right.  If three are given,
+  the first is for top, the second for left and
+  right, the third for bottom.
+
+> border-width-native :: (send an-mx-element border-width-native)
+
+  Retrieves a string describing the CSS
+  border-width for the element.  The string
+  contains one to four substrings, each of which
+  is either a CSS length, or a string from
+  '("medium" "thin" "thick").  If only one width
+  is given, it applies to all four sides.  If two
+  are given, the first is for top and bottom, the
+  second for left and right.  If three are given,
+  the first is for top, the second for left and
+  right, the third for bottom.
+
+> set-border-width! :: (send an-mx-element set-border-width! bw)
+
+  Sets the element's CSS border-color using the
+  list `bw', which may contain one to four
+  elements, each of which is either a css-length,
+  or a symbol from '(thin medium thick).  If only
+  one width is given, it applies to all four
+  sides.  If two are given, the first is for top
+  and bottom, the second for left and right.  If
+  three are given, the first is for top, the
+  second for left and right, the third for bottom.
+
+> set-border-width-native! :: (send an-mx-element set-border-width-native! bw)
+
+  Sets the element's CSS border-color using the
+  string `bw', which consists of one to four
+  space-separated substrings, each of which is
+  either a CSS length or a string from '("thin"
+  "medium" "thick").  If only one width is given,
+  it applies to all four sides.  If two are given,
+  the first is for top and bottom, the second for
+  left and right.  If three are given, the first
+  is for top, the second for left and right, the
+  third for bottom.
+
+> border-style :: (send an-mx-element border-style)
+
+  Retrieves a symbol describing the CSS
+  border-style for the element.  The symbol is
+  from '(none dotted dashed solid double groove
+  ridge inset outset).
+
+> border-style-native :: (send an-mx-element border-style-native)
+
+  Retrieves a string describing the CSS
+  border-style for the element.  The string is
+  from '("none" "dotted" "dashed" "solid" "double"
+  "groove" "ridge" "inset" "outset").
+
+> set-border-style! :: (send an-mx-element set-border-style! bs)
+
+  Sets the element's CSS border-style using the
+  symbol `bs', which is from '(none dotted dashed
+  solid double groove ridge inset outset).
+
+> set-border-style-native! :: (send an-mx-element set-border-style-native! bs)
+
+  Sets the element's CSS border-style using the
+  string `bs', which is from '("none" "dotted"
+  "dashed" "solid" "double" "groove" "ridge"
+  "inset" "outset").
+
+> border-top-style :: (send an-mx-element border-top-style)
+
+  Retrieves a symbol describing the CSS
+  border-top-style for the element.  See
+  border-style for possible values.
+
+> border-top-style-native :: (send an-mx-element border-top-style-native)
+
+  Retrieves a string describing the CSS
+  border-top-style for the element.  See
+  border-style-native for possible values.
+
+> set-border-top-style! :: (send an-mx-element set-border-top-style! bts)
+
+  Sets the element's CSS border-top-style using
+  the symbol `bts'.  See set-border-style! for
+  possible values.
+
+> set-border-top-style-native! :: (send an-mx-element set-border-top-style-native! bts)
+
+  Sets the element's CSS border-top-style using
+  the string `bts'.  See set-border-style-native!
+  for possible values.
+
+> border-bottom-style :: (send an-mx-element border-bottom-style)
+
+  Retrieves a symbol describing the CSS
+  border-bottom-style for the element.  See
+  border-style for possible values.
+
+> border-bottom-style-native :: (send an-mx-element border-bottom-style-native)
+
+  Retrieves a string describing the CSS
+  border-bottom-style for the element.  See
+  border-style-native for possible values.
+
+> set-border-bottom-style! :: (send an-mx-element set-border-bottom-style! bbs)
+
+  Sets the element's CSS border-bottom-style using
+  the symbol `bbs'.  See set-border-style! for
+  possible values.
+
+> set-border-bottom-style-native! :: (send an-mx-element set-border-bottom-style-native! bbs)
+
+  Sets the element's CSS border-bottom-style using
+  the string `bbs'.  See set-border-style-native!
+  for possible values.
+
+> border-left-style :: (send an-mx-element border-left-style)
+
+  Retrieves a symbol describing the CSS
+  border-left-style for the element.  See
+  border-style for possible values.
+
+> border-left-style-native :: (send an-mx-element border-left-style-native)
+
+  Retrieves a string describing the CSS
+  border-left-style for the element.  See
+  border-style-native for possible values.
+
+> set-border-left-style! :: (send an-mx-element set-border-left-style! bls)
+
+  Sets the element's CSS border-left-style using
+  the string `bls'.  See set-border-style! for
+  possible values.
+
+> set-border-left-style-native! :: (send an-mx-element set-border-left-style-native! bls)
+
+  Sets the element's CSS border-left-style using
+  the string `bls'.  See set-border-style-native!
+  for possible values.
+
+> border-right-style :: (send an-mx-element border-right-style)
+
+  Retrieves a symbol describing the CSS
+  border-right-style for the element.  See
+  border-style for possible values.
+
+> border-right-style-native :: (send an-mx-element border-right-style-native)
+
+  Retrieves a string describing the CSS
+  border-right-style for the element.  See
+  border-style-native for possible values.
+
+> set-border-right-style! :: (send an-mx-element set-border-right-style! brs)
+
+  Sets the element's CSS border-right-style using
+  the symbol `brs'.  See set-border-style! for
+  possible values.
+
+> set-border-right-style! :: (send an-mx-element set-border-right-style! brs)
+
+  Sets the element's CSS border-right-style using
+  the string `brs'.  See set-border-style-native!
+  for possible values.
+
+> style-float :: (send an-mx-element style-float)
+
+  Retrieves a symbol describing the CSS
+  style-float for the element, one of '(none left
+  right).
+
+> style-float-native :: (send an-mx-element style-float-native)
+
+  Retrieves a string describing the CSS
+  style-float for the element, one of '("none"
+  "left" "right").
+
+> set-style-float! :: (send an-mx-element set-style-float! sf)
+
+  Sets the element's CSS style-float using the
+  symbol `sf', which is one of '(none left right).
+
+> set-style-float-native! :: (send an-mx-element set-style-float-native! sf)
+
+  Sets the element's CSS style-float using the
+  string `sf', which is one of '("none" "left"
+  "right").
+
+> clear :: (send an-mx-element clear)
+
+  Retrieves a symbol describing the CSS clear for
+  the element, which is one of '(none left right
+  both).
+
+> clear-native :: (send an-mx-element clear-native)
+
+  Retrieves a string describing the CSS clear for
+  the element, which is one of '("none" "left"
+  "right" "both").
+
+> set-clear! :: (send an-mx-element set-clear! clr)
+
+  Sets the element's CSS clear using the symbol
+  `clr', which is one of '(none left right both).
+
+> set-clear-native! :: (send an-mx-element set-clear-native! clr)
+
+  Sets the element's CSS clear using the string
+  `clr', which is one of '("none" "left" "right"
+  "both").
+
+> display :: (send an-mx-element display)
+
+  Retrieves a symbol describing the CSS clear for
+  the element, which is one of '(block none inline
+  list-item table-header-group
+  table-footer-group).
+
+> display-native :: (send an-mx-element display-native)
+
+  Retrieves a string describing the CSS clear for
+  the element, which is one of '("block" "none"
+  "inline" "list-item" "table-header-group"
+  "table-footer-group").
+
+> set-display! :: (send an-mx-element set-display! dpy)
+
+  Sets the element's CSS display using the symbol
+  `dpy', which is one of '(block none inline
+  list-item table-header-group
+  table-footer-group).
+
+> set-display-native! :: (send an-mx-element set-display-native! dpy)
+
+  Sets the element's CSS display using the string
+  `dpy', which is one of '("block" "none" "inline"
+  "list-item" "table-header-group"
+  "table-footer-group").
+
+> visibility :: (send an-mx-element visibility)
+
+  Retrieves a symbol describing the CSS visibility
+  for the element, which is one of '(inherit
+  visible hidden).
+
+> visibility-native :: (send an-mx-element visibility-native)
+
+  Retrieves a string describing the CSS visibility
+  for the element, which is one of '("inherit"
+  "visible" "hidden").
+
+> set-visibility! :: (send an-mx-element set-visibility! vis)
+
+  Sets the element's CSS visibility using the
+  symbol `vis', which is one of '(inherit visible
+  hidden).
+
+> set-visibility-native! :: (send an-mx-element set-visibility-native! vis)
+
+  Sets the element's CSS visibility using the
+  string `vis', which is one of '("inherit"
+  "visible" "hidden").
+
+> list-style-type :: (send an-mx-element list-style-type)
+
+  Retrieves a symbol describing the CSS
+  list-style-type for the element, one of '(disc
+  circle square decimal lower-roman upper-roman
+  lower-alpha upper-alpha none).
+
+> list-style-type-native :: (send an-mx-element list-style-type-native)
+
+  Retrieves a string describing the CSS
+  list-style-type for the element, one of '("disc"
+  "circle" "square" "decimal" "lower-roman"
+  "upper-roman" "lower-alpha" "upper-alpha"
+  "none").
+
+> set-list-style-type! :: (send an-mx-element set-list-style-type! sty)
+
+  Sets the element's CSS list-style-type using the
+  symbol `sty', which is one of '(disc circle
+  square decimal lower-roman upper-roman
+  lower-alpha upper-alpha none).
+
+> set-list-style-type-native! :: (send an-mx-element set-list-style-type-native! lst)
+
+  Sets the element's CSS list-style-type using the
+  string `sty', which is one of '("disc" "circle"
+  "square" "decimal" "lower-roman" "upper-roman"
+  "lower-alpha" "upper-alpha" "none").
+
+> list-style-position :: (send an-mx-element list-style-position)
+
+  Retrieves a symbol describing the CSS
+  list-style-position for the element, one of
+  '(outside inside).
+
+> list-style-position-native :: (send an-mx-element list-style-position-native)
+
+  Retrieves a string describing the CSS
+  list-style-position for the element, one of
+  '("outside" "inside").
+
+> set-list-style-position! :: (send an-mx-element set-list-style-position! pos)
+
+  Sets the element's CSS list-style-position using
+  the symbol `pos', which is one of '(outside
+  inside).
+
+> set-list-style-position-native! :: (send an-mx-element set-list-style-position-native! pos)
+
+  Sets the element's CSS list-style-position using
+  the string `pos', which is one of '("outside"
+  "inside").
+
+> list-style-image :: (send an-mx-element list-style-image)
+
+  Retrieves a string describing the CSS
+  list-style-image for the element, which is
+  either "none" or a URL.
+
+> list-style-image-native :: (send an-mx-element list-style-image-native)
+
+  Retrieves a string describing the CSS
+  list-style-image for the element, which is
+  either "none" or of the form "url(url-string)".
+
+> set-list-style-image! :: (send an-mx-element set-list-style-image! image)
+
+  Sets the element's CSS list-style-image using
+  the string `image', which is either "none" or a
+  URL.
+
+> set-list-style-image-native! :: (send an-mx-element set-list-style-image-native! image)
+
+  Sets the element's CSS list-style-image using
+  the string `image', which is either "none" or of
+  the form "url(url-string)".
+
+> list-style :: (send an-mx-element list-style)
+
+  Retrieves a list of one to three values
+  describing the CSS list-style for the element.
+  Each value in the list is as the values returned
+  by the methods list-style-type,
+  list-style-position, and list-style-image.  The
+  values may appear in any order.
+
+> list-style-native :: (send an-mx-element list-style-native)
+
+  Retrieves a string with one to three substrings
+  describing the CSS list-style for the element.
+  Each substring is of the form of the strings
+  returned by the methods list-style-type-native,
+  list-style-position-native, and
+  list-style-image-native.  The substrings may
+  appear in any order.
+
+> set-list-style! :: (send an-mx-element set-list-style! ls)
+
+  Sets the element's CSS list-style using the list
+  `ls', which contains one to three elements, each
+  of which is of the form of the possible
+  arguments to set-list-style-type!,
+  set-list-style-image!, and
+  set-list-style-position!.
+
+> set-list-style-native! :: (send an-mx-element set-list-style-native! ls)
+
+  Sets the element's CSS list-style using the
+  string `ls', which contains one to three
+  space-separated substrings.  Each substring is
+  of the form of the possible arguments to
+  set-list-style-type-native!,
+  set-list-style-image-native!, and
+  set-list-style-position-native!.
+
+> position :: (send an-mx-element position)
+
+  Retrieves a symbol describing the CSS position
+  for the element, which is one of '(absolute
+  relative static).
+
+> position-native :: (send an-mx-element position-native)
+
+  Retrieves a string describing the CSS position
+  for the element, which is one of '("absolute"
+  "relative" "static").
+
+> overflow :: (send an-mx-element overflow)
+
+  Retrieves a symbol describing the CSS overflow
+  for the element, which is one of '(visible
+  scroll hidden auto).
+
+> overflow-native :: (send an-mx-element overflow-native)
+
+  Retrieves a string describing the CSS overflow
+  for the element, which is one of '("visible"
+  "scroll" "hidden" "auto").
+
+> set-overflow! :: (send an-mx-element set-overflow! of)
+
+  Sets the element's CSS overflow using the symbol
+  `of', which is one of '(visible scroll hidden
+  auto).
+
+> set-overflow-native! :: (send an-mx-element set-overflow-native! of)
+
+  Sets the element's CSS overflow using the string
+  `of', which is one of '("visible" "scroll"
+  "hidden" "auto").
+
+> pagebreak-before :: (send an-mx-element pagebreak-before)
+
+  Retrieves a symbol describing the CSS
+  pagebreak-before for the element, which is one
+  of '(always auto none).
+
+> pagebreak-before-native :: (send an-mx-element pagebreak-before-native)
+
+  Retrieves a string describing the CSS
+  pagebreak-before for the element, which is one
+  of '("always" "auto" "").  Note that unlike most
+  other "-native" properties, the empty string
+  does not mean the property has not been set.
+
+> set-pagebreak-before! :: (send an-mx-element set-pagebreak-before! pbb)
+
+  Sets the element's CSS pagebreak-before using
+  the symbol `pbb', which is one of '(always auto
+  none).
+
+> set-pagebreak-before-native! :: (send an-mx-element set-pagebreak-before-native! pbb)
+
+  Sets the element's CSS pagebreak-before using
+  the string `pbb', which is one of '("always"
+  "auto" "").  Note that the empty string is a
+  valid value.
+
+> pagebreak-after :: (send an-mx-element pagebreak-after)
+
+  Retrieves a symbol describing the CSS
+  pagebreak-after for the element, which is one of
+  '(always auto none).
+
+> pagebreak-after-native :: (send an-mx-element pagebreak-after-native)
+
+  Retrieves a string describing the CSS
+  pagebreak-after for the element, which is one of
+  '("always" "auto" "").  Note that unlike most
+  other "-native" properties, the empty string
+  does not mean the property has not been set.
+
+> set-pagebreak-after! :: (send an-mx-element set-pagebreak-after! pba)
+
+  Sets the element's CSS pagebreak-after using the
+  symbol `pbb', which is one of '(always auto
+  none).
+
+> set-pagebreak-after-native! :: (send an-mx-element set-pagebreak-after-native! pba)
+
+  Sets the element's CSS pagebreak-after using the
+  string `pbb', which is one of '("always" "auto"
+  "").  Note that the empty string is a valid
+  value.
+
+> css-text-native :: (send an-mx-element css-text-native)
+
+  Retrieves a string describing the CSS text for
+  the element.
+
+> set-css-text-native! :: (send an-mx-element set-css-text-native! txt)
+
+  Sets the element's CSS text using the string
+  `txt'.
+
+> cursor :: (send an-mx-element cursor)
+
+  Retrieves a symbol describing the CSS cursor for
+  the element, one of '(auto crosshair default
+  hand move n-resize ne-resize nw-resize s-resize
+  se-resize sw-resize e-resize w-resize text wait
+  help).
+
+> cursor-native :: (send an-mx-element cursor-native)
+
+  Retrieves a string describing the CSS cursor for
+  the element, one of '("auto" "crosshair"
+  "default" "hand" "move" "n-resize" "ne-resize"
+  "nw-resize" "s-resize" "se-resize" "sw-resize"
+  "e-resize" "w-resize" "text" "wait" "help").
+
+> set-cursor! :: (send an-mx-element set-cursor! csr)
+
+  Sets the element's CSS cursor using the symbol
+  `csr', which is one of '(auto crosshair default
+  hand move n-resize ne-resize nw-resize s-resize
+  se-resize sw-resize e-resize w-resize text wait
+  help).
+
+> set-cursor-native! :: (send an-mx-element set-cursor-native! csr)
+
+  Sets the element's CSS cursor using the string
+  `csr', which is one of '("auto" "crosshair"
+  "default" "hand" "move" "n-resize" "ne-resize"
+  "nw-resize" "s-resize" "se-resize" "sw-resize"
+  "e-resize" "w-resize" "text" "wait" "help").
+
+> clip :: (send an-mx-element clip)
+
+  Retrieves a value describing the CSS clip for
+  the element.  The value is either 'auto, or a
+  list of four values for the top, right, bottom,
+  and left edges.  In the list, each value is
+  either 'auto or a css-length.
+
+> clip-native :: (send an-mx-element clip-native)
+
+  Retrieves a string describing the CSS clip for
+  the element.  The string is either "auto" or of
+  the form "rect(top right bottom left)", where
+  the edges are either "auto" or CSS lengths.
+
+> set-clip! :: (send an-mx-element set-clip! clp)
+
+  Sets the element's CSS clip using the value
+  `clp'.  The value is either 'auto, or a list of
+  four values for the top, right, bottom, and left
+  edges.  In the list, each value is either 'auto
+  or a css-length.
+
+> set-clip-native! :: (send an-mx-element set-clip-native! clp)
+
+  Sets the element's CSS clip using the string
+  `clp'.  The string is either "auto" or of the
+  form "rect(top right bottom left)", where the
+  edges are either "auto" or CSS lengths.
+
+> filter :: (send an-mx-element filter)
+
+  Retrieves a list describing the CSS filter for
+  the element.  The list is of the form
+  (filter-name (opt val) ...).  See the method
+  set-filter! for the filters and their options.
+
+> filter-native :: (send an-mx-element filter-native)
+
+  Retrieves a string describing the CSS filter for
+  the element.  The string is of the form
+  "filter-name(opt=val,...)"  or simply
+  "filter-name".  See the Internet Explorer SDK
+  for more information about filters and their
+  options.
+
+> set-filter! :: (send an-mx-element set-filter! flt opt ...)
+
+  Sets the element's CSS filter using the `flt', 
+  which is a symbol.  Each option `opt' is a pair 
+  consisting of a symbol and a value.  For all filters, 
+  any of its options may be omitted.  The filters and 
+  their options are
+
+  filter           option              value      
+  -----            ------              -----
+  alpha            enabled             boolean
+                   finish-opacity      n exact, 0 <= n <= 100
+                   opacity             n exact, 0 <= n <= 100
+                   start-x             exact number
+                   start-y             exact number 
+                   finish-x            exact number
+                   finish-y            exact number
+                   style               in '(uniform linear
+                                            radial rectangular)
+  blend-trans      enable              boolean
+                   duration            number
+                   status              in '(stopped applied playing)
+  blur             add                 boolean
+                   enabled             boolean
+                   direction           in '(0 45 90 135 180 
+                                            225 270 315)
+                   strength            exact n, 1 <= n <= 100
+  chroma           enabled             boolean
+                   color               RGB string
+  drop-shadow      enabled             boolean
+                   off-x               exact number
+                   off-y               exact number  
+  flip-horizontal  enabled             boolean
+  flip-vertical    enabled             boolean 
+  glow             enabled             boolean
+                   color               RGB string
+                   strength            exact n, 1 <= n <= 100  
+  gray             enabled             boolean
+  invert           enabled             boolean 
+  light            enabled             boolean 
+  mask             enabled             boolean
+                   color               RGB string
+  redirect         enabled             boolean
+  reveal-trans     enabled             boolean
+                   duration            number
+                   status              in '(stopped applied playing)
+  shadow           enabled             boolean
+                   color               RGB string
+                   direction           in '(0 45 90 135 180 
+                                            225 270 315)   
+  wave             enabled             boolean
+                   freq                number n, n >= 0
+                   light-strength      exact n, 1 <= n <= 100
+  x-ray            enabled             boolean
+
+> set-filter-native! :: (send an-mx-element set-filter-native! flt)
+
+  Sets the element's CSS filter using the string
+  `flt'.  The string is of the form
+  "filter-name(opt=val,...)"  or simply
+  "filter-name".  See the Internet Explorer SDK
+  for more information on filters and their
+  options.
+
+> style-string :: (send an-mx-element style-string)
+
+  Retrieves a string describing the complete CSS
+  description for the element.
+
+> text-decoration-none :: (send an-mx-element text-decoration-none)
+
+  Retrieves the CSS text-decoration-none, a
+  boolean value, for the element.
+
+> set-text-decoration-none! :: (send an-mx-element set-text-decoration-none! tdn)
+
+  Sets the element's CSS text-decoration-none
+  using `tdn'.  If `tdn' is #f, the value is
+  false, otherwise it is considered true.
+
+> text-decoration-underline :: (send an-mx-element text-decoration-underline)
+
+  Retrieves the CSS text-decoration-underline, a
+  boolean value, for the element.
+
+> set-text-decoration-underline! :: (send an-mx-element set-text-decoration-underline! tdu)
+
+  Sets the element's CSS text-decoration-underline
+  using `tdu'.  If `tdn' is #f, the value is
+  false, otherwise it is considered true.
+
+> text-decoration-overline :: (send an-mx-element text-decoration-overline)
+
+  Retrieves the CSS text-decoration-overline, a
+  boolean value, for the element.
+
+> set-text-decoration-overline! :: (send an-mx-element set-text-decoration-overline! tdo)
+
+  Sets the element's CSS text-decoration-overline
+  using `tdo'.  If `tdn' is #f, the value is
+  false, otherwise it is considered true.
+
+> text-decoration-linethrough :: (send an-mx-element text-decoration-linethrough)
+
+  Retrieves the CSS text-decoration-linethrough, a
+  boolean value, for the element.
+
+> set-text-decoration-linethrough! :: (send an-mx-element set-text-decoration-linethrough! tdlt)
+
+  Sets the element's CSS
+  text-decoration-linethrough using `tdlt'.  If
+  `tdn' is #f, the value is false, otherwise it is
+  considered true.
+
+> text-decoration-blink :: (send an-mx-element text-decoration-blink)
+
+  Retrieves the CSS text-decoration-blink, a
+  boolean value, for the element.
+
+> set-text-decoration-blink! :: (send an-mx-element set-text-decoration-blink! bl)
+
+  Sets the element's CSS text-decoration-blink
+  using `bl'.  If `tdn' is #f, the value is false,
+  otherwise it is considered true.
+
+> pixel-top :: (send an-mx-element pixel-top)
+
+  Retrieves the CSS pixel-top, an integer, for the
+  element.
+
+> set-pixel-top! :: (send an-mx-element set-pixel-top! pt)
+
+  Sets the element's CSS pixel-top using `pt',
+  which is an integer.
+
+> pixel-left :: (send an-mx-element pixel-left)
+
+  Retrieves the CSS pixel-left, an integer, for
+  the element.
+
+> set-pixel-left! :: (send an-mx-element set-pixel-left! pl)
+
+  Sets the element's CSS pixel-left using `pl',
+  which is an integer.
+
+> pixel-width :: (send an-mx-element pixel-width)
+
+  Retrieves the CSS pixel-width, an integer, for
+  the element.
+
+> set-pixel-width! :: (send an-mx-element set-pixel-width! pw)
+
+  Sets the element's CSS pixel-width using `pw',
+  which is an integer.
+
+> pixel-height :: (send an-mx-element pixel-height)
+
+  Retrieves the CSS pixel-height, an integer, for
+  the element.
+
+> set-pixel-height! :: (send an-mx-element set-pixel-height! ph)
+
+  Sets the element's CSS pixel-height using `ph',
+  which is an integer.
+
+> pos-top :: (send an-mx-element pos-top)
+
+  Retrieves the CSS pos-top, an inexact number,
+  for the element.
+
+> set-pos-top! :: (send an-mx-element set-pos-top! pt)
+
+  Sets the element's CSS pos-top using `pt', which
+  is an inexact number.
+
+> pos-left :: (send an-mx-element pos-left)
+
+  Retrieves the CSS pos-left, an inexact number,
+  for the element.
+
+> set-pos-left! :: (send an-mx-element set-pos-left! pl)
+
+  Sets the element's CSS pos-left using `pl',
+  which is an inexact number.
+
+> pos-width :: (send an-mx-element pos-width)
+
+  Retrieves the CSS pos-width, an inexact number,
+  for the element.
+
+> set-pos-width! :: (send an-mx-element set-pos-width! pw)
+
+  Sets the element's CSS pos-width using `pw',
+  which is an inexact number.
+
+> pos-height :: (send an-mx-element pos-height)
+
+  Retrieves the CSS pos-height, an inexact number,
+  for the element.
+
+> set-pos-height! :: (send an-mx-element set-pos-height! ph)
+
+  Sets the element's CSS pos-height using `ph',
+  which is an inexact number.
+
+> color :: (send an-mx-element color)
+
+  Retrieves the CSS color for the element, either
+  a symbol indicating the name of a color, or an
+  RGB string.
+
+> color-native :: (send an-mx-element color-native)
+
+  Retrieves a string indicating the CSS color for
+  the element.  The string either names a color or
+  is an RGB string.
+
+> set-color! :: (send an-mx-element set-color! col)
+
+  Sets the element's CSS color using `col', which
+  may be a string indicating a color name, an
+  integer describing an RGB value, or a string
+  encoding an RGB value.
+
+> set-color-native! :: (send an-mx-element set-color-native! col)
+
+  Sets the element's CSS color using the string
+  `col', which may be a color name or an RGB
+  string.
+
+> background-color :: (send an-mx-element background-color)
+
+  Retrieves a string indicating the CSS
+  background-color for the element.  The string
+  either names a color or is an RGB string.
+
+> background-color-native :: (send an-mx-element background-color-native)
+
+  Retrieves a string indicating the CSS
+  background-color for the element.  The string
+  either names a color or is an RGB string.
+
+> set-background-color! :: (send an-mx-element set-background-color! bc)
+
+  Sets the element's CSS background-color using
+  `bc', which may be a string indicating a color
+  name, an integer describing an RGB value, or a
+  string encoding an RGB value.
+
+> set-background-color-native! :: (send an-mx-element set-background-color-native! bc)
+
+  Sets the element's CSS background-color using
+  the string `bc', which may be a color name or an
+  RGB string.
+
+> background-position-x :: (send an-mx-element background-position-x)
+
+  Retrieves the CSS background-position-x for the
+  element.  The value is either a css-length, a
+  css-percentage, or a symbol in '(left center
+  right).
+
+> background-position-x-native :: (send an-mx-element background-position-x-native)
+
+  Retrieves the CSS background-position-x for the
+  element, a string which is either a CSS length,
+  a CSS percentage, or in '("left" "center"
+  "right").
+
+> set-background-position-x! :: (send an-mx-element set-background-position-x! bpx)
+
+  Sets the element's background-position-x using
+  `bpx', which is either a css-length, a
+  css-percentage, or a symbol in '(left center
+  right).
+
+> set-background-position-x-native! :: (send an-mx-element set-background-position-x-native! bpx)
+
+  Sets the element's background-position-x using
+  the string `bpx', which is either a CSS length,
+  a CSS percentage, or one of '("left" "center"
+  "right").
+
+> background-position-y :: (send an-mx-element background-position-y)
+
+  Retrieves the CSS background-position-y for the
+  element.  The value is either a css-length, a
+  css-percentage, or a symbol in '(top center
+  bottom).
+
+> background-position-y-native :: (send an-mx-element background-position-y-native)
+
+  Retrieves the CSS background-position-y for the
+  element, a string which is either a CSS length,
+  a CSS percentage, or in '("top" "center"
+  "bottom").
+
+> set-background-position-y! :: (send an-mx-element set-background-position-y! bpy)
+
+  Sets the element's background-position-y using
+  `bpy', which is either a css-length, a
+  css-percentage, or a symbol in '(top center
+  bottom).
+
+> set-background-position-y-native! :: (send an-mx-element set-background-position-y-native! bpy)
+
+  Sets the element's background-position-y using
+  the string `bpy', which is either a CSS length,
+  a CSS percentage, or one of '("top" "center"
+  "bottom").
+
+> letter-spacing :: (send an-mx-element letter-spacing)
+
+  Retrieves the CSS letter-spacing for the
+  element, either a css-length or 'normal.
+
+> letter-spacing-native :: (send an-mx-element letter-spacing-native)
+
+  Retrieves the CSS letter-spacing for the
+  element.  The value is a string that is either a
+  CSS length or "normal".
+
+> set-letter-spacing! :: (send an-mx-element set-letter-spacing! ls)
+
+  Sets the element's letter-spacing using `ls',
+  which is either a css-length or 'normal.
+
+> set-letter-spacing-native! :: (send an-mx-element set-letter-spacing-native! ls)
+
+  Sets the element's letter-spacing using the
+  string `ls', which is either a CSS length or
+  "normal".
+
+> vertical-align :: (send an-mx-element vertical-align)
+
+  Retrieves the CSS vertical-align for the
+  element.  The value is a symbol in '(baseline
+  sub super top middle bottom text-top text-bottom
+  ).
+
+> vertical-align-native :: (send an-mx-element vertical-align-native)
+
+  Retrieves the CSS vertical-align for the
+  element.  The value is a string in '("baseline"
+  "sub" "super" "top" "middle" "bottom" "text-top"
+  "text-bottom").
+
+> set-vertical-align! :: (send an-mx-element set-vertical-align! va)
+
+  Sets the element's CSS vertical-align using
+  `va', which is a symbol in '(baseline sub super
+  top middle bottom text-top text-bottom ).
+
+> set-vertical-align-native! :: (send an-mx-element set-vertical-align-native! va)
+
+  Sets the element's letter-spacing using `va',
+  which is a string in '("baseline" "sub" "super"
+  "top" "middle" "bottom" "text-top"
+  "text-bottom").
+
+> text-indent :: (send an-mx-element text-indent)
+
+  Retrieves the CSS text-indent for the element.
+  The value is either a css-length or a
+  css-percentage.
+
+> text-indent-native :: (send an-mx-element text-indent-native)
+
+  Retrieves the CSS text-indent for the element.
+  The value is a string that is either a CSS
+  length or a CSS percentage.
+
+> set-text-indent! :: (send an-mx-element set-text-indent! ti)
+
+  Sets the element's text-indent using `ti', which
+  is either a css-length a css-percentage.
+
+> set-text-indent-native! :: (send an-mx-element set-text-indent-native! ti)
+
+  Sets the element's text-indent using the string
+  `ti', which is either a CSS length or a CSS
+  percentage.
+
+> line-height :: (send an-mx-element line-height)
+
+  Retrieves the CSS line-height for the element.
+  The value is either a css-length, a
+  css-percentage, or 'normal.
+
+> line-height-native :: (send an-mx-element line-height-native)
+
+  Retrieves the CSS line-height for the element.
+  The value is a string that is either a CSS
+  length, a CSS percentage, or "normal".
+
+> set-line-height! :: (send an-mx-element set-line-height! lh)
+
+  Sets the element's line-height using `lh', which
+  is either a css-length, a css-percentage, or
+  'normal.
+
+> set-line-height-native! :: (send an-mx-element set-line-height-native! lh)
+
+  Sets the element's line-height using the string
+  `lh', which is either a CSS length, a CSS
+  percentage, or "normal".
+
+> margin-top :: (send an-mx-element margin-top)
+
+  Retrieves the CSS margin-top for the element.
+  The value is a css-length, a css-percentage, or
+  'auto.
+
+> margin-top-native :: (send an-mx-element margin-top-native)
+
+  Retrieves the CSS margin-top for the element.
+  The value is a string that is a CSS length, a
+  CSS percentage, or "auto".
+
+> set-margin-top! :: (send an-mx-element set-margin-top! mt)
+
+  Sets the element's margin-top using `mt', which
+  is a css-length, a css-percentage, or 'auto.
+
+> set-margin-top-native! :: (send an-mx-element set-margin-top-native! mt)
+
+  Sets the element's margin-top using the string
+  `mt', which is a CSS length, a CSS percentage,
+  or "auto".
+
+> margin-bottom :: (send an-mx-element margin-bottom)
+
+  Retrieves the CSS margin-bottom for the element.
+  The value is a css-length, a css-percentage, or
+  'auto.
+
+> margin-bottom-native :: (send an-mx-element margin-bottom-native)
+
+  Retrieves the CSS margin-bottom for the element.
+  The value is a string that is a CSS length, a
+  CSS percentage, or "auto".
+
+> set-margin-bottom! :: (send an-mx-element set-margin-bottom! mb)
+
+  Sets the element's margin-bottom using `mb',
+  which is a css-length, a css-percentage, or
+  'auto.
+
+> set-margin-bottom-native! :: (send an-mx-element set-margin-bottom-native! mb)
+
+  Sets the element's margin-bottom using the
+  string `mb', which is a CSS length, a CSS
+  percentage, or "auto".
+
+> margin-left :: (send an-mx-element margin-left)
+
+  Retrieves the CSS margin-left for the element.
+  The value is a css-length, a css-percentage, or
+  'auto.
+
+> margin-left-native :: (send an-mx-element margin-left-native)
+
+  Retrieves the CSS margin-left for the element.
+  The value is a string that is a CSS length, a
+  CSS percentage, or "auto".
+
+> set-margin-left! :: (send an-mx-element set-margin-left! ml)
+
+  Sets the element's margin-left using `ml', which
+  is a css-length, a css-percentage, or 'auto.
+
+> set-margin-left-native! :: (send an-mx-element set-margin-left-native! ml)
+
+  Sets the element's margin-left using the string
+  `ml', which is a CSS length, a CSS percentage,
+  or "auto".
+
+> margin-right :: (send an-mx-element margin-right)
+
+  Retrieves the CSS margin-right for the element.
+  The value is a css-length, a css-percentage, or
+  'auto.
+
+> margin-right-native :: (send an-mx-element margin-right-native)
+
+  Retrieves the CSS margin-right for the element.
+  The value is a string that is a CSS length, a
+  CSS percentage, or "auto".
+
+> set-margin-right! :: (send an-mx-element set-margin-right! mr)
+
+  Sets the element's margin-right using `mr',
+  which is a css-length, a css-percentage, or
+  'auto.
+
+> set-margin-right-native! :: (send an-mx-element set-margin-right-native! mr)
+
+  Sets the element's margin-right using the string
+  `mr', which is a CSS length, a CSS percentage,
+  or "auto".
+
+> padding-top :: (send an-mx-element padding-top)
+
+  Retrieves the CSS padding-top for the element.
+  The value is a css-length or css-percentage.
+
+> padding-top-native :: (send an-mx-element padding-top-native)
+
+  Retrieves the CSS padding-top for the element.
+  The value is a string that is a CSS length or
+  CSS percentage.
+
+> set-padding-top! :: (send an-mx-element set-padding-top! pt)
+
+  Sets the element's padding-top using `pt', which
+  is either a css-length or a css-percentage.
+
+> set-padding-top-native! :: (send an-mx-element set-padding-top-native! pt)
+
+  Sets the element's padding-top using `pt', a
+  string that is either a CSS length or a CSS
+  percentage.
+
+> padding-bottom :: (send an-mx-element padding-bottom)
+
+  Retrieves the CSS padding-bottom for the
+  element.  The value is a css-length or a
+  css-percentage.
+
+> padding-bottom-native :: (send an-mx-element padding-bottom-native)
+
+  Retrieves the CSS padding-bottom for the
+  element.  The value is a string that is a CSS
+  length or a CSS percentage.
+
+> set-padding-bottom! :: (send an-mx-element set-padding-bottom! pb)
+
+  Sets the element's padding-bottom using `pb',
+  which is either a css-length or a
+  css-percentage.
+
+> set-padding-bottom-native! :: (send an-mx-element set-padding-bottom-native! pb)
+
+  Sets the element's padding-bottom using `pb', a
+  string that is either a CSS length or a CSS
+  percentage.
+
+> padding-left :: (send an-mx-element padding-left)
+
+  Retrieves the CSS padding-left for the element.
+  The value is a css-length or a css-percentage.
+
+> padding-left-native :: (send an-mx-element padding-left-native)
+
+  Retrieves the CSS padding-left for the element.
+  The value is a string that is a CSS length or a
+  CSS percentage.
+
+> set-padding-left! :: (send an-mx-element set-padding-left! pl)
+
+  Sets the element's padding-left using `pl',
+  which is either a css-length or a
+  css-percentage.
+
+> set-padding-left-native! :: (send an-mx-element set-padding-left-native! pl)
+
+  Sets the element's padding-left using `pl', a
+  string that is either a CSS length or a CSS
+  percentage.
+
+> padding-right :: (send an-mx-element padding-right)
+
+  Retrieves the CSS padding-right for the element.
+  The value is a css-length or a css-percentage.
+
+> padding-right-native :: (send an-mx-element padding-right-native)
+
+  Retrieves the CSS padding-right for the element.
+  The value is a string that is a CSS length or a
+  CSS percentage.
+
+> set-padding-right! :: (send an-mx-element set-padding-right! pr)
+
+  Sets the element's padding-right using `pr',
+  which is either a css-length or a
+  css-percentage.
+
+> set-padding-right-native! :: (send an-mx-element set-padding-right-native! pr)
+
+  Sets the element's padding-right using `pr',
+  which is either a CSS length or a CSS
+  percentage.
+
+> border-top-color :: (send an-mx-element border-top-color)
+
+  Retrieves the CSS border-top-color for the
+  element.  The value is either a symbol
+  indicating a color name or an RGB string.
+
+> border-top-color-native :: (send an-mx-element border-top-color-native)
+
+  Retrieves a string indicating the CSS
+  border-top-color for the element.  The string is
+  either the name of a color or an RGB string.
+
+> set-border-top-color! :: (send an-mx-element set-border-top-color! btc)
+
+  Sets the element's border-top-color using the
+  string `btc', which is either a symbol
+  indicating the name of a color or an RGB string.
+
+> set-border-top-color-native! :: (send an-mx-element set-border-top-color-native! btc)
+
+  Sets the element's border-top-color using the
+  string `btc', which is either the name of a
+  color or an RGB string.
+
+> border-bottom-color :: (send an-mx-element border-bottom-color)
+
+  Retrieves the CSS border-bottom-color for the
+  element.  The value is either a symbol
+  indicating a color name or an RGB string.
+
+> border-bottom-color-native :: (send an-mx-element border-bottom-color-native)
+
+  Retrieves the CSS border-bottom-color for the
+  element.  The value is a string that is either a
+  color name or an RGB string.
+
+> set-border-bottom-color! :: (send an-mx-element set-border-bottom-color! btc)
+
+  Sets the element's border-bottom-color using
+  `btc', which either a symbol indicating a color
+  name, or an RGB string.
+
+> set-border-bottom-color-native! :: (send an-mx-element set-border-bottom-color-native! btc)
+
+  Sets the element's border-bottom-color using
+  `btc', a string that is either a color name or
+  an RGB string.
+
+> border-left-color :: (send an-mx-element border-left-color)
+
+  Retrieves the CSS border-left-color for the
+  element.  The value is either a symbol
+  indicating a color name or an RGB string.
+
+> border-left-color-native :: (send an-mx-element border-left-color-native)
+
+  Retrieves the CSS border-left-color for the
+  element.  The value is a string that is either a
+  color name or RGB string.
+
+> set-border-left-color! :: (send an-mx-element set-border-left-color! btc)
+
+  Sets the element's border-left-color using
+  `btc', which is either a symbol indicating a
+  color name or an RGB string.
+
+> set-border-left-color-native! :: (send an-mx-element set-border-left-color-native! btc)
+
+  Sets the element's border-left-color using the
+  string `btc', which is either a color name or
+  RGB string.
+
+> border-right-color :: (send an-mx-element border-right-color)
+
+  Retrieves the CSS border-right-color for the
+  element.  The value is either a symbol
+  indicating a color name or an RGB string.
+
+> border-right-color-native :: (send an-mx-element border-right-color-native)
+
+  Retrieves the CSS border-right-color for the
+  element.  The value is a string indicating a
+  color name or an RGB string.
+
+> set-border-right-color! :: (send an-mx-element set-border-right-color! btc)
+
+  Sets the element's border-right-color using
+  `btc', which is either a symbol indicating a
+  color name or an RGB string.
+
+> set-border-right-color-native! :: (send an-mx-element set-border-right-color-native! btc)
+
+  Sets the element's border-right-color using the
+  string `btc', which is either a color name or
+  RGB string.
+
+> border-top-width :: (send an-mx-element border-top-width)
+
+  Retrieves a value describing the CSS
+  border-top-width for the element.  The value is
+  either a css-length or a symbol, one of '(medium
+  thin thick).
+
+> border-top-width-native :: (send an-mx-element border-top-width-native)
+
+  Retrieves a string describing the CSS
+  border-top-width for the element.  The string is
+  either a CSS length or one of '("medium" "thin"
+  "thick").
+
+> set-border-top-width! :: (send an-mx-element set-border-top-width! btw)
+
+  Sets the element's CSS border-top-width using
+  `btw', which is either a css-length, or a symbol
+  in '(thin medium thick).
+
+> set-border-top-width-native! :: (send an-mx-element set-border-top-width-native! btw)
+
+  Sets the element's CSS border-top-width using
+  the string `btw', which is either a CSS length,
+  or in '("thin" "medium" "thick").
+
+> border-bottom-width :: (send an-mx-element border-bottom-width)
+
+  Retrieves a value describing the CSS
+  border-bottom-width for the element.  The value
+  is either a css-length or a symbol in '(medium
+  thin thick).
+
+> border-bottom-width-native :: (send an-mx-element border-bottom-width-native)
+
+  Retrieves a string describing the CSS
+  border-bottom-width for the element.  The string
+  is either a CSS length or in '("thin" "medium"
+  "thick").
+
+> set-border-bottom-width! :: (send an-mx-element set-border-bottom-width! bbw)
+
+  Sets the element's CSS border-bottom-width using
+  the value `bbw', which is either a css-length,
+  or a symbol in '(thin medium thick).
+
+> set-border-bottom-width-native! :: (send an-mx-element set-border-bottom-width-native! bbw)
+
+  Sets the element's CSS border-bottom-width using
+  the string `bbw', which is either a CSS length
+  or in '("thin" "medium" "thick").
+
+> border-left-width :: (send an-mx-element border-left-width)
+
+  Retrieves a value describing the CSS
+  border-left-width for the element.  The value is
+  either a css-length or a symbol in '(thin medium
+  thick).
+
+> border-left-width-native :: (send an-mx-element border-left-width-native)
+
+  Retrieves a string describing the CSS
+  border-left-width for the element.  The string
+  is either a CSS length or in '("thin" "medium"
+  "thick").
+
+> set-border-left-width! :: (send an-mx-element set-border-left-width! blw)
+
+  Sets the element's CSS border-left-width using
+  `blw', which is either a css-length or a symbol
+  in '(thin medium thick).
+
+> set-border-left-width-native! :: (send an-mx-element set-border-left-width-native! blw)
+
+  Sets the element's CSS border-left-width using
+  the string `blw', which is either a CSS length
+  or in '("thin" "medium" "thick").
+
+> border-right-width :: (send an-mx-element border-right-width)
+
+  Retrieves a value describing the CSS
+  border-right-width for the element.  The value
+  is either a css-length or a symbol in '(thin
+  medium thick).
+
+> border-right-width-native :: (send an-mx-element border-right-width-native)
+
+  Retrieves a string describing the CSS
+  border-right-width for the element.  The string
+  is either a CSS length or in '("thin" "medium"
+  "thick").
+
+> set-border-right-width! :: (send an-mx-element set-border-right-width! brw)
+
+  Sets the element's CSS border-right-width using
+  `brw', which is either a css-length or a symbol
+  in '(thin medium thick).
+
+> set-border-right-width-native! :: (send an-mx-element set-border-right-width-native! brw)
+
+  Sets the element's CSS border-right-width using
+  the string `brw', which is either a CSS length
+  or in '("thin" "medium" "thick").
+
+> width :: (send an-mx-element width)
+
+  Retrieves a value describing the CSS width for
+  the element.  The value is a css-length, a
+  css-percentage, or 'auto.
+
+> width-native :: (send an-mx-element width-native)
+
+  Retrieves a string describing the CSS width for
+  the element.  The string is a CSS length, a CSS
+  percentage, or "auto".
+
+> set-width! :: (send an-mx-element set-width! w)
+
+  Sets the element's CSS width using `w', which
+  may be a css-length, a css-percentage, or 'auto.
+
+> set-width-native! :: (send an-mx-element set-width-native! w)
+
+  Sets the element's CSS width using `w', which
+  may be a CSS length, a CSS percentage, or
+  "auto".
+
+> height :: (send an-mx-element height)
+
+  Retrieves a value describing the CSS height for
+  the element.  The value is a css-length, a
+  css-percentage, or 'auto.
+
+> height-native :: (send an-mx-element height-native)
+
+  Retrieves a string describing the CSS height for
+  the element.  The string is a CSS length, a CSS
+  percentage, or "auto".
+
+> set-height! :: (send an-mx-element set-height! h)
+
+  Sets the element's CSS height using `h', which
+  may be css-length, a css-percentage, or 'auto.
+
+> set-height-native! :: (send an-mx-element set-height-native! h)
+
+  Sets the element's CSS height using `h', which
+  may be CSS length, a CSS percentage, or "auto".
+
+> top :: (send an-mx-element top)
+
+  Retrieves a value describing the CSS topt for
+  the element.  The value is a css-length, a
+  css-percentage, or 'auto.
+
+> top-native :: (send an-mx-element top-native)
+
+  Retrieves a string describing the CSS top for
+  the element.  The string is a CSS length, a CSS
+  percentage, or "auto".
+
+> set-top! :: (send an-mx-element set-top! t)
+
+  Sets the element's CSS top using `t', which may
+  be css-length, a css-percentage, or 'auto.
+
+> set-top-native! :: (send an-mx-element set-top-native! t)
+
+  Sets the element's CSS top using `t', which may
+  be CSS length, a CSS percentage, or "auto".
+
+> left :: (send an-mx-element left)
+
+  Retrieves a string describing the CSS left for
+  the element.  The string is a CSS length, a CSS
+  percentage, or "auto".
+
+> left-native :: (send an-mx-element left-native)
+
+  Retrieves a string describing the CSS left for
+  the element.  The string is a CSS length, a CSS
+  percentage, or "auto".
+
+> set-left! :: (send an-mx-element set-left! l)
+
+  Sets the element's CSS left using `l', which may
+  be css-length, a css-percentage, or 'auto.
+
+> set-left-native! :: (send an-mx-element set-left-native! l)
+
+  Sets the element's CSS left using `l', which may
+  be CSS length, a CSS percentage, or "auto".
+
+> z-index :: (send an-mx-element z-index)
+
+  Retrieves a value describing the CSS z-index for
+  the element.  The value is either an integer or
+  'auto.
+
+> z-index-native :: (send an-mx-element z-index-native)
+
+  Retrieves a value describing the CSS z-index for
+  the element.  The value is either an integer or
+  "auto".
+
+> set-z-index! :: (send an-mx-element set-z-index! zi)
+
+  Sets the element's CSS z-index using `zi', which
+  may be either an integer or 'auto.
+
+> set-z-index-native! :: (send an-mx-element set-z-index-native! zi)
+
+  Sets the element's CSS z-index using `zi', which
+  may be either an integer or "auto".
diff --git a/collects/mysterx/info.ss b/collects/mysterx/info.ss
new file mode 100644
index 0000000000..38f76445be
--- /dev/null
+++ b/collects/mysterx/info.ss
@@ -0,0 +1,16 @@
+;; info.ss for mysterx collection
+
+(module info (lib "infotab.ss" "setup")
+  (define name "MysterX")
+  (define doc.txt "doc.txt")
+  (define help-desk-message "Mz/Mr: (require (lib \"mysterx.ss\" \"mysterx\"))")
+  (define blurb
+    (list
+     "MysterX is an extension that lets you use Scheme to script "
+     "ActiveX controls and other COM components under Windows. "
+     "MysterX also has a programmable Web browser with support for "
+     "Dynamic HTML."))
+  (define compile-omit-files '("mxdemo.ss"))
+  (define post-install-collection "installer.ss")
+  (define release-version "299")
+  (define release-iteration "0"))
diff --git a/collects/mysterx/installer.ss b/collects/mysterx/installer.ss
new file mode 100644
index 0000000000..ed220a420d
--- /dev/null
+++ b/collects/mysterx/installer.ss
@@ -0,0 +1,27 @@
+(module installer mzscheme
+  (require (lib "process.ss"))
+  (provide post-installer)
+  (define (post-installer mx-path)
+    (define (make-dll-path . more)
+      (apply build-path (collection-path "mysterx")
+             "private" "compiled" "native" "win32" "i386" more))
+    (define (warn fmt . args) (apply fprintf (current-error-port) fmt args))
+    (let* ([dlls '("myspage.dll" "myssink.dll")]
+           [dll-paths (map make-dll-path dlls)]
+           [winsys-dir (find-system-path 'sys-dir)]
+           [regsvr (and winsys-dir (build-path winsys-dir "REGSVR32.EXE"))])
+      (cond
+       [(not (eq? (system-type) 'windows))
+        (printf "Warning: can't install MysterX on non-Windows machine\n")]
+       [(not (andmap file-exists? dll-paths))
+        (printf "Warning: MysterX binaries not installed\n")]
+       [(not winsys-dir)
+        (printf "Warning: Can't run REGSVR32 on libraries\n")]
+       [else (parameterize ([current-directory (make-dll-path)])
+               (for-each
+                (lambda (dll)
+                  (printf "MysterX: ~a library ~a\n"
+                          (if (eq? 0 (system*/exit-code regsvr "/s" dll))
+                            "Registered" "Unable to register")
+                          dll))
+                dlls))]))))
diff --git a/collects/mysterx/mxdemo.ss b/collects/mysterx/mxdemo.ss
new file mode 100644
index 0000000000..aa7c797124
--- /dev/null
+++ b/collects/mysterx/mxdemo.ss
@@ -0,0 +1,194 @@
+;;; mxdemo.ss -- demo program for MysterX
+
+;;; requires Office 97/2000/XP to be installed for Calendar Control to work
+
+(require (lib "class.ss"))
+(require (lib "mysterx.ss" "mysterx"))
+
+; the browser with the calendar
+
+(define calwb (instantiate mx-browser% 
+			   () ; no by-position initializers
+			   (label "Calendar control")
+			   (height 400)
+			   (width 350)
+			   (y 100)
+			   (x 100)
+			   (style-options '(scrollbars))))
+
+(define caldoc (send calwb current-document))
+
+(send caldoc insert-html 
+	(string-append	
+	 "<H1 id=\"mx-header\">MysterX Demo</H1>"
+	 "<p>"
+	 "<hr>"
+	 "<p>"
+	 (progid->html "MSCAL.Calendar.7" 300 200)
+	 "<p>"
+	 "<H3 id=\"event-header\"></H3>"))
+
+(define cal (car (send caldoc objects)))
+
+; the control panel document 
+(define ctrlwb (make-object mx-browser% "Control Panel" 180 350 600 300 '()))
+(define ctrldoc (send ctrlwb current-document))
+
+(send ctrldoc insert-html 
+	(string-append	
+	"<table align = center>"
+
+	"<caption id=\"Caption\"><b>Keypress here</b></caption>"
+
+	"<colgroup align=left>"
+	"<colgroup align=center>"
+	"<colgroup align=right>"
+
+	"<tr>"
+	"<td><BUTTON id=\"Yesterday\" style=\"color: blue\">&LT----</BUTTON></td>"
+	"<td><b>Day</b></td>"
+	"<td><BUTTON id=\"Tomorrow\" style=\"color: red\">----&GT</BUTTON></td>"
+	"</tr>"
+
+	"<tr>"
+	"<td><BUTTON id=\"Last-month\" style=\"color: green\">&LT----</BUTTON></td>"
+	"<td><b>Month</b></td>"
+	"<td><BUTTON id=\"Next-month\" style=\"color: indigo\">----&GT</BUTTON></td>"
+	"</tr>"
+
+	"<tr>"
+	"<td><BUTTON id=\"Last-year\" style=\"color: yellow\">&LT----</BUTTON></td>"
+	"<td><b>Year</b></td>"
+	"<td><BUTTON id=\"Next-year\" style=\"color: purple\">----&GT</BUTTON></td>"
+	"</tr>"
+
+	"</table>"
+
+	"<table align=center>"
+	
+	"<td><BUTTON id=\"Today\">Today</BUTTON></td>"
+
+	"</table>"
+	
+	"<hr>"
+
+	"<table align=center>"
+
+	"<tr>"
+	"<td><BUTTON id=\"Hide\">Hide</BUTTON></td>"
+	"<td><BUTTON id=\"Show\">Show</BUTTON></td>"
+	"</tr>"
+
+	"</table>"
+
+	"<table align=center>"
+	
+	"<td><BUTTON id=\"Rub-me\">Rub me!</BUTTON></td>"
+
+	"</table>"
+
+	"<table align=center>"
+
+	"<td><BUTTON id=\"About\">About</BUTTON></td>"
+
+	"</table>"
+
+	"<p>"
+
+	"<table align=center>"
+	
+	"<td id=\"event-reflector\">Click on the calendar</td>"
+
+	"</table>"))
+	
+(define reflector (send ctrldoc find-element "TD" "event-reflector"))
+
+(com-register-event-handler 
+ cal "Click" 
+ (lambda ()
+   (send reflector set-color! 'white) 
+   (send reflector set-background-color! 'blue)
+   (thread
+    (lambda ()
+      (sleep 0.25)
+      (send reflector set-color! 'black) 
+      (send reflector set-background-color! 'white)))))
+
+(define (about-handler ev)
+  (when (send ev click?)
+	(com-invoke cal "AboutBox")))
+
+(define (hide-handler ev)
+  (when (send ev click?)
+	(send calwb show #f)))
+
+(define (show-handler ev)
+  (when (send ev click?)
+	(send calwb show #t)))
+
+(define rub-me-handler
+  (let ([count 0])
+    (lambda (ev)
+      (when (send ev mousemove?)
+	    (printf "mousemove #~a, but who's counting?~n" count)
+	    (set! count (add1 count))))))
+
+(define (today-handler ev)
+  (when (send ev click?)
+	(com-invoke cal "Today")))
+
+(define (yesterday-handler ev)
+  (when (send ev click?)
+	(com-invoke cal "PreviousDay")))
+
+(define (tomorrow-handler ev)
+  (when (send ev click?)
+	(com-invoke cal "NextDay")))
+
+(define (last-month-handler ev)
+  (when (send ev click?)
+	(com-invoke cal "PreviousMonth")))
+
+(define (next-month-handler ev)
+  (when (send ev click?)
+	(com-invoke cal "NextMonth")))
+
+(define (last-year-handler ev)
+  (when (send ev click?)
+	(com-invoke cal "PreviousYear")))
+
+(define (next-year-handler ev)
+  (when (send ev click?)
+	(com-invoke cal "NextYear")))
+
+(define button-handlers
+  `(("About" ,about-handler)
+    ("Hide" ,hide-handler)
+    ("Show" ,show-handler)
+    ("Rub-me" ,rub-me-handler)
+    ("Today" ,today-handler)
+    ("Yesterday" ,yesterday-handler)
+    ("Tomorrow" ,tomorrow-handler)
+    ("Last-month" ,last-month-handler)
+    ("Next-month" ,next-month-handler)
+    ("Last-year" ,last-year-handler)
+    ("Next-year" ,next-year-handler)))
+
+(send ctrlwb register-event-handler 
+  (send ctrldoc find-element "CAPTION" "Caption")
+	(lambda (ev)
+	  (when (send ev keypress?)
+		(printf "ooh that tickles~n"))))
+
+(for-each
+ (lambda (sym-handler)
+   (send ctrlwb register-event-handler 
+		(send ctrldoc find-element 
+		      "BUTTON"              ; tag
+                      (car sym-handler))    ; id
+		(cadr sym-handler)))        ; handler
+ button-handlers)
+
+(send ctrlwb handle-events)
+
+			       
diff --git a/collects/mysterx/mysterx.ss b/collects/mysterx/mysterx.ss
new file mode 100644
index 0000000000..3c13e21747
--- /dev/null
+++ b/collects/mysterx/mysterx.ss
@@ -0,0 +1,2598 @@
+;; mysterx.ss
+
+(module mysterx mzscheme
+
+  ; private mysterx modules
+
+  (require (prefix mxprims: "private/mxmain.ss"))
+  (require (prefix style: "private/style.ss"))
+  (require "private/filter.ss")
+  (require "private/properties.ss")
+  (require "private/util.ss")
+
+  ; mzlib
+
+  (require (prefix mzlib: (lib "list.ss")))
+  (require (lib "string.ss"))
+  (require (lib "class.ss"))
+  (require (lib "url.ss" "net"))
+  (require (lib "etc.ss"))
+  (require (lib "thread.ss"))
+
+  ; exports
+
+  (provide
+    mx-browser%
+    mx-element%
+    mx-version
+    block-while-browsers
+    com-invoke
+    com-get-property
+    com-set-property!
+    com-methods
+    com-get-properties
+    com-set-properties
+    com-events
+    com-method-type
+    com-get-property-type
+    com-set-property-type
+    com-event-type
+    com-object-type
+    com-add-ref
+    com-ref-count
+    com-is-a?
+    com-help
+    com-register-event-handler
+    com-unregister-event-handler
+    com-all-coclasses
+    com-all-controls
+    coclass->html
+    progid->html
+    cocreate-instance-from-coclass
+    cci/coclass
+    cocreate-instance-from-progid
+    cci/progid
+    coclass
+    progid
+    set-coclass!
+    set-coclass-from-progid!
+    com-object-eq?
+    com-omit
+    make-css-percentage
+    css-percentage?
+    css-percentage-num
+    make-css-length
+    css-length?
+    css-length-num
+    css-length-units
+    com-date->date
+    date->com-date
+    com-date?
+    com-currency?
+    com-currency->number
+    number->com-currency
+    com-scode?
+    com-scode->number
+    number->com-scode
+    com-object?
+    com-iunknown?
+    %%initialize-dotnet-runtime)
+
+  (define mx-version mxprims:mx-version)
+  (define block-while-browsers mxprims:block-while-browsers)
+  (define com-invoke mxprims:com-invoke)
+  (define com-method-type mxprims:com-method-type)
+  (define com-get-property-type mxprims:com-get-property-type)
+  (define com-set-property-type mxprims:com-set-property-type)
+  (define com-event-type mxprims:com-event-type)
+  (define com-object-type mxprims:com-object-type)
+  (define com-add-ref mxprims:com-add-ref)
+  (define com-ref-count mxprims:com-ref-count)
+  (define com-is-a? mxprims:com-is-a?)
+  (define com-currency? mxprims:com-currency?)
+  (define number->com-currency mxprims:number->com-currency)
+  (define com-currency->number mxprims:com-currency->number)
+  (define com-date? mxprims:com-date?)
+  (define com-date->date mxprims:com-date->date)
+  (define date->com-date mxprims:date->com-date)
+  (define com-scode? mxprims:com-scode?)
+  (define number->com-scode mxprims:number->com-scode)
+  (define com-scode->number mxprims:com-scode->number)
+  (define com-object? mxprims:com-object?)
+  (define com-iunknown? mxprims:com-iunknown?)
+  (define com-help mxprims:com-help)
+  (define com-register-event-handler mxprims:com-register-event-handler)
+  (define com-unregister-event-handler mxprims:com-unregister-event-handler)
+  (define coclass->html mxprims:coclass->html)
+  (define progid->html mxprims:progid->html)
+  (define cocreate-instance-from-coclass mxprims:cocreate-instance-from-coclass)
+  (define cci/coclass cocreate-instance-from-coclass)
+  (define cocreate-instance-from-progid mxprims:cocreate-instance-from-progid)
+  (define cci/progid cocreate-instance-from-progid)
+  (define coclass mxprims:coclass)
+  (define progid mxprims:progid)
+  (define set-coclass! mxprims:set-coclass!)
+  (define set-coclass-from-progid! mxprims:set-coclass-from-progid!)
+  (define com-object-eq? mxprims:com-object-eq?)
+  (define com-omit mxprims:com-omit)
+
+  (define %%initialize-dotnet-runtime mxprims:%%initialize-dotnet-runtime)
+
+  ;; sort results of "reflection" results
+
+  (define (alphabetize lst)
+    (mzlib:quicksort lst string-ci<?))
+
+  (define (make-sorted-fun f)
+    (lambda (obj)
+      (alphabetize (f obj))))
+
+  (define com-methods (make-sorted-fun mxprims:com-methods))
+  (define com-get-properties (make-sorted-fun mxprims:com-get-properties))
+  (define com-set-properties (make-sorted-fun mxprims:com-set-properties))
+  (define com-events (make-sorted-fun mxprims:com-events))
+
+  (define (make-sorted-thunk f)
+    (lambda ()
+      (alphabetize (f))))
+
+  (define com-all-coclasses
+    (make-sorted-thunk mxprims:com-all-coclasses))
+  (define com-all-controls
+    (make-sorted-thunk mxprims:com-all-controls))
+
+  ;; property getter/setter
+
+  (define (get-item-property obj item)
+    (cond
+     [(and (pair? item)
+	   (string? (car item)))
+      (apply mxprims:com-get-property obj item)]
+     [(string? item)
+      (mxprims:com-get-property obj item)]
+     [else
+      (error "For COM property, expected a string or a list with a string a the first element")]))
+
+  (define (com-get-property obj . path)
+    (cond
+     [(null? path)
+      (error 'com-get-property
+	     "Expected one or more properties (strings or lists with a string as the first element)")]
+     [(null? (cdr path))
+      (get-item-property obj (car path))]
+     [else (apply com-get-property
+		  (get-item-property obj (car path))
+		  (cdr path))]))
+
+  (define (com-set-property! obj . path-and-value)
+    (cond
+     [(or (null? path-and-value)
+	  (null? (cdr path-and-value)))
+      (error 'com-set-property!
+	     "Expected one or more properties (strings or lists with a string as the first element) and a value")]
+     [(null? (cddr path-and-value)) ; (property value)
+      (let ([ppty (car path-and-value)]
+	    [val (cadr path-and-value)])
+	(if (pair? ppty)
+	    (if (string? (car ppty))
+		(apply mxprims:com-set-property! obj
+		       (append ppty (list val)))
+		(error 'com-set-property!
+		       "Indexed property must be a list with a string (property name) as the first element"))
+	    (mxprims:com-set-property! obj ppty val)))]
+     [else (apply com-set-property!
+		  (get-item-property obj (car path-and-value))
+		  (cdr path-and-value))]))
+
+  ;; style-related procedures
+
+  (define make-css-percentage style:make-css-percentage)
+  (define css-percentage? style:css-percentage?)
+  (define css-percentage-num style:css-percentage-num)
+  (define make-css-length style:make-css-length)
+  (define css-length? style:css-length?)
+  (define css-length-num style:css-length-num)
+  (define css-length-units style:css-length-units)
+
+  (define html-sem (make-semaphore 1))   ; protects HTML insertions
+  (define html-wait (lambda () (semaphore-wait html-sem)))
+  (define html-post (lambda () (semaphore-post html-sem)))
+
+  (define mx-element%
+    (class object% (init document dhtml-element)
+       (public
+	insert-html
+	append-html
+	replace-html
+	get-html
+	get-text
+	insert-text
+	append-text
+	insert-object-from-coclass
+	append-object-from-coclass
+	insert-object-from-progid
+	append-object-from-progid
+	focus
+	selection
+	set-selection!
+	attribute
+	set-attribute!
+	click
+	tag
+	font-family
+	font-family-native
+	set-font-family!
+	set-font-family-native!
+	font-style
+	font-style-native
+	set-font-style!
+	set-font-style-native!
+	font-variant
+	font-variant-native
+	set-font-variant!
+	set-font-variant-native!
+	font-weight
+	font-weight-native
+	set-font-weight!
+	set-font-weight-native!
+	font-native
+	set-font-native!
+	background-native
+	set-background-native!
+	background-attachment
+	background-attachment-native
+	set-background-attachment!
+	set-background-attachment-native!
+	background-image
+	background-image-native
+	set-background-image!
+	set-background-image-native!
+	background-repeat
+	background-repeat-native
+	set-background-repeat!
+	set-background-repeat-native!
+	background-position
+	background-position-native
+	set-background-position!
+	set-background-position-native!
+	text-decoration
+	text-decoration-native
+	set-text-decoration!
+	set-text-decoration-native!
+	text-transform
+	text-transform-native
+	set-text-transform!
+	set-text-transform-native!
+	text-align
+	text-align-native
+	set-text-align!
+	set-text-align-native!
+	margin
+	margin-native
+	set-margin!
+	set-margin-native!
+	padding
+	padding-native
+	set-padding!
+	set-padding-native!
+	border
+	border-native
+	set-border!
+	set-border-native!
+	border-top-native
+	set-border-top!
+	set-border-top-native!
+	border-bottom-native
+	set-border-bottom!
+	set-border-bottom-native!
+	border-left-native
+	set-border-left!
+	set-border-left-native!
+	border-right-native
+	border-top
+	border-bottom
+	border-left
+	border-right
+	set-border-right!
+	set-border-right-native!
+	border-color
+	border-color-native
+	set-border-color!
+	set-border-color-native!
+	border-width
+	border-width-native
+	set-border-width!
+	set-border-width-native!
+	border-style
+	border-style-native
+	set-border-style!
+	set-border-style-native!
+	border-top-style
+	border-top-style-native
+	set-border-top-style!
+	set-border-top-style-native!
+	border-bottom-style
+	border-bottom-style-native
+	set-border-bottom-style!
+	set-border-bottom-style-native!
+	border-left-style
+	border-left-style-native
+	set-border-left-style!
+	set-border-left-style-native!
+	border-right-style
+	border-right-style-native
+	set-border-right-style!
+	set-border-right-style-native!
+	border-top-color
+	border-top-color-native!
+	set-border-top-color!
+	set-border-top-color-native!
+	border-bottom-color
+	border-bottom-color-native
+	set-border-bottom-color!
+	set-border-bottom-color-native!
+	border-left-color
+	border-left-color-native
+	set-border-left-color!
+	set-border-left-color-native!
+	border-right-color
+	border-right-color-native
+	set-border-right-color!
+	set-border-right-color-native!
+	border-top-width
+	border-top-width-native
+	set-border-top-width!
+	set-border-top-width-native!
+	border-bottom-width
+	border-bottom-width-native
+	set-border-bottom-width!
+	set-border-bottom-width-native!
+	border-left-width
+	border-left-width-native
+	set-border-left-width!
+	set-border-left-width-native!
+	border-right-width
+	border-right-width-native
+	set-border-right-width!
+	set-border-right-width-native!
+	style-float
+	style-float-native
+	set-style-float!
+	set-style-float-native!
+	clear
+	clear-native
+	set-clear!
+	set-clear-native!
+	display
+	display-native
+	set-display!
+	set-display-native!
+	visibility
+	visibility-native
+	set-visibility!
+	set-visibility-native!
+	list-style-type
+	list-style-type-native
+	set-list-style-type!
+	set-list-style-type-native!
+	list-style-position
+	list-style-position-native
+	set-list-style-position!
+	set-list-style-position-native!
+	list-style-image
+	list-style-image-native
+	set-list-style-image!
+	set-list-style-image-native!
+	list-style
+	list-style-native
+	set-list-style!
+	set-list-style-native!
+	position
+	position-native
+	overflow
+	overflow-native
+	set-overflow!
+	set-overflow-native!
+	pagebreak-before
+	pagebreak-before-native
+	set-pagebreak-before!
+	set-pagebreak-before-native!
+	pagebreak-after
+	pagebreak-after-native
+	set-pagebreak-after!
+	css-text-native
+	set-css-text-native!
+	cursor
+	cursor-native
+	set-cursor!
+	set-cursor-native!
+	clip
+	clip-native
+	set-clip!
+	set-clip-native!
+	filter
+	filter-native
+	set-filter!
+	set-filter-native!
+	style-string
+	text-decoration-none
+	set-text-decoration-none!
+	text-decoration-underline
+	set-text-decoration-underline!
+	text-decoration-overline
+	set-text-decoration-overline!
+	text-decoration-linethrough
+	set-text-decoration-linethrough!
+	text-decoration-blink
+	set-text-decoration-blink!
+	pixel-top
+	set-pixel-top!
+	pixel-left
+	set-pixel-left!
+	pixel-width
+	set-pixel-width!
+	pixel-height
+	set-pixel-height!
+	pos-top
+	set-pos-top!
+	pos-left
+	set-pos-left!
+	pos-width
+	set-pos-width!
+	pos-height
+	set-pos-height!
+	font-size
+	font-size-native
+	set-font-size!
+	set-font-size-native!
+	color
+	color-native
+	set-color!
+	set-color-native!
+	background-color
+	background-color-native
+	set-background-color!
+	set-background-color-native!
+	background-position-x
+	background-position-x-native
+	set-background-position-x!
+	set-background-position-x-native!
+	background-position-y
+	background-position-y-native
+	set-background-position-y!
+	set-background-position-y-native!
+	letter-spacing
+	letter-spacing-native
+	set-letter-spacing!
+	set-letter-spacing-native!
+	vertical-align
+	vertical-align-native
+	set-vertical-align!
+	set-vertical-align-native!
+	text-indent
+	text-indent-native
+	set-text-indent!
+	set-text-indent-native!
+	line-height
+	line-height-native
+	set-line-height!
+	set-line-height-native!
+	margin-top
+	margin-top-native
+	set-margin-top!
+	set-margin-top-native!
+	margin-bottom
+	margin-bottom-native
+	set-margin-bottom!
+	set-margin-bottom-native!
+	margin-left
+	margin-left-native
+	set-margin-left!
+	set-margin-left-native!
+	margin-right
+	margin-right-native
+	set-margin-right!
+	set-margin-right-native!
+	padding-top
+	padding-top-native
+	set-padding-top!
+	set-padding-top-native!
+	padding-bottom
+	padding-bottom-native
+	set-padding-bottom!
+	set-padding-bottom-native!
+	padding-left
+	padding-left-native
+	set-padding-left!
+	set-padding-left-native!
+	padding-right
+	padding-right-native
+	set-padding-right!
+	set-padding-right-native!
+	width
+	width-native
+	set-width!
+	set-width-native!
+	height
+	height-native
+	set-height!
+	set-height-native!
+	top
+	top-native
+	set-top!
+	set-top-native!
+	left
+	left-native
+	set-left!
+	set-left-native!
+	z-index
+	z-index-native
+	set-z-index!
+	set-z-index-native!)
+
+       ; private fields
+       (define elt dhtml-element)
+
+       (define doc document)
+
+       (define get-string-as-symbol
+	(lambda (f name)
+	  (let ([s (f elt)])
+	    (if (empty-string? s)
+		(empty-property-error name)
+		(string->symbol s)))))
+
+       (define set-symbol-as-string
+	 (lambda (sym vals f name)
+	   (unless (member sym vals)
+		   (error
+		    (format "~a: Expected value in '~a, got ~a"
+			    name vals sym)))
+	   (f elt (symbol->string sym))))
+
+       (define html-insertion-maker
+	 (lambda (f)
+	   (lambda (s)
+	     (dynamic-wind
+		 html-wait
+		 (lambda () (f elt s))
+		 html-post))))
+
+       (define insert-object-maker
+	 (lambda (name->html)
+	   (opt-lambda
+	    (object width height [size 'pixels])
+	    (dynamic-wind
+		html-wait
+		(lambda ()
+		  (let ([old-objects (mxprims:document-objects doc)])
+		    (mxprims:element-insert-html
+		     elt
+		     (name->html object width height size))
+		    (let* ([new-objects (mxprims:document-objects doc)]
+			   [obj (car (mzlib:remove* old-objects new-objects
+						    com-object-eq?))])
+		      (mxprims:com-register-object obj)
+		      obj)))
+		html-post))))
+
+       (define append-object-maker
+	 (lambda (name->html)
+	   (opt-lambda
+	    (object width height [size 'pixels])
+	    (dynamic-wind
+		html-wait
+		(lambda ()
+		  (let* ([old-objects (mxprims:document-objects doc)])
+		    (mxprims:element-append-html
+		     elt
+		     (name->html object width height size))
+		    (let* ([new-objects (mxprims:document-objects doc)]
+			   [obj (car (mzlib:remove* old-objects
+						    new-objects
+						    com-object-eq?))])
+		      (mxprims:com-register-object obj)
+		      obj)))
+		html-post))))
+
+       (define insert-object-from-coclass-raw
+	(insert-object-maker coclass->html))
+       (define append-object-from-coclass-raw
+	(append-object-maker coclass->html))
+       (define insert-object-from-progid-raw
+	(insert-object-maker progid->html))
+       (define append-object-from-progid-raw
+	(append-object-maker progid->html))
+       (define insert-html
+	 (lambda (s)
+	   (dynamic-wind
+	       html-wait
+	       (lambda () (mxprims:element-insert-html elt s))
+	       html-post)))
+       (define get-html
+	 (lambda () (mxprims:element-get-html elt)))
+       (define get-text
+	 (lambda () (mxprims:element-get-text elt)))
+       (define insert-text
+	 (lambda (s)
+	   (dynamic-wind
+	       html-wait
+	       (lambda () (mxprims:element-insert-text elt s))
+	       html-post)))
+       (define append-text
+	 (lambda (s)
+	   (dynamic-wind
+	       html-wait
+	       (lambda () (mxprims:element-append-text elt s))
+	       html-post)))
+       (define append-html
+	 (lambda (s)
+	   (dynamic-wind
+	       html-wait
+	       (lambda () (mxprims:element-append-html elt s))
+	       html-post)))
+       (define replace-html
+	 (lambda (s)
+	   (dynamic-wind
+	       html-wait
+	       (lambda () (mxprims:element-replace-html elt s))
+	       html-post)))
+       (define insert-object-from-coclass
+	 (lambda args
+	   (apply insert-object-from-coclass-raw args)))
+       (define append-object-from-coclass
+	 (lambda args
+	   (apply append-object-from-coclass-raw args)))
+       (define insert-object-from-progid
+	 (lambda args
+	   (apply insert-object-from-progid-raw args)))
+       (define append-object-from-progid
+	 (lambda args
+	   (apply append-object-from-progid-raw args)))
+       (define focus
+	 (lambda ()
+	   (mxprims:element-focus elt)))
+       (define selection
+	 (lambda ()
+	   (mxprims:element-selection elt)))
+       (define set-selection!
+	 (lambda (val)
+	   (mxprims:element-set-selection! elt val)))
+       (define attribute
+	 (lambda (s)
+	   (mxprims:element-attribute elt s)))
+       (define set-attribute!
+	 (lambda (a v)
+	   (mxprims:element-set-attribute! elt a v)))
+       (define click
+	 (lambda ()
+	   (mxprims:element-click elt)))
+       (define tag
+	 (lambda ()
+	   (mxprims:element-tag elt)))
+       (define font-family
+	 (lambda ()
+	   (let ([s (mxprims:element-font-family elt)])
+	     (if (empty-string? s)
+		 (empty-property-error "font-family")
+		 (style:string->font-families s)))))
+       (define font-family-native
+	 (lambda ()
+	   (mxprims:element-font-family elt)))
+       (define set-font-family!
+	 (lambda (ff)
+	   (unless (and (pair? ff)
+			(andmap string? ff))
+		   (error "set-font-family!: Expected list of strings, got"
+			  ff))
+	   (mxprims:element-set-font-family!
+	    elt
+	    (style:font-families->string ff))))
+       (define set-font-family-native!
+	 (lambda (s)
+	   (mxprims:element-set-font-family! elt s)))
+       (define font-style
+	 (lambda ()
+	   (get-string-as-symbol
+	    mxprims:element-font-style "font-style")))
+	(define font-style-native
+	 (lambda ()
+	   (mxprims:element-font-style elt)))
+	(define set-font-style!
+	 (lambda (sym)
+	   (set-symbol-as-string sym *font-styles*
+				 mxprims:element-set-font-style!
+				 "set-font-style!")))
+	(define set-font-style-native!
+	 (lambda (s)
+	   (mxprims:element-set-font-style! elt s)))
+	(define font-variant
+	 (lambda ()
+	   (get-string-as-symbol mxprims:element-font-variant
+				 "font-variant")))
+	(define font-variant-native
+	 (lambda ()
+	   (mxprims:element-font-variant elt)))
+	(define set-font-variant!
+	 (lambda (sym)
+	   (set-symbol-as-string
+	    sym *font-variants* mxprims:element-set-font-variant!
+	    "set-font-variant!")))
+	(define set-font-variant-native!
+	 (lambda (s)
+	   (mxprims:element-set-font-variant! elt s)))
+	(define font-weight
+	 (lambda ()
+	   (let ([s (mxprims:element-font-weight elt)])
+	     (if (empty-string? s)
+		 (empty-property-error "font-weight")
+		 (let ((c (string-ref s 0)))
+		   (if (char-numeric? c)
+		       (string->number s)
+		       (string->symbol s)))))))
+	(define font-weight-native
+	 (lambda ()
+	   (mxprims:element-font-weight elt)))
+	(define set-font-weight!
+	 (lambda (w)
+	   (unless (member w
+			   '(bold bolder lighter normal
+				  100 200 300 400 500 600 700 800 900))
+		   (error
+		    (string-append
+		     "Expected value in "
+		     "'(bold bolder lighter normal "
+		     "100 200 300 400 500 600 700 800 900),"
+		     "got ~a")
+		    w))
+	   (let ((s (if (number? w)
+			(number->string w)
+			(symbol->string w))))
+	     (mxprims:element-set-font-weight! elt s))))
+
+
+	(define set-font-weight-native!
+	 (lambda (s)
+	   (mxprims:element-set-font-weight! elt s)))
+	(define font-native
+	 (lambda ()
+	   (mxprims:element-font elt)))
+	(define set-font-native!
+	 (lambda (s)
+	   (mxprims:element-set-font! elt s)))
+	(define background-native
+	 (lambda ()
+	   (mxprims:element-background elt)))
+	(define set-background-native!
+	 (lambda (s)
+	   (mxprims:element-set-background! elt s)))
+	(define background-attachment
+	 (lambda ()
+	   (get-string-as-symbol mxprims:element-background-attachment
+				 "background-attachment")))
+	(define background-attachment-native
+	 (lambda ()
+	   (mxprims:element-background-attachment elt)))
+	(define set-background-attachment!
+	 (lambda (sym)
+	   (set-symbol-as-string
+	    sym *background-attachments*
+	    mxprims:element-set-background-attachment!
+	    "set-background-attachment!")))
+	(define set-background-attachment-native!
+	 (lambda (s)
+	   (mxprims:element-set-background-attachment! elt s)))
+	(define background-image
+	 (lambda ()
+	   (let ([s (mxprims:element-background-image elt)])
+	     (cond
+	      [(empty-string? s)
+	       (empty-property-error "background-image")]
+	      [(string=? s "none") 'none]
+	      [(string-ci=? (substring s 0 3) "url")
+	       (list->string
+		(mzlib:filter (lambda (c)
+				(not (member c '(#\( #\)))))
+			      (string->list
+			       (substring s 3 (string-length s)))))]
+	      [else (error "Unknown background-image value: ~a"
+			   s)]))))
+	(define background-image-native
+	 (lambda ()
+	   (mxprims:element-background-image elt)))
+	(define set-background-image!
+	 (lambda (image)
+	   (cond
+	    [(eq? image 'none)
+	     (mxprims:element-set-background-image! elt "none")]
+	    [(string? image)
+	     (mxprims:element-set-background-image!
+	      elt
+	      (string-append "url(" image ")"))]
+	    [else
+	     (error "Expected 'none or string, got: ~a" image)])))
+	(define set-background-image-native!
+	 (lambda (s)
+	   (mxprims:element-set-background-image! elt s)))
+	(define background-repeat
+	 (lambda ()
+	   (get-string-as-symbol mxprims:element-background-repeat
+				 "background-repeat")))
+	(define background-repeat-native
+	 (lambda ()
+	   (mxprims:element-background-repeat elt)))
+	(define set-background-repeat!
+	 (lambda (sym)
+	   (set-symbol-as-string
+	    sym *background-repeats*
+	    mxprims:element-set-background-repeat!
+	    "set-background-repeat!")))
+	(define set-background-repeat-native!
+	 (lambda (s)
+	   (mxprims:element-set-background-repeat! elt s)))
+	(define background-position
+	 (lambda ()
+	   (let ([s (mxprims:element-background-position elt)])
+	     (if (empty-string? s)
+		 (empty-property-error "background-position")
+		 (style:string->background-position s)))))
+	(define background-position-native
+	 (lambda ()
+	   (mxprims:element-background-position elt)))
+	(define set-background-position!
+	 (lambda (pos)
+	   (cond
+	    [(and (pair? pos) (= (length pos) 2))
+	     (if (andmap symbol? pos)
+		 (let ([elt-1 (car pos)]
+		       [elt-2 (cadr pos)])
+		   (if (or (and (horizontal? elt-1)
+				(vertical? elt-2))
+			   (and (vertical? elt-1)
+				(horizontal? elt-2)))
+		       (mxprims:element-set-background-position!
+			elt
+			(string-append (symbol->string elt-1)
+				       " "
+				       (symbol->string elt-2)))
+		       (error
+			(format
+			 (string-append
+			  "One symbol must be from "
+			  "'~a, other from "
+			  "'~a, got: ~a")
+			 *horizontals* *verticals* pos))))
+		 (if (andmap style:percentage-or-length? pos)
+		     (mxprims:element-set-background-position!
+		      elt
+		      (string-append
+		       (style:percentage-or-length->string (car pos))
+		       " "
+		       (style:percentage-or-length->string (cadr pos))))
+		     (error
+		      (format
+		       (string-append
+			"Two elements of list "
+			" must be either a percentage or "
+			" CSS length, got: ~a") pos))))]
+	    [(style:percentage-or-length? pos)
+	     (mxprims:element-set-background-position!
+	      elt
+	      (style:percentage-or-length->string pos))]
+	    [else
+	     (error
+	      (format
+	       (string-append
+		"Expected any of "
+		"1) a list of two symbols, one "
+		"from '~a, the other from '~a, or "
+		"2) a two element list, where each element is a "
+		"percentage or CSS length, or "
+		"3) a percentage, or "
+		"4) a CSS length.  Got: ~a")
+	       *horizontals* *verticals* pos))])))
+	(define set-background-position-native!
+	 (lambda (s)
+	   (mxprims:element-set-background-position! elt s)))
+	(define text-decoration
+	 (lambda ()
+	   (style:validated-string->symbols
+	    (mxprims:element-text-decoration elt)
+	    "text-decoration" style:parse-decoration)))
+	(define text-decoration-native
+	 (lambda ()
+	   (mxprims:element-text-decoration elt)))
+	(define set-text-decoration!
+	 (lambda (decs)
+	   (unless
+	    (andmap decoration? decs)
+	    (error
+	     (format "Expected text decorations from ~a, got: ~a"
+		     *decorations* decs)))
+	   (mxprims:element-set-text-decoration! elt
+						 (symbols->string decs))))
+	(define set-text-decoration-native!
+	 (lambda (s)
+	   (mxprims:element-set-text-decoration! elt s)))
+	(define text-transform
+	 (lambda ()
+	   (get-string-as-symbol mxprims:element-text-transform
+				 "text-transform")))
+	(define text-transform-native
+	 (lambda ()
+	   (mxprims:element-text-transform elt)))
+	(define set-text-transform!
+	 (lambda (sym)
+	   (set-symbol-as-string
+	    sym *text-transforms* mxprims:element-set-text-transform!
+	    "set-text-transforms!")))
+	(define set-text-transform-native!
+	 (lambda (s)
+	   (mxprims:element-set-text-transform! elt s)))
+	(define text-align
+	 (lambda ()
+	   (get-string-as-symbol
+	    mxprims:element-text-align
+	    "text-align")))
+	(define text-align-native
+	 (lambda ()
+	   (mxprims:element-text-align elt)))
+	(define set-text-align!
+	 (lambda (sym)
+	   (set-symbol-as-string
+	    sym *text-aligns*
+	    mxprims:element-set-text-align!
+	    "set-text-align!")))
+	(define set-text-align-native!
+	 (lambda (s)
+	   (mxprims:element-set-text-align! elt s)))
+	(define margin
+	 (lambda ()
+	   (let ([s (mxprims:element-margin elt)])
+	     (if (empty-string? s)
+		 (empty-property-error "margin")
+		 (style:string->margin s)))))
+	(define margin-native
+	 (lambda ()
+	   (mxprims:element-margin elt)))
+	(define set-margin!
+	 (lambda (lst)
+	   (let ([len (length lst)])
+	     (when (or (< len 1) (> len 4))
+		   (error
+		    "Expected one to four margin values, got"
+		    lst)))
+	   (mxprims:element-set-margin! elt (style:margin->string lst))))
+	(define set-margin-native!
+	 (lambda (s)
+	   (mxprims:element-set-margin! elt s)))
+	(define padding
+	 (lambda ()
+	   (let ([s (mxprims:element-padding elt)])
+	     (if (empty-string? s)
+		 (empty-property-error "padding")
+		 (style:string->padding s)))))
+	(define padding-native
+	 (lambda ()
+	   (mxprims:element-padding elt)))
+	(define set-padding!
+	 (lambda (pads)
+	   (unless (and (pair? pads)
+			(let ([len (length pads)])
+			  (and (>= len 1) (<= len 4)))
+			(andmap style:percentage-or-length? pads))
+		   (error (string-append
+			   "set-padding: expected list of "
+			   "1 to 4 css-percentages or "
+			   "css-lengths, got") pads))
+	   (mxprims:element-set-padding!
+	    elt
+	    (style:padding->string pads))))
+	(define set-padding-native!
+	 (lambda (s)
+	   (mxprims:element-set-padding! elt s)))
+	(define border-raw
+	 (style:make-border-getter elt mxprims:element-border "border"))
+	(define border
+	  (lambda args
+	    (apply border-raw args)))
+	(define border-native
+	 (lambda (s)
+	   (mxprims:element-border elt s)))
+	(define set-border!
+	 (lambda (cs)
+	   (style:set-border-with-fun
+	    elt cs mxprims:element-set-border!)))
+	(define set-border-native!
+	 (lambda (s)
+	   (mxprims:element-set-border! elt s)))
+	(define border-top-raw
+	 (style:make-border-getter
+	  elt mxprims:element-border-top "border-top"))
+	(define border-top
+	 (lambda args
+	   (apply border-top-raw args)))
+	(define border-top-native
+	 (lambda ()
+	   (mxprims:element-border-top elt)))
+	(define set-border-top!
+	 (lambda (cs)
+	   (style:set-border-with-fun
+	    elt cs mxprims:element-set-border-top!)))
+	(define set-border-top-native!
+	 (lambda (s)
+	   (mxprims:element-set-border-top! elt s)))
+	(define border-bottom-raw
+	 (style:make-border-getter
+	  elt mxprims:element-border-bottom "border-bottom"))
+	(define border-bottom
+	  (lambda args
+	    (apply border-bottom-raw args)))
+	(define border-bottom-native
+	 (lambda ()
+	   (mxprims:element-border-bottom elt)))
+	(define set-border-bottom!
+	 (lambda (cs)
+	   (style:set-border-with-fun
+	    elt cs mxprims:element-set-border-bottom!)))
+	(define set-border-bottom-native!
+	 (lambda (s)
+	   (mxprims:element-set-border-bottom! elt s)))
+	(define border-left-raw
+	 (style:make-border-getter
+	  elt mxprims:element-border-left "border-left"))
+	(define border-left
+	  (lambda args
+	  (apply border-left-raw args)))
+	(define border-left-native
+	 (lambda ()
+	   (mxprims:element-border-left elt)))
+	(define set-border-left!
+	 (lambda (cs)
+	   (style:set-border-with-fun
+	    elt cs mxprims:element-set-border-left!)))
+	(define set-border-left-native!
+	 (lambda (s)
+	   (mxprims:element-set-border-left! elt s)))
+	(define border-right-raw
+	 (style:make-border-getter
+	  elt mxprims:element-border-right "border-right"))
+	(define border-right
+	  (lambda args
+	    (apply border-right-raw args)))
+	(define border-right-native
+	 (lambda ()
+	   (mxprims:element-border-right elt)))
+	(define set-border-right!
+	 (lambda (cs)
+	   (style:set-border-with-fun
+	    elt cs mxprims:element-set-border-right!)))
+	(define set-border-right-native!
+	 (lambda (s)
+	   (mxprims:element-set-border-right! elt s)))
+	(define border-color-raw
+	 (style:make-color-getter
+	  elt
+	  mxprims:element-border-color
+	  "border-color"))
+	(define border-color
+	  (lambda args
+	    (apply border-color-raw args)))
+	(define border-color-native
+	 (lambda ()
+	   (mxprims:element-border-color elt)))
+	(define set-border-color-raw!
+	 (style:make-color-setter
+	  elt mxprims:element-set-border-color!
+	  "set-border-color!"))
+	(define set-border-color!
+	  (lambda args
+	    (apply set-border-color-raw! args)))
+	(define set-border-color-native!
+	 (lambda (s)
+	   (mxprims:element-set-border-color! elt s)))
+	(define border-width-raw
+	 (style:make-border-width-getter
+	  elt mxprims:element-border-width "border-width"))
+	(define border-width
+	  (lambda args
+	    (apply border-width-raw args)))
+	(define border-width-native
+	 (lambda ()
+	   (mxprims:element-border-width elt)))
+	(define set-border-width!
+	 (lambda (s)
+	   (unless (style:border-width? s)
+		   (error
+		    (format "border-width: Expected element of ~a or CSS length, got: ~a"
+			    *border-widths* s)))
+	   (mxprims:element-set-border-width!
+	    elt
+	    (style:border-width->string s))))
+	(define set-border-width-native!
+	 (lambda (s)
+	   (mxprims:element-set-border-width! elt s)))
+	(define border-style-raw
+	 (style:make-border-style-getter
+	  elt mxprims:element-border-style
+	  "border-style"))
+	(define border-style
+	  (lambda args
+	    (apply border-style-raw args)))
+	(define border-style-native
+	 (lambda ()
+	   (mxprims:element-border-style elt)))
+	(define set-border-style-raw!
+	 (style:make-border-style-setter
+	  elt mxprims:element-set-border-style!
+	  "set-border-style!"))
+	(define set-border-style!
+	  (lambda args
+	    (apply set-border-style-raw! args)))
+	(define set-border-style-native!
+	 (lambda (s)
+	   (mxprims:element-set-border-style! elt s)))
+	(define border-top-style-raw
+	 (style:make-border-style-getter
+	  elt mxprims:element-border-top-style
+	  "border-top-style"))
+	(define border-top-style
+	  (lambda args
+	    (apply border-top-style-raw args)))
+	(define border-top-style-native
+	 (lambda ()
+	   (mxprims:element-border-top-style elt)))
+	(define set-border-top-style-raw!
+	 (style:make-border-style-setter
+	  elt mxprims:element-set-border-top-style!
+	  "set-border-top-style!"))
+	(define set-border-top-style!
+	  (lambda args
+	    (apply set-border-top-style-raw! args)))
+	(define set-border-top-style-native!
+	 (lambda (s)
+	   (mxprims:element-set-border-top-style! elt s)))
+	(define border-bottom-style-raw
+	 (style:make-border-style-getter
+	  elt mxprims:element-border-bottom-style
+	  "border-bottom-style"))
+	(define border-bottom-style
+	  (lambda args
+	    (apply border-bottom-style-raw args)))
+	(define border-bottom-style-native
+	 (lambda ()
+	   (mxprims:element-border-bottom-style elt)))
+	(define set-border-bottom-style-raw!
+	 (style:make-border-style-setter
+	  elt mxprims:element-set-border-bottom-style!
+	  "set-border-bottom-style!"))
+	(define set-border-bottom-style!
+	  (lambda args
+	    (apply set-border-bottom-style-raw! args)))
+	(define set-border-bottom-style-native!
+	 (lambda (s)
+	   (mxprims:element-set-border-bottom-style! elt s)))
+	(define border-left-style-raw
+	 (style:make-border-style-getter
+	  elt mxprims:element-border-left-style
+	  "border-left-style"))
+	(define border-left-style
+	  (lambda args
+	    (apply border-left-style-raw args)))
+	(define border-left-style-native
+	 (lambda ()
+	   (mxprims:element-border-left-style elt)))
+	(define set-border-left-style-raw!
+	 (style:make-border-style-setter
+	  elt mxprims:element-set-border-left-style!
+	  "set-border-left-style!"))
+	(define set-border-left-style!
+	  (lambda args
+	    (apply set-border-left-style-raw! args)))
+	(define set-border-left-style-native!
+	 (lambda (s)
+	   (mxprims:element-set-border-left-style! elt s)))
+	(define border-right-style-raw
+	 (style:make-border-style-getter
+	  elt mxprims:element-border-right-style
+	  "border-right-style"))
+	(define border-right-style
+	  (lambda args
+	    (apply border-right-style-raw args)))
+	(define border-right-style-native
+	 (lambda ()
+	   (mxprims:element-border-right-style elt)))
+	(define set-border-right-style-raw!
+	 (style:make-border-style-setter elt
+					 mxprims:element-set-border-right-style!
+					 "set-border-right-style!"))
+	(define set-border-right-style!
+	  (lambda args
+	    (apply set-border-right-style-raw! args)))
+	(define set-border-right-style-native!
+	 (lambda (s)
+	   (mxprims:element-set-border-right-style! elt s)))
+	(define border-top-color-raw
+	 (style:make-color-getter
+	  elt mxprims:element-border-top-color
+	  "border-top-color"))
+	(define border-top-color
+	  (lambda args
+	    (apply border-top-color-raw args)))
+	(define border-top-color-native!
+	 (lambda ()
+	   (mxprims:element-border-top-color elt)))
+	(define set-border-top-color-raw!
+	 (style:make-color-setter
+	  elt mxprims:element-set-border-top-color!
+	  "set-border-top-color!"))
+	(define set-border-top-color!
+	  (lambda args
+	    (apply set-border-top-color-raw! args)))
+	(define set-border-top-color-native!
+	 (lambda (s)
+	   (mxprims:element-set-border-top-color! elt s)))
+	(define border-bottom-color-raw
+	 (style:make-color-getter
+	  elt mxprims:element-border-bottom-color
+	  "border-bottom-color"))
+	(define border-bottom-color
+	  (lambda args
+	    (apply border-bottom-color-raw args)))
+	(define border-bottom-color-native
+	 (lambda ()
+	   (mxprims:element-border-bottom-color elt)))
+	(define set-border-bottom-color-raw!
+	 (style:make-color-setter
+	  elt mxprims:element-set-border-bottom-color!
+	  "set-border-bottom-color!"))
+	(define set-border-bottom-color!
+	  (lambda args
+	    (apply set-border-bottom-color-raw! args)))
+	(define set-border-bottom-color-native!
+	 (lambda (s)
+	   (mxprims:element-set-border-bottom-color! elt s)))
+	(define border-left-color-raw
+	 (style:make-color-getter
+	  elt mxprims:element-border-left-color
+	  "border-left-color"))
+	(define border-left-color
+	  (lambda args
+	    (apply border-left-color-raw args)))
+	(define border-left-color-native
+	 (lambda ()
+	   (mxprims:element-border-left-color elt)))
+	(define set-border-left-color-raw!
+	 (style:make-color-setter
+	  elt mxprims:element-set-border-left-color!
+	  "set-border-left-color!"))
+	(define set-border-left-color!
+	  (lambda args
+	    (apply set-border-left-color-raw! args)))
+	(define set-border-left-color-native!
+	 (lambda (s)
+	   (mxprims:element-set-border-left-color! elt s)))
+	(define border-right-color-raw
+	 (style:make-color-getter
+	  elt mxprims:element-border-right-color
+	  "border-right-color"))
+	(define border-right-color
+	  (lambda args
+	    (apply border-right-color-raw args)))
+	(define border-right-color-native
+	 (lambda ()
+	   (mxprims:element-border-right-color elt)))
+	(define set-border-right-color-raw!
+	 (style:make-color-setter
+	  elt mxprims:element-set-border-right-color!
+	  "set-border-right-color!"))
+	(define set-border-right-color!
+	  (lambda args
+	    (apply set-border-right-color-raw! args)))
+	(define set-border-right-color-native!
+	 (lambda (s)
+	   (mxprims:element-set-border-right-color! elt s)))
+	(define border-top-width-raw
+	 (style:make-border-width-getter
+	  elt mxprims:element-border-top-width "border-top-width"))
+	(define border-top-width
+	  (lambda args
+	    (apply border-top-width-raw args)))
+	(define border-top-width-native
+	 (lambda ()
+	   (mxprims:element-border-top-width elt)))
+	(define set-border-top-width-raw!
+	 (style:make-border-width-setter
+	  elt mxprims:element-set-border-top-width!
+	  "set-border-top-width!"))
+	(define set-border-top-width!
+	  (lambda args
+	    (apply set-border-top-width-raw! args)))
+	(define set-border-top-width-native!
+	 (lambda (s)
+	   (mxprims:element-set-border-top-width! elt s)))
+	(define border-bottom-width-raw
+	 (style:make-border-width-getter
+	  elt mxprims:element-border-bottom-width "border-bottom-width"))
+	(define border-bottom-width
+	  (lambda args
+	    (apply border-bottom-width-raw args)))
+	(define border-bottom-width-native
+	 (lambda ()
+	   (mxprims:element-border-bottom-width elt)))
+	(define set-border-bottom-width-raw!
+	 (style:make-border-width-setter
+	  elt mxprims:element-set-border-bottom-width!
+	  "set-border-bottom-width!"))
+	(define set-border-bottom-width!
+	  (lambda args
+	    (apply set-border-bottom-width-raw! args)))
+	(define set-border-bottom-width-native!
+	 (lambda (s)
+	   (mxprims:element-set-border-bottom-width! elt s)))
+	(define border-left-width-raw
+	 (style:make-border-width-getter
+	  elt mxprims:element-border-left-width "border-left-width"))
+	(define border-left-width
+	  (lambda args
+	    (apply border-left-width-raw args)))
+	(define border-left-width-native
+	 (lambda ()
+	   (mxprims:element-border-left-width elt)))
+	(define set-border-left-width-raw!
+	 (style:make-border-width-setter
+	  elt mxprims:element-set-border-left-width!
+	  "set-border-left-width!"))
+	(define set-border-left-width!
+	  (lambda args
+	    (apply set-border-left-width-raw! args)))
+	(define set-border-left-width-native!
+	 (lambda (s)
+	   (mxprims:element-set-border-left-width! elt s)))
+	(define border-right-width-raw
+	 (style:make-border-width-getter
+	  elt mxprims:element-border-right-width "border-right-width"))
+	(define border-right-width
+	  (lambda args
+	    (apply border-right-width-raw args)))
+	(define border-right-width-native
+	 (lambda ()
+	   (mxprims:element-border-right-width elt)))
+	(define set-border-right-width-raw!
+	 (style:make-border-width-setter
+	  elt mxprims:element-set-border-right-width!
+	  "set-border-right-width!"))
+	(define set-border-right-width!
+	  (lambda args
+	    (apply set-border-right-width-raw! args)))
+	(define set-border-right-width-native!
+	 (lambda (s)
+	   (mxprims:element-set-border-right-width! elt s)))
+	(define style-float-raw
+	 (style:make-element-getter
+	  elt
+	  mxprims:element-style-float "style-float" ))
+	(define style-float
+	  (lambda args
+	    (apply style-float-raw args)))
+	(define style-float-native
+	 (lambda ()
+	   (mxprims:element-style-float elt)))
+	(define set-style-float-raw!
+	 (style:make-element-setter elt
+				    style-float?
+				    *style-floats*
+				    mxprims:element-set-style-float!))
+	(define set-style-float!
+	  (lambda args
+	    (apply set-style-float-raw! args)))
+	(define set-style-float-native!
+	 (lambda (s)
+	   (mxprims:element-set-style-float! elt s)))
+	(define clear-raw
+	 (style:make-element-getter
+	  elt mxprims:element-clear "clear"))
+	(define clear
+	  (lambda args
+	    (apply clear-raw args)))
+	(define clear-native
+	 (lambda ()
+	   (mxprims:element-clear elt)))
+	(define set-clear-raw!
+	 (style:make-element-setter elt
+				    clear?
+				    *clears*
+				    mxprims:element-set-clear!))
+	(define set-clear!
+	  (lambda args
+	    (apply set-clear-raw! args)))
+	(define set-clear-native!
+	 (lambda (s)
+	   (mxprims:element-set-clear! elt s)))
+	(define display-raw
+	 (style:make-element-getter
+	  elt mxprims:element-display "display"))
+	(define display
+	  (lambda args
+	    (apply display-raw args)))
+	(define display-native
+	 (lambda ()
+	   (mxprims:element-display elt)))
+	(define set-display-raw!
+	 (style:make-element-setter elt
+				    display?
+				    *displays*
+				    mxprims:element-set-display!))
+	(define set-display!
+	  (lambda args
+	    (apply set-display-raw! args)))
+	(define set-display-native!
+	 (lambda (s)
+	   (mxprims:element-set-display! elt s)))
+	(define visibility-raw
+	 (style:make-element-getter
+	  elt mxprims:element-visibility
+	  "visibility"))
+	(define visibility
+	  (lambda args
+	    (apply visibility-raw args)))
+	(define visibility-native
+	 (lambda ()
+	   (mxprims:element-visibility elt)))
+	(define set-visibility-raw!
+	 (style:make-element-setter elt
+				    visibility?
+				    *visibilities*
+				    mxprims:element-set-visibility!))
+	(define set-visibility!
+	  (lambda args
+	    (apply set-visibility-raw! args)))
+	(define set-visibility-native!
+	 (lambda (s)
+	   (mxprims:element-set-visibility! elt s)))
+	(define list-style-type-raw
+	 (style:make-element-getter
+	  elt mxprims:element-list-style-type
+	  "list-style-type"))
+	(define list-style-type
+	  (lambda args
+	    (apply list-style-type-raw args)))
+	(define list-style-type-native
+	 (lambda ()
+	   (mxprims:element-list-style-type elt)))
+	(define set-list-style-type-native!
+	 (lambda (s)
+	   (mxprims:element-set-list-style-type! elt s)))
+	(define list-style-position-raw
+	 (style:make-element-getter
+	  elt mxprims:element-list-style-position
+	  "list-style-position"))
+	(define list-style-position
+	  (lambda args
+	    (apply list-style-position-raw args)))
+	(define list-style-position-native
+	 (lambda ()
+	   (mxprims:element-list-style-position elt)))
+	(define set-list-style-position-native!
+	 (lambda (s)
+	   (mxprims:element-set-list-style-position! elt s)))
+	(define list-style-image
+	 (lambda ()
+	   (let ([s (mxprims:element-list-style-image  elt)])
+	     (when (empty-string? s)
+		   (empty-property-error "list-style-image"))
+	     (cond
+	      [(string-ci=? s "none") 'none]
+	      [(string-ci=? (substring s 0 4) "url(")
+	       (style:url->string s)]
+	      [else
+	       (error
+		(format
+		 "list-style-image: Expected 'none or URL, got: ~a" s))]))))
+	(define list-style-image-native
+	 (lambda ()
+	   (mxprims:element-list-style-image elt)))
+	(define set-list-style-image!
+	 (lambda (s)
+	   (let ([str (if (eq? s 'none)
+			  "none"
+			  (style:string->url s))])
+	     (mxprims:element-set-list-style-image! elt str))))
+	(define set-list-style-image-native!
+	 (lambda (s)
+	   (mxprims:element-set-list-style-image! elt s)))
+	(define list-style
+	 (lambda ()
+	   (let* ([s (mxprims:element-list-style elt)]
+		  [elts (style:parse-string s)])
+	     (map style:string->list-style-item elts))))
+	(define list-style-native
+	 (lambda ()
+	   (mxprims:element-list-style elt)))
+	(define set-list-style!
+	 (lambda (items)
+	   (mxprims:element-set-list-style!
+	    elt
+	    (fold-strings-with-spaces
+	     (map style:list-style-item->string items)))))
+	(define set-list-style-native!
+	 (lambda (s)
+	   (mxprims:element-set-list-style! elt s)))
+	(define position-raw
+	 (style:make-element-getter
+	  elt mxprims:element-position
+	  "position"))
+	(define position
+	  (lambda args
+	    (apply position-raw args)))
+	(define position-native
+	 (lambda ()
+	   (mxprims:element-position elt)))
+	(define overflow-raw
+	 (style:make-element-getter
+	  elt mxprims:element-overflow "overflow"))
+	(define overflow
+	  (lambda args
+	    (apply overflow-raw args)))
+	(define overflow-native
+	 (lambda ()
+	   (mxprims:element-overflow elt)))
+	(define set-overflow-raw!
+	 (style:make-element-setter elt
+				    overflow?
+				    *overflows*
+				    mxprims:element-set-overflow!))
+	(define set-overflow!
+	  (lambda args
+	    (apply set-overflow-raw! args)))
+	(define set-overflow-native!
+	 (lambda (s)
+	   (mxprims:element-set-overflow! elt s)))
+	(define pagebreak-before-raw
+	 (style:make-pagebreak-getter
+	  elt
+	  mxprims:element-pagebreak-before))
+	(define pagebreak-before
+	  (lambda args
+	    (apply pagebreak-before-raw args)))
+	(define pagebreak-before-native
+	 (lambda ()
+	   (mxprims:element-pagebreak-before elt)))
+	(define set-pagebreak-before-raw!
+	 (style:make-pagebreak-setter elt
+				      mxprims:element-set-pagebreak-before!
+				      "set-pagebreak-before!"))
+	(define set-pagebreak-before!
+	  (lambda args
+	    (apply set-pagebreak-before-raw! args)))
+	(define set-pagebreak-before-native!
+	 (lambda (s)
+	   (mxprims:element-set-pagebreak-before! elt s)))
+	(define pagebreak-after-raw
+	 (style:make-pagebreak-getter
+	  elt mxprims:element-pagebreak-after))
+	(define pagebreak-after
+	  (lambda args
+	    (apply pagebreak-after-raw args)))
+	(define pagebreak-after-native
+	 (lambda ()
+	   (mxprims:element-pagebreak-after elt)))
+	(define set-pagebreak-after-raw!
+	 (style:make-pagebreak-setter elt
+				      mxprims:element-set-pagebreak-after!
+				      "set-pagebreak-after!"))
+	(define set-pagebreak-after!
+	  (lambda args
+	    (apply set-pagebreak-after-raw! args)))
+	(define css-text-native
+	 (lambda ()
+	   (mxprims:element-css-text elt)))
+	(define set-css-text-native!
+	 (lambda (s)
+	   (mxprims:element-set-css-text! elt s)))
+	(define cursor-raw
+	 (style:make-element-getter
+	  elt mxprims:element-cursor "cursor"))
+	(define cursor
+	  (lambda args
+	    (apply cursor-raw args)))
+	(define cursor-native
+	 (lambda ()
+	   (mxprims:element-cursor elt)))
+	(define set-cursor-raw!
+	 (style:make-element-setter elt
+				    cursor?
+				    *cursors*
+				    mxprims:element-set-cursor!))
+	(define set-cursor!
+	  (lambda args
+	    (apply set-cursor-raw! args)))
+	(define set-cursor-native!
+	 (lambda (s)
+	   (mxprims:element-set-cursor! elt s)))
+	(define clip
+	 (lambda ()
+	   (let ([s (mxprims:element-clip elt)])
+	     (cond
+	      [(empty-string? s)
+	       (empty-property-error "clip")]
+	      [(string-ci=? s "auto")
+	       'auto]
+	      [(style:clip-rect? s)
+	       (style:clip-rect->symbols s)]
+	      [else
+	       (error
+		(format "clip: Expected clip string, got: ~a" s))]))))
+	(define clip-native
+	 (lambda ()
+	   (mxprims:element-clip elt)))
+	(define set-clip!
+	 (lambda (s)
+	   (let ([str (cond
+		       [(eq? s 'auto) "auto"]
+		       [(and (pair? s)
+			     (= (length s) 4)
+			     (andmap
+			      (lambda (elt)
+				(or (eq? elt 'auto)
+				    (css-length? elt)))
+			      s))
+			(string-append
+			 "rect("
+			 (fold-strings-with-spaces
+			  (map
+			   (lambda (elt)
+			     (if (eq? elt 'auto)
+				 "auto"
+				 (style:css-length->string elt)))
+			   s))
+			 ")")]
+		       [else
+			(error
+			 (format
+			  (string-append
+			   "Expected 'auto or 4-element list of "
+			   "CSS lengths, with elements "
+			   "possibly replaced by 'auto. Got ~a")
+			  s))])])
+	     (mxprims:element-set-clip! elt str))))
+	(define set-clip-native!
+	 (lambda (s)
+	   (mxprims:element-set-clip! elt s)))
+	(define filter
+	 (lambda ()
+	   (let ([s (mxprims:element-filter elt)])
+	     (if (empty-string? s)
+		 (empty-property-error "filter")
+		 (string->filter s)))))
+	(define filter-native
+	 (lambda ()
+	   (mxprims:element-filter elt)))
+	(define set-filter!
+	 (lambda (flt . options)
+	   (let ([s (filter->string flt options)])
+	     (mxprims:element-set-filter! elt s))))
+	(define set-filter-native!
+	 (lambda (s)
+	   (mxprims:element-set-filter! elt s)))
+	(define style-string
+	 (lambda ()
+	   (mxprims:element-style-string elt)))
+		; the text decoration, blink attributes are boolean
+		; hence no conversion to/from strings
+	(define text-decoration-none
+	 (lambda ()
+	   (mxprims:element-text-decoration-none elt)))
+	(define set-text-decoration-none!
+	 (lambda (s)
+	   (mxprims:element-set-text-decoration-none! elt s)))
+	(define text-decoration-underline
+	 (lambda ()
+	   (mxprims:element-text-decoration-underline elt)))
+	(define set-text-decoration-underline!
+	 (lambda (s)
+	   (mxprims:element-set-text-decoration-underline! elt s)))
+	(define text-decoration-overline
+	 (lambda ()
+	   (mxprims:element-text-decoration-overline elt)))
+	(define set-text-decoration-overline!
+	 (lambda (s)
+	   (mxprims:element-set-text-decoration-overline! elt s)))
+	(define text-decoration-linethrough
+	 (lambda ()
+	   (mxprims:element-text-decoration-linethrough elt)))
+	(define set-text-decoration-linethrough!
+	 (lambda (s)
+	   (mxprims:element-set-text-decoration-linethrough! elt s)))
+	(define text-decoration-blink
+	 (lambda ()
+	   (mxprims:element-text-decoration-blink elt)))
+	(define set-text-decoration-blink!
+	 (lambda (s)
+	   (mxprims:element-set-text-decoration-blink! elt s)))
+					; pixel attributes are all longs
+					; hence, no conversion to/from strings
+	(define pixel-top
+	 (lambda ()
+	   (mxprims:element-pixel-top elt)))
+	(define set-pixel-top!
+	 (lambda (s)
+	   (mxprims:element-set-pixel-top! elt s)))
+	(define pixel-left
+	 (lambda ()
+	   (mxprims:element-pixel-left elt)))
+	(define set-pixel-left!
+	 (lambda (s)
+	   (mxprims:element-set-pixel-left! elt s)))
+	(define pixel-width
+	 (lambda ()
+	   (mxprims:element-pixel-width elt)))
+	(define set-pixel-width!
+	 (lambda (s)
+	   (mxprims:element-set-pixel-width! elt s)))
+	(define pixel-height
+	 (lambda ()
+	   (mxprims:element-pixel-height elt)))
+	(define set-pixel-height!
+	 (lambda (s)
+	   (mxprims:element-set-pixel-height! elt s)))
+  	; position attributes are all floats
+	; hence no conversion to/from strings
+	(define pos-top
+	 (lambda ()
+	   (mxprims:element-pos-top elt)))
+	(define set-pos-top!
+	 (lambda (s)
+	   (mxprims:element-set-pos-top! elt s)))
+	(define pos-left
+	 (lambda ()
+	   (mxprims:element-pos-left elt)))
+	(define set-pos-left!
+	 (lambda (s)
+	   (mxprims:element-set-pos-left! elt s)))
+	(define pos-width
+	 (lambda ()
+	   (mxprims:element-pos-width elt)))
+	(define set-pos-width!
+	 (lambda (s)
+	   (mxprims:element-set-pos-width! elt s)))
+	(define pos-height
+	 (lambda ()
+	   (mxprims:element-pos-height elt)))
+	(define set-pos-height!
+	 (lambda (s)
+	   (mxprims:element-set-pos-height! elt s)))
+	(define font-size
+	 (lambda ()
+	   (let ([s (mxprims:element-font-size elt)])
+	     (if (empty-string? s)
+		 (empty-property-error "font-size")
+		 (style:string->font-size s)))))
+	(define font-size-native
+	 (lambda ()
+	   (mxprims:element-font-size elt)))
+	(define set-font-size!
+	 (lambda (sz)
+	   (let ([s (cond
+		     [(font-size? sz)
+		      (symbol->string sz)]
+		     [(style:percentage-or-length? sz)
+		      (style:percentage-or-length->string sz)]
+		     [else
+		      (error
+		       (format (string-append
+				"set-font-size!: Expected element of ~a, "
+				"a CSS length, or CSS percentage. Got: ~a")
+			       *font-sizes* sz))])])
+	     (mxprims:element-set-font-size! elt s))))
+	(define set-font-size-native!
+	 (lambda (s)
+	   (mxprims:element-set-font-size! elt s)))
+	(define color-raw
+	 (style:make-color-getter elt mxprims:element-color "color"))
+	(define color
+	  (lambda args
+	    (apply color-raw args)))
+	(define color-native-raw
+	  (lambda ()
+	    (mxprims:element-color elt)))
+	(define color-native
+	  (lambda args
+	    (apply color-native-raw args)))
+	(define set-color-raw!
+	 (style:make-color-setter
+	  elt mxprims:element-set-color! "set-color!"))
+	(define set-color!
+	  (lambda args
+	    (apply set-color-raw! args)))
+	(define set-color-native!
+	 (lambda (s)
+	   (mxprims:element-set-color! elt s)))
+	(define background-color-raw
+	 (style:make-color-getter
+	  elt mxprims:element-background-color
+	  "background-color"))
+	(define background-color
+	  (lambda args
+	    (apply background-color-raw args)))
+	(define background-color-native
+	 (lambda ()
+	   (mxprims:element-background-color elt)))
+	(define set-background-color-raw!
+	 (style:make-color-setter
+	  elt mxprims:element-set-background-color!
+	  "set-background-color!"))
+	(define set-background-color!
+	  (lambda args
+	    (apply set-background-color-raw! args)))
+	(define set-background-color-native!
+	 (lambda (s)
+	   (mxprims:element-set-background-color! elt s)))
+	(define background-position-x-raw
+	 (style:make-bg-pos-getter
+	  elt
+	  mxprims:element-background-position-x
+	  "background-position-x"))
+	(define background-position-x
+	  (lambda args
+	    (apply background-position-x-raw args)))
+	(define background-position-x-native
+	 (lambda ()
+	   (mxprims:element-background-position-x elt)))
+	(define set-background-position-x-raw!
+	 (style:make-bg-pos-setter
+	  elt
+	  mxprims:element-set-background-position-x!
+	  horizontal? *horizontals*
+	  "x"))
+	(define set-background-position-x!
+	  (lambda args
+	    (apply set-background-position-x-raw! args)))
+	(define set-background-position-x-native!
+	 (lambda (n)
+	   (mxprims:element-set-background-position-x! elt n)))
+	(define background-position-y-raw
+	 (style:make-bg-pos-getter
+	  elt
+	  mxprims:element-background-position-y
+	  "background-position-y"))
+	(define background-position-y
+	  (lambda args
+	    (apply background-position-y-raw args)))
+	(define background-position-y-native
+	 (lambda ()
+	   (mxprims:element-background-position-y elt)))
+	(define set-background-position-y-raw!
+	 (style:make-bg-pos-setter
+	  elt
+	  mxprims:element-set-background-position-y!
+	  vertical? *verticals*
+	  "y"))
+	(define set-background-position-y!
+	  (lambda args
+	    (apply set-background-position-y-raw! args)))
+	(define set-background-position-y-native!
+	 (lambda (s)
+	   (mxprims:element-set-background-position-y! elt s)))
+	(define letter-spacing-raw
+	 (style:make-normal-or-css-getter elt
+					  mxprims:element-letter-spacing
+					  "letter-spacing"))
+	(define letter-spacing
+	  (lambda args
+	    (apply letter-spacing-raw args)))
+	(define letter-spacing-native
+	 (lambda ()
+	   (mxprims:element-letter-spacing elt)))
+	(define set-letter-spacing-raw!
+	 (style:make-normal-or-css-setter elt
+					  mxprims:element-set-letter-spacing!
+					  "set-letter-spacing!"))
+	(define set-letter-spacing!
+	  (lambda args
+	    (apply set-letter-spacing-raw! args)))
+	(define set-letter-spacing-native!
+	 (lambda (s)
+	   (mxprims:element-set-letter-spacing! elt s)))
+	(define vertical-align
+	 (lambda ()
+	   (let ([s (mxprims:element-vertical-align elt)])
+	     (when (empty-string? s)
+		   (empty-property-error "vertical-align"))
+	     (string->symbol s))))
+	(define vertical-align-native
+	 (lambda ()
+	   (mxprims:element-vertical-align elt)))
+	(define set-vertical-align!
+	 (lambda (sym)
+	   (unless (vertical-align? sym)
+		   (error
+		    (format
+		     (string-append "set-vertical-align!: "
+				    "Expected element of ~a, got ~a")
+		     *vertical-aligns* sym)))
+	   (mxprims:element-set-vertical-align!
+	    elt
+	    (symbol->string sym))))
+	(define set-vertical-align-native!
+	 (lambda (s)
+	   (mxprims:element-set-vertical-align! elt s)))
+	(define text-indent-raw
+	 (style:make-css-getter elt
+				mxprims:element-text-indent "text-indent"))
+	(define text-indent
+	  (lambda args
+	    (apply text-indent-raw args)))
+	(define text-indent-native
+	 (lambda ()
+	   (mxprims:element-text-indent elt)))
+	(define set-text-indent-raw!
+	 (style:make-css-setter elt
+				mxprims:element-set-text-indent!
+                               "set-text-indent!"))
+	(define set-text-indent!
+	  (lambda args
+	    (apply set-text-indent-raw! args)))
+	(define set-text-indent-native!
+	 (lambda (s)
+	   (mxprims:element-set-text-indent! elt s)))
+	(define line-height-raw
+	 (style:make-normal-or-css-getter elt
+					  mxprims:element-line-height
+					  "line-height"))
+	(define line-height
+	  (lambda args
+	    (apply line-height-raw args)))
+	(define line-height-native
+	 (lambda ()
+	   (mxprims:element-line-height elt)))
+	(define set-line-height-raw!
+	 (style:make-normal-or-css-setter elt
+					  mxprims:element-set-line-height!
+					  "set-line-height!"))
+	(define set-line-height!
+	  (lambda args
+	    (apply set-line-height-raw! args)))
+	(define set-line-height-native!
+	 (lambda (s)
+	   (mxprims:element-set-line-height! elt s)))
+	(define margin-top-raw
+	 (style:make-auto-or-css-getter elt
+					mxprims:element-margin-top
+					"margin-top"))
+	(define margin-top
+	  (lambda args
+	    (apply margin-top-raw args)))
+	(define margin-top-native
+	 (lambda ()
+	   (mxprims:element-margin-top elt)))
+	(define set-margin-top-raw!
+	 (style:make-auto-or-css-setter elt
+					mxprims:element-set-margin-top!
+					"set-margin-top!"))
+	(define set-margin-top!
+	  (lambda args
+	    (apply set-margin-top-raw! args)))
+	(define set-margin-top-native!
+	 (lambda (s)
+	   (mxprims:element-set-margin-top! elt s)))
+	(define margin-bottom-raw
+	 (style:make-auto-or-css-getter elt
+					mxprims:element-margin-bottom
+					"margin-bottom"))
+	(define margin-bottom
+	  (lambda args
+	    (apply margin-bottom-raw args)))
+	(define margin-bottom-native
+	 (lambda ()
+	   (mxprims:element-margin-bottom elt)))
+	(define set-margin-bottom-raw!
+	 (style:make-auto-or-css-setter elt
+					mxprims:element-set-margin-bottom!
+					"set-margin-bottom!"))
+	(define set-margin-bottom!
+	  (lambda args
+	    (apply set-margin-bottom-raw! args)))
+	(define set-margin-bottom-native!
+	 (lambda (s)
+	   (mxprims:element-set-margin-bottom! elt s)))
+	(define margin-left-raw
+	 (style:make-auto-or-css-getter elt
+					mxprims:element-margin-left
+					"margin-left"))
+	(define margin-left
+	  (lambda args
+	    (apply margin-left-raw args)))
+	(define margin-left-native
+	 (lambda ()
+	   (mxprims:element-margin-left elt)))
+	(define set-margin-left-raw!
+	 (style:make-auto-or-css-setter elt
+					mxprims:element-set-margin-left!
+					"set-margin-left!"))
+	(define set-margin-left!
+	  (lambda args
+	    (apply set-margin-left-raw! args)))
+	(define set-margin-left-native!
+	 (lambda (s)
+	   (mxprims:element-set-margin-left! elt s)))
+	(define margin-right-raw
+	 (style:make-auto-or-css-getter elt
+					mxprims:element-margin-right
+					"margin-right"))
+	(define margin-right
+	  (lambda args
+	    (apply margin-right-raw args)))
+	(define margin-right-native
+	 (lambda ()
+	   (mxprims:element-margin-right elt)))
+	(define set-margin-right-raw!
+	 (style:make-auto-or-css-setter elt
+					mxprims:element-set-margin-right!
+					"set-margin-right!"))
+	(define set-margin-right!
+	  (lambda args
+	    (apply set-margin-right-raw! args)))
+	(define set-margin-right-native!
+	 (lambda (s)
+	   (mxprims:element-set-margin-right! elt s)))
+	(define padding-top-raw
+	 (style:make-css-getter elt
+				mxprims:element-padding-top "padding-top"))
+	(define padding-top
+	  (lambda args
+	    (apply padding-top-raw args)))
+	(define padding-top-native
+	 (lambda ()
+	   (mxprims:element-padding-top elt)))
+	(define set-padding-top-raw!
+	 (style:make-css-setter elt
+				mxprims:element-set-padding-top! "set-padding-top!"))
+	(define set-padding-top!
+	  (lambda args
+	    (apply set-padding-top-raw! args)))
+	(define set-padding-top-native!
+	 (lambda (s)
+	   (mxprims:element-set-padding-top! elt s)))
+	(define padding-bottom-raw
+	 (style:make-css-getter elt
+				mxprims:element-padding-bottom "padding-bottom"))
+	(define padding-bottom
+	  (lambda args
+	    (apply padding-bottom-raw args)))
+	(define padding-bottom-native
+	 (lambda ()
+	   (mxprims:element-padding-bottom elt)))
+	(define set-padding-bottom-raw!
+	 (style:make-css-setter elt
+				mxprims:element-set-padding-bottom! "set-padding-bottom!"))
+	(define set-padding-bottom!
+	  (lambda args
+	    (apply set-padding-bottom-raw! args)))
+	(define set-padding-bottom-native!
+	 (lambda (s)
+	   (mxprims:element-set-padding-bottom! elt s)))
+	(define padding-left-raw
+	 (style:make-css-getter elt
+				mxprims:element-padding-left "padding-left"))
+	(define padding-left
+	  (lambda args
+	    (apply padding-left-raw args)))
+	(define padding-left-native
+	 (lambda ()
+	   (mxprims:element-padding-left elt)))
+	(define set-padding-left-raw!
+	 (style:make-css-setter elt
+				mxprims:element-set-padding-left! "set-padding-left!"))
+	(define set-padding-left!
+	  (lambda args
+	    (apply set-padding-left-raw! args)))
+	(define set-padding-left-native!
+	 (lambda (s)
+	   (mxprims:element-set-padding-left! elt s)))
+	(define padding-right-raw
+	 (style:make-css-getter elt
+				mxprims:element-padding-right "padding-right"))
+	(define padding-right
+	  (lambda args
+	    (apply padding-right-raw args)))
+	(define padding-right-native
+	 (lambda ()
+	   (mxprims:element-padding-right elt)))
+	(define set-padding-right-raw!
+	 (style:make-css-setter elt
+				mxprims:element-set-padding-right! "set-padding-right!"))
+	(define set-padding-right!
+	  (lambda args
+	    (apply set-padding-right-raw! args)))
+	(define set-padding-right-native!
+	 (lambda (s)
+	   (mxprims:element-set-padding-right! elt s)))
+	(define width-raw
+	 (style:make-auto-or-css-getter
+	  elt mxprims:element-width "width"))
+	(define width
+	  (lambda args
+	    (apply width-raw args)))
+	(define width-native
+	 (lambda ()
+	   (mxprims:element-width elt)))
+	(define set-width-raw!
+	 (style:make-auto-or-css-setter
+	  elt mxprims:element-set-width!
+	  "set-width!"))
+	(define set-width!
+	  (lambda args
+	    (apply set-width-raw! args)))
+	(define set-width-native!
+	 (lambda (s)
+	   (mxprims:element-set-width! elt s)))
+	(define height-raw
+	 (style:make-auto-or-css-getter
+	  elt mxprims:element-height "height"))
+	(define height
+	  (lambda args
+	    (apply height-raw args)))
+	(define height-native
+	 (lambda ()
+	   (mxprims:element-height elt)))
+	(define set-height-raw!
+	 (style:make-auto-or-css-setter
+	  elt mxprims:element-set-height!
+	  "set-height!"))
+	(define set-height!
+	  (lambda args
+	    (apply set-height-raw! args)))
+	(define set-height-native!
+	 (lambda (s)
+	   (mxprims:element-set-height! elt s)))
+	(define top-raw
+	 (style:make-auto-or-css-getter
+	  elt mxprims:element-top "top"))
+	(define top
+	  (lambda args
+	    (apply top-raw args)))
+	(define top-native
+	 (lambda ()
+	   (mxprims:element-top elt)))
+	(define set-top-raw!
+	 (style:make-auto-or-css-setter
+	  elt mxprims:element-set-top!
+	  "set-top!"))
+	(define set-top!
+	  (lambda args
+	    (apply set-top-raw! args)))
+	(define set-top-native!
+	 (lambda (s)
+	   (mxprims:element-set-top! elt s)))
+	(define left-raw
+	 (style:make-auto-or-css-getter
+	  elt mxprims:element-left "left"))
+	(define left
+	  (lambda args
+	    (apply left-raw args)))
+	(define left-native
+	 (lambda ()
+	   (mxprims:element-left elt)))
+	(define set-left-raw!
+	 (style:make-auto-or-css-setter
+	  elt
+	  mxprims:element-set-left!
+	  "set-left!"))
+	(define set-left!
+	  (lambda args
+	    (apply set-left-raw! args)))
+	(define set-left-native!
+	 (lambda (s)
+	   (mxprims:element-set-left! elt s)))
+	(define z-index
+	 (lambda ()
+	   (let ([s (mxprims:element-z-index elt)])
+	     (when (empty-string? s)
+		   (empty-property-error "z-index"))
+	     (if (and (string? s) (string=? s "auto"))
+		 'auto
+		 s))))
+	(define z-index-native
+	 (lambda ()
+	   (mxprims:element-z-index elt)))
+	(define set-z-index!
+	 (lambda (zi)
+	   (let ([s (cond
+		     [(eq? zi 'auto) "auto"]
+		     [(and (number? zi)
+			   (exact? zi)) zi]
+		     [else
+		      (error
+		       (string-append "set-z-index!: "
+				      "Expected 'auto or exact integer, "
+				      "got")
+		       zi)])])
+	     (mxprims:element-set-z-index! elt s))))
+	(define set-z-index-native!
+	 (lambda (s)
+	   (mxprims:element-set-z-index! elt s)))
+	(define set-list-style-position-raw!
+	  (style:make-element-setter elt
+				     list-style-position?
+				     *list-style-positions*
+				     mxprims:element-set-list-style-position!))
+	(define set-list-style-position!
+	  (lambda args
+	    (apply set-list-style-position-raw! args)))
+	(define set-list-style-type-raw!
+	  (style:make-element-setter elt
+				     list-style-type?
+				     *list-style-types*
+				     mxprims:element-set-list-style-type!))
+	(define set-list-style-type!
+	  (lambda args
+	    (apply set-list-style-type-raw! args)))
+	(super-make-object)))
+
+  (define mx-event%
+    (class object% (init dhtml-event)
+
+	; private fields
+
+	(define event dhtml-event)
+
+	(public
+	 keypress?
+	 keydown?
+	 keyup?
+	 mousedown?
+	 mousemove?
+	 mouseover?
+	 mouseout?
+	 mouseup?
+	 click?
+	 dblclick?
+	 error?
+	 tag
+	 id
+	 from-tag
+	 from-id
+	 to-tag
+	 to-id
+	 keycode
+	 shift-key
+	 ctrl-key
+	 alt-key
+	 x
+	 y)
+
+	; predicates
+
+	(define keypress? (lambda () (mxprims:event-keypress? event)))
+	(define keydown? (lambda () (mxprims:event-keydown? event)))
+	(define keyup? (lambda () (mxprims:event-keyup? event)))
+	(define mousedown? (lambda () (mxprims:event-mousedown? event)))
+	(define mousemove? (lambda () (mxprims:event-mousemove? event)))
+	(define mouseover? (lambda () (mxprims:event-mouseover? event)))
+	(define mouseout? (lambda () (mxprims:event-mouseout? event)))
+	(define mouseup? (lambda () (mxprims:event-mouseup? event)))
+	(define click? (lambda () (mxprims:event-click? event)))
+	(define dblclick? (lambda () (mxprims:event-dblclick? event)))
+	(define error? (lambda () (mxprims:event-error? event)))
+
+	; attributes
+
+	(define tag (lambda () (mxprims:event-tag event)))
+	(define id (lambda () (mxprims:event-id event)))
+	(define from-tag (lambda () (mxprims:event-from-tag event)))
+	(define from-id (lambda () (mxprims:event-id event)))
+	(define to-tag (lambda () (mxprims:event-to-tag event)))
+	(define to-id (lambda () (mxprims:event-to-id event)))
+	(define keycode (lambda () (mxprims:event-keycode event)))
+	(define shift-key (lambda () (mxprims:event-shiftkey event)))
+	(define ctrl-key (lambda () (mxprims:event-ctrlkey event)))
+	(define alt-key (lambda () (mxprims:event-altkey event)))
+	(define x (lambda () (mxprims:event-x event)))
+	(define y (lambda () (mxprims:event-y event)))
+	(super-make-object)))
+
+  (define mx-browser%
+    (class object% (init (label "MysterX")
+			 (width 'default)
+			 (height 'default)
+			 (x 'default)
+			 (y 'default)
+			 (style-options null))
+
+	   ; private fields
+	   (define browser (mxprims:make-browser label width height x y style-options))
+	    (define thread-sem (make-semaphore 1))
+	    (define thread-wait (lambda () (semaphore-wait thread-sem)))
+	    (define thread-post (lambda () (semaphore-post thread-sem)))
+	    (define navigate-sem (make-semaphore 0))
+	    (define navigate-mutex (make-semaphore 1))
+	    (define navigate-url #f)
+	    (define handler-sem (make-semaphore 1))
+	    (define handler-wait (lambda () (semaphore-wait handler-sem)))
+	    (define handler-post (lambda () (semaphore-post handler-sem)))
+	    (define handler-table (make-hash-table))
+	    (define handler-thread #f)
+	    (define make-navigator
+	     (lambda (navigate-fun name)
+	       (lambda url
+		 (let ([actual-url #f])
+		   (semaphore-wait navigate-mutex)
+		   (if (apply navigate-fun (cons browser url))
+		       (begin
+			 (semaphore-wait navigate-sem)
+			 (set! actual-url navigate-url))
+		       (begin (semaphore-post navigate-mutex)
+			      (error name "Error navigating browser")))
+                   (semaphore-post navigate-mutex)
+		   actual-url))))
+	    (define block-until-event
+	     (lambda () (mxprims:block-until-event browser)))
+	    (define make-event-key
+	     (lambda (tag id) ; string x string -> symbol
+	       (let ([new-tag (string-copy tag)]
+		     [new-id (string-copy id)])
+		 (string-uppercase! new-tag)
+		    (string-uppercase! new-id)
+		    (string->symbol
+		     (string-append new-tag "@" new-id)))))
+
+	   (public
+	    show
+	    navigate
+	    navigate/status
+	    go-back
+	    go-forward
+	    refresh
+	    iconize
+	    restore
+	    current-url
+	    current-document
+	    print-document
+	    register-event-handler
+	    unregister-event-handler
+	    handle-events
+	    stop-handling-events)
+
+	    (define show
+	     (lambda (b)
+	       (mxprims:browser-show browser b)))
+	    (define navigate/status
+	     (lambda (url)
+	       (let ([actual (navigate url)])
+		 (if (and (>= (string-length actual) 7)
+			  (string=? (substring actual 0 7)
+				    "http://"))
+		     (let* ([p (get-impure-port (string->url actual))]
+			    [response (read-line p)]
+			    [raw-status
+			     (regexp-match "[0-9][0-9][0-9]" response)])
+		       (close-input-port p)
+		       (list actual
+			     (if raw-status
+				 (string->number (car raw-status))
+				 #f)))
+		     (list actual 'no-status)))))
+	    (define navigate-raw
+	     (make-navigator mxprims:navigate 'navigate))
+	    (define navigate
+	      (lambda args
+		(apply navigate-raw args)))
+	    (define go-back-raw
+	     (make-navigator mxprims:go-back 'go-back))
+	    (define go-back
+	      (lambda args
+		(apply go-back-raw args)))
+	    (define go-forward-raw
+	     (make-navigator mxprims:go-forward 'go-forward))
+	    (define go-forward
+	      (lambda args
+		(apply go-forward-raw args)))
+	    (define refresh
+	     (lambda () (mxprims:refresh browser)))
+	    (define iconize
+	     (lambda () (mxprims:iconize browser)))
+	    (define restore
+	     (lambda () (mxprims:restore browser)))
+	    (define current-url
+	     (lambda ()
+	       (mxprims:current-url browser)))
+	    (define current-document
+	     (lambda ()
+	       (make-object mx-document%
+			    (mxprims:current-document browser))))
+	    (define print-document
+	     (lambda ()
+	       (mxprims:print-document browser)))
+	    (define register-event-handler
+	     (lambda (elt fn)
+	       (dynamic-wind
+		handler-wait
+		(lambda ()
+		  (let* ([tag (send elt tag)]
+			 [id (send elt attribute "id")])
+		    (let ([key (make-event-key tag id)])
+		      (hash-table-remove! handler-table key)
+			 (hash-table-put! handler-table key fn))))
+		handler-post)))
+	    (define unregister-event-handler
+	     (lambda (elt)
+	       (dynamic-wind
+		handler-wait
+		(lambda ()
+		  (let* ([tag (send elt tag)]
+			 [id (send elt attribute "id")])
+		    (let ([key (make-event-key tag id)])
+		      (hash-table-remove! handler-table key))))
+		handler-post)))
+	    (define handle-events
+	     (lambda ()
+	       (dynamic-wind
+		thread-wait
+                (lambda ()	; no-op if existing handler-thread
+		  (unless handler-thread
+			  (dynamic-wind
+			   handler-wait
+			   (lambda ()
+			     (let* ([handler-thunk
+				     (lambda ()
+				       (let loop ()
+					 (block-until-event)
+				         (let* ([prim-event
+						 (with-handlers
+						  ([void
+						    (lambda (e)
+						      (printf "~a~n" (exn-message e))
+						      (loop))])
+						    (mxprims:get-event browser))]
+						[event (make-object mx-event% prim-event)]
+						[tag (send event tag)]
+						[id (send event id)]
+						[key (make-event-key tag id)]
+						[handler (hash-table-get handler-table key void)])
+					   (unless (void? handler)
+						   (handler event))
+					   (loop))))])
+			       (set! handler-thread (thread handler-thunk))))
+			   handler-post)))
+		thread-post)))
+	    (define stop-handling-events
+	     (lambda ()
+	       (dynamic-wind
+		thread-wait
+		(lambda ()
+		  (when handler-thread
+			(kill-thread handler-thread))
+		  (set! handler-thread #f))
+		thread-post)))
+
+	    (super-make-object)
+	    (mxprims:register-navigate-handler
+	     browser
+	     (lambda (_ boxed-url)
+	       (set! navigate-url (current-url))
+	       (semaphore-post navigate-sem)))))
+
+  (define mx-document%
+    (class object%
+	   (init the-doc)
+
+     ; private fields
+
+     (define doc the-doc)
+
+     (define insert-object-maker
+       (lambda (name->html)
+	 (opt-lambda
+	  (object width height [size 'pixels])
+	  (dynamic-wind
+	      html-wait
+	      (lambda ()
+		(mxprims:document-insert-html
+		 doc
+		 (name->html object width height size))
+		(car (mxprims:document-objects doc)))
+	      html-post))))
+
+     (define append-object-maker
+       (lambda (name->html)
+	 (opt-lambda
+	  (object width height [size 'pixels])
+	  (dynamic-wind
+	      html-wait
+	      (lambda ()
+		(mxprims:document-append-html
+		    doc
+		    (name->html object width height size))
+		(car (mzlib:last-pair (mxprims:document-objects doc))))
+	      html-post))))
+
+     (define html-insertion-maker
+       (lambda (f)
+	 (lambda (s)
+	   (dynamic-wind
+	       html-wait
+	       (lambda () (f doc s))
+	       html-post))))
+
+     (public
+      title
+      find-element
+      find-element-by-id-or-name
+      elements-with-tag
+      objects
+      insert-html
+      append-html
+      replace-html
+      insert-object-from-coclass
+      append-object-from-coclass
+      insert-object-from-progid
+      append-object-from-progid)
+
+     (define title
+      (lambda ()
+	(mxprims:document-title doc)))
+     (define find-element
+       (lambda (tag id . n)
+	 (make-object mx-element% doc
+		      (apply mxprims:document-find-element
+			     doc tag id n))))
+     (define find-element-by-id-or-name
+       (lambda (id . n)
+	 (make-object
+	  mx-element% doc
+	  (apply mxprims:document-find-element-by-id-or-name
+		 doc id n))))
+     (define elements-with-tag
+       (lambda (tag)
+	 (map
+	  (lambda (elt)
+	    (make-object mx-element% doc elt))
+	  (mxprims:document-elements-with-tag doc tag))))
+     (define objects
+       (lambda ()
+	 (mxprims:document-objects doc)))
+     (define insert-html-raw
+       (html-insertion-maker mxprims:document-insert-html))
+     (define insert-html
+       (lambda args
+	 (apply insert-html-raw args)))
+     (define append-html-raw
+       (html-insertion-maker mxprims:document-append-html))
+     (define append-html
+       (lambda args
+	 (apply append-html-raw args)))
+     (define replace-html-raw
+       (html-insertion-maker mxprims:document-replace-html))
+     (define replace-html
+       (lambda args
+	 (apply replace-html-raw args)))
+     (define insert-object-from-coclass-raw
+       (insert-object-maker coclass->html))
+     (define insert-object-from-coclass
+       (lambda args
+	 (apply insert-object-from-coclass-raw args)))
+     (define append-object-from-coclass-raw
+       (append-object-maker coclass->html))
+     (define append-object-from-coclass
+       (lambda args
+	 (apply append-object-from-coclass-raw args)))
+     (define insert-object-from-progid-raw
+       (insert-object-maker progid->html))
+     (define insert-object-from-progid
+       (lambda args
+	 (apply insert-object-from-progid-raw args)))
+     (define append-object-from-progid-raw
+       (append-object-maker progid->html))
+     (define append-object-from-progid
+       (lambda args
+	 (apply append-object-from-progid-raw args)))
+
+     (super-make-object)))
+
+  (thread
+   (lambda ()
+     (let loop ()
+       (mxprims:process-win-events)
+       (sleep 0.01)
+       (loop)))))
diff --git a/collects/mysterx/private/filter.ss b/collects/mysterx/private/filter.ss
new file mode 100644
index 0000000000..ee5b5408cb
--- /dev/null
+++ b/collects/mysterx/private/filter.ss
@@ -0,0 +1,362 @@
+;;; filter.ss
+
+(module filter mzscheme
+  (require (lib "string.ss"))
+  (require "properties.ss")
+  (require "util.ss")
+
+  (provide
+   string->filter
+   filter->string)
+
+  (define (alpha-filter-options-validator opt)
+    (let ([name (car opt)]
+	  [val (cadr opt)])
+      (case name
+	[(enabled) #t]
+	[(finish-opacity opacity) 
+	 (exact-with-bounds? val 0 100)]
+	[(finish-x finish-y)
+	 (and (number? val)
+	      (exact? val))]
+	[(finish-x finish-y start-x starty-y)
+	 (and (number? val)
+	      (exact? val))]
+	[(style)
+	 (alpha-filter-style? val)]
+	[else #f])))
+
+  (define (alpha-filter-options-translator opt)
+    (let ([name (car opt)]
+	  [val (cadr opt)])
+      (case name
+	[(enabled) (bool->string val)]
+	[(finish-opacity opacity finish-x finish-y start-x start-y)
+	 (number->string val)]
+	[(style)
+	 (number->string (list-pos val *alpha-filter-styles*))]
+	[else (error "Can't translate alpha filter option" opt)])))
+
+  (define (blend-trans-filter-options-validator opt)
+    (let ([name (car opt)]
+	  [val (cadr opt)])
+      (case name
+	[(enable) #t]
+	[(duration) (number? val)]
+	[(status) (trans-filter-status? val)] 
+	[else #f])))
+
+  (define (blend-trans-filter-options-translator opt)
+    (let ([name (car opt)]
+	  [val (cadr opt)])
+      (case name
+	[(enable) (bool->string val)]
+	[(duration) (number->string val)]
+	[(status) (list-pos val *trans-filter-statuses*)]
+	[else (error "Can't translate blend-trans filter option" opt)])))
+
+  (define (blur-filter-options-validator opt)
+    (let ([name (car opt)]
+	  [val (cadr opt)])
+      (case name
+	[(add enabled) #t]
+	[(direction) (filter-direction? val)]
+	[(strength) (exact-with-bounds? val 1 100)]
+	[else #f])))
+
+  (define (blur-filter-options-translator opt)
+    (let ([name (car opt)]
+	  [val (cadr opt)])
+      (case name
+	[(add enabled) (bool->string val)]
+	[(direction strength) (number->string val)]
+	[else (error "Can't translate blur filter option" opt)])))
+
+  (define (chroma-filter-options-validator opt)
+    (let ([name (car opt)]
+	  [val (cadr opt)])
+      (case name
+	[(enabled) #t]
+	[(color) (hex-color-string? val)]
+	[else #f])))
+
+  (define (chroma-filter-options-translator opt)
+    (let ([name (car opt)]
+	  [val (cadr opt)])
+      (case name
+	[(enabled) (bool->string val)]
+	[(color) val]
+	[else (error "Can't translate chroma filter option" opt)])))
+
+  (define (drop-shadow-filter-options-validator opt)
+    (let ([name (car opt)]
+	  [val (cadr opt)])
+      (case name
+	[(enabled positive) #t]
+	[(color) (hex-color-string? val)]
+	[(off-x off-y) 
+	 (and (number? val)
+	      (exact? val))]
+	[else #f])))
+
+  (define (drop-shadow-filter-options-translator opt)
+    (let ([name (car opt)]
+	  [val (cadr opt)])
+      (case name
+	[(enabled positive) (bool->string val)]
+	[(color) val]
+	[(off-x off-y) (number->string val)]
+	[else (error "Can't translate drop-shadow filter option" opt)])))
+
+  (define (basic-filter-options-validator opt)
+    (let ([name (car opt)]
+	  [val (cadr opt)])
+      (case name
+	[(enabled positive) #t]
+	[else #f])))
+
+  (define (basic-filter-options-translator opt)
+    (let ([name (car opt)]
+	  [val (cadr opt)])
+      (case name
+	[(enabled positive) (bool->string val)]
+	[else (error "Can't translate basic filter option" opt)])))
+
+  (define (glow-filter-options-validator opt)
+    (let ([name (car opt)]
+	  [val (cadr opt)])
+      (case name
+	[(enabled) #t]
+	[(color) (hex-color-string? val)]
+	[(strength) (exact-with-bounds? val 1 100)]
+	[else #f])))
+
+  (define (glow-filter-options-translator opt)
+    (let ([name (car opt)]
+	  [val (cadr opt)])
+      (case name
+	[(enabled) (bool->string val)]
+	[(color) val]
+	[(strength) (number->string val)]
+	[else (error "Can't translate glow filter option" opt)])))
+
+
+  (define (mask-filter-options-validator opt)
+    (let ([name (car opt)]
+	  [val (cadr opt)])
+      (case name
+	[(enabled) #t]
+	[(color) (hex-color-string? val)]
+	[else #f])))
+
+  (define (mask-filter-options-translator opt)
+    (let ([name (car opt)]
+	  [val (cadr opt)])
+      (case name
+	[(enabled) (bool->string val)]
+	[(color) val]
+	[else (error "Can't translate mask filter option" opt)])))
+
+  (define (reveal-trans-filter-options-validator opt)
+    (let ([name (car opt)]
+	  [val (cadr opt)])
+      (case name
+	[(enabled) #t]
+	[(duration) (number? val)]
+	[(status) (trans-filter-status? val)] 
+	[else #f])))
+
+  (define (reveal-trans-filter-options-translator opt)
+    (let ([name (car opt)]
+	  [val (cadr opt)])
+      (case name
+	[(enabled) (bool->string val)]
+	[(duration) (number->string val)]
+	[(status) (list-pos val *trans-filter-statuses*)]
+	[else (error "Can't translate reveal-trans filter option" opt)])))
+
+  (define (shadow-filter-options-validator opt)
+    (let ([name (car opt)]
+	  [val (cadr opt)])
+      (case name
+	[(enabled) #t]
+	[(color) (hex-color-string? val)]
+	[(direction) (filter-direction? val)]
+	[else #f])))
+
+  (define (shadow-filter-options-translator opt)
+    (let ([name (car opt)]
+	  [val (cadr opt)])
+      (case name
+	[(enabled) (bool->string val)]
+	[(color) val]
+	[(direction) (number->string val)]
+	[else #f])))
+
+  (define (wave-filter-options-validator opt)
+    (let ([name (car opt)]
+	  [val (cadr opt)])
+      (case name
+	[(enabled add) #t]
+	[(freq) (and (number? val)
+		     (>= val 0))]
+	[(light-strength phase) (exact-with-bounds? val 0 100)]
+	[(strength) (exact-with-bounds? val 1 100)]
+	[else #f])))
+
+  (define (wave-filter-options-translator opt)
+    (let ([name (car opt)]
+	  [val (cadr opt)])
+      (case name
+	[(enabled add) (bool->string val)]
+	[(freq) (number->string val)]
+	[(light-strength phase) (number->string val)]
+	[(strength) (number->string val)]
+	[else (error "Can't translate wave filter option" opt)])))
+
+  (define (filter->string filter options)
+    (unless (filter? filter)
+	    (error 
+	     (format "Expected filter (element of '~a), got ~a" 
+		     *filters* filter)))
+    (for-each
+     (lambda (opt)
+       (unless (and (pair? opt)
+		    (symbol? (car opt))
+		    (eq? (length opt) 2))
+	       (error (string-append
+		       "Filter options must be of the form (option value), "
+		       "got") opt)))
+     options)
+    (let* ([validators
+	    `((alpha ,alpha-filter-options-validator 
+		     ,alpha-filter-options-translator)
+	      (blend-trans ,blend-trans-filter-options-validator
+			   ,blend-trans-filter-options-translator)
+	      (blur ,blur-filter-options-validator
+		    ,blur-filter-options-translator)
+	      (chroma ,chroma-filter-options-validator
+		      ,chroma-filter-options-translator)
+	      (drop-shadow ,drop-shadow-filter-options-validator
+			   ,drop-shadow-filter-options-translator)
+	      (flip-horizontal ,basic-filter-options-validator
+			       ,basic-filter-options-translator)
+	      (flip-vertical ,basic-filter-options-validator
+			     ,basic-filter-options-translator)
+	      (glow ,glow-filter-options-validator
+		    ,glow-filter-options-translator)
+	      (gray ,basic-filter-options-validator
+		    ,basic-filter-options-translator)
+	      (invert ,basic-filter-options-validator
+		      ,basic-filter-options-translator)
+	      (light ,basic-filter-options-validator
+		     ,basic-filter-options-translator)
+	      (mask ,mask-filter-options-validator
+		    ,mask-filter-options-translator)
+	      (redirect ,basic-filter-options-validator
+			,basic-filter-options-translator)
+	      (reveal-trans ,reveal-trans-filter-options-validator
+			    ,reveal-trans-filter-options-translator)
+	      (shadow ,shadow-filter-options-validator
+		      ,shadow-filter-options-translator)
+	      (wave ,wave-filter-options-validator
+		    ,wave-filter-options-translator)
+	      (x-ray ,basic-filter-options-validator
+		     ,basic-filter-options-validator))]
+	   [entry (assq filter validators)]
+	   [validate-one (cadr entry)]
+	   [translate-one (caddr entry)])
+      ; validate
+      (for-each
+       (lambda (opt)
+	 (unless (validate-one opt)
+		 (error 
+		  (format "Invalid ~a filter option: ~a"
+			  filter opt))))
+       options)
+      ; translate
+      (let* ([translated-options 
+	      (map (lambda (opt)
+		     (list 
+		      (symbol->string (car opt))
+		      (translate-one opt)))
+		   options)]
+	     [flat-string-options
+	      (let loop ([opts translated-options])
+		(cond
+		 [(null? opts) ""]
+		 [(null? (cdr opts))
+		  (string-append 
+		   (caar opts)
+		   "="
+		   (cadar opts))]
+		 [else
+		  (string-append 
+		   (caar opts)
+		   "="
+		   (cadar opts)
+		   ","
+		   (loop (cdr opts)))]))])
+      (string-append
+       (symbol->string (cadr (assq filter *filters-and-official-names*))) "("  
+       flat-string-options
+       ")"))))
+
+  (define (filter-opt-string->value s)
+   (cond
+    [(string=? s "true") #t]
+    [(string=? s "false") #f]
+    [(hex-digit-string? s) s]
+    [(string->number s) => 
+     (lambda (n) n)]
+    [else
+     (let ([sym (string->symbol s)])
+       (cond
+	[(alpha-filter-style? sym)
+	 (list-pos sym *alpha-filter-styles*)]
+	[(trans-filter-status? sym)
+	 (list-pos sym *trans-filter-statuses*)]
+	[(reveal-transition? sym)
+	 (list-pos sym *reveal-transitions*)]
+	[else ; guess
+	 s]))]))
+
+ (define (string->filter s)
+    ; s should be of form "name(opt=val,...)"
+   (string-lowercase! s)
+   (let* ([filter-name
+	   (regexp-match *filter-re* s)]
+	  [filter-sym
+	   (if filter-name
+	       (let ([entry
+		      (assq (string->symbol (car filter-name))
+			    *official-names-and-filters*)])
+		 (if entry
+		     (cadr entry)
+		     'empty-filter))
+	       'empty-filter)]
+	  [re-opt (regexp "[^,()]*=[^,()]*")]
+	  [re-opt-name (regexp ".*=")]
+	  [re-opt-val (regexp "=.*")])
+     (if (eq? filter-sym 'empty-filter)
+	 '(empty-filter)
+	 (let loop ([rs (regexp-replace (car filter-name) s "")]
+		    [opts '()])
+	   (let ([opt-match (regexp-match re-opt rs)])
+	     (if opt-match
+		 (let* ([one-opt (car opt-match)]
+			[opt-name
+			 (let ([name 
+				(car (regexp-match re-opt-name one-opt))])
+			   (string->symbol 
+			    (substring name 0 (sub1 (string-length name)))))]
+			[opt-val
+			 (let ([val 
+				(car (regexp-match re-opt-val one-opt))])
+			   (substring val 1 (string-length val)))])
+		   (loop (regexp-replace one-opt rs "")
+			 (cons (list opt-name 
+				     (filter-opt-string->value
+				      opt-val)) opts)))
+		 (cons filter-sym (reverse opts)))))))))
+
diff --git a/collects/mysterx/private/mxmain.ss b/collects/mysterx/private/mxmain.ss
new file mode 100644
index 0000000000..0b1f77b771
--- /dev/null
+++ b/collects/mysterx/private/mxmain.ss
@@ -0,0 +1,573 @@
+(module mxmain mzscheme
+
+  ; dummy entries to make Setup happy
+  ; these are the names defined in mxPrims[] in src/mysterx.cxx
+
+  (provide
+   mx-version
+   block-while-browsers
+   com-invoke
+   com-set-property!
+   com-get-property
+   com-get-properties
+   com-set-properties
+   com-methods
+   com-events
+   com-method-type
+   com-get-property-type
+   com-set-property-type
+   com-event-type
+   com-help
+   com-object-type
+   com-is-a?
+   com-currency?
+   com-date?
+   com-date->date
+   date->com-date
+   com-scode?
+   com-scode->number
+   number->com-scode
+   com-currency->number
+   number->com-currency
+   com-object?
+   com-iunknown?
+   com-register-event-handler
+   com-unregister-event-handler
+   com-all-coclasses
+   com-all-controls
+   coclass->html
+   progid->html
+   cocreate-instance-from-coclass
+   cocreate-instance-from-progid
+   coclass
+   progid
+   set-coclass!
+   set-coclass-from-progid!
+   com-object-eq?
+   com-register-object
+   com-release-object
+   com-add-ref
+   com-ref-count
+   com-terminate
+   make-browser
+   browser-show
+   navigate
+   go-back
+   go-forward
+   refresh
+   iconize
+   restore
+   current-url
+   register-navigate-handler
+   current-document
+   print-document
+   document?
+   document-title
+   document-insert-html
+   document-append-html
+   document-replace-html
+   document-find-element
+   document-find-element-by-id-or-name
+   document-elements-with-tag
+   document-objects
+   element-insert-html
+   element-append-html
+   element-insert-text
+   element-append-text
+   element-replace-html
+   element-get-html
+   element-get-text
+   element-focus
+   element-selection
+   element-set-selection!
+   element-attribute
+   element-set-attribute!
+   element-click
+   element-tag
+   element-font-family
+   element-set-font-family!
+   element-font-style
+   element-set-font-style!
+   element-font-variant
+   element-set-font-variant!
+   element-font-weight
+   element-set-font-weight!
+   element-font
+   element-set-font!
+   element-background
+   element-set-background!
+   element-background-attachment
+   element-set-background-attachment!
+   element-background-image
+   element-set-background-image!
+   element-background-repeat
+   element-set-background-repeat!
+   element-background-position
+   element-set-background-position!
+   element-text-decoration
+   element-set-text-decoration!
+   element-text-transform
+   element-set-text-transform!
+   element-text-align
+   element-set-text-align!
+   element-margin
+   element-set-margin!
+   element-padding
+   element-set-padding!
+   element-border
+   element-set-border!
+   element-border-top
+   element-set-border-top!
+   element-border-bottom
+   element-set-border-bottom!
+   element-border-left
+   element-set-border-left!
+   element-border-right
+   element-set-border-right!
+   element-border-color
+   element-set-border-color!
+   element-border-width
+   element-set-border-width!
+   element-border-style
+   element-set-border-style!
+   element-border-top-style
+   element-set-border-top-style!
+   element-border-bottom-style
+   element-set-border-bottom-style!
+   element-border-left-style
+   element-set-border-left-style!
+   element-border-right-style
+   element-set-border-right-style!
+   element-style-float
+   element-set-style-float!
+   element-clear
+   element-set-clear!
+   element-display
+   element-set-display!
+   element-visibility
+   element-set-visibility!
+   element-list-style-type
+   element-set-list-style-type!
+   element-list-style-position
+   element-set-list-style-position!
+   element-list-style-image
+   element-set-list-style-image!
+   element-list-style
+   element-set-list-style!
+   element-position
+   element-overflow
+   element-set-overflow!
+   element-pagebreak-before
+   element-set-pagebreak-before!
+   element-pagebreak-after
+   element-set-pagebreak-after!
+   element-css-text
+   element-set-css-text!
+   element-cursor
+   element-set-cursor!
+   element-clip
+   element-set-clip!
+   element-filter
+   element-set-filter!
+   element-style-string
+   element-text-decoration-none
+   element-set-text-decoration-none!
+   element-text-decoration-underline
+   element-set-text-decoration-underline!
+   element-text-decoration-overline
+   element-set-text-decoration-overline!
+   element-text-decoration-linethrough
+   element-set-text-decoration-linethrough!
+   element-text-decoration-blink
+   element-set-text-decoration-blink!
+   element-pixel-top
+   element-set-pixel-top!
+   element-pixel-left
+   element-set-pixel-left!
+   element-pixel-width
+   element-set-pixel-width!
+   element-pixel-height
+   element-set-pixel-height!
+   element-pos-top
+   element-set-pos-top!
+   element-pos-left
+   element-set-pos-left!
+   element-pos-width
+   element-set-pos-width!
+   element-pos-height
+   element-set-pos-height!
+   element-font-size
+   element-set-font-size!
+   element-color
+   element-set-color!
+   element-background-color
+   element-set-background-color!
+   element-background-position-x
+   element-set-background-position-x!
+   element-background-position-y
+   element-set-background-position-y!
+   element-letter-spacing
+   element-set-letter-spacing!
+   element-vertical-align
+   element-set-vertical-align!
+   element-text-indent
+   element-set-text-indent!
+   element-line-height
+   element-set-line-height!
+   element-margin-top
+   element-set-margin-top!
+   element-margin-bottom
+   element-set-margin-bottom!
+   element-margin-left
+   element-set-margin-left!
+   element-margin-right
+   element-set-margin-right!
+   element-padding-top
+   element-set-padding-top!
+   element-padding-bottom
+   element-set-padding-bottom!
+   element-padding-left
+   element-set-padding-left!
+   element-padding-right
+   element-set-padding-right!
+   element-border-top-color
+   element-set-border-top-color!
+   element-border-bottom-color
+   element-set-border-bottom-color!
+   element-border-left-color
+   element-set-border-left-color!
+   element-border-right-color
+   element-set-border-right-color!
+   element-border-top-width
+   element-set-border-top-width!
+   element-border-bottom-width
+   element-set-border-bottom-width!
+   element-border-left-width
+   element-set-border-left-width!
+   element-border-right-width
+   element-set-border-right-width!
+   element-width
+   element-set-width!
+   element-height
+   element-set-height!
+   element-top
+   element-set-top!
+   element-left
+   element-set-left!
+   element-z-index
+   element-set-z-index!
+   event?
+   get-event
+   event-tag
+   event-id
+   event-from-tag
+   event-from-id
+   event-to-tag
+   event-to-id
+   event-keycode
+   event-shiftkey
+   event-ctrlkey
+   event-altkey
+   event-x
+   event-y
+   event-keypress?
+   event-keydown?
+   event-keyup?
+   event-mousedown?
+   event-mousemove?
+   event-mouseover?
+   event-mouseout?
+   event-mouseup?
+   event-click?
+   event-dblclick?
+   event-error?
+   block-until-event
+   process-win-events
+   release-type-table
+   com-omit
+   %%initialize-dotnet-runtime)
+
+  (error "mxmain.ss: you seem to be missing mxmain.dll; you need to build MysterX in plt\\src\\mysterx\\")
+
+  (define mx-version #f)
+  (define block-while-browsers #f)
+  (define com-invoke #f)
+  (define com-set-property! #f)
+  (define com-get-property #f)
+  (define com-get-properties #f)
+  (define com-set-properties #f)
+  (define com-methods #f)
+  (define com-events #f)
+  (define com-method-type #f)
+  (define com-get-property-type #f)
+  (define com-set-property-type #f)
+  (define com-event-type #f)
+  (define com-help #f)
+  (define com-object-type #f)
+  (define com-is-a? #f)
+  (define com-currency? #f)
+  (define com-date? #f)
+  (define com-date->date #f)
+  (define date->com-date #f)
+  (define com-scode? #f)
+  (define com-scode->number #f)
+  (define number->com-scode #f)
+  (define com-currency->number #f)
+  (define number->com-currency #f)
+  (define com-object? #f)
+  (define com-iunknown? #f)
+  (define com-register-event-handler #f)
+  (define com-unregister-event-handler #f)
+  (define com-all-coclasses #f)
+  (define com-all-controls #f)
+  (define coclass->html #f)
+  (define progid->html #f)
+  (define cocreate-instance-from-coclass #f)
+  (define cocreate-instance-from-progid #f)
+  (define coclass #f)
+  (define progid #f)
+  (define set-coclass! #f)
+  (define set-coclass-from-progid! #f)
+  (define com-object-eq? #f)
+  (define com-register-object #f)
+  (define com-release-object #f)
+  (define com-add-ref #f)
+  (define com-ref-count #f)
+  (define com-terminate #f)
+  (define make-browser #f)
+  (define browser-show #f)
+  (define navigate #f)
+  (define go-back #f)
+  (define go-forward #f)
+  (define refresh #f)
+  (define iconize #f)
+  (define restore #f)
+  (define current-url #f)
+  (define register-navigate-handler #f)
+  (define current-document #f)
+  (define print-document #f)
+  (define document? #f)
+  (define document-title #f)
+  (define document-insert-html #f)
+  (define document-append-html #f)
+  (define document-replace-html #f)
+  (define document-find-element #f)
+  (define document-find-element-by-id-or-name #f)
+  (define document-elements-with-tag #f)
+  (define document-objects #f)
+  (define element-insert-html #f)
+  (define element-append-html #f)
+  (define element-insert-text #f)
+  (define element-append-text #f)
+  (define element-replace-html #f)
+  (define element-get-html #f)
+  (define element-get-text #f)
+  (define element-focus #f)
+  (define element-selection #f)
+  (define element-set-selection! #f)
+  (define element-attribute #f)
+  (define element-set-attribute! #f)
+  (define element-click #f)
+  (define element-tag #f)
+  (define element-font-family #f)
+  (define element-set-font-family! #f)
+  (define element-font-style #f)
+  (define element-set-font-style! #f)
+  (define element-font-variant #f)
+  (define element-set-font-variant! #f)
+  (define element-font-weight #f)
+  (define element-set-font-weight! #f)
+  (define element-font #f)
+  (define element-set-font! #f)
+  (define element-background #f)
+  (define element-set-background! #f)
+  (define element-background-attachment #f)
+  (define element-set-background-attachment! #f)
+  (define element-background-image #f)
+  (define element-set-background-image! #f)
+  (define element-background-repeat #f)
+  (define element-set-background-repeat! #f)
+  (define element-background-position #f)
+  (define element-set-background-position! #f)
+  (define element-text-decoration #f)
+  (define element-set-text-decoration! #f)
+  (define element-text-transform #f)
+  (define element-set-text-transform! #f)
+  (define element-text-align #f)
+  (define element-set-text-align! #f)
+  (define element-margin #f)
+  (define element-set-margin! #f)
+  (define element-padding #f)
+  (define element-set-padding! #f)
+  (define element-border #f)
+  (define element-set-border! #f)
+  (define element-border-top #f)
+  (define element-set-border-top! #f)
+  (define element-border-bottom #f)
+  (define element-set-border-bottom! #f)
+  (define element-border-left #f)
+  (define element-set-border-left! #f)
+  (define element-border-right #f)
+  (define element-set-border-right! #f)
+  (define element-border-color #f)
+  (define element-set-border-color! #f)
+  (define element-border-width #f)
+  (define element-set-border-width! #f)
+  (define element-border-style #f)
+  (define element-set-border-style! #f)
+  (define element-border-top-style #f)
+  (define element-set-border-top-style! #f)
+  (define element-border-bottom-style #f)
+  (define element-set-border-bottom-style! #f)
+  (define element-border-left-style #f)
+  (define element-set-border-left-style! #f)
+  (define element-border-right-style #f)
+  (define element-set-border-right-style! #f)
+  (define element-style-float #f)
+  (define element-set-style-float! #f)
+  (define element-clear #f)
+  (define element-set-clear! #f)
+  (define element-display #f)
+  (define element-set-display! #f)
+  (define element-visibility #f)
+  (define element-set-visibility! #f)
+  (define element-list-style-type #f)
+  (define element-set-list-style-type! #f)
+  (define element-list-style-position #f)
+  (define element-set-list-style-position! #f)
+  (define element-list-style-image #f)
+  (define element-set-list-style-image! #f)
+  (define element-list-style #f)
+  (define element-set-list-style! #f)
+  (define element-position #f)
+  (define element-overflow #f)
+  (define element-set-overflow! #f)
+  (define element-pagebreak-before #f)
+  (define element-set-pagebreak-before! #f)
+  (define element-pagebreak-after #f)
+  (define element-set-pagebreak-after! #f)
+  (define element-css-text #f)
+  (define element-set-css-text! #f)
+  (define element-cursor #f)
+  (define element-set-cursor! #f)
+  (define element-clip #f)
+  (define element-set-clip! #f)
+  (define element-filter #f)
+  (define element-set-filter! #f)
+  (define element-style-string #f)
+  (define element-text-decoration-none #f)
+  (define element-set-text-decoration-none! #f)
+  (define element-text-decoration-underline #f)
+  (define element-set-text-decoration-underline! #f)
+  (define element-text-decoration-overline #f)
+  (define element-set-text-decoration-overline! #f)
+  (define element-text-decoration-linethrough #f)
+  (define element-set-text-decoration-linethrough! #f)
+  (define element-text-decoration-blink #f)
+  (define element-set-text-decoration-blink! #f)
+  (define element-pixel-top #f)
+  (define element-set-pixel-top! #f)
+  (define element-pixel-left #f)
+  (define element-set-pixel-left! #f)
+  (define element-pixel-width #f)
+  (define element-set-pixel-width! #f)
+  (define element-pixel-height #f)
+  (define element-set-pixel-height! #f)
+  (define element-pos-top #f)
+  (define element-set-pos-top! #f)
+  (define element-pos-left #f)
+  (define element-set-pos-left! #f)
+  (define element-pos-width #f)
+  (define element-set-pos-width! #f)
+  (define element-pos-height #f)
+  (define element-set-pos-height! #f)
+  (define element-font-size #f)
+  (define element-set-font-size! #f)
+  (define element-color #f)
+  (define element-set-color! #f)
+  (define element-background-color #f)
+  (define element-set-background-color! #f)
+  (define element-background-position-x #f)
+  (define element-set-background-position-x! #f)
+  (define element-background-position-y #f)
+  (define element-set-background-position-y! #f)
+  (define element-letter-spacing #f)
+  (define element-set-letter-spacing! #f)
+  (define element-vertical-align #f)
+  (define element-set-vertical-align! #f)
+  (define element-text-indent #f)
+  (define element-set-text-indent! #f)
+  (define element-line-height #f)
+  (define element-set-line-height! #f)
+  (define element-margin-top #f)
+  (define element-set-margin-top! #f)
+  (define element-margin-bottom #f)
+  (define element-set-margin-bottom! #f)
+  (define element-margin-left #f)
+  (define element-set-margin-left! #f)
+  (define element-margin-right #f)
+  (define element-set-margin-right! #f)
+  (define element-padding-top #f)
+  (define element-set-padding-top! #f)
+  (define element-padding-bottom #f)
+  (define element-set-padding-bottom! #f)
+  (define element-padding-left #f)
+  (define element-set-padding-left! #f)
+  (define element-padding-right #f)
+  (define element-set-padding-right! #f)
+  (define element-border-top-color #f)
+  (define element-set-border-top-color! #f)
+  (define element-border-bottom-color #f)
+  (define element-set-border-bottom-color! #f)
+  (define element-border-left-color #f)
+  (define element-set-border-left-color! #f)
+  (define element-border-right-color #f)
+  (define element-set-border-right-color! #f)
+  (define element-border-top-width #f)
+  (define element-set-border-top-width! #f)
+  (define element-border-bottom-width #f)
+  (define element-set-border-bottom-width! #f)
+  (define element-border-left-width #f)
+  (define element-set-border-left-width! #f)
+  (define element-border-right-width #f)
+  (define element-set-border-right-width! #f)
+  (define element-width #f)
+  (define element-set-width! #f)
+  (define element-height #f)
+  (define element-set-height! #f)
+  (define element-top #f)
+  (define element-set-top! #f)
+  (define element-left #f)
+  (define element-set-left! #f)
+  (define element-z-index #f)
+  (define element-set-z-index! #f)
+  (define event? #f)
+  (define get-event #f)
+  (define event-tag #f)
+  (define event-id #f)
+  (define event-from-tag #f)
+  (define event-from-id #f)
+  (define event-to-tag #f)
+  (define event-to-id #f)
+  (define event-keycode #f)
+  (define event-shiftkey #f)
+  (define event-ctrlkey #f)
+  (define event-altkey #f)
+  (define event-x #f)
+  (define event-y #f)
+  (define event-keypress? #f)
+  (define event-keydown? #f)
+  (define event-keyup? #f)
+  (define event-mousedown? #f)
+  (define event-mousemove? #f)
+  (define event-mouseover? #f)
+  (define event-mouseout? #f)
+  (define event-mouseup? #f)
+  (define event-click? #f)
+  (define event-dblclick? #f)
+  (define event-error? #f)
+  (define block-until-event #f)
+  (define process-win-events #f)
+  (define release-type-table #f)
+  (define com-omit #f)
+  (define %%initialize-dotnet-runtime #f))
diff --git a/collects/mysterx/private/prims.ss b/collects/mysterx/private/prims.ss
new file mode 100644
index 0000000000..b2b4fdfba1
--- /dev/null
+++ b/collects/mysterx/private/prims.ss
@@ -0,0 +1,300 @@
+;; prims.ss
+
+(module prims mzscheme
+  (require "mxmain.ss")
+
+  (provide 
+   mx-version
+   com-invoke
+   com-set-property!
+   com-get-property
+   com-methods
+   com-get-properties
+   com-set-properties
+   com-events	
+   com-method-type
+   com-get-property-type
+   com-set-property-type
+   com-event-type
+   com-object-type
+   com-is-a?
+   com-date->date
+   date->com-date
+   com-date?
+   com-currency?
+   com-currency->number	
+   number->com-currency
+   com-scode?
+   com-scode->number
+   number->com-scode
+   com-object?
+   com-iunknown?
+   com-help
+   com-register-event-handler
+   com-unregister-event-handler
+   com-all-coclasses
+   com-all-controls
+   coclass->html
+   progid->html
+   cocreate-instance-from-coclass
+   cocreate-instance-from-progid
+   coclass
+   progid
+   set-coclass!
+   set-coclass-from-progid!
+   com-object-eq?
+   com-register-object
+   com-release-object
+   com-add-ref
+   com-ref-count
+   make-browser
+   browser-show
+   navigate
+   go-back
+   go-forward
+   refresh
+   iconize
+   restore
+   register-navigate-handler
+   current-url
+   current-document	
+   print
+   document?
+   document-title
+   document-insert-html
+   document-append-html
+   document-replace-html
+   document-find-element
+   document-find-element-by-id-or-name
+   document-elements-with-tag
+   document-objects
+   element-insert-html
+   element-append-html
+   element-replace-html
+   element-get-html
+   element-get-text
+   element-insert-text
+   element-append-text
+   element-focus	
+   element-selection
+   element-set-selection!
+   element-attribute
+   element-set-attribute!
+   element-click
+   element-tag
+   element-font-family
+   element-set-font-family!
+   element-font-style
+   element-set-font-style!
+   element-font-variant
+   element-set-font-variant!
+   element-font-weight
+   element-set-font-weight!
+   element-font
+   element-set-font!
+   element-background
+   element-set-background!
+   element-background-attachment
+   element-set-background-attachment!
+   element-background-image
+   element-set-background-image!
+   element-background-repeat
+   element-set-background-repeat!
+   element-background-position
+   element-set-background-position!
+   element-text-decoration
+   element-set-text-decoration!
+   element-text-transform
+   element-set-text-transform!
+   element-text-align
+   element-set-text-align!
+   element-margin
+   element-set-margin!
+   element-padding
+   element-set-padding!
+   element-border
+   element-set-border!
+   element-border-top
+   element-set-border-top!
+   element-border-bottom
+   element-set-border-bottom!
+   element-border-left
+   element-set-border-left!
+   element-border-right
+   element-set-border-right!
+   element-border-color
+   element-set-border-color!
+   element-border-width
+   element-set-border-width!
+   element-border-style
+   element-set-border-style!
+   element-border-top-style
+   element-set-border-top-style!
+   element-border-bottom-style
+   element-set-border-bottom-style!
+   element-border-left-style
+   element-set-border-left-style!
+   element-border-right-style
+   element-set-border-right-style!
+   element-style-float
+   element-set-style-float!
+   element-clear
+   element-set-clear!
+   element-display
+   element-set-display!
+   element-visibility
+   element-set-visibility!
+   element-list-style-type
+   element-set-list-style-type!
+   element-list-style-position
+   element-set-list-style-position!
+   element-list-style-image
+   element-set-list-style-image!
+   element-list-style
+   element-set-list-style!
+   element-position
+   element-overflow
+   element-set-overflow!
+   element-pagebreak-before
+   element-set-pagebreak-before!
+   element-pagebreak-after
+   element-set-pagebreak-after!
+   element-css-text
+   element-set-css-text!
+   element-cursor
+   element-set-cursor!
+   element-clip
+   element-set-clip!
+   element-filter
+   element-set-filter!
+   element-style-string
+   element-text-decoration-none
+   element-set-text-decoration-none!
+   element-text-decoration-underline
+   element-set-text-decoration-underline!
+   element-text-decoration-overline
+   element-set-text-decoration-overline!
+   element-text-decoration-linethrough
+   element-set-text-decoration-linethrough!
+   element-text-decoration-blink
+   element-set-text-decoration-blink!
+   element-pixel-top
+   element-set-pixel-top!
+   element-pixel-left
+   element-set-pixel-left!
+   element-pixel-width
+   element-set-pixel-width!
+   element-pixel-height
+   element-set-pixel-height!
+   element-pos-top
+   element-set-pos-top!
+   element-pos-left
+   element-set-pos-left!
+   element-pos-width
+   element-set-pos-width!
+   element-pos-height
+   element-set-pos-height!
+   element-font-size
+   element-set-font-size!
+   element-color
+   element-set-color!
+   element-background-color
+   element-set-background-color!
+   element-background-position-x
+   element-set-background-position-x!
+   element-background-position-y
+   element-set-background-position-y!
+   element-letter-spacing
+   element-set-letter-spacing!
+   element-vertical-align
+   element-set-vertical-align!
+   element-text-indent
+   element-set-text-indent!
+   element-line-height
+   element-set-line-height!
+   element-margin-top
+   element-set-margin-top!
+   element-margin-bottom
+   element-set-margin-bottom!
+   element-margin-left
+   element-set-margin-left!
+   element-margin-right
+   element-set-margin-right!
+   element-padding-top
+   element-set-padding-top!
+   element-padding-bottom
+   element-set-padding-bottom!
+   element-padding-left
+   element-set-padding-left!
+   element-padding-right
+   element-set-padding-right!
+   element-border-top-color
+   element-set-border-top-color!
+   element-border-bottom-color
+   element-set-border-bottom-color!
+   element-border-left-color
+   element-set-border-left-color!
+   element-border-right-color
+   element-set-border-right-color!
+   element-border-top-width
+   element-set-border-top-width!
+   element-border-bottom-width
+   element-set-border-bottom-width!
+   element-border-left-width
+   element-set-border-left-width!
+   element-border-right-width
+   element-set-border-right-width!
+   element-width
+   element-set-width!
+   element-height
+   element-set-height!
+   element-top
+   element-set-top!
+   element-left
+   element-set-left!
+   element-z-index
+   element-set-z-index!
+   event?
+   get-event
+   event-tag
+   event-id
+   event-from-tag
+   event-from-id
+   event-to-tag
+   event-to-id
+   event-keycode
+   event-shiftkey
+   event-ctrlkey
+   event-altkey
+   event-x
+   event-y
+   event-keypress?
+   event-keydown?
+   event-keyup?
+   event-mousedown?
+   event-mousemove?
+   event-mouseover?
+   event-mouseout?
+   event-mouseup?
+   event-click?
+   event-dblclick?
+   event-error?
+   block-until-event
+   process-win-events
+   com-omit))
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/collects/mysterx/private/properties.ss b/collects/mysterx/private/properties.ss
new file mode 100644
index 0000000000..6b5dfcd6d1
--- /dev/null
+++ b/collects/mysterx/private/properties.ss
@@ -0,0 +1,319 @@
+;; properties.ss
+
+(module properties mzscheme
+  (require (lib "list.ss"))	
+
+  (provide
+   *css-units*
+   *background-attachments*
+   *background-repeats*
+   *text-transforms*
+   *text-aligns*
+   *border-widths*
+   *border-styles*
+   *displays*
+   *font-styles*
+   *font-variants*
+   *font-sizes* 
+   *style-floats*
+   *clears*
+   *horizontals*
+   *verticals* 
+   *decorations*
+   *visibilities*
+   *list-style-types*
+   *list-style-positions*
+   *positions*
+   *overflows*
+   *page-breaks*
+   *cursors*
+   *html-colors*
+   *filters-and-official-names*
+   *official-names-and-filters*
+   *filters*
+   *filter-official-names* 
+   *filter-re*
+   *alpha-filter-styles*
+   *trans-filter-statuses*
+   *filter-directions*
+   *reveal-transitions*
+   *vertical-aligns* 
+   decoration?
+   horizontal?
+   vertical?
+   font-size?
+   style-float?
+   clear?
+   display?
+   visibility?
+   list-style-type?
+   list-style-position? 
+   position?
+   overflow?
+   pagebreak?
+   cursor?
+   filter?
+   alpha-filter-style?
+   trans-filter-status? 
+   filter-direction?
+   reveal-transition? 
+   vertical-align?
+   css-unit?
+   border-style?)
+
+  (define *css-units* '(em ex cm mm in pt pc px))
+  (define *background-attachments* '(fixed scroll))
+  (define *background-repeats* '(no-repeat repeat repeat-x repeat-y))
+  (define *text-transforms* '(none capitalize uppercase lowercase))
+  (define *text-aligns* '(left right center justify))
+  (define *border-widths* '(medium thin thick))
+  (define *border-styles* '(none dotted dashed solid double groove 
+				 ridge inset outset))
+  (define *displays* '(block none inline list-item 
+			     table-header-group table-footer-group)) 
+  (define *generic-font-families* '(serif sans-serif cursive 
+					  fantasy monospace))
+  (define *font-styles* '(normal italic oblique))
+  (define *font-variants* '(normal small-caps))
+  (define *font-sizes* '(xx-small x-small small medium large 
+				  x-large xx-large
+				  larger smaller))
+  (define *style-floats* '(none left right))
+  (define *clears* '(none left right both)) 
+  (define *horizontals* '(left center right))
+  (define *verticals* '(top center bottom))
+  (define *decorations* '(none underline overline line-through blink))
+  (define *visibilities* '(inherit visible hidden))
+  (define *list-style-types* '(disc circle square decimal lower-roman 
+				    upper-roman lower-alpha upper-alpha none)) 
+  (define *list-style-positions* '(outside inside))
+  (define *positions* '(static absolute relative))
+  (define *overflows* '(visible scroll hidden auto))
+  (define *page-breaks* '(always auto none))
+  (define *cursors* '(auto crosshair default hand move 
+			   n-resize ne-resize nw-resize s-resize 
+			   se-resize sw-resize e-resize w-resize 
+			   text wait help)) 
+  (define *html-colors*
+    '(aliceblue
+      antiquewhite
+      aqua
+      aquamarine
+      azure
+      beige
+      bisque
+      black
+      blanchedalmond
+      blue
+      blueviolet
+      brown
+      burlywood
+      cadetblue
+      chartreuse
+      chocolate
+      coral
+      cornflower
+      cornsilk
+      crimson
+      cyan
+      darkblue
+      darkcyan
+      darkgoldenrod
+      darkgray
+      darkgreen
+      darkkhaki
+      darkmagenta
+      darkolivegreen
+      darkorange
+      darkorchid
+      darkred
+      darksalmon
+      darkseagreen
+      darkslateblue
+      darkslategray
+      darkturquoise
+      darkviolet
+      deeppink
+      deepskyblue
+      dimgray
+      dodgerblue
+      firebrick
+      floralwhite
+      forestgreen
+      fuchsia
+      gainsboro
+      ghostwhite
+      gold
+      goldenrod
+      gray
+      green
+      greenyellow
+      honeydew
+      hotpink
+      indianred
+      indigo
+      ivory
+      khaki
+      lavender
+      lavenderblush
+      lawngreen
+      lemonchiffon
+      lightblue
+      lightcoral
+      lightcyan
+      lightgoldenrodyellow
+      lightgreen
+      lightgray
+      lightpink
+      lightsalmon
+      lightseagreen
+      lightskyblue
+      lightslategray
+      lightsteelblue
+      lightyellow
+      lime
+      limegreen
+      linen
+      magenta
+      maroon
+      mediumaquamarine
+      mediumblue
+      mediumorchid
+      mediumpurple
+      mediumseagreen
+      mediumslateblue
+      mediumspringgreen
+      mediumturquoise
+      mediumvioletred
+      midnightblue
+      mintcream
+      mistyrose
+      moccasin
+      navajowhite
+      navy
+      oldlace
+      olive
+      olivedrab
+      orange
+      orangered
+      orchid
+      palegoldenrod
+      palegreen
+      paleturquoise
+      palevioletred
+      papayawhip
+      peachpuff
+      peru
+      pink
+      plum
+      powderblue
+      purple
+      red
+      rosybrown
+      royalblue
+      saddlebrown
+      salmon
+      sandybrown
+      seagreen
+      seashell
+      sienna
+      silver
+      skyblue
+      slateblue
+      slategray
+      snow
+      springgreen
+      steelblue
+      tan
+      teal
+      thistle
+      tomato
+      turquoise
+      violet
+      wheat
+      white
+      whitesmoke
+      yellow
+      yellowgreen))
+  (define *filters-and-official-names*
+    '((alpha alpha)
+      (blend-trans blendTrans)
+      (blur blur)
+      (chroma chroma)
+      (drop-shadow dropShadow)
+      (flip-horizontal flipH)
+      (flip-vertical flipV)
+      (glow glow)
+      (gray gray)
+      (invert invert)
+      (light light)
+      (mask mask)
+      (redirect redirect)
+      (reveal-trans revealTrans)
+      (shadow shadow)
+      (wave wave)
+      (x-ray xray)))
+  (define *official-names-and-filters*
+    (map (lambda (flt) (list (cadr flt)
+			     (car flt)))
+	 *filters-and-official-names*))
+  (define *filters* (map car *filters-and-official-names*))
+  (define *filter-official-names* (map cadr *filters-and-official-names*))
+  (define *filter-re*
+    (regexp (foldr (lambda (s t) 
+		     (if (> (string-length t) 0) 
+			 (string-append s "|" t) 
+			 s)) "" 
+			 (map symbol->string *filter-official-names*))))
+  (define *alpha-filter-styles*
+    '(uniform linear radial rectangular))
+  (define *trans-filter-statuses*
+    '(stopped applied playing))
+  (define *filter-directions*
+    '(0 45 90 135 180 225 270 315))
+  (define *reveal-transitions*
+    '(box-in box-out circle-in circle-out
+      wipe-up wipe-down wipe-right wipe-left
+      vertical-blinds horizontal-blinds checkerboard-across
+      checkerboard-down random-dissolve split-vertical-in 
+      split-vertical-out split-horizontal-in split-horizontal-out
+      strips-left-down strips-left-up strips-right-down
+      strips-right-up random-bars-horizontal random-bars-vertical
+      random))
+  (define *vertical-aligns* 
+    '(baseline sub super top middle bottom text-top text-bottom ))
+
+  ; predicates based on membership in symbol lists
+
+  (define (make-sym-pred lst)
+    (lambda (s)
+      (memq s lst)))
+
+  (define decoration? (make-sym-pred *decorations*))
+  (define horizontal? (make-sym-pred *horizontals*))
+  (define vertical? (make-sym-pred *verticals*))
+  (define generic-font-family? (make-sym-pred *generic-font-families*))
+  (define font-size? (make-sym-pred *font-sizes*))
+  (define style-float? (make-sym-pred *style-floats*))
+  (define clear? (make-sym-pred *clears*))
+  (define display? (make-sym-pred *displays*))
+  (define visibility? (make-sym-pred *visibilities*))
+  (define list-style-type? (make-sym-pred *list-style-types*))
+  (define list-style-position? (make-sym-pred *list-style-positions*))
+  (define position? (make-sym-pred *positions*))
+  (define overflow? (make-sym-pred *overflows*))
+  (define pagebreak? (make-sym-pred *page-breaks*))
+  (define cursor? (make-sym-pred *cursors*))
+  (define filter? (make-sym-pred *filters*))
+  (define alpha-filter-style? (make-sym-pred *alpha-filter-styles*))
+  (define trans-filter-status? 
+    (make-sym-pred *trans-filter-statuses*))
+  (define filter-direction? (make-sym-pred *filter-directions*))
+  (define reveal-transition? (make-sym-pred *reveal-transitions*))
+  (define vertical-align? (make-sym-pred *vertical-aligns*))
+  (define css-unit? (make-sym-pred *css-units*))
+  (define border-style? (make-sym-pred *border-styles*)))
+
+
+
+
diff --git a/collects/mysterx/private/style.ss b/collects/mysterx/private/style.ss
new file mode 100644
index 0000000000..ca2c0db6aa
--- /dev/null
+++ b/collects/mysterx/private/style.ss
@@ -0,0 +1,654 @@
+;;; style.ss 
+
+(module style mzscheme
+  (require (lib "string.ss"))
+  (require "util.ss")
+  (require "properties.ss")
+
+  (provide
+   make-css-percentage
+   css-percentage?
+   css-percentage-num
+   make-css-length
+   css-length?
+   css-length-num
+   css-length-units
+   font-families->string
+   string->font-families
+   string->font-size
+   valid-css-length?
+   css-length->string
+   percentage-or-length?
+   percentage-or-length->string
+   make-bg-pos-getter	
+   make-bg-pos-setter	
+   make-element-getter
+   make-element-setter
+   make-pagebreak-getter
+   make-pagebreak-setter
+   list->background-position
+   border-width?
+   border-style->string
+   border-width->string
+   border->string
+   border-items->string
+   set-border-with-fun
+   string->border-item
+   make-border-getter
+   make-border-style-getter
+   make-border-style-setter
+   make-border-width-getter
+   make-border-width-setter
+   string->html-color
+   html-color->string
+   make-color-getter
+   make-color-setter
+   make-css-getter
+   make-css-setter
+   make-const-or-css-getter-maker
+   make-normal-or-css-getter
+   make-auto-or-css-getter
+   make-const-or-css-setter-maker
+   make-normal-or-css-setter
+   make-auto-or-css-setter
+   parse-string
+   parse-decoration
+   validated-string->symbols
+   string->list-style-item
+   list-style-item->string
+   string->background-position
+   string->margin
+   margin->string
+   string->padding
+   padding->string
+   url->string
+   string->url
+   clip-rect?
+   clip-rect->symbols)
+
+  (define-struct css-percentage (num))
+  (define-struct css-length (num units))
+
+  (define font-family->string
+    (lambda (ff)
+      (if (regexp-match ".* .*" ff)  ; contains a space
+	  (string-append "\"" ff "\"")
+	  ff)))
+
+  (define font-families->string
+    (lambda (ffs)
+      (let loop ([ffs ffs])
+	(cond 
+	 [(null? ffs) 
+	  ""]
+	 [(null? (cdr ffs))
+	  (font-family->string (car ffs))]
+	 [else 
+	  (string-append (font-family->string (car ffs))
+			 ","
+			 (loop (cdr ffs)))]))))
+
+   (define string->font-families
+    (lambda (s)
+      (let ([lst (string->list s)]
+	    [build-curr 
+	     (lambda (cs)
+	       (list->string (reverse (remove-ws cs))))])
+	(let loop ([lst lst]
+		   [curr '()])
+          (cond
+	   [(null? lst) 
+	    (if (null? curr)
+		'()
+		(list (build-curr curr)))]
+	   [(char-ci=? #\, (car lst))
+            ; strip leading whitespace
+	    ; start on new current word
+	    (let ([tail (loop (remove-ws (cdr lst)) '())])
+	      (if (null? curr)
+		  tail
+		  (cons (build-curr curr) tail)))]
+	   [(member (car lst) '(#\" #\')) ; strip quotes
+	    (loop (cdr lst) curr)]
+	   [else
+	    (loop (cdr lst) (cons (car lst) curr))])))))
+
+  (define (string->font-size s)
+    (let ([sym (string->symbol s)])
+      (cond
+       [(font-size? sym) sym]
+       [(parse-css-length (string->list s)) => 
+	(lambda (val-rest) (car val-rest))] 
+       [else s])))
+
+   (define (valid-css-length? elt)
+     (and (css-length? elt)
+	  (exact? (css-length-num elt))
+	  (css-unit? (css-length-units elt))))
+
+   (define (css-length->string elt)
+     (string-append (number->string (css-length-num elt))
+		    (symbol->string (css-length-units elt))))
+
+   (define percentage-or-length?
+     (lambda (elt)
+	(or (and (css-percentage? elt)
+		 (exact? (css-percentage-num elt)))
+	    (and (valid-css-length? elt)))))
+
+   (define percentage-or-length->string
+     (lambda (elt)
+       (cond
+	[(css-length? elt)
+	 (css-length->string elt)]
+	[(css-percentage? elt)
+	 (string-append (number->string (css-percentage-num elt)) "%")]
+	[else
+	 (error "Not a CSS percentage or length: ~a" elt)])))
+
+   (define (make-bg-pos-getter elt f fname)
+     (lambda ()
+       (let ([pos (f elt)])
+	 (when (empty-string? pos)
+	       (empty-property-error fname))
+	    (car (list->background-position (string->list pos))))))
+
+   (define (make-bg-pos-setter elt f pred? elts coord) 
+     (lambda (pos)
+       (cond
+	[(pred? pos)
+	 (f elt (symbol->string pos))]
+	[(percentage-or-length? pos)
+	 (f elt (percentage-or-length->string pos))]
+	[else 
+	 (error 
+	  (format
+	   (string-append 
+	    "set-background-position-~a!: "
+	    "Expected value in ~a, "
+	    "CSS length, or CSS percentage, "
+	    "got ~a") 
+	   coord elts pos))])))
+
+   (define (make-element-getter elt getter name)
+     (lambda ()
+       (let ([s (getter elt)])
+	 (if (empty-string? s)
+	     (empty-property-error name)
+	     (string->symbol s)))))
+
+   (define (make-element-setter elt pred? props f!)
+     (lambda (s)
+       (unless (pred? s)
+	       (error 
+		(format "Expected element of ~a, got: ~a"
+			props s)))
+       (f! elt (symbol->string s))))
+
+   (define (make-pagebreak-getter elt f)       
+     (lambda ()
+       (let ([s (f elt)])
+	 (if (empty-string? s)
+	     'none
+	     (string->symbol s)))))
+
+   (define (make-pagebreak-setter elt f! name) 
+     (lambda (s)
+       (unless (pagebreak? s)
+	       (error
+		(format "~a: Expected element of ~a, got: ~a"
+			name *page-breaks* s)))
+       (let ([str (if (eq? s 'none)
+		      ""
+		      (symbol->string s))])
+	 (f! elt str))))
+
+   (define (border-width? elt)
+     (or (memq elt *border-widths*)
+	 (valid-css-length? elt)))
+
+   (define border-style->string symbol->string)
+
+   (define (border-width->string elt)
+     (if (css-length? elt)
+	 (css-length->string elt)
+	 (symbol->string elt)))
+
+   (define (border->string elt)
+     (cond 
+      [(border-width? elt)
+       (border-width->string elt)]
+      [(border-style? elt)
+       (border-style->string elt)]
+      [(html-color? elt)
+       (html-color->string elt)]))
+
+   (define (border-items->string elts)
+     (fold-strings-with-spaces (map border->string elts)))
+
+   (define (set-border-with-fun elt cs f) 
+     (for-each
+      (lambda (c)
+	(unless (or (border-width? c)
+		    (border-style? c)
+		    (html-color? c))
+		(error 
+		 (format 
+		  (string-append 
+		   "set-border!: expected nonempty list where each "
+		   "element is either "
+		   "a border width (one of '~a, or a CSS length), " 
+		   "a border style (one of '~a, or "
+		   "an HTML color, got ~a")
+		  *border-widths*
+		  *border-styles*
+		  c))))
+      cs)
+     (f elt (border-items->string cs)))
+
+   (define (string->border-item s)
+     (let ([sym (string->symbol s)])
+       (cond
+       ;color
+	[(memq sym *html-colors*)
+	 sym]
+	[(hex-digit-string? s)
+	 s]
+       ;style
+	[(memq sym *border-styles*)
+	 sym]
+       ;width
+	[(memq sym *border-widths*)
+	 sym]
+	[(parse-css-length (string->list s)) => car]
+       ;error
+	[else 
+	 (error (format "Expected border item, got: ~a" s))])))
+
+   (define (string->border-list s)
+     (map string->border-item (parse-string s)))
+
+   (define (make-border-getter elt f name)
+     (lambda ()
+       (let ([s (f elt)])
+	 (if (empty-string? s)
+	     (empty-property-error name)
+	     (string->border-list s)))))
+
+   (define (make-border-style-getter elt f name)
+     (lambda ()
+       (let ([s (f elt)])
+	 (if (empty-string? s)
+	     (empty-property-error name)
+	     (string->border-item s)))))
+     
+   (define (make-border-style-setter elt f name)
+     (lambda (s)
+       (unless (border-style? s)
+	       (error 
+		(format "~a: Expected element of ~a, got ~a"
+			name *border-styles* s)))
+       (f elt (border-style->string s))))
+
+   (define (make-border-width-getter elt f name)
+     (lambda ()
+       (let ([s (f elt)])
+	 (if (empty-string? s)
+	     (empty-property-error name)
+	     (string->border-item s)))))
+     
+   (define (make-border-width-setter elt f name)
+     (lambda (s)
+       (unless (border-width? s)
+	       (error 
+		(format "~a: Expected element of ~a or CSS length, got ~a"
+			name *border-widths* s)))
+       (f elt (border->string s))))
+
+   (define (string->html-color s)
+     (if (char=? (string-ref s 0) #\#)
+	 s
+	 (string->symbol s)))
+
+   (define (html-color->string s)
+     (if (symbol? s)
+	 (symbol->string s)
+	 s))
+
+   (define (make-color-getter elt f name)
+     (lambda ()
+       (let ([s (f elt)])
+	 (if (empty-string? s)
+	     (empty-property-error name)
+	     (string->html-color s)))))
+
+   (define (make-color-setter elt f name)
+     (lambda (s)
+       (unless 
+	(html-color? s)
+	(error 
+	 (format "~a: Expected HTML color, got: ~a"
+		 name s)))
+       (f elt (html-color->string s))))
+
+  (define (make-css-getter elt f fname)
+    (lambda ()
+      (let ([s (f elt)])
+	(when (empty-string? s)
+	      (empty-property-error fname))
+        (cond
+	 [(parse-css-length (string->list s)) => car]
+	 [else s]))))
+
+  (define (make-css-setter elt f fname)
+    (lambda (css)
+      (let ([s (cond
+		[(percentage-or-length? css)
+		 (percentage-or-length->string css)]
+		[else 
+		 (error 
+		  (string-append 
+		   fname ": Expected "
+		   "CSS length or percentage, got")
+		  css)])])
+	(f elt s))))
+
+  (define (make-const-or-css-getter-maker c)
+    (lambda (elt f fname)
+      (lambda ()
+	(let ([s (f elt)])
+	  (when (empty-string? s)
+		(empty-property-error fname))
+	     (cond 
+	      [(string=? (symbol->string c) s) c] 
+	      [(parse-css-length (string->list s)) => car]
+	      [else s])))))
+
+  (define make-normal-or-css-getter
+    (make-const-or-css-getter-maker 'normal))
+
+  (define make-auto-or-css-getter 
+    (make-const-or-css-getter-maker 'auto))
+
+  (define (make-const-or-css-setter-maker c)
+    (lambda (elt f fname)
+      (lambda (v)
+	(let ([s (cond
+		  [(eq? v c) (symbol->string c)]
+		  [(percentage-or-length? v)
+		   (percentage-or-length->string v)]
+		  [else 
+		   (error 
+		    (string-append 
+		     fname ": Expected 'normal, "
+		     "CSS length or percentage, got")
+		    v)])])
+	  (f elt s)))))
+
+  (define make-normal-or-css-setter
+    (make-const-or-css-setter-maker 'normal))
+
+  (define make-auto-or-css-setter 
+    (make-const-or-css-setter-maker 'auto))
+
+  (define (html-color? s)
+    (or (hex-color-string? s)
+	(memq s *html-colors*)))
+
+  (define parse-number ; returns number, rest of list
+    (lambda (lst)
+      (let loop ([num? #f]
+		 [seen-dot #f]
+		 [digits '()]
+		 [lst lst])
+	(let ([c (car lst)])
+	  (cond
+	   [(char-numeric? c) 
+	    (loop #t seen-dot (cons c digits) (cdr lst))]
+	   [(eq? c #\.)
+	    (if seen-dot
+		(error "More than one period in number")
+		(loop #t #t (cons c digits) (cdr lst)))]
+	   [else
+	    (if num? 
+		(cons (string->number 
+		       (list->string (reverse digits))) lst)
+		#f)])))))
+
+   ; (listof char) -> (cons symbol (listof char))
+   (define parse-units ; returns unit symbol, rest of list
+     (lambda (lst)
+       (let* ([sym-rest
+	       (let loop ([word '()]
+			  [lst lst])
+		 (cond 
+		  [(or (null? lst) (char-whitespace? (car lst)))
+		   (cons (string->symbol (list->string (reverse word)))
+			 lst)]
+		  [else
+		   (loop (cons (car lst) word) (cdr lst))]))]
+	      [sym (car sym-rest)]
+	      [rst (cdr sym-rest)])
+	 (if (or (eq? sym '%) (css-unit? sym))
+	     (cons sym rst)
+	     (error "Unable to parse units")))))
+
+   ; (listof symbols) -> (listof char) -> (union #f (listof symbol))
+   (define make-words-parser 
+     (lambda (syms)
+       (lambda (lst)
+	 (let loop ([word '()]
+		    [lst lst])
+	   (cond 
+	    [(or (null? lst)
+		 (char-whitespace? (car lst)))
+	     (let ([sym (string->symbol (list->string (reverse word)))])
+	       (if (memq sym syms)
+		   (cons sym lst)
+		   #f))]
+	    [else
+	     (loop (cons (car lst) word) (cdr lst))])))))
+
+   (define parse-horizontal 
+     (make-words-parser *horizontals*))
+
+   (define parse-vertical
+     (make-words-parser *verticals*))
+
+   (define parse-string ; string -> (listof string)
+     (lambda (s)
+       (let ([tack-on-word 
+	      (lambda (word words)
+		(if (null? word)
+		    words
+		    (cons (list->string (reverse word)) words)))])
+	 (let loop ([word '()]
+		    [words '()]
+		    [lst (string->list s)])
+	   (cond 
+	    [(null? lst)
+	     (reverse (tack-on-word word words))]
+	    [(char-whitespace? (car lst))
+	     (loop '() (tack-on-word word words) (cdr lst))]
+	    [else
+	     (loop (cons (car lst) word) words (cdr lst))])))))
+
+   (define (parse-css-length lst)
+     (cond 
+      [(parse-number lst) =>
+       (lambda (num-rest)
+	 (let ([num (car num-rest)]
+	       [rst (cdr num-rest)])
+	   (cond 
+	    [(parse-units rst) =>
+	     (lambda (unit-rest)
+	       (let* ([units (car unit-rest)]
+		      [val (if (eq? units '%)
+			       (make-css-percentage num)
+			       (make-css-length num units))])
+		 (cons val (cdr unit-rest))))]
+	    [else #f])))]
+      [else #f]))
+
+   (define parse-decoration
+     (make-words-parser *decorations*))
+
+   (define validated-string->symbols
+     (lambda (s funname parser)
+       (if (empty-string? s)
+	   (empty-property-error funname)
+	   (let ([lst (string->list s)])
+	     (let loop ([lst lst]
+			[words '()])
+	       (let ([word-rest (parser lst)])
+		 (if word-rest
+		     (loop (remove-ws (cdr word-rest)) 
+			   (cons (car word-rest) words))
+		     (reverse words))))))))
+
+   (define (string->list-style-item s)
+     (if (string-ci=? (substring s 0 4) "url(")
+	 (url->string s)
+	 (let ([sym (string->symbol s)])
+	   (if (or (list-style-type? sym)
+		   (list-style-position? sym))
+	       sym
+	       (error (format "Expected list-style item, got: ~a"
+			      s))))))
+
+  (define (list-style-item->string s) 
+     (cond
+      [(or (list-style-type? s)
+	   (list-style-position? s))
+       (symbol->string s)]
+      [(string? s)
+       (string->url s)]
+      [else 
+       (error 
+	(format "Expected list-style item, got: ~a"))]))
+
+   (define string->background-position
+     (lambda (s)
+       (let ([bp (list->background-position (string->list s))])
+	 (case (length bp)
+	   [(1) (car bp)]
+	   [(2) bp]
+	   [else "Invalid background position"]))))
+
+   (define list->background-position
+     (lambda (lst)
+       (cond
+	[(null? lst) '()]
+	[(parse-css-length lst) =>
+	 (lambda (val-rest)
+	   (cons (car val-rest)
+		 (list->background-position 
+		  (remove-ws (cdr val-rest)))))]
+	[(parse-horizontal lst) =>
+	 (lambda (x-rest)
+	   (cons (car x-rest)
+		 (list->background-position (remove-ws (cdr x-rest)))))]
+	[(parse-vertical lst) =>
+	 (lambda (y-rest)
+	   (cons (car y-rest)
+		 (list->background-position (remove-ws (cdr y-rest)))))]
+	[else
+	 (error "Can't parse background-position")])))
+
+  (define (make-css-parser loop lst)
+    (lambda (num-rest)
+      (let ([num (car num-rest)]
+	    [rst (cdr num-rest)])
+	(let* ([unit-rest (parse-units rst)]
+	       [units (car unit-rest)]
+	       [the-val (if (eq? units '%)
+			    (make-css-percentage num)
+			    (make-css-length num units))])
+	  (cons the-val (loop (cdr lst)))))))
+
+  (define string->margin
+     (lambda (s)
+       (let loop ([lst (parse-string s)])
+	 (when (> (length lst) 4)
+	       (error "Only four margin values allowed, got" s))
+	 (cond
+	  [(null? lst)
+	   '()]
+	  [(string=? (car lst) "auto")
+	   (cons 'auto (loop (cdr lst)))]
+	  [(parse-number (string->list (car lst))) =>
+	   (make-css-parser loop lst)]
+	  [else
+	   (error (string-append 
+		   "Expected margin string with up to four of "
+		   "CSS length, CSS percentage, or auto.  Got")
+		   s)]))))
+
+  (define string->padding
+     (lambda (s)
+       (let loop ([lst (parse-string s)])
+	 (when (> (length lst) 4)
+	       (error "Only four padding values allowed, got" s))
+	 (cond
+	  [(null? lst)
+	   '()]
+	  [(parse-number (string->list (car lst))) =>
+	   (make-css-parser loop lst)]
+	  [else
+	   (error (string-append 
+		   "Expected padding string with up to four of "
+		   "CSS lengths or CSS percentages.  Got")
+		   s)]))))
+
+  (define string->percentage-or-length
+    (lambda (s)
+      (let ([lst (string->list s)])
+	  (cond
+	   [(parse-number (string->list (car lst))) =>
+	    (lambda (num-rest)
+	      (let ([num (car num-rest)]
+		    [rst (cdr num-rest)])
+		(let* ([unit-rest (parse-units rst)]
+		       [units (car unit-rest)]
+		       [the-val (if (eq? units '%)
+				    (make-css-percentage num)
+				    (make-css-length num units))])
+		 the-val)))]
+	   [else
+	    (error "Expected string with percentage or length, got ~a"
+		   s)]))))
+
+  (define margin-item->string
+    (lambda (item)
+      (cond 
+       [(eq? item 'auto)
+	"auto"]
+       [else 
+	(percentage-or-length->string item)])))
+
+  (define margin->string
+    (map-to-string margin-item->string)) 
+
+  (define padding->string
+    (map-to-string percentage-or-length->string))
+
+  (define (url->string s)
+    ; "url(foo)" -> "foo"
+    (substring s 4 (sub1 (string-length s))))
+
+  (define (string->url s)
+    ; ""foo" -> url(foo)"
+    (string-append "url(" s ")"))
+
+  (define (clip-rect? s)
+    (string-ci=? 
+     (substring s 0 5) "rect("))
+
+  (define (clip-rect->symbols s)
+    (map (lambda (s)
+	   (if (string=? s "auto") 
+	       'auto
+	       (car (parse-css-length (string->list s)))))
+	 (parse-string (substring s 5 (sub1 (string-length s)))))))
+
+
diff --git a/collects/mysterx/private/util.ss b/collects/mysterx/private/util.ss
new file mode 100644
index 0000000000..6cc2b3d97f
--- /dev/null
+++ b/collects/mysterx/private/util.ss
@@ -0,0 +1,101 @@
+;;; util.ss -- utility procedures for MysterX
+
+(module util mzscheme
+  (require (lib "unitsig.ss"))
+  (require (lib "list.ss"))	   
+
+  (provide 
+   fold-strings-with-spaces
+   map-to-string
+   empty-string?
+   bool->string
+   exact-with-bounds?
+   list-pos
+   remove-ws
+   symbols->string
+   hex-digit-string?
+   hex-color-string?
+   empty-property-error)
+  
+  (define (fold-strings-with-spaces strs)
+    (foldr (lambda (s accum) 
+	     (if (string? accum)
+		 (string-append s " " accum)
+		 s))
+	     'dummy
+	     strs))
+
+  (define (map-to-string f)
+    (lambda (lst)
+    (let loop ([lst lst])
+      (cond
+       [(null? lst) ""]
+       [(null? (cdr lst))
+	(f (car lst))]
+       [else
+	(string-append (f (car lst)) 
+		       " "
+		       (loop (cdr lst)))]))))
+
+  (define empty-string?
+    (lambda (s)
+      (and (string? s) 
+	   (eq? (string-length s) 0))))
+
+  (define (bool->string v)
+    (if v
+	"true"
+	"false"))
+
+  (define (exact-with-bounds? n lo hi)
+	(and (number? n)
+	     (exact? n)
+	     (>= n lo)
+	     (<= n hi)))
+
+  (define (list-pos v lst)
+    (let loop ([lst lst]
+	       [n 0])
+      (if (eq? v (car lst))
+	  n
+	  (loop (cdr lst) (add1 n)))))
+   
+  (define remove-ws ; remove leading whitespace
+    (lambda (cs)
+      (cond [(null? cs) '()]
+	    [(char-whitespace? (car cs))
+	     (remove-ws (cdr cs))]
+	    [else cs])))
+
+  (define symbols->string ; '(a b c ...) => "a b c ..."
+    (lambda (syms)
+      (cond [(null? syms) ""]
+	    [(null? (cdr syms))
+	     (symbol->string (car syms))]
+	    [else
+	     (string-append (symbol->string (car syms))
+			    " "
+			    (symbols->string (cdr syms)))])))
+
+  (define (hex-digit-string? elt)
+    (let ([lst (string->list elt)]
+	  [hex-digit? 
+	   (lambda (c)
+	     (or (char-numeric? c)
+		 (memq c '(#\a #\b #\c #\d #\e #\f 
+			   #\A #\B #\C #\D #\E #\F))))])
+      (and (= (length lst) 7)
+	   (eq? (car lst) #\#)
+	   (andmap hex-digit? (cdr lst)))))
+
+  (define (hex-color-string? s)
+    (and (string? s)
+	 (hex-digit-string? s)))
+
+  (define empty-property-error
+     (lambda (p)
+       (error (format "Empty value for property ~a" p)))))
+
+
+
+
diff --git a/collects/mzcom/doc.txt b/collects/mzcom/doc.txt
new file mode 100644
index 0000000000..ab5e26f532
--- /dev/null
+++ b/collects/mzcom/doc.txt
@@ -0,0 +1,189 @@
+_MzCOM_
+=======
+
+This directory contains the files for MzCOM, a COM 
+class wrapper for MzScheme.
+
+The code is in the file mzcom.exe.  During normal
+installation of MzCOM from the file mzcom.plt, the
+executable is registered automatically.  You can 
+move the .exe to whatever location you like, but
+you'll need to re-register it.  From the command
+line, run
+
+  mzcom.exe /RegServer
+
+If you move mzcom.exe, you'll also need to set the Windows 
+environment variables PLTHOME or PLTCOLLECTS for 
+MzCOM to find collections.  
+
+The mzcom.exe executable also requires the dynamic 
+libraries libmzsch<version>.dll and libmzgc<version>.dll.
+Those files must be in your PATH.  If you have DrScheme 
+installed, those files are in the System32 subdirectory of the 
+main Windows directory, which is in the default Windows PATH.
+
+Loading MzCOM
+-------------
+
+To load a COM object, COM hosts require a COM class 
+name or a ProgID.  MzCOM has the class name 
+"MzObj Class" and the ProgID "MzCOM.MzObj.<version>",
+where <version> is the version number, such as 200.
+
+In the Visual BASIC 6 environment, from the menu 
+Project|References (VB6), check "MzCOM 1.0 Type Library".  
+In Visual BASIC .NET, choose Project|Add Reference,
+and from the COM tab, select "MzCOM 1.0 Type Library".
+In your code, declare a variable, then assign to it:
+
+  DIM schemeObject AS MzObj
+  SET schemeObject = NEW MzObj
+
+From Visual C++:
+
+ #include "mzcom.h" 
+     
+ CLSID clsid;
+ IMzObj *pIMzObj;
+
+ CoInitialize(NULL);
+ CLSIDFromProgID(L"MzCOM.MzObj.<version>",&clsid);
+ CoCreateInstance(clsid,NULL,CLSCTX_SERVER,IID_IMzObj,
+                        (void **)&pIMzObj);
+
+where <version> is the version number.  You'll need the 
+definition of IID_IMzObj (see GUID's, below).  The header 
+file mzcom.h is in plt\src\worksp\mzcom\. This C/C++ code 
+is for illustration.  Of course, your actual code should 
+check return values.  
+
+Using PLT's MysterX, available at 
+
+  http://www.plt-scheme.org/software/mysterx/
+
+you can load MzCOM with either
+
+  (cci/coclass "MzObj Class")
+
+or
+
+  (cci/progid "MzCOM.MzObj.<version>")
+
+Consult your documentation for loading MzCOM into other
+COM environments.  MzCOM is compiled as a "dual-mode"
+class, meaning its methods may be called directly or by
+using OLE Automation.
+
+GUID's
+------
+
+When compiled, the directory
+
+  plt\src\worksp\mzcom\
+
+contains the file MzCOM_i.c that contains GUID's for MzCOM.
+Those GUID's are
+
+  const IID IID_IMzObj = 
+    {0xA604CBA8,0x2AB5,0x11D4,{0xB6,0xD3,0x00,0x60,0x08,0x90,0x02,0xFE}};
+
+  const IID LIBID_MZCOMLib = 
+    {0xA604CB9C,0x2AB5,0x11D4,{0xB6,0xD3,0x00,0x60,0x08,0x90,0x02,0xFE}};
+
+  const IID DIID__IMzObjEvents = 
+    {0xA604CBA9,0x2AB5,0x11D4,{0xB6,0xD3,0x00,0x60,0x08,0x90,0x02,0xFE}};
+
+  const CLSID CLSID_MzObj = 
+    {0xA3B0AF9E,0x2AB0,0x11D4,{0xB6,0xD2,0x00,0x60,0x08,0x90,0x02,0xFE}};
+
+which represent the IMzObj interface, the MzCOM type library,
+the IMzObjEvents interface, and the MzObj class, respectively.
+
+Methods
+-------
+
+MzCOM has three methods.
+
+> About :: void About(void)
+
+About() takes no arguments and displays an informational 
+dialog.
+
+> Eval :: BSTR Eval(BSTR input)
+
+Eval() takes and returns BSTR's (BASIC strings).  The
+returned value is the result of evaluating the input
+expression, formatted as a string.  The input string
+may contain several S-expressions.  The embedded MzScheme
+updates its environment with each evaluation.  Therefore,
+it is possible to define procedures in a call to 
+Eval(), and use the procedures in subsequent calls.
+
+> Reset :: void Reset(void)
+
+Reset() resets the Scheme environment to the 
+initial environment.  Also, the custodian for the 
+primary Scheme thread is invoked, shutting 
+all its managed values.
+
+Events
+------
+
+MzCOM has a single event.
+
+> SchemeError()
+
+The SchemeError() event is passed a BSTR (BASIC string)
+that explains the error.  
+
+Errors
+------
+
+When an error occurs in MzCOM, it creates a COM
+error object.  C and C++ clients can use GetErrorInfo()
+to retrieve error information.  Clients implemented 
+in other languages typically have some equivalent means 
+to obtain COM error information.
+
+Collections
+-----------
+
+If mzcom.exe is installed to its default location,
+MzCOM is able to find other PLT collections. 
+When setting up the collection paths, MzCOM adds 
+the variable
+
+> mzcom-exe
+
+to the global environment.  That variable is bound 
+to a string containing the full pathname for mzcom.exe.
+
+If mzcom.exe is moved to another location, you should 
+set either the PLTHOME or PLTCOLLECTS environment 
+variables before loading MzCOM.
+
+Evaluation thread
+-----------------
+
+The MzScheme evaluator runs in a Win32 thread created
+when MzCOM is loaded.  If an expression kills the 
+primary MzScheme thread, as in 
+
+  (kill-thread (current-thread))
+
+then the evaluator Win32 thread is also killed.  
+When that happens, subsequent calls to Eval() will fail.
+
+Contact us
+----------
+
+If you need more information on using MzCOM, please 
+contact us at scheme@plt-scheme.org.
+
+Acknowledgements
+----------------
+
+MzCOM was developed in response to a query by 
+Andre Van Meulebrouck.  Andre also did extensive 
+testing with Visual BASIC.
diff --git a/collects/mzcom/info.ss b/collects/mzcom/info.ss
new file mode 100644
index 0000000000..ba590c3a6b
--- /dev/null
+++ b/collects/mzcom/info.ss
@@ -0,0 +1,11 @@
+;; info.ss for mzcom collection
+
+(module info (lib "infotab.ss" "setup")
+  (define name "MzCOM")
+  (define doc.txt "doc.txt")
+  (define blurb
+    (list
+      "MzCOM is a COM class that makes Scheme available to any COM client."))
+  (define release-version "299")
+  (define release-iteration "0")
+  (define post-install-collection "installer.ss"))
diff --git a/collects/mzcom/installer.ss b/collects/mzcom/installer.ss
new file mode 100644
index 0000000000..9cf90b93dd
--- /dev/null
+++ b/collects/mzcom/installer.ss
@@ -0,0 +1,11 @@
+(module installer mzscheme
+  (require (lib "process.ss"))
+  (provide post-installer)
+  (define (post-installer plt-home)
+    (let ([exe "MzCOM.exe"])
+      (cond [(not (eq? (system-type) 'windows))
+             (printf "Warning: can't install MzCOM on non-Windows machine\n")]
+            [(not (file-exists? (build-path plt-home exe)))
+             (printf "Warning: MzCOM binary not installed\n")]
+            [else (parameterize ([current-directory plt-home])
+                    (system* exe "/RegServer"))]))))
diff --git a/collects/mzlib/async-channel.ss b/collects/mzlib/async-channel.ss
new file mode 100644
index 0000000000..7b966a01b6
--- /dev/null
+++ b/collects/mzlib/async-channel.ss
@@ -0,0 +1,161 @@
+
+(module async-channel mzscheme
+  (require (lib "etc.ss")
+	   (lib "contract.ss"))
+
+  ;; This library implements buffered channels with
+  ;; and optional buffer limit (so that puts block
+  ;; if the buffer is full).
+
+  ;; We make a fancy structure just so an async-channel
+  ;; can be supplied directly to `sync'.
+  ;; The alternative is to use `define-struct' and supply
+  ;; a `async-channel-get-evt' procedure.
+  (define-values (struct:ac make-ac async-channel? ac-ref ac-set!)
+    (make-struct-type 'async-channel #f 5 0 #f 
+		      (list (cons prop:evt 
+				  ;; This is the guard that is called when
+				  ;;  we use an async-channel as an event
+				  ;;  (to get).
+				  (lambda (ac)
+				    (async-channel-get-guard ac))))
+		      (current-inspector) #f))
+  (define ac-enqueue-ch (make-struct-field-accessor ac-ref 0))
+  (define ac-dequeue-ch (make-struct-field-accessor ac-ref 1))
+  (define ac-empty-ch (make-struct-field-accessor ac-ref 2))
+  (define ac-full-ch (make-struct-field-accessor ac-ref 3))
+  (define ac-thread (make-struct-field-accessor ac-ref 4))
+    
+  ;; Make ----------------------------------------
+
+  (define make-async-channel
+    (opt-lambda ([limit #f])
+      (let* ([enqueue-ch (make-channel)]  ; for puts
+	     [dequeue-ch (make-channel)]  ; for gets
+	     [empty-ch (make-channel)]    ; for get polls
+	     [full-ch (make-channel)]     ; for put polls
+	     [queue-first (cons #f null)] ; queue head
+	     [queue-last queue-first]     ; queue tail
+	     ;; Events:
+	     [tell-empty 
+	      (channel-put-evt empty-ch (make-semaphore))] ; see poll->ch
+	     [tell-full 
+	      (channel-put-evt full-ch (make-semaphore))]  ; see poll->ch
+	     [enqueue (handle-evt
+		       enqueue-ch
+		       (lambda (v)
+			 ;; We received a put; enqueue it:
+			 (let ([p (cons #f null)])
+			   (set-car! queue-last v)
+			   (set-cdr! queue-last p)
+			   (set! queue-last p))))]
+	     [mk-dequeue
+	      (lambda ()
+		(handle-evt
+		 (channel-put-evt dequeue-ch (car queue-first))
+		 (lambda (ignored)
+		   ;; A get succeeded; dequeue it:
+		   (set! queue-first (cdr queue-first)))))]
+	     [manager-thread
+	      ;; This thread is the part that makes the channel asynchronous.
+	      ;; It waits for a combination of gets and puts as appropriate.
+	      ;; Note that we start it with `thread/suspend-kill', and we
+	      ;; resume the manager thread with the current thread everytime
+	      ;; we want to talk to the manager thread, which effectively
+	      ;; means that the manager thread is not bound by a custodian
+	      ;; that is weaker than any of its user's custodians (and thus,
+	      ;; from the user's perspective, is not bound by any custodian
+	      ;; at all).
+	      (thread/suspend-to-kill
+	       (lambda ()
+		 (let loop ()
+		   (cond
+		    [(= 1 (length queue-first))
+		     ;; The queue is currently empty:
+		     (sync enqueue tell-empty)]
+		    [(or (not limit) ((sub1 (length queue-first)) . < . limit))
+		     (sync enqueue (mk-dequeue))]
+		    [else
+		     (sync (mk-dequeue) tell-full)])
+		   (loop))))])
+	(make-ac enqueue-ch dequeue-ch empty-ch full-ch manager-thread))))
+
+  ;; Get ----------------------------------------
+  
+  (define (async-channel-get-guard ac)
+    ;; Make sure queue manager is running:
+    (thread-resume (ac-thread ac) (current-thread))
+    ;; If it the channel is being polled, it's not
+    ;;  good enough to poll the dequeue channel, because
+    ;;  the server thread may be looping. In that case,
+    ;;  block on the dequeue channel and the empty
+    ;;  channel, and create a new waitable to report
+    ;;  the result.
+    (poll-guard-evt
+     (lambda (poll?)
+       (if poll?
+	   (poll->ch (ac-dequeue-ch ac) (ac-empty-ch ac))
+	   (ac-dequeue-ch ac)))))
+
+  (define (async-channel-get ac)
+    (sync ac))
+
+  (define (async-channel-try-get ac)
+    (sync/timeout 0 ac))
+
+  ;; Put ----------------------------------------
+
+  (define (async-channel-put-evt ac v)
+    (letrec ([p (wrap-evt
+		 (guard-evt
+		  (lambda ()
+		    ;; Make sure queue manager is running:
+		    (thread-resume (ac-thread ac) (current-thread))
+		    (let ([p (channel-put-evt (ac-enqueue-ch ac) v)])
+		      ;; Poll handling, as in `async-channel-get-guard':
+		      (poll-guard-evt
+		       (lambda (poll?)
+			 (if poll?
+			     (poll->ch p (ac-full-ch ac))
+			     p))))))
+		 (lambda (ignored) p))])
+      p))
+  
+  (define (async-channel-put ac v)
+    (thread-resume (ac-thread ac) (current-thread))
+    (sync (channel-put-evt (ac-enqueue-ch ac) v))
+    (void))
+
+  ;; Poll helper ----------------------------------------
+
+  (define (poll->ch normal not-ready)
+    (sync
+     ;; If a value becomes available,
+     ;;  create a waitable that returns
+     ;;  the value:
+     (wrap-evt
+      normal
+      (lambda (v)
+	;; Return a waitable for a successful poll:
+	(wrap-evt
+	 always-evt
+	 (lambda (ignored) v))))
+     ;; If not-ready becomes available,
+     ;;  the result is supposed to be
+     ;;  a never-ready waitable:
+     not-ready))
+
+  ;; Provides ----------------------------------------
+
+  (provide async-channel?)
+  (provide/contract (make-async-channel (case->
+					 (-> async-channel?)
+					 ((union false/c (lambda (x)
+							   (and (integer? x)
+								(exact? x)
+								(positive? x))))
+					  . -> . async-channel?)))
+		    (async-channel-get (async-channel? . -> . any/c))
+		    (async-channel-try-get (async-channel? . -> . any/c))
+		    (async-channel-put (async-channel? any/c . -> . any/c))
+		    (async-channel-put-evt (async-channel? any/c . -> . evt?))))
diff --git a/collects/mzlib/awk.ss b/collects/mzlib/awk.ss
new file mode 100644
index 0000000000..0c6bfa57c0
--- /dev/null
+++ b/collects/mzlib/awk.ss
@@ -0,0 +1,256 @@
+
+(module awk mzscheme
+  (require-for-syntax (lib "stx.ss" "syntax"))
+
+  (provide awk match:start match:end match:substring regexp-exec)
+
+  (define-syntax awk
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ next-record
+	    (record field ...)
+	    counter
+	    ((state-variable init-expr) ...)
+	    continue
+	    clause ...)
+	 (and (identifier? (syntax counter))
+	      (identifier? (syntax continue)))
+	 (let ([clauses (syntax->list (syntax (clause ...)))]
+	       [initvars null])
+	   (with-syntax ([(local-state ...) (generate-temporaries
+					     (syntax->list (syntax (state-variable ...))))])
+	     (letrec ([get-after-clauses
+		       (lambda ()
+			 (let loop ([l clauses][afters null])
+			   (cond
+			    [(null? l) (if (stx-null? afters)
+					   (syntax ((values state-variable ...)))
+					   afters)]
+			    [(syntax-case (car l) (after)
+			       [(after . rest) (syntax rest)]
+			       [_else #f])
+			     => (lambda (rest)
+				  (with-syntax ([(after ...) afters])
+				    (loop (cdr l) (syntax (after ... .  rest)))))]
+			    [else
+			     (loop (cdr l) afters)])))]
+		      [wrap-state
+		       (lambda (e)
+			 (syntax-case e (=>)
+			   [(=> f)
+			    (with-syntax ([body (wrap-state (syntax ((f arg))))])
+			      (syntax (=> (lambda (arg)
+					    . body))))]
+			   [body
+			    (syntax
+			     ((call-with-values (lambda () . body)
+				(lambda (local-state ... . extras)
+				  (set! else-ready? #f)
+				  (set! state-variable local-state)
+				  ...))))]))]
+		      [make-range
+		       (lambda (include-on? include-off? body rest)
+			 (syntax-case body ()
+			   [(t1 t2 . body)
+			    (with-syntax ([on? (car (generate-temporaries '(1)))]
+					  [t1 (make-test (syntax-e (syntax t1)) (syntax t1))]
+					  [t2 (make-test (syntax-e (syntax t2)) (syntax t2))]
+					  [body (wrap-state (syntax body))])
+			      (with-syntax ([check (if include-on?
+						       (if include-off?
+							   (syntax post-on-on?)
+							   (syntax on?))
+						       (if include-off?
+							   (syntax orig-on?)
+							   (syntax (and orig-on? on?))))])
+				(set! initvars (cons (syntax (on? #f)) initvars))
+				(syntax
+				 ((let ([orig-on? on?])
+				    (unless on? 
+				      (set! on? t1))
+				    (let ([post-on-on? on?])
+				      (when on? 
+					(set! on? (not t2))))
+				    (when check
+				      . body))
+				  . rest))))]
+			   [_else (raise-syntax-error
+				   #f
+				   "bad range"
+				   stx
+				   body)]))]
+		      [make-test
+		       (lambda (test expr)
+			 (cond
+			  [(string? test)
+			   (with-syntax ([g (car (generate-temporaries '(1)))]
+					 [expr expr])
+			     (set! initvars (cons (syntax (g (regexp expr))) initvars))
+			     (syntax (regexp-exec g record)))]
+			  [(number? test)
+			   (with-syntax ([expr expr])
+			     (syntax (= expr counter)))]
+			  [else expr]))]
+		      [get-testing-clauses
+		       (lambda ()
+			 (let loop ([l clauses])
+			   (if (null? l)
+			       null
+			       (syntax-case (car l) ()
+				 [(test-expr body ...)
+				  (with-syntax ([rest (loop (cdr l))])
+				    (let ([test (syntax-e (syntax test-expr))]
+					  [body (syntax (body ...))])
+				      (cond
+				       [(or (string? test) (number? test))
+					(with-syntax ([t (make-test test (syntax test-expr))]
+						      [body (wrap-state body)])
+					  (syntax
+					   ((cond [t . body]
+						  [else (void)])
+					    . rest)))]
+				       [(eq? test 'else)
+					(with-syntax ([body (wrap-state body)])
+					  (syntax
+					   ((when else-ready? . body)
+					    (set! else-ready? #t)
+					    . rest)))]
+				       [(eq? test 'range)
+					(make-range #f #f body (syntax rest))]
+				       [(eq? test ':range)
+					(make-range #t #f body (syntax rest))]
+				       [(eq? test 'range:)
+					(make-range #f #t body (syntax rest))]
+				       [(eq? test ':range:)
+					(make-range #t #t body (syntax rest))]
+				       [(eq? test 'after)
+					(syntax rest)]
+				       [(eq? test '/)
+					(with-syntax ([g (car (generate-temporaries '(1)))])
+					  (syntax-case* body (/) (lambda (a b)
+								  (eq? (syntax-e a)
+								       (syntax-e b)))
+					    [(re / (var ...) . body)
+					     (and (string? (syntax-e (syntax re)))
+						  (andmap (lambda (x) (or (identifier? x)
+									  (not (syntax-e x))))
+							  (syntax->list (syntax (var ...)))))
+					     (with-syntax ([(var ...)
+							    (map (lambda (x)
+								   (if (identifier? x)
+								       x
+								       (car (generate-temporaries '(1)))))
+								 (syntax->list (syntax (var ...))))]
+							   [body (wrap-state (syntax body))])
+					       (set! initvars (cons (syntax (g (regexp re))) initvars))
+					       (syntax
+						((cond
+						  [(regexp-match re record)
+						   => (lambda (arg)
+							(apply
+							 (lambda (var ...) . body)
+							 arg))]
+						  [else (void)])
+						 . rest)))]
+					    [_else (raise-syntax-error
+						    #f
+						    "bad / ... / clause"
+						    stx
+						    (car l))]))]
+				       [else
+					(with-syntax ([body (wrap-state body)])
+					  (syntax
+					   ((cond [test-expr . body]
+						  [else (void)])
+					    . rest)))])))]
+				 [_else (raise-syntax-error
+					 #f
+					 "bad clause"
+					 stx
+					 (car l))]))))])
+	       (with-syntax ([testing-clauses (get-testing-clauses)]
+			     [after-clauses (get-after-clauses)]
+			     [initvars initvars])
+		 (syntax
+		  (let ((state-variable init-expr) ...
+			. initvars)
+		    (let loop ([counter 1]) 
+		      (call-with-values (lambda () next-record)
+			(lambda (record field ...)
+			  (if (eof-object? record)
+			      (begin
+				. after-clauses)
+			      (let ([else-ready? #t])
+				(let/ec escape
+				  (let ([continue
+					 (lambda (local-state ... . extras)
+					   (set! state-variable local-state)
+					   ...
+					   (escape))])
+				    . testing-clauses))
+				(loop (add1 counter)))))))))))))]
+	;; Left out continue...
+	[(_ next-record
+	    (record field-variable ...)
+	    counter-variable
+	    ((state-variable init-expr) ...)
+	    clause ...)
+	 (identifier? (syntax counter-variable))
+	 (syntax
+	  (awk next-record
+	       (record field-variable ...)
+	       counter-variable
+	       ((state-variable init-expr) ...)
+	       continue
+	       clause ...))]
+	;; Left out counter...
+	[(_ next-record
+	    (record field-variable ...)
+	    ((state-variable init-expr) ...)
+	    continue-variable
+	    clause ...)
+	 (identifier? (syntax continue-variable))
+	 (syntax
+	  (awk next-record
+	       (record field-variable ...)
+	       counter
+	       ((state-variable init-expr) ...)
+	       continue-variable
+	       clause ...))]
+	;; Left out both...
+	[(_ next-record
+	    (record field-variable ...)
+	    ((state-variable init-expr) ...)
+	    clause ...)
+	 (syntax
+	  (awk next-record
+	       (record field-variable ...)
+	       counter
+	       ((state-variable init-expr) ...)
+	       continue
+	       clause ...))])))
+
+  (define-struct match (s a))
+
+  (define match:start
+    (case-lambda
+     [(rec) (match:start rec 0)]
+     [(rec which) (car (list-ref (match-a rec) which))]))
+
+  (define match:end
+    (case-lambda
+     [(rec) (match:end rec 0)]
+     [(rec which) (cdr (list-ref (match-a rec) which))]))
+
+  (define match:substring
+    (case-lambda
+     [(rec) (match:substring rec 0)]
+     [(rec which) (let ([p (list-ref (match-a rec) which)])
+		    (substring (match-s rec) (car p) (cdr p)))]))
+
+  (define regexp-exec
+    (lambda (re s)
+      (let ([r (regexp-match-positions re s)])
+	(if r
+	    (make-match s r)
+	    #f)))))
diff --git a/collects/mzlib/class-old.ss b/collects/mzlib/class-old.ss
new file mode 100644
index 0000000000..9327fbac8e
--- /dev/null
+++ b/collects/mzlib/class-old.ss
@@ -0,0 +1,999 @@
+
+;; Object system, same as MzScheme version 103 and earlier.
+
+;; This was a fairly simple implementation until it was extended to
+;;  handle primitive classes (e.g., for MrEd). Now it's a mess.
+
+(module class-old mzscheme
+  (require-for-syntax (lib "stx.ss""syntax")
+		      (lib "name.ss""syntax"))
+
+  (define insp (current-inspector))
+
+  (define-values (prop:object object? object-ref) (make-struct-type-property 'object))
+
+  (define-struct class (name
+			object-make object-slot-ref object-slot-set!
+			width method-prim-vec
+			pos supers
+			interface
+			public-ht public-ids 
+			init-old-indices    ;; rename
+			init-define-indices ;; override, public
+			replace-indices     ;; override
+			init-new-indices    ;; inherit, override, public
+			go go-arity
+			struct:prim prop:dispatch prim-methods
+			immediate-primitive?))
+  ;; simplistic implementation for now:
+  (define-struct interface (name supers public-ids class))
+
+  (define undefined (letrec ([x x]) x))
+
+  (define object<%> (make-interface 'object% null null #f))
+  (define object% (make-class 'object%
+			      'make-obj 'slot-ref 'slot-set! 0 (vector)
+			      0 (vector #f) 
+			      object<%>
+			      (make-hash-table) 
+			      null null null null null 
+			      (lambda ()
+				(let ([object%-init (lambda () (void))])
+				  object%-init))
+			      0
+			      #f #f #f #f))
+  (set-interface-class! object<%> object%)
+  (vector-set! (class-supers object%) 0 object%)
+  (define-values (struct:obj make-obj)
+    (let-values ([(struct:obj make-obj obj? obj-accessor obj-mutator)
+		  (make-struct-type 'object #f 0 0 #f (list (cons prop:object (box object%))) insp)])
+      (set-class-object-make! object% make-obj)
+      (set-class-object-slot-ref! object% obj-accessor)
+      (set-class-object-slot-set!! object% obj-mutator)
+      (values struct:obj make-obj)))
+
+  (define (obj-class o)
+    (unbox (object-ref o)))
+  (define (slot-ref o p)
+    (unbox/prim-resolve ((class-object-slot-ref (unbox (object-ref o))) o p) o))
+
+  (define (make-naming-constructor type name)
+    (let-values ([(struct: make- ? -accessor -mutator)
+		  (make-struct-type name type 0 0 #f null insp)])
+      make-))
+
+  (define skip (gensym))
+
+  (define-struct lazy-prim-method (m))
+
+  (define (unbox/prim-resolve b o)
+    (let ([v (unbox b)])
+      (if (lazy-prim-method? v)
+	  (begin
+	    (set-box! b (lambda r (apply (lazy-prim-method-m v) o r)))
+	    (unbox b))
+	  v)))
+
+  (define (make-prim-class struct:prim prim-side-box prop:dispatch prim-init name super old-mnames new-mnames methods)
+    (let ([c (compose-class name (or super object%) null
+			    null          ;; rename
+			    null          ;; inherit
+			    old-mnames    ;; override
+			    new-mnames    ;; public
+			    (let ([lazys
+				   (map make-lazy-prim-method
+					methods)])
+			      (lambda (this super-init . pub-defines+pub-mutables)
+				(lambda args
+				  (if super (super-init skip) (super-init))
+				  (unless (and (pair? args)
+					       (eq? (car args) skip))
+				    (apply prim-init this args))
+				  (unless (null? pub-defines+pub-mutables)
+				    ;; "define" all methods with lazy tokens:
+				    (let loop ([ms lazys]
+					       [l pub-defines+pub-mutables]) ; longer than ms
+				      (unless (null? ms)
+					(let ([m (car ms)])
+					  (set-box! (car l) m))
+					(loop (cdr ms) (cdr l))))))))
+			    (box 0)
+			    (list struct:prim prop:dispatch methods))])
+      (set-box! prim-side-box c)
+      c))
+
+  (define-struct (exn:object exn) ())
+
+  (define (obj-error where . msg)
+    (raise
+     (make-exn:object
+      (string-append
+       (format "~a: " where)
+       (apply format msg))
+      (current-continuation-marks))))
+
+  (define (for-class name)
+    (if name (format " for class: ~a" name) ""))
+  (define (for-intf name)
+    (if name (format " for interface: ~a" name) ""))
+
+  (define (get-implement-requirement interfaces where for)
+    (let loop ([class #f]
+	       [supers interfaces])
+      (if (null? supers)
+	  class
+	  (let ([c (interface-class (car supers))])
+	    (loop
+	     (cond
+	      [(not c) class]
+	      [(not class) c]
+	      [(subclass? c class) class]
+	      [(subclass? class c) c]
+	      [else
+	       (obj-error 
+		where
+		"conflicting class implementation requirements in superinterfaces~a"
+		for)])
+	     (cdr supers))))))
+
+  (define (compose-class name super interfaces 
+			 use-pre-ids   ;; rename
+			 use-final-ids ;; inherit
+			 replace-ids   ;; override
+			 new-ids       ;; public
+			 go go-arity
+			 primitive)
+    (unless (class? super)
+      (obj-error 'class*/names "superclass expression returned a non-class: ~a~a" 
+		 super
+		 (for-class name)))
+    (let ([name (or name
+		    (let ([s (class-name super)])
+		      (and s 
+			   (not (eq? super object%))
+			   (if (symbol? s)
+			       (format "derived-from-~a" s)
+			       s))))])
+      (for-each
+       (lambda (intf)
+	 (unless (interface? intf)
+	   (obj-error 'class*/names "interface expression returned a non-interface: ~a~a" 
+		      intf
+		      (for-class name))))
+       interfaces)
+      (let ([ht (make-hash-table)]
+	    [super-public-ids (class-public-ids super)])
+	;; Put superclass ids in table, with pos
+	(let loop ([ids super-public-ids][p 0])
+	  (unless (null? ids)
+	    (hash-table-put! ht (car ids) p)
+	    (loop (cdr ids) (add1 p))))
+	;; Put new ids in table, with pos
+	(let loop ([ids new-ids][p (class-width super)])
+	  (unless (null? ids)
+	    (when (hash-table-get ht (car ids) (lambda () #f))
+	      (obj-error 'class*/names "superclass already contains ivar: ~a~a" 
+			 (car ids)
+			 (for-class name)))
+	    (hash-table-put! ht (car ids) p)
+	    (loop (cdr ids) (add1 p))))
+	;; Check that superclass has expected ids, and get indices
+	(let ([get-indices
+	       (lambda (ids)
+		 (map
+		  (lambda (id)
+		    (hash-table-get 
+		     ht id
+		     (lambda ()
+		       (obj-error 'class*/names 
+				  "superclass does not provide an expected ivar: ~a~a" 
+				  id
+				  (for-class name)))))
+		  ids))]
+	      [width (+ (class-width super) (length new-ids))]
+	      [prop:dispatch (or (and primitive (cadr primitive))
+				 (class-prop:dispatch super))]
+	      [methods (and primitive 
+			    (list->vector
+			     (append (if (class-prim-methods super)
+					 (vector->list (class-prim-methods super))
+					 null)
+				     (caddr primitive))))])
+	  (let ([define-indices (get-indices (append replace-ids new-ids))]
+		[use-pre-indices (get-indices use-pre-ids)]
+		[use-final-indices (get-indices use-final-ids)]
+		[replace-indices (get-indices replace-ids)]
+		[new-indices (get-indices new-ids)]
+		[method-prim-vec (make-vector width (and primitive #t))])
+
+	    ;; Copy super's method prim flags:
+	    (let ([svec (class-method-prim-vec super)])
+	      (let loop ([i (class-width super)])
+		(unless (zero? i)
+		  (let ([i (sub1 i)])
+		    (vector-set! method-prim-vec i (vector-ref svec i))
+		    (loop i)))))
+	    ;; If not prim, set prim-method flag for overridings
+	    (unless primitive
+	      (for-each (lambda (i)
+			  (vector-set! method-prim-vec i #f))
+			replace-indices))
+
+	    ;; Check here that all interface ivars are satisfied
+	    (for-each
+	     (lambda (intf)
+	       (for-each
+		(lambda (var)
+		  (unless (hash-table-get ht var (lambda () #f))
+		    (obj-error 'class*/names 
+			       "interface-required variable missing: ~a~a~a" 
+			       var
+			       (for-class name)
+			       (for-intf (interface-name intf)))))
+		(interface-public-ids intf)))
+	     interfaces)
+	    (let ([c (get-implement-requirement interfaces 'class*/names (for-class name))])
+	      (when (and c (not (subclass? super c)))
+		(obj-error 'class*/names 
+			   "interface-required implementation not satisfied~a~a"
+			   (for-class name)
+			   (let ([r (class-name c)])
+			     (if r
+				 (format " required class: ~a" r)
+				 "")))))
+	    ;; Make the class and its interface
+	    (let* ([class-make (if name
+				   (make-naming-constructor 
+				    struct:class 
+				    (string->symbol (format "class:~a" name)))
+				   make-class)]
+		   [interface-make (if name
+				       (make-naming-constructor 
+					struct:interface
+					(string->symbol (format "interface:~a" name)))
+				       make-interface)]
+		   [public-ids (append super-public-ids new-ids)]
+		   [super-interfaces (cons (class-interface super) interfaces)]
+		   [i (interface-make name super-interfaces public-ids #f)]
+		   [struct:prim (or (and primitive (car primitive))
+				    (class-struct:prim super))]
+		   [c (class-make name
+				  'object-make 'object-slot-ref 'object-slot-set!
+				  width method-prim-vec
+				  (add1 (class-pos super))
+				  (list->vector (append (vector->list (class-supers super)) (list #f)))
+				  i
+				  ht public-ids
+				  use-pre-indices ;; rename
+				  define-indices  ;; override, public
+				  replace-indices ;; override
+				  (append use-final-indices replace-indices new-indices) ;; inherit, override, public
+				  go (if (box? go-arity)
+					 (make-arity-at-least (unbox go-arity))
+					 go-arity)
+				  struct:prim prop:dispatch methods
+				  (and primitive #t))]
+		   [obj-name (if name 
+				 (string->symbol (format "object:~a" name))
+				 'object)])
+	      (let-values ([(struct:object object-make object-slot-ref object-slot-set!)
+			    (let-values ([(t make p a m)
+					  (make-struct-type obj-name
+							    (or struct:prim #f)
+							    0 ;; No init fields
+							    ;; Unless prim, add uninit fields for slots:
+							    (if primitive
+								0
+								width)
+							    'uninitialized-slot ;; anything for uninit val
+							    (append
+							     (if (and struct:prim (not primitive))
+								 ;; Need dispatcher
+								 (list (cons prop:dispatch
+									     (lambda (ivar-name)
+									       (let ([pos (hash-table-get ht ivar-name)])
+										 (if (vector-ref method-prim-vec pos)
+										     #f
+										     (lambda (o . args)
+										       (apply (slot-ref o pos) args)))))))
+								 null)
+							     ;; Add/override backbox:
+							     (list
+							      (cons prop:object (box #f))))
+							    insp)])
+			      (values t
+				      make
+				      (if primitive
+					  ;; No slots - selector always manufactures a value
+					  (lambda (o p)
+					    (box (lambda r (apply (vector-ref methods p) o r))))
+					  ;; Normal object slots:
+					  a)
+				      m))])
+		(set-box! (object-ref struct:object) c)
+		(set-class-object-make! c object-make)
+		(set-class-object-slot-ref! c object-slot-ref)
+		(set-class-object-slot-set!! c object-slot-set!)
+		(vector-set! (class-supers c) (class-pos c) c)
+		(set-interface-class! i c)
+		c)))))))
+
+  (define (compose-interface name supers vars)
+    (for-each
+     (lambda (intf)
+       (unless (interface? intf)
+	 (obj-error 'interface 
+		    "superinterface expression returned a non-interface: ~a~a" 
+		    intf
+		    (for-intf name))))
+     supers)
+    (let ([ht (make-hash-table)])
+      (for-each
+       (lambda (var)
+	 (hash-table-put! ht var #t))
+       vars)
+      ;; Check that vars don't already exist in supers:
+      (for-each
+       (lambda (super)
+	 (for-each
+	  (lambda (var)
+	    (when (hash-table-get ht var (lambda () #f))
+	      (obj-error 'interface "variable already in superinterface: ~a~a~a" 
+			 var
+			 (for-intf name)
+			 (let ([r (interface-name super)])
+			   (if r
+			       (format " already in: ~a" r)
+			       "")))))
+	  (interface-public-ids super)))
+       supers)
+      ;; Check for [conflicting] implementation requirements
+      (let ([class (get-implement-requirement supers 'interface (for-intf name))]
+	    [interface-make (if name
+				(make-naming-constructor 
+				 struct:interface
+				 (string->symbol (format "interface:~a" name)))
+				make-interface)])
+	;; Add supervars to table:
+	(for-each
+	 (lambda (super)
+	   (for-each
+	    (lambda (var) (hash-table-put! ht var #t))
+	    (interface-public-ids super)))
+	 supers)
+	;; Done
+	(interface-make name supers (hash-table-map ht (lambda (k v) k)) class))))
+
+  (define (make-object c . args)
+    (unless (class? c)
+      (apply raise-type-error 'make-object "class" 0 c args))
+    (let ([this ((class-object-make c))])
+      (let ([slot-ref (class-object-slot-ref c)]
+	    [slot-set! (class-object-slot-set! c)]
+	    [making-prim? (class-immediate-primitive? c)])
+	(unless (class-immediate-primitive? c)
+	  (let loop ([n (class-width c)])
+	    (unless (= n 0)
+	      (slot-set! this (sub1 n) (box undefined))
+	      (loop (sub1 n)))))
+	(let ([setup (let setup-class ([c c])
+		       (if (zero? (class-pos c))
+			   (lambda ()
+			     ((class-go c)))
+			   (let ([super (vector-ref (class-supers c) 
+						    (sub1 (class-pos c)))])
+			     (let ([super-setup (setup-class super)])
+			       (let ([old-boxes (map (lambda (i)
+						       (slot-ref this i))
+						     (class-init-old-indices c))])
+				 (for-each (lambda (i)
+					     (slot-set! this i (box undefined)))
+					   (if making-prim?
+					       null
+					       (class-replace-indices c)))
+				 (let ([define-boxes (map (lambda (i)
+							    (slot-ref this i))
+							  (if making-prim?
+							      null
+							      (class-init-define-indices c)))])
+				   (lambda ()
+				     (let ([new-boxes (map (lambda (i)
+							     (slot-ref this i))
+							   (if making-prim?
+							       null
+							       (class-init-new-indices c)))]
+					   [super-init (super-setup)]
+					   [super-called? #f])
+				       (letrec ([init (apply
+						       (class-go c)
+						       this
+						       (lambda args
+							 (when super-called?
+							   (obj-error (or (object-name init)
+									  'object-init)
+								      "multiple intializations of superclass"))
+							 (set! super-called? #t)
+							 (apply super-init args)
+							 ;; Force lazy method boxes that might be used directly:
+							 (when (and (class-struct:prim c)
+								    (not (class-immediate-primitive? c)))
+							   (for-each (lambda (b) (unbox/prim-resolve b this)) old-boxes)
+							   (for-each (lambda (b) (unbox/prim-resolve b this)) new-boxes)))
+						       (append
+							define-boxes  ;; override, public
+							old-boxes     ;; rename
+							new-boxes))]) ;; inherit, override, public
+					 (lambda args
+					   (apply init args)
+					   (unless super-called?
+					     (obj-error 
+					      (or (object-name init)
+						  'object-init)
+					      "initialization did not invoke superclass initializer"))))))))))))])
+	  (apply (setup) args)
+	  this))))
+
+  (define (is-a? v c)
+    (cond
+     [(class? c)
+      (and (object? v)
+	   (subclass? (obj-class v) c))]
+     [(interface? c)
+      (and (object? v)
+	   (implementation? (obj-class v) c))]
+     [else (raise-type-error 'is-a? "class or interface" 1 v c)]))
+
+  (define (subclass? v c)
+    (unless (class? c)
+      (raise-type-error 'subclass? "class" 1 v c))
+    (and (class? v)
+	 (let ([p (class-pos c)])
+	   (and (<= p (class-pos v))
+		(eq? c (vector-ref (class-supers v) p))))))
+
+  (define class->interface class-interface)
+  (define (object-interface o) (class-interface (obj-class o)))
+
+  (define (implementation? v i)
+    (unless (interface? i)
+      (raise-type-error 'implementation? "interface" 1 v i))
+    (and (class? v)
+	 (interface-extension? (class->interface v) i)))
+
+  (define (interface-extension? v i)
+    (unless (interface? i)
+      (raise-type-error 'interface-extension? "interface" 1 v i))
+    (and (interface? i)
+	 (let loop ([v v])
+	   (or (eq? v i)
+	       (ormap loop (interface-supers v))))))
+
+  (define (ivar-in-interface? s i)
+    (unless (symbol? s)
+      (raise-type-error 'ivar-in-interface? "symbol" 0 s i))
+    (unless (interface? i)
+      (raise-type-error 'ivar-in-interface? "interface" 1 s i))
+    (and (memq s (interface-public-ids i)) #t))
+
+  (define (interface->ivar-names i)
+    (unless (interface? i)
+      (raise-type-error 'interface->ivar-names "interface" i))
+					; copy list
+    (map values (interface-public-ids i)))
+
+  (define (class-initialization-arity c)
+    (unless (class? c)
+      (raise-type-error 'class-initialization-arity "class" c))
+    (class-go-arity c))
+
+  (define (ivar/proc o n)
+    (unless (object? o)
+      (raise-type-error 'ivar/proc "object" 0 o n))
+    (let ([c (obj-class o)])
+      (let ([p (hash-table-get
+		(class-public-ht c)
+		n
+		(lambda () #f))])
+	(if p
+	    (slot-ref o p)
+	    (begin
+	       (unless (symbol? n)
+		 (raise-type-error 'ivar/proc "symbol" 1 o n))
+	       (obj-error 'ivar 
+			  "instance variable not found: ~e~a in: ~e" 
+			  n 
+			  (for-class (class-name c))
+			  o))))))
+  
+  (define-syntax ivar
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ o m)
+	 (identifier? (syntax m))
+	 (syntax (ivar/proc o 'm))])))
+
+  (define-syntax send
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ o m arg ...)
+	 (identifier? (syntax m))
+	 (syntax ((ivar o m) arg ...))])))
+
+  (define-syntax send*
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ obj (meth arg ...) ...)
+	 (syntax/loc stx
+		     (let ([o obj])
+		       (send o meth arg ...)
+		       ...))])))
+  
+  (define (make-generic/proc c n)
+    (unless (or (class? c) (interface? c))
+      (raise-type-error 'make-generic "class or interface" 0 c n))
+    (unless (symbol? n)
+      (raise-type-error 'make-generic/proc "symbol" 1 c n))
+    (if (class? c)
+	(let ([p (hash-table-get
+		  (class-public-ht c)
+		  n
+		  (lambda () #f))])
+	  (if p
+	      (lambda (o)
+		(unless (is-a? o c)
+		  (let ([name (string->symbol (format "generic~a" (for-class (class-name c))))])
+		    (if (object? o)
+			(obj-error name
+				   "object not an instance of the generic's class: ~e"
+				   o)
+			(raise-type-error
+			 name
+			 "object"
+			 o))))
+		(slot-ref o p))
+	      (obj-error 'make-generic 
+			 "instance variable not found: ~e~a" 
+			 n 
+			 (for-class (class-name c)))))
+	(begin
+	  (unless (memq n (interface-public-ids c))
+	    (obj-error 'make-generic 
+		       "instance variable not found: ~e~a" 
+		       n 
+		       (for-intf (interface-name c))))
+	  (lambda (o)
+	    (unless (is-a? o c)
+	      (let ([name (string->symbol (format "generic~a" (for-intf (interface-name c))))])
+		(if (object? o)
+		    (obj-error name
+			       "object not an instance of the generic's interface: ~e"
+			       o)
+		    (raise-type-error
+		     name
+		     "object"
+		     o))))
+	    (ivar/proc o n)))))
+
+  (define-syntax make-generic
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ c n)
+	 (identifier? (syntax n))
+	 (syntax
+	  (make-generic/proc c 'n))])))
+
+  (define needs-init (gensym))
+
+  (define-syntax class*/names
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ (this-id super-init-id)
+	    super-expr
+	    (interface-expr ...)
+	    init-vars
+	    clauses ...)
+	 (let ([se (lambda (msg expr)
+		     (raise-syntax-error #f msg stx expr))])
+	   ;; Check this and super-init:
+	   (unless (identifier? (syntax this-id))
+	     (se "not an identifier" (syntax this-id)))
+	   (unless (identifier? (syntax super-init-id))
+	     (se "not an identifier" (syntax super-init-id)))
+	   ;; Unpack init arguments, with default expressions:
+	   (let-values ([(init-ids init-defs init-rest-id)
+			 (let loop ([inits (syntax init-vars)][need-def? #f])
+			   (syntax-case inits ()
+			     [() (values null null #f)]
+			     [id (identifier? (syntax id))
+				 (values null null (syntax id))]
+			     [(id . rest) (identifier? (syntax id))
+			      (begin
+				(when need-def?
+				  (se "expected identifier with default value" (syntax id)))
+				(let-values ([(ids defs rest) (loop (syntax rest) #f)])
+				  (values (cons (syntax id) ids)
+					  (cons #f defs)
+					  rest)))]
+			     [((id def) . rest) (identifier? (syntax id))
+			      (let-values ([(ids defs rest) (loop (syntax rest) #f)])
+				(values (cons (syntax id) ids)
+					(cons (syntax def) defs)
+					rest))]
+			     [(first . rest)
+			      (se "bad initialization declaration" (syntax first))]
+			     [else (se "improper identifier list" (syntax init-vars))]))])
+	     ;; Unpack all body clauses:
+	     (let* ([extract-ivars
+		     ;; Unpacks a public, private, or override clause
+		     (lambda (kind can-rename? decls)
+		       (map
+			(lambda (decl)
+			  (syntax-case decl ()
+			    [id (identifier? (syntax id))
+				(list kind (syntax id) (syntax id) (syntax (void)))]
+			    [(id expr) (identifier? (syntax id))
+			     (list kind (syntax id) (syntax id) (syntax expr))]
+			    [(id) (and can-rename? (identifier? (syntax id)))
+			     (list kind (syntax id) (syntax id) (syntax (void)))]
+			    [((iid eid) expr) (and can-rename?
+						   (identifier? (syntax iid))
+						   (identifier? (syntax eid)))
+			     (list kind (syntax iid) (syntax eid) (syntax expr))]
+			    [else (se (format "bad ~a clause" kind) (syntax decl))]))
+			(syntax->list decls)))]
+		    [body 
+		     ;; Make a list of normalized clause-like lists, e.g:
+		     ;;  (list (list 'public internal-id extenal-id expr) ...)
+		     (apply
+		      append
+		      (map
+		       (lambda (clause)
+			 (syntax-case clause (public override private rename inherit sequence)
+			   [(public decl ...)
+			    (extract-ivars 'public #t (syntax (decl ...)))]
+			   [(override decl ...)
+			    (extract-ivars 'override #t (syntax (decl ...)))]
+			   [(private decl ...)
+			    (extract-ivars 'private #f (syntax (decl ...)))]
+			   [(rename (iid eid) ...)
+			    (let ([iids (syntax->list (syntax (iid ...)))]
+				  [eids (syntax->list (syntax (eid ...)))])
+			      (for-each (lambda (s)
+					  (unless (identifier? s)
+					    (se "expected an identifier" s)))
+					(append iids eids))
+			      (map (lambda (iid eid)
+				     (list 'rename iid eid))
+				   iids eids))]
+			   [(inherit id ...)
+			    (map
+			     (lambda (decl)
+			       (syntax-case decl ()
+				 [id (identifier? (syntax id))
+				     (list 'inherit (syntax id) (syntax id))]
+				 [(iid eid) (and (identifier? (syntax iid))
+						 (identifier? (syntax eid)))
+				  (list 'inherit (syntax iid) (syntax eid))]
+				 [else (se "bad inherit clause" decl)]))
+			     (syntax->list (syntax (id ...))))]
+			   [(sequence expr ...)
+			    (map
+			     (lambda (expr)
+			       (list 'sequence expr))
+			     (syntax->list (syntax (expr ...))))]
+			   [else (se "not a class clause" clause)]))
+		       (syntax->list (syntax (clauses ...)))))]
+		    [get-info (lambda (tags select)
+				(let loop ([body body])
+				  (cond
+				   [(null? body) null]
+				   [(memq (caar body) tags)
+				    (cons (select (car body)) (loop (cdr body)))]
+				   [else (loop (cdr body))])))])
+	       ;; Extract internal and external ids, and create xformed body:
+	       (let ([new-eids (get-info '(public) caddr)]
+		     [use-pre-eids (get-info '(rename) caddr)]
+		     [use-final-eids (get-info '(inherit) caddr)]
+		     [replace-eids (get-info '(override) caddr)]
+		     [inherited-ids (get-info '(inherit rename) cadr)]
+		     [public-ids (get-info '(public override) cadr)]
+		     [private-ids (get-info '(private) cadr)]
+		     [immutable-boxed-ids (append (get-info '(rename) cadr) ;; order matters!
+						  (get-info '(inherit) cadr))]
+		     [mutable-boxed-ids (append (get-info '(override) cadr) ;; order matters!
+						(get-info '(public) cadr))])
+		 (let* ([define-eids (append replace-eids new-eids)]
+			[define-iids (generate-temporaries define-eids)]
+			[body-exprs 
+			 (map
+			  ;; Map each declaration clause to a set!:
+			  (lambda (clause)
+			    (if (eq? (car clause) 'sequence)
+				(cadr clause)
+				(with-syntax ([id (cadr clause)]
+					      [expr (cadddr clause)])
+				  (if (memq (car clause) '(public override))
+				      (let ([eid (caddr clause)])
+					(with-syntax ([nid (let loop ([de define-eids]
+								      [di define-iids])
+							     (if (eq? eid (car de))
+								 (car di)
+								 (loop (cdr de) (cdr di))))])
+					  ;; let sets name for expr:
+					  (syntax (set-box! nid (let ([id expr]) id)))))
+				      (syntax (set! id expr))))))
+			  (get-info '(public override private sequence) values))]
+			[name (syntax-local-infer-name stx)])
+		   ;; Check for duplicates:
+		   (cond
+		    [(check-duplicate-identifier 
+		      (append new-eids use-final-eids replace-eids))
+		     => (lambda (name)
+			  (se "duplicate declaration of external name" name))]
+		    [(check-duplicate-identifier 
+		      (append init-ids (if init-rest-id (list init-rest-id) null)
+			      public-ids inherited-ids private-ids))
+		     => (lambda (name)
+			  (se "duplicate declaration of identifier" name))]
+		    [else (void)])
+		   ;; ---------- build the result ----------
+		   ;; References to non-private ivars are converted to box
+		   ;; references.
+		   (with-syntax ([use-pre-eids use-pre-eids]
+				 [use-final-eids use-final-eids]
+				 [replace-eids replace-eids]
+				 [new-eids new-eids]
+				 [define-eids define-eids]
+				 [(define-iid ...) define-iids]
+				 [(immutable-box-id ...) (generate-temporaries immutable-boxed-ids)]
+				 [(mutable-box-id ...) (generate-temporaries mutable-boxed-ids)]
+				 [(immutable-boxed-id ...) immutable-boxed-ids]
+				 [(mutable-boxed-id ...) mutable-boxed-ids]
+				 [(private-id ...) private-ids]
+				 [body-exprs (if (null? body-exprs)
+						 (syntax ((void)))
+						 body-exprs)]
+				 [init (datum->syntax-object
+					#f
+					(if name
+					    (string->symbol (format "~a-init" name))
+					    'init)
+					#f)]
+				 [name (datum->syntax-object #f name #f)])
+		     (with-syntax ([go 
+				    ;; Create a sequence of case-lambda
+				    ;; clauses, to implement init variable defaults:
+				    (let loop ([vars-so-far null]
+					       [vars-w/def-so-far null]
+					       [def-so-far null]
+					       [init-ids init-ids]
+					       [init-defs init-defs])
+				      (cond
+				       [(null? init-ids)
+					(with-syntax ([(var ...) (reverse vars-so-far)]
+						      [(maybe-inited ...) (generate-temporaries vars-w/def-so-far)]
+						      [(dvar ...) (reverse vars-w/def-so-far)]
+						      [(def ...) (reverse def-so-far)]
+						      [rest-id (if init-rest-id
+								   init-rest-id
+								   null)])
+					  (syntax
+					   ([(var ... maybe-inited ... . rest-id)
+					     (let ([dvar undefined] ...)
+					       (set! dvar (if (eq? maybe-inited needs-init)
+							      def
+							      maybe-inited)) ...
+							      .
+							      body-exprs)])))]
+				       [else
+					(with-syntax ([rest (loop (if (car init-defs)
+								      vars-so-far
+								      (cons (car init-ids) vars-so-far))
+								  (if (car init-defs)
+								      (cons (car init-ids) vars-w/def-so-far)
+								      null)
+								  (if (car init-defs)
+								      (cons (car init-defs) def-so-far)
+								      null)
+								  (cdr init-ids)
+								  (cdr init-defs))])
+					  (if (car init-defs)
+					      (with-syntax ([(var ...) (reverse vars-so-far)]
+							    [(wd-var ...) (reverse vars-w/def-so-far)])
+						(syntax ([(var ... wd-var ...) (init var ... wd-var ... needs-init)]
+							 . rest)))
+					      (syntax rest)))]))]
+				   [go-arity (datum->syntax-object
+					      #f
+					      (let ([req (let loop ([l init-defs][c 0])
+							   (if (or (null? l) (car l))
+							       c
+							       (loop (cdr l) (add1 c))))]
+						    [cnt (length init-ids)])
+						(cond
+						 [init-rest-id
+						  (box req)]
+						 [(< req cnt)
+						  (let loop ([req req])
+						    (if (= req cnt)
+							(list req)
+							(cons req (loop (add1 req)))))]
+						 [else req]))
+					      #f)])
+		       ;; Assemble the result as a `compose-class-info' call,
+		       ;; which does all the run-time checks, and knows how
+		       ;; to allocate objects and pass boxes to the init
+		       ;; function.
+		       (syntax/loc
+			stx
+			(compose-class
+			 'name
+			 super-expr
+			 (list interface-expr ...)
+			 'use-pre-eids   ;; rename
+			 'use-final-eids ;; inherit
+			 'replace-eids   ;; override
+			 'new-eids       ;; public
+			 (lambda (this-id super-init-id 
+					  define-iid ...        ;; override, public
+					  immutable-box-id ...  ;; rename, inherit
+					  mutable-box-id ...)   ;; override, public
+			   (let-syntax ([immutable-boxed-id
+					 (make-set!-transformer
+					  (lambda (stx)
+					    (syntax-case stx (set!)
+					      [vr (identifier? (syntax vr)) 
+						  (syntax (unbox immutable-box-id))]
+					      [(set! vr val)
+					       (raise-syntax-error
+						#f
+						"cannot mutate an inherit or rename variable"
+						stx)]
+					      [(vr . args) (syntax ((unbox immutable-box-id) . args))])))]
+					...
+					[mutable-boxed-id
+					 (make-set!-transformer
+					  (lambda (stx)
+					    (syntax-case stx (set!)
+					      [vr (identifier? (syntax vr)) 
+						  (syntax (unbox mutable-box-id))]
+					      [(set! vr val)
+					       (syntax 
+						(set-box! mutable-box-id 
+							  ;; let vr gives val the right name
+							  (let ([vr val]) vr)))]
+					      [(vr . args) (syntax ((unbox mutable-box-id) . args))])))]
+					...)
+			     (let ([private-id undefined] ...)
+			       (letrec ([init (case-lambda . go)])
+				 init))))
+			 'go-arity
+			 #f)))))))))]
+	;; Error cases
+	;; --
+	[(_ bad-this-super
+	    super-expr
+	    (interface-expr ...)
+	    init-vars
+	    clauses ...)
+	 (raise-syntax-error 
+	  #f
+	  "bad this and super bindings"
+	  stx
+	  (syntax bad-this-super))]
+	;; --
+	[(_ this-super
+	    super-expr
+	    bad-interface-seq
+	    init-vars
+	    clauses ...)
+	 (raise-syntax-error 
+	  #f
+	  "expected sequence of interface expressions"
+	  stx
+	  (syntax bad-interface-seq))]
+	;;
+	[(_ this-super
+	    super-expr
+	    interface-seq)
+	 (raise-syntax-error 
+	  #f
+	  "missing initialization arguments"
+	  stx
+	  (syntax bad-this-super))]
+	[(_ this-super
+	    super-expr)
+	 (raise-syntax-error 
+	  #f
+	  "missing interface expressions"
+	  stx
+	  (syntax bad-this-super))]
+	[(_ this-super)
+	 (raise-syntax-error 
+	  #f
+	  "missing this and super-init bindings"
+	  stx
+	  (syntax bad-this-super))])))
+
+  (define-syntax class*
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ super-expr
+	    (interface-expr ...)
+	    init-vars
+	    clauses ...)
+	 (with-syntax ([this (datum->syntax-object (stx-car stx) 'this stx)]
+		       [super-init (datum->syntax-object (stx-car stx) 'super-init stx)])
+	   (syntax/loc
+	    stx
+	    (class*/names (this super-init)
+			  super-expr 
+			  (interface-expr ...)
+			  init-vars
+			  clauses ...)))])))
+
+  (define-syntax :class
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ super-expr
+	    init-vars
+	    clauses ...)
+	 (with-syntax ([class* (datum->syntax-object (stx-car stx) 'class* stx)])
+	   (syntax/loc stx (class* super-expr () init-vars clauses ...)))])))
+
+  (define-syntax class*-asi
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ super (interface ...) body ...)
+	 (syntax/loc stx (class* super (interface ...) args
+			   body ...))])))
+
+  (define-syntax class-asi
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ super body ...)
+	 (syntax/loc stx (class* super () args
+			   body ...))])))
+  
+  (define-syntax :interface
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ (interface-expr ...) var ...)
+	 (let ([vars (syntax->list (syntax (var ...)))]
+	       [name (syntax-local-infer-name stx)])
+	   (for-each
+	    (lambda (v)
+	      (unless (identifier? v)
+		(raise-syntax-error #f
+				    "not an identifier"
+				    stx
+				    v)))
+	    vars)
+	   (let ([dup (check-duplicate-identifier vars)])
+	     (when dup
+	       (raise-syntax-error #f
+				   "duplicate name"
+				   stx
+				   dup)))
+	   (with-syntax ([name (datum->syntax-object #f name #f)])
+	     (syntax/loc
+	      stx
+	      (compose-interface
+	       'name
+	       (list interface-expr ...)
+	       '(var ...)))))])))
+
+  (provide (rename :class class) class* class*/names
+	   class-asi class*-asi
+	   (rename :interface interface)
+	   make-object object? is-a? subclass? class? interface?
+	   class->interface object-interface
+	   implementation? interface-extension?
+	   ivar-in-interface? interface->ivar-names
+	   class-initialization-arity
+	   ivar send send* make-generic
+	   ivar/proc make-generic/proc
+	   object% ;; object<%>
+	   exn:object? struct:exn:object make-exn:object
+
+	   prop:object make-prim-class))
diff --git a/collects/mzlib/class.ss b/collects/mzlib/class.ss
new file mode 100644
index 0000000000..f98c652bde
--- /dev/null
+++ b/collects/mzlib/class.ss
@@ -0,0 +1,41 @@
+(module class mzscheme
+  
+  ;; All of the implementation is actually in private/class-internal.ss,
+  ;;  which provides extra (private) functionality to contract.ss.
+  (require "private/class-internal.ss")
+  
+  (provide class class* class/derived
+	   define-serializable-class define-serializable-class*
+           class?
+	   mixin
+           interface interface?
+	   object% object? externalizable<%>
+           object=?
+	   new make-object instantiate
+	   send send/apply send* class-field-accessor class-field-mutator with-method
+           get-field field-bound? field-names
+	   private* public*  pubment*
+	   override* overment*
+	   augride* augment*
+	   public-final* override-final* augment-final*
+	   define/private define/public define/pubment
+	   define/override define/overment
+	   define/augride define/augment
+	   define/public-final define/override-final define/augment-final
+	   define-local-member-name
+	   generic make-generic send-generic
+	   is-a? subclass? implementation? interface-extension?
+	   object-interface object-info object->vector
+	   method-in-interface? interface->method-names class->interface class-info
+	   (struct exn:fail:object ())
+	   make-primitive-class
+
+	   ;; "keywords":
+	   private public override augment
+	   pubment overment augride
+           public-final override-final augment-final
+	   field init init-field
+	   rename-super rename-inner inherit
+	   this super inner
+	   super-make-object super-instantiate super-new
+	   inspect))
diff --git a/collects/mzlib/class100.ss b/collects/mzlib/class100.ss
new file mode 100644
index 0000000000..76b51abb62
--- /dev/null
+++ b/collects/mzlib/class100.ss
@@ -0,0 +1,257 @@
+
+(module class100 mzscheme
+  (require "class.ss")
+
+  (require-for-syntax (lib "stx.ss" "syntax"))
+
+  (define-syntax super-init (make-rename-transformer #'super-make-object))
+
+  (define-syntax class100*
+    (lambda (stx)
+      (let ([main
+	     (lambda (stx)
+	       (syntax-case stx ()
+		 [(_ super-expr
+		     (interface-expr ...)
+		     init-vars
+		     clauses ...)
+		  (let ([se (lambda (msg expr)
+			      (raise-syntax-error #f msg stx expr))])
+		    ;; Unpack init arguments, with default expressions:
+		    (let-values ([(init-ids init-defs init-rest-id)
+				  (let loop ([inits (syntax init-vars)][need-def? #f])
+				    (syntax-case inits ()
+				      [() (values null null #f)]
+				      [id 
+				       (identifier? (syntax id))
+				       (values null null (syntax id))]
+				      [(id . rest) 
+				       (identifier? (syntax id))
+				       (begin
+					 (when need-def?
+					   (se "expected identifier with default value" (syntax id)))
+					 (let-values ([(ids defs rest) (loop (syntax rest) #f)])
+					   (values (cons (syntax id) ids)
+						   (cons #f defs)
+						   rest)))]
+				      [((id def) . rest)
+				       (identifier? (syntax id))
+				       (let-values ([(ids defs rest) (loop (syntax rest) #f)])
+					 (values (cons (syntax id) ids)
+						 (cons (syntax def) defs)
+						 rest))]
+				      [(first . rest)
+				       (se "bad initialization declaration" (syntax first))]
+				      [else (se "improper identifier list" (syntax init-vars))]))])
+		      ;; Unpack all body clauses:
+		      (let* ([extract-ivars
+			      ;; Unpacks a public, private, or override clause
+			      (lambda (kind can-rename? decls)
+				(map
+				 (lambda (decl)
+				   (syntax-case decl ()
+				     [id (identifier? (syntax id))
+					 (list kind (syntax id) (syntax id) (syntax/loc (syntax id) (void)))]
+				     [(id expr) (identifier? (syntax id))
+				      (list kind (syntax id) (syntax id) (syntax expr))]
+				     [(id) (and can-rename? (identifier? (syntax id)))
+				      (list kind (syntax id) (syntax id) (syntax/loc (syntax id) (void)))]
+				     [((iid eid) expr) (and can-rename?
+							    (identifier? (syntax iid))
+							    (identifier? (syntax eid)))
+				      (list kind (syntax iid) (syntax eid) (syntax expr))]
+				     [else (se (format "bad ~a clause" kind) decl)]))
+				 (syntax->list decls)))]
+			     [body 
+			      ;; Make a list of normalized clause-like lists, e.g:
+			      ;;  (list (list 'public internal-id extenal-id expr) ...)
+			      (apply
+			       append
+			       (map
+				(lambda (clause)
+				  (syntax-case clause (public pubment 
+							      override augment 
+							      augride overment
+							      private private-field 
+							      rename inherit sequence)
+				    [(public decl ...)
+				     (extract-ivars 'public #t (syntax (decl ...)))]
+				    [(pubment decl ...)
+				     (extract-ivars 'pubment #t (syntax (decl ...)))]
+				    [(override decl ...)
+				     (extract-ivars 'override #t (syntax (decl ...)))]
+				    [(augment decl ...)
+				     (extract-ivars 'augment #t (syntax (decl ...)))]
+				    [(overment decl ...)
+				     (extract-ivars 'overment #t (syntax (decl ...)))]
+				    [(augride decl ...)
+				     (extract-ivars 'augride #t (syntax (decl ...)))]
+				    [(private decl ...)
+				     (extract-ivars 'private #f (syntax (decl ...)))]
+				    [(private-field decl ...)
+				     (extract-ivars 'private-field #f (syntax (decl ...)))]
+				    [(rename (iid eid) ...)
+				     (let ([iids (syntax->list (syntax (iid ...)))]
+					   [eids (syntax->list (syntax (eid ...)))])
+				       (for-each (lambda (s)
+						   (unless (identifier? s)
+						     (se "expected an identifier" s)))
+						 (append iids eids))
+				       (map (lambda (iid eid)
+					      (list 'rename iid eid))
+					    iids eids))]
+				    [(inherit id ...)
+				     (map
+				      (lambda (decl)
+					(syntax-case decl ()
+					  [id (identifier? (syntax id))
+					      (list 'inherit (syntax id) (syntax id))]
+					  [(iid eid) (and (identifier? (syntax iid))
+							  (identifier? (syntax eid)))
+					   (list 'inherit (syntax iid) (syntax eid))]
+					  [else (se "bad inherit clause" decl)]))
+				      (syntax->list (syntax (id ...))))]
+				    [(sequence expr ...)
+				     (map
+				      (lambda (expr)
+					(list 'sequence expr))
+				      (syntax->list (syntax (expr ...))))]
+				    [else (se "not a class100 clause" clause)]))
+				(syntax->list (syntax (clauses ...)))))]
+			     [get-info (lambda (tags select)
+					 (let loop ([body body])
+					   (cond
+					    [(null? body) null]
+					    [(memq (caar body) tags)
+					     (cons (select (car body)) (loop (cdr body)))]
+					    [else (loop (cdr body))])))]
+			     [make-idp (lambda (x) (list (cadr x) (caddr x)))]
+			     [make-decl (lambda (x) (with-syntax ([name (cadr x)]
+								  [expr (cadddr x)])
+						      (syntax (define-values (name) expr))))]
+			     [make-seq (lambda (x) (if (eq? (car x) 'private-field)
+						       (with-syntax ([name (cadr x)]
+								     [expr (cadddr x)])
+							 (syntax (define-values (name) expr)))
+						       (cadr x)))])
+			;; Extract internal and external ids, and create xformed body:
+			(with-syntax ([public-ipds (get-info '(public) make-idp)]
+				      [pubment-ipds (get-info '(pubment) make-idp)]
+				      [override-ipds (get-info '(override) make-idp)]
+				      [augment-ipds (get-info '(augment) make-idp)]
+				      [overment-ipds (get-info '(overment) make-idp)]
+				      [augride-ipds (get-info '(augride) make-idp)]
+				      [rename-ipds (get-info '(rename) make-idp)]
+				      [inherit-ipds (get-info '(inherit) make-idp)]
+				      [private-ids (get-info '(private) (lambda (x) (cadr x)))]
+				      
+				      [(method-decl ...) (get-info '(public override augment 
+									    pubment overment augride 
+									    private) 
+								   make-decl)]
+				      [(expr ...) (get-info '(private-field sequence) make-seq)]
+				      [(init-expr ...) (let loop ([init-ids init-ids]
+								  [init-defs init-defs])
+							 (cond
+							  [(null? init-ids)
+							   (if init-rest-id
+							       (with-syntax ([init-rest-id init-rest-id])
+								 (list (syntax (init-rest init-rest-id))))
+							       (list (syntax (init-rest))))]
+							  [(car init-defs)
+							   (with-syntax ([id (car init-ids)]
+									 [def (car init-defs)])
+							     (cons (syntax (init [id def]))
+								   (loop (cdr init-ids)
+									 (cdr init-defs))))]
+							  [else
+							   (with-syntax ([id (car init-ids)])
+							     (cons (syntax (init id))
+								   (loop (cdr init-ids)
+									 (cdr init-defs))))]))]
+				      [super-instantiate-id (if (stx-pair? #'optional-super-inst-id)
+								(stx-car #'optional-super-inst-id)
+								'super-instantiate)])
+			  (syntax/loc stx
+			    (class* super-expr (interface-expr ...)
+			     init-expr ...
+			     (private . private-ids)
+			     (public . public-ipds)
+			     (pubment . pubment-ipds)
+			     (override . override-ipds)
+			     (augment . augment-ipds)
+			     (overment . overment-ipds)
+			     (augride . augride-ipds)
+			     (rename-super . rename-ipds)
+			     (inherit . inherit-ipds)
+			     method-decl ...
+			     expr ...))))))]))])
+
+	(syntax-case stx ()
+	  [(_ super-expr
+	      (interface-expr ...)
+	      init-vars
+	      clauses ...)
+	   (main stx)]
+	  
+	  ;; Error cases
+	  ;; --
+	  ;; --
+	  [(_ super-expr
+	      bad-interface-seq
+	      init-vars
+	      clauses ...)
+	   (raise-syntax-error 
+	    #f
+	    "expected sequence of interface expressions"
+	    stx
+	    (syntax bad-interface-seq))]
+	  ;;
+	  [(_ super-expr
+	      interface-seq)
+	   (raise-syntax-error 
+	    #f
+	    "missing initialization arguments"
+	    stx
+	    (syntax bad-this-super))]
+	  [(_ super-expr)
+	   (raise-syntax-error 
+	    #f
+	    "missing interface expressions"
+	    stx
+	    (syntax bad-this-super))]
+	  [(_)
+	   (raise-syntax-error 
+	    #f
+	    "missing superclass expression and interface expressions"
+	    stx
+	    (syntax bad-this-super))]))))
+
+  (define-syntax class100
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ super-expr
+	    init-vars
+	    clauses ...)
+	 (syntax/loc stx 
+	   (class100* super-expr () init-vars 
+		      clauses ...))])))
+
+  (define-syntax class100*-asi
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ super (interface ...) body ...)
+	 (syntax/loc stx 
+	   (class100*  super (interface ...) args 
+		       body ... (sequence (apply super-init args))))])))
+
+  (define-syntax class100-asi
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ super body ...)
+	 (syntax/loc stx 
+	   (class100* super () args 
+		      body ... (sequence (apply super-init args))))])))
+
+  (provide class100 class100*
+	   class100-asi class100*-asi super-init))
diff --git a/collects/mzlib/cm-accomplice.ss b/collects/mzlib/cm-accomplice.ss
new file mode 100644
index 0000000000..e58b4b6a64
--- /dev/null
+++ b/collects/mzlib/cm-accomplice.ss
@@ -0,0 +1,19 @@
+(module cm-accomplice mzscheme
+  (provide register-external-file)
+
+  (define (register-external-file f)
+    (unless (and (path? f)
+		 (complete-path? f))
+      (raise-type-error 'register-external-file "complete path" f))
+    (let ([param (lambda () void)])
+      ;; Load the code in a separate thread, so that the dynamic
+      ;; extent of this one (likely a phase-sensitive macro expansion)
+      ;; doesn't pollute the load:
+      (thread-wait 
+       (thread (lambda ()
+		 (set! param
+		       (dynamic-require '(lib "cm-ctime.ss" "mzlib" "private")
+					'current-external-file-registrar)))))
+      ((param) f))))
+
+
diff --git a/collects/mzlib/cm.ss b/collects/mzlib/cm.ss
new file mode 100644
index 0000000000..166190f93d
--- /dev/null
+++ b/collects/mzlib/cm.ss
@@ -0,0 +1,280 @@
+(module cm mzscheme
+  (require (lib "moddep.ss" "syntax")
+	   (lib "plthome.ss" "setup")
+	   (lib "file.ss"))
+
+  (provide make-compilation-manager-load/use-compiled-handler
+	   managed-compile-zo
+	   make-caching-managed-compile-zo
+	   trust-existing-zos
+	   manager-compile-notify-handler
+	   (rename trace manager-trace-handler))
+  
+  (define manager-compile-notify-handler (make-parameter void))
+  (define trace (make-parameter void))
+  (define indent (make-parameter ""))
+  (define trust-existing-zos (make-parameter #f))
+
+  (define (trace-printf fmt . args) ((trace) (string-append (indent) (apply format fmt args))))
+  
+  (define my-max
+    (case-lambda
+      (() 0)
+      (x (apply max x))))
+  
+  (define (get-deps code path)
+    (let-values ([(imports fs-imports ft-imports) (module-compiled-imports code)])
+      (map path->bytes
+	   (map (lambda (x)
+		  (resolve-module-path-index x path))
+		;; Filter symbols:
+		(let loop ([l (append imports fs-imports ft-imports)])
+		  (cond
+		   [(null? l) null]
+		   [(symbol? (car l)) (loop (cdr l))]
+		   [else (cons (car l) (loop (cdr l)))]))))))
+
+  (define (get-compilation-dir+name mode path)
+    (let-values (((base name-suffix must-be-dir?) (split-path path)))
+      (let ((name (path-replace-suffix name-suffix #"")))
+	(values
+	 (cond
+	  ((eq? 'relative base) mode)
+	  (else (build-path base mode)))
+	 name))))
+
+  (define (get-compilation-path mode path)
+    (let-values ([(dir name) (get-compilation-dir+name mode path)])
+      (path->bytes (build-path dir name))))
+
+  (define (get-code-dir mode path)
+    (let-values (((base name-suffix must-be-dir?) (split-path path)))
+      (cond
+        ((eq? 'relative base) mode)
+        (else (build-path base mode)))))
+
+  (define (write-deps code mode path external-deps)
+    (let ((dep-path (bytes->path
+		     (bytes-append (get-compilation-path mode path) #".dep")))
+          (deps (get-deps code path)))
+      (let ((op (open-output-file dep-path 'replace)))
+        (write (cons (version)
+		     (append (map plthome-ify deps)
+			     (map (lambda (x) (plthome-ify (cons 'ext x)))
+                                  external-deps)))
+	       op)
+        (newline op)
+        (close-output-port op))))
+
+  (define (touch path)
+    (close-output-port (open-output-file path 'append)))
+
+  (define (compilation-failure mode path zo-name date-path reason)
+    (with-handlers ((exn:fail:filesystem? void))
+      (delete-file zo-name))
+    (let ([fail-path (bytes->path
+		      (bytes-append (get-compilation-path mode path) #".fail"))])
+      (let ([p (open-output-file fail-path 'truncate/replace)])
+	(display reason p)
+	(close-output-port p)))
+    (trace-printf "failure"))
+
+  (define (compile-zo mode path)
+    ((manager-compile-notify-handler) path)
+    (trace-printf "compiling: ~a" path)
+    (parameterize ([indent (string-append "  " (indent))])
+      (let ([zo-name (bytes->path (bytes-append (get-compilation-path mode path) #".zo"))])
+        (cond
+         [(and (file-exists? zo-name) (trust-existing-zos)) (touch zo-name)]
+         [else
+          (when (file-exists? zo-name) (delete-file zo-name))
+          (with-handlers ([exn:get-module-code?
+                           (lambda (ex)
+                             (compilation-failure
+                              mode path zo-name (exn:get-module-code-path ex)
+			      (exn-message ex)))])
+            (let* ([param
+                    ;; Avoid using cm while loading cm-ctime:
+                    (parameterize ([use-compiled-file-paths null])
+                      (dynamic-require '(lib "cm-ctime.ss" "mzlib" "private")
+                                       'current-external-file-registrar))]
+                   [external-deps null]
+                   [code (parameterize ([param (lambda (ext-file)
+                                                 (set! external-deps
+                                                       (cons (path->bytes ext-file)
+                                                             external-deps)))])
+                           (get-module-code path mode))]
+                   [code-dir (get-code-dir mode path)])
+              (if (not (directory-exists? code-dir))
+                (make-directory* code-dir))
+              (let ((out (open-output-file zo-name 'replace)))
+                (with-handlers ((exn:fail?
+                                 (lambda (ex) (compilation-failure mode path zo-name #f (exn-message ex)))))
+                  (dynamic-wind
+                    void
+                    (lambda () (write code out))
+                    (lambda () (close-output-port out)))))
+              (let ([ss-sec (file-or-directory-modify-seconds path)]
+                    [zo-sec (if (file-exists? zo-name)
+				(file-or-directory-modify-seconds zo-name)
+				+inf.0)])
+                (when (< zo-sec ss-sec)
+                  (error 'compile-zo
+                         "date for newly created .zo file (~a @ ~a) is before source-file date (~a @ ~a)~a"
+                         zo-name
+                         (format-date (seconds->date zo-sec))
+                         path
+                         (format-date (seconds->date ss-sec))
+                         (if (> ss-sec (current-seconds))
+                           ", which appears to be in the future"
+                           ""))))
+              (write-deps code mode path external-deps)))])))
+    (trace-printf "end compile: ~a" path))
+
+  (define (format-date date)
+    (format "~a:~a:~a:~a:~a:~a"
+	    (date-year date)
+	    (date-month date)
+	    (date-day date)
+	    (date-hour date)
+	    (date-minute date)
+	    (date-second date)))
+  
+  (define (append-object-suffix f)
+    (path-replace-suffix f (case (system-type)
+			     [(windows) #".dll"]
+			     [else #".so"])))
+
+  (define _loader-path (append-object-suffix (bytes->path #"_loader")))
+
+  (define (get-compiled-time mode path w/fail?)
+    (let*-values  ([(dir name) (get-compilation-dir+name mode path)])
+      (first-date
+       (lambda () (build-path dir "native" (system-library-subpath) _loader-path))
+       (lambda () (build-path dir "native" (system-library-subpath) (append-object-suffix name)))
+       (lambda () (build-path dir (path-replace-suffix name #".zo")))
+       (and w/fail? (lambda () (build-path dir (path-replace-suffix name #".fail")))))))
+
+  (define first-date
+    (case-lambda
+     [() -inf.0]
+     [(f . l)
+      (if f
+	  (with-handlers ([exn:fail:filesystem?
+			   (lambda (ex)
+			     (apply first-date l))])
+            (let ([name (f)])
+              (file-or-directory-modify-seconds name)))
+	  (apply first-date l))]))
+  
+  (define (compile-root mode path up-to-date)
+    (let ([path (simplify-path (expand-path path))])
+      (let ((stamp (and up-to-date
+			(hash-table-get up-to-date path (lambda () #f)))))
+	(cond
+          (stamp stamp)
+          (else
+           (trace-printf "checking: ~a" path)
+           (let ((path-zo-time (get-compiled-time mode path #f))
+                 (path-time 
+                  (with-handlers ((exn:fail:filesystem? 
+                                   (lambda (ex)
+                                     (trace-printf "~a does not exist" path)
+                                     #f)))
+                    (file-or-directory-modify-seconds path))))
+             (cond
+               ((not path-time) path-zo-time)
+               (else
+                (cond
+                  ((> path-time path-zo-time) 
+		   (trace-printf "newer src...")
+		   (compile-zo mode path))
+                  (else
+                   (let ((deps (with-handlers ((exn:fail:filesystem? (lambda (ex) (list (version)))))
+                                 (call-with-input-file (bytes->path 
+							(bytes-append (get-compilation-path mode path) #".dep"))
+                                   read))))
+                     (cond
+                       ((or (not (pair? deps))
+                            (not (equal? (version) (car deps))))
+			(trace-printf "newer version...")
+                        (compile-zo mode path))
+                       ((ormap (lambda (d)
+				 ;; str => str is a module file name (check transitive dates)
+				 ;; (cons 'ext str) => str is an non-module file (check date)
+				 (let ([t (cond
+					   [(bytes? d) (compile-root mode (bytes->path d) up-to-date)]
+					   [(path? d) (compile-root mode d up-to-date)]
+					   [(and (pair? d) (eq? (car d) 'ext))
+					    (with-handlers ((exn:fail:filesystem?
+							     (lambda (ex) +inf.0)))
+					      (file-or-directory-modify-seconds (cdr d)))]
+					   [else -inf.0])])
+				   (when (> t path-zo-time)
+				     (trace-printf "newer: ~a (~a > ~a)..." d t path-zo-time))
+				   (> t path-zo-time)))
+			       (map un-plthome-ify (cdr deps)))
+                        (compile-zo mode path))))))
+                (let ((stamp (get-compiled-time mode path #t)))
+                  (hash-table-put! up-to-date path stamp)
+                  stamp)))))))))
+  
+  (define (managed-compile-zo zo)
+    ((make-caching-managed-compile-zo) zo))
+  
+  (define (make-caching-managed-compile-zo)
+    (let ([cache (make-hash-table 'equal)])
+      (lambda (zo)
+	(parameterize ([current-load/use-compiled (make-compilation-manager-load/use-compiled-handler/table cache)])
+	  (compile-root (car (use-compiled-file-paths)) (path->complete-path zo) cache)))))
+
+  (define (make-compilation-manager-load/use-compiled-handler)
+    (make-compilation-manager-load/use-compiled-handler/table (make-hash-table 'equal)))
+
+  (define (make-compilation-manager-load/use-compiled-handler/table cache)
+    (let ([orig-eval (current-eval)]
+	  [orig-load (current-load)]
+	  [orig-namespace (current-namespace)]
+	  [default-handler (current-load/use-compiled)]
+	  [modes (use-compiled-file-paths)])
+      (when (null? modes)
+	(raise-mismatch-error 'make-compilation-manager-... 
+			      "empty use-compiled-file-paths list: "
+			      modes))
+      (letrec ([compilation-manager-load-handler
+		(lambda (path mod-name)
+		  (cond
+                    [(not mod-name)
+                     (trace-printf "skipping:  ~a mod-name ~s" path mod-name)
+                     (default-handler path mod-name)]
+                    [(not (member (car modes) (use-compiled-file-paths)))
+                     (trace-printf "skipping:  ~a compiled-paths ~s" path (use-compiled-file-paths))
+                     (default-handler path mod-name)]
+                    [(not (eq? compilation-manager-load-handler (current-load/use-compiled)))
+                     (trace-printf "skipping:  ~a current-load/use-compiled changed ~s" 
+                                   path
+                                   (current-load/use-compiled))
+                     (default-handler path mod-name)]
+                    [(not (eq? orig-eval (current-eval)))
+                     (trace-printf "skipping:  ~a orig-eval ~s current-eval ~s" 
+                                   path orig-eval 
+                                   (current-eval))
+                     (default-handler path mod-name)]
+                    [(not (eq? orig-load (current-load)))
+                     (trace-printf "skipping:  ~a orig-load ~s current-load ~s" 
+                                   path
+                                   orig-load
+                                   (current-load))
+                     (default-handler path mod-name)]
+                    [(not (eq? orig-namespace (current-namespace)))
+                     (trace-printf "skipping:  ~a orig-namespace ~s current-namespace ~s" 
+                                   path
+                                   orig-namespace
+                                   (current-namespace))
+                     (default-handler path mod-name)]
+                    [else 
+                     (trace-printf "processing: ~a" path)
+                     (compile-root (car modes) path cache)
+		     (trace-printf "done: ~a" path)
+                     (default-handler path mod-name)]))])
+	compilation-manager-load-handler))))
diff --git a/collects/mzlib/cmdline.ss b/collects/mzlib/cmdline.ss
new file mode 100644
index 0000000000..65c659af42
--- /dev/null
+++ b/collects/mzlib/cmdline.ss
@@ -0,0 +1,538 @@
+
+(module cmdline mzscheme
+
+  (define-syntax command-line
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ program-name
+	    argv
+	    clause ...)
+	 (let ([serror
+		(lambda (msg . detail)
+		  (apply
+		   raise-syntax-error
+		   #f
+		   msg
+		   stx
+		   detail))])
+	   (let ([extract-one
+                  (lambda (what args . detail)
+                    (if (null? args)
+                      (apply serror (format "missing ~a" what) detail)
+                      (values (car args) (cdr args))))]
+                 [extract-list
+                  (lambda (stx/list pred)
+                    (let loop ([xs null]
+                               [rest (if (syntax? stx/list) (syntax->list stx/list) stx/list)])
+                      (if (and (pair? rest) (pred (car rest)))
+                        (loop (cons (car rest) xs) (cdr rest))
+                        (values (reverse xs) rest))))]
+		 [formal-names
+		  (lambda (l)
+		    (map
+		     (lambda (a)
+		       (datum->syntax-object
+			(quote-syntax here)
+			(let ([s (symbol->string (syntax-e a))])
+			  (if (char=? #\* (string-ref s (sub1 (string-length s))))
+			      (substring s 0 (sub1 (string-length s)))
+			      s))
+			#f))
+		     l))])
+	     (let ([clauses
+		    (let loop ([csrcs (syntax->list (syntax (clause ...)))][clauses null])
+		      (with-syntax ([(clause ...) clauses])
+			(if (null? csrcs)
+			    (syntax ((list clause ...) (lambda (accum) (void)) null))
+			    (let ([line (car csrcs)]
+				  [arest (cdr csrcs)])
+			      (syntax-case line (help-labels => args)
+				[(help-labels s ...)
+				 (begin
+				   (unless (andmap (lambda (x) (string? (syntax-e x)))
+						   (syntax->list (syntax (s ...))))
+				     (serror "help-labels clause must contain only strings" line))
+				   (loop arest
+					 (syntax (clause 
+						  ...
+						  '(help-labels s ...)))))]
+				[(tag . rest)
+				 (ormap (lambda (x) (module-identifier=? (syntax tag) x))
+					(syntax->list (syntax (once-each once-any multi final))))
+				 (with-syntax 
+				     ([sublines
+				       (let slloop ([sublines (syntax->list (syntax rest))])
+					 (if (null? sublines)
+					     (syntax ())
+					     (with-syntax 
+						 ([looped (slloop (cdr sublines))]
+						  [subline
+						   (with-syntax 
+						       ([flags 
+							 (syntax-case (car sublines) ()
+							   [((flag ...) . rest)
+							    (begin
+							      (unless (andmap 
+								       (lambda (x) (string? (syntax-e x)))
+								       (syntax->list (syntax (flag ...))))
+								(serror 
+								 "flag specification is not a string or sequence of strings" 
+								 (syntax (flag ...))))
+							      (syntax (flag ...)))]
+							   [(flag . rest)
+							    (string? (syntax-e (syntax flag)))
+							    (syntax (flag))]
+							   [else
+							    (serror "clause does not start with flags")])])
+						     (syntax-case (car sublines) (=>)
+						       [(_ => a b)
+							(syntax (list 'flags a b))]
+						       [(_ rest ...)
+							(let*-values ([(formals rest)
+                                                                       (extract-list (syntax (rest ...)) identifier?)]
+								      [(helps rest)
+                                                                       (extract-list
+                                                                        rest (lambda (x) (string? (syntax-e x))))]
+								      [(expr1 rest)
+								       (extract-one
+									"handler body expressions" rest line)])
+                                                          (when (null? helps)
+                                                            (serror "missing help string/s"))
+							  (with-syntax ([formals formals]
+									[formal-names (formal-names formals)]
+									[helps helps]
+									[expr1 expr1]
+									[rest rest])
+							    (syntax (list 'flags
+									  (lambda (flag . formals)
+									    expr1 . rest)
+									  '(helps . formal-names)))))]))])
+					       (syntax (subline . looped)))))])
+				   (loop arest
+					 (syntax (clause
+						  ...
+						  (list 'tag . sublines)))))]
+				[(=> finish-proc arg-help help-proc unknown-proc)
+				 (begin
+				   (unless (null? arest)
+				     (serror "=> must be the last clause line"))
+				   (syntax ((list clause
+						  ...)
+					    finish-proc arg-help help-proc unknown-proc)))]
+				[(=> finish-proc arg-help help-proc)
+				 (begin
+				   (unless (null? arest)
+				     (serror "=> must be the last clause line"))
+				   (syntax ((list clause
+						  ...)
+					    finish-proc arg-help help-proc)))]
+				[(=> finish-proc arg-help)
+				 (begin
+				   (unless (null? arest)
+				     (serror "=> must be the last clause line"))
+				   (syntax ((list clause
+						  ...)
+					    finish-proc arg-help)))]
+				[(=> . _)
+				 (serror "bad => line" line)]
+				[(args arg-formals body1 body ...)
+				 (begin
+				   (unless (null? arest)
+				     (serror "args must be the last clause" line))
+				   (let ([formals
+					  (let loop ([f (syntax arg-formals)])
+					    (syntax-case f ()
+					      [() null]
+					      [(arg . rest)
+					       (identifier? (syntax arg))
+					       (cons (syntax arg) (loop (syntax rest)))]
+					      [arg
+					       (identifier? (syntax arg))
+					       (list (syntax arg))]
+					      [else
+					       (serror "bad argument list" line)]))])
+				     (with-syntax ([formal-names (formal-names formals)])
+				       (syntax ((list clause
+						      ...)
+						(lambda (accume . arg-formals)
+						  body1 body ...)
+						'formal-names)))))]
+				[(args . _)
+				 (serror "bad args line" line)]
+				[else (serror "not a once-each, once-any, multi, final, args, or => line" line)])))))])
+	       (with-syntax ([clauses clauses])
+		 (syntax
+		  (parse-command-line
+		   program-name argv
+		   . clauses))))))])))
+
+  (define number-regexp (regexp "^[-+][0-9]*(|[.][0-9]*)$"))
+  
+  (define print-args
+    (lambda (port l f)
+      (let loop ([l l][a (letrec ([a (procedure-arity f)]
+				  [a-c (lambda (a)
+					 (cond
+					  [(number? a) (cons (sub1 a) (sub1 a))]
+					  [(arity-at-least? a) 
+					   (let ([v (sub1 (arity-at-least-value a))])
+					     (cons v v))]
+					  [else (let ([r (map a-c a)])
+						  (cons (apply min (map car r))
+							(apply max (map cdr r))))]))])
+			   (a-c a))])
+	(unless (null? l)
+	  (fprintf port " ~a<~a>~a" 
+		   (if (positive? (car a)) "" "[")
+		   (car l)
+		   (if (positive? (car a)) "" "]"))
+	  (unless (positive? (cdr a))
+	    (fprintf port " ..."))
+	  (loop (cdr l) (cons (sub1 (car a)) (sub1 (cdr a))))))))
+
+  (define (procedure-arity-includes-at-least? p n)
+    (letrec ([a-c
+	      (lambda (a)
+		(cond
+		 [(number? a) (>= a n)]
+		 [(arity-at-least? a) #t]
+		 [else (ormap a-c a)]))])
+      (a-c (procedure-arity p))))
+
+  (define parse-command-line
+    (case-lambda
+     [(program arguments table finish finish-help)
+      (parse-command-line program arguments table finish finish-help
+			  (lambda (s)
+			    (display s)
+			    (exit 0)))]
+     [(program arguments table finish finish-help help)
+      (parse-command-line program arguments table finish finish-help help
+			  (lambda (flag)
+			    (error (string->symbol program) "unknown flag: ~s" flag)))]
+     [(program arguments table finish finish-help help unknown-flag)
+      (unless (string? program)
+	(raise-type-error 'parse-command-line "program name string" program))
+      (unless (and (vector? arguments)
+		   (andmap string? (vector->list arguments)))
+	(raise-type-error 'parse-command-line "argument vector of strings" arguments))
+      (unless (and (list? table)
+		   (let ([bad-table
+			  (lambda (reason)
+			    (raise-type-error 'parse-command-line 
+					      (format "table as a list of flag-list/procedure pairs (~a)" 
+						      reason)
+					      table))])
+		     (andmap 
+		      (lambda (spec)
+			(and (or (and (list? spec) (pair? spec))
+				 (bad-table (format "spec-set must be a non-empty list: ~a" spec)))
+			     (or (memq (car spec) '(once-any once-each multi final help-labels))
+				 (bad-table (format "spec-set type must be 'once-any, 'once-each, 'multi, 'final, or 'help-labels: ~a" 
+						    (car spec))))
+			     (andmap 
+			      (lambda (line)
+				(if (eq? (car spec) 'help-labels)
+
+				    (or (string? line)
+					(bad-table (format "help-labels line must be a string: ~e" line)))
+
+				    (and (or (and (list? line) (= (length line) 3))
+					     (bad-table (format "spec-line must be a list of at three or four items: ~e" line)))
+
+					 (or (list? (car line))
+					     (bad-table (format "flags part of a spec-line must be a list: ~e" (car line))))
+
+					 (andmap
+					  (lambda (flag)
+					    (or (string? flag)
+						(bad-table (format "flag must be a string: ~e" flag)))
+					    (or (and (or (regexp-match #rx"^-[^-]$" flag)
+							 (regexp-match #rx"^[+][^+]$" flag)
+							 (regexp-match #rx"^--." flag)
+							 (regexp-match #rx"^[+][+]." flag))
+						     (not (or (regexp-match #rx"^--help$" flag)
+							      (regexp-match #rx"^-h$" flag)
+							      (regexp-match number-regexp flag))))
+						(bad-table (format "no ill-formed or pre-defined flags: ~e" flag))))
+					  (car line))
+
+					 (or (procedure? (cadr line))
+					     (bad-table (format "second item in a spec-line must be a procedure: ~e" (cadr line))))
+
+					 (let ([a (procedure-arity (cadr line))])
+					   (or (and (number? a)
+						    (or (>= a 1)
+							(bad-table (format "flag handler procedure must take at least 1 argument: ~e" 
+									   (cadr line)))))
+					       (arity-at-least? a)
+					       (bad-table (format "flag handler procedure cannot have multiple cases: ~e" (cadr line)))))
+
+					 (or (let ([h (caddr line)])
+                                               (and (pair? h)
+                                                    (or (string? (car h))
+                                                        (andmap string? (car h)))
+                                                    (andmap string? (cdr h))))
+					     (bad-table (format "spec-line help section must be a list of string-or-string-list and strings")))
+
+					 (or (let ([l (length (caddr line))]
+						   [a (procedure-arity (cadr line))])
+					       (if (number? a)
+						   (= a l)
+						   (and (>= l 1)
+							(>= l (arity-at-least-value a)))))
+					     (bad-table (format "spec-line help list strings must match procedure arguments"))))))
+			      (cdr spec))))
+		      table)))
+	(raise-type-error 'parse-command-line "table of spec sets" table))
+      (unless (and (procedure? finish)
+		   (procedure-arity-includes-at-least? finish 1))
+	(raise-type-error 'parse-command-line "finish procedure accepting at least 1 argument" finish))
+      (unless (and (list? finish-help) (andmap string? finish-help))
+	(raise-type-error 'parse-command-line "argument help list of strings" finish-help))
+      (unless (and (procedure? help) (procedure-arity-includes? help 1))
+	(raise-type-error 'parse-command-line "help procedure of arity 1" help))
+      (unless (and (procedure? unknown-flag) (procedure-arity-includes? unknown-flag 1)
+		   (let ([a (procedure-arity unknown-flag)])
+		     (or (number? a) (arity-at-least? a))))
+	(raise-type-error 'parse-command-line "unknown-flag procedure of simple arity, accepting 1 argument (an perhaps more)" unknown-flag))
+
+      (letrec ([a (procedure-arity finish)]
+	       [l (length finish-help)]
+	       [a-c (lambda (a)
+		      (or (and (number? a) (sub1 a))
+			  (and (arity-at-least? a)
+			       (max 1 (arity-at-least-value a)))
+			  (and (list? a) (apply max (map a-c a)))))])
+	(unless (= (a-c a) l)
+	  (error 'parse-command-line "the length of the argument help string list does not match the arity of the finish procedure")))
+
+      (let* ([finalled? #f] ; set to true when 'once-final is seen
+             [once-spec-set
+	      (lambda (lines)
+		(let ([set (cons #f (apply append (map car lines)))])
+		  (map
+		   (lambda (line) (cons set line))
+		   lines)))]
+             [first? (lambda (x lst)
+                       (and (pair? lst) (eq? x (car lst))))]
+             [last? (lambda (x lst)
+                      (and (pair? lst)
+                           (let loop ([l lst])
+                             (if (pair? (cdr l))
+                               (loop (cdr l))
+                               (eq? x (car l))))))]
+	     [table
+              ;; list of (list <once-set> <spec-line> ...)
+              ;; If <once-set> is #f, then flags in <spec-line> are allowed
+              ;;  any number of times.
+              ;; If <once-set> is 'final, then its like #f, and `finalled?' should
+              ;;  be set.
+              ;; Otherwise, <once-set> is (list <bool> <string> ...) where <bool>
+              ;;  starts as #f and is mutated to #t when one of <string> is
+              ;;  matched.
+	      (apply
+	       append
+	       (list
+		(list #f (list "--help" "-h")
+		      (lambda (f)
+			(let* ([sp (open-output-string)])
+			  (fprintf sp "~a~a" program
+				   (if (null? table)
+				       ""
+				       " [ <flag> ... ]"))
+			  (print-args sp finish-help finish)
+			  (fprintf sp "~n where <flag> is one of~n")
+			  (for-each
+			   (lambda (set)
+			     (if (eq? (car set) 'help-labels)
+				 (for-each
+				  (lambda (line)
+				    (fprintf sp " ~a~n" line))
+				  (cdr set))
+				 (for-each
+				  (lambda (line)
+                                    (let* ([helps (caaddr line)]
+                                           [helps (if (string? helps) (list helps) helps)])
+                                      (for-each
+                                       (lambda (help)
+
+                                         (fprintf sp
+                                                  (cond [(and (eq? (car set) 'once-any)
+                                                              (pair? (cddr set)))
+                                                         (cond
+                                                          [(and (first? line (cdr set))
+                                                                (first? help helps))
+                                                           "/"]
+                                                          [(and (last? line (cdr set))
+                                                                (last? help helps))
+                                                           "\\"]
+                                                          [else "|"])]
+                                                        [(and (memq (car set) '(multi final))
+                                                              (first? help helps))
+                                                         "*"]
+                                                        [else " "]))
+                                         (if (first? help helps)
+                                           (begin
+                                             (let loop ([flags (car line)])
+                                               (let ([flag (car flags)])
+                                                 (fprintf sp " ~a" flag)
+                                                 (print-args sp (cdaddr line) (cadr line)))
+                                               (unless (null? (cdr flags))
+                                                 (fprintf sp ",")
+                                                 (loop (cdr flags))))
+                                             (fprintf sp " :"))
+                                           (fprintf sp "  "))
+                                         (fprintf sp " ~a~n" help))
+                                       helps)))
+				  (cdr set))))
+			   table) ; the original table
+			  (fprintf sp "  --help, -h : Show this help~n")
+			  (fprintf sp "  -- : Do not treat any remaining argument as a flag (at this level)~n")
+			  (when (or (assq 'multi table) (assq 'final table))
+			    (fprintf sp " * Asterisks indicate flags allowed multiple times.~n"))
+			  (when (assq 'once-any table)
+			    (fprintf sp " /|\\ Brackets indicate mutually exclusive flags.~n"))
+			  (fprintf sp " Multiple single-letter flags can be combined after one `-'; for~n")
+			  (fprintf sp "  example: `-h-' is the same as `-h --'~n")
+			  (help (get-output-string sp))))
+		      (list "Help")))
+	       (map
+		(lambda (spec)
+		  (cond
+		   [(eq? (car spec) 'once-each)
+		    (apply
+		     append
+		     (map 
+		      (lambda (line) (once-spec-set (list line)))
+		      (cdr spec)))]
+		   [(eq? (car spec) 'once-any)
+		    (once-spec-set (cdr spec))]
+		   [(eq? (car spec) 'help-labels)
+		    null]
+		   [(eq? (car spec) 'multi)
+		    (map
+		     (lambda (line) (cons #f line))
+		     (cdr spec))]
+                   [(eq? (car spec) 'final)
+                    (map
+                     (lambda (line) (cons 'final line))
+                     (cdr spec))]))
+		table))]
+	     [done
+	      (lambda (args r-acc)
+		(let ([options (reverse r-acc)]
+		      [c (length args)])
+		  (if (procedure-arity-includes? finish (add1 c))
+		      (apply finish options args)
+		      (error (string->symbol (format "~a" program))
+			     (format "expects~a on the command line, given ~a argument~a~a"
+				     (if (null? finish-help)
+					 " no arguments"
+					 (let ([s (open-output-string)])
+					   (parameterize ([current-output-port s])
+					     (print-args s finish-help finish))
+					   (let ([s (get-output-string s)])
+					     (if (equal? 2 (procedure-arity finish))
+						 (format " 1~a" s)
+						 s))))
+				     c
+				     (cond
+				      [(zero? c) "s"]
+				      [(= c 1) ": "]
+				      [else "s: "])
+				     (let loop ([args args])
+				       (if (null? args)
+					   ""
+					   (string-append (car args) " " (loop (cdr args))))))))))]
+	     [call-handler
+	      (lambda (handler flag args r-acc k)
+		(let* ([a (procedure-arity handler)]
+		       [remaining (length args)]
+		       [needed (if (number? a)
+				   (sub1 a)
+				   (sub1 (arity-at-least-value a)))]
+		       [use (if (number? a)
+				(sub1 a)
+				remaining)])
+		  (if (< remaining needed)
+		      (error (string->symbol (format "~a" program))
+			     "the ~s flag needs ~a argument~a, but ~a~a provided"
+			     flag needed (if (> needed 1) "s" "")
+                             (if (zero? remaining) "" "only ")
+			     remaining)
+		      (let ([v (apply handler 
+				      flag
+				      (let loop ([n use][args args])
+					(if (zero? n)
+					    null
+					    (cons (car args)
+						  (loop (sub1 n) (cdr args))))))])
+			(k (list-tail args use)
+			   (if (void? v)
+			       r-acc
+			       (cons v r-acc)))))))]
+	     [handle-flag
+	      (lambda (flag args r-acc orig-multi k)
+		(let loop ([table table])
+		  (cond
+		   [(null? table)
+		    (call-handler unknown-flag flag args r-acc k)]
+		   [(member flag (cadar table))
+		    (when (eq? 'final (caar table))
+                      (set! finalled? #t))
+		    (when (pair? (caar table))
+		      (let ([set (caar table)])
+			(if (car set)
+			    (let ([flags (cdr set)])
+			      (error (string->symbol (format "~a" program))
+				     (let ([s (if (= 1 (length flags))
+						  (format "the ~a flag can only be specified once" (car flags))
+						  (format "only one instance of one flag from ~a is allowed" flags))])
+				       (if orig-multi
+					   (format "~a; note that ~s is shorthand for ~s, in contrast to ~s"
+						   s
+						   orig-multi
+						   (let loop ([prefix (string-ref orig-multi 0)]
+							      [flags (string->list (substring orig-multi 1 (string-length orig-multi)))]
+							      [sep ""])
+						     (if (null? flags)
+							 ""
+							 (format "~a~a~a~a" sep prefix (car flags)
+								 (loop prefix (cdr flags) " "))))
+						   (string-append (substring orig-multi 0 1) orig-multi))
+					   s))))
+			    (set-car! set #t))))
+		    (call-handler (caddar table) flag args r-acc k)]
+		   [else (loop (cdr table))])))])
+	(let loop ([args (vector->list arguments)][r-acc null])
+	  (if (null? args)
+	      (done args r-acc)
+	      (let ([arg (car args)]
+		    [rest (cdr args)])
+		(cond
+                  [finalled?
+                   (done args r-acc)]
+                  [(regexp-match number-regexp arg)
+                   (done args r-acc)]
+                  [(regexp-match "^--$" arg)
+                   (done (cdr args) r-acc)]
+                  [(regexp-match "^[-+][-+]" arg)
+                   (handle-flag arg rest r-acc #f loop)]
+                  [(regexp-match "^[-+]." arg)
+                   (let a-loop ([s (string->list (substring arg 1 (string-length arg)))]
+                                [rest rest]
+                                [r-acc r-acc])
+                     (if (null? s)
+                         (loop rest r-acc)
+                         (handle-flag (string (string-ref arg 0) (car s)) 
+                                      rest r-acc
+                                      arg
+                                      (lambda (args r-acc)
+                                        (a-loop (cdr s) args r-acc)))))]
+                  [else
+                   (done args r-acc)])))))]))
+
+  (provide command-line parse-command-line))
+
+
diff --git a/collects/mzlib/cml.ss b/collects/mzlib/cml.ss
new file mode 100644
index 0000000000..d85ab51368
--- /dev/null
+++ b/collects/mzlib/cml.ss
@@ -0,0 +1,36 @@
+
+(module cml mzscheme
+  (require (lib "contract.ss"))
+
+  (define (spawn thunk)
+    (thread/suspend-to-kill thunk))
+
+  (define (channel)
+    (make-channel))
+
+  (define (channel-recv-evt ch)
+    ch)
+
+  (define (channel-send-evt ch v)
+    (wrap-evt
+     (channel-put-evt ch v)
+     void))
+
+  (define (thread-done-evt th)
+    (thread-dead-evt th))
+  
+  (define (current-time)
+    (current-inexact-milliseconds))
+  (define (time-evt t)
+    (alarm-evt t))
+
+  (provide/contract
+   (spawn ((-> any) . -> . thread?))
+   (channel (-> channel?))
+   (channel-recv-evt (channel? . -> . evt?))
+   (channel-send-evt (channel? any/c . -> . evt?))
+   
+   (thread-done-evt (thread? . -> . evt?))
+   (current-time (-> number?))
+   (time-evt (real? . -> . evt?))))
+
diff --git a/collects/mzlib/compat.ss b/collects/mzlib/compat.ss
new file mode 100644
index 0000000000..3cb804f6c9
--- /dev/null
+++ b/collects/mzlib/compat.ss
@@ -0,0 +1,115 @@
+
+(module compat mzscheme
+  (require "list.ss")
+
+  (provide real-time
+	   1+ 1-
+	   >=? <=? >? <? =?
+	   flush-output-port
+	   sort
+	   gentemp
+	   atom?
+	   putprop getprop
+	   new-cafe
+	   define-structure)
+  
+  (define 1+ add1)
+  (define 1- sub1)
+  
+  (define =? =)
+  (define <? <)
+  (define >? >)
+  (define <=? <)
+  (define >=? >)
+
+  (define atom? (lambda (v) (not (pair? v))))
+
+  (define gentemp gensym)
+
+  (define sort ; Chez argument order
+    (lambda (less-than? l)
+      (mergesort l less-than?)))
+
+  (define flush-output-port flush-output)
+
+  (define real-time current-milliseconds)
+
+  (define table (make-hash-table))
+  (define getprop
+    (case-lambda
+     [(k prop) (getprop k prop #f)]
+     [(k prop def)
+      (let ([al (hash-table-get table k (lambda () #f))])
+	(if al
+	    (let ([v (assq prop al)])
+	      (if v
+		  (cdr v)
+		  def))
+	    def))]))
+  (define putprop
+    (lambda (k prop nv)
+      (let ([al (hash-table-get table k (lambda () '()))])
+	(let ([v (assq prop al)])
+	  (if v
+	      (set-cdr! v nv)
+	      (hash-table-put! table k (cons (cons prop nv) al)))))))
+
+  ;; Chez's new-cafe
+  (define new-cafe 
+    (letrec ([nc
+	      (case-lambda
+	       [() (nc (current-eval))]
+	       [(eval)
+		(let/ec escape
+		  (let ([orig-exit (exit-handler)]
+			[orig-eval (current-eval)])
+		    (dynamic-wind
+			(lambda ()
+			  (current-eval eval)
+			  (exit-handler
+			   (lambda (v) (escape v))))
+			read-eval-print-loop
+			(lambda ()
+			  (current-eval orig-eval)
+			  (exit-handler orig-exit)))))])])
+      nc))
+
+  (define-syntax define-structure
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ (sname field ...))
+	 (syntax (define-structure (sname field ...) ()))]
+	[(_ (sname field ...) ([init-field init] ...))
+	 (andmap identifier? (syntax->list 
+			      (syntax (sname field ... init-field ...))))
+	 (let ([name (symbol->string (syntax-e (syntax sname)))]
+	       [fields (map symbol->string 
+			    (map syntax-e 
+				 (syntax->list (syntax (field ...)))))]
+	       [init-fields (map symbol->string 
+				 (map syntax-e 
+				      (syntax->list (syntax (init-field ...)))))]
+	       [+ (lambda args
+		    (datum->syntax-object
+		     (syntax sname)
+		     (string->symbol (apply string-append args)) 
+		     (syntax sname)))])
+	   (with-syntax ([struct: (+ "struct:" name)]
+			 [make- (+ "make-" name)]
+			 [? (+ name "?")]
+			 [(gs ...)
+			  (apply
+			   append
+			   (map (lambda (f) (list (+ name "-" f)
+						  (+ "set-" name "-" f "!")))
+				(append fields init-fields)))])
+	     (syntax
+	      (define-values (struct: make- ? gs ...)
+		(let ()
+		  (define-struct sname (field ... init-field ...))
+		  (values struct: 
+			  (let ([make- (lambda (field ...)
+					 (make- field ...
+						init ...))])
+			    make-)
+			  ? gs ...))))))]))))
diff --git a/collects/mzlib/compile.ss b/collects/mzlib/compile.ss
new file mode 100644
index 0000000000..088725804f
--- /dev/null
+++ b/collects/mzlib/compile.ss
@@ -0,0 +1,55 @@
+
+(module compile mzscheme
+  (require "file.ss")
+  (provide compile-file)
+  
+  ;; (require (lib "src2src.ss" "compiler"))
+
+  (define compile-file
+    (case-lambda
+     [(src)
+      (let-values ([(base name dir?) (split-path src)])
+	(let ([cdir (build-path
+		     (if (symbol? base)
+			 'same
+			 base)
+		     "compiled")])
+	  (unless (directory-exists? cdir)
+	    (make-directory cdir))
+	  (compile-file src (build-path cdir (path-replace-suffix name #".zo")))))]
+     [(src dest) (compile-file src dest values)]
+     [(src dest filter)
+      (let ([in (open-input-file src)])
+	(dynamic-wind
+	 void
+	 (lambda ()
+	   (port-count-lines! (current-input-port))
+	   (with-handlers ([void
+			    (lambda (exn)
+			      (with-handlers ([void void])
+				(delete-file dest))
+			      (raise exn))])
+	     (let ([out (open-output-file dest 'truncate/replace)]
+		   [ok? #f])
+	       (parameterize ([current-load-relative-directory
+			       (let-values ([(base name dir?) (split-path src)])
+				 (if (eq? base 'relative)
+				     (current-directory)
+				     (path->complete-path base (current-directory))))])
+		 (dynamic-wind
+		     void
+		     (lambda ()
+		       (let loop ()
+			 (let ([r (read-syntax src in)])
+			   (unless (eof-object? r)
+			     (write (compile-syntax (filter (namespace-syntax-introduce r))) out)
+			     (loop))))
+		       (set! ok? #t))
+		     (lambda () 
+		       (close-output-port out)
+		       (unless ok?
+			 (with-handlers ([void void])
+			   (delete-file dest)))))))))
+	 (lambda () (close-input-port in))))
+      dest])))
+
diff --git a/collects/mzlib/contract.ss b/collects/mzlib/contract.ss
new file mode 100644
index 0000000000..db6811375f
--- /dev/null
+++ b/collects/mzlib/contract.ss
@@ -0,0 +1,3215 @@
+#|
+
+improve method arity mismatch contract violation error messages?
+  (abstract out -> and friends even more?)
+
+add struct contracts for immutable structs?
+
+|#
+
+(module contract mzscheme
+  
+  (provide (rename -contract contract)
+           any
+           ->
+           ->d
+           ->*
+           ->d*
+           ->r
+           ->pp
+           ->pp-rest
+           case->
+	   opt->
+           opt->*
+           object-contract
+           provide/contract
+           define/contract
+	   contract?
+           contract-name
+           flat-contract?
+           flat-contract
+           flat-contract-predicate
+           flat-named-contract
+           
+           contract-proc)
+
+  (require-for-syntax mzscheme
+                      "list.ss"
+                      (lib "stx.ss" "syntax")
+                      (lib "name.ss" "syntax"))
+  
+  (require "private/class-internal.ss"
+           "etc.ss"
+           "list.ss"
+           "pretty.ss")
+  
+  (require (lib "contract-helpers.scm" "mzlib" "private"))
+  (require-for-syntax (prefix a: (lib "contract-helpers.scm" "mzlib" "private")))
+
+  
+  
+;                                                                                                    
+;                                                                                                    
+;                                                                                                    
+;       ;           ;;; ;                     ;                                                      
+;       ;          ;                          ;                                                      
+;       ;          ;                         ;                           ;                       ;   
+;    ;; ;    ;;;  ;;;;  ;   ; ;;     ;;;     ;     ;;;    ;;;    ; ;;   ;;;;  ; ;  ;;;     ;;;  ;;;; 
+;   ;  ;;   ;   ;  ;    ;   ;;  ;   ;   ;    ;    ;   ;  ;   ;   ;;  ;   ;    ;;  ;   ;   ;   ;  ;   
+;  ;    ;  ;    ;  ;    ;   ;   ;  ;    ;    ;   ;      ;     ;  ;   ;   ;    ;       ;  ;       ;   
+;  ;    ;  ;;;;;;  ;    ;   ;   ;  ;;;;;;   ;    ;      ;     ;  ;   ;   ;    ;    ;;;;  ;       ;   
+;  ;    ;  ;       ;    ;   ;   ;  ;        ;    ;      ;     ;  ;   ;   ;    ;   ;   ;  ;       ;   
+;   ;  ;;   ;      ;    ;   ;   ;   ;       ;     ;   ;  ;   ;   ;   ;   ;    ;   ;   ;   ;   ;  ;   
+;    ;; ;    ;;;;  ;    ;   ;   ;    ;;;;  ;       ;;;    ;;;    ;   ;    ;;  ;    ;;;;;   ;;;    ;; 
+;                                          ;                                                         
+;                                          ;                                                         
+;                                                                                                    
+
+  
+  ;; (define/contract id contract expr)
+  ;; defines `id' with `contract'; initially binding
+  ;; it to the result of `expr'.  These variables may not be set!'d.
+  (define-syntax (define/contract define-stx)
+    (syntax-case define-stx ()
+      [(_ name contract-expr expr)
+       (identifier? (syntax name))
+       (with-syntax ([pos-blame-stx (datum->syntax-object define-stx 'here)]
+                     [contract-id 
+                      (a:mangle-id define-stx
+                                   "define/contract-contract-id"
+                                   (syntax name))]
+                     [id (a:mangle-id define-stx
+                                      "define/contract-id"
+                                      (syntax name))])
+         (syntax/loc define-stx 
+          (begin
+            (define contract-id contract-expr)
+            (define-syntax name
+              (make-set!-transformer
+               (lambda (stx)
+                 (with-syntax ([neg-blame-str (or (a:build-src-loc-string stx) "")])
+                   (syntax-case stx (set!)
+                     [(set! _ arg) 
+                      (raise-syntax-error 'define/contract
+                                          "cannot set! a define/contract variable" 
+                                          stx 
+                                          (syntax _))]
+                     [(_ arg (... ...))
+                      (syntax/loc stx
+                       ((-contract contract-id
+                                   id
+                                   (syntax-object->datum (quote-syntax _))
+                                   (string->symbol neg-blame-str)
+                                   (quote-syntax _))
+                        arg
+                        (... ...)))]
+                     [_
+                      (identifier? (syntax _))
+                      (syntax/loc stx
+                       (-contract contract-id
+                                  id  
+                                  (syntax-object->datum (quote-syntax _)) 
+                                  (string->symbol neg-blame-str)
+                                  (quote-syntax _)))])))))
+            (define id (let ([name expr]) name))  ;; let for procedure naming
+            )))]
+      [(_ name contract-expr expr)
+       (raise-syntax-error 'define/contract "expected identifier in first position"
+                           define-stx
+                           (syntax name))])) 
+  
+  
+;                                                                                                            
+;                                                                                                            
+;                                                                                                            
+;                               ;       ;             ;                                                      
+;                                       ;             ;                                                      
+;                                       ;            ;                           ;                       ;   
+;   ; ;;    ; ;   ;;;   ;     ; ;    ;; ;    ;;;     ;     ;;;    ;;;    ; ;;   ;;;;  ; ;  ;;;     ;;;  ;;;; 
+;   ;;  ;   ;;   ;   ;   ;   ;  ;   ;  ;;   ;   ;    ;    ;   ;  ;   ;   ;;  ;   ;    ;;  ;   ;   ;   ;  ;   
+;   ;    ;  ;   ;     ;  ;   ;  ;  ;    ;  ;    ;    ;   ;      ;     ;  ;   ;   ;    ;       ;  ;       ;   
+;   ;    ;  ;   ;     ;   ; ;   ;  ;    ;  ;;;;;;   ;    ;      ;     ;  ;   ;   ;    ;    ;;;;  ;       ;   
+;   ;    ;  ;   ;     ;   ; ;   ;  ;    ;  ;        ;    ;      ;     ;  ;   ;   ;    ;   ;   ;  ;       ;   
+;   ;;  ;   ;    ;   ;     ;    ;   ;  ;;   ;       ;     ;   ;  ;   ;   ;   ;   ;    ;   ;   ;   ;   ;  ;   
+;   ; ;;    ;     ;;;      ;    ;    ;; ;    ;;;;  ;       ;;;    ;;;    ;   ;    ;;  ;    ;;;;;   ;;;    ;; 
+;   ;                                              ;                                                         
+;   ;                                              ;                                                         
+;   ;                                                                                                        
+
+  
+  ;; (provide/contract p/c-ele ...)
+  ;; p/c-ele = (id expr) | (rename id id expr) | (struct (id expr) ...)
+  ;; provides each `id' with the contract `expr'.
+  (define-syntax (provide/contract provide-stx)
+    (syntax-case provide-stx (struct)
+      [(_ p/c-ele ...)
+       (let ()
+         
+         ;; code-for-each-clause : (listof syntax) -> (listof syntax)
+         ;; constructs code for each clause of a provide/contract
+         (define (code-for-each-clause clauses)
+           (cond
+             [(null? clauses) null]
+             [else
+              (let ([clause (car clauses)])
+                (syntax-case clause (struct rename)
+                  [(rename this-name new-name contract)
+                   (and (identifier? (syntax this-name))
+                        (identifier? (syntax new-name)))
+                   (cons (code-for-one-id provide-stx (syntax this-name) (syntax contract) (syntax new-name))
+                         (code-for-each-clause (cdr clauses)))]
+                  [(rename this-name new-name contract)
+                   (identifier? (syntax this-name))
+                   (raise-syntax-error 'provide/contract 
+                                       "malformed rename clause, expected an identifier" 
+                                       provide-stx
+                                       (syntax new-name))]
+                  [(rename this-name new-name contract)
+                   (identifier? (syntax new-name))
+                   (raise-syntax-error 'provide/contract 
+                                       "malformed rename clause, expected an identifier" 
+                                       provide-stx
+                                       (syntax this-name))]
+                  [(rename . _)
+                   (raise-syntax-error 'provide/contract "malformed rename clause" provide-stx clause)]
+                  [(struct struct-name ((field-name contract) ...))
+                   (and (well-formed-struct-name? (syntax struct-name))
+                        (andmap identifier? (syntax->list (syntax (field-name ...)))))
+                   (let ([sc (build-struct-code provide-stx
+                                                (syntax struct-name)
+                                                (syntax->list (syntax (field-name ...)))
+                                                (syntax->list (syntax (contract ...))))])
+                     (cons sc (code-for-each-clause (cdr clauses))))]
+                  [(struct name)
+                   (identifier? (syntax name))
+                   (raise-syntax-error 'provide/contract
+                                       "missing fields"
+                                       provide-stx
+                                       clause)]
+                  [(struct name . rest)
+                   (not (well-formed-struct-name? (syntax name)))
+                   (raise-syntax-error 'provide/contract "name must be an identifier or two identifiers with parens around them"
+                                       provide-stx
+                                       (syntax name))]
+                  [(struct name (fields ...))
+                   (for-each (lambda (field)
+                               (syntax-case field ()
+                                 [(x y) 
+                                  (identifier? (syntax x)) 
+                                  (void)]
+                                 [(x y) 
+                                  (raise-syntax-error 'provide/contract
+                                                      "malformed struct field, expected identifier"
+                                                      provide-stx
+                                                      (syntax x))]
+                                 [else
+                                  (raise-syntax-error 'provide/contract
+                                                      "malformed struct field"
+                                                      provide-stx
+                                                      field)]))
+                             (syntax->list (syntax (fields ...))))
+                   
+                   ;; if we didn't find a bad field something is wrong!
+                   (raise-syntax-error 'provide/contract "internal error" provide-stx clause)]
+                  [(struct name . fields)
+                   (raise-syntax-error 'provide/contract
+                                       "malformed struct fields"
+                                       provide-stx
+                                       clause)]
+                  [(name contract)
+                   (identifier? (syntax name))
+                   (cons (code-for-one-id provide-stx (syntax name) (syntax contract) #f)
+                         (code-for-each-clause (cdr clauses)))]
+                  [(name contract)
+                   (raise-syntax-error 'provide/contract
+                                       "expected identifier"
+                                       provide-stx
+                                       (syntax name))]
+                  [unk
+                   (raise-syntax-error 'provide/contract
+                                       "malformed clause"
+                                       provide-stx
+                                       (syntax unk))]))]))
+         
+         ;; well-formed-struct-name? : syntax -> bool
+         (define (well-formed-struct-name? stx)
+           (or (identifier? stx)
+               (syntax-case stx ()
+                 [(name super)
+                  (and (identifier? (syntax name))
+                       (identifier? (syntax super)))
+                  #t]
+                 [else #f])))
+         
+         ;; build-struct-code : syntax syntax (listof syntax) (listof syntax) -> syntax
+         ;; constructs the code for a struct clause
+         ;; first arg is the original syntax object, for source locations
+         (define (build-struct-code stx struct-name-position field-names field-contracts)
+           (let* ([struct-name (syntax-case struct-name-position ()
+                                 [(a b) (syntax a)]
+                                 [else struct-name-position])]
+                  [parent-struct-count (let ([parent-info (extract-parent-struct-info struct-name-position)])
+                                         (and parent-info
+                                              (let ([fields (cadddr parent-info)])
+                                                (cond
+                                                  [(null? fields) 0]
+                                                  [(not (car (last-pair fields)))
+                                                   (raise-syntax-error 
+                                                    'provide/contract
+                                                    "cannot determine the number of fields in super struct"
+                                                    provide-stx
+                                                    struct-name)]
+                                                  [else (length fields)]))))]
+                  [field-contract-ids (map (lambda (field-name) 
+                                             (a:mangle-id provide-stx
+                                                          "provide/contract-field-contract"
+                                                          field-name
+                                                          struct-name))
+                                           field-names)]
+                  [selector-ids (map (lambda (field-name) 
+                                       (build-selector-id struct-name field-name))
+                                     field-names)]
+                  [mutator-ids (map (lambda (field-name) 
+                                      (build-mutator-id struct-name field-name))
+                                    field-names)]
+                  [predicate-id (build-predicate-id struct-name)]
+                  [constructor-id (build-constructor-id struct-name)])
+             (with-syntax ([(selector-codes ...)
+                            (filter
+                             (lambda (x) x)
+                             (map/count (lambda (selector-id field-contract-id index)
+                                          (if (or (not parent-struct-count)
+                                                  (parent-struct-count . <= . index))
+                                              (code-for-one-id stx
+                                                               selector-id
+                                                               (build-selector-contract struct-name 
+                                                                                        predicate-id
+                                                                                        field-contract-id)
+                                                               #f)
+                                              #f))
+                                        selector-ids
+                                        field-contract-ids))]
+                           [(mutator-codes ...)
+                            (filter
+                             (lambda (x) x)
+                             (map/count (lambda (mutator-id field-contract-id index)
+                                          (if (or (not parent-struct-count)
+                                                  (parent-struct-count . <= . index))
+                                              (code-for-one-id stx
+                                                               mutator-id 
+                                                               (build-mutator-contract struct-name 
+                                                                                       predicate-id
+                                                                                       field-contract-id)
+                                                               #f)
+                                              #f))
+                                        mutator-ids
+                                        field-contract-ids))]
+                           [predicate-code (code-for-one-id stx predicate-id (syntax (-> any/c boolean?)) #f)]
+                           [constructor-code (code-for-one-id
+                                              stx
+                                              constructor-id
+                                              (build-constructor-contract stx
+                                                                          field-contract-ids 
+                                                                          predicate-id)
+                                              #f)]
+                           [(field-contracts ...) field-contracts]
+                           [(field-contract-ids ...) field-contract-ids]
+                           [struct-name struct-name]
+                           [struct:struct-name (datum->syntax-object
+                                                struct-name
+                                                (string->symbol
+                                                 (string-append
+                                                  "struct:"
+                                                  (symbol->string (syntax-e struct-name)))))])
+               (syntax/loc stx
+                (begin
+                  (define field-contract-ids field-contracts) ...
+                  selector-codes ...
+                  mutator-codes ...
+                  predicate-code
+                  constructor-code
+                  (provide struct-name struct:struct-name))))))
+ 
+         ;; map/count : (X Y int -> Z) (listof X) (listof Y) -> (listof Z)
+         (define (map/count f l1 l2)
+           (let loop ([l1 l1]
+                      [l2 l2]
+                      [i 0])
+             (cond
+               [(and (null? l1) (null? l2)) '()]
+               [(or (null? l1) (null? l2)) (error 'map/count "mismatched lists")]
+               [else (cons (f (car l1) (car l2) i)
+                           (loop (cdr l1)
+                                 (cdr l2)
+                                 (+ i 1)))])))
+         
+         ;; extract-parent-struct-info : syntax -> (union #f (list syntax syntax (listof syntax) ...))
+         (define (extract-parent-struct-info stx)
+           (syntax-case stx ()
+             [(a b)
+              (syntax-local-value 
+               (syntax b)
+               (lambda ()
+                 (raise-syntax-error 'provide/contract
+                                     "expected a struct name" 
+                                     provide-stx
+                                     (syntax b))))]
+             [a #f]))
+         
+         ;; build-constructor-contract : syntax (listof syntax) syntax -> syntax
+         (define (build-constructor-contract stx field-contract-ids predicate-id)
+           (with-syntax ([(field-contract-ids ...) field-contract-ids]
+                         [predicate-id predicate-id])
+             (syntax/loc stx
+               (field-contract-ids 
+                ...
+                . -> . 
+                (let ([predicate-id (lambda (x) (predicate-id x))]) predicate-id)))))
+         
+         ;; build-selector-contract : syntax syntax -> syntax
+         ;; constructs the contract for a selector
+         (define (build-selector-contract struct-name predicate-id field-contract-id)
+           (with-syntax ([field-contract-id field-contract-id]
+                         [predicate-id predicate-id])
+             (syntax ((let ([predicate-id (lambda (x) (predicate-id x))]) predicate-id)
+                      . -> .
+                      field-contract-id))))
+         
+         ;; build-mutator-contract : syntax syntax -> syntax
+         ;; constructs the contract for a selector
+         (define (build-mutator-contract struct-name predicate-id field-contract-id)
+           (with-syntax ([field-contract-id field-contract-id]
+                         [predicate-id predicate-id])
+             (syntax ((let ([predicate-id (lambda (x) (predicate-id x))]) predicate-id)
+                      field-contract-id
+                      . -> .
+                      void?))))
+         
+         ;; build-constructor-id : syntax -> syntax
+         ;; constructs the name of the selector for a particular field of a struct
+         (define (build-constructor-id struct-name)
+           (datum->syntax-object
+            struct-name
+            (string->symbol
+             (string-append
+              "make-"
+              (symbol->string (syntax-object->datum struct-name))))))
+         
+         ;; build-predicate-id : syntax -> syntax
+         ;; constructs the name of the selector for a particular field of a struct
+         (define (build-predicate-id struct-name)
+           (datum->syntax-object
+            struct-name
+            (string->symbol
+             (string-append
+              (symbol->string (syntax-object->datum struct-name))
+              "?"))))
+         
+         ;; build-selector-id : syntax syntax -> syntax
+         ;; constructs the name of the selector for a particular field of a struct
+         (define (build-selector-id struct-name field-name)
+           (datum->syntax-object
+            struct-name
+            (string->symbol
+             (string-append
+              (symbol->string (syntax-object->datum struct-name))
+              "-"
+              (symbol->string (syntax-object->datum field-name))))))
+         
+         ;; build-mutator-id : syntax syntax -> syntax
+         ;; constructs the name of the selector for a particular field of a struct
+         (define (build-mutator-id struct-name field-name)
+           (datum->syntax-object
+            struct-name
+            (string->symbol
+             (string-append
+              "set-"
+              (symbol->string (syntax-object->datum struct-name))
+              "-"
+              (symbol->string (syntax-object->datum field-name))
+              "!"))))
+         
+         ;; code-for-one-id : syntax syntax syntax (union syntax #f) -> syntax
+         ;; given the syntax for an identifier and a contract,
+         ;; builds a begin expression for the entire contract and provide
+         ;; the first syntax object is used for source locations
+         (define (code-for-one-id stx id ctrct user-rename-id)
+           (with-syntax ([id-rename (a:mangle-id provide-stx "provide/contract-id" id)]
+                         [contract-id (a:mangle-id provide-stx "provide/contract-contract-id" id)]
+                         [pos-module-source (a:mangle-id provide-stx "provide/contract-pos-module-source" id)]
+                         [pos-stx (datum->syntax-object provide-stx 'here)]
+                         [id id]
+                         [ctrct ctrct])
+             (with-syntax ([provide-clause (if user-rename-id
+                                               (with-syntax ([user-rename-id user-rename-id])
+                                                 (syntax (provide (rename id-rename user-rename-id))))
+                                               (syntax (provide (rename id-rename id))))])
+               (syntax/loc stx
+                 (begin
+                   provide-clause
+                   
+                   ;; unbound id check
+                   (if #f id)
+                   
+                   (define pos-module-source (module-source-as-symbol #'pos-stx))
+                   (define contract-id (let ([id ctrct]) id))
+                   (define-syntax id-rename
+                     (make-set!-transformer
+                      (lambda (stx)
+                        (with-syntax ([neg-stx (datum->syntax-object stx 'here)])
+                          (syntax-case stx (set!)
+                            [(set! _ body) (raise-syntax-error
+                                            #f 
+                                            "cannot set! provide/contract identifier"
+                                            stx
+                                            (syntax _))]
+                            [(_ arg (... ...))
+                             (syntax 
+                              ((begin-lifted
+				(-contract contract-id
+					   id
+					   pos-module-source
+					   (module-source-as-symbol #'neg-stx)
+					   (quote-syntax _)))
+                               arg
+                               (... ...)))]
+                            [_
+                             (identifier? (syntax _))
+                             (syntax 
+                              (begin-lifted
+			       (-contract contract-id
+					  id  
+					  pos-module-source 
+					  (module-source-as-symbol #'neg-stx)
+					  (quote-syntax _))))]))))))))))
+         
+         (with-syntax ([(bodies ...) (code-for-each-clause (syntax->list (syntax (p/c-ele ...))))])
+           (syntax 
+            (begin
+              bodies ...))))]))
+  
+  
+  ;                                                      
+  ;                                                      
+  ;                                                      
+  ;                                                      
+  ;                                                      
+  ;                          ;                       ;   
+  ;    ;;;    ;;;    ; ;;   ;;;;  ; ;  ;;;     ;;;  ;;;; 
+  ;   ;   ;  ;   ;   ;;  ;   ;    ;;  ;   ;   ;   ;  ;   
+  ;  ;      ;     ;  ;   ;   ;    ;       ;  ;       ;   
+  ;  ;      ;     ;  ;   ;   ;    ;    ;;;;  ;       ;   
+  ;  ;      ;     ;  ;   ;   ;    ;   ;   ;  ;       ;   
+  ;   ;   ;  ;   ;   ;   ;   ;    ;   ;   ;   ;   ;  ;   
+  ;    ;;;    ;;;    ;   ;    ;;  ;    ;;;;;   ;;;    ;; 
+  ;                                                      
+  ;                                                      
+  ;                                                      
+  
+  ;; contract = (make-contract ((union #f (listof number)) -> string)
+  ;;                           (sym
+  ;;                            sym
+  ;;                            (union syntax #f)
+  ;;                            string
+  ;;                            ->
+  ;;                            (alpha -> alpha)))
+  ;; the first arg to make-contract builds the name of the contract. The
+  ;; path records how the violation occurs
+  ;;
+  ;; generic contract container; 
+  ;; the first arg to proc is a symbol representing the name of the positive blame
+  ;; the second arg to proc is the symbol representing the name of the negative blame
+  ;; the third argument to proc is the src-info.
+  ;; the fourth argumet is a textual representation of the original contract
+  ;;
+  ;; the argument to the result function is the value to test.
+  ;; (the result function is the projection)
+  ;;  
+  (define-values (make-flat-contract
+                  flat-contract-predicate
+                  flat-contract?
+                  
+                  make-contract
+                  contract-name
+                  contract-proc
+                  contract?)
+    (let ()
+      (define-struct contract (name proc))
+      (define-struct (flat-contract contract) (predicate))
+      (values make-flat-contract
+              flat-contract-predicate
+              flat-contract?
+              
+              make-contract
+              contract-name
+              contract-proc
+              contract?)))
+
+  (define (test-proc/flat-contract f x)
+    (if (flat-contract? f)
+        ((flat-contract-predicate f) x)
+        (f x)))
+  
+  (define (proc/ctc->ctc f)
+    (if (contract? f)
+        f
+        (flat-named-contract
+         (or (object-name f)
+             (string->symbol (format "contract:~e" f)))
+         f)))
+    
+  
+  
+  ;; build-compound-type-name : (union contract symbol) ... -> (union path #f) -> sexp
+  (define (build-compound-type-name . fs)
+    (let loop ([subs fs]
+               [i 0])
+      (cond
+        [(null? subs)
+         '()]
+        [else (let ([sub (car subs)])
+                (cond
+                  [(contract? sub)
+                   (let ([mk-sub-name (contract-name sub)])
+                     `(,mk-sub-name ,@(loop (cdr subs) (+ i 1))))]
+                  [else `(,sub ,@(loop (cdr subs) i))]))])))
+  
+  (define (flat-contract predicate)
+    (unless (and (procedure? predicate)
+                 (procedure-arity-includes? predicate 1))
+      (error 'flat-contract
+             "expected procedure of one argument as argument, given ~e"
+             predicate))
+    (let ([pname (object-name predicate)])
+      (if pname
+          (flat-named-contract pname predicate)
+          (flat-named-contract '??? predicate))))
+  
+  (define (flat-named-contract name predicate)
+    (unless (and (procedure? predicate)
+                 (procedure-arity-includes? predicate 1))
+      (error 'flat-named-contract
+             "expected procedure of one argument as second argument, given: ~e, fst arg ~e"
+             predicate name))
+    (build-flat-contract name predicate))
+  
+  (define (build-flat-contract name predicate)
+    (make-flat-contract 
+     name
+     (lambda (pos neg src-info orig-str) 
+       (lambda (val)
+         (if (predicate val)
+             val
+             (raise-contract-error
+              src-info
+              pos
+              neg
+              orig-str
+              "expected <~a>, given: ~e"
+              name
+              val))))
+     predicate))
+
+  (define-syntax (-contract stx)
+    (syntax-case stx ()
+      [(_ a-contract to-check pos-blame-e neg-blame-e)
+       (with-syntax ([src-loc (syntax/loc stx here)])
+         (syntax/loc stx
+           (contract/proc a-contract to-check pos-blame-e neg-blame-e (quote-syntax src-loc))))]
+      [(_ a-contract-e to-check pos-blame-e neg-blame-e src-info-e)
+       (syntax/loc stx
+         (contract/proc a-contract-e to-check pos-blame-e neg-blame-e src-info-e))]))
+  
+  (define (contract/proc a-contract-raw name pos-blame neg-blame src-info)
+    (unless (or (contract? a-contract-raw)
+                (and (procedure? a-contract-raw)
+                     (procedure-arity-includes? a-contract-raw 1)))
+      (error 'contract "expected a contract or a procedure of arity 1 as first argument, given: ~e, other args ~e ~e ~e ~e" 
+             a-contract-raw
+             name
+             pos-blame
+             neg-blame
+             src-info))
+    (let ([a-contract (if (contract? a-contract-raw)
+                          a-contract-raw
+                          (flat-contract a-contract-raw))])
+      (unless (and (symbol? neg-blame)
+                   (symbol? pos-blame))
+        (error 'contract
+               "expected symbols as names for assigning blame, given: ~e and ~e, other args ~e ~e ~e"
+               neg-blame pos-blame
+               a-contract-raw 
+               name
+               src-info))
+      (unless (syntax? src-info)
+        (error 'contract "expected syntax as last argument, given: ~e, other args ~e ~e ~e ~e"
+               src-info
+               neg-blame 
+               pos-blame
+               a-contract-raw
+               name))
+      (((contract-proc a-contract) pos-blame neg-blame src-info (contract-name a-contract))
+       name)))
+    
+  (define-values (make-exn:fail:contract2 
+                  exn:fail:contract2?
+                  exn:fail:contract2-srclocs)
+    (let-values ([(exn:fail:contract2 
+                   make-exn:fail:contract2 
+                   exn:fail:contract2?
+                   get
+                   set)
+                  (parameterize ([current-inspector (make-inspector)])
+                    (make-struct-type 'exn:fail:contract2
+                                      struct:exn:fail
+                                      1
+                                      0
+                                      #f
+                                      (list (cons prop:exn:srclocs (lambda (x) (exn:fail:contract2-srclocs x))))))])
+      (values
+       make-exn:fail:contract2 
+       exn:fail:contract2?
+       (lambda (x) (get x 0)))))
+  
+  ;; raise-contract-error : (union syntax #f) symbol symbol string string args ... -> alpha
+  ;; doesn't return
+  (define (raise-contract-error src-info to-blame other-party contract-sexp fmt . args)
+    (let ([blame-src (src-info-as-string src-info)]
+          [formatted-contract-sexp
+           (let ([one-line (format "~s" contract-sexp)])
+             (if (< (string-length one-line) 30)
+                 (string-append one-line " ")
+                 (let ([sp (open-output-string)])
+                   (newline sp)
+                   (parameterize ([pretty-print-print-line print-contract-liner]
+                                  [pretty-print-columns 50])
+                     (pretty-print contract-sexp sp))
+                   (get-output-string sp))))]
+	  [specific-blame
+	   (let ([datum (syntax-object->datum src-info)])
+	     (if (symbol? datum)
+		 (format " on ~a" datum)
+                 ""))])
+      (raise
+       (make-exn:fail:contract2
+        (string->immutable-string
+         (string-append (format "~a~a broke the contract ~ait had with ~a~a; "
+                                blame-src
+                                to-blame
+                                formatted-contract-sexp
+                                other-party
+                                specific-blame)
+                        (apply format fmt args)))
+        (current-continuation-marks)
+        (if src-info
+            (list (make-srcloc 
+                   (syntax-source src-info)
+                   (syntax-line src-info)
+                   (syntax-column src-info)
+                   (syntax-position src-info)
+                   (syntax-span src-info)))
+            '())))))
+  
+  (define print-contract-liner
+    (let ([default (pretty-print-print-line)])
+      (λ (line port ol cols)
+        (+ (default line port ol cols)
+           (if line
+               (begin (display "  " port)
+                      2)
+               0)))))
+  
+  ;; src-info-as-string : (union syntax #f) -> string
+  (define (src-info-as-string src-info)
+    (if (syntax? src-info)
+        (let ([src-loc-str (build-src-loc-string src-info)])
+          (if src-loc-str
+              (string-append src-loc-str  ": ")
+              ""))
+        ""))
+    
+;                                                                                   
+;                                                                                   
+;                                                                                   
+;                                                                                   
+;                                                                                   
+;           ;                                    ;                       ;          
+;            ;;            ;;;    ;;;    ; ;;   ;;;;  ; ;  ;;;     ;;;  ;;;;   ;;;  
+;              ;;         ;   ;  ;   ;   ;;  ;   ;    ;;  ;   ;   ;   ;  ;    ;     
+;                ;;      ;      ;     ;  ;   ;   ;    ;       ;  ;       ;    ;;    
+;   ;;;;;;       ;;      ;      ;     ;  ;   ;   ;    ;    ;;;;  ;       ;     ;;   
+;              ;;        ;      ;     ;  ;   ;   ;    ;   ;   ;  ;       ;       ;  
+;            ;;           ;   ;  ;   ;   ;   ;   ;    ;   ;   ;   ;   ;  ;       ;  
+;           ;              ;;;    ;;;    ;   ;    ;;  ;    ;;;;;   ;;;    ;;  ;;;   
+;                                                                                   
+;                                                                                   
+;                                                                                   
+
+  
+  (define-syntax (any stx)
+    (raise-syntax-error 'any "Use any out of an arrow contract" stx))
+
+  (define-syntax-set (-> ->* ->d ->d* ->r ->pp ->pp-rest case-> object-contract opt-> opt->*)
+    
+    (define (->/proc stx) (make-/proc #f ->/h stx))
+    (define (->*/proc stx) (make-/proc #f ->*/h stx))
+    (define (->d/proc stx) (make-/proc #f ->d/h stx))
+    (define (->d*/proc stx) (make-/proc #f ->d*/h stx))
+    (define (->r/proc stx) (make-/proc #f ->r/h stx))
+    (define (->pp/proc stx) (make-/proc #f ->pp/h stx))
+    (define (->pp-rest/proc stx) (make-/proc #f ->pp-rest/h stx))
+        
+    (define (obj->/proc stx) (make-/proc #t ->/h stx))
+    (define (obj->*/proc stx) (make-/proc #t ->*/h stx))
+    (define (obj->d/proc stx) (make-/proc #t ->d/h stx))
+    (define (obj->d*/proc stx) (make-/proc #t ->d*/h stx))
+    (define (obj->r/proc stx) (make-/proc #t ->r/h stx))
+    (define (obj->pp/proc stx) (make-/proc #t ->pp/h stx))
+    (define (obj->pp-rest/proc stx) (make-/proc #t ->pp-rest/h stx))
+    
+    (define (case->/proc stx) (make-case->/proc #f stx))
+    (define (obj-case->/proc stx) (make-case->/proc #t stx))
+
+    (define (obj-opt->/proc stx) (make-opt->/proc #t stx))
+    (define (obj-opt->*/proc stx) (make-opt->*/proc #t stx))
+    (define (opt->/proc stx) (make-opt->/proc #f stx))
+    (define (opt->*/proc stx) (make-opt->*/proc #f stx))
+  
+    ;; make-/proc : boolean
+    ;;              (syntax -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))) 
+    ;;              syntax
+    ;;           -> (syntax -> syntax)
+    (define (make-/proc method-proc? /h stx)
+      (let-values ([(arguments-check build-proj check-val wrapper) (/h method-proc? stx)])
+        (let ([outer-args (syntax (val pos-blame neg-blame src-info orig-str name-id))])
+          (with-syntax ([inner-check (check-val outer-args)]
+                        [(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                        [(val-args body) (wrapper outer-args)])
+            (with-syntax ([inner-lambda
+                           (set-inferred-name-from
+                            stx
+                            (syntax/loc stx (lambda val-args body)))])
+              (let ([inner-lambda-w/err-check
+                     (syntax
+                      (lambda (val)
+                        inner-check
+                        inner-lambda))])
+                (with-syntax ([proj-code (build-proj outer-args inner-lambda-w/err-check)])
+                  (arguments-check
+                   outer-args
+                   (syntax/loc stx
+                     (make-contract
+                      name-id
+                      (lambda (pos-blame neg-blame src-info orig-str)
+                        proj-code)))))))))))
+    
+    (define (make-case->/proc method-proc? stx)
+      (syntax-case stx ()
+        [(_ cases ...)
+         (let-values ([(arguments-check build-projs check-val wrapper)
+                       (case->/h method-proc? stx (syntax->list (syntax (cases ...))))])
+           (let ([outer-args (syntax (val pos-blame neg-blame src-info orig-str name-id))])
+             (with-syntax ([(inner-check ...) (check-val outer-args)]
+                           [(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                           [(body ...) (wrapper outer-args)])
+               (with-syntax ([inner-lambda 
+                              (set-inferred-name-from
+                               stx
+                               (syntax/loc stx (case-lambda body ...)))])
+                 (let ([inner-lambda-w/err-check
+                        (syntax
+                         (lambda (val)
+                           inner-check ...
+                           inner-lambda))])
+                   (with-syntax ([proj-code (build-projs outer-args inner-lambda-w/err-check)])
+                     (arguments-check
+                      outer-args
+                      (syntax/loc stx
+                        (make-contract
+                         (apply build-compound-type-name 'case-> name-id)
+                         (lambda (pos-blame neg-blame src-info orig-str)
+                           proj-code))))))))))]))
+    
+    (define (make-opt->/proc method-proc? stx)
+      (syntax-case stx (any)
+        [(_ (reqs ...) (opts ...) any)
+         (make-opt->*/proc method-proc? (syntax (opt->* (reqs ...) (opts ...) any)))]
+        [(_ (reqs ...) (opts ...) res)
+         (make-opt->*/proc method-proc? (syntax (opt->* (reqs ...) (opts ...) (res))))]))
+  
+    (define (make-opt->*/proc method-proc? stx)
+      (syntax-case stx (any)
+        [(_ (reqs ...) (opts ...) any)
+         (let* ([req-vs (generate-temporaries (syntax->list (syntax (reqs ...))))]
+                [opt-vs (generate-temporaries (syntax->list (syntax (opts ...))))]
+                [cses
+                 (reverse
+                  (let loop ([opt-vs (reverse opt-vs)])
+                    (cond
+                      [(null? opt-vs) (list req-vs)]
+                      [else (cons (append req-vs (reverse opt-vs))
+                                  (loop (cdr opt-vs)))])))])
+           (with-syntax ([(req-vs ...) req-vs]
+                         [(opt-vs ...) opt-vs]
+                         [((case-doms ...) ...) cses])
+             (with-syntax ([expanded-case->
+                            (make-case->/proc
+                             method-proc?
+                             (syntax (case-> (-> case-doms ... any) ...)))])
+               (syntax/loc stx
+                 (let ([req-vs reqs] ...
+                       [opt-vs opts] ...)
+                   expanded-case->)))))]
+        [(_ (reqs ...) (opts ...) (ress ...))
+         (let* ([res-vs (generate-temporaries (syntax->list (syntax (ress ...))))]
+                [req-vs (generate-temporaries (syntax->list (syntax (reqs ...))))]
+                [opt-vs (generate-temporaries (syntax->list (syntax (opts ...))))]
+                [cses
+                 (reverse
+                  (let loop ([opt-vs (reverse opt-vs)])
+                    (cond
+                      [(null? opt-vs) (list req-vs)]
+                      [else (cons (append req-vs (reverse opt-vs))
+                                  (loop (cdr opt-vs)))])))])
+           (with-syntax ([(res-vs ...) res-vs]
+                         [(req-vs ...) req-vs]
+                         [(opt-vs ...) opt-vs]
+                         [((case-doms ...) ...) cses])
+             (with-syntax ([(single-case-result ...)
+                            (let* ([ress-lst (syntax->list (syntax (ress ...)))]
+                                   [only-one?
+                                    (and (pair? ress-lst)
+                                         (null? (cdr ress-lst)))])
+                              (map
+                               (if only-one?
+                                   (lambda (x) (car (syntax->list (syntax (res-vs ...)))))
+                                   (lambda (x) (syntax (values res-vs ...))))
+                               cses))])
+               (with-syntax ([expanded-case->
+                              (make-case->/proc
+                               method-proc?
+                               (syntax (case-> (-> case-doms ... single-case-result) ...)))])
+                 (set-inferred-name-from
+                  stx
+                  (syntax/loc stx
+                    (let ([res-vs ress] 
+                          ...
+                          [req-vs reqs]
+                          ...
+                          [opt-vs opts]
+                          ...)
+                      expanded-case->)))))))]))
+
+    ;; exactract-argument-lists : syntax -> (listof syntax)
+    (define (extract-argument-lists stx)
+      (map (lambda (x)
+             (syntax-case x ()
+               [(arg-list body) (syntax arg-list)]))
+           (syntax->list stx)))
+    
+    ;; ensure-cases-disjoint : syntax syntax[list] -> void
+    (define (ensure-cases-disjoint stx cases)
+      (let ([individual-cases null]
+            [dot-min #f])
+        (for-each (lambda (case)
+                    (let ([this-case (get-case case)])
+                      (cond
+                        [(number? this-case) 
+                         (cond
+                           [(member this-case individual-cases)
+                            (raise-syntax-error
+                             'case-> 
+                             (format "found multiple cases with ~a arguments" this-case)
+                             stx)]
+                           [(and dot-min (dot-min . <= . this-case))
+                            (raise-syntax-error 
+                             'case-> 
+                             (format "found overlapping cases (~a+ followed by ~a)" dot-min this-case)
+                             stx)]
+                           [else (set! individual-cases (cons this-case individual-cases))])]
+                        [(pair? this-case)
+                         (let ([new-dot-min (car this-case)])
+                           (cond
+                             [dot-min
+                              (if (dot-min . <= . new-dot-min)
+                                  (raise-syntax-error
+                                   'case->
+                                   (format "found overlapping cases (~a+ followed by ~a+)" dot-min new-dot-min)
+                                   stx)
+                                  (set! dot-min new-dot-min))]
+                             [else
+                              (set! dot-min new-dot-min)]))])))
+                  cases)))
+
+    ;; get-case : syntax -> (union number (cons number 'more))
+    (define (get-case stx)
+      (let ([ilist (syntax-object->datum stx)])
+        (if (list? ilist)
+            (length ilist)
+            (cons 
+             (let loop ([i ilist])
+               (cond
+                 [(pair? i) (+ 1 (loop (cdr i)))]
+                 [else 0]))
+             'more))))
+
+    
+    ;; case->/h : boolean
+    ;;            syntax
+    ;;            (listof syntax) 
+    ;;         -> (values (syntax -> syntax)
+    ;;                    (syntax -> syntax)
+    ;;                    (syntax syntax -> syntax) 
+    ;;                    (syntax -> syntax))
+    ;; like the other /h functions, but composes the wrapper functions
+    ;; together and combines the cases of the case-lambda into a single list.
+    (define (case->/h method-proc? orig-stx cases)
+      (let loop ([cases cases]
+                 [name-ids '()])
+        (cond
+          [(null? cases) (values (lambda (outer-args body)
+                                   (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                                                 [body body]
+                                                 [(name-ids ...) (reverse name-ids)])
+                                     (syntax
+                                      (let ([name-id (list name-ids ...)])
+                                        body))))
+                                 (lambda (x y) y)
+                                 (lambda (args) (syntax ()))
+                                 (lambda (args) (syntax ())))]
+          [else
+           (let ([/h (select/h (car cases) 'case-> orig-stx)]
+                 [new-id (car (generate-temporaries (syntax (case->name-id))))])
+             (let-values ([(arguments-checks build-projs check-vals wrappers)
+                           (loop (cdr cases) (cons new-id name-ids))]
+                          [(arguments-check build-proj check-val wrapper)
+                           (/h method-proc? (car cases))])
+               (values
+                (lambda (outer-args x) 
+                  (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                                [new-id new-id])
+                    (arguments-check 
+                     (syntax (val pos-blame neg-blame src-info orig-str new-id)) 
+                     (arguments-checks 
+                      outer-args
+                      x))))
+                (lambda (args inner)
+                  (build-projs
+                   args
+                   (build-proj
+                    args
+                    inner)))
+                (lambda (args)
+                  (with-syntax ([checks (check-vals args)]
+                                [check (check-val args)])
+                    (syntax (check . checks))))
+                (lambda (args)
+                  (with-syntax ([case (wrapper args)]
+                                [cases (wrappers args)])
+                    (syntax (case . cases)))))))])))
+    
+    (define (object-contract/proc stx)
+      
+      ;; name : syntax
+      ;; ctc-stx : syntax[evals to a contract]
+      ;; mtd-arg-stx : syntax[list of arg-specs] (ie, for use in a case-lambda)
+      (define-struct mtd (name ctc-stx mtd-arg-stx))
+      
+      ;; name : syntax
+      ;; ctc-stx : syntax[evals to a contract]
+      (define-struct fld (name ctc-stx))
+      
+      ;; expand-field/mtd-spec : stx -> (union mtd fld)
+      (define (expand-field/mtd-spec f/m-stx)
+        (syntax-case f/m-stx (field)
+          [(field field-name ctc)
+           (identifier? (syntax field-name))
+           (make-fld (syntax field-name) (syntax ctc))]
+          [(field field-name ctc)
+           (raise-syntax-error 'object-contract "expected name of field" stx (syntax field-name))]
+          [(mtd-name ctc)
+           (identifier? (syntax mtd-name))
+           (let-values ([(ctc-stx proc-stx) (expand-mtd-contract (syntax ctc))])
+             (make-mtd (syntax mtd-name)
+                       ctc-stx
+                       proc-stx))]
+          [(mtd-name ctc)
+           (raise-syntax-error 'object-contract "expected name of method" stx (syntax mtd-name))]
+          [_ (raise-syntax-error 'object-contract "expected field or method clause" stx f/m-stx)]))
+      
+      ;; expand-mtd-contract : syntax -> (values syntax[expanded ctc] syntax[mtd-arg])
+      (define (expand-mtd-contract mtd-stx)
+        (syntax-case mtd-stx (case-> opt-> opt->*)
+          [(case-> cases ...)
+           (let loop ([cases (syntax->list (syntax (cases ...)))]
+                      [ctc-stxs null]
+                      [args-stxs null])
+             (cond
+               [(null? cases) 
+                (values
+                 (with-syntax ([(x ...) (reverse ctc-stxs)])
+                   (obj-case->/proc (syntax (case-> x ...))))
+                 (with-syntax ([(x ...) (apply append (map syntax->list (reverse args-stxs)))])
+                   (syntax (x ...))))]
+               [else
+                (let-values ([(trans ctc-stx mtd-args) (expand-mtd-arrow (car cases))])
+                  (loop (cdr cases)
+                        (cons ctc-stx ctc-stxs)
+                        (cons mtd-args args-stxs)))]))]
+          [(opt->* (req-contracts ...) (opt-contracts ...) (res-contracts ...))
+           (values
+            (obj-opt->*/proc (syntax (opt->* (any/c req-contracts ...) (opt-contracts ...) (res-contracts ...))))
+            (generate-opt->vars (syntax (req-contracts ...))
+                                (syntax (opt-contracts ...))))]
+          [(opt->* (req-contracts ...) (opt-contracts ...) any)
+           (values
+            (obj-opt->*/proc (syntax (opt->* (any/c req-contracts ...) (opt-contracts ...) any)))
+            (generate-opt->vars (syntax (req-contracts ...))
+                                (syntax (opt-contracts ...))))]
+          [(opt-> (req-contracts ...) (opt-contracts ...) res-contract) 
+           (values
+            (obj-opt->/proc (syntax (opt-> (any/c req-contracts ...) (opt-contracts ...) res-contract)))
+            (generate-opt->vars (syntax (req-contracts ...))
+                                (syntax (opt-contracts ...))))]
+          [else (let-values ([(x y z) (expand-mtd-arrow mtd-stx)])
+                  (values (x y) z))]))
+      
+      ;; generate-opt->vars : syntax[requried contracts] syntax[optional contracts] -> syntax[list of arg specs]
+      (define (generate-opt->vars req-stx opt-stx)
+        (with-syntax ([(req-vars ...) (generate-temporaries req-stx)]
+                      [(ths) (generate-temporaries (syntax (ths)))])
+          (let loop ([opt-vars (generate-temporaries opt-stx)])
+            (cond
+              [(null? opt-vars) (list (syntax (ths req-vars ...)))]
+              [else (with-syntax ([(opt-vars ...) opt-vars]
+                                  [(rests ...) (loop (cdr opt-vars))])
+                      (syntax ((ths req-vars ... opt-vars ...)
+                               rests ...)))]))))
+      
+      ;; expand-mtd-arrow : stx -> (values (syntax[ctc] -> syntax[expanded ctc]) syntax[ctc] syntax[mtd-arg])
+      (define (expand-mtd-arrow mtd-stx)
+        (syntax-case mtd-stx (-> ->* ->d ->d* ->r ->pp ->pp-rest)
+          [(->) (raise-syntax-error 'object-contract "-> must have arguments" stx mtd-stx)]
+          [(-> args ...)
+           (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (args ...)))])
+             (values obj->/proc
+                     (syntax (-> any/c args ...))
+                     (syntax ((arg-vars ...)))))]
+          [(->* (doms ...) (rngs ...))
+           (with-syntax ([(args-vars ...) (generate-temporaries (syntax (doms ...)))]
+                         [(this-var) (generate-temporaries (syntax (this-var)))])
+             (values obj->*/proc
+                     (syntax (->* (any/c doms ...) (rngs ...)))
+                     (syntax ((this-var args-vars ...)))))]
+          [(->* (doms ...) rst (rngs ...))
+           (with-syntax ([(args-vars ...) (generate-temporaries (syntax (doms ...)))]
+                         [(rst-var) (generate-temporaries (syntax (rst)))]
+                         [(this-var) (generate-temporaries (syntax (this-var)))])
+             (values obj->*/proc
+                     (syntax (->* (any/c doms ...) rst (rngs ...)))
+                     (syntax ((this-var args-vars ... . rst-var)))))]
+          [(->* x ...)
+           (raise-syntax-error 'object-contract "malformed ->*" stx mtd-stx)]
+          [(->d) (raise-syntax-error 'object-contract "->d must have arguments" stx mtd-stx)]
+          [(->d doms ... rng-proc)
+           (let ([doms-val (syntax->list (syntax (doms ...)))])
+             (values
+              obj->d/proc
+              (with-syntax ([(arg-vars ...) (generate-temporaries doms-val)]
+                            [arity-count (length doms-val)])
+                (syntax 
+                 (->d any/c doms ... 
+                      (let ([f rng-proc])
+			(check->* f arity-count)
+                        (lambda (_this-var arg-vars ...)
+                          (f arg-vars ...))))))
+              (with-syntax ([(args-vars ...) (generate-temporaries doms-val)])
+                (syntax ((this-var args-vars ...))))))]
+          [(->d* (doms ...) rng-proc)
+           (values
+            obj->d*/proc
+            (let ([doms-val (syntax->list (syntax (doms ...)))])
+              (with-syntax ([(arg-vars ...) (generate-temporaries doms-val)]
+                            [arity-count (length doms-val)])
+                (syntax (->d* (any/c doms ...)
+                              (let ([f rng-proc])
+				(check->* f arity-count)
+                                (lambda (_this-var arg-vars ...)
+                                  (f arg-vars ...)))))))
+            (with-syntax ([(args-vars ...) (generate-temporaries (syntax (doms ...)))]
+                          [(this-var) (generate-temporaries (syntax (this-var)))])
+              (syntax ((this-var args-vars ...)))))]
+          [(->d* (doms ...) rst-ctc rng-proc)
+           (let ([doms-val (syntax->list (syntax (doms ...)))])
+             (values
+              obj->d*/proc
+              (with-syntax ([(arg-vars ...) (generate-temporaries doms-val)]
+                            [(rest-var) (generate-temporaries (syntax (rst-ctc)))]
+                            [arity-count (length doms-val)])
+                (syntax (->d* (any/c doms ...)
+                              rst-ctc
+                              (let ([f rng-proc])
+				(check->*/more f arity-count)
+                                (lambda (_this-var arg-vars ... . rest-var)
+                                  (apply f arg-vars ... rest-var))))))
+              (with-syntax ([(args-vars ...) (generate-temporaries (syntax (doms ...)))]
+                            [(rst-var) (generate-temporaries (syntax (rst-ctc)))]
+                            [(this-var) (generate-temporaries (syntax (this-var)))])
+                (syntax ((this-var args-vars ... . rst-var))))))]
+          [(->d* x ...)
+           (raise-syntax-error 'object-contract "malformed ->d* method contract" stx mtd-stx)]
+          
+          [(->r ([x dom] ...) rng)
+           (andmap identifier? (syntax->list (syntax (x ...))))
+           (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))])
+             (values
+              obj->r/proc
+              (syntax (->r ([_this any/c] [x dom] ...) rng))
+              (syntax ((_this arg-vars ...)))))]
+          
+          [(->r ([x dom] ...) rest-x rest-dom rng)
+           (andmap identifier? (syntax->list (syntax (x ...))))
+           (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))])
+             (values
+              obj->r/proc
+              (syntax (->r ([_this any/c] [x dom] ...) rest-x rest-dom rng))
+              (syntax ((_this arg-vars ... . rest-var)))))]
+          
+          [(->r . x)
+           (raise-syntax-error 'object-contract "malformed ->r declaration")]
+          [(->pp ([x dom] ...) . other-stuff)
+           (andmap identifier? (syntax->list (syntax (x ...))))
+           (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))])
+             (values
+              obj->pp/proc
+              (syntax (->pp ([_this any/c] [x dom] ...) . other-stuff))
+              (syntax ((_this arg-vars ...)))))]
+          [(->pp . x)
+           (raise-syntax-error 'object-contract "malformed ->pp declaration")]
+          [(->pp-rest ([x dom] ...) rest-id . other-stuff)
+           (and (identifier? (syntax id))
+                (andmap identifier? (syntax->list (syntax (x ...)))))
+           (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))])
+             (values
+              obj->pp-rest/proc
+              (syntax (->pp ([_this any/c] [x dom] ...) rest-id . other-stuff))
+              (syntax ((_this arg-vars ... . rest-id)))))]
+          [(->pp-rest . x)
+           (raise-syntax-error 'object-contract "malformed ->pp-rest declaration")]
+          [else (raise-syntax-error 'object-contract "unknown method contract syntax" stx mtd-stx)]))
+      
+      ;; build-methods-stx : syntax[list of lambda arg specs] -> syntax[method realized as proc]
+      (define (build-methods-stx mtds)
+        (let loop ([arg-spec-stxss (map mtd-mtd-arg-stx mtds)]
+                   [names (map mtd-name mtds)]
+                   [i 0])
+          (cond
+            [(null? arg-spec-stxss) null]
+            [else (let ([arg-spec-stxs (car arg-spec-stxss)])
+                    (with-syntax ([(cases ...)
+                                   (map (lambda (arg-spec-stx)
+                                          (with-syntax ([i i])
+                                            (syntax-case arg-spec-stx ()
+                                              [(this rest-ids ...)
+                                               (syntax
+                                                ((this rest-ids ...)
+                                                 ((field-ref this i) (wrapper-object-wrapped this) rest-ids ...)))]
+                                              [else
+                                               (let-values ([(this rest-ids last-var)
+                                                             (let ([lst (syntax->improper-list arg-spec-stx)])
+                                                               (values (car lst)
+                                                                       (all-but-last (cdr lst))
+                                                                       (cdr (last-pair lst))))])
+                                                 (with-syntax ([this this]
+                                                               [(rest-ids ...) rest-ids]
+                                                               [last-var last-var])
+                                                   (syntax
+                                                    ((this rest-ids ... . last-var)
+                                                     (apply (field-ref this i)
+                                                            (wrapper-object-wrapped this)
+                                                            rest-ids ...
+                                                            last-var)))))])))
+                                        (syntax->list arg-spec-stxs))]
+                                  [name (string->symbol (format "~a method" (syntax-object->datum (car names))))])
+                      (with-syntax ([proc (syntax-property (syntax (case-lambda cases ...)) 'method-arity-error #t)])
+                        (cons (syntax (lambda (field-ref) (let ([name proc]) name)))
+                              (loop (cdr arg-spec-stxss)
+                                    (cdr names)
+                                    (+ i 1))))))])))
+      
+      (define (syntax->improper-list stx)
+        (define (se->il se)
+          (cond
+            [(pair? se) (sp->il se)]
+            [else se]))
+        (define (stx->il stx)
+          (se->il (syntax-e stx)))
+        (define (sp->il p)
+          (cond
+            [(null? (cdr p)) p]
+            [(pair? (cdr p)) (cons (car p) (sp->il (cdr p)))]
+            [(syntax? (cdr p)) 
+             (let ([un (syntax-e (cdr p))])
+               (if (pair? un)
+                   (cons (car p) (sp->il un))
+                   p))]))
+        (stx->il stx))
+      
+      (syntax-case stx ()
+        [(_ field/mtd-specs ...)
+         (let* ([mtd/flds (map expand-field/mtd-spec (syntax->list (syntax (field/mtd-specs ...))))]
+		[mtds (filter mtd? mtd/flds)]
+		[flds (filter fld? mtd/flds)])
+           (with-syntax ([(method-ctc-stx ...) (map mtd-ctc-stx mtds)]
+                         [(method-name ...) (map mtd-name mtds)]
+                         [(method-ctc-var ...) (generate-temporaries mtds)]
+                         [(method-var ...) (generate-temporaries mtds)]
+                         [(method/app-var ...) (generate-temporaries mtds)]
+                         [(methods ...) (build-methods-stx mtds)]
+                         
+                         [(field-ctc-stx ...) (map fld-ctc-stx flds)]
+                         [(field-name ...) (map fld-name flds)]
+                         [(field-ctc-var ...) (generate-temporaries flds)]
+                         [(field-var ...) (generate-temporaries flds)]
+                         [(field/app-var ...) (generate-temporaries flds)])
+             (syntax
+              (let ([method-ctc-var method-ctc-stx] 
+                    ...
+                    [field-ctc-var (coerce-contract object-contract field-ctc-stx)]
+                    ...)
+                (let ([method-var (contract-proc method-ctc-var)] 
+                      ...
+                      [field-var (contract-proc field-ctc-var)] 
+                      ...)
+                  (make-contract
+                   `(object-contract 
+                     ,(build-compound-type-name 'method-name method-ctc-var) ...
+                     ,(build-compound-type-name 'field 'field-name field-ctc-var) ...)
+                   (lambda (pos-blame neg-blame src-info orig-str)
+                     (let ([method/app-var (method-var pos-blame neg-blame src-info orig-str)] 
+                           ...
+                           [field/app-var (field-var pos-blame neg-blame src-info orig-str)]
+                           ...)
+                       (let ([cls (make-wrapper-class 'wrapper-class 
+                                                      '(method-name ...)
+                                                      (list methods ...)
+                                                      '(field-name ...))]
+                             [field-names-list '(field-name ...)])
+                         (lambda (val)
+			   (check-object val src-info pos-blame neg-blame orig-str)
+                           (let ([val-mtd-names
+                                  (interface->method-names
+                                   (object-interface
+                                    val))])
+                             (void)
+			     (check-method 'method-name val-mtd-names src-info pos-blame neg-blame orig-str)
+                             ...)
+                           
+                           (unless (field-bound? field-name val)
+			     (field-error 'field-name src-info pos-blame neg-blame orig-str)) ...
+                           
+                           (let ([vtable (extract-vtable val)]
+                                 [method-ht (extract-method-ht val)])
+                             (make-object cls
+                               val
+                               (method/app-var (vector-ref vtable (hash-table-get method-ht 'method-name))) ...
+                               (field/app-var (get-field field-name val)) ...
+                               ))))))))))))]))
+
+    ;; ensure-no-duplicates : syntax (listof syntax[identifier]) -> void
+    (define (ensure-no-duplicates stx form-name names)
+      (let ([ht (make-hash-table)])
+        (for-each (lambda (name)
+                    (let ([key (syntax-e name)])
+                      (when (hash-table-get ht key (lambda () #f))
+                        (raise-syntax-error form-name
+                                            "duplicate method name"
+                                            stx
+                                            name))
+                      (hash-table-put! ht key #t)))
+                  names)))
+    
+    ;; method-specifier? : syntax -> boolean
+    ;; returns #t if x is the syntax for a valid method specifier
+    (define (method-specifier? x)
+      (or (eq? 'public (syntax-e x))
+          (eq? 'override (syntax-e x))))
+    
+    ;; make-object-wrapper-method : syntax syntax[identifier] syntax[identifier] syntax -> syntax
+    ;; constructs a wrapper method that checks the pre and post-condition, and
+    ;; calls the original object's method
+    (define (make-object-wrapper-method outer-args method-name contract-var contract-stx)
+      (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                    [method-name method-name]
+                    [method-name-string (symbol->string (syntax-e method-name))]
+                    [contract-var contract-var])
+        (syntax/loc contract-stx
+          (define/public (method-name . args)
+            (let ([other-method (lambda x (send/apply val method-name x))]
+                  [method-specific-src-info 
+                   (if (identifier? src-info)
+                       (datum->syntax-object
+                        src-info
+                        (string->symbol
+                         (string-append
+                          (symbol->string (syntax-e src-info))
+                          " method "
+                          method-name-string)))
+                       src-info)])
+              (apply (contract-var
+                      other-method
+                      pos-blame
+                      neg-blame
+                      method-specific-src-info)
+                     args))))))
+
+    ;; make-class-wrapper-method : syntax syntax[identifier] syntax[identifier] syntax -> syntax
+    ;; constructs a wrapper method that checks the pre and post-condition, and
+    ;; calls the super method inbetween.
+    (define (make-class-wrapper-method outer-args method-name contract-var contract-stx)
+      (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                    [super-method-name (prefix-super method-name)]
+                    [method-name method-name]
+                    [method-name-string (symbol->string (syntax-e method-name))]
+                    [contract-var contract-var])
+        (syntax/loc contract-stx
+          (define/override method-name
+            (lambda args
+              (let* ([super-method (lambda x (super-method-name . x))]
+                     [method-specific-src-info 
+                      (if (identifier? src-info)
+                          (datum->syntax-object
+                           src-info
+                           (string->symbol
+                            (string-append
+                             (symbol->string (syntax-e src-info))
+                             " method "
+                             method-name-string)))
+                          src-info)]
+                     [super-contract (and super-contracts-ht
+                                          (hash-table-get super-contracts-ht
+                                                          'method-name
+                                                          (lambda () #f)))]
+                     [wrapped-method (contract-var
+                                      super-method
+                                      pos-blame
+                                      neg-blame
+                                      method-specific-src-info)])
+                (apply wrapped-method args)))))))
+    
+    ;; prefix-super : syntax[identifier] -> syntax[identifier]
+    ;; adds super- to the front of the identifier
+    (define (prefix-super stx)
+      (datum->syntax-object
+       #'here
+       (string->symbol
+        (format 
+         "super-~a"
+         (syntax-object->datum
+          stx)))))
+    
+    ;; method-name->contract-method-name : syntax[identifier] -> syntax[identifier]
+    ;; given the syntax for a method name, constructs the name of a method
+    ;; that returns the super's contract for the original method.
+    (define (method-name->contract-method-name stx)
+      (datum->syntax-object
+       #'here
+       (string->symbol
+        (format 
+         "ACK_DONT_GUESS_ME-super-contract-~a"
+         (syntax-object->datum
+          stx)))))
+    
+    ;; Each of the /h functions builds four pieces of syntax:
+    ;;  - [arguments-check]
+    ;;    code that binds the contract values to names and
+    ;;    does error checking for the contract specs
+    ;;    (were the arguments all contracts?)
+    ;;  - [build-proj]
+    ;;    code that partially applies the input contracts to build projections
+    ;;  - [check-val]
+    ;;    code that does error checking on the contract'd value itself
+    ;;    (is it a function of the right arity?)
+    ;;  - [wrapper]
+    ;;    a piece of syntax that has the arguments to the wrapper
+    ;;    and the body of the wrapper.
+    ;; the first function accepts a body expression and wraps
+    ;;    the body expression with checks. In addition, it
+    ;;    adds a let that binds the contract exprssions to names
+    ;;    the results of the other functions mention these names.
+    ;; the second and third function's input syntax should be four
+    ;;    names: val, pos-blame, neg-blame, src-info, orig-str, name-id
+    ;; the fourth function returns a syntax list with two elements,
+    ;;    the argument list (to be used as the first arg to lambda,
+    ;;    or as a case-lambda clause) and the body of the function.
+    ;; They are combined into a lambda for the -> ->* ->d ->d* macros,
+    ;; and combined into a case-lambda for the case-> macro.
+    
+    ;; ->/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
+    (define (->/h method-proc? stx)
+      (syntax-case stx ()
+        [(_) (raise-syntax-error '-> "expected at least one argument" stx)]
+        [(_ dom ... rng)
+         (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
+                       [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))]
+                       [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))]
+                       [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))]
+                       [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))]
+                       [(arg-x ...) (generate-temporaries (syntax (dom ...)))])
+           (with-syntax ([(name-dom-contract-x ...)
+                          (if method-proc?
+                              (cdr
+                               (syntax->list
+                                (syntax (dom-contract-x ...))))
+                              (syntax (dom-contract-x ...)))])
+             (syntax-case* (syntax rng) (any values) module-or-top-identifier=?
+               [any 
+                (values
+                 (lambda (outer-args body)
+                   (with-syntax ([body body]
+                                 [(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+                     (syntax
+                      (let ([dom-contract-x (coerce-contract -> dom)] ...)
+                        (let ([dom-x (contract-proc dom-contract-x)] ...)
+                          (let ([name-id (build-compound-type-name '-> name-dom-contract-x ... 'any)])
+                            body))))))
+                 
+                 (lambda (outer-args inner-lambda)
+                   (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                                 [inner-lambda inner-lambda])
+                     (syntax
+                      (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ...)
+                        inner-lambda))))
+                 
+                 (lambda (outer-args)
+                   (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+                     (syntax
+		      (check-procedure val dom-length src-info pos-blame neg-blame orig-str))))
+                 
+                 (lambda (outer-args)
+                   (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+                     (syntax
+                      ((arg-x ...)
+                       (val (dom-projection-x arg-x) ...))))))]
+               [(values rng ...)
+                (with-syntax ([(rng-x ...) (generate-temporaries (syntax (rng ...)))]
+                              [(rng-contract-x ...) (generate-temporaries (syntax (rng ...)))]
+                              [(rng-projection-x ...) (generate-temporaries (syntax (rng ...)))]
+                              [(rng-length rng-index ...) (generate-indicies (syntax (rng ...)))]
+                              [(rng-ant-x ...) (generate-temporaries (syntax (rng ...)))]
+                              [(res-x ...) (generate-temporaries (syntax (rng ...)))])
+                  (values
+                   (lambda (outer-args body)
+                     (with-syntax ([body body]
+                                   [(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+                       (syntax
+                        (let ([dom-contract-x (coerce-contract -> dom)] ...
+                              [rng-contract-x (coerce-contract -> rng)] ...)
+                          (let ([dom-x (contract-proc dom-contract-x)] ...
+                                [rng-x (contract-proc rng-contract-x)] ...)
+                            (let ([name-id 
+                                   (build-compound-type-name 
+                                    '-> 
+                                    name-dom-contract-x ...
+                                    (build-compound-type-name 'values rng-contract-x ...))])
+                              body))))))
+                   
+                   (lambda (outer-args inner-lambda)
+                     (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                                   [inner-lambda inner-lambda])
+                       (syntax
+                        (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ...
+                              [rng-projection-x (rng-x pos-blame neg-blame src-info orig-str)] ...)
+                          inner-lambda))))
+                   
+                   (lambda (outer-args)
+                     (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+                       (syntax
+			(check-procedure val dom-length src-info pos-blame neg-blame orig-str))))
+                   
+                   (lambda (outer-args)
+                     (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+                       (syntax
+                        ((arg-x ...)
+                         (let-values ([(res-x ...) (val (dom-projection-x arg-x) ...)])
+                           (values (rng-projection-x
+                                    res-x)
+                                   ...))))))))]
+               [rng
+                (with-syntax ([(rng-x) (generate-temporaries (syntax (rng)))]
+                              [(rng-contact-x) (generate-temporaries (syntax (rng)))]
+                              [(rng-projection-x) (generate-temporaries (syntax (rng)))]
+                              [(rng-ant-x) (generate-temporaries (syntax (rng)))]
+                              [(res-x) (generate-temporaries (syntax (rng)))])
+                  (values
+                   (lambda (outer-args body)
+                     (with-syntax ([body body]
+                                   [(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+                       (syntax
+                        (let ([dom-contract-x (coerce-contract -> dom)] ...
+                              [rng-contract-x (coerce-contract -> rng)])
+                          (let ([dom-x (contract-proc dom-contract-x)] ...
+                                [rng-x (contract-proc rng-contract-x)])
+                            (let ([name-id (build-compound-type-name '-> name-dom-contract-x ... rng-contract-x)])
+                              body))))))
+                   
+                   (lambda (outer-args inner-lambda)
+                     (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                                   [inner-lambda inner-lambda])
+                       (syntax
+                        (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ...
+                              [rng-projection-x (rng-x pos-blame neg-blame src-info orig-str)])
+                          inner-lambda))))
+                   
+                   (lambda (outer-args)
+                     (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+                       (syntax
+			(check-procedure val dom-length src-info pos-blame neg-blame orig-str))))
+                   
+                   (lambda (outer-args)
+                     (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+                       (syntax
+                        ((arg-x ...)
+                         (let ([res-x (val (dom-projection-x arg-x) ...)])
+                           (rng-projection-x res-x))))))))])))]))
+    
+    ;; ->*/h : boolean stx -> (values (syntax -> syntax) (syntax syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
+    (define (->*/h method-proc? stx)
+      (syntax-case stx (any)
+        [(_ (dom ...) (rng ...))
+         (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
+                       [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))]
+                       [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))]
+                       [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))]
+                       [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))]
+                       [(arg-x ...) (generate-temporaries (syntax (dom ...)))]
+                       
+                       [(rng-x ...) (generate-temporaries (syntax (rng ...)))]
+                       [(rng-contract-x ...) (generate-temporaries (syntax (rng ...)))]
+                       [(rng-projection-x ...) (generate-temporaries (syntax (rng ...)))]
+                       [(rng-length rng-index ...) (generate-indicies (syntax (rng ...)))]
+                       [(rng-ant-x ...) (generate-temporaries (syntax (rng ...)))]
+                       [(res-x ...) (generate-temporaries (syntax (rng ...)))])
+           (values
+            (lambda (outer-args body)
+              (with-syntax ([body body]
+                            [(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                            [(name-dom-contract-x ...)
+                             (if method-proc?
+                                 (cdr
+                                  (syntax->list
+                                   (syntax (dom-contract-x ...))))
+                                 (syntax (dom-contract-x ...)))])
+                (syntax
+                 (let ([dom-contract-x (coerce-contract ->* dom)] ...
+                       [rng-contract-x (coerce-contract ->* rng)] ...)
+                   (let ([dom-x (contract-proc dom-contract-x)] ...
+                         [rng-x (contract-proc rng-contract-x)] ...)
+                     (let ([name-id  (build-compound-type-name
+                                      '->*
+                                      (build-compound-type-name name-dom-contract-x ...)
+                                      (build-compound-type-name rng-contract-x ...))])
+                       body))))))
+            
+            (lambda (outer-args inner-lambda)
+              (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                            [inner-lambda inner-lambda])
+                (syntax
+                 (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ...
+                       [rng-projection-x (rng-x pos-blame neg-blame src-info orig-str)] ...)
+                   inner-lambda))))
+            
+            (lambda (outer-args)
+              (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+                (syntax
+		 (check-procedure val dom-length src-info pos-blame neg-blame orig-str))))
+            
+            (lambda (outer-args)
+              (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+                (syntax
+                 ((arg-x ...)
+                  (let-values ([(res-x ...) (val (dom-projection-x arg-x) ...)])
+                    (values (rng-projection-x
+                             res-x)
+                            ...))))))))]
+        [(_ (dom ...) any)
+         (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
+                       [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))]
+                       [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))]
+                       [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))]
+                       [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))]
+                       [(arg-x ...) (generate-temporaries (syntax (dom ...)))])
+           (values
+            (lambda (outer-args body)
+              (with-syntax ([body body]
+                            [(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                            [(name-dom-contract-x ...)
+                             (if method-proc?
+                                 (cdr
+                                  (syntax->list
+                                   (syntax (dom-contract-x ...))))
+                                 (syntax (dom-contract-x ...)))])
+                (syntax
+                 (let ([dom-contract-x (coerce-contract ->* dom)] ...)
+                   (let ([dom-x (contract-proc dom-contract-x)] ...)
+                     (let ([name-id (build-compound-type-name
+                                     '->* 
+                                     (build-compound-type-name name-dom-contract-x ...)
+                                     'any)])
+                       body))))))
+            
+            (lambda (outer-args inner-lambda)
+              (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                            [inner-lambda inner-lambda])
+                (syntax
+                 (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ...)
+                   inner-lambda))))
+            
+            (lambda (outer-args)
+              (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+                (syntax
+		 (check-procedure val dom-length src-info pos-blame neg-blame orig-str))))
+            
+            (lambda (outer-args)
+              (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+                (syntax
+                 ((arg-x ...)
+                  (val (dom-projection-x arg-x) ...)))))))]
+        [(_ (dom ...) rest (rng ...))
+         (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
+                       [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))]
+                       [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))]
+                       [(arg-x ...) (generate-temporaries (syntax (dom ...)))]
+                       [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))]
+                       [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))]
+                       [dom-rest-x (car (generate-temporaries (list (syntax rest))))]
+                       [dom-rest-contract-x (car (generate-temporaries (list (syntax rest))))]
+                       [dom-rest-projection-x (car (generate-temporaries (list (syntax rest))))]
+                       [arg-rest-x (car (generate-temporaries (list (syntax rest))))]
+                       
+                       [(rng-x ...) (generate-temporaries (syntax (rng ...)))]
+                       [(rng-contract-x ...) (generate-temporaries (syntax (rng ...)))]
+                       [(rng-projection-x ...) (generate-temporaries (syntax (rng ...)))]
+                       [(rng-length rng-index ...) (generate-indicies (syntax (rng ...)))]
+                       [(rng-ant-x ...) (generate-temporaries (syntax (rng ...)))]
+                       [(res-x ...) (generate-temporaries (syntax (rng ...)))]
+                       [arity (length (syntax->list (syntax (dom ...))))])
+           (values
+            (lambda (outer-args body)
+              (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                            [body body]
+                            [(name-dom-contract-x ...)
+                             (if method-proc?
+                                 (cdr
+                                  (syntax->list
+                                   (syntax (dom-contract-x ...))))
+                                 (syntax (dom-contract-x ...)))])
+                (syntax
+                 (let ([dom-contract-x (coerce-contract ->* dom)] ...
+                       [dom-rest-contract-x (coerce-contract ->* rest)]
+                       [rng-contract-x (coerce-contract ->* rng)] ...)
+                   (let ([dom-x (contract-proc dom-contract-x)] ...
+                         [dom-rest-x (contract-proc dom-rest-contract-x)]
+                         [rng-x (contract-proc rng-contract-x)] ...)
+                     (let ([name-id 
+                            (build-compound-type-name 
+                             '->*
+                             (build-compound-type-name dom-contract-x ...)
+                             dom-rest-contract-x
+                             (build-compound-type-name rng-contract-x ...))])
+                       body))))))
+            (lambda (outer-args inner-lambda)
+              (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                            [inner-lambda inner-lambda])
+                (syntax
+                 (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ...
+                       [dom-rest-projection-x (dom-rest-x neg-blame pos-blame src-info orig-str)]
+                       [rng-projection-x (rng-x pos-blame neg-blame src-info orig-str)] ...)
+                   inner-lambda))))
+            (lambda (outer-args)
+              (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+                (syntax
+		 (check-procedure/more val dom-length src-info pos-blame neg-blame orig-str))))
+            (lambda (outer-args)
+              (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+                (syntax
+                 ((arg-x ... . arg-rest-x)
+                  (let-values ([(res-x ...)
+                                (apply
+                                 val
+                                 (dom-projection-x arg-x)
+                                 ...
+                                 (dom-rest-projection-x arg-rest-x))])
+                    (values (rng-projection-x res-x) ...))))))))]
+	[(_ (dom ...) rest any)
+         (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
+                       [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))]
+                       [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))]
+                       [(arg-x ...) (generate-temporaries (syntax (dom ...)))]
+                       [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))]
+                       [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))]
+                       [dom-rest-x (car (generate-temporaries (list (syntax rest))))]
+                       [dom-rest-contract-x (car (generate-temporaries (list (syntax rest))))]
+                       [dom-projection-rest-x (car (generate-temporaries (list (syntax rest))))]
+                       [arg-rest-x (car (generate-temporaries (list (syntax rest))))]
+                       
+                       [arity (length (syntax->list (syntax (dom ...))))])
+           (values
+            (lambda (outer-args body)
+              (with-syntax ([body body]
+                            [(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                            [(name-dom-contract-x ...)
+                             (if method-proc?
+                                 (cdr
+                                  (syntax->list
+                                   (syntax (dom-contract-x ...))))
+                                 (syntax (dom-contract-x ...)))])
+                (syntax
+                 (let ([dom-contract-x (coerce-contract ->* dom)] ...
+                       [dom-rest-contract-x (coerce-contract ->* rest)])
+                   (let ([dom-x (contract-proc dom-contract-x)] ...
+                         [dom-rest-x (contract-proc dom-rest-contract-x)])
+                     (let ([name-id (build-compound-type-name
+                                     '->* 
+                                     (build-compound-type-name name-dom-contract-x ...)
+                                     dom-rest-contract-x
+                                     'any)])
+                       body))))))
+            (lambda (outer-args inner-lambda)
+              (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                            [inner-lambda inner-lambda])
+                (syntax
+                 (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ...
+                       [dom-projection-rest-x (dom-rest-x neg-blame pos-blame src-info orig-str)])
+                   inner-lambda))))
+            (lambda (outer-args)
+              (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+                (syntax
+		 ;; CHECK: previously, this test didn't use `procedure-arity' and compare to `dom-length'
+		 (check-procedure val dom-length src-info pos-blame neg-blame orig-str))))
+            (lambda (outer-args)
+              (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+                (syntax
+                 ((arg-x ... . arg-rest-x)
+                  (apply
+		   val
+		   (dom-projection-x arg-x)
+		   ...
+		   (dom-projection-rest-x arg-rest-x))))))))]))
+
+    ;; ->d/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
+    (define (->d/h method-proc? stx)
+      (syntax-case stx ()
+        [(_) (raise-syntax-error '->d "expected at least one argument" stx)]
+        [(_ dom ... rng)
+         (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
+                       [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))]
+                       [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))]
+                       [(arg-x ...) (generate-temporaries (syntax (dom ...)))]
+                       [arity (length (syntax->list (syntax (dom ...))))])
+           (values
+            (lambda (outer-args body)
+              (with-syntax ([body body]
+                            [(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                            [(name-dom-contract-x ...)
+                             (if method-proc?
+                                 (cdr
+                                  (syntax->list
+                                   (syntax (dom-contract-x ...))))
+                                 (syntax (dom-contract-x ...)))])
+                (syntax
+                 (let ([dom-contract-x (coerce-contract ->d dom)] ...)
+                   (let ([dom-x (contract-proc dom-contract-x)] ...
+                         [rng-x rng])
+		     (check-rng-procedure '->d rng-x arity)
+                     (let ([name-id (build-compound-type-name '->d name-dom-contract-x ... '(... ...))])
+                       
+                       body))))))
+            (lambda (outer-args inner-lambda)
+              (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                            [inner-lambda inner-lambda])
+                (syntax
+                 (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ...)
+                   inner-lambda))))
+            (lambda (outer-args)
+              (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+                (syntax
+		 (check-procedure val arity src-info pos-blame neg-blame orig-str))))
+            (lambda (outer-args)
+              (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+                (syntax
+                 ((arg-x ...)
+                  (let ([rng-contract (rng-x arg-x ...)])
+                    (((coerce/select-contract ->d rng-contract)
+                      pos-blame
+                      neg-blame
+                      src-info
+                      orig-str)
+                     (val (dom-projection-x arg-x) ...)))))))))]))
+    
+    ;; ->d*/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
+    (define (->d*/h method-proc? stx)
+      (syntax-case stx ()
+        [(_ (dom ...) rng-mk)
+         (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
+                       [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))]
+                       [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))]
+                       [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))]
+                       [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))]
+                       [(arg-x ...) (generate-temporaries (syntax (dom ...)))])
+           (values
+            (lambda (outer-args body)
+              (with-syntax ([body body]
+                            [(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                            [(name-dom-contract-x ...)
+                             (if method-proc?
+                                 (cdr
+                                  (syntax->list
+                                   (syntax (dom-contract-x ...))))
+                                 (syntax (dom-contract-x ...)))])
+                (syntax
+                 (let ([dom-contract-x (coerce-contract ->d* dom)] ...)
+                   (let ([dom-x (contract-proc dom-contract-x)] ...
+                         [rng-mk-x rng-mk])
+		     (check-rng-procedure '->d* rng-mk-x dom-length)
+                     (let ([name-id (build-compound-type-name
+                                     '->d* 
+                                     (build-compound-type-name name-dom-contract-x ...)
+                                     '(... ...))])
+                       body))))))
+            (lambda (outer-args inner-lambda)
+              (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                            [inner-lambda inner-lambda])
+                (syntax
+                 (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ...)
+                   inner-lambda))))
+            (lambda (outer-args)
+              (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+                (syntax
+		 (check-procedure val dom-length src-info pos-blame neg-blame orig-str))))
+            (lambda (outer-args)
+              (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+                (syntax
+                 ((arg-x ...)
+                  (call-with-values
+                   (lambda () (rng-mk-x arg-x ...))
+                   (lambda rng-contracts
+                     (call-with-values
+                      (lambda ()
+                        (val (dom-projection-x arg-x) ...))
+                      (lambda results
+			(check-rng-lengths results rng-contracts)
+                        (apply 
+                         values
+                         (map (lambda (rng-contract result)
+                                (((coerce/select-contract ->d* rng-contract)
+                                  pos-blame
+                                  neg-blame
+                                  src-info
+                                  orig-str)
+                                 result))
+                              rng-contracts
+                              results))))))))))))]
+        [(_ (dom ...) rest rng-mk)
+         (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
+                       [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))]
+                       [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))]
+                       [(dom-rest-x) (generate-temporaries (syntax (rest)))]
+                       [(dom-rest-contract-x) (generate-temporaries (syntax (rest)))]
+                       [(dom-rest-projection-x) (generate-temporaries (syntax (rest)))]
+                       [(arg-x ...) (generate-temporaries (syntax (dom ...)))]
+                       [arity (length (syntax->list (syntax (dom ...))))])
+           (values
+            (lambda (outer-args body)
+              (with-syntax ([body body]
+                            [(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                            [(name-dom-contract-x ...)
+                             (if method-proc?
+                                 (cdr
+                                  (syntax->list
+                                   (syntax (dom-contract-x ...))))
+                                 (syntax (dom-contract-x ...)))])
+                (syntax
+                 (let ([dom-contract-x (coerce-contract ->d* dom)] ...
+                       [dom-rest-contract-x (coerce-contract ->d* rest)])
+                   (let ([dom-x (contract-proc dom-contract-x)] ...
+                         [dom-rest-x (contract-proc dom-rest-contract-x)]
+                         [rng-mk-x rng-mk])
+		     (check-rng-procedure/more rng-mk-x arity)
+                     (let ([name-id (build-compound-type-name 
+                                     '->d*
+                                     (build-compound-type-name name-dom-contract-x ...)
+                                     dom-rest-contract-x
+                                     '(... ...))])
+                       body))))))
+            (lambda (outer-args inner-lambda)
+              (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                            [inner-lambda inner-lambda])
+                (syntax
+                 (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ...
+                       [dom-rest-projection-x (dom-rest-x neg-blame pos-blame src-info orig-str)])
+                   inner-lambda))))
+            (lambda (outer-args)
+              (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+                (syntax
+		 ;; CHECK: old check use "and more", but error message didn't
+		 (check-procedure/more val arity src-info pos-blame neg-blame orig-str))))
+            (lambda (outer-args)
+              (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+                (syntax
+                 ((arg-x ... . rest-arg-x)
+                  (call-with-values
+                   (lambda ()
+                     (apply rng-mk-x arg-x ... rest-arg-x))
+                   (lambda rng-contracts
+                     (call-with-values
+                      (lambda ()
+                        (apply 
+                         val
+                         (dom-projection-x arg-x)
+                         ...
+                         (dom-rest-projection-x rest-arg-x)))
+                      (lambda results
+			(check-rng-lengths results rng-contracts)
+                        (apply 
+                         values
+                         (map (lambda (rng-contract result)
+                                (((coerce/select-contract ->d* rng-contract)
+                                  pos-blame
+                                  neg-blame
+                                  src-info
+                                  orig-str)
+                                 result))
+                              rng-contracts
+                              results))))))))))))]))
+
+    ;; ->r/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
+    (define (->r/h method-proc? stx)
+      (syntax-case stx ()
+        [(_ ([x dom] ...) rng)
+         (syntax-case* (syntax rng) (any values) module-or-top-identifier=?
+           [any 
+            (->r-pp/h method-proc? '->r (syntax (->r ([x dom] ...) #t any)))]
+           [(values . args)
+            (->r-pp/h method-proc? '->r (syntax (->r ([x dom] ...) #t rng #t)))]
+           [rng
+            (->r-pp/h method-proc? '->r (syntax (->r ([x dom] ...) #t rng unused-id #t)))]
+           [_
+            (raise-syntax-error '->r "unknown result contract spec" stx (syntax rng))])]
+        
+        [(_ ([x dom] ...) rest-x rest-dom rng)
+         (syntax-case* (syntax rng) (values any) module-or-top-identifier=?
+           [any 
+            (->r-pp-rest/h method-proc? '->r (syntax (->r ([x dom] ...) rest-x rest-dom #t any)))]
+           [(values . whatever)
+            (->r-pp-rest/h method-proc? '->r (syntax (->r ([x dom] ...) rest-x rest-dom #t rng #t)))]
+           [_
+            (->r-pp-rest/h method-proc? '->r (syntax (->r ([x dom] ...) rest-x rest-dom #t rng unused-id #t)))])]))
+    
+    ;; ->pp/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
+    (define (->pp/h method-proc? stx) (->r-pp/h method-proc? '->pp stx))
+    
+    ;; ->pp/h : boolean symbol stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
+    (define (->r-pp/h method-proc? name stx)
+      (syntax-case stx ()
+        [(_ ([x dom] ...) pre-expr . result-stuff)
+         (and (andmap identifier? (syntax->list (syntax (x ...))))
+              (not (check-duplicate-identifier (syntax->list (syntax (x ...))))))
+         (with-syntax ([stx-name name])
+           (with-syntax ([(dom-id ...) (generate-temporaries (syntax (dom ...)))]
+                         [arity (length (syntax->list (syntax (dom ...))))]
+                         [name-stx
+                          (with-syntax ([(name-xs ...) (if method-proc?
+                                                           (cdr (syntax->list (syntax (x ...))))
+                                                           (syntax (x ...)))])
+                            (syntax 
+                             (build-compound-type-name 'stx-name
+                                                       (build-compound-type-name
+                                                        (build-compound-type-name 'name-xs '(... ...))
+                                                        ...)
+                                                       '(... ...))))])
+             (values
+              (lambda (outer-args body)
+                (with-syntax ([body body]
+                              [(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+                  (syntax
+                   (let ([name-id name-stx])
+                     body))))
+              (lambda (outer-args inner-lambda) inner-lambda)
+              (lambda (outer-args)
+                (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                              [kind-of-thing (if method-proc? 'method 'procedure)])
+                  (syntax
+                   (begin 
+                     (check-procedure/kind val arity 'kind-of-thing src-info pos-blame neg-blame orig-str)))))
+              (lambda (outer-args)
+                (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+                  (syntax-case* (syntax result-stuff) (any values) module-or-top-identifier=?
+                    [(any)
+                     (syntax
+                      ((x ...)
+                       (begin
+                         (check-pre-expr->pp/h pre-expr src-info pos-blame neg-blame orig-str)
+                         (let ([dom-id ((coerce/select-contract stx-name dom) neg-blame pos-blame src-info orig-str)]
+                               ...)
+                           (val (dom-id x) ...)))))]
+                    [((values (rng-ids rng-ctc) ...) post-expr)
+                     (and (andmap identifier? (syntax->list (syntax (rng-ids ...))))
+                          (not (check-duplicate-identifier (syntax->list (syntax (rng-ids ...))))))
+                     (with-syntax ([(rng-ids-x ...) (generate-temporaries (syntax (rng-ids ...)))])
+                       (syntax
+                        ((x ...)
+                         (begin
+                           (check-pre-expr->pp/h pre-expr src-info pos-blame neg-blame orig-str)
+                           (let ([dom-id ((coerce/select-contract stx-name dom) neg-blame pos-blame src-info orig-str)]
+                                 ...)
+                             (let-values ([(rng-ids ...) (val (dom-id x) ...)])
+                               (check-post-expr->pp/h post-expr src-info pos-blame neg-blame orig-str)
+                               (let ([rng-ids-x ((coerce/select-contract stx-name rng-ctc)
+                                                 pos-blame neg-blame src-info orig-str)] ...)
+                                 (values (rng-ids-x rng-ids) ...))))))))]
+                    [((values (rng-ids rng-ctc) ...) post-expr)
+                     (andmap identifier? (syntax->list (syntax (rng-ids ...))))
+                     (let ([dup (check-duplicate-identifier (syntax->list (syntax (rng-ids ...))))])
+                       (raise-syntax-error name "duplicate identifier" stx dup))]
+                    [((values (rng-ids rng-ctc) ...) post-expr)
+                     (for-each (lambda (rng-id) 
+                                 (unless (identifier? rng-id)
+                                   (raise-syntax-error name "expected identifier" stx rng-id)))
+                               (syntax->list (syntax (rng-ids ...))))]
+                    [((values . x) . junk)
+                     (raise-syntax-error name "malformed multiple values result" stx (syntax (values . x)))]
+                    [(rng res-id post-expr)
+                     (syntax
+                      ((x ...)
+                       (begin
+                         (check-pre-expr->pp/h pre-expr src-info pos-blame neg-blame orig-str)
+                         (let ([dom-id ((coerce/select-contract stx-name dom) neg-blame pos-blame src-info orig-str)]
+                               ...
+                               [rng-id ((coerce/select-contract stx-name rng) pos-blame neg-blame src-info orig-str)])
+                           (let ([res-id (rng-id (val (dom-id x) ...))])
+                             (check-post-expr->pp/h post-expr src-info pos-blame neg-blame orig-str)
+                             res-id)))))]
+                    [_ 
+                     (raise-syntax-error name "unknown result specification" stx (syntax result-stuff))]))))))]
+        [(_ ([x dom] ...) pre-expr . result-stuff)
+         (andmap identifier? (syntax->list (syntax (x ...))))
+         (raise-syntax-error 
+          name
+          "duplicate identifier"
+          stx
+          (check-duplicate-identifier (syntax->list (syntax (x ...)))))]
+        [(_ ([x dom] ...) pre-expr . result-stuff)
+         (for-each (lambda (x) (unless (identifier? x) (raise-syntax-error name "expected identifier" stx x)))
+                   (syntax->list (syntax (x ...))))]
+        [(_ (x ...) pre-expr . result-stuff)
+         (for-each (lambda (x)
+                     (syntax-case x ()
+                       [(x y) (identifier? (syntax x)) (void)]
+                       [bad (raise-syntax-error name "expected identifier and contract" stx (syntax bad))]))
+                   (syntax->list (syntax (x ...))))]
+        [(_ x dom pre-expr . result-stuff)
+         (raise-syntax-error name "expected list of identifiers and expression pairs" stx (syntax x))]))
+        
+    ;; ->pp-rest/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
+    (define (->pp-rest/h method-proc? stx) (->r-pp-rest/h method-proc? '->pp-rest stx))
+    
+    ;; ->r-pp-rest/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
+    (define (->r-pp-rest/h method-proc? name stx)
+      (syntax-case stx ()
+        [(_ ([x dom] ...) rest-x rest-dom pre-expr . result-stuff)
+         (and (identifier? (syntax rest-x))
+              (andmap identifier? (syntax->list (syntax (x ...))))
+              (not (check-duplicate-identifier (cons (syntax rest-x) (syntax->list (syntax (x ...)))))))
+         (with-syntax ([stx-name name])
+           (with-syntax ([(dom-id ...) (generate-temporaries (syntax (dom ...)))]
+                         [arity (length (syntax->list (syntax (dom ...))))]
+                         [name-stx 
+                          (with-syntax ([(name-xs ...) (if method-proc?
+                                                           (cdr (syntax->list (syntax (x ...))))
+                                                           (syntax (x ...)))])
+                            (syntax 
+                             (build-compound-type-name 'stx-name
+                                                       `(,(build-compound-type-name 'name-xs '(... ...)) ...)
+                                                       'rest-x
+                                                       '(... ...)
+                                                       '(... ...))))])
+             (values
+              (lambda (outer-args body)
+                (with-syntax ([body body]
+                              [(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+                  (syntax
+                   (let ([name-id name-stx])
+                     body))))
+              (lambda (outer-args inner-lambda) inner-lambda)
+              (lambda (outer-args)
+                (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                              [kind-of-thing (if method-proc? 'method 'procedure)])
+                  (syntax
+                   (begin 
+                     (check-procedure/more/kind val arity 'kind-of-thing src-info pos-blame neg-blame orig-str)))))
+              (lambda (outer-args)
+                (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+                  (syntax-case* (syntax result-stuff) (values any) module-or-top-identifier=?
+                    [(any)
+                     (syntax
+                      ((x ... . rest-x)
+                       (begin
+                         (check-pre-expr->pp/h pre-expr src-info pos-blame neg-blame orig-str)
+                         (let ([dom-id ((coerce/select-contract stx-name dom) neg-blame pos-blame src-info orig-str)]
+                               ...
+                               [rest-id ((coerce/select-contract stx-name rest-dom) neg-blame pos-blame src-info orig-str)])
+                           (apply val (dom-id x) ... (rest-id rest-x))))))]
+                    [(any . x)
+                     (raise-syntax-error name "cannot have anything after any" stx (syntax result-stuff))]
+                    [((values (rng-ids rng-ctc) ...) post-expr)
+                     (and (andmap identifier? (syntax->list (syntax (rng-ids ...))))
+                          (not (check-duplicate-identifier (syntax->list (syntax (rng-ids ...))))))
+                     (with-syntax ([(rng-ids-x ...) (generate-temporaries (syntax (rng-ids ...)))])
+                       (syntax
+                        ((x ... . rest-x)
+                         (begin
+                           (check-pre-expr->pp/h pre-expr src-info pos-blame neg-blame orig-str)
+                           (let ([dom-id ((coerce/select-contract stx-name dom) neg-blame pos-blame src-info orig-str)]
+                                 ...
+                                 [rest-id ((coerce/select-contract stx-name rest-dom) neg-blame pos-blame src-info orig-str)])
+                             (let-values ([(rng-ids ...) (apply val (dom-id x) ... (rest-id rest-x))])
+                               (check-post-expr->pp/h post-expr src-info pos-blame neg-blame orig-str)
+                               (let ([rng-ids-x ((coerce/select-contract stx-name rng-ctc)
+                                                 pos-blame neg-blame src-info orig-str)] ...)
+                                 (values (rng-ids-x rng-ids) ...))))))))]
+                    [((values (rng-ids rng-ctc) ...) . whatever)
+                     (and (andmap identifier? (syntax->list (syntax (rng-ids ...))))
+                          (not (check-duplicate-identifier (syntax->list (syntax (rng-ids ...))))))
+                     (raise-syntax-error name "expected exactly on post-expression at the end" stx)]
+                    [((values (rng-ids rng-ctc) ...) . whatever)
+                     (andmap identifier? (syntax->list (syntax (rng-ids ...))))
+                     (let ([dup (check-duplicate-identifier (syntax->list (syntax (rng-ids ...))))])
+                       (raise-syntax-error name "duplicate identifier" stx dup))]
+                    [((values (rng-ids rng-ctc) ...) . whatever)
+                     (for-each (lambda (rng-id) 
+                                 (unless (identifier? rng-id)
+                                   (raise-syntax-error name "expected identifier" stx rng-id)))
+                               (syntax->list (syntax (rng-ids ...))))]
+                    [((values . x) . whatever)
+                     (raise-syntax-error name "malformed multiple values result" stx (syntax (values . x)))]
+                    [(rng res-id post-expr)
+                     (identifier? (syntax res-id))
+                     (syntax
+                      ((x ... . rest-x)
+                       (begin
+                         (check-pre-expr->pp/h pre-expr src-info pos-blame neg-blame orig-str)
+                         (let ([dom-id ((coerce/select-contract stx-name dom) neg-blame pos-blame src-info orig-str)]
+                               ...
+                               [rest-id ((coerce/select-contract stx-name rest-dom) neg-blame pos-blame src-info orig-str)]
+                               [rng-id ((coerce/select-contract stx-name rng) pos-blame neg-blame src-info orig-str)])
+                           (let ([res-id (rng-id (apply val (dom-id x) ... (rest-id rest-x)))])
+                             (check-post-expr->pp/h post-expr src-info pos-blame neg-blame orig-str)
+                             res-id)))))]
+                    [(rng res-id post-expr)
+                     (not (identifier? (syntax res-id)))
+                     (raise-syntax-error name "expected an identifier" stx (syntax res-id))]
+                    [_
+                     (raise-syntax-error name "malformed result sepecification" stx (syntax result-stuff))]))))))]
+        [(_ ([x dom] ...) rest-x rest-dom pre-expr . result-stuff)
+         (not (identifier? (syntax rest-x)))
+         (raise-syntax-error name "expected identifier" stx (syntax rest-x))]
+        [(_ ([x dom] ...) rest-x rest-dom rng . result-stuff)
+         (and (identifier? (syntax rest-x))
+              (andmap identifier? (cons (syntax rest-x) (syntax->list (syntax (x ...))))))
+         (raise-syntax-error 
+          name
+          "duplicate identifier"
+          stx
+          (check-duplicate-identifier (syntax->list (syntax (x ...)))))]
+
+        [(_ ([x dom] ...) rest-x rest-dom rng . result-stuff)
+         (for-each (lambda (x) (unless (identifier? x) (raise-syntax-error name "expected identifier" stx x)))
+                   (cons
+                    (syntax rest-x)
+                    (syntax->list (syntax (x ...)))))]
+        [(_ x dom rest-x rest-dom rng . result-stuff)
+         (raise-syntax-error name "expected list of identifiers and expression pairs" stx (syntax x))]))
+    
+    ;; select/h : syntax -> /h-function
+    (define (select/h stx err-name ctxt-stx)
+      (syntax-case stx (-> ->* ->d ->d* ->r ->pp ->pp-rest)
+        [(-> . args) ->/h]
+        [(->* . args) ->*/h]
+        [(->d . args) ->d/h]
+        [(->d* . args) ->d*/h]
+        [(->r . args) ->r/h]
+        [(->pp . args) ->pp/h]
+        [(->pp-rest . args) ->pp-rest/h]
+        [(xxx . args) (raise-syntax-error err-name "unknown arrow constructor" ctxt-stx (syntax xxx))]
+        [_ (raise-syntax-error err-name "malformed arrow clause" ctxt-stx stx)]))
+    
+    
+    ;; set-inferred-name-from : syntax syntax -> syntax
+    (define (set-inferred-name-from with-name to-be-named)
+      (let ([name (syntax-local-infer-name with-name)])
+        (cond
+          [(identifier? name)
+           (with-syntax ([rhs (syntax-property to-be-named 'inferred-name (syntax-e name))]
+                         [name (syntax-e name)])
+             (syntax (let ([name rhs]) name)))]
+          [(symbol? name)
+           (with-syntax ([rhs (syntax-property to-be-named 'inferred-name name)]
+                         [name name])
+             (syntax (let ([name rhs]) name)))]
+          [else to-be-named])))
+    
+    ;; (cons X (listof X)) -> (listof X)
+    ;; returns the elements of `l', minus the last element
+    ;; special case: if l is an improper list, it leaves off
+    ;; the contents of the last cdr (ie, making a proper list
+    ;; out of the input), so (all-but-last '(1 2 . 3)) = '(1 2)
+    (define (all-but-last l)
+      (cond
+        [(null? l) (error 'all-but-last "bad input")]
+        [(not (pair? l)) '()]
+        [(null? (cdr l)) null]
+        [(pair? (cdr l)) (cons (car l) (all-but-last (cdr l)))]
+        [else (list (car l))]))
+    
+    ;; generate-indicies : syntax[list] -> (cons number (listof number))
+    ;; given a syntax list of length `n', returns a list containing
+    ;; the number n followed by th numbers from 0 to n-1
+    (define (generate-indicies stx)
+      (let ([n (length (syntax->list stx))])
+        (cons n
+              (let loop ([i n])
+                (cond
+                  [(zero? i) null]
+                  [else (cons (- n i)
+                              (loop (- i 1)))]))))))
+
+  ;; procedure-accepts-and-more? : procedure number -> boolean
+  ;; returns #t if val accepts dom-length arguments and
+  ;; any number of arguments more than dom-length. 
+  ;; returns #f otherwise.
+  (define (procedure-accepts-and-more? val dom-length)
+    (let ([arity (procedure-arity val)])
+      (cond
+        [(number? arity) #f]
+        [(arity-at-least? arity)
+         (<= (arity-at-least-value arity) dom-length)]
+        [else
+         (let ([min-at-least (let loop ([ars arity]
+                                        [acc #f])
+                               (cond
+                                 [(null? ars) acc]
+                                 [else (let ([ar (car ars)])
+                                         (cond
+                                           [(arity-at-least? ar)
+                                            (if (and acc
+                                                     (< acc (arity-at-least-value ar)))
+                                                (loop (cdr ars) acc)
+                                                (loop (cdr ars) (arity-at-least-value ar)))]
+                                           [(number? ar)
+                                            (loop (cdr ars) acc)]))]))])
+           (and min-at-least
+                (begin
+                  (let loop ([counts (quicksort (filter number? arity) >=)])
+                    (unless (null? counts)
+                      (let ([count (car counts)])
+                        (cond
+                          [(= (+ count 1) min-at-least)
+                           (set! min-at-least count)
+                           (loop (cdr counts))]
+                          [(< count min-at-least)
+                           (void)]
+                          [else (loop (cdr counts))]))))
+                  (<= min-at-least dom-length))))])))
+
+  ;; ----------------------------------------
+  ;; Checks and error functions used in macro expansions
+  
+  (define (check->* f arity-count)
+    (unless (procedure? f)
+      (error 'object-contract "expected last argument of ->d* to be a procedure, got ~e" f))
+    (unless (procedure-arity-includes? f arity-count)
+      (error 'object-contract 
+	     "expected last argument of ->d* to be a procedure that accepts ~a arguments, got ~e"
+	     arity-count
+	     f)))
+
+  (define (check->*/more f arity-count)
+    (unless (procedure? f)
+      (error 'object-contract "expected last argument of ->d* to be a procedure, got ~e" f))
+    (unless (procedure-accepts-and-more? f arity-count)
+      (error 'object-contract 
+	     "expected last argument of ->d* to be a procedure that accepts ~a arguments and arbitrarily many more, got ~e"
+	     arity-count
+	     f)))
+
+
+  (define (check-pre-expr->pp/h pre-expr src-info pos-blame neg-blame orig-str)
+    (unless pre-expr
+      (raise-contract-error src-info
+                            neg-blame
+                            pos-blame
+                            orig-str
+                            "pre-condition expression failure")))
+  
+  (define (check-post-expr->pp/h post-expr src-info pos-blame neg-blame orig-str)
+    (unless post-expr
+      (raise-contract-error src-info
+                            pos-blame
+                            neg-blame
+                            orig-str
+                            "post-condition expression failure")))
+  
+  (define (check-procedure val dom-length src-info pos-blame neg-blame orig-str)
+    (unless (and (procedure? val)
+		 (procedure-arity-includes? val dom-length))
+      (raise-contract-error
+       src-info
+       pos-blame
+       neg-blame
+       orig-str
+       "expected a procedure that accepts ~a arguments, given: ~e"
+       dom-length
+       val)))
+
+  (define (check-procedure/kind val arity kind-of-thing src-info pos-blame neg-blame orig-str)
+    (unless (procedure? val)
+      (raise-contract-error src-info
+			    pos-blame
+			    neg-blame
+			    orig-str
+			    "expected a procedure, got ~e"
+			    val))
+    (unless (procedure-arity-includes? val arity)
+      (raise-contract-error src-info
+			    pos-blame
+			    neg-blame
+			    orig-str
+			    "expected a ~a of arity ~a (not arity ~a), got  ~e"
+			    kind-of-thing
+			    arity
+			    (procedure-arity val)
+			    val)))
+
+  (define (check-procedure/more/kind val arity kind-of-thing src-info pos-blame neg-blame orig-str)
+    (unless (procedure? val)
+      (raise-contract-error src-info
+			    pos-blame
+			    neg-blame
+			    orig-str
+			    "expected a procedure, got ~e"
+			    val))
+    (unless (procedure-accepts-and-more? val arity)
+      (raise-contract-error src-info
+			    pos-blame
+			    neg-blame
+			    orig-str
+			    "expected a ~a that accepts ~a arguments and aribtrarily more (not arity ~a), got  ~e"
+			    kind-of-thing
+			    arity
+			    (procedure-arity val)
+			    val)))
+
+  (define (check-procedure/more val dom-length src-info pos-blame neg-blame orig-str)
+    (unless (and (procedure? val)
+		 (procedure-accepts-and-more? val dom-length))
+      (raise-contract-error
+       src-info
+       pos-blame
+       neg-blame
+       orig-str
+       "expected a procedure that accepts ~a arguments and any number of arguments larger than ~a, given: ~e"
+       dom-length
+       dom-length
+       val)))
+
+
+  (define (check-rng-procedure who rng-x arity)
+    (unless (and (procedure? rng-x)
+		 (procedure-arity-includes? rng-x arity))
+      (error who "expected range position to be a procedure that accepts ~a arguments, given: ~e"
+	     arity
+	     rng-x)))
+
+  (define (check-rng-procedure/more rng-mk-x arity)
+    (unless (and (procedure? rng-mk-x)
+		 (procedure-accepts-and-more? rng-mk-x arity))
+      (error '->d* "expected range position to be a procedure that accepts ~a arguments and arbitrarily many more, given: ~e"
+	     arity 
+	     rng-mk-x)))
+
+  (define (check-rng-lengths results rng-contracts)
+    (unless (= (length results) (length rng-contracts))
+      (error '->d* 
+	     "expected range contract contructor and function to have the same number of values, given: ~a and ~a respectively" 
+	     (length results) (length rng-contracts))))
+
+  (define (check-object val src-info pos-blame neg-blame orig-str)
+    (unless (object? val)
+      (raise-contract-error src-info
+			    pos-blame
+			    neg-blame
+			    orig-str
+			    "expected an object, got ~e"
+			    val)))
+
+  (define (check-method method-name val-mtd-names src-info pos-blame neg-blame orig-str)
+    (unless (memq method-name val-mtd-names)
+      (raise-contract-error src-info
+			    pos-blame
+			    neg-blame
+			    orig-str
+			    "expected an object with method ~s"
+			    method-name)))
+
+  (define (field-error field-name src-info pos-blame neg-blame orig-str)
+    (raise-contract-error src-info
+			  pos-blame
+			  neg-blame
+			  orig-str
+			  "expected an object with field ~s"
+			  field-name))
+                                                
+  #|
+
+  test cases for procedure-accepts-and-more?
+
+  (and (procedure-accepts-and-more? (lambda (x . y) 1) 3)
+       (procedure-accepts-and-more? (lambda (x . y) 1) 2)
+       (procedure-accepts-and-more? (lambda (x . y) 1) 1)
+       (not (procedure-accepts-and-more? (lambda (x . y) 1) 0))
+       
+       (procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 3)
+       (procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 2)
+       (procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 1)
+       (not (procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 0))
+       
+       (procedure-accepts-and-more? (case-lambda [(x y . z) 1] [(x) 1]) 2)
+       (procedure-accepts-and-more? (case-lambda [(x y . z) 1] [(x) 1]) 1)
+       (not (procedure-accepts-and-more? (case-lambda [(x y . z) 1] [(x) 1]) 0)))
+  
+  |#
+    
+    
+  ;; coerce/select-contract : id (union contract? procedure-arity-1) -> contract-proc
+  ;; contract-proc = sym sym stx -> alpha -> alpha
+  ;; returns the procedure for the contract after extracting it from the
+  ;; struct. Coerces the argument to a flat contract if it is procedure, but first.
+  (define-syntax (coerce/select-contract stx)
+    (syntax-case stx ()
+      [(_ name val)
+       (syntax
+        (let ([x val])
+          (cond
+            [(contract? x)
+             (contract-proc x)]
+            [(and (procedure? x) (procedure-arity-includes? x 1))
+             (contract-proc (flat-contract x))]
+            [else
+             (error 'name 
+                    "expected contract or procedure of arity 1, got ~e"
+                    x)])))]))
+  
+  ;; coerce-contract : id (union contract? procedure-arity-1) -> contract
+  ;; contract-proc = sym sym stx -> alpha -> alpha
+  ;; returns the procedure for the contract after extracting it from the
+  ;; struct. Coerces the argument to a flat contract if it is procedure, but first.
+  (define-syntax (coerce-contract stx)
+    (syntax-case stx ()
+      [(_ name val)
+       (syntax
+        (let ([x val])
+          (cond
+            [(contract? x) x]
+            [(and (procedure? x) (procedure-arity-includes? x 1))
+             (flat-contract x)]
+            [else
+             (error 'name 
+                    "expected contract or procedure of arity 1, got ~e"
+                    x)])))]))
+
+
+;                                                                                                   
+;                                                                                                   
+;                                                                                                   
+;               ;                                                                                   
+;                                                                                                   
+;                                                                ;                       ;          
+;   ; ;;  ;;    ;    ;;;    ;;;            ;;;    ;;;    ; ;;   ;;;;  ; ;  ;;;     ;;;  ;;;;   ;;;  
+;   ;;  ;;  ;   ;   ;      ;   ;          ;   ;  ;   ;   ;;  ;   ;    ;;  ;   ;   ;   ;  ;    ;     
+;   ;   ;   ;   ;   ;;    ;              ;      ;     ;  ;   ;   ;    ;       ;  ;       ;    ;;    
+;   ;   ;   ;   ;    ;;   ;              ;      ;     ;  ;   ;   ;    ;    ;;;;  ;       ;     ;;   
+;   ;   ;   ;   ;      ;  ;              ;      ;     ;  ;   ;   ;    ;   ;   ;  ;       ;       ;  
+;   ;   ;   ;   ;      ;   ;   ;  ;       ;   ;  ;   ;   ;   ;   ;    ;   ;   ;   ;   ;  ;       ;  
+;   ;   ;   ;   ;   ;;;     ;;;   ;        ;;;    ;;;    ;   ;    ;;  ;    ;;;;;   ;;;    ;;  ;;;   
+;                                                                                                   
+;                                                                                                   
+;                                                                                                   
+
+  
+  
+  (provide any/c
+           anaphoric-contracts
+           flat-rec-contract
+           flat-murec-contract
+	   union
+           and/c
+	   not/c
+           =/c >=/c <=/c </c >/c 
+           integer-in
+           exact-integer-in
+	   real-in
+           natural-number/c
+	   string/len
+           false/c
+	   printable/c
+           symbols
+	   is-a?/c subclass?/c implementation?/c
+           listof list-immutableof 
+           vectorof vector-immutableof vector/c vector-immutable/c 
+           cons-immutable/c cons/c list-immutable/c list/c
+           box-immutable/c box/c
+           promise/c
+           struct/c
+	   mixin-contract make-mixin-contract
+           syntax/c)
+  
+  (define-syntax (flat-rec-contract stx)
+    (syntax-case stx  ()
+      [(_ name ctc ...)
+       (identifier? (syntax name))
+       (with-syntax ([(ctc-id ...) (generate-temporaries (syntax (ctc ...)))]
+                     [(pred-id ...) (generate-temporaries (syntax (ctc ...)))])
+         (syntax 
+          (let* ([pred (lambda (x) (error 'flat-rec-contract "applied too soon"))]
+                 [name (flat-contract (let ([name (lambda (x) (pred x))]) name))])
+            (let ([ctc-id (coerce-contract flat-rec-contract ctc)] ...)
+              (unless (flat-contract? ctc-id)
+                (error 'flat-rec-contract "expected flat contracts as arguments, got ~e" ctc-id))
+              ...
+              (set! pred
+                    (let ([pred-id (flat-contract-predicate ctc-id)] ...)
+                      (lambda (x)
+                        (or (pred-id x) ...))))
+              name))))]
+      [(_ name ctc ...)
+       (raise-syntax-error 'flat-rec-contract "expected first argument to be an identifier" stx (syntax name))]))
+
+  (define-syntax (flat-murec-contract stx)
+    (syntax-case stx  ()
+      [(_ ([name ctc ...] ...) body1 body ...)
+       (andmap identifier? (syntax->list (syntax (name ...))))
+       (with-syntax ([((ctc-id ...) ...) (map generate-temporaries
+                                              (syntax->list (syntax ((ctc ...) ...))))]
+                     [(pred-id ...) (generate-temporaries (syntax (name ...)))]
+                     [((pred-arm-id ...) ...) (map generate-temporaries
+                                               (syntax->list (syntax ((ctc ...) ...))))])
+         (syntax 
+          (let* ([pred-id (lambda (x) (error 'flat-murec-contract "applied too soon"))] ...
+                 [name (flat-contract (let ([name (lambda (x) (pred-id x))]) name))] ...)
+            (let-values ([(ctc-id ...) (values (coerce-contract flat-rec-contract ctc) ...)] ...)
+              (begin
+                (void)
+                (unless (flat-contract? ctc-id)
+                  (error 'flat-rec-contract "expected flat contracts as arguments, got ~e" ctc-id))
+                ...) ...
+              (set! pred-id
+                    (let ([pred-arm-id (flat-contract-predicate ctc-id)] ...)
+                      (lambda (x)
+                        (or (pred-arm-id x) ...)))) ...
+              body1
+              body ...))))]
+      [(_ ([name ctc ...] ...) body1 body ...)
+       (for-each (lambda (name)
+                   (unless (identifier? name)
+                     (raise-syntax-error 'flat-rec-contract
+                                         "expected an identifier" stx name)))
+                 (syntax->list (syntax (name ...))))]
+      [(_ ([name ctc ...] ...))
+       (raise-syntax-error 'flat-rec-contract "expected at least one body expression" stx)]))
+      
+  
+  (define anaphoric-contracts
+    (case-lambda
+      [() (make-anaphoric-contracts (make-hash-table 'weak))]
+      [(x)
+       (unless (eq? x 'equal)
+         (error 'anaphoric-contracts "expected either no arguments, or 'equal as first argument, got ~e" x))
+       (make-anaphoric-contracts (make-hash-table 'equal 'weak))]))
+
+  (define (make-anaphoric-contracts ht)
+    (values
+     (flat-named-contract
+      "(anaphoric-contracts,from)"
+      (lambda (v)
+        (hash-table-put! ht v #t)
+        v))
+     (flat-named-contract
+      "(anaphoric-contracts,to)"
+      (lambda (v)
+        (hash-table-get ht v (lambda () #f))))))     
+  
+  (define (union . args)
+    (for-each
+     (lambda (x) 
+       (unless (or (contract? x)
+                   (and (procedure? x)
+                        (procedure-arity-includes? x 1)))
+         (error 'union "expected procedures of arity 1 or contracts, given: ~e" x)))
+     args)
+    (let-values ([(contract fc/predicates)
+                  (let loop ([contract #f]
+                             [fc/predicates null]
+                             [args args])
+                    (cond
+                      [(null? args) (values contract (reverse fc/predicates))]
+                      [else 
+                       (let ([arg (car args)])
+                         (cond
+                           [(or (flat-contract? arg)
+                                (not (contract? arg)))
+                            (loop contract (cons arg fc/predicates) (cdr args))]
+                           [contract
+                            (error 'union "expected at most one non-flat contract, given ~e and ~e"
+                                   contract
+                                   arg)]
+                           [else (loop arg fc/predicates (cdr args))]))]))])
+      (let* ([flat-contracts (map (lambda (x) (if (flat-contract? x)
+                                                  x
+                                                  (flat-contract x)))
+                                  fc/predicates)]
+             [predicates (map flat-contract-predicate flat-contracts)])
+        (cond
+          [contract
+           (let ([c-proc (contract-proc contract)])
+             (make-contract
+              (apply build-compound-type-name 'union contract flat-contracts)
+              (lambda (pos neg src-info orig-str)
+                (let ([partial-contract (c-proc pos neg src-info orig-str)])
+                  (lambda (val)
+                    (cond
+                      [(ormap (lambda (pred) (pred val)) predicates)
+                       val]
+                      [else
+                       (partial-contract val)]))))))]
+          [else
+           (build-flat-contract
+            (apply build-compound-type-name 'union flat-contracts)
+            (lambda (x)
+              (ormap (lambda (pred) (pred x)) predicates)))]))))
+  
+  (define false/c
+    (flat-named-contract
+     'false/c
+     (lambda (x) (not x))))
+  
+  (define any/c
+    (make-flat-contract
+     'any/c
+     (lambda (pos neg src-info orig-str) (lambda (val) val))
+     (lambda (x) #t)))
+
+  (define (string/len n)
+    (unless (number? n)
+      (error 'string/len "expected a number as argument, got ~e" n))
+    (flat-named-contract 
+     `(string/len ,n)
+     (lambda (x)
+       (and (string? x)
+            ((string-length x) . < . n)))))
+  
+  (define (symbols . ss)
+    (unless ((length ss) . >= . 1)
+      (error 'symbols "expected at least one argument"))
+    (unless (andmap symbol? ss)
+      (error 'symbols "expected symbols as arguments, given: ~a"
+	     (apply string-append (map (lambda (x) (format "~e " x)) ss))))
+    (flat-named-contract
+     `(symbols ,@(map (lambda (x) `',x) ss))
+     (lambda (x)
+       (memq x ss))))
+  
+  (define printable/c
+    (flat-named-contract
+     'printable/c
+     (lambda (x)
+       (let printable? ([x x])
+	 (or (symbol? x)
+	     (string? x)
+	     (bytes? x)
+	     (boolean? x)
+	     (char? x)
+	     (null? x)
+	     (number? x)
+	     (regexp? x)
+	     (and (pair? x)
+		  (printable? (car x))
+		  (printable? (cdr x)))
+	     (and (vector? x)
+		  (andmap printable? (vector->list x)))
+	     (and (box? x)
+		  (printable? (unbox x))))))))
+  
+  (define (=/c x)
+    (flat-named-contract
+     `(=/c ,x)
+     (lambda (y) (and (number? y) (= y x)))))
+  (define (>=/c x)
+    (flat-named-contract
+     `(>=/c ,x)
+     (lambda (y) (and (number? y) (>= y x)))))
+  (define (<=/c x)
+    (flat-named-contract
+     `(<=/c ,x)
+     (lambda (y) (and (number? y) (<= y x)))))
+  (define (</c x)
+    (flat-named-contract
+     `(</c ,x)
+     (lambda (y) (and (number? y) (< y x)))))
+  (define (>/c x)
+    (flat-named-contract
+     `(>/c ,x)
+     (lambda (y) (and (number? y) (> y x)))))
+
+  (define natural-number/c
+    (flat-named-contract
+     'natural-number/c
+     (lambda (x)
+       (and (number? x)
+	    (integer? x)
+	    (x . >= . 0)))))
+  
+  (define (integer-in start end)
+    (unless (and (integer? start)
+                 (integer? end))
+      (error 'integer-in "expected two integers as arguments, got ~e and ~e" start end))
+    (flat-named-contract 
+     `(integer-in ,start ,end)
+     (lambda (x)
+       (and (integer? x)
+            (<= start x end)))))
+  
+  (define (exact-integer-in start end)
+    (unless (and (integer? start)
+                 (exact? start)
+                 (integer? end)
+                 (exact? end))
+      (error 'integer-in "expected two exact integers as arguments, got ~e and ~e" start end))
+    (flat-named-contract 
+     `(exact-integer-in ,start ,end)
+     (lambda (x)
+       (and (integer? x)
+            (exact? x)
+            (<= start x end)))))
+
+  (define (real-in start end)
+    (unless (and (real? start)
+                 (real? end))
+      (error 'real-in "expected two real numbers as arguments, got ~e and ~e" start end))
+    (flat-named-contract 
+     `(real-in ,start ,end)
+     (lambda (x)
+       (and (real? x)
+            (<= start x end)))))
+  
+  (define (and/c . fs)
+    (for-each
+     (lambda (x) 
+       (unless (or (contract? x)
+                   (and (procedure? x)
+                        (procedure-arity-includes? x 1)))
+         (error 'and/c "expected procedures of arity 1 or <contract>s, given: ~e" x)))
+     fs)
+    (cond
+      [(null? fs) any/c]
+      [(andmap flat-contract/predicate? fs)
+       (let* ([to-predicate
+	       (lambda (x)
+		 (if (flat-contract? x)
+		     (flat-contract-predicate x)
+		     x))]
+	      [contracts (map (lambda (x) (if (contract? x) x (flat-contract x))) fs)]
+              [pred
+	       (let loop ([pred (to-predicate (car fs))]
+			  [preds (cdr fs)])
+		 (cond
+		   [(null? preds) pred]
+		   [else
+		    (let* ([fst (to-predicate (car preds))])
+		      (loop (let ([and/c-contract? (lambda (x) (and (pred x) (fst x)))])
+                              and/c-contract?)
+			    (cdr preds)))]))])
+	 (flat-named-contract (apply build-compound-type-name 'and/c contracts) pred))]
+      [else
+       (let* ([contracts (map (lambda (x) (if (contract? x) x (flat-contract x))) fs)]
+              [contract/procs (map contract-proc contracts)])
+	 (make-contract
+          (apply build-compound-type-name 'and/c contracts)
+          (lambda (pos neg src-info orig-str)
+            (let ([partial-contracts (map (lambda (contract/proc) (contract/proc pos neg src-info orig-str))
+                                          contract/procs)])
+              (let loop ([ctct (car partial-contracts)]
+                         [rest (cdr partial-contracts)])
+                (cond
+                  [(null? rest) ctct]
+                  [else 
+                   (let ([fst (car rest)])
+                     (loop (lambda (x) (fst (ctct x)))
+                           (cdr rest)))]))))))]))
+
+  (define (not/c f)
+    (unless (flat-contract/predicate? f)
+      (error 'not/c "expected a procedure of arity 1 or <flat-named-contract>, given: ~e" f))
+    (build-flat-contract
+     (build-compound-type-name 'not/c (proc/ctc->ctc f))
+     (lambda (x) (not (test-proc/flat-contract f x)))))
+
+  (define (is-a?/c <%>)
+    (unless (or (interface? <%>)
+		(class? <%>))
+      (error 'is-a?/c "expected <interface> or <class>, given: ~e" <%>))
+    (let ([name (object-name <%>)])
+      (flat-named-contract
+       (cond
+         [name
+          `(is-a?/c ,name)]
+         [(class? <%>)
+          `(is-a?/c unknown%)]
+         [else `(is-a?/c unknown<%>)])
+       (lambda (x) (is-a? x <%>)))))
+
+  (define (listof p)
+    (unless (flat-contract/predicate? p)
+      (error 'listof "expected a flat contract or procedure of arity 1 as argument, got: ~e" p))
+    (build-flat-contract
+     (build-compound-type-name 'listof (proc/ctc->ctc p))
+     (lambda (v)
+       (and (list? v)
+	    (andmap (lambda (ele) (test-proc/flat-contract p ele))
+		    v)))))
+  
+  (define-syntax (*-immutableof stx)
+    (syntax-case stx ()
+      [(_ predicate? fill type-name name)
+       (syntax
+        (let ([predicate?-name predicate?]
+              [fill-name fill])
+          (lambda (input)
+            (let* ([ctc (coerce-contract name input)]
+                   [p (contract-proc ctc)])
+              (make-contract
+               (build-compound-type-name 'name ctc)
+               (lambda (pos neg src-info orig-str)
+                 (let ([p-app (p pos neg src-info orig-str)])
+                   (lambda (val)
+                     (unless (predicate?-name val)
+                       (raise-contract-error
+                        src-info
+                        pos
+                        neg
+                        orig-str
+                        "expected <~a>, given: ~e"
+                        'type-name
+                        val))
+                     (fill-name p-app val)))))))))]))
+  
+  (define (map-immutable f lst)
+    (let loop ([lst lst])
+      (cond
+        [(pair? lst)
+         (cons-immutable (f (car lst))
+                         (loop (cdr lst)))]
+        [(null? lst) null])))
+  
+  (define (immutable-list? lst)
+    (cond
+      [(and (pair? lst)
+            (immutable? lst))
+       (immutable-list? (cdr lst))]
+      [(null? lst) #t]
+      [else #f]))
+  
+  (define list-immutableof
+    (*-immutableof immutable-list? map-immutable immutable-list list-immutableof))  
+
+  (define vector-immutableof
+    (*-immutableof (lambda (x) (and (vector? x) (immutable? x)))
+                   (lambda (f v) (apply vector-immutable (map f (vector->list v))))
+                   immutable-vector
+                   vector-immutableof))
+  
+  (define (vectorof p)
+    (unless (flat-contract/predicate? p)
+      (error 'vectorof "expected a flat contract or procedure of arity 1 as argument, got: ~e" p))
+    (build-flat-contract
+     (build-compound-type-name 'vectorof (proc/ctc->ctc p))
+     (lambda (v)
+       (and (vector? v)
+	    (andmap (lambda (ele) (test-proc/flat-contract p ele))
+		    (vector->list v))))))
+
+  (define (vector/c . args)
+    (unless (andmap flat-contract/predicate? args)
+      (error 'vector/c "expected flat contracts as arguments, got: ~a"
+             (let loop ([args args])
+               (cond
+                 [(null? args) ""]
+                 [(null? (cdr args)) (format "~e" (car args))]
+                 [else (string-append
+                        (format "~e " (car args))
+                        (loop (cdr args)))]))))
+    (let ([largs (length args)])
+      (build-flat-contract
+       (apply build-compound-type-name 'vector/c (map proc/ctc->ctc args))
+       (lambda (v)
+         (and (vector? v)
+              (= (vector-length v) largs)
+              (andmap test-proc/flat-contract
+                      args
+                      (vector->list v)))))))
+  
+  (define (box/c pred)
+    (unless (flat-contract/predicate? pred)
+      (error 'box/c "expected a flat contract or a procedure of arity 1, got: ~e" pred))
+    (build-flat-contract
+     (build-compound-type-name 'box/c (proc/ctc->ctc pred))
+     (lambda (x)
+       (and (box? x)
+	    (test-proc/flat-contract pred (unbox x))))))
+
+  (define (cons/c hdp tlp)
+    (unless (and (flat-contract/predicate? hdp)
+                 (flat-contract/predicate? tlp))
+      (error 'cons/c "expected two flat contracts or procedures of arity 1, got: ~e and ~e" hdp tlp))
+    (build-flat-contract
+     (build-compound-type-name 'cons/c (proc/ctc->ctc hdp) (proc/ctc->ctc tlp))
+     (lambda (x)
+       (and (pair? x)
+            (test-proc/flat-contract hdp (car x))
+            (test-proc/flat-contract tlp (cdr x))))))
+  
+  (define-syntax (*-immutable/c stx)
+    (syntax-case stx ()
+      [(_ predicate? constructor (arb? selectors ...) type-name name)
+       (eq? #f (syntax-object->datum (syntax arb?)))
+       (with-syntax ([(params ...) (generate-temporaries (syntax (selectors ...)))]
+                     [(p-apps ...) (generate-temporaries (syntax (selectors ...)))]
+                     [(procs ...) (generate-temporaries (syntax (selectors ...)))]
+                     [(selector-names ...) (generate-temporaries (syntax (selectors ...)))])
+         (syntax
+          (let ([predicate?-name predicate?]
+                [constructor-name constructor]
+                [selector-names selectors] ...)
+            (lambda (params ...)
+              (let ([procs (coerce/select-contract name params)] ...)
+                (make-contract
+                 (build-compound-type-name 'name (proc/ctc->ctc params) ...)
+                 (lambda (pos neg src-info orig-str)
+                   (let ([p-apps (procs pos neg src-info orig-str)] ...)
+                     (lambda (v)
+                       (if (and (immutable? v)
+                                (predicate?-name v))
+                           (constructor-name (p-apps (selector-names v)) ...)
+                           (raise-contract-error
+                            src-info
+                            pos
+                            neg
+                            orig-str
+                            "expected <~a>, given: ~e"
+                            'type-name
+                            v)))))))))))]
+      [(_ predicate? constructor (arb? selector) correct-size type-name name)
+       (eq? #t (syntax-object->datum (syntax arb?)))
+       (syntax
+        (let ([predicate?-name predicate?]
+              [constructor-name constructor]
+              [selector-name selector])
+          (lambda params
+            (let ([procs (map (lambda (param) (coerce/select-contract name param)) params)])
+              (make-contract
+               (apply build-compound-type-name 'name (map proc/ctc->ctc params))
+               (lambda (pos neg src-info orig-str)
+                 (let ([p-apps (map (lambda (proc) (proc pos neg src-info orig-str)) procs)]
+                       [count (length params)])
+                   (lambda (v)
+                     (if (and (immutable? v)
+                              (predicate?-name v)
+                              (correct-size count v))
+                         (apply constructor-name 
+                                (let loop ([p-apps p-apps]
+                                           [i 0])
+                                  (cond
+                                    [(null? p-apps) null]
+                                    [else (let ([p-app (car p-apps)])
+                                            (cons (p-app (selector-name v i))
+                                                  (loop (cdr p-apps) (+ i 1))))])))
+                         (raise-contract-error
+                          src-info
+                          pos
+                          neg
+                          orig-str
+                          "expected <~a>, given: ~e"
+                          'type-name
+                          v))))))))))]))
+  
+  (define cons-immutable/c (*-immutable/c pair? cons-immutable (#f car cdr) immutable-cons cons-immutable/c))
+  (define box-immutable/c (*-immutable/c box? box-immutable (#f unbox) immutable-box box-immutable/c))
+  (define vector-immutable/c (*-immutable/c vector?
+                                            vector-immutable
+                                            (#t (lambda (v i) (vector-ref v i)))
+                                            (lambda (n v) (= n (vector-length v)))
+                                            immutable-vector
+                                            vector-immutable/c))
+       
+  (define (list/c . args)
+    (unless (andmap flat-contract/predicate? args)
+      (error 'list/c "expected flat contracts, got: ~a"
+             (let loop ([args args])
+               (cond
+                 [(null? args) ""]
+                 [(null? (cdr args)) (format "~e" (car args))]
+                 [else (string-append
+                        (format "~e " (car args))
+                        (loop (cdr args)))]))))
+    (let loop ([args args])
+      (cond
+	[(null? args) (flat-contract null?)]
+	[else (cons/c (car args) (loop (cdr args)))])))
+  
+  (define (list-immutable/c . args)
+    (unless (andmap (lambda (x) (or (contract? x)
+                                    (and (procedure? x)
+                                         (procedure-arity-includes? x 1))))
+                    args)
+      (error 'list/c "expected flat contracts or procedures of arity 1, got: ~a"
+             (let loop ([args args]) 
+               (cond
+                 [(null? args) ""]
+                 [(null? (cdr args)) (format "~e" (car args))]
+                 [else (string-append
+                        (format "~e " (car args))
+                        (loop (cdr args)))]))))
+    (let loop ([args args])
+      (cond
+	[(null? args) (flat-contract null?)]
+	[else (cons-immutable/c (car args) (loop (cdr args)))])))
+
+  (define (syntax/c c)
+    (unless (flat-contract/predicate? c)
+      (error 'syntax/c "expected argument of type <flat-contract> or procedure of arity 1, got ~e" c))
+    (build-flat-contract
+     (let ([pred (flat-contract-predicate c)])
+       (lambda (val)
+         (and (syntax? val)
+              (pred (syntax-e val)))))))
+  
+  (define promise/c
+    (lambda (ctc-in)
+      (let* ([ctc (coerce-contract promise/c ctc-in)]
+             [ctc-proc (contract-proc ctc)])
+        (make-contract
+         (build-compound-type-name 'promise/c ctc)
+         (lambda (pos neg src-info orig-str)
+           (let ([p-app (ctc-proc pos neg src-info orig-str)])
+             (lambda (val)
+               (unless (promise? val)
+                 (raise-contract-error
+                  src-info
+                  pos
+                  neg
+                  orig-str
+                  "expected <promise>, given: ~e"
+                  val))
+               (delay (p-app (force val))))))))))
+  
+  #|
+   as with copy-struct in struct.ss, this first begin0
+   expansion "declares" that struct/c is an expression.
+   It prevents further expansion until the internal definition
+   context is sorted out.
+  |#
+  (define-syntax (struct/c stx)
+    (syntax-case stx ()
+      [(_ . args) (syntax (begin0 (do-struct/c . args)))]))
+  
+  (define-syntax (do-struct/c stx)
+    (syntax-case stx ()
+      [(_ struct-name args ...)
+       (and (identifier? (syntax struct-name))
+            (syntax-local-value (syntax struct-name) (lambda () #f)))
+       (with-syntax ([(ctc-x ...) (generate-temporaries (syntax (args ...)))]
+                     [(ctc-proc-x ...) (generate-temporaries (syntax (args ...)))]
+                     [(ctc-app-x ...) (generate-temporaries (syntax (args ...)))]
+                     [(type-desc-id 
+                       constructor-id 
+                       predicate-id 
+                       (selector-id ...)
+                       (mutator-id ...)
+                       super-id)
+                      (syntax-local-value (syntax struct-name))])
+         (syntax
+          (let ([ctc-x (coerce-contract struct/c args)] ...)
+            
+            (unless predicate-id
+              (error 'struct/c "could not determine predicate for ~s" 'struct-name))
+            (unless (and selector-id ...)
+              (error 'struct/c "could not determine selectors for ~s" 'struct-name))
+            
+            (unless (flat-contract? ctc-x)
+              (error 'struct/c "expected flat contracts as arguments, got ~e" ctc-x))
+            ...
+            
+            (let ([ctc-proc-x (contract-proc ctc-x)] ...)
+              (make-contract
+               (build-compound-type-name 'struct/c 'struct-name ctc-x ...)
+               (lambda (pos neg src-info orig-str)
+                 (let ([ctc-app-x (ctc-proc-x pos neg src-info orig-str)] ...)
+                   (lambda (val)
+                     (unless (predicate-id val)
+                       (raise-contract-error
+                        src-info
+                        pos
+                        neg
+                        orig-str
+                        "expected <~a>, given: ~e"
+                        'struct-name
+                        val))
+                    (ctc-app-x (selector-id val)) ...
+                     val))))))))]
+      [(_ struct-name anything ...)
+       (raise-syntax-error 'struct/c "expected a struct identifier" stx (syntax struct-name))]))
+  
+  (define (flat-contract/predicate? pred)
+    (or (flat-contract? pred)
+        (and (procedure? pred)
+             (procedure-arity-includes? pred 1))))
+  
+  (define (subclass?/c %)
+    (unless (class? %)
+      (error 'subclass?/c "expected <class>, given: ~e" %))
+    (let ([name (object-name %)])
+      (flat-named-contract
+       `(subclass?/c ,(or name 'unknown%))
+       (lambda (x) (subclass? x %)))))
+
+  (define (implementation?/c <%>)
+    (unless (interface? <%>)
+      (error 'implementation?/c "expected <interface>, given: ~e" <%>))
+    (let ([name (object-name <%>)])
+      (flat-named-contract
+       `(implementation?/c ,(or name 'unknown<%>))
+       (lambda (x) (implementation? x <%>)))))
+
+  (define mixin-contract (class? . ->d . subclass?/c))
+  
+  (define (make-mixin-contract . %/<%>s)
+    ((and/c (flat-contract class?)
+            (apply and/c (map sub/impl?/c %/<%>s)))
+     . ->d .
+     subclass?/c))
+
+  (define (sub/impl?/c %/<%>)
+    (cond
+      [(interface? %/<%>) (implementation?/c %/<%>)]
+      [(class? %/<%>) (subclass?/c %/<%>)]
+      [else (error 'make-mixin-contract "unknown input ~e" %/<%>)])))
diff --git a/collects/mzlib/date.ss b/collects/mzlib/date.ss
new file mode 100644
index 0000000000..49cd322697
--- /dev/null
+++ b/collects/mzlib/date.ss
@@ -0,0 +1,390 @@
+
+(module date mzscheme
+
+  (require "list.ss")
+
+  (provide date->string
+	  date-display-format
+	  find-seconds
+	  
+	  date->julian/scalinger
+	  julian/scalinger->string)
+
+
+  ;; Support for Julian calendar added by Shriram;
+  ;; current version only works until 2099 CE Gregorian
+
+  #|
+
+  (define-primitive seconds->date (num -> structure:date))
+  (define-primitive current-seconds (-> num))
+  (define-primitive date-second (structure:date -> num))
+  (define-primitive date-minute (structure:date -> num))
+  (define-primitive date-hour (structure:date -> num))
+  (define-primitive date-day (structure:date -> num))
+  (define-primitive date-month (structure:date -> num))
+  (define-primitive date-year (structure:date -> num))
+  (define-primitive date-week-day (structure:date -> num))
+  (define-primitive date-year-day (structure:date -> num))
+  (define-primitive date-dst? (structure:date -> bool))
+  (define-primitive make-date (num num num num num num num num bool ->
+				   structure:date))
+  (define-primitive expr->string (a -> string))
+  (define-primitive foldl (case->
+			   ((a z -> z) z (listof a) -> z)
+			   ((a b z -> z) z (listof a) (listof b) -> z)
+			   ((a b c z -> z) z (listof a) (listof b) (listof c) -> z)
+			   (((arglistof x) ->* z) z (listof (arglistof x)) ->* z)))
+  (define-primitive foldr (case->
+			   ((a z -> z) z (listof a) -> z)
+			   ((a b z -> z) z (listof a) (listof b) -> z)
+			   ((a b c z -> z) z (listof a) (listof b) (listof c) -> z)
+			   (((arglistof x) ->* z) z (listof (arglistof x)) ->* z)))
+
+  |#
+
+  (define legal-formats
+    (list 'american 'chinese 'german 'indian 'irish 'julian 'iso-8601 'rfc2822))
+
+  (define date-display-format 
+    (make-parameter 'american
+		    (lambda (s)
+		      (unless (memq s legal-formats)
+			(raise-type-error 'date-display-format
+					  (format "symbol in ~a" legal-formats)
+					  s))
+		      s)))
+
+  (define month/number->string
+    (lambda (x)
+      (case x
+	[(12) "December"] [(1) "January"]  [(2) "February"]
+	[(3) "March"]     [(4) "April"]    [(5) "May"]
+	[(6) "June"]      [(7) "July"]     [(8) "August"]
+	[(9) "September"] [(10) "October"] [(11) "November"]
+	[else ""])))
+  
+  (define day/number->string
+    (lambda (x)
+      (case x
+	[(0) "Sunday"]
+	[(1) "Monday"]
+	[(2) "Tuesday"]
+	[(3) "Wednesday"]
+	[(4) "Thursday"]
+	[(5) "Friday"]
+	[(6) "Saturday"]
+	[else ""])))
+
+  (define date->string
+    (case-lambda 
+     [(date) (date->string date #f)]
+     [(date time?)
+      (let* ((add-zero (lambda (n) (if (< n 10)
+				       (string-append "0" (number->string n))
+				       (number->string n))))
+	     (year (number->string (date-year date)))
+	     (num-month (number->string (date-month date)))
+	     (week-day (day/number->string (date-week-day date)))
+	     (week-day-num (date-week-day date))
+	     (month (month/number->string (date-month date)))
+	     (day (number->string (date-day date)))
+	     (day-th (if (<= 11 (date-day date) 13)
+			 "th"
+			 (case (modulo (date-day date) 10)
+			   [(1) "st"]
+			   [(2) "nd"]
+			   [(3) "rd"]
+			   [(0 4 5 6 7 8 9) "th"])))
+	     (hour (date-hour date))
+	     (am-pm (if (>= hour 12) "pm" "am"))
+	     (hour24 (add-zero hour))
+	     (hour12 (number->string 
+		      (cond
+		       [(zero? hour) 12]
+		       [(> hour 12) (- hour 12)]
+		       [else hour])))
+	     (minute (add-zero (date-minute date)))
+	     (second (add-zero (date-second date))))
+	(let-values
+	    ([(day time)
+	      (case (date-display-format)
+		[(american) 
+		 (values (list week-day ", " month " " day day-th ", " year)
+			 (list " " hour12 ":" minute ":" second am-pm))]
+		[(chinese)
+		 (values
+		  (list year "/" num-month "/" day
+			" \u661F\u671F" (case (date-week-day date)
+				   [(0) "\u5929"]
+				   [(1) "\u4E00"]
+				   [(2) "\u4E8C"]
+				   [(3) "\u4e09"]
+				   [(4) "\u56DB"]
+				   [(5) "\u4E94"]
+				   [(6) "\u516D"]
+				   [else ""]))
+		  (list " " hour24 ":" minute ":" second))]
+		[(indian) 
+		 (values (list day "-" num-month "-" year)
+			 (list " " hour12 ":" minute ":" second am-pm))]
+		[(german) 
+		 (values (list day ". " 
+                                (case (date-month date)
+                                  [(1) "Januar"]
+                                  [(2) "Februar"]
+                                  [(3) "M\344rz"]
+                                  [(4) "April"]
+                                  [(5) "Mai"]
+                                  [(6) "Juni"]
+                                  [(7) "Juli"]
+                                  [(8) "August"]
+                                  [(9) "September"]
+                                  [(10) "Oktober"]
+                                  [(11) "November"]
+                                  [(12) "Dezember"]
+                                  [else ""])
+                                " " year)
+			 (list ", " hour24 "." minute))]
+		[(irish) 
+		 (values (list week-day ", " day day-th " " month " " year)
+			 (list ", " hour12 ":" minute am-pm))]
+		[(julian)
+		 (values (list (julian/scalinger->string
+				(date->julian/scalinger date)))
+			 (list ", " hour24 ":" minute ":" second))]
+		[(iso-8601)
+		 (values
+		  (list year "-" (add-zero (date-month date)) "-" (add-zero (date-day date)))
+		  (list " " hour24 ":" minute ":" second))]
+		[(rfc2822)
+		 (values
+		  (list (substring week-day 0 3) ", " day " " (substring month 0 3) " " year)
+		  (list* " " hour24 ":" minute ":" second " "
+			 (let* ([delta (date-time-zone-offset date)]
+				[hours (quotient delta 3600)]
+				[minutes (modulo (quotient delta 60) 60)])
+			   (list
+			    (if (negative? delta) "-" "")
+			    (add-zero (abs hours))
+			    (add-zero minutes)))))]
+		[else (error 'date->string "unknown date-display-format: ~s"
+			     (date-display-format))])])
+	  (apply string-append (if time?
+				   (append day time)
+				   day))))]))
+  
+  (define leap-year?
+    (lambda (year)
+      (or (= 0 (modulo year 400))
+	  (and (= 0 (modulo year 4))
+	       (not (= 0 (modulo year 100)))))))
+
+  ;; it's not clear what months mean in this context -- use days
+  (define-struct date-offset (second minute hour day year))
+
+  (define date-
+    (lambda (date1 date2)
+      (let* ((second (- (date-second date1) (date-second date2)))
+	     (minute (+ (- (date-minute date1) (date-minute date2))
+			(if (< second 0) -1 0)))
+	     (hour (+ (- (date-hour date1) (date-hour date2))
+		      (if (< minute 0) -1 0)
+		      (cond [(equal? (date-dst? date1) (date-dst? date2)) 0]
+			    [(date-dst? date1) -1]
+			    [(date-dst? date2) 1])))
+	     (day (+ (- (date-year-day date1) (date-year-day date2))
+		     (if (< hour 0) -1 0)))
+	     (year (+ (- (date-year date1) (date-year date2))
+		      (if (< day 0) -1 0)))
+	     (fixup (lambda (s x) (if (< s 0) (+ s x) s))))
+	(make-date-offset (fixup second 60)
+			  (fixup minute 60)
+			  (fixup hour 24)
+			  (fixup day (if (leap-year? (date-year date1)) 366 365))
+			  year))))
+
+
+  (define date-offset->string
+    (let ((first car)
+	  (second cadr))
+      (case-lambda 
+       [(date) (date-offset->string date #f)]
+       [(date seconds?)
+	(let* ((fields (list (list (date-offset-year date) "year")
+			     (list (date-offset-day date) "day")
+			     (list (date-offset-hour date) "hour")
+			     (list (date-offset-minute date) "minute")
+			     (list (if seconds? (date-offset-second date) 0) "second")))
+	       (non-zero-fields (foldl (lambda (x l)
+					 (if (= 0 (first x))
+					     l
+					     (cons x l)))
+				       null
+				       fields))
+	       (one-entry (lambda (b)
+			    (string-append
+			     (number->string (first b))
+			     " "
+			     (second b)
+			     (if (= 1 (first b)) "" "s")))))
+	  (cond
+	   [(null? non-zero-fields) ""]
+	   [(null? (cdr non-zero-fields)) (one-entry (car non-zero-fields))]
+	   [else (foldl (lambda (b string)
+			  (cond
+			   [(= 0 (first b)) string]
+			   [(string=? string "")
+			    (string-append "and "
+					   (one-entry b)
+					   string)]
+			   [else (string-append (one-entry b) ", " string)]))
+			""
+			non-zero-fields)]))])))
+
+  (define days-per-month
+    (lambda (year month)
+      (cond
+       [(and (= month 2) (leap-year? year)) 29]
+       [(= month 2) 28]
+       [(<= month 7) (+ 30 (modulo month 2))]
+       [else (+ 30 (- 1 (modulo month 2)))])))
+
+  (define find-extreme-date-seconds
+    (lambda (start offset)
+      (let/ec found
+	(letrec ([find-between
+		  (lambda (lo hi)
+		    (let ([mid (floor (/ (+ lo hi) 2))])
+		      (if (or (and (positive? offset) (= lo mid))
+			      (and (negative? offset) (= hi mid)))
+			  (found lo)
+			  (let ([mid-ok?
+				 (with-handlers ([exn:fail? (lambda (exn) #f)])
+				   (seconds->date mid)
+				   #t)])
+			    (if mid-ok?
+				(find-between mid hi)
+				(find-between lo mid))))))])
+	  (let loop ([lo start][offset offset])
+	    (let ([hi (+ lo offset)])
+	      (with-handlers ([exn:fail? 
+			       (lambda (exn) 
+					; failed - must be between lo & hi
+				 (find-between lo hi))])
+		(seconds->date hi))
+					; succeeded; double offset again
+	      (loop hi (* 2 offset))))))))
+
+  (define get-min-seconds
+    (let ([d (delay (find-extreme-date-seconds (current-seconds) -1))])
+      (lambda ()
+	(force d))))
+  (define get-max-seconds
+    (let ([d (delay (find-extreme-date-seconds (current-seconds) 1))])
+      (lambda ()
+	(force d))))
+
+  (define find-seconds
+    (lambda (sec min hour day month year)
+      (let ([signal-error
+	     (lambda (msg)
+	       (error 'find-secs (string-append 
+				  msg 
+				  " (inputs: ~a ~a ~a ~a ~a ~a)")
+		      sec min hour day month year))])
+	(let loop ([below-secs (get-min-seconds)]
+		   [secs (floor (/ (+ (get-min-seconds) (get-max-seconds)) 2))]
+		   [above-secs (get-max-seconds)])
+	  (let* ([date (seconds->date secs)]
+		 [compare
+		  (let loop ([inputs (list year month day 
+					   hour min sec)]
+			     [tests (list (date-year date)
+					  (date-month date)
+					  (date-day date)
+					  (date-hour date)
+					  (date-minute date)
+					  (date-second date))])
+		    (cond
+		     [(null? inputs) 'equal]
+		     [else (let ([input (car inputs)]
+				 [test (car tests)])
+			     (if (= input test)
+				 (loop (cdr inputs) (cdr tests))
+				 (if (<= input test)
+				     'input-smaller
+				     'test-smaller)))]))])
+					; (printf "~a ~a ~a~n" compare secs (date->string date))
+	    (cond
+	     [(eq? compare 'equal) secs]
+	     [(or (= secs below-secs) (= secs above-secs))
+	      (signal-error "non-existent date")]
+	     [(eq? compare 'input-smaller) 
+	      (loop below-secs (floor (/ (+ secs below-secs) 2)) secs)]
+	     [(eq? compare 'test-smaller) 
+	      (loop secs (floor (/ (+ above-secs secs) 2)) above-secs)]))))))
+
+  ;; date->julian/scalinger :
+  ;; date -> number [julian-day]
+
+  ;; Note: This code is correct until 2099 CE Gregorian
+
+  (define (date->julian/scalinger date)
+    (let ((day (date-day date))
+	  (month (date-month date))
+	  (year (date-year date)))
+      (let ((year (+ 4712 year)))
+	(let ((year (if (< month 3) (sub1 year) year)))
+	  (let ((cycle-number (quotient year 4))
+		(cycle-position (remainder year 4)))
+	    (let ((base-day (+ (* 1461 cycle-number) (* 365 cycle-position))))
+	      (let ((month-day-number (case month
+					((3) 0)
+					((4) 31)
+					((5) 61)
+					((6) 92)
+					((7) 122)
+					((8) 153)
+					((9) 184)
+					((10) 214)
+					((11) 245)
+					((12) 275)
+					((1) 306)
+					((2) 337))))
+		(let ((total-days (+ base-day month-day-number day)))
+		  (let ((total-days/march-adjustment (+ total-days 59)))
+		    (let ((gregorian-adjustment (cond
+						 ((< year 1700) 11)
+						 ((< year 1800) 12)
+						 (else 13))))
+		      (let ((final-date (- total-days/march-adjustment
+					   gregorian-adjustment)))
+			final-date)))))))))))
+
+  ;; julian/scalinger->string :
+  ;; number [julian-day] -> string [julian-day-format]
+
+  (define (julian/scalinger->string julian-day)
+    (apply string-append
+	   (cons "JD "
+		 (reverse
+		  (let loop ((reversed-digits (map number->string
+						   (let loop ((jd julian-day))
+						     (if (zero? jd) null
+							 (cons (remainder jd 10)
+							       (loop (quotient jd 10))))))))
+		    (cond
+		     ((or (null? reversed-digits)
+			  (null? (cdr reversed-digits))
+			  (null? (cdr (cdr reversed-digits))))
+		      (list (apply string-append reversed-digits)))
+		     (else (cons (apply string-append
+					(list " "
+					      (caddr reversed-digits)
+					      (cadr reversed-digits)
+					      (car reversed-digits)))
+				 (loop (cdr (cdr (cdr reversed-digits))))))))))))
+
+  )
+
diff --git a/collects/mzlib/deflate.ss b/collects/mzlib/deflate.ss
new file mode 100644
index 0000000000..ffdeb27e14
--- /dev/null
+++ b/collects/mzlib/deflate.ss
@@ -0,0 +1,2298 @@
+#|
+/* deflate.c -- compress data using the deflation algorithm
+ * Copyright (C) 1992-1993 Jean-loup Gailly
+ * This is free software; you can redistribute it and/or modify it under the
+ * terms of the GNU General Public License, see the file COPYING.
+ */
+|#
+; Taken from the gzip source distribution
+; Translated directly from C (obviously) by Matthew, July 2000
+
+(module deflate mzscheme
+
+  (provide deflate 
+	  gzip-through-ports
+	  gzip)
+
+  (require "unit.ss")
+
+  (define-syntax INSERT_STRING 
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ s match_head UPDATE_HASH window-vec head-vec prev-vec ins_h)
+	 (syntax
+	  (begin
+	    (UPDATE_HASH (vector-ref window-vec (+ s MIN_MATCH-1)))
+	    (let ([mh (vector-ref head-vec (+ ins_h head-vec-delta))])
+	      (set! match_head mh)
+	      (vector-set! prev-vec (bitwise-and s  WMASK) mh))
+	    (vector-set! head-vec (+ head-vec-delta ins_h) s)))])))
+
+  (define-syntax pqremove 
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ tree top heap heap_len SMALLEST)
+	 (syntax
+	  (begin
+	    (set! top (vector-ref heap SMALLEST))
+	    (vector-set! heap SMALLEST (vector-ref heap heap_len))
+	    (set! heap_len (sub1 heap_len))
+	    (pqdownheap tree SMALLEST)))])))
+
+  (define-syntax DEBUG
+    (lambda (stx)
+      (syntax (void))))
+
+  (define-syntax Assert
+    (lambda (stx)
+      (syntax (void))))
+
+  (define (for start < end next proc)
+    (let loop ([n start])
+      (when (< n end)
+	(proc n)
+	(loop (next n)))))
+
+  (define-struct gzvector (vector offset))
+  (define (gzvector-ref v o)
+    (vector-ref (gzvector-vector v)
+		(+ (gzvector-offset v) o)))
+  (define (gzvector-set! v o x)
+    (vector-set! (gzvector-vector v)
+		 (+ (gzvector-offset v) o)
+		 x))
+  (define (gzvector+ v o)
+    (make-gzvector (gzvector-vector v)
+		   (+ (gzvector-offset v) o)))
+
+  (define (gzvector<vec v1 v2)
+    (< (gzvector-offset v1) (gzvector-offset v2)))
+  (define (gzvector-vec v1 v2)
+    (- (gzvector-offset v1) (gzvector-offset v2)))
+
+  (define (gzvector-copy v1 v2 n)
+    (for 0 < n add1
+	 (lambda (m)
+	   (gzvector-set! v1 m (gzvector-ref v2 m)))))
+  
+  (define (gzvector-zero! v n)
+    (for 0 < n add1
+	 (lambda (m)
+	   (gzvector-set! v m 0))))
+
+  (define (Trace stderr str . args)
+    (apply fprintf (current-error-port) str args))
+  (define Tracevv Trace)
+  (define Tracev Trace)
+  (define (Tracec test . args)
+    (when test
+      (apply Trace args)))
+  (define Tracecv Tracec)
+  (define stderr 'sdterr)
+  
+#|
+/*
+ *  PURPOSE
+ *
+ *      Identify new text as repetitions of old text within a fixed-
+ *      length sliding window trailing behind the new text.
+ *
+ *  DISCUSSION
+ *
+ *      The "deflation" process depends on being able to identify portions
+ *      of the input text which are identical to earlier input (within a
+ *      sliding window trailing behind the input currently being processed).
+ *
+ *      The most straightforward technique turns out to be the fastest for
+ *      most input files: try all possible matches and select the longest.
+ *      The key feature of this algorithm is that insertions into the string
+ *      dictionary are very simple and thus fast, and deletions are avoided
+ *      completely. Insertions are performed at each input character, whereas
+ *      string matches are performed only when the previous match ends. So it
+ *      is preferable to spend more time in matches to allow very fast string
+ *      insertions and avoid deletions. The matching algorithm for small
+ *      strings is inspired from that of Rabin & Karp. A brute force approach
+ *      is used to find longer strings when a small match has been found.
+ *      A similar algorithm is used in comic (by Jan-Mark Wams) and freeze
+ *      (by Leonid Broukhis).
+ *         A previous version of this file used a more sophisticated algorithm
+ *      (by Fiala and Greene) which is guaranteed to run in linear amortized
+ *      time, but has a larger average cost, uses more memory and is patented.
+ *      However the F&G algorithm may be faster for some highly redundant
+ *      files if the parameter max_chain_length (described below) is too large.
+ *
+ *  ACKNOWLEDGEMENTS
+ *
+ *      The idea of lazy evaluation of matches is due to Jan-Mark Wams, and
+ *      I found it in 'freeze' written by Leonid Broukhis.
+ *      Thanks to many info-zippers for bug reports and testing.
+ *
+ *  REFERENCES
+ *
+ *      APPNOTE.TXT documentation file in PKZIP 1.93a distribution.
+ *
+ *      A description of the Rabin and Karp algorithm is given in the book
+ *         "Algorithms" by R. Sedgewick, Addison-Wesley, p252.
+ *
+ *      Fiala,E.R., and Greene,D.H.
+ *         Data Compression with Finite Windows, Comm.ACM, 32,4 (1989) 490-595
+ *
+ *  INTERFACE
+ *
+ *      void lm_init (int pack_level, ush *flags)
+ *          Initialize the "longest match" routines for a new file
+ *
+ *      ulg deflate (void)
+ *          Processes a new input file and return its compressed length. Sets
+ *          the compressed length, crc, deflate flags and internal file
+ *          attributes.
+ */
+
+|#
+
+ (define LEVEL 6)
+
+ (define OUTBUFSIZ  16384);;   /* output buffer size */
+ (define INBUFSIZ  #x8000);;   /* input buffer size */
+ (define INBUF_EXTRA  64)
+
+ (define WSIZE #x8000) ;; /* window size--must be a power of two, and */
+ ;;                       /*  at least 32K for zip's deflate method */
+
+ (define MIN_MATCH  3)
+ (define MIN_MATCH-1 (- MIN_MATCH 1))
+ (define MAX_MATCH  258)
+ ;; /* The minimum and maximum match lengths */
+
+ (define MIN_LOOKAHEAD (+ MAX_MATCH MIN_MATCH 1))
+ ;; /* Minimum amount of lookahead, except at the end of the input file.
+ ;;  * See for comments about the MIN_MATCH+1.
+ ;; */
+
+ (define MAX_DIST  (- WSIZE MIN_LOOKAHEAD))
+ ;; /* In order to simplify the code, particularly on 16 bit machines, match
+ ;;  * distances are limited to MAX_DIST instead of WSIZE.
+ ;;  */
+
+ (define HASH_BITS  15)
+ (define BITS 16)
+
+ (define << arithmetic-shift)
+ (define (>> x y) (arithmetic-shift x (- y)))
+ (define EOF-const -1)
+
+ ;; /* To save space (see unlzw.c), we overlay prev+head with tab_prefix and
+ ;;  * window with tab_suffix. Check that we can do this:
+ ;;  */
+ (Assert
+  (when (> (<< WSIZE 1) (<< 1 BITS))
+    (error "cannot overlay window with tab_suffix and prev with tab_prefix0")))
+ (Assert
+  (when (> HASH_BITS (- BITS 1))
+    (error "cannot overlay head with tab_prefix1")))
+
+ (define HASH_SIZE (<< 1 HASH_BITS))
+ (define HASH_MASK (- HASH_SIZE 1))
+ (define WMASK     (- WSIZE 1))
+ ;; /* HASH_SIZE and WSIZE must be powers of two */
+
+ (define NIL 0)
+ ;; /* Tail of hash chains */
+
+ (define FAST 4)
+ (define SLOW 2)
+ ;; /* speed options for the general purpose bit flag */
+
+ (define TOO_FAR 4096)
+ ;; /* Matches of length 3 are discarded if their distance exceeds TOO_FAR */
+
+ (define bits_sent 0)
+ (define (isgraph c) #t)
+
+(define head-vec-delta WSIZE)
+
+ ;; The gzip code wasn't defined for threads (or even to be
+ ;;  multiply invoked), so we pack it up into a unit to
+ ;;  invoke each time we need it.
+ 
+ (define code
+   (unit 
+     (import)
+     (export)
+      
+
+;; /* ===========================================================================
+;;  * Local data used by the "longest match" routines.
+;;  */
+
+(define real-table (make-vector (<< 1 BITS) 0))
+
+(define prev-vec real-table)
+(define prev (make-gzvector prev-vec 0))
+(define head-vec real-table)
+(define head (make-gzvector head-vec head-vec-delta))
+
+;;  /* DECLARE(uch, window, 2L*WSIZE); */
+;;  /* Sliding window. Input bytes are read into the second half of the window,
+;;   * and move to the first half later to keep a dictionary of at least WSIZE
+;;   * bytes. With this organization, matches are limited to a distance of
+;;   * WSIZE-MAX_MATCH bytes, but this ensures that IO is always
+;;   * performed with a length multiple of the block size. Also, it limits
+;;   * the window size to 64K, which is quite useful on MSDOS.
+;;   * To do: limit the window size to WSIZE+BSZ if SMALL_MEM (the code would
+;;   * be less efficient).
+;;   */
+
+;;  /* DECLARE(Pos, prev, WSIZE); */
+;;  /* Link to older string with same hash index. To limit the size of this
+;;   * array to 64K, this link is maintained only for the last 32K strings.
+;;   * An index in this array is thus a window index modulo 32K.
+;;   */
+
+;;  /* DECLARE(Pos, head, 1<<HASH_BITS); */
+;;  /* Heads of the hash chains or NIL. */
+
+(define window_size (* 2 WSIZE))
+;;  /* window size, 2*WSIZE 
+;;   */
+(define window-vec (make-vector window_size 0))
+(define window (make-gzvector window-vec 0))
+
+(define block_start 0)
+;;  /* window position at the beginning of the current output block. Gets
+;;   * negative when the window is moved backwards.
+;;   */
+
+(define ins_h 0) ;; /* hash index of string to be inserted */
+
+(define H_SHIFT  (quotient (+ HASH_BITS MIN_MATCH-1) MIN_MATCH))
+;; /* Number of bits by which ins_h and del_h must be shifted at each
+;;  * input step. It must be such that after MIN_MATCH steps, the oldest
+;;  * byte no longer takes part in the hash key, that is:
+;;  *   H_SHIFT * MIN_MATCH >= HASH_BITS
+;;  */
+
+(define prev_length 0)
+;; /* Length of the best match at previous step. Matches not greater than this
+;;  * are discarded. This is used in the lazy match evaluation.
+;; */
+
+(define strstart 0)    ;; /* start of string to insert */
+(define match_start 0) ;; /* start of matching string */
+(define eofile #f)     ;; /* flag set at end of input file */
+(define lookahead 0)   ;; /* number of valid bytes ahead in window */
+
+(define max_chain_length 0)
+;; /* To speed up deflation, hash chains are never searched beyond this length.
+;;  * A higher limit improves compression ratio but degrades the speed.
+;;  */
+
+(define max_lazy_match 0)
+;; /* Attempt to find a better match only when the current match is strictly
+;;  * smaller than this value. This mechanism is used only for compression
+;;  * levels >= 4.
+;;  */
+
+(define (max_insert_length)  max_lazy_match)
+;; /* Insert new strings in the hash table only if the match length
+;;  * is not greater than this length. This saves time but degrades compression.
+;;  * max_insert_length is used only for compression levels <= 3.
+;;  */
+
+(define good_match 0)
+;; /* Use a faster search when the previous match is longer than this */
+
+
+;; /* Values for max_lazy_match, good_match and max_chain_length, depending on
+;;  * the desired pack level (0..9). The values given below have been tuned to
+;;  * exclude worst case performance for pathological files. Better values may be
+;;  * found for specific files.
+;;  */
+
+(define-struct config
+  (good_length ;; /* reduce lazy search above this match length */
+   max_lazy    ;; /* do not perform lazy search above this match length */
+   nice_length ;; /* quit search above this match length */
+   max_chain))
+
+(define nice_match MAX_MATCH)
+;; /* Stop searching when current match exceeds this */
+
+(define configuration_table
+  (vector
+   ;; /* good lazy nice chain */
+   (make-config 0 0 0 0)           ;; /* 0 - store only */
+   (make-config 4 4 8 4)           ;; /* 1 - maximum speed, no lazy matches */
+   (make-config 4 5 16 8)          ;; /* 2 */
+   (make-config 4 6 32 32)         ;; /* 3 */
+
+   (make-config 4 4 16 16)         ;; /* 4 - lazy matches */
+   (make-config 8 16 32 32)        ;; /* 5 */
+   (make-config 8 16 128 128)      ;; /* 6 */
+   (make-config 8 32 128 256)      ;; /* 7 */
+   (make-config 32 128 258 1024)   ;; /* 8 */
+   (make-config 32 258 258 4096))) ;; /* 9 - maximum compression */
+
+;; /* Note: the deflate() code requires max_lazy >= MIN_MATCH and max_chain >= 4
+;;  * For deflate_fast() (levels <= 3) good is ignored and lazy has a different
+;; * meaning.
+;; */
+
+;; /* ===========================================================================
+;;  * Update a hash value with the given input byte
+;;  * IN  assertion: all calls to to UPDATE_HASH are made with consecutive
+;;  *    input characters, so that a running hash key can be computed from the
+;;  *    previous key instead of complete recalculation each time.
+;;  */
+(define (UPDATE_HASH c)
+  (set!  ins_h (bitwise-and (bitwise-xor (<< ins_h H_SHIFT) c) HASH_MASK)))
+
+;; /* ===========================================================================
+;;  * Insert string s in the dictionary and set match_head to the previous head
+;;  * of the hash chain (the most recent string with same hash key). Return
+;;  * the previous length of the hash chain.
+;;  * IN  assertion: all calls to to INSERT_STRING are made with consecutive
+;;  *    input characters and the first MIN_MATCH bytes of s are valid
+;;  *    (except for the last MIN_MATCH-1 bytes of the input file).
+;;  */
+;; (define-macro INSERT_STRING <see above>)
+
+;; /* ===========================================================================
+;;  * Initialize the "longest match" routines for a new file
+;; */
+(define (lm_init pack_level)
+  ;; int pack_level; /* 0: store, 1: best speed, 9: best compression */
+
+  (when (or (< pack_level 1)
+	    (> pack_level 9))
+    (error "bad pack level"))
+
+  ;; /* Initialize the hash table. */
+  (gzvector-zero! head HASH_SIZE)
+
+  ;; /* prev will be initialized on the fly */
+
+  ;; /* Set the default configuration parameters:
+  ;; */
+  (set! max_lazy_match (config-max_lazy (vector-ref configuration_table pack_level)))
+  (set! good_match (config-good_length (vector-ref configuration_table pack_level)))
+  (set! nice_match (config-nice_length (vector-ref configuration_table pack_level)))
+  (set! max_chain_length (config-max_chain (vector-ref configuration_table pack_level)))
+  
+  (let ([flag (cond
+	       [(= pack_level 1) FAST]
+	       [(= pack_level 9) SLOW]
+	       [else 0])])
+    ;; /* ??? reduce max_chain_length for binary files */
+
+    (set! strstart 0)
+    (set! block_start 0)
+
+    (set! lookahead (read_buf 0 (* 2 WSIZE)))
+
+    (if (or (= lookahead 0) (= lookahead EOF-const))
+	(begin
+	  (set! eofile #t)
+	  (set! lookahead 0))
+	(begin
+	  (set! eofile #f)
+	  ;; /* Make sure that we always have enough lookahead. This is important
+	  ;;  * if input comes from a device such as a tty.
+	  ;;  */
+	  (let loop ()
+	    (when (and (< lookahead MIN_LOOKAHEAD)
+		       (not eofile))
+	      (fill_window)))
+
+	  (set! ins_h 0)
+	  (for 0 < MIN_MATCH-1 add1
+	       (lambda (j) (UPDATE_HASH (vector-ref window-vec j))))
+	  (DEBUG (Trace stderr "hash init: ~a~n" ins_h))
+	  ;; /* If lookahead < MIN_MATCH, ins_h is garbage, but this is
+	  ;;  * not important since only literal bytes will be emitted.
+	  ;;  */
+	  ))
+
+    flag))
+
+;; /* ===========================================================================
+;;  * Set match_start to the longest match starting at the given string and
+;;  * return its length. Matches shorter or equal to prev_length are discarded,
+;;  * in which case the result is equal to prev_length and match_start is
+;;  * garbage.
+;;  * IN assertions: cur_match is the head of the hash chain for the current
+;;  *   string (strstart) and its distance is <= MAX_DIST, and prev_length >= 1
+;;  */
+(define (longest_match cur_match)
+  ;; IPos cur_match; /* current match */
+
+  (define chain_length max_chain_length)   ;;   /* max hash chain length */
+  (define scanpos strstart) ;;   /* current string */
+  (define matchpos 0) ;; /* matched string */
+  (define len 0) ;; /* length of current match */
+  (define best_len prev_length) ;; /* best match length so far */
+  (define limit (if (> strstart MAX_DIST)
+		    (- strstart MAX_DIST)
+		    NIL))
+  ;; /* Stop when cur_match becomes <= limit. To simplify the code,
+  ;;  * we prevent matches with the string of window index 0.
+  ;;  */
+
+  ;; /* The code is optimized for HASH_BITS >= 8 and MAX_MATCH-2 multiple of 16.
+  ;;  * It is easy to get rid of this optimization if necessary.
+  ;;  */
+  ;; #if HASH_BITS < 8 || MAX_MATCH != 258
+  ;;   error: Code too clever
+  ;; #endif
+
+  (define strendpos (+ strstart MAX_MATCH))
+  (define scan_end1 (vector-ref window-vec (+ scanpos best_len -1)))
+  (define scan_end (vector-ref window-vec (+ scanpos best_len)))
+
+  ;; /* Do not waste too much time if we already have a good match: */
+  (when (>= prev_length good_match)
+    (set! chain_length (>> chain_length 2)))
+      
+  (Assert
+   (unless (<= strstart (- window_size MIN_LOOKAHEAD))
+     (error "insufficient lookahead")))
+
+  (let/ec break
+    (define (continue loop)
+      (set! cur_match (vector-ref prev-vec (bitwise-and cur_match WMASK)))
+      (when (and (> cur_match limit)
+		 (begin
+		   (set! chain_length (sub1 chain_length))
+		   (positive? chain_length)))
+	(loop)))
+    (define (*++scan)
+      (set! scanpos (add1 scanpos))
+      (vector-ref window-vec scanpos))
+    (define (*++match)
+      (set! matchpos (add1 matchpos))
+      (vector-ref window-vec matchpos))
+
+    (let loop ()
+      (Assert
+       (unless (< cur_match strstart)
+	 (error "no future")))
+
+      (set! matchpos cur_match)
+
+      ;; /* Skip to next match if the match length cannot increase
+      ;;  * or if the match length is less than 2:
+      ;;  */
+
+      (if (or (not (eq? (vector-ref window-vec (+ matchpos best_len)) scan_end))
+	      (not (eq? (vector-ref window-vec (+ matchpos best_len -1)) scan_end1))
+	      (not (eq? (vector-ref window-vec matchpos) (vector-ref window-vec scanpos)))
+	      (not (eq? (begin (set! matchpos (add1 matchpos))
+			     (vector-ref window-vec matchpos))
+		      (vector-ref window-vec (add1 scanpos)))))
+	  (continue loop)
+
+	  (begin
+	    ;; /* The check at best_len-1 can be removed because it will be made
+	    ;;  * again later. (This heuristic is not always a win.)
+	    ;;  * It is not necessary to compare scan[2] and match[2] since they
+	    ;;  * are always equal when the other bytes match, given that
+	    ;;  * the hash keys are equal and that HASH_BITS >= 8.
+	    ;;  */
+	    (set! scanpos (+ scanpos 2))
+	    (set! matchpos (+ matchpos 1))
+
+	    ;; /* We check for insufficient lookahead only every 8th comparison;
+	    ;; * the 256th check will be made at strstart+258.
+	    ;; */
+	    (let loop2 ()
+	      (when (and (eq? (*++scan) (*++match)) (eq? (*++scan) (*++match))
+			 (eq? (*++scan) (*++match)) (eq? (*++scan) (*++match))
+			 (eq? (*++scan) (*++match)) (eq? (*++scan) (*++match))
+			 (eq? (*++scan) (*++match)) (eq? (*++scan) (*++match))
+			 (< scanpos strendpos))
+		(loop2)))
+	    
+	    (set! len (- MAX_MATCH (- strendpos scanpos)))
+	    (set! scanpos (+ strendpos (- MAX_MATCH)))
+	    (DEBUG (Trace stderr "Match: ~a~n" len))
+
+	    (when (> len best_len)
+	      (set! match_start cur_match)
+	      (set! best_len len)
+	      (when (>= len nice_match)
+		(break))
+
+	      (set! scan_end1 (vector-ref window-vec (+ scanpos best_len -1)))
+	      (set! scan_end (vector-ref window-vec (+ scanpos best_len))))
+
+	    (continue loop)))))
+
+  best_len)
+
+;; /* ===========================================================================
+;;  * Check that the match at match_start is indeed a match.
+;;  */
+;;
+(define (check_match start match length)
+  #t)
+
+;; /* ===========================================================================
+;;  * Fill the window when the lookahead becomes insufficient.
+;;  * Updates strstart and lookahead, and sets eofile if end of input file.
+;;  * IN assertion: lookahead < MIN_LOOKAHEAD && strstart + lookahead > 0
+;;  * OUT assertions: at least one byte has been read, or eofile is set;
+;;  *    file reads are performed for at least two bytes (required for the
+;;  *    translate_eol option).
+;;  */
+(define (fill_window)
+  (define more (- window_size lookahead strstart))
+  ;; /* Amount of free space at the end of the window. */
+
+  ;; /* If the window is almost full and there is insufficient lookahead,
+  ;;  * move the upper half to the lower one to make room in the upper half.
+  ;;  */
+  (when (>= strstart (+ WSIZE MAX_DIST))
+    (gzvector-copy window (gzvector+ window WSIZE) WSIZE)
+    (set! match_start (- match_start WSIZE))
+    (set! strstart (- strstart WSIZE)) ;; /* we now have strstart >= MAX_DIST: */
+
+    (set! block_start (- block_start WSIZE))
+
+    (for 0 < HASH_SIZE add1
+	 (lambda (n)
+	   (let ([m (vector-ref head-vec (+ n head-vec-delta))])
+	     (vector-set! head-vec (+ n head-vec-delta)
+			  (if (>= m WSIZE)
+			      (- m WSIZE)
+			      NIL)))))
+
+    (for 0 < WSIZE add1
+	 (lambda (n)
+	   (let ([m (vector-ref prev-vec n)])
+	     (vector-set! prev-vec n
+			  (if (>= m WSIZE)
+			      (- m WSIZE)
+			      NIL)))
+	   ;; /* If n is not on any hash chain, prev[n] is garbage but
+	   ;;  * its value will never be used.
+	   ;;  */
+	   ))
+
+    (set! more (+ more WSIZE)))
+
+  (when (not eofile)
+    (let ([n (read_buf (+ strstart lookahead) more)])
+      (if (or (= n 0) (= n EOF-const))
+	  (set! eofile #t)
+	  (set! lookahead (+ lookahead n))))))
+
+;; /* ===========================================================================
+;;  * Flush the current block, with given end-of-file flag.
+;;  * IN assertion: strstart is set to the end of the current match.
+;;  */
+(define (FLUSH-BLOCK eof)
+  (flush_block (if (>= block_start 0)
+		   (gzvector+ window block_start)
+		   null)
+	       (- strstart block_start) 
+	       eof))
+
+;; /* ===========================================================================
+;;  * Same as above, but achieves better compression. We use a lazy
+;;  * evaluation for matches: a match is finally adopted only if there is
+;;  * no better match at the next window position.
+;;  */
+(define (do-deflate)
+  (define  hash_head 0) ;; /* head of hash chain */
+  (define prev_match 0) ;; /* previous match */
+  (define flush #f) ;; /* set if current block must be flushed */
+  (define match_available #f) ;; /* set if previous match exists */
+  (define match_length MIN_MATCH-1) ;; /* length of best match */
+
+  ;; /* Process the input block. */
+  (let dloop ()
+    (when (not (zero? lookahead))
+      (DEBUG (Trace stderr
+		    "prep ~a ~a ~a ~a ~a ~a ~a ~a ~a ~a~n" hash_head prev_length match_length max_lazy_match strstart
+		    ins_h (+ strstart MIN_MATCH-1) (vector-ref window-vec (+ strstart MIN_MATCH-1))
+		    H_SHIFT HASH_MASK))
+
+      ;; /* Insert the string window[strstart .. strstart+2] in the
+      ;;  * dictionary, and set hash_head to the head of the hash chain:
+      ;;  */
+      (INSERT_STRING strstart hash_head UPDATE_HASH window-vec head-vec prev-vec ins_h)
+
+      (DEBUG (Trace stderr
+		    "inh ~a ~a ~a ~a ~a ~a ~a~n" hash_head prev_length match_length max_lazy_match strstart
+		    ins_h (vector-ref window-vec (+ strstart MIN_MATCH-1))))
+
+      ;; /* Find the longest match, discarding those <= prev_length.
+      ;;  */
+      (set! prev_length match_length)
+      (set! prev_match match_start)
+      (set! match_length MIN_MATCH-1)
+
+      (when (and (not (= hash_head NIL))
+		 (< prev_length max_lazy_match)
+		 (<= (- strstart hash_head) MAX_DIST))
+	;; /* To simplify the code, we prevent matches with the string
+	;;  * of window index 0 (in particular we have to avoid a match
+	;;  * of the string with itself at the start of the input file).
+	;;  */
+	(set! match_length (longest_match hash_head))
+	(DEBUG (Trace stderr "blip ~a~n" match_length))
+	;; /* longest_match() sets match_start */
+	(when (> match_length lookahead)
+	  (set! match_length lookahead))
+
+	;; /* Ignore a length 3 match if it is too distant: */
+	(when (and (= match_length MIN_MATCH)
+		   (> (- strstart match_start) TOO_FAR))
+	  ;; /* If prev_match is also MIN_MATCH, match_start is garbage
+	  ;;  * but we will ignore the current match anyway.
+	  ;;  */
+	  (set! match_length (sub1 match_length))))
+
+      ;; /* If there was a match at the previous step and the current
+      ;;  * match is not better, output the previous match:
+      ;;  */
+      (cond
+       [(and (>= prev_length MIN_MATCH)
+	     (<= match_length prev_length))
+	(DEBUG (Trace stderr "x1~n"))
+
+	(check_match (- strstart 1) prev_match prev_length)
+
+	(set! flush (ct_tally (- strstart 1 prev_match)
+			      (- prev_length MIN_MATCH)))
+
+	;; /* Insert in hash table all strings up to the end of the match.
+	;;  * strstart-1 and strstart are already inserted.
+	;;  */
+	(set! lookahead (- lookahead (- prev_length 1)))
+	(set! prev_length (- prev_length 2))
+	(let loop ()
+	  (set! strstart (add1 strstart))
+	  (INSERT_STRING strstart hash_head UPDATE_HASH window-vec head-vec prev-vec ins_h)
+	  (DEBUG (Trace stderr
+			"inhx ~a ~a ~a ~a ~a ~a~n" hash_head prev_length max_lazy_match strstart
+			ins_h (vector-ref window-vec (+ strstart MIN_MATCH -1))))
+	  ;; /* strstart never exceeds WSIZE-MAX_MATCH, so there are
+	  ;;  * always MIN_MATCH bytes ahead. If lookahead < MIN_MATCH
+	  ;;  * these bytes are garbage, but it does not matter since the
+	  ;;  * next lookahead bytes will always be emitted as literals.
+	  ;;  */
+	  (set! prev_length (sub1 prev_length))
+	  (when (not (= prev_length 0))
+	    (loop)))
+	(set! match_available #f)
+	(set! match_length MIN_MATCH-1)
+	(set! strstart (add1 strstart))
+	(when flush
+	  (DEBUG (Trace stderr "flush~n"))
+	  (FLUSH-BLOCK 0)
+	  (DEBUG (Trace stderr "flush done~n"))
+	  (set! block_start strstart))]
+
+       [match_available
+	(DEBUG (Trace stderr "x2~n"))
+	;; /* If there was no match at the previous position, output a
+	;;  * single literal. If there was a match but the current match
+	;;  * is longer, truncate the previous match to a single literal.
+	;;  */
+	;; (Tracevv stderr "~c" (integer->char (vector-ref window-vec (- strstart 1))))
+	(when (ct_tally 0 (vector-ref window-vec (- strstart 1)))
+	  (FLUSH-BLOCK 0)
+	  (set! block_start strstart))
+	(set! strstart (add1 strstart))
+	(set! lookahead (sub1 lookahead))]
+
+       [else
+	(DEBUG (Trace stderr "x3~n"))
+	;; /* There is no previous match to compare with, wait for
+	;;  * the next step to decide.
+	;;  */
+	(set! match_available #t)
+	(set! strstart (add1 strstart))
+	(set! lookahead (sub1 lookahead))])
+
+      (Assert 
+       (unless (and (<= strstart bytes_in)
+		    (<= lookahead bytes_in))
+	 (error "a bit too far")))
+
+      ;; /* Make sure that we always have enough lookahead, except
+      ;;  * at the end of the input file. We need MAX_MATCH bytes
+      ;;  * for the next match, plus MIN_MATCH bytes to insert the
+      ;;   * string following the next match.
+      ;;  */
+      (let loop ()
+	(when (and (< lookahead MIN_LOOKAHEAD)
+		   (not eofile))
+	  (DEBUG (Trace stderr "fill~n"))
+	  (fill_window)
+	  (loop)))
+
+      (dloop)))
+
+  (when match_available
+    (ct_tally 0 (vector-ref window-vec (- strstart 1))))
+
+  (FLUSH-BLOCK 1)); /* eof */
+
+#|
+/* trees.c -- output deflated data using Huffman coding
+ * Copyright (C) 1992-1993 Jean-loup Gailly
+ * This is free software; you can redistribute it and/or modify it under the
+ * terms of the GNU General Public License, see the file COPYING.
+ */
+
+/*
+ *  PURPOSE
+ *
+ *      Encode various sets of source values using variable-length
+ *      binary code trees.
+ *
+ *  DISCUSSION
+ *
+ *      The PKZIP "deflation" process uses several Huffman trees. The more
+ *      common source values are represented by shorter bit sequences.
+ *
+ *      Each code tree is stored in the ZIP file in a compressed form
+ *      which is itself a Huffman encoding of the lengths of
+ *      all the code strings (in ascending order by source values).
+ *      The actual code strings are reconstructed from the lengths in
+ *      the UNZIP process, as described in the "application note"
+ *      (APPNOTE.TXT) distributed as part of PKWARE's PKZIP program.
+ *
+ *  REFERENCES
+ *
+ *      Lynch, Thomas J.
+ *          Data Compression:  Techniques and Applications, pp. 53-55.
+ *          Lifetime Learning Publications, 1985.  ISBN 0-534-03418-7.
+ *
+ *      Storer, James A.
+ *          Data Compression:  Methods and Theory, pp. 49-50.
+ *          Computer Science Press, 1988.  ISBN 0-7167-8156-5.
+ *
+ *      Sedgewick, R.
+ *          Algorithms, p290.
+ *          Addison-Wesley, 1983. ISBN 0-201-06672-6.
+ *
+ *  INTERFACE
+ *
+ *      void ct_init (ush *attr, int *methodp)
+ *          Allocate the match buffer, initialize the various tables and save
+ *          the location of the internal file attribute (ascii/binary) and
+ *          method (DEFLATE/STORE)
+ *
+ *      void ct_tally (int dist, int lc);
+ *          Save the match info and tally the frequency counts.
+ *
+ *      long flush_block (char *buf, ulg stored_len, int eof)
+ *          Determine the best encoding for the current block: dynamic trees,
+ *          static trees or store, and output the encoded block to the zip
+ *          file. Returns the total compressed length for the file so far.
+ *
+ */
+
+|#
+
+;; /* ===========================================================================
+;;  * Constants
+;;  */
+
+(define MAX_BITS 15)
+;; /* All codes must not exceed MAX_BITS bits */
+
+(define MAX_BL_BITS 7)
+;; /* Bit length codes must not exceed MAX_BL_BITS bits */
+
+(define LENGTH_CODES 29)
+;; /* number of length codes, not counting the special END_BLOCK code */
+
+(define LITERALS  256)
+;; /* number of literal bytes 0..255 */
+
+(define END_BLOCK 256)
+;; /* end of block literal code */
+
+(define L_CODES (+ LITERALS 1 LENGTH_CODES))
+;; /* number of Literal or Length codes, including the END_BLOCK code */
+
+(define D_CODES   30)
+;; /* number of distance codes */
+
+(define BL_CODES  19)
+;; /* number of codes used to transfer the bit lengths */
+
+(define extra_lbits ;; /* extra bits for each length code */
+  (vector 0 0 0 0 0 0 0 0 1 1 1 1 2 2 2 2 3 3 3 3 4 4 4 4 5 5 5 5 0))
+
+(define extra_dbits ;; /* extra bits for each distance code */
+  (vector 0 0 0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 10 10 11 11 12 12 13 13))
+
+(define extra_blbits ;; /* extra bits for each bit length code */
+  (vector 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 3 7))
+
+(define STORED_BLOCK 0)
+(define STATIC_TREES 1)
+(define DYN_TREES    2)
+;; /* The three kinds of block type */
+
+(define LIT_BUFSIZE  #x8000)
+(define DIST_BUFSIZE #x8000)
+;; /* Sizes of match buffers for literals/lengths and distances.  There are
+;;  * 4 reasons for limiting LIT_BUFSIZE to 64K:
+;;  *   - frequencies can be kept in 16 bit counters
+;;  *   - if compression is not successful for the first block, all input data is
+;;  *     still in the window so we can still emit a stored block even when input
+;;  *     comes from standard input.  (This can also be done for all blocks if
+;;  *     LIT_BUFSIZE is not greater than 32K.)
+;;  *   - if compression is not successful for a file smaller than 64K, we can
+;;  *     even emit a stored file instead of a stored block (saving 5 bytes).
+;;  *   - creating new Huffman trees less frequently may not provide fast
+;;  *     adaptation to changes in the input data statistics. (Take for
+;;  *     example a binary file with poorly compressible code followed by
+;;  *     a highly compressible string table.) Smaller buffer sizes give
+;;  *     fast adaptation but have of course the overhead of transmitting trees
+;;  *     more frequently.
+;;  *   - I can't count above 4
+;;  * The current code is general and allows DIST_BUFSIZE < LIT_BUFSIZE (to save
+;;  * memory at the expense of compression). Some optimizations would be possible
+;;  * if we rely on DIST_BUFSIZE == LIT_BUFSIZE.
+;;  */
+(when (> LIT_BUFSIZE INBUFSIZ)
+  (error "cannot overlay l_buf and inbuf"))
+
+(define REP_3_6      16)
+;; /* repeat previous bit length 3-6 times (2 bits of repeat count) */
+
+(define REPZ_3_10    17)
+;; /* repeat a zero length 3-10 times  (3 bits of repeat count) */
+
+(define REPZ_11_138  18)
+;; /* repeat a zero length 11-138 times  (7 bits of repeat count) */
+
+;; /* ===========================================================================
+;;  * Local data
+;;  */
+
+;; /* Data structure describing a single value and its code string. */
+(define-struct ct_data (freq code dad len))
+;;    union {
+;;        ush  freq;       ;; /* frequency count */
+;;        ush  code;       ;; /* bit string */
+;;    } fc;
+;;    union {
+;;        ush  dad;        ;; /* father node in Huffman tree */
+;;        ush  len;        ;; /* length of bit string */
+;;    } dl;
+#|
+(define ct_data-freq ct_data-freq/code)
+(define ct_data-code ct_data-freq/code)
+(define ct_data-dad ct_data-dad/len)
+(define ct_data-len ct_data-dad/len)
+(define set-ct_data-freq! set-ct_data-freq/code!)
+(define set-ct_data-code! set-ct_data-freq/code!)
+(define set-ct_data-dad! set-ct_data-dad/len!)
+(define set-ct_data-len! set-ct_data-dad/len!)
+(define (_make-ct_data f c d l) (make-ct_data (or f c) (or d l)))
+|#
+(define _make-ct_data make-ct_data)
+
+(define HEAP_SIZE (+ (* 2 L_CODES) 1))
+;; /* maximum heap size */
+
+(define dyn_ltree (make-vector HEAP_SIZE 'uninit-dl))   ;; /* literal and length tree */
+(define dyn_dtree (make-vector (+ (* 2 D_CODES) 1) 'uninit-dd)) ;; /* distance tree */
+
+(define static_ltree (make-vector (+ L_CODES 2) 'uninit-sl))
+;; /* The static literal tree. Since the bit lengths are imposed, there is no
+;;  * need for the L_CODES extra codes used during heap construction. However
+;;  * The codes 286 and 287 are needed to build a canonical tree (see ct_init
+;;  * below).
+;;  */
+
+(define static_dtree (make-vector D_CODES 'uninit-sd))
+;; /* The static distance tree. (Actually a trivial tree since all codes use
+;;  * 5 bits.)
+;;  */
+
+(define bl_tree (make-vector (+ (* 2 BL_CODES) 1) 'uninit-dl))
+;; /* Huffman tree for the bit lengths */
+
+(define-struct tree_desc
+  (dyn_tree;      ;; /* the dynamic tree */
+   static_tree;   ;; /* corresponding static tree or NULL */
+   extra_bits;    ;; /* extra bits for each code or NULL */
+   extra_base;    ;; /* base index for extra_bits */
+   elems;         ;; /* max number of elements in the tree */
+   max_length;    ;; /* max bit length for the codes */
+   max_code));    ;; /* largest code with non zero frequency */
+
+(define l_desc (make-tree_desc
+		dyn_ltree static_ltree extra_lbits
+		(+ LITERALS 1) L_CODES MAX_BITS 0))
+
+(define d_desc (make-tree_desc
+		dyn_dtree static_dtree extra_dbits
+		0 D_CODES MAX_BITS 0))
+
+(define bl_desc (make-tree_desc
+		 bl_tree #f extra_blbits
+		 0 BL_CODES MAX_BL_BITS 0))
+
+
+(define bl_count (make-vector (+ MAX_BITS 1) 0))
+;; /* number of codes at each bit length for an optimal tree */
+
+(define bl_order 
+  (vector 16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15))
+;; /* The lengths of the bit length codes are sent in order of decreasing
+;;  * probability, to avoid transmitting the lengths for unused bit length codes.
+;;  */
+
+(define heap (make-vector (+ (* 2 L_CODES) 1) 0)) ;; /* heap used to build the Huffman trees */
+(define heap_len 0)               ;; /* number of elements in the heap */
+(define heap_max 0)               ;; /* element of largest frequency */
+;; /* The sons of heap[n] are heap[2*n] and heap[2*n+1]. heap[0] is not used.
+;;  * The same heap array is used to build all trees.
+;;  */
+
+(define depth (make-vector (+ (* 2 L_CODES) 1) 0))
+;; /* Depth of each subtree used as tie breaker for trees of equal frequency */
+
+(define length_code (make-vector (- MAX_MATCH MIN_MATCH -1) 0))
+;; /* length code for each normalized match length (0 == MIN_MATCH) */
+
+(define dist_code (make-vector 512 0))
+;; /* distance codes. The first 256 values correspond to the distances
+;;  * 3 .. 258, the last 256 values correspond to the top 8 bits of
+;;  * the 15 bit distances.
+;;  */
+
+(define base_length (make-vector LENGTH_CODES 0))
+;; /* First normalized length for each code (0 = MIN_MATCH) */
+
+(define base_dist (make-vector D_CODES 0))
+;; /* First normalized distance for each code (0 = distance of 1) */
+
+(define inbuf (make-gzvector (make-vector (+ INBUFSIZ INBUF_EXTRA) 0) 0))
+(define l_buf inbuf)
+;; /* DECLARE(uch, l_buf, LIT_BUFSIZE);  buffer for literals or lengths */
+
+(define d_buf (make-vector DIST_BUFSIZE 0))
+;; /* DECLARE(ush, d_buf, DIST_BUFSIZE); buffer for distances */
+
+(define flag_buf (make-vector (/ LIT_BUFSIZE 8) 0))
+;; /* flag_buf is a bit array distinguishing literals from lengths in
+;;  * l_buf, thus indicating the presence or absence of a distance.
+;;  */
+
+(define last_lit 0)    ;; /* running index in l_buf */
+(define last_dist 0)   ;; /* running index in d_buf */
+(define last_flags 0)  ;; /* running index in flag_buf */
+(define flags 0)            ;; /* current flags not yet saved in flag_buf */
+(define flag_bit 0)         ;; /* current bit used in flags */
+;; /* bits are filled in flags starting at bit 0 (least significant).
+;;  * Note: these flags are overkill in the current code since we don't
+;;  * take advantage of DIST_BUFSIZE == LIT_BUFSIZE.
+;; */
+
+(define opt_len 0);        ;; /* bit length of current block with optimal trees */
+(define static_len 0);     ;; /* bit length of current block with static trees */
+
+(define compressed_len 0); ;; /* total bit length of compressed file */
+
+(define input_len 0);      ;; /* total byte length of input file */
+;; /* input_len is for debugging only since we can get it by other means. */
+
+;; (define block_start 0);       ;; /* window offset of current block */
+;; (define strstart 0); ;; /* window offset of current string */
+
+(define (send_code c tree) (send_bits (ct_data-code (vector-ref tree c))
+				      (ct_data-len (vector-ref tree c))))
+;; /* Send a code of the given tree. c and tree must not have side effects */
+
+(define (d_code dist) 
+  (if (< dist 256)
+      (vector-ref dist_code dist)
+      (vector-ref dist_code (+ 256 (>> dist 7)))))
+;; /* Mapping from a distance to a distance code. dist is the distance - 1 and
+;;  * must not have side effects. dist_code[256] and dist_code[257] are never
+;;  * used.
+;; */
+
+;; /* ===========================================================================
+;;  * Allocate the match buffer, initialize the various tables and save the
+;;  * location of the internal file attribute (ascii/binary) and method
+;;  * (DEFLATE/STORE).
+;; */
+(define (ct_init)
+
+  (define length 0)   ;; /* length value */
+  (define dist 0)     ;; /* distance index */
+
+  (set! compressed_len 0)
+  (set! input_len 0)
+  
+  (unless (ct_data? (vector-ref static_dtree 0)) ;; /* ct_init already called? */
+    ;; /* Initialize the mapping length (0..255) -> length code (0..28) */
+    (set! length 0)
+    (for 0 < (- LENGTH_CODES 1) add1
+	 (lambda (code)
+	   (vector-set! base_length code length)
+	   (for 0 < (<< 1 (vector-ref extra_lbits code)) add1
+		(lambda (n)
+		  (vector-set! length_code length code)
+		  (set! length (add1 length))))))
+    
+    (Assert 
+     (unless (= length 256)
+       (error "ct_init: length != 256")))
+
+    ;; /* Note that the length 255 (match length 258) can be represented
+    ;;  * in two different ways: code 284 + 5 bits or code 285, so we
+    ;;  * overwrite length_code[255] to use the best encoding:
+    ;; */
+    (vector-set! length_code (- length 1) (- LENGTH_CODES 1))
+
+    ;; /* Initialize the mapping dist (0..32K) -> dist code (0..29) */
+    (set! dist 0)
+    (for 0 < 16 add1
+	 (lambda (code)
+	   (vector-set! base_dist code dist)
+	   (for 0 < (<< 1 (vector-ref extra_dbits code)) add1
+		(lambda (n)
+		  (vector-set! dist_code dist code)
+		  (set! dist (add1 dist))))))
+
+    (Assert
+     (unless (= dist 256)
+       (error "ct_init: dist != 256")))
+    (set! dist (>> dist 7)) ;; /* from now on, all distances are divided by 128 */
+    (for 16 < D_CODES add1
+	 (lambda (code)
+	   (vector-set! base_dist code (<< dist 7))
+	   (for 0 < (<< 1 (- (vector-ref extra_dbits code) 7)) add1
+		(lambda (n)
+		  (vector-set! dist_code (+ 256 dist) code)
+		  (set! dist (add1 dist))))))
+
+    (Assert
+     (unless (= dist 256)
+       (error "ct_init: 256+dist != 512")))
+
+    ;; /* Construct the codes of the static literal tree */
+    (for 0 <= MAX_BITS add1
+	 (lambda (bits)
+	   (vector-set! bl_count bits 0)))
+
+    (let ([init-ltree
+	   (lambda (s e v)
+	     (for s <= e add1
+		  (lambda (n)
+		    (vector-set! static_ltree n (_make-ct_data #f 0 #f v))
+		    (vector-set! bl_count v (add1 (vector-ref bl_count v))))))])
+      (init-ltree 0 143 8)
+      (init-ltree 144 255 9)
+      (init-ltree 256 279 7)
+      (init-ltree 280 287 8))
+    ;; /* Codes 286 and 287 do not exist, but we must include them in the
+    ;;  * tree construction to get a canonical Huffman tree (longest code
+    ;;  * all ones)
+    ;; */
+    (gen_codes static_ltree (+ L_CODES 1))
+
+    ;; /* The static distance tree is trivial: */
+    (for 0 < D_CODES add1
+	 (lambda (n)
+	   (vector-set! static_dtree n 
+			(_make-ct_data #f (bi_reverse n 5)
+				       #f 5))))
+
+    ;; /* Initialize the first block of the first file: */
+    (init_block)))
+
+;; /* ===========================================================================
+;;  * Initialize a new block.
+;; */
+(define inited-once? #f)
+(define (init_block)
+  (for 0 < (if inited-once? L_CODES HEAP_SIZE) add1
+       (lambda (n)
+	 (vector-set! dyn_ltree n (_make-ct_data 0 #f 0 #f))))
+  (for 0 < (if inited-once? D_CODES (+ (* 2 D_CODES) 1)) add1
+       (lambda (n)
+	 (vector-set! dyn_dtree n (_make-ct_data 0 #f 0 #f))))
+  (for 0 < (if inited-once? BL_CODES (+ (* 2 BL_CODES) 1)) add1
+       (lambda (n)
+	 (vector-set! bl_tree n (_make-ct_data 0 #f 0 #f))))
+
+  (set! inited-once? #t)
+
+  (set-ct_data-freq! (vector-ref dyn_ltree END_BLOCK) 1)
+  (set! opt_len 0)
+  (set! static_len 0)
+  (set! last_lit 0)
+  (set! last_dist 0)
+  (set! last_flags 0)
+  (set! flags 0)
+  (set! flag_bit 1))
+
+(define SMALLEST 1)
+;; /* Index within the heap array of least frequent node in the Huffman tree */
+
+
+;; /* ===========================================================================
+;;  * Remove the smallest element from the heap and recreate the heap with
+;;  * one less element. Updates heap and heap_len.
+;; */
+;; (define-macro pqremove <see above>)
+
+;; /* ===========================================================================
+;;  * Compares to subtrees, using the tree depth as tie breaker when
+;;  * the subtrees have equal frequency. This minimizes the worst case length.
+;;  */
+(define (smaller tree n m)
+  (or (< (ct_data-freq (vector-ref tree n)) (ct_data-freq (vector-ref tree m)))
+      (and (= (ct_data-freq (vector-ref tree n)) (ct_data-freq (vector-ref tree m)))
+	   (<= (vector-ref depth n) (vector-ref depth m)))))
+
+;; /* ===========================================================================
+;;  * Restore the heap property by moving down the tree starting at node k,
+;;  * exchanging a node with the smallest of its two sons if necessary, stopping
+;;  * when the heap property is re-established (each father smaller than its
+;;  * two sons).
+;;  */
+(define (pqdownheap tree k)
+  ;; ct_data near *tree;  /* the tree to restore */
+  ;; int k;               /* node to move down */
+
+  (define v (vector-ref heap k))
+  (define j (<< k 1))  ;; /* left son of k */
+  (let/ec break
+    (let loop ()
+      (when (<= j heap_len)
+	;; /* Set j to the smallest of the two sons: */
+	(when (and (< j heap_len)
+		   (smaller tree 
+			    (vector-ref heap (+ j 1))
+			    (vector-ref heap j)))
+	  (set! j (add1 j)))
+	
+	;; /* Exit if v is smaller than both sons */
+	(when (smaller tree  v (vector-ref heap j))
+	  (break))
+
+	;; /* Exchange v with the smallest son */
+	(vector-set! heap k (vector-ref heap j))
+	(set! k j)
+
+	;; /* And continue down the tree, setting j to the left son of k */
+	(set! j (<< j 1))
+
+	(loop))))
+  (vector-set! heap k v))
+
+;; /* ===========================================================================
+;;  * Compute the optimal bit lengths for a tree and update the total bit length
+;;  * for the current block.
+;;  * IN assertion: the fields freq and dad are set, heap[heap_max] and
+;;  *    above are the tree nodes sorted by increasing frequency.
+;;  * OUT assertions: the field len is set to the optimal bit length, the
+;;  *     array bl_count contains the frequencies for each bit length.
+;;  *     The length opt_len is updated; static_len is also updated if stree is
+;;  *     not null.
+;; */
+(define (gen_bitlen desc)
+  ;; tree_desc near *desc; ;; /* the tree descriptor */
+
+  (define tree (tree_desc-dyn_tree desc))
+  (define extra (tree_desc-extra_bits desc))
+  (define base (tree_desc-extra_base desc))
+  (define max_code (tree_desc-max_code desc))
+  (define max_length (tree_desc-max_length desc))
+  (define stree (tree_desc-static_tree desc))
+  (define n 0) (define m 0) ;; /* iterate over the tree elements */
+  (define bits 0)           ;; /* bit length */
+  (define xbits 0)          ;; /* extra bits */
+  (define f 0);              ;; /* frequency */
+  (define overflow 0);   ;; /* number of elements with bit length too large */
+  (define h 0)
+
+  (for 0 <= MAX_BITS add1
+       (lambda (bits)
+	 (vector-set! bl_count bits 0)))
+
+  ;; /* In a first pass, compute the optimal bit lengths (which may
+  ;;  * overflow in the case of the bit length tree).
+  ;;  */
+  (set-ct_data-len! (vector-ref tree (vector-ref heap heap_max)) 0) ;; /* root of the heap */
+
+  (for (+ 1 heap_max) < HEAP_SIZE add1
+       (lambda (h)
+	 (set! n (vector-ref heap h))
+	 (set! bits (+ (ct_data-len (vector-ref tree (ct_data-dad (vector-ref tree n)))) 1))
+	 (when (> bits max_length) 
+	   (set! bits max_length)
+	   (set! overflow (add1 overflow)))
+	 (set-ct_data-len! (vector-ref tree n) bits)
+	 ;; /* We overwrite tree[n].Dad which is no longer needed */
+
+	 (unless (> n max_code)
+	   ;; /* leaf node */
+
+	   (vector-set! bl_count bits (add1 (vector-ref bl_count bits)))
+	   (set! xbits 0)
+	   (when (>= n base)
+	     (set! xbits (vector-ref extra (- n base))))
+	   (set! f (ct_data-freq (vector-ref tree n)))
+	   (set! opt_len (+ opt_len (* f (+ bits xbits))))
+	   (when stree
+	     (set! static_len (+ static_len (* f (+ (ct_data-len (vector-ref stree n)) xbits))))))))
+
+  (unless (= overflow 0)
+
+    (DEBUG (Trace stderr "~nbit length overflow~n"))
+    ;; /* This happens for example on obj2 and pic of the Calgary corpus */
+
+    ;; /* Find the first bit length which could increase: */
+    (let loop ()
+      (set! bits (- max_length 1))
+      (let loop ()
+	(when (= (vector-ref bl_count bits) 0)
+	  (set! bits (sub1 bits))
+	  (loop)))
+      (vector-set! bl_count bits (sub1 (vector-ref bl_count bits)))
+      (vector-set! bl_count (+ bits 1) (+ (vector-ref bl_count (+ bits 1)) 2))
+      (vector-set! bl_count max_length (sub1 (vector-ref bl_count max_length)))
+      ;; /* The brother of the overflow item also moves one step up,
+      ;;  * but this does not affect bl_count[max_length]
+      ;;  */
+      (set! overflow (- overflow 2))
+      (when (> overflow 0)
+	(loop)))
+
+    (set! h HEAP_SIZE)
+    ;; /* Now recompute all bit lengths, scanning in increasing frequency.
+    ;;  * h is still equal to HEAP_SIZE. (It is simpler to reconstruct all
+    ;;  * lengths instead of fixing only the wrong ones. This idea is taken
+    ;;  * from 'ar' written by Haruhiko Okumura.)
+    ;;  */
+    (for max_length > 0 sub1
+	 (lambda (bits)
+	   (set! n (vector-ref bl_count bits))
+	   (let loop ()
+	     (when (not (= n 0))
+	       (set! h (sub1 h))
+	       (set! m (vector-ref heap h))
+	       (if (> m max_code)
+		   (loop)
+		   (begin
+		     (when (not (= (ct_data-len (vector-ref tree m)) bits))
+		       (set! opt_len
+			     (+ opt_len (* (- bits (ct_data-len (vector-ref tree m)))
+					   (ct_data-freq (vector-ref tree m))))))
+		     (set-ct_data-len! (vector-ref tree m) bits)
+		     (set! n (sub1 n))
+		     (loop)))))))))
+
+;; /* ===========================================================================
+;;  * Generate the codes for a given tree and bit counts (which need not be
+;;  * optimal).
+;;  * IN assertion: the array bl_count contains the bit length statistics for
+;;  * the given tree and the field len is set for all tree elements.
+;;  * OUT assertion: the field code is set for all tree elements of non
+;;  *     zero code length.
+;; */
+(define (gen_codes tree max_code)
+  ;; ct_data near *tree;        /* the tree to decorate */
+  ;; int max_code;              /* largest code with non zero frequency */
+
+  (define next_code (make-vector (+ MAX_BITS 1) 0)) ;; /* next code value for each bit length */
+  (define code 0)              ;; /* running code value */
+  (define bits 0)                  ;; /* bit index */
+
+  ;; /* The distribution counts are first used to generate the code values
+  ;;  * without bit reversal.
+  ;;  */
+  (for 1 <= MAX_BITS add1
+       (lambda (bits)
+	 (set! code (<< (+ code (vector-ref bl_count (- bits 1))) 1))
+	 (vector-set! next_code bits code)))
+  ;; /* Check that the bit counts in bl_count are consistent. The last code
+  ;;  * must be all ones.
+  ;;  */
+  (Assert 
+   (unless (= (+ code (vector-ref bl_count MAX_BITS)-1)
+	      (- (<< 1 MAX_BITS) 1))
+     "inconsistent bit counts"))
+  (DEBUG (Tracev stderr "\ngen_codes: max_code ~a " max_code))
+
+  (for  0 <= max_code add1
+	(lambda (n)
+	  (let ([len (ct_data-len (vector-ref tree n))])
+	    (unless (= len 0)
+	      ;; /* Now reverse the bits */
+	      (let ([nc (vector-ref next_code len)])
+		(set-ct_data-code! (vector-ref tree n)
+				   (bi_reverse nc len))
+		(vector-set! next_code len (add1 nc)))
+
+	      (DEBUG (Tracec (not (eq? tree static_ltree))
+			     stderr
+			     "~nn ~a ~c l ~a c ~x (~x) "
+			     n #\space len
+			     (or (ct_data-code (vector-ref tree n)) 0)
+			     (or (- (vector-ref next_code len) 1) 0))))))))
+
+;; /* ===========================================================================
+;;  * Construct one Huffman tree and assigns the code bit strings and lengths.
+;;  * Update the total bit length for the current block.
+;;  * IN assertion: the field freq is set for all tree elements.
+;;  * OUT assertions: the fields len and code are set to the optimal bit length
+;;  *     and corresponding code. The length opt_len is updated; static_len is
+;;  *     also updated if stree is not null. The field max_code is set.
+;;  */
+(define (build_tree desc)
+  ;; tree_desc near *desc; ;; /* the tree descriptor */
+
+  (define tree (tree_desc-dyn_tree desc))
+  (define stree (tree_desc-static_tree desc))
+  (define elems (tree_desc-elems desc))
+  (define n 0) (define m 0)   ;; /* iterate over heap elements */
+  (define max_code -1) ;; /* largest code with non zero frequency */
+  (define node elems)  ;; /* next internal node of the tree */
+
+  ;; /* Construct the initial heap, with least frequent element in
+  ;;  * heap[SMALLEST]. The sons of heap[n] are heap[2*n] and heap[2*n+1].
+  ;;  * heap[0] is not used.
+  ;; */
+  (set! heap_len 0)
+  (set! heap_max HEAP_SIZE)
+
+  (for 0 < elems add1
+       (lambda (n)
+	 (DEBUG (Trace stderr "freq: ~a ~a~n" n (ct_data-freq (vector-ref tree n))))
+	 (if (not (= (ct_data-freq (vector-ref tree n)) 0))
+	     (begin
+	       (set! heap_len (add1 heap_len))
+	       (set! max_code n)
+	       (vector-set! heap heap_len n)
+	       (vector-set! depth n 0))
+	     (set-ct_data-len! (vector-ref tree n) 0))))
+
+  (DEBUG (Trace stderr "Building: ~a ~a ~a~n" elems heap_len max_code))
+
+  ;; /* The pkzip format requires that at least one distance code exists,
+  ;;  * and that at least one bit should be sent even if there is only one
+  ;;  * possible code. So to avoid special checks later on we force at least
+  ;;  * two codes of non zero frequency.
+  ;;  */
+  (let loop ()
+    (when (< heap_len 2)
+      (let ([new (if (< max_code 2)
+		     (begin
+		       (set! max_code (add1 max_code))
+		       max_code)
+		     0)])
+	(set! heap_len (add1 heap_len))
+	(vector-set! heap heap_len new)
+	(set-ct_data-freq! (vector-ref tree new) 1)
+        (vector-set! depth new 0)
+	(set! opt_len (sub1 opt_len))
+	(when stree
+	  (set! static_len (- static_len (ct_data-len (vector-ref stree new)))))
+        ;; /* new is 0 or 1 so it does not have extra bits */
+	(loop))))
+
+  (set-tree_desc-max_code! desc max_code)
+
+  ;; /* The elements heap[heap_len/2+1 .. heap_len] are leaves of the tree,
+  ;;  * establish sub-heaps of increasing lengths:
+  ;;  */
+  (for (quotient heap_len 2) >= 1 sub1
+       (lambda (n)
+	 (pqdownheap tree n)))
+ 
+  ;; /* Construct the Huffman tree by repeatedly combining the least two
+  ;;  * frequent nodes.
+  ;;  */
+  (let loop ()
+    ;; /* n = node of least frequency */
+    (set! n (vector-ref heap SMALLEST))
+    (vector-set! heap SMALLEST (vector-ref heap heap_len))
+    (set! heap_len (sub1 heap_len))
+    (pqdownheap tree SMALLEST)
+
+    (set! m (vector-ref heap SMALLEST))  ;; /* m = node of next least frequency */
+
+    (set! heap_max (sub1 heap_max))
+    (vector-set! heap heap_max n) ;; /* keep the nodes sorted by frequency */
+    (set! heap_max (sub1 heap_max))
+    (vector-set! heap heap_max m)
+
+    ;; /* Create a new node father of n and m */
+    (set-ct_data-freq! (vector-ref tree node)
+		       (+ (ct_data-freq (vector-ref tree n))
+			  (ct_data-freq (vector-ref tree m))))
+    (vector-set! depth node (+ (max (vector-ref depth n)
+				    (vector-ref depth m))
+			       1))
+    (set-ct_data-dad! (vector-ref tree n) node)
+    (set-ct_data-dad! (vector-ref tree m) node)
+
+    ;; /* and insert the new node in the heap */
+    (vector-set! heap SMALLEST node)
+    (set! node (add1 node))
+    (pqdownheap tree SMALLEST)
+
+    (when (>= heap_len 2)
+      (loop)))
+
+  (set! heap_max (sub1 heap_max))
+  (vector-set! heap heap_max (vector-ref heap SMALLEST))
+
+  ;; /* At this point, the fields freq and dad are set. We can now
+  ;;  * generate the bit lengths.
+  ;;  */
+  (gen_bitlen desc)
+
+  (DEBUG (Trace stderr "Build: ~a~n" max_code))
+  ;; /* The field len is now set, we can generate the bit codes */
+  (gen_codes tree max_code))
+
+;; /* ===========================================================================
+;;  * Scan a literal or distance tree to determine the frequencies of the codes
+;;  * in the bit length tree. Updates opt_len to take into account the repeat
+;;  * counts. (The contribution of the bit length codes will be added later
+;;  * during the construction of bl_tree.)
+;;  */
+(define (scan_tree tree max_code)
+  ;; ct_data near *tree; ;; /* the tree to be scanned */
+  ;; int max_code;       ;; /* and its largest code of non zero frequency */
+
+  (define prevlen -1)          ;; /* last emitted length */
+  (define curlen 0)                ;; /* length of current code */
+  (define nextlen (ct_data-len (vector-ref tree 0))) ;; /* length of next code */
+  (define count 0)             ;; /* repeat count of the current code */
+  (define max_count 7)         ;; /* max repeat count */
+  (define min_count 4)         ;; /* min repeat count */
+
+  (when (= nextlen 0)
+    (set! max_count 138)
+    (set! min_count 3))
+  
+  (set-ct_data-len! (vector-ref tree (+ max_code 1)) #xffff) ;; /* guard */
+
+  (for 0 <= max_code add1
+       (lambda (n)
+	 (let/ec continue
+	   (define (inc-bl_tree-freq which amt)
+	     (set-ct_data-freq! (vector-ref bl_tree which)
+				(+ amt (ct_data-freq 
+					(vector-ref bl_tree which)))))
+
+	   (set! curlen nextlen)
+	   (set! nextlen (ct_data-len (vector-ref tree (+ n 1))))
+	   (set! count (add1 count))
+
+	   (cond
+	    [(and (< count max_count)
+		  (= curlen nextlen))
+	     (continue)]
+	    [(< count min_count)
+	     (inc-bl_tree-freq curlen count)]
+	    [(not (= curlen 0))
+	     (when (not (= curlen prevlen))
+	       (inc-bl_tree-freq curlen 1))
+	     (inc-bl_tree-freq REP_3_6 1)]
+	    [(<= count 10)
+	     (inc-bl_tree-freq REPZ_3_10 1)]
+	    [else
+	     (inc-bl_tree-freq REPZ_11_138 1)])
+
+	   (set! count 0)
+	   (set! prevlen curlen)
+
+	   (cond
+	    [(= nextlen 0)
+	     (set! max_count 138)
+	     (set! min_count 3)]
+	    [(= curlen nextlen)
+	     (set! max_count 6)
+	     (set! min_count 3)]
+	    [else
+	     (set! max_count 7)
+	     (set! min_count 4)])))))
+
+;; /* ===========================================================================
+;;  * Send a literal or distance tree in compressed form, using the codes in
+;;  * bl_tree.
+;;  */
+(define (send_tree tree max_code)
+  ;; ct_data near *tree; ;; /* the tree to be scanned */
+  ;; int max_code;       ;; /* and its largest code of non zero frequency */
+
+  (define prevlen -1)          ;; /* last emitted length */
+  (define curlen 0)              ;; /* length of current code */
+  (define nextlen (ct_data-len (vector-ref tree 0))) ;; /* length of next code */
+  (define count 0)             ;; /* repeat count of the current code */
+  (define max_count 7)         ;; /* max repeat count */
+  (define min_count 4)         ;; /* min repeat count */
+
+  ;; /* tree[max_code+1].Len = -1; */  ;; /* guard already set */
+  (when (= nextlen 0) 
+    (set! max_count 138)
+    (set! min_count 3))
+
+  (for 0 <= max_code add1
+       (lambda (n)
+	 (let/ec continue
+	   (set! curlen nextlen)
+	   (set! nextlen (ct_data-len (vector-ref tree (+ n 1))))
+	   
+	   (set! count (add1 count))
+	   (cond
+	    [(and (< count max_count)
+		  (= curlen nextlen))
+	     (continue)]
+	    [(< count min_count)
+	     (let loop ()
+	       (send_code curlen bl_tree)
+	       (set! count (sub1 count))
+	       (when (not (= count 0))
+		 (loop)))]
+	    [(not (= curlen 0))
+	     (when (not (= curlen prevlen))
+	       (send_code curlen bl_tree)
+	       (set! count (sub1 count)))
+	     (Assert
+	      (unless (>= 6 count 3)
+		(error " 3_6?")))
+	     (send_code REP_3_6 bl_tree)
+	     (send_bits (- count 3) 2)]
+	    [(<= count 10)
+	     (send_code REPZ_3_10 bl_tree)
+	     (send_bits (- count 3) 3)]
+	    [else
+	     (send_code REPZ_11_138 bl_tree)
+	     (send_bits (- count 11) 7)])
+
+	   (set! count 0)
+	   (set! prevlen curlen)
+	   
+	   (cond
+	    [(= nextlen 0)
+	     (set! max_count 138)
+	     (set! min_count 3)]
+	    [(= curlen nextlen)
+	     (set! max_count 6)
+	     (set! min_count 3)]
+	    [else
+	     (set! max_count 7)
+	     (set! min_count 4)])))))
+
+;; /* ===========================================================================
+;;  * Construct the Huffman tree for the bit lengths and return the index in
+;;  * bl_order of the last bit length code to send.
+;;  */
+(define (build_bl_tree)
+  (define max_blindex 0)  ;; /* index of last bit length code of non zero freq */
+
+  ;; /* Determine the bit length frequencies for literal and distance trees */
+  (scan_tree dyn_ltree (tree_desc-max_code l_desc))
+  (scan_tree dyn_dtree (tree_desc-max_code d_desc))
+
+  ;; /* Build the bit length tree: */
+  (build_tree bl_desc)
+  ;; /* opt_len now includes the length of the tree representations, except
+  ;;  * the lengths of the bit lengths codes and the 5+5+4 bits for the counts.
+  ;;  */
+
+  ;; /* Determine the number of bit length codes to send. The pkzip format
+  ;;  * requires that at least 4 bit length codes be sent. (appnote.txt says
+  ;;  * 3 but the actual value used is 4.)
+  ;;  */
+  (set! max_blindex (- BL_CODES 1))
+  (let loop ()
+    (when (and (>= max_blindex 3) 
+	       (= (ct_data-len (vector-ref bl_tree
+					   (vector-ref bl_order max_blindex)))
+		  0))
+      (set! max_blindex (sub1 max_blindex))
+      (loop)))
+
+  ;; /* Update opt_len to include the bit length tree and counts */
+  (set! opt_len (+ opt_len (* 3 (+ max_blindex 1)) 5 5 4))
+  (DEBUG (Tracev stderr "~ndyn trees: dyn ~a, stat ~a" opt_len static_len))
+
+  max_blindex)
+
+;; /* ===========================================================================
+;;  * Send the header for a block using dynamic Huffman trees: the counts, the
+;;  * lengths of the bit length codes, the literal tree and the distance tree.
+;;  * IN assertion: lcodes >= 257, dcodes >= 1, blcodes >= 4.
+;;  */
+(define (send_all_trees lcodes dcodes blcodes)
+  ;; int lcodes, dcodes, blcodes; ;; /* number of codes for each tree */
+
+  (Assert 
+   (unless (and (>= lcodes 257)
+		(>= dcodes 1)
+		(>= blcodes 4))
+     (error "not enough codes")))
+  (Assert 
+   (unless (and (<= lcodes L_CODES)
+		(<= dcodes D_CODES)
+		(<= blcodes BL_CODES))
+     (error "too many codes ~a(~a) ~a(~a) ~a(~a)"
+	    lcodes L_CODES
+	    dcodes D_CODES
+	    blcodes BL_CODES)))
+
+  (DEBUG (Tracev stderr "~nbl counts: "))
+
+  (send_bits (- lcodes 257) 5) ;; /* not +255 as stated in appnote.txt */
+  (send_bits (- dcodes 1) 5)
+  (send_bits (- blcodes 4) 4) ;; /* not -3 as stated in appnote.txt */
+  (for 0 < blcodes add1
+       (lambda (rank)
+	 (DEBUG (Tracev stderr "~nbl code ~a " (vector-ref bl_order rank)))
+	 (send_bits (ct_data-len (vector-ref bl_tree (vector-ref bl_order rank))) 
+		    3)))
+  (DEBUG (Tracev stderr "~nbl tree: sent ~a" bits_sent))
+
+  (send_tree dyn_ltree (- lcodes 1)) ;; /* send the literal tree */
+  (DEBUG (Tracev stderr "~nlit tree: sent ~a" bits_sent))
+
+  (send_tree dyn_dtree (- dcodes 1)) ;; /* send the distance tree */
+  (DEBUG (Tracev stderr "~ndist tree: sent ~a" bits_sent)))
+
+;; /* ===========================================================================
+;;  * Determine the best encoding for the current block: dynamic trees, static
+;;  * trees or store, and output the encoded block to the zip file. This function
+;;  * returns the total compressed length for the file so far.
+;;  */
+(define (flush_block buf stored_len eof)
+  ;; char *buf;        ;; /* input block, or NULL if too old */
+  ;; ulg stored_len;   ;; /* length of input block */
+  ;; int eof;          ;; /* true if this is the last block for a file */
+
+  (define opt_lenb 0) (define static_lenb 0) ;; /* opt_len and static_len in bytes */
+  (define max_blindex 0)  ;; /* index of last bit length code of non zero freq */
+
+  (vector-set! flag_buf last_flags flags) ;; /* Save the flags for the last 8 items */
+
+  ;; /* Construct the literal and distance trees */
+  (build_tree l_desc)
+  (DEBUG (Tracev stderr "~nlit data: dyn ~a, stat ~a" opt_len static_len))
+
+  (build_tree d_desc)
+  (DEBUG (Tracev stderr "~ndist data: dyn ~a, stat ~a" opt_len static_len))
+  ;; /* At this point, opt_len and static_len are the total bit lengths of
+  ;;  * the compressed block data, excluding the tree representations.
+  ;;  */
+
+  ;; /* Build the bit length tree for the above two trees, and get the index
+  ;;  * in bl_order of the last bit length code to send.
+  ;;  */
+  (set! max_blindex (build_bl_tree))
+
+  ;; /* Determine the best encoding. Compute first the block length in bytes */
+  (set! opt_lenb (>> (+ opt_len 3 7) 3))
+  (set! static_lenb (>> (+ static_len 3 7) 3))
+  (set! input_len (+ input_len stored_len)) ;; /* for debugging only */
+
+  (DEBUG (Trace stderr "~nopt ~a(~a) stat ~a(~a) stored ~a lit ~a dist ~a "
+		opt_lenb opt_len static_lenb static_len stored_len
+		last_lit last_dist))
+
+  (when (<= static_lenb opt_lenb)
+    (set! opt_lenb static_lenb))
+  
+  ;; /* If compression failed and this is the first and last block,
+  ;;  * and if the zip file can be seeked (to rewrite the local header),
+  ;;  * the whole file is transformed into a stored file:
+  ;;  */
+  (cond
+   [(and (<= (+ stored_len 4) opt_lenb)
+	 (not (null? buf)))
+    ;; /* 4: two words for the lengths */
+
+    ;; /* The test buf != NULL is only necessary if LIT_BUFSIZE > WSIZE.
+    ;;  * Otherwise we can't have processed more than WSIZE input bytes since
+    ;;  * the last block flush, because compression would have been
+    ;;  * successful. If LIT_BUFSIZE <= WSIZE, it is never too late to
+    ;;  * transform a block into a stored block.
+    ;;  */
+    (send_bits (+ (<< STORED_BLOCK 1) eof) 3)  ;; /* send block type */
+    (set! compressed_len (bitwise-and (+ compressed_len 3 7) (bitwise-not 7)))
+    (set! compressed_len (+ compressed_len (<< (+ stored_len 4) 3)))
+    
+    (copy_block buf stored_len #t)] ;; /* with header */
+   [(= static_lenb opt_lenb)
+    (send_bits (+ (<< STATIC_TREES 1) eof) 3)
+    (compress_block static_ltree static_dtree)
+    (set! compressed_len (+ compressed_len 3 static_len))]
+   [else
+    (send_bits (+ (<< DYN_TREES 1) eof) 3)
+    (send_all_trees (+ (tree_desc-max_code l_desc) 1)
+		    (+ (tree_desc-max_code d_desc) 1)
+		    (+ max_blindex 1))
+    (compress_block dyn_ltree dyn_dtree)
+    (set! compressed_len (+ compressed_len 3 opt_len))])
+
+  ;; Assert 
+  ;; (unless (= compressed_len bits_sent)
+  ;;  (error "bad compressed size"))
+  (init_block)
+
+  (when (not (= eof 0))
+    (Assert 
+     (unless (= input_len bytes_in)
+       (newline (current-error-port))
+       (error 'eof "bad input size: ~a != ~a" input_len bytes_in)))
+    (bi_windup)
+    (set! compressed_len   ;; /* align on byte boundary */
+	  (+ compressed_len 7)))
+
+  (DEBUG (Tracev stderr "~ncomprlen ~a(~a) " (>> compressed_len 3)
+		 (- compressed_len (* 7 eof))))
+
+  (>> compressed_len 3))
+
+;; /* ===========================================================================
+;;  * Save the match info and tally the frequency counts. Return true if
+;;  * the current block must be flushed.
+;;  */
+(define (ct_tally dist lc)
+  ;; int dist;  ;; /* distance of matched string */
+  ;; int lc;    ;; /* match length-MIN_MATCH or unmatched char (if dist==0) */
+
+  (gzvector-set! l_buf last_lit lc)
+  (set! last_lit (add1 last_lit))
+  (if (= dist 0)
+      ;; /* lc is the unmatched char */
+      (set-ct_data-freq! (vector-ref dyn_ltree lc)
+			 (add1 (ct_data-freq (vector-ref dyn_ltree lc))))
+      (begin
+        ;; /* Here, lc is the match length - MIN_MATCH */
+	(set! dist (sub1 dist)) ;; /* dist = match distance - 1 */
+	(Assert
+	 (unless (and (< dist MAX_DIST)
+		      (<= lc (- MAX_MATCH MIN_MATCH))
+		      (< (d_code dist) D_CODES))
+	   (error "ct_tally: bad match")))
+
+	(let* ([i (+ (vector-ref length_code lc) LITERALS 1)]
+	       [ct (vector-ref dyn_ltree i)])
+	  (DEBUG (Trace stderr "Set: ~a -> ~a~n" lc i))
+	  (set-ct_data-freq! ct (add1 (ct_data-freq ct))))
+	(let ([ct (vector-ref dyn_dtree (d_code dist))])
+	  (set-ct_data-freq! ct (add1 (ct_data-freq ct))))
+	
+	(vector-set! d_buf last_dist dist)
+	(set! last_dist (add1 last_dist))
+	(set! flags (bitwise-ior flags flag_bit))))
+
+  (set! flag_bit (<< flag_bit 1))
+
+  ;; /* Output the flags if they fill a byte: */
+  (when (= (bitwise-and last_lit 7) 0)
+    (vector-set! flag_buf last_flags flags)
+    (set! last_flags (add1 last_flags))
+    (set! flags 0) (set! flag_bit 1))
+
+  (let/ec return
+
+    ;; /* Try to guess if it is profitable to stop the current block here */
+    (when (and (> LEVEL 2) (= (bitwise-and last_lit #xfff) 0))
+      (let ()
+        ;; /* Compute an upper bound for the compressed length */
+        (define out_length (* last_lit 8))
+        (define in_length (- strstart block_start))
+        
+        (for 0 < D_CODES add1
+             (lambda (dcode)
+               (set! out_length (+ out_length 
+                                   (* (ct_data-freq (vector-ref dyn_dtree dcode))
+                                      (+ 5 (vector-ref extra_dbits dcode)))))))
+        (set! out_length (>> out_length 3))
+        (DEBUG (Trace stderr "~nlast_lit ~a, last_dist ~a, in ~a, out ~~~a(~a%) "
+		      last_lit last_dist in_length out_length
+		      (- 100 (/ (* out_length 100) in_length))))
+        (when (and (< last_dist (quotient last_lit 2))
+                   (< out_length (quotient in_length 2)))
+          (return #t))))
+      
+    (or (= last_lit (- LIT_BUFSIZE 1))
+	(= last_dist DIST_BUFSIZE))
+    ;; /* We avoid equality with LIT_BUFSIZE because of wraparound at 64K
+    ;;  * on 16 bit machines and because stored blocks are restricted to
+    ;;  * 64K-1 bytes.
+    ;;  */
+    ))
+
+;; /* ===========================================================================
+;;  * Send the block data compressed using the given Huffman trees
+;;  */
+(define (compress_block ltree dtree)
+  ;; ct_data near *ltree; ;; /* literal tree */
+  ;; ct_data near *dtree; ;; /* distance tree */
+
+  (define dist 0) ;; /* distance of matched string */
+  (define lc 0) ;; /* match length or unmatched char (if dist == 0) */
+  (define lx 0) ;; /* running index in l_buf */
+  (define  dx 0)    ;; /* running index in d_buf */
+  (define fx 0)    ;; /* running index in flag_buf */
+  (define flag 0)       ;; /* current flags */
+  (define code 0)      ;; /* the code to send */
+  (define extra 0) ;; /* number of extra bits to send */
+
+  (when (not (= last_lit 0))
+    (let loop ()
+      (when (= (bitwise-and lx 7) 0)
+	(set! flag (vector-ref flag_buf fx))
+	(set! fx (add1 fx)))
+      
+      (set! lc (gzvector-ref l_buf lx))
+      (set! lx (add1 lx))
+
+      (cond
+       [(= (bitwise-and flag 1) 0)
+	(send_code lc ltree) ;; /* send a literal byte */
+	(DEBUG '(Tracecv (isgraph lc) stderr " '~c' " (integer->char lc)))]
+       [else
+	;; /* Here, lc is the match length - MIN_MATCH */
+	(set! code (vector-ref length_code lc))
+	(send_code (+ code LITERALS 1) ltree) ;; /* send the length code */
+	(set! extra (vector-ref extra_lbits code))
+	(when (not (= extra 0))
+	  (set! lc (- lc (vector-ref base_length code)))
+	  (send_bits lc extra))        ;; /* send the extra length bits */
+	(set! dist (vector-ref d_buf dx))
+	(set! dx (add1 dx))
+
+	;; /* Here, dist is the match distance - 1 */
+	(set! code (d_code dist))
+	(Assert 
+	 (unless (< code D_CODES)
+	   (error "bad d_code")))
+
+	(send_code code dtree)       ;; /* send the distance code */
+	(set! extra (vector-ref extra_dbits code))
+	(when (not (= extra 0))
+	  (set! dist (- dist (vector-ref base_dist code)))
+	  (send_bits dist extra))])   ;; /* send the extra distance bits */
+      ;; /* literal or match pair ? */
+      (set! flag (>> flag 1))
+      (when (< lx last_lit)
+	(loop))))
+
+  (send_code END_BLOCK ltree))
+
+#|
+/* bits.c -- output variable-length bit strings
+ * Copyright (C) 1992-1993 Jean-loup Gailly
+ * This is free software; you can redistribute it and/or modify it under the
+ * terms of the GNU General Public License, see the file COPYING.
+ */
+
+
+/*
+ *  PURPOSE
+ *
+ *      Output variable-length bit strings. Compression can be done
+ *      to a file or to memory. (The latter is not supported in this version.)
+ *
+ *  DISCUSSION
+ *
+ *      The PKZIP "deflate" file format interprets compressed file data
+ *      as a sequence of bits.  Multi-bit strings in the file may cross
+ *      byte boundaries without restriction.
+ *
+ *      The first bit of each byte is the low-order bit.
+ *
+ *      The routines in this file allow a variable-length bit value to
+ *      be output right-to-left (useful for literal values). For
+ *      left-to-right output (useful for code strings from the tree routines),
+ *      the bits must have been reversed first with bi_reverse().
+ *
+ *      For in-memory compression, the compressed bit stream goes directly
+ *      into the requested output buffer. The input data is read in blocks
+ *      by the mem_read() function. The buffer is limited to 64K on 16 bit
+ *      machines.
+ *
+ *  INTERFACE
+ *
+ *      void bi_init (FILE *zipfile)
+ *          Initialize the bit string routines.
+ *
+ *      void send_bits (int value, int length)
+ *          Write out a bit string, taking the source bits right to
+ *          left.
+ *
+ *      int bi_reverse (int value, int length)
+ *          Reverse the bits of a bit string, taking the source bits left to
+ *          right and emitting them right to left.
+ *
+ *      void bi_windup (void)
+ *          Write out any remaining bits in an incomplete byte.
+ *
+ *      void copy_block(char *buf, unsigned len, int header)
+ *          Copy a stored block to the zip file, storing first the length and
+ *          its one's complement if requested.
+ *
+ */
+|#
+
+(define bytes_in 0)
+
+(define bi_buf 0)
+;; /* Output buffer. bits are inserted starting at the bottom (least significant
+;;  * bits).
+;;  */
+
+(define Buf_size (* 8 2))
+;; /* Number of bits used within bi_buf. (bi_buf might be implemented on
+;;  * more than 16 bits on some systems.)
+;;  */
+
+(define bi_valid 0)
+;; /* Number of valid bits in bi_buf.  All bits above the last valid bit
+;;  * are always zero.
+;;  */
+
+;; /* ===========================================================================
+;;  * Initialize the bit string routines.
+;;  */
+(define (bi_init)
+  (set! bi_buf 0)
+  (set! bi_valid 0)
+  (set! bits_sent 0))
+
+
+;; /* ===========================================================================
+;;  * Send a value on a given number of bits.
+;;  * IN assertion: length <= 16 and value fits in length bits.
+;;  */
+(define (send_bits value length)
+  ;; int value;  /* value to send */
+  ;; int length; /* number of bits */
+
+  (DEBUG (Tracev stderr " l ~a v ~x " length value))
+  (Assert
+   (unless (and (> length 0) (<= length 15))
+     (error "invalid length")))
+  (set! bits_sent (+ bits_sent length))
+
+  ;; /* If not enough room in bi_buf, use (valid) bits from bi_buf and
+  ;;  * (16 - bi_valid) bits from value, leaving (width - (16-bi_valid))
+  ;;  * unused bits in value.
+  ;;  */
+  (if (> bi_valid (- Buf_size length))
+      (begin
+        (set! bi_buf (bitwise-ior bi_buf (<< value bi_valid)))
+        (put_short bi_buf)
+        (set! bi_buf (>> value (- Buf_size bi_valid)))
+        (set! bi_valid (+ bi_valid (- length Buf_size))))
+      (begin
+        (set! bi_buf (bitwise-ior bi_buf (<< value bi_valid)))
+        (set! bi_valid (+ bi_valid length)))))
+
+;; /* ===========================================================================
+;;  * Reverse the first len bits of a code, using straightforward code (a faster
+;;  * method would use a table)
+;;  * IN assertion: 1 <= len <= 15
+;;  */
+(define (bi_reverse code len)
+  ;; unsigned code; /* the value to invert */
+  ;; int len;       /* its bit length */
+
+  (let loop ([res 0][code code][len len])
+    (let ([res (<< (bitwise-ior res (bitwise-and code 1)) 1)])
+      (if (> len 1)
+	  (loop res (>> code 1) (sub1 len))
+	  (>> res 1)))))
+
+;; /* ===========================================================================
+;;  * Write out any remaining bits in an incomplete byte.
+;;  */
+(define (bi_windup)
+  (cond
+   [(> bi_valid 8)
+    (put_short bi_buf)]
+   [(> bi_valid 0)
+    (put_byte bi_buf)])
+  (set! bi_buf 0)
+  (set! bi_valid 0)
+  (set! bits_sent (bitwise-and (+ bits_sent 7) (bitwise-not 7))))
+
+;; /* ===========================================================================
+;;  * Run a set of bytes through the crc shift register.  If s is a NULL
+;;  * pointer, then initialize the crc shift register contents instead.
+;;  */
+(define crc 0)
+(define (updcrc s n)
+  ;; uch *s;                 /* pointer to bytes to pump through */
+  ;; unsigned n;             /* number of bytes in s[] */
+
+  (if s
+      (let loop ([c crc][p 0])
+	(if (= p n)
+	    (set! crc c)
+	    (loop (bitwise-xor
+		   (vector-ref crc_32_tab
+			       (bitwise-and
+				(bitwise-xor c (vector-ref window-vec (+ s p)))
+				#xff))
+		   (arithmetic-shift c -8))
+		  (add1 p))))
+      (set! crc #xffffffff)))
+
+(define crc_32_tab
+   #(#x00000000 
+     #x77073096 #xee0e612c #x990951ba #x076dc419
+     #x706af48f #xe963a535 #x9e6495a3 #x0edb8832 #x79dcb8a4
+     #xe0d5e91e #x97d2d988 #x09b64c2b #x7eb17cbd #xe7b82d07
+     #x90bf1d91 #x1db71064 #x6ab020f2 #xf3b97148 #x84be41de
+     #x1adad47d #x6ddde4eb #xf4d4b551 #x83d385c7 #x136c9856
+     #x646ba8c0 #xfd62f97a #x8a65c9ec #x14015c4f #x63066cd9
+     #xfa0f3d63 #x8d080df5 #x3b6e20c8 #x4c69105e #xd56041e4
+     #xa2677172 #x3c03e4d1 #x4b04d447 #xd20d85fd #xa50ab56b
+     #x35b5a8fa #x42b2986c #xdbbbc9d6 #xacbcf940 #x32d86ce3
+     #x45df5c75 #xdcd60dcf #xabd13d59 #x26d930ac #x51de003a
+     #xc8d75180 #xbfd06116 #x21b4f4b5 #x56b3c423 #xcfba9599
+     #xb8bda50f #x2802b89e #x5f058808 #xc60cd9b2 #xb10be924
+     #x2f6f7c87 #x58684c11 #xc1611dab #xb6662d3d #x76dc4190
+     #x01db7106 #x98d220bc #xefd5102a #x71b18589 #x06b6b51f
+     #x9fbfe4a5 #xe8b8d433 #x7807c9a2 #x0f00f934 #x9609a88e
+     #xe10e9818 #x7f6a0dbb #x086d3d2d #x91646c97 #xe6635c01
+     #x6b6b51f4 #x1c6c6162 #x856530d8 #xf262004e #x6c0695ed
+     #x1b01a57b #x8208f4c1 #xf50fc457 #x65b0d9c6 #x12b7e950
+     #x8bbeb8ea #xfcb9887c #x62dd1ddf #x15da2d49 #x8cd37cf3
+     #xfbd44c65 #x4db26158 #x3ab551ce #xa3bc0074 #xd4bb30e2
+     #x4adfa541 #x3dd895d7 #xa4d1c46d #xd3d6f4fb #x4369e96a
+     #x346ed9fc #xad678846 #xda60b8d0 #x44042d73 #x33031de5
+     #xaa0a4c5f #xdd0d7cc9 #x5005713c #x270241aa #xbe0b1010
+     #xc90c2086 #x5768b525 #x206f85b3 #xb966d409 #xce61e49f
+     #x5edef90e #x29d9c998 #xb0d09822 #xc7d7a8b4 #x59b33d17
+     #x2eb40d81 #xb7bd5c3b #xc0ba6cad #xedb88320 #x9abfb3b6
+     #x03b6e20c #x74b1d29a #xead54739 #x9dd277af #x04db2615
+     #x73dc1683 #xe3630b12 #x94643b84 #x0d6d6a3e #x7a6a5aa8
+     #xe40ecf0b #x9309ff9d #x0a00ae27 #x7d079eb1 #xf00f9344
+     #x8708a3d2 #x1e01f268 #x6906c2fe #xf762575d #x806567cb
+     #x196c3671 #x6e6b06e7 #xfed41b76 #x89d32be0 #x10da7a5a
+     #x67dd4acc #xf9b9df6f #x8ebeeff9 #x17b7be43 #x60b08ed5
+     #xd6d6a3e8 #xa1d1937e #x38d8c2c4 #x4fdff252 #xd1bb67f1
+     #xa6bc5767 #x3fb506dd #x48b2364b #xd80d2bda #xaf0a1b4c
+     #x36034af6 #x41047a60 #xdf60efc3 #xa867df55 #x316e8eef
+     #x4669be79 #xcb61b38c #xbc66831a #x256fd2a0 #x5268e236
+     #xcc0c7795 #xbb0b4703 #x220216b9 #x5505262f #xc5ba3bbe
+     #xb2bd0b28 #x2bb45a92 #x5cb36a04 #xc2d7ffa7 #xb5d0cf31
+     #x2cd99e8b #x5bdeae1d #x9b64c2b0 #xec63f226 #x756aa39c
+     #x026d930a #x9c0906a9 #xeb0e363f #x72076785 #x05005713
+     #x95bf4a82 #xe2b87a14 #x7bb12bae #x0cb61b38 #x92d28e9b
+     #xe5d5be0d #x7cdcefb7 #x0bdbdf21 #x86d3d2d4 #xf1d4e242
+     #x68ddb3f8 #x1fda836e #x81be16cd #xf6b9265b #x6fb077e1
+     #x18b74777 #x88085ae6 #xff0f6a70 #x66063bca #x11010b5c
+     #x8f659eff #xf862ae69 #x616bffd3 #x166ccf45 #xa00ae278
+     #xd70dd2ee #x4e048354 #x3903b3c2 #xa7672661 #xd06016f7
+     #x4969474d #x3e6e77db #xaed16a4a #xd9d65adc #x40df0b66
+     #x37d83bf0 #xa9bcae53 #xdebb9ec5 #x47b2cf7f #x30b5ffe9
+     #xbdbdf21c #xcabac28a #x53b39330 #x24b4a3a6 #xbad03605
+     #xcdd70693 #x54de5729 #x23d967bf #xb3667a2e #xc4614ab8
+     #x5d681b02 #x2a6f2b94 #xb40bbe37 #xc30c8ea1 #x5a05df1b
+     #x2d02ef8d))
+
+;; /* ===========================================================================
+;;  * Copy a stored block to the zip file, storing first the length and its
+;;  * one's complement if requested.
+;; */
+(define (copy_block buf len header)
+  ;; char     *buf;    /* the input data */
+  ;; unsigned len;     /* its length */
+  ;; int      header;  /* true if block header must be written */
+
+  (bi_windup);; /* align on byte boundary */
+
+  (when header
+    (put_short len)
+    (put_short (bitwise-not len))
+    (set! bits_sent (+ bits_sent (* 2 16))))
+
+  (set! bits_sent (+ bits_sent (<< len 3)))
+
+  (let loop ([len len][pos 0])
+    (unless (zero? len)
+      (put_byte (gzvector-ref buf pos))
+      (loop (sub1 len) (add1 pos)))))
+
+;; /* ===========================================================================
+;;  * Read a new buffer from the current input file, perform end-of-line
+;;  * translation, and update the crc and input file size.
+;;  * IN assertion: size >= 2 (for end-of-line translation)
+;;  */
+(define (read_buf startpos size)
+  ;; char *buf;
+  ;; unsigned size;
+
+  ;; Assert
+  ;; (unless (= insize 0)
+  ;;   (error "inbuf not empty"))
+
+  (let* ([s (read-bytes size ifd)]
+	 [len (if (eof-object? s)
+		  EOF-const
+		  (bytes-length s))])
+    (when (positive? len)
+      (let rloop ([p 0])
+	(unless (= p len)
+	  (vector-set! window-vec (+ p startpos) (bytes-ref s p))
+	  (rloop (add1 p))))
+
+      (updcrc startpos len)
+      (set! bytes_in (+ bytes_in len)))
+
+    len))
+
+(define (put_byte c)
+  (bytes-set! outbuf outcnt (bitwise-and #xFF c))
+  (set! outcnt (add1 outcnt))
+  (when (= outcnt OUTBUFSIZ)
+    (flush_outbuf)))
+
+;; /* Output a 16 bit value, lsb first */
+(define (put_short w)
+  (if (< outcnt (- OUTBUFSIZ 2))
+      (begin
+	(bytes-set! outbuf outcnt (bitwise-and #xFF w))
+	(bytes-set! outbuf (add1 outcnt) (bitwise-and #xFF (>> w 8)))
+	(set! outcnt (+ outcnt 2)))
+      (begin
+	(put_byte w)
+	(put_byte (>> w 8)))))
+
+;; /* Output a 32 bit value to the bit stream, lsb first */
+(define (put_long n)
+  (put_short n)
+  (put_short (>> n 16)))
+
+(define outcnt 0)
+(define bytes_out 0)
+(define outbuf (make-bytes OUTBUFSIZ))
+
+;; /* ===========================================================================
+;;  * Write the output buffer outbuf[0..outcnt-1] and update bytes_out.
+;;  * (used for the compressed data only)
+;;  */
+(define (flush_outbuf)
+  (unless (= outcnt 0)
+
+    (write-bytes outbuf ofd 0 outcnt)
+
+    (set! bytes_out (+ bytes_out outcnt))
+    (set! outcnt 0)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define ifd #f)
+(define ofd #f)
+
+(define (deflate-inner in out)
+  (do-deflate))
+  
+(define (deflate in out)
+
+  (set! bytes_in 0)
+
+  (set! ifd in)
+  (set! ofd out)
+  (set! outcnt 0)
+
+  (bi_init)
+  (ct_init)
+  (lm_init LEVEL)
+  
+  (deflate-inner in out)
+
+  (flush_outbuf)
+
+  (values bytes_in bytes_out crc))
+
+(define (gzip-through-ports in out origname time_stamp)
+  
+  (define flags (if origname #x8 0)) ;; /* general purpose bit flags */
+
+  (set! bytes_in 0)
+
+  (set! ifd in)
+  (set! ofd out)
+  (set! outcnt 0)
+
+  ;; /* Write the header to the gzip file. See algorithm.doc for the format */
+  (put_byte #o037) ;; /* magic header */
+  (put_byte #o213)
+  (put_byte 8) ;; /* compression method */
+
+  (put_byte flags);; /* general flags */
+  (put_long time_stamp);
+
+  ;; /* Write deflated file to zip file */
+  (updcrc #f 0)
+
+  (bi_init)
+  (ct_init)
+  
+  (put_byte (lm_init LEVEL));; /* extra flags */
+  (put_byte 3) ;; /* OS identifier */
+  
+  (when origname
+    (for-each put_byte (map char->integer (string->list origname)))
+    (put_byte 0))
+  
+  (do-deflate)
+  
+  ;; /* Write the crc and uncompressed size */
+  (put_long (bitwise-xor crc #xffffffff))
+  (put_long bytes_in)
+  
+  (flush_outbuf))
+
+(define (gzip infile outfile)
+  (let ([i (open-input-file infile)])
+    (dynamic-wind
+     void
+     (lambda ()
+       (let ([o (open-output-file outfile 'truncate/replace)])
+	 (dynamic-wind
+	  void
+	  (lambda ()
+	    (let ([name (with-handlers ([exn:fail? (lambda (x) #f)])
+			  (let-values ([(base name dir?) (split-path infile)])
+			    name))]
+		  [timestamp (with-handlers ([exn:fail:filesystem? (lambda (x) 0)])
+			       (file-or-directory-modify-seconds infile))])
+	      (gzip-through-ports i o name timestamp)))
+	  (lambda () (close-output-port o)))))
+     (lambda () (close-input-port i)))))
+
+(list gzip gzip-through-ports deflate)))
+
+(define gzip
+  (case-lambda
+   [(infile) (gzip infile (string-append infile ".gz"))]
+   [(infile outfile) ((car (invoke-unit code)) infile outfile)]))
+
+(define (gzip-through-ports in out origname time_stamp)
+  ((cadr (invoke-unit code)) in out origname time_stamp))
+
+(define (deflate in out)
+  ((caddr (invoke-unit code)) in out))
+
+)
diff --git a/collects/mzlib/defmacro.ss b/collects/mzlib/defmacro.ss
new file mode 100644
index 0000000000..fb9d4f7a9c
--- /dev/null
+++ b/collects/mzlib/defmacro.ss
@@ -0,0 +1,72 @@
+
+(module defmacro mzscheme
+  (require-for-syntax (lib "stx.ss" "syntax")
+		      "private/dmhelp.ss")
+
+  (provide define-macro
+	   defmacro)
+
+  (define-syntax define-macro
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ (name . args) proc0 proc ...)
+	 (begin
+	   (unless (identifier? (syntax name))
+	     (raise-syntax-error
+	      #f
+	      "expected an identifier for the macro name"
+	      stx
+	      (syntax name)))
+	   (let loop ([args (syntax args)])
+	     (cond
+	      [(stx-null? args) 'ok]
+	      [(identifier? args) 'ok]
+	      [(stx-pair? args)
+	       (unless (identifier? (stx-car args))
+		 (raise-syntax-error
+		  #f
+		  "expected an identifier for a macro argument"
+		  stx
+		  (stx-car args)))
+	       (loop (stx-cdr args))]
+	      [else (raise-syntax-error
+		     #f
+		     "not a valid argument sequence after the macro name"
+		     stx)]))
+	   (syntax
+	    (define-macro name (lambda args proc0 proc ...))))]
+	[(_ name proc)
+	 (begin
+	   (unless (identifier? (syntax name))
+	     (raise-syntax-error
+	      #f
+	      "expected an identifier for the macro name"
+	      stx
+	      (syntax name)))
+	   (syntax
+	    (define-syntax name
+	      (let ([p proc])
+		(unless (procedure? p)
+		  (raise-type-error 
+		   'define-macro 
+		   "procedure (arity 1)"
+		   p))
+		(lambda (stx)
+		  (let ([l (syntax->list stx)])
+		    (unless (and l (procedure-arity-includes? p (sub1 (length l))))
+		      (raise-syntax-error
+		       #f
+		       "bad form"
+		       stx))
+		    (let ([ht (make-hash-table)])
+		      (datum->syntax-object 
+		       stx
+		       (dm-subst
+			ht
+			(apply proc (cdr (dm-syntax->datum stx ht))))
+		       stx))))))))])))
+
+  (define-syntax defmacro
+    (syntax-rules ()
+	[(_ name formals body1 body ...)
+	 (define-macro (name . formals) body1 body ...)])))
diff --git a/collects/mzlib/etc.ss b/collects/mzlib/etc.ss
new file mode 100644
index 0000000000..27556fcc4b
--- /dev/null
+++ b/collects/mzlib/etc.ss
@@ -0,0 +1,582 @@
+
+(module etc mzscheme
+  
+  (require "spidey.ss"
+           (lib "plthome.ss" "setup"))
+  
+  (require-for-syntax (lib "kerncase.ss" "syntax")
+		      (lib "stx.ss" "syntax")
+		      (lib "name.ss" "syntax")
+		      (lib "context.ss" "syntax")
+                      (lib "plthome.ss" "setup")
+                      "list.ss"
+                      "private/stxset.ss")
+
+  
+  (provide true false
+	   boolean=? symbol=?
+	   identity
+	   compose
+	   
+	   build-string
+	   build-vector
+	   build-list
+	   
+	   loop-until
+	   
+           opt-lambda
+           
+	   local
+	   recur
+	   rec
+	   evcase
+	   nor
+	   nand
+	   let+
+
+	   namespace-defined?
+	   this-expression-source-directory
+           this-expression-file-name
+	   define-syntax-set
+           
+           hash-table
+
+	   begin-with-definitions
+
+	   begin-lifted)
+  
+  (define true #t)
+  (define false #f)
+  
+  (define identity (polymorphic (lambda (x) x)))
+  
+  (define compose
+    (polymorphic
+     (case-lambda 
+      [(f) (if (procedure? f) f (raise-type-error 'compose "procedure" f))]
+      [(f g)
+       (let ([f (compose f)]
+             [g (compose g)])
+         (if (eqv? 1 (procedure-arity f)) ; optimize: don't use call-w-values
+             (if (eqv? 1 (procedure-arity g)) ; optimize: single arity everywhere
+                 (lambda (x) (f (g x)))
+                 (lambda args (f (apply g args))))
+             (if (eqv? 1 (procedure-arity g)) ; optimize: single input
+                 (lambda (a)
+                   (call-with-values
+                    (lambda () (g a))
+                    f))
+                 (lambda args
+                   (call-with-values
+                    (lambda () (apply g args))
+                    f)))))]
+      [(f . more)
+       (let ([m (apply compose more)])
+         (compose f m))])))
+  
+
+  (define  build-string
+    (lambda  (n  fcn)
+      (unless  (and (integer? n) (exact? n) (>= n 0))
+        (error  'build-string  "~s must be an exact integer >= 0"  n))
+      (unless  (procedure? fcn)
+        (error  'build-string  "~s must be a procedure"  fcn))
+      (let  ((str  (make-string n)))
+        (let  loop  ((i  0))
+          (if (= i n)  
+              str
+              (begin
+                (string-set!  str  i  (fcn i))
+                (loop  (add1 i))))))))
+  
+  ;; (build-vector n f) returns a vector 0..n-1 where the ith element is (f i).
+  ;; The eval order is guaranteed to be: 0, 1, 2, ..., n-1.
+  ;; eg: (build-vector 4 (lambda (i) i)) ==> #4(0 1 2 3)
+  
+  (define  build-vector
+    (polymorphic
+     (lambda  (n  fcn)
+       (unless  (and (integer? n) (exact? n) (>= n 0))
+         (error  'build-vector  "~s must be an exact integer >= 0"  n))
+       (unless  (procedure? fcn)
+         (error  'build-vector  "~s must be a procedure"  fcn))
+       (let  ((vec  (make-vector n)))
+         (let  loop  ((i  0))
+           (if  (= i n)  vec
+                (begin
+                  (vector-set!  vec  i  (fcn i))
+                  (loop  (add1 i)))))))))
+  
+  (define  build-list
+    (polymorphic
+     (lambda  (n  fcn)
+       (unless  (and (integer? n) (exact? n) (>= n 0))
+         (error  'build-list  "~s must be an exact integer >= 0"  n))
+       (unless  (procedure? fcn)
+         (error  'build-list  "~s must be a procedure"  fcn))
+       (if  (zero? n)  '()
+            (let  ([head  (list (fcn 0))])
+              (let  loop  ([i 1]  [p head])
+                (if  (= i n)  head
+                     (begin
+                       (set-cdr!  p  (list (fcn i)))
+                       (loop  (add1 i)  (cdr p))))))))))
+  
+  (define loop-until
+    (polymorphic
+     (lambda (start done? next body)
+       (let loop ([i start])
+         (unless (done? i)
+           (body i)
+           (loop (next i)))))))
+  
+  (define boolean=?
+    (lambda (x y)
+      (unless (and (boolean? x)
+                   (boolean? y))
+        (raise-type-error 'boolean=? 
+                          "boolean"
+                          (if (boolean? x) y x)))
+      (eq? x y)))
+  
+  (define (symbol=? x y)
+    (unless (and (symbol? x)
+		 (symbol? y))
+      (raise-type-error 'symbol=? "symbol"
+			(if (symbol? x) y x)))
+    (eq? x y))
+
+ (define-syntax opt-lambda 
+   (lambda (stx)
+     (with-syntax ([name (or (syntax-local-infer-name stx)
+			     (quote-syntax opt-lambda-proc))])
+       (syntax-case stx ()
+	 [(_ args body1 body ...)
+	  (let ([clauses (let loop ([pre-args null]
+				    [args (syntax args)]
+				    [needs-default? #f])
+			   (syntax-case args ()
+			     [id
+			      (identifier? (syntax id))
+			      (with-syntax ([(pre-arg ...) pre-args])
+				(syntax ([(pre-arg ... . id)
+					  body1 body ...])))]
+                             [()
+			      (with-syntax ([(pre-arg ...) pre-args])
+				(syntax ([(pre-arg ...)
+					  body1 body ...])))]
+			     [(id . rest)
+			      (identifier? (syntax id))
+			      (begin
+				(when needs-default?
+				  (raise-syntax-error
+				   #f
+				   "default value missing"
+				   stx
+				   (syntax id)))
+				(loop (append pre-args (list (syntax id)))
+				      (syntax rest)
+				      #f))]
+			     [([id default] . rest)
+			      (identifier? (syntax id))
+                              (with-syntax ([rest (loop (append pre-args (list (syntax id)))
+                                                        (syntax rest)
+                                                        #t)]
+                                            [(pre-arg ...) pre-args])
+                                (syntax ([(pre-arg ...) (name pre-arg ... default)]
+                                         . rest)))]
+			     [(bad . rest)
+			      (raise-syntax-error
+			       #f
+			       "not an identifier or identifier with default"
+			       stx
+			       (syntax bad))]
+			     [else
+			      (raise-syntax-error
+			       #f
+			       "bad identifier sequence"
+			       stx
+			       (syntax args))]))])
+            (with-syntax ([clauses clauses])
+              (syntax/loc stx
+                          (letrec ([name
+                                    (case-lambda
+                                     . clauses)])
+                            name))))]))))
+ 
+ (define-syntax local 
+   (lambda (stx)
+     (syntax-case stx ()
+       [(_ (defn ...) body1 body ...)
+	(let ([defs (let ([expand-context (generate-expand-context)])
+		      (let loop ([defns (syntax->list (syntax (defn ...)))])
+			(apply
+			 append
+			 (map
+			  (lambda (defn)
+			    (let ([d (local-expand
+				      defn
+				      expand-context
+				      (kernel-form-identifier-list 
+				       (quote-syntax here)))]
+				  [check-ids (lambda (ids)
+					       (for-each
+						(lambda (id)
+						  (unless (identifier? id)
+						    (raise-syntax-error
+						     #f
+						     "not an identifier for definition"
+						     stx
+						     id)))
+						ids))])
+			      (syntax-case d (define-values define-syntaxes begin)
+				[(begin defn ...)
+				 (loop (syntax->list (syntax (defn ...))))]
+				[(define-values (id ...) body)
+				 (begin
+				   (check-ids (syntax->list (syntax (id ...))))
+				   (list d))]
+				[(define-values . rest)
+				 (raise-syntax-error
+				  #f
+				  "ill-formed definition"
+				  stx
+				  d)]
+				[(define-syntaxes (id ...) body)
+				 (begin
+				   (check-ids (syntax->list (syntax (id ...))))
+				   (list d))]
+				[(define-syntaxes . rest)
+				 (raise-syntax-error
+				  #f
+				  "ill-formed definition"
+				  stx
+				  d)]
+				[_else
+				 (raise-syntax-error
+				  #f
+				  "not a definition"
+				  stx
+				  defn)])))
+			  defns))))])
+	  (let ([ids (apply append
+			    (map
+			     (lambda (d)
+			       (syntax-case d ()
+				 [(_ ids . __)
+				  (syntax->list (syntax ids))]))
+			     defs))])
+	    (let ([dup (check-duplicate-identifier ids)])
+	      (when dup
+		(raise-syntax-error
+		 #f
+		 "duplicate identifier"
+		 stx
+		 dup)))
+	    (with-syntax ([(def ...) defs])
+	      (syntax/loc
+	       stx
+	       (let ()
+		 def ...
+		 (let ()
+		   body1
+		   body ...))))))]
+       [(_ x body1 body ...)
+	(raise-syntax-error
+	 #f
+	 "not a definition sequence"
+	 stx
+	 (syntax x))])))
+
+ ;; recur is another name for 'let' in a named let
+ (define-syntax recur 
+   (lambda (stx)
+     (syntax-case stx ()
+       [(_ . rest)
+	(syntax/loc stx (let . rest))])))
+
+ ;; define a recursive value
+ (define-syntax rec
+   (lambda (stx)
+     (syntax-case stx ()
+       [(_ name expr)
+	(begin
+	  (unless (identifier? (syntax name))
+	    (raise-syntax-error
+	     #f
+	     "not an identifier"
+	     stx
+	     (syntax name)))
+	  (syntax/loc stx
+	      (letrec ([name expr])
+		name)))])))
+
+ (define-syntax evcase 
+   (lambda (stx)
+     (syntax-case stx ()
+       [(_ val [test body ...] ...)
+	(let ([tests (syntax->list (syntax (test ...)))])
+	  (with-syntax ([(a-test ...)
+			 (map
+			  (lambda (t)
+			    (syntax-case t (else)
+			      [else (syntax #t)]
+			      [_else (with-syntax ([t t])
+				       (syntax (eqv? evcase-v t)))]))
+			  tests)])
+	    ;; Make sure else is last:
+	    (unless (null? tests)
+	      (let loop ([tests tests])
+		(unless (null? (cdr tests))
+		  (when (and (identifier? (car tests))
+			     (module-identifier=? (quote-syntax else) (car tests)))
+		    (raise-syntax-error
+		     #f
+		     "else is not in last clause"
+		     stx
+		     (car tests)))
+		  (loop (cdr tests)))))
+	    (syntax/loc stx
+	      (let ([evcase-v val])
+		(cond
+		 [a-test
+		  (begin body ...)]
+		 ...)))))]
+       [(_ val something ...)
+	;; Provide a good error message:
+	(for-each
+	 (lambda (s)
+	   (syntax-case s ()
+	     [(t a ...)
+	      (raise-syntax-error
+	       #f
+	       "invalid clause"
+	       stx
+	       s)]))
+	 (syntax->list (syntax (something ...))))])))
+       
+ (define-syntax nor
+   (lambda (stx)
+     (syntax-case stx ()
+       [(_ expr ...)
+	(syntax/loc stx (not (or expr ...)))])))
+ 
+ (define-syntax nand
+   (lambda (stx)
+     (syntax-case stx ()
+       [(_ expr ...)
+	(syntax/loc stx (not (and expr ...)))])))
+
+ (define-syntax let+
+   (lambda (stx)
+     (syntax-case stx ()
+       [(_ [clause ...] body1 body ...)
+	(let ([clauses (syntax->list (syntax (clause ...)))]
+	      [bad (lambda (c n)
+		     (raise-syntax-error
+		      #f
+		      (format "illegal use of ~a for a clause" n)
+		      stx
+		      c))]
+	      [var? (lambda (x)
+		      (or (identifier? x)
+			  (let ([l (syntax->list x)])
+			    (and l
+				 (pair? l)
+				 (eq? (syntax-e (car l)) 'values)
+				 (andmap identifier? (cdr l))))))]
+	      [normal-var (lambda (x)
+			    (if (identifier? x)
+				(list x)
+				(cdr (syntax-e x))))])
+	  ;; syntax checks
+	  (for-each
+	   (lambda (clause)
+	     (syntax-case* clause (val rec vals recs _) (lambda (a b) 
+							  (eq? (syntax-e b) 
+							       (syntax-e a)))
+	       [(val var expr)
+		(var? (syntax var))
+		'ok]
+	       [(rec var expr)
+		(var? (syntax var))
+		'ok]
+	       [(vals (var expr) ...)
+		(andmap var? (syntax->list (syntax (var ...))))
+		'ok]
+	       [(recs (var expr) ...)
+		(andmap var? (syntax->list (syntax (var ...))))
+		'ok]
+	       [(_ expr0 expr ...)
+		'ok]
+	       [(val . __) (bad clause "val")]
+	       [(rec . __) (bad clause "rec")]
+	       [(vals . __) (bad clause "vals")]
+	       [(recs . __) (bad  clause"recs")]
+	       [(_ . __) (bad clause "_")]
+	       [_else (raise-syntax-error #f "bad clause" stx clause)]))
+	   clauses)
+	  ;; result
+	(let loop ([clauses clauses])
+	  (if (null? clauses)
+	      (syntax (let () body1 body ...))
+	      (with-syntax ([rest (loop (cdr clauses))])
+		(syntax-case* (car clauses) (val rec vals recs _)  (lambda (a b) 
+								     (eq? (syntax-e b) 
+									  (syntax-e a)))
+		  [(val var expr)
+		   (with-syntax ([vars (normal-var (syntax var))])
+		     (syntax (let-values ([vars expr]) rest)))]
+		  [(rec var expr)
+		   (with-syntax ([vars (normal-var (syntax var))])
+		     (syntax (letrec-values ([vars expr]) rest)))]
+		  [(vals (var expr) ...)
+		   (with-syntax ([(vars ...) (map normal-var (syntax->list (syntax (var ...))))])
+		     (syntax (let-values ([vars expr] ...) rest)))]
+		  [(recs (var expr) ...)
+		   (with-syntax ([(vars ...) (map normal-var (syntax->list (syntax (var ...))))])
+		     (syntax (letrec-values ([vars expr] ...) rest)))]
+		  [(_ expr0 expr ...)
+		   (syntax (begin expr0 expr ... rest))])))))])))
+
+ (define ns-undefined (gensym))
+
+ (define (namespace-defined? n)
+   (unless (symbol? n)
+     (raise-type-error 'namespace-defined? "symbol" n))
+   (not (eq? (namespace-variable-value n #t (lambda () ns-undefined)) ns-undefined)))
+
+ (define-syntax (this-expression-source-directory stx)
+   (syntax-case stx ()
+     [(_)
+      (let* ([source (syntax-source stx)]
+             [source (and (path? source) source)]
+             [local (or (current-load-relative-directory) (current-directory))]
+	     [dir (plthome-ify
+                   (or (and source (file-exists? source)
+                            (let-values ([(base file dir?) (split-path source)])
+                              (and (path? base)
+                                   (path->complete-path base local))))
+                       local))])
+        (if (and (pair? dir) (eq? 'plthome (car dir)))
+          (with-syntax ([d dir])
+            #'(un-plthome-ify 'd))
+          (with-syntax ([d (if (bytes? dir) dir (path->bytes dir))])
+            #'(bytes->path d))))]))
+
+ (define-syntax (this-expression-file-name stx)
+   (syntax-case stx ()
+     [(_)
+      (let* ([f (syntax-source stx)]
+             [f (and f (path? f) (file-exists? f)
+                     (let-values ([(base file dir?) (split-path f)]) file))])
+        (if f
+          (with-syntax ([f (path->bytes f)]) #'(bytes->path f))
+          #'#f))]))
+
+ ;; This is a macro-generating macro that wants to expand
+ ;; expressions used in the generated macro. So it's weird,
+ ;; and we put much of the work in a helper macro,
+ ;; `finish-syntax-set'.
+ (define-syntax (define-syntax-set stx)
+   (syntax-case stx ()
+     [(_ (id ...) defn ...)
+      (let ([ids (syntax->list (syntax (id ...)))])
+	;; Check ids ------------------------------
+	(for-each (lambda (id)
+		    (unless (identifier? id)
+		      (raise-syntax-error
+		       #f
+		       "not an identifier or two identifier in parentheses"
+		       stx
+		       id)))
+		  ids)
+	(let ([dup (check-duplicate-identifier ids)])
+	  (when dup
+	    (raise-syntax-error
+	     #f
+	     "duplicate identifier"
+	     stx
+	     dup)))
+
+	;; We'd like to check the `defns', but that requires
+	;; and expansion in a different phase. So we move
+	;; into that phase using `finish-syntax-set':
+	(with-syntax ([orig-stx stx])
+	  (syntax/loc stx
+	    (define-syntaxes (id ...)
+	      (finish-syntax-set orig-stx)))))]))
+
+  (define-syntax (hash-table stx)
+    (syntax-case stx (quote)
+      [(_ x ...)
+       (let loop ([xs #'(x ...)] [flags '()])
+         (syntax-case xs (quote)
+           [('flag x ...) (loop #'(x ...) (cons #''flag flags))]
+           [([key val] ...)
+            (with-syntax ([(flag ...) (reverse flags)])
+              (syntax/loc stx
+                (let ([ht (make-hash-table flag ...)])
+                  (hash-table-put! ht key val) ...
+                  ht)))]
+           [_else (raise-syntax-error 'hash-table "bad syntax" stx)]))]))
+
+  (define-syntax (begin-with-definitions stx)
+    ;; Body can have mixed exprs and defns. Wrap expressions with
+    ;; `(define-values () ... (values))' as needed, and add a (void)
+    ;; at the end if needed.
+    (let* ([ctx (generate-expand-context)]
+	   [kernel-forms (kernel-form-identifier-list #'here)]
+	   [init-exprs (let ([v (syntax->list stx)])
+			 (unless v
+			   (raise-syntax-error #f "bad syntax" stx))
+			 (cdr v))]
+	   [exprs (let loop ([exprs init-exprs])
+		    (apply 
+		     append
+		     (map (lambda (expr)
+			    (let ([expr (local-expand
+					 expr
+					 ctx
+					 kernel-forms)])
+			      (syntax-case expr (begin)
+				[(begin . rest)
+				 (loop (syntax->list #'rest))]
+				[else
+				 (list expr)])))
+			  exprs)))])
+      #`(let ()
+	  #,@(let loop ([exprs exprs][prev-defns null][prev-exprs null])
+	       (cond
+		[(null? exprs) (append 
+				(reverse prev-defns)
+				(reverse prev-exprs)
+				(if (null? prev-exprs)
+				    (list #'(void))
+				    null))]
+		[(and (stx-pair? (car exprs))
+		      (identifier? (stx-car (car exprs)))
+		      (or (module-identifier=? #'define-values (stx-car (car exprs)))
+			  (module-identifier=? #'define-syntaxes (stx-car (car exprs)))))
+		 (loop (cdr exprs)
+		       (cons (car exprs)
+			     (append
+			      (map (lambda (expr)
+				     #`(define-values () (begin #,expr (values))))
+				   prev-exprs)
+			      prev-defns))
+		       null)]
+		[else
+		 (loop (cdr exprs) prev-defns (cons (car exprs) prev-exprs))])))))
+
+  (define-syntax (begin-lifted stx)
+    (syntax-case stx ()
+      [(_ expr0 expr ...)
+       (let ([name (syntax-local-name)])
+	 (if name
+	     (with-syntax ([name name])
+	       (syntax-local-lift-expression 
+		#'(let ([name (begin expr0 expr ...)])
+		    name)))
+	     (syntax-local-lift-expression 
+	      #'(begin expr0 expr ...))))])))
diff --git a/collects/mzlib/file.ss b/collects/mzlib/file.ss
new file mode 100644
index 0000000000..786cdd2517
--- /dev/null
+++ b/collects/mzlib/file.ss
@@ -0,0 +1,517 @@
+(module file mzscheme
+  (provide find-relative-path
+	  explode-path
+	  normalize-path
+	  build-absolute-path
+	  build-relative-path
+	  filename-extension
+	  file-name-from-path
+	  path-only
+	  delete-directory/files
+	  copy-directory/files
+	  make-directory*
+	  make-temporary-file
+	  find-library
+
+	  get-preference
+	  put-preferences
+
+	  call-with-input-file*
+	  call-with-output-file*
+
+	  fold-files
+	  find-files)
+
+  (require "list.ss"
+	   "etc.ss")
+
+  (define build-relative-path
+    (lambda (p . args)
+      (if (relative-path? p)
+	  (apply build-path p args)
+	  (error 'build-relative-path "base path ~s is absolute" p))))
+
+  (define build-absolute-path
+    (lambda (p . args)
+      (if (relative-path? p)
+	  (error 'build-absolute-path "base path ~s is relative" p)
+	  (apply build-path p args))))
+
+  ;; Note that normalize-path does not normalize the case
+  (define normalize-path
+    (letrec ([resolve-all
+	      (lambda (path wrt)
+		(let ([orig-path (if (and wrt (not (complete-path? path)))
+				     (path->complete-path path wrt)
+				     path)])
+		  (let loop ([full-path orig-path][seen-paths (list orig-path)])
+		    (let ([resolved (resolve-path full-path)])
+		      (if (equal? resolved full-path)
+			  (do-normalize-path resolved #f)
+			  (let ([path (if (relative-path? resolved)
+					  (build-path
+					   (let-values ([(base name dir?) (split-path full-path)])
+					     base)
+					   resolved)
+					  resolved)])
+			    (if (member path seen-paths)
+				(error 'normalize-path "circular reference at ~s" path)
+				(let ([spath
+				       ;; Use simplify-path to get rid of ..s, which can
+				       ;;  allow the path to grow indefinitely in a cycle.
+				       ;; An exception must mean a cycle of links.
+				       (with-handlers ([exn:fail:filesystem?
+							(lambda (x)
+							  (error 'normalize-path "circular reference at ~s" path))])
+					 (simplify-path path))])
+				  (loop spath (cons path seen-paths))))))))))]
+	     [resolve
+	      (lambda (path)
+		(if (equal? path (resolve-path path))
+		    path
+		    (resolve-all path #f)))]
+	     [normalize-path
+	      (case-lambda 
+	       [(orig-path) (do-normalize-path orig-path (current-directory))]
+	       [(orig-path wrt) 
+		(unless (complete-path? wrt)
+		  (raise-type-error 'normalize-path "complete path" wrt))
+		(do-normalize-path orig-path wrt)])]
+	     [error-not-a-dir
+	      (lambda (path)
+		(error 'normalize-path 
+		       "~s (within the input path) is not a directory or does not exist"
+		       path))]
+	     [do-normalize-path
+	      (lambda (orig-path wrt)
+		(let normalize ([path (expand-path orig-path)])
+		  (let-values ([(base name dir?) (split-path path)])
+		    (cond
+		     [(eq? name 'up)
+		      (let up ([base (if (eq? base 'relative)
+					 wrt
+					 (resolve-all base wrt))])
+			(if (directory-exists? base)
+			    (let-values ([(prev name dir?) (split-path base)])
+			      (cond
+			       [(not prev) 
+				(error 'normalize-path
+				       "root has no parent directory: ~s"
+				       orig-path)]
+			       [else
+				(let ([prev
+				       (if (eq? prev 'relative)
+					   wrt
+					   (normalize prev))])
+				  (cond
+				   [(eq? name 'same) (up prev)]
+				   [(eq? name 'up) (up (up prev))]
+				   [else prev]))]))
+			    (error-not-a-dir base)))]
+		     [(eq? name 'same)
+		      (cond
+		       [(eq? base 'relative) wrt]
+		       [else (let ([n (normalize base)])
+			       (if (directory-exists? n)
+				   n
+				   (error-not-a-dir n)))])]
+		     [else
+		      (cond
+		       [(not base) (path->complete-path path)]
+		       [else (let* ([base (if (eq? base 'relative)
+					      (normalize wrt)
+					      (normalize base))]
+				    [path (if (directory-exists? base)
+					      (build-path base name)
+					      (error-not-a-dir base))]
+				    [resolved (expand-path (resolve path))])
+			       (cond
+				[(relative-path? resolved)
+				 (normalize (build-path base resolved))]
+				[(complete-path? resolved)
+				 resolved]
+				[else (path->complete-path resolved base)]))])]))))])
+      normalize-path))
+
+  ;; Argument must be in normal form
+  (define do-explode-path
+    (lambda (who orig-path)
+      (let loop ([path orig-path][rest '()])
+	(let-values ([(base name dir?) (split-path path)])
+	  (when (or (and base
+			 (not (path? base)))
+		    (not (path? name)))
+	    (raise-type-error who "path in normal form" orig-path))
+	  (if base
+	      (loop base (cons name rest))
+	      (cons name rest))))))
+
+  (define explode-path
+    (lambda (orig-path)
+      (unless (path-string? orig-path)
+	(raise-type-error 'explode-path "path or string" orig-path))
+      (do-explode-path 'explode-path orig-path)))
+
+  ;; Arguments must be in normal form
+  (define find-relative-path
+    (lambda (directory filename)
+      (let ([dir (do-explode-path 'find-relative-path directory)]
+	    [file (do-explode-path 'find-relative-path filename)])
+	(if (equal? (car dir) (car file))
+	    (let loop ([dir (cdr dir)]
+		       [file (cdr file)])
+	      (cond
+	       [(null? dir) (if (null? file) filename (apply build-path file))]
+	       [(null? file) (apply build-path (map (lambda (x) 'up) dir))]
+	       [(equal? (car dir) (car file))
+		(loop (cdr dir) (cdr file))]
+	       [else
+		(apply build-path 
+		       (append (map (lambda (x) 'up) dir)
+			       file))]))
+	    filename))))
+
+  (define file-name-from-path
+    (lambda (name)
+      (unless (path-string? name)
+	(raise-type-error 'file-name-from-path "path or string" name))
+      (let-values ([(base file dir?) (split-path name)])
+	(if (and (not dir?) (path? file))
+	    file
+	    #f))))
+
+  (define path-only
+    (lambda (name)
+      (unless (path-string? name)
+	(raise-type-error 'path-only "path or string" name))
+      (let-values ([(base file dir?) (split-path name)])
+	(cond
+	 [dir? name]
+	 [(path? base) base]
+	 [else #f]))))
+
+  ;; name can be any string; we just look for a dot
+  (define filename-extension
+    (lambda (name)
+      (unless (path-string? name)
+	(raise-type-error 'filename-extension "path or string" name))
+      (let ([name (if (path? name)
+		      (path->bytes name)
+		      name)])
+	(let ([m (regexp-match #rx#"[.]([^.]+)$" name)])
+	  (and m
+	       (cadr m))))))
+
+  (define (delete-directory/files path)
+    (unless (path-string? path)
+      (raise-type-error 'delete-directory/files "path or string" path))
+    (cond
+     [(or (link-exists? path) (file-exists? path))
+      (delete-file path)]
+     [(directory-exists? path)
+      (for-each (lambda (e) (delete-directory/files (build-path path e)))
+		(directory-list path))
+      (delete-directory path)]
+     [else (error 'delete-directory/files
+		  "encountered ~a, neither a file nor a directory"
+		  path)]))
+
+  (define (copy-directory/files src dest)
+    (cond
+     [(file-exists? src)
+      (copy-file src dest)]
+     [(directory-exists? src)
+      (make-directory dest)
+      (for-each (lambda (e) (copy-directory/files (build-path src e)
+						  (build-path dest e)))
+		(directory-list src))]
+     [else (error 'copy-directory/files
+		  "encountered ~a, neither a file nor a directory"
+		  src)]))
+
+  (define (make-directory* dir)
+    (let-values ([(base name dir?) (split-path dir)])
+      (when (and (path? base)
+		 (not (directory-exists? base)))
+	(make-directory* base))
+      (unless (directory-exists? dir)
+        (make-directory dir))))
+
+  (define make-temporary-file
+    (case-lambda
+     [(template copy-from base-dir)
+      (with-handlers ([exn:fail:contract?
+		       (lambda (x)
+			 (raise-type-error 'make-temporary-file
+					   "format string for 1 argument"
+					   template))])
+	(format template void))
+      (unless (or (not copy-from) (path-string? copy-from))
+	(raise-type-error 'make-temporary-file "path, valid-path string, or #f" copy-from))
+      (unless (or (not base-dir) (path-string? base-dir))
+	(raise-type-error 'make-temporary-file "path, valid-path, string, or #f" base-dir))
+      (let ([tmpdir (find-system-path 'temp-dir)])
+	(let loop ([s (current-seconds)][ms (current-milliseconds)])
+	  (let ([name (let ([n (format template (format "~a~a" s ms))])
+			(cond
+			 [base-dir (build-path base-dir n)]
+			 [(relative-path? n) (build-path tmpdir n)]
+			 [else n]))])
+	    (with-handlers ([exn:fail:filesystem:exists? (lambda (x) 
+							   ;; try again with a new name
+							   (loop (- s (random 10))
+								 (+ ms (random 10))))])
+	      (if copy-from
+		  (copy-file copy-from name)
+		  (close-output-port (open-output-file name)))
+	      name))))]
+     [(template copy-from) (make-temporary-file template copy-from #f)]
+     [(template) (make-temporary-file template #f #f)]
+     [() (make-temporary-file "mztmp~a" #f #f)]))
+  
+  (define find-library
+    (case-lambda 
+     [(name) (find-library name "mzlib")]
+     [(name collection . cp)
+      (let ([dir (with-handlers ([exn:fail:filesystem? (lambda (exn) #f)])
+		   (apply collection-path collection cp))])
+	(if dir
+	    (let ([file (build-path dir name)])
+	      (if (file-exists? file)
+		  file
+		  #f))
+	    #f))]))
+
+  (define (with-pref-params thunk)
+    (parameterize ((read-case-sensitive #f)
+		   (read-square-bracket-as-paren #t)
+		   (read-curly-brace-as-paren #t)
+		   (read-accept-box #t)
+		   (read-accept-compiled #f)
+		   (read-accept-bar-quote #t)
+		   (read-accept-graph #t)
+		   (read-decimal-as-inexact #t)
+		   (read-accept-dot #t)
+		   (read-accept-quasiquote #t)
+		   (read-accept-reader #f)
+		   (print-struct #f)
+		   (print-graph #t)
+		   (print-box #t)
+		   (print-vector-length #t)
+		   (current-readtable #f))
+      (thunk)))
+
+
+  (define pref-box (make-weak-box #f)) ; non-weak box => need to save
+  (define (get-prefs flush? filename)
+    (let ([f (and (not flush?)
+		  (not filename)
+		  (weak-box-value pref-box))])
+      (or f
+	  (let ([f (let ([v (with-handlers ([exn:fail:filesystem? (lambda (x) null)])
+			      (let ([pref-file (or filename
+						   (let ([f (find-system-path 'pref-file)])
+						     (if (file-exists? f)
+							 ;; Using `file-exists?' means there's technically
+							 ;; a race condition, but something
+							 ;; has gone really wrong if the file disappears.
+							 f
+							 ;; Error here bails out through above `with-handlers'
+							 (build-path (collection-path "defaults")
+								     "plt-prefs.ss"))))])
+				(with-pref-params
+				 (lambda ()
+				   (with-input-from-file pref-file
+				     read)))))])
+		     ;; Make sure file content had the right shape:
+		     (if (and (list? v) 
+			      (andmap (lambda (x) 
+					(and (pair? x) 
+					     (pair? (cdr x))
+					     (null? (cddr x))))
+				      v))
+			 v
+			 null))])
+	    (unless filename
+	      (set! pref-box (make-weak-box f)))
+	    f))))
+
+  (define get-preference
+    (case-lambda 
+     [(name fail-thunk refresh-cache? filename)
+      (unless (symbol? name)
+	(raise-type-error
+	 'get-preference
+	 "symbol"
+	 name))
+      (unless (and (procedure? fail-thunk)
+		   (procedure-arity-includes? fail-thunk 0))
+	(raise-type-error
+	 'get-preference
+	 "procedure (arity 0)"
+	 fail-thunk))
+      (let ([f (get-prefs refresh-cache? filename)])
+	(let ([m (assq name f)])
+	  (if m
+	      (cadr m)
+	      (fail-thunk))))]
+     [(name fail-thunk refresh-cache?) (get-preference name fail-thunk refresh-cache? #f)]
+     [(name fail-thunk) (get-preference name fail-thunk #t #f)]
+     [(name) (get-preference name (lambda () #f) #t #f)]))
+
+  (define put-preferences
+    (case-lambda
+     [(names vals lock-there filename)
+      (unless (and (list? names)
+		   (andmap symbol? names))
+	(raise-type-error
+	 'put-preferences
+	 "list of symbols"
+	 names))
+      (unless (list? vals)
+	(raise-type-error
+	 'put-preferences
+	 "list"
+	 vals))
+      (unless (= (length names) (length vals))
+	(raise-mismatch-error
+	 'put-preferences
+	 (format "the size of the name list (~a) does not match the size of the value list (~a): "
+		 (length names) (length vals))
+	 vals))
+      (let-values ([(pref-file lock-file pref-dir)
+		    (let ([filename (or filename (find-system-path 'pref-file))])
+		      (let-values ([(base name dir?) (split-path filename)])
+			(let ([dir (if (symbol? base)
+				       (current-directory)
+				       base)])
+			  (unless (directory-exists? dir)
+			    (make-directory* dir))
+			  (values filename
+				  (build-path dir (bytes->path
+						   (bytes-append
+						    (if (eq? 'windows (system-type))
+							#"_"
+							#".")
+						    #"LOCK"
+						    (path->bytes name))))
+				  dir))))])
+	(with-handlers ([exn:fail:filesystem:exists?
+			 (lambda (x)
+			   (lock-there lock-file))])
+	  ;; Grab lock:
+	  (close-output-port (open-output-file lock-file 'error))
+	  (dynamic-wind
+	      void
+	      (lambda ()
+		(let ([f (get-prefs #t filename)])
+		  (for-each
+		   (lambda (name val)
+		     (let ([m (assq name f)])
+		       (if m
+			   (set-car! (cdr m) val)
+			   (set! f (cons (list name val) f)))))
+		   names vals)
+		  (unless filename
+		    (set! pref-box (make-weak-box f)))
+		  ;; To write the file, copy the old one to a temporary name
+		  ;; (preserves permissions, etc), write to the temp file,
+		  ;; then move (atomicly) the temp file to the normal name.
+		  (let* ([tmp-file (make-temporary-file
+				    "TMPPREF~a"
+				    (and (file-exists? pref-file) pref-file)
+				    pref-dir)])
+		    ;; If something goes wrong, try to delete the temp file.
+		    (with-handlers ([exn:fail? (lambda (exn)
+						 (with-handlers ([exn:fail:filesystem? void])
+						   (delete-file tmp-file))
+						 (raise exn))])
+		      ;; Write to temp file...
+		      (with-output-to-file tmp-file
+			(lambda ()
+			  (with-pref-params
+			   (lambda ()
+			     ;; If a pref value turns out to be unreadable, raise
+			     ;;  an exception instead of creating a bad pref file.
+			     (parameterize ([print-unreadable #f])
+			       ;; Poor man's pretty-print: one line per entry.
+			       (printf "(~n")
+			       (for-each (lambda (a)
+					   (if (list? (cadr a))
+					       (begin
+						 (printf " (~s~n  (~n" (car a))
+						 (for-each (lambda (i) (printf "  ~s~n" i)) (cadr a))
+						 (printf "  ))~n"))
+					       (printf " ~s~n" a)))
+					 f)
+			       (printf ")~n")))))
+			'truncate/replace)
+		      (rename-file-or-directory tmp-file pref-file #t)))))
+	      (lambda ()
+		;; Release lock:
+		(delete-file lock-file)))))]
+     [(names vals lock-there) 
+      (put-preferences names vals lock-there #f)]
+     [(names vals) 
+      (put-preferences
+       names vals 
+       (lambda (lock-file) 
+	 (error 'put-preferences
+		"some other process has the preference-file lock, as indicated by the existence of the lock file: ~e"
+		lock-file)))]))
+
+  (define call-with-input-file*
+    (lambda (file thunk . flags)
+      (let ([p (apply open-input-file file flags)])
+	(dynamic-wind
+	    void
+	    (lambda () (thunk p))
+	    (lambda () (close-input-port p))))))	  
+
+  (define call-with-output-file*
+    (lambda (file thunk . flags)
+      (let ([p (apply open-output-file file flags)])
+	(dynamic-wind
+	    void
+	    (lambda () (thunk p))
+	    (lambda () (close-output-port p))))))
+
+  ;; fold-files : (pathname sym alpha -> alpha) alpha pathname/#f -> alpha
+  (define fold-files
+    (opt-lambda (f init [path #f] [follow-links? #t])
+
+      ;; traverse-dir : string[directory] (listof string[file/directory]) -> (listof string[file/directory])
+      (define (traverse-dir dir base acc)
+	(let loop ([subs (directory-list dir)]
+		   [acc acc])
+	  (cond
+	   [(null? subs) acc]
+	   [else (loop (cdr subs)
+		       (let ([path (if base
+				       (build-path base (car subs))
+				       (car subs))])
+			 (traverse-file/dir path path acc)))])))
+
+      ;; traverse-file/dir : string[file/directory] (listof string[file/directory]) -> (listof string[file/directory])
+      (define (traverse-file/dir file/dir base acc)
+	(cond
+	 [(and (not follow-links?) (link-exists? file/dir))
+	  (f file/dir 'link acc)]
+	 [(directory-exists? file/dir)
+	  (traverse-dir file/dir base (if base
+					  (f file/dir 'dir acc)
+					  acc))]
+	 [else (f file/dir 'file acc)]))
+      
+      (traverse-file/dir (or path (current-directory)) 
+			 path
+			 init)))
+
+  (define find-files 
+    (opt-lambda (f [path #f])
+      (fold-files (lambda (path kind acc)
+		    (if (f path)
+			(cons path acc)
+			acc))
+		  null
+		  path))))
diff --git a/collects/mzlib/foreign.ss b/collects/mzlib/foreign.ss
new file mode 100644
index 0000000000..23438da2ac
--- /dev/null
+++ b/collects/mzlib/foreign.ss
@@ -0,0 +1,1503 @@
+;; Foreign Scheme interface
+
+(module foreign mzscheme
+
+(require #%foreign)
+(require-for-syntax (lib "stx.ss" "syntax"))
+
+;; This module is full of unsafe bindings that are not provided to requiring
+;; modules.  Instead, an `unsafe!' binding is provided that makes these unsafe
+;; bindings available.  The following two syntaxes do that: `provide*' is like
+;; `provide', but using `(unsafe id)' registers an unsafe binding.  Then,
+;; `define-unsafer' should be used with a binding that will expose the unsafe
+;; bindings.  This might move elsewhere at some point if it turns out to be
+;; useful in other contexts.
+(provide provide* define-unsafer)
+(define-syntaxes (provide* define-unsafer)
+  (let ((unsafe-bindings '()))
+    (values
+     (lambda (stx)
+       (syntax-case stx ()
+         [(_ p ...)
+          (let loop ([provides '()]
+                     [unsafes  '()]
+                     [ps (syntax->list #'(p ...))])
+            (if (null? ps)
+              (begin (set! unsafe-bindings
+                           (append unsafe-bindings (reverse unsafes)))
+                     (with-syntax ([(p ...) provides]) #'(provide p ...)))
+              (syntax-case (car ps) (unsafe)
+                [(unsafe u)
+                 (syntax-case #'u (rename)
+                   [(rename from to)
+                    (loop provides (cons (cons #'from #'to) unsafes) (cdr ps))]
+                   [id (identifier? #'id)
+                    (loop provides (cons (cons #'id #'id) unsafes) (cdr ps))]
+                   [_else
+                    (raise-syntax-error 'provide* "bad unsafe usage"
+                                        (car ps) stx)])]
+                [_ (loop (cons (car ps) provides) unsafes (cdr ps))])))]))
+     (lambda (stx)
+       (syntax-case stx ()
+         [(_ unsafe)
+          (with-syntax ([(from ...)  (map car unsafe-bindings)]
+                        [(to   ...)  (map cdr unsafe-bindings)]
+                        [(id   ...) (generate-temporaries unsafe-bindings)])
+            (set! unsafe-bindings '())
+            #'(begin
+                (provide (protect unsafe))
+                (define-syntax (unsafe stx)
+                  (syntax-case stx ()
+                    [(_) (with-syntax ([(id ...) (list (datum->syntax-object
+                                                        stx 'to stx)
+                                                       ...)])
+                           #'(begin (define-syntax id
+                                      (make-rename-transformer #'from))
+                                    ...))]))))])))))
+
+(provide* ctype-sizeof ctype-alignof compiler-sizeof
+          malloc free end-stubborn-change
+          cpointer? ptr-equal? (unsafe ptr-ref) (unsafe ptr-set!)
+          ctype? make-ctype make-cstruct-type make-sized-byte-string
+          _void _int8 _uint8 _int16 _uint16 _int32 _uint32 _int64 _uint64
+          _fixint _ufixint _fixnum _ufixnum
+          _float _double _double*
+          _bool _pointer _scheme _fpointer)
+
+(define-syntax define*
+  (syntax-rules ()
+    [(_ (name . args) body ...)
+     (begin (provide name) (define (name . args) body ...))]
+    [(_ name expr)
+     (begin (provide name) (define name expr))]))
+
+;; ----------------------------------------------------------------------------
+;; C integer types
+
+(define* _sint8  _int8)
+(define* _sint16 _int16)
+(define* _sint32 _int32)
+(define* _sint64 _int64)
+
+;; _byte etc is a convenient name for _uint8 & _sint8
+;; (_byte is unsigned)
+(define* _byte  _uint8)
+(define* _ubyte _uint8)
+(define* _sbyte _int8)
+
+;; _word etc is a convenient name for _uint16 & _sint16
+;; (_word is unsigned)
+(define* _word  _uint16)
+(define* _uword _uint16)
+(define* _sword _int16)
+
+;; _short etc is a convenient name for whatever is the compiler's `short'
+;; (_short is signed)
+(provide _short _ushort _sshort)
+(define-values (_short _ushort _sshort)
+  (case (compiler-sizeof 'short)
+    [(2) (values _int16 _uint16 _int16)]
+    [(4) (values _int32 _uint32 _int32)]
+    [else (error 'foreign "internal error: bad compiler size for `short'")]))
+
+;; _int etc is a convenient name for whatever is the compiler's `int'
+;; (_int is signed)
+(provide _int _uint _sint)
+(define-values (_int _uint _sint)
+  (case (compiler-sizeof 'int)
+    [(2) (values _int16 _uint16 _int16)]
+    [(4) (values _int32 _uint32 _int32)]
+    [(8) (values _int64 _uint64 _int64)]
+    [else (error 'foreign "internal error: bad compiler size for `int'")]))
+
+;; _long etc is a convenient name for whatever is the compiler's `long'
+;; (_long is signed)
+(provide _long _ulong _slong)
+(define-values (_long _ulong _slong)
+  (case (compiler-sizeof 'long)
+    [(4) (values _int32 _uint32 _int32)]
+    [(8) (values _int64 _uint64 _int64)]
+    [else (error 'foreign "internal error: bad compiler size for `long'")]))
+
+;; _llong etc is a convenient name for whatever is the compiler's `long long'
+;; (_llong is signed)
+(provide _llong _ullong _sllong)
+(define-values (_llong _ullong _sllong)
+  (case (compiler-sizeof '(long long))
+    [(4) (values _int32 _uint32 _int32)]
+    [(8) (values _int64 _uint64 _int64)]
+    [else (error 'foreign "internal error: bad compiler size for `llong'")]))
+
+;; ----------------------------------------------------------------------------
+;; Getting and setting library objects
+
+(define lib-suffix
+  (case (system-type)
+    [(unix)    "so"]
+    [(macosx)  "dylib"]
+    [(windows) "dll"]
+    [else (error 'foreign "unknown system type: ~s" (system-type))]))
+(define lib-suffix-re (regexp (string-append "\\." lib-suffix "$")))
+
+(provide (rename get-ffi-lib ffi-lib)
+         ffi-lib? ffi-lib-name)
+(define get-ffi-lib
+  (case-lambda
+   [(name) (get-ffi-lib name "")]
+   [(name version)
+    (cond
+     [(ffi-lib? name) name]
+     [(not name) (ffi-lib name)] ; #f => NULL => open this executable
+     [(not (or (string? name) (path? name)))
+      (raise-type-error 'ffi-lib "library-name" name)]
+     [else
+      ;; A possible way that this might be misleading: say that there is a
+      ;; "foo.so" file in the current directory, which refers to some undefined
+      ;; symbol, trying to use this function with "foo.so" will try a dlopen
+      ;; with "foo.so" which isn't found, then it tries a dlopen with
+      ;; "/<curpath>/foo.so" which fails because of the undefined symbol, and
+      ;; since all fails, it will use (ffi-lib "foo.so") to raise the original
+      ;; file-not-found error.  This is because the dlopen doesn't provide a
+      ;; way to distinguish different errors (only dlerror, but that's
+      ;; unreliable).
+      (let* ([version (if (pair? version) (string-append "." (car version)) "")]
+             [fullpath (lambda (p) (path->complete-path (expand-path p)))]
+             [name0 (path->string (expand-path name))]     ; orig name
+             [name  (if (regexp-match lib-suffix-re name0) ; name + suffix
+                      (string-append name0 version)
+                      (string-append name0 "." lib-suffix version))])
+        (or (ffi-lib name #t)         ; try good name first
+            (ffi-lib name0 #t)        ; try original
+            (and (file-exists? name)  ; try a relative path
+                 (ffi-lib (fullpath name) #t))
+            (and (file-exists? name0) ; relative with original
+                 (ffi-lib (fullpath name0) #t))
+            ;; give up: call ffi-lib so it will raise an error
+            (ffi-lib name)))])]))
+
+;; These internal functions provide the functionality to be used by
+;; get-ffi-obj, set-ffi-obj! and define-c below
+(define (ffi-get ffi-obj type)
+  (ptr-ref ffi-obj type))
+(define (ffi-set! ffi-obj type new)
+  (let-values ([(new type) (get-lowlevel-object new type)])
+    (hash-table-put! ffi-objects-ref-table ffi-obj new)
+    (ptr-set! ffi-obj type new)))
+
+;; This is better handled with `make-c-parameter'
+(provide* ffi-obj-ref)
+(define ffi-obj-ref
+  (case-lambda
+   [(name lib) (ffi-obj-ref name lib #f)]
+   [(name lib failure)
+    (let ([name (get-ffi-obj-name 'ffi-obj-ref name)]
+          [lib  (get-ffi-lib lib)])
+      (with-handlers ([exn:fail:filesystem?
+                       (lambda (e) (if failure (failure) (raise e)))])
+        (ffi-obj name lib)))]))
+
+;; get-ffi-obj is implemented as a syntax only to be able to propagate the
+;; foreign name into the type syntax, which allows generated wrappers to have a
+;; proper name.
+(provide* (unsafe get-ffi-obj))
+(define get-ffi-obj*
+  (case-lambda
+   [(name lib type) (get-ffi-obj* name lib type #f)]
+   [(name lib type failure)
+    (let ([name (get-ffi-obj-name 'get-ffi-obj name)]
+          [lib  (get-ffi-lib lib)])
+      (let-values ([(obj error?)
+                    (with-handlers
+                        ([exn:fail:filesystem?
+                          (lambda (e)
+                            (if failure (values (failure) #t) (raise e)))])
+                      (values (ffi-obj name lib) #f))])
+        (if error? obj (ffi-get obj type))))]))
+(define-syntax (get-ffi-obj stx)
+  (syntax-case stx ()
+    [(_ name lib type)
+     #`(get-ffi-obj* name lib #,(syntax-property #`type 'ffi-name #'name))]
+    [(_ name lib type failure)
+     #`(get-ffi-obj* name lib #,(syntax-property #`type 'ffi-name #'name)
+                     failure)]
+    [x (identifier? #'x) #'get-ffi-obj*]))
+
+;; It is important to use the set-ffi-obj! wrapper because it takes care of
+;; keeping a handle on the object -- otherwise, setting a callback hook will
+;; crash when the Scheme function is gone.
+(provide* (unsafe set-ffi-obj!))
+(define (set-ffi-obj! name lib type new)
+  (ffi-set! (ffi-obj (get-ffi-obj-name 'set-ffi-obj! name) (get-ffi-lib lib))
+            type new))
+
+;; Combining the above two in a `define-c' special form which makes a Scheme
+;; `binding', first a `parameter'-like constructor:
+(provide* (unsafe make-c-parameter))
+(define (make-c-parameter name lib type)
+  (let ([obj (ffi-obj (get-ffi-obj-name 'make-c-parameter name)
+                      (get-ffi-lib lib))])
+    (case-lambda [()    (ffi-get  obj type)]
+                 [(new) (ffi-set! obj type new)])))
+;; Then the fake binding syntax, uses the defined identifier to name the
+;; object:
+(provide* (unsafe define-c))
+(define-syntax (define-c stx)
+  (syntax-case stx ()
+    [(_ var-name lib-name type-expr)
+     (with-syntax ([(p) (generate-temporaries (list #'var-name))])
+       (namespace-syntax-introduce
+        #'(begin (define p (make-c-parameter 'var-name lib-name type-expr))
+                 (define-syntax var-name
+                   (syntax-id-rules (set!)
+                     [(set! var val) (p val)]
+                     [(var . xs) ((p) . xs)]
+                     [var (p)])))))]))
+
+;; Used to convert strings and symbols to a byte-string that names an object
+(define (get-ffi-obj-name who objname)
+  (cond [(bytes? objname) objname]
+        [(symbol? objname) (get-ffi-obj-name who (symbol->string objname))]
+        [(string? objname) (string->bytes/utf-8 objname)]
+        [else (raise-type-error who "object-name" objname)]))
+
+;; This table keeps references to values that are set in foreign libraries, to
+;; avoid them being GCed.  See set-ffi-obj! above.
+(define ffi-objects-ref-table (make-hash-table))
+
+;; ----------------------------------------------------------------------------
+;; Compile-time support for fun-expanders
+
+(begin-for-syntax
+
+  ;; The `_fun' macro tears its input apart and reassemble it using pieces from
+  ;; custom function types (macros).  This whole deal needs some work to make
+  ;; it play nicely with code certificates, so Matthew wrote the following
+  ;; code.  The idea is to create a define-fun-syntax which makes the new
+  ;; syntax transformer be an object that carries extra information, later used
+  ;; by `expand-fun-syntax/fun'.
+
+  (define fun-cert-key (gensym))
+
+  ;; bug in begin-for-syntax (PR7104), see below
+  (define foo!!! (make-parameter #f))
+  (define (expand-fun-syntax/normal fun-stx stx)
+    ((foo!!!) fun-stx stx))
+
+  (define-values (make-fun-syntax fun-syntax?
+                  fun-syntax-proc fun-syntax-certifier fun-syntax-name)
+    (let-values ([(desc make pred? get set!)
+                  (make-struct-type
+                   'fun-syntax #f 3 0 #f '() (current-inspector)
+                   expand-fun-syntax/normal)])
+      (values make pred?
+              (make-struct-field-accessor get 0 'proc)
+              (make-struct-field-accessor get 1 'certifier)
+              (make-struct-field-accessor get 2 'name))))
+
+  ;; This is used to expand a fun-syntax in a _fun type context.
+  (define (expand-fun-syntax/fun stx)
+    (let loop ([stx stx])
+      (define (do-expand id id?) ; id? == are we expanding an identifier?
+        (define v           (syntax-local-value id (lambda () #f)))
+        (define set!-trans? (set!-transformer? v))
+        (define proc        (if set!-trans? (set!-transformer-procedure v) v))
+        (if (and (fun-syntax? proc) (or (not id?) set!-trans?))
+          ;; Do essentially the same thing that `local-expand' does.
+          ;;  First, create an "introducer" to mark introduced identifiers:
+          (let* ([introduce (make-syntax-introducer)]
+                 [expanded
+                  ;; Re-introduce mark related to expansion of `_fun':
+                  (syntax-local-introduce
+                   ;; Re-add mark specific to this expansion, cancelling
+                   ;;  some marks applied before expanding (leaving only
+                   ;;  introuced syntax marked)
+                   (introduce
+                    ;; Actually expand:
+                    ((fun-syntax-proc proc)
+                     ;; Add mark specific to this expansion:
+                     (introduce
+                      ;; Remove mark related to expansion of `_fun':
+                      (syntax-local-introduce stx)))))])
+            ;; Certify based on definition of expander, then loop
+            ;;  to continue expanding:
+            (loop ((fun-syntax-certifier proc)
+                   expanded fun-cert-key introduce)))
+          stx))
+      (syntax-case stx ()
+        [(id . rest) (identifier? #'id) (do-expand #'id #f)]
+        [id          (identifier? #'id) (do-expand #'id #t)]
+        [_else stx])))
+
+  ;; Use module-or-top-identifier=? because we use keywords like `=' and want
+  ;; to make it possible to play with it at the toplevel.
+  (define id=? module-or-top-identifier=?)
+
+  (define (split-by key args)
+    (let loop ([args args] [r (list '())])
+      (cond [(null? args) (reverse! (map reverse! r))]
+            [(eq? key (car args)) (loop (cdr args) (cons '() r))]
+            [else (set-car! r (cons (car args) (car r)))
+                  (loop (cdr args) r)])))
+
+  (define (filtmap f l)
+    (let loop ([l l] [r '()])
+      (if (null? l)
+        (reverse! r)
+        (let ([x (f (car l))]) (loop (cdr l) (if x (cons x r) r))))))
+
+  (define (add-renamer body from to)
+    (with-syntax ([body body] [from from] [to to])
+      #'(let-syntax ([to (syntax-id-rules ()
+                           [(_?_ . _rest_) (from . _rest_)] [_?_ from])])
+          body)))
+
+  (define (custom-type->keys type err)
+    (define stops (map (lambda (s) (datum->syntax-object type s #f))
+                       '(#%app #%top #%datum)))
+    ;; Expand `type' using expand-fun-syntax/fun
+    (define orig (expand-fun-syntax/fun type))
+    (define (with-arg x)
+      (syntax-case* x (=>) id=?
+        [(id => body) (identifier? #'id)
+         ;; Extract #'body from its context, use a key it needs certification:
+         (list (syntax-recertify #'id orig #f fun-cert-key)
+	       (syntax-recertify #'body orig #f fun-cert-key))]
+        [_else x]))
+    (define (cert-id id)
+      (syntax-recertify id orig #f fun-cert-key))
+   (let ([keys '()])
+     (define (setkey! key val . id?)
+       (cond
+        [(assq key keys)
+         (err "bad expansion of custom type (two `~a:'s)" key type)]
+        [(and (pair? id?) (car id?) (not (identifier? val)))
+         (err "bad expansion of custom type (`~a:' expects an identifier)"
+              key type)]
+        [else (set! keys (cons (cons key val) keys))]))
+     (let loop ([t orig])
+       (define (next rest . args) (apply setkey! args) (loop rest))
+       (syntax-case* t (type: expr: bind: 1st-arg: prev-arg: pre: post:) id=?
+         [(type: t x ...)      (next #'(x ...) 'type #'t)]
+         [(expr:     e  x ...) (next #'(x ...) 'expr #'e)]
+         [(bind:     id x ...) (next #'(x ...) 'bind (cert-id #'id) #t)]
+         [(1st-arg:  id x ...) (next #'(x ...) '1st  (cert-id #'id) #t)]
+         [(prev-arg: id x ...) (next #'(x ...) 'prev (cert-id #'id) #t)]
+         ;; in the following two cases pass along orig for recertifying
+         [(pre:      p  x ...) (next #'(x ...) 'pre  (with-arg #'p))]
+         [(post:     p  x ...) (next #'(x ...) 'post (with-arg #'p))]
+         [() (and (pair? keys) keys)]
+         [_else #f]))))
+
+  ;; This is used for a normal expansion of fun-syntax, when not in a _fun type
+  ;; context.
+  ;; bug in begin-for-syntax (PR7104), see above
+  ;;   should be (define (expand-fun-syntax/normal fun-stx stx) ...)
+  (foo!!! (lambda (fun-stx stx)
+    (define (err msg . sub)
+      (apply raise-syntax-error (fun-syntax-name fun-stx) msg stx sub))
+    (let ([keys (custom-type->keys stx err)])
+      (define (getkey key) (cond [(assq key keys) => cdr] [else #f]))
+      (define (notkey key)
+        (when (getkey key)
+          (err (format "this type must be used in a _fun expression (uses ~s)"
+                       key))))
+      (if keys
+        (let ([type (getkey 'type)] [pre (getkey 'pre)] [post (getkey 'post)])
+          (unless type
+            (err "this type must be used in a _fun expression (#f type)"))
+          (for-each notkey '(expr bind 1st prev))
+          (if (or pre post)
+            ;; a type with pre/post blocks
+            (let ([make-> (lambda (x what)
+                            (cond [(not x) #'#f]
+                                  [(and (list? x) (= 2 (length x))
+                                        (identifier? (car x)))
+                                   #`(lambda (#,(car x)) #,(cadr x))]
+                                  [else #`(lambda (_)
+                                            (error '#,(fun-syntax-name fun-stx)
+                                                   "cannot be used to ~a"
+                                                   #,what))]))])
+              (with-syntax ([type type]
+                            [scheme->c (make-> pre "send values to C")]
+                            [c->scheme (make-> post "get values from C")])
+                #'(make-ctype type scheme->c c->scheme)))
+            ;; simple type
+            type))
+        ;; no keys => normal expansion
+        ((fun-syntax-proc fun-stx) stx))))))
+
+;; Use define-fun-syntax instead of define-syntax for forms that
+;;  are to be expanded by `_fun':
+(provide define-fun-syntax)
+(define-syntax define-fun-syntax
+  (syntax-rules ()
+    [(_ id trans)
+     (define-syntax id
+       (let* ([xformer trans]
+              [set!-trans? (set!-transformer? xformer)])
+         (unless (or (and (procedure? xformer)
+                          (procedure-arity-includes? xformer 1))
+                     set!-trans?)
+           (raise-type-error 'define-fun-syntax
+                             "procedure (arity 1) or set!-transformer"
+                             xformer))
+         (let ([f (make-fun-syntax (if set!-trans?
+                                     (set!-transformer-procedure xformer)
+                                     xformer)
+                                   ;; Capture definition-time certificates:
+                                   (syntax-local-certifier)
+                                   'id)])
+           (if set!-trans? (make-set!-transformer f) f))))]))
+
+;; ----------------------------------------------------------------------------
+;; Function type
+
+;; Creates a simple function type that can be used for callouts and callbacks,
+;; optionally applying a wrapper function to modify the result primitive
+;; (callouts) or the input procedure (callbacks).
+(define* (_cprocedure itypes otype . wrapper)
+  (let ([wrapper (and (pair? wrapper) (car wrapper))])
+    (if wrapper
+      (make-ctype _fpointer
+        (lambda (x) (ffi-callback (wrapper x) itypes otype))
+        (lambda (x) (wrapper (ffi-call x itypes otype))))
+      (make-ctype _fpointer
+        (lambda (x) (ffi-callback x itypes otype))
+        (lambda (x) (ffi-call x itypes otype))))))
+
+;; Syntax for the special _fun type:
+;; (_fun [{(name ... [. name]) | name} [-> expr] ::]
+;;       {type | (name : type [= expr]) | ([name :] type = expr)} ...
+;;       -> {type | (name : type)}
+;;       [-> expr])
+;; Usage:
+;; `{(name ...) | ...} ::' specify explicit wrapper function formal arguments
+;;           `-> expr'     can be used instead of the last expr
+;; `type'                  input type (implies input, but see type macros next)
+;; `(name : type = expr)'  specify name and type, `= expr' means computed input
+;; `-> type'               output type (possibly with name)
+;; `-> expr'               specify different output, can use previous names
+;; Also, see below for custom function types.
+
+(provide ->) ; to signal better errors when trying to use this with contracts
+(define-syntax ->
+  (syntax-id-rules ()
+    [_ (raise-syntax-error '-> "should be used only in a _fun context")]))
+
+(provide _fun)
+(define-syntax (_fun stx)
+  (define (err msg . sub) (apply raise-syntax-error '_fun msg stx sub))
+  (syntax-case stx ()
+    [(_ x ...)
+     (let ([xs (map (lambda (x)
+                      (syntax-case* x (-> ::) id=? [:: '::] [-> '->] [_  x]))
+                    (syntax->list #'(x ...)))]
+           [inputs #f] [output #f] [bind '()] [pre '()] [post '()]
+           [input-names #f] [output-type #f] [output-expr #f]
+           [1st-arg #f] [prev-arg #f])
+       (define (bind! x) (set! bind (append! bind (list x))))
+       (define (pre!  x) (set! pre  (append! pre  (list x))))
+       (define (post! x) (set! post (append! post (list x))))
+       (define ((t-n-e clause) type name expr)
+         (let ([keys (custom-type->keys type err)])
+           (define (getkey key) (cond [(assq key keys) => cdr] [else #f]))
+           (define (arg x . no-expr?)
+             (define use-expr?
+               (and (list? x) (= 2 (length x)) (identifier? (car x))))
+             ;; when the current expr is not used with a (x => ...) form,
+             ;; either check that no expression is given or just make it
+             ;; disappear from the inputs.
+             (unless use-expr?
+               (if (and (pair? no-expr?) (car no-expr?) expr)
+                 (err "got an expression for a custom type that do not use it"
+                      clause)
+                 (set! expr (void))))
+             (set! x (if use-expr? (add-renamer (cadr x) name (car x)) x))
+             (cond [(getkey '1st) =>
+                    (lambda (v)
+                      (if 1st-arg
+                        (set! x (add-renamer x 1st-arg v))
+                        (err "got a custom type that wants 1st arg too early"
+                             clause)))])
+             (cond [(getkey 'prev) =>
+                    (lambda (v)
+                      (if prev-arg
+                        (set! x (add-renamer x prev-arg v))
+                        (err "got a custom type that wants prev arg too early"
+                             clause)))])
+             x)
+           (when keys
+             (set! type (getkey 'type))
+             (cond [(and (not expr) (getkey 'expr)) =>
+                    (lambda (x) (set! expr x))])
+             (cond [(getkey 'bind) =>
+                    (lambda (x) (bind! #`[#,x #,name]))])
+             (cond [(getkey 'pre) =>
+                    (lambda (x) (pre!  #`[#,name #,(arg x #t)]))])
+             (cond [(getkey 'post) =>
+                    (lambda (x) (post! #`[#,name #,(arg x)]))]))
+           ;; turn a #f syntax to #f
+           (set! type (and type (syntax-case type () [#f #f] [_ type])))
+           (when type ; remember these for later usages
+             (unless 1st-arg (set! 1st-arg name))
+             (set! prev-arg name))
+           (list type name expr)))
+       ;; parse "::"
+       (let ([s (split-by ':: xs)])
+         (case (length s)
+           [(0) (err "something bad happened (::)")]
+           [(1) #f]
+           [(2) (if (and (= 1 (length (car s))) (not (eq? '-> (caar s))))
+                  (begin (set! xs (cadr s)) (set! input-names (caar s)))
+                  (err "bad wrapper formals"))]
+           [else (err "saw two or more instances of `::'")]))
+       ;; parse "->"
+       (let ([s (split-by '-> xs)])
+         (case (length s)
+           [(0) (err "something bad happened (->)")]
+           [(1) (err "missing output type")]
+           [(2 3) (set! inputs (car s))
+                  (case (length (cadr s))
+                    [(1) (set! output-type (caadr s))]
+                    [(0) (err "missing output type after `->'")]
+                    [else (err "extraneous output type" (cadadr s))])
+                  (unless (null? (cddr s))
+                    (case (length (caddr s))
+                      [(1) (set! output-expr (caaddr s))]
+                      [(0) (err "missing output expression after `->'")]
+                      [else (err "extraneous output expression"
+                                 (cadr (caddr s)))]))]
+           [else (err "saw three or more instances of `->'")]))
+       (set! inputs
+             (map (lambda (sub temp)
+                    (let ([t-n-e (t-n-e sub)])
+                      (syntax-case* sub (: =) id=?
+                        [(name : type)        (t-n-e #'type #'name #f)]
+                        [(type = expr)        (t-n-e #'type temp   #'expr)]
+                        [(name : type = expr) (t-n-e #'type #'name #'expr)]
+                        [type                 (t-n-e #'type temp   #f)])))
+                  inputs
+                  (generate-temporaries (map (lambda (x) 'tmp) inputs))))
+       ;; when processing the output type, only the post code matters
+       (set! pre! (lambda (x) #f))
+       (set! output
+             (let ([temp (car (generate-temporaries #'(ret)))]
+                   [t-n-e (t-n-e output-type)])
+               (syntax-case* output-type (: =) id=?
+                 [(name : type) (t-n-e #'type #'name output-expr)]
+                 [(type = expr) (if output-expr
+                                  (err "extraneous output expression" #'expr)
+                                  (t-n-e #'type temp #'expr))]
+                 [(name : type = expr)
+                                (if output-expr
+                                  (err "extraneous output expression" #'expr)
+                                  (t-n-e #'type #'name #'expr))]
+                 [type          (t-n-e #'type temp output-expr)])))
+       (if (or (caddr output) input-names (ormap caddr inputs)
+               (ormap (lambda (x) (not (car x))) inputs)
+               (pair? bind) (pair? pre) (pair? post))
+         (let* ([input-names (or input-names
+                                 (filtmap (lambda (i)
+                                            (and (not (caddr i)) (cadr i)))
+                                          inputs))]
+                [output-expr (let ([o (caddr output)])
+                               (or (and (not (void? o)) o)
+                                   (cadr output)))]
+                [args (filtmap (lambda (i) (and (caddr i)
+                                                (not (void? (caddr i)))
+                                                #`[#,(cadr i) #,(caddr i)]))
+                               inputs)]
+                [ffi-args (filtmap (lambda (x) (and (car x) (cadr x)))
+                                   inputs)]
+                ;; the actual wrapper body
+                [body (quasisyntax/loc stx
+                        (lambda #,input-names
+                          (let* (#,@args
+                                 #,@bind
+                                 #,@pre
+                                 [#,(cadr output) (ffi #,@ffi-args)]
+                                 #,@post)
+                            #,output-expr)))]
+                ;; if there is a string 'ffi-name property, use it as a name
+                [body (let ([n (cond [(syntax-property stx 'ffi-name)
+                                      => syntax-object->datum]
+                                     [else #f])])
+                        (if (string? n)
+                          (syntax-property
+                           body 'inferred-name
+                           (string->symbol (string-append "ffi-wrapper:" n)))
+                          body))])
+           #`(_cprocedure (list #,@(filtmap car inputs)) #,(car output)
+               (lambda (ffi) #,body)))
+         #`(_cprocedure (list #,@(filtmap car inputs)) #,(car output))))]))
+
+;; ----------------------------------------------------------------------------
+;; String types
+
+;; The internal _string type uses the native ucs-4 encoding, also providing a
+;; utf-16 type (note: these do not use #f as NULL).
+(provide _string/ucs-4 _string/utf-16)
+
+;; 8-bit string encodings, #f is NULL
+(define ((false-or-op op) x) (and x (op x)))
+(define* _string/utf-8
+  (make-ctype _bytes
+    (false-or-op string->bytes/utf-8) (false-or-op bytes->string/utf-8)))
+(define* _string/locale
+  (make-ctype _bytes
+    (false-or-op string->bytes/locale) (false-or-op bytes->string/locale)))
+(define* _string/latin-1
+  (make-ctype _bytes
+    (false-or-op string->bytes/latin-1) (false-or-op bytes->string/latin-1)))
+
+;; 8-bit string encodings, #f is NULL, can also use bytes and paths
+(define ((any-string-op op) x)
+  (cond [(not    x) x]
+        [(bytes? x) x]
+        [(path?  x) (path->bytes x)]
+        [else (op x)]))
+(define* _string*/utf-8
+  (make-ctype _bytes
+    (any-string-op string->bytes/utf-8) (false-or-op bytes->string/utf-8)))
+(define* _string*/locale
+  (make-ctype _bytes
+    (any-string-op string->bytes/locale) (false-or-op bytes->string/locale)))
+(define* _string*/latin-1
+  (make-ctype _bytes
+    (any-string-op string->bytes/latin-1) (false-or-op bytes->string/latin-1)))
+
+;; A generic _string type that usually does the right thing via a parameter
+(define* default-_string-type
+  (make-parameter _string*/utf-8
+    (lambda (x)
+      (if (ctype? x)
+        x (error 'default-_string-type "expecting a C type, got ~e" x)))))
+;; The type looks like an identifier, but it's actually using the parameter
+(provide _string)
+(define-syntax _string
+  (syntax-id-rules ()
+    [(_ . xs) ((default-_string-type) . xs)]
+    [_ (default-_string-type)]))
+
+;; _symbol is defined in C, since it uses simple C strings
+(provide _symbol)
+
+(provide _path)
+;; `file' type: path-expands a path string, provide _path too.
+(define* _file (make-ctype _path expand-path #f))
+
+;; `string/eof' type: converts an output #f (NULL) to an eof-object.
+(define string-type->string/eof-type
+  (let ([table (make-hash-table)])
+    (lambda (string-type)
+      (hash-table-get table string-type
+        (lambda ()
+          (let ([new-type (make-ctype string-type
+                            (lambda (x) (and (not (eof-object? x)) x))
+                            (lambda (x) (or x eof)))])
+            (hash-table-put! table string-type new-type)
+            new-type))))))
+(provide _string/eof)
+(define-syntax _string/eof
+  (syntax-id-rules ()
+    [(_ . xs) ((string-type->string/eof-type _string) . xs)]
+    [_ (string-type->string/eof-type _string)]))
+
+;; ----------------------------------------------------------------------------
+;; Utility types
+
+;; Call this with a name (symbol) and a list of symbols, where a symbol can be
+;; followed by a '= and an integer to have a similar effect of C's enum.
+(define (_enum* name symbols . base?)
+  (define basetype (if (pair? base?) (car base?) _ufixint))
+  (define sym->int '())
+  (define int->sym '())
+  (define s->c
+    (if name (string->symbol (format "enum:~a->int" name)) 'enum->int))
+  (let loop ([i 0] [symbols symbols])
+    (unless (null? symbols)
+      (when (and (pair? (cdr symbols))
+                 (eq? '= (cadr symbols))
+                 (pair? (cddr symbols)))
+        (set! i (caddr symbols))
+        (set-cdr! symbols (cdddr symbols)))
+      (set! sym->int (cons (cons (car symbols) i) sym->int))
+      (set! int->sym (cons (cons i (car symbols)) int->sym))
+      (loop (add1 i) (cdr symbols))))
+  (make-ctype basetype
+    (lambda (x)
+      (let ([a (assq x sym->int)])
+        (if a
+          (cdr a)
+          (raise-type-error s->c (format "~a" (or name "enum")) x))))
+    (lambda (x) (cond [(assq x int->sym) => cdr] [else #f]))))
+
+;; Macro wrapper -- no need for a name
+(provide _enum)
+(define-syntax (_enum stx)
+  (syntax-case stx ()
+    [(_ syms)
+     (with-syntax ([name (syntax-local-name)])
+       #'(_enum* 'name syms))]
+    [(_ syms basetype)
+     (with-syntax ([name (syntax-local-name)])
+       #'(_enum* 'name syms basetype))]
+    [id (identifier? #'id)
+     #'(lambda (syms . base?) (apply _enum* #f syms base?))]))
+
+;; Call this with a name (symbol) and a list of (symbol int) or symbols like
+;; the above with '= -- but the numbers have to be specified in some way.  The
+;; generated type will convert a list of these symbols into the logical-or of
+;; their values and back.
+(define (_bitmask* name symbols->integers . base?)
+  (define basetype (if (pair? base?) (car base?) _uint))
+  (define s->c
+    (if name (string->symbol (format "bitmask:~a->int" name)) 'bitmask->int))
+  (let loop ([s->i symbols->integers])
+    (unless (null? s->i)
+      (when (and (pair? (cdr s->i)) (eq? '= (cadr s->i)) (pair? (cddr s->i)))
+        (set-car! s->i (list (car s->i) (caddr s->i)))
+        (set-cdr! s->i (cdddr s->i)))
+      (unless (and (pair? (car s->i)) (pair? (cdar s->i)) (null? (cddar s->i))
+                   (symbol? (caar s->i)) (integer? (cadar s->i)))
+        (error '_bitmask "bad spec in ~e" symbols->integers))
+      (loop (cdr s->i))))
+  (make-ctype basetype
+    (lambda (symbols)
+      (if (null? symbols) ; probably common
+        0
+        (let loop ([xs (if (pair? symbols) symbols (list symbols))] [n 0])
+          (cond [(null? xs) n]
+                [(assq (car xs) symbols->integers) =>
+                 (lambda (x) (loop (cdr xs) (bitwise-ior (cadr x) n)))]
+                [else (raise-type-error s->c (format "~a" (or name "bitmaks"))
+                                        symbols)]))))
+    (lambda (n)
+      (if (zero? n) ; probably common
+        '()
+        (let loop ([s->i symbols->integers] [l '()])
+          (if (null? s->i)
+            (reverse! l)
+            (loop (cdr s->i)
+                  (let ([i (cadar s->i)])
+                    (if (and (not (= i 0)) (= i (bitwise-and i n)))
+                      (cons (caar s->i) l)
+                      l)))))))))
+
+;; Macro wrapper -- no need for a name
+(provide _bitmask)
+(define-syntax (_bitmask stx)
+  (syntax-case stx ()
+    [(_ syms)
+     (with-syntax ([name (syntax-local-name)])
+       #'(_bitmask* 'name syms))]
+    [(_ syms basetype)
+     (with-syntax ([name (syntax-local-name)])
+       #'(_bitmask* 'name syms basetype))]
+    [id (identifier? #'id)
+     #'(lambda (syms . base?) (apply _bitmask* #f syms base?))]))
+
+;; ----------------------------------------------------------------------------
+;; Custom function type macros
+
+;; These macros get expanded by the _fun type.  They can expand to a form that
+;; looks like (keyword: value ...), where the keyword is one of:
+;; * `type:'     for the type that will be used,
+;; * `expr:'     an expression that will always be used for these arguments, as
+;;               if `= expr' is always given, when an expression is actually
+;;               given in an argument specification, it supersedes this.
+;; * `bind:'     for an additional binding that holds the initial value,
+;; * `1st-arg:'  is used to name an identifier that will be bound to the value
+;;               of the 1st foreign argument in pre/post chunks (good for
+;;               common cases where the first argument has a special meaning,
+;;               eg, for method calls),
+;; * `prev-arg:' similar to 1st-arg: but for the previous argument,
+;; * `pre:'      for a binding that will be inserted before the ffi call,
+;; * `post:'     for a binding after the ffi call.
+;; The pre: and post: bindings can be of the form (id => expr) to use the
+;; existing value.  Note that if the pre: expression is not (id => expr), then
+;; it means that there is no input for this argument.  Also note that if a
+;; custom type is used as an output type of a function, then only the post:
+;; code is used -- for example, this is useful for foreign functions that
+;; allocate a memory block and return it to the user.  The resulting wrapper
+;; looks like:
+;;   (let* (...bindings for arguments...
+;;          ...bindings for bind: identifiers...
+;;          ...bindings for pre-code...
+;;          (ret-name ffi-call)
+;;          ...bindings for post-code...)
+;;     return-expression)
+;;
+;; Finally, the code in a custom-function macro needs special treatment when it
+;; comes to dealing with code certificates, so instead of using
+;; `define-syntax', you should use `define-fun-syntax' (used in the same way).
+
+;; _?
+;; This is not a normal ffi type -- it is a marker for expressions that should
+;; not be sent to the ffi function.  Use this to bind local values in a
+;; computation that is part of an ffi wrapper interface.
+(provide _?)
+(define-fun-syntax _?
+  (syntax-id-rules () [(_ . xs) ((type: #f) . xs)] [_ (type: #f)]))
+
+;; (_ptr <mode> <type>)
+;; This is for pointers, where mode indicates input or output pointers (or
+;; both).  If the mode is `o' (output), then the wrapper will not get an
+;; argument for it, instead it generates the matching argument.
+(provide _ptr)
+(define-fun-syntax _ptr
+  (syntax-rules (i o io)
+    [(_ i  t) (type: _pointer
+               pre:  (x => (let ([p (malloc t)]) (ptr-set! p t x) p)))]
+    [(_ o  t) (type: _pointer
+               pre:  (malloc t)
+               post: (x => (ptr-ref x t)))]
+    [(_ io t) (type: _pointer
+               pre:  (x => (let ([p (malloc t)]) (ptr-set! p t x) p))
+               post: (x => (ptr-ref x t)))]))
+
+;; (_box <type>)
+;; This is similar to a (_ptr io <type>) argument, where the input is expected
+;; to be a box, which is unboxed on entry and modified on exit.
+(provide _box)
+(define-fun-syntax _box
+  (syntax-rules ()
+    [(_ t) (type: _pointer
+            bind: tmp ; need to save the box so we can get back to it
+            pre:  (x => (let ([p (malloc t)]) (ptr-set! p t (unbox x)) p))
+            post: (x => (begin (set-box! tmp (ptr-ref x t)) tmp)))]))
+
+;; (_list <mode> <type> [<len>])
+;; Similar to _ptr, except that it is used for converting lists to/from C
+;; vectors.  The length is needed for output values where it is used in the
+;; post code, and in the pre code of an output mode to allocate the block.  In
+;; any case it can refer to a previous binding for the length of the list which
+;; the C function will most likely require.
+(provide _list)
+(define-fun-syntax _list
+  (syntax-rules (i o io)
+    [(_ i  t  ) (type: _pointer
+                 pre:  (x => (list->cblock x t)))]
+    [(_ o  t n) (type: _pointer
+                 pre:  (malloc n t)
+                 post: (x => (cblock->list x t n)))]
+    [(_ io t n) (type: _pointer
+                 pre:  (x => (list->cblock x t))
+                 post: (x => (cblock->list x t n)))]))
+
+;; (_vector <mode> <type> [<len>])
+;; Same as _list, except that it uses Scheme vectors.
+(provide _vector)
+(define-fun-syntax _vector
+  (syntax-rules (i o io)
+    [(_ i  t  ) (type: _pointer
+                 pre:  (x => (vector->cblock x t)))]
+    [(_ o  t n) (type: _pointer
+                 pre:  (malloc n t)
+                 post: (x => (cblock->vector x t n)))]
+    [(_ io t n) (type: _pointer
+                 pre:  (x => (vector->cblock x t))
+                 post: (x => (cblock->vector x t n)))]))
+
+;; _bytes or (_bytes o n) is for a memory block represented as a Scheme byte
+;; string.  _bytes is just like a byte-string, and (_bytes o n) is for
+;; pre-malloc of the string.  There is no need for other modes: i or io would
+;; be just like _bytes since the string carries its size information (so there
+;; is no real need for the `o', but it's there for consistency with the above
+;; macros).
+(provide (rename _bytes* _bytes))
+(define-fun-syntax _bytes*
+  (syntax-id-rules (o)
+    [(_ o n) (type: _bytes
+              pre:  (make-sized-byte-string (malloc n) n)
+              ;; post is needed when this is used as a function output type
+              post: (x => (make-sized-byte-string x n)))]
+    [(_ . xs) (_bytes . xs)]
+    [_ _bytes]))
+
+;; ----------------------------------------------------------------------------
+;; Safe raw vectors
+
+(define-struct cvector (ptr type length))
+
+(provide* cvector? cvector-length cvector-type
+          ;; make-cvector* is a dangerous operation
+          (unsafe (rename make-cvector make-cvector*)))
+
+(define _cvector* ; used only as input types
+  (make-ctype _pointer cvector-ptr
+    (lambda (x)
+      (error '_cvector
+             "cannot automatically convert a C pointer to a cvector"))))
+
+;; (_cvector <mode> [<type> <len>]) | _cevector
+;; Same as _list etc above, except that it uses C vectors.
+(provide _cvector)
+(define-fun-syntax _cvector
+  (syntax-id-rules (i o io)
+    [(_ i     ) _cvector*]
+    [(_ o  t n) (type: _pointer ; needs to be a pointer, not a cvector*
+                 pre:  (malloc n t)
+                 post: (x => (make-cvector x t n)))]
+    [(_ io    ) (type: _cvector*
+                 bind: tmp
+                 pre:  (x => (cvector-ptr x))
+                 post: (x => tmp))]
+    [(_ . xs)   (_cvector* . xs)]
+    [_          _cvector*]))
+
+(provide (rename allocate-cvector make-cvector))
+(define (allocate-cvector type len)
+  (let ([cblock (malloc len type)])
+    (make-cvector cblock type len)))
+
+(provide (rename cvector-args cvector))
+(define (cvector-args type . args)
+  (list->cvector args type))
+
+(define* (cvector-ref v i)
+  (if (and (integer? i) (<= 0 i (sub1 (cvector-length v))))
+    (ptr-ref (cvector-ptr v) (cvector-type v) i)
+    (error 'cvector-ref "bad index ~e for cvector bounds of 0..~e"
+           i (sub1 (cvector-length v)))))
+
+(define* (cvector-set! v i x)
+  (if (and (integer? i) (<= 0 i (sub1 (cvector-length v))))
+    (ptr-set! (cvector-ptr v) (cvector-type v) i x)
+    (error 'cvector-ref "bad index ~e for cvector bounds of 0..~e"
+           i (sub1 (cvector-length v)))))
+
+(define* (cvector->list v)
+  (cblock->list (cvector-ptr v) (cvector-type v) (cvector-length v)))
+
+(define* (list->cvector l type)
+  (make-cvector (list->cblock l type) type (length l)))
+
+;; ----------------------------------------------------------------------------
+;; SRFI-4 implementation
+
+(define-syntaxes (make-srfi-4 define-srfi-4-provider)
+  (let ([bindings '()])
+    (values
+     (lambda (stx)
+       (syntax-case stx ()
+         [(_ TAG type) (identifier? #'TAG)
+          (let ([name (string-append
+                       (symbol->string (syntax-object->datum #'TAG))
+                       "vector")])
+            (define (make-TAG-id prefix suffix)
+              (datum->syntax-object #'TAG
+                                    (string->symbol
+                                     (string-append prefix name suffix))
+                                    #'TAG))
+            (with-syntax ([TAG?         (make-TAG-id "" "?")]
+                          [TAG          (make-TAG-id "" "")]
+                          [make-TAG     (make-TAG-id "make-" "")]
+                          [TAG-ptr      (make-TAG-id "" "-ptr")]
+                          [TAG-length   (make-TAG-id "" "-length")]
+                          [allocate-TAG (make-TAG-id "allocate-" "")]
+                          [TAG*         (make-TAG-id "" "*")]
+                          [list->TAG    (make-TAG-id "list->" "")]
+                          [TAG->list    (make-TAG-id "" "->list")]
+                          [TAG-ref      (make-TAG-id "" "-ref")]
+                          [TAG-set!     (make-TAG-id "" "-set!")]
+                          [_TAG         (make-TAG-id "_" "")]
+                          [_TAG*        (make-TAG-id "_" "*")]
+                          [TAGname      name])
+              (set! bindings (list* #'TAG?
+                                    #'TAG-length
+                                    #'make-TAG
+                                    #'TAG
+                                    #'TAG-ref
+                                    #'TAG-set!
+                                    #'TAG->list
+                                    #'list->TAG
+                                    #'_TAG
+                                    bindings))
+              #'(begin
+                  (define-struct TAG (ptr length))
+                  (provide TAG? TAG-length)
+                  (provide (rename allocate-TAG make-TAG))
+                  (define (allocate-TAG n . init)
+                    (let* ([p (if (eq? n 0) #f (malloc n type))]
+                           [v (make-TAG p n)])
+                      (when (and p (pair? init))
+                        (let ([init (car init)])
+                          (let loop ([i (sub1 n)])
+                            (unless (< i 0)
+                              (ptr-set! p type i init)
+                              (loop (sub1 i))))))
+                      v))
+                  (provide (rename TAG* TAG))
+                  (define (TAG* . vals)
+                    (list->TAG vals))
+                  (define* (TAG-ref v i)
+                    (if (TAG? v)
+                      (if (and (integer? i) (< -1 i (TAG-length v)))
+                        (ptr-ref (TAG-ptr v) type i)
+                        (error 'TAG-ref "bad index ~e for ~a bounds of 0..~e"
+                               i 'TAG (sub1 (TAG-length v))))
+                      (raise-type-error 'TAG-ref TAGname v)))
+                  (define* (TAG-set! v i x)
+                    (if (TAG? v)
+                      (if (and (integer? i) (< -1 i (TAG-length v)))
+                        (ptr-set! (TAG-ptr v) type i x)
+                        (error 'TAG-set! "bad index ~e for ~a bounds of 0..~e"
+                               i 'TAG (sub1 (TAG-length v))))
+                      (raise-type-error 'TAG-set! TAGname v)))
+                  (define* (TAG->list v)
+                    (if (TAG? v)
+                      (cblock->list (TAG-ptr v) type (TAG-length v))
+                      (raise-type-error 'TAG->list TAGname v)))
+                  (define* (list->TAG l)
+                    (make-TAG (list->cblock l type) (length l)))
+                  ;; same as the _cvector implementation
+                  (provide _TAG)
+                  (define _TAG*
+                    (make-ctype _pointer TAG-ptr
+                      (lambda (x)
+                        (error
+                         '_cvector
+                         "cannot automatically convert a C pointer to a ~a"
+                         TAGname))))
+                  (define-fun-syntax _TAG
+                    (syntax-id-rules (i o io)
+                      [(_ i   ) _TAG*]
+                      [(_ o  n) (type: _pointer
+                                       pre:  (malloc n type)
+                                       post: (x => (make-TAG x n)))]
+                      [(_ io  ) (type: _cvector*
+                                       bind: tmp
+                                       pre:  (x => (TAG-ptr x))
+                                       post: (x => tmp))]
+                      [(_ . xs)   (_TAG* . xs)]
+                      [_          _TAG*]))
+                  )))]))
+     (lambda (stx)
+       (syntax-case stx ()
+         [(_ x) (with-syntax ([(binding ...) bindings])
+                  #'(define-syntax x
+                      (syntax-rules ()
+                        [(_) (provide binding ...)])))])))))
+
+(make-srfi-4 s8  _int8)
+(make-srfi-4 u8  _uint8)
+(make-srfi-4 s16 _int16)
+(make-srfi-4 u16 _uint16)
+(make-srfi-4 s32 _int32)
+(make-srfi-4 u32 _uint32)
+(make-srfi-4 s64 _int64)
+(make-srfi-4 u64 _uint64)
+(make-srfi-4 f32 _float)
+(make-srfi-4 f64 _double*)
+(define-srfi-4-provider provide-srfi-4)
+(provide provide-srfi-4)
+
+;; check that the types that were used above have the proper sizes
+(unless (= 4 (ctype-sizeof _float))
+  (error 'foreign "internal error: float has a bad size (~s)"
+         (ctype-sizeof _float)))
+(unless (= 8 (ctype-sizeof _double*))
+  (error 'foreign "internal error: double has a bad size (~s)"
+         (ctype-sizeof _double*)))
+
+;; ----------------------------------------------------------------------------
+;; Tagged pointers
+
+;; Make these operations available for unsafe interfaces (they can be used to
+;; grab a hidden tag value and break code).
+(provide* (unsafe cpointer-tag) (unsafe set-cpointer-tag!)
+          (unsafe cpointer-has-tag?) (unsafe cpointer-push-tag!))
+
+;; Defined as syntax for efficiency, but can be used as procedures too.
+(define-syntax (cpointer-has-tag? stx)
+  (syntax-case stx ()
+    [(_ cptr tag)
+     #'(let ([ptag (cpointer-tag cptr)])
+         (if (pair? ptag) (memq tag ptag) (eq? tag ptag)))]
+    [id (identifier? #'id)
+     #'(lambda (cptr tag) (cpointer-has-tag? cptr tag))]))
+(define-syntax (cpointer-push-tag! stx)
+  (syntax-case stx ()
+    [(_ cptr tag)
+     #'(let ([ptag (cpointer-tag cptr)])
+         (set-cpointer-tag! cptr
+           (cond [(not ptag) tag]
+                 [(pair? ptag) (cons tag ptag)]
+                 [else (list tag ptag)])))]
+    [id (identifier? #'id)
+     #'(lambda (cptr tag) (cpointer-push-tag! cptr tag))]))
+
+(define (cpointer-maker nullable?)
+  (case-lambda
+   [(tag) ((cpointer-maker nullable?) tag #f #f #f)]
+   [(tag ptr-type) ((cpointer-maker nullable?) tag ptr-type #f #f)]
+   [(tag ptr-type scheme->c c->scheme)
+    (let* ([tag->C (string->symbol (format "~a->C" tag))]
+           [error-str (format "~a`~a' pointer"
+                              (if nullable? "" "non-null ") tag)]
+           [error* (lambda (p) (raise-type-error tag->C error-str p))])
+      (let-syntax ([tag-or-error
+                    (syntax-rules ()
+                      [(tag-or-error ptr t)
+                       (let ([p ptr])
+                         (if (cpointer? p)
+                           (unless (cpointer-has-tag? p t) (error* p))
+                           (error* p)))])]
+                   [tag-or-error/null
+                    (syntax-rules ()
+                      [(tag-or-error/null ptr t)
+                       (let ([p ptr])
+                         (if (cpointer? p)
+                           (when p (unless (cpointer-has-tag? p t) (error* p)))
+                           (error* p)))])])
+        (make-ctype (or ptr-type _pointer)
+          ;; bad hack: cond outside the lambda for efficiency
+          (if nullable?
+            (if scheme->c
+              (lambda (p) (tag-or-error/null (scheme->c p) tag) p)
+              (lambda (p) (tag-or-error/null p tag) p))
+            (if scheme->c
+              (lambda (p) (tag-or-error (scheme->c p) tag) p)
+              (lambda (p) (tag-or-error p tag) p)))
+          (if nullable?
+            (if c->scheme
+              (lambda (p) (when p (cpointer-push-tag! p tag)) (c->scheme p))
+              (lambda (p) (when p (cpointer-push-tag! p tag)) p))
+            (if c->scheme
+              (lambda (p)
+                (if p (cpointer-push-tag! p tag) (error* p))
+                (c->scheme p))
+              (lambda (p)
+                (if p (cpointer-push-tag! p tag) (error* p))
+                p))))))]))
+
+;; This is a kind of a pointer that gets a specific tag when converted to
+;; Scheme, and accepts only such tagged pointers when going to C.  An optional
+;; `ptr-type' can be given to be used as the base pointer type, instead of
+;; _pointer, `scheme->c' and `c->scheme' can be used for adding conversion
+;; hooks.
+(define* _cpointer (cpointer-maker #f))
+
+;; Similar to the above, but can tolerate null pointers (#f).
+(define* _cpointer/null (cpointer-maker #t))
+
+;; A macro version of the above two functions, using the defined name for a tag
+;; string, and defining a predicate too.  The name should look like `_foo', the
+;; predicate will be `foo?', and the tag will be "foo".  In addition, `foo-tag'
+;; is bound to the tag.  The optional `ptr-type', `scheme->c', and `c->scheme'
+;; arguments are the same as those of `_cpointer'.  `_foo' will be bound to the
+;; _cpointer type, and `_foo/null' to the _cpointer/null type.
+(provide define-cpointer-type)
+(define-syntax (define-cpointer-type stx)
+  (syntax-case stx ()
+    [(_ _TYPE) #'(_ _TYPE #f #f #f)]
+    [(_ _TYPE ptr-type) #'(_ _TYPE ptr-type #f #f)]
+    [(_ _TYPE ptr-type scheme->c c->scheme)
+     (and (identifier? #'_TYPE)
+          (regexp-match #rx"^_.+" (symbol->string (syntax-e #'_TYPE))))
+     (let ([name (cadr (regexp-match #rx"^_(.+)$"
+                                     (symbol->string (syntax-e #'_TYPE))))])
+       (define (id . strings)
+         (datum->syntax-object
+          #'_TYPE (string->symbol (apply string-append strings)) #'_TYPE))
+       (with-syntax ([name-string name]
+                     [TYPE?      (id name "?")]
+                     [TYPE-tag   (id name "-tag")]
+                     [_TYPE/null (id "_" name "/null")])
+         #'(define-values (_TYPE _TYPE/null TYPE? TYPE-tag)
+             (let ([TYPE-tag name-string])
+               (values (_cpointer      TYPE-tag ptr-type scheme->c c->scheme)
+                       (_cpointer/null TYPE-tag ptr-type scheme->c c->scheme)
+                       (lambda (x)
+                         (and (cpointer? x) (cpointer-has-tag? x TYPE-tag)))
+                       TYPE-tag)))))]))
+
+;; ----------------------------------------------------------------------------
+;; Struct wrappers
+
+(define (compute-offsets types)
+  (let loop ([ts types] [cur 0] [r '()])
+    (if (null? ts)
+      (reverse! r)
+      (let* ([algn (ctype-alignof (car ts))]
+             [pos  (+ cur (modulo (- (modulo cur algn)) algn))])
+        (loop (cdr ts)
+              (+ pos (ctype-sizeof (car ts)))
+              (cons pos r))))))
+
+;; Simple structs: call this with a list of types, and get a type that marshals
+;; C structs to/from Scheme lists.
+(define* (_list-struct . types)
+  (let ([stype (make-cstruct-type types)]
+        [offsets (compute-offsets types)])
+    (make-ctype stype
+      (lambda (vals)
+        (let ([block (malloc stype)])
+          (for-each (lambda (type ofs val) (ptr-set! block type 'abs ofs val))
+                    types offsets vals)
+          block))
+      (lambda (block)
+        (map (lambda (type ofs) (ptr-ref block type 'abs ofs))
+             types offsets)))))
+
+;; (define-cstruct _foo ([slot type] ...))
+;; or
+;; (define-cstruct (_foo _super) ([slot type] ...))
+;; defines a type called _foo for a C struct, with user-procedues: make-foo,
+;; foo? foo-slot... and set-foo-slot!....  The `_' prefix is required.  Objects
+;; of this new type are actually cpointers, with a type tag that is "foo" and
+;; (possibly more if the first type is itself a cstruct type or if a super type
+;; is given,) provided as foo-tag, and tags of pointers are checked before
+;; attempting to use them (see define-cpointer-type above).  Note that since
+;; structs are implemented as pointers, they can be used for a _pointer input
+;; to a foreign function: their address will be used, to make this possible,
+;; the corresponding cpointer type is defined as _foo-pointer.  If a super
+;; cstruct type is given, the constructor function expects values for every
+;; field of the super type as well as other fields that are specified, and a
+;; slot named `super' can be used to extract this initial struct -- although
+;; pointers to the new struct type can be used as pointers to the super struct
+;; type.
+(provide define-cstruct)
+(define-syntax (define-cstruct stx)
+  (define (make-syntax _TYPE-stx has-super? slot-names-stx slot-types-stx)
+    (define name
+      (cadr (regexp-match #rx"^_(.+)$" (symbol->string (syntax-e _TYPE-stx)))))
+    (define slot-names (map (lambda (x) (symbol->string (syntax-e x)))
+                            (syntax->list slot-names-stx)))
+    (define (id . strings)
+      (datum->syntax-object
+       _TYPE-stx (string->symbol (apply string-append strings)) _TYPE-stx))
+    (define (ids name-func)
+      (map (lambda (s)
+             (datum->syntax-object
+              _TYPE-stx
+              (string->symbol (apply string-append (name-func s)))
+              _TYPE-stx))
+           slot-names))
+    (with-syntax
+        ([first-type           (let ([xs (syntax->list slot-types-stx)])
+                                 (and (pair? xs) (car xs)))]
+         [has-super?           has-super?]
+         [name-string          name]
+         [struct-string        (format "struct:~a" name)]
+         [(slot ...)           slot-names-stx]
+         [(slot-type ...)      slot-types-stx]
+         [_TYPE                _TYPE-stx]
+         [_TYPE-pointer        (id "_"name"-pointer")]
+         [_TYPE-pointer/null   (id "_"name"-pointer/null")]
+         [_TYPE/null           (id "_"name"/null")]
+         [_TYPE*               (id "_"name"*")]
+         [TYPE?                (id name"?")]
+         [make-TYPE            (id "make-"name)]
+         [list->TYPE           (id "list->"name)]
+         [list*->TYPE          (id "list*->"name)]
+         [TYPE->list           (id name"->list")]
+         [TYPE->list*          (id name"->list*")]
+         [TYPE-tag             (id name"-tag")]
+         [(stype ...)          (ids (lambda (s) `(,name"-",s"-type")))]
+         [(TYPE-SLOT ...)      (ids (lambda (s) `(,name"-",s)))]
+         [(set-TYPE-SLOT! ...) (ids (lambda (s) `("set-",name"-",s"!")))]
+         [(offset ...) (generate-temporaries
+                               (ids (lambda (s) `(,s"-offset"))))])
+      #'(define-values (_TYPE _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag
+                        make-TYPE list->TYPE list*->TYPE TYPE->list TYPE->list*
+                        TYPE-SLOT ... set-TYPE-SLOT! ...)
+          (let-values ([(super-pointer super-tags super-types super-offsets
+                         super->list* list*->super)
+                        (cstruct-info
+                         first-type
+                         (lambda () (values #f '() #f #f #f #f)))])
+            (define-cpointer-type _TYPE super-pointer)
+            ;; these makes it possible to use recursive pointer definitions
+            (define _TYPE-pointer      _TYPE)
+            (define _TYPE-pointer/null _TYPE/null)
+            (let*-values ([(stype ...)  (values slot-type ...)]
+                          [(types)      (list stype ...)]
+                          [(offsets)    (compute-offsets types)]
+                          [(offset ...) (apply values offsets)])
+              (define _TYPE* (_cpointer TYPE-tag (make-cstruct-type types)))
+              (define all-tags (cons TYPE-tag super-tags))
+              (define-values (all-types all-offsets)
+                (if (and has-super? super-types super-offsets)
+                  (values (append super-types   (cdr types))
+                          (append super-offsets (cdr offsets)))
+                  (values types offsets)))
+              (define (TYPE-SLOT x)
+                (unless (TYPE? x)
+                  (raise-type-error 'TYPE-SLOT struct-string x))
+                (ptr-ref x stype 'abs offset))
+              ...
+              (define (set-TYPE-SLOT! x slot)
+                (unless (TYPE? x)
+                  (raise-type-error 'set-TYPE-SLOT! struct-string 0 x slot))
+                (ptr-set! x stype 'abs offset slot))
+              ...
+              (define make-TYPE
+                (if (and has-super? super-types super-offsets)
+                  ;; init using all slots
+                  (lambda vals
+                    (if (= (length vals) (length all-types))
+                      (let ([block (malloc _TYPE*)])
+                        (set-cpointer-tag! block all-tags)
+                        (for-each (lambda (type ofs value)
+                                    (ptr-set! block type 'abs ofs value))
+                                  all-types all-offsets vals)
+                        block)
+                      (error '_TYPE "expecting ~s values, got ~s: ~e"
+                             (length all-types) (length vals) vals)))
+                  ;; normal initializer
+                  (lambda (slot ...)
+                    (let ([block (malloc _TYPE*)])
+                      (set-cpointer-tag! block all-tags)
+                      (ptr-set! block stype 'abs offset slot)
+                      ...
+                      block))))
+              (define (list->TYPE vals) (apply make-TYPE vals))
+              (define (list*->TYPE vals)
+                (cond
+                 [(TYPE? vals) vals]
+                 [(= (length vals) (length all-types))
+                  (let ([block (malloc _TYPE*)])
+                    (set-cpointer-tag! block all-tags)
+                    (for-each
+                     (lambda (type ofs value)
+                       (let-values
+                           ([(ptr tags types offsets T->list* list*->T)
+                             (cstruct-info
+                              type
+                              (lambda () (values #f '() #f #f #f #f)))])
+                         (ptr-set! block type 'abs ofs
+                                   (if list*->T (list*->T value) value))))
+                     all-types all-offsets vals)
+                    block)]
+                 [else (error '_TYPE "expecting ~s values, got ~s: ~e"
+                              (length all-types) (length vals) vals)]))
+              (define (TYPE->list x)
+                (unless (TYPE? x)
+                  (raise-type-error 'TYPE-list struct-string x))
+                (map (lambda (type ofs) (ptr-ref x type 'abs ofs))
+                     all-types all-offsets))
+              (define (TYPE->list* x)
+                (unless (TYPE? x)
+                  (raise-type-error 'TYPE-list struct-string x))
+                (map (lambda (type ofs)
+                       (let-values
+                           ([(v) (ptr-ref x type 'abs ofs)]
+                            [(ptr tags types offsets T->list* list*->T)
+                             (cstruct-info
+                              type
+                              (lambda () (values #f '() #f #f #f #f)))])
+                         (if T->list* (T->list* v) v)))
+                     all-types all-offsets))
+              (cstruct-info
+               _TYPE* 'set!
+               _TYPE all-tags all-types all-offsets TYPE->list* list*->TYPE)
+              (values _TYPE* _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag
+                      make-TYPE list->TYPE list*->TYPE TYPE->list TYPE->list*
+                      TYPE-SLOT ... set-TYPE-SLOT! ...))))))
+  (define (identifiers? stx)
+    (andmap identifier? (syntax->list stx)))
+  (define (_-identifier? stx)
+    (and (identifier? stx)
+         (regexp-match #rx"^_.+" (symbol->string (syntax-e stx)))))
+  (syntax-case stx ()
+    [(_ _TYPE ([slot slot-type] ...))
+     (and (_-identifier? #'_TYPE) (identifiers? #'(slot ...)))
+     (make-syntax #'_TYPE #f #'(slot ...) #'(slot-type ...))]
+    [(_ (_TYPE _SUPER) ([slot slot-type] ...))
+     (and (_-identifier? #'_TYPE) (identifiers? #'(slot ...)))
+     (with-syntax ([super (datum->syntax-object #'_TYPE 'super #'_TYPE)])
+       (make-syntax #'_TYPE #t #'(super slot ...) #'(_SUPER slot-type ...)))]))
+
+;; helper for the above: keep runtime information on structs
+(define cstruct-info
+  (let ([table (make-hash-table 'weak)])
+    (lambda (cstruct msg/fail-thunk . args)
+      (cond [(eq? 'set! msg/fail-thunk) (hash-table-put! table cstruct args)]
+            [(and cstruct ; might get a #f if there were no slots
+                  (hash-table-get table cstruct (lambda () #f)))
+             => (lambda (xs) (apply values xs))]
+            [else (msg/fail-thunk)]))))
+
+;; ----------------------------------------------------------------------------
+;; Misc utilities
+
+;; Used by set-ffi-obj! to get the actual value so it can be kept around
+(define (get-lowlevel-object x type)
+  (let ([basetype (ctype-basetype type)])
+    (if basetype
+      (let ([s->c (ctype-scheme->c type)])
+        (get-lowlevel-object (if s->c (s->c x) x) basetype))
+      (values x type))))
+
+;; Converting Scheme lists to/from C vectors (going back requires a length)
+(define* (list->cblock l type)
+  (if (null? l)
+    #f ; null => NULL
+    (let ([cblock (malloc (length l) type)])
+      (let loop ([l l] [i 0])
+        (unless (null? l)
+          (ptr-set! cblock type i (car l))
+          (loop (cdr l) (add1 i))))
+      cblock)))
+(provide* (unsafe cblock->list))
+(define (cblock->list cblock type len)
+  (cond [(zero? len) '()]
+        [(cpointer? cblock)
+         (let loop ([i (sub1 len)] [r '()])
+           (if (< i 0)
+             r
+             (loop (sub1 i) (cons (ptr-ref cblock type i) r))))]
+        [else (error 'cblock->list
+                     "expecting a non-void pointer, got ~s" cblock)]))
+
+;; Converting Scheme vectors to/from C vectors
+(define* (vector->cblock v type)
+  (let ([len (vector-length v)])
+    (if (zero? len)
+      #f ; #() => NULL
+      (let ([cblock (malloc len type)])
+        (let loop ([i (sub1 len)])
+          (unless (< i 0)
+            (ptr-set! cblock type i (vector-ref v i))
+            (loop (add1 i))))
+        cblock))))
+(provide* (unsafe cblock->vector))
+(define (cblock->vector cblock type len)
+  (cond [(zero? len) '#()]
+        [(cpointer? cblock)
+         (let ([v (make-vector len)])
+           (let loop ([i (sub1 len)])
+             (unless (< i 0)
+               (vector-set! v i (ptr-ref cblock type i))
+               (loop (sub1 i))))
+           v)]
+        [else (error 'cblock->vector
+                     "expecting a non-void pointer, got ~s" cblock)]))
+
+;; Useful for automatic definitions
+;; If a provided regexp begins with a "^" or ends with a "$", then
+;; `regexp-replace' is used, otherwise use `regexp-replace*'.
+(define* (regexp-replaces x rs)
+  (let loop ([str (if (bytes? x) (bytes->string/utf-8 x) (format "~a" x))]
+             [rs rs])
+    (if (null? rs)
+      str
+      (loop ((if (regexp-match #rx"^\\^|\\$$"
+                               (if (regexp? (caar rs))
+                                 (object-name (caar rs)) (caar rs)))
+               regexp-replace regexp-replace*)
+             (caar rs) str (cadar rs)) (cdr rs)))))
+
+;; A facility for running finalizers using executors.  #%foreign has a C-based
+;; version that uses finalizers, but that leads to calling Scheme from the GC
+;; which is not a good idea.
+(define killer-executor (make-will-executor))
+(define killer-thread
+  (thread (lambda () (let loop () (will-execute killer-executor) (loop)))))
+(define* (register-finalizer obj finalizer)
+  (will-register killer-executor obj finalizer))
+
+(define-unsafer unsafe!)
+)
diff --git a/collects/mzlib/include.ss b/collects/mzlib/include.ss
new file mode 100644
index 0000000000..26a3257933
--- /dev/null
+++ b/collects/mzlib/include.ss
@@ -0,0 +1,150 @@
+
+(module include mzscheme
+  (require-for-syntax (lib "stx.ss" "syntax")
+		      (lib "path-spec.ss" "syntax")
+		      "private/increader.ss"
+		      "cm-accomplice.ss")
+  (require (lib "etc.ss"))
+
+  (define-syntax-set (do-include ; private
+		      include-at/relative-to
+		      include
+		      include-at/relative-to/reader
+		      include/reader)
+
+    (define (do-include/proc stx)
+      (syntax-case stx ()
+	[(_ orig-stx ctx loc fn reader)
+	 ;; Parse the file name
+	 (let ([c-file (resolve-path-spec (syntax fn) (syntax loc) (syntax orig-stx) #'build-path)]
+	       [ctx (syntax ctx)]
+	       [loc (syntax loc)]
+	       [reader (syntax reader)]
+	       [orig-stx (syntax orig-stx)])
+	   
+	   (register-external-file c-file)
+
+	   (let ([read-syntax (if (syntax-e reader)
+                                  (reader-val
+                                   (let loop ([e (syntax-object->datum
+                                                  (local-expand reader 'expression null))])
+                                     (cond
+                                       [(reader? e) e]
+                                       [(pair? e) (or (loop (car e))
+                                                      (loop (cdr e)))]
+                                       [else #f])))
+				  read-syntax)])
+	     (unless (and (procedure? read-syntax)
+			  (procedure-arity-includes? read-syntax 2))
+	       (raise-syntax-error
+		#f
+		"reader is not a procedure of two arguments"
+		orig-stx))
+
+	     ;; Open the included file
+	     (let ([p (with-handlers ([exn:fail?
+				       (lambda (exn)
+					 (raise-syntax-error
+					  #f
+					  (format
+					   "can't open include file (~a)"
+					   (if (exn? exn)
+					       (exn-message exn)
+					       exn))
+					  orig-stx
+					  c-file))])
+			(open-input-file c-file))])
+	       (port-count-lines! p)
+	       ;; Read expressions from file
+	       (let ([content
+		      (let loop ()
+			(let ([r (with-handlers ([exn:fail?
+						  (lambda (exn)
+						    (close-input-port p)
+						    (raise-syntax-error
+						     #f
+						     (format
+						      "read error (~a)"
+						      (if (exn? exn)
+							  (exn-message exn)
+							  exn))
+						     orig-stx))])
+				   (read-syntax c-file p))])
+			  (if (eof-object? r)
+			      null
+			      (cons r (loop)))))])
+		 (close-input-port p)
+		 ;; Preserve src info for content, but set its
+		 ;; lexical context to be that of the include expression
+		 (let ([lexed-content
+			(let loop ([content content])
+			  (cond
+			   [(pair? content)
+			    (cons (loop (car content))
+				  (loop (cdr content)))]
+			   [(null? content) null]
+			   [else
+			    (let ([v (syntax-e content)])
+			      (datum->syntax-object
+			       ctx
+			       (cond
+				[(pair? v) 
+				 (loop v)]
+				[(vector? v)
+				 (list->vector (loop (vector->list v)))]
+				[(box? v)
+				 (box (loop (unbox v)))]
+				[else
+				 v])
+			       content))]))])
+		   (datum->syntax-object
+		    (quote-syntax here)
+		    `(begin ,@lexed-content)
+		    orig-stx))))))]))
+    
+    (define (include/proc stx)
+      (syntax-case stx ()
+	[(_ fn)
+	 (with-syntax ([_stx stx])
+	   (syntax/loc stx (do-include _stx _stx _stx fn #f)))]))
+
+    (define (include-at/relative-to/proc stx)
+      (syntax-case stx ()
+	[(_ ctx loc fn)
+	 (with-syntax ([_stx stx])
+	   (syntax/loc stx (do-include _stx ctx loc fn #f)))]))
+      
+    (define (include/reader/proc stx)
+      (syntax-case stx ()
+	[(_ fn reader)
+	 ;; Expand to do-include:
+	 (with-syntax ([_stx stx])
+	   (syntax/loc stx 
+	     (do-include _stx _stx _stx fn 
+			 (letrec-syntax ([the-reader (lambda (stx)
+						       (datum->syntax-object
+							#'here
+							(make-reader reader)))])
+			   the-reader))))]))
+    
+    (define (include-at/relative-to/reader/proc stx)
+      (syntax-case stx ()
+	[(_ ctx loc fn reader)
+	 (with-syntax ([_stx stx])
+	   (syntax/loc stx 
+	     (do-include _stx ctx loc fn 
+			 (letrec-syntax ([the-reader (lambda (stx)
+						       (datum->syntax-object
+							#'here
+							(make-reader reader)))])
+			   the-reader))))])))
+  
+  (provide include
+	   include-at/relative-to
+	   include/reader
+	   include-at/relative-to/reader))
+
+		 
+			   
+	      
+		     
diff --git a/collects/mzlib/inflate.ss b/collects/mzlib/inflate.ss
new file mode 100644
index 0000000000..45803115e4
--- /dev/null
+++ b/collects/mzlib/inflate.ss
@@ -0,0 +1,901 @@
+
+(module inflate mzscheme
+
+  (provide inflate 
+	  gunzip-through-ports
+	  gunzip)
+
+#|
+
+/* inflate.c -- Not copyrighted 1992 by Mark Adler
+   version c10p1, 10 January 1993 */
+; Taken from the gzip source distribution
+; Translated directly from C (obviously) by Matthew, April 1997
+
+/* You can do whatever you like with this source file, though I would
+   prefer that if you modify it and redistribute it that you include
+   comments to that effect with your name and the date.  Thank you.
+   [The history has been moved to the file ChangeLog.]
+   ; ChangeLog is distributed with the gzip source. 
+ */
+
+/*
+   Inflate deflated (PKZIP's method 8 compressed) data.  The compression
+   method searches for as much of the current string of bytes (up to a
+   length of 258) in the previous 32K bytes.  If it doesn't find any
+   matches (of at least length 3), it codes the next byte.  Otherwise, it
+   codes the length of the matched string and its distance backwards from
+   the current position.  There is a single Huffman code that codes both
+   single bytes (called "literals") and match lengths.  A second Huffman
+   code codes the distance information, which follows a length code.  Each
+   length or distance code actually represents a base value and a number
+   of "extra" (sometimes zero) bits to get to add to the base value.  At
+   the end of each deflated block is a special end-of-block (EOB) literal/
+   length code.  The decoding process is basically: get a literal/length
+   code; if EOB then done; if a literal, emit the decoded byte; if a
+   length then get the distance and emit the referred-to bytes from the
+   sliding window of previously emitted data.
+
+   There are (currently) three kinds of inflate blocks: stored, fixed, and
+   dynamic.  The compressor deals with some chunk of data at a time, and
+   decides which method to use on a chunk-by-chunk basis.  A chunk might
+   typically be 32K or 64K.  If the chunk is uncompressible, then the
+   "stored" method is used.  In this case, the bytes are simply stored as
+   is, eight bits per byte, with none of the above coding.  The bytes are
+   preceded by a count, since there is no longer an EOB code.
+
+   If the data is compressible, then either the fixed or dynamic methods
+   are used.  In the dynamic method, the compressed data is preceded by
+   an encoding of the literal/length and distance Huffman codes that are
+   to be used to decode this block.  The representation is itself Huffman
+   coded, and so is preceded by a description of that code.  These code
+   descriptions take up a little space, and so for small blocks, there is
+   a predefined set of codes, called the fixed codes.  The fixed method is
+   used if the block codes up smaller that way (usually for quite small
+   chunks), otherwise the dynamic method is used.  In the latter case, the
+   codes are customized to the probabilities in the current block, and so
+   can code it much better than the pre-determined fixed codes.
+ 
+   The Huffman codes themselves are decoded using a mutli-level table
+   lookup, in order to maximize the speed of decoding plus the speed of
+   building the decoding tables.  See the comments below that precede the
+   lbits and dbits tuning parameters.
+ */
+
+
+/*
+   Notes beyond the 1.93a appnote.txt:
+
+   1. Distance pointers never point before the beginning of the output
+      stream.
+   2. Distance pointers can point back across blocks, up to 32k away.
+   3. There is an implied maximum of 7 bits for the bit length table and
+      15 bits for the actual data.
+   4. If only one code exists, then it is encoded using one bit.  (Zero
+      would be more efficient, but perhaps a little confusing.)  If two
+      codes exist, they are coded using one bit each (0 and 1).
+   5. There is no way of sending zero distance codes--a dummy must be
+      sent if there are none.  (History: a pre 2.0 version of PKZIP would
+      store blocks with no distance codes, but this was discovered to be
+      too harsh a criterion.)  Valid only for 1.93a.  2.04c does allow
+      zero distance codes, which is sent as one code of zero bits in
+      length.
+   6. There are up to 286 literal/length codes.  Code 256 represents the
+      end-of-block.  Note however that the static length tree defines
+      288 codes just to fill out the Huffman codes.  Codes 286 and 287
+      cannot be used though, since there is no length base or extra bits
+      defined for them.  Similarly, there are up to 30 distance codes.
+      However, static trees define 32 codes (all 5 bits) to fill out the
+      Huffman codes, but the last two had better not show up in the data.
+   7. Unzip can check dynamic Huffman blocks for complete code sets.
+      The exception is that a single code would not be complete (see #4).
+   8. The five bits following the block type is really the number of
+      literal codes sent minus 257.
+   9. Length codes 8,16,16 are interpreted as 13 length codes of 8 bits
+      (1+6+6).  Therefore, to output three times the length, you output
+      three codes (1+1+1), whereas to output four times the same length,
+      you only need two codes (1+3).  Hmm.
+  10. In the tree reconstruction algorithm, Code = Code + Increment
+      only if BitLength(i) is not zero.  (Pretty obvious.)
+  11. Correction: 4 Bits: # of Bit Length codes - 4     (4 - 19)
+  12. Note: length code 284 can represent 227-258, but length code 285
+      really is 258.  The last length deserves its own, short code
+      since it gets used a lot in very redundant files.  The length
+      258 is special since 258 - 3 (the min match length) is 255.
+  13. The literal/length and distance code bit lengths are read as a
+      single stream of lengths.  It is possible (and advantageous) for
+      a repeat code (16, 17, or 18) to go across the boundary between
+      the two sets of lengths.
+ */
+
+|#
+
+#|
+/* Huffman code lookup table entry--this entry is four bytes for machines
+   that have 16-bit pointers (e.g. PC's in the small or medium model).
+   Valid extra bits are 0..13.  e == 15 is EOB (end of block), e == 16
+   means that v is a literal, 16 < e < 32 means that v is a pointer to
+   the next table, which codes e - 16 bits, and lastly e == 99 indicates
+   an unused code.  If a code with e == 99 is looked up, this implies an
+   error in the data. */
+|#
+
+  (define-struct huft (e b v))
+  
+  (define (huft-copy dest src)
+    (set-huft-e! dest (huft-e src))
+    (set-huft-b! dest (huft-b src))
+    (set-huft-v! dest (huft-v src)))
+  
+  (define (step start < end add1 f)
+    (let loop ([i start])
+      (when (< i end)
+	(f i)
+	(loop (add1 i)))))
+  
+  (define (subvector v offset)
+    (let* ([len (- (vector-length v) offset)]
+	   [new (make-vector len)])
+      (step 0 < len add1 
+	    (lambda (i) 
+	      (vector-set! new i (vector-ref v (+ i offset)))))
+      new))
+
+  (define (build-vector n p)
+    (let ([v (make-vector n)])
+      (step 0 < n add1 (lambda (i) (vector-set! v i (p i))))
+      v))
+
+#|
+/* The inflate algorithm uses a sliding 32K byte window on the uncompressed
+   stream to find repeated byte strings.  This is implemented here as a
+   circular buffer.  The index is updated simply by incrementing and then
+   and'ing with 0x7fff (32K-1). */
+|#
+
+  (define WSIZE 32768)
+  
+  (define border 
+    (vector 
+     16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15))
+  
+  (define cplens
+    (vector
+     3 4 5 6 7 8 9 10 11 13 15 17 19 23 27 31
+     35 43 51 59 67 83 99 115 131 163 195 227 258 0 0))
+  ; /* note: see note #13 above about the 258 in this list. */
+  (define cplext
+    (vector
+     0 0 0 0 0 0 0 0 1 1 1 1 2 2 2 2
+     3 3 3 3 4 4 4 4 5 5 5 5 0 99 99)) ; /* 99==invalid */
+  (define cpdist
+    (vector
+     1 2 3 4 5 7 9 13 17 25 33 49 65 97 129 193
+     257 385 513 769 1025 1537 2049 3073 4097 6145
+     8193 12289 16385 24577))
+  (define cpdext
+    (vector
+     0 0 0 0 1 1 2 2 3 3 4 4 5 5 6 6
+     7 7 8 8 9 9 10 10 11 11
+     12 12 13 13))
+  
+  (define mask_bits
+    (vector
+     #x0000
+     #x0001 #x0003 #x0007 #x000f #x001f #x003f #x007f #x00ff
+     #x01ff #x03ff #x07ff #x0fff #x1fff #x3fff #x7fff #xffff))
+
+  (define lbits 9) ; /* bits in base literal/length lookup table */
+  (define dbits 6) ; /* bits in base distance lookup table */
+
+
+  ; /* If BMAX needs to be larger than 16, then h and x[] should be ulg. */
+  (define BMAX 16) ; /* maximum bit length of any code (16 for explode) */
+  (define N_MAX 288) ; /* maximum number of codes in any set */
+
+(define (inflate input-port output-port)
+
+  (define slide (make-bytes WSIZE))
+  (define wp 0)
+  
+  (define (flush-output len)
+    ; write out the data
+    (write-bytes slide output-port 0 len))
+  
+  (define (check-flush)
+    (when (= wp WSIZE)
+      (flush-output WSIZE)
+      (set! wp 0)))
+
+#|
+/* Macros for inflate() bit peeking and grabbing.
+   The usage is:
+   
+        NEEDBITS(j)
+        x = b & mask_bits[j];
+        DUMPBITS(j)
+
+   where NEEDBITS makes sure that b has at least j bits in it, and
+   DUMPBITS removes the bits from b.  The macros use the variable k
+   for the number of bits in b.  Normally, b and k are register
+   variables for speed, and are initialized at the beginning of a
+   routine that uses these macros from a global bit buffer and count.
+
+   If we assume that EOB will be the longest code, then we will never
+   ask for bits with NEEDBITS that are beyond the end of the stream.
+   So, NEEDBITS should not read any more bytes than are needed to
+   meet the request.  Then no bytes need to be "returned" to the buffer
+   at the end of the last block.
+
+   However, this assumption is not true for fixed blocks--the EOB code
+   is 7 bits, but the other literal/length codes can be 8 or 9 bits.
+   (The EOB code is shorter than other codes because fixed blocks are
+   generally short.  So, while a block always has an EOB, many other
+   literal/length codes have a significantly lower probability of
+   showing up at all.)  However, by making the first table have a
+   lookup of seven bits, the EOB code will be found in that first
+   lookup, and so will not require that too many bits be pulled from
+   the stream.
+ */
+|#
+
+  (define bb 0) ; /* bit buffer */
+  (define bk 0) ; /* bits in bit buffer */
+  (define peeked 0)
+  
+  (define (NEEDBITS n)
+    (when (< bk n)
+      (let ([v (peek-byte input-port peeked)])
+	(unless (eof-object? v)
+	  (set! bb (+ bb (arithmetic-shift v bk)))
+	  ;; assume that lookahead never needs more than 32 bytes:
+	  (if (peeked . < . 32)
+	      (set! peeked (add1 peeked))
+	      (read-byte input-port))))
+      (set! bk (+ bk 8))
+      (NEEDBITS n)))
+  (define (DUMPBITS n)
+    (set! bb (arithmetic-shift bb (- n)))
+    (set! bk (- bk n)))
+  
+  (define (GETBITS n)
+    (NEEDBITS n)
+    (begin0
+      bb
+      (DUMPBITS n)))
+    
+#|
+/*
+   Huffman code decoding is performed using a multi-level table lookup.
+   The fastest way to decode is to simply build a lookup table whose
+   size is determined by the longest code.  However, the time it takes
+   to build this table can also be a factor if the data being decoded
+   is not very long.  The most common codes are necessarily the
+   shortest codes, so those codes dominate the decoding time, and hence
+   the speed.  The idea is you can have a shorter table that decodes the
+   shorter, more probable codes, and then point to subsidiary tables for
+   the longer codes.  The time it costs to decode the longer codes is
+   then traded against the time it takes to make longer tables.
+
+   This results of this trade are in the variables lbits and dbits
+   below.  lbits is the number of bits the first level table for literal/
+   length codes can decode in one step, and dbits is the same thing for
+   the distance codes.  Subsequent tables are also less than or equal to
+   those sizes.  These values may be adjusted either when all of the
+   codes are shorter than that, in which case the longest code length in
+   bits is used, or when the shortest code is *longer* than the requested
+   table size, in which case the length of the shortest code in bits is
+   used.
+
+   There are two different values for the two tables, since they code a
+   different number of possibilities each.  The literal/length table
+   codes 286 possible values, or in a flat code, a little over eight
+   bits.  The distance table codes 30 possible values, or a little less
+   than five bits, flat.  The optimum values for speed end up being
+   about one bit more than those, so lbits is 8+1 and dbits is 5+1.
+   The optimum values may differ though from machine to machine, and
+   possibly even between compilers.  Your mileage may vary.
+ */
+|#
+
+  (define (huft_build
+	   b ; int vector           /* code lengths in bits (all assumed <= BMAX) */ 
+	   n ;             /* number of codes (assumed <= N_MAX) */
+	   s ;             /* number of simple-valued codes (0..s-1) */
+	   d ; int vector                /* list of base values for non-simple codes */
+	   e ; int vector                /* list of extra bits for non-simple codes */
+	   m ; int                /* maximum lookup bits, returns actual */
+	   incomp-ok?)
+    ; return: new-t new-m ok?
+
+#|
+/* Given a list of code lengths and a maximum table size, make a set of
+   tables to decode that set of codes.  Return zero on success, one if
+   the given code set is incomplete (the tables are still built in this
+   case), two if the input is invalid (all zero length codes or an
+   oversubscribed set of lengths), and three if not enough memory. */
+|#
+    (define c (make-vector (add1 BMAX) 0))
+    (define x (make-vector (add1 BMAX)))
+    (define v (make-vector N_MAX))
+    
+    (define final-y 0)
+    (define t-result #f)
+    
+    ; (printf "n: ~s~n" n)
+
+    (let/ec return
+
+#|
+(if (= n 270)
+    (step 0 < n add1
+	     (lambda (i) (printf "b[~a] = ~a~n" i (vector-ref b i)))))
+|#
+
+      (step 0 < n add1
+	    (lambda (i) 
+	      (let ([pos (vector-ref b i)])
+		(vector-set! c pos (add1 (vector-ref c pos))))))
+
+      (when (= n (vector-ref c 0))
+	; (printf "zero~n")
+	(return #f 0 #t))
+
+#|
+(when (= n 270)
+  (step 0 <= BMAX add1
+	(lambda (i)
+	  (printf "c[~s]: ~s~n" i (vector-ref c i)))))
+|#
+
+      ; /* Find minimum and maximum length, bound m-result by those */
+      (let* ([j ; min-code-length
+	      (let loop ([j 1])
+		(cond
+		  [(> j BMAX) j]
+		  [(positive? (vector-ref c j)) j]
+		  [else (loop (add1 j))]))]
+	     [k j]
+	     [i ; max-code-length
+	      (let loop ([i BMAX])
+		(cond
+		  [(zero? i) 0]
+		  [(positive? (vector-ref c i)) i]
+		  [else (loop (sub1 i))]))]
+	     [g i]
+	     [l (min (max m j) i)]
+	     [m-result l])
+	; (printf "min: ~s max: ~s~n" k g)
+	; /* Adjust last length count to fill out codes, if needed */
+	(let-values ([(y j)
+		      (let loop ([y (arithmetic-shift 1 j)][j j])
+			(if (>= j i)
+			    (values y j)
+			    (let ([new-y (- y (vector-ref c j))])
+			      (if (negative? new-y) 
+				  (begin
+				    (error 'inflate 
+					   "bad input: more codes than bits")
+				    (return null m-result #f))
+				  (loop (* new-y 2) (add1 j))))))])
+	  ; (printf "loop y: ~s~n" y)
+	  (let ([y (- y (vector-ref c i))])
+	    (when (negative? y)
+	      (error 'inflate "bad input: more codes than bits")
+	      (return #f m-result #f))
+	    ; (printf "set c[~s] ~s + ~s~n" i (vector-ref c i) y)
+	    (vector-set! c i (+ (vector-ref c i) y))
+	    (set! final-y y)))
+	; /* Generate starting offsets into the value table for each length */
+	(vector-set! x 1 0)
+	(let* ([j (let loop ([i (sub1 i)][x-pos 2][c-pos 1][j 0])
+		    (if (zero? i)
+			j
+			(let ([v (vector-ref c c-pos)])
+			  (vector-set! x x-pos (+ j v))
+			  (loop (sub1 i) (add1 x-pos) (add1 c-pos) (+ j v)))))])
+	  ; /* Make a table of values in order of bit lengths */
+	  (let loop ([i 0][b-pos 0])
+	    (let ([j (vector-ref b b-pos)])
+	      (unless (zero? j)
+		(let ([xj (vector-ref x j)])
+		  (vector-set! x j (add1 xj))
+		  (vector-set! v xj i)))
+	      (let ([new-i (add1 i)])
+		(when (< new-i n)
+		  (loop new-i (add1 b-pos))))))
+	  
+	  ; /* Generate the Huffman codes and for each, make the table entries */
+	  (vector-set! x 0 0) ; /* first Huffman code is zero */
+	  (let ([v-pos 0] ; /* grab values in bit order */
+		[i 0]     ; /* the Huffman code of length k bits for value *p */
+		[h -1]    ; /* no tables yet--level -1 */
+		[w (- l)] ; /* bits decoded == (l * h) */
+		[u (make-vector BMAX)] ; /* table stack */
+		[q null]  ; /* points to current table */
+		[z 0]     ; /* number of entries in current table */
+		[r (make-huft 0 0 0)]) ; /* table entry for structure assignment */
+	    ; /* go through the bit lengths (k already is bits in shortest code) */
+	    (let k-loop ([k k])
+	      ; (printf "k: ~s~n" k)
+	      (when (<= k g)
+		(let ([a (vector-ref c k)])
+		  (let a-loop ([a (sub1 a)])
+		    (unless (negative? a)
+		      ; (printf "a: ~s~n" a)
+		      ; /* here i is the Huffman code of length k bits for value *p */
+		      ; /* make tables up to required level */
+		      (let kwl-loop ()
+			(when (> k (+ w l))
+			  (set! h (add1 h))
+			  (set! w (+ w l)) ; /* previous table always l bits */
+			  
+			  ; /* compute minimum size table less than or equal to l bits */
+			  (set! z (min (- g w) l)) ; /* upper limit on table size */
+
+			  ; (printf "z: ~s k: ~s w: ~s~n" z k w)
+			  
+			  (let* ([j (- k w)]
+				 [f (arithmetic-shift 1 j)])
+			    (when (> f (add1 a)) ; /* try a k-w bit table */
+			      ; /* too few codes for k-w bit table */
+			      (set! f (- f a 1)) ; /* deduct codes from patterns left */
+			      ; /* try smaller tables up to z bits */
+			      (let loop ([c-pos k])
+				(set! j (add1 j))
+				(when (< j z)
+				  (set! f (* f 2))
+				  (let* ([c-pos (add1 c-pos)]
+					 [cv (vector-ref c c-pos)])
+				    (if (<= f cv)
+					(void) ; /* enough codes to use up j bits */
+					(begin
+					  (set! f (- f cv)) ; /* else deduct codes from patterns */
+					  (loop c-pos)))))))
+			    (set! z (arithmetic-shift 1 j)) ; /* table entries for j-bit table */
+			    
+			    ; /* allocate and link in new table */
+			    ; (printf "alloc: ~a~n" z)
+			    (set! q (build-vector z (lambda (i) (make-huft 0 0 0))))
+			    
+			    (when (not t-result)
+			      (set! t-result q))
+			    
+			    (vector-set! u h q)
+			    
+			    ; /* connect to last table, if there is one */
+			    (unless (zero? h)
+			      (vector-set! x h i) ; /* save pattern for backing up */
+			      (set-huft-b! r l) ; /* bits to dump before this table */
+			      (set-huft-e! r (+ j 16)); /* bits in this table */
+			      (set-huft-v! r q) ; /* pointer to this table */
+			      (set! j (arithmetic-shift i (- l w)))
+			      ; /* connect to last table: */
+			      (huft-copy (vector-ref (vector-ref u (sub1 h)) j) r))) 
+			  
+			  (kwl-loop)))
+		      
+		      (set-huft-b! r (- k w)) ; cast uch  (- k w) if needed
+		      (if (>= v-pos n)
+			  (set-huft-e! r 99) ; /* out of values--invalid code */
+			  (let ([vv (vector-ref v v-pos)])
+			    ; (printf "*p: ~s s: ~s~n" vv s)
+			    (if (< vv s)
+				(begin
+				  (set-huft-e! r (if (< vv 256) 16 15)) ; /* 256 is end-of-block code */
+				  (set-huft-v! r vv)) ; /* simple code is just the value */
+				(begin
+				  (set-huft-e! r (vector-ref e (- vv s))) ; /* non-simple--look up in lists */
+				  (set-huft-v! r (vector-ref d (- vv s)))))
+			    (set! v-pos (add1 v-pos))))
+		      ; /* fill code-like entries with r */
+		      ; (printf "i: ~s w: ~s k: ~s~n" i w k)
+		      (let ([f (arithmetic-shift 1 (- k w))]) ; /* i repeats in table every f entries */
+			(let loop ([j (arithmetic-shift i (- w))])
+			  (when (< j z)
+			    (huft-copy (vector-ref q j) r)
+			    (loop (+ j f)))))
+		      ; /* backwards increment the k-bit code i */
+		      (let loop ([j (arithmetic-shift 1 (sub1 k))])
+			(if (positive? (bitwise-and i j))
+			    (begin
+			      (set! i (bitwise-xor i j))
+			      (loop (arithmetic-shift j -1)))
+			    (set! i (bitwise-xor i j))))
+		      ; /* backup over finished tables */
+		      (let loop ()
+			(unless (= (vector-ref x h) (bitwise-and i (sub1 (arithmetic-shift 1 w))))
+			  (set! h (sub1 h)) ; /* don't need to update q */
+			  (set! w (- w l))
+			  (loop)))
+		      
+		      (a-loop (sub1 a))))
+		  (k-loop (add1 k)))))
+	    
+	    ; /* Return #f as third if we were given an incomplete table */
+	    ; (printf "done: ~s ~s~n" final-y g)
+	    (let ([ok? (or incomp-ok?
+			   (not (and (not (zero? final-y))
+				     (not (= g 1)))))])
+	      (unless ok? 
+		      (error 'inflate "incomplete table"))
+	      (values t-result m-result ok?)))))))
+  
+  (define (inflate_codes
+	   tl ; vector of hufts ; /* literal/length tables */
+	   td ; vector of hufts ; /* distance decoder tables */
+	   bl ; /* number of bits decoded by tl */
+	   bd) ; /* number of bits decoded by td[] */
+    ; /* inflate (decompress) the codes in a deflated (compressed) block.
+    ;    Return an error code or zero if it all goes ok. */
+
+    ; /* inflate the coded data */
+
+    ; /* precompute masks for speed */
+    (define ml (vector-ref mask_bits bl))
+    (define md (vector-ref mask_bits bd))
+    (define t (void))
+    (define e 0)
+    (define n 0)
+    (define d 0)
+    
+    (let/ec return
+
+      (define (jump-to-next)
+	(let loop ()
+	  (when (= e 99)
+	    (error 'inflate "bad inflate code")
+	    (return #f))
+	  (DUMPBITS (huft-b t))
+	  (set! e (- e 16))
+	  (NEEDBITS e)
+	  (set! t (vector-ref (huft-v t) (bitwise-and bb (vector-ref mask_bits e))))
+	  (set! e (huft-e t))
+	  (when (> e 16)
+	    (loop))))
+      
+      (let loop () ; /* do until end of block */
+	(NEEDBITS bl)
+	(set! t (vector-ref tl (bitwise-and bb ml)))
+	; (printf "t->e: ~s t->b: ~s~n" (huft-e t) (huft-b t))
+	(set! e (huft-e t))
+	(if (> e 16)
+	    (jump-to-next))
+	(DUMPBITS (huft-b t))
+	; (printf "e: ~s~n" e)
+	(if (= e 16) ; /* then it's a literal */
+	    (begin
+	      (bytes-set! slide wp (huft-v t))
+	      (set! wp (add1 wp))
+	      (check-flush))
+	    (begin ; /* it's an EOB or a length */
+	      ; /* exit if end of block */
+	      (when (= e 15)
+		(return #t))
+	      
+	      ; /* get length of block to copy */
+	      (NEEDBITS e)
+	      (set! n (+ (huft-v t) (bitwise-and bb (vector-ref mask_bits e))))
+	      (DUMPBITS e)
+	      ; (printf "n: ~s bb: ~s md: ~s~n" n bb md)
+	      
+	      ; /* decode distance of block to copy */
+	      (NEEDBITS bd)
+	      (set! t (vector-ref td (bitwise-and bb md)))
+	      ; (printf "t->e: ~s t->b: ~s~n" (huft-e t) (huft-b t))
+	      (set! e (huft-e t))
+	      ; (printf "e: ~s~n" e)
+	      (when (> e 16)
+		(jump-to-next))
+	      (DUMPBITS (huft-b t))
+	      ; (printf "e: ~s~n" e)
+	      
+	      (NEEDBITS e)
+	      (set! d (modulo (- wp (huft-v t) (bitwise-and bb (vector-ref mask_bits e))) WSIZE))
+	      (DUMPBITS e)
+	      
+	      ; (printf "wp: ~s t->v: ~s d: ~s~n" wp (huft-v t) d)
+	      
+	      ; /* do the copy */
+	      (let loop ()
+		(set! d (bitwise-and d (sub1 WSIZE)))
+		(set! e (min n (- WSIZE (max d wp))))
+		(set! n (- n e))
+		(let loop ()
+		  (bytes-set! slide wp (bytes-ref slide d))
+		  (set! wp (add1 wp))
+		  (set! d (add1 d))
+		  (set! e (sub1 e))
+		  (unless (zero? e)
+		    (loop)))
+		(check-flush)
+		(unless (zero? n)
+		  (loop)))))
+	(loop))))
+  
+  (define (inflate_stored)
+    ; /* "decompress" an inflated type 0 (stored) block. */
+    
+    (let/ec return
+
+      ; /* go to byte boundary */
+      (DUMPBITS (bitwise-and bk 7))
+      
+      ; /* get the length and its complement */
+      (NEEDBITS 16)
+      (let ([n (bitwise-and bb #xffff)])
+	(DUMPBITS 16)
+	(NEEDBITS 16)
+	(unless (= n (bitwise-and (bitwise-not bb) #xffff))
+	  (error 'inflate "error in compressed data")
+	  (return #f)) ; /* error in compressed data */
+	(DUMPBITS 16)
+	
+	; /* read and output the compressed data */
+	(let loop ([n n])
+	  (when (positive? n)
+	    (NEEDBITS 8)
+	    (bytes-set! slide wp (bitwise-and bb #xff))
+	    (set! wp (add1 wp))
+	    (check-flush)
+	    (DUMPBITS 8)
+	    (loop (sub1 n))))
+	
+	#t)))
+
+  (define (inflate_fixed)
+    ; /* decompress an inflated type 1 (fixed Huffman codes) block.  We should
+    ;    either replace this with a custom decoder, or at least precompute the
+    ;    Huffman tables. */
+
+    (define l (make-vector 288))
+    
+    (step 0 < 144 add1 (lambda (i) (vector-set! l i 8)))
+    (step 144 < 256 add1 (lambda (i) (vector-set! l i 9)))
+    (step 256 < 280 add1 (lambda (i) (vector-set! l i 7)))
+    (step 280 < 288 add1 (lambda (i) (vector-set! l i 8)))
+    
+    (let-values ([(tl bl ok?)
+		  (huft_build l 288 257 cplens cplext 7 #f)])
+      
+      (if (not ok?)
+	  #f
+	  (begin
+	    (step 0 < 30 add1 (lambda (i) (vector-set! l i 5)))
+	    (let-values ([(td bd ok?)
+			  (huft_build l 30 0 cpdist cpdext 5 #t)])
+	      (if (not ok?)
+		  #f
+		  ; /* decompress until an end-of-block code */
+		  (inflate_codes tl td bl bd)))))))
+
+  (define (inflate_dynamic)
+    ; /* decompress an inflated type 2 (dynamic Huffman codes) block. */
+
+    (let/ec return
+
+      ; /* read in table lengths */
+      ; (define junk1 (begin (NEEDBITS 5) (printf "~s ~s~n" bb bk)))
+      (define nl (+ 257 (bitwise-and (GETBITS 5) #x1f)))
+      ; (define junk2 (begin (NEEDBITS 5) (printf "~s ~s~n" bb bk)))
+      (define nd (+ 1 (bitwise-and (GETBITS 5) #x1f)))
+      ; (define junk3 (begin (NEEDBITS 4) (printf "~s ~s~n" bb bk)))
+      (define nb (+ 4 (bitwise-and (GETBITS 4) #xf)))
+
+      ; (define junk8 (printf "~s ~s ~s~n" nl nd nb))
+
+      (define ll (make-vector (+ 286 30)))
+      (define i 0)
+      (define l 0)
+
+      (if (or (> nl 286) (> nd 30))
+	  (begin
+	    (error 'inflate "bad lengths")
+	    #f) ; /* bad lengths */
+	  (begin
+	    ; /* read in bit-length-code lengths */
+	    (step 0 < nb add1 
+		  (lambda (j) 
+		    (vector-set! ll (vector-ref border j) (bitwise-and (GETBITS 3) 7))))
+	    (step nb < 19 add1 
+		  (lambda (j) 
+		    (vector-set! ll (vector-ref border j) 0)))
+	    
+	    ; /* build decoding table for trees--single level, 7 bit lookup */
+	    (let-values ([(tl bl ok?)
+			  (huft_build ll 19 19 null null 7 #f)])
+	      (if (not ok?)
+		  #f
+		  (begin
+		    ; /* read in literal and distance code lengths */
+		    (let ([n (+ nl nd)]
+			  [m (vector-ref mask_bits bl)])
+		      ; (printf "bl: ~s~n" bl)
+		      (set! i 0)
+		      (set! l 0)
+		      (let loop ()
+			(when (< i n)
+			  (NEEDBITS bl)
+			  (let* ([pos (bitwise-and bb m)]
+				 [td (vector-ref tl pos)]
+				 [dmp (huft-b td)]
+				 [j (huft-v td)]
+				 [set-lit
+				  (lambda (j l)
+				    (when (> (+ i j) n)
+				      (error 'inflate "bad hop")
+				      (return #f))
+				    (let loop ([j j])
+				      (unless (zero? j)
+					(vector-set! ll i l)
+					(set! i (add1 i))
+					(loop (sub1 j)))))])
+			    (DUMPBITS dmp)
+			    ; (printf "pos: ~s j: ~s l: ~s i: ~s~n" pos j l i)
+			    (cond
+			      [(< j 16) ; /* length of code in bits (0..15) */
+			       (vector-set! ll i j)
+			       (set! l j) ; /* save last length in l */
+			       (set! i (add1 i))]
+			      [(= j 16) ; /* repeat last length 3 to 6 times */
+			       (let ([j (+ 3 (bitwise-and (GETBITS 2) 3))])
+				 (set-lit j l))]
+			      [(= j 17) ; /* 3 to 10 zero length codes */
+			       (let ([j (+ 3 (bitwise-and (GETBITS 3) 7))])
+				 (set-lit j 0)
+				 (set! l 0))]
+			      [else ; /* j == 18: 11 to 138 zero length codes */
+			       (let ([j (+ 11 (bitwise-and (GETBITS 7) #x7f))])
+				 (set-lit j 0)
+				 (set! l 0))]))
+			  (loop)))
+		      
+		      ; /* build the decoding tables for literal/length and distance codes */
+		      (let-values ([(tl bl ok?)
+				    (huft_build ll nl 257 cplens cplext lbits #f)])
+			(if (not ok?)
+			    (begin
+			      (error 'inflate "incomplete code set")
+			      #f) ; /* incomplete code set */
+			    (let-values ([(td bd ok?)
+					  (huft_build (subvector ll nl) nd 0 cpdist cpdext dbits #f)])
+			      (if (not ok?)
+				  (begin
+				    (error 'inflate "incomplete code set")
+				    #f) ; /* incomplete code set */
+				  ; /* decompress until an end-of-block code */
+				  (inflate_codes tl td bl bd)))))))))))))
+
+  (define (inflate_block)
+    ; return values: /* last block flag */ ok?
+    ; /* decompress an inflated block */
+
+    (define e-result (bitwise-and (GETBITS 1) 1))
+    
+    ; /* read in block type */
+    (define t (bitwise-and (GETBITS 2) 3))
+
+    (values e-result
+	    (case t
+	      [(2) (inflate_dynamic)]
+	      [(0) (inflate_stored)]
+	      [(1) (inflate_fixed)]
+	      [else (error 'inflate "unknown inflate type")
+		    #f])))
+
+  ;;;;;;;;;;;;;;;;;;;;;;;;
+  ; inflate starts here
+  ;;;;;;;;;;;;;;;;;;;;;;;;
+  
+  ; /* decompress an inflated entry */
+  ; /* initialize window, bit buffer */
+  (set! wp 0)
+  (set! bk 0)
+  (set! bb 0)
+
+  
+  ; /* decompress until the last block */
+  (let loop ()
+    (let-values ([(e ok?) (inflate_block)])
+      (if ok?
+	  (if (zero? e)
+	      (loop)
+	      (begin
+		; /* Undo too much lookahead. The next read will be byte aligned so we
+		; * can discard unused bits in the last meaningful byte.
+		; */
+		(let loop ()
+		  (when (>= bk 8)
+		    (set! bk (- bk 8))
+		    (set! peeked (sub1 peeked))
+		    (loop)))
+		(let loop ([peeked peeked])
+		  (when (positive? peeked)
+		    (read-byte input-port)
+		    (loop (sub1 peeked))))
+		(flush-output wp)
+		#t = (void)))
+	  #f))))
+
+  (define make-small-endian
+    (case-lambda
+     [(a b) (+ a (arithmetic-shift b 8))]
+     [(a b c d) (+ a
+		   (arithmetic-shift b 8)
+		   (arithmetic-shift c 16)
+		   (arithmetic-shift d 24))]))
+  
+  (define (do-gunzip in out name-filter)
+    (let ([header1 (read-byte in)]
+	  [header2 (read-byte in)])
+      (unless (and (= header1 #o037) (= header2 #o213))
+	(error 'gnu-unzip "bad header")))
+    (let ([compression-type (read-byte in)])
+      (unless (= compression-type #o010)
+	(error 'gnu-unzip "unknown compression type")))
+    (let* ([flags (read-byte in)]
+	   [ascii? (positive? (bitwise-and flags #b1))]
+	   [continuation? (positive? (bitwise-and flags #b10))]
+	   [has-extra-field? (positive? (bitwise-and flags #b100))]
+	   [has-original-filename? (positive? (bitwise-and flags #b1000))]
+	   [has-comment? (positive? (bitwise-and flags #b10000))]
+	   [encrypted? (positive? (bitwise-and flags #b100000))])
+      (when encrypted?
+	(error 'gnu-unzip "cannot unzip encrypted file"))
+      (when continuation?
+	(error 'gnu-unzip "cannot handle multi-part files"))
+      (let ([unix-mod-time (make-small-endian (read-byte in) (read-byte in)
+					      (read-byte in) (read-byte in))]
+	    [extra-flags (read-byte in)]
+	    [source-os (read-byte in)])
+	(when continuation?
+	  (let ([part-number (make-small-endian (read-byte in) (read-byte in))])
+	    'ok))
+	(when has-extra-field?
+	  (let ([len (make-small-endian (read-byte in) (read-byte in))])
+	    (let loop ([len len])
+	      (unless (zero? len)
+		(read-byte in)
+		(loop (sub1 len))))))
+	(let* ([read-null-term-string
+		(lambda ()
+		  (let loop ([s null])
+		    (let ([r (read-byte in)])
+		      (if (zero? r)
+			  (list->bytes (reverse! s))
+			  (loop (cons r s))))))]
+	       [original-filename (and has-original-filename?
+				       (read-null-term-string))]
+	       [comment (and has-comment? (read-null-term-string))])
+	  (when encrypted?
+	    (let loop ([n 12])
+	      (unless (zero? n)
+		(read-byte in)
+		(loop (sub1 n)))))
+	  
+	  (let-values ([(out close?) (if out
+					 (values out #f)
+					 (let-values ([(fn orig?)
+						       (if original-filename
+							   (values (bytes->path original-filename) #t)
+							   (values "unzipped" #f))])
+					   (values (open-output-file (name-filter fn orig?) 'truncate)
+						   #t)))])
+	    (dynamic-wind
+	     void
+	     (lambda () (inflate in out))
+	     (lambda () (when close? (close-output-port out)))))))))
+  
+  (define (gunzip-through-ports in out)
+    (do-gunzip in out void))
+  
+  (define gunzip
+    (case-lambda
+     [(src) (gunzip src (lambda (name from-file?) name))]
+     [(src name-filter)
+      (let ([in (open-input-file src 'binary)])
+	(dynamic-wind
+	 void
+	 (lambda () (do-gunzip in #f name-filter))
+	 (lambda () (close-input-port in))))]))	     
+)
diff --git a/collects/mzlib/info.ss b/collects/mzlib/info.ss
new file mode 100644
index 0000000000..793e937fe0
--- /dev/null
+++ b/collects/mzlib/info.ss
@@ -0,0 +1,4 @@
+
+(module info (lib "infotab.ss" "setup")
+  (define name "MzLib"))
+
diff --git a/collects/mzlib/integer-set.ss b/collects/mzlib/integer-set.ss
new file mode 100644
index 0000000000..96b0668ade
--- /dev/null
+++ b/collects/mzlib/integer-set.ss
@@ -0,0 +1,450 @@
+(module integer-set mzscheme
+  (require (lib "list.ss")
+           (lib "contract.ss"))
+  
+  #;(define-syntax test-block
+    (syntax-rules ()
+      ((_ defs (code right-ans) ...)
+       (let* defs
+         (let ((real-ans code))
+           (unless (equal? real-ans right-ans)
+             (printf "Test failed: ~e gave ~e.  Expected ~e~n"
+                     'code real-ans 'right-ans))) ...))))
+
+  (define-syntax test-block
+    (syntax-rules ()
+      ((_ x ...) (void))))
+    
+  ;; An integer-set is (make-integer-set (listof (cons int int)))
+  ;; Each cons represents a range of integers, and the entire
+  ;; set is the union of the ranges.  The ranges must be disjoint and
+  ;; increasing.  Further, adjacent ranges must have at least
+  ;; one number between them.
+  (define-struct integer-set (contents))
+  
+  (define (int? x)
+    (and (integer? x) (exact? x)))
+  
+  ;; well-formed-set? : X -> bool
+  (define (well-formed-set? x)
+    (let loop ((set x)
+               (current-num -inf.0))
+      (or
+       (null? set)
+       (and (pair? set)
+            (pair? (car set))
+            (int? (caar set))
+            (int? (cdar set))
+            (< (add1 current-num) (caar set))
+            (<= (caar set) (cdar set))
+            (loop (cdr set) (cdar set))))))
+  (test-block ()
+              ((well-formed-set? '((0 . 4) (7 . 9))) #t)
+              ((well-formed-set? '((-1 . 4))) #t)
+              ((well-formed-set? '((11 . 10))) #f)
+              ((well-formed-set? '((0 . 10) (8 . 12))) #f)
+              ((well-formed-set? '((10 . 20) (1 . 2))) #f)
+              ((well-formed-set? '((-10 . -20))) #f)
+              ((well-formed-set? '((-20 . -10))) #t)
+              ((well-formed-set? '((1 . 1))) #t)
+              ((well-formed-set? '((1 . 1) (2 . 3))) #f)
+              ((well-formed-set? '((1 . 1) (3 . 3))) #t)
+              ((well-formed-set? null) #t))
+               
+
+  
+  ;; make-range : int * int -> integer-set
+  ;; creates a set of integers between i and j.  i <= j
+  (define make-range
+    (case-lambda 
+      (() (make-integer-set null))
+      ((i) (make-integer-set (list (cons i i))))
+      ((i j) (make-integer-set (list (cons i j))))))
+  (test-block ()
+              ((integer-set-contents (make-range)) '())
+              ((integer-set-contents (make-range 12)) '((12 . 12)))
+              ((integer-set-contents (make-range 97 110)) '((97 . 110)))
+              ((integer-set-contents (make-range 111 111)) '((111 . 111))))
+   
+  
+  ;; sub-range? : (cons int int) (cons int int) -> bool
+  ;; true iff the interval [(car r1), (cdr r1)] is a subset of
+  ;; [(car r2), (cdr r2)]
+  (define (sub-range? r1 r2)
+    (and (>= (car r1) (car r2))
+         (<= (cdr r1) (cdr r2))))
+    
+  ;; overlap? : (cons int int) (cons int int) -> bool
+  ;; true iff the intervals [(car r1), (cdr r1)] and [(car r2), (cdr r2)]
+  ;; have non-empty intersections and (car r1) >= (car r2)
+  (define (overlap? r1 r2)
+    (and (>= (car r1) (car r2))
+         (>= (cdr r1) (cdr r2))
+         (<= (car r1) (cdr r2))))
+    
+  
+  ;; merge-helper : (listof (cons int int)) (listof (cons int int)) -> (listof (cons int int))
+  (define (merge-helper s1 s2)
+    (cond
+      ((null? s2) s1)
+      ((null? s1) s2)
+      (else 
+       (let ((r1 (car s1))
+             (r2 (car s2)))
+         (cond
+           ((sub-range? r1 r2) (merge-helper (cdr s1) s2))
+           ((sub-range? r2 r1) (merge-helper s1 (cdr s2)))
+           ((or (overlap? r1 r2) (= (car r1) (add1 (cdr r2))))
+            (merge-helper (cons (cons (car r2) (cdr r1)) (cdr s1)) (cdr s2)))
+           ((or (overlap? r2 r1) (= (car r2) (add1 (cdr r1))))
+            (merge-helper (cdr s1) (cons (cons (car r1) (cdr r2)) (cdr s2))))
+           ((< (car r1) (car r2))
+            (cons r1 (merge-helper (cdr s1) s2)))
+           (else
+            (cons r2 (merge-helper s1 (cdr s2)))))))))
+  (test-block ()
+              ((merge-helper null null) null)
+              ((merge-helper null '((1 . 10))) '((1 . 10)))
+              ((merge-helper '((1 . 10)) null) '((1 . 10)))
+              ;; r1 in r2
+              ((merge-helper '((5 . 10)) '((5 . 10))) '((5 . 10)))
+              ((merge-helper '((6 . 9)) '((5 . 10))) '((5 . 10)))
+              ((merge-helper '((7 . 7)) '((5 . 10))) '((5 . 10)))
+              ;; r2 in r1
+              ((merge-helper '((5 . 10)) '((5 . 10))) '((5 . 10)))
+              ((merge-helper '((5 . 10)) '((6 . 9))) '((5 . 10)))
+              ((merge-helper '((5 . 10)) '((7 . 7))) '((5 . 10)))
+              ;; r2 and r1 are disjoint
+              ((merge-helper '((5 . 10)) '((12 . 14))) '((5 . 10) (12 . 14)))
+              ((merge-helper '((12 . 14)) '((5 . 10))) '((5 . 10) (12 . 14)))
+              ;; r1 and r1 are adjacent
+              ((merge-helper '((5 . 10)) '((11 . 13))) '((5 . 13)))
+              ((merge-helper '((11 . 13)) '((5 . 10))) '((5 . 13)))
+              ;; r1 and r2 overlap
+              ((merge-helper '((5 . 10)) '((7 . 14))) '((5 . 14)))
+              ((merge-helper '((7 . 14)) '((5 . 10))) '((5 . 14)))
+              ((merge-helper '((5 . 10)) '((10 . 14))) '((5 . 14)))
+              ((merge-helper '((7 . 10)) '((5 . 7))) '((5 . 10)))
+              ;; with lists
+              ((merge-helper '((1 . 1) (3 . 3) (5 . 10) (100 . 200))
+                      '((2 . 2) (10 . 12) (300 . 300)))
+               '((1 . 3) (5 . 12) (100 . 200) (300 . 300)))
+              ((merge-helper '((1 . 1) (3 . 3) (5 . 5) (8 . 8) (10 . 10) (12 . 12))
+                      '((2 . 2) (4 . 4) (6 . 7) (9 . 9) (11 . 11)))
+               '((1 . 12)))
+              ((merge-helper '((2 . 2) (4 . 4) (6 . 7) (9 . 9) (11 . 11))
+                      '((1 . 1) (3 . 3) (5 . 5) (8 . 8) (10 . 10) (12 . 12)))
+               '((1 . 12))))
+                      
+  ;; merge : integer-set integer-set -> integer-set
+  ;; Union of s1 and s2
+  (define (merge s1 s2)
+    (make-integer-set (merge-helper (integer-set-contents s1) (integer-set-contents s2))))
+  
+  ;; split-sub-range : (cons int int) (cons int int) -> char-set
+  ;; (subrange? r1 r2) must hold.
+  ;; returns [(car r2), (cdr r2)] - ([(car r1), (cdr r1)] intersect [(car r2), (cdr r2)]).
+  (define (split-sub-range r1 r2)
+    (let ((r1-car (car r1))
+          (r1-cdr (cdr r1))
+          (r2-car (car r2))
+          (r2-cdr (cdr r2)))
+      (cond
+        ((and (= r1-car r2-car) (= r1-cdr r2-cdr)) null)
+        ((= r1-car r2-car) (list (cons (add1 r1-cdr) r2-cdr)))
+        ((= r1-cdr r2-cdr) (list (cons r2-car (sub1 r1-car))))
+        (else
+         (list (cons r2-car (sub1 r1-car)) (cons (add1 r1-cdr) r2-cdr))))))
+
+  (test-block ()
+              ((split-sub-range '(1 . 10) '(1 . 10)) '())
+              ((split-sub-range '(1 . 5) '(1 . 10)) '((6 . 10)))
+              ((split-sub-range '(2 . 10) '(1 . 10)) '((1 . 1)))
+              ((split-sub-range '(2 . 5) '(1 . 10)) '((1 . 1) (6 . 10))))
+  
+  
+  ;; split-acc : (listof (cons int int))^5 -> integer-set^3
+  (define (split-acc s1 s2 i s1-i s2-i)
+    (cond
+      ((null? s1) (values (make-integer-set (reverse! i))
+                          (make-integer-set (reverse! s1-i))
+                          (make-integer-set (reverse! (append! (reverse s2) s2-i)))))
+      ((null? s2) (values (make-integer-set (reverse! i))
+                          (make-integer-set (reverse! (append! (reverse s1) s1-i)))
+                          (make-integer-set (reverse! s2-i))))
+      (else
+       (let ((r1 (car s1))
+             (r2 (car s2)))
+         (cond
+           ((sub-range? r1 r2)
+            (split-acc (cdr s1) (append (split-sub-range r1 r2) (cdr s2))
+                       (cons r1 i) s1-i s2-i))
+           ((sub-range? r2 r1)
+            (split-acc (append (split-sub-range r2 r1) (cdr s1)) (cdr s2)
+                       (cons r2 i) s1-i s2-i))
+           ((overlap? r1 r2)
+            (split-acc (cons (cons (add1 (cdr r2)) (cdr r1)) (cdr s1))
+                       (cdr s2)
+                       (cons (cons (car r1) (cdr r2)) i)
+                       s1-i 
+                       (cons (cons (car r2) (sub1 (car r1))) s2-i)))
+           ((overlap? r2 r1)
+            (split-acc (cdr s1)
+                       (cons (cons (add1 (cdr r1)) (cdr r2)) (cdr s2))
+                       (cons (cons (car r2) (cdr r1)) i)
+                       (cons (cons (car r1) (sub1 (car r2)))s1-i )
+                       s2-i))
+           ((< (car r1) (car r2))
+            (split-acc (cdr s1) s2 i (cons r1 s1-i) s2-i))
+           (else
+            (split-acc s1 (cdr s2) i s1-i (cons r2 s2-i))))))))
+  
+  ;; split : integer-set integer-set -> integer-set integer-set integer-set
+  ;; returns (s1 intersect s2), s1 - (s1 intersect s2) and s2 - (s1 intersect s2)
+  ;; Of course, s1 - (s1 intersect s2) = s1 intersect (complement s2) = s1 - s2
+  (define (split s1 s2)
+    (split-acc (integer-set-contents s1) (integer-set-contents s2) null null null))
+    
+  ;; intersect: integer-set integer-set -> integer-set
+  (define (intersect s1 s2)
+    (let-values (((i s1-s2 s2-s1) (split s1 s2)))
+      i))
+         
+  ;; difference: integer-set integer-set -> integer-set
+  (define (difference s1 s2)
+    (let-values (((i s1-s2 s2-s1) (split s1 s2)))
+      s1-s2))
+  
+  ;; xor: integer-set integer-set -> integer-set
+  (define (xor s1 s2)
+    (let-values (((i s1-s2 s2-s1) (split s1 s2)))
+      (merge s1-s2 s2-s1)))
+  
+  (test-block ((s (lambda (s1 s2)
+                    (map integer-set-contents
+                         (call-with-values (lambda () (split (make-integer-set s1)
+                                                             (make-integer-set s2))) list)))))
+              ((s null null) '(() () ()))
+              ((s '((1 . 10)) null) '(() ((1 . 10)) ()))
+              ((s null '((1 . 10))) '(() () ((1 . 10))))
+              ((s '((1 . 10)) null) '(() ((1 . 10)) ()))
+              ((s '((1 . 10)) '((1 . 10))) '(((1 . 10)) () ()))
+              ((s '((1 . 10)) '((2 . 5))) '(((2 . 5)) ((1 . 1) (6 . 10)) ()))
+              ((s '((2 . 5)) '((1 . 10))) '(((2 . 5)) () ((1 . 1) (6 . 10))))
+              ((s '((2 . 5)) '((5 . 10))) '(((5 . 5)) ((2 . 4)) ((6 . 10))))
+              ((s '((5 . 10)) '((2 . 5))) '(((5 . 5)) ((6 . 10)) ((2 . 4))))
+              ((s '((2 . 10)) '((5 . 14))) '(((5 . 10)) ((2 . 4)) ((11 . 14))))
+              ((s '((5 . 14)) '((2 . 10))) '(((5 . 10)) ((11 . 14)) ((2 . 4))))
+              ((s '((10 . 20)) '((30 . 50))) '(() ((10 . 20)) ((30 . 50))))
+              ((s '((100 . 200)) '((30 . 50))) '(() ((100 . 200)) ((30 . 50))))
+              ((s '((1 . 5) (7 . 9) (100 . 200) (500 . 600) (600 . 700))
+                  '((2 . 8) (50 . 60) (101 . 104) (105 . 220)))
+               '(((2 . 5) (7 . 8) (101 . 104) (105 . 200))
+                 ((1 . 1) (9 . 9) (100 . 100) (500 . 600) (600 . 700))
+                 ((6 . 6) (50 . 60) (201 . 220))))
+              ((s '((2 . 8) (50 . 60) (101 . 104) (105 . 220))
+                  '((1 . 5) (7 . 9) (100 . 200) (500 . 600) (600 . 700)))
+               '(((2 . 5) (7 . 8) (101 . 104) (105 . 200))
+                 ((6 . 6) (50 . 60) (201 . 220))
+                 ((1 . 1) (9 . 9) (100 . 100) (500 . 600) (600 . 700))))
+              )
+  
+  ;; complement-helper : (listof (cons int int)) int int -> (listof (cons int int))
+  ;; The current-nat accumulator keeps track of where the
+  ;; next range in the complement should start.
+  (define (complement-helper s min max)
+    (cond
+      ((null? s) (if (<= min max)
+                     (list (cons min max))
+                     null))
+      (else
+       (let ((s-car (car s)))
+         (cond
+           ((< min (car s-car))
+            (cons (cons min (sub1 (car s-car)))
+                  (complement-helper (cdr s) (add1 (cdr s-car)) max)))
+           ((<= min (cdr s-car))
+            (complement-helper (cdr s) (add1 (cdr s-car)) max))
+           (else
+            (complement-helper (cdr s) min max)))))))
+  
+    
+  ;; complement : integer-set int int -> integer-set
+  ;; A set of all the nats not in s and between min and max, inclusive.
+  ;; min <= max
+  (define (complement s min max)
+    (make-integer-set (complement-helper (integer-set-contents s) min max)))
+  (test-block ((c (lambda (a b c)
+                    (integer-set-contents (complement (make-integer-set a) b c)))))
+              ((c null 0 255) '((0 . 255)))
+              ((c '((1 . 5) (7 . 7) (10 . 200)) 0 255)
+               '((0 . 0) (6 . 6) (8 . 9) (201 . 255)))
+              ((c '((0 . 254)) 0 255) '((255 . 255)))
+              ((c '((1 . 255)) 0 255) '((0 . 0)))
+              ((c '((0 . 255)) 0 255) null)
+              ((c '((1 . 10)) 2 5) null)
+              ((c '((1 . 5) (7 . 12)) 2 8) '((6 . 6)))
+              ((c '((1 . 5) (7 . 12)) 6 6) '((6 . 6)))
+              ((c '((1 . 5) (7 . 12)) 7 7) '()))
+                                           
+  
+  ;; member?-helper : int (listof (cons int int)) -> bool
+  (define (member?-helper i is)
+    (and
+      (pair? is)
+      (or (<= (caar is) i (cdar is))
+          (member?-helper i (cdr is)))))
+  
+  ;; member? : int integer-set -> bool
+  (define (member? i is)
+    (member?-helper i (integer-set-contents is)))
+  (test-block ()
+              ((member? 1 (make-integer-set null)) #f)
+              ((member? 19 (make-integer-set '((1 . 18) (20 . 21)))) #f)
+              ((member? 19 (make-integer-set '((1 . 2) (19 . 19) (20 . 21)))) #t))
+     
+  
+  ;; get-integer : integer-set -> (union int #f)
+  (define (get-integer is)
+    (let ((l (integer-set-contents is)))
+      (cond
+        ((null? l) #f)
+        (else (caar l)))))
+  (test-block ()
+              ((get-integer (make-integer-set null)) #f)
+              ((get-integer (make-integer-set '((1 . 2) (5 . 6)))) 1))
+    
+  ;; is-foldr-helper : (int Y -> Y) Y int int (listof (cons int int)) -> Y
+  (define (is-foldr-helper f base start stop is)
+    (cond
+      ((and (> start stop) (null? is)) base)
+      ((> start stop)
+       (is-foldr-helper f base (caar is) (cdar is) (cdr is)))
+      (else
+       (f start
+          (is-foldr-helper f base (add1 start) stop is)))))
+  
+  ;; is-foldr : (int Y -> Y) Y integer-set -> Y
+  (define (is-foldr f base is)
+    (let ((l (integer-set-contents is)))
+      (cond
+        ((null? l) base)
+        (else
+         (is-foldr-helper f base (caar l) (cdar l) (cdr l))))))
+
+  (test-block ()
+              ((is-foldr cons null (make-integer-set null)) null)
+              ((is-foldr cons null (make-integer-set '((1 . 2) (5 . 10))))
+               '(1 2 5 6 7 8 9 10)))
+
+  ;; partition : (listof integer-set) -> (listof integer-set)
+  ;; The coarsest refinment r of sets such that the integer-sets in r
+  ;; are pairwise disjoint.
+  (define (partition sets)
+    (map make-integer-set (foldr partition1 null sets)))
+    
+  ;; partition1 : integer-set (listof (listof (cons int int))) -> (listof (listof (cons int int)))
+  ;; All the integer-sets in sets must be pairwise disjoint.  Splits set
+  ;; against each element in sets.
+  (define (partition1 set sets)
+    (let ((set (integer-set-contents set)))
+      (cond
+        ((null? set) sets)
+        ((null? sets) (list set))
+        (else
+         (let ((set2 (car sets)))
+           (let-values (((i s1 s2) (split-acc set set2 null null null)))
+             (let ((rest (partition1 s1 (cdr sets)))
+                   (i (integer-set-contents i))
+                   (s2 (integer-set-contents s2)))
+               (cond
+                 ((null? i)
+                  (cons s2 rest))
+                 ((null? s2)
+                  (cons i rest))
+                 (else
+                  (cons i (cons s2 rest)))))))))))
+  (test-block ((->is (lambda (str)
+                     (foldr (lambda (c cs)
+                              (merge (make-range (char->integer c))
+                                     cs))
+                            (make-range)
+                            (string->list str))))
+               (->is2 (lambda (str)
+                      (integer-set-contents (->is str)))))
+              ((partition null) null)
+              ((map integer-set-contents (partition (list (->is "1234")))) (list (->is2 "1234")))
+              ((map integer-set-contents (partition (list (->is "1234") (->is "0235"))))
+               (list (->is2 "23") (->is2 "05") (->is2 "14")))
+              ((map integer-set-contents (partition (list (->is "12349") (->is "02359") (->is "67") (->is "29"))))
+               (list (->is2 "29") (->is2 "67") (->is2 "3") (->is2 "05") (->is2 "14")))
+              ((partition1 (->is "bcdjw") null) (list (->is2 "bcdjw")))
+              ((partition1 (->is "") null) null)
+              ((partition1 (->is "") (list (->is2 "a") (->is2 "b") (->is2 "1")))
+               (list (->is2 "a") (->is2 "b") (->is2 "1")))
+              ((partition1 (->is "bcdjw")
+                           (list (->is2 "z")
+                                 (->is2 "ab")
+                                 (->is2 "dj")))
+               (list (->is2 "z") (->is2 "b") (->is2 "a") (->is2 "dj") (->is2 "cw"))))
+
+  
+  ;; card : integer-set -> nat
+  (define (card s)
+    (foldr (lambda (range sum) (+ 1 sum (- (cdr range) (car range))))
+           0
+           (integer-set-contents s)))
+  (test-block ()
+              ((card (make-integer-set null)) 0)
+              ((card (make-integer-set '((1 . 1)))) 1)
+              ((card (make-integer-set '((-1 . 10)))) 12)
+              ((card (make-integer-set '((-10 . -5) (-1 . 10) (12 . 12)))) 19))
+             
+    
+  ;; subset?-helper : (listof (cons int int)) (listof (cons int int)) -> bool
+  (define (subset?-helper l1 l2)
+    (cond
+      ((null? l1) #t)
+      ((null? l2) #f)
+      (else
+       (let ((r1 (car l1))
+             (r2 (car l2)))
+         (cond
+           ((sub-range? r1 r2) (subset?-helper (cdr l1) l2))
+           ((<= (car r1) (cdr r2)) #f)
+           (else (subset?-helper l1 (cdr l2))))))))
+  (test-block ()
+              ((subset?-helper null null) #t)
+              ((subset?-helper null '((1 . 1))) #t)
+              ((subset?-helper '((1 . 1)) null) #f)
+              ((subset?-helper '((1 . 1)) '((0 . 10))) #t)
+              ((subset?-helper '((1 . 1)) '((2 . 10))) #f)
+              ((subset?-helper '((-4 . -4) (2 . 10)) '((-20 . -17) (-15 . -10) (-5 . -4) (-2 . 0) (1 . 12))) #t)
+              ((subset?-helper '((-4 . -3) (2 . 10)) '((-20 . -17) (-15 . -10) (-5 . -4) (-2 . 0) (1 . 12))) #f)
+              ((subset?-helper '((-4 . -4) (2 . 10)) '((-20 . -17) (-15 . -10) (-5 . -4) (-2 . 0) (3 . 12))) #f))
+              
+  
+         
+  ;; subset? : integer-set integer-set -> bool
+  (define (subset? s1 s2)
+    (subset?-helper (integer-set-contents s1) (integer-set-contents s2)))
+    
+  (define int (flat-named-contract "exact-integer" int?))
+  (provide/contract (struct integer-set ((contents (flat-named-contract "integer-set-list" well-formed-set?))))
+                    (make-range (case-> (-> integer-set?)
+                                        (int . ->  . integer-set?)
+                                        (((i int) (j (and/c int (>=/c i)))) . ->r . integer-set?)))
+                    (rename merge union (integer-set? integer-set? . -> . integer-set?))
+                    (split (integer-set? integer-set? . -> . (values integer-set? integer-set? integer-set?)))
+                    (intersect (integer-set? integer-set? . -> . integer-set?))
+                    (difference (integer-set? integer-set? . -> . integer-set?))
+                    (xor (integer-set? integer-set? . -> . integer-set?))
+                    (complement (((s integer-set?) (min int) (max (and/c int (>=/c min)))) . ->r . integer-set?))
+                    (member? (int integer-set? . -> . any))
+                    (get-integer (integer-set? . -> . (union false/c int)))
+                    (rename is-foldr foldr (any/c any/c integer-set? . -> . any))
+                    (partition ((listof integer-set?) . -> . (listof integer-set?)))
+                    (card (integer-set? . -> . natural-number/c))
+                    (subset? (integer-set? integer-set? . -> . any)))
+
+  ) 
diff --git a/collects/mzlib/list.ss b/collects/mzlib/list.ss
new file mode 100644
index 0000000000..a95ce77026
--- /dev/null
+++ b/collects/mzlib/list.ss
@@ -0,0 +1,337 @@
+
+(module list mzscheme
+  (require "spidey.ss")
+
+  (provide set-first!
+	  first
+	  second
+	  third
+	  fourth
+	  fifth
+	  sixth
+	  seventh
+	  eighth
+
+	  set-rest!
+	  rest
+
+	  cons?
+	  empty
+	  empty?
+
+	  foldl
+	  foldr
+
+	  last-pair
+
+	  remv
+	  remq
+	  remove
+	  remv*
+	  remq*
+	  remove*
+
+	  assf
+	  memf
+
+	  filter
+	  
+	  quicksort
+	  mergesort)
+  
+  (define quicksort
+    (polymorphic
+     (lambda (l less-than)
+       (unless (list? l)
+	 (raise-type-error 'quicksort "proper list" l))
+       (unless (procedure-arity-includes? less-than 2)
+	 (raise-type-error 'quicksort "procedure of arity 2" less-than))
+       (let* ([v (list->vector l)]
+              [count (vector-length v)])
+	 (let loop ([min 0][max count])
+           (if (< min (sub1 max))
+               (let ([pval (vector-ref v min)])
+                 (let pivot-loop ([pivot min]
+                                  [pos (add1 min)])
+                   (if (< pos max)
+                       (let ([cval (vector-ref v pos)])
+                         (if (less-than cval pval)
+                             (begin
+                               (vector-set! v pos (vector-ref v pivot))
+                               (vector-set! v pivot cval)
+                               (pivot-loop (add1 pivot) (add1 pos)))
+                             (pivot-loop pivot (add1 pos))))
+                       (if (= min pivot)
+                           (loop (add1 pivot) max)
+                           (begin
+                             (loop min pivot)
+                             (loop pivot max))))))))
+         (vector->list v)))))
+
+  (define mergesort
+    (polymorphic
+     (lambda (alox less-than)
+       (letrec ([split (lambda (alox r)
+			 (cond
+			  [(null? alox) r]
+			  [(null? (cdr alox)) (cons alox r)]
+			  [else (split (cdr alox) (cons (list (car alox)) r))]))]
+		[merge (lambda (l1 l2 r)
+			 (cond
+			  [(null? l1) (append! (reverse! r) l2)]
+			  [(null? l2) (append! (reverse! r) l1)]
+			  [(less-than (car l1) (car l2)) 
+			   (merge (cdr l1) l2 (cons (car l1) r))]
+			  [else (merge (cdr l2) l1 (cons (car l2) r))]))]
+		[map2 (lambda (l)
+			(cond
+			 [(null? l) '()]
+			 [(null? (cdr l)) l]
+			 [else (cons (merge (car l) (cadr l) null) 
+				     (map2 (cddr l)))]))]
+		[until (lambda (l)
+			 (if (null? (cdr l)) 
+			     (car l) 
+			     (until (map2 l))))])
+	 (if (null? alox)
+	     null
+	     (until (split alox null)))))))
+
+  (define remove
+    (polymorphic
+     (letrec ([rm (case-lambda 
+                   [(item list) (rm item list equal?)]
+                   [(item list equal?)
+                    (let loop ([list list])
+                      (cond
+			[(null? list) ()]
+			[(equal? item (car list)) (cdr list)]
+			[else (cons (car list)
+				    (loop (cdr list)))]))])])
+       rm)))
+  
+  (define remq
+    (polymorphic
+     (lambda (item list)
+       (remove item list eq?))))
+  
+  (define remv
+    (polymorphic
+     (lambda (item list)
+       (remove item list eqv?))))
+  
+  (define remove*
+    (polymorphic
+     (case-lambda
+      [(l r equal?)
+       (cond 
+	[(null? r) null]
+	[else (let ([first-r (car r)])
+		(let loop ([l-rest l])
+		  (cond 
+		   [(null? l-rest) (cons first-r (remove* l (cdr r) equal?))]
+		   [(equal? (car l-rest) first-r) (remove* l (cdr r) equal?)]
+		   [else (loop (cdr l-rest))])))])]
+      [(l r) (remove* l r equal?)])))
+  
+  (define remq*
+    (polymorphic
+     (lambda (l r)
+       (remove* l r eq?))))
+  
+  (define remv*
+    (polymorphic
+     (lambda (l r)
+       (remove* l r eqv?))))
+  
+  ;; fold : ((A B -> B) B (listof A) -> B)
+  ;; fold : ((A1 ... An B -> B) B (listof A1) ... (listof An) -> B)
+  
+  ;; foldl builds "B" from the beginning of the list to the end of the
+  ;; list and foldr builds the "B" from the end of the list to the
+  ;; beginning of the list.
+  
+  (define mapadd
+    (polymorphic
+     (lambda (f l last)
+       (letrec ((helper
+                 (lambda (l)
+                   (cond
+		     [(null? l) (list last)]
+		     [else (cons (f (car l)) (helper (cdr l)))]))))
+         (helper l)))))
+  
+  (define foldl
+    (polymorphic
+     (letrec ((fold-one
+               (lambda (f init l)
+                 (letrec ((helper
+                           (lambda (init l)
+                             (cond
+			       [(null? l) init]
+			       [else (helper (f (car l) init) (cdr l))]))))
+                   (helper init l))))
+              (fold-n
+               (lambda (f init  l)
+                 (cond
+		   [(ormap null? l)
+		    (if (andmap null? l) 
+			init
+			(error 'foldl "received non-equal length input lists"))]
+		   [else (fold-n
+			  f
+			  (apply f (mapadd car l init))
+			  (map cdr l))]))))
+       (case-lambda
+        [(f init l) (fold-one f init l)]
+        [(f init l . ls) (fold-n f init (cons l ls))]))))
+  
+  (define foldr
+    (polymorphic
+     (letrec ((fold-one
+               (lambda (f init l)
+                 (letrec ((helper
+                           (lambda (init l)
+                             (cond
+			       [(null? l) init]
+			       [else (f (car l) (helper init (cdr l)))]))))
+                   (helper init l))))
+              (fold-n
+               (lambda (f init l)
+                 (cond
+		   [(ormap null? l)
+		    (if (andmap null? l)
+			init
+			(error 'foldr "received non-equal length input lists"))]
+		   [else (apply f
+				(mapadd car l
+					(fold-n f init (map cdr l))))]))))
+       (case-lambda
+        [(f init l) (fold-one f init l)]
+        [(f init l . ls) (fold-n f init (cons l ls))]))))
+  
+  (define make-find
+    (lambda (name whole-list?)
+      (polymorphic
+       (lambda (f list)
+         (unless (and (procedure? f)
+                      (procedure-arity-includes? f 1))
+           (raise-type-error name "procedure (arity 1)" f))
+         (let loop ([l list])
+           (cond
+	     [(null? l) #f]
+	     [(not (pair? l)) 
+	      (raise (make-exn:fail:contract
+		      (format "~a: second argument must be a (proper) list; given ~e" name list)
+		      (current-continuation-marks)))]
+	     [else (let ([a (car l)])
+		     (if whole-list?
+			 (if (f a)
+			     l
+			     (loop (cdr l)))
+			 (if (pair? a)
+			     (if (f (car a))
+				 a
+				 (loop (cdr l)))
+			     (raise-mismatch-error
+			      name
+			      "found a non-pair in the list: "
+			      a))))]))))))
+
+  (define assf
+    (let ([a (make-find 'assf #f)])
+      (polymorphic
+       (lambda (f l)
+	 (a f l)))))
+  
+  (define memf
+    (let ([a (make-find 'memf #t)])
+      (polymorphic
+       (lambda (f l)
+	 (a f l)))))
+  
+  (define filter
+    (polymorphic
+     (lambda (f list)
+       (unless (and (procedure? f)
+                    (procedure-arity-includes? f 1))
+         (raise-type-error 'filter "procedure (arity 1)" f))
+       ;; We use the reverse! trick because it's too easy to
+       ;;  overflow the internal stack using natural recursion.
+       ;; It's too bad that our Scheme system is so bad, but
+       ;;  until someone fixes it...
+       (let loop ([l list][result null])
+         (cond
+	   [(null? l) (reverse! result)]
+	   [(pair? l)
+	    (loop (cdr l) (if (f (car l))
+			      (cons (car l) result)
+			      result))]
+	   [else (raise-mismatch-error
+		  'filter
+		  "expects a proper list: "
+		  list)])))))
+  
+  (define first (polymorphic (lambda (x) 
+                               (unless (pair? x)
+                                 (raise-type-error 'first "non-empty list" x))
+                               (car x))))
+  (define set-first! 
+    (polymorphic (lambda (x v)
+                   (unless (pair? x)
+                     (raise-type-error 'set-first! "non-empty list" x))
+                   (set-car! x v))))
+  (define (lget name npos)
+    (lambda (x)
+      (let loop ([l x][pos npos])
+	(cond
+	 [(and (= pos 1) (pair? l))
+	  (car l)]
+	 [(pair? l)
+	  (loop (cdr l) (sub1 pos))]
+	 [else
+	  (raise-type-error name 
+			    (format "list with ~a or more items" npos) 
+			    x)]))))
+
+  ;; Gives the function a name:
+  (define-syntax (mk-lget stx)
+    (syntax-case stx ()
+      [(_ name pos)
+       (syntax (polymorphic (let ([g (lget 'name pos)])
+			      (lambda (x) (g x)))))]))
+
+  (define second (mk-lget second 2))
+  (define third (mk-lget third 3))
+  (define fourth (mk-lget fourth 4))
+  (define fifth (mk-lget fifth 5))
+  (define sixth (mk-lget sixth 6))
+  (define seventh (mk-lget seventh 7))
+  (define eighth (mk-lget eighth 8))
+  
+  (define rest (polymorphic (lambda (x) 
+                              (unless (pair? x)
+                                (raise-type-error 'rest "non-empty list" x))
+                              (cdr x))))
+  
+  (define set-rest! (polymorphic (lambda (x v)
+                                   (unless (pair? x)
+                                     (raise-type-error 'set-rest! "non-empty list" x))
+                                   (unless (or (null? v) (pair? v))
+                                     (raise-type-error 'set-rest! "second argument must be a list" v))
+                                   (set-cdr! x v))))
+    
+  (define last-pair
+    (polymorphic
+     (lambda (l)
+       (if (pair? l)
+	   (let loop ((l l) (x (cdr l)))
+	     (if (pair? x)
+		 (loop x (cdr x))
+		 l))
+	   (raise-type-error 'last-pair "pair" l)))))
+
+  (define cons? (lambda (x) (pair? x)))
+  (define empty? (lambda (x) (null? x)))
+  (define empty '()))
+
diff --git a/collects/mzlib/match.ss b/collects/mzlib/match.ss
new file mode 100644
index 0000000000..17f2d9cf85
--- /dev/null
+++ b/collects/mzlib/match.ss
@@ -0,0 +1,197 @@
+;; (documentation (name match))
+;; <pre>Pattern Matching Syntactic Extensions for Scheme
+;;
+;; All bugs or questions concerning this software should be directed to
+;; Bruce Hauman <bhauman@cs.wcu.edu>.  The latest version of this software
+;; can be obtained from http://sol.cs.wcu.edu/~bhauman/scheme/pattern.php.
+;;
+;; Special thanks go out to:
+;; Robert Bruce Findler for support and bug detection.
+;; Doug Orleans for pointing out that pairs should be reused while
+;; matching lists.
+;;
+;;
+;; Originally written by Andrew K. Wright, 1993 (wright@research.nj.nec.com)
+;; which in turn was adapted from code written by Bruce F. Duba, 1991.
+;;
+;; This software is in the public domain.  Feel free to copy,
+;; distribute, and modify this software as desired.  No warranties
+;; nor guarantees of any kind apply.  Please return any improvements
+;; or bug fixes to bhauman@cs.wcu.edu so that they may be included
+;; in future releases.
+;;
+;; This macro package extends Scheme with several new expression forms.
+;; Following is a brief summary of the new forms.  See the associated
+;; LaTeX documentation for a full description of their functionality.
+;;
+;;
+;;         match expressions:
+;;
+;; exp ::= ...
+;;       | (match exp clause ...)
+;;       | (match-lambda clause ...) 
+;;       | (match-lambda* clause ...)
+;;       | (match-let ((pat exp) ...) body ...)
+;;       | (match-let var ((pat exp) ...) body ...)
+;;       | (match-let* ((pat exp) ...) body ...)
+;;       | (match-letrec ((pat exp) ...) body ...)
+;;       | (match-define pat exp)
+;;
+;; clause ::= (pat body) | (pat (=> identifier) exp)
+;;
+;;         patterns:                       matches:
+;;
+;; pat ::= 
+;;         identifier                      this binds an identifier if it 
+;;                                         doesn't conflict with
+;;                                         ..k, var, $, =, and, 
+;;                                         or, not, ?, set!, or get!
+;;       | _                               anything
+;;       | ()                              the empty list
+;;       | #t                              #t
+;;       | #f                              #f
+;;       | string                          a string
+;;       | number                          a number
+;;       | character                       a character
+;;       | 'sexp                           an s-expression
+;;       | 'symbol                         a symbol (special case of s-expr)
+;;       | (lvp_1 ... lvp_n)               list of n elements
+;;       | (pat ... pat_n . pat_{n+1})           list of n or more
+;;       | #(lvp_1 ... lvp_n)              vector of n elements
+;;       | #&pat                           box
+;;       | ($ struct-name pat_1 ... pat_n) a structure
+;;       | (= field pat)                   a field of a structure (field is 
+;;                                         an accessor)
+;;                                         Actually field can be any function 
+;;                                         which can be
+;;                                         applied to the data being matched.
+;;                                         Ex: (match 5 ((= add1 b) b)) => 6
+;;
+;;       | (and pat_1 ... pat_n)           if all of pat_1 thru pat_n match
+;;       | (or pat_1 ... pat_n)            if any of pat_1 thru pat_n match
+;;       | (not pat_1 ... pat_n)           if all pat_1 thru pat_n don't match
+;;       | (? predicate pat_1 ... pat_n)   if predicate true and all of
+;;                                           pat_1 thru pat_n match
+;;       | (set! identifier)               anything, and binds setter
+;;       | (get! identifier)               anything, and binds getter
+;;       | `qp                             a quasi-pattern
+;;
+;; lvp ::= pat ooo                         greedily matches n or more of pat, 
+;;                                         each element must match pat
+;;       | pat                             matches pat
+;;
+;; ooo ::= ...                             zero or more
+;;       | ___                             zero or more
+;;       | ..k                             k or more
+;;       | __k                             k or more
+;;
+;;         quasi-patterns:                 matches:
+;;
+;; qp  ::= ()                              the empty list
+;;       | #t                              #t
+;;       | #f                              #f
+;;       | string                          a string
+;;       | number                          a number
+;;       | character                       a character
+;;       | identifier                      a symbol
+;;       | (qp_1 ... qp_n)                 list of n elements
+;;       | (qp_1 ... qp_n . qp_{n+1})      list of n or more
+;;       | (qp_1 ... qp_n qp_n+1 ooo)      list of n or more, each element
+;;                                           of remainder must match qp_n+1
+;;       | #(qp_1 ... qp_n)                vector of n elements
+;;       | #(qp_1 ... qp_n qp_n+1 ooo)     vector of n or more, each element
+;;                                           of remainder must match qp_n+1
+;;       | #&qp                            box
+;;       | ,pat                            a pattern
+;;       | ,@(lvp . . . lvp-n)
+;;       | ,@(pat . . . pat_n . pat_{n+1})
+;;       | ,@`qp                           qp must evaluate to a list as 
+;;                                         so that this rule resembles the 
+;;                                         above two rules
+;;
+;; The names (quote, quasiquote, unquote, unquote-splicing, ?, _, $,
+;; and, or, not, set!, get!, list-no-order, hash-table, ..., ___) 
+;; cannot be used as pattern variables.</pre>
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(module match mzscheme
+  (provide
+   match
+   match-lambda
+   match-lambda*
+   match-let
+   match-let*
+   match-letrec
+   match-define   
+   match-equality-test
+   exn:misc:match?
+   exn:misc:match-value
+   define-match-expander)
+  
+  (require-for-syntax "private/convert-pat.ss"
+                      "private/match-helper.ss")
+  
+  (require-for-template mzscheme  (prefix plt: "private/match-internal-func.ss"))
+                      
+  (require  (prefix plt: "private/match-internal-func.ss")
+   "private/match-expander.ss"
+   "private/match-helper.ss"
+   "private/match-error.ss")
+  
+  (define-syntax (match-lambda stx)
+    (syntax-case stx ()
+      [(k clause ...)
+       (with-syntax ([(new-clauses ...) (handle-clauses #'(clause ...))]) 
+          #'(plt:match-lambda new-clauses ...))]))
+  
+  (define-syntax (match-lambda* stx)
+    (syntax-case stx ()
+      [(k clause ...)
+       (with-syntax ([(new-clauses ...) (handle-clauses #'(clause ...))])
+         #'(plt:match-lambda* new-clauses ...))]))
+  
+  (define-syntax (match-let stx)
+    (syntax-case stx ()
+      [(k name (clauses ...) body ...)
+       (identifier? (syntax name))
+       (with-syntax ([(new-clauses ...) (handle-clauses #'(clauses ...))])
+          #'(plt:match-let name (new-clauses ...) body ...))]          
+      [(k (clauses ...) body ...)
+       (with-syntax ([(new-clauses ...) (handle-clauses #'(clauses ...))])
+          #'(plt:match-let (new-clauses ...) body ...))]))          
+  
+  (define-syntax (match-let* stx)
+    (syntax-case stx ()
+      [(k (clauses ...) body ...)
+       (with-syntax
+           ([(new-clauses ...) (handle-clauses #'(clauses ...))])
+         #'(plt:match-let* (new-clauses ...) body ...))]))
+  
+  (define-syntax (match stx)
+    (syntax-case stx ()
+      [(_ exp clause ...)
+       (with-syntax 
+           ([(new-clauses ...) (handle-clauses #'(clause ...))])
+         #'(plt:match exp new-clauses ...))]))
+  
+  (define-syntax (match-letrec stx)
+    (syntax-case stx ()
+      [(k (clauses ...) body ...)
+       (with-syntax 
+           ([(new-clauses ...) (handle-clauses #'(clauses ...))])
+         #'(plt:match-letrec (new-clauses ...) body ...))]))
+
+  
+  (define-syntax (match-define stx)
+    (syntax-case stx ()
+      [(k pat exp)
+       (with-syntax ([new-pat (convert-pat #'pat)])
+         #'(plt:match-define new-pat exp))]))
+  
+  
+  
+  )
+
+
diff --git a/collects/mzlib/math.ss b/collects/mzlib/math.ss
new file mode 100644
index 0000000000..cc903ba285
--- /dev/null
+++ b/collects/mzlib/math.ss
@@ -0,0 +1,50 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; math.ss: some extra math routines
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(module math mzscheme
+  (provide e 
+	  pi 
+	  sqr
+	  sgn conjugate
+	  sinh cosh)
+
+  (define (sqr z) (* z z))
+  
+  ;; circular constants and aliases
+  (define e (exp 1.0)) 
+  (define pi (atan 0 -1))
+  
+  ;; sgn function 
+  (define sgn
+    (lambda (x)
+      (if (exact? x)
+	  (cond
+	   ((< x 0) -1)
+	   ((> x 0)  1)
+	   (else 0))
+	  (cond
+	   ((< x 0.0) -1.0)
+	   ((> x 0.0)  1.0)
+	   (else 0.0)))))
+  
+  ;; complex conjugate
+  (define conjugate
+    (lambda (z)
+      (make-rectangular 
+       (real-part z)
+       (- (imag-part z)))))
+  
+  ;; real hyperbolic functions
+  (define sinh 
+    (lambda (x)
+      (/
+       (- (exp x) (exp (- x)))
+       2.0)))
+  
+  (define cosh
+    (lambda (x)
+      (/
+       (+ (exp x) (exp (- x)))
+       2.0))))
diff --git a/collects/mzlib/md5.ss b/collects/mzlib/md5.ss
new file mode 100644
index 0000000000..4c86331bdb
--- /dev/null
+++ b/collects/mzlib/md5.ss
@@ -0,0 +1,451 @@
+(module md5 mzscheme
+  (provide md5) 
+  
+;;; -*- mode: scheme; mode: font-lock -*-
+;;;
+;;; Copyright (c) 2002, Jens Axel Søgaard
+;;; 
+;;; Permission to copy this software, in whole or in part, to use this
+;;; software for any lawful purpose, and to redistribute this software
+;;; is hereby granted.
+;;;
+;;; md5.scm  --  Jens Axel Søgaard, 16 oct 2002  
+
+;;; History
+; 14-10-2002  /jas
+;   - Bored. Initial attempt. Done. Well, except for faulty output.
+; 15-10-2002  /jas
+;   - It works at last
+; 16-10-2002  /jas
+;   - Added R5RS support
+; 16-02-2003 / lth
+;   - Removed let-values implementation because Larceny has it already
+;   - Implemented Larceny versions of many bit primitives (note, 0.52 
+;     or later required due to bignum bug)
+;   - Removed most 'personal idiosyncrasies' to give the compiler a fair 
+;     chance to inline primitives and improve performance some.
+;     Performance in the interpreter is still really quite awful.
+;   - Wrapped entire procedure in a big LET to protect the namespace
+;   - Some cleanup of repeated computations
+;   - Moved test code to separate file
+; 17-02-2003 / lth
+;   - Removed some of the indirection, for a 30% speedup in Larceny's
+;     interpreter.  Running in the interpreter on my Dell Inspiron 4000
+;     I get a fingerprint of "Lib/Common/bignums-be.sch" in about 63ms,
+;     which is slow but adequate.  (The compiled version is not much
+;     faster -- most time is spent in bignum manipulation, which is
+;     compiled in either case.  To do this well we must either operate
+;     on the bignum representation or redo the algorithm to use
+;     fixnums only.)
+; 01-12-2003 / lth
+;   - Reimplemented word arithmetic to use two 16-bit fixnums boxed in
+;     a cons cell.  In Petit Larceny's interpreter this gives a speedup
+;     of a factor of almost eight, and in addition this change translates
+;     well to other Scheme systems that support bit operations on fixnums.
+;     Only 17-bit (signed) fixnums are required.
+; 23-12-2003 / jas
+;   - Trivial port to PLT. Rewrote the word macro to syntax-rules.
+;     Larceny primitives written as syntax-rules macros exanding
+;     to their PLT name.
+  
+; 5-5-2005 / Greg Pettyjohn
+;  - It was failing for strings of length 56 bytes i.e. when the length
+;    in bits was congruent 448 modulo 512. Changed step 1 to fix this.
+;    According to RFC 1321, the message should still be padded in this
+;    case.
+  
+
+
+;;; Summary
+; This is an implementation of the md5 message-digest algorithm
+; in R5RS Scheme. The algorithm takes an arbitrary string and 
+; returns a 128-bit "fingerprint". 
+; The algorithm was invented by Ron Rivest, RSA Security, INC.
+; Reference:  RFC 1321, <http://www.faqs.org/rfcs/rfc1321.html>
+
+;;; Contact
+; Email jensaxel@soegaard.net if you have problems,
+; suggestions, code for 32 bit arithmetic for your
+; favorite implementation.
+; Check <http://www.scheme.dk/md5/> for new versions.
+
+;;; Technicalities
+; The algorithm is designed to be efficiently implemented
+; using 32 bit arithmetic. If your implementation supports
+; 32 bit arithmetic directly, you should substitute the
+; portable 32 operations with primitives of your implementation.
+; See the PLT version below for an example. 
+
+;;; Word aritmetic (32 bit)
+; Terminology
+;    word:  32 bit unsigned integer
+;    byte:   8 bit unsigned integer
+
+(define md5 'undefined)
+
+; (word c) turns into a quoted pair '(hi . lo).  I would have this local to the
+; let below except Twobit does not allow transformer to be used with let-syntax,
+; only with define-syntax.
+
+;(define-syntax word
+;  (transformer 
+;    (lambda (expr rename compare)
+;      (list 'quote (cons (quotient (cadr expr) 65536) (remainder (cadr expr) 65536))))))
+
+(define-syntax word
+  (syntax-rules ()
+    [(word c)
+     (cons (quotient c 65536) (remainder c 65536))]))
+
+
+(let ()
+
+  ;;; PORTING NOTES
+  
+  ;   logand is bitwise "and" on fixnums
+  ;   logior is bitwise "inclusive or" on fixnums
+  ;   logxor is bitwise "exclusive or" on fixnums
+  ;   lognot is bitwise "not" on fixnums
+  ;   lsh    is bitwise left-shift without overflow detection on fixnums
+  ;   rshl   is bitwise logical right-shift on fixnums.  Arithmetic 
+  ;             right shift (rsha in Larceny) can be used instead of rshl
+  ;             in this code
+
+  ; PLT versions of the Larceny primitives
+  (define-syntax fixnum? (syntax-rules () [(_ n) #t]))
+  (define-syntax logand  (syntax-rules () [(_ . more) (bitwise-and . more)]))
+  (define-syntax logior  (syntax-rules () [(_ . more) (bitwise-ior . more)]))
+  (define-syntax logxor  (syntax-rules () [(_ . more) (bitwise-xor . more)]))
+  (define-syntax lognot  (syntax-rules () [(_ . more) (bitwise-not . more)]))
+  (define-syntax lsh     (syntax-rules () [(_ n s)    (arithmetic-shift n s)]))
+  (define-syntax rshl    (syntax-rules () [(_ n s)    (arithmetic-shift n (- s))]))
+                   
+  ; Words are represented as a cons where the car holds the high 16
+  ; bits and the cdr holds the low 16 bits.  Most good Scheme systems
+  ; will have fixnums that hold at least 16 bits as well as fast
+  ; allocation, so this has a fair chance at beating bignums for
+  ; performance.
+
+  (define (integer->word i)
+    (if (or (and (fixnum? i) (>= i 0))
+	    (<= 0 i 4294967296))
+	(cons (quotient i 65536) (remainder i 65536))
+	(error "integer->word: out of range: " i)))
+
+  (define (word->integer w)
+    (+ (* (car w) 65536) (cdr w)))
+
+  (define (word+ a b)
+    (let ((t1 (+ (car a) (car b)))
+	  (t2 (+ (cdr a) (cdr b))))
+      (cons (logand (+ t1 (rshl t2 16)) 65535)
+	    (logand t2 65535))))
+
+  (define (word-or a b)
+    (cons (logior (car a) (car b))
+	  (logior (cdr a) (cdr b))))
+
+  (define (word-not a)
+    (cons (logand (lognot (car a)) 65535) (logand (lognot (cdr a)) 65535)))
+
+  (define (word-xor a b)
+    (cons (logxor (car a) (car b)) (logxor (cdr a) (cdr b))))
+    
+  (define (word-and a b)
+    (cons (logand (car a) (car b)) (logand (cdr a) (cdr b))))
+
+  (define (word<<< a s)
+    (define masks
+      '#(#x0 #x1 #x3 #x7 #xF #x1F #x3F #x7F #xFF 
+	 #x1FF #x3FF #x7FF #xFFF #x1FFF #x3FFF #x7FFF #xFFFF))
+    (define (rot hi lo s)
+      (cons (logior (lsh (logand hi (vector-ref masks (- 16 s))) s)
+		    (logand (rshl lo (- 16 s)) (vector-ref masks s)))
+	    (logior (lsh (logand lo (vector-ref masks (- 16 s))) s)
+		    (logand (rshl hi (- 16 s)) (vector-ref masks s)))))
+    (cond ((< 0 s 16)
+	   (rot (car a) (cdr a) s))
+	  ((< s 32)
+	   (rot (cdr a) (car a) (- s 16)))
+	  (else
+	   (error "word<<<: shift out of range: " s))))
+
+  ;; word->bytes : word -> "(list byte byte byte byte)", little endian!
+  (define (word->bytes w)
+    (list (logand (cdr w) 255)
+	  (logand (rshl (cdr w) 8) 255)
+	  (logand (car w) 255)
+	  (logand (rshl (car w) 8) 255)))
+
+  (define (word.4+ a b c d)
+    (word+ (word+ (word+ a b) c) d))
+
+  (define bitpos 
+    '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 
+	26 27 28 29 30 31))
+
+  (define powers 
+    '#(1 2 4 8 16 32 64 128 256 512 1024 2048 4096 8192 16384 32768 65536
+       131072 262144 524288 1048576 2097152 4194304 8388608 16777216 33554432
+       67108864 134217728 268435456 536870912 1073741824 2147483648 
+       4294967296))
+
+  ;; word->bits : word -> (list (union 0 1))
+  (define (word->bits w)
+    (let ((w (word->integer w)))
+      (define (bit i)  
+	(remainder (quotient w (vector-ref powers i)) 2))
+      (map bit bitpos)))
+
+  ;; bits->integer : (list (union 0 1)) -> integer
+  (define (bits->integer bs)
+    (apply + (map * bs (map (lambda (i) (vector-ref powers i)) bitpos))))
+  
+  ;; Bytes and words
+  ;; The least significant byte of a word is the first
+
+  ;; bytes->word : (list byte*) -> word
+  (define (bytes->word bs)
+    (define (bs->w akk mul bs)
+      (if (null? bs) 
+	  (integer->word akk)
+	  (bs->w (+ akk (* (car bs) mul)) (* 256 mul) (cdr bs))))
+    (bs->w 0 1 bs))
+
+  ;; bytes->words : (list byte) -> (list word)
+  (define (bytes->words bytes)
+    (define (loop bs l)
+      (cond ((null? l)          (list (bytes->word (reverse bs))))
+	    ((< (length bs) 4)  (loop (cons (car l) bs)  (cdr l)))
+	    (else               (cons (bytes->word (reverse bs))
+				      (loop '() l)))))
+    (if (null? bytes)
+	'()
+	(loop '() bytes)))
+
+  ;; string->bytes : string -> (list byte)
+  (define (string->bytes s)
+    (bytes->list s))
+
+  ;; List Helper
+  ;; block/list : list -> (values vector list)
+  ;; return a vector of the first 16 elements of the list,
+  ;;         and the rest of the list
+  (define (block/list l)
+    (let* (( v0 (car  l))  ( l0 (cdr l))
+	   ( v1 (car l0))  ( l1 (cdr l0))
+	   ( v2 (car l1))  ( l2 (cdr l1))
+	   ( v3 (car l2))  ( l3 (cdr l2))
+	   ( v4 (car l3))  ( l4 (cdr l3))
+	   ( v5 (car l4))  ( l5 (cdr l4))
+	   ( v6 (car l5))  ( l6 (cdr l5))
+	   ( v7 (car l6))  ( l7 (cdr l6))
+	   ( v8 (car l7))  ( l8 (cdr l7))
+	   ( v9 (car l8))  ( l9 (cdr l8))
+	   (v10 (car l9))  (l10 (cdr l9))
+	   (v11 (car l10)) (l11 (cdr l10))
+	   (v12 (car l11)) (l12 (cdr l11))
+	   (v13 (car l12)) (l13 (cdr l12))
+	   (v14 (car l13)) (l14 (cdr l13))
+	   (v15 (car l14)) (l15 (cdr l14)))
+      (values (vector v0 v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 v11 v12 v13 v14 v15)
+	      l15)))
+
+  ;; MD5
+  ;; The algorithm consists of five steps.
+  ;; All we need to do, is to call them in order.
+  ;; md5 : string -> string
+
+  (define (md5-computation str)
+    (step5 (step4 (step2 (* 8 (bytes-length str)) 
+			 (step1 (string->bytes str))))))
+
+  ;; Step 1  -  Append Padding Bits
+  ;; The message is padded so the length (in bits) becomes 448 modulo 512.
+  ;; We allways append a 1 bit and then append the proper numbber of 0's.
+  ;; NB: 448 bits is 14 words and 512 bits is 16 words
+  ;; step1 : (list byte) -> (list byte)
+  
+  (define (step1 message)
+    (let* ([z-b-t-a (modulo (- 448 (* 8 (length message))) 512)]
+           [zero-bits-to-append (if (zero? z-b-t-a) 512 z-b-t-a)])
+      (append message 
+              (cons #x80		; The byte containing the 1 bit => one less 
+					; 0 byte to append 
+                    (vector->list
+                     (make-vector
+                      (quotient (- zero-bits-to-append 1) 8) 0))))))
+
+  ;; Step 2  -  Append Length
+  ;; A 64 bit representation of the bit length b of the message before
+  ;; the padding of step 1 is appended. Lower word first.
+  ;; step2 : number (list byte) -> (list word)
+  ;;  org-len is the length of the original message in number of bits
+
+  (define (step2 original-length padded-message)
+    (let* ((b  original-length)
+	   (lo (remainder b #x100000000))
+	   (hi (remainder (quotient b #x100000000) #x100000000)))
+      (bytes->words 
+       (append padded-message 
+	       (append (word->bytes (integer->word lo))
+		       (word->bytes (integer->word hi)))))))
+
+  ;; Step 3  -  Initialize MD Buffer
+  ;; These magic constants are used to initialize the loop
+  ;; in step 4.
+  ;;
+  ;;          word A: 01 23 45 67
+  ;;          word B: 89 ab cd ef
+  ;;          word C: fe dc ba 98
+  ;;          word D: 76 54 32 10
+
+  ;; Step 4  -  Process Message in 16-Word Blocks
+  ;; For each 16 word block, go through a round one to four.
+  ;; step4 : (list word) -> "(list word word word word)"
+
+  (define (step4 message)
+    
+    
+    (define (loop A B C D message)
+      (if (null? message)
+	  (list A B C D)
+	  (let-values (((X rest) (block/list message)))
+	    (let* ((AA A) (BB B) (CC C) (DD D)
+
+		   (A (word+ B (word<<< (word.4+ A (F B C D) (vector-ref X 0) (word 3614090360)) 7)))
+		   (D (word+ A (word<<< (word.4+ D (F A B C) (vector-ref X 1) (word 3905402710)) 12)))
+		   (C (word+ D (word<<< (word.4+ C (F D A B) (vector-ref X 2) (word 606105819)) 17)))
+		   (B (word+ C (word<<< (word.4+ B (F C D A) (vector-ref X 3) (word 3250441966)) 22)))
+		   (A (word+ B (word<<< (word.4+ A (F B C D) (vector-ref X 4) (word 4118548399)) 7)))
+		   (D (word+ A (word<<< (word.4+ D (F A B C) (vector-ref X 5) (word 1200080426)) 12)))
+		   (C (word+ D (word<<< (word.4+ C (F D A B) (vector-ref X 6) (word 2821735955)) 17)))
+		   (B (word+ C (word<<< (word.4+ B (F C D A) (vector-ref X 7) (word 4249261313)) 22)))
+		   (A (word+ B (word<<< (word.4+ A (F B C D) (vector-ref X 8) (word 1770035416)) 7)))
+		   (D (word+ A (word<<< (word.4+ D (F A B C) (vector-ref X 9) (word 2336552879)) 12)))
+		   (C (word+ D (word<<< (word.4+ C (F D A B) (vector-ref X 10) (word 4294925233)) 17)))
+		   (B (word+ C (word<<< (word.4+ B (F C D A) (vector-ref X 11) (word 2304563134)) 22)))
+		   (A (word+ B (word<<< (word.4+ A (F B C D) (vector-ref X 12) (word 1804603682)) 7)))
+		   (D (word+ A (word<<< (word.4+ D (F A B C) (vector-ref X 13) (word 4254626195)) 12)))
+		   (C (word+ D (word<<< (word.4+ C (F D A B) (vector-ref X 14) (word 2792965006)) 17)))
+		   (B (word+ C (word<<< (word.4+ B (F C D A) (vector-ref X 15) (word 1236535329)) 22)))
+
+		   (A (word+ B (word<<< (word.4+ A (G B C D) (vector-ref X 1) (word 4129170786)) 5)))
+		   (D (word+ A (word<<< (word.4+ D (G A B C) (vector-ref X 6) (word 3225465664)) 9)))
+		   (C (word+ D (word<<< (word.4+ C (G D A B) (vector-ref X 11) (word 643717713)) 14)))
+		   (B (word+ C (word<<< (word.4+ B (G C D A) (vector-ref X 0) (word 3921069994)) 20)))
+		   (A (word+ B (word<<< (word.4+ A (G B C D) (vector-ref X 5) (word 3593408605)) 5)))
+		   (D (word+ A (word<<< (word.4+ D (G A B C) (vector-ref X 10) (word 38016083)) 9)))
+		   (C (word+ D (word<<< (word.4+ C (G D A B) (vector-ref X 15) (word 3634488961)) 14)))
+		   (B (word+ C (word<<< (word.4+ B (G C D A) (vector-ref X 4) (word 3889429448)) 20)))
+		   (A (word+ B (word<<< (word.4+ A (G B C D) (vector-ref X 9) (word 568446438)) 5)))
+		   (D (word+ A (word<<< (word.4+ D (G A B C) (vector-ref X 14) (word 3275163606)) 9)))
+		   (C (word+ D (word<<< (word.4+ C (G D A B) (vector-ref X 3) (word 4107603335)) 14)))
+		   (B (word+ C (word<<< (word.4+ B (G C D A) (vector-ref X 8) (word 1163531501)) 20)))
+		   (A (word+ B (word<<< (word.4+ A (G B C D) (vector-ref X 13) (word 2850285829)) 5)))
+		   (D (word+ A (word<<< (word.4+ D (G A B C) (vector-ref X 2) (word 4243563512)) 9)))
+		   (C (word+ D (word<<< (word.4+ C (G D A B) (vector-ref X 7) (word 1735328473)) 14)))
+		   (B (word+ C (word<<< (word.4+ B (G C D A) (vector-ref X 12) (word 2368359562)) 20)))
+
+		   (A (word+ B (word<<< (word.4+ A (H B C D) (vector-ref X 5) (word 4294588738)) 4)))
+		   (D (word+ A (word<<< (word.4+ D (H A B C) (vector-ref X 8) (word 2272392833)) 11)))
+		   (C (word+ D (word<<< (word.4+ C (H D A B) (vector-ref X 11) (word 1839030562)) 16)))
+		   (B (word+ C (word<<< (word.4+ B (H C D A) (vector-ref X 14) (word 4259657740)) 23)))
+		   (A (word+ B (word<<< (word.4+ A (H B C D) (vector-ref X 1) (word 2763975236)) 4)))
+		   (D (word+ A (word<<< (word.4+ D (H A B C) (vector-ref X 4) (word 1272893353)) 11)))
+		   (C (word+ D (word<<< (word.4+ C (H D A B) (vector-ref X 7) (word 4139469664)) 16)))
+		   (B (word+ C (word<<< (word.4+ B (H C D A) (vector-ref X 10) (word 3200236656)) 23)))
+		   (A (word+ B (word<<< (word.4+ A (H B C D) (vector-ref X 13) (word 681279174)) 4)))
+		   (D (word+ A (word<<< (word.4+ D (H A B C) (vector-ref X 0) (word 3936430074)) 11)))
+		   (C (word+ D (word<<< (word.4+ C (H D A B) (vector-ref X 3) (word 3572445317)) 16)))
+		   (B (word+ C (word<<< (word.4+ B (H C D A) (vector-ref X 6) (word 76029189)) 23)))
+		   (A (word+ B (word<<< (word.4+ A (H B C D) (vector-ref X 9) (word 3654602809)) 4)))
+		   (D (word+ A (word<<< (word.4+ D (H A B C) (vector-ref X 12) (word 3873151461)) 11)))
+		   (C (word+ D (word<<< (word.4+ C (H D A B) (vector-ref X 15) (word 530742520)) 16)))
+		   (B (word+ C (word<<< (word.4+ B (H C D A) (vector-ref X 2) (word 3299628645)) 23)))
+
+		   (A (word+ B (word<<< (word.4+ A (II B C D) (vector-ref X 0) (word 4096336452)) 6)))
+		   (D (word+ A (word<<< (word.4+ D (II A B C) (vector-ref X 7) (word 1126891415)) 10)))
+		   (C (word+ D (word<<< (word.4+ C (II D A B) (vector-ref X 14) (word 2878612391)) 15)))
+		   (B (word+ C (word<<< (word.4+ B (II C D A) (vector-ref X 5) (word 4237533241)) 21)))
+		   (A (word+ B (word<<< (word.4+ A (II B C D) (vector-ref X 12) (word 1700485571)) 6)))
+		   (D (word+ A (word<<< (word.4+ D (II A B C) (vector-ref X 3) (word 2399980690)) 10)))
+		   (C (word+ D (word<<< (word.4+ C (II D A B) (vector-ref X 10) (word 4293915773)) 15)))
+		   (B (word+ C (word<<< (word.4+ B (II C D A) (vector-ref X 1) (word 2240044497)) 21)))
+		   (A (word+ B (word<<< (word.4+ A (II B C D) (vector-ref X 8) (word 1873313359)) 6)))
+		   (D (word+ A (word<<< (word.4+ D (II A B C) (vector-ref X 15) (word 4264355552)) 10)))
+		   (C (word+ D (word<<< (word.4+ C (II D A B) (vector-ref X 6) (word 2734768916)) 15)))
+		   (B (word+ C (word<<< (word.4+ B (II C D A) (vector-ref X 13) (word 1309151649)) 21)))
+		   (A (word+ B (word<<< (word.4+ A (II B C D) (vector-ref X 4) (word 4149444226)) 6)))
+		   (D (word+ A (word<<< (word.4+ D (II A B C) (vector-ref X 11) (word 3174756917)) 10)))
+		   (C (word+ D (word<<< (word.4+ C (II D A B) (vector-ref X 2) (word 718787259)) 15)))
+		   (B (word+ C (word<<< (word.4+ B (II C D A) (vector-ref X 9) (word 3951481745)) 21)))
+
+		   (A (word+ A AA)) 
+		   (B (word+ B BB))
+		   (C (word+ C CC)) 
+		   (D (word+ D DD)))
+	      (loop A B C D rest)))))
+  
+    ;; Step 3 :-) (magic constants)
+    (loop (word #x67452301) (word #xefcdab89) (word #x98badcfe) (word #x10325476) message))
+
+  ;; Each round consists of the application of the following
+  ;; basic functions. They functions on a word bitwise, as follows.
+  ;;          F(X,Y,Z) = XY v not(X) Z  (NB: or can be replaced with + in F)
+  ;;          G(X,Y,Z) = XZ v Y not(Z)
+  ;;          H(X,Y,Z) = X xor Y xor Z
+  ;;          I(X,Y,Z) = Y xor (X v not(Z))
+
+  (define (F x y z)
+    (word-or (word-and x y) (word-and (word-not x) z)))
+
+  (define (G x y z)
+    (word-or (word-and x z) (word-and y (word-not z))))
+
+  (define (H x y z)
+    (word-xor x (word-xor y z)))
+
+  (define (II x y z)
+    (word-xor y (word-or x (word-not z))))
+
+  ;; Step 5  -  Output
+  ;; To finish up, we convert the word to hexadecimal string
+  ;; - and make sure they end up in order.
+  ;; step5 : "(list word word word word)" -> string
+
+  (define (step5 l)
+    
+    
+    (define hex #(48 49 50 51 52 53 54 55 56 57 97 98 99 100 101 102))
+
+    (define (number->hex n)
+      (bytes (vector-ref hex (quotient n 16))
+	     (vector-ref hex (modulo n 16))))
+    
+    (apply bytes-append
+           (map number->hex
+                (apply append (map word->bytes l)))))
+
+  (set! md5 md5-computation))
+
+;(define (md5-test)
+;  (if (and (equal? (md5 "")
+;                   "d41d8cd98f00b204e9800998ecf8427e")
+;           (equal? (md5 "a")
+;                   "0cc175b9c0f1b6a831c399e269772661")
+;           (equal? (md5 "abc")
+;                   "900150983cd24fb0d6963f7d28e17f72")
+;           (equal? (md5 "message digest")
+;                   "f96b697d7cb7938d525a2f31aaf161d0")
+;           (equal? (md5 "abcdefghijklmnopqrstuvwxyz")
+;                   "c3fcd3d76192e4007dfb496cca67e13b")
+;           (equal? (md5 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789")
+;                   "d174ab98d277d9f5a5611c2c9f419d9f")
+;           (equal? (md5 "12345678901234567890123456789012345678901234567890123456789012345678901234567890")
+;                   "57edf4a22be3c955ac49da2e2107b67a"))
+;      'passed
+;      'failed))
+;
+;(md5-test)
+)
diff --git a/collects/mzlib/os.ss b/collects/mzlib/os.ss
new file mode 100644
index 0000000000..e5b53138c1
--- /dev/null
+++ b/collects/mzlib/os.ss
@@ -0,0 +1,68 @@
+(module os mzscheme
+  (require (lib "foreign.ss")) (unsafe!)
+  
+  (define kernel32 
+    (delay (and (eq? 'windows (system-type))
+		(ffi-lib "kernel32"))))
+
+  (define (delay-ffi-obj name lib type)
+    (delay (get-ffi-obj name lib type)))
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; gethostbyname
+  
+  (define BUFFER-SIZE 1024)
+  (define (extract-terminated-string proc)
+    (let ([s (make-bytes BUFFER-SIZE)])
+      (if (proc s BUFFER-SIZE)
+	  (bytes->string/utf-8 (car (regexp-match #rx#"^[^\0]*" s)))
+	  (error 'gethostname
+		 "could not get hostname"))))
+
+  (define unix-gethostname
+    (delay-ffi-obj "gethostname"  #f
+		   (_fun _bytes _int -> _int)))
+  
+  (define windows-getcomputername
+    (delay-ffi-obj "GetComputerNameExA" (force kernel32)
+		   (_fun _int _bytes _cvector -> _int)))
+
+  (define (gethostname)
+    (case (system-type)
+      [(unix macosx)
+       (let ([ghn (force unix-gethostname)])
+	 (extract-terminated-string 
+	  (lambda (s sz)
+	    (zero? (ghn s sz)))))]
+      [(windows)
+       (let ([gcn (force windows-getcomputername)]
+	     [DNS_FULLY_QUALIFIED 3])
+	 (extract-terminated-string 
+	  (lambda (s sz)
+	    (let ([sz_ptr (cvector _int sz)])
+	      (and (not (zero? (gcn DNS_FULLY_QUALIFIED s sz_ptr)))
+		   (let ([sz (cvector-ref sz_ptr 0)])
+		     (when (sz . < . (bytes-length s))
+		       (bytes-set! s sz 0))
+		     #t))))))]
+      [else #f]))
+
+  (provide gethostname)
+  
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; getpid
+
+  (define unix-getpid
+    (delay-ffi-obj "getpid" #f 
+		   (_fun -> _int)))
+
+  (define windows-getpid
+    (delay-ffi-obj "GetCurrentProcessId" (force kernel32) 
+		   (_fun -> _int)))
+
+  (define (getpid)
+    (case (system-type)
+      [(macosx unix) ((force unix-getpid))]
+      [(windows) ((force windows-getpid))]))
+
+  (provide getpid))
diff --git a/collects/mzlib/package.ss b/collects/mzlib/package.ss
new file mode 100644
index 0000000000..98f23bae03
--- /dev/null
+++ b/collects/mzlib/package.ss
@@ -0,0 +1,672 @@
+;; `package' and `open' correspond to Chez's `module' and `import' ---
+;; without making `import' a part of the primitive expander mechanism,
+;; which would require special handling for anything that uses
+;; `local-expand'.
+;;
+;; The main idea is to hide package definitions by "introducing" the
+;; identifier (i.e., applying a fresh mark for each definition).
+;;
+;; Beyond the main strategy, there are two major problems:
+;;
+;;  1. Making `package' declarations available to immediately
+;;     following `open' declarations in an internal-definition
+;;     context: (let () (package p ...) (open p) ...)
+;;
+;;     The problem is that `open' needs to inspect the package
+;;     to decide what variables it binds, but the package
+;;     descriptor isn't executed until the defn context has
+;;     dertemined the full set of names to be defined.
+;;
+;;     We work around this problem by keeping our own table
+;;     of "recently" processed `package' declarations. The
+;;     `syntax-local-context' function lets us key this to
+;;     specific internal-definition contexts.
+;;
+;;  2. Implementing the binding effect of an `open', which needs
+;;     to expose the bindings hidden by a `package', but also
+;;     needs to override shadowing.
+;;
+;;     The `syntax-local-get-shadower' MzScheme function provides
+;;     the key ingredient for this part, but it doesn't quite work
+;;     when `open' appears within `package'. In that case, we
+;;     need to first take into account the package's introductions
+;;     that hide definitions.
+
+(module package mzscheme
+  (require (lib "etc.ss")
+	   (lib "stxparam.ss"))
+  (require-for-syntax "private/package-helper.ss"
+                      (lib "kerncase.ss" "syntax")
+                      (lib "stx.ss" "syntax")
+		      (lib "boundmap.ss" "syntax")
+		      (lib "context.ss" "syntax")
+		      (lib "define.ss" "syntax")
+                      (lib "list.ss")
+		      (lib "stxparam.ss"))
+
+  (provide package package*
+	   open define-dot
+	   open* define*-dot
+	   dot 
+	   define*-syntax define*
+	   define*-syntaxes define*-values
+	   open/derived open*/derived package/derived
+	   define-dot/derived define*-dot/derived
+	   rename-potential-package rename*-potential-package)
+
+  ;; Used to communicate to `open'
+  ;; when an expression is within the body of a `package' declaration.
+  ;; This matters for choosing the right shadower of an id.
+  ;; The value of current-pack is a list of (cons id num),
+  ;;  where num is the size of the applicable tail of the rename list
+  ;;  for the package named id.
+  (define-syntax-parameter current-package null)
+
+  ;; The *ed define forms are the same as the usual
+  ;; forms, except inside a package, where the
+  ;; *ed names are specially detected.
+  (define-syntax-set (define*-syntaxes
+		       define*-values
+		       define*-syntax
+		       define*)
+    (define (check-formals s)
+      (let loop ([s s])
+	(cond
+	 [(stx-null? s) #t]
+	 [(identifier? s) #t]
+	 [(and (stx-pair? s)
+	       (identifier? (stx-car s)))
+	  (loop (stx-cdr s))]
+	 [else #f])))
+
+    (define (multi stx def)
+      (syntax-case stx ()
+	((_ (id ...) body) 
+	 (andmap identifier? (syntax->list #'(id ...)))
+	 (quasisyntax/loc stx (#,def (id ...) body)))))
+
+    (define (define*-syntaxes/proc stx)
+      (multi stx #'define-syntaxes))
+    
+    (define (define*-values/proc stx)
+      (multi stx #'define-values))
+  
+    (define (single stx def-vals)
+      (let-values ([(id rhs) (normalize-definition stx #'lambda)])
+	(quasisyntax/loc stx (#,def-vals (#,id) #,rhs))))
+
+    (define (define*-syntax/proc stx)
+      (single stx #'define*-syntaxes))
+    
+    (define (define*/proc stx)
+      (single stx #'define*-values)))
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; The main `package' implementation (actually, package/derived)
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (define-syntax-set (package/derived)
+
+    ;; Adds the *ed "primitive" definition forms to the
+    ;;  kernel-form list:
+    (define kernel-form-identifier-list+defines
+      (append (list #'define*-values #'define*-syntaxes)
+	      (kernel-form-identifier-list #'here)))
+
+    ;; Ensures that a single package element is a definition:
+    (define (fix-expr e)
+      (kernel-syntax-case e #f
+        ((define-values x y) e)
+        ((define-syntaxes x y) e)
+        ((d x y) (and (identifier? #'d)
+		      (or (module-identifier=? (quote-syntax define*-values) #'d)
+			  (module-identifier=? (quote-syntax define*-syntaxes) #'d)))
+         e)
+        (x #`(define-values () (begin x (values))))))
+    
+    ;; Partially expands all body expressions, and wraps expressions
+    ;; in empty `define-values'; the result is a list of definitions
+    (define (get-defs expand-context defs exports)
+      (let ([stop-list (append kernel-form-identifier-list+defines
+			       exports)])
+	(map fix-expr
+	     (apply append
+		    (map (letrec ([ex
+				   (lambda (d)
+				     (let ([_e (local-expand 
+						d
+						expand-context
+						stop-list)])
+				       (syntax-case _e (begin)
+					 [(begin e ...)
+					  (apply
+					   append
+					   (map (lambda (s)
+						  (ex (syntax-track-origin s _e #'begin)))
+						(syntax->list #'(e ...))))]
+					 [else (list _e)])))])
+			   ex)
+			 defs)))))
+    
+    ;; Extracts all defined names, and also checks for duplicates
+    ;; in the * forms.
+    (define (extract-ids defs stx)
+      (let loop ([defs defs][normal-defs null][let*-defs null])
+	(if (null? defs)
+	    (values normal-defs let*-defs)
+	    (syntax-case (car defs) ()
+	      [(dv (id ...) expr)
+	       (and (identifier? #'dv)
+		    (or (module-identifier=? #'dv #'define-values)
+			(module-identifier=? #'dv #'define-syntaxes))
+		    (andmap identifier? (syntax->list #'(id ...))))
+	       (loop (cdr defs)
+		     (append normal-defs (syntax->list #'(id ...)))
+		     let*-defs)]
+	      [(dv . _)
+	       (and (identifier? #'dv)
+		    (or (module-identifier=? #'dv #'define-values)
+			(module-identifier=? #'dv #'define-syntaxes)))
+	       (raise-syntax-error #f "bad syntax" (car defs))]
+	      [(dv (id ...) expr)
+	       (and (identifier? #'dv)
+		    (or (module-identifier=? #'dv #'define*-values)
+			(module-identifier=? #'dv #'define*-syntaxes))
+		    (andmap identifier? (syntax->list #'(id ...))))
+	       ;; Check that the identifiers in a single set are distinct
+	       (let ([ids (syntax->list #'(id ...))])
+		 (let ([dup (check-duplicate-identifier ids)])
+		   (when dup
+		     (raise-syntax-error
+		      #f
+		      "identifier defined multiple times in a single set"
+		      stx
+		      dup)))
+		 (loop (cdr defs)
+		       normal-defs
+		       (append let*-defs ids)))]
+	      [(dv . _)
+	       (and (identifier? #'dv)
+		    (or (module-identifier=? #'dv #'define*-values)
+			(module-identifier=? #'dv #'define*-syntaxes)))
+	       (raise-syntax-error #f "illegal definition form" (car defs))]))))
+
+    ;; Extracts one set of starred names:
+    (define (get/let*-ids def)
+      (syntax-case def ()
+        ((d vars body) (or (module-identifier=? (quote-syntax define*-values) #'d)
+                           (module-identifier=? (quote-syntax define*-syntaxes) #'d))
+         (syntax->list #'vars))
+        (_ null)))
+    
+    ;; Combines parts of a transformed definition in a package:
+    (define (rebuild-def orig package-name rename-length kw ids body compile-time?)
+      (datum->syntax-object
+       orig
+       `(,kw ,ids ,(if compile-time?
+		       body
+		       #`(syntax-parameterize ([current-package
+						(cons
+						 (cons
+						  (quote-syntax #,package-name)
+						  #,rename-length)
+						 (syntax-parameter-value
+						  (quote-syntax current-package)))])
+			   #,body)))
+       orig
+       orig))
+
+    ;;  mark-ids : defn-stx 
+    ;;             (list (cons id-stx (stx . -> . stx)))
+    ;;             id-stx 
+    ;;              ->  (list (cons id-stx (stx . -> . stx)))
+    ;; Convert a definition from a package body, and add marks as
+    ;; appropriate to map to hidden names within the package. Also
+    ;; accumulate new hidden names from starred bindings.
+    (define (mark-ids def introducers package-name expand-ctx)
+      ;; Note: new-ids is null if this is a non-* definition
+      (let ([new-ids (map (lambda (id) (cons id (make-syntax-introducer)))
+                          (get/let*-ids def))]
+	    [rename-length (length introducers)])
+        (values
+         (syntax-case def ()
+           ((ds vars body) 
+	    (module-identifier=? (quote-syntax define-syntaxes) #'ds)
+	    (rebuild-def def package-name rename-length
+			 #'ds 
+			 (mark-to-localize #'vars (append new-ids introducers) #'protect) 
+			 (mark-to-localize #'body (append new-ids introducers) #'protect)
+			 #t))
+           ((dv vars body)
+	    (module-identifier=? (quote-syntax define-values) #'dv)
+            (rebuild-def def package-name rename-length
+			 #'dv 
+			 (mark-to-localize #'vars (append new-ids introducers) #'protect) 
+			 (mark-to-localize #'body (append new-ids introducers) #'protect)
+			 #f))
+           ((d vars body) 
+	    (module-identifier=? (quote-syntax define*-values) #'d)
+            (rebuild-def def package-name rename-length
+			 #'define-values
+			 (mark-to-localize #'vars (append new-ids introducers) #'protect)
+			 (mark-to-localize #'body introducers #'protect)
+			 #f))
+           ((d vars body) 
+	    (module-identifier=? (quote-syntax define*-syntaxes) #'d)
+	    (rebuild-def def package-name rename-length
+			 #'define-syntaxes
+			 (mark-to-localize #'vars (append new-ids introducers) #'protect)
+			 (mark-to-localize #'body introducers #'protect)
+			 #t)))
+	 new-ids)))
+        
+    ;; For top-level definitions, we need to "declare"
+    ;; the defined variables before we might use them.
+    ;; We declare the variable by compiling a dummy
+    ;; define-values expression.
+    (define (extract-declarations converted-defs)
+      (let loop ([converted-defs converted-defs]
+		 [pre-accum null])
+	(if (null? converted-defs)
+	    (values (reverse pre-accum))
+	    (syntax-case (car converted-defs) (define-values)
+	      [(define-values (id ...) body)
+	       (loop (cdr converted-defs)
+		     (list* #'(define-syntaxes (id ...) (values))
+			    pre-accum))]
+	      [_ (loop (cdr converted-defs)
+		       pre-accum)]))))
+    
+    ;; The main package/derived transformer:
+    (define (package/derived/proc derived-stx)
+      (syntax-case derived-stx ()
+        ((_ orig-stx name provides body ...)
+         (let ([stx #'orig-stx])
+	   ;; --- Error checking
+	   (check-defn-context stx)
+           (unless (identifier? #'name)
+             (raise-syntax-error #f "structure name must be an identifier" stx #'name))
+	   (unless (or (and (identifier? #'provides)
+			    (module-identifier=? (quote-syntax all-defined) #'provides))
+		       (and (stx-list? #'provides)
+			    (andmap identifier? (stx->list #'provides))))
+	     (if (eq? 'all-defined (syntax-e #'provides))
+		 (raise-syntax-error
+		  #f
+		  "`all-defined' keyword has a binding, so it is disallowed as an export"
+		  stx
+		  #'provides)
+		 (raise-syntax-error
+		  #f
+		  "exports must have the form `all-defined' or `(identifier ...)'"
+		  stx
+		  #'provides)))
+	   (let ([specific-exports (if (identifier? #'provides)
+				       #f
+				       (syntax->list #'provides))])
+	     (when specific-exports
+	       (let ([dup (check-duplicate-identifier specific-exports)])
+		 (when dup
+		   (raise-syntax-error
+		    #f
+		    "identifier exported multiple times"
+		    stx
+		    dup))))
+	     ;; --- Parse package body
+	     (let*-values ([(expand-context) (build-expand-context (gensym 'package-define))]
+			   [(defs) (get-defs expand-context
+					     (syntax->list #'(body ...))
+					     (or specific-exports
+						 null))]
+			   ;; normal-ids and let*-ids are in same order as in package:
+			   [(normal-ids let*-ids) (extract-ids defs stx)]
+			   [(bt) (make-bound-identifier-mapping)])
+	       ;; --- More error checking (duplicate defns)
+	       (for-each (lambda (id)
+			   (when (bound-identifier-mapping-get bt id (lambda () #f))
+			     (raise-syntax-error
+			      #f
+			      "identifier defined multiple times"
+			      stx
+			      id))
+			   (bound-identifier-mapping-put! bt id #t))
+			 normal-ids)
+	       (for-each (lambda (id)
+			   (when (bound-identifier-mapping-get bt id (lambda () #f))
+			     (raise-syntax-error
+			      #f
+			      "identifier for * definition has a non-* definition"
+			      stx
+			      id)))
+			 let*-ids)
+	       ;; --- Convert package body, accumulating introducers
+	       ;; The `defined-ids' variable is a (list (cons id-stx (stx . -> . stx)))
+	       (let-values ([(converted-defs defined-ids)
+			     (let loop ((defined-ids (map (lambda (id) (cons id (make-syntax-introducer)))
+							  normal-ids))
+					(defs defs)
+					(accum null))
+			       (cond
+				((null? defs)
+				 (values (reverse accum) defined-ids))
+				(else
+				 (let-values (((marked-def new-defined-ids)
+					       (mark-ids (car defs) defined-ids #'name expand-context)))
+				   (loop (append new-defined-ids defined-ids)
+					 (cdr defs)
+					 (cons marked-def accum))))))]
+			    [(reverse-orig-ids) (reverse (append normal-ids let*-ids))])
+		 ;; --- Create the list of exported identifiers
+		 (let ([export-renames
+			(remove-dups
+			 (cond
+			  [(not specific-exports)
+			   (map (lambda (id)
+				  (cons (car id)
+					((cdr id) (car id))))
+				defined-ids)]
+			  [else
+			   (map (lambda (provide)
+				  (let ((introducer (stx-assoc provide defined-ids)))
+				    (unless introducer
+				      (raise-syntax-error
+				       #f
+				       "exported identifier not defined"
+				       stx
+				       provide))
+				    (cons (car introducer)
+					  ((cdr introducer) provide))))
+				specific-exports)]))]
+		       [all-renames (map (lambda (id)
+					   (cons (car id)
+						 ((cdr id) (car id))))
+					 defined-ids)])
+		   ;; --- Shuffle the package body to put syntax definitions first
+		   (let ([pre-decls
+			  (if (eq? 'top-level (syntax-local-context))
+			      (extract-declarations converted-defs)
+			      null)]
+			 [converted-syntax-defs (filter (lambda (def)
+							  (or (module-identifier=? (stx-car def) #'define-syntaxes)
+							      (module-identifier=? (stx-car def) #'define*-syntaxes)))
+							converted-defs)]
+			 [converted-value-defs (filter (lambda (def)
+							 (or (module-identifier=? (stx-car def) #'define-values)
+							     (module-identifier=? (stx-car def) #'define*-values)))
+						       converted-defs)])
+		     ;; --- Register this package, in case an `open' appears before the
+		     ;;     syntax definition is executed.
+		     ;;       export-renames provides an (id-stx . id-stx) mapping for exported ids 
+		     ;;       all-renames is (id-stx . id-stx) mapping for all ids (superset of export-renames)
+		     (pre-register-package expand-context #'name export-renames all-renames defined-ids #'protect)
+		     ;; --- Assemble the result
+		     #`(begin
+			 (define-syntaxes (name)
+			   (make-str (list #,@(map (lambda (i)
+						     ;; Use of `protect' keeps the id from being localized
+						     ;; if this package is in another. That way, the
+						     ;; source name in the mapping is always the original
+						     ;; name.
+						     #`(cons (protect #,(car i))
+							     (quote-syntax #,(cdr i))))
+						   export-renames))
+				     (list #,@(map (lambda (i)
+						     #`(cons (protect #,(car i))
+							     (quote-syntax #,(cdr i))))
+						   all-renames))))
+			 #,@pre-decls
+			 #,@converted-syntax-defs
+			 #,@converted-value-defs))))))))))
+    )
+
+  (define-syntax (package* stx)
+    (syntax-case stx ()
+      [(package* name exports body ...)
+       (with-syntax ([this-pkg (car (generate-temporaries '(this-pkg)))])
+	 #`(begin
+	     (package/derived #,stx this-pkg exports
+			      body ...)
+	     (rename*-potential-package name this-pkg)))]))
+  
+  (define-syntax (package stx)
+    (syntax-case stx ()
+      [(package* name exports body ...)
+       #`(package/derived #,stx name exports
+			  body ...)]))
+  
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; The main `open' implementation
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (define-syntax-set (open/derived open*/derived open open* 
+				   define-dot define*-dot define-dot/derived define*-dot/derived
+				   rename-potential-package rename*-potential-package)
+    (define (do-open stx orig-name
+		     path
+		     ex-name bind-name
+		     def)
+      (let* (;; If we're in an enclosing package's body, get it's rename environment, etc.
+	     ;;   env is an (id-stx . id-stx) mapping - names exported by the package
+	     ;;   rns is an (id-stx . id-stx) mapping - names defined in the package
+	     ;;   subs is a table mapping defined id-stx to sub-package mappings
+	     [cps (syntax-parameter-value #'current-package)]
+	     [cp-env+rns+subs+ispre/s (map (lambda (cp) (open (car cp) (car cp) stx))
+					   cps)]
+	     ;; Reverse-map renaming due to being in a package body. In other words,
+	     ;;  we find id "x", but it's been renamed because we're in an enclosing
+	     ;;  package, and we're about to look in a table that maps original
+	     ;;  names to something, so we need to reverse-map the name.
+	     [cp-orig-name (lambda (id)
+			     (let loop ([id id][cp-env+rns+subs+ispre/s cp-env+rns+subs+ispre/s][cps cps])
+			       (if (null? cp-env+rns+subs+ispre/s)
+				   id
+				   (let ([in-pack-bind
+					  (ormap (lambda (p)
+						   (and (bound-identifier=? (cdr p) id)
+							p))
+						 (let ([l (cadr (car cp-env+rns+subs+ispre/s))])
+						   (list-tail l (- (length l) (cdar cps)))))])
+				     (loop (if in-pack-bind
+					       (car in-pack-bind)
+					       id)
+					   (cdr cp-env+rns+subs+ispre/s)
+					   (cdr cps))))))]
+	     ;; Reverse-map renaming due to being in a package
+	     ;;  body. For example, we have an "x" that we want to
+	     ;;  shadow, but the correct shadower must use the new name
+	     ;;  in the enclosing package.
+	     [cp-current-name (lambda (id)
+				(let loop ([id id][cp-env+rns+subs+ispre/s cp-env+rns+subs+ispre/s][cps cps])
+				  (if (null? cp-env+rns+subs+ispre/s)
+				      id
+				      (let* ([l (cadr (car cp-env+rns+subs+ispre/s))]
+					     [l (list-tail l (- (length l) (cdar cps)))])
+					(let ([in-pack-bind (stx-assoc id l)])
+					  (loop (if in-pack-bind
+						    (cdr in-pack-bind)
+						    id)
+						(cdr cp-env+rns+subs+ispre/s)
+						(cdr cps)))))))])
+	;; Find the package. See above for a remainder of env+rns+subs+ispre.
+	;; The `rename-chain' variable binds an (stx . -> stx).
+	(let*-values ([(env+rns+subs+ispre rename-chain)
+		       ;; Find the initial package. `open' reports an error if it can't find one
+		       (let ([env+rns+subs+ispre (open (car path) orig-name stx)])
+			 (walk-path (cdr path) env+rns+subs+ispre stx values cp-orig-name))])
+	  (let* ([env (and env+rns+subs+ispre 
+			   (let ([e (car env+rns+subs+ispre)])
+			     (if ex-name
+				 (let ([a (stx-assoc 
+					   (let ([id (syntax-local-introduce ex-name)])
+					     (cp-orig-name id))
+					   (car env+rns+subs+ispre))])
+				   (unless a
+				     (raise-syntax-error
+				      #f
+				      "no such export from package"
+				      stx
+				      ex-name))
+				   (list a))
+				 e)))]
+		 ;; Find the names that `open' is supposed to bind
+		 [shadowers (if bind-name
+				(list bind-name)
+				(map (lambda (x)
+				       (syntax-local-get-shadower
+					(cp-current-name
+					 (car x))))
+				     env))])
+	    ;; Set up the defined-name -> opened-name mapping
+	    (with-syntax ([((pub . hid) ...)
+			   (map (lambda (x shadower)
+				  (cons (if bind-name
+					    shadower ; which is bind-name
+					    (syntax-local-introduce shadower))
+					;; If the source module is defined in the same
+					;; internal-definition context as this open, then we must
+					;; introduce the use of the package export.
+					;;
+					;; If the source source module comes from elsewhere, we
+					;; must not introduce it, in case the new and original
+					;; name are the same (so the new binding might capture
+					;; the reference to the original binding.
+					;; 
+					;; Note that if the names are the same and the
+					;; context are the same, the choise doens't matter,
+					;; because a dup-defn error will be reported.
+					((if (cadddr env+rns+subs+ispre)
+					     syntax-local-introduce 
+					     values)
+					 (cp-current-name (cdr x)))))
+				env shadowers)]
+			  [def-stxes def])
+	      ;; In case another `open' follows this one in an
+	      ;; internal-defn position, register renames for
+	      ;; packages that we just made available:
+	      (let* ([ctx (syntax-local-context)]
+		     [subs (caddr env+rns+subs+ispre)])
+		(when (pair? ctx)
+		  (for-each (lambda (x shadower)
+			      (re-pre-register-package subs ctx 
+						       (if bind-name
+							   (syntax-local-introduce shadower)
+							   shadower)
+						       (if subs
+							   (car x)
+							   (cdr x))))
+			    env shadowers)))
+	      ;; Open produces a syntax binding to map to the opened names:
+	      (syntax/loc stx
+		(def-stxes (pub ...)
+		  (values (make-rename-transformer (quote-syntax hid)) ...))))))))
+
+    (define (generic-open stx def)
+      (check-defn-context stx)
+      (syntax-case stx ()
+	[(_ elem1 elem ...)
+	 (do-open stx #f (syntax->list #'(elem1 elem ...))
+		  #f #f
+		  def)]))
+
+    (define (generic-open/derived stx def)
+      (syntax-case stx ()
+	[(_ orig-stx name elem ...)
+	 (do-open #'orig-stx #'name (syntax->list #'(elem ...))
+		  #f #f
+		  def)]))
+
+    (define (open/proc stx)
+      (generic-open stx #'define-syntaxes))
+    (define (open*/proc stx)
+      (generic-open stx #'define*-syntaxes))
+
+    (define (open/derived/proc stx)
+      (generic-open/derived stx #'define-syntaxes))
+    (define (open*/derived/proc stx)
+      (generic-open/derived stx #'define*-syntaxes))
+
+    (define (do-define-dot stx def-stxes path bind-name)
+      (unless (identifier? bind-name)
+	(raise-syntax-error #f "not an identifier" stx bind-name))
+      (let-values ([(path last) (split path)])
+	(do-open stx #f
+		 path
+		 last bind-name
+		 def-stxes)))
+
+    (define (generic-define-dot stx def-stxes)
+      (check-defn-context stx)
+      (syntax-case stx ()
+	((_ bind-name path1 path2 path3 ...)
+	 (do-define-dot stx def-stxes (syntax->list #'(path1 path2 path3 ...)) #'bind-name))))
+
+    (define (generic-define-dot/derived stx def-stxes)
+      (check-defn-context stx)
+      (syntax-case stx ()
+	((_ orig-stx bind-name path1 path2 path3 ...)
+	 (do-define-dot #'orig-stx def-stxes (syntax->list #'(path1 path2 path3 ...)) #'bind-name))))
+
+    (define (define-dot/proc stx)
+      (generic-define-dot stx #'define-syntaxes))
+
+    (define (define*-dot/proc stx)
+      (generic-define-dot stx #'define*-syntaxes))
+
+    (define (define-dot/derived/proc stx)
+      (generic-define-dot/derived stx #'define-syntaxes))
+
+    (define (define*-dot/derived/proc stx)
+      (generic-define-dot/derived stx #'define*-syntaxes))
+
+    (define (do-rename stx def-stxes)
+      (syntax-case stx ()
+	[(_ new-name old-name)
+	 (begin
+	   (unless (identifier? #'new-name)
+	     (raise-syntax-error #f "new name must be an identifier" stx #'new-name))
+	   (unless (identifier? #'old-name)
+	     (raise-syntax-error #f "old name must be an identifier" stx #'old-name))
+	   ;; Re-register if in nested int-def context, and if old-name has
+	   ;; a package mapping:
+	   (let ([ctx (syntax-local-context)])
+	     (when (list? ctx)
+	       (re-pre-register-package #f (syntax-local-context)
+					(syntax-local-introduce #'new-name)
+					(syntax-local-introduce #'old-name))))
+	   ;; Produce syntax-level renaming:
+	   #`(#,def-stxes (new-name) (make-rename-transformer (quote-syntax old-name))))]))
+
+    (define (rename-potential-package/proc stx)
+      (do-rename stx #'define-syntaxes))
+    (define (rename*-potential-package/proc stx)
+      (do-rename stx #'define*-syntaxes)))
+  
+  (define-syntax (dot stx)
+    (syntax-case stx ()
+      ((_ path1 path2 path-rest ...)
+       (let ([path (syntax->list #'(path1 path2 path-rest ...))])
+	 (for-each (lambda (elem)
+		     (unless (identifier? elem)
+		       (raise-syntax-error
+			#f
+			"path element must be an identfier"
+			stx
+			elem)))
+		   path)
+	 (let*-values ([(path field) (split path)])
+	   (quasisyntax/loc
+	    stx
+	    (let ()
+	      (package this-pkg all-defined
+		(open/derived #,stx #f #,@path))
+	      (let-syntax ([#,field (lambda (stx)
+				      (raise-syntax-error
+				       #f
+				       "no such exported identifier"
+				       (quote-syntax #,stx)
+				       stx))])
+		(open/derived #f #f this-pkg)
+		(let ()
+		  #,field)))))))))
+
+  )
\ No newline at end of file
diff --git a/collects/mzlib/pconvert.ss b/collects/mzlib/pconvert.ss
new file mode 100644
index 0000000000..83fcdd1f56
--- /dev/null
+++ b/collects/mzlib/pconvert.ss
@@ -0,0 +1,540 @@
+
+(module pconvert mzscheme
+  
+  (require (prefix s: "string.ss")
+           (prefix f: "list.ss"))
+  (require "class.ss")
+  (require "unit.ss")
+  
+  (provide show-sharing
+           constructor-style-printing
+           quasi-read-style-printing
+           abbreviate-cons-as-list
+           whole/fractional-exact-numbers
+           booleans-as-true/false
+           named/undefined-handler
+           use-named/undefined-handler
+           
+           print-convert
+           print-convert-expr
+           build-share
+           get-shared
+           current-read-eval-convert-print-prompt 
+           install-converting-printer
+           
+           current-build-share-name-hook
+           current-build-share-hook
+           current-print-convert-hook)
+  
+  (define undefined-val (letrec ([x x]) x))
+  
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; the value stored in the hash table.  Contains the name
+  ;; <which is a number unless we are in donkey and it already has a name>
+  ;; and whether or not it is shared in the expr.
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  (define-struct share-info (name shared?))
+  
+  (define boolean-filter (lambda (x) (and x #t)))
+  
+  (define show-sharing (make-parameter #t boolean-filter))
+  (define constructor-style-printing (make-parameter #f boolean-filter))
+  (define quasi-read-style-printing (make-parameter #t boolean-filter))
+  (define abbreviate-cons-as-list (make-parameter #t boolean-filter))
+  (define whole/fractional-exact-numbers (make-parameter #f boolean-filter))
+  (define booleans-as-true/false (make-parameter #t boolean-filter))
+  (define use-named/undefined-handler (make-parameter (lambda (x) #f)))
+  (define named/undefined-handler (make-parameter (lambda (x) #f)))
+  
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; share-hash is the hash-table containing info on what cons cells
+  ;; of the expression are shared.
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; sometimes you want to go ahead and start displaying a shared
+  ;; expression rather than just showing its name.  For instance, in
+  ;; the shared list, you want (shared ((-1- (list 1 2))... not
+  ;; (shared ((-1- -1-) ...
+  ;; expand-shared? controls this
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  (define-struct convert-share-info (share-hash expand-shared?))
+  
+  (define current-build-share-name-hook 
+    (make-parameter (let ([original-build-share-name-hook (lambda (e) #f)]) original-build-share-name-hook)
+                    (lambda (f)
+                      (unless (procedure-arity-includes? f 1)
+                        (raise-type-error 'current-build-share-name-hook "procedure of arity 1" f))
+                      f)))
+  (define current-build-share-hook 
+    (make-parameter (lambda (e base sub) (base e))
+                    (lambda (f)
+                      (unless (procedure-arity-includes? f 3)
+                        (raise-type-error 'current-build-share-hook "procedure of arity 3" f))
+                      f)))
+  (define current-print-convert-hook 
+    (make-parameter (lambda (e base sub) (base e))
+                    (lambda (f)
+                      (unless (procedure-arity-includes? f 3)
+                        (raise-type-error 'current--hook "procedure of arity 3" f))
+                      f)))
+  
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; builds the hash table
+  ;; --------- THIS PROCEDURE IS EXPORTED ----------
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  (define build-share
+    (lambda (expr)
+      (letrec
+          ([share-cnt 0]
+           [share-hash (make-hash-table)]
+           [csi (make-convert-share-info share-hash #f)]
+           [hash
+            (lambda (obj)
+              (let ([name ((current-build-share-name-hook) obj)])
+                (hash-table-put! share-hash obj
+                                 (make-share-info (if name (car name) share-cnt) #f)))
+              (set! share-cnt (add1 share-cnt)))]
+           [build-sub
+            (lambda (expr)
+              (let/ec k
+                (if (or (equal? expr "")
+                        (equal? expr #()))
+                    (k #f)
+                    (let ([val (hash-table-get share-hash expr 
+                                               (lambda ()
+                                                 (hash expr)
+                                                 (k #f)))])
+                      (when val
+                        (set-share-info-shared?! val #t))
+                      val))))]
+           [build
+            (lambda (expr)
+              ((current-build-share-hook)
+               expr
+               (lambda (expr)
+                 (cond
+                   [(or (number? expr)
+                        (symbol? expr)
+                        (boolean? expr)
+                        (char? expr) (void? expr)
+                        (null? expr)
+                        (eq? expr undefined-val) ; #<undefined> test - yuck
+                        )
+                    'atomic]
+                   [(and (not (struct? expr))  ;; struct names are the wrong thing, here
+                         (not (regexp? expr))
+                         (not (procedure? expr))
+                         (not (promise? expr))
+                         (not (object? expr))
+                         (not (unit? expr))
+                         (not (port? expr))
+                         (not (class? expr))
+                         (object-name expr))
+                    'atomic]
+                   [(box? expr) 
+                    (unless (build-sub expr)
+                      (build (unbox expr)))]
+                   [(hash-table? expr) 
+                    (unless (build-sub expr)
+                      (hash-table-for-each 
+                       expr
+                       (lambda (key value)
+                         (build value))))]
+                   [(pair? expr)  
+                    (unless (build-sub expr)
+                      (build (car expr))
+                      (build (cdr expr)))]
+                   [(vector? expr) 
+                    (unless (build-sub expr)
+                      (for-each build (vector->list expr)))]
+                   [(struct? expr)
+                    (unless (build-sub expr)
+                      (for-each build (vector->list (struct->vector expr))))]
+                   [else (build-sub expr)]))
+               build-sub))])
+        (build expr)
+        csi)))
+  
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; creates a distinctive symbol out of a name (usually just a number)
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  (define map-share-name
+    (lambda (name)
+      (string->symbol
+       (string-append "-" (s:expr->string name) "-"))))
+  
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; prints an expression given that it has already been hashed. This
+  ;; does not include the list of shared items.
+  ;; --------- THIS PROCEDURE IS EXPORTED ----------
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  (define print-convert-expr
+    (lambda (csi expr unroll-once?)
+      (letrec
+          ([share-hash (convert-share-info-share-hash csi)]
+           [find-hash
+            (lambda (expr)
+              (hash-table-get share-hash expr (lambda () #f)))]
+           [shared?
+            (lambda (expr)
+              (let* ([info (find-hash expr)]
+                     [ans (and info
+                               (share-info-shared? info))])
+                ans))]
+           
+           [make-list
+            (lambda (f n)
+              (letrec ([helper
+                        (lambda (n l)
+                          (cond [(zero? n) l]
+                                [else (helper (sub1 n) (cons (f n) l))]))])
+                (helper n null)))]
+           [make-lambda-helper
+            (lambda (arity)
+              (cond
+                [(arity-at-least? arity)
+                 (let ([v (arity-at-least-value arity)])
+                   (if (zero? v)
+                       'args
+                       (append (make-lambda-helper v) 'args)))]
+                [(list? arity)
+                 (map (lambda (x)
+                        (list (make-lambda-helper x) '...))
+                      arity)]
+                [else (make-list
+                       (lambda (x)
+                         (string->symbol
+                          (string-append "a" (number->string x))))
+                       arity)]))]
+           [use-quasi-quote? (not (constructor-style-printing))]
+           [use-read-syntax (quasi-read-style-printing)]
+           [doesnt-contain-shared-conses
+            (lambda (input-expr)
+              (letrec ([doesnt-contain-shared-conses
+                        (lambda (expr)
+                          (cond
+                            [(and (pair? expr)
+                                  (shared? expr))
+                             #f]
+                            [(pair? expr)
+                             (doesnt-contain-shared-conses (cdr expr))]
+                            [else #t]))])
+                (let ([answer (doesnt-contain-shared-conses input-expr)])
+                  answer)))]
+           [get-whole/frac
+            (lambda (exact-num)
+              (let ([split 
+                     (lambda (real)
+                       (let* ([num (numerator (abs real))]
+                              [den (denominator (abs real))]
+                              [sign (if (< real 0) - +)])
+                         (values (sign (quotient num den))
+                                 (sign (* (if (negative? num) -1 1)
+                                          (/ (modulo num den) den))))))])
+                (let-values ([(whole frac) (split (real-part exact-num))]
+                             [(whole-i frac-i) (split (imag-part exact-num))])
+                  (values whole frac whole-i frac-i))))]
+           [print
+            (lambda (in-quasiquote? first-time)
+              (lambda (expr)
+                (letrec
+                    ([lookup (find-hash expr)]
+                     [recur (print in-quasiquote? #f)]
+                     [self-quoting?
+                      (lambda (expr)
+                        (or (and (number? expr)
+                                 (or (inexact? expr)
+                                     (not (whole/fractional-exact-numbers))
+                                     (and (real? expr)
+                                          (or (let-values ([(whole frac whole-i frac-i) 
+                                                            (get-whole/frac expr)])
+                                                (and (or (zero? whole)
+                                                         (zero? frac))))))))
+                            (and (symbol? expr)
+                                 (not (eq? expr 'quasiquote))
+                                 (not (eq? expr 'quote))
+                                 (not (eq? expr 'unquote))
+                                 (not (eq? expr 'quote-syntax))
+                                 (not (eq? expr 'syntax)))
+                            (char? expr)
+                            (string? expr)
+                            (not expr)
+                            (eq? #t expr)))]
+                     [quasi-read-style
+                      (lambda ()
+                        (cond
+                          [(box? expr) (box (recur (unbox expr)))]
+                          [(vector? expr) (apply vector (map recur (vector->list expr)))]
+                          [else (quasi-style)]))]
+                     [quasi-style
+                      (lambda ()
+                        (cond
+                          [(null? expr) '()]
+                          [(and (pair? expr)
+                                (pair? (cdr expr))
+                                (null? (cddr expr))
+                                (or (eq? (car expr) 'quote)
+                                    (eq? expr 'quasiquote)
+                                    (eq? expr 'quote)
+                                    (eq? expr 'unquote)
+                                    (eq? expr 'quote-syntax)
+                                    (eq? expr 'syntax)))
+                           `(,(car expr) ,(recur (cadr expr)))]
+                          [(and (list? expr)
+                                (doesnt-contain-shared-conses expr))
+                           (map recur expr)]
+                          [(pair? expr) 
+                           (cons (recur (car expr)) (recur (cdr expr)))]
+                          [(self-quoting? expr) expr]
+                          [else `(,'unquote ,((print #f first-time) expr))]))]
+                     
+                     [guard/quasiquote
+                      (lambda (f)
+                        (cond
+                          [use-quasi-quote?
+                           `(,'quasiquote ,(if use-read-syntax
+                                               ((print #t first-time) expr)
+                                               ((print #t first-time) expr)))]
+                          [else
+                           (f)]))]
+                     [constructor-style
+                      (let ([build-named
+                              (lambda (expr build-unnamed)
+                                (let ([answer (and (not (struct? expr))
+                                                   (object-name expr))])
+                                  (cond
+                                    [(not answer)
+                                     (build-unnamed)]
+                                    [(let/ec k
+				       (eq?
+					(namespace-variable-value
+					 answer
+					 #t
+                                         (lambda () (k #f)))
+					expr))
+                                     answer]
+                                    [((use-named/undefined-handler) expr)
+                                     ((named/undefined-handler) expr)]
+                                    [else
+                                     (build-unnamed)])))])
+                        (lambda ()
+                          ((current-print-convert-hook)
+                           expr
+                           (lambda (expr)
+                             (cond
+                               [(null? expr) (guard/quasiquote (lambda () 'empty))]
+                               [(and (abbreviate-cons-as-list)
+                                     (list? expr)
+                                     (or (and first-time
+                                              (doesnt-contain-shared-conses (cdr expr)))
+                                         (doesnt-contain-shared-conses expr)))
+                                (guard/quasiquote
+                                 (lambda ()
+                                   `(list ,@(map recur expr))))]
+                               [(pair? expr)
+                                (guard/quasiquote
+                                 (lambda ()
+                                   `(cons ,(recur (car expr)) ,(recur (cdr expr)))))]
+                               [(weak-box? expr) `(make-weak-box ,(recur (weak-box-value expr)))]
+                               [(box? expr) `(box ,(recur (unbox expr)))]
+                               [(hash-table? expr) `(hash-table 
+                                                     ,@(cond
+                                                         [(hash-table? expr 'weak 'equal) '('equal 'weak)]
+                                                         [(hash-table? expr 'equal) '('equal)]
+                                                         [(hash-table? expr 'weak) '('weak)]
+                                                         [else '()])
+                                                     ,@(hash-table-map
+                                                        expr
+                                                        (lambda (k v)
+                                                          `(,(recur k) ,(recur v)))))]
+                               [(vector? expr) `(vector ,@(map recur (vector->list expr)))]
+                               [(symbol? expr) `',expr]
+                               [(string? expr) expr]
+                               [(primitive? expr) (object-name expr)]
+                               [(procedure? expr)
+                                (build-named
+                                 expr
+                                 (lambda ()
+                                   (let ([arity (procedure-arity expr)])
+                                     (if (list? arity)
+                                         `(case-lambda . ,(make-lambda-helper arity))
+                                         `(lambda ,(make-lambda-helper arity) ...)))))]
+                               [(regexp? expr) `(regexp ,(or (object-name expr)
+                                                             '...))]
+                               [(module-path-index? expr) 
+                                (let-values ([(left right) (module-path-index-split expr)])
+                                  `(module-path-index-join ,(recur left) ,(recur right)))]
+                               [(interface? expr) `(interface ...)]
+                               [(class? expr) 
+                                (build-named 
+                                 expr
+                                 (lambda () '(class ...)))]
+                               [(object? expr) `(instantiate
+                                                    ,(build-named 
+                                                      (object-interface expr)
+                                                      (lambda () '(class ...)))
+                                                  ...)]
+                               [(void? expr) '(void)]
+                               [(promise? expr) '(delay ...)]
+                               [(unit? expr) (build-named 
+                                              expr
+                                              (lambda () 
+                                                '(unit ...)))]
+                               [(and (number? expr) (exact? expr))
+                                (let-values ([(whole frac whole-i frac-i) (get-whole/frac expr)])
+                                  (cond
+                                    [(not (whole/fractional-exact-numbers)) expr]
+                                    [(and (or (zero? whole)
+                                              (zero? frac))
+                                          (zero? whole-i)
+                                          (zero? frac-i))
+                                     expr]
+                                    [(real? expr) `(+ ,whole ,frac)]
+                                    [(and (or (zero? whole) (zero? frac))
+                                          (or (zero? whole-i) (zero? frac-i)))
+                                     `(+ ,(real-part expr) (* +1i ,(imag-part expr)))]
+                                    [(or (zero? whole-i) (zero? frac-i))
+                                     `(+ (+ ,whole ,frac) (* +1i ,(imag-part expr)))]
+                                    [(or (zero? whole) (zero? frac))
+                                     `(+ ,(real-part expr) (* +1i (+ ,whole-i ,frac-i)))]
+                                    [else `(+ (+ ,whole ,frac) (* +1i (+ ,whole-i ,frac-i)))]))]
+                               [(eq? expr #f) (if (booleans-as-true/false) 'false #f)]
+                               [(eq? expr #t) (if (booleans-as-true/false) 'true #t)]
+                               
+                               [(and (input-port? expr)
+                                     (file-stream-port? expr)
+                                     (object-name expr))
+                                `(open-input-file ,(object-name expr))]
+                               [(and (output-port? expr)
+                                     (file-stream-port? expr)
+                                     (object-name expr))
+                                `(open-output-file ,(object-name expr))]
+                               [(port? expr) expr]
+                               
+                               ;; this case must be next to last, so that all of the
+                               ;; things with object-name's fall into the cases above first
+                               [(object-name expr)
+                                (let* ([name (object-name expr)]
+                                       [str-name (if (string? name)
+                                                     name
+                                                     (symbol->string name))]
+                                       [uniq (box #f)])
+                                  `(,(string->symbol (string-append "make-" str-name))
+                                    ,@(map (lambda (x) 
+                                             (if (eq? uniq x)
+                                                 '...
+                                                 (recur x)))
+                                           (cdr (vector->list (struct->vector expr uniq))))))]
+                               
+                               [else expr]))
+                           recur)))])
+                  (let ([es (convert-share-info-expand-shared? csi)])
+                    (set-convert-share-info-expand-shared?! csi #f)
+                    (if (and lookup
+                             (not es)
+                             (not first-time)
+                             (share-info-shared? lookup))
+                        (let ([name (map-share-name (share-info-name lookup))])
+                          (if in-quasiquote?
+                              `(,'unquote ,name)
+                              name))
+                        (if in-quasiquote?
+                            (if use-read-syntax
+                                (quasi-read-style)
+                                (quasi-style))
+                            (constructor-style)))))))])
+        ((print #f unroll-once?) expr))))
+  
+  ;; type (improper-list a) = (union (cons (improper-list a) (improper-list a)) null a)
+  ;; improper-map : (a -> b) -> (improper-list a) -> (improper-list b)
+  (define (improper-map f x)
+    (cond
+      [(pair? x) (cons (f (car x)) (improper-map f (cdr x)))]
+      [(null? x) null]
+      [else (f x)]))
+  
+  
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; these functions get the list of shared items.  If just-circular is
+  ;; true, then it will modify the hash table so that the only shared
+  ;; items are those that are circular.
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  
+  (define get-shared-helper
+    (lambda (csi)
+      (let ([shared '()]
+            [share-hash (convert-share-info-share-hash csi)])
+        (hash-table-for-each share-hash
+                             (lambda (key val)
+                               (when (share-info-shared? val)
+                                 (set! shared (cons (list key val) shared)))))
+        (map (lambda (s)
+               (set-convert-share-info-expand-shared?! csi #t)
+               (let* ([info (cadr s)]
+                      [name (share-info-name info)])
+                 (list info
+                       (map-share-name name)
+                       (print-convert-expr csi (car s) #t))))
+             shared))))
+  
+  ;; --------- THIS PROCEDURE IS EXPORTED ----------
+  (define get-shared
+    (case-lambda
+      [(csi) (get-shared csi #f)]
+      [(csi just-circular)
+       (let ([shared-listss
+              (if just-circular
+                  (let ([shared (get-shared-helper csi)])
+                    (for-each (lambda (x)
+                                (unless (member* (cadr x) (caddr x))
+                                  (set-share-info-shared?! (car x) #f)))
+                              shared)
+                    (get-shared-helper csi))
+                  (get-shared-helper csi))]
+             [cmp 
+              (lambda (x y)
+                (string<? (s:expr->string (share-info-name (car x)))
+                          (s:expr->string (share-info-name (car y)))))])
+         (map cdr (f:quicksort shared-listss cmp)))]))
+  
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; helper function for determining if an item is circular.  In the
+  ;; shared list: (shared ((-1- (list 1 2)) (-2- (list -2- 2 3)))), you
+  ;; can tell by doing a member* of the first item on the second. In this
+  ;; case, the second item in the shared list is circular because -2- appears
+  ;; in the value
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  (define member*
+    (lambda (a l)
+      (cond [(or (not (pair? l)) (null? l)) #f]
+            [(eq? a (car l)) #t]
+            [else (or (member* a (car l)) (member* a (cdr l)))])))
+  
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; takes an expression and completely converts it to show sharing
+  ;; (or if just-circular, just circularity) and special forms.
+  ;; --------- THIS PROCEDURE IS EXPORTED ----------
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  (define print-convert
+    (case-lambda
+      [(expr) (print-convert expr (not (show-sharing)))]
+      [(expr just-circ)
+       (let* ([csi (build-share expr)])
+         (let ([shared (get-shared csi just-circ)]
+               [body (print-convert-expr csi expr #f)])
+           (if (null? shared)
+               body
+               `(shared ,shared ,body))))]))
+  
+  (define current-read-eval-convert-print-prompt
+    (make-parameter "|- "))
+  
+  (define install-converting-printer
+    (lambda ()
+      (let ([print (current-print)])
+        (current-print (lambda (v)
+                         (unless (void? v)
+                           (print (print-convert v))))))
+      (current-prompt-read (lambda ()
+                             (display (current-read-eval-convert-print-prompt))
+                             (read-syntax 'STDIN))))))
diff --git a/collects/mzlib/plt-match.ss b/collects/mzlib/plt-match.ss
new file mode 100644
index 0000000000..9d069aa0a9
--- /dev/null
+++ b/collects/mzlib/plt-match.ss
@@ -0,0 +1,158 @@
+;; (documentation (name plt-match))
+;; <pre>Pattern Matching Syntactic Extensions for Scheme
+;;
+;; All bugs or questions concerning this software should be directed to
+;; Bruce Hauman <bhauman@cs.wcu.edu>.  The latest version of this software
+;; can be obtained from http://sol.cs.wcu.edu/~bhauman/scheme/pattern.php.
+;;
+;; Special thanks go out to:
+;; Robert Bruce Findler for support and bug detection.
+;; Doug Orleans for pointing out that pairs should be reused while
+;; matching lists.
+;;
+;;
+;; Originally written by Andrew K. Wright, 1993 (wright@research.nj.nec.com)
+;; which in turn was adapted from code written by Bruce F. Duba, 1991.
+;;
+;; This software is in the public domain.  Feel free to copy,
+;; distribute, and modify this software as desired.  No warranties
+;; nor guarantees of any kind apply.  Please return any improvements
+;; or bug fixes to bhauman@cs.wcu.edu so that they may be included
+;; in future releases.
+;;
+;; This macro package extends Scheme with several new expression forms.
+;; Following is a brief summary of the new forms.  See the associated
+;; LaTeX documentation for a full description of their functionality.
+;;
+;;
+;;         match expressions:
+;;
+;; exp ::= ...
+;;       | (match exp clause ...)
+;;       | (match-lambda clause ...) 
+;;       | (match-lambda* clause ...)
+;;       | (match-let ((pat exp) ...) body ...)
+;;       | (match-let var ((pat exp) ...) body ...)
+;;       | (match-let* ((pat exp) ...) body ...)
+;;       | (match-letrec ((pat exp) ...) body ...)
+;;       | (match-define pat exp)
+;;
+;; clause ::= (pat body) | (pat (=> identifier) exp)
+;;
+;;         patterns:                       matches:
+;;
+;; pat ::= 
+;;         identifier                      this binds an identifier if it 
+;;                                         doesn't conflict with ..k, __k or _
+;;       | _                               anything
+;;       | #t                              #t
+;;       | #f                              #f
+;;       | string                          a string
+;;       | number                          a number
+;;       | character                       a character
+;;       | 'sexp                           an s-expression
+;;       | 'symbol                         a symbol (special case of s-expr)
+;;       | (var id)                        allows one to use ..k or _ as 
+;;                                         identifiers
+;;       | (list lvp_1 ... lvp_n)               list of n elements
+;;       | (list-rest lvp_1 ... lvp_n pat) an improper list of n elements
+;;                                         plus a last element which represents
+;;                                         the last cdr of the list
+;;       | (vector lvp_1 ... lvp_n)        vector of n elements
+;;       | (box pat)                       box
+;;       | (struct struct-name (pat_1 ... pat_n)) a structure
+;;       | (regexp exp)                     if regular expression exp matches
+;;       | (regexp exp pat)                 if result of regexp-match matches pat
+;;       | (pregexp exp)                    if pregexp.ss regular expression exp matches
+;;       | (pregexp exp pat)                if result of pregexp-match matches pat
+;;       | (list-no-order pat ...)         matches a list with no regard for 
+;;                                         the order of the
+;;                                         items in the list
+;;       | (list-no-order pat ... pat_n ooo) pat_n matches the remaining 
+;;                                           unmatched items
+;;       | (hash-table (pat_k pat_v) ...)  matches the elements of a hash table
+;;       | (hash-table (pat_k pat_v) ... (pat_kn pat_vn) ooo)  
+;;                                         pat_kn must match the remaining 
+;;                                         unmatched key elements
+;;                                         pat_vn must match the remaining 
+;;                                         unmatched value elements
+;;       | (app field pat)                 a field of a structure (field is 
+;;                                         an accessor)
+;;                                         Actually field can be any function 
+;;                                         which can be
+;;                                         applied to the data being matched.
+;;                                         Ex: (match 5 ((= add1 b) b)) => 6
+;;
+;;       | (and pat_1 ... pat_n)           if all of pat_1 thru pat_n match
+;;       | (or pat_1 ... pat_n)            if any of pat_1 thru pat_n match
+;;       | (not pat_1 ... pat_n)           if all pat_1 thru pat_n don't match
+;;       | (? predicate pat_1 ... pat_n)   if predicate true and all of
+;;                                           pat_1 thru pat_n match
+;;       | (set! identifier)               anything, and binds setter
+;;       | (get! identifier)               anything, and binds getter
+;;       | `qp                             a quasi-pattern
+;;
+;; lvp ::= pat ooo                         greedily matches n or more of pat, 
+;;                                         each element must match pat
+;;       | pat                             matches pat
+;;
+;; ooo ::= ...                             zero or more
+;;       | ___                             zero or more
+;;       | ..k                             k or more
+;;       | __k                             k or more
+;;
+;;         quasi-patterns:                 matches:
+;;
+;; qp  ::= ()                              the empty list
+;;       | #t                              #t
+;;       | #f                              #f
+;;       | string                          a string
+;;       | number                          a number
+;;       | character                       a character
+;;       | identifier                      a symbol
+;;       | (qp_1 ... qp_n)                 list of n elements
+;;       | (qp_1 ... qp_n . qp_{n+1})      list of n or more
+;;       | (qp_1 ... qp_n qp_n+1 ooo)      list of n or more, each element
+;;                                           of remainder must match qp_n+1
+;;       | #(qp_1 ... qp_n)                vector of n elements
+;;       | #(qp_1 ... qp_n qp_n+1 ooo)     vector of n or more, each element
+;;                                           of remainder must match qp_n+1
+;;       | #&qp                            box
+;;       | ,pat                            a pattern
+;;       | ,@(list lvp . . . lvp-n)
+;;       | ,@(list-rest lvp-1 . . . lvp-n pat)
+;;       | ,@`qp                           qp must evaluate to a list as 
+;;                                         so that this rule resembles the 
+;;                                         above two rules
+;;
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; 
+
+(module plt-match mzscheme
+  (provide 
+   match
+   match-lambda
+   match-lambda*
+   match-let
+   match-let*
+   match-letrec
+   match-define
+   match:test-no-order
+   pregexp-match-with-error
+   exn:misc:match?
+   exn:misc:match-value
+   match-equality-test
+   define-match-expander) 
+  
+  (require "private/match-internal-func.ss"
+           "private/match-expander.ss"
+           "private/match-helper.ss"
+           "private/match-error.ss"
+           "private/render-helpers.ss")
+  
+  )
+
+
+
+
diff --git a/collects/mzlib/port.ss b/collects/mzlib/port.ss
new file mode 100644
index 0000000000..1a928c372e
--- /dev/null
+++ b/collects/mzlib/port.ss
@@ -0,0 +1,1529 @@
+
+(module port mzscheme
+  (require (lib "etc.ss")
+	   (lib "contract.ss")
+	   (lib "list.ss")
+	   "private/port.ss")
+
+  (provide open-output-nowhere
+	   make-pipe-with-specials
+	   make-input-port/read-to-peek
+	   peeking-input-port
+	   relocate-input-port
+	   transplant-input-port
+	   relocate-output-port
+	   transplant-output-port
+	   merge-input
+	   copy-port
+	   input-port-append
+	   convert-stream
+	   make-limited-input-port
+	   reencode-input-port
+	   reencode-output-port)
+
+  (define (exact-non-negative-integer? i)
+    (and (number? i) (exact? i) (integer? i) (i . >= . 0)))
+
+  (define (input-port-with-progress-evts? ip)
+    (and (input-port? ip)
+	 (port-provides-progress-evts? ip)))
+
+  (define (mutable-bytes? b)
+    (and (bytes? b) (not (immutable? b))))
+  (define (mutable-string? b)
+    (and (string? b) (not (immutable? b))))
+
+  (define (line-mode-symbol? s)
+    (memq s '(linefeed return return-linefeed any any-one)))
+
+  (define (evt?/false v)
+    (or (eq? #f v) (evt? v)))
+  
+  (provide/contract (read-bytes-avail!-evt (mutable-bytes? input-port-with-progress-evts?
+							   . -> . evt?))
+		    (peek-bytes-avail!-evt (mutable-bytes? exact-non-negative-integer? evt?/false
+							   input-port-with-progress-evts? 
+							   . -> . evt?))
+		    (read-bytes!-evt (mutable-bytes? input-port-with-progress-evts? . -> . evt?))
+		    (peek-bytes!-evt (mutable-bytes? exact-non-negative-integer? evt?/false
+						     input-port-with-progress-evts? 
+						     . -> . evt?))
+		    (read-bytes-evt (exact-non-negative-integer? input-port-with-progress-evts? 
+								 . -> . evt?))
+		    (peek-bytes-evt (exact-non-negative-integer? exact-non-negative-integer? evt?/false
+								 input-port-with-progress-evts? 
+								 . -> . evt?))
+		    (read-string!-evt (mutable-string? input-port-with-progress-evts? 
+						       . -> . evt?))
+		    (peek-string!-evt (mutable-string? exact-non-negative-integer? evt?/false
+						       input-port-with-progress-evts? 
+						       . -> . evt?))
+		    (read-string-evt (exact-non-negative-integer? input-port-with-progress-evts? 
+								  . -> . evt?))
+		    (peek-string-evt (exact-non-negative-integer? exact-non-negative-integer? evt?/false
+								  input-port-with-progress-evts? 
+								  . -> . evt?))
+		    (regexp-match-evt ((union regexp? byte-regexp? string? bytes?)
+				       input-port-with-progress-evts? 
+				       . -> . evt?))
+
+		    (read-bytes-line-evt (case->
+					  (input-port-with-progress-evts? . -> . evt?)
+					  (input-port-with-progress-evts? line-mode-symbol? . -> . evt?)))
+		    (read-line-evt (case->
+				    (input-port-with-progress-evts? . -> . evt?)
+				    (input-port-with-progress-evts? line-mode-symbol? . -> . evt?)))
+		    (eof-evt (input-port-with-progress-evts? . -> . evt?)))
+
+  ;; ----------------------------------------
+
+  (define (copy-port src dest . dests)
+    (unless (input-port? src)
+      (raise-type-error 'copy-port "input-port" src))
+    (for-each
+     (lambda (dest)
+       (unless (output-port? dest)
+	 (raise-type-error 'copy-port "output-port" dest)))
+     (cons dest dests))
+    (let ([s (make-bytes 4096)]
+	  [dests (cons dest dests)])
+      (let loop ()
+	(let ([c (read-bytes-avail! s src)])
+	  (cond
+	   [(number? c)
+	    (for-each
+	     (lambda (dest)
+	       (let loop ([start 0])
+		 (unless (= start c)
+		   (let ([c2 (write-bytes-avail s dest start c)])
+		     (loop (+ start c2))))))
+	     dests)
+	    (loop)]
+	   [(procedure? c)
+	    (let ([v (let-values ([(l col p) (port-next-location src)])
+		       (c (object-name src) l col p))])
+	      (for-each
+	       (lambda (dest) (write-special v dest))
+	       dests))
+	    (loop)]
+	   [else
+	    ;; Must be EOF
+	    (void)])))))
+  
+  (define merge-input
+    (case-lambda
+     [(a b) (merge-input a b 4096)]
+     [(a b limit)
+      (or (input-port? a)
+	  (raise-type-error 'merge-input "input-port" a))
+      (or (input-port? b)
+	  (raise-type-error 'merge-input "input-port" b))
+      (or (not limit)
+	  (and (number? limit) (positive? limit) (exact? limit) (integer? limit))
+	  (raise-type-error 'merge-input "positive exact integer or #f" limit))
+      (let-values ([(rd wt) (make-pipe-with-specials limit)]
+		   [(other-done?) #f]
+		   [(sema) (make-semaphore 1)])
+	(let ([copy
+	       (lambda (from)
+                 (thread 
+                  (lambda ()
+                    (copy-port from wt)
+                    (semaphore-wait sema)
+                    (if other-done?
+                        (close-output-port wt)
+                        (set! other-done? #t))
+                    (semaphore-post sema))))])
+	  (copy a)
+	  (copy b)
+	  rd))]))
+
+  ;; Not kill-safe.
+  ;; If the `read' proc returns an event, the event must produce 
+  ;;  0 always
+  (define make-input-port/read-to-peek 
+    (opt-lambda (name read fast-peek close 
+		      [location-proc #f] 
+		      [count-lines!-proc void] 
+		      [init-position 1]
+		      [buffer-mode-proc #f])
+      (define lock-semaphore (make-semaphore 1))
+      (define commit-semaphore (make-semaphore 1))
+      (define-values (peeked-r peeked-w) (make-pipe))
+      (define special-peeked null)
+      (define special-peeked-tail #f)
+      (define progress-requested? #f)
+      (define use-manager? #f)
+      (define manager-th #f)
+      (define manager-ch (make-channel))
+      (define resume-ch (make-channel))
+      (define buf (make-bytes 4096))
+      (define (try-again)
+	(wrap-evt
+	 (semaphore-peek-evt lock-semaphore)
+	 (lambda (x) 0)))
+      (define (suspend-manager)
+	(channel-put manager-ch 'suspend))
+      (define (resume-manager)
+	(channel-put resume-ch 'resume))
+      (define (with-manager-lock thunk)
+	(thread-resume manager-th (current-thread))
+	(dynamic-wind suspend-manager thunk resume-manager))
+      (define (make-progress)
+	(write-byte 0 peeked-w)
+	(read-byte peeked-r))
+      (define (read-it-with-lock s)
+	(if use-manager?
+	    (with-manager-lock (lambda () (do-read-it s)))
+	    (do-read-it s)))
+      (define (read-it s)
+	(call-with-semaphore
+	 lock-semaphore
+	 read-it-with-lock
+	 try-again
+	 s))
+      (define (do-read-it s)
+	(if (char-ready? peeked-r)
+	    (read-bytes-avail!* s peeked-r)
+	    ;; If nothing is saved from a peeking read,
+	    ;; dispatch to `read', otherwise return
+	    ;; previously peeked data
+	    (cond
+	     [(null? special-peeked) 
+	      (when progress-requested? (make-progress))
+	      (read s)]
+	     [else (if (bytes? (car special-peeked))
+		       (let ([b (car special-peeked)])
+			 (write-bytes b peeked-w)
+			 (set! special-peeked (cdr special-peeked))
+			 (when (null? special-peeked)
+			   (set! special-peeked-tail #f))
+			 (read-bytes-avail!* s peeked-r))
+		       (begin0
+			(car special-peeked)
+			(make-progress)
+			(set! special-peeked (cdr special-peeked))
+			(when (null? special-peeked)
+			  (set! special-peeked-tail #f))))])))
+      (define (peek-it-with-lock s skip unless-evt)
+	(if use-manager?
+	    (with-manager-lock (lambda () (do-peek-it s skip unless-evt)))
+	    (do-peek-it s skip unless-evt)))
+      (define (peek-it s skip unless-evt)
+	(let ([v (peek-bytes-avail!* s skip unless-evt peeked-r)])
+	  (if (eq? v 0)
+	      (call-with-semaphore
+	       lock-semaphore
+	       peek-it-with-lock
+	       try-again
+	       s skip unless-evt)
+	      v)))
+      (define (do-peek-it s skip unless-evt)
+	(let ([v (peek-bytes-avail!* s skip unless-evt peeked-r)])
+	  (if (eq? v 0)
+	      ;; The peek may have failed because peeked-r is empty,
+	      ;; because unless-evt is ready, or because the skip is
+	      ;; far. Handle nicely the common case where there are no
+	      ;; specials.
+	      (cond
+	       [(and unless-evt (sync/timeout 0 unless-evt))
+		#f]
+	       [(null? special-peeked)
+		;; Empty special queue, so read through the original proc.
+		;; We only only need 
+		;;  (- (+ skip (bytes-length s)) (pipe-content-length peeked-w))
+		;; bytes, but read more (up to size of buf) to help move
+		;; things along.
+		(let* ([r (read buf)])
+		  (cond
+		   [(number? r)
+		    ;; The nice case --- reading gave us more bytes
+		    (write-bytes buf peeked-w 0 r)
+		    ;; Now try again
+		    (peek-bytes-avail!* s skip #f peeked-r)]
+		   [(evt? r)
+		    (if unless-evt
+			;; Technically, there's a race condition here.
+			;; We might choose r (and return 0) even when
+			;; unless-evt becomes available first. However,
+			;; this race is detectable only by the inside
+			;; of `read'.
+			(choice-evt r (wrap-evt unless-evt (lambda (x) #f)))
+			r)]
+		   [else
+		    (set! special-peeked (cons r null))
+		    (set! special-peeked-tail special-peeked)
+		    ;; Now try again
+		    (do-peek-it s skip unless-evt)]))]
+	       [else
+		;; Non-empty special queue, so try to use it
+		(let* ([avail (pipe-content-length peeked-r)]
+		       [sk (- skip avail)])
+		  (let loop ([sk sk]
+			     [l special-peeked])
+		    (cond
+		     [(null? l)
+		      ;; Not enough even in the special queue.
+		      ;; Read once and add it.
+		      (let* ([t (make-bytes (min 4096 (+ sk (bytes-length s))))]
+			     [r (read t)])
+			(cond
+			 [(evt? r) 
+			  (if unless-evt
+			      ;; See note above
+			      (choice-evt r (wrap-evt unless-evt (lambda (x) #f)))
+			      r)]
+			 [(eq? r 0) 
+			  ;; Original read thinks a spin is ok,
+			  ;;  so we return 0 to skin, too.
+			  0]
+			 [else (let ([v (if (number? r)
+					    (subbytes t 0 r)
+					    r)])
+				 (let ([pr (cons v null)])
+				   (set-cdr! special-peeked-tail pr)
+				   (set! special-peeked-tail pr))
+				 ;; Got something; now try again
+				 (do-peek-it s skip unless-evt))]))]
+		     [(eof-object? (car l)) 
+		      ;; No peeking past an EOF
+		      eof]
+		     [(procedure? (car l))
+		      (if (zero? sk)
+			  (car l)
+			  (loop (sub1 sk) (cdr l)))]
+		     [(bytes? (car l))
+		      (let ([len (bytes-length (car l))])
+			(if (sk . < . len)
+			    (let ([n (min (bytes-length s)
+					  (- len sk))])
+			      (bytes-copy! s 0 (car l) sk (+ sk n))
+			      n)
+			    (loop (- sk len) (cdr l))))])))])
+	      v)))
+      (define (commit-it-with-lock amt unless-evt done-evt)
+	(if use-manager?
+	    (with-manager-lock (lambda () (do-commit-it amt unless-evt done-evt)))
+	    (do-commit-it amt unless-evt done-evt)))
+      (define (commit-it amt unless-evt done-evt)
+	(call-with-semaphore
+	 lock-semaphore
+	 commit-it-with-lock
+	 #f
+	 amt unless-evt done-evt))
+      (define (do-commit-it amt unless-evt done-evt)
+	(if (sync/timeout 0 unless-evt)
+	    #f
+	    (let* ([avail (pipe-content-length peeked-r)]
+		   [p-commit (min avail amt)])
+	      (let loop ([amt (- amt p-commit)]
+			 [l special-peeked])
+		(cond
+		 [(amt . <= . 0)
+		  ;; Enough has been peeked. Do commit...
+		  (actual-commit p-commit l unless-evt done-evt)]
+		 [(null? l)
+		  ;; Requested commit was larger than previous peeks
+		  #f]
+		 [(bytes? (car l))
+		  (let ([bl (bytes-length (car l))])
+		    (if (bl . > . amt)
+			;; Split the string
+			(let ([next (cons
+				     (subbytes (car l) amt)
+				     (cdr l))])
+			  (set-car! l (subbytes (car l) 0 amt))
+			  (set-cdr! l next)
+			  (when (eq? l special-peeked-tail)
+			    (set! special-peeked-tail next))
+			  (loop 0 (cdr l)))
+			;; Consume this string...
+			(loop  (- amt bl) (cdr l))))]
+		 [else
+		  (loop (sub1 amt) (cdr l))])))))
+      (define (actual-commit p-commit l unless-evt done-evt)
+	;; The `finish' proc finally, actually, will commit...
+	(define (finish)
+	  (unless (zero? p-commit)
+	    (peek-byte peeked-r (sub1 p-commit))
+	    (port-commit-peeked p-commit unless-evt always-evt peeked-r))
+	  (set! special-peeked l)
+	  (when (null? special-peeked)
+	    (set! special-peeked-tail #f))
+	  (when (and progress-requested? (zero? p-commit))
+	    (make-progress))
+	  #t)
+	;; If we can sync done-evt immediately, then finish.
+	(if (sync/timeout 0 (wrap-evt done-evt (lambda (x) #t)))
+	    (finish)
+	    ;; We need to wait, so we'll have to release the lock.
+	    ;; Send the work to a manager thread.
+	    (let ([result-ch (make-channel)]
+		  [w/manager? use-manager?])
+	      (if w/manager?
+		  ;; Resume manager if it was running:
+		  (resume-manager)
+		  ;; Start manager if it wasn't running:
+		  (begin
+		    (set! manager-th (thread manage-commits))
+		    (set! use-manager? #t)
+		    (thread-resume manager-th (current-thread))))
+	      ;; Sets use-manager? if the manager wasn't already running:
+	      (channel-put manager-ch (list finish unless-evt done-evt result-ch))
+	      ;; Release locks:
+	      (semaphore-post lock-semaphore)
+	      (begin0
+	       ;; Wait for manager to complete commit:
+	       (sync result-ch)
+	       ;; Grab locks again, so they're released
+	       ;;  properly on exit:
+	       (semaphore-wait lock-semaphore)
+	       (when w/manager?
+		 (suspend-manager))))))
+      (define (manage-commits)
+	(let loop ([commits null])
+	  (apply
+	   sync
+	   (handle-evt manager-ch
+		       (lambda (c)
+			 (case c
+			   [(suspend)
+			    (channel-get resume-ch)
+			    (loop commits)]
+			   [else
+			    ;; adding a commit
+			    (loop (cons c commits))])))
+	   (map (lambda (c)
+		  (define (send-result v)
+		    ;; Create a new thread to send the result asynchronously:
+		    (thread-resume
+		     (thread (lambda ()
+			       (channel-put (list-ref c 3) v)))
+		     (current-thread))
+		    (when (null? (cdr commits))
+		      (set! use-manager? #f))
+		    (loop (remq c commits)))
+		  ;; Choose between done and unless:
+		  (if (sync/timeout 0 (list-ref c 1))
+		      (handle-evt always-evt
+				  (lambda (x)
+				    (send-result #f)))
+		      (choice-evt
+		       (handle-evt (list-ref c 1)
+				   (lambda (x)
+				     ;; unless ready, which means that the commit must fail
+				     (send-result #f)))
+		       (handle-evt (list-ref c 2)
+				   (lambda (x)
+				     ;; done-evt ready, which means that the commit
+				     ;;  must succeed.
+				     ;; If we get here, then commits are not
+				     ;; suspended, so we implicitly have the
+				     ;; lock.
+				     ((list-ref c 0))
+				     (send-result #t))))))
+		commits))))
+      (make-input-port
+       name
+       ;; Read
+       read-it
+       ;; Peek
+       (if fast-peek
+	   (let ([fast-peek-k (lambda (s skip)
+				(peek-it s skip #f))])
+	     (lambda (s skip unless-evt)
+	       (if (or unless-evt
+		       (char-ready? peeked-r)
+		       (pair? special-peeked))
+		   (peek-it s skip unless-evt)
+		   (fast-peek s skip fast-peek-k))))
+	   peek-it)
+       close
+       (lambda ()
+	 (set! progress-requested? #t)
+	 (port-progress-evt peeked-r))
+       commit-it
+       location-proc
+       count-lines!-proc
+       init-position
+       buffer-mode-proc)))
+
+  (define peeking-input-port
+    (opt-lambda (orig-in [name (object-name orig-in)] [delta 0])
+      (make-input-port/read-to-peek
+       name
+       (lambda (s)
+	 (let ([r (peek-bytes-avail!* s delta #f orig-in)])
+	   (set! delta (+ delta (cond
+				 [(number? r) r]
+				 [else 1])))
+	   (if (eq? r 0)
+	       (handle-evt orig-in (lambda (v) 0))
+	       r)))
+       (lambda (s skip default)
+	 (peek-bytes-avail!* s (+ delta skip) #f orig-in))
+       void)))
+
+  (define relocate-input-port
+    (opt-lambda (p line col pos [close? #t])
+      (transplant-to-relocate
+       transplant-input-port
+       p line col pos close?)))
+
+  (define transplant-input-port
+    (opt-lambda (p location-proc pos [close? #t] [count-lines!-proc void])
+      (make-input-port
+       (object-name p)
+       (lambda (s) (let ([v (read-bytes-avail!* s p)])
+		     (if (eq? v 0)
+			 (wrap-evt p (lambda (x) 0))
+			 v)))
+       (lambda (s skip evt) 
+	 (let ([v (peek-bytes-avail!* s skip evt p)])
+	   (if (eq? v 0)
+	       (choice-evt
+		(wrap-evt p (lambda (x) 0))
+		(if evt
+		    (wrap-evt evt (lambda (x) #f))
+		    never-evt))
+	       v)))
+       (lambda ()
+	 (when close?
+	   (close-input-port p)))
+       (and (port-provides-progress-evts? p)
+	    (lambda ()
+	      (port-progress-evt p)))
+       (and (port-provides-progress-evts? p)
+	    (lambda (n evt target-evt)
+	      (port-commit-peeked n evt target-evt p)))
+       location-proc
+       count-lines!-proc
+       pos)))
+
+  ;; Not kill-safe.
+  (define make-pipe-with-specials
+    ;; This implementation of pipes is almost CML-style, with a manager thread
+    ;; to guard access to the pipe content. But we only enable the manager
+    ;; thread when write evts are active; otherwise, we use a lock semaphore.
+    ;; (Actually, the lock semaphore has to be used all the time, to guard
+    ;; the flag indicating whether the manager thread is running.)
+    (opt-lambda ([limit (expt 2 64)] [in-name 'pipe] [out-name 'pipe])
+      (let-values ([(r w) (make-pipe limit)]
+		   [(more) null]
+		   [(more-last) #f]
+		   [(more-sema) #f]
+		   [(close-w?) #f]
+		   [(lock-semaphore) (make-semaphore 1)]
+		   [(mgr-th) #f]
+		   [(via-manager?) #f]
+		   [(mgr-ch) (make-channel)])
+	(define (flush-more)
+	  (if (null? more)
+	      (begin
+		(set! more-last #f)
+		(when close-w?
+		  (close-output-port w)))
+	      (when (bytes? (car more))
+		(let ([amt (bytes-length (car more))])
+		  (let ([wrote (write-bytes-avail* (car more) w)])
+		    (if (= wrote amt)
+			(begin
+			  (set! more (cdr more))
+			  (flush-more))
+			(begin
+			  ;; This means that we let too many bytes
+			  ;;  get written while a special was pending.
+			  ;;  Too bad...
+			  (set-car! more (subbytes (car more) wrote))
+			  ;; By peeking, make room for more:
+			  (peek-byte r (sub1 (min (pipe-content-length w)
+						  (- amt wrote))))
+			  (flush-more))))))))
+	(define (read-one s)
+	  (let ([v (read-bytes-avail!* s r)])
+	    (if (eq? v 0)
+		(if more-last
+		    ;; Return a special
+		    (let ([a (car more)])
+		      (set! more (cdr more))
+		      (flush-more)
+		      (lambda (file line col ppos)
+			a))
+		    ;; Nothing available, yet.
+		    (begin
+		      (unless more-sema
+			(set! more-sema (make-semaphore)))
+		      (wrap-evt (semaphore-peek-evt more-sema)
+				(lambda (x) 0))))
+		v)))
+	(define (close-it)
+	  (set! close-w? #t)
+	  (unless more-last
+	    (close-output-port w))
+	  (when more-sema
+	    (semaphore-post more-sema)))
+	(define (write-these-bytes str start end)
+	  (begin0
+	   (if more-last
+	       (let ([p (cons (subbytes str start end) null)])
+		 (set-cdr! more-last p)
+		 (set! more-last p)
+		 (- end start))
+	       (let ([v (write-bytes-avail* str w start end)])
+		 (if (zero? v)
+		     (wrap-evt w (lambda (x) #f))
+		     v)))
+	   (when more-sema
+	     (semaphore-post more-sema)
+	     (set! more-sema #f))))
+	(define (write-spec v)
+	  (let ([p (cons v null)])
+	    (if more-last
+		(set-cdr! more-last p)
+		(set! more p))
+	    (set! more-last p)
+	    (when more-sema
+	      (semaphore-post more-sema)
+	      (set! more-sema #f))))
+	(define (serve)
+	  ;; A request is
+	  ;;  (list sym result-ch nack-evt . v)
+	  ;; where `v' varies for different `sym's
+	  ;; The possible syms are: read, reply, close, 
+	  ;;  write, write-spec, write-evt, write-spec-evt
+	  (let loop ([reqs null])
+	    (apply
+	     sync
+	     ;; Listen for a request:
+	     (handle-evt mgr-ch
+			 (lambda (req)
+			   (let ([req
+				  ;; Most requests we handle immediately and
+				  ;; convert to a reply. The manager thread
+				  ;; implicitly has the lock.
+				  (let ([reply (lambda (v)
+						 (list 'reply (cadr req) (caddr req) v))])
+				    (case (car req)
+				      [(read)
+				       (printf "read~n")
+				       (reply (read-one (cadddr req)))]
+				      [(close)
+				       (reply (close-it))]
+				      [(write)
+				       (reply (apply write-these-bytes (cdddr req)))]
+				      [(write-spec)
+				       (reply (write-spec (cadddr req)))]
+				      [else req]))])
+			     (loop (cons req reqs)))))
+	     (if (and (null? reqs)
+		      via-manager?)
+		 ;; If we can get the lock before another request
+		 ;;  turn off manager mode:
+		 (handle-evt lock-semaphore
+			     (lambda (x)
+			       (set! via-manager? #f)
+			       (semaphore-post lock-semaphore)
+			       (loop null)))
+		 never-evt)
+	     (append
+	      (map (lambda (req)
+		     (case (car req)
+		       [(reply) (handle-evt (channel-put-evt (cadr req)
+							     (cadddr req))
+					    (lambda (x)
+					      (loop (remq req reqs))))]
+		       [(write-spec-evt) (if close-w?
+					     ;; Report close error:
+					     (handle-evt (channel-put-evt (cadr req) 'closed)
+						    (lambda (x)
+						      (loop (remq req reqs))))
+					     ;; Try to write special:
+					     (handle-evt (channel-put-evt (cadr req) #t)
+							 (lambda (x)
+							   ;; We sync'd, so now we *must* write
+							   (write-spec (cadddr req))
+							   (loop (remq req reqs)))))]
+		       [(write-evt) (if close-w?
+					;; Report close error:
+					(handle-evt (channel-put-evt (cadr req) 'closed)
+						    (lambda (x)
+						      (loop (remq req reqs))))
+					;; Try to write bytes:
+					(let* ([start (list-ref req 4)]
+					       [end (list-ref req 5)]
+					       [len (if more-last
+							(- end start)
+							(min (- end start)
+							     (max 0
+								  (- limit (pipe-content-length w)))))])
+					  (if (zero? len)
+					      (handle-evt w (lambda (x) (loop reqs)))
+					      (handle-evt (channel-put-evt (cadr req) len)
+							  (lambda (x)
+							    ;; We sync'd, so now we *must* write
+							    (write-these-bytes (cadddr req) start (+ start len))
+							    (loop (remq req reqs)))))))]))
+		   reqs)
+	      ;; nack => remove request (could be anything)
+	      (map (lambda (req)
+		     (handle-evt (caddr req)
+				 (lambda (x)
+				   (loop (remq req reqs)))))
+		   reqs)))))
+	(define (via-manager what req-sfx)
+	  (thread-resume mgr-th (current-thread))
+	  (let ([ch (make-channel)])
+	    (sync (nack-guard-evt
+		   (lambda (nack)
+		     (channel-put mgr-ch (list* what ch nack req-sfx))
+		     ch)))))
+	(define (start-mgr)
+	  (unless mgr-th
+	    (set! mgr-th (thread serve)))
+	  (set! via-manager? #t))
+	(define (evt what req-sfx)
+	  (nack-guard-evt
+	   (lambda (nack)
+	     (resume-mgr)
+	     (let ([ch (make-channel)])
+	       (call-with-semaphore
+		lock-semaphore
+		(lambda ()
+		  (unless via-manager?
+		    (set! mgr-th (thread serve)))
+		  (set! via-manager? #t)
+		  (thread-resume mgr-th (current-thread))
+		  (channel-put mgr-ch (list* what ch nack req-sfx))
+		  (wrap-evt ch (lambda (x)
+				 (if (eq? x 'close)
+				     (raise-mismatch-error 'write-evt "port is closed: " out)
+				     x)))))))))
+	(define (resume-mgr)
+	  (when mgr-th
+	    (thread-resume mgr-th (current-thread))))
+	(define in 
+	  ;; ----- Input ------
+	  (make-input-port/read-to-peek 
+	   in-name
+	   (lambda (s)
+	     (let ([v (read-bytes-avail!* s r)])
+	       (if (eq? v 0)
+		   (begin
+		     (resume-mgr)
+		     (call-with-semaphore
+		      lock-semaphore
+		      (lambda ()
+			(if via-manager?
+			    (via-manager 'read (list s))
+			    (read-one s)))))
+		   v)))
+	   #f
+	   void))
+	(define out
+	  ;; ----- Output ------
+	  (make-output-port
+	   out-name
+	   w
+	   ;; write
+	   (lambda (str start end buffer? w/break?)
+	     (if (= start end)
+		 #t
+		 (begin
+		   (resume-mgr)
+		   (call-with-semaphore
+		    lock-semaphore
+		    (lambda ()
+		      (if via-manager?
+			  (via-manager 'write (list str start end))
+			  (write-these-bytes str start end)))))))
+	   ;; close
+	   (lambda ()
+	     (resume-mgr)
+	     (call-with-semaphore
+	      lock-semaphore
+	      (lambda ()
+		(if via-manager?
+		    (via-manager 'close null)
+		    (close-it)))))
+	   ;; write-special
+	   (lambda (v buffer? w/break?)
+	     (resume-mgr)
+	     (call-with-semaphore
+	      lock-semaphore
+	      (lambda ()
+		(if via-manager?
+		    (via-manager 'write-spec (list v))
+		    (write-spec v)))))
+	   ;; write-evt
+	   (lambda (str start end)
+	     (if (= start end)
+		 (wrap-evt always-evt (lambda (x) 0))
+		 (evt 'write-evt (list str start end))))
+	   ;; write-special-evt
+	   (lambda (v)
+	     (evt 'write-spec-evt (list v)))))
+	(values in out))))
+		   
+
+  (define input-port-append
+    (opt-lambda (close-orig? . ports)
+      (make-input-port
+       (map object-name ports)
+       (lambda (str)
+	 ;; Reading is easy -- read from the first port,
+	 ;;  and get rid of it if the result is eof
+	 (if (null? ports)
+	     eof
+	     (let ([n (read-bytes-avail!* str (car ports))])
+	       (cond
+		[(eq? n 0) (wrap-evt (car ports) (lambda (x) 0))]
+		[(eof-object? n)
+		 (when close-orig?
+		   (close-input-port (car ports)))
+		 (set! ports (cdr ports))
+		 0]
+		[else n]))))
+       (lambda (str skip unless-evt)
+	 ;; Peeking is more difficult, due to skips.
+	 (let loop ([ports ports][skip skip])
+	   (if (null? ports)
+	       eof
+	       (let ([n (peek-bytes-avail!* str skip unless-evt (car ports))])
+		 (cond
+		  [(eq? n 0) 
+		   ;; Not ready, yet.
+		   (peek-bytes-avail!-evt str skip unless-evt (car ports))]
+		  [(eof-object? n)
+		   ;; Port is exhausted, or we skipped past its input.
+		   ;; If skip is not zero, we need to figure out
+		   ;;  how many chars were skipped.
+		   (loop (cdr ports)
+			 (- skip (compute-avail-to-skip skip (car ports))))]
+		  [else n])))))
+       (lambda ()
+	 (when close-orig?
+	   (map close-input-port ports))))))
+
+  (define (convert-stream from from-port
+			  to to-port)
+    (let ([c (bytes-open-converter from to)]
+	  [in (make-bytes 4096)]
+	  [out (make-bytes 4096)])
+      (unless c
+	(error 'convert-stream "could not create converter from ~e to ~e"
+	       from to))
+      (dynamic-wind
+	  void
+	  (lambda ()
+	    (let loop ([got 0])
+	      (let ([n (read-bytes-avail! in from-port got)])
+		(let ([got (+ got (if (number? n)
+				      n
+				      0))])
+		  (let-values ([(wrote used status) (bytes-convert c in 0 got out)])
+		    (when (eq? status 'error)
+		      (error 'convert-stream "conversion error"))
+		    (unless (zero? wrote)
+		      (write-bytes out to-port 0 wrote))
+		    (bytes-copy! in 0 in used got)
+		    (if (not (number? n))
+			(begin
+			  (unless (= got used)
+			    (error 'convert-stream "input stream ~a with a partial conversion"
+				   (if (eof-object? n) "ended" "hit a special value")))
+			  (let-values ([(wrote status) (bytes-convert-end c out)])
+			    (when (eq? status 'error)
+			      (error 'convert-stream "conversion-end error"))
+			    (unless (zero? wrote)
+			      (write-bytes out to-port 0 wrote))
+			    (if (eof-object? n)
+				;; Success
+				(void)
+				(begin
+				  (write-special n to-port)
+				  (loop 0)))))
+			(loop (- got used))))))))
+	  (lambda () (bytes-close-converter c)))))
+
+  ;; Helper for input-port-append; given a skip count
+  ;;  and an input port, determine how many characters
+  ;;  (up to upto) are left in the port. We figure this
+  ;;  out using binary search.
+  (define (compute-avail-to-skip upto p)
+    (let ([str (make-bytes 1)])
+      (let loop ([upto upto][skip 0])
+	(if (zero? upto)
+	    skip
+	    (let* ([half (quotient upto 2)]
+		   [n (peek-bytes-avail!* str (+ skip half) #f p)])
+	      (if (eq? n 1)
+		  (loop (- upto half 1) (+ skip half 1))
+		  (loop half skip)))))))
+
+  (define make-limited-input-port
+    (opt-lambda (port limit [close-orig? #t])
+      (let ([got 0])
+	(make-input-port
+	 (object-name port)
+	 (lambda (str)
+	   (let ([count (min (- limit got) (bytes-length str))])
+	     (if (zero? count)
+		 eof
+		 (let ([n (read-bytes-avail!* str port 0 count)])
+		   (cond
+		    [(eq? n 0) (wrap-evt port (lambda (x) 0))]
+		    [(number? n) (set! got (+ got n)) n]
+		    [(procedure? n) (set! got (add1 got)) n]
+		    [else n])))))
+	 (lambda (str skip progress-evt)
+	   (let ([count (max 0 (min (- limit got skip) (bytes-length str)))])
+	     (if (zero? count)
+		 eof
+		 (let ([n (peek-bytes-avail!* str skip progress-evt port 0 count)])
+		   (if (eq? n 0)
+		       (wrap-evt port (lambda (x) 0))
+		       n)))))
+	 (lambda ()
+	   (when close-orig?
+	     (close-input-port port)))))))
+	      
+  ;; ----------------------------------------
+
+  (define (poll-or-spawn go)
+    (poll-guard-evt
+     (lambda (poll?)
+       (if poll?
+	   ;; In poll mode, call `go' directly:
+	   (let ([v (go never-evt #f #t)])
+	     (if v
+		 (wrap-evt always-evt (lambda (x) v))
+		 never-evt))
+	   ;; In non-poll mode, start a thread to call go
+	   (nack-guard-evt
+	    (lambda (nack)
+	      (define ch (make-channel))
+	      (define ready (make-semaphore))
+	      (let ([t (thread (lambda () 
+				 (parameterize-break #t
+				   (with-handlers ([exn:break? void])
+				     (semaphore-post ready)
+				     (go nack ch #f)))))])
+		(thread (lambda ()
+			  (sync nack) 
+			  (semaphore-wait ready)
+			  (break-thread t))))
+	      ch))))))
+
+  (define (read-at-least-bytes!-evt orig-bstr input-port need-more? shrink combo 
+				    peek-offset prog-evt)
+    ;; go is the main reading function, either called directly for
+    ;; a poll, or called in a thread for a non-poll read
+    (define (go nack ch poll?)
+      (let try-again ([pos 0][bstr orig-bstr])
+	(let* ([progress-evt (or prog-evt 
+				 (port-progress-evt input-port))]
+	       [v ((if poll? 
+		       peek-bytes-avail!* 
+		       peek-bytes-avail!)
+		   bstr (+ pos (or peek-offset 0)) progress-evt input-port pos)])
+	  (cond
+	   ;; the first two cases below are shortcuts, and not
+	   ;;  strictly necessary
+	   [(sync/timeout 0 nack) (void)]
+	   [(sync/timeout 0 progress-evt) (if poll?
+					      #f
+					      (if prog-evt
+						  (void)
+						  (try-again pos bstr)))]
+	   [(and poll? (equal? v 0)) #f]
+	   [(and (number? v) (need-more? bstr (+ pos v)))
+	    => (lambda (bstr)
+		 (try-again (+ v pos) bstr))]
+	   [else
+	    (let* ([v2 (cond
+			[(number? v) (shrink bstr (+ v pos))]
+			[(positive? pos) pos]
+			[else v])]
+		   [result (combo bstr v2)])
+	      (cond
+	       [peek-offset
+		(if poll?
+		    result
+		    (sync (or prog-evt never-evt)
+			  (channel-put-evt ch result)))]
+	       [(port-commit-peeked (if (number? v2) v2 1)
+				    progress-evt
+				    (if poll?
+					always-evt
+					(channel-put-evt ch result))
+				    input-port)
+		result]
+	       [(and (eof-object? eof)
+		     (zero? pos)
+		     (not (sync/timeout 0 progress-evt)))
+		;; Must be a true end-of-file
+		(let ([result (combo bstr eof)])
+		  (if poll?
+		      result
+		      (channel-put ch result)))]
+	       [poll? #f]
+	       [else (try-again 0 orig-bstr)]))]))))
+    (if (zero? (bytes-length orig-bstr))
+	(wrap-evt always-evt (lambda (x) 0))
+	(poll-or-spawn go)))
+  
+  (define (-read-bytes-avail!-evt bstr input-port peek-offset prog-evt)
+    (read-at-least-bytes!-evt bstr input-port 
+			      (lambda (bstr v) (if (zero? v)
+						   bstr
+						   #f))
+			      (lambda (bstr v) v)
+			      (lambda (bstr v) v)
+			      peek-offset prog-evt))
+
+  (define (read-bytes-avail!-evt bstr input-port)
+    (-read-bytes-avail!-evt bstr input-port #f #f))
+
+  (define (peek-bytes-avail!-evt bstr peek-offset prog-evt input-port)
+    (-read-bytes-avail!-evt bstr input-port peek-offset prog-evt))
+
+  (define (-read-bytes!-evt bstr input-port peek-offset prog-evt)
+    (read-at-least-bytes!-evt bstr input-port 
+			      (lambda (bstr v)
+				(if (v . < . (bytes-length bstr))
+				    bstr
+				    #f))
+			      (lambda (bstr v) v)
+			      (lambda (bstr v) v)
+			      peek-offset prog-evt))
+
+  (define (read-bytes!-evt bstr input-port)
+    (-read-bytes!-evt bstr input-port #f #f))
+  
+  (define (peek-bytes!-evt bstr peek-offset prog-evt input-port)
+    (-read-bytes!-evt bstr input-port peek-offset prog-evt))
+  
+  (define (-read-bytes-evt len input-port peek-offset prog-evt)
+    (let ([bstr (make-bytes len)])
+      (wrap-evt
+       (-read-bytes!-evt bstr input-port peek-offset prog-evt)
+       (lambda (v)
+	 (if (number? v)
+	     (if (= v len)
+		 bstr
+		 (subbytes bstr 0 v))
+	     v)))))
+
+  (define (read-bytes-evt len input-port)
+    (-read-bytes-evt len input-port #f #f))
+	   
+  (define (peek-bytes-evt len peek-offset prog-evt input-port)
+    (-read-bytes-evt len input-port peek-offset prog-evt))
+  
+  (define (-read-string-evt goal input-port peek-offset prog-evt)
+    (if (zero? goal)
+	(wrap-evt always-evt (lambda (x) ""))
+	(let ([bstr (make-bytes goal)]
+	      [c (bytes-open-converter "UTF-8-permissive" "UTF-8")])
+	  (wrap-evt
+	   (read-at-least-bytes!-evt bstr input-port 
+				     (lambda (bstr v)
+				       (if (= v (bytes-length bstr))
+					   ;; We can't easily use bytes-utf-8-length here,
+					   ;; because we may need more bytes to figure out
+					   ;; the true role of the last byte. The
+					   ;; `bytes-convert' function lets us deal with
+					   ;; the last byte properly.
+					   (let-values ([(bstr2 used status) 
+							 (bytes-convert c bstr 0 v)])
+					     (let ([got (bytes-utf-8-length bstr2)])
+					       (if (= got goal)
+						   ;; Done:
+						   #f 
+						   ;; Need more bytes:
+						   (let ([bstr2 (make-bytes (+ v (- goal got)))])
+						     (bytes-copy! bstr2 0 bstr)
+						     bstr2))))
+					   ;; Need more bytes in bstr:
+					   bstr))
+				     (lambda (bstr v)
+				       ;; We may need one less than v,
+				       ;; because we may have had to peek
+				       ;; an extra byte to discover an
+				       ;; error in the stream.
+				       (if ((bytes-utf-8-length bstr #\? 0 v) . > . goal)
+					   (sub1 v)
+					   v))
+				     cons
+				     peek-offset prog-evt)
+	   (lambda (bstr+v)
+	     (let ([bstr (car bstr+v)]
+		   [v (cdr bstr+v)])
+	       (if (number? v)
+		   (bytes->string/utf-8 bstr #\? 0 v)
+		   v)))))))
+
+  (define (read-string-evt goal input-port)
+    (-read-string-evt goal input-port #f #f))
+    
+  (define (peek-string-evt goal peek-offset prog-evt input-port)
+    (-read-string-evt goal input-port peek-offset prog-evt))
+
+  (define (-read-string!-evt str input-port peek-offset prog-evt)
+    (wrap-evt
+     (-read-string-evt (string-length str) input-port peek-offset prog-evt)
+     (lambda (s)
+       (if (string? s)
+	   (begin
+	     (string-copy! str 0 s)
+	     (string-length s))
+	   s))))
+
+  (define (read-string!-evt str input-port)
+    (-read-string!-evt str input-port #f #f))
+
+  (define (peek-string!-evt str peek-offset prog-evt input-port)
+    (-read-string!-evt str input-port peek-offset prog-evt))
+
+  (define (regexp-match-evt pattern input-port)
+    (define (go nack ch poll?)
+      (let try-again ()
+	(let* ([progress-evt (port-progress-evt input-port)]
+	       [m ((if poll?
+		       regexp-match-peek-positions-immediate 
+		       regexp-match-peek-positions)
+		   pattern input-port 0 #f progress-evt)])
+	  (cond
+	   [(sync/timeout 0 nack) (void)]
+	   [(sync/timeout 0 progress-evt) (try-again)]
+	   [(not m)
+	    (if poll?
+		#f
+		(sync nack
+		      (handle-evt progress-evt
+				  (lambda (x) (try-again)))))]
+	   [else
+	    (let ([m2 (map (lambda (p)
+			     (and p
+				  (let ([bstr (make-bytes (- (cdr p) (car p)))])
+				    (unless (= (car p) (cdr p))
+				      (let loop ([offset 0])
+					(let ([v (peek-bytes-avail! bstr (car p) progress-evt input-port offset)])
+					  (unless (zero? v)
+					    (when ((+ offset v) . < . (bytes-length bstr))
+					      (loop (+ offset v)))))))
+				    bstr)))
+			   m)])
+	      (cond
+	       [(and (zero? (cdar m))
+		     (or poll?
+			 (channel-put ch m2)))
+		m2]
+	       [(port-commit-peeked (cdar m) 
+				    progress-evt 
+				    (if poll?
+					always-evt
+					(channel-put-evt ch m2))
+				    input-port)
+		m2]
+	       [poll? #f]
+	       [else (try-again)]))]))))
+    (poll-or-spawn go))
+
+  (define-syntax (newline-rx stx)
+    (syntax-case stx ()
+      [(_ str) (datum->syntax-object #'here
+				     (byte-regexp 
+				      (string->bytes/latin-1
+				       (format "^(?:(.*?)~a)|(.*?$)"
+					       (syntax-e #'str)))))]))
+
+  (define read-bytes-line-evt
+    (opt-lambda (input-port [mode 'linefeed])
+      (wrap-evt
+       (regexp-match-evt (case mode
+			   [(linefeed) (newline-rx "\n")]
+			   [(return) (newline-rx "\r")]
+			   [(return-linefeed) (newline-rx "\r\n")]
+			   [(any) (newline-rx "(?:\r\n|\r|\n)")]
+			   [(any-one) (newline-rx "[\r\n]")])
+			 input-port)
+       (lambda (m)
+	 (or (cadr m)
+	     (let ([l (caddr m)])
+	       (if (and l (zero? (bytes-length l)))
+		   eof
+		   l)))))))
+  
+  (define read-line-evt
+    (opt-lambda (input-port [mode 'linefeed])
+      (wrap-evt
+       (read-bytes-line-evt input-port mode)
+       (lambda (s)
+	 (if (eof-object? s)
+	     s
+	     (bytes->string/utf-8 s #\?))))))
+
+  (define (eof-evt input-port)
+    (wrap-evt
+     (regexp-match-evt #rx#"^$" input-port)
+     (lambda (x)
+       eof)))
+
+  ;; --------------------------------------------------
+  
+  (define reencode-input-port
+    (opt-lambda (port encoding [error-bytes #f] [close? #f] [name (object-name port)])
+      (let ([c (bytes-open-converter encoding "UTF-8")]
+	    [ready-bytes (make-bytes 1024)]
+	    [ready-start 0]
+	    [ready-end 0]
+	    [buf (make-bytes 1024)]
+	    [buf-start 0]
+	    [buf-end 0]
+	    [buf-eof? #f]
+	    [buf-eof-result #f]
+	    [buffer-mode (or (file-stream-buffer-mode port)
+			     'none)])
+	;; Main reader entry:
+	(define (read-it s)
+	  (cond
+	   [(> ready-end ready-start)
+	    ;; We have leftover converted bytes:
+	    (let ([cnt (min (bytes-length s)
+			    (- ready-end ready-start))])
+	      (bytes-copy! s 0 ready-bytes ready-start (+ ready-start cnt))
+	      (set! ready-start (+ ready-start cnt))
+	      cnt)]
+	   [else
+	    ;; Try converting already-read bytes:
+	    (let-values ([(got-c used-c status) (if (= buf-start buf-end)
+						    (values 0 0 'aborts)
+						    (bytes-convert c buf buf-start buf-end s))])
+	      (cond
+	       [(positive? got-c)
+		;; We converted some bytes into s.
+		(set! buf-start (+ used-c buf-start))
+		got-c]
+	       [(eq? status 'aborts)
+		(if buf-eof?
+		    ;; Had an EOF or special in the stream.
+		    (if (= buf-start buf-end)
+			(begin0
+			 buf-eof-result
+			 (set! buf-eof? #f)
+			 (set! buf-eof-result #f))
+			(handle-error s))
+		    ;; Need more bytes.
+		    (begin
+		      (when (positive? buf-start)
+			(bytes-copy! buf 0 buf buf-start buf-end)
+			(set! buf-end (- buf-end buf-start))
+			(set! buf-start 0))
+		      (let* ([amt (bytes-length s)]
+			     [c (read-bytes-avail!* buf port buf-end
+						    (if (eq? buffer-mode 'block)
+							(bytes-length buf)
+							(min (bytes-length buf) 
+							     (+ buf-end amt))))])
+			(cond
+			 [(or (eof-object? c) 
+			      (procedure? c))
+			  ;; Got EOF/procedure
+			  (set! buf-eof? #t)
+			  (set! buf-eof-result c)
+			  (read-it s)]
+			 [(zero? c)
+			  ;; No bytes ready --- try again later.
+			  (wrap-evt port (lambda (v) 0))]
+			 [else
+			  ;; Got some bytes; loop to decode.
+			  (set! buf-end (+ buf-end c))
+			  (read-it s)]))))]
+	       [(eq? status 'error)
+		(handle-error s)]
+	       [(eq? status 'continues)
+		;; Need more room to make progress at all.
+		;; Decode into ready-bytes.
+		(let-values ([(got-c used-c status) (bytes-convert c buf buf-start buf-end ready-bytes)])
+		  (unless (memq status '(continues complete))
+		    (error 'reencode-input-port-read
+			   "unable to make decoding progress: ~e"
+			   port))
+		  (set! ready-start 0)
+		  (set! ready-end got-c)
+		  (set! buf-start (+ used-c buf-start))
+		  (read-it s))]))]))
+
+	;; Raise exception or discard first buffered byte.
+	;;  We assume that read-bytes is empty
+	(define (handle-error s)
+	  (if error-bytes
+	      (begin
+		(set! buf-start (add1 buf-start))
+		(let ([cnt (min (bytes-length s)
+				(bytes-length error-bytes))])
+		  (bytes-copy! s 0 error-bytes 0 cnt)
+		  (bytes-copy! ready-bytes 0 error-bytes cnt)
+		  (set! ready-start 0)
+		  (set! ready-end (- (bytes-length error-bytes) cnt))
+		  cnt))
+	      (error
+	       'converting-input-port
+	       "decoding error in input stream: ~e"
+	       port)))
+
+	(unless c
+	  (error 'reencode-input-port 
+		 "could not create converter from ~e to UTF-8"
+		 encoding))
+	
+	(make-input-port/read-to-peek
+	 name 
+	 read-it
+	 #f
+	 (lambda ()
+	   (when close?
+	     (close-input-port port))
+	   (bytes-close-converter c))
+	 #f void 1
+	 (case-lambda 
+	  [() buffer-mode]
+	  [(mode) (set! buffer-mode mode)])))))
+  
+  ;; --------------------------------------------------
+  
+  (define reencode-output-port
+    (opt-lambda (port encoding [error-bytes #f] [close? #f] [name (object-name port)])
+      (let ([c (bytes-open-converter "UTF-8" encoding)]
+	    [ready-bytes (make-bytes 1024)]
+	    [ready-start 0]
+	    [ready-end 0]
+	    [out-bytes (make-bytes 1024)]
+	    [out-start 0]
+	    [out-end 0]
+	    [buffer-mode (or (file-stream-buffer-mode port)
+			     'block)])
+	
+	;; The main writing entry point:
+	(define (write-it s start end no-buffer&block? enable-break?)
+	  (cond
+	   [(= start end)
+	    ;; This is a flush request; no-buffer&block? must be #f
+	    ;; Note: we could get stuck because only half an encoding
+	    ;;  is available in out-bytes.
+	    (flush-some #f enable-break?)
+	    (if (buffer-flushed?)
+		0
+		(write-it s start end no-buffer&block? enable-break?))]
+	   [no-buffer&block?
+	    (case (flush-all #t enable-break?)
+	      [(not-done)
+	       ;; We couldn't flush right away, so give up.
+	       #f]
+	      [(done)
+	       (non-blocking-write s start end)]
+	      [(stuck)
+	       ;; We need more bytes to make progress.
+	       ;;  Add out-bytes and s into one string for non-blocking-write.
+	       (let ([s2 (bytes-append (subbytes out-bytes out-start out-end)
+				       (subbytes s start end))]
+		     [out-len (- out-end out-start)])
+		 (let ([c (non-blocking-write s2 0 (bytes-length s2))])
+		   (and c
+			(begin
+			  (set! out-start 0)
+			  (set! out-end 0)
+			  (- c out-len)))))])]
+	   [else
+	    (when (or (> ready-end ready-start)
+		      (< (- (bytes-length out-bytes) out-end) 100))
+	      ;; Make room for conversion.
+	      (flush-some #f enable-break?))
+	    ;; Make room in buffer
+	    (when (positive? out-start)
+	      (bytes-copy! out-bytes 0 out-bytes out-start out-end)
+	      (set! out-end (- out-end out-start))
+	      (set! out-start 0))
+	    ;; Buffer some bytes:
+	    (let ([cnt (min (- end start)
+			    (- (bytes-length out-bytes) out-end))])
+	      (if (zero? cnt)
+		  ;; No room --- try flushing again:
+		  (write-it s start end #f enable-break?)
+		  ;; Buffer and report success:
+		  (begin
+		    (bytes-copy! out-bytes out-end s start (+ start cnt))
+		    (set! out-end (+ cnt out-end))
+		    (case buffer-mode
+		      [(none) (flush-all-now enable-break?)]
+		      [(line) (when (regexp-match-positions #rx#"[\r\n]" s start (+ start cnt))
+				(flush-all-now enable-break?))])
+		    cnt)))]))
+	   
+	(define (non-blocking-write s start end)
+	  ;; For now, everything that we can flushed is flushed.
+	  ;;  Try to write the minimal number of bytes, and hope for the
+	  ;;  best. If none of all of the minimal bytes get written,
+	  ;;  everyone is happy enough. If some of the bytes get written,
+	  ;;  the we will have buffered bytes when we shouldn't have.
+	  ;;  That probably won't happen, but we can't guarantee it.
+	  (let loop ([len 1])
+	    (let-values ([(got-c used-c status) (bytes-convert c s start (+ start len) ready-bytes)])
+	      (cond
+	       [(positive? got-c)
+		(try-flush-ready got-c used-c)]
+	       [(eq? status 'aborts)
+		(if (< len (- end start))
+		    ;; Try converting a bigger chunk
+		    (loop (add1 len))
+		    ;; We can't flush half an encoding, so just buffer it.
+		    (let ([cnt (- start end)])
+		      (when (> (- end start) (bytes-length out-bytes))
+			(raise-insane-decoding-length))
+		      (bytes-copy out-bytes 0 s start end)
+		      (set! out-start 0)
+		      (set! out-end cnt)
+		      cnt))]
+	       [(eq? status 'continues)
+		;; Not enough room in ready-bytes!? We give up.
+		(raise-insane-decoding-length)]
+	       [else
+		;; Encoding error. Try to flush error bytes.
+		(let ([cnt (bytes-length error-bytes)])
+		  (bytes-copy! ready-bytes 0 error-bytes)
+		  (try-flush-ready cnt 1))]))))
+
+	(define (write-special-it v no-buffer&block? enable-break?)
+	  (cond
+	   [(buffer-flushed?)
+	    ((if no-buffer&block?
+		 write-special-avail*
+		 (if enable-break?
+		     (lambda (v p)
+		       (parameterize-break #t (write-special v p)))
+		     write-special))
+	     v port)]
+	   [else
+	    ;; Note: we could get stuck because only half an encoding
+	    ;;  is available in out-bytes.
+	    (flush-some no-buffer&block? enable-break?)
+	    (if (or (buffer-flushed?)
+		    (not no-buffer&block?))
+		(write-special-it v no-buffer&block? enable-break?)
+		#f)]))
+	
+	;; flush-all : -> 'done, 'not-done, or 'stuck
+	(define (flush-all non-block? enable-break?)
+	  (let ([orig-none-ready? (= ready-start ready-end)]
+		[orig-out-start out-start]
+		[orig-out-end out-end])
+	    (flush-some non-block? enable-break?)
+	    (if (buffer-flushed?)
+		'done
+		;; Couldn't flush everything. One possibility is that we need
+		;;  more bytes to convert before a flush.
+		(if (and orig-none-ready?
+			 (= ready-start ready-end)
+			 (= orig-out-start out-start)
+			 (= orig-out-end out-end))
+		    'stuck
+		    'not-done))))
+
+	(define (flush-all-now enable-break?)
+	  (case (flush-all #f enable-break?)
+	    [(not-done) (flush-all-now enable-break?)]))
+	
+	(define (buffer-flushed?)
+	  (and (= ready-start ready-end)
+	       (= out-start out-end)))
+	
+	;; Try to flush immediately a certain number of bytes
+	(define (try-flush-ready got-c used-c)
+	  (let ([c (write-bytes-avail* ready-bytes port 0 got-c)])
+	    (if (zero? c)
+		;; Didn't flush any - give up:
+		#f
+		;; Hopefully, we flushed them all, but set ready-start and ready-end,
+		;;  just in case.
+		(begin	    
+		  (set! ready-start c)
+		  (set! ready-end got-c)
+		  used-c))))
+
+	;; Try to make progress flushing buffered bytes
+	(define (flush-some non-block? enable-break?)
+	  (unless (= ready-start ready-end)
+	    ;; Flush converted bytes:
+	    (let ([cnt ((cond
+			 [non-block? write-bytes-avail*]
+			 [enable-break? write-bytes-avail/enable-break]
+			 [else write-bytes-avail])
+			ready-bytes port ready-start ready-end)])
+	      (set! ready-start (+ ready-start cnt))))
+	  (when (= ready-start ready-end)
+	    ;; Convert more, if available:
+	    (set! ready-start 0)
+	    (set! ready-end 0)
+	    (when (> out-end out-start)
+	      (let-values ([(got-c used-c status) (bytes-convert c out-bytes out-start out-end ready-bytes)])
+		(set! ready-end got-c)
+		(set! out-start (+ out-start used-c))
+		(when (and (eq? status 'continues)
+			   (zero? used-c))
+		  ;; Yikes! Size of ready-bytes isn't enough room for progress!?
+		  (raise-insane-decoding-length))
+		(when (and (eq? status 'error)
+			   (zero? used-c))
+		  ;; No progress before an encoding error.
+		  (if error-bytes
+		      ;; Write error bytes and drop an output byte:
+		      (begin
+			(set! out-start (add1 out-start))
+			(bytes-copy! ready-bytes 0 error-bytes)
+			(set! ready-end (bytes-length error-bytes)))
+		      ;; Raise an exception:
+		      (begin
+			(set! out-start (add1 out-start))
+			(error
+			 'reencode-output-port
+			 "error decoding output to stream: ~e"
+			 port))))))))
+
+	;; This error is used when decoding wants more bytes to make progress even
+	;;  though we've supplied hundreds of bytes
+	(define (raise-insane-decoding-length)
+	  (error 'reencode-output-port-write
+		 "unable to make decoding progress: ~e"
+		 port))
+
+	;; Check that a decoder is available:
+	(unless c
+	  (error 'reencode-output-port 
+		 "could not create converter from ~e to UTF-8"
+		 encoding))
+
+	(make-output-port
+	 name
+	 port
+	 write-it
+	 (lambda ()
+	   ;; Flush output
+	   (write-it #"" 0 0 #f #f)
+	   (when close?
+	     (close-output-port port))
+	   (bytes-close-converter c))
+	 write-special-it
+	 #f #f
+	 #f void
+	 1
+	 (case-lambda
+	  [() buffer-mode]
+	  [(mode) (let ([old buffer-mode])
+		    (set! buffer-mode mode)
+		    (when (or (and (eq? old 'block)
+				   (memq mode '(none line)))
+			      (and (eq? old 'line)
+				   (memq mode '(none))))
+		      ;; Flush output
+		      (write-it #"" 0 0 #f #f)))]))))))
diff --git a/collects/mzlib/pregexp.ss b/collects/mzlib/pregexp.ss
new file mode 100644
index 0000000000..a2ddb07b79
--- /dev/null
+++ b/collects/mzlib/pregexp.ss
@@ -0,0 +1,697 @@
+;pregexp.ss
+;Portable regular expressions for Scheme
+;Dorai Sitaram
+;http://www.ccs.neu.edu/~dorai/pregexp/pregexp.html
+
+(module pregexp mzscheme
+        (provide pregexp
+                 pregexp-match-positions
+                 pregexp-match
+                 pregexp-split
+                 pregexp-replace
+                 pregexp-replace*
+                 pregexp-quote
+                 *pregexp-comment-char*)
+
+;Configured for Scheme dialect plt by scmxlate, v 2004-09-08,
+;(c) Dorai Sitaram, 
+;http://www.ccs.neu.edu/~dorai/scmxlate/scmxlate.html
+
+(define *pregexp-version* 20050502)
+
+(define *pregexp-comment-char* #\;)
+
+(define *pregexp-space-sensitive?* #t)
+
+(define pregexp-error
+  (lambda whatever
+    (display "Error:")
+    (for-each (lambda (x) (display #\space) (write x)) whatever)
+    (newline)
+    (error "pregexp-error")))
+
+(define pregexp-read-pattern
+  (lambda (s i n)
+    (if (>= i n)
+      (list (list ':or (list ':seq)) i)
+      (let loop ((branches '()) (i i))
+        (if (or (>= i n) (char=? (string-ref s i) #\)))
+          (list (cons ':or (reverse! branches)) i)
+          (let ((vv
+                 (pregexp-read-branch
+                   s
+                   (if (char=? (string-ref s i) #\|) (+ i 1) i)
+                   n)))
+            (loop (cons (car vv) branches) (cadr vv))))))))
+
+(define pregexp-read-branch
+  (lambda (s i n)
+    (let loop ((pieces '()) (i i))
+      (cond
+       ((>= i n) (list (cons ':seq (reverse! pieces)) i))
+       ((let ((c (string-ref s i))) (or (char=? c #\|) (char=? c #\))))
+        (list (cons ':seq (reverse! pieces)) i))
+       (else
+        (let ((vv (pregexp-read-piece s i n)))
+          (loop (cons (car vv) pieces) (cadr vv))))))))
+
+(define pregexp-read-piece
+  (lambda (s i n)
+    (let ((c (string-ref s i)))
+      (case c
+        ((#\^) (list ':bos (+ i 1)))
+        ((#\$) (list ':eos (+ i 1)))
+        ((#\.) (pregexp-wrap-quantifier-if-any (list ':any (+ i 1)) s n))
+        ((#\[)
+         (let ((i+1 (+ i 1)))
+           (pregexp-wrap-quantifier-if-any
+             (case (and (< i+1 n) (string-ref s i+1))
+               ((#\^)
+                (let ((vv (pregexp-read-char-list s (+ i 2) n)))
+                  (list (list ':neg-char (car vv)) (cadr vv))))
+               (else (pregexp-read-char-list s i+1 n)))
+             s
+             n)))
+        ((#\()
+         (pregexp-wrap-quantifier-if-any
+           (pregexp-read-subpattern s (+ i 1) n)
+           s
+           n))
+        ((#\\)
+         (pregexp-wrap-quantifier-if-any
+           (cond
+            ((pregexp-read-escaped-number s i n)
+             =>
+             (lambda (num-i) (list (list ':backref (car num-i)) (cadr num-i))))
+            ((pregexp-read-escaped-char s i n)
+             =>
+             (lambda (char-i) (list (car char-i) (cadr char-i))))
+            (else (pregexp-error 'pregexp-read-piece 'backslash)))
+           s
+           n))
+        (else
+         (if (or *pregexp-space-sensitive?*
+                 (and (not (char-whitespace? c))
+                      (not (char=? c *pregexp-comment-char*))))
+           (pregexp-wrap-quantifier-if-any (list c (+ i 1)) s n)
+           (let loop ((i i) (in-comment? #f))
+             (if (>= i n)
+               (list ':empty i)
+               (let ((c (string-ref s i)))
+                 (cond
+                  (in-comment? (loop (+ i 1) (not (char=? c #\newline))))
+                  ((char-whitespace? c) (loop (+ i 1) #f))
+                  ((char=? c *pregexp-comment-char*) (loop (+ i 1) #t))
+                  (else (list ':empty i))))))))))))
+
+(define pregexp-read-escaped-number
+  (lambda (s i n)
+    (and (< (+ i 1) n)
+         (let ((c (string-ref s (+ i 1))))
+           (and (char-numeric? c)
+                (let loop ((i (+ i 2)) (r (list c)))
+                  (if (>= i n)
+                    (list (string->number (list->string (reverse! r))) i)
+                    (let ((c (string-ref s i)))
+                      (if (char-numeric? c)
+                        (loop (+ i 1) (cons c r))
+                        (list
+                         (string->number (list->string (reverse! r)))
+                         i))))))))))
+
+(define pregexp-read-escaped-char
+  (lambda (s i n)
+    (and (< (+ i 1) n)
+         (let ((c (string-ref s (+ i 1))))
+           (case c
+             ((#\b) (list ':wbdry (+ i 2)))
+             ((#\B) (list ':not-wbdry (+ i 2)))
+             ((#\d) (list ':digit (+ i 2)))
+             ((#\D) (list '(:neg-char :digit) (+ i 2)))
+             ((#\n) (list #\newline (+ i 2)))
+             ((#\r) (list #\return (+ i 2)))
+             ((#\s) (list ':space (+ i 2)))
+             ((#\S) (list '(:neg-char :space) (+ i 2)))
+             ((#\t) (list #\tab (+ i 2)))
+             ((#\w) (list ':word (+ i 2)))
+             ((#\W) (list '(:neg-char :word) (+ i 2)))
+             (else (list c (+ i 2))))))))
+
+(define pregexp-read-posix-char-class
+  (lambda (s i n)
+    (let ((neg? #f))
+      (let loop ((i i) (r (list #\:)))
+        (if (>= i n)
+          (pregexp-error 'pregexp-read-posix-char-class)
+          (let ((c (string-ref s i)))
+            (cond
+             ((char=? c #\^) (set! neg? #t) (loop (+ i 1) r))
+             ((char-alphabetic? c) (loop (+ i 1) (cons c r)))
+             ((char=? c #\:)
+              (if (or (>= (+ i 1) n) (not (char=? (string-ref s (+ i 1)) #\])))
+                (pregexp-error 'pregexp-read-posix-char-class)
+                (let ((posix-class
+                        (string->symbol (list->string (reverse! r)))))
+                  (list
+                   (if neg? (list ':neg-char posix-class) posix-class)
+                   (+ i 2)))))
+             (else (pregexp-error 'pregexp-read-posix-char-class)))))))))
+
+(define pregexp-read-cluster-type
+  (lambda (s i n)
+    (let ((c (string-ref s i)))
+      (case c
+        ((#\?)
+         (let ((i (+ i 1)))
+           (case (string-ref s i)
+             ((#\:) (list '() (+ i 1)))
+             ((#\=) (list '(:lookahead) (+ i 1)))
+             ((#\!) (list '(:neg-lookahead) (+ i 1)))
+             ((#\>) (list '(:no-backtrack) (+ i 1)))
+             ((#\<)
+              (list
+               (case (string-ref s (+ i 1))
+                 ((#\=) '(:lookbehind))
+                 ((#\!) '(:neg-lookbehind))
+                 (else (pregexp-error 'pregexp-read-cluster-type)))
+               (+ i 2)))
+             (else
+              (let loop ((i i) (r '()) (inv? #f))
+                (let ((c (string-ref s i)))
+                  (case c
+                    ((#\-) (loop (+ i 1) r #t))
+                    ((#\i)
+                     (loop
+                      (+ i 1)
+                      (cons (if inv? ':case-sensitive ':case-insensitive) r)
+                      #f))
+                    ((#\x)
+                     (set! *pregexp-space-sensitive?* inv?)
+                     (loop (+ i 1) r #f))
+                    ((#\:) (list r (+ i 1)))
+                    (else (pregexp-error 'pregexp-read-cluster-type)))))))))
+        (else (list '(:sub) i))))))
+
+(define pregexp-read-subpattern
+  (lambda (s i n)
+    (let* ((remember-space-sensitive? *pregexp-space-sensitive?*)
+           (ctyp-i (pregexp-read-cluster-type s i n))
+           (ctyp (car ctyp-i))
+           (i (cadr ctyp-i))
+           (vv (pregexp-read-pattern s i n)))
+      (set! *pregexp-space-sensitive?* remember-space-sensitive?)
+      (let ((vv-re (car vv)) (vv-i (cadr vv)))
+        (if (and (< vv-i n) (char=? (string-ref s vv-i) #\)))
+          (list
+           (let loop ((ctyp ctyp) (re vv-re))
+             (if (null? ctyp) re (loop (cdr ctyp) (list (car ctyp) re))))
+           (+ vv-i 1))
+          (pregexp-error 'pregexp-read-subpattern))))))
+
+(define pregexp-wrap-quantifier-if-any
+  (lambda (vv s n)
+    (let ((re (car vv)))
+      (let loop ((i (cadr vv)))
+        (if (>= i n)
+          vv
+          (let ((c (string-ref s i)))
+            (if (and (char-whitespace? c) (not *pregexp-space-sensitive?*))
+              (loop (+ i 1))
+              (case c
+                ((#\* #\+ #\? #\{)
+                 (let* ((new-re
+                          (list ':between 'minimal? 'at-least 'at-most re))
+                        (new-vv (list new-re 'next-i)))
+                   (case c
+                     ((#\*)
+                      (set-car! (cddr new-re) 0)
+                      (set-car! (cdddr new-re) #f))
+                     ((#\+)
+                      (set-car! (cddr new-re) 1)
+                      (set-car! (cdddr new-re) #f))
+                     ((#\?)
+                      (set-car! (cddr new-re) 0)
+                      (set-car! (cdddr new-re) 1))
+                     ((#\{)
+                      (let ((pq (pregexp-read-nums s (+ i 1) n)))
+                        (if (not pq)
+                          (pregexp-error
+                            'pregexp-wrap-quantifier-if-any
+                            'left-brace-must-be-followed-by-number))
+                        (set-car! (cddr new-re) (car pq))
+                        (set-car! (cdddr new-re) (cadr pq))
+                        (set! i (caddr pq)))))
+                   (let loop ((i (+ i 1)))
+                     (if (>= i n)
+                       (begin
+                         (set-car! (cdr new-re) #f)
+                         (set-car! (cdr new-vv) i))
+                       (let ((c (string-ref s i)))
+                         (cond
+                          ((and (char-whitespace? c)
+                                (not *pregexp-space-sensitive?*))
+                           (loop (+ i 1)))
+                          ((char=? c #\?)
+                           (set-car! (cdr new-re) #t)
+                           (set-car! (cdr new-vv) (+ i 1)))
+                          (else
+                           (set-car! (cdr new-re) #f)
+                           (set-car! (cdr new-vv) i))))))
+                   new-vv))
+                (else vv)))))))))
+
+(define pregexp-read-nums
+  (lambda (s i n)
+    (let loop ((p '()) (q '()) (k i) (reading 1))
+      (if (>= k n) (pregexp-error 'pregexp-read-nums))
+      (let ((c (string-ref s k)))
+        (cond
+         ((char-numeric? c)
+          (if (= reading 1)
+            (loop (cons c p) q (+ k 1) 1)
+            (loop p (cons c q) (+ k 1) 2)))
+         ((and (char-whitespace? c) (not *pregexp-space-sensitive?*))
+          (loop p q (+ k 1) reading))
+         ((and (char=? c #\,) (= reading 1)) (loop p q (+ k 1) 2))
+         ((char=? c #\})
+          (let ((p (string->number (list->string (reverse! p))))
+                (q (string->number (list->string (reverse! q)))))
+            (cond
+             ((and (not p) (= reading 1)) (list 0 #f k))
+             ((= reading 1) (list p p k))
+             (else (list p q k)))))
+         (else #f))))))
+
+(define pregexp-invert-char-list
+  (lambda (vv) (set-car! (car vv) ':none-of-chars) vv))
+
+(define pregexp-read-char-list
+  (lambda (s i n)
+    (let loop ((r '()) (i i))
+      (if (>= i n)
+        (pregexp-error 'pregexp-read-char-list 'character-class-ended-too-soon)
+        (let ((c (string-ref s i)))
+          (case c
+            ((#\])
+             (if (null? r)
+               (loop (cons c r) (+ i 1))
+               (list (cons ':one-of-chars (reverse! r)) (+ i 1))))
+            ((#\\)
+             (let ((char-i (pregexp-read-escaped-char s i n)))
+               (if char-i
+                 (loop (cons (car char-i) r) (cadr char-i))
+                 (pregexp-error 'pregexp-read-char-list 'backslash))))
+            ((#\-)
+             (if (or (null? r)
+                     (let ((i+1 (+ i 1)))
+                       (and (< i+1 n) (char=? (string-ref s i+1) #\]))))
+               (loop (cons c r) (+ i 1))
+               (let ((c-prev (car r)))
+                 (if (char? c-prev)
+                   (loop
+                    (cons
+                     (list ':char-range c-prev (string-ref s (+ i 1)))
+                     (cdr r))
+                    (+ i 2))
+                   (loop (cons c r) (+ i 1))))))
+            ((#\[)
+             (if (char=? (string-ref s (+ i 1)) #\:)
+               (let ((posix-char-class-i
+                       (pregexp-read-posix-char-class s (+ i 2) n)))
+                 (loop
+                  (cons (car posix-char-class-i) r)
+                  (cadr posix-char-class-i)))
+               (loop (cons c r) (+ i 1))))
+            (else (loop (cons c r) (+ i 1)))))))))
+
+(define pregexp-string-match
+  (lambda (s1 s i n sk fk)
+    (let ((n1 (string-length s1)))
+      (if (> n1 n)
+        (fk)
+        (let loop ((j 0) (k i))
+          (cond
+           ((>= j n1) (sk k))
+           ((>= k n) (fk))
+           ((char=? (string-ref s1 j) (string-ref s k)) (loop (+ j 1) (+ k 1)))
+           (else (fk))))))))
+
+(define pregexp-char-word?
+  (lambda (c) (or (char-alphabetic? c) (char-numeric? c) (char=? c #\_))))
+
+(define pregexp-at-word-boundary?
+  (lambda (s i n)
+    (or (= i 0)
+        (>= i n)
+        (let ((c/i (string-ref s i)) (c/i-1 (string-ref s (- i 1))))
+          (let ((c/i/w? (pregexp-check-if-in-char-class? c/i ':word))
+                (c/i-1/w? (pregexp-check-if-in-char-class? c/i-1 ':word)))
+            (or (and c/i/w? (not c/i-1/w?)) (and (not c/i/w?) c/i-1/w?)))))))
+
+(define pregexp-check-if-in-char-class?
+  (lambda (c char-class)
+    (case char-class
+      ((:any) (not (char=? c #\newline)))
+      ((:alnum) (or (char-alphabetic? c) (char-numeric? c)))
+      ((:alpha) (char-alphabetic? c))
+      ((:ascii) (< (char->integer c) 128))
+      ((:blank) (or (char=? c #\space) (char=? c #\tab)))
+      ((:cntrl) (< (char->integer c) 32))
+      ((:digit) (char-numeric? c))
+      ((:graph) (and (>= (char->integer c) 32) (not (char-whitespace? c))))
+      ((:lower) (char-lower-case? c))
+      ((:print) (>= (char->integer c) 32))
+      ((:punct)
+       (and (>= (char->integer c) 32)
+            (not (char-whitespace? c))
+            (not (char-alphabetic? c))
+            (not (char-numeric? c))))
+      ((:space) (char-whitespace? c))
+      ((:upper) (char-upper-case? c))
+      ((:word) (or (char-alphabetic? c) (char-numeric? c) (char=? c #\_)))
+      ((:xdigit)
+       (or (char-numeric? c)
+           (char-ci=? c #\a)
+           (char-ci=? c #\b)
+           (char-ci=? c #\c)
+           (char-ci=? c #\d)
+           (char-ci=? c #\e)
+           (char-ci=? c #\f)))
+      (else (pregexp-error 'pregexp-check-if-in-char-class?)))))
+
+(define pregexp-list-ref
+  (lambda (s i)
+    (let loop ((s s) (k 0))
+      (cond ((null? s) #f) ((= k i) (car s)) (else (loop (cdr s) (+ k 1)))))))
+
+(define pregexp-make-backref-list
+  (lambda (re)
+    (let sub ((re re))
+      (if (pair? re)
+        (let ((car-re (car re)) (sub-cdr-re (sub (cdr re))))
+          (if (eqv? car-re ':sub)
+            (cons (cons re #f) sub-cdr-re)
+            (append (sub car-re) sub-cdr-re)))
+        '()))))
+
+(define pregexp-match-positions-aux
+  (lambda (re s sn start n i)
+    (let ((identity (lambda (x) x))
+          (backrefs (pregexp-make-backref-list re))
+          (case-sensitive? #t))
+      (let sub ((re re) (i i) (sk identity) (fk (lambda () #f)))
+        (cond
+         ((eqv? re ':bos) (if (= i start) (sk i) (fk)))
+         ((eqv? re ':eos) (if (>= i n) (sk i) (fk)))
+         ((eqv? re ':empty) (sk i))
+         ((eqv? re ':wbdry) (if (pregexp-at-word-boundary? s i n) (sk i) (fk)))
+         ((eqv? re ':not-wbdry)
+          (if (pregexp-at-word-boundary? s i n) (fk) (sk i)))
+         ((and (char? re) (< i n))
+          (if ((if case-sensitive? char=? char-ci=?) (string-ref s i) re)
+            (sk (+ i 1))
+            (fk)))
+         ((and (not (pair? re)) (< i n))
+          (if (pregexp-check-if-in-char-class? (string-ref s i) re)
+            (sk (+ i 1))
+            (fk)))
+         ((and (pair? re) (eqv? (car re) ':char-range) (< i n))
+          (let ((c (string-ref s i)))
+            (if (let ((c< (if case-sensitive? char<=? char-ci<=?)))
+                  (and (c< (cadr re) c) (c< c (caddr re))))
+              (sk (+ i 1))
+              (fk))))
+         ((pair? re)
+          (case (car re)
+            ((:char-range)
+             (if (>= i n) (fk) (pregexp-error 'pregexp-match-positions-aux)))
+            ((:one-of-chars)
+             (if (>= i n)
+               (fk)
+               (let loup-one-of-chars ((chars (cdr re)))
+                 (if (null? chars)
+                   (fk)
+                   (sub
+                    (car chars)
+                    i
+                    sk
+                    (lambda () (loup-one-of-chars (cdr chars))))))))
+            ((:neg-char)
+             (if (>= i n)
+               (fk)
+               (sub (cadr re) i (lambda (i1) (fk)) (lambda () (sk (+ i 1))))))
+            ((:seq)
+             (let loup-seq ((res (cdr re)) (i i))
+               (if (null? res)
+                 (sk i)
+                 (sub (car res) i (lambda (i1) (loup-seq (cdr res) i1)) fk))))
+            ((:or)
+             (let loup-or ((res (cdr re)))
+               (if (null? res)
+                 (fk)
+                 (sub
+                  (car res)
+                  i
+                  (lambda (i1) (or (sk i1) (loup-or (cdr res))))
+                  (lambda () (loup-or (cdr res)))))))
+            ((:backref)
+             (let* ((c (pregexp-list-ref backrefs (cadr re)))
+                    (backref
+                      (cond
+                       (c => cdr)
+                       (else
+                        (pregexp-error
+                          'pregexp-match-positions-aux
+                          'non-existent-backref
+                          re)
+                        #f))))
+               (if backref
+                 (pregexp-string-match
+                   (substring s (car backref) (cdr backref))
+                   s
+                   i
+                   n
+                   (lambda (i) (sk i))
+                   fk)
+                 (sk i))))
+            ((:sub)
+             (sub
+              (cadr re)
+              i
+              (lambda (i1) (set-cdr! (assv re backrefs) (cons i i1)) (sk i1))
+              fk))
+            ((:lookahead)
+             (let ((found-it? (sub (cadr re) i identity (lambda () #f))))
+               (if found-it? (sk i) (fk))))
+            ((:neg-lookahead)
+             (let ((found-it? (sub (cadr re) i identity (lambda () #f))))
+               (if found-it? (fk) (sk i))))
+            ((:lookbehind)
+             (let ((n-actual n) (sn-actual sn))
+               (set! n i)
+               (set! sn i)
+               (let ((found-it?
+                       (sub
+                        (list ':seq '(:between #f 0 #f :any) (cadr re) ':eos)
+                        0
+                        identity
+                        (lambda () #f))))
+                 (set! n n-actual)
+                 (set! sn sn-actual)
+                 (if found-it? (sk i) (fk)))))
+            ((:neg-lookbehind)
+             (let ((n-actual n) (sn-actual sn))
+               (set! n i)
+               (set! sn i)
+               (let ((found-it?
+                       (sub
+                        (list ':seq '(:between #f 0 #f :any) (cadr re) ':eos)
+                        0
+                        identity
+                        (lambda () #f))))
+                 (set! n n-actual)
+                 (set! sn sn-actual)
+                 (if found-it? (fk) (sk i)))))
+            ((:no-backtrack)
+             (let ((found-it? (sub (cadr re) i identity (lambda () #f))))
+               (if found-it? (sk found-it?) (fk))))
+            ((:case-sensitive :case-insensitive)
+             (let ((old case-sensitive?))
+               (set! case-sensitive? (eqv? (car re) ':case-sensitive))
+               (sub
+                (cadr re)
+                i
+                (lambda (i1) (set! case-sensitive? old) (sk i1))
+                (lambda () (set! case-sensitive? old) (fk)))))
+            ((:between)
+             (let* ((maximal? (not (cadr re)))
+                    (p (caddr re))
+                    (q (cadddr re))
+                    (could-loop-infinitely? (and maximal? (not q)))
+                    (re (car (cddddr re))))
+               (let loup-p ((k 0) (i i))
+                 (if (< k p)
+                   (sub
+                    re
+                    i
+                    (lambda (i1)
+                      (if (and could-loop-infinitely? (= i1 i))
+                        (pregexp-error
+                          'pregexp-match-positions-aux
+                          'greedy-quantifier-operand-could-be-empty))
+                      (loup-p (+ k 1) i1))
+                    fk)
+                   (let ((q (and q (- q p))))
+                     (let loup-q ((k 0) (i i))
+                       (let ((fk (lambda () (sk i))))
+                         (if (and q (>= k q))
+                           (fk)
+                           (if maximal?
+                             (sub
+                              re
+                              i
+                              (lambda (i1)
+                                (if (and could-loop-infinitely? (= i1 i))
+                                  (pregexp-error
+                                    'pregexp-match-positions-aux
+                                    'greedy-quantifier-operand-could-be-empty))
+                                (or (loup-q (+ k 1) i1) (fk)))
+                              fk)
+                             (or (fk)
+                                 (sub
+                                  re
+                                  i
+                                  (lambda (i1) (loup-q (+ k 1) i1))
+                                  fk)))))))))))
+            (else (pregexp-error 'pregexp-match-positions-aux))))
+         ((>= i n) (fk))
+         (else (pregexp-error 'pregexp-match-positions-aux))))
+      (let ((backrefs (map cdr backrefs))) (and (car backrefs) backrefs)))))
+
+(define pregexp-replace-aux
+  (lambda (str ins n backrefs)
+    (let loop ((i 0) (r ""))
+      (if (>= i n)
+        r
+        (let ((c (string-ref ins i)))
+          (if (char=? c #\\)
+            (let* ((br-i (pregexp-read-escaped-number ins i n))
+                   (br
+                    (if br-i
+                      (car br-i)
+                      (if (char=? (string-ref ins (+ i 1)) #\&) 0 #f)))
+                   (i (if br-i (cadr br-i) (if br (+ i 2) (+ i 1)))))
+              (if (not br)
+                (let ((c2 (string-ref ins i)))
+                  (loop
+                   (+ i 1)
+                   (if (char=? c2 #\$) r (string-append r (string c2)))))
+                (loop
+                 i
+                 (let ((backref (pregexp-list-ref backrefs br)))
+                   (if backref
+                     (string-append
+                       r
+                       (substring str (car backref) (cdr backref)))
+                     r)))))
+            (loop (+ i 1) (string-append r (string c)))))))))
+
+(define pregexp
+  (lambda (s)
+    (set! *pregexp-space-sensitive?* #t)
+    (list ':sub (car (pregexp-read-pattern s 0 (string-length s))))))
+
+(define pregexp-match-positions
+  (lambda (pat str . opt-args)
+    (cond
+     ((string? pat) (set! pat (pregexp pat)))
+     ((pair? pat) #t)
+     (else
+      (pregexp-error
+        'pregexp-match-positions
+        'pattern-must-be-compiled-or-string-regexp
+        pat)))
+    (let* ((str-len (string-length str))
+           (start
+            (if (null? opt-args)
+              0
+              (let ((start (car opt-args)))
+                (set! opt-args (cdr opt-args))
+                start)))
+           (end (if (null? opt-args) str-len (car opt-args))))
+      (let loop ((i start))
+        (and (<= i end)
+             (or (pregexp-match-positions-aux pat str str-len start end i)
+                 (loop (+ i 1))))))))
+
+(define pregexp-match
+  (lambda (pat str . opt-args)
+    (let ((ix-prs (apply pregexp-match-positions pat str opt-args)))
+      (and ix-prs
+           (map
+            (lambda (ix-pr)
+              (and ix-pr (substring str (car ix-pr) (cdr ix-pr))))
+            ix-prs)))))
+
+(define pregexp-split
+  (lambda (pat str)
+    (let ((n (string-length str)))
+      (let loop ((i 0) (r '()) (picked-up-one-undelimited-char? #f))
+        (cond
+         ((>= i n) (reverse! r))
+         ((pregexp-match-positions pat str i n)
+          =>
+          (lambda (y)
+            (let ((jk (car y)))
+              (let ((j (car jk)) (k (cdr jk)))
+                (cond
+                 ((= j k) (loop (+ k 1) (cons (substring str i (+ j 1)) r) #t))
+                 ((and (= j i) picked-up-one-undelimited-char?) (loop k r #f))
+                 (else (loop k (cons (substring str i j) r) #f)))))))
+         (else (loop n (cons (substring str i n) r) #f)))))))
+
+(define pregexp-replace
+  (lambda (pat str ins)
+    (let* ((n (string-length str)) (pp (pregexp-match-positions pat str 0 n)))
+      (if (not pp)
+        str
+        (let ((ins-len (string-length ins)) (m-i (caar pp)) (m-n (cdar pp)))
+          (string-append
+            (substring str 0 m-i)
+            (pregexp-replace-aux str ins ins-len pp)
+            (substring str m-n n)))))))
+
+(define pregexp-replace*
+  (lambda (pat str ins)
+    (let ((pat (if (string? pat) (pregexp pat) pat))
+          (n (string-length str))
+          (ins-len (string-length ins)))
+      (let loop ((i 0) (r ""))
+        (if (>= i n)
+          r
+          (let ((pp (pregexp-match-positions pat str i n)))
+            (if (not pp)
+              (if (= i 0) str (string-append r (substring str i n)))
+              (loop
+               (cdar pp)
+               (string-append
+                 r
+                 (substring str i (caar pp))
+                 (pregexp-replace-aux str ins ins-len pp))))))))))
+
+(define pregexp-quote
+  (lambda (s)
+    (let loop ((i (- (string-length s) 1)) (r '()))
+      (if (< i 0)
+        (list->string r)
+        (loop
+         (- i 1)
+         (let ((c (string-ref s i)))
+           (if (memv
+                c
+                '(#\\ #\. #\? #\* #\+ #\| #\^ #\$ #\[ #\] #\{ #\} #\( #\)))
+             (cons #\\ (cons c r))
+             (cons c r))))))))
+
+
+)
diff --git a/collects/mzlib/pretty.ss b/collects/mzlib/pretty.ss
new file mode 100644
index 0000000000..0d00e140e2
--- /dev/null
+++ b/collects/mzlib/pretty.ss
@@ -0,0 +1,1074 @@
+;; Originally:
+;; "genwrite.scm" generic write used by pp.scm
+;; copyright (c) 1991, marc feeley
+
+;; Pretty-printer for MzScheme
+;;  Handles structures, cycles, and graphs
+
+;; TO INSTALL this pretty-printer into a MzScheme's read-eval-print loop,
+;; require this module and evaluate:
+;;      (current-print pretty-print-handler)
+
+(module pretty mzscheme
+   (require (lib "port.ss" "mzlib" "private"))
+
+   (provide pretty-print
+	    pretty-display
+	    pretty-print-columns
+	    pretty-print-depth
+	    pretty-print-handler
+	    pretty-print-size-hook
+	    pretty-print-print-hook
+	    pretty-print-pre-print-hook
+	    pretty-print-post-print-hook
+	    pretty-print-print-line
+	    pretty-print-show-inexactness
+	    pretty-print-exact-as-decimal
+	    pretty-print-.-symbol-without-bars
+
+	    pretty-print-style-table?
+	    pretty-print-current-style-table
+	    pretty-print-extend-style-table
+
+	    pretty-printing
+	    pretty-print-newline
+	    make-tentative-pretty-print-output-port
+	    tentative-pretty-print-port-transfer
+	    tentative-pretty-print-port-cancel)
+
+   (define-struct pretty-print-style-table (hash))
+
+   (define pretty-print-extend-style-table
+     (lambda (table symbols like-symbols)
+       (let ([terr (lambda (kind which)
+                     (raise-type-error
+                      'pretty-print-extend-style-table
+                      kind
+                      which
+                      table symbols like-symbols))])
+         (unless (or (not table) (pretty-print-style-table? table))
+           (terr "pretty-print style table or #f" 0))
+         (unless (and (list? symbols)
+                      (andmap symbol? symbols))
+           (terr "list of symbols" 1))
+         (unless (and (list? like-symbols)
+                      (andmap symbol? like-symbols))
+           (terr "list of symbols" 1))
+         (unless (= (length symbols) (length like-symbols))
+           (raise-mismatch-error
+            'pretty-print-extend-style-table
+            (format "length of first list (~a) doesn't match the length of the second list (~a): "
+                    (length symbols) (length like-symbols))
+            like-symbols)))
+       (let ([ht (if table (pretty-print-style-table-hash table) (make-hash-table))]
+             [new-ht (make-hash-table)])
+         (hash-table-for-each
+          ht
+          (lambda (key val)
+            (hash-table-put! new-ht key val)))
+         (for-each
+          (lambda (symbol like-symbol)
+            (let ((s (hash-table-get ht
+                                     like-symbol
+                                     (lambda () #f))))
+              (hash-table-put! new-ht symbol (or s like-symbol))))
+          symbols like-symbols)
+         (make-pretty-print-style-table new-ht))))
+
+   (define pretty-print-current-style-table 
+     (make-parameter 
+      (pretty-print-extend-style-table #f null null)
+      (lambda (s)
+	(unless (pretty-print-style-table? s)
+	  (raise-type-error
+	   'pretty-print-current-style-table 
+	   "pretty-print style table"
+	   s))
+	s)))
+
+   (define pretty-print-.-symbol-without-bars
+     (make-parameter #f (lambda (x) (and x #t))))
+
+   (define pretty-print-show-inexactness 
+     (make-parameter #f
+		     (lambda (x) (and x #t))))
+
+   (define pretty-print-exact-as-decimal
+     (make-parameter #f
+		     (lambda (x) (and x #t))))
+
+   (define pretty-print-columns 
+     (make-parameter 79
+		     (lambda (x)
+		       (unless (or (eq? x 'infinity)
+				   (integer? x))
+			       (raise-type-error 
+				'pretty-print-columns
+				"integer or 'infinity"
+				x))
+		       x)))
+
+   (define pretty-print-depth
+     (make-parameter #f
+		     (lambda (x)
+		       (unless (or (not x) (number? x))
+			       (raise-type-error 
+				'pretty-print-depth
+				"number or #f"
+				x))
+		       x)))
+
+   (define can-accept-n?
+     (lambda (n x)
+       (procedure-arity-includes? x n)))
+   
+   (define pretty-print-size-hook
+     (make-parameter (lambda (x display? port) #f)
+		     (lambda (x)
+		       (unless (can-accept-n? 3 x)
+			       (raise-type-error 
+				'pretty-print-size-hook
+				"procedure of 3 arguments"
+				x))
+		       x)))
+
+   (define pretty-print-print-hook
+     (make-parameter void
+		     (lambda (x)
+		       (unless (can-accept-n? 3 x)
+			       (raise-type-error 
+				'pretty-print-print-hook
+				"procedure of 3 arguments"
+				x))
+		       x)))
+
+   (define pretty-print-print-line
+     (make-parameter (lambda (line port offset width)
+		       (when (and (number? width)
+				  (not (eq? 0 line)))
+			     (newline port))
+		       0)
+		     (lambda (x)
+		       (unless (can-accept-n? 4 x)
+			       (raise-type-error 
+				'pretty-print-print-line
+				"procedure of 4 arguments"
+				x))
+		       x)))
+
+   (define pretty-print-pre-print-hook
+     (make-parameter void
+		     (lambda (x)
+		       (unless (can-accept-n? 2 x)
+			       (raise-type-error 
+				'pretty-print-pre-print-hook
+				"procedure of 2 arguments"
+				x))
+		       x)))
+
+   (define pretty-print-post-print-hook
+     (make-parameter void
+		     (lambda (x)
+		       (unless (can-accept-n? 2 x)
+			       (raise-type-error 
+				'pretty-print-post-print-hook
+				"procedure of 2 arguments"
+				x))
+		       x)))
+
+   (define pretty-printing
+     (make-parameter #f (lambda (x) (and x #t))))
+
+   (define make-pretty-print
+     (lambda (display?)
+       (letrec ([pretty-print
+		 (case-lambda 
+		  [(obj port)
+		   (let ([width (pretty-print-columns)]
+			 [size-hook (pretty-print-size-hook)]
+			 [print-hook (pretty-print-print-hook)]
+			 [pre-hook (pretty-print-pre-print-hook)]
+			 [post-hook (pretty-print-post-print-hook)])
+		     (generic-write obj display?
+				    width
+				    (make-printing-port port 
+							pre-hook
+							post-hook
+							print-hook
+							(pretty-print-print-line))
+				    (print-graph) (print-struct) (print-hash-table)
+				    (and (not display?) (print-vector-length))
+				    (pretty-print-depth)
+				    (lambda (o display?)
+				      (size-hook o display? port)))
+		     (void))]
+		  [(obj) (pretty-print obj (current-output-port))])])
+	 pretty-print)))
+
+   (define pretty-print (make-pretty-print #f))
+   (define pretty-display (make-pretty-print #t))
+
+   (define-struct mark (str def))
+
+   (define (make-tentative-output-port pport width esc)
+     (let* ([content null]
+	    [special-ok? (port-writes-special? pport)]
+	    ;; The null device counts for us:
+	    [/dev/null (let-values ([(line col pos) (port-next-location pport)])
+			 (relocate-output-port 
+			  (let ([p (open-output-nowhere special-ok?)])
+			    (port-count-lines! p)
+			    p)
+			  (or line 1) (or col 0) (or pos 1)))]
+	    [check-esc (lambda ()
+			 (let-values ([(l c p) (port-next-location /dev/null)])
+			   (when (c . > . width)
+			     (esc))))]
+	    [p (make-output-port
+		'tentative
+		always-evt
+		(lambda (s start end block? break?)
+		  (write-bytes s /dev/null start end)
+		  (check-esc)
+		  (set! content (cons (subbytes s start end) content))
+		  (- end start))
+		void
+		(and special-ok?
+		     (lambda (special block break?)
+		       (write-special special /dev/null)
+		       (check-esc)
+		       (set! content (cons (cons 'special special) content))
+		       #t))
+		#f #f
+		(lambda ()
+		  (port-next-location /dev/null)))]
+	    [first-line? #t])
+       (port-count-lines! /dev/null)
+       (port-count-lines! p)
+       (register-printing-port p 
+			       (make-print-port-info
+				(lambda () (reverse content))
+				(box #t)
+				(lambda (v)
+				  (set! content (cons (cons 'pre v) content)))
+				(lambda (v)
+				  (set! content (cons (cons 'post v) content)))
+				(lambda (v len display?)
+				  (display (make-string len #\.) /dev/null)
+				  (set! content (cons (list* 'hooked v len display?)
+						      content)))
+				(lambda (use-line? offset width)
+				  (when (and (number? width)
+					     (not first-line?))
+				    (newline p))
+				  (set! first-line? #f)
+				  0)
+				esc))
+       p))
+
+   (define (make-tentative-pretty-print-output-port pport width esc)
+     (let ([p (make-tentative-output-port pport width esc)])
+       (port-write-handler p (port-write-handler pport))
+       (port-display-handler p (port-display-handler pport))
+       (port-print-handler p (port-print-handler pport))
+       p))
+   
+   (define (make-printing-port port pre-print post-print output-hooked print-line)
+     (let-values ([(line col pos) (port-next-location port)])
+       (let* ([orig-counts? (and line col pos)]
+	      [p (if orig-counts?
+		     (relocate-output-port port line col pos #f)
+		     (transplant-output-port port #f 1 #f))]
+	      [line -1])
+	 (port-count-lines! p)
+	 (register-printing-port p 
+				 (make-print-port-info 
+				  (lambda () null)
+				  (box #t)
+				  (lambda (v)
+				    (pre-print v port))
+				  (lambda (v)
+				    (post-print v port))
+				  (lambda (v len display?)
+				    (output-hooked v display? p))
+				  (lambda (use-line? offset width)
+				    (set! line (add1 line))
+				    (print-line (and use-line? line) p offset width))
+				  void))
+	 p)))
+
+   (define printing-ports (make-hash-table 'weak))
+
+   (define-struct print-port-info (get-content
+				   def-box
+				   pre-print
+				   post-print
+				   output-hooked
+				   print-line
+				   esc))
+
+   (define (register-printing-port p info)
+     (hash-table-put! printing-ports p info))
+
+   (define (register-printing-port-like p pport)
+     (hash-table-put! printing-ports p 
+		      (hash-table-get printing-ports pport)))
+
+   (define (get pport selector)
+     (selector (hash-table-get printing-ports pport
+			       (lambda ()
+				 (make-print-port-info
+				  (lambda () null)
+				  (box #t)
+				  void void void void void)))))
+
+   (define (printing-port-pre-print pport)
+     (get pport print-port-info-pre-print))
+   (define (printing-port-post-print pport)
+     (get pport print-port-info-post-print))
+   (define (printing-port-def-box pport)
+     (get pport print-port-info-def-box))
+   (define (printing-port-output-hooked pport)
+     (get pport print-port-info-output-hooked))
+   (define (printing-port-print-line pport)
+     (get pport print-port-info-print-line))
+   (define (printing-port-esc pport)
+     (get pport print-port-info-esc))
+
+   (define orig-display (port-display-handler (open-output-string)))
+   (define orig-write (port-write-handler (open-output-string)))
+   
+   (define (pretty-print-newline pport width)
+     (let-values ([(l col p) (port-next-location pport)])
+       ((printing-port-print-line pport) #t (or col 0) width)))
+
+   (define (tentative-pretty-print-port-transfer a-pport pport)
+     (let ([content ((get a-pport print-port-info-get-content))])
+       (for-each (lambda (elem)
+		   (if (bytes? elem)
+		       (write-bytes elem pport)
+		       (case (car elem)
+			 [(special) (write-special (cdr elem) pport)]
+			 [(pre) ((printing-port-pre-print pport) (cdr elem))]
+			 [(post) ((printing-port-post-print pport) (cdr elem))]
+			 [(hooked) ((printing-port-output-hooked pport) 
+				    (cadr elem) (caddr elem) (cdddr elem))])))
+		 content)))
+   
+   (define (tentative-pretty-print-port-cancel pport)
+     (set-box! (get pport print-port-info-def-box) #f))
+
+   (define (add-spaces n port)
+     (if (> n 0)
+	 (if (> n 7)
+	     (begin
+	       (write-string "        " port)
+	       (add-spaces (- n 8) port))
+	     (write-string "        " port 0 n))))
+
+   (define (generic-write obj display? width pport
+			  print-graph? print-struct? print-hash-table? print-vec-length?
+			  depth size-hook)
+     
+     (define table (make-hash-table)) ; Hash table for looking for loops
+
+     (define show-inexactness? (pretty-print-show-inexactness))
+     (define exact-as-decimal? (pretty-print-exact-as-decimal))
+     
+     (define vector->repeatless-list
+       (if print-vec-length?
+	   (lambda (v)
+	     (let ([len (vector-length v)])
+               (if (zero? len)
+                   null
+                   (let ([last (vector-ref v (sub1 len))])
+                     (let loop ([i (- len 2)])
+                       (if (i . < . 0)
+                           (list last)
+                           (let ([e (vector-ref v i)])
+                             (if (eq? e last)
+                                 (loop (sub1 i))
+                                 (let loop ([i (sub1 i)][r (list e last)])
+                                   (if (i . < . 0)
+                                       r
+                                       (loop (sub1 i) (cons (vector-ref v i) r))))))))))))
+           vector->list))
+
+     (define (extract-sub-objects obj pport)
+       (let ([p (open-output-nowhere 'null (port-writes-special? pport))]
+	     [l null])
+	 (let ([record (lambda (o p) (set! l (cons o l)))])
+	   (port-write-handler p record)
+	   (port-display-handler p record)
+	   (port-print-handler p record))
+	 (parameterize ([pretty-printing #f])
+	   ((custom-write-accessor obj) obj p #f))
+	 l))
+
+     (define found-cycle
+       (or print-graph?
+	   (let loop ([obj obj])
+	     (and (or (vector? obj)
+		      (pair? obj)
+		      (box? obj)
+		      (custom-write? obj)
+		      (and (struct? obj) print-struct?)
+		      (and (hash-table? obj) print-hash-table?))
+		  (or (hash-table-get table obj (lambda () #f))
+		      (begin
+			(hash-table-put! table obj #t)
+			(let ([cycle
+			       (cond
+				[(vector? obj)
+				 (let ([len (vector-length obj)])
+				   (let loop ([i 0])
+				     (if (= i len)
+					 #f
+					 (or (vector-ref obj i)
+					     (loop (add1 i))))))]
+				[(pair? obj)
+				 (or (loop (car obj))
+				     (loop (cdr obj)))]
+				[(box? obj) (loop (unbox obj))]
+				[(custom-write? obj)
+				 (loop (extract-sub-objects obj pport))]
+				[(struct? obj)
+				 (ormap loop 
+					(vector->list (struct->vector obj)))]
+				[(hash-table? obj)
+				 (let/ec esc
+				   (hash-table-for-each
+				    obj
+				    (lambda (v k)
+				      (when (or (loop v)
+						(loop k))
+					(esc #t))))
+				   #f)])])
+			  (hash-table-remove! table obj)
+			  cycle)))))))
+
+     (define ::dummy::
+       (when found-cycle
+	 (let loop ([obj obj])
+	   (if (or (vector? obj)
+		   (pair? obj)
+		   (box? obj)
+		   (custom-write? obj)
+		   (and (struct? obj) print-struct?)
+		   (and (hash-table? obj) print-hash-table?))
+	       ;; A little confusing: use #t for not-found
+	       (let ([p (hash-table-get table obj (lambda () #t))])
+		 (when (not (mark? p))
+		   (if p
+		       (begin
+			 (hash-table-put! table obj #f)
+			 (cond
+			  [(vector? obj)
+			   (let ([len (vector-length obj)])
+			     (let vloop ([i 0])
+			       (unless (= i len)
+				 (loop (vector-ref obj i))
+				 (vloop (add1 i)))))]
+			  [(pair? obj)
+			   (loop (car obj))
+			   (loop (cdr obj))]
+			  [(box? obj) (loop (unbox obj))]
+			  [(custom-write? obj)
+			   (loop (extract-sub-objects obj pport))]
+			  [(struct? obj)
+			   (for-each loop 
+				     (vector->list (struct->vector obj)))]
+			  [(hash-table? obj)
+			   (hash-table-for-each
+			    obj
+			    (lambda (k v)
+			      (loop k)
+			      (loop v)))]))
+		       (begin
+			 (hash-table-put! table obj 
+					  (make-mark #f (box #f)))))))))))
+
+     (define cycle-counter 0)
+
+     (define found (if found-cycle
+		       table 
+		       #f))
+
+     (define dsub1 (lambda (d)
+		     (if d
+			 (sub1 d)
+			 #f)))
+
+     (define (pre-print pport obj)
+       ((printing-port-pre-print pport) obj))
+     (define (post-print pport obj)
+       ((printing-port-post-print pport)
+	obj))
+     (define (output-hooked pport obj len display?)
+       ((printing-port-output-hooked pport)
+	obj len display?))
+
+     (define expr-found
+       (lambda (pport ref)
+	 (let ([n cycle-counter])
+	   (set! cycle-counter (add1 cycle-counter))
+	   (set-mark-str! ref 
+			  (string-append "#"
+					 (number->string n)
+					 "#"))
+	   (set-mark-def! ref (printing-port-def-box pport))
+	   (display (string-append "#"
+				   (number->string n)
+				   "=")
+		    pport))))
+     
+     (define check-expr-found
+       (lambda (obj pport check? c-k d-k n-k)
+	 (let ([ref (and check? 
+			 found
+			 (hash-table-get found obj (lambda () #f)))])
+	   (if (and ref (unbox (mark-def ref)))
+	       (if c-k
+		   (c-k (mark-str ref))
+		   (display (mark-str ref) pport))
+	       (if (and ref d-k)
+		   (d-k)
+		   (begin
+		     (when ref
+		       (expr-found pport ref))
+		     (n-k)))))))
+
+     (define (write-custom recur obj pport depth display? width)
+       (let-values ([(l c p) (port-next-location pport)])
+	 (let ([p (relocate-output-port pport l c p)])
+	   (port-count-lines! p)
+	   (let ([writer (lambda (v port)
+			   (recur port v (dsub1 depth) #f))]
+		 [displayer (lambda (v port)
+			      (recur port v (dsub1 depth) #t))])
+	     (port-write-handler p writer)
+	     (port-display-handler p displayer)
+	     (port-print-handler p writer))
+	   (register-printing-port-like p pport)
+	   (parameterize ([pretty-printing #t]
+			  [pretty-print-columns (or width 'infinity)])
+	     ((custom-write-accessor obj) obj p (not display?))))))
+
+     ;; ------------------------------------------------------------
+     ;; wr: write on a single line
+     (define (wr* pport obj depth display?)
+
+       (define (out str)
+	 (write-string str pport))
+       
+       (define (wr obj depth)
+	 (wr* pport obj depth display?))
+
+       (define (wr-expr expr depth)
+	 (if (read-macro? expr)
+	     (begin
+	       (out (read-macro-prefix expr))
+	       (wr (read-macro-body expr) depth))
+	     (wr-lst expr #t depth)))
+
+       (define (wr-lst l check? depth)
+	 (if (pair? l)
+	     (check-expr-found 
+	      l pport check?
+	      #f #f
+	      (lambda ()
+		(if (and depth (zero? depth))
+		    (out "(...)")
+		    (begin
+		      (out "(")
+		      (wr (car l) (dsub1 depth))
+		      (let loop ([l (cdr l)])
+			(check-expr-found
+			 l pport (and check? (pair? l))
+			 (lambda (s) (out " . ") (out s) (out ")"))
+			 (lambda ()
+			   (out " . ")
+			   (wr-lst l check? (dsub1 depth))
+			   (out ")"))
+			 (lambda ()
+			   (cond 
+			    [(pair? l) 
+			     (if (and (eq? (car l) 'unquote)
+				      (pair? (cdr l))
+				      (null? (cddr l)))
+				 (begin
+				   (out " . ,")
+				   (wr (cadr l) (dsub1 depth))
+				   (out ")"))
+				 (begin
+				   (out " ")
+				   (wr (car l) (dsub1 depth))
+				   (loop (cdr l))))]
+			    [(null? l) (out ")")]
+			    [else
+			     (out " . ")
+			     (wr l (dsub1 depth))
+			     (out ")")]))))))))
+	     (out "()")))
+
+       (pre-print pport obj)
+       (if (and depth (negative? depth))
+	   (out "...")
+	   
+	   (cond 
+	    [(size-hook obj display?)
+	     => (lambda (len)
+		  (output-hooked pport obj len display?))]
+	    
+	    [(pair? obj) 
+	     (wr-expr obj depth)]
+	    [(null? obj)
+	     (wr-lst obj #f depth)]
+	    [(vector? obj)   
+	     (check-expr-found
+	      obj pport #t
+	      #f #f
+	      (lambda ()
+		(out "#")
+		(when print-vec-length?
+		  (out (number->string (vector-length obj))))
+		(wr-lst (vector->repeatless-list obj) #f depth)))]
+	    [(box? obj)        
+	     (check-expr-found
+	      obj pport #t
+	      #f #f
+	      (lambda ()
+		(out "#&") 
+		(wr (unbox obj) (dsub1 depth))))]
+	    [(custom-write? obj) 
+	     (check-expr-found
+	      obj pport #t
+	      #f #f
+	      (lambda ()
+		(parameterize ([pretty-print-columns 'infinity])
+		  (write-custom wr* obj pport depth display? width))))]
+	    [(struct? obj)
+	     (if (and print-struct?
+		      (not (and depth
+				(zero? depth))))
+		 (check-expr-found
+		  obj pport #t
+		  #f #f
+		  (lambda ()
+		    (out "#")
+		    (wr-lst (vector->list (struct->vector obj)) #f (dsub1 depth))))
+		 (parameterize ([print-struct #f])
+		   ((if display? orig-display orig-write) obj pport)))]
+	    [(hash-table? obj)  
+	     (if (and print-hash-table?
+		      (not (and depth
+				(zero? depth))))
+		 (check-expr-found
+		  obj pport #t
+		  #f #f
+		  (lambda ()
+		    (out "#hash")
+		    (wr-lst (hash-table-map obj cons) #f depth))
+		  (parameterize ([print-hash-table #f])
+		    ((if display? orig-display orig-write) obj pport))))]
+	    [(boolean? obj)
+	     (out (if obj "#t" "#f"))]
+	    [(number? obj)
+	     (when (and show-inexactness?
+			(inexact? obj))
+	       (out "#i"))
+	     (out ((if exact-as-decimal?
+		       number->decimal-string
+		       number->string)
+		   obj))]
+	    [(and (pretty-print-.-symbol-without-bars)
+		  (eq? obj '|.|))
+	     (out ".")]
+	    [else
+	     ((if display? orig-display orig-write) obj pport)]))
+       (post-print pport obj))
+
+     ;; ------------------------------------------------------------
+     ;; pp: write on (potentially) multiple lines
+     (define (pp* pport obj depth display?)
+
+       (define (pp obj depth)
+	 (pp* pport obj depth display?))
+
+       (define (out str)
+	 (write-string str pport))
+       
+       (define (spaces n)
+	 (add-spaces n pport))
+
+       (define (ccol)
+	 (let-values ([(l col p) (port-next-location pport)])
+	   col))
+
+       (define (indent to)
+	 (let ([col (ccol)])
+	   (if (< to col)
+	       (begin
+		 (let ([col ((printing-port-print-line pport) #t col width)])
+		   (spaces (- to col))))
+	       (spaces (max 0 (- to col))))))
+
+       (define (pr obj extra pp-pair depth)
+	 ;; may have to split on multiple lines
+	 (let* ([can-multi (and width
+				(or (pair? obj) (vector? obj) 
+				    (box? obj) 
+				    (custom-write? obj)
+				    (and (struct? obj) print-struct?)
+				    (and (hash-table? obj) print-hash-table?)))]
+		[graph-ref (if can-multi
+			       (and found (hash-table-get found obj (lambda () #f)))
+			       #f)])
+	   (if (and can-multi
+		    (or (not graph-ref) 
+			(not (unbox (mark-def graph-ref)))))
+	       ;; It might be possible to split obj across lines.
+	       ;; Try writing the obj, but accumulate the info that goes out
+	       ;;  into a-pport
+	       (let ([a-pport
+		      (let/ec esc
+			(letrec ([a-pport (make-tentative-output-port
+					   pport 
+					   (- width extra)
+					   (lambda () (esc a-pport)))])
+			  ;; Here's the attempt to write on one line:
+			  (wr* a-pport obj depth display?)
+			  a-pport))])
+		 (let-values ([(l c p) (port-next-location a-pport)])
+		   (if (<= c (- width extra))
+		       ;; All can be printed on one line, so just dump the
+		       ;;  accumulated text
+		       (tentative-pretty-print-port-transfer a-pport pport)
+		       ;; Doesn't fit on one line, so start over
+		       (begin
+			 (tentative-pretty-print-port-cancel a-pport)
+			 (when graph-ref
+			   (expr-found pport graph-ref))
+			 (pre-print pport obj)
+			 (cond
+			  [(pair? obj) (pp-pair obj extra depth)]
+			  [(vector? obj)
+			   (out "#")
+			   (when print-vec-length?
+			     (out (number->string (vector-length obj))))
+			   (pp-list (vector->repeatless-list obj) extra pp-expr #f depth)]
+			  [(custom-write? obj)
+			   (write-custom pp* obj pport depth display? width)]
+			  [(struct? obj) ; print-struct is on if we got here
+			   (out "#")
+			   (pp-list (vector->list (struct->vector obj)) extra pp-expr #f depth)]
+			  [(hash-table? obj)
+			   (out "#hash")
+			   (pp-list (hash-table-map obj cons) extra pp-expr #f depth)]
+			  [(box? obj)
+			   (out "#&") 
+			   (pr (unbox obj) extra pp-pair depth)])
+			 (post-print pport obj)))))
+	       ;; Not possible to split obj across lines; so just write directly
+	       (wr* pport obj depth display?))))
+
+       (define (pp-expr expr extra depth)
+	 (if (read-macro? expr)
+	     (begin
+	       (out (read-macro-prefix expr))
+	       (pr (read-macro-body expr)
+		   extra
+		   pp-expr
+		   depth))
+	     (let ((head (car expr)))
+	       (if (and (symbol? head)
+			(not (size-hook head display?)))
+		   (let ((proc (style head)))
+		     (if proc
+			 (proc expr extra depth)
+			 (if (> (string-length (symbol->string head))
+				max-call-head-width)
+			     (pp-general expr extra #f #f #f pp-expr depth)
+			     (pp-list expr extra pp-expr #t depth))))
+		   (pp-list expr extra pp-expr #t depth)))))
+
+       (define (wr obj depth)
+	 (wr* pport obj depth display?))
+
+       ;; (head item1
+       ;;       item2
+       ;;       item3)
+       (define (pp-call expr extra pp-item depth)
+	 (out "(")
+	 (wr (car expr) (dsub1 depth))
+	 (let ([col (+ (ccol) 1)])
+	   (pp-down ")" (cdr expr) col col extra pp-item #t #t depth)))
+
+       ;; (head item1 item2
+       ;;   item3
+       ;;   item4)
+       (define (pp-two-up expr extra pp-item depth)
+	 (out "(")
+	 (let ([col (ccol)])
+	   (wr (car expr) (dsub1 depth))
+	   (out " ")
+	   (wr (cadr expr) (dsub1 depth))
+	   (pp-down ")" (cddr expr) (+ (ccol) 1) (+ col 1) extra pp-item #t #t depth)))
+
+       ;; (head item1
+       ;;   item2
+       ;;   item3)
+       (define (pp-one-up expr extra pp-item depth)
+	 (out "(")
+	 (let ([col (ccol)])
+	   (wr (car expr) (dsub1 depth))
+	   (pp-down ")" (cdr expr) (+ (ccol) 1) (+ col 1) extra pp-item #t #t depth)))
+
+       ;; (item1
+       ;;  item2
+       ;;  item3)
+       (define (pp-list l extra pp-item check? depth)
+	 (out "(")
+	 (let ([col (ccol)])
+	   (pp-down ")" l col col extra pp-item #f check? depth)))
+
+       (define (pp-down closer l col1 col2 extra pp-item check-first? check-rest? depth)
+	 (let loop ([l l] [icol col1] [check? check-first?])
+	   (check-expr-found
+	    l pport (and check? (pair? l))
+	    (lambda (s) 
+	      (indent col2)
+	      (out ".")
+	      (indent col2)
+	      (out s)
+	      (out closer))
+	    (lambda ()
+	      (indent col2)
+	      (out ".")
+	      (indent col2)
+	      (pr l extra pp-item depth)
+	      (out closer))
+	    (lambda ()
+	      (cond 
+	       [(pair? l)
+		(let ([rest (cdr l)])
+		  (let ([extra (if (null? rest) (+ extra 1) 0)])
+		    (indent icol)
+		    (pr (car l) extra pp-item (dsub1 depth))
+		    (loop rest col2 check-rest?)))]
+	       [(null? l)
+		(out closer)]
+	       [else
+		(indent col2)
+		(out ".")
+		(indent col2)
+		(pr l (+ extra 1) pp-item (dsub1 depth))
+		(out closer)])))))
+
+       (define (pp-general expr extra named? pp-1 pp-2 pp-3 depth)
+
+	 (define (tail1 rest col1 col3)
+	   (if (and pp-1 (pair? rest))
+	       (let* ((val1 (car rest))
+		      (rest (cdr rest))
+		      (extra (if (null? rest) (+ extra 1) 0)))
+		 (indent col3)
+		 (pr val1 extra pp-1 depth)
+		 (tail2 rest col1 col3))
+	       (tail2 rest col1 col3)))
+
+	 (define (tail2 rest col1 col3)
+	   (if (and pp-2 (pair? rest))
+	       (let* ((val1 (car rest))
+		      (rest (cdr rest))
+		      (extra (if (null? rest) (+ extra 1) 0)))
+		 (indent col3)
+		 (pr val1 extra pp-2 depth)
+		 (tail3 rest col1))
+	       (tail3 rest col1)))
+
+	 (define (tail3 rest col1)
+	   (pp-down ")" rest col1 col1 extra pp-3 #f #t depth))
+
+	 (let* ([head (car expr)]
+		[rest (cdr expr)]
+		[col (ccol)])
+	   (out "(")
+	   (wr head (dsub1 depth))
+	   (if (and named? (pair? rest))
+	       (let* ((name (car rest))
+		      (rest (cdr rest)))
+		 (out " ")
+		 (wr name (dsub1 depth))
+		 (tail1 rest (+ col indent-general) (+ (ccol) 1)))
+	       (tail1 rest (+ col indent-general) (+ (ccol) 1)))))
+
+       (define (pp-expr-list l extra depth)
+	 (pp-list l extra pp-expr #t depth))
+
+       (define (pp-lambda expr extra depth)
+	 (pp-general expr extra #f pp-expr-list #f pp-expr depth))
+
+       (define (pp-if expr extra depth)
+	 (pp-general expr extra #f pp-expr #f pp-expr depth))
+
+       (define (pp-cond expr extra depth)
+	 (pp-list expr extra pp-expr-list #t depth))
+
+       (define (pp-class expr extra depth)
+	 (pp-two-up expr extra pp-expr-list depth))
+
+       (define (pp-make-object expr extra depth)
+	 (pp-one-up expr extra pp-expr-list depth))
+
+       (define (pp-case expr extra depth)
+	 (pp-general expr extra #f pp-expr #f pp-expr-list depth))
+
+       (define (pp-and expr extra depth)
+	 (pp-call expr extra pp-expr depth))
+
+       (define (pp-let expr extra depth)
+	 (let* ((rest (cdr expr))
+		(named? (and (pair? rest) (symbol? (car rest)))))
+	   (pp-general expr extra named? pp-expr-list #f pp-expr depth)))
+
+       (define (pp-begin expr extra depth)
+	 (pp-general expr extra #f #f #f pp-expr depth))
+
+       (define (pp-do expr extra depth)
+	 (pp-general expr extra #f pp-expr-list pp-expr-list pp-expr depth))
+
+       ;; define formatting style (change these to suit your style)
+
+       (define indent-general 2)
+
+       (define max-call-head-width 5)
+
+       (define (style head)
+	 (case (or (hash-table-get (pretty-print-style-table-hash
+				    (pretty-print-current-style-table))
+				   head
+				   (lambda () #f))
+		   head)
+	   ((lambda define define-macro define-syntax
+		    syntax-rules
+		    shared
+		    unless when)
+	    pp-lambda)
+	   ((if set! set!-values)
+	    pp-if)
+	   ((cond case-lambda)
+	    pp-cond)
+	   ((case) 
+	    pp-case)
+	   ((and or import export 
+		 require require-for-syntax require-for-template 
+		 provide link
+		 public private override rename inherit field init)
+	    pp-and)
+	   ((let letrec let*
+	      let-values letrec-values let*-values
+	      let-syntax letrec-syntax
+	      let-syntaxes letrec-syntaxes)
+	    pp-let)
+	   ((begin begin0)
+	    pp-begin)
+	   ((do letrec-syntaxes+values)
+	    pp-do)
+
+	   ((send class syntax-case instantiate module)
+	    pp-class)
+	   ((make-object)
+	    pp-make-object)
+
+	   (else #f)))
+
+       (pr obj 0 pp-expr depth))
+
+     ;; ------------------------------------------------------------
+     ;; This is where generic-write's body expressions start
+
+     ((printing-port-print-line pport) #t 0 width)
+     (let-values ([(l col p) (port-next-location pport)])
+       (if (and width (not (eq? width 'infinity)))
+	   (pp* pport obj depth display?)
+	   (wr* pport obj depth display?)))
+     (let-values ([(l col p) (port-next-location pport)])
+       ((printing-port-print-line pport) #f col width)))
+   
+   (define (read-macro? l)
+     (define (length1? l) (and (pair? l) (null? (cdr l))))
+     (let ((head (car l)) (tail (cdr l)))
+       (case head
+	 ((quote quasiquote unquote unquote-splicing syntax)
+	  (length1? tail))
+	 (else #f))))
+   
+   (define (read-macro-body l)
+     (cadr l))
+   
+   (define (read-macro-prefix l)
+     (let ((head (car l)))
+       (case head
+	 ((quote)             "'")
+	 ((quasiquote)        "`")
+	 ((unquote)           ",")
+	 ((unquote-splicing)  ",@")
+	 ((syntax)            "#'")
+	 ((unsyntax)          "#,")
+	 ((unsyntax-splicing) "#,@"))))
+
+   (define pretty-print-handler
+     (lambda (v)
+       (unless (void? v)
+	       (pretty-print v))))
+
+   (define (number->decimal-string x)
+     (cond
+      [(or (inexact? x)
+	   (integer? x))
+       (number->string x)]
+      [(not (real? x))
+       (let ([r (real-part x)]
+	     [i (imag-part x)])
+	 (format "~a~a~ai"
+		 (number->decimal-string r)
+		 (if (negative? i)
+		     ""
+		     "+")
+		 (number->decimal-string i)))]
+      [else
+       (let ([n (numerator x)]
+	     [d (denominator x)])
+	 ;; Count powers of 2 in denomintor
+	 (let loop ([v d][2-power 0])
+	   (if (and (positive? v)
+		    (even? v))
+	       (loop (arithmetic-shift v -1) (add1 2-power))
+	       ;; Count powers of 5 in denominator
+	       (let loop ([v v][5-power 0])
+		 (if (zero? (remainder v 5))
+		     (loop (quotient v 5) (add1 5-power))
+		     ;; No more 2s or 5s. Anything left?
+		     (if (= v 1)
+			 ;; Denominator = (* (expt 2 2-power) (expt 5 5-power)).
+			 ;; Print number as decimal.
+			 (let* ([10-power (max 2-power 5-power)]
+				[scale (* (expt 2 (- 10-power 2-power))
+					  (expt 5 (- 10-power 5-power)))]
+				[s (number->string (* (abs n) scale))]
+				[orig-len (string-length s)]
+				[len (max (add1 10-power) orig-len)]
+				[padded-s (if (< orig-len len)
+					      (string-append
+					       (make-string (- len orig-len) #\0)
+					       s)
+					      s)])
+			   (format "~a~a.~a"
+				   (if (negative? n) "-" "")
+				   (substring padded-s 0 (- len 10-power))
+				   (substring padded-s (- len 10-power) len)))
+			 ;; d has factor(s) other than 2 and 5.
+			 ;; Print as a fraction.
+			 (number->string x)))))))])))
+
diff --git a/collects/mzlib/private/class-internal.ss b/collects/mzlib/private/class-internal.ss
new file mode 100644
index 0000000000..ac04b4b93d
--- /dev/null
+++ b/collects/mzlib/private/class-internal.ss
@@ -0,0 +1,3144 @@
+
+(module class-internal mzscheme
+  (require (lib "list.ss")
+           (lib "etc.ss")
+	   (lib "stxparam.ss")
+	   "serialize-structs.ss")
+  (require-for-syntax (lib "kerncase.ss" "syntax")
+		      (lib "stx.ss" "syntax")
+		      (lib "name.ss" "syntax")
+		      (lib "context.ss" "syntax")
+		      (lib "define.ss" "syntax")
+		      (lib "stxparam.ss")
+		      "classidmap.ss")
+
+  (define insp (current-inspector)) ; for all opaque structures
+
+  ;;--------------------------------------------------------------------
+  ;;  keyword setup
+  ;;--------------------------------------------------------------------
+  
+  (define-syntax provide-class-keyword
+    (syntax-rules ()
+      [(_ id ...)
+       (begin
+	 (define-syntax (id stx)
+	   (raise-syntax-error
+	    #f
+	    "use of a class keyword is not in a class top-level"
+	    stx))
+	 ...
+	 (provide id ...))]))
+  
+  (provide-class-keyword private public override augride
+			 pubment overment augment
+			 public-final override-final augment-final
+			 field init init-field
+			 rename-super rename-inner inherit
+			 inspect)
+
+  (define-syntax define/provide-context-keyword
+    (syntax-rules ()
+      [(_ (id param-id) ...)
+       (begin
+	 (begin
+	   (provide id)
+	   (define-syntax-parameter param-id 
+	     (make-set!-transformer
+	      (lambda (stx)
+		(raise-syntax-error
+		 #f
+		 "use of a class keyword is not in a class"
+		 stx))))
+	   (define-syntax id
+	     (make-parameter-rename-transformer #'param-id)))
+	 ...)]))
+
+  (define/provide-context-keyword
+    [this this-param]
+    [super super-param]
+    [inner inner-param]
+    [super-make-object super-make-object-param]
+    [super-instantiate super-instantiate-param]
+    [super-new super-new-param])
+
+  ;;--------------------------------------------------------------------
+  ;;  class macros
+  ;;--------------------------------------------------------------------
+
+  (define-syntaxes (class* :class class/derived)
+    (let ()
+      ;; Start with Helper functions
+
+      (define (expand-all-forms stx defn-and-exprs)
+	(let* ([stop-forms
+		(append
+		 (kernel-form-identifier-list (quote-syntax here))
+		 (list 
+		  (quote-syntax init)
+		  (quote-syntax init-rest)
+		  (quote-syntax field)
+		  (quote-syntax init-field)
+		  (quote-syntax inherit-field)
+		  (quote-syntax private)
+		  (quote-syntax public)
+		  (quote-syntax override)
+		  (quote-syntax augride)
+		  (quote-syntax public-final)
+		  (quote-syntax override-final)
+		  (quote-syntax augment-final)
+		  (quote-syntax pubment)
+		  (quote-syntax overment)
+		  (quote-syntax augment)
+		  (quote-syntax rename-super)
+		  (quote-syntax inherit)
+		  (quote-syntax rename-inner)
+		  (quote-syntax super)
+		  (quote-syntax inner)
+		  (quote-syntax this)
+		  (quote-syntax super-instantiate)
+		  (quote-syntax super-make-object)
+		  (quote-syntax super-new)
+		  (quote-syntax inspect)))]
+	       [expand-context (generate-class-expand-context)]
+	       [expand
+		(lambda (defn-or-expr)
+		  (local-expand
+		   defn-or-expr
+		   expand-context
+		   stop-forms))])
+	  (let loop ([l defn-and-exprs])
+	    (if (null? l)
+		null
+		(let ([e (expand (car l))])
+		  (syntax-case e (begin)
+		    [(begin expr ...)
+		     (loop (append
+			    (syntax->list (syntax (expr ...)))
+			    (cdr l)))]
+		    [(begin . _)
+		     (raise-syntax-error 
+		      #f
+		      "ill-formed begin expression"
+		      e)]
+		    [_else (cons e (loop (cdr l)))]))))))
+
+      ;; returns two lists: expressions that start with an identifier in
+      ;; `kws', and expressions that don't
+      (define (extract kws l out-cons)
+	(let loop ([l l])
+	  (if (null? l)
+	      (values null null)
+	      (let-values ([(in out) (loop (cdr l))])
+		(cond
+		 [(and (stx-pair? (car l))
+		       (let ([id (stx-car (car l))])
+			 (and (identifier? id)
+			      (ormap (lambda (k) (module-identifier=? k id)) kws))))
+		  (values (cons (car l) in) out)]
+		 [else
+		  (values in (out-cons (car l) out))])))))
+
+      (define (extract* kws l)
+	(let-values ([(in out) (extract kws l void)])
+	  in))
+
+      (define (flatten alone l)
+	(apply append
+	       (map (lambda (i)
+		      (let ([l (cdr (syntax->list i))])
+			(if alone
+			    (map (lambda (i)
+				   (if (identifier? i)
+				       (alone i)
+				       (cons (stx-car i)
+					     (stx-car (stx-cdr i)))))
+				 l)
+			    l)))
+		    l)))
+
+      ;; Used with flatten:
+      (define (pair i) (cons i i))
+
+      (define (normalize-init/field i)
+	;; Put i in ((iid eid) optional-expr) form
+	(cond
+	 [(identifier? i) (list (list i i))]
+	 [else (let ([a (stx-car i)])
+		 (if (identifier? a)
+		     (cons (list a a) (stx-cdr i))
+		     i))]))
+
+      (define (norm-init/field-iid norm) (stx-car (stx-car norm)))
+      (define (norm-init/field-eid norm) (stx-car (stx-cdr (stx-car norm))))
+
+      ;; expands an expression enough that we can check whether it has
+      ;; the right form for a method; must use local syntax definitions
+      (define (proc-shape name orig-stx xform? 
+			  the-obj the-finder
+			  bad class-name expand-stop-names)
+	(define (expand expr locals)
+	  (local-expand
+	   expr
+	   'expression
+	   (append locals expand-stop-names)))
+	;; Checks whether the vars sequence is well-formed
+	(define (vars-ok? vars)
+	  (or (identifier? vars)
+	      (stx-null? vars)
+	      (and (stx-pair? vars)
+		   (identifier? (stx-car vars))
+		   (vars-ok? (stx-cdr vars)))))
+	;; mk-name: constructs a method name
+	;; for error reporting, etc.
+	(define (mk-name name)
+	  (datum->syntax-object 
+	   #f 
+	   (string->symbol (format "~a method~a~a" 
+				   (syntax-e name)
+				   (if class-name
+				       " in "
+				       "")
+				   (or class-name 
+				       ""))) 
+	   #f))
+	;; -- tranform loop starts here --
+	(let loop ([stx orig-stx][can-expand? #t][name name][locals null])
+	  (syntax-case stx (lambda case-lambda letrec-values let-values)
+	    [(lambda vars body1 body ...)
+	     (vars-ok? (syntax vars))
+	     (if xform?
+		 (with-syntax ([the-obj the-obj]
+			       [the-finder the-finder]
+			       [name (mk-name name)])
+		   (let ([l (syntax/loc stx 
+			      (lambda (the-obj . vars) 
+				(let-syntax ([the-finder (quote-syntax the-obj)])
+				  body1 body ...)))])
+		     (with-syntax ([l (recertify (add-method-property l) stx)])
+		       (syntax/loc stx 
+			 (let ([name l]) name)))))
+		 stx)]
+	    [(lambda . _)
+	     (bad "ill-formed lambda expression for method" stx)]
+	    [(case-lambda [vars body1 body ...] ...)
+	     (andmap vars-ok? (syntax->list (syntax (vars ...))))
+	     (if xform?
+		 (with-syntax ([the-obj the-obj]
+			       [the-finder the-finder]
+			       [name (mk-name name)])
+		   (let ([cl (syntax/loc stx
+			       (case-lambda [(the-obj . vars) 
+					     (let-syntax ([the-finder (quote-syntax the-obj)])
+					       body1 body ...)] ...))])
+		     (with-syntax ([cl (recertify (add-method-property cl) stx)])
+		       (syntax/loc stx
+			 (let ([name cl]) name)))))
+		 stx)]
+	    [(case-lambda . _)
+	     (bad "ill-formed case-lambda expression for method" stx)]
+	    [(let- ([(id) expr] ...) let-body)
+	     (and (or (module-identifier=? (syntax let-) 
+					   (quote-syntax let-values))
+		      (module-identifier=? (syntax let-) 
+					   (quote-syntax letrec-values)))
+		  (andmap identifier? (syntax->list (syntax (id ...)))))
+	     (let* ([letrec? (module-identifier=? (syntax let-) 
+						  (quote-syntax letrec-values))]
+		    [ids (syntax->list (syntax (id ...)))]
+		    [new-ids (if xform?
+				 (map
+				  (lambda (id)
+				    (datum->syntax-object
+				     #f
+				     (gensym (syntax-e id))))
+				  ids)
+				 ids)]
+		    [body-locals (append ids locals)]
+		    [exprs (map (lambda (expr id)
+				  (loop expr #t id (if letrec?
+						       body-locals
+						       locals)))
+				(syntax->list (syntax (expr ...)))
+				ids)]
+		    [body (let ([body (syntax let-body)])
+			    (if (identifier? body)
+				(ormap (lambda (id new-id)
+					 (and (bound-identifier=? body id)
+					      new-id))
+				       ids new-ids)
+				(loop body #t name body-locals)))])
+	       (unless body
+		 (bad "bad form for method definition" orig-stx))
+	       (with-syntax ([(proc ...) exprs]
+			     [(new-id ...) new-ids]
+			     [mappings
+			      (if xform?
+				  (map
+				   (lambda (old-id new-id)
+				     (with-syntax ([old-id old-id]
+						   [new-id new-id]
+						   [the-obj the-obj]
+						   [the-finder the-finder])
+				       (syntax (old-id (make-direct-method-map 
+							(quote-syntax the-finder)
+							(quote the-obj)
+							(quote-syntax old-id)
+							(quote new-id))))))
+				   ids new-ids)
+				  null)]
+			     [body body])
+		 (recertify
+		  (if xform?
+		      (if letrec?
+			  (syntax/loc stx (letrec-syntax mappings
+					    (let- ([(new-id) proc] ...) 
+						  body)))
+			  (syntax/loc stx (let- ([(new-id) proc] ...) 
+						(letrec-syntax mappings
+						  body))))
+		      (syntax/loc stx (let- ([(new-id) proc] ...) 
+					    body)))
+		  stx)))]
+	    [_else 
+	     (if can-expand?
+		 (loop (expand stx locals) #f name locals)
+		 (bad "bad form for method definition" orig-stx))])))
+
+      (define (add-method-property l)
+	(syntax-property l 'method-arity-error #t))
+
+      (define method-insp (current-code-inspector))
+
+      (define (recertify new old)
+	(syntax-recertify new old method-insp #f))
+
+      ;; --------------------------------------------------------------------------------
+      ;; Start here:
+
+      (define (main stx super-expr deserialize-id-expr name-id interface-exprs defn-and-exprs)
+	(let-values ([(this-id) #'this-id]
+		     [(the-obj) (datum->syntax-object (quote-syntax here) (gensym 'self))]
+		     [(the-finder) (datum->syntax-object (quote-syntax here) (gensym 'find-self))])
+	  
+	  ;; ----- Expand definitions -----
+	  (let ([defn-and-exprs (expand-all-forms stx defn-and-exprs)]
+		[bad (lambda (msg expr)
+		       (raise-syntax-error #f msg stx expr))]
+		[class-name (if name-id
+				(syntax-e name-id)
+				(let ([s (syntax-local-infer-name stx)])
+				  (if (syntax? s)
+				      (syntax-e s)
+				      s)))])
+	    
+	    ;; ------ Basic syntax checks -----
+	    (for-each (lambda (stx)
+			(syntax-case stx (init init-rest field init-field inherit-field
+					       private public override augride
+					       public-final override-final augment-final
+					       pubment overment augment
+					       rename-super inherit rename-inner
+					       inspect)
+			  [(form idp ...)
+			   (and (identifier? (syntax form))
+				(or (module-identifier=? (syntax form) (quote-syntax init))
+				    (module-identifier=? (syntax form) (quote-syntax init-field))))
+			   
+			   (let ([form (syntax-e (syntax form))])
+			     (for-each 
+			      (lambda (idp)
+				(syntax-case idp ()
+				  [id (identifier? (syntax id)) 'ok]
+				  [((iid eid)) (and (identifier? (syntax iid))
+						    (identifier? (syntax eid))) 'ok]
+				  [(id expr) (identifier? (syntax id)) 'ok]
+				  [((iid eid) expr) (and (identifier? (syntax iid))
+							 (identifier? (syntax eid))) 'ok]
+				  [else
+				   (bad 
+				    (format
+				     "~a element is not an optionally renamed identifier or identifier-expression pair"
+				     form)
+				    idp)]))
+			      (syntax->list (syntax (idp ...)))))]
+			  [(inspect expr)
+			   'ok]
+			  [(inspect . rest)
+			   (bad "ill-formed inspect clause" stx)]
+			  [(init . rest)
+			   (bad "ill-formed init clause" stx)]
+			  [(init-rest)
+			   'ok]
+			  [(init-rest rest)
+			   (identifier? (syntax rest))
+			   'ok]
+			  [(init-rest . rest)
+			   (bad "ill-formed init-rest clause" stx)]
+			  [(init-field . rest)
+			   (bad "ill-formed init-field clause" stx)]
+			  [(field idp ...)
+			   (for-each (lambda (idp)
+				       (syntax-case idp ()
+					 [(id expr) (identifier? (syntax id)) 'ok]
+					 [((iid eid) expr) (and (identifier? (syntax iid))
+								(identifier? (syntax eid)))
+					  'ok]
+					 [else
+					  (bad 
+					   "field element is not an optionally renamed identifier-expression pair"
+					   idp)]))
+				     (syntax->list (syntax (idp ...))))]
+			  [(field . rest)
+			   (bad "ill-formed field clause" stx)]
+			  [(private id ...)
+			   (for-each
+			    (lambda (id)
+			      (unless (identifier? id)
+				(bad "private element is not an identifier" id)))
+			    (syntax->list (syntax (id ...))))]
+			  [(private . rest)
+			   (bad "ill-formed private clause" stx)]
+			  [(form idp ...)
+			   (and (identifier? (syntax form))
+				(ormap (lambda (f) (module-identifier=? (syntax form) f))
+				       (syntax-e (quote-syntax (public
+								 override
+								 augride
+								 public-final
+								 override-final
+								 augment-final
+								 pubment
+								 overment
+								 augment
+								 inherit
+								 inherit-field)))))
+			   (let ([form (syntax-e (syntax form))])
+			     (for-each
+			      (lambda (idp)
+				(syntax-case idp ()
+				  [id (identifier? (syntax id)) 'ok]
+				  [(iid eid) (and (identifier? (syntax iid)) (identifier? (syntax eid))) 'ok]
+				  [else
+				   (bad 
+				    (format
+				     "~a element is not an identifier or pair of identifiers"
+				     form)
+				    idp)]))
+			      (syntax->list (syntax (idp ...)))))]
+			  [(public . rest)
+			   (bad "ill-formed public clause" stx)]
+			  [(override . rest)
+			   (bad "ill-formed override clause" stx)]
+			  [(augride . rest)
+			   (bad "ill-formed augride clause" stx)]
+			  [(public-final . rest)
+			   (bad "ill-formed public-final clause" stx)]
+			  [(override-final . rest)
+			   (bad "ill-formed override-final clause" stx)]
+			  [(augment-final . rest)
+			   (bad "ill-formed augment-final clause" stx)]
+			  [(pubment . rest)
+			   (bad "ill-formed pubment clause" stx)]
+			  [(overment . rest)
+			   (bad "ill-formed overment clause" stx)]
+			  [(augment . rest)
+			   (bad "ill-formed augment clause" stx)]
+			  [(inherit . rest)
+			   (bad "ill-formed inherit clause" stx)]
+			  [(inherit-field . rest)
+			   (bad "ill-formed inherit-field clause" stx)]
+			  [(kw idp ...)
+			   (and (identifier? #'kw)
+				(or (module-identifier=? #'rename-super #'kw)
+				    (module-identifier=? #'rename-inner #'kw)))
+			   (for-each 
+			    (lambda (idp)
+			      (syntax-case idp ()
+				[(iid eid) (and (identifier? (syntax iid)) (identifier? (syntax eid))) 'ok]
+				[else
+				 (bad 
+				  (format "~a element is not a pair of identifiers" (syntax-e #'kw))
+				  idp)]))
+			    (syntax->list (syntax (idp ...))))]
+			  [(rename-super . rest)
+			   (bad "ill-formed rename-super clause" stx)]
+			  [(rename-inner . rest)
+			   (bad "ill-formed rename-inner clause" stx)]
+			  [_ 'ok]))
+		      defn-and-exprs)
+	    
+	    ;; ----- Sort body into different categories -----
+	    (let*-values ([(decls exprs)
+			   (extract (syntax-e (quote-syntax (inherit-field
+							     private
+							     public
+							     override
+							     augride
+							     public-final
+							     override-final
+							     augment-final
+							     pubment
+							     overment
+							     augment
+							     rename-super
+							     inherit
+							     rename-inner)))
+				    defn-and-exprs
+				    cons)]
+			  [(inspect-decls exprs)
+			   (extract (list (quote-syntax inspect))
+				    exprs
+				    cons)]
+			  [(plain-inits)
+			   ;; Normalize after, but keep un-normal for error reporting
+			   (flatten #f (extract* (syntax-e 
+						  (quote-syntax (init init-rest)))
+						 exprs))]
+			  [(normal-plain-inits) (map normalize-init/field plain-inits)]
+			  [(init-rest-decls _)
+			   (extract (list (quote-syntax init-rest))
+				    exprs
+				    void)]
+			  [(inits)
+			   (flatten #f (extract* (syntax-e 
+						  (quote-syntax (init init-field)))
+						 exprs))]
+			  [(normal-inits)
+			   (map normalize-init/field inits)]
+			  [(plain-fields)
+			   (flatten #f (extract* (list (quote-syntax field)) exprs))]
+			  [(normal-plain-fields)
+			   (map normalize-init/field plain-fields)]
+			  [(plain-init-fields)
+			   (flatten #f (extract* (list (quote-syntax init-field)) exprs))]
+			  [(normal-plain-init-fields)
+			   (map normalize-init/field plain-init-fields)]
+			  [(inherit-fields)
+			   (flatten pair (extract* (list (quote-syntax inherit-field)) decls))]
+			  [(privates)
+			   (flatten pair (extract* (list (quote-syntax private)) decls))]
+			  [(publics)
+			   (flatten pair (extract* (list (quote-syntax public)) decls))]
+			  [(overrides)
+			   (flatten pair (extract* (list (quote-syntax override)) decls))]
+			  [(augrides)
+			   (flatten pair (extract* (list (quote-syntax augride)) decls))]
+			  [(public-finals)
+			   (flatten pair (extract* (list (quote-syntax public-final)) decls))]
+			  [(override-finals)
+			   (flatten pair (extract* (list (quote-syntax override-final)) decls))]
+			  [(pubments)
+			   (flatten pair (extract* (list (quote-syntax pubment)) decls))]
+			  [(overments)
+			   (flatten pair (extract* (list (quote-syntax overment)) decls))]
+			  [(augments)
+			   (flatten pair (extract* (list (quote-syntax augment)) decls))]
+			  [(augment-finals)
+			   (flatten pair (extract* (list (quote-syntax augment-final)) decls))]
+			  [(rename-supers)
+			   (flatten pair (extract* (list (quote-syntax rename-super)) decls))]
+			  [(inherits)
+			   (flatten pair (extract* (list (quote-syntax inherit)) decls))]
+			  [(rename-inners)
+			   (flatten pair (extract* (list (quote-syntax rename-inner)) decls))])
+	      
+	      ;; At most one inspect:
+	      (unless (or (null? inspect-decls)
+			  (null? (cdr inspect-decls)))
+		(bad "multiple inspect clauses" (cadr inspect-decls)))
+	      
+	      ;; At most one init-rest:
+	      (unless (or (null? init-rest-decls)
+			  (null? (cdr init-rest-decls)))
+		(bad "multiple init-rest clauses" (cadr init-rest-decls)))
+	      
+	      ;; Make sure init-rest is last
+	      (unless (null? init-rest-decls)
+		(let loop ([l exprs] [saw-rest? #f])
+		  (unless (null? l)
+		    (cond
+		     [(and (stx-pair? (car l))
+			   (identifier? (stx-car (car l))))
+		      (let ([form (stx-car (car l))])
+			(cond
+			 [(module-identifier=? #'init-rest form)
+			  (loop (cdr l) #t)]
+			 [(not saw-rest?) (loop (cdr l) #f)]
+			 [(module-identifier=? #'init form)
+			  (bad "init clause follows init-rest clause" (car l))]
+			 [(module-identifier=? #'init-field form)
+			  (bad "init-field clause follows init-rest clause" (car l))]
+			 [else (loop (cdr l) #t)]))]
+		     [else (loop (cdr l) saw-rest?)]))))
+	      
+	      ;; --- Check initialization on inits: ---
+	      (let loop ([inits inits] [normal-inits normal-inits])
+		(unless (null? normal-inits)
+		  (if (stx-null? (stx-cdr (car normal-inits)))
+		      (loop (cdr inits)(cdr normal-inits))
+		      (let loop ([inits (cdr inits)] [normal-inits (cdr normal-inits)])
+			(unless (null? inits)
+			  (if (stx-null? (stx-cdr (car normal-inits)))
+			      (bad "initializer without default follows an initializer with default"
+				   (car inits))
+			      (loop (cdr inits) (cdr normal-inits))))))))
+	      
+	      ;; ----- Extract method definitions; check that they look like procs -----
+	      ;;  Optionally transform them, can expand even if not transforming.
+	      (let* ([field-names (map norm-init/field-iid
+				       (append normal-plain-fields normal-plain-init-fields))]
+		     [inherit-field-names (map car inherit-fields)]
+		     [plain-init-names (map norm-init/field-iid normal-plain-inits)]
+		     [inherit-names (map car inherits)]
+		     [rename-super-names (map car rename-supers)]
+		     [rename-inner-names (map car rename-inners)]
+		     [local-public-dynamic-names (map car (append publics overrides augrides
+								  overments augments
+								  override-finals augment-finals))]
+		     [local-public-names (append (map car (append pubments public-finals))
+						 local-public-dynamic-names)]
+		     [local-method-names (append (map car privates) local-public-names)]
+		     [expand-stop-names (append
+					 local-method-names
+					 field-names
+					 inherit-field-names
+					 plain-init-names
+					 inherit-names
+					 rename-super-names
+					 rename-inner-names
+					 (kernel-form-identifier-list
+					  (quote-syntax here)))])
+		;; Do the extraction:
+		(let-values ([(methods          ; (listof (cons id stx))
+			       private-methods  ; (listof (cons id stx))
+			       exprs            ; (listof stx)
+			       stx-defines)     ; (listof (cons (listof id) stx))
+			      (let loop ([exprs exprs][ms null][pms null][es null][sd null])
+				(if (null? exprs)
+				    (values (reverse! ms) (reverse! pms) (reverse! es) (reverse! sd))
+				    (syntax-case (car exprs) (define-values define-syntaxes)
+				      [(define-values (id ...) expr)
+				       (let ([ids (syntax->list (syntax (id ...)))])
+					 ;; Check form:
+					 (for-each (lambda (id)
+						     (unless (identifier? id)
+						       (bad "not an identifier for definition" id)))
+						   ids)
+					 ;; method defn? (id in the list of privates/publics/overrides/augrides?)
+					 (if (ormap (lambda (id)
+						      (ormap (lambda (i) (bound-identifier=? i id))
+							     local-method-names))
+						    ids)
+					     ;; Yes, it's a method:
+					     (begin
+					       (unless (null? (cdr ids))
+						 (bad "each method variable needs its own definition"
+						      (car exprs)))
+					       (let ([expr (proc-shape #f (syntax expr) #f 
+								       the-obj the-finder
+								       bad class-name expand-stop-names)]
+						     [public? (ormap (lambda (i) 
+								       (bound-identifier=? i (car ids)))
+								     local-public-names)])
+						 (loop (cdr exprs) 
+						       (if public?
+							   (cons (cons (car ids) expr) ms)
+							   ms)
+						       (if public?
+							   pms
+							   (cons (cons (car ids) expr) pms))
+						       es
+						       sd)))
+					     ;; Non-method defn:
+					     (loop (cdr exprs) ms pms (cons (car exprs) es) sd)))]
+				      [(define-values . _)
+				       (bad "ill-formed definition" (car exprs))]
+				      [(define-syntaxes (id ...) expr)
+				       (let ([ids (syntax->list (syntax (id ...)))])
+					 (for-each (lambda (id) (unless (identifier? id)
+								  (bad "syntax name is not an identifier" id)))
+						   ids)
+					 (loop (cdr exprs) ms pms es (cons (cons ids (car exprs)) sd)))]
+				      [(define-syntaxes . _)
+				       (bad "ill-formed syntax definition" (car exprs))]
+				      [_else
+				       (loop (cdr exprs) ms pms (cons (car exprs) es) sd)])))])
+		  
+		  ;; ---- Extract all defined names, including field accessors and mutators ---
+		  (let ([defined-syntax-names (apply append (map car stx-defines))]
+			[defined-method-names (append (map car methods)
+						      (map car private-methods))]
+			[private-field-names (let loop ([l exprs])
+					       (if (null? l)
+						   null
+						   (syntax-case (car l) (define-values)
+						     [(define-values (id ...) expr)
+						      (append (syntax->list (syntax (id ...)))
+							      (loop (cdr l)))]
+						     [_else (loop (cdr l))])))]
+			[init-mode (cond
+				    [(null? init-rest-decls) 'normal]
+				    [(stx-null? (stx-cdr (car init-rest-decls))) 'stop]
+				    [else 'list])])
+		    
+		    ;; -- Look for duplicates --
+		    (let ([dup (check-duplicate-identifier
+				(append defined-syntax-names
+					defined-method-names
+					private-field-names
+					field-names
+					inherit-field-names
+					plain-init-names
+					inherit-names
+					rename-super-names
+					rename-inner-names))])
+		      (when dup
+			(bad "duplicate declared identifier" dup)))
+		    
+		    ;; -- Could still have duplicates within private/public/override/augride --
+		    (let ([dup (check-duplicate-identifier local-method-names)])
+		      (when dup
+			(bad "duplicate declared identifier" dup)))
+		    
+		    ;; -- Check for duplicate external method names, init names, or field names
+		    (let ([check-dup
+			   (lambda (what l)
+			     (let ([ht (make-hash-table)])
+			       (for-each (lambda (id)
+					   (when (hash-table-get ht (syntax-e id) (lambda () #f))
+					     (bad (format "duplicate declared external ~a name" what) id))
+					   (hash-table-put! ht (syntax-e id) #t))
+					 l)))])
+		      ;; method names
+		      (check-dup "method" (map cdr (append publics overrides augrides
+							   pubments overments augments
+							   public-finals override-finals augment-finals)))
+		      ;; inits
+		      (check-dup "init" (map norm-init/field-eid (append normal-inits)))
+		      ;; fields
+		      (check-dup "field" (map norm-init/field-eid (append normal-plain-fields normal-plain-init-fields))))
+		    
+		    ;; -- Check that private/public/override/augride are defined --
+		    (let ([ht (make-hash-table)]
+			  [stx-ht (make-hash-table)])
+		      (for-each
+		       (lambda (defined-name)
+			 (let ([l (hash-table-get ht (syntax-e defined-name) (lambda () null))])
+			   (hash-table-put! ht (syntax-e defined-name) (cons defined-name l))))
+		       defined-method-names)
+		      (for-each
+		       (lambda (defined-name)
+			 (let ([l (hash-table-get stx-ht (syntax-e defined-name) (lambda () null))])
+			   (hash-table-put! stx-ht (syntax-e defined-name) (cons defined-name l))))
+		       defined-syntax-names)
+		      (for-each
+		       (lambda (pubovr-name)
+			 (let ([l (hash-table-get ht (syntax-e pubovr-name) (lambda () null))])
+			   (unless (ormap (lambda (i) (bound-identifier=? i pubovr-name)) l)
+			     ;; Either undefined or defined as syntax:
+			     (let ([stx-l (hash-table-get stx-ht (syntax-e pubovr-name) (lambda () null))])
+			       (if (ormap (lambda (i) (bound-identifier=? i pubovr-name)) stx-l)
+				   (bad 
+				    "method declared but defined as syntax"
+				    pubovr-name)
+				   (bad 
+				    "method declared but not defined"
+				    pubovr-name))))))
+		       local-method-names))
+
+		    ;; ---- Check that rename-inner doesn't have a non-final decl ---
+		    (unless (null? rename-inners)
+		      (let ([ht (make-hash-table)])
+			(for-each (lambda (pub)
+				    (hash-table-put! ht (syntax-e (cdr pub)) #t))
+				  (append publics public-finals overrides override-finals augrides))
+			(for-each (lambda (inn)
+				    (when (hash-table-get ht (syntax-e (cdr inn)) (lambda () #f))
+				      (bad
+				       "inner method is locally declared as public, override, public-final, override-final, or augride"
+				       (cdr inn))))
+				  rename-inners)))
+		    
+		    ;; ---- Convert expressions ----
+		    ;;  Non-method definitions to set!
+		    ;;  Initializations args access/set!
+		    (let ([exprs (map (lambda (e)
+					(syntax-case e (define-values field init-rest)
+					  [(define-values (id ...) expr)
+					   (syntax/loc e (set!-values (id ...) expr))]
+					  [(-init idp ...)
+					   (and (identifier? (syntax -init))
+						(ormap (lambda (it) 
+							 (module-identifier=? it (syntax -init)))
+						       (syntax-e (quote-syntax (init
+										init-field)))))
+					   (let* ([norms (map normalize-init/field
+							      (syntax->list (syntax (idp ...))))]
+						  [iids (map norm-init/field-iid norms)]
+						  [exids (map norm-init/field-eid norms)])
+					     (with-syntax ([(id ...) iids]
+							   [(idpos ...) (map localize exids)]
+							   [(defval ...) 
+							    (map (lambda (norm)
+								   (if (stx-null? (stx-cdr norm))
+								       (syntax #f)
+								       (with-syntax ([defexp (stx-car (stx-cdr norm))])
+									 (syntax (lambda () defexp)))))
+								 norms)]
+							   [class-name class-name])
+					       (syntax/loc e 
+						 (begin 
+						   1 ; to ensure a non-empty body
+						   (set! id (extract-arg 'class-name `idpos init-args defval))
+						   ...))))]
+					  [(field idp ...)
+					   (with-syntax ([(((iid eid) expr) ...)
+							  (map normalize-init/field (syntax->list #'(idp ...)))])
+					     (syntax/loc e (begin 
+							     1 ; to ensure a non-empty body
+							     (set! iid expr)
+							     ...)))]
+					  [(init-rest id/rename)
+					   (with-syntax ([n (+ (length plain-inits)
+							       (length plain-init-fields)
+							       -1)]
+							 [id (if (identifier? #'id/rename)
+								 #'id/rename
+								 (stx-car #'id/rename))])
+					     (syntax/loc e (set! id (extract-rest-args n init-args))))]
+					  [(init-rest)
+					   (syntax (void))]
+					  [_else e]))
+				      exprs)]
+			  [mk-method-temp
+			   (lambda (id-stx)
+			     (datum->syntax-object (quote-syntax here)
+						   (gensym (syntax-e id-stx))))]
+			  [rename-super-extras (append overments overrides override-finals)]
+			  [rename-inner-extras (append pubments overments augments)]
+			  [all-rename-inners (append (map car rename-inners)
+						     (generate-temporaries (map car pubments))
+						     (generate-temporaries (map car overments))
+						     (generate-temporaries (map car augments)))])
+		      
+		      ;; ---- set up field and method mappings ----
+		      (with-syntax ([(rename-super-orig ...) (map car rename-supers)]
+				    [(rename-super-extra-orig ...) (map car rename-super-extras)]
+				    [(rename-super-temp ...) (generate-temporaries (map car rename-supers))]
+				    [(rename-super-extra-temp ...) (generate-temporaries (map car rename-super-extras))]
+				    [(rename-inner-orig ...) (map car rename-inners)]
+				    [(rename-inner-extra-orig ...) (map car rename-inner-extras)]
+				    [(rename-inner-temp ...) (generate-temporaries (map car rename-inners))]
+				    [(rename-inner-extra-temp ...) (generate-temporaries (map car rename-inner-extras))]
+				    [(private-name ...) (map car privates)]
+				    [(private-temp ...) (map mk-method-temp (map car privates))]
+				    [(pubment-name ...) (map car pubments)]
+				    [(pubment-temp ...) (map
+							 mk-method-temp
+							 (map car pubments))]
+				    [(public-final-name ...) (map car public-finals)]
+				    [(public-final-temp ...) (map
+							      mk-method-temp
+							      (map car public-finals))]
+				    [(method-name ...) (append local-public-dynamic-names
+							       (map car inherits))]
+				    [(method-accessor ...) (generate-temporaries
+							    (map car
+								 (append publics overrides augrides
+									 overments augments
+									 override-finals augment-finals
+									 inherits)))]
+				    [(inherit-field-accessor ...) (generate-temporaries
+								   (map (lambda (id)
+									  (format "get-~a"
+										  (syntax-e id)))
+									inherit-field-names))]
+				    [(inherit-field-mutator ...) (generate-temporaries
+								  (map (lambda (id)
+									 (format "set-~a!"
+										 (syntax-e id)))
+								       inherit-field-names))]
+				    [(inherit-field-name ...) inherit-field-names]
+				    [(local-field ...) (append field-names
+							       private-field-names)]
+				    [(local-field-pos ...) (let loop ([pos 0][l (append field-names
+											private-field-names)])
+							     (if (null? l)
+								 null
+								 (cons pos (loop (add1 pos) (cdr l)))))]
+				    [(plain-init-name ...) plain-init-names])
+			(let ([mappings
+			       ;; make-XXX-map is supplied by private/classidmap.ss
+			       (with-syntax ([the-obj the-obj]
+					     [the-finder the-finder]
+					     [this-id this-id])
+				 (syntax 
+				  ([(inherit-field-name ...
+							local-field ...
+							rename-super-orig ...
+							rename-inner-orig ...
+							method-name ...
+							private-name ...
+							public-final-name ...
+							pubment-name ...)
+				    (values
+				     (make-field-map (quote-syntax the-finder)
+						     (quote the-obj)
+						     (quote-syntax inherit-field-name)
+						     (quote-syntax inherit-field-accessor)
+						     (quote-syntax inherit-field-mutator)
+						     '())
+				     ...
+				     (make-field-map (quote-syntax the-finder)
+						     (quote the-obj)
+						     (quote-syntax local-field)
+						     (quote-syntax local-accessor)
+						     (quote-syntax local-mutator)
+						     '(local-field-pos))
+				     ...
+				     (make-rename-super-map (quote-syntax the-finder)
+							    (quote the-obj)
+							    (quote-syntax rename-super-orig)
+							    (quote-syntax rename-super-temp))
+				     ...
+				     (make-rename-inner-map (quote-syntax the-finder)
+							    (quote the-obj)
+							    (quote-syntax rename-inner-orig)
+							    (quote-syntax rename-inner-temp))
+				     ...
+				     (make-method-map (quote-syntax the-finder)
+						      (quote the-obj)
+						      (quote-syntax method-name)
+						      (quote-syntax method-accessor))
+				     ...
+				     (make-direct-method-map (quote-syntax the-finder)
+							     (quote the-obj)
+							     (quote-syntax private-name)
+							     (quote private-temp))
+				     ...
+				     (make-direct-method-map (quote-syntax the-finder)
+							     (quote the-obj)
+							     (quote-syntax public-final-name)
+							     (quote public-final-temp))
+				     ...
+				     (make-direct-method-map (quote-syntax the-finder)
+							     (quote the-obj)
+							     (quote-syntax pubment-name)
+							     (quote pubment-temp))
+				     ...)])))]
+			      [extra-init-mappings
+			       (with-syntax ([(init-error-map ...)
+					      (map (lambda (x)
+						     (syntax init-error-map))
+						   plain-inits)])
+				 (syntax 
+				  ([(plain-init-name ...)
+				    (values
+				     init-error-map
+				     ...)])))])
+			  
+			  (let ([find-method 
+				 (lambda (methods)
+				   (lambda (name)
+				     (ormap 
+				      (lambda (m)
+					(and (bound-identifier=? (car m) name)
+					     (with-syntax ([proc (proc-shape (car m) (cdr m) #t 
+									     the-obj the-finder
+									     bad class-name expand-stop-names)]
+							   [extra-init-mappings extra-init-mappings])
+					       (syntax
+						(syntax-parameterize 
+						 ([super-instantiate-param super-error-map]
+						  [super-make-object-param super-error-map]
+						  [super-new-param super-error-map])
+						 (letrec-syntaxes+values extra-init-mappings ()
+						   proc))))))
+				      methods)))]
+				[localize-cdr (lambda (p) (localize (cdr p)))])
+			    
+			    ;; ---- build final result ----
+			    (with-syntax ([public-names (map localize-cdr publics)]
+					  [public-final-names (map localize-cdr public-finals)]
+					  [override-names (map localize-cdr overrides)]
+					  [override-final-names (map localize-cdr override-finals)]
+					  [augride-names (map localize-cdr augrides)]
+					  [pubment-names (map localize-cdr pubments)]
+					  [overment-names (map localize-cdr overments)]
+					  [augment-names (map localize-cdr augments)]
+					  [augment-final-names (map localize-cdr augment-finals)]
+					  [(rename-super-name ...) (map localize-cdr rename-supers)]
+					  [(rename-super-extra-name ...) (map localize-cdr rename-super-extras)]
+					  [(rename-inner-name ...) (map localize-cdr rename-inners)]
+					  [(rename-inner-extra-name ...) (map localize-cdr rename-inner-extras)]
+					  [inherit-names (map localize-cdr inherits)]
+					  [num-fields (datum->syntax-object
+						       (quote-syntax here)
+						       (+ (length private-field-names)
+							  (length plain-init-fields)
+							  (length plain-fields)))]
+					  [field-names (map (lambda (norm)
+							      (localize (norm-init/field-eid norm)))
+							    (append
+							     normal-plain-fields
+							     normal-plain-init-fields))]
+					  [inherit-field-names (map localize (map cdr inherit-fields))]
+					  [init-names (map (lambda (norm)
+							     (localize
+							      (norm-init/field-eid norm)))
+							   normal-inits)]
+					  [init-mode init-mode]
+					  [(private-method ...) (map (find-method private-methods) (map car privates))]
+					  [public-methods (map (find-method methods) (map car publics))]
+					  [override-methods (map (find-method methods) (map car (append overments
+													override-finals
+													overrides)))]
+					  [augride-methods (map (find-method methods) (map car (append augments
+												       augment-finals
+												       augrides)))]
+					  [(pubment-method ...) (map (find-method methods) (map car pubments))]
+					  [(public-final-method ...) (map (find-method methods) (map car public-finals))]
+					  [mappings mappings]
+					  
+					  [exprs exprs]
+					  [the-obj the-obj]
+					  [the-finder the-finder]
+					  [name class-name]
+					  [(stx-def ...) (map cdr stx-defines)]
+					  [super-expression super-expr]
+					  [(interface-expression ...) interface-exprs]
+					  [inspector (if (pair? inspect-decls)
+							 (stx-car (stx-cdr (car inspect-decls)))
+							 #'(current-inspector))]
+					  [deserialize-id-expr deserialize-id-expr])
+			      
+			      (quasisyntax/loc stx
+				(let ([superclass super-expression]
+				      [interfaces (list interface-expression ...)])
+				  (compose-class 
+				   'name superclass interfaces inspector deserialize-id-expr
+				   ;; Field count:
+				   num-fields
+				   ;; Field names:
+				   `field-names
+				   `inherit-field-names
+				   ;; Method names:
+				   `(rename-super-name ... rename-super-extra-name ...)
+				   `(rename-inner-name ... rename-inner-extra-name ...)
+				   `pubment-names
+				   `public-final-names
+				   `public-names
+				   `overment-names
+				   `override-final-names
+				   `override-names
+				   `augment-names
+				   `augment-final-names
+				   `augride-names
+				   `inherit-names
+				   ;; Init arg names (in order)
+				   `init-names
+				   (quote init-mode)
+				   ;; Methods (when given needed super-methods, etc.):
+				   #, ;; Attach srcloc (useful for profiling)
+				   (quasisyntax/loc stx
+				     (lambda (local-accessor
+					      local-mutator
+					      inherit-field-accessor ...  ; inherit
+					      inherit-field-mutator ...
+					      rename-super-temp ... rename-super-extra-temp ...
+					      rename-inner-temp ... rename-inner-extra-temp ...
+					      method-accessor ...) ; for a local call that needs a dynamic lookup
+				       (syntax-parameterize
+					([this-param (make-this-map (quote-syntax this-id)
+								    (quote-syntax the-finder)
+								    (quote the-obj))])
+					(let-syntaxes 
+					 mappings
+					 (syntax-parameterize 
+					  ([super-param
+					    (lambda (stx)
+					      (syntax-case stx (rename-super-extra-orig ...)
+						[(_ rename-super-extra-orig . args) 
+						 (generate-super-call 
+						  stx
+						  (quote-syntax the-finder)
+						  (quote the-obj)
+						  (quote-syntax rename-super-extra-temp)
+						  (syntax args))]
+						...
+						[(_ id . args)
+						 (identifier? #'id)
+						 (raise-syntax-error
+						  #f
+						  (string-append
+						   "identifier for super call does not have an override, "
+						   "override-final, or overment declaration")
+						  stx
+						  #'id)]
+						[_else
+						 (raise-syntax-error
+						  #f
+						  "expected an identifier after the keyword"
+						  stx)]))]
+					   [inner-param
+					    (lambda (stx)
+					      (syntax-case stx (rename-inner-extra-orig ...)
+						[(_ default-expr rename-inner-extra-orig . args)
+						 (generate-inner-call 
+						  stx
+						  (quote-syntax the-finder)
+						  (quote the-obj)
+						  (syntax default-expr)
+						  (quote-syntax rename-inner-extra-temp)
+						  (syntax args))]
+						...
+						[(_ default-expr id . args)
+						 (identifier? #'id)
+						 (raise-syntax-error
+						  #f
+						  (string-append
+						   "identifier for inner call does not have a pubment, augment, "
+						   "or overment declaration")
+						  stx
+						  #'id)]
+						[(_)
+						 (raise-syntax-error
+						  #f
+						  "expected a default-value expression after the keyword"
+						  stx
+						  #'id)]
+						[_else
+						 (raise-syntax-error
+						  #f
+						  "expected an identifier after the keyword and default-value expression"
+						  stx)]))])
+					  stx-def ...
+					  (letrec ([private-temp private-method]
+						   ...
+						   [pubment-temp pubment-method]
+						   ...
+						   [public-final-temp public-final-method]
+						   ...)
+					    (values
+					     (list pubment-temp ... public-final-temp ... . public-methods)
+					     (list . override-methods)
+					     (list . augride-methods)
+					     ;; Initialization
+					     #, ;; Attach srcloc (useful for profiling)
+					     (quasisyntax/loc stx
+					       (lambda (the-obj super-go si_c si_inited? si_leftovers init-args)
+						 (let-syntax ([the-finder (quote-syntax the-obj)])
+						   (syntax-parameterize
+						    ([super-instantiate-param
+						      (lambda (stx)
+							(syntax-case stx () 
+							  [(_ (arg (... ...)) (kw kwarg) (... ...))
+							   (with-syntax ([stx stx])
+							     (syntax (-instantiate super-go stx (the-obj si_c si_inited? 
+													 si_leftovers)
+										   (list arg (... ...)) 
+										   (kw kwarg) (... ...))))]))]
+						     [super-new-param
+						      (lambda (stx)
+							(syntax-case stx () 
+							  [(_ (kw kwarg) (... ...))
+							   (with-syntax ([stx stx])
+							     (syntax (-instantiate super-go stx (the-obj si_c si_inited? 
+													 si_leftovers)
+										   null
+										   (kw kwarg) (... ...))))]))]
+						     [super-make-object-param
+						      (lambda (stx)
+							(let ([code 
+							       (quote-syntax
+								(lambda args
+								  (super-go the-obj si_c si_inited? si_leftovers args null)))])
+							  (if (identifier? stx)
+							      code
+							      (datum->syntax-object
+							       code
+							       (cons code
+								     (cdr (syntax-e stx)))))))])
+						    (let ([plain-init-name undefined]
+							  ...)
+						      (void) ; in case the body is empty
+						      . exprs))))))))))))
+				   ;; Not primitive:
+				   #f)))))))))))))))
+
+      ;; The class* and class entry points:
+      (values
+       ;; class*
+       (lambda (stx)
+	 (syntax-case stx ()
+	   [(_  super-expression (interface-expr ...)
+		defn-or-expr
+		...)
+	    (main stx 
+		  #'super-expression 
+		  #f #f
+		  (syntax->list #'(interface-expr ...))
+		  (syntax->list #'(defn-or-expr ...)))]))
+       ;; class
+       (lambda (stx)
+	 (syntax-case stx ()
+	   [(_ super-expression
+	       defn-or-expr
+	       ...)
+	    (main stx 
+		  #'super-expression 
+		  #f #f
+		  null
+		  (syntax->list #'(defn-or-expr ...)))]))
+       ;; class/derived
+       (lambda (stx)
+	 (syntax-case stx ()
+	   [(_  orig-stx
+		[name-id super-expression (interface-expr ...) deserialize-id-expr]
+		defn-or-expr
+		...)
+	    (main #'orig-stx 
+		  #'super-expression 
+		  #'deserialize-id-expr 
+		  (and (syntax-e #'name-id) #'name-id)
+		  (syntax->list #'(interface-expr ...))
+		  (syntax->list #'(defn-or-expr ...)))])))))
+
+  (define-syntax (-define-serializable-class stx)
+    (syntax-case stx ()
+      [(_ orig-stx name super-expression (interface-expr ...)
+	  defn-or-expr ...)
+       (let ([deserialize-name-info (datum->syntax-object
+				     #'name
+				     (string->symbol
+				      (format "deserialize-info:~a" (syntax-e #'name)))
+				     #'name)])
+	 (unless (memq (syntax-local-context) '(top-level module))
+	   (raise-syntax-error
+	    #f
+	    "allowed only at the top level or within a module top level"
+	    #'orig-stx))
+	 (with-syntax ([deserialize-name-info deserialize-name-info]
+		       [(provision ...) (if (eq? (syntax-local-context) 'module)
+					    #`((provide #,deserialize-name-info))
+					    #'())])
+	   #'(begin
+	       (define-values (name deserialize-name-info)
+		 (class/derived orig-stx [name
+					  super-expression 
+					  (interface-expr ...)
+					  #'deserialize-name-info]
+		   defn-or-expr ...))
+	       provision ...)))]))
+
+  (define-syntax (define-serializable-class* stx)
+    (syntax-case stx ()
+      [(_ name super-expression (interface-expr ...)
+	  defn-or-expr ...)
+       (with-syntax ([orig-stx stx])
+	 #'(-define-serializable-class orig-stx
+				       name
+				       super-expression
+				       (interface-expr ...)
+				       defn-or-expr ...))]))
+
+  (define-syntax (define-serializable-class stx)
+    (syntax-case stx ()
+      [(_ name super-expression
+	  defn-or-expr ...)
+       (with-syntax ([orig-stx stx])
+	 #'(-define-serializable-class orig-stx
+				       name
+				       super-expression
+				       ()
+				       defn-or-expr ...))]))
+  
+
+  (define-syntaxes (private* public* pubment* override* overment* augride* augment*
+			     public-final* override-final* augment-final*)
+    (let ([mk
+	   (lambda (who decl-form)
+	     (lambda (stx)
+	       (unless (class-top-level-context? (syntax-local-context))
+		 (raise-syntax-error
+		  #f
+		  "use of a class keyword is not in a class top-level"
+		  stx))
+	       (syntax-case stx ()
+		 [(_ binding ...)
+		  (let ([bindings (syntax->list (syntax (binding ...)))])
+		    (let ([name-exprs
+			   (map (lambda (binding)
+				  (syntax-case binding ()
+				    [(name expr)
+				     (identifier? (syntax name))
+				     (cons (syntax name) (syntax expr))]
+				    [_else
+				     (identifier? (syntax name))
+				     (raise-syntax-error
+				      #f
+				      "expected an identifier and expression"
+				      stx
+				      binding)]))
+				bindings)])
+		      (with-syntax ([(name ...) (map car name-exprs)]
+				    [(expr ...) (map cdr name-exprs)]
+				    [decl-form decl-form])
+			(syntax
+			 (begin
+			   (decl-form name ...)
+			   (define name expr)
+			   ...)))))])))])
+      (values
+       (mk 'private* (syntax private))
+       (mk 'public* (syntax public))
+       (mk 'pubment* (syntax pubment))
+       (mk 'override* (syntax override))
+       (mk 'overment* (syntax overment))
+       (mk 'augride* (syntax augride))
+       (mk 'augment* (syntax augment))
+       (mk 'public-final* (syntax public-final))
+       (mk 'override-final* (syntax override-final))
+       (mk 'augment-final* (syntax augment)))))
+
+  (define-syntaxes (define/private define/public define/pubment 
+		     define/override define/overment
+		     define/augride define/augment
+		     define/public-final define/override-final define/augment-final)
+    (let ([mk
+	   (lambda (decl-form)
+	     (lambda (stx)
+	       (unless (class-top-level-context? (syntax-local-context))
+		 (raise-syntax-error
+		  #f
+		  "use of a class keyword is not in a class top-level"
+		  stx))
+	       (let-values ([(id rhs) (normalize-definition stx #'lambda)])
+		 (quasisyntax/loc stx
+		   (begin
+		     (#,decl-form #,id)
+		     (define #,id #,rhs))))))])
+      (values
+       (mk #'private)
+       (mk #'public)
+       (mk #'pubment)
+       (mk #'override)
+       (mk #'overment)
+       (mk #'augride)
+       (mk #'augment)
+       (mk #'public-final)
+       (mk #'override-final)
+       (mk #'augment-final))))
+
+  (define-syntax (define-local-member-name stx)
+    (syntax-case stx ()
+      [(_ id ...)
+       (let ([ids (syntax->list (syntax (id ...)))])
+	 (for-each (lambda (id)
+		     (unless (identifier? id)
+		       (raise-syntax-error
+			#f
+			"expected an identifier"
+			stx
+			id)))
+		   ids)
+	 (let ([dup (check-duplicate-identifier ids)])
+	   (when dup
+	     (raise-syntax-error
+	      #f
+	      "duplicate identifier"
+	      stx
+	      dup)))
+	 (if (eq? (syntax-local-context) 'top-level)
+	     ;; Does nothing in particular at the top level:
+	     (syntax/loc stx (define-syntaxes (id ...) (values 'id ...)))
+	     ;; Map names to private indicators, which are made private
+	     ;;  simply by introduction:
+	     (with-syntax ([(gen-id ...) (generate-temporaries ids)])
+	       (with-syntax ([stx-defs
+			      ;; Need to attach srcloc to this definition:
+			      (syntax/loc stx
+				(define-syntaxes (id ...)
+				  (values (make-private-name (quote-syntax id) 
+							     ((syntax-local-certifier) (quote-syntax gen-id)))
+					  ...)))])
+		 (syntax/loc stx
+		   (begin
+		     (define-values (gen-id ...)
+		       (values (generate-local-member-name 'id) ...))
+		     stx-defs))))))]))
+
+  (define (generate-local-member-name id)
+    (string->uninterned-symbol
+     (symbol->string id)))
+
+  ;;--------------------------------------------------------------------
+  ;;  class implementation
+  ;;--------------------------------------------------------------------
+
+  (define-struct class (name
+			pos supers     ; pos is subclass depth, supers is vector
+			self-interface ; self interface
+			insp-mk        ; dummy struct maker to control inspection access
+
+			method-width   ; total number of methods
+			method-ht      ; maps public names to vector positions
+			method-ids     ; reverse-ordered list of public method names
+
+			methods        ; vector of methods
+			beta-methods   ; vector of vector of methods
+			meth-flags     ; vector: #f => primitive-implemented
+                                       ;         'final => final
+
+			field-width    ; total number of fields
+			field-ht       ; maps public field names to (cons class pos)
+			field-ids      ; list of public field names
+
+			struct:object  ; structure type for instances
+			object?        ; predicate
+			make-object    ; : (-> object), constructor that creates an uninitialized object
+			field-ref      ; accessor
+			field-set!     ; mutator
+
+			init-args      ; list of symbols in order; #f => only by position
+			init-mode      ; 'normal, 'stop (don't accept by-pos for super), or 'list
+
+                        init           ; initializer
+                                       ; :   object
+                                       ;     (object class (box boolean) leftover-args new-by-pos-args new-named-args 
+				       ;      -> void) // always continue-make-super?
+                                       ;     class
+                                       ;     (box boolean)
+                                       ;     leftover-args
+                                       ;     named-args
+                                       ;  -> void
+                        
+			serializer     ; proc => serializer, #f => not serializable
+			fixup          ; for deserialization
+
+			no-super-init?); #t => no super-init needed
+                    insp)
+  
+  ;; compose-class: produces one result if `deserialize-id' is #f, two
+  ;;                results if `deserialize-id' is not #f
+  (define (compose-class name                ; symbol
+			 super               ; class
+			 interfaces          ; list of interfaces
+			 inspector           ; inspector or #f
+			 deserialize-id      ; identifier or #f
+
+			 num-fields          ; total fields (public & private)
+			 public-field-names  ; list of symbols (shorter than num-fields)
+			 inherit-field-names ; list of symbols (not included in num-fields)
+			 
+			 rename-super-names  ; list of symbols
+			 rename-inner-names
+			 pubment-names
+			 public-final-names
+			 public-normal-names
+			 overment-names
+			 override-final-names
+			 override-normal-names
+			 augment-names
+			 augment-final-names
+			 augride-normal-names
+			 inherit-names
+
+			 init-args           ; list of symbols in order
+			 init-mode           ; 'normal, 'stop, or 'list
+			 
+			 make-methods        ; takes field and method accessors
+			 make-struct:prim)   ; see "primitive classes", below
+
+    ;; -- Check superclass --
+    (unless (class? super)
+      (obj-error 'class* "superclass expression returned a non-class: ~a~a" 
+		 super
+		 (for-class name)))
+    ;; -- Create new class's name --
+    (let* ([name (or name
+		     (let ([s (class-name super)])
+		       (and s 
+			    (not (eq? super object%))
+			    (if (symbol? s)
+				(format "derived-from-~a" s)
+				s))))]
+	   ;; Combine method lists
+	   [public-names (append pubment-names public-final-names public-normal-names)]
+	   [override-names (append overment-names override-final-names override-normal-names)]
+	   [augride-names (append augment-names augment-final-names augride-normal-names)]
+	   [final-names (append public-final-names override-final-names augment-final-names)]
+	   [augonly-names (append pubment-names overment-names augment-names)]
+	   ;; Mis utilities
+	   [no-new-methods? (null? public-names)]
+	   [no-method-changes? (and (null? public-names)
+				    (null? override-names)
+				    (null? augride-names))]
+	   [no-new-fields? (null? public-field-names)]
+	   [xappend (lambda (a b) (if (null? b) a (append a b)))])
+
+      ;; -- Check interfaces ---
+      (for-each
+       (lambda (intf)
+	 (unless (interface? intf)
+	   (obj-error 'class* "interface expression returned a non-interface: ~a~a" 
+		      intf
+		      (for-class name))))
+       interfaces)
+
+      ;; -- Check inspectors ---
+      (when inspector
+	(unless (inspector? inspector)
+	  (obj-error 'class* "inspect class result is not an inspector or #f: ~a~a" 
+		      inspector
+		      (for-class name))))
+
+      ;; -- Match method and field names to indices --
+      (let ([method-ht (if no-new-methods?
+			   (class-method-ht super)
+			   (make-hash-table))]
+	    [field-ht (if no-new-fields?
+			  (class-field-ht super)
+			  (make-hash-table))]
+	    [super-method-ht (class-method-ht super)]
+	    [super-method-ids (class-method-ids super)]
+	    [super-field-ids (class-field-ids super)]
+	    [super-field-ht (class-field-ht super)])
+
+	;; Put superclass ids in tables, with pos
+	(unless no-new-methods?
+	  (let loop ([ids super-method-ids][p (sub1 (class-method-width super))])
+	    (unless (null? ids)
+	      (hash-table-put! method-ht (car ids) p)
+	      (loop (cdr ids) (sub1 p)))))
+	(unless no-new-fields?
+	  (let loop ([ids super-field-ids])
+	    (unless (null? ids)
+	      (hash-table-put! field-ht (car ids) (hash-table-get super-field-ht (car ids)))
+	      (loop (cdr ids)))))
+
+	;; Put new ids in table, with pos (replace field pos with accessor info later)
+	(unless no-new-methods?
+	  (let loop ([ids public-names][p (class-method-width super)])
+	    (unless (null? ids)
+	      (when (hash-table-get method-ht (car ids) (lambda () #f))
+		(obj-error 'class* "superclass already contains method: ~a~a" 
+			   (car ids)
+			   (for-class name)))
+	      (hash-table-put! method-ht (car ids) p)
+	      (loop (cdr ids) (add1 p)))))
+	(unless no-new-fields?
+	  (let loop ([ids public-field-names][p (class-field-width super)])
+	    (unless (null? ids)
+	      (when (hash-table-get field-ht (car ids) (lambda () #f))
+		(obj-error 'class* "superclass already contains field: ~a~a" 
+			   (car ids)
+			   (for-class name)))
+	      (hash-table-put! field-ht (car ids) p)
+	      (loop (cdr ids) (add1 p)))))
+
+	;; Check that superclass has expected fields
+	(for-each (lambda (id)
+		    (unless (hash-table-get field-ht id (lambda () #f))
+		      (obj-error 'class* "superclass does not provide field: ~a~a" 
+				 id
+				 (for-class name))))
+		  inherit-field-names)
+
+	;; Check that superclass has expected methods, and get indices
+	(let ([get-indices
+	       (lambda (method-ht what ids)
+		 (map
+		  (lambda (id)
+		    (hash-table-get 
+		     method-ht id
+		     (lambda ()
+		       (obj-error 'class* 
+				  "~a does not provide an expected method for ~a: ~a~a" 
+				  (if (eq? method-ht super-method-ht) "superclass" "class")
+				  what
+				  id
+				  (for-class name)))))
+		  ids))]
+	      [method-width (+ (class-method-width super) (length public-names))]
+	      [field-width (+ (class-field-width super) num-fields)])
+	  (let ([inherit-indices (get-indices super-method-ht "inherit" inherit-names)]
+		[replace-augonly-indices (get-indices super-method-ht "overment" overment-names)]
+		[replace-final-indices (get-indices super-method-ht "override-final" override-final-names)]
+		[replace-normal-indices (get-indices super-method-ht "override" override-normal-names)]
+		[refine-augonly-indices (get-indices super-method-ht "augment" augment-names)]
+		[refine-final-indices (get-indices super-method-ht "augment-final" augment-final-names)]
+		[refine-normal-indices (get-indices super-method-ht "augride" augride-normal-names)]
+		[rename-super-indices (get-indices super-method-ht "rename-super" rename-super-names)]
+		[rename-inner-indices (get-indices method-ht "rename-inner" rename-inner-names)]
+		[new-augonly-indices (get-indices method-ht "pubment" pubment-names)]
+		[new-final-indices (get-indices method-ht "public-final" public-final-names)]
+		[new-normal-indices (get-indices method-ht "public" public-normal-names)])
+
+	    ;; -- Check that all interfaces are satisfied --
+	    (for-each
+	     (lambda (intf)
+	       (for-each
+		(lambda (var)
+		  (unless (hash-table-get method-ht var (lambda () #f))
+		    (obj-error 'class* 
+			       "interface-required method missing: ~a~a~a" 
+			       var
+			       (for-class name)
+			       (for-intf (interface-name intf)))))
+		(interface-public-ids intf)))
+	     interfaces)
+	    (let ([c (get-implement-requirement interfaces 'class* (for-class name))])
+	      (when (and c (not (subclass? super c)))
+		(obj-error 'class* 
+			   "interface-required implementation not satisfied~a~a"
+			   (for-class name)
+			   (let ([r (class-name c)])
+			     (if r
+				 (format " required class: ~a" r)
+				 "")))))
+
+	    ;; -- For serialization, check that the superclass is compatible --
+	    (when deserialize-id
+	      (unless (class-serializer super)
+		(obj-error 'class*
+			   "superclass is not serialiazable, not transparent, and does not implement externalizable<%>: ~e~a"
+			   super
+			   (for-class name))))
+
+	    ;; ---- Make the class and its interface ----
+	    (let* ([class-make (if name
+				   (make-naming-constructor 
+				    struct:class
+				    (string->symbol (format "class:~a" name)))
+				   make-class)]
+		   [interface-make (if name
+				       (make-naming-constructor 
+					struct:interface
+					(string->symbol (format "interface:~a" name)))
+				       make-interface)]
+		   [method-names (append (reverse public-names) super-method-ids)]
+		   [field-names (append public-field-names super-field-ids)]
+		   [super-interfaces (cons (class-self-interface super) interfaces)]
+		   [i (interface-make name super-interfaces #f method-names #f)]
+		   [methods (if no-method-changes?
+				(class-methods super)
+				(make-vector method-width))]
+		   [beta-methods (if no-method-changes?
+				     (class-beta-methods super)
+				     (make-vector method-width))]
+		   [meth-flags (if no-method-changes?
+				   (class-meth-flags super)
+				   (make-vector method-width))]
+		   [c (class-make name
+				  (add1 (class-pos super))
+				  (list->vector (append (vector->list (class-supers super)) (list #f)))
+				  i
+				  (let-values ([(struct: make- ? -ref -set) (make-struct-type 'insp #f 0 0 #f null inspector)])
+				    make-)
+				  method-width method-ht method-names
+				  methods beta-methods meth-flags
+				  field-width field-ht field-names
+				  'struct:object 'object? 'make-object 'field-ref 'field-set!
+				  init-args
+				  init-mode
+				  'init
+				  #f #f ; serializer is set later
+				  (and make-struct:prim #t))]
+		   [obj-name (if name
+				 (string->symbol (format "object:~a" name))
+				 'object)]
+		   ;; Used only for prim classes
+		   [preparer (lambda (name)
+			       ;; Map symbol to number:
+			       (hash-table-get method-ht name))]
+		   [dispatcher (lambda (obj n)
+				 ;; Extract method:
+				 (vector-ref (class-methods (object-ref obj)) n))])
+	      (setup-all-implemented! i)
+	      (vector-set! (class-supers c) (add1 (class-pos super)) c)
+
+	      ;; --- Make the new object struct ---
+	      (let*-values ([(prim-object-make prim-object? struct:prim-object)
+			     (if make-struct:prim
+				 (make-struct:prim c prop:object preparer dispatcher)
+				 (values #f #f #f))]
+			    [(struct:object object-make object? object-field-ref object-field-set!)
+			     (if make-struct:prim
+				 ;; Use prim struct:
+				 (values struct:prim-object prim-object-make prim-object? #f #f)
+				 ;; Normal struct creation:
+				 (make-struct-type obj-name
+						   (class-struct:object super)
+						   0 ;; No init fields
+						   ;; Fields for new slots:
+						   num-fields undefined
+						   ;; Map object property to class:
+						   (append
+						    (list (cons prop:object c))
+						    (if deserialize-id
+							(list
+							 (cons prop:serializable
+							       ;; Serialization:
+							       (make-serialize-info
+								(lambda (obj) 
+								  ((class-serializer c) obj))
+								deserialize-id
+								(and (not inspector)
+								     (not (interface-extension? i externalizable<%>))
+								     (eq? #t (class-serializer super)))
+								(or (current-load-relative-directory) 
+								    (current-directory)))))
+							null))
+						   inspector))])
+		(set-class-struct:object! c struct:object)
+		(set-class-object?! c object?)
+		(set-class-make-object! c object-make)
+		(unless (zero? num-fields)
+		  ;; We need these only if there are fields, used for for public-field
+		  ;; access or for inspection:
+		  (set-class-field-ref! c object-field-ref)
+		  (set-class-field-set!! c object-field-set!))
+
+		;; --- Build field accessors and mutators ---
+		;;  Use public field names to name the accessors and mutators
+		(let-values ([(inh-accessors inh-mutators)
+			      (values
+			       (map (lambda (id) (make-class-field-accessor super id))
+				    inherit-field-names)
+			       (map (lambda (id) (make-class-field-mutator super id))
+				    inherit-field-names))])
+		  ;; -- Reset field table to register accessor and mutator info --
+		  ;;  There are more accessors and mutators than public fields...
+		  (let loop ([ids public-field-names][pos 0])
+		    (unless (null? ids)
+		      (hash-table-put! field-ht (car ids) (cons c pos))
+		      (loop (cdr ids) (add1 pos))))
+
+		  ;; -- Extract superclass methods and make rename-inners ---
+		  (let ([rename-supers (map (lambda (index mname)
+					(let ([vec (vector-ref (class-beta-methods super) index)])
+					  (if (positive? (vector-length vec))
+					      (or (vector-ref vec (sub1 (vector-length vec)))
+						  (obj-error 'class* 
+							     (string-append
+							      "superclass method for override, overment, "
+							      "or rename-super is not overrideable: ~a~a")
+							     mname
+							     (for-class name)))
+					      (vector-ref (class-methods super) index))))
+				      rename-super-indices
+				      rename-super-names)]
+			[rename-inners (let ([new-augonly (make-vector method-width #f)])
+					 (define (get-depth index)
+					   (+ (if (index . < . (class-method-width super))
+						  (vector-length (vector-ref (class-beta-methods super) 
+									     index))
+						  0)
+					      (if (vector-ref new-augonly index) 0 -1)))
+					 ;; To compute `rename-inner' indices, we need to know which methods
+					 ;;  are augonly in this new class.
+					 (for-each (lambda (id)
+						     (vector-set! new-augonly (hash-table-get method-ht id) #t))
+						   (append pubment-names overment-names))
+					 (for-each (lambda (mname index)
+						     (let ([depth (get-depth index)])
+						       (when (negative? depth)
+							 (obj-error 'class* 
+								    (string-append
+								     "superclass method for augride, augment, "
+								     "or rename-inner method is not augmentable: ~a~a")
+								    mname
+								    (for-class name)))))
+						   (append augride-normal-names
+							   augment-final-names
+							   rename-inner-names)
+						   (append (get-indices method-ht "augride" augride-normal-names)
+							   refine-final-indices
+							   rename-inner-indices))
+					 ;; Now that checking is done, add `augment':
+					 (for-each (lambda (id)
+						     (vector-set! new-augonly (hash-table-get method-ht id) #t))
+						   augment-names)
+					 (map (lambda (mname index)
+						(let ([depth (get-depth index)])
+						  (lambda (obj default)
+						    (let* ([rename-inner (vector-ref (vector-ref (class-beta-methods (object-ref obj)) 
+												 index)
+										     depth)])
+						      (or rename-inner
+							  (lambda args default))))))
+					      rename-inner-names
+					      rename-inner-indices))])
+		    ;; -- Create method accessors --
+		    (let ([method-accessors (map (lambda (index)
+						   (lambda (obj)
+						     (vector-ref (class-methods (object-ref obj)) index)))
+						 (append new-normal-indices replace-normal-indices refine-normal-indices
+							 replace-augonly-indices refine-augonly-indices
+							 replace-final-indices refine-final-indices
+							 inherit-indices))])
+		      
+		      ;; -- Get new methods and initializers --
+		      (let-values ([(new-methods override-methods augride-methods init)
+				    (apply make-methods
+					   object-field-ref
+					   object-field-set!
+					   (append inh-accessors
+						   inh-mutators
+						   rename-supers
+						   rename-inners
+						   method-accessors))])
+			;; -- Fill in method tables --
+			;;  First copy old methods
+			(unless no-method-changes?
+			  (hash-table-for-each
+			   super-method-ht
+			   (lambda (name index)
+			     (vector-set! methods index (vector-ref (class-methods super) index))
+			     (vector-set! beta-methods index (vector-ref (class-beta-methods super) index))
+			     (vector-set! meth-flags index (vector-ref (class-meth-flags super) index)))))
+			;; Add new methods:
+			(for-each (lambda (index method)
+				    (vector-set! methods index method)
+				    (vector-set! beta-methods index (vector)))
+				  (append new-augonly-indices new-final-indices new-normal-indices)
+				  new-methods)
+			;; Override old methods:
+			(for-each (lambda (index method id)
+				    (when (eq? 'final (vector-ref meth-flags index))
+				      (obj-error 'class* 
+						 "cannot override or augment final method: ~a~a"
+						 id
+						 (for-class name)))
+				    (let ([v (vector-ref beta-methods index)])
+				      (if (zero? (vector-length v))
+					  ;; Normal mode - set vtable entry
+					  (vector-set! methods index method)
+					  ;; Under final mode - set extended vtable entry
+					  (let ([v (list->vector (vector->list v))])
+					    (vector-set! v (sub1 (vector-length v)) method)
+					    (vector-set! beta-methods index v))))
+				    (vector-set! meth-flags index (not make-struct:prim)))
+				  (append replace-augonly-indices replace-final-indices replace-normal-indices
+					  refine-augonly-indices refine-final-indices refine-normal-indices)
+				  (append override-methods augride-methods)
+				  (append override-names augride-names))
+			;; Expand `rename-inner' vector, adding a #f to indicate that
+			;;  no rename-inner function is available, so far
+			(for-each (lambda (id)
+				    (let ([index (hash-table-get method-ht id)])
+				      (let ([v (list->vector (append (vector->list (vector-ref beta-methods index))
+								     (list #f)))])
+					(vector-set! beta-methods index v))))
+				  augonly-names)
+			;; Mark final methods:
+			(for-each (lambda (id)
+				    (let ([index (hash-table-get method-ht id)])
+				      (vector-set! meth-flags index 'final)))
+				  final-names)
+			
+			;; --- Install serialize info into class --
+			(set-class-serializer!
+			 c
+			 (cond
+			  [(interface-extension? i externalizable<%>)
+			   (let ([index (car (get-indices method-ht "???" '(externalize)))])
+			     (lambda (obj)
+			       (vector ((vector-ref methods index) obj))))]
+			  [(and (or deserialize-id
+				    (not inspector))
+				(class-serializer super))
+			   => (lambda (ss)
+				(lambda (obj)
+				  (vector (cons (ss obj)
+						(let loop ([i 0])
+						  (if (= i num-fields)
+						      null
+						      (cons (object-field-ref obj i)
+							    (loop (add1 i)))))))))]
+			  [else #f]))
+
+			(set-class-fixup!
+			 c
+			 ;; Used only for non-externalizable:
+			 (lambda (o args)
+			   (if (pair? args)
+			       (begin
+				 ((class-fixup super) o (vector-ref (car args) 0))
+				 (let loop ([i 0][args (cdr args)])
+				   (unless (= i num-fields)
+				     (object-field-set! o i (car args))
+				     (loop (add1 i) (cdr args)))))
+			       (begin
+				 ((class-fixup super) o args)
+				 (let loop ([i 0])
+				   (unless (= i num-fields)
+				     (object-field-set! o i (object-field-ref args i))
+				     (loop (add1 i))))))))
+
+			;; --- Install initializer into class ---
+			(set-class-init! c init)
+				    
+			;; -- result is the class, and maybe deserialize-info ---
+			(if deserialize-id
+			    (values c (make-deserialize-info
+				       (if (interface-extension? i externalizable<%>)
+					   (lambda (args)
+					     (let ([o (make-object c)])
+					       (send o internalize args)
+					       o))
+					   (lambda (args)
+					     (let ([o (object-make)])
+					       ((class-fixup c) o args)
+					       o)))
+				       (if (interface-extension? i externalizable<%>)
+					   (lambda ()
+					     (error 'deserialize "cannot deserialize instance with cycles~a"
+						    (for-class name)))
+					   (lambda ()
+					     (let ([o (object-make)])
+					       (values o
+						       (lambda (o2)
+							 ((class-fixup c) o o2))))))))
+			    c))))))))))))
+
+  (define-values (prop:object object? object-ref) (make-struct-type-property 'object))
+
+  ;;--------------------------------------------------------------------
+  ;;  interfaces
+  ;;--------------------------------------------------------------------
+  
+  ;; >> Simplistic implementation for now <<
+
+  (define-syntax :interface
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ (interface-expr ...) var ...)
+	 (let ([vars (syntax->list (syntax (var ...)))]
+	       [name (syntax-local-infer-name stx)])
+	   (for-each
+	    (lambda (v)
+	      (unless (identifier? v)
+		(raise-syntax-error #f
+				    "not an identifier"
+				    stx
+				    v)))
+	    vars)
+	   (let ([dup (check-duplicate-identifier vars)])
+	     (when dup
+	       (raise-syntax-error #f
+				   "duplicate name"
+				   stx
+				   dup)))
+	   (with-syntax ([name (datum->syntax-object #f name #f)]
+			 [(var ...) (map localize vars)])
+	     (syntax/loc
+	      stx
+	      (compose-interface
+	       'name
+	       (list interface-expr ...)
+	       `(var ...)))))])))
+
+  (define-struct interface 
+                 (name            ; symbol
+                  supers          ; (listof interface)
+		  all-implemented ; hash-table: interface -> #t
+                  public-ids      ; (listof symbol) (in any order?!?)
+                  class)          ; (union #f class) -- means that anything implementing
+                                  ; this interface must be derived from this class
+                 insp)
+
+  (define (compose-interface name supers vars)
+    (for-each
+     (lambda (intf)
+       (unless (interface? intf)
+	 (obj-error 'interface 
+		    "superinterface expression returned a non-interface: ~a~a" 
+		    intf
+		    (for-intf name))))
+     supers)
+    (let ([ht (make-hash-table)])
+      (for-each
+       (lambda (var)
+	 (hash-table-put! ht var #t))
+       vars)
+      ;; Check that vars don't already exist in supers:
+      (for-each
+       (lambda (super)
+	 (for-each
+	  (lambda (var)
+	    (when (hash-table-get ht var (lambda () #f))
+	      (obj-error 'interface "variable already in superinterface: ~a~a~a" 
+			 var
+			 (for-intf name)
+			 (let ([r (interface-name super)])
+			   (if r
+			       (format " already in: ~a" r)
+			       "")))))
+	  (interface-public-ids super)))
+       supers)
+      ;; Check for [conflicting] implementation requirements
+      (let ([class (get-implement-requirement supers 'interface (for-intf name))]
+	    [interface-make (if name
+				(make-naming-constructor 
+				 struct:interface
+				 (string->symbol (format "interface:~a" name)))
+				make-interface)])
+	;; Add supervars to table:
+	(for-each
+	 (lambda (super)
+	   (for-each
+	    (lambda (var) (hash-table-put! ht var #t))
+	    (interface-public-ids super)))
+	 supers)
+	;; Done
+	(let ([i (interface-make name supers #f (hash-table-map ht (lambda (k v) k)) class)])
+	  (setup-all-implemented! i)
+	  i))))
+
+  ;; setup-all-implemented! : interface -> void
+  ;;  Creates the hash table for all implemented interfaces
+  (define (setup-all-implemented! i)
+    (let ([ht (make-hash-table)])
+      (hash-table-put! ht i #t)
+      (for-each (lambda (si)
+		  (hash-table-for-each
+		   (interface-all-implemented si)
+		   (lambda (k v)
+		     (hash-table-put! ht k #t))))
+		(interface-supers i))
+      (set-interface-all-implemented! i ht)))
+
+  (define (get-implement-requirement interfaces where for)
+    (let loop ([class #f]
+	       [supers interfaces])
+      (if (null? supers)
+	  class
+	  (let ([c (interface-class (car supers))])
+	    (loop
+	     (cond
+	      [(not c) class]
+	      [(not class) c]
+	      [(subclass? c class) class]
+	      [(subclass? class c) c]
+	      [else
+	       (obj-error 
+		where
+		"conflicting class implementation requirements in superinterfaces~a"
+		for)])
+	     (cdr supers))))))
+  
+  ;;--------------------------------------------------------------------
+  ;;  object%
+  ;;--------------------------------------------------------------------
+  
+  (define (make-naming-constructor type name)
+    (let-values ([(struct: make- ? -accessor -mutator)
+		  (make-struct-type name type 0 0 #f null insp)])
+      make-))
+  
+  (define object<%> ((make-naming-constructor struct:interface 'interface:object%)
+		     'object% null #f null #f))
+  (setup-all-implemented! object<%>)
+  (define object% ((make-naming-constructor struct:class 'class:object%)
+		   'object%
+		   0 (vector #f) 
+		   object<%>
+		   void ; never inspectable
+
+		   0 (make-hash-table) null
+		   (vector) (vector) (vector)
+		   
+		   0 (make-hash-table) null
+		   
+		   'struct:object object? 'make-object
+		   'field-ref-not-needed 'field-set!-not-needed
+
+		   null
+		   'normal
+
+		   (lambda (this super-init si_c si_inited? si_leftovers args) 
+		     (unless (null? args)
+		       (unused-args-error this args))
+		     (void))
+
+		   (lambda (obj) #(()))        ; serialize
+		   (lambda (obj args) (void))  ; deserialize-fixup
+
+		   #t)) ; no super-init
+
+  (vector-set! (class-supers object%) 0 object%)
+  (let*-values ([(struct:obj make-obj obj? -get -set!)
+                 (make-struct-type 'object #f 0 0 #f (list (cons prop:object object%)) #f)])
+    (set-class-struct:object! object% struct:obj)
+    (set-class-make-object! object% make-obj))
+  (set-class-object?! object% object?) ; don't use struct pred; it wouldn't work with prim classes
+
+  (set-interface-class! object<%> object%)
+
+  ;;--------------------------------------------------------------------
+  ;;  instantiation
+  ;;--------------------------------------------------------------------
+  
+  (define-syntax (new stx)
+    (syntax-case stx ()
+      [(_ cls (id arg) ...)
+       (andmap identifier? (syntax->list (syntax (id ...))))
+       (syntax/loc stx (instantiate cls () (id arg) ...))]
+      [(_ cls (id arg) ...)
+       (for-each (lambda (id)
+                   (unless (identifier? id)
+                     (raise-syntax-error 'new "expected identifier" stx id)))
+                 (syntax->list (syntax (id ...))))]
+      [(_ cls pr ...)
+       (for-each
+        (lambda (pr)
+          (syntax-case pr ()
+            [(x y) (void)]
+            [else (raise-syntax-error 'new "expected name and value binding" stx pr)]))
+        (syntax->list (syntax (pr ...))))]))
+  
+  (define make-object 
+    (lambda (class . args)
+      (do-make-object class args null)))
+  
+  (define-syntax instantiate
+    (lambda (stx)
+      (syntax-case stx ()
+	[(form class (arg ...) . x)
+	 (with-syntax ([orig-stx stx])
+	   (syntax/loc stx 
+             (-instantiate do-make-object orig-stx (class) (list arg ...) . x)))])))
+
+  ;; Helper; used by instantiate and super-instantiate
+  (define-syntax -instantiate
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ do-make-object orig-stx (maker-arg ...) args (kw arg) ...)
+	 (andmap identifier? (syntax->list (syntax (kw ...))))
+	 (with-syntax ([(kw ...) (map localize (syntax->list (syntax (kw ...))))])
+	   (syntax/loc stx
+	     (do-make-object maker-arg ...
+			     args
+			     (list (cons `kw arg)
+				   ...))))]
+	[(_ super-make-object orig-stx (make-arg ...) args kwarg ...)
+	 ;; some kwarg must be bad:
+	 (for-each (lambda (kwarg)
+		     (syntax-case kwarg ()
+		       [(kw arg)
+			(identifier? (syntax kw))
+			'ok]
+		       [(kw arg)
+			(raise-syntax-error
+			 #f
+			 "by-name argument does not start with an identifier"
+			 (syntax orig-stx)
+			 kwarg)]
+		       [_else
+			(raise-syntax-error
+			 #f
+			 "ill-formed by-name argument"
+			 (syntax orig-stx)
+			 kwarg)]))
+		   (syntax->list (syntax (kwarg ...))))])))
+
+  (define (do-make-object class by-pos-args named-args)
+    (unless (class? class)
+      (raise-type-error 'instantiate "class" class))
+    (let ([o ((class-make-object class))])
+      ;; Initialize it:
+      (continue-make-object o class by-pos-args named-args #t)
+      o))
+
+  (define (continue-make-object o c by-pos-args named-args explict-named-args?)
+    (let ([by-pos-only? (not (class-init-args c))])
+      ;; Primitive class with by-pos arguments?
+      (when by-pos-only?
+	(unless (null? named-args)
+	  (if explict-named-args?
+	      (obj-error 
+	       'instantiate
+	       "class has only by-position initializers, but given by-name arguments:~a~a" 
+	       (make-named-arg-string named-args)
+	       (for-class (class-name c)))
+	      ;; If args were implicit from subclass, should report as unused:
+	      (unused-args-error o named-args))))
+      ;; Merge by-pos into named args:
+      (let* ([named-args (if (not by-pos-only?)
+			     ;; Normal merge
+			     (do-merge by-pos-args (class-init-args c) c named-args by-pos-args c)
+			     ;; Non-merge for by-position initializers:
+			     by-pos-args)]
+	     [leftovers (if (not by-pos-only?)
+			    (get-leftovers named-args (class-init-args c))
+			    null)])
+	;; In 'list mode, make sure no by-name arguments are left over
+	(when (eq? 'list (class-init-mode c))
+	  (unless (or (null? leftovers)
+		      (not (ormap car leftovers)))
+	    (unused-args-error o (filter car leftovers))))
+	(unless (and (eq? c object%)
+		     (null? named-args))
+	  (let ([inited? (box (class-no-super-init? c))])
+	    ;; ----- Execute the class body -----
+	    ((class-init c)
+	     o 
+	     continue-make-super
+	     c inited? leftovers ; merely passed through to continue-make-super
+	     named-args)
+	    (unless (unbox inited?)
+	      (obj-error 'instantiate "superclass initialization not invoked by initialization~a"
+			 (for-class (class-name c)))))))))
+
+  (define (continue-make-super o c inited? leftovers by-pos-args new-named-args)
+    (when (unbox inited?)
+      (obj-error 'instantiate "superclass already initialized by class initialization~a"
+		 (for-class (class-name c))))
+    (set-box! inited? #t)
+    (let ([named-args (if (eq? 'list (class-init-mode c))
+			  ;; all old args must have been used up
+			  new-named-args
+			  ;; Normal mode: merge leftover keyword-based args with new ones
+			  (append
+			   new-named-args
+			   leftovers))])
+      (continue-make-object o
+			    (vector-ref (class-supers c) (sub1 (class-pos c))) 
+			    by-pos-args 
+			    named-args
+			    (pair? new-named-args))))
+
+  (define (do-merge al nl ic named-args by-pos-args c)
+    (cond
+     [(null? al) named-args]
+     [(null? nl)
+      ;; continue mapping with superclass init args, if allowed
+      (let ([super (and (eq? 'normal (class-init-mode ic))
+			(positive? (class-pos ic))
+			(vector-ref (class-supers ic) (sub1 (class-pos ic))))])
+	(cond
+	 [(and super (class-init-args super))
+	  (do-merge al (class-init-args super) super named-args by-pos-args c)]
+	 [(eq? 'list (class-init-mode ic))
+	  ;; All unconsumed named-args must have #f
+	  ;;  "name"s, otherwise an error is raised in
+	  ;;  the leftovers checking.
+	  (append (map (lambda (x) (cons #f x)) al)
+		  named-args)]
+	 [else
+	  (obj-error 'instantiate 
+		     "too many initialization arguments:~a~a" 
+		     (make-pos-arg-string by-pos-args)
+		     (for-class (class-name c)))]))]
+     [else (cons (cons (car nl) (car al))
+		 (do-merge (cdr al) (cdr nl) ic named-args by-pos-args c))]))
+
+  (define (get-leftovers l names)
+    (cond
+     [(null? l) null]
+     [(memq (caar l) names)
+      (get-leftovers (cdr l) (remq (caar l) names))]
+     [else (cons (car l) (get-leftovers (cdr l) names))]))
+
+  (define (extract-arg class-name name arguments default)
+    (if (symbol? name)
+	;; Normal mode
+	(let ([a (assq name arguments)])
+	  (cond
+	   [a (cdr a)]
+	   [default (default)]
+	   [else (missing-argument-error class-name name)]))
+	;; By-position mode
+	(cond
+	 [(< name (length arguments))
+	  (cdr (list-ref arguments name))]
+	 [default (default)]
+	 [else (obj-error 'instantiate "too few initialization arguments")])))
+
+  (define (extract-rest-args skip arguments)
+    (if (< skip (length arguments))
+	(map cdr (list-tail arguments skip))
+	null))
+
+  (define (make-pos-arg-string args)
+    (let ([len (length args)])
+      (apply string-append
+	     (map (lambda (a)
+		    (format " ~e" a))
+		  args))))
+
+  (define (make-named-arg-string args)
+    (let loop ([args args][count 0])
+      (cond
+       [(null? args) ""]
+       [(= count 3) " ..."]
+       [else (let ([rest (loop (cdr args) (add1 count))])
+	       (format " (~a ~e)~a"
+		       (caar args)
+		       (cdar args)
+		       rest))])))
+
+  (define (unused-args-error this args)
+    (let ([arg-string (make-named-arg-string args)])
+      (obj-error 'instantiate "unused initialization arguments:~a~a" 
+		 arg-string
+		 (for-class/which "instantiated" (class-name (object-ref this))))))
+
+  (define (missing-argument-error class-name name)
+    (obj-error 'instantiate "no argument for required init variable: ~a~a"
+	       name
+	       (if class-name (format " in class: ~a" class-name) "")))
+
+  ;;--------------------------------------------------------------------
+  ;;  methods and fields
+  ;;--------------------------------------------------------------------
+  
+  (define-syntaxes (send send/apply)
+    (let ([mk
+	   (lambda (flatten?)
+	     (lambda (stx)
+	       (syntax-case stx ()
+		 [(_ obj name . args)
+		  (begin
+		    (unless (identifier? (syntax name))
+		      (raise-syntax-error
+		       #f
+		       "method name is not an identifier"
+		       stx
+		       (syntax name)))
+		    (with-syntax ([name (localize (syntax name))])
+		      (if flatten?
+			  (if (stx-list? (syntax args))
+			      (syntax (let-values ([(mth unwrapped-this)
+						    (find-method/who 'send obj `name)])
+					(apply mth unwrapped-this . args)))
+			      (raise-syntax-error
+			       #f
+			       "bad syntax (illegal use of `.')"
+			       stx))
+			  (if (stx-list? (syntax args))
+			      (syntax/loc stx
+				(let-values ([(mth unwrapped-this)
+					      (find-method/who 'send obj `name)])
+				    (mth unwrapped-this . args)))
+			      (with-syntax ([args (flatten-args (syntax args))])
+				(syntax/loc stx
+				  (let-values ([(mth unwrapped-this)
+						(find-method/who 'send obj `name)])
+				    (apply mth unwrapped-this . args))))))))])))])
+      (values (mk #f) (mk #t))))
+  
+  (define-syntax send*
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ obj s ...)
+	 (with-syntax ([sends (map (lambda (s)
+				     (syntax-case s ()
+				       [(meth . args)
+					(syntax/loc s (send o meth . args))]
+				       [_else (raise-syntax-error
+					       #f
+					       "bad method call"
+					       stx
+					       s)]))
+				   (syntax->list (syntax (s ...))))])
+	   (syntax/loc stx
+	     (let ([o obj])
+	       . sends)))])))
+    
+  ;; find-method/who : symbol[top-level-form/proc-name]
+  ;;                   any[object] 
+  ;;                   symbol[method-name] 
+  ;;               -> (values method-proc object)
+  ;; returns the method's procedure and a function to unwrap `this' in the case
+  ;; that this is a wrapper object that is just "falling thru".
+  (define (find-method/who who in-object name)
+    (unless (object? in-object)
+      (obj-error who "target is not an object: ~e for method: ~a"
+		 in-object name))
+    
+    (let-syntax ([loop-body
+                  (lambda (stx)
+                    (syntax-case stx ()
+                      [(_ abs-object wrapper-case)
+                       (identifier? (syntax abs-object))
+                       (syntax
+                        (let* ([c (object-ref abs-object)]
+                               [pos (hash-table-get (class-method-ht c) name (lambda () #f))])
+                          (cond
+                            [pos (values (vector-ref (class-methods c) pos) abs-object)]
+                            [(wrapper-object? abs-object) wrapper-case]
+                            [else
+                             (obj-error who "no such method: ~a~a"
+                                        name
+                                        (for-class (class-name c)))])))]))])
+      (loop-body
+       in-object
+       (let loop ([loop-object in-object])
+         (loop-body
+          loop-object
+          (loop (wrapper-object-wrapped loop-object)))))))
+  
+
+  (define (class-field-X who which cwhich class name)
+    (unless (class? class)
+      (raise-type-error who "class" class))
+    (unless (symbol? name)
+      (raise-type-error who "symbol" name))
+    (let ([p (hash-table-get (class-field-ht class) name
+			     (lambda ()
+			       (obj-error who "no such field: ~a~a"
+					  name
+					  (for-class (class-name class)))))])
+      (which (cwhich (car p)) (cdr p))))
+  
+  (define (make-class-field-accessor class name)
+    (class-field-X 'class-field-accessor
+		   make-struct-field-accessor class-field-ref
+		   class name))
+  
+  (define (make-class-field-mutator class name)
+    (class-field-X 'class-field-mutator 
+		   make-struct-field-mutator class-field-set!
+		   class name))
+
+  (define-struct generic (applicable))
+
+  ;; Internally, make-generic comes from the struct def.
+  ;; Externally, make-generic is the following procedure.
+  ;; The extra `let' gives it the right name.
+  (define make-generic/proc
+    (let ([make-generic
+	   (lambda (class name)
+	     (unless (or (class? class) (interface? class))
+	       (raise-type-error 'make-generic "class or interface" class))
+	     (unless (symbol? name)
+	       (raise-type-error 'make-generic "symbol" name))
+	     (make-generic
+	      (if (interface? class)
+		  (let ([intf class])
+		    (unless (method-in-interface? name intf)
+		      (obj-error 'make-generic "no such method: ~a~a"
+				 name
+				 (for-intf (interface-name intf))))
+		    (lambda (obj)
+		      (unless (is-a? obj intf)
+			(raise-type-error 
+			 (string->symbol (format "generic:~a~a" name (for-intf (interface-name intf))))
+			 (format "instance~a" (for-intf (interface-name intf)))
+			 obj))
+		      (let-values ([(mth ths) (find-method/who 'make-generic obj name)])
+                        mth)))
+		  (let ([pos (hash-table-get (class-method-ht class) name
+					     (lambda ()
+					       (obj-error 'make-generic "no such method: ~a~a"
+							  name
+							  (for-class (class-name class)))))])
+		    (lambda (obj)
+		      (unless ((class-object? class) obj)
+			(raise-type-error 
+			 (string->symbol (format "generic:~a~a" name (for-class (class-name class))))
+			 (format "instance~a" (for-class (class-name class)))
+			 obj))
+		      (vector-ref (class-methods (object-ref obj)) pos))))))])
+      make-generic))
+
+  (define-syntax send-generic
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ obj generic . args)
+	 (if (stx-list? (syntax args))
+	     (with-syntax ([call (syntax/loc stx
+				   (((generic-applicable generic) this) this . args))])
+	       (syntax/loc stx (let ([this obj])
+				 call)))
+	     (with-syntax ([args (flatten-args (syntax args))])
+	       (with-syntax ([call (syntax/loc stx
+				     (apply ((generic-applicable generic) this) this . args))])
+		 (syntax (let ([this obj])
+			   call)))))])))
+  
+  (define-syntaxes (class-field-accessor class-field-mutator generic/form)
+    (let ([mk
+	   (lambda (make targets)
+	     (lambda (stx)
+	       (syntax-case stx ()
+		 [(_ class-expr name)
+		  (let ([name (syntax name)])
+		    (unless (identifier? name)
+		      (raise-syntax-error
+		       #f
+		       "expected an indentifier"
+		       stx
+		       name))
+		    (with-syntax ([name (localize name)]
+				  [make make])
+		      (syntax/loc stx (make class-expr `name))))]
+		 [(_ class-expr)
+		  (raise-syntax-error
+		   #f
+		   (format "expected a field name after the ~a expression"
+			   targets)
+		   stx)])))])
+      (values
+       (mk (quote-syntax make-class-field-accessor) "class")
+       (mk (quote-syntax make-class-field-mutator) "class")
+       (mk (quote-syntax make-generic/proc) "class or interface"))))
+
+  (define-syntax (get-field stx)
+    (syntax-case stx ()
+      [(_ name obj)
+       (identifier? (syntax name))
+       (with-syntax ([localized (localize (syntax name))])
+         (syntax (get-field/proc `localized obj)))]
+      [(_ name obj)
+       (raise-syntax-error 'get-field "expected a field name as first argument" stx (syntax name))]))
+  
+  (define (get-field/proc id obj)
+    (unless (object? obj)
+      (raise-mismatch-error 
+       'get-field
+       "expected an object, got "
+       obj))
+    (let loop ([obj obj])
+      (let* ([cls (object-ref obj)]
+             [field-ht (class-field-ht cls)]
+             [index (hash-table-get 
+                     field-ht
+                     id
+                     (lambda () #f))])
+        (cond
+          [index
+           ((class-field-ref (car index)) obj (cdr index))]
+          [(wrapper-object? obj)
+           (loop (wrapper-object-wrapped obj))]
+          [else
+           (raise-mismatch-error 
+            'get-field
+            (format "expected an object that has a field named ~s, got " id)
+            obj)]))))
+  
+  (define-syntax (field-bound? stx)
+    (syntax-case stx ()
+      [(_ name obj)
+       (identifier? (syntax name))
+       (with-syntax ([localized (localize (syntax name))])
+         (syntax (field-bound?/proc `localized obj)))]
+      [(_ name obj)
+       (raise-syntax-error 'field-bound? "expected a field name as first argument" stx (syntax name))]))
+  
+  (define (field-bound?/proc id obj)
+    (unless (object? obj)
+      (raise-mismatch-error 
+       'field-bound?
+       "expected an object, got "
+       obj))
+    (let loop ([obj obj])
+      (let* ([cls (object-ref obj)]
+             [field-ht (class-field-ht cls)])
+        (or (and (hash-table-get field-ht id (lambda () #f))
+                 #t) ;; ensure that only #t and #f leak out, not bindings in ht
+            (and (wrapper-object? obj)
+                 (loop (wrapper-object-wrapped obj)))))))
+  
+  (define (field-names obj)
+    (unless (object? obj)
+      (raise-mismatch-error 
+       'field-names
+       "expected an object, got "
+       obj))
+    (let loop ([obj obj])
+      (let* ([cls (object-ref obj)]
+             [field-ht (class-field-ht cls)]
+             [flds (filter interned? (hash-table-map field-ht (lambda (x y) x)))])
+        (if (wrapper-object? obj)
+            (append flds (loop (wrapper-object-wrapped obj)))
+            flds))))
+    
+  (define-syntax with-method
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ ([id (obj-expr name)] ...) body0 body1 ...)
+	 (let ([ids (syntax->list (syntax (id ...)))]
+	       [names (syntax->list (syntax (name ...)))])
+	   (for-each (lambda (id name)
+		       (unless (identifier? id)
+			 (raise-syntax-error #f
+					     "not an identifier for binding"
+					     stx
+					     id))
+		       (unless (identifier? name)
+			 (raise-syntax-error #f
+					     "not an identifier for method name"
+					     stx
+					     name)))
+		     ids names)
+	   (with-syntax ([(method ...) (generate-temporaries ids)]
+			 [(method-obj ...) (generate-temporaries ids)]
+			 [(name ...) (map localize names)])
+	     (syntax/loc stx (let-values ([(method method-obj)
+					   (let ([obj obj-expr])
+					     (find-method/who 'with-method obj `name))]
+					  ...)
+			       (letrec-syntaxes+values ([(id) (make-with-method-map
+							       (quote-syntax set!)
+							       (quote-syntax id)
+							       (quote-syntax method)
+							       (quote-syntax method-obj))]
+							...)
+				   ()
+				 body0 body1 ...)))))]
+	;; Error cases:
+	[(_ (clause ...) . body)
+	 (begin
+	   (for-each (lambda (clause)
+		       (syntax-case clause ()
+			 [(id (obj-expr name))
+			  (and (identifier? (syntax id))
+			       (identifier? (syntax name)))
+			  'ok]
+			 [_else
+			  (raise-syntax-error 
+			   #f
+			   "binding clause is not of the form (identifier (object-expr method-identifier))"
+			   stx
+			   clause)]))
+		     (syntax->list (syntax (clause ...))))
+	   ;; If we get here, the body must be bad
+	   (if (stx-null? (syntax body))
+	       (raise-syntax-error 
+		#f
+		"empty body"
+		stx)
+	       (raise-syntax-error 
+		#f
+		"bad syntax (illegal use of `.')"
+		stx)))]
+	[(_ x . rest)
+	 (raise-syntax-error 
+	  #f
+	  "not a binding sequence"
+	  stx
+	  (syntax x))])))
+  
+  ;;--------------------------------------------------------------------
+  ;;  class, interface, and object properties
+  ;;--------------------------------------------------------------------
+  
+  (define (is-a? v c)
+    (cond
+     [(class? c) ((class-object? c) (unwrap-object v))]
+     [(interface? c)
+      (and (object? v)
+	   (implementation? (object-ref (unwrap-object v)) c))]
+     [else (raise-type-error 'is-a? "class or interface" 1 v c)]))
+  
+  (define (subclass? v c)
+    (unless (class? c)
+      (raise-type-error 'subclass? "class" 1 v c))
+    (and (class? v)
+	 (let ([p (class-pos c)])
+	   (and (<= p (class-pos v))
+		(eq? c (vector-ref (class-supers v) p))))))
+
+  (define (object-interface o)
+    (unless (object? o)
+      (raise-type-error 'object-interface "object" o))
+    (class-self-interface (object-ref (unwrap-object o))))
+  
+  (define (implementation? v i)
+    (unless (interface? i)
+      (raise-type-error 'implementation? "interface" 1 v i))
+    (and (class? v)
+	 (interface-extension? (class-self-interface v) i)))
+
+  (define (interface-extension? v i)
+    (unless (interface? i)
+      (raise-type-error 'interface-extension? "interface" 1 v i))
+    (and (interface? i)
+	 (hash-table-get (interface-all-implemented v) i (lambda () #f))))
+  
+  (define (method-in-interface? s i)
+    (unless (symbol? s)
+      (raise-type-error 'method-in-interface? "symbol" 0 s i))
+    (unless (interface? i)
+      (raise-type-error 'method-in-interface? "interface" 1 s i))
+    (and (memq s (interface-public-ids i)) #t))
+
+  (define (class->interface c)
+    (unless (class? c)
+      (raise-type-error 'class->interface "class" c))
+    (class-self-interface c))
+  
+  (define (interned? sym)
+    (eq? sym (string->symbol (symbol->string sym))))
+
+  (define (interface->method-names i)
+    (unless (interface? i)
+      (raise-type-error 'interface->method-names "interface" i))
+    ;; copy list, and also filter private (interned) methods:
+    (apply list-immutable (filter interned? (interface-public-ids i))))
+
+  
+  (define (object-info o)
+    (unless (object? o)
+      (raise-type-error 'object-info "object" o))
+    (let loop ([c (object-ref (unwrap-object o))]
+               [skipped? #f])
+      (if (struct? ((class-insp-mk c)))
+	  ;; current inspector can inspect this object
+	  (values c skipped?)
+	  (if (zero? (class-pos c))
+	      (values #f #t)
+	      (loop (vector-ref (class-supers c) (sub1 (class-pos c))) #t)))))
+
+  (define (class-info c)
+    (unless (class? c)
+      (raise-type-error 'class-info "class" c))
+    (if (struct? ((class-insp-mk c)))
+	(let ([super (vector-ref (class-supers c) (sub1 (class-pos c)))])
+	  (let loop ([next super][skipped? #f])
+	    (if (or (not next)
+		    (struct? ((class-insp-mk next))))
+		(values (class-name c)
+			(- (class-field-width c) (class-field-width super))
+			(apply list-immutable (filter interned? (class-field-ids c)))
+			(class-field-ref c)
+			(class-field-set! c)
+			next
+			skipped?)
+		(if (zero? (class-pos next))
+		    (loop #f #t)
+		    (loop (vector-ref (class-supers next) (sub1 (class-pos next))) #t)))))
+	(raise-mismatch-error 'class-info "current inspector cannot inspect class: " c)))
+
+  (define object->vector
+    (opt-lambda (in-o [opaque-v '...])
+      (unless (object? in-o)
+	(raise-type-error 'object->vector "object" in-o))
+      (let ([o (unwrap-object in-o)])
+        (list->vector
+         (cons
+          (string->symbol (format "object:~a" (class-name (object-ref o))))
+          (reverse
+           (let-values ([(c skipped?) (object-info o)])
+             (let loop ([c c][skipped? skipped?])
+               (cond
+                 [(not c) (if skipped? (list opaque-v) null)]
+                 [else (let-values ([(name num-fields field-ids field-ref field-set next next-skipped?)
+                                     (class-info c)])
+                         (let ([rest (loop next next-skipped?)]
+                               [here (let loop ([n num-fields])
+                                       (if (zero? n)
+                                           null
+                                           (cons (field-ref o (sub1 n))
+                                                 (loop (sub1 n)))))])
+                           (append (if skipped? (list opaque-v) null)
+                                   here
+                                   rest)))])))))))))
+  
+  (define (object=? o1 o2)
+    (unless (object? o1)
+      (raise-type-error 'object=? "object" o1))
+    (unless (object? o2)
+      (raise-type-error 'object=? "object" o2))
+    (eq? (unwrap-object o1)
+         (unwrap-object o2)))
+    
+  ;;--------------------------------------------------------------------
+  ;;  primitive classes
+  ;;--------------------------------------------------------------------
+  
+  (define (make-primitive-class 
+	   make-struct:prim     ; see below
+	   prim-init            ; primitive initializer: takes obj and list of name-arg pairs
+	   name                 ; symbol
+	   super                ; superclass
+	   init-arg-names       ; #f or list of syms and sym--value lists
+	   override-names       ; overridden method names
+	   new-names            ; new (public) method names
+	   override-methods     ; list of methods
+	   new-methods)         ; list of methods
+
+    ; The `make-struct:prim' function takes prop:object, a
+    ;  class, a preparer, and a dispatcher function, and produces:
+    ;    * a struct constructor (must have prop:object)
+    ;    * a struct predicate
+    ;    * a struct type for derived classes (mustn't have prop:object)
+    ;
+    ; The supplied preparer takes a symbol and returns a num.
+    ; 
+    ; The supplied dispatcher takes an object and a num and returns a method.
+    ;
+    ; When a primitive class has a superclass, the struct:prim maker
+    ;  is responsible for ensuring that the returned struct items match
+    ;  the supertype predicate.
+
+    (compose-class name
+		   (or super object%)
+		   null
+		   #f
+		   #f
+		   
+		   0 null null ; no fields
+
+		   null ; no rename-supers
+		   null ; no rename-inners
+		   null null new-names
+		   null null override-names
+		   null null null ; no augrides
+		   null ; no inherits
+		   
+		   ; #f => init args by position only
+		   ; sym => required arg
+		   ; sym--value list => optional arg
+		   (and init-arg-names  
+			(map (lambda (s)
+			       (if (symbol? s) s (car s)))
+			     init-arg-names))
+		   'stop
+		   
+		   (lambda ignored
+		     (values
+		      new-methods
+		      override-methods
+		      null ; no augride-methods
+		      (lambda (this super-go/ignored si_c/ignored si_inited?/ignored si_leftovers/ignored init-args)
+			(apply prim-init this 
+			       (if init-arg-names
+				   (extract-primitive-args this name init-arg-names init-args)
+				   init-args)))))
+		   
+		   make-struct:prim))
+
+  (define (extract-primitive-args this class-name init-arg-names init-args)
+    (let loop ([names init-arg-names][args init-args])
+      (cond
+       [(null? names)
+	(unless (null? args)
+	  (unused-args-error this args))
+	null]
+       [else (let* ([name (car names)]
+		    [id (if (symbol? name)
+			    name
+			    (car name))])
+	       (let ([arg (assq id args)])
+		 (cond
+		  [arg 
+		   (cons (cdr arg) (loop (cdr names) (remq arg args)))]
+		  [(symbol? name)
+		   (missing-argument-error class-name name)]
+		  [else
+		   (cons (cadr name) (loop (cdr names) args))])))])))
+
+  ;;--------------------------------------------------------------------
+  ;;  wrapper for contracts
+  ;;--------------------------------------------------------------------
+
+  (define-struct wrapper-field (name ctc-stx))
+  (define-struct wrapper-method (name mth-stx))
+
+  (define-values (wrapper-object? wrapper-object-wrapped set-wrapper-object-wrapped! struct:wrapper-object)
+    (let-values ([(struct:wrapper-object make-wrapper-object wrapper-object? ref set!)
+                  (make-struct-type 'raw-wrapper-object
+                                    #f
+                                    0
+                                    1)])
+      (values wrapper-object?
+              (lambda (v) (ref v 0))
+              (lambda (o v) (set! o 0 v))
+              struct:wrapper-object)))
+  
+  ;; unwrap-object : (union wrapper-object object) -> object
+  (define (unwrap-object o)
+    (let loop ([o o])
+      (if (wrapper-object? o)
+          (loop (wrapper-object-wrapped o))
+          o)))
+  
+  ;; make-wrapper-class :   symbol
+  ;;                        (listof symbol)
+  ;;                        (listof (selector -> method-func-spec[object args -> result]))
+  ;;                        (listof symbol)
+  ;;                     -> class
+  ;; the resulting class is the "proxy" class for the contracted version of an
+  ;; object with contracts on the method-ids. 
+  
+  ;; Overall, objects of this class have one field for the original object,
+  ;; one field per method in the contract and one field per field in the contract.
+  ;; Each of the methods (passed in) just accesses the initial (method) fields
+  ;; (which contain procedures) and calls them and returns their results.
+  ;; Those fields do not show up from outside of this file, via the usual
+  ;; field accessors. In addition, the class has one field per field that
+  ;; will contain the contracted versions of the input fields.
+  ;; The class accepts one initialization argument per method and
+  ;; one init arg per field (in that order) using the make-object style
+  ;; initialization.
+  (define (make-wrapper-class class-name method-ids methods field-ids)
+    (let* ([supers (vector object% #f)]
+           [method-ht (make-hash-table)]
+           [method-count (length method-ids)]
+           [methods-vec (make-vector method-count #f)]
+           
+           [field-ht (make-hash-table)]
+           [field-count (length field-ids)]
+           
+           [cls
+            (make-class class-name
+                        1
+                        supers
+                        'bogus-self-interface
+                        void  ; nothing can be inspected
+			
+                        method-count
+                        method-ht
+                        (reverse method-ids)
+                        
+                        methods-vec
+                        (list->vector (map (lambda (x) 'final) method-ids))
+			'dont-use-me!
+                        
+                        (+ 1 field-count method-count)
+                        field-ht
+                        field-ids
+                        
+                        #f; struct:object
+                        #f; object?
+                        #f; make-object ;; -> void
+                        #f; field-ref
+                        #f; field-set!
+                        
+                        #f ;; only by position arguments
+                        'normal ; init-mode - ??
+                        
+                        #f ; init
+			#f #f ; not serializable
+                        #f)])
+      (let-values ([(struct:object make-object object? field-ref field-set!)
+                    (make-struct-type 'wrapper-object
+                                      struct:wrapper-object
+                                      0
+                                      (+ (length field-ids) (length method-ids))
+                                      undefined
+                                      (list (cons prop:object cls))
+                                      insp)])
+        (set-class-struct:object! cls struct:object)
+        (set-class-object?! cls object?)
+        (set-class-make-object! cls make-object)
+        (set-class-field-ref! cls field-ref)
+        (set-class-field-set!! cls field-set!)
+
+        (let ([init
+               (lambda (o continue-make-super c inited? named-args leftover-args)
+                 ;; leftover args will contain:
+                 ;; the original object,
+                 ;; all of the contract-ized versions of the methods,
+                 ;; and all of the contract-ized versions of the fields
+                 ;; just fill them into `o'.
+                 (set-wrapper-object-wrapped! o (car leftover-args))
+                 (let loop ([leftover-args (cdr leftover-args)]
+                            [i 0])
+                   (unless (null? leftover-args)
+                     (field-set! o i (car leftover-args))
+                     (loop (cdr leftover-args)
+                           (+ i 1))))
+                 (continue-make-super o c inited? '() '() '()))])
+          (set-class-init! cls init))
+        
+        ;; fill in the methods vector
+        (let loop ([i 0]
+                   [methods methods])
+          (when (< i method-count)
+            (vector-set! methods-vec i ((car methods) field-ref))
+            (loop (+ i 1)
+                  (cdr methods))))
+        
+        ;; fill in the methods-ht
+        (let loop ([i 0]
+                   [method-ids method-ids])
+          (when (< i method-count)
+            (hash-table-put! method-ht (car method-ids) i)
+            (loop (+ i 1)
+                  (cdr method-ids))))
+        
+        ;; fill in the fields-ht
+        (let loop ([i 0]
+                   [field-ids field-ids])
+          (when (< i field-count)
+            (hash-table-put! field-ht (car field-ids) (cons cls (+ i method-count)))
+            (loop (+ i 1)
+                  (cdr field-ids))))
+        
+        ;; fill in the supers vector
+        (vector-set! supers 1 cls)
+        
+        cls)))
+  
+  ; extract-vtable : object -> (vectorof method-proc[this args ... -> res])
+  (define (extract-vtable o) (class-methods (object-ref o)))
+
+  ; extract-method-ht : object -> hash-table[sym -> number]
+  (define (extract-method-ht o) (class-method-ht (object-ref o)))
+
+  ;;--------------------------------------------------------------------
+  ;;  misc utils
+  ;;--------------------------------------------------------------------
+  
+  (define undefined (letrec ([x x]) x))
+  
+  (define-struct (exn:fail:object exn:fail) () insp)
+
+  (define (obj-error where . msg)
+    (raise
+     (make-exn:fail:object
+      (string->immutable-string
+       (string-append
+	(format "~a: " where)
+	(apply format msg)))
+      (current-continuation-marks))))
+
+  (define (for-class name)
+    (if name (format " for class: ~a" name) ""))
+  (define (for-class/which which name)
+    (if name (format " for ~a class: ~a" which name) ""))
+  (define (for-intf name)
+    (if name (format " for interface: ~a" name) ""))
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;
+  ;; mixin
+  ;;
+  
+  (define-syntax (mixin stx)
+    (syntax-case stx ()
+      [(_ (from ...) (to ...) clauses ...)
+       (let ([extract-renamed-names
+              (λ (x)
+                (map (λ (x) (syntax-case x ()
+                              [(internal-name external-name) (syntax external-name)]
+                              [else x]))
+                     (syntax->list x)))])
+         (define (get-super-names stx)
+           (syntax-case stx (inherit rename 
+                                     override overment override-final
+                                     define/override define/overment define/override-final
+                                     augment augride augment-final
+                                     define/augment define/augride define/augment-final)
+             [(inherit names ...) (extract-renamed-names (syntax (names ...)))]
+             [(rename [x names] ...) (syntax->list (syntax (names ...)))]
+             [(override names ...) (extract-renamed-names (syntax (names ...)))]
+             [(overment names ...) (extract-renamed-names (syntax (names ...)))]
+             [(override-final names ...) (extract-renamed-names (syntax (names ...)))]
+             [(augment names ...) (extract-renamed-names (syntax (names ...)))]
+             [(augride names ...) (extract-renamed-names (syntax (names ...)))]
+             [(augment-final names ...) (extract-renamed-names (syntax (names ...)))]
+             
+             [(define/augment (name . names) . rest) (extract-renamed-names (syntax (name)))]
+             [(define/augment name . rest) (identifier? (syntax name)) (extract-renamed-names (syntax (name)))]
+             [(define/augride (name . names) . rest) (extract-renamed-names (syntax (name)))]
+             [(define/augride name . rest) (identifier? (syntax name)) (extract-renamed-names (syntax (name)))]
+             [(define/augment-final (name . names) . rest) (extract-renamed-names (syntax (name)))]
+             [(define/augment-final name . rest) (identifier? (syntax name)) (extract-renamed-names (syntax (name)))]
+             [(define/override (name . names) . rest) (extract-renamed-names (syntax (name)))]
+             [(define/override name . rest) (identifier? (syntax name)) (extract-renamed-names (syntax (name)))]
+             [(define/overment (name . names) . rest) (extract-renamed-names (syntax (name)))]
+             [(define/overment name . rest) (identifier? (syntax name)) (extract-renamed-names (syntax (name)))]
+             [(define/override-final (name . names) . rest) (extract-renamed-names (syntax (name)))]
+             [(define/override-final name . rest) (identifier? (syntax name)) (extract-renamed-names (syntax (name)))]
+             [else null]))
+         (with-syntax ([(from-ids ...) (generate-temporaries (syntax (from ...)))]
+                       [(to-ids ...) (generate-temporaries (syntax (to ...)))]
+                       [(super-vars ...)
+                        (apply
+                         append
+                         (map get-super-names
+                              (syntax->list (syntax (clauses ...)))))]
+                       [mixin-name (or (with-syntax ([tmp (syntax-local-name)])
+                                         (syntax (quote tmp)))
+                                       (syntax (quote mixin)))])
+           
+           ;; Build the class expression first, to give it a good src location:
+           (with-syntax ([class-expr
+                          (syntax/loc stx
+                            (class* super% (to-ids ...)
+                              clauses ...))])
+             
+             ;; Now build mixin proc, again to give it a good src location:
+             (with-syntax ([mixin-expr
+                            (syntax/loc stx
+                              (λ (super%)
+                                (unless (class? super%)
+                                  (error mixin-name "argument ~a not a class" super%))
+                                (unless (implementation? super% from-ids)
+                                  (error mixin-name "argument ~s does not implement ~s" super% from-ids))
+                                ...
+                                class-expr))])
+               
+               ;; Finally, build the complete mixin expression:
+               (syntax/loc stx
+                 (let ([from-ids from] ...)
+                   (let ([to-ids to] ...)
+                     
+                     (let ([all-from (list from-ids ...)])
+                       (void)
+                       (unless (interface? from-ids)
+                         (error 'mixin
+                                "expected interfaces for from, got: ~e, others ~e"
+                                from-ids
+                                all-from)) ...)
+                     
+                     (let ([all-to (list to-ids ...)])
+                       (void)
+                       (unless (interface? to-ids)
+                         (error 'mixin
+                                "expected interfaces for to, got: ~e, others ~e"
+                                to-ids
+                                all-to)) ...)
+                     
+                     (let ([ensure-interface-has?
+                            (λ (x)
+                              (unless (or (method-in-interface? x from-ids) ...)
+                                (error 'mixin
+                                       "method `~a' not in any of ~a, but was referenced in definition"
+                                       x (list from-ids ...))))])
+                       (void)
+                       (ensure-interface-has? (quote super-vars)) ...)
+                     
+                     mixin-expr)))))))]))
+
+  (define externalizable<%>
+    (:interface () externalize internalize))
+  
+  (provide (protect make-wrapper-class
+		    wrapper-object-wrapped
+		    extract-vtable
+		    extract-method-ht)
+           
+           (rename :class class) class* class/derived
+           define-serializable-class define-serializable-class*
+           class?
+           mixin
+	   (rename :interface interface) interface?
+	   object% object? object=? externalizable<%>
+           new make-object instantiate
+           get-field field-bound? field-names
+	   send send/apply send* class-field-accessor class-field-mutator with-method
+	   private* public*  pubment*
+	   override* overment*
+	   augride* augment*
+	   public-final* override-final* augment-final*
+	   define/private define/public define/pubment 
+	   define/override define/overment
+	   define/augride define/augment
+	   define/public-final define/override-final define/augment-final
+	   define-local-member-name
+	   (rename generic/form generic) (rename make-generic/proc make-generic) send-generic
+	   is-a? subclass? implementation? interface-extension?
+	   object-interface object-info object->vector
+	   method-in-interface? interface->method-names class->interface class-info
+	   (struct exn:fail:object ())
+	   make-primitive-class))
+
diff --git a/collects/mzlib/private/classidmap.ss b/collects/mzlib/private/classidmap.ss
new file mode 100644
index 0000000000..cf1e50c27b
--- /dev/null
+++ b/collects/mzlib/private/classidmap.ss
@@ -0,0 +1,297 @@
+
+(module classidmap mzscheme
+
+  (require (lib "stx.ss" "syntax"))
+
+  (define-values (struct:s!t make-s!t s!t? s!t-ref s!t-set!)
+    (make-struct-type 'set!-transformer #f 2 0 #f null (current-inspector) 0))
+  
+  (define (mk-set!-trans old-id proc)
+    (make-set!-transformer (make-s!t proc old-id)))
+
+  (define (make-method-apply id this orig-args)
+    (let loop ([args orig-args][accum null])
+      (cond
+       [(stx-null? args)
+	(list* id this orig-args)]
+       [(stx-pair? args)
+	(loop (stx-cdr args) (cons (stx-car args) accum))]
+       [else
+	(list* 'apply id this (reverse (cons args accum)))])))
+
+  (define (find the-finder name src)
+    (let ([this-id (syntax-local-value (syntax-local-get-shadower the-finder))])
+      (datum->syntax-object this-id name src)))
+
+  ;; Check Syntax binding info:
+  (define (binding from to stx)
+    stx
+    ;; This 'bound-in-source is no longer needed
+    #;
+    (syntax-property
+     stx
+     'bound-in-source
+     (cons from (syntax-local-introduce to))))
+
+
+  (define (make-this-map orig-id the-finder the-obj)
+    (let ([set!-stx (datum->syntax-object the-finder 'set!)])
+      (mk-set!-trans
+       orig-id
+       (lambda (stx)
+	 (syntax-case stx ()
+	   [(set! id expr)
+	    (module-identifier=? (syntax set!) set!-stx)
+	    (raise-syntax-error 'class "cannot mutate object identifier" stx)]
+	   [(id . args)
+	    (datum->syntax-object 
+	     stx
+	     (cons (find the-finder the-obj stx) (syntax args))
+	     stx)]
+	   [id (find the-finder the-obj stx)])))))
+
+  (define (make-field-map the-finder the-obj the-binder field-accessor field-mutator field-pos/null)
+    (let ([set!-stx (datum->syntax-object the-finder 'set!)])
+      (mk-set!-trans
+       the-binder
+       (lambda (stx)
+	 (syntax-case stx ()
+	   [(set! id expr)
+	    (module-identifier=? (syntax set!) set!-stx)
+	    (binding
+	     the-binder (syntax id)
+	     (datum->syntax-object 
+	      the-finder
+	      (list* field-mutator (find the-finder the-obj stx) (append field-pos/null (list (syntax expr))))
+	      stx))]
+	   [(id . args)
+	    (binding
+	     the-binder (syntax id)
+	     (datum->syntax-object 
+	      the-finder
+	      (cons (list* field-accessor (find the-finder the-obj stx) field-pos/null) (syntax args))
+	      stx))]
+	   [_else
+	    (binding
+	     the-binder stx
+	     (datum->syntax-object 
+	      the-finder
+	      (list* field-accessor (find the-finder the-obj stx) field-pos/null)
+	      stx))])))))
+
+  (define (make-method-map the-finder the-obj the-binder method-accessor)
+    (let ([set!-stx (datum->syntax-object the-finder 'set!)])
+      (mk-set!-trans
+       the-binder
+       (lambda (stx)
+	 (syntax-case stx ()
+	   [(set! id expr)
+	    (module-identifier=? (syntax set!) set!-stx)
+	    (raise-syntax-error 'class "cannot mutate method" stx)]
+	   [(id . args)
+	    (binding
+	     the-binder (syntax id)
+	     (datum->syntax-object 
+	      the-finder
+	      (make-method-apply
+	       (list method-accessor (find the-finder the-obj stx))
+	       (find the-finder the-obj stx)
+	       (syntax args))
+	      stx))]
+	   [_else
+	    (raise-syntax-error 
+	     'class 
+	     "misuse of method (not in application)" 
+	     stx)])))))
+
+  ;; For methods that are dirrectly available via their names
+  ;;  (e.g., private methods)
+  (define (make-direct-method-map the-finder the-obj the-binder new-name)
+    (let ([set!-stx (datum->syntax-object the-finder 'set!)])
+      (mk-set!-trans
+       the-binder
+       (lambda (stx)
+	 (syntax-case stx ()
+	   [(set! id expr)
+	    (module-identifier=? (syntax set!) set!-stx)
+	    (raise-syntax-error 'class "cannot mutate method" stx)]
+	   [(id . args)
+	    (binding
+	     the-binder (syntax id)
+	     (datum->syntax-object 
+	      the-finder
+	      (make-method-apply (find the-finder new-name stx) (find the-finder the-obj stx) (syntax args))
+	      stx))]
+	   [_else
+	    (raise-syntax-error 
+	     'class 
+	     "misuse of method (not in application)" 
+	     stx)])))))
+
+  (define (make-rename-super-map the-finder the-obj the-binder rename-temp)
+    (let ([set!-stx (datum->syntax-object the-finder 'set!)])
+      (mk-set!-trans
+       the-binder
+       (lambda (stx)
+	 (syntax-case stx ()
+	   [(set! id expr)
+	    (module-identifier=? (syntax set!) set!-stx)
+	    (raise-syntax-error 'class "cannot mutate super method" stx)]
+	   [(id . args)
+	    (binding
+	     the-binder (syntax id)
+	     (datum->syntax-object 
+	      the-finder
+	      (make-method-apply (find the-finder rename-temp stx) (find the-finder the-obj stx) (syntax args))
+	      stx))]
+	   [_else
+	    (raise-syntax-error 
+	     'class 
+	     "misuse of super method (not in application)" 
+	     stx)])))))
+
+  (define (make-rename-inner-map the-finder the-obj the-binder rename-temp)
+    (let ([set!-stx (datum->syntax-object the-finder 'set!)]
+	  [lambda-stx (datum->syntax-object the-finder 'lambda)])
+      (mk-set!-trans
+       the-binder
+       (lambda (stx)
+	 (syntax-case stx ()
+	   [(set! id expr)
+	    (module-identifier=? (syntax set!) set!-stx)
+	    (raise-syntax-error 'class "cannot mutate inner method" stx)]
+	   [(id (lambda () default) . args)
+	    (module-identifier=? (syntax lambda) lambda-stx)
+	    (let ([target (find the-finder the-obj stx)])
+	      (binding
+	       the-binder (syntax id)
+	       (datum->syntax-object 
+		the-finder
+		(make-method-apply (list (find the-finder rename-temp stx) target #'default)
+				   target (syntax args))
+		stx)))]
+	   [(id (lambda largs default) . args)
+	    (module-identifier=? (syntax lambda) lambda-stx)
+	    (raise-syntax-error 
+	     'class 
+	     "misuse of inner method (lambda for default does not take zero arguments)" 
+	     stx)]
+	   [(id (lambda . rest) . args)
+	    (module-identifier=? (syntax lambda) lambda-stx)
+	    (raise-syntax-error 
+	     'class 
+	     "misuse of inner method (ill-formed lambda for default)" 
+	     stx)]
+	   [(id . args)
+	    (raise-syntax-error 
+	     'class 
+	     "misuse of inner method (no lambda-wrapped default after name)" 
+	     stx)]
+	   [_else
+	    (raise-syntax-error 
+	     'class 
+	     "misuse of inner method (not in application)" 
+	     stx)])))))
+
+  (define (generate-super-call stx the-finder the-obj rename-temp args)
+    (datum->syntax-object 
+     the-finder
+     (make-method-apply (find the-finder rename-temp stx) 
+			(find the-finder the-obj stx) 
+			args)
+     stx))
+
+  (define (generate-inner-call stx the-finder the-obj default-expr rename-temp args)
+    (datum->syntax-object 
+     the-finder
+     (let ([target (find the-finder the-obj stx)])
+       (datum->syntax-object 
+	the-finder
+	(make-method-apply (list (find the-finder rename-temp stx) target default-expr)
+			   target args)
+	stx))
+     stx))
+
+  (define init-error-map
+    (make-set!-transformer
+     (lambda (stx)
+       (raise-syntax-error 
+	'class
+	"cannot use non-field init variable in a method"
+	stx))))
+
+  (define super-error-map
+    (lambda (stx)
+      (raise-syntax-error 
+       'class
+       "cannot use superclass initialization form in a method"
+       stx)))
+
+  (define (make-with-method-map set!-stx id-stx method-stx method-obj-stx)
+    (make-set!-transformer
+     (lambda (stx)
+       (syntax-case stx ()
+	 [(set! id expr)
+	  (module-identifier=? (syntax set!) set!-stx)
+	  (raise-syntax-error 'with-method "cannot mutate method" stx)]
+	 [(id . args)
+	  (datum->syntax-object 
+	   set!-stx
+	   (make-method-apply
+	    method-stx
+	    method-obj-stx
+	    (syntax args))
+	   stx)]
+	 [_else
+	  (raise-syntax-error 
+	   'with-method 
+	   "misuse of method (not in application)" 
+	   stx)]))))
+
+  (define (flatten-args orig-args)
+    (let loop ([args orig-args][accum null])
+      (cond
+       [(stx-null? args) orig-args]
+       [(stx-pair? args)
+	(loop (stx-cdr args) (cons (stx-car args) accum))]
+       [else
+	(reverse (cons args accum))])))
+
+  (define-struct private-name (orig-id gen-id))
+
+  (define (localize orig-id)
+    (let loop ([id orig-id])
+      (let ([v (syntax-local-value id (lambda () #f))])
+	(cond
+	 [(and v (private-name? v))
+	  (list 'unquote 
+		(binding (private-name-orig-id v)
+			 id
+			 (private-name-gen-id v)))]
+	 [(and (set!-transformer? v)
+	       (s!t? (set!-transformer-procedure v)))
+	  (loop (s!t-ref (set!-transformer-procedure v) 1))]
+	 [else orig-id]))))
+
+  (define-struct class-context ())
+
+  (define (generate-class-expand-context)
+    (let ([c (syntax-local-context)]
+	  [v (make-class-context)])
+      (if (pair? c)
+	  (cons-immutable v c)
+	  (list-immutable v))))
+
+  (define (class-top-level-context? ctx)
+    (and (pair? ctx)
+	 (class-context? (car ctx))))
+
+  (provide (protect make-this-map make-field-map make-method-map 
+		    make-direct-method-map 
+		    make-rename-super-map make-rename-inner-map
+		    init-error-map super-error-map 
+		    make-with-method-map
+		    flatten-args
+		    make-private-name localize
+		    generate-super-call generate-inner-call
+		    generate-class-expand-context class-top-level-context?)))
diff --git a/collects/mzlib/private/cm-ctime.ss b/collects/mzlib/private/cm-ctime.ss
new file mode 100644
index 0000000000..274882eebd
--- /dev/null
+++ b/collects/mzlib/private/cm-ctime.ss
@@ -0,0 +1,11 @@
+(module cm-ctime mzscheme
+  (provide current-external-file-registrar)
+  
+  (define current-external-file-registrar
+    (make-parameter
+     void
+     (lambda (p)
+       (unless (and (procedure? p)
+		    (procedure-arity-includes? p 1))
+	 (raise-type-error 'current-external-file-registrar "procedure (arity 2)" p))
+       p))))
diff --git a/collects/mzlib/private/contract-helpers.scm b/collects/mzlib/private/contract-helpers.scm
new file mode 100644
index 0000000000..77bf0de552
--- /dev/null
+++ b/collects/mzlib/private/contract-helpers.scm
@@ -0,0 +1,62 @@
+(module contract-helpers mzscheme
+
+  (provide module-source-as-symbol build-src-loc-string mangle-id)
+
+  ;; mangle-id : syntax string syntax ... -> syntax
+  ;; constructs a mangled name of an identifier from an identifier
+  ;; the name isn't fresh, so `id' combined with `ids' must already be unique.
+  (define (mangle-id main-stx prefix id . ids)
+    (datum->syntax-object
+     #f
+     (string->symbol
+      (string-append
+       prefix
+       (format 
+        "-~a~a"
+        (syntax-object->datum id)
+        (apply 
+         string-append 
+         (map 
+          (lambda (id)
+            (format "-~a" (syntax-object->datum id)))
+          ids)))))))
+  
+  ;; build-src-loc-string : syntax -> (union #f string)
+  (define (build-src-loc-string stx)
+    (let ([source (syntax-source stx)]
+          [line (syntax-line stx)]
+          [col (syntax-column stx)]
+          [pos (syntax-position stx)])
+      (cond
+        [(and (path? source) line col)
+         (format "~a:~a:~a" (path->string source) line col)]
+        [(and (string? source) line col)
+         (format "~a:~a:~a" source line col)]
+        [(and line col)
+         (format "~a:~a" line col)]
+        [(and (string? source) pos)
+         (format "~a:~a" source pos)]
+        [(and (path? source) pos)
+         (format "~a:~a" (path->string source) pos)]
+        [pos
+         (format "~a" pos)]
+        [else #f])))
+  
+  (define o (current-output-port))
+  
+  ;; module-source-as-symbol : syntax -> symbol
+  ;; constructs a symbol for use in the blame error messages
+  ;; when blaming the module where stx's occurs.
+  (define (module-source-as-symbol stx)
+    (let ([src-module (syntax-source-module stx)])
+      (cond
+        [(symbol? src-module) src-module]
+        [(module-path-index? src-module) 
+         (let-values ([(path base) (module-path-index-split src-module)])
+           ;; we dont' normalize here, because we don't
+           ;; want to assume that the collection paths
+           ;; are set or the file system can be accessed.
+           (if path
+               (string->symbol (format "~s" path))
+               'top-level))]
+        [else 'top-level]))))
diff --git a/collects/mzlib/private/convert-pat.ss b/collects/mzlib/private/convert-pat.ss
new file mode 100644
index 0000000000..590b473733
--- /dev/null
+++ b/collects/mzlib/private/convert-pat.ss
@@ -0,0 +1,137 @@
+(module convert-pat mzscheme
+  (require "match-error.ss"
+           "match-helper.ss"
+           "match-expander-struct.ss")
+
+  (require-for-template
+   mzscheme
+   "match-error.ss"
+   "match-helper.ss")
+  
+ (provide convert-pat handle-clauses convert-pats)
+                
+  
+  ;; these functions convert the patterns from the old syntax 
+  ;; to the new syntax
+    
+  (define (handle-clause stx)
+    (syntax-case stx ()
+      [(pat . rest) #`(#,(convert-pat (syntax pat)) . rest)]))
+  
+  (define (handle-clauses stx) (syntax-map handle-clause stx))
+  
+ 
+  (define (convert-pats stx)
+    (with-syntax ([new-pats (syntax-map convert-pat stx)])
+      #'new-pats))
+  
+    (define (imp-list? x stx)
+      (define (keyword? x)
+        (member (syntax-object->datum x)
+                '(
+                  quote
+                  quasiquote
+                  ?
+                  =
+                  and
+                  or
+                  not
+                  $
+                  set!
+                  get!
+                  ;unquote
+                  ;unquote-splicing
+                  )))
+      (let/ec out
+        (let loop ((x x))
+          (cond ((null? x) (out #f))
+                ((or (not (pair? x))
+                     (and (list? x)
+                          (keyword? (car x)))) 
+                 (list 
+                  (quasisyntax/loc stx #,x)))
+                (else (cons (car x) (loop (cdr x))))))))
+  
+    (define (convert-quasi stx)
+      (syntax-case stx (unquote quasiquote unquote-splicing)
+        [,pat #`,#,(convert-pat (syntax pat))]
+        [,@pat #`,@#,(convert-pat (syntax pat))]
+        ((x . y)
+         (quasisyntax/loc 
+             stx (#,(convert-quasi (syntax x)) . #,(convert-quasi (syntax y)))))
+        (pat
+         (vector? (syntax-e stx))
+         (quasisyntax/loc 
+             stx 
+           #,(list->vector (map convert-quasi 
+                                (vector->list (syntax-e stx))))))
+        (pat
+         (box? (syntax-e stx))
+         (quasisyntax/loc 
+             stx #,(box (convert-quasi (unbox (syntax-e stx))))))
+        (pat stx)))
+
+  (define (convert-pat stx)
+    (syntax-case* 
+        stx
+      (_ ? = and or not $ set! get! quasiquote 
+         quote unquote unquote-splicing) stx-equal?
+      [(expander . args)
+       (and (identifier? #'expander)
+            (match-expander? (syntax-local-value #'expander (lambda () #f))))
+       (let ([xformer (match-expander-match-xform  
+                       (syntax-local-value #'expander (lambda () #f)))])
+         (if (not xformer)
+             (match:syntax-err #'expander
+                               "This expander only works with plt-match.")
+             (convert-pat (xformer #'(expander . args)))))]
+      [p
+       (dot-dot-k? (syntax-object->datum #'p))
+       stx]
+      [_ stx]
+      [() #'(list)]
+      ['() #'(list)]
+      ['item stx]
+      [p
+       (let ((old-pat (syntax-object->datum #'p)))
+         (or (string? old-pat)
+             (boolean? old-pat)
+             (char? old-pat)
+             (number? old-pat)))
+       stx]
+      [(? pred) stx]
+      [(? pred . a)
+       (with-syntax ([pats (syntax-map convert-pat #'a)])
+         #'(? pred . pats))]
+      [`pat #``#,(convert-quasi #'pat)]
+      [(= op pat) #`(app op #,(convert-pat #'pat))]
+      [(and . pats)
+       (with-syntax ([new-pats (syntax-map convert-pat #'pats)])
+         #'(and . new-pats))]
+      [(or . pats)
+       (with-syntax ([new-pats (syntax-map convert-pat #'pats)])
+         #'(or . new-pats))]
+      [(not pat) #`(not #,(convert-pat #'pat))]
+      [($ struct-name . fields)
+       (with-syntax ([new-fields (syntax-map convert-pat #'fields)])
+         #'(struct struct-name new-fields))]
+      [(get! id) stx]
+      [(set! id) stx]
+      [(quote p) stx]
+      [(car-pat . cdr-pat)
+       (let ([l (imp-list? (syntax-e stx) stx)])
+         (if l #`(list-rest #,@(map convert-pat l))
+             #`(list #,@(map convert-pat (syntax-e stx)))))]
+      [pt
+       (vector? (syntax-e stx))
+       (with-syntax ([new-pats (map convert-pat (vector->list (syntax-e stx)))])
+         #'(vector . new-pats))]
+      [pt
+       (box? (syntax-e stx))
+       #`(box #,(convert-pat (unbox (syntax-e stx))))]
+      [pt
+       (identifier? stx)
+       stx]
+      [got-too-far 
+       (match:syntax-err stx "syntax error in pattern")]))
+  )
\ No newline at end of file
diff --git a/collects/mzlib/private/coupling-and-binding.scm b/collects/mzlib/private/coupling-and-binding.scm
new file mode 100644
index 0000000000..5a4161f2e6
--- /dev/null
+++ b/collects/mzlib/private/coupling-and-binding.scm
@@ -0,0 +1,205 @@
+
+(module coupling-and-binding mzscheme
+  ;; This library is used by match.ss
+  
+  (provide couple-tests meta-couple subst-bindings)
+  
+  (require "test-structure.scm"
+	   "match-helper.ss")
+  
+  (require-for-template 
+   mzscheme
+   "test-structure.scm"
+   "match-helper.ss")
+  
+  ;;!(function couple-tests
+  ;;          (form (couple-tests test-list ks-func kf-func let-bound)
+  ;;                ->
+  ;;                ((list list) -> syntax))
+  ;;          (contract (list
+  ;;                     ((((list list) -> syntax) list) -> 
+  ;;                      ((list list) -> syntax))
+  ;;                     (list -> ((list list) -> syntax))
+  ;;                     list)
+  ;;                    ->
+  ;;                    ((list list) -> syntax)))
+  ;; This is a major function of the compiler.  This function
+  ;; couples a list of tests together.  Here is where state is
+  ;; passed around to the various partially compiled tests so that
+  ;; compilation can be completed.  This returns a function that takes a
+  ;; list of tests so far and a list of bound pattern variables.
+  (define couple-tests
+    (lambda (test-list ks-func kf-func let-bound)
+      (if (null? test-list)
+          (ks-func (kf-func let-bound) let-bound)
+          (let ((cur-test (car test-list)))
+            (if (and (>= (test-bind-count cur-test) 2)
+                     (not (exp-already-bound?
+                           (test-bind-exp cur-test)
+                           let-bound))) ;; if it is member of
+                ;;let-bound skip it
+                (let* ((new-exp (get-exp-var))
+                       (binding (list (test-bind-exp cur-test)
+                                      (test-bind-exp-stx cur-test)
+                                      new-exp))
+                       (let-bound (cons binding
+                                        let-bound))
+                       (kf (kf-func let-bound)))
+                  (lambda (sf bv)
+                    (quasisyntax/loc
+                        (test-bind-exp-stx cur-test)
+                      (let ((#,new-exp
+                               #,(sub-expr-subst (bind-get-exp-stx binding)
+                                                 let-bound)))
+                        #,(((test-comp (car test-list)) 
+                            (couple-tests (cdr test-list)
+                                          ks-func
+                                          (if (negate-test? cur-test) 
+                                              (lambda (let-bound)
+                                                (lambda (sf bv)
+                                                  (quasisyntax/loc
+                                                      (test-bind-exp-stx cur-test)
+                                                    (match-failure))))
+                                              kf-func)
+                                          ;kf-func
+                                          let-bound) 
+                            kf let-bound) sf bv)))))
+                (let* ((kf (kf-func let-bound)))
+                  ((test-comp (car test-list)) 
+                   (couple-tests (cdr test-list)
+                                 ks-func
+                                 (if (negate-test? cur-test) 
+                                     (lambda (let-bound)
+                                       (lambda (sf bv)
+                                         (quasisyntax/loc
+                                             (test-bind-exp-stx cur-test)
+                                           (match-failure))))
+                                     kf-func) 
+                                 ;kf-func
+                                 let-bound) 
+                   kf 
+                   let-bound)))))))
+  
+  ;;!(function bind-get-exp
+  ;;          (form (bind-get-exp binding) -> exp)
+  ;;          (contract binding -> exp))
+  ;; This is just an accessor function for a binding.  This function
+  ;; returns the expression that is bound in s-exp form.
+  (define bind-get-exp car)         
+  
+  ;;!(function bind-get-exp-stx
+  ;;          (form (bind-get-exp-stx binding) -> exp)
+  ;;          (contract binding -> exp))
+  ;; This is just an accessor function for a binding.  This function
+  ;; returns the expression that is bound in syntax form.
+  (define bind-get-exp-stx  cadr)
+  
+  ;;!(function bind-get-new-exp
+  ;;          (form (bind-get-new-exp binding) -> exp)
+  ;;          (contract binding -> exp))
+  ;; This is just an accessor function for a binding.  This function
+  ;; returns the new symbol that will represent the expression.
+  (define bind-get-new-exp caddr)         
+  
+  ;;!(function subst-bindings
+  ;;          (form (subst-bindings exp-stx let-bound) -> syntax)
+  ;;          (contract (syntax list) -> syntax)
+  ;;          (example (subst-bindings (syntax (car (cdr x))) 
+  ;;                                   (list (list '(cdr x) 
+  ;;                                                (syntax (cdr x)) 
+  ;;                                                'exp5)))
+  ;;                   -> (syntax (car 'exp5))))
+  ;; This function substitutes let bound variables names for the
+  ;; expressions that they represent.
+  (define subst-bindings 
+    (lambda (exp-stx let-bound)
+      (let* ((exp (syntax-object->datum exp-stx))
+             (binding (get-bind exp let-bound)))
+        (if binding
+            (bind-get-new-exp binding)
+            (sub-expr-subst exp-stx let-bound)))))
+  
+  ;;!(function sub-exp-subst
+  ;;          (form (sub-exp-subst exp-stx let-bound) -> syntax)
+  ;;          (contract (syntax list) -> syntax)
+  ;;          (example (subst-bindings (syntax (car (cdr x))) 
+  ;;                                   (list (list '(cdr x) 
+  ;;                                         (syntax (cdr x)) 
+  ;;                                         'exp5)))
+  ;;                   -> (syntax (car 'exp5))))
+  ;; This function substitutes let bound variables names for the
+  ;; expressions that they represent. This only works if a
+  ;; subexpression of exp-stx is bound in the let-bound list.
+  (define sub-expr-subst 
+    (lambda (exp-stx let-bound)
+      (syntax-case exp-stx ()
+        ((access sub-exp rest ...)
+         (let ((binding (get-bind 
+                         (syntax-object->datum (syntax sub-exp)) 
+                         let-bound)))
+           ;;(write (syntax sub-exp))(newline) (write binding)(newline)
+           (if binding
+               (quasisyntax/loc 
+                   exp-stx (access #,(bind-get-new-exp binding) rest ...))
+               (quasisyntax/loc 
+                   exp-stx (access #,(sub-expr-subst (syntax sub-exp) 
+                                                     let-bound) 
+                                   rest ...)))))
+        (other (syntax other)))))
+  
+  ;;!(function get-bind
+  ;;          (form (get-bind exp let-bound) -> binding)
+  ;;          (contract (any list) -> list))
+  ;; This function looks up the binding for a given expression exp
+  ;; in the binding list let-bound.  If the binding is found then the
+  ;; binding is returned if not then #f is returned.
+  (define get-bind 
+    (lambda (exp let-bound)
+      (cond ((null? let-bound) #f)
+            ((equal? exp (bind-get-exp (car let-bound))) (car let-bound))
+            (else (get-bind exp (cdr let-bound))))))
+  
+  ;;!(function exp-already-bound?
+  ;;          (form (exp-already-bound? exp let-bound) -> binding)
+  ;;          (contract (any list) -> list))
+  ;; This function looks up the binding for a given expression exp
+  ;; in the binding list let-bound.  If the binding is found then #t
+  ;; binding is returned if not then #f is returned.
+  (define exp-already-bound? 
+    (lambda (exp let-bound)
+      ;;(write exp) (newline) (write let-bound)(newline)
+      (cond ((null? let-bound) #f)
+            ((equal? exp (bind-get-exp (car let-bound))) #t)
+            (else (exp-already-bound? exp (cdr let-bound))))))
+  
+  ;;!(function meta-couple
+  ;;          (form (meta-couple rendered-list failure-func 
+  ;;                             let-bound bvsf)
+  ;;                ->
+  ;;                ((list list) -> syntax))
+  ;;          (contract (list ((list list) -> syntax) list list)
+  ;;                    ->
+  ;;                    ((list list) -> syntax)))
+  ;; This function takes a list of rendered clauses which also have
+  ;; success functions attached and couples the whole lot together
+  ;; yeilding one function that when invoked will compile the whole
+  ;; original match expression.
+  (define meta-couple
+    (lambda (rendered-list failure-func let-bound bvsf)
+      (if (null? rendered-list)
+          failure-func
+          ;; here we erase the previously bound variables
+          (let* ((failed 
+                  (lambda (let-bound)
+                    (lambda (sf bv)
+                      ((meta-couple (cdr rendered-list) 
+                                    failure-func 
+                                    let-bound 
+                                    bvsf) sf bvsf)))))
+            (couple-tests (caar rendered-list)
+                          (cdar rendered-list) ;; successfunc needs 
+                          ;; failure method
+                          failed ;; needs let-bound
+                          let-bound ;; initial-let bindings
+                          )))))      ;; fail-func
+  )
\ No newline at end of file
diff --git a/collects/mzlib/private/define-struct.scm b/collects/mzlib/private/define-struct.scm
new file mode 100644
index 0000000000..cf62a45f43
--- /dev/null
+++ b/collects/mzlib/private/define-struct.scm
@@ -0,0 +1,113 @@
+
+(module define-struct mzscheme
+  (require-for-syntax "struct-helper.scm")
+  (provide define-struct*)
+  
+  (define-syntax (define-struct* stx)
+    (syntax-case stx ()
+      [(_ type [field-decl ...] decl ...)
+       (let* ([field-decls (map (mk-parse-field-decl #'type) (syntax->list #'(field-decl ...)))]
+              [decls (map parse-decl (syntax->list #'(decl ...)))]
+              [info (create-info #'type decls field-decls)])
+         (let ([init-field-k (length (info-init-fields info))]
+               [auto-field-k (length (info-auto-fields info))])
+           #`(begin
+               #,(if (info-include-define-values? info)
+                     #`(define-values #,(info-defined-names info)
+                         (let-values 
+                             ([(struct:x make-x x? x-ref x-set!)
+                               (make-struct-type 'type
+                                                 #,(info-super info)
+                                                 #,init-field-k
+                                                 #,auto-field-k
+                                                 #,(info-auto-v info)
+                                                 #,(info-props info)
+                                                 #,(info-insp info)
+                                                 #,(info-proc-spec info)
+                                                 #,(info-imm-k-list info)
+                                                 #,(info-guard info))])
+                           (values struct:x
+                                   make-x
+                                   x?
+                                   #,@(if (info-include-x-ref? info) #'(x-ref) #'())
+                                   #,@(if (info-include-x-set!? info) #'(x-set!) #'())
+                                   #,@(map (lambda (ref-field ref-posn)
+                                             #`(make-struct-field-accessor 
+                                                x-ref
+                                                #,ref-posn
+                                                '#,ref-field))
+                                           (info-ref-fields info)
+                                           (info-ref-posns info))
+                                   #,@(map (lambda (mut-field mut-posn)
+                                             #`(make-struct-field-mutator
+                                                x-set!
+                                                #,mut-posn
+                                                '#,mut-field))
+                                           (info-mut-fields info)
+                                           (info-mut-posns info)))))
+                     #'(begin))
+               #,(if (info-include-replacers? info)
+                     #`(define-struct-replacers type #,(info-name:constructor info)
+                         #,(map field-decl-field (info-init-fields info))
+                         #,(map field-decl-ref (info-init-fields info)))
+                     #'(begin))
+               #,(if (info-include-clone? info)
+                     (with-syntax ([(field-ref ...) (map field-decl-ref (info-init-fields info))])
+                       #`(define (#,(datum->syntax-object #'type (sym+ 'clone- #'type)) obj)
+                           (let ([field-ref (field-ref obj)] ...)
+                             (#,(info-name:constructor info) field-ref ...))))
+                     #'(begin))
+               #;#,(if (info-include-static-info? info)
+                       #`(define-syntax type
+                           (list-immutable
+                            (quote-syntax #,(info-name:struct-record info))
+                            (quote-syntax #,(info-name:constructor info))
+                            (quote-syntax #,(info-name:predicate info))
+                            (list-immutable
+                             #,@(map (lambda (ref) #`(quote-syntax #,ref))
+                                     (info-field-refs info)))
+                            (list-immutable
+                             #,@(map (lambda (mut) #`(quote-syntax #,mut))
+                                     (info-field-muts info)))
+                            ;; FIXME
+                            #t))
+                       #'(begin)))))]))
+  
+  (define-syntax (define-struct-replacers stx)
+    (syntax-case stx ()
+      [(_ type constructor (field ...) (accessor ...))
+       (with-syntax 
+           ([(replace ...)
+             (map (lambda (f) (datum->syntax-object #'type (sym+ 'replace- #'type '- f)))
+                  (syntax->list #'(field ...)))]
+            [all-field-bindings #'([field (accessor obj)] ...)]
+            [all-fields #'(field ...)])
+         #'(begin (define (replace obj newval)
+                    (let all-field-bindings
+                      (let ([field newval])
+                        (constructor . all-fields))))
+                  ...))]))
+  
+  )
+#|
+
+(require struct)
+(require (lib "pretty.ss"))
+(print-struct #t)
+
+(define-syntax go
+  (syntax-rules ()
+    [(_ form)
+     (begin #;(pretty-print (syntax-object->datum (expand-once #'form)))
+            form)]))
+(go (define-struct* A 
+      [x (y (immutable)) (z (auto)) (w (auto))]
+      transparent (auto-value 'foo)))
+(go (define-struct* B
+      [q (r (immutable)) c]
+      (procedure (lambda (self) (list (B-q self) (B-r self))))
+      transparent clone replace))
+
+(define a1 (make-A 'athens 'sparta))
+(define b1 (make-B 'three 'fifty (lambda _ 'loch-ness)))
+|#
\ No newline at end of file
diff --git a/collects/mzlib/private/dmhelp.ss b/collects/mzlib/private/dmhelp.ss
new file mode 100644
index 0000000000..e21a62f681
--- /dev/null
+++ b/collects/mzlib/private/dmhelp.ss
@@ -0,0 +1,67 @@
+
+(module dmhelp mzscheme
+  (require (lib "stx.ss" "syntax"))
+
+  (provide dm-syntax->datum
+	   dm-subst)
+
+  ;; `dm->syntax-datum' is like syntax-object->datum, but it also
+  ;; builds a hash table that maps generated data to original syntax
+  ;; objects. The hash table can then be used with `dm-subst' to
+  ;; replace each re-used, unmodified datum with the original syntax
+  ;; object.
+
+  (define (dm-syntax->datum stx ht)
+    (define cycle-ht #f)
+    ;; Easiest to handle cycles by letting `syntax-object->datum'
+    ;;  do all the work.
+    (let ([v (syntax-object->datum stx)])
+      (let loop ([stx stx][v v])
+	(unless (and cycle-ht (hash-table-get cycle-ht v (lambda () #f)))
+	  (when (and (syntax? stx) (syntax-graph? stx))
+	    (unless cycle-ht
+	      (set! cycle-ht (make-hash-table)))
+	    (hash-table-put! cycle-ht v #t))
+	  (let ([already (hash-table-get ht v (lambda () #f))])
+	    (if already
+		(hash-table-put! ht v #t) ;; not stx => don't subst later
+		(hash-table-put! ht v stx))
+	    (cond
+	     [(stx-pair? stx)
+	      (loop (stx-car stx) (car v))
+	      (loop (stx-cdr stx) (cdr v))]
+	     [(stx-null? stx) null]
+	     [(vector? (syntax-e stx))
+	      (for-each
+	       loop
+	       (vector->list
+		(syntax-e stx))
+	       (vector->list v))]
+	     [(box? (syntax-e stx))
+	      (loop (unbox (syntax-e stx))
+		    (unbox v))]
+	     [else (void)]))))
+      v))
+  
+  (define (dm-subst ht v)
+    (define cycle-ht (make-hash-table))
+    (let loop ([v v])
+      (if (hash-table-get cycle-ht v (lambda () #f))
+	  v
+	  (begin
+	    (hash-table-put! cycle-ht v #t)
+	    (let ([m (hash-table-get ht v (lambda () #f))])
+	      (cond
+	       [(syntax? m) m] ;; subst back!
+	       [(pair? v) (cons (loop (car v))
+				(loop (cdr v)))]
+	       [(vector? v) (list->vector
+			     (map
+			      loop
+			      (vector->list v)))]
+	       [(box? v) (box (loop (unbox v)))]
+	       [else v])))))))
+
+
+
+	  
diff --git a/collects/mzlib/private/emit-assm.scm b/collects/mzlib/private/emit-assm.scm
new file mode 100644
index 0000000000..7799c95a32
--- /dev/null
+++ b/collects/mzlib/private/emit-assm.scm
@@ -0,0 +1,105 @@
+;; This library is used by match.ss
+
+(module emit-assm mzscheme
+  (provide emit assm)
+  
+  (require "match-helper.ss"
+	   "coupling-and-binding.scm")
+  
+  (require-for-template 
+   mzscheme
+   "match-helper.ss"
+   "coupling-and-binding.scm")
+  ;;!(function emit
+  ;;          (form (emit act-test-func ae let-bound sf bv kf ks)
+  ;;                ->
+  ;;                syntax)
+  ;;          (contract ((syntax -> syntax)
+  ;;                     syntax
+  ;;                     list
+  ;;                     list
+  ;;                     list
+  ;;                     (list list -> syntax)
+  ;;                     (list list -> syntax))
+  ;;                    ->
+  ;;                    syntax))
+  ;; emit's true function is to manage the tests-seen-so-far lists
+  ;; it decides whether a new test needs to be added to the list
+  ;; or whether this condition has already been tested for and if
+  ;; it is true emit calls the success function. If it has been
+  ;; determined to be a false property emit calls the fail function.
+  ;; emit adds implied truths to the test seen so far list so that
+  ;; these truths can be checked against later.
+  (define emit
+    (lambda (act-test-func ae let-bound sf bv kf ks)
+      (let ((test (syntax-object->datum (act-test-func ae))))
+        (cond
+          ((in test sf) (ks sf bv))
+          ((in `(not ,test) sf) (kf sf bv))
+          (else
+           (let* ((pred (car test))
+                  (exp (cadr test))
+                  (implied (implied test))
+                  (not-imp
+                   (if (equal? pred 'list?)
+                       (list `(not (null? ,exp)))
+                       '()))
+                  (s (ks (cons test (append implied sf)) bv))
+                  (k (kf (cons `(not ,test) (append not-imp sf)) bv))
+                  (the-test (act-test-func (subst-bindings ae let-bound))))
+             (assm (syntax-case the-test (struct-pred)
+                     ((struct-pred pred parent-list exp) (syntax (pred exp)))
+                     (reg (syntax reg)))
+                   k s))))))) 
+  
+  ;;!(function assm
+  ;;          (form (assm tst main-fail main-succ) -> syntax)
+  ;;          (contract (syntax syntax syntax) -> syntax))
+  ;; assm - this function is responsible for constructing the actual
+  ;; if statements.  It performs minor expansion optimizations.
+  (define assm
+    (lambda (tst main-fail main-succ)
+      (let ((s (syntax-object->datum main-succ))
+            (f (syntax-object->datum main-fail)))
+        ;; this is for match-count
+        ;;(write (syntax-object->datum tst))(newline)
+        (node-count (add1 (node-count)))
+        (cond ((equal? s f) 
+               (begin 
+                 (when (equal? s '(match-failure))
+                   (node-count (sub1 (node-count)))
+                   ;(write 'here)(newline)
+                   '()
+                   )
+                 main-succ))
+              ((and (eq? s #t) (eq? f #f)) tst)
+              (else
+               (syntax-case main-succ (if
+                                       and
+                                       call/ec
+                                       lambda
+                                       let) ;free-identifier=?  ;stx-equal?
+                 ((if (and tsts ...) true-act fail-act)
+                  (equal? f (syntax-object->datum (syntax fail-act)))
+                  (quasisyntax/loc
+                      tst
+                    (if (and #,tst tsts ...) true-act fail-act)))
+                 ((if tst-prev true-act fail-act)
+                  (equal? f (syntax-object->datum (syntax fail-act)))
+                  (quasisyntax/loc
+                      tst
+                    (if (and #,tst tst-prev) true-act fail-act)))
+                 ((call/ec
+                   (lambda (k) (let ((fail (lambda () (_ f2)))) s2)))
+                  (equal? f (syntax-object->datum (syntax f2)))
+                  (quasisyntax/loc
+                      tst
+                    (call/ec
+                     (lambda (k)
+                       (let ((fail (lambda () (k #,main-fail))))
+                         #,(assm tst (syntax/loc tst (fail)) (syntax s2)))))))
+                 ;; leaving out pattern that is never used in original
+                 (_ (quasisyntax/loc
+                        tst
+                      (if #,tst #,main-succ #,main-fail)))))))))
+  )
\ No newline at end of file
diff --git a/collects/mzlib/private/gen-match.ss b/collects/mzlib/private/gen-match.ss
new file mode 100644
index 0000000000..931dda4d8b
--- /dev/null
+++ b/collects/mzlib/private/gen-match.ss
@@ -0,0 +1,251 @@
+(module gen-match mzscheme
+  
+  (provide gen-match)
+  
+  (require (lib "etc.ss")
+           (lib "stx.ss" "syntax")
+           "match-helper.ss"
+           "match-error.ss"           
+           "coupling-and-binding.scm"		      
+           "update-counts.scm"
+           "update-binding-counts.scm"
+           "render-test-list.scm"
+           "reorder-tests.scm"
+           "tag-negate-tests.scm"
+           "convert-pat.ss")
+  
+  (require-for-template
+   mzscheme
+   (lib "etc.ss")
+   (lib "stx.ss" "syntax")
+   "match-error.ss"           
+   "coupling-and-binding.scm"		      
+   "update-counts.scm"
+   "update-binding-counts.scm"
+   "render-test-list.scm"
+   "reorder-tests.scm"
+   "tag-negate-tests.scm")
+  
+  ;;!(function mark-patlist
+  ;;          (form (mark-patlist clauses) -> marked-clause-list)
+  ;;          (contract list -> list))
+  ;; This function takes each clause from the match expression and
+  ;; pairs it with the dummy value #f.  This value will be set! when
+  ;; the pattern matcher compiles a possible successful match for
+  ;; the clause.  If it is not set to #t then the clause is
+  ;; unreachable which is an indication of programmer error.
+  (define (mark-patlist clauses)
+    (syntax-map (lambda (x) (cons x #f)) clauses))
+  
+  ;; parse-clause : syntax -> syntax syntax maybe[syntax]
+  ;; takes in a pattern
+  ;; returns three values representing the pattern, the body and the failure symbol
+  
+  (define (parse-clause clause)
+    (syntax-case clause (=>)
+      [(pat) (match:syntax-err clause
+                               "missing action for pattern")]
+      [(pat (=> fail-sym)) 
+       (match:syntax-err clause
+                         "missing action for pattern")]
+      [(pat (=> fail-sym) body ...)
+       (values #'pat
+               #'(body ...)
+               #'fail-sym)]
+      [(pat body ...)
+       (values #'pat
+               #'(body ...) 
+               #f)]      
+      [pat (match:syntax-err #'pat
+                             "syntax error in clause")]))
+  
+  ;;!(function test-list-with-success-func
+  ;;          (form (test-list-with-success-func exp car-patlist
+  ;;                         stx success-func)
+  ;;                ->
+  ;;                (test-list success-func))
+  ;;          (contract (syntax-object pair syntax-object
+  ;;                                   (list list -> syntax-object))
+  ;;                    ->
+  ;;                    (list ((list list -> syntax) list ->
+  ;;                           (list list -> syntax)))))
+  ;; This function takes an exp which is to be matched, a marked
+  ;; clause, and a syntax-object that is fro reporting errors. It
+  ;; returns a pair the car of which is a list of test structs which
+  ;; are in essense partially evaluated tests.  The cdr of the
+  ;; result is a function which takes a failure function and a list
+  ;; of let-bound expressions and returns a success-function.
+  (define (test-list-with-success-func exp car-patlist stx success-func)
+    (let-values ([(pat body fail-sym) (parse-clause (car car-patlist))])            
+      (define (success fail let-bound)
+        (if (not success-func)
+            (lambda (sf bv)
+              ;; mark this pattern as reached
+              (set-cdr! car-patlist #t)
+              (if fail-sym
+                  (quasisyntax/loc
+                      stx
+                    (let/ec fail-cont
+                      (let
+                          ((failure
+                            (lambda ()
+                              (fail-cont
+                               ; it seems like fail is called
+                               ; twice in this situation
+                               #,( fail sf bv)))))
+                        ((lambda (#,fail-sym
+                                    #,@(map car bv))
+                           #,@body)
+                         failure
+                         #,@(map (lambda (b)
+                                   (subst-bindings
+                                    (cdr b)
+                                    let-bound))
+                                 bv)))))
+                  (quasisyntax/loc
+                      stx
+                    ((lambda #,(map car bv)
+                       #,@body)
+                     #,@(map
+                         (lambda (b) (subst-bindings
+                                      (cdr b)
+                                      let-bound))
+                         bv)))))
+            (lambda (sf bv)
+              ;; mark this pattern as reached
+              (set-cdr! car-patlist #t)
+              (let ((bv (map
+                         (lambda (bind)
+                           (cons (car bind)
+                                 (subst-bindings
+                                  (cdr bind)
+                                  let-bound)))
+                         bv)))
+                (success-func sf bv)))))
+      (define test-list (render-test-list pat exp stx))
+      (cons test-list success)))
+  
+  ;;!(function gen-match
+  ;;          (form (gen-match exp tsf patlist stx [success-func])
+  ;;                ->
+  ;;                compiled-pattern)
+  ;;          (contract (syntax-object list list syntax-object
+  ;;                                   (list list -> syntax-object))
+  ;;                    ->
+  ;;                    syntax-object))
+  ;; <p>gen-match is the gateway through which match, match-lambda,
+  ;; match-lambda*,
+  ;; match-let, match-let*, match-letrec, match-define access the match
+  ;; expression compiler.
+  ;;
+  ;; <p>exp - the expression that is to be tested against the pattern.
+  ;; This should normally be a piece of syntax that indirectly
+  ;; represents the expression.  Because if it is the syntax of the
+  ;; expression itself it will be duplicated many times throughout
+  ;; the generated match test.
+  ;;
+  ;; <p>tsf - is a list of tests-seen-so-far and is used to
+  ;; prevent generating tests for the same condition twice
+  ;;
+  ;; <p>patlist - is a list of the pattern clauses of the match expr
+  ;; these can be of either form (pat body ...) or
+  ;; (pat (=> fail) body ...)x
+  ;;
+  ;; <p>stx is the original syntax of the match expression.
+  ;; This is only used for error reporting.
+  ;;
+  ;; <p>success-func - an optional argument which allows one to
+  ;; specify how a successful match is treated.  This made
+  ;; the creation of match-letrec and match-define macros simple.
+  ;; The reason for this function is that most of the information
+  ;; about a match (namely the bound match variables) is at the bottom
+  ;; of the recursion tree. The success function must take two arguments
+  ;; and it should return a syntax object.
+  (define gen-match
+    (opt-lambda (exp tsf patlist stx [success-func #f])      
+      
+      ;;!(function gen-help
+      ;;          (form (gen-help exp tsf patlist stx [success-func]) ->
+      ;;                          syntax-object)
+      ;;          (contract (syntax-object list list syntax-object
+      ;;                                   (list list -> syntax-object))
+      ;;                    ->
+      ;;                    syntax-object))
+      ;; This function does some basic house keeping before forwarding
+      ;; the compilation to the gen function.  It sets up the list of
+      ;; clauses so that one can mark that they have been "reached".  It
+      ;; also wraps the final compilation in syntax which binds the
+      ;; match-failure function.
+      (define (gen-help opt)
+        ;(opt-lambda (exp tsf patlist stx opt [success-func #f])
+        (when (stx-null? patlist)
+          (match:syntax-err stx "null clause list"))
+        (let* ((marked-clauses (mark-patlist patlist))
+               (compiled-match
+                (quasisyntax/loc stx
+                  (let ((match-failure
+                         (lambda ()
+                           (match:error #,exp (quote #,stx)))))
+                    #,(gen exp tsf marked-clauses
+                           stx
+                           (syntax (match-failure))
+                           opt
+                           success-func)))))
+          (unreachable marked-clauses stx)
+          compiled-match))
+      
+      
+      
+      
+      
+      ;;!(function gen
+      ;;          (form (gen exp tsf patlist stx failure-func opt success-func)
+      ;;                ->
+      ;;                syntax)
+      ;;          (contract (syntax list list syntax
+      ;;                     (() -> void) bool (list list -> syntax))
+      ;;                    ->
+      ;;                    syntax))
+      ;; This function is primarily called by gen-help and takes the the
+      ;; newly marked clauses and the failure-func which is really a
+      ;; variable-name which will bound to the failure in the runtime
+      ;; code.  This function then makes successive calls to
+      ;; test-list-with-success-func which gives us a list of partially
+      ;; compiled tests for each clause.  I say partially compiled
+      ;; because the test structures containa a function that needs to
+      ;; be coupled with the other functions of the other test
+      ;; structures before actual compilation results.  This function
+      ;; then takes these lists of partially compiled tests and reorders
+      ;; them in an attempt to reduce the size of the final compiled
+      ;; match expression.  Binding counts are also updated to help
+      ;; determind which supexpressions of the expression to be matched
+      ;; need to be bound by let expressions.  After all of this the
+      ;; tests are "coupled" together for final compilation.
+      (define gen
+        (opt-lambda (exp tsf patlist stx failure-func opt [success-func #f])
+          ;; iterate through list and render each pattern to a list of tests
+          ;; and success functions
+          (let ((rendered-list
+                 (let loop ((clause-list patlist))
+                   (if (null? clause-list)
+                       '()
+                       (cons (test-list-with-success-func exp
+                                                          (car clause-list)
+                                                          stx
+                                                          success-func)
+                             (loop (cdr clause-list)))))))
+            (update-counts rendered-list)
+            (tag-negate-tests rendered-list)
+            (update-binding-counts rendered-list)
+            (let* ((rendered-list (reorder-all-lists rendered-list))
+                   (output
+                    (begin 
+                      ;(pretty-print rendered-list)(newline)      
+                      ((meta-couple rendered-list
+                                    (lambda (sf bv) failure-func)
+                                    '()
+                                    '())
+                       '() '()))))
+              output))))
+      (gen-help #f)))
+  )
\ No newline at end of file
diff --git a/collects/mzlib/private/getter-setter.scm b/collects/mzlib/private/getter-setter.scm
new file mode 100644
index 0000000000..eebdd97bdf
--- /dev/null
+++ b/collects/mzlib/private/getter-setter.scm
@@ -0,0 +1,143 @@
+;; This library is used by match.ss
+
+(module getter-setter mzscheme
+  (provide getter setter)
+  (require "coupling-and-binding.scm"
+           "match-helper.ss"
+           "match-error.ss"
+           (lib "stx.ss" "syntax"))
+  (require-for-template 
+   mzscheme
+   "coupling-and-binding.scm"
+   "match-helper.ss"
+   "match-error.ss"
+   (lib "stx.ss" "syntax"))
+  
+  ;;!(function setter
+  ;;          (form (setter e ident let-bound) -> syntax)
+  ;;          (contract (syntax syntax list) -> syntax)
+  ;;          (example (setter (syntax (car x)) (syntax here) '())
+  ;;                   ->
+  ;;          (syntax (lambda (y) (set-car! x y)))))
+  ;; This function takes an expression and returns syntax which
+  ;; represents a function that is able to set the value that the
+  ;; expression points to.
+  (define setter (lambda (e ident let-bound)
+                   (let ((mk-setter (lambda (s)
+                                      (symbol-append 'set- s '!))))
+                     (syntax-case e (vector-ref unbox car cdr)
+                       (p
+                        (not (stx-pair? (syntax p)))
+                        (match:syntax-err
+                         ident
+                         "set! pattern should be nested inside of a list, vector or box"))
+                       ((vector-ref vector index)
+                        (quasisyntax/loc
+                            ident
+                          (let ((x #,(subst-bindings (syntax vector)
+                                                     let-bound)))
+                            (lambda (y)
+                              (vector-set!
+                               x
+                               index
+                               y)))))
+                       ((unbox boxed)
+                        (quasisyntax/loc
+                            ident (let ((x #,(subst-bindings (syntax boxed)
+                                                             let-bound)))
+                                    (lambda (y)
+                                      (set-box! x  y)))))
+                       ((car exp)
+                        (quasisyntax/loc
+                            ident
+                          (let ((x #,(subst-bindings (syntax exp)
+                                                     let-bound)))
+                            (lambda (y)
+                              (set-car! x y)))))
+                       ((cdr exp)
+                        (quasisyntax/loc
+                            ident
+                          (let ((x #,(subst-bindings (syntax exp)
+                                                     let-bound)))
+                            (lambda (y)
+                              (set-cdr! x y)))))
+                       ((acc exp)
+                        (let ((a (assq (syntax-object->datum (syntax acc))
+                                       get-c---rs)))
+                          (if a
+                              (quasisyntax/loc
+                                  ident
+                                (let ((x (#,(cadr a) 
+                                            #,(subst-bindings (syntax exp)
+                                                              let-bound))))
+                                  (lambda (y)
+                                    (#,(mk-setter (cddr a)) x y))))
+                              (quasisyntax/loc
+                                  ident
+                                (let ((x #,(subst-bindings (syntax exp)
+                                                           let-bound)))
+                                  (lambda (y)
+                                    (#,(mk-setter 
+                                        (syntax-object->datum (syntax acc)))
+                                       x y)))))))))))
+  
+  ;;!(function getter
+  ;;          (form (getter e ident let-bound) -> syntax)
+  ;;          (contract (syntax syntax list) -> syntax)
+  ;;          (example (getter (syntax (car x)) (syntax here) '())
+  ;;                   ->
+  ;;          (syntax (lambda () (car x)))))
+  ;; This function takes an expression and returns syntax which
+  ;; represents a function that is able to get the value that the
+  ;; expression points to.
+  (define getter (lambda (e ident let-bound)
+                   (syntax-case e (vector-ref unbox car cdr)
+                     (p
+                      (not (stx-pair? (syntax p)))
+                      (match:syntax-err 
+                       ident
+                       "get! pattern should be nested inside of a list, vector or box"))
+                     ((vector-ref vector index)
+                      (quasisyntax/loc
+                          ident
+                        (let ((x #,(subst-bindings (syntax vector)
+                                                   let-bound)))
+                          (lambda ()
+                            (vector-ref
+                             x
+                             index)))))
+                     ((unbox boxed)
+                      (quasisyntax/loc
+                          ident
+                        (let ((x #,(subst-bindings (syntax boxed)
+                                                   let-bound)))
+                          (lambda () (unbox x)))))
+                     ((car exp)
+                      (quasisyntax/loc
+                          ident
+                        (let ((x #,(subst-bindings (syntax exp)
+                                                   let-bound)))
+                          (lambda () (car x)))))
+                     ((cdr exp)
+                      (quasisyntax/loc
+                          ident
+                        (let ((x #,(subst-bindings (syntax exp)
+                                                   let-bound)))
+                          (lambda () (cdr x)))))
+                     ((acc exp)
+                      (let ((a (assq (syntax-object->datum (syntax acc))
+                                     get-c---rs)))
+                        (if a
+                            (quasisyntax/loc
+                                ident
+                              (let ((x (#,(cadr a)
+                                          #,(subst-bindings (syntax exp)
+                                                            let-bound))))
+                                (lambda () (#,(cddr a) x))))
+                            (quasisyntax/loc
+                                ident
+                              (let ((x #,(subst-bindings (syntax exp)
+                                                         let-bound)))
+                                (lambda ()
+                                  (acc x))))))))))
+  )
\ No newline at end of file
diff --git a/collects/mzlib/private/increader.ss b/collects/mzlib/private/increader.ss
new file mode 100644
index 0000000000..26db1a0570
--- /dev/null
+++ b/collects/mzlib/private/increader.ss
@@ -0,0 +1,5 @@
+
+(module increader mzscheme
+  (define-struct reader (val))
+  (provide reader? make-reader reader-val))
+
diff --git a/collects/mzlib/private/info.ss b/collects/mzlib/private/info.ss
new file mode 100644
index 0000000000..0a41030119
--- /dev/null
+++ b/collects/mzlib/private/info.ss
@@ -0,0 +1,4 @@
+
+(module info (lib "infotab.ss" "setup")
+  (define name "MzLib private")
+  (define compile-omit-files '("shared-body.ss")))
diff --git a/collects/mzlib/private/match-error.ss b/collects/mzlib/private/match-error.ss
new file mode 100644
index 0000000000..b0de1cb7de
--- /dev/null
+++ b/collects/mzlib/private/match-error.ss
@@ -0,0 +1,77 @@
+(module match-error mzscheme
+  (provide (all-defined))
+  
+  (require (lib "pregexp.ss"))
+  
+  (define-struct (exn:misc:match exn:fail) (value))
+  
+  (define match:error
+    (case-lambda
+      ((val)
+       (raise
+        (make-exn:misc:match
+         (string->immutable-string (format "match: no matching clause for ~e" val))
+         (current-continuation-marks)
+         val)))
+      ((val expr)
+       (raise
+        (make-exn:misc:match
+         (string->immutable-string (format "match: no matching clause for ~e: ~s" val expr))
+         (current-continuation-marks)
+         val)))))
+  
+  ;;! (function match:syntax-err
+  ;;          (form (match:syntax-err object message . detail) -> void)
+  ;;          (contract (any string . any) -> void)
+  ;;          (example (match:syntax-err (syntax here) "Bad error" (vector))
+  ;;                   -> void)
+  ;;          (contract object -> (normally a syntax object that
+  ;;                               that helps determine the source location
+  ;;                               of the error)))
+  ;; This function is used to report malformed match expressions.
+  
+  (define match:syntax-err (lambda (obj msg . detail)
+                             (apply
+                              raise-syntax-error
+                              'match
+                              msg
+                              obj
+                              detail)))
+  
+  
+  
+  ;;!(function unreachable
+  ;;          (form (unreachable plist match-expr) -> void)
+  ;;          (contract (list syntax-object) -> void)
+  ;;          (contract plist -> (is a list of unreached pattern clauses))
+  ;;          (contract match-expr -> (is the origional match expr
+  ;;                                   the clauses came from)))
+  ;; This function takes a list of unreached clauses and the original
+  ;; match expression and prints a warning for each of the unreached
+  ;; match clauses to the current error port
+  (define unreachable
+    (lambda (plist match-expr)
+      (map
+       (lambda (x)
+         (if (not (cdr x))
+             (fprintf
+              (current-error-port)
+              "Warning: unreachable match clause ~e in ~e~n"
+              (syntax-object->datum (car x))
+              (syntax-object->datum match-expr))))
+       plist)))
+  
+   ;; this makes pregexp errors a little more friendly
+  (define (pregexp-match-with-error regex str)
+    (if (or (string? regex)
+            (and (pair? regex)
+                 (equal? ':sub (car regex))))
+        (pregexp-match regex str)
+        (error 'match:pregex 
+               (string-append 
+                "this pattern expects either a S-regexp or a U-regexp,"
+                " given " (format "~s" regex) "; "
+                "other argument was " (format "~s" str)))))
+     
+  
+  )
\ No newline at end of file
diff --git a/collects/mzlib/private/match-expander-struct.ss b/collects/mzlib/private/match-expander-struct.ss
new file mode 100644
index 0000000000..0dbb5e28aa
--- /dev/null
+++ b/collects/mzlib/private/match-expander-struct.ss
@@ -0,0 +1,7 @@
+  (module match-expander-struct mzscheme
+    (require "define-struct.scm")
+    (provide (all-defined))
+    #;(provide (struct match-expander (match-xform std-xform)))
+    (define-struct* match-expander (plt-match-xform match-xform std-xform) 
+      (procedure-field std-xform))
+    )
\ No newline at end of file
diff --git a/collects/mzlib/private/match-expander.ss b/collects/mzlib/private/match-expander.ss
new file mode 100644
index 0000000000..d908c8ecc9
--- /dev/null
+++ b/collects/mzlib/private/match-expander.ss
@@ -0,0 +1,50 @@
+(module match-expander mzscheme
+  (provide (all-defined))
+  ;(require "match-expander-struct.ss")
+  (require-for-template "match-expander-struct.ss"
+                        "match-error.ss")
+  (require-for-syntax "match-expander-struct.ss"
+                      "match-error.ss")
+  
+
+  
+  ;; (define-match-expander id transformer-for-plt-match
+  ;;                           [transformer-for-match]
+  ;;                           [transformer-outside-of-match])
+  ;; if only three args, the third is assumed to be the transformer-outside-of-match
+  ;; I wish I had keyword macro args
+  
+  (define-syntax (define-match-expander stx)
+    (syntax-case stx ()
+      [(_ id plt-match-xform match-xform std-xform)
+       (if (identifier? (syntax std-xform))
+           #`(define-syntax id (make-match-expander plt-match-xform
+                                                    match-xform
+                                                    (lambda (stx)
+                                                      (syntax-case stx (set!)
+                                                        #;[(set! id v) #'(set! std-xform v)]
+                                                        [(nm args (... ...)) #'(std-xform args (... ...))]
+                                                        [nm #'std-xform]))))
+           #'(define-syntax id (make-match-expander plt-match-xform match-xform std-xform)))]
+      [(_ id plt-match-xform std-xform)
+       (if (identifier? (syntax std-xform))
+           #`(define-syntax id (make-match-expander plt-match-xform
+                                                    #f
+                                                    (lambda (stx)
+                                                      (syntax-case stx (set!)
+                                                        #;[(set! id v) #'(set! std-xform v)]
+                                                        [(nm args (... ...)) #'(std-xform args (... ...))]
+                                                        [nm #'std-xform]))))
+           #'(define-syntax id (make-match-expander plt-match-xform #f std-xform)))]      
+      [(_ id plt-match-xform) 
+       #'(define-syntax id 
+           (make-match-expander 
+            plt-match-xform 
+            #f
+            (lambda (stx) 
+              (match:syntax-err stx "This match expander must be used inside match"))))]
+      
+      [_ (match:syntax-err stx "Invalid use of define-match-expander")]
+      ))
+  
+  )
\ No newline at end of file
diff --git a/collects/mzlib/private/match-helper.ss b/collects/mzlib/private/match-helper.ss
new file mode 100644
index 0000000000..f1374bdd13
--- /dev/null
+++ b/collects/mzlib/private/match-helper.ss
@@ -0,0 +1,447 @@
+(module match-helper mzscheme
+  
+  (provide (all-defined)
+           (all-from "syntax-utils.ss"))
+  
+  (require (lib "struct.ss" "syntax")
+           "syntax-utils.ss"
+           "match-error.ss"
+           (lib "list.ss"))
+  
+  (require-for-template mzscheme
+                        (lib "struct.ss" "syntax")
+                        (lib "syntax-utils.ss" "mzlib" "private"))
+  
+  ;; define a syntax-transformer in terms of a two-argument function  
+  (define-syntax define-proc 
+    (syntax-rules ()
+      [(_ nm func)
+       (define-syntax (nm stx) (func stx stx))]))
+  
+  
+  ;;!(function symbol-append
+  ;;          (form (symbol-append . args) -> symbol)
+  ;;          (contract ((symbol or number) ...) -> symbol)
+  ;;          (example (symbol-append 'hello 5 'goodbye) -> 'hello5goodbye))
+  ;; This function takes any number of arguments which can be either
+  ;; symbols or numbers and returns one symbol which is the
+  ;; concatenation of the input.
+  (define (symbol-append . l)
+    (define (data->string x)
+      (cond
+        [(symbol? x) (symbol->string x)]
+        [(number? x) (number->string x)]
+        [else x]))      
+    (string->symbol (apply string-append (map data->string l))))
+  
+  ;;!(function struct-pred-accessors-mutators
+  ;;          (form (struct-pred-accessors-mutators struct-name failure-thunk)
+  ;;                ->
+  ;;                (values pred accessors mutators parental-chain))
+  ;;          (contract (syntax-object (any -> void))
+  ;;                     ->
+  ;;                     (values (any -> bool) list list)))
+  ;; This function takes a syntax-object that is the name of a structure
+  ;; as well as a failure thunk.  It returns three values.  The first is
+  ;; a predicate for the structure.  The second is a list of accessors
+  ;; in the same order as the fields of the structure declaration.  The
+  ;; third is a list of mutators for the structure also in the same
+  ;; order.  The last is a list of supertypes of this struct. The
+  ;; failure thunk is invoked if the struct-name is not bound to a
+  ;; structure.
+  (define (struct-pred-accessors-mutators struct-name)
+    (define accessors-index 3)
+    (define mutators-index 4)
+    (define pred-index 2)
+    (define super-type-index 5)
+    (define (failure-thunk)
+      (match:syntax-err struct-name 
+                        "not a defined structure"))
+    (define (local-val sn) (syntax-local-value sn failure-thunk))
+    (define (handle-acc-list l)
+      (reverse (filter (lambda (x) x) l)))
+    (define (get-lineage struct-name)
+      (let ([super (list-ref 
+                    (local-val struct-name)
+                    super-type-index)])
+        (cond [(equal? super #t) '()]
+              [(equal? super #f) '()] ;; not sure what to do in case where super-type is unknown
+              [else (cons super (get-lineage super))])))
+    (define info-on-struct (local-val struct-name))
+    
+    (define (get-info info-on-struct)
+      (values (handle-acc-list
+               (list-ref info-on-struct accessors-index))
+              (handle-acc-list
+               (list-ref info-on-struct mutators-index))
+              (list-ref info-on-struct pred-index)))
+    
+    (unless (struct-declaration-info? info-on-struct) (failure-thunk))
+    
+    (let-values ([(accessors mutators pred) (get-info info-on-struct)]      
+                 [(parental-chain) (get-lineage struct-name)])
+      (values pred accessors mutators (cons struct-name parental-chain)))
+    )
+  
+  
+  
+  
+  
+  
+  ;;!(function in
+  ;;          (form (in e l) -> bool)
+  ;;          (contract (s-exp list) -> bool)
+  ;;          (example (in '(number? x) (list '(number? x))) -> #t))
+  ;; This function is responsible for determining which tests are
+  ;; redundant.  If e can be determined to be true from the list of
+  ;; tests l then e is "in" l.
+  (define (in e l)
+    (or 
+     (ormap
+      (lambda (el)
+        (or (equal? e el)
+            (and 
+             (eq? (car e) 'struct-pred)
+             (eq? (car el) 'struct-pred)
+             (member (caaddr e) (caddr el))
+             (equal? (cadddr e) (cadddr el))))) l)
+     (and (eq? (car e) 'list?)
+          (or (member `(null? ,(cadr e)) l)
+              (member `(pair? ,(cadr e)) l)))
+     (and (eq? (car e) 'not)
+          (let* ((srch (cadr e))
+                 (const-class (equal-test? srch)))
+            ;(write srch)
+            (cond
+              ((equal? (car srch) 'struct-pred)
+               (let mem ((l l))
+                 (if (null? l)
+                     #f
+                     (let ((x (car l)))
+                       (if (and (equal? (car x)
+                                        'struct-pred)
+                                (not (equal? (cadr x) (cadr srch)))
+                                ; the current struct type should not
+                                ; be a member of the parental-chain of 
+                                (not (member (caaddr x) (caddr srch))) 
+                                (equal? (cadddr x) (cadddr srch)))
+                           #t
+                           (mem (cdr l)))))))        
+              (const-class  
+               (let mem ((l l))
+                 (if (null? l)
+                     #f
+                     (let ((x (car l)))
+                       (or (and (equal?
+                                 (cadr x)
+                                 (cadr srch))
+                                (disjoint? x)
+                                (not (equal?
+                                      const-class
+                                      (car x))))
+                           (equal?
+                            x
+                            `(not (,const-class
+                                    ,(cadr srch))))
+                           (and (equal?
+                                 (cadr x)
+                                 (cadr srch))
+                                (equal-test?
+                                 x)
+                                (not (equal?
+                                      (caddr
+                                       srch)
+                                      (caddr
+                                       x))))
+                           (mem (cdr l)))))))
+              ((disjoint? srch) 
+               (let mem ((l l))
+                 (if (null? l)
+                     #f
+                     (let ((x (car l)))
+                       (or (and (disjoint? x)
+                                (not (equal?
+                                      (car x)
+                                      (car srch)))
+                                (cond ((equal?
+                                        (car srch)
+                                        'struct-pred)
+                                       (equal? 
+                                        (cadr x)
+                                        ;; we use cadddr here to access the expression
+                                        ;; because struct predicates carry some extra baggage
+                                        ;; They have the form (struct-pred <predicate> <list of super types> <exp>)
+                                        (cadddr srch)))
+                                      ((equal?
+                                        (car x)
+                                        'struct-pred)
+                                       (equal? 
+                                        (cadr srch)
+                                        ;; we use cadddr here to access the expression
+                                        ;; because struct predicates carry some extra baggage
+                                        (cadddr x)))
+                                      (else (equal?
+                                             (cadr x)
+                                             (cadr srch)))))
+                           (mem (cdr l)))))))
+              ((eq? (car srch) 'list?) 
+               (let mem ((l l))
+                 (if (null? l)
+                     #f
+                     (let ((x (car l)))
+                       (or (and (equal?
+                                 (cadr x)
+                                 (cadr srch))
+                                (disjoint?
+                                 x)
+                                (not (memq (car x)
+                                           '(list?
+                                             pair?
+                                             null?))))
+                           (mem (cdr l)))))))
+              ((vec-structure? srch) 
+               (let mem ((l l))
+                 (if (null? l)
+                     #f
+                     (let ((x (car l)))
+                       (or (and (equal?
+                                 (cadr x)
+                                 (cadr srch))
+                                (or (disjoint?
+                                     x)
+                                    (vec-structure?
+                                     x))
+                                (not (equal?
+                                      (car x)
+                                      'vector?))
+                                (not (equal?
+                                      (car x)
+                                      (car srch))))
+                           (equal?
+                            x
+                            `(not (vector?
+                                   ,(cadr srch))))
+                           (mem (cdr l)))))))
+              (else #f))))))
+  
+  ;;!(function equal-test?
+  ;;          (form (equal-test? tst) -> (or symbol
+  ;;                                         #f))
+  ;;          (contract s-exp -> (or symbol
+  ;;                                         #f))
+  ;;          (example (equal-test? '(equal? x 5))
+  ;;                   -> 'number?)
+  ;;          (example (equal-test? '(symbol? x))
+  ;;                   -> #f))
+  ;; This function returns false if the s-exp does not represent an
+  ;; "equal?" test.  If it does then this function returns a
+  ;; predicate for the data type that the test is testing.
+  (define (equal-test? tst)
+    (and (eq? (car tst) 'equal?)
+         (let ((p (caddr tst)))
+           (cond
+             ((string? p) 'string?)
+             ((boolean? p) 'boolean?)
+             ((char? p) 'char?)
+             ((number? p) 'number?)
+             ((and (pair? p)
+                   (pair? (cdr p))
+                   (null? (cddr p))
+                   (eq? 'quote (car p))
+                   (symbol? (cadr p))) 'symbol?)
+             (else #f)))))
+  
+  (define match:disjoint-predicates
+    '(struct-pred null? pair? symbol? boolean? number? string? char?
+                  procedure? vector?
+                  box? promise?)) 
+  
+  (define match:vector-structures '())
+  
+  ;;!(function disjoint?
+  ;;          (form (disjoint? tst))
+  ;;          (contract s-exp -> bool)
+  ;;          (example (disjoint? 'pair?) -> #t))
+  ;; This function retirns true if the predicate is disjoint.
+  (define (disjoint? tst)
+    (memq (car tst) match:disjoint-predicates))
+  
+  (define (vec-structure? tst)
+    (memq (car tst) match:vector-structures))
+
+  ;;!(function add-a
+  ;;          (form (add-a exp-syntax) -> syntax)
+  ;;          (contract syntax -> syntax)
+  ;;          (example (add-a (syntax (cdr x))) -> (syntax (cadr x))))
+  ;; Add car operation, ie. given (c...r x), return (ca...r x).
+  (define add-a
+    (lambda (exp-syntax)
+      (syntax-case exp-syntax ()
+        ((car-thing exp)
+         (let ((new (assq (syntax-object->datum (syntax car-thing)) c---rs)))
+           (if new
+               (quasisyntax/loc exp-syntax (#,(cadr new) exp))
+               (syntax/loc exp-syntax (car (car-thing exp))))))
+        (exp (syntax/loc exp-syntax (car exp))))))
+  
+  ;;!(function add-d
+  ;;          (form (add-d exp-syntax) -> syntax)
+  ;;          (contract syntax -> syntax)
+  ;;          (example (add-a (syntax (cdr x))) -> (syntax (cddr x))))
+  ;; Add cdr operation, ie. given (c...r x), return (cd...r x).
+  (define add-d
+    (lambda (exp-syntax)
+      (syntax-case exp-syntax ()
+        ((car-thing exp)
+         (let ((new (assq (syntax-object->datum (syntax car-thing)) c---rs)))
+           (if new
+               (quasisyntax/loc exp-syntax (#,(cddr new) exp))
+               (syntax/loc exp-syntax (cdr (car-thing exp))))))
+        (exp (syntax/loc exp-syntax (cdr exp))))))
+  
+  (define c---rs '((car caar . cdar)
+                   (cdr cadr . cddr)
+                   (caar caaar . cdaar)
+                   (cadr caadr . cdadr)
+                   (cdar cadar . cddar)
+                   (cddr caddr . cdddr)
+                   (caaar caaaar . cdaaar)
+                   (caadr caaadr . cdaadr)
+                   (cadar caadar . cdadar)
+                   (caddr caaddr . cdaddr)
+                   (cdaar cadaar . cddaar)
+                   (cdadr cadadr . cddadr)
+                   (cddar caddar . cdddar)
+                   (cdddr cadddr . cddddr)))
+  
+  (define get-c---rs '((caar car . car)
+                       (cadr cdr . car)
+                       (cdar car . cdr)
+                       (cddr cdr . cdr)
+                       (caaar caar . car)
+                       (caadr cadr . car)
+                       (cadar cdar . car)
+                       (caddr cddr . car)
+                       (cdaar caar . cdr)
+                       (cdadr cadr . cdr)
+                       (cddar cdar . cdr)
+                       (cdddr cddr . cdr)
+                       (caaaar caaar . car)
+                       (caaadr caadr . car)
+                       (caadar cadar . car)
+                       (caaddr caddr . car)
+                       (cadaar cdaar . car)
+                       (cadadr cdadr . car)
+                       (caddar cddar . car)
+                       (cadddr cdddr . car)
+                       (cdaaar caaar . cdr)
+                       (cdaadr caadr . cdr)
+                       (cdadar cadar . cdr)
+                       (cdaddr caddr . cdr)
+                       (cddaar cdaar . cdr)
+                       (cddadr cdadr . cdr)
+                       (cdddar cddar . cdr)
+                       (cddddr cdddr . cdr)))
+  
+  ;;!(function stx-dot-dot-k?
+  ;;          (form (stx-dot-dot-k? syn) -> bool)
+  ;;          (contract syntax -> bool)
+  ;;          (example (stx-dot-dot-k? (syntax ..3)) -> #t))
+  ;; This function is a predicate that returns true if the argument
+  ;; is syntax represents a ... or ___ syntax where the last dot or
+  ;; underscore can be an integer
+  (define stx-dot-dot-k?
+    (lambda (syn)
+      (dot-dot-k? (syntax-object->datum syn))))
+  
+  ;;!(function implied
+  ;;          (form (implied test) -> list)
+  ;;          (contract s-exp -> list))
+  ;; This function is given a s-expression for a test and returns a
+  ;; list of tests that are implied by that test.  The implied test
+  ;; would have to be true if the argument is true.
+  (define (implied test)
+    (let* ((pred (car test))
+           (exp (cadr test)))
+      (cond
+        ((equal? pred 'equal?)
+         (let ((ex (caddr test)))
+           (cond ((string? ex)
+                  (list `(string? ,ex)))
+                 ((boolean? ex)
+                  (list `(boolean? ,exp)))
+                 ((char? ex)
+                  (list `(char? ,exp)))
+                 ((number? ex)
+                  (list `(number? ,exp)))
+                 ((and (pair? ex)
+                       (eq? 'quote (car ex)))
+                  (list `(symbol? ,exp)))
+                 (else '()))))
+        ((equal? pred 'null?)
+         (list `(list? ,exp)))
+        (else '()))))
+  
+  
+  ;;! (function pattern-var?
+  ;;    (form (pattern-var? pattern-element) -> bool)
+  ;;    (contract syntax -> bool)
+  ;;    (example (pattern-var? #'x) -> #t)
+  ;;    )
+  ;; This function takes a syntax object and determines if it
+  ;; qualifies as a pattern variable.
+  (define (pattern-var? x)
+    (let ([x (syntax-object->datum x)])
+      (and (symbol? x)
+           (not (dot-dot-k? x))
+           (not (memq x '(_
+                          quasiquote
+                          quote
+                          unquote
+                          unquote-splicing
+                          ;                      hash-table
+                          ;                      list-no-order
+                          ;                       list-rest
+                          ;                       list
+                          ;                       app
+                          ;                       struct
+                          ;                       var
+                          ;                       vector
+                          ;                       box
+                          ;                       ?
+                          ;                       and
+                          ;                       or
+                          ;                       not
+                          ;                       set!
+                          ;                       get!
+                          ))))))
+  
+  ;;!(function dot-dot-k?
+  ;;          (form (dot-dot-k? s) -> bool)
+  ;;          (contract any -> bool)
+  ;;          (example (dot-dot-k? '..3) -> 3))
+  ;; This function is a predicate that returns the number of elements required 
+  ;; by the pattern
+  ;; (dot-dot-k? '..3) -> 3
+  ;; (dot-dot-k? '...) -> 0
+  (define (dot-dot-k? s)
+    (define (./_ c)
+      (or (equal? c #\.)
+          (equal? c #\_)))
+    (and (symbol? s)
+         (if (memq s '(... ___)) 0
+             (let* ((s (symbol->string s)))                    
+               (and (<= 3 (string-length s))
+                    (./_ (string-ref s 0))
+                    (./_ (string-ref s 1))                    
+                    (string->number
+                     (substring s 2)))))))
+  
+  
+  (define node-count (make-parameter 0))
+  
+  (define convert-patterns? (make-parameter #f))
+  
+  (define match-equality-test (make-parameter equal?))
+  
+  )
diff --git a/collects/mzlib/private/match-internal-func.ss b/collects/mzlib/private/match-internal-func.ss
new file mode 100644
index 0000000000..7672eb74e5
--- /dev/null
+++ b/collects/mzlib/private/match-internal-func.ss
@@ -0,0 +1,131 @@
+(module match-internal-func mzscheme
+
+  (provide (all-defined))
+  
+  (require-for-syntax "gen-match.ss"                      
+                      "match-helper.ss"
+                      "match-error.ss"
+                      #;"convert-pat.ss")
+  
+  (require-for-template "gen-match.ss"                      
+                        "match-helper.ss"
+                        mzscheme)                        
+
+  (require (lib "etc.ss")           
+           (lib "list.ss")
+           "gen-match.ss"
+           "match-expander.ss"
+           "match-helper.ss"
+           "match-error.ss"
+           "render-helpers.ss")
+
+  
+  (define-syntax (match stx)
+    (syntax-case stx ()
+      [(_ exp . clauses)       
+       (if (identifier? #'exp)
+           (gen-match #'exp '() #'clauses stx)
+           (with-syntax ([body (gen-match #'x '() #'clauses stx)])
+             #`(let ((x exp)) body)))]))
+  
+  (define-syntax (match-lambda stx)
+    (syntax-case stx ()
+      [(k . clauses)
+       #'(lambda (exp) (match exp . clauses))]))
+
+  (define-syntax (match-lambda* stx)
+    (syntax-case stx ()
+      [(k . clauses)
+       #'(lambda exp (match exp . clauses))]))
+  
+  ;; there's lots of duplication here to handle named let
+  ;; some factoring out would do a lot of good
+  (define-syntax (match-let stx)
+    (syntax-case stx ()
+      ;; an empty body is an error
+      [(_ nm (clauses ...))
+       (identifier? #'nm)
+       (match:syntax-err stx "bad syntax (empty body)")]
+      [(_ (clauses ...)) (match:syntax-err stx "bad syntax (empty body)")]
+      ;; with no bindings, there's nothing to do
+      [(_ name () body ...) 
+       (identifier? #'name)
+       #'(let name () body ...)]
+      [(_ () body ...) #'(let () body ...)]  
+      ;; optimize the all-variable case            
+      [(_ ([pat exp]...) body ...)
+       (andmap pattern-var? (syntax->list #'(pat ...)))
+       #'(let name ([pat exp] ...) body ...)]           
+      [(_ name ([pat exp]...) body ...)
+       (and (identifier? (syntax name))
+            (andmap pattern-var? (syntax->list #'(pat ...))))
+       #'(let name ([pat exp] ...) body ...)]
+      ;; now the real cases
+      [(_ name ([pat exp] ...) . body)
+       #'(letrec ([name (match-lambda* ((list pat ...) . body))])                             
+           (name exp ...))]        
+      [(_ ([pat exp] ...) . body)
+       #'((match-lambda* ((list pat ...) . body)) exp ...)]))
+  
+  (define-syntax (match-let* stx)
+    (syntax-case stx ()
+      [(_ (clauses ...)) (match:syntax-err stx "bad syntax (empty body)")]
+      ((_ () body ...)
+       #'(let* () body ...))
+      ((_ ([pat exp] rest ...) body ...)
+       (if (pattern-var? (syntax pat))
+           #'(let ([pat exp])
+                 (match-let* (rest ...) body ...))
+           #'(match exp [pat (match-let* (rest ...) body ...)]))
+       )))
+  
+  (define-syntax (match-letrec stx)
+      (syntax-case stx ()
+        [(_ (clauses ...)) (match:syntax-err stx "bad syntax (empty body)")]
+        [(_ ([pat exp] ...) . body)
+         (andmap pattern-var?
+                 (syntax->list #'(pat ...)))
+         #'(letrec ([pat exp] ...) . body)]
+        [(_ ([pat exp] ...) . body)         
+           (let* ((**match-bound-vars** '())
+                  (compiled-match 
+                   (gen-match #'the-exp
+                              '()
+                              #'(((list pat ...) never-used))
+                              stx
+                              (lambda (sf bv)
+                                (set! **match-bound-vars** bv)
+                                #`(begin
+                                    #,@(map (lambda (x) #`(set! #,(car x) #,(cdr x)))
+                                          (reverse bv))
+                                    . body )))))
+             #`(letrec (#,@(map
+                            (lambda (x) #`(#,(car x) #f))
+                            (reverse **match-bound-vars**))
+                           (the-exp (list exp ...)))
+                 #,compiled-match))]))
+  
+  (define-syntax (match-define stx)
+    (syntax-case stx ()
+        [(_ pat exp)
+         (identifier? #'pat)
+         #'(define pat exp)]
+        [(_ pat exp)
+         (let* ((**match-bound-vars** '())
+                  (compiled-match
+                   (gen-match #'the-exp
+                              '()
+                              #'((pat never-used))
+                              stx
+                              (lambda (sf bv)
+                                (set! **match-bound-vars** bv)
+                                #`(begin
+                                    #,@(map (lambda (x)
+                                              #`(set! #,(car x) #,(cdr x)))
+                                            (reverse bv)))))))
+             #`(begin #,@(map
+                          (lambda (x) #`(define #,(car x) #f))
+                          (reverse **match-bound-vars**))
+                      (let ((the-exp exp))
+                        #,compiled-match)))]))    
+  )
\ No newline at end of file
diff --git a/collects/mzlib/private/mkmatch.ss b/collects/mzlib/private/mkmatch.ss
new file mode 100644
index 0000000000..74704bb90c
--- /dev/null
+++ b/collects/mzlib/private/mkmatch.ss
@@ -0,0 +1,1167 @@
+
+;; Utilities for match
+
+(module mkmatch mzscheme
+  (provide genmatch genletrec gendefine pattern-var? match:syntax-err re:..k :ucall)
+
+ (define re:..k (regexp "[.][.][0-9]+"))
+
+ (define match:disjoint-predicates
+   (cons
+    'null
+    '(pair? symbol? boolean? number? string? char? procedure? vector? box?)))
+
+ (define match:syntax-err (lambda (obj msg . detail)
+			    (apply
+			     raise-syntax-error
+			     'match
+			     msg
+			     obj
+			     detail)))
+  (define genmatch
+    (lambda (x clauses match-expr)
+      (let* ((length>= (gensym))
+	     (eb-errf (error-maker match-expr))
+	     (blist (car eb-errf))
+	     (plist
+	      (map
+	       (lambda (c)
+		 (let* ((x (bound (validate-pattern (car c)) match-expr))
+			(p (car x))
+			(bv (cadr x))
+			(bindings (caddr x))
+			(code (gensym))
+			(fail
+			 (and (pair? (cdr c))
+			      (pair? (cadr c))
+			      (eq? (caadr c) '=>)
+			      (identifier? (cadadr c))
+			      (pair? (cdadr c))
+			      (null? (cddadr c))
+			      (pair? (cddr c))
+			      (cadadr c)))
+			(bv2 (if fail (cons fail bv) bv))
+			(body (if fail (cddr c) (cdr c))))
+		   (set! blist
+			 (cons
+			  `(,code (lambda ,bv2 ,@body))
+			  (append bindings blist)))
+		   (list p code bv (and fail (gensym)) #f)))
+	       clauses))
+	     (code
+	      (gen x '() plist (cdr eb-errf) length>= (gensym))))
+	(unreachable plist match-expr)
+	(inline-let
+	 `(let ((,length>=
+		 (lambda (n) (lambda (l) (>= (length l) n))))
+		,@blist)
+	    ,code)))))
+
+  (define genletrec
+    (lambda (pat exp body match-expr)
+      (let* ((length>= (gensym))
+	     (eb-errf (error-maker match-expr))
+	     (x (bound (validate-pattern pat) match-expr))
+	     (p (car x))
+	     (bv (cadr x))
+	     (bindings (caddr x))
+	     (code (gensym))
+	     (plist (list (list p code bv #f #f)))
+	     (x (gensym))
+	     (m (gen x '() plist (cdr eb-errf) length>= (gensym)))
+	     (gs (map (lambda (_) (gensym)) bv)))
+	(unreachable plist match-expr)
+	`(letrec ((,length>=
+		   (lambda (n) (lambda (l) (>= (length l) n))))
+		  ,@(map (lambda (v) `(,v #f)) bv)
+		  (,x (list ,@exp))
+		  (,code
+		   (lambda ,gs
+		     ,@(map (lambda (v g) `(set! ,v ,g)) bv gs)
+		     ,@body))
+		  ,@bindings
+		  ,@(car eb-errf))
+	   ,m))))
+
+  (define gendefine
+    (lambda (pat exp match-expr)
+      (let* ((length>= (gensym))
+	     (eb-errf (error-maker match-expr))
+	     (x (bound (validate-pattern pat) match-expr))
+	     (p (car x))
+	     (bv (cadr x))
+	     (bindings (caddr x))
+	     (code (gensym))
+	     (plist (list (list p code bv #f #f)))
+	     (x (gensym))
+	     (m (gen x '() plist (cdr eb-errf) length>= (gensym)))
+	     (gs (map (lambda (_) (gensym)) bv)))
+	(unreachable plist match-expr)
+        `(define-values ,bv
+           (let ,(map (lambda (v) `(,v #f)) bv)
+             ,(inline-let
+               `(let ((,length>=
+                       (lambda (n) (lambda (l) (>= (length l) n))))
+                      (,x ,exp)
+                      (,code
+                       (lambda ,gs
+                         ,@(map (lambda (v g) `(set! ,v ,g)) bv gs)
+                         (cond (#f #f))))
+                      ,@bindings
+                      ,@(car eb-errf))
+                  ,m))
+             (values ,@bv))))))
+
+;  (define gendefine
+;    (lambda (pat exp match-expr)
+;      (let* ((length>= (gensym))
+;	     (eb-errf (error-maker match-expr))
+;	     (x (bound (validate-pattern pat) match-expr))
+;	     (p (car x))
+;	     (bv (cadr x))
+;	     (bindings (caddr x))
+;	     (code (gensym))
+;	     (plist (list (list p code bv #f #f)))
+;	     (x (gensym))
+;	     (m (gen x '() plist (cdr eb-errf) length>= (gensym)))
+;	     (gs (map (lambda (_) (gensym)) bv)))
+;	(unreachable plist match-expr)
+;	`(begin
+;	   ,@(map (lambda (v) `(define ,v #f)) bv)
+;	   ,(inline-let
+;	     `(let ((,length>=
+;		     (lambda (n) (lambda (l) (>= (length l) n))))
+;		    (,x ,exp)
+;		    (,code
+;		     (lambda ,gs
+;		       ,@(map (lambda (v g) `(set! ,v ,g)) bv gs)
+;		       (cond (#f #f))))
+;		    ,@bindings
+;		    ,@(car eb-errf))
+;		,m))))))
+
+  (define pattern-var?
+    (lambda (x)
+      (and (identifier? x)
+	   (not (dot-dot-k? x)))))
+
+  (define dot-dot-k?
+    (lambda (s)
+      (and (symbol? s)
+	   (if (memq s '(... ___))
+	       0
+	       (let* ((s (symbol->string s)) (n (string-length s)))
+		 (and (<= 3 n)
+		      (memq (string-ref s 0) '(#\. #\_))
+		      (memq (string-ref s 1) '(#\. #\_))
+		      (andmap
+		       char-numeric?
+		       (string->list (substring s 2 n)))
+		      (string->number (substring s 2 n))))))))
+
+  (define error-maker
+    (lambda (match-expr)
+      (cons
+       '()
+       (lambda (x) `(match:error ,x)))))
+
+  (define unreachable
+    (lambda (plist match-expr)
+      (for-each
+       (lambda (x)
+	 (if (not (car (cddddr x)))
+	     (fprintf
+	      (current-error-port)
+	      "Warning: unreachable pattern ~e in ~e~n"
+	      ;; This (s->d (d->s _)) pattern is used in case
+	      ;;  the value is a mixture of syntax and non-syntax
+	      (syntax-object->datum (datum->syntax-object #f (car x)))
+	      (syntax-object->datum (datum->syntax-object #f match-expr)))))
+       plist)))
+  
+  (define validate-pattern
+    (lambda (pattern)
+      (letrec ((simple?
+		(lambda (x)
+		  (or (string? x)
+		      (boolean? x)
+		      (char? x)
+		      (number? x)
+		      (null? x))))
+	       (ordinary
+		(lambda (p)
+		  (let ((g204
+			 (lambda (x y)
+			   (cons (ordinary x) (ordinary y)))))
+		    (if (simple? p)
+			((lambda (p) p) p)
+			(if (equal? p '_)
+			    ((lambda () '_))
+			    (if (pattern-var? p)
+				((lambda (p) p) p)
+				(if (pair? p)
+				    (if (equal? (car p) 'quasiquote)
+					(if (and (pair? (cdr p))
+						 (null? (cddr p)))
+					    ((lambda (p) (quasi p)) (cadr p))
+					    (g204 (car p) (cdr p)))
+					(if (equal? (car p) 'quote)
+					    (if (and (pair? (cdr p))
+						     (null? (cddr p)))
+						((lambda (p) p) p)
+						(g204 (car p) (cdr p)))
+					    (if (equal? (car p) '?)
+						(if (and (pair? (cdr p))
+							 (list? (cddr p)))
+						    ((lambda (pred ps)
+						       `(?
+							 ,pred
+							 ,@(map ordinary ps)))
+						     (cadr p)
+						     (cddr p))
+						    (g204 (car p) (cdr p)))
+						(if (equal? (car p) 'and)
+						    (if (and (list? (cdr p))
+							     (pair? (cdr p)))
+							((lambda (ps)
+							   `(and ,@(map ordinary ps)))
+							 (cdr p))
+							(g204 (car p) (cdr p)))
+						    (if (equal? (car p) 'or)
+							(if (and (list? (cdr p))
+								 (pair? (cdr p)))
+							    ((lambda (ps)
+							       `(or ,@(map
+								       ordinary
+								       ps)))
+							     (cdr p))
+							    (g204 (car p) (cdr p)))
+							(if (equal? (car p) 'not)
+							    (if (and (list? (cdr p))
+								     (pair? (cdr p)))
+								((lambda (ps)
+								   `(not
+								     ,@(map ordinary ps)))
+								 (cdr p))
+								(g204 (car p) (cdr p)))
+							    (if (equal? (car p) '$)
+								(if (and (pair? (cdr p))
+									 '(symbol? (cadr p)) ; skip this test - not a symbol anymore
+									 (list? (cddr p)))
+								    ((lambda (r ps)
+								       `($
+									 ,r
+									 ,@(map
+									    ordinary
+									    ps)))
+								     (cadr p)
+								     (cddr p))
+								    (g204 (car p) (cdr p)))
+								(if (equal? (car p) 'set!)
+								    (if (and (pair? (cdr p))
+									     (pattern-var?
+									      (cadr p))
+									     (null?
+									      (cddr p)))
+									((lambda (p) p) p)
+									(g204
+									 (car p)
+									 (cdr p)))
+								    (if (equal?
+									 (car p)
+									 'get!)
+									(if (and (pair?
+										  (cdr p))
+										 (pattern-var?
+										  (cadr p))
+										 (null?
+										  (cddr p)))
+									    ((lambda (p) p) p)
+									    (g204
+									     (car p)
+									     (cdr p)))
+									(if (equal?
+									     (car p)
+									     'unquote)
+									    (g204
+									     (car p)
+									     (cdr p))
+									    (if (equal?
+										 (car p)
+										 'unquote-splicing)
+										(g204
+										 (car p)
+										 (cdr p))
+										(if (and (pair?
+											  (cdr p))
+											 (dot-dot-k?
+											  (cadr
+											   p))
+											 (null?
+											  (cddr
+											   p)))
+										    ((lambda (p ddk)
+										       `(,(ordinary
+											   p)
+											 ,ddk))
+										     (car p)
+										     (cadr p))
+										    (g204
+										     (car p)
+										     (cdr
+										      p))))))))))))))
+				    (if (vector? p)
+					((lambda (p)
+					   (let* ((pl (vector->list p))
+						  (rpl (reverse pl)))
+					     (apply
+					      vector
+					      (if (and (not (null? rpl))
+						       (dot-dot-k? (car rpl)))
+						  (reverse
+                                                   (cons
+                                                    (car rpl)
+                                                    (map ordinary (cdr rpl))))
+						  (map ordinary pl)))))
+					 p)
+					(if (box? p)
+					    ((lambda (p)
+					       (box (ordinary (unbox p))))
+					     p)
+					    ((lambda ()
+					       (match:syntax-err
+                                                pattern
+                                                "syntax error in pattern"))))))))))))
+	       (quasi
+		(lambda (p)
+		  (let ((g193
+			 (lambda (x y) (cons (quasi x) (quasi y)))))
+		    (if (simple? p)
+			p
+			(if (symbol? p)
+			    `',p
+			    (if (pair? p)
+				(if (equal? (car p) 'unquote)
+				    (if (and (pair? (cdr p))
+					     (null? (cddr p)))
+                                        ((lambda (p) (ordinary p)) (cadr p))
+                                        (g193 (car p) (cdr p)))
+				    (if (and (pair? (car p))
+					     (equal?
+					      (caar p)
+					      'unquote-splicing)
+					     (pair? (cdar p))
+					     (null? (cddar p)))
+                                        (if (null? (cdr p))
+					    ((lambda (p) (ordinary p)) (cadar p))
+					    ((lambda (p y)
+					       (append (ordlist p) (quasi y)))
+					     (cadar p)
+					     (cdr p)))
+                                        (if (and (pair? (cdr p))
+                                                 (dot-dot-k? (cadr p))
+                                                 (null? (cddr p)))
+					    ((lambda (p ddk) `(,(quasi p) ,ddk))
+					     (car p)
+					     (cadr p))
+					    (g193 (car p) (cdr p)))))
+				(if (vector? p)
+				    ((lambda (p)
+				       (let* ((pl (vector->list p))
+					      (rpl (reverse pl)))
+					 (apply
+					  vector
+					  (if (dot-dot-k? (car rpl))
+                                              (reverse
+					       (cons
+						(car rpl)
+						(map quasi (cdr rpl))))
+                                              (map ordinary pl)))))
+				     p)
+				    (if (box? p)
+                                        ((lambda (p) (box (quasi (unbox p))))
+                                         p)
+                                        ((lambda ()
+                                           (match:syntax-err
+					    pattern
+					    "syntax error in pattern")))))))))))
+	       (ordlist
+		(lambda (p)
+		  (cond
+		   ((null? p) '())
+		   ((pair? p)
+		    (cons (ordinary (car p)) (ordlist (cdr p))))
+		   (else
+		    (match:syntax-err
+		     pattern
+		     "invalid use of unquote-splicing in pattern"))))))
+	(ordinary pattern))))
+
+  (define bound
+    (lambda (pattern match-expr)
+      (letrec ((pred-bodies '())
+	       (bound
+		(lambda (p a k)
+		  (cond
+		   ((eq? '_ p) (k p a))
+		   ((identifier? p)
+		    (let ([dup (check-duplicate-identifier (cons p a))])
+		      (if dup
+			  (match:syntax-err
+			   match-expr
+			   "duplicate variable in pattern"
+			   dup)))
+		    (k p (cons p a)))
+		   ((and (pair? p) (eq? 'quote (car p))) (k p a))
+		   ((and (pair? p) (eq? '? (car p)))
+		    (cond
+		     ((not (null? (cddr p)))
+		      (bound `(and (? ,(cadr p)) ,@(cddr p)) a k))
+		     ((or (not (identifier? (cadr p))) (memq (cadr p) a))
+		      (let ((g (gensym)))
+			(set! pred-bodies
+			      (cons `(,g ,(cadr p)) pred-bodies))
+			(k `(? ,g) a)))
+		     (else (k p a))))
+		   ((and (pair? p) (eq? 'and (car p)))
+		    (bound*
+		     (cdr p)
+		     a
+		     (lambda (p a) (k `(and ,@p) a))))
+		   ((and (pair? p) (eq? 'or (car p)))
+		    (bound
+		     (cadr p)
+		     a
+		     (lambda (first-p first-a)
+		       (let or* ((plist (cddr p))
+				 (k
+				  (lambda (plist)
+				    (k
+				     `(or ,first-p ,@plist)
+				     first-a))))
+			 (if (null? plist)
+			     (k plist)
+			     (bound
+			      (car plist)
+			      a
+			      (lambda (car-p car-a)
+				(if (not (permutation car-a first-a))
+				    (match:syntax-err
+				     pattern
+				     "variables of or-pattern differ in"))
+				(or*
+				 (cdr plist)
+				 (lambda (cdr-p)
+				   (k (cons car-p cdr-p)))))))))))
+		   ((and (pair? p) (eq? 'not (car p)))
+		    (cond
+		     ((not (null? (cddr p)))
+		      (bound `(not (or ,@(cdr p))) a k))
+		     (else
+		      (bound
+		       (cadr p)
+		       a
+		       (lambda (p2 a2)
+			 (if (not (permutation a a2))
+			     (match:syntax-err
+			      p
+			      "no variables allowed in"))
+			 (k `(not ,p2) a))))))
+		   ((and (pair? p)
+			 (pair? (cdr p))
+			 (dot-dot-k? (cadr p)))
+		    (bound
+		     (car p)
+		     a
+		     (lambda (q b)
+		       (let ((bvars (find-prefix b a)))
+			 (k
+			  `(,q
+			    ,(cadr p)
+			    ,bvars
+			    ,(gensym)
+			    ,(gensym)
+			    ,(map (lambda (_) (gensym)) bvars))
+			  b)))))
+		   ((and (pair? p) (eq? '$ (car p)))
+		    (bound*
+		     (cddr p)
+		     a
+		     (lambda (p1 a) (k `($ ,(cadr p) ,@p1) a))))
+		   ((and (pair? p) (eq? 'set! (car p)))
+		    (if (memq (cadr p) a)
+			(k p a)
+			(k p (cons (cadr p) a))))
+		   ((and (pair? p) (eq? 'get! (car p)))
+		    (if (memq (cadr p) a)
+			(k p a)
+			(k p (cons (cadr p) a))))
+		   ((pair? p)
+		    (bound
+		     (car p)
+		     a
+		     (lambda (car-p a)
+		       (bound
+			(cdr p)
+			a
+			(lambda (cdr-p a)
+			  (k (cons car-p cdr-p) a))))))
+		   ((vector? p)
+		    (boundv
+		     (vector->list p)
+		     a
+		     (lambda (pl a) (k (list->vector pl) a))))
+		   ((box? p)
+		    (bound (unbox p) a (lambda (p a) (k (box p) a))))
+		   (else (k p a)))))
+	       (boundv
+		(lambda (plist a k)
+		  (let ((g187 (lambda () (k plist a))))
+		    (if (pair? plist)
+			(if (and (pair? (cdr plist))
+				 (dot-dot-k? (cadr plist))
+				 (null? (cddr plist)))
+			    ((lambda () (bound plist a k)))
+			    (if (null? plist)
+				(g187)
+				((lambda (x y)
+				   (bound
+				    x
+				    a
+				    (lambda (car-p a)
+				      (boundv
+				       y
+				       a
+				       (lambda (cdr-p a)
+					 (k (cons car-p cdr-p) a))))))
+				 (car plist)
+				 (cdr plist))))
+			(if (null? plist)
+			    (g187)
+			    (match:syntax-err
+			     "boundv"
+			     plist))))))
+	       (bound*
+		(lambda (plist a k)
+		  (if (null? plist)
+		      (k plist a)
+		      (bound
+		       (car plist)
+		       a
+		       (lambda (car-p a)
+			 (bound*
+			  (cdr plist)
+			  a
+			  (lambda (cdr-p a)
+			    (k (cons car-p cdr-p) a))))))))
+	       (find-prefix
+		(lambda (b a)
+		  (if (eq? b a)
+		      '()
+		      (cons (car b) (find-prefix (cdr b) a)))))
+	       (permutation
+		(lambda (p1 p2)
+		  (and (= (length p1) (length p2))
+		       (andmap (lambda (x1) (memq x1 p2)) p1)))))
+	(bound
+	 pattern
+	 '()
+	 (lambda (p a) (list p (reverse a) pred-bodies))))))
+
+  (define inline-let
+    (lambda (let-exp)
+      (letrec ((occ
+		(lambda (x e)
+		  (let loop ((e e))
+		    (cond
+		     ((pair? e) (+ (loop (car e)) (loop (cdr e))))
+		     ((eq? x e) 1)
+		     (else 0)))))
+	       (subst
+		(lambda (e old new)
+		  (let loop ((e e))
+		    (cond
+		     ((pair? e) (cons (loop (car e)) (loop (cdr e))))
+		     ((eq? old e) new)
+		     (else e)))))
+	       (const?
+		(lambda (sexp)
+		  (or (symbol? sexp)
+		      (boolean? sexp)
+		      (string? sexp)
+		      (char? sexp)
+		      (number? sexp)
+		      (null? sexp)
+		      (and (pair? sexp)
+			   (eq? (car sexp) 'quote)
+			   (pair? (cdr sexp))
+			   (symbol? (cadr sexp))
+			   (null? (cddr sexp))))))
+	       (isval?
+		(lambda (sexp)
+		  (or (const? sexp)
+		      (and (pair? sexp)
+			   (memq
+			    (car sexp)
+			    '(lambda quote
+			       match-lambda
+			       match-lambda*))))))
+	       (small?
+		(lambda (sexp)
+		  (or (const? sexp)
+		      (and (pair? sexp)
+			   (eq? (car sexp) 'lambda)
+			   (pair? (cdr sexp))
+			   (pair? (cddr sexp))
+			   (const? (caddr sexp))
+			   (null? (cdddr sexp)))))))
+	(let loop ((b (cadr let-exp))
+		   (new-b '())
+		   (e (caddr let-exp)))
+	  (cond
+	   ((null? b)
+	    (if (null? new-b) e `(let ,(reverse new-b) ,e)))
+	   ((isval? (cadr (car b)))
+	    (let* ((x (caar b)) (n (occ x e)))
+	      (cond
+	       ((= 0 n) (loop (cdr b) new-b e))
+	       ((or (= 1 n) (small? (cadr (car b))))
+		(loop (cdr b) new-b (subst e x (cadr (car b)))))
+	       (else (loop (cdr b) (cons (car b) new-b) e)))))
+	   (else (loop (cdr b) (cons (car b) new-b) e)))))))
+
+  (define gen
+    (lambda (x sf plist erract length>= eta)
+      (if (null? plist)
+	  (erract x)
+	  (let* ((v '())
+		 (val (lambda (x) (cdr (assq x v))))
+		 (fail
+		  (lambda (sf)
+		    (gen x sf (cdr plist) erract length>= eta)))
+		 (success
+		  (lambda (sf)
+		    (set-car! (cddddr (car plist)) #t)
+		    (let* ((code (cadr (car plist)))
+			   (bv (caddr (car plist)))
+			   (fail-sym (cadddr (car plist))))
+		      (if fail-sym
+			  (let ((ap `(,code ,fail-sym ,@(map val bv))))
+			    `(call/ec
+			      (lambda (,fail-sym)
+				(let ((,fail-sym
+				       (lambda ()
+					 (call-with-values
+					  (lambda () ,(fail sf))
+					  ,fail-sym))))
+				  ,ap))))
+			  `(,code ,@(map val bv)))))))
+	    (let next ((p (caar plist))
+		       (e x)
+		       (sf sf)
+		       (kf fail)
+		       (ks success))
+	      (cond
+	       ((eq? '_ p) (ks sf))
+	       ((identifier? p) (set! v (cons (cons p e) v)) (ks sf))
+	       ((null? p) (emit `(null? ,e) sf kf ks))
+	       ((string? p) (emit `(equal? ,e ,p) sf kf ks))
+	       ((boolean? p) (emit `(equal? ,e ,p) sf kf ks))
+	       ((char? p) (emit `(equal? ,e ,p) sf kf ks))
+	       ((number? p) (emit `(equal? ,e ,p) sf kf ks))
+	       ((and (pair? p) (eq? 'quote (car p)))
+		(emit `(equal? ,e ,p) sf kf ks))
+	       ((and (pair? p) (eq? '? (car p)))
+		(let ((tst `(,(cadr p) ,e))) (emit tst sf kf ks)))
+	       ((and (pair? p) (eq? 'and (car p)))
+		(let loop ((p (cdr p)) (sf sf))
+		  (if (null? p)
+		      (ks sf)
+		      (next
+		       (car p)
+		       e
+		       sf
+		       kf
+		       (lambda (sf) (loop (cdr p) sf))))))
+	       ((and (pair? p) (eq? 'or (car p)))
+		(let ((or-v v))
+		  (let loop ((p (cdr p)) (sf sf))
+		    (if (null? p)
+			(kf sf)
+			(begin
+			  (set! v or-v)
+			  (next
+			   (car p)
+			   e
+			   sf
+			   (lambda (sf) (loop (cdr p) sf))
+			   ks))))))
+	       ((and (pair? p) (eq? 'not (car p)))
+		(next (cadr p) e sf ks kf))
+	       ((and (pair? p) (eq? '$ (car p)))
+		(let* ((info (cadr p))
+		       (fields (cdr p))
+		       (rlen (length fields)))
+		  (emit
+		   `(,(car info) ,e)
+		   sf
+		   kf
+		   (let rloop ((n 1))
+		     (lambda (sf)
+		       (if (= n rlen)
+			   (ks sf)
+			   (next
+			    (list-ref fields n)
+			    `(,(list-ref info n) ,e)
+			    sf
+			    kf
+			    (rloop (+ 1 n)))))))))
+	       ((and (pair? p) (eq? 'set! (car p)))
+		(set! v (cons (cons (cadr p) (setter e p)) v))
+		(ks sf))
+	       ((and (pair? p) (eq? 'get! (car p)))
+		(set! v (cons (cons (cadr p) (getter e p)) v))
+		(ks sf))
+	       ((and (pair? p) (pair? (cdr p)) (dot-dot-k? (cadr p)))
+		(emit
+		 `(list? ,e)
+		 sf
+		 kf
+		 (lambda (sf)
+		   (let* ((k (dot-dot-k? (cadr p)))
+			  (ks
+			   (lambda (sf)
+			     (let ((bound (list-ref p 2)))
+			       (cond
+				((eq? (car p) '_) (ks sf))
+				((null? bound)
+				 (let* ((ptst
+					 (next
+					  (car p)
+					  eta
+					  sf
+					  (lambda (sf) #f)
+					  (lambda (sf) #t)))
+					(tst
+					 (if (and (pair? ptst)
+						  (symbol? (car ptst))
+						  (pair? (cdr ptst))
+						  (eq? eta (cadr ptst))
+						  (null? (cddr ptst)))
+					     (car ptst)
+					     `(lambda (,eta) ,ptst))))
+				   (assm
+				    `(andmap ,tst ,e)
+				    (kf sf)
+				    (ks sf))))
+				((and (symbol? (car p))
+				      (equal? (list (car p)) bound))
+				 (next (car p) e sf kf ks))
+				(else
+				 (let* ((gloop (list-ref p 3))
+					(ge (list-ref p 4))
+					(fresh (list-ref p 5))
+					(p1
+					 (next
+					  (car p)
+					  `(car ,ge)
+					  sf
+					  kf
+					  (lambda (sf)
+					    `(,gloop
+					      (cdr ,ge)
+					      ,@(map
+						 (lambda (b f)
+						   `(cons ,(val b) ,f))
+						 bound
+						 fresh))))))
+				   (set! v
+					 (append
+					  (map
+					   cons
+					   bound
+					   (map
+					    (lambda (x) `(reverse ,x))
+					    fresh))
+					  v))
+				   `(let ,gloop
+				      ((,ge ,e)
+				       ,@(map
+					  (lambda (x) `(,x '()))
+					  fresh))
+				      (if (null? ,ge)
+					  ,(ks sf)
+					  ,p1)))))))))
+		     (case k
+		       ((0) (ks sf))
+		       ((1) (emit `(pair? ,e) sf kf ks))
+		       (else (emit `((,length>= ,k) ,e) sf kf ks)))))))
+	       ((pair? p)
+		(emit
+		 `(pair? ,e)
+		 sf
+		 kf
+		 (lambda (sf)
+		   (next
+		    (car p)
+		    (add-a e)
+		    sf
+		    kf
+		    (lambda (sf) (next (cdr p) (add-d e) sf kf ks))))))
+	       ((and (vector? p)
+		     (>= (vector-length p) 6)
+		     (dot-dot-k?
+		      (vector-ref p (- (vector-length p) 5))))
+		(let* ((vlen (- (vector-length p) 6))
+		       (k (dot-dot-k? (vector-ref p (+ vlen 1))))
+		       (minlen (+ vlen k))
+		       (bound (vector-ref p (+ vlen 2))))
+		  (emit
+		   `(vector? ,e)
+		   sf
+		   kf
+		   (lambda (sf)
+		     (assm
+		      `(>= (vector-length ,e) ,minlen)
+		      (kf sf)
+		      ((let vloop ((n 0))
+			 (lambda (sf)
+			   (cond
+			    ((not (= n vlen))
+			     (next
+			      (vector-ref p n)
+			      `(vector-ref ,e ,n)
+			      sf
+			      kf
+			      (vloop (+ 1 n))))
+			    ((eq? (vector-ref p vlen) '_) (ks sf))
+			    (else
+			     (let* ((gloop (vector-ref p (+ vlen 3)))
+				    (ind (vector-ref p (+ vlen 4)))
+				    (fresh (vector-ref p (+ vlen 5)))
+				    (p1
+				     (next
+				      (vector-ref p vlen)
+				      `(vector-ref ,e ,ind)
+				      sf
+				      kf
+				      (lambda (sf)
+					`(,gloop
+					  (- ,ind 1)
+					  ,@(map
+					     (lambda (b f)
+					       `(cons ,(val b) ,f))
+					     bound
+					     fresh))))))
+			       (set! v
+				     (append (map cons bound fresh) v))
+			       `(let ,gloop
+				  ((,ind (- (vector-length ,e) 1))
+				   ,@(map (lambda (x) `(,x '())) fresh))
+				  (if (> ,minlen ,ind)
+				      ,(ks sf)
+				      ,p1)))))))
+		       sf))))))
+	       ((vector? p)
+		(let ((vlen (vector-length p)))
+		  (emit
+		   `(vector? ,e)
+		   sf
+		   kf
+		   (lambda (sf)
+		     (emit
+		      `(equal? (vector-length ,e) ,vlen)
+		      sf
+		      kf
+		      (let vloop ((n 0))
+			(lambda (sf)
+			  (if (= n vlen)
+			      (ks sf)
+			      (next
+			       (vector-ref p n)
+			       `(vector-ref ,e ,n)
+			       sf
+			       kf
+			       (vloop (+ 1 n)))))))))))
+	       ((box? p)
+		(emit
+		 `(box? ,e)
+		 sf
+		 kf
+		 (lambda (sf) (next (unbox p) `(unbox ,e) sf kf ks))))
+	       (else
+		(display "FATAL ERROR IN PATTERN MATCHER")
+		(newline)
+		(error #f "THIS NEVER HAPPENS"))))))))
+
+  (define emit
+    (lambda (tst sf kf ks)
+      (cond
+       ((in tst sf) (ks sf))
+       ((in `(not ,tst) sf) (kf sf))
+       (else
+	(let* ((e (cadr tst))
+	       (implied
+		(cond
+		 ((eq? (car tst) 'equal?)
+		  (let ((p (caddr tst)))
+		    (cond
+		     ((string? p) `((string? ,e)))
+		     ((boolean? p) `((boolean? ,e)))
+		     ((char? p) `((char? ,e)))
+		     ((number? p) `((number? ,e)))
+		     ((and (pair? p) (eq? 'quote (car p)))
+		      `((symbol? ,e)))
+		     (else '()))))
+		 ((eq? (car tst) 'null?) `((list? ,e)))
+		 (else '())))
+	       (not-imp
+		(case (car tst)
+		  ((list?) `((not (null? ,e))))
+		  (else '())))
+	       (s (ks (cons tst (append implied sf))))
+	       (k (kf (cons `(not ,tst) (append not-imp sf)))))
+	  (assm tst k s))))))
+
+  (define assm
+    (lambda (tst f s)
+      (cond
+       ((equal? s f) s)
+       ((and (eq? s #t) (eq? f #f)) tst)
+       ((and (eq? (car tst) 'pair?)
+	     #f ;; <<<<<<<<< Change to #t if crashing is ok!
+	     (memq (car f) '(cond match:error))
+	     (guarantees s (cadr tst)))
+	s)
+       ((and (pair? s) (eq? (car s) 'if) (equal? (cadddr s) f))
+	(if (eq? (car (cadr s)) 'and)
+	    `(if (and ,tst ,@(cdr (cadr s))) ,(caddr s) ,f)
+	    `(if (and ,tst ,(cadr s)) ,(caddr s) ,f)))
+       ((and #f
+	     (pair? s)
+	     (equal? (car s) 'let)
+	     (pair? (cdr s))
+	     (pair? (cadr s))
+	     (pair? (caadr s))
+	     (pair? (cdaadr s))
+	     (pair? (car (cdaadr s)))
+	     (equal? (caar (cdaadr s)) 'lambda)
+	     (pair? (cdar (cdaadr s)))
+	     (null? (cadar (cdaadr s)))
+	     (pair? (cddar (cdaadr s)))
+	     (null? (cdddar (cdaadr s)))
+	     (null? (cdr (cdaadr s)))
+	     (null? (cdadr s))
+	     (pair? (cddr s))
+	     (null? (cdddr s))
+	     (equal? (caddar (cdaadr s)) f))
+	(let ((fail (caaadr s)) (s2 (caddr s)))
+	  `(let ((,fail (lambda () ,f))) ,(assm tst `(,fail) s2))))
+       (else `(if ,tst ,s ,f)))))
+
+  (define guarantees
+    (lambda (code x)
+      (let ((a (add-a x)) (d (add-d x)))
+	(let loop ((code code))
+	  (cond
+	   ((not (pair? code)) #f)
+	   ((memq (car code) '(cond match:error)) #t)
+	   ((or (equal? code a) (equal? code d)) #t)
+	   ((eq? (car code) 'if)
+	    (or (loop (cadr code))
+		(and (loop (caddr code)) (loop (cadddr code)))))
+	   ((eq? (car code) 'lambda) #f)
+	   ((and (eq? (car code) 'let) (symbol? (cadr code))) #f)
+	   (else (or (loop (car code)) (loop (cdr code)))))))))
+
+  (define in
+    (lambda (e l)
+      (or (member e l)
+	  (and (eq? (car e) 'list?)
+	       (or (member `(null? ,(cadr e)) l)
+		   (member `(pair? ,(cadr e)) l)))
+	  (and (eq? (car e) 'not)
+	       (let* ((srch (cadr e))
+		      (const-class (equal-test? srch)))
+		 (cond
+		  (const-class
+		   (let mem ((l l))
+		     (if (null? l)
+			 #f
+			 (let ((x (car l)))
+			   (or (and (equal? (cadr x) (cadr srch))
+				    (disjoint? x)
+				    (not (equal? const-class (car x))))
+			       (equal?
+				x
+				`(not (,const-class ,(cadr srch))))
+			       (and (equal? (cadr x) (cadr srch))
+				    (equal-test? x)
+				    (not
+				     (equal? (caddr srch) (caddr x))))
+			       (mem (cdr l)))))))
+		  ((disjoint? srch)
+		   (let mem ((l l))
+		     (if (null? l)
+			 #f
+			 (let ((x (car l)))
+			   (or (and (equal? (cadr x) (cadr srch))
+				    (disjoint? x)
+				    (not (equal? (car x) (car srch))))
+			       (mem (cdr l)))))))
+		  ((eq? (car srch) 'list?)
+		   (let mem ((l l))
+		     (if (null? l)
+			 #f
+			 (let ((x (car l)))
+			   (or (and (equal? (cadr x) (cadr srch))
+				    (disjoint? x)
+				    (not
+				     (memq
+				      (car x)
+				      '(list? pair? null?))))
+			       (mem (cdr l)))))))
+		  (else #f)))))))
+
+  (define equal-test?
+    (lambda (tst)
+      (and (eq? (car tst) 'equal?)
+	   (let ((p (caddr tst)))
+	     (cond
+	      ((string? p) 'string?)
+	      ((boolean? p) 'boolean?)
+	      ((char? p) 'char?)
+	      ((number? p) 'number?)
+	      ((and (pair? p)
+		    (pair? (cdr p))
+		    (null? (cddr p))
+		    (eq? 'quote (car p))
+		    (symbol? (cadr p)))
+	       'symbol?)
+	      (else #f))))))
+
+  (define disjoint?
+    (lambda (tst) (memq (car tst) match:disjoint-predicates)))
+
+  (define add-a
+    (lambda (a)
+      (let ((new (and (pair? a) (assq (car a) c---rs))))
+	(if new (cons (cadr new) (cdr a)) `(car ,a)))))
+
+  (define add-d
+    (lambda (a)
+      (let ((new (and (pair? a) (assq (car a) c---rs))))
+	(if new (cons (cddr new) (cdr a)) `(cdr ,a)))))
+  
+  (define c---rs
+    '((car caar . cdar)
+      (cdr cadr . cddr)
+      (caar caaar . cdaar)
+      (cadr caadr . cdadr)
+      (cdar cadar . cddar)
+      (cddr caddr . cdddr)
+      (caaar caaaar . cdaaar)
+      (caadr caaadr . cdaadr)
+      (cadar caadar . cdadar)
+      (caddr caaddr . cdaddr)
+      (cdaar cadaar . cddaar)
+      (cdadr cadadr . cddadr)
+      (cddar caddar . cdddar)
+      (cdddr cadddr . cddddr)))
+
+  (define setter
+    (lambda (e p)
+      (let ((mk-setter (lambda (s) (symbol-append 'set- s '!))))
+	(cond
+	 ((not (pair? e))
+	  (match:syntax-err p "unnested set! pattern"))
+	 ((eq? (car e) 'vector-ref)
+	  `(let ((x ,(cadr e)))
+	     (lambda (y) (vector-set! x ,(caddr e) y))))
+	 ((eq? (car e) 'unbox)
+	  `(let ((x ,(cadr e))) (lambda (y) (set-box! x y))))
+	 ((eq? (car e) 'car)
+	  `(let ((x ,(cadr e))) (lambda (y) (set-car! x y))))
+	 ((eq? (car e) 'cdr)
+	  `(let ((x ,(cadr e))) (lambda (y) (set-cdr! x y))))
+	 ((let ((a (assq (car e) get-c---rs)))
+	    (and a
+		 `(let ((x (,(cadr a) ,(cadr e))))
+		    (lambda (y) (,(mk-setter (cddr a)) x y))))))
+	 (else
+	  `(let ((x ,(cadr e)))
+	     (lambda (y) (,(mk-setter (car e)) x y))))))))
+
+  (define getter
+    (lambda (e p)
+      (cond
+       ((not (pair? e)) (match:syntax-err p "unnested get! pattern"))
+       ((eq? (car e) 'vector-ref)
+	`(let ((x ,(cadr e))) (lambda () (vector-ref x ,(caddr e)))))
+       ((eq? (car e) 'unbox)
+	`(let ((x ,(cadr e))) (lambda () (unbox x))))
+       ((eq? (car e) 'car)
+	`(let ((x ,(cadr e))) (lambda () (car x))))
+       ((eq? (car e) 'cdr)
+	`(let ((x ,(cadr e))) (lambda () (cdr x))))
+       ((let ((a (assq (car e) get-c---rs)))
+	  (and a
+	       `(let ((x (,(cadr a) ,(cadr e))))
+		  (lambda () (,(cddr a) x))))))
+       (else `(let ((x ,(cadr e))) (lambda () (,(car e) x)))))))
+
+  (define get-c---rs
+    '((caar car . car)
+      (cadr cdr . car)
+      (cdar car . cdr)
+      (cddr cdr . cdr)
+      (caaar caar . car)
+      (caadr cadr . car)
+      (cadar cdar . car)
+      (caddr cddr . car)
+      (cdaar caar . cdr)
+      (cdadr cadr . cdr)
+      (cddar cdar . cdr)
+      (cdddr cddr . cdr)
+      (caaaar caaar . car)
+      (caaadr caadr . car)
+      (caadar cadar . car)
+      (caaddr caddr . car)
+      (cadaar cdaar . car)
+      (cadadr cdadr . car)
+      (caddar cddar . car)
+      (cadddr cdddr . car)
+      (cdaaar caaar . cdr)
+      (cdaadr caadr . cdr)
+      (cdadar cadar . cdr)
+      (cdaddr caddr . cdr)
+      (cddaar cdaar . cdr)
+      (cddadr cdadr . cdr)
+      (cdddar cddar . cdr)
+      (cddddr cdddr . cdr)))
+
+  (define symbol-append
+    (lambda l
+      (string->symbol
+       (apply
+	string-append
+	(map
+	 (lambda (x)
+	   (cond
+	    ((symbol? x) (symbol->string x))
+	    ((number? x) (number->string x))
+	    (else x)))
+	 l)))))
+
+  (define rac (lambda (l) (if (null? (cdr l)) (car l) (rac (cdr l)))))
+  (define rdc
+    (lambda (l)
+      (if (null? (cdr l)) '() (cons (car l) (rdc (cdr l))))))
+
+ (define-syntax :ucall
+   (lambda (stx)
+     (syntax-case stx ()
+       [(_ name arg ...)
+	(syntax
+	 (let ([name (syntax-local-value (quote-syntax name))])
+	   (name arg ...)))]))))
diff --git a/collects/mzlib/private/package-helper.ss b/collects/mzlib/private/package-helper.ss
new file mode 100644
index 0000000000..94747d7bdd
--- /dev/null
+++ b/collects/mzlib/private/package-helper.ss
@@ -0,0 +1,281 @@
+(module package-helper mzscheme
+  (require (lib "stx.ss" "syntax")
+	   (lib "boundmap.ss" "syntax"))
+
+  (provide str str? str-renames str-all-renames make-str 
+	   check-defn-context
+	   pre-register-package
+	   re-pre-register-package 
+	   remove-dups stx-assoc mark-to-localize rebuild rebuild-cons
+	   split open
+	   protect
+	   walk-path)
+
+  ;; A compile-time struct for package info:
+  (define-struct str (renames all-renames))
+  ;; renames = renames for exports: (list (id-stx . id-stx) ...)
+  ;; all-renames = all internal renames (needed to determine
+  ;;               the appropriate shadowing variable when `open'
+  ;;               appears in a `package' body)
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; General utilities
+
+  ;; Helper:
+  (define (check-defn-context stx)
+    (when (eq? 'expression (syntax-local-context))
+      (raise-syntax-error
+       #f
+       "allowed only in definition contexts"
+       stx)))
+  
+  ;; Removes dups from * defns
+  (define (remove-dups l)
+    (let ((ht (make-bound-identifier-mapping)))
+      (let loop ((l l))
+        (cond
+          ((null? l) (bound-identifier-mapping-map ht (lambda (k v) v)))
+          ((bound-identifier-mapping-get ht (caar l) (lambda () #f)) (loop (cdr l)))
+          (else 
+           (bound-identifier-mapping-put! ht (caar l) (car l))
+	   (loop (cdr l)))))))
+  
+  (define (stx-assoc id renames)
+    (cond
+     ((null? renames) #f)
+     ((bound-identifier=? id (caar renames)) (car renames))
+     (else (stx-assoc id (cdr renames)))))
+  
+  (define insp (current-code-inspector))
+
+  (define (rebuild ctxt val)
+    (if (syntax? ctxt)
+	(syntax-recertify (datum->syntax-object ctxt val ctxt ctxt)
+			  ctxt
+			  insp
+			  #f)
+	val))
+  
+  (define (rebuild-cons car cdr stx)
+    (rebuild stx (cons car cdr)))
+
+  (define (split path)
+    (let ((r (reverse path)))
+      (values (reverse (cdr r)) (car r))))
+
+  ;; The mark-to-localize function detects uses of `protect'
+  ;; to prevent localization.
+  (define-syntax protect
+    (syntax-rules ()
+      [(_ id) (quote-syntax id)]))
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; Side registration table of packages
+
+  (define pre-registered (make-hash-table 'weak))
+  ;; maps context keys to context-hash,
+  ;; where a contetx hash maps id to (cons renames sub-context-hash-or-#f)
+
+  (define (pre-register-package expand-ctx name renames all-renames introducers protect-stx)
+    ;; expand-ctx is the context used for expanding the body;
+    ;; if it's a list longer than 1, then the package itself was
+    ;; expanded in an internal-def position. In that case,
+    ;; we register the just-created package in the table. We
+    ;; also remember any packages that were registered with
+    ;; `(car expand-ctx)'.
+    (when (> (length expand-ctx) 1)
+      (let ([sub-ht (hash-table-get pre-registered (car expand-ctx) (lambda () #f))])
+	(do-pre-register-package
+	 (cadr expand-ctx)
+	 (syntax-local-introduce name)
+	 (list (map (lambda (i)
+		      (cons (syntax-local-introduce (car i)) 
+			    (syntax-local-introduce (cdr i))))
+		    renames)
+	       (map (lambda (i)
+		      (cons (syntax-local-introduce (car i)) 
+			    (syntax-local-introduce (cdr i))))
+		    all-renames)
+	       ;; Each package in the sub-ht table needs to be fixed
+	       ;; up with the renamings introduced by the enclosing package.
+	       (convert-subs sub-ht introducers protect-stx)
+	       #t)))))
+
+  ;; Just a hash-table wrapper
+  (define (do-pre-register-package immediate-ctx name val)
+    (let ([ht (hash-table-get pre-registered immediate-ctx
+			      (lambda ()
+				(let ([ht (make-bound-identifier-mapping)])
+				  (hash-table-put! pre-registered immediate-ctx ht)
+				  ht)))])
+      (bound-identifier-mapping-put! 
+       ht 
+       name
+       val)))
+
+  ;; Gets info for a package that has been expanded but not
+  ;; yet executed as syntax. Used only by get-renames.
+  (define (get-pre-registered-package use-ctx name)
+    (and (pair? use-ctx)
+	 (ormap (lambda (ctx)
+		  (let ([ht (hash-table-get pre-registered ctx (lambda () #f))])
+		    (and ht
+			 (bound-identifier-mapping-get ht 
+						       name
+						       (lambda () #f)))))
+		use-ctx)))
+
+  ;; When `open' exposes a package, we need to pre-register it.
+  ;; Ditto for renaming a package.
+  (define (re-pre-register-package subs expand-ctx name id)
+    (let ([v (if subs
+		 (bound-identifier-mapping-get subs id (lambda () #f))
+		 (get-renames id (lambda (x) (lambda () #f)) #t))])
+      (when v
+	(do-pre-register-package
+	 (car expand-ctx)
+	 name
+	 v))))
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;  Fixup
+
+  ;; See pre-register-package. In each package's rename mappings,
+  ;; the source is the original name, so it needs no conversion,
+  ;; but the rename targets need to be the final names.
+  ;; Recursively fix up nasted-package info.
+  (define (convert-subs rn introducers protect-stx)
+    (and rn
+	 (let ([naya (make-bound-identifier-mapping)])
+	   (bound-identifier-mapping-for-each
+	    rn
+	    (lambda (id v)
+	      (bound-identifier-mapping-put!
+	       naya
+	       id
+	       (list (map (lambda (i)
+			    (cons (car i)
+				  ;; The main fixup operation:
+				  (intro-mark-to-localize (cdr i) introducers protect-stx)))
+			  (car v))
+		     (map (lambda (i)
+			    (cons (car i)
+				  ;; The main fixup operation:
+				  (intro-mark-to-localize (cdr i) introducers protect-stx)))
+			  (cadr v))
+		     (convert-subs (caddr v) introducers protect-stx)
+		     #t))))
+	   naya)))
+
+  ;; Mainly applies the introducers, but those introducers are
+  ;;  for the package currently being expanded, and the saved
+  ;;  syntax objects were stored in a table on the side from a
+  ;;  previous expansion. So, we need to "introduce" the
+  ;;  expressions before applying the renaming introducers, then
+  ;;  un-introduce nack to neutral to store in the table.
+  (define (intro-mark-to-localize def introducers protect-stx)
+    (syntax-local-introduce
+     (mark-to-localize (syntax-local-introduce def) introducers protect-stx)))
+
+  ;; Traverses an S-expression, "introducing" identifiers
+  ;; so that they refer to bindings that will be hidden 
+  ;; by the package. Don't localize protected ids, though.
+  (define (mark-to-localize def introducers protect-stx)
+    (let ((contents 
+	   (if (syntax? def)
+	       (syntax-e def)
+	       def)))
+      (cond
+       ((symbol? contents)
+	(let ((introducer (stx-assoc def introducers)))
+	  (if introducer ((cdr introducer) def) def)))
+       ((pair? contents)
+	(if (and (identifier? (car contents))
+		 (module-transformer-identifier=? protect-stx (car contents)))
+	    def
+	    (rebuild-cons (mark-to-localize (car contents) introducers protect-stx)
+			  (mark-to-localize (cdr contents) introducers protect-stx)
+			  def)))
+       ((vector? contents)
+	(rebuild def (list->vector
+		      (map (lambda (x) (mark-to-localize x introducers protect-stx))
+			   (vector->list contents)))))
+       (else def))))
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;  Open
+
+  ;; Finds a package, either as a syntax definition or in the
+  ;;  pre-registration table.
+  ;; If the id was input to the current macro expander, it
+  ;;  as been introduced (so we need to un-introduce it
+  ;;  before using syntax-local-value).
+  ;; The resulting env+rns+subs+ispre will have #f for subs when
+  ;;  the package is found by `syntax-local-introduce'. In
+  ;;  that case, sub-packages will be found in the
+  ;;  environment, too.
+  (define (get-renames id err try-pre?)
+    (let ([env+rns+subs+ispre 
+	   (or (and try-pre?
+		    (get-pre-registered-package (syntax-local-context) id))
+	       (let ([v (syntax-local-value (syntax-local-introduce id) (err id))])
+		 (and (str? v)
+		      (list (str-renames v) (str-all-renames v) #f #f))))])
+      (or env+rns+subs+ispre
+	  ((err id)))))
+  
+  ;; Wraps `get-renames' with suitable error handling.
+  (define (open name orig-name stx)
+    (unless (identifier? name)
+      (raise-syntax-error #f "path component must be an identifier" stx name))
+    (let ((err (lambda (name)
+                 (lambda ()
+                   (raise-syntax-error #f "unknown package" stx (if (identifier? orig-name)
+								    orig-name 
+								    name))))))
+      (get-renames (syntax-local-introduce name) err #t)))
+
+  ;; Given an initial package description (as env+rns+subs+ispre), find
+  ;;  the innermost package indicated by `path'. The `stx'
+  ;;  argument is for error reporting, the `rename' argument
+  ;;  accumulates a renamer for environment lookups, and 
+  ;;  `cp-rename' reverse-maps source ids for table lookups 
+  ;;  (when we're in an enclosing package).
+  ;; When env+rns+subs+ispre has a non-#f subs, then we'll always
+  ;;  walk pre-registration info, and the renamer is
+  ;;  not extended.
+  (define (walk-path path env+rns+subs+ispre stx rename cp-rename)
+    (let loop ([path path][env+rns+subs+ispre env+rns+subs+ispre][rename rename])
+      (cond
+       [(null? path) (values env+rns+subs+ispre rename)]
+       [else (let* (;; Revser-map id, in case we're in an enclosing package:
+		    [id (cp-rename (syntax-local-introduce (car path)))]
+		    ;; If we have a sub-package table, it maps the 
+		    ;;  original name, otherwise we need to search
+		    ;;  based on the renamed package in an enclosing package.
+		    [new-name (if (caddr env+rns+subs+ispre)
+				  (cons id id)
+				  (stx-assoc id (cadr env+rns+subs+ispre)))]
+		    [v (and new-name
+			    (if (caddr env+rns+subs+ispre)
+				(bound-identifier-mapping-get (caddr env+rns+subs+ispre) 
+							      (cdr new-name)
+							      (lambda () #f))
+				(get-renames (rename (cdr new-name))
+					     (lambda (x) (lambda () #f))
+					     #f)))])
+	       (if v
+		   (loop (cdr path) v (if (caddr env+rns+subs+ispre)
+					  rename
+					  (lambda (id)
+					    (let ([a (stx-assoc id (cadr env+rns+subs+ispre))])
+					      (rename (if a
+							  (cdr a)
+							  id))))))
+		   (raise-syntax-error
+		    #f
+		    "no such exported subpackage"
+		    stx
+		    (car path))))])))
+  
+  )
diff --git a/collects/mzlib/private/parse-quasi.scm b/collects/mzlib/private/parse-quasi.scm
new file mode 100644
index 0000000000..80902b765e
--- /dev/null
+++ b/collects/mzlib/private/parse-quasi.scm
@@ -0,0 +1,137 @@
+;; This library is used by match.ss
+(module parse-quasi mzscheme
+  (provide (all-defined))
+  (require "match-error.ss"
+           "match-helper.ss"
+           (lib "etc.ss")
+           (lib "stx.ss" "syntax"))
+  
+  (require-for-template mzscheme
+                        "match-error.ss"
+                        "match-helper.ss"
+                        (lib "etc.ss")
+                        (lib "stx.ss" "syntax"))
+
+  ;; Raise an error from a quasi-pattern
+  (define q-error 
+    (opt-lambda (syn [msg ""])
+      (match:syntax-err
+       syn
+       (string-append "syntax error in quasi-pattern: " msg))))     
+  
+  ;;!(function parse-quasi
+  ;;          (form (parse-quasi syn) -> syntax)
+  ;;          (contract syntax -> syntax))
+  ;; This function parses a quasi pattern in to a regular pattern
+  ;; and returns it.  This function does not parse the quasi pattern
+  ;; recursively in order to find nested quasi patterns.  It only
+  ;; parses the top quasi pattern.
+  (define (parse-quasi stx)    
+    (define parse-q
+      (lambda (phrase)
+        ;(write phrase)(newline)
+        (syntax-case phrase (quasiquote unquote unquote-splicing)
+          (p
+           (let ((pat (syntax-object->datum (syntax p))))
+             (or (string? pat)
+                 (boolean? pat)
+                 (char? pat)
+                 (number? pat)
+                 (dot-dot-k? pat)))
+           (syntax p))
+          (p
+           (stx-null? (syntax p))
+           (syntax/loc stx (list)))
+          (p
+           ;; although it is not in the grammer for quasi patterns
+           ;; it seems important to not allow unquote splicing to be
+           ;; a symbol in this case `,@(a b c). In this unquote-splicing
+           ;; is treated as a symbol and quoted to be matched.
+           ;; this is probably not what the programmer intends so
+           ;; it may be better to throw a syntax error
+           (identifier? (syntax p)) 
+           (syntax/loc stx 'p))
+          ;; ((var p)  ;; we shouldn't worry about this in quasi-quote
+          ;;  (identifier? (syntax p))
+          ;;  (syntax/loc phrase 'p))
+          (,p (syntax p))
+          (,@pat
+             (q-error (syntax ,@pat) "unquote-splicing not nested in list"))
+          ((x . y) 
+           (let* ((list-type 'list)
+                  (result
+                   (let loop 
+                     ((l (syntax-e (syntax (x . y)))))
+                     ;(write l)(newline)
+                     (cond ((null? l) '())
+                           ((and (stx-pair? (car l))
+                                 (equal? (car (syntax-object->datum (car l))) 
+                                         'unquote-splicing))
+                            (let ((first-car  
+                                   (syntax-case (car l) 
+                                     (unquote-splicing quasiquote)
+                                     (,@`p  ;; have to parse forward here
+                                        (let ((pq (parse-q (syntax p))))
+                                          (if (stx-list? pq)
+                                              (cdr (syntax->list pq))
+                                              (q-error (syntax ,@`p)
+                                                       "unquote-splicing not followed by list"))))
+                                     (,@p
+                                        (if (stx-list? (syntax p))
+                                            (cdr (syntax->list (syntax p)))
+                                            (begin ; (write (syntax-e (syntax p))) 
+                                              (q-error (syntax ,@p)
+                                                       "unquote-splicing not followed by list")))))))
+                              (syntax-case (cdr l) (unquote unquote-splicing)
+                                (,@p (q-error (syntax ,@p) 
+                                              "unquote-splicing can not follow dot notation"))
+                                (,p  
+                                  (let ((res (parse-q (syntax ,p))))
+                                    (set! list-type 'list-rest)
+                                    `(,@first-car ,res)))
+                                (p (or (stx-pair? (syntax p))
+                                       (stx-null? (syntax p)))
+                                   (append first-car 
+                                           (loop (syntax-e (syntax p)))))
+                                (p ;; must be an atom
+                                 (let ((res (parse-q (syntax p))))
+                                   (set! list-type 'list-rest)
+                                   `(,@first-car ,res))))))
+                           (else 
+                            (syntax-case (cdr l) (unquote unquote-splicing)
+                              (,@p (q-error (syntax p) 
+                                            "unquote-splicing can not follow dot notation"))
+                              (,p  (begin 
+                                     (set! list-type 'list-rest)
+                                     (list (parse-q (car l))  
+                                           (parse-q (syntax ,p)))))
+                              (p (or (stx-pair? (syntax p))
+                                     (stx-null? (syntax p)))
+                                 (cons (parse-q (car l))
+                                       (loop (syntax-e (syntax p)))))
+                              (p ;; must be an atom
+                               (begin 
+                                 (set! list-type 'list-rest)
+                                 (list (parse-q (car l)) 
+                                       (parse-q (syntax p)))))))))))
+             (quasisyntax/loc stx (#,list-type #,@result))))
+          (p
+           (vector? (syntax-object->datum (syntax p)))
+           (quasisyntax/loc 
+               stx
+             (vector #,@(cdr 
+                         (syntax-e 
+                          (parse-q
+                           (quasisyntax/loc 
+                               stx 
+                             #,(vector->list (syntax-e (syntax p))))))))))
+          (p
+           (box? (syntax-object->datum (syntax p)))
+           (quasisyntax/loc 
+               stx
+             (box #,(parse-q (unbox (syntax-e (syntax p)))))))
+          (p (q-error (syntax p))))))
+    (parse-q stx))
+  
+  )
+
diff --git a/collects/mzlib/private/plt-match/coupling-and-binding-new.scm b/collects/mzlib/private/plt-match/coupling-and-binding-new.scm
new file mode 100644
index 0000000000..5d33b2b224
--- /dev/null
+++ b/collects/mzlib/private/plt-match/coupling-and-binding-new.scm
@@ -0,0 +1,301 @@
+;; This library is used by match.ss
+
+(define-values (couple-tests meta-couple subst-bindings)
+  (letrec 
+      (
+       ;;!(function couple-tests
+       ;;          (form (couple-tests test-list ks-func kf-func let-bound)
+       ;;                ->
+       ;;                ((list list) -> syntax))
+       ;;          (contract (list
+       ;;                     ((((list list) -> syntax) list) -> 
+       ;;                      ((list list) -> syntax))
+       ;;                     (list -> ((list list) -> syntax))
+       ;;                     list)
+       ;;                    ->
+       ;;                    ((list list) -> syntax)))
+       ;; This is a major function of the compiler.  This function
+       ;; couples a list of tests together.  Here is where state is
+       ;; passed around to the various partially compiled tests so that
+       ;; compilation can be completed.  This returns a function that takes a
+       ;; list of tests so far and a list of bound pattern variables.
+       (couple-tests
+        (lambda (test-list ks-func kf-func let-bound)
+          (if (null? test-list)
+              (ks-func (kf-func let-bound) let-bound)
+              (let ((cur-test (car test-list)))
+                (if (and (>= (test-bind-count cur-test) 2)
+                         (not (exp-already-bound?
+                               (test-bind-exp cur-test)
+                               let-bound))) ;; if it is member of
+                    ;;let-bound skip it
+                    (let* ((new-exp (get-exp-var))
+                           (binding (list (test-bind-exp cur-test)
+                                          (test-bind-exp-stx cur-test)
+                                          new-exp))
+                           (let-bound (cons binding
+                                            let-bound))
+                           (kf (kf-func let-bound)))
+                      (lambda (sf bv)
+                        (let ((coup-res
+                               (((test-comp (car test-list)) 
+                                 (couple-tests (cdr test-list)
+                                               ks-func
+                                               (if (negate-test? cur-test) 
+                                                   (lambda (let-bound)
+                                                     (lambda (sf bv)
+                                                       (quasisyntax/loc
+                                                        (test-bind-exp-stx cur-test)
+                                                        (match-failure))))
+                                                   kf-func)
+                                        ;kf-func
+                                               let-bound) 
+                                 kf let-bound) sf bv)))
+                          (if (equal? (syntax-object->datum coup-res)
+                                      '(match-failure))
+                              coup-res
+                              (quasisyntax/loc
+                               (test-bind-exp-stx cur-test)
+                               (let ((#,new-exp
+                                      #,(sub-expr-subst (bind-get-exp-stx binding)
+                                                        let-bound)))
+                                 #,coup-res))))))
+                    (let* ((kf (kf-func let-bound)))
+                      ((test-comp (car test-list)) 
+                       (couple-tests (cdr test-list)
+                                     ks-func
+                                     (if (negate-test? cur-test) 
+                                         (lambda (let-bound)
+                                           (lambda (sf bv)
+                                             (quasisyntax/loc
+                                              (test-bind-exp-stx cur-test)
+                                              (match-failure))))
+                                         kf-func) 
+                                        ;kf-func
+                                     let-bound) 
+                       kf 
+                       let-bound)))))))
+
+       ;;!(function bind-get-exp
+       ;;          (form (bind-get-exp binding) -> exp)
+       ;;          (contract binding -> exp))
+       ;; This is just an accessor function for a binding.  This function
+       ;; returns the expression that is bound in s-exp form.
+       (bind-get-exp 
+        (lambda (binding)
+          (car binding)))
+
+       ;;!(function bind-get-exp-stx
+       ;;          (form (bind-get-exp-stx binding) -> exp)
+       ;;          (contract binding -> exp))
+       ;; This is just an accessor function for a binding.  This function
+       ;; returns the expression that is bound in syntax form.
+       (bind-get-exp-stx 
+        (lambda (binding)
+         (cadr binding)))
+
+       ;;!(function bind-get-new-exp
+       ;;          (form (bind-get-new-exp binding) -> exp)
+       ;;          (contract binding -> exp))
+       ;; This is just an accessor function for a binding.  This function
+       ;; returns the new symbol that will represent the expression.
+       (bind-get-new-exp 
+        (lambda (binding)
+         (caddr binding)))
+
+       ;;!(function subst-bindings
+       ;;          (form (subst-bindings exp-stx let-bound) -> syntax)
+       ;;          (contract (syntax list) -> syntax)
+       ;;          (example (subst-bindings (syntax (car (cdr x))) 
+       ;;                                   (list (list '(cdr x) 
+       ;;                                                (syntax (cdr x)) 
+       ;;                                                'exp5)))
+       ;;                   -> (syntax (car 'exp5))))
+       ;; This function substitutes let bound variables names for the
+       ;; expressions that they represent.
+       (subst-bindings 
+        (lambda (exp-stx let-bound)
+          (let* ((exp (syntax-object->datum exp-stx))
+                 (binding (get-bind exp let-bound)))
+            (if binding
+                (bind-get-new-exp binding)
+                (sub-expr-subst exp-stx let-bound)))))
+
+       ;;!(function sub-exp-subst
+       ;;          (form (sub-exp-subst exp-stx let-bound) -> syntax)
+       ;;          (contract (syntax list) -> syntax)
+       ;;          (example (subst-bindings (syntax (car (cdr x))) 
+       ;;                                   (list (list '(cdr x) 
+       ;;                                         (syntax (cdr x)) 
+       ;;                                         'exp5)))
+       ;;                   -> (syntax (car 'exp5))))
+       ;; This function substitutes let bound variables names for the
+       ;; expressions that they represent. This only works if a
+       ;; subexpression of exp-stx is bound in the let-bound list.
+       (sub-expr-subst 
+        (lambda (exp-stx let-bound)
+          (syntax-case exp-stx ()
+            ((access sub-exp rest ...)
+             (let ((binding (get-bind 
+                             (syntax-object->datum (syntax sub-exp)) 
+                             let-bound)))
+               (if binding
+                   (quasisyntax/loc 
+                    exp-stx (access #,(bind-get-new-exp binding) rest ...))
+                   (quasisyntax/loc 
+                    exp-stx (access #,(sub-expr-subst (syntax sub-exp) 
+                                                      let-bound) 
+                                    rest ...)))))
+            (other (syntax other)))))
+
+        ;;!(function get-bind
+        ;;          (form (get-bind exp let-bound) -> binding)
+        ;;          (contract (any list) -> list))
+        ;; This function looks up the binding for a given expression exp
+        ;; in the binding list let-bound.  If the binding is found then the
+        ;; binding is returned if not then #f is returned.
+        (get-bind 
+         (lambda (exp let-bound)
+           (cond ((null? let-bound) #f)
+                 ((equal? exp (bind-get-exp (car let-bound))) (car let-bound))
+                 (else (get-bind exp (cdr let-bound))))))
+
+        ;;!(function exp-already-bound?
+        ;;          (form (exp-already-bound? exp let-bound) -> binding)
+        ;;          (contract (any list) -> list))
+        ;; This function looks up the binding for a given expression exp
+        ;; in the binding list let-bound.  If the binding is found then #t
+        ;; binding is returned if not then #f is returned.
+        (exp-already-bound? 
+         (lambda (exp let-bound)
+           (cond ((null? let-bound) #f)
+                 ((equal? exp (bind-get-exp (car let-bound))) #t)
+                 (else (exp-already-bound? exp (cdr let-bound))))))
+
+        ;;!(function meta-couple
+        ;;          (form (meta-couple rendered-list failure-func 
+        ;;                             let-bound bvsf)
+        ;;                ->
+        ;;                ((list list) -> syntax))
+        ;;          (contract (list ((list list) -> syntax) list list)
+        ;;                    ->
+        ;;                    ((list list) -> syntax)))
+        ;; This function takes a list of rendered clauses which also have
+        ;; success functions attached and couples the whole lot together
+        ;; yeilding one function that when invoked will compile the whole
+        ;; original match expression.
+        (meta-couple
+         (lambda (rendered-list failure-func let-bound bvsf)
+         ;; here we are going to tag the rendered-list before moving on
+           (let* ((count 0)
+                  (rendered-list 
+                   (map (lambda (x)
+                          (begin
+                            (set! count (add1 count))
+                            (cons count x)))
+                        rendered-list)))
+             (meta-couple-help rendered-list failure-func let-bound bvsf))))
+        ;; so the shape of the data is ((index test-list . success-func) ...)
+        (tests-index (lambda (x) (car x)))
+        (tests-list (lambda (x) (cadr x)))
+        (tests-succ-func (lambda (x) (cddr x)))
+        (no-group? (lambda (x) (<= (length (test-used-set x)) 1)))
+
+        (meta-couple-help
+         (lambda (rendered-list failure-func let-bound bvsf)
+            (cond ((null? rendered-list) failure-func)
+                  ;; if the top list is null
+                  ;; or the first item of the top list
+                  ;; has no group associated with it
+                  ;; or is a negate test 
+                  ;; handle list normally
+                  ((let ((tlist (tests-list (car rendered-list))))
+                     (or (null? tlist)
+                         (or (negate-test? (car tlist))
+                             (no-group? (car tlist)))))
+                   ;; here we erase the previously bound (bv) variables
+                   (let* ((failed 
+                           (lambda (let-bound)
+                             (lambda (sf bv)
+                               ((meta-couple-help (cdr rendered-list) 
+                                                  failure-func 
+                                                  let-bound 
+                                                  bvsf) sf bvsf)))))
+                     (couple-tests (tests-list (car rendered-list))
+                                   (tests-succ-func (car rendered-list)) ;; successfunc needs 
+                                   ;; failure method
+                                   failed ;; needs let-bound
+                                   let-bound ;; initial-let bindings
+                                   )))
+                  (else
+                   (let ((upper-left-test
+                          (car (tests-list (car rendered-list)))))
+                     (let-values (((top-group remainder-of-list)
+                                   (lift-out-group (test-used-set 
+                                                    upper-left-test)
+                                                   rendered-list)))
+                       (let* ((failed
+                               (lambda (let-bound)
+                                 (lambda (sf bv)
+                                   ((meta-couple-help remainder-of-list
+                                                      failure-func
+                                                      let-bound
+                                                      bvsf) sf bvsf)))))
+                         (couple-tests (list upper-left-test)
+                                       (lambda (fail let-bound)
+                                         (lambda (sf bv)
+                                           ((meta-couple-help
+                                             (cons
+                                              (cons (tests-index (car top-group))
+                                                    (cons
+                                                     (cdr (tests-list (car top-group)))
+                                                     (tests-succ-func (car top-group))))
+                                              (map
+                                               (lambda (tests)
+                                                 (cons
+                                                  (tests-index tests)
+                                                  (cons 
+                                                   (eliminate-test-from-list 
+                                                    upper-left-test
+                                                    (tests-list tests)
+                                                    )
+                                                   (tests-succ-func tests))))
+                                               (cdr top-group)))
+                                             fail
+                                             let-bound
+                                             bv)
+                                            sf bv)))
+                                       failed
+                                       let-bound))))))))
+
+
+        ;; returns a list containing the separated group and the 
+        ;; the rest of the rendered list
+        (lift-out-group
+         (lambda (group-list rendered-list)
+           (let loop ((rl rendered-list)
+                      (k (lambda (grp rest)
+                           (values grp rest))))
+             (when (null? group-list) (error 'null-group-list))
+             (if (null? rl)
+                 (k '() '())
+                 (if (member (caar rl) group-list)
+                     (loop (cdr rl)
+                           (lambda (g r)
+                             (k (cons (car rl) g) 
+                                r)))
+                     (loop (cdr rl)
+                           (lambda (g r)
+                             (k g
+                                (cons (car rl) r)))))))))
+        
+        (eliminate-test-from-list
+         (lambda (test tl)
+            (filter 
+             (lambda (t)
+               (or (action-test? t)
+                   (not (in (test-tst t) (list (test-tst test))))))
+             tl)))
+
+        )
+    (values couple-tests meta-couple subst-bindings)))
\ No newline at end of file
diff --git a/collects/mzlib/private/plt-match/coupling-and-binding.scm b/collects/mzlib/private/plt-match/coupling-and-binding.scm
new file mode 100644
index 0000000000..6df396bf43
--- /dev/null
+++ b/collects/mzlib/private/plt-match/coupling-and-binding.scm
@@ -0,0 +1,203 @@
+;; This library is used by match.ss
+
+(define-values (couple-tests meta-couple subst-bindings)
+  (letrec 
+      (
+       ;;!(function couple-tests
+       ;;          (form (couple-tests test-list ks-func kf-func let-bound)
+       ;;                ->
+       ;;                ((list list) -> syntax))
+       ;;          (contract (list
+       ;;                     ((((list list) -> syntax) list) -> 
+       ;;                      ((list list) -> syntax))
+       ;;                     (list -> ((list list) -> syntax))
+       ;;                     list)
+       ;;                    ->
+       ;;                    ((list list) -> syntax)))
+       ;; This is a major function of the compiler.  This function
+       ;; couples a list of tests together.  Here is where state is
+       ;; passed around to the various partially compiled tests so that
+       ;; compilation can be completed.  This returns a function that takes a
+       ;; list of tests so far and a list of bound pattern variables.
+       (couple-tests
+        (lambda (test-list ks-func kf-func let-bound)
+          (if (null? test-list)
+              (ks-func (kf-func let-bound) let-bound)
+              (let ((cur-test (car test-list)))
+                (if (and (>= (test-bind-count cur-test) 2)
+                         (not (exp-already-bound?
+                               (test-bind-exp cur-test)
+                               let-bound))) ;; if it is member of
+                    ;;let-bound skip it
+                    (let* ((new-exp (get-exp-var))
+                           (binding (list (test-bind-exp cur-test)
+                                          (test-bind-exp-stx cur-test)
+                                          new-exp))
+                           (let-bound (cons binding
+                                            let-bound))
+                           (kf (kf-func let-bound)))
+                      (lambda (sf bv)
+                        (quasisyntax/loc
+                         (test-bind-exp-stx cur-test)
+                         (let ((#,new-exp
+                                #,(sub-expr-subst (bind-get-exp-stx binding)
+                                                  let-bound)))
+                           #,(((test-comp (car test-list)) 
+                               (couple-tests (cdr test-list)
+                                             ks-func
+                                             (if (negate-test? cur-test) 
+                                                 (lambda (let-bound)
+                                                   (lambda (sf bv)
+                                                     (quasisyntax/loc
+                                                      (test-bind-exp-stx cur-test)
+                                                      (match-failure))))
+                                                 kf-func)
+                                             ;kf-func
+                                             let-bound) 
+                               kf let-bound) sf bv)))))
+                    (let* ((kf (kf-func let-bound)))
+                      ((test-comp (car test-list)) 
+                       (couple-tests (cdr test-list)
+                                     ks-func
+                                     (if (negate-test? cur-test) 
+                                         (lambda (let-bound)
+                                           (lambda (sf bv)
+                                             (quasisyntax/loc
+                                              (test-bind-exp-stx cur-test)
+                                              (match-failure))))
+                                         kf-func) 
+                                        ;kf-func
+                                     let-bound) 
+                       kf 
+                       let-bound)))))))
+
+       ;;!(function bind-get-exp
+       ;;          (form (bind-get-exp binding) -> exp)
+       ;;          (contract binding -> exp))
+       ;; This is just an accessor function for a binding.  This function
+       ;; returns the expression that is bound in s-exp form.
+       (bind-get-exp 
+        (lambda (binding)
+          (car binding)))
+
+       ;;!(function bind-get-exp-stx
+       ;;          (form (bind-get-exp-stx binding) -> exp)
+       ;;          (contract binding -> exp))
+       ;; This is just an accessor function for a binding.  This function
+       ;; returns the expression that is bound in syntax form.
+       (bind-get-exp-stx 
+        (lambda (binding)
+         (cadr binding)))
+
+       ;;!(function bind-get-new-exp
+       ;;          (form (bind-get-new-exp binding) -> exp)
+       ;;          (contract binding -> exp))
+       ;; This is just an accessor function for a binding.  This function
+       ;; returns the new symbol that will represent the expression.
+       (bind-get-new-exp 
+        (lambda (binding)
+         (caddr binding)))
+
+       ;;!(function subst-bindings
+       ;;          (form (subst-bindings exp-stx let-bound) -> syntax)
+       ;;          (contract (syntax list) -> syntax)
+       ;;          (example (subst-bindings (syntax (car (cdr x))) 
+       ;;                                   (list (list '(cdr x) 
+       ;;                                                (syntax (cdr x)) 
+       ;;                                                'exp5)))
+       ;;                   -> (syntax (car 'exp5))))
+       ;; This function substitutes let bound variables names for the
+       ;; expressions that they represent.
+       (subst-bindings 
+        (lambda (exp-stx let-bound)
+          (let* ((exp (syntax-object->datum exp-stx))
+                 (binding (get-bind exp let-bound)))
+            (if binding
+                (bind-get-new-exp binding)
+                (sub-expr-subst exp-stx let-bound)))))
+
+       ;;!(function sub-exp-subst
+       ;;          (form (sub-exp-subst exp-stx let-bound) -> syntax)
+       ;;          (contract (syntax list) -> syntax)
+       ;;          (example (subst-bindings (syntax (car (cdr x))) 
+       ;;                                   (list (list '(cdr x) 
+       ;;                                         (syntax (cdr x)) 
+       ;;                                         'exp5)))
+       ;;                   -> (syntax (car 'exp5))))
+       ;; This function substitutes let bound variables names for the
+       ;; expressions that they represent. This only works if a
+       ;; subexpression of exp-stx is bound in the let-bound list.
+       (sub-expr-subst 
+        (lambda (exp-stx let-bound)
+          (syntax-case exp-stx ()
+            ((access sub-exp rest ...)
+             (let ((binding (get-bind 
+                             (syntax-object->datum (syntax sub-exp)) 
+                             let-bound)))
+               ;;(write (syntax sub-exp))(newline) (write binding)(newline)
+               (if binding
+                   (quasisyntax/loc 
+                    exp-stx (access #,(bind-get-new-exp binding) rest ...))
+                   (quasisyntax/loc 
+                    exp-stx (access #,(sub-expr-subst (syntax sub-exp) 
+                                                      let-bound) 
+                                    rest ...)))))
+            (other (syntax other)))))
+
+        ;;!(function get-bind
+        ;;          (form (get-bind exp let-bound) -> binding)
+        ;;          (contract (any list) -> list))
+        ;; This function looks up the binding for a given expression exp
+        ;; in the binding list let-bound.  If the binding is found then the
+        ;; binding is returned if not then #f is returned.
+        (get-bind 
+         (lambda (exp let-bound)
+           (cond ((null? let-bound) #f)
+                 ((equal? exp (bind-get-exp (car let-bound))) (car let-bound))
+                 (else (get-bind exp (cdr let-bound))))))
+
+        ;;!(function exp-already-bound?
+        ;;          (form (exp-already-bound? exp let-bound) -> binding)
+        ;;          (contract (any list) -> list))
+        ;; This function looks up the binding for a given expression exp
+        ;; in the binding list let-bound.  If the binding is found then #t
+        ;; binding is returned if not then #f is returned.
+        (exp-already-bound? 
+         (lambda (exp let-bound)
+           ;;(write exp) (newline) (write let-bound)(newline)
+           (cond ((null? let-bound) #f)
+                 ((equal? exp (bind-get-exp (car let-bound))) #t)
+                 (else (exp-already-bound? exp (cdr let-bound))))))
+
+        ;;!(function meta-couple
+        ;;          (form (meta-couple rendered-list failure-func 
+        ;;                             let-bound bvsf)
+        ;;                ->
+        ;;                ((list list) -> syntax))
+        ;;          (contract (list ((list list) -> syntax) list list)
+        ;;                    ->
+        ;;                    ((list list) -> syntax)))
+        ;; This function takes a list of rendered clauses which also have
+        ;; success functions attached and couples the whole lot together
+        ;; yeilding one function that when invoked will compile the whole
+        ;; original match expression.
+        (meta-couple
+         (lambda (rendered-list failure-func let-bound bvsf)
+           (if (null? rendered-list)
+               failure-func
+               ;; here we erase the previously bound variables
+               (let* ((failed 
+                       (lambda (let-bound)
+                         (lambda (sf bv)
+                           ((meta-couple (cdr rendered-list) 
+                                         failure-func 
+                                         let-bound 
+                                         bvsf) sf bvsf)))))
+                 (couple-tests (caar rendered-list)
+                               (cdar rendered-list) ;; successfunc needs 
+                               ;; failure method
+                               failed ;; needs let-bound
+                               let-bound ;; initial-let bindings
+                               )))))      ;; fail-func
+        )
+    (values couple-tests meta-couple subst-bindings)))
\ No newline at end of file
diff --git a/collects/mzlib/private/plt-match/ddk-handlers.scm b/collects/mzlib/private/plt-match/ddk-handlers.scm
new file mode 100644
index 0000000000..4a3536840d
--- /dev/null
+++ b/collects/mzlib/private/plt-match/ddk-handlers.scm
@@ -0,0 +1,653 @@
+;; This library is used by match.ss
+
+(define (get-bind-val b-var bv-list)
+  (let ((res (assq
+              b-var
+              bv-list)))
+    (if res (cdr res)
+        (let ((res 
+               (assq
+                (syntax-object->datum b-var)
+                (map (lambda (x)
+                       (cons 
+                        (syntax-object->datum (car x)) (cdr x))) 
+                     bv-list))))
+          (if res (cdr res) (error 'var-not-found))))))
+
+
+;;!(function handle-end-ddk-list
+;;          (form (handle-end-ddk-list ae kf ks pat
+;;                                     dot-dot-k stx
+;;                                     let-bound)
+;;                ->
+;;                ((list list) -> syntax))
+;;          (contract (syntax
+;;                     ((list list) -> syntax)
+;;                     ((list list) -> syntax)
+;;                     syntax
+;;                     syntax
+;;                     syntax
+;;                     list)
+;;                    ->
+;;                    ((list list) -> syntax)))
+;; This returns a function which generates the code for
+;; a pattern that ends with a ddk. This function is only applied to the
+;; last pattern and the ddk.
+;; Args:
+;; ae - the expression being matched
+;; kf - a failure function
+;; ks - a success function
+;; pat - the pattern to be matched repeatedly
+;; dot-dot-k - the ddk pattern
+;; stx - the source stx for error purposes
+;; let-bound - a list of let bindings
+(define handle-end-ddk-list
+  (lambda (ae kf ks pat dot-dot-k stx let-bound)
+    (lambda (sf bv)
+      (let* ((k (stx-dot-dot-k? dot-dot-k))
+             (ksucc (lambda (sf bv) 
+                      (let ((bound (getbindings pat)))
+                           (if (syntax? bound)
+                               (kf sf bv)
+                               (syntax-case pat (_)
+                                 (_ (ks sf bv))
+                                 (the-pat
+                                  (null? bound)
+                                  (with-syntax ((exp-sym (syntax exp-sym)))
+                                    (let* ((ptst (next-outer
+                                                  pat
+                                                  (syntax exp-sym)
+                                                  sf
+                                                  bv
+                                                  let-bound
+                                                  (lambda (sf bv) (syntax #f))
+                                                  (lambda (sf bv) (syntax #t))))
+                                           (tst (syntax-case ptst ()
+                                                  ((pred eta)
+                                                   (and (identifier?
+                                                         (syntax pred))
+                                        ;free-identifier=?
+                                                        (stx-equal?
+                                                         (syntax eta)
+                                                         (syntax exp-sym)))
+                                                   (syntax pred))
+                                                  (whatever
+                                                   (quasisyntax/loc 
+                                                    stx 
+                                                    (lambda (exp-sym)
+                                               #,ptst))))))
+                                      (assm (quasisyntax/loc 
+                                             stx 
+                                             (andmap #,tst 
+                                                     #,(subst-bindings ae let-bound)))
+                                            (kf sf bv)
+                                            (ks sf bv)))))
+                                 (id
+                                  (and (identifier? (syntax id))
+                                       (stx-equal? (syntax id)
+                                                   (car bound)))
+                                  (next-outer (syntax id) ae sf bv let-bound kf ks))
+                                 (the-pat
+                                  (let ((binding-list-names
+                                         (map (lambda (x)
+                                                (datum->syntax-object
+                                                 (quote-syntax here)
+                                                 (symbol-append
+                                                  (gensym (syntax-object->datum x))
+                                           '-bindings)))
+                                              bound))
+                                        (loop-name (quasisyntax/loc 
+                                                    (syntax the-pat) 
+                                                    #,(gensym 'loop)))
+                                        (exp-name (quasisyntax/loc 
+                                                   (syntax the-pat) 
+                                                   #,(gensym 'exp))))
+                                    (quasisyntax/loc
+                                     stx
+                                     (let #,loop-name
+                                       ((#,exp-name #,(subst-bindings ae let-bound))
+                                        #,@(map
+                                            (lambda (x)
+                                              (quasisyntax/loc
+                                               stx
+                                               (#,x '())))
+                                            binding-list-names))
+                                       (if (null? #,exp-name)
+                                           #,(ks sf
+                                                 (append
+                                                  (map cons
+                                                       bound
+                                                       (map
+                                                        (lambda (x)
+                                                          (quasisyntax/loc 
+                                                           stx 
+                                                           (reverse #,x)))
+                                                        binding-list-names))
+                                                  bv))
+                                           #,(next-outer (syntax the-pat)
+                                                         (quasisyntax/loc 
+                                                          (syntax the-pat) 
+                                                          (car #,exp-name))
+                                                         sf
+                                                         bv  ;; we always start
+                                                         ;; over with the old
+                                                         ;; bindings
+                                                         let-bound
+                                                         kf
+                                                         (lambda (sf bv)
+                                                           (quasisyntax/loc
+                                                            stx
+                                                            (#,loop-name
+                                                             (cdr #,exp-name)
+                                                             #,@(map
+                                                                 (lambda
+                                                                     (b-var
+                                                                      bindings-var)
+                                                                   (quasisyntax/loc
+                                                                    stx
+                                                                    (cons
+                                                                     #,(get-bind-val
+                                                                        b-var
+                                                                        bv)
+                                                                     #,bindings-var)))
+                                                                 bound binding-list-names))))))))))))))))
+           (case k
+             ((0) (ksucc sf bv))
+             ((1) (emit (lambda (exp) (quasisyntax/loc stx (pair? #,exp)))
+                        ae
+                        let-bound
+                        sf bv kf ksucc))
+             (else (emit (lambda (exp) (quasisyntax/loc stx (>= (length #,exp) #,k)))
+                         ae
+                         let-bound
+                         sf bv kf ksucc)))))))
+
+;;!(function handle-inner-ddk-list
+;;          (form (handle-inner-ddk-list ae kf ks pat
+;;                                     dot-dot-k pat-rest stx
+;;                                     let-bound)
+;;                ->
+;;                ((list list) -> syntax))
+;;          (contract (syntax
+;;                     ((list list) -> syntax)
+;;                     ((list list) -> syntax)
+;;                     syntax
+;;                     syntax
+;;                     syntax
+;;                     syntax
+;;                     list)
+;;                    ->
+;;                    ((list list) -> syntax)))
+;; This returns a function which generates the code for a list
+;; pattern that contains with a ddk that occurs before the end of
+;; the list. This code is extremely similar to the code in
+;; handle-end-ddk-list but there are enough differences to warrant
+;; having a separate method for readability.
+;; Args:
+;; ae - the expression being matched
+;; kf - a failure function
+;; ks - a success function
+;; pat - the pattern that preceeds the ddk
+;; dot-dot-k - the ddk pattern
+;; pat-rest - the rest of the list pattern that occurs after the ddk
+;; stx - the source stx for error purposes
+;; let-bound - a list of let bindings
+(define handle-inner-ddk-list
+  (lambda (ae kf ks pat dot-dot-k pat-rest stx let-bound)
+    (lambda (sf bv)
+      (let* ((k (stx-dot-dot-k? dot-dot-k)))
+           (let ((bound (getbindings pat)))
+             (if (syntax? bound)
+                 (kf sf bv)
+                 (syntax-case pat (_)
+                   (_
+                    (stx-null? pat-rest)
+                    (ks sf bv))
+                   (the-pat
+                    (null? bound)
+                    (with-syntax ((exp-sym (syntax exp-sym)))
+                      (let* ((ptst (next-outer
+                             pat
+                             (syntax exp-sym)
+                             sf
+                             bv
+                             let-bound
+                             (lambda (sf bv) (syntax #f))
+                             (lambda (sf bv) (syntax #t))))
+                      (tst (syntax-case ptst ()
+                             ((pred eta)
+                              (and (identifier?
+                                    (syntax pred))
+                                        ;free-identifier=?
+                                   (stx-equal?
+                                    (syntax eta)
+                                    (syntax exp-sym)))
+                              (syntax pred))
+                             (whatever
+                              (quasisyntax/loc stx (lambda (exp-sym)
+                                                     #,ptst)))))
+                      (loop-name (gensym 'ddnnl))
+                      (exp-name (gensym 'exp))
+                      (count-name (gensym 'count)))
+                 (quasisyntax/loc
+                  (syntax the-pat)
+                  (let #,loop-name ((#,exp-name 
+                                     #,(subst-bindings ae let-bound))
+                                    (#,count-name 0))
+                       (if (and (not (null? #,exp-name))
+                                ;; added for improper ddk
+                                (pair? #,exp-name)
+                                (#,tst (car #,exp-name)))
+                           (#,loop-name (cdr #,exp-name) 
+                                        (add1 #,count-name))
+                           ;; testing the count is not neccessary 
+                           ;; if the count is zero
+                           #,(let ((succ (next-outer
+                                          pat-rest
+                                          (quasisyntax/loc
+                                           (syntax the-pat) #,exp-name)
+                                          sf
+                                          bv
+                                          let-bound
+                                          kf
+                                          ks)))
+                               (if (zero? k)
+                                   succ
+                                   (quasisyntax/loc
+                                    (syntax the-pat)
+                                    (if (>= #,count-name #,k)
+                                        #,succ
+                                        #,(kf sf bv)))))))))))
+            (the-pat
+             (let* ((binding-list-names
+                     (map (lambda (x)
+                            (datum->syntax-object
+                             (quote-syntax here)
+                             (symbol-append
+                              (gensym (syntax-object->datum x))
+                              '-bindings)))
+                          bound))
+                    (loop-name (quasisyntax/loc 
+                                (syntax the-pat) 
+                                #,(gensym 'loop)))
+                    (exp-name (quasisyntax/loc 
+                               (syntax the-pat) 
+                               #,(gensym 'exp)))
+                    (fail-name (quasisyntax/loc 
+                                (syntax the-pat) 
+                                #,(gensym 'fail)))
+                    (count-name (quasisyntax/loc 
+                                 (syntax the-pat) 
+                                 #,(gensym 'count)))
+                    (new-bv (append
+                             (map cons
+                                  bound
+                                  (map
+                                   (lambda (x)
+                                     (quasisyntax/loc stx (reverse #,x)))
+                                   binding-list-names)) bv)))
+               (quasisyntax/loc
+                (syntax the-pat)
+                (let #,loop-name
+                  ((#,exp-name #,(subst-bindings ae let-bound))
+                   (#,count-name 0)
+                   #,@(map
+                       (lambda (x) (quasisyntax/loc 
+                                    (syntax the-pat) 
+                                    (#,x '())))
+                       binding-list-names))
+                  (let ((#,fail-name
+                         (lambda ()
+                           #,(let ((succ (next-outer
+                                          pat-rest
+                                          (quasisyntax/loc 
+                                           (syntax the-pat) 
+                                           #,exp-name)
+                                          sf
+                                          new-bv
+                                          let-bound
+                                          kf
+                                          ks)))
+                               (if (zero? k)
+                                   succ
+                                   (quasisyntax/loc 
+                                    (syntax the-pat) 
+                                    (if (>= #,count-name #,k)
+                                        #,succ
+                                        #,(kf sf new-bv))))))))
+                    (if (or (null? #,exp-name)
+                            (not (pair? #,exp-name)))
+                        (#,fail-name)
+                        #,(next-outer (syntax the-pat)
+                                      (quasisyntax/loc 
+                                       (syntax the-pat) 
+                                       (car #,exp-name))
+                                      sf
+                                      bv  ;; we always start
+                                      ;; over with the old
+                                      ;; bindings
+                                      let-bound
+                                      (lambda (sf bv)
+                                        (quasisyntax/loc 
+                                         (syntax the-pat) 
+                                         (#,fail-name)))
+                                      (lambda (sf bv)
+                                        (quasisyntax/loc
+                                         stx
+                                         (#,loop-name
+                                          (cdr #,exp-name)
+                                          (add1 #,count-name)
+                                          #,@(map
+                                              (lambda
+                                                  (b-var
+                                                   bindings-var)
+                                                (quasisyntax/loc 
+                                                 stx 
+                                                 (cons
+                                                  #,(get-bind-val
+                                                      b-var
+                                                      bv)
+                                                  #,bindings-var)))
+                                              bound
+                                              binding-list-names))))))))))))))))))
+;;!(function handle-ddk-vector
+;;          (form (handle-ddk-vector ae kf ks pt let-bound)
+;;                ->
+;;                ((list list) -> syntax))
+;;          (contract (syntax
+;;                     ((list list) -> syntax)
+;;                     ((list list) -> syntax)
+;;                     syntax
+;;                     list)
+;;                    ->
+;;                    ((list list) -> syntax)))
+;; This returns a function which generates the code for a vector
+;; pattern that contains a ddk that occurs at the end of the
+;; vector.
+;; Args:
+;; ae - the expression being matched
+;; kf - a failure function
+;; ks - a success function
+;; pt - the whole vector pattern
+;; let-bound - a list of let bindings
+(define handle-ddk-vector
+  (lambda (ae kf ks pt stx let-bound)
+    (let* ((vec-stx (syntax-e pt))
+           (vlen (- (vector-length vec-stx) 2)) ;; length minus
+           ;; the pat ...
+           (k (stx-dot-dot-k? (vector-ref vec-stx (add1 vlen))))
+           (minlen (+ vlen k))
+           ;; get the bindings for the second to last element:
+           ;; 'pat' in pat ...
+           (bound (getbindings (vector-ref vec-stx vlen)))
+           (exp-name (gensym 'exnm)))
+      (lambda (sf bv)
+        (if (syntax? bound)
+            (kf sf bv)
+        (quasisyntax/loc
+         pt
+         (let ((#,exp-name #,(subst-bindings ae let-bound)))
+           #,(assm (quasisyntax/loc
+                    stx
+                    (>= (vector-length #,exp-name) #,minlen))
+                   (kf sf bv)
+                   ((let vloop ((n 0))
+                      (lambda (sf bv)
+                        (cond
+                         ((not (= n vlen))
+                          (next-outer
+                           (vector-ref vec-stx n)
+                           (quasisyntax/loc
+                            stx
+                            (vector-ref #,exp-name #,n))
+                           sf
+                           bv
+                           let-bound
+                           kf
+                           (vloop (+ 1 n))))
+                         ((eq? (syntax-object->datum
+                                (vector-ref vec-stx vlen))
+                               '_)
+                          (ks sf bv))
+                         (else
+                          (let* ((binding-list-names
+                                  (map (lambda (x)
+                                         (datum->syntax-object
+                                          (quote-syntax here)
+                                          (symbol-append
+                                           (gensym (syntax-object->datum x))
+                                           '-bindings)))
+                                       bound))
+                                 (vloop-name (gensym 'vloop))
+                                 (index-name (gensym 'index)))
+                            (quasisyntax/loc
+                             stx
+                             (let #,vloop-name
+                               ((#,index-name (- (vector-length #,exp-name) 1))
+                                #,@(map (lambda (x) 
+                                          (quasisyntax/loc stx (#,x '())))
+                                        binding-list-names))
+                               (if (> #,vlen #,index-name)
+                                   #,(ks sf
+                                         (append (map cons bound
+                                                      binding-list-names)
+                                                 bv))
+                                   #,(next-outer
+                                      (vector-ref vec-stx n)
+                                      (quasisyntax/loc
+                                       stx
+                                       (vector-ref #,exp-name #,index-name))
+                                      sf
+                                      bv ;; we alway start over
+                                      ;; with the old bindings
+                                      let-bound
+                                      kf
+                                      (lambda (sf bv)
+                                        (quasisyntax/loc
+                                         stx (#,vloop-name
+                                              (- #,index-name 1)
+                                              #,@(map
+                                                  (lambda (b-var
+                                                           bindings-var)
+                                                    (quasisyntax/loc
+                                                     stx
+                                                     (cons
+                                                      #,(get-bind-val
+                                                          b-var
+                                                          bv)
+                                                      #,bindings-var)))
+                                                  bound
+                                                  binding-list-names)))))))))))))
+                    sf
+                    bv)))))))))
+
+;;!(function handle-ddk-vector-inner
+;;          (form (handle-ddk-vector-inner ae kf ks pt let-bound)
+;;                ->
+;;                ((list list) -> syntax))
+;;          (contract (syntax
+;;                     ((list list) -> syntax)
+;;                     ((list list) -> syntax)
+;;                     syntax
+;;                     list)
+;;                    ->
+;;                    ((list list) -> syntax)))
+;; This returns a function which generates the code for a vector
+;; pattern that contains a ddk that occurs before another pattern
+;; in the list.
+;; Args:
+;; ae - the expression being matched
+;; kf - a failure function
+;; ks - a success function
+;; pt - the whole vector pattern
+;; let-bound - a list of let bindings
+(define handle-ddk-vector-inner
+  (lambda (ae kf ks pt stx let-bound)
+    (let* ((vec-stx (syntax-e pt))
+           ;; vlen as an index points at the pattern before the ddk
+           (vlen (- (vector-length vec-stx) 2)) ;; length minus
+           ;; the pat ...
+           (vec-len (vector-length vec-stx))
+           (total-k (ddk-in-vec? vec-stx pt))
+           ;; (k (stx-dot-dot-k? (vector-ref vec-stx (add1 vlen))))
+           (minlen (+ vec-len total-k))
+           (length-of-vector-name (gensym 'lv))
+           (exp-name (gensym 'exnm)))
+      ;; get the bindings for the second to last element:
+      ;; 'pat' in pat ...
+      ;;(bound (getbindings (vector-ref vec-stx vlen))))
+      ;; we have to look at the first pattern and see if a ddk follows it
+      ;; if so handle that case else handle the pattern
+      (lambda (sf bv)
+        ;; minlen here could be the lentgh plus the k's - 1 for each ddk
+        (quasisyntax/loc
+         pt
+         (let ((#,exp-name #,(subst-bindings ae let-bound)))
+           (let ((#,length-of-vector-name (vector-length #,exp-name)))
+             #,(assm (quasisyntax/loc pt (>= #,length-of-vector-name #,minlen))
+                     (kf sf bv)
+                     (let ((current-index-name (gensym 'curr-ind)))
+                       (quasisyntax/loc
+                        pt
+                        (let ((#,current-index-name 0))
+                          #,((let vloop ((n 0)
+                                         (count-offset-name-passover 
+                                          current-index-name))
+                               (lambda (sf bv)
+
+                                 (cond
+                                  ((= n vec-len) ;; at the end of the patterns
+                                   (quasisyntax/loc
+                                    pt
+                                    (if (>= #,count-offset-name-passover
+                                            #,length-of-vector-name)
+                                        #,(ks sf bv)
+                                        #,(kf sf bv))))
+                                  ((stx-dot-dot-k? (vector-ref vec-stx n))  
+                                   ;;this could be it
+                                   (match:syntax-err
+                                    stx
+                                    "should not get here"))
+                                  ;; if the next one is not a ddk do a normal pattern match
+                                  ;; on element
+                                  ((or (= n (sub1 vec-len))
+                                       (not (stx-dot-dot-k? (vector-ref vec-stx
+                                                                        (add1 n)))))
+                                   (quasisyntax/loc
+                                    pt
+                                    (if (= #,count-offset-name-passover
+                                           #,length-of-vector-name)
+                                        #,(kf sf bv)
+                                        #,(next-outer
+                                           (vector-ref vec-stx n) ;this could be it
+                                           (quasisyntax/loc
+                                            stx
+                                            (vector-ref #,exp-name #,count-offset-name-passover))
+                                           '() ;we don't want these tests to take part in future
+                                        ; elimination or to be eliminated
+                                           bv
+                                           let-bound
+                                           kf
+                                           (lambda (bsf bv)
+                                        ;(set! current-index-name #`(add1 #,current-index-name))
+                                             (let ((cindnm (gensym 'cindnm)))
+                                               (quasisyntax/loc
+                                                pt
+                                                (let ((#,cindnm (add1 #,count-offset-name-passover)))
+                                                  #,((vloop (+ 1 n) cindnm) sf bv)))))))))
+                                  ((and (eq? (syntax-object->datum
+                                              (vector-ref vec-stx n)) ;this could be it
+                                             '_)
+                                        (>= (- vec-len n 1)
+                                            (stx-dot-dot-k? (vector-ref vec-stx (add1 n)))))
+                                   (ks sf bv))
+                                  (else  ;; we now know that the next pattern is a ddk
+                                   (let ((bound (getbindings (vector-ref vec-stx n))))
+                                     (if (syntax? bound)
+                                         (kf sf bv)
+                                     (let* ((k (stx-dot-dot-k? (vector-ref vec-stx (add1 n))))
+                                            (binding-list-names
+                                             (map (lambda (x)
+                                                  (datum->syntax-object
+                                                   (quote-syntax here)
+                                                   (symbol-append
+                                                    (gensym (syntax-object->datum x))
+                                                    '-bindings)))
+                                                bound))
+                                          (vloop-name (gensym 'vloop))
+                                          (count-name (gensym 'count))
+                                          (index-name (gensym 'index)))
+                                     (quasisyntax/loc
+                                      stx
+                                      (let #,vloop-name
+                                        ((#,count-name #,count-offset-name-passover)
+                                         #,@(map (lambda (x) (quasisyntax/loc stx (#,x '())))
+                                                 binding-list-names))
+                                        #,(let ((fail-name (gensym 'fail))
+                                                (count-offset-name (gensym 'count-offset))
+                                                (index-name (gensym 'index))
+                                                )
+                                            (quasisyntax/loc
+                                             pt
+                                             (let ((#,fail-name
+                                                    (lambda (#,count-offset-name #,index-name)
+                                                      #,(let ((body ((vloop (+ n 2) index-name) sf
+                                                                     (append (map (lambda (b bln)
+                                                                                    (cons b
+                                                                                          (quasisyntax/loc
+                                                                                           pt
+                                                                                           (reverse #,bln))))
+                                                                                  bound
+                                                                                  binding-list-names)
+                                                                             bv)
+                                                                     )))
+                                                          (if (> k 0)
+                                                              (quasisyntax/loc
+                                                               pt
+                                                               (if (>= #,count-offset-name #,k)
+                                                                   #,body
+                                                                   #,(kf sf bv)))
+                                                              body)))))
+                                               (if (= #,length-of-vector-name #,count-name)
+                                                   (#,fail-name
+                                                    (- #,count-name #,count-offset-name-passover)
+                                                    #,count-name)
+                                                   #,(next-outer
+                                                      (vector-ref vec-stx n) ;this could be it
+                                                      (quasisyntax/loc
+                                                       stx
+                                                       (vector-ref #,exp-name #,count-name))
+                                                      '() ;sf
+                                                      bv ;; we alway start over
+                                                      ;; with the old bindings
+                                                      let-bound
+                                                      (lambda (sf bv)
+                                                        (quasisyntax/loc
+                                                         pt
+                                                         (#,fail-name
+                                                          (- #,count-name
+                                                             #,count-offset-name-passover)
+                                                          #,count-name)))
+                                                      (lambda (sf bv)
+                                                        (quasisyntax/loc
+                                                         stx
+                                                         (let ((arglist
+                                                                (list
+                                                                 #,@(map
+                                                                     (lambda (b-var
+                                                                              bindings-var)
+                                                                       (quasisyntax/loc
+                                                                        stx
+                                                                        (cons
+                                                                         #,(get-bind-val
+                                                                             b-var
+                                                                             bv)
+                                                                         #,bindings-var)))
+                                                                     bound
+                                                                     binding-list-names))))
+                                                           (apply
+                                                            #,vloop-name
+                                                            (add1 #,count-name)
+                                                            arglist))))))))))))))))))
+                             sf
+                             bv))))))))))))
diff --git a/collects/mzlib/private/plt-match/emit-assm.scm b/collects/mzlib/private/plt-match/emit-assm.scm
new file mode 100644
index 0000000000..eee3306130
--- /dev/null
+++ b/collects/mzlib/private/plt-match/emit-assm.scm
@@ -0,0 +1,94 @@
+;; This library is used by match.ss
+
+;;!(function emit
+;;          (form (emit act-test-func ae let-bound sf bv kf ks)
+;;                ->
+;;                syntax)
+;;          (contract ((syntax -> syntax)
+;;                     syntax
+;;                     list
+;;                     list
+;;                     list
+;;                     (list list -> syntax)
+;;                     (list list -> syntax))
+;;                    ->
+;;                    syntax))
+;; emit's true function is to manage the tests-seen-so-far lists
+;; it decides whether a new test needs to be added to the list
+;; or whether this condition has already been tested for and if
+;; it is true emit calls the success function. If it has been
+;; determined to be a false property emit calls the fail function.
+;; emit adds implied truths to the test seen so far list so that
+;; these truths can be checked against later.
+(define emit
+  (lambda (act-test-func ae let-bound sf bv kf ks)
+    (let ((test (syntax-object->datum (act-test-func ae))))
+      (cond
+       ((in test sf) (ks sf bv))
+       ((in `(not ,test) sf) (kf sf bv))
+       (else
+        (let* ((pred (car test))
+               (exp (cadr test))
+               (implied (implied test))
+               (not-imp
+                (if (equal? pred 'list?)
+                    (list `(not (null? ,exp)))
+                    '()))
+               (s (ks (cons test (append implied sf)) bv))
+               (k (kf (cons `(not ,test) (append not-imp sf)) bv))
+               (the-test (act-test-func (subst-bindings ae let-bound))))
+          (assm (syntax-case the-test (struct-pred)
+                  ((struct-pred pred parent-list exp) (syntax (pred exp)))
+                  (reg (syntax reg)))
+                k s))))))) 
+
+;;!(function assm
+;;          (form (assm tst main-fail main-succ) -> syntax)
+;;          (contract (syntax syntax syntax) -> syntax))
+;; assm - this function is responsible for constructing the actual
+;; if statements.  It performs minor expansion optimizations.
+(define assm
+  (lambda (tst main-fail main-succ)
+    (let ((s (syntax-object->datum main-succ))
+          (f (syntax-object->datum main-fail)))
+      ;; this is for match-count
+      ;;(write (syntax-object->datum tst))(newline)
+      (set! node-count (add1 node-count))
+      (cond ((equal? s f) 
+              (begin 
+                (when (equal? s '(match-failure))
+                   (set! node-count (sub1 node-count))
+                  ;(write 'here)(newline)
+                  '()
+                  )
+                main-succ))
+            ((and (eq? s #t) (eq? f #f)) tst)
+            (else
+             (syntax-case main-succ (if
+                                     and
+                                     call/ec
+                                     lambda
+                                     let) ;free-identifier=?  ;stx-equal?
+               ((if (and tsts ...) true-act fail-act)
+                (equal? f (syntax-object->datum (syntax fail-act)))
+                (quasisyntax/loc
+                 tst
+                 (if (and #,tst tsts ...) true-act fail-act)))
+               ((if tst-prev true-act fail-act)
+                (equal? f (syntax-object->datum (syntax fail-act)))
+                (quasisyntax/loc
+                 tst
+                 (if (and #,tst tst-prev) true-act fail-act)))
+               ((call/ec
+                 (lambda (k) (let ((fail (lambda () (_ f2)))) s2)))
+                (equal? f (syntax-object->datum (syntax f2)))
+                (quasisyntax/loc
+                 tst
+                 (call/ec
+                  (lambda (k)
+                    (let ((fail (lambda () (k #,main-fail))))
+                      #,(assm tst (syntax/loc tst (fail)) (syntax s2)))))))
+               ;; leaving out pattern that is never used in original
+               (_ (quasisyntax/loc
+                   tst
+                   (if #,tst #,main-succ #,main-fail)))))))))
diff --git a/collects/mzlib/private/plt-match/getter-setter.scm b/collects/mzlib/private/plt-match/getter-setter.scm
new file mode 100644
index 0000000000..f900e0ff9f
--- /dev/null
+++ b/collects/mzlib/private/plt-match/getter-setter.scm
@@ -0,0 +1,129 @@
+;; This library is used by match.ss
+
+;;!(function setter
+;;          (form (setter e ident let-bound) -> syntax)
+;;          (contract (syntax syntax list) -> syntax)
+;;          (example (setter (syntax (car x)) (syntax here) '())
+;;                   ->
+;;          (syntax (lambda (y) (set-car! x y)))))
+;; This function takes an expression and returns syntax which
+;; represents a function that is able to set the value that the
+;; expression points to.
+(define setter (lambda (e ident let-bound)
+                 (let ((mk-setter (lambda (s)
+                                    (symbol-append 'set- s '!))))
+                   (syntax-case e (vector-ref unbox car cdr)
+                     (p
+                      (not (stx-pair? (syntax p)))
+                      (match:syntax-err
+                       ident
+                       "set! pattern should be nested inside of a list, vector or box"))
+                     ((vector-ref vector index)
+                      (quasisyntax/loc
+                       ident
+                       (let ((x #,(subst-bindings (syntax vector)
+                                                  let-bound)))
+                         (lambda (y)
+                           (vector-set!
+                            x
+                            index
+                            y)))))
+                     ((unbox boxed)
+                      (quasisyntax/loc
+                       ident (let ((x #,(subst-bindings (syntax boxed)
+                                                        let-bound)))
+                               (lambda (y)
+                                 (set-box! x  y)))))
+                     ((car exp)
+                      (quasisyntax/loc
+                       ident
+                       (let ((x #,(subst-bindings (syntax exp)
+                                                  let-bound)))
+                         (lambda (y)
+                           (set-car! x y)))))
+                     ((cdr exp)
+                      (quasisyntax/loc
+                       ident
+                       (let ((x #,(subst-bindings (syntax exp)
+                                                  let-bound)))
+                         (lambda (y)
+                           (set-cdr! x y)))))
+                     ((acc exp)
+                      (let ((a (assq (syntax-object->datum (syntax acc))
+                                     get-c---rs)))
+                        (if a
+                            (quasisyntax/loc
+                             ident
+                             (let ((x (#,(cadr a) 
+                                       #,(subst-bindings (syntax exp)
+                                                         let-bound))))
+                               (lambda (y)
+                                 (#,(mk-setter (cddr a)) x y))))
+                            (quasisyntax/loc
+                             ident
+                             (let ((x #,(subst-bindings (syntax exp)
+                                                        let-bound)))
+                               (lambda (y)
+                                 (#,(mk-setter 
+                                     (syntax-object->datum (syntax acc)))
+                                  x y)))))))))))
+
+;;!(function getter
+;;          (form (getter e ident let-bound) -> syntax)
+;;          (contract (syntax syntax list) -> syntax)
+;;          (example (getter (syntax (car x)) (syntax here) '())
+;;                   ->
+;;          (syntax (lambda () (car x)))))
+;; This function takes an expression and returns syntax which
+;; represents a function that is able to get the value that the
+;; expression points to.
+(define getter (lambda (e ident let-bound)
+                 (syntax-case e (vector-ref unbox car cdr)
+                   (p
+                    (not (stx-pair? (syntax p)))
+                    (match:syntax-err 
+                     ident
+                     "get! pattern should be nested inside of a list, vector or box"))
+                   ((vector-ref vector index)
+                    (quasisyntax/loc
+                     ident
+                     (let ((x #,(subst-bindings (syntax vector)
+                                                let-bound)))
+                       (lambda ()
+                         (vector-ref
+                          x
+                          index)))))
+                   ((unbox boxed)
+                    (quasisyntax/loc
+                     ident
+                     (let ((x #,(subst-bindings (syntax boxed)
+                                                let-bound)))
+                       (lambda () (unbox x)))))
+                   ((car exp)
+                    (quasisyntax/loc
+                     ident
+                     (let ((x #,(subst-bindings (syntax exp)
+                                                let-bound)))
+                       (lambda () (car x)))))
+                   ((cdr exp)
+                    (quasisyntax/loc
+                     ident
+                     (let ((x #,(subst-bindings (syntax exp)
+                                                let-bound)))
+                       (lambda () (cdr x)))))
+                   ((acc exp)
+                    (let ((a (assq (syntax-object->datum (syntax acc))
+                                   get-c---rs)))
+                      (if a
+                          (quasisyntax/loc
+                           ident
+                           (let ((x (#,(cadr a)
+                                     #,(subst-bindings (syntax exp)
+                                                       let-bound))))
+                             (lambda () (#,(cddr a) x))))
+                          (quasisyntax/loc
+                           ident
+                           (let ((x #,(subst-bindings (syntax exp)
+                                                      let-bound)))
+                             (lambda ()
+                               (acc x))))))))))
diff --git a/collects/mzlib/private/plt-match/match-inc.scm b/collects/mzlib/private/plt-match/match-inc.scm
new file mode 100644
index 0000000000..7573ac07ae
--- /dev/null
+++ b/collects/mzlib/private/plt-match/match-inc.scm
@@ -0,0 +1,345 @@
+;; This library is usedby match.ss and plt-match.ss
+
+;;! (function match:syntax-err
+;;          (form (match:syntax-err object message . detail) -> void)
+;;          (contract (any string . any) -> void)
+;;          (example (match:syntax-err (syntax here) "Bad error" (vector))
+;;                   -> void)
+;;          (contract object -> (normally a syntax object that
+;;                               that helps determine the source location
+;;                               of the error)))
+;; This function is used to report malformed match expressions.
+(define match:syntax-err (lambda (obj msg . detail)
+                           (apply
+                            raise-syntax-error
+                            'match
+                            msg
+                            obj
+                            detail)))
+
+;;! (function pattern-var?
+;;    (form (pattern-var? pattern-element) -> bool)
+;;    (contract any -> bool)
+;;    (example (pattern-var? 'x) -> t)
+;;    )
+;; This function takes an object and determines if it
+;; qualifies as a pattern variable.
+(define pattern-var?
+  (lambda (x)
+    (and (symbol? x)
+         (not (dot-dot-k? x))
+         (not (memq x
+                    '(
+                      _
+                      quasiquote
+                      quote
+                      unquote
+                      unquote-splicing
+;                      hash-table
+;                      list-no-order
+;                       list-rest
+;                       list
+;                       app
+;                       struct
+;                       var
+;                       vector
+;                       box
+;                       ?
+;                       and
+;                       or
+;                       not
+;                       set!
+;                       get!
+                      ))))))
+
+;;!(function dot-dot-k?
+;;          (form (dot-dot-k? s) -> bool)
+;;          (contract any -> bool)
+;;          (example (stx-dot-dot-k? '..3) -> #t))
+;; This function is a predicate that returns true if the argument
+;; is a symbol '... or '___ where the last dot or
+;; underscore can be an integer
+(define dot-dot-k? (lambda (s)
+                     (and (symbol? s)
+                          (if (memq s '(... ___))
+                              0
+                              (let* ((s (symbol->string s))
+                                     (n (string-length s)))
+                                (and (<= 3 n)
+                                     (memq (string-ref s 0)
+                                           '(#\. #\_))
+                                     (memq (string-ref s 1)
+                                           '(#\. #\_))
+                                     (andmap
+                                      char-numeric?
+                                      (string->list
+                                       (substring s 2 n)))
+                                     (string->number
+                                      (substring s 2 n))))))))
+
+;;!(function gen-match
+;;          (form (gen-match exp tsf patlist stx [success-func])
+;;                ->
+;;                compiled-pattern)
+;;          (contract (syntax-object list list syntax-object
+;;                                   (list list -> syntax-object))
+;;                    ->
+;;                    syntax-object))
+;; <p>gen-match is the gateway through which match, match-lambda,
+;; match-lambda*,
+;; match-let, match-let*, match-letrec, match-define access the match
+;; expression compiler.
+;;
+;; <p>exp - the expression that is to be tested against the pattern.
+;; This should normally be a piece of syntax that indirectly
+;; represents the expression.  Because if it is the syntax of the
+;; expression itself it will be duplicated many times throughout
+;; the generated match test.
+;;
+;; <p>tsf - is a list of tests-seen-so-far and is used to
+;; prevent generating tests for the same condition twice
+;;
+;; <p>patlist - is a list of the pattern clauses of the match expr
+;; these can be of either form (pat body ...) or
+;; (pat (=> fail) body ...)x
+;;
+;; <p>stx is the original syntax of the match expression.
+;; This is only used for error reporting.
+;;
+;; <p>success-func - an optional argument which allows one to
+;; specify how a successful match is treated.  This made
+;; the creation of match-letrec and match-define macros simple.
+;; The reason for this function is that most of the information
+;; about a match (namely the bound match variables) is at the bottom
+;; of the recursion tree. The success function must take two arguments
+;; and it should return a syntax object.
+(define gen-match
+  (opt-lambda (exp tsf patlist stx [success-func #f])
+    (include "test-structure.scm")
+    ;(include "coupling-and-binding-new.scm")
+    (include "coupling-and-binding.scm")
+    (include "render-test-list.scm")
+    (include "reorder-tests.scm")
+    (include "update-counts.scm")
+    (include "update-binding-counts.scm")
+    (include "match-util.scm")
+    (include "tag-negate-tests.scm")
+    ;;!(function unreachable
+    ;;          (form (unreachable plist match-expr) -> void)
+    ;;          (contract (list syntax-object) -> void)
+    ;;          (contract plist -> (is a list of unreached pattern clauses))
+    ;;          (contract match-expr -> (is the origional match expr
+    ;;                                   the clauses came from)))
+    ;; This function takes a list of unreached clauses and the original
+    ;; match expression and prints a warning for each of the unreached
+    ;; match clauses to the current error port
+    (define unreachable
+      (lambda (plist match-expr)
+        (map
+         (lambda (x)
+           (if (not (cdr x))
+               (fprintf
+                (current-error-port)
+                "Warning: unreachable match clause ~e in ~e~n"
+                (syntax-object->datum (car x))
+                (syntax-object->datum match-expr))))
+         plist)))
+
+    ;;!(function gen-match-opt
+    ;;          (form (gen-match exp tsf patlist stx [success-func])
+    ;;                ->
+    ;;                compiled-pattern)
+    ;;          (contract (syntax-object list list syntax-object
+    ;;                                   (list list -> syntax-object))
+    ;;                    ->
+    ;;                    syntax-object))
+    ;; This function is left over from an experiment that explored the
+    ;; idea that certain "shape" tests can be ommited if the input for
+    ;; a match expression is known.
+    ;; For example if one knows that the the match expression is only
+    ;; ever going to be applied to a list of four items.  Then it
+    ;; would behoove us to eliminate the extraneous tests that verify
+    ;; this.
+    (define gen-match-opt
+      (opt-lambda (exp tsf patlist stx [success-func #f])
+        (gen-help exp tsf patlist stx #t success-func)))
+
+    ;;!(function gen-help
+    ;;          (form (gen-help exp tsf patlist stx [success-func]) ->
+    ;;                          syntax-object)
+    ;;          (contract (syntax-object list list syntax-object
+    ;;                                   (list list -> syntax-object))
+    ;;                    ->
+    ;;                    syntax-object))
+    ;; This function does some basic house keeping before forwarding
+    ;; the compilation to the gen function.  It sets up the list of
+    ;; clauses so that one can mark that they have been "reached".  It
+    ;; also wraps the final compilation in syntax which binds the
+    ;; match-failure function.
+    (define gen-help
+      (opt-lambda (exp tsf patlist stx opt [success-func #f])
+        (when
+            (stx-null? patlist)
+          (match:syntax-err stx "null clause list"))
+        (let* ((marked-clauses (mark-patlist patlist))
+               (compiled-match
+                (quasisyntax/loc stx
+                                 (let ((match-failure
+                                        (lambda ()
+                                          (match:error #,exp (quote #,stx)))))
+                                   #,(gen exp tsf marked-clauses
+                                          stx
+                                          (syntax (match-failure))
+                                          opt
+                                          success-func)))))
+          (unreachable marked-clauses stx)
+          compiled-match)))
+
+    ;;!(function mark-patlist
+    ;;          (form (mark-patlist clauses) -> marked-clause-list)
+    ;;          (contract list -> list))
+    ;; This function takes each clause from the match expression and
+    ;; pairs it with the dummy value #f.  This value will be set! when
+    ;; the pattern matcher compiles a possible successful match for
+    ;; the clause.  If it is not set to #t then the clause is
+    ;; unreachable which is an indication of programmer error.
+    (define mark-patlist
+      (lambda (clauses)
+        (map (lambda (x) (cons x #f)) (syntax->list clauses))))
+
+    ;;!(function test-list-with-success-func
+    ;;          (form (test-list-with-success-func exp car-patlist
+    ;;                         stx success-func)
+    ;;                ->
+    ;;                (test-list success-func))
+    ;;          (contract (syntax-object pair syntax-object
+    ;;                                   (list list -> syntax-object))
+    ;;                    ->
+    ;;                    (list ((list list -> syntax) list ->
+    ;;                           (list list -> syntax)))))
+    ;; This function takes an exp which is to be matched, a marked
+    ;; clause, and a syntax-object that is fro reporting errors. It
+    ;; returns a pair the car of which is a list of test structs which
+    ;; are in essense partially evaluated tests.  The cdr of the
+    ;; result is a function which takes a failure function and a list
+    ;; of let-bound expressions and returns a success-function.
+    (define test-list-with-success-func
+      (opt-lambda (exp car-patlist stx [success-func #f])
+        (let ((clause1 (car car-patlist)))
+          (let-values (((pat body fail-sym)
+                        (syntax-case clause1 (=>)
+                          ((pat (=> fail-sym) body1 bodys ...)
+                           (values (syntax pat)
+                                   (syntax (body1 bodys ...))
+                                   (syntax fail-sym)))
+                          ((pat body1 bodys ...)
+                           (values (syntax pat)
+                                   (syntax (body1 bodys ...)) #f))
+                          ((pat) (match:syntax-err
+                                  (syntax pat)
+                                  "missing action for pattern"))
+                          (pat (match:syntax-err
+                                (syntax pat)
+                                "syntax error in clause")))))
+            (let* (
+                   (success
+                    (lambda (fail let-bound)
+                      (if (not success-func)
+                          (lambda (sf bv)
+                            ;; mark this pattern as reached
+                            (set-cdr! car-patlist #t)
+                            (if fail-sym
+                                (quasisyntax/loc
+                                 stx
+                                 (call/ec
+                                  (lambda (fail-cont)
+                                    (let
+                                        ((failure
+                                          (lambda ()
+                                            (fail-cont
+                                        ; it seems like fail is called
+                                        ; twice in this situation
+                                             #,( fail sf bv)))))
+                                      ((lambda (#,fail-sym
+                                                #,@(map car bv))
+                                         #,@body)
+                                       failure
+                                       #,@(map (lambda (b)
+                                                 (subst-bindings
+                                                  (cdr b)
+                                                  let-bound))
+                                               bv))))))
+                                (quasisyntax/loc
+                                 stx
+                                 ((lambda #,(map car bv)
+                                    #,@body)
+                                  #,@(map
+                                      (lambda (b) (subst-bindings
+                                                   (cdr b)
+                                                   let-bound))
+                                      bv)))))
+                          (lambda (sf bv)
+                            ;; mark this pattern as reached
+                            (set-cdr! car-patlist #t)
+                            (let ((bv (map
+                                       (lambda (bind)
+                                         (cons (car bind)
+                                               (subst-bindings
+                                                (cdr bind)
+                                                let-bound)))
+                                       bv)))
+                              (success-func sf bv))))))
+                   (test-list (render-test-list pat exp stx)))
+              (cons test-list success))))))
+
+    ;;!(function gen
+    ;;          (form (gen exp tsf patlist stx failure-func opt success-func)
+    ;;                ->
+    ;;                syntax)
+    ;;          (contract (syntax list list syntax
+    ;;                     (() -> void) bool (list list -> syntax))
+    ;;                    ->
+    ;;                    syntax))
+    ;; This function is primarily called by gen-help and takes the the
+    ;; newly marked clauses and the failure-func which is really a
+    ;; variable-name which will bound to the failure in the runtime
+    ;; code.  This function then makes successive calls to
+    ;; test-list-with-success-func which gives us a list of partially
+    ;; compiled tests for each clause.  I say partially compiled
+    ;; because the test structures containa a function that needs to
+    ;; be coupled with the other functions of the other test
+    ;; structures before actual compilation results.  This function
+    ;; then takes these lists of partially compiled tests and reorders
+    ;; them in an attempt to reduce the size of the final compiled
+    ;; match expression.  Binding counts are also updated to help
+    ;; determind which supexpressions of the expression to be matched
+    ;; need to be bound by let expressions.  After all of this the
+    ;; tests are "coupled" together for final compilation.
+    (define gen
+      (opt-lambda (exp tsf patlist stx failure-func opt [success-func #f])
+        ;; iterate through list and render each pattern to a list of tests
+        ;; and success functions
+        (let ((rendered-list
+               (let loop ((clause-list patlist))
+                 (if (null? clause-list)
+                     '()
+                     (cons (test-list-with-success-func exp
+                                                        (car clause-list)
+                                                        stx
+                                                        success-func)
+                           (loop (cdr clause-list)))))))
+          (update-counts rendered-list)
+          (tag-negate-tests rendered-list)
+          (update-binding-counts rendered-list)
+          (let* ((rendered-list (reorder-all-lists rendered-list))
+                 (output
+                  (begin 
+                    ;(pretty-print rendered-list)(newline)      
+                    ((meta-couple rendered-list
+                                  (lambda (sf bv) failure-func)
+                                  '()
+                                  '())
+                     '() '()))))
+            output))))
+    (gen-help exp tsf patlist stx #f success-func)))
+
diff --git a/collects/mzlib/private/plt-match/match-util.scm b/collects/mzlib/private/plt-match/match-util.scm
new file mode 100644
index 0000000000..ff290a8df5
--- /dev/null
+++ b/collects/mzlib/private/plt-match/match-util.scm
@@ -0,0 +1,404 @@
+;; This library is used by match.ss
+;
+
+;;! (function stx-length
+;;          (form (syntax-length syntax-obj) -> int)
+;;          (contract syntax-object -> int)
+;;          (example (syntax-length (syntax iraq war idiocy)) -> 3))
+;;  Returns the length of the top-level syntax list.
+(define stx-length (lambda (syntax-obj)
+                     (length (syntax->list syntax-obj))))
+
+;;! (function stx-?
+;;          (form (stx? test val) -> bool)
+;;          (contract ((any -> bool) syntax-object) -> bool)
+;;          (example (stx-? number? (syntax 4)) -> #t))
+;;  Applies predicate test to the syntax object val and returns the resulting
+;; boolean value.
+(define stx-? (lambda (test val)
+                (test (syntax-object->datum val))))
+
+;;!(function stx-equal?
+;;          (form (stx-equal? a b) -> bool)
+;;          (contract (syntax-object syntax-object) -> bool)
+;;          (example (stx-equal? (syntax 5) (syntax 5)) -> #t))
+;; Check the equality of two syntax objects by after applying
+;; syntax-object->datum to the objects first.  Checks equaltiy of
+;; syntax objects after they have had all syntax data stripped away.
+(define stx-equal? (lambda (a b)
+                     (equal? (syntax-object->datum a)
+                             (syntax-object->datum b))))
+
+;;!(function symbol-append
+;;          (form (symbol-append . args) -> symbol)
+;;          (contract ((symbol or number) ...) -> symbol)
+;;          (example (symbol-append 'hello 5 'goodbye) -> 'hello5goodbye))
+;; This function takes any number of arguments which can be either
+;; symbols or numbers and returns one symbol which is the
+;; concatenation of the input.
+(define symbol-append (lambda l
+                        (string->symbol
+                         (apply
+                          string-append
+                          (map (lambda (x)
+                                 (cond
+                                  ((symbol? x) (symbol->string x))
+                                  ((number? x) (number->string x))
+                                  (else x)))
+                               l)))))
+
+;;!(function struct-pred-accessors-mutators
+;;          (form (struct-pred-accessors-mutators struct-name failure-thunk)
+;;                ->
+;;                (values pred accessors mutators parental-chain))
+;;          (contract (syntax-object (any -> void))
+;;                     ->
+;;                     (values (any -> bool) list list)))
+;; This function takes a syntax-object that is the name of a structure
+;; as well as a failure thunk.  It returns three values.  The first is
+;; a predicate for the structure.  The second is a list of accessors
+;; in the same order as the fields of the structure declaration.  The
+;; third is a list of mutators for the structure also in the same
+;; order.  The last is a list of supertypes of this struct. The
+;; failure thunk is invoked if the struct-name is not bound to a
+;; structure.
+(define struct-pred-accessors-mutators
+  (let ((accessors-index 3)
+        (mutators-index 4)
+        (pred-index 2)
+        (super-type-index 5)
+        (handle-acc-list
+         (lambda (l)
+           (letrec ((RC
+                     (lambda (ac-list)
+                       (cond ((null? ac-list) '())
+                             ((not (car ac-list)) '())
+                             (else (cons (car ac-list)
+                                         (RC (cdr ac-list))))))))
+             (reverse (RC l))))))
+    (lambda (struct-name failure-thunk)
+      (letrec ((get-lineage
+                (lambda (struct-name)
+                  (let ((super 
+                         (list-ref 
+                          (syntax-local-value struct-name 
+                                              failure-thunk)
+                          super-type-index)))
+                    (cond ((equal? super #t) '())
+                          ((equal? super #f) '()) ;; not sure what to do in case where super-type is unknown
+                          (else
+                           (cons super (get-lineage super))))))))
+            (let ((info-on-struct (syntax-local-value struct-name failure-thunk)))
+              (if (struct-declaration-info? info-on-struct)
+                  (let ((accessors (handle-acc-list
+                                    (list-ref info-on-struct accessors-index)))
+                        (mutators (handle-acc-list
+                                   (list-ref info-on-struct mutators-index)))
+                        (pred (list-ref info-on-struct pred-index))
+                        (parental-chain (get-lineage struct-name)))
+                    (values pred accessors mutators (cons struct-name parental-chain)))
+                  (failure-thunk)))))))
+
+
+
+
+;;!(function get-exp-var
+;;          (form (get-exp-var) -> syntax)
+;;          (contract () -> syntax)
+;;          (example (get-exp-var) -> (syntax exp754)))
+;; This function just produces unique identifiers for expressions.
+(define get-exp-var (lambda () #`#,(gensym 'exp)))
+
+;;!(function in
+;;          (form (in e l) -> bool)
+;;          (contract (s-exp list) -> bool)
+;;          (example (in '(number? x) (list '(number? x))) -> #t))
+;; This function is responsible for determining which tests are
+;; redundant.  If e can be determined to be true from the list of
+;; tests l then e is "in" l.
+(define in (lambda (e l)
+             (or 
+                 (ormap
+                  (lambda (el)
+                    (or (equal? e el)
+                        (and 
+                         (eq? (car e) 'struct-pred)
+                         (eq? (car el) 'struct-pred)
+                         (member (caaddr e) (caddr el))
+                         (equal? (cadddr e) (cadddr el))))) l)
+                 (and (eq? (car e) 'list?)
+                      (or (member `(null? ,(cadr e)) l)
+                          (member `(pair? ,(cadr e)) l)))
+                 (and (eq? (car e) 'not)
+                      (let* ((srch (cadr e))
+                             (const-class (equal-test? srch)))
+                        ;(write srch)
+                        (cond
+                         ((equal? (car srch) 'struct-pred)
+                          (let mem ((l l))
+                            (if (null? l)
+                                #f
+                                (let ((x (car l)))
+                                  (if (and (equal? (car x)
+                                                   'struct-pred)
+                                           (not (equal? (cadr x) (cadr srch)))
+                                           ; the current struct type should not
+                                           ; be a member of the parental-chain of 
+                                           (not (member (caaddr x) (caddr srch))) 
+                                           (equal? (cadddr x) (cadddr srch)))
+                                      #t
+                                      (mem (cdr l)))))))        
+                         (const-class  
+                          (let mem ((l l))
+                            (if (null? l)
+                                #f
+                                (let ((x (car l)))
+                                  (or (and (equal?
+                                            (cadr x)
+                                            (cadr srch))
+                                           (disjoint? x)
+                                           (not (equal?
+                                                 const-class
+                                                 (car x))))
+                                      (equal?
+                                       x
+                                       `(not (,const-class
+                                              ,(cadr srch))))
+                                      (and (equal?
+                                            (cadr x)
+                                            (cadr srch))
+                                           (equal-test?
+                                            x)
+                                           (not (equal?
+                                                 (caddr
+                                                  srch)
+                                                 (caddr
+                                                  x))))
+                                      (mem (cdr l)))))))
+                         ((disjoint? srch) 
+                          (let mem ((l l))
+                            (if (null? l)
+                                #f
+                                (let ((x (car l)))
+                                  (or (and (disjoint? x)
+                                           (not (equal?
+                                                 (car x)
+                                                 (car srch)))
+                                           (cond ((equal?
+                                                   (car srch)
+                                                   'struct-pred)
+                                                  (equal? 
+                                                   (cadr x)
+                                                   ;; we use cadddr here to access the expression
+                                                   ;; because struct predicates carry some extra baggage
+                                                   ;; They have the form (struct-pred <predicate> <list of super types> <exp>)
+                                                   (cadddr srch)))
+                                                 ((equal?
+                                                   (car x)
+                                                   'struct-pred)
+                                                  (equal? 
+                                                   (cadr srch)
+                                                   ;; we use cadddr here to access the expression
+                                                   ;; because struct predicates carry some extra baggage
+                                                   (cadddr x)))
+                                                 (else (equal?
+                                                        (cadr x)
+                                                        (cadr srch)))))
+                                      (mem (cdr l)))))))
+                         ((eq? (car srch) 'list?) 
+                          (let mem ((l l))
+                            (if (null? l)
+                                #f
+                                (let ((x (car l)))
+                                  (or (and (equal?
+                                            (cadr x)
+                                            (cadr srch))
+                                           (disjoint?
+                                            x)
+                                           (not (memq (car x)
+                                                      '(list?
+                                                        pair?
+                                                        null?))))
+                                      (mem (cdr l)))))))
+                         ((vec-structure? srch) 
+                          (let mem ((l l))
+                            (if (null? l)
+                                #f
+                                (let ((x (car l)))
+                                  (or (and (equal?
+                                            (cadr x)
+                                            (cadr srch))
+                                           (or (disjoint?
+                                                x)
+                                               (vec-structure?
+                                                x))
+                                           (not (equal?
+                                                 (car x)
+                                                 'vector?))
+                                           (not (equal?
+                                                 (car x)
+                                                 (car srch))))
+                                      (equal?
+                                       x
+                                       `(not (vector?
+                                              ,(cadr srch))))
+                                      (mem (cdr l)))))))
+                         (else #f)))))))
+
+;;!(function equal-test?
+;;          (form (equal-test? tst) -> (or symbol
+;;                                         #f))
+;;          (contract s-exp -> (or symbol
+;;                                         #f))
+;;          (example (equal-test? '(equal? x 5))
+;;                   -> 'number?)
+;;          (example (equal-test? '(symbol? x))
+;;                   -> #f))
+;; This function returns false if the s-exp does not represent an
+;; "equal?" test.  If it does then this function returns a
+;; predicate for the data type that the test is testing.
+(define equal-test? (lambda (tst)
+                      (and (eq? (car tst) 'equal?)
+                           (let ((p (caddr tst)))
+                             (cond
+                              ((string? p) 'string?)
+                              ((boolean? p) 'boolean?)
+                              ((char? p) 'char?)
+                              ((number? p) 'number?)
+                              ((and (pair? p)
+                                    (pair? (cdr p))
+                                    (null? (cddr p))
+                                    (eq? 'quote (car p))
+                                    (symbol? (cadr p))) 'symbol?)
+                              (else #f))))))
+
+(define match:disjoint-predicates
+  '(struct-pred null? pair? symbol? boolean? number? string? char?
+          procedure? vector?
+          box? promise?)) 
+
+(define match:vector-structures '())
+
+;;!(function disjoint?
+;;          (form (disjoint? tst))
+;;          (contract s-exp -> bool)
+;;          (example (disjoint? 'pair?) -> #t))
+;; This function retirns true if the predicate is disjoint.
+(define disjoint?
+  (lambda (tst)
+    (memq (car tst) match:disjoint-predicates)))
+
+(define vec-structure? (lambda (tst)
+                         (memq (car tst) match:vector-structures)))
+;;!(function add-a
+;;          (form (add-a exp-syntax) -> syntax)
+;;          (contract syntax -> syntax)
+;;          (example (add-a (syntax (cdr x))) -> (syntax (cadr x))))
+;; Add car operation, ie. given (c...r x), return (ca...r x).
+(define add-a
+  (lambda (exp-syntax)
+    (syntax-case exp-syntax ()
+      ((car-thing exp)
+       (let ((new (assq (syntax-object->datum (syntax car-thing)) c---rs)))
+         (if new
+             (quasisyntax/loc exp-syntax (#,(cadr new) exp))
+             (syntax/loc exp-syntax (car (car-thing exp))))))
+      (exp (syntax/loc exp-syntax (car exp))))))
+
+;;!(function add-d
+;;          (form (add-d exp-syntax) -> syntax)
+;;          (contract syntax -> syntax)
+;;          (example (add-a (syntax (cdr x))) -> (syntax (cddr x))))
+;; Add cdr operation, ie. given (c...r x), return (cd...r x).
+(define add-d
+  (lambda (exp-syntax)
+    (syntax-case exp-syntax ()
+      ((car-thing exp)
+       (let ((new (assq (syntax-object->datum (syntax car-thing)) c---rs)))
+         (if new
+             (quasisyntax/loc exp-syntax (#,(cddr new) exp))
+             (syntax/loc exp-syntax (cdr (car-thing exp))))))
+      (exp (syntax/loc exp-syntax (cdr exp))))))
+
+(define c---rs '((car caar . cdar)
+                 (cdr cadr . cddr)
+                 (caar caaar . cdaar)
+                 (cadr caadr . cdadr)
+                 (cdar cadar . cddar)
+                 (cddr caddr . cdddr)
+                 (caaar caaaar . cdaaar)
+                 (caadr caaadr . cdaadr)
+                 (cadar caadar . cdadar)
+                 (caddr caaddr . cdaddr)
+                 (cdaar cadaar . cddaar)
+                 (cdadr cadadr . cddadr)
+                 (cddar caddar . cdddar)
+                 (cdddr cadddr . cddddr)))
+
+(define get-c---rs '((caar car . car)
+                     (cadr cdr . car)
+                     (cdar car . cdr)
+                     (cddr cdr . cdr)
+                     (caaar caar . car)
+                     (caadr cadr . car)
+                     (cadar cdar . car)
+                     (caddr cddr . car)
+                     (cdaar caar . cdr)
+                     (cdadr cadr . cdr)
+                     (cddar cdar . cdr)
+                     (cdddr cddr . cdr)
+                     (caaaar caaar . car)
+                     (caaadr caadr . car)
+                     (caadar cadar . car)
+                     (caaddr caddr . car)
+                     (cadaar cdaar . car)
+                     (cadadr cdadr . car)
+                     (caddar cddar . car)
+                     (cadddr cdddr . car)
+                     (cdaaar caaar . cdr)
+                     (cdaadr caadr . cdr)
+                     (cdadar cadar . cdr)
+                     (cdaddr caddr . cdr)
+                     (cddaar cdaar . cdr)
+                     (cddadr cdadr . cdr)
+                     (cdddar cddar . cdr)
+                     (cddddr cdddr . cdr)))
+
+;;!(function stx-dot-dot-k?
+;;          (form (stx-dot-dot-k? syn) -> bool)
+;;          (contract syntax -> bool)
+;;          (example (stx-dot-dot-k? (syntax ..3)) -> #t))
+;; This function is a predicate that returns true if the argument
+;; is syntax represents a ... or ___ syntax where the last dot or
+;; underscore can be an integer
+(define stx-dot-dot-k?
+  (lambda (syn)
+    (dot-dot-k? (syntax-object->datum syn))))
+
+;;!(function implied
+;;          (form (implied test) -> list)
+;;          (contract s-exp -> list))
+;; This function is given a s-expression for a test and returns a
+;; list of tests that are implied by that test.  The implied test
+;; would have to be true if the argument is true.
+(define (implied test)
+  (let* ((pred (car test))
+         (exp (cadr test)))
+    (cond
+     ((equal? pred 'equal?)
+      (let ((ex (caddr test)))
+        (cond ((string? ex)
+               (list `(string? ,ex)))
+              ((boolean? ex)
+               (list `(boolean? ,exp)))
+              ((char? ex)
+               (list `(char? ,exp)))
+              ((number? ex)
+               (list `(number? ,exp)))
+              ((and (pair? ex)
+                    (eq? 'quote (car ex)))
+               (list `(symbol? ,exp)))
+              (else '()))))
+     ((equal? pred 'null?)
+      (list `(list? ,exp)))
+     (else '()))))
diff --git a/collects/mzlib/private/plt-match/newsyntax.txt b/collects/mzlib/private/plt-match/newsyntax.txt
new file mode 100644
index 0000000000..65ebc96df3
--- /dev/null
+++ b/collects/mzlib/private/plt-match/newsyntax.txt
@@ -0,0 +1,76 @@
+This is the proposed pattern grammer.
+
+Asterisks mark rules that have changed.
+
+pat ::= 
+        identifier                      anything, can not be ooo
+      | _                               anything
+      | #t                              #t
+      | #f                              #f
+      | string                          a string
+      | number                          a number
+      | character                       a character
+      | 'sexp                           an s-expression
+      | 'symbol                         a symbol (special case of s-expr)
+*     | (list lvp_1 ... lvp_n)               list of n elements
+*     | (list-rest lvp_1 ... lvp_n lvp_{n+1})   list of n or more
+*     | (vector lvp_1 ... lvp_n)              vector of n elements
+*     | (box pat)                           box
+*     | (struct struct-name (pat_1 ... pat_n)) a structure
+      ;; this may be better as '$' ?     
+      | (list-no-order pat ...)         matches a list with no regard for 
+                                        the order of the
+                                        items in the list
+      | (list-no-order pat ... pat_n ooo) pat_n matches the remaining 
+                                          unmatched items
+      | (hash-table pat ...)            matches the elements of a hash table
+      | (hash-table pat ... pat_n ooo)  pat_n must match the remaining 
+                                        unmatched elements
+*     | (app field pat)                   a field of a structure (field is 
+                                          an accessor)
+                                        Actually field can be any function 
+                                        which can be
+                                        applied to the data being matched.
+                                        Ex: (match 5 ((= add1 b) b)) => 6
+
+      | (and pat_1 ... pat_n)           if all of pat_1 thru pat_n match
+      | (or pat_1 ... pat_n)            if any of pat_1 thru pat_n match
+      | (not pat_1 ... pat_n)           if all pat_1 thru pat_n don't match
+*     | (? predicate pat_1 ... pat_n)   if predicate is true and all of
+                                         pat_1 thru pat_n match
+      | (set! identifier)               anything, and binds setter
+      | (get! identifier)               anything, and binds getter
+      | `qp                             a quasi-pattern
+
+lvp ::= pat ooo                         greedily matches n or more of pat, 
+                                        each element must match pat
+      | pat                             matches pat
+
+ooo ::= ...                             zero or more
+      | ___                             zero or more
+      | ..k                             k or more
+      | __k                             k or more
+
+        quasi-patterns:                 matches:
+
+qp  ::= ()                              the empty list
+      | #t                              #t
+      | #f                              #f
+      | string                          a string
+      | number                          a number
+      | character                       a character
+      | identifier                      a symbol
+      | (qp_1 ... qp_n)                 list of n elements
+      | (qp_1 ... qp_n . qp_{n+1})      list of n or more
+      | (qp_1 ... qp_n qp_n+1 ooo)      list of n or more, each element
+                                          of remainder must match qp_n+1
+      | #(qp_1 ... qp_n)                vector of n elements
+      | #(qp_1 ... qp_n qp_n+1 ooo)     vector of n or more, each element
+                                          of remainder must match qp_n+1
+      | #&qp                            box
+      | ,pat                            a pattern
+      | ,@(lvp . . . lvp-n)
+      | ,@(lvp-1 . . . lvp-n . lvp-{n+1})
+      | ,@`qp                           qp must evaluate to a list as 
+                                        so that this rule resembles the 
+                                        above two rules
diff --git a/collects/mzlib/private/plt-match/parse-quasi.scm b/collects/mzlib/private/plt-match/parse-quasi.scm
new file mode 100644
index 0000000000..2fcf167ade
--- /dev/null
+++ b/collects/mzlib/private/plt-match/parse-quasi.scm
@@ -0,0 +1,124 @@
+;; This library is used by match.ss
+
+;;!(function parse-quasi
+;;          (form (parse-quasi syn) -> syntax)
+;;          (contract syntax -> syntax))
+;; This function parses a quasi pattern in to a regular pattern
+;; and returns it.  This function does not parse the quasi pattern
+;; recursively in order to find nested quasi patterns.  It only
+;; parses the top quasi pattern.
+(define parse-quasi
+  (lambda (stx)
+    (letrec 
+        ((q-error (opt-lambda (syn [msg ""])
+                    (match:syntax-err
+                     stx
+                     (string-append 
+                      "syntax error in quasi-pattern: "
+                      msg))))
+         (parse-q
+          (lambda (phrase)
+                                        ;(write phrase)(newline)
+            (syntax-case phrase (quasiquote unquote unquote-splicing)
+              (p
+               (let ((pat (syntax-object->datum (syntax p))))
+                 (or (string? pat)
+                     (boolean? pat)
+                     (char? pat)
+                     (number? pat)
+                     (dot-dot-k? pat)))
+               (syntax p))
+              (p
+               (stx-null? (syntax p))
+               (syntax/loc stx (list)))
+              (p
+               ;; although it is not in the grammer for quasi patterns
+               ;; it seems important to not allow unquote splicing to be
+               ;; a symbol in this case `,@(a b c). In this unquote-splicing
+               ;; is treated as a symbol and quoted to be matched.
+               ;; this is probably not what the programmer intends so
+               ;; it may be better to throw a syntax error
+               (identifier? (syntax p)) 
+               (syntax/loc stx 'p))
+              ;; ((var p)  ;; we shouldn't worry about this in quasi-quote
+              ;;  (identifier? (syntax p))
+              ;;  (syntax/loc phrase 'p))
+            (,p (syntax p))
+            (,@pat
+             (q-error (syntax ,@pat) "unquote-splicing not nested in list"))
+            ((x . y) 
+             (let* ((list-type 'list)
+                    (result
+                     (let loop 
+                         ((l (syntax-e (syntax (x . y)))))
+                                        ;(write l)(newline)
+                       (cond ((null? l) '())
+                             ((and (stx-pair? (car l))
+                                   (equal? (car (syntax-object->datum (car l))) 
+                                           'unquote-splicing))
+                              (let ((first-car  
+                                     (syntax-case (car l) 
+                                         (unquote-splicing quasiquote)
+                                       (,@`p  ;; have to parse forward here
+                                        (let ((pq (parse-q (syntax p))))
+                                          (if (stx-list? pq)
+                                              (cdr (syntax->list pq))
+                                              (q-error (syntax ,@`p)
+                                                       "unquote-splicing not followed by list"))))
+                                       (,@p
+                                        (if (stx-list? (syntax p))
+                                            (cdr (syntax->list (syntax p)))
+                                            (begin ; (write (syntax-e (syntax p))) 
+                                                   (q-error (syntax ,@p)
+                                                     "unquote-splicing not followed by list")))))))
+                                (syntax-case (cdr l) (unquote unquote-splicing)
+                                  (,@p (q-error (syntax ,@p) 
+                                                "unquote-splicing can not follow dot notation"))
+                                  (,p  
+                                   (let ((res (parse-q (syntax ,p))))
+                                     (set! list-type 'list-rest)
+                                     `(,@first-car ,res)))
+                                  (p (or (stx-pair? (syntax p))
+                                         (stx-null? (syntax p)))
+                                     (append first-car 
+                                             (loop (syntax-e (syntax p)))))
+                                  (p ;; must be an atom
+                                   (let ((res (parse-q (syntax p))))
+                                     (set! list-type 'list-rest)
+                                     `(,@first-car ,res))))))
+                             (else 
+                              (syntax-case (cdr l) (unquote unquote-splicing)
+                                (,@p (q-error (syntax p) 
+                                              "unquote-splicing can not follow dot notation"))
+                                (,p  (begin 
+                                       (set! list-type 'list-rest)
+                                       (list (parse-q (car l))  
+                                             (parse-q (syntax ,p)))))
+                                (p (or (stx-pair? (syntax p))
+                                       (stx-null? (syntax p)))
+                                   (cons (parse-q (car l))
+                                         (loop (syntax-e (syntax p)))))
+                                (p ;; must be an atom
+                                 (begin 
+                                   (set! list-type 'list-rest)
+                                   (list (parse-q (car l)) 
+                                         (parse-q (syntax p)))))))))))
+               (quasisyntax/loc stx (#,list-type #,@result))))
+            (p
+             (vector? (syntax-object->datum (syntax p)))
+             (quasisyntax/loc 
+              stx
+              (vector #,@(cdr 
+                          (syntax-e 
+                           (parse-q
+                            (quasisyntax/loc 
+                             stx 
+                             #,(vector->list (syntax-e (syntax p))))))))))
+            (p
+             (box? (syntax-object->datum (syntax p)))
+             (quasisyntax/loc 
+              stx
+              (box #,(parse-q (unbox (syntax-e (syntax p)))))))
+            (p (q-error (syntax p)))))))
+      (parse-q stx))))
+    
diff --git a/collects/mzlib/private/plt-match/pattern-predicates.scm b/collects/mzlib/private/plt-match/pattern-predicates.scm
new file mode 100644
index 0000000000..e0bb6350a6
--- /dev/null
+++ b/collects/mzlib/private/plt-match/pattern-predicates.scm
@@ -0,0 +1,125 @@
+;; This library is used by match.ss
+
+;;!(function proper-hash-table-pattern?
+;;          (form (proper-hash-table-pattern? pat-list) -> bool)
+;;          (contract list-of-syntax -> bool))
+;; This function returns true if there is no ddk in the list of
+;; patterns or there is only a ddk at the end of the list.
+(define (proper-hash-table-pattern? pat-list)
+  (cond ((null? pat-list) #t)
+        (else
+         (let ((ddk-list (ddk-in-list? pat-list)))
+           (or (not ddk-list)
+               (and ddk-list
+                    (ddk-only-at-end-of-list? pat-list)))))))
+
+;;!(function ddk-in-list?
+;;          (form (ddk l) -> bool)
+;;          (contract list-of-syntax -> bool))
+;; This is a predicate that returns true if there is a ddk in the
+;; list.
+(define (ddk-in-list? l)
+  (not (andmap (lambda (x) (not (stx-dot-dot-k? x))) l)))
+
+;;!(function ddk-only-at-end-of-list?
+;;          (form (ddk-only-at-end-of-list? l) -> bool)
+;;          (contract list-of-syntax -> bool))
+;; This is a predicate that returns true if there is a ddk at the
+;; end of the list and the list has at least one item before the ddk.
+(define ddk-only-at-end-of-list?
+  (lambda (l)
+    '(match
+      l
+      (((not (? stx-dot-dot-k?)) ..1 a) (stx-dot-dot-k? a)))
+    (let ((x l))
+      (if (list? x)
+          (let ddnnl26305 ((exp26306 x) (count26307 0))
+            (if (and (not (null? exp26306))
+                     ((lambda (exp-sym) (if (stx-dot-dot-k? exp-sym) #f #t))
+                      (car exp26306)))
+                (ddnnl26305 (cdr exp26306) (add1 count26307))
+                (if (>= count26307 1)
+                    (if (and (pair? exp26306) (null? (cdr exp26306)))
+                        ((lambda (a) (stx-dot-dot-k? a)) (car exp26306))
+                        #f)
+                    #f)))
+          #f))))
+
+;;!(function ddk-only-at-end-of-vector?
+;;          (form (ddk-only-at-end-of-vector? vec) -> bool)
+;;          (contract vector -> bool))
+;; This is a predicate that returns true if there is a ddk at the
+;; end of the vector and the list has at least one item before the ddk.
+(define ddk-only-at-end-of-vector?
+  (lambda (vec)
+    '(match
+      vec
+      (#((not (? stx-dot-dot-k?)) ..1 a) #t))
+    ;; the following is expanded from the above match expression
+    (let ((x vec))
+      (let ((match-failure
+             (lambda () #f)))
+        (if (vector? x)
+            (let ((lv32956 (vector-length x)))
+              (if (>= lv32956 2)
+                  (let ((curr-ind32957 0))
+                    (let vloop32958 ((count32959 curr-ind32957))
+                      (let ((fail32961
+                             (lambda (count-offset32962 index32963)
+                               (if (>= count-offset32962 1)
+                                   (if (= index32963 lv32956)
+                                       (match-failure)
+                                       (let ((cindnm32965 (add1 index32963)))
+                                         (if (>= cindnm32965 lv32956)
+                                             ((lambda (a) #t) 
+                                              (vector-ref x index32963))
+                                             (match-failure))))
+                                   (match-failure)))))
+                        (if (= lv32956 count32959)
+                            (fail32961 (- count32959 curr-ind32957) count32959)
+                            (if (stx-dot-dot-k? (vector-ref x count32959))
+                                (fail32961 (- count32959 curr-ind32957) 
+                                           count32959)
+                                (let ((arglist (list)))
+                                  (apply vloop32958 (add1 count32959) 
+                                         arglist)))))))
+                  (match-failure)))
+            (match-failure))))))
+
+;;!(function ddk-in-vec?
+;;          (form (ddk-in-vec? vec stx) -> (integer or #f))
+;;          (contract (vector syntax) -> (integer or bool)))
+;; this function returns the total of the k's in a vector of syntax
+;; it also insure that the ..k's are not consecutive
+(define ddk-in-vec?
+  (lambda (vec stx)
+    ;; make sure first element is not ddk
+    (if (stx-dot-dot-k? (vector-ref vec 0))
+        (match:syntax-err
+         stx
+         "vector pattern cannot start with ..k syntax")
+        (let ((vlength (vector-length vec))
+              (flag #f))
+          (letrec ((check-vec
+                    (lambda (last-stx index)
+                      (if (= index vlength)
+                          0
+                          (let ((k-prev (stx-dot-dot-k? last-stx))
+                                (k-curr (stx-dot-dot-k? (vector-ref vec 
+                                                                    index))))
+                            (cond
+                             ((and k-prev k-curr)
+                              (match:syntax-err
+                               stx
+                               "consecutive ..k markers are not allowed"))
+                             (k-curr
+                              (begin
+                                (set! flag #t)
+                                (+ (- k-curr 2) (check-vec (vector-ref vec 
+                                                                       index) 
+                                                           (add1 index)))))
+                             (else
+                              (check-vec (vector-ref vec index) 
+                                         (add1 index)))))))))
+            (let ((res (check-vec (vector-ref vec 0) 1)))
+              (if flag res #f)))))))
diff --git a/collects/mzlib/private/plt-match/render-test-list.scm b/collects/mzlib/private/plt-match/render-test-list.scm
new file mode 100644
index 0000000000..b89da2b427
--- /dev/null
+++ b/collects/mzlib/private/plt-match/render-test-list.scm
@@ -0,0 +1,822 @@
+;; This library is used by match.ss
+
+;;!(function render-test-list
+;;          (form (render-test-list p ae stx) -> test-list)
+;;          (contract (syntax syntax syntax) -> list))
+;; This is the most important function of the entire compiler.
+;; This is where the functionality of each pattern is implemented.
+;; This function maps out how each pattern is compiled.  While it
+;; only returns a list of tests, the comp field of those tests
+;; contains a function which inturn knows enough to compile the
+;; pattern.
+;; <p>This is implemented in what Wright terms as mock-continuation-passing
+;; style.  The functions that create the syntax for a match success and failure
+;; are passed forward
+;; but they are always called in emit.  This is extremely effective for
+;; handling the different structures that are matched.  This way we can
+;; specify ahead of time how the rest of the elements of a list or vector
+;; should be handled.  Otherwise we would have to pass more information
+;; forward in the argument list of next and then test for it later and
+;; then take the appropriate action.  To understand this better take a
+;; look at how proper and improper lists are handled.
+(define (render-test-list p ae stx)
+  (include "special-generators.scm")
+  (include "ddk-handlers.scm")
+  (include "getter-setter.scm")
+  (include "emit-assm.scm")
+  (include "parse-quasi.scm")
+  (include "pattern-predicates.scm")
+
+  (define (append-if-necc sym stx)
+    (syntax-case stx ()
+      (() (syntax (list)))
+      ((a ...)
+       (quasisyntax/loc stx (#,sym a ...)))
+      (p (syntax p))))
+  (syntax-case*
+   p
+   (_ list quote quasiquote vector box ? app and or not struct set! var
+      list-rest get! ... ___ unquote unquote-splicing
+      list-no-order hash-table regexp pregexp) stx-equal?
+      (_ '()) ;(ks sf bv let-bound))
+      (pt
+       (and (identifier? (syntax pt))
+            (pattern-var? (syntax-object->datum (syntax pt)))
+            (not (stx-dot-dot-k? (syntax pt))))
+       (render-test-list (syntax/loc stx (var pt)) ae stx))
+      ((var pt)
+       (identifier? (syntax pt))
+       (list (make-act `bind-var-pat
+                       ae
+                       (lambda (ks kf let-bound)
+                         (lambda (sf bv)
+                           (let ((raw-id (syntax-object->datum (syntax pt))))
+                             (cond ((ormap (lambda (x)
+                                             (if (equal? raw-id (syntax-object->datum (car x)))
+                                                 (cdr x) #f)) bv)
+                                    => (lambda (bound-exp)
+                                         (emit (lambda (exp)
+                                                 (quasisyntax/loc
+                                                  p
+                                                  (equal? #,exp #,(subst-bindings bound-exp let-bound))))
+                                               ae
+                                               let-bound
+                                               sf bv kf ks)))
+                                   (else
+                                    (ks sf (cons (cons (syntax pt) ae) bv))))))))))
+
+      ((list)
+       (list
+        (make-reg-test
+         `(null? ,(syntax-object->datum ae))
+         ae
+         (lambda (ks kf let-bound)
+           (lambda (sf bv)
+             (emit (lambda (exp)
+                     (quasisyntax/loc p (null? #,exp)))
+                   ae
+                   let-bound
+                   sf
+                   bv
+                   kf
+                   ks))))))
+      ('()
+       (list
+        (make-reg-test
+         `(null? ,(syntax-object->datum ae))
+         ae
+         (lambda (ks kf let-bound)
+           (lambda (sf bv)
+             (emit (lambda (exp)
+                     (quasisyntax/loc p (null? #,exp)))
+                   ae
+                   let-bound
+                   sf
+                   bv
+                   kf
+                   ks)))))
+       )
+
+      (pt
+       ;; could convert the syntax once
+       (or (stx-? string? (syntax pt))
+           (stx-? boolean? (syntax pt))
+           (stx-? char? (syntax pt))
+           (stx-? number? (syntax pt)))
+       (list
+        (make-reg-test
+         `(equal? ,(syntax-object->datum ae)
+                  ,(syntax-object->datum (syntax pt)))
+         ae
+         (lambda (ks kf let-bound)
+           (lambda (sf bv)
+             (emit (lambda (exp) (quasisyntax/loc p (equal? #,exp pt)))
+                   ae
+                   let-bound
+                   sf bv kf ks))))))
+
+      ;(pt
+      ; (stx-? regexp? (syntax pt))
+      ; (render-test-list (syntax/loc p (regex pt)) ae stx))
+
+      ((quote _)
+       (list
+        (make-reg-test
+         `(equal? ,(syntax-object->datum ae)
+                  ,(syntax-object->datum p))
+         ae
+         (lambda (ks kf let-bound)
+           (lambda (sf bv)
+             (emit (lambda (exp) (quasisyntax/loc p (equal? #,exp #,p)))
+                   ae
+                   let-bound
+                   sf bv kf ks))))))
+      (`quasi-pat
+       (render-test-list (parse-quasi (syntax quasi-pat)) ae stx))
+      ('item
+       (list (make-reg-test
+              `(equal? ,(syntax-object->datum ae)
+                       ,(syntax-object->datum p))
+              ae
+              (lambda (ks kf let-bound)
+                (lambda (sf bv)
+                  (emit (lambda (exp) (quasisyntax/loc p (equal? #,exp #,p)))
+                        ae
+                        let-bound
+                        sf bv kf ks))))))
+      ;;('(items ...)
+      ;;(emit (quasisyntax/loc p (equal? #,e #,p)) sf bv kf ks))
+      ((? pred? pat1 pats ...)
+       (render-test-list (syntax (and (? pred?) pat1 pats ...)) ae stx))
+      ;; could we check to see if a predicate is a procedure here?
+      ((? pred?)
+       (list (make-reg-test
+              `(,(syntax-object->datum (syntax pred?))
+                ,(syntax-object->datum ae))
+              ae
+              (lambda (ks kf let-bound)
+                (lambda (sf bv)
+                  (emit (lambda (exp) (quasisyntax/loc p (pred? #,exp)))
+                        ae
+                        let-bound
+                        sf bv kf ks))))))
+      ;; syntax checking
+      ((? pred? ...)
+       (match:syntax-err
+        p
+        (if (zero? (length (syntax-e (syntax (pred? ...)))))
+            "a predicate pattern must have a predicate following the ?"
+            "syntax error in predicate pattern")))
+
+      ((regexp reg-exp)
+       (render-test-list (quasisyntax/loc 
+                          p
+                          (and (? string?)
+                               (? (lambda (x) (regexp-match reg-exp x)))))
+                         ae 
+                         stx))
+      ((pregexp reg-exp)
+       (render-test-list (quasisyntax/loc
+                          p
+                          (and (? string?)
+                               (? (lambda (x) (pregexp-match-with-error 
+                                               reg-exp x)))))
+                         ae 
+                         stx))
+
+      ((regexp reg-exp pat)
+       (render-test-list (quasisyntax/loc
+                          p
+                          (and (? string?)
+                               (app (lambda (x) (regexp-match reg-exp x)) pat)))
+                         ae 
+                         stx))
+
+      ((pregexp reg-exp pat)
+       (render-test-list (quasisyntax/loc
+                          p
+                          (and (? string?)
+                               (app (lambda (x) (pregexp-match-with-error 
+                                                   reg-exp x)) pat)))
+                         ae 
+                         stx))
+
+      ((app op pat)
+       (render-test-list (syntax pat)
+                         (quasisyntax/loc p (op #,ae))
+                         stx))
+      ;; syntax checking
+      ((app op ...)
+       (match:syntax-err
+        p
+        (if (zero? (length (syntax-e (syntax (op ...)))))
+            "an operation pattern must have a procedure following the app"
+            "there should be one pattern following the operator")))
+      ((and pats ...)
+       (let loop
+           ((p (syntax (pats ...))))
+         (syntax-case p ()
+           (() '()) ;(ks seensofar boundvars let-bound))
+           ((pat1 pats ...)
+            (append (render-test-list (syntax pat1) ae stx)
+                    (loop (syntax (pats ...))))))))
+
+      ((or pats ...)
+       (list (make-act
+              'or-pat ;`(or-pat ,(syntax-object->datum ae))
+              ae
+              (lambda (ks kf let-bound)
+                (lambda (sf bv)
+                  (or-gen ae (syntax-e (syntax (pats ...)))
+                          stx sf bv ks kf let-bound))))))
+
+                                        ; backtracking or
+
+                                        ;       ((or pats ...)
+                                        ;        (let* ((pat-list (syntax->list (syntax (pats ...)))))
+                                        ;          (let* ((bound (getbindings (stx-car (syntax (pats ...)))))
+                                        ;                 (bind-map
+                                        ;                  (map (lambda (x)
+                                        ;                         (cons x
+                                        ;                               #`#,(gensym (syntax-object->datum x))))
+                                        ;                       bound))
+                                        ;                 (id (begin (set! or-id (add1 or-id)) (sub1 or-id))))
+                                        ;            (write id)(newline)
+                                        ;            (write (syntax-object->datum (syntax (pats ...))))(newline)
+                                        ;            (list
+                                        ;             (make-act
+                                        ;              'or-pat
+                                        ;              ae
+                                        ;              (lambda (ks kf let-bound)
+                                        ;                (lambda (sf bv)
+                                        ;                  (write id)(newline)
+                                        ;                  (if (stx-null? (syntax (pats ...)))
+                                        ;                      (kf sf bv)
+                                        ;                      #`(let #,(map (lambda (b)
+                                        ;                                      #`(#,(cdr b) '()))
+                                        ;                                    bind-map)
+                                        ;                          (if (or
+                                        ;                               #,@(map (lambda (p)
+                                        ;                                         #`(#,(create-test-func
+                                        ;                                               p
+                                        ;                                               sf
+                                        ;                                               let-bound
+                                        ;                                               bind-map
+                                        ;                                               #f) #,(subst-bindings ae
+                                        ;                                                            let-bound)))
+                                        ;                                       pat-list))
+                                        ;                              #,(ks sf (append bind-map bv))
+                                        ;                              #,(kf sf bv)))))))))))
+
+      ((not pat)
+       (list (make-act
+              'not-pat ;`(not-pat ,(syntax-object->datum ae))
+              ae
+              (lambda (ks kf let-bound)
+                (lambda (sf bv)
+                  ;; swap success and fail
+                  (next-outer (syntax pat) ae sf bv let-bound ks kf))))))
+      ;; could try to catch syntax local value error and rethrow syntax error
+
+      ((list-no-order pats ...)
+       (if (stx-null? (syntax (pats ...)))
+           (render-test-list (syntax/loc p (list)) ae stx)
+           (let* ((pat-list (syntax->list (syntax (pats ...))))
+                  (ddk-list (ddk-in-list? pat-list))
+                  (ddk (ddk-only-at-end-of-list? pat-list)))
+             (if (or (not ddk-list)
+                     (and ddk-list ddk))
+                 (let* ((bound (getbindings (append-if-necc 'list
+                                                            (syntax (pats ...)))))
+                        (bind-map
+                         (map (lambda (x)
+                                (cons x
+                                      #`#,(gensym (syntax-object->datum x))))
+                              bound)))
+
+                   (list
+                    (make-shape-test
+                     `(list? ,(syntax-object->datum ae))
+                     ae
+                     (lambda (ks kf let-bound)
+                       (lambda (sf bv)
+                         (emit (lambda (exp)
+                                 (quasisyntax/loc stx (list? #,exp)))
+                               ae
+                               let-bound
+                               sf
+                               bv
+                               kf
+                               ks))))
+                    (make-act
+                     'list-no-order
+                     ae
+                     (lambda (ks kf let-bound)
+                       (lambda (sf bv)
+                         (let ((last-test
+                                (if ddk
+                                    (let ((pl (cdr (reverse pat-list))))
+                                      (begin
+                                        (set! pat-list (reverse (cdr pl)))
+                                        (create-test-func (car pl)
+                                                          sf
+                                                          let-bound
+                                                          bind-map
+                                                          #t)))
+                                    #f)))
+                           #`(let #,(map (lambda (b)
+                                           #`(#,(cdr b) '()))
+                                         bind-map)
+                               (let ((last-test #,last-test)
+                                     (test-list
+                                      (list
+                                       #,@(map (lambda (p)
+                                                 (create-test-func
+                                                  p
+                                                  sf
+                                                  let-bound
+                                                  bind-map
+                                                  #f))
+                                               pat-list))))
+                                 (if (match:test-no-order test-list
+                                                          #,ae
+                                                          last-test
+                                                          #,ddk)
+                                     #,(ks sf (append bind-map bv))
+                                     #,(kf sf bv))))))))))
+                 (match:syntax-err
+                  p
+                  (string-append "dot dot k can only appear at "
+                                 "the end of unordered match patterns"))))))
+
+      ((hash-table pats ...)
+       ;; must check the structure
+       (proper-hash-table-pattern? (syntax->list (syntax (pats ...))))
+       (list
+        (make-shape-test
+         `(hash-table? ,(syntax-object->datum ae))
+         ae
+         (lambda (ks kf let-bound)
+           (lambda (sf bv)
+             (emit (lambda (exp) (quasisyntax/loc stx (hash-table? #,exp)))
+                   ae
+                   let-bound
+                   sf
+                   bv
+                   kf
+                   ks))))
+        (let ((mod-pat
+               (lambda (pat)
+                 (syntax-case pat ()
+                   ((key value) (syntax (list key value)))
+                   (ddk
+                    (stx-dot-dot-k? (syntax ddk))
+                    (syntax ddk))
+                   (id
+                    (and (identifier? (syntax id))
+                         (pattern-var? (syntax-object->datum (syntax id)))
+                         (not (stx-dot-dot-k? (syntax id))))
+                    (syntax id))
+                   (p (match:syntax-err
+                       (syntax/loc stx p)
+                       "poorly formed hash-table pattern"))))))
+          (make-act
+           'hash-table-pat
+           ae
+           (lambda (ks kf let-bound)
+             (lambda (sf bv)
+               (let ((hash-name (gensym 'hash)))
+                 #`(let ((#,hash-name
+                          (hash-table-map #,(subst-bindings ae
+                                                            let-bound)
+                                          (lambda (k v) (list k v)))))
+                     #,(next-outer #`(list-no-order #,@(map mod-pat (syntax->list (syntax (pats ...)))))
+                                   #`#,hash-name
+                                   sf
+                                   ;; these tests have to be true
+                                   ;;(append (list
+                                   ;;         '(pair? exp)
+                                   ;;         '(pair? (cdr exp))
+                                   ;;         '(null? (cdr (cdr exp))))
+                                   ;;        sf)
+                                   bv
+                                   let-bound
+                                   kf
+                                   ks)))))))))
+
+      ((hash-table pats ...)
+       (match:syntax-err
+        p
+        "improperly formed hash table pattern"))
+
+      ((struct struct-name (fields ...))
+       (identifier? (syntax struct-name))
+       (let ((num-of-fields (stx-length (syntax (fields ...)))))
+         (let-values (((pred accessors mutators parental-chain)
+                       (struct-pred-accessors-mutators
+                        (syntax struct-name)
+                        (lambda ()
+                          (match:syntax-err
+                           (syntax struct-name)
+                           "not a defined structure")))))
+           (let ((dif (- (length accessors) num-of-fields)))
+             (if (not (zero? dif))
+                 (match:syntax-err
+                  p
+                  (string-append
+                   (if (> dif 0) "not enough " "too many ")
+                   "fields for structure in pattern"))
+                 (cons
+                  (make-shape-test
+                   `(struct-pred ,(syntax-object->datum pred)
+                                 ,(map syntax-object->datum parental-chain)
+                                 ,(syntax-object->datum ae))
+                   ae
+                   (lambda (ks kf let-bound)
+                     (lambda (sf bv)
+                       (emit (lambda (exp)
+                               (quasisyntax/loc stx (struct-pred #,pred #,parental-chain #,exp)))
+                             ae
+                             let-bound
+                             sf
+                             bv
+                             kf
+                             ks))))
+                  (let ((field-pats (syntax->list (syntax (fields ...)))))
+                    (let rloop ((n 0))
+                      (if (= n num-of-fields)
+                          '()
+                          (append
+                           (let ((cur-pat (list-ref field-pats n)))
+                             (syntax-case cur-pat (set! get!)
+                               ((set! setter-name)
+                                (list (make-act
+                                       'set!-pat
+                                       ae
+                                       (lambda (ks kf let-bound)
+                                         (lambda (sf bv)
+                                           (ks sf
+                                               (cons (cons (syntax setter-name)
+                                                           #`(lambda (y)
+                                                               (#,(list-ref
+                                                                   mutators
+                                                                   n)
+                                                                #,ae y)))
+                                                     bv)))))))
+                               ((get! getter-name)
+                                (list (make-act
+                                       'get!-pat
+                                       ae
+                                       (lambda (ks kf let-bound)
+                                         (lambda (sf bv)
+                                           (ks sf
+                                               (cons (cons (syntax getter-name)
+                                                           #`(lambda ()
+                                                               (#,(list-ref
+                                                                   accessors
+                                                                   n)
+                                                                #,ae)))
+                                                     bv)))))))
+                               (_
+                                (render-test-list
+                                 cur-pat
+                                 (quasisyntax/loc
+                                  stx
+                                  (#,(list-ref accessors n) #,ae))
+                                 stx))))
+                           (rloop (+ 1 n))))))))))))
+      ;; syntax checking
+      ((struct ident ...)
+       (match:syntax-err
+        p
+        (if (zero? (length (syntax-e (syntax (ident ...)))))
+            (format "~a~n~a~n~a"
+                    "a structure pattern must have the name "
+                    "of a defined structure followed by a list of patterns "
+                    "to match each field of that structure")
+            "syntax error in structure pattern")))
+      ((set! ident)
+       (identifier? (syntax ident))
+       (list (make-act
+              'set!-pat
+              ae
+              (lambda (ks kf let-bound)
+                (lambda (sf bv)
+                  (ks sf (cons (cons (syntax ident)
+                                     (setter ae p let-bound))
+                               bv)))))))
+      ;; syntax checking
+      ((set! ident ...)
+       (let ((x (length (syntax-e (syntax (ident ...))))))
+         (match:syntax-err
+          p
+          (if (= x 1)
+              "there should be an identifier after set! in pattern"
+              (string-append "there should "
+                             (if (zero? x) "" "only ")
+                             "be one identifier after set! in pattern")))))
+      ((get! ident)
+       (identifier? (syntax ident))
+       (list (make-act
+              'get!-pat
+              ae
+              (lambda (ks kf let-bound)
+                (lambda (sf bv)
+                  (ks sf (cons (cons (syntax ident)
+                                     (getter ae p let-bound))
+                               bv)))))))
+      ((get! ident ...)
+       (let ((x (length (syntax-e (syntax (ident ...))))))
+         (match:syntax-err
+          p
+          (if (= x 1)
+              "there should be an identifier after get! in pattern"
+              (string-append "there should "
+                             (if (zero? x) "" "only ")
+                             "be one identifier after get! in pattern")))))
+
+      ((list pat dot-dot-k pat-rest ...)
+       (and (not (or (memq (syntax-e (syntax pat))
+                           '(unquote unquote-splicing ... ___))
+                     (stx-dot-dot-k? (syntax pat))))
+            (stx-dot-dot-k? (syntax dot-dot-k)))
+       (list
+        (make-shape-test
+         `(list? ,(syntax-object->datum ae))
+         ae
+         (lambda (ks kf let-bound)
+           ;;(write 'here)(write let-bound)(newline)
+           (lambda (sf bv)
+             (emit
+              (lambda (exp) (quasisyntax/loc stx (list? #,exp)))
+              ae
+              let-bound
+              sf
+              bv
+              kf
+              ks))))
+        (make-act
+         'list-ddk-pat
+         ae
+         (lambda (ks kf let-bound)
+           (if (stx-null? (syntax (pat-rest ...)))
+               (handle-end-ddk-list ae kf ks
+                                    (syntax pat)
+                                    (syntax dot-dot-k)
+                                    stx let-bound)
+               (handle-inner-ddk-list ae kf ks
+                                      (syntax pat)
+                                      (syntax dot-dot-k)
+                                      (append-if-necc 'list
+                                                      (syntax (pat-rest ...)))
+                                      stx
+                                      let-bound))))))
+
+      ((list-rest pat dot-dot-k pat-rest ...)
+       (and (not (or (memq (syntax-e (syntax pat))
+                           '(unquote unquote-splicing ... ___))
+                     (stx-dot-dot-k? (syntax pat))
+                     (stx-null? (syntax (pat-rest ...)))))
+            (stx-dot-dot-k? (syntax dot-dot-k)))
+       (list
+        (make-shape-test
+         `(pair? ,(syntax-object->datum ae))
+         ae
+         (lambda (ks kf let-bound)
+           ;;(write 'here)(write let-bound)(newline)
+           (lambda (sf bv)
+             (emit
+              (lambda (exp) (quasisyntax/loc stx (pair? #,exp)))
+              ae
+              let-bound
+              sf
+              bv
+              kf
+              ks))))
+        (make-act
+         'list-ddk-pat
+         ae
+         (lambda (ks kf let-bound)
+           (handle-inner-ddk-list
+            ae kf ks
+            (syntax pat)
+            (syntax dot-dot-k)
+            (if (= 1 (length
+                      (syntax->list (syntax (pat-rest ...)))))
+                (stx-car (syntax (pat-rest ...)))
+                (append-if-necc  'list-rest
+                                 (syntax (pat-rest ...))))
+            stx
+            let-bound)))))
+
+      ;; handle proper and improper lists
+
+      ((list-rest car-pat cdr-pat) ;pattern ;(pat1 pats ...)
+       (not (or (memq (syntax-e (syntax car-pat))
+                      '(unquote unquote-splicing))
+                (stx-dot-dot-k? (syntax car-pat))))
+       (cons
+        (make-shape-test
+         `(pair? ,(syntax-object->datum ae))
+         ae
+         (lambda (ks kf let-bound)
+           ;;(write 'here)(write let-bound)(newline)
+           (lambda (sf bv)
+             (emit
+              (lambda (exp) (quasisyntax/loc stx (pair? #,exp)))
+              ae
+              let-bound
+              sf
+              bv
+              kf
+              ks))))
+        (append
+         (render-test-list (syntax car-pat)
+                           (quasisyntax/loc (syntax car-pat) (car #,ae))
+                           stx) ;(add-a e)
+         (render-test-list
+          (syntax cdr-pat)
+          (quasisyntax/loc (syntax cdr-pat) (cdr #,ae))
+          stx))))
+
+      ((list-rest car-pat cdr-pat ...) ;pattern ;(pat1 pats ...)
+       (not (or (memq (syntax-e (syntax car-pat))
+                      '(unquote unquote-splicing))
+                (stx-dot-dot-k? (syntax car-pat))))
+       (cons
+        (make-shape-test
+         `(pair? ,(syntax-object->datum ae))
+         ae
+         (lambda (ks kf let-bound)
+           ;;(write 'here)(write let-bound)(newline)
+           (lambda (sf bv)
+             (emit
+              (lambda (exp) (quasisyntax/loc stx (pair? #,exp)))
+              ae
+              let-bound
+              sf
+              bv
+              kf
+              ks))))
+        (append
+         (render-test-list (syntax car-pat)
+                           (quasisyntax/loc (syntax car-pat) (car #,ae))
+                           stx) ;(add-a e)
+         (render-test-list
+          (append-if-necc 'list-rest (syntax (cdr-pat ...)))
+          (quasisyntax/loc (syntax (cdr-pat ...)) (cdr #,ae))
+          stx))))
+
+      ((list car-pat cdr-pat ...) ;pattern ;(pat1 pats ...)
+       (not (or (memq (syntax-e (syntax car-pat))
+                      '(unquote unquote-splicing))
+                (stx-dot-dot-k? (syntax car-pat))))
+       (cons
+        (make-shape-test
+         `(pair? ,(syntax-object->datum ae))
+         ae
+         (lambda (ks kf let-bound)
+           ;;(write 'here)(write let-bound)(newline)
+           (lambda (sf bv)
+             (emit
+              (lambda (exp) (quasisyntax/loc stx (pair? #,exp)))
+              ae
+              let-bound
+              sf
+              bv
+              kf
+              ks))))
+        (append
+         (render-test-list (syntax car-pat)
+                           (quasisyntax/loc (syntax car-pat) (car #,ae))
+                           stx) ;(add-a e)
+         (if (stx-null? (syntax (cdr-pat ...)))
+             (list
+              (make-shape-test
+               `(null? (cdr ,(syntax-object->datum ae)))
+               ae
+               (lambda (ks kf let-bound)
+                 (lambda (sf bv)
+                   (emit (lambda (exp)
+                           (quasisyntax/loc p (null? #,exp)))
+                         (quasisyntax/loc (syntax (cdr-pat ...)) (cdr #,ae));ae
+                         let-bound
+                         sf
+                         bv
+                         kf
+                         ks)))))
+             (render-test-list
+              (append-if-necc 'list (syntax (cdr-pat ...)))
+              (quasisyntax/loc (syntax (cdr-pat ...)) (cdr #,ae))
+              stx)))))
+
+      ((vector pats ...)
+       (ddk-only-at-end-of-list? (syntax-e (syntax (pats ...))))
+       (list
+        (make-shape-test
+         `(vector? ,(syntax-object->datum ae))
+         ae
+         (lambda (ks kf let-bound)
+           (lambda (sf bv)
+             (emit (lambda (exp) (quasisyntax/loc stx (vector? #,exp)))
+                   ae
+                   let-bound
+                   sf
+                   bv
+                   kf
+                   ks))))
+        (make-act
+         'vec-ddk-pat
+         ae
+         (lambda (ks kf let-bound)
+           (handle-ddk-vector ae kf ks
+                              (syntax/loc p #(pats ...))
+                              stx let-bound)))))
+
+      ((vector pats ...)
+       (let* ((temp (syntax-e (syntax (pats ...))))
+              (len (length temp)))
+         (and (>= len 2)
+              (ddk-in-list? temp)))
+       ;; make this contains ddk with no ddks consecutive
+       ;;(stx-dot-dot-k? (vector-ref temp (sub1 len))))))
+       (list
+        (make-shape-test
+         `(vector? ,(syntax-object->datum ae))
+         ae
+         (lambda (ks kf let-bound)
+           (lambda (sf bv)
+             (emit (lambda (exp) (quasisyntax/loc stx (vector? #,exp)))
+                   ae
+                   let-bound
+                   sf
+                   bv
+                   kf
+                   ks))))
+        ;; we have to look at the first pattern and see if a ddk follows it
+        ;; if so handle that case else handle the pattern
+        (make-act
+         'vec-ddk-pat
+         ae
+         (lambda (ks kf let-bound)
+           (handle-ddk-vector-inner ae kf ks
+                                    (syntax/loc p #(pats ...))
+                                    stx let-bound)))))
+
+      ((vector pats ...)
+       (let* ((syntax-vec (list->vector (syntax->list (syntax (pats ...)))))
+              (vlen (vector-length syntax-vec)))
+         (cons
+          (make-shape-test
+           `(vector? ,(syntax-object->datum ae))
+           ae
+           (lambda (ks kf let-bound)
+             (lambda (sf bv)
+               (emit
+                (lambda (exp) (quasisyntax/loc stx (vector? #,exp)))
+                ae
+                let-bound
+                sf bv kf ks))))
+          (cons
+           (make-shape-test
+            `(equal? (vector-length ,(syntax-object->datum ae)) ,vlen)
+            ae
+            (lambda (ks kf let-bound)
+              (lambda (sf bv)
+                (emit
+                 (lambda (exp) (quasisyntax/loc
+                                stx
+                                (equal? (vector-length #,exp) #,vlen)))
+                 ae
+                 let-bound
+                 sf bv kf ks))))
+           (let vloop ((n 0))
+             (if (= n vlen)
+                 '()
+                 (append
+                  (render-test-list
+                   (vector-ref syntax-vec n)
+                   (quasisyntax/loc stx (vector-ref #,ae #,n))
+                   stx)
+                  (vloop (+ 1 n)))))))))
+
+      ((box pat)
+       (cons
+        (make-shape-test
+         `(box? ,(syntax-object->datum ae))
+         ae
+         (lambda (ks kf let-bound)
+           (lambda (sf bv)
+             (emit
+              (lambda (exp) (quasisyntax/loc stx (box? #,exp)))
+              ae
+              let-bound
+              sf bv kf ks))))
+        (render-test-list
+         (syntax pat)
+         (quasisyntax/loc stx (unbox #,ae))
+         stx)))
+      (got-too-far
+       (match:syntax-err
+        (syntax/loc stx got-too-far)
+        "syntax error in pattern"))))
diff --git a/collects/mzlib/private/plt-match/reorder-tests.scm b/collects/mzlib/private/plt-match/reorder-tests.scm
new file mode 100644
index 0000000000..919a7fbf0b
--- /dev/null
+++ b/collects/mzlib/private/plt-match/reorder-tests.scm
@@ -0,0 +1,99 @@
+;; This library is used by match.ss
+;; This requires the test data structure.
+
+(define-values (reorder-all-lists)
+  (letrec 
+      (
+       ;;!(function insertion-sort
+       ;;          (form (insertion-sort ls less-than?) -> list)
+       ;;          (contract (list (any any -> bool) -> list)))
+       ;; This is the classic stable sort.  Any stable sort will do.
+       (insertion-sort 
+        (lambda (ls less-than?)
+          (define (insert el ls)
+            (define (ins ls)
+              (cond ((null? ls) (list el))
+                    ((less-than? el (car ls))
+                     (cons el ls))
+                    (else (cons (car ls) (ins (cdr ls))))))
+            (ins ls))
+          (letrec ((IS (lambda (ls)
+                         (if (null? ls)
+                             '()
+                             (insert (car ls)
+                                     (IS (cdr ls)))))))
+            (IS ls))))
+
+        ;;!(function make-test-order-func
+        ;;          (form (make-test-order-func whole-list) -> less-than?)
+        ;;          (contract list -> (any any -> bool)))
+        ;; This function creates a test function which has access to the
+        ;;whole list of test structures capured in the closure.  This
+        ;;function places tests that are used more ahead of those used
+        ;;less.  When tests are used an equal number of times the test whos
+        ;;membership set has the greatest presence is placed ahead.
+        (make-test-order-func
+         (lambda (whole-list)
+           (lambda (t1 t2)
+             (let ((t1-tu (test-times-used t1))
+                   (t2-tu (test-times-used t2)))
+               (cond ((> t1-tu t2-tu) #t)
+                     ;; these two new rules allow negate
+                     ;; tests to be placed properly
+                     ((and (= t1-tu t2-tu)
+                           (shape-test? t1)
+                           (not (shape-test? t2))
+                           (negate-test? t2))
+                      #t)
+                     ((and (= t1-tu t2-tu)
+                           (not (shape-test? t1))
+                           (negate-test? t1)
+                           (shape-test? t2))
+                      #f)
+                     ((and (= t1-tu t2-tu)
+                           (or (equal? (test-used-set t1) (test-used-set t2))
+                               (>= (number-of-similar (test-used-set t1) 
+                                                      whole-list)
+                                   (number-of-similar (test-used-set t2) 
+                                                      whole-list))))
+                      #t)
+                     (else #f))))))
+
+        ;;!(function number-of-similar
+        ;;          (form (number-of-similar set ls) -> integer)
+        ;;          (contract (list list) -> integer))
+        ;; This function returns the number of tests that have a
+        ;; membership set similar to set.  A membership set is the set of
+        ;; test-lists that have a similar tests as the test itself.
+        (number-of-similar 
+         (lambda (set ls)
+           (apply + (map (lambda (set2) (if (equal? set set2) 1 0))
+                         (map test-used-set ls)))))
+
+        ;;!(function reorder-tests
+        ;;          (form (reorder-tests2 test-list) -> test-list)
+        ;;          (contract list -> list))
+        ;; This function reorders one list of test structs.
+        (reorder-tests 
+         (lambda (test-list)
+           ;;(pretty-print test-list)(newline)
+           (insertion-sort test-list (make-test-order-func test-list))))
+
+        ;;!(function reorder-all-lists
+        ;;          (form (reorder-all-lists2 rendered-list) -> list)
+        ;;          (contract list -> list))
+        ;; This function reorders all of the rendered-lists that have
+        ;; success-functions attached to them.
+        (reorder-all-lists 
+         (lambda (rendered-list)
+           (if (null? rendered-list)
+               '()
+               (let ((success-func (cdr (car rendered-list)))
+                     (rot (reorder-tests (caar rendered-list))))
+                                        ;(pretty-print rot)(newline)
+                 (cons (cons rot success-func)
+                       (reorder-all-lists (cdr rendered-list)))))))
+        )
+    (values reorder-all-lists)))
+
+
diff --git a/collects/mzlib/private/plt-match/special-generators.scm b/collects/mzlib/private/plt-match/special-generators.scm
new file mode 100644
index 0000000000..fc28ac0489
--- /dev/null
+++ b/collects/mzlib/private/plt-match/special-generators.scm
@@ -0,0 +1,150 @@
+;; This library is used by match.ss
+
+;;!(function or-gen
+;;         (form (or-gen exp orpatlist stx sf bv ks kf let-bound)
+;;               ->
+;;               syntax)
+;;         (contract (syntax list syntax list list (list list -> syntax) 
+;;                    (list list -> syntax) list)
+;;                   ->
+;;                   syntax))
+;; The function or-gen is very similar to the function gen except
+;; that it is called when an or pattern is compiled.  An or
+;; pattern is essentially the same as a match pattern with several
+;; clauses.  The key differences are that it exists within a
+;; larger pattern and the state of compilation has information
+;; that will help optimaize its compilation.  And the success of
+;; any pattern results in the same outcome.
+(define or-gen
+  (lambda (exp orpatlist stx sf bv ks kf let-bound)
+    (let ((rendered-list
+           (map
+            (lambda (pat) 
+              (cons (render-test-list pat exp stx)
+                    (lambda (fail let-bound)
+                      (lambda (sf bv)
+                        (let ((bv (map
+                                   (lambda (bind)
+                                     (cons (car bind)
+                                           (subst-bindings (cdr bind) 
+                                                           let-bound)))
+                                   bv)))
+                          (ks sf bv))))))
+            orpatlist)))
+      (update-counts rendered-list)
+      (update-binding-counts rendered-list)
+      (let* ((rendered-list 
+              (reorder-all-lists rendered-list)
+              )
+             (output ((meta-couple rendered-list kf let-bound bv) sf bv)))
+        output))))
+
+;;!(function next-outer
+;;          (form (next-outer p ae sf bv let-bound kf ks syntax bool)
+;;                ->
+;;                syntax)
+;;          (contract (syntax syntax list list list (list list -> syntax)
+;;                     (list list -> syntax) syntax bool)
+;;                    ->
+;;                    syntax))
+;; The function next-outer is basically a throw-back to the next
+;; function of the original match compiler.  It compiles a pattern
+;; or sub-pattern of a clause and does not yield a list of
+;; partially compiled test structs.  This function is called
+;; inside of test constructs that cannot be eliminated because of
+;; a related presence in the test-so-far list.  So, instead of
+;; partially compiling patterns this function fully compiles patterns.
+(define next-outer
+  (opt-lambda (p
+               ae ;; this is the actual expression
+               sf
+               bv
+               let-bound
+               kf
+               ks
+               [stx (syntax '())]
+               [opt #f])
+    (next-outer-helper p ae sf bv let-bound 
+                       (lambda (x) kf) (lambda (a b) ks) stx opt)))
+
+;;!(function next-outer-helper
+;;          (form (next-outer p ae sf bv let-bound kf-func ks-func syntax bool)
+;;                ->
+;;                syntax)
+;;          (contract (syntax syntax list list list (list list -> syntax)
+;;                     (list list -> syntax) syntax bool)
+;;                    ->
+;;                    syntax))
+;; The function next-outer-helper contains the meat of next-outer
+;; and allows the programmer to pass higher order functions
+;; ks-func and kf-func that will be given compile time imformation
+;; about let-bindings etc. which in turn will allow the programmer
+;; to take advantage of this info.
+(define next-outer-helper
+  (opt-lambda (p
+               ae ;; this is the actual expression
+               sf
+               bv
+               let-bound
+               kf-func
+               ks-func
+               [stx (syntax '())]
+               [opt #f])
+    ;; right now this does not bind new variables
+    (let ((rendered-list (render-test-list p ae stx)))
+      ;; no need to reorder lists although I suspect that it may be
+      ;; better to put shape tests first
+      (update-binding-count rendered-list)
+      ((couple-tests rendered-list ks-func kf-func let-bound) sf bv))))
+
+;;!(function create-test-func
+;;          (form (create-test-func p sf let-bound bind-map last-test)
+;;                ->
+;;                syntax)
+;;          (contract (syntax list list a-list bool) -> syntax))
+;; This function creates a runtime function that is used as an
+;; individual test in a list of tests for the list-no-order
+;; pattern.
+;; <pre>
+;; bindmap - a-list of bindings mapped to their expressions
+;; last-test - a boolean value that indicates whether this function
+;; is collecting one value or a list of values.</pre>
+(define (create-test-func p sf let-bound bind-map last-test)
+  (quasisyntax/loc
+   p
+   (lambda (exp)
+     #,(next-outer-helper 
+        p #'exp sf '() let-bound
+        (lambda (let-bound)
+          (lambda (sf bv)
+            #'#f))
+        (lambda (fail let-bound)
+          (lambda (sf bv)
+            #`(begin
+                #,@(map (lambda (bind)
+                          (let ((binding-name (get-bind-val (car bind) bind-map))
+                                (exp-to-bind 
+                                 (subst-bindings (cdr bind) let-bound)))
+                            (if last-test
+                                #`(set! #,binding-name
+                                        (cons #,exp-to-bind #,binding-name))
+                                #`(set! #,binding-name
+                                        #,exp-to-bind))))
+                        bv)
+                #t)))))))
+
+;;!(function getbindings
+;;          (form (getbindings pat-syntax) -> list)
+;;          (contract syntax -> list))
+;; This function given a pattern returns a list of pattern
+;; variable names which are found in the pattern.
+(define (getbindings pat-syntax)
+  (let/cc out
+          (next-outer
+           pat-syntax
+           (quote-syntax dummy)
+           '()
+           '()
+           '()
+           (lambda (sf bv) #'(dummy-symbol))
+           (lambda (sf bv) (out (map car bv))))))
diff --git a/collects/mzlib/private/plt-match/tag-negate-tests.scm b/collects/mzlib/private/plt-match/tag-negate-tests.scm
new file mode 100644
index 0000000000..393061d6b6
--- /dev/null
+++ b/collects/mzlib/private/plt-match/tag-negate-tests.scm
@@ -0,0 +1,99 @@
+(define (tag-neg-test ls target-set)
+  (easy-tag ls #f target-set))
+
+(define (easy-tag ls last-shape target-set)
+  (cond ((null? ls) #f)
+        ((let ((tst (car ls)))
+           (and ;(not (action-test? tst))
+                (not (or (shape-test? tst) (action-test? tst)))
+                (equal? target-set (test-used-set-neg tst))))
+         (begin 
+           (when (and last-shape (not (shape-test? (car ls))))
+             (set-test-closest-shape-tst! (car ls) last-shape) 
+             (set-test-used-set! (car ls) last-shape)
+             (set-test-times-used! (car ls) (length last-shape)))
+           #t))
+        ((shape-test? (car ls))
+         (easy-tag (cdr ls) (test-used-set (car ls)) target-set))
+        (else 
+         (easy-tag (cdr ls) last-shape target-set))))
+
+(define (tag-negate-tests ls-of-ls)
+  (letrec ((gen-target-set-help
+            (lambda (init length)
+              (if (zero? length)
+                  '()
+                  (cons init 
+                        (gen-target-set-help (add1 init) 
+                                             (sub1 length))))))
+           (gen-target-set
+            (lambda (length)
+              (gen-target-set-help 2 length)))
+           (tag-help 
+            (lambda (ls target-set)
+              (if (null? target-set) 
+                  '()
+                  (begin 
+                    (tag-neg-test (car ls) 
+                                  (reverse target-set))
+                    (tag-help
+                     (cdr ls)
+                     (cdr target-set)))))))
+    (tag-help (map car ls-of-ls) (gen-target-set (sub1 (length ls-of-ls))))))
+           
+
+; (define (move-negates-to-tags ls-of-ls)
+;   (map (lambda (l) (cons (move-neg-to-tag (car l))
+;                          (cdr l)))
+;        ls-of-ls))
+                         
+
+; (define (move-neg-to-tag ls)
+;   (let-values (((list-without-neg-tests neg-tests)
+;                 (let loop ((l ls)
+;                            (ntsf '()))
+;                   (cond ((null? l) (values '() ntsf))
+;                         ((negate-test? (car l))
+;                          (loop (cdr l) (append ntsf (list (car l)))))
+;                         (else 
+;                          (let-values (((lwnt ntsf) (loop (cdr l) ntsf)))
+;                            (values (cons (car l) lwnt)
+;                                    ntsf)))))))
+; ;(write 'lwnt--)(pretty-print list-without-neg-tests)
+; ;(write 'neg-test)(pretty-print neg-tests)
+;     (letrec ((insert-negtest 
+;               (lambda (t-list neg-test)
+;                 (cond ((null? t-list)
+;                        '())
+;                       ((and (equal? (test-used-set (car t-list))
+;                                     (test-closest-shape-tst neg-test))
+;                             (or (null? (cdr t-list))
+;                                 (not (equal? (test-used-set (cadr t-list))
+;                                     (test-closest-shape-tst neg-test)))))
+;                        (cons (car t-list)
+;                              (cons neg-test
+;                                    (cdr t-list))))
+;                      ;  ((equal? (test-tst (car t-list))
+; ;                                (test-closest-shape-tst neg-test))
+; ;                        (cons (car t-list)
+; ;                              (cons neg-test
+; ;                                    (cdr t-list))))
+;                       (else 
+;                        (cons (car t-list) 
+;                              (insert-negtest (cdr t-list)
+;                                              neg-test)))))))
+;       (let loop2 ((t-list list-without-neg-tests)
+;                   (ntst neg-tests))
+;         ;(write 't-list)(pretty-print t-list)
+;         ;(write 'ntst ) (pretty-print ntst)
+;         ;(write 'insert) (pretty-print (insert-negtest t-list (car ntst)) )
+; (cond ((null? ntst) t-list)
+;       (else (insert-negtest t-list (car ntst))))))))
+;        ;  (cond ((null? ntst)
+; ;                t-list)
+; ;               (loop2 (insert-negtest t-list (car ntst)) 
+; ;                      (cdr ntst)))))))
+  
+    
+         
+  
\ No newline at end of file
diff --git a/collects/mzlib/private/plt-match/test-structure.scm b/collects/mzlib/private/plt-match/test-structure.scm
new file mode 100644
index 0000000000..0601185510
--- /dev/null
+++ b/collects/mzlib/private/plt-match/test-structure.scm
@@ -0,0 +1,110 @@
+;; This library is used by match.ss
+
+;; This is the major data structure of the compiler.  It holds a
+;; great deal of information.  This structure represents a
+;; partially compiled match test.  This test is the basic unit of
+;; compilation.  The order of these tests greatly affects the size
+;; of the final compiled match expression.  it also affects the
+;; amount of time it takes to compile a match expression.
+;; the fields:
+;; tst - an S-exp of the test such as (equal exp 5).  It can also
+;;       be a name of a test that isn't meant to be compared to other
+;;       tests such as 'list-ddk-pat.
+;; comp - a function that takes a success-function, a fail-function and
+;;        a list of let bindings
+;; shape - a boolean that is true if the test tests the shape or type
+;;         of the data rather than the value of the data
+;; times-used - the number of clauses that use this test.  In reality
+;;              the number of clauses in which this test will eliminate
+;;              tests
+;; used-set - a list of numbers which designate the test-lists that
+;;            in which this test will eliminate tests
+;; bind-exp-stx - the syntax of the actual expression that is being tested
+;;                by this test ex. (syntax (car (cdr x)))
+;; bind-exp - the s-exp that is being tested by this test,
+;;            easily obtained by taking the syntax-object->datum
+;;            of bind-exp-stx
+;; bind-count - is the number of times in the bind-exp is found in the
+;;              test list in which this test is a member
+(define-struct test (tst
+                     comp
+                     shape
+                     times-used
+                     used-set
+                     bind-exp-stx
+                     bind-exp
+                     bind-count
+                     times-used-neg
+                     used-set-neg
+                     closest-shape-tst
+                     equal-set)
+  (make-inspector))
+
+;;!(function make-shape-test
+;;          (form (make-shape-test test exp comp) -> test-struct)
+;;          (contract (s-exp syntax (((list list -> syntax) 
+;;                                   (list list -> syntax) list) 
+;;                    -> 
+;;                    (list list -> syntax)))
+;;                    -> test))
+;; This function is essentially a constructor for a test struct.
+;; This constructor makes a "shape" test - test that tests for type
+;; rather than value.
+;; Arguments:
+;; test - s-exp of the test
+;; exp - the syntax of the expression being tested
+;; comp - the compilation function which will finish the compilation
+;;        after tests have been reordered
+(define (make-shape-test test exp comp)
+  (make-test test comp #t 0 '() exp (syntax-object->datum exp) 1 0 '() #f '()))
+
+;;!(function make-reg-test
+;;          (form (make-shape-test test exp comp) -> test-struct)
+;;          (contract (s-exp syntax (((list list -> syntax) 
+;;                                   (list list -> syntax) list) 
+;;                                   -> (list list -> syntax)))
+;;                    -> test))
+;; This function is essentially a constructor for a test struct.
+;; This constructor makes a "regular" test
+;; Arguments:
+;; test - s-exp of the test
+;; exp - the syntax of the expression being tested
+;; comp - the compilation function which will finish the compilation
+;;        after tests have been reordered
+(define (make-reg-test test exp comp)
+  (make-test test comp #f 0 '() exp (syntax-object->datum exp) 1 0 '() #f '()))
+
+;;!(function make-act-test
+;;          (form (make-shape-test test exp comp) -> test-struct)
+;;          (contract (s-exp syntax (((list list -> syntax) 
+;;                     (list list -> syntax) list) -> (list list -> syntax)))
+;;                    -> test))
+;; This function is essentially a constructor for a test struct.
+;; This constructor makes an "action" test - an action test is not
+;; neccessarily a test so to speak but rather an action that needs to be
+;; taken in order to verify that a certain expression matches a pattern.
+;; A good example of this is the binding of a pattern variable.
+;; Arguments:
+;; act-name -
+;; exp - the syntax of the expression being tested
+;; comp - the compilation function which will finish the compilation
+;;        after tests have been reordered
+(define (make-act act-name exp comp)
+  (make-test act-name comp #f -1 '() exp (syntax-object->datum exp) 1 -1 '() #f '()))
+
+;;!(function action-test?
+;;          (form (action-test? test) -> bool)
+;;          (contract  test -> bool))
+;; a predicate that returns true if a test is an action test
+(define (action-test? test)
+  (= -1 (test-times-used test)))
+
+;;!(function shape-test?
+;;          (form (shape-test? test) -> bool)
+;;          (contract  test -> bool))
+;; a predicate that returns true if a test is an shape test
+(define (shape-test? test)
+  (test-shape test))
+
+(define (negate-test? test)
+  (test-closest-shape-tst test))
diff --git a/collects/mzlib/private/plt-match/update-binding-counts.scm b/collects/mzlib/private/plt-match/update-binding-counts.scm
new file mode 100644
index 0000000000..d0e96c75c0
--- /dev/null
+++ b/collects/mzlib/private/plt-match/update-binding-counts.scm
@@ -0,0 +1,107 @@
+;; This library is used by match.ss
+
+(define-values (update-binding-counts update-binding-count)
+  (letrec 
+      (
+       ;;!(function update-binding-count
+       ;;          (form (update-binding-count render-list) -> list)
+       ;;          (contract list -> list))
+       ;; This function is normally executed for its side effect of
+       ;; setting the count for the number of times an expression used in
+       ;; a test if found in the rest of the list of tests.  This does
+       ;; not only count occurrances of the exp in other tests but
+       ;; whether the expression is also a sub expression in the other tests.
+       ;; Arg:
+       ;; render-list - a list of test structs
+       (update-binding-count 
+        (lambda (render-list)
+          (define (inc-bind-count test)
+            (set-test-bind-count! test
+                                  (add1 (test-bind-count test))))
+          (if (null? render-list)
+              '()
+              (let ((cur-test (car render-list)))
+                (update-binding-count
+                 (let loop ((l (cdr render-list)))
+                   (cond ((null? l) '())
+                         ((>= (test-bind-count cur-test) 2) l)
+                         ((and (valid-for-let-binding (test-bind-exp cur-test))
+                               (equal? (test-bind-exp cur-test)
+                                       (test-bind-exp (car l))))
+                          (begin
+                            (inc-bind-count cur-test)
+                            (loop (cdr l))))
+                         ((sub-exp-contains (test-bind-exp cur-test)
+                                            (test-bind-exp (car l)))
+                          (begin
+                            (inc-bind-count cur-test)
+                            (cons (car l) (loop (cdr l)))))
+                         (else (cons (car l) (loop (cdr l)))))))))))
+
+       ;;!(function valid-for-let-binding
+       ;;          (form (valid-for-let-binding exp) -> bool)
+       ;;          (contract s-exp -> bool)
+       ;;          (example (valid-for-let-binding 'x) -> #f))
+       ;; This function is a predicate that determins if an expression
+       ;; should be considered for let binding.
+       (valid-for-let-binding 
+        (lambda (exp)
+          ;; it must be a pair
+          ;; the index must be an integer
+          '(match exp
+                  (('vector-ref _ n) (number? n))
+                  ((? pair?) #t)
+                  (_ #f))
+          ;; the following is expanded fromt the above match expression
+          (let ((x exp))
+            (if (pair? x)
+                (if (and (equal? (car x) 'vector-ref)
+                         (pair? (cdr x))
+                         (pair? (cdr (cdr x)))
+                         (null? (cdr (cdr (cdr x)))))
+                    ((lambda (n) (number? n)) (car (cdr (cdr x))))
+                    ((lambda () #t)))
+                ((lambda () #f))))))
+
+       ;;!(function sub-exp-contains
+       ;;          (form (sub-exp-contains exp1 exp2) -> bool)
+       ;;          (contract (s-exp s-exp) -> bool)
+       ;;          (example (sub-exp-contains '(cdr x) '(car (cdr x))) -> #t))
+       ;; This function returns true if exp2 contains a sub-expression
+       ;; that is equal? to exp1.  For this function to work the subexp
+       ;; must always be in the second position in a exp.  This is a
+       ;; convention that is followed throughout the match program.
+       (sub-exp-contains 
+        (lambda (exp1 exp2)
+          '(match exp2
+                  (() #f)
+                  ((_ sub-exp _ ...)
+                   (if (and (valid-for-let-binding sub-exp)
+                            (equal? sub-exp exp1))
+                       #t
+                       (sub-exp-contains exp1 sub-exp)))
+                  (_ #f))
+          ;; The following was expanded from the above match expression
+          (let ((x exp2))
+            (if (null? x)
+                ((lambda () #f))
+                (if (and (pair? x) (pair? (cdr x)) (list? (cdr (cdr x))))
+                    ((lambda (sub-exp)
+                       (if (and (pair? sub-exp)
+                                (equal? sub-exp exp1))
+                           #t
+                           (sub-exp-contains exp1 sub-exp)))
+                     (car (cdr x)))
+                    ((lambda () #f)))))))
+
+       ;;!(function update-binding-counts
+       ;;          (form (update-binding-counts render-lists) -> list)
+       ;;          (contract list -> list))
+       ;; This function calls update-binding-count for each render list
+       ;; in the list of render lists.  This is used mainly for its side
+       ;; affects.  The result is of no consequence.
+       (update-binding-counts 
+        (lambda (render-lists)
+          (map update-binding-count (map car render-lists))))
+       )
+    (values update-binding-counts update-binding-count)))
diff --git a/collects/mzlib/private/plt-match/update-counts.scm b/collects/mzlib/private/plt-match/update-counts.scm
new file mode 100644
index 0000000000..c746938b25
--- /dev/null
+++ b/collects/mzlib/private/plt-match/update-counts.scm
@@ -0,0 +1,181 @@
+;; This library is used by match.ss
+;; This requires the test data structure.
+
+(define-values (update-counts)
+  (letrec 
+      (
+       ;;!(function test-filter
+       ;;          (form (test-filter test-list) -> test-list)
+       ;;          (contract list -> list))
+       ;; This function filters out tests that do not need to be to have
+       ;; their counts updated for reordering purposes.  These are the
+       ;; more complex patterns such as or-patterns or ddk patterns.
+       (test-filter
+        (lambda (tlist)
+          (if (null? tlist)
+              '()
+              (if (= -1 (test-times-used (car tlist)))
+                  (test-filter (cdr tlist))
+                  (cons (car tlist)
+                        (test-filter (cdr tlist)))))))
+
+
+       ;; !(function inverse-in
+       ;;            (form (inverse-in test test-list) -> bool)
+       ;;            (contract (s-exp list) -> bool))
+       ;; This function checks to see if any of the members of the test-list
+       ;; would be eliminated by the function if the test was in the test so far 
+       ;; list.  This is the opposite of what the in function does.
+       (inverse-in
+        (lambda (test test-list)
+          (or (pos-inverse-in test test-list)
+              (neg-inverse-in test test-list))))
+
+       (pos-inverse-in
+        (lambda (test test-list)
+          (let ((test-with-implied (cons test (implied test))))
+            (ormap (lambda (t) (in t test-with-implied))
+                   test-list)
+            )))
+
+       (neg-inverse-in
+        (lambda (test test-list)
+          (let ((test-with-implied (cons test (implied test))))
+            (ormap (lambda (t) (in `(not ,t) test-with-implied))
+                   test-list)
+            )))
+
+       (logical-member
+        (lambda (item lst)
+          (ormap (lambda (cur)
+                   (logical-equal? item cur))
+                 lst)))
+         
+       (logical-equal?  
+        (lambda x
+          (if (pair? x)
+              (let ((exp8163 (cdr x)))
+                (if (and (pair? exp8163) (null? (cdr exp8163)))
+                    (if (equal? (car exp8163) (car x))
+                        ((lambda (a) #t) (car x))
+                        (let ((exp8164 (car x)))
+                          (if (and (pair? exp8164) (equal? (car exp8164) 'list?))
+                              (let ((exp8165 (cdr exp8164)))
+                                (if (and (pair? exp8165) (null? (cdr exp8165)))
+                                    (let ((exp8166 (car exp8163)))
+                                      (if (and (pair? exp8166) (equal? (car exp8166) 'null?))
+                                          (let ((exp8167 (cdr exp8166)))
+                                            (if (and (pair? exp8167)
+                                                     (null? (cdr exp8167))
+                                                     (equal? (car exp8167) (car exp8165)))
+                                                ((lambda (x) #t) (car exp8165))
+                                                ((lambda (else) #f) x)))
+                                          ((lambda (else) #f) x)))
+                                    ((lambda (else) #f) x)))
+                              ((lambda (else) #f) x))))
+                    ((lambda (else) #f) x)))
+              ((lambda (else) #f) x))))
+
+       (truncate 
+        (lambda (pos used-set-neg)
+          (cond ((null? used-set-neg)
+                '())
+                ((>= pos (car used-set-neg))
+                 (list pos))
+                (else
+                 (cons (car used-set-neg)
+                       (truncate pos (cdr used-set-neg)))))))
+
+       (truncate-neg 
+        (lambda (pos used-set-neg)
+          (cond ((null? used-set-neg)
+                '())
+                ((>= pos (car used-set-neg))
+                 '())
+                (else
+                 (cons (car used-set-neg)
+                       (truncate-neg pos (cdr used-set-neg)))))))
+          
+
+
+       ;;!(function update-count
+       ;;          (form (update-count test tests-rest pos) -> void)
+       ;;          (contract (test-struct list integer) -> void))
+       ;; This function updates the test-times-used and test-used-set
+       ;; fields of the test structs.  These fields are essential to
+       ;; determining the order of the tests.
+       (update-count 
+        (lambda (test tests-rest pos mem-table)
+          (let loop ((l tests-rest)
+                     (p (add1 pos)))
+            (if (null? l)
+                (begin
+                  ;; memoize
+                  (hash-table-get mem-table (test-tst test) 
+                                  (lambda () 
+                                    (hash-table-put! 
+                                     mem-table 
+                                     (test-tst test) (list (test-used-set test)
+                                                           (test-used-set-neg test)))))
+                  )
+                (let ((entry-pair 
+                       (hash-table-get mem-table (test-tst test)
+                                      (lambda ()
+                                         (when (
+                                                ;member
+                                                logical-member
+                                                ;inverse-in
+                                                (test-tst test) (car l))
+                                           (set-test-times-used! test (add1 (test-times-used test)))
+                                           (set-test-used-set! test (cons p (test-used-set test)))
+                                           (set-test-equal-set! test (cons p (test-equal-set test)))
+                                           )
+                                         (when (neg-inverse-in (test-tst test) (car l))
+                                           (set-test-used-set-neg! test (cons p (test-used-set-neg test))))
+                                         (loop (cdr l) (add1 p))
+                                       ))))
+                  (when (and (list? entry-pair) (not (null? entry-pair)))
+                    (let ((trun-used (truncate pos (car entry-pair))))
+                      (set-test-used-set! test trun-used)
+                      (set-test-equal-set! test trun-used)
+                      (set-test-times-used! test (length trun-used))
+                      (set-test-used-set-neg! test (truncate-neg pos (cadr entry-pair)))))
+                )))))
+
+       ;;!(function update-counts
+       ;;          (form (update-counts render-list) -> void)
+       ;;          (contract list -> void))
+       ;; This function essentially calls update-count on every test in
+       ;; all of the test lists.
+       (update-counts 
+        (lambda (render-list)
+          (let* ((mem-table (make-hash-table 'equal))
+                 (test-master-list (map test-filter 
+                                        (map car render-list)))
+                 (test-so-far-lists ;; horrible name
+                  (map
+                    (lambda (tl)
+                     (let ((f (map test-tst (test-filter tl))))
+                       f))
+                   test-master-list)))
+            (let loop ((tml test-master-list)
+                       (tsf test-so-far-lists)
+                       (pos 1))
+              (if (null? tml)
+                  '()
+                  (begin
+                    (map (lambda (t)
+                           (set-test-times-used! t 1)
+                           (set-test-used-set! 
+                            t 
+                            (cons pos (test-used-set t)))
+                           (set-test-equal-set! 
+                            t 
+                            (cons pos (test-equal-set t)))
+                           (update-count t (cdr tsf) pos mem-table))
+                         (car tml))
+                    (loop (cdr tml) (cdr tsf) (add1 pos))))))))
+       )
+    (values update-counts)))
+
+
diff --git a/collects/mzlib/private/port.ss b/collects/mzlib/private/port.ss
new file mode 100644
index 0000000000..027b58d250
--- /dev/null
+++ b/collects/mzlib/private/port.ss
@@ -0,0 +1,87 @@
+
+;; A few simple port functions are needed in pretty.ss, which is
+;;  used by contract.ss, which is used by port.ss --- so we
+;;  break the cycle with this module.
+
+(module port mzscheme
+  (require "../etc.ss")
+  (provide open-output-nowhere
+	   relocate-output-port
+	   transplant-output-port
+	   transplant-to-relocate)
+
+  (define open-output-nowhere
+    (opt-lambda ([name 'nowhere] [specials-ok? #t])
+      (make-output-port 
+       name
+       always-evt
+       (lambda (s start end non-block? breakable?) (- end start))
+       void
+       (and specials-ok?
+	    (lambda (special non-block? breakable?) #t))
+       (lambda (s start end) (wrap-evt
+			      always-evt
+			      (lambda (x)
+				(- end start))))
+       (and specials-ok?
+	    (lambda (special) 
+	      (wrap-evt always-evt (lambda (x) #t)))))))
+
+  (define (transplant-to-relocate transplant p line col pos close?)
+    (let-values ([(init-l init-c init-p) (port-next-location p)])
+      (transplant
+       p
+       (lambda ()
+	 (let-values ([(l c p) (port-next-location p)])
+	   (values (and l init-l (+ l (- init-l) line))
+		   (and c init-c (if (equal? l init-l)
+				     (+ c (- init-c) col)
+				     c))
+		   (and p init-p (+ p (- init-p) pos)))))
+       pos
+       close?)))
+
+  (define relocate-output-port
+    (opt-lambda (p line col pos [close? #t])
+      (transplant-to-relocate
+       transplant-output-port
+       p line col pos close?)))
+  
+  (define transplant-output-port
+    (opt-lambda (p location-proc pos [close? #t] [count-lines!-proc void])
+      (make-output-port
+       (object-name p)
+       p
+       (lambda (s start end nonblock? breakable?)
+	 (let ([v ((if nonblock? 
+		       write-bytes-avail*
+		       (if breakable?
+			   write-bytes-avail/enable-break
+			   write-bytes-avail))
+		   s p start end)])
+	   (if (and (zero? v) (not (= start end)))
+	       (wrap-evt p (lambda (x) 0))
+	       v)))
+       (lambda ()
+	 (when close?
+	   (close-output-port p)))
+       (and (port-writes-special? p)
+	    (lambda (special nonblock? breakable?)
+	      ((if nonblock? 
+		   write-special-avail*
+		   (if breakable?
+		       (lambda (spec p)
+			 (parameterize-break #t
+			   (write-special spec p)))
+		       write-special))
+	       special p)))
+       (and (port-writes-atomic? p)
+	    (lambda (s start end)
+	      (write-bytes-avail-evt s p start end)))
+       (and (port-writes-atomic? p)
+	    (port-writes-special? p)
+	    (lambda (spec)
+	      (write-special-evt spec p)))
+       location-proc
+       count-lines!-proc
+       pos))))
diff --git a/collects/mzlib/private/render-helpers.ss b/collects/mzlib/private/render-helpers.ss
new file mode 100644
index 0000000000..c75488c385
--- /dev/null
+++ b/collects/mzlib/private/render-helpers.ss
@@ -0,0 +1,220 @@
+(module render-helpers mzscheme
+  
+  (provide (all-defined))  
+  
+  (require "match-helper.ss"
+           "match-error.ss"
+  
+	   "emit-assm.scm"
+	   "getter-setter.scm"
+	   "parse-quasi.scm"
+           (lib "list.ss"))
+
+  (require-for-template 
+   mzscheme
+   "match-helper.ss"
+   "match-error.ss"
+   
+   "emit-assm.scm"
+   "getter-setter.scm"
+   "parse-quasi.scm"
+   (lib "list.ss"))
+  
+  (provide (all-from "emit-assm.scm")
+           (all-from "getter-setter.scm")
+           (all-from "parse-quasi.scm"))
+  
+  ;;!(function match:test-no-order 
+  ;;          (form (match:test-no-order tests l last-test ddk-num)
+  ;;                -> 
+  ;;                bool)
+  ;;          (contract (list list test integer) -> bool))
+  ;; This is a recursive depth first search for a sequence of
+  ;; items in list l which will satisfy all of the tests in list
+  ;; tests.  This is used for list-no-order and hash-table patterns.
+  ;; This function also handles ddk patterns by passing it the last
+  ;; test before the ddk and the value of k.
+  (define (match:test-no-order tests l last-test ddk-num)
+    (define (handle-last-test test l)
+      (and (>= (length l) ddk-num) 
+           (andmap test l)))
+    (define (dep-first-test head rest tests)
+      (cond ((null? tests) 
+             (if last-test 
+                 (handle-last-test last-test (cons head rest)) 
+                 #f))
+            ((null? rest)
+             (if last-test
+                 (and (= 0 ddk-num)
+                      (= 1 (length tests))
+                      ((car tests) head))
+                 (and (= 1 (length tests))
+                      ((car tests) head))))
+            (else (and (pair? tests)
+                       ((car tests) head)
+                       (match:test-no-order (cdr tests) 
+                                            rest 
+                                            last-test 
+                                            ddk-num)))))
+    ; I think this is equivalent to 
+    #;(ormap (lambda (elem) 
+               (dep-first-test elem 
+                               (remove elem l)
+                               tests))
+             l)
+    (let loop ((lst l))
+      (if (null? lst) 
+          #f
+          (or (dep-first-test (car lst) (remove (car lst) l) tests)
+              (loop (cdr lst))))))
+  
+  (define (append-if-necc sym stx)
+    (syntax-case stx ()
+      (() (syntax (list)))
+      ((a ...)
+       (quasisyntax/loc stx (#,sym a ...)))
+      (p (syntax p))))
+
+  (define (get-bind-val b-var bv-list)
+    (let ((res (assq
+                b-var
+                bv-list)))
+      (if res (cdr res)
+          (let ((res 
+                 (assq
+                    (syntax-object->datum b-var)
+                    (map (lambda (x)
+                           (cons 
+                            (syntax-object->datum (car x)) (cdr x))) 
+                         bv-list))))
+            (if res (cdr res) (error 'var-not-found))))))
+  
+  
+      ;; BEGIN PATTERN-PREDICATE.SCM
+    ;;!(function proper-hash-table-pattern?
+    ;;          (form (proper-hash-table-pattern? pat-list) -> bool)
+    ;;          (contract list-of-syntax -> bool))
+    ;; This function returns true if there is no ddk in the list of
+    ;; patterns or there is only a ddk at the end of the list.
+    (define (proper-hash-table-pattern? pat-list)
+      (cond ((null? pat-list) #t)
+            (else
+             (let ((ddk-list (ddk-in-list? pat-list)))
+               (or (not ddk-list)
+                   (and ddk-list
+                        (ddk-only-at-end-of-list? pat-list)))))))
+    
+    ;;!(function ddk-in-list?
+    ;;          (form (ddk l) -> bool)
+    ;;          (contract list-of-syntax -> bool))
+    ;; This is a predicate that returns true if there is a ddk in the
+    ;; list.
+    (define (ddk-in-list? l)
+      (not (andmap (lambda (x) (not (stx-dot-dot-k? x))) l)))
+    
+    ;;!(function ddk-only-at-end-of-list?
+    ;;          (form (ddk-only-at-end-of-list? l) -> bool)
+    ;;          (contract list-of-syntax -> bool))
+    ;; This is a predicate that returns true if there is a ddk at the
+    ;; end of the list and the list has at least one item before the ddk.
+    (define ddk-only-at-end-of-list?
+      (lambda (l)
+        '(match
+             l
+           (((not (? stx-dot-dot-k?)) ..1 a) (stx-dot-dot-k? a)))
+        (let ((x l))
+          (if (list? x)
+              (let ddnnl26305 ((exp26306 x) (count26307 0))
+                (if (and (not (null? exp26306))
+                         ((lambda (exp-sym) (if (stx-dot-dot-k? exp-sym) #f #t))
+                          (car exp26306)))
+                    (ddnnl26305 (cdr exp26306) (add1 count26307))
+                    (if (>= count26307 1)
+                        (if (and (pair? exp26306) (null? (cdr exp26306)))
+                            ((lambda (a) (stx-dot-dot-k? a)) (car exp26306))
+                            #f)
+                        #f)))
+              #f))))
+    
+    ;;!(function ddk-only-at-end-of-vector?
+    ;;          (form (ddk-only-at-end-of-vector? vec) -> bool)
+    ;;          (contract vector -> bool))
+    ;; This is a predicate that returns true if there is a ddk at the
+    ;; end of the vector and the list has at least one item before the ddk.
+    (define ddk-only-at-end-of-vector?
+      (lambda (vec)
+        '(match
+             vec
+           (#((not (? stx-dot-dot-k?)) ..1 a) #t))
+        ;; the following is expanded from the above match expression
+        (let ((x vec))
+          (let ((match-failure
+                 (lambda () #f)))
+            (if (vector? x)
+                (let ((lv32956 (vector-length x)))
+                  (if (>= lv32956 2)
+                      (let ((curr-ind32957 0))
+                        (let vloop32958 ((count32959 curr-ind32957))
+                          (let ((fail32961
+                                 (lambda (count-offset32962 index32963)
+                                   (if (>= count-offset32962 1)
+                                       (if (= index32963 lv32956)
+                                           (match-failure)
+                                           (let ((cindnm32965 (add1 index32963)))
+                                             (if (>= cindnm32965 lv32956)
+                                                 ((lambda (a) #t) 
+                                                  (vector-ref x index32963))
+                                                 (match-failure))))
+                                       (match-failure)))))
+                            (if (= lv32956 count32959)
+                                (fail32961 (- count32959 curr-ind32957) count32959)
+                                (if (stx-dot-dot-k? (vector-ref x count32959))
+                                    (fail32961 (- count32959 curr-ind32957) 
+                                               count32959)
+                                    (let ((arglist (list)))
+                                      (apply vloop32958 (add1 count32959) 
+                                             arglist)))))))
+                      (match-failure)))
+                (match-failure))))))
+    
+    ;;!(function ddk-in-vec?
+    ;;          (form (ddk-in-vec? vec stx) -> (integer or #f))
+    ;;          (contract (vector syntax) -> (integer or bool)))
+    ;; this function returns the total of the k's in a vector of syntax
+    ;; it also insure that the ..k's are not consecutive
+    (define ddk-in-vec?
+      (lambda (vec stx)
+        ;; make sure first element is not ddk
+        (if (stx-dot-dot-k? (vector-ref vec 0))
+            (match:syntax-err
+             stx
+             "vector pattern cannot start with ..k syntax")
+            (let ((vlength (vector-length vec))
+                  (flag #f))
+              (letrec ((check-vec
+                        (lambda (last-stx index)
+                          (if (= index vlength)
+                              0
+                              (let ((k-prev (stx-dot-dot-k? last-stx))
+                                    (k-curr (stx-dot-dot-k? (vector-ref vec 
+                                                                        index))))
+                                (cond
+                                  ((and k-prev k-curr)
+                                   (match:syntax-err
+                                    stx
+                                    "consecutive ..k markers are not allowed"))
+                                  (k-curr
+                                   (begin
+                                     (set! flag #t)
+                                     (+ (- k-curr 2) (check-vec (vector-ref vec 
+                                                                            index) 
+                                                                (add1 index)))))
+                                  (else
+                                   (check-vec (vector-ref vec index) 
+                                              (add1 index)))))))))
+                (let ((res (check-vec (vector-ref vec 0) 1)))
+                  (if flag res #f)))))))
+    ;; END PATTERN-PREDICATES.SCM
+
+  
+  )
\ No newline at end of file
diff --git a/collects/mzlib/private/render-test-list.scm b/collects/mzlib/private/render-test-list.scm
new file mode 100644
index 0000000000..2e4c0fa9ee
--- /dev/null
+++ b/collects/mzlib/private/render-test-list.scm
@@ -0,0 +1,1448 @@
+;; This library is used by match.ss
+(module render-test-list mzscheme
+  (provide render-test-list)
+  
+  (require (lib "etc.ss"))
+  (require (lib "stx.ss" "syntax"))    
+  (require (rename (lib "1.ss" "srfi") map-append append-map ))
+  
+  (require "match-error.ss"
+           "match-helper.ss"
+           "test-structure.scm"
+           "coupling-and-binding.scm"
+           "update-counts.scm"
+           "update-binding-counts.scm"
+           "reorder-tests.scm"
+           "match-expander-struct.ss"
+
+           ;; the following are only used by render-test-list
+           "render-helpers.ss")
+
+  (require-for-syntax "match-helper.ss"
+                      "match-expander-struct.ss")
+  
+  (require-for-template
+   mzscheme
+   "match-expander-struct.ss"
+   "match-error.ss"
+   "match-helper.ss"
+   "test-structure.scm"
+   "coupling-and-binding.scm"
+   "update-counts.scm"
+   "update-binding-counts.scm"
+   "reorder-tests.scm"
+   
+   ;; the following are only used by render-test-list
+   "render-helpers.ss")
+  
+   ;; BEGIN SPECIAL-GENERATORS.SCM
+
+      ;;!(function or-gen
+    ;;         (form (or-gen exp orpatlist stx sf bv ks kf let-bound)
+    ;;               ->
+    ;;               syntax)
+    ;;         (contract (syntax list syntax list list (list list -> syntax) 
+    ;;                    (list list -> syntax) list)
+    ;;                   ->
+    ;;                   syntax))
+    ;; The function or-gen is very similar to the function gen except
+    ;; that it is called when an or pattern is compiled.  An or
+    ;; pattern is essentially the same as a match pattern with several
+    ;; clauses.  The key differences are that it exists within a
+    ;; larger pattern and the state of compilation has information
+    ;; that will help optimaize its compilation.  And the success of
+    ;; any pattern results in the same outcome.
+    (define or-gen
+      (lambda (exp orpatlist stx sf bv ks kf let-bound)
+        (let ((rendered-list
+               (map
+                (lambda (pat) 
+                  (cons (render-test-list pat exp stx)
+                        (lambda (fail let-bound)
+                          (lambda (sf bv)
+                            (let ((bv (map
+                                       (lambda (bind)
+                                         (cons (car bind)
+                                               (subst-bindings (cdr bind) 
+                                                               let-bound)))
+                                       bv)))
+                              (ks sf bv))))))
+                orpatlist)))
+          (update-counts rendered-list)
+          (update-binding-counts rendered-list)
+          (let* ((rendered-list 
+                  (reorder-all-lists rendered-list)
+                  )
+                 (output ((meta-couple rendered-list kf let-bound bv) sf bv)))
+            output))))
+    
+    ;;!(function next-outer
+    ;;          (form (next-outer p ae sf bv let-bound kf ks syntax bool)
+    ;;                ->
+    ;;                syntax)
+    ;;          (contract (syntax syntax list list list (list list -> syntax)
+    ;;                     (list list -> syntax) syntax bool)
+    ;;                    ->
+    ;;                    syntax))
+    ;; The function next-outer is basically a throw-back to the next
+    ;; function of the original match compiler.  It compiles a pattern
+    ;; or sub-pattern of a clause and does not yield a list of
+    ;; partially compiled test structs.  This function is called
+    ;; inside of test constructs that cannot be eliminated because of
+    ;; a related presence in the test-so-far list.  So, instead of
+    ;; partially compiling patterns this function fully compiles patterns.
+    (define next-outer
+      (opt-lambda (p
+                   ae ;; this is the actual expression
+                   sf
+                   bv
+                   let-bound
+                   kf
+                   ks
+                   [stx (syntax '())]
+                   [opt #f])
+        (next-outer-helper p ae sf bv let-bound 
+                           (lambda (x) kf) (lambda (a b) ks) stx opt)))
+    
+    ;;!(function next-outer-helper
+    ;;          (form (next-outer p ae sf bv let-bound kf-func ks-func syntax bool)
+    ;;                ->
+    ;;                syntax)
+    ;;          (contract (syntax syntax list list list (list list -> syntax)
+    ;;                     (list list -> syntax) syntax bool)
+    ;;                    ->
+    ;;                    syntax))
+    ;; The function next-outer-helper contains the meat of next-outer
+    ;; and allows the programmer to pass higher order functions
+    ;; ks-func and kf-func that will be given compile time imformation
+    ;; about let-bindings etc. which in turn will allow the programmer
+    ;; to take advantage of this info.
+    (define next-outer-helper
+      (opt-lambda (p
+                   ae ;; this is the actual expression
+                   sf
+                   bv
+                   let-bound
+                   kf-func
+                   ks-func
+                   [stx (syntax '())]
+                   [opt #f])
+        ;; right now this does not bind new variables
+        (let ((rendered-list (render-test-list p ae stx)))
+          ;; no need to reorder lists although I suspect that it may be
+          ;; better to put shape tests first
+          (update-binding-count rendered-list)
+          ((couple-tests rendered-list ks-func kf-func let-bound) sf bv))))
+
+      ;;!(function create-test-func
+    ;;          (form (create-test-func p sf let-bound bind-map last-test)
+    ;;                ->
+    ;;                syntax)
+    ;;          (contract (syntax list list a-list bool) -> syntax))
+    ;; This function creates a runtime function that is used as an
+    ;; individual test in a list of tests for the list-no-order
+    ;; pattern.
+    ;; <pre>
+    ;; bindmap - a-list of bindings mapped to their expressions
+    ;; last-test - a boolean value that indicates whether this function
+    ;; is collecting one value or a list of values.</pre>
+    (define (create-test-func p sf let-bound bind-map last-test)
+      (quasisyntax/loc
+          p
+        (lambda (exp)
+          #,(next-outer-helper 
+             p #'exp sf '() let-bound
+             (lambda (let-bound)
+               (lambda (sf bv)
+                 #'#f))
+             (lambda (fail let-bound)
+               (lambda (sf bv)
+                 #`(begin
+                     #,@(map (lambda (bind)
+                               (let ((binding-name (get-bind-val (car bind) bind-map))
+                                     (exp-to-bind 
+                                      (subst-bindings (cdr bind) let-bound)))
+                                 (if last-test
+                                     #`(set! #,binding-name
+                                             (cons #,exp-to-bind #,binding-name))
+                                     #`(set! #,binding-name
+                                             #,exp-to-bind))))
+                             bv)
+                     #t)))))))
+  
+  ;;!(function getbindings
+    ;;          (form (getbindings pat-syntax) -> list)
+    ;;          (contract syntax -> list))
+    ;; This function given a pattern returns a list of pattern
+    ;; variable names which are found in the pattern.
+    (define (getbindings pat-syntax)
+      (let/cc out
+        (next-outer
+         pat-syntax
+         (quote-syntax dummy)
+         '()
+         '()
+         '()
+         (lambda (sf bv) #'(dummy-symbol))
+         (lambda (sf bv) (out (map car bv))))))
+ 
+     ;; END SPECIAL-GENERATORS.SCM
+  
+  ;; BEGIN DDK
+
+     
+  ;; END DDK
+
+
+    
+    
+    
+    
+    ;; BEGIN DDK-HANDLERS.SCM
+    
+    
+ 
+    
+    
+    ;;!(function handle-end-ddk-list
+    ;;          (form (handle-end-ddk-list ae kf ks pat
+    ;;                                     dot-dot-k stx
+    ;;                                     let-bound)
+    ;;                ->
+    ;;                ((list list) -> syntax))
+    ;;          (contract (syntax
+    ;;                     ((list list) -> syntax)
+    ;;                     ((list list) -> syntax)
+    ;;                     syntax
+    ;;                     syntax
+    ;;                     syntax
+    ;;                     list)
+    ;;                    ->
+    ;;                    ((list list) -> syntax)))
+    ;; This returns a function which generates the code for
+    ;; a pattern that ends with a ddk. This function is only applied to the
+    ;; last pattern and the ddk.
+    ;; Args:
+    ;; ae - the expression being matched
+    ;; kf - a failure function
+    ;; ks - a success function
+    ;; pat - the pattern to be matched repeatedly
+    ;; dot-dot-k - the ddk pattern
+    ;; stx - the source stx for error purposes
+    ;; let-bound - a list of let bindings
+    (define handle-end-ddk-list
+      (lambda (ae kf ks pat dot-dot-k stx let-bound)
+        (lambda (sf bv)
+          (let* ((k (stx-dot-dot-k? dot-dot-k))
+                 (ksucc (lambda (sf bv) 
+                          (let ((bound (getbindings pat)))
+                            (if (syntax? bound)
+                                (kf sf bv)
+                                (syntax-case pat (_)
+                                  (_ (ks sf bv))
+                                  (the-pat
+                                   (null? bound)
+                                   (with-syntax ((exp-sym (syntax exp-sym)))
+                                     (let* ((ptst (next-outer
+                                                   pat
+                                                   (syntax exp-sym)
+                                                   sf
+                                                   bv
+                                                   let-bound
+                                                   (lambda (sf bv) (syntax #f))
+                                                   (lambda (sf bv) (syntax #t))))
+                                            (tst (syntax-case ptst ()
+                                                   ((pred eta)
+                                                    (and (identifier?
+                                                          (syntax pred))
+                                                         ;free-identifier=?
+                                                         (stx-equal?
+                                                          (syntax eta)
+                                                          (syntax exp-sym)))
+                                                    (syntax pred))
+                                                   (whatever
+                                                    (quasisyntax/loc 
+                                                        stx 
+                                                      (lambda (exp-sym)
+                                                        #,ptst))))))
+                                       (assm (quasisyntax/loc 
+                                                 stx 
+                                               (andmap #,tst 
+                                                       #,(subst-bindings ae let-bound)))
+                                             (kf sf bv)
+                                             (ks sf bv)))))
+                                  (id
+                                   (and (identifier? (syntax id))
+                                        (stx-equal? (syntax id)
+                                                    (car bound)))
+                                   (next-outer (syntax id) ae sf bv let-bound kf ks))
+                                  (the-pat
+                                   (let ((binding-list-names
+                                          (map (lambda (x)
+                                                 (datum->syntax-object
+                                                  (quote-syntax here)
+                                                  (symbol-append
+                                                   (gensym (syntax-object->datum x))
+                                                   '-bindings)))
+                                               bound))
+                                         (loop-name (quasisyntax/loc 
+                                                        (syntax the-pat) 
+                                                      #,(gensym 'loop)))
+                                         (exp-name (quasisyntax/loc 
+                                                       (syntax the-pat) 
+                                                     #,(gensym 'exp))))
+                                     (quasisyntax/loc
+                                         stx
+                                       (let #,loop-name
+                                         ((#,exp-name #,(subst-bindings ae let-bound))
+                                          #,@(map
+                                              (lambda (x)
+                                                (quasisyntax/loc
+                                                    stx
+                                                  (#,x '())))
+                                              binding-list-names))
+                                         (if (null? #,exp-name)
+                                             #,(ks sf
+                                                   (append
+                                                    (map cons
+                                                         bound
+                                                         (map
+                                                          (lambda (x)
+                                                            (quasisyntax/loc 
+                                                                stx 
+                                                              (reverse #,x)))
+                                                          binding-list-names))
+                                                    bv))
+                                             #,(next-outer (syntax the-pat)
+                                                           (quasisyntax/loc 
+                                                               (syntax the-pat) 
+                                                             (car #,exp-name))
+                                                           sf
+                                                           bv  ;; we always start
+                                                           ;; over with the old
+                                                           ;; bindings
+                                                           let-bound
+                                                           kf
+                                                           (lambda (sf bv)
+                                                             (quasisyntax/loc
+                                                                 stx
+                                                               (#,loop-name
+                                                                  (cdr #,exp-name)
+                                                                  #,@(map
+                                                                      (lambda
+                                                                          (b-var
+                                                                           bindings-var)
+                                                                        (quasisyntax/loc
+                                                                            stx
+                                                                          (cons
+                                                                           #,(get-bind-val
+                                                                              b-var
+                                                                              bv)
+                                                                           #,bindings-var)))
+                                                                      bound binding-list-names))))))))))))))))
+            (case k
+              ((0) (ksucc sf bv))
+              ((1) (emit (lambda (exp) (quasisyntax/loc stx (pair? #,exp)))
+                         ae
+                         let-bound
+                         sf bv kf ksucc))
+              (else (emit (lambda (exp) (quasisyntax/loc stx (>= (length #,exp) #,k)))
+                          ae
+                          let-bound
+                          sf bv kf ksucc)))))))
+    
+    ;;!(function handle-inner-ddk-list
+    ;;          (form (handle-inner-ddk-list ae kf ks pat
+    ;;                                     dot-dot-k pat-rest stx
+    ;;                                     let-bound)
+    ;;                ->
+    ;;                ((list list) -> syntax))
+    ;;          (contract (syntax
+    ;;                     ((list list) -> syntax)
+    ;;                     ((list list) -> syntax)
+    ;;                     syntax
+    ;;                     syntax
+    ;;                     syntax
+    ;;                     syntax
+    ;;                     list)
+    ;;                    ->
+    ;;                    ((list list) -> syntax)))
+    ;; This returns a function which generates the code for a list
+    ;; pattern that contains with a ddk that occurs before the end of
+    ;; the list. This code is extremely similar to the code in
+    ;; handle-end-ddk-list but there are enough differences to warrant
+    ;; having a separate method for readability.
+    ;; Args:
+    ;; ae - the expression being matched
+    ;; kf - a failure function
+    ;; ks - a success function
+    ;; pat - the pattern that preceeds the ddk
+    ;; dot-dot-k - the ddk pattern
+    ;; pat-rest - the rest of the list pattern that occurs after the ddk
+    ;; stx - the source stx for error purposes
+    ;; let-bound - a list of let bindings
+    (define handle-inner-ddk-list
+      (lambda (ae kf ks pat dot-dot-k pat-rest stx let-bound)
+        (lambda (sf bv)
+          (let* ((k (stx-dot-dot-k? dot-dot-k)))
+            (let ((bound (getbindings pat)))
+              (if (syntax? bound)
+                  (kf sf bv)
+                  (syntax-case pat (_)
+                    (_
+                     (stx-null? pat-rest)
+                     (ks sf bv))
+                    (the-pat
+                     (null? bound)
+                     (with-syntax ((exp-sym (syntax exp-sym)))
+                       (let* ((ptst (next-outer
+                                     pat
+                                     (syntax exp-sym)
+                                     sf
+                                     bv
+                                     let-bound
+                                     (lambda (sf bv) (syntax #f))
+                                     (lambda (sf bv) (syntax #t))))
+                              (tst (syntax-case ptst ()
+                                     ((pred eta)
+                                      (and (identifier?
+                                            (syntax pred))
+                                           ;free-identifier=?
+                                           (stx-equal?
+                                            (syntax eta)
+                                            (syntax exp-sym)))
+                                      (syntax pred))
+                                     (whatever
+                                      (quasisyntax/loc stx (lambda (exp-sym)
+                                                             #,ptst)))))
+                              (loop-name (gensym 'ddnnl))
+                              (exp-name (gensym 'exp))
+                              (count-name (gensym 'count)))
+                         (quasisyntax/loc
+                             (syntax the-pat)
+                           (let #,loop-name ((#,exp-name 
+                                                #,(subst-bindings ae let-bound))
+                                             (#,count-name 0))
+                             (if (and (not (null? #,exp-name))
+                                      ;; added for improper ddk
+                                      (pair? #,exp-name)
+                                      (#,tst (car #,exp-name)))
+                                 (#,loop-name (cdr #,exp-name) 
+                                    (add1 #,count-name))
+                                 ;; testing the count is not neccessary 
+                                 ;; if the count is zero
+                                 #,(let ((succ (next-outer
+                                                pat-rest
+                                                (quasisyntax/loc
+                                                    (syntax the-pat) #,exp-name)
+                                                sf
+                                                bv
+                                                let-bound
+                                                kf
+                                                ks)))
+                                     (if (zero? k)
+                                         succ
+                                         (quasisyntax/loc
+                                             (syntax the-pat)
+                                           (if (>= #,count-name #,k)
+                                               #,succ
+                                               #,(kf sf bv)))))))))))
+                    (the-pat
+                     (let* ((binding-list-names
+                             (map (lambda (x)
+                                    (datum->syntax-object
+                                     (quote-syntax here)
+                                     (symbol-append
+                                      (gensym (syntax-object->datum x))
+                                      '-bindings)))
+                                  bound))
+                            (loop-name (quasisyntax/loc 
+                                           (syntax the-pat) 
+                                         #,(gensym 'loop)))
+                            (exp-name (quasisyntax/loc 
+                                          (syntax the-pat) 
+                                        #,(gensym 'exp)))
+                            (fail-name (quasisyntax/loc 
+                                           (syntax the-pat) 
+                                         #,(gensym 'fail)))
+                            (count-name (quasisyntax/loc 
+                                            (syntax the-pat) 
+                                          #,(gensym 'count)))
+                            (new-bv (append
+                                     (map cons
+                                          bound
+                                          (map
+                                           (lambda (x)
+                                             (quasisyntax/loc stx (reverse #,x)))
+                                           binding-list-names)) bv)))
+                       (quasisyntax/loc
+                           (syntax the-pat)
+                         (let #,loop-name
+                           ((#,exp-name #,(subst-bindings ae let-bound))
+                            (#,count-name 0)
+                            #,@(map
+                                (lambda (x) (quasisyntax/loc 
+                                                (syntax the-pat) 
+                                              (#,x '())))
+                                binding-list-names))
+                           (let ((#,fail-name
+                                    (lambda ()
+                                      #,(let ((succ (next-outer
+                                                     pat-rest
+                                                     (quasisyntax/loc 
+                                                         (syntax the-pat) 
+                                                       #,exp-name)
+                                                     sf
+                                                     new-bv
+                                                     let-bound
+                                                     kf
+                                                     ks)))
+                                          (if (zero? k)
+                                              succ
+                                              (quasisyntax/loc 
+                                                  (syntax the-pat) 
+                                                (if (>= #,count-name #,k)
+                                                    #,succ
+                                                    #,(kf sf new-bv))))))))
+                             (if (or (null? #,exp-name)
+                                     (not (pair? #,exp-name)))
+                                 (#,fail-name)
+                                 #,(next-outer (syntax the-pat)
+                                               (quasisyntax/loc 
+                                                   (syntax the-pat) 
+                                                 (car #,exp-name))
+                                               sf
+                                               bv  ;; we always start
+                                               ;; over with the old
+                                               ;; bindings
+                                               let-bound
+                                               (lambda (sf bv)
+                                                 (quasisyntax/loc 
+                                                     (syntax the-pat) 
+                                                   (#,fail-name)))
+                                               (lambda (sf bv)
+                                                 (quasisyntax/loc
+                                                     stx
+                                                   (#,loop-name
+                                                      (cdr #,exp-name)
+                                                      (add1 #,count-name)
+                                                      #,@(map
+                                                          (lambda
+                                                              (b-var
+                                                               bindings-var)
+                                                            (quasisyntax/loc 
+                                                                stx 
+                                                              (cons
+                                                               #,(get-bind-val
+                                                                  b-var
+                                                                  bv)
+                                                               #,bindings-var)))
+                                                          bound
+                                                          binding-list-names))))))))))))))))))
+    ;;!(function handle-ddk-vector
+    ;;          (form (handle-ddk-vector ae kf ks pt let-bound)
+    ;;                ->
+    ;;                ((list list) -> syntax))
+    ;;          (contract (syntax
+    ;;                     ((list list) -> syntax)
+    ;;                     ((list list) -> syntax)
+    ;;                     syntax
+    ;;                     list)
+    ;;                    ->
+    ;;                    ((list list) -> syntax)))
+    ;; This returns a function which generates the code for a vector
+    ;; pattern that contains a ddk that occurs at the end of the
+    ;; vector.
+    ;; Args:
+    ;; ae - the expression being matched
+    ;; kf - a failure function
+    ;; ks - a success function
+    ;; pt - the whole vector pattern
+    ;; let-bound - a list of let bindings
+    (define handle-ddk-vector
+      (lambda (ae kf ks pt stx let-bound)
+        (let* ((vec-stx (syntax-e pt))
+               (vlen (- (vector-length vec-stx) 2)) ;; length minus
+               ;; the pat ...
+               (k (stx-dot-dot-k? (vector-ref vec-stx (add1 vlen))))
+               (minlen (+ vlen k))
+               ;; get the bindings for the second to last element:
+               ;; 'pat' in pat ...
+               (bound (getbindings (vector-ref vec-stx vlen)))
+               (exp-name (gensym 'exnm)))
+          (lambda (sf bv)
+            (if (syntax? bound)
+                (kf sf bv)
+                (quasisyntax/loc
+                    pt
+                  (let ((#,exp-name #,(subst-bindings ae let-bound)))
+                    #,(assm (quasisyntax/loc
+                                stx
+                              (>= (vector-length #,exp-name) #,minlen))
+                            (kf sf bv)
+                            ((let vloop ((n 0))
+                               (lambda (sf bv)
+                                 (cond
+                                   ((not (= n vlen))
+                                    (next-outer
+                                     (vector-ref vec-stx n)
+                                     (quasisyntax/loc
+                                         stx
+                                       (vector-ref #,exp-name #,n))
+                                     sf
+                                     bv
+                                     let-bound
+                                     kf
+                                     (vloop (+ 1 n))))
+                                   ((eq? (syntax-object->datum
+                                          (vector-ref vec-stx vlen))
+                                         '_)
+                                    (ks sf bv))
+                                   (else
+                                    (let* ((binding-list-names
+                                            (map (lambda (x)
+                                                   (datum->syntax-object
+                                                    (quote-syntax here)
+                                                    (symbol-append
+                                                     (gensym (syntax-object->datum x))
+                                                     '-bindings)))
+                                                 bound))
+                                           (vloop-name (gensym 'vloop))
+                                           (index-name (gensym 'index)))
+                                      (quasisyntax/loc
+                                          stx
+                                        (let #,vloop-name
+                                          ((#,index-name (- (vector-length #,exp-name) 1))
+                                           #,@(map (lambda (x) 
+                                                     (quasisyntax/loc stx (#,x '())))
+                                                   binding-list-names))
+                                          (if (> #,vlen #,index-name)
+                                              #,(ks sf
+                                                    (append (map cons bound
+                                                                 binding-list-names)
+                                                            bv))
+                                              #,(next-outer
+                                                 (vector-ref vec-stx n)
+                                                 (quasisyntax/loc
+                                                     stx
+                                                   (vector-ref #,exp-name #,index-name))
+                                                 sf
+                                                 bv ;; we alway start over
+                                                 ;; with the old bindings
+                                                 let-bound
+                                                 kf
+                                                 (lambda (sf bv)
+                                                   (quasisyntax/loc
+                                                       stx (#,vloop-name
+                                                              (- #,index-name 1)
+                                                              #,@(map
+                                                                  (lambda (b-var
+                                                                           bindings-var)
+                                                                    (quasisyntax/loc
+                                                                        stx
+                                                                      (cons
+                                                                       #,(get-bind-val
+                                                                          b-var
+                                                                          bv)
+                                                                       #,bindings-var)))
+                                                                  bound
+                                                                  binding-list-names)))))))))))))
+                             sf
+                             bv)))))))))
+    
+    ;;!(function handle-ddk-vector-inner
+    ;;          (form (handle-ddk-vector-inner ae kf ks pt let-bound)
+    ;;                ->
+    ;;                ((list list) -> syntax))
+    ;;          (contract (syntax
+    ;;                     ((list list) -> syntax)
+    ;;                     ((list list) -> syntax)
+    ;;                     syntax
+    ;;                     list)
+    ;;                    ->
+    ;;                    ((list list) -> syntax)))
+    ;; This returns a function which generates the code for a vector
+    ;; pattern that contains a ddk that occurs before another pattern
+    ;; in the list.
+    ;; Args:
+    ;; ae - the expression being matched
+    ;; kf - a failure function
+    ;; ks - a success function
+    ;; pt - the whole vector pattern
+    ;; let-bound - a list of let bindings
+    (define handle-ddk-vector-inner
+      (lambda (ae kf ks pt stx let-bound)
+        (let* ((vec-stx (syntax-e pt))
+               ;; vlen as an index points at the pattern before the ddk
+               (vlen (- (vector-length vec-stx) 2)) ;; length minus
+               ;; the pat ...
+               (vec-len (vector-length vec-stx))
+               (total-k (ddk-in-vec? vec-stx pt))
+               ;; (k (stx-dot-dot-k? (vector-ref vec-stx (add1 vlen))))
+               (minlen (+ vec-len total-k))
+               (length-of-vector-name (gensym 'lv))
+               (exp-name (gensym 'exnm)))
+          ;; get the bindings for the second to last element:
+          ;; 'pat' in pat ...
+          ;;(bound (getbindings (vector-ref vec-stx vlen))))
+          ;; we have to look at the first pattern and see if a ddk follows it
+          ;; if so handle that case else handle the pattern
+          (lambda (sf bv)
+            ;; minlen here could be the lentgh plus the k's - 1 for each ddk
+            (quasisyntax/loc
+                pt
+              (let ((#,exp-name #,(subst-bindings ae let-bound)))
+                (let ((#,length-of-vector-name (vector-length #,exp-name)))
+                  #,(assm (quasisyntax/loc pt (>= #,length-of-vector-name #,minlen))
+                          (kf sf bv)
+                          (let ((current-index-name (gensym 'curr-ind)))
+                            (quasisyntax/loc
+                                pt
+                              (let ((#,current-index-name 0))
+                                #,((let vloop ((n 0)
+                                               (count-offset-name-passover 
+                                                current-index-name))
+                                     (lambda (sf bv)
+                                       
+                                       (cond
+                                         ((= n vec-len) ;; at the end of the patterns
+                                          (quasisyntax/loc
+                                              pt
+                                            (if (>= #,count-offset-name-passover
+                                                    #,length-of-vector-name)
+                                                #,(ks sf bv)
+                                                #,(kf sf bv))))
+                                         ((stx-dot-dot-k? (vector-ref vec-stx n))  
+                                          ;;this could be it
+                                          (match:syntax-err
+                                           stx
+                                           "should not get here"))
+                                         ;; if the next one is not a ddk do a normal pattern match
+                                         ;; on element
+                                         ((or (= n (sub1 vec-len))
+                                              (not (stx-dot-dot-k? (vector-ref vec-stx
+                                                                               (add1 n)))))
+                                          (quasisyntax/loc
+                                              pt
+                                            (if (= #,count-offset-name-passover
+                                                   #,length-of-vector-name)
+                                                #,(kf sf bv)
+                                                #,(next-outer
+                                                   (vector-ref vec-stx n) ;this could be it
+                                                   (quasisyntax/loc
+                                                       stx
+                                                     (vector-ref #,exp-name #,count-offset-name-passover))
+                                                   '() ;we don't want these tests to take part in future
+                                                   ; elimination or to be eliminated
+                                                   bv
+                                                   let-bound
+                                                   kf
+                                                   (lambda (bsf bv)
+                                                     ;(set! current-index-name #`(add1 #,current-index-name))
+                                                     (let ((cindnm (gensym 'cindnm)))
+                                                       (quasisyntax/loc
+                                                           pt
+                                                         (let ((#,cindnm (add1 #,count-offset-name-passover)))
+                                                           #,((vloop (+ 1 n) cindnm) sf bv)))))))))
+                                         ((and (eq? (syntax-object->datum
+                                                     (vector-ref vec-stx n)) ;this could be it
+                                                    '_)
+                                               (>= (- vec-len n 1)
+                                                   (stx-dot-dot-k? (vector-ref vec-stx (add1 n)))))
+                                          (ks sf bv))
+                                         (else  ;; we now know that the next pattern is a ddk
+                                          (let ((bound (getbindings (vector-ref vec-stx n))))
+                                            (if (syntax? bound)
+                                                (kf sf bv)
+                                                (let* ((k (stx-dot-dot-k? (vector-ref vec-stx (add1 n))))
+                                                       (binding-list-names
+                                                        (map (lambda (x)
+                                                               (datum->syntax-object
+                                                                (quote-syntax here)
+                                                                (symbol-append
+                                                                 (gensym (syntax-object->datum x))
+                                                                 '-bindings)))
+                                                             bound))
+                                                       (vloop-name (gensym 'vloop))
+                                                       (count-name (gensym 'count))
+                                                       (index-name (gensym 'index)))
+                                                  (quasisyntax/loc
+                                                      stx
+                                                    (let #,vloop-name
+                                                      ((#,count-name #,count-offset-name-passover)
+                                                       #,@(map (lambda (x) (quasisyntax/loc stx (#,x '())))
+                                                               binding-list-names))
+                                                      #,(let ((fail-name (gensym 'fail))
+                                                              (count-offset-name (gensym 'count-offset))
+                                                              (index-name (gensym 'index))
+                                                              )
+                                                          (quasisyntax/loc
+                                                              pt
+                                                            (let ((#,fail-name
+                                                                     (lambda (#,count-offset-name #,index-name)
+                                                                       #,(let ((body ((vloop (+ n 2) index-name) sf
+                                                                                                                 (append (map (lambda (b bln)
+                                                                                                                                (cons b
+                                                                                                                                      (quasisyntax/loc
+                                                                                                                                          pt
+                                                                                                                                        (reverse #,bln))))
+                                                                                                                              bound
+                                                                                                                              binding-list-names)
+                                                                                                                         bv)
+                                                                                                                 )))
+                                                                           (if (> k 0)
+                                                                               (quasisyntax/loc
+                                                                                   pt
+                                                                                 (if (>= #,count-offset-name #,k)
+                                                                                     #,body
+                                                                                     #,(kf sf bv)))
+                                                                               body)))))
+                                                              (if (= #,length-of-vector-name #,count-name)
+                                                                  (#,fail-name
+                                                                     (- #,count-name #,count-offset-name-passover)
+                                                                     #,count-name)
+                                                                  #,(next-outer
+                                                                     (vector-ref vec-stx n) ;this could be it
+                                                                     (quasisyntax/loc
+                                                                         stx
+                                                                       (vector-ref #,exp-name #,count-name))
+                                                                     '() ;sf
+                                                                     bv ;; we alway start over
+                                                                     ;; with the old bindings
+                                                                     let-bound
+                                                                     (lambda (sf bv)
+                                                                       (quasisyntax/loc
+                                                                           pt
+                                                                         (#,fail-name
+                                                                            (- #,count-name
+                                                                               #,count-offset-name-passover)
+                                                                            #,count-name)))
+                                                                     (lambda (sf bv)
+                                                                       (quasisyntax/loc
+                                                                           stx
+                                                                         (let ((arglist
+                                                                                (list
+                                                                                 #,@(map
+                                                                                     (lambda (b-var
+                                                                                              bindings-var)
+                                                                                       (quasisyntax/loc
+                                                                                           stx
+                                                                                         (cons
+                                                                                          #,(get-bind-val
+                                                                                             b-var
+                                                                                             bv)
+                                                                                          #,bindings-var)))
+                                                                                     bound
+                                                                                     binding-list-names))))
+                                                                           (apply
+                                                                            #,vloop-name
+                                                                            (add1 #,count-name)
+                                                                            arglist))))))))))))))))))
+                                   sf
+                                   bv))))))))))))
+    
+    ;; END DDK-HANDLERS.SCM
+    
+    ;(include "ddk-handlers.scm")
+    ;(include "getter-setter.scm")
+    ;(include "emit-assm.scm")
+    ;(include "parse-quasi.scm")
+    ;(include "pattern-predicates.scm")
+  
+  ;; some convenient syntax for make-reg-test and make-shape-test
+  (define-syntax make-test-gen
+    (syntax-rules ()
+      [(_ constructor test ae emitter) (make-test-gen constructor test ae emitter ae)]
+      [(_ constructor test ae emitter ae2)
+       (constructor test ae
+                    (lambda (ks kf let-bound)
+                      (lambda (sf bv)
+                        (emit emitter ae2 let-bound sf bv kf ks))))]))
+  
+  (define-syntax reg-test
+    (syntax-rules ()
+      [(_ args ...) (make-test-gen make-reg-test args ...)]))
+  
+  (define-syntax shape-test
+    (syntax-rules ()
+      [(_ args ...) (make-test-gen make-shape-test args ...)]))
+  
+  ;; expand the regexp-matcher into an (and) with string?
+  (define-syntax regexp-matcher
+    (syntax-rules ()
+      [(_ ae stx pred)
+       (render-test-list #'(and (? string?) pred)
+                         ae stx)]))
+  
+  ;; produce a matcher for the empty list
+  (define (emit-null ae)  
+    (list (reg-test `(null? ,(syntax-object->datum ae)) 
+                    ae (lambda (exp) #`(null? #,exp)))))
+
+  ;; generic helper for producing set/get matchers
+  (define-syntax (set/get-matcher stx)    
+    (syntax-case stx (set! get!)
+      [(_ set!/get! ae p arg set/get-func) #`(set/get-matcher set!/get! ae p let-bound arg set/get-func)]
+      [(_ set!/get! ae p let-bound arg set/get-func)              
+       (with-syntax ([sym (syntax-case  #'set!/get! (set! get!) ['set! #''set!-pat] ['get! #''get!-pat])])
+       #`(syntax-case arg ()
+             [(ident)
+              (identifier? (syntax ident))
+              (list (make-act
+                     sym
+                     ae
+                     (lambda (ks kf let-bound)
+                       (lambda (sf bv)
+                         (ks sf (cons (cons #'ident
+                                            set/get-func)
+                                      bv))))))]
+             [() (match:syntax-err p
+                                   (format "there should be an identifier after ~a in pattern" set!/get!))]
+             [(_) (match:syntax-err p
+                                    (format " ~a followed by something that is not an identifier" set!/get!))]
+             [(_ (... ...))
+              (match:syntax-err p
+                                (format "there should be only one identifier after ~a in pattern" set!/get!))]
+             [_ (match:syntax-err p
+                                  (format "invalid ~a pattern syntax" set!/get!))]))]))
+             
+  
+  ;;!(function render-test-list
+  ;;          (form (render-test-list p ae stx) -> test-list)
+  ;;          (contract (syntax syntax syntax) -> list))
+  ;; This is the most important function of the entire compiler.
+  ;; This is where the functionality of each pattern is implemented.
+  ;; This function maps out how each pattern is compiled.  While it
+  ;; only returns a list of tests, the comp field of those tests
+  ;; contains a function which inturn knows enough to compile the
+  ;; pattern.
+  ;; <p>This is implemented in what Wright terms as mock-continuation-passing
+  ;; style.  The functions that create the syntax for a match success and failure
+  ;; are passed forward
+  ;; but they are always called in emit.  This is extremely effective for
+  ;; handling the different structures that are matched.  This way we can
+  ;; specify ahead of time how the rest of the elements of a list or vector
+  ;; should be handled.  Otherwise we would have to pass more information
+  ;; forward in the argument list of next and then test for it later and
+  ;; then take the appropriate action.  To understand this better take a
+  ;; look at how proper and improper lists are handled.
+  (define (render-test-list p ae stx)
+    ;(include "special-generators.scm")
+    
+    
+    
+
+    (syntax-case*
+        p
+      (_ list quote quasiquote vector box ? app and or not struct set! var
+         list-rest get! ... ___ unquote unquote-splicing
+         list-no-order hash-table regexp pregexp cons) stx-equal?
+
+      ;; this is how we extend match
+      [(expander args ...)
+       (and (identifier? #'expander) 
+            (match-expander? (syntax-local-value #'expander (lambda () #f))))
+       (let ([transformer (match-expander-plt-match-xform (syntax-local-value #'expander))])                  
+         (if (not transformer)
+             (match:syntax-err #'expander
+                               "This expander only works with standard match.")            
+             (render-test-list (transformer #'(expander args ...))
+                               ae stx)))]
+
+      ;; underscore is reserved to match nothing
+      (_ '()) ;(ks sf bv let-bound))
+      
+      ;; plain identifiers expand into (var) patterns
+      (pt
+       (and (pattern-var? (syntax pt))
+            (not (stx-dot-dot-k? (syntax pt))))
+       (render-test-list #'(var pt) ae stx))
+      
+      ;; for variable patterns, we do bindings, and check if we've seen this variable before
+      ((var pt)
+       (identifier? (syntax pt))
+       (list (make-act `bind-var-pat
+                       ae
+                       (lambda (ks kf let-bound)
+                         (lambda (sf bv)                           
+                           (cond [(ormap (lambda (x)
+                                           (if (stx-equal? #'pt (car x))
+                                               (cdr x) #f)) bv)
+                                  => (lambda (bound-exp)
+                                       (emit (lambda (exp)
+                                               #`((match-equality-test) #,exp #,(subst-bindings bound-exp let-bound)))
+                                             ae
+                                             let-bound
+                                             sf bv kf ks))]
+                                 [else
+                                  (ks sf (cons (cons (syntax pt) ae) bv))]))))))
+      
+      ;; Recognize the empty list
+      ((list) (emit-null ae))
+      ('() (emit-null ae))
+         
+
+      ;; This recognizes constants such strings
+      [pt
+       (let ([pt (syntax-object->datum #'pt)])
+         (or (string? pt)
+             (boolean? pt)
+             (char? pt)
+             (number? pt)))
+       (list
+        (reg-test 
+         `(equal? ,(syntax-object->datum ae)
+                  ,(syntax-object->datum (syntax pt)))
+         ae (lambda (exp) #`(equal? #,exp pt))))]
+      
+      ;(pt
+      ; (stx-? regexp? (syntax pt))
+      ; (render-test-list (syntax/loc p (regex pt)) ae stx))
+      
+       ;; match a quoted datum
+       ;; this is very similar to the previous pattern, except for the second argument to equal?
+      [(quote _)
+       (list 
+        (reg-test
+         `(equal? ,(syntax-object->datum ae)
+                  ,(syntax-object->datum p))
+         ae (lambda (exp) #`(equal? #,exp #,p))))]
+      
+      ;; I do not understand this, or why it is ever matched, but removing it causes test failures
+      ('item
+       (list 
+        (reg-test
+         `(equal? ,(syntax-object->datum ae)
+                  ,(syntax-object->datum p))
+         ae (lambda (exp) #`(equal? #,exp #,p)))))
+      
+      (`quasi-pat
+        (render-test-list (parse-quasi #'quasi-pat) ae stx))
+      
+      
+      ;; check for predicate patterns
+      ;; could we check to see if a predicate is a procedure here?
+      ((? pred?)
+       (list (reg-test 
+              `(,(syntax-object->datum #'pred?)
+                 ,(syntax-object->datum ae))
+              ae (lambda (exp) #`(pred? #,exp)))))
+      
+      ;; predicate patterns with binders are redundant with and patterns
+      ((? pred? pats ...)
+       (render-test-list #'(and (? pred?) pats ...) ae stx))
+      
+      ;; syntax checking
+      ((? anything ...)
+       (match:syntax-err
+        p
+        (if (zero? (length (syntax-e #'(anything ...))))
+            "a predicate pattern must have a predicate following the ?"
+            "syntax error in predicate pattern")))
+      
+      ((regexp reg-exp)
+       (regexp-matcher ae stx (? (lambda (x) (regexp-match reg-exp x)))))
+      ((pregexp reg-exp) 
+       (regexp-matcher ae stx (? (lambda (x) (pregexp-match-with-error reg-exp x)))))
+      ((regexp reg-exp pat)
+       (regexp-matcher ae stx (app (lambda (x) (regexp-match reg-exp x)) pat)))
+      ((pregexp reg-exp pat)
+       (regexp-matcher ae stx (app (lambda (x) (pregexp-match-with-error reg-exp x)) pat)))
+      
+      ;; app patterns just apply their operation.  I'm not sure why they exist.
+      ((app op pat)
+       (render-test-list #'pat #`(op #,ae) stx))
+      
+      ;; syntax checking
+      ((app . op)
+       (match:syntax-err
+        p
+        (if (zero? (length (syntax-e #'op)))
+            "an operation pattern must have a procedure following the app"
+            "there should be one pattern following the operator")))
+      ((and . pats)
+       (let loop
+         ((p #'pats))
+         (syntax-case p ()
+           ;; empty and always succeeds
+           (() '()) ;(ks seensofar boundvars let-bound))
+           ((pat . rest)
+            (append (render-test-list #'pat ae stx)
+                    (loop #'rest))))))
+      
+      ((or . pats)
+       (list (make-act
+              'or-pat ;`(or-pat ,(syntax-object->datum ae))
+              ae
+              (lambda (ks kf let-bound)
+                (lambda (sf bv)
+                  (or-gen ae (syntax-e #'pats)
+                          stx sf bv ks kf let-bound))))))
+      
+      
+      ((not pat)
+       (list (make-act
+              'not-pat ;`(not-pat ,(syntax-object->datum ae))
+              ae
+              (lambda (ks kf let-bound)
+                (lambda (sf bv)
+                  ;; swap success and fail
+                  (next-outer #'pat ae sf bv let-bound ks kf))))))
+      
+      ;; (cons a b) == (list-rest a b)
+      [(cons p1 p2) (render-test-list #'(list-rest a b) ae stx)]
+      
+      ;; could try to catch syntax local value error and rethrow syntax error      
+      ((list-no-order pats ...)
+       (if (stx-null? (syntax (pats ...)))
+           (render-test-list #'(list) ae stx)
+           (let* ((pat-list (syntax->list (syntax (pats ...))))
+                  (ddk-list (ddk-in-list? pat-list))
+                  (ddk (ddk-only-at-end-of-list? pat-list)))
+             (if (or (not ddk-list)
+                     (and ddk-list ddk))
+                 (let* ((bound (getbindings (append-if-necc 'list
+                                                            (syntax (pats ...)))))
+                        (bind-map
+                         (map (lambda (x)
+                                (cons x #`#,(gensym (syntax-object->datum x))))
+                              bound)))
+                   
+                   (list
+                    (shape-test
+                     `(list? ,(syntax-object->datum ae))
+                     ae (lambda (exp) #`(list? #,exp)))
+                    (make-act
+                     'list-no-order
+                     ae
+                     (lambda (ks kf let-bound)
+                       (lambda (sf bv)
+                         (let ((last-test
+                                (if ddk
+                                    (let ((pl (cdr (reverse pat-list))))
+                                      (begin
+                                        (set! pat-list (reverse (cdr pl)))
+                                        (create-test-func (car pl)
+                                                          sf
+                                                          let-bound
+                                                          bind-map
+                                                          #t)))
+                                    #f)))
+                           #`(let #,(map (lambda (b)
+                                           #`(#,(cdr b) '()))
+                                         bind-map)
+                               (let ((last-test #,last-test)
+                                     (test-list
+                                      (list
+                                       #,@(map (lambda (p)
+                                                 (create-test-func
+                                                  p
+                                                  sf
+                                                  let-bound
+                                                  bind-map
+                                                  #f))
+                                               pat-list))))
+                                 (if (match:test-no-order test-list
+                                                          #,ae
+                                                          last-test
+                                                          #,ddk)
+                                     #,(ks sf (append bind-map bv))
+                                     #,(kf sf bv))))))))))
+                 (match:syntax-err
+                  p
+                  (string-append "dot dot k can only appear at "
+                                 "the end of unordered match patterns"))))))
+      
+      ((hash-table pats ...)
+       ;; must check the structure
+       (proper-hash-table-pattern? (syntax->list (syntax (pats ...))))
+       (list
+        (shape-test
+         `(hash-table? ,(syntax-object->datum ae))
+         ae (lambda (exp) #`(hash-table? #,exp)))
+         
+        (let ((mod-pat
+               (lambda (pat)
+                 (syntax-case pat ()
+                   ((key value) (syntax (list key value)))
+                   (ddk
+                    (stx-dot-dot-k? (syntax ddk))
+                    (syntax ddk))
+                   (id
+                    (and (pattern-var? (syntax id))
+                         (not (stx-dot-dot-k? (syntax id))))
+                    (syntax id))
+                   (p (match:syntax-err
+                       (syntax/loc stx p)
+                       "poorly formed hash-table pattern"))))))
+          (make-act
+           'hash-table-pat
+           ae
+           (lambda (ks kf let-bound)
+             (lambda (sf bv)
+               (let ((hash-name (gensym 'hash)))
+                 #`(let ((#,hash-name
+                            (hash-table-map #,(subst-bindings ae
+                                                              let-bound)
+                                            (lambda (k v) (list k v)))))
+                     #,(next-outer #`(list-no-order #,@(map mod-pat (syntax->list (syntax (pats ...)))))
+                                   #`#,hash-name
+                                   sf
+                                   ;; these tests have to be true
+                                   ;;(append (list
+                                   ;;         '(pair? exp)
+                                   ;;         '(pair? (cdr exp))
+                                   ;;         '(null? (cdr (cdr exp))))
+                                   ;;        sf)
+                                   bv
+                                   let-bound
+                                   kf
+                                   ks)))))))))
+      
+      ((hash-table . pats)
+       (match:syntax-err
+        p
+        "improperly formed hash table pattern"))
+      
+      ((struct struct-name (fields ...))
+       (identifier? (syntax struct-name))       
+       (let*-values ([(field-pats) (syntax->list (syntax (fields ...)))]
+                     [(num-of-fields) (length field-pats)]
+                     [(pred accessors mutators parental-chain)
+                      (struct-pred-accessors-mutators #'struct-name)]
+                     ;; check that we have the right number of fields
+                      [(dif) (- (length accessors) num-of-fields)])
+         (unless (zero? dif)
+           (match:syntax-err
+            p
+            (string-append
+             (if (> dif 0) "not enough " "too many ")
+             "fields for structure in pattern")))
+         (cons
+          (shape-test
+           `(struct-pred ,(syntax-object->datum pred)
+                         ,(map syntax-object->datum parental-chain)
+                         ,(syntax-object->datum ae))
+           ae (lambda (exp) #`(struct-pred #,pred #,parental-chain #,exp)))
+          (map-append 
+             (lambda (cur-pat cur-mutator cur-accessor) 
+               (syntax-case cur-pat (set! get!)
+                 [(set! . rest) 
+                  (set/get-matcher 'set! ae stx (syntax rest)
+                                   #`(lambda (y)
+                                       (#,cur-mutator #,ae y)))]
+                 [(get! . rest)
+                  (set/get-matcher 'get! ae stx (syntax rest)
+                                   #`(lambda ()
+                                       (#,cur-accessor #,ae)))]
+                 [_ (render-test-list 
+                     cur-pat
+                     (quasisyntax/loc stx (#,cur-accessor #,ae))
+                     stx)]))
+             field-pats mutators accessors))))
+  
+      ;; syntax checking
+      ((struct ident ...)
+       (match:syntax-err
+        p
+        (if (zero? (length (syntax-e (syntax (ident ...)))))
+            (format "~a~n~a~n~a"
+                    "a structure pattern must have the name "
+                    "of a defined structure followed by a list of patterns "
+                    "to match each field of that structure")
+            "syntax error in structure pattern")))
+      ;; use a helper macro to match set/get patterns.  
+      ;; we give it the whole rest so that it can do error-checking and reporting
+      [(set! . rest)
+       (set/get-matcher 'set! ae p let-bound (syntax rest)
+                        (setter ae p let-bound))]
+      [(get! . rest)
+       (set/get-matcher 'get! ae p let-bound (syntax rest)
+                        (getter ae p let-bound))]
+
+      ;; list pattern with ooo or ook
+      ((list pat dot-dot-k pat-rest ...)
+       (and (not (or (memq (syntax-e (syntax pat))
+                           '(unquote unquote-splicing ... ___))
+                     (stx-dot-dot-k? (syntax pat))))
+            (stx-dot-dot-k? (syntax dot-dot-k)))
+       (list
+        (shape-test
+         `(list? ,(syntax-object->datum ae))
+         ae (lambda (exp) #`(list? #,exp)))
+        (make-act
+         'list-ddk-pat
+         ae
+         (lambda (ks kf let-bound)
+           (if (stx-null? (syntax (pat-rest ...)))
+               (handle-end-ddk-list ae kf ks
+                                    (syntax pat)
+                                    (syntax dot-dot-k)
+                                    stx let-bound)
+               (handle-inner-ddk-list ae kf ks
+                                      (syntax pat)
+                                      (syntax dot-dot-k)
+                                      (append-if-necc 'list
+                                                      (syntax (pat-rest ...)))
+                                      stx
+                                      let-bound))))))
+      
+      ;; list-rest pattern with a ooo or ook pattern
+      ((list-rest pat dot-dot-k pat-rest ...)
+       (and (not (or (memq (syntax-e (syntax pat))
+                           '(unquote unquote-splicing ... ___))
+                     (stx-dot-dot-k? (syntax pat))
+                     (stx-null? (syntax (pat-rest ...)))))
+            (stx-dot-dot-k? (syntax dot-dot-k)))
+       (list
+        (shape-test
+         `(pair? ,(syntax-object->datum ae))
+         ae (lambda (exp) #`(pair? #,exp)))
+        (make-act
+         'list-ddk-pat
+         ae
+         (lambda (ks kf let-bound)
+           (handle-inner-ddk-list
+            ae kf ks
+            (syntax pat)
+            (syntax dot-dot-k)
+            (if (= 1 (length
+                      (syntax->list (syntax (pat-rest ...)))))
+                (stx-car (syntax (pat-rest ...)))
+                (append-if-necc  'list-rest
+                                 (syntax (pat-rest ...))))
+            stx
+            let-bound)))))
+      
+      ;; list-rest pattern for improper lists
+      ;; handle proper and improper lists      
+      ((list-rest car-pat cdr-pat) ;pattern ;(pat1 pats ...)
+       (not (or (memq (syntax-e (syntax car-pat))
+                      '(unquote unquote-splicing))
+                (stx-dot-dot-k? (syntax car-pat))))
+       (cons
+        (shape-test
+         `(pair? ,(syntax-object->datum ae))
+         ae (lambda (exp) #`(pair? #,exp)))
+        (append
+         (render-test-list (syntax car-pat)
+                           (quasisyntax/loc (syntax car-pat) (car #,ae))
+                           stx) ;(add-a e)
+         (render-test-list
+          (syntax cdr-pat)
+          #`(cdr #,ae)
+          stx))))
+      
+      ;; list-rest pattern
+      ((list-rest car-pat cdr-pat ...) ;pattern ;(pat1 pats ...)
+       (not (or (memq (syntax-e (syntax car-pat))
+                      '(unquote unquote-splicing))
+                (stx-dot-dot-k? (syntax car-pat))))
+       (cons
+        (shape-test
+         `(pair? ,(syntax-object->datum ae))
+         ae (lambda (exp) #`(pair? #,exp)))
+        (append
+         (render-test-list (syntax car-pat)
+                           #`(car #,ae)
+                           stx) ;(add-a e)
+         (render-test-list
+          (append-if-necc 'list-rest (syntax (cdr-pat ...)))
+          #`(cdr #,ae)
+          stx))))
+      
+      ;; general list pattern
+      ((list car-pat cdr-pat ...) ;pattern ;(pat1 pats ...)
+       (not (or (memq (syntax-e (syntax car-pat))
+                      '(unquote unquote-splicing))
+                (stx-dot-dot-k? (syntax car-pat))))
+       (cons
+        (shape-test
+         `(pair? ,(syntax-object->datum ae))
+         ae (lambda (exp) #`(pair? #,exp)))
+        (append
+         (render-test-list (syntax car-pat)
+                           #`(car #,ae)
+                           stx) ;(add-a e)
+         (if (stx-null? (syntax (cdr-pat ...)))
+             (list
+              (shape-test
+               `(null? (cdr ,(syntax-object->datum ae)))
+               ae (lambda (exp) #`(null? #,exp)) #`(cdr #,ae)))
+             (render-test-list
+              (append-if-necc 'list (syntax (cdr-pat ...)))
+              #`(cdr #,ae)
+              stx)))))
+      
+      ;; vector pattern with ooo or ook at end
+      ((vector pats ...)
+       (ddk-only-at-end-of-list? (syntax-e (syntax (pats ...))))
+       (list
+        (shape-test
+         `(vector? ,(syntax-object->datum ae))
+         ae (lambda (exp) #`(vector? #,exp)))
+        (make-act
+         'vec-ddk-pat
+         ae
+         (lambda (ks kf let-bound)
+           (handle-ddk-vector ae kf ks
+                              #'#(pats ...)
+                              stx let-bound)))))
+      
+      ;; vector pattern with ooo or ook, but not at end
+      ((vector pats ...)
+       (let* ((temp (syntax-e (syntax (pats ...))))
+              (len (length temp)))
+         (and (>= len 2)
+              (ddk-in-list? temp)))
+       ;; make this contains ddk with no ddks consecutive
+       ;;(stx-dot-dot-k? (vector-ref temp (sub1 len))))))
+       (list
+        (shape-test
+         `(vector? ,(syntax-object->datum ae))
+         ae (lambda (exp) #`(vector? #,exp)))
+         ;; we have to look at the first pattern and see if a ddk follows it
+        ;; if so handle that case else handle the pattern
+        (make-act
+         'vec-ddk-pat
+         ae
+         (lambda (ks kf let-bound)
+           (handle-ddk-vector-inner ae kf ks
+                                    #'#(pats ...)
+                                    stx let-bound)))))
+      
+      ;; plain old vector pattern
+      ((vector pats ...)
+       (let* ((syntax-vec (list->vector (syntax->list (syntax (pats ...)))))
+              (vlen (vector-length syntax-vec)))
+         (list*
+          (shape-test
+           `(vector? ,(syntax-object->datum ae)) ae
+           (lambda (exp) #`(vector? #,exp)))
+          (shape-test
+           `(equal? (vector-length ,(syntax-object->datum ae)) ,vlen)
+           ae (lambda (exp) #`(equal? (vector-length #,exp) #,vlen)))
+          (let vloop ((n 0))
+            (if (= n vlen)
+                '()
+                (append
+                 (render-test-list
+                  (vector-ref syntax-vec n)
+                  #`(vector-ref #,ae #,n)
+                  stx)
+                 (vloop (+ 1 n))))))))
+      
+      ((box pat)
+       (cons
+        (shape-test
+         `(box? ,(syntax-object->datum ae))
+         ae (lambda (exp) #`(box? #,exp)))
+        (render-test-list
+         #'pat #`(unbox #,ae) stx)))
+      
+      ;; This pattern wasn't a valid form.
+      (got-too-far
+       (match:syntax-err
+        #'got-too-far
+        "syntax error in pattern"))))
+  )
\ No newline at end of file
diff --git a/collects/mzlib/private/reorder-tests.scm b/collects/mzlib/private/reorder-tests.scm
new file mode 100644
index 0000000000..36f8dfd1b0
--- /dev/null
+++ b/collects/mzlib/private/reorder-tests.scm
@@ -0,0 +1,103 @@
+;; This library is used by match.ss
+;; This requires the test data structure.
+(module reorder-tests mzscheme
+  
+  (provide reorder-all-lists)
+  
+  (require "test-structure.scm")
+  
+  (require-for-template mzscheme
+                        "test-structure.scm")
+  
+  ;; There really ought to be a stable sort in the std library.
+  
+  ;;!(function insertion-sort
+  ;;          (form (insertion-sort ls less-than?) -> list)
+  ;;          (contract (list (any any -> bool) -> list)))
+  ;; This is the classic stable sort.  Any stable sort will do.
+  (define insertion-sort 
+    (lambda (ls less-than?)
+      (define (insert el ls)
+        (define (ins ls)
+          (cond ((null? ls) (list el))
+                ((less-than? el (car ls))
+                 (cons el ls))
+                (else (cons (car ls) (ins (cdr ls))))))
+        (ins ls))
+      (letrec ((IS (lambda (ls)
+                     (if (null? ls)
+                         '()
+                         (insert (car ls)
+                                 (IS (cdr ls)))))))
+        (IS ls))))
+  
+  ;;!(function make-test-order-func
+  ;;          (form (make-test-order-func whole-list) -> less-than?)
+  ;;          (contract list -> (any any -> bool)))
+  ;; This function creates a test function which has access to the
+  ;;whole list of test structures capured in the closure.  This
+  ;;function places tests that are used more ahead of those used
+  ;;less.  When tests are used an equal number of times the test whos
+  ;;membership set has the greatest presence is placed ahead.
+  (define make-test-order-func
+    (lambda (whole-list)
+      (lambda (t1 t2)
+        (let ((t1-tu (test-times-used t1))
+              (t2-tu (test-times-used t2)))
+          (cond ((> t1-tu t2-tu) #t)
+                ;; these two new rules allow negate
+                ;; tests to be placed properly
+                ((and (= t1-tu t2-tu)
+                      (shape-test? t1)
+                      (not (shape-test? t2))
+                      (negate-test? t2))
+                 #t)
+                ((and (= t1-tu t2-tu)
+                      (not (shape-test? t1))
+                      (negate-test? t1)
+                      (shape-test? t2))
+                 #f)
+                ((and (= t1-tu t2-tu)
+                      (or (equal? (test-used-set t1) (test-used-set t2))
+                          (>= (number-of-similar (test-used-set t1) 
+                                                 whole-list)
+                              (number-of-similar (test-used-set t2) 
+                                                 whole-list))))
+                 #t)
+                (else #f))))))
+  
+  ;;!(function number-of-similar
+  ;;          (form (number-of-similar set ls) -> integer)
+  ;;          (contract (list list) -> integer))
+  ;; This function returns the number of tests that have a
+  ;; membership set similar to set.  A membership set is the set of
+  ;; test-lists that have a similar tests as the test itself.
+  (define number-of-similar 
+    (lambda (set ls)
+      (apply + (map (lambda (set2) (if (equal? set set2) 1 0))
+                    (map test-used-set ls)))))
+  
+  ;;!(function reorder-tests
+  ;;          (form (reorder-tests2 test-list) -> test-list)
+  ;;          (contract list -> list))
+  ;; This function reorders one list of test structs.
+  (define reorder-tests 
+    (lambda (test-list)
+      ;;(pretty-print test-list)(newline)
+      (insertion-sort test-list (make-test-order-func test-list))))
+  
+  ;;!(function reorder-all-lists
+  ;;          (form (reorder-all-lists2 rendered-list) -> list)
+  ;;          (contract list -> list))
+  ;; This function reorders all of the rendered-lists that have
+  ;; success-functions attached to them.
+  (define reorder-all-lists 
+    (lambda (rendered-list)
+      (if (null? rendered-list)
+          '()
+          (let ((success-func (cdr (car rendered-list)))
+                (rot (reorder-tests (caar rendered-list))))
+            ;(pretty-print rot)(newline)
+            (cons (cons rot success-func)
+                  (reorder-all-lists (cdr rendered-list)))))))
+  )
diff --git a/collects/mzlib/private/serialize-structs.ss b/collects/mzlib/private/serialize-structs.ss
new file mode 100644
index 0000000000..87e87adb12
--- /dev/null
+++ b/collects/mzlib/private/serialize-structs.ss
@@ -0,0 +1,18 @@
+(module serialize-structs mzscheme
+
+  ;; Exports just the structre info, which is needed in
+  ;;  "class.ss" (which is, in turn, ultimately required by
+  ;;  "serialize.ss")
+
+  (provide
+   (protect
+    (struct serialize-info (vectorizer deserialize-id can-cycle? dir))
+    (struct deserialize-info (maker cycle-maker))
+    prop:serializable serializable-struct? serializable-info))
+  
+  (define-struct serialize-info (vectorizer deserialize-id can-cycle? dir))
+  
+  (define-struct deserialize-info (maker cycle-maker))
+  
+  (define-values (prop:serializable serializable-struct? serializable-info)
+    (make-struct-type-property 'serializable #f)))
diff --git a/collects/mzlib/private/shared-body.ss b/collects/mzlib/private/shared-body.ss
new file mode 100644
index 0000000000..33f4ec2d2e
--- /dev/null
+++ b/collects/mzlib/private/shared-body.ss
@@ -0,0 +1,172 @@
+
+;; Used by ../shared.ss, and also collects/lang/private/teach.ss
+;; Besides the usual things, this code expects `undefined' and
+;; `the-cons' to be bound, and it expects `struct-declaration-info?'
+;; from the "struct.ss" library of the "syntax" collection.
+
+(syntax-case stx ()
+  [(_ ([name expr] ...) body1 body ...)
+   (let ([names (syntax->list (syntax (name ...)))]
+	 [exprs (syntax->list (syntax (expr ...)))])
+     (for-each (lambda (name)
+		 (unless (identifier? name)
+		   (raise-syntax-error
+		    'shared
+		    "not an identifier"
+		    stx
+		    name)))
+	       names)
+     (let ([dup (check-duplicate-identifier names)])
+       (when dup
+	 (raise-syntax-error
+	  'shared
+	  "duplicate identifier"
+	  stx
+	  dup)))
+     (let ([exprs (map (lambda (expr)
+			 (let ([e (local-expand
+				   expr
+				   'expression
+				   (append
+				    (kernel-form-identifier-list (quote-syntax here))
+				    names))])
+			   ;; Remove #%app if present...
+			   (syntax-case e (#%app)
+			     [(#%app a ...)
+			      (syntax/loc e (a ...))]
+			     [_else e])))
+		       exprs)]
+	   [struct-decl-for (lambda (id)
+			      (and (identifier? id)
+				   (let* ([s (symbol->string (syntax-e id))]
+					  [m (regexp-match-positions "make-" s)])
+				     (and m
+					  (let ([name (datum->syntax-object
+						       id
+						       (string->symbol (string-append (substring s 0 (caar m))
+										      (substring s (cdar m) (string-length s))))
+						       id)])
+					    (let ([v (syntax-local-value name (lambda () #f))])
+					      (and v
+						   (struct-declaration-info? v)
+						   v)))))))]
+	   [same-special-id? (lambda (a b)
+			       ;; Almost module-or-top-identifier=?,
+			       ;; but handle the-cons specially
+			       (or (module-identifier=? a b)
+				   (module-identifier=? 
+				    a 
+				    (datum->syntax-object
+				     #f
+				     (if (eq? 'the-cons (syntax-e b))
+					 'cons
+					 (syntax-e b))))))])
+       (with-syntax ([(init-expr ...)
+		      (map (lambda (expr)
+			     (define (bad n)
+			       (raise-syntax-error
+				'shared
+				(format "illegal use of ~a" n)
+				stx
+				expr))
+			     (syntax-case* expr (the-cons list box vector) same-special-id?
+			       [(the-cons a d)
+				(syntax (cons undefined undefined))]
+			       [(the-cons . _)
+				(bad "cons")]
+			       [(list e ...)
+				(with-syntax ([(e ...)
+					       (map (lambda (x) (syntax undefined))
+						    (syntax->list (syntax (e ...))))])
+				  (syntax (list e ...)))]
+			       [(list . _)
+				(bad "list")]
+			       [(box v)
+				(syntax (box undefined))]
+			       [(box . _)
+				(bad "box")]
+			       [(vector e ...)
+				(with-syntax ([(e ...)
+					       (map (lambda (x) (syntax undefined))
+						    (syntax->list (syntax (e ...))))])
+				  (syntax (vector e ...)))]
+			       [(vector . _)
+				(bad "vector")]
+			       [(make-x . _)
+				(struct-decl-for (syntax make-x))
+				(let ([decl (struct-decl-for (syntax make-x))]
+				      [args (syntax->list (syntax _))])
+				  (unless args
+				    (bad "structure constructor"))
+				  (when (or (not (cadr decl))
+					    (ormap not (list-ref decl 4)))
+				    (raise-syntax-error
+				     'shared
+				     "not enough information about the structure type in this context"
+				     stx
+				     expr))
+				  (unless (= (length (list-ref decl 4)) (length args))
+				    (raise-syntax-error
+				     'shared
+				     (format "wrong argument count for structure constructor; expected ~a, found ~a"
+					     (length (list-ref decl 4)) (length args))
+				     stx
+				     expr))
+				  (with-syntax ([undefineds (map (lambda (x) (syntax undefined)) args)])
+				    (syntax (make-x . undefineds))))]
+			       [_else
+				expr]))
+			   exprs)]
+		     [(finish-expr ...)
+		      (let ([gen-n (lambda (l)
+				     (let loop ([l l][n 0])
+				       (if (null? l)
+					   null
+					   (cons (datum->syntax-object (quote-syntax here) n #f)
+						 (loop (cdr l) (add1 n))))))])
+			(map (lambda (name expr)
+			       (with-syntax ([name name])
+				 (syntax-case* expr (the-cons list box vector) same-special-id?
+				   [(the-cons a d)
+				    (syntax (begin 
+					      (set-car! name a)
+					      (set-cdr! name d)))]
+				   [(list e ...)
+				    (with-syntax ([(n ...) (gen-n (syntax->list (syntax (e ...))))])
+				      (syntax (let ([lst name])
+						(set-car! (list-tail lst n) e)
+						...)))]
+				   [(box v)
+				    (syntax (set-box! name v))]
+				   [(vector e ...)
+				    (with-syntax ([(n ...) (gen-n (syntax->list (syntax (e ...))))])
+				      (syntax (let ([vec name])
+						(vector-set! vec n e)
+						...)))]
+				   [(make-x e ...)
+				    (struct-decl-for (syntax make-x))
+				    (let ([decl (struct-decl-for (syntax make-x))])
+				      (with-syntax ([(setter ...) (reverse (list-ref decl 4))])
+					(syntax
+					 (begin
+					   (setter name e) ...))))]
+				   [_else (syntax (void))])))
+			     names exprs))]
+		     [(check-expr ...)
+		      (if make-check-cdr
+			  (map (lambda (name expr)
+				 (syntax-case* expr (the-cons list box vector) same-special-id?
+				   [(the-cons a d)
+				    (make-check-cdr name)]
+				   [_else (syntax #t)]))
+			       names exprs)
+			  null)])
+	 (syntax
+	  (letrec ([name init-expr] ...)
+	    finish-expr
+	    ...
+	    check-expr
+	    ...
+	    body1
+	    body
+	    ...)))))])
diff --git a/collects/mzlib/private/sigmatch.ss b/collects/mzlib/private/sigmatch.ss
new file mode 100644
index 0000000000..ff779af4b4
--- /dev/null
+++ b/collects/mzlib/private/sigmatch.ss
@@ -0,0 +1,139 @@
+
+(module sigmatch mzscheme
+
+  (require "../unit.ss")
+
+  (define (hash-sig src-sig table)
+    (and (pair? src-sig)
+	 (vector? (car src-sig))
+	 (andmap
+	  (lambda (s)
+	    (cond
+	     [(symbol? s)
+	      (if (hash-table-get table s (lambda () #f))
+		  #f
+		  (begin
+		    (hash-table-put! table s s)
+		    #t))]
+	     [(and (pair? s) (symbol? (car s)))
+	      (let ([name (car s)])
+		(if (hash-table-get table name (lambda () #f))
+		  #f
+		  (let ([t (make-hash-table)])
+		    (hash-table-put! table name t)
+		    (hash-sig (cdr s) t))))]
+	     [else #f]))
+	  (vector->list (car src-sig)))))
+
+  (define (sig-path-name name path)
+    (let loop ([s (symbol->string name)]
+	       [path path])
+      (if (null? path)
+	  s
+	  (loop (format "~a:~a" s (car path))
+		(cdr path)))))
+
+  (define (check-sig-match table sig path exact? who src-context dest-context)
+    (and (vector? (car sig))
+	 (andmap
+	  (lambda (s)
+	    (cond
+	     [(symbol? s)
+	      (let ([v (hash-table-get table s
+				       (lambda ()
+					 (raise
+					  (make-exn:fail:unit
+					   (string->immutable-string
+					    (format
+					     "~a: ~a is missing a value name `~a', required by ~a"
+					     who
+					     src-context
+					     (sig-path-name s path)
+					     dest-context))
+					   (current-continuation-marks)))))])
+		(and v
+		     (begin
+		       (unless (symbol? v)
+			 (let ([p (sig-path-name s path)])
+			   (raise
+			    (make-exn:fail:unit
+			     (string->immutable-string
+			      (format
+			       "~a: ~a contains `~a' as a sub-unit name, but ~a contains `~a' as a value name"
+			       who
+			       src-context
+			       p
+			       dest-context
+			       p))
+			     (current-continuation-marks)))))
+		       (hash-table-put! table s #f)
+		       #t)))]
+	     [(and (pair? s) (symbol? (car s)))
+	      (let ([v (hash-table-get table (car s)
+				       (lambda ()
+					 (raise
+					  (make-exn:fail:unit
+					   (string->immutable-string
+					    (format
+					     "~a: ~a is missing a sub-unit name `~a', required by ~a"
+					     who
+					     src-context
+					     (sig-path-name (car s) path)
+					     dest-context))
+					   (current-continuation-marks)))))])
+		(and v
+		     (begin
+		       (unless (hash-table? v)
+			 (let ([p (sig-path-name (car s) path)])
+			   (raise
+			    (make-exn:fail:unit
+			     (string->immutable-string
+			      (format
+			       "~a: ~a contains `~a' as a value name, but ~a contains `~a' as a sub-unit name"
+			       who
+			       src-context
+			       p
+			       dest-context
+			       p))
+			     (current-continuation-marks)))))
+		       (hash-table-put! table (car s) #f)
+		       (check-sig-match v (cdr s) (cons (car s) path)
+					exact? who src-context dest-context))))]
+	     [else #f]))
+	  (vector->list (car sig)))
+	 (or (not exact?)
+	     (hash-table-for-each
+	      table
+	      (lambda (k v)
+		(when v
+		  (let ([p (sig-path-name k path)])
+		    (raise
+		     (make-exn:fail:unit
+		      (string->immutable-string
+		       (format
+			"~a: ~a contains an extra ~a name `~a' that is not required by ~a"
+			who
+			src-context
+			(if (symbol? v) 'value 'sub-unit)
+			p
+			dest-context))
+		      (current-continuation-marks)))))))
+	     #t)))
+
+  (define (verify-signature-match who exact? dest-context dest-sig src-context src-sig)
+    (unless (symbol? who)
+      (raise-type-error 'verify-signature-match "symbol" who))
+    (unless (string? dest-context)
+      (raise-type-error 'verify-signature-match "string" dest-context))
+    (unless (string? src-context)
+      (raise-type-error 'verify-signature-match "string" src-context))
+
+    (let ([src-table (make-hash-table)])
+      (unless (hash-sig src-sig src-table)
+	(raise-type-error 'verify-signature-match "signature" src-sig))
+
+      (unless (check-sig-match src-table dest-sig null
+			       exact? who src-context dest-context)
+	(raise-type-error 'verify-signature-match "signature" dest-sig))))
+
+  (provide verify-signature-match))
diff --git a/collects/mzlib/private/sigutil.ss b/collects/mzlib/private/sigutil.ss
new file mode 100644
index 0000000000..637dbb93b1
--- /dev/null
+++ b/collects/mzlib/private/sigutil.ss
@@ -0,0 +1,1167 @@
+
+(module sigutil mzscheme
+  ;; Used by unitsig.ss
+  ;; (needs an overhaul, too)
+
+  (require (lib "stx.ss" "syntax")
+	   (lib "struct.ss" "syntax")
+	   (lib "context.ss" "syntax"))
+
+  (require "sigmatch.ss")
+  (require "../unit.ss")
+  (require "../list.ss")
+
+  (define-struct signature (name      ; sym
+			    src       ; sym
+			    elems     ; list of syms and signatures
+			    ctxs      ; list of stx
+			    structs)) ; list of struct-infos
+  (define-struct parsed-unit (imports renames vars stxes body stx-checks))
+
+  (define-struct struct-def (name super-name names))
+
+  (define-struct sigdef (content interned))
+  (define (make-sig x) (make-sigdef x #f))
+  (provide make-sig)
+
+  (define inline-sig-name '<unnamed>)
+
+  (define-syntax literal?
+    (lambda (expr)
+      (syntax-case expr ()
+	[(_ a)
+	 (syntax (eq? (syntax-e (syntax a)) 'a))])))
+
+  (define (stx->sym s)
+    (if (syntax? s) (syntax-e s) s))
+
+  (define syntax-error
+    (case-lambda 
+     [(who expr msg sub)
+      (raise-syntax-error who msg expr sub)]
+     [(who expr msg)
+      (raise-syntax-error who msg expr)]))
+
+  (define undef-sig-error
+    (lambda (who expr what)
+      (syntax-error #f expr 
+		    "signature not defined"
+		    what)))
+
+  (define not-a-sig-error
+    (lambda (who expr what)
+      (syntax-error #f expr 
+		    "not a signature"
+		    what)))
+
+  (define rename-signature
+    (lambda (sig name main-ctx)
+      (make-signature name 
+		      (signature-src sig) 
+		      (signature-elems sig)
+		      (if main-ctx
+			  (map (lambda (ctx) (or ctx main-ctx)) (signature-ctxs sig))
+			  (signature-ctxs sig))
+		      (signature-structs sig))))
+
+  (define intern-signature
+    (lambda (name desc)
+      (let ([elems (vector->list (car desc))])
+	(make-signature
+	 name
+	 name
+	 (map
+	  (lambda (elem)
+	    (cond
+	     [(symbol? elem) elem]
+	     [(and (pair? elem) (symbol? (car elem)))
+	      (intern-signature (car elem) (cdr elem))]
+	     [else (error "intern failed")]))
+	  elems)
+	 (map (lambda (elem) #f) elems)
+	 (map
+	  (lambda (elem)
+	    (make-struct-def (vector-ref elem 0)
+			     (vector-ref elem 1)
+			     (cddr (vector->list elem))))
+	  (vector->list (cdr desc)))))))
+
+  (define get-sig
+    (lambda (who expr name sigid main-ctx)
+      (if (not (identifier? sigid))
+	  (parse-signature who expr 
+			   (if name
+			       name
+			       inline-sig-name)
+			   sigid
+			   main-ctx)
+	  (let ([v (syntax-local-value sigid (lambda () #f))])
+	    (unless v
+	      (undef-sig-error who expr sigid))
+	    (unless (sigdef? v)
+	      (not-a-sig-error who expr sigid))
+	    (unless (sigdef-interned v)
+	      (set-sigdef-interned! v (intern-signature (syntax-e sigid) (sigdef-content v))))
+	    (let ([s (sigdef-interned v)])
+	      (if name
+		  (rename-signature s (stx->sym name) (and main-ctx sigid))
+		  s))))))
+
+  (define check-unique
+    (lambda (names error-k)
+      (let ([dup (check-duplicate-identifier 
+		  (map (lambda (n)
+			 (if (syntax? n)
+			     n
+			     (datum->syntax-object #f n #f)))
+		       names))])
+	(when dup
+	  (error-k dup)))))
+
+  (define parse-signature
+    (lambda (who expr name body main-ctx)
+      (let-values ([(elems ctxs struct-defs)
+		    (let loop ([body body][accum null][ctx-accum null][struct-accum null])
+		      (syntax-case body ()
+			[() (values (reverse! accum) (reverse! ctx-accum) (reverse! struct-accum))]
+			[(something . rest)
+			 (syntax-case (syntax something) ()
+			   [:
+			    (literal? :)
+			    (syntax-error #f expr
+					  "misplaced `:'"
+					  (syntax something))]
+			   [id
+			    (identifier? (syntax id))
+			    (loop
+			     (syntax rest)
+			     (cons (syntax id) accum)
+			     (cons (syntax id) ctx-accum)
+			     struct-accum)]
+			   [(struct name (field ...) omission ...)
+			    (literal? struct)
+			    (let ([name (syntax name)]
+				  [fields (syntax->list (syntax (field ...)))]
+				  [omissions (syntax->list (syntax (omission ...)))])
+			      (unless (or (identifier? name)
+					  ;; >>> disabled the `(name super)' case for now <<<
+					  (and #f (syntax-case name ()
+						    [(name super)
+						     (and (identifier? (syntax name))
+							  (identifier? (syntax super)))]
+						    [_else #f])))
+				(syntax-error #f expr
+					      "struct name is not an identifier" ;; " or a parenthesized name--super sequence of identifiers"
+					      name))
+			      (for-each
+			       (lambda (fld)
+				 (unless (identifier? fld)
+				   (syntax-error #f expr
+						 "field name is not an identifier"
+						 fld)))
+			       fields)
+			      (let-values ([(omit-names
+					     omit-setters?
+					     omit-selectors?)
+					    (let loop ([omissions omissions]
+						       [names null]
+						       [no-set? #f]
+						       [no-sel? #f])
+					      (if (null? omissions)
+						  (values names no-set? no-sel?)
+						  (let ([rest (cdr omissions)])
+						    (syntax-case (car omissions) ()
+						      [-selectors
+						       (literal? -selectors)
+						       (loop rest names no-sel? #t)]
+						      [-setters
+						       (literal? -setters)
+						       (loop rest names #t no-set?)]
+						      [(- name)
+						       (and (literal? -) (identifier? (syntax name)))
+						       (loop rest (cons (syntax name) names)
+							     no-set? no-sel?)]
+						      [else
+						       (syntax-error #f expr
+								     "bad struct omission"
+								     (car omissions))]))))]
+					   [(name super-name) (if (identifier? name)
+								  (values name #f)
+								  (values (stx-car name)
+									  (stx-car (stx-cdr name))))])
+				(letrec ([names (build-struct-names 
+						 name fields 
+						 omit-selectors? omit-setters?)]
+					 [filter
+					  (lambda (names)
+					    (cond
+					     [(null? names) null]
+					     [(ormap (lambda (x) (eq? (syntax-e (car names))
+								      (syntax-e x)))
+						     omit-names)
+					      (filter (cdr names))]
+					     [else (cons (car names) (filter (cdr names)))]))])
+				  (let ([elems (if (null? omit-names)
+						   names 
+						   (filter names))])
+				    (loop (syntax rest)
+					  (append
+					   elems
+					   accum)
+					  (append
+					   (map (lambda (elem) name) elems)
+					   ctx-accum)
+					  (cons (make-struct-def (syntax-e name) 
+								 (and super-name (syntax-e super-name))
+								 names)
+						struct-accum))))))]
+			   [(struct . _)
+			    (literal? struct)
+			    (syntax-error #f expr
+					  "bad `struct' clause form"
+					  (syntax something))]
+			   [(unit name : sig) 
+			    (and (literal? unit)
+				 (identifier? (syntax name)))
+			    (let ([s (get-sig who expr (syntax name) (syntax sig) (and main-ctx (syntax sig)))])
+			      (loop (syntax rest)
+				    (cons s accum)
+				    (cons (syntax name) ctx-accum)
+				    struct-accum))]
+			   [(unit . _)
+			    (literal? unit)
+			    (syntax-error #f expr 
+					  "bad `unit' clause form"
+					  (syntax something))]
+			   [(open sig)
+			    (literal? open)
+			    (let ([s (get-sig who expr #f (syntax sig) (and main-ctx (syntax sig)))])
+			      (loop (syntax rest)
+				    (append (signature-elems s) accum)
+				    (append
+				     (map (lambda (e ctx)
+					    (or ctx (syntax sig)))
+					  (signature-elems s)
+					  (signature-ctxs s))
+				     ctx-accum)
+				    (append (signature-structs s) struct-accum)))]
+			   [(open . _)
+			    (literal? open)
+			    (syntax-error #f expr 
+					  "bad `open' clause form"
+					  (syntax something))]
+			   [else
+			    (syntax-error #f expr "improper signature clause type"
+					  (syntax something))])]
+			[_else (syntax-error #f expr "ill-formed signature"
+					     body)]))])
+	(check-unique (map
+		       (lambda (elem)
+			 (cond
+			  [(symbol? elem) elem]
+			  [(identifier? elem) (syntax-e elem)]
+			  [else (signature-name elem)]))
+		       elems)
+		      (lambda (name)
+			(syntax-error #f expr
+				      "duplicate name in signature"
+				      name)))
+	(let ([sorted (sort-signature-elems (map cons 
+						 (map (lambda (id)
+							(if (identifier? id)
+							    (syntax-e id)
+							    id))
+						      elems)
+						 (if main-ctx
+						     (map (lambda (ctx) (or ctx main-ctx)) ctxs)
+						     (map (lambda (id) #f) ctxs))))])
+	  (make-signature (stx->sym name)
+			  (stx->sym name)
+			  (map car sorted)
+			  (map cdr sorted)
+			  struct-defs)))))
+
+  (define (intern-vector intern-box v)
+    (if (and intern-box
+	     (equal? #() (cdr v))
+	     (andmap symbol? (vector->list (car v))))
+	(or (ormap (lambda (i)
+		     (and (equal? (car v) (caadr i))
+			  (list 'unquote (car i))))
+		   (unbox intern-box))
+	    (let ([name (car (generate-temporaries '(idvec)))])
+	      (set-box! intern-box
+			(cons (list name v)
+			      (unbox intern-box)))
+	      (list 'unquote name)))
+	v))
+
+  (define explode-sig
+    (lambda (sig intern-box)
+      (intern-vector
+       intern-box
+       (cons
+	(list->vector
+	 (map
+	  (lambda (v)
+	    (if (symbol? v)
+		v
+		(cons
+		 (signature-name v)
+		 (explode-sig v intern-box))))
+	  (signature-elems sig)))
+	(list->vector
+	 (map
+	  (lambda (v)
+	    (list->vector (list* (struct-def-name v)
+				 (struct-def-super-name v)
+				 (struct-def-names v))))
+	  (signature-structs sig)))))))
+
+  (define explode-named-sig
+    (lambda (s intern-box)
+      (cons
+       (cond
+	[(signature-name s)]
+	[(signature-src s)]
+	[else inline-sig-name])
+       (explode-sig s intern-box))))
+
+  (define explode-named-sigs
+    (lambda (sigs intern-box)
+      (map (lambda (sig) (explode-named-sig sig intern-box)) sigs)))
+
+  (define sort-signature-elems
+    (lambda (elems)
+      (map car
+	   (quicksort (map
+		       (lambda (ip)
+			 (let ([i (car ip)])
+			   (cons ip (symbol->string (if (symbol? i) 
+							i 
+							(signature-name i))))))
+		       elems)
+		      ;; Less-than; put subs at front
+		      (lambda (a b)
+			(if (symbol? (caar a))
+			    (if (symbol? (caar b))
+				(string<? (cdr a) (cdr b))
+				#f)
+			    (if (symbol? (caar b))
+				#t
+				(string<? (cdr a) (cdr b)))))))))
+  
+  (define flatten-signature
+    (lambda (id sig main-ctx)
+      (apply
+       append
+       (map
+	(lambda (elem ctx)
+	  (if (symbol? elem)
+	      (let ([sym
+		     (if id
+			 (string->symbol (string-append id ":" (symbol->string elem)))
+			 elem)])
+		(list
+		 (if main-ctx
+		     (datum->syntax-object (or ctx main-ctx) sym)
+		     sym)))
+	      (flatten-signature (let* ([n (signature-name elem)]
+					[s (if n
+					       (symbol->string n)
+					       #f)])
+				   (if (and id s)
+				       (string-append id ":" s)
+				       (or id s)))
+				 elem
+				 (or ctx main-ctx))))
+	(signature-elems sig)
+	(signature-ctxs sig)))))
+
+  (define flatten-signatures
+    (lambda (sigs main-ctx)
+      (apply append (map (lambda (s) 
+			   (let* ([name (signature-name s)]
+				  [id (if name
+					  (symbol->string name)
+					  #f)])
+			     (flatten-signature id s main-ctx)))
+			 sigs))))
+
+  (define signature-parts
+    (lambda (q?)
+      (lambda (sig)
+	(let loop ([elems (signature-elems sig)])
+	  (cond
+	   [(null? elems) null]
+	   [(q? (car elems)) (cons (car elems) (loop (cdr elems)))]
+	   [else (loop (cdr elems))])))))
+  (define signature-vars (signature-parts symbol?))
+  (define signature-subsigs (signature-parts signature?))
+
+  (define do-rename
+    (lambda (export-name renames)
+      (let loop ([renames renames])
+	(cond
+	 [(null? renames) export-name]
+	 [(eq? (cadar renames) export-name)
+	  (caar renames)]
+	 [else (loop (cdr renames))]))))
+
+  (define (make-struct-stx-decls sig prefix init-prefix? src-stx check?)
+    ;; If check? is #f, generates a syntax definition for <name> for
+    ;; each <name> struct form in `sig'. Used for imports.
+    ;; If check? is #t, generates an empty syntax "definition" that has
+    ;; the side-effect of checking <name> against its expected shape.
+    ;; CURRENTLY, check? is always #f.
+    (let ([signame (and init-prefix?
+			(signature-name sig))])
+      (append
+       (apply
+	append
+	(map (lambda (s)
+	       (make-struct-stx-decls s
+				      (if signame
+					  (format "~a~a:"
+						  (or prefix "")
+						  signame)
+					  prefix)
+				      #t
+				      src-stx
+				      check?))
+	     (filter signature? (signature-elems sig))))
+       (map (lambda (si)
+	      (let ([names (struct-def-names si)]
+		    [pfx (lambda (s)
+			   `(quote-syntax
+			     ,(let ([id (string->symbol 
+					 (format "~a~a~a" 
+						 (or prefix "")
+						 (if signame
+						     (format "~a:" signame)
+						     "")
+						 (if (syntax? s)
+						     (syntax-e s)
+						     s)))])
+				(datum->syntax-object src-stx id))))])
+		(let* ([name (pfx (struct-def-name si))]
+		       [check (if check?
+				  (lambda (l)
+				    `(verify-struct-shape ,name ,l))
+				  values)])
+		  `(define-syntaxes (,@(if check? null (list (cadr name))))
+		     ,(check
+		       `(list-immutable ,(pfx (car names))
+					,(pfx (cadr names))
+					,(pfx (caddr names))
+					;; trailing #fs below mean that we don't know whether we have all the fields:
+					(list-immutable
+					 ,@(map pfx (every-other (cdddr names)))
+					 #f)
+					(list-immutable
+					 ,@(map pfx (every-other (if (null? (cdddr names)) null (cddddr names))))
+					 #f)
+					#f))))))
+	    (signature-structs sig)))))
+
+  ;; Could be called at expansion time from the result of a `unit/sig' expansion.
+  ;; NOT CURRENTLY USED.
+  (define (verify-struct-shape name shape)
+    (let ([v (syntax-local-value name (lambda () #f))]
+	  [n (length (list-ref shape 3))])
+      (unless (and (list? v)
+		   (= (length v) 5)
+		   (identifier? (car v))
+		   (module-identifier=? (car v) (car shape))
+		   (identifier? (cadr v))
+		   (module-identifier=? (cadr v) (cadr shape))
+		   (identifier? (caddr v))
+		   (module-identifier=? (caddr v) (caddr shape))
+		   (list? (list-ref v 3))
+		   (= (length (list-ref v 3)) n)
+		   (andmap identifier? (list-ref v 3))
+		   (andmap module-identifier=? (list-ref v 3) (list-ref shape 3))
+		   (list? (list-ref v 4))
+		   (= (length (list-ref v 4)) n)
+		   (andmap identifier? (list-ref v 4))
+		   (andmap module-identifier=? (list-ref v 4) (list-ref shape 4)))
+	(raise-syntax-error
+	 'unit/sig
+	 (format "struct definition for `~a' within the unit does not match the export signature (~a)"
+		 (let ([s (symbol->string (syntax-e name))])
+		   (substring s 0 (- (string-length s) 2)))
+		 ;; Say why:
+		 (cond
+		  [(not v) "definition is missing or does not use `define-struct'"]
+		  [(not (and (list? v)
+			     (= (length v) 5)
+			     (identifier? (car v))
+			     (identifier? (cadr v))
+			     (identifier? (caddr v))
+			     (list? (list-ref v 3))
+			     (andmap identifier? (list-ref v 3))
+			     (list? (list-ref v 4))
+			     (andmap identifier? (list-ref v 4))
+			     (= (length (list-ref v 4)) (length (list-ref v 3)))))
+		   "compile-time struct information is stragely malformed"]
+		  [(not (< (length (list-ref v 3)) n))
+		   "extra fields in definition"]
+		  [(not (> (length (list-ref v 3)) n))
+		   "missing fields in definition"]
+		  [else
+		   "different field names or order"]))))
+      ;; Return 0 values to context
+      (values)))
+	 
+
+  (define (every-other l)
+    (let loop ([l l][r null])
+      (cond
+       [(null? l) r]
+       [(null? (cdr l)) (cons (car l) r)]
+       [else (loop (cddr l) (cons (car l) r))])))
+  
+  ;; ------------------------------------------------------------
+      
+  (define check-signature-unit-body
+    (lambda (sig a-unit renames who expr)
+      (let ([vars (map syntax-e (parsed-unit-vars a-unit))])
+	(for-each
+	 (lambda (var)
+	   (let ([renamed (do-rename var renames)])
+	     (unless (memq renamed vars)
+		     (syntax-error #f expr
+				   (format 
+				    "signature \"~s\" requires variable \"~s\"~a"
+				    (signature-src sig)
+				    var
+				    (if (eq? var renamed)
+					""
+					(format " renamed \"~s\"" renamed)))))))
+	 (signature-vars sig))
+	(unless (null? (signature-subsigs sig))
+		(syntax-error #f expr
+			      (format 
+			       "signature \"~s\" requires sub-units"
+			       (signature-src sig)))))))
+
+  (define parse-imports
+    (lambda (who untagged-legal? really-import? expr clause keep-ctx?)
+      (let ([bad
+	     (lambda (why . rest)
+	       (apply
+		syntax-error #f expr 
+		(format (if really-import?
+			    "bad `import' clause~a" 
+			    "bad linkage specification~a")
+			why)
+		rest))])
+	(let ([clause (stx->list clause)])
+	  (unless (stx-list? clause)
+	    (bad ""))
+	  (map
+	   (lambda (item)
+	     (syntax-case item ()
+	       [id 
+		(and (identifier? (syntax id))
+		     untagged-legal?)
+		(rename-signature (get-sig who expr #f item (and keep-ctx? (syntax id))) #f (syntax id))]
+	       [(id : sig)
+		(and (identifier? (syntax id))
+		     (literal? :))
+		(get-sig who expr (syntax id) (syntax sig) (and keep-ctx? (syntax sig)))]
+	       [any
+		untagged-legal?
+		(rename-signature (get-sig who expr #f item (and keep-ctx? (syntax any))) #f (syntax any))]
+	       [_else
+		(bad "" item)]))
+	   clause)))))
+
+  (define parse-unit
+    (lambda (expr body sig user-stx-forms dv-stx begin-stx)
+      (let ([body (stx->list body)])
+	(unless body
+	  (syntax-error #f expr "illegal use of `.'"))
+	(unless (and (pair? body)
+		     (stx-pair? (car body))
+		     (eq? 'import (syntax-e (stx-car (car body)))))
+	  (syntax-error #f expr 
+			"expected `import' clause"))
+	(let* ([imports (parse-imports 'unit/sig #t #t expr (stx-cdr (car body)) #t)]
+	       [imported-names (flatten-signatures imports #f)]
+	       [exported-names (flatten-signature #f sig #f)]
+	       [body (cdr body)])
+	  (let-values ([(renames body)
+			(if (and (stx-pair? body)
+				 (stx-pair? (car body))
+				 (eq? 'rename (syntax-e (stx-car (car body)))))
+			    (values (map syntax-object->datum (cdr (stx->list (car body)))) (cdr body))
+			    (values null body))])
+	    (unless renames
+	      (syntax-error #f expr "illegal use of `.'" (car body)))
+	    ;; Check renames:
+	    (let ([bad
+		   (lambda (why sub)
+		     (syntax-error #f expr 
+				   (format "bad `rename' clause~a" why)
+				   sub))])
+	      (for-each
+	       (lambda (id)
+		 (syntax-case id ()
+		   [(iid eid)
+		    (begin
+		      (unless (identifier? (syntax iid))
+			(bad ": original name is not an identifier" (syntax iid)))
+		      (unless (identifier? (syntax eid))
+			(bad ": new name is not an identifier" (syntax eid))))]
+		   [else
+		    (bad "" id)]))
+	       renames))
+	    (check-unique (map car renames)
+			  (lambda (name)
+			    (syntax-error #f expr
+					  "id renamed twice"
+					  name)))
+	    (let* ([renamed-internals (map car renames)]
+		   [swapped-renames (map (lambda (s) (cons (cadr s) (car s))) renames)]
+		   [filtered-exported-names 
+		    (if (null? renames) ;; an optimization
+			exported-names
+			(let loop ([e exported-names])
+			  (if (null? e)
+			      e
+			      (if (ormap (lambda (rn) (eq? (car rn) (car e))) 
+					 swapped-renames)
+				  (loop (cdr e))
+				  (cons (car e) (loop (cdr e)))))))]
+		   [local-vars (append renamed-internals filtered-exported-names imported-names)]
+		   [expand-context (generate-expand-context)])
+	      (let loop ([pre-lines null][lines body][port #f][port-name #f][body null][vars null])
+		(cond
+		 [(and (null? pre-lines) (not port) (null? lines))
+		  (make-parsed-unit imports 
+				    renames 
+				    vars 
+				    (lambda (src-stx) (apply append (map (lambda (i) (make-struct-stx-decls i #f #t src-stx #f)) imports)))
+				    body
+				    (lambda (src-stx) 
+				      ;; Disabled until we have a mechanism for declaring precise information in signatures:
+				      ;; (make-struct-stx-decls sig #f #f src-stx #t)
+				      null))]
+		 [(and (null? pre-lines) (not port) (not (pair? lines)))
+		  (syntax-error #f expr "improper body list form")]
+		 [else
+		  (let-values ([(line) (let ([s (cond
+						 [(pair? pre-lines) (car pre-lines)]
+						 [port (read-syntax port-name port)]
+						 [else (car lines)])])
+					 (if (eof-object? s)
+					   s
+					   (local-expand s    
+							 expand-context
+							 (append
+							  user-stx-forms
+							  local-vars))))]
+			       [(rest-pre-lines) 
+				(if (null? pre-lines)
+				    null
+				    (cdr pre-lines))]
+			       [(rest-lines)
+				(if (and (null? pre-lines) (not port))
+				    (cdr lines)
+				    lines)])
+		    (cond
+		     [(and (null? pre-lines) 
+			   port
+			   (eof-object? line))
+		      (values lines body vars)]
+		     [(and (stx-pair? line)
+			   (identifier? (stx-car line))
+			   (module-identifier=? (stx-car line) dv-stx))
+		      (syntax-case line ()
+			[(_ (id ...) expr)
+			 (loop rest-pre-lines
+			       rest-lines
+			       port
+			       port-name
+			       (cons line body)
+			       (append (syntax->list (syntax (id ...))) vars))]
+			[else
+			 (syntax-error #f expr 
+				       "improper `define-values' clause form"
+				       line)])]
+		     [(and (stx-pair? line)
+			   (identifier? (stx-car line))
+			   (module-identifier=? (stx-car line) begin-stx))
+		      (let ([line-list (stx->list line)])
+			(unless line-list
+			  (syntax-error #f expr 
+					"improper `begin' clause form"
+					line))
+			(loop (append (cdr line-list) rest-pre-lines)
+			      rest-lines
+			      port
+			      port-name
+			      body
+			      vars))]
+		     [else
+		      (loop rest-pre-lines
+			    rest-lines
+			    port
+			    port-name
+			    (cons line body)
+			    vars)]))]))))))))
+  
+  (define-struct link (name sig expr links))
+  (define-struct sig-explode-pair (sigpart exploded))
+
+  (define parse-compound-unit
+    (lambda (expr body)
+      (syntax-case body ()
+	[((import . imports)
+	  (link . links)
+	  (export . exports))
+	 (and (literal? import) (literal? link) (literal? export))
+	 (let* ([imports (parse-imports 'compound-unit/sig #f #t expr (syntax imports) #f)])
+	   (let ([link-list (syntax->list (syntax links))])
+	     (unless link-list
+	       (syntax-error #f expr 
+			     "improper `link' clause form"
+			     (syntax links)))
+	     (let* ([bad
+		     (lambda (why sub)
+		       (syntax-error #f expr 
+				     (format "bad `link' element~a" why)
+				     sub))]
+		    [links
+		     (map
+		      (lambda (line)
+			(syntax-case line ()
+			  [(tag : sig (expr linkage ...))
+			   (literal? :)
+			   (begin
+			     (unless (identifier? (syntax tag))
+			       (bad ": link tag is not an identifier" line))
+			     (make-link (syntax-e (syntax tag))
+					(get-sig 'compound-unit/sig (syntax expr) #f (syntax sig) #f)
+					(syntax expr)
+					(syntax->list (syntax (linkage ...)))))]
+			  [(tag . x)
+			   (not (identifier? (syntax tag)))
+			   (bad ": tag is not an identifier" (syntax tag))]
+			  [(tag : sig (expr linkage ...) . rest)
+			   (literal? :)
+			   (bad ": extra expressions in sub-clause" line)]
+			  [(tag : sig (expr . rest))
+			   (literal? :)
+			   (bad ": illegal use of `.' in linkages" line)]
+			  [(tag : sig)
+			   (literal? :)
+			   (bad ": expected a unit expression and its linkages" line)]
+			  [(tag : sig . e)
+			   (literal? :)
+			   (bad ": unit expression and its linkages not parenthesized" line)]
+			  [(tag :)
+			   (literal? :)
+			   (bad ": expected a signature" line)]
+			  [(tag)
+			   (bad ": expected `:'" line)]
+			  [_else
+			   (bad "" line)]))
+		      link-list)]
+		    [in-sigs imports]
+		    [find-link
+		     (lambda (name links)
+		       (let loop ([links links])
+			 (cond
+			  [(null? links) #f]
+			  [(eq? name (link-name (car links)))
+			   (car links)]
+			  [else (loop (cdr links))])))]
+		    [find-sig
+		     (lambda (name sigs)
+		       (let loop ([sigs sigs])
+			 (cond
+			  [(null? sigs) #f]
+			  [(and (signature? (car sigs))
+				(eq? name (signature-name (car sigs))))
+			   (car sigs)]
+			  [else (loop (cdr sigs))])))]
+		    [flatten-path
+		     (lambda (clause path var-k unit-k)
+		       (letrec ([check-sig
+				 (lambda (sig use-sig)
+				   (when use-sig
+				     (with-handlers ([exn:fail:unit?
+						      (lambda (exn)
+							(syntax-error 
+							 #f expr
+							 (exn-message exn)))])
+				       (verify-signature-match
+					'compound-unit/sig #f
+					(format "signature ~s" (signature-src use-sig))
+					(explode-sig use-sig #f)
+					(format "signature ~s" (signature-src sig))
+					(explode-sig sig #f)))))]
+				[flatten-subpath
+				 (lambda (base last use-sig name sig p)
+				   (cond
+				    [(stx-null? p) 
+				     (check-sig sig use-sig)
+				     (unit-k base last name (if use-sig
+								use-sig
+								sig))]
+				    [(or (not (stx-pair? p))
+					 (not (identifier? (stx-car p))))
+				     (syntax-error #f expr
+						   path)]
+				    [(memq (syntax-e (stx-car p)) (signature-vars sig))
+				     (if (and (stx-null? (stx-cdr p)) (not use-sig))
+					 (let* ([id-nopath (syntax-e (stx-car p))]
+						[id (if name
+							(string->symbol 
+							 (string-append name
+									":"
+									(symbol->string id-nopath)))
+							id-nopath)])
+					   (var-k base id id-nopath))
+					 (syntax-error #f expr
+						       (format 
+							"bad `~a' path: \"~a\" is a variable" 
+							clause
+							(syntax-e (stx-car p)))
+						       path))]
+				    [(find-sig (syntax-e (stx-car p)) (signature-elems sig))
+				     =>
+				     (lambda (s)
+				       (flatten-subpath base
+							(syntax-e (stx-car p))
+							use-sig
+							(let ([n (symbol->string 
+								  (signature-name s))])
+							  (if name
+							      (string-append name ":" n)
+							      n))
+							s
+							(stx-cdr p)))]
+				    [else
+				     (syntax-error #f expr
+						   (format 
+						    "bad `~a' path: \"~a\" not found"
+						    clause
+						    (syntax-e (stx-car p)))
+						   path)]))])
+			 (let-values ([(p use-sig)
+				       (syntax-case path ()
+					[_
+					 (identifier? path)
+					 (values (list path) #f)]
+					[(name : sig)
+					 (and (identifier? (syntax name))
+					      (literal? :))
+					 (values (list (syntax name))
+						 (get-sig 'compound-unit/sig expr
+							  #f
+							  (syntax sig)
+							  #f))]
+					[((elem ...) : sig)
+					 (and (andmap (lambda (s)
+							(and (identifier? s)
+							     (not (eq? (syntax-e s) ':))))
+						      (syntax->list (syntax (elem ...))))
+					      (literal? :))
+					 (values (syntax (elem ...))
+						 (get-sig 'compound-unit/sig expr
+							  #f
+							  (syntax sig)
+							  #f))]
+					[(elem1 elem ...)
+					 (andmap (lambda (s)
+						   (and (identifier? s)
+							(not (eq? (syntax-e s) ':))))
+						 (syntax->list (syntax (elem1 elem ...))))
+					 (values path #f)]
+					[else
+					 (syntax-error #f expr
+						       (format 
+							"bad `~a' path"
+							clause)
+						       path)])])
+			   (cond
+			    [(find-link (syntax-e (stx-car p)) links)
+			     => (lambda (link) 
+				  (flatten-subpath (link-name link)
+						   (syntax-e (stx-car p))
+						   use-sig
+						   #f
+						   (link-sig link)
+						   (stx-cdr p)))]
+			    [(find-sig (syntax-e (stx-car p)) in-sigs)
+			     => (lambda (sig) 
+				  (let ([s (symbol->string (signature-name sig))])
+				    (flatten-subpath #f
+						     (syntax-e (stx-car p))
+						     use-sig
+						     s
+						     sig
+						     (stx-cdr p))))]
+			    [else
+			     (syntax-error #f expr
+					   (format 
+					    "bad `~a' path: \"~a\" not found"
+					    clause
+					    (syntax-e (stx-car p)))
+					   path)]))))])
+	       (check-unique (map link-name links)
+			     (lambda (name)
+			       (syntax-error #f expr
+					     (format "duplicate sub-unit tag \"~s\"" name))))
+	       (check-unique (map signature-name imports)
+			     (lambda (name)
+			       (syntax-error #f expr
+					     (format "duplicate import identifier \"~s\"" name))))
+	       (check-unique (append (map signature-name imports)
+				     (map link-name links))
+			     (lambda (name)
+			       (syntax-error #f expr
+					     (format 
+					      "name \"~s\" is both import and sub-unit identifier" 
+					      name))))
+	       ;; Expand `link' clause using signatures
+	       (for-each
+		(lambda (link)
+		  (set-link-links! 
+		   link
+		   (map
+		    (lambda (link)
+		      (flatten-path 'link link
+				    (lambda (base var var-nopath)
+				      (make-sig-explode-pair
+				       var
+				       (list
+					(if base
+					    (list base var)
+					    var))))
+				    (lambda (base last id sig)
+				      (make-sig-explode-pair
+				       (rename-signature sig last #f)
+				       (if base
+					   (list (cons base (flatten-signature id sig #f)))
+					   (flatten-signature id sig #f))))))
+		    (link-links link))))
+		links)
+	       (let ([export-list (syntax->list (syntax exports))])
+		 (unless export-list
+		   (syntax-error #f expr 
+				 "improper `export' clause form"
+				 (syntax exports)))
+		 (let* ([upath? (lambda (p)
+				  (or (identifier? p)
+				      (and (stx-list? p)
+					   (andmap identifier? (stx->list p)))))]
+			[spath? (lambda (p)
+				  (syntax-case p ()
+				    [(name : sig)
+				     (and (literal? :)
+					  (upath? (syntax name))
+					  (or (identifier? (syntax sig))
+					      (parse-signature 'compound-unit/sig expr #f (syntax sig) #f)))
+				     #t]
+				    [_else
+				     (upath? p)]))]
+			[exports 
+			 (map
+			  (lambda (export)
+			    (syntax-case export ()
+			      [(open spath)
+			       (literal? open)
+			       (begin
+				 (unless (spath? (syntax spath))
+				   (syntax-error #f expr 
+						 "bad `open' sub-clause of `export'"
+						 export))
+				 (flatten-path 'export
+					       (syntax spath)
+					       (lambda (base var var-nopath)
+						 (syntax-error 
+						  #f expr 
+						  "`open' sub-clause path is a variable"
+						  (car export)))
+					       (lambda (base last name sig)
+						 (if base
+						     (make-sig-explode-pair
+						      (signature-elems sig)
+						      (cons base 
+							    (map
+							     list
+							     (flatten-signature name sig #f)
+							     (flatten-signature #f sig #f))))
+						     (syntax-error 
+						      #f expr 
+						      "cannot export imported variables"
+						      export)))))]
+			      [(var (upath vname) . exname)
+			       (literal? var)
+			       (let ([upath (syntax upath)]
+				     [vname (syntax vname)]
+				     [exname (syntax exname)])
+				 (unless (and (upath? upath)
+					      (identifier? vname)
+					      (or (stx-null? exname)
+						  (and (stx-pair? exname)
+						       (identifier? (stx-car exname))
+						       (stx-null? (stx-cdr exname)))))
+				   (syntax-error #f expr 
+						 "bad `var' sub-clause of `export'"
+						 export))
+				 (flatten-path 'export
+					       (if (identifier? upath)
+						   (list upath vname)
+						   (append (stx->list upath) (list vname)))
+					       (lambda (base var var-nopath)
+						 (if base
+						     (make-sig-explode-pair
+						      (list (if (stx-null? exname)
+								var-nopath
+								(syntax-e (stx-car exname))))
+						      (list base
+							    (if (stx-null? exname)
+								(list var var-nopath)
+								(list var (syntax-e (stx-car exname))))))
+						     (syntax-error 
+						      #f expr 
+						      "cannot export imported variables"
+						      export)))
+					       (lambda (base last name var)
+						 (syntax-error 
+						  #f expr 
+						  "`var' sub-clause path specifies a unit"
+						  export))))]
+			      [(unit spath . exname)
+			       (literal? unit)
+			       (let ([spath (syntax spath)]
+				     [exname (syntax exname)])
+				 (unless (and (spath? spath)
+					      (or (stx-null? exname)
+						  (and (stx-pair? exname)
+						       (identifier? (stx-car exname))
+						       (stx-null? (stx-cdr exname)))))
+				   (syntax-error #f expr 
+						 "bad `unit' sub-clause of `export'"
+						 export))
+				 (flatten-path 'export
+					       spath
+					       (lambda (base var var-nopath)
+						 (syntax-error 
+						  #f expr 
+						  "`unit' sub-clause path is a variable"
+						  export))
+					       (lambda (base last name sig)
+						 (if base
+						     (make-sig-explode-pair
+						      (list (rename-signature
+							     sig
+							     (if (stx-null? exname)
+								 last
+								 (syntax-e (stx-car exname)))
+							     #f))
+						      (let ([flat (flatten-signature name sig #f)])
+							(cons base 
+							      (map
+							       list
+							       flat
+							       (flatten-signature 
+								(symbol->string
+								 (if (stx-null? exname)
+								     last
+								     (syntax-e (stx-car exname))))
+								sig
+								#f)))))
+						     (syntax-error 
+						      #f expr 
+						      "cannot export imported variables"
+						      export)))))]
+			      [_else
+			       (syntax-error #f expr 
+					     (format 
+					      "bad `export' sub-clause")
+					     export)]))
+			  export-list)]
+			[interned-vectors (box null)])
+		   (check-unique (map
+				  (lambda (s)
+				    (if (signature? s)
+					(signature-name s)
+					s))
+				  (apply
+				   append
+				   (map sig-explode-pair-sigpart exports)))
+				 (lambda (name)
+				   (syntax-error #f expr
+						 "name is exported twice"
+						 name)))
+		   (values (map link-name links)
+			   (map link-expr links)
+			   (map (lambda (link) (explode-sig (link-sig link) interned-vectors)) links)
+			   (map
+			    (lambda (link)
+			      (map (lambda (sep)
+				     (explode-named-sig (sig-explode-pair-sigpart sep) interned-vectors))
+				   (link-links link)))
+			    links)
+			   (flatten-signatures imports #f)
+			   (map (lambda (link)
+				  (apply
+				   append
+				   (map 
+				    sig-explode-pair-exploded 
+				    (link-links link))))
+				links)
+			   (map sig-explode-pair-exploded exports)
+			   (explode-named-sigs imports interned-vectors)
+			   (explode-sig
+			    (let ([elems (apply
+					  append
+					  (map sig-explode-pair-sigpart exports))])
+			      (make-signature
+			       'dummy
+			       'dummy
+			       elems
+			       (map (lambda (x) #f) elems)
+			       null))
+			    interned-vectors)
+			   interned-vectors))))))]
+	[_else (raise-syntax-error 
+		#f
+		"bad syntax"
+		expr)])))
+  
+  (define parse-invoke-vars
+    (lambda (who rest expr)
+      (parse-imports who #t #f expr rest #f)))
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (provide parse-unit
+	   parse-compound-unit
+	   parse-invoke-vars
+
+	   parsed-unit-renames
+	   parsed-unit-imports
+	   parsed-unit-stxes
+	   parsed-unit-body
+	   parsed-unit-stx-checks
+
+	   make-struct-stx-decls
+	   verify-struct-shape
+
+	   signature-vars
+	   signature-structs
+	   do-rename
+	   get-sig
+	   explode-sig
+	   explode-named-sigs
+	   check-signature-unit-body
+	   flatten-signature
+	   flatten-signatures
+	   struct-def-name))
diff --git a/collects/mzlib/private/struct-helper.scm b/collects/mzlib/private/struct-helper.scm
new file mode 100644
index 0000000000..41cd346a38
--- /dev/null
+++ b/collects/mzlib/private/struct-helper.scm
@@ -0,0 +1,235 @@
+(module struct-helper mzscheme
+  (require (lib "list.ss"))
+  (require-for-template mzscheme)
+  (provide (all-defined))
+  
+  (define-struct field-decl (field ref mut posn immutable? auto?) (make-inspector))
+  
+  (define (sym+ . items)
+    (define (->string x)
+      (cond [(string? x) x]
+            [(symbol? x) (symbol->string x)]
+            [(identifier? x) (symbol->string (syntax-e x))]))
+    (string->symbol (apply string-append (map ->string items))))
+  
+  (define (identifier/tf? stx)
+    (or (identifier? stx) 
+        (not stx) 
+        (eq? (syntax-e stx) #t)
+        (eq? (syntax-e stx) #f)))
+  
+  (define (id/tf stx stx2)
+    (cond [(identifier? stx)
+           stx]
+          [(eq? (syntax-e stx) #t)
+           stx2]
+          [else #f]))
+  
+  (define (mk-parse-field-decl name-id)
+    (define (parse-field-decl stx)
+      (syntax-case stx ()
+        [(field (flag ...) ref mut)
+         (and (identifier? #'field)
+              (identifier/tf? #'ref)
+              (identifier/tf? #'mut)
+              (andmap identifier? (syntax->list #'(flag ...))))
+         (let ((flags (syntax-object->datum #'(flag ...))))
+           (make-field-decl
+            (id/tf #'field #f)
+            (id/tf #'ref (datum->syntax-object name-id (sym+ name-id '- #'field)))
+            (id/tf #'mut (datum->syntax-object name-id (sym+ 'set- name-id '- #'field '!)))
+            #f
+            (memq 'immutable flags)
+            (memq 'auto flags)))]
+        [(field (flag ...) ref)
+         (parse-field-decl #'(field (flag ...) ref #t))]
+        [(field (flag ...))
+         (parse-field-decl
+          #`(field 
+             (flag ...)
+             #t
+             #t))]
+        [field
+         (identifier? #'field)
+         (parse-field-decl
+          #`(field () #t #t))]))
+    (lambda (stx)
+      (let ((r (parse-field-decl stx)))
+        #;(printf "parse-field-decl returned ~s~n" r)
+        r)))
+  
+  (define-struct decl:super (super struct:super))
+  (define-struct decl:auto (value))
+  (define-struct decl:property (key value))
+  (define-struct decl:inspector (value))
+  (define-struct decl:procedure-field (field))
+  (define-struct decl:procedure (value))
+  (define-struct decl:guard (value))
+  (define-struct decl:option (value))
+  
+  (define (fetch-struct:super type)
+    (let ((struct-info (syntax-local-value type)))
+      (car struct-info)))
+  
+  (define (parse-decl stx)
+    (syntax-case stx (super struct:super
+                            auto-value property inspector transparent
+                            procedure procedure-field guard
+                            omit-define-values
+                            omit-static-info
+                            clone
+                            replace
+                            )
+      [(super type)
+       (identifier? #'type)
+       (make-decl:super #'type (fetch-struct:super #'type))]
+      [(struct:super value)
+       (make-decl:super #f #'value)]
+      [(auto-value value)
+       (make-decl:auto #'value)]
+      [(property key value)
+       (make-decl:property #'key #'value)]
+      [(inspector value)
+       (make-decl:inspector #'value)]
+      [transparent
+       (make-decl:inspector #'(make-inspector))]
+      [(procedure proc)
+       (make-decl:procedure #'proc)]
+      [(procedure-field field)
+       (identifier? #'field)
+       (make-decl:procedure-field #'field)]
+      [(guard proc)
+       (make-decl:guard #'proc)]
+      [omit-define-values
+       (make-decl:option 'omit-define-values)]
+      [omit-static-info
+       (make-decl:option 'omit-static-info)]
+      [clone
+       (make-decl:option 'include-clone)]
+      [replace
+       (make-decl:option 'include-replace)]))
+  
+  (define-struct info (type super auto-k auto-v 
+                            props insp proc-spec imm-k-list guard
+                            ref-fields ref-posns ref-names
+                            mut-fields mut-posns mut-names
+                            options fdecls))
+  (define (make-null-info type)
+    (make-info type #f 0 #f
+               '() #f #f '() #f
+               '() '() '()
+               '() '() '()
+               '() '()))
+  (define (create-info type decls field-decls)
+    (let ((info (make-null-info type)))
+      (let loop ((fdecls field-decls) (posn 0) (first-auto #f))
+        (if (pair? fdecls)
+            (let ((fdecl (car fdecls)))
+              (set-field-decl-posn! fdecl posn)
+              (when (and first-auto (not (field-decl-auto? fdecl)))
+                (raise-syntax-error 'define-struct* 
+                                    "non-auto field came after auto field"
+                                    (field-decl-field fdecl)))
+              (when (field-decl-ref fdecl)
+                (set-info-ref-fields! info 
+                                      (cons (field-decl-field fdecl) (info-ref-fields info)))
+                (set-info-ref-posns! info 
+                                     (cons posn (info-ref-posns info)))
+                (set-info-ref-names! info 
+                                     (cons (field-decl-ref fdecl) (info-ref-names info))))
+              (when (field-decl-mut fdecl)
+                (set-info-mut-fields! info 
+                                      (cons (field-decl-field fdecl) (info-mut-fields info)))
+                (set-info-mut-posns! info 
+                                     (cons posn (info-mut-posns info)))
+                (set-info-mut-names! info 
+                                     (cons (field-decl-mut fdecl) (info-mut-names info))))
+              (loop (cdr fdecls)
+                    (add1 posn)
+                    (or first-auto (if (field-decl-auto? fdecl) posn #f))))
+            (begin (set-info-auto-k! info 
+                                     (if first-auto (- posn first-auto) 0)))))
+      (set-info-ref-fields! info (reverse (info-ref-fields info)))
+      (set-info-ref-posns! info (reverse (info-ref-posns info)))
+      (set-info-ref-names! info (reverse (info-ref-names info)))
+      (set-info-mut-fields! info (reverse (info-mut-fields info)))
+      (set-info-mut-posns! info (reverse (info-mut-posns info)))
+      (set-info-mut-names! info (reverse (info-mut-names info)))
+      (set-info-fdecls! info field-decls)
+      (for-each 
+       (lambda (decl)
+         (cond [(decl:super? decl) (set-info-super! info decl)]
+               [(decl:auto? decl) (set-info-auto-v! info (decl:auto-value decl))]
+               [(decl:property? decl)
+                (set-info-props! info (cons (cons (decl:property-key decl)
+                                                  (decl:property-value decl))
+                                            (info-props info)))]
+               [(decl:inspector? decl)
+                (set-info-insp! info (decl:inspector-value decl))]
+               [(decl:procedure? decl)
+                (set-info-proc-spec! info (decl:procedure-value decl))]
+               [(decl:procedure-field? decl)
+                (set-info-proc-spec! 
+                 info
+                 (let loop ((fields (map field-decl-field field-decls)) (i 0))
+                   (cond
+                     [(null? fields)
+                      (raise-syntax-error 'define-struct*
+                                          "procedure-field not in field set"
+                                          (decl:procedure-field-field decl))]
+                     [(module-identifier=? (decl:procedure-field-field decl)
+                                           (car fields))
+                      i]
+                     [else (loop (cdr fields) (add1 i))])))]
+               [(decl:guard? decl)
+                (set-info-guard! info (decl:guard-value decl))]
+               [(decl:option? decl)
+                (set-info-options! info (cons (decl:option-value decl)
+                                              (info-options info)))]
+               ))
+       decls)
+      (when (and (info-include-replacers? info) (pair? (info-auto-fields info)))
+        (error 'define-struct* "cannot define replacers with auto-fields"))
+      info))
+  
+  (define (info-init-fields info)
+    (filter (lambda (fdecl) (not (field-decl-auto? fdecl)))
+            (info-fdecls info)))
+  (define (info-auto-fields info)
+    (filter (lambda (fdecl) (field-decl-auto? fdecl))
+            (info-fdecls info)))
+  
+  (define (info-include-define-values? info)
+    (not (memq 'omit-define-values (info-options info))))
+  
+  (define (info-include-static-info? info)
+    (not (memq 'omit-static-info (info-options info))))
+  (define (info-include-replacers? info)
+    (memq 'include-replace (info-options info)))
+  (define (info-include-clone? info)
+    (memq 'include-clone (info-options info)))
+  
+  (define (info-include-x-ref? info)
+    #f)
+  (define (info-include-x-set!? info)
+    #f)
+  
+  
+  (define (info-name:struct-record info)
+    (let ((type (info-type info)))
+      (datum->syntax-object type (sym+ 'struct: type))))
+  (define (info-name:constructor info)
+    (let ((type (info-type info)))
+      (datum->syntax-object type (sym+ 'make- type))))
+  (define (info-name:predicate info)
+    (let ((type (info-type info)))
+      (datum->syntax-object type (sym+ type '?))))
+  (define (info-defined-names info)
+    (let ((type (info-type info)))
+      (append (list (info-name:struct-record info)
+                    (info-name:constructor info)
+                    (info-name:predicate info))
+              (info-ref-names info)
+              (info-mut-names info))))
+  
+  )
diff --git a/collects/mzlib/private/structure-helper.ss b/collects/mzlib/private/structure-helper.ss
new file mode 100644
index 0000000000..3eb7391d9b
--- /dev/null
+++ b/collects/mzlib/private/structure-helper.ss
@@ -0,0 +1,53 @@
+(module structure-helper mzscheme
+  (require (lib "stx.ss" "syntax"))
+  (provide str str? str-renames make-str remove-dups split open open-as-helper)
+  (define-struct str (renames))
+  
+  (define (remove-dups l)
+    (let ((ht (make-hash-table)))
+      (let loop ((l l))
+        (cond
+          ((null? l) null)
+          ((hash-table-get ht (caar l) (lambda () #f)) (loop (cdr l)))
+          (else 
+           (hash-table-put! ht (caar l) #t)
+           (cons (car l) (loop (cdr l))))))))
+  
+  (define (split path)
+    (let ((r (reverse path)))
+      (values (reverse (cdr r)) (car r))))
+
+  (define (get-renames id err)
+    (let ((x (syntax-local-value id (err id))))
+      (unless (str? x)
+        ((err id)))
+      (str-renames x)))
+  
+  (define (open path type)
+    (unless (identifier? (car path))
+      (raise-syntax-error type "Path component must be an identifier" (car path)))
+    (let ((err (lambda (name)
+                 (lambda ()
+                   (raise-syntax-error type "Unknown structure" name)))))
+      (let loop ((path (cdr path))
+                 (env (get-renames (car path) err)))
+        (cond
+          ((null? path) env)
+          (else
+           (unless (identifier? (car path))
+             (raise-syntax-error type "Path component must be an identifier" (car path)))
+           (let ((bind (assq (syntax-object->datum (car path)) env)))
+             (unless bind
+               ((err (car path))))
+             (loop (cdr path) (get-renames (cdr bind) err))))))))
+
+  (define (open-as-helper path field)
+    (unless (identifier? field)
+      (raise-syntax-error 'open-as "Field to open must be an identifier" field))
+    (let ((hid (assq (syntax-object->datum field )
+                     (open (stx->list path) 'open-as))))
+      (unless hid
+        (raise-syntax-error 'open-as "Unknown field" field))
+      (make-rename-transformer (cdr hid))))
+  
+  )
\ No newline at end of file
diff --git a/collects/mzlib/private/stxparamkey.ss b/collects/mzlib/private/stxparamkey.ss
new file mode 100644
index 0000000000..9dd88067ad
--- /dev/null
+++ b/collects/mzlib/private/stxparamkey.ss
@@ -0,0 +1,71 @@
+
+(module stxparamkey mzscheme
+
+  (define-struct wrapped-renamer (renamer))
+  
+  (define-values (struct:syntax-parameter make-syntax-parameter syntax-parameter? syntax-parameter-ref syntax-parameter-set!)
+    (make-struct-type 'syntax-parameter #f 2 0 #f null (current-inspector) 0))
+
+  (define (syntax-parameter-target sp)
+    (syntax-parameter-ref sp 1))
+
+  (define (syntax-parameter-target-value target)
+    (let ([v (syntax-local-value (syntax-local-get-shadower target)
+				 (lambda ()
+				   #f
+				   (syntax-local-value 
+				    target
+				    (lambda () #f))))])
+      (if (wrapped-renamer? v)
+	  (wrapped-renamer-renamer v)
+	  v)))
+
+  (define (convert-renamer v)
+    (if (rename-transformer? v)
+	(make-wrapped-renamer v)
+	v))
+
+  (define (apply-transformer v stx set!-stx)
+    (cond
+     [(rename-transformer? v) 
+      (with-syntax ([target (rename-transformer-target v)])
+	(syntax-case stx ()
+	  [(set! id _expr) 
+	   (module-identifier=? #'set! set!-stx)
+	   (syntax/loc stx (set! target expr))]
+	  [(id . rest)
+	   (let ([v (syntax (target . rest))])
+	     (datum->syntax-object
+	      stx
+	      (syntax-e v)
+	      stx))]
+	  [_else
+	   #'target]))]
+     [(set!-transformer? v) ((set!-transformer-procedure v) stx)]
+     [(and (procedure? v)
+	   (procedure-arity-includes? v 1))
+      (syntax-case stx ()
+	[(set! id _) 
+	 (module-identifier=? #'set! set!-stx)
+	 (raise-syntax-error
+	  #f
+	  "cannot mutate syntax identifier"
+	  stx
+	  #'id)]
+	[else (v stx)])]
+     [else
+      (raise-syntax-error
+       #f
+       "bad syntax"
+       stx
+       #f)]))
+
+
+  (provide convert-renamer
+	   apply-transformer
+	   syntax-parameter?
+	   make-syntax-parameter
+	   syntax-parameter-target
+	   syntax-parameter-target-value))
+	   
+
diff --git a/collects/mzlib/private/stxset.ss b/collects/mzlib/private/stxset.ss
new file mode 100644
index 0000000000..d19b603d12
--- /dev/null
+++ b/collects/mzlib/private/stxset.ss
@@ -0,0 +1,103 @@
+
+(module stxset mzscheme
+
+  (require-for-syntax (lib "kerncase.ss" "syntax")
+		      (lib "context.ss" "syntax"))
+
+  (provide finish-syntax-set)
+
+  ;; Used in the expansion of `define-syntax-set' from "etc.ss"
+  (define-syntax (finish-syntax-set stx)
+    (syntax-case stx ()
+      [(_ stx)
+       (let ([stx (syntax stx)])
+	 (syntax-case stx ()
+	   [(_ (id ...) defn ...)
+	    ;; The ids have already been checked --------------------
+	    (let ([ids (syntax->list (syntax (id ...)))])
+	      (let ([internal-ids (map (lambda (id)
+					 (datum->syntax-object
+					  id
+					  (string->symbol (format "~a/proc" (syntax-e id)))
+					  id))
+				       ids)]
+		    [expand-context (generate-expand-context)])
+		;; Check defns (requires expand) ---------
+		(let* ([defns (let loop ([defns (syntax->list (syntax (defn ...)))])
+				(apply 
+				 append
+				 (map
+				  (lambda (defn)
+				    (let ([defn (local-expand
+						 defn
+						 expand-context
+						 (kernel-form-identifier-list (quote-syntax here)))])
+				      (syntax-case defn (define-values define-syntaxes begin)
+					[(define-values (id ...) expr)
+					 (andmap identifier? (syntax->list (syntax (id ...))))
+					 (list defn)]
+					[(define-values . _)
+					 (raise-syntax-error
+					  #f
+					  "bad definition"
+					  stx
+					  defn)]
+					[(define-syntaxes (id ...) expr)
+					 (andmap identifier? (syntax->list (syntax (id ...))))
+					 (list defn)]
+					[(define-syntaxes . _)
+					 (raise-syntax-error
+					  #f
+					  "bad definition"
+					  stx
+					  defn)]
+					[(begin defn ...)
+					 (loop (syntax->list (syntax (defn ...))))]
+					[(begin . _)
+					 (raise-syntax-error
+					  #f
+					  "bad `begin'"
+					  stx
+					  defn)]
+					[else
+					 (raise-syntax-error
+					  #f
+					  "not a definition"
+					  stx
+					  defn)])))
+				  defns)))]
+		       
+		       [def-ids (apply append (map (lambda (defn)
+						     (syntax-case defn ()
+						       [(_ (id ...) expr)
+							(syntax->list (syntax (id ...)))]))
+						   defns))]
+		       [val-ids (apply append (map (lambda (defn)
+						     (syntax-case defn (define-values)
+						       [(define-values (id ...) expr)
+							(syntax->list (syntax (id ...)))]
+						       [_else null]))
+						   defns))])
+		  (let ([dup (check-duplicate-identifier def-ids)])
+		    (when dup
+		      (raise-syntax-error
+		       #f
+		       "duplicate defined identifier"
+		       stx
+		       dup)))
+		  ;; Check that declared are defined ---------
+		  (for-each (lambda (id)
+			      (unless (check-duplicate-identifier (cons id val-ids))
+				(raise-syntax-error
+				 #f
+				 "expected identifier is not defined"
+				 stx
+				 id)))
+			    internal-ids)
+		  ;; Produce result ------------------------------
+		  (with-syntax ([(defn ...) defns]
+				[(internal-id ...) internal-ids])
+		    (syntax/loc stx
+		      (let ()
+			defn ...
+			(values internal-id ...)))))))]))])))
diff --git a/collects/mzlib/private/syntax-utils.ss b/collects/mzlib/private/syntax-utils.ss
new file mode 100644
index 0000000000..51c800705a
--- /dev/null
+++ b/collects/mzlib/private/syntax-utils.ss
@@ -0,0 +1,45 @@
+(module syntax-utils mzscheme
+  ;; Useful utilities on syntax objects
+  
+  (provide (all-defined))
+  
+   ;;! (function stx-length
+  ;;          (form (syntax-length syntax-obj) -> int)
+  ;;          (contract syntax-object -> int)
+  ;;          (example (syntax-length (syntax iraq war idiocy)) -> 3))
+  ;;  Returns the length of the top-level syntax list.
+  (define (stx-length stx) (length (syntax->list stx)))
+  
+  ;;! (function stx-?
+  ;;          (form (stx? test val) -> bool)
+  ;;          (contract ((any -> bool) syntax-object) -> bool)
+  ;;          (example (stx-? number? (syntax 4)) -> #t))
+  ;;  Applies predicate test to the syntax object val and returns the resulting
+  ;; boolean value.
+  (define (stx-? test val) (test (syntax-object->datum val)))
+  
+  ;;!(function stx-equal?
+  ;;          (form (stx-equal? a b) -> bool)
+  ;;          (contract (syntax-object syntax-object) -> bool)
+  ;;          (example (stx-equal? (syntax 5) (syntax 5)) -> #t))
+  ;; Check the equality of two syntax objects by after applying
+  ;; syntax-object->datum to the objects first.  Checks equaltiy of
+  ;; syntax objects after they have had all syntax data stripped away.
+  (define (stx-equal? a b)
+    (equal? (syntax-object->datum a)
+            (syntax-object->datum b)))
+  
+  ;;!(function get-exp-var
+  ;;          (form (get-exp-var) -> syntax)
+  ;;          (contract () -> syntax)
+  ;;          (example (get-exp-var) -> (syntax exp754)))
+  ;; This function just produces unique identifiers for expressions.
+  (define (get-exp-var) #`#,(gensym 'exp))
+  
+  
+  ;; syntax-map : (stx -> b)  stx-list -> listof[b]
+  ;; maps a function over a syntax object that represents a list
+  (define (syntax-map f stx-l)
+    (map f (syntax->list stx-l)))
+  
+  )
\ No newline at end of file
diff --git a/collects/mzlib/private/tag-negate-tests.scm b/collects/mzlib/private/tag-negate-tests.scm
new file mode 100644
index 0000000000..45474b287e
--- /dev/null
+++ b/collects/mzlib/private/tag-negate-tests.scm
@@ -0,0 +1,105 @@
+(module tag-negate-tests mzscheme
+  (provide tag-negate-tests)
+  (require "test-structure.scm")
+  #;(require-for-template mzscheme
+                        "test-structure.scm")
+  
+  (define (tag-neg-test ls target-set)
+    (easy-tag ls #f target-set))
+  
+  (define (easy-tag ls last-shape target-set)
+    (cond ((null? ls) #f)
+          ((let ((tst (car ls)))
+             (and ;(not (action-test? tst))
+              (not (or (shape-test? tst) (action-test? tst)))
+              (equal? target-set (test-used-set-neg tst))))
+           (begin 
+             (when (and last-shape (not (shape-test? (car ls))))
+               (set-test-closest-shape-tst! (car ls) last-shape) 
+               (set-test-used-set! (car ls) last-shape)
+               (set-test-times-used! (car ls) (length last-shape)))
+             #t))
+          ((shape-test? (car ls))
+           (easy-tag (cdr ls) (test-used-set (car ls)) target-set))
+          (else 
+           (easy-tag (cdr ls) last-shape target-set))))
+  
+  (define (tag-negate-tests ls-of-ls)
+    (letrec ((gen-target-set-help
+              (lambda (init length)
+                (if (zero? length)
+                    '()
+                    (cons init 
+                          (gen-target-set-help (add1 init) 
+                                               (sub1 length))))))
+             (gen-target-set
+              (lambda (length)
+                (gen-target-set-help 2 length)))
+             (tag-help 
+              (lambda (ls target-set)
+                (if (null? target-set) 
+                    '()
+                    (begin 
+                      (tag-neg-test (car ls) 
+                                    (reverse target-set))
+                      (tag-help
+                       (cdr ls)
+                       (cdr target-set)))))))
+      (tag-help (map car ls-of-ls) (gen-target-set (sub1 (length ls-of-ls))))))
+  
+  
+  ; (define (move-negates-to-tags ls-of-ls)
+  ;   (map (lambda (l) (cons (move-neg-to-tag (car l))
+  ;                          (cdr l)))
+  ;        ls-of-ls))
+  
+  
+  ; (define (move-neg-to-tag ls)
+  ;   (let-values (((list-without-neg-tests neg-tests)
+  ;                 (let loop ((l ls)
+  ;                            (ntsf '()))
+  ;                   (cond ((null? l) (values '() ntsf))
+  ;                         ((negate-test? (car l))
+  ;                          (loop (cdr l) (append ntsf (list (car l)))))
+  ;                         (else 
+  ;                          (let-values (((lwnt ntsf) (loop (cdr l) ntsf)))
+  ;                            (values (cons (car l) lwnt)
+  ;                                    ntsf)))))))
+  ; ;(write 'lwnt--)(pretty-print list-without-neg-tests)
+  ; ;(write 'neg-test)(pretty-print neg-tests)
+  ;     (letrec ((insert-negtest 
+  ;               (lambda (t-list neg-test)
+  ;                 (cond ((null? t-list)
+  ;                        '())
+  ;                       ((and (equal? (test-used-set (car t-list))
+  ;                                     (test-closest-shape-tst neg-test))
+  ;                             (or (null? (cdr t-list))
+  ;                                 (not (equal? (test-used-set (cadr t-list))
+  ;                                     (test-closest-shape-tst neg-test)))))
+  ;                        (cons (car t-list)
+  ;                              (cons neg-test
+  ;                                    (cdr t-list))))
+  ;                      ;  ((equal? (test-tst (car t-list))
+  ; ;                                (test-closest-shape-tst neg-test))
+  ; ;                        (cons (car t-list)
+  ; ;                              (cons neg-test
+  ; ;                                    (cdr t-list))))
+  ;                       (else 
+  ;                        (cons (car t-list) 
+  ;                              (insert-negtest (cdr t-list)
+  ;                                              neg-test)))))))
+  ;       (let loop2 ((t-list list-without-neg-tests)
+  ;                   (ntst neg-tests))
+  ;         ;(write 't-list)(pretty-print t-list)
+  ;         ;(write 'ntst ) (pretty-print ntst)
+  ;         ;(write 'insert) (pretty-print (insert-negtest t-list (car ntst)) )
+  ; (cond ((null? ntst) t-list)
+  ;       (else (insert-negtest t-list (car ntst))))))))
+  ;        ;  (cond ((null? ntst)
+  ; ;                t-list)
+  ; ;               (loop2 (insert-negtest t-list (car ntst)) 
+  ; ;                      (cdr ntst)))))))
+  
+  
+  
+  )
\ No newline at end of file
diff --git a/collects/mzlib/private/test-structure.scm b/collects/mzlib/private/test-structure.scm
new file mode 100644
index 0000000000..baa36e9c3c
--- /dev/null
+++ b/collects/mzlib/private/test-structure.scm
@@ -0,0 +1,116 @@
+;; This library is used by match.ss
+
+(module test-structure mzscheme
+  (provide (all-defined))
+  
+ 
+  
+  ;; This is the major data structure of the compiler.  It holds a
+  ;; great deal of information.  This structure represents a
+  ;; partially compiled match test.  This test is the basic unit of
+  ;; compilation.  The order of these tests greatly affects the size
+  ;; of the final compiled match expression.  it also affects the
+  ;; amount of time it takes to compile a match expression.
+  ;; the fields:
+  ;; tst - an S-exp of the test such as (equal exp 5).  It can also
+  ;;       be a name of a test that isn't meant to be compared to other
+  ;;       tests such as 'list-ddk-pat.
+  ;; comp - a function that takes a success-function, a fail-function and
+  ;;        a list of let bindings
+  ;; shape - a boolean that is true if the test tests the shape or type
+  ;;         of the data rather than the value of the data
+  ;; times-used - the number of clauses that use this test.  In reality
+  ;;              the number of clauses in which this test will eliminate
+  ;;              tests
+  ;; used-set - a list of numbers which designate the test-lists that
+  ;;            in which this test will eliminate tests
+  ;; bind-exp-stx - the syntax of the actual expression that is being tested
+  ;;                by this test ex. (syntax (car (cdr x)))
+  ;; bind-exp - the s-exp that is being tested by this test,
+  ;;            easily obtained by taking the syntax-object->datum
+  ;;            of bind-exp-stx
+  ;; bind-count - is the number of times in the bind-exp is found in the
+  ;;              test list in which this test is a member
+  (define-struct test (tst
+                       comp
+                       shape
+                       times-used
+                       used-set
+                       bind-exp-stx
+                       bind-exp
+                       bind-count
+                       times-used-neg
+                       used-set-neg
+                       closest-shape-tst
+                       equal-set)
+    (make-inspector))
+  
+  ;;!(function make-shape-test
+  ;;          (form (make-shape-test test exp comp) -> test-struct)
+  ;;          (contract (s-exp syntax (((list list -> syntax) 
+  ;;                                   (list list -> syntax) list) 
+  ;;                    -> 
+  ;;                    (list list -> syntax)))
+  ;;                    -> test))
+  ;; This function is essentially a constructor for a test struct.
+  ;; This constructor makes a "shape" test - test that tests for type
+  ;; rather than value.
+  ;; Arguments:
+  ;; test - s-exp of the test
+  ;; exp - the syntax of the expression being tested
+  ;; comp - the compilation function which will finish the compilation
+  ;;        after tests have been reordered
+  (define (make-shape-test test exp comp)
+    (make-test test comp #t 0 '() exp (syntax-object->datum exp) 1 0 '() #f '()))
+  
+  ;;!(function make-reg-test
+  ;;          (form (make-shape-test test exp comp) -> test-struct)
+  ;;          (contract (s-exp syntax (((list list -> syntax) 
+  ;;                                   (list list -> syntax) list) 
+  ;;                                   -> (list list -> syntax)))
+  ;;                    -> test))
+  ;; This function is essentially a constructor for a test struct.
+  ;; This constructor makes a "regular" test
+  ;; Arguments:
+  ;; test - s-exp of the test
+  ;; exp - the syntax of the expression being tested
+  ;; comp - the compilation function which will finish the compilation
+  ;;        after tests have been reordered
+  (define (make-reg-test test exp comp)
+    (make-test test comp #f 0 '() exp (syntax-object->datum exp) 1 0 '() #f '()))
+  
+  ;;!(function make-act-test
+  ;;          (form (make-shape-test test exp comp) -> test-struct)
+  ;;          (contract (s-exp syntax (((list list -> syntax) 
+  ;;                     (list list -> syntax) list) -> (list list -> syntax)))
+  ;;                    -> test))
+  ;; This function is essentially a constructor for a test struct.
+  ;; This constructor makes an "action" test - an action test is not
+  ;; neccessarily a test so to speak but rather an action that needs to be
+  ;; taken in order to verify that a certain expression matches a pattern.
+  ;; A good example of this is the binding of a pattern variable.
+  ;; Arguments:
+  ;; act-name -
+  ;; exp - the syntax of the expression being tested
+  ;; comp - the compilation function which will finish the compilation
+  ;;        after tests have been reordered
+  (define (make-act act-name exp comp)
+    (make-test act-name comp #f -1 '() exp (syntax-object->datum exp) 1 -1 '() #f '()))
+  
+  ;;!(function action-test?
+  ;;          (form (action-test? test) -> bool)
+  ;;          (contract  test -> bool))
+  ;; a predicate that returns true if a test is an action test
+  (define (action-test? test)
+    (= -1 (test-times-used test)))
+  
+  ;;!(function shape-test?
+  ;;          (form (shape-test? test) -> bool)
+  ;;          (contract  test -> bool))
+  ;; a predicate that returns true if a test is an shape test
+  (define (shape-test? test)
+    (test-shape test))
+  
+  (define (negate-test? test)
+    (test-closest-shape-tst test))
+  )
\ No newline at end of file
diff --git a/collects/mzlib/private/unitidmap.ss b/collects/mzlib/private/unitidmap.ss
new file mode 100644
index 0000000000..a0eb58bdcc
--- /dev/null
+++ b/collects/mzlib/private/unitidmap.ss
@@ -0,0 +1,36 @@
+
+(module unitidmap mzscheme
+
+  ;; Help Desk binding info:
+  (define (binding binder bound stx)
+    stx
+    ;; This 'bound-in-source is no longer needed
+    #;
+    (syntax-property
+     stx
+     'bound-in-source
+     (cons binder (syntax-local-introduce bound))))
+
+  (define (make-id-mapper unbox-stx the-binder)
+    (let ([set!-stx (datum->syntax-object unbox-stx 'set! #f)])
+      (make-set!-transformer
+       (lambda (sstx)
+	 (cond
+	  [(identifier? sstx) 
+	   (binding the-binder sstx
+		    unbox-stx)]
+	  [(module-identifier=? set!-stx (car (syntax-e sstx)))
+	   (raise-syntax-error
+	    'unit
+	    "cannot set! imported or exported variables"
+	    sstx)]
+	  [else
+	   (binding
+	    the-binder (car (syntax-e sstx))
+	    (datum->syntax-object
+	     set!-stx
+	     (cons unbox-stx (cdr (syntax-e sstx)))
+	     sstx))])))))
+
+  (provide make-id-mapper))
+
diff --git a/collects/mzlib/private/update-binding-counts.scm b/collects/mzlib/private/update-binding-counts.scm
new file mode 100644
index 0000000000..64f8a91265
--- /dev/null
+++ b/collects/mzlib/private/update-binding-counts.scm
@@ -0,0 +1,110 @@
+;; This library is used by match.ss
+(module update-binding-counts mzscheme
+  (provide update-binding-counts update-binding-count)
+  
+  (require "test-structure.scm")
+  (require-for-template "test-structure.scm")
+  (require (lib "etc.ss"))
+  
+  
+  ;;!(function update-binding-count
+  ;;          (form (update-binding-count render-list) -> list)
+  ;;          (contract list -> list))
+  ;; This function is normally executed for its side effect of
+  ;; setting the count for the number of times an expression used in
+  ;; a test if found in the rest of the list of tests.  This does
+  ;; not only count occurrances of the exp in other tests but
+  ;; whether the expression is also a sub expression in the other tests.
+  ;; Arg:
+  ;; render-list - a list of test structs
+  (define update-binding-count 
+    (lambda (render-list)
+      (define (inc-bind-count test)
+        (set-test-bind-count! test
+                              (add1 (test-bind-count test))))
+      (if (null? render-list)
+          '()
+          (let ((cur-test (car render-list)))
+            (update-binding-count
+             (let loop ((l (cdr render-list)))
+               (cond ((null? l) '())
+                     ((>= (test-bind-count cur-test) 2) l)
+                     ((and (valid-for-let-binding (test-bind-exp cur-test))
+                           (equal? (test-bind-exp cur-test)
+                                   (test-bind-exp (car l))))
+                      (begin
+                        (inc-bind-count cur-test)
+                        (loop (cdr l))))
+                     ((sub-exp-contains (test-bind-exp cur-test)
+                                        (test-bind-exp (car l)))
+                      (begin
+                        (inc-bind-count cur-test)
+                        (cons (car l) (loop (cdr l)))))
+                     (else (cons (car l) (loop (cdr l)))))))))))
+  
+  ;;!(function valid-for-let-binding
+  ;;          (form (valid-for-let-binding exp) -> bool)
+  ;;          (contract s-exp -> bool)
+  ;;          (example (valid-for-let-binding 'x) -> #f))
+  ;; This function is a predicate that determins if an expression
+  ;; should be considered for let binding.
+  (define valid-for-let-binding 
+    (lambda (exp)
+      ;; it must be a pair
+      ;; the index must be an integer
+      #;(match exp
+          (('vector-ref _ n) (number? n))
+          ((? pair?) #t)
+          (_ #f))
+      ;; the following is expanded fromt the above match expression
+      (let ((x exp))
+        (if (pair? x)
+            (if (and (equal? (car x) 'vector-ref)
+                     (pair? (cdr x))
+                     (pair? (cdr (cdr x)))
+                     (null? (cdr (cdr (cdr x)))))
+                ((lambda (n) (number? n)) (car (cdr (cdr x))))
+                ((lambda () #t)))
+            ((lambda () #f))))))
+  
+  ;;!(function sub-exp-contains
+  ;;          (form (sub-exp-contains exp1 exp2) -> bool)
+  ;;          (contract (s-exp s-exp) -> bool)
+  ;;          (example (sub-exp-contains '(cdr x) '(car (cdr x))) -> #t))
+  ;; This function returns true if exp2 contains a sub-expression
+  ;; that is equal? to exp1.  For this function to work the subexp
+  ;; must always be in the second position in a exp.  This is a
+  ;; convention that is followed throughout the match program.
+  (define sub-exp-contains 
+    (lambda (exp1 exp2)
+      #;(match exp2
+          (() #f)
+          ((_ sub-exp _ ...)
+           (if (and (valid-for-let-binding sub-exp)
+                    (equal? sub-exp exp1))
+               #t
+               (sub-exp-contains exp1 sub-exp)))
+          (_ #f))
+      ;; The following was expanded from the above match expression
+      (let ((x exp2))
+        (if (null? x)
+            ((lambda () #f))
+            (if (and (pair? x) (pair? (cdr x)) (list? (cdr (cdr x))))
+                ((lambda (sub-exp)
+                   (if (and (pair? sub-exp)
+                            (equal? sub-exp exp1))
+                       #t
+                       (sub-exp-contains exp1 sub-exp)))
+                 (car (cdr x)))
+                ((lambda () #f)))))))
+  
+  ;;!(function update-binding-counts
+  ;;          (form (update-binding-counts render-lists) -> list)
+  ;;          (contract list -> list))
+  ;; This function calls update-binding-count for each render list
+  ;; in the list of render lists.  This is used mainly for its side
+  ;; affects.  The result is of no consequence.
+  (define update-binding-counts 
+    (lambda (render-lists)
+      (map (compose update-binding-count car) render-lists)))
+  )
diff --git a/collects/mzlib/private/update-counts.scm b/collects/mzlib/private/update-counts.scm
new file mode 100644
index 0000000000..7a6a64ce55
--- /dev/null
+++ b/collects/mzlib/private/update-counts.scm
@@ -0,0 +1,187 @@
+;; This library is used by match.ss
+;; This requires the test data structure.
+
+(module update-counts mzscheme
+  (provide update-counts)
+  
+  (require "test-structure.scm"
+	   "match-helper.ss")
+  
+  #;(require-for-template "test-structure.scm"
+	   "match-helper.ss")
+  
+  ;;!(function test-filter
+  ;;          (form (test-filter test-list) -> test-list)
+  ;;          (contract list -> list))
+  ;; This function filters out tests that do not need to be to have
+  ;; their counts updated for reordering purposes.  These are the
+  ;; more complex patterns such as or-patterns or ddk patterns.
+  (define test-filter
+    (lambda (tlist)
+      (if (null? tlist)
+          '()
+          (if (= -1 (test-times-used (car tlist)))
+              (test-filter (cdr tlist))
+              (cons (car tlist)
+                    (test-filter (cdr tlist)))))))
+  
+  
+  ;; !(function inverse-in
+  ;;            (form (inverse-in test test-list) -> bool)
+  ;;            (contract (s-exp list) -> bool))
+  ;; This function checks to see if any of the members of the test-list
+  ;; would be eliminated by the function if the test was in the test so far 
+  ;; list.  This is the opposite of what the in function does.
+  (define inverse-in
+    (lambda (test test-list)
+      (or (pos-inverse-in test test-list)
+          (neg-inverse-in test test-list))))
+  
+  (define pos-inverse-in
+    (lambda (test test-list)
+      (let ((test-with-implied (cons test (implied test))))
+        (ormap (lambda (t) (in t test-with-implied))
+               test-list)
+        )))
+  
+  (define neg-inverse-in
+    (lambda (test test-list)
+      (let ((test-with-implied (cons test (implied test))))
+        (ormap (lambda (t) (in `(not ,t) test-with-implied))
+               test-list)
+        )))
+  
+  (define logical-member
+    (lambda (item lst)
+      (ormap (lambda (cur)
+               (logical-equal? item cur))
+             lst)))
+  
+  (define logical-equal?  
+    (lambda x
+      (if (pair? x)
+          (let ((exp8163 (cdr x)))
+            (if (and (pair? exp8163) (null? (cdr exp8163)))
+                (if (equal? (car exp8163) (car x))
+                    ((lambda (a) #t) (car x))
+                    (let ((exp8164 (car x)))
+                      (if (and (pair? exp8164) (equal? (car exp8164) 'list?))
+                          (let ((exp8165 (cdr exp8164)))
+                            (if (and (pair? exp8165) (null? (cdr exp8165)))
+                                (let ((exp8166 (car exp8163)))
+                                  (if (and (pair? exp8166) (equal? (car exp8166) 'null?))
+                                      (let ((exp8167 (cdr exp8166)))
+                                        (if (and (pair? exp8167)
+                                                 (null? (cdr exp8167))
+                                                 (equal? (car exp8167) (car exp8165)))
+                                            ((lambda (x) #t) (car exp8165))
+                                            ((lambda (else) #f) x)))
+                                      ((lambda (else) #f) x)))
+                                ((lambda (else) #f) x)))
+                          ((lambda (else) #f) x))))
+                ((lambda (else) #f) x)))
+          ((lambda (else) #f) x))))
+  
+  (define truncate-list 
+    (lambda (pos used-set-neg)
+      (cond ((null? used-set-neg)
+             '())
+            ((>= pos (car used-set-neg))
+             (list pos))
+            (else
+             (cons (car used-set-neg)
+                   (truncate-list pos (cdr used-set-neg)))))))
+  
+  (define truncate-list-neg 
+    (lambda (pos used-set-neg)
+      (cond ((null? used-set-neg)
+             '())
+            ((>= pos (car used-set-neg))
+             '())
+            (else
+             (cons (car used-set-neg)
+                   (truncate-list-neg pos (cdr used-set-neg)))))))
+  
+  
+  
+  ;;!(function update-count
+  ;;          (form (update-count test tests-rest pos) -> void)
+  ;;          (contract (test-struct list integer) -> void))
+  ;; This function updates the test-times-used and test-used-set
+  ;; fields of the test structs.  These fields are essential to
+  ;; determining the order of the tests.
+  (define update-count 
+    (lambda (test tests-rest pos mem-table)
+      (let loop ((l tests-rest)
+                 (p (add1 pos)))
+        (if (null? l)
+            (begin
+              ;; memoize
+              (hash-table-get mem-table (test-tst test) 
+                              (lambda () 
+                                (hash-table-put! 
+                                 mem-table 
+                                 (test-tst test) (list (test-used-set test)
+                                                       (test-used-set-neg test)))))
+              )
+            (let ((entry-pair 
+                   (hash-table-get mem-table (test-tst test)
+                                   (lambda ()
+                                     (when (
+                                            ;member
+                                            logical-member
+                                            ;inverse-in
+                                            (test-tst test) (car l))
+                                       (set-test-times-used! test (add1 (test-times-used test)))
+                                       (set-test-used-set! test (cons p (test-used-set test)))
+                                       (set-test-equal-set! test (cons p (test-equal-set test)))
+                                       )
+                                     (when (neg-inverse-in (test-tst test) (car l))
+                                       (set-test-used-set-neg! test (cons p (test-used-set-neg test))))
+                                     (loop (cdr l) (add1 p))
+                                     ))))
+              (when (and (list? entry-pair) (not (null? entry-pair)))
+                (let ((trun-used (truncate-list pos (car entry-pair))))
+                  (set-test-used-set! test trun-used)
+                  (set-test-equal-set! test trun-used)
+                  (set-test-times-used! test (length trun-used))
+                  (set-test-used-set-neg! test (truncate-list-neg pos (cadr entry-pair)))))
+              )))))
+  
+  ;;!(function update-counts
+  ;;          (form (update-counts render-list) -> void)
+  ;;          (contract list -> void))
+  ;; This function essentially calls update-count on every test in
+  ;; all of the test lists.
+  (define update-counts 
+    (lambda (render-list)
+      (let* ((mem-table (make-hash-table 'equal))
+             (test-master-list (map test-filter 
+                                    (map car render-list)))
+             (test-so-far-lists ;; horrible name
+              (map
+               (lambda (tl)
+                 (let ((f (map test-tst (test-filter tl))))
+                   f))
+               test-master-list)))
+        (let loop ((tml test-master-list)
+                   (tsf test-so-far-lists)
+                   (pos 1))
+          (if (null? tml)
+              '()
+              (begin
+                (map (lambda (t)
+                       (set-test-times-used! t 1)
+                       (set-test-used-set! 
+                        t 
+                        (cons pos (test-used-set t)))
+                       (set-test-equal-set! 
+                        t 
+                        (cons pos (test-equal-set t)))
+                       (update-count t (cdr tsf) pos mem-table))
+                     (car tml))
+                (loop (cdr tml) (cdr tsf) (add1 pos))))))))
+  )
+
+
+
diff --git a/collects/mzlib/process.ss b/collects/mzlib/process.ss
new file mode 100644
index 0000000000..cf73edd9d5
--- /dev/null
+++ b/collects/mzlib/process.ss
@@ -0,0 +1,196 @@
+
+(module process mzscheme
+  (provide process
+	   process*
+	   process/ports
+	   process*/ports
+	   system
+	   system*
+	   system/exit-code
+	   system*/exit-code)
+
+  (require (lib "port.ss"))
+
+  ;; Helpers: ----------------------------------------
+
+  (define (shell-path/args who argstr)
+    (case (system-type)
+      ((unix macosx) (append '("/bin/sh" "-c") (list argstr)))
+      ((windows) (let ([cmd
+			(let ([d (find-system-path 'sys-dir)])
+			  (let ([cmd (build-path d "cmd.exe")])
+			    (if (file-exists? cmd)
+				cmd
+				(let ([cmd (build-path d "command.com")])
+				  (if (file-exists? cmd)
+				      cmd
+				      ;; One last try: up a dir
+				      (build-path d 'up "command.com"))))))])
+		   (list cmd
+			 'exact
+			 (format "~a /c ~a" (path->string cmd) argstr))))
+      (else (raise-mismatch-error 
+	     who
+	     (format "~a: don't know what shell to use for platform: " who)
+	     (system-type)))))
+
+  (define (if-stream-out p)
+    (if (or (not p) (file-stream-port? p))
+	p
+	(if (output-port? p)
+	    #f
+	    (raise-type-error
+	     'subprocess
+	     "output port"
+	     p))))
+
+  (define (if-stream-in p)
+    (if (or (not p) (file-stream-port? p))
+	p
+	(if (input-port? p)
+	    #f
+	    (raise-type-error
+	     'subprocess
+	     "input port"
+	     p))))
+
+  (define (streamify-in cin in get-thread? ready-for-break)
+    (if (and cin (not (file-stream-port? cin)))
+	(let ([t (thread (lambda () 
+			   (dynamic-wind
+			       void
+			       (lambda ()
+				 (with-handlers ([exn:break? void])
+				   (ready-for-break #t)
+				   (copy-port cin in)
+				   (ready-for-break #f)))
+			       (lambda () (close-output-port in)))
+			   (ready-for-break #t)))])
+	  (and get-thread? t))
+	in))
+
+  (define (streamify-out cout out get-thread?)
+    (if (and cout (not (file-stream-port? cout)))
+	(let ([t (thread (lambda () (copy-port out cout)))])
+	  (and get-thread? t))
+	out))
+
+  ;; Old-style functions: ----------------------------------------
+
+  (define (process*/ports cout cin cerr exe . args)
+    (let-values ([(subp out in err) (apply subprocess 
+					   (if-stream-out cout)
+					   (if-stream-in cin)
+					   (if-stream-out cerr)
+					   exe args)]
+		 [(it-ready) (make-semaphore)])
+      (let ([so (streamify-out cout out #t)]
+	    [si (streamify-in cin in #t (lambda (ok?)
+					  (if ok?
+					      (semaphore-post it-ready)
+					      (semaphore-wait it-ready))))]
+	    [se (streamify-out cerr err #t)]
+	    [aport (lambda (x)
+		     (and (port? x) x))])
+	(when (thread? si)
+	  ;; Wait for process to end, then stop copying input:
+	  (thread (lambda ()
+		    (sync subp si)
+		    (semaphore-wait it-ready)
+		    (break-thread si))))
+	(list (aport so)
+	      (aport si)
+	      (subprocess-pid subp)
+	      (aport se)
+	      (letrec ((control
+			(lambda (m)
+			  (case m
+			    ((status) (let ((s (subprocess-status subp)))
+					(cond ((not (integer? s)) s)
+					      ((zero? s) 'done-ok)
+					      (else 'done-error))))
+			    ((exit-code) (let ((s (subprocess-status subp)))
+					   (and (integer? s) s)))
+			    ((wait) 
+			     (subprocess-wait subp)
+			     (let ([twait (lambda (t)
+					    (when (thread? t)
+					      (thread-wait t)))])
+			       (twait so)
+			       (twait si)
+			       (twait se)))
+			    ((interrupt) (subprocess-kill subp #f))
+			    ((kill) (subprocess-kill subp #t))
+			    (else
+			     (raise-type-error 'control-process
+					       "'status, 'exit-code, 'wait, 'interrupt, or 'kill" m))))))
+		control)))))
+
+  (define (process/ports out in err str)
+    (apply process*/ports out in err (shell-path/args "process/ports" str)))
+
+  (define (process* exe . args)
+    (apply process*/ports #f #f #f exe args))
+
+  (define (process str)
+    (apply process* (shell-path/args "process" str)))
+
+  ;; Note: these always use current ports
+  (define (system*/exit-code exe . args)
+    (if (eq? (system-type) 'macos)
+	(if (null? args)
+          (raise-mismatch-error
+           'system*/exit-code "command-line arguments not supported for MacOS" args)
+	  (subprocess #f #f #f exe))
+	(let ([cout (current-output-port)]
+	      [cin (current-input-port)]
+	      [cerr (current-error-port)]
+	      [it-ready (make-semaphore)])
+	  (let-values ([(subp out in err)
+			(apply
+			 subprocess
+			 (if-stream-out cout)
+			 (if-stream-in cin)
+			 (if-stream-out cerr)
+			 exe args)])
+	    (let ([ot (streamify-out cout out #t)]
+		  [it (streamify-in cin in #t (lambda (ok?)
+						(if ok?
+						    (semaphore-post it-ready)
+						    (semaphore-wait it-ready))))]
+		  [et (streamify-out cerr err #t)])
+	      (subprocess-wait subp)
+	      (when it
+		;; stop piping output to subprocess
+		(semaphore-wait it-ready)
+		(break-thread it))
+	      ;; wait for other pipes to run dry:
+	      (when (thread? ot)
+		(thread-wait ot))
+	      (when (thread? et)
+		(thread-wait et))
+	      (when err
+		(close-input-port err))
+	      (when out
+		(close-input-port out))
+	      (when in
+		(close-output-port in)))
+	    (subprocess-status subp)))))
+
+  (define (system* exe . args)
+    (if (eq? (system-type) 'macos)
+	(if (null? args)
+          (raise-mismatch-error
+           'system* "command-line arguments not supported for MacOS" args)
+	  (subprocess #f #f #f exe))
+	(zero? (apply system*/exit-code exe args))))
+
+  (define (system str)
+    (if (eq? (system-type) 'macos)
+	(subprocess #f #f #f "by-id" str)
+	(apply system* (shell-path/args "system" str))))
+
+  (define (system/exit-code str)
+    (if (eq? (system-type) 'macos)
+	(subprocess #f #f #f "by-id" str)
+	(apply system*/exit-code (shell-path/args "system" str)))))
diff --git a/collects/mzlib/restart.ss b/collects/mzlib/restart.ss
new file mode 100644
index 0000000000..dda744d5f6
--- /dev/null
+++ b/collects/mzlib/restart.ss
@@ -0,0 +1,183 @@
+
+(module restart mzscheme
+  (require "cmdline.ss")
+
+  (provide restart-mzscheme)
+
+  (define (restart-mzscheme init-argv adjust-flag-table argv init-namespace)
+    (let* ([result #t]
+	   [args #f]
+	   [mute-banner? #f]
+	   [no-rep? #f]
+	   [no-coll-paths? #f]
+	   [no-init-file? #f]
+           [no-define-argv? #f]
+	   [case-sensitive? #f]
+	   [allow-set!-undefined? #t]
+	   [print-error
+	    (lambda (e)
+	      (if (exn? e)
+		  (fprintf (current-error-port) "~a~n" (exn-message e))
+		  (fprintf (current-error-port) "Exception in init file: ~e~n" e)))]
+           [beginize (lambda (l)
+                       (string-append
+                        "(begin "
+                        (apply string-append l)
+                        ")"))]
+           [script (lambda (flags proc like)
+                     `[,flags
+                       ,(lambda (f file) 
+                          (begin0
+                            (format proc file)
+                            (set! mute-banner? #t)
+                            (set! no-rep? #t)))
+                       (,(format "Same as -~amv-" like) "file")])]
+	   [table
+	    `([multi
+	       [("-e" "--eval")
+		,(lambda (f expr) expr)
+		("Evaluates <expr>" "expr")]
+	       [("-f" "--load")
+		,(lambda (f file) (format "(load ~s)" file))
+		("Loads <file>" "file")]
+	       [("-d" "--load-cd")
+		,(lambda (f file) (format "(load/cd ~s)" file))
+		("Load/cds <file>" "file")]
+	       [("-t" "--require")
+		,(lambda (f file) (format "(require (file ~s))" file))
+		("Requires <file>" "file")]
+	       [("-F" "--Load")
+		,(lambda (f . files) (beginize
+                                      (map (lambda (file)
+                                             (format "(load ~s)" file))
+                                           files)))
+		("Loads all <file>s" "file")]
+	       [("-D" "--Load-cd")
+		,(lambda (f . files) (beginize
+                                      (map (lambda (file)
+                                             (format "(load/cd ~s)" file))
+                                           files)))
+		("Load/cds all <file>s" "file")]
+	       [("-T" "--Require")
+		,(lambda (f . files) (beginize
+                                      (map (lambda (file)
+                                             (format "(require (file ~s))" file))
+                                           files)))
+		("Requires all <file>s" "file")]
+	       [("-l" "--mzlib")
+		,(lambda (f file) (format "(require (lib ~s))" file))
+		("Imports library <file>" "file")]
+	       [("-L")
+		,(lambda (f file collection) (format "(require (lib ~s ~s))" file collection))
+		("Imports library <file> in <collection>" "file" "collection")]
+	       [("-M")
+		,(lambda (f collection) (format "(require (lib ~s ~s))"
+                                                (format "~a.ss" collection)
+                                                collection))
+		("Imports library <collection>.ss in <collection>" "collection")]]
+              [final
+               ,(script '("-r" "--script") "(load ~s)" "f")
+               ,(script '("-u" "--require-script") "(require (file ~s))"  "t")
+	       ,(script '("-i" "--script-cd") "(load/cd ~s)" "d")]
+              [multi
+	       [("-w" "--awk")
+		,(lambda (f) "(require-library \"awk.ss\")")
+		("Same as -l awk.ss")]
+	       [("-k")
+		,(lambda (f n m) (error 'mzscheme "The -k flag is not supported in this mode"))
+		("Load executable-embedded code from file offset <n> to <m>" "n" "m")]
+               [("-C" "--main")
+                ,(lambda (f) (lambda ()
+                               (when result
+                                 ((eval 'main) args))))
+                ("Calls `main' with a list of argument strings, if no prior errors")]
+	       [("-x" "--no-init-path")
+		,(lambda (f) (set! no-coll-paths? #t))
+		("Don't set current-library-collection-paths")]
+	       [("-q" "--no-init-file")
+		,(lambda (f) (set! no-init-file? #t))
+		("Don't load \"~/.mzschemerc\" or \"mzscheme.rc\"")]
+               [("-A")
+                ,(lambda (f) (set! no-define-argv? #t))
+		("Don't define `argv' or `program'")]
+	       [("-g" "--case-sens")
+		,(lambda (f) (set! case-sensitive? #t))
+		("Identifiers and symbols are initially case-sensitive")]
+	       [("-s" "--set-undef")
+		,(lambda (f) (set! allow-set!-undefined? #t))
+		("Set! works on undefined identifiers")]
+	       [("-m" "--mute-banner")
+		,(lambda (f) (set! mute-banner? #t))
+		("Suppresses the startup banner text")]
+	       [("-v" "--version")
+		,(lambda (f) (set! no-rep? #t))
+		("Suppresses the read-eval-print loop")]
+	       [("-b" "--binary")
+		,(lambda (f) (error 'mzscheme "The -b flag is not supported in this mode"))
+		("Read stdin and write stdout/stderr in binary mode")]
+	       [("--restore")
+		,(lambda (f) (error 'mzscheme "The --restore flag is not supported in this mode"))
+		("Not supported")]])])
+      (parse-command-line
+       "mzscheme"
+       init-argv
+       table
+       void
+       '("ignored"))
+      (set! args #f)
+      (parse-command-line
+       "mzscheme"
+       argv
+       (adjust-flag-table table)
+       (lambda (exprs . rest)
+	 (unless (null? rest)
+	   (set! args rest))
+	 ;(when args (set! rest args))
+	 (let ([n (make-namespace)]
+	       [argv (if args (list->vector args) (vector))])
+	   (parameterize ([current-command-line-arguments argv])
+	     (thread-wait
+	      (thread
+	       (lambda ()
+		 (current-namespace n)
+		 (namespace-transformer-require 'mzscheme)
+		 (let ([program (find-system-path 'exec-file)])
+		   (read-case-sensitive case-sensitive?)
+		   (compile-allow-set!-undefined allow-set!-undefined?)
+		   
+		   (unless mute-banner? (display (banner)))
+		   
+		   (unless no-define-argv?
+		     (eval `(define-values (argv) (quote ,argv)))
+		     (eval `(define-values (program) (quote ,program))))
+		   
+		   (find-library-collection-paths))
+		 
+		 (init-namespace)
+		 
+		 (unless no-init-file?
+		   (let ([f (find-system-path 'init-file)])
+		     (when (file-exists? f)
+		       (with-handlers ([void print-error])
+			 (load f)))))
+		 
+		 (let/ec k
+		   (exit-handler
+		    (lambda (status)
+		      (set! result status)
+		      (k #f)))
+		   (let/ec escape
+		     (for-each
+		      (lambda (e)
+			(with-handlers ([void (lambda (e) 
+						(print-error e) 
+						(set! result #f)
+						(escape #f))])
+			  (if (string? e)
+			      (eval (read (open-input-string e)))
+			      (e))))
+		      exprs))
+		   (unless no-rep? 
+		     (read-eval-print-loop)))))))))
+       `("arg"))
+      result)))
diff --git a/collects/mzlib/sendevent.ss b/collects/mzlib/sendevent.ss
new file mode 100644
index 0000000000..15c5fc65c6
--- /dev/null
+++ b/collects/mzlib/sendevent.ss
@@ -0,0 +1,16 @@
+
+(module sendevent mzscheme 
+  (require "etc.ss")
+  (provide send-event)
+  
+  (define send-event 
+    (opt-lambda (who class msg [data (void)] [args null])
+      (let ([send-event (with-handlers ([exn:fail? (lambda (x) #f)])
+			  (dynamic-require '(lib "mred.ss" "mred") 
+					   'send-event))])
+	(if send-event
+	    (send-event who class msg data args)
+	    (raise
+	     (make-exn:fail:unsupported
+	      "send-event: only supported in MrEd"
+	      (current-continuation-marks))))))))
diff --git a/collects/mzlib/serialize.ss b/collects/mzlib/serialize.ss
new file mode 100644
index 0000000000..12efa78435
--- /dev/null
+++ b/collects/mzlib/serialize.ss
@@ -0,0 +1,850 @@
+(module serialize mzscheme
+  (require-for-syntax (lib "struct.ss" "syntax"))
+  (require (lib "moddep.ss" "syntax")
+	   (lib "etc.ss")
+	   (lib "list.ss")
+	   "private/serialize-structs.ss")
+
+  (provide define-serializable-struct
+	   define-serializable-struct/versions
+
+	   ;; For implementors of other `define-struct'-like forms:
+	   prop:serializable
+	   make-serialize-info
+	   make-deserialize-info
+
+	   ;; Checks whether a value is seriliazable:
+	   serializable?
+
+	   ;; The two main routines:
+	   serialize
+	   deserialize)
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; define-serializable-struct
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  ;; generate-struct-declaration wants a function to generate the actual
+  ;;  call to `make-struct-type'. This is where we insert the serializable property.
+  (define-for-syntax (make-make-make-struct-type inspector+deserializer-stx)
+    (let-values ([(inspector-stx deserialize-id)
+		  (apply values (syntax->list inspector+deserializer-stx))])
+      (lambda (orig-stx name-stx defined-name-stxes super-info)
+	(when super-info
+	  (unless (andmap values (list-ref super-info 3))
+	    (raise-syntax-error
+	     #f
+	     "not all fields are known for parent struct type"
+	     orig-stx
+	     (syntax-case orig-stx ()
+	       [(_ (__ super-id) . rest) #'super-id]))))
+	(let ([num-fields (/ (- (length defined-name-stxes) 3) 2)])
+	  #`(letrec-values ([(type maker pred access mutate)
+			     (make-struct-type '#,name-stx 
+					       #,(and super-info (list-ref super-info 0))
+					       #,num-fields
+					       0 #f
+					       (list
+						;; --- The prop:serializable property means this is serializable
+						(cons
+						 prop:serializable
+						 (make-serialize-info
+						  ;; The struct-to-vector function: --------------------
+						  (lambda (v)
+						    (vector
+						     #,@(if super-info
+							    (reverse
+							     (map (lambda (sel)
+								    #`(#,sel v))
+								  (list-ref super-info 3)))
+							    null)
+						     #,@(let loop ([n num-fields][r null])
+							  (if (zero? n)
+							      r
+							      (loop (sub1 n)
+								    (cons
+								     #`(access v #,(sub1 n))
+								     r))))))
+						  ;; The serializer id: --------------------
+						  (quote-syntax #,deserialize-id)
+						  ;; Alternate --- does the same thing, due to the way
+						  ;;  this macro is set up:
+						  #;
+						  (let ([b (identifier-binding (quote-syntax #,deserialize-id))])
+						    (if (list? b)
+							(cons '#,deserialize-id (caddr b))
+							'#,deserialize-id))
+						  ;; Can handle cycles? --------------------
+						  ;;  Yes, as long as we have mutators for the
+						  ;;  superclass.
+						  #,(or (not super-info)
+							(andmap values (list-ref super-info 4)))
+						  ;; Directory for last-ditch resolution --------------------
+						  (or (current-load-relative-directory) 
+						      (current-directory))))
+						;; --- The prop:internal-deserialize property just communicates
+						;;     information to the deserialize binding (because it's more
+						;;     convenient to generate the deserialize info here)
+						(cons
+						 prop:internal-deserialize
+						 (list
+						  ;; The maker-getter: --------------------
+						  (lambda () maker)
+						  ;; The shell function: --------------------
+						  ;;  Returns an shell object plus
+						  ;;  a function to update the shell (used for
+						  ;;  building cycles): 
+						  (let ([super-sets
+							 (list #,@(if super-info
+								      (list-ref super-info 4)
+								      null))])
+						    (lambda ()
+						      (let ([s0
+							     (#,(list-ref defined-name-stxes 1)
+							      #,@(append
+								  (if super-info
+								      (map (lambda (x) #f)
+									   (list-ref super-info 3))
+								      null)
+								  (vector->list
+								   (make-vector num-fields #f))))])
+							(values
+							 s0
+							 (lambda (s)
+							   #,@(if super-info
+								  (map (lambda (set get)
+									 #`(#,set s0 (#,get s)))
+								       (list-ref super-info 4)
+								       (list-ref super-info 3))
+								  null)
+							   #,@(let loop ([n num-fields])
+								(if (zero? n)
+								    null
+								    (let ([n (sub1 n)])
+								      (cons #`(mutate s0 #,n (access s #,n))
+									    (loop n)))))
+							   (void)))))))))
+					       #,inspector-stx)])
+	      (values type maker pred access mutate))))))
+    
+  (define-syntaxes (define-serializable-struct define-serializable-struct/versions)
+    (let ()
+      (define expected-ids
+	"expected an identifier or parenthesized sequence of struct identifier and parent identifier")
+      (define expected-fields
+	"expected parenthesized sequence of field identifiers")
+      (define expected-version
+	"expected a version (literal, exact, non-negative integer)")
+      (define (after-name id/sup-stx)
+	(if (identifier? id/sup-stx)
+	    " after struct identifier"
+	    " after sequence of struct and parent identifiers"))
+      (define version-conflicts
+	"version number for other-version deserializer conflicts with")
+      
+      (define (context-check stx)
+	(unless (memq (syntax-local-context) '(top-level module))
+	  (raise-syntax-error
+	   #f
+	   "allowed only at the top level or within a module top level"
+	   stx)))
+
+      (define (ok-version? v)
+	(and (number? v)
+	     (integer? v)
+	     (v . >= . 0)
+	     (exact? v)))
+
+      ;; ------------------------------
+      ;;  Main parsing
+      
+      ;; Check high-level syntax, then dispatch to parsing parts
+      (define main
+	(lambda (stx)
+	  (syntax-case stx ()
+	    [(_ id/sup fields)
+	     (parse stx #'id/sup #'0 #'fields #'() #'(current-inspector))]
+	    [(_ id/sup fields inspector-expr)
+	     (parse stx #'id/sup #'0 #'fields #'() #'inspector-expr)]
+	    [(_ id/sup)
+	     (parse stx #'id/sup #'0 #f #f #f)]
+	    [(_)
+	     (raise-syntax-error
+	      #f
+	      expected-ids
+	      stx)])))
+
+      ;; Check high-level syntax with versions, then dispatch to parsing parts
+      (define main/versions
+	(lambda (stx)
+	  (syntax-case stx ()
+	    [(_ id/sup version-num fields other-versions)
+	     (parse stx #'id/sup #'version-num #'fields #'other-versions #'(current-inspector))]
+	    [(_ id/sup version-num fields other-versions inspector-expr)
+	     (parse stx #'id/sup #'version-num #'fields #'other-versions #'inspector-expr)]
+	    [(_ id/sup)
+	     (parse stx #'id/sup #f #f #f #f)]
+	    [(_ id/sup version-num)
+	     (parse stx #'id/sup #'version-num #f #f #f)]
+	    [(_ id/sup version-num fields)
+	     (parse stx #'id/sup #'version-num #'fields #f #f)]
+	    [(_)
+	     (raise-syntax-error
+	      #f
+	      expected-ids
+	      stx)])))
+      
+      ;; ------------------------------
+      ;;  Part parsing
+
+      ;; Parse parts, then dispatch to result generation
+      (define (parse stx id/sup-stx version-num-stx fields-stx other-versions-stx inspector-stx)
+	;; First, check id or id+super:
+	(let-values ([(id super-id) (parse-id+super stx id/sup-stx)])
+	  (let* ([version-num (parse-version stx id/sup-stx version-num-stx)]
+		 [field-ids (parse-fields stx id/sup-stx version-num-stx fields-stx)]
+		 [other-versions (parse-other-versions stx version-num other-versions-stx)])
+	    ;; Input syntax is ok! Generate the results
+	    #`(begin
+		#,(generate-main-result stx id super-id field-ids inspector-stx version-num)
+		#,@(map (lambda (other-version)
+			  (generate-other-result stx id other-version))
+			other-versions)))))
+
+      ;; id+super
+      (define (parse-id+super stx id/sup-stx)
+	(syntax-case id/sup-stx ()
+	  [id
+	   (identifier? #'id)
+	   (values #'id #f)]
+	  [(id sup-id)
+	   (and (identifier? #'id)
+		(identifier? #'sup-id))
+	   (values #'id #'sup-id)]
+	  [(id other)
+	   (identifier? #'id)
+	   (raise-syntax-error
+	    #f
+	    "expected identifier for parent struct type"
+	    stx
+	    #'other)]
+	  [else
+	   (raise-syntax-error
+	    #f
+	    expected-ids
+	    stx
+	    id/sup-stx)]))
+
+      ;; version
+      (define (parse-version stx id/sup-stx version-num-stx)
+	;; Check version; #f means no version in original expression
+	(unless version-num-stx
+	  (raise-syntax-error
+	   #f
+	   (string-append expected-version
+			  (after-name id/sup-stx))
+	   stx))
+	(let ([v (syntax-e version-num-stx)])
+	  (unless (ok-version? v)
+	    (raise-syntax-error
+	     #f
+	     (string-append expected-version
+			    (after-name id/sup-stx))
+	     stx
+	     version-num-stx))
+	  v))
+
+      ;; fields
+      (define (parse-fields stx id/sup-stx version-num-stx fields-stx)
+	;; Now check fields; #f means no fields in oirignal expression
+	(unless fields-stx
+	  (raise-syntax-error
+	   #f
+	   (string-append expected-fields
+			  (cond
+			   [version-num-stx
+			    " after version number"]
+			   [else (after-name id/sup-stx)]))
+	   stx))
+	(let ([field-ids (syntax-case fields-stx ()
+			   [(field ...)
+			    (let ([field-ids (syntax->list #'(field ...))])
+			      (for-each (lambda (id)
+					  (unless (identifier? id)
+					      (raise-syntax-error
+					       #f
+					       "expected a field identifier"
+					       stx
+					       id)))
+					field-ids)
+			      field-ids)]
+			   [else
+			    (raise-syntax-error
+			     #f
+			     expected-fields
+			     stx
+			     fields-stx)])])
+	  ;; Fields are all identifiers, so check for distinct fields
+	  (let ([dup (check-duplicate-identifier field-ids)])
+	    (when dup
+	      (raise-syntax-error
+	       #f
+	       "duplicate field identifier"
+	       stx
+	       dup)))
+	  field-ids))
+
+      ;; Other-version deserializers
+      (define (parse-other-versions stx main-version-num other-versions-stx)
+	(when (or (not other-versions-stx)
+		  (not (syntax->list other-versions-stx)))
+	  (raise-syntax-error
+	   #f
+	   "expected a parenthesized sequence of other-version deserializers after field sequence"
+	   stx
+	   other-versions-stx))
+	(let* ([ht (make-hash-table 'equal)]
+	       [other-versions
+		(map (lambda (other-stx)
+		       (syntax-case other-stx ()
+			 [(version-num maker-expr cycle-maker-expr)
+			  (let ([v (syntax-e #'version-num)])
+			    (unless (ok-version? v)
+			      (raise-syntax-error
+			       #f
+			       (string-append expected-version
+					      " for other-version deserializer")
+			       stx
+			       #'version-num))
+			    (when (= v main-version-num)
+			      (raise-syntax-error
+			       #f
+			       (string-append version-conflicts " the main version")
+			       stx
+			       other-stx))
+			    (when (hash-table-get ht v (lambda () #f))
+			      (raise-syntax-error
+			       #f
+			       (string-append version-conflicts " another deserializer")
+			       stx
+			       other-stx))
+			    (hash-table-put! ht v #t)
+			    (list v #'maker-expr #'cycle-maker-expr))]
+			 [else
+			  (raise-syntax-error
+			   #f
+			   "expected a deserializer for another version: version number, constructor, and cycle constructor"
+			   stx
+			   other-stx)]))
+		     (syntax->list other-versions-stx))])
+	  other-versions))
+
+      ;; ------------------------------
+      ;;  Generate result
+
+      ;; Generate the result expression. This is complicated
+      ;; by the fact that super-id information may or may not be
+      ;; immediately available, so we also need continue-define-...
+      (define (generate-main-result stx id super-id field-ids inspector-stx version-num)
+	(with-syntax ([deserializer-id (make-deserialize-name id version-num)]
+		      [struct-type-id (datum->syntax-object
+				       id
+				       (string->symbol
+					(format "struct:~a" (syntax-e id)))
+				       id)]
+		      [inspector-expr inspector-stx])
+	  #`(begin
+	      #,(generate-struct-declaration stx
+					     id super-id field-ids 
+					     (syntax-local-context)
+					     (make-make-make-struct-type #'(inspector-expr deserializer-id))
+					     #'continue-define-serializable-struct 
+					     #'(inspector-expr deserializer-id))
+	      (define deserializer-id (let ([l (internal-deserialize-info struct-type-id)])
+					(make-deserialize-info
+					 ((car l))
+					 (cadr l))))
+	      #,@(make-deserialize-provide stx #'deserializer-id))))
+
+      (define (generate-other-result stx id other-version)
+	(with-syntax ([deserializer-id (make-deserialize-name id (car other-version))])
+	  #`(begin
+	      (define deserializer-id (make-deserialize-info #,(cadr other-version)
+							     #,(caddr other-version)))
+	      #,@(make-deserialize-provide stx #'deserializer-id))))
+
+      (define (make-deserialize-name id version-num)
+	(datum->syntax-object
+	 id
+	 (string->symbol
+	  (format "deserialize-info:~a-v~a" 
+		  (syntax-e id) 
+		  version-num))
+	 id))
+
+      (define (make-deserialize-provide stx deserializer-id-stx)
+	(if (eq? 'top-level (syntax-local-context))
+	    ;; Top level; in case deserializer-id-stx is macro-introduced,
+	    ;;  explicitly use namespace-set-variable-value!
+	    (list (quasisyntax/loc stx
+		    (namespace-set-variable-value! '#,deserializer-id-stx 
+						   #,deserializer-id-stx )))
+	    ;; In a module; provide:
+	    (list (quasisyntax/loc stx
+		    (provide #,deserializer-id-stx)))))
+
+      ;; ------------------------------
+      ;;  The transformers
+
+      (values
+       (lambda (stx)
+	 (context-check stx)
+	 (main stx))
+       (lambda (stx)
+	 (context-check stx)
+	 (main/versions stx)))))
+
+  (define-syntax (continue-define-serializable-struct stx)
+    (generate-delayed-struct-declaration stx make-make-make-struct-type))
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; serialize
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (define (serializable? v)
+    (or (serializable-struct? v)
+	(boolean? v)
+	(null? v)
+	(number? v)
+	(char? v)
+	(symbol? v)
+	(string? v)
+	(path? v)
+	(bytes? v)
+	(vector? v)
+	(pair? v)
+	(hash-table? v)
+	(box? v)
+	(void? v)
+	(date? v)
+	(arity-at-least? v)))
+  
+  (define (mod-to-id info mod-map cache)
+    (let ([deserialize-id (serialize-info-deserialize-id info)])
+      (hash-table-get 
+       cache deserialize-id
+       (lambda ()
+	 (let ([id
+		(let ([path+name
+		       (cond
+			[(identifier? deserialize-id)
+			 (let ([b (identifier-binding deserialize-id)])
+			   (cons
+			    (and (list? b)
+				 (if (symbol? (caddr b))
+				     (caddr b)
+				     (collapse-module-path-index 
+				      (caddr b)
+				      `(file ,(build-path (serialize-info-dir info)
+							  "here.ss")))))
+			    (syntax-e deserialize-id)))]
+			[(symbol? deserialize-id)
+			 (cons #f deserialize-id)]
+			[else
+			 (cons
+			  (if (symbol? (cdr deserialize-id))
+			      (cdr deserialize-id)
+			      (collapse-module-path-index 
+			       (cdr deserialize-id)
+			       `(file ,(build-path (serialize-info-dir info)
+						   "here.ss"))))
+			  (car deserialize-id))])])
+		  (hash-table-get 
+		   mod-map path+name
+		   (lambda ()
+		     (let ([id (hash-table-count mod-map)])
+		       (hash-table-put! mod-map path+name id)
+		       id))))])
+	   (hash-table-put! cache deserialize-id id)
+	   id)))))
+
+  (define (is-mutable? o)
+    (or (and (or (pair? o)
+		 (box? o)
+		 (vector? o)
+		 (date? o)
+		 (hash-table? o)
+		 (arity-at-least? o))
+	     (not (immutable? o)))
+	(serializable-struct? o)))
+
+  ;; Finds a mutable object among those that make the
+  ;;  current cycle.
+  (define (find-mutable v cycle-stack) 
+    ;; Walk back through cycle-stack to find something
+    ;;  mutable. If we get to v without anything being
+    ;;  mutable, then we're stuck.
+    (let ([o (car cycle-stack)])
+      (cond
+       [(eq? o v)
+	(error 'serialize "cannot serialize cycle of immutable values: ~e" v)]
+       [(is-mutable? o)
+	o]
+       [else
+	(find-mutable v (cdr cycle-stack))])))
+
+
+  (define (share-id share cycle)
+    (+ (hash-table-count share)
+       (hash-table-count cycle)))
+
+  ;; Traverses v to find cycles and charing. Shared
+  ;;  object go in the `shared' table, and cycle-breakers go in
+  ;;  `cycle'. In each case, the object is mapped to a number that is
+  ;;  incremented as shared/cycle objects are discovered, so
+  ;;  when the objects are deserialized, build them in reverse
+  ;;  order.
+  (define (find-cycles-and-sharing v cycle share)
+    (let ([tmp-cycle (make-hash-table)]  ;; candidates for sharing
+	  [tmp-share (make-hash-table)]  ;; candidates for cycles
+	  [cycle-stack null])            ;; same as in tmpcycle, but for finding mutable
+      (let loop ([v v])
+	(cond
+	 [(or (boolean? v)
+	      (number? v)
+	      (char? v)
+	      (symbol? v)
+	      (null? v)
+	      (void? v))
+	  (void)]
+	 [(hash-table-get cycle v (lambda () #f))
+	  ;; We already know that this value is
+	  ;;  part of a cycle
+	  (void)]
+	 [(hash-table-get tmp-cycle v (lambda () #f))
+	  ;; We've just learned that this value is
+	  ;;  part of a cycle.
+	  (let ([mut-v (if (is-mutable? v)
+			   v
+			   (find-mutable v cycle-stack))])
+	    (hash-table-put! cycle mut-v (share-id share cycle))
+	    (unless (eq? mut-v v)
+	      ;; This value is potentially shared
+	      (hash-table-put! share v (share-id share cycle))))]
+	 [(hash-table-get share v (lambda () #f))
+	  ;; We already know that this value is shared
+	  (void)]
+	 [(hash-table-get tmp-share v (lambda () #f))
+	  ;; We've just learned that this value is
+	  ;;  shared
+	  (hash-table-put! share v (share-id share cycle))]
+	 [else
+	  (hash-table-put! tmp-share v #t)
+	  (hash-table-put! tmp-cycle v #t)
+	  (set! cycle-stack (cons v cycle-stack))
+	  (cond
+	   [(serializable-struct? v)
+	    (let ([info (serializable-info v)])
+	      (for-each loop (vector->list ((serialize-info-vectorizer info) v))))]
+	   [(or (string? v)
+		(bytes? v)
+		(path? v))
+	    ;; No sub-structure
+	    (void)]
+	   [(vector? v)
+	    (for-each loop (vector->list v))]
+	   [(pair? v)
+	    (loop (car v)) 
+	    (loop (cdr v))]
+	   [(box? v)
+	    (loop (unbox v))]
+	   [(date? v)
+	    (for-each loop (cdr (vector->list (struct->vector v))))]
+	   [(hash-table? v)
+	    (hash-table-for-each v (lambda (k v)
+				     (loop k)
+				     (loop v)))]
+	   [(arity-at-least? v)
+	    (loop (arity-at-least-value v))]
+	   [else (raise-type-error
+		  'serialize
+		  "serializable object"
+		  v)])
+	  ;; No more possibility for this object in
+	  ;;  a cycle:
+	  (hash-table-remove! tmp-cycle v)
+	  (set! cycle-stack (cdr cycle-stack))]))))
+
+  (define (serialize-one v share check-share? mod-map mod-map-cache)
+    (define ((serial check-share?) v)
+      (cond
+       [(or (boolean? v)
+	    (number? v)
+	    (char? v)
+	    (symbol? v)
+	    (null? v))
+	v]
+       [(void? v)
+	'(void)]
+       [(and check-share?
+	     (hash-table-get share v (lambda () #f)))
+	=> (lambda (v) (cons '? v))]
+       [(and (or (string? v)
+		 (bytes? v))
+	     (immutable? v))
+	v]
+       [(serializable-struct? v)
+	(let ([info (serializable-info v)])
+	  (cons (mod-to-id info mod-map mod-map-cache) 
+		(map (serial #t)
+		     (vector->list
+		      ((serialize-info-vectorizer info) v)))))]
+       [(or (string? v)
+	    (bytes? v))
+	(cons 'u v)]
+       [(path? v)
+	(cons 'p (path->bytes v))]
+       [(vector? v)
+	(cons (if (immutable? v) 'v 'v!)
+	      (map (serial #t) (vector->list v)))]
+       [(pair? v)
+	(let ([loop (serial #t)])
+	  (cons (if (immutable? v) 'c 'c!)
+		(cons (loop (car v)) 
+		      (loop (cdr v)))))]
+       [(box? v)
+	(cons (if (immutable? v) 'b 'b!)
+	      ((serial #t) (unbox v)))]
+       [(hash-table? v)
+	(list* 'h
+	       (if (immutable? v) '- '!)
+	       (append
+		(if (hash-table? v 'equal) '(equal) null)
+		(if (hash-table? v 'weak) '(weak) null))
+	       (let ([loop (serial #t)])
+		 (hash-table-map v (lambda (k v)
+				     (cons (loop k)
+					   (loop v))))))]
+       [(date? v)
+	(cons 'date
+	      (map (serial #t) (cdr (vector->list (struct->vector v)))))]
+       [(arity-at-least? v)
+	(cons 'arity-at-least
+	      ((serial #t) (arity-at-least-value v)))]
+       [else (error 'serialize "shouldn't get here")]))
+    ((serial check-share?) v))
+  
+  (define (serial-shell v mod-map mod-map-cache)
+    (cond
+     [(serializable-struct? v)
+      (let ([info (serializable-info v)])
+	(mod-to-id info mod-map mod-map-cache))]
+     [(vector? v)
+      (cons 'v (vector-length v))]
+     [(pair? v)
+      'c]
+     [(box? v)
+      'b]
+     [(hash-table? v)
+      (cons 'h (append
+		(if (hash-table? v 'equal) '(equal) null)
+		(if (hash-table? v 'weak) '(weak) null)))]
+     [(date? v)
+      'date]
+     [(arity-at-least? v)
+      'arity-at-least]))
+
+  (define (serialize v)
+    (let ([mod-map (make-hash-table)]
+	  [mod-map-cache (make-hash-table 'equal)]
+	  [share (make-hash-table)]
+	  [cycle (make-hash-table)])
+      ;; First, traverse V to find cycles and sharing
+      (find-cycles-and-sharing v cycle share)
+      ;; To simplify, all add the cycle records to shared.
+      ;;  (but keep cycle info, too).
+      (hash-table-for-each cycle
+			   (lambda (k v)
+			     (hash-table-put! share k v)))
+      (let ([ordered (map car
+			  (mergesort (hash-table-map share cons)
+				     (lambda (a b)
+				       (< (cdr a) (cdr b)))))])
+	(let ([serializeds (map (lambda (v)
+				  (if (hash-table-get cycle v (lambda () #f))
+				      ;; Box indicates cycle record allocation
+				      ;;  followed by normal serialization
+				      (box (serial-shell v mod-map mod-map-cache))
+				      ;; Otherwise, normal serialization
+				      (serialize-one v share #f mod-map mod-map-cache)))
+				ordered)]
+	      [fixups (hash-table-map 
+		       cycle
+		       (lambda (v n)
+			 (cons n
+			       (serialize-one v share #f mod-map mod-map-cache))))]
+	      [main-serialized (serialize-one v share #t mod-map mod-map-cache)]
+	      [mod-map-l (map car
+			      (mergesort (hash-table-map mod-map cons)
+					 (lambda (a b) (< (cdr a) (cdr b)))))])
+	  (list (hash-table-count mod-map)
+		mod-map-l
+		(length serializeds)
+		serializeds
+		fixups
+		main-serialized)))))
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; deserialize
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (define-values (prop:internal-deserialize internal-deserialize? internal-deserialize-info)
+    (make-struct-type-property 'internal-deserialize #f))
+
+  (define (deserialize-one v share mod-map)
+    (let loop ([v v])
+      (cond
+       [(or (boolean? v)
+	    (number? v)
+	    (char? v)
+	    (symbol? v)
+	    (null? v))
+	v]
+       [(string? v)
+	(string->immutable-string v)]
+       [(bytes? v)
+	(bytes->immutable-bytes v)]
+       [(number? (car v))
+	;; Struct instance:
+	(let ([info (vector-ref mod-map (car v))])
+	  (apply (deserialize-info-maker info) (map loop (cdr v))))]
+       [else
+	(case (car v)
+	  [(?) (vector-ref share (cdr v))]
+	  [(void) (void)]
+	  [(u) (let ([x (cdr v)])
+		 (cond
+		  [(string? x) (string-copy x)]
+		  [(bytes? x) (bytes-copy x)]))]
+	  [(p) (bytes->path (cdr v))]
+	  [(c) (cons-immutable (loop (cadr v)) (loop (cddr v)))]
+	  [(c!) (cons (loop (cadr v)) (loop (cddr v)))]
+	  [(v) (apply vector-immutable (map loop (cdr v)))]
+	  [(v!) (list->vector (map loop (cdr v)))]
+	  [(b) (box-immutable (loop (cdr v)))]
+	  [(b!) (box (loop (cdr v)))]
+	  [(h) (let ([al (map (lambda (p)
+				(cons (loop (car p))
+				      (loop (cdr p))))
+			      (cdddr v))])
+		 (if (eq? '! (cadr v))
+		     (let ([ht (apply make-hash-table (caddr v))])
+		       (for-each (lambda (p)
+				   (hash-table-put! ht (car p) (cdr p)))
+				 al)
+		       ht)
+		     (apply make-immutable-hash-table al (caddr v))))]
+	  [(date) (apply make-date (map loop (cdr v)))]
+	  [(arity-at-least) (make-arity-at-least (loop (cdr v)))]
+	  [else (error 'serialize "ill-formed serialization")])])))
+
+  (define (deserial-shell v mod-map fixup n)
+    (cond
+     [(number? v)
+      ;; Struct instance
+      (let* ([info (vector-ref mod-map v)])
+	(let-values ([(obj fix) ((deserialize-info-cycle-maker info))])
+	  (vector-set! fixup n fix)
+	  obj))]
+     [(pair? v)
+      (case (car v)
+	[(v)
+	 ;; Vector 
+	 (let* ([m (cdr v)]
+		[v0 (make-vector m #f)])
+	   (vector-set! fixup n (lambda (v)
+				  (let loop ([i m])
+				    (unless (zero? i)
+				      (let ([i (sub1 i)])
+					(vector-set! v0 i (vector-ref v i))
+					(loop i))))))
+	   v0)]
+	[(h)
+	 ;; Hash table
+	 (let ([ht0 (make-hash-table)])
+	   (vector-set! fixup n (lambda (ht)
+				  (hash-table-for-each 
+				   ht
+				   (lambda (k v)
+				     (hash-table-put! ht0 k v)))))
+	   ht0)])]
+     [else
+      (case v
+	[(c) 
+	 (let ([p0 (cons #f #f)])
+	   (vector-set! fixup n (lambda (p)
+				  (set-car! p0 (car p))
+				  (set-cdr! p0 (cdr p))))
+	   p0)]
+	[(b)
+	 (let ([b0 (box #f)])
+	   (vector-set! fixup n (lambda (b)
+				  (set-box! b0 (unbox b))))
+	   b0)]
+	[(date)
+	 (let ([d0 (make-date #f #f #f #f #f #f #f #f #f #f)])
+	   (vector-set! fixup n (lambda (d)
+				  (set-date-second! d0 (date-second d))
+				  (set-date-minute! d0 (date-minute d))
+				  (set-date-hour! d0 (date-hour d))
+				  (set-date-day! d0 (date-day d))
+				  (set-date-month! d0 (date-month d))
+				  (set-date-year! d0 (date-year d))
+				  (set-date-week-day! d0 (date-week-day d))
+				  (set-date-year-day! d0 (date-year-day d))
+				  (set-date-dst?! d0 (date-dst? d))
+				  (set-date-time-zone-offset! d0 (date-time-zone-offset d))))
+	   d0)]
+	[(arity-at-least)
+	 (let ([a0 (make-arity-at-least #f)])
+	   (vector-set! fixup n (lambda (a)
+				  (set-arity-at-least-value! a0 (arity-at-least-value a))))
+	   a0)])]))
+
+  (define (deserialize l)
+    (let ([mod-map (make-vector (list-ref l 0))]
+	  [mod-map-l (list-ref l 1)]
+	  [share-n (list-ref l 2)]
+	  [shares (list-ref l 3)]
+	  [fixups (list-ref l 4)]
+	  [result (list-ref l 5)])
+      ;; Load constructor mapping
+      (let loop ([n 0][l mod-map-l])
+	(unless (null? l)
+	  (let* ([path+name (car l)]
+		 [des (if (car path+name)
+			  (dynamic-require (car path+name) (cdr path+name))
+			  (namespace-variable-value (cdr path+name)))])
+	    ;; Register maker and struct type:
+	    (vector-set! mod-map n des))
+	  (loop (add1 n) (cdr l))))
+      ;; Create vector for sharing:
+      (let ([share (make-vector share-n #f)]
+	    [fixup (make-vector share-n #f)])
+	;; Deserialize into sharing array:
+	(let loop ([n 0][l shares])
+	  (unless (= n share-n)
+	    (vector-set! share n
+			 (let ([v (car l)])
+			   (if (box? v)
+			       (deserial-shell (unbox v) mod-map fixup n)
+			       (deserialize-one v share mod-map))))
+	    (loop (add1 n) (cdr l))))
+	;; Fixup shell for graphs
+	(for-each (lambda (n+v)
+		    (let ([v (deserialize-one (cdr n+v) share mod-map)])
+		      ((vector-ref fixup (car n+v)) v)))
+		  fixups)
+	;; Deserialize final result. (If there's no sharing, then
+	;;  all the work is actually here.)
+	(deserialize-one result share mod-map)))))
diff --git a/collects/mzlib/shared.ss b/collects/mzlib/shared.ss
new file mode 100644
index 0000000000..d71b2c4a12
--- /dev/null
+++ b/collects/mzlib/shared.ss
@@ -0,0 +1,18 @@
+
+(module shared mzscheme
+  (require-for-syntax (lib "stx.ss" "syntax")
+		      (lib "kerncase.ss" "syntax")
+		      (lib "struct.ss" "syntax")
+		      "include.ss")
+
+  (provide shared)
+
+  (define undefined (letrec ([x x]) x))
+  (require (rename mzscheme the-cons cons))
+
+  (define-syntax shared
+    (lambda (stx)
+      (define make-check-cdr #f)
+      ;; Include the implementation.
+      ;; See private/shared-body.ss.
+      (include (build-path "private" "shared-body.ss")))))
diff --git a/collects/mzlib/spidey.ss b/collects/mzlib/spidey.ss
new file mode 100644
index 0000000000..05fc7d1199
--- /dev/null
+++ b/collects/mzlib/spidey.ss
@@ -0,0 +1,31 @@
+
+(module spidey mzscheme
+
+  (provide define-constructor
+	  define-type
+	  :
+	  mrspidey:control
+	  polymorphic
+	  type:)
+
+  (define-syntax define-constructor
+    (lambda (stx) (syntax (void))))
+
+  (define-syntax define-type
+    (lambda (stx) (syntax (void))))
+
+  (define-syntax :
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ v t) (syntax v)])))
+
+  (define-syntax mrspidey:control
+    (lambda (stx) (syntax (void))))  
+
+  (define-syntax polymorphic
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ e) (syntax e)])))
+
+  (define-syntax type:
+    (lambda (stx) (syntax (void)))))
diff --git a/collects/mzlib/string.ss b/collects/mzlib/string.ss
new file mode 100644
index 0000000000..af32376a2c
--- /dev/null
+++ b/collects/mzlib/string.ss
@@ -0,0 +1,405 @@
+
+(module string mzscheme
+  (provide string-lowercase!
+	   string-uppercase!
+	   eval-string
+	   read-from-string
+	   read-from-string-all
+	   expr->string
+	   regexp-quote
+	   regexp-replace-quote
+	   regexp-match*
+	   regexp-match-positions*
+	   regexp-match-peek-positions*
+	   regexp-split
+	   regexp-match-exact?
+           regexp-match/fail-without-reading)
+
+  (require (lib "etc.ss"))
+
+  (define make-string-do!
+    (lambda (translate)
+      (lambda (s)
+	(let loop ([n (sub1 (string-length s))])
+	  (unless (negative? n)
+	    (string-set! s n
+			 (translate (string-ref s n)))
+	    (loop (sub1 n)))))))
+  (define string-lowercase! (make-string-do! char-downcase))
+  (define string-uppercase! (make-string-do! char-upcase))
+
+  (define eval-string
+    (let ([do-eval
+	   (lambda (str)
+	     (let ([p (open-input-string str)])
+	       (apply
+		values
+		(let loop ()
+		  (let ([e (read p)])
+		    (if (eof-object? e)
+			'()
+			(call-with-values
+			    (lambda () (eval e))
+			  (case-lambda
+			   [() (loop)]
+			   [(only) (cons only (loop))]
+			   [multi 
+			    (append multi (loop))]))))))))])
+      (case-lambda
+       [(str) (eval-string str #f #f)]
+       [(str error-display) (eval-string str error-display #f)]
+       [(str error-display error-result)
+	(if (or error-display error-result)
+	    (with-handlers ([void
+			     (lambda (exn)
+			       ((or error-display (lambda (x)
+						    ((error-display-handler) x exn)))
+				(exn-message exn))
+			       (if error-result
+				   (error-result)
+				   #f))])
+	      (do-eval str))
+	    (do-eval str))])))
+
+  (define read-from-string-one-or-all
+    (case-lambda
+     [(k all? str) (read-from-string-one-or-all k all? str #f #f)]
+     [(k all? str error-display) (read-from-string-one-or-all k all? str error-display #f)]
+     [(k all? str error-display error-result)
+      (let* ([p (open-input-string str)]
+	     [go (lambda ()
+		   (let loop ()
+		     (let ([v (read p)])
+		       (if (eof-object? v)
+			   '()
+			   (cons v
+				 (if all?
+				     (loop)
+				     '()))))))])
+	(if error-display
+	    (with-handlers ([void
+			     (lambda (exn)
+			       ((or error-display (lambda (x)
+						    ((error-display-handler) x exn)))
+				(exn-message exn))
+			       (k (if error-result
+				      (error-result)
+				      #f)))])
+	      (go))
+	    (go)))]))
+
+  (define read-from-string
+    (lambda args
+      (let/ec k
+	(let ([l (apply read-from-string-one-or-all k #f args)])
+	  (if (null? l)
+	      eof
+	      (car l))))))
+  
+  (define read-from-string-all
+    (lambda args
+      (let/ec k
+	(apply read-from-string-one-or-all k #t args))))
+  
+  (define expr->string
+    (lambda (v)
+      (let ([port (open-output-string)])
+	(write v port)
+	(get-output-string port))))
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; Regexp helpers
+
+  (define (bstring-length s)
+    (if (string? s)
+	(string-length s)
+	(bytes-length s)))
+
+  (define (subbstring s st e)
+    (if (string? s)
+	(substring s st e)
+	(subbytes s st e)))
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; Regexp helpers
+  
+  (define regexp-quote
+    (opt-lambda (s [case-sens? #t])
+      (unless (or (string? s)
+		  (bytes? s))
+	(raise-type-error 'regexp-quote "string or byte string" s))
+      ((if (bytes? s) 
+	   (lambda (l) (list->bytes (map char->integer l)))
+	   list->string)
+       (apply
+	append
+	(map
+	 (lambda (c)
+	   (cond 
+	    [(memq c '(#\$ #\| #\\ #\[ #\] #\. #\* #\? #\+ #\( #\) #\^))
+	     (list #\\ c)]
+	    [(and (not case-sens?)
+		  (not (char=? (char-upcase c) (char-downcase c))))
+	     (list #\[ (char-upcase c) (char-downcase c) #\])]
+	    [else (list c)]))
+	 (if (bytes? s) 
+	     (map integer->char (bytes->list s))
+	     (string->list s)))))))
+
+  (define (regexp-replace-quote s)
+    (unless (or (string? s)
+		(bytes? s))
+      (raise-type-error 'regexp-replace-quote "string or byte string" s))
+    (if (bytes? s)
+	(regexp-replace* #rx#"&" (regexp-replace* #rx#"\\\\" s #"\\\\\\\\") #"\\\\&")
+	(regexp-replace* #rx"&" (regexp-replace* #rx"\\\\" s "\\\\\\\\") "\\\\&")))
+
+  (define regexp-match/fail-without-reading
+    (opt-lambda (pattern input-port [start-k 0] [end-k #f] [out #f])
+      (unless (input-port? input-port)
+        (raise-type-error 'regexp-match/fail-without-reading "input port" input-port))
+      (unless (or (not out) (output-port? out))
+        (raise-type-error 'regexp-match/fail-without-reading "output port or #f" out))
+      (let ([m (regexp-match-peek-positions pattern input-port start-k end-k)])
+        (and m
+             ;; What happens if someone swipes our bytes before we can get them?
+             (let ([drop (caar m)])
+               ;; drop prefix before match:
+               (let ([s (read-bytes drop input-port)])
+		 (when out
+		   (display s out)))
+	       ;; Get the matching part, and shift matching indicies
+               (let ([s (read-bytes (- (cdar m) drop) input-port)])
+                 (cons s
+                       (map (lambda (p)
+                              (and p (subbytes s (- (car p) drop) (- (cdr p) drop))))
+                            (cdr m)))))))))
+
+  ;; Helper function for the regexp functions below.
+  (define (regexp-fn name success-k port-success-k failure-k port-failure-k 
+		     need-leftover? peek?)
+    (lambda (pattern string start end)
+      (unless (or (string? pattern) (bytes? pattern) 
+		  (regexp? pattern) (byte-regexp? pattern))
+	(raise-type-error name "regexp, byte regexp, string, or byte string" pattern))
+      (if peek?
+	  (unless (input-port? string)
+	    (raise-type-error name "input port" string))
+	  (unless (or (string? string) 
+		      (bytes? string) 
+		      (input-port? string))
+	    (raise-type-error name "string, byte string or input port" string)))
+      (unless (and (number? start) (exact? start) (integer? start) (start . >= . 0))
+	(raise-type-error name "non-negative exact integer" start))
+      (unless (or (not end) 
+		  (and (number? end) (exact? end) (integer? end) (end . >= . 0)))
+	(raise-type-error name "non-negative exact integer or false" end))
+      (unless (or (input-port? string)
+		  (and (string? string)
+		       (start . <= . (string-length string)))
+		  (and (bytes? string)
+		       (start . <= . (bytes-length string))))
+	(raise-mismatch-error
+	 name
+	 (format "starting offset index out of range [0,~a]: " 
+		 (if (string? string)
+		     (string-length string)
+		     (bytes-length string)))
+	 start))
+      (unless (or (not end)
+		  (and (start . <= . end)
+		       (or (input-port? string)
+			   (and (string? string)
+				(end . <= . (string-length string)))
+			   (and (bytes? string)
+				(end . <= . (bytes-length string))))))
+	(raise-mismatch-error
+	 name
+	 (format "ending offset index out of range [~a,~a]: " 
+		 end
+		 (if (string? string)
+		     (string-length string)
+		     (bytes-length string)))
+	 start))
+
+      (when (and (positive? start)
+		 (input-port? string)
+		 need-leftover?)
+	;; Skip start chars:
+	(let ([s (make-bytes 4096)])
+	  (let loop ([n 0])
+	    (unless (= n start)
+	      (let ([m (read-bytes-avail! s string 0 (min (- start n) 4096))])
+		(unless (eof-object? m)
+		  (loop (+ n m))))))))
+
+      (let ((expr (cond
+		   [(string? pattern) (regexp pattern)]
+		   [(bytes? pattern) (byte-regexp pattern)]
+		   [else pattern])))
+	(if (and (input-port? string)
+		 port-success-k)
+	    ;; Input port match, get string
+	    (let ([discarded 0]
+		  [leftover-port (and need-leftover?
+				      (open-output-bytes))])
+	      (let ([match (regexp-match expr string 
+					 (if need-leftover? 0 start) 
+					 (and end (if need-leftover? (- end start) end))
+					 (if need-leftover?
+					     leftover-port
+					     (make-output-port
+					      'counter
+					      always-evt
+					      (lambda (s start end flush? breakable?)
+						(let ([c (- end start)])
+						  (set! discarded (+ c discarded))
+						  c))
+					      void)))]
+		    [leftovers (and need-leftover?
+				    (if (and (regexp? pattern) 
+					     (string? string))
+					(get-output-string leftover-port)
+					(get-output-bytes leftover-port)))])
+		(if match
+		    (port-success-k expr string (car match) 
+				    (and end (- end 
+						(if need-leftover?
+						    (+ (bstring-length leftovers) start)
+						    discarded)
+						(bstring-length (car match))))
+				    leftovers)
+		    (port-failure-k leftovers))))
+	    ;; String/port match, get positions
+	    (let ([match ((if peek?
+			      regexp-match-peek-positions
+			      regexp-match-positions) 
+			  expr string start end)])
+	      (if match
+		  (let ((match-start (caar match))
+			(match-end (cdar match)))
+		    (when (= match-start match-end)
+		      (error name "pattern matched a zero-length substring"))
+		    (success-k expr string start end match-start match-end))
+		  (failure-k expr string start end)))))))
+
+  (define-syntax wrap
+    (syntax-rules ()
+      [(_ out orig)
+       (define out 
+	 (opt-lambda (pattern string [start 0] [end #f])
+	   (orig pattern string start end)))]))
+
+  ;; Returns all the positions at which the pattern matched.
+  (define -regexp-match-positions*
+    (regexp-fn 'regexp-match-positions*
+	       ;; success-k:
+	       (lambda (expr string start end match-start match-end)
+		 (cons (cons match-start match-end)
+		       (if (or (string? string)
+			       (bytes? string))
+			   (regexp-match-positions* expr string match-end end)
+			   ;; Need to shift index of rest as reading:
+			   (map (lambda (p)
+				  (cons (+ match-end (car p))
+					(+ match-end (cdr p))))
+				(regexp-match-positions* expr string 0 (and end (- end match-end)))))))
+	       ;; port-success-k --- use string case
+	       #f
+	       ;; fail-k:
+	       (lambda (expr string start end)
+		 null)
+	       ;; port-fail-k --- use string case
+	       #f
+	       #f
+	       #f))
+  (wrap regexp-match-positions* -regexp-match-positions*)
+
+  ;; Returns all the positions at which the pattern matched.
+  (define -regexp-match-peek-positions*
+    (regexp-fn 'regexp-match-peek-positions*
+	       ;; success-k:
+	       (lambda (expr string start end match-start match-end)
+		 (cons (cons match-start match-end)
+		       (regexp-match-peek-positions* expr string match-end end)))
+	       ;; port-success-k --- use string case
+	       #f
+	       ;; fail-k:
+	       (lambda (expr string start end)
+		 null)
+	       ;; port-fail-k --- use string case
+	       #f
+	       #f
+	       #t))
+  (wrap regexp-match-peek-positions* -regexp-match-peek-positions*)
+
+  ;; Splits a string into a list by removing any piece which matches
+  ;; the pattern.
+  (define -regexp-split
+    (regexp-fn 'regexp-split
+	       ;; success-k
+	       (lambda (expr string start end match-start match-end)
+		 (let ([string (if (and (string? string)
+					(or (bytes? expr)
+					    (byte-regexp? expr)))
+				   (string->bytes/utf-8 string (char->integer #\?))
+				   string)])
+		   (cons
+		    (subbstring string start match-start)
+		    (regexp-split expr string match-end end))))
+	       ;; port-success-k:
+	       (lambda (expr string match-string new-end leftovers)
+		 (cons 
+		  leftovers
+		  (regexp-split expr string 0 new-end)))
+	       ;; failure-k:
+	       (lambda (expr string start end)
+		 (list
+		  (subbstring string start (or end (bstring-length string)))))
+	       ;; port-fail-k
+	       (lambda (leftover)
+		 (list leftover))
+	       #t
+	       #f))
+  (wrap regexp-split -regexp-split)
+
+  ;; Returns all the matches for the pattern in the string.
+  (define -regexp-match*
+    (regexp-fn 'regexp-match*
+	       ;; success-k:
+	       (lambda (expr string start end match-start match-end)
+		 (let ([string (if (and (string? string)
+					(or (bytes? expr)
+					    (byte-regexp? expr)))
+				   (string->bytes/utf-8 string (char->integer #\?))
+				   string)])
+		   (cons
+		    (subbstring string match-start match-end)
+		    (regexp-match* expr string match-end end))))
+	       ;; port-success-k:
+	       (lambda (expr string match-string new-end leftovers)
+		 (cons
+		  match-string
+		  (regexp-match* expr string 0 new-end)))
+	       ;; fail-k:
+	       (lambda (expr string start end)
+		 null)
+	       ;; port-fail-k:
+	       (lambda (leftover)
+		 null)
+	       #f
+	       #f))
+  (wrap regexp-match* -regexp-match*)
+
+  (define regexp-match-exact?
+    (lambda (p s)
+      (let ([m (regexp-match-positions p s)])
+	(and m
+	     (zero? (caar m))
+	     (if (or (byte-regexp? p)
+		     (bytes? p)
+		     (bytes? s))
+		 (= (cdar m) (if (bytes? s)
+				 (bytes-length s)
+				 (string-utf-8-length s)))
+		 (= (cdar m) (string-length s))))))))
diff --git a/collects/mzlib/struct.ss b/collects/mzlib/struct.ss
new file mode 100644
index 0000000000..a3c0b3b5a8
--- /dev/null
+++ b/collects/mzlib/struct.ss
@@ -0,0 +1,193 @@
+
+;; by Jacob Matthews (and others)
+
+(module struct mzscheme
+  (provide copy-struct 
+	   define-struct/properties
+	   make-->vector)
+  (require-for-syntax (lib "struct.ss" "syntax")
+		      "list.ss"
+                      (lib "stx.ss" "syntax"))
+
+  ;; ------------------------------------------------------------
+  ;; copy-struct
+
+  ;; copy-struct expands to `do-copy-struct' to delay the expansion
+  ;;  in an internal-definition context. (The `begin0' wrapper
+  ;;  effectively declares the form to be an expression.)
+  (define-syntax (copy-struct stx)
+    (syntax-case stx ()
+      [_ #'(begin0 (do-copy-struct _))]))
+  
+  (define-syntax (do-copy-struct dstx)
+    (syntax-case dstx ()
+      [(_ stx)
+       (let ([stx #'stx])
+	 (syntax-case stx ()
+	   [(_ info structure (accessor-name new-val) ...)
+	    (let ([ans (syntax->list  #'((accessor-name new-val) ...))])
+	      (unless (identifier? #'info)
+		(raise-syntax-error #f "not an identifier for structure type" stx #'info))
+	      (for-each (lambda (an)
+			  (unless (identifier? (stx-car an))
+			    (raise-syntax-error #f "not an identifier for accessor name" stx (stx-car an))))
+			ans)
+	      
+	      ;; new-binding-for : syntax[field-name] -> (union syntax[expression] #f)
+	      (let ((new-binding-for 
+		     (lambda (f)
+		       (ormap (lambda (x) 
+				(if (module-or-top-identifier=? (stx-car x) f)
+				    (cadr (syntax-e x)) 
+				    #f))
+			      ans))))
+		
+		(let-values ([(construct pred accessors)
+			      (let ([v (syntax-local-value #'info (lambda () #f))])
+				(unless (struct-declaration-info? v)
+				  (raise-syntax-error #f "identifier is not bound to a structure type" stx #'info))
+				(values (cadr v)
+					(caddr v)
+					(cadddr v)))]
+			     [(as) (map (lambda (an) (stx-car an)) ans)])
+		  (let ([dests
+			 (map
+			  (lambda (field)
+			    (or (ormap (lambda (f2) (and (module-or-top-identifier=? field f2) f2)) accessors)
+				(raise-syntax-error #f "accessor name not associated with the given structure type" stx field)))
+			  as)])
+		    ;; Check for duplicates using dests, not as, because mod=? as might not be id=?
+		    (let ((dupe (check-duplicate-identifier dests)))
+		      (when dupe 
+			(raise-syntax-error #f 
+					    "duplicate field assignment" 
+					    stx 
+					    ;; Map back to an original field:
+					    (ormap (lambda (a)
+						     (and (module-or-top-identifier=? dupe a)
+							  a))
+						   (reverse as))))))
+		  
+		  ;; the actual result
+		  #`(let ((the-struct structure))
+		      (if (#,pred the-struct)
+			  (#,construct
+			   #,@(map 
+			       (lambda (field) (or (new-binding-for field) #`(#,field the-struct)))
+			       (reverse accessors)))
+			  (raise-type-error '_  #,(format "struct:~a" (syntax-object->datum #'info)) the-struct))))))]))]))
+
+  ;; --------------------------------------------------
+  ;; define-struct/properties
+  
+  ;; Used at run time:
+  (define (check-prop v)
+    (unless (struct-type-property? v)
+      (raise-type-error
+       'define-struct/properties
+       "struct-type property"
+       v))
+    v)
+    
+  ;; This compile-time proc fills in the crucial part of the expansion.
+  ;; Because it's called through a syntax trampoline, the arguments have to
+  ;; to be packaged as a syntax object.
+  (define-for-syntax (make-make-make-struct-type props+insp-stx)
+    (with-syntax ([(([prop expr] ...) inspector) props+insp-stx])
+      (lambda (orig-stx name-stx defined-name-stxes super-info)
+	#`(make-struct-type '#,name-stx 
+			    #,(and super-info (list-ref super-info 0))
+			    #,(/ (- (length defined-name-stxes) 3) 2)
+			    0 #f
+			    (list
+			     (cons (check-prop prop)
+				   expr)
+			     ...)
+			    inspector))))
+  
+  ;; The main macro:
+  (define-syntax (define-struct/properties stx)    
+
+    ;; Start paring. Exploit `parse-define-struct' as much as possible.
+    (define (parse-at-main)
+      (syntax-case stx ()
+	[(_ id/sup fields . rest)
+	 ;; Check initial part:
+	 (let-values ([(id sup-id fields _) 
+		       (parse-define-struct #`(_ id/sup fields) stx)])
+	   (parse-at-props id sup-id fields #'rest))]
+	[_
+	 ;; Not even right up to define-struct, so let the
+	 ;;  simple parser report the problem:
+	 (parse-define-struct stx stx)]))
+    
+    ;; So far, so good. Parse props.
+    (define (parse-at-props id sup-id fields rest)
+      (syntax-case rest ()
+	[(([prop expr] ...) . rrest)
+	 (parse-at-inspector id sup-id fields (stx-car rest) (stx-cdr rest))]
+	[((bad ...) . rest)
+	 (for-each (lambda (bad)
+		     (syntax-case bad ()
+		       [(a b) 'ok]
+		       [_ (raise-syntax-error
+			   #f
+			   "expected a parenthesized property--value pairing"
+			   stx
+			   bad)]))
+		   (syntax->list #'(bad ...)))]
+	[(bad . rest)
+	 (raise-syntax-error
+	  #f
+	  "expected a parenthesized sequence of property--value pairings"
+	  stx
+	  #'bad)]
+	[_
+	 (raise-syntax-error
+	  #f
+	  "expected a parenthesized sequence of property--value pairings after fields"
+	  stx)]))
+
+    ;; Finally, parse optional inspector expr, again exploting
+    ;;  `parse-define-struct'.
+    (define (parse-at-inspector id sup-id fields props rest)
+      (let-values ([(_ __ ___ inspector-stx)
+		    (parse-define-struct #`(ds id () #,@rest) stx)])
+	(build-result id sup-id fields props inspector-stx)))
+
+    ;; Build the result using `generate-struct-declaration', which 
+    ;;  sometimes needs the `continue-ds/p' trampoline to eventually get
+    ;;  to make-make-make-struct-type.
+    (define (build-result id sup-id fields props inspector)
+      (let ([props+insp #`(#,props #,inspector)])
+	(generate-struct-declaration stx
+				     id sup-id fields
+				     (syntax-local-context)
+				     (make-make-make-struct-type props+insp)
+				     #'continue-ds/p props+insp)))
+    
+    (parse-at-main))
+      
+  (define-syntax (continue-ds/p stx)
+    (generate-delayed-struct-declaration stx make-make-make-struct-type))
+
+  ;; ------------------------------------------------------------
+  ;; make->vector
+  
+  (define-syntax (make-->vector stx)
+    (syntax-case stx ()
+      [(_ name) ; a struct type name
+       (identifier? (syntax name))
+       (let ([info (syntax-local-value (syntax name))])
+         (if (struct-declaration-info? info)
+             (with-syntax ([(accessor ...)
+                            (reverse
+                             (filter identifier? (list-ref info 3)))])
+               (syntax
+                (λ (s)
+                  (vector (accessor s) ...))))
+             (raise-syntax-error
+              #f
+              "not a declared structure type name"
+              stx
+              (syntax name))))])))
diff --git a/collects/mzlib/structure.ss b/collects/mzlib/structure.ss
new file mode 100644
index 0000000000..f5c6bd9890
--- /dev/null
+++ b/collects/mzlib/structure.ss
@@ -0,0 +1,224 @@
+(module structure mzscheme
+  (require (lib "etc.ss"))
+  (require-for-syntax "private/structure-helper.ss"
+                      (lib "kerncase.ss" "syntax")
+                      (lib "stx.ss" "syntax")
+                      (lib "list.ss"))
+  
+  (provide structure dot open open-in-context open-as)
+
+  ;; Dangerous, but seems to work.
+  (define-syntax define-syntaxes-ml
+    (syntax-rules  ()
+      ((_ . x) (define-syntaxes . x))))
+  
+  (define-syntax-set (structure)
+
+    (define kernel-form-identifier-list/no-begin
+      (append (map (lambda (x) (datum->syntax-object #'here x))
+                   `(define-values-ml define-syntaxes-ml))
+              (filter (lambda (id) (not (eq? 'begin (syntax-e id))))
+                      (kernel-form-identifier-list #'here))))
+
+    (define (stx-assoc id renames)
+      (cond
+        ((null? renames) #f)
+        ((bound-identifier=? id (caar renames)) (car renames))
+        (else (stx-assoc id (cdr renames)))))
+
+    (define (remove-begins def)
+      (kernel-syntax-case def #f
+        ((begin defs ...)
+         (apply append (map remove-begins (syntax->list #'(defs ...)))))
+        (_ (list def))))
+    
+    (define (fix-expr e)
+      (kernel-syntax-case e #f
+        ((define-values x y) e)
+        ((define-syntaxes x y) e)
+        ((d x y) (or (module-identifier=? (quote-syntax define-values-ml) #'d)
+                     (module-identifier=? (quote-syntax define-syntaxes-ml) #'d))
+         e)
+        (x #`(define-values () (begin x (values))))))
+    
+    (define (get-defs defs)
+      (map fix-expr
+           (apply append
+                  (map (lambda (d)
+                         (remove-begins
+                          (local-expand d
+                                        (syntax-local-context)
+                                        kernel-form-identifier-list/no-begin)))
+                       defs))))
+    
+    (define (get-ids def)
+      (kernel-syntax-case def #f
+        ((define-syntaxes vars body) (syntax->list #'vars))
+        ((define-values vars body) (syntax->list #'vars))
+        ((d vars body) (or (module-identifier=? (quote-syntax define-values-ml) #'d)
+                           (module-identifier=? (quote-syntax define-syntaxes-ml) #'d))
+         (syntax->list #'vars))
+        (_ (raise-syntax-error 'structure "Internal error" def))))
+    
+    (define (rebuild ctxt val)
+      (if (syntax? ctxt)
+          (datum->syntax-object ctxt val ctxt ctxt)
+          val))
+    
+    (define (rebuild-cons car cdr stx)
+      (rebuild stx (cons car cdr)))
+    
+    (define (mark-ids def introducers)
+      (let ((new-ids (map (lambda (id) (cons id (make-syntax-introducer)))
+                          (get-ids def))))
+        (values
+         (syntax-case def ()
+           ((ds . x) (module-identifier=? (quote-syntax define-syntaxes) #'ds)
+            (rebuild-cons #'ds (mark-ids-helper #'x (append new-ids introducers)) def))
+           ((dv . x) (module-identifier=? (quote-syntax define-values) #'dv)
+            (rebuild-cons #'dv (mark-ids-helper #'x (append new-ids introducers)) def))
+           ((d vars body) (module-identifier=? (quote-syntax define-values-ml) #'d)
+            (rebuild def `(,(datum->syntax-object #'here 'define-values #'d #'d)
+                           ,(mark-ids-helper #'vars (append new-ids introducers))
+                           ,(mark-ids-helper #'body introducers))))
+           ((d vars body) (module-identifier=? (quote-syntax define-syntaxes-ml) #'d)
+            (rebuild def `(,(datum->syntax-object #'here 'define-syntaxes #'d #'d)
+                           ,(mark-ids-helper #'vars (append new-ids introducers))
+                           ,(mark-ids-helper #'body introducers)))))
+        new-ids)))
+        
+    (define (mark-ids-helper def introducers)
+      (let ((contents 
+             (if (syntax? def)
+                 (syntax-e def)
+                 def)))
+        (cond
+          ((symbol? contents)
+           (let ((introducer (stx-assoc def introducers)))
+             (if introducer ((cdr introducer) def) def)))
+          ((pair? contents)
+           (rebuild-cons (mark-ids-helper (car contents) introducers)
+                         (mark-ids-helper (cdr contents) introducers)
+                         def))
+          ((vector? contents)
+           (rebuild def (list->vector
+                         (map (lambda (x) (mark-ids-helper x introducers))
+                              (vector->list contents)))))
+          (else def))))
+    
+    (define (structure/proc stx)
+      (syntax-case stx ()
+        ((_ name provides body ...)
+         (let ((defs (get-defs (syntax->list #'(body ...)))))
+           (unless (identifier? #'name)
+             (raise-syntax-error 'structure "Structure name must be an identifier" #'name))
+           #`(begin
+               #,@(let loop ((defined-ids null)
+                             (defs defs))
+                    (cond
+                      ((null? defs)
+                       (list
+                        #`(define-syntaxes-ml (name)
+                            (make-str
+                             (remove-dups
+                              (list
+                               #,@(syntax-case #'provides () 
+                                    (all (and (identifier? #'all)
+                                              (module-identifier=? (quote-syntax provide-all)
+                                                                   #'all))
+                                     (map (lambda (id)
+                                            `(cons 
+                                              (quote ,(car id))
+                                              (quote-syntax ,((cdr id)
+                                                              (car id)))))
+                                          (filter (lambda (id)
+                                                    (bound-identifier=? 
+                                                     (car id)
+                                                     (datum->syntax-object 
+                                                      #'provides
+                                                      (syntax-object->datum (car id)))))
+                                                  defined-ids)))
+                                    ((provides ...)
+                                     (map (lambda (provide)
+                                            (let ((introducer (stx-assoc provide defined-ids)))
+                                              (unless introducer
+                                                (raise-syntax-error
+                                                 'structure 
+                                                 "Attempt to export undefined identifier"
+                                                 provide))
+                                              `(cons 
+                                                (quote ,provide)
+                                                (quote-syntax ,((cdr introducer) provide)))))
+                                          (syntax->list #'(provides ...))))
+                                    (p 
+                                     (cond
+                                       ((eq? 'provide-all (syntax-e #'p))
+                                        (raise-syntax-error
+                                         'structure
+                                         "provide-all has been rebound"
+                                         #'provides))
+                                       (else
+                                        (raise-syntax-error
+                                         'structure
+                                         "Export must have the form \"provide-all\" or \"(identifier ...)\""
+                                         #'provides)))))))))))
+                      (else
+                       (let-values (((marked-def new-defined-ids)
+                                     (mark-ids (car defs) defined-ids)))
+                         (cons marked-def
+                               (loop (append new-defined-ids defined-ids)
+                                     (cdr defs))))))))))))
+    )
+  
+  (define-syntax (open stx)
+    (syntax-case stx ()
+      ((_ top-name path ...)
+       (datum->syntax-object #'here
+         `(open-in-context ,#'top-name ,#'top-name ,@(syntax->list #'(path ...)))
+         stx))))
+  
+  (define-syntax (open-in-context stx)
+    (syntax-case stx ()
+      ((_ context top-name path ...)
+       (let ((env (open (cons #'top-name (syntax->list #'(path ...))) 'open)))
+         (with-syntax ((((pub . hid) ...)
+                        (map (lambda (x)
+                               (cons (datum->syntax-object #'context (car x) stx)
+                                     (cdr x)))
+                             env)))
+           #`(define-syntaxes-ml (pub ...)
+               (values (make-rename-transformer (quote-syntax hid)) ...)))))))
+       
+  
+  (define-syntax (dot-helper stx)
+    (syntax-case stx ()
+      ((_ path field)
+       (begin
+         (unless (identifier? #'field)
+           (raise-syntax-error 'dot "Field to open must be an identifier" #'field))
+         (cond
+           ((stx-null? #'path) #'field)
+           (else
+            (let ((hid (assq (syntax-object->datum #'field)
+                             (open (stx->list #'path) 'dot))))
+              (unless hid
+                (raise-syntax-error 'dot "Unknown field" #'field))
+              (cdr hid))))))))
+
+  (define-syntax (dot stx)
+    (syntax-case stx ()
+      ((_ path1 path-rest ...)
+       (let*-values (((path field)
+                      (split (cons #'path1 (syntax->list #'(path-rest ...))))))
+         #`(begin0 (dot-helper #,path #,field))))))
+                     
+  (define-syntax (open-as stx)
+    (syntax-case stx ()
+      ((_ rename top-name path1 path-rest ...)
+       (let-values (((path field)
+                     (split (cons #'top-name (cons #'path1 (syntax->list #'(path-rest ...)))))))
+         (unless (identifier? #'rename)
+           (raise-syntax-error 'open-as "First position must be an identifier" #'rename))
+         #`(define-syntaxes-ml (rename)
+             (open-as-helper #'#,path #'#,field))))))
+  )
diff --git a/collects/mzlib/stxparam.ss b/collects/mzlib/stxparam.ss
new file mode 100644
index 0000000000..85e895ef0e
--- /dev/null
+++ b/collects/mzlib/stxparam.ss
@@ -0,0 +1,78 @@
+
+(module stxparam mzscheme
+  (require-for-syntax "private/stxparamkey.ss")
+
+  (provide define-syntax-parameter
+	   syntax-parameterize)
+
+  (define-syntax (define-syntax-parameter stx)
+    (syntax-case stx ()
+      [(_ id init-val)
+       (with-syntax ([gen-id (car (generate-temporaries (list #'id)))])
+	 #'(begin
+	     (define-syntax gen-id (convert-renamer init-val))
+	     (define-syntax id 
+	       (let ([gen-id ((syntax-local-certifier) #'gen-id)])
+		 (make-set!-transformer
+		  (make-syntax-parameter 
+		   (lambda (stx)
+		     (let ([v (syntax-parameter-target-value gen-id)])
+		       (apply-transformer v stx #'set!)))
+		   gen-id))))))]))
+
+  (define-syntax (syntax-parameterize stx)
+    (syntax-case stx ()
+      [(_ ([id val] ...) body0 body ...)
+       (let ([ids (syntax->list #'(id ...))])
+	 (with-syntax ([(gen-id ...)
+			(map (lambda (id)
+			       (unless (identifier? id)
+				 (raise-syntax-error
+				  #f
+				  "not an identifier"
+				  stx
+				  id))
+			       (let* ([rt (syntax-local-value id (lambda () #f))]
+				      [sp (if (set!-transformer? rt)
+					      (set!-transformer-procedure rt)
+					      rt)])
+				 (unless (syntax-parameter? sp)
+				   (raise-syntax-error
+				    #f
+				    "not bound as a syntax parameter"
+				    stx
+				    id))
+				 (syntax-local-get-shadower 
+				  (syntax-local-introduce (syntax-parameter-target sp)))))
+			     ids)])
+	   (let ([dup (check-duplicate-identifier ids)])
+	     (when dup
+	       (raise-syntax-error
+		#f
+		"duplicate binding"
+		stx
+		dup)))
+	   #'(let-syntax ([gen-id (convert-renamer val)] ...)
+	       body0 body ...)))]))
+
+  ;; ----------------------------------------
+
+  (require "private/stxparamkey.ss")
+  (provide syntax-parameter-value
+	   make-parameter-rename-transformer)
+
+  (define (make-parameter-rename-transformer id)
+    (make-set!-transformer
+     (lambda (stx)
+       (let ([v (syntax-parameter-value (syntax-local-introduce id))])
+	 (apply-transformer v stx #'set!)))))
+
+  (define (syntax-parameter-value id)
+    (let* ([v (syntax-local-value id (lambda () #f))]
+	   [v (if (set!-transformer? v)
+		  (set!-transformer-procedure v)
+		  v)])
+      (unless (syntax-parameter? v)
+	(raise-type-error 'syntax-parameter-value "syntax parameter" v))
+      (let ([target (syntax-parameter-target v)])
+	(syntax-parameter-target-value target)))))
diff --git a/collects/mzlib/surrogate.ss b/collects/mzlib/surrogate.ss
new file mode 100644
index 0000000000..16aca250c3
--- /dev/null
+++ b/collects/mzlib/surrogate.ss
@@ -0,0 +1,188 @@
+(module surrogate mzscheme
+  (require (lib "class.ss"))
+
+  (provide surrogate)
+  
+  (define-syntax (surrogate stx)
+    
+    (define (make-empty-method method-spec)
+      (syntax-case method-spec (override augment)
+	[(override name argspec ...)
+         (identifier? (syntax name))
+	 (make-empty-method-from-argspec #'name (syntax (argspec ...)))]
+        [(augment def-expr name argspec ...)
+         (identifier? (syntax name))
+	 (make-empty-method-from-argspec #'name (syntax (argspec ...)))]))
+
+    (define (make-empty-method-from-argspec name argspecs)
+      (with-syntax ([(cases ...) (map make-empty-lambda-case
+				      (syntax->list argspecs))]
+		    [name name])
+	(syntax
+	 (begin
+	   (define/public name
+	     (case-lambda cases ...))))))
+    
+    (define (make-empty-lambda-case spec)
+      (syntax-case spec ()
+        [(id ...) (syntax [(ths super-call id ...) (super-call id ...)])]
+        [id
+         (identifier? (syntax id))
+         (syntax [(ths super-call . name) (apply super-call name)])]))
+    
+    (define (make-overriding-method method-spec)
+      (syntax-case method-spec (override augment)
+	[(override name argspec ...)
+	 (identifier? (syntax name))
+	 (make-overriding-method-with-inner-default 
+	  #'name #f #'(argspec ...))]
+        [(augment def-expr name argspec ...)
+	 (identifier? (syntax name))
+	 (make-overriding-method-with-inner-default 
+	  #'name #'def-expr #'(argspec ...))]))
+
+    (define (make-overriding-method-with-inner-default name def-expr argspecs)
+      ;; (not def-expr) => normal override
+      ;; def-expr => beta override
+      (let ([super-call-name
+	     (datum->syntax-object 
+	      name
+	      (string->symbol
+	       (string-append
+		(if def-expr
+		    "inner-proc-"
+		    "super-proc-")
+		(symbol->string
+		 (syntax-object->datum
+		  name)))))])
+	(with-syntax ([(cases ...) 
+		       (map (make-lambda-case name
+					      super-call-name)
+			    (syntax->list argspecs))]
+		      [(super-proc-cases ...)
+		       (map (make-super-proc-case name def-expr)
+			    (syntax->list argspecs))]
+		      [super-call-name super-call-name]
+		      [name name]
+		      [ren/inn (if def-expr
+				   #'inner
+				   #'rename)]
+		      [define/override/fnl (if def-expr
+					       #'define/augment
+					       #'define/override)])
+	  (syntax
+	   (begin
+	     (field [super-call-name
+		     (case-lambda super-proc-cases ...)])
+	     (define/override/fnl name
+	       (case-lambda cases ...)))))))
+    
+    (define ((extract-id stx) method-spec)
+      (syntax-case method-spec (override augment)
+	[(override name argspec ...)
+	 (identifier? #'name)
+	 (syntax name)]
+	[(augment result-expr name argspec ...)
+	 (identifier? #'name)
+	 (syntax name)]
+	[else (raise-syntax-error 
+	       #f
+	       "bad method specification"
+	       stx
+	       method-spec)]))
+    
+    (define (make-super-proc-case name def-expr)
+      (lambda (spec)
+        (with-syntax ([name name])
+          (syntax-case spec ()
+	    ;; Not a rest arg: normal mode
+            [(id ...) (quasisyntax [(id ...)
+				    (#,@(if def-expr 
+					    (list #'inner def-expr)
+					    (list #'super))
+				     name
+				     id ...)])]
+	    ;; A rest arg: take args as list
+            [id 
+             (identifier? (syntax id))
+             (quasisyntax [(id) (#,@(if def-expr 
+					(list #'inner def-expr)
+					(list #'super))
+				 name
+				 . id)])]))))
+    
+    (define (make-lambda-case name super-call)
+      (with-syntax ([name name]
+                    [super-call super-call])
+        (lambda (spec)
+          (syntax-case spec ()
+	    ;; Not a rest arg: normal mode for super-call
+            [(id ...) (syntax [(id ...)
+                               (if surrogate
+                                   (send surrogate name this super-call id ...)
+                                   (super-call id ...))])]
+	    ;; A rest arg: super-class takes args as a list
+            [id
+             (identifier? (syntax id))
+             (syntax [name 
+                      (if surrogate
+                          (send surrogate name this (lambda args (super-call args)) . id)
+                          (super-call id))])]))))
+    
+    (syntax-case stx ()
+      [(_ method-spec ...)
+       (with-syntax ([(ids ...) (map (extract-id stx) (syntax->list (syntax (method-spec ...))))]
+                     [(overriding-methods ...)
+                      (map make-overriding-method 
+                           (syntax->list
+                            (syntax (method-spec ...))))]
+                     [(empty-methods ...)
+                      (map make-empty-method
+                           (syntax->list
+                            (syntax (method-spec ...))))])
+         (syntax/loc stx
+          (let ([surrogate<%>
+                 (interface ()
+                   on-disable-surrogate
+                   on-enable-surrogate
+                   ids ...)]
+		[host<%> 
+		 (interface ()
+		   set-surrogate
+		   get-surrogate
+		   ids ...)])
+            (values
+             (lambda (super%)
+               (class* super% (host<%>)
+                 (field [surrogate #f])
+                 (define/public (set-surrogate d)
+                   (when surrogate
+                     (send surrogate on-disable-surrogate this))
+                   
+                   ;; error checking
+                   (when d
+                     (unless (object? d)
+                       (error 'set-surrogate "expected an object, got: ~e" d))
+                     (let ([methods-to-impl '(on-enable-surrogate on-disable-surrogate ids ...)]
+                           [i (object-interface d)])
+                       (for-each (lambda (x) 
+                                   (unless (method-in-interface? x i)
+                                     (error 'set-surrogate "expected object to implement an ~s method" x)))
+                                 methods-to-impl)))
+                   
+                   (set! surrogate d)
+                   (when surrogate
+                     (send surrogate on-enable-surrogate this)))
+                 (define/public (get-surrogate) surrogate)
+                 
+                 overriding-methods ...
+                 
+                 (super-new)))
+             host<%>
+
+             (class* object% (surrogate<%>)
+               (define/public (on-enable-surrogate x) (void))
+               (define/public (on-disable-surrogate x) (void))
+               empty-methods ...
+               (super-new))
+             surrogate<%>))))])))
diff --git a/collects/mzlib/thread.ss b/collects/mzlib/thread.ss
new file mode 100644
index 0000000000..0135fc64ee
--- /dev/null
+++ b/collects/mzlib/thread.ss
@@ -0,0 +1,223 @@
+
+(module thread mzscheme
+  (require "spidey.ss"
+	   "etc.ss"
+	   "contract.ss")
+
+  (provide run-server
+	   consumer-thread)
+  
+  #|
+  t accepts a function, f, and creates a thread. It returns the thread and a
+  function, g. When g is applied it passes it's argument to f, and evaluates
+  the call of f in the time of the thread that was created. Calls to g do not
+  block.
+  |#
+
+  (define consumer-thread
+    (case-lambda
+     [(f) (consumer-thread f void)]
+     [(f init)
+      (unless (procedure? f) (raise-type-error 'consumer-thread "procedure" f))
+      (let ([sema (make-semaphore 0)]
+	    [protect (make-semaphore 1)]
+	    [front-state null]
+	    [back-state null])
+	(values 
+	 (thread
+	  (letrec ([loop
+		    (lambda ()
+		      (semaphore-wait sema)
+		      (let ([local-state
+			     (begin
+			       (semaphore-wait protect)
+			       (if (null? back-state)
+				   (let ([new-front (reverse front-state)])
+				     (set! back-state (cdr new-front))
+				     (set! front-state null)
+				     (semaphore-post protect)
+				     (car new-front))
+				   (begin0
+				    (car back-state)
+				    (set! back-state (cdr back-state))
+				    (semaphore-post protect))))])
+			(apply f local-state))
+		      (loop))])
+	    (lambda ()
+	      (init)
+	      (loop))))
+	 (lambda new-state
+	   (let ([num (length new-state)])
+	     (unless (procedure-arity-includes? f num) 
+		     (raise 
+		      (make-exn:fail:contract:arity
+		       (string->immutable-string
+			(format "<procedure-from-consumer-thread>: consumer procedure arity is ~e; provided ~s argument~a"
+				(procedure-arity f) num (if (= 1 num) "" "s")))
+		       (current-continuation-marks)))))
+	   (semaphore-wait protect)
+	   (set! front-state (cons new-state front-state))
+	   (semaphore-post protect)
+	   (semaphore-post sema))))]))
+
+  (define run-server
+    (opt-lambda (port-number 
+		 handler 
+		 connection-timeout
+		 [handle-exn void]
+		 [tcp-listen tcp-listen]
+		 [tcp-close tcp-close]
+		 [tcp-accept tcp-accept]
+		 [tcp-accept/enable-break tcp-accept/enable-break])
+      (let ([l (tcp-listen port-number 5 #t)]
+	    [can-break? (break-enabled)])
+	(dynamic-wind
+	    void
+	    (lambda ()
+	      ;; All connections should use the same parameterization,
+	      ;;  to facilitate transferring continuations from one
+	      ;;  connection to another:
+	      (let ([paramz (current-parameterization)])
+		;; Loop to handle connections:
+		(let loop ()
+		  (with-handlers ([exn:fail:network? handle-exn])
+		    ;; Make a custodian for the next session:
+		    (let ([c (make-custodian)])
+		      (parameterize ([current-custodian c])
+			;; disable breaks during session set-up...
+			(parameterize-break #f
+			  ;; ... but enable breaks while blocked on an accept:
+			  (let-values ([(r w) ((if can-break?
+						   tcp-accept/enable-break
+						   tcp-accept)
+					       l)])
+			    ;; Handler thread:
+			    (let ([t (thread (lambda () 
+					       ;; First, install the parameterization
+					       ;;  used for all connections:
+					       (call-with-parameterization
+						paramz
+						(lambda ()
+						  ;; Install this connection's custodian
+						  ;;  for this thread in the shared
+						  ;;  parameterization:
+						  (current-custodian c)
+						  ;; Enable breaking:
+						  (when can-break?
+						    (break-enabled #t))
+						  ;; Call the handler
+						  (handler r w)))))])
+			      ;; Clean-up and timeout thread:
+			      (thread (lambda () 
+					(sync/timeout connection-timeout t)
+					(when (thread-running? t)
+					  ;; Only happens if connection-timeout is not #f
+					  (break-thread t))
+					(sync/timeout connection-timeout t)
+					(custodian-shutdown-all c)))))))))
+		  (loop))))
+	    (lambda () (tcp-close l))))))
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; Couroutine
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  ;; An X-coroutine-object is 
+  ;; (make-coroutine-object thread semaphore channel channel X)
+  (define-struct coroutine-object (worker can-stop-lock done-ch ex-ch result))
+  
+  ;; coroutine : ((bool ->) -> X) -> X-coroutine-object
+  (define (coroutine f)
+    ;;(printf "2. new coroutine~n")
+    (let* ((can-stop-lock (make-semaphore 1))
+           (done-ch (make-channel))
+           (ex-ch (make-channel))
+	   (proceed-sema (make-semaphore))
+           (stop-enabled? #t)
+           (enable-stop
+            (lambda (enable?)
+              ;;(printf "3. enabling ~a~n" enable?)
+              (cond
+	       ((and enable? (not stop-enabled?))
+		(semaphore-post can-stop-lock)
+		(set! stop-enabled? #t))
+	       ((and (not enable?) stop-enabled?)
+		(semaphore-wait can-stop-lock)
+		(set! stop-enabled? #f)))
+              ;;(printf "3. finished enabling~n")
+	      ))
+	   (tid (thread (lambda ()
+			  (semaphore-wait proceed-sema)
+			  ;;(printf "3. creating coroutine thread~n")
+			  (with-handlers (((lambda (exn) #t)
+					   (lambda (exn) 
+					     (enable-stop #t)
+					     (channel-put ex-ch exn))))
+			    (let ([v (f enable-stop)])
+			      (enable-stop #t)
+			      (channel-put done-ch v)))))))
+      (begin0
+       (make-coroutine-object tid can-stop-lock done-ch ex-ch #f)
+       (thread-suspend tid)
+       (semaphore-post proceed-sema))))
+                        
+  ;; coroutine : real-number X-coroutine-object -> bool
+  (define (coroutine-run timeout w)
+    (if (coroutine-object-worker w)
+	#;(printf "2. starting coroutine~n")
+	(let ((can-stop-lock (coroutine-object-can-stop-lock w))
+	      (worker (coroutine-object-worker w)))
+	  (thread-resume worker)
+	  (dynamic-wind
+	      void
+	      ;; Let the co-routine run...
+	      (lambda ()
+		(sync (choice-evt (wrap-evt (alarm-evt (+ timeout (current-inexact-milliseconds)))
+					    (lambda (x)
+					      #;(printf "2. alarm-evt~n")
+					      (semaphore-wait can-stop-lock)
+					      (thread-suspend worker)
+					      (semaphore-post can-stop-lock)
+					      #f))
+				  (wrap-evt (coroutine-object-done-ch w) 
+					    (lambda (res)
+					      #;(printf "2. coroutine-done-evt~n")
+					      (set-coroutine-object-result! w res)
+					      (coroutine-kill w)
+					      #t))
+				  (wrap-evt (coroutine-object-ex-ch w)
+					    (lambda (exn)
+					      #;(printf "2. ex-evt~n")
+					      (coroutine-kill w)
+					      (raise exn))))))
+	      ;; In case we escape through a break:
+	      (lambda ()
+		(when (thread-running? worker)
+		  (semaphore-wait can-stop-lock)
+		  (thread-suspend worker)
+		  (semaphore-post can-stop-lock)))))
+	#t))
+
+  ;; coroutine-result : X-coroutine-object -> X
+  (define (coroutine-result w)
+    (coroutine-object-result w))
+  
+  ;; coroutine-kill : X-coroutine-object ->
+  (define (coroutine-kill w)
+    (set-coroutine-object-can-stop-lock! w #f)
+    (set-coroutine-object-done-ch! w #f)
+    (set-coroutine-object-ex-ch! w #f)
+    (when (coroutine-object-worker w)
+      (kill-thread (coroutine-object-worker w))
+      (set-coroutine-object-worker! w #f)))
+
+  (define (coroutine? x)
+    (coroutine-object? x))
+
+  (provide coroutine?)
+  (provide/contract 
+   (coroutine (((any/c . -> . any) . -> . any) . -> . coroutine?))
+   (coroutine-run (real? coroutine? . -> . boolean?))
+   (coroutine-result (coroutine? . -> . any))
+   (coroutine-kill (coroutine? . -> . any))))
+
diff --git a/collects/mzlib/trace.ss b/collects/mzlib/trace.ss
new file mode 100644
index 0000000000..080ed6ac5d
--- /dev/null
+++ b/collects/mzlib/trace.ss
@@ -0,0 +1,264 @@
+
+(module trace mzscheme
+  (require "pretty.ss")
+
+  (provide trace untrace)
+
+  (define max-dash-space-depth 10)
+  (define number-nesting-depth 6)
+
+  (define as-spaces
+    (lambda (s)
+      (let ((n (string-length s)))
+	(apply string-append
+	       (let loop ((k n))
+		 (if (zero? k) '("")
+		     (cons " " (loop (sub1 k)))))))))
+
+  (define-struct prefix-entry (for-first for-rest))
+
+  (define prefixes (make-vector 20 #f))
+  (define prefix-vector-length 20)
+
+  (define lookup-prefix
+    (lambda (n)
+      (and (< n prefix-vector-length)
+	   (vector-ref prefixes n))))
+
+  (define insert-prefix
+    (lambda (n first rest)
+      (if (>= n prefix-vector-length)
+	  (let ((v (make-vector (* 2 prefix-vector-length) #f)))
+	    (let loop ((k 0))
+	      (when (< k prefix-vector-length)
+		(vector-set! v k (vector-ref prefixes k))
+		(loop (add1 k))))
+	    (set! prefixes v)
+	    (set! prefix-vector-length (* 2 prefix-vector-length))
+	    (insert-prefix n first rest))
+	  (vector-set! prefixes n (make-prefix-entry first rest)))))
+
+  (define construct-prefixes
+    (lambda (level)
+      (let loop ((n level)
+		 (first '("|"))
+		 (rest '(" ")))
+	(if (>= n max-dash-space-depth)
+	    (let-values (((pre-first pre-rest)
+			  (build-prefixes number-nesting-depth)))
+	      (let ((s (number->string level)))
+		(values
+		 (apply string-append
+			(cons pre-first (cons "[" (cons s (cons "]" '())))))
+		 (apply string-append
+			(cons pre-rest (cons " " (cons (as-spaces s)
+						       (cons " " '()))))))))
+	    (cond
+	     ((= n 0) (values (apply string-append (reverse first))
+			      (apply string-append (reverse rest))))
+	     ((= n 1) (loop (- n 1)
+			    (cons '" " first)
+			    (cons '" " rest)))
+	     (else (loop (- n 2)
+			 (cons " |" first)
+			 (cons "  " rest))))))))
+
+  (define build-prefixes
+    (lambda (level)
+      (let ((p (lookup-prefix level)))
+	(if p
+	    (values (prefix-entry-for-first p)
+		    (prefix-entry-for-rest p))
+	    (let-values (((first rest)
+			  (construct-prefixes level)))
+	      (insert-prefix level first rest)
+	      (values first rest))))))
+
+  (define -:trace-print-args
+    (lambda (name args level)
+      (let-values (((first rest)
+		    (build-prefixes level)))
+	(parameterize ((pretty-print-print-line
+			(lambda (n port offset width)
+			  (display
+			   (if n
+			       (if (zero? n) first
+				   (format "~n~a" rest))
+			       (format "~n"))
+			   port)
+			  (if n
+			      (if (zero? n)
+				  (string-length first)
+				  (string-length rest))
+			      0))))
+	  (pretty-print (cons name args))))))
+
+  (define -:trace-print-results
+    (lambda (name results level)
+      (let-values (((first rest)
+		    (build-prefixes level)))
+	(parameterize ((pretty-print-print-line
+			(lambda (n port offset width)
+			  (display
+			   (if n
+			       (if (zero? n) first
+				   (format "~n~a" rest))
+			       (format "~n"))
+			   port)
+			  (if n
+			      (if (zero? n)
+				  (string-length first)
+				  (string-length rest))
+			      0))))
+	  (cond
+	   ((null? results)
+	    (pretty-display "*** no values ***"))
+	   ((null? (cdr results))
+	    (pretty-print (car results)))
+	   (else
+	    (pretty-print (car results))
+	    (parameterize ((pretty-print-print-line
+			    (lambda (n port offset width)
+			      (display
+			       (if n
+				   (if (zero? n) rest
+				       (format "~n~a" rest))
+				   (format "~n"))
+			       port)
+			      (if n
+				  (string-length rest)
+				  0))))
+	      (for-each pretty-print (cdr results)))))))))
+
+  ;; A traced-proc struct instance acts like a procedure,
+  ;;  but preserves the original, too.
+  (define-values (struct:traced-proc make-traced-proc traced-proc? traced-proc-ref traced-proc-set!)
+    (make-struct-type 'traced-proc #f 2 0 #f null (current-inspector) 0))
+
+  ;; Install traced versions of a given set of procedures.  The traced
+  ;;  versions are also given, so that they can be constructed to have
+  ;;  a nice name.
+  (define (do-trace ids procs setters traced-procs)
+    (for-each (lambda (id proc)
+		(unless (procedure? proc)
+		  (error 'trace
+			 "the value of ~s is not a procedure: ~e" id proc)))
+	      ids procs)
+    (for-each (lambda (proc setter traced-proc)
+		(unless (traced-proc? proc)
+		  (setter (make-traced-proc traced-proc proc))))
+	      procs setters traced-procs)
+    ids)
+
+  ;; Key used for a continuation mark to indicate
+  ;;  the nesting depth:
+  (define -:trace-level-key (gensym))
+
+  ;; Apply a traced procedure to arguments, printing arguments
+  ;; and results. We set and inspect the -:trace-level-key continuation
+  ;; mark a few times to detect tail calls.
+  (define (do-traced id args real-value)
+    (let* ([levels (continuation-mark-set->list
+		    (current-continuation-marks)
+		    -:trace-level-key)]
+	   [level (if (null? levels) 0 (car levels))])
+      ;; Tentatively push the new depth level:
+      (with-continuation-mark
+	  -:trace-level-key
+	  (add1 level)
+	;; Check for tail-call => car of levels replaced,
+	;;  which means that the first two new marks are
+	;;  not consecutive:
+	(let ([new-levels (continuation-mark-set->list
+			   (current-continuation-marks)
+			   -:trace-level-key)])
+	  (if (and (pair? (cdr new-levels))
+		   (> (car new-levels) (add1 (cadr new-levels))))
+	      ;; Tail call: reset level and just call real-value.
+	      ;;  (This is in tail position to the call to `do-traced'.)
+	      ;;  We don't print the results, because the original
+	      ;;  call will.
+	      (begin
+		(-:trace-print-args id args (sub1 level))
+		(with-continuation-mark
+		    -:trace-level-key
+		    (car levels)
+		  (apply real-value args)))
+	      ;; Not a tail call; push the old level, again, to ensure
+	      ;;  that when we push the new level, we have consecutive
+	      ;;  levels associated with the mark (i.e., set up for 
+	      ;;  tail-call detection the next time around):
+	      (begin
+		(-:trace-print-args id args level)
+		(with-continuation-mark
+		    -:trace-level-key
+		    level
+		  (call-with-values (lambda () 
+				      (with-continuation-mark
+					  -:trace-level-key
+					  (add1 level)
+					(apply real-value args)))
+		    (lambda results
+		      (flush-output)
+		      ;; Print the results:
+		      (-:trace-print-results id results level)
+		      ;; Return the results:
+		      (apply values results))))))))))
+
+  (define-syntax trace
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ id ...)
+	 (let ([ids (syntax->list (syntax (id ...)))])
+	   (for-each (lambda (id)
+		       (unless (identifier? id)
+			 (raise-syntax-error
+			  #f
+			  "not an identifier"
+			  stx
+			  id)))
+		     ids)
+	   (with-syntax ([(traced-name ...)
+			  (map (lambda (id)
+				 (datum->syntax-object
+				  id
+				  (string->symbol
+				   (string-append "traced-"
+						  (symbol->string (syntax-e id))))
+				  #f))
+			       ids)])
+	     #'(do-trace
+		'(id ...)
+		(list id ...)
+		(list (lambda (v) (set! id v)) ...)
+		(list
+		 (let ([real-value id])
+		   (let ([traced-name
+			  (lambda args
+			    (do-traced 'id args real-value))])
+		     traced-name))
+		 ...))))])))
+
+  (define-syntax untrace
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ id ...)
+	 (let ([ids (syntax->list (syntax (id ...)))])
+	   (for-each (lambda (id)
+		       (unless (identifier? id)
+			 (raise-syntax-error
+			  #f
+			  "not an identifier"
+			  stx
+			  id)))
+		     ids)
+	   (syntax
+	    (append
+	     (if (traced-proc? id)
+		 (begin
+		   (set! id (traced-proc-ref id 1))
+		   '(id))
+		 null)
+	     ...)))])))
+  )
+
diff --git a/collects/mzlib/traceld.ss b/collects/mzlib/traceld.ss
new file mode 100644
index 0000000000..bcb9263ade
--- /dev/null
+++ b/collects/mzlib/traceld.ss
@@ -0,0 +1,49 @@
+
+(module traceld mzscheme
+
+ (let ([load (current-load)]
+       [load-extension (current-load-extension)]
+       [ep (current-error-port)]
+       [tab ""])
+   (let ([mk-chain
+	  (lambda (load)
+	    (lambda (filename expected-module)
+	      (fprintf ep
+		       "~aloading ~a at ~a~n" 
+		       tab filename (current-process-milliseconds))
+	      (begin0
+	       (let ([s tab])
+		 (dynamic-wind
+		  (lambda () (set! tab (string-append " " tab)))
+		  (lambda () 
+		    (if (regexp-match #rx#"_loader" (path->bytes filename))
+			(let ([f (load filename #f)])
+			  (lambda (sym)
+			    (fprintf ep
+				     "~atrying ~a's ~a~n" tab filename sym)
+			    (let-values ([(loader provided-module) (f sym)])
+                              (values
+                               (and loader
+                                    (lambda ()
+                                      (fprintf ep
+                                               "~astarting ~a's ~a at ~a~n" 
+                                               tab filename sym
+                                               (current-process-milliseconds))
+                                      (let ([s tab])
+                                        (begin0
+                                          (dynamic-wind
+                                           (lambda () (set! tab (string-append " " tab)))
+                                           (lambda () (loader))
+                                           (lambda () (set! tab s)))
+                                          (fprintf ep
+                                                   "~adone ~a's ~a at ~a~n"
+                                                   tab filename sym
+                                                   (current-process-milliseconds))))))
+                               provided-module))))
+			(load filename expected-module)))
+		  (lambda () (set! tab s))))
+	       (fprintf ep
+			"~adone ~a at ~a~n"
+			tab filename (current-process-milliseconds)))))])
+     (current-load (mk-chain load))
+     (current-load-extension (mk-chain load-extension)))))
diff --git a/collects/mzlib/transcr.ss b/collects/mzlib/transcr.ss
new file mode 100644
index 0000000000..f9ca994193
--- /dev/null
+++ b/collects/mzlib/transcr.ss
@@ -0,0 +1,49 @@
+
+(module transcr mzscheme
+  (require (lib "port.ss"))
+  (provide (rename -transcript-on transcript-on)
+	   (rename -transcript-off transcript-off))
+
+  ;; Bug: the implementation strategy used for the tees does not
+  ;; guarantee that flushes to stdout and stderr are kept in order.
+  ;; It depends instead on the whims of scheduling the tee threads.
+  ;; This problem could be fixed using `make-output-port' instead
+  ;; of pipes and `copy-port'.
+
+  (define-values (-transcript-on -transcript-off)
+    (let ([in #f]
+	  [out #f]
+	  [err #f]
+	  [tee-out (lambda (p p2)
+		     (let-values ([(r w) (make-pipe)])
+		       (thread
+			(lambda () 
+			  (copy-port r p p2)))
+		       w))]
+	  [tee-in (lambda (in out)
+		     (let-values ([(r w) (make-pipe)])
+		       (thread
+			(lambda ()
+			  (copy-port in w out)))
+		       r))])
+      (values
+       (lambda (file)
+	 (when in
+	   (error 'transcript-on "transcript is already on"))
+	 (let ([p (open-output-file file)])
+	   (set! in (current-input-port))
+	   (set! out (current-output-port))
+	   (set! err (current-error-port))
+	   (current-output-port (tee-out out p))
+	   (current-error-port (tee-out err p))
+	   (current-input-port (tee-in in p))))
+       (lambda ()
+	 (unless in
+	   (error 'transcript-on "transcript is not on"))
+	 (current-input-port in)
+	 (current-output-port out)
+	 (current-error-port err)
+	 (set! in #f)
+	 (set! out #f)
+	 (set! err #f))))))
+
diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss
new file mode 100644
index 0000000000..8a3698c3fc
--- /dev/null
+++ b/collects/mzlib/unit.ss
@@ -0,0 +1,831 @@
+
+;; Unit system
+
+(module unit mzscheme
+  (require-for-syntax (lib "kerncase.ss" "syntax")
+		      (lib "stx.ss" "syntax")
+		      (lib "name.ss" "syntax")
+		      (lib "context.ss" "syntax")
+		      "list.ss"
+		      "private/unitidmap.ss")
+
+  ;; ----------------------------------------------------------------------
+  ;; Structures and helpers
+
+  (define undefined (letrec ([x x]) x)) ; initial value
+
+  (define insp (current-inspector)) ; for named structures
+
+  (define-struct unit (num-imports exports go)) ; unit value
+  (define-struct (exn:fail:unit exn:fail) ()) ; run-time exception
+
+  ;; For units with inferred names, generate a struct that prints using the name:
+  (define (make-naming-constructor type name)
+    (let-values ([(struct: make- ? -accessor -mutator)
+		  (make-struct-type name type 0 0 #f null insp)])
+      make-))
+
+  ;; Make a unt value (call by the macro expansion of `unit')
+  (define (make-a-unit name num-imports exports go)
+    ((if name 
+	 (make-naming-constructor 
+	  struct:unit
+	  (string->symbol (format "unit:~a" name)))
+	 make-unit)
+     num-imports exports go))
+
+  ;; ----------------------------------------------------------------------
+  ;; The `unit' syntactic form
+
+  (define-syntax :unit
+    (lambda (stx)
+      (syntax-case stx (import export)
+	[(_ (import ivar ...)
+	    (export evar ...)
+	    defn&expr ...)
+	 (let ([check-id (lambda (v)
+			   (unless (identifier? v)
+			     (raise-syntax-error
+			      #f
+			      "import is not an identifier"
+			      stx
+			      v)))]
+	       [check-renamed-id 
+		(lambda (v)
+		  (syntax-case v ()
+		    [id (identifier? (syntax id)) 'ok]
+		    [(lid eid) (and (identifier? (syntax lid))
+				    (identifier? (syntax eid))) 'ok]
+		    [else (raise-syntax-error
+			   #f
+			   "export is not an identifier or renamed identifier"
+			   stx
+			   v)]))]
+	       [expand-context (generate-expand-context)]
+	       [ivars (syntax->list (syntax (ivar ...)))]
+	       [evars (syntax->list (syntax (evar ...)))])
+	   (for-each check-id ivars)
+	   (for-each check-renamed-id evars)
+	   
+	   ;; Get import/export declared names:
+	   (let* ([exported-names
+		   (map (lambda (v)
+			  (syntax-case v ()
+			    [(lid eid) (syntax lid)]
+			    [id (syntax id)]))
+			evars)]
+		  [extnames (map (lambda (v)
+				   (syntax-case v ()
+				     [(lid eid) (syntax eid)]
+				     [id (syntax id)]))
+				 evars)]
+		  [imported-names ivars]
+		  [declared-names (append imported-names exported-names)])
+	     ;; Check that all exports are distinct (as symbols)
+	     (let ([ht (make-hash-table)])
+	       (for-each (lambda (name)
+			   (when (hash-table-get ht (syntax-e name) (lambda () #f))
+			     (raise-syntax-error
+			      #f
+			      "duplicate export"
+			      stx
+			      name))
+			   (hash-table-put! ht (syntax-e name) #t))
+			 extnames))
+
+	     ;; Expand all body expressions
+	     ;; so that all definitions are exposed.
+	     (letrec ([expand-all
+		       (lambda (defns&exprs)
+			 (let ([expanded
+				(map
+				 (lambda (defn-or-expr)
+				   (local-expand
+				    defn-or-expr
+				    expand-context
+				    (append
+				     (kernel-form-identifier-list (quote-syntax here))
+				     declared-names)))
+				 defns&exprs)])
+			   (apply
+			    append
+			    (map
+			     (lambda (defn-or-expr)
+			       (syntax-case defn-or-expr (begin)
+				 [(begin . l)
+				  (let ([l (syntax->list (syntax l))])
+				    (unless l
+				      (raise-syntax-error
+				       #f
+				       "bad syntax (illegal use of `.')"
+				       defn-or-expr))
+				    (expand-all (map (lambda (s)
+						       (syntax-track-origin s defn-or-expr #'begin))
+						     l)))]
+				 [else (list defn-or-expr)]))
+			     expanded))))])
+	       (let ([all-expanded (expand-all (syntax->list (syntax (defn&expr ...))))])
+		 ;; Get all the defined names, sorting out variable definitions
+		 ;; from syntax definitions.
+		 (let* ([definition?
+			  (lambda (id)
+			    (and (identifier? id)
+				 (or (module-identifier=? id (quote-syntax define-values))
+				     (module-identifier=? id (quote-syntax define-syntaxes)))))]
+			[all-defined-names/kinds
+			 (apply
+			  append
+			  (map
+			   (lambda (defn-or-expr)
+			     (syntax-case defn-or-expr (define-values define-syntaxes)
+			       [(dv (id ...) expr)
+				(definition? (syntax dv))
+				(let ([l (syntax->list (syntax (id ...)))])
+				  (for-each (lambda (i)
+					      (unless (identifier? i)
+						(raise-syntax-error
+						 #f
+						 "not an identifier in definition"
+						 defn-or-expr
+						 i)))
+					    l)
+				  (let ([key (if (module-identifier=? (syntax dv) (quote-syntax define-syntaxes))
+						 'stx
+						 'val)])
+				    (map (lambda (id) (cons key id)) l)))]
+			       [(define-values . l)
+				(raise-syntax-error
+				 #f
+				 "bad definition form"
+				 defn-or-expr)]
+			       [(define-syntaxes . l)
+				(raise-syntax-error
+				 #f
+				 "bad syntax definition form"
+				 defn-or-expr)]
+			       [else null]))
+			   all-expanded))]
+			[all-defined-names (map cdr all-defined-names/kinds)]
+			[all-defined-val-names (map cdr 
+						    (filter (lambda (i) (eq? (car i) 'val))
+							    all-defined-names/kinds))])
+		   ;; Check that all defined names (var + stx) are distinct:
+		   (let ([name (check-duplicate-identifier
+				(append imported-names all-defined-names))])
+		     (when name
+		       (raise-syntax-error 
+			#f
+			"variable imported and/or defined twice"
+			stx
+			name)))
+		   ;; Check that all exported names are defined (as var):
+		   (let ([ht (make-hash-table)]
+			 [stx-ht (make-hash-table)])
+		     (for-each
+		      (lambda (kind+name)
+			(let ([name (cdr kind+name)])
+			  (let ([l (hash-table-get ht (syntax-e name) (lambda () null))])
+			    (hash-table-put! (if (eq? (car kind+name) 'val) ht stx-ht)
+					     (syntax-e name) 
+					     (cons name l)))))
+		      all-defined-names/kinds)
+		     (for-each 
+		      (lambda (n)
+			(let ([v (hash-table-get ht (syntax-e n) (lambda () null))])
+			  (unless (ormap (lambda (i) (bound-identifier=? i n)) v)
+			    ;; Either not defined, or defined as syntax:
+			    (let ([stx-v (hash-table-get stx-ht (syntax-e n) (lambda () null))])
+			      (if (ormap (lambda (i) (bound-identifier=? i n)) stx-v)
+				  (raise-syntax-error
+				   #f
+				   "cannot export syntax from a unit"
+				   stx
+				   n)
+				  (raise-syntax-error
+				   #f
+				   "exported variable is not defined"
+				   stx
+				   n))))))
+		      exported-names))
+
+		   ;; Compute defined but not exported:
+		   (let ([ht (make-hash-table)])
+		     (for-each
+		      (lambda (name)
+			(let ([l (hash-table-get ht (syntax-e name) (lambda () null))])
+			  (hash-table-put! ht (syntax-e name) (cons name l))))
+		      exported-names)
+		     (let ([internal-names
+			    (let loop ([l all-defined-val-names])
+			      (cond
+			       [(null? l) null]
+			       [(let ([v (hash-table-get ht (syntax-e (car l)) (lambda () null))])
+				  (ormap (lambda (i) (bound-identifier=? i (car l))) v))
+				(loop (cdr l))]
+			       [else (cons (car l) (loop (cdr l)))]))])
+		       ;; Generate names for import/export boxes, etc:
+		       (with-syntax ([(iloc ...) (generate-temporaries (syntax (ivar ...)))]
+				     [(eloc ...) (generate-temporaries evars)]
+				     [(extname ...) extnames]
+				     [(expname ...) exported-names]
+				     [(intname ...) internal-names])
+			 ;; Change all definitions to set!s. Convert evars to set-box!,
+			 ;; because set! on exported variables is not allowed.
+			 (with-syntax ([(defn&expr ...) 
+					(let ([elocs (syntax->list (syntax (eloc ...)))])
+					  (filter
+					   values
+					   (map (lambda (defn-or-expr)
+						  (syntax-case defn-or-expr (define-values define-syntaxes)
+						    [(define-values ids expr)
+						     (let* ([ids (syntax->list (syntax ids))])
+						       (if (null? ids)
+							   (syntax/loc defn-or-expr (set!-values ids expr))
+							   (let ([do-one
+								  (lambda (id tmp name)
+								    (let loop ([evars exported-names]
+									       [elocs elocs])
+								      (cond
+								       [(null? evars)
+									;; not an exported id
+									(with-syntax ([id id][tmp tmp])
+									  (syntax/loc
+									      defn-or-expr
+									      (set! id tmp)))]
+								       [(bound-identifier=? (car evars) id)
+									;; set! exported id:
+									(with-syntax 
+									    ([loc (car elocs)]
+									     [tmp 
+									      (if name
+										  (with-syntax 
+										      ([tmp tmp]
+										       [name name])
+										    (syntax 
+										     (let ([name tmp])
+										       name)))
+										  tmp)])
+									  (syntax/loc defn-or-expr
+									      (set-box! loc tmp)))]
+								       [else (loop (cdr evars) 
+										   (cdr elocs))])))])
+							     (if (null? (cdr ids))
+								 (do-one (car ids) (syntax expr) (car ids))
+								 (let ([tmps (generate-temporaries ids)])
+								   (with-syntax ([(tmp ...) tmps]
+										 [(set ...)
+										  (map (lambda (id tmp)
+											 (do-one id tmp #f))
+										       ids tmps)])
+								     (syntax/loc defn-or-expr
+									 (let-values ([(tmp ...) expr])
+									   set ...))))))))]
+						    [(define-syntaxes . l) #f]
+						    [else defn-or-expr]))
+						all-expanded)))]
+				       [(stx-defn ...) 
+					(filter
+					 values
+					 (map (lambda (defn-or-expr)
+						(syntax-case defn-or-expr (define-syntaxes)
+						  [(define-syntaxes . l) defn-or-expr]
+						  [else #f]))
+					      all-expanded))])
+			   ;; Build up set! redirection chain:
+			   (with-syntax ([redirections
+					  (let ([varlocs 
+						 (syntax->list 
+						  (syntax ((ivar iloc) ... (expname eloc) ...)))])
+					    (with-syntax ([vars (map stx-car varlocs)]
+							  [rhss
+							   (map
+							    (lambda (varloc)
+							      (with-syntax ([(var loc) varloc])
+								(syntax
+								 (make-id-mapper (quote-syntax (unbox loc))
+										 (quote-syntax var)))))
+							    varlocs)])
+					      (syntax
+					       ([vars (values . rhss)]))))]
+					 [num-imports (datum->syntax-object
+						       (quote-syntax here)
+						       (length (syntax->list (syntax (iloc ...))))
+						       #f)]
+					 [name (syntax-local-infer-name stx)])
+			     (syntax/loc stx
+			       (make-a-unit
+				'name
+				num-imports
+				(list (quote extname) ...)
+				(lambda ()
+				  (let ([eloc (box undefined)] ...)
+				    (list (vector eloc ...)
+					  (lambda (iloc ...)
+					    (let ([intname undefined] ...)
+					      (letrec-syntaxes+values redirections ()
+						stx-defn ...
+						(void) ; in case the body would be empty
+						defn&expr ...))))))))))))))))))])))
+
+  ;; ----------------------------------------------------------------------
+  ;; check-expected-interface: used by the expansion of `compound-unit'
+  
+  (define (check-expected-interface tag unit num-imports exports)
+    (unless (unit? unit)
+      (raise
+       (make-exn:fail:unit
+	(string->immutable-string
+	 (format "compound-unit: result of expression for tag ~s not a unit: ~e" tag unit))
+	(current-continuation-marks))))
+    (unless (= num-imports (unit-num-imports unit))
+      (raise
+       (make-exn:fail:unit
+	(string->immutable-string
+	 (format "compound-unit: unit for tag ~s expects ~a imports, given ~a" 
+		 tag
+		 (unit-num-imports unit)
+		 num-imports))
+	(current-continuation-marks))))
+    (list->vector
+     (map (lambda (ex)
+	    (let loop ([l (unit-exports unit)][i 0])
+	      (cond
+	       [(null? l)
+		(raise
+		 (make-exn:fail:unit
+		  (string->immutable-string
+		   (format "compound-unit: unit for tag ~s has no ~s export" 
+			   tag ex))
+		  (current-continuation-marks)))]
+	       [(eq? (car l) ex)
+		i]
+	       [else (loop (cdr l) (add1 i))])))
+	  exports)))
+
+  ;; ----------------------------------------------------------------------
+  ;; The `compound-unit' syntactic form
+
+  (define-syntax compound-unit
+    (lambda (stx)
+      (syntax-case stx (import export link)
+	[(_ (import ivar ...)
+	    (link [tag (unit-expr linkage ...)] ...)
+	    (export exportage ...))
+	 (let ([check-id (lambda (v)
+			   (unless (identifier? v)
+			     (raise-syntax-error
+			      #f
+			      "import is not an identifier"
+			      stx
+			      v)))]
+	       [check-tag (lambda (v)
+			   (unless (identifier? v)
+			     (raise-syntax-error
+			      #f
+			      "tag is not an identifier"
+			      stx
+			      v)))]
+	       [check-linkage (lambda (v)
+				(syntax-case v ()
+				  [id (identifier? (syntax id)) #t]
+				  [(tag id ...)
+				   (for-each (lambda (v)
+					       (unless (identifier? v)
+						 (raise-syntax-error
+						  #f
+						  "non-identifier in linkage"
+						  stx
+						  v)))
+					     (syntax->list v))]
+				  [else
+				   (raise-syntax-error
+				    #f
+				    "ill-formed linkage"
+				    stx
+				    v)]))]
+	       [check-exportage (lambda (v)
+				  (syntax-case v ()
+				    [(tag ex ...)
+				     (begin
+				       (unless (identifier? (syntax tag))
+					 (raise-syntax-error
+					  #f
+					  "export tag is not an identifier"
+					  stx
+					  (syntax tag)))
+				       (for-each 
+					(lambda (e)
+					  (syntax-case e ()
+					    [id (identifier? (syntax id)) #t]
+					    [(iid eid)
+					     (begin
+					       (unless (identifier? (syntax iid))
+						 (raise-syntax-error
+						  #f
+						  "export internal name is not an identifier"
+						  stx
+						  (syntax iid)))
+					       (unless (identifier? (syntax eid))
+						 (raise-syntax-error
+						  #f
+						  "export internal name is not an identifier"
+						  stx
+						  (syntax eid))))]
+					    [else
+					     (raise-syntax-error
+					      #f
+					      (format "ill-formed export with tag ~a" 
+						      (syntax-e (syntax tag)))
+					      stx
+					      e)]))
+					(syntax->list (syntax (ex ...)))))]
+				    [else
+				     (raise-syntax-error
+				      #f
+				      "ill-formed export"
+				      stx
+				      v)]))]
+	       [imports (syntax->list (syntax (ivar ...)))]
+	       [tags (syntax->list (syntax (tag ...)))]
+	       [linkages (map syntax->list (syntax->list (syntax ((linkage ...) ...))))]
+	       [exports (syntax->list (syntax (exportage ...)))])
+	   ;; Syntax checks:
+	   (for-each check-id imports)
+	   (for-each check-tag tags)
+	   (for-each (lambda (l) (for-each check-linkage l)) linkages)
+	   (for-each check-exportage exports)
+	   ;; Check for duplicate imports
+	   (let ([dup (check-duplicate-identifier imports)])
+	     (when dup
+	       (raise-syntax-error
+		#f
+		"duplicate import"
+		stx
+		dup)))
+	   ;; Check for duplicate tags
+	   (let ([dup (check-duplicate-identifier tags)])
+	     (when dup
+	       (raise-syntax-error
+		#f
+		"duplicate tag"
+		stx
+		dup)))
+	   ;; Check referenced imports and tags
+	   (let ([check-linkage-refs (lambda (v)
+				       (syntax-case v ()
+					 [(tag . exs)
+					  (unless (ormap (lambda (t)
+							   (bound-identifier=? t (syntax tag)))
+							 tags)
+					    (raise-syntax-error
+					     #f
+					     "linkage tag is not bound"
+					     stx
+					     (syntax tag)))]
+					 [id (unless (ormap (lambda (i)
+							      (bound-identifier=? i (syntax id)))
+							    imports)
+					       (raise-syntax-error
+						#f
+						"no imported identified for linkage"
+						stx
+						(syntax id)))]))]
+		 [check-export-refs (lambda (v)
+				      (syntax-case v ()
+					[(tag . r)
+					 (unless (ormap (lambda (t)
+							  (bound-identifier=? t (syntax tag)))
+							tags)
+					   (raise-syntax-error
+					    #f
+					    "export tag is not bound"
+					    stx
+					    (syntax tag)))]))])
+	     (for-each (lambda (l) (for-each check-linkage-refs l))
+		       linkages)
+	     (for-each check-export-refs exports)
+	     ;; Get all export names, and check for duplicates
+	     (let ([export-names
+		    (apply
+		     append
+		     (map
+		      (lambda (v)
+			(syntax-case v ()
+			  [(tag . exs)
+			   (map
+			    (lambda (e)
+			      (syntax-case e ()
+				[(iid eid) (syntax eid)]
+				[id e]))
+			    (syntax->list (syntax exs)))]))
+		      exports))])
+	       (let ([dup (check-duplicate-identifier export-names)])
+		 (when dup
+		   (raise-syntax-error
+		    #f
+		    "duplicate export"
+		    stx
+		    dup)))
+
+	       (let ([constituents (generate-temporaries tags)]
+		     [unit-export-positionss (generate-temporaries tags)]
+		     [unit-setups (generate-temporaries tags)]
+		     [unit-extracts (generate-temporaries tags)]
+		     [unit-export-lists
+		      ;; For each tag, get all expected exports
+		      (let* ([hts (map (lambda (x) (make-hash-table)) tags)]
+			     [get-add-name 
+			      (lambda (tag)
+				(ormap (lambda (t ht)
+					 (and (bound-identifier=? t tag)
+					      (lambda (name)
+						(hash-table-put! ht (syntax-e name) name))))
+				       tags hts))])
+			;; Walk though linkages
+			(for-each
+			 (lambda (linkage-list)
+			   (for-each 
+			    (lambda (linkage)
+			      (syntax-case linkage ()
+				[(tag . ids)
+				 (let ([add-name (get-add-name (syntax tag))])
+				   (for-each add-name (syntax->list (syntax ids))))]
+				[else (void)]))
+			    linkage-list))
+			 linkages)
+			;; Walk through exports
+			(for-each
+			 (lambda (v)
+			   (syntax-case v ()
+			     [(tag . exs)
+			      (let ([add-name (get-add-name (syntax tag))])
+				(for-each 
+				 (lambda (e)
+				   (syntax-case e ()
+				     [(iid eid) (add-name (syntax iid))]
+				     [id (add-name (syntax id))]))
+				 (syntax->list (syntax exs))))]))
+			 exports)
+			;; Extract names from hash tables
+			(map (lambda (ht)
+			       (hash-table-map ht (lambda (k v) v)))
+			     hts))])
+		 ;; Map exports to imports and indices based on expected unit exports
+		 (let ([map-tag (lambda (t l)
+				  (let loop ([tags tags][l l])
+				    (if (bound-identifier=? (car tags) t)
+					(car l)
+					(loop (cdr tags) (cdr l)))))]
+		       [unit-export-hts (map (lambda (export-list)
+					       (let ([ht (make-hash-table)])
+						 (let loop ([l export-list][p 0])
+						   (unless (null? l)
+						     (hash-table-put! ht (syntax-e (car l)) p)
+						     (loop (cdr l) (add1 p))))
+						 ht))
+					     unit-export-lists)]
+		       [interned-integer-lists null]
+		       [interned-id-lists null])
+		   (let ([make-mapping
+			  (lambda (v)
+			    (syntax-case v ()
+			      [(tag . exs)
+			       (let ([extract (map-tag (syntax tag)
+						       unit-extracts)]
+				     [ht (map-tag (syntax tag)
+						  unit-export-hts)])
+				 (with-syntax ([extract extract]
+					       [pos-name
+						(let ([il
+						       (map
+							(lambda (e)
+							  (hash-table-get
+							   ht
+							   (syntax-e
+							    (syntax-case e ()
+							      [(iid eid) (syntax iid)]
+							      [id e]))))
+							(syntax->list (syntax exs)))])
+						  (or (ormap (lambda (i)
+							       (and (equal? il (cadadr i))
+								    (car i)))
+							     interned-integer-lists)
+						      (let ([name (car (generate-temporaries 
+									(list (syntax tag))))])
+							(set! interned-integer-lists
+							      (cons `(,name ',il)
+								    interned-integer-lists))
+							name)))])
+				   (syntax (map extract pos-name))))]
+			      [import v]))]
+			 [collapse (lambda (l)
+				     (let loop ([l l])
+				       (cond
+					[(null? l) null]
+					[(identifier? (car l))
+					 (let-values ([(ids rest)
+						       (let loop ([l l][ids null])
+							 (if (or (null? l)
+								 (not (identifier? (car l))))
+							     (values (reverse ids) l)
+							     (loop (cdr l) (cons (car l) ids))))])
+					   (let ([name
+						  (let ([id-syms (map syntax-e ids)])
+						    (or (ormap (lambda (i)
+								 (and (equal? id-syms (cadr i))
+								      (car i)))
+							       interned-id-lists)
+							(let ([name 
+							       (car (generate-temporaries (list 'ids)))])
+							  (set! interned-id-lists
+								(cons (list* name id-syms ids)
+								      interned-id-lists))
+							  name)))])
+					     (cons name
+						   (loop rest))))]
+					[else (cons (car l) (loop (cdr l)))])))])
+		     (let ([export-mapping (collapse (map make-mapping exports))]
+			   [import-mappings (map (lambda (linkage-list)
+						   (collapse
+						    (map make-mapping linkage-list)))
+						 linkages)])
+		       (with-syntax ([(constituent ...) constituents]
+				     [(unit-export-positions ...) unit-export-positionss]
+				     [(unit-setup ...) unit-setups]
+				     [(unit-extract ...) unit-extracts]
+				     [interned-integer-lists interned-integer-lists]
+				     [interned-id-lists (map (lambda (i)
+							       (with-syntax ([name (car i)]
+									     [ids (cddr i)])
+								 (syntax [name (list . ids)])))
+							     interned-id-lists)]
+				     [(unit-export-list ...) unit-export-lists]
+				     [(import-mapping ...) import-mappings]
+				     [(unit-import-count ...) 
+				      (map (lambda (l) 
+					     (datum->syntax-object
+					      (quote-syntax here)
+					      (apply
+					       +
+					       (map (lambda (v)
+						      (if (identifier? v)
+							  1
+							  (length (cdr (syntax->list v)))))
+						    l))
+					      #f))
+					   linkages)]
+				     [num-imports (datum->syntax-object
+						   (quote-syntax here)
+						   (length imports)
+						   #f)]
+				     [export-names export-names]
+				     [export-mapping export-mapping]
+				     [name (syntax-local-infer-name stx)])
+			 (syntax/loc
+			  stx
+			  (let ([constituent unit-expr]
+				...)
+			    (let ([unit-export-positions
+				   (check-expected-interface 
+                                    'tag
+				    constituent
+				    unit-import-count
+				    'unit-export-list)]
+				  ...)
+			      (make-a-unit
+			       'name
+			       num-imports
+			       (quote export-names)
+			       (lambda ()
+				 (let ([unit-setup ((unit-go constituent))] ...)
+				   (let ([unit-extract
+					  (lambda (pos)
+					    (vector-ref (car unit-setup)
+							(vector-ref unit-export-positions pos)))]
+					 ...
+					 .
+					 interned-integer-lists)
+				     (list (list->vector (append . export-mapping))
+					   (lambda (ivar ...)
+					     (let interned-id-lists
+						 (void) ;; in case there are no units
+					       (apply (list-ref unit-setup 1) 
+						      (append . import-mapping))
+					       ...))))))))))))))))))])))
+
+  ;; ----------------------------------------------------------------------
+  ;; check-unit: used by the expansion of `invoke-unit'
+  
+  (define (check-unit u n)
+    (unless (unit? u)
+      (raise
+       (make-exn:fail:unit
+	(string->immutable-string
+	 (format "invoke-unit: result of unit expression was not a unit: ~e" u))
+	(current-continuation-marks))))
+    (unless (= (unit-num-imports u) n)
+      (raise
+       (make-exn:fail:unit
+	(string->immutable-string
+	 (format "invoke-unit: expected a unit with ~a imports, given one with ~a imports"
+		 n (unit-num-imports u)))
+	(current-continuation-marks)))))
+
+  ;; ----------------------------------------------------------------------
+  ;; The `invoke-unit' syntactic form
+  
+  (define-syntax invoke-unit
+    (lambda (stx)
+      (syntax-case stx (import export)
+	[(_ unit-expr expr ...)
+	 (let ([exprs (syntax (expr ...))])
+	   (with-syntax ([(bx ...) (generate-temporaries (syntax (expr ...)))]
+			 [num (datum->syntax-object
+			       (quote-syntax here)
+			       (length (syntax->list exprs)) 
+			       #f)])
+	     (syntax/loc
+	      stx
+	      (let ([u unit-expr])
+		(check-unit u num)
+		(let ([bx (box expr)] ...)
+		  ((list-ref ((unit-go u)) 1)
+		   bx ...))))))])))
+
+  (define-syntaxes (define-values/invoke-unit
+		     namespace-variable-bind/invoke-unit)
+    (let ([mk
+	   (lambda (global?)
+	     (lambda (stx)
+	       (syntax-case stx ()
+		 [(_ exports unite . prefix+imports)
+		  (let* ([badsyntax (lambda (s why)
+				      (raise-syntax-error
+				       #f
+				       (format "bad syntax (~a)" why)
+				       stx
+				       s))]
+			 [symcheck (lambda (s)
+				     (or (identifier? s)
+					 (badsyntax s "not an identifier")))])
+		    (unless (stx-list? (syntax exports))
+		      (badsyntax (syntax exports) "not a sequence of identifiers"))
+		    (for-each symcheck (syntax->list (syntax exports)))
+		    (let ([prefix (if (stx-null? (syntax prefix+imports))
+				      #f
+				      (stx-car (syntax prefix+imports)))])
+		      (unless (or (not prefix)
+				  (not (syntax-e prefix))
+				  (identifier? prefix))
+			(badsyntax prefix "prefix is not an identifier"))
+		      (for-each symcheck (let ([v (syntax prefix+imports)])
+					   (cond
+					    [(stx-null? v) null]
+					    [(stx-list? v) (cdr (syntax->list v))]
+					    [else
+					     (badsyntax (syntax prefix+imports) "illegal use of `.'")])))
+		      (with-syntax ([(tagged-export ...) 
+				     (if (and prefix (syntax-e prefix))
+					 (let ([prefix (string-append
+							(symbol->string 
+							 (syntax-e prefix))
+						      ":")])
+					   (map (lambda (s)
+						  (datum->syntax-object
+						   s
+						   (string->symbol
+						    (string-append
+						     prefix
+						     (symbol->string (syntax-e s))))
+						   s))
+						(syntax->list (syntax exports))))
+					 (syntax exports))]
+				    [extract-unit (syntax (:unit
+							    (import . exports)
+							    (export)
+							    (values . exports)))])
+			(with-syntax ([invoke-unit (with-syntax ([(x . imports)
+								  (if prefix
+								      (syntax prefix+imports)
+								      `(#f))])
+						     (syntax (invoke-unit
+							      (compound-unit
+							       (import . imports)
+							       (link [unit-to-invoke (unite . imports)]
+								     [export-extractor 
+								      (extract-unit (unit-to-invoke . exports))])
+							       (export))
+							      . imports)))])
+			  (if global?
+			      (syntax (let-values ([(tagged-export ...) invoke-unit])
+					(namespace-set-variable-value! 'tagged-export tagged-export)
+					...
+					(void)))
+			      (syntax (define-values (tagged-export ...) invoke-unit)))))))])))])
+      (values (mk #f) (mk #t))))
+  
+  (provide (rename :unit unit) compound-unit invoke-unit unit?
+	   (struct exn:fail:unit ())
+
+	   define-values/invoke-unit
+	   namespace-variable-bind/invoke-unit))
diff --git a/collects/mzlib/unitsig.ss b/collects/mzlib/unitsig.ss
new file mode 100644
index 0000000000..4fff0b45fa
--- /dev/null
+++ b/collects/mzlib/unitsig.ss
@@ -0,0 +1,348 @@
+
+;; This implementation of `unit/sig' was ported from the old v100
+;; implementation, and then hacked a bit to produce more compact
+;; output, and finally mangled to handle the v200 `struct' (with
+;; compile-time information). It's in dire need of an overhaul.
+
+(module unitsig mzscheme
+  (require "unit.ss")
+  (require "private/sigmatch.ss")
+
+  (require-for-syntax "private/sigutil.ss")
+  (require-for-syntax "private/sigmatch.ss")
+  (require-for-syntax (lib "kerncase.ss" "syntax"))
+
+  (define-struct signed-unit (unit imports exports))
+
+  (define-syntax define-signature
+    (lambda (expr)
+      (syntax-case expr ()
+	[(_ name sig)
+	 (identifier? (syntax name))
+	 (let ([sig (get-sig 'define-signature expr (syntax-e (syntax name))
+			     (syntax sig) #f)])
+	   (with-syntax ([content (explode-sig sig #f)])
+	     (syntax (define-syntax name
+		       (make-sig (quote content))))))])))
+
+  (define-syntax let-signature
+    (lambda (expr)
+      (syntax-case expr ()
+	[(_ name sig . body)
+	 (identifier? (syntax name))
+	 (let ([sig (get-sig 'let-signature expr (syntax-e (syntax name))
+			     (syntax sig) #f)])
+	   (with-syntax ([content (explode-sig sig #f)])
+	     (syntax (letrec-syntax ([name (make-sig (quote content))])
+		       . body))))])))
+  
+  (define-syntax unit/sig
+    (lambda (expr)
+      (syntax-case expr ()
+	[(_ sig . rest)
+	 (let ([sig (get-sig 'unit/sig expr #f (syntax sig) #f)])
+	  (let ([a-unit (parse-unit expr (syntax rest) sig
+				    (kernel-form-identifier-list (quote-syntax here))
+				    (quote-syntax define-values)
+				    (quote-syntax begin))])
+	    (check-signature-unit-body sig a-unit (parsed-unit-renames a-unit) 'unit/sig expr)
+	    (with-syntax ([imports (datum->syntax-object
+				    expr
+				    (flatten-signatures (parsed-unit-imports a-unit) 'must-have-ctx)
+				    expr)]
+			  [exports (datum->syntax-object
+				    expr
+				    (map
+				     (lambda (name)
+				       (list (do-rename name (parsed-unit-renames a-unit))
+					     name))
+				     (signature-vars sig))
+				    expr)]
+			  [body (append
+				 ((parsed-unit-stxes a-unit) expr)
+				 (reverse! (parsed-unit-body a-unit))
+				 ((parsed-unit-stx-checks a-unit) expr))]
+			  [import-sigs (explode-named-sigs (parsed-unit-imports a-unit) #f)]
+			  [export-sig (explode-sig sig #f)])
+	      (syntax/loc expr
+		(make-signed-unit
+		 (unit
+		   (import . imports)
+		   (export . exports)
+		   . body)
+		 (quote import-sigs)
+		 (quote export-sig))))))])))
+
+  (define-syntax compound-unit/sig
+    (lambda (expr)
+      (syntax-case expr ()
+	[(_ . body)
+	 (let-values ([(tags
+			exprs
+			exploded-link-imports
+			exploded-link-exports
+			flat-imports
+			link-imports
+			flat-exports
+			exploded-imports
+			exploded-exports
+			boxed-interned-symbol-vectors)
+		       (parse-compound-unit expr (syntax body))]
+		      [(t) (lambda (l) (datum->syntax-object expr l expr))])
+	   (with-syntax ([(tag ...) (t tags)]
+			 [(uexpr ...) (t exprs)]
+			 [(tagx ...) (t (map (lambda (t) (string->symbol (format "u:~a" t))) tags))]
+			 [exploded-link-imports (t exploded-link-imports)]
+			 [exploded-link-exports (t exploded-link-exports)]
+			 [flat-imports (t flat-imports)]
+			 [(link-import ...) (t link-imports)]
+			 [flat-exports (t flat-exports)]
+			 [exploded-imports (t exploded-imports)]
+			 [exploded-exports (t exploded-exports)]
+			 [interned-vectors (t (map (lambda (x) `(,(car x) (quote ,(cadr x))))
+						   (unbox boxed-interned-symbol-vectors)))])
+	     (syntax/loc
+	      expr
+	      (let ([tagx uexpr] ... . interned-vectors)
+		(verify-linkage-signature-match
+		 'compound-unit/sig
+		 '(tag ...)
+		 (list tagx ...)
+		 `exploded-link-imports
+		 `exploded-link-exports)
+		;; All checks done. Make the unit:
+		(make-signed-unit
+		 (compound-unit
+		  (import . flat-imports)
+		  (link [tag ((signed-unit-unit tagx)
+			      . link-import)]
+			...)
+		  (export . flat-exports))
+		 `exploded-imports
+		 `exploded-exports)))))])))
+
+  (define-syntax invoke-unit/sig
+    (lambda (expr)
+      (syntax-case expr ()
+	[(_ u sig ...)
+	 (let ([sigs (parse-invoke-vars 'invoke-unit/sig (syntax (sig ...)) expr)])
+	   (with-syntax ([exploded-sigs (datum->syntax-object
+					 expr
+					 (explode-named-sigs sigs #f)
+					 expr)]
+			 [flat-sigs (datum->syntax-object
+				     expr
+				     (flatten-signatures sigs #f) 
+				     expr)])
+	     (syntax/loc
+	      expr
+	      (let ([unt u])
+		(verify-linkage-signature-match
+		 (quote invoke-unit/sig)
+		 (quote (invoke))
+		 (list unt)
+		 (quote ((#() . #())))
+		 (quote (exploded-sigs)))
+		(invoke-unit (signed-unit-unit unt)
+			     . flat-sigs)))))])))
+  
+  (define-syntax unit->unit/sig
+    (lambda (expr)
+      (syntax-case expr ()
+	[(_ e (im-sig ...) ex-sig)
+	 (let ([im-sigs (map (lambda (sig)
+			       (get-sig 'unit->unit/sig expr #f sig #f))
+			     (syntax->list (syntax (im-sig ...))))]
+	       [ex-sig (get-sig 'unit->unit/sig expr #f (syntax ex-sig) #f)])
+	   (with-syntax ([exploded-imports (datum->syntax-object
+					    expr
+					    (explode-named-sigs im-sigs #f)
+					    expr)]
+			 [exploded-exports (datum->syntax-object
+					    expr
+					    (explode-sig ex-sig #f)
+					    expr)])
+	     (syntax
+	      (make-signed-unit
+	       e
+	       (quote exploded-imports)
+	      (quote exploded-exports)))))])))
+
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (define verify-linkage-signature-match
+    (let ([make-exn make-exn:fail:unit]
+	  [p-suffix (lambda (pos) (case pos [(1) 'st][(2) 'nd][(3) 'rd][else 'th]))])
+      (lambda (who tags units esigs isigs)
+	(for-each
+	 (lambda (u tag)
+	   (unless (signed-unit? u)
+	     (raise
+	      (make-exn
+	       (string->immutable-string
+		(format
+		 "~s: expression for \"~s\" is not a signed unit: ~e"
+		 who tag u))
+	       (current-continuation-marks)))))
+	 units tags)
+	(for-each
+	 (lambda (u tag esig)
+	   (verify-signature-match
+	    who #f
+	    (format "specified export signature for ~a" tag)
+	    esig
+	    (format "export signature for actual ~a sub-unit" tag)
+	    (signed-unit-exports u)))
+	 units tags esigs)
+	(for-each
+	 (lambda (u tag isig)
+	   (let ([n (length (signed-unit-imports u))]
+		 [c (length isig)])
+	     (unless (= c n)
+	       (raise
+		(make-exn
+		 (string->immutable-string
+		  (format
+		   "~s: ~a unit imports ~a units, but ~a units were provided"
+		   who tag n c))
+		 (current-continuation-marks))))))
+	 units tags isigs)
+	(for-each
+	 (lambda (u tag isig)
+	   (let loop ([isig isig][expecteds (signed-unit-imports u)][pos 1])
+	     (unless (null? isig)
+	       (let ([expected (car expecteds)]
+		     [provided (car isig)])
+		 (verify-signature-match
+		  who #t
+		  (format "~a unit's ~s~s import (which is ~a)" tag
+			  pos (p-suffix pos)
+			  (car expected))
+		  (cdr expected)
+		  (format "~a's ~s~s linkage (which is ~a)"
+			  tag
+			  pos (p-suffix pos)
+			  (car provided))
+		  (cdr provided))
+		 (loop (cdr isig) (cdr expecteds) (add1 pos))))))
+	 units tags isigs))))
+
+  (define-syntax signature->symbols
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ name)
+	 (identifier? (syntax name))
+	 (let ([sig (get-sig 'signature->symbols stx #f (syntax name) #f)])
+	   (with-syntax ([e (let cleanup ([p (explode-sig sig #f)])
+			      ;; Strip struct info:
+			      (list->vector 
+			       (map (lambda (i)
+				      (if (symbol? i)
+					  i
+					  (cons (car i) (cleanup (cdr i)))))
+				    (vector->list (car p)))))])
+	     (syntax 'e)))])))
+
+  ;; Internal:
+  (define-syntax do-define-values/invoke-unit/sig
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ global? signame unite prefix imports orig)
+	 (let* ([formname (if (syntax-e (syntax global?))
+			      'namespace-variable-bind/invoke-unit/sig
+			      'define-values/invoke-unit/sig)]
+		[badsyntax (lambda (s why)
+			     (raise-syntax-error
+			      #f
+			      (format "bad syntax (~a)" why)
+			      (syntax orig)
+			      s))])
+	   (unless (or (not (syntax-e (syntax prefix)))
+		       (identifier? (syntax prefix)))
+	     (badsyntax (syntax prefix) "prefix is not an identifier"))
+	   (let ([ex-sig (get-sig formname (syntax orig) #f (syntax signame) (syntax signame))])
+	     (let ([ex-exploded (explode-sig ex-sig #f)]
+		   [ex-flattened (flatten-signature #f ex-sig #'signame)])
+	       (let ([im-sigs
+		      (parse-invoke-vars formname (syntax imports) (syntax orig))])
+		 (let ([im-explodeds (explode-named-sigs im-sigs #f)]
+		       [im-flattened (flatten-signatures im-sigs #f)]
+		       [d->s (lambda (x) (datum->syntax-object (syntax orig) x (syntax orig)))])
+		   (with-syntax ([dv/iu (if (syntax-e (syntax global?))
+					    (quote-syntax namespace-variable-bind/invoke-unit)
+					    (quote-syntax define-values/invoke-unit))]
+				 [ex-flattened ex-flattened]
+				 [ex-exploded (d->s ex-exploded)]
+				 [im-explodeds (d->s im-explodeds)]
+				 [im-flattened (d->s im-flattened)]
+				 [formname formname]
+				 [stx-decls (if (syntax-e (syntax global?))
+						null
+						(make-struct-stx-decls ex-sig #f #f (syntax signame) #f))])
+		     (syntax/loc stx
+		       (begin
+			 (dv/iu
+			  ex-flattened
+			  (let ([unit-var unite])
+			    (verify-linkage-signature-match
+			     'formname
+			     '(invoke)
+			     (list unit-var)
+			     '(ex-exploded)
+			     '(im-explodeds))
+			    (signed-unit-unit unit-var))
+			  prefix
+			  . im-flattened)
+			 . stx-decls))))))))])))
+  
+  (define-syntax define-values/invoke-unit/sig
+    (lambda (stx)
+      (with-syntax ([orig stx])
+	(syntax-case stx ()
+	  [(_ signame unit prefix . imports)
+	   (syntax (do-define-values/invoke-unit/sig #f signame unit prefix imports orig))]
+	  [(_ signame unit)
+	   (syntax (do-define-values/invoke-unit/sig #f signame unit #f () orig))]))))
+
+  (define-syntax namespace-variable-bind/invoke-unit/sig
+    (lambda (stx)
+      (with-syntax ([orig stx])
+	(syntax-case stx ()
+	  [(_ signame unit prefix . imports)
+	   (syntax (do-define-values/invoke-unit/sig #t signame unit prefix imports orig))]
+	  [(_ signame unit)
+	   (syntax (do-define-values/invoke-unit/sig #t signame unit #f () orig))]))))
+
+  (define-syntax provide-signature-elements
+    (lambda (stx)
+      (with-syntax ([orig stx])
+	(syntax-case stx ()
+	  [(_ signame)
+	   (let ([sig (get-sig 'provide-signature-elements stx #f (syntax signame) (syntax signame))])
+	     (let ([flattened (flatten-signature #f sig (syntax signame))]
+		   [structs (map struct-def-name (signature-structs sig))])
+	       (with-syntax ([flattened (map (lambda (x) (datum->syntax-object (syntax signame) x #f))
+					     (append flattened structs))])
+		 (syntax/loc stx
+		   (provide . flattened)))))]))))
+  
+  (define (unit/sig? x) (signed-unit? x))
+  (define (unit/sig->unit x) (signed-unit-unit x))
+
+  (provide define-signature
+	   let-signature
+	   unit/sig
+	   compound-unit/sig
+	   invoke-unit/sig
+	   unit->unit/sig
+	   signature->symbols
+	   verify-signature-match
+	   verify-linkage-signature-match
+
+	   (struct signed-unit (unit imports exports))
+	   unit/sig? unit/sig->unit
+	   
+	   define-values/invoke-unit/sig
+	   namespace-variable-bind/invoke-unit/sig
+	   provide-signature-elements))
+
diff --git a/collects/mzscheme/examples/README b/collects/mzscheme/examples/README
new file mode 100644
index 0000000000..9791740460
--- /dev/null
+++ b/collects/mzscheme/examples/README
@@ -0,0 +1,55 @@
+This directory contains a few example MzScheme extensions. Most
+examples are implemented directly in C. A few examples listed at the
+end use the mzc `c-lambda', etc. forms.
+
+ * hello.c - returns the string "Hello, World!". Demonstrates creating
+   a Scheme value. (Works with 3m.)
+
+ * fmod.c - defines the `fmod' procedure, which calculates modulo on
+   floating-point numbers. Demonstrates creating Scheme procedures
+   from C and adding top-level definitions. (Works with 3m.)
+
+ * curses.c - links MzScheme to the curses library. Demonstrates more
+   procedures and definitions, a little more type dispatching, and
+   returning multiple values. (Works with 3m.)
+
+ * makeadder.c - defines `make-adder', which takes a number and
+   returns a procedure that takes another number to add to
+   it. Demonstrates closure creation in C, getting Scheme global
+   values, and calling Scheme procedures from C.
+
+   makeadder3m.c - the same, but works with 3m. Making the code
+   work with 3m requires several changes.
+
+ * catch.c - defined `eval-string/catch-error', which catches
+   excpetions whil evaluating a string. Demonstrates how to catch
+   exceptions from C code. (Does not work with 3m.)
+
+ * bitmatrix.c - implements two-dimentional bit matrixes with some
+   operations. Demonstrates defining a new Scheme data type, data
+   allocation, fancy integer type checking, general exception raising,
+   and registering static variables. (Does not work with 3m.)
+
+ * idmodule.c - Declares the module named `idmodule' that provides an
+   `identity' function. Demonstrates implementing a primitive module
+   in C. (Does not work with 3m.)
+
+ * helloprint.c - prints "Hello, World!" directly to the current
+   output port rather than relying on the read-eval-print-loop.
+   Demonstrates using built-in Scheme parameter values from C.  (Does
+   not work with 3m.)
+
+ * tree.cxx, tree-finish.ss - shows how to inject a C++ class into
+   MzLib's class.ss world. (Does not work with 3m.)
+
+
+ * fmod-ez.ss - same as fmod.c, but with 10% of the code. Demonstrates
+   `c-lambda'. (Does not work with 3m.)
+
+ * cfile.ss - simple (and unsafe) glue to the fopen(), fread(),
+   fwrite(), and fclose() C library functions. Demonstrates the use of
+   `(pointer ...)' types. (Does not work with 3m.)
+
+ * msgbox.ss - a Windows-only example, provides a `message-box'
+   procedure. Demonstrates some of the limitations of `c-lambda' and
+   how to work around them. (Does not work with 3m.)
diff --git a/collects/mzscheme/examples/bitmatrix.c b/collects/mzscheme/examples/bitmatrix.c
new file mode 100644
index 0000000000..27653db323
--- /dev/null
+++ b/collects/mzscheme/examples/bitmatrix.c
@@ -0,0 +1,305 @@
+/* 
+
+   This extension Defines a new type of Scheme data: a two-dimensional
+   matrix of bits.
+   
+   A client using this extension would look something like this:
+
+      (load-extension "bitmatrix.so")
+      (define bm (make-bit-matrix 1000 1000))
+      ...
+      (bit-matrix-set! bm 500 500 #t)
+      ...
+      (if (bit-matrix-get bm 500 500) ...)
+      ...
+
+*/
+
+#include "escheme.h"
+
+/* Instances of this Bitmatrix structure will be the Scheme bit matirx
+   values: */
+typedef struct {
+  Scheme_Type type; /* Every Scheme value starts with a type tag.  The
+		       format for the rest of the structure is
+		       anything we want it to be. */
+  unsigned long w, h, l; /* l = w rounded to multiple of LONG_SIZE */
+  unsigned long *matrix;
+} Bitmatrix;
+
+/* We'll get some Scheme primitives so we can calculate with numbers
+   taht are potentially bignums: */
+static Scheme_Object *mult, *add, *sub, *modulo, *neg;
+
+/* The type tag for bit matrixes, initialized with scheme_make_type */
+static Scheme_Type bitmatrix_type;
+
+#define LONG_SIZE 32
+#define LOG_LONG_SIZE 5
+#define LONG_SIZE_PER_BYTE 4
+
+# define FIND_BIT(p) (1 << (p & (LONG_SIZE - 1)))
+
+/* Helper function to check whether an integer (fixnum or bignum) is
+   negative: */
+static int negative(Scheme_Object *o)
+{
+  return SCHEME_TRUEP(_scheme_apply(neg, 1, &o));
+}
+
+/* Scheme procedure to make a bit matrix: */
+Scheme_Object *make_bit_matrix(int argc, Scheme_Object **argv)
+{
+  Scheme_Object *size, *rowlength, *a[2];
+  unsigned long w, h, s, l;
+  Bitmatrix *bm;
+
+  /* Really fancy: we allow any kind of positive integer for
+     specifying the size of a bit matrix. If we get a bignum (or the
+     resulting matrix size is a bignum), we'll signal an out-of-memory
+     exception. */
+  if ((!SCHEME_INTP(argv[0])  && !SCHEME_BIGNUMP(argv[0]))
+      || negative(argv[0]))
+    scheme_wrong_type("make-bit-matrix", "positive integer", 0, argc, argv);
+  if ((!SCHEME_INTP(argv[1])  && !SCHEME_BIGNUMP(argv[1]))
+      || (negative(argv[1])))
+    scheme_wrong_type("make-bit-matrix", "positive integer", 1, argc, argv);
+
+  a[0] = argv[0];
+  a[1] = scheme_make_integer(LONG_SIZE - 1);
+  /* Apply the Scheme `add' procedure to argv[0] and argv[1]. Note the
+     "_" in "_scheme_apply"; that's a lot faster than "scheme_apply",
+     and we know that no continuation jumps will occur (although it
+     would be fine if one did. */
+  a[0] = _scheme_apply(add, 2, a);
+  a[1] = scheme_make_integer(LONG_SIZE);
+  a[1] = _scheme_apply(modulo, 2, a);
+  a[0] = _scheme_apply(sub, 2, a);
+  rowlength = a[0];
+  a[1] = argv[1];
+  size = _scheme_apply(mult, 2, a);
+  if (SCHEME_BIGNUMP(size))
+    /* Use scheme_raise_exn to raise exceptions. The first argument
+       describes the type of the exception. After an exception-specific
+       number of Scheme values (none in this case), the rest of the
+       arguments are like printf. */
+    scheme_raise_exn(MZEXN_FAIL, "make-bit-matrix: out of memory");
+  
+  s = SCHEME_INT_VAL(size);
+  w = SCHEME_INT_VAL(argv[0]);
+  h = SCHEME_INT_VAL(argv[1]);
+  l = SCHEME_INT_VAL(rowlength);
+
+  /* Malloc the bit matrix structure. Since we use scheme_malloc, the
+     bit matrix value is GC-able. */
+  bm = (Bitmatrix *)scheme_malloc(sizeof(Bitmatrix));
+  bm->type = bitmatrix_type;
+
+  /* Try to allocate the bit matrix. Handle failure gracefully. Note
+     that we use scheme_malloc_atomic since the allocated memory will
+     never contain pointers to GC-allocated memory. */
+  s = ((s + LONG_SIZE - 1) >> LOG_LONG_SIZE);
+  bm->matrix = (unsigned long *)scheme_malloc_fail_ok(scheme_malloc_atomic, 
+						      sizeof(long) * s);
+  if (!bm->matrix)
+    scheme_raise_exn(MZEXN_FAIL, "make-bit-matrix: out of memory");
+
+  bm->w = w;
+  bm->h = h;
+  bm->l = l;
+
+  /* Init matirx to all 0s: */
+  while (s--)
+    bm->matrix[s] = 0;
+
+  return (Scheme_Object *)bm;
+}
+
+/* Internal utility function for error-checking with a fancy error
+   message: */
+static void range_check_one(char *name, char *which, 
+			    int l, int h, int startpos, 
+			    int argc, Scheme_Object **argv)
+{
+  int bad1;
+
+  if (SCHEME_BIGNUMP(argv[startpos])) {
+    bad1 = 1;
+  } else {
+    int v = SCHEME_INT_VAL(argv[startpos]);
+    bad1 = ((v < l) || (v > h));
+  }
+
+  if (bad1) {
+    /* A mismatch exception requires one Scheme value, so we provide
+       it before the printf string: */
+    char *args;
+    long argslen;
+
+    args = scheme_make_args_string("other ", startpos, argc, argv, &argslen);
+    scheme_raise_exn(MZEXN_FAIL_CONTRACT,
+		     "%s: %s index %s is not in the range [%d,%d]%t",
+		     name, which,
+		     scheme_make_provided_string(argv[startpos], 1, NULL),
+		     l, h,
+		     args,
+		     argslen);
+  }
+}
+
+/* Internal utility function that implements most of the work of the
+   get- and set- Scheme procedures: */
+static Scheme_Object *do_bit_matrix(char *name, int get, int argc, Scheme_Object **argv)
+{
+  Bitmatrix *bm;
+  unsigned long x, y, p, v, m;
+
+  if (SCHEME_TYPE(argv[0]) != bitmatrix_type)
+    scheme_wrong_type(name, "bit-matrix", 0, argc, argv);
+  if (!SCHEME_INTP(argv[1])  && !SCHEME_BIGNUMP(argv[1]))
+    scheme_wrong_type(name, "integer", 1, argc, argv);
+  if (!SCHEME_INTP(argv[2])  && !SCHEME_BIGNUMP(argv[2]))
+    scheme_wrong_type(name, "integer", 2, argc, argv);
+
+  /* After checking that argv[0] has te bitmatrix_type tag, we can safely perform
+     a cast to Bitmatrix*: */
+  bm = (Bitmatrix *)argv[0];
+
+  range_check_one(name, "first", 0, bm->w - 1, 1, argc, argv);
+  range_check_one(name, "second", 0, bm->h - 1, 2, argc, argv);
+
+  x = SCHEME_INT_VAL(argv[1]);
+  y = SCHEME_INT_VAL(argv[2]);
+
+  p = y * bm->l + x;
+  m = FIND_BIT(p);
+  v = bm->matrix[p >> LOG_LONG_SIZE];
+  if (get) {
+    return (v & m) ? scheme_true : scheme_false;
+  } else {
+    if (SCHEME_TRUEP(argv[3]))
+      bm->matrix[p >> LOG_LONG_SIZE] = (v | m);
+    else
+      bm->matrix[p >> LOG_LONG_SIZE] = (v - (v & m));
+    return scheme_void;
+  }
+}
+
+/* Scheme procedure: get a bit from the matrix */
+Scheme_Object *bit_matrix_get(int argc, Scheme_Object **argv)
+{
+  return do_bit_matrix("bit-matrix-get", 1, argc, argv);
+}
+
+/* Scheme procedure: set a bit in the matrix */
+Scheme_Object *bit_matrix_set(int argc, Scheme_Object **argv)
+{
+  return do_bit_matrix("bit-matrix-set!", 0, argc, argv);
+}
+
+/* Scheme procedure: invert the whole matrix */
+Scheme_Object *bit_matrix_invert(int argc, Scheme_Object **argv)
+{
+  Bitmatrix *bm;
+  unsigned long i;
+
+  if (SCHEME_TYPE(argv[0]) != bitmatrix_type)
+    scheme_wrong_type("bit-matrix-invert!", "bit-matrix", 0, argc, argv);
+
+  bm = (Bitmatrix *)argv[0];
+
+  i = (bm->l * bm->h) >> LOG_LONG_SIZE;
+  while (i--)
+    bm->matrix[i] = ~bm->matrix[i];
+
+  return scheme_void;
+}
+
+/* Scheme procedure: clear the whole matrix */
+Scheme_Object *bit_matrix_clear(int argc, Scheme_Object **argv)
+{
+  char *name = "bit-matrix-clear!";
+  Bitmatrix *bm;
+  unsigned long i;
+
+  if (SCHEME_TYPE(argv[0]) != bitmatrix_type)
+    scheme_wrong_type(name, "bit-matrix", 0, argc, argv);
+
+  bm = (Bitmatrix *)argv[0];
+
+  i = (bm->l * bm->h) >> LOG_LONG_SIZE;
+  while (i--)
+    bm->matrix[i] = 0;
+
+  return scheme_void;
+}
+
+Scheme_Object *scheme_reload(Scheme_Env *env)
+{
+  /* Define our new primitives: */
+
+  scheme_add_global("make-bit-matrix",
+		    scheme_make_prim_w_arity(make_bit_matrix,
+					     "make-bit-matrix",
+					     2, 2),
+		    env);
+
+  scheme_add_global("bit-matrix-get",
+		    scheme_make_prim_w_arity(bit_matrix_get,
+					     "bit-matrix-get",
+					     3, 3),
+		    env);
+
+  scheme_add_global("bit-matrix-set!",
+		    scheme_make_prim_w_arity(bit_matrix_set,
+					     "bit-matrix-set!",
+					     4, 4),
+		    env);
+
+  scheme_add_global("bit-matrix-invert!",
+		    scheme_make_prim_w_arity(bit_matrix_invert,
+					     "bit-matrix-invert!",
+					     1, 1),
+		    env);
+
+  scheme_add_global("bit-matrix-clear!",
+		    scheme_make_prim_w_arity(bit_matrix_clear,
+					     "bit-matrix-clear!",
+					     1, 1),
+		    env);
+
+  return scheme_void;
+}
+
+Scheme_Object *scheme_initialize(Scheme_Env *env)
+{
+  bitmatrix_type = scheme_make_type("<bit-matrix>");
+
+  /* Get some Scheme primitives. Conservative garbage collection sees
+     any local variables we use within a function, but we have to register
+     static variables: */
+
+  scheme_register_extension_global(&mult, sizeof(Scheme_Object*));
+  mult = scheme_builtin_value("*");
+
+  scheme_register_extension_global(&add, sizeof(Scheme_Object*));
+  add = scheme_builtin_value("+");
+
+  scheme_register_extension_global(&sub, sizeof(Scheme_Object*));
+  sub = scheme_builtin_value("-");
+
+  scheme_register_extension_global(&modulo, sizeof(Scheme_Object*));
+  modulo = scheme_builtin_value("modulo");
+
+  scheme_register_extension_global(&neg, sizeof(Scheme_Object*));
+  neg = scheme_builtin_value("negative?");
+
+  return scheme_reload(env);
+}
+
+
+Scheme_Object *scheme_module_name()
+{
+  /* This extension doesn't define a module: */
+  return scheme_false;
+}
diff --git a/collects/mzscheme/examples/catch.c b/collects/mzscheme/examples/catch.c
new file mode 100644
index 0000000000..e1c347c5ba
--- /dev/null
+++ b/collects/mzscheme/examples/catch.c
@@ -0,0 +1,143 @@
+/* 
+   MzScheme extension example that catches exceptions and extracts
+   error messages.
+
+   The defined function is `eval-string/catch-error', which takes a
+   string and evaluates it, returning either the value, a string for
+   the error message, and a non-exn value raised by the expression.
+
+  > (eval-string/catch-error "10")
+  10
+
+  > (eval-string/catch-error "(+ 'a)")
+  "+: expects argument of type <number>; given a"
+
+  > (eval-string/catch-error "(raise 'ack)")
+  ack
+
+*/
+
+#include "escheme.h"
+
+/*********************************************************************/
+/* Exception-catching code                                           */
+/*********************************************************************/
+
+/* These must be registered with the memory manager: */
+static Scheme_Object *exn_catching_apply, *exn_p, *exn_message;
+
+static void init_exn_catching_apply()
+{
+  if (!exn_catching_apply) {
+    char *e = 
+      "(lambda (thunk) "
+	"(with-handlers ([void (lambda (exn) (cons #f exn))]) "
+	  "(cons #t (thunk))))";
+    /* make sure we have a namespace with the standard bindings: */
+    Scheme_Env *env = (Scheme_Env *)scheme_make_namespace(0, NULL);
+
+    scheme_register_extension_global(&exn_catching_apply, sizeof(Scheme_Object *));
+    scheme_register_extension_global(&exn_p, sizeof(Scheme_Object *));
+    scheme_register_extension_global(&exn_message, sizeof(Scheme_Object *));
+    
+    exn_catching_apply = scheme_eval_string(e, env);
+    exn_p = scheme_lookup_global(scheme_intern_symbol("exn?"), env);
+    exn_message = scheme_lookup_global(scheme_intern_symbol("exn-message"), env);
+  }
+}
+
+/* This function applies a thunk, returning the Scheme value if there's no exception, 
+   otherwise returning NULL and setting *exn to the raised value (usually an exn 
+   structure). */
+Scheme_Object *_apply_thunk_catch_exceptions(Scheme_Object *f, Scheme_Object **exn)
+{
+  Scheme_Object *v;
+
+  init_exn_catching_apply();
+  
+  v = _scheme_apply(exn_catching_apply, 1, &f);
+  /* v is a pair: (cons #t value) or (cons #f exn) */
+
+  if (SCHEME_TRUEP(SCHEME_CAR(v)))
+    return SCHEME_CDR(v);
+  else {
+    *exn = SCHEME_CDR(v);
+    return NULL;
+  }
+}
+
+Scheme_Object *extract_exn_message(Scheme_Object *v)
+{
+  init_exn_catching_apply();
+
+  if (SCHEME_TRUEP(_scheme_apply(exn_p, 1, &v)))
+    return _scheme_apply(exn_message, 1, &v);
+  else
+    return NULL; /* Not an exn structure */
+}
+
+/*********************************************************************/
+/* Use of example exception-catching code                            */
+/*********************************************************************/
+
+static Scheme_Object *do_eval(void *s, int noargc, Scheme_Object **noargv)
+{
+  return scheme_eval_string((char *)s, scheme_get_env(NULL));
+}
+
+static Scheme_Object *eval_string_or_get_exn_message(char *s)
+{
+  Scheme_Object *v, *exn;
+
+  v = _apply_thunk_catch_exceptions(scheme_make_closed_prim(do_eval, s), &exn);
+  /* Got a value? */
+  if (v)
+    return v;
+
+  v = extract_exn_message(exn);
+  /* Got an exn? */
+  if (v)
+    return v;
+
+  /* `raise' was called on some arbitrary value */
+  return exn;
+}
+
+static Scheme_Object *catch_eval_error(int argc, Scheme_Object **argv)
+{
+  Scheme_Object *bs;
+
+  if (!SCHEME_CHAR_STRINGP(argv[0]))
+    scheme_wrong_type("eval-string/catch-error", "string", 0, argc, argv);
+
+  bs = scheme_char_string_to_byte_string(argv[0]);
+  
+  return eval_string_or_get_exn_message(SCHEME_BYTE_STR_VAL(bs));
+}
+
+/*********************************************************************/
+/* Initialization                                                    */
+/*********************************************************************/
+
+Scheme_Object *scheme_reload(Scheme_Env *env)
+{
+  scheme_add_global("eval-string/catch-error",
+		    scheme_make_prim_w_arity(catch_eval_error,
+					     "eval-string/catch-error", 
+					     1, 1),
+		    env);
+
+  return scheme_void;
+}
+
+Scheme_Object *scheme_initialize(Scheme_Env *env)
+{
+  /* First load is same as every load: */
+  return scheme_reload(env);
+}
+
+Scheme_Object *scheme_module_name()
+{
+  /* This extension doesn't define a module: */
+  return scheme_false;
+}
diff --git a/collects/mzscheme/examples/cfile.ss b/collects/mzscheme/examples/cfile.ss
new file mode 100644
index 0000000000..fb361802e7
--- /dev/null
+++ b/collects/mzscheme/examples/cfile.ss
@@ -0,0 +1,16 @@
+
+;; Direct access to fopen, fread, fwrite, and fclose. The interface is
+;;  not remotely safe, since #f is accepted (and converted to NULL)
+;;  for `(pointer "FILE")' arguments. Also, blocking reads or writes
+;;  will block all MzScheme threads.
+
+(c-declare "#include <stdio.h>")
+
+(define fopen
+  (c-lambda (char-string char-string) (pointer "FILE") "fopen"))
+(define fread
+  (c-lambda (char-string long long (pointer "FILE")) long "fread"))
+(define fwrite
+  (c-lambda (char-string long long (pointer "FILE")) long "fwrite"))
+(define fclose
+  (c-lambda ((pointer "FILE")) int "fclose"))
diff --git a/collects/mzscheme/examples/curses-demo.ss b/collects/mzscheme/examples/curses-demo.ss
new file mode 100644
index 0000000000..1056e4cc11
--- /dev/null
+++ b/collects/mzscheme/examples/curses-demo.ss
@@ -0,0 +1,23 @@
+
+; Uses the curses.so extension. Run with
+;    mzscheme -r curses-demo.ss
+
+; To get append-extension-suffix, which adds .so or .ddl as
+; approrpiate for the current platform:
+(require (lib "file.ss" "dynext"))
+
+; Load the curses extension
+(load-extension (append-extension-suffix "curses"))
+
+; Screen is initialize. Let's go!
+(move 8 10)
+(put "Hello, World!")
+(put #\newline)
+(put "Hit any key to continue.")
+(refresh)
+
+(get)
+
+
+
+
diff --git a/collects/mzscheme/examples/curses.c b/collects/mzscheme/examples/curses.c
new file mode 100644
index 0000000000..fa20e21f18
--- /dev/null
+++ b/collects/mzscheme/examples/curses.c
@@ -0,0 +1,130 @@
+/*
+  Extension that uses the curses library.
+
+  Link the extension to the curses library like this:
+     mzc --ld hello.so hello.o -lcurses
+
+  For obvious reasons, this library doesn't interact well
+  with MzScheme's read-eval-print loop. The example file
+  curses-demo.ss demos this extension.
+*/
+
+#include "escheme.h"
+#include <curses.h>
+
+/**************************************************/
+
+static Scheme_Object *sch_clear(int argc, Scheme_Object **argv)
+{
+  clear();
+}
+
+static Scheme_Object *sch_put(int argc, Scheme_Object **argv)
+{
+  /* Puts a char or string on the screen */
+  if (SCHEME_CHARP(argv[0]))
+    addch(SCHEME_CHAR_VAL(argv[0]));
+  else if (SCHEME_BYTE_STRINGP(argv[0]))
+    addstr(SCHEME_BYTE_STR_VAL(argv[0]));
+  else if (SCHEME_CHAR_STRINGP(argv[0])) {
+    Scheme_Object *bs;
+    bs = scheme_char_string_to_byte_string(argv[0]);
+    addstr(SCHEME_BYTE_STR_VAL(bs));
+  } else
+    scheme_wrong_type("put", "character, string, or byte string", 0, argc, argv);
+
+  return scheme_void;
+}
+
+static Scheme_Object *sch_get(int argc, Scheme_Object **argv)
+{
+  /* Gets keyboard input */
+  int c = getch();
+  return scheme_make_character(c);
+}
+
+static Scheme_Object *sch_move(int argc, Scheme_Object **argv)
+{
+  /* Move the output cursor */
+  if (!SCHEME_INTP(argv[0]))
+    scheme_wrong_type("move", "exact integer", 0, argc, argv);
+  if (!SCHEME_INTP(argv[1]))
+    scheme_wrong_type("move", "exact integer", 1, argc, argv);
+
+  move(SCHEME_INT_VAL(argv[0]), SCHEME_INT_VAL(argv[1]));
+
+  return scheme_void;
+}
+
+static Scheme_Object *sch_get_size(int argc, Scheme_Object **argv)
+{
+  /* Returns two values */
+  int w, h;
+  Scheme_Object *a[2];
+
+  w = getmaxx(stdscr);
+  h = getmaxy(stdscr);
+
+  a[0] = scheme_make_integer(w);
+  a[1] = scheme_make_integer(h);
+  return scheme_values(1, a);
+}
+
+static Scheme_Object *sch_refresh(int argc, Scheme_Object **argv)
+{
+  refresh();
+  return scheme_void;
+}
+
+/**************************************************/
+
+Scheme_Object *scheme_reload(Scheme_Env *env)
+{
+  /* The MZ_GC... lines are for for 3m, because env is live across an
+     allocating call. They're not needed for plain old (conservatively
+     collected) Mzscheme. See makeadder3m.c for more info. */
+  Scheme_Object *v;
+  MZ_GC_DECL_REG(1);
+  MZ_GC_VAR_IN_REG(0, env);
+  MZ_GC_REG();
+
+  v = scheme_make_prim_w_arity(sch_clear, "clear", 0, 0),
+  scheme_add_global("clear", v, env);
+
+  v = scheme_make_prim_w_arity(sch_put, "put", 1, 1);
+  scheme_add_global("put", v, env);
+
+  v = scheme_make_prim_w_arity(sch_get, "get", 0, 0);
+  scheme_add_global("get", v, env);
+
+  v = scheme_make_prim_w_arity(sch_move, "move", 2, 2);
+  scheme_add_global("move", v, env);
+
+  v = scheme_make_prim_w_arity(sch_get_size, "get-size", 0, 0);
+  scheme_add_global("get-size", v, env);
+
+  v = scheme_make_prim_w_arity(sch_refresh, "refresh", 0, 0);
+  scheme_add_global("refresh", v, env);
+
+  MZ_GC_UNREG();
+
+  return scheme_void;
+}
+
+Scheme_Object *scheme_initialize(Scheme_Env *env)
+{
+  /* The first time we're loaded, initialize the screen: */
+  initscr();
+  cbreak();
+  noecho();
+  atexit(endwin);
+
+  /* Then do the usual stuff: */
+  return scheme_reload(env);
+}
+
+Scheme_Object *scheme_module_name()
+{
+  /* This extension doesn't define a module: */
+  return scheme_false;
+}
diff --git a/collects/mzscheme/examples/fmod-ez.ss b/collects/mzscheme/examples/fmod-ez.ss
new file mode 100644
index 0000000000..823a276233
--- /dev/null
+++ b/collects/mzscheme/examples/fmod-ez.ss
@@ -0,0 +1,4 @@
+
+(c-declare "#include <math.h>")
+
+(define fmod (c-lambda (double double) double "fmod"))
diff --git a/collects/mzscheme/examples/fmod.c b/collects/mzscheme/examples/fmod.c
new file mode 100644
index 0000000000..70b4324421
--- /dev/null
+++ b/collects/mzscheme/examples/fmod.c
@@ -0,0 +1,76 @@
+/*
+  Extension that defines fmod, modulo on floating-point numbers.
+  The extension is equivalent to Scheme source of them form:
+    (define (fmod a b) ...)
+*/
+
+#include "escheme.h"
+#include <math.h>
+
+/**************************************************/
+
+/* Every C implementation of a Scheme function takes argc and an array
+   of Scheme_Object* values for argv, and returns a Scheme_Object*: */
+static Scheme_Object *sch_fmod(int argc, Scheme_Object **argv)
+{
+  /* Because we'll use scheme_make_prim_w_arity, MzScheme will
+     have already checked that we're getting the right number of
+     arguments. */
+  Scheme_Object *a = argv[0], *b = argv[1];
+  double v;
+
+  /* Make sure we got real numbers, and complain if not: */
+  if (!SCHEME_REALP(a))
+    scheme_wrong_type("fmod", "real number", 0, argc, argv);
+  /*                       1st arg wrong ----^ */
+  if (!SCHEME_REALP(b))
+    scheme_wrong_type("fmod", "real number", 1, argc, argv);
+  /*                       2nd arg wrong ----^ */
+
+  /* Convert the Scheme numbers to double-precision floating point
+     numbers, and compute fmod: */
+  v = fmod(scheme_real_to_double(a),
+	   scheme_real_to_double(b));
+
+  /* Return the result, packaging it as a Scheme value: */
+  return scheme_make_double(v);
+}
+
+/**************************************************/
+
+Scheme_Object *scheme_reload(Scheme_Env *env)
+{
+  Scheme_Object *proc;
+
+  /* The MZ_GC... lines are for for 3m, because env is live across an
+     allocating call. They're not needed for plain old (conservatively
+     collected) Mzscheme. See makeadder3m.c for more info. */
+  MZ_GC_DECL_REG(1);
+  MZ_GC_VAR_IN_REG(0, env);
+  MZ_GC_REG();
+
+  /* Package the C implementation of fmod into a Scheme procedure
+     value: */
+  proc = scheme_make_prim_w_arity(sch_fmod, "fmod", 2, 2);
+  /*               Requires at least two args ------^  ^ */
+  /*                  Accepts no more than two args ---| */
+
+  /* Define `fmod' as a global :*/
+  scheme_add_global("fmod", proc, env);
+
+  MZ_GC_UNREG();
+
+  return scheme_void;
+}
+
+Scheme_Object *scheme_initialize(Scheme_Env *env)
+{
+  /* First load is same as every load: */
+  return scheme_reload(env);
+}
+
+Scheme_Object *scheme_module_name()
+{
+  /* This extension doesn't define a module: */
+  return scheme_false;
+}
diff --git a/collects/mzscheme/examples/hello.c b/collects/mzscheme/examples/hello.c
new file mode 100644
index 0000000000..1afbcd9371
--- /dev/null
+++ b/collects/mzscheme/examples/hello.c
@@ -0,0 +1,30 @@
+/* 
+   MzScheme extension example that returns the string "Hello, world!"
+   when loaded.
+
+   Compile with:
+     mzc --cc hello.c
+     mzc --ld hello.so hello.o
+   And load with
+     (load-extension "hello.so")
+*/
+
+#include "escheme.h"
+
+Scheme_Object *scheme_reload(Scheme_Env *env)
+{
+  /* When the extension is loaded, return a Scheme string: */
+  return scheme_make_utf8_string("Hello, world!");
+}
+
+Scheme_Object *scheme_initialize(Scheme_Env *env)
+{
+  /* First load is same as every load: */
+  return scheme_reload(env);
+}
+
+Scheme_Object *scheme_module_name()
+{
+  /* This extension doesn't define a module: */
+  return scheme_false;
+}
diff --git a/collects/mzscheme/examples/helloprint.c b/collects/mzscheme/examples/helloprint.c
new file mode 100644
index 0000000000..69b28c34a6
--- /dev/null
+++ b/collects/mzscheme/examples/helloprint.c
@@ -0,0 +1,34 @@
+/* Like hello.c, but prints to the current output port and returns
+   (void). */
+
+#include "escheme.h"
+
+Scheme_Object *scheme_reload(Scheme_Env *env)
+{
+  /* Make the string: */
+  Scheme_Object *hw = scheme_make_utf8_string("Hello, World!\n");
+
+  /* Display it: */
+  scheme_display(hw, scheme_get_param(scheme_current_config(), 
+				      MZCONFIG_OUTPUT_PORT));
+
+  /* Why not just
+        printf("Hello, World!\n");
+     ? That would write to stdout, which may or may not be the same as
+     the current output port. But sometimes printf() is what you
+     want. */
+
+  return scheme_void;
+}
+
+Scheme_Object *scheme_initialize(Scheme_Env *env)
+{
+  /* First load is same as every load: */
+  return scheme_reload(env);
+}
+
+Scheme_Object *scheme_module_name()
+{
+  /* This extension doesn't define a module: */
+  return scheme_false;
+}
diff --git a/collects/mzscheme/examples/idmodule.c b/collects/mzscheme/examples/idmodule.c
new file mode 100644
index 0000000000..6c8c13b567
--- /dev/null
+++ b/collects/mzscheme/examples/idmodule.c
@@ -0,0 +1,44 @@
+/*
+  Extension that declares a module.
+  The extension is equivalent to Scheme source of them form:
+    (module idmodule mzscheme
+      (define (identity x) x)
+      (provide identity))
+*/
+
+#include "escheme.h"
+
+static Scheme_Object *id(int argc, Scheme_Object **argv)
+{
+  return argv[0];
+}
+
+Scheme_Object *scheme_reload(Scheme_Env *env)
+{
+  Scheme_Env *menv;
+  Scheme_Object *proc;
+
+  menv = scheme_primitive_module(scheme_intern_symbol("idmodule"),
+				 env);
+
+  proc = scheme_make_prim_w_arity(id, "identity", 1, 1);
+
+  /* All added names are automatically exported by the module: */
+  scheme_add_global("identity", proc, menv);
+
+  scheme_finish_primitive_module(menv);
+
+  return scheme_void;
+}
+
+Scheme_Object *scheme_initialize(Scheme_Env *env)
+{
+  /* First load is same as every load: */
+  return scheme_reload(env);
+}
+
+Scheme_Object *scheme_module_name()
+{
+  /* This extension defines a module named `idmodule': */
+  return scheme_intern_symbol("idmodule");
+}
diff --git a/collects/mzscheme/examples/makeadder.c b/collects/mzscheme/examples/makeadder.c
new file mode 100644
index 0000000000..f841795b8d
--- /dev/null
+++ b/collects/mzscheme/examples/makeadder.c
@@ -0,0 +1,65 @@
+/* 
+   Defines make-adder:
+     (define (make-adder n)
+       (lambda (m) (+ m n)))
+   which illustrates closure-creation, looking up Scheme
+   definitions, and calling Scheme procedures from C.
+*/
+
+#include "escheme.h"
+
+/* The inner lambda, which must close over `n'. A closure function is
+   like a regular Scheme-procedure function, except that it takes an
+   extra argument containing the closure data. The closre data can be
+   any format that we want. */
+static Scheme_Object *sch_inner(void *closure_data, int argc, Scheme_Object **argv)
+{
+  /* We only close over one value, so our closure data reprsentation
+     is just thaht value: */
+  Scheme_Object *n = (Scheme_Object *)closure_data;
+  Scheme_Object *plus;
+  Scheme_Object *a[2];
+
+  plus = scheme_lookup_global(scheme_intern_symbol("+"), 
+			      scheme_get_env(NULL));
+
+  /* return the result of summing m and n: */
+  a[0] = n;
+  a[1] = argv[0]; /* m */
+  return _scheme_apply(plus, 2, a); 
+
+  /* Actually, that's not quite right. In the Scheme code, (+ m n) is
+     a tail call. The following would be better:
+     return _scheme_tail_apply(plus, 2, a); */
+}
+
+static Scheme_Object *sch_make_adder(int argc, Scheme_Object **argv)
+{
+  return scheme_make_closed_prim_w_arity(sch_inner,
+					 argv[0],
+					 "adder",
+					 1, 1);
+}
+
+Scheme_Object *scheme_reload(Scheme_Env *env)
+{
+  scheme_add_global("make-adder",
+		    scheme_make_prim_w_arity(sch_make_adder,
+					     "make-adder", 
+					     1, 1),
+		    env);
+
+  return scheme_void;
+}
+
+Scheme_Object *scheme_initialize(Scheme_Env *env)
+{
+  /* First load is same as every load: */
+  return scheme_reload(env);
+}
+
+Scheme_Object *scheme_module_name()
+{
+  /* This extension doesn't define a module: */
+  return scheme_false;
+}
diff --git a/collects/mzscheme/examples/makeadder3m.c b/collects/mzscheme/examples/makeadder3m.c
new file mode 100644
index 0000000000..3b8d1fca2c
--- /dev/null
+++ b/collects/mzscheme/examples/makeadder3m.c
@@ -0,0 +1,91 @@
+/* 
+   The same as makeaddr.c, but revised and annotated so that it works
+   with 3m. All non-3m comments have been deleted (to better highlight
+   the 3m parts).
+
+   Using the --3m flag when compiling and linking with mzc.
+*/
+
+#include "escheme.h"
+
+static Scheme_Object *sch_inner(void *closure_data, int argc, Scheme_Object **argv)
+{
+  Scheme_Object *n = (Scheme_Object *)closure_data;
+  Scheme_Object *plus, *plus_sym, *result;
+  Scheme_Env *env;
+  Scheme_Object *a[2];
+  /* Declare registration space. The number 6 comes from the
+     MZ_GC_VAR... declarations (i.e., if we add or remove
+     some, the number changes */
+  MZ_GC_DECL_REG(6);
+
+  MZ_GC_ARRAY_VAR_IN_REG(0, a, 2); /* takes 3 slots */
+  MZ_GC_VAR_IN_REG(3, argv);
+  MZ_GC_VAR_IN_REG(4, n);
+  MZ_GC_VAR_IN_REG(5, plus_sym);
+  MZ_GC_REG();
+
+  /* Note that we've pulled out nested calls and assigned
+     the results to explicitly declared variables. Even though
+     `env' is not help across an allocating function call,
+     we need to lift out the call to scheme_get_env(), otherwise
+     plus_sym's value might get pushed on the stack in anticipation
+     of the function call, and the corresponding object might
+     move. As written, plus_sym's value is not set up for the
+     call until after scheme_get_env() returns. */
+  plus_sym = scheme_intern_symbol("+");
+  env = scheme_get_env(NULL);
+  plus = scheme_lookup_global(plus_sym, env);
+
+  a[0] = n;
+  a[1] = argv[0]; /* m */
+  result = _scheme_apply(plus, 2, a); 
+  
+  /* The following unregister can't go before _scheme_apply,
+     because `a' is passed in as a stack-allocated array.
+     If `a' were heap-allocated, instead, MZ_GC_UNREG()
+     could go before the call to _scheme_apply. */
+  MZ_GC_UNREG();
+
+  return result;
+
+}
+
+static Scheme_Object *sch_make_adder(int argc, Scheme_Object **argv)
+{
+  return scheme_make_closed_prim_w_arity(sch_inner,
+					 argv[0],
+					 "adder",
+					 1, 1);
+}
+
+Scheme_Object *scheme_reload(Scheme_Env *env)
+{
+  Scheme_Object *p;
+  MZ_GC_DECL_REG(1);
+  MZ_GC_VAR_IN_REG(0, env);
+  
+  MZ_GC_REG();
+
+  p = scheme_make_prim_w_arity(sch_make_adder,
+			       "make-adder", 
+			       1, 1);
+
+  scheme_add_global("make-adder", p, env);
+
+  MZ_GC_UNREG();
+
+  return scheme_void;
+}
+
+Scheme_Object *scheme_initialize(Scheme_Env *env)
+{
+  /* First load is same as every load: */
+  return scheme_reload(env);
+}
+
+Scheme_Object *scheme_module_name()
+{
+  /* This extension doesn't define a module: */
+  return scheme_false;
+}
diff --git a/collects/mzscheme/examples/msgbox.ss b/collects/mzscheme/examples/msgbox.ss
new file mode 100644
index 0000000000..d4342e46b7
--- /dev/null
+++ b/collects/mzscheme/examples/msgbox.ss
@@ -0,0 +1,41 @@
+;; Build with
+;;   mzc ++ldf user32.lib msgbox.ss
+;; so that MessageBox() is linked in.
+
+(module msgbox mzscheme
+  (require (lib "cffi.ss" "compiler"))
+  
+  ;; c-declare is really file-specific, and
+  ;;  not module-specific
+  (c-declare "#include <windows.h>")
+
+  ;; A direct hook to the MessageBox() function.
+  ;; We never have a parent window, but NULL is ok,
+  ;;  and we can pretend that a window is a string
+  ;;  for the purposes of providing a NULL:
+  (define unsafe-message-box
+    (c-lambda ((pointer "void") ; always use #f
+	       nonnull-char-string ; title
+	       nonnull-char-string ; message
+	       int)   ; style
+	      int
+	      "MessageBox"))
+
+  ;; Functions that really just access constants:
+  (define get-mb-okcancel
+    (c-lambda () int "___result = MB_OKCANCEL;"))
+  (define get-mb-yesno
+    (c-lambda () int "___result = MB_YESNO;"))
+
+  ;; Nice function for clients to use:
+  (define (message-box title message style)
+    (unsafe-message-box
+     #f
+     title
+     message
+     (case style
+       [(ok-cancel) (get-mb-okcancel)]
+       [(yes-no) (get-mb-yesno)]
+       [else (raise-type-error 'message-box "'ok-cancel or 'yes-no" style)])))
+
+  (provide message-box))
diff --git a/collects/mzscheme/examples/tree-finish.ss b/collects/mzscheme/examples/tree-finish.ss
new file mode 100644
index 0000000000..95bf1341a2
--- /dev/null
+++ b/collects/mzscheme/examples/tree-finish.ss
@@ -0,0 +1,30 @@
+
+;; Assumes that tree.so has been loaded
+
+(require (lib "class.ss"))
+
+(define tree%
+  (let ([method-names '(get-leaves 
+			get-left get-right
+			grow
+			graft)])
+    (make-primitive-class
+     (lambda (class prop:object preparer dispatcher)
+       (primitive-class-prepare-struct-type! 
+	tree-primitive-class
+	prop:object
+	class
+	preparer
+	dispatcher))
+     initialize-primitive-object
+     'tree%
+     object%
+     '(leaves)
+     null
+     method-names
+     null
+     (map
+      (lambda (name)
+	(primitive-class-find-method tree-primitive-class name))
+      method-names))))
+
diff --git a/collects/mzscheme/examples/tree.cxx b/collects/mzscheme/examples/tree.cxx
new file mode 100644
index 0000000000..c22c6ca580
--- /dev/null
+++ b/collects/mzscheme/examples/tree.cxx
@@ -0,0 +1,911 @@
+/* Example demonstrating how to inject a C++ class into the class
+   world of MzLib's class.ss library.
+
+   Since it uses C++, this example can be slightly tricky to compile.
+   Specifying a C++ linker (e.g., g++) ensures that the right C++
+   libraries get included:
+     mzc --cc tree.cxx
+     mzc --linker /usr/bin/g++ --ld tree.so tree.o
+
+  The C++ class Tree defines the following:
+
+    Tree(int init_leaves);                       constructor
+
+    int leaves;                                  \ fields
+    Tree *left_branch, *right_branch;            /
+
+    void Graft(Tree *left, Tree *right);         method
+
+    virtual void Grow(int n);                    \ overloaded and
+    virtual void Grow(char *cmd, char *&result); / with ref param
+
+  The Scheme version of the class has the following methods:
+
+    "get-leaves", "get-left", "get-rght" -- gets field values
+    "grow" -- override to replace C++ methods
+    "graft" -- takes Scheme tree% objects
+
+  Example use in Scheme:
+
+    (load-extension "tree.so") ; defines tree-primitive-class and
+                               ; other things not to be used directly
+    (load "tree-finish.ss") ; defines tree%
+
+    (define o (make-object tree% 10))
+    (send o get-leaves) ; => 10
+    (send o get-left) ; => #f
+
+    (send o grow 2) ; grows new branches on the frontier
+    (send o get-left) ; => #<object:tree%>
+    (send (send o get-left) get-leaves) ; => 2
+    
+    (define b (box "sunshine"))
+    (send o grow "sunshine" b)
+    (unbox b) ; => "sprouted left"
+
+    (define apple-tree%
+      (class tree%
+        (inherit graft)
+        (override grow)
+        
+        (define grow
+          ;; This `grow' drops branches and grows new ones.
+          ;; For the command-string form, it does nothing.
+          (case-lambda 
+           [(n)
+            (let ([l (make-object apple-tree%)]
+                  [r (make-object apple-tree%)])
+              (graft l r))]
+           [(cmd result)
+            (set-box! result (format "ignoring ~a" cmd))]))
+
+        (super-instantiate () (leaves 1))))
+
+    (define a (make-object apple-tree%))
+    (send a get-leaves) ; => 1
+    (send a grow 1)
+    (send a get-left) ; => #<struct:object:apple-tree%>
+
+    (define o (make-object tree% 10))
+    (define a (make-object apple-tree%))
+    (send o graft a #f)
+    (send o grow 1)   ; C++ calls apple-tree%'s `grow' for `a'
+    (send a get-left) ; -> #<struct:object:apple-tree>
+
+    (send a grow "sunshine" b)
+    (unbox b) ; => "ignoring sunshine"
+
+ How it Works
+
+   The class.ss library cooperates with primitive classes through a
+   `make-primitive-class' function. The glue code in this file
+   essentially builds up the necessary arguments to
+   `make-primitive-class', and tree-finish.ss actually makes the
+   call. In fact, tree.cxx knows nothing about the class
+   implementation, and the class implementation knows nothing about
+   the glue; they "just happen" to be compatible, but this glue could
+   work with a variety of class implementation.
+
+   The glue, furthermore, is split into two parts. The first part is
+   specific to the Tree class. The second part is more generic,
+   providing a fairly simple objscheme_ interface to class-specific
+   glue, such the Tree glue. The second part can be shared for any
+   number of C++ classes, and it is similar to code used by MrEd.
+*/
+
+#include "escheme.h"
+
+/**********************************************************/
+/* The original C++ class: Tree                           */
+/**********************************************************/
+
+/* This kind of tree never grows or loses leaves. It only changes when
+   it grows subtrees, or when subtrees are grafted onto it. We can
+   derive new classes (in Scheme) for trees that can grow leaves and
+   fruit. */
+
+class Tree {
+private:
+
+  int refcount; /* Suppose the C++ class uses reference counting. */
+
+public:
+
+  /* Public fields: */
+  Tree *left_branch, *right_branch;
+  int leaves;
+
+  void *user_data; /* Field that we use for pointing back to the
+		      Scheme view of the objects. The original class
+		      might not be this friendly, but for simplicity
+		      we assume that it is. The alternative is to use
+		      a hash table. */
+
+  Tree(int init_leaves) {
+    left_branch = right_branch = NULL;
+    leaves = init_leaves;
+    refcount = 1;
+    user_data = NULL;
+  }
+
+  /* The Grow method is overloaded... */
+
+  virtual void Grow(int n) {
+    if (left_branch)
+      left_branch->Grow(n);
+    else
+      left_branch = new Tree(n);
+    if (right_branch)
+      right_branch->Grow(n);
+    else
+      right_branch = new Tree(n);
+  }
+
+  virtual void Grow(char *command, char *&result) {
+    if (!strcmp(command, "sunshine")) {
+      if (left_branch)
+	left_branch->Grow(command, result);
+      else {
+	left_branch = new Tree(1);
+	result = "sprouted left";
+      }
+    } else if (!strcmp(command, "water")) {
+      if (right_branch)
+	right_branch->Grow(command, result);
+      else {
+	right_branch = new Tree(1);
+	result = "sprouted left";
+      }
+    } else {
+      result = "unrecognized command for growing";
+    }
+  }
+
+  void Graft(Tree *left, Tree *right) {
+    Drop(left_branch);
+    Drop(right_branch);
+
+    left_branch = left;
+    right_branch = right;
+
+    Add(left_branch);
+    Add(right_branch);
+  }
+
+  /* Note that Graft is not overrideable in C++.
+     In Scheme, we might override this method, but
+     the C++ code never has to know since it never
+     calls the Graft method itself. */
+
+  /* Reference counting utils: */
+
+  static void Add(Tree *t) {
+    if (t)
+      t->refcount++;
+  }
+  static void Drop(Tree *t) {
+    if (t) {
+      t->refcount--;
+      if (!t->refcount)
+	delete t;
+    }
+  }
+};
+
+/**********************************************************/
+/* The glue class: mzTree (C++ calls to Scheme)           */
+/**********************************************************/
+
+/* Forward declarations (documented further below) */
+void objscheme_init();
+void objscheme_add_procedures(Scheme_Env *);
+Scheme_Object *objscheme_make_class(const char *name, Scheme_Object *sup, 
+				    Scheme_Prim *initf, int num_methods);
+Scheme_Object *objscheme_add_method_w_arity(Scheme_Object *c, const char *name, 
+					    Scheme_Prim *f, int mina, int maxa);
+Scheme_Object *objscheme_make_uninited_object(Scheme_Object *sclass);
+Scheme_Object *objscheme_find_method(Scheme_Object *obj, char *name, void **cache);
+int objscheme_is_a(Scheme_Object *o, Scheme_Object *c);
+
+
+/* The #<primitive-class> value: */
+static Scheme_Object *tree_class;
+/* Cache for lookup of overrideable method: */
+static void *grow_method_cache= NULL;
+/* To recognize original overrideable method: */
+Scheme_Object *grow_prim;
+
+/* We keep a pointer to the Scheme object, and override the
+   Grow method to (potentially) dispatch to Scheme. */
+
+class mzTree : public Tree {
+public:
+  mzTree(int c) : Tree(c) { }
+
+  virtual void Grow(int n) {
+    /* Check whether the Scheme class for user_data is 
+       actually a derived class that overrides `grow': */
+    Scheme_Object *scmobj;
+    Scheme_Object *overriding;
+
+    /* Pointer to Scheme instance kept in user_data: */
+    scmobj = (Scheme_Object *)user_data;
+
+    /* Look for an overriding `grow' method in scmobj: */
+    overriding = objscheme_find_method(scmobj,
+				       "grow",
+				       &grow_method_cache);
+
+    if (overriding != grow_prim) {
+      /* Call Scheme-based overriding implementation: */
+      Scheme_Object *argv[2];
+
+      argv[0] = scmobj;
+      argv[1] = scheme_make_integer(n);
+      _scheme_apply(overriding, 2, argv);
+    } else {
+      /* Grow is not overridden in Scheme: */
+      Tree::Grow(n);
+    }
+  }
+
+  /* Same strategy for other form of Grow, but we have to
+     deal with the "result" parameter: */
+  virtual void Grow(char *cmd, char *&result) {
+    Scheme_Object *scmobj;
+    Scheme_Object *overriding;
+
+    scmobj = (Scheme_Object *)user_data;
+
+    /* Look for an overriding `grow' method in scmobj: */
+    overriding = objscheme_find_method(scmobj,
+				       "grow",
+				       &grow_method_cache);
+
+    if (overriding != grow_prim) {
+      /* When calling the Scheme-based overriding implementation,
+	 we implement the `result' parameter as a boxed string.
+	 The Scheme code mutates the box content to return a 
+	 result. */
+      Scheme_Object *argv[2], *res;
+
+      argv[0] = scmobj;
+      argv[1] = scheme_make_utf8_string(cmd);
+      argv[2] = scheme_box(scheme_make_utf8_string(""));
+
+      _scheme_apply(overriding, 3, argv);
+
+      res = scheme_unbox(argv[2]);
+      if (!SCHEME_CHAR_STRINGP(res)) {
+	scheme_wrong_type("result for tree%'s grow method",
+			  "string", -1, 0, &res);
+      } else
+	result = scheme_utf8_encode_to_buffer(SCHEME_CHAR_STR_VAL(argv[2]), -1, NULL, 0);
+    } else {
+      Tree::Grow(cmd, result);
+    }
+  }
+};
+
+/**********************************************************/
+/* The glue functions (Scheme calls to C++)               */
+/**********************************************************/
+
+/* Macro for accessing C++ object pointer from a Scheme object: */
+#define OBJSCHEME_GET_CPP_OBJ(obj) scheme_struct_ref(obj, 0)
+#define OBJSCHEME_SET_CPP_OBJ(obj, v) scheme_struct_set(obj, 0, v)
+
+/* Used for finalizing: */
+void FreeTree(void *scmobj, void *t)
+{
+  Tree::Drop((Tree *)t);
+}
+
+Scheme_Object *Make_Tree(int argc, Scheme_Object **argv)
+{
+  Scheme_Object *obj;
+
+  /* Unfortunately, init arity is not automatically checked: */
+  if (argc != 2)
+    scheme_wrong_count("tree% initialization", 2, 2, argc, argv);
+
+  /* Assuming the initializer is only called through
+     the class interface, argv[0] is always ok: */
+  obj = argv[0];
+
+  if (!SCHEME_INTP(argv[1]))
+    scheme_wrong_type("tree% initialization", 
+		      "fixnum", 
+		      1, argc, argv);
+
+  /* Create C++ instance, and remember pointer back to Scheme instance: */
+  Tree *t = new mzTree(SCHEME_INT_VAL(argv[1]));
+  t->user_data = obj;
+
+  /* Store C++ pointer in Scheme object: */
+  OBJSCHEME_SET_CPP_OBJ(obj, (Scheme_Object *)t);
+
+  /* Free C++ instance when the Scheme object is no longer referenced: */
+  scheme_add_finalizer(obj, FreeTree, t);
+
+  return obj;
+}
+
+Scheme_Object *Grow(int argc, Scheme_Object **argv)
+{
+  Scheme_Object *obj = argv[0];
+
+  if (argc == 2) {
+    Tree *t;
+    int n;
+
+    if (!SCHEME_INTP(argv[1]))
+      scheme_wrong_type("tree%'s grow", 
+			"fixnum", 
+			1, argc, argv);
+    n = SCHEME_INT_VAL(argv[1]);
+    
+    /* Extract the C++ pointer: */
+    t = (Tree *)OBJSCHEME_GET_CPP_OBJ(obj);
+    
+    /* Call method (without override check): */
+    t->Tree::Grow(n);
+  } else {
+    Tree *t;
+    char *cmd, *result;
+
+    if (!SCHEME_CHAR_STRINGP(argv[1]))
+      scheme_wrong_type("tree%'s grow", 
+			"string", 
+			1, argc, argv);
+    if (!SCHEME_BOXP(argv[2])
+	|| !SCHEME_CHAR_STRINGP(SCHEME_BOX_VAL(argv[2])))
+      scheme_wrong_type("tree%'s grow", 
+			"boxed string", 
+			2, argc, argv);
+
+    cmd = scheme_utf8_encode_to_buffer(SCHEME_CHAR_STR_VAL(argv[1]), -1, NULL, 0);
+    result = scheme_utf8_encode_to_buffer(SCHEME_CHAR_STR_VAL(SCHEME_BOX_VAL(argv[2])), 1, NULL, 0);
+
+    /* Extract the C++ pointer: */
+    t = (Tree *)OBJSCHEME_GET_CPP_OBJ(obj);
+    
+    /* Call method (without override check): */
+    t->Tree::Grow(cmd, result);
+
+    /* Put result back in box: */
+    SCHEME_BOX_VAL(argv[2]) = scheme_make_utf8_string(result);
+  }
+  
+  return scheme_void;
+}
+
+Scheme_Object *Graft(int argc, Scheme_Object **argv)
+{
+  Scheme_Object *obj = argv[0];
+  Tree *t, *l, *r;
+
+  if (!SCHEME_FALSEP(argv[1]) && !objscheme_is_a(argv[1], tree_class))
+    scheme_wrong_type("tree%'s graft", 
+		      "tree% object or #f", 
+		      1, argc, argv);
+  if (!SCHEME_FALSEP(argv[2]) && !objscheme_is_a(argv[2], tree_class))
+    scheme_wrong_type("tree%'s graft", 
+		      "tree% object or #f", 
+		      2, argc, argv);
+
+  /* Extract the C++ pointer for `this': */
+  t = (Tree *)OBJSCHEME_GET_CPP_OBJ(obj);
+
+  /* Extract the C++ pointers for the args: */
+  l = (SCHEME_FALSEP(argv[1])
+       ? (Tree *)NULL
+       : (Tree *)OBJSCHEME_GET_CPP_OBJ(argv[1]));
+  r = (SCHEME_FALSEP(argv[2])
+       ? (Tree *)NULL
+       : (Tree *)OBJSCHEME_GET_CPP_OBJ(argv[2]));
+  
+  /* Call method: */
+  t->Graft(l, r);
+  
+  return scheme_void;
+}
+
+Scheme_Object *MarshalTree(Tree *t)
+{
+  if (!t)
+    return scheme_false;
+  else if (!t->user_data) {
+    /* Object created in C++, not seen by Scheme, yet.
+       Create a Scheme version of this object. */
+    Scheme_Object *scmobj;
+
+    /* Make Scheme object: */
+    scmobj = objscheme_make_uninited_object(tree_class);
+
+    /* Link C++ and Scheme objects: */
+    t->user_data = scmobj;
+    OBJSCHEME_SET_CPP_OBJ(scmobj, (Scheme_Object *)t);
+    
+    return scmobj;
+  } else
+    /* Get pointer back to Scheme: */
+    return (Scheme_Object *)t->user_data;
+}
+
+Scheme_Object *Get_Left(int argc, Scheme_Object **argv)
+{
+  Tree *t = (Tree *)OBJSCHEME_GET_CPP_OBJ(argv[0]);
+  
+  return MarshalTree(t->left_branch);
+}
+
+Scheme_Object *Get_Right(int argc, Scheme_Object **argv)
+{ 
+  Tree *t = (Tree *)OBJSCHEME_GET_CPP_OBJ(argv[0]);
+ 
+  return MarshalTree(t->right_branch);
+}
+
+Scheme_Object *Get_Leaves(int argc, Scheme_Object **argv)
+{
+  Tree *t = (Tree *)OBJSCHEME_GET_CPP_OBJ(argv[0]);
+ 
+  return scheme_make_integer(t->leaves);
+}
+
+/**********************************************************/
+/* Extension initialization: create the Scheme class      */
+/**********************************************************/
+
+Scheme_Object *scheme_reload(Scheme_Env *env)
+{
+  scheme_add_global("tree-primitive-class", tree_class, env);
+
+  objscheme_add_procedures(env);
+
+  return scheme_void;
+}
+
+Scheme_Object *scheme_initialize(Scheme_Env *env)
+{
+  objscheme_init();
+
+  scheme_register_extension_global(&tree_class, sizeof(tree_class));
+
+  tree_class = objscheme_make_class("tree%",    /* name */
+				    NULL,       /* superclass */
+				    Make_Tree,  /* init func */
+				    5);         /* num methods */
+
+  scheme_register_extension_global(&grow_prim, sizeof(grow_prim));
+
+  grow_prim = objscheme_add_method_w_arity(tree_class, "grow",
+					   Grow, 1, 2);
+  (void)objscheme_add_method_w_arity(tree_class, "graft", 
+				     Graft, 2, 2);
+  
+  (void)objscheme_add_method_w_arity(tree_class, "get-left",
+				     Get_Left, 0, 0);
+  (void)objscheme_add_method_w_arity(tree_class, "get-right",
+				     Get_Right, 0, 0);
+  (void)objscheme_add_method_w_arity(tree_class, "get-leaves",
+				     Get_Leaves, 0, 0);
+
+  return scheme_reload(env);
+}
+
+
+Scheme_Object *scheme_module_name()
+{
+  /* This extension doesn't define a module: */
+  return scheme_false;
+}
+
+/**********************************************************/
+/* The generic (class-independent) C++--Scheme glue       */
+/**********************************************************/
+
+/* 
+   (This code is mostly the same as code used by MrEd, and duplicating
+   it is certainly a bad idea in principle, but putting the code in a
+   shareable place seems like more work than is worthwhile for now.)
+
+   Scheme side:
+   ------------
+
+   This glue provides a new type, #<primitive-class>, and several
+   procedures:
+
+      (initialize-primitive-object prim-obj v ...) -
+        initializes the primitive object, given initialization
+        arguments v ...
+
+      (primitive-class-prepare-struct-type! prim-class gen-property
+        gen-value preparer dispatcher) - prepares a class's struct-type for
+        objects generated C-side; returns a constructor, predicate,
+        and a struct:type for derived classes. The constructor and
+        struct:type map the given dispatcher to the class.
+
+        The preparer takes a symbol naming the method. It returns a
+        value to be used in future calls to the dispatcher.
+
+        The dispatcher takes two arguments: an object and a
+        method-specific value produced by the prepaper. It returns a
+        method procedure.
+
+      (primitive-class-find-method prim-class sym) - gets the method
+        procedure for the given symbol from the class. The procedure
+        consumes "self" and then the rest of the arguments.
+
+   C side:
+   -------
+
+     void objscheme_init() - initializes the glue; call this first.
+
+     void objscheme_add_procedures(Scheme_Env *) - installs the
+        Scheme-side procedure listed above into the environment.
+
+     Scheme_Object *objscheme_make_class(const char *name,
+        Scheme_Object *sup, Scheme_Prim *initf, int num_methods) -
+        creates a #<primitive-class> representing a C++ class. The
+        initf function is called to create and initialize the C++-side
+        when the class is instantiated from Scheme; the first argument
+        is the Scheme-side `self' object. The Scheme-side object is a
+        struct, and the first field should be set to point to the C++
+        object.
+
+        The sup argument is a #<primitive-class> for a superclass, or
+        scheme_false. The num_methods argument specifies the number of
+        methods that will be added to the class.
+
+     void objscheme_add_method_w_arity(Scheme_Object *c, const char
+	*name, Scheme_Prim *f, int mina, int maxa) - adds a method to
+	a #<primitive-class>, specifying the method's arity as with
+	scheme_make_prim_w_arity().
+
+     Scheme_Object *objscheme_make_uninited_object(Scheme_Object *sclass)
+        - creates a Scheme-side object for an existing C++ obj. The
+        Scheme-side object is a struct, and the first field should be
+        set to point to the C++ object.
+
+     Scheme_Object *objscheme_find_method(Scheme_Object *obj, char
+        *name, void **cache) - finds a method by name in a Scheme-side
+        object. It is a Scheme procedure for the method (which takes
+        the Scheme-side `self' as its first argument). The cache
+        pointer should point to static, class-specific space for
+        caching lookup information.
+
+     int objscheme_is_a(Scheme_Object *o, Scheme_Object *c) - returns 1
+        if the given Scheme-side object is an instance of the given
+        #<primitive-class>, 0 otherwise.
+
+*/
+
+typedef struct Objscheme_Class {
+  Scheme_Type type;
+  const char *name;
+  Scheme_Object *sup;
+  Scheme_Object *initf;
+  int num_methods, num_installed;
+  Scheme_Object **names;
+  Scheme_Object **methods;
+  Scheme_Object *base_struct_type;
+  Scheme_Object *struct_type;
+} Objscheme_Class;
+
+Scheme_Type objscheme_class_type;
+
+static Scheme_Object *object_struct;
+static Scheme_Object *object_property;
+static Scheme_Object *preparer_property;
+static Scheme_Object *dispatcher_property;
+
+#define CONS(a, b) scheme_make_pair(a, b)
+
+/***************************************************************************/
+/* Scheme-side implementation: */
+
+static Scheme_Object *init_prim_obj(int argc, Scheme_Object **argv)
+{
+  Objscheme_Class *c;
+  Scheme_Object *obj = argv[0];
+
+  if (!SCHEME_STRUCTP(argv[0])
+      || !scheme_is_struct_instance(object_struct, argv[0]))
+    scheme_wrong_type("initialize-primitive-object", "primitive-object", 0, argc, argv);
+  
+  c = (Objscheme_Class *)scheme_struct_type_property_ref(object_property, obj);
+
+  return _scheme_apply(c->initf, argc, argv);
+}
+
+static Scheme_Object *class_prepare_struct_type(int argc, Scheme_Object **argv)
+{
+  Scheme_Object *name, *base_stype, *stype, *derive_stype;
+  Scheme_Object **names, **vals, *a[3], *props;
+  Objscheme_Class *c;
+  int flags, count;
+
+  if (SCHEME_TYPE(argv[0]) != objscheme_class_type)
+    scheme_wrong_type("primitive-class-prepare-struct-type!", "primitive-class", 0, argc, argv);
+  if (SCHEME_TYPE(argv[1]) != scheme_struct_property_type)
+    scheme_wrong_type("primitive-class-prepare-struct-type!", "struct-type-property", 1, argc, argv);
+  scheme_check_proc_arity("primitive-class-prepare-struct-type!", 1, 3, argc, argv);
+  scheme_check_proc_arity("primitive-class-prepare-struct-type!", 2, 4, argc, argv);
+
+  c = ((Objscheme_Class *)argv[0]);
+  
+  stype = c->struct_type;
+
+  name = scheme_intern_symbol(c->name);
+
+  if (stype) {
+    scheme_arg_mismatch("primitive-class-prepare-struct-type!",
+			"struct-type already prepared for primitive-class: ",
+			name);
+    return NULL;
+  }
+
+  if (SCHEME_TRUEP(c->sup) && !((Objscheme_Class *)c->sup)->base_struct_type) {
+    scheme_arg_mismatch("primitive-class-prepare-struct-type!",
+			"super struct-type not yet prepared for primitive-class: ",
+			name);
+    return NULL;
+  }
+
+  /* Root for this class.  */
+
+  base_stype = scheme_make_struct_type(name, 
+				       (SCHEME_TRUEP(c->sup) 
+					? ((Objscheme_Class *)c->sup)->base_struct_type 
+					: object_struct),
+				       NULL,
+				       0, 0, NULL,
+				       NULL, NULL);
+  c->base_struct_type = base_stype;
+
+  /* Type to use when instantiating from C: */
+
+  props = CONS(CONS(object_property, 
+		    argv[0]),
+	       scheme_null);
+
+  stype = scheme_make_struct_type(name,
+				  base_stype, 
+				  NULL,
+				  0, 0, NULL,
+				  CONS(CONS(argv[1], argv[2]),
+				       props),
+				  NULL);
+  
+  c->struct_type = stype;
+  
+  /* Type to derive from Scheme: */
+  
+  props = CONS(CONS(preparer_property, argv[3]),
+	       CONS(CONS(dispatcher_property, argv[4]),
+		    props));
+
+  derive_stype = scheme_make_struct_type(name,
+					 base_stype, 
+					 NULL,
+					 0, 0, NULL,
+					 props, 
+					 NULL);
+  
+  /* Type to instantiate from Scheme: */
+  
+  stype = scheme_make_struct_type(name,
+				  base_stype, 
+				  NULL,
+				  0, 0, NULL,
+				  CONS(CONS(argv[1], argv[2]), props),
+				  NULL);
+  
+  /* Need constructor from instantiate type: */
+  flags = (SCHEME_STRUCT_NO_TYPE
+	   | SCHEME_STRUCT_NO_PRED
+	   | SCHEME_STRUCT_NO_GET
+	   | SCHEME_STRUCT_NO_SET);
+  names = scheme_make_struct_names(name, NULL, flags, &count);
+  vals = scheme_make_struct_values(stype, names, count, flags);
+  a[0] = vals[0];
+
+  /* Need predicate from base type: */
+  flags = (SCHEME_STRUCT_NO_TYPE
+	   | SCHEME_STRUCT_NO_CONSTR
+	   | SCHEME_STRUCT_NO_GET
+	   | SCHEME_STRUCT_NO_SET);
+  names = scheme_make_struct_names(name, NULL, flags, &count);
+  vals = scheme_make_struct_values(base_stype, names, count, flags);
+  a[1] = vals[0];
+
+  /* Need derive type: */
+  a[2] = derive_stype;
+
+  return scheme_values(3, a);
+}
+
+static Scheme_Object *class_find_meth(int argc, Scheme_Object **argv)
+{
+  Objscheme_Class *sclass = (Objscheme_Class *)argv[0];
+  Scheme_Object *s;
+  int i;
+
+  if (SCHEME_TYPE(argv[0]) != objscheme_class_type)
+    scheme_wrong_type("primitive-class-find-method", "primitive-class", 0, argc, argv);
+  if (!SCHEME_SYMBOLP(argv[1]))
+    scheme_wrong_type("primitive-class-find-method", "symbol", 1, argc, argv);
+
+  s = argv[1];
+
+  for (i = sclass->num_installed; i--; ) {
+    if (SAME_OBJ(sclass->names[i], s))
+      return sclass->methods[i];
+  }
+
+  return scheme_false;
+}
+
+Scheme_Object *objscheme_make_uninited_object(Scheme_Object *sclass)
+{
+  Scheme_Object *obj;
+  Scheme_Object *stype;
+
+  stype = ((Objscheme_Class *)sclass)->struct_type;
+  if (!stype) {
+    scheme_arg_mismatch("make-primitive-object",
+			"struct-type not yet prepared: ",
+			sclass);
+    return NULL;
+  }
+
+  obj = scheme_make_struct_instance(stype, 0, NULL);
+
+  return obj;  
+}
+
+/***************************************************************************/
+/* C-side implementation: */
+
+Scheme_Object *objscheme_make_class(const char *name, Scheme_Object *sup, 
+				    Scheme_Prim *initf, int num_methods)
+{
+  Objscheme_Class *sclass;
+  Scheme_Object *f, **methods, **names;
+
+  sclass = (Objscheme_Class *)scheme_malloc_tagged(sizeof(Objscheme_Class));
+  sclass->type = objscheme_class_type;
+
+  if (!sup)
+    sup = scheme_false;
+
+  sclass->name = name;
+  sclass->sup = sup;
+
+  f = scheme_make_prim(initf);
+  sclass->initf = f;
+
+  sclass->num_methods = num_methods;
+  sclass->num_installed = 0;
+
+  methods = (Scheme_Object **)scheme_malloc(sizeof(Scheme_Object *) * num_methods);
+  names = (Scheme_Object **)scheme_malloc(sizeof(Scheme_Object *) * num_methods);
+
+  sclass->methods = methods;
+  sclass->names = names;
+
+  return (Scheme_Object *)sclass;
+}
+
+Scheme_Object *objscheme_add_method_w_arity(Scheme_Object *c, const char *name,
+					    Scheme_Prim *f, int mina, int maxa)
+{
+  Scheme_Object *s;
+  Objscheme_Class *sclass;
+
+  sclass = (Objscheme_Class *)c;
+
+  s = scheme_make_prim_w_arity(f, name, mina + 1, (maxa < 0) ? -1 : (maxa + 1));
+
+  sclass->methods[sclass->num_installed] = s;
+
+  s = scheme_intern_symbol(name);
+
+  sclass->names[sclass->num_installed] = s;
+
+  sclass->num_installed++;
+
+  return s;
+}
+
+int objscheme_is_a(Scheme_Object *o, Scheme_Object *c)
+{
+  Scheme_Object *a;
+
+  if (!SCHEME_STRUCTP(o) || !scheme_is_struct_instance(object_struct, o))
+    return 0;
+
+  a = scheme_struct_type_property_ref(object_property, o);
+  
+  while (a && (a != c)) {
+    a = ((Objscheme_Class *)a)->sup;
+  }
+
+  return !!a;
+}
+
+void objscheme_init()
+{
+  objscheme_class_type = scheme_make_type("<primitive-class>");
+
+  /* Attaches a primitive class to an object: */
+  scheme_register_extension_global(&object_property, sizeof(object_property));
+  object_property = scheme_make_struct_type_property(scheme_intern_symbol("primitive-object"));
+  
+  /* Attaches a preparer function to a derived class: */
+  scheme_register_extension_global(&preparer_property, sizeof(preparer_property));
+  preparer_property = scheme_make_struct_type_property(scheme_intern_symbol("primitive-preparer"));
+
+  /* Attaches a dispatcher function to a derived class: */
+  scheme_register_extension_global(&dispatcher_property, sizeof(dispatcher_property));
+  dispatcher_property = scheme_make_struct_type_property(scheme_intern_symbol("primitive-dispatcher"));
+
+  /* The base struct type for the Scheme view of a primitive object: */
+  scheme_register_extension_global(&object_struct, sizeof(object_struct));
+  object_struct = scheme_make_struct_type(scheme_intern_symbol("primitive-object"), 
+					  NULL, NULL,
+					  0, 2, NULL,
+					  NULL, NULL);
+}
+
+void objscheme_add_procedures(Scheme_Env *env)
+{
+  scheme_add_global("initialize-primitive-object",
+		    scheme_make_prim_w_arity(init_prim_obj,
+					     "initialize-primitive-object",
+					     1, -1),
+		    env);
+
+  scheme_add_global("primitive-class-prepare-struct-type!",
+		    scheme_make_prim_w_arity(class_prepare_struct_type,
+					     "primitive-class-prepare-struct-type!",
+					     5, 5),
+		    env);
+  
+  scheme_add_global("primitive-class-find-method",
+		    scheme_make_prim_w_arity(class_find_meth,
+					     "primitive-class-find-method",
+					     2, 2),
+		    env);
+}
+
+Scheme_Object *objscheme_find_method(Scheme_Object *obj, char *name, void **cache)
+{
+  Scheme_Object *s, *p[2], *dispatcher;
+
+  if (!obj)
+    return NULL;
+
+  dispatcher = scheme_struct_type_property_ref(dispatcher_property, (Scheme_Object *)obj);
+  if (!dispatcher)
+    return NULL;
+
+  if (*cache)
+    s = (Scheme_Object *)*cache;
+  else {
+    s = scheme_intern_symbol(name);
+    p[0] = s;
+    s = scheme_struct_type_property_ref(preparer_property, (Scheme_Object *)obj);
+    if (!s)
+      return NULL;
+    s = scheme_apply(s, 1, p);
+    scheme_register_extension_global((void *)cache, sizeof(Scheme_Object*));
+    *cache = s;
+  }
+
+  p[0] = obj;
+  p[1] = s;
+  return _scheme_apply(dispatcher, 2, p);
+}
diff --git a/collects/mzscheme/info.ss b/collects/mzscheme/info.ss
new file mode 100644
index 0000000000..5da30be9b5
--- /dev/null
+++ b/collects/mzscheme/info.ss
@@ -0,0 +1,4 @@
+
+(module info (lib "infotab.ss" "setup")
+  (define name "MzScheme")
+  (define version '(200)))
diff --git a/collects/mzscheme/lib/mzdyn.c b/collects/mzscheme/lib/mzdyn.c
new file mode 100644
index 0000000000..2eaee379a4
--- /dev/null
+++ b/collects/mzscheme/lib/mzdyn.c
@@ -0,0 +1,56 @@
+/*
+  MzScheme
+  Copyright (c) 2004-2005 PLT Scheme, Inc.
+  Copyright (c) 1995 Matthew Flatt
+  All rights reserved.
+
+  Please see the full copyright in the documentation.
+
+  libscheme
+  Copyright (c) 1994 Brent Benson
+  All rights reserved.
+*/
+
+/* This file should be linked with any MzScheme extension dynamic
+   object. */
+
+
+#include "escheme.h"
+#ifdef INCLUDE_WITHOUT_PATHS
+# include "schvers.h"
+#else
+# include "../src/schvers.h"
+#endif
+
+#ifdef MZ_PRECISE_GC
+# define PLAIN_OR_3M "@3m"
+#else
+# define PLAIN_OR_3M ""
+#endif
+
+#ifdef LINK_EXTENSIONS_BY_TABLE
+Scheme_Extension_Table *scheme_extension_table;
+#endif
+
+#ifdef CODEFRAGMENT_DYNAMIC_LOAD
+#pragma export on
+char *scheme_initialize_internal(
+#ifdef LINK_EXTENSIONS_BY_TABLE
+				 Scheme_Extension_Table *table
+#endif
+				 );
+#pragma export off
+#endif
+
+char *scheme_initialize_internal(
+#ifdef LINK_EXTENSIONS_BY_TABLE
+				 Scheme_Extension_Table *table
+#endif
+				 )
+{
+#ifdef LINK_EXTENSIONS_BY_TABLE
+  scheme_extension_table = table;
+#endif
+
+  return MZSCHEME_VERSION PLAIN_OR_3M;
+}
diff --git a/collects/net/base64-sig.ss b/collects/net/base64-sig.ss
new file mode 100644
index 0000000000..485e63f90e
--- /dev/null
+++ b/collects/net/base64-sig.ss
@@ -0,0 +1,12 @@
+
+(module base64-sig mzscheme
+  (require (lib "unitsig.ss"))
+
+  (provide net:base64^)
+
+  (define-signature net:base64^
+    (base64-encode-stream
+     base64-decode-stream
+     base64-encode
+     base64-decode)))
+
diff --git a/collects/net/base64-unit.ss b/collects/net/base64-unit.ss
new file mode 100644
index 0000000000..2bb1d075d6
--- /dev/null
+++ b/collects/net/base64-unit.ss
@@ -0,0 +1,140 @@
+
+
+(module base64-unit mzscheme
+  (require (lib "unitsig.ss"))
+
+  (require "base64-sig.ss")
+
+  (provide net:base64@)
+  (define net:base64@
+    (unit/sig net:base64^
+      (import)
+
+      (define base64-digit (make-vector 256))
+      (let loop ([n 0])
+	(unless (= n 256)
+	  (cond
+	   [(<= (char->integer #\A) n (char->integer #\Z)) 
+	    (vector-set! base64-digit n (- n (char->integer #\A)))]
+	   [(<= (char->integer #\a) n (char->integer #\z)) 
+	    (vector-set! base64-digit n (+ 26 (- n (char->integer #\a))))]
+	   [(<= (char->integer #\0) n (char->integer #\9)) 
+	    (vector-set! base64-digit n (+ 52 (- n (char->integer #\0))))]
+	   [(= (char->integer #\+) n)
+	    (vector-set! base64-digit n 62)]
+	   [(= (char->integer #\/) n)
+	    (vector-set! base64-digit n 63)]
+	   [else
+	    (vector-set! base64-digit n #f)])
+	  (loop (add1 n))))
+
+      (define digit-base64 (make-vector 64))
+      (let ([each-char (lambda (s e pos)
+			 (let loop ([i (char->integer s)][pos pos])
+			   (unless (> i (char->integer e))
+			     (vector-set! digit-base64 pos i)
+			     (loop (add1 i) (add1 pos)))))])
+	(each-char #\A #\Z 0)
+	(each-char #\a #\z 26)
+	(each-char #\0 #\9 52)
+	(each-char #\+ #\+ 62)
+	(each-char #\/ #\/ 63))
+
+      (define (base64-decode-stream in out)
+	(let loop ([waiting 0][waiting-bits 0])
+	  (if (>= waiting-bits 8)
+	      (begin
+		(write-byte (arithmetic-shift waiting (- 8 waiting-bits))
+			    out)
+		(let ([waiting-bits (- waiting-bits 8)])
+		  (loop (bitwise-and waiting (sub1 (arithmetic-shift 1 waiting-bits)))
+			waiting-bits)))
+	      (let* ([c0 (read-byte in)]
+		     [c (if (eof-object? c0) (char->integer #\=) c0)]
+		     [v (vector-ref base64-digit c)])
+		(cond
+		 [v (loop (+ (arithmetic-shift waiting 6) v)
+			  (+ waiting-bits 6))]
+		 [(eq? c (char->integer #\=)) (void)] ; done
+		 [else (loop waiting waiting-bits)])))))
+
+
+      (define base64-encode-stream
+	(case-lambda
+	 [(in out) (base64-encode-stream in out #"\n")]
+	 [(in out linesep)
+	  ;; Process input 3 characters at a time, because 18 bits
+	  ;;  is divisible by both 6 and 8, and 72 (the line length)
+	  ;;  is divisible by 3.
+	  (let ([three (make-bytes 3)]
+		[outc (lambda (n)
+			(write-byte (vector-ref digit-base64 n) out))]
+		[done (lambda (fill)
+			(let loop ([fill fill])
+			  (unless (zero? fill)
+			    (write-byte (char->integer #\=) out)
+			    (loop (sub1 fill))))
+			(display linesep out))])
+	    (let loop ([pos 0])
+	      (if (= pos 72)
+		  ; Insert newline
+		  (begin
+		    (display linesep out)
+		    (loop 0))
+		  ;; Next group of 3
+		  (let ([n (read-bytes-avail! three in)])
+		    (cond
+		     [(eof-object? n)
+		      (unless (= pos 0)
+			(done 0))]
+		     [(= n 3)
+		      ;; Easy case:
+		      (let ([a (bytes-ref three 0)]
+			    [b (bytes-ref three 1)]
+			    [c (bytes-ref three 2)])
+			(outc (arithmetic-shift a -2))
+			(outc (+ (bitwise-and #x3f (arithmetic-shift a 4))
+				 (arithmetic-shift b -4)))
+			(outc (+ (bitwise-and #x3f (arithmetic-shift b 2))
+				 (arithmetic-shift c -6)))
+			(outc (bitwise-and #x3f c))
+			(loop (+ pos 4)))]
+		     [else
+		      ;; Hard case: n is 1 or 2
+		      (let ([a (bytes-ref three 0)])
+			(outc (arithmetic-shift a -2))
+			(let* ([next (if (= n 2)
+					 (bytes-ref three 1)
+					 (read-byte in))]
+			       [b (if (eof-object? next)
+				      0
+				      next)])
+			  (outc (+ (bitwise-and #x3f (arithmetic-shift a 4))
+				   (arithmetic-shift b -4)))
+			  (if (eof-object? next)
+			      (done 2)
+			      ;; More to go
+			      (let* ([next (read-byte in)]
+				     [c (if (eof-object? next)
+					    0
+					    next)])
+				(outc (+ (bitwise-and #x3f (arithmetic-shift b 2))
+					 (arithmetic-shift c -6)))
+				(if (eof-object? next)
+				    (done 1)
+				    ;; Finish c, loop
+				    (begin
+				      (outc (bitwise-and #x3f c))
+				      (loop (+ pos 4))))))))])))))]))
+
+      (define (base64-decode src)
+	(let ([s (open-output-bytes)])
+	  (base64-decode-stream (open-input-bytes src) s)
+	  (get-output-bytes s)))
+
+      (define (base64-encode src)
+	(let ([s (open-output-bytes)])
+	  (base64-encode-stream (open-input-bytes src) s
+				(bytes 13 10))
+	  (get-output-bytes s))))))
+
diff --git a/collects/net/base64.ss b/collects/net/base64.ss
new file mode 100644
index 0000000000..a1be0d6b85
--- /dev/null
+++ b/collects/net/base64.ss
@@ -0,0 +1,12 @@
+
+
+(module base64 mzscheme
+  (require (lib "unitsig.ss"))
+
+  (require "base64-sig.ss")
+  (require "base64-unit.ss")
+
+  (define-values/invoke-unit/sig net:base64^
+    net:base64@)
+
+  (provide-signature-elements net:base64^))
diff --git a/collects/net/cgi-sig.ss b/collects/net/cgi-sig.ss
new file mode 100644
index 0000000000..8b88696ee3
--- /dev/null
+++ b/collects/net/cgi-sig.ss
@@ -0,0 +1,30 @@
+
+(module cgi-sig mzscheme
+  (require (lib "unitsig.ss"))
+
+  (provide net:cgi^)
+
+  (define-signature net:cgi^
+    (
+     ;; -- exceptions raised --
+     (struct cgi-error ())
+     (struct incomplete-%-suffix (chars))
+     (struct invalid-%-suffix (char))
+
+     ;; -- cgi methods --
+     get-bindings
+     get-bindings/post
+     get-bindings/get
+     output-http-headers
+     generate-html-output
+     generate-error-output
+     bindings-as-html
+     extract-bindings
+     extract-binding/single
+     get-cgi-method
+     
+     ;; -- general HTML utilities --
+     string->html
+     generate-link-text
+     )))
+
diff --git a/collects/net/cgi-unit.ss b/collects/net/cgi-unit.ss
new file mode 100644
index 0000000000..b915dd926c
--- /dev/null
+++ b/collects/net/cgi-unit.ss
@@ -0,0 +1,326 @@
+
+(module cgi-unit mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "etc.ss"))
+
+  (require "cgi-sig.ss")
+
+  (provide net:cgi@)
+  (define net:cgi@
+    (unit/sig net:cgi^
+      (import)
+      
+      ;; type bindings = list ((symbol . string))
+
+      ;; --------------------------------------------------------------------
+
+      ;; Exceptions:
+
+      (define-struct cgi-error ())
+
+      ;; chars : list (char)
+      ;; -- gives the suffix which is invalid, not including the `%'
+
+      (define-struct (incomplete-%-suffix cgi-error) (chars))
+
+      ;; char : char
+      ;; -- an invalid character in a hex string
+
+      (define-struct (invalid-%-suffix cgi-error) (char))
+
+      ;; --------------------------------------------------------------------
+
+      ;; query-chars->string :
+      ;; list (char) -> string
+
+      ;; -- The input is the characters post-processed as per Web specs, which
+      ;; is as follows:
+      ;; spaces are turned into "+"es and lots of things are turned into %XX,
+      ;; where XX are hex digits, eg, %E7 for ~.  The output is a regular
+      ;; Scheme string with all the characters converted back.
+
+      (define query-chars->string
+	(lambda (chars)
+	  (list->string
+	   (let loop ((chars chars))
+	     (if (null? chars) null
+		 (let ((first (car chars))
+		       (rest (cdr chars)))
+		   (let-values (((this rest)
+				 (cond
+				  ((char=? first #\+)
+				   (values #\space rest))
+				  ((char=? first #\%)
+				   (if (and (pair? rest)
+					    (pair? (cdr rest)))
+				       (values
+					(integer->char
+					 (or (string->number
+					      (string
+					       (car rest) (cadr rest))
+					      16)
+					     (raise (make-invalid-%-suffix
+						     (if (string->number
+							  (string (car rest))
+							  16)
+							 (cadr rest)
+							 (car rest))))))
+					(cddr rest))
+				       (raise
+					(make-incomplete-%-suffix rest))))
+				  (else
+				   (values first rest)))))
+		     (cons this (loop rest)))))))))
+
+      ;; string->html :
+      ;; string -> string
+      ;; -- the input is raw text, the output is HTML appropriately quoted
+
+      (define string->html
+	(lambda (s)
+	  (apply string-append
+		 (map (lambda (c)
+			(case c
+			  ((#\<) "&lt;")
+			  ((#\>) "&gt;")
+			  ((#\&) "&amp;")
+			  (else (string c))))
+		      (string->list s)))))
+
+      (define default-text-color "#000000")
+      (define default-bg-color "#ffffff")
+      (define default-link-color "#cc2200")
+      (define default-vlink-color "#882200")
+      (define default-alink-color "#444444")
+
+      ;; generate-html-output :
+      ;; html-string x list (html-string) x ... -> ()
+
+      (define generate-html-output
+	(opt-lambda (title body-lines
+			   (text-color default-text-color)
+			   (bg-color default-bg-color)
+			   (link-color default-link-color)
+			   (vlink-color default-vlink-color)
+			   (alink-color default-alink-color))
+	  (let ((sa string-append))
+	    (for-each 
+	     (lambda (l)
+	       (display l) (newline))
+	     `("Content-type: text/html"
+	       ""
+	       "<html>"
+	       "<!-- The form was processed, and this document was generated,"
+	       "     using the CGI utilities for MzScheme.  For more information"
+	       "     on MzScheme, see"
+	       "      http://www.plt-scheme.org/software/mzscheme/"
+	       "     and for the CGI utilities, contact"
+	       "     (sk@cs.brown.edu). -->"
+	       
+	       "<head>"
+	       ,(sa "<title>" title "</title>")
+	       "</head>"
+	       ""
+	       ,(sa "<body bgcolor=\"" bg-color "\" text=\"" text-color "\"")
+	       ,(sa "      link=\"" link-color "\"")
+	       ,(sa "      vlink=\"" vlink-color "\" alink=\"" alink-color "\">")
+	       ""
+	       ,@body-lines
+	       ""
+	       "</body>"
+	       "</html>")))))
+      
+      ;; output-http-headers : -> void
+      (define (output-http-headers)
+	(printf "Content-type: text/html~a~n~a~n" #\return #\return))
+      
+      ;; read-until-char :
+      ;; iport x char -> list (char) x bool
+      ;; -- operates on the default input port; the second value indicates
+      ;; whether reading stopped because an EOF was hit (as opposed to the
+      ;; delimiter being seen); the delimiter is not part of the result
+      
+      (define read-until-char
+	(lambda (ip delimiter)
+	  (let loop ((chars '()))
+	    (let ((c (read-char ip)))
+	      (cond
+	       ((eof-object? c)
+		(values (reverse chars) #t))
+	       ((char=? c delimiter)
+		(values (reverse chars) #f))
+	       (else
+		(loop (cons c chars))))))))
+
+      ;; read-name+value :
+      ;; iport -> (symbol + bool) x (string + bool) x bool
+
+      ;; -- If the first value is false, so is the second, and the third is
+      ;; true, indicating EOF was reached without any input seen.  Otherwise,
+      ;; the first and second values contain strings and the third is either
+      ;; true or false depending on whether the EOF has been reached.  The
+      ;; strings are processed to remove the CGI spec "escape"s.
+
+      ;; This code is _slightly_ lax: it allows an input to end in `&'.  It's
+      ;; not clear this is legal by the CGI spec, which suggests that the last
+      ;; value binding must end in an EOF.  It doesn't look like this matters.
+      ;; It would also introduce needless modality and reduce flexibility.
+
+      (define read-name+value
+	(lambda (ip)
+	  (let-values 
+	      (((name eof?)
+		(read-until-char ip #\=)))
+	    (cond
+	     ((and eof? (null? name))
+	      (values #f #f #t))
+	     (eof?
+	      (generate-error-output
+	       (list "Server generated malformed input for POST method:"
+		     (string-append
+		      "No binding for `" (list->string name) "' field."))))
+	     (else
+	      (let-values (((value eof?)
+			    (read-until-char ip #\&)))
+		(values (string->symbol (query-chars->string name))
+			(query-chars->string value)
+			eof?)))))))
+      
+      ;; get-bindings/post :
+      ;; () -> bindings
+      
+      (define get-bindings/post
+	(lambda ()
+	  (let-values (((name value eof?)
+			(read-name+value
+			 (current-input-port))))
+	    (cond
+	     ((and eof? (not name))
+	      null)
+	     ((and eof? name)
+	      (list (cons name value)))
+	     (else
+	      (cons (cons name value)
+		    (get-bindings/post)))))))
+
+      ;; get-bindings/get :
+      ;; () -> bindings
+
+      (define get-bindings/get
+	(lambda ()
+	  (let ((p (open-input-string
+		    (getenv "QUERY_STRING"))))
+	    (let loop ()
+	      (let-values (((name value eof?)
+			    (read-name+value p)))
+		(cond
+		 ((and eof? (not name))
+		  null)
+		 ((and eof? name)
+		  (list (cons name value)))
+		 (else
+		  (cons (cons name value)
+			(loop)))))))))
+
+      ;; get-bindings :
+      ;; () -> bindings
+
+      (define get-bindings
+	(lambda ()
+	  (if (string=? (get-cgi-method) "POST")
+	      (get-bindings/post)
+	      (get-bindings/get))))
+
+      ;; generate-error-output :
+      ;; list (html-string) -> <exit>
+
+      (define generate-error-output
+	(lambda (error-message-lines)
+	  (generate-html-output "Internal Error"
+				error-message-lines)
+	  (exit)))
+
+      ;; bindings-as-html :
+      ;; bindings -> list (html-string)
+      ;; -- formats name-value bindings as HTML appropriate for displaying
+
+      (define bindings-as-html
+	(lambda (bindings)
+	  `("<code>"
+	    ,@(map
+	       (lambda (bind)
+		 (string-append
+		  (symbol->string (car bind))
+		  "&nbsp;--&gt;&nbsp;"
+		  (cdr bind)
+		  "<br>"))
+	       bindings)
+	    "</code>")))
+
+      ;; extract-bindings :
+      ;; (string + symbol) x bindings -> list (string)
+
+      ;; -- Extracts the bindings associated with a given name.  The semantics
+      ;; of forms states that a CHECKBOX may use the same NAME field multiple
+      ;; times.  Hence, a list of strings is returned.  Note that the result
+      ;; may be the empty list.
+
+      (define extract-bindings
+	(lambda (field-name bindings)
+	  (let ((field-name (if (symbol? field-name) field-name
+				(string->symbol field-name))))
+	    (let loop ((found null) (bindings bindings))
+	      (if (null? bindings)
+		  found
+		  (if (equal? field-name (caar bindings))
+		      (loop (cons (cdar bindings) found) (cdr bindings))
+		      (loop found (cdr bindings))))))))
+
+      ;; extract-binding/single : 
+      ;; (string + symbol) x bindings -> string
+      ;; -- used in cases where only one binding is supposed to occur
+
+      (define extract-binding/single
+	(lambda (field-name bindings)
+	  (let ((field-name (if (symbol? field-name) field-name
+				(string->symbol field-name))))
+	    (let ((result (extract-bindings field-name bindings)))
+	      (cond
+	       ((null? result)
+		(generate-error-output
+		 `(,(string-append "No binding for field `"
+				   (if (symbol? field-name)
+				       (symbol->string field-name)
+				       field-name)
+				   "' in <p>")
+		   ,@(bindings-as-html bindings))))
+	       ((null? (cdr result))
+		(car result))
+	       (else
+		(generate-error-output
+		 `(,(string-append "Multiple bindings for field `"
+				   (if (symbol? field-name)
+				       (symbol->string field-name)
+				       field-name)
+				   "' where only one was expected in <p>")
+		   ,@(bindings-as-html bindings)))))))))
+
+      ;; get-cgi-method :
+      ;; () -> string
+      ;; -- string is either GET or POST (though future extension is possible)
+
+      (define get-cgi-method
+	(lambda ()
+	  (getenv "REQUEST_METHOD")))
+
+      ;; generate-link-text :
+      ;; string x html-string -> html-string
+
+      (define generate-link-text
+	(lambda (url anchor-text)
+	  (string-append "<a href=\"" url "\">" anchor-text "</a>")))
+
+      ;; ====================================================================
+
+      )))
+
diff --git a/collects/net/cgi.ss b/collects/net/cgi.ss
new file mode 100644
index 0000000000..317331028c
--- /dev/null
+++ b/collects/net/cgi.ss
@@ -0,0 +1,11 @@
+
+(module cgi mzscheme
+  (require (lib "unitsig.ss"))
+
+  (require "cgi-sig.ss")
+  (require "cgi-unit.ss")
+
+  (define-values/invoke-unit/sig net:cgi^
+    net:cgi@)
+
+  (provide-signature-elements net:cgi^))
diff --git a/collects/net/cookie-sig.ss b/collects/net/cookie-sig.ss
new file mode 100644
index 0000000000..ef216c6c45
--- /dev/null
+++ b/collects/net/cookie-sig.ss
@@ -0,0 +1,19 @@
+(module cookie-sig mzscheme
+  (require (lib "unitsig.ss"))
+  (provide net:cookie^)
+
+  (define-signature net:cookie^
+    (set-cookie
+     cookie:add-comment
+     cookie:add-domain
+     cookie:add-max-age
+     cookie:add-path
+     cookie:secure
+     cookie:version
+     ;; To actually return a cookie (string formated as a cookie):
+     print-cookie
+     ;; To parse the Cookies header:
+     get-cookie
+     get-cookie/single
+     ;; exceptions
+     (struct cookie-error ()))))
diff --git a/collects/net/cookie-unit.ss b/collects/net/cookie-unit.ss
new file mode 100644
index 0000000000..bee49f50af
--- /dev/null
+++ b/collects/net/cookie-unit.ss
@@ -0,0 +1,297 @@
+;;;
+;;; <cookie-unit.ss> ---- HTTP cookies library
+;;; Time-stamp: <03/04/25 10:50:05 noel>
+;;;
+;;; Copyright (C) 2002 by Francisco Solsona. 
+;;;
+;;; This file is part of net.
+
+;;; net is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2.1 of the License, or (at your option) any later version.
+
+;;; net is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with net; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+;;; Author: Francisco Solsona <solsona@acm.org>
+;;
+;;
+;; Commentary:
+;;
+;; The PLT Web server offers functionality to keep state beyond the
+;; capacity of HTTP cookies.  Believe or not, sometimes you may want
+;; to keep stuff on the client end, like the theme the (anonymous)
+;; user likes, a session id, etc., so I wrote this wanna be library.
+;;
+;; It uses some of the surfies you see on the require section below.
+;; It doesn't actually "send" the Set-Cookie header to the browser, it
+;; doesn't even add the string "Set-Cookie: " to the will-be cookie it
+;; generates.  Why? well because you may want to use this code with
+;; very different Web browsers, and the way to send them may vary
+;; drastically.  For instance, if you are writing a CGI to be executed
+;; from a non-cooperative (from the PLT Scheme point of view) web
+;; server, like Apache, then you will `display' de cookie right to the
+;; standard output.  If you use FastCGI, you will `display' it trhough
+;; the `output' communication stream between your CGI, and the Web
+;; browser, but if you are using PLT Scheme Web browser, you will use
+;; `make-response/full', or similar, chances are you will add cookies
+;; to the `extras' parameter (extra headers), as cons pairs... as in
+;; `(("Set-Cookie" . "cookie=\"as_returned_by_this_library";etc"))'.
+;;
+;; You should think of this procedures as a `format' for cookies.
+
+(module cookie-unit mzscheme
+  (require (lib "unitsig.ss")
+           (lib "etc.ss")
+	   (lib "list.ss")
+	   (lib "string.ss" "srfi" "13")
+	   (lib "char-set.ss" "srfi" "14")
+           "cookie-sig.ss")
+
+  (provide cookie@)
+
+
+  (define cookie@
+    (unit/sig net:cookie^
+      (import)
+  
+      (define-struct cookie (name value comment domain max-age path secure version))
+      (define-struct (cookie-error exn) ())
+  
+      ;; The syntax for the Set-Cookie response header is
+      ;; set-cookie      =       "Set-Cookie:" cookies
+      ;; cookies         =       1#cookie
+      ;; cookie          =       NAME "=" VALUE *(";" cookie-av)
+      ;; NAME            =       attr
+      ;; VALUE           =       value
+      ;; cookie-av       =       "Comment" "=" value
+      ;; 		      |       "Domain" "=" value
+      ;; 		      |       "Max-Age" "=" value
+      ;; 		      |       "Path" "=" value
+      ;; 		      |       "Secure"
+      ;; 		      |       "Version" "=" 1*DIGIT
+      (define set-cookie
+        (lambda (name value)
+          (unless (and (cookie-string? name #f)
+                       (cookie-string? value))
+            (raise (make-cookie-error (format "Invalid NAME/VALUE pair: ~a / ~a" name value) (current-continuation-marks))))
+          (make-cookie name value
+                       #f;; comment
+                       #f;; current domain
+                       #f;; at the end of session
+                       #f;; current path
+                       #f;; normal (non SSL)
+                       #f;; default version
+                       )))
+
+      ;;!
+      ;;
+      ;; (function (print-cookie cookie))
+      ;;
+      ;; (param cookie Cookie-structure "The cookie to return as a string")
+      ;;
+      ;; Formats the cookie contents in a string ready to be appended to a
+      ;; "Set-Cookie: " header, and sent to a client (browser).
+      (define print-cookie
+        (lambda (cookie)
+          (unless (cookie? cookie)
+            (raise (make-cookie-error (format "Cookie expected, received: ~a" cookie) (current-continuation-marks))))
+          (string-join
+           (filter (lambda (s)
+                     (not (string-null? s)))
+                   (list (format "~a=~a" (cookie-name cookie) (cookie-value cookie))
+                         (let ((c (cookie-comment cookie))) (if c (format "Comment=~a" c) ""))
+                         (let ((d (cookie-domain cookie))) (if d (format "Domain=~a" d) ""))
+                         (let ((age (cookie-max-age cookie))) (if age (format "Max-Age=~a" age) ""))
+                         (let ((p (cookie-path cookie))) (if p (format "Path=~a" p) ""))
+                         (let ((s (cookie-secure cookie))) (if s "Secure" ""))
+                         (let ((v (cookie-version cookie))) (format "Version=~a" (if v v 1)))))
+           "; ")))
+
+      (define cookie:add-comment
+        (lambda (cookie comment)
+          (unless (cookie-string? comment)
+            (raise (make-cookie-error (format "Invalid comment: ~a" comment) (current-continuation-marks))))
+          (unless (cookie? cookie)
+            (raise (make-cookie-error (format "Cookie expected, received: ~a" cookie) (current-continuation-marks))))
+          (set-cookie-comment! cookie comment)
+          cookie))
+
+      (define cookie:add-domain
+        (lambda (cookie domain)
+          (unless (valid-domain? domain)
+            (raise (make-cookie-error (format "Invalid domain: ~a" domain) (current-continuation-marks))))
+          (unless (cookie? cookie)
+            (raise (make-cookie-error (format "Cookie expected, received: ~a" cookie) (current-continuation-marks))))
+          (set-cookie-domain! cookie domain)
+          cookie))
+
+      (define cookie:add-max-age
+        (lambda (cookie seconds)
+          (unless (and (integer? seconds) (not (negative? seconds)))
+            (raise (make-cookie-error (format "Invalid Max-Age for cookie: ~a" seconds) (current-continuation-marks))))
+          (unless (cookie? cookie)
+            (raise (make-cookie-error (format "Cookie expected, received: ~a" cookie) (current-continuation-marks))))
+          (set-cookie-max-age! cookie seconds)
+          cookie))
+
+      (define cookie:add-path
+        (lambda (cookie path)
+          (unless (string? path)
+            (raise (make-cookie-error (format "Invalid path: ~a" path) (current-continuation-marks))))
+          (unless (cookie? cookie)
+            (raise (make-cookie-error (format "Cookie expected, received: ~a" cookie) (current-continuation-marks))))
+          (set-cookie-path! cookie path)
+          cookie))
+   
+      (define cookie:secure
+        (lambda (cookie secure?)
+          (unless (boolean? secure?)
+            (raise (make-cookie-error (format "Invalid argument (boolean expected), received: ~a" secure?) (current-continuation-marks))))
+          (unless (cookie? cookie)
+            (raise (make-cookie-error (format "Cookie expected, received: ~a" cookie) (current-continuation-marks))))
+          (set-cookie-secure! cookie secure?)
+          cookie))
+
+      (define cookie:version
+        (lambda (cookie version)
+          (unless (integer? version)
+            (raise (make-cookie-error (format "Unsupported version: ~a" version) (current-continuation-marks))))
+          (unless (cookie? cookie)
+            (raise (make-cookie-error (format "Cookie expected, received: ~a" cookie) (current-continuation-marks))))
+          (set-cookie-version! cookie version)
+          cookie))
+
+
+      ;; Parsing the Cookie header:
+
+
+      (define char-set:all-but=
+        (char-set-difference char-set:full (string->char-set "=")))
+
+      (define char-set:all-but-semicolon
+        (char-set-difference char-set:full (string->char-set ";")))
+
+      ;;!
+      ;;
+      ;; (function (get-all-results name cookies))
+      ;;
+      ;; Auxiliar procedure that returns all values associated with
+      ;; `name' in the association list (cookies).
+      (define get-all-results
+        (lambda (name cookies)
+          (let loop ((c cookies))
+            (cond ((null? c) ())
+                  (else
+                   (let ((pair (car c)))
+                     (if (string=? name (car pair))
+                         ;; found an instance of cookie named `name'
+                         (cons (cadr pair) (loop (cdr c)))
+                         (loop (cdr c)))))))))
+   
+      ;; which tipically looks like: (cookie . "test5=\"5\"; test1=\"1\"; test0=\"0\"; test1=\"20\"")
+      ;; note that it can be multi-valued: `test1' has values: "1", and "20".
+      ;; Of course, in the same spirit, we only receive the "string content".
+      (define get-cookie
+        (lambda (name cookies)
+          (let ((cookies (map (lambda (p)
+                                (map string-trim-both
+                                     (string-tokenize p char-set:all-but=)))
+                              (string-tokenize cookies char-set:all-but-semicolon))))
+            (get-all-results name cookies))))
+
+      ;;!
+      ;;
+      ;; (function (get-cookie/single name cookies))
+      ;;
+      ;; (param name String "The name of the cookie we are looking for")
+      ;; (param cookies String "The string (from the environment) with the content of the cookie header.")
+      ;;
+      ;; Returns the first name associated with the cookie named `name', if any, or #f.
+      (define get-cookie/single
+        (lambda (name cookies)
+          (let ((cookies (get-cookie name cookies)))
+            (and (not (null? cookies))
+                 (car cookies)))))
+
+   
+   
+   ;;;;;
+      ;; Auxiliar procedures
+   ;;;;;
+   
+
+      ;; token          = 1*<any CHAR except CTLs or tspecials>
+      ;; 
+      ;; tspecials      = "(" | ")" | "<" | ">" | "@"
+      ;;	            | "," | ";" | ":" | "\" | <">
+      ;;	            | "/" | "[" | "]" | "?" | "="
+      ;;	            | "{" | "}" | SP | HT
+      (define char-set:tspecials
+        (char-set-union
+         (char-set-difference char-set:punctuation (string->char-set "_"))
+         char-set:whitespace))
+      (define char-set:control (char-set-union char-set:iso-control
+                                               (char-set (integer->char 127))));; DEL
+      (define char-set:token (char-set-difference char-set:ascii char-set:tspecials char-set:control))
+
+      ;;!
+      ;;
+      ;; (function (quoted-string? s))
+      ;;
+      ;; (param s String "The string to check")
+      ;;
+      ;; Returns #t only if the string is surrounded by double quotes.  As in:
+      ;; quoted-string  = ( <"> *(qdtext) <"> )
+      ;; qdtext         = <any TEXT except <">>
+      (define quoted-string?
+        (lambda (s)
+          (and (string=? (string-take s 1) "\"")
+               (string=? (string-take-right s 1) "\""))))
+
+      ;;!
+      ;;
+      ;; (function (cookie-string? s))
+      ;;
+      ;; (param s String "String to check")
+      ;;
+      ;; Returns whether this is a valid string to use as the value or the
+      ;; name (depending on value?) of an HTTP cookie.
+      (define cookie-string?
+        (opt-lambda (s (value? #t))
+          (unless (string? s)
+            (raise (make-cookie-error (format "String expected, received: ~a" s) (current-continuation-marks))))
+          (if value?
+              ;; value: token | quoted-string
+              (or (string-every char-set:token s)
+                  (quoted-string? s))
+              ;; name:  token
+              (string-every char-set:token s))))
+
+      ;; Host names as per RFC 1123 and RFC952, more or less, anyway. :-)
+      (define char-set:hostname
+        (let ((a-z-lowercase (ucs-range->char-set #x61 #x7B))
+              (a-z-uppercase (ucs-range->char-set #x41 #x5B)))
+          (char-set-adjoin!
+           (char-set-union char-set:digit a-z-lowercase a-z-uppercase)
+           #\. )))
+  
+      (define valid-domain?
+        (lambda (dom)
+          (and
+           ;; Domain must start with a dot (.)
+           (string=? (string-take dom 1) ".")
+           ;; The rest are tokens-like strings separated by dots
+           (string-every char-set:hostname dom)
+           (<= (string-length dom) 76))))
+      ))
+  )
+
+;;; cookie-unit.ss ends here
\ No newline at end of file
diff --git a/collects/net/cookie.ss b/collects/net/cookie.ss
new file mode 100644
index 0000000000..b9f4ceeafc
--- /dev/null
+++ b/collects/net/cookie.ss
@@ -0,0 +1,9 @@
+(module cookie mzscheme
+  (require (lib "unitsig.ss")
+           "cookie-sig.ss"
+           "cookie-unit.ss")
+
+  (provide-signature-elements net:cookie^)
+
+  (define-values/invoke-unit/sig net:cookie^
+    cookie@))
\ No newline at end of file
diff --git a/collects/net/dns-sig.ss b/collects/net/dns-sig.ss
new file mode 100644
index 0000000000..020f460bc1
--- /dev/null
+++ b/collects/net/dns-sig.ss
@@ -0,0 +1,12 @@
+
+(module dns-sig mzscheme
+  (require (lib "unitsig.ss"))
+
+  (provide net:dns^)
+  
+  (define-signature net:dns^
+    (dns-get-address
+     dns-get-name
+     dns-get-mail-exchanger
+     dns-find-nameserver)))
+
diff --git a/collects/net/dns-unit.ss b/collects/net/dns-unit.ss
new file mode 100644
index 0000000000..897bba3730
--- /dev/null
+++ b/collects/net/dns-unit.ss
@@ -0,0 +1,369 @@
+
+(module dns-unit mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "list.ss")
+           (lib "process.ss"))
+
+  (require "dns-sig.ss")
+
+  ;; UDP retry timeout:
+  (define INIT-TIMEOUT 50)
+
+  (provide net:dns@)
+  (define net:dns@
+    (unit/sig net:dns^
+      (import)
+
+      (define types
+	'((a 1)
+	  (ns 2)
+	  (md 3)
+	  (mf 4)
+	  (cname 5)
+	  (soa 6)
+	  (mb 7)
+	  (mg 8)
+	  (mr 9)
+	  (null 10)
+	  (wks 11)
+	  (ptr 12)
+	  (hinfo 13)
+	  (minfo 14)
+	  (mx 15)
+	  (txt 16)))
+
+      (define classes
+	'((in 1)
+	  (cs 2)
+	  (ch 3)
+	  (hs 4)))
+
+      (define (cossa i l)
+	(cond
+	 [(null? l) #f]
+	 [(equal? (cadar l) i)
+	  (car l)]
+	 [else (cossa i (cdr l))]))
+      
+
+      (define (number->octet-pair n)
+	(list (arithmetic-shift n -8)
+	      (modulo n 256)))
+
+      (define (octet-pair->number a b)
+	(+ (arithmetic-shift a 8)
+	   b))
+
+      (define (octet-quad->number a b c d)
+	(+ (arithmetic-shift a 24)
+	   (arithmetic-shift b 16)
+	   (arithmetic-shift c 8)
+	   d))
+
+      (define (name->octets s)
+	(let ([do-one (lambda (s)
+			(cons
+			 (bytes-length s)
+			 (bytes->list s)))])
+	  (let loop ([s s])
+	    (let ([m (regexp-match #rx#"^([^.]*)[.](.*)" s)])
+	      (if m
+		  (append
+		   (do-one (cadr m))
+		   (loop (caddr m)))
+		  (append
+		   (do-one s)
+		   (list 0)))))))
+
+      (define (make-std-query-header id question-count)
+	(append
+	 (number->octet-pair id)
+	 (list 1 0) ; Opcode & flags (recusive flag set)
+	 (number->octet-pair question-count)
+	 (number->octet-pair 0)
+	 (number->octet-pair 0)
+	 (number->octet-pair 0)))
+
+      (define (make-query id name type class)
+	(append
+	 (make-std-query-header id 1)
+	 (name->octets name)
+	 (number->octet-pair (cadr (assoc type types)))
+	 (number->octet-pair (cadr (assoc class classes)))))
+
+      (define (add-size-tag m)
+	(append (number->octet-pair (length m)) m))
+
+      (define (rr-data rr)
+	(cadddr (cdr rr)))
+
+      (define (rr-type rr)
+	(cadr rr))
+
+      (define (rr-name rr)
+	(car rr))
+
+      (define (parse-name start reply)
+	(let ([v (car start)])
+	  (cond
+	   [(zero? v)
+	    ;; End of name
+	    (values #f (cdr start))]
+	   [(zero? (bitwise-and #xc0 v))
+	    ;; Normal label
+	    (let loop ([len v][start (cdr start)][accum null])
+	      (cond
+	       [(zero? len) 
+		(let-values ([(s start) (parse-name start reply)])
+		  (let ([s0 (list->bytes (reverse! accum))])
+		    (values (if s
+				(bytes-append s0 #"." s)
+				s0)
+			    start)))]
+	       [else (loop (sub1 len) (cdr start) (cons (car start) accum))]))]
+	   [else
+	    ;; Compression offset
+	    (let ([offset (+ (arithmetic-shift (bitwise-and #x3f v) 8)
+			     (cadr start))])
+	      (let-values ([(s ignore-start) (parse-name (list-tail reply offset) reply)])
+		(values s (cddr start))))])))
+
+      (define (parse-rr start reply)
+	(let-values ([(name start) (parse-name start reply)])
+	  (let ([type (car (cossa (octet-pair->number (car start) (cadr start)) types))]
+		[start (cddr start)])
+	    (let ([class (car (cossa (octet-pair->number (car start) (cadr start)) classes))]
+		  [start (cddr start)])
+	      (let ([ttl (octet-quad->number (car start) (cadr start)
+					     (caddr start) (cadddr start))]
+		    [start (cddddr start)])
+		(let ([len (octet-pair->number (car start) (cadr start))]
+		      [start (cddr start)])
+					; Extract next len bytes for data:
+		  (let loop ([len len][start start][accum null])
+		    (if (zero? len)
+			(values (list name type class ttl (reverse! accum))
+				start)
+			(loop (sub1 len) (cdr start) (cons (car start) accum))))))))))
+
+      (define (parse-ques start reply)
+	(let-values ([(name start) (parse-name start reply)])
+	  (let ([type (car (cossa (octet-pair->number (car start) (cadr start)) types))]
+		[start (cddr start)])
+	    (let ([class (car (cossa (octet-pair->number (car start) (cadr start)) classes))]
+		  [start (cddr start)])
+	      (values (list name type class) start)))))
+
+      (define (parse-n parse start reply n)
+	(let loop ([n n][start start][accum null])
+	  (if (zero? n)
+	      (values (reverse! accum) start)
+	      (let-values ([(rr start) (parse start reply)])
+		(loop (sub1 n) start (cons rr accum))))))
+
+      (define (dns-query nameserver addr type class)
+	(unless (assoc type types)
+	  (raise-type-error 'dns-query "DNS query type" type))
+	(unless (assoc class classes)
+	  (raise-type-error 'dns-query "DNS query class" class))
+
+	(let* ([query (make-query (random 256) (string->bytes/latin-1 addr) type class)]
+	       [udp (udp-open-socket)]
+	       [reply
+		(dynamic-wind
+		    void
+		    
+		    (lambda ()
+		      (let ([s (make-bytes 512)])
+			(let retry ([timeout INIT-TIMEOUT])
+			  (udp-send-to udp nameserver 53 (list->bytes query))
+			  
+			  (sync
+			   (handle-evt
+			    (udp-receive!-evt udp s)
+			    (lambda (r)
+			      (bytes->list (subbytes s 0 (car r)))))
+			   (handle-evt
+			    (alarm-evt (+ (current-inexact-milliseconds)
+					  timeout))
+			    (lambda (v)
+			      (retry (* timeout 2))))))))
+		    
+		    (lambda ()
+		      (udp-close udp)))])
+
+          ; First two bytes must match sent message id:
+	  (unless (and (= (car reply) (car query))
+		       (= (cadr reply) (cadr query)))
+	    (error 'dns-query "bad reply id from server"))
+
+	  (let ([v0 (caddr reply)]
+		[v1 (cadddr reply)])
+            ; Check for error code:
+	    (let ([rcode (bitwise-and #xf v1)])
+	      (unless (zero? rcode)
+		(error 'dns-query "error from server: ~a"
+		       (case rcode
+			 [(1) "format error"]
+			 [(2) "server failure"]
+			 [(3) "name error"]
+			 [(4) "not implemented"]
+			 [(5) "refused"]))))
+	    
+	    (let ([qd-count (octet-pair->number (list-ref reply 4) (list-ref reply 5))]
+		  [an-count (octet-pair->number (list-ref reply 6) (list-ref reply 7))]
+		  [ns-count (octet-pair->number (list-ref reply 8) (list-ref reply 9))]
+		  [ar-count (octet-pair->number (list-ref reply 10) (list-ref reply 11))])
+	      
+	      (let ([start (list-tail reply 12)])
+		(let*-values ([(qds start) (parse-n parse-ques start reply qd-count)]
+			      [(ans start) (parse-n parse-rr start reply an-count)]
+			      [(nss start) (parse-n parse-rr start reply ns-count)]
+			      [(ars start) (parse-n parse-rr start reply ar-count)])
+		  (unless (null? start)
+		    (error 'dns-query "error parsing server reply"))
+		  (values (positive? (bitwise-and #x4 v0))
+			  qds ans nss ars reply)))))))
+
+      (define cache (make-hash-table))
+      (define (dns-query/cache nameserver addr type class)
+	(let ([key (string->symbol (format "~a;~a;~a;~a" nameserver addr type class))])
+	  (let ([v (hash-table-get cache key (lambda () #f))])
+	    (if v
+		(apply values v)
+		(let-values ([(auth? qds ans nss ars reply) (dns-query nameserver addr type class)])
+		  (hash-table-put! cache key (list auth? qds ans nss ars reply))
+		  (values auth? qds ans nss ars reply))))))
+
+      (define (ip->string s)
+	(format "~a.~a.~a.~a" 
+		(list-ref s 0)
+		(list-ref s 1)
+                (list-ref s 2)
+                (list-ref s 3)))
+
+      (define (try-forwarding k nameserver)
+	(let loop ([nameserver nameserver][tried (list nameserver)])
+          ; Normally the recusion is done for us, but it's technically optional
+	  (let-values ([(v ars auth?) (k nameserver)])
+	    (or v
+		(and (not auth?)
+		     (let* ([ns (ormap
+				 (lambda (ar)
+				   (and (eq? (rr-type ar) 'a)
+					(ip->string (rr-data ar))))
+				 ars)])
+		       (and ns
+			    (not (member ns tried))
+			    (loop ns (cons ns tried)))))))))
+
+  (define ip->in-addr.arpa
+    (lambda (ip)
+      (let ((result (regexp-match "([0-9]+)\\.([0-9]+)\\.([0-9]+)\\.([0-9]+)" ip)))
+        (format "~a.~a.~a.~a.in-addr.arpa"
+                (list-ref result 4)
+                (list-ref result 3)
+                (list-ref result 2)
+                (list-ref result 1)))))
+  
+  (define get-ptr-list-from-ans
+    (lambda (ans)
+      (filter (lambda (ans-entry)
+		(eq? (list-ref ans-entry 1) 'ptr))
+	      ans)))
+  
+  (define dns-get-name 
+    (lambda (nameserver ip)
+      (or (try-forwarding
+           (lambda (nameserver)
+             (let-values ([(auth? qds ans nss ars reply)
+                           (dns-query/cache nameserver (ip->in-addr.arpa ip) 'ptr 'in)])
+               (values (and (positive? (length (get-ptr-list-from-ans ans)))
+                            (let ([s (rr-data (car (get-ptr-list-from-ans ans)))])
+                              (let-values (((name null) (parse-name s reply)))
+                                (bytes->string/latin-1 name))))
+                       ars auth?)))
+           nameserver)
+          (error 'dns-get-name "bad ip address"))))
+  
+  (define get-a-list-from-ans
+    (lambda (ans)
+      (filter (lambda (ans-entry)
+                (eq? (list-ref ans-entry 1) 'a))
+              ans)))
+  
+  (define (dns-get-address nameserver addr)
+    (or (try-forwarding
+	 (lambda (nameserver)
+	   (let-values ([(auth? qds ans nss ars reply) (dns-query/cache nameserver addr 'a 'in)])
+	     (values (and (positive? (length (get-a-list-from-ans ans)))
+			  (let ([s (rr-data (car (get-a-list-from-ans ans)))])
+			    (ip->string s)))
+		     ars auth?)))
+	 nameserver)
+	(error 'dns-get-address "bad address")))
+
+  (define (dns-get-mail-exchanger nameserver addr)
+    (or (try-forwarding
+	 (lambda (nameserver)
+	   (let-values ([(auth? qds ans nss ars reply) (dns-query/cache nameserver addr 'mx 'in)])
+	     (values (let loop ([ans ans][best-pref +inf.0][exchanger #f])
+		       (cond
+			[(null? ans) (or exchanger
+					 ;; Does 'soa mean that the input address is fine?
+					 (and (ormap
+					       (lambda (ns) (eq? (rr-type ns) 'soa))
+					       nss)
+					      addr))]
+			[else
+			 (let ([d (rr-data (car ans))])
+			   (let ([pref (octet-pair->number (car d) (cadr d))])
+			     (if (< pref best-pref)
+				 (let-values ([(name start) (parse-name (cddr d) reply)])
+				   (loop (cdr ans) pref name))
+				 (loop (cdr ans) best-pref exchanger))))]))
+		     ars auth?)))
+	 nameserver)
+	(error 'dns-get-mail-exchanger "bad address")))
+
+  (define (dns-find-nameserver)
+    (case (system-type)
+      [(unix macosx)
+       (with-handlers ([void (lambda (x) #f)])
+	 (with-input-from-file "/etc/resolv.conf"
+	   (lambda ()
+	     (let loop ()
+	       (let ([l (read-line)])
+		 (or (and (string? l)
+			  (let ([m (regexp-match
+				    (format "nameserver[ ~a]+([0-9]+[.][0-9]+[.][0-9]+[.][0-9]+)" #\tab)
+				    l)])
+			    (and m (cadr m))))
+		     (and (not (eof-object? l))
+			  (loop))))))))]
+      [(windows)
+       (let ([nslookup (find-executable-path "nslookup.exe" #f)])
+         (and nslookup
+              (let-values ([(pin pout pid perr proc)
+                            (apply
+                             values
+                             (process/ports
+                              #f (open-input-file "NUL") (current-error-port)
+                              nslookup))])
+                (let loop ([name #f][ip #f][try-ip? #f])
+                  (let ([line (read-line pin 'any)])
+                    (cond [(eof-object? line)
+                           (close-input-port pin)
+                           (proc 'wait)
+                           (or ip name)]
+                          [(and (not name)
+                                (regexp-match #rx"^Default Server: +(.*)$"
+                                              line))
+                           => (lambda (m) (loop (cadr m) #f #t))]
+                          [(and try-ip?
+                                (regexp-match #rx"^Address: +(.*)$"
+                                              line))
+                           => (lambda (m) (loop name (cadr m) #f))]
+                          [else (loop name ip #f)]))))))]
+      [else #f])))))
+
diff --git a/collects/net/dns.ss b/collects/net/dns.ss
new file mode 100644
index 0000000000..44ad9cda6c
--- /dev/null
+++ b/collects/net/dns.ss
@@ -0,0 +1,11 @@
+
+(module dns mzscheme
+  (require (lib "unitsig.ss"))
+
+  (require "dns-sig.ss")
+  (require "dns-unit.ss")
+
+  (define-values/invoke-unit/sig net:dns^
+    net:dns@)
+
+  (provide-signature-elements net:dns^))
diff --git a/collects/net/doc.txt b/collects/net/doc.txt
new file mode 100644
index 0000000000..0a6548c57f
--- /dev/null
+++ b/collects/net/doc.txt
@@ -0,0 +1,2260 @@
+The `net' collection contains libraries that provide access to the
+following _Internet_ (quasi-)protocols:
+
+  URL parsing
+  CGI backends
+  sendmail
+  SMTP
+  NNTP
+  POP-3
+  IMAP
+  Mail header reading and writing
+  DNS
+
+==========================================================================
+_URL_ posting, _web clients_, _WWW_
+==========================================================================
+
+To load directly: (require (lib "url.ss" "net"))
+Module files: _url.ss_ - provides the procedures documented below
+              _url-unit.ss_ - provides unit net:url@
+              _url-sig.ss_ - provides signalture net:url^
+
+
+ABSTRACT -------------------------------------------------------------
+
+The url package helps programmers use URIs as specified in RFC 2396:
+http://www.ietf.org/rfc/rfc2396.txt
+
+TYPES ----------------------------------------------------------------
+
+> url
+  struct url (scheme user host port path fragment)
+  scheme : string or #f
+  user : string or #f
+  host : string or #f
+  port : number or #f
+  path : (listof (union string path/param))
+  query : (listof (cons symbol string))
+  fragment : string or #f
+
+  The basic structure for all URLs.
+
+  http://sky@www.cs.brown.edu:801/cgi-bin/finger;xyz?name=shriram;host=nw#top
+  {-1}   {2} {----3---------} {4}{---5---------} {6} {----7-------------} {8}
+
+  1 = scheme, 2 = user, 3 = host, 4 = port,
+  5 = path,  6 = param, 7 = query, 8 = fragment
+
+  If the scheme is "file", then the path is a platform-dependent
+  string assumed to have been constructed using build-path.  The library
+  does, however, check for the presence of a fragment designator and, if
+  there is one, separates it from the rest of the path.  For non-"file"
+  schemes, the path is a URL path as defined in the standard.
+
+  If a path segment has a parameter, it is represented with
+  an instance of the path/param struct. Otherwise, it is
+  just represented as a string.
+
+  The strings inside the fields user, path, query, and fragment are
+  represented directly as Scheme strings, ie without
+  url-syntax-specific quoting. The procedures `string->url' and
+  `url->string' translate things like %20 into spaces and back again.
+
+  By default, query associations are parsed with either ";" or "&" as
+  a separator, and they are generated with ";" as a separtor. The
+  `current-alist-separator-mode' parameter for "uri-codec.ss" adjusts
+  this default.
+
+  An empty string at the end of the list of paths
+  corresponds to a url that ends in a slash. For example,
+  this url: http://www.drscheme.org/a/ has a path field
+  '("a" "") and this url: http://www.drscheme.org/a
+  has a path field '("a").
+
+> path/param
+
+  A pair of strings, accessible with _path/param-path_ and
+  path/param-params_ that joins a path segment with its
+  params in a url. The function _path/param?_ recognizes
+  such pairs.
+
+> pure-port
+
+  A pure port is one from which the MIME headers have been removed, so
+  that what remains is purely the first content fragment.
+
+> impure-port
+
+  An impure port is one that still has its MIME headers.  Contrast
+  with a pure-port.
+
+PROCEDURES -----------------------------------------------------------
+
+> unixpath->path
+
+  This procedure, which used to be provided by this library, is no
+  longer supported.
+
+> (string->url string) -> url
+
+  Parses the url specified by the string into a url struct. The
+  `string->url' procedure uses `form-urlencoded->alist' when parsing
+  the query, so it is sensitive to the `current-alist-separator-mode'
+  parameter for determining the association separtor.
+
+> (combine-url/relative url string) -> url
+
+  Given a base URL and a relative path, combines the two and returns a
+  new URL as per the URL combination specification.  Call the
+  arguments base and relative.  They are combined according to the
+  following rules (applied in order until one matches):
+  - If either argument is an empty URL, the result is the other
+    argument.
+  - If relative sports a scheme, then the result is relative.
+  - If the base has scheme "file", the procedure uses the special rule
+    specified below.
+  - If relative specifies a host, then the result is relative.
+  Failing the above, relative inherit's base's host and port.  Then:
+  - If the path of relative begins with a "/", the result is relative.
+  - If the path of relative is empty, then relative inherits base's
+    params and query, and the result is relative.
+  - Otherwise base and relative are combined as per the standard
+    specification of merging and normalization.
+
+  On combining "file" schemes:
+
+  If the base has scheme "file", relative is treated as a
+  slash-separated path (unless it contains an empty path --- only
+  params, queries, and fragments --- in which case the path is not
+  used).  These path fragments are combined using build-path, starting
+  with the base's path.  Three path segments are special: ".."
+  corresponds to an 'up directive to build-path, while "." and ""
+  correspond to 'same.  As a consequence, if relative begins with "/",
+  this does not make it an absolute URL: the leading slash is treated
+  as if the initial segment is "", so this has no effect, and base's
+  path remains the base path of the result.  If base refers to a
+  directory, relative is indexed from that directory; if base refers
+  to a file, relative is indexed from the directory containing the
+  file.  Note that if base does not refer to an actual directory that
+  exists on the filesystem, then it must syntactically be a directory
+  as understood by split-path.
+
+  The above algorithm tests for the presence of a directory to
+  correctly combine paths.  As a result, it can raise any exception
+  raised by directory-exists?.  None of these exceptions is trapped by
+  the procedure; consumers must be prepared for them.
+
+> (netscape/string->url string) -> url
+
+  Turns a string into a URL, applying (what appear to be) Netscape's
+  conventions on automatically specifying the scheme: a string
+  starting with a slash gets the scheme "file", while all others get
+  the scheme "http".
+
+> (url->string url) -> string
+
+  Generates a string corresponding to the contents of the url struct.
+
+  The `url->string' procedure uses `alist->form-urlencoded' when
+  formatting the query, so it it sensitive to the
+  `current-alist-separator-mode' parameter for determining the
+  association separtor. In particular, the default is to separate
+  associations with ";" (based on modern recommendations) instead of
+  "&".
+
+> (decode-some-url-parts url) -> url
+
+  This procedure, which used to be provided by this library, is no
+  longer supported or necessary. A `url' struct not contains properly
+  decoded information.
+
+> (get-pure-port url [list-of-strings]) -> input-port
+
+  Takes a URL and returns a pure port corresponding to it.  Writes the
+  optional RFC 822 header-line strings to the server.  For the "file"
+  scheme, uses open-input-file, does not handle exceptions, and
+  ignores the optional strings.
+
+> (post-pure-port url post-byte-string [list-of-strings]) -> input-port
+
+  Like `get-pure-port', but issues a POST request (instead of a GET
+  request) to a web server using the given post data byte string.
+
+> (get-impure-port url [list-of-strings]) -> input-port
+
+  Takes a URL and returns an impure port corresponding to it.  Writes
+  the optional RFC 822 header-line strings to the server.  There are
+  no impure ports with scheme "file".
+
+> (post-impure-port url post-byte-string [list-of-strings]) -> input-port
+
+  Like `get-impure-port', but issues a POST request (instead of a GET
+  request) to a web server using the given post data string.
+
+> (display-pure-port input-port) -> void
+
+  Writes the output of a pure port.  For debugging purposes.
+
+> (purify-port input-port) -> string
+
+  Purifies a port, returning the MIME headers, plus a leading line
+  for the form
+
+   HTTP/<vers> <code> <messsage>
+
+  where <vers> is something like 1.0 or 1.1, <code> is an exact
+  integer for the response code, and <message> is arbitrary text
+  without a return or newline.
+
+  The "head.ss" library provides procedures, such as `extract-field,
+  for manipulating the header.
+
+  Since web server sometimes return mis-formatted replies,
+  `purify-port' is liberal in what it accepts as a header. as a
+  result, the result string may be ill formed, but it will either be
+  the empty string, or it will be a string matching the following
+  regexp:
+
+      #rx"^HTTP/.*?((\r\n\r\n)|(\n\n)|(\r\r))"
+
+> (call/input-url url url->port-proc port->X-proc [list-of-strings]) -> X
+
+  First argument is the URL to open.  Second is a procedure that takes
+  a URL and turns it into a (pure or impure) port.  The third takes
+  the (pure or impure) port and handles its contents.  The optional
+  fourth argument is a set of strings to send to the server. The result
+  of `call/input-url' is the result of the third argument procedure.
+
+> (current-proxy-servers) -> (list (list scheme string port-number) ...)
+> (current-proxy-servers server-mapping) -> void
+
+  The `current-proxy-server' parameter determines a mapping of proxy
+  servers used for connections. The mapping is of the form
+
+    (list (list proxiable-scheme server-string port-number) ...)
+
+  where, currently, the only proxiable scheme is "http". An omitted
+  mapping indicates that no proxy should be used. The default mapping
+  is the empty list (i.e., no proxies).
+
+PRAGMATICS -----------------------------------------------------------
+
+_web documents_
+
+  To access the text of a document from the Web, first obtain its URL
+  as a string; convert this into a url structure using string->url;
+  then open the document using get-pure-port or get-impure-port,
+  depending on whether or not you wish to examine its MIME headers.
+  At this point you have a regular input port with which to process
+  the document like any other file.  Note that currently the only
+  supported protocol is "http".  The "news" protocol is not supported
+  directly by this library, but the news library in this collection
+  can be used to read NNTP documents.
+
+EXAMPLE --------------------------------------------------------------
+
+ (require (lib "url.ss" "net"))
+ (define url:cs (string->url "http://www.cs.rice.edu/"))
+ (define (test url)
+   (call/input-url url get-pure-port display-pure-port))
+ (test url:cs)
+
+UNITS ----------------------------------------------------------------
+
+The _url-sig.ss_ module exports the _net:url^_ signature which
+contains the names documented above. the _url-unit.ss_ module exports
+_url@_, a unit that imports net:tcp^ (see "tcp-sig.ss", below) and
+exports the names in net:url^.
+
+==========================================================================
+_URL viewing_
+==========================================================================
+
+To load a module for accessing a Web _browser_ either
+  (require (lib "external.ss" "browser"))
+or
+  (require (lib "sendurl.ss" "net"))
+
+The version in "browser" will prompt the user for a browser preference
+if not already set.  The version in "sendurl.ss" lacks this capability,
+but does not depend on MrEd's graphical toolbox.
+
+These modules define one main function:
+
+> (send-url str [separate-window? #t]) -
+  opens the url in a platform-specific manner,
+  sending a message to the local browser to display the url named
+  by `str'. The separate-window? parameter determines
+  if the browser creates a new window to display the url
+  or not.
+
+  Under Windows, `send-url' uses the registry to get a
+  browser-launching command line. The registry can be read only from
+  MrEd (i.e., not MzScheme).
+
+  Under Mac OS, `send-url' uses the URL apple event library.
+
+  Under Unix, `send-url' uses the value of a the _external-browser_
+  parameter to select a browser.  The parameter is initialized to the
+  value of the _'external-browser preference_, which can be either
+  'opera, 'galeon, 'netscape, 'mozilla, 'dillo, #f, or a pair of
+  strings.  If #f, `send-url' uses the first of these browsers found
+  in the path.  If the parameter is a pair of strings, then the first
+  string, the url requested, followed by the second string is
+  interpreted as a command line used to launch a browser.  If the
+  preferred or default browser can't be launched, `send-url'
+  fails. See the file.ss library for details on setting preferences.
+
+> (browser-preference? v) -> bool
+  return #t if v is a valid browser preference
+
+==========================================================================
+_CGI_ backends, _WWW_
+==========================================================================
+
+To load directly: (require (lib "cgi.ss" "net"))
+Module files: _cgi.ss_ - provides the procedures documented below
+              _cgi-unit.ss_ - provides unit net:cgi@
+              _cgi-sig.ss_ - provides signalture net:cgi^
+
+ABSTRACT -------------------------------------------------------------
+
+The cgi package helps programmers write scripts that follow the Common
+Gateway Interface (CGI/1.1) protocol of the World-Wide Web:
+http://hoohoo.ncsa.uiuc.edu/cgi/
+
+INTERACTIONS ---------------------------------------------------------
+
+The CGI library expects to be run in a certain context as defined by
+the CGI standard.  This means, for instance, that certain environment
+variables will be bound.  Unfortunately, not all CGI environments
+provide this.  For instance, the FastCGI library, despite its name,
+does not bind the environment variables required of the standard.
+Users of FastCGI will need to bind REQUEST_METHOD and possibly also
+QUERY_STRING to successfully employ the CGI library.  The FastCGI
+library ought to provide a way to extract the values bound to these
+variables; the user can then put these into the CGI program's
+environment using PLT Scheme's `putenv' function.
+
+TYPES ----------------------------------------------------------------
+
+binding:
+
+  A binding is an association of a form item with its value.  Some form
+  items (such as checkboxes) may correspond to multiple bindings.  A
+  binding is a tag-string pair, where a tag is a symbol or a string.
+
+bindings:
+
+  A list of `binding's.
+
+html-string:
+
+  A text string that has been escaped according to HTML conventions.
+
+EXCEPTIONS -----------------------------------------------------------
+
+> cgi-error
+  struct cgi-error ()
+
+  cgi-error is a super-structure for all exceptions thrown by this
+  library.
+
+> incomplete-%-suffix
+  struct (incomplete-%-suffix cgi-error) (chars)
+  chars : list of chars
+
+  Used when a % in a query is followed by an incomplete suffix.  The
+  characters of the suffix -- excluding the "%" -- are provided by the
+  exception.
+
+> invalid-%-suffix
+  struct (invalid-%-suffix cgi-error) (char)
+  char : char
+
+  Used when the character immediately following a % in a query is
+  invalid.
+
+PROCEDURES -----------------------------------------------------------
+
+> (get-bindings) -> bindings
+> (get-bindings/post) -> bindings
+> (get-bindings/get) -> bindings
+
+  Returns the bindings that corresponding to the options specified by
+  the user.  The /post and /get forms work only when POST and GET
+  forms are used, respectively, while get-bindings determines the kind
+  of form that was used and invokes the appropriate function.
+
+> (extract-bindings symbol-or-string bindings) -> list of strings
+
+  Given a key and a set of bindings, extract-bindings determines which
+  ones correspond to a given key.  There may be zero, one, or many
+  associations for a given key.
+
+> (extract-binding/single symbol-or-string bindings) -> string
+
+  Given a key and a set of bindings, extract-binding/single ensures
+  that the key has exactly one association, and returns it.
+
+> (output-http-headers) -> void
+
+  Outputs all the http headers needed for a normal html response.
+  Only call this function if you are not using generate-html-output
+  or generate-error-output.
+
+> (generate-html-output html-string list-of-html-strings [color color color color color]) -> void
+
+  The first argument is the title.  The second is a list of strings
+  that consist of the body.  The last five arguments are each strings
+  representing a HTML color; in order, they represent the color of the
+  text, the background, un-visited links, visited links, and a link
+  being selected.
+
+> (string->html string) -> html-string
+
+  Converts a string into an html-string by applying the appropriate
+  HTML quoting conventions.
+
+> (generate-link-text string html-string) -> html-string
+
+  Takes a string representing a URL, a html-string for the anchor
+  text, and generates HTML corresponding to an achor.
+
+> (generate-error-output list-of-html-strings) -> <exit>
+
+  The procedure takes a series of strings representing the body,
+  prints them with the subject line "Internal error", and forces the
+  script to exit.
+
+> (get-cgi-method) -> string
+
+  Returns either "GET" or "POST".  Always returns a string when
+  invoked inside a CGI script.  Unpredictable otherwise.
+
+> (bindings-as-html bindings) -> list of html-strings
+
+  Converts a set of bindings into a list of html-string's.  Useful for
+  debugging.
+
+==========================================================================
+_sending mail_, _sendmail_
+==========================================================================
+
+To load directly: (require (lib "sendmail.ss" "net"))
+Module files: _sendmail.ss_ - provides the procedures documented below
+              _sendmail-unit.ss_ - provides unit net:sendmail@
+              _sendmail-sig.ss_ - provides signalture net:sendmail^
+
+
+ABSTRACT -------------------------------------------------------------
+
+The sendmail package helps programmers write programs that need to
+send electronic mail messages.  The package assumes the existence of a
+conformant sendmail program on the local system; see also the SMTP
+package, below (and, in most cases, use it instead).
+
+TYPES ----------------------------------------------------------------
+
+  All strings used in mail messages are assumed to conform to their
+  corresponding SMTP specifications, except as noted otherwise.
+
+EXCEPTIONS -----------------------------------------------------------
+
+> no-mail-recipients
+  struct (no-mail-recipients exn) ()
+
+  Raised when no mail recipients were specified.
+
+PROCEDURES -----------------------------------------------------------
+
+> (send-mail-message/port from-string subject-string to-list-of-strings cc-list-of-strings bcc-list-of-string) -> output-port
+
+  The first argument is the header for the sender, the second is the
+  subject line, the third a list of To: recipients, the fourth a list
+  of CC: recipients, and the fifth a list of BCC: recipients.  The
+  optional sixth argument is used for other mail headers, which must
+  be specified completely formatted.
+
+  The return value is an output port into which the client must write
+  the message.  Clients are urged to use close-output-port on the
+  return value as soon as the necessary text has been written, so that
+  the sendmail process can complete.
+
+  The sender can hold any value, though of course spoofing should be
+  used with care.
+
+> (send-mail-message from-string subject-string to-list-of-strings cc-list-of-strings bcc-list-of-string body-list-of-strings [extra-headers-list-of-strings]) -> void
+
+  The arguments are the same as that for send-mail-message/port except
+  that there is one extra input, the list of strings corresponding to
+  the mail message (followed by the optional additional headers, if
+  present).  There is no interesting return value.
+
+  Lines that contain a single period do not need to be quoted.
+
+==========================================================================
+_sending mail_, _SMTP_
+==========================================================================
+
+To load directly: (require (lib "smtp.ss" "net"))
+Module files: _smtp.ss_ - provides the procedures documented below
+              _smtp-unit.ss_ - provides unit net:smtp@
+              _smtp-sig.ss_ - provides signalture net:smtp^
+
+ABSTRACT -------------------------------------------------------------
+
+The SMTP package helps programmers write programs that need to send
+electronic mail messages using SMTP. The client must provide the
+address of an SMTP server; in contrast, the mail package (see above)
+uses a pre-configured sendmail on the local system.
+
+TYPES ----------------------------------------------------------------
+
+  The head package defines the format of a `header' string, which is
+  used by `send-smtp-message'. The head package also provides
+  utilities to verify the formatting of a mail address. The procedures
+  of the SMTP package assume that the given string arguments are
+  well-formed.
+
+EXCEPTIONS -----------------------------------------------------------
+
+  Communication errors are signalled via exn:fail structure instances.
+
+PROCEDURES -----------------------------------------------------------
+
+> (smtp-send-message server-string from-string to-list-of-strings header
+                     message-list-of-strings/bytes [port]) -> void
+
+  The first argument is the IP address of the SMTP server. The
+  `from-string' argument specifies the mail address of the sender, and
+  `to-listof-strings' is a list of recipient addresses (including
+  "To", "CC", and "BCC" recipients). The `header' argument is the
+  complete message header, which should already include "From", "To",
+  and "CC" fields consistent with the given sender and recipients.
+  the `message-list-of-strings/bytes' argument is the body of the
+  message, where each string or byte string in the list corresponds to
+  a single line of message text; no string in
+  `message-list-of-strings' should contain a carriage return or
+  newline characters. The optional `port' argument specifies the IP
+  port to use in contacting the SMTP server; the default is 25.
+
+  See the head package for utilities that construct a message headers
+  and validate mail address strings.
+
+> (smtp-sending-end-of-message [proc])
+
+  Parameter that detemines a send-done procedure to be called after
+  `smtp-send-message' has completely sent the message. Before the
+  send-done procedure is called, breaking the thread that is executing
+  `smtp-send-message' cancels the send. After the send-done procedure
+  is called, breaking may or may not cancel the send (and probably
+  won't).
+
+==========================================================================
+_NNTP_, _newsgroups_
+==========================================================================
+
+To load directly: (require (lib "nntp.ss" "net"))
+Module files: _nntp.ss_ - provides the procedures documented below
+              _nntp-unit.ss_ - provides unit net:nntp@
+              _nntp-sig.ss_ - provides signalture net:nntp^
+
+ABSTRACT -------------------------------------------------------------
+
+The nntp package helps programmers access Usenet groups via the NNTP
+protocols:
+http://www.ietf.org/rfc/rfc0977.txt
+
+TYPES ----------------------------------------------------------------
+
+> communicator
+  struct communicator (sender receiver server port)
+  sender : oport
+  receiver : iport
+  server : string
+  port : number
+
+  Once a connection to a Usenet server has been established, its state
+  is stored in a communicator, and other procedures take communicators
+  as an argument.
+
+> message-index
+
+  A number or string (the number is common, but a string is useful for
+  specifying the entire Message-ID).
+
+> desired
+
+  A regular expression that matches against a Usenet header.
+
+EXCEPTIONS -----------------------------------------------------------
+
+> nntp
+  struct (nntp exn) ()
+
+  The super-struct of all subsequent exceptions.
+
+> unexpected-response
+  struct (unexpected-response nntp) (code text)
+  code : number
+  text : string
+
+  Thrown whenever an unexpected response code is received.  The text
+  holds the response text sent by the server.
+
+> bad-status-line
+  struct (bad-status-line nntp) (line)
+  line : string
+
+  Mal-formed status lines.
+
+> premature-close
+  struct (premature-close nntp) (communicator)
+  communicator : communicator
+
+  Thrown when a remote server closes its connection unexpectedly.
+
+> bad-newsgroup-line
+  struct (bad-newsgroup-line nntp) (line)
+  line : string
+
+  When the newsgroup line is improperly formatted.
+
+> non-existent-group
+  struct (non-existent-group nntp) (group)
+  group : string
+
+  When the server does not recognize the name of the requested group.
+
+> article-not-in-group
+  struct (article-not-in-group nntp) (article)
+  article : number
+
+  When an article is outside the server's range for that group.
+
+> no-group-selected
+  struct (no-group-selected nntp) ()
+
+  When an article operation is used before a group has been selected.
+
+> article-not-found
+  struct (article-not-found nntp) (article)
+  article : number
+
+  When the server is unable to locate the article.
+
+> authentication-rejected
+  struct (authentication-rejected nntp) ()
+
+  When the server reject an authentication attempt.
+
+PROCEDURES -----------------------------------------------------------
+
+> (connect-to-server server-string [port-number]) -> communicator
+
+  Connects to the name server.  The second argument, if provided, must
+  be a port number; otherwise the default NNTP port is used.
+
+> (disconnect-from-server communicator) -> void
+
+  Disconnects a communicator.
+
+> (open-news-group communicator newsgroup-string) -> three values: number number number
+
+  The second argument is the name of a newsgroup.  The returned values
+  are the total number of articles in that group, the first available
+  article, and the last available article.
+
+> (authenticate-user communicator username password) -> void
+
+  Tries to authenticate a user.  This is using the original authinfo command
+  (uses cleartext).  The password argument is ignored if the server does not
+  ask for it.
+
+> (head-of-message communicator message-index) -> list of strings
+
+  Given a message number, returns its headers.
+
+> (body-of-message communicator message-index) -> list of strings
+
+  Given a message number, returns the body of the message.
+
+> (newnews-since communicator message-index) -> list of strings
+
+  Implements the NEWNEWS command (often disabled on servers).
+
+> (generic-message-command communicator message-index) -> list of strings
+
+  Useful primitive for implementing head-of-message, body-of-message
+  and other similar commands.
+
+> (make-desired-header tag-string) -> desired
+
+  Takes the header's tag and returns a desired regexp for that header.
+
+> (extract-desired-headers list-of-header-strings list-of-desireds) -> list of strings
+
+  Given a list of headers and of desired's, returns the header lines
+  that match any of the desired's.
+
+==========================================================================
+_POP-3_, _reading mail_
+==========================================================================
+
+To load directly: (require (lib "pop3.ss" "net"))
+Module files: _pop3.ss_ - provides the procedures documented below
+              _pop3-unit.ss_ - provides unit net:pop3@
+              _pop3-sig.ss_ - provides signalture net:pop3^
+
+ABSTRACT -------------------------------------------------------------
+
+Implements RFC 1939, Post Office Protocol - Version 3, Myers & Rose.
+http://www.ietf.org/rfc/rfc1939.txt
+
+TYPES ----------------------------------------------------------------
+
+> communicator
+  struct communicator (sender receiver server port state)
+  sender : oport
+  receiver : iport
+  server : string
+  port : number
+  state : symbol = (disconnected, authorization, transaction)
+
+  Once a connection to a POP-3 server has been established, its state
+  is stored in a communicator, and other procedures take communicators
+  as an argument.
+
+> desired
+
+  A regular expression that matches against a mail header.
+
+EXCEPTIONS -----------------------------------------------------------
+
+> pop3
+  struct (pop3 exn) ()
+
+  The super-struct used for all other package exceptions.
+
+> cannot-connect
+  struct (cannot-connect pop3) ()
+
+  When a connection to a server cannot be established.
+
+> username-rejected
+  struct (username-rejected pop3) ()
+
+  If the username is rejected.
+
+> password-rejected
+  struct (password-rejected pop3) ()
+
+  If the password is rejected.
+
+> not-ready-for-transaction
+  struct (not-ready-for-transaction pop3) (communicator)
+  communicator : communicator
+
+  When the communicator is not in transaction mode.
+
+> not-given-headers
+  struct (not-given-headers pop3) (communicator message)
+  communicator : communicator
+  message : number
+
+  When the server does not respond with headers for a message as
+  requested.
+
+> illegal-message-number
+  struct (illegal-message-number pop3) (communicator message)
+  communicator : communicator
+  message : number
+
+  When the user specifies an illegal message number.
+
+> cannot-delete-message
+  struct (cannot-delete-message exn) (communicator message)
+  communicator : communicator
+  message : number
+
+  When the server is unable to delete a message.
+
+> disconnect-not-quiet
+  struct (disconnect-not-quiet pop3) (communicator)
+  communicator : communicator
+
+  When the server does not gracefully disconnect.
+
+> malformed-server-response
+  struct (malformed-server-response pop3) (communicator)
+  communicator : communicator
+
+  When the server produces a mal-formed response.
+
+PROCEDURES -----------------------------------------------------------
+
+> (connect-to-server server-string [port-number]) -> communicator
+
+  Connects to a server.  Uses the default port number if none is
+  provided.
+
+> (disconnect-from-server communicator) -> void
+
+  Disconnects from as server.  Sets the communicator state to
+  disconnected.
+
+> (authenticate/plain-text user-string passwd-string communicator) -> void
+
+  Takes a username and password string and, if successful, changes the
+  communicator's state to transaction.
+
+> (get-mailbox-status communicator) -> two values: count-number octet-number
+
+  Returns the number of messages and the number of octets.
+
+> (get-message/complete communicator message-number) -> two lists of strings
+
+  Given a message number, returns a list of headers and list of
+  strings for the body.
+
+> (get-message/headers communicator message-number) -> list of strings
+
+  Given a message number, returns the list of headers.
+
+> (get-message/body communicator message-number) -> list of strings
+
+  Given a message number, returns the list of strings for the body.
+
+> (delete-message communicator message-number) -> void
+
+  Deletes the specified message.
+
+> (get-unique-id/single communicator message-number) -> string
+
+  Gets the server's unique id for a particular message.
+
+> (get-unique-id/all communicator) -> list of (cons message-number id-string)
+
+  Gets a list of unique id's from the server for all the messages in
+  the mailbox.
+
+> (make-desired-header tag-string) -> desired
+
+  Takes the header's tag and returns a desired regexp for that header.
+
+> (extract-desired-headers list-of-strings list-of-desireds) -> list of strings
+
+  Given a list of headers and of desired's, returns the header lines
+  that match any of the desired's.
+
+EXAMPLE --------------------------------------------------------------
+
+ > (require (lib "pop3.ss" "net"))
+ > (define c (connect-to-server "cs.rice.edu"))
+ > (authenticate/plain-text "scheme" "********" c)
+ > (get-mailbox-status c)
+ 196
+ 816400
+ > (get-message/headers c 100)
+ ("Date: Thu, 6 Nov 1997 12:34:18 -0600 (CST)"
+  "Message-Id: <199711061834.MAA11961@new-world.cs.rice.edu>"
+  "From: Shriram Krishnamurthi <shriram@cs.rice.edu>"
+  ...
+  "Status: RO")
+ > (get-message/complete  c 100)
+ ("Date: Thu, 6 Nov 1997 12:34:18 -0600 (CST)"
+  "Message-Id: <199711061834.MAA11961@new-world.cs.rice.edu>"
+  "From: Shriram Krishnamurthi <shriram@cs.rice.edu>"
+  ...
+  "Status: RO")
+ ("some body" "text" "goes" "." "here" "." "")
+ > (get-unique-id/single c 205)
+ no message numbered 205 available for unique id
+ > (list-tail (get-unique-id/all c) 194)
+ ((195 . "e24d13c7ef050000") (196 . "3ad2767070050000"))
+ > (get-unique-id/single c 196)
+ "3ad2767070050000"
+ > (disconnect-from-server c)
+
+==========================================================================
+_IMAP_, _reading mail_
+==========================================================================
+
+To load directly: (require (lib "imap.ss" "net"))
+Module files: _imap.ss_ - provides the procedures documented below
+              _imap-unit.ss_ - provides unit net:imap@
+              _imap-sig.ss_ - provides signalture net:imap^
+
+ABSTRACT -------------------------------------------------------------
+
+Implements portions of client-side RFC 2060, Internet Message Access
+Protocol - Version 4rev1, Crispin
+http://www.ietf.org/rfc/rfc2060.txt
+
+TYPES ----------------------------------------------------------------
+
+> imap
+
+  An opaque record reprsenting an IMAP connection.
+
+> imap-flag
+
+  A symbol, but generally not a convenient one to use within a Scheme
+  program. The `imap-flag->symbol' and `symbol->imap-flag' procedures
+  convert IMAP flags to convenient symbols and vice-versa.
+
+EXCEPTIONS -----------------------------------------------------------
+
+  Communication errors are signalled via exn:fail structure instances.
+
+PROCEDURES -----------------------------------------------------------
+
+- - - - - - Connecting and selecting mailboxes - - - - -
+
+> (imap-connect server-string username-str/bytes password-str/bytes mailbox-str/bytes)
+   -> three values: imap, message count, recent message count
+
+  Establishes an IMAP connection to the given server using the given
+  username and password, and selects the specified mailbox. The second
+  and third return values indicate the total number of messages in the
+  mailbox and the number of recent messages (i.e., messages received
+  since the mailbox was last selected), respectively.
+
+  See also `imap-port-number', below.
+
+  A user's primary mailbox is always called "INBOX". (Capitalization
+  doesn't matther for that keyword.)
+
+  Updated message-count and recent-count values are available through
+  `imap-messages' and `imap-recent'. See also `imap-new?' and
+  `imap-reset-new!'.
+
+> (imap-port-number [k])
+
+  A parameter that determines the server port number. The initial
+  value is 143.
+
+> (imap-connect* in-port out-port username-str/bytes password-str/bytes mailbox-str/bytes)
+   -> three values: imap, message count, recent message count
+
+  Like `imap-connect', but given input and output ports instead of a
+  server address.
+
+> (imap-disconnect imap) -> void
+
+  Closes an IMAP connection. The close may fail due to a communication
+  error.
+
+> (imap-force-disconnect imap) -> void
+
+  Closes an IMAP connection forcefully (i.e., without send a close
+  message to the server). A forced disconnect never fails.
+
+> (imap-reselect imap mailbox-str/bytes)
+  -> two values: message count and recent message count
+
+  De-selects the mailbox currently selected by the connection and
+  selects the specified mailbox, returning the total and recent
+  message counts for the new mailbox. Expunge and message-state
+  information is removed.
+
+  Do not use this procedure to poll a mailbox to see whether there are
+  any new messages. Use `imap-noop', `imap-new?', and
+  `imap-reset-new?' instead.
+
+> (imap-examine imap mailbox-str/bytes)
+  -> two values: message count and recent message count
+
+  Like `imap-reselect', but the mailbox is selected as read-only.
+
+- - - - - - Selected mailbox state - - - - -
+
+> (imap-noop imap mailbox-str/bytes)
+  -> two values: message count and recent message count
+
+  Sends a "no-op" message to the server, typically to keep the session
+  alive. As for many commands, the server may report message-state
+  updates or expunges.
+
+  The return information is the same as for `imap-reselect'.
+
+> (imap-poll imap) -> void
+
+  Does not send a request to the server, but checks for asynchronous
+  messages from the server that update the message count, to report
+  expunges, etc.
+
+
+> (imap-messages imap) -> number
+
+  Returns the number of messages in the selected mailbox. The server
+  can update this count during most any interaction.
+
+  This operation does not communicate with the server. It merely
+  reports the result of previous communication.
+
+> (imap-recent imap) -> number
+
+  Returns the number of "recent" messages in the currently selected
+  mailbox, as most recently reported by the server. The server can
+  update this count during most any interaction.
+
+  This operation does not communicate with the server. It merely
+  reports the result of previous communication.
+
+> (imap-unseen imap) -> number-or-false
+
+  Returns the number of "unseen" messages in the currently selected
+  mailbox, as most recently reported by the server. The server can
+  update this count during most any interaction. Old IMAP servers
+  might not report this value, in which case the result is #f.
+
+  This operation does not communicate with the server. It merely
+  reports the result of previous communication.
+
+> (imap-uidnext imap) -> number-or-false
+
+  Returns the predicted next uid for a message in the currently
+  selected mailbox, as most recently reported by the server. The
+  server can update this count during most any interaction. Old IMAP
+  servers might not report this value, in which case the result is #f.
+
+  This operation does not communicate with the server. It merely
+  reports the result of previous communication.
+
+> (imap-uidvalidity imap) -> number-or-false
+
+  Returns an id number that changes when all uids become invalid. The
+  server *cannot* update this number during a session. Old IMAP
+  servers might not report this value, in which case the result is #f.
+
+  This operation does not communicate with the server. It merely
+  reports the result of previous communication.
+
+> (imap-new? imap) -> boolean
+
+  Returns #t if the server has reported an increase in the message
+  count for the currently mailbox since the last call to
+  `imap-reset-new!'. Selecting a mailbox implicitly calls
+  `imap-reset-new!'.
+
+  This operation does not communicate with the server. It merely
+  reports the result of previous communication.
+
+> (imap-reset-new! imap) -> void
+
+  Resets the new flag for the session; see `imap-new?', above.
+  This operation does not communicate with the server.
+
+> (imap-get-expunges imap) -> msg-num-list
+
+  Returns pending expunge notifications from the server for the
+  selected mailbox in terms of message positions (not uids), and
+  clears the pending notifications. The result list is sorted,
+  ascending.
+
+  This operation does not communicate with the server. It merely
+  reports the result of previous communication.
+
+  The server can notify the client of newly deleted messages during
+  most other commands, but not asynchronously between
+  commands. Furthermore, the server cannot report new deletions during
+  `imap-get-messages' or `imap-store' operations.
+
+  Before calling any IMAP operation that works in terms of message
+  numbers, pending expunge notifications must be handled by calling
+  `imap-get-expunges'.
+
+> (imap-pending-expunges? imap) -> boolean
+
+  Returns #f if `imap-get-expunges' would return an empty list, #t
+  otherwise.
+
+> (imap-get-updates imap) -> list of (cons msg-num assoc-list)
+
+  Returns information must like `imap-get-messages', but includes
+  information reported asynchronously by the server (e.g., to notify a
+  client with some other client changes a message attribute).  Instead
+  of reporting specific requested information for specific messages,
+  the result is associates message positions to field-value
+  association lists. The result list is sorted by message position,
+  ascending.
+
+  This operation does not communicate with the server; it merely
+  reports the result of previous communication. It also clears the
+  update information from the connection after reporting it.
+
+  When a server reports information that supercedes old reported
+  information for a message, or if the server reports that a message
+  has been deleted, then old information for the message is
+  dropped. Similarly, if `imap-get-messages' is used to explicitly
+  obtain information, any redudant (or out-of-date) information is
+  dropped.
+
+  A client need not use `imap-get-updates' ever, but accumulated
+  information for the connection consumes space.
+
+> (imap-pending-updates? imap) -> boolean
+
+  Returns #f if `imap-get-updates' would return an empty list, #t
+  otherwise.
+
+- - - - - - Manipulating messages - - - - -
+
+> (imap-get-messages imap msg-num-list field-list)
+  -> list of field-value lists
+
+  Downloads information for a set of messages. The `msg-num-list'
+  argument specifies a set of messages by their message positions (not
+  their uids). The `field-list' argument specifies the type of
+  information to download for each message. The avilable fields are:
+
+    * 'uid - value is an integer
+    * 'header - value is a header (string; see the head package)
+    * 'body - value is a byte string (with CRLF-separated lines)
+    * 'flags - value is a list of imap flags
+
+  The return value is a list of entry items in parallel to
+  `msg-num-list'. Each entry is itself a list containing value items
+  in parallel to `field-list'.
+
+  Pending expunges must be handled before calling this function; see
+  `imap-get-expunges'.
+
+  Example:
+    (imap-get-message imap '(1 3 5) '(uid header))
+    ; => ((107 #"From: larry@stooges.com ...")
+          (110 #"From: moe@stooges.com ...")
+          (112 #"From: curly@stooges.com ..."))
+
+> (imap-flag->symbol imap-flag) -> symbol
+> (symbol->imap-flag symbol) -> imap-flag
+
+  An imap flag is a symbol, but it is generally not a convenient one
+  to use within a Scheme program, because it usually starts with a
+  backslash and flag comparisions are case-insensitive. The
+  `imap-flag->symbol' and `symbol->imap-flag' procedures convert IMAP
+  flags to convenient symbols and vice-versa:
+
+      symbol       imap flag
+      ------       ----------
+     'seen         '|\Seen|            \
+     'answered     '|\Answered|        |
+     'flagged      '|\Flagged|          > message flags
+     'deleted      '|\Deleted|         |
+     'draft        '|\Draft|           |
+     'recent       '|\Recent|          /
+
+     'noinferiors   '|\Noinferiors|    \
+     'noselect      '|\Noselect|       |
+     'marked        '|\Marked|          > mailbox flags
+     'unmarked      '|\Unmarked|       |
+     'hasnochildren '|\HasNoChildren|  |
+     'haschildren   '|\HasChildren|    /
+
+  `imap-flag->symbol' and `symbol->imap-flag' act like the identity
+  function when any other symbol/flag is provided.
+
+> (imap-store imap mode msg-num-list imap-flags) -> void
+
+  Sets flags for a set of messages. The mode argument specifies how
+  flags are set:
+
+       * '+ - add the given flags to each message
+       * '- - remove the given flags from each emssage
+       * '! - set each message's flags to the given set
+
+  The `msg-num-list' argument specifies a set of messages by their
+  message positions (not their uids). The `flags' argument specifies
+  the imap flags to add/remove/install.
+
+  Pending expunges must be handled before calling this function; see
+  `imap-get-expunges'. The server will not report back message-state
+  changes (so they will not show up through `imap-get-updates').
+
+  Example:
+    (imap-store imap '+ '(1 2 3) (list (symbol->imap-flag 'deleted)))
+    ; marks the first three messages to be deleted
+    (imap-expunge imap)
+    ; permanently removes the first three messages (and possibly others)
+    ;  from the currently-selected mailbox
+
+> (imap-expunge imap) -> void
+
+  Purges every message currently marked with the '|\Deleted| flag from
+  the mailbox.
+
+- - - - - - Querying and changing (other) mailboxes - - - - -
+
+> (imap-copy imap msg-num-list dest-mailbox-str/bytes) -> void
+
+  Copies the specified messages from the currently selected mailbox to
+  the specified mailbox.
+
+  Pending expunges must be handled before calling this function; see
+  `imap-get-expunges'.
+
+> (imap-append imap mailbox-string message-str/bytes) -> void
+
+  Adds a new message (containing message-string) to the given mailbox
+
+> (imap-status imap mailbox-str/bytes status-symbol-list)
+  -> list of status values
+
+  Requests information about a mailbox from the server, typically
+  *not* the currently selected mailbox.
+
+  The status-symbol-list specifies the request, and the return value
+  includes one value for each symbol in status-symbol-list. The
+  allowed status symbols are:
+
+    'messages - number of messages
+    'recent - number of recent messages
+    'unseen - number of unseen messages
+    'uidnext - uid for next received message
+    'uidvalidity - id that changes when all uids are changed
+
+  Use `imap-messages' to get the message count for the currently
+  selected mailbox, etc. Use `imap-new?' and `imap-reset-new!' to
+  detect when new messages are available in the currently selected
+  mailbox.
+
+> (imap-mailbox-exists? imap mailbox-str/bytes) -> bool
+
+  Returns #t if the specified mailbox exists, #f otherwise.
+
+> (imap-create-mailbox imap mailbox-str/bytes) -> void
+
+  Creates the specified mailbox. (It must not exist already.)
+
+> (imap-list-child-mailboxes imap mailbox-str/bytes [delimiter-str/bytes])
+  -> list of mailbox-info lists
+
+  Returns information about sub-mailboxes of the given mailbox.  If
+  mailbox-string is #f, information about all top-level mailboxes is
+  returned. The optional `delimiter-string' is determined
+  automatically (via `imap-get-hierarchy-delimiter') if it is not
+  provided.
+
+  The return value is a list of mailbox-information lists. Each
+  mailbox-information list contains two items:
+    * a list of imap flags for the mailbox
+    * the mailbox's name
+
+> (imap-get-hierarchy-delimiter imap) -> bytes
+
+  Returns the server-specific string that is used as a separator in
+  mailbox path names.
+
+> (imap-mailbox-flags imap mailbox-str/bytes)
+  -> list of imap flags
+
+  Returns a list of imap flags for the given mailbox.
+
+==========================================================================
+_mime headers_, _mail headers_, _http headers_
+==========================================================================
+
+To load directly: (require (lib "head.ss" "net"))
+Module files: _head.ss_ - provides the procedures documented below
+              _head-unit.ss_ - provides unit net:head@
+              _head-sig.ss_ - provides signalture net:head^
+
+ABSTRACT -------------------------------------------------------------
+
+Implements utlities for RFC 822 headers and mail addresses.
+
+TYPES ----------------------------------------------------------------
+
+> header
+
+  A string that is an RFC-882-compliant header. A header string
+  contains a series of CRLF-delimitted fields, and ends with two CRLFs
+  (the first one terminates the last field, and the second terminates
+  the header).
+
+PROCEDURES -----------------------------------------------------------
+
+> empty-header
+
+  A string correcponding to the empty header, useful for building up
+  headers with `insert-field' and `append-headers'.
+
+> (validate-header candidate-header-string) -> void
+
+  If the format of `candidate-header-string' matches RFC 822, void is
+  returned, otherwise an exception is raised.
+
+> (extract-field field-string header) -> string or #f
+
+  Returns the header content for the specified field, or #f if the
+  field is not in the header. `field-string' should not end with ":",
+  and it is used case-insensitively. The returned string will not
+  contain the field name, color separator, of CRLF terminator for the
+  field; however, if the field spans multiple lines, the CRLFs
+  separating the lines will be intact.
+
+  Example:
+    (extract-field "TO" (insert-field "to" "me@localhost" empty-header))
+    ; => "me@localhost"
+
+> (extract-all-fields header) -> (list (cons string string))
+
+  Returns an association-list version of the header; the case of the
+  field names is preserved, as well as the order and duplicate uses of
+  a field name.
+
+> (remove-field field-string header) -> header
+
+  Creates a new header by removing the specified field from `header'
+  (or the first instance of the field, if it occurs multiple
+  times). If the field is not in `header', then the return value is
+  `header'.
+
+> (insert-field field-string value-string header) -> header
+
+  Creates a new header by prefixing the given header with the given
+  field-value pair. `value-string' should not contain a terminating
+  CRLF, but a multi-line value (perhaps created with
+  `data-lines->data') may contain seperator CRLFs.
+
+> (replace-field field-string value-string header) -> header
+
+  Replaces or inserts the given field. If value-string is #f, then
+  the field is simply removed.
+
+> (append-headers a-header another-header) -> header
+
+> (standard-message-header from-string to-list-of-strings cc-list-of-strings bcc-list-of-strings subject-string) -> header
+
+  Creates a standard mail header given the sender, various lists of
+  recipients, a subject, and the current date. (The BCC recipients do
+  not acually appear in the header, but they're accepted anyway to
+  complete the abstraction.)
+
+> (data-lines->data list-of-strings) -> string
+
+  Merges multiple lines for a single field value into one string,
+  adding CRLF-TAB separators.
+
+> (extract-addresses string kind) -> list of strings or
+                                     list of list of strings
+
+  Parses `string' as a list of comma-delimited mail addresses, raising
+  an exception if the list is ill-formed. This procedure can be used
+  for single-address strings, in which case the returned list should
+  contain only one address.
+
+  The `kind' argument specifies which portion of an address should be
+  returned:
+
+     * 'name - the free-form name in the address, or the address
+               itself if no name is available:
+        "John Doe <doe@localhost>" => "Jon Doe"
+        "doe@localhost (Johnny Doe)" => "Johnny Doe"
+        "doe@localhost" => "doe@localhost"
+
+     * 'address - just the mailing address, without any free-form
+               names:
+        "Jon Doe <doe@localhost>" => "doe@localhost"
+        "doe@localhost (Johnny Doe)" => "doe@localhost"
+        "doe@localhost" => "doe@localhost"
+
+     * 'full - the full address, essentially as it appears in the
+               input, but normalized:
+        "Jon Doe   < doe@localhost >" => "Jon Doe <doe@localhost>"
+        "  doe@localhost  (Johnny Doe)" => "doe@localhost (Johnny Doe)"
+        "doe@localhost" => "doe@localhost"
+
+     * 'all - a list containing each of the three posibilities:
+              free-form name, address, and full address (in that
+              order)
+
+  Example:
+    (extract-addresses " \"Doe, John\" <doe@localhost>, john" 'address)
+    ; => ("doe@localhost" "john")
+
+> (assemble-address-field list-of-address-strings) -> string
+
+  Creates a header field value from a list of addresses. The addresses
+  are comma-separated, and possibly broken into multiple lines.
+
+==========================================================================
+_DNS_, _domain name service_
+==========================================================================
+
+To load directly: (require (lib "dns.ss" "net"))
+Module files: _dns.ss_ - provides the procedures documented below
+              _dns-unit.ss_ - provides unit net:dns@
+              _dns-sig.ss_ - provides signalture net:dns^
+
+ABSTRACT -------------------------------------------------------------
+
+Implements part of a DNS client, based on RFC 1035. The name cache
+does not properly time out entries, however.
+
+Thanks to Eduardo Cavazos and Jason Crowe for repairs and
+improvements.
+
+PROCEDURES -----------------------------------------------------------
+
+> (dns-get-address nameserver-string address-string) -> address-string
+
+  Consults the specified nameserver (normally a numerical address like
+  "128.42.1.30") to obtain a numerical address for the given internet
+  address.
+
+  The query record sent to the DNS server includes the "recursive"
+  bit, but `dns-get-address' also implements a recursive search itself
+  in case the server does not provide this optional feature.
+
+> (dns-get-name nameserver-string address-string) -> address-string
+
+  Consults the specified nameserver (normally a numerical address like
+  "128.42.1.30") to obtain a name for the given numerical address.
+
+> (dns-get-mail-exchanger nameserver-string address-string) -> address-string
+
+  Consults the specified nameserver to obtain the address for a mail
+  exchanger the given mail host address. For example, the mail
+  exchanger for "ollie.cs.rice.edu" is currently "cs.rice.edu".
+
+> (dns-find-nameserver) -> address-string or #f
+
+  Attempts to find the address of a nameserver on the present system.
+  Under Unix, this procedure parses /etc/resolv.conf to extract the
+  first nameserver address. Under Windows, it runs "nslookup.exe".
+
+==========================================================================
+_MIME support__
+==========================================================================
+
+To load directly: (require (lib "mime.ss" "net"))
+Module files: _mime.ss_ - provides the procedures documented below
+              _mime-unit.ss_ - provides unit net:mime@
+                               imports net:base64^ from "base64-sig.ss"
+                               and net:qp^ from "qp-sig.ss"
+              _mime-sig.ss_ - provides signalture net:mime^
+
+ABSTRACT -------------------------------------------------------------
+
+Author: Francisco Solsona <solsona@acm.org>
+
+MIME stands for Multipurpose Internet Mail Extensions. the mime
+library provides support for MIME as described in: rfc2045 through
+rfc2049.
+
+This library is supposed to be used by PLT Scheme applications, or
+libraries to make the MIME-aware.  For instance, MUAs, (Fast)CGI
+libraries to support multipart/form-data extensions, etc.
+
+EXCEPTIONS -----------------------------------------------------------
+
+   unexpected-termination
+
+   This exception is raised when eof is reached while parsing the
+   headers of a MIME entity.  And it usually means, that the message
+   does not conform to rfc2045, and friends. It has a message
+   parameter, `msg', that gives exact information on the problem:
+   unexpected-termination-msg.
+
+   missing-multipart-boundary-parameter
+
+   A multipart type is signalled, but no `boundary' parameter is
+   given, also an error on the producer end of the message.
+
+   malformed-multipart-entity
+
+   Similar to `unexpected-termination', but it is used only while
+   scanning parts of a multipart message.
+
+   empty-mechanism
+
+   No transport encoding mechanism was provided with the
+   Conent-Transfer-Encoding field.
+
+   empty-type
+
+   No type specified for Content-Type, or incorrectly formated.
+
+   empty-subtype
+
+   No subtype specified for Content-Type, or incorrectly formated.
+
+   empty-disposition-type
+
+   No type specified for the Content-Disposition field, or incorrectly
+   formated.
+
+
+   mime-error
+
+   A catch-all exception.
+
+PROCEDURES -----------------------------------------------------------
+
+> (mime-analyze message)
+
+   Message must conform to the RFC 2045, 2046, 2047, 2048, and 2049.
+
+   This is basically the only function provided by the MIME support
+   library.  It returns a `message' structure, having the following
+   fields: version, entity, and fields.
+
+> (message-version message-struct)
+
+   the value of the MIME-version header.  It has a default 1.0 value
+   when message does not contain a MIME-version header.
+
+> (message-entity message-struct)
+
+   another structure, `entity'.  According to rfc2045, and entity
+   refers to the MIME-defined header fields and contents of either a
+   message or one of the parts in the body of a multipart entity.
+
+   See below, for the fields of an entity-structure.  All the
+   MIME-headers, parts (sub-entities), and/or contents of message are
+   stored into this structure.
+
+> (message-fields message-struct)
+
+   a list of all non-MIME headers in message.  If message is an
+   rfc822, for instance, this list could contain 'From', 'Subject',
+   etc.
+
+struct entity
+-------------
+
+   These kind of structure contains all the headers, parameters, and
+   contents of a given entity, and its parts (sub-entities).  These
+   are the fields of the entity structure:
+
+   type, subtype, charset, encoding, disposition, params, id,
+   description, other, fields, parts, body, close.
+
+> (entity-type entity-struct)
+
+   In rfc822 BNF extension:
+
+   type := discrete-type | composite-type
+
+   discrete-type := "text" / "image" / "audio" / "video" /
+                        "application" / extension-token
+
+   composite-type := "message" / "multipart" / extension-token
+
+   extension-token := ietf-token / x-token
+
+   ietf-token := <An extension token defined by a standards-track
+                  RFC and registered with IANA.>
+
+   x-token := <The two characters "X-" or "x-" followed, with no
+               intervening white space, by any token>
+
+   In English, it returns one of the symbols: text, image, audio,
+   video, application, an ietf-extension, and x-token, or a local
+   extension (not recommended by the way.)
+
+> (entity-subtype entity-struct)
+
+   subtype := extension-token / iana-token
+
+   Also a symbol, it depends on the value of type.  Quoting RFC 1700:
+
+ Type            Subtype         Description                 Reference
+ ----            -------         -----------                 ---------
+ text            plain                                   [RFC1521,NSB]
+                 richtext                                [RFC1521,NSB]
+                 tab-separated-values                   [Paul Lindner]
+
+ multipart       mixed                                   [RFC1521,NSB]
+                 alternative                             [RFC1521,NSB]
+                 digest                                  [RFC1521,NSB]
+                 parallel                                [RFC1521,NSB]
+                 appledouble                [MacMime,Patrik Faltstrom]
+                 header-set                             [Dave Crocker]
+
+ message         rfc822                                  [RFC1521,NSB]
+                 partial                                 [RFC1521,NSB]
+                 external-body                           [RFC1521,NSB]
+                 news                        [RFC 1036, Henry Spencer]
+
+ application     octet-stream                            [RFC1521,NSB]
+                 postscript                              [RFC1521,NSB]
+                 oda                                     [RFC1521,NSB]
+                 atomicmail                           [atomicmail,NSB]
+                 andrew-inset                       [andrew-inset,NSB]
+                 slate                           [slate,terry crowley]
+                 wita              [Wang Info Transfer,Larry Campbell]
+                 dec-dx            [Digital Doc Trans, Larry Campbell]
+                 dca-rft        [IBM Doc Content Arch, Larry Campbell]
+                 activemessage                          [Ehud Shapiro]
+                 rtf                                    [Paul Lindner]
+                 applefile                  [MacMime,Patrik Faltstrom]
+                 mac-binhex40               [MacMime,Patrik Faltstrom]
+                 news-message-id              [RFC1036, Henry Spencer]
+                 news-transmission            [RFC1036, Henry Spencer]
+                 wordperfect5.1                         [Paul Lindner]
+                 pdf                                    [Paul Lindner]
+                 zip                                    [Paul Lindner]
+                 macwriteii                             [Paul Lindner]
+                 msword                                 [Paul Lindner]
+                 remote-printing                         [RFC1486,MTR]
+
+ image           jpeg                                    [RFC1521,NSB]
+                 gif                                     [RFC1521,NSB]
+                 ief             Image Exchange Format       [RFC1314]
+                 tiff            Tag Image File Format           [MTR]
+
+ audio           basic                                   [RFC1521,NSB]
+
+ video           mpeg                                    [RFC1521,NSB]
+                 quicktime                              [Paul Lindner]
+
+
+> (entity-charset entity-struct)
+
+   The value of the `charset' parameter of the Content-Type header.
+   By default, the symbol: us-ascii.
+
+> (entity-encoding entity-struct)
+
+   The value of the Content-Transfer-Encoding header, one of the
+   symbols: 7bit, 8bit, binary, quoted-printable, base64.  If no
+   Content-Transfer-Encoding header is given, message should be 7bit,
+   thus, 7bit is the default value of this field.
+
+> (entity-disposition entity-struct)
+
+   This one is a litter bit complex, so it is yet another structure.
+   These `disposition' structures represent the value of the
+   Content-Disposition header, as defined in rfc2183:
+
+  disposition := "Content-Disposition" ":"
+                  disposition-type
+                  *(";" disposition-parm)
+
+   disposition structs have the following fields: type, filename,
+   creation, modification, read, size, and params.  Only type is
+   required.
+
+> (disposition-type disposition-struct)
+
+   disposition-type := 'inline / 'attachment  / extension-token
+
+> (disposition-filename disposition-struct)
+
+   string representing the `filename' parameter of the
+   Content-Disposition header.
+
+> (disposition-creation disposition-struct)
+
+   string representing the `creation-date' parameter, which must
+   follow this BNF grammar:
+
+ date-time   =  [ day "," ] date time        ; dd mm yy
+                                   ;  hh:mm:ss zzz
+
+ day         =  "Mon"  / "Tue" /  "Wed"  / "Thu"
+            /  "Fri"  / "Sat" /  "Sun"
+
+ date        =  1*2DIGIT month 2DIGIT        ; day month year
+                                   ;  e.g. 20 Jun 82
+
+ month       =  "Jan"  /  "Feb" /  "Mar"  /  "Apr"
+            /  "May"  /  "Jun" /  "Jul"  /  "Aug"
+            /  "Sep"  /  "Oct" /  "Nov"  /  "Dec"
+
+ time        =  hour zone                    ; ANSI and Military
+
+ hour        =  2DIGIT ":" 2DIGIT [":" 2DIGIT]
+                                   ; 00:00:00 - 23:59:59
+
+ zone        =  "UT"  / "GMT"                ; Universal Time
+                                   ; North American : UT
+            /  "EST" / "EDT"                ;  Eastern:  - 5/ - 4
+            /  "CST" / "CDT"                ;  Central:  - 6/ - 5
+            /  "MST" / "MDT"                ;  Mountain: - 7/ - 6
+            /  "PST" / "PDT"                ;  Pacific:  - 8/ - 7
+            /  1ALPHA                       ; Military: Z = UT;
+                                   ;  A:-1; (J not used)
+                                   ;  M:-12; N:+1; Y:+12
+            / ( ("+" / "-") 4DIGIT )        ; Local differential
+
+> (disposition-modification disposition-struct)
+
+   String representing the `modification-date' parameter, it has the
+   same syntax as `disposition-creation'.
+
+> (disposition-read disposition-struct)
+
+   String representing the `read-date' parameter, it has the same
+   syntax as `disposition-creation'.
+
+> (disposition-size disposition-struct)
+
+   Number representing the `size' parameter (the size of the file).
+
+> (disposition-params disposition-struct)
+
+   List of extra parameters (non-standard) following the
+   Content-Disposition header.
+
+> (entity-params entity-struct)
+
+   List of `parameters' given with all the MIME headers above.  Each
+   of these parameters is a pair of the form: (parameter-name . value)
+
+> (entity-id entity-struct)
+
+   The value of the Content-Id header.
+
+> (entity-description entity-struct)
+
+   The value of the Content-description header.
+
+> (entity-other entity-struct)
+
+   MIME extension fields (non-standard) they all start with
+   "Content-".
+
+> (entity-fields entity-struct)
+
+   A list of all non-MIME headers.
+
+> (entity-parts entity-struct)
+
+   A list of `message'-structs see above.  Each entry represents a
+   part of the current MIME entity (only multipart, or message
+   entities can have parts).
+
+> (entity-body entity-struct)
+
+   A procedure that consumes an output port and writes the message
+   body into the port, properly decoded (e.g. if body was
+   quoted-printable encoded, then the body is written already
+   quoted-printable decoded.).  If type is multipart, or message,
+   clearly no bytes are written to port. The procedure only works
+   once (since the encoded body is pulled from a stream).
+
+==========================================================================
+_Base 64 Encoding_, _base64_
+==========================================================================
+
+To load directly: (require (lib "base64.ss" "net"))
+Module files: _base64.ss_ - provides the procedures documented below
+              _base64-unit.ss_ - provides unit net:base64@
+              _base64-sig.ss_ - provides signalture net:base64^
+
+ABSTRACT -------------------------------------------------------------
+
+Implements Base 64 (mime-standard) encoder and decoder.
+
+PROCEDURES -----------------------------------------------------------
+
+> (base64-encode bytes) -> bytes
+
+  Consumes a byte string and returns its Base 64 encoding as a new
+  byte string.  The returned string is broken into 72-byte lines
+  separated by CRLF combinations, and always ends with a CRLF
+  combination unless the input is empty.
+
+> (base64-decode bytes) -> bytes
+
+  Consumes a byte string and returns its Base 64 decoding as a new
+  byte string.
+
+> (base64-encode-stream input-port output-port [newline-bytes]) -> void
+
+  Reads bytes from `input-port' and writes the encoded result to
+  `output-port', breaking the output into 72-character lines separated
+  by `newline-bytes, and ending with `newline-bytes unless the
+  input stream is empty. The default `newline-bytes contains just a
+  newline (not CRLF). The procedure returns when it encounters an
+  end-of-file from `input-port'.
+
+> (base64-decode-stream input-port output-port) -> void
+
+  Reads a Base 64 encoding from `input-port' and writes the decoded
+  result to `output-port'. The procedure returns when it encounters an
+  end-of-file or Base 64 terminator (=) from `input-port'.
+
+==========================================================================
+_Quoted Printable Encoding_, _qp__
+==========================================================================
+
+To load directly: (require (lib "qp.ss" "net"))
+Module files: _qp.ss_ - provides the procedures documented below
+              _qp-unit.ss_ - provides unit net:qp@
+              _qp-sig.ss_ - provides signalture net:qp^
+
+ABSTRACT -------------------------------------------------------------
+
+Author: Francisco Solsona <solsona@acm.org>
+
+Implements Quoted Printable (mime-standard) encoder and decoder. As
+proposed by the rfc2045 section 6.7.
+
+EXCEPTIONS -----------------------------------------------------------
+
+
+  qp-wrong-input
+
+  This exception is raised when input to any of the qp-procedures (see
+  below) is neither a string, nor an input port.
+
+  qp-wrong-line-size
+
+  If the length of a supposedly quoted-printable line is longer than
+  76 this exception is raised.
+
+  qp-error
+
+  is a catch all exception.
+
+PROCEDURES -----------------------------------------------------------
+
+
+> (qp-encode string) -> string
+
+  Consumes a string and returns its quoted printable representation as
+  a new string. The encoded string uses "\r\n" where necessary to
+  create shorter lines.
+
+> (qp-decode string) -> string
+
+  Consumes a string and returns its un-quoted printable representation
+  as a new string. Non-soft linebreaks are preserved in whatever form
+  they exist (CR, LR, or CRLF) in the input string.
+
+> (qp-encode-stream input output [newline-string]) -> void
+
+  Reads characters from `input' and writes the quoted printable
+  encoded result to `output'.
+
+  The `newline-string' argument is used for soft line-breaks (after
+  "="). The default `newline-string' is #"\n", though it should
+  probably be #"\r\n" instead.
+
+  Other linebreaks are preserved in whatever form they exist (CR, LR,
+  or CRLF) in the input stream.
+
+> (qp-decode-stream input output) -> void
+
+   Reads characters from `input' and writes de-quoted-printable result
+   to `output'.  Non-soft linebreaks are preserved in whatever form
+   they exist (CR, LR, or CRLF) in the input stream.
+
+
+==========================================================================
+_FTP client_
+==========================================================================
+
+To load directly: (require (lib "ftp.ss" "net"))
+Module files: _ftp.ss_ - provides the procedures documented below
+              _ftp-unit.ss_ - provides unit net:ftp@
+              _ftp-sig.ss_ - provides signalture net:ftp^
+
+ABSTRACT -------------------------------------------------------------
+
+Author: Micah Flatt <mflatt@elephant-ear.com>
+
+Implements FTP client actions.
+
+PROCEDURES -----------------------------------------------------------
+
+> (ftp-establish-connection server-host-string server-port-k user-string passwd-string)
+
+  Establishes an FTP connection with the given server using the
+  supplied username and password. The result is an opaque `ftp-conn'
+  structure reprsenting the connection.
+
+  The username and password strings are encoded to bytes using the
+  current locale's encoding.
+
+> (ftp-close-connection ftp-conn)
+
+  Closes an FTP connection.
+
+> (ftp-cd ftp-conn new-dir-string)
+
+  Changes the current directory on the FTP server to `new-dir-string'.
+  The `new-dir-string' is not interpreted at all, but simply passed on
+  to the server (encoded using the current locale's encoding). It must
+  not contain a newline.
+
+> (ftp-directory-list ftp-conn)
+
+  Returns a list of files and directories in the current directory of
+  the server, assuming that the server provides directory information
+  in the quasi-standard Unix format.
+
+  Each file or directory is represented by a list of three
+  strings. The first string is either "-", "d", or "l", depending on
+  whether the items is a file, directory, or link, respectively.  The
+  second item is the file's date; to convert this value to seconds
+  consistent with `file-seconds', pass the date string to
+  `ftp-make-file-seconds', below.  The third string is the name of the
+  file or directory.
+
+  All strings are decoded frombytes using the current locale's
+  encoding.
+
+> (ftp-make-file-seconds ftp-date-string)
+
+  Takes a date string produced by `ftp-directory-list' and converts it
+  to seconds.
+
+> (ftp-download-file ftp-conn local-directory-path filename-string)
+
+  Downloads `filename-string' from the server's current directory and
+  puts it in `local-directory-path' using the same name. If the file
+  already exists in the local directory, it is replaced, but only
+  after the transfer suceeds (i.e., the file is first downloaded to a
+  temporary file, then moved into place on success).
+
+==========================================================================
+_TCP redirect_
+==========================================================================
+
+The "tcp-redirect.ss" library provides an function to generate a unit
+with the signature net:tcp^ that redirects certain port numbers to
+intra-process listeners that do not actually use TCP. The net:tcp^
+signature is imported, for example, by the url@ unit of "url-unit.ss".
+
+Module file: _tcp-redirect.ss_ - provides the `tcp-redirect-function
+             _tcp-sig.ss_ - defines _net:tcp^_, which contains the
+                            following:
+                                 tcp-abandon-port
+                                 tcp-accept
+                                 tcp-accept-ready?
+                                 tcp-addresses
+                                 tcp-close
+                                 tcp-connect
+                                 tcp-connect/enable-break
+                                 tcp-listen
+                                 tcp-listener?
+             _tcp-unit.ss_ - defines _tcp@_ which implements
+                             net:tcp^ using the MzScheme functions of
+                             the same name
+             ssl-tcp-unit.ss - see below
+
+PROCEDURES -----------------------------------------------------------
+
+> (tcp-redirect port-number-list)
+
+  Returns a unit that implements net:tcp^ (from "tcp-sig.ss"). For
+  port numbers not listed in `port-number-list', the unit's
+  implementations are the MzScheme implementations.
+
+  For the port numbers listed in `port-number-list', and for
+  connections to "127.0.0.1", the unit's implementation does not use
+  TCP connections, but instead uses internal buffered channels. Such
+  channels behave exactly as TCP listeners and ports.
+
+==========================================================================
+_SSL redirect__
+==========================================================================
+
+The _ssl-tcp-unit.ss_ library provides `make-ssl-tcp@', which returns
+a unit that implements net:tcp^ from "tcp-sig.ss"
+
+PROCEDURES -----------------------------------------------------------
+
+> (make-ssl-tcp@
+   server-cert-file server-key-file server-root-cert-files
+   server-suggest-auth-file
+   client-cert-file client-key-file client-root-cert-files)
+
+  Returns a unit that implements net:tcp^ using the SSL functions from
+  (lib "mzssl.ss" "openssl"). The arguments to `make-ssl-tcp@' control
+  the certificates and keys uses by server and client connections:
+
+    `server-cert-file' - a PEM file for a server's certyificate; #f means
+     no certificate (which is unlikely to work with any SSL client)
+    `server-key-file' - a private key PEM to go with `server-cert-file';
+     #f means no key (which is likely renders a certificate useless)
+    `server-root-cert-files' - a list of PEM files for trusted root
+     ceritifcates; #f disables verification of peer client certificates
+
+    `server-suggest-auth-file' - PEM file for root certificates to be
+     suggested to peer clients that must supply certificates
+
+    `client-cert-file' - a PEM file for a client's certificate; #f means
+     no certificate (usually fine)
+    `client-key-file' - a private key PEM to go with `client-cert-file';
+     #f means no key (which is likely renders a certificate useless)
+    `client-root-cert-files' - a list of PEM files for trusted root
+     ceritifcates; #f disables verification of peer server certificates
+
+==========================================================================
+_cookies_, HTTP _State Management_
+==========================================================================
+
+To load directly: (require (lib "cookie.ss" "net"))
+Module files: _cookie.ss_ - provides the procedures documented below
+              _cookie-unit.ss_ - provides unit net:cookie@
+              _cookie-sig.ss_ - provides signalture net:cookie^
+
+
+ABSTRACT -------------------------------------------------------------
+
+The cookie package helps programmers use cookies as specified in RFC
+2109 HTTP State Management Mechanism, aka HTTP cookies:
+http://www.w3.org/Protocols/rfc2109/rfc2109
+
+EXCEPTIONS -----------------------------------------------------------
+
+> cookie-error
+  struct (cookie-error exn) ()
+
+  All errors are signalled by raising a cookie-error
+
+TYPES ----------------------------------------------------------------
+
+> cookie
+
+  The opaque structure that represents a cookie
+
+PROCEDURES -----------------------------------------------------------
+
+> (set-cookie name value)
+  : String String -> cookie
+
+  Creates a new cookie, with default values for required fields:
+
+> (cookie:add-comment cookie comment)
+  : cookie String -> cookie
+
+> (cookie:add-domain cookie domain)
+  : cookie String -> cookie
+
+> (cookie:add-max-age cookie seconds)
+  : cookie Nat -> cookie
+
+> (cookie:add-path cookie path)
+  : cookie String -> cookie
+
+> (cookie:secure cookie secure?)
+  : cookie Boolean -> cookie
+
+> (cookie:version cookie version)
+  : cookie Nat -> cookie
+
+  These procedures all modify the fields of an existing cookie.  The
+  modification is destructive, and the modified cookie is returned.
+
+  `domain' must match a prefix of the request-URI.
+
+  `seconds' should be a non-negative natural number representing the
+  number of seconds you want the client to retain the cookie.
+
+  `version' is a required field; the library defaults to the only
+  known incarnation of HTTP cookies: 1.
+
+> (print-cookie cookie)
+  : cookie-structure -> String
+
+  Printing a cookie obtains the string that represents the cookie you
+  formed with the procedures above.
+
+  Empty fields will not appear in the output except when there is a
+  required default.  Currently only the Version is always added.
+
+> (get-cookie name cookies)
+  : String String -> (listof String)
+
+  Returns a list with all the values (strings) associated with name.
+
+> (get-cookie/single name cookies)
+  : String String -> (U String #f)
+
+  Returns the `first' value string associated to name, or #f if no
+  association is found.
+
+  The method used to obtain the `Cookie' header depends on the web
+  server.  It may be an environment variable (CGI), or you may have to
+  read it from the `input port' (FastCGI), or maybe it comes in an
+  `initial-request' structure, etc.  The above two procedures can be
+  used to extract fields from a `Cookie' header.
+
+
+EXAMPLES -------------------------------------------------------------
+
+> Creating a cookie
+
+(let ((c (cookie:add-max-age
+          (cookie:add-path
+           (set-cookie "foo" "bar")
+           "/servlets")
+          3600)))
+  (print-cookie c))
+=>
+"foo=bar; Max-Age=3600; Path=/servlets; Version=1"
+
+To use this output in a "regular" CGI, instead of the last line you
+would use:
+
+  (display (format "Set-Cookie: ~a" (print-cookie c)))
+
+and to use with the PLT Web Server, you would use:
+
+  (make-response/full code message (current-seconds) mime
+                      `((Set-Cookie . ,(print-cookie c)))
+                      body)
+
+> Parsing a cookie
+
+Imagine your Cookie header looks like this:
+
+(cookies . "test2=2; test3=3; xfcTheme=theme6; xfcTheme=theme2")
+
+Then, to get the values of the xfcTheme cookie, you would use:
+
+  (get-cookie "xfcTheme" cookies)
+=> ("theme6" "theme2")
+  (get-cookie/single "xfcTheme" cookies)
+=> "theme6"
+
+If you try to get a cookie that simply is not there, you will get:
+
+ (get-cookie/single "foo" cookies)
+=> #f
+ (get-cookie "foo" cookies)
+=> ()
+
+Note that not having a cookie is normally not an error.  Most clients
+won't have a cookie set then first arrive at your site.
+
+==========================================================================
+_URL encoding_, _URL decoding_, _application/x-www-form-urlencoded_
+==========================================================================
+
+To load directly: (require (lib "uri-codec.ss" "net"))
+Module files: _uri-codec.ss_ - provides the procedures documented below
+              _uri-codec-unit.ss_ - provides unit net:uri-codec@
+              _uri-codec-sig.ss_ - provides signalture net:uri-codec^
+
+
+ABSTRACT -------------------------------------------------------------
+
+The module provides functions to encode and decode strings using
+the URI encoding rules given in RFC 2396, and to encode and decode
+name/value pairs using the application/x-www-form-urlencoded
+mimetype given the in HTML 4.0 specification.  There are minor
+differences between the two encodings.
+
+The URI encoding uses allows a few characters to be represented `as
+is': a-Z, A-Z, 0-9, -, _, ., !, ~, *, ', ( and ).  The remaining
+characters are encoded as %xx, where xx is the hex representation
+of the integer value of the character (where the mapping
+character<->integer is determined by US-ASCII if the integer is
+<128).
+
+The encoding, inline with RFC 2396's recommendation, represents a
+character as is, if possible.  The decoding allows any characters
+to be represented by their hex values, and allows characters to be
+incorrectly represented `as is'.
+
+The rules for the application/x-www-form-urlencoded mimetype given
+in the HTML 4.0 spec are:
+
+  1. Control names and values are escaped. Space characters are
+  replaced by `+', and then reserved characters are escaped as
+  described in [RFC1738], section 2.2: Non-alphanumeric characters
+  are replaced by `%HH', a percent sign and two hexadecimal digits
+  representing the ASCII code of the character. Line breaks are
+  represented as "CR LF" pairs (i.e., `%0D%0A').
+
+  2. The control names/values are listed in the order they appear in
+  the document. The name is separated from the value by `=' and
+  name/value pairs are separated from each other by either `;' or `&'.
+  When encoding, `;' is used as the separator by default. When
+  decoding, both `;' and `&' are parsed as separators by default.
+
+NB: RFC 2396 supersedes RFC 1738.
+
+This differs slightly from the straight encoding in RFC 2396 in
+that `+' is allowed, and represents a space.  We follow this
+convention, encoding a space as `+' and decoding `+' as a space.
+There appear to be some brain-dead decoders on the web, so we also
+encode `!', `~', `'', `(' and ')' using their hex representation.
+This is the same choice as made by the Java URLEncoder.
+
+TYPES ----------------------------------------------------------------
+
+> alist
+
+  (list-of (cons symbol string))  Represents decoded name/value pairs
+
+PROCEDURES -----------------------------------------------------------
+
+> (uri-encode string)
+  : String -> String
+
+  Encode a string using the URI encoding rules
+
+> (uri-decode string)
+  : String -> String
+
+  Decode a string encoded using the URI encoding rules
+
+> (form-urlencoded-encode string)
+  : String -> String
+
+  Encode a string using the application/x-www-form-urlencoded encoding
+  rules. (This string contains no non-ASCII characters, of course.)
+
+> (form-urlencoded-decode string)
+  : String -> String
+
+  Decode a string encoded using the application/x-www-form-urlencoded
+  encoding rules.
+
+> (alist->form-urlencoded alist)
+  : alist -> String
+
+  Encode an alist of key/value pairs using the
+  application/x-www-form-urlencoded encoding rules.
+
+  The `separator-mode-sym' argument must be either 'amp or 'semi to
+  select the separator. The default is 'semi.
+ 
+
+> (form-urlencoded->alist string [separator-mode-sym])
+  : String -> alist
+
+  Decode a string encoded using the application/x-www-form-urlencoded
+  encoding rules into an alist of key/value pairs. All keys are
+  downcased for conversion to symbols.
+
+  The `separator-mode-sym' argument must be either 'amp, 'semi, or
+  'both to select the separator. The default is 'both.
+
+> (current-alist-separator-mode)
+> (current-alist-separator-mode mode-sym)
+
+  A parameter that determines the separator used/recognized between
+  alist pairs in `form-urlencoded->alist', `alist->form-urlencoded',
+  `url->string', and `string->url'. The possible mode symbols are
+  'amp, 'semi, and 'amp-or-semi.
+
+  The default value is 'amp-or-semi, which means that both "&" and ";"
+  are treated as separators when parsing, and ";" is used as a
+  separator when encoding. The other modes use/recognize only of the
+  separators.
+
+  Exmaples for '((name . "shriram") (host "nw")):
+
+    Mode                     Parse                    Generate
+   ------             --------------------      --------------------
+
+   'amp               name=shriram&host=nw      name=shriram&host=nw
+
+   'semi              name=shriram;host=nw      name=shriram;host=nw
+
+   'amp-or-semi       name=shriram&host=nw      name=shriram;host=nw
+                               or
+                      name=shriram;host=nw
diff --git a/collects/net/ftp-sig.ss b/collects/net/ftp-sig.ss
new file mode 100644
index 0000000000..3de7fdc083
--- /dev/null
+++ b/collects/net/ftp-sig.ss
@@ -0,0 +1,13 @@
+(module ftp-sig mzscheme
+  (require (lib "unitsig.ss"))
+
+  (provide net:ftp^)
+  
+  (define-signature net:ftp^
+    (ftp-cd 
+     ftp-establish-connection ftp-establish-connection*
+     ftp-close-connection 
+     ftp-directory-list
+     ftp-download-file
+     ftp-make-file-seconds)))
+
diff --git a/collects/net/ftp-unit.ss b/collects/net/ftp-unit.ss
new file mode 100644
index 0000000000..4e3723bd14
--- /dev/null
+++ b/collects/net/ftp-unit.ss
@@ -0,0 +1,219 @@
+(module ftp-unit mzscheme
+  ;; Version 0.2
+  ;;   Version 0.1a 
+  ;;   Micah Flatt 
+  ;;   06-06-2002
+  (require (lib "date.ss")
+	   (lib "file.ss")
+	   (lib "port.ss")
+	   "ftp-sig.ss"
+           (lib "unitsig.ss"))
+
+  (provide net:ftp@)
+  (define net:ftp@
+    (unit/sig net:ftp^
+      (import)
+
+      ;; opqaue record to represent an FTP connection:
+      (define-struct tcp-connection (in out))
+      
+      (define tzoffset (date-time-zone-offset (seconds->date (current-seconds))))
+      
+      (define re:multi-response-start #rx#"^[0-9][0-9][0-9]-")
+      (define re:response-end #rx#"^[0-9][0-9][0-9] ")
+
+      (define (check-expected-result line expected)
+	(when expected
+	  (unless (ormap (lambda (expected)
+			   (bytes=? expected (subbytes line 0 3)))
+			 (if (bytes? expected)
+			     (list expected)
+			     expected))
+	    (error 'ftp "exected result code ~a, got ~a" expected line))))
+      
+      ;; ftp-check-response : input-port output-port bytes-or-byteslist-or-#f (bytes any -> any) any -> any
+      ;;
+      ;;  Checks a standard-format response, checking for the given
+      ;;  expected 3-digit result code if expected is not #f. 
+      ;; 
+      ;;  While checking, the function sends reponse lines to
+      ;;  diagnostic-accum. This function -accum functions can return a
+      ;;  value that accumulates over multiple calls to the function, and
+      ;;  accum-start is used as the initial value. Use `void' and
+      ;;  `(void)' to ignore the response info.
+      ;;
+      ;; If an unexpected result is found, an exception is raised, and the
+      ;; stream is left in an undefined state.
+      (define (ftp-check-response tcpin tcpout expected diagnostic-accum accum-start)
+	(flush-output tcpout)
+	(let ([line (read-bytes-line tcpin 'any)])
+	  (cond
+	   [(eof-object? line)
+	    (error 'ftp "unexpected EOF")]
+	   [(regexp-match re:multi-response-start line)
+	    (check-expected-result line expected)
+	    (let ([re:done (regexp (format "^~a " (subbytes line 0 3)))])
+	      (let loop ([accum (diagnostic-accum line accum-start)])
+		(let ([line (read-bytes-line tcpin 'any)])
+		  (cond
+		   [(eof-object? line)
+		    (error 'ftp "unexpected EOF")]
+		   [(regexp-match re:done line)
+		    (diagnostic-accum line accum)]
+		   [else
+		    (loop (diagnostic-accum line accum))]))))]
+	   [(regexp-match re:response-end line)
+	    (check-expected-result line expected)
+	    (diagnostic-accum line accum-start)]
+	   [else
+	    (error 'ftp "unexpected result: ~e" line)])))
+
+      (define (get-month month-bytes)
+	(cond
+	 [(equal? #"Jan" month-bytes) 1]
+	 [(equal? #"Feb" month-bytes) 2]
+	 [(equal? #"Mar" month-bytes) 3]
+	 [(equal? #"Apr" month-bytes) 4]
+	 [(equal? #"May" month-bytes) 5]
+	 [(equal? #"Jun" month-bytes) 6]
+	 [(equal? #"Jul" month-bytes) 7]
+	 [(equal? #"Aug" month-bytes) 8]
+	 [(equal? #"Sep" month-bytes) 9]
+	 [(equal? #"Oct" month-bytes) 10]
+	 [(equal? #"Nov" month-bytes) 11]
+	 [(equal? #"Dec" month-bytes) 12]))
+
+      (define (bytes->number bytes)
+	(string->number (bytes->string/latin-1 bytes)))
+      
+      (define re:date #rx#"(...) *(.*) (..):(..)|(...) *([0-9]*) +(....)")
+
+      (define (ftp-make-file-seconds ftp-date-str)
+	(let ([date-list (regexp-match re:date (string->bytes/locale ftp-date-str))])
+	  (if (not (list-ref date-list 4))
+	      (find-seconds 0 
+			    0
+			    2 
+			    (bytes->number (list-ref date-list 6))
+			    (get-month (list-ref date-list 5))
+			    (bytes->number (list-ref date-list 7)))
+	      (+ (find-seconds 0 
+			       (bytes->number (list-ref date-list 4))
+			       (bytes->number (list-ref date-list 3))
+			       (bytes->number (list-ref date-list 2))
+			       (get-month (list-ref date-list 1)) 
+			       2002) 
+		 tzoffset))))
+      
+      (define re:passive #rx#"\\((.*),(.*),(.*),(.*),(.*),(.*)\\)")
+
+      (define (establish-data-connection tcp-ports)
+	(fprintf (tcp-connection-out tcp-ports) "PASV~n")
+	(let ([response (ftp-check-response (tcp-connection-in tcp-ports)
+					    (tcp-connection-out tcp-ports)
+					    #"227"
+					    (lambda (s ignore) s) ;; should be the only response
+					    (void))])
+	  (let* ([reg-list (regexp-match re:passive response)]
+		 [pn1 (and reg-list
+			   (bytes->number (list-ref reg-list 5)))]
+		 [pn2 (bytes->number (list-ref reg-list 6))])
+	    (unless (and reg-list pn1 pn2)
+	      (error 'ftp "can't understand PASV response: ~e" response))
+	    (let-values ([(tcp-data tcp-data-out) (tcp-connect (format "~a.~a.~a.~a"
+								       (list-ref reg-list 1)
+								       (list-ref reg-list 2)
+								       (list-ref reg-list 3)
+								       (list-ref reg-list 4)) 
+							       (+ (* 256 pn1) pn2))])
+	      (fprintf (tcp-connection-out tcp-ports) "TYPE I~n")
+	      (ftp-check-response (tcp-connection-in tcp-ports) 
+				  (tcp-connection-out tcp-ports)
+				  #"200" void (void))
+	      (close-output-port tcp-data-out)
+	      tcp-data))))
+
+      ;; Used where version 0.1a printed responses:
+      (define (print-msg s ignore)
+	;; (printf "~a~n" s)
+	(void))
+
+      (define (ftp-establish-connection* in out username password)
+	(ftp-check-response in out #"220" print-msg (void))
+	(display (bytes-append #"USER " (string->bytes/locale username) #"\n") out)
+	(let ([no-password? (ftp-check-response in out (list #"331" #"230") 
+			      (lambda (line 230?)
+				(or 230? (regexp-match #rx#"^230" line)))
+			      #f)])
+	  (unless no-password?
+	    (display (bytes-append #"PASS " (string->bytes/locale password) #"\n") out)
+	    (ftp-check-response in out #"230" void (void))))
+	(make-tcp-connection in out))
+      
+      (define (ftp-establish-connection server-address server-port username password)
+	(let-values ([(tcpin tcpout) (tcp-connect server-address server-port)])
+	  (ftp-establish-connection* tcpin tcpout username password)))
+
+      (define (ftp-close-connection tcp-ports)
+	(fprintf (tcp-connection-out tcp-ports) "QUIT~n")
+	(ftp-check-response (tcp-connection-in tcp-ports) (tcp-connection-out tcp-ports) #"221" void (void))
+	(close-input-port (tcp-connection-in tcp-ports))
+	(close-output-port (tcp-connection-out tcp-ports)))
+
+      (define (filter-tcp-data tcp-data-port regular-exp)
+	(let loop ()
+	  (let ([theline (read-bytes-line tcp-data-port 'any)])
+	    (cond
+	     [(or (eof-object? theline)
+		  (< (bytes-length theline) 3)) 
+	      null]
+	     [(regexp-match regular-exp theline)
+	      => (lambda (m)
+		   (cons (cdr m) (loop)))]
+	     [else 
+	      ;; ignore unrecognized lines?
+	      (loop)]))))
+
+      (define (ftp-cd ftp-ports new-dir)
+	(display (bytes-append #"CWD " (string->bytes/locale new-dir) #"\n")
+		 (tcp-connection-out ftp-ports))
+	(ftp-check-response (tcp-connection-in ftp-ports) (tcp-connection-out ftp-ports) 
+			    #"250" void (void)))
+
+      (define re:dir-line #rx#"^(.)......... .* ([A-Z].* .* [0-9][0-9]:?[0-9][0-9]) (.*)$")
+
+      (define (ftp-directory-list tcp-ports)
+	(let ([tcp-data (establish-data-connection tcp-ports)])
+	  (fprintf (tcp-connection-out tcp-ports) "LIST~n")
+	  (ftp-check-response (tcp-connection-in tcp-ports) (tcp-connection-out tcp-ports) 
+			      #"150" void (void))
+	  (let ([dir-list (filter-tcp-data tcp-data re:dir-line)])
+	    (close-input-port tcp-data)
+	    (ftp-check-response (tcp-connection-in tcp-ports) (tcp-connection-out tcp-ports)
+				#"226" print-msg (void))
+	    (map (lambda (l) (map bytes->string/locale l)) dir-list))))
+
+      (define (ftp-download-file tcp-ports folder filename)
+	;; Save the file under the name tmp.file,
+	;; rename it once download is complete
+	;; this assures we don't over write any existing file without having a good file down
+	(let* ([tmpfile (make-temporary-file (string-append
+					      (regexp-replace #rx"~"
+							      (path->string (build-path folder "ftptmp"))
+							      "~~")
+					      "~a"))]
+	       [new-file (open-output-file tmpfile 'replace)] 
+	       [tcpstring (bytes-append #"RETR " (string->bytes/locale filename) #"\n")] 
+	       [tcp-data (establish-data-connection tcp-ports)])
+	  (display tcpstring (tcp-connection-out tcp-ports))
+	  (ftp-check-response (tcp-connection-in tcp-ports) (tcp-connection-out tcp-ports) 
+			      #"150" print-msg (void))
+	  (copy-port tcp-data new-file)
+	  (close-output-port new-file)
+	  (close-input-port tcp-data)
+	  (ftp-check-response (tcp-connection-in tcp-ports) (tcp-connection-out tcp-ports) 
+			      #"226" print-msg (void))
+	  (rename-file-or-directory tmpfile (build-path folder filename) #t)))
+
+      ;; (printf "FTP Client Installed...~n")
+      )))
diff --git a/collects/net/ftp.ss b/collects/net/ftp.ss
new file mode 100644
index 0000000000..4fbe7ff0a1
--- /dev/null
+++ b/collects/net/ftp.ss
@@ -0,0 +1,11 @@
+
+(module ftp mzscheme
+  (require (lib "unitsig.ss"))
+
+  (require "ftp-sig.ss")
+  (require "ftp-unit.ss")
+
+  (define-values/invoke-unit/sig net:ftp^
+    net:ftp@)
+
+  (provide-signature-elements net:ftp^))
diff --git a/collects/net/head-sig.ss b/collects/net/head-sig.ss
new file mode 100644
index 0000000000..d32cae1beb
--- /dev/null
+++ b/collects/net/head-sig.ss
@@ -0,0 +1,19 @@
+
+(module head-sig mzscheme
+  (require (lib "unitsig.ss"))
+
+  (provide net:head^)
+  (define-signature net:head^
+    (empty-header
+     validate-header
+     extract-field
+     remove-field
+     insert-field
+     replace-field
+     extract-all-fields
+     append-headers
+     standard-message-header
+     data-lines->data
+     extract-addresses
+     assemble-address-field)))
+
diff --git a/collects/net/head-unit.ss b/collects/net/head-unit.ss
new file mode 100644
index 0000000000..48654bd1df
--- /dev/null
+++ b/collects/net/head-unit.ss
@@ -0,0 +1,285 @@
+
+(module head-unit mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "date.ss")
+	   (lib "string.ss"))
+
+  (require "head-sig.ss")
+
+  (provide net:head@)
+  (define net:head@
+    (unit/sig net:head^
+      (import)
+
+      (define empty-header (string #\return #\newline))
+
+      (define re:field-start (regexp "^[^ \t\n\r\v:\001-\032\"]*:"))
+      (define re:continue (regexp "^[ \t\v]"))
+      
+      (define (validate-header s)
+	(let ([m (regexp-match #rx"[^\000-\377]" s)])
+	  (when m
+	    (error 'validate-header "non-Latin-1 character in string: ~a" (car m))))
+	(let ([len (string-length s)])
+	  (let loop ([offset 0])
+	    (cond
+	     [(and (= (+ offset 2) len)
+		   (string=? empty-header (substring s offset len)))
+	      (void)] ; validated
+	     [(= offset len) (error 'validate-header "missing ending CRLF")]
+	     [(or (regexp-match re:field-start s offset)
+		  (regexp-match re:continue s offset))
+	      (let ([m (regexp-match-positions #rx"\r\n" s offset)])
+		(if m
+		    (loop (cdar m))
+		    (error 'validate-header "missing ending CRLF")))]
+	     [else (error 'validate-header "ill-formed header at ~s" 
+			  (substring s offset (string-length s)))]))))
+      
+      (define (make-field-start-regexp field)
+	(format "(^|[\r][\n])(~a: *)" (regexp-quote field #f)))
+
+      (define (extract-field field header)
+	(let ([m (regexp-match-positions 
+		  (make-field-start-regexp field)
+		  header)])
+	  (and m
+	       (let ([s (substring header 
+				   (cdaddr m)
+				   (string-length header))])
+		 (let ([m (regexp-match-positions #rx"[\r][\n][^: \r\n\"]*:" s)])
+		   (if m
+		       (substring s 0 (caar m))
+		       ;; Rest of header is this field, but strip trailing CRLFCRLF:
+		       (regexp-replace #rx"\r\n\r\n$"
+				       s
+				       "")))))))
+
+      (define (replace-field field data header)
+	(let ([m (regexp-match-positions 
+		  (make-field-start-regexp field)
+		  header)])
+	  (if m
+	      (let ([pre (substring header
+				    0
+				    (caaddr m))]
+		    [s (substring header 
+				  (cdaddr m)
+				  (string-length header))])
+		(let ([m (regexp-match-positions #rx"[\r][\n][^: \r\n\"]*:" s)])
+		  (if m
+		      (string-append pre 
+				     (let ([rest 
+					    (substring s (+ 2 (caar m)) 
+						       (string-length s))])
+				       (if data
+					   (insert-field field data rest)
+					   rest)))
+		      (if data
+			  (insert-field field data pre)
+			  pre))))
+	      (if data
+		  (insert-field field data header)
+		  header))))
+
+      (define (remove-field field header)
+	(replace-field field #f header))
+	
+
+      (define (insert-field field data header)
+	(let ([field (format "~a: ~a\r\n"
+			     field
+			     data)])
+	  (string-append field header)))
+
+      (define (append-headers a b)
+	(let ([alen (string-length a)])
+	  (if (> alen 1)
+	      (string-append (substring a 0 (- alen 2)) b)
+	      (error 'append-headers "first argument is not a header: ~a" a))))
+      
+      (define (extract-all-fields header)
+	(let ([re #rx"(^|[\r][\n])(([^\r\n:\"]*): *)"])
+	  (let loop ([start 0])
+	    (let ([m (regexp-match-positions re header start)])
+	      (if m
+		  (let ([start (cdaddr m)]
+			[field-name (substring header (caaddr (cdr m)) (cdaddr (cdr m)))])
+		    (let ([m2 (regexp-match-positions 
+			       #rx"\r\n[^: \r\n\"]*:"
+			       header
+			       start)])
+		      (if m2
+			  (cons (cons field-name
+				      (substring header start (caar m2)))
+				(loop (caar m2)))
+			  ;; Rest of header is this field, but strip trailing CRLFCRLF:
+			  (list
+			   (cons field-name
+				 (regexp-replace (format "~a~a~a~a$" #\return #\linefeed #\return #\linefeed)
+						 (substring header start (string-length header))
+						 ""))))))
+		  ;; malformed header:
+		  null)))))
+      
+      (define (standard-message-header from tos ccs bccs subject)
+	(let ([h (insert-field
+		  "Subject" subject
+		  (insert-field 
+		   "Date" (parameterize ([date-display-format 'rfc2822])
+			    (date->string (seconds->date (current-seconds)) #t))
+		   empty-header))])
+	  ;; NOTE: bccs don't go into the header; that's why
+	  ;; they're "blind"
+	  (let ([h (if (null? ccs)
+		       h
+		       (insert-field 
+			"CC" (assemble-address-field ccs)
+			h))])
+	    (let ([h (if (null? tos)
+			 h
+			 (insert-field 
+			  "To" (assemble-address-field tos)
+			  h))])
+	      (insert-field 
+	       "From" from
+	       h)))))
+
+      (define (splice l sep)
+	(if (null? l)
+	    ""
+	    (format "~a~a"
+		    (car l)
+		    (apply
+		     string-append
+		     (map
+		      (lambda (n) (format "~a~a" sep n))
+		      (cdr l))))))
+
+      (define (data-lines->data datas)
+	(splice datas "\r\n\t"))
+
+      ;; Extracting Addresses ;;
+
+      (define blank "[ \t\n\r\v]")
+      (define nonblank "[^ \t\n\r\v]")
+      (define re:all-blank (regexp (format "^~a*$" blank)))
+      (define re:quoted (regexp "\"[^\"]*\""))
+      (define re:comma (regexp ","))
+      (define re:comma-separated (regexp "([^,]*),(.*)"))
+
+      (define (extract-addresses s form)
+	(unless (memq form '(name address full all))
+	  (raise-type-error 'extract-addresses 
+			    "form: 'name, 'address, 'full, or 'all"
+			    form))
+	(if (or (not s) (regexp-match re:all-blank s))
+	    null
+	    (let loop ([prefix ""][s s])
+	      ;; Which comes first - a quote or a comma?
+	      (let ([mq (regexp-match-positions re:quoted s)]
+		    [mc (regexp-match-positions re:comma s)])
+		(if (and mq mc (< (caar mq) (caar mc) (cdar mq)))
+		    ;; Quote contains a comma
+		    (loop (string-append 
+			   prefix 
+			   (substring s 0 (cdar mq)))
+			  (substring s (cdar mq) (string-length s)))
+		    ;; Normal comma parsing:
+		    (let ([m (regexp-match re:comma-separated s)])
+		      (if m
+			  (let ([n (extract-one-name (string-append prefix (cadr m)) form)]
+				[rest (extract-addresses (caddr m) form)])
+			    (cons n rest))
+			  (let ([n (extract-one-name (string-append prefix s) form)])
+			    (list n)))))))))
+      
+      (define (select-result form name addr full)
+	(case form
+	  [(name) name]
+	  [(address) addr]
+	  [(full) full]
+	  [(all) (list name addr full)]))
+
+      (define (one-result form s)
+	(select-result form s s s))
+
+      (define re:quoted-name (regexp (format "^~a*(\"[^\"]*\")(.*)" blank)))
+      (define re:parened-name (regexp (format "(.*)[(]([^)]*)[)]~a*$" blank)))
+      (define re:simple-name (regexp (format "^~a*(~a.*)(<.*>)~a*$" blank nonblank blank)))
+      (define re:normal-name (regexp (format "~a*<([^>]*)>~a*" blank blank)))
+      (define re:double-less (regexp "<.*<"))
+      (define re:double-greater (regexp ">.*>"))
+      (define re:bad-chars (regexp "[,\"()<>]"))
+      (define re:tail-blanks (regexp (format "~a+$" blank)))
+      (define re:head-blanks (regexp (format "^~a+" blank)))
+
+      (define (extract-one-name orig form)
+	(let loop ([s orig][form form])
+	  (cond
+	   ;; ?!?!? Where does the "addr (name)" standard come from ?!?!?
+	   [(regexp-match re:parened-name s)
+	    => (lambda (m)
+		 (let ([name (caddr m)]
+		       [all (loop (cadr m) 'all)])
+		   (select-result form 
+				  (if (string=? (car all) (cadr all))
+				      name
+				      (car all))
+				  (cadr all)
+				  (format "~a (~a)" (caddr all) name))))]
+	   [(regexp-match re:quoted-name s)
+	    => (lambda (m)
+		 (let ([name (cadr m)]
+		       [addr (extract-angle-addr (caddr m) s)])
+		   (select-result form name addr
+				  (format "~a <~a>" name addr))))]
+	   [(regexp-match re:simple-name s)
+	    => (lambda (m)
+		 (let ([name (regexp-replace (format "~a*$" blank) (cadr m) "")]
+		       [addr (extract-angle-addr (caddr m) s)])
+		   (select-result form name addr 
+				  (format "~a <~a>" name addr))))]
+	   [(or (regexp-match "<" s) (regexp-match ">" s))
+	    (one-result form (extract-angle-addr s orig))]
+	   [else
+	    (one-result form (extract-simple-addr s orig))])))
+
+      (define (extract-angle-addr s orig)
+	(if (or (regexp-match re:double-less s) (regexp-match re:double-greater s))
+	    (error 'extract-address "too many angle brackets: ~a" s)
+	    (let ([m (regexp-match re:normal-name s)])
+	      (if m
+		  (extract-simple-addr (cadr m) orig)
+		  (error 'extract-address "cannot parse address: ~a" orig)))))
+
+      (define (extract-simple-addr s orig)
+	(cond
+	 [(regexp-match re:bad-chars s)
+	  (error 'extract-address "cannot parse address: ~a" orig)]
+	 [else 
+	  ;; final whitespace strip
+	  (regexp-replace
+	   re:tail-blanks
+	   (regexp-replace re:head-blanks s "")
+	   "")]))
+
+      (define (assemble-address-field addresses)
+	(if (null? addresses)
+	    ""
+	    (let loop ([addresses (cdr addresses)]
+		       [s (car addresses)]
+		       [len (string-length (car addresses))])
+	      (if (null? addresses)
+		  s
+		  (let* ([addr (car addresses)]
+			 [alen (string-length addr)])
+		    (if (<= 72 (+ len alen))
+			(loop (cdr addresses)
+			      (format "~a,~a~a~a~a" 
+				      s #\return #\linefeed 
+				      #\tab addr)
+			      alen)
+			(loop (cdr addresses)
+			      (format "~a, ~a" s addr)
+			      (+ len alen 2)))))))))))
diff --git a/collects/net/head.ss b/collects/net/head.ss
new file mode 100644
index 0000000000..10249f5ed5
--- /dev/null
+++ b/collects/net/head.ss
@@ -0,0 +1,11 @@
+
+(module head mzscheme
+  (require (lib "unitsig.ss"))
+
+  (require "head-sig.ss")
+  (require "head-unit.ss")
+
+  (define-values/invoke-unit/sig net:head^
+    net:head@)
+
+  (provide-signature-elements net:head^))
diff --git a/collects/net/imap-sig.ss b/collects/net/imap-sig.ss
new file mode 100644
index 0000000000..44d8dda237
--- /dev/null
+++ b/collects/net/imap-sig.ss
@@ -0,0 +1,44 @@
+
+
+(module imap-sig mzscheme
+  (require (lib "unitsig.ss"))
+
+  (provide net:imap^)
+  (define-signature net:imap^
+    (imap-port-number
+     imap-connection?
+
+     imap-connect imap-connect*
+     imap-disconnect
+     imap-force-disconnect
+     imap-reselect
+     imap-examine
+     imap-noop
+     imap-status
+     imap-poll
+     
+     imap-new?
+     imap-messages
+     imap-recent
+     imap-uidnext
+     imap-uidvalidity
+     imap-unseen
+     imap-reset-new!
+
+     imap-get-expunges
+     imap-pending-expunges?
+     imap-get-updates
+     imap-pending-updates?
+
+     imap-get-messages
+     imap-copy imap-append
+     imap-store imap-flag->symbol symbol->imap-flag
+     imap-expunge
+     
+     imap-mailbox-exists?
+     imap-create-mailbox
+
+     imap-list-child-mailboxes
+     imap-mailbox-flags
+     imap-get-hierarchy-delimiter)))
+
diff --git a/collects/net/imap-unit.ss b/collects/net/imap-unit.ss
new file mode 100644
index 0000000000..27a6002365
--- /dev/null
+++ b/collects/net/imap-unit.ss
@@ -0,0 +1,573 @@
+
+(module imap-unit mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "list.ss")
+	   "imap-sig.ss"
+	   "private/rbtree.ss")
+  
+  (provide net:imap@)
+  (define net:imap@
+    (unit/sig net:imap^
+      (import)
+
+      (define debug-via-stdio? #f)
+
+      (define eol (if debug-via-stdio?
+		      'linefeed
+		      'return-linefeed))
+
+      (define (tag-eq? a b)
+	(or (eq? a b)
+	    (and (symbol? a)
+		 (symbol? b)
+		 (string-ci=? (symbol->string a) 
+			      (symbol->string b)))))
+
+      (define field-names
+	(list
+	 (list 'uid (string->symbol "UID"))
+	 (list 'header (string->symbol "RFC822.HEADER"))
+	 (list 'body (string->symbol "RFC822.TEXT"))
+	 (list 'size (string->symbol "RFC822.SIZE"))
+	 (list 'flags (string->symbol "FLAGS"))))
+
+      (define flag-names
+	(list
+	 (list 'seen (string->symbol "\\Seen"))
+	 (list 'answered (string->symbol "\\Answered"))
+	 (list 'flagged (string->symbol "\\Flagged"))
+	 (list 'deleted (string->symbol "\\Deleted"))
+	 (list 'draft (string->symbol "\\Draft"))
+	 (list 'recent (string->symbol "\\Recent"))
+
+	 (list 'noinferiors (string->symbol "\\Noinferiors"))
+	 (list 'noselect (string->symbol "\\Noselect"))
+	 (list 'marked (string->symbol "\\Marked"))
+	 (list 'unmarked (string->symbol "\\Unmarked"))
+
+	 (list 'hasnochildren (string->symbol "\\HasNoChildren"))
+	 (list 'haschildren (string->symbol "\\HasChildren"))))
+
+      (define (imap-flag->symbol f)
+	(or (ormap (lambda (a) (and (tag-eq? f (cadr a)) (car a)))
+		   flag-names)
+	    f))
+
+      (define (symbol->imap-flag s)
+	(let ([a (assoc s flag-names)])
+	  (if a
+	      (cadr a)
+	      s)))
+
+      (define (log-warning . args)
+        ;; (apply printf args)
+	(void))
+      (define log log-warning)
+
+      (define make-msg-id
+	(let ([id 0])
+	  (lambda ()
+	    (begin0
+	     (string->bytes/latin-1 (format "a~a " id))
+	     (set! id (add1 id))))))
+
+      (define (starts-with? l n)
+	(and (>= (bytes-length l) (bytes-length n))
+	     (bytes=? n (subbytes l 0 (bytes-length n)))))
+
+      (define (skip s n)
+	(subbytes s
+		  (if (number? n) n (bytes-length n))
+		  (bytes-length s)))
+      
+      (define (splice l sep)
+	(if (null? l)
+	    ""
+	    (format "~a~a"
+		    (car l)
+		    (apply
+		     string-append
+		     (map
+		      (lambda (n) (format "~a~a" sep n))
+		      (cdr l))))))
+
+      (define (imap-read s r)
+	(let loop ([s s]
+		   [r r]
+		   [accum null]
+		   [eol-k (lambda (accum) (reverse! accum))]
+		   [eop-k (lambda (s accum) (error 'imap-read "unxpected close parenthesis"))])
+          (cond
+	   [(bytes=? #"" s) 
+            (eol-k accum)]
+	   [(char-whitespace? (integer->char (bytes-ref s 0)))
+            (loop (skip s 1) r accum eol-k eop-k)]
+	   [else
+	    (case (integer->char (bytes-ref s 0))
+	      [(#\") 
+               (let ([m (regexp-match #rx#"\"([^\"]*)\"(.*)" s)])
+		       (if m
+			   (loop (caddr m) r (cons (cadr m) accum) eol-k eop-k)
+			   (error 'imap-read "didn't find end of quoted string in: ~a" s)))]
+	      [(#\)) 
+               (eop-k (skip s 1) accum)]
+	      [(#\() (letrec ([next-line
+			       (lambda (accum) 
+				 (loop (read-bytes-line r eol) r
+				       accum
+				       next-line
+				       finish-parens))]
+			      [finish-parens
+			       (lambda (s laccum)
+				 (loop s r
+				       (cons (reverse! laccum) accum)
+				       eol-k eop-k))])
+                       (loop (skip s 1) r null next-line finish-parens))]
+	      [(#\{) (let ([m (regexp-match #rx#"{([0-9]+)}(.*)" s)])
+		       (cond
+			[(not m) (error 'imap-read "couldn't read {} number: ~a" s)]
+			[(not (bytes=? (caddr m) #"")) (error 'imap-read "{} not at end-of-line: ~a" s)]
+			[else 
+                         (loop #"" r
+                               (cons (read-bytes (string->number 
+                                                  (bytes->string/latin-1 (cadr m)))
+                                                 r)
+                                     accum)
+                               eol-k eop-k)]))]
+	      [else (let ([m (regexp-match #rx#"([^ (){}]+)(.*)" s)])
+                      (if m
+			  (loop (caddr m) r
+				(cons (let ([v (cadr m)])
+					(if (regexp-match #rx#"^[0-9]*$" v)
+					    (string->number (bytes->string/latin-1 v))
+					    (string->symbol (bytes->string/latin-1 v))))
+				      accum)
+				eol-k eop-k)
+			  (error 'imap-read "failure reading atom: ~a" s)))])])))
+
+      (define (get-response r id info-handler continuation-handler)
+	(let loop ()
+	  (let ([l (read-bytes-line r eol)])
+	    (log "raw-reply: ~s~n" l)
+	    (cond
+	     [(and id (starts-with? l id))
+	      (let ([reply (imap-read (skip l id) r)])
+		(log "response: ~a~n" reply)
+		reply)]
+	     [(starts-with? l #"* ")
+	      (let ([info (imap-read (skip l 2) r)])
+		(log "info: ~s~n" info)
+		(info-handler info))
+	      (when id
+		(loop))]
+	     [(starts-with? l #"+ ")
+	      (if (null? continuation-handler)
+		  (error 'imap-send "unexpected continuation request: ~a" l)
+		  ((car continuation-handler) loop (imap-read (skip l 2) r)))]
+	     [else
+	      (log-warning "warning: unexpected response for ~a: ~a~n" id l)
+	      (when id
+		(loop))]))))
+
+      ;; A cmd is
+      ;;  * (box v) - send v literally via ~a
+      ;;  * string or bytes - protect as necessary
+      ;;  * (cons cmd null) - same as cmd
+      ;;  * (cons cmd cmd) - send cmd, space, cmd
+
+      (define (imap-send imap cmd info-handler . continuation-handler)
+	(let ([r (imap-r imap)]
+              [w (imap-w imap)]
+	      [id (make-msg-id)])
+	  (log "sending ~a~a~n" id cmd)
+	  (fprintf w "~a" id)
+	  (let loop ([cmd cmd])
+	    (cond
+	     [(box? cmd) (fprintf w "~a" (unbox cmd))]
+	     [(string? cmd) (loop (string->bytes/utf-8 cmd))]
+	     [(bytes? cmd) (if (or (regexp-match #rx#"[ *\"\r\n]" cmd)
+				   (equal? cmd #""))
+			       (if (regexp-match #rx#"[\"\r\n]" cmd)
+				   (begin
+				     ;; Have to send size, then continue if the
+				     ;;  server consents
+				     (fprintf w "{~a}\r\n" (bytes-length cmd))
+				     (flush-output w)
+				     (get-response r #f void (list (lambda (gloop data) (void))))
+				     ;; Continue by writing the data
+				     (write-bytes cmd w))
+				   (fprintf w "\"~a\"" cmd))
+			       (fprintf w "~a" cmd))]
+	     [(and (pair? cmd) (null? (cdr cmd))) (loop (car cmd))]
+	     [(pair? cmd) (begin (loop (car cmd))
+				 (fprintf w " ")
+				 (loop (cdr cmd)))]))
+	  (fprintf w "\r\n")
+	  (flush-output w)
+	  (get-response r id (wrap-info-handler imap info-handler) continuation-handler)))
+
+      (define (check-ok reply)
+	(unless (and (pair? reply)
+		     (tag-eq? (car reply) 'OK))
+	  (error 'check-ok "server error: ~s" reply)))
+
+      (define (ok-tag-eq? i t)
+	(and (tag-eq? (car i) 'OK)
+	     ((length i) . >= . 3)
+	     (tag-eq? (cadr i) (string->symbol (format "[~a" t)))))
+
+      (define (ok-tag-val i)
+	(let ([v (caddr i)])
+	  (and (symbol? v)
+	       (let ([v (symbol->string v)])
+		 (regexp-match #rx"[]]$" v)
+		 (string->number (substring v 0 (sub1 (string-length v))))))))
+	
+      (define (wrap-info-handler imap info-handler)
+	(lambda (i)
+	  (when (and (list? i) ((length i) . >= . 2))
+	    (cond
+	     [(tag-eq? (cadr i) 'EXISTS)
+	      (when (> (car i) (or (imap-exists imap) 0))
+		(set-imap-new?! imap #t))
+	      (set-imap-exists! imap (car i))]
+	     [(tag-eq? (cadr i) 'RECENT)
+	      (set-imap-recent! imap (car i))]
+	     [(tag-eq? (cadr i) 'EXPUNGE)
+	      (let ([n (car i)])
+		(log "Recording expunge: ~s~n" n)
+		;; add it to the tree of expunges
+		(expunge-insert! (imap-expunges imap) n)
+		;; decrement exists count:
+		(set-imap-exists! imap (sub1 (imap-exists imap)))
+		;; adjust ids for any remembered fetches:
+		(fetch-shift! (imap-fetches imap) n))]
+	     [(tag-eq? (cadr i) 'FETCH)
+	      (fetch-insert! (imap-fetches imap)
+			     ;; Convert result to assoc list:
+			     (cons (car i)
+				   (let ([new
+					  (let loop ([l (caddr i)])
+					    (if (null? l)
+						null
+						(cons (cons (car l) (cadr l))
+						      (loop (cddr l)))))])
+				     ;; Keep anything not overridden:
+				     (let ([old (cdr (or (fetch-find (imap-fetches imap) (car i))
+							 '(0)))])
+				       (let loop ([old old][new new])
+					 (cond
+					  [(null? old) new]
+					  [(assq (caar old) new)
+					   (loop (cdr old) new)]
+					  [else (loop (cdr old) (cons (car old) new))]))))))]
+	     [(ok-tag-eq? i 'UIDNEXT)
+	      (set-imap-uidnext! imap (ok-tag-val i))]
+	     [(ok-tag-eq? i 'UIDVALIDITY)
+	      (set-imap-uidvalidity! imap (ok-tag-val i))]
+	     [(ok-tag-eq? i 'UNSEEN)
+	      (set-imap-uidvalidity! imap (ok-tag-val i))]))
+	  (info-handler i)))
+      
+      (define-struct imap (r w 
+			     exists recent unseen uidnext uidvalidity
+			     expunges fetches new?))
+      (define (imap-connection? v) (imap? v))
+      
+      (define imap-port-number (make-parameter 143
+					       (lambda (v)
+						 (unless (and (number? v)
+							      (exact? v)
+							      (integer? v)
+							      (<= 1 v 65535))
+						   (raise-type-error 'imap-port-number
+								     "exact integer in [1,65535]"
+								     v))
+						 v)))
+
+      (define (imap-connect* r w username password inbox)
+	(with-handlers ([void
+			  (lambda (x)
+			    (close-input-port r)
+			    (close-output-port w)
+			    (raise x))])
+	  
+	  (let ([imap (make-imap r w 
+					    #f #f #f #f #f 
+					    (new-tree) (new-tree) #f)])
+	    (check-ok (imap-send imap "NOOP" void))
+	    (let ([reply (imap-send imap (list "LOGIN" username password) void)])
+	      (if (and (pair? reply) (tag-eq? 'NO (car reply)))
+		  (error 'imap-connect "username or password rejected by server: ~s" reply)
+		  (check-ok reply)))
+	    (let-values ([(init-count init-recent) (imap-reselect imap inbox)])
+	      (values imap
+		      init-count
+		      init-recent)))))
+
+      (define (imap-connect server username password inbox)
+	;; => imap count-k recent-k
+	(let-values ([(r w) (if debug-via-stdio?
+				(begin
+				  (printf "stdin == ~a~n" server)
+				  (values  (current-input-port) (current-output-port)))
+				(tcp-connect server (imap-port-number)))])
+	  (imap-connect* r w username password inbox)))
+      
+      (define (imap-reselect imap inbox)
+	(imap-selectish-command imap (list "SELECT" inbox) #t))
+
+      (define (imap-examine imap inbox)
+	(imap-selectish-command imap (list "EXAMINE" inbox) #t))
+
+      ;; Used to return (values #f #f) if no change since last check?
+      (define (imap-noop imap)
+        (imap-selectish-command imap "NOOP" #f))
+
+      (define (imap-selectish-command imap cmd reset?)
+	(let ([init-count #f]
+	      [init-recent #f])
+	  (check-ok (imap-send imap cmd void))
+	  (when reset?
+	    (set-imap-expunges! imap (new-tree))
+	    (set-imap-fetches! imap (new-tree))
+	    (set-imap-new?! imap #f))
+	  (values (imap-exists imap) (imap-recent imap))))
+
+      (define (imap-status imap inbox flags)
+	(unless (and (list? flags)
+		     (andmap (lambda (s)
+			       (memq s '(messages recent uidnext uidvalidity unseen)))
+			     flags))
+	  (raise-type-error 'imap-status "list of status flag symbols" flags))
+	(let ([results null])
+	  (check-ok (imap-send imap (list "STATUS" inbox 
+					  (box (format "~a" flags)))
+			       (lambda (i)
+				 (when (and (list? i) (= 3 (length i))
+					    (tag-eq? (car i) 'STATUS))
+				   (set! results (caddr i))))))
+	  (map
+	   (lambda (f)
+	     (let loop ([l results])
+	       (cond
+		[(or (null? l) (null? (cdr l))) #f]
+		[(tag-eq? f (car l)) (cadr l)]
+		[else (loop (cdr l))])))
+	   flags)))
+
+      (define (imap-poll imap)
+	;; Check for async messages from the server
+	(when (char-ready? (imap-r imap))
+	  ;; It has better start with "*"...
+	  (when (= (peek-byte (imap-r imap))
+		   (char->integer #\*))
+	    ;; May set fields in `imap':
+	    (get-response (imap-r imap) #f (wrap-info-handler imap void) null)
+	    (void))))
+
+      (define (imap-get-updates imap)
+	(no-expunges 'imap-updates imap)
+	(let ([l (fetch-tree->list (imap-fetches imap))])
+	  (set-imap-fetches! imap (new-tree))
+	  l))
+
+      (define (imap-pending-updates? imap)
+	(not (tree-empty? (imap-fetches imap))))
+
+      (define (imap-get-expunges imap)
+	(let ([l (expunge-tree->list (imap-expunges imap))])
+	  (set-imap-expunges! imap (new-tree))
+	  l))
+
+      (define (imap-pending-expunges? imap)
+	(not (tree-empty? (imap-expunges imap))))
+
+      (define (imap-reset-new! imap)
+	(set-imap-new?! imap #f))
+
+      (define (imap-messages imap)
+	(imap-exists imap))
+      
+      (define (imap-disconnect imap)
+	(let ([r (imap-r imap)]
+	      [w (imap-w imap)])
+	  (check-ok (imap-send imap "LOGOUT" void))
+	  (close-input-port r) 
+	  (close-output-port w)))
+
+      (define (imap-force-disconnect imap)
+	(let ([r (imap-r imap)]
+	      [w (imap-w imap)])
+	  (close-input-port r) 
+	  (close-output-port w)))
+      
+      (define (no-expunges who imap)
+	(unless (tree-empty? (imap-expunges imap))
+	  (raise-mismatch-error who 
+				"session has pending expunge reports: "
+				imap)))
+
+      (define (imap-get-messages imap msgs field-list)
+	(no-expunges 'imap-get-messages imap)
+	(when (or (not (list? msgs))
+		  (not (andmap integer? msgs)))
+	  (raise-type-error 'imap-get-messages "non-empty message list" msgs))
+	(when (or (null? field-list)
+		  (not (list? field-list))
+		  (not (andmap (lambda (f) (assoc f field-names)) field-list)))
+	  (raise-type-error 'imap-get-messages "non-empty field list" field-list))
+	
+	(if (null? msgs)
+	    null
+	    (begin
+	      ;; FETCH request adds info to `(imap-fectches imap)':
+	      (imap-send imap (list "FETCH"
+				    (box (splice msgs ","))
+				    (box
+				     (format "(~a)"
+					     (splice (map (lambda (f) (cadr (assoc f field-names))) field-list) " "))))
+			 void)
+	      ;; Sort out the collected info:
+	      (let ([flds (map (lambda (f)
+				 (cadr (assoc f field-names)))
+			       field-list)])
+		(begin0
+		 ;; For each msg, try to get each field value:
+		 (map
+		  (lambda (msg)
+		    (let ([m (or (fetch-find (imap-fetches imap) msg)
+				 (error 'imap-get-messages "no result for message ~a" msg))])
+		      (let loop ([flds flds][m (cdr m)])
+			(cond
+			 [(null? flds)
+			  (if (null? m)
+			      (fetch-delete! (imap-fetches imap) msg)
+			      (fetch-insert! (imap-fetches imap) (cons msg m)))
+			  null]
+			 [else
+			  (let ([a (assoc (car flds) m)])
+			    (cons
+			     (and a (cdr a))
+			     (loop (cdr flds) (if a
+						  (remq a m)
+						  m))))]))))
+		  msgs))))))
+      
+      (define (imap-store imap mode msgs flags)
+	(no-expunges 'imap-store imap)
+	(check-ok 
+	 (imap-send imap 
+		    (list "STORE"
+			  (box (splice msgs ","))
+			  (case mode
+			    [(+) "+FLAGS.SILENT"]
+			    [(-) "-FLAGS.SILENT"]
+			    [(!) "FLAGS.SILENT"]			    
+			    [else (raise-type-error
+				   'imap-store
+				   "mode: '!, '+, or '-"
+				   mode)])
+			  (box (format "~a" flags)))
+		    void)))
+
+      (define (imap-copy imap msgs dest-mailbox)
+	(no-expunges 'imap-copy imap)
+	(check-ok 
+	 (imap-send imap
+		    (list "COPY"
+			  (box (splice msgs ","))
+			  dest-mailbox)
+		    void)))
+      
+      (define (imap-append imap dest-mailbox msg)
+	(no-expunges 'imap-append imap)
+        (let ([msg (if (bytes? msg)
+		       msg
+		       (string->bytes/utf-8 msg))])
+          (check-ok
+           (imap-send imap (list "APPEND"
+				 dest-mailbox
+				 (box "(\\Seen)")
+				 (box (format "{~a}" (bytes-length msg))))
+                      void
+                      (lambda (loop contin)
+                        (fprintf (imap-w imap) "~a\r\n" msg)
+			(loop))))))
+      
+      (define (imap-expunge imap)
+	(check-ok (imap-send imap "EXPUNGE" void)))
+      
+      (define (imap-mailbox-exists? imap mailbox)
+	(let ([exists? #f])
+	  (check-ok (imap-send imap
+			       (list "LIST"
+				     ""
+				     mailbox)
+			       (lambda (i)
+				 (when (and (pair? i)
+					    (tag-eq? (car i) 'LIST))
+				   (set! exists? #t)))))
+	  exists?))
+
+      (define (imap-create-mailbox imap mailbox)
+	(check-ok 
+	 (imap-send imap
+		    (list "CREATE" mailbox)
+		    void)))
+      
+      (define (imap-get-hierarchy-delimiter imap)
+	(let* ([result #f])
+	  (check-ok
+	   (imap-send imap (list "LIST" "" "")
+		      (lambda (i)
+			(when (and (pair? i)
+				   (tag-eq? (car i) 'LIST))
+			  (set! result (caddr i))))))
+	  result))
+
+      (define imap-list-child-mailboxes 
+	(case-lambda
+	 [(imap mailbox)
+	  (imap-list-child-mailboxes imap mailbox #f)]
+	 [(imap mailbox raw-delimiter)
+	  (let* ([delimiter (or raw-delimiter (imap-get-hierarchy-delimiter imap))]
+                 [mailbox-name (and mailbox (bytes-append mailbox delimiter))]
+		 [pattern (if mailbox
+			      (bytes-append mailbox-name #"%")
+			      #"%")])
+	    (map (lambda (p)
+		   (list (car p)
+			 (cond
+			  [(symbol? (cadr p)) (string->bytes/utf-8 (symbol->string (cadr p)))]
+			  [(string? (cadr p)) (string->bytes/utf-8 (symbol->string (cadr p)))]
+			  [(bytes? (cadr p)) (cadr p)])))
+		 (imap-list-mailboxes imap pattern mailbox-name)))]))
+      
+      (define (imap-mailbox-flags imap mailbox)
+        (let ([r (imap-list-mailboxes imap mailbox #f)])
+          (if (= (length r) 1)
+              (caar r)
+              (error 'imap-mailbox-flags "could not get flags for ~s (~a)"
+                     mailbox
+                     (if (null? r) "no matches" "multiple matches")))))
+      
+      (define (imap-list-mailboxes imap pattern except)
+        (let* ([sub-folders null])
+          (check-ok
+           (imap-send imap (list "LIST" "" pattern)
+                      (lambda (x)
+			(when (and (pair? x)
+				   (tag-eq? (car x) 'LIST))
+			  (let* ([flags (cadr x)]
+                                 [name (cadddr x)]
+                                 [bytes-name (if (symbol? name)
+                                                 (string->bytes/utf-8 (symbol->string name))
+                                                 name)])
+                            (unless (and except
+					 (bytes=? bytes-name except))
+			      (set! sub-folders 
+				    (cons 
+				     (list flags name)
+				     sub-folders))))))))
+          (reverse sub-folders))))))
diff --git a/collects/net/imap.ss b/collects/net/imap.ss
new file mode 100644
index 0000000000..61d94ed92d
--- /dev/null
+++ b/collects/net/imap.ss
@@ -0,0 +1,55 @@
+
+(module imap mzscheme
+  (require (lib "unitsig.ss")
+           (lib "contract.ss"))
+  
+  (require "imap-sig.ss"
+           "imap-unit.ss")
+  
+  (define-values/invoke-unit/sig net:imap^
+                                 net:imap@)
+  
+  (provide/contract
+   [imap-get-hierarchy-delimiter (imap-connection? . -> . bytes?)]
+   [imap-list-child-mailboxes
+    (case->
+     (imap-connection? (union false/c bytes?) . -> . (listof (list/c (listof symbol?) bytes?)))
+     (imap-connection? (union false/c bytes?) (union false/c bytes?)
+                       . -> .
+                       (listof (list/c (listof symbol?) bytes?))))])
+   
+  (provide
+   imap-connection?
+   imap-connect imap-connect*
+   imap-disconnect
+   imap-force-disconnect
+   imap-reselect
+   imap-examine
+   imap-noop
+   imap-poll
+   imap-status
+   
+   imap-port-number ; a parameter
+
+   imap-new?
+   imap-messages
+   imap-recent
+   imap-uidnext
+   imap-uidvalidity
+   imap-unseen
+   imap-reset-new!
+   
+   imap-get-expunges
+   imap-pending-expunges?
+   imap-get-updates
+   imap-pending-updates?
+   
+   imap-get-messages
+   imap-copy imap-append
+   imap-store imap-flag->symbol symbol->imap-flag
+   imap-expunge
+   
+   imap-mailbox-exists?
+   imap-create-mailbox
+   
+   imap-mailbox-flags))
\ No newline at end of file
diff --git a/collects/net/info.ss b/collects/net/info.ss
new file mode 100644
index 0000000000..a356656241
--- /dev/null
+++ b/collects/net/info.ss
@@ -0,0 +1,13 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Net")
+  (define doc.txt "doc.txt")
+  
+  (define help-desk-message
+    "Mz/Mr: See the \"To load\" section of each collection for the command to load it.")
+  (define blurb 
+    (list
+     "The net collection provides a suite of libraries to handle standard "
+     "internet-based protocols."))
+
+  ;; Should be removed when openssl is part of main distribution
+  (define compile-omit-files '("ssl-tcp-unit.ss")))
diff --git a/collects/net/mime-sig.ss b/collects/net/mime-sig.ss
new file mode 100644
index 0000000000..6983623876
--- /dev/null
+++ b/collects/net/mime-sig.ss
@@ -0,0 +1,33 @@
+(module mime-sig mzscheme
+  (require (lib "unitsig.ss"))
+
+  (provide net:mime^)
+  
+  (define-signature net:mime^
+    (
+     ;; -- exceptions raised --
+     (struct mime-error () -setters (- make-mime-error))
+     (struct unexpected-termination (msg) -setters (- make-unexpected-termination))
+     (struct missing-multipart-boundary-parameter () -setters
+             (- make-missing-multipart-boundary-parameter))
+     (struct malformed-multipart-entity (msg) -setters (- make-malformed-multipart-entity))
+     (struct empty-mechanism () -setters (- make-empty-mechanism))
+     (struct empty-type () -setters (- make-empty-type))
+     (struct empty-subtype () -setters (- make-empty-subtype))
+     (struct empty-disposition-type () -setters (- make-empty-disposition-type))
+     
+     ;; -- basic mime structures --
+     (struct message (version entity fields))
+     (struct entity
+             (type subtype charset encoding
+                   disposition params id
+                   description other fields
+                   parts body))
+     (struct disposition
+             (type filename creation
+                   modification read
+                   size params))
+     
+     ;; -- mime methods --
+     mime-analyze
+     )))
diff --git a/collects/net/mime-unit.ss b/collects/net/mime-unit.ss
new file mode 100644
index 0000000000..8abeec0e0c
--- /dev/null
+++ b/collects/net/mime-unit.ss
@@ -0,0 +1,786 @@
+;;;
+;;; <mime-unit.ss> ---- MIME support
+;;;
+;;; Copyright (C) 2002 by PLT. 
+;;; Copyright (C) 2001 by Wish Computing. 
+;;;
+;;; This file is part of mime
+
+;;; mime-plt is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2, or (at your option)
+;;; any later version.
+
+;;; mime-plt is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+
+;;; You should have received a copy of the GNU General Public License
+;;; along with mime-plt; see the file COPYING.  If not, write to the
+;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;;; Boston, MA 02111-1307, USA.
+
+;;; Author: Francisco Solsona <solsona@acm.org>
+;;
+;;
+;; Commentary: MIME support for PLT Scheme: an implementation of
+;; rfc2045, rfc2046, rfc2047, rfc2048, and rfc2049.
+
+(module mime-unit mzscheme
+  (require "mime-sig.ss"
+           "qp-sig.ss"
+           "base64-sig.ss"
+	   "head-sig.ss"
+           "mime-util.ss"
+           (lib "unitsig.ss")
+           (lib "etc.ss")
+           (lib "string.ss")
+           (lib "port.ss"))
+
+  (provide net:mime@)
+  (define net:mime@
+    (unit/sig net:mime^
+      (import net:base64^
+              net:qp^
+	      net:head^)
+
+      ;; Constants:
+      (define discrete-alist '(("text" . text)
+                               ("image" . image)
+                               ("audio" . audio)
+                               ("video" . video)
+                               ("application" . application)))
+
+      (define disposition-alist '(("inline" . inline)
+                                  ("attachment" . attachment)
+                                  ("file" . attachment) ;; This is used
+                                                        ;; (don't know why)
+                                                        ;; by multipart/form-data
+				  ("messagetext" . inline)
+                                  ("form-data" . form-data)))
+
+      (define composite-alist '(("message" . message)
+                                ("multipart" . multipart)))
+      
+      (define mechanism-alist '(("7bit" . 7bit)
+                                ("8bit" . 8bit)
+                                ("binary" . binary)
+                                ("quoted-printable" . quoted-printable)
+                                ("base64" . base64)))
+      
+      (define ietf-extensions '())
+      (define iana-extensions '(;; text
+                                ("plain" . plain)
+                                ("html" . html)
+                                ("enriched"  . enriched) ; added 5/2005 - probably not iana
+                                ("richtext"  . richtext)
+                                ("tab-separated-values" . tab-separated-values)
+                                ;; Multipart
+                                ("mixed" . mixed)
+                                ("alternative" . alternative)
+                                ("digest" . digest)
+                                ("parallel" . parallel)
+                                ("appledouble" . appledouble)
+                                ("header-set" . header-set)
+                                ("form-data" . form-data)
+                                ;; Message
+                                ("rfc822" . rfc822)
+                                ("partial" . partial)
+                                ("external-body" . external-body)
+                                ("news" . news)
+                                ;; Application
+                                ("octet-stream" . octet-stream)
+                                ("postscript" . postscript)
+                                ("oda" . oda)
+                                ("atomicmail" . atomicmail)
+                                ("andrew-inset" . andrew-inset)
+                                ("slate" . slate)
+                                ("wita" . wita)
+                                ("dec-dx" . dec-dx)
+                                ("dca-rf" . dca-rf)
+                                ("activemessage" . activemessage)
+                                ("rtf" . rtf)
+                                ("applefile" . applefile)
+                                ("mac-binhex40" . mac-binhex40)
+                                ("news-message-id" . news-message-id)
+                                ("news-transmissio" . news-transmissio)
+                                ("wordperfect5.1" . wordperfect5.1)
+                                ("pdf" . pdf)
+                                ("zip" . zip)
+                                ("macwritei" . macwritei)
+                                ;; "image"
+                                ("jpeg" . jpeg)
+                                ("gif" . gif)
+                                ("ief" . ief)
+                                ("tiff" . tiff)
+                                ;; "audio"
+                                ("basic" . basic)
+                                ;; "video" .
+                                ("mpeg" . mpeg)
+                                ("quicktime" . quicktime)))
+
+      ;; Basic structures
+      (define-struct message (version entity fields))
+      (define-struct entity
+                     (type subtype charset encoding disposition params id description other fields parts body))
+      (define-struct disposition
+                     (type filename creation modification read size params))
+
+      ;; Exceptions
+      (define-struct mime-error ())
+      (define-struct (unexpected-termination mime-error) (msg))
+      (define-struct (missing-multipart-boundary-parameter mime-error) ())
+      (define-struct (malformed-multipart-entity mime-error) (msg))
+      (define-struct (empty-mechanism mime-error) ())
+      (define-struct (empty-type mime-error) ())
+      (define-struct (empty-subtype mime-error) ())
+      (define-struct (empty-disposition-type mime-error) ())
+
+      ;; *************************************
+      ;; Practical stuff, aka MIME in action:
+      ;; *************************************
+      (define CRLF (format "~a~a" #\return #\newline))
+      (define CRLF-binary "=0D=0A") ;; quoted printable representation
+
+      ;; get-headers : input-port -> string
+      ;; returns the header part of a message/part conforming to rfc822,
+      ;; and rfc2045.
+      (define get-headers
+        (lambda (in)
+          (let loop ((headers "") (ln (read-line in 'any)))
+            (cond ((eof-object? ln)
+		   ;; (raise (make-unexpected-termination "eof reached! while parsing headers"))
+		   (warning "premature eof while parsing headers")
+		   headers)
+                  ((string=? ln "") headers)
+                  (else
+                   ;; Quoting rfc822:
+                   ;; " Headers occur before the message body and are
+                   ;; terminated by a null line (i.e., two contiguous
+                   ;; CRLFs)."
+                   ;; That is: Two empty lines.  But most MUAs seem to count
+                   ;; the CRLF ending the last field (header) as the first
+                   ;; CRLF of the null line.
+                   (loop (string-append headers ln CRLF)
+                         (read-line in 'any)))))))
+      
+      (define make-default-disposition
+        (lambda ()
+          (make-disposition
+           'inline ;; type
+           "" ;; filename
+           #f ;; creation
+           #f ;; modification
+           #f ;; read
+           #f ;; size
+           null ;; params
+           )))
+      
+      (define make-default-entity
+        (lambda ()
+          (make-entity
+           'text ;; type
+           'plain ;; subtype
+           'us-ascii ;; charset
+           '7bit  ;; encoding
+           (make-default-disposition) ;; disposition
+           null ;; params
+           "" ;; id
+           "" ;; description
+           null ;; other MIME fields (MIME-extension-fields)
+           null ;; fields
+           null ;; parts
+           null ;; body
+           )))
+      
+      (define make-default-message
+        (lambda ()
+          (make-message 1.0 (make-default-entity) null)))
+      
+      (define mime-decode
+        (lambda (entity input)
+          (set-entity-body!
+           entity
+           (case (entity-encoding entity)
+             ((quoted-printable)
+              (lambda (output)
+		(qp-decode-stream input output)))
+             ((base64)
+              (lambda (output)
+		(base64-decode-stream input output)))
+             (else ;; 7bit, 8bit, binary
+              (lambda (output)
+                (copy-port input output)))))))
+
+      (define mime-analyze
+        (opt-lambda (input (part #f))
+          (let* ((iport (if (bytes? input)
+                            (open-input-bytes input)
+                            input))
+                 (headers (get-headers iport))
+                 (msg (if part
+                          (MIME-part-headers headers)
+                          (MIME-message-headers headers)))
+                 (entity (message-entity msg)))
+            ;; OK we have in msg a MIME-message structure, lets see what we have:
+            (case (entity-type entity)
+              ((text image audio video application)
+               ;; decode part, and save port and thunk
+               (mime-decode entity iport))
+              ((message multipart)
+               (let ((boundary (entity-boundary entity)))
+                 (when (not boundary)
+		   (if (eq? 'multipart (entity-type entity))
+		       (raise (make-missing-multipart-boundary-parameter))))
+                 (set-entity-parts! entity
+                                    (map (lambda (part)
+                                           (mime-analyze part #t))
+					 (if boundary
+					     (multipart-body iport boundary)
+					     (list iport))))))
+              (else
+               ;; Unrecognized type, you're on your own! (sorry)
+               (mime-decode entity iport)))
+            ;; return mime structure
+            msg)))
+      
+      
+      (define entity-boundary
+        (lambda (entity)
+          (let* ((params (entity-params entity))
+                 (ans (assoc "boundary" params)))
+            (and ans
+                 (cdr ans)))))
+      
+      ;; *************************************************
+      ;; MIME Specific: rfc2045-2049, and rfc0822, rfc2183
+      ;; *************************************************
+      
+      ;;multipart-body := [preamble CRLF]
+      ;;		  dash-boundary transport-padding CRLF
+      ;;		  body-part *encapsulation
+      ;;		  close-delimiter transport-padding
+      ;;		  [CRLF epilogue]
+      ;; Returns a list of input ports, each one containing the correspongind part.
+      (define multipart-body
+        (lambda (input boundary)
+          (let* ([make-re (lambda (prefix)
+			    (regexp (string-append prefix "--" (regexp-quote boundary) "(--)?\r\n")))]
+		 [re (make-re "\r\n")])
+            (letrec ((eat-part (lambda ()
+                                 (let-values ([(pin pout) (make-pipe)])
+				   (let ([m (regexp-match re input 0 #f pout)])
+				     (cond
+				      [(not m)
+				       (close-output-port pout)
+				       (values pin;; part
+					       #f;; close-delimiter?
+					       #t;; eof reached?
+					       )]
+				      [(cadr m)
+				       (close-output-port pout)
+				       (values pin #t #f)]
+				      [else
+				       (close-output-port pout)
+				       (values pin #f #f)]))))))
+	      ;; pre-amble is allowed to be completely empty:
+	      (if (regexp-match-peek (make-re "^") input)
+		  ;; No \r\f before first separator:
+		  (read-line input)
+		  ;; non-empty preamble:
+		  (eat-part))
+              (let loop ()
+                (let-values ([(part close? eof?) (eat-part)])
+                  (cond (close? (list part))
+                        (eof? (list part))
+                        (else
+                         (cons part (loop))))))))))
+      
+      ;; MIME-message-headers := entity-headers
+      ;; 			fields
+      ;; 			version CRLF
+      ;; 			; The ordering of the header
+      ;; 			; fields implied by this BNF
+      ;; 			; definition should be ignored.
+      (define MIME-message-headers
+        (lambda (headers)
+          (let ((message (make-default-message)))
+            (entity-headers headers message #t)
+            message)))
+      
+      ;; MIME-part-headers := entity-headers
+      ;; 		     [ fields ]
+      ;; 		     ; Any field not beginning with
+      ;; 		     ; "content-" can have no defined
+      ;; 		     ; meaning and may be ignored.
+      ;; 		     ; The ordering of the header
+      ;; 		     ; fields implied by this BNF
+      ;; 		     ; definition should be ignored.
+      (define MIME-part-headers
+        (lambda (headers)
+          (let ((message (make-default-message)))
+            (entity-headers headers message #f)
+            message)))
+      
+      ;; entity-headers := [ content CRLF ]
+      ;; 		  [ encoding CRLF ]
+      ;; 		  [ id CRLF ]
+      ;; 		  [ description CRLF ]
+      ;; 		  *( MIME-extension-field CRLF )
+      (define entity-headers
+        (lambda (headers message version?)
+          (let ((entity (message-entity message)))
+            (let-values ([(mime non-mime) (get-fields headers)])
+              (let loop ((fields mime))
+                (unless (null? fields)
+                  ;; Process MIME field
+                  (let ((trimmed-h (trim-comments (car fields))))
+                    (or (and version? (version trimmed-h message))
+                        (content trimmed-h entity)
+                        (encoding trimmed-h entity)
+                        (dispositione trimmed-h entity)
+                        (id trimmed-h entity)
+                        (description trimmed-h entity)
+                        (MIME-extension-field trimmed-h entity))
+                    ;; keep going
+                    (loop (cdr fields)))))
+              ;; NON-mime headers  (or semantically incorrect). In
+              ;; order to make this implementation of rfc2045 robuts,
+              ;; we will save the header in the fields field of the
+              ;; message struct:
+              (set-message-fields! message non-mime)
+              ;; Return message
+              message))))
+      
+      (define get-fields
+        (lambda (headers)
+          (let ((mime null) (non-mime null))
+            (letrec ((store-field
+                      (lambda (f)
+                        (unless (string=? f "")
+                          (if (mime-header? f)
+                              (set! mime (append mime (list (trim-spaces f))))
+                              (set! non-mime (append non-mime (list (trim-spaces f)))))))))
+	      (let ([fields (extract-all-fields headers)])
+		(for-each (lambda (p)
+			    (store-field (format "~a: ~a" (car p) (cdr p))))
+			  fields))
+	      (values mime non-mime)))))
+      
+      (define re:content (regexp (format "^~a" (regexp-quote "content-" #f))))
+      (define re:mime (regexp (format "^~a:" (regexp-quote "mime-version" #f))))
+
+      (define mime-header?
+        (lambda (h)
+	  (or (regexp-match re:content h)
+	      (regexp-match re:mime h))))
+      
+      
+      ;;; Headers
+      ;;; Content-type follows this BNF syntax:
+      ;; content := "Content-Type" ":" type "/" subtype
+      ;; 	   *(";" parameter)
+      ;; 	   ; Matching of media type and subtype
+      ;; 	   ; is ALWAYS case-insensitive.
+      (define re:content-type (regexp (format "^~a:([^/]+)/([^/]+)$" (regexp-quote "content-type" #f))))
+      (define content
+        (lambda (header entity)
+          (let* ((params (string-tokenizer #\; header))
+                 (one re:content-type)
+                 (h (trim-all-spaces (car params)))
+                 (target (regexp-match one h))
+                 (old-param (entity-params entity)))
+            (and target
+                 (set-entity-type! entity
+                                   (type (regexp-replace one h "\\1")))   ;; type
+                 (set-entity-subtype!  entity
+                                       (subtype (regexp-replace one h "\\2"))) ;; subtype
+                 (set-entity-params!
+                  entity
+                  (append old-param
+                          (let loop ((p (cdr params));; parameters
+                                     (ans null))
+                            (cond ((null? p) ans)
+                                  (else
+                                   (let ((par-pair (parameter (trim-all-spaces (car p)))))
+                                     (cond (par-pair
+                                            (when (string=? (car par-pair) "charset")
+					      (set-entity-charset! entity (cdr par-pair)))
+                                            (loop (cdr p)
+                                                  (append ans
+                                                          (list par-pair))))
+                                           (else
+                                            (warning "Invalid parameter for Content-Type: `~a'" (car p))
+                                            ;; go on...
+                                            (loop (cdr p) ans)))))))))))))
+      
+      ;; From rfc2183 Content-Disposition
+      ;; disposition := "Content-Disposition" ":"
+      ;;		  disposition-type
+      ;;		  *(";" disposition-parm)
+      (define re:content-disposition (regexp (format "^~a:(.+)$" (regexp-quote "content-disposition" #f))))
+      (define dispositione
+        (lambda (header entity)
+          (let* ((params (string-tokenizer #\; header))
+                 (reg re:content-disposition)
+                 (h (trim-all-spaces (car params)))
+                 (target (regexp-match reg h))
+                 (disp-struct (entity-disposition entity)))
+            (and target
+                 (set-disposition-type!
+                  disp-struct
+		  (disp-type (regexp-replace reg h "\\1")))
+                 (disp-params (cdr params) disp-struct)))))
+      
+      ;; version := "MIME-Version" ":" 1*DIGIT "." 1*DIGIT
+      (define re:mime-version (regexp (format "^~a:([0-9]+)\\.([0-9]+)$" (regexp-quote "MIME-Version" #f))))
+      (define version
+        (lambda (header message)
+          (let* ((reg re:mime-version)
+                 (h (trim-all-spaces header))
+                 (target (regexp-match reg h)))
+            (and target
+                 (set-message-version!
+                  message
+                  (string->number (regexp-replace reg h "\\1.\\2")))))))
+      
+      ;;   description := "Content-Description" ":" *text
+      (define re:content-description (regexp (format "^~a:[ \t\r\n]*(.*)$" (regexp-quote "content-description" #f))))
+      (define description
+        (lambda (header entity)
+          (let* ((reg re:content-description)
+                 (target (regexp-match reg header)))
+            (and target
+                 (set-entity-description!
+                  entity
+                  (trim-spaces (regexp-replace reg header "\\1")))))))
+      
+      ;;   encoding := "Content-Transfer-Encoding" ":" mechanism
+      (define re:content-transfer-encoding (regexp (format "^~a:(.+)$" (regexp-quote "content-transfer-encoding" #f))))
+      (define encoding
+        (lambda (header entity)
+          (let* ((reg re:content-transfer-encoding)
+                 (h (trim-all-spaces header))
+                 (target (regexp-match reg h)))
+            (and target
+                 (set-entity-encoding!
+                  entity
+                  (mechanism (regexp-replace reg h "\\1")))))))
+      
+      ;;   id := "Content-ID" ":" msg-id
+      (define re:content-id (regexp (format "^~a:(.+)$" (regexp-quote "content-id" #f))))
+      (define id
+        (lambda (header entity)
+          (let* ((reg re:content-id)
+                 (h (trim-all-spaces header))
+                 (target (regexp-match reg h)))
+            (and target
+                 (set-entity-id!
+                  entity
+                  (msg-id (regexp-replace reg h "\\1")))))))
+      
+      ;; From rfc822:
+      ;; msg-id      =  "<" addr-spec ">"            ; Unique message id
+      ;; addr-spec   =  local-part "@" domain        ; global address
+      ;; local-part  =  word *("." word)             ; uninterpreted
+      ;;                                             ; case-preserved
+      ;; domain      =  sub-domain *("." sub-domain)
+      ;; sub-domain  =  domain-ref / domain-literal
+      ;; domain-literal =  "[" *(dtext / quoted-pair) "]"
+      ;; domain-ref  =  atom                         ; symbolic reference
+      (define msg-id
+        (lambda (str)
+          (let* ((r (regexp "^<[^@>]+@[^.]+(\\.[^.]+)*>$"))
+                 (ans (regexp-match r str)))
+            (if ans
+                str
+                (begin (warning "Invalid msg-id: ~a" str)
+                       str)))))
+      
+      ;;  mechanism := "7bit" / "8bit" / "binary" /
+      ;;		 "quoted-printable" / "base64" /
+      ;;		 ietf-token / x-token
+      (define mechanism
+        (lambda (mech)
+          (if (not mech)
+              (raise (make-empty-mechanism))
+              (let ((val (assoc (lowercase mech) mechanism-alist)))
+                (or (and val (cdr val))
+                    (ietf-token mech)
+                    (x-token mech))))))
+      
+      ;;  MIME-extension-field := <Any RFC 822 header field which
+      ;;			      begins with the string
+      ;;			      "Content-">
+      ;;
+      (define MIME-extension-field
+        (lambda (header entity)
+          (let* ((reg (regexp "^[Cc]ontent-(.+):[ \t]*(.+)$"))
+                 (target (regexp-match reg header)))
+            (and target
+                 (set-entity-other!
+                  entity
+                  (append (entity-other entity)
+                          (list 
+                           (cons (regexp-replace reg header "\\1")
+                                 (trim-spaces (regexp-replace reg header "\\2"))))))))))
+      
+      ;; type := discrete-type / composite-type
+      (define type
+        (lambda (value)
+          (if (not value)
+              (raise (make-empty-type))
+              (or (discrete-type value)
+                  (composite-type value)))))
+      
+      ;; disposition-type := "inline" / "attachment"  / extension-token
+      (define disp-type
+        (lambda (value)
+          (if (not value)
+              (raise (make-empty-disposition-type))
+              (let ((val (assoc (lowercase (trim-spaces value)) disposition-alist)))
+                (if val (cdr val) (extension-token value))))))
+      
+      ;; discrete-type := "text" / "image" / "audio" / "video" /
+      ;; 		 "application" / extension-token
+      (define discrete-type
+        (lambda (value)
+          (let ((val (assoc (lowercase (trim-spaces value)) discrete-alist)))
+            (if val (cdr val) (extension-token value)))))
+      
+      ;; composite-type := "message" / "multipart" / extension-token
+      (define composite-type
+        (lambda (value)
+          (let ((val (assoc (lowercase (trim-spaces value)) composite-alist)))
+            (if val (cdr val) (extension-token value)))))
+      
+      ;; extension-token := ietf-token / x-token
+      (define extension-token
+        (lambda (value)
+          (or (ietf-token value)
+              (x-token value))))
+      
+      ;; ietf-token := <An extension token defined by a
+      ;; 	       standards-track RFC and registered
+      ;; 	       with IANA.>
+      (define ietf-token
+        (lambda (value)
+          (let ((ans (assoc (lowercase (trim-spaces value)) ietf-extensions)))
+            (and ans
+                 (cdr ans)))))
+      
+      ;;  Directly from RFC 1700:
+      ;; Type            Subtype         Description                 Reference
+      ;; ----            -------         -----------                 ---------
+      ;; text            plain                                   [RFC1521,NSB]
+      ;;                 richtext                                [RFC1521,NSB]
+      ;;                 tab-separated-values                   [Paul Lindner]
+      ;; 
+      ;; multipart       mixed                                   [RFC1521,NSB]
+      ;;                 alternative                             [RFC1521,NSB]
+      ;;                 digest                                  [RFC1521,NSB]
+      ;;                 parallel                                [RFC1521,NSB]
+      ;;                 appledouble                [MacMime,Patrik Faltstrom]
+      ;;                 header-set                             [Dave Crocker]
+      ;; 
+      ;; message         rfc822                                  [RFC1521,NSB]
+      ;;                 partial                                 [RFC1521,NSB]
+      ;;                 external-body                           [RFC1521,NSB]
+      ;;                 news                        [RFC 1036, Henry Spencer]
+      ;; 
+      ;; application     octet-stream                            [RFC1521,NSB]
+      ;;     		   postscript                              [RFC1521,NSB]
+      ;;     		   oda                                     [RFC1521,NSB]
+      ;;     		   atomicmail                           [atomicmail,NSB]
+      ;;     		   andrew-inset                       [andrew-inset,NSB]
+      ;;     		   slate                           [slate,terry crowley]
+      ;;     		   wita              [Wang Info Transfer,Larry Campbell]
+      ;;     		   dec-dx            [Digital Doc Trans, Larry Campbell]
+      ;;     		   dca-rft        [IBM Doc Content Arch, Larry Campbell]
+      ;;     		   activemessage                          [Ehud Shapiro]
+      ;;     		   rtf                                    [Paul Lindner]
+      ;;     		   applefile                  [MacMime,Patrik Faltstrom]
+      ;;     		   mac-binhex40               [MacMime,Patrik Faltstrom]
+      ;;     		   news-message-id              [RFC1036, Henry Spencer]
+      ;;     		   news-transmission            [RFC1036, Henry Spencer]
+      ;;     		   wordperfect5.1                         [Paul Lindner]
+      ;;     		   pdf                                    [Paul Lindner]
+      ;;     		   zip                                    [Paul Lindner]
+      ;;     		   macwriteii                             [Paul Lindner]
+      ;;     		   msword                                 [Paul Lindner]
+      ;;     		   remote-printing                         [RFC1486,MTR]
+      ;; 
+      ;; image           jpeg                                    [RFC1521,NSB]
+      ;;                 gif                                     [RFC1521,NSB]
+      ;;                 ief             Image Exchange Format       [RFC1314]
+      ;;                 tiff            Tag Image File Format           [MTR]
+      ;; 
+      ;; audio           basic                                   [RFC1521,NSB]
+      ;; 
+      ;; video           mpeg                                    [RFC1521,NSB]
+      ;;                 quicktime                              [Paul Lindner]
+      
+      
+      ;; x-token := <The two characters "X-" or "x-" followed, with
+      ;; 	    no intervening white space, by any token>
+      (define x-token
+        (lambda (value)
+          (let* ((r  #rx"^[xX]-(.*)")
+                 (h (trim-spaces value))
+                 (ans (regexp-match r h)))
+            (and ans
+                 (token (regexp-replace r h "\\1"))
+                 h))))
+      
+      ;; subtype := extension-token / iana-token
+      (define subtype
+        (lambda (value)
+          (if (not value)
+              (raise (make-empty-subtype))
+              (or (extension-token value)
+                  (iana-token value)))))
+      
+      ;; iana-token := <A publicly-defined extension token. Tokens
+      ;; 	       of this form must be registered with IANA
+      ;; 	       as specified in RFC 2048.>
+      (define iana-token
+        (lambda (value)
+          (let ((ans (assoc (lowercase (trim-spaces value)) iana-extensions)))
+            (and ans
+                 (cdr ans)))))
+      
+      ;; parameter := attribute "=" value
+      (define re:parameter (regexp "([^=]+)=(.+)"))
+      (define parameter
+        (lambda (par)
+          (let* ((r re:parameter)
+                 (att (attribute (regexp-replace r par "\\1")))
+                 (val (value (regexp-replace r par "\\2"))))
+            (if (regexp-match r par)
+		(cons (if att (lowercase att) "???") val)
+		(cons "???" par)))))
+      
+      ;; value := token / quoted-string
+      (define value
+        (lambda (val)
+          (or (token val)
+              (quoted-string val)
+	      val)))
+
+      ;; token := 1*<any (US-ASCII) CHAR except SPACE, CTLs,
+      ;; 	    or tspecials>
+      ;; tspecials :=  "(" / ")" / "<" / ">" / "@" /
+      ;; 	      "," / ";" / ":" / "\" / <">
+      ;; 	      "/" / "[" / "]" / "?" / "="
+      ;; 	      ; Must be in quoted-string,
+      ;; 	      ; to use within parameter values
+      (define token
+        (lambda (value)
+          (let* ((tspecials (regexp "[^][()<>@,;:\\\"/?= ]+"))
+                 (ans (regexp-match tspecials value)))
+            (and ans
+                 (string=? value (car ans))
+                 (car ans)))))
+      
+      ;; attribute := token
+      ;; 	     ; Matching of attributes
+      ;; 	     ; is ALWAYS case-insensitive.
+      (define attribute token)
+      
+      (define re:quotes (regexp "\"(.+)\""))
+      (define quoted-string
+        (lambda (str)
+          (let* ((quotes re:quotes)
+                 (ans (regexp-match quotes str)))
+            (and ans
+                 (regexp-replace quotes str "\\1")))))
+      
+      ;; disposition-parm := filename-parm
+      ;; 		     / creation-date-parm
+      ;; 		     / modification-date-parm
+      ;; 		     / read-date-parm
+      ;; 		     / size-parm
+      ;; 		     / parameter
+      ;; 
+      ;; filename-parm := "filename" "=" value
+      ;; 
+      ;; creation-date-parm := "creation-date" "=" quoted-date-time
+      ;; 
+      ;; modification-date-parm := "modification-date" "=" quoted-date-time
+      ;; 
+      ;; read-date-parm := "read-date" "=" quoted-date-time
+      ;; 
+      ;; size-parm := "size" "=" 1*DIGIT
+      (define disp-params
+        (lambda (lst disp)
+          (let loop ((lst lst))
+            (unless (null? lst)
+              (let* ((p (parameter (trim-all-spaces (car lst))))
+                     (parm (car p))
+                     (value (cdr p)))
+                (cond ((string=? parm "filename")
+                       (set-disposition-filename! disp value))
+                      ((string=? parm "creation-date")
+                       (set-disposition-creation!
+                        disp
+                        (disp-quoted-data-time value)))
+                      ((string=? parm "modification-date")
+                       (set-disposition-modification!
+                        disp
+                        (disp-quoted-data-time value)))
+                      ((string=? parm "read-date")
+                       (set-disposition-read!
+                        disp
+                        (disp-quoted-data-time value)))
+                      ((string=? parm "size")
+                       (set-disposition-size!
+                        disp
+                        (string->number value)))
+                      (else
+                       (set-disposition-params!
+                        disp
+                        (append (disposition-params disp) (list p)))))
+                (loop (cdr lst)))))))
+      
+      ;; date-time   =  [ day "," ] date time        ; dd mm yy
+      ;; 				   ;  hh:mm:ss zzz
+      ;; 
+      ;; day         =  "Mon"  / "Tue" /  "Wed"  / "Thu"
+      ;; 	    /  "Fri"  / "Sat" /  "Sun"
+      ;; 
+      ;; date        =  1*2DIGIT month 2DIGIT        ; day month year
+      ;; 				   ;  e.g. 20 Jun 82
+      ;; 
+      ;; month       =  "Jan"  /  "Feb" /  "Mar"  /  "Apr"
+      ;; 	    /  "May"  /  "Jun" /  "Jul"  /  "Aug"
+      ;; 	    /  "Sep"  /  "Oct" /  "Nov"  /  "Dec"
+      ;; 
+      ;; time        =  hour zone                    ; ANSI and Military
+      ;; 
+      ;; hour        =  2DIGIT ":" 2DIGIT [":" 2DIGIT]
+      ;; 				   ; 00:00:00 - 23:59:59
+      ;; 
+      ;; zone        =  "UT"  / "GMT"                ; Universal Time
+      ;; 				   ; North American : UT
+      ;; 	    /  "EST" / "EDT"                ;  Eastern:  - 5/ - 4
+      ;; 	    /  "CST" / "CDT"                ;  Central:  - 6/ - 5
+      ;; 	    /  "MST" / "MDT"                ;  Mountain: - 7/ - 6
+      ;; 	    /  "PST" / "PDT"                ;  Pacific:  - 8/ - 7
+      ;; 	    /  1ALPHA                       ; Military: Z = UT;
+      ;; 				   ;  A:-1; (J not used)
+      ;; 				   ;  M:-12; N:+1; Y:+12
+      ;; 	    / ( ("+" / "-") 4DIGIT )        ; Local differential
+      ;; 				   ;  hours+min. (HHMM)
+      (define date-time
+        (lambda (str)
+          ;; Fix Me: I have to return a date structure, or time in seconds.
+          str))
+      
+      ;; quoted-date-time := quoted-string
+      ;;		; contents MUST be an RFC 822 `date-time'
+      ;;		; numeric timezones (+HHMM or -HHMM) MUST be used
+      
+      (define disp-quoted-data-time date-time)
+      
+      )))
diff --git a/collects/net/mime-util.ss b/collects/net/mime-util.ss
new file mode 100644
index 0000000000..88b44102e2
--- /dev/null
+++ b/collects/net/mime-util.ss
@@ -0,0 +1,146 @@
+;;;
+;;; <mime-util.ss> ---- Extra utilities
+;;; Time-stamp: <01/05/07 17:41:12 solsona>
+;;;
+;;; Copyright (C) 2001 by Francisco Solsona. 
+;;;
+;;; This file is part of mime-plt.
+
+;;; mime-plt is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2.1 of the License, or (at your option) any later version.
+
+;;; mime-plt is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with mime-plt; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+;;; Author: Francisco Solsona <solsona@acm.org>
+;;
+;;
+;; Commentary:
+
+(module mime-util mzscheme
+  (require (lib "etc.ss"))
+
+  (provide string-tokenizer
+           trim-all-spaces
+           trim-spaces
+           trim-comments
+           lowercase
+           warning
+           cat)
+
+  ;; string-index returns the leftmost index in string s
+  ;; that has character c
+  (define string-index
+    (lambda (s c)
+      (let ((n (string-length s)))
+	(let loop ((i 0))
+	  (cond ((>= i n) #f)
+		((char=? (string-ref s i) c) i)
+		(else (loop (+ i 1))))))))
+
+  ;; string-tokenizer breaks string s into substrings separated by character c
+  (define string-tokenizer
+    (lambda (c s)
+      (let loop ((s s))
+	(if (string=? s "") '()
+	    (let ((i (string-index s c)))
+	      (if i (cons (substring s 0 i)
+			  (loop (substring s (+ i 1)
+					   (string-length s))))
+		  (list s)))))))
+
+  ;; Trim all spaces, except those in quoted strings.
+  (define re:quote-start (regexp "\""))
+  (define re:space (regexp "[ \t\n\r\v]"))
+  (define trim-all-spaces
+    (lambda (str)
+      ;; Break out alternate quoted and unquoted parts.
+      ;; Initial and final string are unquoted.
+      (let-values ([(unquoted quoted)
+		    (let loop ([str str][unquoted null][quoted null])
+		      (let ([m (regexp-match-positions re:quote-start str)])
+			(if m
+			    (let ([prefix (substring str 0 (caar m))]
+				  [rest (substring str (add1 (caar m)) (string-length str))])
+			      ;; Find closing quote
+			      (let ([m (regexp-match-positions re:quote-start rest)])
+				(if m
+				    (let ([inside (substring rest 0 (caar m))]
+					  [rest (substring rest (add1 (caar m)) (string-length rest))])
+				      (loop rest (cons prefix unquoted) (cons (format "\"~a\"" inside) quoted)))
+				    ;; No closing quote! 
+				    (loop "" (cons prefix unquoted) (cons (format "\"~a" rest) quoted)))))
+			    (values (reverse! (cons str unquoted)) (reverse! quoted)))))])
+          ;; Put the pieces back together, stripping spaces for unquoted parts:
+	  (apply
+	   string-append
+	   (let loop ([unquoted unquoted][quoted quoted])
+	     (let ([clean (regexp-replace* re:space (car unquoted) "")])
+	       (if (null? quoted)
+		   (list clean)
+		   (list* clean
+			  (car quoted)
+			  (loop (cdr unquoted) (cdr quoted))))))))))
+
+  ;; Only trims left and right spaces:
+  (define trim-spaces
+    (lambda (str)
+      (trim-right (trim-left str))))
+
+  (define re:left-spaces (regexp "^[ \t\r\n\v]+"))
+  (define trim-left
+    (lambda (str)
+      (regexp-replace re:left-spaces str "")))
+
+  (define re:right-spaces (regexp "[ \t\r\n\v]+$"))
+  (define trim-right
+    (lambda (str)
+      (regexp-replace re:right-spaces str "")))
+
+  (define re:comments (regexp "^[^\"]*(\"[^\"]*\")*[^\"]*(\\(.*\\))"))
+  (define trim-comments
+    (lambda (str)
+      (let* ((positions (regexp-match-positions re:comments str)))
+	(if positions
+	    (string-append (substring str 0 (caaddr positions))
+			   (substring str (cdaddr positions) (string-length str)))
+	    str))))
+
+  (define lowercase
+    (lambda (str)
+      (let loop ((out "") (rest str) (size (string-length str)))
+	(cond ((zero? size) out)
+	      (else
+	       (loop (string-append out (string
+					 (char-downcase
+					  (string-ref rest 0))))
+		     (substring rest 1 size)
+		     (sub1 size)))))))
+
+  (define warning void)
+#|
+    (lambda (msg . args)
+      (fprintf (current-error-port)
+	       (apply format (cons msg args)))
+      (newline (current-error-port))))
+|#
+
+  ;; Copies its input `in' to its ouput port if given, it uses
+  ;; current-output-port if out is not provided.
+  (define cat
+    (opt-lambda (in (out (current-output-port)))
+		(let loop ((ln (read-line in)))
+		  (unless (eof-object? ln)
+			  (fprintf out "~a~n" ln)
+			  (loop (read-line in))))))
+
+  )
+;;; mime-util.ss ends here
diff --git a/collects/net/mime.ss b/collects/net/mime.ss
new file mode 100644
index 0000000000..aa58c2b24b
--- /dev/null
+++ b/collects/net/mime.ss
@@ -0,0 +1,48 @@
+;;;
+;;; <mime.ss> ---- MIME support
+;;;
+;;; Copyright (C) 2002 by PLT. 
+;;; Copyright (C) 2001 by Wish Computing. 
+;;;
+;;; This file is part of mime
+
+;;; mime is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2, or (at your option)
+;;; any later version.
+
+;;; mime is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+
+;;; You should have received a copy of the GNU General Public License
+;;; along with mime; see the file COPYING.  If not, write to the
+;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;;; Boston, MA 02111-1307, USA.
+
+;;; Author: Francisco Solsona <solsona@acm.org>
+;;
+;;
+;; Commentary:
+
+(module mime mzscheme
+  (require (lib "unitsig.ss"))
+
+  (require "mime-sig.ss"
+           "mime-unit.ss"
+           "qp-sig.ss"
+           "qp.ss"
+           "base64-sig.ss"
+           "base64.ss"
+	   "head-sig.ss"
+	   "head.ss")
+
+  (define-values/invoke-unit/sig net:mime^
+    net:mime@
+    #f
+    net:base64^ net:qp^ net:head^)
+
+  (provide-signature-elements net:mime^))
+
+;;; mime.ss ends here
\ No newline at end of file
diff --git a/collects/net/nntp-sig.ss b/collects/net/nntp-sig.ss
new file mode 100644
index 0000000000..2fd7e4d470
--- /dev/null
+++ b/collects/net/nntp-sig.ss
@@ -0,0 +1,26 @@
+
+(module nntp-sig mzscheme
+  (require (lib "unitsig.ss"))
+
+  (provide net:nntp^)
+  
+  (define-signature net:nntp^
+    ((struct communicator (sender receiver server port))
+     connect-to-server connect-to-server* disconnect-from-server
+     authenticate-user open-news-group
+     head-of-message body-of-message
+     newnews-since generic-message-command
+     make-desired-header extract-desired-headers
+
+     (struct nntp ())
+     (struct unexpected-response (code text))
+     (struct bad-status-line (line))
+     (struct premature-close (communicator))
+     (struct bad-newsgroup-line (line))
+     (struct non-existent-group (group))
+     (struct article-not-in-group (article))
+     (struct no-group-selected ())
+     (struct article-not-found (article))
+     (struct authentication-rejected ()))))
+
+
diff --git a/collects/net/nntp-unit.ss b/collects/net/nntp-unit.ss
new file mode 100644
index 0000000000..199e73e00c
--- /dev/null
+++ b/collects/net/nntp-unit.ss
@@ -0,0 +1,338 @@
+(module nntp-unit mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "etc.ss"))
+
+  (require "nntp-sig.ss")
+
+  (provide net:nntp@)
+  (define net:nntp@
+    (unit/sig net:nntp^
+      (import)
+
+      ;; sender : oport
+      ;; receiver : iport
+      ;; server : string
+      ;; port : number
+
+      (define-struct communicator (sender receiver server port))
+
+      ;; code : number
+      ;; text : string
+      ;; line : string
+      ;; communicator : communicator
+      ;; group : string
+      ;; article : number
+
+      (define-struct (nntp exn) ())
+      (define-struct (unexpected-response nntp) (code text))
+      (define-struct (bad-status-line nntp) (line))
+      (define-struct (premature-close nntp) (communicator))
+      (define-struct (bad-newsgroup-line nntp) (line))
+      (define-struct (non-existent-group nntp) (group))
+      (define-struct (article-not-in-group nntp) (article))
+      (define-struct (no-group-selected nntp) ())
+      (define-struct (article-not-found nntp) (article))
+      (define-struct (authentication-rejected nntp) ())
+
+      ;; signal-error :
+      ;; (exn-args ... -> exn) x format-string x values ... ->
+      ;;   exn-args -> ()
+
+      ;; - throws an exception
+
+      (define signal-error
+	(lambda (constructor format-string . args)
+	  (lambda exn-args
+	    (raise (apply constructor
+			  (apply format format-string args)
+			  (current-continuation-marks)
+			  exn-args)))))
+
+      ;; default-nntpd-port-number :
+      ;; number
+
+      (define default-nntpd-port-number 119)
+
+      ;; connect-to-server*:
+      ;; input-port output-port -> communicator
+      
+      (define connect-to-server*
+	(case-lambda
+	  [(receiver sender) (connect-to-server* receiver sender "unspecified"
+			                         "unspecified")]
+	  [(receiver sender server-name port-number)
+	   (let ((communicator (make-communicator sender receiver server-name
+				                  port-number)))
+	     (let-values (((code response)
+			   (get-single-line-response communicator)))
+	       (case code
+		 [(201) communicator]
+		 ((200)
+		  communicator)
+		 (else
+		   ((signal-error make-unexpected-response
+		      "unexpected connection response: ~s ~s"
+		      code response)
+		    code response)))))]))
+      
+      ;; connect-to-server :
+      ;; string [x number] -> commnicator
+
+      (define connect-to-server
+	(opt-lambda (server-name (port-number default-nntpd-port-number))
+	  (let-values (((receiver sender)
+			(tcp-connect server-name port-number)))
+	    (connect-to-server* receiver sender server-name port-number))))
+
+      ;; close-communicator :
+      ;; communicator -> ()
+
+      (define close-communicator
+	(lambda (communicator)
+	  (close-input-port (communicator-receiver communicator))
+	  (close-output-port (communicator-sender communicator))))
+
+      ;; disconnect-from-server :
+      ;; communicator -> ()
+
+      (define disconnect-from-server
+	(lambda (communicator)
+	  (send-to-server communicator "QUIT")
+	  (let-values (((code response)
+			(get-single-line-response communicator)))
+	    (case code
+	      ((205)
+	       (close-communicator communicator))
+	      (else
+	       ((signal-error make-unexpected-response
+			      "unexpected dis-connect response: ~s ~s"
+			      code response)
+		code response))))))
+
+      ;; authenticate-user :
+      ;; communicator x user-name x password -> ()
+      ;; the password is not used if the server does not ask for it.
+
+      (define authenticate-user
+        (lambda (communicator user password)
+          (define (reject code response)
+            ((signal-error make-authentication-rejected
+                           "authentication rejected (~s ~s)"
+                           code response)))
+          (define (unexpected code response)
+            ((signal-error make-unexpected-response
+                           "unexpected response for authentication: ~s ~s"
+                           code response)
+             code response))
+          (send-to-server communicator "AUTHINFO USER ~a" user)
+          (let-values (((code response)
+                        (get-single-line-response communicator)))
+            (case code
+              ((281) (void)) ; server doesn't ask for a password
+              ((381)
+               (send-to-server communicator "AUTHINFO PASS ~a" password)
+               (let-values (((code response)
+                             (get-single-line-response communicator)))
+                 (case code
+                   ((281) (void)) ; done
+                   ((502) (reject code response))
+                   (else (unexpected code response)))))
+              ((502) (reject code response))
+              (else (reject code response)
+                    (unexpected code response))))))
+
+      ;; send-to-server :
+      ;; communicator x format-string x list (values) -> ()
+
+      (define send-to-server
+	(lambda (communicator message-template . rest)
+	  (apply fprintf (communicator-sender communicator)
+		 (string-append message-template "\r\n")
+		 rest)))
+
+      ;; parse-status-line :
+      ;; string -> number x string
+
+      (define parse-status-line
+	(lambda (line)
+          (if (eof-object? line)
+            ((signal-error make-bad-status-line "eof instead of a status line")
+             line)
+            (let ((match (cdr (or (regexp-match #rx"([0-9]+) (.*)" line)
+                                  ((signal-error make-bad-status-line
+                                                 "malformed status line: ~s" line)
+                                   line)))))
+              (values (string->number (car match))
+                      (cadr match))))))
+
+      ;; get-one-line-from-server :
+      ;; iport -> string
+
+      (define get-one-line-from-server
+	(lambda (server->client-port)
+	  (read-line server->client-port 'return-linefeed)))
+
+      ;; get-single-line-response :
+      ;; communicator -> number x string
+
+      (define get-single-line-response
+	(lambda (communicator)
+	  (let ((receiver (communicator-receiver communicator)))
+	    (let ((status-line (get-one-line-from-server receiver)))
+	      (parse-status-line status-line)))))
+
+      ;; get-rest-of-multi-line-response :
+      ;; communicator -> list (string)
+
+      (define get-rest-of-multi-line-response
+	(lambda (communicator)
+	  (let ((receiver (communicator-receiver communicator)))
+	    (let loop ()
+	      (let ((l (get-one-line-from-server receiver)))
+		(cond
+		 ((eof-object? l)
+		  ((signal-error make-premature-close
+				 "port prematurely closed during multi-line response")
+		   communicator))
+		 ((string=? l ".")
+		  '())
+		 ((string=? l "..")
+		  (cons "." (loop)))
+		 (else
+		  (cons l (loop)))))))))
+
+      ;; get-multi-line-response :
+      ;; communicator -> number x string x list (string)
+
+      ;; -- The returned values are the status code, the rest of the status
+      ;; response line, and the remaining lines.
+
+      (define get-multi-line-response
+	(lambda (communicator)
+	  (let ((receiver (communicator-receiver communicator)))
+	    (let ((status-line (get-one-line-from-server receiver)))
+	      (let-values (((code rest-of-line)
+			    (parse-status-line status-line)))
+		(values code rest-of-line (get-rest-of-multi-line-response)))))))
+
+      ;; open-news-group :
+      ;; communicator x string -> number x number x number
+
+      ;; -- The returned values are the number of articles, the first
+      ;; article number, and the last article number for that group.
+
+      (define open-news-group
+	(lambda (communicator group-name)
+          (send-to-server communicator "GROUP ~a" group-name)
+          (let-values (((code rest-of-line)
+                        (get-single-line-response communicator)))
+            (case code
+              ((211)
+               (let ((match (map string->number
+                                 (cdr
+                                  (or (regexp-match #rx"([0-9]+) ([0-9]+) ([0-9]+)" rest-of-line)
+                                      ((signal-error make-bad-newsgroup-line
+                                                     "malformed newsgroup open response: ~s"
+                                                     rest-of-line)
+                                       rest-of-line))))))
+                 (let ((number-of-articles (car match))
+                       (first-article-number (cadr match))
+                       (last-article-number (caddr match)))
+                   (values number-of-articles
+                           first-article-number
+                           last-article-number))))
+              ((411)
+               ((signal-error make-non-existent-group
+                              "group ~s does not exist on server ~s"
+                              group-name (communicator-server communicator))
+                group-name))
+              (else
+               ((signal-error make-unexpected-response
+                              "unexpected group opening response: ~s" code)
+                code rest-of-line))))))
+
+      ;; generic-message-command :
+      ;; string x number -> communicator x (number U string) -> list (string)
+
+      (define generic-message-command
+	(lambda (command ok-code)
+	  (lambda (communicator message-index)
+	    (send-to-server communicator (string-append command " ~a")
+			    (if (number? message-index)
+				(number->string message-index)
+				message-index))
+	    (let-values (((code response)
+			  (get-single-line-response communicator)))
+	      (if (= code ok-code)
+		  (get-rest-of-multi-line-response communicator)
+		  (case code
+		    ((423)
+		     ((signal-error make-article-not-in-group
+				    "article id ~s not in group" message-index)
+		      message-index))
+		    ((412)
+		     ((signal-error make-no-group-selected
+				    "no group selected")))
+		    ((430)
+		     ((signal-error make-article-not-found
+				    "no article id ~s found" message-index)
+		      message-index))
+		    (else
+		     ((signal-error make-unexpected-response
+				    "unexpected message access response: ~s" code)
+		      code response))))))))
+
+      ;; head-of-message :
+      ;; communicator x (number U string) -> list (string)
+
+      (define head-of-message
+	(generic-message-command "HEAD" 221))
+
+      ;; body-of-message :
+      ;; communicator x (number U string) -> list (string)
+
+      (define body-of-message
+	(generic-message-command "BODY" 222))
+
+      ;; newnews-since :
+      ;; communicator x (number U string) -> list (string)
+      
+      (define newnews-since
+        (generic-message-command "NEWNEWS" 230))
+
+      ;; make-desired-header :
+      ;; string -> desired
+
+      (define make-desired-header
+	(lambda (raw-header)
+	  (regexp
+	   (string-append
+	    "^"
+	    (list->string
+	     (apply append
+		    (map (lambda (c)
+			   (cond
+			    ((char-lower-case? c)
+			     (list #\[ (char-upcase c) c #\]))
+			    ((char-upper-case? c)
+			     (list #\[ c (char-downcase c) #\]))
+			    (else
+			     (list c))))
+			 (string->list raw-header))))
+	    ":"))))
+
+      ;; extract-desired-headers :
+      ;; list (string) x list (desired) -> list (string)
+
+      (define extract-desired-headers
+	(lambda (headers desireds)
+	  (let loop ((headers headers))
+	    (if (null? headers) null
+		(let ((first (car headers))
+		      (rest (cdr headers)))
+		  (if (ormap (lambda (matcher)
+			       (regexp-match matcher first))
+			     desireds)
+		      (cons first (loop rest))
+		      (loop rest))))))))))
+
diff --git a/collects/net/nntp.ss b/collects/net/nntp.ss
new file mode 100644
index 0000000000..57b2b25c4d
--- /dev/null
+++ b/collects/net/nntp.ss
@@ -0,0 +1,11 @@
+
+(module nntp mzscheme
+  (require (lib "unitsig.ss"))
+
+  (require "nntp-sig.ss")
+  (require "nntp-unit.ss")
+
+  (define-values/invoke-unit/sig net:nntp^
+    net:nntp@)
+
+  (provide-signature-elements net:nntp^))
diff --git a/collects/net/pop3-sig.ss b/collects/net/pop3-sig.ss
new file mode 100644
index 0000000000..3b0db30662
--- /dev/null
+++ b/collects/net/pop3-sig.ss
@@ -0,0 +1,27 @@
+
+(module pop3-sig mzscheme
+  (require (lib "unitsig.ss"))
+
+  (provide net:pop3^)
+  
+  (define-signature net:pop3^
+    ((struct communicator (sender receiver server port state))
+     connect-to-server connect-to-server* disconnect-from-server
+     authenticate/plain-text
+     get-mailbox-status
+     get-message/complete get-message/headers get-message/body
+     delete-message
+     get-unique-id/single get-unique-id/all
+     
+     make-desired-header extract-desired-headers
+
+     (struct pop3 ())
+     (struct cannot-connect ())
+     (struct username-rejected ())
+     (struct password-rejected ())
+     (struct not-ready-for-transaction (communicator))
+     (struct not-given-headers (communicator message))
+     (struct illegal-message-number (communicator message))
+     (struct cannot-delete-message (communicator message))
+     (struct disconnect-not-quiet (communicator))
+     (struct malformed-server-response (communicator)))))
diff --git a/collects/net/pop3-unit.ss b/collects/net/pop3-unit.ss
new file mode 100644
index 0000000000..46ed8064a3
--- /dev/null
+++ b/collects/net/pop3-unit.ss
@@ -0,0 +1,415 @@
+
+(module pop3-unit mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "etc.ss"))
+
+  (require "pop3-sig.ss")
+
+  (provide net:pop3@)
+  (define net:pop3@
+    (unit/sig net:pop3^
+      (import)
+
+      ;; Implements RFC 1939, Post Office Protocol - Version 3, Myers & Rose
+
+      ;; sender : oport
+      ;; receiver : iport
+      ;; server : string
+      ;; port : number
+      ;; state : symbol = (disconnected, authorization, transaction)
+
+      (define-struct communicator (sender receiver server port state))
+
+      (define-struct (pop3 exn) ())
+      (define-struct (cannot-connect pop3) ())
+      (define-struct (username-rejected pop3) ())
+      (define-struct (password-rejected pop3) ())
+      (define-struct (not-ready-for-transaction pop3) (communicator))
+      (define-struct (not-given-headers pop3) (communicator message))
+      (define-struct (illegal-message-number pop3) (communicator message))
+      (define-struct (cannot-delete-message exn) (communicator message))
+      (define-struct (disconnect-not-quiet pop3) (communicator))
+      (define-struct (malformed-server-response pop3) (communicator))
+
+      ;; signal-error :
+      ;; (exn-args ... -> exn) x format-string x values ... ->
+      ;;   exn-args -> ()
+
+      (define signal-error
+	(lambda (constructor format-string . args)
+	  (lambda exn-args
+	    (raise (apply constructor
+			  (string->immutable-string
+			   (apply format format-string args))
+			  (current-continuation-marks)
+			  exn-args)))))
+
+      ;; signal-malformed-response-error :
+      ;; exn-args -> ()
+
+      ;; -- in practice, it takes only one argument: a communicator.
+
+      (define signal-malformed-response-error
+	(signal-error make-malformed-server-response
+		      "malformed response from server"))
+
+      ;; confirm-transaction-mode :
+      ;; communicator x string -> ()
+
+      ;; -- signals an error otherwise.
+
+      (define confirm-transaction-mode
+	(lambda (communicator error-message)
+	  (unless (eq? (communicator-state communicator) 'transaction)
+	    ((signal-error make-not-ready-for-transaction error-message)
+	     communicator))))
+
+      ;; default-pop-port-number :
+      ;; number
+
+      (define default-pop-port-number 110)
+
+      (define-struct server-responses ())
+      (define-struct (+ok server-responses) ())
+      (define-struct (-err server-responses) ())
+
+      ;; connect-to-server*:
+      ;; input-port output-port -> communicator
+
+      (define connect-to-server*
+	(case-lambda
+	  [(receiver sender) (connect-to-server* receiver sender "unspecified" "unspecified")]
+	  [(receiver sender server-name port-number)
+	   (let ((communicator  (make-communicator sender receiver server-name port-number
+				  'authorization)))
+	     (let ((response (get-status-response/basic communicator)))
+	       (cond
+		 ((+ok? response) communicator)
+		 ((-err? response)
+		  ((signal-error make-cannot-connect
+		     "cannot connect to ~a on port ~a"
+		     server-name port-number))))))]))
+      
+      ;; connect-to-server :
+      ;; string [x number] -> communicator
+
+      (define connect-to-server
+	(opt-lambda (server-name (port-number default-pop-port-number))
+	  (let-values (((receiver sender) (tcp-connect server-name port-number)))
+	    (connect-to-server* receiver sender server-name port-number))))
+
+      ;; authenticate/plain-text :
+      ;; string x string x communicator -> ()
+
+      ;; -- if authentication succeeds, sets the communicator's state to
+      ;; transaction.
+
+      (define authenticate/plain-text
+	(lambda (username password communicator)
+	  (let ((sender (communicator-sender communicator)))
+	    (send-to-server communicator "USER ~a" username)
+	    (let ((status (get-status-response/basic communicator)))
+	      (cond
+	       ((+ok? status)
+		(send-to-server communicator "PASS ~a" password)
+		(let ((status (get-status-response/basic communicator)))
+		  (cond
+		   ((+ok? status)
+		    (set-communicator-state! communicator 'transaction))
+		   ((-err? status)
+		    ((signal-error make-password-rejected
+				   "password was rejected"))))))
+	       ((-err? status)
+		((signal-error make-username-rejected
+			       "username was rejected"))))))))
+
+      ;; get-mailbox-status :
+      ;; communicator -> number x number
+
+      ;; -- returns number of messages and number of octets.
+
+      (define get-mailbox-status
+        (lambda (communicator)
+          (confirm-transaction-mode
+           communicator
+           "cannot get mailbox status unless in transaction mode")
+          (send-to-server communicator "STAT")
+          (apply values
+                 (map string->number
+                      (let-values (((status result)
+                                    (get-status-response/match
+                                     communicator
+                                     #rx"([0-9]+) ([0-9]+)"
+                                     #f)))
+                        result)))))
+
+      ;; get-message/complete :
+      ;; communicator x number -> list (string) x list (string)
+
+      (define get-message/complete
+	(lambda (communicator message)
+	  (confirm-transaction-mode communicator
+				    "cannot get message headers unless in transaction state")
+	  (send-to-server communicator "RETR ~a" message)
+	  (let ((status (get-status-response/basic communicator)))
+	    (cond
+	     ((+ok? status)
+	      (split-header/body (get-multi-line-response communicator)))
+	     ((-err? status)
+	      ((signal-error make-illegal-message-number
+			     "not given message ~a" message)
+	       communicator message))))))
+
+      ;; get-message/headers :
+      ;; communicator x number -> list (string)
+
+      (define get-message/headers
+	(lambda (communicator message)
+	  (confirm-transaction-mode communicator
+				    "cannot get message headers unless in transaction state")
+	  (send-to-server communicator "TOP ~a 0" message)
+	  (let ((status (get-status-response/basic communicator)))
+	    (cond
+	     ((+ok? status)
+	      (let-values (((headers body)
+			    (split-header/body
+			     (get-multi-line-response communicator))))
+		headers))
+	     ((-err? status)
+	      ((signal-error make-not-given-headers
+			     "not given headers to message ~a" message)
+	       communicator message))))))
+
+      ;; get-message/body :
+      ;; communicator x number -> list (string)
+
+      (define get-message/body
+	(lambda (communicator message)
+	  (let-values (((headers body)
+			(get-message/complete communicator message)))
+	    body)))
+
+      ;; split-header/body :
+      ;; list (string) -> list (string) x list (string)
+
+      ;; -- returns list of headers and list of body lines.
+
+      (define split-header/body
+	(lambda (lines)
+	  (let loop ((lines lines) (header null))
+	    (if (null? lines)
+		(values (reverse header) null)
+		(let ((first (car lines))
+		      (rest (cdr lines)))
+		  (if (string=? first "")
+		      (values (reverse header) rest)
+		      (loop rest (cons first header))))))))
+
+      ;; delete-message :
+      ;; communicator x number -> ()
+
+      (define delete-message
+	(lambda (communicator message)
+	  (confirm-transaction-mode communicator
+				    "cannot delete message unless in transaction state")
+	  (send-to-server communicator "DELE ~a" message)
+	  (let ((status (get-status-response/basic communicator)))
+	    (cond
+	     ((-err? status)
+	      ((signal-error make-cannot-delete-message
+			     "no message numbered ~a available to be deleted" message)
+	       communicator message))
+	     ((+ok? status)
+	      'deleted)))))
+
+      ;; regexp for UIDL responses
+
+      (define uidl-regexp #rx"([0-9]+) (.*)")
+
+      ;; get-unique-id/single :
+      ;; communicator x number -> string
+
+      (define (get-unique-id/single communicator message)
+	(confirm-transaction-mode communicator
+				  "cannot get unique message id unless in transaction state")
+	(send-to-server communicator "UIDL ~a" message)
+	(let-values (((status result)
+		      (get-status-response/match communicator
+						 uidl-regexp
+						 ".*")))
+	  ;; The server response is of the form
+	  ;; +OK 2 QhdPYR:00WBw1Ph7x7
+	  (cond
+	   ((-err? status)
+	    ((signal-error make-illegal-message-number
+			   "no message numbered ~a available for unique id" message)
+	     communicator message))
+	   ((+ok? status)
+	    (cadr result)))))
+
+      ;; get-unique-id/all :
+      ;; communicator -> list(number x string)
+
+      (define (get-unique-id/all communicator)
+	(confirm-transaction-mode communicator
+				  "cannot get unique message ids unless in transaction state")
+	(send-to-server communicator "UIDL")
+	(let ((status (get-status-response/basic communicator)))
+	  ;; The server response is of the form
+	  ;; +OK
+	  ;; 1 whqtswO00WBw418f9t5JxYwZ
+	  ;; 2 QhdPYR:00WBw1Ph7x7
+	  ;; .
+	  (map (lambda (l)
+		 (let ((m (regexp-match uidl-regexp l)))
+		   (cons (string->number (cadr m)) (caddr m))))
+	       (get-multi-line-response communicator))))
+
+      ;; close-communicator :
+      ;; communicator -> ()
+
+      (define close-communicator
+	(lambda (communicator)
+	  (close-input-port (communicator-receiver communicator))
+	  (close-output-port (communicator-sender communicator))))
+
+      ;; disconnect-from-server :
+      ;; communicator -> ()
+
+      (define disconnect-from-server
+	(lambda (communicator)
+	  (send-to-server communicator "QUIT")
+	  (set-communicator-state! communicator 'disconnected)
+	  (let ((response (get-status-response/basic communicator)))
+	    (close-communicator communicator)
+	    (cond
+	     ((+ok? response) (void))
+	     ((-err? response)
+	      ((signal-error make-disconnect-not-quiet
+			     "got error status upon disconnect")
+	       communicator))))))
+
+      ;; send-to-server :
+      ;; communicator x format-string x list (values) -> ()
+
+      (define send-to-server
+	(lambda (communicator message-template . rest)
+	  (apply fprintf (communicator-sender communicator)
+		 (string-append message-template "\r\n")
+		 rest)
+	  (flush-output (communicator-sender communicator))))
+
+      ;; get-one-line-from-server :
+      ;; iport -> string
+
+      (define get-one-line-from-server
+	(lambda (server->client-port)
+	  (read-line server->client-port 'return-linefeed)))
+
+      ;; get-server-status-response :
+      ;; communicator -> server-responses x string
+
+      ;; -- provides the low-level functionality of checking for +OK
+      ;; and -ERR, returning an appropriate structure, and returning the
+      ;; rest of the status response as a string to be used for further
+      ;; parsing, if necessary.
+
+      (define get-server-status-response
+	(lambda (communicator)
+          (let* ((receiver (communicator-receiver communicator))
+                 (status-line (get-one-line-from-server receiver))
+                 (r (regexp-match #rx"^\\+OK(.*)" status-line)))
+            (if r
+              (values (make-+ok) (cadr r))
+              (let ((r (regexp-match #rx"^\\-ERR(.*)" status-line)))
+                (if r
+                  (values (make--err) (cadr r))
+                  (signal-malformed-response-error communicator)))))))
+
+      ;; get-status-response/basic :
+      ;; communicator -> server-responses
+
+      ;; -- when the only thing to determine is whether the response
+      ;; was +OK or -ERR.
+
+      (define get-status-response/basic
+	(lambda (communicator)
+	  (let-values (((response rest)
+			(get-server-status-response communicator)))
+	    response)))
+
+      ;; get-status-response/match :
+      ;; communicator x regexp x regexp -> (status x list (string))
+
+      ;; -- when further parsing of the status response is necessary.
+      ;; Strips off the car of response from regexp-match.
+
+      (define get-status-response/match
+	(lambda (communicator +regexp -regexp)
+	  (let-values (((response rest)
+			(get-server-status-response communicator)))
+	    (if (and +regexp (+ok? response))
+		(let ((r (regexp-match +regexp rest)))
+		  (if r (values response (cdr r))
+		      (signal-malformed-response-error communicator)))
+		(if (and -regexp (-err? response))
+		    (let ((r (regexp-match -regexp rest)))
+		      (if r (values response (cdr r))
+			  (signal-malformed-response-error communicator)))
+		    (signal-malformed-response-error communicator))))))
+
+      ;; get-multi-line-response :
+      ;; communicator -> list (string)
+
+      (define get-multi-line-response
+	(lambda (communicator)
+	  (let ((receiver (communicator-receiver communicator)))
+	    (let loop ()
+	      (let ((l (get-one-line-from-server receiver)))
+		(cond
+		 ((eof-object? l)
+		  (signal-malformed-response-error communicator))
+		 ((string=? l ".")
+		  '())
+		 ((and (> (string-length l) 1)
+		       (char=? (string-ref l 0) #\.))
+		  (cons (substring l 1 (string-length l)) (loop)))
+		 (else
+		  (cons l (loop)))))))))
+
+      ;; make-desired-header :
+      ;; string -> desired
+
+      (define make-desired-header
+	(lambda (raw-header)
+	  (regexp
+	   (string-append
+	    "^"
+	    (list->string
+	     (apply append
+		    (map (lambda (c)
+			   (cond
+			    ((char-lower-case? c)
+			     (list #\[ (char-upcase c) c #\]))
+			    ((char-upper-case? c)
+			     (list #\[ c (char-downcase c) #\]))
+			    (else
+			     (list c))))
+			 (string->list raw-header))))
+	    ":"))))
+
+      ;; extract-desired-headers :
+      ;; list (string) x list (desired) -> list (string)
+
+      (define extract-desired-headers
+	(lambda (headers desireds)
+	  (let loop ((headers headers))
+	    (if (null? headers) null
+		(let ((first (car headers))
+		      (rest (cdr headers)))
+		  (if (ormap (lambda (matcher)
+			       (regexp-match matcher first))
+			     desireds)
+		      (cons first (loop rest))
+		      (loop rest))))))))))
+
diff --git a/collects/net/pop3.ss b/collects/net/pop3.ss
new file mode 100644
index 0000000000..e625094901
--- /dev/null
+++ b/collects/net/pop3.ss
@@ -0,0 +1,36 @@
+
+(module pop3 mzscheme
+  (require (lib "unitsig.ss"))
+
+  (require "pop3-sig.ss")
+  (require "pop3-unit.ss")
+
+  (define-values/invoke-unit/sig net:pop3^
+    net:pop3@)
+
+  (provide-signature-elements net:pop3^))
+
+#|
+
+> (require-library "pop3.ss" "net")
+> (define c (connect-to-server "cs.rice.edu"))
+> (authenticate/plain-text "scheme" "********" c)
+> (get-mailbox-status c)
+100
+177824
+> (get-message/headers c 100)
+("Date: Thu, 6 Nov 1997 12:34:18 -0600 (CST)"
+ "Message-Id: <199711061834.MAA11961@new-world.cs.rice.edu>"
+ "From: Shriram Krishnamurthi <shriram@cs.rice.edu>"
+ ...
+ "Status: RO")
+> (get-message/complete  c 100)
+("Date: Thu, 6 Nov 1997 12:34:18 -0600 (CST)"
+ "Message-Id: <199711061834.MAA11961@new-world.cs.rice.edu>"
+ "From: Shriram Krishnamurthi <shriram@cs.rice.edu>"
+ ...
+ "Status: RO")
+("some body" "text" "goes" "." "here" "." "")
+> (disconnect-from-server c)
+
+|#
diff --git a/collects/net/private/rbtree.ss b/collects/net/private/rbtree.ss
new file mode 100644
index 0000000000..ae70d18855
--- /dev/null
+++ b/collects/net/private/rbtree.ss
@@ -0,0 +1,387 @@
+
+;; Two variants of red-black trees.
+
+;; In the expunge variant, each node stores the count of nodes in its
+;; left branch. A nodes' value corresponds to a pre-delete index, and
+;; subtracting the right-branch count produces a post-delete index
+;; (i.e., as if all deleteions for earlier pre-delete indices happened
+;; first).  Inserting into the tree provides a post-delete index, so
+;; the insert must use the left-branch count to compare the node's
+;; pre-delete index to the given post-delete index. Rotations to
+;; maintain the red-black property can locally update the left-branch
+;; count stored in the rotated nodes. It's not possible to insert the
+;; same pre-delete index twice, since insertion uses the post-delete
+;; index.
+
+;; In the fetch variant, each node's value is a list, where the first
+;; number in the list is the key. But for a right branch, all keys are
+;; decremented by the node's key (recursively). This allows a ln-time
+;; shift operation when a message is expunged.
+
+(module rbtree mzscheme
+  (provide new-tree tree-empty?
+	   expunge-insert! expunge-tree->list
+	   fetch-insert! fetch-find fetch-delete! fetch-shift! fetch-tree->list)
+
+  (define-struct tree (v red? left-count left right parent) (make-inspector))
+
+  (define (new-tree)
+    (make-tree 'pre-root #f 0 #f #f #f))
+
+  (define (tree-empty? t)
+    (not (tree-left t)))
+
+  (define (k+ a b)
+    (cons (+ (car a) (if (number? b) b (car b)))
+	  (cdr a)))
+  (define (k- a b)
+    (cons (- (car a) (if (number? b) b (car b)))
+	  (cdr a)))
+  (define kv car)
+
+  (define (mk-insert sort-to-left? sort=? right+ 
+		     left-insert-adjust!
+		     left-rotate-adjust! right-rotate-adjust!)
+    (define-values (rotate-left! rotate-right!)
+      (let ([mk
+	     (lambda (tree-west tree-east set-tree-west! set-tree-east! adj-count!)
+	       (lambda (t)
+		 (let ([old-east (tree-east t)])
+		   (let ([r (tree-west old-east)])
+		     (set-tree-east! t r)
+		     (when r
+		       (set-tree-parent! r t)))
+		   (let ([p (tree-parent t)])
+		     (set-tree-parent! old-east p)
+		     (if (eq? t (tree-left p))
+			 (set-tree-left! p old-east)
+			 (set-tree-right! p old-east)))
+		   (set-tree-west! old-east t)
+		   (set-tree-parent! t old-east)
+		   (adj-count! t old-east))))])
+	(values (mk tree-left tree-right set-tree-left! set-tree-right!
+		    left-rotate-adjust!)
+		(mk tree-right tree-left set-tree-right! set-tree-left!
+		    right-rotate-adjust!))))
+
+    (values
+     ;; insert
+     (lambda (pre-root n)
+       (let ([new
+	      ;; Insert:
+	      (let loop ([t (tree-left pre-root)] 
+			 [n n] 
+			 [parent pre-root] 
+			 [set-child! (lambda (t v)
+				       (set-tree-left! pre-root v))])
+		(cond
+		 [(not t) (let ([new (make-tree n #t 0 #f #f parent)])
+			    (set-child! parent new)
+			    new)]
+		 [(sort=? n t)
+		  (set-tree-v! t n)
+		  pre-root]
+		 [(sort-to-left? n t)
+		  (left-insert-adjust! t)
+		  (loop (tree-left t) n t set-tree-left!)]
+		 [else
+		  (loop (tree-right t) (right+ n t) t set-tree-right!)]))])
+	 ;; Restore red-black property:
+	 (let loop ([v new])
+	   (let ([p (tree-parent v)])
+	     (when (and p (tree-red? p))
+	       (let ([gp (tree-parent p)])
+		 (let-values ([(tree-west tree-east rotate-west! rotate-east!)
+			       (if (eq? p (tree-left gp))
+				   (values tree-left tree-right rotate-left! rotate-right!)
+				   (values tree-right tree-left rotate-right! rotate-left!))])
+		   (let ([uncle (tree-east (tree-parent p))])
+		     (if (and uncle (tree-red? uncle))
+			 (begin
+			   (set-tree-red?! p #f)
+			   (set-tree-red?! uncle #f)
+			   (set-tree-red?! gp #t)
+			   (loop gp))
+			 (let ([finish (lambda (v)
+					 (let* ([p (tree-parent v)]
+						[gp (tree-parent p)])
+					   (set-tree-red?! p #f)
+					   (set-tree-red?! gp #t)
+					   (rotate-east! gp)
+					   (loop gp)))])
+			   (if (eq? v (tree-east p))
+			       (begin
+				 (rotate-west! p)
+				 (finish p))
+			       (finish v))))))))))
+	 (set-tree-red?! (tree-left pre-root) #f)))
+
+     ;; delete (fetch only)
+     (lambda (pre-root n)
+       (let ([orig-t (fetch-find-node pre-root n)])
+	 (when orig-t
+	   ;; Delete note t if it has at most one child.
+	   ;; Otherwise, move a leaf's data to here, and
+	   ;; delete the leaf.
+	   (let ([t (if (and (tree-left orig-t)
+			     (tree-right orig-t))
+			(let loop ([t (tree-right orig-t)])
+			  (if (tree-left t)
+			      (loop (tree-left t))
+			      t))
+			orig-t)])
+	     (unless (eq? t orig-t)
+	       ;; Swap out:
+	       (let ([delta (kv (tree-v t))])
+		 (set-tree-v! orig-t (k+ (tree-v t) (tree-v orig-t)))
+		 (let loop ([c (tree-right orig-t)])
+		   (when c
+		     (set-tree-v! c (k- (tree-v c) delta))
+		     (loop (tree-left c))))))
+	     ;; Now we can delete t:
+	     (let ([child-t (or (tree-left t)
+				(tree-right t))]
+		   [p (tree-parent t)])
+	       (when child-t
+		 (set-tree-parent! child-t p)
+		 ;; Adjust relative index of left spine of the
+		 ;;  right branch (in the case that there was only
+		 ;;  a right branch)
+		 (let loop ([c (tree-right t)])
+		   (when c
+		     (set-tree-v! c (k+ (tree-v c) (tree-v t)))
+		     (loop (tree-left c)))))
+	       (if (eq? (tree-left p) t) 
+		   (set-tree-left! p child-t)
+		   (set-tree-right! p child-t))
+	       ;; Restore red-black property:
+	       (when (not (tree-red? t))
+		 (let loop ([c child-t] [p p])
+		   (cond
+		    [(and c (tree-red? c)) (set-tree-red?! c #f)]
+		    [(tree-parent p)
+		     (let-values ([(tree-west tree-east rotate-west! rotate-east!)
+				   (if (eq? c (tree-left p))
+				       (values tree-left tree-right rotate-left! rotate-right!)
+				       (values tree-right tree-left rotate-right! rotate-left!))])
+		       (let ([sibling (tree-east p)])
+			 (let ([z (if (tree-red? sibling)
+				      (begin
+					(set-tree-red?! sibling #f)
+					(set-tree-red?! p #t)
+					(rotate-west! p)
+					(tree-east p))
+				      sibling)])
+			   (if (not (or (and (tree-west z)
+					     (tree-red? (tree-west z)))
+					(and (tree-east z)
+					     (tree-red? (tree-east z)))))
+			       (begin
+				 (set-tree-red?! z #t)
+				 (loop p (tree-parent p)))
+			       (let ([w (if (not (and (tree-east z)
+						      (tree-red? (tree-east z))))
+					    (begin
+					      (set-tree-red?! (tree-west z) #f)
+					      (set-tree-red?! z #t)
+					      (rotate-east! z)
+					      (tree-east p))
+					    z)])
+				 (set-tree-red?! w (tree-red? p))
+				 (set-tree-red?! p #f)
+				 (set-tree-red?! (tree-east w) #f)
+				 (rotate-west! p))))))]))))))))))
+
+  (define-values (expunge-insert! ---)
+    (mk-insert 
+     ;; sort-to-left?
+     (lambda (n t)
+       ((+ n (tree-left-count t)) . < . (tree-v t)))
+     ;; sort=?
+     (lambda (n t) #f)
+     ;; right+
+     (lambda (n t)
+       (+ n 1 (tree-left-count t)))
+     ;; left-insert-adjust!
+     (lambda (t)
+       (set-tree-left-count! t (add1 (tree-left-count t))))
+     ;; left-rotate-adjust!
+     (lambda (t old-right)
+       (set-tree-left-count! old-right (+ 1 
+					  (tree-left-count old-right)
+					  (tree-left-count t))))
+     ;; right-rotate-adjust!
+     (lambda (t old-left)
+       (set-tree-left-count! t (- (tree-left-count t)
+				  (tree-left-count old-left)
+				  1)))))
+
+  (define-values (fetch-insert! fetch-delete!)
+    (mk-insert
+     ;; sort-to-left?
+     (lambda (n t)
+       ((kv n) . < . (kv (tree-v t))))
+     ;; sort=?
+     (lambda (n t)
+       (= (kv n) (kv (tree-v t))))
+     ;; right+
+     (lambda (n t)
+       (k- n (tree-v t)))
+     ;; left-insert-adjust!
+     void
+     ;; left-rotate-adjust!
+     (lambda (t old-right)
+       (set-tree-v! old-right (k+ (tree-v old-right)
+				  (tree-v t))))
+     ;; right-rotate-adjust!
+     (lambda (t old-left)
+       (set-tree-v! t (k- (tree-v t)
+			  (tree-v old-left))))))
+  
+  (define (expunge-tree->list pre-root)
+    (let loop ([t (tree-left pre-root)])
+      (if t
+	  (append (loop (tree-left t))
+		  (list (tree-v t))
+		  (loop (tree-right t)))
+	  null)))
+
+  (define (fetch-find-node pre-root n)
+    (let loop ([t (tree-left pre-root)]
+	       [n n])
+      (and t
+	   (cond
+	    [(= n (kv (tree-v t))) t]
+	    [(< n (kv (tree-v t))) (loop (tree-left t) n)]
+	    [else (loop (tree-right t) (- n (kv (tree-v t))))]))))
+
+  (define (fetch-find pre-root n)
+    (let ([t (fetch-find-node pre-root n)])
+      (and t (tree-v t))))
+
+  (define (fetch-shift! pre-root n)
+    (fetch-delete! pre-root n)
+    (let loop ([t (tree-left pre-root)]
+	       [n n])
+      (when t
+	(if (n . < . (kv (tree-v t)))
+	    (begin
+	      (set-tree-v! t (k- (tree-v t) 1))
+	      (loop (tree-left t) n))
+	    (loop (tree-right t)
+		  (- n (kv (tree-v t))))))))
+
+  (define (fetch-tree->list pre-root)
+    (let loop ([t (tree-left pre-root)][d 0])
+      (if t
+	  (append (loop (tree-left t) d)
+		  (list (k+ (tree-v t) d))
+		  (loop (tree-right t) (+ d (kv (tree-v t)))))
+	  null))))
+
+#|
+
+Tests:
+
+(require rbtree)
+(require (lib "pretty.ss"))
+(print-struct #t)
+
+(define t (new-tree))
+(define (test n v)
+  (expunge-insert! t n)
+  (unless (equal? (expunge-tree->list t) v)
+    (error 'bad "~s != ~s" (tree->list t) v)))
+
+(test 12 '(12))
+(test 8 '(8 12))
+(test 1 '(1 8 12))
+
+(define t (new-tree))
+
+(test 10 '(10))
+(test 8 '(8 10))
+(test 10 '(8 10 12))
+(test 8 '(8 9 10 12))
+(test 8 '(8 9 10 11 12))
+(test 100 '(8 9 10 11 12 105))
+(test 1 '(1 8 9 10 11 12 105))
+(test 105 '(1 8 9 10 11 12 105 112))
+(test 99 '(1 8 9 10 11 12 105 106 112))
+(test 2 '(1 3 8 9 10 11 12 105 106 112))
+(test 6 '(1 3 8 9 10 11 12 13 105 106 112))
+(test 5 '(1 3 7 8 9 10 11 12 13 105 106 112))
+(test 15 '(1 3 7 8 9 10 11 12 13 24 105 106 112))
+(test 15 '(1 3 7 8 9 10 11 12 13 24 25 105 106 112))
+(test 15 '(1 3 7 8 9 10 11 12 13 24 25 26 105 106 112))
+
+(define t (new-tree))
+(define (test n v)
+  (cond
+   [(< n 0) (fetch-delete! t (- n))]
+   [(inexact? n) (fetch-shift! t (inexact->exact n))]
+   [else (fetch-insert! t (list n))])
+  (printf "Check ~a~n" v)
+  (let ([v (map list v)])
+    (unless (equal? (fetch-tree->list t) v)
+      (error 'bad "~s != ~s" (fetch-tree->list t) v))))
+
+(test 10 '(10))
+(test 12 '(10 12))
+(test 8 '(8 10 12))
+(test 10 '(8 10 12))
+(test -10 '(8 12))
+(test -10 '(8 12))
+(test 10.0 '(8 11))
+(test 100.0 '(8 11))
+(test 5.0 '(7 10))
+(test 1 '(1 7 10))
+(test 2 '(1 2 7 10))
+(test 3 '(1 2 3 7 10))
+(test 4 '(1 2 3 4 7 10))
+(test 5 '(1 2 3 4 5 7 10))
+(test 6 '(1 2 3 4 5 6 7 10))
+(test -6 '(1 2 3 4 5 7 10))
+(test -5 '(1 2 3 4 7 10))
+(test -4 '(1 2 3 7 10))
+(test -3 '(1 2 7 10))
+(test -2 '(1 7 10))
+(test -7 '(1 10))
+(test -1 '(10))
+(test -10 '())
+
+(define (in-all-positions n l)
+  (if (null? l)
+      (list (list n))
+      (cons
+       (cons n l)
+       (map (lambda (r) (cons (car l) r))
+	    (in-all-positions n (cdr l))))))
+
+(define (permutations l)
+  (if (or (null? l)
+	  (null? (cdr l)))
+      (list l)
+      (apply
+       append
+       (map (lambda (lol)
+	      (in-all-positions (car l) lol))
+	    (permutations (cdr l))))))
+
+(define perms (permutations '(1 2 3 4 5 6 7 8)))
+
+(for-each (lambda (l)
+	    (let ([t (new-tree)])
+	      (for-each (lambda (i)
+			  (fetch-insert! t (list i)))
+			l)
+	      (unless (equal? (fetch-tree->list t) '((1) (2) (3) (4) (5) (6) (7) (8)))
+		(error 'perms "bad: ~a" l))
+	      (for-each (lambda (i)
+			  (fetch-delete! t i))
+			l)
+	      (unless (equal? (fetch-tree->list t) '())
+		(error 'perms "remove bad: ~a" l))))
+	  perms)
+
+|#
diff --git a/collects/net/qp-sig.ss b/collects/net/qp-sig.ss
new file mode 100644
index 0000000000..c381844145
--- /dev/null
+++ b/collects/net/qp-sig.ss
@@ -0,0 +1,17 @@
+(module qp-sig mzscheme
+  (require (lib "unitsig.ss"))
+  
+  (provide net:qp^)
+  (define-signature net:qp^
+    (
+     ;; -- exceptions raised --
+     (struct qp-error () -setters (- make-qp-error))
+     (struct qp-wrong-input () -setters (- make-qp-wrong-input))
+     (struct qp-wrong-line-size (size) -setters (- make-qp-wrong-line-size))
+     
+     ;; -- qp methods --
+     qp-encode
+     qp-decode
+     qp-encode-stream
+     qp-decode-stream
+     )))
diff --git a/collects/net/qp-unit.ss b/collects/net/qp-unit.ss
new file mode 100644
index 0000000000..b02c37ac86
--- /dev/null
+++ b/collects/net/qp-unit.ss
@@ -0,0 +1,176 @@
+;;;
+;;; <qp-unit.ss> ---- Quoted Printable Implementation
+;;;
+;;; Copyright (C) 2002 by PLT. 
+;;; Copyright (C) 2001 by Francisco Solsona. 
+;;;
+;;; This file was part of mime-plt.
+
+;;; mime-plt is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2.1 of the License, or (at your option) any later version.
+
+;;; mime-plt is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with mime-plt; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+;;; Author: Francisco Solsona <solsona@acm.org>
+;;
+;;
+;; Commentary:
+
+(module qp-unit mzscheme
+  (require "qp-sig.ss"
+           (lib "unitsig.ss")
+           (lib "etc.ss"))
+
+  (provide net:qp@)
+  (define net:qp@
+    (unit/sig net:qp^
+      (import)
+      
+      ;; Exceptions:
+      ;; String or input-port expected:
+      (define-struct qp-error ())
+      (define-struct (qp-wrong-input qp-error) ())
+      (define-struct (qp-wrong-line-size qp-error) (size))
+      
+      ;; qp-encode : bytes -> bytes
+      ;; returns the quoted printable representation of STR.
+      (define qp-encode
+        (lambda (str)
+          (let ((out (open-output-bytes)))
+            (qp-encode-stream (open-input-bytes str) out #"\r\n")
+            (get-output-bytes out))))
+      
+      ;; qp-decode : string -> string
+      ;; returns STR unqp.
+      (define qp-decode
+        (lambda (str)
+          (let ((out (open-output-bytes)))
+            (qp-decode-stream (open-input-bytes str) out)
+            (get-output-bytes out))))
+      
+      (define qp-decode-stream
+        (lambda (in out)
+	  (let loop ((ch (read-byte in)))
+	    (unless (eof-object? ch)
+	      (case ch
+		((61) ;; A "=", which is quoted-printable stuff
+		 (let ((next (read-byte in)))
+		   (cond 
+		    ((eq? next 10)
+		     ;; Soft-newline -- drop it
+		     (void))
+		    ((eq? next 13)
+		     ;; Expect a newline for a soft CRLF...
+		     (let ((next-next (read-byte in)))
+		       (if (eq? next-next 10)
+			   ;; Good.
+			   (loop (read-byte in))
+			   ;; Not a LF? Well, ok.
+			   (loop next-next))))
+		    ((hex-digit? next)
+		     (let ((next-next (read-byte in)))
+		       (cond ((eof-object? next-next)
+			      (warning "Illegal qp sequence: `=~a'" next)
+			      (display "=" out)
+			      (display next out))
+			     ((hex-digit? next-next)
+			      ;; qp-encoded
+			      (write-byte (hex-bytes->byte next next-next)
+					  out))
+			     (else
+			      (warning "Illegal qp sequence: `=~a~a'" next next-next)
+			      (write-byte 61 out)
+			      (write-byte next out)
+			      (write-byte next-next out)))))
+		    (else
+		     ;; Warning: invalid
+		     (warning "Illegal qp sequence: `=~a'" next)
+		     (write-byte 61 out)
+		     (write-byte next out)))
+		   (loop (read-byte in))))
+		(else
+		 (write-byte ch out)
+		 (loop (read-byte in))))))))
+      
+      (define warning
+        (lambda (msg . args)
+	  (when #f
+	    (fprintf (current-error-port)
+		     (apply format msg args))
+	    (newline (current-error-port)))))
+
+      (define (hex-digit? i)
+	(vector-ref hex-values i))
+
+      (define hex-bytes->byte
+        (lambda (b1 b2)
+	  (+ (* 16 (vector-ref hex-values b1))
+	     (vector-ref hex-values b2))))
+
+      (define write-hex-bytes
+        (lambda (byte p)
+	  (write-byte 61 p)
+	  (write-byte (vector-ref hex-bytes (arithmetic-shift byte -4)) p)
+	  (write-byte (vector-ref hex-bytes (bitwise-and byte 15)) p)))
+      
+      (define re:blanks #rx#"[ \t]+$")
+      
+      (define qp-encode-stream
+        (opt-lambda (in out [newline-string #"\n"])
+          (let loop ([col 0])
+	    (if (= col 75)
+		(begin
+		  ;; Soft newline:
+		  (write-byte 61 out)
+		  (display newline-string out)
+		  (loop 0))
+		(let ([i (read-byte in)])
+		  (cond
+		   [(eof-object? i) (void)]
+		   [(or (= i 10) (= i 13))
+		    (write-byte i out)
+		    (loop 0)]
+		   [(or (<= 33 i 60) (<= 62 i 126)
+			(and (or (= i 32) (= i 9)) 
+			     (not (let ([next (peek-byte in)])
+				    (or (eof-object? next) (= next 10) (= next 13))))))
+		    ;; single-byte mode:
+		    (write-byte i out)
+		    (loop (add1 col))]
+		   [(>= col 73)
+		    ;; need a soft newline first
+		    (write-byte 61 out)
+		    (display newline-string out)
+		    ;; now the octect
+		    (write-hex-bytes i out)
+		    (loop 3)]
+		   [else
+		    ;; an octect
+		    (write-hex-bytes i out)
+		    (loop (+ col 3))]))))))
+
+      ;; Tables
+      (define hex-values (make-vector 256 #f))
+      (define hex-bytes (make-vector 16))
+      (let loop ([i 0])
+	(unless (= i 10)
+	  (vector-set! hex-values (+ i 48) i)
+	  (vector-set! hex-bytes i (+ i 48))
+	  (loop (add1 i))))
+      (let loop ([i 0])
+	(unless (= i 6)
+	  (vector-set! hex-values (+ i 65) (+ 10 i))
+	  (vector-set! hex-values (+ i 97) (+ 10 i))
+	  (vector-set! hex-bytes (+ 10 i) (+ i 65))
+	  (loop (add1 i)))))))
+
+;;; qp-unit.ss ends here
diff --git a/collects/net/qp.ss b/collects/net/qp.ss
new file mode 100644
index 0000000000..5c050b4e13
--- /dev/null
+++ b/collects/net/qp.ss
@@ -0,0 +1,39 @@
+;;;
+;;; <qp.ss> ---- Quoted Printable Encoding/Decoding
+;;;
+;;; Copyright (C) 2002 by PLT. 
+;;; Copyright (C) 2001 by Francisco Solsona. 
+;;;
+;;; This file is part of mime-plt.
+
+;;; mime-plt is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2.1 of the License, or (at your option) any later version.
+
+;;; mime-plt is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with mime-plt; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+;;; Author: Francisco Solsona <solsona@acm.org>
+;;
+;;
+;; Commentary:
+
+(module qp mzscheme
+  (require (lib "unitsig.ss"))
+
+  (require "qp-sig.ss")
+  (require "qp-unit.ss")
+
+  (define-values/invoke-unit/sig net:qp^
+    net:qp@)
+
+  (provide-signature-elements net:qp^))
+
+;;; qp.ss ends here
\ No newline at end of file
diff --git a/collects/net/sendmail-sig.ss b/collects/net/sendmail-sig.ss
new file mode 100644
index 0000000000..f3ce211da7
--- /dev/null
+++ b/collects/net/sendmail-sig.ss
@@ -0,0 +1,11 @@
+
+(module sendmail-sig mzscheme
+  (require (lib "unitsig.ss"))
+
+  (provide net:sendmail^)
+  
+  (define-signature net:sendmail^
+    (send-mail-message/port
+     send-mail-message
+     (struct no-mail-recipients ()))))
+
diff --git a/collects/net/sendmail-unit.ss b/collects/net/sendmail-unit.ss
new file mode 100644
index 0000000000..b3cc5d700c
--- /dev/null
+++ b/collects/net/sendmail-unit.ss
@@ -0,0 +1,124 @@
+
+(module sendmail-unit mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "process.ss"))
+
+  (require "sendmail-sig.ss")
+
+  (provide net:sendmail@)
+  (define net:sendmail@
+    (unit/sig net:sendmail^
+      (import)
+
+      (define-struct (no-mail-recipients exn) ())
+
+      (define sendmail-search-path
+	'("/usr/lib" "/usr/sbin"))
+
+      (define sendmail-program-file
+	(if (or (eq? (system-type) 'unix)
+                (eq? (system-type) 'macosx))
+	    (let loop ((paths sendmail-search-path))
+	      (if (null? paths)
+		  (raise (make-exn:fail:unsupported
+			  "unable to find sendmail on this Unix variant"
+			  (current-continuation-marks)))
+		  (let ((p (build-path (car paths) "sendmail")))
+		    (if (and (file-exists? p)
+			     (memq 'execute (file-or-directory-permissions p)))
+			p
+			(loop (cdr paths))))))
+	    (raise (make-exn:fail:unsupported
+		    "sendmail only available under Unix"
+		    (current-continuation-marks)))))
+
+      ;; send-mail-message/port :
+      ;; string x string x list (string) x list (string) x list (string) 
+      ;;   [x list (string)] -> oport
+
+      ;; -- sender can be anything, though spoofing is not recommended.
+      ;; The recipients must all be pure email addresses.  Note that
+      ;; everything is expected to follow RFC conventions.  If any other
+      ;; headers are specified, they are expected to be completely
+      ;; formatted already.  Clients are urged to use close-output-port on
+      ;; the port returned by this procedure as soon as the necessary text
+      ;; has been written, so that the sendmail process can complete.
+
+      (define send-mail-message/port 
+	(lambda (sender subject to-recipients cc-recipients bcc-recipients
+			. other-headers)
+	  (when (and (null? to-recipients) (null? cc-recipients)
+		     (null? bcc-recipients))
+	    (raise (make-no-mail-recipients
+		    "no mail recipients were specified"
+		    (current-continuation-marks))))
+	  (let ((return (apply process* sendmail-program-file "-i"
+			       (append to-recipients cc-recipients bcc-recipients))))
+	    (let ((reader (car return))
+		  (writer (cadr return))
+		  (pid (caddr return))
+		  (error-reader (cadddr return)))
+	      (close-input-port reader)
+	      (close-input-port error-reader)
+	      (fprintf writer "From: ~a~n" sender)
+	      (letrec ((write-recipient-header
+			(lambda (header-string recipients)
+			  (let ((header-space
+				 (+ (string-length header-string) 2)))
+			    (fprintf writer "~a: " header-string)
+			    (let loop ((to recipients) (indent header-space))
+			      (if (null? to)
+				  (newline writer)
+				  (let ((first (car to))
+					[rest (cdr to)])
+				    (let ((len (string-length first)))
+				      (if (>= (+ len indent) 80)
+					  (begin
+					    (fprintf writer
+					      (if (null? rest)
+						  "~n    ~a"
+						  "~n    ~a, ")
+					      first)
+					    (loop (cdr to)
+					      (+ len header-space 2)))
+					  (begin
+					    (fprintf writer
+					      (if (null? rest)
+						  "~a "
+						  "~a, ")
+					      first)
+					    (loop (cdr to)
+						  (+ len indent 2))))))))))))
+		(write-recipient-header "To" to-recipients)
+		(unless (null? cc-recipients)
+		  (write-recipient-header "CC" cc-recipients)))
+	      (fprintf writer "Subject: ~a~n" subject)
+	      (fprintf writer "X-Mailer: MzScheme: see www.plt-scheme.org~n")
+	      (for-each (lambda (s)
+			  (display s writer)
+			  (newline writer))
+			other-headers)
+	      (newline writer)
+	      writer))))
+
+      ;; send-mail-message :
+      ;; string x string x list (string) x list (string) x list (string) x
+      ;;   list (string) [x list (string)] -> ()
+
+      ;; -- sender can be anything, though spoofing is not recommended.  The
+      ;; recipients must all be pure email addresses.  The text is expected
+      ;; to be pre-formatted.  Note that everything is expected to follow
+      ;; RFC conventions.  If any other headers are specified, they are
+      ;; expected to be completely formatted already.
+
+      (define send-mail-message
+	(lambda (sender subject to-recipients cc-recipients bcc-recipients text
+			. other-headers)
+	  (let ((writer (apply send-mail-message/port sender subject
+			       to-recipients cc-recipients bcc-recipients
+			       other-headers)))
+	    (for-each (lambda (s)
+			(display s writer)	; We use -i, so "." is not a problem
+			(newline writer))
+		      text)
+	    (close-output-port writer)))))))
diff --git a/collects/net/sendmail.ss b/collects/net/sendmail.ss
new file mode 100644
index 0000000000..0bb3dbb22e
--- /dev/null
+++ b/collects/net/sendmail.ss
@@ -0,0 +1,11 @@
+
+(module sendmail mzscheme
+  (require (lib "unitsig.ss"))
+
+  (require "sendmail-sig.ss")
+  (require "sendmail-unit.ss")
+
+  (define-values/invoke-unit/sig net:sendmail^
+    net:sendmail@)
+
+  (provide-signature-elements net:sendmail^))
diff --git a/collects/net/sendurl.ss b/collects/net/sendurl.ss
new file mode 100644
index 0000000000..94422d6475
--- /dev/null
+++ b/collects/net/sendurl.ss
@@ -0,0 +1,147 @@
+(module sendurl mzscheme
+  (require (lib "process.ss")
+           (lib "file.ss")
+           (lib "etc.ss")
+           (lib "port.ss")
+           (lib "sendevent.ss"))
+  
+  (provide send-url unix-browser-list browser-preference? external-browser)
+  
+  (define separate-by-default?
+    (get-preference 'new-browser-for-urls (lambda () #t)))
+
+  ; : any -> bool
+  (define (browser-preference? x)
+    (or (not x) (eq? 'plt x) (memq x unix-browser-list) (custom-browser? x)
+        (procedure? x)))
+
+  (define external-browser
+    (make-parameter
+     #f ; #f means "consult the preferences file"
+     (lambda (x)
+       (if (browser-preference? x)
+           x
+           (error 'external-browser "~a is not a valid browser preference" x)))))
+  
+  ; send-url : str [bool] -> void
+  (define send-url
+    (opt-lambda (url-str [separate-window? separate-by-default?])
+      (cond
+       [(procedure? (external-browser))
+	((external-browser) url-str)]
+       [(eq? (system-type) 'macos)
+	(if (regexp-match "Blue Box" (system-type #t))
+	    ;; Classic inside OS X:
+	    (let loop ([l '("MSIE" "NAVG")])
+	      (if (null? l)
+		  (error 'send-url "couldn't start Internet Explorer or Netscape")
+		  (with-handlers ([exn:fail? (lambda (x) (loop (cdr l)))])
+		    (subprocess #f #f #f "by-id" (car l))
+		    (let loop ([retries 2]) ;; <<< Yuck <<<
+		      (if (zero? retries)
+			  (error "enough already") ; caught above
+			  (with-handlers ([exn:fail? (lambda (x)
+						       (loop (sub1 retries)))])
+			    (let ([t (thread (lambda ()
+					       (send-event (car l) "GURL" "GURL" url-str)))])
+			      (sync/timeout 1 t) ;; <<< Yuck (timeout) <<<
+			      (when (thread-running? t)
+				(kill-thread t)
+				(error "timeout")))))))))
+	    ;; Normal OS Classic:
+	    (send-event "MACS" "GURL" "GURL" url-str))]
+       [(or (eq? (system-type) 'macosx)
+	    (equal? "ppc-darwin" (system-library-subpath)))
+	;; not sure what changed, but this is wrong now.... -robby
+	;;(browser-process (format "osascript -e 'open location \"~a\"'" (regexp-replace* "%" url-str "%25")))	
+	(browser-process (format "osascript -e 'open location \"~a\"'" url-str))]
+       [(eq? (system-type) 'windows)
+	(shell-execute #f url-str "" (current-directory) 'SW_SHOWNORMAL)]
+       [(eq? (system-type) 'unix)
+	(let ([preferred (or (external-browser) (get-preference 'external-browser))])
+	  (cond
+	   [(use-browser 'opera preferred)
+	    =>
+	    (lambda (browser-path) 
+	      ;; opera may not return -- always open asyncronously
+	      ;; opera starts a new browser automatically, if it can't find one
+	      (browser-process* browser-path "-remote"
+				(format "openURL(~a)"
+					(if separate-window?
+					    (format "~a,new-window" url-str)
+					    url-str))))]
+	   [(use-browser 'galeon preferred)
+	    =>
+	    (lambda (browser-path)
+	      (browser-process* browser-path
+				(if separate-window? "-w" "-x")
+				url-str))]
+	   [(or (use-browser 'netscape preferred)
+		(use-browser 'mozilla preferred))
+	    =>
+	    (lambda (browser-path)
+	      ;; netscape's -remote returns with an error code, if no
+	      ;; netscape is around. start a new netscape in that case.
+	      (or (system* browser-path "-remote"
+			   (format "openURL(~a)"
+				   (if separate-window?
+				       (format "~a,new-window" url-str)
+				       url-str)))
+		  (browser-process* browser-path url-str)))]
+	   [(use-browser 'dillo preferred)
+	    =>
+	    (lambda (browser-path)
+	      (browser-process* browser-path url-str))]
+	   [(custom-browser? preferred)
+	    (let ([cmd (string-append (car preferred)
+				      url-str
+				      (cdr preferred))])
+	      (browser-process cmd))]
+	   [else
+	    (error 'send-url "Couldn't find ~a to open URL: ~e" (orify unix-browser-list) url-str)]))]
+       [else (error 'send-url "don't know how to open URL on platform: ~s" (system-type))])))
+  
+  ; : tst -> bool
+  (define (custom-browser? x)
+    (and (pair? x) (string? (car x)) (string? (cdr x))))
+  
+  (define unix-browser-list '(opera galeon netscape mozilla dillo))
+  
+  ; : (cons tst (listof tst)) -> str
+  (define (orify l)
+    (cond
+      [(null? (cdr l)) (format "~a" (car l))]
+      [(null? (cddr l)) (format "~a or ~a" (car l) (cadr l))]
+      [else 
+    (let loop ([l l])
+      (cond
+        [(null? (cdr l)) (format "or ~a" (car l))]
+        [else (string-append (format "~a, " (car l)) (loop (cdr l)))]))]))
+  
+  ; : sym sym -> (U #f str)
+  ; to find the path for the named browser, unless another browser is preferred
+  (define (use-browser browser-name preferred)
+    (and (or (not preferred)
+	     (eq? preferred browser-name))
+	 (find-executable-path (symbol->string browser-name) #f)))
+    
+  ;; run-browser : process-proc list-of-strings -> void
+  (define (run-browser process*/ports args)
+    (let-values ([(stdout stdin pid stderr control)
+		  (apply values (apply process*/ports
+				       (open-output-nowhere)
+				       #f
+				       (current-error-port)
+				       args))])
+      (close-output-port stdin)
+      (thread (lambda ()
+		(control 'wait)
+		(when (eq? 'done-error (control 'status))
+		  (error 'run-browser "process execute failed: ~e" args))))
+      (void)))
+
+  (define (browser-process* . args)
+    (run-browser process*/ports args))
+
+  (define (browser-process cmd)
+    (run-browser process/ports (list cmd))))
diff --git a/collects/net/smtp-sig.ss b/collects/net/smtp-sig.ss
new file mode 100644
index 0000000000..004d81d23d
--- /dev/null
+++ b/collects/net/smtp-sig.ss
@@ -0,0 +1,10 @@
+
+(module smtp-sig mzscheme
+  (require (lib "unitsig.ss"))
+
+  (provide net:smtp^)
+  (define-signature net:smtp^
+    (smtp-send-message
+     smtp-send-message*
+     smtp-sending-end-of-message)))
+
diff --git a/collects/net/smtp-unit.ss b/collects/net/smtp-unit.ss
new file mode 100644
index 0000000000..980ac248db
--- /dev/null
+++ b/collects/net/smtp-unit.ss
@@ -0,0 +1,119 @@
+
+(module smtp-unit mzscheme
+  (require (lib "unitsig.ss"))
+
+  (require "smtp-sig.ss")
+
+  (provide net:smtp@)
+  (define net:smtp@
+    (unit/sig net:smtp^
+      (import)
+
+      (define ID "localhost")
+
+      (define debug-via-stdio? #f)
+
+      (define crlf (string #\return #\linefeed))
+
+      (define (log . args)
+	;; (apply printf args)
+	(void))
+
+      (define (starts-with? l n)
+	(and (>= (string-length l) (string-length n))
+	     (string=? n (substring l 0 (string-length n)))))
+
+      (define (check-reply r v w)
+	(flush-output w)
+	(let ([l (read-line r (if debug-via-stdio?
+				  'linefeed
+				  'return-linefeed))])
+	  (log "server: ~a~n" l)
+	  (if (eof-object? l)
+	      (error 'check-reply "got EOF")
+	      (let ([n (number->string v)])
+		(unless (starts-with? l n)
+		  (error 'check-reply "expected reply ~a; got: ~a" v l))
+		(let ([n- (string-append n "-")])
+		  (when (starts-with? l n-)
+		    ;; Multi-line reply. Go again.
+		    (check-reply r v w)))))))
+
+      (define (protect-line l)
+	;; If begins with a dot, add one more
+	(if (or (equal? l #"")
+		(equal? l "")
+		(and (string? l)
+		     (not (char=? #\. (string-ref l 0))))
+		(and (bytes? l)
+		     (not (= (char->integer #\.) (bytes-ref l 0)))))
+	    l
+	    (if (bytes? l)
+		(bytes-append #"." l)
+		(string-append "." l))))
+
+      (define smtp-sending-end-of-message
+	(make-parameter void
+			(lambda (f)
+			  (unless (and (procedure? f)
+				       (procedure-arity-includes? f 0))
+			    (raise-type-error 'smtp-sending-end-of-message "thunk" f))
+			  f)))
+      
+      (define (smtp-send-message* r w sender recipients header message-lines)
+	    (with-handlers ([void (lambda (x)
+				    (close-input-port r)
+				    (close-output-port w)
+				    (raise x))])
+	      (check-reply r 220 w)
+	      (log "hello~n")
+	      (fprintf w "EHLO ~a~a" ID crlf)
+	      (check-reply r 250 w)
+	      
+	      (log "from~n")
+	      (fprintf w "MAIL FROM:<~a>~a" sender crlf)
+	      (check-reply r 250 w)
+	      
+	      (log "to~n")
+	      (for-each
+	       (lambda (dest)
+		 (fprintf w "RCPT TO:<~a>~a" dest crlf)
+		 (check-reply r 250 w))
+	       recipients)
+	      
+	      (log "header~n")
+	      (fprintf w "DATA~a" crlf)
+	      (check-reply r 354 w)
+	      (fprintf w "~a" header)
+	      (for-each
+	       (lambda (l)
+		 (log "body: ~a~n" l)
+		 (fprintf w "~a~a" (protect-line l) crlf))
+	       message-lines)
+
+	      ;; After we send the ".", then only break in an emergency
+	      ((smtp-sending-end-of-message))
+
+	      (log "dot~n")
+	      (fprintf w ".~a" crlf)
+	      (flush-output w)
+	      (check-reply r 250 w)
+	      
+	      (log "quit~n")
+	      (fprintf w "QUIT~a" crlf)
+	      (check-reply r 221 w)
+	      
+	      (close-output-port w)
+	      (close-input-port r)))
+      
+      (define smtp-send-message
+	(case-lambda
+	 [(server sender recipients header message-lines)
+	  (smtp-send-message server sender recipients header message-lines 25)]
+	 [(server sender recipients header message-lines pos)
+	  (when (null? recipients)
+	    (error 'send-smtp-message "no receivers"))
+	  (let-values ([(r w) (if debug-via-stdio?
+				  (values (current-input-port) (current-output-port))
+				  (tcp-connect server pos))])
+	    (smtp-send-message* r w sender recipients header message-lines))])))))
\ No newline at end of file
diff --git a/collects/net/smtp.ss b/collects/net/smtp.ss
new file mode 100644
index 0000000000..3f4cebcc8c
--- /dev/null
+++ b/collects/net/smtp.ss
@@ -0,0 +1,11 @@
+
+(module smtp mzscheme
+  (require (lib "unitsig.ss"))
+
+  (require "smtp-sig.ss")
+  (require "smtp-unit.ss")
+
+  (define-values/invoke-unit/sig net:smtp^
+    net:smtp@)
+
+  (provide-signature-elements net:smtp^))
diff --git a/collects/net/ssl-tcp-unit.ss b/collects/net/ssl-tcp-unit.ss
new file mode 100644
index 0000000000..3b27e49b24
--- /dev/null
+++ b/collects/net/ssl-tcp-unit.ss
@@ -0,0 +1,61 @@
+(module ssl-tcp-unit mzscheme
+  (provide make-ssl-tcp@)
+  (require (lib "unitsig.ss")
+           "tcp-sig.ss"
+	   (lib "mzssl.ss" "openssl")
+	   (lib "etc.ss"))
+  
+  (define (make-ssl-tcp@ 
+	   server-cert-file server-key-file server-root-cert-files server-suggest-auth-file
+	   client-cert-file client-key-file client-root-cert-files)
+    (unit/sig net:tcp^
+      (import)
+
+      (define ctx (ssl-make-client-context))
+      (when client-cert-file
+	(ssl-load-certificate-chain! ctx client-cert-file))
+      (when client-key-file
+	(ssl-load-private-key! ctx client-key-file))
+      (when client-root-cert-files
+	(ssl-set-verify! ctx #t)
+	(map (lambda (f)
+	       (ssl-load-verify-root-certificates! ctx f))
+	     client-root-cert-files))
+
+      (define (tcp-abandon-port p)
+	(if (input-port? p)
+	    (close-input-port p)
+	    (close-output-port p)))
+
+      (define tcp-accept ssl-accept)
+
+      ;; accept-ready? doesn't really work for SSL:
+      (define (tcp-accept-ready? p)
+	#f)
+
+      (define tcp-addresses ssl-addresses)
+      (define tcp-close ssl-close)
+      (define tcp-connect 
+	(opt-lambda (hostname port-k)
+	  (ssl-connect hostname port-k ctx)))
+      (define tcp-connect/enable-break
+	(opt-lambda (hostname port-k)
+	  (ssl-connect/enable-break hostname port-k ctx)))
+
+      (define tcp-listen
+	(opt-lambda (port [allow-k 4] [reuse? #f] [hostname #f])
+	  (let ([l (ssl-listen port allow-k reuse? hostname)])
+	    (when server-cert-file
+	      (ssl-load-certificate-chain! l server-cert-file))
+	    (when server-key-file
+	      (ssl-load-private-key! l server-key-file))
+	    (when server-root-cert-files
+	      (ssl-set-verify! l #t)
+	      (map (lambda (f)
+		     (ssl-load-verify-root-certificates! l f))
+		   server-root-cert-files))
+	    (when server-suggest-auth-file
+	      (ssl-load-suggested-certificate-authorities! l server-suggest-auth-file))
+	    l)))
+
+      (define tcp-listener? ssl-listener?))))
diff --git a/collects/net/tcp-redirect.ss b/collects/net/tcp-redirect.ss
new file mode 100644
index 0000000000..891abf69a2
--- /dev/null
+++ b/collects/net/tcp-redirect.ss
@@ -0,0 +1,124 @@
+(module tcp-redirect mzscheme
+  (provide tcp-redirect)
+  
+  (require (lib "unitsig.ss")
+           (lib "async-channel.ss")
+           (lib "etc.ss")
+           "tcp-sig.ss")
+  
+  (define raw:tcp-abandon-port tcp-abandon-port)
+  (define raw:tcp-accept tcp-accept) 
+  (define raw:tcp-accept-ready? tcp-accept-ready?)
+  (define raw:tcp-addresses tcp-addresses)
+  (define raw:tcp-close tcp-close)
+  (define raw:tcp-connect tcp-connect)
+  (define raw:tcp-connect/enable-break tcp-connect/enable-break)
+  (define raw:tcp-listen tcp-listen)
+  (define raw:tcp-listener? tcp-listener?)
+  
+  ; For tcp-listeners, we use an else branch in the conds since
+  ; (instead of a contract) I want the same error message as the raw
+  ; primitive for bad inputs.
+  
+  ; : (listof nat) -> (unit/sig () -> net:tcp^)
+  (define tcp-redirect
+    (opt-lambda (redirected-ports [redirected-address "127.0.0.1"])
+      (unit/sig net:tcp^
+        (import)
+        
+        ; : (make-pipe-listener nat (channel (cons iport oport)))
+        (define-struct pipe-listener (port channel))
+        
+        ; : port -> void
+        (define (tcp-abandon-port tcp-port)
+          (when (tcp-port? tcp-port)
+            (raw:tcp-abandon-port tcp-port)))
+        
+        ; : listener -> iport oport
+        (define (tcp-accept tcp-listener)
+          (cond
+            [(pipe-listener? tcp-listener)
+             (let ([in-out (async-channel-get (pipe-listener-channel tcp-listener))])
+               (values (car in-out) (cdr in-out)))]
+            [else (raw:tcp-accept tcp-listener)]))
+        
+        ; : tcp-listener -> iport oport
+        ; FIX - check channel queue size
+        (define (tcp-accept-ready? tcp-listener)
+          (cond
+            [(pipe-listener? tcp-listener) #t]
+            [else (raw:tcp-accept-ready? tcp-listener)]))
+        
+        ; : tcp-port -> str str
+        (define (tcp-addresses tcp-port)
+          (if (tcp-port? tcp-port)
+              (raw:tcp-addresses tcp-port)
+              (values redirected-address redirected-address)))
+        
+        ; : port -> void
+        (define (tcp-close tcp-listener)
+          (if (tcp-listener? tcp-listener)
+              (raw:tcp-close tcp-listener)
+              (hash-table-remove!
+               port-table
+               (pipe-listener-port tcp-listener))))
+        
+        ; : (str nat -> iport oport) -> str nat -> iport oport
+        (define (gen-tcp-connect raw)
+          (lambda (hostname-string port)
+            (if (and (string=? redirected-address hostname-string)
+                     (redirect? port))
+                (let-values ([(to-in from-out) (make-pipe)]
+                             [(from-in to-out) (make-pipe)])
+                  (async-channel-put
+                   (pipe-listener-channel
+                    (hash-table-get
+                     port-table
+                     port
+                     (lambda ()
+                       (raise (make-exn:fail:network
+                               (string->immutable-string
+                                (format "tcp-connect: connection to ~a, port ~a failed (nobody is listening)"
+                                        hostname-string port))
+                               (current-continuation-marks))))))
+                   (cons to-in to-out))
+                  (values from-in from-out))
+                (raw hostname-string port))))
+        
+        ; : str nat -> iport oport
+        (define tcp-connect (gen-tcp-connect raw:tcp-connect))
+        
+        ; : str nat -> iport oport
+        (define tcp-connect/enable-break (gen-tcp-connect raw:tcp-connect/enable-break))
+        
+        ; FIX - support the reuse? flag.
+        (define tcp-listen
+          (opt-lambda (port [max-allow-wait 4] [reuse? #f] [hostname-string #f])
+            (hash-table-get
+             port-table
+             port
+             (lambda ()
+               (if (redirect? port)
+                   (let ([listener (make-pipe-listener port (make-async-channel))])
+                     (hash-table-put! port-table port listener)
+                     listener)
+                   (raw:tcp-listen port max-allow-wait reuse? hostname-string))))))
+        
+        ; : tst -> bool
+        (define (tcp-listener? x)
+          (or (pipe-listener? x) (raw:tcp-listener? x)))
+        
+        ; ---------- private ----------
+        
+        ; : (hash-table nat[port] -> tcp-listener)
+        (define port-table (make-hash-table))
+        
+        (define redirect-table
+          (let ([table (make-hash-table)])
+            (for-each (lambda (x) (hash-table-put! table x #t))
+                      redirected-ports)
+            table))
+        
+        ; : nat -> bool
+        (define (redirect? port)
+          (hash-table-get redirect-table port (lambda () #f)))))))
\ No newline at end of file
diff --git a/collects/net/tcp-sig.ss b/collects/net/tcp-sig.ss
new file mode 100644
index 0000000000..a00b1d3483
--- /dev/null
+++ b/collects/net/tcp-sig.ss
@@ -0,0 +1,14 @@
+(module tcp-sig mzscheme
+  (provide net:tcp^)
+  (require (lib "unitsig.ss"))
+  
+  (define-signature net:tcp^
+    (tcp-abandon-port
+     tcp-accept
+     tcp-accept-ready?
+     tcp-addresses
+     tcp-close
+     tcp-connect
+     tcp-connect/enable-break
+     tcp-listen
+     tcp-listener?)))
\ No newline at end of file
diff --git a/collects/net/tcp-unit.ss b/collects/net/tcp-unit.ss
new file mode 100644
index 0000000000..7cf917a3cd
--- /dev/null
+++ b/collects/net/tcp-unit.ss
@@ -0,0 +1,32 @@
+(module tcp-unit mzscheme
+  (provide tcp@)
+  (require (lib "unitsig.ss")
+           "tcp-sig.ss")
+  
+  ; Okay, this file looks retarded.  Something is clearly wrong.
+  
+  
+  (define raw:tcp-abandon-port tcp-abandon-port)
+  (define raw:tcp-accept tcp-accept) 
+  (define raw:tcp-accept-ready? tcp-accept-ready?)
+  (define raw:tcp-addresses tcp-addresses)
+  (define raw:tcp-close tcp-close)
+  (define raw:tcp-connect tcp-connect)
+  (define raw:tcp-connect/enable-break tcp-connect/enable-break)
+  (define raw:tcp-listen tcp-listen)
+  (define raw:tcp-listener? tcp-listener?)
+  
+  (define tcp@
+    (unit/sig net:tcp^
+      (import)
+      
+      (define tcp-abandon-port raw:tcp-abandon-port)
+      (define tcp-accept raw:tcp-accept) 
+      (define tcp-accept-ready? raw:tcp-accept-ready?)
+      (define tcp-addresses raw:tcp-addresses)
+      (define tcp-close raw:tcp-close)
+      (define tcp-connect raw:tcp-connect)
+      (define tcp-connect/enable-break raw:tcp-connect/enable-break)
+      (define tcp-listen raw:tcp-listen)
+      (define tcp-listener? raw:tcp-listener?)
+      )))
\ No newline at end of file
diff --git a/collects/net/unihead.ss b/collects/net/unihead.ss
new file mode 100644
index 0000000000..a49b646c0a
--- /dev/null
+++ b/collects/net/unihead.ss
@@ -0,0 +1,119 @@
+(module unihead mzscheme
+  (require (lib "base64.ss" "net")
+	   (lib "qp.ss" "net")
+	   (lib "string.ss"))
+
+  (provide encode-for-header
+	   decode-for-header
+	   generalize-encoding)
+  
+  (define re:ascii #rx"^[\u0-\u7F]*$")
+
+  (define (encode-for-header s)
+    (if (regexp-match re:ascii s)
+	s
+	(let ([l (regexp-split #rx"\r\n" s)])
+	  (apply string-append
+		 (map encode-line-for-header l)))))
+  
+  (define (encode-line-for-header s)
+    (define (loop s string->bytes charset encode encoding)
+      ;; Find ASCII (and no "=") prefix before a space
+      (let ([m (regexp-match #rx"^([\u0-\u3c\u3e-\u7F]* )(.*)$" s)])
+	(if m
+	    (string-append
+	     (cadr m)
+	     (loop (caddr m) string->bytes charset encode encoding))
+	    ;; Find ASCII (and no "=") suffix after a space
+	    (let ([m (regexp-match #rx"^(.*?)( [\u0-\u3c\u3e-\u7F]*)$" s)])
+	      (if m
+		  (string-append
+		   (loop (cadr m) string->bytes charset encode encoding)
+		   (caddr m))
+		  (format "=?~a?~a?~a?="
+			  charset encoding
+			  (regexp-replace* #rx#"[\r\n]+$"
+					   (encode (string->bytes s))
+					   #"")))))))
+    (cond
+     [(regexp-match re:ascii s)
+      ;; ASCII - do nothing
+      s]
+     [(regexp-match #rx"[^\u0-\uFF]" s)
+      ;; Not Latin-1, so use UTF-8
+      (loop s string->bytes/utf-8 "UTF-8" base64-encode "B")]
+     [else
+      ;; use Latin-1
+      (loop s string->bytes/latin-1 "ISO-8859-1"
+	    (lambda (s)
+	      (regexp-replace #rx#" " (qp-encode s) #"_"))
+	    "Q")]))
+
+  ;; ----------------------------------------
+
+  (define re:us-ascii #rx#"^[uS][sS]-[aA][sS][cC][iI][iI]$")
+  (define re:iso #rx#"^[iI][sS][oO]-8859-1$")
+  (define re:gb #rx#"^[gG][bB](2312)?$")
+  (define re:ks_c #rx#"^[kK][sS]_[cC]_5601-1987$")
+  (define re:utf-8 #rx#"^[uU][tT][fF]-8$")
+  
+  (define re:encoded #rx#"^(.*?)=[?]([^?]+)[?]([qQbB])[?](.*?)[?]=(.*)$")
+  
+  (define (generalize-encoding encoding)
+    ;; Treat Latin-1 as Windows-1252 and also threat GB and GB2312
+    ;; as GBK, because some mailers are broken.
+    (cond 
+     [(or (regexp-match re:iso encoding) 
+	  (regexp-match re:us-ascii encoding))
+      (if (bytes? encoding)
+	  #"WINDOWS-1252"
+	  "WINDOWS-1252")]
+     [(regexp-match re:gb encoding) 
+      (if (bytes? encoding)
+	  #"GBK"
+	  "GBK")]
+     [(regexp-match re:ks_c encoding) 
+      (if (bytes? encoding)
+	  #"CP949"
+	  "CP949")]
+     [else encoding]))
+  
+  (define (decode-for-header s)
+    (and s
+	 (let ([m (regexp-match re:encoded (string->bytes/latin-1 s (char->integer #\?)))])
+	   (if m
+	       (let ([s ((if (member (cadddr m) '(#"q" #"Q"))
+			     ;; quoted-printable, with special _ handling
+			     (lambda (x)
+			       (qp-decode (regexp-replace* #rx#"_" x #" ")))
+			     ;; base64:
+			     base64-decode)
+			 (cadddr (cdr m)))]
+		     [encoding (caddr m)])
+		 (string-append
+		  (decode-for-header (bytes->string/latin-1 (cadr m)))
+		  (let ([encoding (generalize-encoding encoding)])
+		    (cond
+		     [(regexp-match re:utf-8 encoding) (bytes->string/utf-8 s #\?)]
+		     [else (let ([c (bytes-open-converter (bytes->string/latin-1 encoding) "UTF-8")])
+			     (if c
+				 (let-values ([(r got status) (bytes-convert c s)])
+				   (bytes-close-converter c)
+				   (if (eq? status 'complete)
+				       (bytes->string/utf-8 r #\?)
+				       (bytes->string/latin-1 s)))
+				 (bytes->string/latin-1 s)))]))
+		  (let ([rest (cadddr (cddr m))])
+		    (let ([rest
+			   ;; A CR-LF-space-encoding sequence means that we should
+			   ;; drop the space.
+			   (if (and (> (bytes-length rest) 4)
+				    (= 13 (bytes-ref rest 0))
+				    (= 10 (bytes-ref rest 1))
+				    (= 32 (bytes-ref rest 2))
+				    (let ([m (regexp-match-positions re:encoded rest)])
+				      (and m (= (caaddr m) 5))))
+			       (subbytes rest 3)
+			       rest)])
+		      (decode-for-header (bytes->string/latin-1 rest))))))
+	       s)))))
diff --git a/collects/net/uri-codec-sig.ss b/collects/net/uri-codec-sig.ss
new file mode 100644
index 0000000000..f0aed959e9
--- /dev/null
+++ b/collects/net/uri-codec-sig.ss
@@ -0,0 +1,12 @@
+(module uri-codec-sig mzscheme
+  (require (lib "unitsig.ss"))
+  (provide net:uri-codec^)
+
+  (define-signature net:uri-codec^
+    (uri-encode
+     uri-decode
+     form-urlencoded-encode
+     form-urlencoded-decode
+     alist->form-urlencoded
+     form-urlencoded->alist
+     current-alist-separator-mode)))
\ No newline at end of file
diff --git a/collects/net/uri-codec-unit.ss b/collects/net/uri-codec-unit.ss
new file mode 100644
index 0000000000..acbf0e3832
--- /dev/null
+++ b/collects/net/uri-codec-unit.ss
@@ -0,0 +1,293 @@
+;;;
+;;; <uri-codec-unit.ss> ---- En/Decode URLs and form-urlencoded data
+;;; Time-stamp: <03/04/25 10:31:31 noel>
+;;;
+;;; Copyright (C) 2002 by Noel Welsh.
+;;;
+;;; This file is part of Net.
+
+;;; Net is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2.1 of the License, or (at your option) any later version.
+
+;;; Net is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with Net; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307  USA
+
+;;; Author: Noel Welsh <noelwelsh@yahoo.com>
+;;
+;;
+;; Commentary:
+
+;; The module provides functions to encode and decode strings using
+;; the URI encoding rules given in RFC 2396, and to encode and decode
+;; name/value pairs using the application/x-www-form-urlencoded
+;; mimetype given the in HTML 4.0 specification.  There are minor
+;; differences between the two encodings.
+
+;; The URI encoding uses allows a few characters to be represented `as
+;; is': a-Z, A-Z, 0-9, -, _, ., !, ~, *, ', ( and ).  The remaining
+;; characters are encoded as %xx, where xx is the hex representation
+;; of the integer value of the character (where the mapping
+;; character<->integer is determined by US-ASCII if the integer is
+;; <128).
+
+;; The encoding, inline with RFC 2396's recommendation, represents a
+;; character as is, if possible.  The decoding allows any characters
+;; to be represented by their hex values, and allows characters to be
+;; incorrectly represented `as is'.
+
+;; The rules for the application/x-www-form-urlencoded mimetype given
+;; in the HTML 4.0 spec are:
+
+;;   1. Control names and values are escaped. Space characters are
+;;   replaced by `+', and then reserved characters are escaped as
+;;   described in [RFC1738], section 2.2: Non-alphanumeric characters
+;;   are replaced by `%HH', a percent sign and two hexadecimal digits
+;;   representing the ASCII code of the character. Line breaks are
+;;   represented as "CR LF" pairs (i.e., `%0D%0A').
+
+;;   2. The control names/values are listed in the order they appear
+;;   in the document. The name is separated from the value by `=' and
+;;   name/value pairs are separated from each other by `&'.
+
+;; NB: RFC 2396 supersedes RFC 1738.
+
+;; This differs slightly from the straight encoding in RFC 2396 in
+;; that `+' is allowed, and represents a space.  We follow this
+;; convention, encoding a space as `+' and decoding `+' as a space.
+;; There appear to be some brain-dead decoders on the web, so we also
+;; encode `!', `~', `'', `(' and ')' using their hex representation.
+;; This is the same choice as made by the Java URLEncoder.
+
+;; Draws inspiration from encode-decode.scm by Kurt Normark and a code
+;; sample provided by Eli Barzilay
+
+(module uri-codec-unit mzscheme
+
+  (require (lib "unitsig.ss")
+           (lib "match.ss")
+           (lib "string.ss")
+	   (lib "etc.ss")
+           "uri-codec-sig.ss")
+
+  (provide uri-codec@)
+
+  ;; Macro to loop over integers from n (inclusive) to m (exclusive)
+  ;; Extracted from iteration.ss in macro package at Schematics
+  (define-syntax for
+        (syntax-rules ()
+          ((for (i n m) forms ...)
+           (let ((fixed-m m))
+                 (let loop ((i n))
+                   (if (< i fixed-m)
+                           (begin
+                                 forms ...
+                                 (loop (+ i 1)))))))))
+
+  (define uri-codec@
+    (unit/sig net:uri-codec^
+      (import)
+
+      ;; The characters that always map to themselves
+      (define alphanumeric-mapping
+        (map (lambda (char)
+               (cons char char))
+             '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
+               #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J
+               #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T
+               #\U #\V #\W #\X #\Y #\Z #\a #\b #\c #\d
+               #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n
+               #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x
+               #\y #\z)))
+
+      ;; Characters that sometimes map to themselves
+      (define safe-mapping
+        (map (lambda (char)
+               (cons char char))
+             '(#\- #\_ #\. #\! #\~ #\* #\' #\( #\))))
+
+      ;; The strict URI mapping
+      (define uri-mapping
+        (append alphanumeric-mapping safe-mapping))
+
+      ;; The form-urlencoded mapping
+      (define form-urlencoded-mapping
+        (append '((#\. . #\.)
+                  (#\- . #\-)
+                  (#\* . #\*)
+                  (#\_ . #\_)
+                  (#\space . #\+))
+                alphanumeric-mapping))
+
+      (define (number->hex-string number)
+        (let ((hex (number->string number 16)))
+          (string-append "%"
+                         (if (= (string-length hex) 1)
+                             (string-append "0" hex)
+                             hex))))
+
+      (define (hex-string->number hex-string)
+        (string->number (substring hex-string 1 3) 16))
+
+      ;; (listof (cons char char)) -> (values (vectorof string) (vectorof string))
+      (define (make-codec-tables alist)
+        (let ((encoding-table (make-vector 256 ""))
+              (decoding-table (make-vector 256 0)))
+          (for (i 0 256)
+               (vector-set! encoding-table i (number->hex-string i))
+               (vector-set! decoding-table i i))
+          (for-each (match-lambda
+                     [(orig . enc)
+                      (vector-set! encoding-table
+                                   (char->integer orig)
+                                   (string enc))
+                      (vector-set! decoding-table
+                                   (char->integer enc)
+                                   (char->integer orig))])
+                    alist)
+          (values encoding-table decoding-table)))
+
+      (define-values (uri-encoding-vector uri-decoding-vector)
+        (make-codec-tables uri-mapping))
+
+      (define-values (form-urlencoded-encoding-vector
+                      form-urlencoded-decoding-vector)
+        (make-codec-tables form-urlencoded-mapping))
+
+      ;; vector string -> string
+      (define (encode table str)
+        (apply string-append
+               (map (lambda (byte)
+                      (vector-ref table byte))
+                    (bytes->list (string->bytes/utf-8 str)))))
+
+      ;; vector string -> string
+      (define (decode table str)
+        (define internal-decode
+          (match-lambda
+           [() (list)]
+           [(#\% (? hex-digit? char1) (? hex-digit? char2) . rest)
+            ;; This used to consult the table again, but I think that's
+            ;;  wrong. For exmaple %2b should produce +, not a space.
+            (cons (string->number (string char1 char2) 16)
+                  (internal-decode rest))]
+           [(char . rest)
+            (cons
+             (vector-ref table
+                         (char->integer char))
+             (internal-decode rest))]))
+	(bytes->string/utf-8
+	 (apply bytes (internal-decode (string->list str)))))
+
+      (define (hex-digit? c)
+        (or (char<=? #\0 c #\9)
+            (char<=? #\a c #\f)
+            (char<=? #\A c #\F)))
+      
+      ;; string -> string
+      (define (uri-encode str)
+        (encode uri-encoding-vector str))
+
+      ;; string -> string
+      (define (uri-decode str)
+        (decode uri-decoding-vector str))
+
+      ;; string -> string
+      (define (form-urlencoded-encode str)
+        (encode form-urlencoded-encoding-vector str))
+
+      ;; string -> string
+      (define (form-urlencoded-decode str)
+        (decode form-urlencoded-decoding-vector str))
+
+      ;; listof (cons string string) -> string
+      ;; http://www.w3.org/TR/html401/appendix/notes.html#ampersands-in-uris
+      ;; listof (cons symbol string) -> string
+      (define alist->form-urlencoded
+        (opt-lambda (args)
+          (let* ([mode (current-alist-separator-mode)]
+		 [format-one
+                  (lambda (arg)
+                    (let* ([name (car arg)]
+                           [value (cdr arg)])
+                      (string-append 
+                       (form-urlencoded-encode (symbol->string name))
+                       "="
+                       (form-urlencoded-encode value))))]
+                 [strs (let loop ([args args])
+                         (cond
+                           [(null? args) null]
+                           [(null? (cdr args)) (list (format-one (car args)))]
+                           [else (list* (format-one (car args))
+                                        (if (eq? mode 'amp)
+					    "&"
+					    ";")
+                                        (loop (cdr args)))]))])
+            (apply string-append strs))))
+
+      ;; string -> listof (cons string string)  
+      ;; http://www.w3.org/TR/html401/appendix/notes.html#ampersands-in-uris
+      (define form-urlencoded->alist
+	(opt-lambda (str)
+	  (define key-regexp (regexp "[^=]*"))
+	  (define value-regexp (case (current-alist-separator-mode)
+				 [(semi) (regexp "[^;]*")]
+				 [(amp) (regexp "[^&]*")]
+				 [else (regexp "[^&;]*")]))
+	  (define (next-key str start)
+	    (if (>= start (string-length str))
+		#f
+		(match (regexp-match-positions key-regexp str start)
+		  [((start . end))
+		   (vector (let ([s (form-urlencoded-decode (substring str start end))])
+			     (string-lowercase! s)
+			     (string->symbol s))
+			   (add1 end))]
+		  [#f #f])))
+	  (define (next-value str start)
+	    (if (>= start (string-length str))
+		#f
+		(match (regexp-match-positions value-regexp str start)
+		  [((start . end))
+		   (vector (form-urlencoded-decode (substring str start end))
+			   (add1 end))]
+		  [#f #f])))
+	  (define (next-pair str start)
+	    (match (next-key str start)
+	      [#(key start)
+	       (match (next-value str start)
+		 [#(value start)
+		  (vector (cons key value) start)]
+		 [#f
+		  (vector (cons key "") (string-length str))])]
+	      [#f #f]))
+	  (let loop ([start 0]
+		     [end (string-length str)]
+		     [make-alist (lambda (x) x)])
+	    (cond
+	     [(>= start end) (make-alist '())]
+	     [else
+	      (match (next-pair str start)
+		[#(pair next-start)
+		 (loop next-start end (lambda (x) (make-alist (cons pair x))))]
+		[#f (make-alist '())])]))))
+
+      (define current-alist-separator-mode
+	(make-parameter 'amp-or-semi (lambda (s)
+				       (unless (memq s '(amp semi amp-or-semi))
+					 (raise-type-error 'current-alist-separator-mode
+							   "'amp, 'semi, or 'amp-or-semi"
+							   s))
+				       s)))
+
+      ))
+  )
+
+;;; uri-codec-unit.ss ends here
diff --git a/collects/net/uri-codec.ss b/collects/net/uri-codec.ss
new file mode 100644
index 0000000000..ecd6f4d713
--- /dev/null
+++ b/collects/net/uri-codec.ss
@@ -0,0 +1,9 @@
+(module uri-codec mzscheme
+  (require (lib "unitsig.ss")
+           "uri-codec-sig.ss"
+           "uri-codec-unit.ss")
+
+  (provide-signature-elements net:uri-codec^)
+
+  (define-values/invoke-unit/sig net:uri-codec^
+    uri-codec@))
\ No newline at end of file
diff --git a/collects/net/url-sig.ss b/collects/net/url-sig.ss
new file mode 100644
index 0000000000..bc13e18160
--- /dev/null
+++ b/collects/net/url-sig.ss
@@ -0,0 +1,21 @@
+(module url-sig mzscheme
+  (require (lib "unitsig.ss"))
+  (provide net:url^)
+  
+  (define-signature net:url^
+    ((struct url (scheme user host port path query fragment))
+     (struct path/param (path param))
+     get-pure-port
+     get-impure-port
+     post-pure-port
+     post-impure-port
+     display-pure-port
+     purify-port
+     netscape/string->url
+     string->url
+     url->string
+     call/input-url
+     combine-url/relative
+     url-exception?
+     current-proxy-servers)))
+
diff --git a/collects/net/url-unit.ss b/collects/net/url-unit.ss
new file mode 100644
index 0000000000..9aec7803f7
--- /dev/null
+++ b/collects/net/url-unit.ss
@@ -0,0 +1,436 @@
+;; To do:
+;;   Handle HTTP/file errors.
+;;   Not throw away MIME headers.
+;;     Determine file type.
+
+;; ----------------------------------------------------------------------
+
+;; Input ports have two statuses:
+;;   "impure" = they have text waiting
+;;   "pure" = the MIME headers have been read
+
+(module url-unit mzscheme
+  (require (lib "file.ss")
+           (lib "unitsig.ss")
+           (lib "port.ss")
+           "uri-codec.ss"
+           "url-sig.ss"
+           "tcp-sig.ss")
+  (provide url@)
+
+  (define url@
+    (unit/sig net:url^
+      (import net:tcp^)
+
+      (define-struct (url-exception exn:fail) ())
+
+      (define current-proxy-servers
+        (make-parameter null (lambda (v)
+                               (unless (and (list? v)
+                                            (andmap
+                                             (lambda (v)
+                                               (and (list? v)
+                                                    (= 3 (length v))
+                                                    (equal? (car v) "http")
+                                                    (string? (car v))
+                                                    (number? (caddr v))
+                                                    (exact? (caddr v))
+                                                    (integer? (caddr v))
+                                                    (<= 1 (caddr v) 65535)))
+                                             v))
+                                 (raise-type-error
+                                  'current-proxy-servers
+                                  "list of list of scheme, string, and exact integer in [1,65535]"
+                                  v))
+                               (apply
+                                list-immutable
+                                (map (lambda (v)
+                                       (list-immutable (string->immutable-string (car v))
+                                                       (string->immutable-string (cadr v))
+                                                       (caddr v)))
+                                     v)))))
+
+      (define url-error
+        (lambda (fmt . args)
+          (let ((s (string->immutable-string
+                    (apply format fmt (map (lambda (arg)
+                                             (if (url? arg)
+                                                 (url->string arg)
+                                                 arg))
+                                           args)))))
+            (raise (make-url-exception s (current-continuation-marks))))))
+
+      (define-struct url (scheme user host port path query fragment))
+      (define-struct path/param (path param))
+
+      (define url->string
+        (lambda (url)
+          (let ((scheme (url-scheme url))
+                (user (url-user url))
+                (host (url-host url))
+                (port (url-port url))
+                (path (url-path url))
+                (query (url-query url))
+                (fragment (url-fragment url)))
+            (cond
+             ((and scheme (string=? scheme "file"))
+              (string-append "file:" path
+                             (or (and (not fragment) "")
+                                 (string-append "#" fragment))))
+             (else
+              (let ((sa string-append))
+                (sa (if scheme (sa scheme "://") "")
+                    (if user (sa (uri-encode user) "@") "")
+                    (if host host "")
+                    (if port (sa ":" (number->string port)) "")
+                                        ; There used to be a "/" here, but that causes an
+                                        ; extra leading slash -- wonder why it ever worked!
+                    (combine-path-strings path)
+                    ;(if query (sa "?" (uri-encode query)) "")
+                    (if (null? query) "" (sa "?"  (alist->form-urlencoded query)))
+                    (if fragment (sa "#" (uri-encode fragment)) ""))))))))
+
+      ;; url->default-port : url -> num
+      (define url->default-port
+        (lambda (url)
+          (let ((scheme (url-scheme url)))
+            (cond
+             ((not scheme) 80)
+             ((string=? scheme "http") 80)
+             (else
+              (url-error "Scheme ~a not supported" (url-scheme url)))))))
+
+      ;; make-ports : url -> in-port x out-port
+      (define make-ports
+        (lambda (url proxy)
+          (let ((port-number (if proxy
+                                 (caddr proxy)
+                                 (or (url-port url)
+                                     (url->default-port url))))
+                (host (if proxy
+                          (cadr proxy)
+                          (url-host url))))
+            (tcp-connect host port-number))))
+
+      ;; http://getpost-impure-port : bool x url x union (str, #f) x list (str) -> in-port
+      (define http://getpost-impure-port
+        (lambda (get? url post-data strings)
+          (let*-values (((proxy) (assoc (url-scheme url) (current-proxy-servers)))
+                        ((server->client client->server)
+                         (make-ports url proxy)))
+            (let ((access-string
+                   (url->string
+                    (if proxy
+                        url
+                        (make-url #f #f #f #f
+                                  (url-path url)
+                                  (url-query url)
+                                  (url-fragment url))))))
+              (for-each (lambda (s)
+                          (display (string-append s "\r\n") client->server))
+                        (cons (format "~a ~a HTTP/1.0" (if get? "GET" "POST") access-string)
+                              (cons (format "Host: ~a" (url-host url))
+                                    (if post-data
+                                        (cons
+                                         (format "Content-Length: ~a" (bytes-length post-data))
+                                         strings)
+                                        strings)))))
+            (display "\r\n" client->server)
+            (when post-data
+              (display post-data client->server))
+	    (tcp-abandon-port client->server) ; flushes
+            server->client)))
+
+      ;; file://get-pure-port : url -> in-port
+      (define file://get-pure-port
+        (lambda (url)
+          (when (url-host url)
+            (url-error "Don't know how to get files from remote hosts"))
+          (open-input-file (apply build-path (url-path url)))))
+
+      (define (schemeless-url url)
+        (url-error "Missing protocol (usually \"http:\") at the beginning of URL: ~a" url))
+
+      ;; getpost-impure-port : bool x url x list (str) -> in-port
+      (define getpost-impure-port
+        (lambda (get? url post-data strings)
+          (let ((scheme (url-scheme url)))
+            (cond
+             ((not scheme)
+              (schemeless-url url))
+             ((string=? scheme "http")
+              (http://getpost-impure-port get? url post-data strings))
+             ((string=? scheme "file")
+              (url-error "There are no impure file: ports"))
+             (else
+              (url-error "Scheme ~a unsupported" scheme))))))
+
+      ;; get-impure-port : url [x list (str)] -> in-port
+      (define get-impure-port
+        (case-lambda
+         [(url) (get-impure-port url '())]
+         [(url strings) (getpost-impure-port #t url #f strings)]))
+
+      ;; post-impure-port : url x bytes [x list (str)] -> in-port
+      (define post-impure-port
+        (case-lambda
+         [(url post-data) (post-impure-port url post-data '())]
+         [(url post-data strings) (getpost-impure-port #f url post-data strings)]))
+
+      ;; getpost-pure-port : bool x url x list (str) -> in-port
+      (define getpost-pure-port
+        (lambda (get? url post-data strings)
+          (let ((scheme (url-scheme url)))
+            (cond
+             ((not scheme)
+              (schemeless-url url))
+             ((string=? scheme "http")
+              (let ((port (http://getpost-impure-port get? url post-data strings)))
+                (with-handlers ([void (lambda (exn)
+                                        (close-input-port port)
+                                        (raise exn))])
+                  (purify-port port))
+                port))
+             ((string=? scheme "file")
+              (file://get-pure-port url))
+             (else
+              (url-error "Scheme ~a unsupported" scheme))))))
+
+      ;; get-pure-port : url [x list (str)] -> in-port
+      (define get-pure-port
+        (case-lambda
+         [(url) (get-pure-port url '())]
+         [(url strings) (getpost-pure-port #t url #f strings)]))
+
+      ;; post-pure-port : url bytes [x list (str)] -> in-port
+      (define post-pure-port
+        (case-lambda
+         [(url post-data) (post-pure-port url post-data '())]
+         [(url post-data strings) (getpost-pure-port #f url post-data strings)]))
+
+      ;; display-pure-port : in-port -> ()
+      (define display-pure-port
+        (lambda (server->client)
+          (copy-port server->client (current-output-port))
+          (close-input-port server->client)))
+
+      (define empty-url?
+        (lambda (url)
+          (and (not (url-scheme url))
+               (not (url-query url))
+               (not (url-fragment url))
+               (null? (url-path url)))))
+
+      (define (combine-url/relative base string)
+        (let ([relative (string->url string)])
+          (cond
+            [(empty-url? base)                ; Step 1
+             relative]
+            [(empty-url? relative)            ; Step 2a
+             base]
+            [(url-scheme relative)            ; Step 2b
+             relative]
+            [else                             ; Step 2c
+             (set-url-scheme! relative (url-scheme base))
+             (cond
+               [(url-host relative)     ; Step 3
+                relative]
+               [else
+                (set-url-host! relative (url-host base))
+                (set-url-port! relative (url-port base)) ; Unspecified!
+                (let ([rel-path (url-path relative)])
+                  (cond
+                    [(and (not (equal? string "")) ; Step 4
+                          (char=? #\/ (string-ref string 0)))
+                     relative]
+                    [(or (not rel-path) ; Step 5
+                         (null? rel-path))
+                     (set-url-path! relative (url-path base))
+                     (when (url-query relative)
+                       (set-url-query! relative (url-query base)))
+                     relative]
+                    [else               ; Step 6
+                     (merge-and-normalize
+                      (url-path base) relative)]))])])))
+
+      (define (merge-and-normalize base-path relative-url)
+        (let* ([joined
+                (let loop ([base-path base-path])
+                  (cond
+                    [(null? base-path) (url-path relative-url)]
+                    [(null? (cdr base-path)) (url-path relative-url)]
+                    [else (cons (car base-path) (loop (cdr base-path)))]))]
+               [reversed/simplified
+                (if (null? joined)
+                    null
+                    (let loop ([segs (reverse joined)])
+                      (cond
+                        [(null? segs) null]
+                        [else (let ([fst (car segs)])
+                                (cond
+                                  [(string=? fst ".")
+                                   (loop (cdr segs))]
+                                  [(string=? fst "..")
+                                   (if (null? (cdr segs))
+                                       segs
+                                       (loop (cddr segs)))]
+                                  [else (cons (car segs) (loop (cdr segs)))]))])))])
+          (set-url-path! relative-url (reverse reversed/simplified))
+          relative-url))
+
+      ;; call/input-url : url x (url -> in-port) x (in-port -> T)
+      ;;                  [x list (str)] -> T
+      (define call/input-url
+        (let ((handle-port (lambda (server->client handler)
+                             (dynamic-wind (lambda () 'do-nothing)
+                                 (lambda () (handler server->client))
+                                 (lambda () (close-input-port server->client))))))
+          (case-lambda
+           ((url getter handler)
+            (handle-port (getter url) handler))
+           ((url getter handler params)
+            (handle-port (getter url params) handler)))))
+
+      ;; purify-port : in-port -> header-string
+      (define purify-port
+        (lambda (port)
+          (let ([m (regexp-match-peek-positions #rx"^HTTP/.*?((\r\n\r\n)|(\n\n)|(\r\r))" port)])
+            (if m
+                (read-string (cdar m) port)
+                ""))))
+
+      (define character-set-size 256)
+
+      ;; netscape/string->url : str -> url
+      (define netscape/string->url
+        (lambda (string)
+          (let ((url (string->url string)))
+            (if (url-scheme url)
+                url
+                (if (string=? string "")
+                    (url-error "Can't resolve empty string as URL")
+                    (begin
+                      (set-url-scheme! url
+                                       (if (char=? (string-ref string 0) #\/)
+                                           "file"
+                                           "http"))
+                      url))))))
+
+      ;; string->url : str -> url
+      ;; New implementation, mostly provided by Neil Van Dyke
+      (define string->url
+        (let ((rx (regexp (string-append
+                           "^"
+                           "[ \t\f\r\n]*"
+                           "("                ; <1  front-opt
+                           "([a-zA-Z]*:)?"    ; =2  scheme-colon-opt
+                           "("                ; <3  slashslash-opt
+                           "//"
+                           "([^:/@;?#]*@)?"   ; =4  user-at-opt
+                           "([^:/@;?#]+)?"    ; =5  host-opt
+                           "(:[0-9]*)?"       ; =6  colon-port-opt
+                           ")?"               ; >3  slashslash-opt
+                           ")?"               ; >1  front-opt
+                           "([^?#]*)"         ; =7  path
+                           "(\\?[^#]*)?"      ; =8  question-query-opt
+                           "(#.*)?"           ; =9 hash-fragment-opt
+                           "[ \t\f\r\n]*"
+                           "$"))))
+          (lambda (str)
+            (let ([m (regexp-match #rx"^[ \t\f\r\n]*file:(.*)$" str)])
+              ;; File scheme:
+              (if m
+                  (let ([path+fragment (regexp-match #rx"^([^#]*)(#(.*))?$" (cadr m))])
+                    (let ([path (cadr path+fragment)]
+                          [fragment (caddr path+fragment)])
+                      (if (or (relative-path? path)
+                              (absolute-path? path))
+                          (make-url "file"
+                                    #f  ; user
+                                    #f  ; host
+                                    #f  ; port
+                                    (separate-path-strings path)
+                                    '()  ; query
+                                    fragment)
+                          (url-error "scheme 'file' path ~s neither relative nor absolute" path))))
+                  ;; Other scheme:
+                  (let ((match (regexp-match-positions rx str)))
+                    (if match
+                        (let* ((get-str (lambda (pos skip-left skip-right)
+                                          (let ((pair (list-ref match pos)))
+                                            (if pair
+                                                (substring str
+                                                           (+ (car pair) skip-left)
+                                                           (- (cdr pair) skip-right))
+                                                #f))))
+                               (get-num (lambda (pos skip-left skip-right)
+                                          (let ((s (get-str pos skip-left skip-right)))
+                                            (if s (string->number s) #f))))
+                               (host (get-str 5  0 0)))
+                          (make-url (get-str 2  0 1) ; scheme
+                                    (uri-decode/maybe (get-str 4  0 1)) ; user
+                                    host
+                                    (get-num 6  1 0) ; port
+                                    (separate-path-strings
+                                     (let ([path (get-str 7  0 0)])
+                                       ;; If path is "" and the input is an absolute URL
+                                       ;; with a hostname, then the intended path is "/",
+                                       ;; but the URL is missing a "/" at the end.
+                                       (if (and (string=? path "")
+                                                host)
+                                           "/"
+                                           path)))
+                                    ;(uri-decode/maybe (get-str 8  1 0)) ;
+                                    ;query
+                                    (let ([q (get-str 8 1 0)])
+                                      (if q (form-urlencoded->alist q) '()))
+                                    (uri-decode/maybe (get-str 9  1 0)) ; fragment
+                                    ))
+                        (url-error "Invalid URL string: ~e" str))))))))
+
+      (define (uri-decode/maybe f)
+        ;; If #f, and leave unmolested any % that is followed by hex digit
+        ;; if a % is not followed by a hex digit, replace it with %25
+        ;; in an attempt to be "friendly"
+        (and f (uri-decode (regexp-replace* "%([^0-9a-fA-F])" f "%25\\1"))))
+
+      ;; separate-path-strings : string[starting with /] -> (listof (union string path/param))
+      (define (separate-path-strings str)
+        (cond
+          [(string=? str "") '()]
+          [else
+           (let loop ([str (if (char=? #\/ (string-ref str 0))
+                               (substring str 1 (string-length str))
+                               str)])
+             (cond
+               [(regexp-match #rx"([^/]*)/(.*)$" str)
+                =>
+                (lambda (m)
+                  (cons (maybe-separate-params (cadr m)) (loop (caddr m))))]
+               [else (list (maybe-separate-params str))]))]))
+
+      (define (maybe-separate-params s)
+        (cond
+          [(regexp-match #rx"^([^;]*);(.*)$" s)
+           =>
+           (lambda (m)
+             (make-path/param (cadr m) (caddr m)))]
+          [else s]))
+
+      (define (combine-path-strings strs)
+        (apply
+         string-append
+         (let loop ([strs strs])
+           (cond
+             [(null? strs) '()]
+             [else (list* "/"
+                          (maybe-join-params (car strs))
+                          (loop (cdr strs)))]))))
+
+      ;; needs to unquote things!
+      (define (maybe-join-params s)
+        (cond
+          [(string? s) s]
+          [else (string-append (path/param-path s)
+                               ";"
+                               (path/param-param s))])))))
diff --git a/collects/net/url.ss b/collects/net/url.ss
new file mode 100644
index 0000000000..53e3df90f1
--- /dev/null
+++ b/collects/net/url.ss
@@ -0,0 +1,48 @@
+(module url mzscheme
+  (require (lib "unitsig.ss")
+           (lib "contract.ss")
+           "url-sig.ss"
+           "url-unit.ss"
+           "tcp-sig.ss"
+           "tcp-unit.ss")
+
+  (define-values/invoke-unit/sig
+   net:url^
+   (compound-unit/sig
+     (import)
+     (link
+      [T : net:tcp^ (tcp@)]
+      [U : net:url^ (url@ T)])
+     (export (open U))))
+
+  (provide/contract
+   (struct url ([scheme (union false/c string?)]
+                [user (union false/c string?)]
+                [host (union false/c string?)]
+                [port (union false/c number?)]
+                [path (listof (union string? path/param?))]
+                [query (listof (cons/c symbol? string?))]
+                [fragment (union false/c string?)]))
+   (struct path/param ([path string?]
+                       [param string?]))
+   (string->url ((union bytes? string?) . -> . url?))
+   (url->string (url? . -> . string?))
+
+   (get-pure-port (opt-> (url?) ((listof string?)) input-port?))
+   (get-impure-port (opt-> (url?) ((listof string?)) input-port?))
+   (post-pure-port (opt-> (url? (union false/c bytes?)) ((listof string?)) input-port?))
+   (post-impure-port (opt-> (url? bytes?) ((listof string?)) input-port?))
+   (display-pure-port (input-port? . -> . void?))
+   (purify-port (input-port? . -> . string?))
+   (netscape/string->url (string? . -> . url?))
+   (call/input-url (opt->* (url?
+			    (opt-> (url?) ((listof string?)) input-port?)
+			    (input-port? . -> . any))
+			   ((listof string?))
+			   any))
+   (combine-url/relative (url? string? . -> . url?))
+   (url-exception? (any/c . -> . boolean?))
+   (current-proxy-servers
+    (case-> ((union false/c (listof (list/c string? string? number?))) . -> . void?)
+            (-> (union false/c (listof (list/c string? string? number?))))))))
+
diff --git a/collects/openssl/doc.txt b/collects/openssl/doc.txt
new file mode 100644
index 0000000000..6f86b77ee5
--- /dev/null
+++ b/collects/openssl/doc.txt
@@ -0,0 +1,237 @@
+The _openssl_ collection provides glue for the OpenSSL library with
+the MzScheme port system. The OpenSSL collection functions nearly
+identically to the standard TCP subsystems in PLT Scheme, with a few
+additional flags.
+
+To use this library, you will need OpenSSL installed on your
+machine, but
+
+ * the PLT-distributed archive for Windows installs the necessary
+   DLLs, and
+
+ * Mac OS X 10.2 provides the necessary OpenSSL libraries
+   (as do some other operating systems).
+
+To build from source, you will need a C compiler and linker;
+see the end of this documentation for build notes.
+
+==================================================
+
+_mzssl.ss_ library
+
+The variables below are provided the by "mzssl.ss" library.
+
+> ssl-available? 
+
+A boolean value which says whether the system openssl library was
+successfully loaded. Calling `ssl-connect', etc.  when this value is
+#f (library not loaded) will raise an error.
+
+
+-- Client procedures ----------------------------------------
+
+> (ssl-connect hostname port-k [ssl-client-context-or-protocol-symbol])
+
+Connect to the given host (a string) on the given port-k (a number
+from 1 to 65535). This connection will be encrypted using SSL.  The
+return values are as tcp-connect; an input port and an output port.
+
+The optional `ssl-context-or-protocol-symbol' argument determines
+which encryption protocol is used, whether the server's certificate is
+checked, etc. The argument can be either a client context created by
+`make-client-context' (see below), or one of the following symbols:
+'sslv2-or-v3 (the default), 'sslv2, 'sslv3, or 'tls; see
+`make-client-context' for further details (including the meanings of
+the protocol symbols.)
+
+
+> (ssl-connect/enable-break hostname port-k [protocol-symbol])
+
+Like `ssl-connect', but breaking is enabled while trying to connect. 
+
+
+> (ssl-make-client-context [protocol-symbol])
+
+Creates a context to be supplied to `ssl-connect'. The context
+identifis a communication protocol (as selected by `protocol-symbol'),
+and also holds certificate information (i.e., the client's identity,
+its trusted certificate authorities, etc.). See the "Certificate
+procedures" section below for more information on certificates.
+
+The `protocol-symbol' must be one of the following:
+
+ * _'sslv2-or-v3_ : SSL protocol versions 2 or 3, as
+                     appropriate (this is the default)
+
+ * _'sslv2_ : SSL protocol version 2
+
+ * _'sslv3_ : SSL protocol version 3
+
+ * _'tls_ : the TLS protocol version 1
+
+By default, the context returned by `ssl-make-client-context' does not
+request verification of a server's certificate. Use `ssl-set-verify!'
+to enable such verification.
+
+
+> (ssl-client-context? v)
+
+Returns #t if `v' is a value produced by `ssl-make-client-context', #f
+otherwise.
+
+
+-- Server procedures ----------------------------------------
+
+> (ssl-listen port-k [queue-k reuse? hostname-or-#f protocol-symbol])
+
+Like `tcp-listen', but the result is an SSL listener (which is a
+waitable object). The extra optional `protocol-symbol' is as for
+`ssl-connect'.
+
+Call `ssl-load-certificate-chain!' and `ssl-load-private-key!' to
+avoid a _no shared cipher_ error on accepting connections. The file
+"test.pem" in the "openssl" collection is a suitable argument for both
+calls when testing. Since "test.pem" is public, however, such a test
+configuration obviously provides no security.
+
+
+> (ssl-close ssl-listener)
+> (ssl-listener? v)
+
+Analogous to `tcp-close' and `tcp-listener?'.
+
+
+> (ssl-accept ssl-listener)
+
+Analogous to `tcp-accept'.
+
+
+> (ssl-accept/enable-break ssl-listener)
+
+Analogous to `tcp-accept/enable-break'.
+
+
+-- Certificate procedures ----------------------------------------
+
+> (ssl-load-certificate-chain! ssl-client-context-or-listener pathname)
+
+Loads a PEM-format certification chain file for connections to made
+with the given context (created by `ssl-make-context') or listener
+(created by `ssl-listener').
+
+This chain is used to identify the client or server when it connects
+or accepts connections. Loading a chain overwrites the old chain. Also
+call `ssl-load-private-key!' to load the certificate's corresponding
+key.
+
+The file "test.pem" is suitable for testing purposes. Since "test.pem"
+is public, such a test configuration obviously provides no security.
+
+
+> (ssl-load-private-key! ssl-client-context-or-listener pathname [rsa? asn1?])
+
+Loads the first private key from `pathname' for the given client
+context or listener. The key goes with the certificate that identifies
+the client or server.
+
+If `rsa?' is #t (the default), the first RSA key is read (i.e.,
+non-RSA keys are skipped). If `asn1?' is #t (the default is #f), the
+file is parsed as ASN1 format instead of PEM.
+
+The file "test.pem" is suitable for testing purposes. Since "test.pem"
+is public, such a test configuration obviously provides no security.
+
+
+> (ssl-set-verify! ssl-client-context-or-listener boolean)
+
+Enables or disables verification of a connection peer's certificates.
+By default, verification is disabled.
+
+Enabling verification also requires, at a minimum, designating trusted
+certificate authorities with `ssl-load-verify-root-certificates!'.
+
+
+> (ssl-load-verify-root-certificates! ssl-client-context-or-listener pathname)
+
+Loads a PEM-format file containing trusted certificates that are used
+to verify the certificates of a connection peer. Call this procedure
+multiple times to load multiple sets of trusted certifactes.
+
+The file "test.pem" is suitable for testing purposes where the peer
+identifies itself using "test.pem".  Since "test.pem" is public, such
+a test configuration obviously provides no security.
+
+
+> (ssl-load-suggested-certificate-authorities! ssl-listener pathname)
+
+Loads a PEM-format file containing certificates that are used by a
+server. The certificate list is sent to a client when the server
+requests a certificate as an indication of which certificates the
+server trusts.
+
+Loading the suggested certifcicates does not imply trust, however; any
+certificate presented by the client will be checked using the trusted
+roots loaded by `ssl-load-verify-root-certificates!'.
+
+The file "test.pem" is suitable for testing purposes where the peer
+identifies itself using "test.pem".
+
+
+==================================================
+
+Build notes
+-----------
+
+The "mzssl.ss" library is actually implemented in C as "mzssl.c".
+When you run Setup PLT, setup attempts to compile and link "mzssl.c"
+to create a PLT Scheme extension.
+
+Per-platform notes:
+
+ * Windows
+
+   The setup script needs "libeay32.lib" and "ssleay32.lib", which it
+   can find automatically if they are installed as
+   plt/collects/openssl/openssl/lib/{lib,ssl}easy32.lib. Similarly, the
+   setup script needs several OpenSSL header files (such as "ssl.h"),
+   which it can find automatically if they are installed as
+   plt/collects/openssl/openssl/include/openssl/ssl.h, etc.
+
+   At run-time, the DLLs "libeay32.dll" and "ssleay32.dll" must be
+   found by Windows as it tries to load the "mzssl.dll" extension. For
+   example, if the two DLLs are installed in the system folder, they
+   will be found. (Another possibility is the folder containing the
+   ".exe" that uses the "mzssl.dll" extension.)
+
+   To designate a directory other than plt/collects/openssl/openssl
+   for .lib and .h files, define the environment variable
+   PLT_EXTENSION_LIB_PATHS. The variable's value should be a
+   semicolon-separated path list, where one of the paths contains
+   "include" and "lib" subdirectories with the OpenSSL headers and
+   libraries.
+
+   If OpenSLL is built with cygwin, ".a" files are generated instead
+   of ".lib" an ".dll" files. Presumably "mzssl.c" could be made to
+   build with those libraries by modifying "pre-installer.ss", but we
+   haven't tried. Similar caveats apply to other build techniques that
+   do not produce DLLs.
+
+   Bonus hack: If "{lib,ssl}easy32xxxxxxx.lib" exist in the lib
+   directory, they are used (instead of "{liib,ssl}eay32.lib") with
+   the expectation that the resulting extension will link to
+   "{lib,ssl}eay32xxxxxxx.dll". This enables the name-mangling version
+   hack for distributing DLLs.
+
+ * Mac OS
+
+   "Just works" for Mac OS X version >= 10.2 if you have the developer
+   tools installed. Building for 10.1 requires installing OpenSSL. Mac
+   OS Classic is not supported at all.
+
+ * Unix (including Linux)
+
+   Usually "just works" if you have OpenSSL installed.  If the header
+   files or libraries are in a non-standard place, define the
+   environment variable PLT_EXTENSION_LIB_PATHS as a colon-separated
+   path list, where one of the paths contains "include" and "lib"
+   subdirectories with the OpenSSL headers and libraries.
diff --git a/collects/openssl/info.ss b/collects/openssl/info.ss
new file mode 100644
index 0000000000..b442356651
--- /dev/null
+++ b/collects/openssl/info.ss
@@ -0,0 +1,9 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "SSL Driver")
+  (define doc.txt "doc.txt")
+  (define compile-omit-files '("mzssl.ss"))
+  (define pre-install-collection "pre-installer.ss")
+  (define blurb '("The SSL collection provides a driver for using the OpenSSL "
+		  "secure connection library."))
+  (define release-version "299")
+  (define release-iteration "0"))
diff --git a/collects/openssl/make-archive.ss b/collects/openssl/make-archive.ss
new file mode 100644
index 0000000000..9d45878d29
--- /dev/null
+++ b/collects/openssl/make-archive.ss
@@ -0,0 +1,147 @@
+
+;; This module creates openssl-<version>.<platform>.plt.
+;;
+;; For Windows and Mac OS X, it creates an archive
+;; with a "precompiled" subdirectory containing
+;; the compiled extension.
+;; 
+;; For Windows, it also arranges for
+;;  {lib,sll}eay32<version>.dll
+;; to be in the archive, and it mangles the extension
+;; to replace references to 
+;;  {lib,sll}eay32xxxxxxx.dll
+;; to the versioned names. The xxxxxxx DLLs must
+;; be in the PLT directory (two levels up from here)
+;; to be compied and version-mangled.
+
+(module make-archive mzscheme
+  (require (lib "pack.ss" "setup")
+	   (lib "file.ss")
+	   (lib "cmdline.ss"))
+
+  (define target-sys-type (system-type))
+
+  (command-line
+   "make-archive"
+   (current-command-line-arguments)
+   (once-each
+    [("-s" "--src") "Make source bundle"
+     (set! target-sys-type 'unix)]))
+
+  (define tmp-dir (find-system-path 'temp-dir))
+  (define work-dir (build-path tmp-dir "mk-openssl-plt"))
+
+  (when (directory-exists? work-dir)
+    (error 'make-archive "please delete leftover work directory: ~a"
+	   work-dir))
+
+  (make-directory work-dir)
+
+  (printf "Working in ~a~n" work-dir)
+
+  (define ssl-target-dir (build-path work-dir "collects" "openssl"))
+
+  (make-directory* ssl-target-dir)
+
+  (define (copy-files from to re)
+    (for-each (lambda (f)
+		(when (and (file-exists? (build-path from f))
+			   (regexp-match re f)
+			   (not (regexp-match #rx"~$" f))
+			   (not (regexp-match #rx"[.]plt$" f))
+			   (not (regexp-match #rx"^#.*#$" f))
+			   (not (regexp-match #rx"^[.]#" f)))
+		  (copy-file (build-path from f) (build-path to f))))
+	      (directory-list from)))
+
+  (copy-files (collection-path "openssl") ssl-target-dir #rx".")
+
+  (unless (eq? target-sys-type 'unix)
+    (let ()
+      (define pre-dir (build-path ssl-target-dir "precompiled" "native" (system-library-subpath)))
+
+      (make-directory* pre-dir)
+      
+      (copy-files (build-path (collection-path "openssl")
+			      "compiled"
+			      "native"
+			      (system-library-subpath))
+		  pre-dir
+		  (if (eq? target-sys-type 'windows)
+		      #rx"[.]dll$"
+		      #rx"[.]so$"))
+      
+      (when (eq? target-sys-type 'windows)
+	;; Assume that the xxxx-ized versions of the DLLs are in
+	;; the plt directory:
+	(let* ([new-version (substring
+			     (regexp-replace*
+			      "alpha"
+			      (format "~a_000000000" (version))
+			      "a")
+			     0
+			     7)]
+	       [target-name
+		(lambda (x)
+		  (format "~aeay32~a.dll" x new-version))]
+	       [move-dll
+		(lambda (x)
+		  (copy-file (build-path (collection-path "openssl")
+					 'up 'up
+					 (format "~aeay32xxxxxxx.dll" x))
+			     (build-path pre-dir 
+					 (target-name x))))])
+	  (move-dll "lib")
+	  (move-dll "ssl")
+
+	  ;; Mangle xxxxxxxx to a version:
+	  (let ([fixup
+		 (lambda (f)
+		   (let ([p (build-path pre-dir f)])
+		     (let ([i (open-input-file p)]
+			   [o (open-output-file p 'append)])
+		       (let loop ()
+			 (file-position i 0)
+			 ;; This is a poor technique for updating the files, but
+			 ;;  it works well enough.
+			 (let ([m (regexp-match-positions #rx"[eE][aA][yY]32xxxxxxx" i)])
+			   (when m
+				 (file-position o (+ (caar m) 5))
+				 (display new-version o)
+				 (loop))))
+		       (close-input-port i)
+		       (close-output-port o))))])
+	    (fixup "mzssl.dll")
+	    (fixup (target-name "lib"))
+	    (fixup (target-name "ssl")))))
+
+      'done))
+
+  (parameterize ([current-directory work-dir])
+    (pack "openssl.plt"
+	  "OpenSSL for PLT"
+	  (list (build-path "collects" "openssl"))
+	  '(("openssl"))
+	  (lambda (x) #t) ; filter nothing
+	  #t
+	  'file
+	  #f
+	  #t ;; plt-relative
+	  null ;; FIXME - we need better version tracking!
+	  '(("openssl"))
+	  #t)) ;; rel to PLTHOME
+
+  (define dest  (format "openssl-~a.~a.plt" 
+			(version)
+			(case target-sys-type
+			  [(windows) "i386-win32"]
+			  [(macosx) "ppc-macosx"]
+			  [else "src"])))
+  
+  (when (file-exists? dest)
+    (delete-file dest))
+  (copy-file (build-path work-dir "openssl.plt") dest)
+
+  (delete-directory/files work-dir)
+
+  (printf "Output to ~a~n" dest))
diff --git a/collects/openssl/mzssl.c b/collects/openssl/mzssl.c
new file mode 100644
index 0000000000..c42b568746
--- /dev/null
+++ b/collects/openssl/mzssl.c
@@ -0,0 +1,1837 @@
+/* ssl.c: an extension to PLT MzScheme to allow SSL connections */
+
+#define OPENSSL_NO_KRB5
+
+#include <openssl/ssl.h>
+#include <openssl/err.h>
+#include "escheme.h"
+
+#ifdef USE_UNIX_SOCKETS_TCP
+# include <sys/types.h>
+# include <netinet/in.h>
+# include <netdb.h>
+# include <sys/socket.h>
+# include <sys/time.h>
+# include <fcntl.h>
+# include <unistd.h>
+# include <errno.h>
+# define SOCK_ERRNO() errno
+# define NOT_WINSOCK(x) (x)
+# define INVALID_SOCKET (-1)
+# define WAS_EINPROGRESS(e) ((e == EINPROGRESS))
+# define mz_h_errno() h_errno
+# define mz_hstrerror(x) dup_errstr(hstrerror(x))
+#endif
+
+#ifdef USE_WINSOCK_TCP
+# include <winsock.h>
+# define SOCK_ERRNO() WSAGetLastError()
+# define NOT_WINSOCK(x) 0
+# define WAS_EINPROGRESS(e) ((e == WSAEWOULDBLOCK))
+# define mz_h_errno() WSAGetLastError()
+# define mz_hstrerror(x) NULL
+#endif
+
+/* stolen from $(PLTHOME}/src/mzscheme/src/schpriv.h */
+#ifdef USE_FCNTL_O_NONBLOCK
+# define MZ_NONBLOCKING O_NONBLOCK
+#else
+# define MZ_NONBLOCKING FNDELAY
+#endif
+
+/* stolen from $(PLTHOME)/src/mzscheme/src/network.c */
+# ifdef PROTOENT_IS_INT
+#  define PROTO_P_PROTO PROTOENT_IS_INT
+# else
+#  define PROTO_P_PROTO proto->p_proto
+# endif
+
+/* stolen from $(PLTHOME)/src/mzscheme/src/schfd.h */
+#ifdef USE_FAR_MZ_FDCALLS
+# define DECL_FDSET(n, c) static fd_set *n
+# define INIT_DECL_FDSET(n, c) (n = (n ? (fd_set *)scheme_init_fdset_array(n,c)\
+                                       : (fd_set*)scheme_alloc_fdset_array(c,1)))
+#else
+# define DECL_FDSET(n, c) fd_set n[c]
+# define INIT_DECL_FDSET(n, c) /* empty */
+#endif
+
+struct sslplt {
+#ifdef MZ_PRECISE_GC
+  Scheme_Type type;
+#endif
+  SSL *ssl;
+  char *obuffer; /* Buffer for outgoing bytes, but this is not a "buffer"
+		    at the Scheme level. A daemon thread flushes it.
+		    This is necessary because there's no way to know
+		    whether a write to SSL will succeed, and handing
+		    WANT_READ and WANT_WRITE requires consistent
+		    calls to SSL_write. */
+  int ob_used;  /* Length of data in obuffer. */
+  char ibuffer; /* One char is enough because SSL_read doesn't appear
+		   to actually need consistency for WANT_READ and WANT_WRITE.
+		   Or maybe I've just been [un]lucky. */
+  char ib_used; /* 0 or 1, length of data in ibuffer */
+  char close_in, close_out;
+  char write_blocked_reason; /* 0 => might not be blocked, 1 => for read, 2 => for write */
+  struct sslplt *next;
+};
+
+#define OBUFFER_SIZE 4096
+
+typedef struct {
+  Scheme_Object so;
+  int s;
+  Scheme_Custodian_Reference *mref;
+  SSL_CTX *ctx;
+} listener_t;
+
+typedef struct {
+  Scheme_Object so;
+  SSL_CTX *ctx;
+} mzssl_ctx_t;
+
+static Scheme_Type ssl_listener_type;
+static Scheme_Type ssl_ctx_type;
+#ifdef MZ_PRECISE_GC
+static Scheme_Type sslplt_type;
+#endif
+
+#define LISTENER_WAS_CLOSED(x) (((listener_t *)(x))->s == INVALID_SOCKET)
+
+#ifndef MZ_PRECISE_GC
+# define GC_CAN_IGNORE /* empty */
+# define XFORM_OK_PLUS +
+#endif
+
+/* create_ register_sslplt: called when a new sslplt structure needs to be 
+   created. */
+struct sslplt *create_register_sslplt(SSL *ssl)
+{
+  struct sslplt *sslplt;
+  char *obuffer;
+
+#ifdef MZ_PRECISE_GC
+  sslplt = (struct sslplt *)scheme_malloc_tagged(sizeof(struct sslplt));
+  sslplt->type = sslplt_type;
+#else
+  sslplt = (struct sslplt *)scheme_malloc(sizeof(struct sslplt));
+#endif
+
+  obuffer = (char *)scheme_malloc_atomic(OBUFFER_SIZE);
+
+  sslplt->ssl = ssl;
+  sslplt->ib_used = 0; sslplt->ob_used = 0; 
+  sslplt->close_in = 0; sslplt->close_out = 0;
+  sslplt->write_blocked_reason = 0;
+  sslplt->obuffer = obuffer;
+  return sslplt;
+}
+
+/*****************************************************************************
+ * GENERC SOCKET CHECKS: ready? and needs-wakeup.                            *
+ *****************************************************************************/
+
+int check_socket_ready(int s, int for_write)
+{
+  DECL_FDSET(writefds, 1);
+  DECL_FDSET(exnfds, 1);
+  struct timeval time = {0, 0};
+  int res;
+
+  INIT_DECL_FDSET(writefds, 1);
+  INIT_DECL_FDSET(exnfds, 1);
+
+  MZ_FD_ZERO(writefds);
+  MZ_FD_SET(s, writefds);
+  MZ_FD_ZERO(exnfds);
+  MZ_FD_SET(s, exnfds);
+
+  do {
+    res = select(s + 1, 
+		 for_write ? NULL : writefds, 
+		 for_write ? writefds : NULL, 
+		 exnfds, &time);
+  } while((res == -1) && NOT_WINSOCK(errno == EINTR));
+
+  return res;
+}
+
+void socket_add_fds(int s, void *fds, int for_write)
+{
+  void *fds1, *fds2;
+  
+  fds1 = MZ_GET_FDSET(fds, (for_write ? 1 : 0));
+  fds2 = MZ_GET_FDSET(fds, 2);
+  MZ_FD_SET(s, (fd_set *)fds1);
+  MZ_FD_SET(s, (fd_set *)fds2);
+}
+
+/*****************************************************************************
+ * TOP-LEVEL THREAD: This is the routine and data involved with running the  *
+ * top level thread (the one that helps us fake a couple guarantees).        *
+ * When output can't be written without blocking, we put one char in a       *
+ * and promise to flush in a priviledged daemon thread. If this one-char     *
+ * buffer is empty, we can promise a "non-blocking" write to the Scheme      *
+ * level. We need the one-char buffer because the SSL layer offers no way to *
+ * get a promise that at least one character can be written without          *
+ * blocking.                                                                 *
+ *****************************************************************************/
+Scheme_Object *daemon_attn = NULL;
+struct sslplt *ssls = NULL;
+
+int daemon_ready(Scheme_Object *ignored)
+{
+  struct sslplt *cur;
+
+  for (cur = ssls; cur; cur = cur->next) {
+    if (!cur->write_blocked_reason) {
+      /* Newly queued, or someone else operated on the same
+	 SSL connection, so we should try again. */
+      return 1;
+    } else
+      /* The SLL layer is waiting for either input or output
+	 on the underlying socket: */
+      if (check_socket_ready(BIO_get_fd(SSL_get_wbio(cur->ssl), NULL),
+			     (cur->write_blocked_reason == 2)))
+	return 1;
+  }
+
+  return 0;
+}
+
+void deamon_needs_wakeup(Scheme_Object *ignored, void *fds)
+{
+  struct sslplt *cur;
+
+  for (cur = ssls; cur; cur = cur->next) {
+    if (!cur->write_blocked_reason)
+      scheme_cancel_sleep();
+    else
+      socket_add_fds(BIO_get_fd(SSL_get_wbio(cur->ssl), NULL),
+		     fds,
+		     (cur->write_blocked_reason == 2));
+  }
+}
+
+
+/* write_close_thread: this is the thread that flushes out our buffers
+   automatically and/or closes items which need closing */
+Scheme_Object *write_close_thread(int argc, Scheme_Object *argv[])
+{
+  struct sslplt *cur, *prev;
+  int empty;
+
+  /* this thread should not terminate unless killed externally */
+  while (1) {
+    /* Wait until there's something to do: */
+    scheme_wait_sema(daemon_attn, 0);
+
+    while (1) {
+      cur = ssls; prev = NULL;
+      while (cur) {
+	int status, drop = 1;
+
+	if (cur->ob_used) {
+	  cur->write_blocked_reason = 0;
+
+	  /* Try to write: */
+	  status = SSL_write(cur->ssl, cur->obuffer, cur->ob_used);
+
+	  if (status >= 1) {
+	    cur->ob_used -= status;
+	    if (cur->ob_used) {
+	      memmove(cur->obuffer, cur->obuffer + status, cur->ob_used);
+	      drop = 0;
+	    }
+	  } else {
+	    int err;
+	    drop = 0;
+	    err = SSL_get_error(cur->ssl, status);
+	    if (err == SSL_ERROR_WANT_READ) {
+	      cur->write_blocked_reason = 1;
+	    } else if (err == SSL_ERROR_WANT_WRITE) {
+	      cur->write_blocked_reason = 2;
+	    } else {
+	      /* Some error. We drop the char, and assume
+		 that it's not a transient error, so the
+		 next action will find the same error. */
+	      drop = 1;
+	      cur->ob_used = 0;
+	    }
+	  }
+	} else if (cur->close_in && cur->close_out) {
+	  /* Apparently a force close */
+          SSL_free(cur->ssl);
+        }
+	/* there shouldn't be a 3rd possibility */
+	
+	if (!drop) {
+	  prev = cur; 
+	} else{
+	  if (prev)
+	    prev->next = cur->next;
+	  else
+	    ssls = cur->next;
+	}
+	cur = cur->next;
+      }
+      empty = !ssls;
+   
+      if (empty)
+	break;
+
+      /* wait until something becomes unblocked, or something new is queued */
+      scheme_block_until(daemon_ready, deamon_needs_wakeup, NULL, (float)0.0);
+    }
+  }
+}
+
+/*****************************************************************************
+ * ERROR FUNCTIONs: wrap the SSL error reporter to get a string and error    *
+ * number that fits into MzScheme's %Z convention.                           *
+ * Also, copy error strings provided libraries, in case of a thread swap     *
+ * between the time the string is obtained and the string is put into an     *
+ * error message (otherwise the string could get overwritten?).              *
+ *****************************************************************************/
+
+static const char *dup_errstr(const char *s) {
+  char *t;
+  long len;
+  if (s){
+    len = strlen(s);
+    t = scheme_malloc_atomic(len+1);
+    memcpy(t, s, len+1);
+    return t;
+  } else
+    return s;
+}
+
+static int get_ssl_error_msg(int errid, const char **msg, int status, int has_status)
+{
+  if ((errid == SSL_ERROR_SYSCALL) && has_status) {
+    if (status == 0) {
+      *msg = "unexpected EOF";
+    } else {
+      *msg = NULL;
+      errid = SOCK_ERRNO();
+    }
+  } else {
+    const char *c;
+    char buf[121];
+
+    if (errid == SSL_ERROR_SSL) {
+      errid = ERR_get_error();
+    }
+
+    if (errid && (ERR_GET_LIB(errid) == ERR_LIB_SYS)) {
+      *msg = NULL;
+      return ERR_GET_REASON(errid);
+    } else {
+      memset(buf, 0, 121);
+      /* wants a buffer of size 120: */
+      ERR_error_string(errid, buf);
+
+      c = dup_errstr(buf);
+      if (c)
+	*msg = c;
+      else
+	*msg = "Unknown error";
+    }
+  }
+
+  return errid;
+}
+
+/*****************************************************************************
+ * INPORT PORT FUNCTIONS: This is the stuff that works on input ports. This  *
+ * is a little complicated because we have to get char_ready to work on top  *
+ * of a system that doesn't have such a function. So we buffer one character *
+ * as necessary.                                                             *
+ *****************************************************************************/
+
+/* this is the new subtype we're creating */
+static Scheme_Object *ssl_input_port_type = NULL; 
+
+/* forward decls: */
+static void sslin_need_wakeup(Scheme_Input_Port *port, void *fds);
+static int sslin_char_ready(Scheme_Input_Port *port);
+
+/* ssl_get_string: read a sequence of bytes into a buffer given to us. This is 
+   made severely annoying by the nonblocking nature of the socket stream and 
+   the possibly blocking nature that mzscheme might want from us. */
+long ssl_do_get_string(Scheme_Input_Port *port, char *buffer, long offset,
+		       long size, int nonblocking, 
+		       int *stuck_why, int err_ok,
+		       Scheme_Object *unless) 
+{
+  const char *errstr = "Unknown error";
+  int err = 0;
+  long status = 0;
+  long bytes_read = 0;
+  struct sslplt *ssl = (struct sslplt *)SCHEME_INPORT_VAL(port);
+
+  while (!bytes_read) {
+    /* check unless before anything else */
+    if (scheme_unless_ready(unless))
+      return SCHEME_UNLESS_READY;
+
+    /* check the buffer */
+    if(ssl->ib_used) {
+      buffer[offset + bytes_read] = ssl->ibuffer;
+      bytes_read++; 
+      ssl->ib_used = 0;
+    }
+
+    /* make sure people aren't being sneaky */
+    if(ssl->close_in) {
+      errstr = "read from closed port!";
+      goto read_error;
+    }
+    
+    /* re-check writes,if any are blocked, since we're touching the
+       ssl channel */
+    ssl->write_blocked_reason = 0;
+  
+    if (ssl->ob_used) {
+      /* A write needs to be re-tried. Can't read until then. */
+      bytes_read = 0;
+      *stuck_why = 3;
+    } else {
+      /* read the data. maybe. hopefully. please. */
+      status = SSL_read(ssl->ssl, 
+			buffer XFORM_OK_PLUS offset XFORM_OK_PLUS bytes_read, 
+			size-bytes_read);
+      
+      if(status < 1) {
+	/* see what kind of error this was */
+	err = SSL_get_error(ssl->ssl, status);
+
+	/* see if we've hit the end of file */
+	if ((err == SSL_ERROR_ZERO_RETURN)
+	    || ((err == SSL_ERROR_SYSCALL) && !status)) {
+	  if(bytes_read == 0)
+	    return EOF;
+	  else
+	    return bytes_read;
+	} else if ((err != SSL_ERROR_WANT_READ) && (err != SSL_ERROR_WANT_WRITE)) {
+	  /* critical error */
+	  if (!err_ok) return 0;
+
+	  err = get_ssl_error_msg(err, &errstr, status, 1);
+	  goto read_error;
+	}
+
+	*stuck_why = ((err == SSL_ERROR_WANT_READ) ? 1 : 2);
+      } else
+	bytes_read += status;
+    }
+
+    if (nonblocking > 0)
+      break;
+
+    /* It might be tempting at this point to block on the fd
+       for reading if SSL_ERROR_WANT_READ. That would be a bad
+       idea, because another thread might be using the port,
+       and might shift it into SSL_ERROR_WANT_WRITE mode.
+       Use the general sll input blocking functions. */
+
+    if (!bytes_read) {
+      while (!sslin_char_ready(port)) {
+	scheme_block_until_unless((Scheme_Ready_Fun)sslin_char_ready, 
+				  (Scheme_Needs_Wakeup_Fun)sslin_need_wakeup,
+				  (void *)port, (float)0.0,
+				  unless,
+				  nonblocking < 0);
+	
+	scheme_wait_input_allowed(port, nonblocking);
+	
+	if (scheme_unless_ready(unless))
+	  return SCHEME_UNLESS_READY;
+      }
+    }
+  }
+  
+  return bytes_read;
+
+ read_error:
+  scheme_raise_exn(MZEXN_FAIL_NETWORK, 
+		   "ssl-read: error reading (%Z)",
+		   err, errstr);
+  return 0; /* needless, but it makes GCC happy */
+}
+
+long ssl_get_string(Scheme_Input_Port *port, char *buffer, long offset,
+		    long size, int nonblocking,
+		    Scheme_Object *unless) 
+{
+  int stuck_why;
+
+  return ssl_do_get_string(port, buffer, offset, size, nonblocking, 
+			   &stuck_why, 1,
+			   unless);
+}
+
+/* sslin_char_ready: return 1 (true) iff a nonblocking call to get_string 
+   can read at least one character (that is, it won't return 0). This 
+   function is the cause of a bit of suffering, actually. */
+static int sslin_do_char_ready(Scheme_Input_Port *port, int *stuck_why)
+{
+  struct sslplt *ssl = SCHEME_INPORT_VAL(port);
+  char buf[1];
+  int r;
+  
+  *stuck_why = 0;
+
+  if (ssl->close_in) return 1;
+
+  /* see if the buffer has something in it, and if so, return true */
+  if(ssl->ib_used) return 1;
+
+  /* otherwise, try to read a character in */
+  r = ssl_do_get_string(port, buf, 0, 1, 1, stuck_why, 0, NULL);
+  if (r) {
+    if (r != EOF) {
+      ssl->ib_used = 1;
+      ssl->ibuffer = ((unsigned char *)buf)[0];
+    }
+    return 1;
+  }
+
+  if (!*stuck_why) {
+    /* not-yet-reported error */
+    return 1;
+  }
+
+  /* nothing buffered and we can't read, so the answer is no */
+  return 0;
+}
+
+static int sslin_char_ready(Scheme_Input_Port *port)
+{
+  int stuck_why;
+
+  return sslin_do_char_ready(port, &stuck_why);
+}
+
+/* sslin_close: close down a buffer, freeing the temporary structures we
+   created. */
+void sslin_close(Scheme_Input_Port *port)
+{
+  struct sslplt *ssl;
+  ssl= (struct sslplt *)SCHEME_INPORT_VAL(port);
+
+  ssl->close_in = 1;
+  ssl->write_blocked_reason = 0;
+
+  if (ssl->close_out)
+    SSL_free(ssl->ssl);
+}
+
+/* sslin_need_wakeup: called when the input port is blocked to determine 
+   what exactly it's blocked on. We have to try a read to find out
+   why it's blocked: waiting for input or output on the low-level
+   socket? */
+static void sslin_need_wakeup(Scheme_Input_Port *port, void *fds)
+{
+  struct sslplt *ssl = SCHEME_INPORT_VAL(port);
+  long rfd;
+  void *fds2;
+  int stuck_why;
+
+  rfd = BIO_get_fd(SSL_get_rbio(ssl->ssl), NULL);
+
+  if (sslin_do_char_ready(port, &stuck_why)) {
+    /* Need wakeup now! */
+    scheme_cancel_sleep();
+  } else {
+    if (stuck_why != 3)
+      socket_add_fds(rfd, fds, (stuck_why == 2));
+    /* but stuck_why == 3 implies that a write is
+       responsible for waking up */
+  }
+}
+
+/* make_sslin_port: called to create a scheme input port to return to the
+   caller, eventually */
+Scheme_Input_Port *make_sslin_port(SSL *ssl, struct sslplt *wrapper, const char *name)
+{
+  return scheme_make_input_port(ssl_input_port_type, wrapper, 
+				scheme_make_immutable_sized_utf8_string((char *)name, -1),
+				ssl_get_string, 
+				NULL, 
+				scheme_progress_evt_via_get,
+				scheme_peeked_read_via_get,
+				sslin_char_ready, sslin_close, 
+				sslin_need_wakeup, 1);
+}
+
+/*****************************************************************************
+ * OUTPUT PORT FUNCTIONS: This is the stuff that works on output ports. This *
+ * is very complicated because we have to get char_ready to work on top of a *
+ * system that doesn't have such a function. So we buffer one character on   *
+ * output as necessary.                                                      *
+ *****************************************************************************/
+
+/* this is the new subtype we're creating */
+static Scheme_Object *ssl_output_port_type = NULL;
+
+/* forward decls: */
+static int sslout_char_ready(Scheme_Output_Port *port);
+static void sslout_need_wakeup(Scheme_Output_Port *port, void *fds);
+
+/* write_string: write some bits of data out to the wire, if possible. This
+   is made complicated by a host of problems. */
+long write_string(Scheme_Output_Port *port, const char *buffer, long offset, 
+		  long size, int rarely_block, int enable_break) 
+{
+  struct sslplt *ssl = (struct sslplt *)SCHEME_OUTPORT_VAL(port);
+  const char *errstr = "Unknown error";
+  int err = 0;
+  int status = 0;
+  long out_size;
+
+  /* make sure people aren't trying to do something sneaky */
+  if (ssl->close_out) {
+    errstr = "write to closed port!"; 
+    goto write_error;
+  }
+
+  if (ssl->ob_used) {
+    if (rarely_block == 2)
+      return size ? 0 : -1; /* return -1 if this was a flush request */
+    /* Wait until it's writable */
+    scheme_block_until_enable_break((Scheme_Ready_Fun)sslout_char_ready, 
+				    (Scheme_Needs_Wakeup_Fun)sslout_need_wakeup,
+				    (void *)port, (float)0.0,
+				    enable_break);
+  }
+
+  /* We get here only when !ssl->ob_used. */
+
+  if (!size) /* this was a flush request, and we've flushed */
+    return 0;
+
+  /* could have been closed by another thread */
+  if (ssl->close_out) {
+    errstr = "write to closed port!"; 
+    goto write_error;
+  }
+
+  /* Try to write a decent sized chunk.  We have to copy it to
+     obuffer, in case the write must be continued (in which case
+     SSL_write insists on getting the same arguments that it received
+     last time). */
+  out_size = size;
+  if (out_size > OBUFFER_SIZE)
+    out_size = OBUFFER_SIZE;
+  memcpy(ssl->obuffer, buffer + offset, out_size);
+  status = SSL_write(ssl->ssl, ssl->obuffer, out_size);
+
+  if (status > 0)
+    return status; /* success */
+
+  err = SSL_get_error(ssl->ssl, status);
+  if((err != SSL_ERROR_WANT_READ) && (err != SSL_ERROR_WANT_WRITE)) {
+    err = get_ssl_error_msg(err, &errstr, status, 1);
+    goto write_error;
+  }
+
+  /* Can't write a decent-sized chunk. Put out_size chars in the outgoing
+     buffer, and block as necessary until those chars are flushed */
+  if (out_size) {
+    int was_empty;
+
+    ssl->ob_used = out_size;
+
+    /* Put this SLL into the list of things that the deamon must
+       process. */
+    was_empty = !ssls;
+    ssl->next = ssls;
+    ssls = ssl;
+
+    /* Wake up the daemon thread if the list used to be empty: */
+    if (was_empty)
+      scheme_post_sema(daemon_attn);
+
+    /* We "wrote" out_size bytes. The daemon will ensure that the bytes
+       actually go out. */
+
+    return out_size;
+  } else
+    return 0;
+
+ write_error:
+   scheme_raise_exn(MZEXN_FAIL_NETWORK, 
+		    "ssl-write: error writing (%Z)",
+		   err, errstr);
+  return 0; /* needless, but it makes GCC happy */
+}
+
+/* sslout_char_ready: return 1 (true) iff a nonblocking (version 1, not 
+   version 2) call to write_string will write at least one character. */
+static int sslout_char_ready(Scheme_Output_Port *port)
+{
+  struct sslplt *ssl = SCHEME_OUTPORT_VAL(port);
+
+  return !ssl->ob_used;
+}
+
+static int shutdown_ready(Scheme_Object *_ssl)
+{
+  struct sslplt *ssl = (struct sslplt *)_ssl;
+
+  if (!ssl->write_blocked_reason)
+    return 1;
+  else
+    return check_socket_ready(BIO_get_fd(SSL_get_wbio(ssl->ssl), NULL),
+			      (ssl->write_blocked_reason == 2));
+}
+
+static void shutdown_need_wakeup(Scheme_Object *_ssl, void *fds)
+{
+  struct sslplt *ssl = (struct sslplt *)_ssl;
+
+  if (!ssl->write_blocked_reason)
+    scheme_cancel_sleep();
+  else
+    socket_add_fds(BIO_get_fd(SSL_get_wbio(ssl->ssl), NULL),
+		   fds,
+		   (ssl->write_blocked_reason == 2));
+}
+
+/* sslout_close: close down a buffer */
+void sslout_close(Scheme_Output_Port *port)
+{
+  struct sslplt *ssl = (struct sslplt *)SCHEME_OUTPORT_VAL(port);
+  int forced = 0;
+
+  if (ssl->ob_used && scheme_close_should_force_port_closed()) {
+    /* Tell daemon to give up on this port, 
+       and don't bother with a shutdown: */
+    ssl->ob_used = 0;
+    ssl->write_blocked_reason = 0;
+    ssl->close_out = 1;
+  } else {
+    /* We want to shutdown. If there's still a write in
+       progress, wait. */
+    if (ssl->ob_used){
+      scheme_block_until((Scheme_Ready_Fun)sslout_char_ready, 
+			 (Scheme_Needs_Wakeup_Fun)sslout_need_wakeup,
+			 (void *)port, (float)0.0);
+    }
+    /* assert: !ssl->ob_used */
+    /* it's possible that we were shut down in another
+       thread, though. */
+
+    /* FIXME: what if a another thread writes at this point?
+       In particular, the code below assumes that the deamon
+       thread is not trying to output. */
+
+    while (!ssl->close_out) {
+      int status;
+      int err, tries = 0;
+
+      while (1) {
+	status = SSL_shutdown(ssl->ssl);
+	if (status < 1)
+	  err = SSL_get_error(ssl->ssl, status);
+	/* Note: SSL_ERROR_SYSCALL may be erroneous if status was 0.
+	   Indeed 0 seems to be the result in many cases because the socket
+	   is non-blocking, and then neither of the WANTs is returned.
+	   We address this by simply trying 10 times and then giving
+	   up. The two-step shutdown is optional, anyway. */
+
+	if ((status < 0) && !scheme_close_should_force_port_closed()
+	    /* if an eof occurs, let's agree that it's shut down */
+	    && !(err == SSL_ERROR_SYSCALL)) {
+	  if (err == SSL_ERROR_WANT_READ)
+	    ssl->write_blocked_reason = 1;
+	  else if (err == SSL_ERROR_WANT_WRITE)
+	    ssl->write_blocked_reason = 2;
+	  else {
+	    const char *errstr;
+	    err = get_ssl_error_msg(err, &errstr, status, 1);
+	    scheme_raise_exn(MZEXN_FAIL_NETWORK, 
+			     "ssl-close: error shutting down output (%Z)",
+			     err, errstr);
+	    return;
+	  }
+
+	  scheme_block_until(shutdown_ready, 
+			     shutdown_need_wakeup,
+			     (void *)ssl, (float)0.0);      
+	} else if (status || (tries > 10)) {
+	  ssl->close_out = 1;
+	  if (ssl->close_in) {
+	    SSL_free(ssl->ssl);
+	  }
+	  break;
+	} else {
+	  tries++;
+	  scheme_thread_block(0.0);
+	}
+      }
+    }
+  }
+}
+
+/* sslout_need_wakeup: we don't do anything, because low-level
+   blocking is handled by the daemon thread */
+static void sslout_need_wakeup(Scheme_Output_Port *port, void *fds)
+{
+}
+
+/* make_sslout_port: called to create a scheme output port to return to the
+   caller, eventually. */
+static Scheme_Output_Port *make_sslout_port(SSL *ssl, struct sslplt *data, const char *name)
+{
+  return scheme_make_output_port(ssl_output_port_type, data, 
+				 scheme_make_immutable_sized_utf8_string((char *)name, -1),
+				 scheme_write_evt_via_write,
+				 write_string, 
+				 sslout_char_ready, sslout_close, 
+				 sslout_need_wakeup, 
+				 NULL, NULL, 1);
+}
+
+/*****************************************************************************
+ * CLEANING AND NETWORK FUNCTIONS: These are the functions which convert the *
+ * things we get in to things that are useful, plus the routines for doing   *
+ * various network operations                                                *
+ *****************************************************************************/
+
+/* check_host_and_convert: Make absolutely sure the first argument was a 
+   string, and then convert it into a character string we can actually use.
+   Or scream bloody murder if it wasn't a string. */
+char *check_host_and_convert(const char *name, int argc, Scheme_Object *argv[], int pos)
+{
+  if (SCHEME_CHAR_STRINGP(argv[pos]))
+    return SCHEME_BYTE_STR_VAL(scheme_char_string_to_byte_string(argv[pos]));
+  
+  scheme_wrong_type(name, "string", pos, argc, argv);
+  return NULL; /* unnecessary, but it makes GCC happy */
+}
+
+/* check_port_and_convert: Make absolutely sure the second argument
+   was a potential port number, and if it is, convert it into a number
+   we can actually use. Or scream if it wasn't kosher. */
+unsigned short check_port_and_convert(const char *name, int argc, Scheme_Object *argv[], int pos)
+{
+  if(SCHEME_INTP(argv[pos]))
+    if(SCHEME_INT_VAL(argv[pos]) >= 1)
+      if(SCHEME_INT_VAL(argv[pos]) <= 65535)
+	return htons(SCHEME_INT_VAL(argv[pos]));
+  scheme_wrong_type(name, "exact integer in [1, 65535]", pos, argc,argv);
+  return 0; /* unnessary and wrong, but it makes GCC happy */
+}
+
+/* check_encrypt_and_convert: Check the third argument is a valid symbol here,
+   and convert it to the SSL method function we'll be using if they gave us
+   a good argument. Otherwise scream. The third argument tells us if we want
+   client or server method functions. */
+SSL_METHOD *check_encrypt_and_convert(const char *name, int argc, Scheme_Object *argv[], int pos, int c, int ctx_ok)
+{
+  Scheme_Object *v;
+
+  if(argc <= pos)
+    return (c ? SSLv23_client_method() : SSLv23_server_method());
+    
+  v = argv[pos];
+
+  if(!SAME_OBJ(v, scheme_intern_symbol("sslv2-or-v3"))) {
+    return (c ? SSLv23_client_method() : SSLv23_server_method());
+  } else if(!SAME_OBJ(v, scheme_intern_symbol("sslv2"))) {
+    return (c ? SSLv2_client_method() : SSLv2_server_method());
+  } else if(!SAME_OBJ(v, scheme_intern_symbol("sslv3"))) {
+    return (c ? SSLv3_client_method() : SSLv3_server_method());
+  } else if(!SAME_OBJ(v, scheme_intern_symbol("tls"))) {
+    return (c ? TLSv1_client_method() : TLSv1_server_method());
+  } else {
+#   define ALLOWED_SYMS "'sslv2-or-v3, 'sslv2, 'sslv3, or 'tls"
+    scheme_wrong_type(name, 
+		      ctx_ok ? "ssl-client-context, " ALLOWED_SYMS : ALLOWED_SYMS, 
+		      pos, argc, argv);
+    return NULL; /* unnecessary, but it makes GCC happy */
+  }
+}
+
+/* ssl_check_sock: determine if a socket is ready for reading or
+   writing; conector_p is an array of integers: socket and 
+   0=>read/1=>write. */
+int ssl_check_sock(Scheme_Object *connector_p)
+{
+  return check_socket_ready(((int *)connector_p)[0], ((int *)connector_p)[1]);
+}
+
+/* ssl_check_sock: block on socket for reading or
+   writing; conector_p is an array of integers: socket and 
+   0=>read/1=>write. */
+void ssl_sock_needs_wakeup(Scheme_Object *connector_p, void *fds)
+{
+  socket_add_fds(((int *)connector_p)[0], fds, ((int *)connector_p)[1]);
+}
+
+#ifdef USE_UNIX_SOCKETS_TCP
+
+/* closesocket: close a socket, and try real hard to do it. This is lifted 
+   entirely from ${PLTHOME}/src/mzscheme/src/network.c */
+void closesocket(long s)
+{
+  int cr;
+  do { cr = close(s); } while((cr == -1) && NOT_WINSOCK(errno == EINTR));
+}
+
+#endif
+
+/* close_socket_and_dec: called when we're broken out of our attempt to
+   connect a socket */
+void close_socket_and_dec(unsigned short sock)
+{
+  closesocket(sock);
+}
+
+/*****************************************************************************
+ * SOCKET->SSL connection completion                                         *
+ *****************************************************************************/
+
+static Scheme_Object *finish_ssl(const char *name, int sock, SSL_METHOD *meth,
+				 char *address, int port, int do_accept,
+				 SSL_CTX *ctx_in)
+{
+  SSL_CTX *ctx = NULL;
+  BIO *bio = NULL;
+  SSL *ssl = NULL;
+  struct sslplt *sslplt = NULL;
+  const char *errstr = "Unknown error";
+  Scheme_Object *retval[2]; 
+  int status;
+  int err = 0;
+  int *sptr = NULL;
+
+  /* set up the BIO pipe */
+  bio = BIO_new_socket(sock, BIO_CLOSE);
+  if(!bio) { errstr = "couldn't create BIO stream"; goto clean_up_and_die; }
+
+  /* set up the SSL context object */
+  if (!ctx_in) {
+    ctx = SSL_CTX_new(meth);
+    if(!ctx) { 
+      err = get_ssl_error_msg(ERR_get_error(), &errstr, 0, 0);
+      goto clean_up_and_die; 
+    }
+  }
+
+  /* set up the full SSL object */
+  ssl = SSL_new(ctx ? ctx : ctx_in);
+  if(!ssl) {
+    err = get_ssl_error_msg(ERR_get_error(), &errstr, 0, 0);
+    goto clean_up_and_die; 
+  }
+  SSL_set_bio(ssl, bio, bio);
+
+  if (ctx) {
+    SSL_CTX_free(ctx); /* ssl has incremented ref count */
+    ctx = NULL;
+  }
+
+  /* see if we can connect via SSL */
+  if (do_accept)
+    status = SSL_accept(ssl);
+  else
+    status = SSL_connect(ssl);
+  while(status < 1) {
+    err = SSL_get_error(ssl, status);
+    if ((err == SSL_ERROR_WANT_READ) 
+	|| (err == SSL_ERROR_WANT_WRITE)) {
+      if (!sptr) {
+	sptr = (int *)scheme_malloc_atomic(2 * sizeof(int));
+	sptr[0] = sock;
+      }
+      sptr[1] = (err == SSL_ERROR_WANT_WRITE);
+
+      BEGIN_ESCAPEABLE(close_socket_and_dec, sock);
+      scheme_block_until(ssl_check_sock, ssl_sock_needs_wakeup, 
+			 (void *)sptr, (float)0.0);
+      END_ESCAPEABLE();
+    } else {
+      err = get_ssl_error_msg(err, &errstr, status, 1);
+      goto clean_up_and_die;
+    }
+    if (do_accept)
+      status = SSL_accept(ssl);
+    else
+      status = SSL_connect(ssl);
+  }
+
+  sslplt = create_register_sslplt(ssl);
+  retval[0] = (Scheme_Object*)make_sslin_port(ssl, sslplt, address);
+  retval[1] = (Scheme_Object*)make_sslout_port(ssl, sslplt, address);
+  return scheme_values(2, retval);
+
+ clean_up_and_die:
+  if (ctx) 
+    SSL_CTX_free(ctx);
+
+  if (ssl) 
+    SSL_free(ssl);
+  else {
+    if (bio)
+      BIO_free(bio);
+    else {
+      if(sock) 
+	closesocket(sock);
+    }
+  }
+
+  if (do_accept)
+    scheme_raise_exn(MZEXN_FAIL_NETWORK, 
+		     "%s: accepted connection failed (%Z)",
+		     name,
+		     err, errstr);
+  else
+    scheme_raise_exn(MZEXN_FAIL_NETWORK, 
+		     "%s: connection to %s, port %d failed (%Z)",
+		     name,
+		     address, port, err, errstr);
+  
+  /* not strictly necessary, but it makes our C compiler happy */
+  return NULL;
+}
+
+#ifdef USE_WINSOCK_TCP
+static int started;
+static void TCP_INIT(char *name)
+{
+  static int started = 0;
+  
+  if (!started) {
+    WSADATA data;
+    if (!WSAStartup(MAKEWORD(1, 1), &data)) {
+      started = 1;
+      return;
+    }
+  } else
+    return;
+  
+  scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
+		   "%s: not supported on this machine"
+		   " (no winsock driver)",
+		   name);
+}
+#else
+# define TCP_INIT(n) /* empty */
+#endif
+
+/*****************************************************************************
+ * SCHEME EXTERNAL FUNCTION IMPLEMENTATIONS: These are the implemenations of *
+ * the functions which are actually going to be exported to MzScheme userland*
+ *****************************************************************************/
+
+static Scheme_Object *ssl_connect(int argc, Scheme_Object *argv[])
+{
+  char *address;
+  unsigned short nport;
+  int port;
+  SSL_METHOD *meth;
+  SSL_CTX *ctx;
+  int status;
+  const char *errstr = "Unknown error";
+  int err = 0;
+  GC_CAN_IGNORE struct sockaddr_in addr;
+  int sock;
+#ifndef PROTOENT_IS_INT
+  struct protoent *proto;
+#endif
+
+  address = check_host_and_convert("ssl-connect", argc, argv, 0);
+  nport = check_port_and_convert("ssl-connect", argc, argv, 1);
+  port = SCHEME_INT_VAL(argv[1]);
+  if ((argc > 2) && SAME_TYPE(SCHEME_TYPE(argv[2]), ssl_ctx_type)) {
+    meth = NULL;
+    ctx = ((mzssl_ctx_t *)(argv[2]))->ctx;
+  } else {
+    meth = check_encrypt_and_convert("ssl-connect", argc, argv, 2, 1, 1);
+    ctx = NULL;
+  }
+
+  /* check we have the security clearance to actually do this */
+  scheme_security_check_network("ssl-connect", address, port, 1);
+  scheme_custodian_check_available(NULL, "ssl-connect", "network");
+
+  TCP_INIT("ssl-connect");
+
+  /* try to create the socket */
+#ifndef PROTOENT_IS_INT
+  proto = getprotobyname("tcp");
+  if(!proto) { 
+    errstr = "couldn't find tcp protocol id"; goto clean_up_and_die; 
+  }
+#endif
+  sock = socket(PF_INET, SOCK_STREAM, PROTO_P_PROTO);
+  if (sock == INVALID_SOCKET)  { errstr = NULL; err = SOCK_ERRNO(); goto clean_up_and_die; }
+#ifdef USE_WINSOCK_TCP
+  {
+    unsigned long ioarg = 1;
+    ioctlsocket(sock, FIONBIO, &ioarg);
+  }
+#else
+  fcntl(sock, F_SETFL, MZ_NONBLOCKING);
+#endif
+  
+  /* lookup hostname and get a reasonable structure */
+  if (!scheme_get_host_address(address, nport, &addr)) {
+    err = 0; 
+    errstr = "Unknown error resolving address"; 
+    goto clean_up_and_die;
+  }
+
+  status = connect(sock, (struct sockaddr *)&addr, sizeof(addr));
+  /* here's the complicated bit */
+  if (status) {
+    int errid;
+    errid = SOCK_ERRNO();
+    if (!WAS_EINPROGRESS(errid)) { 
+      errstr = NULL; err = errid; goto clean_up_and_die; 
+    }
+
+    {
+      int *sptr;
+
+      sptr = (int *)scheme_malloc_atomic(2 * sizeof(int));
+      sptr[0] = sock;
+      sptr[1] = 1;
+
+      BEGIN_ESCAPEABLE(close_socket_and_dec, sock);
+      scheme_block_until(ssl_check_sock, ssl_sock_needs_wakeup, 
+			 (void *)sptr, (float)0.0);
+      END_ESCAPEABLE();
+    }
+
+    /* see if the connection succeeded, or die if it didn't */
+    {
+      int so_len = sizeof(status);
+      if(getsockopt(sock, SOL_SOCKET,SO_ERROR, (void*)&status, &so_len) != 0) {
+	errstr = NULL;
+	err = status; 
+	goto clean_up_and_die;
+      }
+    }
+  }
+
+  return finish_ssl("ssl-connect", sock, meth, address, port, 0, ctx);
+
+ clean_up_and_die:
+  if (sock != INVALID_SOCKET) closesocket(sock);
+  scheme_raise_exn(MZEXN_FAIL_NETWORK, 
+		   "ssl-connect: connection to %T, port %d failed (%Z)",
+		   argv[0], SCHEME_INT_VAL(argv[1]), 
+		   err, errstr);
+  
+  /* not strictly necessary, but it makes our C compiler happy */
+  return NULL;
+}
+
+static Scheme_Object *ssl_connect_break(int argc, Scheme_Object *argv[]) {
+  return scheme_call_enable_break(ssl_connect, argc, argv);
+}
+
+/*****************************************************************************
+ * SSL LISTENER: sadly, cut-and-paste from the MzScheme source.              *
+ *****************************************************************************/
+
+/* Forward declaration */
+static int stop_listener(Scheme_Object *o);
+
+static Scheme_Object *
+ssl_listen(int argc, Scheme_Object *argv[])
+{
+  unsigned short id, origid;
+  int backlog, errid;
+  int reuse = 0;
+  const char *address = NULL;
+# ifndef PROTOENT_IS_INT
+  struct protoent *proto;
+# endif
+  SSL_METHOD *meth;
+  SSL_CTX *ctx;
+
+  id = check_port_and_convert("ssl-listen", argc, argv, 0);
+  if (argc > 1) {
+    if (!SCHEME_INTP(argv[1]) || (SCHEME_INT_VAL(argv[1]) < 1))
+      scheme_wrong_type("ssl-listen", "small positive integer", 1, argc, argv);
+  }
+  if (argc > 2)
+    reuse = SCHEME_TRUEP(argv[2]);
+  if (argc > 3) {
+    if (!SCHEME_FALSEP(argv[3]))
+      address = check_host_and_convert("ssl-listen", argc, argv, 3);
+  }
+  
+  if (0 && (argc > 4) && SAME_TYPE(SCHEME_TYPE(argv[4]), ssl_ctx_type)) {
+    meth = NULL;
+    ctx = ((mzssl_ctx_t *)(argv[4]))->ctx;
+  } else {
+    meth = check_encrypt_and_convert("ssl-connect", argc, argv, 4, 0, 0);
+    ctx = NULL;
+  }
+    
+  TCP_INIT("ssl-listen");
+
+  origid = (unsigned short)SCHEME_INT_VAL(argv[0]);
+  if (argc > 1)
+    backlog = SCHEME_INT_VAL(argv[1]);
+  else
+    backlog = 4;
+
+  scheme_security_check_network("ssl-listen", address, origid, 0);
+  scheme_custodian_check_available(NULL, "ssl-listen", "network");
+
+  if (!ctx) {
+    ctx = SSL_CTX_new(meth);
+    if(!ctx) { 
+      const char *errstr;
+      errid = get_ssl_error_msg(ERR_get_error(), &errstr, 0, 0);
+      scheme_raise_exn(MZEXN_FAIL_NETWORK,
+		       "sll-listen: context creation failed for listen on %d (%Z)",
+		       origid, errid, errstr);
+      return scheme_void;
+    }
+  }
+
+# ifndef PROTOENT_IS_INT
+  proto = getprotobyname("tcp");
+  if (proto)
+# endif
+  {
+    GC_CAN_IGNORE struct sockaddr_in tcp_listen_addr;
+
+    if (scheme_get_host_address(address, id, &tcp_listen_addr)) {
+      int s;
+
+      s = socket(PF_INET, SOCK_STREAM, PROTO_P_PROTO);
+      if (s != INVALID_SOCKET) {
+#ifdef USE_WINSOCK_TCP
+	unsigned long ioarg = 1;
+	ioctlsocket(s, FIONBIO, &ioarg);
+#else
+	fcntl(s, F_SETFL, MZ_NONBLOCKING);
+#endif
+
+	if (reuse) {
+	  setsockopt(s, SOL_SOCKET, SO_REUSEADDR, &reuse, sizeof(int));
+	}
+      
+	if (!bind(s, (struct sockaddr *)&tcp_listen_addr, sizeof(tcp_listen_addr))) {
+	  if (!listen(s, backlog)) {
+	    listener_t *l;
+
+	    l = (listener_t *)scheme_malloc_tagged(sizeof(listener_t));
+	    l->so.type = ssl_listener_type;
+	    l->s = s;
+	    l->ctx = ctx;
+	    {
+	      Scheme_Custodian_Reference *mref;
+	      mref = scheme_add_managed(NULL,
+					(Scheme_Object *)l,
+					(Scheme_Close_Custodian_Client *)stop_listener,
+					NULL,
+					1);
+	      l->mref = mref;
+	    }
+	    
+	    return (Scheme_Object *)l;
+	  }
+	}
+
+	errid = SOCK_ERRNO();
+
+	closesocket(s);
+      } else
+	errid = SOCK_ERRNO();
+    } else {
+      if (ctx && meth)
+	SSL_CTX_free(ctx);
+      scheme_raise_exn(MZEXN_FAIL_NETWORK,
+		       "ssl-listen: host not found: %s",
+		       address);
+      return NULL;
+    }
+  }
+# ifndef PROTOENT_IS_INT
+  else {
+    errid = SOCK_ERRNO();
+  }
+# endif
+
+  if (ctx && meth)
+    SSL_CTX_free(ctx);
+      
+  scheme_raise_exn(MZEXN_FAIL_NETWORK,
+		   "sll-listen: listen on %d failed (%E)",
+		   origid, errid);
+
+  return NULL;
+}
+
+static int stop_listener(Scheme_Object *o)
+{
+  int was_closed = 0;
+
+  {
+    int s = ((listener_t *)o)->s;
+    if (s == INVALID_SOCKET)
+      was_closed = 1;
+    else {
+      closesocket(s);
+      ((listener_t *)o)->s = INVALID_SOCKET;
+      scheme_remove_managed(((listener_t *)o)->mref, o);
+      SSL_CTX_free(((listener_t *)o)->ctx);
+    }
+  }
+
+  return was_closed;
+}
+
+static Scheme_Object *
+ssl_close(int argc, Scheme_Object *argv[])
+{
+  int was_closed;
+
+  if (!SAME_TYPE(SCHEME_TYPE(argv[0]), ssl_listener_type))
+    scheme_wrong_type("ssl-close", "ssl-listener", 0, argc, argv);
+
+  was_closed = stop_listener(argv[0]);
+
+  if (was_closed) {
+    scheme_raise_exn(MZEXN_FAIL_NETWORK,
+		     "ssl-close: listener was already closed");
+    return NULL;
+  }
+
+  return scheme_void;
+}
+
+static Scheme_Object *
+ssl_listener_p(int argc, Scheme_Object *argv[])
+{
+  return ((SAME_TYPE(SCHEME_TYPE(argv[0]), ssl_listener_type))
+	  ? scheme_true
+	  : scheme_false);
+}
+
+enum {
+  mzssl_CERT_CHAIN,
+  mzssl_CERT_ROOT,
+  mzssl_CERT_REQ,
+  mzssl_RSA_KEY
+};
+
+static Scheme_Object *
+ctx_load_file(const char *name, int mode, int client_ok, int argc, Scheme_Object *argv[])
+{
+  char *filename;
+  const char *what;
+  int result, use_rsa = 1, format = SSL_FILETYPE_PEM;
+  SSL_CTX *ctx;
+  
+  if (!SAME_TYPE(SCHEME_TYPE(argv[0]), ssl_listener_type)
+      && (! client_ok || !SAME_TYPE(SCHEME_TYPE(argv[0]), ssl_ctx_type)))
+    scheme_wrong_type(name, 
+		      (client_ok ? "ssl-listener or ssl-client-context" : "ssl-listener"),
+		      0, argc, argv);
+
+  if (!SCHEME_PATHP(argv[1]))
+    scheme_wrong_type(name, "string", 1, argc, argv);
+
+  if (mode == mzssl_RSA_KEY) {
+    if (argc > 2)
+      use_rsa = SCHEME_TRUEP(argv[2]);
+    if (argc > 3)
+      if (SCHEME_TRUEP(argv[3]))
+	format = SSL_FILETYPE_ASN1;
+  }
+  
+  filename = scheme_expand_string_filename(argv[1],
+					   name,
+					   NULL,
+					   SCHEME_GUARD_FILE_READ);
+
+  if (SAME_TYPE(SCHEME_TYPE(argv[0]), ssl_listener_type))
+    ctx = ((listener_t *)(argv[0]))->ctx;
+  else
+    ctx = ((mzssl_ctx_t *)(argv[0]))->ctx;
+  
+  if (mode == mzssl_CERT_CHAIN) {
+    result = SSL_CTX_use_certificate_chain_file(ctx, filename);
+    what = "certificate chain";
+  } else if (mode == mzssl_CERT_ROOT) {
+    result = SSL_CTX_load_verify_locations(ctx, filename, NULL);
+    what = "root certificates";
+  } else if (mode == mzssl_CERT_REQ) {
+    GC_CAN_IGNORE STACK_OF(X509_NAME) *stk;
+    stk = SSL_load_client_CA_file(filename);
+    if (stk) {
+      result = 1;
+      SSL_CTX_set_client_CA_list(ctx, stk);
+    } else
+      result = 0;
+    what = "suggested certificate authorities";
+  } else if (mode == mzssl_RSA_KEY) {
+    if (use_rsa)
+      result = SSL_CTX_use_RSAPrivateKey_file(ctx, filename, format);
+    else
+      result = SSL_CTX_use_PrivateKey_file(ctx, filename, format);
+    what = "private key";
+  }
+
+  if (result != 1) {
+    int errid;
+    const char *errstr;
+    errid = get_ssl_error_msg(ERR_get_error(), &errstr, 0, 0);
+    scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
+		     "%s: %s load failed from: %s (%Z)",
+		     name, what, filename, errid, errstr);
+    return NULL;
+  }
+
+  return scheme_void;
+}
+
+static Scheme_Object *
+ssl_load_cert_chain(int argc, Scheme_Object *argv[])
+{
+  return ctx_load_file("ssl-load-certificate-chain!", mzssl_CERT_CHAIN, 1, argc, argv);
+}
+
+static Scheme_Object *
+ssl_load_cert_root(int argc, Scheme_Object *argv[])
+{
+  return ctx_load_file("ssl-load-root-verify-certificate!", mzssl_CERT_ROOT, 1, argc, argv);
+}
+
+static Scheme_Object *
+ssl_load_accept_cert_auth(int argc, Scheme_Object *argv[])
+{
+  return ctx_load_file("ssl-load-suggested-certificate-authorities!", mzssl_CERT_REQ, 0, argc, argv);
+}
+
+static Scheme_Object *
+ssl_load_priv_key(int argc, Scheme_Object *argv[])
+{
+  return ctx_load_file("ssl-load-prvate-key!", mzssl_RSA_KEY, 1, argc, argv);
+}
+
+static Scheme_Object *
+ssl_set_verify(int argc, Scheme_Object *argv[])
+{
+  SSL_CTX *ctx;
+
+  if (!SAME_TYPE(SCHEME_TYPE(argv[0]), ssl_listener_type)
+      && !SAME_TYPE(SCHEME_TYPE(argv[0]), ssl_ctx_type))
+    scheme_wrong_type("ssl-set-verify!", "ssl-listener or ssl-client-context", 0, argc, argv);
+
+  if (SAME_TYPE(SCHEME_TYPE(argv[0]), ssl_listener_type))
+    ctx = ((listener_t *)(argv[0]))->ctx;
+  else
+    ctx = ((mzssl_ctx_t *)(argv[0]))->ctx;
+  
+  SSL_CTX_set_verify(ctx, 
+		     (SCHEME_TRUEP(argv[1]) 
+		      ? (SSL_VERIFY_PEER | SSL_VERIFY_FAIL_IF_NO_PEER_CERT)
+		      : SSL_VERIFY_NONE),
+		     NULL);
+
+  return scheme_void;
+}
+
+static void release_ctx(void *p, void *data)
+{
+  SSL_CTX_free(((mzssl_ctx_t *)p)->ctx);
+}
+
+static Scheme_Object *
+ssl_mk_ctx(int argc, Scheme_Object *argv[])
+{
+  mzssl_ctx_t *c;
+  SSL_METHOD *meth;
+  SSL_CTX *ctx;
+
+  meth = check_encrypt_and_convert("ssl-make-context", argc, argv, 0, 1, 0);
+
+  c = (mzssl_ctx_t *)scheme_malloc_tagged(sizeof(mzssl_ctx_t));
+  c->so.type = ssl_ctx_type;
+
+  ctx = SSL_CTX_new(meth);
+  if (!ctx) { 
+    const char *errstr;
+    int errid;
+    errid = get_ssl_error_msg(ERR_get_error(), &errstr, 0, 0);
+    scheme_raise_exn(MZEXN_FAIL_NETWORK,
+		     "sll-make-context: context creation failed (%Z)",
+		     errid, errstr);
+    return scheme_void;
+  }
+
+  c->ctx = ctx;
+  
+  scheme_add_finalizer(c, release_ctx, NULL);
+
+  return (Scheme_Object *)c;
+}
+
+static Scheme_Object *
+ssl_ctx_p(int argc, Scheme_Object *argv[])
+{
+  return ((SAME_TYPE(SCHEME_TYPE(argv[0]), ssl_ctx_type))
+	  ? scheme_true
+	  : scheme_false);
+}
+
+
+static int tcp_check_accept(Scheme_Object *listener)
+{
+  if (LISTENER_WAS_CLOSED(listener))
+    return 1;
+
+  return check_socket_ready(((listener_t *)listener)->s, 0);
+}
+
+static void tcp_accept_needs_wakeup(Scheme_Object *listener, void *fds)
+{
+  socket_add_fds(((listener_t *)listener)->s, fds, 0);
+}
+
+static Scheme_Object *
+ssl_accept(int argc, Scheme_Object *argv[])
+{
+  int was_closed = 0, errid;
+  Scheme_Object *listener;
+  int s;
+  int l;
+  GC_CAN_IGNORE struct sockaddr_in tcp_accept_addr;
+  
+  if (!SAME_TYPE(SCHEME_TYPE(argv[0]), ssl_listener_type))
+    scheme_wrong_type("ssl-accept", "ssl-listener", 0, argc, argv);
+
+  scheme_custodian_check_available(NULL, "ssl-accept", "network");
+
+  listener = argv[0];
+
+  was_closed = LISTENER_WAS_CLOSED(listener);
+
+  if (!was_closed) {
+    scheme_block_until(tcp_check_accept, tcp_accept_needs_wakeup,
+		       listener, (float)0.0);
+    was_closed = LISTENER_WAS_CLOSED(listener);
+  }
+
+  if (was_closed) {
+    scheme_raise_exn(MZEXN_FAIL_NETWORK,
+		     "ssl-accept: listener is closed");
+    return NULL;
+  }
+
+  scheme_custodian_check_available(NULL, "ssl-accept", "network");
+  
+  s = ((listener_t *)listener)->s;
+
+  l = sizeof(tcp_accept_addr);
+
+  do {
+    s = accept(s, (struct sockaddr *)&tcp_accept_addr, &l);
+  } while ((s == -1) && (NOT_WINSOCK(errno) == EINTR));
+
+  if (s != INVALID_SOCKET) {
+# ifdef USE_WINSOCK_TCP
+    {
+      unsigned long ioarg = 1;
+      ioctlsocket(s, FIONBIO, &ioarg);
+    }
+# else
+    fcntl(s, F_SETFL, MZ_NONBLOCKING);
+# endif
+    
+    return finish_ssl("ssl-accept", s, NULL, NULL, 0,
+		      1, ((listener_t *)listener)->ctx);
+  }
+
+
+  errid = SOCK_ERRNO();
+  scheme_raise_exn(MZEXN_FAIL_NETWORK,
+		   "ssl-accept: accept from listener failed (%E)", errid);
+
+  return NULL;
+}
+
+static Scheme_Object *ssl_accept_break(int argc, Scheme_Object *argv[]) {
+  return scheme_call_enable_break(ssl_accept, argc, argv);
+}
+
+/*****************************************************************************
+ * MISC                                                                      *
+ *****************************************************************************/
+
+static Scheme_Object *ssl_addresses(int argc, Scheme_Object *argv[])
+{
+  /* Again, sadly cut-and-paste from MzScheme's network.c */
+  GC_CAN_IGNORE struct sockaddr_in tcp_here_addr, tcp_there_addr;
+  int l, closed;
+  struct sslplt *wrapper = NULL;
+  unsigned long here_a, there_a;
+  unsigned char *b;
+  Scheme_Object *result[2];
+  char sa[20];
+  int fd;
+
+  if (SCHEME_OUTPORTP(argv[0])) {
+    Scheme_Output_Port *op;
+    op = (Scheme_Output_Port *)argv[0];
+    if (op->sub_type == ssl_output_port_type) {
+      wrapper = (struct sslplt *)op->port_data;
+      fd = BIO_get_fd(SSL_get_wbio(wrapper->ssl), NULL);
+    }
+    closed = op->closed;
+    
+  } else if (SCHEME_INPORTP(argv[0])) {
+    Scheme_Input_Port *ip;
+    ip = (Scheme_Input_Port *)argv[0];
+    if (ip->sub_type == ssl_input_port_type) {
+      wrapper = (struct sslplt *)ip->port_data;
+      fd = BIO_get_fd(SSL_get_rbio(wrapper->ssl), NULL);
+    }
+    closed = ip->closed;
+  }
+
+  if (!wrapper)
+    scheme_wrong_type("ssl-addresses", "ssl-port", 0, argc, argv);
+
+  if (closed)
+    scheme_raise_exn(MZEXN_FAIL,
+		     "ssl-addresses: port is closed");
+
+  l = sizeof(tcp_here_addr);
+  if (getsockname(fd, (struct sockaddr *)&tcp_here_addr, &l)) {
+    scheme_raise_exn(MZEXN_FAIL_NETWORK,
+		     "ssl-addresses: could not get local address (%e)",
+		     SOCK_ERRNO());
+  }
+  l = sizeof(tcp_there_addr);
+  if (getpeername(fd, (struct sockaddr *)&tcp_there_addr, &l)) {
+    scheme_raise_exn(MZEXN_FAIL_NETWORK,
+		     "ssl-addresses: could not get peer address (%e)",
+		     SOCK_ERRNO());
+  }
+  
+  here_a = *(unsigned long *)&tcp_here_addr.sin_addr;
+  there_a = *(unsigned long *)&tcp_there_addr.sin_addr;
+
+  b = (unsigned char *)&here_a;
+  sprintf(sa, "%d.%d.%d.%d", b[0], b[1], b[2], b[3]);
+  result[0] = scheme_make_utf8_string(sa);
+
+  b = (unsigned char *)&there_a;
+  sprintf(sa, "%d.%d.%d.%d", b[0], b[1], b[2], b[3]);
+  result[1] = scheme_make_utf8_string(sa);
+
+  return scheme_values(2, result);
+}
+
+/*****************************************************************************
+ * PRECISE GC                                                                *
+ *****************************************************************************/
+
+#ifdef MZ_PRECISE_GC
+
+int sslplt_SIZE(void *p) {
+  return
+  gcBYTES_TO_WORDS(sizeof(struct sslplt));
+}
+
+int sslplt_MARK(void *p) {
+  struct sslplt *ssl = (struct sslplt *)p;
+
+  gcMARK(ssl->next);
+  gcMARK(ssl->obuffer);
+
+  return
+  gcBYTES_TO_WORDS(sizeof(struct sslplt));
+}
+
+int sslplt_FIXUP(void *p) {
+  struct sslplt *ssl = (struct sslplt *)p;
+
+  gcFIXUP(ssl->next);
+  gcFIXUP(ssl->obuffer);
+
+  return
+  gcBYTES_TO_WORDS(sizeof(struct sslplt));
+}
+
+int listener_SIZE(void *p) {
+  return
+  gcBYTES_TO_WORDS(sizeof(listener_t));
+}
+
+int listener_MARK(void *p) {
+  listener_t *l = (listener_t *)p;
+
+  gcMARK(l->mref);
+
+  return
+  gcBYTES_TO_WORDS(sizeof(listener_t));
+}
+
+int listener_FIXUP(void *p) {
+  listener_t *l = (listener_t *)p;
+
+  gcFIXUP(l->mref);
+
+  return
+  gcBYTES_TO_WORDS(sizeof(listener_t));
+}
+
+int mzssl_ctx_SIZE(void *p) {
+  return
+  gcBYTES_TO_WORDS(sizeof(mzssl_ctx_t));
+}
+
+int mzssl_ctx_MARK(void *p) {
+  mzssl_ctx_t *l = (mzssl_ctx_t *)p;
+
+  return
+  gcBYTES_TO_WORDS(sizeof(mzssl_ctx_t));
+}
+
+int mzssl_ctx_FIXUP(void *p) {
+  mzssl_ctx_t *l = (mzssl_ctx_t *)p;
+
+  return
+  gcBYTES_TO_WORDS(sizeof(mzssl_ctx_t));
+}
+
+#endif
+
+/*****************************************************************************
+ * REGISTRATION FUNCTIONS: The functions that register the above externals so*
+ * everybody else can use them.                                              *
+ *****************************************************************************/
+
+/* scheme_initialize: called when the extension is first loaded */
+Scheme_Object *scheme_initialize(Scheme_Env *env)
+{
+  Scheme_Object *thread;
+  Scheme_Custodian *newcust;
+  Scheme_Config *cfg;
+
+  thread = scheme_make_prim_w_arity(write_close_thread,
+				    "SSL Flushing Thread",
+				    0, 0);
+  newcust = scheme_make_custodian(NULL);
+
+  scheme_register_extension_global(&daemon_attn, sizeof(daemon_attn));
+  scheme_register_extension_global(&ssls, sizeof(ssls));
+  scheme_register_extension_global(&ssl_input_port_type, sizeof(ssl_input_port_type));
+  scheme_register_extension_global(&ssl_output_port_type, sizeof(ssl_output_port_type));
+  
+  SSL_library_init();
+  daemon_attn = scheme_make_sema(0);
+  ssl_listener_type = scheme_make_type("<ssl-listener>");
+  ssl_ctx_type = scheme_make_type("<ssl-client-context>");
+#ifdef MZTAG_REQUIRED
+  sslplt_type = scheme_make_type("<ssl-plt-internal>");
+#endif
+  ssl_input_port_type = scheme_make_port_type("<ssl-input-port>");
+  ssl_output_port_type = scheme_make_port_type("<ssl-output-port>");
+  
+#ifdef MZ_PRECISE_GC
+  GC_register_traversers(ssl_listener_type, listener_SIZE,
+			 listener_MARK, listener_FIXUP,
+			 1, 0);
+  GC_register_traversers(ssl_ctx_type, mzssl_ctx_SIZE,
+			 mzssl_ctx_MARK, mzssl_ctx_FIXUP,
+			 1, 1);
+  GC_register_traversers(sslplt_type, sslplt_SIZE,
+			 sslplt_MARK, sslplt_FIXUP,
+			 1, 0);
+#endif
+
+  SSL_load_error_strings();
+
+
+  scheme_add_evt(ssl_listener_type,
+		 tcp_check_accept, tcp_accept_needs_wakeup,
+		 NULL, 0);
+
+  scheme_thread_w_details(thread, NULL, NULL, NULL, newcust, 0);
+  return scheme_reload(env);
+}
+
+/* scheme_reload: called when an extension is loaded a second+ time */
+Scheme_Object *scheme_reload(Scheme_Env *env)
+{
+  Scheme_Object *v;
+
+  v = scheme_intern_symbol("mzssl");
+  env = scheme_primitive_module(v, env);
+  
+  /* add ssl-connect */
+  v = scheme_make_prim_w_arity(ssl_connect, "ssl-connect", 2, 3);
+  scheme_add_global("ssl-connect", v, env);
+
+  v = scheme_make_prim_w_arity(ssl_connect_break,"ssl-connect/enable-break",2,3);
+  scheme_add_global("ssl-connect/enable-break", v, env);
+
+  v = scheme_make_prim_w_arity(ssl_listen,"ssl-listen",1,5);
+  scheme_add_global("ssl-listen", v, env);
+
+  v = scheme_make_prim_w_arity(ssl_close,"ssl-close",1,1);
+  scheme_add_global("ssl-close", v, env);
+
+  v = scheme_make_prim_w_arity(ssl_listener_p,"ssl-listener?",1,1);
+  scheme_add_global("ssl-listener?", v, env);
+
+  v = scheme_make_prim_w_arity(ssl_load_cert_chain,"ssl-load-certificate-chain!",2,2);
+  scheme_add_global("ssl-load-certificate-chain!", v, env);
+
+  v = scheme_make_prim_w_arity(ssl_load_cert_root,"ssl-load-verify-root-certificates!",2,2);
+  scheme_add_global("ssl-load-verify-root-certificates!", v, env);
+
+  v = scheme_make_prim_w_arity(ssl_load_cert_chain,"ssl-load-suggested-certificate-authorities!",2,2);
+  scheme_add_global("ssl-load-suggested-certificate-authorities!", v, env);
+
+  v = scheme_make_prim_w_arity(ssl_load_priv_key,"ssl-load-private-key!",2,4);
+  scheme_add_global("ssl-load-private-key!", v, env);
+
+  v = scheme_make_prim_w_arity(ssl_set_verify,"ssl-set-verify!",2,2);
+  scheme_add_global("ssl-set-verify!", v, env);
+
+  v = scheme_make_prim_w_arity(ssl_mk_ctx,"ssl-make-client-context",0,0);
+  scheme_add_global("ssl-make-client-context", v, env);
+
+  v = scheme_make_prim_w_arity(ssl_ctx_p,"ssl-client-context?",1,1);
+  scheme_add_global("ssl-client-context?", v, env);
+
+  v = scheme_make_prim_w_arity(ssl_accept,"ssl-accept",1,1);
+  scheme_add_global("ssl-accept", v, env);
+
+  v = scheme_make_prim_w_arity(ssl_accept_break,"ssl-accept/enable-break",1,1);
+  scheme_add_global("ssl-accept/enable-break", v, env);
+
+  v = scheme_make_prim_w_arity(ssl_mk_ctx,"ssl-make-context",0,1);
+  scheme_add_global("ssl-make-context", v, env);
+
+  v = scheme_make_prim_w_everything(ssl_addresses, 0, "ssl-addresses", 1, 1, 0, 2, 2);
+  scheme_add_global("ssl-addresses", v, env);
+
+  scheme_add_global("ssl-available?", scheme_true, env);
+  scheme_finish_primitive_module(env);
+
+  return scheme_void;
+}
+
+/* scheme_module_name: called to get the name of this module */
+Scheme_Object *scheme_module_name()
+{
+  return scheme_intern_symbol("mzssl");
+}
diff --git a/collects/openssl/mzssl.ss b/collects/openssl/mzssl.ss
new file mode 100644
index 0000000000..2cf8689daf
--- /dev/null
+++ b/collects/openssl/mzssl.ss
@@ -0,0 +1,26 @@
+(module mzssl mzscheme
+  (define ssl-available? #f)
+  (provide ssl-available?)
+
+  (define-syntax provide-wrappers
+    (syntax-rules ()
+      [(_) (begin)]
+      [(_ id1 id ...)
+       (begin
+	 (define (id1 . args)
+	   (error 'id1 "extension not compiled"))
+	 (provide id1)
+	 (provide-wrappers id ...))]))
+
+  (provide-wrappers
+   ssl-connect ssl-connect/enable-break
+   ssl-listen ssl-listener? ssl-close
+   ssl-accept ssl-accept/enable-break
+   ssl-addresses
+   ssl-make-client-context ssl-client-context?
+   ssl-load-certificate-chain!
+   ssl-set-verify!
+   ssl-load-verify-root-certificates!
+   ssl-load-private-key!
+   ssl-load-suggested-certificate-authorities!))
+
diff --git a/collects/openssl/openssl.ss b/collects/openssl/openssl.ss
new file mode 100644
index 0000000000..0b17751a13
--- /dev/null
+++ b/collects/openssl/openssl.ss
@@ -0,0 +1,4 @@
+(module openssl mzscheme
+  (require "mzssl.ss")
+
+  (provide ssl-connect))
\ No newline at end of file
diff --git a/collects/openssl/pre-installer.ss b/collects/openssl/pre-installer.ss
new file mode 100644
index 0000000000..0787ae5fa5
--- /dev/null
+++ b/collects/openssl/pre-installer.ss
@@ -0,0 +1,140 @@
+
+(module pre-installer mzscheme
+  (require (lib "setup-extension.ss" "make")
+	   (lib "compile.ss" "dynext")
+	   (lib "link.ss" "dynext")
+	   (lib "restart.ss")
+	   (lib "launcher.ss" "launcher")
+	   (lib "file.ss"))
+
+  (define (pre-installer plthome openssl-dir)
+    (define (go file)
+      (pre-install plthome
+		   openssl-dir
+		   file
+		   (build-path openssl-dir
+			       "openssl")
+		   ;; header subdirs
+		   (list "openssl")
+		   ;; unix libs
+		   (list "ssl" "crypto")
+		   ;; windows libs
+		   (let* ([default-paths
+			    (list (build-path openssl-dir "openssl"))]
+			  [paths
+			   (let ([v (getenv "PLT_EXTENSION_LIB_PATHS")])
+			     (if v
+				 (path-list-string->path-list v default-paths)
+				 default-paths))])
+		     (if (ormap (lambda (path)
+				  (and (file-exists? (build-path path "lib" "libeay32xxxxxxx.lib"))
+				       (file-exists? (build-path path "lib" "ssleay32xxxxxxx.lib"))))
+				paths)
+			 ;; Use mangleable names:
+			 (list "libeay32xxxxxxx" "ssleay32xxxxxxx")
+			 ;; Use simple names:
+			 (list "libeay32" "ssleay32")))
+		   ;; unix extra libs (assume always there)
+		   null
+		   ;; Windows extra libs (assume always there)
+		   (list "wsock32.lib")
+		   ;; Extra depends:
+		   (list "mzssl.ss")
+		   ;; Last-chance k:
+		   (lambda (k) (k))))
+    (go "mzssl.c")
+
+    ;; Build for 3m when it looks like we can/should.
+    ;; This is a hack --- hopefully temporary!
+    (let ([3m-dir (build-path "compiled" "native" (system-library-subpath #f) "3m")]
+	  [mzssl.so (case (system-type)
+		      [(windows) "mzssl.dll"]
+		      [(macosx) "mzssl.dylib"]
+		      [else "mzssl.so"])])
+      (parameterize ([current-directory openssl-dir])
+	(when (and (memq (system-type) '(unix macosx windows))
+		   (memq '3m (available-mzscheme-variants))
+		   (directory-exists? (build-path 'up 'up "src" "mzscheme" "gc2")))
+	  (when (or (not (file-exists? (build-path 3m-dir mzssl.so)))
+		    (not (file-exists? (build-path 3m-dir "mzssl.c")))
+		    ((file-or-directory-modify-seconds (build-path 3m-dir 'up mzssl.so))
+		     . > .
+		     (file-or-directory-modify-seconds (build-path 3m-dir mzssl.so))))
+	    (make-directory* 3m-dir)
+	    (restart-mzscheme #() 
+			      (lambda (x) x)
+			      (list->vector 
+			       (list
+				"-qr"
+				(path->string
+				 (build-path 'up 'up "src" "mzscheme" "gc2" "xform.ss"))
+				(let* ([inc (build-path 'up 'up "include")]
+				       [fix-path (lambda (s)
+						   (regexp-replace* " " (path->string s) "\" \""))]
+				       [extras (cond ((getenv "PLT_EXTENSION_LIB_PATHS") =>
+						      (lambda (ext)
+							(apply string-append
+							       (map (lambda (p)
+								      (format 
+								       " ~a~s"
+								       (if (eq? 'windows (system-type))
+									   " /I"
+									   " -I")
+								       (fix-path
+									(build-path p "include"))))
+								    (path-list-string->path-list ext '())))))
+						     (else ""))])
+				  (if (eq? 'windows (system-type))
+				      (format "cl.exe /MT /E /I~a /I~a~a" 
+					      (fix-path inc)
+					      (fix-path
+					       (build-path openssl-dir "openssl" "include"))
+					      extras)
+				      (format "gcc -E ~a-I~a~a" 
+					      (if (eq? 'macosx (system-type))
+						  "-DOS_X "
+						  "")
+					      (fix-path inc) 
+					      extras)))
+				"mzssl.c"
+				(path->string 
+				 (build-path 3m-dir "mzssl.c"))))
+			      void))
+	  (parameterize ([link-variant '3m])
+	    (with-new-flags current-extension-compiler-flags
+			    (if (eq? 'windows (system-type))
+				'("/Zi")
+				null)
+	      (with-new-flags current-extension-linker-flags
+			      (if (eq? 'windows (system-type))
+				  '("/Zi")
+				  null)
+	        (go (build-path 3m-dir "mzssl.c"))))))))
+
+    ;; Under windows, put "{lib,sll}eay32" into the system folder when
+    ;; they're in a "precompiled" dir.
+    (when (eq? 'windows (system-type))
+      (let ([dir (build-path openssl-dir
+			     "precompiled"
+			     "native"
+			     (system-library-subpath #f))])
+	(when (directory-exists? dir)
+	  (let ([l (directory-list dir)])
+	    (let ([libeay (ormap (lambda (f)
+				   (regexp-match #rx"^libeay32.*[.]dll$" f))
+				 l)]
+		  [ssleay (ormap (lambda (f)
+				   (regexp-match #rx"^ssleay32.*[.]dll$" f))
+				 l)])
+	      (when (and libeay ssleay)
+		(let ([sys-dir (find-system-path 'sys-dir)])
+		  (let ([move-over
+			 (lambda (f)
+			   (unless (file-exists? (build-path sys-dir f))
+			     (printf "  Installing ~a into system directory~n" f)
+			     (copy-file (build-path dir f)
+					(build-path sys-dir f))))])
+		    (move-over (car libeay))
+		    (move-over (car ssleay)))))))))))
+
+  (provide pre-installer))
diff --git a/collects/openssl/test.pem b/collects/openssl/test.pem
new file mode 100644
index 0000000000..4619e88f9b
--- /dev/null
+++ b/collects/openssl/test.pem
@@ -0,0 +1,35 @@
+-----BEGIN RSA PRIVATE KEY-----
+MIICXgIBAAKBgQDFbpSdxnIGsjPGn5KImciYO8m0j/ETbKOFwKGf8tkg6rWS0Pep
+9ANx3gKT8nSuMBrpmcRzMouyrpBr6mxIRX5wt4MBXr67n+w4RdyCXvEl9gcR2iqg
+cSEr6Zdx4zJLHRMy3UCCgk8L/fgC+AGsxjtH+DInBw3vtsEH/GL6cX518wIDAQAB
+AoGBAJNdH5bIaZHv70+BCenmB2EBt2OL0SBzhXavOrRdmo3EQvUr/sAfP3b9hCUT
+4t2lUGEuggCOKNGdFHVIS7yCCoYbnSb8q7JZgRvQRa708ziLeFETQ9oVMdbb4bg0
+65gAEl8f9zq6H5RHYnYQimU6hr5sdCT5jUhj5o8Fud3I1bUpAkEA/XBB2a/Ycp4q
+msP+PctIRewW10IklzweFUGXA4QxnEwLVEjbNLXBTvah0moQrbO8S4koOvwiRXUm
+Ei+Yd98cTwJBAMdtabA9ftzsZGC3e7oEvHqJma2q6rLWsCy+oFMqYbme5gBOlMZz
+d9pWw7joo5R174VFXEbjyTKFyOMwSCpubx0CQQDS4Iw6WKHORSMIIdqziij53Ubo
+F6YgnKofX7MK/vzUo0Wt/O1Af5d4X6koTo7QKcScSWTLJ65QgviJm0bPPzrrAkEA
+s6LJtbffA29oB3qfV3MWt6YkqLuxR0B9VwCq997QQlxwP0yJVK0EA8dt66yaVItb
+IofU1AIw5HJ//q0qBBaPvQJAOv8WxBzKLHUNVV0hqOnN24KT7CZDvZZnIuoUsrWJ
+rcw3PaKedhgZLd1a81iO6lXEehMeT8VLKrKnnIvM/f8W0Q==
+-----END RSA PRIVATE KEY-----
+-----BEGIN CERTIFICATE-----
+MIIDWTCCAsKgAwIBAgIBADANBgkqhkiG9w0BAQQFADCBgDELMAkGA1UEBhMCVVMx
+DTALBgNVBAgTBFV0YWgxFzAVBgNVBAcTDlNhbHQgTGFrZSBDaXR5MRIwEAYDVQQK
+EwlQTFQsIEluYy4xDzANBgNVBAMTBmxhbWJkYTEkMCIGCSqGSIb3DQEJARYVbWZs
+YXR0QHBsdC1zY2hlbWUub3JnMB4XDTAzMDQyNzIyMjEyM1oXDTIyMDYyNjIyMjEy
+M1owgYAxCzAJBgNVBAYTAlVTMQ0wCwYDVQQIEwRVdGFoMRcwFQYDVQQHEw5TYWx0
+IExha2UgQ2l0eTESMBAGA1UEChMJUExULCBJbmMuMQ8wDQYDVQQDEwZsYW1iZGEx
+JDAiBgkqhkiG9w0BCQEWFW1mbGF0dEBwbHQtc2NoZW1lLm9yZzCBnzANBgkqhkiG
+9w0BAQEFAAOBjQAwgYkCgYEAxW6UncZyBrIzxp+SiJnImDvJtI/xE2yjhcChn/LZ
+IOq1ktD3qfQDcd4Ck/J0rjAa6ZnEczKLsq6Qa+psSEV+cLeDAV6+u5/sOEXcgl7x
+JfYHEdoqoHEhK+mXceMySx0TMt1AgoJPC/34AvgBrMY7R/gyJwcN77bBB/xi+nF+
+dfMCAwEAAaOB4DCB3TAdBgNVHQ4EFgQUgv6eOELlgSd+z1XIAc68hbt7jV4wga0G
+A1UdIwSBpTCBooAUgv6eOELlgSd+z1XIAc68hbt7jV6hgYakgYMwgYAxCzAJBgNV
+BAYTAlVTMQ0wCwYDVQQIEwRVdGFoMRcwFQYDVQQHEw5TYWx0IExha2UgQ2l0eTES
+MBAGA1UEChMJUExULCBJbmMuMQ8wDQYDVQQDEwZsYW1iZGExJDAiBgkqhkiG9w0B
+CQEWFW1mbGF0dEBwbHQtc2NoZW1lLm9yZ4IBADAMBgNVHRMEBTADAQH/MA0GCSqG
+SIb3DQEBBAUAA4GBAB4s3hvzfG0Otle5JZFM86pVCy9LEJUiR3kH79qp2h5m+I6J
+h9otCYtrCDUfkwyoaX1bzsrSyK3SMs7wuW8l7OWDskbNip+Zh+oG/Mhj/Wor6C+x
+AddsCrCDKvjIYKs3UJpxUvz9dcaC/Q1UWRCyzn4VT2maxjWM/8MjXvtmgmQy
+-----END CERTIFICATE-----
diff --git a/collects/parser-tools/doc.txt b/collects/parser-tools/doc.txt
new file mode 100644
index 0000000000..51b1113e5d
--- /dev/null
+++ b/collects/parser-tools/doc.txt
@@ -0,0 +1,430 @@
+_parser-tools_ 
+
+This documentation assumes familiarity with lex and yacc style lexer
+and parser generators.
+
+_lex.ss_
+A _regular expression_ is one of the following:
+
+  identifier                expands to the named lex abbreviation
+  string                    matches the sequence of characters
+  character                 matches the character
+> (repetition lo hi re)     matches re repeated between lo and hi times,
+                             inclusive.  hi = +inf.0 for unbounded repetitions
+> (union re ...)            matches if any of the sub-expressions match
+> (intersection re ...)     matches if all of the sub-expressions match
+> (complement re)           matches anything that the sub-expressions does not
+> (concatenation re ...)    matches each sub-expression in succession
+> (char-range char char)    matches any character between the two (inclusive)
+                             (A single character string can be used here)
+> (char-complement re)      matches any character not matched by the sub-re.
+                             The sub-expression must be a set of characters re.
+> (char-set string)         matches any character in the string
+  (op form ...)             expands the re macro named op
+
+  (Both (concatenation) and "" match the empty string.
+   (union) matches nothing.
+   (intersection) matches any string.
+   (char-complement) matches any single character.)
+
+This regular expression language is not designed to be used directly,
+but rather as a basis for a user-friendly notation written with
+regular expression macros.  For example, _lex-sre.ss_ supplies
+operators from Olin Shivers's SREs and _lex-plt-v200.ss_ supplies
+operators from the previous version of this library.  The old plt
+syntax is deprecated.  To use one of these syntaxes, use one of the
+following commands:
+
+(require (prefix : (lib "lex-sre.ss" "parser-tools")))
+(require (prefix : (lib "lex-plt-v200.ss" "parser-tools")))
+
+The regular expression operators occupy the same namespace as other
+Scheme identifiers, so common operator names, such as * and +,
+conflict with built-in identifiers.  The suggested prefix form of
+require prefixes each imported operator with :, :* and :+, for
+example.  Of course, a prefix other than : (such as re-) will work
+too.  Unfortunately, this causes the regexps in v20x lexers to need
+some translation, even with the lex-plt-v200 operators.  The exports
+of each of these libraries is explained in their sections below.
+
+Since negation is not a common operator on regular expressions, here
+are a few examples, using : prefixed SRE syntax:
+
+(complement "1") matches all strings except the string "1",
+  including "11", "111", "0", "01", "", and so on.
+
+(complement (:* "1")) matches all strings that are not
+  sequences of "1", including "0", "00", "11110", "0111", "11001010"
+  and so on.
+
+(:& (:: any-string "111" any-string)
+    (complement (:or (:: any-string "01") (:+ "1"))))
+  matches all strings that have 3 consecutive ones, but not those that
+  end in "01" and not those that are ones only.  These include "1110",
+  "0001000111" and "0111" but not "", "11", "11101", "111" and
+  "11111".
+
+(:: "/*" (complement (:: any-string "*/" any-string)) "*/") 
+  matches Java/C block comments.  "/**/", "/******/", "/*////*/",
+  "/*asg4*/" and so on.  It does not match "/**/*/", "/* */ */" and so
+  on.  (:: any-string "*/" any-string) matches any string that has a
+  "*/" in is, so (complement (:: any-string "*/" any-string)) matches
+  any string without a "*/" in it.
+
+(:: "/*" (:* (complement "*/")) "*/")
+  matches any string that starts with "/*" and and ends with "*/",
+  including "/* */ */ */".  (complement "*/") matches any string
+  except "*/".  This includes "*" and "/" separately.  Thus (:*
+  (complement "*/")) matches "*/" by first matching "*" and then
+  matching "/".  Any other string is matched directly by (complement
+  "*/").  In other words, (:* (complement "xx")) = any-string.  It is
+  usually not correct to place a :* around a complement.
+
+
+The following require imports the _lexer generator_.
+
+(require (lib "lex.ss" "parser-tools"))
+
+
+"lex.ss" exports the following named regular expressions:
+
+> any-char:            matches any character
+> any-string:          matches any string
+> nothing:             matches no string
+> alphabetic:          see the mzscheme manual section 3.4
+> lower-case:          see the mzscheme manual section 3.4
+> upper-case:          see the mzscheme manual section 3.4
+> title-case numeric:  see the mzscheme manual section 3.4
+> symbolic:            see the mzscheme manual section 3.4
+> punctuation:         see the mzscheme manual section 3.4
+> graphic:             see the mzscheme manual section 3.4
+> whitespace:          see the mzscheme manual section 3.4
+> blank:               see the mzscheme manual section 3.4
+> iso-control:         see the mzscheme manual section 3.4
+
+
+"lex.ss" exports the following variables:
+
+> start-pos
+> end-pos
+> lexeme
+> input-port
+> return-without-pos
+   Use of these names outside of a lexer action is a syntax error.
+   See the lexer form below for their meaning when used inside a 
+   lexer action.
+
+"lex.ss" exports the following syntactic forms:
+
+> (define-lex-abbrev name re) which associates a regular expression
+   with a name to be used in other regular expressions with the
+   identifier form.  The definition of name has the same scoping
+   properties as a normal mzscheme macro definition.
+
+> (define-lex-abbrevs (name re) ...) defines several lex-abbrevs
+
+> (define-lex-trans name trans) define a regular expression macro.
+   When the name appears as an operator in a regular expression, the
+   expression is replaced with the result of the transformer.  The
+   definition of name has the same scoping properties as a normal
+   mzscheme macro definition.  For examples, see the file
+   ${PLTHOME}/collects/parser-tools/lex-sre.ss which contains simple,
+   but useful, regular expression macro definitions.
+
+
+> (lexer (re action) ...) expands into a function that takes an
+   input-port, matches the re's against the buffer, and returns the
+   result of executing the corresponding action.  Each action is
+   scheme code that has the same scope as the enclosing lexer definition.
+   The following variables have special meaning inside of a lexer
+   action:
+    start-pos - a position struct for the first character matched
+    end-pos - a position struct for the character after the last
+      character in the match
+    lexeme - the matched string
+    input-port - the input-port being processed (this is useful for
+      matching input with multiple lexers)
+    (return-without-pos x) is a function (continuation) that
+     immediately returns the value of x from the lexer.  This useful
+     in a src-pos lexer to prevent the lexer from adding source
+     information.  For example:
+     (define get-token
+       (lexer-src-pos
+       ...
+       ((comment) (get-token input-port))
+       ...))
+     would wrap the source location information for the comment around
+     the value of the recursive call.  Using
+     ((comment) (return-without-pos (get-token input-port))) 
+     will cause the value of the recursive call to be returned without
+     wrapping position around it.
+
+   The lexer raises an exception (exn:read) if none of the regular
+   expressions match the input.
+   Hint: If (any-char custom-error-behavior) is the last rule,
+   then there will always be a match and custom-error-behavior will be
+   executed to handle the error situation as desired, only consuming
+   the first character from the input buffer.
+
+   The lexer treats the rules ((eof) action), ((special) action), and
+   ((special-comment) action) specially.  In addition to returning
+   characters, input ports can return eof-objects.  Custom input ports
+   can also return a special-comment value to indicate a non-textual
+   comment, or return another arbitrary value (a special).
+
+   The eof rule is matched when the input port returns an eof value.
+   If no eof rule is present, the lexer returns the symbol 'eof when
+   the port returns an eof value.
+
+   The special-comment rule is matched when the input port returns a
+   special-comment structure.  If no special-comment rule is present,
+   the lexer automatically tries to return the next token from the
+   input port.
+
+   The special rule is matched when the input port returns a value
+   other than a character, eof-object, or special-comment structure.
+   If no special rule is present, the lexer returns void.
+
+   Eofs, specials, special-comments and special-errors can never be
+   part of a lexeme with surrounding characters.
+
+   When peeking from the input port raises an exception (such as by an
+   embedded XML editor with malformed syntax), the exception can be
+   raised before all tokens preceeding the exception have been
+   returned.
+
+
+> (lexer-src-pos (re action) ...) is a lexer that returns
+   (make-position-token action-result start-pos end-pos) instead of
+   simply action-result.
+   
+> (define-tokens group-name (token-name ...)) binds group-name to the
+   group of tokens being defined.  For each token-name, t, a function
+   (token-t expr) is created.  It constructs a token structure with
+   name t and stores the value of expr in it.  The definition of
+   group-name has the same scoping properties as a normal mzscheme
+   macro definition.  A token cannot be named error since it has
+   special use in the parser.
+
+> (define-empty-tokens group-name (token-name ...)) is like
+   define-tokens, except a resulting token constructor take no
+   arguments and returns the name as a symbol.  (token-t) returns 't.
+
+
+HINT: Token definitions are usually necessary for inter-operating with
+a generated parser, but may not be the right choice when using the
+lexer in other situations.
+
+"lex.ss" exports the following token helper functions:
+
+> (token-name token) returns the name of a token that is represented either
+   by a symbol or a token structure.
+
+> (token-value token) returns the value of a token that is represented either
+   by a symbol or a token structure.  It returns #f for a symbol token.
+> (token? val) returns #t if val is a token structure and #f otherwise.
+
+
+"lex.ss" exports the following structures:
+
+> (struct position (offset line col))
+   These structures are bound to start-pos and end-pos.
+   Offset is the offset of the character in the input.
+   Line in the line number of the character.
+   Col is the offset in the current line.
+
+> (struct position-token (token start-pos end-pos))
+   src-pos-lexers return these.
+
+"lex.ss" exports the following parameter for tracking the source file:
+
+> (file-path string) - sets the parameter file-path, which the lexer
+   will use as the source location if it raises a read error.  This
+   allows DrScheme to open the file containing the error.
+
+
+Each time the scheme code for a lexer is compiled (e.g. when a .ss
+file containing a (lex ...) is loaded/required) the lexer generator is
+run.  To avoid this overhead place the lexer into a module and compile
+the module to a .zo with 'mzc --zo --auto-dir filename'.  This should
+create a .zo file in the 'compiled' subdirectory.
+
+Compiling the lex.ss file to an extension can produce a good speedup
+in generated lexers since the lex.ss file contains the interpreter for
+the generated lex tables.  If mzscheme is able to compile extensions
+(a c compiler must be available) run the commands:
+cd ${PLTHOME}/collects/parser-tools
+mzc --auto-dir lex.ss
+
+NOTE: Since the lexer gets its source information from the port, use
+port-count-lines! to enable the tracking of line and column information.
+Otherwise the line and column information will return #f.
+
+The file ${PLTHOME}/collects/syntax-color/scheme-lexer.ss contains a
+lexer for Scheme, as extended by mzscheme.  The files in
+${PLTHOME}/collects/parser-tools/examples contain simpler example
+lexers.
+
+
+
+
+_lex-sre.ss_
+The lex-sre.ss module exports the following regular expression
+operators:
+> (* re ...)       repetition of regexps 0 or more times 
+> (+ re ...)       repetition of regexps 1 or more times 
+> (? re ...)       0 or 1 occurrence of regexps
+> (= natural-number re ...)
+                   exactly n occurences of regexps
+> (>= natural-number re ...)
+                   at least n occurences of regexps
+> (** natural-number natural-number-or-#f-or-+inf.0 re ...)
+                   between m and n of regexps, inclusive
+                     #f and +inf.0 both indicate no upper limit
+> (or re ...)      union 
+> (: re ...)       concatenation 
+> (seq re ...)     concatenation
+> (& re ...)       intersection
+> (~ re ...)       character set complement, each given regexp must match
+                     exactly one character
+> (- re re ...)    character set difference, each given regexp must match
+                     exactly one character
+> (/ char-or-string ...)
+                   character ranges, matches characters between successive 
+                     pairs of chars.
+
+
+_yacc.ss_
+
+To use the _parser generator_ (require (lib "yacc.ss" "parser-tools")).
+This module provides the following syntactic form:
+
+> (parser args ...) where the possible args may come in any order (as
+  long as there are no duplicates and all non-optional arguments are
+  present) and are:
+
+  > (debug filename) OPTIONAL causes the parser generator to write the
+     LALR table to the file named filename (unless the file exists).
+     filename must be a string.  Additionally, if a debug file is
+     specified, when a running generated parser encounters a parse
+     error on some input file, after the user specified error
+     expression returns, the complete parse stack is printed to assist
+     in debugging the grammar of that particular parser.  The numbers
+     in the stack printout correspond to the state numbers in the LALR
+     table file.
+
+  > (yacc-output filename) OPTIONAL causes the parser generator to
+     write a grammar file in the syntax of YACC/Bison.  The file might
+     not be a valid YACC file because the scheme grammar can use
+     symbols that are invalid in C.
+
+  > (suppress) OPTIONAL causes the parser generator not to report
+     shift/reduce or reduce/reduce conflicts.
+
+  > (src-pos) OPTIONAL causes the generated parser to expect input in
+     the form (make-position-token token position position) instead of
+     simply token.  Include this option when using the parser with a
+     lexer generated with lexer-src-pos.
+
+  > (error expression) expression should evaluate to a function which
+     will be executed for its side-effect whenever the parser
+     encounters an error.  If the src-pos option is present, the
+     function should accept 5 arguments, 
+     (lambda (token-ok token-name token-value start-pos end-pos) ...).     
+     Otherwise it should accept 3, 
+     (lambda (token-ok token-name token-value) ...).
+     The first argument will be #f iff the error is that an invalid
+     token was received.  The second and third arguments will be the
+     name and the value of the token at which the error was detected.
+     The fourth and fifth arguments, if present, provide the source
+     positions of that token.
+
+  > (tokens group-name ...) declares that all of the tokens defined in
+     the groups can be handled by this parser.
+
+  > (start non-terminal-name ...) declares a list of starting
+     non-terminals for the grammar.
+
+  > (end token-name ...) specifies a set of tokens from which some
+     member must follow any valid parse.  For example an EOF token
+     would be specified for a parser that parses entire files and a
+     NEWLINE token for a parser that parses entire lines individually.
+
+  > (precs (assoc token-name ...) ...) OPTIONAL precedence
+     declarations to resolve shift/reduce and reduce/reduce conflicts
+     as in YACC/BISON.  assoc must be one of left, right or nonassoc.
+     States with multiple shift/reduce or reduce/reduce conflicts or
+     some combination thereof are not resolved with precedence.
+
+  > (grammar (non-terminal ((grammar-symbol ...) (prec token-name) expression)
+                            ...) 
+              ...)
+
+     declares the grammar to be parsed.  Each grammar-symbol must be a
+     token-name or non-terminal.  The prec declaration is optional.
+     expression is a semantic action which will be evaluated when the
+     input is found to match its corresponding production.  Each
+     action is scheme code that has the same scope as its parser's
+     definition, except that the variables $1, ..., $n are bound in
+     the expression and may hide outside bindings of $1, ... $n.  $x
+     is bound to the result of the action for the $xth grammar symbol
+     on the right of the production, if that grammar symbol is a
+     non-terminal, or the value stored in the token if the grammar
+     symbol is a terminal.  Here n is the number of grammar-symbols on
+     the right of the production.  If the src-pos option is present in
+     the parser, variables $1-start-pos, ..., $n-start-pos and
+     $1-end-pos, ..., $n-end-pos are also available and refer to the
+     position structures corresponding to the start and end of the
+     corresponding grammar-symbol.  Grammar symbols defined as
+     empty-tokens have no $n associated, but do have $n-start-pos and
+     $n-end-pos.  All of the productions for a given non-terminal must
+     be grouped with it, i.e. No non-terminal may appear twice on the
+     left hand side in a parser.
+
+The result of a parser expression with one start non-terminal is a
+function, f, that takes one argument.  This argument must be a zero
+argument function, t, that produces successive tokens of the input
+each time it is called.  If desired, the t may return symbols instead
+of tokens.  The parser will treat symbols as tokens of the
+corresponding name (with #f as a value, so it is usual to return
+symbols only in the case of empty tokens).  f returns the value
+associated with the parse tree by the semantic actions.  If the parser
+encounters an error, after invoking the supplied error function, it
+will try to use error productions to continue parsing.  If it cannot,
+it raises a read error.
+
+If multiple start non-terminals are provided, the parser expression
+will result in a list of parsing functions (each one will individually
+behave as if it were the result of a parser expression with only one
+start non-terminal), one for each start non-terminal, in the same order.
+
+Each time the scheme code for a parser is compiled (e.g. when a .ss
+file containing a (parser ...) is loaded/required) the parser
+generator is run.  To avoid this overhead place the lexer into a
+module and compile the module to a .zo with 'mzc --zo --auto-dir
+filename'.  This should create a .zo file in the 'compiled'
+subdirectory.
+
+Compiling the yacc.ss file to an extension can produce a good speedup
+in generated parsers since the yacc.ss file contains the interpreter
+for the generated parse tables.  If mzscheme is able to compile
+extensions (a c compiler must be available) run the commands:
+cd ${PLTHOME}/collects/parser-tools
+mzc --auto-dir yacc.ss
+
+
+_yacc-to-scheme.ss_
+This library provides one function:
+> (trans filename) - reads a C YACC/BISON grammar from filename and
+   produces an s-expression that represents a scheme parser for use
+   with the yacc.ss module.
+This library is intended to assist in the manual conversion of
+grammars for use with yacc.ss and not as a fully automatic conversion
+tool.  It is not entirely robust.  For example, if the C actions in
+the original grammar have nested blocks the tool will fail.
+
+
+Annotated examples are in the examples subdirectory of the parser-tools
+collection directory.
+
+
diff --git a/collects/parser-tools/examples/calc.ss b/collects/parser-tools/examples/calc.ss
new file mode 100644
index 0000000000..ba65091eb0
--- /dev/null
+++ b/collects/parser-tools/examples/calc.ss
@@ -0,0 +1,88 @@
+;; An interactive calculator inspired by the calculator example in the bison manual.
+
+
+;; Import the parser and lexer generators.
+(require (lib "yacc.ss" "parser-tools")
+         (lib "lex.ss" "parser-tools")
+         (prefix : (lib "lex-sre.ss" "parser-tools")))
+
+(define-tokens value-tokens (NUM VAR FNCT))
+(define-empty-tokens op-tokens (newline = OP CP + - * / ^ EOF NEG))
+
+;; A hash table to store variable values in for the calculator
+(define vars (make-hash-table))
+
+(define-lex-abbrevs
+ (lower-letter (:/ "a" "z"))
+
+ (upper-letter (:/ #\A #\Z))
+
+ ;; (:/ 0 9) would not work because the lexer does not understand numbers.  (:/ #\0 #\9) is ok too.
+ (digit (:/ "0" "9")))
+ 
+(define calcl
+  (lexer
+   [(eof) 'EOF]
+   ;; recursively call the lexer on the remaining input after a tab or space.  Returning the
+   ;; result of that operation.  This effectively skips all whitespace.
+   [(:or #\tab #\space) (calcl input-port)]
+   ;; (token-newline) returns 'newline
+   [#\newline (token-newline)]
+   ;; Since (token-=) returns '=, just return the symbol directly
+   [(:or "=" "+" "-" "*" "/" "^") (string->symbol lexeme)]
+   ["(" 'OP]
+   [")" 'CP]
+   ["sin" (token-FNCT sin)]
+   [(:+ (:or lower-letter upper-letter)) (token-VAR (string->symbol lexeme))]
+   [(:+ digit) (token-NUM (string->number lexeme))]
+   [(:: (:+ digit) #\. (:* digit)) (token-NUM (string->number lexeme))]))
+   
+
+(define calcp
+  (parser
+
+   (start start)
+   (end newline EOF)
+   (tokens value-tokens op-tokens)
+   (error (lambda (a b c) (void)))
+
+   (precs (right =)
+          (left - +)
+          (left * /)
+          (left NEG)
+          (right ^))
+   
+   (grammar
+    
+    (start [() #f]
+           ;; If there is an error, ignore everything before the error
+           ;; and try to start over right after the error
+           [(error start) $2]
+           [(exp) $1])
+    
+    (exp [(NUM) $1]
+         [(VAR) (hash-table-get vars $1 (lambda () 0))]
+         [(VAR = exp) (begin (hash-table-put! vars $1 $3)
+                             $3)]
+         [(FNCT OP exp CP) ($1 $3)]
+         [(exp + exp) (+ $1 $3)]
+         [(exp - exp) (+ $1 $3)]
+         [(exp * exp) (* $1 $3)]
+         [(exp / exp) (/ $1 $3)]
+         [(- exp) (prec NEG) (- $2)]
+         [(exp ^ exp) (expt $1 $3)]
+         [(OP exp CP) $2]))))
+           
+;; run the calculator on the given input-port       
+(define (calc ip)
+  (port-count-lines! ip)
+  (letrec ((one-line
+	    (lambda ()
+	      (let ((result (calcp (lambda () (calcl ip)))))
+		(if result
+		    (begin
+		      (printf "~a~n" result)
+		      (one-line)))))))
+    (one-line)))
+
+(calc (open-input-string "(1 + 2 * 3 3) 3)\n(1.2 + 3.3) / 44 \n !"))
diff --git a/collects/parser-tools/examples/read.ss b/collects/parser-tools/examples/read.ss
new file mode 100644
index 0000000000..68838a1a5e
--- /dev/null
+++ b/collects/parser-tools/examples/read.ss
@@ -0,0 +1,242 @@
+;; This implements the equivalent of mzscheme's read-syntax for R5RS scheme.
+;; It has not been thoroughly tested.  Also it will read an entire file into a 
+;; list of syntax objects, instead of returning one syntax object at a time
+
+(module read mzscheme
+  
+  (require (lib "lex.ss" "parser-tools")
+           (prefix : (lib "lex-sre.ss" "parser-tools"))
+           (lib "yacc.ss" "parser-tools")
+           (lib "readerr.ss" "syntax"))
+  
+  (define-tokens data (DATUM))
+  (define-empty-tokens delim (OP CP HASHOP QUOTE QUASIQUOTE UNQUOTE UNQUOTE-SPLICING DOT EOF))
+  
+  (define scheme-lexer
+    (lexer-src-pos
+     
+     ;; Skip comments, without accumulating extra position information
+     [(:or scheme-whitespace comment) (return-without-pos (scheme-lexer input-port))]
+     
+     ["#t" (token-DATUM #t)]
+     ["#f" (token-DATUM #f)]
+     [(:: "#\\" any-char) (token-DATUM (caddr (string->list lexeme)))]
+     ["#\\space" (token-DATUM #\space)]
+     ["#\\newline" (token-DATUM #\newline)]
+     [(:or (:: initial (:* subsequent)) "+" "-" "...") (token-DATUM (string->symbol lexeme))]
+     [#\" (token-DATUM (list->string (get-string-token input-port)))]
+     [#\( 'OP]
+     [#\) 'CP]
+     [#\[ 'OP]
+     [#\] 'CP]
+     ["#(" 'HASHOP]
+     [num2 (token-DATUM (string->number lexeme 2))]
+     [num8 (token-DATUM (string->number lexeme 8))]
+     [num10 (token-DATUM (string->number lexeme 10))]
+     [num16 (token-DATUM (string->number lexeme 16))]
+     ["'" 'QUOTE]
+     ["`" 'QUASIQUOTE]
+     ["," 'UNQUOTE]
+     [",@" 'UNQUOTE-SPLICING]
+     ["." 'DOT]
+     [(eof) 'EOF]))
+  
+  (define get-string-token
+    (lexer
+     [(:~ #\" #\\) (cons (car (string->list lexeme))
+                         (get-string-token input-port))]
+     [(:: #\\ #\\) (cons #\\ (get-string-token input-port))]
+     [(:: #\\ #\") (cons #\" (get-string-token input-port))]
+     [#\" null]))
+  
+  
+  (define-lex-abbrevs
+   [letter (:or (:/ "a" "z") (:/ #\A #\Z))]
+   [digit (:/ #\0 #\9)]
+   [scheme-whitespace (:or #\newline #\return #\tab #\space #\vtab)]
+   [initial (:or letter (char-set "!$%&*/:<=>?^_~@"))]
+   [subsequent (:or initial digit (char-set "+-.@"))]
+   [comment (:: #\; (:* (:~ #\newline)) #\newline)]
+   
+   
+   ;; See ${PLTHOME}/collects/syntax-color/scheme-lexer.ss for an example of
+   ;; using regexp macros to avoid the cut and paste.
+   ;   [numR (:: prefixR complexR)]
+   ;   [complexR (:or realR
+   ;                (:: realR "@" realR)
+   ;                (:: realR "+" urealR "i")
+   ;                (:: realR "-" urealR "i")
+   ;                (:: realR "+i")
+   ;                (:: realR "-i")
+   ;                (:: "+" urealR "i")
+   ;                (:: "-" urealR "i")
+   ;                (:: "+i")
+   ;                (:: "-i"))]
+   ;   [realR (:: sign urealR)]
+   ;   [urealR (:or uintegerR (:: uintegerR "/" uintegerR) decimalR)]
+   ;   [uintegerR (:: (:+ digitR) (:* #\#))]
+   ;   [prefixR (:or (:: radixR exactness)
+   ;               (:: exactness radixR))]
+   
+   [num2 (:: prefix2 complex2)]
+   [complex2 (:or real2
+                  (:: real2 "@" real2)
+                  (:: real2 "+" ureal2 "i")
+                  (:: real2 "-" ureal2 "i")
+                  (:: real2 "+i")
+                  (:: real2 "-i")
+                  (:: "+" ureal2 "i")
+                  (:: "-" ureal2 "i")
+                  (:: "+i")
+                  (:: "-i"))]
+   [real2 (:: sign ureal2)]
+   [ureal2 (:or uinteger2 (:: uinteger2 "/" uinteger2))]
+   [uinteger2 (:: (:+ digit2) (:* #\#))]
+   [prefix2 (:or (:: radix2 exactness)
+                 (:: exactness radix2))]
+   [radix2 "#b"]
+   [digit2 (:or "0" "1")]
+   [num8 (:: prefix8 complex8)]
+   [complex8 (:or real8
+                  (:: real8 "@" real8)
+                  (:: real8 "+" ureal8 "i")
+                  (:: real8 "-" ureal8 "i")
+                  (:: real8 "+i")
+                  (:: real8 "-i")
+                  (:: "+" ureal8 "i")
+                  (:: "-" ureal8 "i")
+                  (:: "+i")
+                  (:: "-i"))]
+   [real8 (:: sign ureal8)]
+   [ureal8 (:or uinteger8 (:: uinteger8 "/" uinteger8))]
+   [uinteger8 (:: (:+ digit8) (:* #\#))]
+   [prefix8 (:or (:: radix8 exactness)
+                 (:: exactness radix8))]
+   [radix8 "#o"]
+   [digit8 (:/ "0" "7")]
+   
+   [num10 (:: prefix10 complex10)]
+   [complex10 (:or real10
+                   (:: real10 "@" real10)
+                   (:: real10 "+" ureal10 "i")
+                   (:: real10 "-" ureal10 "i")
+                   (:: real10 "+i")
+                   (:: real10 "-i")
+                   (:: "+" ureal10 "i")
+                   (:: "-" ureal10 "i")
+                   (:: "+i")
+                   (:: "-i"))]
+   [real10 (:: sign ureal10)]
+   [ureal10 (:or uinteger10 (:: uinteger10 "/" uinteger10) decimal10)]
+   [uinteger10 (:: (:+ digit10) (:* #\#))]
+   [prefix10 (:or (:: radix10 exactness)
+                  (:: exactness radix10))]
+   [radix10 (:? "#d")]
+   [digit10 digit]
+   [decimal10 (:or (:: uinteger10 suffix)
+                   (:: #\. (:+ digit10) (:* #\#) suffix)
+                   (:: (:+ digit10) #\. (:* digit10) (:* #\#) suffix)
+                   (:: (:+ digit10) (:+ #\#) #\. (:* #\#) suffix))]
+   
+   [num16 (:: prefix16 complex16)]
+   [complex16 (:or real16
+                   (:: real16 "@" real16)
+                   (:: real16 "+" ureal16 "i")
+                   (:: real16 "-" ureal16 "i")
+                   (:: real16 "+i")
+                   (:: real16 "-i")
+                   (:: "+" ureal16 "i")
+                   (:: "-" ureal16 "i")
+                   "+i"
+                   "-i")]
+   [real16 (:: sign ureal16)]
+   [ureal16 (:or uinteger16 (:: uinteger16 "/" uinteger16))]
+   [uinteger16 (:: (:+ digit16) (:* #\#))]
+   [prefix16 (:or (:: radix16 exactness)
+                  (:: exactness radix16))]
+   [radix16 "#x"]
+   [digit16 (:or digit (:/ #\a #\f) (:/ #\A #\F))]
+   
+   
+   [suffix (:or "" (:: exponent-marker sign (:+ digit10)))]
+   [exponent-marker (:or "e" "s" "f" "d" "l")]
+   [sign (:or "" "+" "-")]
+   [exactness (:or "" "#i" "#e")])
+  
+  
+  (define stx-for-original-property (read-syntax #f (open-input-string "original")))
+  
+  ;; A macro to build the syntax object
+  (define-syntax (build-so stx)
+    (syntax-case stx ()
+      ((_ value start end)
+       (with-syntax ((start-pos (datum->syntax-object 
+                                 (syntax end)
+                                 (string->symbol 
+                                  (format "$~a-start-pos"
+                                          (syntax-object->datum (syntax start))))))
+                     (end-pos (datum->syntax-object 
+                               (syntax end)
+                               (string->symbol 
+                                (format "$~a-end-pos"
+                                        (syntax-object->datum (syntax end))))))
+                     (source (datum->syntax-object
+                              (syntax end)
+                              'source-name)))
+         (syntax
+          (datum->syntax-object 
+           #f
+           value
+           (list source 
+                 (position-line start-pos)
+                 (position-col start-pos)
+                 (position-offset start-pos)
+                 (- (position-offset end-pos)
+                    (position-offset start-pos)))
+           stx-for-original-property))))))
+  
+  (define (scheme-parser source-name)
+    (parser
+     (src-pos)
+     
+     (start s)
+     (end EOF)
+     (error (lambda (a name val start end)
+              (raise-read-error 
+               "read-error"
+               source-name
+               (position-line start)
+               (position-col start)
+               (position-offset start)
+               (- (position-offset end)
+                  (position-offset start)))))
+     (tokens data delim)
+     
+     
+     (grammar
+      
+      (s [(sexp-list) (reverse $1)])
+      
+      (sexp [(DATUM) (build-so $1 1 1)]
+            [(OP sexp-list CP) (build-so (reverse $2) 1 3)]
+            [(HASHOP sexp-list CP) (build-so (list->vector (reverse $2)) 1 3)]
+            [(QUOTE sexp) (build-so (list 'quote $2) 1 2)]
+            [(QUASIQUOTE sexp) (build-so (list 'quasiquote $2) 1 2)]
+            [(UNQUOTE sexp) (build-so (list 'unquote $2) 1 2)]
+            [(UNQUOTE-SPLICING sexp) (build-so (list 'unquote-splicing $2) 1 2)]
+            [(OP sexp-list DOT sexp CP) (build-so (append (reverse $2) $4) 1 5)])
+      
+      (sexp-list [() null]
+                 [(sexp-list sexp) (cons $2 $1)]))))
+  
+  (define (rs sn ip)
+    (port-count-lines! ip)
+    ((scheme-parser sn) (lambda () (scheme-lexer ip))))
+  
+  (define readsyntax
+    (case-lambda ((sn) (rs sn (current-input-port)))
+                 ((sn ip) (rs sn ip))))
+  
+  (provide (rename readsyntax read-syntax))
+  
+  )
\ No newline at end of file
diff --git a/collects/parser-tools/info.ss b/collects/parser-tools/info.ss
new file mode 100644
index 0000000000..8326e98d1d
--- /dev/null
+++ b/collects/parser-tools/info.ss
@@ -0,0 +1,5 @@
+
+(module info (lib "infotab.ss" "setup")
+  (define doc.txt "doc.txt")
+  (define name "Parser-tools"))
+
diff --git a/collects/parser-tools/lex-plt-v200.ss b/collects/parser-tools/lex-plt-v200.ss
new file mode 100644
index 0000000000..939c51a4ad
--- /dev/null
+++ b/collects/parser-tools/lex-plt-v200.ss
@@ -0,0 +1,24 @@
+(module lex-plt-v200 mzscheme
+  (require (lib "lex.ss" "parser-tools")
+           (prefix : (lib "lex-sre.ss" "parser-tools")))
+  
+  (provide epsilon
+           ~
+           (rename :* *)
+           (rename :+ +)
+           (rename :? ?)
+           (rename :or :)
+           (rename :& &)
+           (rename :: @)
+           (rename :~ ^)
+           (rename :/ -))
+           
+  (define-lex-trans epsilon
+    (syntax-rules ()
+      ((_) "")))
+  
+  (define-lex-trans ~
+    (syntax-rules ()
+      ((_ re) (complement re)))))
+  
+  
diff --git a/collects/parser-tools/lex-sre.ss b/collects/parser-tools/lex-sre.ss
new file mode 100644
index 0000000000..6c8d777d4c
--- /dev/null
+++ b/collects/parser-tools/lex-sre.ss
@@ -0,0 +1,119 @@
+(module lex-sre mzscheme
+  (require (lib "lex.ss" "parser-tools"))
+    
+  (provide (rename sre-* *)
+           (rename sre-+ +)
+           ?
+           (rename sre-= =)
+           (rename sre->= >=)
+           **
+           (rename sre-or or)
+           :
+           seq
+           &
+           ~
+           (rename sre-- -)
+           (rename sre-/ /)
+           /-only-chars)
+           
+  (define-lex-trans sre-*
+    (syntax-rules ()
+      ((_ re ...)
+       (repetition 0 +inf.0 (union re ...)))))
+
+  (define-lex-trans sre-+
+    (syntax-rules ()
+      ((_ re ...)
+       (repetition 1 +inf.0 (union re ...)))))
+
+  (define-lex-trans ?
+    (syntax-rules ()
+      ((_ re ...)
+       (repetition 0 1 (union re ...)))))
+  
+  (define-lex-trans sre-=
+    (syntax-rules ()
+      ((_ n re ...)
+       (repetition n n (union re ...)))))
+  
+  (define-lex-trans sre->=
+    (syntax-rules ()
+      ((_ n re ...)
+       (repetition n +inf.0 (union re ...)))))
+
+  (define-lex-trans **
+    (syntax-rules ()
+      ((_ low #f re ...)
+       (** low +inf.0 re ...))
+      ((_ low high re ...)
+       (repetition low high (union re ...)))))
+  
+  (define-lex-trans sre-or
+    (syntax-rules ()
+      ((_ re ...)
+       (union re ...))))
+  
+  (define-lex-trans :
+    (syntax-rules ()
+      ((_ re ...)
+       (concatenation re ...))))
+
+  (define-lex-trans seq
+    (syntax-rules ()
+      ((_ re ...)
+       (concatenation re ...))))
+
+  (define-lex-trans &
+    (syntax-rules ()
+      ((_ re ...)
+       (intersection re ...))))
+
+  (define-lex-trans ~
+    (syntax-rules ()
+      ((_ re ...)
+       (char-complement (union re ...)))))
+  
+  ;; char-set difference
+  (define-lex-trans (sre-- stx)
+    (syntax-case stx ()
+      ((_)
+       (raise-syntax-error #f
+                           "must have at least one argument"
+                           stx))
+      ((_ big-re re ...)
+       (syntax (intersect big-re (~ (union re) ...))))))
+  
+  (define-lex-trans (sre-/ stx)
+    (syntax-case stx ()
+      ((_ range ...)
+       (let ((chars
+              (apply append (map (lambda (r)
+                                   (let ((x (syntax-e r)))
+                                     (cond
+                                       ((char? x) (list x))
+                                       ((string? x) (string->list x))
+                                       (else
+                                        (raise-syntax-error 
+                                         #f
+                                         "not a char or string"
+                                         stx
+                                         r)))))
+                                 (syntax->list (syntax (range ...)))))))
+         (unless (even? (length chars))
+           (raise-syntax-error
+            #f
+            "not given an even number of characters"
+            stx))
+         #`(/-only-chars #,@chars)))))
+  
+  (define-lex-trans /-only-chars
+    (syntax-rules ()
+      ((_ c1 c2)
+       (char-range c1 c2))
+      ((_ c1 c2 c ...)
+       (union (char-range c1 c2)
+              (/-only-chars c ...)))))
+  
+  )
+                           
+   
diff --git a/collects/parser-tools/lex.ss b/collects/parser-tools/lex.ss
new file mode 100644
index 0000000000..e0a1e28b2b
--- /dev/null
+++ b/collects/parser-tools/lex.ss
@@ -0,0 +1,383 @@
+(module lex mzscheme
+
+  ;; Provides the syntax used to create lexers and the functions needed to
+  ;; create and use the buffer that the lexer reads from.  See doc.txt.
+	
+  (require-for-syntax (lib "list.ss")
+                      (lib "stx.ss" "syntax")
+                      (lib "define.ss" "syntax")
+                      (lib "boundmap.ss" "syntax")
+                      "private-lex/util.ss"
+                      "private-lex/actions.ss"
+                      "private-lex/front.ss"
+                      "private-lex/unicode-chars.ss")
+
+  (require (lib "stxparam.ss")
+           (lib "readerr.ss" "syntax")
+           "private-lex/token.ss")
+
+  (provide lexer lexer-src-pos define-lex-abbrev define-lex-abbrevs define-lex-trans
+           
+           ;; Dealing with tokens and related structures 
+           define-tokens define-empty-tokens token-name token-value token?
+           (struct position (offset line col))
+           (struct position-token (token start-pos end-pos))
+           
+           ;; File path for highlighting errors while lexing
+           file-path
+           
+           ;; Lex abbrevs for unicode char sets.  See mzscheme manual section 3.4.
+           any-char any-string nothing alphabetic lower-case upper-case title-case
+           numeric symbolic punctuation graphic whitespace blank iso-control
+
+           ;; A regular expression operator
+           char-set)
+  
+  ;; wrap-action: syntax-object src-pos? -> syntax-object
+  (define-for-syntax (wrap-action action src-pos?)
+    (with-syntax ((action-stx 
+                   (if src-pos?
+                       #`(let/ec ret
+                           (syntax-parameterize 
+                            ((return-without-pos (make-rename-transformer #'ret)))
+                            (make-position-token #,action start-pos end-pos)))
+                        action)))
+      (syntax/loc action
+        (lambda (start-pos-p end-pos-p lexeme-p input-port-p)
+          (syntax-parameterize 
+           ((start-pos (make-rename-transformer #'start-pos-p))
+            (end-pos (make-rename-transformer #'end-pos-p))
+            (lexeme (make-rename-transformer #'lexeme-p))
+            (input-port (make-rename-transformer #'input-port-p)))
+           action-stx)))))
+        
+  (define-for-syntax (make-lexer-trans src-pos?)
+    (lambda (stx)
+      (syntax-case stx ()
+        ((_ re-act ...)
+         (begin
+           (for-each
+            (lambda (x)
+              (syntax-case x ()
+                ((re act) (void))
+                (_ (raise-syntax-error #f
+                                       "not a regular expression / action pair"
+                                       stx
+                                       x))))
+            (syntax->list (syntax (re-act ...))))
+           (let* ((spec/re-act-lst
+                   (syntax->list (syntax (re-act ...))))
+                  (eof-act
+                   (get-special-action spec/re-act-lst #'eof #''eof))
+                  (spec-act 
+                   (get-special-action spec/re-act-lst #'special #'(void)))
+                  (spec-comment-act 
+                   (get-special-action spec/re-act-lst #'special-comment #'#f))
+                  (ids (list #'special #'special-comment #'eof))
+                  (re-act-lst
+                   (filter
+                    (lambda (spec/re-act)
+                      (syntax-case spec/re-act ()
+                        (((special) act)
+                           (not (ormap
+                                 (lambda (x)
+                                   (module-or-top-identifier=? (syntax special) x))
+                                 ids)))
+                        (_ #t)))
+                    spec/re-act-lst))
+		  (name-lst (map (lambda (x) (datum->syntax-object #f (gensym))) re-act-lst))
+		  (act-lst (map (lambda (x) (stx-car (stx-cdr x))) re-act-lst))
+		  (re-actname-lst (map (lambda (re-act name)
+					 (list (stx-car re-act)
+					       name))
+				       re-act-lst
+				       name-lst)))
+             (let-values (((trans start action-names no-look disappeared-uses)
+                           (build-lexer re-actname-lst)))
+               (when (vector-ref action-names start) ;; Start state is final
+                 (unless (and 
+                          ;; All the successor states are final
+                          (andmap (lambda (x) (vector-ref action-names (vector-ref x 2)))
+                                      (vector->list (vector-ref trans start)))
+                          ;; Each character has a successor state
+                          (let loop ((check 0)
+                                     (nexts (vector->list (vector-ref trans start))))
+                            (cond
+                              ((null? nexts) #f)
+                              (else
+                               (let ((next (car nexts)))
+                                 (and (= (vector-ref next 0) check)
+                                      (let ((next-check (vector-ref next 1)))
+                                        (or (>= next-check max-char-num)
+                                            (loop (add1 next-check) (cdr nexts))))))))))
+                   (printf "Warning: lexer at ~a can accept the empty string.~n" stx)))
+               (with-syntax ((start-state-stx start)
+                             (trans-table-stx trans)
+                             (no-lookahead-stx no-look)
+			     ((name ...) name-lst)
+			     ((act ...) (map (lambda (a)
+					       (wrap-action a src-pos?))
+					     act-lst))
+			     ((act-name ...) (vector->list action-names))
+			     (spec-act-stx
+                              (wrap-action spec-act src-pos?))
+                             (has-comment-act?-stx 
+                              (if (syntax-e spec-comment-act) #t #f))
+                             (spec-comment-act-stx
+                              (wrap-action spec-comment-act src-pos?))
+                             (eof-act-stx (wrap-action eof-act src-pos?)))
+                 (syntax-property
+                  (syntax/loc stx
+		    (let ([name act] ...)
+		      (lexer-body start-state-stx 
+				  trans-table-stx
+				  (vector act-name ...)
+				  no-lookahead-stx
+				  spec-act-stx
+				  has-comment-act?-stx
+				  spec-comment-act-stx
+				  eof-act-stx)))
+                  'disappeared-use
+                  disappeared-uses)))))))))
+
+  (define-syntax lexer (make-lexer-trans #f))
+  (define-syntax lexer-src-pos (make-lexer-trans #t))
+    
+  (define-syntax (define-lex-abbrev stx)
+    (syntax-case stx ()
+      ((_ name re)
+       (identifier? (syntax name))
+       (syntax/loc stx
+        (define-syntax name
+          (make-lex-abbrev (quote-syntax re)))))
+      (_ 
+       (raise-syntax-error
+        #f
+        "form should be (define-lex-abbrev name re)"
+        stx))))
+
+  (define-syntax (define-lex-abbrevs stx)
+    (syntax-case stx ()
+      ((_ x ...)
+       (with-syntax (((abbrev ...)
+                      (map 
+                       (lambda (a)
+                         (syntax-case a ()
+                           ((name re)
+                            (identifier? (syntax name))
+                            (syntax/loc a (define-lex-abbrev name re)))
+                           (_ (raise-syntax-error
+                               #f
+                               "form should be (define-lex-abbrevs (name re) ...)"
+                               stx
+                               a))))
+                       (syntax->list (syntax (x ...))))))
+         (syntax/loc stx (begin abbrev ...))))
+      (_
+       (raise-syntax-error
+        #f
+        "form should be (define-lex-abbrevs (name re) ...)"
+        stx))))
+
+  (define-syntax (define-lex-trans stx)
+    (syntax-case stx ()
+      ((_ name-form body-form)
+       (let-values (((name body)
+                     (normalize-definition (syntax (define-syntax name-form body-form)) #'lambda)))
+         #`(define-syntax #,name 
+             (let ((certifier (syntax-local-certifier)))
+               (make-lex-trans (lambda (stx)
+                                 (certifier (#,body stx) 'a)))))))
+      (_
+       (raise-syntax-error
+        #f
+        "form should be (define-lex-trans name transformer)"
+        stx))))
+       
+
+  (define (get-next-state-helper char min max table)
+    (if (>= min max)
+        #f
+        (let* ((try (quotient (+ min max) 2))
+               (el (vector-ref table try))
+               (r1 (vector-ref el 0))
+               (r2 (vector-ref el 1)))
+          (cond
+            ((and (>= char r1) (<= char r2)) (vector-ref el 2))
+            ((< char r1) (get-next-state-helper char min try table))
+            (else (get-next-state-helper char (add1 try) max table))))))
+               
+          
+          
+  
+  (define (get-next-state char table)
+    (if table
+        (get-next-state-helper char 0 (vector-length table) table)
+        #f))
+  
+  (define (lexer-body start-state trans-table actions no-lookahead special-action
+                      has-special-comment-action? special-comment-action eof-action)
+    (letrec ((lexer
+              (lambda (ip)
+                (let ((first-pos (get-position ip))
+                      (first-char (peek-char-or-special ip 0)))
+                  ;(printf "(peek-char-or-special port 0) = ~e~n" first-char)
+                  (cond
+                    ((eof-object? first-char)
+                     (do-match ip first-pos eof-action (read-char-or-special ip)))
+                    ((special-comment? first-char)
+                     (read-char-or-special ip)
+                     (cond
+                       (has-special-comment-action?
+                        (do-match ip first-pos special-comment-action #f))
+                       (else (lexer ip))))
+                    ((not (char? first-char))
+                     (do-match ip first-pos special-action (read-char-or-special ip)))
+                    (else
+                     (let lexer-loop (
+                                      ;; current-state
+                                      (state start-state)
+                                      ;; the character to transition on
+                                      (char first-char)
+                                      ;; action for the longest match seen thus far
+                                      ;; including a match at the current state
+                                      (longest-match-action 
+                                       (vector-ref actions start-state))
+                                      ;; how many bytes preceed char
+                                      (length-bytes 0)
+                                      ;; how many characters have been read
+                                      ;; including the one just read
+                                      (length-chars 1)
+                                      ;; how many characters are in the longest match
+                                      (longest-match-length 0))
+                       (let ((next-state 
+                              (cond
+                                ((not (char? char)) #f)
+                                (else (get-next-state (char->integer char)
+                                                      (vector-ref trans-table state))))))
+                         (cond
+                           ((not next-state)
+                            (check-match ip first-pos longest-match-length
+                                         length-chars longest-match-action))
+                           ((vector-ref no-lookahead next-state)
+                            (let ((act (vector-ref actions next-state)))
+                              (check-match ip 
+                                           first-pos 
+                                           (if act length-chars longest-match-length)
+                                           length-chars
+                                           (if act act longest-match-action))))
+                           (else
+                            (let* ((act (vector-ref actions next-state))
+                                   (next-length-bytes (+ (char-utf-8-length char) length-bytes))
+                                   (next-char (peek-char-or-special ip next-length-bytes)))
+                              #;(printf "(peek-char-or-special port ~e) = ~e~n"
+                                      next-length-bytes next-char)
+                              (lexer-loop next-state 
+                                          next-char
+                                          (if act
+                                              act
+                                              longest-match-action)
+                                          next-length-bytes
+                                          (add1 length-chars)
+                                          (if act
+                                              length-chars
+                                              longest-match-length)))))))))))))
+      (lambda (ip)
+        (unless (input-port? ip)
+          (raise-type-error 
+           'lexer 
+           "input-port"
+           0
+           ip))
+        (lexer ip))))
+      
+  (define (check-match lb first-pos longest-match-length length longest-match-action)
+    (unless longest-match-action
+      (let* ((match (read-string length lb))
+	     (end-pos (get-position lb)))
+	(raise-read-error
+	 (format "lexer: No match found in input starting with: ~a" match)
+	 (file-path)
+	 (position-line first-pos)
+	 (position-col first-pos)
+	 (position-offset first-pos)
+	 (- (position-offset end-pos) (position-offset first-pos)))))
+    (let ((match (read-string longest-match-length lb)))
+      ;(printf "(read-string ~e port) = ~e~n" longest-match-length match)
+      (do-match lb first-pos longest-match-action match)))
+      
+  (define file-path (make-parameter #f))
+                   
+  (define (do-match ip first-pos action value)
+    #;(printf "(action ~a ~a ~a ~a)~n" 
+            (position-offset first-pos) (position-offset (get-position ip)) value ip)
+    (action first-pos (get-position ip) value ip))
+  
+  (define (get-position ip)
+    (let-values (((line col off) (port-next-location ip)))
+      (make-position off line col)))
+
+  (define-syntax (create-unicode-abbrevs stx)
+    (syntax-case stx ()
+      ((_ ctxt)
+       (with-syntax (((ranges ...) (map (lambda (range)
+                                          `(union ,@(map (lambda (x)
+                                                           `(char-range ,(integer->char (car x))
+                                                                        ,(integer->char (cdr x))))
+                                                         range)))
+                                        (list (force alphabetic-ranges)
+                                              (force lower-case-ranges)
+                                              (force upper-case-ranges)
+                                              (force title-case-ranges)
+                                              (force numeric-ranges)
+                                              (force symbolic-ranges)
+                                              (force punctuation-ranges)
+                                              (force graphic-ranges)
+                                              (force whitespace-ranges)
+                                              (force blank-ranges)
+                                              (force iso-control-ranges))))
+                     ((names ...) (map (lambda (sym)
+                                         (datum->syntax-object (syntax ctxt) sym #f))
+                                       '(alphabetic
+                                         lower-case
+                                         upper-case
+                                         title-case
+                                         numeric
+                                         symbolic
+                                         punctuation
+                                         graphic
+                                         whitespace
+                                         blank
+                                         iso-control))))
+         (syntax (define-lex-abbrevs (names ranges) ...))))))
+                                             
+  (define-lex-abbrev any-char (char-complement (union)))
+  (define-lex-abbrev any-string (intersection))
+  (define-lex-abbrev nothing (union))
+  (create-unicode-abbrevs #'here)
+  
+  (define-lex-trans (char-set stx)
+                    (syntax-case stx ()
+                      ((_ str)
+       (string? (syntax-e (syntax str)))
+       (with-syntax (((char ...) (string->list (syntax-e (syntax str)))))
+         (syntax (union char ...))))))
+
+  (define-syntax provide-lex-keyword
+    (syntax-rules ()
+      [(_ id ...)
+       (begin
+	 (define-syntax-parameter id
+           (make-set!-transformer
+            (lambda (stx)
+              (raise-syntax-error
+               #f
+               (format "use of a lexer keyword (~a) is not in an appropriate lexer action"
+                       'id)
+               stx))))
+	 ...
+	 (provide id ...))]))
+  
+  (provide-lex-keyword start-pos end-pos lexeme input-port return-without-pos)
+
+)
diff --git a/collects/parser-tools/private-lex/actions.ss b/collects/parser-tools/private-lex/actions.ss
new file mode 100644
index 0000000000..172e8dc1b0
--- /dev/null
+++ b/collects/parser-tools/private-lex/actions.ss
@@ -0,0 +1,19 @@
+(module actions mzscheme
+  (provide (all-defined))
+  (require (lib "stx.ss" "syntax"))
+    
+  ;; get-special-action: (syntax-object list) syntax-object syntax-object  -> syntax-object
+  ;; Returns the first action from a rule of the form ((which-special) action)
+  (define (get-special-action rules which-special none)
+    (cond
+      ((null? rules) none)
+      (else
+       (syntax-case (car rules) ()
+         (((special) act)
+          (module-or-top-identifier=? (syntax special) which-special)
+          (syntax act))
+         (_ (get-special-action (cdr rules) which-special none))))))
+  
+
+  
+  )
diff --git a/collects/parser-tools/private-lex/deriv.ss b/collects/parser-tools/private-lex/deriv.ss
new file mode 100644
index 0000000000..27469d6075
--- /dev/null
+++ b/collects/parser-tools/private-lex/deriv.ss
@@ -0,0 +1,339 @@
+(module deriv mzscheme
+  
+  (require (lib "list.ss")
+           (prefix is: (lib "integer-set.ss"))
+           "re.ss"
+           "util.ss")
+
+  (provide build-dfa print-dfa (struct dfa (num-states start-state final-states/actions transitions)))
+
+  (define e (build-epsilon))
+  (define z (build-zero))
+  
+  
+  ;; Don't do anything with this one but extract the chars
+  (define all-chars (->re `(char-complement (union)) (make-cache)))
+  
+  ;; get-char-groups : re bool -> (list-of char-setR?)
+  ;; Collects the char-setRs in r that could be used in
+  ;; taking the derivative of r.
+  (define (get-char-groups r found-negation)
+    (cond
+      ((or (eq? r e) (eq? r z)) null)
+      ((char-setR? r) (list r))
+      ((concatR? r)
+       (if (re-nullable? (concatR-re1 r))
+           (append (get-char-groups (concatR-re1 r) found-negation)
+                   (get-char-groups (concatR-re2 r) found-negation))
+           (get-char-groups (concatR-re1 r) found-negation)))
+      ((repeatR? r)
+       (get-char-groups (repeatR-re r) found-negation))
+      ((orR? r)
+       (apply append (map (lambda (x) (get-char-groups x found-negation)) (orR-res r))))
+      ((andR? r)
+       (apply append (map (lambda (x) (get-char-groups x found-negation)) (andR-res r))))
+      ((negR? r)
+       (if found-negation
+           (get-char-groups (negR-re r) #t)
+           (cons all-chars (get-char-groups (negR-re r) #t))))))
+
+  (test-block ((c (make-cache))
+               (r1 (->re #\1 c))
+               (r2 (->re #\2 c)))
+              ((get-char-groups e #f) null)
+              ((get-char-groups z #f) null)
+              ((get-char-groups r1 #f) (list r1))
+              ((get-char-groups (->re `(concatenation ,r1 ,r2) c) #f)
+               (list r1))
+              ((get-char-groups (->re `(concatenation ,e ,r2) c) #f) 
+               (list r2))
+              ((get-char-groups (->re `(concatenation (repeat 0 +inf.0 ,r1) ,r2) c) #f) 
+               (list r1 r2))
+              ((get-char-groups (->re `(repeat 0 +inf.0 ,r1) c) #f) 
+               (list r1))
+              ((get-char-groups
+                (->re `(union (repeat 0 +inf.0 ,r1) 
+                              (concatenation (repeat 0 +inf.0 ,r2) "3") "4") c) #f)
+               (list r1 r2 (->re "3" c) (->re "4" c)))
+              ((get-char-groups (->re `(complement ,r1) c) #f) 
+               (list all-chars r1))
+              ((get-char-groups 
+                (->re `(intersection (repeat 0 +inf.0 ,r1)
+                                     (concatenation (repeat 0 +inf.0 ,r2) "3") "4") c) #f)
+               (list r1 r2 (->re "3" c) (->re "4" c)))
+              )
+  (define loc:member? is:member?)
+  
+  ;; deriveR : re char cache -> re
+  (define (deriveR r c cache)
+    (cond
+      ((or (eq? r e) (eq? r z)) z)
+      ((char-setR? r)
+       (if (loc:member? c (char-setR-chars r)) e z))
+      ((concatR? r)
+       (let* ((r1 (concatR-re1 r))
+              (r2 (concatR-re2 r))
+              (d (build-concat (deriveR r1 c cache) r2 cache)))
+         (if (re-nullable? r1)
+             (build-or (list d (deriveR r2 c cache)) cache)
+             d)))
+      ((repeatR? r)
+       (build-concat (deriveR (repeatR-re r) c cache)
+                     (build-repeat (sub1 (repeatR-low r))
+                                   (sub1 (repeatR-high r))
+                                   (repeatR-re r) cache)
+                     cache))
+      ((orR? r)
+       (build-or (map (lambda (x) (deriveR x c cache))
+                      (orR-res r))
+                 cache))
+      ((andR? r)
+       (build-and (map (lambda (x) (deriveR x c cache))
+                       (andR-res r))
+                  cache))
+      ((negR? r)
+       (build-neg (deriveR (negR-re r) c cache) cache))))
+
+  (test-block ((c (make-cache))
+               (a (char->integer #\a))
+               (b (char->integer #\b))
+               (r1 (->re #\a c))
+               (r2 (->re `(repeat 0 +inf.0 #\a) c))
+               (r3 (->re `(repeat 0 +inf.0 ,r2) c))
+               (r4 (->re `(concatenation #\a ,r2) c))
+               (r5 (->re `(repeat 0 +inf.0 ,r4) c))
+               (r6 (->re `(union ,r5 #\a) c))
+               (r7 (->re `(concatenation ,r2 ,r2) c))
+               (r8 (->re `(complement ,r4) c))
+               (r9 (->re `(intersection ,r2 ,r4) c)))
+              ((deriveR e a c) z)
+              ((deriveR z a c) z)
+              ((deriveR r1 b c) z)
+              ((deriveR r1 a c) e)
+              ((deriveR r2 a c) r2)
+              ((deriveR r2 b c) z)
+              ((deriveR r3 a c) r2)
+              ((deriveR r3 b c) z)
+              ((deriveR r4 a c) r2)
+              ((deriveR r4 b c) z)
+              ((deriveR r5 a c) (->re `(concatenation ,r2 ,r5) c))
+              ((deriveR r5 b c) z)
+              ((deriveR r6 a c) (->re `(union (concatenation ,r2 ,r5) "") c))
+              ((deriveR r6 b c) z)
+              ((deriveR r7 a c) (->re `(union (concatenation ,r2 ,r2) ,r2) c))
+              ((deriveR r7 b c) z)
+              ((deriveR r8 a c) (->re `(complement, r2) c))
+              ((deriveR r8 b c) (->re `(complement ,z) c))
+              ((deriveR r9 a c) r2)
+              ((deriveR r9 b c) z)
+              ((deriveR (->re `(repeat 1 2 "ab") c) a c)
+               (->re `(concatenation "b" (repeat 0 1 "ab")) c)))
+  
+  ;; An re-action is (cons re action)
+
+  ;; derive : (list-of re-action) char cache -> (union (list-of re-action) #f)
+  ;; applies deriveR to all the re-actions's re parts.
+  ;; Returns #f if the derived state is equivalent to z.
+  (define (derive r c cache)
+    (let ((new-r (map (lambda (ra)
+                        (cons (deriveR (car ra) c cache) (cdr ra)))
+                      r)))
+      (if (andmap (lambda (x) (eq? z (car x)))
+                  new-r)
+          #f
+          new-r)))
+
+  (test-block ((c (make-cache))
+               (r1 (->re #\1 c))
+               (r2 (->re #\2 c)))
+              ((derive null (char->integer #\1) c) #f)
+              ((derive (list (cons r1 1) (cons r2 2)) (char->integer #\1) c)
+               (list (cons e 1) (cons z 2)))
+              ((derive (list (cons r1 1) (cons r2 2)) (char->integer #\3) c) #f))
+  
+
+  ;; get-final : (list-of re-action) -> (union #f syntax-object)
+  ;; An re that accepts e represents a final state.  Return the
+  ;; action from the first final state or #f if there is none.
+  (define (get-final res)
+    (cond
+      ((null? res) #f)
+      ((re-nullable? (caar res)) (cdar res))
+      (else (get-final (cdr res)))))
+
+  (test-block ((c->i char->integer)
+               (c (make-cache))
+               (r1 (->re #\a c))
+               (r2 (->re #\b c))
+               (b (list (cons z 1) (cons z 2) (cons z 3) (cons e 4) (cons z 5)))
+               (a (list (cons r1 1) (cons r2 2))))
+              ((derive null (c->i #\a) c) #f)
+              ((derive a (c->i #\a) c) (list (cons e 1) (cons z 2)))
+              ((derive a (c->i #\b) c) (list (cons z 1) (cons e 2)))
+              ((derive a (c->i #\c) c) #f)
+              ((derive (list (cons (->re `(union " " "\n" ",") c) 1)
+                             (cons (->re `(concatenation (repeat 0 1 "-")
+                                                         (repeat 1 +inf.0 (char-range "0" "9"))) c) 2)
+                             (cons (->re `(concatenation "-" (repeat 1 +inf.0 "-")) c) 3)
+                             (cons (->re "[" c) 4)
+                             (cons (->re "]" c) 5)) (c->i #\[) c)
+               b)
+              ((get-final a) #f)
+              ((get-final (list (cons e 1) (cons e 2))) 1)
+              ((get-final b) 4))
+  
+  
+  ;; A state is (make-state (list-of re-action) nat)
+  (define-struct state (spec index))
+        
+  ;; get->key : re-action -> (list-of nat)
+  ;; states are indexed by the list of indexes of their res
+  (define (get-key s)
+    (map (lambda (x) (re-index (car x))) s))  
+          
+  (define loc:partition is:partition)
+  
+  ;; compute-chars : (list-of state) -> (list-of char-set)
+  ;; Computed the sets of equivalent characters for taking the
+  ;; derivative of the car of st.  Only one derivative per set need to be taken.
+  (define (compute-chars st)
+    (cond
+      ((null? st) null)
+      (else
+       (loc:partition (map char-setR-chars
+                          (apply append (map (lambda (x) (get-char-groups (car x) #f))
+                                             (state-spec (car st)))))))))
+  
+  (test-block ((c (make-cache))
+               (c->i char->integer)
+               (r1 (->re `(char-range #\1 #\4) c))
+               (r2 (->re `(char-range #\2 #\3) c)))
+              ((compute-chars null) null)
+              ((compute-chars (list (make-state null 1))) null)
+              ((map is:integer-set-contents
+                    (compute-chars (list (make-state (list (cons r1 1) (cons r2 2)) 2))))
+               (list (is:integer-set-contents (is:make-range (c->i #\2) (c->i #\3)))
+                     (is:integer-set-contents (is:union (is:make-range (c->i #\1))
+                                                        (is:make-range (c->i #\4)))))))
+  
+  
+  ;; A dfa is (make-dfa int int
+  ;;                    (list-of (cons int syntax-object))
+  ;;                    (list-of (cons int (list-of (cons char-set int)))))
+  ;; Each transitions is a state and a list of chars with the state to transition to.
+  ;; The finals and transitions are sorted by state number, and duplicate free.
+  (define-struct dfa (num-states start-state final-states/actions transitions) (make-inspector))
+  
+  (define loc:get-integer is:get-integer)
+  
+  ;; build-dfa : (list-of re-action) cache -> dfa
+  (define (build-dfa rs cache)
+    (let* ((transitions (make-hash-table))
+           (get-state-number (make-counter))
+           (start (make-state rs (get-state-number))))
+      (cache (cons 'state (get-key rs)) (lambda () start))
+      (let loop ((old-states (list start))
+                 (new-states null)
+		 (all-states (list start))
+                 (cs (compute-chars (list start))))
+        (cond
+          ((and (null? old-states) (null? new-states))
+           (make-dfa (get-state-number) (state-index start)
+                     (mergesort (filter (lambda (x) (cdr x))
+                                        (map (lambda (state)
+					       (cons (state-index state) (get-final (state-spec state))))
+					     all-states))
+                                (lambda (a b) (< (car a) (car b))))
+                     (mergesort (hash-table-map transitions
+                                                (lambda (state trans)
+                                                  (cons (state-index state)
+                                                        (map (lambda (t)
+                                                               (cons (car t)
+                                                                     (state-index (cdr t))))
+                                                             trans))))
+                                (lambda (a b) (< (car a) (car b))))))
+          ((null? old-states)
+           (loop new-states null all-states (compute-chars new-states)))
+          ((null? cs)
+           (loop (cdr old-states) new-states all-states (compute-chars (cdr old-states))))
+          (else
+           (let* ((state (car old-states))
+                  (c (car cs))
+                  (new-re (derive (state-spec state) (loc:get-integer c) cache)))
+             (cond
+               (new-re
+                (let* ((new-state? #f)
+                       (new-state (cache (cons 'state (get-key new-re))
+                                         (lambda ()
+                                           (set! new-state? #t)
+                                           (make-state new-re (get-state-number)))))
+		       (new-all-states (if new-state? (cons new-state all-states) all-states)))
+                  (hash-table-put! transitions 
+                                   state
+                                   (cons (cons c new-state)
+                                         (hash-table-get transitions state
+                                                         (lambda () null))))
+                  (cond
+                    (new-state?
+                     (loop old-states (cons new-state new-states) new-all-states (cdr cs)))
+                    (else
+                     (loop old-states new-states new-all-states (cdr cs))))))
+               (else (loop old-states new-states all-states (cdr cs))))))))))
+  
+  (define (print-dfa x)
+    (printf "number of states: ~a~n" (dfa-num-states x))
+    (printf "start state: ~a~n" (dfa-start-state x))
+    (printf "final states: ~a~n" (map car (dfa-final-states/actions x)))
+    (for-each (lambda (trans)
+                (printf "state: ~a~n" (car trans))
+                (for-each (lambda (rule)
+                            (printf "  -~a-> ~a~n"
+                                    (is:integer-set-contents (car rule))
+                                    (cdr rule)))
+                          (cdr trans)))
+              (dfa-transitions x)))
+ 
+  (define (build-test-dfa rs)
+    (let ((c (make-cache)))
+      (build-dfa (map (lambda (x) (cons (->re x c) 'action))
+                      rs)
+                 c)))
+
+  
+#|
+  (define t1 (build-test-dfa null))
+  (define t2 (build-test-dfa `(#\a)))
+  (define t3 (build-test-dfa `(#\a #\b)))
+  (define t4 (build-test-dfa `((repeat 0 +inf.0 #\a)
+                               (repeat 0 +inf.0 (concatenation #\a #\b)))))
+  (define t5 (build-test-dfa `((concatenation (repeat 0 +inf.0 (union #\0 #\1)) #\1))))
+  (define t6 (build-test-dfa `((repeat 0 +inf.0 (repeat 0 +inf.0 #\a))
+                               (repeat 0 +inf.0 (concatenation #\b (repeat 1 +inf.0 #\b))))))
+  (define t7 (build-test-dfa `((concatenation (repeat 0 +inf.0 #\a) (repeat 0 +inf.0 #\b)
+                                              (repeat 0 +inf.0 #\c) (repeat 0 +inf.0 #\d)
+                                              (repeat 0 +inf.0 #\e)))))
+  (define t8
+    (build-test-dfa `((concatenation (repeat 0 +inf.0 (union #\a #\b)) #\a (union #\a #\b)
+                                     (union #\a #\b) (union #\a #\b) (union #\a #\b)))))
+  (define t9 (build-test-dfa `((concatenation "/*"
+                                  (complement (concatenation (intersection) "*/" (intersection)))
+                                  "*/"))))
+  (define t11 (build-test-dfa `((complement "1"))))
+  (define t12 (build-test-dfa `((concatenation (intersection (concatenation (repeat 0 +inf.0 "a") "b")
+                                                             (concatenation "a" (repeat 0 +inf.0 "b")))
+                                               "ab"))))
+  (define x (build-test-dfa `((union " " "\n" ",")
+                              (concatenation (repeat 0 1 "-") (repeat 1 +inf.0 (char-range "0" "9")))
+                              (concatenation "-" (repeat 1 +inf.0 "-"))
+                              "["
+                              "]")))
+  (define y (build-test-dfa
+             `((repeat 1 +inf.0
+                       (union (concatenation "|" (repeat 0 +inf.0 (char-complement "|")) "|")
+                              (concatenation "|" (repeat 0 +inf.0 (char-complement "|"))))))))
+  (define t13 (build-test-dfa `((intersection (concatenation (intersection) "111" (intersection))
+                                              (complement (union (concatenation (intersection) "01")
+                                       (repeat 1 +inf.0 "1")))))))
+  (define t14 (build-test-dfa `((complement "1"))))
+|#
+  )
\ No newline at end of file
diff --git a/collects/parser-tools/private-lex/error-tests.ss b/collects/parser-tools/private-lex/error-tests.ss
new file mode 100644
index 0000000000..6f27da3a3f
--- /dev/null
+++ b/collects/parser-tools/private-lex/error-tests.ss
@@ -0,0 +1,35 @@
+(define-lex-abbrev)
+(define-lex-abbrev a)
+(define-lex-abbrev (a b) v)
+(define-lex-abbrev 1 1)
+(define-lex-abbrevs ())
+
+(define-lex-trans)
+(define-lex-trans (1 b) 1)
+
+(lexer)
+(lexer ("a" "b" "c"))
+(lexer ())
+(lexer (""))
+
+(lexer (a 1))
+(lexer ((a) 1))
+(let ((a 1))
+  (lexer ((a) 1)))
+(let-syntax ((a 1))
+  (lexer ((a) 1)))
+(let ()
+  (define-lex-trans a 1)
+  (let ()
+    (lexer ((a) 1))))
+
+(lexer (1 1))
+(lexer ((repetition) 1))
+(lexer ((repetition #\1 #\1 "3") 1))
+(lexer ((repetition 1 #\1 "3") 1))
+(lexer ((repetition 1 0 "3") 1))
+(lexer ((complement) 1))
+(lexer ((char-range) 1))
+(lexer ((char-range #\9 #\0) 1))
+(lexer ((char-complement) 1))
+(lexer ((char-complement (concatenation "1" "2")) 1))
\ No newline at end of file
diff --git a/collects/parser-tools/private-lex/front.ss b/collects/parser-tools/private-lex/front.ss
new file mode 100644
index 0000000000..4029e92792
--- /dev/null
+++ b/collects/parser-tools/private-lex/front.ss
@@ -0,0 +1,179 @@
+(module front mzscheme
+  (require (prefix is: (lib "integer-set.ss"))
+           (lib "list.ss")
+	   (lib "stx.ss" "syntax")
+           "util.ss"
+           "stx.ss"
+           "re.ss"
+           "deriv.ss")
+  
+  (provide build-lexer)
+  
+  (define-syntax time-label
+    (syntax-rules ()
+      ((_ l e ...)
+       (begin
+         (printf "~a: " l)
+         (time (begin e ...))))))
+  
+  ;; A table is either
+  ;; - (vector-of (union #f nat))
+  ;; - (vector-of (vector-of (vector nat nat nat)))
+  
+  (define loc:integer-set-contents is:integer-set-contents)
+  
+  ;; dfa->1d-table : dfa -> (same as build-lexer)
+ (define (dfa->1d-table dfa)
+   (let ((state-table (make-vector (dfa-num-states dfa) #f))
+         (transition-cache (make-hash-table 'equal)))
+     (for-each
+      (lambda (trans)
+        (let* ((from-state (car trans))
+               (all-chars/to (cdr trans))
+               (flat-all-chars/to
+                (mergesort
+                 (apply append
+                   (map (lambda (chars/to)
+                          (let ((char-ranges (loc:integer-set-contents (car chars/to)))
+                                (to (cdr chars/to)))
+                            (map (lambda (char-range)
+                                   (let ((entry (vector (car char-range) (cdr char-range) to)))
+                                     (hash-table-get transition-cache entry
+                                                     (lambda ()
+                                                       (hash-table-put! transition-cache
+                                                                        entry
+                                                                        entry)
+                                                       entry))))
+                                 char-ranges)))
+                        all-chars/to))
+                 (lambda (a b)
+                   (< (vector-ref a 0) (vector-ref b 0))))))
+          (vector-set! state-table from-state (list->vector flat-all-chars/to))))
+      (dfa-transitions dfa))
+     state-table))
+  
+         
+  (define loc:foldr is:foldr)
+  
+  ;; dfa->2d-table : dfa -> (same as build-lexer)
+  (define (dfa->2d-table dfa)
+    (let (
+          ;; char-table : (vector-of (union #f nat))
+          ;; The lexer table, one entry per state per char.
+          ;; Each entry specifies a state to transition to.
+          ;; #f indicates no transition
+          (char-table (make-vector (* 256 (dfa-num-states dfa)) #f)))
+      
+      ;; Fill the char-table vector
+      (for-each 
+       (lambda (trans)
+         (let ((from-state (car trans)))
+           (for-each (lambda (chars/to)
+                       (let ((to-state (cdr chars/to)))
+                         (loc:foldr (lambda (char _)
+                                     (vector-set! char-table
+                                                  (bitwise-ior 
+                                                   char
+                                                   (arithmetic-shift from-state 8))
+                                                  to-state))
+                                   (void)
+                                   (car chars/to))))
+                     (cdr trans))))
+       (dfa-transitions dfa))
+      char-table))
+      
+
+  ;; dfa->actions : dfa -> (vector-of (union #f syntax-object))
+  ;; The action for each final state, #f if the state isn't final
+  (define (dfa->actions dfa)
+    (let ((actions (make-vector (dfa-num-states dfa) #f)))
+      (for-each (lambda (state/action)
+                  (vector-set! actions (car state/action) (cdr state/action)))
+                (dfa-final-states/actions dfa))
+      actions))
+      
+  ;; dfa->no-look : dfa -> (vector-of bool)
+  ;; For each state whether the lexer can ignore the next input.
+  ;; It can do this only if there are no transitions out of the
+  ;; current state.
+  (define (dfa->no-look dfa)
+    (let ((no-look (make-vector (dfa-num-states dfa) #t)))
+      (for-each (lambda (trans)
+                  (vector-set! no-look (car trans) #f))
+                (dfa-transitions dfa))
+      no-look))
+      
+  (test-block ((d1 (make-dfa 1 1 (list) (list)))
+               (d2 (make-dfa 4 1 (list (cons 2 2) (cons 3 3))
+                             (list (cons 1 (list (cons (is:make-range 49 50) 1)
+                                                 (cons (is:make-range 51) 2)))
+                                   (cons 2 (list (cons (is:make-range 49) 3))))))
+               (d3 (make-dfa 4 1 (list (cons 2 2) (cons 3 3))
+                             (list (cons 1 (list (cons (is:make-range 100 200) 0)
+                                                 (cons (is:make-range 49 50) 1)
+                                                 (cons (is:make-range 51) 2)))
+                                   (cons 2 (list (cons (is:make-range 49) 3)))))))
+              ((dfa->2d-table d1) (make-vector 256 #f))
+              ((dfa->2d-table d2) (let ((v (make-vector 1024 #f)))
+                                    (vector-set! v 305 1)
+                                    (vector-set! v 306 1)
+                                    (vector-set! v 307 2)
+                                    (vector-set! v 561 3)
+                                    v))
+              ((dfa->1d-table d1) (make-vector 1 #f))
+              ((dfa->1d-table d2) #(#f
+                                  #(#(49 50 1) #(51 51 2))
+                                  #(#(49 49 3))
+                                  #f))
+              ((dfa->1d-table d3) #(#f
+                                  #(#(49 50 1) #(51 51 2) #(100 200 0))
+                                  #(#(49 49 3))
+                                  #f))
+              ((dfa->actions d1) (vector #f))
+              ((dfa->actions d2) (vector #f #f 2 3))
+              ((dfa->no-look d1) (vector #t))
+              ((dfa->no-look d2) (vector #t #f #f #t)))
+
+  ;; build-lexer : syntax-object list ->
+  ;;   (values table nat (vector-of (union #f syntax-object)) (vector-of bool) (list-of syntax-object))
+  ;; each syntax object has the form (re action)
+  (define (build-lexer sos)
+    (let* ((disappeared-uses (box null))
+           (s-re-acts (map (lambda (so)
+                             (cons (parse (stx-car so) disappeared-uses)
+				   (stx-car (stx-cdr so))))
+                           sos))
+
+           (cache (make-cache))
+           
+           (re-acts (map (lambda (s-re-act)
+			   (cons (->re (car s-re-act) cache)
+				 (cdr s-re-act)))
+			 s-re-acts))
+           
+           (dfa (build-dfa re-acts cache))
+           (table (dfa->1d-table dfa)))
+      ;(print-dfa dfa)
+      #;(let ((num-states (vector-length table))
+            (num-vectors (length (filter values (vector->list table))))
+            (num-entries (apply + (map
+                                   (lambda (x) (if x (vector-length x) 0))
+                                   (vector->list table))))
+            (num-different-entries
+             (let ((ht (make-hash-table)))
+               (for-each
+                (lambda (x)
+                  (when x
+                    (for-each
+                     (lambda (y)
+                       (hash-table-put! ht y #t))
+                     (vector->list x))))
+                (vector->list table))
+               (length (hash-table-map ht cons)))))
+        (printf "~a states, ~aKB~n"
+                num-states
+                (/ (* 4.0 (+ 2 num-states (* 2 num-vectors) num-entries
+                             (* 5 num-different-entries))) 1024)))
+      (values table (dfa-start-state dfa) (dfa->actions dfa) (dfa->no-look dfa)
+              (unbox disappeared-uses))))
+  )
diff --git a/collects/parser-tools/private-lex/info.ss b/collects/parser-tools/private-lex/info.ss
new file mode 100644
index 0000000000..c724cd35dc
--- /dev/null
+++ b/collects/parser-tools/private-lex/info.ss
@@ -0,0 +1,5 @@
+
+(module info (lib "infotab.ss" "setup")
+  (define compile-omit-files (list "error-tests.ss"))
+  (define name "Parser-tools private-lex"))
+
diff --git a/collects/parser-tools/private-lex/re.ss b/collects/parser-tools/private-lex/re.ss
new file mode 100644
index 0000000000..2da8e3dc51
--- /dev/null
+++ b/collects/parser-tools/private-lex/re.ss
@@ -0,0 +1,385 @@
+(module re mzscheme
+  (require (lib "match.ss")
+           (lib "list.ss")
+           (prefix is: (lib "integer-set.ss"))
+           "util.ss")
+  
+  (provide ->re build-epsilon build-zero build-char-set build-concat
+           build-repeat build-or build-and build-neg
+           epsilonR? zeroR? char-setR? concatR? repeatR? orR? andR? negR?
+           char-setR-chars concatR-re1 concatR-re2 repeatR-re repeatR-low repeatR-high
+           orR-res andR-res negR-re
+           re-nullable? re-index)
+  
+  ;; get-index : -> nat
+  (define get-index (make-counter))
+
+  ;; An re is either
+  ;; - (make-epsilonR bool nat)
+  ;; - (make-zeroR bool nat)
+  ;; - (make-char-setR bool nat char-set)
+  ;; - (make-concatR bool nat re re)
+  ;; - (make-repeatR bool nat nat nat-or-+inf.0 re)
+  ;; - (make-orR bool nat (list-of re))    Must not directly contain any orRs
+  ;; - (make-andR bool nat (list-of re))   Must not directly contain any andRs
+  ;; - (make-negR bool nat re)
+  ;;
+  ;; Every re must have an index field globally different from all
+  ;; other re index fields.
+  (define-struct re (nullable? index) (make-inspector))
+  (define-struct (epsilonR re) () (make-inspector))
+  (define-struct (zeroR re) () (make-inspector))
+  (define-struct (char-setR re) (chars) (make-inspector))
+  (define-struct (concatR re) (re1 re2) (make-inspector))
+  (define-struct (repeatR re) (low high re) (make-inspector))
+  (define-struct (orR re) (res) (make-inspector))
+  (define-struct (andR re) (res) (make-inspector))
+  (define-struct (negR re) (re) (make-inspector))
+
+  ;; e : re
+  ;; The unique epsilon re
+  (define e (make-epsilonR #t (get-index)))
+
+  ;; z : re
+  ;; The unique zero re
+  (define z (make-zeroR #f (get-index)))
+
+
+  ;; s-re = char                       constant
+  ;;      | string                     constant (sequence of characters)
+  ;;      | re                         a precompiled re
+  ;;      | (repetition low high s-re) repetition between low and high times (inclusive)
+  ;;      | (union s-re ...)           
+  ;;      | (intersection s-re ...)    
+  ;;      | (complement s-re)          
+  ;;      | (concatenation s-re ...)   
+  ;;      | (char-range rng rng)       match any character between two (inclusive)
+  ;;      | (char-complement char-set) match any character not listed
+  ;; low = natural-number
+  ;; high = natural-number or +inf.0
+  ;; rng = char or string with length 1
+  ;; (concatenation) (repetition 0 0 x), and "" match the empty string.
+  ;; (union) matches no strings.
+  ;; (intersection) matches any string.
+  
+  (define loc:make-range is:make-range)
+  (define loc:union is:union)
+  (define loc:split is:split)
+  (define loc:complement is:complement)
+  
+  ;; ->re : s-re cache -> re
+  (define (->re exp cache)
+    (match exp
+      ((? char?) (build-char-set (loc:make-range (char->integer exp)) cache))
+      ((? string?) (->re `(concatenation ,@(string->list exp)) cache))
+      ((? re?) exp)
+      (`(repetition ,low ,high ,r)
+        (build-repeat low high (->re r cache) cache))
+      (`(union ,rs ...)
+        (build-or (flatten-res (map (lambda (r) (->re r cache)) rs)
+                               orR? orR-res loc:union cache)
+                  cache))
+      (`(intersection ,rs ...)
+        (build-and (flatten-res (map (lambda (r) (->re r cache)) rs)
+                                andR? andR-res (lambda (a b)
+                                                 (let-values (((i _ __) (loc:split a b))) i))
+                                cache)
+                   cache))
+      (`(complement ,r)
+        (build-neg (->re r cache) cache))
+      (`(concatenation ,rs ...)
+        (foldr (lambda (x y)
+                 (build-concat (->re x cache) y cache))
+               e
+               rs))
+      (`(char-range ,c1 ,c2)
+        (let ((i1 (char->integer (if (string? c1) (string-ref c1 0) c1)))
+              (i2 (char->integer (if (string? c2) (string-ref c2 0) c2))))
+          (if (<= i1 i2)
+              (build-char-set (loc:make-range i1 i2) cache)
+              z)))
+      (`(char-complement ,crs ...)
+        (let ((cs (->re `(union ,@crs) cache)))
+          (cond
+            ((zeroR? cs) (build-char-set (loc:make-range 0 max-char-num) cache))
+            ((char-setR? cs)
+             (build-char-set (loc:complement (char-setR-chars cs) 0 max-char-num) cache))
+            (else z))))))
+              
+
+        
+
+  ;; flatten-res: (list-of re) (re -> bool) (re -> (list-of re))
+  ;;              (char-set char-set -> char-set) cache -> (list-of re)
+  ;; Takes all the char-sets in l and combines them into one char-set using the combine function.
+  ;; Flattens out the values of type?.  get-res only needs to function on things type? returns
+  ;; true for.
+  (define (flatten-res l type? get-res combine cache)
+    (let loop ((res l)
+               ;; chars : (union #f char-set)
+               (chars #f)
+               (no-chars null))
+      (cond
+        ((null? res) 
+         (if chars
+             (cons (build-char-set chars cache) no-chars)
+             no-chars))
+        ((char-setR? (car res))
+         (if chars
+             (loop (cdr res) (combine (char-setR-chars (car res)) chars) no-chars)
+             (loop (cdr res) (char-setR-chars (car res)) no-chars)))
+        ((type? (car res))
+         (loop (append (get-res (car res)) (cdr res)) chars no-chars))
+        (else (loop (cdr res) chars (cons (car res) no-chars))))))
+    
+  ;; build-epsilon : -> re
+  (define (build-epsilon) e)
+  
+  (define (build-zero) z)
+    
+  (define loc:integer-set-contents is:integer-set-contents)
+  
+  ;; build-char-set : char-set cache -> re
+  (define (build-char-set cs cache)
+    (let ((l (loc:integer-set-contents cs)))
+      (cond
+        ((null? l) z)
+        (else
+         (cache l
+                (lambda ()
+                  (make-char-setR #f (get-index) cs)))))))
+  
+  
+  
+  ;; build-concat : re re cache -> re
+  (define (build-concat r1 r2 cache)
+      (cond
+        ((eq? e r1) r2)
+        ((eq? e r2) r1)
+        ((or (eq? z r1) (eq? z r2)) z)
+        (else
+           (cache (cons 'concat (cons (re-index r1) (re-index r2)))
+                  (lambda ()
+                    (make-concatR (and (re-nullable? r1) (re-nullable? r2))
+                                  (get-index)
+                                  r1 r2))))))
+  
+  ;; build-repeat : nat nat-or-+inf.0 re cache -> re
+  (define (build-repeat low high r cache)
+    (let ((low (if (< low 0) 0 low)))
+      (cond
+        ((eq? r e) e)
+        ((and (= 0 low) (or (= 0 high) (eq? z r))) e)
+        ((and (= 1 low) (= 1 high)) r)
+        ((and (repeatR? r)
+              (eq? (repeatR-high r) +inf.0)
+              (or (= 0 (repeatR-low r))
+                  (= 1 (repeatR-low r))))
+         (build-repeat (* low (repeatR-low r))
+                       +inf.0
+                       (repeatR-re r)
+                       cache))
+        (else
+         (cache (cons 'repeat (cons low (cons high (re-index r))))
+                (lambda ()
+                  (make-repeatR (or (re-nullable? r) (= 0 low)) (get-index) low high r)))))))
+  
+  
+  ;; build-or : (list-of re) cache -> re
+  (define (build-or rs cache)
+    (let ((rs 
+           (filter
+            (lambda (x) (not (eq? x z)))
+            (do-simple-equiv (replace rs orR? orR-res null) re-index))))
+      (cond
+        ((null? rs) z)
+        ((null? (cdr rs)) (car rs))
+        ((memq (build-neg z cache) rs) (build-neg z cache))
+        (else
+         (cache (cons 'or (map re-index rs))
+                (lambda ()
+                  (make-orR (ormap re-nullable? rs) (get-index) rs)))))))
+  
+  ;; build-and : (list-of re) cache -> re
+  (define (build-and rs cache)
+    (let ((rs (do-simple-equiv (replace rs andR? andR-res null) re-index)))
+      (cond
+        ((null? rs) (build-neg z cache))
+        ((null? (cdr rs)) (car rs))
+        ((memq z rs) z)
+        (else
+         (cache (cons 'and (map re-index rs))
+                (lambda ()
+                  (make-andR (andmap re-nullable? rs) (get-index) rs)))))))
+      
+  ;; build-neg : re cache -> re
+  (define (build-neg r cache)
+    (cond
+      ((negR? r) (negR-re r))
+      (else
+       (cache (cons 'neg (re-index r))
+              (lambda ()
+                (make-negR (not (re-nullable? r)) (get-index) r))))))
+  
+  ;; Tests for the build-functions
+  (test-block ((c (make-cache))
+               (isc is:integer-set-contents)
+               (r1 (build-char-set (is:make-range (char->integer #\1)) c))
+               (r2 (build-char-set (is:make-range (char->integer #\2)) c))
+               (r3 (build-char-set (is:make-range (char->integer #\3)) c))
+               (rc (build-concat r1 r2 c))
+               (rc2 (build-concat r2 r1 c))
+               (rr (build-repeat 0 +inf.0 rc c))
+               (ro (build-or `(,rr ,rc ,rr) c))
+               (ro2 (build-or `(,rc ,rr ,z) c))
+               (ro3 (build-or `(,rr ,rc) c))
+               (ro4 (build-or `(,(build-or `(,r1 ,r2) c)
+                                 ,(build-or `(,r2 ,r3) c)) c))
+               (ra (build-and `(,rr ,rc ,rr) c))
+               (ra2 (build-and `(,rc ,rr) c))
+               (ra3 (build-and `(,rr ,rc) c))
+               (ra4 (build-and `(,(build-and `(,r3 ,r2) c)
+                                  ,(build-and `(,r2 ,r1) c)) c))
+               (rn (build-neg z c))
+               (rn2 (build-neg r1 c)))
+               
+              ((isc (char-setR-chars r1)) (isc (is:make-range (char->integer #\1))))
+              ((isc (char-setR-chars r2)) (isc (is:make-range (char->integer #\2))))
+              ((isc (char-setR-chars r3)) (isc (is:make-range (char->integer #\3))))
+              ((build-char-set (is:make-range) c) z)
+              ((build-concat r1 e c) r1)
+              ((build-concat e r1 c) r1)
+              ((build-concat r1 z c) z)
+              ((build-concat z r1 c) z)
+              ((build-concat r1 r2 c) rc)
+              ((concatR-re1 rc) r1)
+              ((concatR-re2 rc) r2)
+              ((concatR-re1 rc2) r2)
+              ((concatR-re2 rc2) r1)
+              (ro ro2)
+              (ro ro3)
+              (ro4 (build-or `(,r1 ,r2 ,r3) c))
+              ((orR-res ro) (list rc rr))
+              ((orR-res ro4) (list r1 r2 r3))
+              ((build-or null c) z)
+              ((build-or `(,r1 ,z) c) r1)
+              ((build-repeat 0 +inf.0 rc c) rr)
+              ((build-repeat 0 1 z c) e)
+              ((build-repeat 0 0 rc c) e)
+              ((build-repeat 0 +inf.0 z c) e)
+              ((build-repeat -1 +inf.0 z c) e)
+              ((build-repeat 0 +inf.0 (build-repeat 0 +inf.0 rc c) c)
+               (build-repeat 0 +inf.0 rc c))
+              ((build-repeat 20 20 (build-repeat 0 +inf.0 rc c) c)
+               (build-repeat 0 +inf.0 rc c))
+              ((build-repeat 20 20 (build-repeat 1 +inf.0 rc c) c)
+               (build-repeat 20 +inf.0 rc c))
+              ((build-repeat 1 1 rc c) rc)
+              ((repeatR-re rr) rc)
+              (ra ra2)
+              (ra ra3)
+              (ra4 (build-and `(,r1 ,r2 ,r3) c))
+              ((andR-res ra) (list rc rr))
+              ((andR-res ra4) (list r1 r2 r3))
+              ((build-and null c) (build-neg z c))
+              ((build-and `(,r1 ,z) c) z)
+              ((build-and `(,r1) c) r1)
+              ((build-neg r1 c) (build-neg r1 c))
+              ((build-neg (build-neg r1 c) c) r1)
+              ((negR-re (build-neg r2 c)) r2)
+              ((re-nullable? r1) #f)
+              ((re-nullable? rc) #f)
+              ((re-nullable? (build-concat rr rr c)) #t)
+              ((re-nullable? rr) #t)
+              ((re-nullable? (build-repeat 0 1 rc c)) #t)
+              ((re-nullable? (build-repeat 1 2 rc c)) #f)
+              ((re-nullable? (build-repeat 1 2 (build-or (list e r1) c) c)) #t)
+              ((re-nullable? ro) #t)
+              ((re-nullable? (build-or `(,r1 ,r2) c)) #f)
+              ((re-nullable? (build-and `(,r1 ,e) c)) #f)
+              ((re-nullable? (build-and `(,rr ,e) c)) #t)
+              ((re-nullable? (build-neg r1 c)) #t)
+              ((re-nullable? (build-neg rr c)) #f))
+              
+  (test-block ((c (make-cache))
+               (isc is:integer-set-contents)
+               (r1 (->re #\1 c))
+               (r2 (->re #\2 c))
+               (r3-5 (->re '(char-range #\3 #\5) c))
+               (r4 (build-or `(,r1 ,r2) c))
+               (r5 (->re `(union ,r3-5 #\7) c))
+               (r6 (->re #\6 c)))
+              ((flatten-res null orR? orR-res is:union c) null)
+              ((isc (char-setR-chars (car (flatten-res `(,r1) orR? orR-res is:union c))))
+               (isc (is:make-range (char->integer #\1))))
+              ((isc (char-setR-chars (car (flatten-res `(,r4) orR? orR-res is:union c))))
+               (isc (is:make-range (char->integer #\1) (char->integer #\2))))
+              ((isc (char-setR-chars (car (flatten-res `(,r6 ,r5 ,r4 ,r3-5 ,r2 ,r1)
+                                                       orR? orR-res is:union c))))
+               (isc (is:make-range (char->integer #\1) (char->integer #\7))))
+              ((flatten-res `(,r1 ,r2) andR? andR-res (lambda (x y)
+                                                        (let-values (((i _ __)
+                                                                      (is:split x y)))
+                                                          i))
+                            c)
+               (list z)))
+  
+  ;; ->re
+  (test-block ((c (make-cache))
+               (isc is:integer-set-contents)
+               (r (->re #\a c))
+               (rr (->re `(concatenation ,r ,r) c))
+               (rrr (->re `(concatenation ,r ,rr) c))
+               (rrr* (->re `(repetition 0 +inf.0 ,rrr) c)))
+              ((isc (char-setR-chars r)) (isc (is:make-range (char->integer #\a))))
+              ((->re "" c) e)
+              ((->re "asdf" c) (->re `(concatenation #\a #\s #\d #\f) c))
+              ((->re r c) r)
+              ((->re `(repetition 0 +inf.0 ,r) c) (build-repeat 0 +inf.0 r c))
+              ((->re `(repetition 1 +inf.0 ,r) c) (build-repeat 1 +inf.0 r c))
+              ((->re `(repetition 0 1 ,r) c) (build-repeat 0 1 r c))
+              ((->re `(repetition 0 1 ,rrr*) c) rrr*)
+              ((->re `(union (union (char-range #\a #\c)
+                                    (char-complement (char-range #\000 #\110)
+                                                     (char-range #\112 ,(integer->char max-char-num))))
+                         (union (repetition 0 +inf.0 #\2))) c)
+               (build-or (list (build-char-set (is:union (is:make-range 73)
+                                                         (is:make-range 97 99))
+                                               c)
+                               (build-repeat 0 +inf.0 (build-char-set (is:make-range 50) c) c))
+                         c))
+              ((->re `(union ,rr ,rrr) c) (build-or (list rr rrr) c))
+              ((->re `(union ,r) c) r)
+              ((->re `(union) c) z)
+              ((->re `(intersection (intersection #\111 
+                                                  (char-complement (char-range #\000 #\110)
+                                                                   (char-range #\112 ,(integer->char max-char-num))))
+                         (intersection (repetition 0 +inf.0 #\2))) c)
+               (build-and (list (build-char-set (is:make-range 73) c)
+                                (build-repeat 0 +inf.0 (build-char-set (is:make-range 50) c) c))
+                          c))
+              ((->re `(intersection (intersection #\000 (char-complement (char-range #\000 #\110)
+                                                                         (char-range #\112 ,(integer->char max-char-num))))
+                                    (intersection (repetition 0 +inf.0 #\2))) c)
+               z)
+              ((->re `(intersection ,rr ,rrr) c) (build-and (list rr rrr) c))
+              ((->re `(intersection ,r) c) r)
+              ((->re `(intersection) c) (build-neg z c))
+              ((->re `(complement ,r) c) (build-neg r c))
+              ((->re `(concatenation) c) e)
+              ((->re `(concatenation ,rrr*) c) rrr*)
+              (rr (build-concat r r c))
+              ((->re `(concatenation ,r ,rr ,rrr) c)
+               (build-concat r (build-concat rr rrr c) c))
+              ((isc (char-setR-chars (->re `(char-range #\1 #\1) c))) (isc (is:make-range 49)))
+              ((isc (char-setR-chars (->re `(char-range #\1 #\9) c))) (isc (is:make-range 49 57)))
+              ((isc (char-setR-chars (->re `(char-range "1" "1") c))) (isc (is:make-range 49)))
+              ((isc (char-setR-chars (->re `(char-range "1" "9") c))) (isc (is:make-range 49 57)))
+              ((->re `(char-range "9" "1") c) z)
+              ((isc (char-setR-chars (->re `(char-complement) c)))
+               (isc (char-setR-chars (->re `(char-range #\000 ,(integer->char max-char-num)) c))))
+              ((isc (char-setR-chars (->re `(char-complement #\001 (char-range #\002 ,(integer->char max-char-num))) c)))
+               (isc (is:make-range 0)))
+              )
+  
+  )
diff --git a/collects/parser-tools/private-lex/stx.ss b/collects/parser-tools/private-lex/stx.ss
new file mode 100644
index 0000000000..e89480181e
--- /dev/null
+++ b/collects/parser-tools/private-lex/stx.ss
@@ -0,0 +1,193 @@
+(module stx mzscheme
+  (require (lib "boundmap.ss" "syntax")
+           "util.ss")
+  
+  (provide parse)
+
+  (define (bad-args stx num)
+    (raise-syntax-error
+     #f
+     (format "incorrect number of arguments (should have ~a)" num)
+     stx))
+  
+  ;; char-range-arg: syntax-object syntax-object -> nat
+  ;; If c contains is a character or length 1 string, returns the integer
+  ;; for the character.  Otherwise raises a syntax error.
+  (define (char-range-arg stx containing-stx)
+    (let ((c (syntax-e stx)))
+      (cond
+        ((char? c) (char->integer c))
+        ((and (string? c) (= (string-length c) 1))
+         (char->integer (string-ref c 0)))
+        (else
+         (raise-syntax-error
+          #f
+          "not a char or single-char string"
+          containing-stx stx)))))
+  (test-block ()
+              ((char-range-arg #'#\1 #'here) (char->integer #\1))
+              ((char-range-arg #'"1" #'here) (char->integer #\1)))
+  
+  
+  ;; parse : syntax-object (box (list-of syntax-object)) -> s-re (see re.ss)
+  ;; checks for errors and generates the plain s-exp form for s
+  ;; Expands lex-abbrevs and applies lex-trans.
+  (define (parse stx disappeared-uses)
+    (let ((parse
+           (lambda (s)
+             (parse (syntax-recertify s stx (current-inspector) 'a) 
+                    disappeared-uses))))
+    (syntax-case stx (repetition union intersection complement concatenation
+                      char-range char-complement)
+      (_
+       (identifier? stx)
+       (let ((expansion (syntax-local-value stx (lambda () #f))))
+         (unless (lex-abbrev? expansion)
+           (raise-syntax-error 'regular-expression
+                               "undefined abbreviation"
+                               stx))
+         (set-box! disappeared-uses (cons stx (unbox disappeared-uses)))
+         (parse (lex-abbrev-abbrev expansion))))
+      (_
+       (or (char? (syntax-e stx)) (string? (syntax-e stx)))
+       (syntax-e stx))
+      ((repetition arg ...)
+       (let ((arg-list (syntax->list (syntax (arg ...)))))
+         (unless (= 3 (length arg-list))
+           (bad-args stx 2))
+         (let ((low (syntax-e (car arg-list)))
+               (high (syntax-e (cadr arg-list)))
+               (re (caddr arg-list)))
+           (unless (and (number? low) (exact? low) (integer? low) (>= low 0))
+             (raise-syntax-error #f
+                                 "not a non-negative exact integer"
+                                 stx
+                                 (car arg-list)))
+           (unless (or (and (number? high) (exact? high) (integer? high) (>= high 0))
+                       (eq? high +inf.0))
+             (raise-syntax-error #f
+                                 "not a non-negative exact integer or +inf.0"
+                                 stx
+                                 (cadr arg-list)))
+           (unless (<= low high)
+             (raise-syntax-error
+                #f
+                "the first argument is not less than or equal to the second argument"
+                stx))
+           `(repetition ,low ,high ,(parse re)))))
+      ((union re ...)
+       `(union ,@(map parse (syntax->list (syntax (re ...))))))
+      ((intersection re ...)
+       `(intersection ,@(map parse (syntax->list (syntax (re ...))))))
+      ((complement re ...)
+       (let ((re-list (syntax->list (syntax (re ...)))))
+         (unless (= 1 (length re-list))
+           (bad-args stx 1))
+         `(complement ,(parse (car re-list)))))
+      ((concatenation re ...)
+       `(concatenation ,@(map parse (syntax->list (syntax (re ...))))))
+      ((char-range arg ...)
+       (let ((arg-list (syntax->list (syntax (arg ...)))))
+         (unless (= 2 (length arg-list))
+           (bad-args stx 2))
+         (let ((i1 (char-range-arg (car arg-list) stx))
+               (i2 (char-range-arg (cadr arg-list) stx)))
+           (if (<= i1 i2)
+               `(char-range ,(integer->char i1) ,(integer->char i2))
+               (raise-syntax-error
+                #f
+                "the first argument does not precede or equal second argument" 
+                stx)))))
+      ((char-complement arg ...)
+       (let ((arg-list (syntax->list (syntax (arg ...)))))
+         (unless (= 1 (length arg-list))
+           (bad-args stx 1))
+         (let ((parsed (parse (car arg-list))))
+           (unless (char-set? parsed)
+             (raise-syntax-error #f
+                                 "not a character set"
+                                 stx
+                                 (car arg-list)))
+           `(char-complement ,parsed))))
+       ((op form ...)
+        (identifier? (syntax op))
+        (let* ((o (syntax op))
+               (expansion (syntax-local-value 
+                           (syntax-recertify o stx (current-inspector) 'a) 
+                           (lambda () #f))))
+          (set-box! disappeared-uses (cons o (unbox disappeared-uses)))
+          (cond
+            ((lex-trans? expansion)
+             (parse ((lex-trans-f expansion) stx)))
+            (expansion
+             (raise-syntax-error 'regular-expression
+                                 "not a lex-trans"
+                                 stx))
+            (else
+             (raise-syntax-error 'regular-expression
+                                 "undefined operator"
+                                 stx)))))
+      (_ 
+       (raise-syntax-error
+        'regular-expression
+        "not a char, string, identifier, or (op args ...)"
+        stx)))))
+       
+
+  
+  ;; char-set? : s-re -> bool
+  ;; A char-set is an re that matches only strings of length 1.
+  ;; char-set? is conservative.
+  (define (char-set? s-re)
+    (cond
+      ((char? s-re) #t)
+      ((string? s-re) (= (string-length s-re) 1))
+      ((list? s-re) 
+       (let ((op (car s-re)))
+         (case op
+           ((union intersection) (andmap char-set? (cdr s-re)))
+           ((char-range char-complement) #t)
+           ((repetition)
+            (and (= (cadr s-re) (caddr s-re)) (char-set? (cadddr s-re))))
+           ((concatenation)
+            (and (= 2 (length s-re)) (char-set? (cadr s-re))))
+           (else #f))))
+      (else #f)))
+  (test-block ()
+              ((char-set? #\a) #t)
+              ((char-set? "12") #f)
+              ((char-set? "1") #t)
+              ((char-set? '(repetition 1 2 #\1)) #f)
+              ((char-set? '(repetition 1 1 "12")) #f)
+              ((char-set? '(repetition 1 1 "1")) #t)
+              ((char-set? '(union "1" "2" "3")) #t)
+              ((char-set? '(union "1" "" "3")) #f)
+              ((char-set? '(intersection "1" "2" (union "3" "4"))) #t)
+              ((char-set? '(intersection "1" "")) #f)
+              ((char-set? '(complement "1")) #f)
+              ((char-set? '(concatenation "1" "2")) #f)
+              ((char-set? '(concatenation "" "2")) #f)
+              ((char-set? '(concatenation "1")) #t)
+              ((char-set? '(concatenation "12")) #f)
+              ((char-set? '(char-range #\1 #\2)) #t)
+              ((char-set? '(char-complement #\1)) #t))
+
+  (test-block ()
+              ((parse #'#\a) #\a)
+              ((parse #'"1") "1")
+              ((parse #'(repetition 1 1 #\1)) '(repetition 1 1 #\1))
+              ((parse #'(repetition 0 +inf.0 #\1)) '(repetition 0 +inf.0 #\1))
+              ((parse #'(union #\1 (union "2") (union)))
+               '(union #\1 (union "2") (union)))
+              ((parse #'(intersection #\1 (intersection "2") (intersection)))
+               '(intersection #\1 (intersection "2") (intersection)))
+              ((parse #'(complement (union #\1 #\2)))
+               '(complement (union #\1 #\2)))
+              ((parse #'(concatenation "1" "2" (concatenation)))
+               '(concatenation "1" "2" (concatenation)))
+              ((parse #'(char-range "1" #\1)) '(char-range #\1 #\1))
+              ((parse #'(char-range #\1 "1")) '(char-range #\1 #\1))
+              ((parse #'(char-range "1" "3")) '(char-range #\1 #\3))
+              ((parse #'(char-complement (union "1" "2")))
+               '(char-complement (union "1" "2"))))
+  )
\ No newline at end of file
diff --git a/collects/parser-tools/private-lex/token-syntax.ss b/collects/parser-tools/private-lex/token-syntax.ss
new file mode 100644
index 0000000000..c1f14927f7
--- /dev/null
+++ b/collects/parser-tools/private-lex/token-syntax.ss
@@ -0,0 +1,9 @@
+(module token-syntax mzscheme
+
+  ;; The things needed at compile time to handle definition of tokens
+  
+  (provide make-terminals-def terminals-def-t terminals-def?
+           make-e-terminals-def e-terminals-def-t e-terminals-def?)
+  (define-struct terminals-def (t))
+  (define-struct e-terminals-def (t))
+  )
diff --git a/collects/parser-tools/private-lex/token.ss b/collects/parser-tools/private-lex/token.ss
new file mode 100644
index 0000000000..e78467a5e4
--- /dev/null
+++ b/collects/parser-tools/private-lex/token.ss
@@ -0,0 +1,89 @@
+(module token mzscheme
+
+  (require-for-syntax "token-syntax.ss")
+  
+  ;; Defining tokens
+  
+  (provide define-tokens define-empty-tokens make-token token?
+           (protect (rename token-name real-token-name))
+           (protect (rename token-value real-token-value))
+           (rename token-name* token-name)
+           (rename token-value* token-value)
+           (struct position (offset line col))
+           (struct position-token (token start-pos end-pos)))
+
+  
+  ;; A token is either
+  ;; - symbol
+  ;; - (make-token symbol any)
+  (define-struct token (name value) (make-inspector))
+
+  ;; token-name*: token -> symbol
+  (define (token-name* t)
+    (cond
+      ((symbol? t) t)
+      ((token? t) (token-name t))
+      (else (raise-type-error 
+             'token-name 
+             "symbol or struct:token"
+             0
+             t))))
+  
+  ;; token-value*: token -> any
+  (define (token-value* t)
+    (cond
+      ((symbol? t) #f)
+      ((token? t) (token-value t))
+      (else (raise-type-error 
+             'token-value
+             "symbol or struct:token"
+             0
+             t))))
+  
+  (define-for-syntax (make-ctor-name n)
+    (datum->syntax-object n
+                          (string->symbol  (format "token-~a" (syntax-e n)))
+                          n
+                          n))
+  
+  (define-for-syntax (make-define-tokens empty?)
+    (lambda (stx)
+      (syntax-case stx ()
+        ((_ name (token ...))
+         (andmap identifier? (syntax->list (syntax (token ...))))
+         (with-syntax (((marked-token ...)
+                        (map values #;(make-syntax-introducer)
+                             (syntax->list (syntax (token ...))))))
+           (quasisyntax/loc stx
+             (begin
+               (define-syntax name
+                 #,(if empty?
+                       #'(make-e-terminals-def (quote-syntax (marked-token ...)))
+                       #'(make-terminals-def (quote-syntax (marked-token ...)))))
+               #,@(map
+                   (lambda (n)
+                     (when (eq? (syntax-e n) 'error)
+                       (raise-syntax-error
+                        #f
+                        "Cannot define a token named error."
+                        stx))
+                     (if empty?
+                         #`(define (#,(make-ctor-name n))
+                             '#,n)
+                         #`(define (#,(make-ctor-name n) x)
+                             (make-token '#,n x))))
+                   (syntax->list (syntax (token ...))))
+               #;(define marked-token #f) #;...))))
+        ((_ ...)
+         (raise-syntax-error 
+          #f
+          "must have the form (define-tokens name (identifier ...)) or (define-empty-tokens name (identifier ...))"
+          stx)))))
+  
+  (define-syntax define-tokens (make-define-tokens #f))
+  (define-syntax define-empty-tokens (make-define-tokens #t))
+
+  (define-struct position (offset line col))
+  (define-struct position-token (token start-pos end-pos))
+  )
+
diff --git a/collects/parser-tools/private-lex/unicode-chars.ss b/collects/parser-tools/private-lex/unicode-chars.ss
new file mode 100644
index 0000000000..b580e6c4d2
--- /dev/null
+++ b/collects/parser-tools/private-lex/unicode-chars.ss
@@ -0,0 +1,69 @@
+(module unicode-chars mzscheme
+  (require "util.ss")
+  
+  (provide (all-defined))
+  
+  ;; mapped-chars : (listof (list nat nat bool))
+  (define mapped-chars (make-known-char-range-list))
+  
+  
+  ;; gat-chars-for-x : (nat -> bool) (listof (list nat nat bool)) -> (listof (cons nat nat))
+  (define (get-chars-for char-x? mapped-chars)
+    (cond
+      ((null? mapped-chars) null)
+      (else
+       (let* ((range (car mapped-chars))
+              (low (car range))
+              (high (cadr range))
+              (x (char-x? low)))
+         (cond
+           ((caddr range)
+            (if x
+                (cons (cons low high)
+                      (get-chars-for char-x? (cdr mapped-chars)))
+                (get-chars-for char-x? (cdr mapped-chars))))
+           (else
+            (let loop ((range-start low)
+                       (i (car range))
+                       (parity x))
+              (cond
+                ((> i high)
+                 (if parity
+                     (cons (cons range-start high) (get-chars-for char-x? (cdr mapped-chars)))
+                     (get-chars-for char-x? (cdr mapped-chars))))
+                ((eq? parity (char-x? i))
+                 (loop range-start (add1 i) parity))
+                (parity
+                 (cons (cons range-start (sub1 i)) (loop i (add1 i) #f)))
+                (else
+                 (loop i (add1 i) #t))))))))))
+                     
+  
+  (define (compute-ranges x?)
+    (delay (get-chars-for (lambda (x) (x? (integer->char x))) mapped-chars)))
+  
+  (define alphabetic-ranges   (compute-ranges char-alphabetic?))  ;; 325
+  (define lower-case-ranges   (compute-ranges char-lower-case?))  ;; 405
+  (define upper-case-ranges   (compute-ranges char-upper-case?))  ;; 380
+  (define title-case-ranges   (compute-ranges char-title-case?))  ;; 10
+  (define numeric-ranges      (compute-ranges char-numeric?))     ;; 47
+  (define symbolic-ranges     (compute-ranges char-symbolic?))    ;; 153
+  (define punctuation-ranges  (compute-ranges char-punctuation?)) ;; 86
+  (define graphic-ranges      (compute-ranges char-graphic?))     ;; 401
+  (define whitespace-ranges   (compute-ranges char-whitespace?))  ;; 10
+  (define blank-ranges        (compute-ranges char-blank?))       ;; 9
+  #;(define hexadecimal-ranges  (compute-ranges char-hexadecimal?))
+  (define iso-control-ranges  (compute-ranges char-iso-control?)) ;; 2
+  
+  
+                   
+       
+  (test-block ()
+              ((get-chars-for odd? '()) '())
+              ((get-chars-for odd? '((1 4 #f) (8 13 #f))) '((1 . 1) (3 . 3) (9 . 9) (11 . 11) (13 . 13)))
+              ((get-chars-for (lambda (x)
+                                (odd? (quotient x 10)))
+                              '((1 5 #t) (17 19 #t) (21 51 #f)))
+               '((17 . 19) (30 . 39) (50 . 51))))
+  
+  )
\ No newline at end of file
diff --git a/collects/parser-tools/private-lex/util.ss b/collects/parser-tools/private-lex/util.ss
new file mode 100644
index 0000000000..739f436658
--- /dev/null
+++ b/collects/parser-tools/private-lex/util.ss
@@ -0,0 +1,113 @@
+(module util mzscheme
+  (require (lib "list.ss"))
+  
+  (provide (all-defined))
+
+  (define max-char-num #x10FFFF)
+  
+  (define-struct lex-abbrev (abbrev))
+  (define-struct lex-trans (f))
+  
+  #;(define-syntax test-block
+    (syntax-rules ()
+      ((_ defs (code right-ans) ...)
+       (let* defs
+         (let ((real-ans code))
+           (unless (equal? real-ans right-ans)
+             (printf "Test failed: ~e gave ~e.  Expected ~e~n"
+                     'code real-ans 'right-ans))) ...))))
+
+  (define-syntax test-block
+    (syntax-rules ()
+      ((_ x ...) (void))))
+  
+  
+  ;; A cache is (X ( -> Y) -> Y)
+  ;; make-cache : -> cache
+  ;; table map Xs to Ys.  If key is mapped, its value is returned.
+  ;; Otherwise, build is invoked and its result is placed in the table and
+  ;; returned.
+  ;; Xs are compared with equal?
+  (define (make-cache)
+    (let ((table (make-hash-table 'equal)))
+      (lambda (key build)
+        (hash-table-get table key
+                        (lambda ()
+                          (let ((new (build)))
+                            (hash-table-put! table key new)
+                            new))))))
+  (test-block ((cache (make-cache)))
+              ((cache '(1 2) (lambda () 9)) 9)
+              ((cache '(2 1) (lambda () 8)) 8)
+              ((cache '(1 2) (lambda () 1)) 9))
+
+  
+  ;; make-counter : -> -> nat
+  ;; makes a function that returns a higher number by 1, each time
+  ;; it is called.
+  (define (make-counter)
+    (let ((counter 0))
+      (lambda ()
+        (begin0
+          counter
+          (set! counter (add1 counter))))))
+  (test-block ((c (make-counter))
+               (d (make-counter)))
+              ((c) 0)
+              ((d) 0)
+              ((c) 1)
+              ((d) 1)
+              ((c) 2))
+  
+
+  ;; remove-dups : (list-of X) (X -> number) -> (list-of X)
+  ;; removes the entries from l that have the same index as a
+  ;; previous entry.  l must be grouped by indexes.
+  (define (remove-dups l index acc)
+    (cond
+      ((null? l) (reverse acc))
+      ((null? acc) (remove-dups (cdr l) index (cons (car l) acc)))
+      ((= (index (car acc)) (index (car l)))
+       (remove-dups (cdr l) index acc))
+      (else 
+       (remove-dups (cdr l) index (cons (car l) acc)))))
+
+  (test-block ()
+              ((remove-dups '((1 2) (2 2) (1 3) (1 4) (100 4) (0 5)) cadr null)
+               '((1 2) (1 3) (1 4) (0 5)))
+              ((remove-dups null error null) null))
+  
+  
+  ;; do-simple-equiv : (list-of X) (X -> nat) -> (list-of X)
+  ;; Sorts l according to index and removes the entries with duplicate
+  ;; indexes.
+  (define (do-simple-equiv l index)
+    (let ((ordered (mergesort l (lambda (a b) (< (index a) (index b))))))
+      (remove-dups ordered index null)))
+
+  (test-block ()
+              ((do-simple-equiv '((2 2) (1 4) (1 2) (100 4) (1 3)  (0 5)) cadr)
+               '((2 2) (1 3) (1 4) (0 5)))
+              ((do-simple-equiv null error) null))
+  
+
+  ;; replace : (list-of X) (X -> bool) (X -> (list-of X)) (list-of X) ->
+  ;;           (list-of X)
+  ;; If (pred? r) for some r in l, splice (get r) in place of r in the resulting
+  ;; list.
+  (define (replace l pred? get acc)
+    (cond
+      ((null? l) acc)
+      ((pred? (car l)) (replace (cdr l) pred? get (append (get (car l)) acc)))
+      (else (replace (cdr l) pred? get (cons (car l) acc)))))       
+
+  (test-block ()
+              ((replace null void (lambda () (list 1)) null) null)
+              ((replace '(1 2 3 4 3 5)
+                        (lambda (x) (= x 3))
+                        (lambda (x) (list 1 2 3))
+                        null)
+               '(5 1 2 3 4 1 2 3 2 1)))
+  
+  
+    )
diff --git a/collects/parser-tools/private-yacc/grammar.ss b/collects/parser-tools/private-yacc/grammar.ss
new file mode 100644
index 0000000000..a5b14369b8
--- /dev/null
+++ b/collects/parser-tools/private-yacc/grammar.ss
@@ -0,0 +1,280 @@
+;; Constructs to create and access grammars, the internal
+;; representation of the input to the parser generator.
+
+(module grammar mzscheme
+  
+  (require (lib "class.ss")
+           (lib "list.ss")
+           "yacc-helper.ss"
+           (lib "contract.ss"))
+  
+  ;; Each production has a unique index 0 <= index <= number of productions
+  (define-struct prod (lhs rhs index prec action) (make-inspector))
+
+  ;; The dot-pos field is the index of the element in the rhs
+  ;; of prod that the dot immediately preceeds.
+  ;; Thus 0 <= dot-pos <= (vector-length rhs).
+  (define-struct item (prod dot-pos) (make-inspector))
+  
+  ;; gram-sym = (union term? non-term?)
+  ;; Each term has a unique index 0 <= index < number of terms
+  ;; Each non-term has a unique index 0 <= index < number of non-terms  
+  (define-struct term (sym index prec) (make-inspector))
+  (define-struct non-term (sym index) (make-inspector))
+
+  ;; a precedence declaration.
+  (define-struct prec (num assoc) (make-inspector))
+  
+  (provide/contract
+   (make-item (prod? (union false/c natural-number/c) . -> . item?))
+   (make-term (symbol? (union false/c natural-number/c) (union prec? false/c) . -> . term?))
+   (make-non-term (symbol? (union false/c natural-number/c) . -> . non-term?))
+   (make-prec (natural-number/c (symbols 'left 'right 'nonassoc) . -> . prec?))
+   (make-prod (non-term? (vectorof (union non-term? term?))
+               (union false/c natural-number/c) (union false/c prec?) syntax? . -> . prod?)))
+  
+  (provide 
+     
+   
+   ;; Things that work on items
+   start-item? item-prod item->string 
+   sym-at-dot move-dot-right item<? item-dot-pos
+   
+   ;; Things that operate on grammar symbols
+   gram-sym-symbol gram-sym-index term-prec gram-sym->string
+   non-term? term? non-term<? term<?
+   term-list->bit-vector term-index non-term-index
+   
+   ;; Things that work on precs
+   prec-num prec-assoc
+
+   grammar%
+   
+   ;; Things that work on productions
+   prod-index prod-prec prod-rhs prod-lhs prod-action)
+
+
+  ;;---------------------- LR items --------------------------
+  
+  ;; item<?: LR-item * LR-item -> bool
+  ;; Lexicographic comparison on two items.
+  (define (item<? i1 i2)
+    (let ((p1 (prod-index (item-prod i1)))
+	  (p2 (prod-index (item-prod i2))))
+      (or (< p1 p2)
+	  (and (= p1 p2)
+	       (let ((d1 (item-dot-pos i1))
+		     (d2 (item-dot-pos i2)))
+		 (< d1 d2))))))
+
+  ;; start-item?: LR-item -> bool
+  ;; The start production always has index 0
+  (define (start-item? i)
+    (= 0 (non-term-index (prod-lhs (item-prod i)))))
+
+  
+  ;; move-dot-right: LR-item -> LR-item | #f
+  ;; moves the dot to the right in the item, unless it is at its 
+  ;; rightmost, then it returns false
+  (define (move-dot-right i)
+    (cond
+     ((= (item-dot-pos i) (vector-length (prod-rhs (item-prod i)))) #f)
+     (else (make-item (item-prod i)
+		      (add1 (item-dot-pos i))))))
+
+  ;; sym-at-dot: LR-item -> gram-sym | #f
+  ;; returns the symbol after the dot in the item or #f if there is none  
+  (define (sym-at-dot i)
+    (let ((dp (item-dot-pos i))
+          (rhs (prod-rhs (item-prod i))))
+      (cond
+       ((= dp (vector-length rhs)) #f)
+       (else (vector-ref rhs dp)))))
+  
+ 
+  ;; print-item: LR-item ->
+  (define (item->string it)
+    (let ((print-sym (lambda (i)
+		       (let ((gs (vector-ref (prod-rhs (item-prod it)) i)))
+			 (cond
+			  ((term? gs) (format "~a " (term-sym gs)))
+			  (else (format "~a " (non-term-sym gs))))))))
+      (string-append
+       (format "~a -> " (non-term-sym (prod-lhs (item-prod it))))
+       (let loop ((i 0))
+	 (cond
+	  ((= i (vector-length (prod-rhs (item-prod it)))) 
+	   (if (= i (item-dot-pos it))
+	       ". "
+	       ""))
+	  ((= i (item-dot-pos it)) 
+	   (string-append ". " (print-sym i) (loop (add1 i))))
+	  (else (string-append (print-sym i) (loop (add1 i)))))))))
+
+  ;; --------------------- Grammar Symbols --------------------------
+
+  (define (non-term<? nt1 nt2)
+    (< (non-term-index nt1) (non-term-index nt2)))
+  
+  (define (term<? nt1 nt2)
+    (< (term-index nt1) (term-index nt2)))
+
+  (define (gram-sym-index gs)
+    (cond
+     ((term? gs) (term-index gs))
+     (else (non-term-index gs))))
+
+  (define (gram-sym-symbol gs)
+    (cond
+     ((term? gs) (term-sym gs))
+     (else (non-term-sym gs))))
+
+  (define (gram-sym->string gs)
+    (symbol->string (gram-sym-symbol gs)))
+
+  ;; term-list->bit-vector: term list -> int
+  ;; Creates a number where the nth bit is 1 if the term with index n is in 
+  ;; the list, and whose nth bit is 0 otherwise
+  (define (term-list->bit-vector terms)
+    (cond
+      ((null? terms) 0)
+      (else 
+       (bitwise-ior (arithmetic-shift 1 (term-index (car terms))) (term-list->bit-vector (cdr terms))))))
+  
+
+  ;; ------------------------- Grammar ------------------------------
+
+  (define grammar%
+    (class object%
+      (super-instantiate ())
+      ;; prods: production list list
+      ;; where there is one production list per non-term
+      (init prods)
+      ;; init-prods: production list
+      ;; The productions parsing can start from
+      ;; nullable-non-terms is indexed by the non-term-index and is true iff non-term is nullable
+      (init-field init-prods terms non-terms end-terms)
+  
+      ;; list of all productions
+      (define all-prods (apply append prods))
+      (define num-prods (length all-prods))
+      (define num-terms (length terms))
+      (define num-non-terms (length non-terms))
+      
+      (let ((count 0))
+        (for-each
+         (lambda (nt)
+           (set-non-term-index! nt count)
+           (set! count (add1 count)))
+         non-terms))
+      
+      (let ((count 0))
+        (for-each
+         (lambda (t)
+           (set-term-index! t count)
+           (set! count (add1 count)))
+         terms))
+
+      (let ((count 0))
+        (for-each
+         (lambda (prod)
+           (set-prod-index! prod count)
+           (set! count (add1 count)))
+         all-prods))
+      
+      ;; indexed by the index of the non-term - contains the list of productions for that non-term
+      (define nt->prods
+        (let ((v (make-vector (length prods) #f)))
+          (for-each (lambda (prods)
+                      (vector-set! v (non-term-index (prod-lhs (car prods))) prods))
+                    prods)
+          v))
+      
+      (define nullable-non-terms
+        (nullable all-prods num-non-terms))
+            
+      (define/public (get-num-terms) num-terms)
+      (define/public (get-num-non-terms) num-non-terms)
+      
+      (define/public (get-prods-for-non-term nt)
+        (vector-ref nt->prods (non-term-index nt)))
+      (define/public (get-prods) all-prods)
+      (define/public (get-init-prods) init-prods)
+      
+      (define/public (get-terms) terms)
+      (define/public (get-non-terms) non-terms)
+      
+      (define/public (get-num-prods) num-prods)
+      (define/public (get-end-terms) end-terms)
+      
+      (define/public (nullable-non-term? nt)
+        (vector-ref nullable-non-terms (non-term-index nt)))
+
+      (define/public (nullable-after-dot? item)
+        (let* ((rhs (prod-rhs (item-prod item)))
+               (prod-length (vector-length rhs)))
+          (let loop ((i (item-dot-pos item)))
+            (cond
+              ((< i prod-length)
+               (if (and (non-term? (vector-ref rhs i)) (nullable-non-term? (vector-ref rhs i)))
+                   (loop (add1 i))
+                   #f))
+              ((= i prod-length) #t)))))
+      
+      (define/public (nullable-non-term-thunk)
+        (lambda (nt)
+          (nullable-non-term? nt)))
+      (define/public (nullable-after-dot?-thunk)
+        (lambda (item)
+          (nullable-after-dot? item)))))
+  
+  
+  ;; nullable: production list * int -> non-term set
+  ;; determines which non-terminals can derive epsilon
+  (define (nullable prods num-nts)
+    (letrec ((nullable (make-vector num-nts #f))
+	     (added #f)
+	     
+	     ;; possible-nullable: producion list -> production list
+	     ;; Removes all productions that have a terminal
+	     (possible-nullable
+	      (lambda (prods)
+		(filter (lambda (prod)
+			  (vector-andmap non-term? (prod-rhs prod)))
+			prods)))
+	     
+	     ;; set-nullables: production list -> production list
+	     ;; makes one pass through the productions, adding the ones
+	     ;; known to be nullable now to nullable and returning a list
+	     ;; of productions that we don't know about yet. 
+	     (set-nullables
+	      (lambda (prods)
+		(cond
+                  ((null? prods) null)
+                  ((vector-ref  nullable 
+                                (gram-sym-index (prod-lhs (car prods))))
+                   (set-nullables (cdr prods)))
+                  ((vector-andmap (lambda (nt) 
+                                    (vector-ref nullable (gram-sym-index nt)))
+                                  (prod-rhs (car prods)))
+                   (vector-set! nullable 
+                                (gram-sym-index (prod-lhs (car prods)))
+                                #t)
+                   (set! added #t)
+                   (set-nullables (cdr prods)))
+                  (else
+                   (cons (car prods) 
+                         (set-nullables (cdr prods))))))))
+      
+      (let loop ((P (possible-nullable prods)))
+	(cond
+          ((null? P) nullable)
+          (else
+           (set! added #f)
+           (let ((new-P (set-nullables P)))
+             (if added
+                 (loop new-P)
+                 nullable)))))))
+
+  
+)
diff --git a/collects/parser-tools/private-yacc/graph.ss b/collects/parser-tools/private-yacc/graph.ss
new file mode 100644
index 0000000000..02e28df58f
--- /dev/null
+++ b/collects/parser-tools/private-yacc/graph.ss
@@ -0,0 +1,66 @@
+(module graph mzscheme
+
+  (provide digraph)
+
+  (define (zero-thunk) 0)
+  
+  ;; digraph: 
+  ;;   ('a list) * ('a -> 'a list) * ('a -> 'b) * ('b * 'b -> 'b) * (-> 'b)
+  ;;     -> ('a -> 'b)
+  ;; DeRemer and Pennello 1982
+  ;; Computes (f x) = (f- x) union Union{(f y) | y in (edges x)}
+  ;; We use a hash-table to represent the result function 'a -> 'b set, so
+  ;; the values of type 'a must be comparable with eq?.
+  (define (digraph nodes edges f- union fail)
+    (letrec (
+	     ;; Will map elements of 'a to 'b sets
+	     (results (make-hash-table))
+	     (f (lambda (x) (hash-table-get results x fail)))
+	     
+	     ;; Maps elements of 'a to integers.
+	     (N (make-hash-table))
+	     (get-N (lambda (x) (hash-table-get N x zero-thunk)))
+	     (set-N (lambda (x d) (hash-table-put! N x d)))
+	     
+	     (stack null)
+	     (push (lambda (x)
+		     (set! stack (cons x stack))))
+	     (pop (lambda () 
+                    (begin0 
+		     (car stack)
+		     (set! stack (cdr stack)))))
+       	     (depth (lambda () (length stack)))
+
+	     ;; traverse: 'a -> 
+	     (traverse
+	      (lambda (x)
+		(push x)
+		(let ((d (depth)))
+		  (set-N x d)
+		  (hash-table-put! results x (f- x))
+		  (for-each (lambda (y)
+			      (if (= 0 (get-N y))
+				  (traverse y))
+			      (hash-table-put! results
+					       x
+					       (union (f x) (f y)))
+			      (set-N x (min (get-N x) (get-N y))))
+			    (edges x))
+		  (if (= d (get-N x))
+		      (let loop ((p (pop)))
+			(set-N p +inf.0)
+			(hash-table-put! results p (f x))
+			(if (not (eq? x p))
+			    (loop (pop)))))))))
+      (for-each (lambda (x)
+		  (if (= 0 (get-N x))
+		      (traverse x)))
+		nodes)
+      f))
+
+)
+
+
+
+
+
diff --git a/collects/parser-tools/private-yacc/info.ss b/collects/parser-tools/private-yacc/info.ss
new file mode 100644
index 0000000000..16a3c7fdab
--- /dev/null
+++ b/collects/parser-tools/private-yacc/info.ss
@@ -0,0 +1,3 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Parser-tools private-yacc"))
+
diff --git a/collects/parser-tools/private-yacc/input-file-parser.ss b/collects/parser-tools/private-yacc/input-file-parser.ss
new file mode 100644
index 0000000000..456c8359e7
--- /dev/null
+++ b/collects/parser-tools/private-yacc/input-file-parser.ss
@@ -0,0 +1,357 @@
+(module input-file-parser mzscheme
+
+  ;; routines for parsing the input to the parser generator and producing a
+  ;; grammar (See grammar.ss)
+  
+  (require "yacc-helper.ss"
+           "../private-lex/token-syntax.ss"
+           "grammar.ss"
+           (lib "class.ss")
+           (lib "contract.ss"))
+  (require-for-template mzscheme)
+  
+
+  (provide/contract 
+   (parse-input ((listof identifier?) (listof identifier?) (listof identifier?)
+                 (union false/c syntax?) syntax? any/c . -> . (is-a?/c grammar%)))
+   (get-term-list ((listof identifier?) . -> . (listof identifier?))))
+
+  (define stx-for-original-property (read-syntax #f (open-input-string "original")))
+
+  ;; get-args: ???
+  (define (get-args i rhs src-pos term-defs)
+    (let ((empty-table (make-hash-table)))
+      (hash-table-put! empty-table 'error #t)
+      (for-each (lambda (td)
+                  (let ((v (syntax-local-value td)))
+                    (if (e-terminals-def? v)
+                        (for-each (lambda (s)
+                                    (hash-table-put! empty-table (syntax-object->datum s) #t))
+                                  (syntax->list (e-terminals-def-t v))))))
+                term-defs)
+      (let get-args ((i i) 
+                     (rhs rhs))
+        (cond
+          ((null? rhs) null)
+          (else
+           (let ((b (car rhs))
+                 (name (if (hash-table-get empty-table (syntax-object->datum (car rhs)) (lambda () #f))
+                           (gensym)
+                           (string->symbol (format "$~a" i)))))
+             (cond
+               (src-pos
+                `(,(datum->syntax-object b name b stx-for-original-property)
+                  ,(datum->syntax-object b (string->symbol (format "$~a-start-pos" i)) b stx-for-original-property)
+                  ,(datum->syntax-object b (string->symbol (format "$~a-end-pos" i)) b stx-for-original-property)
+                  ,@(get-args (add1 i) (cdr rhs))))
+               (else
+                `(,(datum->syntax-object b name b stx-for-original-property)
+                  ,@(get-args (add1 i) (cdr rhs)))))))))))
+    
+  ;; Given the list of terminal symbols and the precedence/associativity definitions,
+  ;; builds terminal structures (See grammar.ss)
+  ;; build-terms: symbol list * symbol list list -> term list
+  (define (build-terms term-list precs)
+    (let ((counter 0)
+
+	  ;;(term-list (cons (gensym) term-list))
+          
+          ;; Will map a terminal symbol to its precedence/associativity
+          (prec-table (make-hash-table)))
+      
+      ;; Fill the prec table
+      (for-each
+       (lambda (p-decl)
+	 (begin0
+	  (let ((assoc (car p-decl)))
+	    (for-each
+	     (lambda (term-sym)
+	       (hash-table-put! prec-table term-sym (make-prec counter assoc)))
+	     (cdr p-decl)))
+	  (set! counter (add1 counter))))
+       precs)
+      
+      ;; Build the terminal structures
+      (map 
+       (lambda (term-sym)
+         (make-term term-sym 
+                    #f
+                    (hash-table-get prec-table term-sym (lambda () #f))))
+       term-list)))
+  
+  ;; Retrieves the terminal symbols from a terminals-def (See terminal-syntax.ss)
+  ;; get-terms-from-def: identifier? -> (listof identifier?)
+  (define (get-terms-from-def term-syn)
+    (let ((t (syntax-local-value term-syn (lambda () #f))))
+      (cond
+       ((terminals-def? t) (syntax->list (terminals-def-t t)))
+       ((e-terminals-def? t) (syntax->list (e-terminals-def-t t)))
+       (else
+	(raise-syntax-error 
+         'parser-tokens
+         "undefined token group"
+         term-syn)))))
+
+  (define (get-term-list term-group-names)
+    (remove-duplicates
+     (cons (datum->syntax-object #f 'error)
+           (apply append
+                  (map get-terms-from-def term-group-names)))))
+  
+  (define (parse-input term-defs start ends prec-decls prods src-pos)
+    (let* ((start-syms (map syntax-e start))
+           
+           (list-of-terms (map syntax-e (get-term-list term-defs)))
+
+           (end-terms
+            (map
+             (lambda (end)
+               (unless (memq (syntax-e end) list-of-terms)
+                 (raise-syntax-error
+                  'parser-end-tokens
+                  (format "End token ~a not defined as a token"
+                          (syntax-e end))
+                  end))
+               (syntax-e end))
+             ends))
+                     
+           ;; Get the list of terminals out of input-terms
+           
+           (list-of-non-terms
+            (syntax-case prods ()
+              (((non-term production ...) ...)
+               (begin
+                 (for-each
+                  (lambda (nts)
+                    (if (memq (syntax-object->datum nts) list-of-terms)
+                        (raise-syntax-error
+                         'parser-non-terminals
+                         (format "~a used as both token and non-terminal"
+                                 (syntax-object->datum nts))
+                         nts)))
+                  (syntax->list (syntax (non-term ...))))
+                 
+                 (let ((dup (duplicate-list? (syntax-object->datum 
+                                              (syntax (non-term ...))))))
+                   (if dup
+                       (raise-syntax-error
+                        'parser-non-terminals
+                        (format "non-terminal ~a defined multiple times"
+                                dup)
+                        prods)))
+                 
+                 (syntax-object->datum (syntax (non-term ...)))))
+              (_
+               (raise-syntax-error
+                'parser-grammar
+                "Grammar must be of the form (grammar (non-terminal productions ...) ...)"
+                prods))))
+           
+           ;; Check the precedence declarations for errors and turn them into data
+           (precs
+            (syntax-case prec-decls ()
+              (((type term ...) ...)
+               (let ((p-terms 
+                      (syntax-object->datum (syntax (term ... ...)))))
+                 (cond
+                   ((duplicate-list? p-terms) =>
+                    (lambda (d)
+                      (raise-syntax-error
+                       'parser-precedences
+                       (format "duplicate precedence declaration for token ~a"
+                               d)
+                       prec-decls)))
+                   (else
+                    (for-each
+                     (lambda (a)
+                       (for-each
+                        (lambda (t)
+                          (if (not (memq (syntax-object->datum t) 
+                                         list-of-terms))
+                              (raise-syntax-error
+                               'parser-precedences
+                               (format
+                                "Precedence declared for non-token ~a"
+                                (syntax-object->datum t))
+                               t)))
+                        (syntax->list a)))
+                     (syntax->list (syntax ((term ...) ...))))
+                    (for-each
+                     (lambda (type)
+                       (if (not (memq (syntax-object->datum type)
+                                      `(left right nonassoc)))
+                           (raise-syntax-error
+                            'parser-precedences
+                            "Associativity must be left, right or nonassoc"
+                            type)))
+                     (syntax->list (syntax (type ...))))
+                    (syntax-object->datum prec-decls)))))
+              (#f null)
+              (_
+               (raise-syntax-error
+                'parser-precedences
+                "Precedence declaration must be of the form (precs (assoc term ...) ...) where assoc is left, right or nonassoc"
+                prec-decls))))
+           
+           (terms (build-terms list-of-terms precs))
+           
+           (non-terms (map (lambda (non-term) (make-non-term non-term #f))
+                           list-of-non-terms))
+           (term-table (make-hash-table))
+           (non-term-table (make-hash-table)))
+      
+      (for-each (lambda (t)
+		  (hash-table-put! term-table (gram-sym-symbol t) t))
+		terms)
+      
+      (for-each (lambda (nt)
+		  (hash-table-put! non-term-table (gram-sym-symbol nt) nt))
+		non-terms)
+      
+      (let* (
+	     ;; parse-prod: syntax-object -> gram-sym vector
+	     (parse-prod
+	      (lambda (prod-so)
+                (syntax-case prod-so ()
+                  ((prod-rhs-sym ...)
+                   (andmap identifier? (syntax->list prod-so))
+                   (begin
+                     (for-each (lambda (t)
+                                 (if (memq (syntax-object->datum t) end-terms)
+                                     (raise-syntax-error
+                                      'parser-production-rhs
+                                      (format "~a is an end token and cannot be used in a production"
+                                              (syntax-object->datum t))
+                                      t)))
+                               (syntax->list prod-so))
+                     (list->vector
+                      (map (lambda (s)
+                             (hash-table-get 
+                              term-table 
+                              (syntax-object->datum s)
+                              (lambda ()
+                                (hash-table-get 
+                                 non-term-table
+                                 (syntax-object->datum s)
+                                 (lambda ()
+                                   (raise-syntax-error
+                                    'parser-production-rhs
+                                    (format 
+                                     "~a is not declared as a terminal or non-terminal"
+                                     (syntax-object->datum s))
+                                    s))))))
+                           (syntax->list prod-so)))))
+                  (_
+                   (raise-syntax-error
+                    'parser-production-rhs
+                    "production right-hand-side must have form (symbol ...)"
+                    prod-so)))))
+	     
+             ;; parse-action: syntax-object * syntax-object -> syntax-object
+             (parse-action 
+              (lambda (rhs act)
+                (quasisyntax/loc act
+                  (lambda #,(get-args 1 (syntax->list rhs) src-pos term-defs)
+                    #,act))))
+             
+	     ;; parse-prod+action: non-term * syntax-object -> production
+	     (parse-prod+action
+	      (lambda (nt prod-so)
+                (syntax-case prod-so ()
+                  ((prod-rhs action)
+                   (let ((p (parse-prod (syntax prod-rhs))))
+                     (make-prod 
+                      nt
+                      p
+                      #f
+                      (let loop ((i (sub1 (vector-length p))))
+                        (if (>= i 0)
+                            (let ((gs (vector-ref p i)))
+                              (if (term? gs)
+                                  (term-prec gs)
+                                  (loop (sub1 i))))
+                            #f))
+                      (parse-action (syntax prod-rhs) (syntax action)))))
+                  ((prod-rhs (prec term) action)
+                   (identifier? (syntax term))
+                   (let ((p (parse-prod (syntax prod-rhs))))
+                     (make-prod 
+                      nt 
+                      p
+                      #f
+                      (term-prec
+                       (hash-table-get 
+                        term-table 
+                        (syntax-object->datum (syntax term))
+                        (lambda ()
+                          (raise-syntax-error
+                           'parser-production-rhs
+                           (format
+                            "unrecognized terminal ~a in precedence declaration"
+                            (syntax-object->datum (syntax term)))
+                           (syntax term)))))
+                      (parse-action (syntax prod-rhs) (syntax action)))))
+                  (_
+                   (raise-syntax-error
+                    'parser-production-rhs
+                    "production must have form [(symbol ...) expression] or [(symbol ...) (prec symbol) expression]"
+                    prod-so)))))
+             
+	     ;; parse-prod-for-nt: syntax-object -> production list
+	     (parse-prods-for-nt
+	      (lambda (prods-so)
+                (syntax-case prods-so ()
+                  ((nt productions ...)
+                   (> (length (syntax->list (syntax (productions ...)))) 0)
+                   (let ((nt (hash-table-get non-term-table 
+                                             (syntax-object->datum (syntax nt)))))
+                     (map (lambda (p) (parse-prod+action nt p)) 
+                          (syntax->list (syntax (productions ...))))))
+		  (_
+                   (raise-syntax-error
+                    'parser-productions
+                    "A production for a non-terminal must be (non-term right-hand-side ...) with at least 1 right hand side"
+                    prods-so))))))
+		 
+        (for-each
+         (lambda (sstx ssym)
+           (unless (memq ssym list-of-non-terms)
+             (raise-syntax-error
+              'parser-start
+              (format "Start symbol ~a not defined as a non-terminal" ssym)
+              sstx)))
+         start start-syms)
+                 
+        (let* ((starts (map (lambda (x) (make-non-term (gensym) #f)) start-syms))
+               (end-non-terms (map (lambda (x) (make-non-term (gensym) #f)) start-syms))
+               (parsed-prods (map parse-prods-for-nt (syntax->list prods)))
+               (start-prods
+                (map (lambda (start end-non-term)
+                       (list (make-prod start (vector end-non-term) #f #f 
+                                        (syntax (lambda (x) x)))))
+                     starts end-non-terms))
+               (prods 
+                `(,@start-prods
+                  ,@(map
+                     (lambda (end-nt start-sym)
+                       (map
+                        (lambda (end)
+                          (make-prod end-nt
+                                     (vector
+                                      (hash-table-get non-term-table start-sym)
+                                      (hash-table-get term-table end))
+                                     #f
+                                     #f
+                                     (syntax (lambda (x) x))))
+                        end-terms))
+                     end-non-terms start-syms)
+                  ,@parsed-prods)))
+          
+          (make-object grammar%
+            prods
+            (map car start-prods)
+            terms
+            (append starts (append end-non-terms non-terms))
+            (map (lambda (term-name)
+                   (hash-table-get term-table term-name))
+                 end-terms)))))))
diff --git a/collects/parser-tools/private-yacc/lalr.ss b/collects/parser-tools/private-yacc/lalr.ss
new file mode 100644
index 0000000000..d37c6d5ba4
--- /dev/null
+++ b/collects/parser-tools/private-yacc/lalr.ss
@@ -0,0 +1,281 @@
+(module lalr mzscheme
+  
+  ;; Compute LALR lookaheads from DeRemer and Pennello 1982
+  
+  (require "lr0.ss"
+	   "grammar.ss"
+	   (lib "list.ss")
+	   (lib "class.ss"))
+
+  (provide compute-LA)
+  
+  ;; compute-DR: LR0-automaton * grammar -> (trans-key -> term set)
+  ;; computes for each state, non-term transition pair, the terminals
+  ;; which can transition out of the resulting state
+  ;; output term set is represented in bit-vector form
+  (define (compute-DR a g)
+    (lambda (tk)
+      (let ((r (send a run-automaton (trans-key-st tk) (trans-key-gs tk))))
+        (term-list->bit-vector
+         (filter
+          (lambda (term)
+            (send a run-automaton r term))
+          (send g get-terms))))))
+  
+  ;; compute-reads: 
+  ;;   LR0-automaton * grammar -> (trans-key -> trans-key list)
+  (define (compute-reads a g)
+    (let ((nullable-non-terms 
+           (filter (lambda (nt) (send g nullable-non-term? nt))
+                   (send g get-non-terms))))
+      (lambda (tk)
+        (let ((r (send a run-automaton (trans-key-st tk) (trans-key-gs tk))))
+          (map (lambda (x) (make-trans-key r x))
+               (filter (lambda (non-term) (send a run-automaton r non-term))
+                       nullable-non-terms))))))
+  
+  ;; compute-read: LR0-automaton * grammar -> (trans-key -> term set)
+  ;; output term set is represented in bit-vector form
+  (define (compute-read a g)
+    (let* ((dr (compute-DR a g))
+	   (reads (compute-reads a g)))
+      (digraph-tk->terml (send a get-mapped-non-term-keys)
+                         reads
+                         dr
+                         (send a get-num-states))))
+  ;; returns the list of all k such that state k transitions to state start on the
+  ;; transitions in rhs (in order)
+  (define (run-lr0-backward a rhs dot-pos start num-states)
+    (let loop ((states (list start))
+               (i (sub1 dot-pos)))
+      (cond
+        ((< i 0) states)
+        (else (loop (send a run-automaton-back states (vector-ref rhs i))
+                    (sub1 i))))))
+
+  ;; prod->items-for-include: grammar * prod * non-term -> lr0-item list
+  ;; returns the list of all (B -> beta . nt gamma) such that prod = (B -> beta nt gamma)
+  ;; and gamma =>* epsilon
+  (define (prod->items-for-include g prod nt)
+    (let* ((rhs (prod-rhs prod))
+           (rhs-l (vector-length rhs)))
+      (append (if (and (> rhs-l 0) (eq? nt (vector-ref rhs (sub1 rhs-l))))
+                  (list (make-item prod (sub1 rhs-l)))
+                  null)
+              (let loop ((i (sub1 rhs-l)))
+                (cond
+                  ((and (> i 0) 
+                        (non-term? (vector-ref rhs i)) 
+                        (send g nullable-non-term? (vector-ref rhs i)))
+                   (if (eq? nt (vector-ref rhs (sub1 i)))
+                       (cons (make-item prod (sub1 i))
+                             (loop (sub1 i)))
+                       (loop (sub1 i))))
+                  (else null))))))
+
+  ;; prod-list->items-for-include: grammar * prod list * non-term -> lr0-item list
+  ;; return the list of all (B -> beta . nt gamma) such that  (B -> beta nt gamma) in prod-list
+  ;; and gamma =>* epsilon
+  (define (prod-list->items-for-include g prod-list nt)
+    (apply append (map (lambda (prod) (prod->items-for-include g prod nt)) prod-list)))
+
+  ;; comput-includes: lr0-automaton * grammar -> (trans-key -> trans-key list)
+  (define (compute-includes a g)
+    (let ((num-states (send a get-num-states))
+          (items-for-input-nt (make-vector (send g get-num-non-terms) null)))
+      (for-each
+       (lambda (input-nt)
+         (vector-set! items-for-input-nt (non-term-index input-nt)
+                      (prod-list->items-for-include g (send g get-prods) input-nt)))
+       (send g get-non-terms))
+      (lambda (tk)
+        (let* ((goal-state (trans-key-st tk))
+               (non-term (trans-key-gs tk))
+               (items (vector-ref items-for-input-nt (non-term-index non-term))))
+          (trans-key-list-remove-dups
+           (apply append
+                  (map (lambda (item)
+                         (let* ((prod (item-prod item))
+                                (rhs (prod-rhs prod))
+                                (lhs (prod-lhs prod)))
+                           (map (lambda (state)
+                                  (make-trans-key state lhs))
+                                (run-lr0-backward a 
+                                                  rhs
+                                                  (item-dot-pos item)
+                                                  goal-state 
+                                                  num-states))))
+                       items)))))))
+  
+  ;; compute-lookback: lr0-automaton * grammar -> (kernel * proc -> trans-key list)
+  (define (compute-lookback a g)
+    (let ((num-states (send a get-num-states)))
+      (lambda (state prod)
+        (map (lambda (k) (make-trans-key k (prod-lhs prod)))
+             (run-lr0-backward a (prod-rhs prod) (vector-length (prod-rhs prod)) state num-states)))))
+  
+  ;; compute-follow:  LR0-automaton * grammar -> (trans-key -> term set)
+  ;; output term set is represented in bit-vector form
+  (define (compute-follow a g includes)
+    (let ((read (compute-read a g)))
+      (digraph-tk->terml (send a get-mapped-non-term-keys)
+                         includes
+                         read
+                         (send a get-num-states))))
+    
+  ;; compute-LA: LR0-automaton * grammar -> kernel * prod -> term set
+  ;; output term set is represented in bit-vector form
+  (define (compute-LA a g)
+    (let* ((includes (compute-includes a g))
+	   (lookback (compute-lookback a g))
+	   (follow  (compute-follow a g includes)))
+      (lambda (k p)
+	(let* ((l (lookback k p))
+	       (f (map follow l)))
+	  (apply bitwise-ior (cons 0 f))))))
+
+
+  (define (print-DR dr a g)
+    (print-input-st-sym dr "DR" a g print-output-terms))
+  (define (print-Read Read a g)
+    (print-input-st-sym Read "Read" a g print-output-terms))
+  (define (print-includes i a g)
+    (print-input-st-sym i "includes" a g print-output-st-nt))
+  (define (print-lookback l a g)
+    (print-input-st-prod l "lookback" a g print-output-st-nt))
+  (define (print-follow f a g)
+    (print-input-st-sym f "follow" a g print-output-terms))
+  (define (print-LA l a g)
+    (print-input-st-prod l "LA" a g print-output-terms))
+
+  (define (print-input-st-sym f name a g print-output)
+    (printf "~a:~n" name)
+    (send a for-each-state
+     (lambda (state)
+       (for-each
+        (lambda (non-term)
+          (let ((res (f (make-trans-key state non-term))))
+            (if (not (null? res))
+                (printf "~a(~a, ~a) = ~a~n"
+                        name
+                        state
+                        (gram-sym-symbol non-term)
+                        (print-output res)))))
+        (send g get-non-terms))))
+    (newline))
+
+  (define (print-input-st-prod f name a g print-output)
+    (printf "~a:~n" name)
+    (send a for-each-state
+     (lambda (state)
+       (for-each
+        (lambda (non-term)
+          (for-each
+           (lambda (prod)
+             (let ((res (f state prod)))
+               (if (not (null? res))
+                   (printf "~a(~a, ~a) = ~a~n"
+                           name
+                           (kernel-index state)
+                           (prod-index prod)
+                           (print-output res)))))
+           (send g get-prods-for-non-term non-term)))
+        (send g get-non-terms)))))
+  
+  (define (print-output-terms r)
+    (map 
+     (lambda (p)
+       (gram-sym-symbol p))
+     r))
+  
+  (define (print-output-st-nt r)
+    (map
+     (lambda (p)
+       (list
+	(kernel-index (trans-key-st p))
+	(gram-sym-symbol (trans-key-gs p))))
+     r))
+
+  ;; init-tk-map : int -> (vectorof hashtable?)
+  (define (init-tk-map n)
+    (let ((v (make-vector n #f)))
+      (let loop ((i (sub1 (vector-length v))))
+        (when (>= i 0)
+          (vector-set! v i (make-hash-table))
+          (loop (sub1 i))))
+      v))
+  
+  ;; lookup-tk-map : (vectorof (symbol? int hashtable)) -> trans-key? -> int
+  (define (lookup-tk-map map)
+    (lambda (tk)
+      (let ((st (trans-key-st tk))
+            (gs (trans-key-gs tk)))
+        (hash-table-get (vector-ref map (kernel-index st))
+                        (gram-sym-symbol gs)
+                        (lambda () 0)))))
+
+  ;; add-tk-map : (vectorof (symbol? int hashtable)) -> trans-key int -> 
+  (define (add-tk-map map)
+    (lambda (tk v)
+      (let ((st (trans-key-st tk))
+            (gs (trans-key-gs tk)))
+        (hash-table-put! (vector-ref map (kernel-index st))
+                         (gram-sym-symbol gs)
+                         v))))
+             
+  ;; digraph-tk->terml: 
+  ;;   (trans-key list) * (trans-key -> trans-key list) * (trans-key -> term list) * int * int * int
+  ;;     -> (trans-key -> term list)
+  ;; DeRemer and Pennello 1982
+  ;; Computes (f x) = (f- x) union Union{(f y) | y in (edges x)}
+  ;; A specialization of digraph in the file graph.ss
+  (define (digraph-tk->terml nodes edges f- num-states)
+    (letrec (
+	     ;; Will map elements of trans-key to term sets represented as bit vectors
+	     (results (init-tk-map num-states))
+             
+	     ;; Maps elements of trans-keys to integers.
+	     (N (init-tk-map num-states))
+             
+             (get-N (lookup-tk-map N))
+	     (set-N (add-tk-map N))
+	     (get-f (lookup-tk-map results))
+	     (set-f (add-tk-map results))
+	     
+	     (stack null)
+	     (push (lambda (x)
+		     (set! stack (cons x stack))))
+	     (pop (lambda () 
+                    (begin0 
+		     (car stack)
+		     (set! stack (cdr stack)))))
+       	     (depth (lambda () (length stack)))
+
+	     ;; traverse: 'a -> 
+	     (traverse
+	      (lambda (x)
+		(push x)
+		(let ((d (depth)))
+		  (set-N x d)
+		  (set-f x (f- x))
+		  (for-each (lambda (y)
+			      (when (= 0 (get-N y))
+                                (traverse y))
+			      (set-f x (bitwise-ior (get-f x) (get-f y)))
+			      (set-N x (min (get-N x) (get-N y))))
+			    (edges x))
+		  (when (= d (get-N x))
+                    (let loop ((p (pop)))
+                      (set-N p +inf.0)
+                      (set-f p (get-f x))
+                      (unless (equal? x p)
+                        (loop (pop)))))))))
+      (for-each (lambda (x)
+		  (when (= 0 (get-N x))
+                    (traverse x)))
+		nodes)
+      get-f))
+)
+
+
+
diff --git a/collects/parser-tools/private-yacc/lr0.ss b/collects/parser-tools/private-yacc/lr0.ss
new file mode 100644
index 0000000000..dbbcc009b9
--- /dev/null
+++ b/collects/parser-tools/private-yacc/lr0.ss
@@ -0,0 +1,373 @@
+(module lr0 mzscheme
+
+  ;; Handle the LR0 automaton
+  
+  (require "grammar.ss"
+	   "graph.ss"
+	   (lib "list.ss")
+	   (lib "class.ss"))
+  
+  (provide build-lr0-automaton lr0%
+	   (struct trans-key (st gs)) trans-key-list-remove-dups
+	   kernel-items kernel-index)
+
+  ;; kernel = (make-kernel (LR1-item list) index)
+  ;;   the list must be kept sorted according to item<? so that equal? can
+  ;;   be used to compare kernels
+  ;;   Each kernel is assigned a unique index, 0 <= index < number of states
+  ;; trans-key = (make-trans-key kernel gram-sym)
+  (define-struct kernel (items index) (make-inspector))
+  (define-struct trans-key (st gs) (make-inspector))
+
+  (define (trans-key<? a b)
+    (let ((kia (kernel-index (trans-key-st a)))
+          (kib (kernel-index (trans-key-st b))))
+    (or (< kia kib)
+        (and (= kia kib)
+             (< (non-term-index (trans-key-gs a))
+                (non-term-index (trans-key-gs b)))))))
+  
+  (define (trans-key-list-remove-dups tkl)
+    (let loop ((sorted (quicksort tkl trans-key<?)))
+      (cond
+        ((null? sorted) null)
+        ((null? (cdr sorted)) sorted)
+        (else
+         (if (and (= (non-term-index (trans-key-gs (car sorted)))
+                     (non-term-index (trans-key-gs (cadr sorted))))
+                  (= (kernel-index (trans-key-st (car sorted)))
+                     (kernel-index (trans-key-st (cadr sorted)))))
+             (loop (cdr sorted))
+             (cons (car sorted) (loop (cdr sorted))))))))
+             
+      
+           
+  ;; build-transition-table : int (listof (cons/c trans-key X) ->
+  ;;                          (vectorof (symbol X hashtable))
+  (define (build-transition-table num-states assoc)
+    (let ((transitions (make-vector num-states #f)))
+      (let loop ((i (sub1 (vector-length transitions))))
+        (when (>= i 0)
+          (vector-set! transitions i (make-hash-table))
+          (loop (sub1 i))))
+      (for-each
+       (lambda (trans-key/kernel)
+         (let ((tk (car trans-key/kernel)))
+           (hash-table-put! (vector-ref transitions (kernel-index (trans-key-st tk)))
+                            (gram-sym-symbol (trans-key-gs tk))
+                            (cdr trans-key/kernel))))
+       assoc)
+      transitions))
+  
+  ;; reverse-assoc : (listof (cons/c trans-key? kernel?)) ->
+  ;;                 (listof (cons/c trans-key? (listof kernel?)))
+  (define (reverse-assoc assoc)
+    (let ((reverse-hash (make-hash-table 'equal))
+	  (hash-table-add!
+	   (lambda (ht k v)
+	     (hash-table-put! ht k (cons v (hash-table-get ht k (lambda () null)))))))
+      (for-each
+       (lambda (trans-key/kernel)
+         (let ((tk (car trans-key/kernel)))
+           (hash-table-add! reverse-hash 
+                            (make-trans-key (cdr trans-key/kernel)
+                                            (trans-key-gs tk))
+                            (trans-key-st tk))))
+       assoc)
+      (hash-table-map reverse-hash cons)))
+
+
+  ;; kernel-list-remove-duplicates
+  ;; LR0-automaton = object of class lr0%
+  (define lr0%
+    (class object%
+      (super-instantiate ())
+      ;; term-assoc : (listof (cons/c trans-key? kernel?))
+      ;; non-term-assoc : (listof (cons/c trans-key? kernel?))
+      ;; states : (vectorof kernel?)
+      ;; epsilons : ???
+      (init-field term-assoc non-term-assoc states epsilons)
+            
+      (define transitions (build-transition-table (vector-length states)
+                                                  (append term-assoc non-term-assoc)))
+      
+      (define reverse-term-assoc (reverse-assoc term-assoc))
+      (define reverse-non-term-assoc (reverse-assoc non-term-assoc))
+      (define reverse-transitions
+        (build-transition-table (vector-length states)
+                                (append reverse-term-assoc reverse-non-term-assoc)))
+      
+      (define mapped-non-terms (map car non-term-assoc))
+      
+      (define/public (get-mapped-non-term-keys)
+	mapped-non-terms)
+
+      (define/public (get-num-states)
+        (vector-length states))
+      
+      (define/public (get-epsilon-trans)
+	epsilons)
+
+      (define/public (get-transitions)
+        (append term-assoc non-term-assoc))
+      
+      ;; for-each-state : (state ->) ->
+      ;; Iteration over the states in an automaton
+      (define/public (for-each-state f)
+	(let ((num-states (vector-length states)))
+	  (let loop ((i 0))
+	    (if (< i num-states)
+		(begin
+		  (f (vector-ref states i))
+		  (loop (add1 i)))))))
+      
+      ;; run-automaton: kernel? gram-sym? -> (union kernel #f)
+      ;; returns the state reached from state k on input s, or #f when k
+      ;; has no transition on s
+      (define/public (run-automaton k s)
+        (hash-table-get (vector-ref transitions (kernel-index k))
+                        (gram-sym-symbol s)
+                        (lambda () #f)))
+
+      ;; run-automaton-back : (listof kernel?) gram-sym? -> (listof kernel)
+      ;; returns the list of states that can reach k by transitioning on s.
+      (define/public (run-automaton-back k s)
+	(apply append
+               (map 
+                (lambda (k)
+                  (hash-table-get (vector-ref reverse-transitions (kernel-index k))
+                                  (gram-sym-symbol s)
+                                  (lambda () null)))
+                k)))))
+      			
+  (define (union comp<?)
+    (letrec ((union
+	      (lambda (l1 l2)
+		(cond
+		 ((null? l1) l2)
+		 ((null? l2) l1)
+		 (else (let ((c1 (car l1))
+			     (c2 (car l2)))
+			 (cond
+			  ((comp<? c1 c2)
+			   (cons c1 (union (cdr l1) l2)))
+			  ((comp<? c2 c1)
+			   (cons c2 (union l1 (cdr l2))))
+			  (else (union (cdr l1) l2)))))))))
+      union))
+  
+
+  ;; The kernels in the automaton are represented cannonically.
+  ;; That is (equal? a b) <=> (eq? a b)
+  (define (kernel->string k)
+    (apply string-append 
+	   `("{" ,@(map (lambda (i) (string-append (item->string i) ", ")) 
+			(kernel-items k)) 
+	     "}")))
+
+  ;; build-LR0-automaton: grammar -> LR0-automaton
+  ;; Constructs the kernels of the sets of LR(0) items of g
+  (define (build-lr0-automaton grammar)
+;    (printf "LR(0) automaton:~n")
+    (letrec (
+	     (epsilons (make-hash-table 'equal))
+	     (grammar-symbols (append (send grammar get-non-terms)
+                                      (send grammar get-terms)))
+	     ;; first-non-term: non-term -> non-term list
+	     ;; given a non-terminal symbol C, return those non-terminal 
+	     ;; symbols A s.t. C -> An for some string of terminals and
+	     ;; non-terminals n where -> means a rightmost derivation in many 
+	     ;; steps.  Assumes that each non-term can be reduced to a string 
+	     ;; of terms.
+	     (first-non-term 
+	      (digraph (send grammar get-non-terms)
+		       (lambda (nt)
+			 (filter non-term?
+				 (map (lambda (prod)
+					(sym-at-dot (make-item prod 0)))
+				      (send grammar get-prods-for-non-term nt))))
+		       (lambda (nt) (list nt))
+		       (union non-term<?)
+		       (lambda () null)))
+             
+	     ;; closure: LR1-item list -> LR1-item list
+	     ;; Creates a set of items containing i s.t. if A -> n.Xm is in it,
+	     ;; X -> .o is in it too.
+	     (LR0-closure
+	      (lambda (i)
+		(cond
+		 ((null? i) null)
+		 (else
+		  (let ((next-gsym (sym-at-dot (car i))))
+		    (cond
+		     ((non-term? next-gsym)
+		      (cons (car i)
+			    (append 
+			     (apply append
+				    (map (lambda (non-term) 
+					   (map (lambda (x) 
+						  (make-item x 0))
+						(send grammar 
+                                                      get-prods-for-non-term
+                                                      non-term)))
+					 (first-non-term next-gsym)))
+			     (LR0-closure (cdr i)))))
+		     (else
+		      (cons (car i) (LR0-closure (cdr i))))))))))
+
+
+	     ;; maps trans-keys to kernels
+	     (automaton-term null)
+             (automaton-non-term null)
+	     
+	     ;; keeps the kernels we have seen, so we can have a unique
+	     ;; list for each kernel
+	     (kernels (make-hash-table 'equal))
+
+	     (counter 0)
+	     
+	     ;; goto: LR1-item list -> LR1-item list list
+	     ;; creates new kernels by moving the dot in each item in the
+	     ;; LR0-closure of kernel to the right, and grouping them by 
+	     ;; the term/non-term moved over.  Returns the kernels not
+	     ;; yet seen, and places the trans-keys into automaton
+	     (goto
+	      (lambda (kernel)
+		(let (
+		      ;; maps a gram-syms to a list of items
+		      (table (make-hash-table))
+
+		      ;; add-item!: 
+		      ;;   (symbol (listof item) hashtable) item? ->
+		      ;; adds i into the table grouped with the grammar
+		      ;; symbol following its dot
+		      (add-item!
+		       (lambda (table i)
+			 (let ((gs (sym-at-dot i)))
+			   (cond
+			    (gs
+			     (let ((already 
+                                    (hash-table-get table
+                                                    (gram-sym-symbol gs)
+                                                    (lambda () null))))
+			       (unless (member i already)
+                                 (hash-table-put! table 
+                                                  (gram-sym-symbol gs)
+                                                  (cons i already)))))
+			    ((= 0 (vector-length (prod-rhs (item-prod i))))
+			     (let ((current (hash-table-get epsilons
+							    kernel
+							    (lambda () null))))
+			       (hash-table-put! epsilons
+						kernel
+						(cons i current)))))))))
+		  
+		  ;; Group the items of the LR0 closure of the kernel
+		  ;; by the character after the dot
+		  (for-each (lambda (item)
+			      (add-item! table item))
+			    (LR0-closure (kernel-items kernel)))
+		  
+		  ;; each group is a new kernel, with the dot advanced.
+		  ;; sorts the items in a kernel so kernels can be compared
+		  ;; with equal? for using the table kernels to make sure
+		  ;; only one representitive of each kernel is created
+		  (filter 
+		   (lambda (x) x)
+		   (map
+		    (lambda (i)
+		      (let* ((gs (car i))
+			     (items (cadr i))
+			     (new #f)
+			     (new-kernel (quicksort
+					  (filter (lambda (x) x)
+						  (map move-dot-right items))
+					  item<?))
+			     (unique-kernel (hash-table-get
+					     kernels
+					     new-kernel
+					     (lambda () 
+					       (let ((k (make-kernel
+							 new-kernel
+							 counter)))
+						 (set! new #t)
+						 (set! counter (add1 counter))
+						 (hash-table-put! kernels
+								  new-kernel
+								  k)
+						 k)))))
+                        (cond
+                          ((term? gs)
+                           (set! automaton-term (cons (cons (make-trans-key kernel gs)
+                                                            unique-kernel)
+                                                      automaton-term)))
+                          (else
+                           (set! automaton-non-term (cons (cons (make-trans-key kernel gs)
+                                                                unique-kernel)
+                                                          automaton-non-term))))
+                        #;(printf "~a -> ~a on ~a~n" 
+ 				(kernel->string kernel)
+ 				(kernel->string unique-kernel)
+				(gram-sym-symbol gs))
+			(if new
+			    unique-kernel
+			    #f)))
+		    (let loop ((gsyms grammar-symbols))
+		      (cond
+                        ((null? gsyms) null)
+                        (else
+                         (let ((items (hash-table-get table
+                                                      (gram-sym-symbol (car gsyms))
+                                                      (lambda () null))))
+                           (cond
+                             ((null? items) (loop (cdr gsyms)))
+                             (else
+                              (cons (list (car gsyms) items)
+                                    (loop (cdr gsyms))))))))))))))
+			
+             (starts 
+              (map (lambda (init-prod) (list (make-item init-prod 0)))
+                   (send grammar get-init-prods)))
+	     (startk
+              (map (lambda (start)
+                     (let ((k (make-kernel start counter)))
+                       (hash-table-put! kernels start k)
+                       (set! counter (add1 counter))
+                       k))
+                   starts))
+	     (new-kernels (make-queue)))
+
+      (let loop ((old-kernels startk)
+		 (seen-kernels null))
+	(cond
+	 ((and (empty-queue? new-kernels) (null? old-kernels))
+	  (make-object lr0% 
+		       automaton-term
+		       automaton-non-term		       
+		       (list->vector (reverse! seen-kernels))
+		       epsilons))
+	 ((null? old-kernels)
+	  (loop (deq! new-kernels) seen-kernels))
+	 (else 
+	  (enq! new-kernels (goto (car old-kernels)))
+	  (loop (cdr old-kernels) (cons (car old-kernels) seen-kernels)))))))
+
+  (define-struct q (f l) (make-inspector))
+  (define (empty-queue? q)
+    (null? (q-f q)))
+  (define (make-queue)
+    (make-q null null))
+  (define (enq! q i)
+    (if (empty-queue? q)
+	(let ((i (list i)))
+	  (set-q-l! q i)
+	  (set-q-f! q i))
+	(begin
+	  (set-cdr! (q-l q) (list i))
+	  (set-q-l! q (cdr (q-l q))))))
+  (define (deq! q)
+    (begin0
+     (car (q-f q))
+     (set-q-f! q (cdr (q-f q)))))
+
+)
\ No newline at end of file
diff --git a/collects/parser-tools/private-yacc/parser-actions.ss b/collects/parser-tools/private-yacc/parser-actions.ss
new file mode 100644
index 0000000000..b06a4e4719
--- /dev/null
+++ b/collects/parser-tools/private-yacc/parser-actions.ss
@@ -0,0 +1,54 @@
+(module parser-actions mzscheme
+  (require "grammar.ss")
+  (provide (all-defined-except make-reduce make-reduce*)
+           (rename make-reduce* make-reduce))
+
+  ;; An action is 
+  ;;  - (make-shift int)
+  ;;  - (make-reduce prod runtime-action)
+  ;;  - (make-accept)
+  ;;  - (make-goto int)
+  ;;  - (no-action)
+  ;; A reduce contains a runtime-reduce so that sharing of the reduces can
+  ;; be easily transferred to sharing of runtime-reduces.
+  
+  (define-struct action () (make-inspector))
+  (define-struct (shift action) (state) (make-inspector))
+  (define-struct (reduce action) (prod runtime-reduce) (make-inspector))
+  (define-struct (accept action) () (make-inspector))
+  (define-struct (goto action) (state) (make-inspector))
+  (define-struct (no-action action) () (make-inspector))
+  
+  (define (make-reduce* p)
+    (make-reduce p
+                 (vector (prod-index p)
+                         (gram-sym-symbol (prod-lhs p))
+                         (vector-length (prod-rhs p)))))
+
+  ;; A runtime-action is
+  ;; non-negative-int        (shift)
+  ;; (vector int symbol int) (reduce)
+  ;; 'accept                 (accept)
+  ;; negative-int            (goto)
+  ;; #f                      (no-action)
+  
+  (define (action->runtime-action a)
+    (cond
+      ((shift? a) (shift-state a))
+      ((reduce? a) (reduce-runtime-reduce a))
+      ((accept? a) 'accept)
+      ((goto? a) (- (+ (goto-state a) 1)))
+      ((no-action? a) #f)))
+  
+  (define (runtime-shift? x) (and (integer? x) (>= x 0)))
+  (define runtime-reduce? vector?)
+  (define (runtime-accept? x) (eq? x 'accept))
+  (define (runtime-goto? x) (and (integer? x) (< x 0)))
+
+  (define runtime-shift-state values) 
+  (define (runtime-reduce-prod-num x) (vector-ref x 0))
+  (define (runtime-reduce-lhs x) (vector-ref x 1))
+  (define (runtime-reduce-rhs-length x) (vector-ref x 2))
+  (define (runtime-goto-state x) (- (+ x 1)))
+
+  )
diff --git a/collects/parser-tools/private-yacc/parser-builder.ss b/collects/parser-tools/private-yacc/parser-builder.ss
new file mode 100644
index 0000000000..467fa048e1
--- /dev/null
+++ b/collects/parser-tools/private-yacc/parser-builder.ss
@@ -0,0 +1,109 @@
+(module parser-builder mzscheme
+  
+  (require "input-file-parser.ss"
+           "grammar.ss"
+           "table.ss"
+           (lib "class.ss")
+           (lib "contract.ss"))
+  (require-for-template mzscheme)
+  
+  (provide/contract
+   (build-parser ((string? any/c any/c (listof identifier?) (listof identifier?)
+                  (listof identifier?) (union syntax? false/c) syntax?) . ->* .
+                 (any/c any/c any/c any/c))))
+  
+  ;; fix-check-syntax : (listof identifier?) (listof identifier?) (listof identifier?)
+  ;;                    (union syntax? false/c) syntax?) -> syntax?
+  (define (fix-check-syntax input-terms start ends assocs prods)
+    (let* ((term-binders (get-term-list input-terms))
+           (get-term-binder
+            (let ((t (make-hash-table)))
+              (for-each 
+               (lambda (term)
+                 (hash-table-put! t (syntax-e term) term))
+               term-binders)
+              (lambda (x)
+                (let ((r (hash-table-get t (syntax-e x) (lambda () #f))))
+                  (if r
+                      (syntax-local-introduce (datum->syntax-object r (syntax-e x) x x))
+                      x)))))
+           (rhs-list
+            (syntax-case prods ()
+              (((_ rhs ...) ...)
+               (syntax->list (syntax (rhs ... ...)))))))
+      (with-syntax (((tmp ...) (map syntax-local-introduce term-binders))
+                    ((term-group ...)
+                     (map (lambda (tg)
+                            (syntax-property
+                             (datum->syntax-object tg #f)
+                             'disappeared-use
+                             tg))
+                          input-terms))
+                    ((end ...)
+                     (map get-term-binder ends))
+                    ((start ...)
+                     (map get-term-binder start))
+                    ((bind ...)
+                     (syntax-case prods ()
+                       (((bind _ ...) ...)
+                        (syntax->list (syntax (bind ...))))))
+                    (((bound ...) ...)
+                     (map
+                      (lambda (rhs)
+                        (syntax-case rhs ()
+                          (((bound ...) (_ pbound) __)
+                           (map get-term-binder
+                                (cons (syntax pbound)
+                                      (syntax->list (syntax (bound ...))))))
+                          (((bound ...) _)
+                           (map get-term-binder
+                                (syntax->list (syntax (bound ...)))))))
+                      rhs-list))
+                    ((prec ...)
+                     (if assocs
+                         (map get-term-binder
+                              (syntax-case assocs ()
+                                (((__ term ...) ...)
+                                 (syntax->list (syntax (term ... ...))))))
+                         null)))
+        #`(when #f
+            (let ((bind void) ... (tmp void) ...)
+              (void bound ... ... term-group ... start ... end ... prec ...))))))
+  (require (lib "list.ss") "parser-actions.ss")
+  (define (build-parser filename src-pos suppress input-terms start end assocs prods)
+    (let* ((grammar (parse-input input-terms start end assocs prods src-pos))
+           (table (build-table grammar filename suppress))
+           (all-tokens (make-hash-table))
+           (actions-code
+            `(vector ,@(map prod-action (send grammar get-prods)))))
+      (for-each (lambda (term)
+                  (hash-table-put! all-tokens (gram-sym-symbol term) #t))
+                (send grammar get-terms))
+      #;(let ((num-states (vector-length table))
+            (num-gram-syms (+ (send grammar get-num-terms)
+                              (send grammar get-num-non-terms)))
+            (num-ht-entries (apply + (map length (vector->list table))))
+            (num-reduces
+             (let ((ht (make-hash-table)))
+               (for-each
+                (lambda (x)
+                  (when (reduce? x)
+                    (hash-table-put! ht x #t)))
+                (map cdr (apply append (vector->list table))))
+               (length (hash-table-map ht void)))))
+        (printf "~a states, ~a grammar symbols, ~a hash-table entries, ~a reduces~n"
+                num-states num-gram-syms num-ht-entries num-reduces)
+        (printf "~a -- ~aKB, previously ~aKB~n"
+                (/ (+ 2 num-states
+                      (* 4 num-states) (* 2 1.5 num-ht-entries)
+                      (* 5 num-reduces)) 256.0)
+                (/ (+ 2 num-states
+                      (* 4 num-states) (* 2 2.3 num-ht-entries)
+                      (* 5 num-reduces)) 256.0)
+                (/ (+ 2 (* num-states num-gram-syms) (* 5 num-reduces)) 256.0)))
+      (values table
+              all-tokens
+              actions-code
+              (fix-check-syntax input-terms start end assocs prods))))
+      
+  )
diff --git a/collects/parser-tools/private-yacc/table.ss b/collects/parser-tools/private-yacc/table.ss
new file mode 100644
index 0000000000..be96a2abf9
--- /dev/null
+++ b/collects/parser-tools/private-yacc/table.ss
@@ -0,0 +1,289 @@
+(module table mzscheme
+
+  ;; Routine to build the LALR table
+  
+  (require "grammar.ss"
+	   "lr0.ss"
+	   "lalr.ss"
+	   "parser-actions.ss"
+	   (lib "contract.ss")
+           (lib "list.ss")
+	   (lib "class.ss"))
+
+  (provide/contract 
+   (build-table ((is-a?/c grammar%) string? any/c . -> .
+                 (vectorof (listof (cons/c (union term? non-term?) action?))))))
+
+  ;; A parse-table is (vectorof (listof (cons/c gram-sym? action)))
+  ;; A grouped-parse-table is (vectorof (listof (cons/c gram-sym? (listof action))))
+  
+  ;; make-parse-table : int -> parse-table
+  (define (make-parse-table num-states)
+    (make-vector num-states null))
+  
+  ;; table-add!: parse-table nat symbol action ->
+  (define (table-add! table state-index symbol val)
+    (vector-set! table state-index (cons (cons symbol val)
+                                         (vector-ref table state-index))))
+  
+  ;; group-table : parse-table -> grouped-parse-table
+  (define (group-table table)
+    (list->vector
+     (map
+      (lambda (state-entry)
+        (let ((ht (make-hash-table 'equal)))
+          (for-each
+           (lambda (gs/actions)
+             (let ((group (hash-table-get ht (car gs/actions) (lambda () null))))
+               (unless (member (cdr gs/actions) group)
+                 (hash-table-put! ht (car gs/actions) (cons (cdr gs/actions) group)))))
+           state-entry)
+          (hash-table-map ht cons)))
+      (vector->list table))))
+  
+  ;; table-map : (vectorof (listof (cons/c gram-sym? X))) (gram-sym? X -> Y) ->
+  ;;             (vectorof (listof (cons/c gram-sym? Y)))
+  (define (table-map f table)
+    (list->vector
+     (map
+      (lambda (state-entry)
+        (map
+         (lambda (gs/X)
+           (cons (car gs/X) (f (car gs/X) (cdr gs/X))))
+         state-entry))
+      (vector->list table))))
+  
+  
+  (define (bit-vector-for-each f bv)
+    (letrec ((for-each
+              (lambda (bv number)
+                (cond
+                  ((= 0 bv) (void))
+                  ((= 1 (bitwise-and 1 bv))
+                   (f number)
+                   (for-each (arithmetic-shift bv -1) (add1 number)))
+                  (else (for-each (arithmetic-shift bv -1) (add1 number)))))))
+      (for-each bv 0)))
+                   
+  
+  ;; print-entry: symbol action output-port ->
+  ;; prints the action a for lookahead sym to the given port
+  (define (print-entry sym a port)
+    (let ((s "\t~a\t\t\t\t\t~a\t~a\n"))
+      (cond
+       ((shift? a)
+	(fprintf port s sym "shift" (shift-state a)))
+       ((reduce? a)
+	(fprintf port s sym "reduce" (prod-index (reduce-prod a))))
+       ((accept? a)
+	(fprintf port s sym "accept" ""))
+       ((goto? a)
+	(fprintf port s sym "goto" (goto-state a))))))
+
+
+  ;; count: ('a -> bool) * 'a list -> num
+  ;; counts the number of elements in list that satisfy pred
+  (define (count pred list)
+    (cond
+     ((null? list) 0)
+     ((pred (car list)) (+ 1 (count pred (cdr list))))
+     (else (count pred (cdr list)))))
+
+  ;; display-parser: LR0-automaton grouped-parse-table (listof prod?) output-port ->
+  ;; Prints out the parser given by table.
+  (define (display-parser a grouped-table prods port)
+    (let* ((SR-conflicts 0)
+	   (RR-conflicts 0))
+      (for-each
+       (lambda (prod)
+         (fprintf port 
+                  "~a\t~a\t=\t~a~n" 
+                  (prod-index prod)
+                  (gram-sym-symbol (prod-lhs prod))
+                  (map gram-sym-symbol (vector->list (prod-rhs prod)))))
+       prods)
+      (send a for-each-state
+        (lambda (state)
+          (fprintf port "State ~a~n" (kernel-index state))
+          (for-each (lambda (item)
+                      (fprintf port "\t~a~n" (item->string item)))
+                    (kernel-items state))
+          (newline port)
+          (for-each
+           (lambda (gs/action)
+             (let ((sym (gram-sym-symbol (car gs/action)))
+                   (act (cdr gs/action)))
+              (cond
+                ((null? act) (void))
+                ((null? (cdr act))
+                 (print-entry sym (car act) port))
+                (else
+                 (fprintf port "begin conflict:~n")
+                 (if (> (count reduce? act) 1)
+                     (set! RR-conflicts (add1 RR-conflicts)))
+                 (if (> (count shift? act) 0)
+                     (set! SR-conflicts (add1 SR-conflicts)))
+                 (map (lambda (x) (print-entry sym x port)) act)
+                 (fprintf port "end conflict~n")))))
+           (vector-ref grouped-table (kernel-index state)))
+          (newline port)))
+      
+      (when (> SR-conflicts 0)
+        (fprintf port "~a shift/reduce conflicts~n" SR-conflicts))
+      (when (> RR-conflicts 0)
+        (fprintf port "~a reduce/reduce conflicts~n" RR-conflicts))))
+  
+  ;; resolve-conflict : (listof action?) -> action? bool bool
+  (define (resolve-conflict actions)
+    (cond
+      ((null? actions) (values (make-no-action) #f #f))
+      ((null? (cdr actions))
+       (values (car actions) #f #f))
+      (else
+       (let ((SR-conflict? (> (count shift? actions) 0))
+             (RR-conflict? (> (count reduce? actions) 1)))
+         (let loop ((current-guess #f)
+                    (rest actions))
+           (cond
+             ((null? rest) (values current-guess SR-conflict? RR-conflict?))
+             ((shift? (car rest)) (values (car rest) SR-conflict? RR-conflict?))
+             ((not current-guess)
+              (loop (car rest) (cdr rest)))
+             ((and (reduce? (car rest))
+                   (< (prod-index (reduce-prod (car rest)))
+                      (prod-index (reduce-prod current-guess))))
+              (loop (car rest) (cdr rest)))
+             ((accept? (car rest))
+              (fprintf (current-error-port) 
+                       "accept/reduce or accept/shift conflicts.  Check the grammar for useless cycles of productions~n")
+              (loop current-guess (cdr rest)))
+             (else (loop current-guess (cdr rest)))))))))
+  
+  ;; resolve-conflicts : grouped-parse-table bool -> parse-table
+  (define (resolve-conflicts grouped-table suppress)
+    (let* ((SR-conflicts 0)
+           (RR-conflicts 0)
+           (table (table-map
+                   (lambda (gs actions)
+                     (let-values (((action SR? RR?)
+                                   (resolve-conflict actions)))
+                       (when SR?
+                         (set! SR-conflicts (add1 SR-conflicts)))
+                       (when RR?
+                         (set! RR-conflicts (add1 RR-conflicts)))
+                       action))
+                   grouped-table)))
+      (unless suppress
+        (when (> SR-conflicts 0)
+          (fprintf (current-error-port) 
+                   "~a shift/reduce conflicts~n" 
+                   SR-conflicts))
+        (when (> RR-conflicts 0)
+          (fprintf (current-error-port)
+                   "~a reduce/reduce conflicts~n"
+                   RR-conflicts)))
+      table))
+  
+
+  ;; resolve-sr-conflict : (listof action) (union int #f) -> (listof action)
+  ;; Resolves a single shift-reduce conflict, if precedences are in place.
+  (define (resolve-sr-conflict/prec actions shift-prec)
+    (let* ((shift (if (shift? (car actions))
+                     (car actions)
+                     (cadr actions)))
+           (reduce (if (shift? (car actions))
+                       (cadr actions)
+                       (car actions)))
+           (reduce-prec (prod-prec (reduce-prod reduce))))
+      (cond
+        ((and shift-prec reduce-prec)
+         (cond
+           ((< (prec-num shift-prec) (prec-num reduce-prec))
+            (list reduce))
+           ((> (prec-num shift-prec) (prec-num reduce-prec))
+            (list shift))
+           ((eq? 'left (prec-assoc shift-prec))
+            (list reduce))
+           ((eq? 'right (prec-assoc shift-prec))
+            (list shift))
+           (else null)))
+        (else actions))))
+    
+  
+  ;; resolve-prec-conflicts : parse-table -> grouped-parse-table
+  (define (resolve-prec-conflicts table)
+    (table-map
+     (lambda (gs actions)
+       (cond
+         ((and (term? gs)
+               (= 2 (length actions))
+               (or (shift? (car actions))
+                   (shift? (cadr actions))))
+          (resolve-sr-conflict/prec actions (term-prec gs)))
+         (else actions)))
+     (group-table table)))
+                        
+  ;; build-table: grammar string bool -> parse-table
+  (define (build-table g file suppress)
+    (let* ((a (build-lr0-automaton g))
+           (term-vector (list->vector (send g get-terms)))
+           (end-terms (send g get-end-terms))
+           (table (make-parse-table (send a get-num-states)))
+           (get-lookahead (compute-LA a g))
+           (reduce-cache (make-hash-table 'equal)))
+
+      (for-each
+       (lambda (trans-key/state)
+         (let ((from-state-index (kernel-index (trans-key-st (car trans-key/state))))
+               (gs (trans-key-gs (car trans-key/state)))
+               (to-state (cdr trans-key/state)))
+           (table-add! table from-state-index gs
+                       (cond
+                         ((non-term? gs)
+                          (make-goto (kernel-index to-state)))
+                         ((member gs end-terms)
+                          (make-accept))
+                         (else
+                          (make-shift 
+                           (kernel-index to-state)))))))
+       (send a get-transitions))
+
+      (send a for-each-state
+        (lambda (state)
+          (for-each
+           (lambda (item)
+             (let ((item-prod (item-prod item)))
+               (bit-vector-for-each 
+                (lambda (term-index)
+                  (unless (start-item? item)
+                    (let ((r (hash-table-get reduce-cache item-prod
+                                             (lambda ()
+                                               (let ((r (make-reduce item-prod)))
+                                                 (hash-table-put! reduce-cache item-prod r)
+                                                 r)))))
+                      (table-add! table
+                                  (kernel-index state)
+                                  (vector-ref term-vector term-index)
+                                  r))))
+                (get-lookahead state item-prod))))
+           (append (hash-table-get (send a get-epsilon-trans) state (lambda () null))
+                   (filter (lambda (item)
+                             (not (move-dot-right item)))
+                           (kernel-items state))))))
+      
+      (let ((grouped-table (resolve-prec-conflicts table)))
+        (unless (string=? file "")
+          (with-handlers [(exn:fail:filesystem?
+                           (lambda (e)
+                             (fprintf 
+                              (current-error-port)
+                              "Cannot write debug output to file \"~a\".~n"
+                              file)))]
+            (call-with-output-file file
+              (lambda (port)
+                (display-parser a grouped-table (send g get-prods) port)))))
+        (resolve-conflicts grouped-table suppress))))
+  
+  )
+
+
diff --git a/collects/parser-tools/private-yacc/yacc-helper.ss b/collects/parser-tools/private-yacc/yacc-helper.ss
new file mode 100644
index 0000000000..4ffc0073f6
--- /dev/null
+++ b/collects/parser-tools/private-yacc/yacc-helper.ss
@@ -0,0 +1,118 @@
+(module yacc-helper mzscheme
+
+  (require (lib "list.ss")
+           "../private-lex/token-syntax.ss")
+  
+  ;; General helper routines
+  
+  (provide duplicate-list? remove-duplicates overlap? vector-andmap display-yacc)
+  
+  (define (vector-andmap f v)
+    (let loop ((i 0))
+      (cond
+       ((= i (vector-length v)) #t)
+       (else (if (f (vector-ref v i))
+		 (loop (add1 i))
+		 #f)))))
+
+  ;; duplicate-list?: symbol list -> #f | symbol
+  ;; returns a symbol that exists twice in l, or false if no such symbol 
+  ;; exists
+  (define (duplicate-list? l)
+    (letrec ((t (make-hash-table))
+	     (dl? (lambda (l)
+		    (cond
+		     ((null? l) #f)
+		     ((hash-table-get t (car l) (lambda () #f)) => 
+		      (lambda (x) x))
+		     (else
+		      (hash-table-put! t (car l) (car l))
+		      (dl? (cdr l)))))))
+      (dl? l)))
+
+  ;; remove-duplicates: syntax-object list -> syntax-object list
+  ;; removes the duplicates from the lists
+  (define (remove-duplicates sl)
+    (let ((t (make-hash-table)))
+      (letrec ((x
+		(lambda (sl)
+		  (cond
+		   ((null? sl) sl)
+		   ((hash-table-get t (syntax-object->datum (car sl)) (lambda () #f))
+		    (x (cdr sl)))
+		   (else 
+		    (hash-table-put! t (syntax-object->datum (car sl)) #t)
+		    (cons (car sl) (x (cdr sl))))))))
+	(x sl))))
+
+  ;; overlap?: symbol list * symbol list -> #f | symbol
+  ;; Returns an symbol in l1 intersect l2, or #f is no such symbol exists
+  (define (overlap? l1 l2)
+    (let/ec ret
+      (let ((t (make-hash-table)))
+	(for-each (lambda (s1)
+		    (hash-table-put! t s1 s1))
+		  l1)
+	(for-each (lambda (s2)
+		    (cond 
+		     ((hash-table-get t s2 (lambda () #f)) =>
+		      (lambda (o) (ret o)))))
+		  l2)
+	#f)))
+
+  
+  (define (display-yacc grammar tokens start precs port)
+    (let-syntax ((p (syntax-rules ()
+                      ((_ args ...) (fprintf port args ...)))))
+      (let* ((tokens (map syntax-local-value tokens))
+             (eterms (filter e-terminals-def? tokens))
+             (terms (filter terminals-def? tokens))
+             (term-table (make-hash-table))
+             (display-rhs
+              (lambda (rhs)
+                (for-each (lambda (sym) (p "~a " (hash-table-get term-table sym (lambda () sym))))
+                          (car rhs))
+                (if (= 3 (length rhs))
+                    (p "%prec ~a" (cadadr rhs)))
+                (p "~n"))))
+        (for-each
+         (lambda (t)
+           (for-each
+            (lambda (t)
+              (hash-table-put! term-table t (format "'~a'" t)))
+            (syntax-object->datum (e-terminals-def-t t))))
+         eterms)
+        (for-each
+         (lambda (t)
+           (for-each
+            (lambda (t)
+              (p "%token ~a~n" t)
+              (hash-table-put! term-table t (format "~a" t)))
+            (syntax-object->datum (terminals-def-t t))))
+         terms)
+        (if precs
+            (for-each (lambda (prec)
+                        (p "%~a " (car prec))
+                        (for-each (lambda (tok)
+                                    (p " ~a" (hash-table-get term-table tok)))
+                                  (cdr prec))
+                        (p "~n"))
+                      precs))
+        (p "%start ~a~n" start)
+        (p "%%~n")
+
+        (for-each (lambda (prod)
+                    (let ((nt (car prod)))
+                      (p "~a: " nt)
+                      (display-rhs (cadr prod))
+                      (for-each (lambda (rhs)
+                                  (p "| ")
+                                  (display-rhs rhs))
+                                (cddr prod))
+                      (p ";~n")))
+          grammar)
+        (p "%%~n"))))
+  
+
+)  
+  
diff --git a/collects/parser-tools/yacc-to-scheme.ss b/collects/parser-tools/yacc-to-scheme.ss
new file mode 100644
index 0000000000..1e6eaca538
--- /dev/null
+++ b/collects/parser-tools/yacc-to-scheme.ss
@@ -0,0 +1,135 @@
+(module yacc-to-scheme mzscheme
+  (require (lib "lex.ss" "parser-tools")
+           (prefix : (lib "lex-sre.ss" "parser-tools"))
+           (lib "yacc.ss" "parser-tools")
+           (lib "readerr.ss" "syntax")
+           (lib "list.ss"))
+  (provide trans)
+  
+  (define match-double-string
+    (lexer
+     ((:* (:~ #\" #\\)) (append (string->list lexeme)
+                                (match-double-string input-port)))
+     ((:: #\\ any-char) (cons (string-ref lexeme 1) (match-double-string input-port)))
+     (#\" null)))
+
+   (define match-single-string
+    (lexer
+     ((:* (:~ #\' #\\)) (append (string->list lexeme)
+                                (match-single-string input-port)))
+     ((:: #\\ any-char) (cons (string-ref lexeme 1) (match-single-string input-port)))
+     (#\' null)))
+  
+  (define-lex-abbrevs
+   (letter (:or (:/ "a" "z") (:/ "A" "Z")))
+   (digit (:/ "0" "9"))
+   (initial (:or letter (char-set "!$%&*/<=>?^_~@")))
+   (subsequent (:or initial digit (char-set "+-.@")))
+   (comment (:: "/*" (complement (:: any-string "*/" any-string)) "*/")))
+
+  (define-empty-tokens x
+    (EOF PIPE |:| SEMI |%%| %prec))
+  (define-tokens y
+    (SYM STRING))
+  
+  (define get-token-grammar
+    (lexer-src-pos
+     ("%%" '|%%|)
+     (":" (string->symbol lexeme))
+     ("%prec" (string->symbol lexeme))
+     (#\| 'PIPE)
+     ((:+ (:or #\newline #\tab " " comment (:: "{" (:* (:~ "}")) "}")))
+      (return-without-pos (get-token-grammar input-port)))
+     (#\; 'SEMI)
+     (#\' (token-STRING (string->symbol (list->string (match-single-string input-port)))))
+     (#\" (token-STRING (string->symbol (list->string (match-double-string input-port)))))
+     ((:: initial (:* subsequent)) (token-SYM (string->symbol lexeme)))))
+
+  (define (parse-grammar enter-term enter-empty-term enter-non-term)
+    (parser
+     (tokens x y)
+     (src-pos)
+     (error (lambda (tok-ok tok-name tok-value start-pos end-pos)
+	      (raise-read-error
+	       (format "Error Parsing YACC grammar at token: ~a with value: ~a" tok-name tok-value)
+	       (file-path)
+	       (position-line start-pos)
+	       (position-col start-pos)
+	       (position-offset start-pos)
+	       (- (position-offset end-pos) (position-offset start-pos)))))
+	       
+     (end |%%|)
+     (start gram)
+     (grammar
+      (gram 
+       ((production) (list $1))
+       ((production gram) (cons $1 $2)))
+      (production
+       ((SYM |:| prods SEMI) 
+        (begin
+          (enter-non-term $1)
+          (cons $1 $3))))
+      (prods
+       ((rhs) (list `(,$1 #f)))
+       ((rhs prec) (list `(,$1 ,$2 #f)))
+       ((rhs PIPE prods) (cons `(,$1 #f) $3))
+       ((rhs prec PIPE prods) (cons `(,$1 ,$2 #f) $4)))
+      (prec
+       ((%prec SYM)
+        (begin
+          (enter-term $2)
+          (list 'prec $2)))
+       ((%prec STRING)
+        (begin
+          (enter-empty-term $2)
+          (list 'prec $2))))
+      (rhs
+       (() null)
+       ((SYM rhs) 
+	(begin
+	  (enter-term $1)
+	  (cons $1 $2)))
+       ((STRING rhs) 
+	(begin
+	  (enter-empty-term $1)
+	  (cons $1 $2)))))))
+  
+  (define (symbol<? a b)
+    (string<? (symbol->string a) (symbol->string b)))
+  
+  (define (trans filename)
+    (let* ((i (open-input-file filename))
+           (terms (make-hash-table))
+           (eterms (make-hash-table))
+           (nterms (make-hash-table))
+           (enter-term
+            (lambda (s)
+              (if (not (hash-table-get nterms s (lambda () #f)))
+                  (hash-table-put! terms s #t))))
+           (enter-empty-term
+            (lambda (s)
+              (if (not (hash-table-get nterms s (lambda () #f)))
+                  (hash-table-put! eterms s #t))))
+           (enter-non-term
+            (lambda (s)
+	     (hash-table-remove! terms s)
+              (hash-table-remove! eterms s)
+              (hash-table-put! nterms s #t))))
+      (port-count-lines! i)
+      (file-path filename)
+      (regexp-match "%%" i)
+      (begin0
+       (let ((gram ((parse-grammar enter-term enter-empty-term enter-non-term)
+		    (lambda () 
+		      (let ((t (get-token-grammar i)))
+			t)))))
+          `(begin
+             (define-tokens t ,(quicksort (hash-table-map terms (lambda (k v) k)) symbol<?))
+             (define-empty-tokens et ,(quicksort (hash-table-map eterms (lambda (k v) k)) symbol<?))
+             (parser
+              (start ___)
+              (end ___)
+              (error ___)
+              (tokens t et)
+              (grammar ,@gram))))
+            (close-input-port i)))))
diff --git a/collects/parser-tools/yacc.ss b/collects/parser-tools/yacc.ss
new file mode 100644
index 0000000000..2929054602
--- /dev/null
+++ b/collects/parser-tools/yacc.ss
@@ -0,0 +1,381 @@
+(module yacc mzscheme
+  
+  (require-for-syntax "private-yacc/parser-builder.ss"
+                      "private-yacc/grammar.ss"
+                      "private-yacc/yacc-helper.ss"
+                      "private-yacc/parser-actions.ss")
+  (require "private-lex/token.ss"
+           "private-yacc/parser-actions.ss"
+           (lib "etc.ss")
+           (lib "pretty.ss")
+	   (lib "readerr.ss" "syntax"))
+  
+  (provide parser)
+  
+    
+  ;; convert-parse-table : (vectorof (listof (cons/c gram-sym? action?))) ->
+  ;;                       (vectorof (symbol runtime-action hashtable))
+  (define-for-syntax (convert-parse-table table)
+    (list->vector
+     (map
+      (lambda (state-entry)
+        (let ((ht (make-hash-table)))
+          (for-each
+           (lambda (gs/action)
+             (hash-table-put! ht
+                              (gram-sym-symbol (car gs/action))
+                              (action->runtime-action (cdr gs/action))))
+           state-entry)
+          ht))
+      (vector->list table))))
+  
+  (define-syntax (parser stx)
+    (syntax-case stx ()
+      ((_ args ...)
+       (let ((arg-list (syntax->list (syntax (args ...))))
+             (src-pos #f)
+             (debug #f)
+             (error #f)
+             (tokens #f)
+             (start #f)
+             (end #f)
+             (precs #f)
+             (suppress #f)
+             (grammar #f)
+             (yacc-output #f))
+         (for-each
+          (lambda (arg)
+            (syntax-case* arg (debug error tokens start end precs grammar
+                               suppress src-pos yacc-output)
+              (lambda (a b)
+                (eq? (syntax-e a) (syntax-e b)))
+              ((debug filename)
+               (cond
+                 ((not (string? (syntax-e (syntax filename))))
+                  (raise-syntax-error 
+                   #f
+                   "Debugging filename must be a string"
+                   stx
+                   (syntax filename)))
+                 (debug
+                  (raise-syntax-error #f "Multiple debug declarations" stx))
+                 (else
+                  (set! debug (syntax-e (syntax filename))))))
+              ((suppress)
+               (set! suppress #t))
+              ((src-pos)
+               (set! src-pos #t))
+              ((error expression)
+               (if error
+                   (raise-syntax-error #f "Multiple error declarations" stx)
+                   (set! error (syntax expression))))
+              ((tokens def ...)
+               (begin
+                 (when tokens
+                   (raise-syntax-error  #f "Multiple tokens declarations" stx))
+                 (let ((defs (syntax->list (syntax (def ...)))))
+                   (for-each 
+                    (lambda (d)
+                      (unless (identifier? d)
+                        (raise-syntax-error 
+                         #f 
+                         "Token-group name must be an identifier"
+                         stx
+                         d)))
+                    defs)
+                   (set! tokens defs))))
+              ((start symbol ...)
+               (let ((symbols (syntax->list (syntax (symbol ...)))))
+                 (for-each
+                  (lambda (sym)
+                    (unless (identifier? sym)
+                      (raise-syntax-error #f
+                                          "Start symbol must be a symbol"
+                                          stx
+                                          sym)))
+                  symbols)
+                 (when start
+                   (raise-syntax-error #f "Multiple start declarations" stx))
+                 (when (null? symbols)
+                   (raise-syntax-error #f
+                                       "Missing start symbol"
+                                       stx
+                                       arg))
+                 (set! start symbols)))
+              ((end symbols ...)
+               (let ((symbols (syntax->list (syntax (symbols ...)))))
+                 (for-each
+                  (lambda (sym)
+                    (unless (identifier? sym)
+                      (raise-syntax-error #f
+                                          "End token must be a symbol"
+                                          stx
+                                          sym)))
+                  symbols)
+                 (let ((d (duplicate-list? (map syntax-e symbols))))
+                   (when d
+                     (raise-syntax-error
+                      #f
+                      (format "Duplicate end token definition for ~a" d)
+                      stx
+                      arg))
+                   (when (null? symbols)
+                     (raise-syntax-error
+                      #f
+                      "end declaration must contain at least 1 token"
+                      stx
+                      arg))
+                   (when end
+                     (raise-syntax-error #f "Multiple end declarations" stx))
+                   (set! end symbols))))
+              ((precs decls ...)
+               (if precs
+                   (raise-syntax-error #f "Multiple precs declarations" stx)
+                   (set! precs (syntax/loc arg (decls ...)))))
+              ((grammar prods ...)
+               (if grammar
+                   (raise-syntax-error #f "Multiple grammar declarations" stx)
+                   (set! grammar (syntax/loc arg (prods ...)))))
+              ((yacc-output filename)
+               (cond
+                 ((not (string? (syntax-e (syntax filename))))
+                  (raise-syntax-error #f
+                                      "Yacc-output filename must be a string"
+                                      stx
+                                      (syntax filename)))
+                 (yacc-output
+                  (raise-syntax-error #f "Multiple yacc-output declarations" stx))
+                 (else
+                  (set! yacc-output (syntax-e (syntax filename))))))
+              (_ (raise-syntax-error #f "argument must match (debug filename), (error expression), (tokens def ...), (start non-term), (end tokens ...), (precs decls ...), or  (grammar prods ...)" stx arg))))
+          (syntax->list (syntax (args ...))))
+         (unless tokens
+           (raise-syntax-error #f "missing tokens declaration" stx))
+         (unless error
+           (raise-syntax-error #f "missing error declaration" stx))
+         (unless grammar
+           (raise-syntax-error #f "missing grammar declaration" stx))
+         (unless end
+           (raise-syntax-error #f "missing end declaration" stx))
+         (unless start
+           (raise-syntax-error #f "missing start declaration" stx))
+         (let-values (((table all-term-syms actions check-syntax-fix)
+                       (build-parser (if debug debug "")
+                                     src-pos
+                                     suppress
+                                     tokens
+                                     start
+                                     end
+                                     precs
+                                     grammar)))
+           (when (and yacc-output (not (string=? yacc-output "")))
+             (with-handlers [(exn:fail:filesystem?
+                              (lambda (e)
+                                (fprintf 
+                                 (current-error-port)
+                                 "Cannot write yacc-output to file \"~a\"~n"
+                                 yacc-output)))]
+               (call-with-output-file yacc-output
+                 (lambda (port)
+                   (display-yacc (syntax-object->datum grammar) 
+                                 tokens 
+                                 (map syntax-object->datum start)
+                                 (if precs
+                                     (syntax-object->datum precs)
+                                     #f)
+                                 port)))))
+           (with-syntax ((check-syntax-fix check-syntax-fix)
+                         (err error)
+                         (ends end)
+                         (starts start)
+                         (debug debug)
+                         (table (convert-parse-table table))
+                         (all-term-syms all-term-syms)
+                         (actions actions)
+                         (src-pos src-pos))
+             (syntax
+              (begin
+                check-syntax-fix
+                (parser-body debug err (quote starts) (quote ends) table all-term-syms actions src-pos)))))))
+      (_
+       (raise-syntax-error #f
+                           "parser must have the form (parser args ...)"
+                           stx))))
+  
+  (define (reduce-stack stack num ret-vals src-pos)
+    (cond
+      ((> num 0)
+       (let* ((top-frame (car stack))
+              (ret-vals
+               (if src-pos
+                   (cons (stack-frame-value top-frame)
+                         (cons (stack-frame-start-pos top-frame)
+                               (cons (stack-frame-end-pos top-frame)
+                                     ret-vals)))
+                   (cons (stack-frame-value top-frame) ret-vals))))
+         (reduce-stack (cdr stack) (sub1 num) ret-vals src-pos)))
+      (else (values stack ret-vals))))
+  
+  ;; extract-helper : (symbol or make-token) any any -> symbol any any any
+  (define (extract-helper tok v1 v2)
+    (cond
+      ((symbol? tok)
+       (values tok #f v1 v2))
+      ((token? tok)
+       (values (real-token-name tok) (real-token-value tok) v1 v2))
+      (else (raise-type-error 'parser 
+                              "symbol or struct:token"
+                              0 
+                              tok))))
+  
+  ;; extract-src-pos : position-token -> symbol any any any
+  (define (extract-src-pos ip)
+    (cond
+      ((position-token? ip)
+       (extract-helper (position-token-token ip)
+                       (position-token-start-pos ip)
+                       (position-token-end-pos ip)))
+      (else
+       (raise-type-error 'parser 
+                         "struct:position-token"
+                         0
+                         ip))))
+  
+  ;; extract-no-src-pos : (symbol or make-token) -> symbol any any any
+  (define (extract-no-src-pos ip)
+    (extract-helper ip #f #f))
+  
+  (define-struct stack-frame (state value start-pos end-pos) (make-inspector))
+  
+  (define (make-empty-stack i) (list (make-stack-frame i #f #f #f)))
+  
+  
+  ;; The table is a vector that maps each state to a hash-table that maps a
+  ;; terminal symbol to either an accept, shift, reduce, or goto structure.
+  ;  We encode the structures according to the runtime-action data definition in
+  ;; parser-actions.ss
+  (define (parser-body debug? err starts ends table all-term-syms actions src-pos)
+    (local ((define extract
+              (if src-pos
+                  extract-src-pos
+                  extract-no-src-pos))
+            
+            (define (fix-error stack tok val start-pos end-pos get-token)
+              (when debug? (pretty-print stack))
+              (local ((define (remove-input tok val start-pos end-pos)
+                        (if (memq tok ends)
+                            (raise-read-error "parser: Cannot continue after error"
+                                              #f #f #f #f #f)
+                            (let ((a (find-action stack tok val start-pos end-pos)))
+                              (cond
+                                ((runtime-shift? a)
+                                 ;; (printf "shift:~a~n" (runtime-shift-state a))
+                                 (cons (make-stack-frame (runtime-shift-state a)
+                                                         val
+                                                         start-pos
+                                                         end-pos)
+                                       stack))
+                                (else
+                                 ;; (printf "discard input:~a~n" tok)
+                                 (let-values (((tok val start-pos end-pos)
+                                               (extract (get-token))))
+                                   (remove-input tok val start-pos end-pos))))))))
+                (let remove-states ()
+                  (let ((a (find-action stack 'error #f start-pos end-pos)))
+                    (cond
+                      ((runtime-shift? a)
+                       ;; (printf "shift:~a~n" (runtime-shift-state a))
+                       (set! stack 
+                             (cons
+                              (make-stack-frame (runtime-shift-state a) 
+                                                #f 
+                                                start-pos
+                                                end-pos)
+                              stack))
+                       (remove-input tok val start-pos end-pos))
+                      (else
+                       ;; (printf "discard state:~a~n" (car stack))
+                       (cond
+                         ((< (length stack) 2)
+                          (raise-read-error "parser: Cannot continue after error"
+                                            #f #f #f #f #f))
+                         (else
+                          (set! stack (cdr stack))
+                          (remove-states)))))))))
+            
+            (define (find-action stack tok val start-pos end-pos)
+              (unless (hash-table-get all-term-syms
+                                      tok
+                                      (lambda () #f))
+                (if src-pos
+                    (err #f tok val start-pos end-pos)
+                    (err #f tok val))
+                (raise-read-error (format "parser: got token of unknown type ~a" tok)
+                                  #f #f #f #f #f))
+              (hash-table-get (vector-ref table (stack-frame-state (car stack)))
+                              tok
+                              (lambda () #f)))
+
+            (define (make-parser start-number)
+              (lambda (get-token)
+                (let parsing-loop ((stack (make-empty-stack start-number))
+                                   (ip (get-token)))
+                  (let-values (((tok val start-pos end-pos)
+                                (extract ip)))
+                    (let ((action (find-action stack tok val start-pos end-pos)))
+                      (cond
+                        ((runtime-shift? action)
+                         ;; (printf "shift:~a~n" (runtime-shift-state action))
+                         (parsing-loop (cons (make-stack-frame (runtime-shift-state action)
+                                                               val
+                                                               start-pos
+                                                               end-pos)
+                                             stack)
+                                       (get-token)))
+                        ((runtime-reduce? action)
+                         ;; (printf "reduce:~a~n" (runtime-reduce-prod-num action))
+                         (let-values (((new-stack args)
+                                       (reduce-stack stack 
+                                                     (runtime-reduce-rhs-length action)
+                                                     null
+                                                     src-pos)))
+                           (let ((goto 
+                                  (runtime-goto-state
+                                   (hash-table-get 
+                                    (vector-ref table (stack-frame-state (car new-stack)))
+                                    (runtime-reduce-lhs action)))))
+                             (parsing-loop 
+                              (cons
+                               (if src-pos
+                                   (make-stack-frame
+                                    goto 
+                                    (apply (vector-ref actions (runtime-reduce-prod-num action)) args)
+                                    (if (null? args) start-pos (cadr args))
+                                    (if (null? args) 
+                                        end-pos
+                                        (list-ref args (- (* (runtime-reduce-rhs-length action) 3) 1))))
+                                   (make-stack-frame
+                                    goto 
+                                    (apply (vector-ref actions (runtime-reduce-prod-num action)) args)
+                                    #f
+                                    #f))
+                               new-stack)
+                              ip))))
+                        ((runtime-accept? action)
+                         ;; (printf "accept~n")
+                         (stack-frame-value (car stack)))
+                        (else 
+                         (if src-pos
+                             (err #t tok val start-pos end-pos)
+                             (err #t tok val))
+                         (parsing-loop (fix-error stack tok val start-pos end-pos get-token)
+                                       (get-token))))))))))
+      (cond
+        ((null? (cdr starts)) (make-parser 0))
+        (else
+         (let loop ((l starts)
+                    (i 0))
+           (cond
+             ((null? l) null)
+             (else (cons (make-parser i) (loop (cdr l) (add1 i))))))))))
+  )
\ No newline at end of file
diff --git a/collects/planet/config.ss b/collects/planet/config.ss
new file mode 100644
index 0000000000..40753704ad
--- /dev/null
+++ b/collects/planet/config.ss
@@ -0,0 +1,13 @@
+(module config mzscheme
+  
+  (require "private/planet-shared.ss")
+  
+  (define-parameters (PLANET-SERVER-NAME       "planet.plt-scheme.org")
+                     (PLANET-SERVER-PORT       270)
+                     (PLANET-CODE-VERSION      "300")
+                     (PLANET-DIR               (build-path (find-system-path 'addon-dir) "planet" (PLANET-CODE-VERSION)))
+                     (CACHE-DIR                (build-path (PLANET-DIR) "cache"))
+                     (LINKAGE-FILE             (build-path (PLANET-DIR) "LINKAGE"))
+                     (LOGGING-ENABLED?         #t)
+                     (LOG-FILE                 (build-path (PLANET-DIR) "INSTALL-LOG"))
+                     (DEFAULT-PACKAGE-LANGUAGE (version))))
diff --git a/collects/planet/doc.txt b/collects/planet/doc.txt
new file mode 100644
index 0000000000..4dc197a2f3
--- /dev/null
+++ b/collects/planet/doc.txt
@@ -0,0 +1,404 @@
+_PLaneT_
+
+The PLaneT Module Repository Interaction Collection
+
+The PLaneT system is a method for automatically sharing code packages,
+both as libraries and as full applications, that gives every user of a
+PLaneT client the illusion of having a local copy of every code
+package on the server, but is parsimonious in its transmission. It
+consists of a centralized server that holds all packages and
+individual clients that hold some portion of the archive
+locally. Maintenance of that archive should be transparent, and is the
+complete responsibility of the PLaneT client.
+
+The PLaneT client receives user requests (i.e., the (require (planet
+...)) forms) and loads the appropriate modules in response. In the
+course of handling these requests it may download new code packages
+from the PLaneT server.
+
+The structure of user PLaneT invocations is listed below.
+
+PLANET-REQUEST ::= (planet FILE-NAME PKG-SPEC [PATH ...]) 
+FILE-NAME      ::= string
+PKG-SPEC       ::= string | (FILE-PATH ... PKG-NAME) | (FILE-PATH ... PKG-NAME VER-SPEC)
+VER-SPEC       ::= Nat | (Nat MINOR) 
+MINOR          ::= Nat       ; the specified revision or above
+                 | (Nat Nat) ; a revision between the two specified numbers (inclusive)
+                 | (= Nat)   ; exactly the revision specified
+                 | (+ Nat)   ; the specified revision or above
+                 | (- Nat)   ; the specified revision or below
+FILE-PATH      ::= string    ; the path to the given package in the repository
+PKG-NAME       ::= string
+OWNER-NAME     ::= string
+PATH           ::= string    ; the subdirectory path to the specified file within the package
+
+All strings must be legal filename strings.
+
+When encountered, a planet-request is interpreted as requiring the
+given file name from the given logical package, specified by the
+client's host language (automatically deduced by the client), the
+package spec and the collection specification, if given. If no
+VER-SPEC is provided, the most recent version is assumed. If no
+owner-name/path ... clause is provided, the default package is
+assumed.
+
+_config.ss_: client configuration
+
+This file provides several parameters useful for configuring how
+PLaneT works. 
+
+Parameters:
+
+> (PLANET-SERVER-NAME) -> string
+> (PLANET-SERVER-NAME string) -> void
+
+The name of the PLaneT server to which the client should connect if it
+needs to fetch a package. The default value for this parameter is
+"planet.plt-scheme.org".
+
+> (PLANET-SERVER-PORT) -> Nat
+> (PLANET-SERVER-PORT Nat) -> void
+
+The port on the server the client should connect to. The default value
+for this parameter is 270.
+
+> (PLANET-DIR) -> directory-string
+> (PLANET-DIR directory-string) -> void
+
+The root PLaneT directory. Default is the directory in which config.ss
+is found.
+
+> (CACHE-DIR) -> directory-string
+> (CACHE-DIR directory-string) -> void
+
+The root of the PLaneT client's cache directory.
+
+> (LINKAGE-FILE) file-string
+> (LINKAGE-FILE file-string) -> void
+
+The file to use as the first place PLaneT looks to determine how a
+particular PLaneT dependence in a file should be satisfied. The
+contents of this file are used to ensure that no "magic upgrades"
+occur after a package is installed. The default is the file "LINKAGE"
+in the root PLaneT directory.
+
+> (LOG-FILE) -> file-string or #f
+> (LOG-FILE [file-string or #f]) -> void
+
+If #f, indicates that no logging should take place. Otherwise
+specifies the file into which logging should be written. The default
+is the file "INSTALL-LOG" in the root PLaneT directory.
+
+Note that while these parameters can be useful to modify
+programmatically, PLaneT code runs at module-expansion time and so
+most user programs cannot set them until PLaneT has already
+run. Therefore to meaningfully change these settings it is best to
+manually edit the config.ss file.
+
+_util.ss_
+
+utility functions
+
+The functions in this module support examination of the pieces of
+PLaneT. They are meant primarily to support debugging and to allow
+easier development of higher-level package-management tools.
+
+> (current-cache-contents) -> ((string ((string ((nat (nat ...)) ...)) ...)) ...)
+
+Returns a listing of all package names and versions installed in the
+local cache.
+
+> (current-linkage) -> ((filename (package-name nat nat) ...) ...)
+
+Gives the current linkage table.
+
+> (make-planet-archive directory [file-string]) -> file-string
+
+Makes a .plt archive file suitable for PLaneT whose contents are all
+files in the given directory and returns that file's name.  If the
+optional filename argument is provided, that filename will be used as
+the output file's name.
+
+> (remove-pkg owner name major-version minor-version) -> void
+
+Removes the specified package from the local planet cache. Owner and
+name must be strings; major-version and minor-version must be natural
+numbers and major-version must be greater than zero.
+
+> (unlink-all) -> void
+
+Removes the entire linkage table from the system, which will force all
+modules to relink themselves to PLaneT modules the next time they run.
+
+
+_The PLaneT search order_
+-------------------------
+
+PLaneT has three strategies it uses to match a request with an appropriate
+package that it tries in order.
+
+1. Previous linkage
+
+Whenever a file requires a package via PLaneT and that requirement is
+satisfied, the system makes a note of exactly which package satisfied
+that requirement and from then on always uses that exact same package,
+even if a newer version is available. This is done to prevent "magic
+upgrades" in which a program stops working after installation because
+an unrelated package was installed. Such connections are called links
+and are stored in a user-specific table called the linkage table.
+
+2. Acceptable local package
+
+If the PLaneT client doesn't have any previous linkage information,
+it checks its list of already-installed PLaneT packages for one that
+meets the requirement, and uses it if available.
+
+3. Acceptable remote package
+
+If there is no acceptable local package, the PLaneT client sends 
+a request to the PLaneT server for a new package that would satisfy
+the requirement. The server then finds the newest matching package
+and sends it back to the client, which then installs it and uses
+it to satisfy the original requirement.
+
+_The planet command-line tool_
+------------------------------
+
+The planet command-line tool allows you to examine and manipulate your
+local planet cache and linkage table. It has several modes (only one
+of which may be used in a single invocation):
+
+-f, --file <plt-file> <owner> <maj> <min>
+
+Install local file <plt-file> as though it had been downloaded from
+the planet server. The installed package has path (planet (<owner>
+<plt-file's filename> <maj> <min>)), where maj and min are natural
+numbers and maj is greater than 0.
+
+-c, --create-archive <path>
+
+Create a PLaneT archive in the current directory whose contents are
+the directory <path>
+
+-i, --install <owner> <pkg> <maj> <min>
+
+Download and install the package that 
+(require (planet "file.ss" (<owner> <pkg> <maj> <min>))
+would install. In this mode, min can be any s-expression that
+the (require (planet ...)) form can interpret, not just a natural
+number.
+
+-r, --remove <owner> <pkg> <maj> <min>
+
+Remove the specified package from the local cache.
+
+-p, --packages
+
+List the packages installed in the local cache.
+
+-l, --linkage
+
+List the current linkage table
+
+-U, --unlink-all
+
+Clear the linkage table, unlinking all packages and allowing upgrades.
+
+_Distributing Packages with PLaneT_
+-----------------------------------
+
+To put a package on PLaneT, or release an upgrade to an
+already-existing package:
+
+1. PREPARE A DIRECTORY
+
+Make sure that all source files, documentation, etc. that you want to
+be a part of the package are in a single directory and its
+subdirectories. Furthermore make sure that nothing else, e.g. unneeded
+backup files, is in that directory (with the exception that the
+subdirectories and files CVS or Subversion creates are allowed).
+
+For instance, in the following directory tree, my-app/ is set up
+appropriately:
+
+home/
+  ...
+  jacob/
+  ...
+    my-app/
+      doc.txt
+      my-app.ss
+      graphic-for-my-app.png
+      private/
+         implementation.ss
+
+There are no strict requirements for what sorts of files can go in
+your package, but for it to work well with PLT Scheme's module
+system you should arrange your Schme code into modules.
+
+2. CREATE INFO.SS AND DOC.TXT FILES [OPTIONAL]
+
+If you put a file named info.ss in your package's root directory, the
+PLaneT system will look in it for descriptive metadata about your
+package. The PLaneT system looks for certain names in that file:
+
+The _'blurb field_
+
+If present, the blurb field should contain a list of XHTML fragments 
+encoded as x-expressions (see the xml collection for details) that
+PLaneT will use as a short description of your project. This field
+is also used by the Help Desk.
+
+The _'categories field_
+
+If present, the categories field should be a list of symbols 
+corresponding to the categories under which this package should be listed.
+The valid categories are:
+
+Symbol         Description
+------         -----------
+devtools       Development Tools
+net            Networking and Protocols
+media          Graphics and Audio
+xml            XML-Related
+datastructures Data Structures and Algorithms
+io             Input/Output and Filesystem
+scientific     Mathematical and Scientific
+system         Hardware/Operating System-Specific Tools
+ui             Textual and Graphical User Interface
+metaprogramming Metaprogramming Tools
+planet         PLaneT-Related
+misc           Miscellaneous
+
+If you put symbols other than these the categories field, they will be
+ignored. If you put no legal symbols in the categories field or do not
+include this field in your info.ss file, your package will be
+categorized as "Miscellaneous."
+
+The _'doc.txt field_
+
+If present, the doc.txt field should be a string corresponding to the
+name (without path) of the text documentatation file for your
+package. If this field is the value "doc.txt" and a file called
+"doc.txt" exists in your package's root directory, it will be used as
+the online documentation visitors to the planet.plt-scheme.org website
+will be able to read.
+
+The _'html-docs field_
+
+If present, this field should be a list of strings representing
+subdirectories of your package. These directories will be used by
+Help Desk as HTML documentation for your package. See
+_Creating Help Desk Documentation in HTML format_ for more information
+on how to useful HTML Help Desk documentation.
+
+The _'homepage field_
+
+If present, the URL field should be a string corresponding to a URL
+for the package. PLaneT provides this link with the description of your
+package on the main PLaneT web page.
+
+The _'primary-file field_
+
+If present, the primary-file field should be a string corresponding to
+the name (without path) of the main Scheme source file of your
+package. PLaneT will direct casual users of your library to require
+this file.
+
+The _'version field_
+
+If present, the version field should describe the version number
+of this code that should be presented to users (e.g., "0.15 alpha").
+This field does not override or in any way interact with your package's
+package version number, which is assigned by PLaneT, but may be useful
+to users.
+
+
+In addition, PLaneT uses the setup-plt installer to install packages
+on client machines, so most fields it looks for can be included with
+their usual effects. In particular, adding a name field indicates that
+the Scheme files in the package should be compiled during
+installation; it is probably a good idea to add it.
+
+An example info.ss file looks like this:
+
+(module info (lib "infotab.ss" "setup")
+  (define name "My Application")
+  (define blurb
+    (list "My application runs 60% faster on 20% less peanut "
+	  "butter. It even shows a fancy graphic!"))
+  (define primary-file "my-app.ss")
+  (define doc.txt '("doc.txt"))
+  (define categories '(system xml)))
+
+See the PLT mzc: MzScheme Compiler Manual, chapter 7 for more
+information on info.ss files.
+
+The other special file PLaneT looks for in the root directory of your
+package is doc.txt. Its contents should be documentation for your
+package. Its contents will be available as a link on your package's
+listing on the PLaneT web page.
+
+3. BUILD A .PLT FILE
+
+Use the planet command-line tool in its archive-creation mode to
+create a planet archive:
+
+  planet --create-archive /home/jacob/my-app/
+
+This will create a planet archive named my-app.plt in the current
+directory whose contents are the contents of /home/jacobm/my-app and
+all its subdirectories. 
+
+Alternately, you can run the function make-planet-archive from the
+util.ss module in the planet collection with the name of the directory
+you've prepared as its argument:
+
+  (make-planet-archive "/home/jacob/my-app/")
+
+This function will build a packaged version of your directory and
+return the path to that package. The path will always be a file named
+X.plt, where X is the name of the directory you gave to
+make-planet-archive, located in that same directory.
+
+You can now test that your .plt file works as intended using the
+planet command-line tool in its install mode:
+
+  planet --file <path to your .plt file> <owner name> <maj> <min>
+
+will install the specified .plt file into your local PLaneT cache as
+though it had been downloaded from the PLaneT server with the given
+owner name and major and minor versions. After you run this command,
+you can require your package on your local machine using
+
+  (require (planet (<owner name> <.plt file name without path> <maj> <min>)))
+
+to verify everything works. After you do so, you can use
+
+  planet --remove <owner name> <.plt file name> <maj> <min>
+
+to remove the test package from your local cache. (Not removing it is
+safe as long as you use the same name and version numbers the package
+will have on the official PLaneT server; otherwise you may experience
+problems.)
+
+4. SUBMIT THE PACKAGE
+
+E-mail the .plt file you built to jacobm+planet@plt-scheme.org If the
+package is an upgrade to a prior package, then tell me so and tell me
+whether or not this package is backwards-compatible with the package
+it's upgrading. Also tell me what PLT Scheme version this package is
+intended for. There's no particular format for this message; the
+system isn't automated yet so I'll just be reading these and
+processing them by hand.
+
+Once I've added your package to the repository, I'll e-mail you
+back and tell you the require-line users will need to type in to get
+it.
+
+WARNING: 
+
+It's very important that packages you say are backwards-compatible
+with the prior version, at a minimum contain all the same modules and
+provide all the same names the prior version did. If you do not,
+programs that use your package will break on some systems.
diff --git a/collects/planet/info.ss b/collects/planet/info.ss
new file mode 100644
index 0000000000..6b1f5dff95
--- /dev/null
+++ b/collects/planet/info.ss
@@ -0,0 +1,9 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "PLaneT")
+  (define doc.txt "doc.txt")
+  (define mzscheme-launcher-names '("planet"))
+  (define mzscheme-launcher-libraries '("planet.ss"))
+  (define blurb 
+    (list
+     "The PLaneT collection provides a suite of libraries to implement the "
+     "PLaneT module distribution system.")))
diff --git a/collects/planet/planet-archives.ss b/collects/planet/planet-archives.ss
new file mode 100644
index 0000000000..130bef77fe
--- /dev/null
+++ b/collects/planet/planet-archives.ss
@@ -0,0 +1,32 @@
+(module planet-archives mzscheme
+  (require "private/planet-shared.ss"
+           "config.ss")
+  
+  (provide repository-tree get-installed-planet-archives)
+  
+  (define (repository-tree)
+    (define (id x) x)
+    (filter-tree-by-pattern
+     (directory->tree (CACHE-DIR)
+                      (lambda (x)
+                        (not (regexp-match #rx"/(CVS|[.]svn)$"
+                                           (path->string x))))
+                      4)
+     (list id id id string->number string->number)))
+  
+  ;; get-installed-planet-dirs : -> listof path[absolute, dir]
+  ;; directories of all installed planet archives
+  (define (get-installed-planet-archives)
+    (with-handlers ((exn:fail:filesystem:no-directory? (lambda (e) '())))
+      (tree-apply 
+       (lambda (rep-name owner package maj min) 
+         (let ((x (list 
+                   (build-path (CACHE-DIR) owner package (number->string maj) (number->string min))
+                   owner
+                   package
+                   '()
+                   maj 
+                   min)))
+           x))
+       (repository-tree)
+       3))))
diff --git a/collects/planet/planet.ss b/collects/planet/planet.ss
new file mode 100644
index 0000000000..fcf0766fe1
--- /dev/null
+++ b/collects/planet/planet.ss
@@ -0,0 +1,166 @@
+(module planet mzscheme
+      #|
+This module contains code that implements the `planet' command-line tool.
+  
+PLANNED FEATURES:
+  
+2. Remove a package from the cache
+3. Disable a package without removing it (disabling meaning
+   that if it's a tool it won't start w/ DrScheme, etc)
+4. Examine and alter linkage table
+|#
+  (require (lib "cmdline.ss")
+           (lib "string.ss")
+           (lib "file.ss")
+           (prefix list: (lib "list.ss"))
+           (lib "match.ss")
+           
+           "config.ss"
+           "resolver.ss" ;; the code I need should be pulled out into a common library
+           "util.ss") 
+  
+  (define actions '())
+  
+  (define (start)
+
+    (make-directory* (PLANET-DIR))
+    (make-directory* (CACHE-DIR))
+    
+    (command-line
+     "planet"
+     (current-command-line-arguments)
+     (once-any
+      (("-f" "--file")
+       plt-file owner maj min
+       ""
+       "Install local file <plt-file> as though it had been downloaded from"
+       "the planet server.  The installed package has path"
+       "  (planet (<owner> <plt-file's filename> <maj> <min>))"
+       (set! actions (cons (lambda () (install-plt-file plt-file owner maj min)) actions)))
+      (("-c" "--create-archive")
+       path
+       ""
+       "Create a PLaneT archive in the current directory"
+       "whose contents are the directory <path>"
+       (set! actions (cons (lambda () (do-archive path)) actions)))
+      (("-i" "--install")
+       owner pkg maj min
+       ""
+       "Download and install the package"
+       "  (require (planet \"file.ss\" (<owner> <pkg> <maj> <min>)))"
+       "would install"
+       (set! actions (cons (lambda () (download/install owner pkg maj min)) actions)))
+      (("-r" "--remove")
+       owner pkg maj min
+       ""
+       "Remove the specified package from the local cache"
+       (set! actions (cons (lambda () (remove owner pkg maj min)) actions)))
+      (("-U" "--unlink-all")
+       ""
+       "Clear the linkage table, unlinking all packages and allowing upgrades"
+       (set! actions (cons unlink-all actions)))
+      (("-p" "--packages")
+       ""
+       "List the packages installed in the local cache"
+       (set! actions (cons show-installed-packages actions)))
+      (("-l" "--linkage")
+       ""
+       "List the current linkage table"
+       (set! actions (cons show-linkage actions)))
+      
+      ;; unimplemented so far:
+      #;(("-u" "--unlink")
+         module
+         "Remove all linkage the given module has, forcing it to upgrade"
+         ...)))
+
+    (for-each (lambda (f) (f)) actions))
+  
+  ;; ============================================================
+  ;; FEATURE IMPLEMENTATIONS
+  
+  (define (fail s) (raise (make-exn:fail s (current-continuation-marks))))
+  
+  (define (download/install owner pkg majstr minstr)
+    (let* ([maj (read-from-string majstr)]
+           [min (read-from-string minstr)]
+           [full-pkg-spec (pkg-spec->full-pkg-spec (list owner pkg maj min) #f)])
+      (when (get-package-from-cache full-pkg-spec)
+        (fail "No package installed (cache already contains a matching package)"))
+      (unless (get-package-from-server full-pkg-spec)
+        (fail "Could not find matching package"))))
+  
+  (define (install-plt-file filestr owner majstr minstr)
+    (let ((maj (string->number majstr))
+          (min (string->number minstr)))
+      (unless (and (integer? maj) (integer? min) (> maj 0) (>= min 0))
+        (fail "Invalid major/minor version"))
+      (unless (file-exists? filestr) (fail (format "File does not exist: ~a" filestr)))
+      (let* ([file (normalize-path filestr)]
+             [name (let-values ([(base name dir?) (split-path file)]) (path->string name))]
+             [spec (list owner name maj min)]
+             [fullspec (pkg-spec->full-pkg-spec spec #f)])
+        (unless spec (fail "invalid spec: ~a" spec))
+        (install-pkg fullspec file maj min))))
+  
+  (define (do-archive p)
+    (unless (directory-exists? p)
+      (fail (format "No such directory: ~a" p)))
+    (make-planet-archive (normalize-path p)))
+  
+  (define (remove owner pkg majstr minstr)
+    (let ((maj (string->number majstr))
+          (min (string->number minstr)))
+      (unless (and (integer? maj) (integer? min) (> maj 0) (>= min 0))
+        (fail "Invalid major/minor version"))
+      (unless (remove-pkg owner pkg maj min)
+        (fail "Could not find package"))))
+        
+  (define (show-installed-packages)
+    (for-each 
+     (lambda (l) (apply printf "  ~a\t~a\t~a ~a\n" l))
+     (sort-by-criteria 
+      (map (lambda (x) (match x [(_ owner pkg _ maj min) (list owner pkg maj min)])) (get-installed-planet-archives))
+      (list string<? string=?)
+      (list string<? string=?)
+      (list < =)
+      (list < =))))
+  
+  (define (show-linkage)
+    (for-each
+     (lambda (module)
+       (printf "  ~a:\n" (car module))
+       (for-each 
+        (lambda (link) (apply printf "    ~a\t~a\t~a ~a\n" link))
+        (cdr module)))
+     (list:quicksort 
+      (current-linkage)
+      (lambda (a b) (string<? (symbol->string a) (symbol->string b))))))
+  
+  
+  
+  
+  ;; ------------------------------------------------------------
+  ;; Utility
+    
+  (define (sort-by-criteria l . criteria)
+    (list:quicksort
+     l
+     (lambda (a b)
+       (let loop ((a a) (b b) (c criteria))
+         (cond
+           [(null? a) #f]
+           [((caar c) (car a) (car b)) #t]
+           [(not ((cadar c) (car a) (car b))) #f]
+           [else (loop (cdr a) (cdr b) (cdr c))])))))
+
+  
+
+  ;; ============================================================
+  ;; start the program
+  
+  (with-handlers ([exn:fail? 
+                   (lambda (e) 
+                     (fprintf (current-error-port) "~a\n" (exn-message e))
+                     (exit 1))])
+    (start)))
diff --git a/collects/planet/private/config.ss b/collects/planet/private/config.ss
new file mode 100644
index 0000000000..d3a4a3db5d
--- /dev/null
+++ b/collects/planet/private/config.ss
@@ -0,0 +1,10 @@
+(module config mzscheme
+  
+  (require "planet-shared.ss")
+  
+  (define-parameters (PLANET-SERVER (make-tcp-resource "localhost" 10000))
+                     (PLANET-DIR    (this-expression-source-directory))
+                     (CACHE-DIR     (build-path (PLANET-DIR) "planet-cache"))
+                     (LINKAGE-FILE  (build-path (PLANET-DIR) "LINKAGE"))                  
+                     (LOGGING-ENABLED? #t)
+                     (LOG-FILE      (build-path (PLANET-DIR) "INSTALL-LOG"))))
\ No newline at end of file
diff --git a/collects/planet/private/linkage.ss b/collects/planet/private/linkage.ss
new file mode 100644
index 0000000000..0a3202ab8e
--- /dev/null
+++ b/collects/planet/private/linkage.ss
@@ -0,0 +1,166 @@
+(module linkage mzscheme
+  
+  (require "planet-shared.ss"
+           "../config.ss"
+           (lib "file.ss")
+           (lib "match.ss")
+           (prefix srfi1: (lib "1.ss" "srfi")))
+
+  (provide get-linkage 
+           add-linkage!
+           remove-linkage-to!
+           
+           remove-all-linkage!)
+  
+  ; ==========================================================================================
+  ; PHASE 1: LINKAGE
+  ; The first check is to see if there is a valid linkage for the module.
+  ; ==========================================================================================
+  
+  ;; NOTE :: right now we have a nasty situation with the linkage-table: it doesn't associate
+  ;; keys to packages, which it seems it should. Instead it associates keys to the arguments
+  ;; to the pkg-spec constructor; this is done to facilitate reading the data from disk but
+  ;; causes ugliness in add-linkage! where we have the actual package but have to break it down
+  ;; so the arguments needed to reconstitute it can be stored.
+  
+  
+  ; LINKAGE-TABLE ::= hash-table[LINKAGE-KEY -> PKG-LOCATION]
+  (define LT #f) 
+  
+  ; get-linkage-table : -> hash-table[LINKAGE-KEY -> PKG-LOCATION]
+  (define (get-linkage-table)
+    (unless (file-exists? (LINKAGE-FILE)) (with-output-to-file (LINKAGE-FILE) newline))
+    (unless LT (set! LT (build-hash-table (with-input-from-file (LINKAGE-FILE) read-all))))
+    LT)
+  
+  ; add-linkage! : (symbol | #f) FULL-PKG-SPEC PKG -> PKG
+  ; unless the first argument is #f, associates the pair of the first two arguments 
+  ; with the last in the linkage table. Returns the given package-location
+  (define (add-linkage! module pkg-spec pkg)
+    (when (and module (current-module-name-prefix))
+      (let ((key (get-key module pkg-spec)))
+        (hash-table-get 
+         (get-linkage-table)
+         key
+         (lambda ()
+           (let ((plist (pkg-as-list pkg)))
+             (begin
+               (hash-table-put! (get-linkage-table) key plist)
+               (with-output-to-file (LINKAGE-FILE)
+                 (lambda () (write (list key plist)))
+                 'append)))))))
+    pkg)
+  
+  ;; remove-linkage! string string nat nat -> void
+  ;; eliminates linkage to the given package
+  (define (remove-linkage-to! pkg)
+    (let ((l (get-linkage-table)))
+      
+      ;; first remove bad entries from the in-memory hash table
+      (hash-table-for-each 
+       l
+       (lambda (k v)
+         (match v
+           [(name route maj min _)
+            (when (and (equal? name (pkg-name pkg))
+                       (equal? route (pkg-route pkg))
+                       (= maj (pkg-maj pkg))
+                       (= min (pkg-min pkg)))
+              (hash-table-remove! l k))]
+           [_ (void)])))
+      
+      ;; now write the new table out to disk to keep it in sync
+      (with-output-to-file (LINKAGE-FILE)
+        (lambda ()
+          (printf "\n")
+          (hash-table-for-each 
+           l
+           (lambda (k v) (write (list k v)))))
+        'truncate/replace)))
+  
+  ;; kill the whole linkage-table
+  (define (remove-all-linkage!)
+    (with-output-to-file (LINKAGE-FILE)
+      (lambda () (printf "\n"))
+      'truncate/replace)
+    (set! LT #f))
+  
+  ;; pkg-as-list : PKG -> (list string string nat nat bytes[path])
+  (define (pkg-as-list pkg)
+    (list (pkg-name pkg)
+          (pkg-route pkg)
+          (pkg-maj pkg)
+          (pkg-min pkg)
+          (path->bytes (pkg-path pkg))))
+  
+  ; get-linkage : symbol FULL-PKG-SPEC -> PKG | #f
+  ; returns the already-linked module location, or #f if there is none
+  (define (get-linkage module-specifier pkg-specifier)
+    (let ((pkg-fields (hash-table-get
+                       (get-linkage-table)
+                       (get-key module-specifier pkg-specifier)
+                       (lambda () #f))))
+      (if pkg-fields 
+          (with-handlers ([exn:fail? (lambda (e) #f)])
+            (match-let ([(name route maj min pathbytes) pkg-fields])
+              (make-pkg name route maj min (bytes->path pathbytes))))
+          #f)))
+  
+  ; get-key : symbol FULL-PKG-SPEC -> LINKAGE-KEY
+  ; produces a linkage key for the given pair.
+  (define (get-key module-specifier pkg-spec)
+    (list* (get-module-id module-specifier pkg-spec)
+           (pkg-spec-name pkg-spec)
+           (pkg-spec-maj pkg-spec)
+           (pkg-spec-minor-lo pkg-spec)
+           (pkg-spec-minor-hi pkg-spec)
+           (pkg-spec-path pkg-spec)))
+  
+  ; get-module-id : TST FULL-PKG-SPEC -> LINKAGE-MODULE-KEY
+  ; gets a unique identifier naming the module that produced the pkg-spec.
+  ; (strategy due to Matthew)
+  (define (get-module-id ms pkg-spec)
+    (cond
+      [(full-filename-identifier? ms) 
+       (module-specifier->key ms)]
+      [(and 
+        (pkg-spec-stx pkg-spec) ;; <-- I don't know about this
+        (syntax-original? (pkg-spec-stx pkg-spec))
+        (path? (syntax-source (pkg-spec-stx pkg-spec))))
+       (path->key (desuffix (syntax-source (pkg-spec-stx pkg-spec))))]
+      [(and (symbol? ms) (current-load-relative-directory))
+       (path->key (build-path 
+                   (current-load-relative-directory)
+                   (symbol->string ms)))]
+      [else #f]))
+  
+  
+  ;; ----------------------------------------
+  ;; ALL THE BELOW CODE IN THIS SECTION NEEDS
+  ;; MAJOR MODIFICATION FOR v299
+  
+  ; path? : tst -> bool
+  ;(define path? string?)
+  
+  ; full-filename-identifier? : TST -> bool
+  ; determines if the given value represents a fully-resolved module identifier
+  (define (full-filename-identifier? ms) 
+    (and (symbol? ms)
+         (regexp-match "^\\,.*" (symbol->string ms))))
+  
+  ; module-specifier->key : symbol -> LINKAGE-MODULE-KEY
+  (define (module-specifier->key ms)
+    (string->symbol (substring (symbol->string ms) 1)))
+  
+  ; path->key : string -> LINKAGE-MODULE-KEY
+  (define (path->key p) (string->symbol (path->string p)))
+  
+  ; desuffix : path -> path
+  ; removes the suffix from the given file
+  (define (desuffix file)
+    (let ((the-extension    (filename-extension file))
+          (the-bytes (path->bytes file)))
+      (if the-extension
+          (bytes->path (list->bytes (reverse (srfi1:drop (reverse (bytes->list the-bytes))
+                                                         (add1 (bytes-length the-extension))))))
+          file))))
diff --git a/collects/planet/private/planet-shared.ss b/collects/planet/private/planet-shared.ss
new file mode 100644
index 0000000000..3337daa47c
--- /dev/null
+++ b/collects/planet/private/planet-shared.ss
@@ -0,0 +1,327 @@
+#| planet-shared.ss -- shared client/server utility functions
+
+Various common pieces of code that both the client and server need to access
+
+==========================================================================================
+
+|#
+
+(module planet-shared mzscheme
+  
+  (require (lib "list.ss")
+           (lib "etc.ss")
+           (lib "port.ss"))
+  
+  (provide (all-defined))
+  
+  (define-syntax (define-parameters stx)
+    (syntax-case stx ()
+      [(_ (name val) ...)
+       (andmap identifier? (syntax-e #'(name ...)))
+       #'(begin
+           (provide name ...)
+           (define name (make-parameter val)) ...)]))
+  
+  
+  ; exn:i/o:protocol: exception indicating that a protocol error occured
+  (define-struct (exn:i/o:protocol exn:fail:network) ())
+
+  (define BUILD "build")
+  
+  ; ==========================================================================================
+  ; CACHE LOGIC
+  ; Handles checking the cache for an appropriate module
+  ; ==========================================================================================
+
+  ; language-version->repository : string -> string | #f
+  ; finds the appropriate language version for the given repository
+  (define (language-version->repository ver)
+    (cond
+      [(regexp-match #rx"20.+" ver) "207.1"]
+      [(regexp-match #rx"3.+|29.|" ver) "300"]
+      [else #f]))
+  
+  (define (version->description ver)
+    (cond
+      [(string=? ver "207.1") "20x"]
+      [(string=? ver "300") "299.x-30x"]
+      [else (error 'version->description "Expected one of 207.1 and 300, got ~a" ver)]))
+  
+  (define (legal-language? l)
+    (and (language-version->repository l) #t))
+  
+  ; lookup-package : FULL-PKG-SPEC string[dirname] -> PKG | #f
+  ; returns the directory pointing to the appropriate package in the cache, or #f if the given package
+  ; isn't in the cache
+  (define (lookup-package pkg cache-dir)
+    (let ((pkg-dir (build-path (apply build-path cache-dir (pkg-spec-path pkg)) (pkg-spec-name pkg))))
+      (if (directory-exists? pkg-dir)
+          (get-best-match pkg pkg-dir)
+          #f)))
+  
+  ; get-best-match :FULL-PKG-SPEC (listof string[directory-name]) -> PKG | #f
+  ; gets the best version in the given subdirectory in the specified low and high version range
+  ; or #f if there is no appropriate version
+  (define (get-best-match pkg-spec path)
+    (let ((major-version (if (pkg-spec-maj pkg-spec)
+                             (let ((specified-number (number->string (pkg-spec-maj pkg-spec))))
+                               (if (directory-exists? (build-path path specified-number))
+                                   specified-number
+                                   #f))
+                             (get-highest-numbered-subdir path #f #f))))
+      (if major-version
+          (let ((minor-version (get-highest-numbered-subdir 
+                                (build-path path major-version)
+                                (pkg-spec-minor-lo pkg-spec)
+                                (pkg-spec-minor-hi pkg-spec))))
+            (if minor-version
+                (make-pkg
+                 (pkg-spec-name pkg-spec)
+                 (pkg-spec-path pkg-spec)
+                 (string->number major-version) 
+                 (string->number minor-version)
+                 (build-path path major-version minor-version))
+                #f))
+          #f)))
+  
+  ; get-highest-numbered-subdir : string (Nat | #f) (Nat | #f) -> string[subdir] | #f
+  ; given a path, returns the subdirectory of that path with the highest numeric name or #f if
+  ; none exists. Does not return the full path.
+  (define (get-highest-numbered-subdir path lo hi)
+    (define (valid-dir? d) 
+      (and 
+       (directory-exists? (build-path path d)) 
+       (let ((n (string->number (path->string d))))
+         (and n
+              (or (not lo) (>= n lo))
+              (or (not hi) (<= n hi))))))
+    
+    (unless (directory-exists? path) 
+      (raise (make-exn:fail:filesystem 
+              "Internal PLaneT error: inconsistent cache, directory does not exist" 
+              (current-continuation-marks))))
+    (max-string (map path->string (filter valid-dir? (directory-list path)))))
+  
+  ; FULL-PKG-SPEC : (make-pkg-spec string (Nat | #f) (Nat | #f) (Nat | #f) (listof string) (syntax | #f))
+  (define-struct pkg-spec (name maj minor-lo minor-hi path stx) (make-inspector))
+  ; PKG : string Nat Nat path
+  (define-struct pkg (name route maj min path))
+  
+  ; ==========================================================================================
+  ; UTILITY
+  ; Miscellaneous utility functions
+  ; ==========================================================================================
+  
+  ; make-cutoff-port : input-port nat [nat -> tst] -> input-port
+  ; makes a new input port that reads the first n characters from the given port, then
+  ; returns eof. If n characters are not available from the given input port, calls
+  ; the given function and then returns eof
+  (define make-cutoff-port
+    (opt-lambda (ip n [underflow-fn void])
+      (let ((to-read n))
+        (make-input-port 
+         'cutoff-port
+         
+         (lambda (bytestr)
+           (cond
+             [(= to-read 0) eof]
+             [else
+              (let ((bytes-read (read-bytes-avail! bytestr ip 0 (min n (bytes-length bytestr)))))
+                (if (eof-object? bytes-read)
+                    (begin
+                      (underflow-fn (- to-read bytes-read))
+                      (set! to-read 0)
+                      eof)
+                    (begin
+                      (set! to-read (- to-read bytes-read))
+                      bytes-read)))]))
+       #f
+       void))))
+  
+  ; max-string : listof string[digits] -> string | #f
+  ; this odd little guy takes a list of strings that represent a number and returns the string
+  ; that represents the maximum number among them, or #f if there were no numbers at all 
+  (define (max-string strs)
+    (if (null? strs)
+        #f
+        (let loop ((biggest (car strs))
+                   (big-n (string->number (car strs)))
+                   (rest (cdr strs)))
+          (cond
+            [(null? rest) biggest]
+            [else
+             (let* ([candidate (car rest)]
+                    [test-n    (string->number candidate)])
+               (if (> test-n big-n)
+                   (loop candidate test-n (cdr rest))
+                   (loop biggest big-n (cdr rest))))]))))
+  
+  ; write-line : X output-port -> void
+  ; writes the given value followed by a newline to the given port
+  (define (write-line obj p)
+    (write obj p)
+    (newline p))
+  
+  ; for-each/n (X Nat -> Y) (listof X) -> void
+  ; calls the input function on each element of the input list in order,
+  ; also providing the element's zero-based index in the list
+  (define (for-each/n f l)
+    (let loop ((l l) (n 0))
+      (cond
+        [(null? l) (void)]
+        [else
+         (f (car l) n)
+         (loop (cdr l) (add1 n))])))
+  
+  ; nat? : TST -> bool
+  ; determines if the given scheme value is a natural number
+  (define (nat? obj) (and (integer? obj) (>= obj 0)))
+  
+  ; read-n-chars-to-file : Nat input-port string[filename] -> void
+  ; copies exactly n chars to the given file from the given port. Raises an exception
+  ; if the given number of characters are not available.
+  (define (read-n-chars-to-file n ip file)
+    (let ((op (open-output-file file 'truncate)))
+      (copy-n-chars n ip op)
+      (close-output-port op)))
+  
+  ; copy-n-chars : Nat input-port output-port -> void
+  ; copies exactly n characters from the input to the output. Raises an exception
+  ; if this is not possible.
+  (define (copy-n-chars n ip op)
+    (let ((cport (make-cutoff-port ip 
+                                   n
+                                   (lambda ()
+                                     (raise 
+                                      (make-exn:fail:read:eof
+                                       (format "Not enough chars on input (expected ~a, got ~a)" 
+                                               n 
+                                               (- n 0))
+                                       (current-continuation-marks)
+                                       ip))))))
+      (copy-port cport op)))
+  
+  ; repeat-forever : (-> void) -> [diverges]
+  ; repeatedly invokes the given thunk forever
+  (define (repeat-forever thunk) (let loop () (thunk) (loop)))
+  
+  ; build-hash-table : listof (list X Y) -> equal-hash-table[X -> Y]
+  ; builds a new hash-table mapping all given X's to their appropriate Y values
+  (define (build-hash-table asl)
+    (let ((ht (make-hash-table 'equal)))
+      (for-each (lambda (item) (hash-table-put! ht (car item) (cadr item))) asl)
+      ht))
+  
+  ; categorize : (X -> Y) (listof X) -> (listof (cons Y (listof X)))
+  ; sorts the l into categories given by f
+  (define (categorize f l)
+    (let ((ht (make-hash-table 'equal)))
+      (for-each 
+       (lambda (i)
+         (let ((key (f i)))
+           (hash-table-put! ht key (cons i (hash-table-get ht key (lambda () '()))))))
+       l)
+      (hash-table-map ht cons)))
+  
+  
+  
+  (define (drop-last l) (reverse (cdr (reverse l))))
+  
+  ;; note: this can be done faster by reading a copy-port'ed port with
+  ;; ( and ) tacked around it
+  (define read-all
+    (case-lambda
+      [() (read-all (current-input-port))]
+      [(ip)
+       (let ((sexpr (read ip)))
+         (cond
+           [(eof-object? sexpr) '()]
+           [else (cons sexpr (read-all ip))]))]))
+  
+  (define (wrap x) (begin (write x) (newline) x))
+  
+  (define (with-logging logfile f)
+    (let* ((null-out (open-output-nowhere))
+           (outport
+            (if logfile
+                (with-handlers ((exn:fail:filesystem? (lambda (e) null-out)))
+                  (open-output-file logfile 'append))
+                null-out)))
+      (parameterize ([current-output-port outport])
+        (f))))
+  
+  ;; ============================================================
+  ;; TREE STUFF
+  ;; ============================================================
+  
+  ;; tree[X] ::= (make-branch X (listof tree[X])
+  (define-struct branch (node children) (make-inspector))
+  
+  (define-struct (exn:fail:filesystem:no-directory exn:fail:filesystem) (dir))
+  
+  ;; directory->tree : directory (string -> bool) [nat | bool] [path->X] -> tree[X] | #f
+  (define directory->tree
+    (opt-lambda (directory valid-dir? [max-depth #f] [path->x path->string])
+      (unless (directory-exists? directory)
+        (raise (make-exn:fail:filesystem:no-directory 
+                "Directory ~s does not exist"
+                (current-continuation-marks)
+                directory)))
+      (let-values ([(path name _) (split-path directory)])
+        (let* ((files (directory-list directory))
+               (files (map (lambda (d) (build-path directory d)) files))
+               (files (filter (lambda (d) (and (directory-exists? d) (valid-dir? d))) files)))
+          (make-branch 
+           (path->x name)
+           ;; NOTE: the above line should not use path->string. I don't have time to track this down though
+           (if (equal? max-depth 0) 
+               '()
+               (let ((next-depth (if max-depth (sub1 max-depth) #f)))
+                 (map (lambda (d) (directory->tree d valid-dir? next-depth)) files))))))))
+
+  ;; filter-pattern : (listof pattern-term)
+  ;; pattern-term   : (x -> y) | (make-star (tst -> bool) (x -> y))
+  (define-struct star (pred fun))
+  
+  ;; filter-tree-by-pattern : tree[x] filter-pattern -> tree[y]
+  ;; constraint: depth of the tree <= length of the list
+  ;; converts the tree by applying to each depth the function at that position in the list
+  (define (filter-tree-by-pattern tree pattern)
+    (cond
+      [(null? pattern) (error 'filter-tree-by-pattern "Tree too deep: ~e" tree)]
+      [(star? (car pattern))
+       (if (star-pred (car pattern))
+           (make-branch
+            (star-fun (branch-node tree))
+            (map (lambda (x) (filter-tree-by-pattern x pattern))
+                 (branch-children tree)))
+           (filter-tree-by-pattern tree (cdr pattern)))]
+      [else
+       (make-branch ((car pattern) (branch-node tree))
+                    (map 
+                     (lambda (x) (filter-tree-by-pattern x (cdr pattern)))
+                     (branch-children tree)))]))
+  
+  ;; sexp-tree[x] ::= (cons x (listof sexp-tree[x]))
+  
+  ;; tree-apply : (... -> tst) tree -> listof tst
+  ;; applies f to every path from root to leaf and
+  ;; accumulates all results in a list
+  (define tree-apply
+    (opt-lambda (f t [depth 0])
+      (let loop ((t t)
+                 (priors '())
+                 (curr-depth 0))
+        (cond
+          [(null? (branch-children t))
+           (if (> curr-depth depth)
+               (list (apply f (reverse (cons (branch-node t) priors))))
+               '())]
+          [else
+           (let ((args (cons (branch-node t) priors)))
+             (apply append
+                    (map (lambda (x) (loop x args (add1 curr-depth))) (branch-children t))))]))))
+  
+  ;; tree->list : tree[x] -> sexp-tree[x]
+  (define (tree->list tree)
+    (cons (branch-node tree) (map tree->list (branch-children tree)))))
\ No newline at end of file
diff --git a/collects/planet/resolver.ss b/collects/planet/resolver.ss
new file mode 100644
index 0000000000..246b3ecc50
--- /dev/null
+++ b/collects/planet/resolver.ss
@@ -0,0 +1,422 @@
+#| resolver.ss -- PLaneT client
+
+1. Introduction
+
+The PLaneT system is a method for automatically sharing code packages, both as libraries and
+as full applications, that gives every user of a PLaneT client the illusion of having a local copy
+of every code package on the server, but is parsimonious in its transmission. It consists of a 
+centralized server that holds all packages and individual clients that hold some portion of the 
+archive locally. Maintenance of that archive should be transparent, and is the complete 
+responsibility of the PLaneT client.
+
+2. Client behavior
+
+The PLaneT client receives user requests (i.e., the "(require (planet ...))" forms) and loads the
+appropriate modules in response. In the course of handling these requests it may download new code
+packages from the PLaneT server.
+
+2.1 User interface
+
+The structure of user PLaneT invocations is listed below.
+
+PLANET-REQUEST ::= (planet FILE-NAME PKG-SPEC [PATH ...]?) 
+FILE-NAME      ::= string
+PKG-SPEC       ::= string | (FILE-PATH ... PKG-NAME) | (FILE-PATH ... PKG-NAME VER-SPEC)
+VER-SPEC       ::= Nat | (Nat MINOR) 
+MINOR          ::= Nat | (Nat Nat) | (= Nat) | (+ Nat) | (- Nat)
+FILE-PATH      ::= string
+PKG-NAME       ::= string
+OWNER-NAME     ::= string
+PATH           ::= string
+
+All strings must be legal filename strings.
+
+When encountered, a planet-request is interpreted as requiring the given file name from the given
+logical package, specified by the package spec and the collection specification, if given. If no
+VER-SPEC is provided, the most recent version is assumed. If no owner-name/path ... clause is
+provided, the default package is assumed.
+
+2. PLaneT protocol
+
+PLaneT clients communicate request PLaneT servers over a TCP connection using a specialized 
+protocol. The protocol is described below.
+
+2.1 Overview
+
+1. PLaneT client establishes TCP connection to PLaneT server.
+2. Client transmits a version specifier.
+3. Server either refuses that version and closes connection or accepts.
+4. Client transmits a sequence of requests terminated by a special end-of-request marker.
+    Simultaneously, server transmits responses to those requests.
+5. Once the server has handled every request, it closes the connection.
+
+
+I am concerned about the overhead of opening and closing TCP connections for a large 
+program with many requires, so I want to allow many requests and responses over the same
+connection. Unfortunately there's a wrinkle: the standard client, implemented the obvious
+way, would be unable to send more than one request at a time because it gets invoked purely 
+as a response to a require form and must load an appropriate file before it returns. This
+means I can't batch up multiple requires, at least not with an obvious implementation.
+  
+A possible solution would be to implement an install program that walks over the syntax
+tree of a program and gathers all requires, then communicates with the server and learns
+what additional packages would be necessary due to those requires, and then downloads all
+of them at once. We would have to implement both methods simultaneously, though, to allow
+for REPL-based PLaneT use and dynamic-require (unless we want it to be a runtime exception
+to use PLaneT from the REPL or via dynamic-require, something I'd rather not do), so I
+want a protocol that will allow both forms of access easily. This protocol does that, and
+doesn't require too much additional overhead in the case that the client only takes one
+package at a time.
+
+2.2 Communication Details
+
+After a TCP connection is established, the client transmits a VERSION-SPECIFIER:
+
+VERSION-SPECIFIER ::= "PLaneT/1.0\n"
+
+The server responds with a VERSION-RESPONSE:
+
+VERSION-RESPONSE ::=
+  'ok "\n"
+| ('invalid string) "\n" 
+
+where the string in the invalid case is descriptive text intended for display to the user
+that may indicate some specific message about the nature of the error.
+
+If the server sends 'invalid, the server closes the connection. Otherwise, the client may 
+send any number of requests, followed by an end-of-request marker:
+
+REQUESTS ::= { REQUEST "\n"}* 'end "\n"
+REQUEST  ::= (SEQ-NO 'get PKG-LANG PKG-NAME (Nat | #f) (Nat | #f) (Nat | #f) [OWNER-NAME PATH ...]?)
+PKG-LANG ::= String
+SEQ-NO   ::= Nat
+ 
+The fields in a request are a uniquely identifying sequence number, the literal symbol 'get,
+the name of the package to receive, the required major version and the lowest and highest
+acceptable version (with #f meaning that there is no constraint for that field, and a #f in
+major-version field implying that both other fields must also be #f), and the package path.
+
+As the client is transmitting a REQUESTS sequence, the server begins responding to it with
+RESPONSE structures, each with a sequence number indicating to which request it is 
+responding (except in the case of input too garbled to extract a sequence number):
+
+RESPONSE ::=
+| ('error 'malformed-input string) "\n"
+| (SEQ-NO 'error 'malformed-request string) "\n" 
+| (SEQ-NO 'bad-language string) "\n"
+| (SEQ-NO 'get 'ok Nat Nat Nat) "\n" BYTE-DATA
+| (SEQ-NO 'get 'error ERROR-CODE string) "\n"
+
+ERROR-CODE ::= 'not-found
+
+If the server receives a malformed request, it may close connection after sending a
+malformed-request response without processing any other requests. Otherwise it must
+process all requests even in the event of an error. On a successful get, the three numbers
+the server returns are the matched package's major version, the matched package's minor version,
+and the number of bytes in the package.
+
+3 Client Download Policies
+
+Mzscheme invokes the PLaneT client once for each instance of a require-planet form in a program
+being run (i.e., the transitive closure of the "requires" relation starting from some specified
+root module; this closure is calculable statically). At each of these invocations, the client
+examines its internal cache to see if an appropriate module exists that matches the specification
+given by the user (for details see the next section). If one does, the client loads that module
+and returns. If none does, it initiates a transaction with the server using the PLaneT protocol
+described in the previous subsection and sends a single request consisting of the user's request. 
+It installs the resulting .plt file and then loads the appropriate file.
+
+The client keeps a cache of downloaded packages locally. It does so in the
+$PLTCOLLECTS/planet/cache/ directory and subdirectories, in an intuitive manner: each item in
+the package's path in the PLaneT require line correspond to a subdirectory in the cache 
+directory, starting with the owner name. (They should be unpacked relative to some user-specific
+rather than installation-specific place, possibly, but that's difficult to do so we won't do it
+yet).
+
+To check whether a package is installed when attempting to satisfy a requirement, the client 
+checks its cache to see if an appropriate entry exists in its link-table for that require line.
+If one exists, it uses the named package directly. If none exists, it checks to see if there is
+an appropriate subdirectory.
+
+||#
+(module resolver mzscheme
+  
+  (require (lib "match.ss")
+           (lib "file.ss")
+           (lib "port.ss")
+           (lib "list.ss")
+           
+           (lib "date.ss")
+           
+           "config.ss"
+           "private/planet-shared.ss"
+           "private/linkage.ss")
+
+  (provide (rename resolver planet-module-name-resolver)
+           pkg-spec->full-pkg-spec
+           get-package-from-cache
+           get-package-from-server
+           install-pkg
+           get-planet-module-path/pkg)
+
+  (define install? (make-parameter #t)) ;; if #f, will not install packages and instead give an error
+
+  (define (resolver spec module-path stx)
+    ;; ensure these directories exist
+    (make-directory* (PLANET-DIR))
+    (make-directory* (CACHE-DIR))
+    (establish-diamond-property-monitor)
+    (cond
+      [(or spec stx) (planet-resolve spec module-path stx)]
+      [else module-path]))
+  
+  ; ==========================================================================================
+  ; DIAMOND PROPERTY STUFF
+  ; make sure a module isn't loaded twice with two different versions
+  ; ==========================================================================================
+  (define VER-CACHE-NAME #f)
+  
+  (define (establish-diamond-property-monitor)
+    (unless VER-CACHE-NAME (set! VER-CACHE-NAME (gensym)))
+    (unless (namespace-variable-value VER-CACHE-NAME #t (lambda () #f))
+      (namespace-set-variable-value! VER-CACHE-NAME (make-hash-table 'equal))))
+      
+  (define (the-version-cache)    (namespace-variable-value VER-CACHE-NAME))
+  (define (pkg->diamond-key pkg) (cons (pkg-name pkg) (pkg-route pkg)))
+  
+  (define (add-pkg-to-diamond-registry! pkg)
+    (let ((orig (hash-table-get (the-version-cache)
+                                (pkg->diamond-key pkg)
+                                (lambda () #f))))
+      (cond
+        [(not orig) (hash-table-put! (the-version-cache) (pkg->diamond-key pkg) pkg)]
+        [(and (eq? (pkg-maj pkg) (pkg-maj orig))
+              (eq? (pkg-min pkg) (pkg-min orig)))
+         (void)]
+        [else (raise (make-exn:fail (string->immutable-string
+                                     (format 
+                                      "Package ~a loaded twice with multiple versions: 
+attempted to load version ~a.~a while version ~a.~a was already loaded" 
+                                      (pkg-name pkg) 
+                                      (pkg-maj pkg)
+                                      (pkg-min pkg)
+                                      (pkg-maj orig)
+                                      (pkg-min orig)))
+                                    (current-continuation-marks)))])))
+    
+  ; ==========================================================================================
+  ; MAIN LOGIC
+  ; Handles the overall functioning of the resolver
+  ; ==========================================================================================
+  
+  ; planet-resolve : PLANET-REQUEST symbol syntax[PLANET-REQUEST] -> symbol
+  ; resolves the given request. Returns a name corresponding to the module in the correct
+  ; environment
+  (define (planet-resolve spec module-path stx)
+    (let-values ([(path pkg) (get-planet-module-path/pkg spec module-path stx)])
+      (add-pkg-to-diamond-registry! pkg)
+      (do-require path (pkg-path pkg) module-path stx)))
+  
+  ;; get-planet-module-path/pkg :PLANET-REQUEST symbol syntax[PLANET-REQUEST] -> path PKG
+  ;; returns the matching package and the file path to the specific request
+  (define (get-planet-module-path/pkg spec module-path stx)
+    (match (cdr spec)
+      [(file-name pkg-spec path ...)
+       (match-let*
+           ([pspec (pkg-spec->full-pkg-spec pkg-spec stx)]
+            [pkg (or (get-linkage module-path pspec)
+                     (add-linkage! module-path pspec
+                                   (or
+                                    (get-package-from-cache pspec)
+                                    (get-package-from-server pspec)
+                                    (raise-syntax-error #f "Could not find matching package" stx))))])
+         (values (apply build-path (pkg-path pkg) (append path (list file-name))) pkg))]
+      [_ (raise-syntax-error 'require (format "Illegal PLaneT invocation: ~e" (cdr spec)) stx)]))
+  
+  ;; get-path : planet-request  -> path
+  
+  ; pkg-spec->full-pkg-spec : PKG-SPEC syntax -> FULL-PKG-SPEC
+  (define (pkg-spec->full-pkg-spec spec stx)
+    (define (pkg name maj lo hi path) (make-pkg-spec name maj lo hi path stx))
+    (match spec
+      [(? string?)            (pkg spec #f #f #f '())]
+      [((? string? path) ...) (pkg (last path) #f 0 #f (drop-last path))]
+      [((? string? path) ... (? number? maj)) (pkg (last path) maj 0 #f (drop-last path))]
+      [((? string? path) ... (? number? maj) min-spec)
+       (let ((pkg (lambda (min max) (pkg (last path) maj min max (drop-last path)))))
+         (match min-spec
+           [(? number? min)                 (pkg min #f)]
+           [((? number? lo) (? number? hi)) (pkg lo  hi)]
+           [('= (? number? min))            (pkg min min)]
+           [('+ (? number? min))            (pkg min #f)]
+           [('- (? number? min))            (pkg 0   min)]))]
+      [_ (raise-syntax-error 'require (format "Invalid PLaneT package specifier: ~e" spec) stx)]))
+
+  ; ==========================================================================================
+  ; PHASE 2: CACHE SEARCH
+  ; If there's no linkage, there might still be an appropriate cached module.
+  ; ==========================================================================================
+
+  ; get-package-from-cache : FULL-PKG-SPEC -> PKG | #f
+  (define (get-package-from-cache pkg-spec) 
+    (lookup-package pkg-spec (CACHE-DIR)))
+  
+  ; ==========================================================================================
+  ; PHASE 3: SERVER RETRIEVAL
+  ; Ask the PLaneT server for an appropriate package if we don't have one locally.
+  ; ==========================================================================================
+                 
+  ; get-package-from-server : FULL-PKG-SPEC -> PKG | #f
+  ; downloads and installs the given package from the PLaneT server and installs it in the cache,
+  ; then returns a path to it 
+  (define (get-package-from-server pkg)
+    (with-handlers
+        ([exn:fail? (lambda (e) 
+                      (raise (make-exn:fail
+                              (string->immutable-string
+                               (format 
+                                "Error downloading module from PLaneT server: ~a"
+                                (exn-message e)))
+                              (exn-continuation-marks e))))])
+      (match (download-package pkg)
+        [(#t path maj min) (install-pkg pkg path maj min)]
+        [(#f str) #f])))
+  
+  
+  (define (current-time) 
+    (let ((date (seconds->date (current-seconds))))
+      (parameterize ((date-display-format 'rfc2822))
+        (format "~a ~a:~a:~a" 
+                (date->string date)
+                (date-hour date)
+                (date-minute date)
+                (date-second date)))))
+  
+  ; install-pkg : FULL-PKG-SPEC path[file] Nat Nat -> PKG
+  ; install the given pkg to the planet cache and return a PKG representing the installed file
+  (define (install-pkg pkg path maj min)
+    (let* ((owner (car (pkg-spec-path pkg)))
+           (extra-path (cdr (pkg-spec-path pkg)))
+           (the-dir 
+            (apply 
+             build-path 
+             (CACHE-DIR) 
+             (append (pkg-spec-path pkg) 
+                     (list (pkg-spec-name pkg) (number->string maj) (number->string min))))))
+      (if (directory-exists? the-dir)
+          (raise (make-exn:fail 
+                  "Internal PLaneT error: trying to install already-installed package" 
+                  (current-continuation-marks)))
+          (begin
+            (with-logging
+             (LOG-FILE)
+             (lambda ()
+               (printf "\n============= Installing ~a on ~a =============\n" 
+                       (pkg-spec-name pkg)
+                       (current-time))
+               ;; oh man is this a bad hack!
+               (parameterize ((current-namespace (make-namespace)))
+                 ((dynamic-require '(lib "plt-single-installer.ss" "setup") 'install-planet-package)
+                  path the-dir (list owner (pkg-spec-name pkg) extra-path maj min)))))
+            (make-pkg (pkg-spec-name pkg) (pkg-spec-path pkg) maj min the-dir)))))
+         
+  ; download-package : FULL-PKG-SPEC -> RESPONSE
+  ; RESPONSE ::= (list #f string) | (list #t path[file] Nat Nat)
+  ; downloads the given package and returns (list bool string): if bool is #t,
+  ; the path is to a file that contains the package. If bool is #f, the package
+  ; didn't exist and the string is the server's informative message.
+  ; raises an exception if some protocol failure occurs in the download process
+  (define (download-package pkg)
+  
+    (define-values (ip op) (tcp-connect (PLANET-SERVER-NAME) (PLANET-SERVER-PORT)))
+
+    (define (close-ports)
+      (close-input-port ip)
+      (close-output-port op))
+    
+    (define (request-pkg-list pkgs)
+      (for-each/n (lambda (pkg seqno) 
+                    (write-line (list* seqno 'get 
+                                   (DEFAULT-PACKAGE-LANGUAGE)    
+                                   (pkg-spec-name pkg) 
+                                   (pkg-spec-maj pkg) 
+                                   (pkg-spec-minor-lo pkg)
+                                   (pkg-spec-minor-hi pkg)
+                                   (pkg-spec-path pkg))
+                             op))
+                  pkgs)
+      (write-line 'end op)
+      (flush-output op))
+    
+    (define (state:initialize)
+      (fprintf op "PLaneT/1.0\n")
+      (flush-output op)
+      (match (read ip)
+        ['ok                        (state:send-pkg-request)]
+        [('invalid (? string? msg)) (state:abort (string-append "protocol version error: " msg))]
+        [bad-msg                    (state:abort (format "server protocol error (received invalid response): ~a" bad-msg))]))
+         
+    (define (state:send-pkg-request)
+      (request-pkg-list (list pkg))
+      (state:receive-package))
+        
+    (define (state:receive-package)
+      (match (read ip)
+        [(_ 'get 'ok (? nat? maj) (? nat? min) (? nat? bytes))
+         (let ((filename (make-temporary-file "planettmp~a.plt")))
+           (read-char ip) ; throw away newline that must be present
+           (read-n-chars-to-file bytes ip filename)
+           (list #t filename maj min))]
+        [(_ 'error 'malformed-request (? string? msg)) 
+         (state:abort (format "Internal error (malformed request): ~a" msg))]
+        [(_ 'get 'error 'not-found (? string? msg)) 
+         (state:failure (format "Server had no matching package: ~a" msg))]
+        [(_ 'get 'error (? symbol? code) (? string? msg))
+         (state:abort (format "Unknown error ~a receiving package: ~a" code msg))]
+        [bad-response  (state:abort (format "Server returned malformed message: ~e" bad-response))]))
+    
+    (define (state:abort msg) (raise (make-exn:i/o:protocol msg (current-continuation-marks))))
+    (define (state:failure msg) (list #f msg))
+    
+    (with-handlers ([void (lambda (e) (close-ports) (raise e))])
+      (begin0
+        (state:initialize)
+        (close-ports))))
+  
+  ; ==========================================================================================
+  ; MODULE MANAGEMENT
+  ; Handles interaction with the module system
+  ; ==========================================================================================
+  
+  ; do-require : path path symbol syntax -> symbol
+  ; requires the given filename, which must be a module, in the given path.
+  (define (do-require file-path package-path module-path stx)
+    (parameterize ((current-load-relative-directory package-path))    
+      ((current-module-name-resolver)
+       file-path
+       module-path
+       stx)))
+
+  ; ============================================================
+  ; UTILITY
+  ; A few small utility functions
+
+  (define (last l) (car (last-pair l)))
+  
+  ;; make-directory*/paths : path -> (listof path)
+  ;; like make-directory*, but returns what directories it actually created
+  (define (make-directory*/paths dir)
+    (let ((dir (if (string? dir) (string->path dir) dir)))
+      (let-values ([(base name dir?) (split-path dir)])
+        (cond
+          [(directory-exists? dir)
+           '()]
+          [(directory-exists? base)
+           (make-directory dir)
+           (list dir)]
+          [else
+           (let ((dirs (make-directory*/paths base)))
+             (make-directory dir)
+             (cons dir dirs))]))))
+  
+  )
\ No newline at end of file
diff --git a/collects/planet/util.ss b/collects/planet/util.ss
new file mode 100644
index 0000000000..e060acb91a
--- /dev/null
+++ b/collects/planet/util.ss
@@ -0,0 +1,151 @@
+(module util mzscheme
+  
+  (require "config.ss"
+           "planet-archives.ss"
+           
+           "private/planet-shared.ss"
+           "private/linkage.ss"
+
+           (lib "pack.ss" "setup")
+           (lib "contract.ss")
+           (lib "file.ss")
+           (lib "list.ss")
+           (lib "plt-single-installer.ss" "setup"))
+
+  #| The util collection provides a number of useful functions for interacting with the PLaneT system. |#
+  
+  (provide 
+   current-cache-contents
+   current-linkage
+   make-planet-archive
+   get-installed-planet-archives
+   remove-pkg
+   unlink-all)
+
+  ;; current-cache-contents : -> ((string ((string ((nat (nat ...)) ...)) ...)) ...)
+  ;; returns the packages installed in the local PLaneT cache
+  (define (current-cache-contents)
+    (cdr (tree->list (repository-tree))))
+  
+  ;; get-installed-package : string string nat nat -> PKG | #f
+  ;; gets the package associated with this package, if any
+  (define (get-installed-package owner name maj min)
+    (lookup-package (make-pkg-spec name maj min min (list owner) #f) (CACHE-DIR)))
+  
+  ;; just so it will be provided
+  (define unlink-all remove-all-linkage!)
+  
+  ;; to remove:
+  ;;   -- setup-plt -c the package
+  ;;   -- remove relevant infodomain cache entries
+  ;;   -- delete files from cache directory
+  ;;   -- remove any existing linkage for package
+  ;; returns #t if the removal worked; #f if no package existed.
+  (define (remove-pkg owner name maj min)
+    (let ((p (get-installed-package owner name maj min)))
+      (and p
+           (let ((path (pkg-path p)))
+             (with-logging 
+              (LOG-FILE)
+              (lambda () 
+                (printf "\n============= Removing ~a =============\n" (list owner name maj min))
+                (clean-planet-package path (list owner name '() maj min))))
+             (remove-infodomain-entries path)
+             (delete-directory/files path)
+             (trim-directory (CACHE-DIR) path)
+             (remove-linkage-to! p)))))
+    
+  ;; this really should go somewhere else. But what should setup's behavior be
+  ;; when a package is cleaned? should it clear info-domain entries out? I think
+  ;; no; an uncompiled package isn't necessarily not to be indexed and so on.
+  ;; remove-infodomain-entries : path -> void
+  (define (remove-infodomain-entries path)
+    (let* ([pathbytes (path->bytes path)]
+           [cache-file (build-path (find-system-path 'addon-dir) "cache.ss")]
+           [cache-lines (with-input-from-file cache-file read)])
+      (with-output-to-file cache-file
+       (lambda ()
+         (if (pair? cache-lines)
+             (write (filter (lambda (line) (not (and (pair? line) (equal? (car line) pathbytes)))) cache-lines))
+             (printf "\n")))
+        'truncate/replace)))
+  
+  ;; listof X * listof X -> nonempty listof X
+  ;; returns de-prefixed version of l2 if l1 is a proper prefix of l2; 
+  ;; signals an error otherwise.
+  (define (drop-common-base list1 list2)
+    (let loop ((l1 list1) (l2 list2))
+      (cond
+        [(null? l2)
+         (error 'drop-common-base "root ~s is not a prefix of stem ~s" list1 list2)]
+        [(null? l1) l2]
+        [(not (equal? (car l1) (car l2)))
+         (error 'drop-common-base "root ~s is not a prefix of stem ~s" list1 list2)]
+        [else (loop (cdr l1) (cdr l2))])))
+  
+  ;; pathify-list : path (listof path) -> listof path
+  ;; given a base and a list of names, interprets each name as a subdirectory
+  ;; of the previous, starting with base, and returns a list. (This list
+  ;; is in reverse order, so the deepest subdirectory is returned first)
+  (define (pathify-list root dirs)
+    (let loop ((base root) (dirs dirs) (acc '()))
+      (cond
+        [(null? dirs) acc]
+        [else
+         (let ((new (build-path base (car dirs))))
+           (loop new (cdr dirs) (cons new acc)))])))
+  
+  ;; directory-empty? path -> bool
+  ;; #t iff the given directory contains no subdirectories of files
+  (define (directory-empty? dir)
+    (null? (directory-list dir)))
+  
+  ;; trim-directory path path -> void
+  ;; deletes nonempty directories starting with stem and working down to root
+  (define (trim-directory root stem)
+    (let* ([rootl (explode-path root)]
+           [steml (explode-path stem)]
+           [extras (cdr (pathify-list root (drop-common-base rootl steml)))])
+      (let loop ((dirs extras))
+        (cond
+          [(null? dirs) (void)]
+          [(directory-empty? (car dirs))
+           (delete-directory (car dirs))
+           (loop (cdr dirs))]
+          [else (void)]))))
+
+  ;; current-linkage : -> ((symbol (package-name nat nat) ...) ...)
+  ;; gives the current "linkage table"; a table that links modules to particular versions
+  ;; of planet requires that satisfy those linkages
+  (define (current-linkage)
+    (let* ((links (with-input-from-file (LINKAGE-FILE) read-all))
+           (buckets (categorize caar links)))
+      (map
+       (lambda (x) (cons (car x) (map (lambda (y) (drop-last (cadr y))) (cdr x))))
+       buckets)))
+  
+  ;; make-planet-archive: directory [file] -> file
+  ;; Makes a .plt archive file suitable for PLaneT whose contents are
+  ;; all files in the given directory and returns that file's name.
+  ;; If the optional filename argument is provided, that filename will 
+  ;; be used as the output file's name.
+  (define make-planet-archive
+    (case-lambda
+      [(dir) 
+       (let-values ([(path name must-be-dir?) (split-path dir)])
+         (make-planet-archive 
+          dir 
+          (build-path (normalize-path (current-directory))
+                      (string-append (path->string name) ".plt"))))]
+      [(dir archive-name)
+       (parameterize ((current-directory dir))
+         (pack archive-name
+               "archive" 
+               (list ".")
+               null
+               std-filter
+               #t
+               'file
+               #f
+               #f))
+       (normalize-path archive-name)])))
\ No newline at end of file
diff --git a/collects/plot/demos/demo-1.ss b/collects/plot/demos/demo-1.ss
new file mode 100644
index 0000000000..aba6d4029d
Binary files /dev/null and b/collects/plot/demos/demo-1.ss differ
diff --git a/collects/plot/demos/demo-10.ss b/collects/plot/demos/demo-10.ss
new file mode 100644
index 0000000000..774e4c7970
--- /dev/null
+++ b/collects/plot/demos/demo-10.ss
@@ -0,0 +1,25 @@
+(require (lib "plot.ss" "plot"))
+
+(require (lib "class.ss")
+         (lib "plot-extend.ss" "plot"))
+; (number -> number) mumbo-jumbo -> 2d-renderer
+(define-plot-type dashed-line
+  fun 2dview (x-min x-max) ((samples 100) (segments 20) (color 'red) (width 1))    
+    (let* ((dash-size (/ (- x-max x-min) segments))
+           (x-lists (build-list (/ segments 2) 
+                                (lambda (index)                                    
+                                  (x-values 
+                                   (/ samples segments) 
+                                   (+ x-min (* 2 index dash-size))
+                                   (+ x-min (* (add1 ( * 2 index)) dash-size)))))))
+      (send* 2dview 
+        (set-line-color color)
+        (set-line-width width))
+      (for-each (lambda (dash)
+                  (send 2dview plot-line 
+                        (map (lambda (x) (vector x (fun x))) dash))) 
+                x-lists)))
+                     ;                                  
+
+(plot (dashed-line (lambda (x) x) (color 'red)))
+(plot3d (surface (lambda (x y) (* (sin x) (sin y)))))
\ No newline at end of file
diff --git a/collects/plot/demos/demo-2.ss b/collects/plot/demos/demo-2.ss
new file mode 100644
index 0000000000..d06c2edeb3
--- /dev/null
+++ b/collects/plot/demos/demo-2.ss
@@ -0,0 +1,4 @@
+(require (lib "plot.ss" "plot"))
+
+(plot 
+ (line identity (color 'red)))
\ No newline at end of file
diff --git a/collects/plot/demos/demo-3.ss b/collects/plot/demos/demo-3.ss
new file mode 100644
index 0000000000..d59954e6c1
--- /dev/null
+++ b/collects/plot/demos/demo-3.ss
@@ -0,0 +1,3 @@
+(require (lib "plot.ss" "plot"))
+
+(plot (line (lambda (x) (sin x)) (color 'red)))
\ No newline at end of file
diff --git a/collects/plot/demos/demo-4.ss b/collects/plot/demos/demo-4.ss
new file mode 100644
index 0000000000..4e0c9174da
--- /dev/null
+++ b/collects/plot/demos/demo-4.ss
@@ -0,0 +1,5 @@
+(require (lib "plot.ss" "plot"))
+
+(plot 
+ (vector-field (gradient (lambda (x y) (* (sin x) (cos y)))) (samples 25))
+ (title "gradient field of F(x,y) = sin(x) * sin(y)"))
diff --git a/collects/plot/demos/demo-5.ss b/collects/plot/demos/demo-5.ss
new file mode 100644
index 0000000000..6061c5e92f
--- /dev/null
+++ b/collects/plot/demos/demo-5.ss
@@ -0,0 +1,7 @@
+(require (lib "plot.ss" "plot"))
+
+
+(define (trig x y) (* (sin x) (sin y)))
+(plot (shade trig)
+      (x-min -1.5) (x-max 1.5) (y-min -1.5) (y-max 1.5) 
+      (title "shdade of F(x,y) = sin(x) * sin(y)"))
\ No newline at end of file
diff --git a/collects/plot/demos/demo-6.ss b/collects/plot/demos/demo-6.ss
new file mode 100644
index 0000000000..ef311fe43a
--- /dev/null
+++ b/collects/plot/demos/demo-6.ss
@@ -0,0 +1,7 @@
+(require (lib "plot.ss" "plot"))
+
+(define (trig x y) (* (sin x) (sin y)))
+
+(plot (contour trig)
+      (x-min -1.5) (x-max 1.5) (y-min -1.5) (y-max 1.5) 
+      (title "contours of F(x,y) = sin(x) * sin(y)"))           
\ No newline at end of file
diff --git a/collects/plot/demos/demo-7.ss b/collects/plot/demos/demo-7.ss
new file mode 100644
index 0000000000..f26c1d3a57
--- /dev/null
+++ b/collects/plot/demos/demo-7.ss
@@ -0,0 +1,7 @@
+(require (lib "plot.ss" "plot"))
+
+(define (trig x y) (* (sin x) (sin y)))
+
+(plot (vector-field (gradient trig) '((samples 25)))
+      (x-min -1.5) (x-max 1.5) (y-min -1.5) (y-max 1.5) 
+      (title "gradient field of F(x,y) = sin(x) * sin(y)"))
diff --git a/collects/plot/demos/demo-8.ss b/collects/plot/demos/demo-8.ss
new file mode 100644
index 0000000000..a7f650c4d9
--- /dev/null
+++ b/collects/plot/demos/demo-8.ss
@@ -0,0 +1,14 @@
+(require (lib "plot.ss" "plot"))
+
+(define (trig x y) (* (sin x) (sin y)))
+
+
+(plot (mix
+       (shade trig)
+       (contour trig)
+       (vector-field (gradient trig ) (samples 25)))
+      (x-min -1.5) (x-max 1.5) (y-min -1.5) (y-max 1.5) 
+      (title "gradient field +shdade + contours of F(x,y) = sin(x) * sin(y)"))
+
+(plot3d (mesh3d trig)
+     (x-min -3.5) (x-max 3.5) (y-min -3.5) (y-max 3.5) (z-min -1.0) (z-max 1.5) (bgcolor '(0 0 0)) (fgcolor '(255 0 0)))   
diff --git a/collects/plot/demos/fit-demo-1.ss b/collects/plot/demos/fit-demo-1.ss
new file mode 100644
index 0000000000..1128b246d7
--- /dev/null
+++ b/collects/plot/demos/fit-demo-1.ss
@@ -0,0 +1,23 @@
+(require (lib "plot.ss" "plot"))
+
+(define x-vals (build-list 15 (lambda (x) x) ))
+(define errors (build-list 15 (lambda (x) 1)))
+
+(define (fun x)
+  (* 3 (exp (* x -1 1.32))))
+(define z-vals (map fun x-vals))
+
+(define (gues-fun x a b)
+  (* a (exp (* x -1 b))))
+
+(define params 
+  (fit gues-fun
+       ((a 1) (b 1))
+       (map vector x-vals z-vals errors)))
+
+(plot (mix
+       (points (map vector x-vals z-vals))
+       (line (lambda (x)
+               (apply gues-fun x (fit-result-final-params params)))))
+      (x-min -1) (x-max 20)
+      (y-min -1) (y-max 10))
diff --git a/collects/plot/demos/fit-demo-2.ss b/collects/plot/demos/fit-demo-2.ss
new file mode 100644
index 0000000000..3a6b5a95f6
--- /dev/null
+++ b/collects/plot/demos/fit-demo-2.ss
@@ -0,0 +1,87 @@
+;; This is data from the Cavendish experiment
+
+(define raw-data
+  '((0.0	-14.7	3.6)
+    (1.0	8.6	3.6)
+    (2.1	28.8	3.0)
+    (3.1	46.7	3.4)
+    (4.2	47.4	3.5)
+    (5.2	36.5	3.4)
+   (6.2	37.0	10.3)
+   (7.2	5.1	3.4)
+   (8.2	-11.2	3.4)
+   (9.1	-22.4	3.5)
+   (10.0	-35.5	3.6)
+   (11.0	-33.6	3.9)
+   (12.0	-21.1	3.9)
+   (12.9	-15.0	4.2)
+   (13.8	-1.6	2.7)
+   (14.9	19.5	3.2)
+   (15.9	27.5	2.8)
+   (17.0	32.6	3.5)
+   (17.9	27.5	2.7)
+   (18.9	20.2	3.3)
+   (20.0	13.8	3.4)
+   (21.0	-1.3	4.2)
+   (22.0	-24.5	6.7)
+   (23.0	-25.0	3.3)
+   (24.0	-25.0	3.1)
+   (25.0	-20.2	3.6)
+   (26.0	-9.9	3.2)
+   (27.0	5.8	3.2)
+   (28.0	14.7	3.0)
+   (29.0	21.8	3.5)
+   (30.0	29.8	2.7)
+   (31.0	21.4	4.1)
+   (32.0	24.6	2.7)
+   (32.9	25.8	12.0)
+   (33.8	0.6	2.9)
+   (34.7	-16.6	3.2)
+   (35.7	-24.0	3.7)
+   (36.6	-24.6	3.8)
+   (37.7	-19.8	3.5)))
+
+; first column is time data, second is result, third is error. to parse them out...
+(require (lib "math.ss"))
+
+(define times
+  (map car raw-data))
+(define vals
+  (map cadr raw-data))
+(define errors
+  (map caddr raw-data))
+
+(define experemental-data (map list->vector raw-data))
+
+(require (lib "plot.ss" "plot"))
+
+(plot (mix (points experemental-data (symbol 'circle))
+           (error-bars experemental-data))
+      (x-min 0) (x-max 40)
+      (y-min -40) (y-max 50)
+      (width 400) (height 300))
+
+(define 
+  (theta x a tau phi T theta0)
+  (+ 
+   theta0
+   (* a 
+      (exp (/ x tau -1))
+      (sin (+ phi (/ (* 2 pi x) T))))))
+
+(define result
+  (fit 
+   theta
+   ((a 40) (tau 15) (phi -0.5) (T 15) (theta0 10))
+   experemental-data))
+              
+  
+(plot (mix
+       (points (map vector times vals) (symobol 'square) (color 'black))
+       (error-bars experemental-data)
+       (line (fit-result-function result) (color 'green)))
+      (x-min -5) (x-max 40)
+      (y-min -40) (y-max 50))
+       
+(fit-result-final-params result)
+;(pretty-print result)
\ No newline at end of file
diff --git a/collects/plot/doc.txt b/collects/plot/doc.txt
new file mode 100644
index 0000000000..531e453985
--- /dev/null
+++ b/collects/plot/doc.txt
@@ -0,0 +1,142 @@
+PLoT collection: Quick Start
+
+[Note: This guide is excerpted from the official documentation available
+ from Help Desk.]
+
+2.1  Making basic plots
+
+   After loading the correct module using (require (lib "plot.ss"
+   "plot")) try (plot (line (lambda (x) x)))
+
+   Any other function with the contract number -> number can be plotted
+   using the same form. To plot multiple items, use the functions mix and
+   mix* to combine the items to be plotted
+
+(plot
+ (mix
+  (line (lambda (x) (sin x)))
+  (line (lambda (x) (cos x)))))
+
+   The display area and appearance of the plot can be changed by adding
+   parenthesized argument/value pairs after the first argument
+
+(plot
+ (line (lambda (x) (sin x)))
+ (x-min -1) (x-max 1) (title "Sin(x)"))
+
+   The appearance of each individual plot item can be altered by adding
+   parameter-value pairs after the data.
+
+(plot
+ (line
+  (lambda (x) x)
+  (color 'green) (width 3)))
+
+   Besides plotting lines from functions in 2d, the plotter can also
+   render a variety of other datums in several ways:
+     * Discreet data, such as
+
+(define data
+ (list
+  (vector 1 1 2)
+  (vector 2 2 2)))
+       can be interpreted in several ways
+          + As points: (plot (points data))
+          + As Error Data: (plot (error-bars data))
+     * A function of two variables, such as
+(define 3dfun (lambda (x y) (* (sin x) (sin y))))
+       can be plotted on a 2d graph
+          + Using contours to represent height (z)
+(plot (contour 3dfun))
+          + Using color shading
+(plot (shade 3dfun))
+          + Using a gradient field
+(plot (field (gradient 3dfun)))
+       or in a 3d box
+          + Displaying only the top of the surface
+(plot3d (surface 3dfun))
+
+[8]2.2  Curve Fitting
+
+   The scheme-plot library uses a Non-Linear Least Squares fit algorithm
+   to fit parametrized functions to given data.
+
+   To fit a particular function to a curve:
+    1. Set up the independent and dependent variable data. The first item
+       in each vector is the independant var, the second is the result.
+       The last item must is the weight of the error - we can leave it as
+       1 since all the items weigh the same.
+(define data '(#(0 3 1)
+               #(1 5 1)
+               #(2 7 1)
+               #(3 9 1)
+               #(4 11 1)))
+
+    2. Set up the function to be fitted using fit. This particular
+       function looks like a line. The independant variables must come
+       before the parameters.
+(define fit-fun
+ (lambda (x m b) (+ b (* m x))))
+    3. If possible, come up with some guesses for the values of the
+       parameters. The guesses can be left as one, but each parameter
+       must be named.
+    4. Do the fit - the details of the function are described in [9]Curve
+       Fitting section
+(define fit-result
+  (fit
+   fit-fun
+   ((m 1) (b 1))
+   data)
+    5. View the resulting parameters
+(fit-result-final-params fit-result) ; will produce ((m 2) (b 3))
+
+    6. For some visual feedback of the fit result, plot the function with
+       the new parameters. For convenience, the structure that is
+       returned by the fit command has already created the function.
+(plot (mix
+        (points data)
+        (line (fit-result-function fit-result)))
+      (y-max 15))
+
+   A more realistic example can be found in demos/fit-demo-2.ss
+
+[10]2.3  Creating Custom Plots
+
+   Defining custom plots is simple : a Plot-item (that is passed to plot
+   or mix) is just a function that acts on a [11]view . Both the 2d and
+   3d view snip have several drawing functions defined that the plot-item
+   can call in any order. The full details of the view interface can be
+   found in the [12]plot-extend.ss section.
+
+   For example, if we wanted to create a constructor that creates
+   Plot-items that draw dashed-lines given a number-number function we
+   could do the following:
+
+; Load the required modules
+(require (lib "class.ss")
+         (lib "etc.ss")
+         (lib "plot-extend.ss" "plot"))
+
+
+; Set up the constructor
+(define-plot-type dashed-line
+  fun 2dview (x-min x-max) ((samples 100) (segments 20) (color 'red) (width 1))
+  (let* ((dash-size (/ (- x-max x-min) segments))
+         (x-lists (build-list
+                   (/ segments 2)
+                   (lambda (index)
+                     (x-values
+                      (/ samples segments)
+                      (+ x-min (* 2 index dash-size))
+                      (+ x-min (* (add1 ( * 2 index)) dash-size)))))))
+    (send* 2dview
+           (set-line-color color)
+           (set-line-width width))
+    (for-each
+     (lambda (dash)
+       (send 2dview plot-line
+              (map (lambda (x) (vector x (fun x))) dash)))
+     x-lists)))
+
+; Plot a test case
+(plot (dashed-line (lambda (x) x) (color 'blue)))
diff --git a/collects/plot/fit-low-level.ss b/collects/plot/fit-low-level.ss
new file mode 100644
index 0000000000..8fec6e4156
--- /dev/null
+++ b/collects/plot/fit-low-level.ss
@@ -0,0 +1,56 @@
+(module fit-low-level mzscheme
+  (require (lib "foreign.ss") (lib "etc.ss"))
+  (unsafe!)
+
+  (define libfit
+    (ffi-lib (build-path (this-expression-source-directory)
+                         "compiled" "native" (system-library-subpath)
+                         "libfit")))
+
+  (define do-fit-int
+    (get-ffi-obj "do_fit" libfit
+      (_fun (func      : (_fun _int _pointer -> _double))
+            (val-num   : _int = (length x-values))
+            (x-values  : (_list i _double*))
+            (y-values  : (_list i _double*))
+            (z-values  : (_list i _double*))
+            (errors    : (_list i _double*))
+            (param-num : _int = (length params))
+            (params    : (_list i _double*))
+            -> (_list o _double* param-num))))
+
+  (define (do-fit callback x-vals y-vals z-vals errors params)
+    (do-fit-int (lambda (argc argv)
+                  (let ([args (cblock->list argv _double argc)])
+                    (apply callback args)))
+                x-vals y-vals z-vals errors params))
+
+  (define get-asym-error
+    (get-ffi-obj "get_asym_error" libfit
+      (_fun (len : _?) ; len is only used for list conversion
+            -> (_list o _double* len))))
+
+  (define get-asym-error-percent
+    (get-ffi-obj "get_asym_error_percent" libfit
+      (_fun (len : _?) ; len is only used for list conversion
+            -> (_list o _double* len))))
+
+  (define get-rms
+    (get-ffi-obj "get_rms" libfit
+      (_fun -> _double*)))
+
+  (define get-varience
+    (get-ffi-obj "get_varience" libfit
+      (_fun -> _double*)))
+
+  (define (fit-internal f-of-x-y x-vals y-vals z-vals err-vals params)
+
+    (let* ([len (length params)]
+           [fit-result (do-fit f-of-x-y x-vals y-vals z-vals err-vals params)]
+           [asym-error (get-asym-error len)]
+           [asym-error-percent (get-asym-error-percent len)]
+           [rms (get-rms)]
+           [varience (get-varience)])
+      (list fit-result asym-error asym-error-percent rms varience)))
+
+  (provide fit-internal))
diff --git a/collects/plot/fit.ss b/collects/plot/fit.ss
new file mode 100644
index 0000000000..54efd7e670
--- /dev/null
+++ b/collects/plot/fit.ss
@@ -0,0 +1,58 @@
+(module fit mzscheme
+  (require (lib "math.ss" "plot"))
+  (require (lib "fit-low-level.ss" "plot"))
+
+  ; a structure contain a the results of a curve-fit
+  (define-struct fit-result (
+                             rms
+                             variance
+                             names
+                             final-params
+                             std-error
+                             std-error-percent
+                             function
+                             ) (make-inspector))
+
+  ; fit-int : (number* -> number) (list-of (symbol number)) (list-of (vector number [number] number number)) -> fit-result
+  (define (fit-int function guesses data)
+    (let* ((independant-vars (- (procedure-arity function) (length guesses)))
+           (f-of-x-y (cond
+                       [(= 1 independant-vars)
+                        (lambda (x y . rest)
+                          (apply function x rest))]
+                       [(= 2 independant-vars)
+                        function]
+                       [else
+                        (error "Function provided is eitehr not of one or two independant variables or the number of
+                        guesses given is incorrect")]))
+           (x-vals (map vector-x data))
+           (y-vals (if (= 1 independant-vars)
+                       x-vals
+                        (map vector-y data)))
+           (z-vals (if (= 1 independant-vars)
+                       (map vector-y data)
+                       (map vector-z data)))
+           (err-vals (if (= 1 independant-vars)
+                         (map vector-z data)
+                         (map (lambda (vec) (vector-ref vec 4)) data)))
+           (result (fit-internal f-of-x-y x-vals y-vals z-vals err-vals (map cadr guesses))))
+      (if (null? result)
+          null
+          (begin
+            ;(display result)
+            (make-fit-result
+             (list-ref result 3)
+             (list-ref result 4)
+             (map car guesses)
+             (car result)
+             (cadr result)
+             (caddr result)
+             (lambda args (apply function(append args (car result)))))))))
+
+   (provide fit-int (struct fit-result (rms
+                             variance
+                             names
+                             final-params
+                             std-error
+                             std-error-percent
+                             function))))
diff --git a/collects/plot/info.ss b/collects/plot/info.ss
new file mode 100644
index 0000000000..e1c638ba61
--- /dev/null
+++ b/collects/plot/info.ss
@@ -0,0 +1,3 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Plot library")
+  (define pre-install-collection "pre-installer.ss"))
diff --git a/collects/plot/math.ss b/collects/plot/math.ss
new file mode 100644
index 0000000000..75b48857dd
--- /dev/null
+++ b/collects/plot/math.ss
@@ -0,0 +1,42 @@
+(module math mzscheme
+
+  ; Usefull mathy functions for plots
+  
+  (require 
+   (lib "list.ss")
+   (lib "etc.ss")
+   (lib "math.ss"))
+  
+  ; using vectors for n-dimentional points
+  
+  ; vector-magnitude : (vectorof number) -> number
+  ; computes the magnituded of the vector by using pythegorean theorem
+  (define (vector-magnitude vec)
+    (sqrt (foldl (lambda (item total) (+ (sqr item) total)) 0 (vector->list vec))))
+  
+  ; shortcuts to avoid writing ugly vector-ref code
+  (define (vector-x vec)
+    (vector-ref vec 0))
+  
+  (define (vector-y vec)
+    (vector-ref vec 1))
+  
+  (define (vector-z vec)
+    (vector-ref vec 2))
+          
+  ;  make-vec : (number number -> number) (number number -> number) -> (vector -> vector)
+  (define (make-vec func1 func2)
+    (lambda (point) (vector (func1 (vector-x point) (vector-y point)) (func2 (vector-x point) (vector-y point)))))
+  
+  ; derivative : (number -> number) [number] -> (number -> number)
+  (define derivative
+    (opt-lambda (func [h .00000001])
+      (lambda (x) (/ (- (func (+ x h)) (func x)) h))))
+  
+  ; gradient : (number number -> number) [number] -> (vector -> vector)
+  (define gradient
+    (opt-lambda (func-3d [h .00000001])
+      (lambda (point) (vector ((derivative (lambda (x) (func-3d x (vector-y point))) h) (vector-x point))
+                              ((derivative (lambda (y) (func-3d (vector-x point) y)) h) (vector-y point))))))
+  
+  (provide (all-defined)))
\ No newline at end of file
diff --git a/collects/plot/plot-extend.ss b/collects/plot/plot-extend.ss
new file mode 100644
index 0000000000..6a1fce920c
--- /dev/null
+++ b/collects/plot/plot-extend.ss
@@ -0,0 +1,118 @@
+(module plot-extend mzscheme
+  (require
+   (lib "class.ss")
+   (lib "view.ss" "plot")
+   (lib "renderer-helpers.ss" "plot")
+   )
+  
+  
+  
+  (define-syntax (define-plot-type stx)
+    (define (join-identifier prefix ident)
+      (datum->syntax-object 
+       ident 
+       (string->symbol 
+        (string-append (symbol->string prefix )
+                       (symbol->string (syntax-e ident)))) ))
+    (syntax-case stx ()
+      [(_ name data view ((var default) ...) body)
+       #'(r-lambda-internal name data view ((var default) ...) () body)]
+      [(_ name data view (field ...) ((var default) ...) body)
+       (let ((accessors (map (lambda (f) (join-identifier 'get- f)) (syntax-e #'(field ...)))))
+         (with-syntax (((getter ...) accessors))
+           #'(r-lambda-internal name data view ((var default) ...) ((field getter) ...) body)))]))
+
+  #|
+  (define-syntax r-lambda-internal-test
+    (syntax-rules ()
+      [(_ name data view ((var default) ...) ((value accessor) ...) body)
+       (define-syntax name
+         (lambda (stx-2)
+           (define (find-val sym lst)
+             (cond 
+               [(null? lst) #f]
+               [(eq? (car (syntax-object->datum (car lst))) sym)
+                (cadr (syntax-object->datum (car lst)))]
+               [else
+                (find-val sym (cdr lst))]))
+
+           ;; there is probably a better way to do this
+           (define (subst-names original overrides)             
+             (map
+              (lambda (default-pair)
+                (let ((pair-id (car (syntax-object->datum default-pair))))
+                  (cond
+                    [(find-val pair-id overrides)
+                     => (lambda (new-val)
+                          (datum->syntax-object 
+                           default-pair
+                           (list pair-id new-val)))]
+                    [else 
+                     default-pair])))
+              original))
+           
+           (syntax-case stx-2 ()
+             [(_ val)
+              #'(let ((var default) ...
+                      (data val))
+                  (lambda (view)
+                    (let ((value (send view accessor)) ...)
+                      body)))]
+             [(_ val (override-name override-value) (... ...) )
+              
+              (let ((new-defaults (subst-names
+                                   (syntax-e #'((var default) ...))
+               
+                                   (syntax-e #'((override-name override-value) (... ...))))))
+                (with-syntax ((((def new-def-val) (... ...)) new-defaults))
+                  #'(let ((def new-def-val) (... ...)
+                          (data val))
+                      (lambda (view)
+                        (let ((value (send view accessor)) ...)
+                          body)))))])))]))
+|#
+  (define-syntax r-lambda-internal
+    (syntax-rules ()
+      [(_ name data view ((var default) ...) ((value accessor) ...) body)
+       (define-syntax name
+         (lambda (stx-2)
+           (syntax-case stx-2 ()
+             [(_ val)
+              #'(let ((var default) ...
+                      (data val))
+                  (lambda (view)
+                    (let ((value (send view accessor)) ...)
+                      body)))]
+             [(_ val (override-name override-value) (... ...) )
+              (let ((overrides
+                     (map
+                      (lambda (stx)
+                        (let ((pair (syntax-e stx)))
+                          (list
+                           (syntax-e (car pair))
+                           (cadr pair))))
+                      (syntax-e #'((override-name override-value) (... ...))))))
+                (let ((new-defaults
+                       (map
+                        (lambda (a-default)
+                          (let ((def-name (syntax-e (car (syntax-e a-default)))))
+                            (cond
+                             [(assq def-name overrides) =>
+                              (lambda (new-val)
+                                (datum->syntax-object
+                                 a-default        ;   ...
+                                 (list (car (syntax-e a-default))
+                                       (cadr new-val))))]
+                               [else a-default])))
+                          (syntax-e #'((var default) ...)))))
+                  (with-syntax ((((var-new default-new) (... ...)) new-defaults))
+                    #'(let ((var-new default-new) (... ...)
+                            (data val))
+                        (lambda (view)
+                          (let ((value (send view accessor)) ...)
+                            body))))))])))]))
+  (provide
+   define-plot-type
+   (all-from (lib "view.ss" "plot"))
+   (all-from (lib "renderer-helpers.ss" "plot"))))
+
diff --git a/collects/plot/plot.ss b/collects/plot/plot.ss
new file mode 100644
index 0000000000..f32530d4a5
--- /dev/null
+++ b/collects/plot/plot.ss
@@ -0,0 +1,94 @@
+(module plot mzscheme
+  (require
+   (lib "list.ss")
+   (lib "etc.ss")
+   (lib "math.ss" "plot")
+   (lib "view.ss" "plot")
+   (lib "renderer-helpers.ss" "plot")
+   (lib "renderers.ss" "plot")
+   (lib "fit.ss" "plot")
+   (lib "class.ss"))
+
+  ; plot : plottable (option value)*
+  (define-syntax plot
+    (syntax-rules ()
+      [(_ ren )
+       (instantiate 2d-view% () (renderer ren))]
+      [(_ ren (option value) ...)
+       (instantiate 2d-view% () (renderer ren) (option value) ...)]))
+
+  (define-syntax plot3d
+    (syntax-rules ()
+      [(_ ren )
+       (instantiate 3d-view% () (renderer ren))]
+      [(_ ren (option value) ...)
+       (instantiate 3d-view% () (renderer ren) (option value) ...)]))
+
+  ; mix-int : renderer renderer -> renderer
+  ; creates a renderer that will renderer both of the inputs
+  (define (mix-int renderer1 renderer2)
+    (lambda (view)
+      (send view reset-to-default)
+      (renderer1 view)
+      (send view reset-to-default)
+      (renderer2 view)))
+
+  ; mix : renderer+ -> renderer
+  ; combine any number of renderers
+  (define (mix r1 . the-rest)
+    (if (empty? the-rest) 
+        r1
+        (mix-int r1 (apply mix the-rest))))
+
+  ; make-2d-renderer : (2d-view% -> void)
+  ; provides a user with the ability to create their own renderers
+  ; without providing the implimentation
+  (define custom identity)
+
+  ;;
+  (define-syntax fit
+    (syntax-rules ()
+      [(_ func ((param guess) ...) data)
+       (fit-int func 
+                '((param guess) ...)
+                data)]))
+
+  (provide
+
+   ;fitting
+   fit
+   (struct fit-result (rms
+                             variance
+                             names
+                             final-params
+                             std-error
+                             std-error-percent
+                             function))
+   ; to make plots
+   plot
+   plot3d
+
+   ; to combine/create renderers
+   mix
+   custom
+
+   ; 2d-renderers
+   error-bars
+   points
+   line
+   vector-field
+   contour
+   shade
+   ; 3d-rendereres
+   surface
+   mesh3d
+
+   ; from math-tools
+   derivative
+   gradient
+   make-vec
+
+
+))
+
+
diff --git a/collects/plot/plplot.ss b/collects/plot/plplot.ss
new file mode 100644
index 0000000000..2856eedbc3
--- /dev/null
+++ b/collects/plot/plplot.ss
@@ -0,0 +1,304 @@
+(module plplot mzscheme
+
+(require (lib "etc.ss") (lib "list.ss") (lib "foreign.ss"))
+(unsafe!)
+
+(define libplplot
+  (ffi-lib
+   (build-path (this-expression-source-directory)
+               "compiled" "native" (system-library-subpath) "libplplot")))
+
+(define plplotlibdir (get-ffi-obj "plplotLibDir" libplplot _string))
+
+;; set the lib dir to contain the fonts.
+(set-ffi-obj! "plplotLibDir" libplplot _string
+  (path->string (this-expression-source-directory)))
+
+(define _plflt _double*)
+(define _plint _int)
+
+(define (_list-of type . len?)
+  (let ([len (and (pair? len?) (car len?))])
+    (make-ctype _pointer
+      (lambda (l) (list->cblock l type))
+      (if len
+        (lambda (b) (cblock->list b type len))
+        (lambda (b) (error "this list type does not specify a size"))))))
+
+(define (_matrix-of type)
+  (_list-of (_list-of type)))
+
+(define-syntax define*
+  (syntax-rules ()
+    [(_ (name . args) body ...)
+     (begin (provide name) (define (name . args) body ...))]
+    [(_ name expr)
+     (begin (provide name) (define name expr))]))
+
+(define* pl-setup-page
+  (get-ffi-obj "c_plspage" libplplot
+               (_fun (xp : _plflt = 0.)
+                     (yp : _plflt = 0.)
+                     (xleng : _plflt)
+                     (yleng : _plflt)
+                     (xoff : _plint = 0)
+                     (yoff : _plint = 0)
+                     -> _void)))
+
+(define* pl-set-device
+  (get-ffi-obj "c_plsdev" libplplot (_fun _string -> _void)))
+
+(define* pl-set-output-file
+  (get-ffi-obj "c_plsfnam" libplplot (_fun _string -> _void)))
+
+(define* pl-init-plot
+  (get-ffi-obj "c_plinit" libplplot (_fun -> _void)))
+
+(define* pl-finish-plot
+  (get-ffi-obj "c_plend" libplplot (_fun -> _void)))
+
+(define* pl-set-plot-environment
+  (get-ffi-obj "c_plenv" libplplot
+    (_fun _plflt _plflt _plflt _plflt _plint _plint -> _void)))
+
+(define* pl-set-labels
+  (get-ffi-obj "c_pllab" libplplot
+    (_fun _string _string _string -> _void)))
+
+(define* pl-plot-line
+  (get-ffi-obj "c_plline" libplplot
+    (_fun _plint (x : (_list i _plflt)) (y : (_list i _plflt)) -> _void)))
+
+(define* pl-plot-segment
+  (get-ffi-obj "c_pljoin" libplplot
+    (_fun _plflt _plflt _plflt _plflt -> _void)))
+
+(define* pl-set-background-color
+  (get-ffi-obj "c_plscolbg" libplplot
+    (_fun _plint _plint _plint -> _void)))
+
+
+(define* pl-select-colormap0-index
+  (get-ffi-obj "c_plcol0" libplplot
+    (_fun _plint -> _void)))
+
+(define* pl-set-colormap0-index
+  (get-ffi-obj "c_plscol0" libplplot
+    (_fun _plint _plint _plint _plint -> _void)))
+
+(define* pl-set-line-width
+  (get-ffi-obj "c_plwid" libplplot
+    (_fun _plint -> _void)))
+
+(define* pl-write-text
+  (get-ffi-obj "c_plptex" libplplot
+               (_fun _plflt _plflt _plflt _plflt _plflt _string -> _void)))
+
+;;(define* pl-2d-countour-plot ...)
+;;(define* pl-2d-shade-plot ...)
+
+(define* pl-x-error-bars
+  (get-ffi-obj "c_plerrx" libplplot
+    (_fun _plint (_list i _plflt)
+          (_list i _plflt)
+          (_list i _plflt) -> _void)))
+
+(define* pl-y-error-bars
+  (get-ffi-obj "c_plerry" libplplot
+    (_fun _plint (_list i _plflt)
+          (_list i _plflt)
+          (_list i _plflt) -> _void)))
+
+(define* pl-plot-points
+  (get-ffi-obj "c_plpoin" libplplot
+    (_fun _plint (x : (_list i _plflt)) (y : (_list i _plflt)) _plint
+          -> _void)))
+
+(define* pl-fill
+  (get-ffi-obj "c_plfill" libplplot
+   (_fun  (n         : _int = (length x-values))
+          (x-values  : (_list i _plflt))
+          (y-values  : (_list i _plflt))
+          -> _void)))
+
+(define* pl-world-3d
+  (get-ffi-obj "c_plw3d" libplplot
+    (_fun
+     _plflt _plflt _plflt _plflt _plflt _plflt _plflt _plflt _plflt _plflt _plflt
+     ->
+     _void)))
+
+;; bit-masks for some of the functions..
+(define-values (DRAW_LINEX DRAW_LINEY MAG_COLOR BASE_CONT TOP_CONT SURF_CONT DRAW_SIDES DRAW_FACETED MESH)
+  (apply values (build-list 9 (lambda (s) (arithmetic-shift 1 s)))))
+
+(define DRAW_LINEXY (bitwise-ior DRAW_LINEX DRAW_LINEY))
+
+
+(define* pl-plot3d
+  (get-ffi-obj "c_plot3d" libplplot
+   (_fun
+    (x-values  : (_list i _plflt))
+    (y-values  : (_list i _plflt))
+    (z-values  : (_matrix-of _plflt))
+    (nx        : _int = (length x-values))
+    (ny        : _int = (length y-values))
+    (draw-opt1 : _int = DRAW_LINEXY)
+    (draw-opt2 : _int = 0)
+    -> _void))) ;; these are documented in the plplot ref manual, and will be obseleted.
+
+(define* pl-mesh3d
+  (get-ffi-obj "c_plot3d" libplplot
+   (_fun
+    (x-values  : (_list i _plflt))
+    (y-values  : (_list i _plflt))
+    (z-values  : (_matrix-of _plflt))
+    (nx        : _int = (length x-values))
+    (ny        : _int = (length y-values))
+    (draw-opt1 : _int = DRAW_LINEXY)
+    -> _void)))
+
+; ;; this function needs to go.
+; (define* pl-plot-points
+;   (get-ffi-obj "c_plpoin" libplplot
+;    (_fun
+;     (nx        : _int = (length x-values))
+;     (x-values  : (_list i _plflt))
+;     (y-values  : (_list i _plflt))
+;     (code      : _int))))
+
+(define* pl-box3
+  (get-ffi-obj "c_plbox3" libplplot
+   (_fun
+    (x-ops     : _string) (x-title   : _string) (x-spacing : _plflt) (x-ticks   : _int)
+    (y-ops     : _string) (y-title   : _string) (y-spacing : _plflt) (y-ticks   : _int)
+    (z-ops     : _string) (z-title   : _string) (z-spacing : _plflt) (z-ticks   : _int)
+    -> _void)))
+
+(define* pl-poly3
+  (get-ffi-obj "c_plline3" libplplot
+   (_fun
+    (n-points : _int = (length x-values))
+    (x-values  : (_list i _plflt))
+    (y-values  : (_list i _plflt))
+    (z-values  : (_list i _plflt))
+    -> _void)))
+
+
+(define* pl-line3
+  (get-ffi-obj "c_plpoly3" libplplot
+   (_fun
+    (n-points : _int = (length x-values))
+    (x-values  : (_list i _plflt))
+    (y-values  : (_list i _plflt))
+    (z-values  : (_list i _plflt))
+    (draw-mask : (_list i _int))
+    (direction : _int)
+    -> _void)))
+
+;; need the CStruct PLcGrid ;
+;;    PLFLT *xg, *yg, *zg;
+;;    PLINT nx, ny, nz;
+(define-cstruct _PLcGrid ((xg _pointer)
+                          (yg _pointer)
+                          (zg _pointer)
+                          (nx _int)
+                          (ny _int)
+                          (nz _int)))
+
+(define pl-2d-contour-plot-int
+  (get-ffi-obj "c_plcont" libplplot
+   (_fun
+    (matrix     : (_matrix-of _plflt))
+    (nx         : _int = (PLcGrid-nx grid))
+    (ny         : _int = (PLcGrid-ny grid))
+    (t1         : _plint = 1)
+    (t2         : _int = (PLcGrid-nx grid))
+    (t3         : _plint = 1)
+    (t4         : _int = (PLcGrid-ny grid))
+    (levels     : (_list i _plflt))
+    (nlevels    : _int = (length levels))
+    (pltr       : _fpointer = (get-ffi-obj "pltr1" libplplot _fpointer))
+    (grid       : _PLcGrid-pointer)
+    -> _void)))
+
+(define* (pl-2d-contour-plot z-vals x-vals y-vals levels)
+  (let ((grid-obj (make-PLcGrid (list->cblock x-vals _plflt) (list->cblock y-vals _plflt) #f
+                                (length x-vals) (length y-vals) 0)))
+    (pl-2d-contour-plot-int z-vals levels grid-obj)))
+
+
+
+(define pl-2d-shade-plot-int
+  (get-ffi-obj "c_plshades" libplplot
+   (_fun
+    (matrix     : (_matrix-of _plflt))
+    (nx         : _int = (PLcGrid-nx grid))
+    (ny         : _int = (PLcGrid-ny grid))
+    (null-val   : _pointer = #f)
+    (x_min      : _plflt = 0)
+    (x_max      : _plflt = 0)
+    (y_min      : _plflt = 0)
+    (y_max      : _plflt = 0)
+    (levels     : (_list i _plflt))
+    (nlevels    : _int = (length levels))
+    (fill_width : _int = 1)
+    (cont_col   : _int = 1)
+    (cont_width : _int = 0)
+    (fill_fun   : _fpointer = (get-ffi-obj "c_plfill" libplplot _fpointer))
+    (rectan     : _int = 1)
+    (pltr       : _fpointer = (get-ffi-obj "pltr1" libplplot _fpointer))
+    (grid       : _PLcGrid-pointer)
+    -> _void)))
+
+(define* (pl-2d-shade-plot z-vals x-vals y-vals levels)
+  ;; this can prolly be inlined above..
+  (let ((grid-obj (make-PLcGrid (list->cblock x-vals _plflt) (list->cblock y-vals _plflt) #f
+                                 (length x-vals) (length y-vals) 0)))
+    (pl-2d-shade-plot-int z-vals levels grid-obj)))
+
+
+;; set up color map numbers
+(define plscmap1n
+  (get-ffi-obj "c_plscmap1n" libplplot
+    (_fun _int -> _void)))
+
+;; set up the map
+(define plscmap1l
+  (get-ffi-obj "c_plscmap1l" libplplot
+    (_fun
+     (itype     : _plint)
+     (npts      : _int = (length intencity))
+     (intencity : (_list i _plflt))
+     (coord1    : (_list i _plflt))
+     (coord2    : (_list i _plflt))
+     (coord3    : (_list i _plflt))
+     (rev       : _pointer = #f)
+     -> _void)))
+
+(define pl-mesh3dc-int 
+  (get-ffi-obj "c_plmeshc" libplplot
+    (_fun
+     (x-values  : (_list i _plflt))
+     (y-values  : (_list i _plflt))
+     (z-values  : (_matrix-of _plflt))
+     (x-len     : _int = (length x-values))
+     (y-len     : _int = (length y-values))
+     (opts      : _int)
+     (levels    : (_list i _plflt))
+     (n-levels  : _int = (length levels))
+     -> _void)))
+
+(define* (pl-mesh3dc x-vals y-vals z-vals contours? lines? colored? sides? levels)
+  (let ((opts (foldl
+               (lambda (mask use? current) (bitwise-ior current (if use? mask 0)))
+               0
+               (list DRAW_LINEXY MAG_COLOR BASE_CONT DRAW_SIDES)
+               (list contours? lines? colored? sides?))))
+    (plscmap1n 256)
+    (plscmap1l 0 '(0.0 1.0) '(240 0) '(.6 .6) '(.8 .8))
+    (pl-mesh3dc-int x-vals y-vals z-vals opts levels)))
+
+
+
+)
diff --git a/collects/plot/plstnd5.fnt b/collects/plot/plstnd5.fnt
new file mode 100644
index 0000000000..51923d998d
Binary files /dev/null and b/collects/plot/plstnd5.fnt differ
diff --git a/collects/plot/plxtnd5.fnt b/collects/plot/plxtnd5.fnt
new file mode 100644
index 0000000000..88ec784ba9
Binary files /dev/null and b/collects/plot/plxtnd5.fnt differ
diff --git a/collects/plot/pre-installer.ss b/collects/plot/pre-installer.ss
new file mode 100644
index 0000000000..358da99acb
--- /dev/null
+++ b/collects/plot/pre-installer.ss
@@ -0,0 +1,60 @@
+(module pre-installer mzscheme
+  (require (lib "etc.ss") (lib "file.ss") (lib "list.ss")
+           (lib "file.ss" "dynext") (lib "link.ss" "dynext")
+           (lib "compile.ss" "dynext")
+           (lib "compiler.ss" "compiler"))
+
+  (define top-dir (this-expression-source-directory))
+  (define src-dir (build-path top-dir "src"))
+  (define tmp-dir (build-path src-dir "tmp"))
+  (define dir->libname '(["all" "libplplot"] ["fit" "libfit"]))
+  (define native-dir
+    (build-path top-dir "compiled" "native" (system-library-subpath)))
+
+  (define (build-library lib)
+    (when (and (directory-exists? lib)
+               (not (member (path->string lib) '("CVS" ".svn"))))
+      (let* ([libname (cond
+                       [(assoc (path->string lib) dir->libname) => cadr]
+                       [else (error 'plot-preinstaller
+                                    "Found an unknown source directory: ~s\n"
+                                    lib)])]
+             [so-name (build-path top-dir "compiled" "native"
+                                  (system-library-subpath)
+                                  (append-extension-suffix libname))])
+        (printf "plot: compiling \"~a\" -> \"~a\"...\n" lib so-name)
+        (parameterize ([current-directory lib]
+                       [current-extension-compiler-flags
+                        (append (current-extension-compiler-flags)
+                                (case (system-type)
+                                  [(windows) '("/DHAVE_LIBPNG" "/DPLD_png")]
+                                  [else '("-DHAVE_LIBPNG" "-DPLD_png")]))]
+                       ;; we compile a simple .so, not an extension
+                       [current-standard-link-libraries '()]
+                       ;[current-use-mzdyn #f]
+                       )
+          (define c-files (filter (lambda (f)
+                                    (regexp-match "\\.[cC]$" (path->string f)))
+                                  (directory-list)))
+          (when (or (not (file-exists? so-name))
+                    (let ([so-time (file-or-directory-modify-seconds so-name)])
+                      (ormap (lambda (f)
+                               (> (file-or-directory-modify-seconds f)
+                                  so-time))
+                             c-files)))
+            (printf "    Compiling \"~a\"\n" lib)
+            (make-directory* tmp-dir)
+            (compile-c-extension-parts c-files tmp-dir)
+            (parameterize ([current-directory tmp-dir])
+              (link-extension #f (directory-list tmp-dir) so-name))
+            (delete-directory/files tmp-dir))))))
+
+  (provide pre-installer)
+  (define (pre-installer plthome)
+    (unless (directory-exists? src-dir)
+      (error 'plot-preinstall "Could not find the source directory at ~a"
+             src-dir))
+    (when (directory-exists? src-dir)
+      (unless (directory-exists? native-dir) (make-directory* native-dir))
+      (parameterize ([current-directory src-dir])
+        (for-each build-library (directory-list))))))
diff --git a/collects/plot/renderer-helpers.ss b/collects/plot/renderer-helpers.ss
new file mode 100644
index 0000000000..76419d8659
--- /dev/null
+++ b/collects/plot/renderer-helpers.ss
@@ -0,0 +1,63 @@
+(module renderer-helpers mzscheme
+
+  ; Contains the helpers for the plot-renderers package
+  ; usefull for building your own renderers
+
+  (require
+   (lib "list.ss")
+   (lib "math.ss")
+   (lib "math.ss" "plot"))
+
+  ; sample-size: number number number -> number
+  (define (sample-size samples x-min x-max)
+    (/ (- x-max x-min) (- samples 1)))
+
+  ; scale-vectors : listof-posn number number -> listof-posn
+  ; scales vectors, causing them to fit in their boxes
+  (define (scale-vectors deltas x-sample-size y-sample-size)
+    (let* ((x-max-value (apply max (map vector-x deltas)))
+           (y-max-value (apply max (map vector-y deltas)))
+           (x-div-const (/ x-max-value x-sample-size))
+           (y-div-const (/ y-max-value y-sample-size)))
+      (map (lambda (point) (vector (* (/ (vector-x point) x-div-const) 9/10) 
+                                   (* (/ (vector-y point) y-div-const) 9/10))) deltas)))
+
+  ; x-values : number number number -> listof-number
+  (define (x-values samples x-min x-max)
+    (let ((ss (sample-size samples x-min x-max)))
+      (build-list samples (lambda (x) (+ x-min (* x ss))))))
+
+  ; normalze-vector : posn number number -> posn
+  (define (normalize-vector vec x-sample-size y-sample-size)
+    (let* ((size (vector-magnitude vec)))
+      (if (zero? size)
+          (vector 0 0)
+          (vector (* (/ (vector-x vec) size) x-sample-size 9/10)
+                  (* (/ (vector-y vec) size) y-sample-size 9/10)))))
+
+  ; normalize-vector : listof-posn number number -> listolf-posn
+  (define (normalize-vectors deltas x-sample-size y-sample-size)
+    (map (lambda (vec) (normalize-vector vec x-sample-size y-sample-size)) deltas))
+
+  ; make-column : number listof-number -> listof-points
+  (define (make-column x-val y-values)
+    (map (lambda (y) (vector x-val y)) y-values))
+
+  ; xy-list : number number number number number  -> listof-posn
+  ; make a list of all the positions on the graph
+  (define (xy-list samples x-min x-max y-min y-max)
+    (let* ((x-vals (x-values samples x-min x-max))
+           (y-vals (x-values samples y-min y-max)))
+      (apply append (map (lambda (x) (make-column x y-vals)) x-vals))))
+
+  ; zgrid : (number number -> number) listof-number listof-number -> listof-listof number
+  (define (zgrid func x-vals y-vals samples)
+    (map (lambda (x) (map (lambda (y) (func x y)) y-vals)) x-vals))
+
+  (provide (all-defined))
+
+  (require
+   (lib "class.ss")
+   (lib "etc.ss"))
+
+  )
diff --git a/collects/plot/renderers.ss b/collects/plot/renderers.ss
new file mode 100644
index 0000000000..7c8a271c19
--- /dev/null
+++ b/collects/plot/renderers.ss
@@ -0,0 +1,149 @@
+(module renderers mzscheme
+  (require 
+   (lib "math.ss" "plot")
+   (lib "renderer-helpers.ss" "plot")
+   (lib "class.ss")
+   (lib "plot-extend.ss" "plot"))
+  
+  ;line : (number -> number) [number] [symbol] [number] -> (2dplotview -> nothing)
+  (define-plot-type line 
+    func 2dplotview (x-min x-max) ((samples 150) (color 'red) 
+                                             (width 1) 
+                                             (mode 'standard) 
+                                             (mapping 'cartesian)
+                                             (t-min -5) (t-max 5))      
+      (let*
+          ((t-min (if (or (eq? mapping 'polar) (eq? mode 'parametric))
+                      t-min x-min))
+           (t-max (if (or (eq? mapping 'polar)(eq? mode 'parametric))
+                      t-max x-max))  ; maybe let-values?
+           (points
+            (case mode
+              ((standard) (map (lambda (x) (vector x (func x))) 
+                               (x-values samples x-min x-max)))
+              ((parametric) (map func (x-values samples t-min t-max))))))
+        (send* 2dplotview 
+          (set-line-color color) (set-line-width width)
+          (plot-line 
+           (case mapping
+             ((cartesian) points)
+             ((polar) (map 
+                       (lambda (point)  ; convert to cartesian from theta, r
+                         (vector 
+                          (* (vector-y point) (cos (vector-x point)))
+                          (* (vector-y point) (sin (vector-x point))))))))))))
+  
+    ; error-bars : (listof (vector x y err)) [symbol] -> (2dplotview -> nothing)
+  (define-plot-type error-bars
+                    errs 2dplotview () ((color 'red))
+      (let* ((y-list (map vector-y errs))
+             (e-list (map vector-z errs))
+             (y-mins (map (lambda (y e) (- y e)) y-list e-list ))
+             (y-maxs (map (lambda (y e) (+ y e)) y-list e-list )))              
+        (send 2dplotview set-line-color color)
+        (send 2dplotview plot-y-errors (map vector (map vector-x errs)
+                                            y-mins y-maxs))))
+  
+
+  ; field : (vector -> vector) [number] [symbol] [number] [symbol] -> (2dplotview -> nothing)
+  ; plots a vector field
+  ; styles are 
+  ; scaled -> vector field with scaled vectors
+  ; normalized -> all vectors same size, indicates direction 
+  ; real -> all vectors drawn to scale
+  (define-plot-type vector-field
+     vfun 2dplotview 
+      (x-min x-max y-min y-max)
+      ([samples 20] [color 'black] [width 1] [style 'scaled])
+      (let* ((points (xy-list samples x-min x-max y-min y-max))
+             (results (map vfun points))
+             (new-results 
+              (case style                  
+                [(real) results]
+                [(scaled) (scale-vectors results
+                                         (sample-size samples x-min x-max)
+                                         (sample-size samples y-min y-max))]
+                [(normalized) (normalize-vectors
+                               results
+                               (sample-size samples x-min x-max)
+                               (sample-size samples y-min y-max))]
+                [else (error (string-append "Unknown vector field style passed to field-renderer: " (symbol->string style)))])))
+        (send* 2dplotview  
+          (set-line-color color) (set-line-width width)
+          (plot-vectors points new-results))))
+
+  ; contour : (nubmer number -> number) [number] [symbol] [number] [number u listof-number] ->  (2dplotview -> void)
+  ; renders a contour plot given function and contour levels
+  (define-plot-type contour
+                    fun3d 2dplotview 
+      (x-min x-max y-min y-max)
+      ((samples 50) (color 'black) (width 1) (levels 10))
+      (let* ((x-vals (x-values samples x-min x-max))
+             (y-vals (x-values samples y-min y-max))
+             (grid (zgrid fun3d x-vals y-vals samples))
+             (z-max (apply max (map (lambda (row) (apply max row)) grid)))
+             (z-min (apply min (map (lambda (row) (apply min row)) grid)))
+             (c-levels (if (list? levels) levels (x-values levels z-min z-max))))
+        (send* 2dplotview 
+          (set-line-color color) (set-line-width width)
+          (plot-contours grid x-vals y-vals c-levels))))
+           
+  ; shade : (number number -> number) [number] [symbol] [number] [number / listof-number] ->  (2dplotview -> nothing)
+  ; renders a shade plot given function and shade levels    
+  (define-plot-type shade
+                    fun3d 2dplotview (x-min x-max y-min y-max)
+                    ((samples 50) (levels 10))
+      (let* ((x-vals (x-values samples x-min x-max))
+             (y-vals (x-values samples y-min y-max))
+             (grid (zgrid fun3d x-vals y-vals samples))
+             (z-max (apply max (map (lambda (row) (apply max row)) grid)))
+             (z-min (apply min (map (lambda (row) (apply min row)) grid)))
+             (c-levels (x-values levels z-min z-max)))
+        (send* 2dplotview 
+          (plot-shades grid x-vals y-vals c-levels))))
+           
+  ; points : (listof vector) [symbol] -> (2dplotview -> nothing)
+  ; plots a set of points using a specific character
+  (define-plot-type points
+                    lop 2dplotview ((sym 'square) (color 'black))
+      (send* 2dplotview 
+       (set-line-color color)
+       (plot-points lop 
+		    (cond [(assq sym point-syms) => cadr]
+			  [else (error "Symbol not found in table!")]))))
+  
+  ; the symbol-> char table
+  (define point-syms
+    '((square 16) (odot 9) (bullet 17) (circle 4)))
+
+
+	
+       
+       
+  ;; 3D PLOTTERS
+  ; plot a surface
+  (define-plot-type surface 
+     fun3d 3dplotview (x-min x-max y-min y-max)
+     ((samples 50) (color 'black) (width '1))
+      (let* ((x-vals (x-values samples x-min x-max))
+             (y-vals (x-values samples y-min y-max))
+             (grid (zgrid fun3d x-vals y-vals samples)))
+          (send* 3dplotview 
+            (set-line-color color) (set-line-width width) 
+            (plot-surface x-vals y-vals grid))))
+  
+  (define-plot-type mesh3d
+     fun3d 3dplotview (x-min x-max y-min y-max z-min z-max)
+     ((samples 50) (width '1) (levels 10) (color #t) (lines #t)
+      (contours #t) (sides #f))
+      (let* ((x-vals (x-values samples x-min x-max))
+             (y-vals (x-values samples y-min y-max))
+             (grid (zgrid fun3d x-vals y-vals samples))
+             (c-levels (if (list? levels) levels (x-values levels z-min z-max))))
+          (send* 3dplotview 
+            (set-line-width width) 
+            (plot-3dmesh x-vals y-vals grid lines color contours sides c-levels))))
+  
+  (provide (all-defined)))
+
+  
diff --git a/collects/plot/src/all/adler32.c b/collects/plot/src/all/adler32.c
new file mode 100644
index 0000000000..07503edd95
--- /dev/null
+++ b/collects/plot/src/all/adler32.c
@@ -0,0 +1,48 @@
+/* adler32.c -- compute the Adler-32 checksum of a data stream
+ * Copyright (C) 1995-2002 Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h 
+ */
+
+/* @(#) $Id: adler32.c,v 1.1 2004/03/01 20:54:45 cozmic Exp $ */
+
+#include "zlib.h"
+
+#define BASE 65521L /* largest prime smaller than 65536 */
+#define NMAX 5552
+/* NMAX is the largest n such that 255n(n+1)/2 + (n+1)(BASE-1) <= 2^32-1 */
+
+#define DO1(buf,i)  {s1 += buf[i]; s2 += s1;}
+#define DO2(buf,i)  DO1(buf,i); DO1(buf,i+1);
+#define DO4(buf,i)  DO2(buf,i); DO2(buf,i+2);
+#define DO8(buf,i)  DO4(buf,i); DO4(buf,i+4);
+#define DO16(buf)   DO8(buf,0); DO8(buf,8);
+
+/* ========================================================================= */
+uLong ZEXPORT adler32(adler, buf, len)
+    uLong adler;
+    const Bytef *buf;
+    uInt len;
+{
+    unsigned long s1 = adler & 0xffff;
+    unsigned long s2 = (adler >> 16) & 0xffff;
+    int k;
+
+    if (buf == Z_NULL) return 1L;
+
+    while (len > 0) {
+        k = len < NMAX ? len : NMAX;
+        len -= k;
+        while (k >= 16) {
+            DO16(buf);
+	    buf += 16;
+            k -= 16;
+        }
+        if (k != 0) do {
+            s1 += *buf++;
+	    s2 += s1;
+        } while (--k);
+        s1 %= BASE;
+        s2 %= BASE;
+    }
+    return (s2 << 16) | s1;
+}
diff --git a/collects/plot/src/all/compress.c b/collects/plot/src/all/compress.c
new file mode 100644
index 0000000000..a28c37ea08
--- /dev/null
+++ b/collects/plot/src/all/compress.c
@@ -0,0 +1,68 @@
+/* compress.c -- compress a memory buffer
+ * Copyright (C) 1995-2002 Jean-loup Gailly.
+ * For conditions of distribution and use, see copyright notice in zlib.h 
+ */
+
+/* @(#) $Id: compress.c,v 1.1 2004/03/01 20:54:45 cozmic Exp $ */
+
+#include "zlib.h"
+
+/* ===========================================================================
+     Compresses the source buffer into the destination buffer. The level
+   parameter has the same meaning as in deflateInit.  sourceLen is the byte
+   length of the source buffer. Upon entry, destLen is the total size of the
+   destination buffer, which must be at least 0.1% larger than sourceLen plus
+   12 bytes. Upon exit, destLen is the actual size of the compressed buffer.
+
+     compress2 returns Z_OK if success, Z_MEM_ERROR if there was not enough
+   memory, Z_BUF_ERROR if there was not enough room in the output buffer,
+   Z_STREAM_ERROR if the level parameter is invalid.
+*/
+int ZEXPORT compress2 (dest, destLen, source, sourceLen, level)
+    Bytef *dest;
+    uLongf *destLen;
+    const Bytef *source;
+    uLong sourceLen;
+    int level;
+{
+    z_stream stream;
+    int err;
+
+    stream.next_in = (Bytef*)source;
+    stream.avail_in = (uInt)sourceLen;
+#ifdef MAXSEG_64K
+    /* Check for source > 64K on 16-bit machine: */
+    if ((uLong)stream.avail_in != sourceLen) return Z_BUF_ERROR;
+#endif
+    stream.next_out = dest;
+    stream.avail_out = (uInt)*destLen;
+    if ((uLong)stream.avail_out != *destLen) return Z_BUF_ERROR;
+
+    stream.zalloc = (alloc_func)0;
+    stream.zfree = (free_func)0;
+    stream.opaque = (voidpf)0;
+
+    err = deflateInit(&stream, level);
+    if (err != Z_OK) return err;
+
+    err = deflate(&stream, Z_FINISH);
+    if (err != Z_STREAM_END) {
+        deflateEnd(&stream);
+        return err == Z_OK ? Z_BUF_ERROR : err;
+    }
+    *destLen = stream.total_out;
+
+    err = deflateEnd(&stream);
+    return err;
+}
+
+/* ===========================================================================
+ */
+int ZEXPORT compress (dest, destLen, source, sourceLen)
+    Bytef *dest;
+    uLongf *destLen;
+    const Bytef *source;
+    uLong sourceLen;
+{
+    return compress2(dest, destLen, source, sourceLen, Z_DEFAULT_COMPRESSION);
+}
diff --git a/collects/plot/src/all/crc32.c b/collects/plot/src/all/crc32.c
new file mode 100644
index 0000000000..5380ea9278
--- /dev/null
+++ b/collects/plot/src/all/crc32.c
@@ -0,0 +1,162 @@
+/* crc32.c -- compute the CRC-32 of a data stream
+ * Copyright (C) 1995-2002 Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h 
+ */
+
+/* @(#) $Id: crc32.c,v 1.1 2004/03/01 20:54:46 cozmic Exp $ */
+
+#include "zlib.h"
+
+#define local static
+
+#ifdef DYNAMIC_CRC_TABLE
+
+local int crc_table_empty = 1;
+local uLongf crc_table[256];
+local void make_crc_table OF((void));
+
+/*
+  Generate a table for a byte-wise 32-bit CRC calculation on the polynomial:
+  x^32+x^26+x^23+x^22+x^16+x^12+x^11+x^10+x^8+x^7+x^5+x^4+x^2+x+1.
+
+  Polynomials over GF(2) are represented in binary, one bit per coefficient,
+  with the lowest powers in the most significant bit.  Then adding polynomials
+  is just exclusive-or, and multiplying a polynomial by x is a right shift by
+  one.  If we call the above polynomial p, and represent a byte as the
+  polynomial q, also with the lowest power in the most significant bit (so the
+  byte 0xb1 is the polynomial x^7+x^3+x+1), then the CRC is (q*x^32) mod p,
+  where a mod b means the remainder after dividing a by b.
+
+  This calculation is done using the shift-register method of multiplying and
+  taking the remainder.  The register is initialized to zero, and for each
+  incoming bit, x^32 is added mod p to the register if the bit is a one (where
+  x^32 mod p is p+x^32 = x^26+...+1), and the register is multiplied mod p by
+  x (which is shifting right by one and adding x^32 mod p if the bit shifted
+  out is a one).  We start with the highest power (least significant bit) of
+  q and repeat for all eight bits of q.
+
+  The table is simply the CRC of all possible eight bit values.  This is all
+  the information needed to generate CRC's on data a byte at a time for all
+  combinations of CRC register values and incoming bytes.
+*/
+local void make_crc_table()
+{
+  uLong c;
+  int n, k;
+  uLong poly;            /* polynomial exclusive-or pattern */
+  /* terms of polynomial defining this crc (except x^32): */
+  static const Byte p[] = {0,1,2,4,5,7,8,10,11,12,16,22,23,26};
+
+  /* make exclusive-or pattern from polynomial (0xedb88320L) */
+  poly = 0L;
+  for (n = 0; n < sizeof(p)/sizeof(Byte); n++)
+    poly |= 1L << (31 - p[n]);
+ 
+  for (n = 0; n < 256; n++)
+  {
+    c = (uLong)n;
+    for (k = 0; k < 8; k++)
+      c = c & 1 ? poly ^ (c >> 1) : c >> 1;
+    crc_table[n] = c;
+  }
+  crc_table_empty = 0;
+}
+#else
+/* ========================================================================
+ * Table of CRC-32's of all single-byte values (made by make_crc_table)
+ */
+local const uLongf crc_table[256] = {
+  0x00000000L, 0x77073096L, 0xee0e612cL, 0x990951baL, 0x076dc419L,
+  0x706af48fL, 0xe963a535L, 0x9e6495a3L, 0x0edb8832L, 0x79dcb8a4L,
+  0xe0d5e91eL, 0x97d2d988L, 0x09b64c2bL, 0x7eb17cbdL, 0xe7b82d07L,
+  0x90bf1d91L, 0x1db71064L, 0x6ab020f2L, 0xf3b97148L, 0x84be41deL,
+  0x1adad47dL, 0x6ddde4ebL, 0xf4d4b551L, 0x83d385c7L, 0x136c9856L,
+  0x646ba8c0L, 0xfd62f97aL, 0x8a65c9ecL, 0x14015c4fL, 0x63066cd9L,
+  0xfa0f3d63L, 0x8d080df5L, 0x3b6e20c8L, 0x4c69105eL, 0xd56041e4L,
+  0xa2677172L, 0x3c03e4d1L, 0x4b04d447L, 0xd20d85fdL, 0xa50ab56bL,
+  0x35b5a8faL, 0x42b2986cL, 0xdbbbc9d6L, 0xacbcf940L, 0x32d86ce3L,
+  0x45df5c75L, 0xdcd60dcfL, 0xabd13d59L, 0x26d930acL, 0x51de003aL,
+  0xc8d75180L, 0xbfd06116L, 0x21b4f4b5L, 0x56b3c423L, 0xcfba9599L,
+  0xb8bda50fL, 0x2802b89eL, 0x5f058808L, 0xc60cd9b2L, 0xb10be924L,
+  0x2f6f7c87L, 0x58684c11L, 0xc1611dabL, 0xb6662d3dL, 0x76dc4190L,
+  0x01db7106L, 0x98d220bcL, 0xefd5102aL, 0x71b18589L, 0x06b6b51fL,
+  0x9fbfe4a5L, 0xe8b8d433L, 0x7807c9a2L, 0x0f00f934L, 0x9609a88eL,
+  0xe10e9818L, 0x7f6a0dbbL, 0x086d3d2dL, 0x91646c97L, 0xe6635c01L,
+  0x6b6b51f4L, 0x1c6c6162L, 0x856530d8L, 0xf262004eL, 0x6c0695edL,
+  0x1b01a57bL, 0x8208f4c1L, 0xf50fc457L, 0x65b0d9c6L, 0x12b7e950L,
+  0x8bbeb8eaL, 0xfcb9887cL, 0x62dd1ddfL, 0x15da2d49L, 0x8cd37cf3L,
+  0xfbd44c65L, 0x4db26158L, 0x3ab551ceL, 0xa3bc0074L, 0xd4bb30e2L,
+  0x4adfa541L, 0x3dd895d7L, 0xa4d1c46dL, 0xd3d6f4fbL, 0x4369e96aL,
+  0x346ed9fcL, 0xad678846L, 0xda60b8d0L, 0x44042d73L, 0x33031de5L,
+  0xaa0a4c5fL, 0xdd0d7cc9L, 0x5005713cL, 0x270241aaL, 0xbe0b1010L,
+  0xc90c2086L, 0x5768b525L, 0x206f85b3L, 0xb966d409L, 0xce61e49fL,
+  0x5edef90eL, 0x29d9c998L, 0xb0d09822L, 0xc7d7a8b4L, 0x59b33d17L,
+  0x2eb40d81L, 0xb7bd5c3bL, 0xc0ba6cadL, 0xedb88320L, 0x9abfb3b6L,
+  0x03b6e20cL, 0x74b1d29aL, 0xead54739L, 0x9dd277afL, 0x04db2615L,
+  0x73dc1683L, 0xe3630b12L, 0x94643b84L, 0x0d6d6a3eL, 0x7a6a5aa8L,
+  0xe40ecf0bL, 0x9309ff9dL, 0x0a00ae27L, 0x7d079eb1L, 0xf00f9344L,
+  0x8708a3d2L, 0x1e01f268L, 0x6906c2feL, 0xf762575dL, 0x806567cbL,
+  0x196c3671L, 0x6e6b06e7L, 0xfed41b76L, 0x89d32be0L, 0x10da7a5aL,
+  0x67dd4accL, 0xf9b9df6fL, 0x8ebeeff9L, 0x17b7be43L, 0x60b08ed5L,
+  0xd6d6a3e8L, 0xa1d1937eL, 0x38d8c2c4L, 0x4fdff252L, 0xd1bb67f1L,
+  0xa6bc5767L, 0x3fb506ddL, 0x48b2364bL, 0xd80d2bdaL, 0xaf0a1b4cL,
+  0x36034af6L, 0x41047a60L, 0xdf60efc3L, 0xa867df55L, 0x316e8eefL,
+  0x4669be79L, 0xcb61b38cL, 0xbc66831aL, 0x256fd2a0L, 0x5268e236L,
+  0xcc0c7795L, 0xbb0b4703L, 0x220216b9L, 0x5505262fL, 0xc5ba3bbeL,
+  0xb2bd0b28L, 0x2bb45a92L, 0x5cb36a04L, 0xc2d7ffa7L, 0xb5d0cf31L,
+  0x2cd99e8bL, 0x5bdeae1dL, 0x9b64c2b0L, 0xec63f226L, 0x756aa39cL,
+  0x026d930aL, 0x9c0906a9L, 0xeb0e363fL, 0x72076785L, 0x05005713L,
+  0x95bf4a82L, 0xe2b87a14L, 0x7bb12baeL, 0x0cb61b38L, 0x92d28e9bL,
+  0xe5d5be0dL, 0x7cdcefb7L, 0x0bdbdf21L, 0x86d3d2d4L, 0xf1d4e242L,
+  0x68ddb3f8L, 0x1fda836eL, 0x81be16cdL, 0xf6b9265bL, 0x6fb077e1L,
+  0x18b74777L, 0x88085ae6L, 0xff0f6a70L, 0x66063bcaL, 0x11010b5cL,
+  0x8f659effL, 0xf862ae69L, 0x616bffd3L, 0x166ccf45L, 0xa00ae278L,
+  0xd70dd2eeL, 0x4e048354L, 0x3903b3c2L, 0xa7672661L, 0xd06016f7L,
+  0x4969474dL, 0x3e6e77dbL, 0xaed16a4aL, 0xd9d65adcL, 0x40df0b66L,
+  0x37d83bf0L, 0xa9bcae53L, 0xdebb9ec5L, 0x47b2cf7fL, 0x30b5ffe9L,
+  0xbdbdf21cL, 0xcabac28aL, 0x53b39330L, 0x24b4a3a6L, 0xbad03605L,
+  0xcdd70693L, 0x54de5729L, 0x23d967bfL, 0xb3667a2eL, 0xc4614ab8L,
+  0x5d681b02L, 0x2a6f2b94L, 0xb40bbe37L, 0xc30c8ea1L, 0x5a05df1bL,
+  0x2d02ef8dL
+};
+#endif
+
+/* =========================================================================
+ * This function can be used by asm versions of crc32()
+ */
+const uLongf * ZEXPORT get_crc_table()
+{
+#ifdef DYNAMIC_CRC_TABLE
+  if (crc_table_empty) make_crc_table();
+#endif
+  return (const uLongf *)crc_table;
+}
+
+/* ========================================================================= */
+#define DO1(buf) crc = crc_table[((int)crc ^ (*buf++)) & 0xff] ^ (crc >> 8);
+#define DO2(buf)  DO1(buf); DO1(buf);
+#define DO4(buf)  DO2(buf); DO2(buf);
+#define DO8(buf)  DO4(buf); DO4(buf);
+
+/* ========================================================================= */
+uLong ZEXPORT crc32(crc, buf, len)
+    uLong crc;
+    const Bytef *buf;
+    uInt len;
+{
+    if (buf == Z_NULL) return 0L;
+#ifdef DYNAMIC_CRC_TABLE
+    if (crc_table_empty)
+      make_crc_table();
+#endif
+    crc = crc ^ 0xffffffffL;
+    while (len >= 8)
+    {
+      DO8(buf);
+      len -= 8;
+    }
+    if (len) do {
+      DO1(buf);
+    } while (--len);
+    return crc ^ 0xffffffffL;
+}
diff --git a/collects/plot/src/all/csa.h b/collects/plot/src/all/csa.h
new file mode 100644
index 0000000000..651ef97848
--- /dev/null
+++ b/collects/plot/src/all/csa.h
@@ -0,0 +1,46 @@
+/******************************************************************************
+ *
+ * File:           csa.h
+ *
+ * Created:        16/10/2002
+ *
+ * Author:         Pavel Sakov
+ *                 CSIRO Marine Research
+ *
+ * Purpose:        A header for csa library (2D data approximation with
+ *                 bivariate cubic spline)
+ *
+ * Revisions:      None
+ *
+ *****************************************************************************/
+
+#if !defined(_CSA_H)
+#define _CSA_H
+
+#if !defined(_POINT_STRUCT)
+#define _POINT_STRUCT
+typedef struct {
+    double x;
+    double y;
+    double z;
+} point;
+#endif
+
+extern int csa_verbose;
+extern char* csa_version;
+
+struct csa;
+typedef struct csa csa;
+
+csa* csa_create();
+void csa_destroy(csa* a);
+void csa_addpoints(csa* a, int n, point points[]);
+void csa_calculatespline(csa* a);
+void csa_approximate_point(csa* a, point* p);
+void csa_approximate_points(csa* a, int n, point* points);
+
+void csa_setnmin(csa* a, int nmin);
+void csa_setnmax(csa* a, int nmax);
+void csa_setk(csa* a, int k);
+
+#endif
diff --git a/collects/plot/src/all/csa_internal.h b/collects/plot/src/all/csa_internal.h
new file mode 100644
index 0000000000..1a06dbf724
--- /dev/null
+++ b/collects/plot/src/all/csa_internal.h
@@ -0,0 +1,99 @@
+/******************************************************************************
+ *
+ * File:           csa.h
+ *
+ * Created:        16/10/2002
+ *
+ * Author:         Pavel Sakov
+ *                 CSIRO Marine Research
+ *
+ * Purpose:        An "internal" header for csa library (2D data approximation
+ *                 with bivariate cubic spline)
+ *
+ * Revisions:      None
+ *
+ *****************************************************************************/
+
+#if !defined(_CSA_INTERNAL_H)
+#define _CSA_INTERNAL_H
+
+#include "csa.h"
+
+struct square;
+typedef struct square square;
+
+typedef struct {
+    square* parent;
+    int index;                  /* index within parent square; 0 <= index <= 
+                                 * 3 */
+    point vertices[3];
+    point middle;               /* barycenter */
+    double h;                   /* parent square edge length */
+    double r;                   /* data visibility radius */
+
+    /*
+     * points used -- in primary triangles only 
+     */
+    int nallocated;
+    int npoints;
+    point** points;
+
+    int primary;                /* flag -- whether calculate spline
+                                 * coefficients directly (by least squares
+                                 * method) (primary = 1) or indirectly (from 
+                                 * * C1 smoothness conditions) (primary = 0) 
+                                 */
+    int hascoeffs;              /* flag -- whether there are no NaNs among
+                                 * the spline coefficients */
+    int order;                  /* spline order -- for primary triangles
+                                 * only */
+} triangle;
+
+struct square {
+    csa* parent;
+    int i, j;                   /* indices */
+
+    int nallocated;
+    int npoints;
+    point** points;
+
+    int primary;                /* flag -- whether this square contains a
+                                 * primary triangle */
+
+    triangle* triangles[4];
+
+    double coeffs[25];
+};
+
+struct csa {
+    int verbose;                /* flag */
+
+    double xmin;
+    double xmax;
+    double ymin;
+    double ymax;
+
+    int nallocated;
+    int npoints;
+    point** points;
+
+    /*
+     * squarization 
+     */
+    int ni;
+    int nj;
+    double h;
+    square*** squares;          /* square* [j][i] */
+
+    int npt;                    /* Number of Primary Triangles */
+    triangle** pt;              /* Primary Triangles -- triangle* [npt] */
+
+    /*
+     * algorithm parameters 
+     */
+    int nmin;
+    int nmax;
+    double k;
+};
+
+#endif
diff --git a/collects/plot/src/all/deflate.c b/collects/plot/src/all/deflate.c
new file mode 100644
index 0000000000..dde41bad11
--- /dev/null
+++ b/collects/plot/src/all/deflate.c
@@ -0,0 +1,1350 @@
+/* deflate.c -- compress data using the deflation algorithm
+ * Copyright (C) 1995-2002 Jean-loup Gailly.
+ * For conditions of distribution and use, see copyright notice in zlib.h 
+ */
+
+/*
+ *  ALGORITHM
+ *
+ *      The "deflation" process depends on being able to identify portions
+ *      of the input text which are identical to earlier input (within a
+ *      sliding window trailing behind the input currently being processed).
+ *
+ *      The most straightforward technique turns out to be the fastest for
+ *      most input files: try all possible matches and select the longest.
+ *      The key feature of this algorithm is that insertions into the string
+ *      dictionary are very simple and thus fast, and deletions are avoided
+ *      completely. Insertions are performed at each input character, whereas
+ *      string matches are performed only when the previous match ends. So it
+ *      is preferable to spend more time in matches to allow very fast string
+ *      insertions and avoid deletions. The matching algorithm for small
+ *      strings is inspired from that of Rabin & Karp. A brute force approach
+ *      is used to find longer strings when a small match has been found.
+ *      A similar algorithm is used in comic (by Jan-Mark Wams) and freeze
+ *      (by Leonid Broukhis).
+ *         A previous version of this file used a more sophisticated algorithm
+ *      (by Fiala and Greene) which is guaranteed to run in linear amortized
+ *      time, but has a larger average cost, uses more memory and is patented.
+ *      However the F&G algorithm may be faster for some highly redundant
+ *      files if the parameter max_chain_length (described below) is too large.
+ *
+ *  ACKNOWLEDGEMENTS
+ *
+ *      The idea of lazy evaluation of matches is due to Jan-Mark Wams, and
+ *      I found it in 'freeze' written by Leonid Broukhis.
+ *      Thanks to many people for bug reports and testing.
+ *
+ *  REFERENCES
+ *
+ *      Deutsch, L.P.,"DEFLATE Compressed Data Format Specification".
+ *      Available in ftp://ds.internic.net/rfc/rfc1951.txt
+ *
+ *      A description of the Rabin and Karp algorithm is given in the book
+ *         "Algorithms" by R. Sedgewick, Addison-Wesley, p252.
+ *
+ *      Fiala,E.R., and Greene,D.H.
+ *         Data Compression with Finite Windows, Comm.ACM, 32,4 (1989) 490-595
+ *
+ */
+
+/* @(#) $Id: deflate.c,v 1.1 2004/03/01 20:54:46 cozmic Exp $ */
+
+#include "deflate.h"
+
+const char deflate_copyright[] =
+   " deflate 1.1.4 Copyright 1995-2002 Jean-loup Gailly ";
+/*
+  If you use the zlib library in a product, an acknowledgment is welcome
+  in the documentation of your product. If for some reason you cannot
+  include such an acknowledgment, I would appreciate that you keep this
+  copyright string in the executable of your product.
+ */
+
+/* ===========================================================================
+ *  Function prototypes.
+ */
+typedef enum {
+    need_more,      /* block not completed, need more input or more output */
+    block_done,     /* block flush performed */
+    finish_started, /* finish started, need only more output at next deflate */
+    finish_done     /* finish done, accept no more input or output */
+} block_state;
+
+typedef block_state (*compress_func) OF((deflate_state *s, int flush));
+/* Compression function. Returns the block state after the call. */
+
+local void fill_window    OF((deflate_state *s));
+local block_state deflate_stored OF((deflate_state *s, int flush));
+local block_state deflate_fast   OF((deflate_state *s, int flush));
+local block_state deflate_slow   OF((deflate_state *s, int flush));
+local void lm_init        OF((deflate_state *s));
+local void putShortMSB    OF((deflate_state *s, uInt b));
+local void flush_pending  OF((z_streamp strm));
+local int read_buf        OF((z_streamp strm, Bytef *buf, unsigned size));
+#ifdef ASMV
+      void match_init OF((void)); /* asm code initialization */
+      uInt longest_match  OF((deflate_state *s, IPos cur_match));
+#else
+local uInt longest_match  OF((deflate_state *s, IPos cur_match));
+#endif
+
+#ifdef DEBUG
+local  void check_match OF((deflate_state *s, IPos start, IPos match,
+                            int length));
+#endif
+
+/* ===========================================================================
+ * Local data
+ */
+
+#define NIL 0
+/* Tail of hash chains */
+
+#ifndef TOO_FAR
+#  define TOO_FAR 4096
+#endif
+/* Matches of length 3 are discarded if their distance exceeds TOO_FAR */
+
+#define MIN_LOOKAHEAD (MAX_MATCH+MIN_MATCH+1)
+/* Minimum amount of lookahead, except at the end of the input file.
+ * See deflate.c for comments about the MIN_MATCH+1.
+ */
+
+/* Values for max_lazy_match, good_match and max_chain_length, depending on
+ * the desired pack level (0..9). The values given below have been tuned to
+ * exclude worst case performance for pathological files. Better values may be
+ * found for specific files.
+ */
+typedef struct config_s {
+   ush good_length; /* reduce lazy search above this match length */
+   ush max_lazy;    /* do not perform lazy search above this match length */
+   ush nice_length; /* quit search above this match length */
+   ush max_chain;
+   compress_func func;
+} config;
+
+local const config configuration_table[10] = {
+/*      good lazy nice chain */
+/* 0 */ {0,    0,  0,    0, deflate_stored},  /* store only */
+/* 1 */ {4,    4,  8,    4, deflate_fast}, /* maximum speed, no lazy matches */
+/* 2 */ {4,    5, 16,    8, deflate_fast},
+/* 3 */ {4,    6, 32,   32, deflate_fast},
+
+/* 4 */ {4,    4, 16,   16, deflate_slow},  /* lazy matches */
+/* 5 */ {8,   16, 32,   32, deflate_slow},
+/* 6 */ {8,   16, 128, 128, deflate_slow},
+/* 7 */ {8,   32, 128, 256, deflate_slow},
+/* 8 */ {32, 128, 258, 1024, deflate_slow},
+/* 9 */ {32, 258, 258, 4096, deflate_slow}}; /* maximum compression */
+
+/* Note: the deflate() code requires max_lazy >= MIN_MATCH and max_chain >= 4
+ * For deflate_fast() (levels <= 3) good is ignored and lazy has a different
+ * meaning.
+ */
+
+#define EQUAL 0
+/* result of memcmp for equal strings */
+
+struct static_tree_desc_s {int dummy;}; /* for buggy compilers */
+
+/* ===========================================================================
+ * Update a hash value with the given input byte
+ * IN  assertion: all calls to to UPDATE_HASH are made with consecutive
+ *    input characters, so that a running hash key can be computed from the
+ *    previous key instead of complete recalculation each time.
+ */
+#define UPDATE_HASH(s,h,c) (h = (((h)<<s->hash_shift) ^ (c)) & s->hash_mask)
+
+
+/* ===========================================================================
+ * Insert string str in the dictionary and set match_head to the previous head
+ * of the hash chain (the most recent string with same hash key). Return
+ * the previous length of the hash chain.
+ * If this file is compiled with -DFASTEST, the compression level is forced
+ * to 1, and no hash chains are maintained.
+ * IN  assertion: all calls to to INSERT_STRING are made with consecutive
+ *    input characters and the first MIN_MATCH bytes of str are valid
+ *    (except for the last MIN_MATCH-1 bytes of the input file).
+ */
+#ifdef FASTEST
+#define INSERT_STRING(s, str, match_head) \
+   (UPDATE_HASH(s, s->ins_h, s->window[(str) + (MIN_MATCH-1)]), \
+    match_head = s->head[s->ins_h], \
+    s->head[s->ins_h] = (Pos)(str))
+#else
+#define INSERT_STRING(s, str, match_head) \
+   (UPDATE_HASH(s, s->ins_h, s->window[(str) + (MIN_MATCH-1)]), \
+    s->prev[(str) & s->w_mask] = match_head = s->head[s->ins_h], \
+    s->head[s->ins_h] = (Pos)(str))
+#endif
+
+/* ===========================================================================
+ * Initialize the hash table (avoiding 64K overflow for 16 bit systems).
+ * prev[] will be initialized on the fly.
+ */
+#define CLEAR_HASH(s) \
+    s->head[s->hash_size-1] = NIL; \
+    zmemzero((Bytef *)s->head, (unsigned)(s->hash_size-1)*sizeof(*s->head));
+
+/* ========================================================================= */
+int ZEXPORT deflateInit_(strm, level, version, stream_size)
+    z_streamp strm;
+    int level;
+    const char *version;
+    int stream_size;
+{
+    return deflateInit2_(strm, level, Z_DEFLATED, MAX_WBITS, DEF_MEM_LEVEL,
+			 Z_DEFAULT_STRATEGY, version, stream_size);
+    /* To do: ignore strm->next_in if we use it as window */
+}
+
+/* ========================================================================= */
+int ZEXPORT deflateInit2_(strm, level, method, windowBits, memLevel, strategy,
+		  version, stream_size)
+    z_streamp strm;
+    int  level;
+    int  method;
+    int  windowBits;
+    int  memLevel;
+    int  strategy;
+    const char *version;
+    int stream_size;
+{
+    deflate_state *s;
+    int noheader = 0;
+    static const char* my_version = ZLIB_VERSION;
+
+    ushf *overlay;
+    /* We overlay pending_buf and d_buf+l_buf. This works since the average
+     * output size for (length,distance) codes is <= 24 bits.
+     */
+
+    if (version == Z_NULL || version[0] != my_version[0] ||
+        stream_size != sizeof(z_stream)) {
+	return Z_VERSION_ERROR;
+    }
+    if (strm == Z_NULL) return Z_STREAM_ERROR;
+
+    strm->msg = Z_NULL;
+    if (strm->zalloc == Z_NULL) {
+	strm->zalloc = zcalloc;
+	strm->opaque = (voidpf)0;
+    }
+    if (strm->zfree == Z_NULL) strm->zfree = zcfree;
+
+    if (level == Z_DEFAULT_COMPRESSION) level = 6;
+#ifdef FASTEST
+    level = 1;
+#endif
+
+    if (windowBits < 0) { /* undocumented feature: suppress zlib header */
+        noheader = 1;
+        windowBits = -windowBits;
+    }
+    if (memLevel < 1 || memLevel > MAX_MEM_LEVEL || method != Z_DEFLATED ||
+        windowBits < 9 || windowBits > 15 || level < 0 || level > 9 ||
+	strategy < 0 || strategy > Z_HUFFMAN_ONLY) {
+        return Z_STREAM_ERROR;
+    }
+    s = (deflate_state *) ZALLOC(strm, 1, sizeof(deflate_state));
+    if (s == Z_NULL) return Z_MEM_ERROR;
+    strm->state = (struct internal_state FAR *)s;
+    s->strm = strm;
+
+    s->noheader = noheader;
+    s->w_bits = windowBits;
+    s->w_size = 1 << s->w_bits;
+    s->w_mask = s->w_size - 1;
+
+    s->hash_bits = memLevel + 7;
+    s->hash_size = 1 << s->hash_bits;
+    s->hash_mask = s->hash_size - 1;
+    s->hash_shift =  ((s->hash_bits+MIN_MATCH-1)/MIN_MATCH);
+
+    s->window = (Bytef *) ZALLOC(strm, s->w_size, 2*sizeof(Byte));
+    s->prev   = (Posf *)  ZALLOC(strm, s->w_size, sizeof(Pos));
+    s->head   = (Posf *)  ZALLOC(strm, s->hash_size, sizeof(Pos));
+
+    s->lit_bufsize = 1 << (memLevel + 6); /* 16K elements by default */
+
+    overlay = (ushf *) ZALLOC(strm, s->lit_bufsize, sizeof(ush)+2);
+    s->pending_buf = (uchf *) overlay;
+    s->pending_buf_size = (ulg)s->lit_bufsize * (sizeof(ush)+2L);
+
+    if (s->window == Z_NULL || s->prev == Z_NULL || s->head == Z_NULL ||
+        s->pending_buf == Z_NULL) {
+        strm->msg = (char*)ERR_MSG(Z_MEM_ERROR);
+        deflateEnd (strm);
+        return Z_MEM_ERROR;
+    }
+    s->d_buf = overlay + s->lit_bufsize/sizeof(ush);
+    s->l_buf = s->pending_buf + (1+sizeof(ush))*s->lit_bufsize;
+
+    s->level = level;
+    s->strategy = strategy;
+    s->method = (Byte)method;
+
+    return deflateReset(strm);
+}
+
+/* ========================================================================= */
+int ZEXPORT deflateSetDictionary (strm, dictionary, dictLength)
+    z_streamp strm;
+    const Bytef *dictionary;
+    uInt  dictLength;
+{
+    deflate_state *s;
+    uInt length = dictLength;
+    uInt n;
+    IPos hash_head = 0;
+
+    if (strm == Z_NULL || strm->state == Z_NULL || dictionary == Z_NULL ||
+        strm->state->status != INIT_STATE) return Z_STREAM_ERROR;
+
+    s = strm->state;
+    strm->adler = adler32(strm->adler, dictionary, dictLength);
+
+    if (length < MIN_MATCH) return Z_OK;
+    if (length > MAX_DIST(s)) {
+	length = MAX_DIST(s);
+#ifndef USE_DICT_HEAD
+	dictionary += dictLength - length; /* use the tail of the dictionary */
+#endif
+    }
+    zmemcpy(s->window, dictionary, length);
+    s->strstart = length;
+    s->block_start = (long)length;
+
+    /* Insert all strings in the hash table (except for the last two bytes).
+     * s->lookahead stays null, so s->ins_h will be recomputed at the next
+     * call of fill_window.
+     */
+    s->ins_h = s->window[0];
+    UPDATE_HASH(s, s->ins_h, s->window[1]);
+    for (n = 0; n <= length - MIN_MATCH; n++) {
+	INSERT_STRING(s, n, hash_head);
+    }
+    if (hash_head) hash_head = 0;  /* to make compiler happy */
+    return Z_OK;
+}
+
+/* ========================================================================= */
+int ZEXPORT deflateReset (strm)
+    z_streamp strm;
+{
+    deflate_state *s;
+    
+    if (strm == Z_NULL || strm->state == Z_NULL ||
+        strm->zalloc == Z_NULL || strm->zfree == Z_NULL) return Z_STREAM_ERROR;
+
+    strm->total_in = strm->total_out = 0;
+    strm->msg = Z_NULL; /* use zfree if we ever allocate msg dynamically */
+    strm->data_type = Z_UNKNOWN;
+
+    s = (deflate_state *)strm->state;
+    s->pending = 0;
+    s->pending_out = s->pending_buf;
+
+    if (s->noheader < 0) {
+        s->noheader = 0; /* was set to -1 by deflate(..., Z_FINISH); */
+    }
+    s->status = s->noheader ? BUSY_STATE : INIT_STATE;
+    strm->adler = 1;
+    s->last_flush = Z_NO_FLUSH;
+
+    _tr_init(s);
+    lm_init(s);
+
+    return Z_OK;
+}
+
+/* ========================================================================= */
+int ZEXPORT deflateParams(strm, level, strategy)
+    z_streamp strm;
+    int level;
+    int strategy;
+{
+    deflate_state *s;
+    compress_func func;
+    int err = Z_OK;
+
+    if (strm == Z_NULL || strm->state == Z_NULL) return Z_STREAM_ERROR;
+    s = strm->state;
+
+    if (level == Z_DEFAULT_COMPRESSION) {
+	level = 6;
+    }
+    if (level < 0 || level > 9 || strategy < 0 || strategy > Z_HUFFMAN_ONLY) {
+	return Z_STREAM_ERROR;
+    }
+    func = configuration_table[s->level].func;
+
+    if (func != configuration_table[level].func && strm->total_in != 0) {
+	/* Flush the last buffer: */
+	err = deflate(strm, Z_PARTIAL_FLUSH);
+    }
+    if (s->level != level) {
+	s->level = level;
+	s->max_lazy_match   = configuration_table[level].max_lazy;
+	s->good_match       = configuration_table[level].good_length;
+	s->nice_match       = configuration_table[level].nice_length;
+	s->max_chain_length = configuration_table[level].max_chain;
+    }
+    s->strategy = strategy;
+    return err;
+}
+
+/* =========================================================================
+ * Put a short in the pending buffer. The 16-bit value is put in MSB order.
+ * IN assertion: the stream state is correct and there is enough room in
+ * pending_buf.
+ */
+local void putShortMSB (s, b)
+    deflate_state *s;
+    uInt b;
+{
+    put_byte(s, (Byte)(b >> 8));
+    put_byte(s, (Byte)(b & 0xff));
+}   
+
+/* =========================================================================
+ * Flush as much pending output as possible. All deflate() output goes
+ * through this function so some applications may wish to modify it
+ * to avoid allocating a large strm->next_out buffer and copying into it.
+ * (See also read_buf()).
+ */
+local void flush_pending(strm)
+    z_streamp strm;
+{
+    unsigned len = strm->state->pending;
+
+    if (len > strm->avail_out) len = strm->avail_out;
+    if (len == 0) return;
+
+    zmemcpy(strm->next_out, strm->state->pending_out, len);
+    strm->next_out  += len;
+    strm->state->pending_out  += len;
+    strm->total_out += len;
+    strm->avail_out  -= len;
+    strm->state->pending -= len;
+    if (strm->state->pending == 0) {
+        strm->state->pending_out = strm->state->pending_buf;
+    }
+}
+
+/* ========================================================================= */
+int ZEXPORT deflate (strm, flush)
+    z_streamp strm;
+    int flush;
+{
+    int old_flush; /* value of flush param for previous deflate call */
+    deflate_state *s;
+
+    if (strm == Z_NULL || strm->state == Z_NULL ||
+	flush > Z_FINISH || flush < 0) {
+        return Z_STREAM_ERROR;
+    }
+    s = strm->state;
+
+    if (strm->next_out == Z_NULL ||
+        (strm->next_in == Z_NULL && strm->avail_in != 0) ||
+	(s->status == FINISH_STATE && flush != Z_FINISH)) {
+        ERR_RETURN(strm, Z_STREAM_ERROR);
+    }
+    if (strm->avail_out == 0) ERR_RETURN(strm, Z_BUF_ERROR);
+
+    s->strm = strm; /* just in case */
+    old_flush = s->last_flush;
+    s->last_flush = flush;
+
+    /* Write the zlib header */
+    if (s->status == INIT_STATE) {
+
+        uInt header = (Z_DEFLATED + ((s->w_bits-8)<<4)) << 8;
+        uInt level_flags = (s->level-1) >> 1;
+
+        if (level_flags > 3) level_flags = 3;
+        header |= (level_flags << 6);
+	if (s->strstart != 0) header |= PRESET_DICT;
+        header += 31 - (header % 31);
+
+        s->status = BUSY_STATE;
+        putShortMSB(s, header);
+
+	/* Save the adler32 of the preset dictionary: */
+	if (s->strstart != 0) {
+	    putShortMSB(s, (uInt)(strm->adler >> 16));
+	    putShortMSB(s, (uInt)(strm->adler & 0xffff));
+	}
+	strm->adler = 1L;
+    }
+
+    /* Flush as much pending output as possible */
+    if (s->pending != 0) {
+        flush_pending(strm);
+        if (strm->avail_out == 0) {
+	    /* Since avail_out is 0, deflate will be called again with
+	     * more output space, but possibly with both pending and
+	     * avail_in equal to zero. There won't be anything to do,
+	     * but this is not an error situation so make sure we
+	     * return OK instead of BUF_ERROR at next call of deflate:
+             */
+	    s->last_flush = -1;
+	    return Z_OK;
+	}
+
+    /* Make sure there is something to do and avoid duplicate consecutive
+     * flushes. For repeated and useless calls with Z_FINISH, we keep
+     * returning Z_STREAM_END instead of Z_BUFF_ERROR.
+     */
+    } else if (strm->avail_in == 0 && flush <= old_flush &&
+	       flush != Z_FINISH) {
+        ERR_RETURN(strm, Z_BUF_ERROR);
+    }
+
+    /* User must not provide more input after the first FINISH: */
+    if (s->status == FINISH_STATE && strm->avail_in != 0) {
+        ERR_RETURN(strm, Z_BUF_ERROR);
+    }
+
+    /* Start a new block or continue the current one.
+     */
+    if (strm->avail_in != 0 || s->lookahead != 0 ||
+        (flush != Z_NO_FLUSH && s->status != FINISH_STATE)) {
+        block_state bstate;
+
+	bstate = (*(configuration_table[s->level].func))(s, flush);
+
+        if (bstate == finish_started || bstate == finish_done) {
+            s->status = FINISH_STATE;
+        }
+        if (bstate == need_more || bstate == finish_started) {
+	    if (strm->avail_out == 0) {
+	        s->last_flush = -1; /* avoid BUF_ERROR next call, see above */
+	    }
+	    return Z_OK;
+	    /* If flush != Z_NO_FLUSH && avail_out == 0, the next call
+	     * of deflate should use the same flush parameter to make sure
+	     * that the flush is complete. So we don't have to output an
+	     * empty block here, this will be done at next call. This also
+	     * ensures that for a very small output buffer, we emit at most
+	     * one empty block.
+	     */
+	}
+        if (bstate == block_done) {
+            if (flush == Z_PARTIAL_FLUSH) {
+                _tr_align(s);
+            } else { /* FULL_FLUSH or SYNC_FLUSH */
+                _tr_stored_block(s, (char*)0, 0L, 0);
+                /* For a full flush, this empty block will be recognized
+                 * as a special marker by inflate_sync().
+                 */
+                if (flush == Z_FULL_FLUSH) {
+                    CLEAR_HASH(s);             /* forget history */
+                }
+            }
+            flush_pending(strm);
+	    if (strm->avail_out == 0) {
+	      s->last_flush = -1; /* avoid BUF_ERROR at next call, see above */
+	      return Z_OK;
+	    }
+        }
+    }
+    Assert(strm->avail_out > 0, "bug2");
+
+    if (flush != Z_FINISH) return Z_OK;
+    if (s->noheader) return Z_STREAM_END;
+
+    /* Write the zlib trailer (adler32) */
+    putShortMSB(s, (uInt)(strm->adler >> 16));
+    putShortMSB(s, (uInt)(strm->adler & 0xffff));
+    flush_pending(strm);
+    /* If avail_out is zero, the application will call deflate again
+     * to flush the rest.
+     */
+    s->noheader = -1; /* write the trailer only once! */
+    return s->pending != 0 ? Z_OK : Z_STREAM_END;
+}
+
+/* ========================================================================= */
+int ZEXPORT deflateEnd (strm)
+    z_streamp strm;
+{
+    int status;
+
+    if (strm == Z_NULL || strm->state == Z_NULL) return Z_STREAM_ERROR;
+
+    status = strm->state->status;
+    if (status != INIT_STATE && status != BUSY_STATE &&
+	status != FINISH_STATE) {
+      return Z_STREAM_ERROR;
+    }
+
+    /* Deallocate in reverse order of allocations: */
+    TRY_FREE(strm, strm->state->pending_buf);
+    TRY_FREE(strm, strm->state->head);
+    TRY_FREE(strm, strm->state->prev);
+    TRY_FREE(strm, strm->state->window);
+
+    ZFREE(strm, strm->state);
+    strm->state = Z_NULL;
+
+    return status == BUSY_STATE ? Z_DATA_ERROR : Z_OK;
+}
+
+/* =========================================================================
+ * Copy the source state to the destination state.
+ * To simplify the source, this is not supported for 16-bit MSDOS (which
+ * doesn't have enough memory anyway to duplicate compression states).
+ */
+int ZEXPORT deflateCopy (dest, source)
+    z_streamp dest;
+    z_streamp source;
+{
+#ifdef MAXSEG_64K
+    return Z_STREAM_ERROR;
+#else
+    deflate_state *ds;
+    deflate_state *ss;
+    ushf *overlay;
+
+
+    if (source == Z_NULL || dest == Z_NULL || source->state == Z_NULL) {
+        return Z_STREAM_ERROR;
+    }
+
+    ss = source->state;
+
+    *dest = *source;
+
+    ds = (deflate_state *) ZALLOC(dest, 1, sizeof(deflate_state));
+    if (ds == Z_NULL) return Z_MEM_ERROR;
+    dest->state = (struct internal_state FAR *) ds;
+    *ds = *ss;
+    ds->strm = dest;
+
+    ds->window = (Bytef *) ZALLOC(dest, ds->w_size, 2*sizeof(Byte));
+    ds->prev   = (Posf *)  ZALLOC(dest, ds->w_size, sizeof(Pos));
+    ds->head   = (Posf *)  ZALLOC(dest, ds->hash_size, sizeof(Pos));
+    overlay = (ushf *) ZALLOC(dest, ds->lit_bufsize, sizeof(ush)+2);
+    ds->pending_buf = (uchf *) overlay;
+
+    if (ds->window == Z_NULL || ds->prev == Z_NULL || ds->head == Z_NULL ||
+        ds->pending_buf == Z_NULL) {
+        deflateEnd (dest);
+        return Z_MEM_ERROR;
+    }
+    /* following zmemcpy do not work for 16-bit MSDOS */
+    zmemcpy(ds->window, ss->window, ds->w_size * 2 * sizeof(Byte));
+    zmemcpy(ds->prev, ss->prev, ds->w_size * sizeof(Pos));
+    zmemcpy(ds->head, ss->head, ds->hash_size * sizeof(Pos));
+    zmemcpy(ds->pending_buf, ss->pending_buf, (uInt)ds->pending_buf_size);
+
+    ds->pending_out = ds->pending_buf + (ss->pending_out - ss->pending_buf);
+    ds->d_buf = overlay + ds->lit_bufsize/sizeof(ush);
+    ds->l_buf = ds->pending_buf + (1+sizeof(ush))*ds->lit_bufsize;
+
+    ds->l_desc.dyn_tree = ds->dyn_ltree;
+    ds->d_desc.dyn_tree = ds->dyn_dtree;
+    ds->bl_desc.dyn_tree = ds->bl_tree;
+
+    return Z_OK;
+#endif
+}
+
+/* ===========================================================================
+ * Read a new buffer from the current input stream, update the adler32
+ * and total number of bytes read.  All deflate() input goes through
+ * this function so some applications may wish to modify it to avoid
+ * allocating a large strm->next_in buffer and copying from it.
+ * (See also flush_pending()).
+ */
+local int read_buf(strm, buf, size)
+    z_streamp strm;
+    Bytef *buf;
+    unsigned size;
+{
+    unsigned len = strm->avail_in;
+
+    if (len > size) len = size;
+    if (len == 0) return 0;
+
+    strm->avail_in  -= len;
+
+    if (!strm->state->noheader) {
+        strm->adler = adler32(strm->adler, strm->next_in, len);
+    }
+    zmemcpy(buf, strm->next_in, len);
+    strm->next_in  += len;
+    strm->total_in += len;
+
+    return (int)len;
+}
+
+/* ===========================================================================
+ * Initialize the "longest match" routines for a new zlib stream
+ */
+local void lm_init (s)
+    deflate_state *s;
+{
+    s->window_size = (ulg)2L*s->w_size;
+
+    CLEAR_HASH(s);
+
+    /* Set the default configuration parameters:
+     */
+    s->max_lazy_match   = configuration_table[s->level].max_lazy;
+    s->good_match       = configuration_table[s->level].good_length;
+    s->nice_match       = configuration_table[s->level].nice_length;
+    s->max_chain_length = configuration_table[s->level].max_chain;
+
+    s->strstart = 0;
+    s->block_start = 0L;
+    s->lookahead = 0;
+    s->match_length = s->prev_length = MIN_MATCH-1;
+    s->match_available = 0;
+    s->ins_h = 0;
+#ifdef ASMV
+    match_init(); /* initialize the asm code */
+#endif
+}
+
+/* ===========================================================================
+ * Set match_start to the longest match starting at the given string and
+ * return its length. Matches shorter or equal to prev_length are discarded,
+ * in which case the result is equal to prev_length and match_start is
+ * garbage.
+ * IN assertions: cur_match is the head of the hash chain for the current
+ *   string (strstart) and its distance is <= MAX_DIST, and prev_length >= 1
+ * OUT assertion: the match length is not greater than s->lookahead.
+ */
+#ifndef ASMV
+/* For 80x86 and 680x0, an optimized version will be provided in match.asm or
+ * match.S. The code will be functionally equivalent.
+ */
+#ifndef FASTEST
+local uInt longest_match(s, cur_match)
+    deflate_state *s;
+    IPos cur_match;                             /* current match */
+{
+    unsigned chain_length = s->max_chain_length;/* max hash chain length */
+    register Bytef *scan = s->window + s->strstart; /* current string */
+    register Bytef *match;                       /* matched string */
+    register int len;                           /* length of current match */
+    int best_len = s->prev_length;              /* best match length so far */
+    int nice_match = s->nice_match;             /* stop if match long enough */
+    IPos limit = s->strstart > (IPos)MAX_DIST(s) ?
+        s->strstart - (IPos)MAX_DIST(s) : NIL;
+    /* Stop when cur_match becomes <= limit. To simplify the code,
+     * we prevent matches with the string of window index 0.
+     */
+    Posf *prev = s->prev;
+    uInt wmask = s->w_mask;
+
+#ifdef UNALIGNED_OK
+    /* Compare two bytes at a time. Note: this is not always beneficial.
+     * Try with and without -DUNALIGNED_OK to check.
+     */
+    register Bytef *strend = s->window + s->strstart + MAX_MATCH - 1;
+    register ush scan_start = *(ushf*)scan;
+    register ush scan_end   = *(ushf*)(scan+best_len-1);
+#else
+    register Bytef *strend = s->window + s->strstart + MAX_MATCH;
+    register Byte scan_end1  = scan[best_len-1];
+    register Byte scan_end   = scan[best_len];
+#endif
+
+    /* The code is optimized for HASH_BITS >= 8 and MAX_MATCH-2 multiple of 16.
+     * It is easy to get rid of this optimization if necessary.
+     */
+    Assert(s->hash_bits >= 8 && MAX_MATCH == 258, "Code too clever");
+
+    /* Do not waste too much time if we already have a good match: */
+    if (s->prev_length >= s->good_match) {
+        chain_length >>= 2;
+    }
+    /* Do not look for matches beyond the end of the input. This is necessary
+     * to make deflate deterministic.
+     */
+    if ((uInt)nice_match > s->lookahead) nice_match = s->lookahead;
+
+    Assert((ulg)s->strstart <= s->window_size-MIN_LOOKAHEAD, "need lookahead");
+
+    do {
+        Assert(cur_match < s->strstart, "no future");
+        match = s->window + cur_match;
+
+        /* Skip to next match if the match length cannot increase
+         * or if the match length is less than 2:
+         */
+#if (defined(UNALIGNED_OK) && MAX_MATCH == 258)
+        /* This code assumes sizeof(unsigned short) == 2. Do not use
+         * UNALIGNED_OK if your compiler uses a different size.
+         */
+        if (*(ushf*)(match+best_len-1) != scan_end ||
+            *(ushf*)match != scan_start) continue;
+
+        /* It is not necessary to compare scan[2] and match[2] since they are
+         * always equal when the other bytes match, given that the hash keys
+         * are equal and that HASH_BITS >= 8. Compare 2 bytes at a time at
+         * strstart+3, +5, ... up to strstart+257. We check for insufficient
+         * lookahead only every 4th comparison; the 128th check will be made
+         * at strstart+257. If MAX_MATCH-2 is not a multiple of 8, it is
+         * necessary to put more guard bytes at the end of the window, or
+         * to check more often for insufficient lookahead.
+         */
+        Assert(scan[2] == match[2], "scan[2]?");
+        scan++, match++;
+        do {
+        } while (*(ushf*)(scan+=2) == *(ushf*)(match+=2) &&
+                 *(ushf*)(scan+=2) == *(ushf*)(match+=2) &&
+                 *(ushf*)(scan+=2) == *(ushf*)(match+=2) &&
+                 *(ushf*)(scan+=2) == *(ushf*)(match+=2) &&
+                 scan < strend);
+        /* The funny "do {}" generates better code on most compilers */
+
+        /* Here, scan <= window+strstart+257 */
+        Assert(scan <= s->window+(unsigned)(s->window_size-1), "wild scan");
+        if (*scan == *match) scan++;
+
+        len = (MAX_MATCH - 1) - (int)(strend-scan);
+        scan = strend - (MAX_MATCH-1);
+
+#else /* UNALIGNED_OK */
+
+        if (match[best_len]   != scan_end  ||
+            match[best_len-1] != scan_end1 ||
+            *match            != *scan     ||
+            *++match          != scan[1])      continue;
+
+        /* The check at best_len-1 can be removed because it will be made
+         * again later. (This heuristic is not always a win.)
+         * It is not necessary to compare scan[2] and match[2] since they
+         * are always equal when the other bytes match, given that
+         * the hash keys are equal and that HASH_BITS >= 8.
+         */
+        scan += 2, match++;
+        Assert(*scan == *match, "match[2]?");
+
+        /* We check for insufficient lookahead only every 8th comparison;
+         * the 256th check will be made at strstart+258.
+         */
+        do {
+        } while (*++scan == *++match && *++scan == *++match &&
+                 *++scan == *++match && *++scan == *++match &&
+                 *++scan == *++match && *++scan == *++match &&
+                 *++scan == *++match && *++scan == *++match &&
+                 scan < strend);
+
+        Assert(scan <= s->window+(unsigned)(s->window_size-1), "wild scan");
+
+        len = MAX_MATCH - (int)(strend - scan);
+        scan = strend - MAX_MATCH;
+
+#endif /* UNALIGNED_OK */
+
+        if (len > best_len) {
+            s->match_start = cur_match;
+            best_len = len;
+            if (len >= nice_match) break;
+#ifdef UNALIGNED_OK
+            scan_end = *(ushf*)(scan+best_len-1);
+#else
+            scan_end1  = scan[best_len-1];
+            scan_end   = scan[best_len];
+#endif
+        }
+    } while ((cur_match = prev[cur_match & wmask]) > limit
+             && --chain_length != 0);
+
+    if ((uInt)best_len <= s->lookahead) return (uInt)best_len;
+    return s->lookahead;
+}
+
+#else /* FASTEST */
+/* ---------------------------------------------------------------------------
+ * Optimized version for level == 1 only
+ */
+local uInt longest_match(s, cur_match)
+    deflate_state *s;
+    IPos cur_match;                             /* current match */
+{
+    register Bytef *scan = s->window + s->strstart; /* current string */
+    register Bytef *match;                       /* matched string */
+    register int len;                           /* length of current match */
+    register Bytef *strend = s->window + s->strstart + MAX_MATCH;
+
+    /* The code is optimized for HASH_BITS >= 8 and MAX_MATCH-2 multiple of 16.
+     * It is easy to get rid of this optimization if necessary.
+     */
+    Assert(s->hash_bits >= 8 && MAX_MATCH == 258, "Code too clever");
+
+    Assert((ulg)s->strstart <= s->window_size-MIN_LOOKAHEAD, "need lookahead");
+
+    Assert(cur_match < s->strstart, "no future");
+
+    match = s->window + cur_match;
+
+    /* Return failure if the match length is less than 2:
+     */
+    if (match[0] != scan[0] || match[1] != scan[1]) return MIN_MATCH-1;
+
+    /* The check at best_len-1 can be removed because it will be made
+     * again later. (This heuristic is not always a win.)
+     * It is not necessary to compare scan[2] and match[2] since they
+     * are always equal when the other bytes match, given that
+     * the hash keys are equal and that HASH_BITS >= 8.
+     */
+    scan += 2, match += 2;
+    Assert(*scan == *match, "match[2]?");
+
+    /* We check for insufficient lookahead only every 8th comparison;
+     * the 256th check will be made at strstart+258.
+     */
+    do {
+    } while (*++scan == *++match && *++scan == *++match &&
+	     *++scan == *++match && *++scan == *++match &&
+	     *++scan == *++match && *++scan == *++match &&
+	     *++scan == *++match && *++scan == *++match &&
+	     scan < strend);
+
+    Assert(scan <= s->window+(unsigned)(s->window_size-1), "wild scan");
+
+    len = MAX_MATCH - (int)(strend - scan);
+
+    if (len < MIN_MATCH) return MIN_MATCH - 1;
+
+    s->match_start = cur_match;
+    return len <= s->lookahead ? len : s->lookahead;
+}
+#endif /* FASTEST */
+#endif /* ASMV */
+
+#ifdef DEBUG
+/* ===========================================================================
+ * Check that the match at match_start is indeed a match.
+ */
+local void check_match(s, start, match, length)
+    deflate_state *s;
+    IPos start, match;
+    int length;
+{
+    /* check that the match is indeed a match */
+    if (zmemcmp(s->window + match,
+                s->window + start, length) != EQUAL) {
+        fprintf(stderr, " start %u, match %u, length %d\n",
+		start, match, length);
+        do {
+	    fprintf(stderr, "%c%c", s->window[match++], s->window[start++]);
+	} while (--length != 0);
+        z_error("invalid match");
+    }
+    if (z_verbose > 1) {
+        fprintf(stderr,"\\[%d,%d]", start-match, length);
+        do { putc(s->window[start++], stderr); } while (--length != 0);
+    }
+}
+#else
+#  define check_match(s, start, match, length)
+#endif
+
+/* ===========================================================================
+ * Fill the window when the lookahead becomes insufficient.
+ * Updates strstart and lookahead.
+ *
+ * IN assertion: lookahead < MIN_LOOKAHEAD
+ * OUT assertions: strstart <= window_size-MIN_LOOKAHEAD
+ *    At least one byte has been read, or avail_in == 0; reads are
+ *    performed for at least two bytes (required for the zip translate_eol
+ *    option -- not supported here).
+ */
+local void fill_window(s)
+    deflate_state *s;
+{
+    register unsigned n, m;
+    register Posf *p;
+    unsigned more;    /* Amount of free space at the end of the window. */
+    uInt wsize = s->w_size;
+
+    do {
+        more = (unsigned)(s->window_size -(ulg)s->lookahead -(ulg)s->strstart);
+
+        /* Deal with !@#$% 64K limit: */
+        if (more == 0 && s->strstart == 0 && s->lookahead == 0) {
+            more = wsize;
+
+        } else if (more == (unsigned)(-1)) {
+            /* Very unlikely, but possible on 16 bit machine if strstart == 0
+             * and lookahead == 1 (input done one byte at time)
+             */
+            more--;
+
+        /* If the window is almost full and there is insufficient lookahead,
+         * move the upper half to the lower one to make room in the upper half.
+         */
+        } else if (s->strstart >= wsize+MAX_DIST(s)) {
+
+            zmemcpy(s->window, s->window+wsize, (unsigned)wsize);
+            s->match_start -= wsize;
+            s->strstart    -= wsize; /* we now have strstart >= MAX_DIST */
+            s->block_start -= (long) wsize;
+
+            /* Slide the hash table (could be avoided with 32 bit values
+               at the expense of memory usage). We slide even when level == 0
+               to keep the hash table consistent if we switch back to level > 0
+               later. (Using level 0 permanently is not an optimal usage of
+               zlib, so we don't care about this pathological case.)
+             */
+	    n = s->hash_size;
+	    p = &s->head[n];
+	    do {
+		m = *--p;
+		*p = (Pos)(m >= wsize ? m-wsize : NIL);
+	    } while (--n);
+
+	    n = wsize;
+#ifndef FASTEST
+	    p = &s->prev[n];
+	    do {
+		m = *--p;
+		*p = (Pos)(m >= wsize ? m-wsize : NIL);
+		/* If n is not on any hash chain, prev[n] is garbage but
+		 * its value will never be used.
+		 */
+	    } while (--n);
+#endif
+            more += wsize;
+        }
+        if (s->strm->avail_in == 0) return;
+
+        /* If there was no sliding:
+         *    strstart <= WSIZE+MAX_DIST-1 && lookahead <= MIN_LOOKAHEAD - 1 &&
+         *    more == window_size - lookahead - strstart
+         * => more >= window_size - (MIN_LOOKAHEAD-1 + WSIZE + MAX_DIST-1)
+         * => more >= window_size - 2*WSIZE + 2
+         * In the BIG_MEM or MMAP case (not yet supported),
+         *   window_size == input_size + MIN_LOOKAHEAD  &&
+         *   strstart + s->lookahead <= input_size => more >= MIN_LOOKAHEAD.
+         * Otherwise, window_size == 2*WSIZE so more >= 2.
+         * If there was sliding, more >= WSIZE. So in all cases, more >= 2.
+         */
+        Assert(more >= 2, "more < 2");
+
+        n = read_buf(s->strm, s->window + s->strstart + s->lookahead, more);
+        s->lookahead += n;
+
+        /* Initialize the hash value now that we have some input: */
+        if (s->lookahead >= MIN_MATCH) {
+            s->ins_h = s->window[s->strstart];
+            UPDATE_HASH(s, s->ins_h, s->window[s->strstart+1]);
+#if MIN_MATCH != 3
+            Call UPDATE_HASH() MIN_MATCH-3 more times
+#endif
+        }
+        /* If the whole input has less than MIN_MATCH bytes, ins_h is garbage,
+         * but this is not important since only literal bytes will be emitted.
+         */
+
+    } while (s->lookahead < MIN_LOOKAHEAD && s->strm->avail_in != 0);
+}
+
+/* ===========================================================================
+ * Flush the current block, with given end-of-file flag.
+ * IN assertion: strstart is set to the end of the current match.
+ */
+#define FLUSH_BLOCK_ONLY(s, eof) { \
+   _tr_flush_block(s, (s->block_start >= 0L ? \
+                   (charf *)&s->window[(unsigned)s->block_start] : \
+                   (charf *)Z_NULL), \
+		(ulg)((long)s->strstart - s->block_start), \
+		(eof)); \
+   s->block_start = s->strstart; \
+   flush_pending(s->strm); \
+   Tracev((stderr,"[FLUSH]")); \
+}
+
+/* Same but force premature exit if necessary. */
+#define FLUSH_BLOCK(s, eof) { \
+   FLUSH_BLOCK_ONLY(s, eof); \
+   if (s->strm->avail_out == 0) return (eof) ? finish_started : need_more; \
+}
+
+/* ===========================================================================
+ * Copy without compression as much as possible from the input stream, return
+ * the current block state.
+ * This function does not insert new strings in the dictionary since
+ * uncompressible data is probably not useful. This function is used
+ * only for the level=0 compression option.
+ * NOTE: this function should be optimized to avoid extra copying from
+ * window to pending_buf.
+ */
+local block_state deflate_stored(s, flush)
+    deflate_state *s;
+    int flush;
+{
+    /* Stored blocks are limited to 0xffff bytes, pending_buf is limited
+     * to pending_buf_size, and each stored block has a 5 byte header:
+     */
+    ulg max_block_size = 0xffff;
+    ulg max_start;
+
+    if (max_block_size > s->pending_buf_size - 5) {
+        max_block_size = s->pending_buf_size - 5;
+    }
+
+    /* Copy as much as possible from input to output: */
+    for (;;) {
+        /* Fill the window as much as possible: */
+        if (s->lookahead <= 1) {
+
+            Assert(s->strstart < s->w_size+MAX_DIST(s) ||
+		   s->block_start >= (long)s->w_size, "slide too late");
+
+            fill_window(s);
+            if (s->lookahead == 0 && flush == Z_NO_FLUSH) return need_more;
+
+            if (s->lookahead == 0) break; /* flush the current block */
+        }
+	Assert(s->block_start >= 0L, "block gone");
+
+	s->strstart += s->lookahead;
+	s->lookahead = 0;
+
+	/* Emit a stored block if pending_buf will be full: */
+ 	max_start = s->block_start + max_block_size;
+        if (s->strstart == 0 || (ulg)s->strstart >= max_start) {
+	    /* strstart == 0 is possible when wraparound on 16-bit machine */
+	    s->lookahead = (uInt)(s->strstart - max_start);
+	    s->strstart = (uInt)max_start;
+            FLUSH_BLOCK(s, 0);
+	}
+	/* Flush if we may have to slide, otherwise block_start may become
+         * negative and the data will be gone:
+         */
+        if (s->strstart - (uInt)s->block_start >= MAX_DIST(s)) {
+            FLUSH_BLOCK(s, 0);
+	}
+    }
+    FLUSH_BLOCK(s, flush == Z_FINISH);
+    return flush == Z_FINISH ? finish_done : block_done;
+}
+
+/* ===========================================================================
+ * Compress as much as possible from the input stream, return the current
+ * block state.
+ * This function does not perform lazy evaluation of matches and inserts
+ * new strings in the dictionary only for unmatched strings or for short
+ * matches. It is used only for the fast compression options.
+ */
+local block_state deflate_fast(s, flush)
+    deflate_state *s;
+    int flush;
+{
+    IPos hash_head = NIL; /* head of the hash chain */
+    int bflush;           /* set if current block must be flushed */
+
+    for (;;) {
+        /* Make sure that we always have enough lookahead, except
+         * at the end of the input file. We need MAX_MATCH bytes
+         * for the next match, plus MIN_MATCH bytes to insert the
+         * string following the next match.
+         */
+        if (s->lookahead < MIN_LOOKAHEAD) {
+            fill_window(s);
+            if (s->lookahead < MIN_LOOKAHEAD && flush == Z_NO_FLUSH) {
+	        return need_more;
+	    }
+            if (s->lookahead == 0) break; /* flush the current block */
+        }
+
+        /* Insert the string window[strstart .. strstart+2] in the
+         * dictionary, and set hash_head to the head of the hash chain:
+         */
+        if (s->lookahead >= MIN_MATCH) {
+            INSERT_STRING(s, s->strstart, hash_head);
+        }
+
+        /* Find the longest match, discarding those <= prev_length.
+         * At this point we have always match_length < MIN_MATCH
+         */
+        if (hash_head != NIL && s->strstart - hash_head <= MAX_DIST(s)) {
+            /* To simplify the code, we prevent matches with the string
+             * of window index 0 (in particular we have to avoid a match
+             * of the string with itself at the start of the input file).
+             */
+            if (s->strategy != Z_HUFFMAN_ONLY) {
+                s->match_length = longest_match (s, hash_head);
+            }
+            /* longest_match() sets match_start */
+        }
+        if (s->match_length >= MIN_MATCH) {
+            check_match(s, s->strstart, s->match_start, s->match_length);
+
+            _tr_tally_dist(s, s->strstart - s->match_start,
+                           s->match_length - MIN_MATCH, bflush);
+
+            s->lookahead -= s->match_length;
+
+            /* Insert new strings in the hash table only if the match length
+             * is not too large. This saves time but degrades compression.
+             */
+#ifndef FASTEST
+            if (s->match_length <= s->max_insert_length &&
+                s->lookahead >= MIN_MATCH) {
+                s->match_length--; /* string at strstart already in hash table */
+                do {
+                    s->strstart++;
+                    INSERT_STRING(s, s->strstart, hash_head);
+                    /* strstart never exceeds WSIZE-MAX_MATCH, so there are
+                     * always MIN_MATCH bytes ahead.
+                     */
+                } while (--s->match_length != 0);
+                s->strstart++; 
+            } else
+#endif
+	    {
+                s->strstart += s->match_length;
+                s->match_length = 0;
+                s->ins_h = s->window[s->strstart];
+                UPDATE_HASH(s, s->ins_h, s->window[s->strstart+1]);
+#if MIN_MATCH != 3
+                Call UPDATE_HASH() MIN_MATCH-3 more times
+#endif
+                /* If lookahead < MIN_MATCH, ins_h is garbage, but it does not
+                 * matter since it will be recomputed at next deflate call.
+                 */
+            }
+        } else {
+            /* No match, output a literal byte */
+            Tracevv((stderr,"%c", s->window[s->strstart]));
+            _tr_tally_lit (s, s->window[s->strstart], bflush);
+            s->lookahead--;
+            s->strstart++; 
+        }
+        if (bflush) FLUSH_BLOCK(s, 0);
+    }
+    FLUSH_BLOCK(s, flush == Z_FINISH);
+    return flush == Z_FINISH ? finish_done : block_done;
+}
+
+/* ===========================================================================
+ * Same as above, but achieves better compression. We use a lazy
+ * evaluation for matches: a match is finally adopted only if there is
+ * no better match at the next window position.
+ */
+local block_state deflate_slow(s, flush)
+    deflate_state *s;
+    int flush;
+{
+    IPos hash_head = NIL;    /* head of hash chain */
+    int bflush;              /* set if current block must be flushed */
+
+    /* Process the input block. */
+    for (;;) {
+        /* Make sure that we always have enough lookahead, except
+         * at the end of the input file. We need MAX_MATCH bytes
+         * for the next match, plus MIN_MATCH bytes to insert the
+         * string following the next match.
+         */
+        if (s->lookahead < MIN_LOOKAHEAD) {
+            fill_window(s);
+            if (s->lookahead < MIN_LOOKAHEAD && flush == Z_NO_FLUSH) {
+	        return need_more;
+	    }
+            if (s->lookahead == 0) break; /* flush the current block */
+        }
+
+        /* Insert the string window[strstart .. strstart+2] in the
+         * dictionary, and set hash_head to the head of the hash chain:
+         */
+        if (s->lookahead >= MIN_MATCH) {
+            INSERT_STRING(s, s->strstart, hash_head);
+        }
+
+        /* Find the longest match, discarding those <= prev_length.
+         */
+        s->prev_length = s->match_length, s->prev_match = s->match_start;
+        s->match_length = MIN_MATCH-1;
+
+        if (hash_head != NIL && s->prev_length < s->max_lazy_match &&
+            s->strstart - hash_head <= MAX_DIST(s)) {
+            /* To simplify the code, we prevent matches with the string
+             * of window index 0 (in particular we have to avoid a match
+             * of the string with itself at the start of the input file).
+             */
+            if (s->strategy != Z_HUFFMAN_ONLY) {
+                s->match_length = longest_match (s, hash_head);
+            }
+            /* longest_match() sets match_start */
+
+            if (s->match_length <= 5 && (s->strategy == Z_FILTERED ||
+                 (s->match_length == MIN_MATCH &&
+                  s->strstart - s->match_start > TOO_FAR))) {
+
+                /* If prev_match is also MIN_MATCH, match_start is garbage
+                 * but we will ignore the current match anyway.
+                 */
+                s->match_length = MIN_MATCH-1;
+            }
+        }
+        /* If there was a match at the previous step and the current
+         * match is not better, output the previous match:
+         */
+        if (s->prev_length >= MIN_MATCH && s->match_length <= s->prev_length) {
+            uInt max_insert = s->strstart + s->lookahead - MIN_MATCH;
+            /* Do not insert strings in hash table beyond this. */
+
+            check_match(s, s->strstart-1, s->prev_match, s->prev_length);
+
+            _tr_tally_dist(s, s->strstart -1 - s->prev_match,
+			   s->prev_length - MIN_MATCH, bflush);
+
+            /* Insert in hash table all strings up to the end of the match.
+             * strstart-1 and strstart are already inserted. If there is not
+             * enough lookahead, the last two strings are not inserted in
+             * the hash table.
+             */
+            s->lookahead -= s->prev_length-1;
+            s->prev_length -= 2;
+            do {
+                if (++s->strstart <= max_insert) {
+                    INSERT_STRING(s, s->strstart, hash_head);
+                }
+            } while (--s->prev_length != 0);
+            s->match_available = 0;
+            s->match_length = MIN_MATCH-1;
+            s->strstart++;
+
+            if (bflush) FLUSH_BLOCK(s, 0);
+
+        } else if (s->match_available) {
+            /* If there was no match at the previous position, output a
+             * single literal. If there was a match but the current match
+             * is longer, truncate the previous match to a single literal.
+             */
+            Tracevv((stderr,"%c", s->window[s->strstart-1]));
+	    _tr_tally_lit(s, s->window[s->strstart-1], bflush);
+	    if (bflush) {
+                FLUSH_BLOCK_ONLY(s, 0);
+            }
+            s->strstart++;
+            s->lookahead--;
+            if (s->strm->avail_out == 0) return need_more;
+        } else {
+            /* There is no previous match to compare with, wait for
+             * the next step to decide.
+             */
+            s->match_available = 1;
+            s->strstart++;
+            s->lookahead--;
+        }
+    }
+    Assert (flush != Z_NO_FLUSH, "no flush?");
+    if (s->match_available) {
+        Tracevv((stderr,"%c", s->window[s->strstart-1]));
+        _tr_tally_lit(s, s->window[s->strstart-1], bflush);
+        s->match_available = 0;
+    }
+    FLUSH_BLOCK(s, flush == Z_FINISH);
+    return flush == Z_FINISH ? finish_done : block_done;
+}
diff --git a/collects/plot/src/all/deflate.h b/collects/plot/src/all/deflate.h
new file mode 100644
index 0000000000..69c8713a4a
--- /dev/null
+++ b/collects/plot/src/all/deflate.h
@@ -0,0 +1,318 @@
+/* deflate.h -- internal compression state
+ * Copyright (C) 1995-2002 Jean-loup Gailly
+ * For conditions of distribution and use, see copyright notice in zlib.h 
+ */
+
+/* WARNING: this file should *not* be used by applications. It is
+   part of the implementation of the compression library and is
+   subject to change. Applications should only use zlib.h.
+ */
+
+/* @(#) $Id: deflate.h,v 1.1 2004/03/01 20:54:46 cozmic Exp $ */
+
+#ifndef _DEFLATE_H
+#define _DEFLATE_H
+
+#include "zutil.h"
+
+/* ===========================================================================
+ * Internal compression state.
+ */
+
+#define LENGTH_CODES 29
+/* number of length codes, not counting the special END_BLOCK code */
+
+#define LITERALS  256
+/* number of literal bytes 0..255 */
+
+#define L_CODES (LITERALS+1+LENGTH_CODES)
+/* number of Literal or Length codes, including the END_BLOCK code */
+
+#define D_CODES   30
+/* number of distance codes */
+
+#define BL_CODES  19
+/* number of codes used to transfer the bit lengths */
+
+#define HEAP_SIZE (2*L_CODES+1)
+/* maximum heap size */
+
+#define MAX_BITS 15
+/* All codes must not exceed MAX_BITS bits */
+
+#define INIT_STATE    42
+#define BUSY_STATE   113
+#define FINISH_STATE 666
+/* Stream status */
+
+
+/* Data structure describing a single value and its code string. */
+typedef struct ct_data_s {
+    union {
+        ush  freq;       /* frequency count */
+        ush  code;       /* bit string */
+    } fc;
+    union {
+        ush  dad;        /* father node in Huffman tree */
+        ush  len;        /* length of bit string */
+    } dl;
+} FAR ct_data;
+
+#define Freq fc.freq
+#define Code fc.code
+#define Dad  dl.dad
+#define Len  dl.len
+
+typedef struct static_tree_desc_s  static_tree_desc;
+
+typedef struct tree_desc_s {
+    ct_data *dyn_tree;           /* the dynamic tree */
+    int     max_code;            /* largest code with non zero frequency */
+    static_tree_desc *stat_desc; /* the corresponding static tree */
+} FAR tree_desc;
+
+typedef ush Pos;
+typedef Pos FAR Posf;
+typedef unsigned IPos;
+
+/* A Pos is an index in the character window. We use short instead of int to
+ * save space in the various tables. IPos is used only for parameter passing.
+ */
+
+typedef struct internal_state {
+    z_streamp strm;      /* pointer back to this zlib stream */
+    int   status;        /* as the name implies */
+    Bytef *pending_buf;  /* output still pending */
+    ulg   pending_buf_size; /* size of pending_buf */
+    Bytef *pending_out;  /* next pending byte to output to the stream */
+    int   pending;       /* nb of bytes in the pending buffer */
+    int   noheader;      /* suppress zlib header and adler32 */
+    Byte  data_type;     /* UNKNOWN, BINARY or ASCII */
+    Byte  method;        /* STORED (for zip only) or DEFLATED */
+    int   last_flush;    /* value of flush param for previous deflate call */
+
+                /* used by deflate.c: */
+
+    uInt  w_size;        /* LZ77 window size (32K by default) */
+    uInt  w_bits;        /* log2(w_size)  (8..16) */
+    uInt  w_mask;        /* w_size - 1 */
+
+    Bytef *window;
+    /* Sliding window. Input bytes are read into the second half of the window,
+     * and move to the first half later to keep a dictionary of at least wSize
+     * bytes. With this organization, matches are limited to a distance of
+     * wSize-MAX_MATCH bytes, but this ensures that IO is always
+     * performed with a length multiple of the block size. Also, it limits
+     * the window size to 64K, which is quite useful on MSDOS.
+     * To do: use the user input buffer as sliding window.
+     */
+
+    ulg window_size;
+    /* Actual size of window: 2*wSize, except when the user input buffer
+     * is directly used as sliding window.
+     */
+
+    Posf *prev;
+    /* Link to older string with same hash index. To limit the size of this
+     * array to 64K, this link is maintained only for the last 32K strings.
+     * An index in this array is thus a window index modulo 32K.
+     */
+
+    Posf *head; /* Heads of the hash chains or NIL. */
+
+    uInt  ins_h;          /* hash index of string to be inserted */
+    uInt  hash_size;      /* number of elements in hash table */
+    uInt  hash_bits;      /* log2(hash_size) */
+    uInt  hash_mask;      /* hash_size-1 */
+
+    uInt  hash_shift;
+    /* Number of bits by which ins_h must be shifted at each input
+     * step. It must be such that after MIN_MATCH steps, the oldest
+     * byte no longer takes part in the hash key, that is:
+     *   hash_shift * MIN_MATCH >= hash_bits
+     */
+
+    long block_start;
+    /* Window position at the beginning of the current output block. Gets
+     * negative when the window is moved backwards.
+     */
+
+    uInt match_length;           /* length of best match */
+    IPos prev_match;             /* previous match */
+    int match_available;         /* set if previous match exists */
+    uInt strstart;               /* start of string to insert */
+    uInt match_start;            /* start of matching string */
+    uInt lookahead;              /* number of valid bytes ahead in window */
+
+    uInt prev_length;
+    /* Length of the best match at previous step. Matches not greater than this
+     * are discarded. This is used in the lazy match evaluation.
+     */
+
+    uInt max_chain_length;
+    /* To speed up deflation, hash chains are never searched beyond this
+     * length.  A higher limit improves compression ratio but degrades the
+     * speed.
+     */
+
+    uInt max_lazy_match;
+    /* Attempt to find a better match only when the current match is strictly
+     * smaller than this value. This mechanism is used only for compression
+     * levels >= 4.
+     */
+#   define max_insert_length  max_lazy_match
+    /* Insert new strings in the hash table only if the match length is not
+     * greater than this length. This saves time but degrades compression.
+     * max_insert_length is used only for compression levels <= 3.
+     */
+
+    int level;    /* compression level (1..9) */
+    int strategy; /* favor or force Huffman coding*/
+
+    uInt good_match;
+    /* Use a faster search when the previous match is longer than this */
+
+    int nice_match; /* Stop searching when current match exceeds this */
+
+                /* used by trees.c: */
+    /* Didn't use ct_data typedef below to supress compiler warning */
+    struct ct_data_s dyn_ltree[HEAP_SIZE];   /* literal and length tree */
+    struct ct_data_s dyn_dtree[2*D_CODES+1]; /* distance tree */
+    struct ct_data_s bl_tree[2*BL_CODES+1];  /* Huffman tree for bit lengths */
+
+    struct tree_desc_s l_desc;               /* desc. for literal tree */
+    struct tree_desc_s d_desc;               /* desc. for distance tree */
+    struct tree_desc_s bl_desc;              /* desc. for bit length tree */
+
+    ush bl_count[MAX_BITS+1];
+    /* number of codes at each bit length for an optimal tree */
+
+    int heap[2*L_CODES+1];      /* heap used to build the Huffman trees */
+    int heap_len;               /* number of elements in the heap */
+    int heap_max;               /* element of largest frequency */
+    /* The sons of heap[n] are heap[2*n] and heap[2*n+1]. heap[0] is not used.
+     * The same heap array is used to build all trees.
+     */
+
+    uch depth[2*L_CODES+1];
+    /* Depth of each subtree used as tie breaker for trees of equal frequency
+     */
+
+    uchf *l_buf;          /* buffer for literals or lengths */
+
+    uInt  lit_bufsize;
+    /* Size of match buffer for literals/lengths.  There are 4 reasons for
+     * limiting lit_bufsize to 64K:
+     *   - frequencies can be kept in 16 bit counters
+     *   - if compression is not successful for the first block, all input
+     *     data is still in the window so we can still emit a stored block even
+     *     when input comes from standard input.  (This can also be done for
+     *     all blocks if lit_bufsize is not greater than 32K.)
+     *   - if compression is not successful for a file smaller than 64K, we can
+     *     even emit a stored file instead of a stored block (saving 5 bytes).
+     *     This is applicable only for zip (not gzip or zlib).
+     *   - creating new Huffman trees less frequently may not provide fast
+     *     adaptation to changes in the input data statistics. (Take for
+     *     example a binary file with poorly compressible code followed by
+     *     a highly compressible string table.) Smaller buffer sizes give
+     *     fast adaptation but have of course the overhead of transmitting
+     *     trees more frequently.
+     *   - I can't count above 4
+     */
+
+    uInt last_lit;      /* running index in l_buf */
+
+    ushf *d_buf;
+    /* Buffer for distances. To simplify the code, d_buf and l_buf have
+     * the same number of elements. To use different lengths, an extra flag
+     * array would be necessary.
+     */
+
+    ulg opt_len;        /* bit length of current block with optimal trees */
+    ulg static_len;     /* bit length of current block with static trees */
+    uInt matches;       /* number of string matches in current block */
+    int last_eob_len;   /* bit length of EOB code for last block */
+
+#ifdef DEBUG
+    ulg compressed_len; /* total bit length of compressed file mod 2^32 */
+    ulg bits_sent;      /* bit length of compressed data sent mod 2^32 */
+#endif
+
+    ush bi_buf;
+    /* Output buffer. bits are inserted starting at the bottom (least
+     * significant bits).
+     */
+    int bi_valid;
+    /* Number of valid bits in bi_buf.  All bits above the last valid bit
+     * are always zero.
+     */
+
+} FAR deflate_state;
+
+/* Output a byte on the stream.
+ * IN assertion: there is enough room in pending_buf.
+ */
+#define put_byte(s, c) {s->pending_buf[s->pending++] = (c);}
+
+
+#define MIN_LOOKAHEAD (MAX_MATCH+MIN_MATCH+1)
+/* Minimum amount of lookahead, except at the end of the input file.
+ * See deflate.c for comments about the MIN_MATCH+1.
+ */
+
+#define MAX_DIST(s)  ((s)->w_size-MIN_LOOKAHEAD)
+/* In order to simplify the code, particularly on 16 bit machines, match
+ * distances are limited to MAX_DIST instead of WSIZE.
+ */
+
+        /* in trees.c */
+void _tr_init         OF((deflate_state *s));
+int  _tr_tally        OF((deflate_state *s, unsigned dist, unsigned lc));
+void _tr_flush_block  OF((deflate_state *s, charf *buf, ulg stored_len,
+			  int eof));
+void _tr_align        OF((deflate_state *s));
+void _tr_stored_block OF((deflate_state *s, charf *buf, ulg stored_len,
+                          int eof));
+
+#define d_code(dist) \
+   ((dist) < 256 ? _dist_code[dist] : _dist_code[256+((dist)>>7)])
+/* Mapping from a distance to a distance code. dist is the distance - 1 and
+ * must not have side effects. _dist_code[256] and _dist_code[257] are never
+ * used.
+ */
+
+#ifndef DEBUG
+/* Inline versions of _tr_tally for speed: */
+
+#if defined(GEN_TREES_H) || !defined(STDC)
+  extern uch _length_code[];
+  extern uch _dist_code[];
+#else
+  extern const uch _length_code[];
+  extern const uch _dist_code[];
+#endif
+
+# define _tr_tally_lit(s, c, flush) \
+  { uch cc = (c); \
+    s->d_buf[s->last_lit] = 0; \
+    s->l_buf[s->last_lit++] = cc; \
+    s->dyn_ltree[cc].Freq++; \
+    flush = (s->last_lit == s->lit_bufsize-1); \
+   }
+# define _tr_tally_dist(s, distance, length, flush) \
+  { uch len = (length); \
+    ush dist = (distance); \
+    s->d_buf[s->last_lit] = dist; \
+    s->l_buf[s->last_lit++] = len; \
+    dist--; \
+    s->dyn_ltree[_length_code[len]+LITERALS+1].Freq++; \
+    s->dyn_dtree[d_code(dist)].Freq++; \
+    flush = (s->last_lit == s->lit_bufsize-1); \
+  }
+#else
+# define _tr_tally_lit(s, c, flush) flush = _tr_tally(s, 0, c)
+# define _tr_tally_dist(s, distance, length, flush) \
+              flush = _tr_tally(s, distance, length) 
+#endif
+
+#endif
diff --git a/collects/plot/src/all/disptab.h b/collects/plot/src/all/disptab.h
new file mode 100644
index 0000000000..6e98329ad0
--- /dev/null
+++ b/collects/plot/src/all/disptab.h
@@ -0,0 +1,92 @@
+/* $Id: disptab.h,v 1.1 2004/03/01 20:54:46 cozmic Exp $
+
+   Defines the data structure which holds the driver functions.
+*/
+
+#ifndef __DISPATCH_H__
+#define __DISPATCH_H__
+
+#include "plConfig.h"
+
+struct PLStream_struct;
+
+enum {
+    plDevType_FileOriented = 0,
+    plDevType_Interactive = 1,
+    plDevType_Null = -1
+};
+
+/*--------------------------------------------------------------------------*\
+ * Define structure containing pointers to device dependent functions.
+ *
+ * pl_MenuStr	Pointer to string that is printed in device menu. 
+ *
+ * pl_DevName	A short device "name" for device selection by name. 
+ *
+ * pl_type	0 for file-oriented device, 1 for interactive
+ *		(the null driver uses -1 here)
+ *
+ * pl_seq       The sequence number for ordering the presentation list of the
+ *              available drivers.  This is an ordering only, not an absolute
+ *              position in the list.
+ *
+ * pl_init	Initialize device.  This routine may also prompt the user
+ *		for certain device parameters or open a graphics file
+ *		(see note).  Called only once to set things up.  Certain
+ *		options such as familying and resolution (dots/mm) should
+ *		be set up before calling this routine (note: some drivers
+ *		ignore these).
+ *
+ * pl_line	Draws a line between two points. 
+ *
+ * pl_polyline	Draws a polyline (no broken segments).
+ *
+ * pl_eop	Finishes out current page (see note). 
+ *
+ * pl_bop	Set up for plotting on a new page. May also open a new
+ *		a new graphics file (see note). 
+ *
+ * pl_tidy	Tidy up. May close graphics file (see note). 
+ *
+ * pl_state	Handle change in PLStream state
+ *		(color, pen width, fill attribute, etc).
+ *
+ * pl_esc	Escape function for driver-specific commands.
+ *
+ *
+ * Notes:
+ *
+ * Most devices allow multi-page plots to be stored in a single graphics
+ * file, in which case the graphics file should be opened in the pl_init()
+ * routine, closed in pl_tidy(), and page advances done by calling pl_eop
+ * and pl_bop() in sequence. If multi-page plots need to be stored in
+ * different files then pl_bop() should open the file and pl_eop() should
+ * close it.  Do NOT open files in both pl_init() and pl_bop() or close
+ * files in both pl_eop() and pl_tidy().
+\*--------------------------------------------------------------------------*/
+
+typedef void (*plD_init_fp)    (struct PLStream_struct *);
+typedef void (*plD_line_fp)    (struct PLStream_struct *, short, short, short, short);
+typedef void (*plD_polyline_fp)(struct PLStream_struct *, short *, short *, PLINT);
+typedef void (*plD_eop_fp)     (struct PLStream_struct *);
+typedef void (*plD_bop_fp)     (struct PLStream_struct *);
+typedef void (*plD_tidy_fp)    (struct PLStream_struct *);
+typedef void (*plD_state_fp)   (struct PLStream_struct *, PLINT);
+typedef void (*plD_esc_fp)     (struct PLStream_struct *, PLINT, void *);
+
+typedef struct {
+    char *pl_MenuStr;
+    char *pl_DevName;
+    int  pl_type;
+    int  pl_seq;
+    plD_init_fp     pl_init;
+    plD_line_fp     pl_line;
+    plD_polyline_fp pl_polyline;
+    plD_eop_fp      pl_eop;
+    plD_bop_fp      pl_bop;
+    plD_tidy_fp     pl_tidy;
+    plD_state_fp    pl_state;
+    plD_esc_fp     pl_esc;
+} PLDispatchTable;
+
+#endif /* __DISPATCH_H__ */
diff --git a/collects/plot/src/all/drivers.h b/collects/plot/src/all/drivers.h
new file mode 100644
index 0000000000..aab3e7664e
--- /dev/null
+++ b/collects/plot/src/all/drivers.h
@@ -0,0 +1,80 @@
+/* $Id: drivers.h,v 1.1 2004/03/01 20:54:46 cozmic Exp $
+
+	Contains all prototypes for driver functions.
+*/
+
+#ifndef __DRIVERS_H__
+#define __DRIVERS_H__
+
+#include "pdf.h"
+#include "plstrm.h"
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+void plD_dispatch_init_mac8	( PLDispatchTable *pdt );
+void plD_dispatch_init_mac1	( PLDispatchTable *pdt );
+void plD_dispatch_init_nx	( PLDispatchTable *pdt );
+void plD_dispatch_init_os2	( PLDispatchTable *pdt );
+void plD_dispatch_init_xw	( PLDispatchTable *pdt );
+void plD_dispatch_init_gnome	( PLDispatchTable *pdt );
+void plD_dispatch_init_tk	( PLDispatchTable *pdt );
+void plD_dispatch_init_vga	( PLDispatchTable *pdt );
+void plD_dispatch_init_mgr	( PLDispatchTable *pdt );
+void plD_dispatch_init_win3	( PLDispatchTable *pdt );
+void plD_dispatch_init_vga	( PLDispatchTable *pdt );
+void plD_dispatch_init_vga	( PLDispatchTable *pdt );
+void plD_dispatch_init_vga	( PLDispatchTable *pdt );
+void plD_dispatch_init_tiff	( PLDispatchTable *pdt );
+void plD_dispatch_init_jpg	( PLDispatchTable *pdt );
+void plD_dispatch_init_jpeg	( PLDispatchTable *pdt );
+void plD_dispatch_init_bmp	( PLDispatchTable *pdt );
+void plD_dispatch_init_vga	( PLDispatchTable *pdt );
+void plD_dispatch_init_xterm	( PLDispatchTable *pdt );
+void plD_dispatch_init_tekt	( PLDispatchTable *pdt );
+void plD_dispatch_init_tek4107t	( PLDispatchTable *pdt );
+void plD_dispatch_init_mskermit	( PLDispatchTable *pdt );
+void plD_dispatch_init_versaterm( PLDispatchTable *pdt );
+void plD_dispatch_init_vlt	( PLDispatchTable *pdt );
+void plD_dispatch_init_conex	( PLDispatchTable *pdt );
+void plD_dispatch_init_dg	( PLDispatchTable *pdt );
+void plD_dispatch_init_plm	( PLDispatchTable *pdt );
+void plD_dispatch_init_tekf	( PLDispatchTable *pdt );
+void plD_dispatch_init_tek4107f	( PLDispatchTable *pdt );
+void plD_dispatch_init_psm	( PLDispatchTable *pdt );
+void plD_dispatch_init_psc	( PLDispatchTable *pdt );
+void plD_dispatch_init_xfig	( PLDispatchTable *pdt );
+void plD_dispatch_init_ljiip	( PLDispatchTable *pdt );
+void plD_dispatch_init_ljii	( PLDispatchTable *pdt );
+void plD_dispatch_init_hp7470	( PLDispatchTable *pdt );
+void plD_dispatch_init_hp7580	( PLDispatchTable *pdt );
+void plD_dispatch_init_hpgl	( PLDispatchTable *pdt );
+void plD_dispatch_init_imp	( PLDispatchTable *pdt );
+void plD_dispatch_init_pbm	( PLDispatchTable *pdt );
+void plD_dispatch_init_png	( PLDispatchTable *pdt );
+void plD_dispatch_init_cgm	( PLDispatchTable *pdt );
+void plD_dispatch_init_null	( PLDispatchTable *pdt );
+void plD_dispatch_init_tkwin	( PLDispatchTable *pdt );
+void plD_dispatch_init_pstex	( PLDispatchTable *pdt );
+void plD_dispatch_init_ntk	( PLDispatchTable *pdt );
+void plD_dispatch_init_mem	( PLDispatchTable *pdt );
+
+/* Prototypes for plot buffer calls. */
+
+void plbuf_init		(PLStream *);
+void plbuf_line		(PLStream *, short, short, short, short);
+void plbuf_polyline	(PLStream *, short *, short *, PLINT);
+void plbuf_eop		(PLStream *);
+void plbuf_bop		(PLStream *);
+void plbuf_tidy		(PLStream *);
+void plbuf_state	(PLStream *, PLINT);
+void plbuf_esc		(PLStream *, PLINT, void *);
+
+void plRemakePlot	(PLStream *);
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif	/* __DRIVERS_H__ */
diff --git a/collects/plot/src/all/gd.c b/collects/plot/src/all/gd.c
new file mode 100644
index 0000000000..2e404e394e
--- /dev/null
+++ b/collects/plot/src/all/gd.c
@@ -0,0 +1,3114 @@
+
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+
+#include <stdio.h>
+#include <math.h>
+#include <string.h>
+#include <stdlib.h>
+/* 2.03: don't include zlib here or we can't build without PNG */
+#include "gd.h"
+#include "gdhelpers.h"
+
+/* 2.0.12: this now checks the clipping rectangle */
+#define gdImageBoundsSafeMacro(im, x, y) (!((((y) < (im)->cy1) || ((y) > (im)->cy2)) || (((x) < (im)->cx1) || ((x) > (im)->cx2))))
+
+#ifdef _OSD_POSIX		/* BS2000 uses the EBCDIC char set instead of ASCII */
+#define CHARSET_EBCDIC
+#define __attribute__(any)	/*nothing */
+#endif
+/*_OSD_POSIX*/
+
+#ifndef CHARSET_EBCDIC
+#define ASC(ch)  ch
+#else /*CHARSET_EBCDIC */
+#define ASC(ch) gd_toascii[(unsigned char)ch]
+static const unsigned char gd_toascii[256] = {
+/*00 */ 0x00, 0x01, 0x02, 0x03, 0x85, 0x09, 0x86, 0x7f,
+  0x87, 0x8d, 0x8e, 0x0b, 0x0c, 0x0d, 0x0e, 0x0f,	/*................ */
+/*10 */ 0x10, 0x11, 0x12, 0x13, 0x8f, 0x0a, 0x08, 0x97,
+  0x18, 0x19, 0x9c, 0x9d, 0x1c, 0x1d, 0x1e, 0x1f,	/*................ */
+/*20 */ 0x80, 0x81, 0x82, 0x83, 0x84, 0x92, 0x17, 0x1b,
+  0x88, 0x89, 0x8a, 0x8b, 0x8c, 0x05, 0x06, 0x07,	/*................ */
+/*30 */ 0x90, 0x91, 0x16, 0x93, 0x94, 0x95, 0x96, 0x04,
+  0x98, 0x99, 0x9a, 0x9b, 0x14, 0x15, 0x9e, 0x1a,	/*................ */
+/*40 */ 0x20, 0xa0, 0xe2, 0xe4, 0xe0, 0xe1, 0xe3, 0xe5,
+  0xe7, 0xf1, 0x60, 0x2e, 0x3c, 0x28, 0x2b, 0x7c,	/* .........`.<(+| */
+/*50 */ 0x26, 0xe9, 0xea, 0xeb, 0xe8, 0xed, 0xee, 0xef,
+  0xec, 0xdf, 0x21, 0x24, 0x2a, 0x29, 0x3b, 0x9f,	/*&.........!$*);. */
+/*60 */ 0x2d, 0x2f, 0xc2, 0xc4, 0xc0, 0xc1, 0xc3, 0xc5,
+  0xc7, 0xd1, 0x5e, 0x2c, 0x25, 0x5f, 0x3e, 0x3f,
+/*-/........^,%_>?*/
+/*70 */ 0xf8, 0xc9, 0xca, 0xcb, 0xc8, 0xcd, 0xce, 0xcf,
+  0xcc, 0xa8, 0x3a, 0x23, 0x40, 0x27, 0x3d, 0x22,	/*..........:#@'=" */
+/*80 */ 0xd8, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67,
+  0x68, 0x69, 0xab, 0xbb, 0xf0, 0xfd, 0xfe, 0xb1,	/*.abcdefghi...... */
+/*90 */ 0xb0, 0x6a, 0x6b, 0x6c, 0x6d, 0x6e, 0x6f, 0x70,
+  0x71, 0x72, 0xaa, 0xba, 0xe6, 0xb8, 0xc6, 0xa4,	/*.jklmnopqr...... */
+/*a0 */ 0xb5, 0xaf, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78,
+  0x79, 0x7a, 0xa1, 0xbf, 0xd0, 0xdd, 0xde, 0xae,	/*..stuvwxyz...... */
+/*b0 */ 0xa2, 0xa3, 0xa5, 0xb7, 0xa9, 0xa7, 0xb6, 0xbc,
+  0xbd, 0xbe, 0xac, 0x5b, 0x5c, 0x5d, 0xb4, 0xd7,	/*...........[\].. */
+/*c0 */ 0xf9, 0x41, 0x42, 0x43, 0x44, 0x45, 0x46, 0x47,
+  0x48, 0x49, 0xad, 0xf4, 0xf6, 0xf2, 0xf3, 0xf5,	/*.ABCDEFGHI...... */
+/*d0 */ 0xa6, 0x4a, 0x4b, 0x4c, 0x4d, 0x4e, 0x4f, 0x50,
+  0x51, 0x52, 0xb9, 0xfb, 0xfc, 0xdb, 0xfa, 0xff,	/*.JKLMNOPQR...... */
+/*e0 */ 0xd9, 0xf7, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58,
+  0x59, 0x5a, 0xb2, 0xd4, 0xd6, 0xd2, 0xd3, 0xd5,	/*..STUVWXYZ...... */
+/*f0 */ 0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37,
+  0x38, 0x39, 0xb3, 0x7b, 0xdc, 0x7d, 0xda, 0x7e	/*0123456789.{.}.~ */
+};
+#endif /*CHARSET_EBCDIC */
+
+extern int gdCosT[];
+extern int gdSinT[];
+
+static void gdImageBrushApply (gdImagePtr im, int x, int y);
+static void gdImageTileApply (gdImagePtr im, int x, int y);
+static void gdImageAntiAliasedApply (gdImagePtr im, int x, int y);
+static int gdImageGetTrueColorPixel (gdImagePtr im, int x, int y);
+
+gdImagePtr
+gdImageCreate (int sx, int sy)
+{
+  int i;
+  gdImagePtr im;
+  im = (gdImage *) gdMalloc (sizeof (gdImage));
+  memset (im, 0, sizeof (gdImage));
+  /* Row-major ever since gd 1.3 */
+  im->pixels = (unsigned char **) gdMalloc (sizeof (unsigned char *) * sy);
+  im->AA_opacity =
+    (unsigned char **) gdMalloc (sizeof (unsigned char *) * sy);
+  im->polyInts = 0;
+  im->polyAllocated = 0;
+  im->brush = 0;
+  im->tile = 0;
+  im->style = 0;
+  for (i = 0; (i < sy); i++)
+    {
+      /* Row-major ever since gd 1.3 */
+      im->pixels[i] = (unsigned char *) gdCalloc (sx, sizeof (unsigned char));
+      im->AA_opacity[i] =
+	(unsigned char *) gdCalloc (sx, sizeof (unsigned char));
+    }
+  im->sx = sx;
+  im->sy = sy;
+  im->colorsTotal = 0;
+  im->transparent = (-1);
+  im->interlace = 0;
+  im->thick = 1;
+  im->AA = 0;
+  im->AA_polygon = 0;
+  for (i = 0; (i < gdMaxColors); i++)
+    {
+      im->open[i] = 1;
+      im->red[i] = 0;
+      im->green[i] = 0;
+      im->blue[i] = 0;
+    };
+  im->trueColor = 0;
+  im->tpixels = 0;
+  im->cx1 = 0;
+  im->cy1 = 0;
+  im->cx2 = im->sx - 1;
+  im->cy2 = im->sy - 1;
+  return im;
+}
+
+gdImagePtr
+gdImageCreateTrueColor (int sx, int sy)
+{
+  int i;
+  gdImagePtr im;
+  im = (gdImage *) gdMalloc (sizeof (gdImage));
+  memset (im, 0, sizeof (gdImage));
+  im->tpixels = (int **) gdMalloc (sizeof (int *) * sy);
+  im->AA_opacity =
+    (unsigned char **) gdMalloc (sizeof (unsigned char *) * sy);
+  im->polyInts = 0;
+  im->polyAllocated = 0;
+  im->brush = 0;
+  im->tile = 0;
+  im->style = 0;
+  for (i = 0; (i < sy); i++)
+    {
+      im->tpixels[i] = (int *) gdCalloc (sx, sizeof (int));
+      im->AA_opacity[i] =
+	(unsigned char *) gdCalloc (sx, sizeof (unsigned char));
+    }
+  im->sx = sx;
+  im->sy = sy;
+  im->transparent = (-1);
+  im->interlace = 0;
+  im->trueColor = 1;
+  /* 2.0.2: alpha blending is now on by default, and saving of alpha is
+     off by default. This allows font antialiasing to work as expected
+     on the first try in JPEGs -- quite important -- and also allows 
+     for smaller PNGs when saving of alpha channel is not really 
+     desired, which it usually isn't! */
+  im->saveAlphaFlag = 0;
+  im->alphaBlendingFlag = 1;
+  im->thick = 1;
+  im->AA = 0;
+  im->AA_polygon = 0;
+  im->cx1 = 0;
+  im->cy1 = 0;
+  im->cx2 = im->sx - 1;
+  im->cy2 = im->sy - 1;
+  return im;
+}
+
+void
+gdImageDestroy (gdImagePtr im)
+{
+  int i;
+  if (im->pixels)
+    {
+      for (i = 0; (i < im->sy); i++)
+	{
+	  gdFree (im->pixels[i]);
+	}
+      gdFree (im->pixels);
+    }
+  if (im->tpixels)
+    {
+      for (i = 0; (i < im->sy); i++)
+	{
+	  gdFree (im->tpixels[i]);
+	}
+      gdFree (im->tpixels);
+    }
+  if (im->AA_opacity)
+    {
+      for (i = 0; (i < im->sy); i++)
+	{
+	  gdFree (im->AA_opacity[i]);
+	}
+      gdFree (im->AA_opacity);
+    }
+  if (im->polyInts)
+    {
+      gdFree (im->polyInts);
+    }
+  if (im->style)
+    {
+      gdFree (im->style);
+    }
+  gdFree (im);
+}
+
+int
+gdImageColorClosest (gdImagePtr im, int r, int g, int b)
+{
+  return gdImageColorClosestAlpha (im, r, g, b, gdAlphaOpaque);
+}
+
+int
+gdImageColorClosestAlpha (gdImagePtr im, int r, int g, int b, int a)
+{
+  int i;
+  long rd, gd, bd, ad;
+  int ct = (-1);
+  int first = 1;
+  long mindist = 0;
+  if (im->trueColor)
+    {
+      return gdTrueColorAlpha (r, g, b, a);
+    }
+  for (i = 0; (i < (im->colorsTotal)); i++)
+    {
+      long dist;
+      if (im->open[i])
+	{
+	  continue;
+	}
+      rd = (im->red[i] - r);
+      gd = (im->green[i] - g);
+      bd = (im->blue[i] - b);
+      /* gd 2.02: whoops, was - b (thanks to David Marwood) */
+      ad = (im->blue[i] - a);
+      dist = rd * rd + gd * gd + bd * bd + ad * ad;
+      if (first || (dist < mindist))
+	{
+	  mindist = dist;
+	  ct = i;
+	  first = 0;
+	}
+    }
+  return ct;
+}
+
+/* This code is taken from http://www.acm.org/jgt/papers/SmithLyons96/hwb_rgb.html, an article
+ * on colour conversion to/from RBG and HWB colour systems. 
+ * It has been modified to return the converted value as a * parameter. 
+ */
+
+#define RETURN_HWB(h, w, b) {HWB->H = h; HWB->W = w; HWB->B = b; return HWB;}
+#define RETURN_RGB(r, g, b) {RGB->R = r; RGB->G = g; RGB->B = b; return RGB;}
+#define HWB_UNDEFINED -1
+#define SETUP_RGB(s, r, g, b) {s.R = r/255.0; s.G = g/255.0; s.B = b/255.0;}
+
+#define MIN(a,b) ((a)<(b)?(a):(b))
+#define MIN3(a,b,c) ((a)<(b)?(MIN(a,c)):(MIN(b,c)))
+#define MAX(a,b) ((a)<(b)?(b):(a))
+#define MAX3(a,b,c) ((a)<(b)?(MAX(b,c)):(MAX(a,c)))
+
+
+/*
+ * Theoretically, hue 0 (pure red) is identical to hue 6 in these transforms. Pure 
+ * red always maps to 6 in this implementation. Therefore UNDEFINED can be 
+ * defined as 0 in situations where only unsigned numbers are desired.
+ */
+typedef struct
+{
+  float R, G, B;
+}
+RGBType;
+typedef struct
+{
+  float H, W, B;
+}
+HWBType;
+
+static HWBType *
+RGB_to_HWB (RGBType RGB, HWBType * HWB)
+{
+
+  /*
+   * RGB are each on [0, 1]. W and B are returned on [0, 1] and H is  
+   * returned on [0, 6]. Exception: H is returned UNDEFINED if W == 1 - B.  
+   */
+
+  float R = RGB.R, G = RGB.G, B = RGB.B, w, v, b, f;
+  int i;
+
+  w = MIN3 (R, G, B);
+  v = MAX3 (R, G, B);
+  b = 1 - v;
+  if (v == w)
+    RETURN_HWB (HWB_UNDEFINED, w, b);
+  f = (R == w) ? G - B : ((G == w) ? B - R : R - G);
+  i = (R == w) ? 3 : ((G == w) ? 5 : 1);
+  RETURN_HWB (i - f / (v - w), w, b);
+
+}
+
+static float
+HWB_Diff (int r1, int g1, int b1, int r2, int g2, int b2)
+{
+  RGBType RGB1, RGB2;
+  HWBType HWB1, HWB2;
+  float diff;
+
+  SETUP_RGB (RGB1, r1, g1, b1);
+  SETUP_RGB (RGB2, r2, g2, b2);
+
+  RGB_to_HWB (RGB1, &HWB1);
+  RGB_to_HWB (RGB2, &HWB2);
+
+  /*
+   * I made this bit up; it seems to produce OK results, and it is certainly
+   * more visually correct than the current RGB metric. (PJW)
+   */
+
+  if ((HWB1.H == HWB_UNDEFINED) || (HWB2.H == HWB_UNDEFINED))
+    {
+      diff = 0;			/* Undefined hues always match... */
+    }
+  else
+    {
+      diff = abs (HWB1.H - HWB2.H);
+      if (diff > 3)
+	{
+	  diff = 6 - diff;	/* Remember, it's a colour circle */
+	}
+    }
+
+  diff =
+    diff * diff + (HWB1.W - HWB2.W) * (HWB1.W - HWB2.W) + (HWB1.B -
+							   HWB2.B) * (HWB1.B -
+								      HWB2.B);
+
+  return diff;
+}
+
+
+#if 0
+/*
+ * This is not actually used, but is here for completeness, in case someone wants to
+ * use the HWB stuff for anything else...
+ */
+static RGBType *
+HWB_to_RGB (HWBType HWB, RGBType * RGB)
+{
+
+  /* 
+   * H is given on [0, 6] or UNDEFINED. W and B are given on [0, 1].  
+   * RGB are each returned on [0, 1]. 
+   */
+
+  float h = HWB.H, w = HWB.W, b = HWB.B, v, n, f;
+  int i;
+
+  v = 1 - b;
+  if (h == HWB_UNDEFINED)
+    RETURN_RGB (v, v, v);
+  i = floor (h);
+  f = h - i;
+  if (i & 1)
+    f = 1 - f;			/* if i is odd */
+  n = w + f * (v - w);		/* linear interpolation between w and v */
+  switch (i)
+    {
+    case 6:
+    case 0:
+      RETURN_RGB (v, n, w);
+    case 1:
+      RETURN_RGB (n, v, w);
+    case 2:
+      RETURN_RGB (w, v, n);
+    case 3:
+      RETURN_RGB (w, n, v);
+    case 4:
+      RETURN_RGB (n, w, v);
+    case 5:
+      RETURN_RGB (v, w, n);
+    }
+
+  return RGB;
+
+}
+#endif
+
+int
+gdImageColorClosestHWB (gdImagePtr im, int r, int g, int b)
+{
+  int i;
+  /* long rd, gd, bd; */
+  int ct = (-1);
+  int first = 1;
+  float mindist = 0;
+  if (im->trueColor)
+    {
+      return gdTrueColor (r, g, b);
+    }
+  for (i = 0; (i < (im->colorsTotal)); i++)
+    {
+      float dist;
+      if (im->open[i])
+	{
+	  continue;
+	}
+      dist = HWB_Diff (im->red[i], im->green[i], im->blue[i], r, g, b);
+      if (first || (dist < mindist))
+	{
+	  mindist = dist;
+	  ct = i;
+	  first = 0;
+	}
+    }
+  return ct;
+}
+
+int
+gdImageColorExact (gdImagePtr im, int r, int g, int b)
+{
+  return gdImageColorExactAlpha (im, r, g, b, gdAlphaOpaque);
+}
+
+int
+gdImageColorExactAlpha (gdImagePtr im, int r, int g, int b, int a)
+{
+  int i;
+  if (im->trueColor)
+    {
+      return gdTrueColorAlpha (r, g, b, a);
+    }
+  for (i = 0; (i < (im->colorsTotal)); i++)
+    {
+      if (im->open[i])
+	{
+	  continue;
+	}
+      if ((im->red[i] == r) &&
+	  (im->green[i] == g) && (im->blue[i] == b) && (im->alpha[i] == a))
+	{
+	  return i;
+	}
+    }
+  return -1;
+}
+
+int
+gdImageColorAllocate (gdImagePtr im, int r, int g, int b)
+{
+  return gdImageColorAllocateAlpha (im, r, g, b, gdAlphaOpaque);
+}
+
+int
+gdImageColorAllocateAlpha (gdImagePtr im, int r, int g, int b, int a)
+{
+  int i;
+  int ct = (-1);
+  if (im->trueColor)
+    {
+      return gdTrueColorAlpha (r, g, b, a);
+    }
+  for (i = 0; (i < (im->colorsTotal)); i++)
+    {
+      if (im->open[i])
+	{
+	  ct = i;
+	  break;
+	}
+    }
+  if (ct == (-1))
+    {
+      ct = im->colorsTotal;
+      if (ct == gdMaxColors)
+	{
+	  return -1;
+	}
+      im->colorsTotal++;
+    }
+  im->red[ct] = r;
+  im->green[ct] = g;
+  im->blue[ct] = b;
+  im->alpha[ct] = a;
+  im->open[ct] = 0;
+  return ct;
+}
+
+/*
+ * gdImageColorResolve is an alternative for the code fragment:
+ *
+ *      if ((color=gdImageColorExact(im,R,G,B)) < 0)
+ *        if ((color=gdImageColorAllocate(im,R,G,B)) < 0)
+ *          color=gdImageColorClosest(im,R,G,B);
+ *
+ * in a single function.    Its advantage is that it is guaranteed to
+ * return a color index in one search over the color table.
+ */
+
+int
+gdImageColorResolve (gdImagePtr im, int r, int g, int b)
+{
+  return gdImageColorResolveAlpha (im, r, g, b, gdAlphaOpaque);
+}
+
+int
+gdImageColorResolveAlpha (gdImagePtr im, int r, int g, int b, int a)
+{
+  int c;
+  int ct = -1;
+  int op = -1;
+  long rd, gd, bd, ad, dist;
+  long mindist = 4 * 255 * 255;	/* init to max poss dist */
+  if (im->trueColor)
+    {
+      return gdTrueColorAlpha (r, g, b, a);
+    }
+
+  for (c = 0; c < im->colorsTotal; c++)
+    {
+      if (im->open[c])
+	{
+	  op = c;		/* Save open slot */
+	  continue;		/* Color not in use */
+	}
+      if (c == im->transparent)
+	{
+	  /* don't ever resolve to the color that has
+	   * been designated as the transparent color */
+	  continue;
+	}
+      rd = (long) (im->red[c] - r);
+      gd = (long) (im->green[c] - g);
+      bd = (long) (im->blue[c] - b);
+      ad = (long) (im->alpha[c] - a);
+      dist = rd * rd + gd * gd + bd * bd + ad * ad;
+      if (dist < mindist)
+	{
+	  if (dist == 0)
+	    {
+	      return c;		/* Return exact match color */
+	    }
+	  mindist = dist;
+	  ct = c;
+	}
+    }
+  /* no exact match.  We now know closest, but first try to allocate exact */
+  if (op == -1)
+    {
+      op = im->colorsTotal;
+      if (op == gdMaxColors)
+	{			/* No room for more colors */
+	  return ct;		/* Return closest available color */
+	}
+      im->colorsTotal++;
+    }
+  im->red[op] = r;
+  im->green[op] = g;
+  im->blue[op] = b;
+  im->alpha[op] = a;
+  im->open[op] = 0;
+  return op;			/* Return newly allocated color */
+}
+
+void
+gdImageColorDeallocate (gdImagePtr im, int color)
+{
+  if (im->trueColor)
+    {
+      return;
+    }
+  /* Mark it open. */
+  im->open[color] = 1;
+}
+
+void
+gdImageColorTransparent (gdImagePtr im, int color)
+{
+  if (!im->trueColor)
+    {
+      if (im->transparent != -1)
+	{
+	  im->alpha[im->transparent] = gdAlphaOpaque;
+	}
+      if (color != -1)
+	{
+	  im->alpha[color] = gdAlphaTransparent;
+	}
+    }
+  im->transparent = color;
+}
+
+void
+gdImagePaletteCopy (gdImagePtr to, gdImagePtr from)
+{
+  int i;
+  int x, y, p;
+  int xlate[256];
+  if (to->trueColor)
+    {
+      return;
+    }
+  if (from->trueColor)
+    {
+      return;
+    }
+
+  for (i = 0; i < 256; i++)
+    {
+      xlate[i] = -1;
+    };
+
+  for (x = 0; x < (to->sx); x++)
+    {
+      for (y = 0; y < (to->sy); y++)
+	{
+	  p = gdImageGetPixel (to, x, y);
+	  if (xlate[p] == -1)
+	    {
+	      /* This ought to use HWB, but we don't have an alpha-aware
+	         version of that yet. */
+	      xlate[p] =
+		gdImageColorClosestAlpha (from, to->red[p], to->green[p],
+					  to->blue[p], to->alpha[p]);
+	      /*printf("Mapping %d (%d, %d, %d, %d) to %d (%d, %d, %d, %d)\n", */
+	      /*      p,  to->red[p], to->green[p], to->blue[p], to->alpha[p], */
+	      /*      xlate[p], from->red[xlate[p]], from->green[xlate[p]], from->blue[xlate[p]], from->alpha[xlate[p]]); */
+	    };
+	  gdImageSetPixel (to, x, y, xlate[p]);
+	};
+    };
+
+  for (i = 0; (i < (from->colorsTotal)); i++)
+    {
+      /*printf("Copying color %d (%d, %d, %d, %d)\n", i, from->red[i], from->blue[i], from->green[i], from->alpha[i]); */
+      to->red[i] = from->red[i];
+      to->blue[i] = from->blue[i];
+      to->green[i] = from->green[i];
+      to->alpha[i] = from->alpha[i];
+      to->open[i] = 0;
+    };
+
+  for (i = from->colorsTotal; (i < to->colorsTotal); i++)
+    {
+      to->open[i] = 1;
+    };
+
+  to->colorsTotal = from->colorsTotal;
+
+}
+
+/* 2.0.10: before the drawing routines, some code to clip points that are
+ * outside the drawing window.  Nick Atty (nick@canalplan.org.uk)
+ *
+ * This is the Sutherland Hodgman Algorithm, as implemented by
+ * Duvanenko, Robbins and Gyurcsik - SH(DRG) for short.  See Dr Dobb's
+ * Journal, January 1996, pp107-110 and 116-117
+ *
+ * Given the end points of a line, and a bounding rectangle (which we
+ * know to be from (0,0) to (SX,SY)), adjust the endpoints to be on
+ * the edges of the rectangle if the line should be drawn at all,
+ * otherwise return a failure code */
+
+/* this does "one-dimensional" clipping: note that the second time it
+   is called, all the x parameters refer to height and the y to width
+   - the comments ignore this (if you can understand it when it's
+   looking at the X parameters, it should become clear what happens on
+   the second call!)  The code is simplified from that in the article,
+   as we know that gd images always start at (0,0) */
+
+static int
+clip_1d (int *x0, int *y0, int *x1, int *y1, int maxdim)
+{
+  double m;			/* gradient of line */
+  if (*x0 < 0)
+    {				/* start of line is left of window */
+      if (*x1 < 0)		/* as is the end, so the line never cuts the window */
+	return 0;
+      m = (*y1 - *y0) / (double) (*x1 - *x0);	/* calculate the slope of the line */
+      /* adjust x0 to be on the left boundary (ie to be zero), and y0 to match */
+      *y0 -= m * *x0;
+      *x0 = 0;
+      /* now, perhaps, adjust the far end of the line as well */
+      if (*x1 > maxdim)
+	{
+	  *y1 += m * (maxdim - *x1);
+	  *x1 = maxdim;
+	}
+      return 1;
+    }
+  if (*x0 > maxdim)
+    {				/* start of line is right of window -
+				   complement of above */
+      if (*x1 > maxdim)		/* as is the end, so the line misses the window */
+	return 0;
+      m = (*y1 - *y0) / (double) (*x1 - *x0);	/* calculate the slope of the line */
+      *y0 += m * (maxdim - *x0);	/* adjust so point is on the right
+					   boundary */
+      *x0 = maxdim;
+      /* now, perhaps, adjust the end of the line */
+      if (*x1 < 0)
+	{
+	  *y1 -= m * *x1;
+	  *x1 = 0;
+	}
+      return 1;
+    }
+  /* the final case - the start of the line is inside the window */
+  if (*x1 > maxdim)
+    {				/* other end is outside to the right */
+      m = (*y1 - *y0) / (double) (*x1 - *x0);	/* calculate the slope of the line */
+      *y1 += m * (maxdim - *x1);
+      *x1 = maxdim;
+      return 1;
+    }
+  if (*x1 < 0)
+    {				/* other end is outside to the left */
+      m = (*y1 - *y0) / (double) (*x1 - *x0);	/* calculate the slope of the line */
+      *y1 -= m * *x1;
+      *x1 = 0;
+      return 1;
+    }
+  /* only get here if both points are inside the window */
+  return 1;
+}
+
+/* end of line clipping code */
+
+void
+gdImageSetPixel (gdImagePtr im, int x, int y, int color)
+{
+  int p;
+  switch (color)
+    {
+    case gdStyled:
+      if (!im->style)
+	{
+	  /* Refuse to draw if no style is set. */
+	  return;
+	}
+      else
+	{
+	  p = im->style[im->stylePos++];
+	}
+      if (p != (gdTransparent))
+	{
+	  gdImageSetPixel (im, x, y, p);
+	}
+      im->stylePos = im->stylePos % im->styleLength;
+      break;
+    case gdStyledBrushed:
+      if (!im->style)
+	{
+	  /* Refuse to draw if no style is set. */
+	  return;
+	}
+      p = im->style[im->stylePos++];
+      if ((p != gdTransparent) && (p != 0))
+	{
+	  gdImageSetPixel (im, x, y, gdBrushed);
+	}
+      im->stylePos = im->stylePos % im->styleLength;
+      break;
+    case gdBrushed:
+      gdImageBrushApply (im, x, y);
+      break;
+    case gdTiled:
+      gdImageTileApply (im, x, y);
+      break;
+    case gdAntiAliased:
+      gdImageAntiAliasedApply (im, x, y);
+      break;
+    default:
+      if (gdImageBoundsSafeMacro (im, x, y))
+	{
+	  if (im->trueColor)
+	    {
+	      if (im->alphaBlendingFlag)
+		{
+		  im->tpixels[y][x] = gdAlphaBlend (im->tpixels[y][x], color);
+		}
+	      else
+		{
+		  im->tpixels[y][x] = color;
+		}
+	    }
+	  else
+	    {
+	      im->pixels[y][x] = color;
+	    }
+	}
+      break;
+    }
+}
+
+static void
+gdImageBrushApply (gdImagePtr im, int x, int y)
+{
+  int lx, ly;
+  int hy;
+  int hx;
+  int x1, y1, x2, y2;
+  int srcx, srcy;
+  if (!im->brush)
+    {
+      return;
+    }
+  hy = gdImageSY (im->brush) / 2;
+  y1 = y - hy;
+  y2 = y1 + gdImageSY (im->brush);
+  hx = gdImageSX (im->brush) / 2;
+  x1 = x - hx;
+  x2 = x1 + gdImageSX (im->brush);
+  srcy = 0;
+  if (im->trueColor)
+    {
+      if (im->brush->trueColor)
+	{
+	  for (ly = y1; (ly < y2); ly++)
+	    {
+	      srcx = 0;
+	      for (lx = x1; (lx < x2); lx++)
+		{
+		  int p;
+		  p = gdImageGetTrueColorPixel (im->brush, srcx, srcy);
+		  /* 2.0.9, Thomas Winzig: apply simple full transparency */
+		  if (p != gdImageGetTransparent (im->brush))
+		    {
+		      gdImageSetPixel (im, lx, ly, p);
+		    }
+		  srcx++;
+		}
+	      srcy++;
+	    }
+	}
+      else
+	{
+	  /* 2.0.12: Brush palette, image truecolor (thanks to Thorben Kundinger
+	     for pointing out the issue) */
+	  for (ly = y1; (ly < y2); ly++)
+	    {
+	      srcx = 0;
+	      for (lx = x1; (lx < x2); lx++)
+		{
+		  int p, tc;
+		  p = gdImageGetPixel (im->brush, srcx, srcy);
+		  tc = gdImageGetTrueColorPixel (im->brush, srcx, srcy);
+		  /* 2.0.9, Thomas Winzig: apply simple full transparency */
+		  if (p != gdImageGetTransparent (im->brush))
+		    {
+		      gdImageSetPixel (im, lx, ly, tc);
+		    }
+		  srcx++;
+		}
+	      srcy++;
+	    }
+	}
+    }
+  else
+    {
+      for (ly = y1; (ly < y2); ly++)
+	{
+	  srcx = 0;
+	  for (lx = x1; (lx < x2); lx++)
+	    {
+	      int p;
+	      p = gdImageGetPixel (im->brush, srcx, srcy);
+	      /* Allow for non-square brushes! */
+	      if (p != gdImageGetTransparent (im->brush))
+		{
+		  /* Truecolor brush. Very slow
+		     on a palette destination. */
+		  if (im->brush->trueColor)
+		    {
+		      gdImageSetPixel (im, lx, ly,
+				       gdImageColorResolveAlpha (im,
+								 gdTrueColorGetRed
+								 (p),
+								 gdTrueColorGetGreen
+								 (p),
+								 gdTrueColorGetBlue
+								 (p),
+								 gdTrueColorGetAlpha
+								 (p)));
+		    }
+		  else
+		    {
+		      gdImageSetPixel (im, lx, ly, im->brushColorMap[p]);
+		    }
+		}
+	      srcx++;
+	    }
+	  srcy++;
+	}
+    }
+}
+
+static void
+gdImageTileApply (gdImagePtr im, int x, int y)
+{
+  int srcx, srcy;
+  int p;
+  if (!im->tile)
+    {
+      return;
+    }
+  srcx = x % gdImageSX (im->tile);
+  srcy = y % gdImageSY (im->tile);
+  if (im->trueColor)
+    {
+      p = gdImageGetTrueColorPixel (im->tile, srcx, srcy);
+      gdImageSetPixel (im, x, y, p);
+    }
+  else
+    {
+      p = gdImageGetPixel (im->tile, srcx, srcy);
+      /* Allow for transparency */
+      if (p != gdImageGetTransparent (im->tile))
+	{
+	  if (im->tile->trueColor)
+	    {
+	      /* Truecolor tile. Very slow
+	         on a palette destination. */
+	      gdImageSetPixel (im, x, y,
+			       gdImageColorResolveAlpha (im,
+							 gdTrueColorGetRed
+							 (p),
+							 gdTrueColorGetGreen
+							 (p),
+							 gdTrueColorGetBlue
+							 (p),
+							 gdTrueColorGetAlpha
+							 (p)));
+	    }
+	  else
+	    {
+	      gdImageSetPixel (im, x, y, im->tileColorMap[p]);
+	    }
+	}
+    }
+}
+
+static void
+gdImageAntiAliasedApply (gdImagePtr im, int px, int py)
+{
+  float p_dist, p_alpha;
+  unsigned char opacity;
+
+  /* 
+   * Find the perpendicular distance from point C (px, py) to the line 
+   * segment AB that is being drawn.  (Adapted from an algorithm from the
+   * comp.graphics.algorithms FAQ.)
+   */
+
+  int LAC_2, LBC_2;
+
+  int Ax_Cx = im->AAL_x1 - px;
+  int Ay_Cy = im->AAL_y1 - py;
+
+  int Bx_Cx = im->AAL_x2 - px;
+  int By_Cy = im->AAL_y2 - py;
+  /* 2.0.13: bounds check! AA_opacity is just as capable of
+    overflowing as the main pixel array. Arne Jorgensen. 
+    2.0.14: typo fixed. 2.0.15: moved down below declarations
+    to satisfy non-C++ compilers. */
+  if (!gdImageBoundsSafeMacro (im, px, py))
+  {
+    return;
+  }
+  /* Get the squares of the lengths of the segemnts AC and BC. */
+  LAC_2 = (Ax_Cx * Ax_Cx) + (Ay_Cy * Ay_Cy);
+  LBC_2 = (Bx_Cx * Bx_Cx) + (By_Cy * By_Cy);
+
+  if (((im->AAL_LAB_2 + LAC_2) >= LBC_2) &&
+      ((im->AAL_LAB_2 + LBC_2) >= LAC_2))
+    {
+      /* The two angles are acute.  The point lies inside the portion of the 
+       * plane spanned by the line segment. */
+      p_dist = fabs ((float) ((Ay_Cy * im->AAL_Bx_Ax) -
+			      (Ax_Cx * im->AAL_By_Ay)) / im->AAL_LAB);
+    }
+  else
+    {
+      /* The point is past an end of the line segment.  It's length from the 
+       * segment is the shorter of the lengths from the endpoints, but call
+       * the distance -1, so as not to compute the alpha nor draw the pixel.
+       */
+      p_dist = -1;
+    }
+
+  if ((p_dist >= 0) && (p_dist <= (float) (im->thick)))
+    {
+      p_alpha = pow (1.0 - (p_dist / 1.5), 2);
+
+      if (p_alpha > 0)
+	{
+	  if (p_alpha >= 1)
+	    opacity = 255;
+	  else
+	    opacity = (unsigned char) (p_alpha * 255.0);
+	  if (!(im->AA_polygon) || (im->AA_opacity[py][px] < opacity))
+	    im->AA_opacity[py][px] = opacity;
+	}
+    }
+}
+
+int
+gdImageGetPixel (gdImagePtr im, int x, int y)
+{
+  if (gdImageBoundsSafeMacro (im, x, y))
+    {
+      if (im->trueColor)
+	{
+	  return im->tpixels[y][x];
+	}
+      else
+	{
+	  return im->pixels[y][x];
+	}
+    }
+  else
+    {
+      return 0;
+    }
+}
+
+static int
+gdImageGetTrueColorPixel (gdImagePtr im, int x, int y)
+{
+  int p = gdImageGetPixel (im, x, y);
+  if (!im->trueColor)
+    {
+      return gdTrueColorAlpha (im->red[p], im->green[p], im->blue[p],
+			       (im->transparent == p) ? gdAlphaTransparent :
+			       gdAlphaOpaque);
+    }
+  else
+    {
+      return p;
+    }
+}
+
+void
+gdImageAABlend (gdImagePtr im)
+{
+  float p_alpha, old_alpha;
+  int color = im->AA_color, color_red, color_green, color_blue;
+  int old_color, old_red, old_green, old_blue;
+  int p_color, p_red, p_green, p_blue;
+  int px, py;
+
+  color_red = gdImageRed (im, color);
+  color_green = gdImageGreen (im, color);
+  color_blue = gdImageBlue (im, color);
+
+  /* Impose the anti-aliased drawing on the image. */
+  for (py = 0; py < im->sy; py++)
+    {
+      for (px = 0; px < im->sx; px++)
+	{
+	  if (im->AA_opacity[py][px] != 0)
+	    {
+	      old_color = gdImageGetPixel (im, px, py);
+
+	      if ((old_color != color)
+		  && ((old_color != im->AA_dont_blend)
+		      || (im->AA_opacity[py][px] == 255)))
+		{
+		  /* Only blend with different colors that aren't the 
+		   * dont_blend color. */
+		  p_alpha = (float) (im->AA_opacity[py][px]) / 255.0;
+		  old_alpha = 1.0 - p_alpha;
+
+		  if (p_alpha >= 1.0)
+		    p_color = color;
+		  else
+		    {
+		      old_red = gdImageRed (im, old_color);
+		      old_green = gdImageGreen (im, old_color);
+		      old_blue = gdImageBlue (im, old_color);
+
+		      p_red = (int) (((float) color_red * p_alpha) +
+				     ((float) old_red * old_alpha));
+		      p_green = (int) (((float) color_green * p_alpha) +
+				       ((float) old_green * old_alpha));
+		      p_blue = (int) (((float) color_blue * p_alpha) +
+				      ((float) old_blue * old_alpha));
+		      p_color =
+			gdImageColorResolve (im, p_red, p_green, p_blue);
+		    }
+		  gdImageSetPixel (im, px, py, p_color);
+		}
+	    }
+	}
+      /* Clear the AA_opacity array behind us. */
+      memset (im->AA_opacity[py], 0, im->sx);
+    }
+}
+
+/* Bresenham as presented in Foley & Van Dam */
+void
+gdImageLine (gdImagePtr im, int x1, int y1, int x2, int y2, int color)
+{
+  int dx, dy, incr1, incr2, d, x, y, xend, yend, xdirflag, ydirflag;
+  int wid;
+  int w, wstart;
+  int thick = im->thick;
+
+  /* 2.0.10: Nick Atty: clip to edges of drawing rectangle, return if no
+     points need to be drawn */
+
+  if (clip_1d (&x1, &y1, &x2, &y2, gdImageSX (im)) == 0)
+    return;
+  if (clip_1d (&y1, &x1, &y2, &x2, gdImageSY (im)) == 0)
+    return;
+
+  /* gdAntiAliased passed as color: set anti-aliased line (AAL) global vars. */
+  if (color == gdAntiAliased)
+    {
+      im->AAL_x1 = x1;
+      im->AAL_y1 = y1;
+      im->AAL_x2 = x2;
+      im->AAL_y2 = y2;
+
+      /* Compute what we can for point-to-line distance calculation later. */
+      im->AAL_Bx_Ax = x2 - x1;
+      im->AAL_By_Ay = y2 - y1;
+      im->AAL_LAB_2 =
+	(im->AAL_Bx_Ax * im->AAL_Bx_Ax) + (im->AAL_By_Ay * im->AAL_By_Ay);
+      im->AAL_LAB = sqrt (im->AAL_LAB_2);
+
+      /* For AA, we must draw pixels outside the width of the line.  Keep in
+       * mind that this will be curtailed by cos/sin of theta later. */
+      thick += 4;
+    }
+
+  dx = abs (x2 - x1);
+  dy = abs (y2 - y1);
+  if (dy <= dx)
+    {
+      /* More-or-less horizontal. use wid for vertical stroke */
+      /* Doug Claar: watch out for NaN in atan2 (2.0.5) */
+      if ((dx == 0) && (dy == 0))
+	{
+	  wid = 1;
+	}
+      else
+	{
+	  /* 2.0.12: Michael Schwartz: divide rather than multiply;
+	     TBB: but watch out for /0! */
+	  double ac = cos (atan2 (dy, dx));
+	  if (ac != 0)
+	    {
+	      wid = thick / ac;
+	    }
+	  else
+	    {
+	      wid = 1;
+	    }
+	  if (wid == 0)
+	    {
+	      wid = 1;
+	    }
+	}
+      d = 2 * dy - dx;
+      incr1 = 2 * dy;
+      incr2 = 2 * (dy - dx);
+      if (x1 > x2)
+	{
+	  x = x2;
+	  y = y2;
+	  ydirflag = (-1);
+	  xend = x1;
+	}
+      else
+	{
+	  x = x1;
+	  y = y1;
+	  ydirflag = 1;
+	  xend = x2;
+	}
+
+      /* Set up line thickness */
+      wstart = y - wid / 2;
+      for (w = wstart; w < wstart + wid; w++)
+	gdImageSetPixel (im, x, w, color);
+
+      if (((y2 - y1) * ydirflag) > 0)
+	{
+	  while (x < xend)
+	    {
+	      x++;
+	      if (d < 0)
+		{
+		  d += incr1;
+		}
+	      else
+		{
+		  y++;
+		  d += incr2;
+		}
+	      wstart = y - wid / 2;
+	      for (w = wstart; w < wstart + wid; w++)
+		gdImageSetPixel (im, x, w, color);
+	    }
+	}
+      else
+	{
+	  while (x < xend)
+	    {
+	      x++;
+	      if (d < 0)
+		{
+		  d += incr1;
+		}
+	      else
+		{
+		  y--;
+		  d += incr2;
+		}
+	      wstart = y - wid / 2;
+	      for (w = wstart; w < wstart + wid; w++)
+		gdImageSetPixel (im, x, w, color);
+	    }
+	}
+    }
+  else
+    {
+      /* More-or-less vertical. use wid for horizontal stroke */
+      /* 2.0.12: Michael Schwartz: divide rather than multiply;
+         TBB: but watch out for /0! */
+      double as = sin (atan2 (dy, dx));
+      if (as != 0)
+	{
+	  wid = thick / as;
+	}
+      else
+	{
+	  wid = 1;
+	}
+      if (wid == 0)
+	wid = 1;
+
+      d = 2 * dx - dy;
+      incr1 = 2 * dx;
+      incr2 = 2 * (dx - dy);
+      if (y1 > y2)
+	{
+	  y = y2;
+	  x = x2;
+	  yend = y1;
+	  xdirflag = (-1);
+	}
+      else
+	{
+	  y = y1;
+	  x = x1;
+	  yend = y2;
+	  xdirflag = 1;
+	}
+
+      /* Set up line thickness */
+      wstart = x - wid / 2;
+      for (w = wstart; w < wstart + wid; w++)
+	gdImageSetPixel (im, w, y, color);
+
+      if (((x2 - x1) * xdirflag) > 0)
+	{
+	  while (y < yend)
+	    {
+	      y++;
+	      if (d < 0)
+		{
+		  d += incr1;
+		}
+	      else
+		{
+		  x++;
+		  d += incr2;
+		}
+	      wstart = x - wid / 2;
+	      for (w = wstart; w < wstart + wid; w++)
+		gdImageSetPixel (im, w, y, color);
+	    }
+	}
+      else
+	{
+	  while (y < yend)
+	    {
+	      y++;
+	      if (d < 0)
+		{
+		  d += incr1;
+		}
+	      else
+		{
+		  x--;
+		  d += incr2;
+		}
+	      wstart = x - wid / 2;
+	      for (w = wstart; w < wstart + wid; w++)
+		gdImageSetPixel (im, w, y, color);
+	    }
+	}
+    }
+
+  /* If this is the only line we are drawing, go ahead and blend. */
+  if ((color == gdAntiAliased) && !(im->AA_polygon))
+    gdImageAABlend (im);
+}
+static void dashedSet (gdImagePtr im, int x, int y, int color,
+		       int *onP, int *dashStepP, int wid, int vert);
+
+void
+gdImageDashedLine (gdImagePtr im, int x1, int y1, int x2, int y2, int color)
+{
+  int dx, dy, incr1, incr2, d, x, y, xend, yend, xdirflag, ydirflag;
+  int dashStep = 0;
+  int on = 1;
+  int wid;
+  int vert;
+  int thick = im->thick;
+
+  dx = abs (x2 - x1);
+  dy = abs (y2 - y1);
+  if (dy <= dx)
+    {
+      /* More-or-less horizontal. use wid for vertical stroke */
+      /* 2.0.12: Michael Schwartz: divide rather than multiply;
+         TBB: but watch out for /0! */
+      double as = sin (atan2 (dy, dx));
+      if (as != 0)
+	{
+	  wid = thick / as;
+	}
+      else
+	{
+	  wid = 1;
+	}
+      vert = 1;
+
+      d = 2 * dy - dx;
+      incr1 = 2 * dy;
+      incr2 = 2 * (dy - dx);
+      if (x1 > x2)
+	{
+	  x = x2;
+	  y = y2;
+	  ydirflag = (-1);
+	  xend = x1;
+	}
+      else
+	{
+	  x = x1;
+	  y = y1;
+	  ydirflag = 1;
+	  xend = x2;
+	}
+      dashedSet (im, x, y, color, &on, &dashStep, wid, vert);
+      if (((y2 - y1) * ydirflag) > 0)
+	{
+	  while (x < xend)
+	    {
+	      x++;
+	      if (d < 0)
+		{
+		  d += incr1;
+		}
+	      else
+		{
+		  y++;
+		  d += incr2;
+		}
+	      dashedSet (im, x, y, color, &on, &dashStep, wid, vert);
+	    }
+	}
+      else
+	{
+	  while (x < xend)
+	    {
+	      x++;
+	      if (d < 0)
+		{
+		  d += incr1;
+		}
+	      else
+		{
+		  y--;
+		  d += incr2;
+		}
+	      dashedSet (im, x, y, color, &on, &dashStep, wid, vert);
+	    }
+	}
+    }
+  else
+    {
+      /* 2.0.12: Michael Schwartz: divide rather than multiply;
+         TBB: but watch out for /0! */
+      double as = sin (atan2 (dy, dx));
+      if (as != 0)
+	{
+	  wid = thick / as;
+	}
+      else
+	{
+	  wid = 1;
+	}
+      vert = 0;
+
+      d = 2 * dx - dy;
+      incr1 = 2 * dx;
+      incr2 = 2 * (dx - dy);
+      if (y1 > y2)
+	{
+	  y = y2;
+	  x = x2;
+	  yend = y1;
+	  xdirflag = (-1);
+	}
+      else
+	{
+	  y = y1;
+	  x = x1;
+	  yend = y2;
+	  xdirflag = 1;
+	}
+      dashedSet (im, x, y, color, &on, &dashStep, wid, vert);
+      if (((x2 - x1) * xdirflag) > 0)
+	{
+	  while (y < yend)
+	    {
+	      y++;
+	      if (d < 0)
+		{
+		  d += incr1;
+		}
+	      else
+		{
+		  x++;
+		  d += incr2;
+		}
+	      dashedSet (im, x, y, color, &on, &dashStep, wid, vert);
+	    }
+	}
+      else
+	{
+	  while (y < yend)
+	    {
+	      y++;
+	      if (d < 0)
+		{
+		  d += incr1;
+		}
+	      else
+		{
+		  x--;
+		  d += incr2;
+		}
+	      dashedSet (im, x, y, color, &on, &dashStep, wid, vert);
+	    }
+	}
+    }
+}
+
+static void
+dashedSet (gdImagePtr im, int x, int y, int color,
+	   int *onP, int *dashStepP, int wid, int vert)
+{
+  int dashStep = *dashStepP;
+  int on = *onP;
+  int w, wstart;
+
+  dashStep++;
+  if (dashStep == gdDashSize)
+    {
+      dashStep = 0;
+      on = !on;
+    }
+  if (on)
+    {
+      if (vert)
+	{
+	  wstart = y - wid / 2;
+	  for (w = wstart; w < wstart + wid; w++)
+	    gdImageSetPixel (im, x, w, color);
+	}
+      else
+	{
+	  wstart = x - wid / 2;
+	  for (w = wstart; w < wstart + wid; w++)
+	    gdImageSetPixel (im, w, y, color);
+	}
+    }
+  *dashStepP = dashStep;
+  *onP = on;
+}
+
+int
+gdImageBoundsSafe (gdImagePtr im, int x, int y)
+{
+  return gdImageBoundsSafeMacro (im, x, y);
+}
+
+void
+gdImageChar (gdImagePtr im, gdFontPtr f, int x, int y, int c, int color)
+{
+  int cx, cy;
+  int px, py;
+  int fline;
+  cx = 0;
+  cy = 0;
+#ifdef CHARSET_EBCDIC
+  c = ASC (c);
+#endif /*CHARSET_EBCDIC */
+  if ((c < f->offset) || (c >= (f->offset + f->nchars)))
+    {
+      return;
+    }
+  fline = (c - f->offset) * f->h * f->w;
+  for (py = y; (py < (y + f->h)); py++)
+    {
+      for (px = x; (px < (x + f->w)); px++)
+	{
+	  if (f->data[fline + cy * f->w + cx])
+	    {
+	      gdImageSetPixel (im, px, py, color);
+	    }
+	  cx++;
+	}
+      cx = 0;
+      cy++;
+    }
+}
+
+void
+gdImageCharUp (gdImagePtr im, gdFontPtr f, int x, int y, int c, int color)
+{
+  int cx, cy;
+  int px, py;
+  int fline;
+  cx = 0;
+  cy = 0;
+#ifdef CHARSET_EBCDIC
+  c = ASC (c);
+#endif /*CHARSET_EBCDIC */
+  if ((c < f->offset) || (c >= (f->offset + f->nchars)))
+    {
+      return;
+    }
+  fline = (c - f->offset) * f->h * f->w;
+  for (py = y; (py > (y - f->w)); py--)
+    {
+      for (px = x; (px < (x + f->h)); px++)
+	{
+	  if (f->data[fline + cy * f->w + cx])
+	    {
+	      gdImageSetPixel (im, px, py, color);
+	    }
+	  cy++;
+	}
+      cy = 0;
+      cx++;
+    }
+}
+
+void
+gdImageString (gdImagePtr im, gdFontPtr f,
+	       int x, int y, unsigned char *s, int color)
+{
+  int i;
+  int l;
+  l = strlen ((char *) s);
+  for (i = 0; (i < l); i++)
+    {
+      gdImageChar (im, f, x, y, s[i], color);
+      x += f->w;
+    }
+}
+
+void
+gdImageStringUp (gdImagePtr im, gdFontPtr f,
+		 int x, int y, unsigned char *s, int color)
+{
+  int i;
+  int l;
+  l = strlen ((char *) s);
+  for (i = 0; (i < l); i++)
+    {
+      gdImageCharUp (im, f, x, y, s[i], color);
+      y -= f->w;
+    }
+}
+
+static int strlen16 (unsigned short *s);
+
+void
+gdImageString16 (gdImagePtr im, gdFontPtr f,
+		 int x, int y, unsigned short *s, int color)
+{
+  int i;
+  int l;
+  l = strlen16 (s);
+  for (i = 0; (i < l); i++)
+    {
+      gdImageChar (im, f, x, y, s[i], color);
+      x += f->w;
+    }
+}
+
+void
+gdImageStringUp16 (gdImagePtr im, gdFontPtr f,
+		   int x, int y, unsigned short *s, int color)
+{
+  int i;
+  int l;
+  l = strlen16 (s);
+  for (i = 0; (i < l); i++)
+    {
+      gdImageCharUp (im, f, x, y, s[i], color);
+      y -= f->w;
+    }
+}
+
+static int
+strlen16 (unsigned short *s)
+{
+  int len = 0;
+  while (*s)
+    {
+      s++;
+      len++;
+    }
+  return len;
+}
+
+#ifndef HAVE_LSQRT
+/* If you don't have a nice square root function for longs, you can use
+   ** this hack
+ */
+long
+lsqrt (long n)
+{
+  long result = (long) sqrt ((double) n);
+  return result;
+}
+#endif
+
+/* s and e are integers modulo 360 (degrees), with 0 degrees
+   being the rightmost extreme and degrees changing clockwise.
+   cx and cy are the center in pixels; w and h are the horizontal 
+   and vertical diameter in pixels. Nice interface, but slow.
+   See gd_arc_f_buggy.c for a better version that doesn't 
+   seem to be bug-free yet. */
+
+void
+gdImageArc (gdImagePtr im, int cx, int cy, int w, int h, int s, int e,
+	    int color)
+{
+  gdImageFilledArc (im, cx, cy, w, h, s, e, color, gdNoFill);
+}
+
+void
+gdImageFilledArc (gdImagePtr im, int cx, int cy, int w, int h, int s, int e,
+		  int color, int style)
+{
+  gdPoint pts[3];
+  int i;
+  int lx = 0, ly = 0;
+  int fx = 0, fy = 0;
+  while (e < s)
+    {
+      e += 360;
+    }
+  for (i = s; (i <= e); i++)
+    {
+      int x, y;
+      x = ((long) gdCosT[i % 360] * (long) w / (2 * 1024)) + cx;
+      y = ((long) gdSinT[i % 360] * (long) h / (2 * 1024)) + cy;
+      if (i != s)
+	{
+	  if (!(style & gdChord))
+	    {
+	      if (style & gdNoFill)
+		{
+		  gdImageLine (im, lx, ly, x, y, color);
+		}
+	      else
+		{
+		  /* This is expensive! */
+		  pts[0].x = lx;
+		  pts[0].y = ly;
+		  pts[1].x = x;
+		  pts[1].y = y;
+		  pts[2].x = cx;
+		  pts[2].y = cy;
+		  gdImageFilledPolygon (im, pts, 3, color);
+		}
+	    }
+	}
+      else
+	{
+	  fx = x;
+	  fy = y;
+	}
+      lx = x;
+      ly = y;
+    }
+  if (style & gdChord)
+    {
+      if (style & gdNoFill)
+	{
+	  if (style & gdEdged)
+	    {
+	      gdImageLine (im, cx, cy, lx, ly, color);
+	      gdImageLine (im, cx, cy, fx, fy, color);
+	    }
+	  gdImageLine (im, fx, fy, lx, ly, color);
+	}
+      else
+	{
+	  pts[0].x = fx;
+	  pts[0].y = fy;
+	  pts[1].x = lx;
+	  pts[1].y = ly;
+	  pts[2].x = cx;
+	  pts[2].y = cy;
+	  gdImageFilledPolygon (im, pts, 3, color);
+	}
+    }
+  else
+    {
+      if (style & gdNoFill)
+	{
+	  if (style & gdEdged)
+	    {
+	      gdImageLine (im, cx, cy, lx, ly, color);
+	      gdImageLine (im, cx, cy, fx, fy, color);
+	    }
+	}
+    }
+}
+
+void
+gdImageFilledEllipse (gdImagePtr im, int cx, int cy, int w, int h, int color)
+{
+  gdImageFilledArc (im, cx, cy, w, h, 0, 360, color, gdPie);
+}
+
+void
+gdImageFillToBorder (gdImagePtr im, int x, int y, int border, int color)
+{
+  int lastBorder;
+  /* Seek left */
+  int leftLimit, rightLimit;
+  int i;
+  leftLimit = (-1);
+  if (border < 0)
+    {
+      /* Refuse to fill to a non-solid border */
+      return;
+    }
+  for (i = x; (i >= 0); i--)
+    {
+      if (gdImageGetPixel (im, i, y) == border)
+	{
+	  break;
+	}
+      gdImageSetPixel (im, i, y, color);
+      leftLimit = i;
+    }
+  if (leftLimit == (-1))
+    {
+      return;
+    }
+  /* Seek right */
+  rightLimit = x;
+  for (i = (x + 1); (i < im->sx); i++)
+    {
+      if (gdImageGetPixel (im, i, y) == border)
+	{
+	  break;
+	}
+      gdImageSetPixel (im, i, y, color);
+      rightLimit = i;
+    }
+  /* Look at lines above and below and start paints */
+  /* Above */
+  if (y > 0)
+    {
+      lastBorder = 1;
+      for (i = leftLimit; (i <= rightLimit); i++)
+	{
+	  int c;
+	  c = gdImageGetPixel (im, i, y - 1);
+	  if (lastBorder)
+	    {
+	      if ((c != border) && (c != color))
+		{
+		  gdImageFillToBorder (im, i, y - 1, border, color);
+		  lastBorder = 0;
+		}
+	    }
+	  else if ((c == border) || (c == color))
+	    {
+	      lastBorder = 1;
+	    }
+	}
+    }
+  /* Below */
+  if (y < ((im->sy) - 1))
+    {
+      lastBorder = 1;
+      for (i = leftLimit; (i <= rightLimit); i++)
+	{
+	  int c;
+	  c = gdImageGetPixel (im, i, y + 1);
+	  if (lastBorder)
+	    {
+	      if ((c != border) && (c != color))
+		{
+		  gdImageFillToBorder (im, i, y + 1, border, color);
+		  lastBorder = 0;
+		}
+	    }
+	  else if ((c == border) || (c == color))
+	    {
+	      lastBorder = 1;
+	    }
+	}
+    }
+}
+
+void
+gdImageFill (gdImagePtr im, int x, int y, int color)
+{
+  int lastBorder;
+  int old;
+  int leftLimit, rightLimit;
+  int i;
+  old = gdImageGetPixel (im, x, y);
+  if (color == gdTiled)
+    {
+      /* Tile fill -- got to watch out! */
+      int p, tileColor;
+      int srcx, srcy;
+      if (!im->tile)
+	{
+	  return;
+	}
+      /* Refuse to flood-fill with a transparent pattern --
+         I can't do it without allocating another image */
+      if (gdImageGetTransparent (im->tile) != (-1))
+	{
+	  return;
+	}
+      srcx = x % gdImageSX (im->tile);
+      srcy = y % gdImageSY (im->tile);
+      p = gdImageGetPixel (im->tile, srcx, srcy);
+      if (im->trueColor)
+	{
+	  tileColor = p;
+	}
+      else
+	{
+	  if (im->tile->trueColor)
+	    {
+	      tileColor = gdImageColorResolveAlpha (im,
+						    gdTrueColorGetRed (p),
+						    gdTrueColorGetGreen (p),
+						    gdTrueColorGetBlue (p),
+						    gdTrueColorGetAlpha (p));
+	    }
+	  else
+	    {
+	      tileColor = im->tileColorMap[p];
+	    }
+	}
+      if (old == tileColor)
+	{
+	  /* Nothing to be done */
+	  return;
+	}
+    }
+  else
+    {
+      if (old == color)
+	{
+	  /* Nothing to be done */
+	  return;
+	}
+    }
+  /* Seek left */
+  leftLimit = (-1);
+  for (i = x; (i >= 0); i--)
+    {
+      if (gdImageGetPixel (im, i, y) != old)
+	{
+	  break;
+	}
+      gdImageSetPixel (im, i, y, color);
+      leftLimit = i;
+    }
+  if (leftLimit == (-1))
+    {
+      return;
+    }
+  /* Seek right */
+  rightLimit = x;
+  for (i = (x + 1); (i < im->sx); i++)
+    {
+      if (gdImageGetPixel (im, i, y) != old)
+	{
+	  break;
+	}
+      gdImageSetPixel (im, i, y, color);
+      rightLimit = i;
+    }
+  /* Look at lines above and below and start paints */
+  /* Above */
+  if (y > 0)
+    {
+      lastBorder = 1;
+      for (i = leftLimit; (i <= rightLimit); i++)
+	{
+	  int c;
+	  c = gdImageGetPixel (im, i, y - 1);
+	  if (lastBorder)
+	    {
+	      if (c == old)
+		{
+		  gdImageFill (im, i, y - 1, color);
+		  lastBorder = 0;
+		}
+	    }
+	  else if (c != old)
+	    {
+	      lastBorder = 1;
+	    }
+	}
+    }
+  /* Below */
+  if (y < ((im->sy) - 1))
+    {
+      lastBorder = 1;
+      for (i = leftLimit; (i <= rightLimit); i++)
+	{
+	  int c;
+	  c = gdImageGetPixel (im, i, y + 1);
+	  if (lastBorder)
+	    {
+	      if (c == old)
+		{
+		  gdImageFill (im, i, y + 1, color);
+		  lastBorder = 0;
+		}
+	    }
+	  else if (c != old)
+	    {
+	      lastBorder = 1;
+	    }
+	}
+    }
+}
+
+void
+gdImageRectangle (gdImagePtr im, int x1, int y1, int x2, int y2, int color)
+{
+  int x1h = x1, x1v = x1, y1h = y1, y1v = y1, x2h = x2, x2v = x2, y2h = y2,
+    y2v = y2;
+  int thick = im->thick;
+  if (thick > 1)
+    {
+      int half = thick / 2;
+      int half1 = thick - half;
+
+      if (y1 < y2)
+	{
+	  y1v = y1h - half;
+	  y2v = y2h + half1 - 1;
+	}
+      else
+	{
+	  y1v = y1h + half1 - 1;
+	  y2v = y2h - half;
+	}
+    }
+
+  gdImageLine (im, x1h, y1h, x2h, y1h, color);
+  gdImageLine (im, x1h, y2h, x2h, y2h, color);
+  gdImageLine (im, x1v, y1v, x1v, y2v, color);
+  gdImageLine (im, x2v, y1v, x2v, y2v, color);
+}
+
+void
+gdImageFilledRectangle (gdImagePtr im, int x1, int y1, int x2, int y2,
+			int color)
+{
+  int x, y;
+  /* Nick Atty: limit the points at the edge.  Note that this also
+     nicely kills any plotting for rectangles completely outside the
+     window as it makes the tests in the for loops fail */
+  if (x1 < 0)
+    x1 = 0;
+  if (x1 > gdImageSX (im))
+    x1 = gdImageSX (im);
+  if (y1 < 0)
+    y1 = 0;
+  if (y1 > gdImageSY (im))
+    y1 = gdImageSY (im);
+
+  for (y = y1; (y <= y2); y++)
+    {
+      for (x = x1; (x <= x2); x++)
+	{
+	  gdImageSetPixel (im, x, y, color);
+	}
+    }
+}
+
+void
+gdImageCopy (gdImagePtr dst, gdImagePtr src, int dstX, int dstY, int srcX,
+	     int srcY, int w, int h)
+{
+  int c;
+  int x, y;
+  int tox, toy;
+  int i;
+  int colorMap[gdMaxColors];
+  if (dst->trueColor)
+    {
+      /* 2.0: much easier when the destination is truecolor. */
+      /* 2.0.10: needs a transparent-index check that is still valid if
+         the source is not truecolor. Thanks to Frank Warmerdam. */
+      for (y = 0; (y < h); y++)
+	{
+	  for (x = 0; (x < w); x++)
+	    {
+	      int p = gdImageGetPixel (src, srcX + x, srcY + y);
+	      if (p != src->transparent)
+		{
+		  int c = gdImageGetTrueColorPixel (src, srcX + x,
+						    srcY + y);
+		  gdImageSetPixel (dst, dstX + x, dstY + y, c);
+		}
+	    }
+	}
+      return;
+    }
+  for (i = 0; (i < gdMaxColors); i++)
+    {
+      colorMap[i] = (-1);
+    }
+  toy = dstY;
+  for (y = srcY; (y < (srcY + h)); y++)
+    {
+      tox = dstX;
+      for (x = srcX; (x < (srcX + w)); x++)
+	{
+	  int nc;
+	  int mapTo;
+	  c = gdImageGetPixel (src, x, y);
+	  /* Added 7/24/95: support transparent copies */
+	  if (gdImageGetTransparent (src) == c)
+	    {
+	      tox++;
+	      continue;
+	    }
+	  /* Have we established a mapping for this color? */
+	  if (src->trueColor)
+	    {
+	      /* 2.05: remap to the palette available in the
+	         destination image. This is slow and
+	         works badly, but it beats crashing! Thanks 
+	         to Padhrig McCarthy. */
+	      mapTo = gdImageColorResolveAlpha (dst,
+						gdTrueColorGetRed (c),
+						gdTrueColorGetGreen (c),
+						gdTrueColorGetBlue (c),
+						gdTrueColorGetAlpha (c));
+	    }
+	  else if (colorMap[c] == (-1))
+	    {
+	      /* If it's the same image, mapping is trivial */
+	      if (dst == src)
+		{
+		  nc = c;
+		}
+	      else
+		{
+		  /* Get best match possible. This
+		     function never returns error. */
+		  nc = gdImageColorResolveAlpha (dst,
+						 src->red[c], src->green[c],
+						 src->blue[c], src->alpha[c]);
+		}
+	      colorMap[c] = nc;
+	      mapTo = colorMap[c];
+	    }
+	  else
+	    {
+	      mapTo = colorMap[c];
+	    }
+	  gdImageSetPixel (dst, tox, toy, mapTo);
+	  tox++;
+	}
+      toy++;
+    }
+}
+
+/* This function is a substitute for real alpha channel operations,
+   so it doesn't pay attention to the alpha channel. */
+void
+gdImageCopyMerge (gdImagePtr dst, gdImagePtr src, int dstX, int dstY,
+		  int srcX, int srcY, int w, int h, int pct)
+{
+
+  int c, dc;
+  int x, y;
+  int tox, toy;
+  int ncR, ncG, ncB;
+  toy = dstY;
+  for (y = srcY; (y < (srcY + h)); y++)
+    {
+      tox = dstX;
+      for (x = srcX; (x < (srcX + w)); x++)
+	{
+	  int nc;
+	  c = gdImageGetPixel (src, x, y);
+	  /* Added 7/24/95: support transparent copies */
+	  if (gdImageGetTransparent (src) == c)
+	    {
+	      tox++;
+	      continue;
+	    }
+	  /* If it's the same image, mapping is trivial */
+	  if (dst == src)
+	    {
+	      nc = c;
+	    }
+	  else
+	    {
+	      dc = gdImageGetPixel (dst, tox, toy);
+
+	      ncR = gdImageRed (src, c) * (pct / 100.0)
+		+ gdImageRed (dst, dc) * ((100 - pct) / 100.0);
+	      ncG = gdImageGreen (src, c) * (pct / 100.0)
+		+ gdImageGreen (dst, dc) * ((100 - pct) / 100.0);
+	      ncB = gdImageBlue (src, c) * (pct / 100.0)
+		+ gdImageBlue (dst, dc) * ((100 - pct) / 100.0);
+
+	      /* Find a reasonable color */
+	      nc = gdImageColorResolve (dst, ncR, ncG, ncB);
+	    }
+	  gdImageSetPixel (dst, tox, toy, nc);
+	  tox++;
+	}
+      toy++;
+    }
+}
+
+/* This function is a substitute for real alpha channel operations,
+   so it doesn't pay attention to the alpha channel. */
+void
+gdImageCopyMergeGray (gdImagePtr dst, gdImagePtr src, int dstX, int dstY,
+		      int srcX, int srcY, int w, int h, int pct)
+{
+
+  int c, dc;
+  int x, y;
+  int tox, toy;
+  int ncR, ncG, ncB;
+  float g;
+  toy = dstY;
+  for (y = srcY; (y < (srcY + h)); y++)
+    {
+      tox = dstX;
+      for (x = srcX; (x < (srcX + w)); x++)
+	{
+	  int nc;
+	  c = gdImageGetPixel (src, x, y);
+	  /* Added 7/24/95: support transparent copies */
+	  if (gdImageGetTransparent (src) == c)
+	    {
+	      tox++;
+	      continue;
+	    }
+	  /* 
+	   * If it's the same image, mapping is NOT trivial since we 
+	   * merge with greyscale target, but if pct is 100, the grey 
+	   * value is not used, so it becomes trivial. pjw 2.0.12. 
+	   */
+	  if (dst == src && pct == 100)
+	    {
+	      nc = c;
+	    }
+	  else
+	    {
+	      dc = gdImageGetPixel (dst, tox, toy);
+	      g = 0.29900 * dst->red[dc]
+		+ 0.58700 * dst->green[dc] + 0.11400 * dst->blue[dc];
+
+	      ncR = gdImageRed (src, c) * (pct / 100.0)
+		+ g * ((100 - pct) / 100.0);
+	      ncG = gdImageGreen (src, c) * (pct / 100.0)
+		+ g * ((100 - pct) / 100.0);
+	      ncB = gdImageBlue (src, c) * (pct / 100.0)
+		+ g * ((100 - pct) / 100.0);
+
+	      /* First look for an exact match */
+	      nc = gdImageColorExact (dst, ncR, ncG, ncB);
+	      if (nc == (-1))
+		{
+		  /* No, so try to allocate it */
+		  nc = gdImageColorAllocate (dst, ncR, ncG, ncB);
+		  /* If we're out of colors, go for the
+		     closest color */
+		  if (nc == (-1))
+		    {
+		      nc = gdImageColorClosest (dst, ncR, ncG, ncB);
+		    }
+		}
+	    }
+	  gdImageSetPixel (dst, tox, toy, nc);
+	  tox++;
+	}
+      toy++;
+    }
+}
+
+void
+gdImageCopyResized (gdImagePtr dst, gdImagePtr src, int dstX, int dstY,
+		    int srcX, int srcY, int dstW, int dstH, int srcW,
+		    int srcH)
+{
+  int c;
+  int x, y;
+  int tox, toy;
+  int ydest;
+  int i;
+  int colorMap[gdMaxColors];
+  /* Stretch vectors */
+  int *stx;
+  int *sty;
+  /* We only need to use floating point to determine the correct
+     stretch vector for one line's worth. */
+  double accum;
+  stx = (int *) gdMalloc (sizeof (int) * srcW);
+  sty = (int *) gdMalloc (sizeof (int) * srcH);
+  accum = 0;
+  for (i = 0; (i < srcW); i++)
+    {
+      int got;
+      accum += (double) dstW / (double) srcW;
+      got = (int) floor (accum);
+      stx[i] = got;
+      accum -= got;
+    }
+  accum = 0;
+  for (i = 0; (i < srcH); i++)
+    {
+      int got;
+      accum += (double) dstH / (double) srcH;
+      got = (int) floor (accum);
+      sty[i] = got;
+      accum -= got;
+    }
+  for (i = 0; (i < gdMaxColors); i++)
+    {
+      colorMap[i] = (-1);
+    }
+  toy = dstY;
+  for (y = srcY; (y < (srcY + srcH)); y++)
+    {
+      for (ydest = 0; (ydest < sty[y - srcY]); ydest++)
+	{
+	  tox = dstX;
+	  for (x = srcX; (x < (srcX + srcW)); x++)
+	    {
+	      int nc = 0;
+	      int mapTo;
+	      if (!stx[x - srcX])
+		{
+		  continue;
+		}
+	      if (dst->trueColor)
+		{
+		  /* 2.0.9: Thorben Kundinger: Maybe the source image is not 
+		     a truecolor image */
+		  if (!src->trueColor)
+		    {
+		      int tmp = gdImageGetPixel (src, x, y);
+		      mapTo = gdImageGetTrueColorPixel (src, x, y);
+		      if (gdImageGetTransparent (src) == tmp)
+			{
+			  tox++;
+			  continue;
+			}
+		    }
+		  else
+		    {
+		      /* TK: old code follows */
+		      mapTo = gdImageGetTrueColorPixel (src, x, y);
+		      /* Added 7/24/95: support transparent copies */
+		      if (gdImageGetTransparent (src) == mapTo)
+			{
+			  tox++;
+			  continue;
+			}
+		    }
+		}
+	      else
+		{
+		  c = gdImageGetPixel (src, x, y);
+		  /* Added 7/24/95: support transparent copies */
+		  if (gdImageGetTransparent (src) == c)
+		    {
+		      tox += stx[x - srcX];
+		      continue;
+		    }
+		  if (src->trueColor)
+		    {
+		      /* Remap to the palette available in the
+		         destination image. This is slow and
+		         works badly. */
+		      mapTo = gdImageColorResolveAlpha (dst,
+							gdTrueColorGetRed (c),
+							gdTrueColorGetGreen
+							(c),
+							gdTrueColorGetBlue
+							(c),
+							gdTrueColorGetAlpha
+							(c));
+		    }
+		  else
+		    {
+		      /* Have we established a mapping for this color? */
+		      if (colorMap[c] == (-1))
+			{
+			  /* If it's the same image, mapping is trivial */
+			  if (dst == src)
+			    {
+			      nc = c;
+			    }
+			  else
+			    {
+			      /* Find or create the best match */
+			      /* 2.0.5: can't use gdTrueColorGetRed, etc with palette */
+			      nc = gdImageColorResolveAlpha (dst,
+							     gdImageRed (src,
+									 c),
+							     gdImageGreen
+							     (src, c),
+							     gdImageBlue (src,
+									  c),
+							     gdImageAlpha
+							     (src, c));
+			    }
+			  colorMap[c] = nc;
+			}
+		      mapTo = colorMap[c];
+		    }
+		}
+	      for (i = 0; (i < stx[x - srcX]); i++)
+		{
+		  gdImageSetPixel (dst, tox, toy, mapTo);
+		  tox++;
+		}
+	    }
+	  toy++;
+	}
+    }
+  gdFree (stx);
+  gdFree (sty);
+}
+
+/* gd 2.0.8: gdImageCopyRotated is added. Source 
+	is a rectangle, with its upper left corner at
+	srcX and srcY. Destination is the *center* of
+        the rotated copy. Angle is in degrees, same as
+        gdImageArc. Floating point destination center
+	coordinates allow accurate rotation of 
+	objects of odd-numbered width or height. */
+
+void
+gdImageCopyRotated (gdImagePtr dst,
+		    gdImagePtr src,
+		    double dstX, double dstY,
+		    int srcX, int srcY,
+		    int srcWidth, int srcHeight, int angle)
+{
+  double dx, dy;
+  double radius = sqrt (srcWidth * srcWidth + srcHeight * srcHeight);
+  double aCos = cos (angle * .0174532925);
+  double aSin = sin (angle * .0174532925);
+  double scX = srcX + ((double) srcWidth) / 2;
+  double scY = srcY + ((double) srcHeight) / 2;
+  int cmap[gdMaxColors];
+  int i;
+  for (i = 0; (i < gdMaxColors); i++)
+    {
+      cmap[i] = (-1);
+    }
+  for (dy = dstY - radius; (dy <= dstY + radius); dy++)
+    {
+      for (dx = dstX - radius; (dx <= dstX + radius); dx++)
+	{
+	  double sxd = (dx - dstX) * aCos - (dy - dstY) * aSin;
+	  double syd = (dy - dstY) * aCos + (dx - dstX) * aSin;
+	  int sx = sxd + scX;
+	  int sy = syd + scY;
+	  if ((sx >= srcX) && (sx < srcX + srcWidth) &&
+	      (sy >= srcY) && (sy < srcY + srcHeight))
+	    {
+	      int c = gdImageGetPixel (src, sx, sy);
+	      if (!src->trueColor)
+		{
+		  /* Use a table to avoid an expensive
+		     lookup on every single pixel */
+		  if (cmap[c] == -1)
+		    {
+		      cmap[c] = gdImageColorResolveAlpha (dst,
+							  gdImageRed (src, c),
+							  gdImageGreen (src,
+									c),
+							  gdImageBlue (src,
+								       c),
+							  gdImageAlpha (src,
+									c));
+		    }
+		  gdImageSetPixel (dst, dx, dy, cmap[c]);
+		}
+	      else
+		{
+		  gdImageSetPixel (dst,
+				   dx, dy,
+				   gdImageColorResolveAlpha (dst,
+							     gdImageRed (src,
+									 c),
+							     gdImageGreen
+							     (src, c),
+							     gdImageBlue (src,
+									  c),
+							     gdImageAlpha
+							     (src, c)));
+		}
+	    }
+	}
+    }
+}
+
+/* When gd 1.x was first created, floating point was to be avoided.
+   These days it is often faster than table lookups or integer
+   arithmetic. The routine below is shamelessly, gloriously
+   floating point. TBB */
+
+/* 2.0.10: cast instead of floor() yields 35% performance improvement. 
+	Thanks to John Buckman. */
+
+#define floor2(exp) ((long) exp)
+/*#define floor2(exp) floor(exp)*/
+
+void
+gdImageCopyResampled (gdImagePtr dst,
+		      gdImagePtr src,
+		      int dstX, int dstY,
+		      int srcX, int srcY,
+		      int dstW, int dstH, int srcW, int srcH)
+{
+  int x, y;
+  if (!dst->trueColor)
+    {
+      gdImageCopyResized (dst, src, dstX, dstY, srcX, srcY, dstW, dstH,
+			  srcW, srcH);
+      return;
+    }
+  for (y = dstY; (y < dstY + dstH); y++)
+    {
+      for (x = dstX; (x < dstX + dstW); x++)
+	{
+	  float sy1, sy2, sx1, sx2;
+	  float sx, sy;
+	  float spixels = 0;
+	  float red = 0.0, green = 0.0, blue = 0.0, alpha = 0.0;
+	  sy1 = ((float) y - (float) dstY) * (float) srcH / (float) dstH;
+	  sy2 = ((float) (y + 1) - (float) dstY) * (float) srcH /
+	    (float) dstH;
+	  sy = sy1;
+	  do
+	    {
+	      float yportion;
+	      if (floor2 (sy) == floor2 (sy1))
+		{
+		  yportion = 1.0 - (sy - floor2 (sy));
+		  if (yportion > sy2 - sy1)
+		    {
+		      yportion = sy2 - sy1;
+		    }
+		  sy = floor2 (sy);
+		}
+	      else if (sy == floor2 (sy2))
+		{
+		  yportion = sy2 - floor2 (sy2);
+		}
+	      else
+		{
+		  yportion = 1.0;
+		}
+	      sx1 = ((float) x - (float) dstX) * (float) srcW / dstW;
+	      sx2 = ((float) (x + 1) - (float) dstX) * (float) srcW / dstW;
+	      sx = sx1;
+	      do
+		{
+		  float xportion;
+		  float pcontribution;
+		  int p;
+		  if (floor2 (sx) == floor2 (sx1))
+		    {
+		      xportion = 1.0 - (sx - floor2 (sx));
+		      if (xportion > sx2 - sx1)
+			{
+			  xportion = sx2 - sx1;
+			}
+		      sx = floor2 (sx);
+		    }
+		  else if (sx == floor2 (sx2))
+		    {
+		      xportion = sx2 - floor2 (sx2);
+		    }
+		  else
+		    {
+		      xportion = 1.0;
+		    }
+		  pcontribution = xportion * yportion;
+		  /* 2.08: previously srcX and srcY were ignored. 
+		     Andrew Pattison */
+		  p = gdImageGetTrueColorPixel (src,
+						(int) sx + srcX,
+						(int) sy + srcY);
+		  red += gdTrueColorGetRed (p) * pcontribution;
+		  green += gdTrueColorGetGreen (p) * pcontribution;
+		  blue += gdTrueColorGetBlue (p) * pcontribution;
+		  alpha += gdTrueColorGetAlpha (p) * pcontribution;
+		  spixels += xportion * yportion;
+		  sx += 1.0;
+		}
+	      while (sx < sx2);
+	      sy += 1.0;
+	    }
+	  while (sy < sy2);
+	  if (spixels != 0.0)
+	    {
+	      red /= spixels;
+	      green /= spixels;
+	      blue /= spixels;
+	      alpha /= spixels;
+	    }
+	  /* Clamping to allow for rounding errors above */
+	  if (red > 255.0)
+	    {
+	      red = 255.0;
+	    }
+	  if (green > 255.0)
+	    {
+	      green = 255.0;
+	    }
+	  if (blue > 255.0)
+	    {
+	      blue = 255.0;
+	    }
+	  if (alpha > gdAlphaMax)
+	    {
+	      alpha = gdAlphaMax;
+	    }
+	  gdImageSetPixel (dst,
+			   x, y,
+			   gdTrueColorAlpha ((int) red,
+					     (int) green,
+					     (int) blue, (int) alpha));
+	}
+    }
+}
+
+gdImagePtr
+gdImageCreateFromXbm (FILE * fd)
+{
+  gdImagePtr im;
+  int bit;
+  int w, h;
+  int bytes;
+  int ch;
+  int i, x, y;
+  char *sp;
+  char s[161];
+  if (!fgets (s, 160, fd))
+    {
+      return 0;
+    }
+  sp = &s[0];
+  /* Skip #define */
+  sp = strchr (sp, ' ');
+  if (!sp)
+    {
+      return 0;
+    }
+  /* Skip width label */
+  sp++;
+  sp = strchr (sp, ' ');
+  if (!sp)
+    {
+      return 0;
+    }
+  /* Get width */
+  w = atoi (sp + 1);
+  if (!w)
+    {
+      return 0;
+    }
+  if (!fgets (s, 160, fd))
+    {
+      return 0;
+    }
+  sp = s;
+  /* Skip #define */
+  sp = strchr (sp, ' ');
+  if (!sp)
+    {
+      return 0;
+    }
+  /* Skip height label */
+  sp++;
+  sp = strchr (sp, ' ');
+  if (!sp)
+    {
+      return 0;
+    }
+  /* Get height */
+  h = atoi (sp + 1);
+  if (!h)
+    {
+      return 0;
+    }
+  /* Skip declaration line */
+  if (!fgets (s, 160, fd))
+    {
+      return 0;
+    }
+  bytes = (w * h / 8) + 1;
+  im = gdImageCreate (w, h);
+  gdImageColorAllocate (im, 255, 255, 255);
+  gdImageColorAllocate (im, 0, 0, 0);
+  x = 0;
+  y = 0;
+  for (i = 0; (i < bytes); i++)
+    {
+      char h[3];
+      unsigned int b;
+      /* Skip spaces, commas, CRs, 0x */
+      while (1)
+	{
+	  ch = getc (fd);
+	  if (ch == EOF)
+	    {
+	      goto fail;
+	    }
+	  if (ch == 'x')
+	    {
+	      break;
+	    }
+	}
+      /* Get hex value */
+      ch = getc (fd);
+      if (ch == EOF)
+	{
+	  goto fail;
+	}
+      h[0] = ch;
+      ch = getc (fd);
+      if (ch == EOF)
+	{
+	  goto fail;
+	}
+      h[1] = ch;
+      h[2] = '\0';
+      sscanf (h, "%x", &b);
+      for (bit = 1; (bit <= 128); (bit = bit << 1))
+	{
+	  gdImageSetPixel (im, x++, y, (b & bit) ? 1 : 0);
+	  if (x == im->sx)
+	    {
+	      x = 0;
+	      y++;
+	      if (y == im->sy)
+		{
+		  return im;
+		}
+	      /* Fix 8/8/95 */
+	      break;
+	    }
+	}
+    }
+  /* Shouldn't happen */
+  fprintf (stderr, "Error: bug in gdImageCreateFromXbm!\n");
+  return 0;
+fail:
+  gdImageDestroy (im);
+  return 0;
+}
+
+void
+gdImagePolygon (gdImagePtr im, gdPointPtr p, int n, int c)
+{
+  int i;
+  int lx, ly;
+  if (!n)
+    {
+      return;
+    }
+
+  /* Let it be known that we are drawing a polygon so that the opacity
+   * mask doesn't get cleared after each line. */
+  if (c == gdAntiAliased)
+    im->AA_polygon = 1;
+
+  lx = p->x;
+  ly = p->y;
+  gdImageLine (im, lx, ly, p[n - 1].x, p[n - 1].y, c);
+  for (i = 1; (i < n); i++)
+    {
+      p++;
+      gdImageLine (im, lx, ly, p->x, p->y, c);
+      lx = p->x;
+      ly = p->y;
+    }
+
+  if (c == gdAntiAliased)
+    {
+      im->AA_polygon = 0;
+      gdImageAABlend (im);
+    }
+}
+
+int gdCompareInt (const void *a, const void *b);
+
+/* THANKS to Kirsten Schulz for the polygon fixes! */
+
+/* The intersection finding technique of this code could be improved  */
+/* by remembering the previous intertersection, and by using the slope. */
+/* That could help to adjust intersections  to produce a nice */
+/* interior_extrema. */
+
+void
+gdImageFilledPolygon (gdImagePtr im, gdPointPtr p, int n, int c)
+{
+  int i;
+  int y;
+  int miny, maxy;
+  int x1, y1;
+  int x2, y2;
+  int ind1, ind2;
+  int ints;
+  int fill_color;
+  if (!n)
+    {
+      return;
+    }
+
+  if (c == gdAntiAliased)
+    fill_color = im->AA_color;
+  else
+    fill_color = c;
+
+  if (!im->polyAllocated)
+    {
+      im->polyInts = (int *) gdMalloc (sizeof (int) * n);
+      im->polyAllocated = n;
+    }
+  if (im->polyAllocated < n)
+    {
+      while (im->polyAllocated < n)
+	{
+	  im->polyAllocated *= 2;
+	}
+      im->polyInts = (int *) gdRealloc (im->polyInts,
+					sizeof (int) * im->polyAllocated);
+    }
+  miny = p[0].y;
+  maxy = p[0].y;
+  for (i = 1; (i < n); i++)
+    {
+      if (p[i].y < miny)
+	{
+	  miny = p[i].y;
+	}
+      if (p[i].y > maxy)
+	{
+	  maxy = p[i].y;
+	}
+    }
+  /* Fix in 1.3: count a vertex only once */
+  for (y = miny; (y <= maxy); y++)
+    {
+/*1.4           int interLast = 0; */
+/*              int dirLast = 0; */
+/*              int interFirst = 1; */
+      ints = 0;
+      for (i = 0; (i < n); i++)
+	{
+	  if (!i)
+	    {
+	      ind1 = n - 1;
+	      ind2 = 0;
+	    }
+	  else
+	    {
+	      ind1 = i - 1;
+	      ind2 = i;
+	    }
+	  y1 = p[ind1].y;
+	  y2 = p[ind2].y;
+	  if (y1 < y2)
+	    {
+	      x1 = p[ind1].x;
+	      x2 = p[ind2].x;
+	    }
+	  else if (y1 > y2)
+	    {
+	      y2 = p[ind1].y;
+	      y1 = p[ind2].y;
+	      x2 = p[ind1].x;
+	      x1 = p[ind2].x;
+	    }
+	  else
+	    {
+	      continue;
+	    }
+
+	  /* Do the following math as float intermediately, and round to ensure
+	   * that Polygon and FilledPolygon for the same set of points have the
+	   * same footprint. */
+	  if ((y >= y1) && (y < y2))
+	    {
+	      im->polyInts[ints++] = (float) ((y - y1) * (x2 - x1)) /
+		(float) (y2 - y1) + 0.5 + x1;
+	    }
+	  else if ((y == maxy) && (y > y1) && (y <= y2))
+	    {
+	      im->polyInts[ints++] = (float) ((y - y1) * (x2 - x1)) /
+		(float) (y2 - y1) + 0.5 + x1;
+	    }
+	}
+      qsort (im->polyInts, ints, sizeof (int), gdCompareInt);
+
+      for (i = 0; (i < (ints)); i += 2)
+	{
+	  gdImageLine (im, im->polyInts[i], y, im->polyInts[i + 1], y,
+		       fill_color);
+	}
+    }
+
+  /* If we are drawing this AA, then redraw the border with AA lines. */
+  if (c == gdAntiAliased)
+    gdImagePolygon (im, p, n, c);
+}
+
+int
+gdCompareInt (const void *a, const void *b)
+{
+  return (*(const int *) a) - (*(const int *) b);
+}
+
+void
+gdImageSetStyle (gdImagePtr im, int *style, int noOfPixels)
+{
+  if (im->style)
+    {
+      gdFree (im->style);
+    }
+  im->style = (int *) gdMalloc (sizeof (int) * noOfPixels);
+  memcpy (im->style, style, sizeof (int) * noOfPixels);
+  im->styleLength = noOfPixels;
+  im->stylePos = 0;
+}
+
+void
+gdImageSetThickness (gdImagePtr im, int thickness)
+{
+  im->thick = thickness;
+}
+
+void
+gdImageSetBrush (gdImagePtr im, gdImagePtr brush)
+{
+  int i;
+  im->brush = brush;
+  if ((!im->trueColor) && (!im->brush->trueColor))
+    {
+      for (i = 0; (i < gdImageColorsTotal (brush)); i++)
+	{
+	  int index;
+	  index = gdImageColorResolveAlpha (im,
+					    gdImageRed (brush, i),
+					    gdImageGreen (brush, i),
+					    gdImageBlue (brush, i),
+					    gdImageAlpha (brush, i));
+	  im->brushColorMap[i] = index;
+	}
+    }
+}
+
+void
+gdImageSetTile (gdImagePtr im, gdImagePtr tile)
+{
+  int i;
+  im->tile = tile;
+  if ((!im->trueColor) && (!im->tile->trueColor))
+    {
+      for (i = 0; (i < gdImageColorsTotal (tile)); i++)
+	{
+	  int index;
+	  index = gdImageColorResolveAlpha (im,
+					    gdImageRed (tile, i),
+					    gdImageGreen (tile, i),
+					    gdImageBlue (tile, i),
+					    gdImageAlpha (tile, i));
+	  im->tileColorMap[i] = index;
+	}
+    }
+}
+
+void
+gdImageSetAntiAliased (gdImagePtr im, int c)
+{
+  im->AA = 1;
+  im->AA_color = c;
+  im->AA_dont_blend = -1;
+}
+
+void
+gdImageSetAntiAliasedDontBlend (gdImagePtr im, int c, int dont_blend)
+{
+  im->AA = 1;
+  im->AA_color = c;
+  im->AA_dont_blend = dont_blend;
+}
+
+void
+gdImageInterlace (gdImagePtr im, int interlaceArg)
+{
+  im->interlace = interlaceArg;
+}
+
+int
+gdImageCompare (gdImagePtr im1, gdImagePtr im2)
+{
+  int x, y;
+  int p1, p2;
+  int cmpStatus = 0;
+  int sx, sy;
+
+  if (im1->interlace != im2->interlace)
+    {
+      cmpStatus |= GD_CMP_INTERLACE;
+    }
+
+  if (im1->transparent != im2->transparent)
+    {
+      cmpStatus |= GD_CMP_TRANSPARENT;
+    }
+
+  if (im1->trueColor != im2->trueColor)
+    {
+      cmpStatus |= GD_CMP_TRUECOLOR;
+    }
+
+  sx = im1->sx;
+  if (im1->sx != im2->sx)
+    {
+      cmpStatus |= GD_CMP_SIZE_X + GD_CMP_IMAGE;
+      if (im2->sx < im1->sx)
+	{
+	  sx = im2->sx;
+	}
+    }
+
+  sy = im1->sy;
+  if (im1->sy != im2->sy)
+    {
+      cmpStatus |= GD_CMP_SIZE_Y + GD_CMP_IMAGE;
+      if (im2->sy < im1->sy)
+	{
+	  sy = im2->sy;
+	}
+    }
+
+  if (im1->colorsTotal != im2->colorsTotal)
+    {
+      cmpStatus |= GD_CMP_NUM_COLORS;
+    }
+
+  for (y = 0; (y < sy); y++)
+    {
+      for (x = 0; (x < sx); x++)
+	{
+	  p1 =
+	    im1->trueColor ? gdImageTrueColorPixel (im1, x,
+						    y) :
+	    gdImagePalettePixel (im1, x, y);
+	  p2 =
+	    im2->trueColor ? gdImageTrueColorPixel (im2, x,
+						    y) :
+	    gdImagePalettePixel (im2, x, y);
+	  if (gdImageRed (im1, p1) != gdImageRed (im2, p2))
+	    {
+	      cmpStatus |= GD_CMP_COLOR + GD_CMP_IMAGE;
+	      break;
+	    }
+	  if (gdImageGreen (im1, p1) != gdImageGreen (im2, p2))
+	    {
+	      cmpStatus |= GD_CMP_COLOR + GD_CMP_IMAGE;
+	      break;
+	    }
+	  if (gdImageBlue (im1, p1) != gdImageBlue (im2, p2))
+	    {
+	      cmpStatus |= GD_CMP_COLOR + GD_CMP_IMAGE;
+	      break;
+	    }
+#if 0
+	  /* Soon we'll add alpha channel to palettes */
+	  if (gdImageAlpha (im1, p1) != gdImageAlpha (im2, p2))
+	    {
+	      cmpStatus |= GD_CMP_COLOR + GD_CMP_IMAGE;
+	      break;
+	    }
+#endif
+	}
+      if (cmpStatus & GD_CMP_COLOR)
+	{
+	  break;
+	};
+    }
+
+  return cmpStatus;
+}
+
+int
+gdAlphaBlend (int dst, int src)
+{
+  /* 2.0.12: TBB: alpha in the destination should be a 
+     component of the result. Thanks to Frank Warmerdam for
+     pointing out the issue. */
+  return ((((gdTrueColorGetAlpha (src) *
+	     gdTrueColorGetAlpha (dst)) / gdAlphaMax) << 24) +
+	  ((((gdAlphaTransparent - gdTrueColorGetAlpha (src)) *
+	     gdTrueColorGetRed (src) / gdAlphaMax) +
+	    (gdTrueColorGetAlpha (src) *
+	     gdTrueColorGetRed (dst)) / gdAlphaMax) << 16) +
+	  ((((gdAlphaTransparent - gdTrueColorGetAlpha (src)) *
+	     gdTrueColorGetGreen (src) / gdAlphaMax) +
+	    (gdTrueColorGetAlpha (src) *
+	     gdTrueColorGetGreen (dst)) / gdAlphaMax) << 8) +
+	  (((gdAlphaTransparent - gdTrueColorGetAlpha (src)) *
+	    gdTrueColorGetBlue (src) / gdAlphaMax) +
+	   (gdTrueColorGetAlpha (src) *
+	    gdTrueColorGetBlue (dst)) / gdAlphaMax));
+}
+
+void
+gdImageAlphaBlending (gdImagePtr im, int alphaBlendingArg)
+{
+  im->alphaBlendingFlag = alphaBlendingArg;
+}
+
+void
+gdImageSaveAlpha (gdImagePtr im, int saveAlphaArg)
+{
+  im->saveAlphaFlag = saveAlphaArg;
+}
+
+void
+gdImageSetClip (gdImagePtr im, int x1, int y1, int x2, int y2)
+{
+  if (x1 < 0) {
+    x1 = 0;
+  }
+  if (x1 >= im->sx) {
+    x1 = im->sx - 1;
+  }
+  if (x2 < 0) {
+    x2 = 0;
+  }
+  if (x2 >= im->sx) {
+    x2 = im->sx - 1;
+  }
+  if (y1 < 0) {
+    y1 = 0;
+  }
+  if (y1 >= im->sy) {
+    y1 = im->sy - 1;
+  }
+  if (y2 < 0) {
+    y2 = 0;
+  }
+  if (y2 >= im->sy) {
+    y2 = im->sy - 1;
+  }
+  im->cx1 = x1;
+  im->cy1 = y1;
+  im->cx2 = x2;
+  im->cy2 = y2;
+}
+
+void
+gdImageGetClip (gdImagePtr im, int *x1P, int *y1P, int *x2P, int *y2P)
+{
+  *x1P = im->cx1;
+  *y1P = im->cy1;
+  *x2P = im->cx2;
+  *y2P = im->cy2;
+}
+
diff --git a/collects/plot/src/all/gd.h b/collects/plot/src/all/gd.h
new file mode 100644
index 0000000000..26a90bb7bf
--- /dev/null
+++ b/collects/plot/src/all/gd.h
@@ -0,0 +1,626 @@
+#ifndef GD_H
+#define GD_H 1
+
+#ifdef __cplusplus
+extern "C"
+{
+#endif
+
+/* some might want to set DEFAULT_FONTPATH from configure in config.h */
+#ifndef DEFAULT_FONTPATH
+/* default fontpath for unix systems  - whatever happened to standards ! */
+#define DEFAULT_FONTPATH "/usr/X11R6/lib/X11/fonts/TrueType:/usr/X11R6/lib/X11/fonts/truetype:/usr/X11R6/lib/X11/fonts/TTF:/usr/share/fonts/TrueType:/usr/share/fonts/truetype:/usr/openwin/lib/X11/fonts/TrueType:/usr/X11R6/lib/X11/fonts/Type1"
+#endif
+#ifndef PATHSEPARATOR
+#define PATHSEPARATOR ":"
+#endif
+
+/* gd.h: declarations file for the graphic-draw module.
+ * Permission to use, copy, modify, and distribute this software and its
+ * documentation for any purpose and without fee is hereby granted, provided
+ * that the above copyright notice appear in all copies and that both that
+ * copyright notice and this permission notice appear in supporting
+ * documentation.  This software is provided "AS IS." Thomas Boutell and
+ * Boutell.Com, Inc. disclaim all warranties, either express or implied, 
+ * including but not limited to implied warranties of merchantability and 
+ * fitness for a particular purpose, with respect to this code and accompanying
+ * documentation. */
+
+/* stdio is needed for file I/O. */
+#include <stdio.h>
+#include "gd_io.h"
+
+/* The maximum number of palette entries in palette-based images.
+	In the wonderful new world of gd 2.0, you can of course have
+	many more colors when using truecolor mode. */
+
+#define gdMaxColors 256
+
+/* Image type. See functions below; you will not need to change
+	the elements directly. Use the provided macros to
+	access sx, sy, the color table, and colorsTotal for 
+	read-only purposes. */
+
+/* If 'truecolor' is set true, the image is truecolor; 
+	pixels are represented by integers, which
+	must be 32 bits wide or more. 
+
+	True colors are repsented as follows:
+
+	ARGB
+
+	Where 'A' (alpha channel) occupies only the
+	LOWER 7 BITS of the MSB. This very small 
+	loss of alpha channel resolution allows gd 2.x
+	to keep backwards compatibility by allowing
+	signed integers to be used to represent colors,
+	and negative numbers to represent special cases,
+	just as in gd 1.x. */
+
+#define gdAlphaMax 127
+#define gdAlphaOpaque 0
+#define gdAlphaTransparent 127
+#define gdRedMax 255
+#define gdGreenMax 255
+#define gdBlueMax 255
+#define gdTrueColorGetAlpha(c) (((c) & 0x7F000000) >> 24)
+#define gdTrueColorGetRed(c) (((c) & 0xFF0000) >> 16)
+#define gdTrueColorGetGreen(c) (((c) & 0x00FF00) >> 8)
+#define gdTrueColorGetBlue(c) ((c) & 0x0000FF)
+
+/* This function accepts truecolor pixel values only. The 
+	source color is composited with the destination color
+	based on the alpha channel value of the source color.
+	The resulting color is opaque. */
+
+  int gdAlphaBlend (int dest, int src);
+
+  typedef struct gdImageStruct
+  {
+    /* Palette-based image pixels */
+    unsigned char **pixels;
+    int sx;
+    int sy;
+    /* These are valid in palette images only. See also
+       'alpha', which appears later in the structure to
+       preserve binary backwards compatibility */
+    int colorsTotal;
+    int red[gdMaxColors];
+    int green[gdMaxColors];
+    int blue[gdMaxColors];
+    int open[gdMaxColors];
+    /* For backwards compatibility, this is set to the
+       first palette entry with 100% transparency,
+       and is also set and reset by the 
+       gdImageColorTransparent function. Newer
+       applications can allocate palette entries
+       with any desired level of transparency; however,
+       bear in mind that many viewers, notably
+       many web browsers, fail to implement
+       full alpha channel for PNG and provide
+       support for full opacity or transparency only. */
+    int transparent;
+    int *polyInts;
+    int polyAllocated;
+    struct gdImageStruct *brush;
+    struct gdImageStruct *tile;
+    int brushColorMap[gdMaxColors];
+    int tileColorMap[gdMaxColors];
+    int styleLength;
+    int stylePos;
+    int *style;
+    int interlace;
+    /* New in 2.0: thickness of line. Initialized to 1. */
+    int thick;
+    /* New in 2.0: alpha channel for palettes. Note that only
+       Macintosh Internet Explorer and (possibly) Netscape 6
+       really support multiple levels of transparency in
+       palettes, to my knowledge, as of 2/15/01. Most
+       common browsers will display 100% opaque and
+       100% transparent correctly, and do something 
+       unpredictable and/or undesirable for levels
+       in between. TBB */
+    int alpha[gdMaxColors];
+    /* Truecolor flag and pixels. New 2.0 fields appear here at the
+       end to minimize breakage of existing object code. */
+    int trueColor;
+    int **tpixels;
+    /* Should alpha channel be copied, or applied, each time a
+       pixel is drawn? This applies to truecolor images only.
+       No attempt is made to alpha-blend in palette images,
+       even if semitransparent palette entries exist. 
+       To do that, build your image as a truecolor image,
+       then quantize down to 8 bits. */
+    int alphaBlendingFlag;
+    /* Should the alpha channel of the image be saved? This affects
+       PNG at the moment; other future formats may also
+       have that capability. JPEG doesn't. */
+    int saveAlphaFlag;
+
+    /* 2.0.12: anti-aliased globals */
+    int AA;
+    int AA_color;
+    int AA_dont_blend;
+    unsigned char **AA_opacity;
+    int AA_polygon;
+    /* Stored and pre-computed variables for determining the perpendicular
+       distance from a point to the anti-aliased line being drawn: */
+    int AAL_x1;
+    int AAL_y1;
+    int AAL_x2;
+    int AAL_y2;
+    int AAL_Bx_Ax;
+    int AAL_By_Ay;
+    int AAL_LAB_2;
+    float AAL_LAB;
+
+    /* 2.0.12: simple clipping rectangle. These values
+      must be checked for safety when set; please use
+      gdImageSetClip */
+    int cx1;
+    int cy1;
+    int cx2;
+    int cy2;
+  }
+  gdImage;
+
+  typedef gdImage *gdImagePtr;
+
+  typedef struct
+  {
+    /* # of characters in font */
+    int nchars;
+    /* First character is numbered... (usually 32 = space) */
+    int offset;
+    /* Character width and height */
+    int w;
+    int h;
+    /* Font data; array of characters, one row after another.
+       Easily included in code, also easily loaded from
+       data files. */
+    char *data;
+  }
+  gdFont;
+
+/* Text functions take these. */
+  typedef gdFont *gdFontPtr;
+
+/* For backwards compatibility only. Use gdImageSetStyle()
+	for MUCH more flexible line drawing. Also see
+	gdImageSetBrush(). */
+#define gdDashSize 4
+
+/* Special colors. */
+
+#define gdStyled (-2)
+#define gdBrushed (-3)
+#define gdStyledBrushed (-4)
+#define gdTiled (-5)
+
+/* NOT the same as the transparent color index.
+	This is used in line styles only. */
+#define gdTransparent (-6)
+
+#define gdAntiAliased (-7)
+
+/* Functions to manipulate images. */
+
+/* Creates a palette-based image (up to 256 colors). */
+  gdImagePtr gdImageCreate (int sx, int sy);
+
+/* An alternate name for the above (2.0). */
+#define gdImageCreatePalette gdImageCreate
+
+/* Creates a truecolor image (millions of colors). */
+  gdImagePtr gdImageCreateTrueColor (int sx, int sy);
+
+/* Creates an image from various file types. These functions
+	return a palette or truecolor image based on the
+	nature of the file being loaded. Truecolor PNG
+	stays truecolor; palette PNG stays palette-based;
+	JPEG is always truecolor. */
+  gdImagePtr gdImageCreateFromPng (FILE * fd);
+  gdImagePtr gdImageCreateFromPngCtx (gdIOCtxPtr in);
+  gdImagePtr gdImageCreateFromWBMP (FILE * inFile);
+  gdImagePtr gdImageCreateFromWBMPCtx (gdIOCtx * infile);
+  gdImagePtr gdImageCreateFromJpeg (FILE * infile);
+  gdImagePtr gdImageCreateFromJpegCtx (gdIOCtx * infile);
+
+/* A custom data source. */
+/* The source function must return -1 on error, otherwise the number
+        of bytes fetched. 0 is EOF, not an error! */
+/* context will be passed to your source function. */
+
+  typedef struct
+  {
+    int (*source) (void *context, char *buffer, int len);
+    void *context;
+  }
+  gdSource, *gdSourcePtr;
+
+  gdImagePtr gdImageCreateFromPngSource (gdSourcePtr in);
+
+  gdImagePtr gdImageCreateFromGd (FILE * in);
+  gdImagePtr gdImageCreateFromGdCtx (gdIOCtxPtr in);
+
+  gdImagePtr gdImageCreateFromGd2 (FILE * in);
+  gdImagePtr gdImageCreateFromGd2Ctx (gdIOCtxPtr in);
+
+  gdImagePtr gdImageCreateFromGd2Part (FILE * in, int srcx, int srcy, int w,
+				       int h);
+  gdImagePtr gdImageCreateFromGd2PartCtx (gdIOCtxPtr in, int srcx, int srcy,
+					  int w, int h);
+  /* 2.0.10: prototype was missing */
+  gdImagePtr gdImageCreateFromXpm (char *filename);
+  gdImagePtr gdImageCreateFromXbm (FILE * in);
+
+  void gdImageDestroy (gdImagePtr im);
+
+/* Replaces or blends with the background depending on the
+	most recent call to gdImageAlphaBlending and the
+	alpha channel value of 'color'; default is to overwrite. 
+	Tiling and line styling are also implemented
+	here. All other gd drawing functions pass through this call, 
+	allowing for many useful effects. */
+
+  void gdImageSetPixel (gdImagePtr im, int x, int y, int color);
+
+  int gdImageGetPixel (gdImagePtr im, int x, int y);
+
+  void gdImageAABlend (gdImagePtr im);
+
+  void gdImageLine (gdImagePtr im, int x1, int y1, int x2, int y2, int color);
+
+/* For backwards compatibility only. Use gdImageSetStyle()
+	for much more flexible line drawing. */
+  void gdImageDashedLine (gdImagePtr im, int x1, int y1, int x2, int y2,
+			  int color);
+/* Corners specified (not width and height). Upper left first, lower right
+ 	second. */
+  void gdImageRectangle (gdImagePtr im, int x1, int y1, int x2, int y2,
+			 int color);
+/* Solid bar. Upper left corner first, lower right corner second. */
+  void gdImageFilledRectangle (gdImagePtr im, int x1, int y1, int x2, int y2,
+			       int color);
+  void gdImageSetClip(gdImagePtr im, int x1, int y1, int x2, int y2);
+  void gdImageGetClip(gdImagePtr im, int *x1P, int *y1P, int *x2P, int *y2P);
+  int gdImageBoundsSafe (gdImagePtr im, int x, int y);
+  void gdImageChar (gdImagePtr im, gdFontPtr f, int x, int y, int c,
+		    int color);
+  void gdImageCharUp (gdImagePtr im, gdFontPtr f, int x, int y, int c,
+		      int color);
+  void gdImageString (gdImagePtr im, gdFontPtr f, int x, int y,
+		      unsigned char *s, int color);
+  void gdImageStringUp (gdImagePtr im, gdFontPtr f, int x, int y,
+			unsigned char *s, int color);
+  void gdImageString16 (gdImagePtr im, gdFontPtr f, int x, int y,
+			unsigned short *s, int color);
+  void gdImageStringUp16 (gdImagePtr im, gdFontPtr f, int x, int y,
+			  unsigned short *s, int color);
+
+/* clean up after using fonts in gdImageStringFT() */
+  void gdFreeFontCache ();
+
+/* Calls gdImageStringFT. Provided for backwards compatibility only. */
+  char *gdImageStringTTF (gdImage * im, int *brect, int fg, char *fontlist,
+			  double ptsize, double angle, int x, int y,
+			  char *string);
+
+/* FreeType 2 text output */
+  char *gdImageStringFT (gdImage * im, int *brect, int fg, char *fontlist,
+			 double ptsize, double angle, int x, int y,
+			 char *string);
+
+/* 2.0.5: provides an extensible way to pass additional parameters.
+	Thanks to Wez Furlong, sorry for the delay. */
+
+  typedef struct
+  {
+    int flags;			/* Logical OR of gdFTEX_ values */
+    double linespacing;		/* fine tune line spacing for '\n' */
+    int charmap;		/* TBB: 2.0.12: may be gdFTEX_Unicode,
+				   gdFTEX_Shift_JIS, or gdFTEX_Big5;
+				   when not specified, maps are searched
+				   for in the above order. */
+  }
+  gdFTStringExtra, *gdFTStringExtraPtr;
+
+#define gdFTEX_LINESPACE 1
+#define gdFTEX_CHARMAP 2
+
+/* These are NOT flags; set one in 'charmap' if you set the
+	gdFTEX_CHARMAP bit in 'flags'. */
+#define gdFTEX_Unicode 0
+#define gdFTEX_Shift_JIS 1
+#define gdFTEX_Big5 2
+
+  char *gdImageStringFTEx (gdImage * im, int *brect, int fg, char *fontlist,
+			   double ptsize, double angle, int x, int y,
+			   char *string, gdFTStringExtraPtr strex);
+
+/* Point type for use in polygon drawing. */
+  typedef struct
+  {
+    int x, y;
+  }
+  gdPoint, *gdPointPtr;
+
+  void gdImagePolygon (gdImagePtr im, gdPointPtr p, int n, int c);
+  void gdImageFilledPolygon (gdImagePtr im, gdPointPtr p, int n, int c);
+
+/* These functions still work with truecolor images, 
+	for which they never return error. */
+  int gdImageColorAllocate (gdImagePtr im, int r, int g, int b);
+/* gd 2.0: palette entries with non-opaque transparency are permitted. */
+  int gdImageColorAllocateAlpha (gdImagePtr im, int r, int g, int b, int a);
+/* Assumes opaque is the preferred alpha channel value */
+  int gdImageColorClosest (gdImagePtr im, int r, int g, int b);
+/* Closest match taking all four parameters into account.
+	A slightly different color with the same transparency
+	beats the exact same color with radically different
+	transparency */
+  int gdImageColorClosestAlpha (gdImagePtr im, int r, int g, int b, int a);
+/* An alternate method */
+  int gdImageColorClosestHWB (gdImagePtr im, int r, int g, int b);
+/* Returns exact, 100% opaque matches only */
+  int gdImageColorExact (gdImagePtr im, int r, int g, int b);
+/* Returns an exact match only, including alpha */
+  int gdImageColorExactAlpha (gdImagePtr im, int r, int g, int b, int a);
+/* Opaque only */
+  int gdImageColorResolve (gdImagePtr im, int r, int g, int b);
+/* Based on gdImageColorExactAlpha and gdImageColorClosestAlpha */
+  int gdImageColorResolveAlpha (gdImagePtr im, int r, int g, int b, int a);
+
+/* A simpler way to obtain an opaque truecolor value for drawing on a
+	truecolor image. Not for use with palette images! */
+
+#define gdTrueColor(r, g, b) (((r) << 16) + \
+	((g) << 8) + \
+	(b))
+
+/* Returns a truecolor value with an alpha channel component.
+	gdAlphaMax (127, **NOT 255**) is transparent, 0 is completely
+	opaque. */
+
+#define gdTrueColorAlpha(r, g, b, a) (((a) << 24) + \
+	((r) << 16) + \
+	((g) << 8) + \
+	(b))
+
+  void gdImageColorDeallocate (gdImagePtr im, int color);
+
+/* Converts a truecolor image to a palette-based image,
+	using a high-quality two-pass quantization routine
+	which attempts to preserve alpha channel information
+	as well as R/G/B color information when creating
+	a palette. If ditherFlag is set, the image will be
+	dithered to approximate colors better, at the expense
+	of some obvious "speckling." colorsWanted can be
+	anything up to 256. If the original source image
+	includes photographic information or anything that
+	came out of a JPEG, 256 is strongly recommended.
+
+	Better yet, don't use this function -- write real
+	truecolor PNGs and JPEGs. The disk space gain of
+        conversion to palette is not great (for small images
+        it can be negative) and the quality loss is ugly. */
+
+  void gdImageTrueColorToPalette (gdImagePtr im, int ditherFlag,
+				  int colorsWanted);
+
+/* Specifies a color index (if a palette image) or an
+	RGB color (if a truecolor image) which should be
+	considered 100% transparent. FOR TRUECOLOR IMAGES,
+	THIS IS IGNORED IF AN ALPHA CHANNEL IS BEING
+	SAVED. Use gdImageSaveAlpha(im, 0); to
+	turn off the saving of a full alpha channel in
+	a truecolor image. Note that gdImageColorTransparent
+	is usually compatible with older browsers that
+	do not understand full alpha channels well. TBB */
+  void gdImageColorTransparent (gdImagePtr im, int color);
+
+  void gdImagePaletteCopy (gdImagePtr dst, gdImagePtr src);
+  void gdImagePng (gdImagePtr im, FILE * out);
+  void gdImagePngCtx (gdImagePtr im, gdIOCtx * out);
+  /* 2.0.12: Compression level: 0-9 or -1, where 0 is NO COMPRESSION at all,
+     1 is FASTEST but produces larger files, 9 provides the best
+     compression (smallest files) but takes a long time to compress, and
+     -1 selects the default compiled into the zlib library. */
+  void gdImagePngEx (gdImagePtr im, FILE * out, int level);
+  void gdImagePngCtxEx (gdImagePtr im, gdIOCtx * out, int level);
+
+  void gdImageWBMP (gdImagePtr image, int fg, FILE * out);
+  void gdImageWBMPCtx (gdImagePtr image, int fg, gdIOCtx * out);
+
+/* Guaranteed to correctly free memory returned
+	by the gdImage*Ptr functions */
+  void gdFree (void *m);
+
+/* Best to free this memory with gdFree(), not free() */
+  void *gdImageWBMPPtr (gdImagePtr im, int *size, int fg);
+
+/* 100 is highest quality (there is always a little loss with JPEG).
+	0 is lowest. 10 is about the lowest useful setting. */
+  void gdImageJpeg (gdImagePtr im, FILE * out, int quality);
+  void gdImageJpegCtx (gdImagePtr im, gdIOCtx * out, int quality);
+
+/* Best to free this memory with gdFree(), not free() */
+  void *gdImageJpegPtr (gdImagePtr im, int *size, int quality);
+
+/* A custom data sink. For backwards compatibility. Use
+	gdIOCtx instead. */
+/* The sink function must return -1 on error, otherwise the number
+        of bytes written, which must be equal to len. */
+/* context will be passed to your sink function. */
+  typedef struct
+  {
+    int (*sink) (void *context, const char *buffer, int len);
+    void *context;
+  }
+  gdSink, *gdSinkPtr;
+
+  void gdImagePngToSink (gdImagePtr im, gdSinkPtr out);
+
+  void gdImageGd (gdImagePtr im, FILE * out);
+  void gdImageGd2 (gdImagePtr im, FILE * out, int cs, int fmt);
+
+/* Best to free this memory with gdFree(), not free() */
+  void *gdImagePngPtr (gdImagePtr im, int *size);
+  void *gdImagePngPtrEx (gdImagePtr im, int *size, int level);
+
+/* Best to free this memory with gdFree(), not free() */
+  void *gdImageGdPtr (gdImagePtr im, int *size);
+
+/* Best to free this memory with gdFree(), not free() */
+  void *gdImageGd2Ptr (gdImagePtr im, int cs, int fmt, int *size);
+
+  void gdImageEllipse (gdImagePtr im, int cx, int cy, int w, int h,
+		       int color);
+
+/* Style is a bitwise OR ( | operator ) of these.
+	gdArc and gdChord are mutually exclusive;
+	gdChord just connects the starting and ending
+	angles with a straight line, while gdArc produces
+	a rounded edge. gdPie is a synonym for gdArc. 
+	gdNoFill indicates that the arc or chord should be
+	outlined, not filled. gdEdged, used together with
+	gdNoFill, indicates that the beginning and ending
+	angles should be connected to the center; this is
+	a good way to outline (rather than fill) a
+	'pie slice'. */
+#define gdArc   0
+#define gdPie   gdArc
+#define gdChord 1
+#define gdNoFill 2
+#define gdEdged 4
+
+  void gdImageFilledArc (gdImagePtr im, int cx, int cy, int w, int h, int s,
+			 int e, int color, int style);
+  void gdImageArc (gdImagePtr im, int cx, int cy, int w, int h, int s, int e,
+		   int color);
+  void gdImageFilledEllipse (gdImagePtr im, int cx, int cy, int w, int h,
+			     int color);
+  void gdImageFillToBorder (gdImagePtr im, int x, int y, int border,
+			    int color);
+  void gdImageFill (gdImagePtr im, int x, int y, int color);
+  void gdImageCopy (gdImagePtr dst, gdImagePtr src, int dstX, int dstY,
+		    int srcX, int srcY, int w, int h);
+  void gdImageCopyMerge (gdImagePtr dst, gdImagePtr src, int dstX, int dstY,
+			 int srcX, int srcY, int w, int h, int pct);
+  void gdImageCopyMergeGray (gdImagePtr dst, gdImagePtr src, int dstX,
+			     int dstY, int srcX, int srcY, int w, int h,
+			     int pct);
+
+/* Stretches or shrinks to fit, as needed. Does NOT attempt
+	to average the entire set of source pixels that scale down onto the
+	destination pixel. */
+  void gdImageCopyResized (gdImagePtr dst, gdImagePtr src, int dstX, int dstY,
+			   int srcX, int srcY, int dstW, int dstH, int srcW,
+			   int srcH);
+
+/* gd 2.0: stretches or shrinks to fit, as needed. When called with a
+	truecolor destination image, this function averages the
+	entire set of source pixels that scale down onto the
+	destination pixel, taking into account what portion of the
+	destination pixel each source pixel represents. This is a
+	floating point operation, but this is not a performance issue
+	on modern hardware, except for some embedded devices. If the 
+	destination is a palette image, gdImageCopyResized is 
+	substituted automatically. */
+  void gdImageCopyResampled (gdImagePtr dst, gdImagePtr src, int dstX,
+			     int dstY, int srcX, int srcY, int dstW, int dstH,
+			     int srcW, int srcH);
+
+/* gd 2.0.8: gdImageCopyRotated is added. Source
+        is a rectangle, with its upper left corner at
+        srcX and srcY. Destination is the *center* of
+        the rotated copy. Angle is in degrees, same as
+        gdImageArc. Floating point destination center
+        coordinates allow accurate rotation of
+        objects of odd-numbered width or height. */
+  void gdImageCopyRotated (gdImagePtr dst,
+			   gdImagePtr src,
+			   double dstX, double dstY,
+			   int srcX, int srcY,
+			   int srcWidth, int srcHeight, int angle);
+
+  void gdImageSetBrush (gdImagePtr im, gdImagePtr brush);
+  void gdImageSetTile (gdImagePtr im, gdImagePtr tile);
+  void gdImageSetAntiAliased (gdImagePtr im, int c);
+  void gdImageSetAntiAliasedDontBlend (gdImagePtr im, int c, int dont_blend);
+  void gdImageSetStyle (gdImagePtr im, int *style, int noOfPixels);
+/* Line thickness (defaults to 1). Affects lines, ellipses, 
+	rectangles, polygons and so forth. */
+  void gdImageSetThickness (gdImagePtr im, int thickness);
+/* On or off (1 or 0) for all three of these. */
+  void gdImageInterlace (gdImagePtr im, int interlaceArg);
+  void gdImageAlphaBlending (gdImagePtr im, int alphaBlendingArg);
+  void gdImageSaveAlpha (gdImagePtr im, int saveAlphaArg);
+
+/* Macros to access information about images. */
+
+/* Returns nonzero if the image is a truecolor image,
+	zero for a palette image. */
+
+#define gdImageTrueColor(im) ((im)->trueColor)
+
+#define gdImageSX(im) ((im)->sx)
+#define gdImageSY(im) ((im)->sy)
+#define gdImageColorsTotal(im) ((im)->colorsTotal)
+#define gdImageRed(im, c) ((im)->trueColor ? gdTrueColorGetRed(c) : \
+	(im)->red[(c)])
+#define gdImageGreen(im, c) ((im)->trueColor ? gdTrueColorGetGreen(c) : \
+	(im)->green[(c)])
+#define gdImageBlue(im, c) ((im)->trueColor ? gdTrueColorGetBlue(c) : \
+	(im)->blue[(c)])
+#define gdImageAlpha(im, c) ((im)->trueColor ? gdTrueColorGetAlpha(c) : \
+	(im)->alpha[(c)])
+#define gdImageGetTransparent(im) ((im)->transparent)
+#define gdImageGetInterlaced(im) ((im)->interlace)
+
+/* These macros provide direct access to pixels in
+	palette-based and truecolor images, respectively.
+	If you use these macros, you must perform your own
+	bounds checking. Use of the macro for the correct type
+	of image is also your responsibility. */
+#define gdImagePalettePixel(im, x, y) (im)->pixels[(y)][(x)]
+#define gdImageTrueColorPixel(im, x, y) (im)->tpixels[(y)][(x)]
+
+/* I/O Support routines. */
+
+  gdIOCtx *gdNewFileCtx (FILE *);
+  gdIOCtx *gdNewDynamicCtx (int, void *);
+  gdIOCtx *gdNewSSCtx (gdSourcePtr in, gdSinkPtr out);
+  void *gdDPExtractData (struct gdIOCtx *ctx, int *size);
+
+#define GD2_CHUNKSIZE           128
+#define GD2_CHUNKSIZE_MIN	64
+#define GD2_CHUNKSIZE_MAX       4096
+
+#define GD2_VERS                2
+#define GD2_ID                  "gd2"
+
+#define GD2_FMT_RAW             1
+#define GD2_FMT_COMPRESSED      2
+
+/* Image comparison definitions */
+  int gdImageCompare (gdImagePtr im1, gdImagePtr im2);
+
+#define GD_CMP_IMAGE		1	/* Actual image IS different */
+#define GD_CMP_NUM_COLORS	2	/* Number of Colours in pallette differ */
+#define GD_CMP_COLOR		4	/* Image colours differ */
+#define GD_CMP_SIZE_X		8	/* Image width differs */
+#define GD_CMP_SIZE_Y		16	/* Image heights differ */
+#define GD_CMP_TRANSPARENT	32	/* Transparent colour */
+#define GD_CMP_BACKGROUND	64	/* Background colour */
+#define GD_CMP_INTERLACE	128	/* Interlaced setting */
+#define GD_CMP_TRUECOLOR	256	/* Truecolor vs palette differs */
+
+/* resolution affects ttf font rendering, particularly hinting */
+#define GD_RESOLUTION           96	/* pixels per inch */
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif				/* GD_H */
diff --git a/collects/plot/src/all/gd_drv.c b/collects/plot/src/all/gd_drv.c
new file mode 100644
index 0000000000..0150f70b62
--- /dev/null
+++ b/collects/plot/src/all/gd_drv.c
@@ -0,0 +1,1143 @@
+/* $Id: gd_drv.c,v 1.1 2004/03/01 20:54:46 cozmic Exp $
+
+         PNG and JPEG device driver based on libgd
+*/
+
+/*
+ *  The GD drivers, PNG and JPEG, support a number of different options
+ *  depending on the version of GD installed.
+ *
+ *  If you have installed GD Ver 2.+ you gain support for truecolour (24
+ *  bit, 16 millionish) modes as well as different line widths. These
+ *  capibilities are part of GD more so than the GD driver, so they aren't
+ *  available in any 1.? versions of the driver.
+ *
+ *  24 bit support is, by default, set to "auto" if you have V2.+ of GD.
+ *  What this means is the *driver* decides when to use 24 bit or 8 bit
+ *  modes for PNG files. The logic is rather simple - if you have less than
+ *  257 colours, it is set to 8 bit mode, if more then it's in 24 bit mode.
+ *  This should work fine for most people, most of the time, in most
+ *  situations; however, it can be overridden in case it has to via the
+ *  "-drvopt" command line switch. The png driver has two related settings:
+ *              8bit    and
+ *              24bit
+ *
+ *  If either of these command line toggles are set, that mode becomes the
+ *  standard used regardless of the number of colours used. It can be envoked
+ *  as follows:
+ *                 x08c -dev png -drvopt 8bit -fam -o 8bitpng
+ *                                      or
+ *                 x08c -dev png -drvopt 24bit -fam -o 24bitpng
+ *
+ *  NOTE:
+ *  The 24 bit PNG file is an RGBA file, not RGB - it includes alpha channel
+ *  (transparency). Transparency is set to opaque, but the fact it is an
+ *  RGBA and not an RGB might cause some problems with some viewers.
+ *  Sadly, I can't do anything about it... sorry.
+ *
+ *
+ *  Stuff for GD V1.? as well as V2.+
+ *
+ *  optimise
+ *
+ *  From version 1.17 of the GD driver, a command line option has been
+ *  added to try and optimise the PNG files. If successful, the optimise
+ *  command will create 4 bit (16 colour) PNGs instead of 8 bit (256 colour)
+ *  ones. This results in slightly smaller files with no loss in any colour
+ *  information. The function has no real memory overhead, but does have a
+ *  slight speed hit in exchange for the optimisation. For example:
+ *         x08c -dev png -drvopt 8bit,optimise -fam -o 8bitpng
+ *  forces the png driver to make 8bit pngs, and will then optimise any PNG
+ *  images with 16 or less colours into a 4 bit PNG. Note, this DOESN'T WORK
+ *  WITH 24bit PNGs yet, and will never work with JPEGs.
+ *
+ *
+ *  Also as of version 1.17 of the GD driver, the options for palette
+ *  modification previously set with the command line option "-hack" have
+ *  now been moved to two options settable from the -drvopt switch.
+ *
+ *  def_black15
+ *
+ *  -drvopt def_black15 sets index 15, usually white, to black if index 0,
+ *  the background colour and usually black, has been set to white from the
+ *  command line option -bg
+ *
+ *  swp_red15
+ *
+ *  -drvopt swp_red15 swaps index 15, usually white, with index 1, which is
+ *  usually red. This might be desirable occasionally, but it is principally
+ *  included for cases when the background has been set on the command line
+ *  to white, and the "def_black15" option has been issued to redefine index
+ *  15 as black. By issuing a command like:
+ *                 x08c -dev png -bg ffffff -drvopt def_black15,swp_red15
+ *  the driver will set the background to white, then redefine index 15 of
+ *  cmap0, which is usually white to black, then swap index 2 (red) to 15
+ *  (white originally, now black), so at the end of the day, the "default"
+ *  plotting colour is now black. Why do all of this ? It is a very quick
+ *  way of making a nice web-friendly png without having to redefine the
+ *  cmaps within your program.
+ *
+ */
+
+
+#include "plDevs.h"
+
+#if defined(PLD_png) || defined(PLD_jpeg)
+
+#include "plplotP.h"
+#include "drivers.h"
+
+#include "gd.h"
+
+/* Device info */
+char* plD_DEVICE_INFO_gd = "jpeg:JPEG file:0:gd:40:jpeg\n"
+                       "png:PNG file:0:gd:39:png";
+
+
+#ifdef HAVE_FREETYPE
+
+/*
+ *  Freetype support has been added to the GD family of drivers using the
+ *  plfreetype.c module, and implemented as a driver-specific optional extra
+ *  invoked via the -drvopt command line toggle. It uses the
+ *  "PLESC_HAS_TEXT" command for rendering within the driver.
+ *
+ *  Freetype support is turned on/off at compile time by defining
+ *  "HAVE_FREETYPE".
+ *
+ *  To give the user some level of control over the fonts that are used,
+ *  environmental variables can be set to over-ride the definitions used by
+ *  the five default plplot fonts.
+ *
+ *  Freetype rendering is used with the command line "-drvopt text".
+ *  Anti-aliased fonts can be used by issuing "-drvopt text,smooth"
+ */
+
+#include "plfreetype.h"
+
+#endif
+
+/* Prototypes for functions in this file. */
+
+static void	fill_polygon	(PLStream *pls);
+static void	setcmap		(PLStream *pls);
+static void     plD_init_png_Dev(PLStream *pls);
+static void     plD_gd_optimise (PLStream *pls);
+static void     plD_black15_gd  (PLStream *pls);
+static void     plD_red15_gd    (PLStream *pls);
+
+#ifdef HAVE_FREETYPE
+
+static void plD_pixel_gd (PLStream *pls, short x, short y);
+static void init_freetype_lv1 (PLStream *pls);
+static void init_freetype_lv2 (PLStream *pls);
+
+extern void plD_FreeType_init(PLStream *pls);
+extern void plD_render_freetype_text (PLStream *pls, EscText *args);
+extern void plD_FreeType_Destroy(PLStream *pls);
+extern void pl_set_extended_cmap0(PLStream *pls, int ncol0_width, int ncol0_org);
+
+#endif
+
+/* top level declarations */
+
+static int NCOLOURS=gdMaxColors;
+
+/* In an attempt to fix a problem with the hidden line removal functions
+ * that results in hidden lines *not* being removed from "small" plot
+ * pages (ie, like a normal video screen), a "virtual" page of much
+ * greater size is used to trick the algorithm into working correctly.
+ * If, in future, this gets fixed on its own, then don't define
+ * "use_experimental_hidden_line_hack"
+ */
+
+#define use_experimental_hidden_line_hack
+
+/* I think the current version of Freetype supports up to a maximum of
+ * 128 grey levels for text smoothing. You can get quite acceptable
+ * results with as few as 4 grey-levels. Uusually only about 5 get used
+ * anyway, but the question is where, in the "grey spectrum" will they be ?
+ * Who knows ? The following define lets you set a maximum limit on the
+ * number of grey-levels used. It is really only here for the 24bit mode
+ * and could be set to 255, but that would slow things down and use more
+ * memory. 64 seems to be a nice compromise, but if you want to change it,
+ * then change it here.
+ */
+
+#ifndef max_number_of_grey_levels_used_in_text_smoothing 
+#define max_number_of_grey_levels_used_in_text_smoothing 64
+#endif
+
+/* Not present in versions before 2.0 */
+
+#ifndef gdImagePalettePixel
+#define gdImagePalettePixel(  im, x, y )   (im)->pixels[(y)][(x)]
+#endif
+
+/* Struct to hold device-specific info. */
+
+typedef struct {
+
+	gdImagePtr im_out;                      /* Graphics pointer */
+        PLINT pngx;
+        PLINT pngy;
+
+        int colour;                             /* Current Colour               */
+        int totcol;                             /* Total number of colours      */
+        int ncol1;                              /* Actual size of ncol1 we got  */
+
+	int scale;                              /* scaling factor to "blow up" to */
+                                                /* the "virtual" page in removing hidden lines*/
+
+	int optimise;                           /* Flag used for 4bit pngs */
+        int black15;                            /* Flag used for forcing a black colour */
+        int red15;                              /* Flag for swapping red and 15 */
+
+#if GD2_VERS >= 2
+        int truecolour;                         /* Flag to ALWAYS force 24 bit mode */
+        int palette;                            /* Flag to ALWAYS force  8 bit mode */
+#endif
+
+} png_Dev;
+
+void plD_init_png		(PLStream *);
+void plD_line_png		(PLStream *, short, short, short, short);
+void plD_polyline_png		(PLStream *, short *, short *, PLINT);
+void plD_eop_png		(PLStream *);
+void plD_eop_jpeg		(PLStream *);
+void plD_bop_png		(PLStream *);
+void plD_tidy_png		(PLStream *);
+void plD_state_png		(PLStream *, PLINT);
+void plD_esc_png		(PLStream *, PLINT, void *);
+
+#ifdef PLD_png
+
+void plD_dispatch_init_png( PLDispatchTable *pdt )
+{
+    pdt->pl_MenuStr  = "PNG file";
+    pdt->pl_DevName  = "png";
+    pdt->pl_type     = plDevType_FileOriented;
+    pdt->pl_seq      = 39;
+    pdt->pl_init     = (plD_init_fp)     plD_init_png;
+    pdt->pl_line     = (plD_line_fp)     plD_line_png;
+    pdt->pl_polyline = (plD_polyline_fp) plD_polyline_png;
+    pdt->pl_eop      = (plD_eop_fp)      plD_eop_png;
+    pdt->pl_bop      = (plD_bop_fp)      plD_bop_png;
+    pdt->pl_tidy     = (plD_tidy_fp)     plD_tidy_png;
+    pdt->pl_state    = (plD_state_fp)    plD_state_png;
+    pdt->pl_esc      = (plD_esc_fp)      plD_esc_png;
+}
+
+#endif
+
+#ifdef PLD_jpeg
+
+void plD_dispatch_init_jpeg( PLDispatchTable *pdt )
+{
+    pdt->pl_MenuStr  = "JPEG File";
+    pdt->pl_DevName  = "jpeg";
+    pdt->pl_type     = plDevType_FileOriented;
+    pdt->pl_seq      = 40;
+    pdt->pl_init     = (plD_init_fp)     plD_init_png;
+    pdt->pl_line     = (plD_line_fp)     plD_line_png;
+    pdt->pl_polyline = (plD_polyline_fp) plD_polyline_png;
+    pdt->pl_eop      = (plD_eop_fp)      plD_eop_jpeg;
+    pdt->pl_bop      = (plD_bop_fp)      plD_bop_png;
+    pdt->pl_tidy     = (plD_tidy_fp)     plD_tidy_png;
+    pdt->pl_state    = (plD_state_fp)    plD_state_png;
+    pdt->pl_esc      = (plD_esc_fp)      plD_esc_png;
+}
+#endif
+
+/*--------------------------------------------------------------------------*\
+ * plD_init_png_Dev()
+ *
+\*--------------------------------------------------------------------------*/
+
+static void
+plD_init_png_Dev(PLStream *pls)
+{
+    png_Dev *dev;
+    int i;
+
+/*  Stuff for the driver options, these vars are copied into the driver
+ *  structure so that everything is thread safe and reenterant.
+ */
+
+    int optimise=0;
+    int black15=0;
+    int red15=0;
+#if GD2_VERS >= 2
+    int truecolour=0;
+    int palette=0;
+#endif
+#ifdef HAVE_FREETYPE
+    int freetype=0;
+    int smooth_text=0;
+    FT_Data *FT;
+#endif
+
+    DrvOpt gd_options[] = {{"optimise", DRV_INT, &optimise, "Optimise PNG palette when possible"},
+                              {"def_black15", DRV_INT, &black15, "Define idx 15 as black. If the background is \"whiteish\" (from \"-bg\" option), force index 15 (traditionally white) to be \"black\""},
+                              {"swp_red15", DRV_INT, &red15, "Swap index 1 (usually red) and 1 (usually white); always done after \"black15\"; quite useful for quick changes to web pages"},
+#if GD2_VERS >= 2
+                              {"8bit", DRV_INT, &palette, "Palette (8 bit) mode"},
+                              {"24bit", DRV_INT, &truecolour, "Truecolor (24 bit) mode"},
+#endif
+#ifdef HAVE_FREETYPE
+                              {"text", DRV_INT, &freetype, "Use driver text (FreeType)"},
+                              {"smooth", DRV_INT, &smooth_text, "Turn text smoothing on (1) or off (0)"},
+#endif
+			      {NULL, DRV_INT, NULL, NULL}};
+
+
+/* Allocate and initialize device-specific data */
+
+    if (pls->dev != NULL)
+	free((void *) pls->dev);
+
+    pls->dev = calloc(1, (size_t) sizeof(png_Dev));
+    if (pls->dev == NULL)
+	plexit("plD_init_png_Dev: Out of memory.");
+
+    dev = (png_Dev *) pls->dev;
+
+    dev->colour=1;  /* Set a fall back pen colour in case user doesn't */
+
+/*
+ *  Set the compression/quality level for JPEG files
+ *  The higher the value, the bigger/better the image is
+ */
+    if ( (pls->dev_compression<=0)||(pls->dev_compression>99) )
+       pls->dev_compression=90;
+
+/* Check for and set up driver options */
+
+    plParseDrvOpts(gd_options);
+
+    dev->black15=black15;
+    dev->red15=red15;
+    dev->optimise=optimise;
+
+#if GD2_VERS >= 2
+
+    dev->palette=palette;
+    dev->truecolour=truecolour;
+    
+    if ((dev->truecolour>0) && (dev->palette>0))
+       plwarn("Selecting both \"truecolor\" AND \"palette\" driver options is contradictory, so\nI will just use my best judgment.\n");
+    else if (dev->truecolour>0)
+       NCOLOURS=16777216;
+    else if ((dev->truecolour==0)&&(dev->palette==0)&&((pls->ncol1+pls->ncol0)>NCOLOURS))
+       {
+        NCOLOURS=16777216;
+       }
+
+#endif
+
+#ifdef HAVE_FREETYPE
+if (freetype)
+   {
+    pls->dev_text = 1; /* want to draw text */
+    init_freetype_lv1(pls);
+    FT=(FT_Data *)pls->FT;
+    FT->want_smooth_text=smooth_text;
+   }
+
+#endif
+}
+
+/*----------------------------------------------------------------------*\
+ * plD_init_png()
+ *
+ * Initialize device.
+\*----------------------------------------------------------------------*/
+
+void plD_init_png(PLStream *pls)
+{
+    png_Dev *dev=NULL;
+
+    pls->termin = 0;            /* Not an interactive device */
+    pls->icol0 = 1;
+    pls->bytecnt = 0;
+    pls->page = 0;
+    pls->dev_fill0 = 1;         /* Can do solid fills */
+
+    if (!pls->colorset)
+	pls->color = 1;         /* Is a color device */
+
+/* Initialize family file info */
+    plFamInit(pls);
+
+/* Prompt for a file name if not already set */
+    plOpenFile(pls);
+
+/* Allocate and initialize device-specific data */
+    plD_init_png_Dev(pls);
+    dev=(png_Dev *)pls->dev;
+
+      if (pls->xlength <= 0 || pls->ylength <=0)
+      {
+/* use default width, height of 800x600 if not specifed by -geometry option
+ * or plspage */
+	 plspage(0., 0., 800, 600, 0, 0);
+      }
+
+     pls->graphx = GRAPHICS_MODE;
+
+     dev->pngx = pls->xlength - 1;	/* should I use -1 or not??? */
+     dev->pngy = pls->ylength - 1;
+
+#ifdef use_experimental_hidden_line_hack
+
+     if (dev->pngx>dev->pngy)    /* Work out the scaling factor for the  */
+        {                        /* "virtual" (oversized) page           */
+        dev->scale=PIXELS_X/dev->pngx;
+        }
+     else
+        {
+        dev->scale=PIXELS_Y/dev->pngy;
+        }
+#else
+
+     dev->scale=1;
+
+#endif
+
+
+     if (pls->xdpi<=0)
+     {
+/* This corresponds to a typical monitor resolution of 4 pixels/mm. */
+        plspage(4.*25.4, 4.*25.4, 0, 0, 0, 0);
+     }
+     else
+     {
+        pls->ydpi=pls->xdpi;        /* Set X and Y dpi's to the same value */
+     }
+/* Convert DPI to pixels/mm */
+     plP_setpxl(dev->scale*pls->xdpi/25.4,dev->scale*pls->ydpi/25.4);
+
+     plP_setphy(0, dev->scale*dev->pngx, 0, dev->scale*dev->pngy);
+
+#ifdef HAVE_FREETYPE
+if (pls->dev_text)
+   {
+    init_freetype_lv2(pls);
+   }
+#endif
+
+}
+
+/*----------------------------------------------------------------------*\
+ * plD_line_png()
+ *
+ * Draw a line in the current color from (x1,y1) to (x2,y2).
+\*----------------------------------------------------------------------*/
+
+void
+plD_line_png(PLStream *pls, short x1a, short y1a, short x2a, short y2a)
+{
+    png_Dev *dev=(png_Dev *)pls->dev;
+    int x1 = x1a/dev->scale, y1 = y1a/dev->scale, x2 = x2a/dev->scale, y2 = y2a/dev->scale;
+    y1 = dev->pngy - y1;
+    y2 = dev->pngy - y2;
+
+    gdImageLine(dev->im_out, x1, y1, x2, y2, dev->colour);
+
+}
+
+/*----------------------------------------------------------------------*\
+ * plD_polyline_png()
+ *
+ * Draw a polyline in the current color.
+\*----------------------------------------------------------------------*/
+
+void
+plD_polyline_png(PLStream *pls, short *xa, short *ya, PLINT npts)
+{
+    PLINT i;
+
+    for (i = 0; i < npts - 1; i++)
+	plD_line_png(pls, xa[i], ya[i], xa[i + 1], ya[i + 1]);
+}
+
+
+/*----------------------------------------------------------------------*\
+ * fill_polygon()
+ *
+ * Fill polygon described in points pls->dev_x[] and pls->dev_y[].
+\*----------------------------------------------------------------------*/
+
+static void
+fill_polygon(PLStream *pls)
+{
+png_Dev *dev=(png_Dev *)pls->dev;
+
+    int i;
+    gdPoint *points=NULL;
+
+    if (pls->dev_npts < 1)
+	return;
+
+     points = malloc((size_t)pls->dev_npts * sizeof(gdPoint));
+
+     for (i = 0; i < pls->dev_npts; i++)
+         {
+	   points[i].x = pls->dev_x[i]/dev->scale;
+	   points[i].y = dev->pngy - (pls->dev_y[i]/dev->scale);
+         }
+
+   gdImageFilledPolygon(dev->im_out, points, pls->dev_npts, dev->colour);
+   free(points);
+
+}
+
+/*----------------------------------------------------------------------*\
+ * setcmap()
+ *
+ * Sets up color palette.
+\*----------------------------------------------------------------------*/
+
+static void
+setcmap(PLStream *pls)
+{
+    int i, ncol1=pls->ncol1;
+    int ncol0=pls->ncol0, total_colours;
+    PLColor cmap1col;
+    png_Dev *dev=(png_Dev *)pls->dev;
+    PLFLT tmp_colour_pos;
+
+/*
+ * Yuckky fix to get rid of the previosuly allocated palette from the 
+ * GD image
+ */
+
+    for (i=0;i<256;i++) 
+      { 
+       gdImageColorDeallocate(dev->im_out,i);
+      }
+
+    if (ncol0>NCOLOURS/2)     /* Check for ridiculous number of colours */
+       {                      /* in ncol0, and appropriately adjust the */
+        plwarn("Too many colours in cmap0.");     /* number, issuing a  */
+        ncol0=NCOLOURS/2;                         /* warning if it does */
+        pls->ncol0=ncol0;
+       }
+
+    dev->totcol=0;       /* Reset the number of colours counter to zero */
+
+    total_colours=ncol0+ncol1;  /* Work out how many colours are wanted */
+
+    if (total_colours>NCOLOURS)     /* Do some rather modest error      */
+       {                            /* checking to make sure that       */
+        total_colours=NCOLOURS;     /* we are not defining more colours */
+        ncol1=total_colours-ncol0;  /* than we have room for.           */
+
+        if (ncol1<=0)
+           {
+            plexit("Problem setting colourmap in PNG or JPEG driver.");
+           }
+       }
+
+ dev->ncol1=ncol1;  /* The actual size of ncol1, regardless of what was asked.
+                     * This is dependent on colour slots available.
+                     * It might well be the same as ncol1.
+                     */
+
+/* Initialize cmap 0 colors */
+
+if (ncol0>0)  /* make sure the program actually asked for cmap0 first */
+   {
+    for (i = 0; i < ncol0; i++)
+        {
+        gdImageColorAllocate(dev->im_out,
+                             pls->cmap0[i].r, pls->cmap0[i].g, pls->cmap0[i].b);
+        ++dev->totcol; /* count the number of colours we use as we use them */
+        }
+
+
+  }
+
+/* Initialize any remaining slots for cmap1 */
+
+
+if (ncol1>0)    /* make sure that we want to define cmap1 first */
+   {
+    for (i = 0; i < ncol1; i++)
+        {
+
+         if (ncol1<pls->ncol1)       /* Check the dynamic range of colours */
+            {
+
+             /*
+              * Ok, now if we have less colour slots available than are being
+              * defined by pls->ncol1, then we still want to use the full
+              * dynamic range of cmap1 as best we can, so what we do is work
+              * out an approximation to the index in the full dynamic range
+              * in cases when pls->ncol1 exceeds the number of free colours.
+              */
+
+             tmp_colour_pos= i>0 ? pls->ncol1*((PLFLT)i/ncol1) : 0;
+             plcol_interp(pls, &cmap1col, (int) tmp_colour_pos, pls->ncol1);
+
+            }
+         else
+            {
+             plcol_interp(pls, &cmap1col, i, ncol1);
+            }
+
+
+         gdImageColorAllocate(dev->im_out,
+                                   cmap1col.r, cmap1col.g, cmap1col.b);
+
+         ++dev->totcol; /* count the number of colours we use as we go */
+        }
+   }
+}
+
+
+/*----------------------------------------------------------------------*\
+ * plD_state_png()
+ *
+ * Handle change in PLStream state (color, pen width, fill attribute, etc).
+\*----------------------------------------------------------------------*/
+
+void
+plD_state_png(PLStream *pls, PLINT op)
+{
+png_Dev *dev=(png_Dev *)pls->dev;
+PLFLT tmp_colour_pos;
+#if GD2_VERS >= 2
+long temp_col;
+#endif
+
+
+    switch (op) {
+
+#if GD2_VERS >= 2
+    case PLSTATE_WIDTH:
+        gdImageSetThickness(dev->im_out, pls->width);
+	break;
+#endif
+
+    case PLSTATE_COLOR0:
+#if GD2_VERS >= 2
+
+	if ( (pls->icol0 == PL_RGB_COLOR)||     /*  Should never happen since PL_RGB_COLOR is depreciated, but here for backwards compatibility */
+             (gdImageTrueColor(dev->im_out)) )  /*  We will do this if we are in "TrueColour" mode */
+           {
+	    if ( (dev->totcol < NCOLOURS)||         /* See if there are slots left, if so we will allocate a new colour */
+                 (gdImageTrueColor(dev->im_out)) )  /* In TrueColour mode we allocate each colour as we come to it */
+	       {
+	        /* Next allocate a new colour to a temporary slot since what we do with it will varay depending on if its a pallter index or truecolour */
+                temp_col=gdImageColorAllocate(dev->im_out,pls->curcolor.r,
+                                             pls->curcolor.g, pls->curcolor.b);
+
+                if (gdImageTrueColor(dev->im_out))
+                    dev->colour = temp_col;     /* If it's truecolour, then we will directly set dev->colour to our "new" colour */
+                else
+                    {
+                     dev->colour = dev->totcol;  /* or else, we will just set it to the last colour */
+                     dev->totcol++;              /* Bump the total colours for next time round */
+                    }
+	       }
+
+           }
+         else  /* just a normal colour allocate, so don't worry about the above stuff, just grab the index */
+           {
+            dev->colour = pls->icol0;
+           }
+
+#else
+	dev->colour = pls->icol0;
+	if (dev->colour == PL_RGB_COLOR)
+           {
+	    if (dev->totcol < NCOLOURS)
+	       {
+                gdImageColorAllocate(dev->im_out,pls->curcolor.r, pls->curcolor.g,  pls->curcolor.b);
+		dev->colour = dev->totcol;
+	       }
+
+           }
+#endif
+	break;
+
+    case PLSTATE_COLOR1:
+
+#if GD2_VERS >= 2
+       if (!gdImageTrueColor(dev->im_out))
+          {
+#endif
+           /*
+            * Start by checking to see if we have to compensate for cases where
+            * we don't have the full dynamic range of cmap1 at our disposal
+            */
+           if (dev->ncol1<pls->ncol1)
+              {
+               tmp_colour_pos=dev->ncol1*((PLFLT)pls->icol1/(pls->ncol1>0 ? pls->ncol1 : 1));
+               dev->colour = pls->ncol0 + (int)tmp_colour_pos;
+              }
+           else
+              dev->colour = pls->ncol0 + pls->icol1;
+#if GD2_VERS >= 2
+           }
+        else    /* it is a truecolour image */
+           {
+             dev->colour = gdTrueColor(pls->curcolor.r, pls->curcolor.g, pls->curcolor.b);
+           }
+#endif
+	break;
+
+
+    case PLSTATE_CMAP0:
+    case PLSTATE_CMAP1:
+
+#if GD2_VERS >= 2
+       if (!gdImageTrueColor(dev->im_out))
+          {
+#endif
+
+    /*
+     *  Code to redefine the entire palette
+     */
+
+
+	if (pls->color)
+	    setcmap(pls);
+
+#if GD2_VERS >= 2
+}
+#endif
+
+	break;
+    }
+}
+
+
+/*----------------------------------------------------------------------*\
+ * plD_esc_png()
+ *
+ * Escape function.
+\*----------------------------------------------------------------------*/
+
+void plD_esc_png(PLStream *pls, PLINT op, void *ptr)
+{
+    switch (op) {
+
+      case PLESC_FILL:  /* fill */
+	fill_polygon(pls);
+	break;
+
+#ifdef HAVE_FREETYPE
+     case PLESC_HAS_TEXT:
+        plD_render_freetype_text(pls, (EscText *)ptr);
+        break;
+#endif
+
+    }
+}
+
+/*----------------------------------------------------------------------*\
+ * plD_bop_png()
+ *
+ * Set up for the next page.
+ * Advance to next family file if necessary (file output).
+\*----------------------------------------------------------------------*/
+
+void plD_bop_png(PLStream *pls)
+{
+    png_Dev *dev;
+
+    plGetFam(pls);
+/* force new file if pls->family set for all subsequent calls to plGetFam
+ * n.b. putting this after plGetFam call is important since plinit calls
+ * bop, and you don't want the familying sequence started until after
+ * that first call to bop.*/
+
+/* n.b. pls->dev can change because of an indirect call to plD_init_png
+ * from plGetFam if familying is enabled.  Thus, wait to define dev until
+ * now. */
+
+    dev = (png_Dev *) pls->dev;
+
+    pls->famadv = 1;
+
+    pls->page++;
+
+if (dev->black15) plD_black15_gd(pls);
+if (dev->red15) plD_red15_gd(pls);
+
+#if GD2_VERS >= 2
+  if ( ( ((dev->truecolour>0) && (dev->palette>0))||     /* In an EXTREMELY convaluted */
+         ((dev->truecolour==0) && (dev->palette==0))&&   /* manner, all this is just   */
+          ((pls->ncol1+pls->ncol0)<=256) )||             /* asking the question, do we */
+       ( ((dev->palette>0)&&(dev->truecolour==0)) )  )   /* want truecolour or not ?   */
+        {
+#endif
+
+           dev->im_out = gdImageCreate(pls->xlength, pls->ylength);
+
+           setcmap(pls);
+
+#if GD2_VERS >= 2
+         }
+       else
+         {
+         dev->im_out = gdImageCreateTrueColor(pls->xlength, pls->ylength);
+
+/*
+ * In truecolour mode, the background colour GD makes is ALWAYS black, so to
+ * "simulate" (stimulate?) a background colour other than black, we will just
+ * draw a dirty big rectange covering the whole image and colour it in
+ * whatever colour cmap0[0] happens to be.
+ *
+ * Question to C gurus: while it is slightly illogical and ugly, would:
+ *   if ((pls->cmap0[0].r+pls->cmap0[0].g+pls->cmap0[0].b)!=0)
+ * be more computationally efficient than:
+ *   if ((pls->cmap0[0].r!=0)||(pls->cmap0[0].g!=0)||(pls->cmap0[0].b!=0))
+ *  ???
+ */
+
+         if ( (pls->cmap0[0].r!=0)||(pls->cmap0[0].g!=0)||
+              (pls->cmap0[0].b!=0) )
+            {
+             gdImageFilledRectangle(dev->im_out,0,0, pls->xlength-1, pls->ylength-1,
+                                    gdTrueColor(pls->cmap0[0].r,pls->cmap0[0].g,
+                                                pls->cmap0[0].b));
+            }
+
+         }
+
+
+/* This ensures the line width is set correctly at the beginning of
+ *    each page */
+
+   plD_state_png(pls, PLSTATE_WIDTH);
+
+#endif
+
+
+}
+
+/*----------------------------------------------------------------------*\
+ * plD_tidy_png()
+ *
+ * Close graphics file or otherwise clean up.
+\*----------------------------------------------------------------------*/
+
+void plD_tidy_png(PLStream *pls)
+{
+
+#ifdef HAVE_FREETYPE
+   if (pls->dev_text)
+     {
+	FT_Data *FT=(FT_Data *)pls->FT;
+	plscmap0n(FT->ncol0_org);
+	plD_FreeType_Destroy(pls);
+     }
+#endif
+
+   fclose(pls->OutFile);
+   free_mem(pls->dev);
+}
+
+/*----------------------------------------------------------------------*\
+ * plD_black15_gd()
+ *
+ *  This small function simply redefines index 15 of cmap0, which is
+ *  usually set to white, to black, but only if index 0, which is usually
+ *  black, has been redefined to white (for example, through -bg).
+ *
+\*----------------------------------------------------------------------*/
+
+void plD_black15_gd(PLStream *pls)
+{
+
+if (pls->ncol0>15)
+   {
+    if ((pls->cmap0[0].r>227)&&(pls->cmap0[0].g>227)&&(pls->cmap0[0].b>227))
+       {
+        pls->cmap0[15].r=0;
+        pls->cmap0[15].g=0;
+        pls->cmap0[15].b=0;
+      }
+   }
+}
+
+
+/*----------------------------------------------------------------------*\
+ * plD_red15_gd()
+ *
+ *
+ *  This function swaps index 1, often the default plotting colour, with
+ *  index 15, the last defined colour.
+ *
+ *  Colour 15 is usually white, and 1 is usually red, so swapping the two
+ *  might be desirable occasionally, but it is principally here for cases
+ *  when the background has been set on the command line to white, and the
+ *  "def_black15" option has been issued to redefine index 15 as black. By
+ *  issuing a command like
+ *
+ *      ... -bg ffffff -drvopt def_black15,swp_red15
+ *
+ *  the driver will set the background to white, then redefine index 15 of
+ *  cmap0, which is usually white to black, then swap index 2 (red) to 15
+ *  (white originally, now black), so at the end of the day, the "default"
+ *  plotting colour is now black. Why do all of this ? It is a very quick
+ *  way of making a nice web-friendly png without having to redefine the
+ *  cmaps within your program.
+ *
+ *  If you don't like it, don't use it !
+ *
+\*----------------------------------------------------------------------*/
+
+void plD_red15_gd(PLStream *pls)
+{
+char r=pls->cmap0[1].r;
+char g=pls->cmap0[1].g;
+char b=pls->cmap0[1].b;
+
+if (pls->ncol0>15)
+   {
+    pls->cmap0[1].r=pls->cmap0[15].r;
+    pls->cmap0[1].g=pls->cmap0[15].r;
+    pls->cmap0[1].b=pls->cmap0[15].r;
+
+    pls->cmap0[15].r=r;
+    pls->cmap0[15].g=g;
+    pls->cmap0[15].b=b;
+   }
+}
+
+
+/*----------------------------------------------------------------------*\
+ * plD_gd_optimise()
+ *
+ *
+ *  This function pretty much does exactly what it says - it optimises the
+ *  PNG file. It does this by checking to see if all the allocated colours
+ *  were actually used. If they were not, then it deallocates them. This
+ *  function often results in the PNG file being saved as a 4 bit (16
+ *  colour) PNG rather than an 8 bit (256 colour) PNG. The file size
+ *  difference is not huge, not as great as for GIFs for example (I think
+ *  most of the saving comes from removing redundant entries from the
+ *  palette entry in the header); however some modest size savings occur.
+ *
+ *  The function isn't always successful - the optimiser will always
+ *  deallocate unused colours as it finds them, but GD will only deallocate
+ *  them "for real" until 16 colours are used up, and then stop since it
+ *  doesn't make a difference if you have 17 colours or 255 colours. The
+ *  result of this is you may end up with an image using say, 130 colours,
+ *  but you will have 240 colour entries, some of which aren't used, and
+ *  aren't blanked out.
+ *
+ *  Another side-effect of this function is the relative position of the
+ *  colour indices MAY shift as colours are deallocated. I really don't
+ *  think this should worry anyone, but if it does, don't optimise the
+ *  image !
+ *
+\*----------------------------------------------------------------------*/
+
+void plD_gd_optimise(PLStream *pls)
+{
+png_Dev *dev=(png_Dev *)pls->dev;
+int i,j;
+char *bbuf;
+
+bbuf=calloc(256,(size_t) 1);    /* Allocate a buffer to "check off" colours as they are used */
+if (bbuf==NULL) plexit("plD_gd_optimise: Out of memory.");
+
+    for(i=0;i<(pls->xlength-1);i++)        /* Walk through the image pixel by pixel */
+       {                                   /* checking to see what colour it is */
+        for(j=0;j<(pls->ylength-1);j++)    /* and adding it to the list of used colours */
+           {
+            bbuf[gdImagePalettePixel(dev->im_out, i, j)]=1;
+           }
+       }
+
+for (i=0;i<256;i++)     /* next walk over the colours and deallocate */
+    {                   /* unused ones */
+    if (bbuf[i]==0) gdImageColorDeallocate(dev->im_out,i);
+    }
+
+free(bbuf);
+}
+
+
+#ifdef PLD_png
+
+/*----------------------------------------------------------------------*\
+ * plD_eop_png()
+ *
+ * End of page.
+\*----------------------------------------------------------------------*/
+
+void plD_eop_png(PLStream *pls)
+{
+png_Dev *dev=(png_Dev *)pls->dev;
+int i;
+
+    if (pls->family || pls->page == 1) {
+
+   if (dev->optimise)
+     {
+#if GD2_VERS >= 2
+      if ( ( ((dev->truecolour>0) && (dev->palette>0))||     /* In an EXTREMELY convaluted */
+             ((dev->truecolour==0) && (dev->palette==0))&&   /* manner, all this is just   */
+              ((pls->ncol1+pls->ncol0)<=256) )||             /* asking the question, do we */
+           ( ((dev->palette>0)&&(dev->truecolour==0)) )  )   /* want truecolour or not ?   */
+            {
+#endif
+             plD_gd_optimise(pls);
+
+#if GD2_VERS >= 2
+            }
+#endif
+        }
+
+       gdImagePng(dev->im_out, pls->OutFile);
+
+       gdImageDestroy(dev->im_out);
+    }
+}
+
+#endif
+
+#ifdef HAVE_FREETYPE
+
+/*----------------------------------------------------------------------*\
+ *  void plD_pixel_gd (PLStream *pls, short x, short y)
+ *
+ *  callback function, of type "plD_pixel_fp", which specifies how a single
+ *  pixel is set in the current colour.
+\*----------------------------------------------------------------------*/
+
+void plD_pixel_gd (PLStream *pls, short x, short y)
+{
+png_Dev *dev=(png_Dev *)pls->dev;
+
+   gdImageSetPixel(dev->im_out, x, y,dev->colour);
+
+}
+
+/*----------------------------------------------------------------------*\
+ *  void init_freetype_lv1 (PLStream *pls)
+ *
+ *  "level 1" initialisation of the freetype library.
+ *  "Level 1" initialisation calls plD_FreeType_init(pls) which allocates
+ *  memory to the pls->FT structure, then sets up the pixel callback
+ *  function.
+\*----------------------------------------------------------------------*/
+
+static void init_freetype_lv1 (PLStream *pls)
+{
+FT_Data *FT;
+
+plD_FreeType_init(pls);
+
+FT=(FT_Data *)pls->FT;
+FT->pixel= (plD_pixel_fp)plD_pixel_gd;
+
+
+}
+
+/*----------------------------------------------------------------------*\
+ *  void init_freetype_lv2 (PLStream *pls)
+ *
+ *  "Level 2" initialisation of the freetype library.
+ *  "Level 2" fills in a few setting that aren't public until after the
+ *  graphics sub-syetm has been initialised.
+ *  The "level 2" initialisation fills in a few things that are defined
+ *  later in the initialisation process for the GD driver.
+ *
+ *  FT->scale is a scaling factor to convert co-ordinates. This is used by
+ *  the GD and other drivers to scale back a larger virtual page and this
+ *  eliminate the "hidden line removal bug". Set it to 1 if your device
+ *  doesn't have scaling.
+ *
+ *  Some coordinate systems have zero on the bottom, others have zero on
+ *  the top. Freetype does it one way, and most everything else does it the
+ *  other. To make sure everything is working ok, we have to "flip" the
+ *  coordinates, and to do this we need to know how big in the Y dimension
+ *  the page is, and whether we have to invert the page or leave it alone.
+ *
+ *  FT->ymax specifies the size of the page FT->invert_y=1 tells us to
+ *  invert the y-coordinates, FT->invert_y=0 will not invert the
+ *  coordinates.
+\*----------------------------------------------------------------------*/
+
+static void init_freetype_lv2 (PLStream *pls)
+{
+png_Dev *dev=(png_Dev *)pls->dev;
+FT_Data *FT=(FT_Data *)pls->FT;
+
+FT->scale=dev->scale;
+FT->ymax=dev->pngy;
+FT->invert_y=1;
+FT->smooth_text=0;
+
+if (FT->want_smooth_text==1)    /* do we want to at least *try* for smoothing ? */
+   {
+    FT->ncol0_org=pls->ncol0;                                   /* save a copy of the original size of ncol0 */
+    FT->ncol0_xtra=NCOLOURS-(pls->ncol1+pls->ncol0);            /* work out how many free slots we have */
+    FT->ncol0_width=FT->ncol0_xtra/(pls->ncol0-1);              /* find out how many different shades of anti-aliasing we can do */
+    if (FT->ncol0_width>4)     /* are there enough colour slots free for text smoothing ? */
+       {
+        if (FT->ncol0_width>max_number_of_grey_levels_used_in_text_smoothing) 
+           FT->ncol0_width=max_number_of_grey_levels_used_in_text_smoothing;                 /* set a maximum number of shades */
+        plscmap0n(FT->ncol0_org+(FT->ncol0_width*pls->ncol0));      /* redefine the size of cmap0 */
+/* the level manipulations are to turn off the plP_state(PLSTATE_CMAP0)
+ * call in plscmap0 which (a) leads to segfaults since the GD image is
+ * not defined at this point and (b) would be inefficient in any case since
+ * setcmap is always called later (see plD_bop_png) to update the driver
+ * color palette to be consistent with cmap0. */
+         {
+          PLINT level_save;
+          level_save = pls->level;
+          pls->level = 0;
+          pl_set_extended_cmap0(pls, FT->ncol0_width, FT->ncol0_org); /* call the function to add the extra cmap0 entries and calculate stuff */
+          pls->level = level_save;
+         }
+        FT->smooth_text=1;      /* Yippee ! We had success setting up the extended cmap0 */
+      }
+    else
+      plwarn("Insufficient colour slots available in CMAP0 to do text smoothing.");
+   }
+}
+
+#endif
+
+
+#ifdef PLD_jpeg
+
+/*----------------------------------------------------------------------*\
+ * plD_eop_jpeg()
+ *
+ * End of page.
+\*----------------------------------------------------------------------*/
+
+void plD_eop_jpeg(PLStream *pls)
+{
+png_Dev *dev=(png_Dev *)pls->dev;
+int i;
+
+    if (pls->family || pls->page == 1) {
+      gdImageJpeg(dev->im_out, pls->OutFile, pls->dev_compression);
+
+      gdImageDestroy(dev->im_out);
+    }
+}
+
+#endif
+
+/*#endif*/
+
+
+#else
+int
+pldummy_png()
+{
+    return 0;
+}
+
+#endif				/* PNG */
diff --git a/collects/plot/src/all/gd_gd.c b/collects/plot/src/all/gd_gd.c
new file mode 100644
index 0000000000..63b1663b0c
--- /dev/null
+++ b/collects/plot/src/all/gd_gd.c
@@ -0,0 +1,325 @@
+
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+
+#include <stdio.h>
+#include <math.h>
+#include <string.h>
+#include <stdlib.h>
+#include "gd.h"
+
+#define TRUE 1
+#define FALSE 0
+
+/* Exported functions: */
+extern void gdImageGd (gdImagePtr im, FILE * out);
+
+
+/* Use this for commenting out debug-print statements. */
+/* Just use the first '#define' to allow all the prints... */
+/*#define GD2_DBG(s) (s) */
+#define GD2_DBG(s)
+
+/* */
+/* Shared code to read color tables from gd file. */
+/* */
+int
+_gdGetColors (gdIOCtx * in, gdImagePtr im, int gd2xFlag)
+{
+  int i;
+  if (gd2xFlag)
+    {
+      int trueColorFlag;
+      if (!gdGetByte (&trueColorFlag, in))
+	{
+	  goto fail1;
+	}
+      /* 2.0.12: detect bad truecolor .gd files created by pre-2.0.12.
+         Beginning in 2.0.12 truecolor is indicated by the initial 2-byte
+         signature. */
+      if (trueColorFlag != im->trueColor)
+	{
+	  goto fail1;
+	}
+      /* This should have been a word all along */
+      if (!im->trueColor)
+	{
+	  if (!gdGetWord (&im->colorsTotal, in))
+	    {
+	      goto fail1;
+	    }
+	}
+      /* Int to accommodate truecolor single-color transparency */
+      if (!gdGetInt (&im->transparent, in))
+	{
+	  goto fail1;
+	}
+    }
+  else
+    {
+      if (!gdGetByte (&im->colorsTotal, in))
+	{
+	  goto fail1;
+	}
+      if (!gdGetWord (&im->transparent, in))
+	{
+	  goto fail1;
+	}
+      if (im->transparent == 257)
+	{
+	  im->transparent = (-1);
+	}
+    }
+  GD2_DBG (printf
+	   ("Pallette had %d colours (T=%d)\n", im->colorsTotal,
+	    im->transparent));
+  if (im->trueColor)
+    {
+      return TRUE;
+    }
+  for (i = 0; (i < gdMaxColors); i++)
+    {
+      if (!gdGetByte (&im->red[i], in))
+	{
+	  goto fail1;
+	}
+      if (!gdGetByte (&im->green[i], in))
+	{
+	  goto fail1;
+	}
+      if (!gdGetByte (&im->blue[i], in))
+	{
+	  goto fail1;
+	}
+      if (gd2xFlag)
+	{
+	  if (!gdGetByte (&im->alpha[i], in))
+	    {
+	      goto fail1;
+	    }
+	}
+    }
+
+  for (i = 0; (i < im->colorsTotal); i++)
+    {
+      im->open[i] = 0;
+    };
+
+  return TRUE;
+fail1:
+  return FALSE;
+}
+
+/* */
+/* Use the common basic header info to make the image object. */
+/* */
+static gdImagePtr
+_gdCreateFromFile (gdIOCtx * in, int *sx, int *sy)
+{
+  gdImagePtr im;
+  int gd2xFlag = 0;
+  int trueColorFlag = 0;
+  if (!gdGetWord (sx, in))
+    {
+      goto fail1;
+    }
+  if ((*sx == 65535) || (*sx == 65534))
+    {
+      /* This is a gd 2.0 .gd file */
+      gd2xFlag = 1;
+      /* 2.0.12: 65534 signals a truecolor .gd file. 
+         There is a slight redundancy here but we can
+         live with it. */
+      if (*sx == 65534)
+	{
+	  trueColorFlag = 1;
+	}
+      if (!gdGetWord (sx, in))
+	{
+	  goto fail1;
+	}
+    }
+  if (!gdGetWord (sy, in))
+    {
+      goto fail1;
+    }
+
+  GD2_DBG (printf ("Image is %dx%d\n", *sx, *sy));
+  if (trueColorFlag)
+    {
+      im = gdImageCreateTrueColor (*sx, *sy);
+    }
+  else
+    {
+      im = gdImageCreate (*sx, *sy);
+    }
+  if (!_gdGetColors (in, im, gd2xFlag))
+    {
+      goto fail2;
+    }
+
+  return im;
+fail2:
+  gdImageDestroy (im);
+fail1:
+  return 0;
+}
+
+gdImagePtr
+gdImageCreateFromGd (FILE * inFile)
+{
+  gdImagePtr im;
+  gdIOCtx *in;
+
+  in = gdNewFileCtx (inFile);
+  im = gdImageCreateFromGdCtx (in);
+
+  in->gd_free (in);
+
+  return im;
+}
+
+gdImagePtr
+gdImageCreateFromGdCtx (gdIOCtxPtr in)
+{
+  int sx, sy;
+  int x, y;
+  gdImagePtr im;
+
+  /* Read the header */
+  im = _gdCreateFromFile (in, &sx, &sy);
+
+  if (im == NULL)
+    {
+      goto fail1;
+    };
+
+  /* Then the data... */
+  /* 2.0.12: support truecolor properly in .gd as well as in .gd2.
+     Problem reported by Andreas Pfaller. */
+  if (im->trueColor)
+    {
+      for (y = 0; (y < sy); y++)
+	{
+	  for (x = 0; (x < sx); x++)
+	    {
+	      int pix;
+	      if (!gdGetInt (&pix, in))
+		{
+		  goto fail2;
+		}
+	      im->tpixels[y][x] = pix;
+	    }
+	}
+    }
+  else
+    {
+      for (y = 0; (y < sy); y++)
+	{
+	  for (x = 0; (x < sx); x++)
+	    {
+	      int ch;
+	      ch = gdGetC (in);
+	      if (ch == EOF)
+		{
+		  goto fail2;
+		}
+	      /* ROW-MAJOR IN GD 1.3 */
+	      im->pixels[y][x] = ch;
+	    }
+	}
+    }
+  return im;
+
+fail2:
+  gdImageDestroy (im);
+fail1:
+  return 0;
+}
+
+void
+_gdPutColors (gdImagePtr im, gdIOCtx * out)
+{
+  int i;
+
+  gdPutC (im->trueColor, out);
+  if (!im->trueColor)
+    {
+      gdPutWord (im->colorsTotal, out);
+    }
+  gdPutInt (im->transparent, out);
+  if (!im->trueColor)
+    {
+      for (i = 0; (i < gdMaxColors); i++)
+	{
+	  gdPutC ((unsigned char) im->red[i], out);
+	  gdPutC ((unsigned char) im->green[i], out);
+	  gdPutC ((unsigned char) im->blue[i], out);
+	  gdPutC ((unsigned char) im->alpha[i], out);
+	}
+    }
+}
+
+static void
+_gdPutHeader (gdImagePtr im, gdIOCtx * out)
+{
+  /* 65535 indicates this is a gd 2.x .gd file. 
+     2.0.12: 65534 indicates truecolor. */
+  if (im->trueColor)
+    {
+      gdPutWord (65534, out);
+    }
+  else
+    {
+      gdPutWord (65535, out);
+    }
+  gdPutWord (im->sx, out);
+  gdPutWord (im->sy, out);
+
+  _gdPutColors (im, out);
+
+}
+
+static void
+_gdImageGd (gdImagePtr im, gdIOCtx * out)
+{
+  int x, y;
+
+  _gdPutHeader (im, out);
+
+  for (y = 0; (y < im->sy); y++)
+    {
+      for (x = 0; (x < im->sx); x++)
+	{
+	  /* ROW-MAJOR IN GD 1.3 */
+	  if (im->trueColor)
+	    {
+	      gdPutInt (im->tpixels[y][x], out);
+	    }
+	  else
+	    {
+	      gdPutC ((unsigned char) im->pixels[y][x], out);
+	    }
+	}
+    }
+}
+
+void
+gdImageGd (gdImagePtr im, FILE * outFile)
+{
+  gdIOCtx *out = gdNewFileCtx (outFile);
+  _gdImageGd (im, out);
+  out->gd_free (out);
+}
+
+void *
+gdImageGdPtr (gdImagePtr im, int *size)
+{
+  void *rv;
+  gdIOCtx *out = gdNewDynamicCtx (2048, NULL);
+  _gdImageGd (im, out);
+  rv = gdDPExtractData (out, size);
+  out->gd_free (out);
+  return rv;
+}
diff --git a/collects/plot/src/all/gd_gd2.c b/collects/plot/src/all/gd_gd2.c
new file mode 100644
index 0000000000..ab6af3da3e
--- /dev/null
+++ b/collects/plot/src/all/gd_gd2.c
@@ -0,0 +1,1016 @@
+/*
+   * gd_gd2.c
+   *
+   * Implements the I/O and support for the GD2 format.
+   *
+   * Changing the definition of GD2_DBG (below) will cause copious messages
+   * to be displayed while it processes requests.
+   *
+   * Designed, Written & Copyright 1999, Philip Warner.
+   *
+ */
+
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+
+#include <stdio.h>
+#include <errno.h>
+#include <math.h>
+#include <string.h>
+#include <stdlib.h>
+#include "gd.h"
+#include "gdhelpers.h"
+
+/* 2.03: gd2 is no longer mandatory */
+/* JCE - test after including gd.h so that HAVE_LIBZ can be set in
+ * a config.h file included by gd.h */
+#ifdef HAVE_LIBZ
+#include <zlib.h>
+
+#define TRUE 1
+#define FALSE 0
+
+/* 2.11: not part of the API, as the save routine can figure it out
+	from im->trueColor, and the load routine doesn't need to tell
+	the end user the saved format. NOTE: adding 2 is assumed
+	to result in the correct format value for truecolor! */
+#define GD2_FMT_TRUECOLOR_RAW 3
+#define GD2_FMT_TRUECOLOR_COMPRESSED 4
+
+#define gd2_compressed(fmt) (((fmt) == GD2_FMT_COMPRESSED) || \
+	((fmt) == GD2_FMT_TRUECOLOR_COMPRESSED))
+
+#define gd2_truecolor(fmt) (((fmt) == GD2_FMT_TRUECOLOR_RAW) || \
+	((fmt) == GD2_FMT_TRUECOLOR_COMPRESSED))
+
+/* Use this for commenting out debug-print statements. */
+/* Just use the first '#define' to allow all the prints... */
+/*#define GD2_DBG(s) (s) */
+#define GD2_DBG(s)
+
+typedef struct
+{
+  int offset;
+  int size;
+}
+t_chunk_info;
+
+extern int _gdGetColors (gdIOCtx * in, gdImagePtr im, int gd2xFlag);
+extern void _gdPutColors (gdImagePtr im, gdIOCtx * out);
+
+/* */
+/* Read the extra info in the gd2 header. */
+/* */
+static int
+_gd2GetHeader (gdIOCtxPtr in, int *sx, int *sy,
+	       int *cs, int *vers, int *fmt, int *ncx, int *ncy,
+	       t_chunk_info ** chunkIdx)
+{
+  int i;
+  int ch;
+  char id[5];
+  t_chunk_info *cidx;
+  int sidx;
+  int nc;
+
+  GD2_DBG (printf ("Reading gd2 header info\n"));
+
+  for (i = 0; i < 4; i++)
+    {
+      ch = gdGetC (in);
+      if (ch == EOF)
+	{
+	  goto fail1;
+	};
+      id[i] = ch;
+    };
+  id[4] = 0;
+
+  GD2_DBG (printf ("Got file code: %s\n", id));
+
+  /* Equiv. of 'magick'.  */
+  if (strcmp (id, GD2_ID) != 0)
+    {
+      GD2_DBG (printf ("Not a valid gd2 file\n"));
+      goto fail1;
+    };
+
+  /* Version */
+  if (gdGetWord (vers, in) != 1)
+    {
+      goto fail1;
+    };
+  GD2_DBG (printf ("Version: %d\n", *vers));
+
+  if ((*vers != 1) && (*vers != 2))
+    {
+      GD2_DBG (printf ("Bad version: %d\n", *vers));
+      goto fail1;
+    };
+
+  /* Image Size */
+  if (!gdGetWord (sx, in))
+    {
+      GD2_DBG (printf ("Could not get x-size\n"));
+      goto fail1;
+    }
+  if (!gdGetWord (sy, in))
+    {
+      GD2_DBG (printf ("Could not get y-size\n"));
+      goto fail1;
+    }
+  GD2_DBG (printf ("Image is %dx%d\n", *sx, *sy));
+
+  /* Chunk Size (pixels, not bytes!) */
+  if (gdGetWord (cs, in) != 1)
+    {
+      goto fail1;
+    };
+  GD2_DBG (printf ("ChunkSize: %d\n", *cs));
+
+  if ((*cs < GD2_CHUNKSIZE_MIN) || (*cs > GD2_CHUNKSIZE_MAX))
+    {
+      GD2_DBG (printf ("Bad chunk size: %d\n", *cs));
+      goto fail1;
+    };
+
+  /* Data Format */
+  if (gdGetWord (fmt, in) != 1)
+    {
+      goto fail1;
+    };
+  GD2_DBG (printf ("Format: %d\n", *fmt));
+
+  if ((*fmt != GD2_FMT_RAW) && (*fmt != GD2_FMT_COMPRESSED) &&
+      (*fmt != GD2_FMT_TRUECOLOR_RAW) &&
+      (*fmt != GD2_FMT_TRUECOLOR_COMPRESSED))
+    {
+      GD2_DBG (printf ("Bad data format: %d\n", *fmt));
+      goto fail1;
+    };
+
+
+  /* # of chunks wide */
+  if (gdGetWord (ncx, in) != 1)
+    {
+      goto fail1;
+    };
+  GD2_DBG (printf ("%d Chunks Wide\n", *ncx));
+
+  /* # of chunks high */
+  if (gdGetWord (ncy, in) != 1)
+    {
+      goto fail1;
+    };
+  GD2_DBG (printf ("%d Chunks vertically\n", *ncy));
+
+  if (gd2_compressed (*fmt))
+    {
+      nc = (*ncx) * (*ncy);
+      GD2_DBG (printf ("Reading %d chunk index entries\n", nc));
+      sidx = sizeof (t_chunk_info) * nc;
+      cidx = gdCalloc (sidx, 1);
+      for (i = 0; i < nc; i++)
+	{
+	  if (gdGetInt (&cidx[i].offset, in) != 1)
+	    {
+	      goto fail1;
+	    };
+	  if (gdGetInt (&cidx[i].size, in) != 1)
+	    {
+	      goto fail1;
+	    };
+	};
+      *chunkIdx = cidx;
+    };
+
+  GD2_DBG (printf ("gd2 header complete\n"));
+
+  return 1;
+
+fail1:
+  return 0;
+}
+
+static gdImagePtr
+_gd2CreateFromFile (gdIOCtxPtr in, int *sx, int *sy,
+		    int *cs, int *vers, int *fmt,
+		    int *ncx, int *ncy, t_chunk_info ** cidx)
+{
+  gdImagePtr im;
+
+  if (_gd2GetHeader (in, sx, sy, cs, vers, fmt, ncx, ncy, cidx) != 1)
+    {
+      GD2_DBG (printf ("Bad GD2 header\n"));
+      goto fail1;
+    }
+  if (gd2_truecolor (*fmt))
+    {
+      im = gdImageCreateTrueColor (*sx, *sy);
+    }
+  else
+    {
+      im = gdImageCreate (*sx, *sy);
+    }
+  if (im == NULL)
+    {
+      GD2_DBG (printf ("Could not create gdImage\n"));
+      goto fail1;
+    };
+
+  if (!_gdGetColors (in, im, (*vers) == 2))
+    {
+      GD2_DBG (printf ("Could not read color palette\n"));
+      goto fail2;
+    }
+  GD2_DBG (printf ("Image palette completed: %d colours\n", im->colorsTotal));
+
+  return im;
+
+fail2:
+  gdImageDestroy (im);
+  return 0;
+
+fail1:
+  return 0;
+
+}
+
+static int
+_gd2ReadChunk (int offset, char *compBuf, int compSize, char *chunkBuf,
+	       uLongf * chunkLen, gdIOCtx * in)
+{
+  int zerr;
+
+  if (gdTell (in) != offset)
+    {
+      GD2_DBG (printf ("Positioning in file to %d\n", offset));
+      gdSeek (in, offset);
+    }
+  else
+    {
+      GD2_DBG (printf ("Already Positioned in file to %d\n", offset));
+    };
+
+  /* Read and uncompress an entire chunk. */
+  GD2_DBG (printf ("Reading file\n"));
+  if (gdGetBuf (compBuf, compSize, in) != compSize)
+    {
+      return FALSE;
+    };
+  GD2_DBG (printf
+	   ("Got %d bytes. Uncompressing into buffer of %d bytes\n", compSize,
+	    *chunkLen));
+  zerr =
+    uncompress ((unsigned char *) chunkBuf, chunkLen,
+		(unsigned char *) compBuf, compSize);
+  if (zerr != Z_OK)
+    {
+      GD2_DBG (printf ("Error %d from uncompress\n", zerr));
+      return FALSE;
+    };
+  GD2_DBG (printf ("Got chunk\n"));
+  return TRUE;
+}
+
+gdImagePtr
+gdImageCreateFromGd2 (FILE * inFile)
+{
+  gdIOCtx *in = gdNewFileCtx (inFile);
+  gdImagePtr im;
+
+  im = gdImageCreateFromGd2Ctx (in);
+
+  in->gd_free (in);
+
+  return im;
+}
+
+gdImagePtr
+gdImageCreateFromGd2Ctx (gdIOCtxPtr in)
+{
+  int sx, sy;
+  int i;
+  int ncx, ncy, nc, cs, cx, cy;
+  int x, y, ylo, yhi, xlo, xhi;
+  int vers, fmt;
+  t_chunk_info *chunkIdx = NULL;	/* So we can gdFree it with impunity. */
+  unsigned char *chunkBuf = NULL;	/* So we can gdFree it with impunity. */
+  int chunkNum = 0;
+  int chunkMax = 0;
+  uLongf chunkLen;
+  int chunkPos = 0;
+  int compMax = 0;
+  int bytesPerPixel;
+  char *compBuf = NULL;		/* So we can gdFree it with impunity. */
+
+  gdImagePtr im;
+
+  /* Get the header */
+  im =
+    _gd2CreateFromFile (in, &sx, &sy, &cs, &vers, &fmt, &ncx, &ncy,
+			&chunkIdx);
+
+  if (im == NULL)
+    {
+      return 0;
+    };
+  bytesPerPixel = im->trueColor ? 4 : 1;
+  nc = ncx * ncy;
+
+  if (gd2_compressed (fmt))
+    {
+      /* Find the maximum compressed chunk size. */
+      compMax = 0;
+      for (i = 0; (i < nc); i++)
+	{
+	  if (chunkIdx[i].size > compMax)
+	    {
+	      compMax = chunkIdx[i].size;
+	    };
+	};
+      compMax++;
+
+      /* Allocate buffers */
+      chunkMax = cs * bytesPerPixel * cs;
+      chunkBuf = gdCalloc (chunkMax, 1);
+      compBuf = gdCalloc (compMax, 1);
+      GD2_DBG (printf ("Largest compressed chunk is %d bytes\n", compMax));
+    };
+
+/*      if ( (ncx != sx / cs) || (ncy != sy / cs)) { */
+/*              goto fail2; */
+/*      }; */
+
+  /* Read the data... */
+  for (cy = 0; (cy < ncy); cy++)
+    {
+      for (cx = 0; (cx < ncx); cx++)
+	{
+
+	  ylo = cy * cs;
+	  yhi = ylo + cs;
+	  if (yhi > im->sy)
+	    {
+	      yhi = im->sy;
+	    };
+
+	  GD2_DBG (printf
+		   ("Processing Chunk %d (%d, %d), y from %d to %d\n",
+		    chunkNum, cx, cy, ylo, yhi));
+
+	  if (gd2_compressed (fmt))
+	    {
+
+	      chunkLen = chunkMax;
+
+	      if (!_gd2ReadChunk (chunkIdx[chunkNum].offset,
+				  compBuf,
+				  chunkIdx[chunkNum].size,
+				  (char *) chunkBuf, &chunkLen, in))
+		{
+		  GD2_DBG (printf ("Error reading comproessed chunk\n"));
+		  goto fail2;
+		};
+
+	      chunkPos = 0;
+	    };
+
+	  for (y = ylo; (y < yhi); y++)
+	    {
+
+	      xlo = cx * cs;
+	      xhi = xlo + cs;
+	      if (xhi > im->sx)
+		{
+		  xhi = im->sx;
+		};
+	      /*GD2_DBG(printf("y=%d: ",y)); */
+	      if (!gd2_compressed (fmt))
+		{
+		  for (x = xlo; x < xhi; x++)
+		    {
+
+		      if (im->trueColor)
+			{
+			  if (!gdGetInt (&im->tpixels[y][x], in))
+			    {
+			      /*printf("EOF while reading\n"); */
+			      /*gdImageDestroy(im); */
+			      /*return 0; */
+			      im->tpixels[y][x] = 0;
+			    }
+			}
+		      else
+			{
+			  int ch;
+			  if (!gdGetByte (&ch, in))
+			    {
+			      /*printf("EOF while reading\n"); */
+			      /*gdImageDestroy(im); */
+			      /*return 0; */
+			      ch = 0;
+			    }
+			  im->pixels[y][x] = ch;
+			}
+		    }
+		}
+	      else
+		{
+		  for (x = xlo; x < xhi; x++)
+		    {
+		      if (im->trueColor)
+			{
+			  /* 2.0.1: work around a gcc bug by being verbose.
+			     TBB */
+			  int a = chunkBuf[chunkPos++] << 24;
+			  int r = chunkBuf[chunkPos++] << 16;
+			  int g = chunkBuf[chunkPos++] << 8;
+			  int b = chunkBuf[chunkPos++];
+			  /* 2.0.11: tpixels */
+			  im->tpixels[y][x] = a + r + g + b;
+			}
+		      else
+			{
+			  im->pixels[y][x] = chunkBuf[chunkPos++];
+			}
+		    };
+		};
+	      /*GD2_DBG(printf("\n")); */
+	    };
+	  chunkNum++;
+	};
+    };
+
+  GD2_DBG (printf ("Freeing memory\n"));
+
+  gdFree (chunkBuf);
+  gdFree (compBuf);
+  gdFree (chunkIdx);
+
+  GD2_DBG (printf ("Done\n"));
+
+  return im;
+
+fail2:
+  gdImageDestroy (im);
+  gdFree (chunkBuf);
+  gdFree (compBuf);
+  gdFree (chunkIdx);
+  return 0;
+
+}
+
+gdImagePtr
+gdImageCreateFromGd2Part (FILE * inFile, int srcx, int srcy, int w, int h)
+{
+  gdImagePtr im;
+  gdIOCtx *in = gdNewFileCtx (inFile);
+
+  im = gdImageCreateFromGd2PartCtx (in, srcx, srcy, w, h);
+
+  in->gd_free (in);
+
+  return im;
+}
+
+gdImagePtr
+gdImageCreateFromGd2PartCtx (gdIOCtx * in, int srcx, int srcy, int w, int h)
+{
+  int scx, scy, ecx, ecy, fsx, fsy;
+  int nc, ncx, ncy, cs, cx, cy;
+  int x, y, ylo, yhi, xlo, xhi;
+  int dstart, dpos;
+  int i;
+  /* 2.0.12: unsigned is correct; fixes problems with color munging.
+     Thanks to Steven Brown. */
+  unsigned int ch;
+  int vers, fmt;
+  t_chunk_info *chunkIdx = NULL;
+  unsigned char *chunkBuf = NULL;
+  int chunkNum;
+  int chunkMax = 0;
+  uLongf chunkLen;
+  int chunkPos = 0;
+  int compMax;
+  char *compBuf = NULL;
+
+  gdImagePtr im;
+
+  /* */
+  /* The next few lines are basically copied from gd2CreateFromFile */
+  /* - we change the file size, so don't want to use the code directly. */
+  /*   but we do need to know the file size. */
+  /* */
+  if (_gd2GetHeader (in, &fsx, &fsy, &cs, &vers, &fmt, &ncx, &ncy, &chunkIdx)
+      != 1)
+    {
+      goto fail1;
+    }
+
+  GD2_DBG (printf ("File size is %dx%d\n", fsx, fsy));
+
+  /* This is the difference - make a file based on size of chunks. */
+  if (gd2_truecolor (fmt))
+    {
+      im = gdImageCreateTrueColor (w, h);
+    }
+  else
+    {
+      im = gdImageCreate (w, h);
+    }
+  if (im == NULL)
+    {
+      goto fail1;
+    };
+
+  if (!_gdGetColors (in, im, vers == 2))
+    {
+      goto fail2;
+    }
+  GD2_DBG (printf ("Image palette completed: %d colours\n", im->colorsTotal));
+
+  /* Process the header info */
+  nc = ncx * ncy;
+
+  if (gd2_compressed (fmt))
+    {
+      /* Find the maximum compressed chunk size. */
+      compMax = 0;
+      for (i = 0; (i < nc); i++)
+	{
+	  if (chunkIdx[i].size > compMax)
+	    {
+	      compMax = chunkIdx[i].size;
+	    };
+	};
+      compMax++;
+
+      if (im->trueColor)
+	{
+	  chunkMax = cs * cs * 4;
+	}
+      else
+	{
+	  chunkMax = cs * cs;
+	}
+      chunkBuf = gdCalloc (chunkMax, 1);
+      compBuf = gdCalloc (compMax, 1);
+    };
+
+/*      Don't bother with this... */
+/*      if ( (ncx != sx / cs) || (ncy != sy / cs)) { */
+/*              goto fail2; */
+/*      }; */
+
+
+  /* Work out start/end chunks */
+  scx = srcx / cs;
+  scy = srcy / cs;
+  if (scx < 0)
+    {
+      scx = 0;
+    };
+  if (scy < 0)
+    {
+      scy = 0;
+    };
+
+  ecx = (srcx + w) / cs;
+  ecy = (srcy + h) / cs;
+  if (ecx >= ncx)
+    {
+      ecx = ncx - 1;
+    };
+  if (ecy >= ncy)
+    {
+      ecy = ncy - 1;
+    };
+
+  /* Remember file position of image data. */
+  dstart = gdTell (in);
+  GD2_DBG (printf ("Data starts at %d\n", dstart));
+
+  /* Loop through the chunks. */
+  for (cy = scy; (cy <= ecy); cy++)
+    {
+
+      ylo = cy * cs;
+      yhi = ylo + cs;
+      if (yhi > fsy)
+	{
+	  yhi = fsy;
+	};
+
+      for (cx = scx; (cx <= ecx); cx++)
+	{
+
+	  xlo = cx * cs;
+	  xhi = xlo + cs;
+	  if (xhi > fsx)
+	    {
+	      xhi = fsx;
+	    };
+
+	  GD2_DBG (printf
+		   ("Processing Chunk (%d, %d), from %d to %d\n", cx, cy, ylo,
+		    yhi));
+
+	  if (!gd2_compressed (fmt))
+	    {
+	      GD2_DBG (printf ("Using raw format data\n"));
+	      if (im->trueColor)
+		{
+		  dpos =
+		    (cy * (cs * fsx) * 4 + cx * cs * (yhi - ylo) * 4) +
+		    dstart;
+		}
+	      else
+		{
+		  dpos = cy * (cs * fsx) + cx * cs * (yhi - ylo) + dstart;
+		}
+	      /* gd 2.0.11: gdSeek returns TRUE on success, not 0.
+	         Longstanding bug. 01/16/03 */
+	      if (!gdSeek (in, dpos))
+		{
+		  printf ("Error from seek: %d\n", errno);
+		  goto fail2;
+		};
+	      GD2_DBG (printf
+		       ("Reading (%d, %d) from position %d\n", cx, cy,
+			dpos - dstart));
+	    }
+	  else
+	    {
+	      chunkNum = cx + cy * ncx;
+
+	      chunkLen = chunkMax;
+	      if (!_gd2ReadChunk (chunkIdx[chunkNum].offset,
+				  compBuf,
+				  chunkIdx[chunkNum].size,
+				  (char*) chunkBuf, &chunkLen, in))
+		{
+		  printf ("Error reading comproessed chunk\n");
+		  goto fail2;
+		};
+	      chunkPos = 0;
+	      GD2_DBG (printf
+		       ("Reading (%d, %d) from chunk %d\n", cx, cy,
+			chunkNum));
+	    };
+
+	  GD2_DBG (printf
+		   ("   into (%d, %d) - (%d, %d)\n", xlo, ylo, xhi, yhi));
+	  for (y = ylo; (y < yhi); y++)
+	    {
+
+	      for (x = xlo; x < xhi; x++)
+		{
+		  if (!gd2_compressed (fmt))
+		    {
+		      if (im->trueColor)
+			{
+			  if (!gdGetInt ( (int*) &ch, in))
+			    {
+			      ch = 0;
+			      /*printf("EOF while reading file\n"); */
+			      /*goto fail2; */
+			    }
+			}
+		      else
+			{
+			  ch = gdGetC (in);
+			  if (ch == EOF)
+			    {
+			      ch = 0;
+			      /*printf("EOF while reading file\n"); */
+			      /*goto fail2; */
+			    }
+			}
+		    }
+		  else
+		    {
+		      if (im->trueColor)
+			{
+			  ch = chunkBuf[chunkPos++];
+			  ch = (ch << 8) + chunkBuf[chunkPos++];
+			  ch = (ch << 8) + chunkBuf[chunkPos++];
+			  ch = (ch << 8) + chunkBuf[chunkPos++];
+			}
+		      else
+			{
+			  ch = chunkBuf[chunkPos++];
+			}
+		    };
+
+		  /* Only use a point that is in the image. */
+		  if ((x >= srcx) && (x < (srcx + w)) && (x < fsx) && (x >= 0)
+		      && (y >= srcy) && (y < (srcy + h)) && (y < fsy)
+		      && (y >= 0))
+		    {
+		      /* 2.0.11: tpixels */
+		      if (im->trueColor)
+			{
+			  im->tpixels[y - srcy][x - srcx] = ch;
+			}
+		      else
+			{
+			  im->pixels[y - srcy][x - srcx] = ch;
+			}
+		    }
+		};
+	    };
+	};
+    };
+
+  gdFree (chunkBuf);
+  gdFree (compBuf);
+  gdFree (chunkIdx);
+
+  return im;
+
+fail2:
+  gdImageDestroy (im);
+fail1:
+  gdFree (chunkBuf);
+  gdFree (compBuf);
+  gdFree (chunkIdx);
+
+  return 0;
+
+}
+
+static void
+_gd2PutHeader (gdImagePtr im, gdIOCtx * out, int cs, int fmt, int cx, int cy)
+{
+  int i;
+
+  /* Send the gd2 id, to verify file format. */
+  for (i = 0; i < 4; i++)
+    {
+      gdPutC ((unsigned char) (GD2_ID[i]), out);
+    };
+
+  /* */
+  /* We put the version info first, so future versions can easily change header info. */
+  /* */
+  gdPutWord (GD2_VERS, out);
+  gdPutWord (im->sx, out);
+  gdPutWord (im->sy, out);
+  gdPutWord (cs, out);
+  gdPutWord (fmt, out);
+  gdPutWord (cx, out);
+  gdPutWord (cy, out);
+
+}
+
+static void
+_gdImageGd2 (gdImagePtr im, gdIOCtx * out, int cs, int fmt)
+{
+  int ncx, ncy, cx, cy;
+  int x, y, ylo, yhi, xlo, xhi;
+  int chunkLen;
+  int chunkNum = 0;
+  char *chunkData = NULL;	/* So we can gdFree it with impunity. */
+  char *compData = NULL;	/* So we can gdFree it with impunity. */
+  uLongf compLen;
+  int idxPos = 0;
+  int idxSize;
+  t_chunk_info *chunkIdx = NULL;
+  int posSave;
+  int bytesPerPixel = im->trueColor ? 4 : 1;
+  int compMax = 0;
+
+  /*printf("Trying to write GD2 file\n"); */
+
+  /* */
+  /* Force fmt to a valid value since we don't return anything. */
+  /* */
+  if ((fmt != GD2_FMT_RAW) && (fmt != GD2_FMT_COMPRESSED))
+    {
+      fmt = im->trueColor ? GD2_FMT_TRUECOLOR_COMPRESSED : GD2_FMT_COMPRESSED;
+    };
+  if (im->trueColor)
+    {
+      fmt += 2;
+    }
+  /* */
+  /* Make sure chunk size is valid. These are arbitrary values; 64 because it seems */
+  /* a little silly to expect performance improvements on a 64x64 bit scale, and  */
+  /* 4096 because we buffer one chunk, and a 16MB buffer seems a little large - it may be */
+  /* OK for one user, but for another to read it, they require the buffer. */
+  /* */
+  if (cs == 0)
+    {
+      cs = GD2_CHUNKSIZE;
+    }
+  else if (cs < GD2_CHUNKSIZE_MIN)
+    {
+      cs = GD2_CHUNKSIZE_MIN;
+    }
+  else if (cs > GD2_CHUNKSIZE_MAX)
+    {
+      cs = GD2_CHUNKSIZE_MAX;
+    };
+
+  /* Work out number of chunks. */
+  ncx = im->sx / cs + 1;
+  ncy = im->sy / cs + 1;
+
+  /* Write the standard header. */
+  _gd2PutHeader (im, out, cs, fmt, ncx, ncy);
+
+  if (gd2_compressed (fmt))
+    {
+      /* */
+      /* Work out size of buffer for compressed data, If CHUNKSIZE is large, */
+      /* then these will be large! */
+      /* */
+      /* The zlib notes say output buffer size should be (input size) * 1.01 * 12 */
+      /* - we'll use 1.02 to be paranoid. */
+      /* */
+      compMax = cs * bytesPerPixel * cs * 1.02 + 12;
+
+      /* */
+      /* Allocate the buffers.  */
+      /* */
+      chunkData = gdCalloc (cs * bytesPerPixel * cs, 1);
+      compData = gdCalloc (compMax, 1);
+
+      /* */
+      /* Save the file position of chunk index, and allocate enough space for */
+      /* each chunk_info block . */
+      /* */
+      idxPos = gdTell (out);
+      idxSize = ncx * ncy * sizeof (t_chunk_info);
+      GD2_DBG (printf ("Index size is %d\n", idxSize));
+      gdSeek (out, idxPos + idxSize);
+
+      chunkIdx = gdCalloc (idxSize * sizeof (t_chunk_info), 1);
+    };
+
+  _gdPutColors (im, out);
+
+  GD2_DBG (printf ("Size: %dx%d\n", im->sx, im->sy));
+  GD2_DBG (printf ("Chunks: %dx%d\n", ncx, ncy));
+
+  for (cy = 0; (cy < ncy); cy++)
+    {
+      for (cx = 0; (cx < ncx); cx++)
+	{
+
+	  ylo = cy * cs;
+	  yhi = ylo + cs;
+	  if (yhi > im->sy)
+	    {
+	      yhi = im->sy;
+	    };
+
+	  GD2_DBG (printf
+		   ("Processing Chunk (%dx%d), y from %d to %d\n", cx, cy,
+		    ylo, yhi));
+	  chunkLen = 0;
+	  for (y = ylo; (y < yhi); y++)
+	    {
+
+	      /*GD2_DBG(printf("y=%d: ",y)); */
+
+	      xlo = cx * cs;
+	      xhi = xlo + cs;
+	      if (xhi > im->sx)
+		{
+		  xhi = im->sx;
+		};
+
+	      if (gd2_compressed (fmt))
+		{
+		  for (x = xlo; x < xhi; x++)
+		    {
+		      /* 2.0.11: use truecolor pixel array. TBB */
+		      /*GD2_DBG(printf("%d...",x)); */
+		      if (im->trueColor)
+			{
+			  int p = im->tpixels[y][x];
+			  chunkData[chunkLen++] = gdTrueColorGetAlpha (p);
+			  chunkData[chunkLen++] = gdTrueColorGetRed (p);
+			  chunkData[chunkLen++] = gdTrueColorGetGreen (p);
+			  chunkData[chunkLen++] = gdTrueColorGetBlue (p);
+			}
+		      else
+			{
+			  int p = im->pixels[y][x];
+			  chunkData[chunkLen++] = p;
+			}
+		    };
+		}
+	      else
+		{
+		  for (x = xlo; x < xhi; x++)
+		    {
+		      /*GD2_DBG(printf("%d, ",x)); */
+
+		      if (im->trueColor)
+			{
+			  gdPutInt (im->tpixels[y][x], out);
+			}
+		      else
+			{
+			  gdPutC ((unsigned char) im->pixels[y][x], out);
+			}
+		    };
+		};
+	      /*GD2_DBG(printf("y=%d done.\n",y)); */
+	    };
+	  if (gd2_compressed (fmt))
+	    {
+	      compLen = compMax;
+	      if (compress ((unsigned char *)
+			    &compData[0], &compLen,
+			    (unsigned char *) &chunkData[0],
+			    chunkLen) != Z_OK)
+		{
+		  printf ("Error from compressing\n");
+		}
+	      else
+		{
+		  chunkIdx[chunkNum].offset = gdTell (out);
+		  chunkIdx[chunkNum++].size = compLen;
+		  GD2_DBG (printf
+			   ("Chunk %d size %d offset %d\n", chunkNum,
+			    chunkIdx[chunkNum - 1].size,
+			    chunkIdx[chunkNum - 1].offset));
+
+		  if (gdPutBuf (compData, compLen, out) <= 0)
+		    {
+		      /* Any alternate suggestions for handling this? */
+		      printf ("Error %d on write\n", errno);
+		    };
+		};
+	    };
+	};
+    };
+  if (gd2_compressed (fmt))
+    {
+      /* Save the position, write the index, restore position (paranoia). */
+      GD2_DBG (printf ("Seeking %d to write index\n", idxPos));
+      posSave = gdTell (out);
+      gdSeek (out, idxPos);
+      GD2_DBG (printf ("Writing index\n"));
+      for (x = 0; x < chunkNum; x++)
+	{
+	  GD2_DBG (printf
+		   ("Chunk %d size %d offset %d\n", x, chunkIdx[x].size,
+		    chunkIdx[x].offset));
+	  gdPutInt (chunkIdx[x].offset, out);
+	  gdPutInt (chunkIdx[x].size, out);
+	};
+      /* We don't use fwrite for *endian reasons. */
+      /*fwrite(chunkIdx, sizeof(int)*2, chunkNum, out); */
+      gdSeek (out, posSave);
+    };
+
+  GD2_DBG (printf ("Freeing memory\n"));
+  gdFree (chunkData);
+  gdFree (compData);
+  gdFree (chunkIdx);
+  GD2_DBG (printf ("Done\n"));
+
+  /*printf("Memory block size is %d\n",gdTell(out)); */
+
+}
+
+void
+gdImageGd2 (gdImagePtr im, FILE * outFile, int cs, int fmt)
+{
+  gdIOCtx *out = gdNewFileCtx (outFile);
+  _gdImageGd2 (im, out, cs, fmt);
+  out->gd_free (out);
+}
+
+void *
+gdImageGd2Ptr (gdImagePtr im, int cs, int fmt, int *size)
+{
+  void *rv;
+  gdIOCtx *out = gdNewDynamicCtx (2048, NULL);
+  _gdImageGd2 (im, out, cs, fmt);
+  rv = gdDPExtractData (out, size);
+  out->gd_free (out);
+  return rv;
+}
+
+#else /* no HAVE_LIBZ */
+gdImagePtr
+gdImageCreateFromGd2 (FILE * inFile)
+{
+  fprintf (stderr, "GD2 support is not available - no libz\n");
+  return NULL;
+}
+
+gdImagePtr
+gdImageCreateFromGd2Ctx (gdIOCtxPtr in)
+{
+  fprintf (stderr, "GD2 support is not available - no libz\n");
+  return NULL;
+}
+#endif /* HAVE_LIBZ */
diff --git a/collects/plot/src/all/gd_io.c b/collects/plot/src/all/gd_io.c
new file mode 100644
index 0000000000..5848fd9ddd
--- /dev/null
+++ b/collects/plot/src/all/gd_io.c
@@ -0,0 +1,179 @@
+
+
+/*
+   * io.c
+   *
+   * Implements the imple I/O 'helper' routines.
+   *
+   * Not really essential, but these routines were used extensively in GD,
+   * so they were moved here. They also make IOCtx calls look better...
+   *
+   * Written (or, at least, moved) 1999, Philip Warner.
+   *
+ */
+
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+
+#include <math.h>
+#include <string.h>
+#include <stdlib.h>
+#include "gd.h"
+
+/* Use this for commenting out debug-print statements. */
+/* Just use the first '#define' to allow all the prints... */
+/*#define IO_DBG(s) (s) */
+#define IO_DBG(s)
+
+
+/*
+ * Write out a word to the I/O context pointer
+ */
+void
+Putword (int w, gdIOCtx * ctx)
+{
+  unsigned char buf[2];
+  buf[0] = w & 0xff;
+  buf[1] = (w / 256) & 0xff;
+  (ctx->putBuf) (ctx, (char *) buf, 2);
+}
+
+void
+Putchar (int c, gdIOCtx * ctx)
+{
+  (ctx->putC) (ctx, c & 0xff);
+}
+
+void
+gdPutC (const unsigned char c, gdIOCtx * ctx)
+{
+  (ctx->putC) (ctx, c);
+}
+
+void
+gdPutWord (int w, gdIOCtx * ctx)
+{
+  IO_DBG (printf ("Putting word...\n"));
+  (ctx->putC) (ctx, (unsigned char) (w >> 8));
+  (ctx->putC) (ctx, (unsigned char) (w & 0xFF));
+  IO_DBG (printf ("put.\n"));
+}
+
+void
+gdPutInt (int w, gdIOCtx * ctx)
+{
+  IO_DBG (printf ("Putting int...\n"));
+  (ctx->putC) (ctx, (unsigned char) (w >> 24));
+  (ctx->putC) (ctx, (unsigned char) ((w >> 16) & 0xFF));
+  (ctx->putC) (ctx, (unsigned char) ((w >> 8) & 0xFF));
+  (ctx->putC) (ctx, (unsigned char) (w & 0xFF));
+  IO_DBG (printf ("put.\n"));
+}
+
+int
+gdGetC (gdIOCtx * ctx)
+{
+  return ((ctx->getC) (ctx));
+}
+
+
+
+int
+gdGetByte (int *result, gdIOCtx * ctx)
+{
+  int r;
+  r = (ctx->getC) (ctx);
+  if (r == EOF)
+    {
+      return 0;
+    }
+  *result = r;
+  return 1;
+}
+
+int
+gdGetWord (int *result, gdIOCtx * ctx)
+{
+  int r;
+  r = (ctx->getC) (ctx);
+  if (r == EOF)
+    {
+      return 0;
+    }
+  *result = r << 8;
+  r = (ctx->getC) (ctx);
+  if (r == EOF)
+    {
+      return 0;
+    }
+  *result += r;
+  return 1;
+}
+
+
+int
+gdGetInt (int *result, gdIOCtx * ctx)
+{
+  int r;
+  r = (ctx->getC) (ctx);
+  if (r == EOF)
+    {
+      return 0;
+    }
+  *result = r << 24;
+
+  r = (ctx->getC) (ctx);
+  if (r == EOF)
+    {
+      return 0;
+    }
+  *result += r << 16;
+
+  r = (ctx->getC) (ctx);
+  if (r == EOF)
+    {
+      return 0;
+    }
+  *result += r << 8;
+
+  r = (ctx->getC) (ctx);
+  if (r == EOF)
+    {
+      return 0;
+    }
+  *result += r;
+
+  return 1;
+}
+
+int
+gdPutBuf (const void *buf, int size, gdIOCtx * ctx)
+{
+  IO_DBG (printf ("Putting buf...\n"));
+  return (ctx->putBuf) (ctx, buf, size);
+  IO_DBG (printf ("put.\n"));
+}
+
+int
+gdGetBuf (void *buf, int size, gdIOCtx * ctx)
+{
+  return (ctx->getBuf) (ctx, buf, size);
+}
+
+
+int
+gdSeek (gdIOCtx * ctx, const int pos)
+{
+  IO_DBG (printf ("Seeking...\n"));
+  return ((ctx->seek) (ctx, pos));
+  IO_DBG (printf ("Done.\n"));
+}
+
+long
+gdTell (gdIOCtx * ctx)
+{
+  IO_DBG (printf ("Telling...\n"));
+  return ((ctx->tell) (ctx));
+  IO_DBG (printf ("told.\n"));
+}
diff --git a/collects/plot/src/all/gd_io.h b/collects/plot/src/all/gd_io.h
new file mode 100644
index 0000000000..cfe7aab70c
--- /dev/null
+++ b/collects/plot/src/all/gd_io.h
@@ -0,0 +1,47 @@
+#ifndef GD_IO_H
+#define GD_IO_H 1
+
+#include <stdio.h>
+
+#ifdef VMS
+#define Putchar gdPutchar
+#endif
+
+typedef struct gdIOCtx
+{
+  int (*getC) (struct gdIOCtx *);
+  int (*getBuf) (struct gdIOCtx *, void *, int);
+
+  void (*putC) (struct gdIOCtx *, int);
+  int (*putBuf) (struct gdIOCtx *, const void *, int);
+
+  /* seek must return 1 on SUCCESS, 0 on FAILURE. Unlike fseek! */
+  int (*seek) (struct gdIOCtx *, const int);
+
+  long (*tell) (struct gdIOCtx *);
+
+  void (*gd_free) (struct gdIOCtx *);
+
+}
+gdIOCtx;
+
+typedef struct gdIOCtx *gdIOCtxPtr;
+
+void Putword (int w, gdIOCtx * ctx);
+void Putchar (int c, gdIOCtx * ctx);
+
+void gdPutC (const unsigned char c, gdIOCtx * ctx);
+int gdPutBuf (const void *, int, gdIOCtx *);
+void gdPutWord (int w, gdIOCtx * ctx);
+void gdPutInt (int w, gdIOCtx * ctx);
+
+int gdGetC (gdIOCtx * ctx);
+int gdGetBuf (void *, int, gdIOCtx *);
+int gdGetByte (int *result, gdIOCtx * ctx);
+int gdGetWord (int *result, gdIOCtx * ctx);
+int gdGetInt (int *result, gdIOCtx * ctx);
+
+int gdSeek (gdIOCtx * ctx, const int);
+long gdTell (gdIOCtx * ctx);
+
+#endif
diff --git a/collects/plot/src/all/gd_io_dp.c b/collects/plot/src/all/gd_io_dp.c
new file mode 100644
index 0000000000..97b5c848ff
--- /dev/null
+++ b/collects/plot/src/all/gd_io_dp.c
@@ -0,0 +1,421 @@
+/*
+   * io_dp.c
+   *
+   * Implements the dynamic pointer interface.
+   *
+   * Based on GD.pm code by Lincoln Stein for interfacing to libgd.
+   * Added support for reading as well as support for 'tell' and 'seek'.
+   *
+   * As will all I/O modules, most functions are for local use only (called
+   * via function pointers in the I/O context).
+   *
+   * gdDPExtractData is the exception to this: it will return the pointer to
+   * the internal data, and reset the internal storage.
+   *
+   * Written/Modified 1999, Philip Warner.
+   *
+ */
+
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+
+#include <math.h>
+#include <string.h>
+#include <stdlib.h>
+#include "gd.h"
+#include "gdhelpers.h"
+
+#define TRUE 1
+#define FALSE 0
+
+/* this is used for creating images in main memory */
+typedef struct dpStruct
+{
+  void *data;
+  int logicalSize;
+  int realSize;
+  int dataGood;
+  int pos;
+}
+dynamicPtr;
+
+typedef struct dpIOCtx
+{
+  gdIOCtx ctx;
+  dynamicPtr *dp;
+}
+dpIOCtx;
+
+typedef struct dpIOCtx *dpIOCtxPtr;
+
+
+/* these functions operate on in-memory dynamic pointers */
+static int allocDynamic (dynamicPtr * dp, int initialSize, void *data);
+static int appendDynamic (dynamicPtr * dp, const void *src, int size);
+static int gdReallocDynamic (dynamicPtr * dp, int required);
+static int trimDynamic (dynamicPtr * dp);
+static void gdFreeDynamicCtx (struct gdIOCtx *ctx);
+static dynamicPtr *newDynamic (int initialSize, void *data);
+
+static int dynamicPutbuf (struct gdIOCtx *, const void *, int);
+static void dynamicPutchar (struct gdIOCtx *, int a);
+
+static int dynamicGetbuf (gdIOCtxPtr ctx, void *buf, int len);
+static int dynamicGetchar (gdIOCtxPtr ctx);
+
+static int dynamicSeek (struct gdIOCtx *, const int);
+static long dynamicTell (struct gdIOCtx *);
+
+/* return data as a dynamic pointer */
+gdIOCtx *
+gdNewDynamicCtx (int initialSize, void *data)
+{
+  dpIOCtx *ctx;
+  dynamicPtr *dp;
+
+  ctx = (dpIOCtx *) gdMalloc (sizeof (dpIOCtx));
+  if (ctx == NULL)
+    {
+      return NULL;
+    }
+
+  dp = newDynamic (initialSize, data);
+  if (!dp)
+    {
+      gdFree (ctx);
+      return NULL;
+    };
+
+  ctx->dp = dp;
+
+  ctx->ctx.getC = dynamicGetchar;
+  ctx->ctx.putC = dynamicPutchar;
+
+  ctx->ctx.getBuf = dynamicGetbuf;
+  ctx->ctx.putBuf = dynamicPutbuf;
+
+  ctx->ctx.seek = dynamicSeek;
+  ctx->ctx.tell = dynamicTell;
+
+  ctx->ctx.gd_free = gdFreeDynamicCtx;
+
+  return (gdIOCtx *) ctx;
+}
+
+void *
+gdDPExtractData (struct gdIOCtx *ctx, int *size)
+{
+  dynamicPtr *dp;
+  dpIOCtx *dctx;
+  void *data;
+
+  dctx = (dpIOCtx *) ctx;
+  dp = dctx->dp;
+
+  /* clean up the data block and return it */
+  if (dp->dataGood)
+    {
+      trimDynamic (dp);
+      *size = dp->logicalSize;
+      data = dp->data;
+    }
+  else
+    {
+      *size = 0;
+      data = NULL;
+      if (dp->data != NULL)
+	{
+	  gdFree (dp->data);
+	}
+    }
+
+  dp->data = NULL;
+  dp->realSize = 0;
+  dp->logicalSize = 0;
+
+  return data;
+}
+
+static void
+gdFreeDynamicCtx (struct gdIOCtx *ctx)
+{
+  dynamicPtr *dp;
+  dpIOCtx *dctx;
+
+  dctx = (dpIOCtx *) ctx;
+  dp = dctx->dp;
+
+  gdFree (ctx);
+
+  /* clean up the data block and return it */
+  if (dp->data != NULL)
+    {
+      gdFree (dp->data);
+      dp->data = NULL;
+    }
+
+  dp->realSize = 0;
+  dp->logicalSize = 0;
+
+  gdFree (dp);
+
+}
+
+static long
+dynamicTell (struct gdIOCtx *ctx)
+{
+  dpIOCtx *dctx;
+
+  dctx = (dpIOCtx *) ctx;
+  return (dctx->dp->pos);
+}
+
+static int
+dynamicSeek (struct gdIOCtx *ctx, const int pos)
+{
+  int bytesNeeded;
+  dynamicPtr *dp;
+  dpIOCtx *dctx;
+
+  dctx = (dpIOCtx *) ctx;
+  dp = dctx->dp;
+
+  if (!dp->dataGood)
+    return FALSE;
+
+  bytesNeeded = pos;
+  if (bytesNeeded > dp->realSize)
+    {
+      if (!gdReallocDynamic (dp, dp->realSize * 2))
+	{
+	  dp->dataGood = FALSE;
+	  return FALSE;
+	}
+    }
+
+  /* if we get here, we can be sure that we have enough bytes
+     to copy safely */
+
+  /* Extend the logical size if we seek beyond EOF. */
+  if (pos > dp->logicalSize)
+    {
+      dp->logicalSize = pos;
+    };
+
+  dp->pos = pos;
+
+  return TRUE;
+}
+
+/* return data as a dynamic pointer */
+static dynamicPtr *
+newDynamic (int initialSize, void *data)
+{
+  dynamicPtr *dp;
+  dp = (dynamicPtr *) gdMalloc (sizeof (dynamicPtr));
+  if (dp == NULL)
+    {
+      return NULL;
+    }
+
+  if (!allocDynamic (dp, initialSize, data))
+    return NULL;
+
+  dp->pos = 0;
+
+  return dp;
+}
+
+static int
+dynamicPutbuf (struct gdIOCtx *ctx, const void *buf, int size)
+{
+  dpIOCtx *dctx;
+  dctx = (dpIOCtx *) ctx;
+
+  appendDynamic (dctx->dp, buf, size);
+
+  if (dctx->dp->dataGood)
+    {
+      return size;
+    }
+  else
+    {
+      return -1;
+    };
+
+}
+
+static void
+dynamicPutchar (struct gdIOCtx *ctx, int a)
+{
+  unsigned char b;
+  dpIOCtxPtr dctx;
+
+  b = a;
+  dctx = (dpIOCtxPtr) ctx;
+
+  appendDynamic (dctx->dp, &b, 1);
+}
+
+static int
+dynamicGetbuf (gdIOCtxPtr ctx, void *buf, int len)
+{
+  int rlen, remain;
+  dpIOCtxPtr dctx;
+  dynamicPtr *dp;
+
+  dctx = (dpIOCtxPtr) ctx;
+  dp = dctx->dp;
+
+  remain = dp->logicalSize - dp->pos;
+  if (remain >= len)
+    {
+      rlen = len;
+    }
+  else
+    {
+      if (remain == 0)
+	{
+	  return EOF;
+	}
+      rlen = remain;
+    }
+
+  memcpy (buf, (void *) ((char *) dp->data + dp->pos), rlen);
+  dp->pos += rlen;
+
+  return rlen;
+}
+
+static int
+dynamicGetchar (gdIOCtxPtr ctx)
+{
+  unsigned char b;
+  int rv;
+
+  rv = dynamicGetbuf (ctx, &b, 1);
+
+  if (rv != 1)
+    {
+      return EOF;
+    }
+  else
+    {
+      return b;			/* (b & 0xff); */
+    }
+}
+
+/* *********************************************************************
+
+ * InitDynamic - Return a dynamically resizable void*
+ *
+ * *********************************************************************
+ */
+static int
+allocDynamic (dynamicPtr * dp, int initialSize, void *data)
+{
+
+  if (data == NULL)
+    {
+      dp->logicalSize = 0;
+      dp->dataGood = FALSE;
+      dp->data = gdMalloc (initialSize);
+    }
+  else
+    {
+      dp->logicalSize = initialSize;
+      dp->dataGood = TRUE;
+      dp->data = data;
+    }
+
+  if (dp->data != NULL)
+    {
+      dp->realSize = initialSize;
+      dp->dataGood = TRUE;
+      dp->pos = 0;
+      return TRUE;
+    }
+  else
+    {
+      dp->realSize = 0;
+      return FALSE;
+    }
+}
+
+/* append bytes to the end of a dynamic pointer */
+static int
+appendDynamic (dynamicPtr * dp, const void *src, int size)
+{
+  int bytesNeeded;
+  char *tmp;
+
+  if (!dp->dataGood)
+    return FALSE;
+
+/*  bytesNeeded = dp->logicalSize + size; */
+  bytesNeeded = dp->pos + size;
+
+  if (bytesNeeded > dp->realSize)
+    {
+      if (!gdReallocDynamic (dp, bytesNeeded * 2))
+	{
+	  dp->dataGood = FALSE;
+	  return FALSE;
+	}
+    }
+
+  /* if we get here, we can be sure that we have enough bytes
+     to copy safely */
+  /*printf("Mem OK Size: %d, Pos: %d\n", dp->realSize, dp->pos); */
+
+  tmp = (char *) dp->data;
+  memcpy ((void *) (tmp + (dp->pos)), src, size);
+  dp->pos += size;
+
+  if (dp->pos > dp->logicalSize)
+    {
+      dp->logicalSize = dp->pos;
+    };
+
+  return TRUE;
+}
+
+/* grow (or shrink) dynamic pointer */
+static int
+gdReallocDynamic (dynamicPtr * dp, int required)
+{
+  void *newPtr;
+
+  /* First try gdRealloc().  If that doesn't work, make a new
+     memory block and copy. */
+  if ((newPtr = gdRealloc (dp->data, required)))
+    {
+      dp->realSize = required;
+      dp->data = newPtr;
+      return TRUE;
+    }
+
+  /* create a new pointer */
+  newPtr = gdMalloc (required);
+  if (!newPtr)
+    {
+      dp->dataGood = FALSE;
+      return FALSE;
+    }
+
+  /* copy the old data into it */
+  memcpy (newPtr, dp->data, dp->logicalSize);
+  gdFree (dp->data);
+  dp->data = newPtr;
+
+  dp->realSize = required;
+  return TRUE;
+}
+
+/* trim pointer so that its real and logical sizes match */
+static int
+trimDynamic (dynamicPtr * dp)
+{
+  return gdReallocDynamic (dp, dp->logicalSize);
+}
diff --git a/collects/plot/src/all/gd_io_file.c b/collects/plot/src/all/gd_io_file.c
new file mode 100644
index 0000000000..78b8148236
--- /dev/null
+++ b/collects/plot/src/all/gd_io_file.c
@@ -0,0 +1,147 @@
+
+/*
+   * io_file.c
+   *
+   * Implements the file interface.
+   *
+   * As will all I/O modules, most functions are for local use only (called
+   * via function pointers in the I/O context).
+   *
+   * Most functions are just 'wrappers' for standard file functions.
+   *
+   * Written/Modified 1999, Philip Warner.
+   *
+ */
+
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+
+/* For platforms with incomplete ANSI defines. Fortunately,
+   SEEK_SET is defined to be zero by the standard. */
+
+#ifndef SEEK_SET
+#define SEEK_SET 0
+#endif /* SEEK_SET */
+
+#include <math.h>
+#include <string.h>
+#include <stdlib.h>
+#include "gd.h"
+#include "gdhelpers.h"
+
+/* this is used for creating images in main memory */
+
+typedef struct fileIOCtx
+{
+  gdIOCtx ctx;
+  FILE *f;
+}
+fileIOCtx;
+
+struct fileIOCtx *fileIOCtxPtr;
+
+gdIOCtx *newFileCtx (FILE * f);
+
+static int fileGetbuf (gdIOCtx *, void *, int);
+static int filePutbuf (gdIOCtx *, const void *, int);
+static void filePutchar (gdIOCtx *, int);
+static int fileGetchar (gdIOCtx * ctx);
+
+static int fileSeek (struct gdIOCtx *, const int);
+static long fileTell (struct gdIOCtx *);
+static void gdFreeFileCtx (gdIOCtx * ctx);
+
+/* return data as a dynamic pointer */
+gdIOCtx *
+gdNewFileCtx (FILE * f)
+{
+  fileIOCtx *ctx;
+
+  ctx = (fileIOCtx *) gdMalloc (sizeof (fileIOCtx));
+  if (ctx == NULL)
+    {
+      return NULL;
+    }
+
+  ctx->f = f;
+
+  ctx->ctx.getC = fileGetchar;
+  ctx->ctx.putC = filePutchar;
+
+  ctx->ctx.getBuf = fileGetbuf;
+  ctx->ctx.putBuf = filePutbuf;
+
+  ctx->ctx.tell = fileTell;
+  ctx->ctx.seek = fileSeek;
+
+  ctx->ctx.gd_free = gdFreeFileCtx;
+
+  return (gdIOCtx *) ctx;
+}
+
+static void
+gdFreeFileCtx (gdIOCtx * ctx)
+{
+  gdFree (ctx);
+}
+
+
+static int
+filePutbuf (gdIOCtx * ctx, const void *buf, int size)
+{
+  fileIOCtx *fctx;
+  fctx = (fileIOCtx *) ctx;
+
+  return fwrite (buf, 1, size, fctx->f);
+
+}
+
+static int
+fileGetbuf (gdIOCtx * ctx, void *buf, int size)
+{
+  fileIOCtx *fctx;
+  fctx = (fileIOCtx *) ctx;
+
+  return (fread (buf, 1, size, fctx->f));
+
+}
+
+static void
+filePutchar (gdIOCtx * ctx, int a)
+{
+  unsigned char b;
+  fileIOCtx *fctx;
+  fctx = (fileIOCtx *) ctx;
+
+  b = a;
+
+  putc (b, fctx->f);
+}
+
+static int
+fileGetchar (gdIOCtx * ctx)
+{
+  fileIOCtx *fctx;
+  fctx = (fileIOCtx *) ctx;
+
+  return getc (fctx->f);
+}
+
+
+static int
+fileSeek (struct gdIOCtx *ctx, const int pos)
+{
+  fileIOCtx *fctx;
+  fctx = (fileIOCtx *) ctx;
+  return (fseek (fctx->f, pos, SEEK_SET) == 0);
+}
+
+static long
+fileTell (struct gdIOCtx *ctx)
+{
+  fileIOCtx *fctx;
+  fctx = (fileIOCtx *) ctx;
+
+  return ftell (fctx->f);
+}
diff --git a/collects/plot/src/all/gd_io_ss.c b/collects/plot/src/all/gd_io_ss.c
new file mode 100644
index 0000000000..257c1d430b
--- /dev/null
+++ b/collects/plot/src/all/gd_io_ss.c
@@ -0,0 +1,168 @@
+
+/*
+   * io_ss.c
+   *
+   * Implements the Source/Sink interface.
+   *
+   * As will all I/O modules, most functions are for local use only (called
+   * via function pointers in the I/O context).
+   *
+   * The Source/Sink model is the primary 'user' interface for alternate data
+   * sources; the IOCtx interface is intended (at least in version 1.5) to be
+   * used internally until it settles down a bit.
+   *
+   * This module just layers the Source/Sink interface on top of the IOCtx; no
+   * support is provided for tell/seek, so GD2 writing is not possible, and 
+   * retrieving parts of GD2 files is also not possible.
+   *
+   * A new SS context does not need to be created with both a Source and a Sink.
+   *
+   * Written/Modified 1999, Philip Warner.
+   *
+ */
+
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+
+#include <math.h>
+#include <string.h>
+#include <stdlib.h>
+#include "gd.h"
+#include "gdhelpers.h"
+
+/* this is used for creating images in main memory */
+
+typedef struct ssIOCtx
+{
+  gdIOCtx ctx;
+  gdSourcePtr src;
+  gdSinkPtr snk;
+}
+ssIOCtx;
+
+typedef struct ssIOCtx *ssIOCtxPtr;
+
+gdIOCtx *gdNewSSCtx (gdSourcePtr src, gdSinkPtr snk);
+
+static int sourceGetbuf (gdIOCtx *, void *, int);
+static int sourceGetchar (gdIOCtx * ctx);
+static int sinkPutbuf (gdIOCtx * ctx, const void *buf, int size);
+static void sinkPutchar (gdIOCtx * ctx, int a);
+static void gdFreeSsCtx (gdIOCtx * ctx);
+
+/* return data as a dynamic pointer */
+gdIOCtx *
+gdNewSSCtx (gdSourcePtr src, gdSinkPtr snk)
+{
+  ssIOCtxPtr ctx;
+
+  ctx = (ssIOCtxPtr) gdMalloc (sizeof (ssIOCtx));
+  if (ctx == NULL)
+    {
+      return NULL;
+    }
+
+  ctx->src = src;
+  ctx->snk = snk;
+
+  ctx->ctx.getC = sourceGetchar;
+  ctx->ctx.getBuf = sourceGetbuf;
+
+  ctx->ctx.putC = sinkPutchar;
+  ctx->ctx.putBuf = sinkPutbuf;
+
+  ctx->ctx.tell = NULL;
+  ctx->ctx.seek = NULL;
+
+  ctx->ctx.gd_free = gdFreeSsCtx;
+
+  return (gdIOCtx *) ctx;
+}
+
+static void
+gdFreeSsCtx (gdIOCtx * ctx)
+{
+  gdFree (ctx);
+}
+
+
+static int
+sourceGetbuf (gdIOCtx * ctx, void *buf, int size)
+{
+  ssIOCtx *lctx;
+  int res;
+
+  lctx = (ssIOCtx *) ctx;
+
+  res = ((lctx->src->source) (lctx->src->context, buf, size));
+
+/*
+   ** Translate the return values from the Source object: 
+   ** 0 is EOF, -1 is error
+ */
+
+  if (res == 0)
+    {
+      return EOF;
+    }
+  else if (res < 0)
+    {
+      return 0;
+    }
+  else
+    {
+      return res;
+    };
+
+}
+
+static int
+sourceGetchar (gdIOCtx * ctx)
+{
+  int res;
+  unsigned char buf;
+
+  res = sourceGetbuf (ctx, &buf, 1);
+
+  if (res == 1)
+    {
+      return buf;
+    }
+  else
+    {
+      return EOF;
+    };
+
+}
+
+static int
+sinkPutbuf (gdIOCtx * ctx, const void *buf, int size)
+{
+  ssIOCtxPtr lctx;
+  int res;
+
+  lctx = (ssIOCtx *) ctx;
+
+  res = (lctx->snk->sink) (lctx->snk->context, buf, size);
+
+  if (res <= 0)
+    {
+      return 0;
+    }
+  else
+    {
+      return res;
+    };
+
+}
+
+static void
+sinkPutchar (gdIOCtx * ctx, int a)
+{
+  unsigned char b;
+
+  b = a;
+  sinkPutbuf (ctx, &b, 1);
+
+}
diff --git a/collects/plot/src/all/gd_jpeg.c b/collects/plot/src/all/gd_jpeg.c
new file mode 100644
index 0000000000..391e9d9694
--- /dev/null
+++ b/collects/plot/src/all/gd_jpeg.c
@@ -0,0 +1,850 @@
+/*
+ * gd_jpeg.c: Read and write JPEG (JFIF) format image files using the
+ * gd graphics library (http://www.boutell.com/gd/).
+ * 
+ * This software is based in part on the work of the Independent JPEG
+ * Group.  For more information on the IJG JPEG software (and JPEG
+ * documentation, etc.), see ftp://ftp.uu.net/graphics/jpeg/.
+ *
+ * NOTE: IJG 12-bit JSAMPLE (BITS_IN_JSAMPLE == 12) mode is not
+ * supported at all on read in gd 2.0, and is not supported on write
+ * except for palette images, which is sort of pointless (TBB). Even that
+ * has never been tested according to DB.
+ *
+ * Copyright 2000 Doug Becker, mailto:thebeckers@home.com
+ *
+ * Modification 4/18/00 TBB: JPEG_DEBUG rather than just DEBUG,
+ * so VC++ builds don't spew to standard output, causing
+ * major CGI brain damage
+ *
+ * 2.0.10: more efficient gdImageCreateFromJpegCtx, thanks to
+ * Christian Aberger 
+ */
+
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <setjmp.h>
+#include <limits.h>
+#include <string.h>
+
+#include "gd.h"
+/* TBB: move this up so include files are not brought in */
+/* JCE: arrange HAVE_LIBJPEG so that it can be set in gd.h */
+#ifdef HAVE_LIBJPEG
+#include "gdhelpers.h"
+
+/* 1.8.1: remove dependency on jinclude.h */
+#include "jpeglib.h"
+#include "jerror.h"
+
+static const char *const GD_JPEG_VERSION = "1.0";
+
+typedef struct _jmpbuf_wrapper
+{
+  jmp_buf jmpbuf;
+}
+jmpbuf_wrapper;
+
+/* Called by the IJG JPEG library upon encountering a fatal error */
+static void
+fatal_jpeg_error (j_common_ptr cinfo)
+{
+  jmpbuf_wrapper *jmpbufw;
+
+  fprintf (stderr, "gd-jpeg: JPEG library reports unrecoverable error: ");
+  (*cinfo->err->output_message) (cinfo);
+  fflush (stderr);
+
+  jmpbufw = (jmpbuf_wrapper *) cinfo->client_data;
+  jpeg_destroy (cinfo);
+
+  if (jmpbufw != 0)
+    {
+      longjmp (jmpbufw->jmpbuf, 1);
+      fprintf (stderr, "gd-jpeg: EXTREMELY fatal error: longjmp"
+	       " returned control; terminating\n");
+    }
+  else
+    {
+      fprintf (stderr, "gd-jpeg: EXTREMELY fatal error: jmpbuf"
+	       " unrecoverable; terminating\n");
+    }
+
+  fflush (stderr);
+  exit (99);
+}
+
+/*
+ * Write IM to OUTFILE as a JFIF-formatted JPEG image, using quality
+ * QUALITY.  If QUALITY is in the range 0-100, increasing values
+ * represent higher quality but also larger image size.  If QUALITY is
+ * negative, the IJG JPEG library's default quality is used (which
+ * should be near optimal for many applications).  See the IJG JPEG
+ * library documentation for more details.  */
+
+void
+gdImageJpeg (gdImagePtr im, FILE * outFile, int quality)
+{
+  gdIOCtx *out = gdNewFileCtx (outFile);
+  gdImageJpegCtx (im, out, quality);
+  out->gd_free (out);
+}
+
+void *
+gdImageJpegPtr (gdImagePtr im, int *size, int quality)
+{
+  void *rv;
+  gdIOCtx *out = gdNewDynamicCtx (2048, NULL);
+  gdImageJpegCtx (im, out, quality);
+  rv = gdDPExtractData (out, size);
+  out->gd_free (out);
+  return rv;
+}
+
+void jpeg_gdIOCtx_dest (j_compress_ptr cinfo, gdIOCtx * outfile);
+
+void
+gdImageJpegCtx (gdImagePtr im, gdIOCtx * outfile, int quality)
+{
+  struct jpeg_compress_struct cinfo;
+  struct jpeg_error_mgr jerr;
+  int i, j, jidx;
+  /* volatile so we can gdFree it on return from longjmp */
+  volatile JSAMPROW row = 0;
+  JSAMPROW rowptr[1];
+  jmpbuf_wrapper jmpbufw;
+  JDIMENSION nlines;
+  char comment[255];
+
+#ifdef JPEG_DEBUG
+  printf ("gd-jpeg: gd JPEG version %s\n", GD_JPEG_VERSION);
+  printf ("gd-jpeg: JPEG library version %d, %d-bit sample values\n",
+	  JPEG_LIB_VERSION, BITS_IN_JSAMPLE);
+  if (!im->trueColor)
+    {
+      for (i = 0; i < im->colorsTotal; i++)
+	{
+	  if (!im->open[i])
+	    printf ("gd-jpeg: gd colormap index %d: (%d, %d, %d)\n", i,
+		    im->red[i], im->green[i], im->blue[i]);
+	}
+    }
+#endif /* JPEG_DEBUG */
+
+  memset (&cinfo, 0, sizeof (cinfo));
+  memset (&jerr, 0, sizeof (jerr));
+
+  cinfo.err = jpeg_std_error (&jerr);
+  cinfo.client_data = &jmpbufw;
+  if (setjmp (jmpbufw.jmpbuf) != 0)
+    {
+      /* we're here courtesy of longjmp */
+      if (row)
+	gdFree (row);
+      return;
+    }
+
+  cinfo.err->error_exit = fatal_jpeg_error;
+
+  jpeg_create_compress (&cinfo);
+
+  cinfo.image_width = im->sx;
+  cinfo.image_height = im->sy;
+  cinfo.input_components = 3;	/* # of color components per pixel */
+  cinfo.in_color_space = JCS_RGB;	/* colorspace of input image */
+  jpeg_set_defaults (&cinfo);
+  if (quality >= 0)
+    jpeg_set_quality (&cinfo, quality, TRUE);
+
+  /* If user requests interlace, translate that to progressive JPEG */
+  if (gdImageGetInterlaced (im))
+    {
+#ifdef JPEG_DEBUG
+      printf ("gd-jpeg: interlace set, outputting progressive"
+	      " JPEG image\n");
+#endif
+      jpeg_simple_progression (&cinfo);
+    }
+
+  jpeg_gdIOCtx_dest (&cinfo, outfile);
+
+  row = (JSAMPROW) gdCalloc (1, cinfo.image_width * cinfo.input_components
+			     * sizeof (JSAMPLE));
+  if (row == 0)
+    {
+      fprintf (stderr, "gd-jpeg: error: unable to allocate JPEG row "
+	       "structure: gdCalloc returns NULL\n");
+      jpeg_destroy_compress (&cinfo);
+      return;
+    }
+
+  rowptr[0] = row;
+
+  jpeg_start_compress (&cinfo, TRUE);
+
+  sprintf (comment, "CREATOR: gd-jpeg v%s (using IJG JPEG v%d),",
+	   GD_JPEG_VERSION, JPEG_LIB_VERSION);
+  if (quality >= 0)
+    sprintf (comment + strlen (comment), " quality = %d\n", quality);
+  else
+    strcat (comment + strlen (comment), " default quality\n");
+  jpeg_write_marker (&cinfo, JPEG_COM, (unsigned char *) comment,
+		     (unsigned int) strlen (comment));
+  if (im->trueColor)
+    {
+#if BITS_IN_JSAMPLE == 12
+      fprintf (stderr,
+	       "gd-jpeg: error: jpeg library was compiled for 12-bit\n"
+	       "precision. This is mostly useless, because JPEGs on the web are\n"
+	       "8-bit and such versions of the jpeg library won't read or write\n"
+	       "them. GD doesn't support these unusual images. Edit your\n"
+	       "jmorecfg.h file to specify the correct precision and completely\n"
+	       "'make clean' and 'make install' libjpeg again. Sorry.\n");
+      goto error;
+#endif /* BITS_IN_JSAMPLE == 12 */
+      for (i = 0; i < im->sy; i++)
+	{
+	  for (jidx = 0, j = 0; j < im->sx; j++)
+	    {
+	      int val = im->tpixels[i][j];
+	      row[jidx++] = gdTrueColorGetRed (val);
+	      row[jidx++] = gdTrueColorGetGreen (val);
+	      row[jidx++] = gdTrueColorGetBlue (val);
+	    }
+
+	  nlines = jpeg_write_scanlines (&cinfo, rowptr, 1);
+	  if (nlines != 1)
+	    fprintf (stderr, "gd_jpeg: warning: jpeg_write_scanlines"
+		     " returns %u -- expected 1\n", nlines);
+	}
+    }
+  else
+    {
+      for (i = 0; i < im->sy; i++)
+	{
+	  for (jidx = 0, j = 0; j < im->sx; j++)
+	    {
+	      int idx = im->pixels[i][j];
+
+	      /*
+	       * NB: Although gd RGB values are ints, their max value is
+	       * 255 (see the documentation for gdImageColorAllocate())
+	       * -- perfect for 8-bit JPEG encoding (which is the norm)
+	       */
+#if BITS_IN_JSAMPLE == 8
+	      row[jidx++] = im->red[idx];
+	      row[jidx++] = im->green[idx];
+	      row[jidx++] = im->blue[idx];
+#elif BITS_IN_JSAMPLE == 12
+	      row[jidx++] = im->red[idx] << 4;
+	      row[jidx++] = im->green[idx] << 4;
+	      row[jidx++] = im->blue[idx] << 4;
+#else
+#error IJG JPEG library BITS_IN_JSAMPLE value must be 8 or 12
+#endif
+	    }
+
+	  nlines = jpeg_write_scanlines (&cinfo, rowptr, 1);
+	  if (nlines != 1)
+	    fprintf (stderr, "gd_jpeg: warning: jpeg_write_scanlines"
+		     " returns %u -- expected 1\n", nlines);
+	}
+    }
+  jpeg_finish_compress (&cinfo);
+  jpeg_destroy_compress (&cinfo);
+  gdFree (row);
+}
+
+gdImagePtr
+gdImageCreateFromJpeg (FILE * inFile)
+{
+  gdImagePtr im;
+  gdIOCtx *in = gdNewFileCtx (inFile);
+  im = gdImageCreateFromJpegCtx (in);
+  in->gd_free (in);
+  return im;
+}
+
+void jpeg_gdIOCtx_src (j_decompress_ptr cinfo, gdIOCtx * infile);
+
+/* 
+ * Create a gd-format image from the JPEG-format INFILE.  Returns the
+ * image, or NULL upon error.
+ */
+gdImagePtr
+gdImageCreateFromJpegCtx (gdIOCtx * infile)
+{
+  struct jpeg_decompress_struct cinfo;
+  struct jpeg_error_mgr jerr;
+  jmpbuf_wrapper jmpbufw;
+  /* volatile so we can gdFree them after longjmp */
+  volatile JSAMPROW row = 0;
+  volatile gdImagePtr im = 0;
+  JSAMPROW rowptr[1];
+  int i, j, retval;
+  JDIMENSION nrows;
+
+#ifdef JPEG_DEBUG
+  printf ("gd-jpeg: gd JPEG version %s\n", GD_JPEG_VERSION);
+  printf ("gd-jpeg: JPEG library version %d, %d-bit sample values\n",
+	  JPEG_LIB_VERSION, BITS_IN_JSAMPLE);
+#endif
+
+  memset (&cinfo, 0, sizeof (cinfo));
+  memset (&jerr, 0, sizeof (jerr));
+
+  cinfo.err = jpeg_std_error (&jerr);
+  cinfo.client_data = &jmpbufw;
+  if (setjmp (jmpbufw.jmpbuf) != 0)
+    {
+      /* we're here courtesy of longjmp */
+      if (row)
+	gdFree (row);
+      if (im)
+	gdImageDestroy (im);
+      return 0;
+    }
+
+  cinfo.err->error_exit = fatal_jpeg_error;
+
+  jpeg_create_decompress (&cinfo);
+
+  jpeg_gdIOCtx_src (&cinfo, infile);
+
+  retval = jpeg_read_header (&cinfo, TRUE);
+  if (retval != JPEG_HEADER_OK)
+    fprintf (stderr, "gd-jpeg: warning: jpeg_read_header returns"
+	     " %d, expected %d\n", retval, JPEG_HEADER_OK);
+
+  if (cinfo.image_height > INT_MAX)
+    fprintf (stderr, "gd-jpeg: warning: JPEG image height (%u) is"
+	     " greater than INT_MAX (%d) (and thus greater than"
+	     " gd can handle)", cinfo.image_height, INT_MAX);
+
+  if (cinfo.image_width > INT_MAX)
+    fprintf (stderr, "gd-jpeg: warning: JPEG image width (%u) is"
+	     " greater than INT_MAX (%d) (and thus greater than"
+	     " gd can handle)\n", cinfo.image_width, INT_MAX);
+
+  im = gdImageCreateTrueColor ((int) cinfo.image_width,
+			       (int) cinfo.image_height);
+  if (im == 0)
+    {
+      fprintf (stderr, "gd-jpeg error: cannot allocate gdImage" " struct\n");
+      goto error;
+    }
+
+  /*
+   * Force the image into RGB colorspace, but don't 
+   * reduce the number of colors anymore (GD 2.0) 
+   */
+  cinfo.out_color_space = JCS_RGB;
+
+  if (jpeg_start_decompress (&cinfo) != TRUE)
+    fprintf (stderr, "gd-jpeg: warning: jpeg_start_decompress"
+	     " reports suspended data source\n");
+
+#ifdef JPEG_DEBUG
+  printf ("gd-jpeg: JPEG image information:");
+  if (cinfo.saw_JFIF_marker)
+    printf (" JFIF version %d.%.2d",
+	    (int) cinfo.JFIF_major_version, (int) cinfo.JFIF_minor_version);
+  else if (cinfo.saw_Adobe_marker)
+    printf (" Adobe format");
+  else
+    printf (" UNKNOWN format");
+
+  printf (" %ux%u (raw) / %ux%u (scaled) %d-bit", cinfo.image_width,
+	  cinfo.image_height, cinfo.output_width,
+	  cinfo.output_height, cinfo.data_precision);
+  printf (" %s", (cinfo.progressive_mode ? "progressive" : "baseline"));
+  printf (" image, %d quantized colors, ", cinfo.actual_number_of_colors);
+
+  switch (cinfo.jpeg_color_space)
+    {
+    case JCS_GRAYSCALE:
+      printf ("grayscale");
+      break;
+
+    case JCS_RGB:
+      printf ("RGB");
+      break;
+
+    case JCS_YCbCr:
+      printf ("YCbCr (a.k.a. YUV)");
+      break;
+
+    case JCS_CMYK:
+      printf ("CMYK");
+      break;
+
+    case JCS_YCCK:
+      printf ("YCbCrK");
+      break;
+
+    default:
+      printf ("UNKNOWN (value: %d)", (int) cinfo.jpeg_color_space);
+      break;
+    }
+  printf (" colorspace\n");
+  fflush (stdout);
+#endif /* JPEG_DEBUG */
+
+  /* REMOVED by TBB 2/12/01. This field of the structure is
+     documented as private, and sure enough it's gone in the
+     latest libjpeg, replaced by something else. Unfortunately
+     there is still no right way to find out if the file was
+     progressive or not; just declare your intent before you
+     write one by calling gdImageInterlace(im, 1) yourself. 
+     After all, we're not really supposed to rework JPEGs and
+     write them out again anyway. Lossy compression, remember? */
+#if 0
+  gdImageInterlace (im, cinfo.progressive_mode != 0);
+#endif
+  if (cinfo.output_components != 3)
+    {
+      fprintf (stderr, "gd-jpeg: error: JPEG color quantization"
+	       " request resulted in output_components == %d"
+	       " (expected 3)\n", cinfo.output_components);
+      goto error;
+    }
+
+#if BITS_IN_JSAMPLE == 12
+  fprintf (stderr, "gd-jpeg: error: jpeg library was compiled for 12-bit\n"
+	   "precision. This is mostly useless, because JPEGs on the web are\n"
+	   "8-bit and such versions of the jpeg library won't read or write\n"
+	   "them. GD doesn't support these unusual images. Edit your\n"
+	   "jmorecfg.h file to specify the correct precision and completely\n"
+	   "'make clean' and 'make install' libjpeg again. Sorry.\n");
+  goto error;
+#endif /* BITS_IN_JSAMPLE == 12 */
+
+  row = gdCalloc (cinfo.output_width * 3, sizeof (JSAMPLE));
+  if (row == 0)
+    {
+      fprintf (stderr, "gd-jpeg: error: unable to allocate row for"
+	       " JPEG scanline: gdCalloc returns NULL\n");
+      goto error;
+    }
+  rowptr[0] = row;
+
+  for (i = 0; i < cinfo.output_height; i++)
+    {
+      register JSAMPROW currow = row;
+      register int *tpix = im->tpixels[i];
+      nrows = jpeg_read_scanlines (&cinfo, rowptr, 1);
+      if (nrows != 1)
+	{
+	  fprintf (stderr, "gd-jpeg: error: jpeg_read_scanlines"
+		   " returns %u, expected 1\n", nrows);
+	  goto error;
+	}
+      for (j = 0; j < cinfo.output_width; j++, currow += 3, tpix++)
+	{
+	  *tpix = gdTrueColor (currow[0], currow[1], currow[2]);
+	}
+    }
+
+  if (jpeg_finish_decompress (&cinfo) != TRUE)
+    fprintf (stderr, "gd-jpeg: warning: jpeg_finish_decompress"
+	     " reports suspended data source\n");
+
+
+  jpeg_destroy_decompress (&cinfo);
+  gdFree (row);
+  return im;
+
+error:
+  jpeg_destroy_decompress (&cinfo);
+  if (row)
+    gdFree (row);
+  if (im)
+    gdImageDestroy (im);
+  return 0;
+}
+
+/*
+
+ * gdIOCtx JPEG data sources and sinks, T. Boutell
+ * almost a simple global replace from T. Lane's stdio versions.
+ *
+ */
+
+/* Different versions of libjpeg use either 'jboolean' or 'boolean', and
+   some platforms define 'boolean', and so forth. Deal with this
+   madness by typedeffing 'safeboolean' to 'boolean' if HAVE_BOOLEAN
+   is already set, because this is the test that libjpeg uses.
+   Otherwise, typedef it to int, because that's what libjpeg does
+   if HAVE_BOOLEAN is not defined. -TBB */
+
+#ifdef HAVE_BOOLEAN
+typedef boolean safeboolean;
+#else
+typedef int safeboolean;
+#endif /* HAVE_BOOLEAN */
+
+/* Expanded data source object for gdIOCtx input */
+
+typedef struct
+{
+  struct jpeg_source_mgr pub;	/* public fields */
+
+  gdIOCtx *infile;		/* source stream */
+  unsigned char *buffer;	/* start of buffer */
+  safeboolean start_of_file;	/* have we gotten any data yet? */
+
+}
+my_source_mgr;
+
+typedef my_source_mgr *my_src_ptr;
+
+#define INPUT_BUF_SIZE  4096	/* choose an efficiently fread'able size */
+
+/*
+ * Initialize source --- called by jpeg_read_header
+ * before any data is actually read.
+ */
+
+void
+init_source (j_decompress_ptr cinfo)
+{
+  my_src_ptr src = (my_src_ptr) cinfo->src;
+
+  /* We reset the empty-input-file flag for each image,
+   * but we don't clear the input buffer.
+   * This is correct behavior for reading a series of images from one source.
+   */
+  src->start_of_file = TRUE;
+}
+
+
+/*
+ * Fill the input buffer --- called whenever buffer is emptied.
+ *
+ * In typical applications, this should read fresh data into the buffer
+ * (ignoring the current state of next_input_byte & bytes_in_buffer),
+ * reset the pointer & count to the start of the buffer, and return TRUE
+ * indicating that the buffer has been reloaded.  It is not necessary to
+ * fill the buffer entirely, only to obtain at least one more byte.
+ *
+ * There is no such thing as an EOF return.  If the end of the file has been
+ * reached, the routine has a choice of ERREXIT() or inserting fake data into
+ * the buffer.  In most cases, generating a warning message and inserting a
+ * fake EOI marker is the best course of action --- this will allow the
+ * decompressor to output however much of the image is there.  However,
+ * the resulting error message is misleading if the real problem is an empty
+ * input file, so we handle that case specially.
+ *
+ * In applications that need to be able to suspend compression due to input
+ * not being available yet, a FALSE return indicates that no more data can be
+ * obtained right now, but more may be forthcoming later.  In this situation,
+ * the decompressor will return to its caller (with an indication of the
+ * number of scanlines it has read, if any).  The application should resume
+ * decompression after it has loaded more data into the input buffer.  Note
+ * that there are substantial restrictions on the use of suspension --- see
+ * the documentation.
+ *
+ * When suspending, the decompressor will back up to a convenient restart point
+ * (typically the start of the current MCU). next_input_byte & bytes_in_buffer
+ * indicate where the restart point will be if the current call returns FALSE.
+ * Data beyond this point must be rescanned after resumption, so move it to
+ * the front of the buffer rather than discarding it.
+ */
+
+#define END_JPEG_SEQUENCE "\r\n[*]--:END JPEG:--[*]\r\n"
+safeboolean
+fill_input_buffer (j_decompress_ptr cinfo)
+{
+  my_src_ptr src = (my_src_ptr) cinfo->src;
+  /* 2.0.12: signed size. Thanks to Geert Jansen */
+  /* 2.0.14: some platforms (mingw-msys) don't have ssize_t. Call 
+    an int an int. */
+  int nbytes = 0;
+  memset (src->buffer, 0, INPUT_BUF_SIZE);
+
+  while (nbytes < INPUT_BUF_SIZE)
+    {
+
+      int got = gdGetBuf (src->buffer + nbytes,
+			  INPUT_BUF_SIZE - nbytes,
+			  src->infile);
+
+      if ((got == EOF) || (got == 0))
+	{
+
+	  /* EOF or error. If we got any data, don't worry about it.
+	     If we didn't, then this is unexpected. */
+	  if (!nbytes)
+	    {
+
+	      nbytes = -1;
+
+	    }
+
+	  break;
+
+	}
+
+      nbytes += got;
+
+    }
+
+  if (nbytes <= 0)
+    {
+      if (src->start_of_file)	/* Treat empty input file as fatal error */
+	ERREXIT (cinfo, JERR_INPUT_EMPTY);
+      WARNMS (cinfo, JWRN_JPEG_EOF);
+      /* Insert a fake EOI marker */
+      src->buffer[0] = (unsigned char) 0xFF;
+      src->buffer[1] = (unsigned char) JPEG_EOI;
+      nbytes = 2;
+    }
+
+  src->pub.next_input_byte = src->buffer;
+  src->pub.bytes_in_buffer = nbytes;
+  src->start_of_file = FALSE;
+
+  return TRUE;
+}
+
+
+/*
+ * Skip data --- used to skip over a potentially large amount of
+ * uninteresting data (such as an APPn marker).
+ *
+ * Writers of suspendable-input applications must note that skip_input_data
+ * is not granted the right to give a suspension return.  If the skip extends
+ * beyond the data currently in the buffer, the buffer can be marked empty so
+ * that the next read will cause a fill_input_buffer call that can suspend.
+ * Arranging for additional bytes to be discarded before reloading the input
+ * buffer is the application writer's problem.
+ */
+
+void
+skip_input_data (j_decompress_ptr cinfo, long num_bytes)
+{
+  my_src_ptr src = (my_src_ptr) cinfo->src;
+
+  /* Just a dumb implementation for now. Not clear that being smart is worth
+   * any trouble anyway --- large skips are infrequent.
+   */
+  if (num_bytes > 0)
+    {
+      while (num_bytes > (long) src->pub.bytes_in_buffer)
+	{
+	  num_bytes -= (long) src->pub.bytes_in_buffer;
+	  (void) fill_input_buffer (cinfo);
+	  /* note we assume that fill_input_buffer will never return FALSE,
+	   * so suspension need not be handled.
+	   */
+	}
+      src->pub.next_input_byte += (size_t) num_bytes;
+      src->pub.bytes_in_buffer -= (size_t) num_bytes;
+    }
+}
+
+
+/*
+ * An additional method that can be provided by data source modules is the
+ * resync_to_restart method for error recovery in the presence of RST markers.
+ * For the moment, this source module just uses the default resync method
+ * provided by the JPEG library.  That method assumes that no backtracking
+ * is possible.
+ */
+
+
+/*
+ * Terminate source --- called by jpeg_finish_decompress
+ * after all data has been read.  Often a no-op.
+ *
+ * NB: *not* called by jpeg_abort or jpeg_destroy; surrounding
+ * application must deal with any cleanup that should happen even
+ * for error exit.
+ */
+
+void
+term_source (j_decompress_ptr cinfo)
+{
+
+#if 0
+/* never used */
+  my_src_ptr src = (my_src_ptr) cinfo->src;
+
+#endif
+}
+
+
+/*
+ * Prepare for input from a gdIOCtx stream.
+ * The caller must have already opened the stream, and is responsible
+ * for closing it after finishing decompression.
+ */
+
+void
+jpeg_gdIOCtx_src (j_decompress_ptr cinfo, gdIOCtx * infile)
+{
+  my_src_ptr src;
+
+  /* The source object and input buffer are made permanent so that a series
+   * of JPEG images can be read from the same file by calling jpeg_gdIOCtx_src
+   * only before the first one.  (If we discarded the buffer at the end of
+   * one image, we'd likely lose the start of the next one.)
+   * This makes it unsafe to use this manager and a different source
+   * manager serially with the same JPEG object.  Caveat programmer.
+   */
+  if (cinfo->src == NULL)
+    {				/* first time for this JPEG object? */
+      cinfo->src = (struct jpeg_source_mgr *)
+	(*cinfo->mem->alloc_small) ((j_common_ptr) cinfo, JPOOL_PERMANENT,
+				    sizeof (my_source_mgr));
+      src = (my_src_ptr) cinfo->src;
+      src->buffer = (unsigned char *)
+	(*cinfo->mem->alloc_small) ((j_common_ptr) cinfo, JPOOL_PERMANENT,
+				    INPUT_BUF_SIZE * sizeof (unsigned char));
+
+    }
+
+  src = (my_src_ptr) cinfo->src;
+  src->pub.init_source = init_source;
+  src->pub.fill_input_buffer = fill_input_buffer;
+  src->pub.skip_input_data = skip_input_data;
+  src->pub.resync_to_restart = jpeg_resync_to_restart;	/* use default method */
+  src->pub.term_source = term_source;
+  src->infile = infile;
+  src->pub.bytes_in_buffer = 0;	/* forces fill_input_buffer on first read */
+  src->pub.next_input_byte = NULL;	/* until buffer loaded */
+}
+
+/* Expanded data destination object for stdio output */
+
+typedef struct
+{
+  struct jpeg_destination_mgr pub;	/* public fields */
+  gdIOCtx *outfile;		/* target stream */
+  unsigned char *buffer;	/* start of buffer */
+}
+my_destination_mgr;
+
+typedef my_destination_mgr *my_dest_ptr;
+
+#define OUTPUT_BUF_SIZE  4096	/* choose an efficiently fwrite'able size */
+
+/*
+ * Initialize destination --- called by jpeg_start_compress
+ * before any data is actually written.
+ */
+
+void
+init_destination (j_compress_ptr cinfo)
+{
+  my_dest_ptr dest = (my_dest_ptr) cinfo->dest;
+
+  /* Allocate the output buffer --- it will be released when done with image */
+  dest->buffer = (unsigned char *)
+    (*cinfo->mem->alloc_small) ((j_common_ptr) cinfo, JPOOL_IMAGE,
+				OUTPUT_BUF_SIZE * sizeof (unsigned char));
+
+  dest->pub.next_output_byte = dest->buffer;
+  dest->pub.free_in_buffer = OUTPUT_BUF_SIZE;
+}
+
+
+/*
+ * Empty the output buffer --- called whenever buffer fills up.
+ *
+ * In typical applications, this should write the entire output buffer
+ * (ignoring the current state of next_output_byte & free_in_buffer),
+ * reset the pointer & count to the start of the buffer, and return TRUE
+ * indicating that the buffer has been dumped.
+ *
+ * In applications that need to be able to suspend compression due to output
+ * overrun, a FALSE return indicates that the buffer cannot be emptied now.
+ * In this situation, the compressor will return to its caller (possibly with
+ * an indication that it has not accepted all the supplied scanlines).  The
+ * application should resume compression after it has made more room in the
+ * output buffer.  Note that there are substantial restrictions on the use of
+ * suspension --- see the documentation.
+ *
+ * When suspending, the compressor will back up to a convenient restart point
+ * (typically the start of the current MCU). next_output_byte & free_in_buffer
+ * indicate where the restart point will be if the current call returns FALSE.
+ * Data beyond this point will be regenerated after resumption, so do not
+ * write it out when emptying the buffer externally.
+ */
+
+safeboolean
+empty_output_buffer (j_compress_ptr cinfo)
+{
+  my_dest_ptr dest = (my_dest_ptr) cinfo->dest;
+
+  if (gdPutBuf (dest->buffer, OUTPUT_BUF_SIZE, dest->outfile) !=
+      (size_t) OUTPUT_BUF_SIZE)
+    ERREXIT (cinfo, JERR_FILE_WRITE);
+
+  dest->pub.next_output_byte = dest->buffer;
+  dest->pub.free_in_buffer = OUTPUT_BUF_SIZE;
+
+  return TRUE;
+}
+
+
+/*
+ * Terminate destination --- called by jpeg_finish_compress
+ * after all data has been written.  Usually needs to flush buffer.
+ *
+ * NB: *not* called by jpeg_abort or jpeg_destroy; surrounding
+ * application must deal with any cleanup that should happen even
+ * for error exit.
+ */
+
+void
+term_destination (j_compress_ptr cinfo)
+{
+  my_dest_ptr dest = (my_dest_ptr) cinfo->dest;
+  size_t datacount = OUTPUT_BUF_SIZE - dest->pub.free_in_buffer;
+
+  /* Write any data remaining in the buffer */
+  if (datacount > 0)
+    {
+      if (gdPutBuf (dest->buffer, datacount, dest->outfile) != datacount)
+	ERREXIT (cinfo, JERR_FILE_WRITE);
+    }
+}
+
+
+/*
+ * Prepare for output to a stdio stream.
+ * The caller must have already opened the stream, and is responsible
+ * for closing it after finishing compression.
+ */
+
+void
+jpeg_gdIOCtx_dest (j_compress_ptr cinfo, gdIOCtx * outfile)
+{
+  my_dest_ptr dest;
+
+  /* The destination object is made permanent so that multiple JPEG images
+   * can be written to the same file without re-executing jpeg_stdio_dest.
+   * This makes it dangerous to use this manager and a different destination
+   * manager serially with the same JPEG object, because their private object
+   * sizes may be different.  Caveat programmer.
+   */
+  if (cinfo->dest == NULL)
+    {				/* first time for this JPEG object? */
+      cinfo->dest = (struct jpeg_destination_mgr *)
+	(*cinfo->mem->alloc_small) ((j_common_ptr) cinfo, JPOOL_PERMANENT,
+				    sizeof (my_destination_mgr));
+    }
+
+  dest = (my_dest_ptr) cinfo->dest;
+  dest->pub.init_destination = init_destination;
+  dest->pub.empty_output_buffer = empty_output_buffer;
+  dest->pub.term_destination = term_destination;
+  dest->outfile = outfile;
+}
+
+#endif /* HAVE_LIBJPEG */
diff --git a/collects/plot/src/all/gd_png.c b/collects/plot/src/all/gd_png.c
new file mode 100644
index 0000000000..44a1eb8796
--- /dev/null
+++ b/collects/plot/src/all/gd_png.c
@@ -0,0 +1,792 @@
+
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+
+#include <stdio.h>
+#include <math.h>
+#include <string.h>
+#include <stdlib.h>
+#include "gd.h"
+
+/* JCE: Arrange HAVE_LIBPNG so that it can be set in gd.h */
+#ifdef HAVE_LIBPNG
+
+#include "gdhelpers.h"
+#include "png.h"		/* includes zlib.h and setjmp.h */
+
+#define TRUE 1
+#define FALSE 0
+
+/*---------------------------------------------------------------------------
+
+    gd_png.c                 Copyright 1999 Greg Roelofs and Thomas Boutell
+
+    The routines in this file, gdImagePng*() and gdImageCreateFromPng*(),
+    are drop-in replacements for gdImageGif*() and gdImageCreateFromGif*(),
+    except that these functions are noisier in the case of errors (comment
+    out all fprintf() statements to disable that).
+
+    GD 2.0 supports RGBA truecolor and will read and write truecolor PNGs.
+    GD 2.0 supports 8 bits of color resolution per channel and 
+    7 bits of alpha channel resolution. Images with more than 8 bits
+    per channel are reduced to 8 bits. Images with an alpha channel are
+    only able to resolve down to '1/128th opaque' instead of '1/256th',
+    and this conversion is also automatic. I very much doubt you can see it.
+    Both tRNS and true alpha are supported.
+
+    Gamma is ignored, and there is no support for text annotations.
+
+    Last updated:  9 February 2001
+
+  ---------------------------------------------------------------------------*/
+
+#ifndef PNG_SETJMP_NOT_SUPPORTED
+typedef struct _jmpbuf_wrapper
+{
+  jmp_buf jmpbuf;
+}
+jmpbuf_wrapper;
+
+static jmpbuf_wrapper gdPngJmpbufStruct;
+
+static void
+gdPngErrorHandler (png_structp png_ptr, png_const_charp msg)
+{
+  jmpbuf_wrapper *jmpbuf_ptr;
+
+  /* This function, aside from the extra step of retrieving the "error
+   * pointer" (below) and the fact that it exists within the application
+   * rather than within libpng, is essentially identical to libpng's
+   * default error handler.  The second point is critical:  since both
+   * setjmp() and longjmp() are called from the same code, they are
+   * guaranteed to have compatible notions of how big a jmp_buf is,
+   * regardless of whether _BSD_SOURCE or anything else has (or has not)
+   * been defined. */
+
+  fprintf (stderr, "gd-png:  fatal libpng error: %s\n", msg);
+  fflush (stderr);
+
+  jmpbuf_ptr = png_get_error_ptr (png_ptr);
+  if (jmpbuf_ptr == NULL)
+    {				/* we are completely hosed now */
+      fprintf (stderr,
+	       "gd-png:  EXTREMELY fatal error: jmpbuf unrecoverable; terminating.\n");
+      fflush (stderr);
+      exit (99);
+    }
+
+  longjmp (jmpbuf_ptr->jmpbuf, 1);
+}
+#endif
+
+static void
+gdPngReadData (png_structp png_ptr, png_bytep data, png_size_t length)
+{
+  gdGetBuf (data, length, (gdIOCtx *) png_get_io_ptr (png_ptr));
+}
+
+static void
+gdPngWriteData (png_structp png_ptr, png_bytep data, png_size_t length)
+{
+  gdPutBuf (data, length, (gdIOCtx *) png_get_io_ptr (png_ptr));
+}
+
+static void
+gdPngFlushData (png_structp png_ptr)
+{
+}
+
+gdImagePtr
+gdImageCreateFromPng (FILE * inFile)
+{
+  gdImagePtr im;
+  gdIOCtx *in = gdNewFileCtx (inFile);
+  im = gdImageCreateFromPngCtx (in);
+  in->gd_free (in);
+  return im;
+}
+
+
+/* This routine is based in part on the Chapter 13 demo code in "PNG: The
+ *  Definitive Guide" (http://www.cdrom.com/pub/png/pngbook.html).
+ */
+gdImagePtr
+gdImageCreateFromPngCtx (gdIOCtx * infile)
+{
+  png_byte sig[8];
+  png_structp png_ptr;
+  png_infop info_ptr;
+  png_uint_32 width, height, rowbytes;
+  int bit_depth, color_type, interlace_type;
+  int num_palette, num_trans;
+  png_colorp palette;
+  png_color_16p trans_gray_rgb;
+  png_color_16p trans_color_rgb;
+  png_bytep trans;
+  png_bytep image_data = NULL;
+  png_bytepp row_pointers = NULL;
+  gdImagePtr im = NULL;
+  int i, j, *open = NULL;
+  volatile int transparent = -1;
+  volatile int palette_allocated = FALSE;
+
+  /* Make sure the signature can't match by dumb luck -- TBB */
+  /* GRR: isn't sizeof(infile) equal to the size of the pointer? */
+  memset (infile, 0, sizeof (infile));
+
+  /* first do a quick check that the file really is a PNG image; could
+   * have used slightly more general png_sig_cmp() function instead */
+  gdGetBuf (sig, 8, infile);
+  if (!png_check_sig (sig, 8))
+    return NULL;		/* bad signature */
+
+#ifndef PNG_SETJMP_NOT_SUPPORTED
+  png_ptr = png_create_read_struct (PNG_LIBPNG_VER_STRING, &gdPngJmpbufStruct,
+				    gdPngErrorHandler, NULL);
+#else
+  png_ptr = png_create_read_struct (PNG_LIBPNG_VER_STRING, NULL, NULL, NULL);
+#endif
+  if (png_ptr == NULL)
+    {
+      fprintf (stderr, "gd-png error: cannot allocate libpng main struct\n");
+      return NULL;
+    }
+
+  info_ptr = png_create_info_struct (png_ptr);
+  if (info_ptr == NULL)
+    {
+      fprintf (stderr, "gd-png error: cannot allocate libpng info struct\n");
+      png_destroy_read_struct (&png_ptr, NULL, NULL);
+      return NULL;
+    }
+
+  /* we could create a second info struct here (end_info), but it's only
+   * useful if we want to keep pre- and post-IDAT chunk info separated
+   * (mainly for PNG-aware image editors and converters) */
+
+  /* setjmp() must be called in every non-callback function that calls a
+   * PNG-reading libpng function */
+#ifndef PNG_SETJMP_NOT_SUPPORTED
+  if (setjmp (gdPngJmpbufStruct.jmpbuf))
+    {
+      fprintf (stderr, "gd-png error: setjmp returns error condition\n");
+      png_destroy_read_struct (&png_ptr, &info_ptr, NULL);
+      return NULL;
+    }
+#endif
+
+  png_set_sig_bytes (png_ptr, 8);	/* we already read the 8 signature bytes */
+
+  png_set_read_fn (png_ptr, (void *) infile, gdPngReadData);
+  png_read_info (png_ptr, info_ptr);	/* read all PNG info up to image data */
+
+  png_get_IHDR (png_ptr, info_ptr, &width, &height, &bit_depth, &color_type,
+		&interlace_type, NULL, NULL);
+  if ((color_type == PNG_COLOR_TYPE_RGB) ||
+      (color_type == PNG_COLOR_TYPE_RGB_ALPHA))
+    {
+      im = gdImageCreateTrueColor ((int) width, (int) height);
+    }
+  else
+    {
+      im = gdImageCreate ((int) width, (int) height);
+    }
+  if (im == NULL)
+    {
+      fprintf (stderr, "gd-png error: cannot allocate gdImage struct\n");
+      png_destroy_read_struct (&png_ptr, &info_ptr, NULL);
+      gdFree (image_data);
+      gdFree (row_pointers);
+      return NULL;
+    }
+
+  if (bit_depth == 16)
+    png_set_strip_16 (png_ptr);
+  else if (bit_depth < 8)
+    png_set_packing (png_ptr);	/* expand to 1 byte per pixel */
+  switch (color_type)
+    {
+    case PNG_COLOR_TYPE_PALETTE:
+      png_get_PLTE (png_ptr, info_ptr, &palette, &num_palette);
+#ifdef DEBUG
+      fprintf (stderr, "gd-png color_type is palette, colors: %d\n",
+	       num_palette);
+#endif /* DEBUG */
+      if (png_get_valid (png_ptr, info_ptr, PNG_INFO_tRNS))
+	{
+	  /* gd 2.0: we support this rather thoroughly now. Grab the
+	     first fully transparent entry, if any, as the value of 
+	     the simple-transparency index, mostly for backwards
+	     binary compatibility. The alpha channel is where it's
+	     really at these days. */
+	  int firstZero = 1;
+	  png_get_tRNS (png_ptr, info_ptr, &trans, &num_trans, NULL);
+	  for (i = 0; i < num_trans; ++i)
+	    {
+	      im->alpha[i] = gdAlphaMax - (trans[i] >> 1);
+	      if ((trans[i] == 0) && (firstZero))
+		{
+		  /* 2.0.5: long-forgotten patch from Wez Furlong */
+		  transparent = i;
+		  firstZero = 0;
+		}
+	    }
+	}
+      break;
+
+    case PNG_COLOR_TYPE_GRAY:
+    case PNG_COLOR_TYPE_GRAY_ALPHA:
+      /* create a fake palette and check for single-shade transparency */
+      if ((palette =
+	   (png_colorp) gdMalloc (256 * sizeof (png_color))) == NULL)
+	{
+	  fprintf (stderr, "gd-png error: cannot allocate gray palette\n");
+	  png_destroy_read_struct (&png_ptr, &info_ptr, NULL);
+	  return NULL;
+	}
+      palette_allocated = TRUE;
+      if (bit_depth < 8)
+	{
+	  num_palette = 1 << bit_depth;
+	  for (i = 0; i < 256; ++i)
+	    {
+	      j = (255 * i) / (num_palette - 1);
+	      palette[i].red = palette[i].green = palette[i].blue = j;
+	    }
+	}
+      else
+	{
+	  num_palette = 256;
+	  for (i = 0; i < 256; ++i)
+	    {
+	      palette[i].red = palette[i].green = palette[i].blue = i;
+	    }
+	}
+      if (png_get_valid (png_ptr, info_ptr, PNG_INFO_tRNS))
+	{
+	  png_get_tRNS (png_ptr, info_ptr, NULL, NULL, &trans_gray_rgb);
+	  if (bit_depth == 16)	/* png_set_strip_16() not yet in effect */
+	    transparent = trans_gray_rgb->gray >> 8;
+	  else
+	    transparent = trans_gray_rgb->gray;
+	  /* Note slight error in 16-bit case:  up to 256 16-bit shades
+	   * may get mapped to a single 8-bit shade, and only one of them
+	   * is supposed to be transparent.  IOW, both opaque pixels and
+	   * transparent pixels will be mapped into the transparent entry.
+	   * There is no particularly good way around this in the case
+	   * that all 256 8-bit shades are used, but one could write some
+	   * custom 16-bit code to handle the case where there are gdFree
+	   * palette entries.  This error will be extremely rare in
+	   * general, though.  (Quite possibly there is only one such
+	   * image in existence.) */
+	}
+      break;
+
+    case PNG_COLOR_TYPE_RGB:
+    case PNG_COLOR_TYPE_RGB_ALPHA:
+      /* gd 2.0: we now support truecolor. See the comment above
+         for a rare situation in which the transparent pixel may not
+         work properly with 16-bit channels. */
+      if (png_get_valid (png_ptr, info_ptr, PNG_INFO_tRNS))
+	{
+	  png_get_tRNS (png_ptr, info_ptr, NULL, NULL, &trans_color_rgb);
+	  if (bit_depth == 16)	/* png_set_strip_16() not yet in effect */
+	    transparent = gdTrueColor (trans_color_rgb->red >> 8,
+				       trans_color_rgb->green >> 8,
+				       trans_color_rgb->blue >> 8);
+	  else
+	    transparent = gdTrueColor (trans_color_rgb->red,
+				       trans_color_rgb->green,
+				       trans_color_rgb->blue);
+	}
+      break;
+    }
+
+  png_read_update_info (png_ptr, info_ptr);
+
+  /* allocate space for the PNG image data */
+  rowbytes = png_get_rowbytes (png_ptr, info_ptr);
+  if ((image_data = (png_bytep) gdMalloc (rowbytes * height)) == NULL)
+    {
+      fprintf (stderr, "gd-png error: cannot allocate image data\n");
+      png_destroy_read_struct (&png_ptr, &info_ptr, NULL);
+      return NULL;
+    }
+  if ((row_pointers =
+       (png_bytepp) gdMalloc (height * sizeof (png_bytep))) == NULL)
+    {
+      fprintf (stderr, "gd-png error: cannot allocate row pointers\n");
+      png_destroy_read_struct (&png_ptr, &info_ptr, NULL);
+      gdFree (image_data);
+      return NULL;
+    }
+
+  /* set the individual row_pointers to point at the correct offsets */
+  for (j = 0; j < height; ++j)
+    {
+      row_pointers[j] = image_data + j * rowbytes;
+    }
+
+  png_read_image (png_ptr, row_pointers);	/* read whole image... */
+  png_read_end (png_ptr, NULL);	/* ...done! */
+
+  if (!im->trueColor)
+    {
+      im->colorsTotal = num_palette;
+      /* load the palette and mark all entries "open" (unused) for now */
+      open = im->open;
+      for (i = 0; i < num_palette; ++i)
+	{
+	  im->red[i] = palette[i].red;
+	  im->green[i] = palette[i].green;
+	  im->blue[i] = palette[i].blue;
+	  open[i] = 1;
+	}
+      for (i = num_palette; i < gdMaxColors; ++i)
+	{
+	  open[i] = 1;
+	}
+    }
+  /* 2.0.12: Slaven Rezic: palette images are not the only images
+     with a simple transparent color setting */
+  im->transparent = transparent;
+  im->interlace = (interlace_type == PNG_INTERLACE_ADAM7);
+
+  /* can't nuke structs until done with palette */
+  png_destroy_read_struct (&png_ptr, &info_ptr, NULL);
+  switch (color_type)
+    {
+    case PNG_COLOR_TYPE_RGB:
+      for (j = 0; j < height; j++)
+	{
+	  int boffset = 0;
+	  for (i = 0; i < width; i++)
+	    {
+	      register png_byte r = row_pointers[j][boffset++];
+	      register png_byte g = row_pointers[j][boffset++];
+	      register png_byte b = row_pointers[j][boffset++];
+	      im->tpixels[j][i] = gdTrueColor (r, g, b);
+	    }
+	}
+      break;
+    case PNG_COLOR_TYPE_RGB_ALPHA:
+      for (j = 0; j < height; j++)
+	{
+	  int boffset = 0;
+	  for (i = 0; i < width; i++)
+	    {
+	      register png_byte r = row_pointers[j][boffset++];
+	      register png_byte g = row_pointers[j][boffset++];
+	      register png_byte b = row_pointers[j][boffset++];
+	      /* gd has only 7 bits of alpha channel resolution, and
+	         127 is transparent, 0 opaque. A moment of convenience, 
+	         a lifetime of compatibility. */
+	      register png_byte a = gdAlphaMax -
+		(row_pointers[j][boffset++] >> 1);
+	      im->tpixels[j][i] = gdTrueColorAlpha (r, g, b, a);
+	    }
+	}
+      break;
+    default:
+      /* Palette image, or something coerced to be one */
+      for (j = 0; j < height; ++j)
+	{
+	  for (i = 0; i < width; ++i)
+	    {
+	      register png_byte idx = row_pointers[j][i];
+	      im->pixels[j][i] = idx;
+	      open[idx] = 0;
+	    }
+	}
+    }
+#ifdef DEBUG
+  if (!im->trueColor)
+    {
+      for (i = num_palette; i < gdMaxColors; ++i)
+	{
+	  if (!open[i])
+	    {
+	      fprintf (stderr,
+		       "gd-png warning: image data references out-of-range"
+		       " color index (%d)\n", i);
+	    }
+	}
+    }
+#endif
+
+  if (palette_allocated)
+    gdFree (palette);
+  gdFree (image_data);
+  gdFree (row_pointers);
+
+  return im;
+}
+
+
+void
+gdImagePngEx (gdImagePtr im, FILE * outFile, int level)
+{
+  gdIOCtx *out = gdNewFileCtx (outFile);
+  gdImagePngCtxEx (im, out, level);
+  out->gd_free (out);
+}
+
+void
+gdImagePng (gdImagePtr im, FILE * outFile)
+{
+  gdIOCtx *out = gdNewFileCtx (outFile);
+  gdImagePngCtxEx (im, out, -1);
+  out->gd_free (out);
+}
+
+void *
+gdImagePngPtr (gdImagePtr im, int *size)
+{
+  void *rv;
+  gdIOCtx *out = gdNewDynamicCtx (2048, NULL);
+  gdImagePngCtxEx (im, out, -1);
+  rv = gdDPExtractData (out, size);
+  out->gd_free (out);
+  return rv;
+}
+
+void *
+gdImagePngPtrEx (gdImagePtr im, int *size, int level)
+{
+  void *rv;
+  gdIOCtx *out = gdNewDynamicCtx (2048, NULL);
+  gdImagePngCtxEx (im, out, level);
+  rv = gdDPExtractData (out, size);
+  out->gd_free (out);
+  return rv;
+}
+
+void
+gdImagePngCtx (gdImagePtr im, gdIOCtx * outfile)
+{
+  /* 2.0.13: 'return' here was an error, thanks to Kevin Smith */
+  gdImagePngCtxEx (im, outfile, -1);
+}
+
+/* This routine is based in part on code from Dale Lutz (Safe Software Inc.)
+ *  and in part on demo code from Chapter 15 of "PNG: The Definitive Guide"
+ *  (http://www.cdrom.com/pub/png/pngbook.html).
+ */
+void
+gdImagePngCtxEx (gdImagePtr im, gdIOCtx * outfile, int level)
+{
+  int i, j, bit_depth = 0, interlace_type;
+  int width = im->sx;
+  int height = im->sy;
+  int colors = im->colorsTotal;
+  int *open = im->open;
+  int mapping[gdMaxColors];	/* mapping[gd_index] == png_index */
+  png_byte trans_values[256];
+  png_color_16 trans_rgb_value;
+  png_color palette[gdMaxColors];
+  png_structp png_ptr;
+  png_infop info_ptr;
+  volatile int transparent = im->transparent;
+  volatile int remap = FALSE;
+
+
+#ifndef PNG_SETJMP_NOT_SUPPORTED
+  png_ptr = png_create_write_struct (PNG_LIBPNG_VER_STRING,
+				     &gdPngJmpbufStruct, gdPngErrorHandler,
+				     NULL);
+#else
+  png_ptr = png_create_write_struct (PNG_LIBPNG_VER_STRING, NULL, NULL, NULL);
+#endif
+  if (png_ptr == NULL)
+    {
+      fprintf (stderr, "gd-png error: cannot allocate libpng main struct\n");
+      return;
+    }
+
+  info_ptr = png_create_info_struct (png_ptr);
+  if (info_ptr == NULL)
+    {
+      fprintf (stderr, "gd-png error: cannot allocate libpng info struct\n");
+      png_destroy_write_struct (&png_ptr, (png_infopp) NULL);
+      return;
+    }
+
+#ifndef PNG_SETJMP_NOT_SUPPORTED
+  if (setjmp (gdPngJmpbufStruct.jmpbuf))
+    {
+      fprintf (stderr, "gd-png error: setjmp returns error condition\n");
+      png_destroy_write_struct (&png_ptr, &info_ptr);
+      return;
+    }
+#endif
+
+  png_set_write_fn (png_ptr, (void *) outfile, gdPngWriteData,
+		    gdPngFlushData);
+
+  /* This is best for palette images, and libpng defaults to it for
+     palette images anyway, so we don't need to do it explicitly.
+     What to ideally do for truecolor images depends, alas, on the image.
+     gd is intentionally imperfect and doesn't spend a lot of time
+     fussing with such things. */
+/*  png_set_filter(png_ptr, 0, PNG_FILTER_NONE);  */
+
+  /* 2.0.12: this is finally a parameter */
+  png_set_compression_level (png_ptr, level);
+
+  /* can set this to a smaller value without compromising compression if all
+   * image data is 16K or less; will save some decoder memory [min == 8] */
+/*  png_set_compression_window_bits(png_ptr, 15);  */
+
+  if (!im->trueColor)
+    {
+      if (transparent >= im->colorsTotal ||
+	  (transparent >= 0 && open[transparent]))
+	transparent = -1;
+    }
+  if (!im->trueColor)
+    {
+      for (i = 0; i < gdMaxColors; ++i)
+	mapping[i] = -1;
+    }
+  if (!im->trueColor)
+    {
+      /* count actual number of colors used (colorsTotal == high-water mark) */
+      colors = 0;
+      for (i = 0; i < im->colorsTotal; ++i)
+	{
+	  if (!open[i])
+	    {
+	      mapping[i] = colors;
+	      ++colors;
+	    }
+	}
+      if (colors < im->colorsTotal)
+	{
+	  remap = TRUE;
+	}
+      if (colors <= 2)
+	bit_depth = 1;
+      else if (colors <= 4)
+	bit_depth = 2;
+      else if (colors <= 16)
+	bit_depth = 4;
+      else
+	bit_depth = 8;
+    }
+  interlace_type = im->interlace ? PNG_INTERLACE_ADAM7 : PNG_INTERLACE_NONE;
+
+  if (im->trueColor)
+    {
+      if (im->saveAlphaFlag)
+	{
+	  png_set_IHDR (png_ptr, info_ptr, width, height, 8,
+			PNG_COLOR_TYPE_RGB_ALPHA, interlace_type,
+			PNG_COMPRESSION_TYPE_DEFAULT,
+			PNG_FILTER_TYPE_DEFAULT);
+	}
+      else
+	{
+	  png_set_IHDR (png_ptr, info_ptr, width, height, 8,
+			PNG_COLOR_TYPE_RGB, interlace_type,
+			PNG_COMPRESSION_TYPE_DEFAULT,
+			PNG_FILTER_TYPE_DEFAULT);
+	}
+    }
+  else
+    {
+      png_set_IHDR (png_ptr, info_ptr, width, height, bit_depth,
+		    PNG_COLOR_TYPE_PALETTE, interlace_type,
+		    PNG_COMPRESSION_TYPE_DEFAULT, PNG_FILTER_TYPE_DEFAULT);
+    }
+  if (im->trueColor && (!im->saveAlphaFlag) && (transparent >= 0))
+    {
+      /* 2.0.9: fixed by Thomas Winzig */
+      trans_rgb_value.red = gdTrueColorGetRed (im->transparent);
+      trans_rgb_value.green = gdTrueColorGetGreen (im->transparent);
+      trans_rgb_value.blue = gdTrueColorGetBlue (im->transparent);
+      png_set_tRNS (png_ptr, info_ptr, 0, 0, &trans_rgb_value);
+    }
+  if (!im->trueColor)
+    {
+      /* Oy veh. Remap the PNG palette to put the 
+         entries with interesting alpha channel
+         values first. This minimizes the size
+         of the tRNS chunk and thus the size
+         of the PNG file as a whole. */
+      int tc = 0;
+      int i;
+      int j;
+      int k;
+      for (i = 0; (i < im->colorsTotal); i++)
+	{
+	  if ((!im->open[i]) && (im->alpha[i] != gdAlphaOpaque))
+	    {
+	      tc++;
+	    }
+	}
+      if (tc)
+	{
+#if 0
+	  for (i = 0; (i < im->colorsTotal); i++)
+	    {
+	      trans_values[i] = 255 -
+		((im->alpha[i] << 1) + (im->alpha[i] >> 6));
+	    }
+	  png_set_tRNS (png_ptr, info_ptr, trans_values, 256, NULL);
+#endif
+	  if (!remap)
+	    {
+	      remap = TRUE;
+	    }
+	  /* (Semi-)transparent indexes come up from the bottom
+	     of the list of real colors; opaque
+	     indexes come down from the top */
+	  j = 0;
+	  k = colors - 1;
+	  for (i = 0; (i < im->colorsTotal); i++)
+	    {
+	      if (!im->open[i])
+		{
+		  if (im->alpha[i] != gdAlphaOpaque)
+		    {
+		      /* Andrew Hull: >> 6, not >> 7! (gd 2.0.5) */
+		      trans_values[j] = 255 -
+			((im->alpha[i] << 1) + (im->alpha[i] >> 6));
+		      mapping[i] = j++;
+		    }
+		  else
+		    {
+		      mapping[i] = k--;
+		    }
+		}
+	    }
+	  png_set_tRNS (png_ptr, info_ptr, trans_values, tc, NULL);
+	}
+    }
+
+  /* convert palette to libpng layout */
+  if (!im->trueColor)
+    {
+      if (remap)
+	for (i = 0; i < im->colorsTotal; ++i)
+	  {
+	    if (mapping[i] < 0)
+	      continue;
+	    palette[mapping[i]].red = im->red[i];
+	    palette[mapping[i]].green = im->green[i];
+	    palette[mapping[i]].blue = im->blue[i];
+	  }
+      else
+	for (i = 0; i < colors; ++i)
+	  {
+	    palette[i].red = im->red[i];
+	    palette[i].green = im->green[i];
+	    palette[i].blue = im->blue[i];
+	  }
+      png_set_PLTE (png_ptr, info_ptr, palette, colors);
+    }
+
+  /* write out the PNG header info (everything up to first IDAT) */
+  png_write_info (png_ptr, info_ptr);
+
+  /* make sure < 8-bit images are packed into pixels as tightly as possible */
+  png_set_packing (png_ptr);
+
+  /* This code allocates a set of row buffers and copies the gd image data
+   * into them only in the case that remapping is necessary; in gd 1.3 and
+   * later, the im->pixels array is laid out identically to libpng's row
+   * pointers and can be passed to png_write_image() function directly.
+   * The remapping case could be accomplished with less memory for non-
+   * interlaced images, but interlacing causes some serious complications. */
+  if (im->trueColor)
+    {
+      int channels = im->saveAlphaFlag ? 4 : 3;
+      /* Our little 7-bit alpha channel trick costs us a bit here. */
+      png_bytep *row_pointers;
+      row_pointers = gdMalloc (sizeof (png_bytep) * height);
+      if (row_pointers == NULL)
+	{
+	  fprintf (stderr, "gd-png error: unable to allocate row_pointers\n");
+	}
+      for (j = 0; j < height; ++j)
+	{
+	  int bo = 0;
+	  if ((row_pointers[j] =
+	       (png_bytep) gdMalloc (width * channels)) == NULL)
+	    {
+	      fprintf (stderr, "gd-png error: unable to allocate rows\n");
+	      for (i = 0; i < j; ++i)
+		gdFree (row_pointers[i]);
+	      return;
+	    }
+	  for (i = 0; i < width; ++i)
+	    {
+	      unsigned char a;
+	      row_pointers[j][bo++] = gdTrueColorGetRed (im->tpixels[j][i]);
+	      row_pointers[j][bo++] = gdTrueColorGetGreen (im->tpixels[j][i]);
+	      row_pointers[j][bo++] = gdTrueColorGetBlue (im->tpixels[j][i]);
+	      if (im->saveAlphaFlag)
+		{
+		  /* convert the 7-bit alpha channel to an 8-bit alpha channel.
+		     We do a little bit-flipping magic, repeating the MSB
+		     as the LSB, to ensure that 0 maps to 0 and
+		     127 maps to 255. We also have to invert to match
+		     PNG's convention in which 255 is opaque. */
+		  a = gdTrueColorGetAlpha (im->tpixels[j][i]);
+		  /* Andrew Hull: >> 6, not >> 7! (gd 2.0.5) */
+		  row_pointers[j][bo++] = 255 - ((a << 1) + (a >> 6));
+		}
+	    }
+	}
+
+      png_write_image (png_ptr, row_pointers);
+      png_write_end (png_ptr, info_ptr);
+
+      for (j = 0; j < height; ++j)
+	gdFree (row_pointers[j]);
+      gdFree (row_pointers);
+    }
+  else
+    {
+      if (remap)
+	{
+	  png_bytep *row_pointers;
+	  row_pointers = gdMalloc (sizeof (png_bytep) * height);
+	  if (row_pointers == NULL)
+	    {
+	      fprintf (stderr,
+		       "gd-png error: unable to allocate row_pointers\n");
+	    }
+	  for (j = 0; j < height; ++j)
+	    {
+	      if ((row_pointers[j] = (png_bytep) gdMalloc (width)) == NULL)
+		{
+		  fprintf (stderr, "gd-png error: unable to allocate rows\n");
+		  for (i = 0; i < j; ++i)
+		    gdFree (row_pointers[i]);
+		  return;
+		}
+	      for (i = 0; i < width; ++i)
+		row_pointers[j][i] = mapping[im->pixels[j][i]];
+	    }
+
+	  png_write_image (png_ptr, row_pointers);
+	  png_write_end (png_ptr, info_ptr);
+
+	  for (j = 0; j < height; ++j)
+	    gdFree (row_pointers[j]);
+	  gdFree (row_pointers);
+	}
+      else
+	{
+	  png_write_image (png_ptr, im->pixels);
+	  png_write_end (png_ptr, info_ptr);
+	}
+    }
+  /* 1.6.3: maybe we should give that memory BACK! TBB */
+  png_destroy_write_struct (&png_ptr, &info_ptr);
+}
+
+
+#endif /* HAVE_LIBPNG */
diff --git a/collects/plot/src/all/gd_ss.c b/collects/plot/src/all/gd_ss.c
new file mode 100644
index 0000000000..e16417004e
--- /dev/null
+++ b/collects/plot/src/all/gd_ss.c
@@ -0,0 +1,58 @@
+
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+
+#include <stdio.h>
+#include <math.h>
+#include <string.h>
+#include <stdlib.h>
+#include "gd.h"
+
+#define TRUE 1
+#define FALSE 0
+
+/* Exported functions: */
+extern void gdImagePngToSink (gdImagePtr im, gdSinkPtr out);
+extern gdImagePtr gdImageCreateFromPngSource (gdSourcePtr inSource);
+
+/* Use this for commenting out debug-print statements. */
+/* Just use the first '#define' to allow all the prints... */
+/*#define GD_SS_DBG(s) (s) */
+#define GD_SS_DBG(s)
+
+#ifdef HAVE_LIBPNG
+void
+gdImagePngToSink (gdImagePtr im, gdSinkPtr outSink)
+{
+  gdIOCtx *out = gdNewSSCtx (NULL, outSink);
+  gdImagePngCtx (im, out);
+  out->gd_free (out);
+}
+
+gdImagePtr
+gdImageCreateFromPngSource (gdSourcePtr inSource)
+{
+  gdIOCtx *in = gdNewSSCtx (inSource, NULL);
+  gdImagePtr im;
+
+  im = gdImageCreateFromPngCtx (in);
+
+  in->gd_free (in);
+
+  return im;
+}
+#else /* no HAVE_LIBPNG */
+void
+gdImagePngToSink (gdImagePtr im, gdSinkPtr outSink)
+{
+  fprintf (stderr, "PNG support is not available\n");
+}
+
+gdImagePtr
+gdImageCreateFromPngSource (gdSourcePtr inSource)
+{
+  fprintf (stderr, "PNG support is not available\n");
+  return NULL;
+}
+#endif /* HAVE_LIBPNG */
diff --git a/collects/plot/src/all/gd_topal.c b/collects/plot/src/all/gd_topal.c
new file mode 100644
index 0000000000..e1e0612410
--- /dev/null
+++ b/collects/plot/src/all/gd_topal.c
@@ -0,0 +1,2010 @@
+/* 2.0.12: a new adaptation from the same original, this time
+	by Barend Gehrels. My attempt to incorporate alpha channel
+	into the result worked poorly and degraded the quality of
+	palette conversion even when the source contained no
+	alpha channel data. This version does not attempt to produce
+	an output file with transparency in some of the palette
+	indexes, which, in practice, doesn't look so hot anyway. TBB */
+
+/*
+ * gd_topal, adapted from jquant2.c
+ *
+ * Copyright (C) 1991-1996, Thomas G. Lane.
+ * This file is part of the Independent JPEG Group's software.
+ * For conditions of distribution and use, see the accompanying README file.
+ *
+ * This file contains 2-pass color quantization (color mapping) routines.
+ * These routines provide selection of a custom color map for an image,
+ * followed by mapping of the image to that color map, with optional
+ * Floyd-Steinberg dithering.
+ * It is also possible to use just the second pass to map to an arbitrary
+ * externally-given color map.
+ *
+ * Note: ordered dithering is not supported, since there isn't any fast
+ * way to compute intercolor distances; it's unclear that ordered dither's
+ * fundamental assumptions even hold with an irregularly spaced color map.
+ */
+
+#ifdef ORIGINAL_LIB_JPEG
+
+#define JPEG_INTERNALS
+
+#include "jinclude.h"
+#include "jpeglib.h"
+
+#else
+
+/*
+ * THOMAS BOUTELL & BAREND GEHRELS, february 2003
+ * adapted the code to work within gd rather than within libjpeg.
+ * If it is not working, it's not Thomas G. Lane's fault.
+ */
+
+/* 
+  SETTING THIS ONE CAUSES STRIPED IMAGE
+  to be done: solve this
+  #define ORIGINAL_LIB_JPEG_REVERSE_ODD_ROWS
+ */
+
+#include <string.h>
+#include "gd.h"
+#include "gdhelpers.h"
+
+/* (Re)define some defines known by libjpeg */
+#define QUANT_2PASS_SUPPORTED
+
+#define RGB_RED		0
+#define RGB_GREEN	1
+#define RGB_BLUE	2
+
+#define JSAMPLE unsigned char
+#define MAXJSAMPLE (gdMaxColors-1)
+#define BITS_IN_JSAMPLE 8
+
+#define JSAMPROW int*
+#define JDIMENSION int
+
+#define METHODDEF(type) static type
+#define LOCAL(type)	static type
+
+
+/* We assume that right shift corresponds to signed division by 2 with
+ * rounding towards minus infinity.  This is correct for typical "arithmetic
+ * shift" instructions that shift in copies of the sign bit.  But some
+ * C compilers implement >> with an unsigned shift.  For these machines you
+ * must define RIGHT_SHIFT_IS_UNSIGNED.
+ * RIGHT_SHIFT provides a proper signed right shift of an INT32 quantity.
+ * It is only applied with constant shift counts.  SHIFT_TEMPS must be
+ * included in the variables of any routine using RIGHT_SHIFT.
+ */
+
+#ifdef RIGHT_SHIFT_IS_UNSIGNED
+#define SHIFT_TEMPS	INT32 shift_temp;
+#define RIGHT_SHIFT(x,shft)  \
+	((shift_temp = (x)) < 0 ? \
+	 (shift_temp >> (shft)) | ((~((INT32) 0)) << (32-(shft))) : \
+	 (shift_temp >> (shft)))
+#else
+#define SHIFT_TEMPS
+#define RIGHT_SHIFT(x,shft)	((x) >> (shft))
+#endif
+
+
+#define range_limit(x) { if(x<0) x=0; if (x>255) x=255; }
+
+
+#ifndef INT16
+#define INT16  short
+#endif
+
+#ifndef UINT16
+#define UINT16 unsigned short
+#endif
+
+#ifndef INT32
+#define INT32 int
+#endif
+
+#ifndef FAR
+#define FAR
+#endif
+
+
+
+#ifndef boolean
+#define boolean int
+#endif
+
+#ifndef TRUE
+#define TRUE 1
+#endif
+
+#ifndef FALSE
+#define FALSE 0
+#endif
+
+
+#define input_buf (im->tpixels)
+#define output_buf (im->pixels)
+
+#endif
+
+#ifdef QUANT_2PASS_SUPPORTED
+
+
+/*
+ * This module implements the well-known Heckbert paradigm for color
+ * quantization.  Most of the ideas used here can be traced back to
+ * Heckbert's seminal paper
+ *   Heckbert, Paul.  "Color Image Quantization for Frame Buffer Display",
+ *   Proc. SIGGRAPH '82, Computer Graphics v.16 #3 (July 1982), pp 297-304.
+ *
+ * In the first pass over the image, we accumulate a histogram showing the
+ * usage count of each possible color.  To keep the histogram to a reasonable
+ * size, we reduce the precision of the input; typical practice is to retain
+ * 5 or 6 bits per color, so that 8 or 4 different input values are counted
+ * in the same histogram cell.
+ *
+ * Next, the color-selection step begins with a box representing the whole
+ * color space, and repeatedly splits the "largest" remaining box until we
+ * have as many boxes as desired colors.  Then the mean color in each
+ * remaining box becomes one of the possible output colors.
+ * 
+ * The second pass over the image maps each input pixel to the closest output
+ * color (optionally after applying a Floyd-Steinberg dithering correction).
+ * This mapping is logically trivial, but making it go fast enough requires
+ * considerable care.
+ *
+ * Heckbert-style quantizers vary a good deal in their policies for choosing
+ * the "largest" box and deciding where to cut it.  The particular policies
+ * used here have proved out well in experimental comparisons, but better ones
+ * may yet be found.
+ *
+ * In earlier versions of the IJG code, this module quantized in YCbCr color
+ * space, processing the raw upsampled data without a color conversion step.
+ * This allowed the color conversion math to be done only once per colormap
+ * entry, not once per pixel.  However, that optimization precluded other
+ * useful optimizations (such as merging color conversion with upsampling)
+ * and it also interfered with desired capabilities such as quantizing to an
+ * externally-supplied colormap.  We have therefore abandoned that approach.
+ * The present code works in the post-conversion color space, typically RGB.
+ *
+ * To improve the visual quality of the results, we actually work in scaled
+ * RGB space, giving G distances more weight than R, and R in turn more than
+ * B.  To do everything in integer math, we must use integer scale factors.
+ * The 2/3/1 scale factors used here correspond loosely to the relative
+ * weights of the colors in the NTSC grayscale equation.
+ * If you want to use this code to quantize a non-RGB color space, you'll
+ * probably need to change these scale factors.
+ */
+
+#define R_SCALE 2		/* scale R distances by this much */
+#define G_SCALE 3		/* scale G distances by this much */
+#define B_SCALE 1		/* and B by this much */
+
+/* Relabel R/G/B as components 0/1/2, respecting the RGB ordering defined
+ * in jmorecfg.h.  As the code stands, it will do the right thing for R,G,B
+ * and B,G,R orders.  If you define some other weird order in jmorecfg.h,
+ * you'll get compile errors until you extend this logic.  In that case
+ * you'll probably want to tweak the histogram sizes too.
+ */
+
+#if RGB_RED == 0
+#define C0_SCALE R_SCALE
+#endif
+#if RGB_BLUE == 0
+#define C0_SCALE B_SCALE
+#endif
+#if RGB_GREEN == 1
+#define C1_SCALE G_SCALE
+#endif
+#if RGB_RED == 2
+#define C2_SCALE R_SCALE
+#endif
+#if RGB_BLUE == 2
+#define C2_SCALE B_SCALE
+#endif
+
+
+/*
+ * First we have the histogram data structure and routines for creating it.
+ *
+ * The number of bits of precision can be adjusted by changing these symbols.
+ * We recommend keeping 6 bits for G and 5 each for R and B.
+ * If you have plenty of memory and cycles, 6 bits all around gives marginally
+ * better results; if you are short of memory, 5 bits all around will save
+ * some space but degrade the results.
+ * To maintain a fully accurate histogram, we'd need to allocate a "long"
+ * (preferably unsigned long) for each cell.  In practice this is overkill;
+ * we can get by with 16 bits per cell.  Few of the cell counts will overflow,
+ * and clamping those that do overflow to the maximum value will give close-
+ * enough results.  This reduces the recommended histogram size from 256Kb
+ * to 128Kb, which is a useful savings on PC-class machines.
+ * (In the second pass the histogram space is re-used for pixel mapping data;
+ * in that capacity, each cell must be able to store zero to the number of
+ * desired colors.  16 bits/cell is plenty for that too.)
+ * Since the JPEG code is intended to run in small memory model on 80x86
+ * machines, we can't just allocate the histogram in one chunk.  Instead
+ * of a true 3-D array, we use a row of pointers to 2-D arrays.  Each
+ * pointer corresponds to a C0 value (typically 2^5 = 32 pointers) and
+ * each 2-D array has 2^6*2^5 = 2048 or 2^6*2^6 = 4096 entries.  Note that
+ * on 80x86 machines, the pointer row is in near memory but the actual
+ * arrays are in far memory (same arrangement as we use for image arrays).
+ */
+
+#define MAXNUMCOLORS  (MAXJSAMPLE+1)	/* maximum size of colormap */
+
+/* These will do the right thing for either R,G,B or B,G,R color order,
+ * but you may not like the results for other color orders.
+ */
+#define HIST_C0_BITS  5		/* bits of precision in R/B histogram */
+#define HIST_C1_BITS  6		/* bits of precision in G histogram */
+#define HIST_C2_BITS  5		/* bits of precision in B/R histogram */
+
+/* Number of elements along histogram axes. */
+#define HIST_C0_ELEMS  (1<<HIST_C0_BITS)
+#define HIST_C1_ELEMS  (1<<HIST_C1_BITS)
+#define HIST_C2_ELEMS  (1<<HIST_C2_BITS)
+
+/* These are the amounts to shift an input value to get a histogram index. */
+#define C0_SHIFT  (BITS_IN_JSAMPLE-HIST_C0_BITS)
+#define C1_SHIFT  (BITS_IN_JSAMPLE-HIST_C1_BITS)
+#define C2_SHIFT  (BITS_IN_JSAMPLE-HIST_C2_BITS)
+
+
+typedef UINT16 histcell;	/* histogram cell; prefer an unsigned type */
+
+typedef histcell FAR *histptr;	/* for pointers to histogram cells */
+
+typedef histcell hist1d[HIST_C2_ELEMS];	/* typedefs for the array */
+typedef hist1d FAR *hist2d;	/* type for the 2nd-level pointers */
+typedef hist2d *hist3d;		/* type for top-level pointer */
+
+
+/* Declarations for Floyd-Steinberg dithering.
+ *
+ * Errors are accumulated into the array fserrors[], at a resolution of
+ * 1/16th of a pixel count.  The error at a given pixel is propagated
+ * to its not-yet-processed neighbors using the standard F-S fractions,
+ *		...	(here)	7/16
+ *		3/16	5/16	1/16
+ * We work left-to-right on even rows, right-to-left on odd rows.
+ *
+ * We can get away with a single array (holding one row's worth of errors)
+ * by using it to store the current row's errors at pixel columns not yet
+ * processed, but the next row's errors at columns already processed.  We
+ * need only a few extra variables to hold the errors immediately around the
+ * current column.  (If we are lucky, those variables are in registers, but
+ * even if not, they're probably cheaper to access than array elements are.)
+ *
+ * The fserrors[] array has (#columns + 2) entries; the extra entry at
+ * each end saves us from special-casing the first and last pixels.
+ * Each entry is three values long, one value for each color component.
+ *
+ * Note: on a wide image, we might not have enough room in a PC's near data
+ * segment to hold the error array; so it is allocated with alloc_large.
+ */
+
+#if BITS_IN_JSAMPLE == 8
+typedef INT16 FSERROR;		/* 16 bits should be enough */
+typedef int LOCFSERROR;		/* use 'int' for calculation temps */
+#else
+typedef INT32 FSERROR;		/* may need more than 16 bits */
+typedef INT32 LOCFSERROR;	/* be sure calculation temps are big enough */
+#endif
+
+typedef FSERROR FAR *FSERRPTR;	/* pointer to error array (in FAR storage!) */
+
+
+/* Private subobject */
+
+typedef struct
+{
+#ifdef ORIGINAL_LIB_JPEG
+  struct jpeg_color_quantizer pub;	/* public fields */
+
+  /* Space for the eventually created colormap is stashed here */
+  JSAMPARRAY sv_colormap;	/* colormap allocated at init time */
+  int desired;			/* desired # of colors = size of colormap */
+  boolean needs_zeroed;		/* TRUE if next pass must zero histogram */
+#endif
+
+  /* Variables for accumulating image statistics */
+  hist3d histogram;		/* pointer to the histogram */
+
+
+  /* Variables for Floyd-Steinberg dithering */
+  FSERRPTR fserrors;		/* accumulated errors */
+
+  boolean on_odd_row;		/* flag to remember which row we are on */
+  int *error_limiter;		/* table for clamping the applied error */
+#ifndef ORIGINAL_LIB_JPEG
+  int *error_limiter_storage;	/* gdMalloc'd storage for the above */
+#endif
+}
+my_cquantizer;
+
+typedef my_cquantizer *my_cquantize_ptr;
+
+
+/*
+ * Prescan some rows of pixels.
+ * In this module the prescan simply updates the histogram, which has been
+ * initialized to zeroes by start_pass.
+ * An output_buf parameter is required by the method signature, but no data
+ * is actually output (in fact the buffer controller is probably passing a
+ * NULL pointer).
+ */
+
+METHODDEF (void)
+#ifndef ORIGINAL_LIB_JPEG
+prescan_quantize (gdImagePtr im, my_cquantize_ptr cquantize)
+{
+#else
+prescan_quantize (j_decompress_ptr cinfo, JSAMPARRAY input_buf,
+		  JSAMPARRAY output_buf, int num_rows)
+{
+  my_cquantize_ptr cquantize = (my_cquantize_ptr) cinfo->cquantize;
+#endif
+  register JSAMPROW ptr;
+  register histptr histp;
+  register hist3d histogram = cquantize->histogram;
+  int row;
+  JDIMENSION col;
+#ifdef ORIGINAL_LIB_JPEG
+  JDIMENSION width = cinfo->output_width;
+#else
+  int width = im->sx;
+  int num_rows = im->sy;
+#endif
+
+  for (row = 0; row < num_rows; row++)
+    {
+      ptr = input_buf[row];
+      for (col = width; col > 0; col--)
+	{
+#ifdef ORIGINAL_LIB_JPEG
+	  int r = GETJSAMPLE (ptr[0]) >> C0_SHIFT;
+	  int g = GETJSAMPLE (ptr[1]) >> C1_SHIFT;
+	  int b = GETJSAMPLE (ptr[2]) >> C2_SHIFT;
+#else
+	  int r = gdTrueColorGetRed (*ptr) >> C0_SHIFT;
+	  int g = gdTrueColorGetGreen (*ptr) >> C1_SHIFT;
+	  int b = gdTrueColorGetBlue (*ptr) >> C2_SHIFT;
+	  /* 2.0.12: Steven Brown: support a single totally transparent
+	     color in the original. */
+	  if ((im->transparent >= 0) && (*ptr == im->transparent))
+	    {
+	      ptr++;
+	      continue;
+	    }
+#endif
+	  /* get pixel value and index into the histogram */
+	  histp = &histogram[r][g][b];
+	  /* increment, check for overflow and undo increment if so. */
+	  if (++(*histp) == 0)
+	    (*histp)--;
+#ifdef ORIGINAL_LIB_JPEG
+	  ptr += 3;
+#else
+	  ptr++;
+#endif
+	}
+    }
+}
+
+
+/*
+ * Next we have the really interesting routines: selection of a colormap
+ * given the completed histogram.
+ * These routines work with a list of "boxes", each representing a rectangular
+ * subset of the input color space (to histogram precision).
+ */
+
+typedef struct
+{
+  /* The bounds of the box (inclusive); expressed as histogram indexes */
+  int c0min, c0max;
+  int c1min, c1max;
+  int c2min, c2max;
+  /* The volume (actually 2-norm) of the box */
+  INT32 volume;
+  /* The number of nonzero histogram cells within this box */
+  long colorcount;
+}
+box;
+
+typedef box *boxptr;
+
+
+LOCAL (boxptr) find_biggest_color_pop (boxptr boxlist, int numboxes)
+/* Find the splittable box with the largest color population */
+/* Returns NULL if no splittable boxes remain */
+{
+  register boxptr boxp;
+  register int i;
+  register long maxc = 0;
+  boxptr which = NULL;
+
+  for (i = 0, boxp = boxlist; i < numboxes; i++, boxp++)
+    {
+      if (boxp->colorcount > maxc && boxp->volume > 0)
+	{
+	  which = boxp;
+	  maxc = boxp->colorcount;
+	}
+    }
+  return which;
+}
+
+
+LOCAL (boxptr) find_biggest_volume (boxptr boxlist, int numboxes)
+/* Find the splittable box with the largest (scaled) volume */
+/* Returns NULL if no splittable boxes remain */
+{
+  register boxptr boxp;
+  register int i;
+  register INT32 maxv = 0;
+  boxptr which = NULL;
+
+  for (i = 0, boxp = boxlist; i < numboxes; i++, boxp++)
+    {
+      if (boxp->volume > maxv)
+	{
+	  which = boxp;
+	  maxv = boxp->volume;
+	}
+    }
+  return which;
+}
+
+
+LOCAL (void)
+#ifndef ORIGINAL_LIB_JPEG
+  update_box (gdImagePtr im, my_cquantize_ptr cquantize, boxptr boxp)
+{
+#else
+  update_box (j_decompress_ptr cinfo, boxptr boxp)
+/* Shrink the min/max bounds of a box to enclose only nonzero elements, */
+/* and recompute its volume and population */
+{
+  my_cquantize_ptr cquantize = (my_cquantize_ptr) cinfo->cquantize;
+#endif
+  hist3d histogram = cquantize->histogram;
+  histptr histp;
+  int c0, c1, c2;
+  int c0min, c0max, c1min, c1max, c2min, c2max;
+  INT32 dist0, dist1, dist2;
+  long ccount;
+
+  c0min = boxp->c0min;
+  c0max = boxp->c0max;
+  c1min = boxp->c1min;
+  c1max = boxp->c1max;
+  c2min = boxp->c2min;
+  c2max = boxp->c2max;
+
+  if (c0max > c0min)
+    for (c0 = c0min; c0 <= c0max; c0++)
+      for (c1 = c1min; c1 <= c1max; c1++)
+	{
+	  histp = &histogram[c0][c1][c2min];
+	  for (c2 = c2min; c2 <= c2max; c2++)
+	    if (*histp++ != 0)
+	      {
+		boxp->c0min = c0min = c0;
+		goto have_c0min;
+	      }
+	}
+have_c0min:
+  if (c0max > c0min)
+    for (c0 = c0max; c0 >= c0min; c0--)
+      for (c1 = c1min; c1 <= c1max; c1++)
+	{
+	  histp = &histogram[c0][c1][c2min];
+	  for (c2 = c2min; c2 <= c2max; c2++)
+	    if (*histp++ != 0)
+	      {
+		boxp->c0max = c0max = c0;
+		goto have_c0max;
+	      }
+	}
+have_c0max:
+  if (c1max > c1min)
+    for (c1 = c1min; c1 <= c1max; c1++)
+      for (c0 = c0min; c0 <= c0max; c0++)
+	{
+	  histp = &histogram[c0][c1][c2min];
+	  for (c2 = c2min; c2 <= c2max; c2++)
+	    if (*histp++ != 0)
+	      {
+		boxp->c1min = c1min = c1;
+		goto have_c1min;
+	      }
+	}
+have_c1min:
+  if (c1max > c1min)
+    for (c1 = c1max; c1 >= c1min; c1--)
+      for (c0 = c0min; c0 <= c0max; c0++)
+	{
+	  histp = &histogram[c0][c1][c2min];
+	  for (c2 = c2min; c2 <= c2max; c2++)
+	    if (*histp++ != 0)
+	      {
+		boxp->c1max = c1max = c1;
+		goto have_c1max;
+	      }
+	}
+have_c1max:
+  if (c2max > c2min)
+    for (c2 = c2min; c2 <= c2max; c2++)
+      for (c0 = c0min; c0 <= c0max; c0++)
+	{
+	  histp = &histogram[c0][c1min][c2];
+	  for (c1 = c1min; c1 <= c1max; c1++, histp += HIST_C2_ELEMS)
+	    if (*histp != 0)
+	      {
+		boxp->c2min = c2min = c2;
+		goto have_c2min;
+	      }
+	}
+have_c2min:
+  if (c2max > c2min)
+    for (c2 = c2max; c2 >= c2min; c2--)
+      for (c0 = c0min; c0 <= c0max; c0++)
+	{
+	  histp = &histogram[c0][c1min][c2];
+	  for (c1 = c1min; c1 <= c1max; c1++, histp += HIST_C2_ELEMS)
+	    if (*histp != 0)
+	      {
+		boxp->c2max = c2max = c2;
+		goto have_c2max;
+	      }
+	}
+have_c2max:
+
+  /* Update box volume.
+   * We use 2-norm rather than real volume here; this biases the method
+   * against making long narrow boxes, and it has the side benefit that
+   * a box is splittable iff norm > 0.
+   * Since the differences are expressed in histogram-cell units,
+   * we have to shift back to JSAMPLE units to get consistent distances;
+   * after which, we scale according to the selected distance scale factors.
+   */
+  dist0 = ((c0max - c0min) << C0_SHIFT) * C0_SCALE;
+  dist1 = ((c1max - c1min) << C1_SHIFT) * C1_SCALE;
+  dist2 = ((c2max - c2min) << C2_SHIFT) * C2_SCALE;
+  boxp->volume = dist0 * dist0 + dist1 * dist1 + dist2 * dist2;
+
+  /* Now scan remaining volume of box and compute population */
+  ccount = 0;
+  for (c0 = c0min; c0 <= c0max; c0++)
+    for (c1 = c1min; c1 <= c1max; c1++)
+      {
+	histp = &histogram[c0][c1][c2min];
+	for (c2 = c2min; c2 <= c2max; c2++, histp++)
+	  if (*histp != 0)
+	    {
+	      ccount++;
+	    }
+      }
+  boxp->colorcount = ccount;
+}
+
+
+LOCAL (int)
+#ifdef ORIGINAL_LIB_JPEG
+median_cut (j_decompress_ptr cinfo, boxptr boxlist, int numboxes,
+	    int desired_colors)
+#else
+median_cut (gdImagePtr im, my_cquantize_ptr cquantize,
+	    boxptr boxlist, int numboxes, int desired_colors)
+#endif
+/* Repeatedly select and split the largest box until we have enough boxes */
+{
+  int n, lb;
+  int c0, c1, c2, cmax;
+  register boxptr b1, b2;
+
+  while (numboxes < desired_colors)
+    {
+      /* Select box to split.
+       * Current algorithm: by population for first half, then by volume.
+       */
+      if (numboxes * 2 <= desired_colors)
+	{
+	  b1 = find_biggest_color_pop (boxlist, numboxes);
+	}
+      else
+	{
+	  b1 = find_biggest_volume (boxlist, numboxes);
+	}
+      if (b1 == NULL)		/* no splittable boxes left! */
+	break;
+      b2 = &boxlist[numboxes];	/* where new box will go */
+      /* Copy the color bounds to the new box. */
+      b2->c0max = b1->c0max;
+      b2->c1max = b1->c1max;
+      b2->c2max = b1->c2max;
+      b2->c0min = b1->c0min;
+      b2->c1min = b1->c1min;
+      b2->c2min = b1->c2min;
+      /* Choose which axis to split the box on.
+       * Current algorithm: longest scaled axis.
+       * See notes in update_box about scaling distances.
+       */
+      c0 = ((b1->c0max - b1->c0min) << C0_SHIFT) * C0_SCALE;
+      c1 = ((b1->c1max - b1->c1min) << C1_SHIFT) * C1_SCALE;
+      c2 = ((b1->c2max - b1->c2min) << C2_SHIFT) * C2_SCALE;
+      /* We want to break any ties in favor of green, then red, blue last.
+       * This code does the right thing for R,G,B or B,G,R color orders only.
+       */
+#if RGB_RED == 0
+      cmax = c1;
+      n = 1;
+      if (c0 > cmax)
+	{
+	  cmax = c0;
+	  n = 0;
+	}
+      if (c2 > cmax)
+	{
+	  n = 2;
+	}
+#else
+      cmax = c1;
+      n = 1;
+      if (c2 > cmax)
+	{
+	  cmax = c2;
+	  n = 2;
+	}
+      if (c0 > cmax)
+	{
+	  n = 0;
+	}
+#endif
+      /* Choose split point along selected axis, and update box bounds.
+       * Current algorithm: split at halfway point.
+       * (Since the box has been shrunk to minimum volume,
+       * any split will produce two nonempty subboxes.)
+       * Note that lb value is max for lower box, so must be < old max.
+       */
+      switch (n)
+	{
+	case 0:
+	  lb = (b1->c0max + b1->c0min) / 2;
+	  b1->c0max = lb;
+	  b2->c0min = lb + 1;
+	  break;
+	case 1:
+	  lb = (b1->c1max + b1->c1min) / 2;
+	  b1->c1max = lb;
+	  b2->c1min = lb + 1;
+	  break;
+	case 2:
+	  lb = (b1->c2max + b1->c2min) / 2;
+	  b1->c2max = lb;
+	  b2->c2min = lb + 1;
+	  break;
+	}
+      /* Update stats for boxes */
+#ifdef ORIGINAL_LIB_JPEG
+      update_box (cinfo, b1);
+      update_box (cinfo, b2);
+#else
+      update_box (im, cquantize, b1);
+      update_box (im, cquantize, b2);
+#endif
+      numboxes++;
+    }
+  return numboxes;
+}
+
+
+LOCAL (void)
+#ifndef ORIGINAL_LIB_JPEG
+  compute_color (gdImagePtr im, my_cquantize_ptr cquantize,
+	       boxptr boxp, int icolor)
+{
+#else
+  compute_color (j_decompress_ptr cinfo, boxptr boxp, int icolor)
+/* Compute representative color for a box, put it in colormap[icolor] */
+{
+  /* Current algorithm: mean weighted by pixels (not colors) */
+  /* Note it is important to get the rounding correct! */
+  my_cquantize_ptr cquantize = (my_cquantize_ptr) cinfo->cquantize;
+#endif
+  hist3d histogram = cquantize->histogram;
+  histptr histp;
+  int c0, c1, c2;
+  int c0min, c0max, c1min, c1max, c2min, c2max;
+  long count;
+  long total = 0;
+  long c0total = 0;
+  long c1total = 0;
+  long c2total = 0;
+
+  c0min = boxp->c0min;
+  c0max = boxp->c0max;
+  c1min = boxp->c1min;
+  c1max = boxp->c1max;
+  c2min = boxp->c2min;
+  c2max = boxp->c2max;
+
+  for (c0 = c0min; c0 <= c0max; c0++)
+    for (c1 = c1min; c1 <= c1max; c1++)
+      {
+	histp = &histogram[c0][c1][c2min];
+	for (c2 = c2min; c2 <= c2max; c2++)
+	  {
+	    if ((count = *histp++) != 0)
+	      {
+		total += count;
+		c0total +=
+		  ((c0 << C0_SHIFT) + ((1 << C0_SHIFT) >> 1)) * count;
+		c1total +=
+		  ((c1 << C1_SHIFT) + ((1 << C1_SHIFT) >> 1)) * count;
+		c2total +=
+		  ((c2 << C2_SHIFT) + ((1 << C2_SHIFT) >> 1)) * count;
+	      }
+	  }
+      }
+
+#ifdef ORIGINAL_LIB_JPEG
+  cinfo->colormap[0][icolor] = (JSAMPLE) ((c0total + (total >> 1)) / total);
+  cinfo->colormap[1][icolor] = (JSAMPLE) ((c1total + (total >> 1)) / total);
+  cinfo->colormap[2][icolor] = (JSAMPLE) ((c2total + (total >> 1)) / total);
+#else
+  im->red[icolor] = (int) ((c0total + (total >> 1)) / total);
+  im->green[icolor] = (int) ((c1total + (total >> 1)) / total);
+  im->blue[icolor] = (int) ((c2total + (total >> 1)) / total);
+#endif
+}
+
+
+LOCAL (void)
+#ifdef ORIGINAL_LIB_JPEG
+select_colors (j_decompress_ptr cinfo, int desired_colors)
+#else
+select_colors (gdImagePtr im, my_cquantize_ptr cquantize, int desired_colors)
+#endif
+/* Master routine for color selection */
+{
+  boxptr boxlist;
+  int numboxes;
+  int i;
+
+  /* Allocate workspace for box list */
+#ifdef ORIGINAL_LIB_JPEG
+  boxlist = (boxptr) (*cinfo->mem->alloc_small)
+    ((j_common_ptr) cinfo, JPOOL_IMAGE, desired_colors * SIZEOF (box));
+#else
+  boxlist = (boxptr) gdMalloc (desired_colors * sizeof (box));
+#endif
+  /* Initialize one box containing whole space */
+  numboxes = 1;
+  boxlist[0].c0min = 0;
+  boxlist[0].c0max = MAXJSAMPLE >> C0_SHIFT;
+  boxlist[0].c1min = 0;
+  boxlist[0].c1max = MAXJSAMPLE >> C1_SHIFT;
+  boxlist[0].c2min = 0;
+  boxlist[0].c2max = MAXJSAMPLE >> C2_SHIFT;
+#ifdef ORIGINAL_LIB_JPEG
+  /* Shrink it to actually-used volume and set its statistics */
+  update_box (cinfo, &boxlist[0]);
+  /* Perform median-cut to produce final box list */
+  numboxes = median_cut (cinfo, boxlist, numboxes, desired_colors);
+  /* Compute the representative color for each box, fill colormap */
+  for (i = 0; i < numboxes; i++)
+    compute_color (cinfo, &boxlist[i], i);
+  cinfo->actual_number_of_colors = numboxes;
+  TRACEMS1 (cinfo, 1, JTRC_QUANT_SELECTED, numboxes);
+#else
+  /* Shrink it to actually-used volume and set its statistics */
+  update_box (im, cquantize, &boxlist[0]);
+  /* Perform median-cut to produce final box list */
+  numboxes = median_cut (im, cquantize, boxlist, numboxes, desired_colors);
+  /* Compute the representative color for each box, fill colormap */
+  for (i = 0; i < numboxes; i++)
+    compute_color (im, cquantize, &boxlist[i], i);
+  im->colorsTotal = numboxes;
+
+  /* If we had a pure transparency color, add it as the last palette entry.
+   * Skip incrementing the color count so that the dither / matching phase
+   * won't use it on pixels that shouldn't have been transparent.  We'll
+   * increment it after all that finishes. */
+  if (im->transparent >= 0)
+    {
+      /* Save the transparent color. */
+      im->red[im->colorsTotal] = gdTrueColorGetRed (im->transparent);
+      im->green[im->colorsTotal] = gdTrueColorGetGreen (im->transparent);
+      im->blue[im->colorsTotal] = gdTrueColorGetBlue (im->transparent);
+      im->alpha[im->colorsTotal] = gdAlphaTransparent;
+      im->open[im->colorsTotal] = 0;
+    }
+
+  gdFree (boxlist);
+#endif
+}
+
+
+/*
+ * These routines are concerned with the time-critical task of mapping input
+ * colors to the nearest color in the selected colormap.
+ *
+ * We re-use the histogram space as an "inverse color map", essentially a
+ * cache for the results of nearest-color searches.  All colors within a
+ * histogram cell will be mapped to the same colormap entry, namely the one
+ * closest to the cell's center.  This may not be quite the closest entry to
+ * the actual input color, but it's almost as good.  A zero in the cache
+ * indicates we haven't found the nearest color for that cell yet; the array
+ * is cleared to zeroes before starting the mapping pass.  When we find the
+ * nearest color for a cell, its colormap index plus one is recorded in the
+ * cache for future use.  The pass2 scanning routines call fill_inverse_cmap
+ * when they need to use an unfilled entry in the cache.
+ *
+ * Our method of efficiently finding nearest colors is based on the "locally
+ * sorted search" idea described by Heckbert and on the incremental distance
+ * calculation described by Spencer W. Thomas in chapter III.1 of Graphics
+ * Gems II (James Arvo, ed.  Academic Press, 1991).  Thomas points out that
+ * the distances from a given colormap entry to each cell of the histogram can
+ * be computed quickly using an incremental method: the differences between
+ * distances to adjacent cells themselves differ by a constant.  This allows a
+ * fairly fast implementation of the "brute force" approach of computing the
+ * distance from every colormap entry to every histogram cell.  Unfortunately,
+ * it needs a work array to hold the best-distance-so-far for each histogram
+ * cell (because the inner loop has to be over cells, not colormap entries).
+ * The work array elements have to be INT32s, so the work array would need
+ * 256Kb at our recommended precision.  This is not feasible in DOS machines.
+ *
+ * To get around these problems, we apply Thomas' method to compute the
+ * nearest colors for only the cells within a small subbox of the histogram.
+ * The work array need be only as big as the subbox, so the memory usage
+ * problem is solved.  Furthermore, we need not fill subboxes that are never
+ * referenced in pass2; many images use only part of the color gamut, so a
+ * fair amount of work is saved.  An additional advantage of this
+ * approach is that we can apply Heckbert's locality criterion to quickly
+ * eliminate colormap entries that are far away from the subbox; typically
+ * three-fourths of the colormap entries are rejected by Heckbert's criterion,
+ * and we need not compute their distances to individual cells in the subbox.
+ * The speed of this approach is heavily influenced by the subbox size: too
+ * small means too much overhead, too big loses because Heckbert's criterion
+ * can't eliminate as many colormap entries.  Empirically the best subbox
+ * size seems to be about 1/512th of the histogram (1/8th in each direction).
+ *
+ * Thomas' article also describes a refined method which is asymptotically
+ * faster than the brute-force method, but it is also far more complex and
+ * cannot efficiently be applied to small subboxes.  It is therefore not
+ * useful for programs intended to be portable to DOS machines.  On machines
+ * with plenty of memory, filling the whole histogram in one shot with Thomas'
+ * refined method might be faster than the present code --- but then again,
+ * it might not be any faster, and it's certainly more complicated.
+ */
+
+
+/* log2(histogram cells in update box) for each axis; this can be adjusted */
+#define BOX_C0_LOG  (HIST_C0_BITS-3)
+#define BOX_C1_LOG  (HIST_C1_BITS-3)
+#define BOX_C2_LOG  (HIST_C2_BITS-3)
+
+#define BOX_C0_ELEMS  (1<<BOX_C0_LOG)	/* # of hist cells in update box */
+#define BOX_C1_ELEMS  (1<<BOX_C1_LOG)
+#define BOX_C2_ELEMS  (1<<BOX_C2_LOG)
+
+#define BOX_C0_SHIFT  (C0_SHIFT + BOX_C0_LOG)
+#define BOX_C1_SHIFT  (C1_SHIFT + BOX_C1_LOG)
+#define BOX_C2_SHIFT  (C2_SHIFT + BOX_C2_LOG)
+
+
+/*
+ * The next three routines implement inverse colormap filling.  They could
+ * all be folded into one big routine, but splitting them up this way saves
+ * some stack space (the mindist[] and bestdist[] arrays need not coexist)
+ * and may allow some compilers to produce better code by registerizing more
+ * inner-loop variables.
+ */
+
+LOCAL (int)
+find_nearby_colors (
+#ifdef ORIGINAL_LIB_JPEG
+		     j_decompress_ptr cinfo,
+#else
+		     gdImagePtr im, my_cquantize_ptr cquantize,
+#endif
+		     int minc0, int minc1, int minc2, JSAMPLE colorlist[])
+/* Locate the colormap entries close enough to an update box to be candidates
+ * for the nearest entry to some cell(s) in the update box.  The update box
+ * is specified by the center coordinates of its first cell.  The number of
+ * candidate colormap entries is returned, and their colormap indexes are
+ * placed in colorlist[].
+ * This routine uses Heckbert's "locally sorted search" criterion to select
+ * the colors that need further consideration.
+ */
+{
+#ifdef ORIGINAL_LIB_JPEG
+  int numcolors = cinfo->actual_number_of_colors;
+#else
+  int numcolors = im->colorsTotal;
+#endif
+  int maxc0, maxc1, maxc2;
+  int centerc0, centerc1, centerc2;
+  int i, x, ncolors;
+  INT32 minmaxdist, min_dist, max_dist, tdist;
+  INT32 mindist[MAXNUMCOLORS];	/* min distance to colormap entry i */
+
+  /* Compute true coordinates of update box's upper corner and center.
+   * Actually we compute the coordinates of the center of the upper-corner
+   * histogram cell, which are the upper bounds of the volume we care about.
+   * Note that since ">>" rounds down, the "center" values may be closer to
+   * min than to max; hence comparisons to them must be "<=", not "<".
+   */
+  maxc0 = minc0 + ((1 << BOX_C0_SHIFT) - (1 << C0_SHIFT));
+  centerc0 = (minc0 + maxc0) >> 1;
+  maxc1 = minc1 + ((1 << BOX_C1_SHIFT) - (1 << C1_SHIFT));
+  centerc1 = (minc1 + maxc1) >> 1;
+  maxc2 = minc2 + ((1 << BOX_C2_SHIFT) - (1 << C2_SHIFT));
+  centerc2 = (minc2 + maxc2) >> 1;
+
+  /* For each color in colormap, find:
+   *  1. its minimum squared-distance to any point in the update box
+   *     (zero if color is within update box);
+   *  2. its maximum squared-distance to any point in the update box.
+   * Both of these can be found by considering only the corners of the box.
+   * We save the minimum distance for each color in mindist[];
+   * only the smallest maximum distance is of interest.
+   */
+  minmaxdist = 0x7FFFFFFFL;
+
+  for (i = 0; i < numcolors; i++)
+    {
+      /* We compute the squared-c0-distance term, then add in the other two. */
+#ifdef ORIGINAL_LIB_JPEG
+      x = GETJSAMPLE (cinfo->colormap[0][i]);
+#else
+      x = im->red[i];
+#endif
+      if (x < minc0)
+	{
+	  tdist = (x - minc0) * C0_SCALE;
+	  min_dist = tdist * tdist;
+	  tdist = (x - maxc0) * C0_SCALE;
+	  max_dist = tdist * tdist;
+	}
+      else if (x > maxc0)
+	{
+	  tdist = (x - maxc0) * C0_SCALE;
+	  min_dist = tdist * tdist;
+	  tdist = (x - minc0) * C0_SCALE;
+	  max_dist = tdist * tdist;
+	}
+      else
+	{
+	  /* within cell range so no contribution to min_dist */
+	  min_dist = 0;
+	  if (x <= centerc0)
+	    {
+	      tdist = (x - maxc0) * C0_SCALE;
+	      max_dist = tdist * tdist;
+	    }
+	  else
+	    {
+	      tdist = (x - minc0) * C0_SCALE;
+	      max_dist = tdist * tdist;
+	    }
+	}
+
+#ifdef ORIGINAL_LIB_JPEG
+      x = GETJSAMPLE (cinfo->colormap[1][i]);
+#else
+      x = im->green[i];
+#endif
+      if (x < minc1)
+	{
+	  tdist = (x - minc1) * C1_SCALE;
+	  min_dist += tdist * tdist;
+	  tdist = (x - maxc1) * C1_SCALE;
+	  max_dist += tdist * tdist;
+	}
+      else if (x > maxc1)
+	{
+	  tdist = (x - maxc1) * C1_SCALE;
+	  min_dist += tdist * tdist;
+	  tdist = (x - minc1) * C1_SCALE;
+	  max_dist += tdist * tdist;
+	}
+      else
+	{
+	  /* within cell range so no contribution to min_dist */
+	  if (x <= centerc1)
+	    {
+	      tdist = (x - maxc1) * C1_SCALE;
+	      max_dist += tdist * tdist;
+	    }
+	  else
+	    {
+	      tdist = (x - minc1) * C1_SCALE;
+	      max_dist += tdist * tdist;
+	    }
+	}
+
+#ifdef ORIGINAL_LIB_JPEG
+      x = GETJSAMPLE (cinfo->colormap[2][i]);
+#else
+      x = im->blue[i];
+#endif
+      if (x < minc2)
+	{
+	  tdist = (x - minc2) * C2_SCALE;
+	  min_dist += tdist * tdist;
+	  tdist = (x - maxc2) * C2_SCALE;
+	  max_dist += tdist * tdist;
+	}
+      else if (x > maxc2)
+	{
+	  tdist = (x - maxc2) * C2_SCALE;
+	  min_dist += tdist * tdist;
+	  tdist = (x - minc2) * C2_SCALE;
+	  max_dist += tdist * tdist;
+	}
+      else
+	{
+	  /* within cell range so no contribution to min_dist */
+	  if (x <= centerc2)
+	    {
+	      tdist = (x - maxc2) * C2_SCALE;
+	      max_dist += tdist * tdist;
+	    }
+	  else
+	    {
+	      tdist = (x - minc2) * C2_SCALE;
+	      max_dist += tdist * tdist;
+	    }
+	}
+
+      mindist[i] = min_dist;	/* save away the results */
+      if (max_dist < minmaxdist)
+	minmaxdist = max_dist;
+    }
+
+  /* Now we know that no cell in the update box is more than minmaxdist
+   * away from some colormap entry.  Therefore, only colors that are
+   * within minmaxdist of some part of the box need be considered.
+   */
+  ncolors = 0;
+  for (i = 0; i < numcolors; i++)
+    {
+      if (mindist[i] <= minmaxdist)
+	colorlist[ncolors++] = (JSAMPLE) i;
+    }
+  return ncolors;
+}
+
+
+LOCAL (void) find_best_colors (
+#ifdef ORIGINAL_LIB_JPEG
+				j_decompress_ptr cinfo,
+#else
+				gdImagePtr im, my_cquantize_ptr cquantize,
+#endif
+				int minc0, int minc1, int minc2,
+				int numcolors, JSAMPLE colorlist[],
+				JSAMPLE bestcolor[])
+/* Find the closest colormap entry for each cell in the update box,
+ * given the list of candidate colors prepared by find_nearby_colors.
+ * Return the indexes of the closest entries in the bestcolor[] array.
+ * This routine uses Thomas' incremental distance calculation method to
+ * find the distance from a colormap entry to successive cells in the box.
+ */
+{
+  int ic0, ic1, ic2;
+  int i, icolor;
+  register INT32 *bptr;		/* pointer into bestdist[] array */
+  JSAMPLE *cptr;		/* pointer into bestcolor[] array */
+  INT32 dist0, dist1;		/* initial distance values */
+  register INT32 dist2;		/* current distance in inner loop */
+  INT32 xx0, xx1;		/* distance increments */
+  register INT32 xx2;
+  INT32 inc0, inc1, inc2;	/* initial values for increments */
+  /* This array holds the distance to the nearest-so-far color for each cell */
+  INT32 bestdist[BOX_C0_ELEMS * BOX_C1_ELEMS * BOX_C2_ELEMS];
+
+  /* Initialize best-distance for each cell of the update box */
+  bptr = bestdist;
+  for (i = BOX_C0_ELEMS * BOX_C1_ELEMS * BOX_C2_ELEMS - 1; i >= 0; i--)
+    *bptr++ = 0x7FFFFFFFL;
+
+  /* For each color selected by find_nearby_colors,
+   * compute its distance to the center of each cell in the box.
+   * If that's less than best-so-far, update best distance and color number.
+   */
+
+  /* Nominal steps between cell centers ("x" in Thomas article) */
+#define STEP_C0  ((1 << C0_SHIFT) * C0_SCALE)
+#define STEP_C1  ((1 << C1_SHIFT) * C1_SCALE)
+#define STEP_C2  ((1 << C2_SHIFT) * C2_SCALE)
+
+  for (i = 0; i < numcolors; i++)
+    {
+      int r, g, b;
+#ifdef ORIGINAL_LIB_JPEG
+
+      icolor = GETJSAMPLE (colorlist[i]);
+      r = GETJSAMPLE (cinfo->colormap[0][icolor]);
+      g = GETJSAMPLE (cinfo->colormap[1][icolor]);
+      b = GETJSAMPLE (cinfo->colormap[2][icolor]);
+#else
+      icolor = colorlist[i];
+      r = im->red[icolor];
+      g = im->green[icolor];
+      b = im->blue[icolor];
+#endif
+
+      /* Compute (square of) distance from minc0/c1/c2 to this color */
+      inc0 = (minc0 - r) * C0_SCALE;
+      dist0 = inc0 * inc0;
+      inc1 = (minc1 - g) * C1_SCALE;
+      dist0 += inc1 * inc1;
+      inc2 = (minc2 - b) * C2_SCALE;
+      dist0 += inc2 * inc2;
+      /* Form the initial difference increments */
+      inc0 = inc0 * (2 * STEP_C0) + STEP_C0 * STEP_C0;
+      inc1 = inc1 * (2 * STEP_C1) + STEP_C1 * STEP_C1;
+      inc2 = inc2 * (2 * STEP_C2) + STEP_C2 * STEP_C2;
+      /* Now loop over all cells in box, updating distance per Thomas method */
+      bptr = bestdist;
+      cptr = bestcolor;
+      xx0 = inc0;
+      for (ic0 = BOX_C0_ELEMS - 1; ic0 >= 0; ic0--)
+	{
+	  dist1 = dist0;
+	  xx1 = inc1;
+	  for (ic1 = BOX_C1_ELEMS - 1; ic1 >= 0; ic1--)
+	    {
+	      dist2 = dist1;
+	      xx2 = inc2;
+	      for (ic2 = BOX_C2_ELEMS - 1; ic2 >= 0; ic2--)
+		{
+		  if (dist2 < *bptr)
+		    {
+		      *bptr = dist2;
+		      *cptr = (JSAMPLE) icolor;
+		    }
+		  dist2 += xx2;
+		  xx2 += 2 * STEP_C2 * STEP_C2;
+		  bptr++;
+		  cptr++;
+		}
+	      dist1 += xx1;
+	      xx1 += 2 * STEP_C1 * STEP_C1;
+	    }
+	  dist0 += xx0;
+	  xx0 += 2 * STEP_C0 * STEP_C0;
+	}
+    }
+}
+
+
+LOCAL (void)
+fill_inverse_cmap (
+#ifdef ORIGINAL_LIB_JPEG
+		    j_decompress_ptr cinfo,
+#else
+		    gdImagePtr im, my_cquantize_ptr cquantize,
+#endif
+		    int c0, int c1, int c2)
+/* Fill the inverse-colormap entries in the update box that contains */
+/* histogram cell c0/c1/c2.  (Only that one cell MUST be filled, but */
+/* we can fill as many others as we wish.) */
+{
+#ifdef ORIGINAL_LIB_JPEG
+  my_cquantize_ptr cquantize = (my_cquantize_ptr) cinfo->cquantize;
+#endif
+  hist3d histogram = cquantize->histogram;
+  int minc0, minc1, minc2;	/* lower left corner of update box */
+  int ic0, ic1, ic2;
+  register JSAMPLE *cptr;	/* pointer into bestcolor[] array */
+  register histptr cachep;	/* pointer into main cache array */
+  /* This array lists the candidate colormap indexes. */
+  JSAMPLE colorlist[MAXNUMCOLORS];
+  int numcolors;		/* number of candidate colors */
+  /* This array holds the actually closest colormap index for each cell. */
+  JSAMPLE bestcolor[BOX_C0_ELEMS * BOX_C1_ELEMS * BOX_C2_ELEMS];
+
+  /* Convert cell coordinates to update box ID */
+  c0 >>= BOX_C0_LOG;
+  c1 >>= BOX_C1_LOG;
+  c2 >>= BOX_C2_LOG;
+
+  /* Compute true coordinates of update box's origin corner.
+   * Actually we compute the coordinates of the center of the corner
+   * histogram cell, which are the lower bounds of the volume we care about.
+   */
+  minc0 = (c0 << BOX_C0_SHIFT) + ((1 << C0_SHIFT) >> 1);
+  minc1 = (c1 << BOX_C1_SHIFT) + ((1 << C1_SHIFT) >> 1);
+  minc2 = (c2 << BOX_C2_SHIFT) + ((1 << C2_SHIFT) >> 1);
+
+  /* Determine which colormap entries are close enough to be candidates
+   * for the nearest entry to some cell in the update box.
+   */
+#ifdef ORIGINAL_LIB_JPEG
+  numcolors = find_nearby_colors (cinfo, minc0, minc1, minc2, colorlist);
+
+  /* Determine the actually nearest colors. */
+  find_best_colors (cinfo, minc0, minc1, minc2, numcolors, colorlist,
+		    bestcolor);
+#else
+  numcolors =
+    find_nearby_colors (im, cquantize, minc0, minc1, minc2, colorlist);
+  find_best_colors (im, cquantize, minc0, minc1, minc2, numcolors,
+		    colorlist, bestcolor);
+#endif
+
+  /* Save the best color numbers (plus 1) in the main cache array */
+  c0 <<= BOX_C0_LOG;		/* convert ID back to base cell indexes */
+  c1 <<= BOX_C1_LOG;
+  c2 <<= BOX_C2_LOG;
+  cptr = bestcolor;
+  for (ic0 = 0; ic0 < BOX_C0_ELEMS; ic0++)
+    {
+      for (ic1 = 0; ic1 < BOX_C1_ELEMS; ic1++)
+	{
+	  cachep = &histogram[c0 + ic0][c1 + ic1][c2];
+	  for (ic2 = 0; ic2 < BOX_C2_ELEMS; ic2++)
+	    {
+#ifdef ORIGINAL_LIB_JPEG
+	      *cachep++ = (histcell) (GETJSAMPLE (*cptr++) + 1);
+#else
+	      *cachep++ = (histcell) ((*cptr++) + 1);
+#endif
+	    }
+	}
+    }
+}
+
+
+/*
+ * Map some rows of pixels to the output colormapped representation.
+ */
+
+METHODDEF (void)
+#ifndef ORIGINAL_LIB_JPEG
+pass2_no_dither (gdImagePtr im, my_cquantize_ptr cquantize)
+{
+  register int *inptr;
+  register unsigned char *outptr;
+  int width = im->sx;
+  int num_rows = im->sy;
+#else
+pass2_no_dither (j_decompress_ptr cinfo,
+		 JSAMPARRAY input_buf, JSAMPARRAY output_buf, int num_rows)
+/* This version performs no dithering */
+{
+  my_cquantize_ptr cquantize = (my_cquantize_ptr) cinfo->cquantize;
+  register JSAMPROW inptr, outptr;
+  JDIMENSION width = cinfo->output_width;
+#endif
+  hist3d histogram = cquantize->histogram;
+  register int c0, c1, c2;
+  int row;
+  JDIMENSION col;
+  register histptr cachep;
+
+
+  for (row = 0; row < num_rows; row++)
+    {
+      inptr = input_buf[row];
+      outptr = output_buf[row];
+      for (col = width; col > 0; col--)
+	{
+	  /* get pixel value and index into the cache */
+	  int r, g, b;
+#ifdef ORIGINAL_LIB_JPEG
+	  r = GETJSAMPLE (*inptr++);
+	  g = GETJSAMPLE (*inptr++);
+	  b = GETJSAMPLE (*inptr++);
+#else
+	  r = gdTrueColorGetRed (*inptr);
+	  g = gdTrueColorGetGreen (*inptr);
+	  b = gdTrueColorGetBlue (*inptr++);
+
+	  /* If the pixel is transparent, we assign it the palette index that
+	   * will later be added at the end of the palette as the transparent
+	   * index. */
+	  if ((im->transparent >= 0) && (im->transparent == *inptr))
+	    {
+	      *outptr++ = im->colorsTotal;
+	      continue;
+	    }
+#endif
+	  c0 = r >> C0_SHIFT;
+	  c1 = g >> C1_SHIFT;
+	  c2 = b >> C2_SHIFT;
+	  cachep = &histogram[c0][c1][c2];
+	  /* If we have not seen this color before, find nearest colormap entry */
+	  /* and update the cache */
+	  if (*cachep == 0)
+#ifdef ORIGINAL_LIB_JPEG
+	    fill_inverse_cmap (cinfo, c0, c1, c2);
+#else
+	    fill_inverse_cmap (im, cquantize, c0, c1, c2);
+#endif
+	  /* Now emit the colormap index for this cell */
+#ifdef ORIGINAL_LIB_JPEG
+	  *outptr++ = (JSAMPLE) (*cachep - 1);
+#else
+	  *outptr++ = (*cachep - 1);
+#endif
+	}
+    }
+}
+
+
+METHODDEF (void)
+#ifndef ORIGINAL_LIB_JPEG
+pass2_fs_dither (gdImagePtr im, my_cquantize_ptr cquantize)
+{
+#else
+pass2_fs_dither (j_decompress_ptr cinfo,
+		 JSAMPARRAY input_buf, JSAMPARRAY output_buf, int num_rows)
+/* This version performs Floyd-Steinberg dithering */
+{
+  my_cquantize_ptr cquantize = (my_cquantize_ptr) cinfo->cquantize;
+  JSAMPROW inptr;		/* => current input pixel */
+#endif
+  hist3d histogram = cquantize->histogram;
+  register LOCFSERROR cur0, cur1, cur2;	/* current error or pixel value */
+  LOCFSERROR belowerr0, belowerr1, belowerr2;	/* error for pixel below cur */
+  LOCFSERROR bpreverr0, bpreverr1, bpreverr2;	/* error for below/prev col */
+  register FSERRPTR errorptr;	/* => fserrors[] at column before current */
+  histptr cachep;
+  int dir;			/* +1 or -1 depending on direction */
+  int dir3;			/* 3*dir, for advancing inptr & errorptr */
+  int row;
+  JDIMENSION col;
+#ifdef ORIGINAL_LIB_JPEG
+  JSAMPROW outptr;		/* => current output pixel */
+  JDIMENSION width = cinfo->output_width;
+  JSAMPLE *range_limit = cinfo->sample_range_limit;
+  JSAMPROW colormap0 = cinfo->colormap[0];
+  JSAMPROW colormap1 = cinfo->colormap[1];
+  JSAMPROW colormap2 = cinfo->colormap[2];
+#else
+  int *inptr;			/* => current input pixel */
+  unsigned char *outptr;	/* => current output pixel */
+  int width = im->sx;
+  int num_rows = im->sy;
+  int *colormap0 = im->red;
+  int *colormap1 = im->green;
+  int *colormap2 = im->blue;
+#endif
+  int *error_limit = cquantize->error_limiter;
+
+
+  SHIFT_TEMPS for (row = 0; row < num_rows; row++)
+    {
+      inptr = input_buf[row];
+      outptr = output_buf[row];
+      if (cquantize->on_odd_row)
+	{
+	  /* work right to left in this row */
+	  inptr += (width - 1) * 3;	/* so point to rightmost pixel */
+	  outptr += width - 1;
+	  dir = -1;
+	  dir3 = -3;
+	  errorptr = cquantize->fserrors + (width + 1) * 3;	/* => entry after last column */
+#ifdef ORIGINAL_LIB_JPEG_REVERSE_ODD_ROWS
+	  cquantize->on_odd_row = FALSE;	/* flip for next time */
+#endif
+	}
+      else
+	{
+	  /* work left to right in this row */
+	  dir = 1;
+	  dir3 = 3;
+	  errorptr = cquantize->fserrors;	/* => entry before first real column */
+#ifdef ORIGINAL_LIB_JPEG_REVERSE_ODD_ROWS
+	  cquantize->on_odd_row = TRUE;	/* flip for next time */
+#endif
+	}
+      /* Preset error values: no error propagated to first pixel from left */
+      cur0 = cur1 = cur2 = 0;
+      /* and no error propagated to row below yet */
+      belowerr0 = belowerr1 = belowerr2 = 0;
+      bpreverr0 = bpreverr1 = bpreverr2 = 0;
+
+      for (col = width; col > 0; col--)
+	{
+
+	  /* If this pixel is transparent, we want to assign it to the special
+	   * transparency color index past the end of the palette rather than
+	   * go through matching / dithering. */
+	  if ((im->transparent >= 0) && (*inptr == im->transparent))
+	    {
+	      *outptr = im->colorsTotal;
+	      errorptr[0] = 0;
+	      errorptr[1] = 0;
+	      errorptr[2] = 0;
+	      errorptr[3] = 0;
+	      inptr += dir;
+	      outptr += dir;
+	      errorptr += dir3;
+	      continue;
+	    }
+	  /* curN holds the error propagated from the previous pixel on the
+	   * current line.  Add the error propagated from the previous line
+	   * to form the complete error correction term for this pixel, and
+	   * round the error term (which is expressed * 16) to an integer.
+	   * RIGHT_SHIFT rounds towards minus infinity, so adding 8 is correct
+	   * for either sign of the error value.
+	   * Note: errorptr points to *previous* column's array entry.
+	   */
+	  cur0 = RIGHT_SHIFT (cur0 + errorptr[dir3 + 0] + 8, 4);
+	  cur1 = RIGHT_SHIFT (cur1 + errorptr[dir3 + 1] + 8, 4);
+	  cur2 = RIGHT_SHIFT (cur2 + errorptr[dir3 + 2] + 8, 4);
+	  /* Limit the error using transfer function set by init_error_limit.
+	   * See comments with init_error_limit for rationale.
+	   */
+	  cur0 = error_limit[cur0];
+	  cur1 = error_limit[cur1];
+	  cur2 = error_limit[cur2];
+	  /* Form pixel value + error, and range-limit to 0..MAXJSAMPLE.
+	   * The maximum error is +- MAXJSAMPLE (or less with error limiting);
+	   * this sets the required size of the range_limit array.
+	   */
+#ifdef ORIGINAL_LIB_JPEG
+	  cur0 += GETJSAMPLE (inptr[0]);
+	  cur1 += GETJSAMPLE (inptr[1]);
+	  cur2 += GETJSAMPLE (inptr[2]);
+	  cur0 = GETJSAMPLE (range_limit[cur0]);
+	  cur1 = GETJSAMPLE (range_limit[cur1]);
+	  cur2 = GETJSAMPLE (range_limit[cur2]);
+#else
+	  cur0 += gdTrueColorGetRed (*inptr);
+	  cur1 += gdTrueColorGetGreen (*inptr);
+	  cur2 += gdTrueColorGetBlue (*inptr);
+	  range_limit (cur0);
+	  range_limit (cur1);
+	  range_limit (cur2);
+#endif
+
+	  /* Index into the cache with adjusted pixel value */
+	  cachep =
+	    &histogram[cur0 >> C0_SHIFT][cur1 >> C1_SHIFT][cur2 >> C2_SHIFT];
+	  /* If we have not seen this color before, find nearest colormap */
+	  /* entry and update the cache */
+	  if (*cachep == 0)
+#ifdef ORIGINAL_LIB_JPEG
+	    fill_inverse_cmap (cinfo, cur0 >> C0_SHIFT, cur1 >> C1_SHIFT,
+			       cur2 >> C2_SHIFT);
+#else
+	    fill_inverse_cmap (im, cquantize, cur0 >> C0_SHIFT,
+			       cur1 >> C1_SHIFT, cur2 >> C2_SHIFT);
+#endif
+	  /* Now emit the colormap index for this cell */
+	  {
+	    register int pixcode = *cachep - 1;
+	    *outptr = (JSAMPLE) pixcode;
+	    /* Compute representation error for this pixel */
+#define GETJSAMPLE
+	    cur0 -= GETJSAMPLE (colormap0[pixcode]);
+	    cur1 -= GETJSAMPLE (colormap1[pixcode]);
+	    cur2 -= GETJSAMPLE (colormap2[pixcode]);
+#undef GETJSAMPLE
+	  }
+	  /* Compute error fractions to be propagated to adjacent pixels.
+	   * Add these into the running sums, and simultaneously shift the
+	   * next-line error sums left by 1 column.
+	   */
+	  {
+	    register LOCFSERROR bnexterr, delta;
+
+	    bnexterr = cur0;	/* Process component 0 */
+	    delta = cur0 * 2;
+	    cur0 += delta;	/* form error * 3 */
+	    errorptr[0] = (FSERROR) (bpreverr0 + cur0);
+	    cur0 += delta;	/* form error * 5 */
+	    bpreverr0 = belowerr0 + cur0;
+	    belowerr0 = bnexterr;
+	    cur0 += delta;	/* form error * 7 */
+	    bnexterr = cur1;	/* Process component 1 */
+	    delta = cur1 * 2;
+	    cur1 += delta;	/* form error * 3 */
+	    errorptr[1] = (FSERROR) (bpreverr1 + cur1);
+	    cur1 += delta;	/* form error * 5 */
+	    bpreverr1 = belowerr1 + cur1;
+	    belowerr1 = bnexterr;
+	    cur1 += delta;	/* form error * 7 */
+	    bnexterr = cur2;	/* Process component 2 */
+	    delta = cur2 * 2;
+	    cur2 += delta;	/* form error * 3 */
+	    errorptr[2] = (FSERROR) (bpreverr2 + cur2);
+	    cur2 += delta;	/* form error * 5 */
+	    bpreverr2 = belowerr2 + cur2;
+	    belowerr2 = bnexterr;
+	    cur2 += delta;	/* form error * 7 */
+	  }
+	  /* At this point curN contains the 7/16 error value to be propagated
+	   * to the next pixel on the current line, and all the errors for the
+	   * next line have been shifted over.  We are therefore ready to move on.
+	   */
+#ifdef ORIGINAL_LIB_JPEG
+	  inptr += dir3;	/* Advance pixel pointers to next column */
+#else
+	  inptr += dir;		/* Advance pixel pointers to next column */
+#endif
+	  outptr += dir;
+	  errorptr += dir3;	/* advance errorptr to current column */
+	}
+      /* Post-loop cleanup: we must unload the final error values into the
+       * final fserrors[] entry.  Note we need not unload belowerrN because
+       * it is for the dummy column before or after the actual array.
+       */
+      errorptr[0] = (FSERROR) bpreverr0;	/* unload prev errs into array */
+      errorptr[1] = (FSERROR) bpreverr1;
+      errorptr[2] = (FSERROR) bpreverr2;
+    }
+}
+
+
+/*
+ * Initialize the error-limiting transfer function (lookup table).
+ * The raw F-S error computation can potentially compute error values of up to
+ * +- MAXJSAMPLE.  But we want the maximum correction applied to a pixel to be
+ * much less, otherwise obviously wrong pixels will be created.  (Typical
+ * effects include weird fringes at color-area boundaries, isolated bright
+ * pixels in a dark area, etc.)  The standard advice for avoiding this problem
+ * is to ensure that the "corners" of the color cube are allocated as output
+ * colors; then repeated errors in the same direction cannot cause cascading
+ * error buildup.  However, that only prevents the error from getting
+ * completely out of hand; Aaron Giles reports that error limiting improves
+ * the results even with corner colors allocated.
+ * A simple clamping of the error values to about +- MAXJSAMPLE/8 works pretty
+ * well, but the smoother transfer function used below is even better.  Thanks
+ * to Aaron Giles for this idea.
+ */
+
+LOCAL (void)
+#ifdef ORIGINAL_LIB_JPEG
+init_error_limit (j_decompress_ptr cinfo)
+#else
+init_error_limit (gdImagePtr im, my_cquantize_ptr cquantize)
+#endif
+/* Allocate and fill in the error_limiter table */
+{
+  int *table;
+  int in, out;
+#ifdef ORIGINAL_LIB_JPEG
+  my_cquantize_ptr cquantize = (my_cquantize_ptr) cinfo->cquantize;
+  table = (int *) (*cinfo->mem->alloc_small)
+    ((j_common_ptr) cinfo, JPOOL_IMAGE, (MAXJSAMPLE * 2 + 1) * SIZEOF (int));
+#else
+  cquantize->error_limiter_storage =
+    (int *) gdMalloc ((MAXJSAMPLE * 2 + 1) * sizeof (int));
+  if (!cquantize->error_limiter_storage)
+    {
+      return;
+    }
+  table = cquantize->error_limiter_storage;
+#endif
+
+  table += MAXJSAMPLE;		/* so can index -MAXJSAMPLE .. +MAXJSAMPLE */
+  cquantize->error_limiter = table;
+
+#define STEPSIZE ((MAXJSAMPLE+1)/16)
+  /* Map errors 1:1 up to +- MAXJSAMPLE/16 */
+  out = 0;
+  for (in = 0; in < STEPSIZE; in++, out++)
+    {
+      table[in] = out;
+      table[-in] = -out;
+    }
+  /* Map errors 1:2 up to +- 3*MAXJSAMPLE/16 */
+  for (; in < STEPSIZE * 3; in++, out += (in & 1) ? 0 : 1)
+    {
+      table[in] = out;
+      table[-in] = -out;
+    }
+  /* Clamp the rest to final out value (which is (MAXJSAMPLE+1)/8) */
+  for (; in <= MAXJSAMPLE; in++)
+    {
+      table[in] = out;
+      table[-in] = -out;
+    }
+#undef STEPSIZE
+}
+
+
+/*
+ * Finish up at the end of each pass.
+ */
+
+#ifdef ORIGINAL_LIB_JPEG
+METHODDEF (void)
+finish_pass1 (j_decompress_ptr cinfo)
+{
+  my_cquantize_ptr cquantize = (my_cquantize_ptr) cinfo->cquantize;
+
+  /* Select the representative colors and fill in cinfo->colormap */
+  cinfo->colormap = cquantize->sv_colormap;
+  select_colors (cinfo, cquantize->desired);
+  /* Force next pass to zero the color index table */
+  cquantize->needs_zeroed = TRUE;
+}
+
+
+METHODDEF (void)
+finish_pass2 (j_decompress_ptr cinfo)
+{
+  /* no work */
+}
+
+/*
+ * Initialize for each processing pass.
+ */
+
+METHODDEF (void)
+start_pass_2_quant (j_decompress_ptr cinfo, boolean is_pre_scan)
+{
+  my_cquantize_ptr cquantize = (my_cquantize_ptr) cinfo->cquantize;
+  hist3d histogram = cquantize->histogram;
+  int i;
+
+  /* Only F-S dithering or no dithering is supported. */
+  /* If user asks for ordered dither, give him F-S. */
+  if (cinfo->dither_mode != JDITHER_NONE)
+    cinfo->dither_mode = JDITHER_FS;
+
+  if (is_pre_scan)
+    {
+      /* Set up method pointers */
+      cquantize->pub.color_quantize = prescan_quantize;
+      cquantize->pub.finish_pass = finish_pass1;
+      cquantize->needs_zeroed = TRUE;	/* Always zero histogram */
+    }
+  else
+    {
+      /* Set up method pointers */
+      if (cinfo->dither_mode == JDITHER_FS)
+	cquantize->pub.color_quantize = pass2_fs_dither;
+      else
+	cquantize->pub.color_quantize = pass2_no_dither;
+      cquantize->pub.finish_pass = finish_pass2;
+
+      /* Make sure color count is acceptable */
+      i = cinfo->actual_number_of_colors;
+      if (i < 1)
+	ERREXIT1 (cinfo, JERR_QUANT_FEW_COLORS, 1);
+      if (i > MAXNUMCOLORS)
+	ERREXIT1 (cinfo, JERR_QUANT_MANY_COLORS, MAXNUMCOLORS);
+
+      if (cinfo->dither_mode == JDITHER_FS)
+	{
+	  size_t arraysize = (size_t) ((cinfo->output_width + 2) *
+				       (3 * SIZEOF (FSERROR)));
+	  /* Allocate Floyd-Steinberg workspace if we didn't already. */
+	  if (cquantize->fserrors == NULL)
+	    cquantize->fserrors = (FSERRPTR) (*cinfo->mem->alloc_large)
+	      ((j_common_ptr) cinfo, JPOOL_IMAGE, arraysize);
+	  /* Initialize the propagated errors to zero. */
+	  jzero_far ((void FAR *) cquantize->fserrors, arraysize);
+	  /* Make the error-limit table if we didn't already. */
+	  if (cquantize->error_limiter == NULL)
+	    init_error_limit (cinfo);
+	  cquantize->on_odd_row = FALSE;
+	}
+
+    }
+  /* Zero the histogram or inverse color map, if necessary */
+  if (cquantize->needs_zeroed)
+    {
+      for (i = 0; i < HIST_C0_ELEMS; i++)
+	{
+	  jzero_far ((void FAR *) histogram[i],
+		     HIST_C1_ELEMS * HIST_C2_ELEMS * SIZEOF (histcell));
+	}
+      cquantize->needs_zeroed = FALSE;
+    }
+}
+
+
+/*
+ * Switch to a new external colormap between output passes.
+ */
+
+METHODDEF (void)
+new_color_map_2_quant (j_decompress_ptr cinfo)
+{
+  my_cquantize_ptr cquantize = (my_cquantize_ptr) cinfo->cquantize;
+
+  /* Reset the inverse color map */
+  cquantize->needs_zeroed = TRUE;
+}
+#else
+static void
+zeroHistogram (hist3d histogram)
+{
+  int i;
+  /* Zero the histogram or inverse color map */
+  for (i = 0; i < HIST_C0_ELEMS; i++)
+    {
+      memset (histogram[i],
+	      0, HIST_C1_ELEMS * HIST_C2_ELEMS * sizeof (histcell));
+    }
+}
+#endif
+
+/*
+ * Module initialization routine for 2-pass color quantization.
+ */
+
+#ifdef ORIGINAL_LIB_JPEG
+GLOBAL (void)
+jinit_2pass_quantizer (j_decompress_ptr cinfo)
+#else
+void
+gdImageTrueColorToPalette (gdImagePtr im, int dither, int colorsWanted)
+#endif
+{
+  my_cquantize_ptr cquantize = NULL;
+  int i;
+
+#ifndef ORIGINAL_LIB_JPEG
+  /* Allocate the JPEG palette-storage */
+  size_t arraysize;
+  int maxColors = gdMaxColors;
+  if (!im->trueColor)
+    {
+      /* Nothing to do! */
+      return;
+    }
+
+  /* If we have a transparent color (the alphaless mode of transparency), we
+   * must reserve a palette entry for it at the end of the palette. */
+  if (im->transparent >= 0)
+    {
+      maxColors--;
+    }
+  if (colorsWanted > maxColors)
+    {
+      colorsWanted = maxColors;
+    }
+  im->pixels = gdCalloc (sizeof (unsigned char *), im->sy);
+  if (!im->pixels)
+    {
+      /* No can do */
+      goto outOfMemory;
+    }
+  for (i = 0; (i < im->sy); i++)
+    {
+      im->pixels[i] = gdCalloc (sizeof (unsigned char *), im->sx);
+      if (!im->pixels[i])
+	{
+	  goto outOfMemory;
+	}
+    }
+#endif
+
+#ifdef ORIGINAL_LIB_JPEG
+  cquantize = (my_cquantize_ptr)
+    (*cinfo->mem->alloc_small) ((j_common_ptr) cinfo, JPOOL_IMAGE,
+				SIZEOF (my_cquantizer));
+  cinfo->cquantize = (struct jpeg_color_quantizer *) cquantize;
+  cquantize->pub.start_pass = start_pass_2_quant;
+  cquantize->pub.new_color_map = new_color_map_2_quant;
+  /* Make sure jdmaster didn't give me a case I can't handle */
+  if (cinfo->out_color_components != 3)
+    ERREXIT (cinfo, JERR_NOTIMPL);
+#else
+  cquantize = (my_cquantize_ptr) gdCalloc (sizeof (my_cquantizer), 1);
+  if (!cquantize)
+    {
+      /* No can do */
+      goto outOfMemory;
+    }
+#endif
+  cquantize->fserrors = NULL;	/* flag optional arrays not allocated */
+  cquantize->error_limiter = NULL;
+
+
+  /* Allocate the histogram/inverse colormap storage */
+#ifdef ORIGINAL_LIB_JPEG
+  cquantize->histogram = (hist3d) (*cinfo->mem->alloc_small)
+    ((j_common_ptr) cinfo, JPOOL_IMAGE, HIST_C0_ELEMS * SIZEOF (hist2d));
+  for (i = 0; i < HIST_C0_ELEMS; i++)
+    {
+      cquantize->histogram[i] = (hist2d) (*cinfo->mem->alloc_large)
+	((j_common_ptr) cinfo, JPOOL_IMAGE,
+	 HIST_C1_ELEMS * HIST_C2_ELEMS * SIZEOF (histcell));
+    }
+  cquantize->needs_zeroed = TRUE;	/* histogram is garbage now */
+#else
+  cquantize->histogram = (hist3d) gdMalloc (HIST_C0_ELEMS * sizeof (hist2d));
+  for (i = 0; i < HIST_C0_ELEMS; i++)
+    {
+      cquantize->histogram[i] =
+	(hist2d) gdMalloc (HIST_C1_ELEMS * HIST_C2_ELEMS * sizeof (histcell));
+      if (!cquantize->histogram[i])
+	{
+	  goto outOfMemory;
+	}
+    }
+#endif
+
+#ifdef ORIGINAL_LIB_JPEG
+  /* Allocate storage for the completed colormap, if required.
+   * We do this now since it is FAR storage and may affect
+   * the memory manager's space calculations.
+   */
+  if (cinfo->enable_2pass_quant)
+    {
+      /* Make sure color count is acceptable */
+      int desired = cinfo->desired_number_of_colors;
+      /* Lower bound on # of colors ... somewhat arbitrary as long as > 0 */
+      if (desired < 8)
+	ERREXIT1 (cinfo, JERR_QUANT_FEW_COLORS, 8);
+      /* Make sure colormap indexes can be represented by JSAMPLEs */
+      if (desired > MAXNUMCOLORS)
+	ERREXIT1 (cinfo, JERR_QUANT_MANY_COLORS, MAXNUMCOLORS);
+      cquantize->sv_colormap = (*cinfo->mem->alloc_sarray)
+	((j_common_ptr) cinfo, JPOOL_IMAGE, (JDIMENSION) desired,
+	 (JDIMENSION) 3);
+      cquantize->desired = desired;
+    }
+  else
+    cquantize->sv_colormap = NULL;
+
+  /* Only F-S dithering or no dithering is supported. */
+  /* If user asks for ordered dither, give him F-S. */
+  if (cinfo->dither_mode != JDITHER_NONE)
+    cinfo->dither_mode = JDITHER_FS;
+
+  /* Allocate Floyd-Steinberg workspace if necessary.
+   * This isn't really needed until pass 2, but again it is FAR storage.
+   * Although we will cope with a later change in dither_mode,
+   * we do not promise to honor max_memory_to_use if dither_mode changes.
+   */
+  if (cinfo->dither_mode == JDITHER_FS)
+    {
+      cquantize->fserrors = (FSERRPTR) (*cinfo->mem->alloc_large)
+	((j_common_ptr) cinfo, JPOOL_IMAGE,
+	 (size_t) ((cinfo->output_width + 2) * (3 * SIZEOF (FSERROR))));
+      /* Might as well create the error-limiting table too. */
+      init_error_limit (cinfo);
+    }
+#else
+
+  cquantize->fserrors = (FSERRPTR) gdMalloc (3 * sizeof (FSERROR));
+  init_error_limit (im, cquantize);
+  arraysize = (size_t) ((im->sx + 2) * (3 * sizeof (FSERROR)));
+  /* Allocate Floyd-Steinberg workspace. */
+  cquantize->fserrors = gdCalloc (arraysize, 1);
+  if (!cquantize->fserrors)
+    {
+      goto outOfMemory;
+    }
+  cquantize->on_odd_row = FALSE;
+
+  /* Do the work! */
+  zeroHistogram (cquantize->histogram);
+  prescan_quantize (im, cquantize);
+  /* TBB 2.0.5: pass colorsWanted, not 256! */
+  select_colors (im, cquantize, colorsWanted);
+  zeroHistogram (cquantize->histogram);
+  if (dither)
+    {
+      pass2_fs_dither (im, cquantize);
+    }
+  else
+    {
+      pass2_no_dither (im, cquantize);
+    }
+#if 0				/* 2.0.12; we no longer attempt full alpha in palettes */
+  if (cquantize->transparentIsPresent)
+    {
+      int mt = -1;
+      int mtIndex = -1;
+      for (i = 0; (i < im->colorsTotal); i++)
+	{
+	  if (im->alpha[i] > mt)
+	    {
+	      mtIndex = i;
+	      mt = im->alpha[i];
+	    }
+	}
+      for (i = 0; (i < im->colorsTotal); i++)
+	{
+	  if (im->alpha[i] == mt)
+	    {
+	      im->alpha[i] = gdAlphaTransparent;
+	    }
+	}
+    }
+  if (cquantize->opaqueIsPresent)
+    {
+      int mo = 128;
+      int moIndex = -1;
+      for (i = 0; (i < im->colorsTotal); i++)
+	{
+	  if (im->alpha[i] < mo)
+	    {
+	      moIndex = i;
+	      mo = im->alpha[i];
+	    }
+	}
+      for (i = 0; (i < im->colorsTotal); i++)
+	{
+	  if (im->alpha[i] == mo)
+	    {
+	      im->alpha[i] = gdAlphaOpaque;
+	    }
+	}
+    }
+#endif
+
+  /* If we had a 'transparent' color, increment the color count so it's
+   * officially in the palette and convert the transparent variable to point to
+   * an index rather than a color (Its data already exists and transparent
+   * pixels have already been mapped to it by this point, it is done late as to
+   * avoid color matching / dithering with it). */
+  if (im->transparent >= 0)
+    {
+      im->transparent = im->colorsTotal;
+      im->colorsTotal++;
+    }
+
+  /* Success! Get rid of the truecolor image data. */
+  im->trueColor = 0;
+  /* Junk the truecolor pixels */
+  for (i = 0; i < im->sy; i++)
+    {
+      gdFree (im->tpixels[i]);
+    }
+  gdFree (im->tpixels);
+  im->tpixels = 0;
+  /* Tediously free stuff. */
+outOfMemory:
+  if (im->trueColor)
+    {
+      /* On failure only */
+      for (i = 0; i < im->sy; i++)
+	{
+	  if (im->pixels[i])
+	    {
+	      gdFree (im->pixels[i]);
+	    }
+	}
+      if (im->pixels)
+	{
+	  gdFree (im->pixels);
+	}
+      im->pixels = 0;
+    }
+  for (i = 0; i < HIST_C0_ELEMS; i++)
+    {
+      if (cquantize->histogram[i])
+	{
+	  gdFree (cquantize->histogram[i]);
+	}
+    }
+  if (cquantize->histogram)
+    {
+      gdFree (cquantize->histogram);
+    }
+  if (cquantize->fserrors)
+    {
+      gdFree (cquantize->fserrors);
+    }
+  if (cquantize->error_limiter_storage)
+    {
+      gdFree (cquantize->error_limiter_storage);
+    }
+  if (cquantize)
+    {
+      gdFree (cquantize);
+    }
+
+#endif
+}
+
+#endif
diff --git a/collects/plot/src/all/gdcache.c b/collects/plot/src/all/gdcache.c
new file mode 100644
index 0000000000..b5b8913415
--- /dev/null
+++ b/collects/plot/src/all/gdcache.c
@@ -0,0 +1,218 @@
+
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+
+#include "gd.h"
+#include "gdhelpers.h"
+
+#ifdef HAVE_LIBTTF
+#define NEED_CACHE 1
+#else
+#ifdef HAVE_LIBFREETYPE
+#define NEED_CACHE 1
+#endif
+#endif
+
+#ifdef NEED_CACHE
+
+/* 
+ * gdcache.c
+ *
+ * Caches of pointers to user structs in which the least-recently-used 
+ * element is replaced in the event of a cache miss after the cache has 
+ * reached a given size.
+ *
+ * John Ellson  (ellson@graphviz.org)  Oct 31, 1997
+ *
+ * Test this with:
+ *               gcc -o gdcache -g -Wall -DTEST gdcache.c
+ *
+ * The cache is implemented by a singly-linked list of elements
+ * each containing a pointer to a user struct that is being managed by
+ * the cache.
+ *
+ * The head structure has a pointer to the most-recently-used
+ * element, and elements are moved to this position in the list each
+ * time they are used.  The head also contains pointers to three
+ * user defined functions: 
+ *              - a function to test if a cached userdata matches some keydata 
+ *              - a function to provide a new userdata struct to the cache 
+ *          if there has been a cache miss.
+ *              - a function to release a userdata struct when it is
+ *          no longer being managed by the cache
+ *
+ * In the event of a cache miss the cache is allowed to grow up to
+ * a specified maximum size.  After the maximum size is reached then
+ * the least-recently-used element is discarded to make room for the 
+ * new.  The most-recently-returned value is always left at the 
+ * beginning of the list after retrieval.
+ *
+ * In the current implementation the cache is traversed by a linear
+ * search from most-recent to least-recent.  This linear search
+ * probably limits the usefulness of this implementation to cache
+ * sizes of a few tens of elements.
+ */
+
+#include "gdcache.h"
+
+/*********************************************************/
+/* implementation                                        */
+/*********************************************************/
+
+
+/* create a new cache */
+gdCache_head_t *
+gdCacheCreate (int size,
+	       gdCacheTestFn_t gdCacheTest,
+	       gdCacheFetchFn_t gdCacheFetch,
+	       gdCacheReleaseFn_t gdCacheRelease)
+{
+  gdCache_head_t *head;
+
+  head = (gdCache_head_t *) gdMalloc (sizeof (gdCache_head_t));
+  head->mru = NULL;
+  head->size = size;
+  head->gdCacheTest = gdCacheTest;
+  head->gdCacheFetch = gdCacheFetch;
+  head->gdCacheRelease = gdCacheRelease;
+  return head;
+}
+
+void
+gdCacheDelete (gdCache_head_t * head)
+{
+  gdCache_element_t *elem, *prev;
+
+  elem = head->mru;
+  while (elem)
+    {
+      (*(head->gdCacheRelease)) (elem->userdata);
+      prev = elem;
+      elem = elem->next;
+      gdFree ((char *) prev);
+    }
+  gdFree ((char *) head);
+}
+
+void *
+gdCacheGet (gdCache_head_t * head, void *keydata)
+{
+  int i = 0;
+  gdCache_element_t *elem, *prev = NULL, *prevprev = NULL;
+  void *userdata;
+
+  elem = head->mru;
+  while (elem)
+    {
+      if ((*(head->gdCacheTest)) (elem->userdata, keydata))
+	{
+	  if (i)
+	    {			/* if not already most-recently-used */
+	      /* relink to top of list */
+	      prev->next = elem->next;
+	      elem->next = head->mru;
+	      head->mru = elem;
+	    }
+	  return elem->userdata;
+	}
+      prevprev = prev;
+      prev = elem;
+      elem = elem->next;
+      i++;
+    }
+  userdata = (*(head->gdCacheFetch)) (&(head->error), keydata);
+  if (!userdata)
+    {
+      /* if there was an error in the fetch then don't cache */
+      return NULL;
+    }
+  if (i < head->size)
+    {				/* cache still growing - add new elem */
+      elem = (gdCache_element_t *) gdMalloc (sizeof (gdCache_element_t));
+    }
+  else
+    {				/* cache full - replace least-recently-used */
+      /* preveprev becomes new end of list */
+      prevprev->next = NULL;
+      elem = prev;
+      (*(head->gdCacheRelease)) (elem->userdata);
+    }
+  /* relink to top of list */
+  elem->next = head->mru;
+  head->mru = elem;
+  elem->userdata = userdata;
+  return userdata;
+}
+
+
+
+/*********************************************************/
+/* test stub                                             */
+/*********************************************************/
+
+
+#ifdef TEST
+
+#include <stdio.h>
+
+typedef struct
+{
+  int key;
+  int value;
+}
+key_value_t;
+
+static int
+cacheTest (void *map, void *key)
+{
+  return (((key_value_t *) map)->key == *(int *) key);
+}
+
+static void *
+cacheFetch (char **error, void *key)
+{
+  key_value_t *map;
+
+  map = (key_value_t *) gdMalloc (sizeof (key_value_t));
+  map->key = *(int *) key;
+  map->value = 3;
+
+  *error = NULL;
+  return (void *) map;
+}
+
+static void
+cacheRelease (void *map)
+{
+  gdFree ((char *) map);
+}
+
+int
+main (char *argv[], int argc)
+{
+  gdCache_head_t *cacheTable;
+  int elem, key;
+
+  cacheTable = gdCacheCreate (3, cacheTest, cacheFetch, cacheRelease);
+
+  key = 20;
+  elem = *(int *) gdCacheGet (cacheTable, &key);
+  key = 30;
+  elem = *(int *) gdCacheGet (cacheTable, &key);
+  key = 40;
+  elem = *(int *) gdCacheGet (cacheTable, &key);
+  key = 50;
+  elem = *(int *) gdCacheGet (cacheTable, &key);
+  key = 30;
+  elem = *(int *) gdCacheGet (cacheTable, &key);
+  key = 30;
+  elem = *(int *) gdCacheGet (cacheTable, &key);
+
+  gdCacheDelete (cacheTable);
+
+  return 0;
+}
+
+#endif /* TEST */
+#endif /* HAVE_LIBTTF */
diff --git a/collects/plot/src/all/gdcache.h b/collects/plot/src/all/gdcache.h
new file mode 100644
index 0000000000..549e224a51
--- /dev/null
+++ b/collects/plot/src/all/gdcache.h
@@ -0,0 +1,85 @@
+/* 
+ * gdcache.h
+ *
+ * Caches of pointers to user structs in which the least-recently-used 
+ * element is replaced in the event of a cache miss after the cache has 
+ * reached a given size.
+ *
+ * John Ellson  (ellson@graphviz.org)  Oct 31, 1997
+ *
+ * Test this with:
+ *		 gcc -o gdcache -g -Wall -DTEST gdcache.c
+ *
+ * The cache is implemented by a singly-linked list of elements
+ * each containing a pointer to a user struct that is being managed by
+ * the cache.
+ *
+ * The head structure has a pointer to the most-recently-used
+ * element, and elements are moved to this position in the list each
+ * time they are used.  The head also contains pointers to three
+ * user defined functions: 
+ *		- a function to test if a cached userdata matches some keydata 
+ *		- a function to provide a new userdata struct to the cache 
+ *          if there has been a cache miss.
+ *		- a function to release a userdata struct when it is
+ *          no longer being managed by the cache
+ *
+ * In the event of a cache miss the cache is allowed to grow up to
+ * a specified maximum size.  After the maximum size is reached then
+ * the least-recently-used element is discarded to make room for the 
+ * new.  The most-recently-returned value is always left at the 
+ * beginning of the list after retrieval.
+ *
+ * In the current implementation the cache is traversed by a linear
+ * search from most-recent to least-recent.  This linear search
+ * probably limits the usefulness of this implementation to cache
+ * sizes of a few tens of elements.
+ */
+
+/*********************************************************/
+/* header                                                */
+/*********************************************************/
+
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+
+#include <stdlib.h>
+#ifndef NULL
+#define NULL (void *)0
+#endif
+
+/* user defined function templates */
+typedef int (*gdCacheTestFn_t) (void *userdata, void *keydata);
+typedef void *(*gdCacheFetchFn_t) (char **error, void *keydata);
+typedef void (*gdCacheReleaseFn_t) (void *userdata);
+
+/* element structure */
+typedef struct gdCache_element_s gdCache_element_t;
+struct gdCache_element_s
+{
+  gdCache_element_t *next;
+  void *userdata;
+};
+
+/* head structure */
+typedef struct gdCache_head_s gdCache_head_t;
+struct gdCache_head_s
+{
+  gdCache_element_t *mru;
+  int size;
+  char *error;
+  gdCacheTestFn_t gdCacheTest;
+  gdCacheFetchFn_t gdCacheFetch;
+  gdCacheReleaseFn_t gdCacheRelease;
+};
+
+/* function templates */
+gdCache_head_t *gdCacheCreate (int size,
+			       gdCacheTestFn_t gdCacheTest,
+			       gdCacheFetchFn_t gdCacheFetch,
+			       gdCacheReleaseFn_t gdCacheRelease);
+
+void gdCacheDelete (gdCache_head_t * head);
+
+void *gdCacheGet (gdCache_head_t * head, void *keydata);
diff --git a/collects/plot/src/all/gdfontg.c b/collects/plot/src/all/gdfontg.c
new file mode 100644
index 0000000000..4fd0fceeae
--- /dev/null
+++ b/collects/plot/src/all/gdfontg.c
@@ -0,0 +1,4382 @@
+
+
+/*
+   This is a header file for gd font, generated using
+   bdftogd version 0.51 by Jan Pazdziora, adelton@fi.muni.cz
+   from bdf font
+   -Misc-Fixed-Bold-R-Normal-Sans-15-140-75-75-C-90-ISO8859-2
+   at Mon Jan 26 14:45:58 1998.
+   The original bdf was holding following copyright:
+   "Libor Skarvada, libor@informatics.muni.cz"
+ */
+
+
+#include "gdfontg.h"
+
+char gdFontGiantData[] = {
+/* Char 0 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 1 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 2 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 0, 1, 0, 1, 0, 1, 0, 0,
+  0, 1, 0, 1, 0, 1, 0, 1, 0,
+  1, 0, 1, 0, 1, 0, 1, 0, 0,
+  0, 1, 0, 1, 0, 1, 0, 1, 0,
+  1, 0, 1, 0, 1, 0, 1, 0, 0,
+  0, 1, 0, 1, 0, 1, 0, 1, 0,
+  1, 0, 1, 0, 1, 0, 1, 0, 0,
+  0, 1, 0, 1, 0, 1, 0, 1, 0,
+  1, 0, 1, 0, 1, 0, 1, 0, 0,
+  0, 1, 0, 1, 0, 1, 0, 1, 0,
+  1, 0, 1, 0, 1, 0, 1, 0, 0,
+  0, 1, 0, 1, 0, 1, 0, 1, 0,
+  1, 0, 1, 0, 1, 0, 1, 0, 0,
+  0, 1, 0, 1, 0, 1, 0, 1, 0,
+
+/* Char 3 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 4 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 5 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 0, 0, 0,
+  1, 1, 0, 0, 0, 1, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 1, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 6 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 7 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 8 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 9 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0, 0, 0,
+  1, 1, 1, 0, 1, 1, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0, 0, 0,
+  1, 1, 0, 1, 1, 1, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 10 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 11 */
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 12 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+
+/* Char 13 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 1, 1, 1,
+  0, 0, 0, 1, 1, 1, 1, 1, 1,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+
+/* Char 14 */
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 1, 1, 1,
+  0, 0, 0, 1, 1, 1, 1, 1, 1,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 15 */
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 1,
+  1, 1, 1, 1, 1, 1, 1, 1, 1,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+
+/* Char 16 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 1,
+  1, 1, 1, 1, 1, 1, 1, 1, 1,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 17 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 1,
+  1, 1, 1, 1, 1, 1, 1, 1, 1,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 18 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 1,
+  1, 1, 1, 1, 1, 1, 1, 1, 1,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 19 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 1,
+  1, 1, 1, 1, 1, 1, 1, 1, 1,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 20 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 1,
+  1, 1, 1, 1, 1, 1, 1, 1, 1,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 21 */
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 1, 1, 1,
+  0, 0, 0, 1, 1, 1, 1, 1, 1,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+
+/* Char 22 */
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+
+/* Char 23 */
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 1,
+  1, 1, 1, 1, 1, 1, 1, 1, 1,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 24 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 1,
+  1, 1, 1, 1, 1, 1, 1, 1, 1,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+
+/* Char 25 */
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+
+/* Char 26 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 1, 0,
+  0, 0, 0, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 27 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0, 0,
+  1, 1, 1, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 28 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 0, 0, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 29 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 30 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0, 0, 0, 0,
+  1, 0, 1, 1, 1, 1, 1, 1, 0,
+  1, 1, 1, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 31 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 32 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 33 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 34 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 35 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 1, 1, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 1, 1, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 1, 1, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 1, 1, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 36 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 1, 0, 0,
+  0, 1, 1, 0, 1, 0, 1, 1, 0,
+  0, 1, 1, 0, 1, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 1, 0, 1, 1, 0,
+  0, 1, 1, 0, 1, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 37 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 1, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 1, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 38 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0, 1, 0,
+  1, 1, 0, 0, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 1, 0, 0,
+  0, 1, 1, 1, 1, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 39 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 40 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 41 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 42 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 43 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 44 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 45 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 46 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 47 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 48 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 49 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 50 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 51 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 0, 0, 0,
+  1, 1, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 1, 1, 0, 0,
+  0, 1, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 52 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 1, 0, 0,
+  0, 0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 1, 1, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 53 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 1, 1, 1, 0, 0, 0,
+  1, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 54 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 1, 1, 1, 0, 0, 0,
+  1, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 55 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 56 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 57 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 58 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 59 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 60 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 61 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 62 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 63 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 64 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 1, 1, 0,
+  1, 1, 0, 1, 1, 0, 1, 1, 0,
+  1, 1, 0, 1, 1, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 65 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 66 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0, 0, 0,
+  1, 1, 0, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 1, 1, 0, 0,
+  1, 1, 1, 1, 1, 1, 0, 0, 0,
+  1, 1, 0, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 1, 1, 0, 0,
+  1, 1, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 67 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0, 1, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 1, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 68 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0, 0, 0,
+  1, 1, 0, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 1, 1, 0, 0,
+  1, 1, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 69 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 70 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 71 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 72 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 73 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 74 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 1, 1, 0, 0,
+  0, 1, 1, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 75 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0, 0, 0,
+  1, 1, 0, 1, 1, 0, 0, 0, 0,
+  1, 1, 1, 1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 1, 1, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0, 0, 0,
+  1, 1, 0, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 76 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 77 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 1, 0, 0, 1, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 1, 1, 0, 1, 1, 0,
+  1, 1, 0, 1, 1, 0, 1, 1, 0,
+  1, 1, 0, 1, 1, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 78 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 1, 0, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 1, 1, 0, 1, 1, 0,
+  1, 1, 0, 1, 1, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 79 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 80 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 81 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 1, 1, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 82 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 1, 0, 0,
+  1, 1, 1, 1, 1, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0, 0, 0,
+  1, 1, 0, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 83 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 84 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 85 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 86 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 87 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 1, 1, 0, 1, 1, 0,
+  1, 1, 0, 1, 1, 0, 1, 1, 0,
+  1, 1, 0, 1, 1, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  1, 1, 1, 0, 0, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 88 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 89 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 90 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 91 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 92 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 93 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 94 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 95 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 96 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 97 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 1, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 98 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 1, 1, 1, 0, 0, 0,
+  1, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 99 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 100 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 101 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 102 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 103 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 0, 1, 0,
+  1, 1, 0, 0, 0, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 1, 1, 0, 0,
+  0, 1, 1, 1, 1, 1, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+
+/* Char 104 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 1, 1, 1, 0, 0, 0,
+  1, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 105 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 106 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 1, 1, 0, 0,
+  0, 1, 1, 1, 1, 1, 0, 0, 0,
+
+/* Char 107 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 1, 1, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 108 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 109 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 0, 1, 1, 0, 1, 1, 0, 0,
+  1, 1, 0, 1, 1, 0, 1, 1, 0,
+  1, 1, 0, 1, 1, 0, 1, 1, 0,
+  1, 1, 0, 1, 1, 0, 1, 1, 0,
+  1, 1, 0, 1, 1, 0, 1, 1, 0,
+  1, 1, 0, 1, 1, 0, 1, 1, 0,
+  1, 1, 0, 1, 1, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 110 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 1, 1, 1, 0, 0, 0,
+  1, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 111 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 112 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 1, 1, 1, 0, 0, 0,
+  1, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 1, 1, 1, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 113 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+
+/* Char 114 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 115 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 116 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 117 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 118 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 119 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 1, 1, 0, 1, 1, 0,
+  1, 1, 0, 1, 1, 0, 1, 1, 0,
+  1, 1, 0, 1, 1, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 120 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 121 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 1, 1, 0,
+  1, 0, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+
+/* Char 122 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 123 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 124 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 125 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 126 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 1, 1, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 127 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 128 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 129 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 130 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 131 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 132 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 133 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 134 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 135 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 136 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 137 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 138 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 139 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 140 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 141 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 142 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 143 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 144 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 145 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 146 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 147 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 148 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 149 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 150 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 151 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 152 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 153 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 154 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 155 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 156 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 157 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 158 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 159 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 160 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 161 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+
+/* Char 162 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 163 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 0, 0, 0,
+  0, 1, 1, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0, 0, 0, 0,
+  1, 1, 1, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 164 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 1, 1, 0, 1, 1, 0, 0,
+  0, 0, 1, 0, 0, 0, 1, 0, 0,
+  0, 0, 1, 1, 0, 1, 1, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 1, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 165 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0, 0, 0,
+  1, 1, 0, 1, 1, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 166 */
+  0, 0, 0, 0, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 167 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 168 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 169 */
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 170 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0, 0, 0, 0,
+
+/* Char 171 */
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 172 */
+  0, 0, 0, 0, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 173 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 174 */
+  0, 1, 1, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 175 */
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 176 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 177 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 1, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 1,
+
+/* Char 178 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 1, 0, 0,
+
+/* Char 179 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 1, 0, 0,
+  0, 0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0, 0, 0,
+  0, 1, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 180 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 181 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 182 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 183 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 184 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0, 0,
+
+/* Char 185 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 186 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0, 0, 0, 0,
+
+/* Char 187 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 0, 1, 1, 0, 0,
+  1, 1, 1, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 188 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 189 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 190 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 191 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 192 */
+  0, 0, 0, 0, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 1, 0, 0,
+  1, 1, 1, 1, 1, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0, 0, 0,
+  1, 1, 0, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 193 */
+  0, 0, 0, 0, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 194 */
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 195 */
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 196 */
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 197 */
+  0, 0, 0, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 198 */
+  0, 0, 0, 0, 0, 1, 1, 1, 0,
+  0, 0, 0, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0, 1, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 1, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 199 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0, 1, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 1, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0, 0,
+
+/* Char 200 */
+  0, 0, 1, 1, 0, 1, 1, 0, 0,
+  0, 0, 0, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0, 1, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 1, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 201 */
+  0, 0, 0, 0, 0, 1, 1, 1, 0,
+  0, 0, 0, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 202 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 1, 0,
+
+/* Char 203 */
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 204 */
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 205 */
+  0, 0, 0, 0, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 206 */
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 207 */
+  0, 1, 1, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0, 0, 0,
+  1, 1, 0, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 1, 1, 0, 0,
+  1, 1, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 208 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 209 */
+  0, 0, 0, 0, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 1, 0, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 1, 1, 0, 1, 1, 0,
+  1, 1, 0, 1, 1, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 210 */
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 1, 0, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 1, 1, 0, 1, 1, 0,
+  1, 1, 0, 1, 1, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 211 */
+  0, 0, 0, 0, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 212 */
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 213 */
+  0, 0, 1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 214 */
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 215 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 1, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 0, 1, 1, 0, 0,
+  0, 0, 0, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  0, 1, 0, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 216 */
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 1, 0, 0,
+  1, 1, 1, 1, 1, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0, 0, 0,
+  1, 1, 0, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 217 */
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 218 */
+  0, 0, 0, 0, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 219 */
+  0, 0, 1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 220 */
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 221 */
+  0, 0, 0, 0, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 222 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0, 0,
+
+/* Char 223 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 1, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 224 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 225 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 1, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 226 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 1, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 227 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 1, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 228 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 1, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 229 */
+  0, 0, 0, 0, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 230 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 231 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0, 0,
+
+/* Char 232 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 1, 1, 0, 0,
+  0, 0, 0, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 233 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 234 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 1, 0,
+
+/* Char 235 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 236 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 237 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 238 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 239 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 1, 1, 1,
+  0, 0, 0, 0, 0, 0, 0, 1, 1,
+  0, 0, 0, 0, 0, 1, 1, 1, 1,
+  0, 0, 0, 0, 0, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 1, 1, 0, 0,
+  0, 1, 1, 0, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 1, 1, 0, 0,
+  0, 1, 1, 0, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 240 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 1, 1, 0, 0,
+  0, 1, 1, 0, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 1, 1, 0, 0,
+  0, 1, 1, 0, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 241 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 1, 1, 1, 0, 0, 0,
+  1, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 242 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 1, 1, 1, 0, 0, 0,
+  1, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 243 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 244 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 245 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 1, 1, 0,
+  0, 0, 1, 1, 0, 1, 1, 0, 0,
+  0, 1, 1, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 246 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 247 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 248 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 1, 1, 0, 0,
+  0, 0, 0, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 249 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 250 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 251 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 1, 1, 0,
+  0, 0, 1, 1, 0, 1, 1, 0, 0,
+  0, 1, 1, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 252 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 253 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 1, 1, 0,
+  1, 0, 0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 1, 0, 0,
+
+/* Char 254 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0, 0,
+
+/* Char 255 */
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+
+};
+
+gdFont gdFontGiantRep = {
+  256,
+  0,
+  9,
+  15,
+  gdFontGiantData
+};
+
+gdFontPtr gdFontGiant = &gdFontGiantRep;
+
+/* This file has not been truncated. */
diff --git a/collects/plot/src/all/gdfontg.h b/collects/plot/src/all/gdfontg.h
new file mode 100644
index 0000000000..9dce47053e
--- /dev/null
+++ b/collects/plot/src/all/gdfontg.h
@@ -0,0 +1,29 @@
+
+#ifndef _GDFONTG_H_
+#define _GDFONTG_H_ 1
+
+#ifdef __cplusplus
+extern "C"
+{
+#endif
+
+/*
+	This is a header file for gd font, generated using
+	bdftogd version 0.51 by Jan Pazdziora, adelton@fi.muni.cz
+	from bdf font
+	-Misc-Fixed-Bold-R-Normal-Sans-15-140-75-75-C-90-ISO8859-2
+	at Mon Jan 26 14:45:58 1998.
+	The original bdf was holding following copyright:
+	"Libor Skarvada, libor@informatics.muni.cz"
+ */
+
+
+#include "gd.h"
+
+  extern gdFontPtr gdFontGiant;
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif
diff --git a/collects/plot/src/all/gdfontl.c b/collects/plot/src/all/gdfontl.c
new file mode 100644
index 0000000000..8e8a279c8f
--- /dev/null
+++ b/collects/plot/src/all/gdfontl.c
@@ -0,0 +1,4639 @@
+
+
+/*
+   This is a header file for gd font, generated using
+   bdftogd version 0.5 by Jan Pazdziora, adelton@fi.muni.cz
+   from bdf font
+   -misc-fixed-medium-r-normal--16-140-75-75-c-80-iso8859-2
+   at Tue Jan  6 19:39:27 1998.
+
+   The original bdf was holding following copyright:
+   "Libor Skarvada, libor@informatics.muni.cz"
+ */
+
+
+#include "gdfontl.h"
+
+char gdFontLargeData[] = {
+/* Char 0 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 1 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 2 */
+  1, 0, 1, 0, 1, 0, 1, 0,
+  0, 1, 0, 1, 0, 1, 0, 1,
+  1, 0, 1, 0, 1, 0, 1, 0,
+  0, 1, 0, 1, 0, 1, 0, 1,
+  1, 0, 1, 0, 1, 0, 1, 0,
+  0, 1, 0, 1, 0, 1, 0, 1,
+  1, 0, 1, 0, 1, 0, 1, 0,
+  0, 1, 0, 1, 0, 1, 0, 1,
+  1, 0, 1, 0, 1, 0, 1, 0,
+  0, 1, 0, 1, 0, 1, 0, 1,
+  1, 0, 1, 0, 1, 0, 1, 0,
+  0, 1, 0, 1, 0, 1, 0, 1,
+  1, 0, 1, 0, 1, 0, 1, 0,
+  0, 1, 0, 1, 0, 1, 0, 1,
+  1, 0, 1, 0, 1, 0, 1, 0,
+  0, 1, 0, 1, 0, 1, 0, 1,
+
+/* Char 3 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 0, 0, 0,
+  1, 0, 0, 0, 1, 0, 0, 0,
+  1, 1, 1, 1, 1, 0, 0, 0,
+  1, 0, 0, 0, 1, 0, 0, 0,
+  1, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 4 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 1, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 5 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 0, 0,
+  0, 0, 0, 1, 0, 0, 1, 0,
+  0, 0, 0, 1, 1, 1, 0, 0,
+  0, 0, 0, 1, 0, 1, 0, 0,
+  0, 0, 0, 1, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 6 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 1, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 7 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 8 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 9 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 0, 0, 0,
+  1, 1, 0, 0, 1, 0, 0, 0,
+  1, 0, 1, 0, 1, 0, 0, 0,
+  1, 0, 0, 1, 1, 0, 0, 0,
+  1, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 10 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 0, 0, 0,
+  1, 0, 0, 0, 1, 0, 0, 0,
+  0, 1, 0, 1, 0, 0, 0, 0,
+  0, 1, 0, 1, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 11 */
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  1, 1, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 12 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+
+/* Char 13 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 1, 1,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+
+/* Char 14 */
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 1, 1,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 15 */
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 1,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+
+/* Char 16 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 1,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 17 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 1,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 18 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 1,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 19 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 1,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 20 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 1,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 21 */
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 1, 1,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+
+/* Char 22 */
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  1, 1, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+
+/* Char 23 */
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 1,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 24 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 1,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+
+/* Char 25 */
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+
+/* Char 26 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 27 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 28 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  1, 0, 1, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 1, 0, 0, 0,
+  1, 1, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 29 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 30 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 1, 0,
+  1, 0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 31 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 32 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 33 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 34 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 35 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 1, 0,
+  0, 0, 0, 1, 0, 0, 1, 0,
+  0, 0, 0, 1, 0, 0, 1, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 1, 0, 0, 1, 0, 0, 0,
+  0, 1, 0, 0, 1, 0, 0, 0,
+  0, 1, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 36 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 0, 0,
+  1, 0, 0, 1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 0, 0,
+  0, 0, 0, 1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0, 0, 1, 0,
+  0, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 37 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 1, 0,
+  1, 0, 0, 1, 0, 1, 0, 0,
+  1, 0, 0, 1, 0, 1, 0, 0,
+  0, 1, 1, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 1, 0, 1, 1, 0, 0,
+  0, 1, 0, 1, 0, 0, 1, 0,
+  0, 1, 0, 1, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 38 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 1, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0, 1, 0,
+  1, 0, 0, 0, 0, 1, 0, 0,
+  1, 0, 0, 0, 1, 1, 0, 0,
+  0, 1, 1, 1, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 39 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 40 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 41 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 42 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  1, 0, 0, 1, 0, 0, 1, 0,
+  0, 1, 0, 1, 0, 1, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0,
+  0, 1, 0, 1, 0, 1, 0, 0,
+  1, 0, 0, 1, 0, 0, 1, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 43 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 44 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 45 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 46 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 47 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 48 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 49 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 50 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 51 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 52 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 1, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 53 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 54 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 0, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 55 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 56 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 57 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 58 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 59 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 60 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 61 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 62 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 63 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 64 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 0, 0,
+  0, 0, 1, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 1, 0, 1, 0,
+  0, 1, 0, 1, 0, 1, 1, 0,
+  0, 1, 0, 1, 0, 0, 1, 0,
+  0, 1, 0, 1, 0, 0, 1, 0,
+  0, 1, 0, 1, 0, 0, 1, 0,
+  0, 1, 0, 0, 1, 1, 1, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 65 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 66 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 67 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 68 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 69 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 70 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 71 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 1, 1, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 72 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 73 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 74 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 75 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 1, 0, 0, 0,
+  0, 1, 0, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0,
+  0, 1, 0, 1, 0, 0, 0, 0,
+  0, 1, 0, 0, 1, 0, 0, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 76 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 77 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0, 1, 0,
+  1, 1, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 1, 1, 0,
+  1, 0, 1, 0, 1, 0, 1, 0,
+  1, 0, 1, 0, 1, 0, 1, 0,
+  1, 0, 0, 1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0, 0, 1, 0,
+  1, 0, 0, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 78 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 1, 0, 0, 0, 1, 0,
+  0, 1, 1, 0, 0, 0, 1, 0,
+  0, 1, 0, 1, 0, 0, 1, 0,
+  0, 1, 0, 1, 0, 0, 1, 0,
+  0, 1, 0, 0, 1, 0, 1, 0,
+  0, 1, 0, 0, 1, 0, 1, 0,
+  0, 1, 0, 0, 0, 1, 1, 0,
+  0, 1, 0, 0, 0, 1, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 79 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 80 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 81 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 1, 1, 0, 1, 0,
+  0, 1, 1, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 1, 1,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 82 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 1, 0, 0, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 83 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 84 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 85 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 86 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 87 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 0, 0, 1, 0,
+  1, 0, 0, 1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0, 0, 1, 0,
+  1, 0, 1, 0, 1, 0, 1, 0,
+  1, 0, 1, 0, 1, 0, 1, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 88 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 89 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 90 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 91 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 92 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 93 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 94 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 95 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 96 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 97 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 1, 1, 1, 0,
+  0, 0, 1, 1, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 98 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 1, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 1, 0, 0, 0, 1, 0,
+  0, 1, 0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 99 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 100 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 0, 1, 0,
+  0, 1, 0, 0, 0, 1, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 101 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 102 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 0, 0,
+  0, 0, 1, 0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 103 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 0, 1, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+
+/* Char 104 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 1, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 105 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 106 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0,
+
+/* Char 107 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 1, 0, 0, 0,
+  0, 1, 0, 1, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0, 0, 0,
+  0, 1, 0, 0, 1, 0, 0, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 108 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 109 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 0, 1, 1, 0, 0,
+  1, 0, 0, 1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 110 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 1, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 111 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 112 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 1, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 1, 0, 0, 0, 1, 0,
+  0, 1, 0, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+
+/* Char 113 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 0, 1, 0,
+  0, 1, 0, 0, 0, 1, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+
+/* Char 114 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 1, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 115 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 116 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 1, 0,
+  0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 117 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 118 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 119 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0, 1, 0,
+  1, 0, 0, 1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0, 0, 1, 0,
+  1, 0, 1, 0, 1, 0, 1, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 120 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 121 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 1, 1, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0,
+
+/* Char 122 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 123 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 124 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 125 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 126 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 1, 0,
+  1, 0, 0, 1, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 127 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 128 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 129 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 130 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 131 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 132 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 133 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 134 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 135 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 136 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 137 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 138 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 139 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 140 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 141 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 142 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 143 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 144 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 145 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 146 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 147 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 148 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 149 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 150 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 151 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 152 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 153 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 154 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 155 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 156 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 157 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 158 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 159 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 160 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 161 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0,
+
+/* Char 162 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 163 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 164 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  1, 0, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 165 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 1, 0, 0, 1, 0, 0, 0,
+  0, 1, 0, 1, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 166 */
+  0, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 167 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 168 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 169 */
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 170 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+
+/* Char 171 */
+  0, 0, 1, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 172 */
+  0, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 173 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 174 */
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 175 */
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 176 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 177 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 1, 1, 1, 0,
+  0, 0, 1, 1, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 1, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0,
+
+/* Char 178 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 1, 0,
+
+/* Char 179 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0,
+  0, 1, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 180 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 181 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 0, 0, 1, 0,
+  0, 0, 0, 1, 0, 0, 1, 0,
+  0, 0, 0, 1, 0, 1, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 182 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 183 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 184 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0,
+
+/* Char 185 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 186 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+
+/* Char 187 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 1, 0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0, 0, 1, 0,
+  1, 1, 1, 1, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 188 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 189 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 1, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 190 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 191 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 192 */
+  0, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 1, 0, 0, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 193 */
+  0, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 194 */
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 195 */
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 196 */
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 197 */
+  0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 198 */
+  0, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 199 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0,
+
+/* Char 200 */
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 201 */
+  0, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 202 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 1, 0,
+
+/* Char 203 */
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 204 */
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 205 */
+  0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 206 */
+  0, 0, 1, 1, 1, 0, 0, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 207 */
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 208 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  1, 1, 1, 1, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 209 */
+  0, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 1, 0, 0, 0, 1, 0,
+  0, 1, 1, 0, 0, 0, 1, 0,
+  0, 1, 0, 1, 0, 0, 1, 0,
+  0, 1, 0, 1, 0, 0, 1, 0,
+  0, 1, 0, 0, 1, 0, 1, 0,
+  0, 1, 0, 0, 1, 0, 1, 0,
+  0, 1, 0, 0, 0, 1, 1, 0,
+  0, 1, 0, 0, 0, 1, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 210 */
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 1, 0, 0, 0, 1, 0,
+  0, 1, 1, 0, 0, 0, 1, 0,
+  0, 1, 0, 1, 0, 0, 1, 0,
+  0, 1, 0, 1, 0, 0, 1, 0,
+  0, 1, 0, 0, 1, 0, 1, 0,
+  0, 1, 0, 0, 1, 0, 1, 0,
+  0, 1, 0, 0, 0, 1, 1, 0,
+  0, 1, 0, 0, 0, 1, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 211 */
+  0, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 212 */
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 213 */
+  0, 0, 0, 1, 0, 0, 1, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 214 */
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 215 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 216 */
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 1, 0, 0, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 217 */
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 218 */
+  0, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 219 */
+  0, 0, 0, 1, 0, 0, 1, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 220 */
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 221 */
+  0, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 222 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+
+/* Char 223 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  1, 1, 0, 0, 1, 0, 0, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 1, 0, 0, 0, 1, 0,
+  0, 1, 0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 224 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 1, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 225 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 1, 1, 1, 0,
+  0, 0, 1, 1, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 226 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 1, 1, 1, 0,
+  0, 0, 1, 1, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 227 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 1, 1, 1, 0,
+  0, 0, 1, 1, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 228 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 1, 1, 1, 0,
+  0, 0, 1, 1, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 229 */
+  0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 230 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 231 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0,
+
+/* Char 232 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 233 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 234 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0, 0,
+
+/* Char 235 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 236 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 237 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 238 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 1, 0, 1, 0, 0, 0,
+  0, 1, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 239 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 1, 1,
+  0, 0, 0, 0, 0, 0, 0, 1,
+  0, 0, 0, 0, 0, 1, 0, 1,
+  0, 0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 1, 1, 1, 0, 1, 0, 0,
+  1, 0, 0, 0, 1, 1, 0, 0,
+  1, 0, 0, 0, 0, 1, 0, 0,
+  1, 0, 0, 0, 0, 1, 0, 0,
+  1, 0, 0, 0, 0, 1, 0, 0,
+  1, 0, 0, 0, 1, 1, 0, 0,
+  0, 1, 1, 1, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 240 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 1, 1, 1, 0, 1, 0, 0,
+  1, 0, 0, 0, 1, 1, 0, 0,
+  1, 0, 0, 0, 0, 1, 0, 0,
+  1, 0, 0, 0, 0, 1, 0, 0,
+  1, 0, 0, 0, 0, 1, 0, 0,
+  1, 0, 0, 0, 1, 1, 0, 0,
+  0, 1, 1, 1, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 241 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 1, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 242 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 1, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 243 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 244 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 245 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 1,
+  0, 0, 0, 1, 0, 0, 1, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 246 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 247 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 248 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 1, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 249 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 250 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 251 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 1,
+  0, 0, 0, 1, 0, 0, 1, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 252 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+/* Char 253 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 1, 1, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 1, 0, 0,
+  0, 0, 1, 1, 1, 0, 0, 0,
+
+/* Char 254 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 1, 0,
+  0, 0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0, 0, 0,
+
+/* Char 255 */
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+
+
+};
+
+gdFont gdFontLargeRep = {
+  256,
+  0,
+  8,
+  16,
+  gdFontLargeData
+};
+
+gdFontPtr gdFontLarge = &gdFontLargeRep;
+
+/* This file has not been truncated. */
diff --git a/collects/plot/src/all/gdfontl.h b/collects/plot/src/all/gdfontl.h
new file mode 100644
index 0000000000..591107350c
--- /dev/null
+++ b/collects/plot/src/all/gdfontl.h
@@ -0,0 +1,30 @@
+
+#ifndef _GDFONTL_H_
+#define _GDFONTL_H_ 1
+
+#ifdef __cplusplus
+extern "C"
+{
+#endif
+
+/*
+	This is a header file for gd font, generated using
+	bdftogd version 0.5 by Jan Pazdziora, adelton@fi.muni.cz
+	from bdf font
+	-misc-fixed-medium-r-normal--16-140-75-75-c-80-iso8859-2
+	at Tue Jan  6 19:39:27 1998.
+
+	The original bdf was holding following copyright:
+	"Libor Skarvada, libor@informatics.muni.cz"
+ */
+
+
+#include "gd.h"
+
+  extern gdFontPtr gdFontLarge;
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif
diff --git a/collects/plot/src/all/gdfontmb.c b/collects/plot/src/all/gdfontmb.c
new file mode 100644
index 0000000000..5c168e6ac1
--- /dev/null
+++ b/collects/plot/src/all/gdfontmb.c
@@ -0,0 +1,3869 @@
+
+
+/*
+   This is a header file for gd font, generated using
+   bdftogd version 0.5 by Jan Pazdziora, adelton@fi.muni.cz
+   from bdf font
+   -misc-fixed-bold-r-normal-sans-13-94-100-100-c-70-iso8859-2
+   at Thu Jan  8 13:54:57 1998.
+   No copyright info was found in the original bdf.
+ */
+
+
+#include "gdfontmb.h"
+
+char gdFontMediumBoldData[] = {
+/* Char 0 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 1 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 2 */
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 3 */
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 1, 1, 0, 0,
+  1, 1, 0, 1, 1, 0, 0,
+  1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 1, 1, 0, 0,
+  1, 1, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 4 */
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 1, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 5 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 1, 0,
+  0, 0, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 1, 0,
+  0, 0, 1, 1, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 6 */
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 7 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 8 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 9 */
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 1, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 1, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 10 */
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 0, 0, 1, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 11 */
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  1, 1, 1, 1, 0, 0, 0,
+  1, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 12 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 0, 0, 0,
+  1, 1, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+
+/* Char 13 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 1,
+  0, 0, 1, 1, 1, 1, 1,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+
+/* Char 14 */
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 1,
+  0, 0, 1, 1, 1, 1, 1,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 15 */
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1,
+  1, 1, 1, 1, 1, 1, 1,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+
+/* Char 16 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1,
+  1, 1, 1, 1, 1, 1, 1,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 17 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1,
+  1, 1, 1, 1, 1, 1, 1,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 18 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1,
+  1, 1, 1, 1, 1, 1, 1,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 19 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1,
+  1, 1, 1, 1, 1, 1, 1,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 20 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1,
+  1, 1, 1, 1, 1, 1, 1,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 21 */
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 1, 1, 1,
+  0, 0, 1, 1, 1, 1, 1,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+
+/* Char 22 */
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  1, 1, 1, 1, 0, 0, 0,
+  1, 1, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+
+/* Char 23 */
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1,
+  1, 1, 1, 1, 1, 1, 1,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 24 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 1,
+  1, 1, 1, 1, 1, 1, 1,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+
+/* Char 25 */
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+
+/* Char 26 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 27 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 28 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 1, 1, 0, 1, 1, 0,
+  0, 1, 1, 0, 1, 1, 0,
+  0, 1, 1, 0, 1, 1, 0,
+  1, 1, 1, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 29 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 30 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 0, 0,
+  0, 1, 1, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 1, 1, 0,
+  1, 0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 31 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 32 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 33 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 34 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 1, 1, 0,
+  0, 1, 1, 0, 1, 1, 0,
+  0, 1, 1, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 35 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 1, 0, 0,
+  0, 0, 1, 0, 1, 0, 0,
+  0, 1, 1, 1, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 0,
+  0, 0, 1, 0, 1, 0, 0,
+  0, 1, 1, 1, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 0,
+  0, 0, 1, 0, 1, 0, 0,
+  0, 0, 1, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 36 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 0, 1, 1, 0, 1, 0,
+  1, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 1, 0,
+  1, 0, 1, 1, 0, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 37 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 0, 0, 1, 0,
+  1, 0, 1, 0, 1, 1, 0,
+  1, 1, 1, 0, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 1, 0, 1, 1, 1, 0,
+  1, 1, 0, 1, 0, 1, 0,
+  1, 0, 0, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 38 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0, 0,
+  1, 1, 0, 1, 1, 0, 0,
+  1, 1, 0, 1, 1, 0, 0,
+  0, 1, 1, 1, 0, 0, 0,
+  1, 1, 0, 1, 0, 1, 0,
+  1, 1, 0, 1, 1, 1, 0,
+  1, 1, 0, 1, 1, 0, 0,
+  0, 1, 1, 1, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 39 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 40 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 41 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 42 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 1, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 43 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 44 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 45 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 46 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 47 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 48 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 1, 1, 1, 0,
+  1, 1, 1, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 49 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 1, 0, 0, 0,
+  1, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 50 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 51 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 52 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 1, 1, 1, 0,
+  0, 0, 1, 1, 1, 1, 0,
+  0, 1, 1, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 53 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 54 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 55 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 56 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 57 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 58 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 59 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 60 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 61 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 62 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 63 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 64 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 1, 0,
+  1, 0, 1, 1, 1, 1, 0,
+  1, 0, 1, 0, 1, 1, 0,
+  1, 0, 1, 1, 1, 1, 0,
+  1, 0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 65 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 66 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 67 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 68 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 69 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 70 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 71 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 1, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 72 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 73 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 74 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 75 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 1, 1, 0, 0,
+  1, 1, 1, 1, 0, 0, 0,
+  1, 1, 1, 0, 0, 0, 0,
+  1, 1, 1, 0, 0, 0, 0,
+  1, 1, 1, 1, 0, 0, 0,
+  1, 1, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 76 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 77 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 78 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 1, 0, 1, 1, 0,
+  1, 1, 1, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 1, 1, 1, 0,
+  1, 1, 0, 1, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 79 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 80 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 81 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 1, 0, 1, 1, 0,
+  1, 1, 0, 1, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 82 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 0, 0,
+  1, 1, 1, 1, 0, 0, 0,
+  1, 1, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 83 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 84 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 85 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 86 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 1, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 87 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 88 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 0, 0, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 89 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 90 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 91 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 92 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 93 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 94 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 95 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 96 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 97 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 98 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 99 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 100 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 101 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 102 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 0, 0,
+  0, 1, 1, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  1, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 103 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+
+/* Char 104 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 105 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 106 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+
+/* Char 107 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 1, 1, 0, 0,
+  1, 1, 1, 1, 0, 0, 0,
+  1, 1, 1, 1, 0, 0, 0,
+  1, 1, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 108 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 109 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 1, 1, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 110 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 111 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 112 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+
+/* Char 113 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+
+/* Char 114 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 115 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 116 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 117 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 118 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 119 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 1, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 120 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 121 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+
+/* Char 122 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 123 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 124 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 125 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 126 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 127 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 128 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 129 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 130 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 131 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 132 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 133 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 134 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 135 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 136 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 137 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 138 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 139 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 140 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 141 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 142 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 143 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 144 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 145 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 146 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 147 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 148 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 149 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 150 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 151 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 152 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 153 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 154 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 155 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 156 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 157 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 158 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 159 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 160 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 161 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0,
+
+/* Char 162 */
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 163 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 1, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 1, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  1, 1, 1, 0, 0, 0, 0,
+  1, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 164 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 1, 0, 0, 1, 0, 0,
+  0, 1, 0, 0, 1, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 165 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 166 */
+  0, 0, 0, 1, 1, 1, 0,
+  0, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 167 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 168 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 1, 1, 0,
+  0, 1, 1, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 169 */
+  0, 1, 1, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 170 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+
+/* Char 171 */
+  0, 1, 1, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 172 */
+  0, 0, 0, 1, 1, 1, 0,
+  0, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 173 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 174 */
+  0, 1, 1, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 175 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 176 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 177 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0,
+
+/* Char 178 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 0,
+
+/* Char 179 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 1, 0,
+  0, 0, 1, 1, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 0,
+  0, 1, 1, 1, 0, 0, 0,
+  1, 1, 1, 1, 0, 0, 0,
+  1, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 180 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 0,
+  0, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 181 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 0,
+  1, 1, 1, 0, 1, 1, 0,
+  0, 1, 1, 0, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 182 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 0,
+  0, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 183 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 184 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 1, 1, 1, 0, 0, 0,
+
+/* Char 185 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 186 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+
+/* Char 187 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 188 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 0,
+  0, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 189 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 190 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 191 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 192 */
+  0, 0, 0, 1, 1, 1, 0,
+  0, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 0, 0,
+  1, 1, 1, 1, 0, 0, 0,
+  1, 1, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 193 */
+  0, 0, 0, 1, 1, 1, 0,
+  0, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 194 */
+  0, 0, 1, 1, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 195 */
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 196 */
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 197 */
+  0, 0, 0, 1, 1, 1, 0,
+  0, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 198 */
+  0, 0, 0, 1, 1, 1, 0,
+  0, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 199 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+
+/* Char 200 */
+  0, 1, 1, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 201 */
+  0, 0, 0, 1, 1, 1, 0,
+  0, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 202 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0,
+
+/* Char 203 */
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 204 */
+  0, 1, 1, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 205 */
+  0, 0, 0, 1, 1, 1, 0,
+  0, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 206 */
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 207 */
+  0, 1, 1, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 208 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0, 0,
+  0, 1, 1, 0, 1, 1, 0,
+  0, 1, 1, 0, 1, 1, 0,
+  1, 1, 1, 0, 1, 1, 0,
+  0, 1, 1, 0, 1, 1, 0,
+  0, 1, 1, 0, 1, 1, 0,
+  0, 1, 1, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 209 */
+  0, 0, 0, 1, 1, 1, 0,
+  0, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 1, 0, 1, 1, 0,
+  1, 1, 1, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 1, 1, 1, 0,
+  1, 1, 0, 1, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 210 */
+  0, 1, 1, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 1, 0, 1, 1, 0,
+  1, 1, 1, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 1, 1, 1, 0,
+  1, 1, 0, 1, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 211 */
+  0, 0, 0, 1, 1, 1, 0,
+  0, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 212 */
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 213 */
+  0, 1, 1, 0, 0, 1, 1,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 214 */
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 215 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 216 */
+  0, 1, 1, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 0, 0,
+  1, 1, 1, 1, 0, 0, 0,
+  1, 1, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 217 */
+  0, 0, 1, 1, 0, 0, 0,
+  0, 1, 0, 0, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 218 */
+  0, 0, 0, 1, 1, 1, 0,
+  0, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 219 */
+  0, 1, 1, 0, 0, 1, 1,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 220 */
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 221 */
+  0, 0, 0, 1, 1, 1, 0,
+  0, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 222 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+
+/* Char 223 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 1, 0, 1, 1, 0,
+  1, 1, 0, 1, 1, 0, 0,
+  1, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 224 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 0,
+  0, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 225 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 0,
+  0, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 226 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 0, 0,
+  0, 1, 1, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 227 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 228 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 229 */
+  0, 0, 0, 1, 1, 1, 0,
+  0, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 230 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 0,
+  0, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 231 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+
+/* Char 232 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 233 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 0,
+  0, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 234 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0, 0,
+
+/* Char 235 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 236 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 237 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 0,
+  0, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 238 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0, 0,
+  1, 1, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 239 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 1, 1,
+  0, 0, 0, 1, 1, 0, 1,
+  0, 0, 0, 1, 1, 1, 0,
+  0, 0, 0, 1, 1, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 1, 1, 0, 0,
+  1, 1, 0, 1, 1, 0, 0,
+  1, 1, 0, 1, 1, 0, 0,
+  1, 1, 0, 1, 1, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 240 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 1, 1, 1, 1,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 241 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 0,
+  0, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 242 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 243 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 0,
+  0, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 244 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 0, 0,
+  0, 1, 1, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 245 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 246 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 247 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 248 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 249 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 1, 0, 0, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 250 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 0,
+  0, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 251 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 1, 1,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 252 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+/* Char 253 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 1, 0,
+  0, 1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  1, 1, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 1, 1, 0,
+  0, 1, 1, 1, 1, 0, 0,
+
+/* Char 254 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 0, 0,
+
+/* Char 255 */
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+
+
+};
+
+gdFont gdFontMediumBoldRep = {
+  256,
+  0,
+  7,
+  13,
+  gdFontMediumBoldData
+};
+
+gdFontPtr gdFontMediumBold = &gdFontMediumBoldRep;
+
+/* This file has not been truncated. */
diff --git a/collects/plot/src/all/gdfontmb.h b/collects/plot/src/all/gdfontmb.h
new file mode 100644
index 0000000000..361d9076e1
--- /dev/null
+++ b/collects/plot/src/all/gdfontmb.h
@@ -0,0 +1,28 @@
+
+#ifndef _GDFONTMB_H_
+#define _GDFONTMB_H_ 1
+
+#ifdef __cplusplus
+extern "C"
+{
+#endif
+
+/*
+	This is a header file for gd font, generated using
+	bdftogd version 0.5 by Jan Pazdziora, adelton@fi.muni.cz
+	from bdf font
+	-misc-fixed-bold-r-normal-sans-13-94-100-100-c-70-iso8859-2
+	at Thu Jan  8 13:54:57 1998.
+	No copyright info was found in the original bdf.
+ */
+
+
+#include "gd.h"
+
+  extern gdFontPtr gdFontMediumBold;
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif
diff --git a/collects/plot/src/all/gdfonts.c b/collects/plot/src/all/gdfonts.c
new file mode 100644
index 0000000000..765d36b21b
--- /dev/null
+++ b/collects/plot/src/all/gdfonts.c
@@ -0,0 +1,3869 @@
+
+
+/*
+   This is a header file for gd font, generated using
+   bdftogd version 0.5 by Jan Pazdziora, adelton@fi.muni.cz
+   from bdf font
+   -misc-fixed-medium-r-semicondensed-sans-12-116-75-75-c-60-iso8859-2
+   at Thu Jan  8 14:13:20 1998.
+   No copyright info was found in the original bdf.
+ */
+
+
+#include "gdfonts.h"
+
+char gdFontSmallData[] = {
+/* Char 0 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 1 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 2 */
+  0, 0, 0, 0, 0, 0,
+  0, 1, 0, 1, 0, 1,
+  1, 0, 1, 0, 1, 0,
+  0, 1, 0, 1, 0, 1,
+  1, 0, 1, 0, 1, 0,
+  0, 1, 0, 1, 0, 1,
+  1, 0, 1, 0, 1, 0,
+  0, 1, 0, 1, 0, 1,
+  1, 0, 1, 0, 1, 0,
+  0, 1, 0, 1, 0, 1,
+  1, 0, 1, 0, 1, 0,
+  0, 1, 0, 1, 0, 1,
+  1, 0, 1, 0, 1, 0,
+
+/* Char 3 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 1, 0, 0, 0,
+  1, 0, 1, 0, 0, 0,
+  1, 1, 1, 0, 0, 0,
+  1, 0, 1, 0, 0, 0,
+  1, 0, 1, 0, 0, 0,
+  0, 0, 1, 1, 1, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 4 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 1, 1, 1, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 5 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 1, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 6 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 1, 1, 0, 0, 0,
+  0, 0, 1, 1, 1, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 7 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0,
+  1, 0, 0, 1, 0, 0,
+  1, 0, 0, 1, 0, 0,
+  0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 8 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 9 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 1, 0, 0, 1, 0,
+  1, 0, 1, 0, 1, 0,
+  1, 0, 0, 1, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 1, 1, 1,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 10 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 11 */
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 12 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+
+/* Char 13 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 1,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+
+/* Char 14 */
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 1, 1, 1,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 15 */
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  1, 1, 1, 1, 1, 1,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+
+/* Char 16 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 17 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 18 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 19 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 20 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 21 */
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 1, 1, 1,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+
+/* Char 22 */
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  1, 1, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+
+/* Char 23 */
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  1, 1, 1, 1, 1, 1,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 24 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 1,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+
+/* Char 25 */
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+
+/* Char 26 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 27 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 28 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  1, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 29 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 1, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  1, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 30 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0,
+  0, 1, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0,
+  1, 1, 1, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 1, 0, 0, 1, 0,
+  1, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 31 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 32 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 33 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 34 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 35 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 1, 0, 1, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 36 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 1, 1, 1, 0,
+  1, 0, 1, 0, 0, 0,
+  1, 0, 1, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 1, 0, 1, 0,
+  0, 0, 1, 0, 1, 0,
+  1, 1, 1, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 37 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 1, 0,
+  1, 0, 1, 0, 1, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  1, 0, 1, 0, 1, 0,
+  1, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 38 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  1, 0, 1, 0, 0, 0,
+  1, 0, 1, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  1, 0, 1, 0, 0, 0,
+  1, 0, 0, 1, 1, 0,
+  1, 0, 0, 1, 0, 0,
+  0, 1, 1, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 39 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 40 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 41 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 42 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  1, 0, 1, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 1, 0, 1, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 43 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 44 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 45 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 46 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 47 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 1, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 48 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 49 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 0,
+  1, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 50 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 1, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 51 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 1, 0,
+  0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 52 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 1, 1, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  1, 0, 0, 1, 0, 0,
+  1, 0, 0, 1, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 53 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 54 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1, 0,
+  0, 1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 55 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 1, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 56 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 57 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 1, 0,
+  0, 0, 0, 1, 0, 0,
+  1, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 58 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 59 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0,
+  0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 60 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 61 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 62 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 1, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 63 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 1, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 64 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 1, 1, 0,
+  1, 0, 1, 0, 1, 0,
+  1, 0, 1, 0, 1, 0,
+  1, 0, 1, 1, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 65 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 1, 1, 1, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 66 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 67 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 68 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 69 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 70 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 71 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 1, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 72 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 1, 1, 1, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 73 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 74 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  1, 0, 0, 1, 0, 0,
+  0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 75 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 1, 0, 0,
+  1, 0, 1, 0, 0, 0,
+  1, 1, 1, 0, 0, 0,
+  1, 0, 0, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 76 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 77 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 1, 0, 1, 1, 0,
+  1, 0, 1, 0, 1, 0,
+  1, 0, 1, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 78 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 1, 0, 0, 1, 0,
+  1, 1, 0, 0, 1, 0,
+  1, 0, 1, 0, 1, 0,
+  1, 0, 1, 0, 1, 0,
+  1, 0, 0, 1, 1, 0,
+  1, 0, 0, 1, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 79 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 80 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 81 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 1, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 82 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 1, 1, 1, 0, 0,
+  1, 0, 1, 0, 0, 0,
+  1, 0, 0, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 83 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 84 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 85 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 86 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 87 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 1, 0, 1, 0,
+  1, 0, 1, 0, 1, 0,
+  1, 0, 1, 0, 1, 0,
+  1, 0, 1, 0, 1, 0,
+  1, 1, 0, 1, 1, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 88 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 89 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 90 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 1, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 91 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 92 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 93 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 94 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 95 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 96 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 97 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 98 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 1, 0, 0, 1, 0,
+  1, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 99 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 100 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 1, 0,
+  0, 1, 1, 0, 1, 0,
+  1, 0, 0, 1, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 101 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 1, 1, 1, 1, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 102 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0,
+  0, 1, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 103 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+
+/* Char 104 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 105 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 106 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  1, 0, 0, 1, 0, 0,
+  1, 0, 0, 1, 0, 0,
+  0, 1, 1, 0, 0, 0,
+
+/* Char 107 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 1, 0, 0,
+  1, 0, 1, 0, 0, 0,
+  1, 1, 0, 0, 0, 0,
+  1, 0, 1, 0, 0, 0,
+  1, 0, 0, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 108 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 109 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 0, 1, 0, 0,
+  1, 0, 1, 0, 1, 0,
+  1, 0, 1, 0, 1, 0,
+  1, 0, 1, 0, 1, 0,
+  1, 0, 1, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 110 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 111 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 112 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 1, 0, 0, 1, 0,
+  1, 0, 1, 1, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+
+/* Char 113 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 1, 0,
+  1, 0, 0, 1, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 1, 0,
+  0, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 1, 0,
+
+/* Char 114 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 115 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 116 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 1, 0, 0, 1, 0,
+  0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 117 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 118 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 119 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 1, 0, 1, 0,
+  1, 0, 1, 0, 1, 0,
+  1, 0, 1, 0, 1, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 120 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 121 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 1, 0,
+  0, 0, 0, 0, 1, 0,
+  0, 0, 0, 1, 0, 0,
+  1, 1, 1, 0, 0, 0,
+
+/* Char 122 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 123 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  1, 1, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 124 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 125 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  1, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 126 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 1, 0,
+  1, 0, 1, 0, 1, 0,
+  1, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 127 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 128 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 129 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 130 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 131 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 132 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 133 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 134 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 135 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 136 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 137 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 138 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 139 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 140 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 141 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 142 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 143 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 144 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 145 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 146 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 147 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 148 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 149 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 150 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 151 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 152 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 153 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 154 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 155 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 156 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 157 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 158 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 159 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 160 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 161 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 1, 1, 1, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 1, 1,
+
+/* Char 162 */
+  0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 163 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  1, 1, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 164 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 165 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0,
+  1, 0, 0, 1, 0, 0,
+  1, 0, 1, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 166 */
+  0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 167 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0,
+  0, 1, 0, 0, 1, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0,
+  0, 1, 0, 0, 1, 0,
+  0, 1, 0, 0, 1, 0,
+  0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 0,
+  0, 1, 0, 0, 1, 0,
+  0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 168 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 0, 1, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 169 */
+  0, 1, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 170 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+
+/* Char 171 */
+  0, 1, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 172 */
+  0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 1, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 173 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 174 */
+  0, 1, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 1, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 175 */
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 1, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 176 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0, 0,
+  0, 1, 0, 0, 1, 0,
+  0, 1, 0, 0, 1, 0,
+  0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 177 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 1, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 1, 1,
+
+/* Char 178 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0,
+
+/* Char 179 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 180 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 181 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 1,
+  0, 1, 1, 0, 0, 1,
+  0, 0, 1, 0, 1, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 182 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 183 */
+  0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 184 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 1, 1, 0, 0, 0,
+
+/* Char 185 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 186 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+
+/* Char 187 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0,
+  0, 0, 0, 0, 1, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 1, 0, 0, 1, 0,
+  0, 0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 188 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 189 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 1,
+  0, 1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 190 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 191 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 192 */
+  0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 1, 1, 1, 0, 0,
+  1, 0, 1, 0, 0, 0,
+  1, 0, 0, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 193 */
+  0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 1, 1, 1, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 194 */
+  0, 0, 1, 0, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 1, 1, 1, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 195 */
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 1, 1, 1, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 196 */
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 1, 1, 1, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 197 */
+  0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 198 */
+  0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 199 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 1, 1, 0, 0, 0,
+
+/* Char 200 */
+  0, 1, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 201 */
+  0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 202 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0,
+
+/* Char 203 */
+  0, 1, 0, 1, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 204 */
+  0, 1, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 205 */
+  0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 206 */
+  0, 0, 1, 0, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 207 */
+  0, 1, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 208 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 1, 0,
+  0, 1, 0, 0, 1, 0,
+  1, 1, 1, 0, 1, 0,
+  0, 1, 0, 0, 1, 0,
+  0, 1, 0, 0, 1, 0,
+  0, 1, 0, 0, 1, 0,
+  1, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 209 */
+  0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 1, 0, 0, 1, 0,
+  1, 1, 0, 0, 1, 0,
+  1, 0, 1, 0, 1, 0,
+  1, 0, 1, 0, 1, 0,
+  1, 0, 0, 1, 1, 0,
+  1, 0, 0, 1, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 210 */
+  0, 1, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 1, 0, 0, 1, 0,
+  1, 1, 0, 0, 1, 0,
+  1, 0, 1, 0, 1, 0,
+  1, 0, 1, 0, 1, 0,
+  1, 0, 0, 1, 1, 0,
+  1, 0, 0, 1, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 211 */
+  0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 212 */
+  0, 0, 1, 0, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 213 */
+  0, 0, 1, 0, 0, 1,
+  0, 1, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 214 */
+  0, 1, 0, 1, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 215 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 216 */
+  0, 1, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 1, 1, 1, 0, 0,
+  1, 0, 1, 0, 0, 0,
+  1, 0, 0, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 217 */
+  0, 0, 1, 0, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 218 */
+  0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 219 */
+  0, 0, 1, 0, 0, 1,
+  0, 1, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 220 */
+  0, 1, 0, 1, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 221 */
+  0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 222 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+
+/* Char 223 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 1, 0, 0, 1, 0,
+  1, 0, 1, 1, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 224 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 225 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 226 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 227 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 228 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 1, 0,
+  0, 1, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 229 */
+  0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 230 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 231 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 1, 1, 0, 0, 0,
+
+/* Char 232 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 233 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 1, 1, 1, 1, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 234 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 1, 1, 1, 1, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 1, 1, 0,
+
+/* Char 235 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 1, 1, 1, 1, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 236 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 1, 1, 1, 1, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 237 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 238 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 239 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 1,
+  0, 0, 0, 0, 0, 1,
+  0, 0, 0, 1, 1, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  1, 0, 1, 1, 0, 0,
+  1, 0, 0, 1, 0, 0,
+  1, 0, 0, 1, 0, 0,
+  1, 0, 0, 1, 0, 0,
+  0, 1, 1, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 240 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 0,
+  0, 0, 0, 1, 1, 1,
+  0, 0, 0, 0, 1, 0,
+  0, 1, 1, 0, 1, 0,
+  1, 0, 0, 1, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 241 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 242 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 243 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 244 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 245 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 246 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 247 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 248 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 1, 1, 0, 0,
+  1, 1, 0, 0, 1, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 249 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 250 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 251 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 252 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 1, 0, 1, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 1, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+/* Char 253 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 0, 1, 0,
+  1, 0, 0, 1, 1, 0,
+  0, 1, 1, 0, 1, 0,
+  0, 0, 0, 0, 1, 0,
+  0, 0, 0, 1, 0, 0,
+  1, 1, 1, 0, 0, 0,
+
+/* Char 254 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  1, 1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 1, 0, 0, 0, 0,
+  0, 1, 0, 0, 1, 0,
+  0, 0, 1, 1, 0, 0,
+  0, 0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0, 0,
+
+/* Char 255 */
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0,
+
+
+};
+
+gdFont gdFontSmallRep = {
+  256,
+  0,
+  6,
+  13,
+  gdFontSmallData
+};
+
+gdFontPtr gdFontSmall = &gdFontSmallRep;
+
+/* This file has not been truncated. */
diff --git a/collects/plot/src/all/gdfonts.h b/collects/plot/src/all/gdfonts.h
new file mode 100644
index 0000000000..c671d73a41
--- /dev/null
+++ b/collects/plot/src/all/gdfonts.h
@@ -0,0 +1,28 @@
+
+#ifndef _GDFONTS_H_
+#define _GDFONTS_H_ 1
+
+#ifdef __cplusplus
+extern "C"
+{
+#endif
+
+/*
+	This is a header file for gd font, generated using
+	bdftogd version 0.5 by Jan Pazdziora, adelton@fi.muni.cz
+	from bdf font
+	-misc-fixed-medium-r-semicondensed-sans-12-116-75-75-c-60-iso8859-2
+	at Thu Jan  8 14:13:20 1998.
+	No copyright info was found in the original bdf.
+ */
+
+
+#include "gd.h"
+
+  extern gdFontPtr gdFontSmall;
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif
diff --git a/collects/plot/src/all/gdfontt.c b/collects/plot/src/all/gdfontt.c
new file mode 100644
index 0000000000..3366b46417
--- /dev/null
+++ b/collects/plot/src/all/gdfontt.c
@@ -0,0 +1,2590 @@
+
+
+/*
+   This is a header file for gd font, generated using
+   bdftogd version 0.5 by Jan Pazdziora, adelton@fi.muni.cz
+   from bdf font
+   -Misc-Fixed-Medium-R-Normal--8-80-75-75-C-50-ISO8859-2
+   at Thu Jan  8 13:49:54 1998.
+   The original bdf was holding following copyright:
+   "Libor Skarvada, libor@informatics.muni.cz"
+ */
+
+
+#include "gdfontt.h"
+
+char gdFontTinyData[] = {
+/* Char 0 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 1 */
+  0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 1, 1, 0,
+  1, 1, 1, 1, 1,
+  0, 1, 1, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 2 */
+  0, 1, 0, 1, 0,
+  1, 0, 1, 0, 0,
+  0, 1, 0, 1, 0,
+  1, 0, 1, 0, 0,
+  0, 1, 0, 1, 0,
+  1, 0, 1, 0, 0,
+  0, 1, 0, 1, 0,
+  1, 0, 1, 0, 0,
+
+/* Char 3 */
+  0, 1, 0, 1, 0,
+  0, 1, 0, 1, 0,
+  0, 1, 1, 1, 0,
+  0, 1, 0, 1, 0,
+  0, 1, 0, 1, 0,
+  0, 0, 1, 1, 1,
+  0, 0, 0, 1, 0,
+  0, 0, 0, 1, 0,
+
+/* Char 4 */
+  1, 1, 1, 0, 0,
+  1, 0, 0, 0, 0,
+  1, 1, 0, 0, 0,
+  1, 0, 1, 1, 1,
+  1, 0, 1, 0, 0,
+  0, 0, 1, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+
+/* Char 5 */
+  0, 1, 1, 0, 0,
+  1, 0, 0, 0, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0,
+  0, 0, 1, 0, 1,
+  0, 0, 1, 1, 0,
+  0, 0, 1, 0, 1,
+
+/* Char 6 */
+  1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0,
+  1, 1, 1, 0, 0,
+  0, 0, 1, 1, 1,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 1, 0,
+  0, 0, 1, 0, 0,
+
+/* Char 7 */
+  0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0,
+  1, 0, 1, 0, 0,
+  0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 8 */
+  0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 1, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 9 */
+  1, 0, 0, 1, 0,
+  1, 1, 0, 1, 0,
+  1, 0, 1, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 1, 1,
+
+/* Char 10 */
+  1, 0, 1, 0, 0,
+  1, 0, 1, 0, 0,
+  1, 0, 1, 0, 0,
+  0, 1, 0, 0, 0,
+  0, 0, 1, 1, 1,
+  0, 0, 0, 1, 0,
+  0, 0, 0, 1, 0,
+  0, 0, 0, 1, 0,
+
+/* Char 11 */
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 12 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  1, 1, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+
+/* Char 13 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 1, 1, 1,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+
+/* Char 14 */
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 1, 1,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 15 */
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  1, 1, 1, 1, 1,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+
+/* Char 16 */
+  0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 17 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 18 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 19 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 20 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 21 */
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 1, 1,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+
+/* Char 22 */
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  1, 1, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+
+/* Char 23 */
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  1, 1, 1, 1, 1,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 24 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+
+/* Char 25 */
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+
+/* Char 26 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 27 */
+  0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0,
+  0, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 28 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1,
+  0, 1, 0, 1, 0,
+  0, 1, 0, 1, 0,
+  0, 1, 0, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 29 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 1, 0,
+  1, 1, 1, 1, 1,
+  0, 0, 1, 0, 0,
+  1, 1, 1, 1, 1,
+  0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 30 */
+  0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0,
+  0, 1, 0, 0, 1,
+  1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0,
+  0, 1, 0, 0, 1,
+  1, 0, 1, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 31 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 32 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 33 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 34 */
+  0, 0, 0, 0, 0,
+  0, 1, 0, 1, 0,
+  0, 1, 0, 1, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 35 */
+  0, 1, 0, 1, 0,
+  0, 1, 0, 1, 0,
+  1, 1, 1, 1, 1,
+  0, 1, 0, 1, 0,
+  1, 1, 1, 1, 1,
+  0, 1, 0, 1, 0,
+  0, 1, 0, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 36 */
+  0, 0, 1, 0, 0,
+  0, 1, 1, 1, 0,
+  1, 0, 1, 0, 0,
+  0, 1, 1, 1, 0,
+  0, 0, 1, 0, 1,
+  0, 1, 1, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 37 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  1, 1, 0, 0, 1,
+  1, 1, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 0, 1, 1,
+  1, 0, 0, 1, 1,
+  0, 0, 0, 0, 0,
+
+/* Char 38 */
+  0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 0, 1, 0,
+  0, 1, 0, 1, 0,
+  0, 0, 1, 0, 1,
+  0, 0, 0, 0, 0,
+
+/* Char 39 */
+  0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 40 */
+  0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0,
+  0, 1, 0, 0, 0,
+  0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 41 */
+  0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 42 */
+  0, 0, 0, 0, 0,
+  1, 0, 0, 1, 0,
+  0, 1, 1, 0, 0,
+  1, 1, 1, 1, 0,
+  0, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 43 */
+  0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  1, 1, 1, 1, 1,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 44 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 45 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 46 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 47 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 1,
+  0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0,
+  1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 48 */
+  0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 0, 1, 0,
+  0, 1, 0, 1, 0,
+  0, 1, 0, 1, 0,
+  0, 1, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 49 */
+  0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 50 */
+  0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0,
+  1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 51 */
+  0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 52 */
+  0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 1, 0, 0,
+  1, 0, 1, 0, 0,
+  1, 1, 1, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 53 */
+  0, 0, 0, 0, 0,
+  1, 1, 1, 1, 0,
+  1, 0, 0, 0, 0,
+  1, 1, 1, 0, 0,
+  0, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 54 */
+  0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0,
+  1, 0, 0, 0, 0,
+  1, 0, 1, 0, 0,
+  1, 1, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 55 */
+  0, 0, 0, 0, 0,
+  1, 1, 1, 1, 0,
+  0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0,
+  0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 56 */
+  0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  0, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 57 */
+  0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 1, 1, 0,
+  0, 1, 0, 1, 0,
+  0, 0, 0, 1, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 58 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 59 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0,
+  0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0,
+
+/* Char 60 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 61 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+  1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 62 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 63 */
+  0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 0, 1, 0,
+  0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 64 */
+  0, 0, 1, 1, 0,
+  0, 1, 0, 0, 1,
+  1, 0, 0, 1, 1,
+  1, 0, 1, 0, 1,
+  1, 0, 1, 0, 1,
+  1, 0, 0, 1, 0,
+  0, 1, 0, 0, 0,
+  0, 0, 1, 1, 0,
+
+/* Char 65 */
+  0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 1, 1, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 66 */
+  0, 0, 0, 0, 0,
+  1, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 67 */
+  0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0,
+  1, 0, 0, 1, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 68 */
+  0, 0, 0, 0, 0,
+  1, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 69 */
+  0, 0, 0, 0, 0,
+  1, 1, 1, 1, 0,
+  1, 0, 0, 0, 0,
+  1, 1, 1, 0, 0,
+  1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0,
+  1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 70 */
+  0, 0, 0, 0, 0,
+  1, 1, 1, 1, 0,
+  1, 0, 0, 0, 0,
+  1, 1, 1, 0, 0,
+  1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 71 */
+  0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 0, 0,
+  1, 0, 1, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 72 */
+  0, 0, 0, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 1, 1, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 73 */
+  0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 74 */
+  0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0,
+  0, 0, 0, 1, 0,
+  0, 0, 0, 1, 0,
+  0, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 75 */
+  0, 0, 0, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 1, 0, 0,
+  1, 1, 0, 0, 0,
+  1, 0, 1, 0, 0,
+  1, 0, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 76 */
+  0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0,
+  1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 77 */
+  0, 0, 0, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 1, 1, 1, 0,
+  1, 1, 1, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 78 */
+  0, 0, 0, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 1, 0, 1, 0,
+  1, 1, 1, 1, 0,
+  1, 0, 1, 1, 0,
+  1, 0, 1, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 79 */
+  0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 80 */
+  0, 0, 0, 0, 0,
+  1, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 1, 1, 0, 0,
+  1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 81 */
+  0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 1, 0, 1, 0,
+  1, 0, 1, 1, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 0, 1, 0,
+
+/* Char 82 */
+  0, 0, 0, 0, 0,
+  1, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 1, 1, 0, 0,
+  1, 0, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 83 */
+  0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0,
+  1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 0, 1, 0,
+  1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 84 */
+  0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 85 */
+  0, 0, 0, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 86 */
+  0, 0, 0, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 1, 1, 0, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 87 */
+  0, 0, 0, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 1, 1, 1, 0,
+  1, 1, 1, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 88 */
+  0, 0, 0, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 1, 1, 0, 0,
+  0, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 89 */
+  0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1,
+  1, 0, 0, 0, 1,
+  0, 1, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 90 */
+  0, 0, 0, 0, 0,
+  1, 1, 1, 1, 0,
+  0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0,
+  1, 0, 0, 0, 0,
+  1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 91 */
+  0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0,
+  0, 1, 0, 0, 0,
+  0, 1, 0, 0, 0,
+  0, 1, 0, 0, 0,
+  0, 1, 0, 0, 0,
+  0, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 92 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0,
+  0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 1, 0,
+  0, 0, 0, 0, 1,
+  0, 0, 0, 0, 0,
+
+/* Char 93 */
+  0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0,
+  0, 0, 0, 1, 0,
+  0, 0, 0, 1, 0,
+  0, 0, 0, 1, 0,
+  0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 94 */
+  0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 0, 1, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 95 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1,
+
+/* Char 96 */
+  0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0,
+  0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 97 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 1, 1, 0,
+  0, 1, 0, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 98 */
+  0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0,
+  1, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 99 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0,
+  1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0,
+  0, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 100 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 1, 0,
+  0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 1, 1, 0,
+  0, 1, 0, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 101 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0,
+  1, 0, 1, 1, 0,
+  1, 1, 0, 0, 0,
+  0, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 102 */
+  0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 0, 1, 0,
+  0, 1, 0, 0, 0,
+  1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0,
+  0, 1, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 103 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 1, 1, 1, 0,
+  0, 0, 0, 1, 0,
+  0, 1, 1, 0, 0,
+
+/* Char 104 */
+  0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0,
+  1, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 105 */
+  0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 106 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 1, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 1, 0,
+  0, 0, 0, 1, 0,
+  0, 0, 0, 1, 0,
+  0, 1, 0, 1, 0,
+  0, 0, 1, 0, 0,
+
+/* Char 107 */
+  0, 0, 0, 0, 0,
+  1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 108 */
+  0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 109 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  1, 1, 0, 1, 0,
+  1, 0, 1, 0, 1,
+  1, 0, 1, 0, 1,
+  1, 0, 0, 0, 1,
+  0, 0, 0, 0, 0,
+
+/* Char 110 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  1, 0, 1, 0, 0,
+  1, 1, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 111 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 112 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  1, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 1, 1, 0, 0,
+  1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0,
+
+/* Char 113 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 1, 1, 1, 0,
+  0, 0, 0, 1, 0,
+  0, 0, 0, 1, 0,
+
+/* Char 114 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  1, 0, 1, 0, 0,
+  1, 1, 0, 1, 0,
+  1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 115 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0,
+  1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0,
+  1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 116 */
+  0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0,
+  0, 1, 0, 0, 0,
+  1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0,
+  0, 1, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 117 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 1, 1, 0,
+  0, 1, 0, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 118 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 1, 0, 1, 0,
+  0, 1, 0, 1, 0,
+  0, 1, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 119 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1,
+  1, 0, 1, 0, 1,
+  1, 0, 1, 0, 1,
+  0, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 120 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  1, 0, 0, 1, 0,
+  0, 1, 1, 0, 0,
+  0, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 121 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 1, 1, 1, 0,
+  0, 0, 0, 1, 0,
+  0, 1, 1, 0, 0,
+
+/* Char 122 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  1, 1, 1, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0,
+  1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 123 */
+  0, 0, 1, 1, 0,
+  0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0,
+  1, 1, 0, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0,
+  0, 0, 1, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 124 */
+  0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 125 */
+  0, 1, 1, 0, 0,
+  0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 1, 1,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 1, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 126 */
+  0, 0, 0, 0, 0,
+  0, 1, 0, 1, 0,
+  1, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 127 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 128 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 129 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 130 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 131 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 132 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 133 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 134 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 135 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 136 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 137 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 138 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 139 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 140 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 141 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 142 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 143 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 144 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 145 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 146 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 147 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 148 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 149 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 150 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 151 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 152 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 153 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 154 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 155 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 156 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 157 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 158 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 159 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 160 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 161 */
+  0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 1, 1, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 1, 1, 0,
+  0, 0, 0, 1, 1,
+
+/* Char 162 */
+  1, 0, 0, 0, 1,
+  0, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 163 */
+  0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0,
+  0, 1, 0, 1, 0,
+  0, 1, 1, 0, 0,
+  0, 1, 0, 0, 0,
+  1, 1, 0, 0, 0,
+  0, 1, 1, 1, 1,
+  0, 0, 0, 0, 0,
+
+/* Char 164 */
+  0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1,
+  0, 1, 1, 1, 0,
+  0, 1, 0, 1, 0,
+  0, 1, 1, 1, 0,
+  1, 0, 0, 0, 1,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 165 */
+  0, 0, 1, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 1, 0, 0,
+  1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0,
+  1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 166 */
+  0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 1, 1, 0,
+  1, 0, 0, 0, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 0, 1, 0,
+  1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 167 */
+  0, 0, 0, 0, 0,
+  0, 0, 1, 1, 0,
+  0, 1, 0, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 1, 0,
+  0, 1, 1, 0, 0,
+
+/* Char 168 */
+  0, 1, 0, 1, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 169 */
+  0, 1, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 1, 1, 0,
+  1, 0, 0, 0, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 0, 1, 0,
+  1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 170 */
+  0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0,
+  1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 0, 1, 0,
+  1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0,
+
+/* Char 171 */
+  0, 1, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  1, 1, 1, 1, 1,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 172 */
+  0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  1, 1, 1, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0,
+  1, 0, 0, 0, 0,
+  1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 173 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 174 */
+  0, 1, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  1, 1, 1, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0,
+  1, 0, 0, 0, 0,
+  1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 175 */
+  0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+  1, 1, 1, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0,
+  1, 0, 0, 0, 0,
+  1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 176 */
+  0, 0, 1, 0, 0,
+  0, 1, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 177 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 1, 1, 0,
+  0, 1, 0, 1, 0,
+  0, 0, 0, 1, 1,
+
+/* Char 178 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 1, 1,
+
+/* Char 179 */
+  0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 1, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 180 */
+  0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 181 */
+  0, 0, 0, 1, 1,
+  1, 1, 0, 0, 1,
+  0, 1, 0, 1, 0,
+  0, 1, 0, 0, 0,
+  0, 1, 0, 0, 0,
+  0, 1, 0, 0, 0,
+  1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 182 */
+  0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0,
+  1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0,
+  1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 183 */
+  0, 1, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 184 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 1, 0,
+  0, 1, 1, 0, 0,
+
+/* Char 185 */
+  0, 1, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0,
+  1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0,
+  1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 186 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0,
+  1, 1, 0, 0, 0,
+  0, 0, 1, 1, 0,
+  1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0,
+
+/* Char 187 */
+  0, 0, 0, 1, 1,
+  0, 1, 0, 0, 1,
+  0, 1, 0, 1, 0,
+  1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0,
+  0, 1, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 188 */
+  0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+  1, 1, 1, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0,
+  1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 189 */
+  0, 1, 0, 0, 1,
+  1, 0, 0, 1, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 190 */
+  0, 1, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+  1, 1, 1, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0,
+  1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 191 */
+  0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+  1, 1, 1, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0,
+  1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 192 */
+  0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0,
+  1, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 1, 1, 0, 0,
+  1, 0, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 193 */
+  0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 1, 1, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 194 */
+  0, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  0, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 1, 1, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 195 */
+  1, 0, 0, 1, 0,
+  0, 1, 1, 0, 0,
+  0, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 1, 1, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 196 */
+  1, 0, 0, 1, 0,
+  0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 1, 1, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 197 */
+  0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0,
+  1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 198 */
+  0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 0, 0,
+  1, 0, 0, 1, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 199 */
+  0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0,
+  1, 0, 0, 1, 0,
+  0, 1, 1, 0, 0,
+  1, 1, 0, 0, 0,
+
+/* Char 200 */
+  0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 0, 0,
+  1, 0, 0, 1, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 201 */
+  0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  1, 1, 1, 1, 0,
+  1, 0, 0, 0, 0,
+  1, 1, 1, 0, 0,
+  1, 0, 0, 0, 0,
+  1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 202 */
+  0, 0, 0, 0, 0,
+  1, 1, 1, 1, 0,
+  1, 0, 0, 0, 0,
+  1, 1, 1, 0, 0,
+  1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0,
+  1, 1, 1, 1, 0,
+  0, 0, 0, 1, 1,
+
+/* Char 203 */
+  1, 0, 0, 1, 0,
+  0, 0, 0, 0, 0,
+  1, 1, 1, 1, 0,
+  1, 0, 0, 0, 0,
+  1, 1, 1, 0, 0,
+  1, 0, 0, 0, 0,
+  1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 204 */
+  0, 1, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  1, 1, 1, 1, 0,
+  1, 0, 0, 0, 0,
+  1, 1, 1, 0, 0,
+  1, 0, 0, 0, 0,
+  1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 205 */
+  0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 1, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 206 */
+  0, 0, 1, 0, 0,
+  0, 1, 0, 1, 0,
+  0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 207 */
+  0, 1, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  1, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 208 */
+  0, 0, 0, 0, 0,
+  1, 1, 1, 0, 0,
+  0, 1, 0, 1, 0,
+  1, 1, 0, 1, 0,
+  0, 1, 0, 1, 0,
+  0, 1, 0, 1, 0,
+  1, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 209 */
+  0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 1, 0, 1, 0,
+  1, 1, 1, 1, 0,
+  1, 0, 1, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 210 */
+  0, 1, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 1, 0, 1, 0,
+  1, 1, 1, 1, 0,
+  1, 0, 1, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 211 */
+  0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 212 */
+  0, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  0, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 213 */
+  0, 1, 0, 0, 1,
+  1, 0, 0, 1, 0,
+  0, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 214 */
+  1, 0, 0, 1, 0,
+  0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 215 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  1, 0, 0, 1, 0,
+  0, 1, 1, 0, 0,
+  0, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 216 */
+  0, 1, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  1, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 1, 1, 0, 0,
+  1, 0, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 217 */
+  0, 1, 1, 0, 0,
+  0, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 218 */
+  0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 219 */
+  0, 1, 0, 0, 1,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 220 */
+  1, 0, 0, 1, 0,
+  0, 0, 0, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 221 */
+  0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  1, 0, 0, 0, 1,
+  0, 1, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 222 */
+  0, 0, 0, 0, 0,
+  1, 1, 1, 1, 1,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 0, 0, 0,
+
+/* Char 223 */
+  0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 1, 0, 1, 0,
+  1, 0, 1, 0, 0,
+  1, 0, 0, 0, 0,
+
+/* Char 224 */
+  0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+  1, 0, 1, 0, 0,
+  1, 1, 0, 1, 0,
+  1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 225 */
+  0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 1, 1, 0,
+  0, 1, 0, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 226 */
+  0, 0, 1, 0, 0,
+  0, 1, 0, 1, 0,
+  0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 1, 1, 0,
+  0, 1, 0, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 227 */
+  1, 0, 0, 1, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 1, 1, 0,
+  0, 1, 0, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 228 */
+  1, 0, 0, 1, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 1, 1, 0,
+  0, 1, 0, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 229 */
+  0, 0, 0, 0, 1,
+  0, 0, 0, 1, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 230 */
+  0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0,
+  1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0,
+  0, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 231 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0,
+  1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0,
+  0, 1, 1, 1, 0,
+  1, 1, 1, 0, 0,
+
+/* Char 232 */
+  0, 1, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 1, 1, 1, 0,
+  1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0,
+  0, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 233 */
+  0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0,
+  1, 0, 1, 1, 0,
+  1, 1, 0, 0, 0,
+  0, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 234 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0,
+  1, 0, 1, 1, 0,
+  1, 1, 0, 0, 0,
+  0, 1, 1, 1, 0,
+  0, 0, 0, 1, 1,
+
+/* Char 235 */
+  0, 0, 0, 0, 0,
+  1, 0, 0, 1, 0,
+  0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0,
+  1, 0, 1, 1, 0,
+  1, 1, 0, 0, 0,
+  0, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 236 */
+  0, 1, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0,
+  1, 0, 1, 1, 0,
+  1, 1, 0, 0, 0,
+  0, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 237 */
+  0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 238 */
+  0, 0, 1, 0, 0,
+  0, 1, 0, 1, 0,
+  0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 239 */
+  0, 0, 0, 1, 1,
+  0, 0, 1, 0, 1,
+  0, 0, 1, 0, 1,
+  0, 1, 1, 0, 0,
+  1, 0, 1, 0, 0,
+  1, 0, 1, 0, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 240 */
+  0, 0, 0, 1, 0,
+  0, 0, 1, 1, 1,
+  0, 0, 0, 1, 0,
+  0, 1, 1, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 1, 1, 0,
+  0, 1, 0, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 241 */
+  0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+  1, 0, 1, 0, 0,
+  1, 1, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 242 */
+  0, 1, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+  1, 0, 1, 0, 0,
+  1, 1, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 243 */
+  0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 244 */
+  0, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 245 */
+  0, 1, 0, 0, 1,
+  1, 0, 0, 1, 0,
+  0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 246 */
+  1, 0, 0, 1, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 247 */
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+  1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 248 */
+  0, 1, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+  1, 0, 1, 0, 0,
+  1, 1, 0, 1, 0,
+  1, 0, 0, 0, 0,
+  1, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 249 */
+  0, 1, 1, 0, 0,
+  0, 1, 1, 0, 0,
+  0, 0, 0, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 1, 1, 0,
+  0, 1, 0, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 250 */
+  0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 1, 1, 0,
+  0, 1, 0, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 251 */
+  0, 1, 0, 0, 1,
+  1, 0, 0, 1, 0,
+  0, 0, 0, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 1, 1, 0,
+  0, 1, 0, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 252 */
+  1, 0, 0, 1, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 1, 1, 0,
+  0, 1, 0, 1, 0,
+  0, 0, 0, 0, 0,
+
+/* Char 253 */
+  0, 0, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+  1, 0, 0, 1, 0,
+  1, 0, 0, 1, 0,
+  0, 1, 1, 1, 0,
+  0, 0, 0, 1, 0,
+  0, 1, 1, 0, 0,
+
+/* Char 254 */
+  0, 0, 0, 0, 0,
+  0, 1, 0, 0, 0,
+  0, 1, 0, 0, 0,
+  1, 1, 1, 0, 0,
+  0, 1, 0, 0, 0,
+  0, 1, 0, 1, 0,
+  0, 0, 1, 0, 0,
+  0, 1, 1, 0, 0,
+
+/* Char 255 */
+  0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0,
+
+
+};
+
+gdFont gdFontTinyRep = {
+  256,
+  0,
+  5,
+  8,
+  gdFontTinyData
+};
+
+gdFontPtr gdFontTiny = &gdFontTinyRep;
+
+/* This file has not been truncated. */
diff --git a/collects/plot/src/all/gdfontt.h b/collects/plot/src/all/gdfontt.h
new file mode 100644
index 0000000000..609dce1c14
--- /dev/null
+++ b/collects/plot/src/all/gdfontt.h
@@ -0,0 +1,29 @@
+
+#ifndef _GDFONTT_H_
+#define _GDFONTT_H_ 1
+
+#ifdef __cplusplus
+extern "C"
+{
+#endif
+
+/*
+	This is a header file for gd font, generated using
+	bdftogd version 0.5 by Jan Pazdziora, adelton@fi.muni.cz
+	from bdf font
+	-Misc-Fixed-Medium-R-Normal--8-80-75-75-C-50-ISO8859-2
+	at Thu Jan  8 13:49:54 1998.
+	The original bdf was holding following copyright:
+	"Libor Skarvada, libor@informatics.muni.cz"
+ */
+
+
+#include "gd.h"
+
+  extern gdFontPtr gdFontTiny;
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif
diff --git a/collects/plot/src/all/gdhelpers.c b/collects/plot/src/all/gdhelpers.c
new file mode 100644
index 0000000000..bd83f5c3c0
--- /dev/null
+++ b/collects/plot/src/all/gdhelpers.c
@@ -0,0 +1,101 @@
+
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+
+#include "gd.h"
+#include "gdhelpers.h"
+#include <stdlib.h>
+#include <string.h>
+
+/* TBB: gd_strtok_r is not portable; provide an implementation */
+
+#define SEP_TEST (separators[*((unsigned char *) s)])
+
+char *
+gd_strtok_r (char *s, char *sep, char **state)
+{
+  char separators[256];
+  char *start;
+  char *result = 0;
+  memset (separators, 0, sizeof (separators));
+  while (*sep)
+    {
+      separators[*((unsigned char *) sep)] = 1;
+      sep++;
+    }
+  if (!s)
+    {
+      /* Pick up where we left off */
+      s = *state;
+    }
+  start = s;
+  /* 1. EOS */
+  if (!(*s))
+    {
+      *state = s;
+      return 0;
+    }
+  /* 2. Leading separators, if any */
+  if (SEP_TEST)
+    {
+      do
+	{
+	  s++;
+	}
+      while (SEP_TEST);
+      /* 2a. EOS after separators only */
+      if (!(*s))
+	{
+	  *state = s;
+	  return 0;
+	}
+    }
+  /* 3. A token */
+  result = s;
+  do
+    {
+      /* 3a. Token at end of string */
+      if (!(*s))
+	{
+	  *state = s;
+	  return result;
+	}
+      s++;
+    }
+  while (!SEP_TEST);
+  /* 4. Terminate token and skip trailing separators */
+  *s = '\0';
+  do
+    {
+      s++;
+    }
+  while (SEP_TEST);
+  /* 5. Return token */
+  *state = s;
+  return result;
+}
+
+void *
+gdCalloc (size_t nmemb, size_t size)
+{
+  return calloc (nmemb, size);
+}
+
+void *
+gdMalloc (size_t size)
+{
+  return malloc (size);
+}
+
+void *
+gdRealloc (void *ptr, size_t size)
+{
+  return realloc (ptr, size);
+}
+
+void
+gdFree (void *ptr)
+{
+  free (ptr);
+}
diff --git a/collects/plot/src/all/gdhelpers.h b/collects/plot/src/all/gdhelpers.h
new file mode 100644
index 0000000000..3f2e9dcfdb
--- /dev/null
+++ b/collects/plot/src/all/gdhelpers.h
@@ -0,0 +1,19 @@
+#ifndef GDHELPERS_H
+#define GDHELPERS_H 1
+
+/* sys/types.h is needed for size_t on Sparc-SunOS-4.1 */
+#include <sys/types.h>
+
+/* TBB: strtok_r is not universal; provide an implementation of it. */
+
+extern char *gd_strtok_r (char *s, char *sep, char **state);
+
+/* These functions wrap memory management. gdFree is
+	in gd.h, where callers can utilize it to correctly
+	free memory allocated by these functions with the
+	right version of free(). */
+void *gdCalloc (size_t nmemb, size_t size);
+void *gdMalloc (size_t size);
+void *gdRealloc (void *ptr, size_t size);
+
+#endif /* GDHELPERS_H */
diff --git a/collects/plot/src/all/gdkanji.c b/collects/plot/src/all/gdkanji.c
new file mode 100644
index 0000000000..a6d090025d
--- /dev/null
+++ b/collects/plot/src/all/gdkanji.c
@@ -0,0 +1,660 @@
+
+/* gdkanji.c (Kanji code converter)                            */
+/*                 written by Masahito Yamaga (ma@yama-ga.com) */
+
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include "gd.h"
+#include "gdhelpers.h"
+
+#ifdef HAVE_ERRNO_H
+#include <errno.h>
+#endif
+
+#include <stdarg.h>
+#if defined(HAVE_ICONV_H)
+#include <iconv.h>
+#endif
+
+#ifndef HAVE_ICONV_T_DEF
+typedef void *iconv_t;
+#endif
+
+#ifndef HAVE_ICONV
+#define ICONV_CONST /**/
+  iconv_t iconv_open (const char *, const char *);
+size_t iconv (iconv_t, ICONV_CONST char **, size_t *, char **, size_t *);
+int iconv_close (iconv_t);
+
+iconv_t
+iconv_open (const char *tocode, const char *fromcode)
+{
+  return (iconv_t) (-1);
+}
+
+size_t
+iconv (iconv_t cd, ICONV_CONST char **inbuf, size_t * inbytesleft,
+       char **outbuf, size_t * outbytesleft)
+{
+  return 0;
+}
+
+int
+iconv_close (iconv_t cd)
+{
+  return 0;
+}
+
+#endif /* !HAVE_ICONV */
+
+#define LIBNAME "any2eucjp()"
+
+#if defined(__MSC__) || defined(__BORLANDC__) || defined(__TURBOC__) || defined(_Windows) || defined(MSDOS)
+#ifndef SJISPRE
+#define SJISPRE 1
+#endif
+#endif
+
+#ifdef TRUE
+#undef TRUE
+#endif
+#ifdef FALSE
+#undef FALSE
+#endif
+
+#define TRUE  1
+#define FALSE 0
+
+#define NEW 1
+#define OLD 2
+#define ESCI 3
+#define NEC 4
+#define EUC 5
+#define SJIS 6
+#define EUCORSJIS 7
+#define ASCII 8
+
+#define NEWJISSTR "JIS7"
+#define OLDJISSTR "jis"
+#define EUCSTR    "eucJP"
+#define SJISSTR   "SJIS"
+
+#define ESC 27
+#define SS2 142
+
+static void
+debug (const char *format, ...)
+{
+#ifdef DEBUG
+  va_list args;
+
+  va_start (args, format);
+  fprintf (stdout, "%s: ", LIBNAME);
+  vfprintf (stdout, format, args);
+  fprintf (stdout, "\n");
+  va_end (args);
+#endif
+}
+
+static void
+error (const char *format, ...)
+{
+  va_list args;
+
+  va_start (args, format);
+  fprintf (stderr, "%s: ", LIBNAME);
+  vfprintf (stderr, format, args);
+  fprintf (stderr, "\n");
+  va_end (args);
+}
+
+/* DetectKanjiCode() derived from DetectCodeType() by Ken Lunde. */
+
+static int
+DetectKanjiCode (unsigned char *str)
+{
+  static int whatcode = ASCII;
+  int oldcode = ASCII;
+  int c, i;
+  char *lang = NULL;
+
+  c = '\1';
+  i = 0;
+
+  if (whatcode != EUCORSJIS && whatcode != ASCII)
+    {
+      oldcode = whatcode;
+      whatcode = ASCII;
+    }
+
+  while ((whatcode == EUCORSJIS || whatcode == ASCII) && c != '\0')
+    {
+      if ((c = str[i++]) != '\0')
+	{
+	  if (c == ESC)
+	    {
+	      c = str[i++];
+	      if (c == '$')
+		{
+		  c = str[i++];
+		  if (c == 'B')
+		    whatcode = NEW;
+		  else if (c == '@')
+		    whatcode = OLD;
+		}
+	      else if (c == '(')
+		{
+		  c = str[i++];
+		  if (c == 'I')
+		    whatcode = ESCI;
+		}
+	      else if (c == 'K')
+		whatcode = NEC;
+	    }
+	  else if ((c >= 129 && c <= 141) || (c >= 143 && c <= 159))
+	    whatcode = SJIS;
+	  else if (c == SS2)
+	    {
+	      c = str[i++];
+	      if ((c >= 64 && c <= 126) || (c >= 128 && c <= 160)
+		  || (c >= 224 && c <= 252))
+		whatcode = SJIS;
+	      else if (c >= 161 && c <= 223)
+		whatcode = EUCORSJIS;
+	    }
+	  else if (c >= 161 && c <= 223)
+	    {
+	      c = str[i++];
+	      if (c >= 240 && c <= 254)
+		whatcode = EUC;
+	      else if (c >= 161 && c <= 223)
+		whatcode = EUCORSJIS;
+	      else if (c >= 224 && c <= 239)
+		{
+		  whatcode = EUCORSJIS;
+		  while (c >= 64 && c != '\0' && whatcode == EUCORSJIS)
+		    {
+		      if (c >= 129)
+			{
+			  if (c <= 141 || (c >= 143 && c <= 159))
+			    whatcode = SJIS;
+			  else if (c >= 253 && c <= 254)
+			    whatcode = EUC;
+			}
+		      c = str[i++];
+		    }
+		}
+	      else if (c <= 159)
+		whatcode = SJIS;
+	    }
+	  else if (c >= 240 && c <= 254)
+	    whatcode = EUC;
+	  else if (c >= 224 && c <= 239)
+	    {
+	      c = str[i++];
+	      if ((c >= 64 && c <= 126) || (c >= 128 && c <= 160))
+		whatcode = SJIS;
+	      else if (c >= 253 && c <= 254)
+		whatcode = EUC;
+	      else if (c >= 161 && c <= 252)
+		whatcode = EUCORSJIS;
+	    }
+	}
+    }
+
+#ifdef DEBUG
+  if (whatcode == ASCII)
+    debug ("Kanji code not included.");
+  else if (whatcode == EUCORSJIS)
+    debug ("Kanji code not detected.");
+  else
+    debug ("Kanji code detected at %d byte.", i);
+#endif
+
+  if (whatcode == EUCORSJIS && oldcode != ASCII)
+    whatcode = oldcode;
+
+  if (whatcode == EUCORSJIS)
+    {
+      if (getenv ("LC_ALL"))
+	lang = getenv ("LC_ALL");
+      else if (getenv ("LC_CTYPE"))
+	lang = getenv ("LC_CTYPE");
+      else if (getenv ("LANG"))
+	lang = getenv ("LANG");
+
+      if (lang)
+	{
+	  if (strcmp (lang, "ja_JP.SJIS") == 0 ||
+#ifdef hpux
+	      strcmp (lang, "japanese") == 0 ||
+#endif
+	      strcmp (lang, "ja_JP.mscode") == 0 ||
+	      strcmp (lang, "ja_JP.PCK") == 0)
+	    whatcode = SJIS;
+	  else if (strncmp (lang, "ja", 2) == 0)
+#ifdef SJISPRE
+	    whatcode = SJIS;
+#else
+	    whatcode = EUC;
+#endif
+	}
+    }
+
+  if (whatcode == EUCORSJIS)
+#ifdef SJISPRE
+    whatcode = SJIS;
+#else
+    whatcode = EUC;
+#endif
+
+  return whatcode;
+}
+
+/* SJIStoJIS() is sjis2jis() by Ken Lunde. */
+
+static void
+SJIStoJIS (int *p1, int *p2)
+{
+  register unsigned char c1 = *p1;
+  register unsigned char c2 = *p2;
+  register int adjust = c2 < 159;
+  register int rowOffset = c1 < 160 ? 112 : 176;
+  register int cellOffset = adjust ? (31 + (c2 > 127)) : 126;
+
+  *p1 = ((c1 - rowOffset) << 1) - adjust;
+  *p2 -= cellOffset;
+}
+
+/* han2zen() was derived from han2zen() written by Ken Lunde. */
+
+#define IS_DAKU(c) ((c >= 182 && c <= 196) || (c >= 202 && c <= 206) || (c == 179))
+#define IS_HANDAKU(c) (c >= 202 && c <= 206)
+
+static void
+han2zen (int *p1, int *p2)
+{
+  int c = *p1;
+  int daku = FALSE;
+  int handaku = FALSE;
+  int mtable[][2] = {
+    {129, 66},
+    {129, 117},
+    {129, 118},
+    {129, 65},
+    {129, 69},
+    {131, 146},
+    {131, 64},
+    {131, 66},
+    {131, 68},
+    {131, 70},
+    {131, 72},
+    {131, 131},
+    {131, 133},
+    {131, 135},
+    {131, 98},
+    {129, 91},
+    {131, 65},
+    {131, 67},
+    {131, 69},
+    {131, 71},
+    {131, 73},
+    {131, 74},
+    {131, 76},
+    {131, 78},
+    {131, 80},
+    {131, 82},
+    {131, 84},
+    {131, 86},
+    {131, 88},
+    {131, 90},
+    {131, 92},
+    {131, 94},
+    {131, 96},
+    {131, 99},
+    {131, 101},
+    {131, 103},
+    {131, 105},
+    {131, 106},
+    {131, 107},
+    {131, 108},
+    {131, 109},
+    {131, 110},
+    {131, 113},
+    {131, 116},
+    {131, 119},
+    {131, 122},
+    {131, 125},
+    {131, 126},
+    {131, 128},
+    {131, 129},
+    {131, 130},
+    {131, 132},
+    {131, 134},
+    {131, 136},
+    {131, 137},
+    {131, 138},
+    {131, 139},
+    {131, 140},
+    {131, 141},
+    {131, 143},
+    {131, 147},
+    {129, 74},
+    {129, 75}
+  };
+
+  if (*p2 == 222 && IS_DAKU (*p1))
+    daku = TRUE;		/* Daku-ten */
+  else if (*p2 == 223 && IS_HANDAKU (*p1))
+    handaku = TRUE;		/* Han-daku-ten */
+
+  *p1 = mtable[c - 161][0];
+  *p2 = mtable[c - 161][1];
+
+  if (daku)
+    {
+      if ((*p2 >= 74 && *p2 <= 103) || (*p2 >= 110 && *p2 <= 122))
+	(*p2)++;
+      else if (*p2 == 131 && *p2 == 69)
+	*p2 = 148;
+    }
+  else if (handaku && *p2 >= 110 && *p2 <= 122)
+    (*p2) += 2;
+}
+
+/* Recast strcpy to handle unsigned chars used below. */
+#define ustrcpy(A,B) (strcpy((char*)(A),(const char*)(B)))
+
+static void
+do_convert (unsigned char *to, unsigned char *from, const char *code)
+{
+#ifdef HAVE_ICONV
+  iconv_t cd;
+  size_t from_len, to_len;
+
+  if ((cd = iconv_open (EUCSTR, code)) == (iconv_t) - 1)
+    {
+      error ("iconv_open() error");
+#ifdef HAVE_ERRNO_H
+      if (errno == EINVAL)
+	error ("invalid code specification: \"%s\" or \"%s\"", EUCSTR, code);
+#endif
+      strcpy ((char *) to, (const char *) from);
+      return;
+    }
+
+  from_len = strlen ((const char *) from) + 1;
+  to_len = BUFSIZ;
+
+  if ((int) (iconv (cd, (char **) &from, &from_len, (char **) &to, &to_len))
+      == -1)
+    {
+#ifdef HAVE_ERRNO_H
+      if (errno == EINVAL)
+	error ("invalid end of input string");
+      else if (errno == EILSEQ)
+	error ("invalid code in input string");
+      else if (errno == E2BIG)
+	error ("output buffer overflow at do_convert()");
+      else
+#endif
+	error ("something happen");
+      strcpy ((char *) to, (const char *) from);
+      return;
+    }
+
+  if (iconv_close (cd) != 0)
+    {
+      error ("iconv_close() error");
+    }
+#else
+  int p1, p2, i, j;
+  int jisx0208 = FALSE;
+  int hankaku = FALSE;
+
+  j = 0;
+  if (strcmp (code, NEWJISSTR) == 0 || strcmp (code, OLDJISSTR) == 0)
+    {
+      for (i = 0; from[i] != '\0' && j < BUFSIZ; i++)
+	{
+	  if (from[i] == ESC)
+	    {
+	      i++;
+	      if (from[i] == '$')
+		{
+		  jisx0208 = TRUE;
+		  hankaku = FALSE;
+		  i++;
+		}
+	      else if (from[i] == '(')
+		{
+		  jisx0208 = FALSE;
+		  i++;
+		  if (from[i] == 'I')	/* Hankaku Kana */
+		    hankaku = TRUE;
+		  else
+		    hankaku = FALSE;
+		}
+	    }
+	  else
+	    {
+	      if (jisx0208)
+		to[j++] = from[i] + 128;
+	      else if (hankaku)
+		{
+		  to[j++] = SS2;
+		  to[j++] = from[i] + 128;
+		}
+	      else
+		to[j++] = from[i];
+	    }
+	}
+    }
+  else if (strcmp (code, SJISSTR) == 0)
+    {
+      for (i = 0; from[i] != '\0' && j < BUFSIZ; i++)
+	{
+	  p1 = from[i];
+	  if (p1 < 127)
+	    to[j++] = p1;
+	  else if ((p1 >= 161) && (p1 <= 223))
+	    {			/* Hankaku Kana */
+	      to[j++] = SS2;
+	      to[j++] = p1;
+	    }
+	  else
+	    {
+	      p2 = from[++i];
+	      SJIStoJIS (&p1, &p2);
+	      to[j++] = p1 + 128;
+	      to[j++] = p2 + 128;
+	    }
+	}
+    }
+  else
+    {
+      error ("invalid code specification: \"%s\"", code);
+      return;
+    }
+
+  if (j >= BUFSIZ)
+    {
+      error ("output buffer overflow at do_convert()");
+      ustrcpy (to, from);
+    }
+  else
+    to[j] = '\0';
+#endif /* HAVE_ICONV */
+}
+
+static int
+do_check_and_conv (unsigned char *to, unsigned char *from)
+{
+  static unsigned char tmp[BUFSIZ];
+  int p1, p2, i, j;
+  int kanji = TRUE;
+
+  switch (DetectKanjiCode (from))
+    {
+    case NEW:
+      debug ("Kanji code is New JIS.");
+      do_convert (tmp, from, NEWJISSTR);
+      break;
+    case OLD:
+      debug ("Kanji code is Old JIS.");
+      do_convert (tmp, from, OLDJISSTR);
+      break;
+    case ESCI:
+      debug
+	("This string includes Hankaku-Kana (jisx0201) escape sequence [ESC] + ( + I.");
+      do_convert (tmp, from, NEWJISSTR);
+      break;
+    case NEC:
+      debug ("Kanji code is NEC Kanji.");
+      error ("cannot convert NEC Kanji.");
+      ustrcpy (tmp, from);
+      kanji = FALSE;
+      break;
+    case EUC:
+      debug ("Kanji code is EUC.");
+      ustrcpy (tmp, from);
+      break;
+    case SJIS:
+      debug ("Kanji code is SJIS.");
+      do_convert (tmp, from, SJISSTR);
+      break;
+    case EUCORSJIS:
+      debug ("Kanji code is EUC or SJIS.");
+      ustrcpy (tmp, from);
+      kanji = FALSE;
+      break;
+    case ASCII:
+      debug ("This is ASCII string.");
+      ustrcpy (tmp, from);
+      kanji = FALSE;
+      break;
+    default:
+      debug ("This string includes unknown code.");
+      ustrcpy (tmp, from);
+      kanji = FALSE;
+      break;
+    }
+
+  /* Hankaku Kana ---> Zenkaku Kana */
+  if (kanji)
+    {
+      j = 0;
+      for (i = 0; tmp[i] != '\0' && j < BUFSIZ; i++)
+	{
+	  if (tmp[i] == SS2)
+	    {
+	      p1 = tmp[++i];
+	      if (tmp[i + 1] == SS2)
+		{
+		  p2 = tmp[i + 2];
+		  if (p2 == 222 || p2 == 223)
+		    i += 2;
+		  else
+		    p2 = 0;
+		}
+	      else
+		p2 = 0;
+	      han2zen (&p1, &p2);
+	      SJIStoJIS (&p1, &p2);
+	      to[j++] = p1 + 128;
+	      to[j++] = p2 + 128;
+	    }
+	  else
+	    to[j++] = tmp[i];
+	}
+
+      if (j >= BUFSIZ)
+	{
+	  error ("output buffer overflow at Hankaku --> Zenkaku");
+	  ustrcpy (to, tmp);
+	}
+      else
+	to[j] = '\0';
+    }
+  else
+    ustrcpy (to, tmp);
+
+  return kanji;
+}
+
+int
+any2eucjp (unsigned char *dest, unsigned char *src, unsigned int dest_max)
+{
+  static unsigned char tmp_dest[BUFSIZ];
+  int ret;
+
+  if (strlen ((const char *) src) >= BUFSIZ)
+    {
+      error ("input string too large");
+      return -1;
+    }
+  if (dest_max > BUFSIZ)
+    {
+      error
+	("invalid maximum size of destination\nit should be less than %d.",
+	 BUFSIZ);
+      return -1;
+    }
+  ret = do_check_and_conv (tmp_dest, src);
+  if (strlen ((const char *) tmp_dest) >= dest_max)
+    {
+      error ("output buffer overflow");
+      ustrcpy (dest, src);
+      return -1;
+    }
+  ustrcpy (dest, tmp_dest);
+  return ret;
+}
+
+#if 0
+unsigned int
+strwidth (unsigned char *s)
+{
+  unsigned char *t;
+  unsigned int i;
+
+  t = (unsigned char *) gdMalloc (BUFSIZ);
+  any2eucjp (t, s, BUFSIZ);
+  i = strlen (t);
+  gdFree (t);
+  return i;
+}
+
+#ifdef DEBUG
+int
+main ()
+{
+  unsigned char input[BUFSIZ];
+  unsigned char *output;
+  unsigned char *str;
+  int c, i = 0;
+
+  while ((c = fgetc (stdin)) != '\n' && i < BUFSIZ)
+    input[i++] = c;
+  input[i] = '\0';
+
+  printf ("input : %d bytes\n", strlen ((const char *) input));
+  printf ("output: %d bytes\n", strwidth (input));
+
+  output = (unsigned char *) gdMalloc (BUFSIZ);
+  any2eucjp (output, input, BUFSIZ);
+  str = output;
+  while (*str != '\0')
+    putchar (*(str++));
+  putchar ('\n');
+  gdFree (output);
+
+  return 0;
+}
+#endif
+#endif
diff --git a/collects/plot/src/all/gdtables.c b/collects/plot/src/all/gdtables.c
new file mode 100644
index 0000000000..71d618e372
--- /dev/null
+++ b/collects/plot/src/all/gdtables.c
@@ -0,0 +1,726 @@
+
+int gdCosT[] = {
+  1024,
+  1023,
+  1023,
+  1022,
+  1021,
+  1020,
+  1018,
+  1016,
+  1014,
+  1011,
+  1008,
+  1005,
+  1001,
+  997,
+  993,
+  989,
+  984,
+  979,
+  973,
+  968,
+  962,
+  955,
+  949,
+  942,
+  935,
+  928,
+  920,
+  912,
+  904,
+  895,
+  886,
+  877,
+  868,
+  858,
+  848,
+  838,
+  828,
+  817,
+  806,
+  795,
+  784,
+  772,
+  760,
+  748,
+  736,
+  724,
+  711,
+  698,
+  685,
+  671,
+  658,
+  644,
+  630,
+  616,
+  601,
+  587,
+  572,
+  557,
+  542,
+  527,
+  512,
+  496,
+  480,
+  464,
+  448,
+  432,
+  416,
+  400,
+  383,
+  366,
+  350,
+  333,
+  316,
+  299,
+  282,
+  265,
+  247,
+  230,
+  212,
+  195,
+  177,
+  160,
+  142,
+  124,
+  107,
+  89,
+  71,
+  53,
+  35,
+  17,
+  0,
+  -17,
+  -35,
+  -53,
+  -71,
+  -89,
+  -107,
+  -124,
+  -142,
+  -160,
+  -177,
+  -195,
+  -212,
+  -230,
+  -247,
+  -265,
+  -282,
+  -299,
+  -316,
+  -333,
+  -350,
+  -366,
+  -383,
+  -400,
+  -416,
+  -432,
+  -448,
+  -464,
+  -480,
+  -496,
+  -512,
+  -527,
+  -542,
+  -557,
+  -572,
+  -587,
+  -601,
+  -616,
+  -630,
+  -644,
+  -658,
+  -671,
+  -685,
+  -698,
+  -711,
+  -724,
+  -736,
+  -748,
+  -760,
+  -772,
+  -784,
+  -795,
+  -806,
+  -817,
+  -828,
+  -838,
+  -848,
+  -858,
+  -868,
+  -877,
+  -886,
+  -895,
+  -904,
+  -912,
+  -920,
+  -928,
+  -935,
+  -942,
+  -949,
+  -955,
+  -962,
+  -968,
+  -973,
+  -979,
+  -984,
+  -989,
+  -993,
+  -997,
+  -1001,
+  -1005,
+  -1008,
+  -1011,
+  -1014,
+  -1016,
+  -1018,
+  -1020,
+  -1021,
+  -1022,
+  -1023,
+  -1023,
+  -1024,
+  -1023,
+  -1023,
+  -1022,
+  -1021,
+  -1020,
+  -1018,
+  -1016,
+  -1014,
+  -1011,
+  -1008,
+  -1005,
+  -1001,
+  -997,
+  -993,
+  -989,
+  -984,
+  -979,
+  -973,
+  -968,
+  -962,
+  -955,
+  -949,
+  -942,
+  -935,
+  -928,
+  -920,
+  -912,
+  -904,
+  -895,
+  -886,
+  -877,
+  -868,
+  -858,
+  -848,
+  -838,
+  -828,
+  -817,
+  -806,
+  -795,
+  -784,
+  -772,
+  -760,
+  -748,
+  -736,
+  -724,
+  -711,
+  -698,
+  -685,
+  -671,
+  -658,
+  -644,
+  -630,
+  -616,
+  -601,
+  -587,
+  -572,
+  -557,
+  -542,
+  -527,
+  -512,
+  -496,
+  -480,
+  -464,
+  -448,
+  -432,
+  -416,
+  -400,
+  -383,
+  -366,
+  -350,
+  -333,
+  -316,
+  -299,
+  -282,
+  -265,
+  -247,
+  -230,
+  -212,
+  -195,
+  -177,
+  -160,
+  -142,
+  -124,
+  -107,
+  -89,
+  -71,
+  -53,
+  -35,
+  -17,
+  0,
+  17,
+  35,
+  53,
+  71,
+  89,
+  107,
+  124,
+  142,
+  160,
+  177,
+  195,
+  212,
+  230,
+  247,
+  265,
+  282,
+  299,
+  316,
+  333,
+  350,
+  366,
+  383,
+  400,
+  416,
+  432,
+  448,
+  464,
+  480,
+  496,
+  512,
+  527,
+  542,
+  557,
+  572,
+  587,
+  601,
+  616,
+  630,
+  644,
+  658,
+  671,
+  685,
+  698,
+  711,
+  724,
+  736,
+  748,
+  760,
+  772,
+  784,
+  795,
+  806,
+  817,
+  828,
+  838,
+  848,
+  858,
+  868,
+  877,
+  886,
+  895,
+  904,
+  912,
+  920,
+  928,
+  935,
+  942,
+  949,
+  955,
+  962,
+  968,
+  973,
+  979,
+  984,
+  989,
+  993,
+  997,
+  1001,
+  1005,
+  1008,
+  1011,
+  1014,
+  1016,
+  1018,
+  1020,
+  1021,
+  1022,
+  1023,
+  1023
+};
+
+int gdSinT[] = {
+  0,
+  17,
+  35,
+  53,
+  71,
+  89,
+  107,
+  124,
+  142,
+  160,
+  177,
+  195,
+  212,
+  230,
+  247,
+  265,
+  282,
+  299,
+  316,
+  333,
+  350,
+  366,
+  383,
+  400,
+  416,
+  432,
+  448,
+  464,
+  480,
+  496,
+  512,
+  527,
+  542,
+  557,
+  572,
+  587,
+  601,
+  616,
+  630,
+  644,
+  658,
+  671,
+  685,
+  698,
+  711,
+  724,
+  736,
+  748,
+  760,
+  772,
+  784,
+  795,
+  806,
+  817,
+  828,
+  838,
+  848,
+  858,
+  868,
+  877,
+  886,
+  895,
+  904,
+  912,
+  920,
+  928,
+  935,
+  942,
+  949,
+  955,
+  962,
+  968,
+  973,
+  979,
+  984,
+  989,
+  993,
+  997,
+  1001,
+  1005,
+  1008,
+  1011,
+  1014,
+  1016,
+  1018,
+  1020,
+  1021,
+  1022,
+  1023,
+  1023,
+  1024,
+  1023,
+  1023,
+  1022,
+  1021,
+  1020,
+  1018,
+  1016,
+  1014,
+  1011,
+  1008,
+  1005,
+  1001,
+  997,
+  993,
+  989,
+  984,
+  979,
+  973,
+  968,
+  962,
+  955,
+  949,
+  942,
+  935,
+  928,
+  920,
+  912,
+  904,
+  895,
+  886,
+  877,
+  868,
+  858,
+  848,
+  838,
+  828,
+  817,
+  806,
+  795,
+  784,
+  772,
+  760,
+  748,
+  736,
+  724,
+  711,
+  698,
+  685,
+  671,
+  658,
+  644,
+  630,
+  616,
+  601,
+  587,
+  572,
+  557,
+  542,
+  527,
+  512,
+  496,
+  480,
+  464,
+  448,
+  432,
+  416,
+  400,
+  383,
+  366,
+  350,
+  333,
+  316,
+  299,
+  282,
+  265,
+  247,
+  230,
+  212,
+  195,
+  177,
+  160,
+  142,
+  124,
+  107,
+  89,
+  71,
+  53,
+  35,
+  17,
+  0,
+  -17,
+  -35,
+  -53,
+  -71,
+  -89,
+  -107,
+  -124,
+  -142,
+  -160,
+  -177,
+  -195,
+  -212,
+  -230,
+  -247,
+  -265,
+  -282,
+  -299,
+  -316,
+  -333,
+  -350,
+  -366,
+  -383,
+  -400,
+  -416,
+  -432,
+  -448,
+  -464,
+  -480,
+  -496,
+  -512,
+  -527,
+  -542,
+  -557,
+  -572,
+  -587,
+  -601,
+  -616,
+  -630,
+  -644,
+  -658,
+  -671,
+  -685,
+  -698,
+  -711,
+  -724,
+  -736,
+  -748,
+  -760,
+  -772,
+  -784,
+  -795,
+  -806,
+  -817,
+  -828,
+  -838,
+  -848,
+  -858,
+  -868,
+  -877,
+  -886,
+  -895,
+  -904,
+  -912,
+  -920,
+  -928,
+  -935,
+  -942,
+  -949,
+  -955,
+  -962,
+  -968,
+  -973,
+  -979,
+  -984,
+  -989,
+  -993,
+  -997,
+  -1001,
+  -1005,
+  -1008,
+  -1011,
+  -1014,
+  -1016,
+  -1018,
+  -1020,
+  -1021,
+  -1022,
+  -1023,
+  -1023,
+  -1024,
+  -1023,
+  -1023,
+  -1022,
+  -1021,
+  -1020,
+  -1018,
+  -1016,
+  -1014,
+  -1011,
+  -1008,
+  -1005,
+  -1001,
+  -997,
+  -993,
+  -989,
+  -984,
+  -979,
+  -973,
+  -968,
+  -962,
+  -955,
+  -949,
+  -942,
+  -935,
+  -928,
+  -920,
+  -912,
+  -904,
+  -895,
+  -886,
+  -877,
+  -868,
+  -858,
+  -848,
+  -838,
+  -828,
+  -817,
+  -806,
+  -795,
+  -784,
+  -772,
+  -760,
+  -748,
+  -736,
+  -724,
+  -711,
+  -698,
+  -685,
+  -671,
+  -658,
+  -644,
+  -630,
+  -616,
+  -601,
+  -587,
+  -572,
+  -557,
+  -542,
+  -527,
+  -512,
+  -496,
+  -480,
+  -464,
+  -448,
+  -432,
+  -416,
+  -400,
+  -383,
+  -366,
+  -350,
+  -333,
+  -316,
+  -299,
+  -282,
+  -265,
+  -247,
+  -230,
+  -212,
+  -195,
+  -177,
+  -160,
+  -142,
+  -124,
+  -107,
+  -89,
+  -71,
+  -53,
+  -35,
+  -17
+};
diff --git a/collects/plot/src/all/gdxpm.c b/collects/plot/src/all/gdxpm.c
new file mode 100644
index 0000000000..42406b80c6
--- /dev/null
+++ b/collects/plot/src/all/gdxpm.c
@@ -0,0 +1,154 @@
+
+/* 
+   add ability to load xpm files to gd, requires the xpm
+   library.
+   Caolan.McNamara@ul.ie 
+   http://www.csn.ul.ie/~caolan
+ */
+
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include "gd.h"
+#include "gdhelpers.h"
+
+#ifndef HAVE_LIBXPM
+gdImagePtr
+gdImageCreateFromXpm (char *filename)
+{
+  fprintf (stderr, "libgd was not built with xpm support\n");
+  return (NULL);
+}
+
+#else
+
+#include <X11/xpm.h>
+
+gdImagePtr
+gdImageCreateFromXpm (char *filename)
+{
+  XpmInfo info;
+  XpmImage image;
+  int i, j, k, number;
+  char buf[5];
+  gdImagePtr im = 0;
+  char *apixel;
+  int *pointer;
+  int red = 0, green = 0, blue = 0;
+  int *colors;
+  int ret;
+
+  ret = XpmReadFileToXpmImage (filename, &image, &info);
+  if (ret != XpmSuccess)
+    return 0;
+
+  if (!(im = gdImageCreate (image.width, image.height)))
+    return 0;
+
+  number = image.ncolors;
+  colors = (int *) gdMalloc (sizeof (int) * number);
+  if (colors == NULL)
+    return (0);
+  for (i = 0; i < number; i++)
+    {
+      switch (strlen (image.colorTable[i].c_color))
+	{
+	case 4:
+	  buf[1] = '\0';
+	  buf[0] = image.colorTable[i].c_color[1];
+	  red = strtol (buf, NULL, 16);
+
+	  buf[0] = image.colorTable[i].c_color[3];
+	  green = strtol (buf, NULL, 16);
+
+	  buf[0] = image.colorTable[i].c_color[5];
+	  blue = strtol (buf, NULL, 16);
+	  break;
+	case 7:
+	  buf[2] = '\0';
+	  buf[0] = image.colorTable[i].c_color[1];
+	  buf[1] = image.colorTable[i].c_color[2];
+	  red = strtol (buf, NULL, 16);
+
+	  buf[0] = image.colorTable[i].c_color[3];
+	  buf[1] = image.colorTable[i].c_color[4];
+	  green = strtol (buf, NULL, 16);
+
+	  buf[0] = image.colorTable[i].c_color[5];
+	  buf[1] = image.colorTable[i].c_color[6];
+	  blue = strtol (buf, NULL, 16);
+	  break;
+	case 10:
+	  buf[3] = '\0';
+	  buf[0] = image.colorTable[i].c_color[1];
+	  buf[1] = image.colorTable[i].c_color[2];
+	  buf[2] = image.colorTable[i].c_color[3];
+	  red = strtol (buf, NULL, 16);
+	  red /= 64;
+
+	  buf[0] = image.colorTable[i].c_color[4];
+	  buf[1] = image.colorTable[i].c_color[5];
+	  buf[2] = image.colorTable[i].c_color[6];
+	  green = strtol (buf, NULL, 16);
+	  green /= 64;
+
+	  buf[0] = image.colorTable[i].c_color[7];
+	  buf[1] = image.colorTable[i].c_color[8];
+	  buf[2] = image.colorTable[i].c_color[9];
+	  blue = strtol (buf, NULL, 16);
+	  blue /= 64;
+	  break;
+	case 13:
+	  buf[4] = '\0';
+	  buf[0] = image.colorTable[i].c_color[1];
+	  buf[1] = image.colorTable[i].c_color[2];
+	  buf[2] = image.colorTable[i].c_color[3];
+	  buf[3] = image.colorTable[i].c_color[4];
+	  red = strtol (buf, NULL, 16);
+	  red /= 256;
+
+	  buf[0] = image.colorTable[i].c_color[5];
+	  buf[1] = image.colorTable[i].c_color[6];
+	  buf[2] = image.colorTable[i].c_color[7];
+	  buf[3] = image.colorTable[i].c_color[8];
+	  green = strtol (buf, NULL, 16);
+	  green /= 256;
+
+	  buf[0] = image.colorTable[i].c_color[9];
+	  buf[1] = image.colorTable[i].c_color[10];
+	  buf[2] = image.colorTable[i].c_color[11];
+	  buf[3] = image.colorTable[i].c_color[12];
+	  blue = strtol (buf, NULL, 16);
+	  blue /= 256;
+	  break;
+	}
+
+
+      colors[i] = gdImageColorResolve (im, red, green, blue);
+      if (colors[i] == -1)
+	fprintf (stderr, "ARRRGH\n");
+    }
+
+  apixel = (char *) gdMalloc (image.cpp + 1);
+  if (apixel == NULL)
+    return (0);
+  apixel[image.cpp] = '\0';
+
+  pointer = (int *) image.data;
+  for (i = 0; i < image.height; i++)
+    {
+      for (j = 0; j < image.width; j++)
+	{
+	  k = *pointer++;
+	  gdImageSetPixel (im, j, i, colors[k]);
+	}
+    }
+  gdFree (apixel);
+  gdFree (colors);
+  return (im);
+}
+#endif /* HAVE_LIBXPM */
diff --git a/collects/plot/src/all/gzio.c b/collects/plot/src/all/gzio.c
new file mode 100644
index 0000000000..e02b59793c
--- /dev/null
+++ b/collects/plot/src/all/gzio.c
@@ -0,0 +1,875 @@
+/* gzio.c -- IO on .gz files
+ * Copyright (C) 1995-2002 Jean-loup Gailly.
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ *
+ * Compile this file with -DNO_DEFLATE to avoid the compression code.
+ */
+
+/* @(#) $Id: gzio.c,v 1.1 2004/03/01 20:54:49 cozmic Exp $ */
+
+#include <stdio.h>
+
+#include "zutil.h"
+
+struct internal_state {int dummy;}; /* for buggy compilers */
+
+#ifndef Z_BUFSIZE
+#  ifdef MAXSEG_64K
+#    define Z_BUFSIZE 4096 /* minimize memory usage for 16-bit DOS */
+#  else
+#    define Z_BUFSIZE 16384
+#  endif
+#endif
+#ifndef Z_PRINTF_BUFSIZE
+#  define Z_PRINTF_BUFSIZE 4096
+#endif
+
+#define ALLOC(size) malloc(size)
+#define TRYFREE(p) {if (p) free(p);}
+
+static int gz_magic[2] = {0x1f, 0x8b}; /* gzip magic header */
+
+/* gzip flag byte */
+#define ASCII_FLAG   0x01 /* bit 0 set: file probably ascii text */
+#define HEAD_CRC     0x02 /* bit 1 set: header CRC present */
+#define EXTRA_FIELD  0x04 /* bit 2 set: extra field present */
+#define ORIG_NAME    0x08 /* bit 3 set: original file name present */
+#define COMMENT      0x10 /* bit 4 set: file comment present */
+#define RESERVED     0xE0 /* bits 5..7: reserved */
+
+typedef struct gz_stream {
+    z_stream stream;
+    int      z_err;   /* error code for last stream operation */
+    int      z_eof;   /* set if end of input file */
+    FILE     *file;   /* .gz file */
+    Byte     *inbuf;  /* input buffer */
+    Byte     *outbuf; /* output buffer */
+    uLong    crc;     /* crc32 of uncompressed data */
+    char     *msg;    /* error message */
+    char     *path;   /* path name for debugging only */
+    int      transparent; /* 1 if input file is not a .gz file */
+    char     mode;    /* 'w' or 'r' */
+    long     startpos; /* start of compressed data in file (header skipped) */
+} gz_stream;
+
+
+local gzFile gz_open      OF((const char *path, const char *mode, int  fd));
+local int do_flush        OF((gzFile file, int flush));
+local int    get_byte     OF((gz_stream *s));
+local void   check_header OF((gz_stream *s));
+local int    destroy      OF((gz_stream *s));
+local void   putLong      OF((FILE *file, uLong x));
+local uLong  getLong      OF((gz_stream *s));
+
+/* ===========================================================================
+     Opens a gzip (.gz) file for reading or writing. The mode parameter
+   is as in fopen ("rb" or "wb"). The file is given either by file descriptor
+   or path name (if fd == -1).
+     gz_open return NULL if the file could not be opened or if there was
+   insufficient memory to allocate the (de)compression state; errno
+   can be checked to distinguish the two cases (if errno is zero, the
+   zlib error is Z_MEM_ERROR).
+*/
+local gzFile gz_open (path, mode, fd)
+    const char *path;
+    const char *mode;
+    int  fd;
+{
+    int err;
+    int level = Z_DEFAULT_COMPRESSION; /* compression level */
+    int strategy = Z_DEFAULT_STRATEGY; /* compression strategy */
+    char *p = (char*)mode;
+    gz_stream *s;
+    char fmode[80]; /* copy of mode, without the compression level */
+    char *m = fmode;
+
+    if (!path || !mode) return Z_NULL;
+
+    s = (gz_stream *)ALLOC(sizeof(gz_stream));
+    if (!s) return Z_NULL;
+
+    s->stream.zalloc = (alloc_func)0;
+    s->stream.zfree = (free_func)0;
+    s->stream.opaque = (voidpf)0;
+    s->stream.next_in = s->inbuf = Z_NULL;
+    s->stream.next_out = s->outbuf = Z_NULL;
+    s->stream.avail_in = s->stream.avail_out = 0;
+    s->file = NULL;
+    s->z_err = Z_OK;
+    s->z_eof = 0;
+    s->crc = crc32(0L, Z_NULL, 0);
+    s->msg = NULL;
+    s->transparent = 0;
+
+    s->path = (char*)ALLOC(strlen(path)+1);
+    if (s->path == NULL) {
+        return destroy(s), (gzFile)Z_NULL;
+    }
+    strcpy(s->path, path); /* do this early for debugging */
+
+    s->mode = '\0';
+    do {
+        if (*p == 'r') s->mode = 'r';
+        if (*p == 'w' || *p == 'a') s->mode = 'w';
+        if (*p >= '0' && *p <= '9') {
+	    level = *p - '0';
+	} else if (*p == 'f') {
+	  strategy = Z_FILTERED;
+	} else if (*p == 'h') {
+	  strategy = Z_HUFFMAN_ONLY;
+	} else {
+	    *m++ = *p; /* copy the mode */
+	}
+    } while (*p++ && m != fmode + sizeof(fmode));
+    if (s->mode == '\0') return destroy(s), (gzFile)Z_NULL;
+    
+    if (s->mode == 'w') {
+#ifdef NO_DEFLATE
+        err = Z_STREAM_ERROR;
+#else
+        err = deflateInit2(&(s->stream), level,
+                           Z_DEFLATED, -MAX_WBITS, DEF_MEM_LEVEL, strategy);
+        /* windowBits is passed < 0 to suppress zlib header */
+
+        s->stream.next_out = s->outbuf = (Byte*)ALLOC(Z_BUFSIZE);
+#endif
+        if (err != Z_OK || s->outbuf == Z_NULL) {
+            return destroy(s), (gzFile)Z_NULL;
+        }
+    } else {
+        s->stream.next_in  = s->inbuf = (Byte*)ALLOC(Z_BUFSIZE);
+
+        err = inflateInit2(&(s->stream), -MAX_WBITS);
+        /* windowBits is passed < 0 to tell that there is no zlib header.
+         * Note that in this case inflate *requires* an extra "dummy" byte
+         * after the compressed stream in order to complete decompression and
+         * return Z_STREAM_END. Here the gzip CRC32 ensures that 4 bytes are
+         * present after the compressed stream.
+         */
+        if (err != Z_OK || s->inbuf == Z_NULL) {
+            return destroy(s), (gzFile)Z_NULL;
+        }
+    }
+    s->stream.avail_out = Z_BUFSIZE;
+
+    errno = 0;
+    s->file = fd < 0 ? F_OPEN(path, fmode) : (FILE*)fdopen(fd, fmode);
+
+    if (s->file == NULL) {
+        return destroy(s), (gzFile)Z_NULL;
+    }
+    if (s->mode == 'w') {
+        /* Write a very simple .gz header:
+         */
+        fprintf(s->file, "%c%c%c%c%c%c%c%c%c%c", gz_magic[0], gz_magic[1],
+             Z_DEFLATED, 0 /*flags*/, 0,0,0,0 /*time*/, 0 /*xflags*/, OS_CODE);
+	s->startpos = 10L;
+	/* We use 10L instead of ftell(s->file) to because ftell causes an
+         * fflush on some systems. This version of the library doesn't use
+         * startpos anyway in write mode, so this initialization is not
+         * necessary.
+         */
+    } else {
+	check_header(s); /* skip the .gz header */
+	s->startpos = (ftell(s->file) - s->stream.avail_in);
+    }
+    
+    return (gzFile)s;
+}
+
+/* ===========================================================================
+     Opens a gzip (.gz) file for reading or writing.
+*/
+gzFile ZEXPORT gzopen (path, mode)
+    const char *path;
+    const char *mode;
+{
+    return gz_open (path, mode, -1);
+}
+
+/* ===========================================================================
+     Associate a gzFile with the file descriptor fd. fd is not dup'ed here
+   to mimic the behavio(u)r of fdopen.
+*/
+gzFile ZEXPORT gzdopen (fd, mode)
+    int fd;
+    const char *mode;
+{
+    char name[20];
+
+    if (fd < 0) return (gzFile)Z_NULL;
+    sprintf(name, "<fd:%d>", fd); /* for debugging */
+
+    return gz_open (name, mode, fd);
+}
+
+/* ===========================================================================
+ * Update the compression level and strategy
+ */
+int ZEXPORT gzsetparams (file, level, strategy)
+    gzFile file;
+    int level;
+    int strategy;
+{
+    gz_stream *s = (gz_stream*)file;
+
+    if (s == NULL || s->mode != 'w') return Z_STREAM_ERROR;
+
+    /* Make room to allow flushing */
+    if (s->stream.avail_out == 0) {
+
+	s->stream.next_out = s->outbuf;
+	if (fwrite(s->outbuf, 1, Z_BUFSIZE, s->file) != Z_BUFSIZE) {
+	    s->z_err = Z_ERRNO;
+	}
+	s->stream.avail_out = Z_BUFSIZE;
+    }
+
+    return deflateParams (&(s->stream), level, strategy);
+}
+
+/* ===========================================================================
+     Read a byte from a gz_stream; update next_in and avail_in. Return EOF
+   for end of file.
+   IN assertion: the stream s has been sucessfully opened for reading.
+*/
+local int get_byte(s)
+    gz_stream *s;
+{
+    if (s->z_eof) return EOF;
+    if (s->stream.avail_in == 0) {
+	errno = 0;
+	s->stream.avail_in = fread(s->inbuf, 1, Z_BUFSIZE, s->file);
+	if (s->stream.avail_in == 0) {
+	    s->z_eof = 1;
+	    if (ferror(s->file)) s->z_err = Z_ERRNO;
+	    return EOF;
+	}
+	s->stream.next_in = s->inbuf;
+    }
+    s->stream.avail_in--;
+    return *(s->stream.next_in)++;
+}
+
+/* ===========================================================================
+      Check the gzip header of a gz_stream opened for reading. Set the stream
+    mode to transparent if the gzip magic header is not present; set s->err
+    to Z_DATA_ERROR if the magic header is present but the rest of the header
+    is incorrect.
+    IN assertion: the stream s has already been created sucessfully;
+       s->stream.avail_in is zero for the first time, but may be non-zero
+       for concatenated .gz files.
+*/
+local void check_header(s)
+    gz_stream *s;
+{
+    int method; /* method byte */
+    int flags;  /* flags byte */
+    uInt len;
+    int c;
+
+    /* Check the gzip magic header */
+    for (len = 0; len < 2; len++) {
+	c = get_byte(s);
+	if (c != gz_magic[len]) {
+	    if (len != 0) s->stream.avail_in++, s->stream.next_in--;
+	    if (c != EOF) {
+		s->stream.avail_in++, s->stream.next_in--;
+		s->transparent = 1;
+	    }
+	    s->z_err = s->stream.avail_in != 0 ? Z_OK : Z_STREAM_END;
+	    return;
+	}
+    }
+    method = get_byte(s);
+    flags = get_byte(s);
+    if (method != Z_DEFLATED || (flags & RESERVED) != 0) {
+	s->z_err = Z_DATA_ERROR;
+	return;
+    }
+
+    /* Discard time, xflags and OS code: */
+    for (len = 0; len < 6; len++) (void)get_byte(s);
+
+    if ((flags & EXTRA_FIELD) != 0) { /* skip the extra field */
+	len  =  (uInt)get_byte(s);
+	len += ((uInt)get_byte(s))<<8;
+	/* len is garbage if EOF but the loop below will quit anyway */
+	while (len-- != 0 && get_byte(s) != EOF) ;
+    }
+    if ((flags & ORIG_NAME) != 0) { /* skip the original file name */
+	while ((c = get_byte(s)) != 0 && c != EOF) ;
+    }
+    if ((flags & COMMENT) != 0) {   /* skip the .gz file comment */
+	while ((c = get_byte(s)) != 0 && c != EOF) ;
+    }
+    if ((flags & HEAD_CRC) != 0) {  /* skip the header crc */
+	for (len = 0; len < 2; len++) (void)get_byte(s);
+    }
+    s->z_err = s->z_eof ? Z_DATA_ERROR : Z_OK;
+}
+
+ /* ===========================================================================
+ * Cleanup then free the given gz_stream. Return a zlib error code.
+   Try freeing in the reverse order of allocations.
+ */
+local int destroy (s)
+    gz_stream *s;
+{
+    int err = Z_OK;
+
+    if (!s) return Z_STREAM_ERROR;
+
+    TRYFREE(s->msg);
+
+    if (s->stream.state != NULL) {
+	if (s->mode == 'w') {
+#ifdef NO_DEFLATE
+	    err = Z_STREAM_ERROR;
+#else
+	    err = deflateEnd(&(s->stream));
+#endif
+	} else if (s->mode == 'r') {
+	    err = inflateEnd(&(s->stream));
+	}
+    }
+    if (s->file != NULL && fclose(s->file)) {
+#ifdef ESPIPE
+	if (errno != ESPIPE) /* fclose is broken for pipes in HP/UX */
+#endif
+	    err = Z_ERRNO;
+    }
+    if (s->z_err < 0) err = s->z_err;
+
+    TRYFREE(s->inbuf);
+    TRYFREE(s->outbuf);
+    TRYFREE(s->path);
+    TRYFREE(s);
+    return err;
+}
+
+/* ===========================================================================
+     Reads the given number of uncompressed bytes from the compressed file.
+   gzread returns the number of bytes actually read (0 for end of file).
+*/
+int ZEXPORT gzread (file, buf, len)
+    gzFile file;
+    voidp buf;
+    unsigned len;
+{
+    gz_stream *s = (gz_stream*)file;
+    Bytef *start = (Bytef*)buf; /* starting point for crc computation */
+    Byte  *next_out; /* == stream.next_out but not forced far (for MSDOS) */
+
+    if (s == NULL || s->mode != 'r') return Z_STREAM_ERROR;
+
+    if (s->z_err == Z_DATA_ERROR || s->z_err == Z_ERRNO) return -1;
+    if (s->z_err == Z_STREAM_END) return 0;  /* EOF */
+
+    next_out = (Byte*)buf;
+    s->stream.next_out = (Bytef*)buf;
+    s->stream.avail_out = len;
+
+    while (s->stream.avail_out != 0) {
+
+	if (s->transparent) {
+	    /* Copy first the lookahead bytes: */
+	    uInt n = s->stream.avail_in;
+	    if (n > s->stream.avail_out) n = s->stream.avail_out;
+	    if (n > 0) {
+		zmemcpy(s->stream.next_out, s->stream.next_in, n);
+		next_out += n;
+		s->stream.next_out = next_out;
+		s->stream.next_in   += n;
+		s->stream.avail_out -= n;
+		s->stream.avail_in  -= n;
+	    }
+	    if (s->stream.avail_out > 0) {
+		s->stream.avail_out -= fread(next_out, 1, s->stream.avail_out,
+					     s->file);
+	    }
+	    len -= s->stream.avail_out;
+	    s->stream.total_in  += (uLong)len;
+	    s->stream.total_out += (uLong)len;
+            if (len == 0) s->z_eof = 1;
+	    return (int)len;
+	}
+        if (s->stream.avail_in == 0 && !s->z_eof) {
+
+            errno = 0;
+            s->stream.avail_in = fread(s->inbuf, 1, Z_BUFSIZE, s->file);
+            if (s->stream.avail_in == 0) {
+                s->z_eof = 1;
+		if (ferror(s->file)) {
+		    s->z_err = Z_ERRNO;
+		    break;
+		}
+            }
+            s->stream.next_in = s->inbuf;
+        }
+        s->z_err = inflate(&(s->stream), Z_NO_FLUSH);
+
+	if (s->z_err == Z_STREAM_END) {
+	    /* Check CRC and original size */
+	    s->crc = crc32(s->crc, start, (uInt)(s->stream.next_out - start));
+	    start = s->stream.next_out;
+
+	    if (getLong(s) != s->crc) {
+		s->z_err = Z_DATA_ERROR;
+	    } else {
+	        (void)getLong(s);
+                /* The uncompressed length returned by above getlong() may
+                 * be different from s->stream.total_out) in case of
+		 * concatenated .gz files. Check for such files:
+		 */
+		check_header(s);
+		if (s->z_err == Z_OK) {
+		    uLong total_in = s->stream.total_in;
+		    uLong total_out = s->stream.total_out;
+
+		    inflateReset(&(s->stream));
+		    s->stream.total_in = total_in;
+		    s->stream.total_out = total_out;
+		    s->crc = crc32(0L, Z_NULL, 0);
+		}
+	    }
+	}
+	if (s->z_err != Z_OK || s->z_eof) break;
+    }
+    s->crc = crc32(s->crc, start, (uInt)(s->stream.next_out - start));
+
+    return (int)(len - s->stream.avail_out);
+}
+
+
+/* ===========================================================================
+      Reads one byte from the compressed file. gzgetc returns this byte
+   or -1 in case of end of file or error.
+*/
+int ZEXPORT gzgetc(file)
+    gzFile file;
+{
+    unsigned char c;
+
+    return gzread(file, &c, 1) == 1 ? c : -1;
+}
+
+
+/* ===========================================================================
+      Reads bytes from the compressed file until len-1 characters are
+   read, or a newline character is read and transferred to buf, or an
+   end-of-file condition is encountered.  The string is then terminated
+   with a null character.
+      gzgets returns buf, or Z_NULL in case of error.
+
+      The current implementation is not optimized at all.
+*/
+char * ZEXPORT gzgets(file, buf, len)
+    gzFile file;
+    char *buf;
+    int len;
+{
+    char *b = buf;
+    if (buf == Z_NULL || len <= 0) return Z_NULL;
+
+    while (--len > 0 && gzread(file, buf, 1) == 1 && *buf++ != '\n') ;
+    *buf = '\0';
+    return b == buf && len > 0 ? Z_NULL : b;
+}
+
+
+#ifndef NO_DEFLATE
+/* ===========================================================================
+     Writes the given number of uncompressed bytes into the compressed file.
+   gzwrite returns the number of bytes actually written (0 in case of error).
+*/
+int ZEXPORT gzwrite (file, buf, len)
+    gzFile file;
+    const voidp buf;
+    unsigned len;
+{
+    gz_stream *s = (gz_stream*)file;
+
+    if (s == NULL || s->mode != 'w') return Z_STREAM_ERROR;
+
+    s->stream.next_in = (Bytef*)buf;
+    s->stream.avail_in = len;
+
+    while (s->stream.avail_in != 0) {
+
+        if (s->stream.avail_out == 0) {
+
+            s->stream.next_out = s->outbuf;
+            if (fwrite(s->outbuf, 1, Z_BUFSIZE, s->file) != Z_BUFSIZE) {
+                s->z_err = Z_ERRNO;
+                break;
+            }
+            s->stream.avail_out = Z_BUFSIZE;
+        }
+        s->z_err = deflate(&(s->stream), Z_NO_FLUSH);
+        if (s->z_err != Z_OK) break;
+    }
+    s->crc = crc32(s->crc, (const Bytef *)buf, len);
+
+    return (int)(len - s->stream.avail_in);
+}
+
+/* ===========================================================================
+     Converts, formats, and writes the args to the compressed file under
+   control of the format string, as in fprintf. gzprintf returns the number of
+   uncompressed bytes actually written (0 in case of error).
+*/
+#ifdef STDC
+#include <stdarg.h>
+
+int ZEXPORTVA gzprintf (gzFile file, const char *format, /* args */ ...)
+{
+    char buf[Z_PRINTF_BUFSIZE];
+    va_list va;
+    int len;
+
+    va_start(va, format);
+#ifdef HAS_vsnprintf
+    (void)vsnprintf(buf, sizeof(buf), format, va);
+#else
+    (void)vsprintf(buf, format, va);
+#endif
+    va_end(va);
+    len = strlen(buf); /* some *sprintf don't return the nb of bytes written */
+    if (len <= 0) return 0;
+
+    return gzwrite(file, buf, (unsigned)len);
+}
+#else /* not ANSI C */
+
+int ZEXPORTVA gzprintf (file, format, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10,
+	               a11, a12, a13, a14, a15, a16, a17, a18, a19, a20)
+    gzFile file;
+    const char *format;
+    int a1, a2, a3, a4, a5, a6, a7, a8, a9, a10,
+	a11, a12, a13, a14, a15, a16, a17, a18, a19, a20;
+{
+    char buf[Z_PRINTF_BUFSIZE];
+    int len;
+
+#ifdef HAS_snprintf
+    snprintf(buf, sizeof(buf), format, a1, a2, a3, a4, a5, a6, a7, a8,
+	     a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20);
+#else
+    sprintf(buf, format, a1, a2, a3, a4, a5, a6, a7, a8,
+	    a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20);
+#endif
+    len = strlen(buf); /* old sprintf doesn't return the nb of bytes written */
+    if (len <= 0) return 0;
+
+    return gzwrite(file, buf, len);
+}
+#endif
+
+/* ===========================================================================
+      Writes c, converted to an unsigned char, into the compressed file.
+   gzputc returns the value that was written, or -1 in case of error.
+*/
+int ZEXPORT gzputc(file, c)
+    gzFile file;
+    int c;
+{
+    unsigned char cc = (unsigned char) c; /* required for big endian systems */
+
+    return gzwrite(file, &cc, 1) == 1 ? (int)cc : -1;
+}
+
+
+/* ===========================================================================
+      Writes the given null-terminated string to the compressed file, excluding
+   the terminating null character.
+      gzputs returns the number of characters written, or -1 in case of error.
+*/
+int ZEXPORT gzputs(file, s)
+    gzFile file;
+    const char *s;
+{
+    return gzwrite(file, (char*)s, (unsigned)strlen(s));
+}
+
+
+/* ===========================================================================
+     Flushes all pending output into the compressed file. The parameter
+   flush is as in the deflate() function.
+*/
+local int do_flush (file, flush)
+    gzFile file;
+    int flush;
+{
+    uInt len;
+    int done = 0;
+    gz_stream *s = (gz_stream*)file;
+
+    if (s == NULL || s->mode != 'w') return Z_STREAM_ERROR;
+
+    s->stream.avail_in = 0; /* should be zero already anyway */
+
+    for (;;) {
+        len = Z_BUFSIZE - s->stream.avail_out;
+
+        if (len != 0) {
+            if ((uInt)fwrite(s->outbuf, 1, len, s->file) != len) {
+                s->z_err = Z_ERRNO;
+                return Z_ERRNO;
+            }
+            s->stream.next_out = s->outbuf;
+            s->stream.avail_out = Z_BUFSIZE;
+        }
+        if (done) break;
+        s->z_err = deflate(&(s->stream), flush);
+
+	/* Ignore the second of two consecutive flushes: */
+	if (len == 0 && s->z_err == Z_BUF_ERROR) s->z_err = Z_OK;
+
+        /* deflate has finished flushing only when it hasn't used up
+         * all the available space in the output buffer: 
+         */
+        done = (s->stream.avail_out != 0 || s->z_err == Z_STREAM_END);
+ 
+        if (s->z_err != Z_OK && s->z_err != Z_STREAM_END) break;
+    }
+    return  s->z_err == Z_STREAM_END ? Z_OK : s->z_err;
+}
+
+int ZEXPORT gzflush (file, flush)
+     gzFile file;
+     int flush;
+{
+    gz_stream *s = (gz_stream*)file;
+    int err = do_flush (file, flush);
+
+    if (err) return err;
+    fflush(s->file);
+    return  s->z_err == Z_STREAM_END ? Z_OK : s->z_err;
+}
+#endif /* NO_DEFLATE */
+
+/* ===========================================================================
+      Sets the starting position for the next gzread or gzwrite on the given
+   compressed file. The offset represents a number of bytes in the
+      gzseek returns the resulting offset location as measured in bytes from
+   the beginning of the uncompressed stream, or -1 in case of error.
+      SEEK_END is not implemented, returns error.
+      In this version of the library, gzseek can be extremely slow.
+*/
+z_off_t ZEXPORT gzseek (file, offset, whence)
+    gzFile file;
+    z_off_t offset;
+    int whence;
+{
+    gz_stream *s = (gz_stream*)file;
+
+    if (s == NULL || whence == SEEK_END ||
+	s->z_err == Z_ERRNO || s->z_err == Z_DATA_ERROR) {
+	return -1L;
+    }
+    
+    if (s->mode == 'w') {
+#ifdef NO_DEFLATE
+	return -1L;
+#else
+	if (whence == SEEK_SET) {
+	    offset -= s->stream.total_in;
+	}
+	if (offset < 0) return -1L;
+
+	/* At this point, offset is the number of zero bytes to write. */
+	if (s->inbuf == Z_NULL) {
+	    s->inbuf = (Byte*)ALLOC(Z_BUFSIZE); /* for seeking */
+	    zmemzero(s->inbuf, Z_BUFSIZE);
+	}
+	while (offset > 0)  {
+	    uInt size = Z_BUFSIZE;
+	    if (offset < Z_BUFSIZE) size = (uInt)offset;
+
+	    size = gzwrite(file, s->inbuf, size);
+	    if (size == 0) return -1L;
+
+	    offset -= size;
+	}
+	return (z_off_t)s->stream.total_in;
+#endif
+    }
+    /* Rest of function is for reading only */
+
+    /* compute absolute position */
+    if (whence == SEEK_CUR) {
+	offset += s->stream.total_out;
+    }
+    if (offset < 0) return -1L;
+
+    if (s->transparent) {
+	/* map to fseek */
+	s->stream.avail_in = 0;
+	s->stream.next_in = s->inbuf;
+        if (fseek(s->file, offset, SEEK_SET) < 0) return -1L;
+
+	s->stream.total_in = s->stream.total_out = (uLong)offset;
+	return offset;
+    }
+
+    /* For a negative seek, rewind and use positive seek */
+    if ((uLong)offset >= s->stream.total_out) {
+	offset -= s->stream.total_out;
+    } else if (gzrewind(file) < 0) {
+	return -1L;
+    }
+    /* offset is now the number of bytes to skip. */
+
+    if (offset != 0 && s->outbuf == Z_NULL) {
+	s->outbuf = (Byte*)ALLOC(Z_BUFSIZE);
+    }
+    while (offset > 0)  {
+	int size = Z_BUFSIZE;
+	if (offset < Z_BUFSIZE) size = (int)offset;
+
+	size = gzread(file, s->outbuf, (uInt)size);
+	if (size <= 0) return -1L;
+	offset -= size;
+    }
+    return (z_off_t)s->stream.total_out;
+}
+
+/* ===========================================================================
+     Rewinds input file. 
+*/
+int ZEXPORT gzrewind (file)
+    gzFile file;
+{
+    gz_stream *s = (gz_stream*)file;
+    
+    if (s == NULL || s->mode != 'r') return -1;
+
+    s->z_err = Z_OK;
+    s->z_eof = 0;
+    s->stream.avail_in = 0;
+    s->stream.next_in = s->inbuf;
+    s->crc = crc32(0L, Z_NULL, 0);
+	
+    if (s->startpos == 0) { /* not a compressed file */
+	rewind(s->file);
+	return 0;
+    }
+
+    (void) inflateReset(&s->stream);
+    return fseek(s->file, s->startpos, SEEK_SET);
+}
+
+/* ===========================================================================
+     Returns the starting position for the next gzread or gzwrite on the
+   given compressed file. This position represents a number of bytes in the
+   uncompressed data stream.
+*/
+z_off_t ZEXPORT gztell (file)
+    gzFile file;
+{
+    return gzseek(file, 0L, SEEK_CUR);
+}
+
+/* ===========================================================================
+     Returns 1 when EOF has previously been detected reading the given
+   input stream, otherwise zero.
+*/
+int ZEXPORT gzeof (file)
+    gzFile file;
+{
+    gz_stream *s = (gz_stream*)file;
+    
+    return (s == NULL || s->mode != 'r') ? 0 : s->z_eof;
+}
+
+/* ===========================================================================
+   Outputs a long in LSB order to the given file
+*/
+local void putLong (file, x)
+    FILE *file;
+    uLong x;
+{
+    int n;
+    for (n = 0; n < 4; n++) {
+        fputc((int)(x & 0xff), file);
+        x >>= 8;
+    }
+}
+
+/* ===========================================================================
+   Reads a long in LSB order from the given gz_stream. Sets z_err in case
+   of error.
+*/
+local uLong getLong (s)
+    gz_stream *s;
+{
+    uLong x = (uLong)get_byte(s);
+    int c;
+
+    x += ((uLong)get_byte(s))<<8;
+    x += ((uLong)get_byte(s))<<16;
+    c = get_byte(s);
+    if (c == EOF) s->z_err = Z_DATA_ERROR;
+    x += ((uLong)c)<<24;
+    return x;
+}
+
+/* ===========================================================================
+     Flushes all pending output if necessary, closes the compressed file
+   and deallocates all the (de)compression state.
+*/
+int ZEXPORT gzclose (file)
+    gzFile file;
+{
+    int err;
+    gz_stream *s = (gz_stream*)file;
+
+    if (s == NULL) return Z_STREAM_ERROR;
+
+    if (s->mode == 'w') {
+#ifdef NO_DEFLATE
+	return Z_STREAM_ERROR;
+#else
+        err = do_flush (file, Z_FINISH);
+        if (err != Z_OK) return destroy((gz_stream*)file);
+
+        putLong (s->file, s->crc);
+        putLong (s->file, s->stream.total_in);
+#endif
+    }
+    return destroy((gz_stream*)file);
+}
+
+/* ===========================================================================
+     Returns the error message for the last error which occured on the
+   given compressed file. errnum is set to zlib error number. If an
+   error occured in the file system and not in the compression library,
+   errnum is set to Z_ERRNO and the application may consult errno
+   to get the exact error code.
+*/
+const char*  ZEXPORT gzerror (file, errnum)
+    gzFile file;
+    int *errnum;
+{
+    char *m;
+    gz_stream *s = (gz_stream*)file;
+
+    if (s == NULL) {
+        *errnum = Z_STREAM_ERROR;
+        return (const char*)ERR_MSG(Z_STREAM_ERROR);
+    }
+    *errnum = s->z_err;
+    if (*errnum == Z_OK) return (const char*)"";
+
+    m =  (char*)(*errnum == Z_ERRNO ? zstrerror(errno) : s->stream.msg);
+
+    if (m == NULL || *m == '\0') m = (char*)ERR_MSG(s->z_err);
+
+    TRYFREE(s->msg);
+    s->msg = (char*)ALLOC(strlen(s->path) + strlen(m) + 3);
+    strcpy(s->msg, s->path);
+    strcat(s->msg, ": ");
+    strcat(s->msg, m);
+    return (const char*)s->msg;
+}
diff --git a/collects/plot/src/all/infblock.c b/collects/plot/src/all/infblock.c
new file mode 100644
index 0000000000..dd7a6d40a8
--- /dev/null
+++ b/collects/plot/src/all/infblock.c
@@ -0,0 +1,403 @@
+/* infblock.c -- interpret and process block types to last block
+ * Copyright (C) 1995-2002 Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h 
+ */
+
+#include "zutil.h"
+#include "infblock.h"
+#include "inftrees.h"
+#include "infcodes.h"
+#include "infutil.h"
+
+struct inflate_codes_state {int dummy;}; /* for buggy compilers */
+
+/* simplify the use of the inflate_huft type with some defines */
+#define exop word.what.Exop
+#define bits word.what.Bits
+
+/* Table for deflate from PKZIP's appnote.txt. */
+local const uInt border[] = { /* Order of the bit length code lengths */
+        16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15};
+
+/*
+   Notes beyond the 1.93a appnote.txt:
+
+   1. Distance pointers never point before the beginning of the output
+      stream.
+   2. Distance pointers can point back across blocks, up to 32k away.
+   3. There is an implied maximum of 7 bits for the bit length table and
+      15 bits for the actual data.
+   4. If only one code exists, then it is encoded using one bit.  (Zero
+      would be more efficient, but perhaps a little confusing.)  If two
+      codes exist, they are coded using one bit each (0 and 1).
+   5. There is no way of sending zero distance codes--a dummy must be
+      sent if there are none.  (History: a pre 2.0 version of PKZIP would
+      store blocks with no distance codes, but this was discovered to be
+      too harsh a criterion.)  Valid only for 1.93a.  2.04c does allow
+      zero distance codes, which is sent as one code of zero bits in
+      length.
+   6. There are up to 286 literal/length codes.  Code 256 represents the
+      end-of-block.  Note however that the static length tree defines
+      288 codes just to fill out the Huffman codes.  Codes 286 and 287
+      cannot be used though, since there is no length base or extra bits
+      defined for them.  Similarily, there are up to 30 distance codes.
+      However, static trees define 32 codes (all 5 bits) to fill out the
+      Huffman codes, but the last two had better not show up in the data.
+   7. Unzip can check dynamic Huffman blocks for complete code sets.
+      The exception is that a single code would not be complete (see #4).
+   8. The five bits following the block type is really the number of
+      literal codes sent minus 257.
+   9. Length codes 8,16,16 are interpreted as 13 length codes of 8 bits
+      (1+6+6).  Therefore, to output three times the length, you output
+      three codes (1+1+1), whereas to output four times the same length,
+      you only need two codes (1+3).  Hmm.
+  10. In the tree reconstruction algorithm, Code = Code + Increment
+      only if BitLength(i) is not zero.  (Pretty obvious.)
+  11. Correction: 4 Bits: # of Bit Length codes - 4     (4 - 19)
+  12. Note: length code 284 can represent 227-258, but length code 285
+      really is 258.  The last length deserves its own, short code
+      since it gets used a lot in very redundant files.  The length
+      258 is special since 258 - 3 (the min match length) is 255.
+  13. The literal/length and distance code bit lengths are read as a
+      single stream of lengths.  It is possible (and advantageous) for
+      a repeat code (16, 17, or 18) to go across the boundary between
+      the two sets of lengths.
+ */
+
+
+void inflate_blocks_reset(s, z, c)
+inflate_blocks_statef *s;
+z_streamp z;
+uLongf *c;
+{
+  if (c != Z_NULL)
+    *c = s->check;
+  if (s->mode == BTREE || s->mode == DTREE)
+    ZFREE(z, s->sub.trees.blens);
+  if (s->mode == CODES)
+    inflate_codes_free(s->sub.decode.codes, z);
+  s->mode = TYPE;
+  s->bitk = 0;
+  s->bitb = 0;
+  s->read = s->write = s->window;
+  if (s->checkfn != Z_NULL)
+    z->adler = s->check = (*s->checkfn)(0L, (const Bytef *)Z_NULL, 0);
+  Tracev((stderr, "inflate:   blocks reset\n"));
+}
+
+
+inflate_blocks_statef *inflate_blocks_new(z, c, w)
+z_streamp z;
+check_func c;
+uInt w;
+{
+  inflate_blocks_statef *s;
+
+  if ((s = (inflate_blocks_statef *)ZALLOC
+       (z,1,sizeof(struct inflate_blocks_state))) == Z_NULL)
+    return s;
+  if ((s->hufts =
+       (inflate_huft *)ZALLOC(z, sizeof(inflate_huft), MANY)) == Z_NULL)
+  {
+    ZFREE(z, s);
+    return Z_NULL;
+  }
+  if ((s->window = (Bytef *)ZALLOC(z, 1, w)) == Z_NULL)
+  {
+    ZFREE(z, s->hufts);
+    ZFREE(z, s);
+    return Z_NULL;
+  }
+  s->end = s->window + w;
+  s->checkfn = c;
+  s->mode = TYPE;
+  Tracev((stderr, "inflate:   blocks allocated\n"));
+  inflate_blocks_reset(s, z, Z_NULL);
+  return s;
+}
+
+
+int inflate_blocks(s, z, r)
+inflate_blocks_statef *s;
+z_streamp z;
+int r;
+{
+  uInt t;               /* temporary storage */
+  uLong b;              /* bit buffer */
+  uInt k;               /* bits in bit buffer */
+  Bytef *p;             /* input data pointer */
+  uInt n;               /* bytes available there */
+  Bytef *q;             /* output window write pointer */
+  uInt m;               /* bytes to end of window or read pointer */
+
+  /* copy input/output information to locals (UPDATE macro restores) */
+  LOAD
+
+  /* process input based on current state */
+  while (1) switch (s->mode)
+  {
+    case TYPE:
+      NEEDBITS(3)
+      t = (uInt)b & 7;
+      s->last = t & 1;
+      switch (t >> 1)
+      {
+        case 0:                         /* stored */
+          Tracev((stderr, "inflate:     stored block%s\n",
+                 s->last ? " (last)" : ""));
+          DUMPBITS(3)
+          t = k & 7;                    /* go to byte boundary */
+          DUMPBITS(t)
+          s->mode = LENS;               /* get length of stored block */
+          break;
+        case 1:                         /* fixed */
+          Tracev((stderr, "inflate:     fixed codes block%s\n",
+                 s->last ? " (last)" : ""));
+          {
+            uInt bl, bd;
+            inflate_huft *tl, *td;
+
+            inflate_trees_fixed(&bl, &bd, &tl, &td, z);
+            s->sub.decode.codes = inflate_codes_new(bl, bd, tl, td, z);
+            if (s->sub.decode.codes == Z_NULL)
+            {
+              r = Z_MEM_ERROR;
+              LEAVE
+            }
+          }
+          DUMPBITS(3)
+          s->mode = CODES;
+          break;
+        case 2:                         /* dynamic */
+          Tracev((stderr, "inflate:     dynamic codes block%s\n",
+                 s->last ? " (last)" : ""));
+          DUMPBITS(3)
+          s->mode = TABLE;
+          break;
+        case 3:                         /* illegal */
+          DUMPBITS(3)
+          s->mode = BAD;
+          z->msg = (char*)"invalid block type";
+          r = Z_DATA_ERROR;
+          LEAVE
+      }
+      break;
+    case LENS:
+      NEEDBITS(32)
+      if ((((~b) >> 16) & 0xffff) != (b & 0xffff))
+      {
+        s->mode = BAD;
+        z->msg = (char*)"invalid stored block lengths";
+        r = Z_DATA_ERROR;
+        LEAVE
+      }
+      s->sub.left = (uInt)b & 0xffff;
+      b = k = 0;                      /* dump bits */
+      Tracev((stderr, "inflate:       stored length %u\n", s->sub.left));
+      s->mode = s->sub.left ? STORED : (s->last ? DRY : TYPE);
+      break;
+    case STORED:
+      if (n == 0)
+        LEAVE
+      NEEDOUT
+      t = s->sub.left;
+      if (t > n) t = n;
+      if (t > m) t = m;
+      zmemcpy(q, p, t);
+      p += t;  n -= t;
+      q += t;  m -= t;
+      if ((s->sub.left -= t) != 0)
+        break;
+      Tracev((stderr, "inflate:       stored end, %lu total out\n",
+              z->total_out + (q >= s->read ? q - s->read :
+              (s->end - s->read) + (q - s->window))));
+      s->mode = s->last ? DRY : TYPE;
+      break;
+    case TABLE:
+      NEEDBITS(14)
+      s->sub.trees.table = t = (uInt)b & 0x3fff;
+#ifndef PKZIP_BUG_WORKAROUND
+      if ((t & 0x1f) > 29 || ((t >> 5) & 0x1f) > 29)
+      {
+        s->mode = BAD;
+        z->msg = (char*)"too many length or distance symbols";
+        r = Z_DATA_ERROR;
+        LEAVE
+      }
+#endif
+      t = 258 + (t & 0x1f) + ((t >> 5) & 0x1f);
+      if ((s->sub.trees.blens = (uIntf*)ZALLOC(z, t, sizeof(uInt))) == Z_NULL)
+      {
+        r = Z_MEM_ERROR;
+        LEAVE
+      }
+      DUMPBITS(14)
+      s->sub.trees.index = 0;
+      Tracev((stderr, "inflate:       table sizes ok\n"));
+      s->mode = BTREE;
+    case BTREE:
+      while (s->sub.trees.index < 4 + (s->sub.trees.table >> 10))
+      {
+        NEEDBITS(3)
+        s->sub.trees.blens[border[s->sub.trees.index++]] = (uInt)b & 7;
+        DUMPBITS(3)
+      }
+      while (s->sub.trees.index < 19)
+        s->sub.trees.blens[border[s->sub.trees.index++]] = 0;
+      s->sub.trees.bb = 7;
+      t = inflate_trees_bits(s->sub.trees.blens, &s->sub.trees.bb,
+                             &s->sub.trees.tb, s->hufts, z);
+      if (t != Z_OK)
+      {
+        r = t;
+        if (r == Z_DATA_ERROR)
+        {
+          ZFREE(z, s->sub.trees.blens);
+          s->mode = BAD;
+        }
+        LEAVE
+      }
+      s->sub.trees.index = 0;
+      Tracev((stderr, "inflate:       bits tree ok\n"));
+      s->mode = DTREE;
+    case DTREE:
+      while (t = s->sub.trees.table,
+             s->sub.trees.index < 258 + (t & 0x1f) + ((t >> 5) & 0x1f))
+      {
+        inflate_huft *h;
+        uInt i, j, c;
+
+        t = s->sub.trees.bb;
+        NEEDBITS(t)
+        h = s->sub.trees.tb + ((uInt)b & inflate_mask[t]);
+        t = h->bits;
+        c = h->base;
+        if (c < 16)
+        {
+          DUMPBITS(t)
+          s->sub.trees.blens[s->sub.trees.index++] = c;
+        }
+        else /* c == 16..18 */
+        {
+          i = c == 18 ? 7 : c - 14;
+          j = c == 18 ? 11 : 3;
+          NEEDBITS(t + i)
+          DUMPBITS(t)
+          j += (uInt)b & inflate_mask[i];
+          DUMPBITS(i)
+          i = s->sub.trees.index;
+          t = s->sub.trees.table;
+          if (i + j > 258 + (t & 0x1f) + ((t >> 5) & 0x1f) ||
+              (c == 16 && i < 1))
+          {
+            ZFREE(z, s->sub.trees.blens);
+            s->mode = BAD;
+            z->msg = (char*)"invalid bit length repeat";
+            r = Z_DATA_ERROR;
+            LEAVE
+          }
+          c = c == 16 ? s->sub.trees.blens[i - 1] : 0;
+          do {
+            s->sub.trees.blens[i++] = c;
+          } while (--j);
+          s->sub.trees.index = i;
+        }
+      }
+      s->sub.trees.tb = Z_NULL;
+      {
+        uInt bl, bd;
+        inflate_huft *tl, *td;
+        inflate_codes_statef *c;
+
+        bl = 9;         /* must be <= 9 for lookahead assumptions */
+        bd = 6;         /* must be <= 9 for lookahead assumptions */
+        t = s->sub.trees.table;
+        t = inflate_trees_dynamic(257 + (t & 0x1f), 1 + ((t >> 5) & 0x1f),
+                                  s->sub.trees.blens, &bl, &bd, &tl, &td,
+                                  s->hufts, z);
+        if (t != Z_OK)
+        {
+          if (t == (uInt)Z_DATA_ERROR)
+          {
+            ZFREE(z, s->sub.trees.blens);
+            s->mode = BAD;
+          }
+          r = t;
+          LEAVE
+        }
+        Tracev((stderr, "inflate:       trees ok\n"));
+        if ((c = inflate_codes_new(bl, bd, tl, td, z)) == Z_NULL)
+        {
+          r = Z_MEM_ERROR;
+          LEAVE
+        }
+        s->sub.decode.codes = c;
+      }
+      ZFREE(z, s->sub.trees.blens);
+      s->mode = CODES;
+    case CODES:
+      UPDATE
+      if ((r = inflate_codes(s, z, r)) != Z_STREAM_END)
+        return inflate_flush(s, z, r);
+      r = Z_OK;
+      inflate_codes_free(s->sub.decode.codes, z);
+      LOAD
+      Tracev((stderr, "inflate:       codes end, %lu total out\n",
+              z->total_out + (q >= s->read ? q - s->read :
+              (s->end - s->read) + (q - s->window))));
+      if (!s->last)
+      {
+        s->mode = TYPE;
+        break;
+      }
+      s->mode = DRY;
+    case DRY:
+      FLUSH
+      if (s->read != s->write)
+        LEAVE
+      s->mode = DONE;
+    case DONE:
+      r = Z_STREAM_END;
+      LEAVE
+    case BAD:
+      r = Z_DATA_ERROR;
+      LEAVE
+    default:
+      r = Z_STREAM_ERROR;
+      LEAVE
+  }
+}
+
+
+int inflate_blocks_free(s, z)
+inflate_blocks_statef *s;
+z_streamp z;
+{
+  inflate_blocks_reset(s, z, Z_NULL);
+  ZFREE(z, s->window);
+  ZFREE(z, s->hufts);
+  ZFREE(z, s);
+  Tracev((stderr, "inflate:   blocks freed\n"));
+  return Z_OK;
+}
+
+
+void inflate_set_dictionary(s, d, n)
+inflate_blocks_statef *s;
+const Bytef *d;
+uInt  n;
+{
+  zmemcpy(s->window, d, n);
+  s->read = s->write = s->window + n;
+}
+
+
+/* Returns true if inflate is currently at the end of a block generated
+ * by Z_SYNC_FLUSH or Z_FULL_FLUSH. 
+ * IN assertion: s != Z_NULL
+ */
+int inflate_blocks_sync_point(s)
+inflate_blocks_statef *s;
+{
+  return s->mode == LENS;
+}
diff --git a/collects/plot/src/all/infblock.h b/collects/plot/src/all/infblock.h
new file mode 100644
index 0000000000..173b2267ad
--- /dev/null
+++ b/collects/plot/src/all/infblock.h
@@ -0,0 +1,39 @@
+/* infblock.h -- header to use infblock.c
+ * Copyright (C) 1995-2002 Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h 
+ */
+
+/* WARNING: this file should *not* be used by applications. It is
+   part of the implementation of the compression library and is
+   subject to change. Applications should only use zlib.h.
+ */
+
+struct inflate_blocks_state;
+typedef struct inflate_blocks_state FAR inflate_blocks_statef;
+
+extern inflate_blocks_statef * inflate_blocks_new OF((
+    z_streamp z,
+    check_func c,               /* check function */
+    uInt w));                   /* window size */
+
+extern int inflate_blocks OF((
+    inflate_blocks_statef *,
+    z_streamp ,
+    int));                      /* initial return code */
+
+extern void inflate_blocks_reset OF((
+    inflate_blocks_statef *,
+    z_streamp ,
+    uLongf *));                  /* check value on output */
+
+extern int inflate_blocks_free OF((
+    inflate_blocks_statef *,
+    z_streamp));
+
+extern void inflate_set_dictionary OF((
+    inflate_blocks_statef *s,
+    const Bytef *d,  /* dictionary */
+    uInt  n));       /* dictionary length */
+
+extern int inflate_blocks_sync_point OF((
+    inflate_blocks_statef *s));
diff --git a/collects/plot/src/all/infcodes.c b/collects/plot/src/all/infcodes.c
new file mode 100644
index 0000000000..9abe5412b9
--- /dev/null
+++ b/collects/plot/src/all/infcodes.c
@@ -0,0 +1,251 @@
+/* infcodes.c -- process literals and length/distance pairs
+ * Copyright (C) 1995-2002 Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h 
+ */
+
+#include "zutil.h"
+#include "inftrees.h"
+#include "infblock.h"
+#include "infcodes.h"
+#include "infutil.h"
+#include "inffast.h"
+
+/* simplify the use of the inflate_huft type with some defines */
+#define exop word.what.Exop
+#define bits word.what.Bits
+
+typedef enum {        /* waiting for "i:"=input, "o:"=output, "x:"=nothing */
+      START,    /* x: set up for LEN */
+      LEN,      /* i: get length/literal/eob next */
+      LENEXT,   /* i: getting length extra (have base) */
+      DIST,     /* i: get distance next */
+      DISTEXT,  /* i: getting distance extra */
+      COPY,     /* o: copying bytes in window, waiting for space */
+      LIT,      /* o: got literal, waiting for output space */
+      WASH,     /* o: got eob, possibly still output waiting */
+      END,      /* x: got eob and all data flushed */
+      BADCODE}  /* x: got error */
+inflate_codes_mode;
+
+/* inflate codes private state */
+struct inflate_codes_state {
+
+  /* mode */
+  inflate_codes_mode mode;      /* current inflate_codes mode */
+
+  /* mode dependent information */
+  uInt len;
+  union {
+    struct {
+      inflate_huft *tree;       /* pointer into tree */
+      uInt need;                /* bits needed */
+    } code;             /* if LEN or DIST, where in tree */
+    uInt lit;           /* if LIT, literal */
+    struct {
+      uInt get;                 /* bits to get for extra */
+      uInt dist;                /* distance back to copy from */
+    } copy;             /* if EXT or COPY, where and how much */
+  } sub;                /* submode */
+
+  /* mode independent information */
+  Byte lbits;           /* ltree bits decoded per branch */
+  Byte dbits;           /* dtree bits decoder per branch */
+  inflate_huft *ltree;          /* literal/length/eob tree */
+  inflate_huft *dtree;          /* distance tree */
+
+};
+
+
+inflate_codes_statef *inflate_codes_new(bl, bd, tl, td, z)
+uInt bl, bd;
+inflate_huft *tl;
+inflate_huft *td; /* need separate declaration for Borland C++ */
+z_streamp z;
+{
+  inflate_codes_statef *c;
+
+  if ((c = (inflate_codes_statef *)
+       ZALLOC(z,1,sizeof(struct inflate_codes_state))) != Z_NULL)
+  {
+    c->mode = START;
+    c->lbits = (Byte)bl;
+    c->dbits = (Byte)bd;
+    c->ltree = tl;
+    c->dtree = td;
+    Tracev((stderr, "inflate:       codes new\n"));
+  }
+  return c;
+}
+
+
+int inflate_codes(s, z, r)
+inflate_blocks_statef *s;
+z_streamp z;
+int r;
+{
+  uInt j;               /* temporary storage */
+  inflate_huft *t;      /* temporary pointer */
+  uInt e;               /* extra bits or operation */
+  uLong b;              /* bit buffer */
+  uInt k;               /* bits in bit buffer */
+  Bytef *p;             /* input data pointer */
+  uInt n;               /* bytes available there */
+  Bytef *q;             /* output window write pointer */
+  uInt m;               /* bytes to end of window or read pointer */
+  Bytef *f;             /* pointer to copy strings from */
+  inflate_codes_statef *c = s->sub.decode.codes;  /* codes state */
+
+  /* copy input/output information to locals (UPDATE macro restores) */
+  LOAD
+
+  /* process input and output based on current state */
+  while (1) switch (c->mode)
+  {             /* waiting for "i:"=input, "o:"=output, "x:"=nothing */
+    case START:         /* x: set up for LEN */
+#ifndef SLOW
+      if (m >= 258 && n >= 10)
+      {
+        UPDATE
+        r = inflate_fast(c->lbits, c->dbits, c->ltree, c->dtree, s, z);
+        LOAD
+        if (r != Z_OK)
+        {
+          c->mode = r == Z_STREAM_END ? WASH : BADCODE;
+          break;
+        }
+      }
+#endif /* !SLOW */
+      c->sub.code.need = c->lbits;
+      c->sub.code.tree = c->ltree;
+      c->mode = LEN;
+    case LEN:           /* i: get length/literal/eob next */
+      j = c->sub.code.need;
+      NEEDBITS(j)
+      t = c->sub.code.tree + ((uInt)b & inflate_mask[j]);
+      DUMPBITS(t->bits)
+      e = (uInt)(t->exop);
+      if (e == 0)               /* literal */
+      {
+        c->sub.lit = t->base;
+        Tracevv((stderr, t->base >= 0x20 && t->base < 0x7f ?
+                 "inflate:         literal '%c'\n" :
+                 "inflate:         literal 0x%02x\n", t->base));
+        c->mode = LIT;
+        break;
+      }
+      if (e & 16)               /* length */
+      {
+        c->sub.copy.get = e & 15;
+        c->len = t->base;
+        c->mode = LENEXT;
+        break;
+      }
+      if ((e & 64) == 0)        /* next table */
+      {
+        c->sub.code.need = e;
+        c->sub.code.tree = t + t->base;
+        break;
+      }
+      if (e & 32)               /* end of block */
+      {
+        Tracevv((stderr, "inflate:         end of block\n"));
+        c->mode = WASH;
+        break;
+      }
+      c->mode = BADCODE;        /* invalid code */
+      z->msg = (char*)"invalid literal/length code";
+      r = Z_DATA_ERROR;
+      LEAVE
+    case LENEXT:        /* i: getting length extra (have base) */
+      j = c->sub.copy.get;
+      NEEDBITS(j)
+      c->len += (uInt)b & inflate_mask[j];
+      DUMPBITS(j)
+      c->sub.code.need = c->dbits;
+      c->sub.code.tree = c->dtree;
+      Tracevv((stderr, "inflate:         length %u\n", c->len));
+      c->mode = DIST;
+    case DIST:          /* i: get distance next */
+      j = c->sub.code.need;
+      NEEDBITS(j)
+      t = c->sub.code.tree + ((uInt)b & inflate_mask[j]);
+      DUMPBITS(t->bits)
+      e = (uInt)(t->exop);
+      if (e & 16)               /* distance */
+      {
+        c->sub.copy.get = e & 15;
+        c->sub.copy.dist = t->base;
+        c->mode = DISTEXT;
+        break;
+      }
+      if ((e & 64) == 0)        /* next table */
+      {
+        c->sub.code.need = e;
+        c->sub.code.tree = t + t->base;
+        break;
+      }
+      c->mode = BADCODE;        /* invalid code */
+      z->msg = (char*)"invalid distance code";
+      r = Z_DATA_ERROR;
+      LEAVE
+    case DISTEXT:       /* i: getting distance extra */
+      j = c->sub.copy.get;
+      NEEDBITS(j)
+      c->sub.copy.dist += (uInt)b & inflate_mask[j];
+      DUMPBITS(j)
+      Tracevv((stderr, "inflate:         distance %u\n", c->sub.copy.dist));
+      c->mode = COPY;
+    case COPY:          /* o: copying bytes in window, waiting for space */
+      f = q - c->sub.copy.dist;
+      while (f < s->window)             /* modulo window size-"while" instead */
+        f += s->end - s->window;        /* of "if" handles invalid distances */
+      while (c->len)
+      {
+        NEEDOUT
+        OUTBYTE(*f++)
+        if (f == s->end)
+          f = s->window;
+        c->len--;
+      }
+      c->mode = START;
+      break;
+    case LIT:           /* o: got literal, waiting for output space */
+      NEEDOUT
+      OUTBYTE(c->sub.lit)
+      c->mode = START;
+      break;
+    case WASH:          /* o: got eob, possibly more output */
+      if (k > 7)        /* return unused byte, if any */
+      {
+        Assert(k < 16, "inflate_codes grabbed too many bytes")
+        k -= 8;
+        n++;
+        p--;            /* can always return one */
+      }
+      FLUSH
+      if (s->read != s->write)
+        LEAVE
+      c->mode = END;
+    case END:
+      r = Z_STREAM_END;
+      LEAVE
+    case BADCODE:       /* x: got error */
+      r = Z_DATA_ERROR;
+      LEAVE
+    default:
+      r = Z_STREAM_ERROR;
+      LEAVE
+  }
+#ifdef NEED_DUMMY_RETURN
+  return Z_STREAM_ERROR;  /* Some dumb compilers complain without this */
+#endif
+}
+
+
+void inflate_codes_free(c, z)
+inflate_codes_statef *c;
+z_streamp z;
+{
+  ZFREE(z, c);
+  Tracev((stderr, "inflate:       codes free\n"));
+}
diff --git a/collects/plot/src/all/infcodes.h b/collects/plot/src/all/infcodes.h
new file mode 100644
index 0000000000..46821a02be
--- /dev/null
+++ b/collects/plot/src/all/infcodes.h
@@ -0,0 +1,27 @@
+/* infcodes.h -- header to use infcodes.c
+ * Copyright (C) 1995-2002 Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h 
+ */
+
+/* WARNING: this file should *not* be used by applications. It is
+   part of the implementation of the compression library and is
+   subject to change. Applications should only use zlib.h.
+ */
+
+struct inflate_codes_state;
+typedef struct inflate_codes_state FAR inflate_codes_statef;
+
+extern inflate_codes_statef *inflate_codes_new OF((
+    uInt, uInt,
+    inflate_huft *, inflate_huft *,
+    z_streamp ));
+
+extern int inflate_codes OF((
+    inflate_blocks_statef *,
+    z_streamp ,
+    int));
+
+extern void inflate_codes_free OF((
+    inflate_codes_statef *,
+    z_streamp ));
+
diff --git a/collects/plot/src/all/inffast.c b/collects/plot/src/all/inffast.c
new file mode 100644
index 0000000000..aa7f1d4d2a
--- /dev/null
+++ b/collects/plot/src/all/inffast.c
@@ -0,0 +1,183 @@
+/* inffast.c -- process literals and length/distance pairs fast
+ * Copyright (C) 1995-2002 Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h 
+ */
+
+#include "zutil.h"
+#include "inftrees.h"
+#include "infblock.h"
+#include "infcodes.h"
+#include "infutil.h"
+#include "inffast.h"
+
+struct inflate_codes_state {int dummy;}; /* for buggy compilers */
+
+/* simplify the use of the inflate_huft type with some defines */
+#define exop word.what.Exop
+#define bits word.what.Bits
+
+/* macros for bit input with no checking and for returning unused bytes */
+#define GRABBITS(j) {while(k<(j)){b|=((uLong)NEXTBYTE)<<k;k+=8;}}
+#define UNGRAB {c=z->avail_in-n;c=(k>>3)<c?k>>3:c;n+=c;p-=c;k-=c<<3;}
+
+/* Called with number of bytes left to write in window at least 258
+   (the maximum string length) and number of input bytes available
+   at least ten.  The ten bytes are six bytes for the longest length/
+   distance pair plus four bytes for overloading the bit buffer. */
+
+int inflate_fast(bl, bd, tl, td, s, z)
+uInt bl, bd;
+inflate_huft *tl;
+inflate_huft *td; /* need separate declaration for Borland C++ */
+inflate_blocks_statef *s;
+z_streamp z;
+{
+  inflate_huft *t;      /* temporary pointer */
+  uInt e;               /* extra bits or operation */
+  uLong b;              /* bit buffer */
+  uInt k;               /* bits in bit buffer */
+  Bytef *p;             /* input data pointer */
+  uInt n;               /* bytes available there */
+  Bytef *q;             /* output window write pointer */
+  uInt m;               /* bytes to end of window or read pointer */
+  uInt ml;              /* mask for literal/length tree */
+  uInt md;              /* mask for distance tree */
+  uInt c;               /* bytes to copy */
+  uInt d;               /* distance back to copy from */
+  Bytef *r;             /* copy source pointer */
+
+  /* load input, output, bit values */
+  LOAD
+
+  /* initialize masks */
+  ml = inflate_mask[bl];
+  md = inflate_mask[bd];
+
+  /* do until not enough input or output space for fast loop */
+  do {                          /* assume called with m >= 258 && n >= 10 */
+    /* get literal/length code */
+    GRABBITS(20)                /* max bits for literal/length code */
+    if ((e = (t = tl + ((uInt)b & ml))->exop) == 0)
+    {
+      DUMPBITS(t->bits)
+      Tracevv((stderr, t->base >= 0x20 && t->base < 0x7f ?
+                "inflate:         * literal '%c'\n" :
+                "inflate:         * literal 0x%02x\n", t->base));
+      *q++ = (Byte)t->base;
+      m--;
+      continue;
+    }
+    do {
+      DUMPBITS(t->bits)
+      if (e & 16)
+      {
+        /* get extra bits for length */
+        e &= 15;
+        c = t->base + ((uInt)b & inflate_mask[e]);
+        DUMPBITS(e)
+        Tracevv((stderr, "inflate:         * length %u\n", c));
+
+        /* decode distance base of block to copy */
+        GRABBITS(15);           /* max bits for distance code */
+        e = (t = td + ((uInt)b & md))->exop;
+        do {
+          DUMPBITS(t->bits)
+          if (e & 16)
+          {
+            /* get extra bits to add to distance base */
+            e &= 15;
+            GRABBITS(e)         /* get extra bits (up to 13) */
+            d = t->base + ((uInt)b & inflate_mask[e]);
+            DUMPBITS(e)
+            Tracevv((stderr, "inflate:         * distance %u\n", d));
+
+            /* do the copy */
+            m -= c;
+            r = q - d;
+            if (r < s->window)                  /* wrap if needed */
+            {
+              do {
+                r += s->end - s->window;        /* force pointer in window */
+              } while (r < s->window);          /* covers invalid distances */
+              e = s->end - r;
+              if (c > e)
+              {
+                c -= e;                         /* wrapped copy */
+                do {
+                    *q++ = *r++;
+                } while (--e);
+                r = s->window;
+                do {
+                    *q++ = *r++;
+                } while (--c);
+              }
+              else                              /* normal copy */
+              {
+                *q++ = *r++;  c--;
+                *q++ = *r++;  c--;
+                do {
+                    *q++ = *r++;
+                } while (--c);
+              }
+            }
+            else                                /* normal copy */
+            {
+              *q++ = *r++;  c--;
+              *q++ = *r++;  c--;
+              do {
+                *q++ = *r++;
+              } while (--c);
+            }
+            break;
+          }
+          else if ((e & 64) == 0)
+          {
+            t += t->base;
+            e = (t += ((uInt)b & inflate_mask[e]))->exop;
+          }
+          else
+          {
+            z->msg = (char*)"invalid distance code";
+            UNGRAB
+            UPDATE
+            return Z_DATA_ERROR;
+          }
+        } while (1);
+        break;
+      }
+      if ((e & 64) == 0)
+      {
+        t += t->base;
+        if ((e = (t += ((uInt)b & inflate_mask[e]))->exop) == 0)
+        {
+          DUMPBITS(t->bits)
+          Tracevv((stderr, t->base >= 0x20 && t->base < 0x7f ?
+                    "inflate:         * literal '%c'\n" :
+                    "inflate:         * literal 0x%02x\n", t->base));
+          *q++ = (Byte)t->base;
+          m--;
+          break;
+        }
+      }
+      else if (e & 32)
+      {
+        Tracevv((stderr, "inflate:         * end of block\n"));
+        UNGRAB
+        UPDATE
+        return Z_STREAM_END;
+      }
+      else
+      {
+        z->msg = (char*)"invalid literal/length code";
+        UNGRAB
+        UPDATE
+        return Z_DATA_ERROR;
+      }
+    } while (1);
+  } while (m >= 258 && n >= 10);
+
+  /* not enough input or output--restore pointers and return */
+  UNGRAB
+  UPDATE
+  return Z_OK;
+}
diff --git a/collects/plot/src/all/inffast.h b/collects/plot/src/all/inffast.h
new file mode 100644
index 0000000000..a31a4bbb05
--- /dev/null
+++ b/collects/plot/src/all/inffast.h
@@ -0,0 +1,17 @@
+/* inffast.h -- header to use inffast.c
+ * Copyright (C) 1995-2002 Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h 
+ */
+
+/* WARNING: this file should *not* be used by applications. It is
+   part of the implementation of the compression library and is
+   subject to change. Applications should only use zlib.h.
+ */
+
+extern int inflate_fast OF((
+    uInt,
+    uInt,
+    inflate_huft *,
+    inflate_huft *,
+    inflate_blocks_statef *,
+    z_streamp ));
diff --git a/collects/plot/src/all/inffixed.h b/collects/plot/src/all/inffixed.h
new file mode 100644
index 0000000000..77f7e76314
--- /dev/null
+++ b/collects/plot/src/all/inffixed.h
@@ -0,0 +1,151 @@
+/* inffixed.h -- table for decoding fixed codes
+ * Generated automatically by the maketree.c program
+ */
+
+/* WARNING: this file should *not* be used by applications. It is
+   part of the implementation of the compression library and is
+   subject to change. Applications should only use zlib.h.
+ */
+
+local uInt fixed_bl = 9;
+local uInt fixed_bd = 5;
+local inflate_huft fixed_tl[] = {
+    {{{96,7}},256}, {{{0,8}},80}, {{{0,8}},16}, {{{84,8}},115},
+    {{{82,7}},31}, {{{0,8}},112}, {{{0,8}},48}, {{{0,9}},192},
+    {{{80,7}},10}, {{{0,8}},96}, {{{0,8}},32}, {{{0,9}},160},
+    {{{0,8}},0}, {{{0,8}},128}, {{{0,8}},64}, {{{0,9}},224},
+    {{{80,7}},6}, {{{0,8}},88}, {{{0,8}},24}, {{{0,9}},144},
+    {{{83,7}},59}, {{{0,8}},120}, {{{0,8}},56}, {{{0,9}},208},
+    {{{81,7}},17}, {{{0,8}},104}, {{{0,8}},40}, {{{0,9}},176},
+    {{{0,8}},8}, {{{0,8}},136}, {{{0,8}},72}, {{{0,9}},240},
+    {{{80,7}},4}, {{{0,8}},84}, {{{0,8}},20}, {{{85,8}},227},
+    {{{83,7}},43}, {{{0,8}},116}, {{{0,8}},52}, {{{0,9}},200},
+    {{{81,7}},13}, {{{0,8}},100}, {{{0,8}},36}, {{{0,9}},168},
+    {{{0,8}},4}, {{{0,8}},132}, {{{0,8}},68}, {{{0,9}},232},
+    {{{80,7}},8}, {{{0,8}},92}, {{{0,8}},28}, {{{0,9}},152},
+    {{{84,7}},83}, {{{0,8}},124}, {{{0,8}},60}, {{{0,9}},216},
+    {{{82,7}},23}, {{{0,8}},108}, {{{0,8}},44}, {{{0,9}},184},
+    {{{0,8}},12}, {{{0,8}},140}, {{{0,8}},76}, {{{0,9}},248},
+    {{{80,7}},3}, {{{0,8}},82}, {{{0,8}},18}, {{{85,8}},163},
+    {{{83,7}},35}, {{{0,8}},114}, {{{0,8}},50}, {{{0,9}},196},
+    {{{81,7}},11}, {{{0,8}},98}, {{{0,8}},34}, {{{0,9}},164},
+    {{{0,8}},2}, {{{0,8}},130}, {{{0,8}},66}, {{{0,9}},228},
+    {{{80,7}},7}, {{{0,8}},90}, {{{0,8}},26}, {{{0,9}},148},
+    {{{84,7}},67}, {{{0,8}},122}, {{{0,8}},58}, {{{0,9}},212},
+    {{{82,7}},19}, {{{0,8}},106}, {{{0,8}},42}, {{{0,9}},180},
+    {{{0,8}},10}, {{{0,8}},138}, {{{0,8}},74}, {{{0,9}},244},
+    {{{80,7}},5}, {{{0,8}},86}, {{{0,8}},22}, {{{192,8}},0},
+    {{{83,7}},51}, {{{0,8}},118}, {{{0,8}},54}, {{{0,9}},204},
+    {{{81,7}},15}, {{{0,8}},102}, {{{0,8}},38}, {{{0,9}},172},
+    {{{0,8}},6}, {{{0,8}},134}, {{{0,8}},70}, {{{0,9}},236},
+    {{{80,7}},9}, {{{0,8}},94}, {{{0,8}},30}, {{{0,9}},156},
+    {{{84,7}},99}, {{{0,8}},126}, {{{0,8}},62}, {{{0,9}},220},
+    {{{82,7}},27}, {{{0,8}},110}, {{{0,8}},46}, {{{0,9}},188},
+    {{{0,8}},14}, {{{0,8}},142}, {{{0,8}},78}, {{{0,9}},252},
+    {{{96,7}},256}, {{{0,8}},81}, {{{0,8}},17}, {{{85,8}},131},
+    {{{82,7}},31}, {{{0,8}},113}, {{{0,8}},49}, {{{0,9}},194},
+    {{{80,7}},10}, {{{0,8}},97}, {{{0,8}},33}, {{{0,9}},162},
+    {{{0,8}},1}, {{{0,8}},129}, {{{0,8}},65}, {{{0,9}},226},
+    {{{80,7}},6}, {{{0,8}},89}, {{{0,8}},25}, {{{0,9}},146},
+    {{{83,7}},59}, {{{0,8}},121}, {{{0,8}},57}, {{{0,9}},210},
+    {{{81,7}},17}, {{{0,8}},105}, {{{0,8}},41}, {{{0,9}},178},
+    {{{0,8}},9}, {{{0,8}},137}, {{{0,8}},73}, {{{0,9}},242},
+    {{{80,7}},4}, {{{0,8}},85}, {{{0,8}},21}, {{{80,8}},258},
+    {{{83,7}},43}, {{{0,8}},117}, {{{0,8}},53}, {{{0,9}},202},
+    {{{81,7}},13}, {{{0,8}},101}, {{{0,8}},37}, {{{0,9}},170},
+    {{{0,8}},5}, {{{0,8}},133}, {{{0,8}},69}, {{{0,9}},234},
+    {{{80,7}},8}, {{{0,8}},93}, {{{0,8}},29}, {{{0,9}},154},
+    {{{84,7}},83}, {{{0,8}},125}, {{{0,8}},61}, {{{0,9}},218},
+    {{{82,7}},23}, {{{0,8}},109}, {{{0,8}},45}, {{{0,9}},186},
+    {{{0,8}},13}, {{{0,8}},141}, {{{0,8}},77}, {{{0,9}},250},
+    {{{80,7}},3}, {{{0,8}},83}, {{{0,8}},19}, {{{85,8}},195},
+    {{{83,7}},35}, {{{0,8}},115}, {{{0,8}},51}, {{{0,9}},198},
+    {{{81,7}},11}, {{{0,8}},99}, {{{0,8}},35}, {{{0,9}},166},
+    {{{0,8}},3}, {{{0,8}},131}, {{{0,8}},67}, {{{0,9}},230},
+    {{{80,7}},7}, {{{0,8}},91}, {{{0,8}},27}, {{{0,9}},150},
+    {{{84,7}},67}, {{{0,8}},123}, {{{0,8}},59}, {{{0,9}},214},
+    {{{82,7}},19}, {{{0,8}},107}, {{{0,8}},43}, {{{0,9}},182},
+    {{{0,8}},11}, {{{0,8}},139}, {{{0,8}},75}, {{{0,9}},246},
+    {{{80,7}},5}, {{{0,8}},87}, {{{0,8}},23}, {{{192,8}},0},
+    {{{83,7}},51}, {{{0,8}},119}, {{{0,8}},55}, {{{0,9}},206},
+    {{{81,7}},15}, {{{0,8}},103}, {{{0,8}},39}, {{{0,9}},174},
+    {{{0,8}},7}, {{{0,8}},135}, {{{0,8}},71}, {{{0,9}},238},
+    {{{80,7}},9}, {{{0,8}},95}, {{{0,8}},31}, {{{0,9}},158},
+    {{{84,7}},99}, {{{0,8}},127}, {{{0,8}},63}, {{{0,9}},222},
+    {{{82,7}},27}, {{{0,8}},111}, {{{0,8}},47}, {{{0,9}},190},
+    {{{0,8}},15}, {{{0,8}},143}, {{{0,8}},79}, {{{0,9}},254},
+    {{{96,7}},256}, {{{0,8}},80}, {{{0,8}},16}, {{{84,8}},115},
+    {{{82,7}},31}, {{{0,8}},112}, {{{0,8}},48}, {{{0,9}},193},
+    {{{80,7}},10}, {{{0,8}},96}, {{{0,8}},32}, {{{0,9}},161},
+    {{{0,8}},0}, {{{0,8}},128}, {{{0,8}},64}, {{{0,9}},225},
+    {{{80,7}},6}, {{{0,8}},88}, {{{0,8}},24}, {{{0,9}},145},
+    {{{83,7}},59}, {{{0,8}},120}, {{{0,8}},56}, {{{0,9}},209},
+    {{{81,7}},17}, {{{0,8}},104}, {{{0,8}},40}, {{{0,9}},177},
+    {{{0,8}},8}, {{{0,8}},136}, {{{0,8}},72}, {{{0,9}},241},
+    {{{80,7}},4}, {{{0,8}},84}, {{{0,8}},20}, {{{85,8}},227},
+    {{{83,7}},43}, {{{0,8}},116}, {{{0,8}},52}, {{{0,9}},201},
+    {{{81,7}},13}, {{{0,8}},100}, {{{0,8}},36}, {{{0,9}},169},
+    {{{0,8}},4}, {{{0,8}},132}, {{{0,8}},68}, {{{0,9}},233},
+    {{{80,7}},8}, {{{0,8}},92}, {{{0,8}},28}, {{{0,9}},153},
+    {{{84,7}},83}, {{{0,8}},124}, {{{0,8}},60}, {{{0,9}},217},
+    {{{82,7}},23}, {{{0,8}},108}, {{{0,8}},44}, {{{0,9}},185},
+    {{{0,8}},12}, {{{0,8}},140}, {{{0,8}},76}, {{{0,9}},249},
+    {{{80,7}},3}, {{{0,8}},82}, {{{0,8}},18}, {{{85,8}},163},
+    {{{83,7}},35}, {{{0,8}},114}, {{{0,8}},50}, {{{0,9}},197},
+    {{{81,7}},11}, {{{0,8}},98}, {{{0,8}},34}, {{{0,9}},165},
+    {{{0,8}},2}, {{{0,8}},130}, {{{0,8}},66}, {{{0,9}},229},
+    {{{80,7}},7}, {{{0,8}},90}, {{{0,8}},26}, {{{0,9}},149},
+    {{{84,7}},67}, {{{0,8}},122}, {{{0,8}},58}, {{{0,9}},213},
+    {{{82,7}},19}, {{{0,8}},106}, {{{0,8}},42}, {{{0,9}},181},
+    {{{0,8}},10}, {{{0,8}},138}, {{{0,8}},74}, {{{0,9}},245},
+    {{{80,7}},5}, {{{0,8}},86}, {{{0,8}},22}, {{{192,8}},0},
+    {{{83,7}},51}, {{{0,8}},118}, {{{0,8}},54}, {{{0,9}},205},
+    {{{81,7}},15}, {{{0,8}},102}, {{{0,8}},38}, {{{0,9}},173},
+    {{{0,8}},6}, {{{0,8}},134}, {{{0,8}},70}, {{{0,9}},237},
+    {{{80,7}},9}, {{{0,8}},94}, {{{0,8}},30}, {{{0,9}},157},
+    {{{84,7}},99}, {{{0,8}},126}, {{{0,8}},62}, {{{0,9}},221},
+    {{{82,7}},27}, {{{0,8}},110}, {{{0,8}},46}, {{{0,9}},189},
+    {{{0,8}},14}, {{{0,8}},142}, {{{0,8}},78}, {{{0,9}},253},
+    {{{96,7}},256}, {{{0,8}},81}, {{{0,8}},17}, {{{85,8}},131},
+    {{{82,7}},31}, {{{0,8}},113}, {{{0,8}},49}, {{{0,9}},195},
+    {{{80,7}},10}, {{{0,8}},97}, {{{0,8}},33}, {{{0,9}},163},
+    {{{0,8}},1}, {{{0,8}},129}, {{{0,8}},65}, {{{0,9}},227},
+    {{{80,7}},6}, {{{0,8}},89}, {{{0,8}},25}, {{{0,9}},147},
+    {{{83,7}},59}, {{{0,8}},121}, {{{0,8}},57}, {{{0,9}},211},
+    {{{81,7}},17}, {{{0,8}},105}, {{{0,8}},41}, {{{0,9}},179},
+    {{{0,8}},9}, {{{0,8}},137}, {{{0,8}},73}, {{{0,9}},243},
+    {{{80,7}},4}, {{{0,8}},85}, {{{0,8}},21}, {{{80,8}},258},
+    {{{83,7}},43}, {{{0,8}},117}, {{{0,8}},53}, {{{0,9}},203},
+    {{{81,7}},13}, {{{0,8}},101}, {{{0,8}},37}, {{{0,9}},171},
+    {{{0,8}},5}, {{{0,8}},133}, {{{0,8}},69}, {{{0,9}},235},
+    {{{80,7}},8}, {{{0,8}},93}, {{{0,8}},29}, {{{0,9}},155},
+    {{{84,7}},83}, {{{0,8}},125}, {{{0,8}},61}, {{{0,9}},219},
+    {{{82,7}},23}, {{{0,8}},109}, {{{0,8}},45}, {{{0,9}},187},
+    {{{0,8}},13}, {{{0,8}},141}, {{{0,8}},77}, {{{0,9}},251},
+    {{{80,7}},3}, {{{0,8}},83}, {{{0,8}},19}, {{{85,8}},195},
+    {{{83,7}},35}, {{{0,8}},115}, {{{0,8}},51}, {{{0,9}},199},
+    {{{81,7}},11}, {{{0,8}},99}, {{{0,8}},35}, {{{0,9}},167},
+    {{{0,8}},3}, {{{0,8}},131}, {{{0,8}},67}, {{{0,9}},231},
+    {{{80,7}},7}, {{{0,8}},91}, {{{0,8}},27}, {{{0,9}},151},
+    {{{84,7}},67}, {{{0,8}},123}, {{{0,8}},59}, {{{0,9}},215},
+    {{{82,7}},19}, {{{0,8}},107}, {{{0,8}},43}, {{{0,9}},183},
+    {{{0,8}},11}, {{{0,8}},139}, {{{0,8}},75}, {{{0,9}},247},
+    {{{80,7}},5}, {{{0,8}},87}, {{{0,8}},23}, {{{192,8}},0},
+    {{{83,7}},51}, {{{0,8}},119}, {{{0,8}},55}, {{{0,9}},207},
+    {{{81,7}},15}, {{{0,8}},103}, {{{0,8}},39}, {{{0,9}},175},
+    {{{0,8}},7}, {{{0,8}},135}, {{{0,8}},71}, {{{0,9}},239},
+    {{{80,7}},9}, {{{0,8}},95}, {{{0,8}},31}, {{{0,9}},159},
+    {{{84,7}},99}, {{{0,8}},127}, {{{0,8}},63}, {{{0,9}},223},
+    {{{82,7}},27}, {{{0,8}},111}, {{{0,8}},47}, {{{0,9}},191},
+    {{{0,8}},15}, {{{0,8}},143}, {{{0,8}},79}, {{{0,9}},255}
+  };
+local inflate_huft fixed_td[] = {
+    {{{80,5}},1}, {{{87,5}},257}, {{{83,5}},17}, {{{91,5}},4097},
+    {{{81,5}},5}, {{{89,5}},1025}, {{{85,5}},65}, {{{93,5}},16385},
+    {{{80,5}},3}, {{{88,5}},513}, {{{84,5}},33}, {{{92,5}},8193},
+    {{{82,5}},9}, {{{90,5}},2049}, {{{86,5}},129}, {{{192,5}},24577},
+    {{{80,5}},2}, {{{87,5}},385}, {{{83,5}},25}, {{{91,5}},6145},
+    {{{81,5}},7}, {{{89,5}},1537}, {{{85,5}},97}, {{{93,5}},24577},
+    {{{80,5}},4}, {{{88,5}},769}, {{{84,5}},49}, {{{92,5}},12289},
+    {{{82,5}},13}, {{{90,5}},3073}, {{{86,5}},193}, {{{192,5}},24577}
+  };
diff --git a/collects/plot/src/all/inflate.c b/collects/plot/src/all/inflate.c
new file mode 100644
index 0000000000..dfb2e867d8
--- /dev/null
+++ b/collects/plot/src/all/inflate.c
@@ -0,0 +1,366 @@
+/* inflate.c -- zlib interface to inflate modules
+ * Copyright (C) 1995-2002 Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h 
+ */
+
+#include "zutil.h"
+#include "infblock.h"
+
+struct inflate_blocks_state {int dummy;}; /* for buggy compilers */
+
+typedef enum {
+      METHOD,   /* waiting for method byte */
+      FLAG,     /* waiting for flag byte */
+      DICT4,    /* four dictionary check bytes to go */
+      DICT3,    /* three dictionary check bytes to go */
+      DICT2,    /* two dictionary check bytes to go */
+      DICT1,    /* one dictionary check byte to go */
+      DICT0,    /* waiting for inflateSetDictionary */
+      BLOCKS,   /* decompressing blocks */
+      CHECK4,   /* four check bytes to go */
+      CHECK3,   /* three check bytes to go */
+      CHECK2,   /* two check bytes to go */
+      CHECK1,   /* one check byte to go */
+      DONE,     /* finished check, done */
+      BAD}      /* got an error--stay here */
+inflate_mode;
+
+/* inflate private state */
+struct internal_state {
+
+  /* mode */
+  inflate_mode  mode;   /* current inflate mode */
+
+  /* mode dependent information */
+  union {
+    uInt method;        /* if FLAGS, method byte */
+    struct {
+      uLong was;                /* computed check value */
+      uLong need;               /* stream check value */
+    } check;            /* if CHECK, check values to compare */
+    uInt marker;        /* if BAD, inflateSync's marker bytes count */
+  } sub;        /* submode */
+
+  /* mode independent information */
+  int  nowrap;          /* flag for no wrapper */
+  uInt wbits;           /* log2(window size)  (8..15, defaults to 15) */
+  inflate_blocks_statef 
+    *blocks;            /* current inflate_blocks state */
+
+};
+
+
+int ZEXPORT inflateReset(z)
+z_streamp z;
+{
+  if (z == Z_NULL || z->state == Z_NULL)
+    return Z_STREAM_ERROR;
+  z->total_in = z->total_out = 0;
+  z->msg = Z_NULL;
+  z->state->mode = z->state->nowrap ? BLOCKS : METHOD;
+  inflate_blocks_reset(z->state->blocks, z, Z_NULL);
+  Tracev((stderr, "inflate: reset\n"));
+  return Z_OK;
+}
+
+
+int ZEXPORT inflateEnd(z)
+z_streamp z;
+{
+  if (z == Z_NULL || z->state == Z_NULL || z->zfree == Z_NULL)
+    return Z_STREAM_ERROR;
+  if (z->state->blocks != Z_NULL)
+    inflate_blocks_free(z->state->blocks, z);
+  ZFREE(z, z->state);
+  z->state = Z_NULL;
+  Tracev((stderr, "inflate: end\n"));
+  return Z_OK;
+}
+
+
+int ZEXPORT inflateInit2_(z, w, version, stream_size)
+z_streamp z;
+int w;
+const char *version;
+int stream_size;
+{
+  if (version == Z_NULL || version[0] != ZLIB_VERSION[0] ||
+      stream_size != sizeof(z_stream))
+      return Z_VERSION_ERROR;
+
+  /* initialize state */
+  if (z == Z_NULL)
+    return Z_STREAM_ERROR;
+  z->msg = Z_NULL;
+  if (z->zalloc == Z_NULL)
+  {
+    z->zalloc = zcalloc;
+    z->opaque = (voidpf)0;
+  }
+  if (z->zfree == Z_NULL) z->zfree = zcfree;
+  if ((z->state = (struct internal_state FAR *)
+       ZALLOC(z,1,sizeof(struct internal_state))) == Z_NULL)
+    return Z_MEM_ERROR;
+  z->state->blocks = Z_NULL;
+
+  /* handle undocumented nowrap option (no zlib header or check) */
+  z->state->nowrap = 0;
+  if (w < 0)
+  {
+    w = - w;
+    z->state->nowrap = 1;
+  }
+
+  /* set window size */
+  if (w < 8 || w > 15)
+  {
+    inflateEnd(z);
+    return Z_STREAM_ERROR;
+  }
+  z->state->wbits = (uInt)w;
+
+  /* create inflate_blocks state */
+  if ((z->state->blocks =
+      inflate_blocks_new(z, z->state->nowrap ? Z_NULL : adler32, (uInt)1 << w))
+      == Z_NULL)
+  {
+    inflateEnd(z);
+    return Z_MEM_ERROR;
+  }
+  Tracev((stderr, "inflate: allocated\n"));
+
+  /* reset state */
+  inflateReset(z);
+  return Z_OK;
+}
+
+
+int ZEXPORT inflateInit_(z, version, stream_size)
+z_streamp z;
+const char *version;
+int stream_size;
+{
+  return inflateInit2_(z, DEF_WBITS, version, stream_size);
+}
+
+
+#define NEEDBYTE {if(z->avail_in==0)return r;r=f;}
+#define NEXTBYTE (z->avail_in--,z->total_in++,*z->next_in++)
+
+int ZEXPORT inflate(z, f)
+z_streamp z;
+int f;
+{
+  int r;
+  uInt b;
+
+  if (z == Z_NULL || z->state == Z_NULL || z->next_in == Z_NULL)
+    return Z_STREAM_ERROR;
+  f = f == Z_FINISH ? Z_BUF_ERROR : Z_OK;
+  r = Z_BUF_ERROR;
+  while (1) switch (z->state->mode)
+  {
+    case METHOD:
+      NEEDBYTE
+      if (((z->state->sub.method = NEXTBYTE) & 0xf) != Z_DEFLATED)
+      {
+        z->state->mode = BAD;
+        z->msg = (char*)"unknown compression method";
+        z->state->sub.marker = 5;       /* can't try inflateSync */
+        break;
+      }
+      if ((z->state->sub.method >> 4) + 8 > z->state->wbits)
+      {
+        z->state->mode = BAD;
+        z->msg = (char*)"invalid window size";
+        z->state->sub.marker = 5;       /* can't try inflateSync */
+        break;
+      }
+      z->state->mode = FLAG;
+    case FLAG:
+      NEEDBYTE
+      b = NEXTBYTE;
+      if (((z->state->sub.method << 8) + b) % 31)
+      {
+        z->state->mode = BAD;
+        z->msg = (char*)"incorrect header check";
+        z->state->sub.marker = 5;       /* can't try inflateSync */
+        break;
+      }
+      Tracev((stderr, "inflate: zlib header ok\n"));
+      if (!(b & PRESET_DICT))
+      {
+        z->state->mode = BLOCKS;
+        break;
+      }
+      z->state->mode = DICT4;
+    case DICT4:
+      NEEDBYTE
+      z->state->sub.check.need = (uLong)NEXTBYTE << 24;
+      z->state->mode = DICT3;
+    case DICT3:
+      NEEDBYTE
+      z->state->sub.check.need += (uLong)NEXTBYTE << 16;
+      z->state->mode = DICT2;
+    case DICT2:
+      NEEDBYTE
+      z->state->sub.check.need += (uLong)NEXTBYTE << 8;
+      z->state->mode = DICT1;
+    case DICT1:
+      NEEDBYTE
+      z->state->sub.check.need += (uLong)NEXTBYTE;
+      z->adler = z->state->sub.check.need;
+      z->state->mode = DICT0;
+      return Z_NEED_DICT;
+    case DICT0:
+      z->state->mode = BAD;
+      z->msg = (char*)"need dictionary";
+      z->state->sub.marker = 0;       /* can try inflateSync */
+      return Z_STREAM_ERROR;
+    case BLOCKS:
+      r = inflate_blocks(z->state->blocks, z, r);
+      if (r == Z_DATA_ERROR)
+      {
+        z->state->mode = BAD;
+        z->state->sub.marker = 0;       /* can try inflateSync */
+        break;
+      }
+      if (r == Z_OK)
+        r = f;
+      if (r != Z_STREAM_END)
+        return r;
+      r = f;
+      inflate_blocks_reset(z->state->blocks, z, &z->state->sub.check.was);
+      if (z->state->nowrap)
+      {
+        z->state->mode = DONE;
+        break;
+      }
+      z->state->mode = CHECK4;
+    case CHECK4:
+      NEEDBYTE
+      z->state->sub.check.need = (uLong)NEXTBYTE << 24;
+      z->state->mode = CHECK3;
+    case CHECK3:
+      NEEDBYTE
+      z->state->sub.check.need += (uLong)NEXTBYTE << 16;
+      z->state->mode = CHECK2;
+    case CHECK2:
+      NEEDBYTE
+      z->state->sub.check.need += (uLong)NEXTBYTE << 8;
+      z->state->mode = CHECK1;
+    case CHECK1:
+      NEEDBYTE
+      z->state->sub.check.need += (uLong)NEXTBYTE;
+
+      if (z->state->sub.check.was != z->state->sub.check.need)
+      {
+        z->state->mode = BAD;
+        z->msg = (char*)"incorrect data check";
+        z->state->sub.marker = 5;       /* can't try inflateSync */
+        break;
+      }
+      Tracev((stderr, "inflate: zlib check ok\n"));
+      z->state->mode = DONE;
+    case DONE:
+      return Z_STREAM_END;
+    case BAD:
+      return Z_DATA_ERROR;
+    default:
+      return Z_STREAM_ERROR;
+  }
+#ifdef NEED_DUMMY_RETURN
+  return Z_STREAM_ERROR;  /* Some dumb compilers complain without this */
+#endif
+}
+
+
+int ZEXPORT inflateSetDictionary(z, dictionary, dictLength)
+z_streamp z;
+const Bytef *dictionary;
+uInt  dictLength;
+{
+  uInt length = dictLength;
+
+  if (z == Z_NULL || z->state == Z_NULL || z->state->mode != DICT0)
+    return Z_STREAM_ERROR;
+
+  if (adler32(1L, dictionary, dictLength) != z->adler) return Z_DATA_ERROR;
+  z->adler = 1L;
+
+  if (length >= ((uInt)1<<z->state->wbits))
+  {
+    length = (1<<z->state->wbits)-1;
+    dictionary += dictLength - length;
+  }
+  inflate_set_dictionary(z->state->blocks, dictionary, length);
+  z->state->mode = BLOCKS;
+  return Z_OK;
+}
+
+
+int ZEXPORT inflateSync(z)
+z_streamp z;
+{
+  uInt n;       /* number of bytes to look at */
+  Bytef *p;     /* pointer to bytes */
+  uInt m;       /* number of marker bytes found in a row */
+  uLong r, w;   /* temporaries to save total_in and total_out */
+
+  /* set up */
+  if (z == Z_NULL || z->state == Z_NULL)
+    return Z_STREAM_ERROR;
+  if (z->state->mode != BAD)
+  {
+    z->state->mode = BAD;
+    z->state->sub.marker = 0;
+  }
+  if ((n = z->avail_in) == 0)
+    return Z_BUF_ERROR;
+  p = z->next_in;
+  m = z->state->sub.marker;
+
+  /* search */
+  while (n && m < 4)
+  {
+    static const Byte mark[4] = {0, 0, 0xff, 0xff};
+    if (*p == mark[m])
+      m++;
+    else if (*p)
+      m = 0;
+    else
+      m = 4 - m;
+    p++, n--;
+  }
+
+  /* restore */
+  z->total_in += p - z->next_in;
+  z->next_in = p;
+  z->avail_in = n;
+  z->state->sub.marker = m;
+
+  /* return no joy or set up to restart on a new block */
+  if (m != 4)
+    return Z_DATA_ERROR;
+  r = z->total_in;  w = z->total_out;
+  inflateReset(z);
+  z->total_in = r;  z->total_out = w;
+  z->state->mode = BLOCKS;
+  return Z_OK;
+}
+
+
+/* Returns true if inflate is currently at the end of a block generated
+ * by Z_SYNC_FLUSH or Z_FULL_FLUSH. This function is used by one PPP
+ * implementation to provide an additional safety check. PPP uses Z_SYNC_FLUSH
+ * but removes the length bytes of the resulting empty stored block. When
+ * decompressing, PPP checks that at the end of input packet, inflate is
+ * waiting for these length bytes.
+ */
+int ZEXPORT inflateSyncPoint(z)
+z_streamp z;
+{
+  if (z == Z_NULL || z->state == Z_NULL || z->state->blocks == Z_NULL)
+    return Z_STREAM_ERROR;
+  return inflate_blocks_sync_point(z->state->blocks);
+}
diff --git a/collects/plot/src/all/inftrees.c b/collects/plot/src/all/inftrees.c
new file mode 100644
index 0000000000..4c32ca30d9
--- /dev/null
+++ b/collects/plot/src/all/inftrees.c
@@ -0,0 +1,454 @@
+/* inftrees.c -- generate Huffman trees for efficient decoding
+ * Copyright (C) 1995-2002 Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h 
+ */
+
+#include "zutil.h"
+#include "inftrees.h"
+
+#if !defined(BUILDFIXED) && !defined(STDC)
+#  define BUILDFIXED   /* non ANSI compilers may not accept inffixed.h */
+#endif
+
+const char inflate_copyright[] =
+   " inflate 1.1.4 Copyright 1995-2002 Mark Adler ";
+/*
+  If you use the zlib library in a product, an acknowledgment is welcome
+  in the documentation of your product. If for some reason you cannot
+  include such an acknowledgment, I would appreciate that you keep this
+  copyright string in the executable of your product.
+ */
+struct internal_state  {int dummy;}; /* for buggy compilers */
+
+/* simplify the use of the inflate_huft type with some defines */
+#define exop word.what.Exop
+#define bits word.what.Bits
+
+
+local int huft_build OF((
+    uIntf *,            /* code lengths in bits */
+    uInt,               /* number of codes */
+    uInt,               /* number of "simple" codes */
+    const uIntf *,      /* list of base values for non-simple codes */
+    const uIntf *,      /* list of extra bits for non-simple codes */
+    inflate_huft * FAR*,/* result: starting table */
+    uIntf *,            /* maximum lookup bits (returns actual) */
+    inflate_huft *,     /* space for trees */
+    uInt *,             /* hufts used in space */
+    uIntf * ));         /* space for values */
+
+/* Tables for deflate from PKZIP's appnote.txt. */
+local const uInt cplens[31] = { /* Copy lengths for literal codes 257..285 */
+        3, 4, 5, 6, 7, 8, 9, 10, 11, 13, 15, 17, 19, 23, 27, 31,
+        35, 43, 51, 59, 67, 83, 99, 115, 131, 163, 195, 227, 258, 0, 0};
+        /* see note #13 above about 258 */
+local const uInt cplext[31] = { /* Extra bits for literal codes 257..285 */
+        0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 2, 2, 2, 2,
+        3, 3, 3, 3, 4, 4, 4, 4, 5, 5, 5, 5, 0, 112, 112}; /* 112==invalid */
+local const uInt cpdist[30] = { /* Copy offsets for distance codes 0..29 */
+        1, 2, 3, 4, 5, 7, 9, 13, 17, 25, 33, 49, 65, 97, 129, 193,
+        257, 385, 513, 769, 1025, 1537, 2049, 3073, 4097, 6145,
+        8193, 12289, 16385, 24577};
+local const uInt cpdext[30] = { /* Extra bits for distance codes */
+        0, 0, 0, 0, 1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, 6,
+        7, 7, 8, 8, 9, 9, 10, 10, 11, 11,
+        12, 12, 13, 13};
+
+/*
+   Huffman code decoding is performed using a multi-level table lookup.
+   The fastest way to decode is to simply build a lookup table whose
+   size is determined by the longest code.  However, the time it takes
+   to build this table can also be a factor if the data being decoded
+   is not very long.  The most common codes are necessarily the
+   shortest codes, so those codes dominate the decoding time, and hence
+   the speed.  The idea is you can have a shorter table that decodes the
+   shorter, more probable codes, and then point to subsidiary tables for
+   the longer codes.  The time it costs to decode the longer codes is
+   then traded against the time it takes to make longer tables.
+
+   This results of this trade are in the variables lbits and dbits
+   below.  lbits is the number of bits the first level table for literal/
+   length codes can decode in one step, and dbits is the same thing for
+   the distance codes.  Subsequent tables are also less than or equal to
+   those sizes.  These values may be adjusted either when all of the
+   codes are shorter than that, in which case the longest code length in
+   bits is used, or when the shortest code is *longer* than the requested
+   table size, in which case the length of the shortest code in bits is
+   used.
+
+   There are two different values for the two tables, since they code a
+   different number of possibilities each.  The literal/length table
+   codes 286 possible values, or in a flat code, a little over eight
+   bits.  The distance table codes 30 possible values, or a little less
+   than five bits, flat.  The optimum values for speed end up being
+   about one bit more than those, so lbits is 8+1 and dbits is 5+1.
+   The optimum values may differ though from machine to machine, and
+   possibly even between compilers.  Your mileage may vary.
+ */
+
+
+/* If BMAX needs to be larger than 16, then h and x[] should be uLong. */
+#define BMAX 15         /* maximum bit length of any code */
+
+local int huft_build(b, n, s, d, e, t, m, hp, hn, v)
+uIntf *b;               /* code lengths in bits (all assumed <= BMAX) */
+uInt n;                 /* number of codes (assumed <= 288) */
+uInt s;                 /* number of simple-valued codes (0..s-1) */
+const uIntf *d;         /* list of base values for non-simple codes */
+const uIntf *e;         /* list of extra bits for non-simple codes */
+inflate_huft * FAR *t;  /* result: starting table */
+uIntf *m;               /* maximum lookup bits, returns actual */
+inflate_huft *hp;       /* space for trees */
+uInt *hn;               /* hufts used in space */
+uIntf *v;               /* working area: values in order of bit length */
+/* Given a list of code lengths and a maximum table size, make a set of
+   tables to decode that set of codes.  Return Z_OK on success, Z_BUF_ERROR
+   if the given code set is incomplete (the tables are still built in this
+   case), or Z_DATA_ERROR if the input is invalid. */
+{
+
+  uInt a;                       /* counter for codes of length k */
+  uInt c[BMAX+1];               /* bit length count table */
+  uInt f;                       /* i repeats in table every f entries */
+  int g;                        /* maximum code length */
+  int h;                        /* table level */
+  register uInt i;              /* counter, current code */
+  register uInt j;              /* counter */
+  register int k;               /* number of bits in current code */
+  int l;                        /* bits per table (returned in m) */
+  uInt mask;                    /* (1 << w) - 1, to avoid cc -O bug on HP */
+  register uIntf *p;            /* pointer into c[], b[], or v[] */
+  inflate_huft *q;              /* points to current table */
+  struct inflate_huft_s r;      /* table entry for structure assignment */
+  inflate_huft *u[BMAX];        /* table stack */
+  register int w;               /* bits before this table == (l * h) */
+  uInt x[BMAX+1];               /* bit offsets, then code stack */
+  uIntf *xp;                    /* pointer into x */
+  int y;                        /* number of dummy codes added */
+  uInt z;                       /* number of entries in current table */
+
+
+  /* Generate counts for each bit length */
+  p = c;
+#define C0 *p++ = 0;
+#define C2 C0 C0 C0 C0
+#define C4 C2 C2 C2 C2
+  C4                            /* clear c[]--assume BMAX+1 is 16 */
+  p = b;  i = n;
+  do {
+    c[*p++]++;                  /* assume all entries <= BMAX */
+  } while (--i);
+  if (c[0] == n)                /* null input--all zero length codes */
+  {
+    *t = (inflate_huft *)Z_NULL;
+    *m = 0;
+    return Z_OK;
+  }
+
+
+  /* Find minimum and maximum length, bound *m by those */
+  l = *m;
+  for (j = 1; j <= BMAX; j++)
+    if (c[j])
+      break;
+  k = j;                        /* minimum code length */
+  if ((uInt)l < j)
+    l = j;
+  for (i = BMAX; i; i--)
+    if (c[i])
+      break;
+  g = i;                        /* maximum code length */
+  if ((uInt)l > i)
+    l = i;
+  *m = l;
+
+
+  /* Adjust last length count to fill out codes, if needed */
+  for (y = 1 << j; j < i; j++, y <<= 1)
+    if ((y -= c[j]) < 0)
+      return Z_DATA_ERROR;
+  if ((y -= c[i]) < 0)
+    return Z_DATA_ERROR;
+  c[i] += y;
+
+
+  /* Generate starting offsets into the value table for each length */
+  x[1] = j = 0;
+  p = c + 1;  xp = x + 2;
+  while (--i) {                 /* note that i == g from above */
+    *xp++ = (j += *p++);
+  }
+
+
+  /* Make a table of values in order of bit lengths */
+  p = b;  i = 0;
+  do {
+    if ((j = *p++) != 0)
+      v[x[j]++] = i;
+  } while (++i < n);
+  n = x[g];                     /* set n to length of v */
+
+
+  /* Generate the Huffman codes and for each, make the table entries */
+  x[0] = i = 0;                 /* first Huffman code is zero */
+  p = v;                        /* grab values in bit order */
+  h = -1;                       /* no tables yet--level -1 */
+  w = -l;                       /* bits decoded == (l * h) */
+  u[0] = (inflate_huft *)Z_NULL;        /* just to keep compilers happy */
+  q = (inflate_huft *)Z_NULL;   /* ditto */
+  z = 0;                        /* ditto */
+
+  /* go through the bit lengths (k already is bits in shortest code) */
+  for (; k <= g; k++)
+  {
+    a = c[k];
+    while (a--)
+    {
+      /* here i is the Huffman code of length k bits for value *p */
+      /* make tables up to required level */
+      while (k > w + l)
+      {
+        h++;
+        w += l;                 /* previous table always l bits */
+
+        /* compute minimum size table less than or equal to l bits */
+        z = g - w;
+        z = z > (uInt)l ? l : z;        /* table size upper limit */
+        if ((f = 1 << (j = k - w)) > a + 1)     /* try a k-w bit table */
+        {                       /* too few codes for k-w bit table */
+          f -= a + 1;           /* deduct codes from patterns left */
+          xp = c + k;
+          if (j < z)
+            while (++j < z)     /* try smaller tables up to z bits */
+            {
+              if ((f <<= 1) <= *++xp)
+                break;          /* enough codes to use up j bits */
+              f -= *xp;         /* else deduct codes from patterns */
+            }
+        }
+        z = 1 << j;             /* table entries for j-bit table */
+
+        /* allocate new table */
+        if (*hn + z > MANY)     /* (note: doesn't matter for fixed) */
+          return Z_DATA_ERROR;  /* overflow of MANY */
+        u[h] = q = hp + *hn;
+        *hn += z;
+
+        /* connect to last table, if there is one */
+        if (h)
+        {
+          x[h] = i;             /* save pattern for backing up */
+          r.bits = (Byte)l;     /* bits to dump before this table */
+          r.exop = (Byte)j;     /* bits in this table */
+          j = i >> (w - l);
+          r.base = (uInt)(q - u[h-1] - j);   /* offset to this table */
+          u[h-1][j] = r;        /* connect to last table */
+        }
+        else
+          *t = q;               /* first table is returned result */
+      }
+
+      /* set up table entry in r */
+      r.bits = (Byte)(k - w);
+      if (p >= v + n)
+        r.exop = 128 + 64;      /* out of values--invalid code */
+      else if (*p < s)
+      {
+        r.exop = (Byte)(*p < 256 ? 0 : 32 + 64);     /* 256 is end-of-block */
+        r.base = *p++;          /* simple code is just the value */
+      }
+      else
+      {
+        r.exop = (Byte)(e[*p - s] + 16 + 64);/* non-simple--look up in lists */
+        r.base = d[*p++ - s];
+      }
+
+      /* fill code-like entries with r */
+      f = 1 << (k - w);
+      for (j = i >> w; j < z; j += f)
+        q[j] = r;
+
+      /* backwards increment the k-bit code i */
+      for (j = 1 << (k - 1); i & j; j >>= 1)
+        i ^= j;
+      i ^= j;
+
+      /* backup over finished tables */
+      mask = (1 << w) - 1;      /* needed on HP, cc -O bug */
+      while ((i & mask) != x[h])
+      {
+        h--;                    /* don't need to update q */
+        w -= l;
+        mask = (1 << w) - 1;
+      }
+    }
+  }
+
+
+  /* Return Z_BUF_ERROR if we were given an incomplete table */
+  return y != 0 && g != 1 ? Z_BUF_ERROR : Z_OK;
+}
+
+
+int inflate_trees_bits(c, bb, tb, hp, z)
+uIntf *c;               /* 19 code lengths */
+uIntf *bb;              /* bits tree desired/actual depth */
+inflate_huft * FAR *tb; /* bits tree result */
+inflate_huft *hp;       /* space for trees */
+z_streamp z;            /* for messages */
+{
+  int r;
+  uInt hn = 0;          /* hufts used in space */
+  uIntf *v;             /* work area for huft_build */
+
+  if ((v = (uIntf*)ZALLOC(z, 19, sizeof(uInt))) == Z_NULL)
+    return Z_MEM_ERROR;
+  r = huft_build(c, 19, 19, (uIntf*)Z_NULL, (uIntf*)Z_NULL,
+                 tb, bb, hp, &hn, v);
+  if (r == Z_DATA_ERROR)
+    z->msg = (char*)"oversubscribed dynamic bit lengths tree";
+  else if (r == Z_BUF_ERROR || *bb == 0)
+  {
+    z->msg = (char*)"incomplete dynamic bit lengths tree";
+    r = Z_DATA_ERROR;
+  }
+  ZFREE(z, v);
+  return r;
+}
+
+
+int inflate_trees_dynamic(nl, nd, c, bl, bd, tl, td, hp, z)
+uInt nl;                /* number of literal/length codes */
+uInt nd;                /* number of distance codes */
+uIntf *c;               /* that many (total) code lengths */
+uIntf *bl;              /* literal desired/actual bit depth */
+uIntf *bd;              /* distance desired/actual bit depth */
+inflate_huft * FAR *tl; /* literal/length tree result */
+inflate_huft * FAR *td; /* distance tree result */
+inflate_huft *hp;       /* space for trees */
+z_streamp z;            /* for messages */
+{
+  int r;
+  uInt hn = 0;          /* hufts used in space */
+  uIntf *v;             /* work area for huft_build */
+
+  /* allocate work area */
+  if ((v = (uIntf*)ZALLOC(z, 288, sizeof(uInt))) == Z_NULL)
+    return Z_MEM_ERROR;
+
+  /* build literal/length tree */
+  r = huft_build(c, nl, 257, cplens, cplext, tl, bl, hp, &hn, v);
+  if (r != Z_OK || *bl == 0)
+  {
+    if (r == Z_DATA_ERROR)
+      z->msg = (char*)"oversubscribed literal/length tree";
+    else if (r != Z_MEM_ERROR)
+    {
+      z->msg = (char*)"incomplete literal/length tree";
+      r = Z_DATA_ERROR;
+    }
+    ZFREE(z, v);
+    return r;
+  }
+
+  /* build distance tree */
+  r = huft_build(c + nl, nd, 0, cpdist, cpdext, td, bd, hp, &hn, v);
+  if (r != Z_OK || (*bd == 0 && nl > 257))
+  {
+    if (r == Z_DATA_ERROR)
+      z->msg = (char*)"oversubscribed distance tree";
+    else if (r == Z_BUF_ERROR) {
+#ifdef PKZIP_BUG_WORKAROUND
+      r = Z_OK;
+    }
+#else
+      z->msg = (char*)"incomplete distance tree";
+      r = Z_DATA_ERROR;
+    }
+    else if (r != Z_MEM_ERROR)
+    {
+      z->msg = (char*)"empty distance tree with lengths";
+      r = Z_DATA_ERROR;
+    }
+    ZFREE(z, v);
+    return r;
+#endif
+  }
+
+  /* done */
+  ZFREE(z, v);
+  return Z_OK;
+}
+
+
+/* build fixed tables only once--keep them here */
+#ifdef BUILDFIXED
+local int fixed_built = 0;
+#define FIXEDH 544      /* number of hufts used by fixed tables */
+local inflate_huft fixed_mem[FIXEDH];
+local uInt fixed_bl;
+local uInt fixed_bd;
+local inflate_huft *fixed_tl;
+local inflate_huft *fixed_td;
+#else
+#include "inffixed.h"
+#endif
+
+
+int inflate_trees_fixed(bl, bd, tl, td, z)
+uIntf *bl;               /* literal desired/actual bit depth */
+uIntf *bd;               /* distance desired/actual bit depth */
+inflate_huft * FAR *tl;  /* literal/length tree result */
+inflate_huft * FAR *td;  /* distance tree result */
+z_streamp z;             /* for memory allocation */
+{
+#ifdef BUILDFIXED
+  /* build fixed tables if not already */
+  if (!fixed_built)
+  {
+    int k;              /* temporary variable */
+    uInt f = 0;         /* number of hufts used in fixed_mem */
+    uIntf *c;           /* length list for huft_build */
+    uIntf *v;           /* work area for huft_build */
+
+    /* allocate memory */
+    if ((c = (uIntf*)ZALLOC(z, 288, sizeof(uInt))) == Z_NULL)
+      return Z_MEM_ERROR;
+    if ((v = (uIntf*)ZALLOC(z, 288, sizeof(uInt))) == Z_NULL)
+    {
+      ZFREE(z, c);
+      return Z_MEM_ERROR;
+    }
+
+    /* literal table */
+    for (k = 0; k < 144; k++)
+      c[k] = 8;
+    for (; k < 256; k++)
+      c[k] = 9;
+    for (; k < 280; k++)
+      c[k] = 7;
+    for (; k < 288; k++)
+      c[k] = 8;
+    fixed_bl = 9;
+    huft_build(c, 288, 257, cplens, cplext, &fixed_tl, &fixed_bl,
+               fixed_mem, &f, v);
+
+    /* distance table */
+    for (k = 0; k < 30; k++)
+      c[k] = 5;
+    fixed_bd = 5;
+    huft_build(c, 30, 0, cpdist, cpdext, &fixed_td, &fixed_bd,
+               fixed_mem, &f, v);
+
+    /* done */
+    ZFREE(z, v);
+    ZFREE(z, c);
+    fixed_built = 1;
+  }
+#endif
+  *bl = fixed_bl;
+  *bd = fixed_bd;
+  *tl = fixed_tl;
+  *td = fixed_td;
+  return Z_OK;
+}
diff --git a/collects/plot/src/all/inftrees.h b/collects/plot/src/all/inftrees.h
new file mode 100644
index 0000000000..04b73b7296
--- /dev/null
+++ b/collects/plot/src/all/inftrees.h
@@ -0,0 +1,58 @@
+/* inftrees.h -- header to use inftrees.c
+ * Copyright (C) 1995-2002 Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h 
+ */
+
+/* WARNING: this file should *not* be used by applications. It is
+   part of the implementation of the compression library and is
+   subject to change. Applications should only use zlib.h.
+ */
+
+/* Huffman code lookup table entry--this entry is four bytes for machines
+   that have 16-bit pointers (e.g. PC's in the small or medium model). */
+
+typedef struct inflate_huft_s FAR inflate_huft;
+
+struct inflate_huft_s {
+  union {
+    struct {
+      Byte Exop;        /* number of extra bits or operation */
+      Byte Bits;        /* number of bits in this code or subcode */
+    } what;
+    uInt pad;           /* pad structure to a power of 2 (4 bytes for */
+  } word;               /*  16-bit, 8 bytes for 32-bit int's) */
+  uInt base;            /* literal, length base, distance base,
+                           or table offset */
+};
+
+/* Maximum size of dynamic tree.  The maximum found in a long but non-
+   exhaustive search was 1004 huft structures (850 for length/literals
+   and 154 for distances, the latter actually the result of an
+   exhaustive search).  The actual maximum is not known, but the
+   value below is more than safe. */
+#define MANY 1440
+
+extern int inflate_trees_bits OF((
+    uIntf *,                    /* 19 code lengths */
+    uIntf *,                    /* bits tree desired/actual depth */
+    inflate_huft * FAR *,       /* bits tree result */
+    inflate_huft *,             /* space for trees */
+    z_streamp));                /* for messages */
+
+extern int inflate_trees_dynamic OF((
+    uInt,                       /* number of literal/length codes */
+    uInt,                       /* number of distance codes */
+    uIntf *,                    /* that many (total) code lengths */
+    uIntf *,                    /* literal desired/actual bit depth */
+    uIntf *,                    /* distance desired/actual bit depth */
+    inflate_huft * FAR *,       /* literal/length tree result */
+    inflate_huft * FAR *,       /* distance tree result */
+    inflate_huft *,             /* space for trees */
+    z_streamp));                /* for messages */
+
+extern int inflate_trees_fixed OF((
+    uIntf *,                    /* literal desired/actual bit depth */
+    uIntf *,                    /* distance desired/actual bit depth */
+    inflate_huft * FAR *,       /* literal/length tree result */
+    inflate_huft * FAR *,       /* distance tree result */
+    z_streamp));                /* for memory allocation */
diff --git a/collects/plot/src/all/infutil.c b/collects/plot/src/all/infutil.c
new file mode 100644
index 0000000000..9a076221f2
--- /dev/null
+++ b/collects/plot/src/all/infutil.c
@@ -0,0 +1,87 @@
+/* inflate_util.c -- data and routines common to blocks and codes
+ * Copyright (C) 1995-2002 Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h 
+ */
+
+#include "zutil.h"
+#include "infblock.h"
+#include "inftrees.h"
+#include "infcodes.h"
+#include "infutil.h"
+
+struct inflate_codes_state {int dummy;}; /* for buggy compilers */
+
+/* And'ing with mask[n] masks the lower n bits */
+uInt inflate_mask[17] = {
+    0x0000,
+    0x0001, 0x0003, 0x0007, 0x000f, 0x001f, 0x003f, 0x007f, 0x00ff,
+    0x01ff, 0x03ff, 0x07ff, 0x0fff, 0x1fff, 0x3fff, 0x7fff, 0xffff
+};
+
+
+/* copy as much as possible from the sliding window to the output area */
+int inflate_flush(s, z, r)
+inflate_blocks_statef *s;
+z_streamp z;
+int r;
+{
+  uInt n;
+  Bytef *p;
+  Bytef *q;
+
+  /* local copies of source and destination pointers */
+  p = z->next_out;
+  q = s->read;
+
+  /* compute number of bytes to copy as far as end of window */
+  n = (uInt)((q <= s->write ? s->write : s->end) - q);
+  if (n > z->avail_out) n = z->avail_out;
+  if (n && r == Z_BUF_ERROR) r = Z_OK;
+
+  /* update counters */
+  z->avail_out -= n;
+  z->total_out += n;
+
+  /* update check information */
+  if (s->checkfn != Z_NULL)
+    z->adler = s->check = (*s->checkfn)(s->check, q, n);
+
+  /* copy as far as end of window */
+  zmemcpy(p, q, n);
+  p += n;
+  q += n;
+
+  /* see if more to copy at beginning of window */
+  if (q == s->end)
+  {
+    /* wrap pointers */
+    q = s->window;
+    if (s->write == s->end)
+      s->write = s->window;
+
+    /* compute bytes to copy */
+    n = (uInt)(s->write - q);
+    if (n > z->avail_out) n = z->avail_out;
+    if (n && r == Z_BUF_ERROR) r = Z_OK;
+
+    /* update counters */
+    z->avail_out -= n;
+    z->total_out += n;
+
+    /* update check information */
+    if (s->checkfn != Z_NULL)
+      z->adler = s->check = (*s->checkfn)(s->check, q, n);
+
+    /* copy */
+    zmemcpy(p, q, n);
+    p += n;
+    q += n;
+  }
+
+  /* update pointers */
+  z->next_out = p;
+  s->read = q;
+
+  /* done */
+  return r;
+}
diff --git a/collects/plot/src/all/infutil.h b/collects/plot/src/all/infutil.h
new file mode 100644
index 0000000000..4401df82fc
--- /dev/null
+++ b/collects/plot/src/all/infutil.h
@@ -0,0 +1,98 @@
+/* infutil.h -- types and macros common to blocks and codes
+ * Copyright (C) 1995-2002 Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h 
+ */
+
+/* WARNING: this file should *not* be used by applications. It is
+   part of the implementation of the compression library and is
+   subject to change. Applications should only use zlib.h.
+ */
+
+#ifndef _INFUTIL_H
+#define _INFUTIL_H
+
+typedef enum {
+      TYPE,     /* get type bits (3, including end bit) */
+      LENS,     /* get lengths for stored */
+      STORED,   /* processing stored block */
+      TABLE,    /* get table lengths */
+      BTREE,    /* get bit lengths tree for a dynamic block */
+      DTREE,    /* get length, distance trees for a dynamic block */
+      CODES,    /* processing fixed or dynamic block */
+      DRY,      /* output remaining window bytes */
+      DONE,     /* finished last block, done */
+      BAD}      /* got a data error--stuck here */
+inflate_block_mode;
+
+/* inflate blocks semi-private state */
+struct inflate_blocks_state {
+
+  /* mode */
+  inflate_block_mode  mode;     /* current inflate_block mode */
+
+  /* mode dependent information */
+  union {
+    uInt left;          /* if STORED, bytes left to copy */
+    struct {
+      uInt table;               /* table lengths (14 bits) */
+      uInt index;               /* index into blens (or border) */
+      uIntf *blens;             /* bit lengths of codes */
+      uInt bb;                  /* bit length tree depth */
+      inflate_huft *tb;         /* bit length decoding tree */
+    } trees;            /* if DTREE, decoding info for trees */
+    struct {
+      inflate_codes_statef 
+         *codes;
+    } decode;           /* if CODES, current state */
+  } sub;                /* submode */
+  uInt last;            /* true if this block is the last block */
+
+  /* mode independent information */
+  uInt bitk;            /* bits in bit buffer */
+  uLong bitb;           /* bit buffer */
+  inflate_huft *hufts;  /* single malloc for tree space */
+  Bytef *window;        /* sliding window */
+  Bytef *end;           /* one byte after sliding window */
+  Bytef *read;          /* window read pointer */
+  Bytef *write;         /* window write pointer */
+  check_func checkfn;   /* check function */
+  uLong check;          /* check on output */
+
+};
+
+
+/* defines for inflate input/output */
+/*   update pointers and return */
+#define UPDBITS {s->bitb=b;s->bitk=k;}
+#define UPDIN {z->avail_in=n;z->total_in+=p-z->next_in;z->next_in=p;}
+#define UPDOUT {s->write=q;}
+#define UPDATE {UPDBITS UPDIN UPDOUT}
+#define LEAVE {UPDATE return inflate_flush(s,z,r);}
+/*   get bytes and bits */
+#define LOADIN {p=z->next_in;n=z->avail_in;b=s->bitb;k=s->bitk;}
+#define NEEDBYTE {if(n)r=Z_OK;else LEAVE}
+#define NEXTBYTE (n--,*p++)
+#define NEEDBITS(j) {while(k<(j)){NEEDBYTE;b|=((uLong)NEXTBYTE)<<k;k+=8;}}
+#define DUMPBITS(j) {b>>=(j);k-=(j);}
+/*   output bytes */
+#define WAVAIL (uInt)(q<s->read?s->read-q-1:s->end-q)
+#define LOADOUT {q=s->write;m=(uInt)WAVAIL;}
+#define WRAP {if(q==s->end&&s->read!=s->window){q=s->window;m=(uInt)WAVAIL;}}
+#define FLUSH {UPDOUT r=inflate_flush(s,z,r); LOADOUT}
+#define NEEDOUT {if(m==0){WRAP if(m==0){FLUSH WRAP if(m==0) LEAVE}}r=Z_OK;}
+#define OUTBYTE(a) {*q++=(Byte)(a);m--;}
+/*   load local pointers */
+#define LOAD {LOADIN LOADOUT}
+
+/* masks for lower bits (size given to avoid silly warnings with Visual C++) */
+extern uInt inflate_mask[17];
+
+/* copy as much as possible from the sliding window to the output area */
+extern int inflate_flush OF((
+    inflate_blocks_statef *,
+    z_streamp ,
+    int));
+
+struct internal_state      {int dummy;}; /* for buggy compilers */
+
+#endif
diff --git a/collects/plot/src/all/jisx0208.h b/collects/plot/src/all/jisx0208.h
new file mode 100644
index 0000000000..4ddce67f80
--- /dev/null
+++ b/collects/plot/src/all/jisx0208.h
@@ -0,0 +1,1206 @@
+#ifndef JISX0208_H
+#define JISX0208_H
+/* This file was derived from "src/VF_Ftype.c" in VFlib2-2.24.2
+   by Dr. Kakugawa */
+
+/* JIS -> Unicode mapping table */
+static unsigned short UnicodeTbl[][94] = {
+  {				/* category 01 */
+   0x0000, 0x3001, 0x3002, 0xFF0C, 0xFF0E, 0x30FB, 0xFF1A, 0xFF1B,
+   0xFF1F, 0xFF01, 0x309B, 0x309C, 0x00B4, 0xFF40, 0x00A8, 0xFF3E,
+   0xFFE3, 0xFF3F, 0x30FD, 0x30FE, 0x309D, 0x309E, 0x3003, 0x4EDD,
+   0x3005, 0x3006, 0x3007, 0x30FC, 0x2015, 0x2010, 0xFF0F, 0xFF3C,
+   0xFF5E, 0x2225, 0xFF5C, 0x2026, 0x2025, 0x2018, 0x2019, 0x201C,
+   0x201D, 0xFF08, 0xFF09, 0x3014, 0x3015, 0xFF3B, 0xFF3D, 0xFF5B,
+   0xFF5D, 0x3008, 0x3009, 0x300A, 0x300B, 0x300C, 0x300D, 0x300E,
+   0x300F, 0x3010, 0x3011, 0xFF0B, 0xFF0D, 0x00B1, 0x00D7, 0x00F7,
+   0xFF1D, 0x2260, 0xFF1C, 0xFF1E, 0x2266, 0x2267, 0x221E, 0x2234,
+   0x2642, 0x2640, 0x00B0, 0x2032, 0x2033, 0x2103, 0xFFE5, 0xFF04,
+   0xFFE0, 0xFFE1, 0xFF05, 0xFF03, 0xFF06, 0xFF0A, 0xFF20, 0x00A7,
+   0x2606, 0x2605, 0x25CB, 0x25CF, 0x25CE, 0x25C7},
+  {				/* category 02 */
+   0x25C6, 0x25A1, 0x25A0, 0x25B3, 0x25B2, 0x25BD, 0x25BC, 0x203B,
+   0x3012, 0x2192, 0x2190, 0x2191, 0x2193, 0x3013, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x2208, 0x220B, 0x2286, 0x2287, 0x2282, 0x2283, 0x222A,
+   0x2229, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x2227, 0x2228, 0xFFE2, 0x21D2, 0x21D4, 0x2200, 0x2203,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x2220, 0x22A5, 0x2312, 0x2202, 0x2207,
+   0x2261, 0x2252, 0x226A, 0x226B, 0x221A, 0x223D, 0x221D, 0x2235,
+   0x222B, 0x222C, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x212B, 0x2030, 0x266F, 0x266D, 0x266A, 0x2020, 0x2021, /**/
+   0x00B6, 0x0000, 0x0000, 0x0000, 0x0000, 0x25EF},
+  {				/* category 03 */
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0xFF10,
+   0xFF11, 0xFF12, 0xFF13, 0xFF14, 0xFF15, 0xFF16, 0xFF17, 0xFF18,
+   0xFF19, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0xFF21, 0xFF22, 0xFF23, 0xFF24, 0xFF25, 0xFF26, 0xFF27, 0xFF28,
+   0xFF29, 0xFF2A, 0xFF2B, 0xFF2C, 0xFF2D, 0xFF2E, 0xFF2F, 0xFF30,
+   0xFF31, 0xFF32, 0xFF33, 0xFF34, 0xFF35, 0xFF36, 0xFF37, 0xFF38,
+   0xFF39, 0xFF3A, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0xFF41, 0xFF42, 0xFF43, 0xFF44, 0xFF45, 0xFF46, 0xFF47, 0xFF48,
+   0xFF49, 0xFF4A, 0xFF4B, 0xFF4C, 0xFF4D, 0xFF4E, 0xFF4F, 0xFF50,
+   0xFF51, 0xFF52, 0xFF53, 0xFF54, 0xFF55, 0xFF56, 0xFF57, 0xFF58,
+   0xFF59, 0xFF5A, 0x0000, 0x0000, 0x0000, 0x0000},
+  {				/* category 04 */
+   0x3041, 0x3042, 0x3043, 0x3044, 0x3045, 0x3046, 0x3047, 0x3048,
+   0x3049, 0x304A, 0x304B, 0x304C, 0x304D, 0x304E, 0x304F, 0x3050,
+   0x3051, 0x3052, 0x3053, 0x3054, 0x3055, 0x3056, 0x3057, 0x3058,
+   0x3059, 0x305A, 0x305B, 0x305C, 0x305D, 0x305E, 0x305F, 0x3060,
+   0x3061, 0x3062, 0x3063, 0x3064, 0x3065, 0x3066, 0x3067, 0x3068,
+   0x3069, 0x306A, 0x306B, 0x306C, 0x306D, 0x306E, 0x306F, 0x3070,
+   0x3071, 0x3072, 0x3073, 0x3074, 0x3075, 0x3076, 0x3077, 0x3078,
+   0x3079, 0x307A, 0x307B, 0x307C, 0x307D, 0x307E, 0x307F, 0x3080,
+   0x3081, 0x3082, 0x3083, 0x3084, 0x3085, 0x3086, 0x3087, 0x3088,
+   0x3089, 0x308A, 0x308B, 0x308C, 0x308D, 0x308E, 0x308F, 0x3090,
+   0x3091, 0x3092, 0x3093, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000},
+  {				/* category 05 */
+   0x30A1, 0x30A2, 0x30A3, 0x30A4, 0x30A5, 0x30A6, 0x30A7, 0x30A8,
+   0x30A9, 0x30AA, 0x30AB, 0x30AC, 0x30AD, 0x30AE, 0x30AF, 0x30B0,
+   0x30B1, 0x30B2, 0x30B3, 0x30B4, 0x30B5, 0x30B6, 0x30B7, 0x30B8,
+   0x30B9, 0x30BA, 0x30BB, 0x30BC, 0x30BD, 0x30BE, 0x30BF, 0x30C0,
+   0x30C1, 0x30C2, 0x30C3, 0x30C4, 0x30C5, 0x30C6, 0x30C7, 0x30C8,
+   0x30C9, 0x30CA, 0x30CB, 0x30CC, 0x30CD, 0x30CE, 0x30CF, 0x30D0,
+   0x30D1, 0x30D2, 0x30D3, 0x30D4, 0x30D5, 0x30D6, 0x30D7, 0x30D8,
+   0x30D9, 0x30DA, 0x30DB, 0x30DC, 0x30DD, 0x30DE, 0x30DF, 0x30E0,
+   0x30E1, 0x30E2, 0x30E3, 0x30E4, 0x30E5, 0x30E6, 0x30E7, 0x30E8,
+   0x30E9, 0x30EA, 0x30EB, 0x30EC, 0x30ED, 0x30EE, 0x30EF, 0x30F0,
+   0x30F1, 0x30F2, 0x30F3, 0x30F4, 0x30F5, 0x30F6, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000},
+  {				/* category 06 */
+   0x0391, 0x0392, 0x0393, 0x0394, 0x0395, 0x0396, 0x0397, 0x0398,
+   0x0399, 0x039A, 0x039B, 0x039C, 0x039D, 0x039E, 0x039F, 0x03A0,
+   0x03A1, 0x03A3, 0x03A4, 0x03A5, 0x03A6, 0x03A7, 0x03A8, 0x03A9,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x03B1, 0x03B2, 0x03B3, 0x03B4, 0x03B5, 0x03B6, 0x03B7, 0x03B8,
+   0x03B9, 0x03BA, 0x03BB, 0x03BC, 0x03BD, 0x03BE, 0x03BF, 0x03C0,
+   0x03C1, 0x03C3, 0x03C4, 0x03C5, 0x03C6, 0x03C7, 0x03C8, 0x03C9,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000},
+  {				/* category 07 */
+   0x0410, 0x0411, 0x0412, 0x0413, 0x0414, 0x0415, 0x0401, 0x0416,
+   0x0417, 0x0418, 0x0419, 0x041A, 0x041B, 0x041C, 0x041D, 0x041E,
+   0x041F, 0x0420, 0x0421, 0x0422, 0x0423, 0x0424, 0x0425, 0x0426,
+   0x0427, 0x0428, 0x0429, 0x042A, 0x042B, 0x042C, 0x042D, 0x042E,
+   0x042F, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0430, 0x0431, 0x0432, 0x0433, 0x0434, 0x0435, 0x0451, 0x0436,
+   0x0437, 0x0438, 0x0439, 0x043A, 0x043B, 0x043C, 0x043D, 0x043E,
+   0x043F, 0x0440, 0x0441, 0x0442, 0x0443, 0x0444, 0x0445, 0x0446,
+   0x0447, 0x0448, 0x0449, 0x044A, 0x044B, 0x044C, 0x044D, 0x044E,
+   0x044F, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000},
+  {				/* category 08 */
+   0x2500, 0x2502, 0x250C, 0x2510, 0x2518, 0x2514, 0x251C, 0x252C,
+   0x2524, 0x2534, 0x253C, 0x2501, 0x2503, 0x250F, 0x2513, 0x251B,
+   0x2517, 0x2523, 0x2533, 0x252B, 0x253B, 0x254B, 0x2520, 0x252F,
+   0x2528, 0x2537, 0x253F, 0x251D, 0x2530, 0x2525, 0x2538, 0x2542,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000},
+  {				/* category 09 */
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000},
+  {				/* category 10 */
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000},
+  {				/* category 11 */
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000},
+  {				/* category 12 */
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000},
+  {				/* category 13 */
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000},
+  {				/* category 14 */
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000},
+  {				/* category 15 */
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000},
+  {				/* category 16 */
+   0x4E9C, 0x5516, 0x5A03, 0x963F, 0x54C0, 0x611B, 0x6328, 0x59F6,
+   0x9022, 0x8475, 0x831C, 0x7A50, 0x60AA, 0x63E1, 0x6E25, 0x65ED,
+   0x8466, 0x82A6, 0x9BF5, 0x6893, 0x5727, 0x65A1, 0x6271, 0x5B9B,
+   0x59D0, 0x867B, 0x98F4, 0x7D62, 0x7DBE, 0x9B8E, 0x6216, 0x7C9F,
+   0x88B7, 0x5B89, 0x5EB5, 0x6309, 0x6697, 0x6848, 0x95C7, 0x978D,
+   0x674F, 0x4EE5, 0x4F0A, 0x4F4D, 0x4F9D, 0x5049, 0x56F2, 0x5937,
+   0x59D4, 0x5A01, 0x5C09, 0x60DF, 0x610F, 0x6170, 0x6613, 0x6905,
+   0x70BA, 0x754F, 0x7570, 0x79FB, 0x7DAD, 0x7DEF, 0x80C3, 0x840E,
+   0x8863, 0x8B02, 0x9055, 0x907A, 0x533B, 0x4E95, 0x4EA5, 0x57DF,
+   0x80B2, 0x90C1, 0x78EF, 0x4E00, 0x58F1, 0x6EA2, 0x9038, 0x7A32,
+   0x8328, 0x828B, 0x9C2F, 0x5141, 0x5370, 0x54BD, 0x54E1, 0x56E0,
+   0x59FB, 0x5F15, 0x98F2, 0x6DEB, 0x80E4, 0x852D},
+  {				/* category 17 */
+   0x9662, 0x9670, 0x96A0, 0x97FB, 0x540B, 0x53F3, 0x5B87, 0x70CF,
+   0x7FBD, 0x8FC2, 0x96E8, 0x536F, 0x9D5C, 0x7ABA, 0x4E11, 0x7893,
+   0x81FC, 0x6E26, 0x5618, 0x5504, 0x6B1D, 0x851A, 0x9C3B, 0x59E5,
+   0x53A9, 0x6D66, 0x74DC, 0x958F, 0x5642, 0x4E91, 0x904B, 0x96F2,
+   0x834F, 0x990C, 0x53E1, 0x55B6, 0x5B30, 0x5F71, 0x6620, 0x66F3,
+   0x6804, 0x6C38, 0x6CF3, 0x6D29, 0x745B, 0x76C8, 0x7A4E, 0x9834,
+   0x82F1, 0x885B, 0x8A60, 0x92ED, 0x6DB2, 0x75AB, 0x76CA, 0x99C5,
+   0x60A6, 0x8B01, 0x8D8A, 0x95B2, 0x698E, 0x53AD, 0x5186, 0x5712,
+   0x5830, 0x5944, 0x5BB4, 0x5EF6, 0x6028, 0x63A9, 0x63F4, 0x6CBF,
+   0x6F14, 0x708E, 0x7114, 0x7159, 0x71D5, 0x733F, 0x7E01, 0x8276,
+   0x82D1, 0x8597, 0x9060, 0x925B, 0x9D1B, 0x5869, 0x65BC, 0x6C5A,
+   0x7525, 0x51F9, 0x592E, 0x5965, 0x5F80, 0x5FDC},
+  {				/* category 18 */
+   0x62BC, 0x65FA, 0x6A2A, 0x6B27, 0x6BB4, 0x738B, 0x7FC1, 0x8956,
+   0x9D2C, 0x9D0E, 0x9EC4, 0x5CA1, 0x6C96, 0x837B, 0x5104, 0x5C4B,
+   0x61B6, 0x81C6, 0x6876, 0x7261, 0x4E59, 0x4FFA, 0x5378, 0x6069,
+   0x6E29, 0x7A4F, 0x97F3, 0x4E0B, 0x5316, 0x4EEE, 0x4F55, 0x4F3D,
+   0x4FA1, 0x4F73, 0x52A0, 0x53EF, 0x5609, 0x590F, 0x5AC1, 0x5BB6,
+   0x5BE1, 0x79D1, 0x6687, 0x679C, 0x67B6, 0x6B4C, 0x6CB3, 0x706B,
+   0x73C2, 0x798D, 0x79BE, 0x7A3C, 0x7B87, 0x82B1, 0x82DB, 0x8304,
+   0x8377, 0x83EF, 0x83D3, 0x8766, 0x8AB2, 0x5629, 0x8CA8, 0x8FE6,
+   0x904E, 0x971E, 0x868A, 0x4FC4, 0x5CE8, 0x6211, 0x7259, 0x753B,
+   0x81E5, 0x82BD, 0x86FE, 0x8CC0, 0x96C5, 0x9913, 0x99D5, 0x4ECB,
+   0x4F1A, 0x89E3, 0x56DE, 0x584A, 0x58CA, 0x5EFB, 0x5FEB, 0x602A,
+   0x6094, 0x6062, 0x61D0, 0x6212, 0x62D0, 0x6539},
+  {				/* category 19 */
+   0x9B41, 0x6666, 0x68B0, 0x6D77, 0x7070, 0x754C, 0x7686, 0x7D75,
+   0x82A5, 0x87F9, 0x958B, 0x968E, 0x8C9D, 0x51F1, 0x52BE, 0x5916,
+   0x54B3, 0x5BB3, 0x5D16, 0x6168, 0x6982, 0x6DAF, 0x788D, 0x84CB,
+   0x8857, 0x8A72, 0x93A7, 0x9AB8, 0x6D6C, 0x99A8, 0x86D9, 0x57A3,
+   0x67FF, 0x86CE, 0x920E, 0x5283, 0x5687, 0x5404, 0x5ED3, 0x62E1,
+   0x64B9, 0x683C, 0x6838, 0x6BBB, 0x7372, 0x78BA, 0x7A6B, 0x899A,
+   0x89D2, 0x8D6B, 0x8F03, 0x90ED, 0x95A3, 0x9694, 0x9769, 0x5B66,
+   0x5CB3, 0x697D, 0x984D, 0x984E, 0x639B, 0x7B20, 0x6A2B, 0x6A7F,
+   0x68B6, 0x9C0D, 0x6F5F, 0x5272, 0x559D, 0x6070, 0x62EC, 0x6D3B,
+   0x6E07, 0x6ED1, 0x845B, 0x8910, 0x8F44, 0x4E14, 0x9C39, 0x53F6,
+   0x691B, 0x6A3A, 0x9784, 0x682A, 0x515C, 0x7AC3, 0x84B2, 0x91DC,
+   0x938C, 0x565B, 0x9D28, 0x6822, 0x8305, 0x8431},
+  {				/* category 20 */
+   0x7CA5, 0x5208, 0x82C5, 0x74E6, 0x4E7E, 0x4F83, 0x51A0, 0x5BD2,
+   0x520A, 0x52D8, 0x52E7, 0x5DFB, 0x559A, 0x582A, 0x59E6, 0x5B8C,
+   0x5B98, 0x5BDB, 0x5E72, 0x5E79, 0x60A3, 0x611F, 0x6163, 0x61BE,
+   0x63DB, 0x6562, 0x67D1, 0x6853, 0x68FA, 0x6B3E, 0x6B53, 0x6C57,
+   0x6F22, 0x6F97, 0x6F45, 0x74B0, 0x7518, 0x76E3, 0x770B, 0x7AFF,
+   0x7BA1, 0x7C21, 0x7DE9, 0x7F36, 0x7FF0, 0x809D, 0x8266, 0x839E,
+   0x89B3, 0x8ACC, 0x8CAB, 0x9084, 0x9451, 0x9593, 0x9591, 0x95A2,
+   0x9665, 0x97D3, 0x9928, 0x8218, 0x4E38, 0x542B, 0x5CB8, 0x5DCC,
+   0x73A9, 0x764C, 0x773C, 0x5CA9, 0x7FEB, 0x8D0B, 0x96C1, 0x9811,
+   0x9854, 0x9858, 0x4F01, 0x4F0E, 0x5371, 0x559C, 0x5668, 0x57FA,
+   0x5947, 0x5B09, 0x5BC4, 0x5C90, 0x5E0C, 0x5E7E, 0x5FCC, 0x63EE,
+   0x673A, 0x65D7, 0x65E2, 0x671F, 0x68CB, 0x68C4},
+  {				/* category 21 */
+   0x6A5F, 0x5E30, 0x6BC5, 0x6C17, 0x6C7D, 0x757F, 0x7948, 0x5B63,
+   0x7A00, 0x7D00, 0x5FBD, 0x898F, 0x8A18, 0x8CB4, 0x8D77, 0x8ECC,
+   0x8F1D, 0x98E2, 0x9A0E, 0x9B3C, 0x4E80, 0x507D, 0x5100, 0x5993,
+   0x5B9C, 0x622F, 0x6280, 0x64EC, 0x6B3A, 0x72A0, 0x7591, 0x7947,
+   0x7FA9, 0x87FB, 0x8ABC, 0x8B70, 0x63AC, 0x83CA, 0x97A0, 0x5409,
+   0x5403, 0x55AB, 0x6854, 0x6A58, 0x8A70, 0x7827, 0x6775, 0x9ECD,
+   0x5374, 0x5BA2, 0x811A, 0x8650, 0x9006, 0x4E18, 0x4E45, 0x4EC7,
+   0x4F11, 0x53CA, 0x5438, 0x5BAE, 0x5F13, 0x6025, 0x6551, 0x673D,
+   0x6C42, 0x6C72, 0x6CE3, 0x7078, 0x7403, 0x7A76, 0x7AAE, 0x7B08,
+   0x7D1A, 0x7CFE, 0x7D66, 0x65E7, 0x725B, 0x53BB, 0x5C45, 0x5DE8,
+   0x62D2, 0x62E0, 0x6319, 0x6E20, 0x865A, 0x8A31, 0x8DDD, 0x92F8,
+   0x6F01, 0x79A6, 0x9B5A, 0x4EA8, 0x4EAB, 0x4EAC},
+  {				/* category 22 */
+   0x4F9B, 0x4FA0, 0x50D1, 0x5147, 0x7AF6, 0x5171, 0x51F6, 0x5354,
+   0x5321, 0x537F, 0x53EB, 0x55AC, 0x5883, 0x5CE1, 0x5F37, 0x5F4A,
+   0x602F, 0x6050, 0x606D, 0x631F, 0x6559, 0x6A4B, 0x6CC1, 0x72C2,
+   0x72ED, 0x77EF, 0x80F8, 0x8105, 0x8208, 0x854E, 0x90F7, 0x93E1,
+   0x97FF, 0x9957, 0x9A5A, 0x4EF0, 0x51DD, 0x5C2D, 0x6681, 0x696D,
+   0x5C40, 0x66F2, 0x6975, 0x7389, 0x6850, 0x7C81, 0x50C5, 0x52E4,
+   0x5747, 0x5DFE, 0x9326, 0x65A4, 0x6B23, 0x6B3D, 0x7434, 0x7981,
+   0x79BD, 0x7B4B, 0x7DCA, 0x82B9, 0x83CC, 0x887F, 0x895F, 0x8B39,
+   0x8FD1, 0x91D1, 0x541F, 0x9280, 0x4E5D, 0x5036, 0x53E5, 0x533A,
+   0x72D7, 0x7396, 0x77E9, 0x82E6, 0x8EAF, 0x99C6, 0x99C8, 0x99D2,
+   0x5177, 0x611A, 0x865E, 0x55B0, 0x7A7A, 0x5076, 0x5BD3, 0x9047,
+   0x9685, 0x4E32, 0x6ADB, 0x91E7, 0x5C51, 0x5C48},
+  {				/* category 23 */
+   0x6398, 0x7A9F, 0x6C93, 0x9774, 0x8F61, 0x7AAA, 0x718A, 0x9688,
+   0x7C82, 0x6817, 0x7E70, 0x6851, 0x936C, 0x52F2, 0x541B, 0x85AB,
+   0x8A13, 0x7FA4, 0x8ECD, 0x90E1, 0x5366, 0x8888, 0x7941, 0x4FC2,
+   0x50BE, 0x5211, 0x5144, 0x5553, 0x572D, 0x73EA, 0x578B, 0x5951,
+   0x5F62, 0x5F84, 0x6075, 0x6176, 0x6167, 0x61A9, 0x63B2, 0x643A,
+   0x656C, 0x666F, 0x6842, 0x6E13, 0x7566, 0x7A3D, 0x7CFB, 0x7D4C,
+   0x7D99, 0x7E4B, 0x7F6B, 0x830E, 0x834A, 0x86CD, 0x8A08, 0x8A63,
+   0x8B66, 0x8EFD, 0x981A, 0x9D8F, 0x82B8, 0x8FCE, 0x9BE8, 0x5287,
+   0x621F, 0x6483, 0x6FC0, 0x9699, 0x6841, 0x5091, 0x6B20, 0x6C7A,
+   0x6F54, 0x7A74, 0x7D50, 0x8840, 0x8A23, 0x6708, 0x4EF6, 0x5039,
+   0x5026, 0x5065, 0x517C, 0x5238, 0x5263, 0x55A7, 0x570F, 0x5805,
+   0x5ACC, 0x5EFA, 0x61B2, 0x61F8, 0x62F3, 0x6372},
+  {				/* category 24 */
+   0x691C, 0x6A29, 0x727D, 0x72AC, 0x732E, 0x7814, 0x786F, 0x7D79,
+   0x770C, 0x80A9, 0x898B, 0x8B19, 0x8CE2, 0x8ED2, 0x9063, 0x9375,
+   0x967A, 0x9855, 0x9A13, 0x9E78, 0x5143, 0x539F, 0x53B3, 0x5E7B,
+   0x5F26, 0x6E1B, 0x6E90, 0x7384, 0x73FE, 0x7D43, 0x8237, 0x8A00,
+   0x8AFA, 0x9650, 0x4E4E, 0x500B, 0x53E4, 0x547C, 0x56FA, 0x59D1,
+   0x5B64, 0x5DF1, 0x5EAB, 0x5F27, 0x6238, 0x6545, 0x67AF, 0x6E56,
+   0x72D0, 0x7CCA, 0x88B4, 0x80A1, 0x80E1, 0x83F0, 0x864E, 0x8A87,
+   0x8DE8, 0x9237, 0x96C7, 0x9867, 0x9F13, 0x4E94, 0x4E92, 0x4F0D,
+   0x5348, 0x5449, 0x543E, 0x5A2F, 0x5F8C, 0x5FA1, 0x609F, 0x68A7,
+   0x6A8E, 0x745A, 0x7881, 0x8A9E, 0x8AA4, 0x8B77, 0x9190, 0x4E5E,
+   0x9BC9, 0x4EA4, 0x4F7C, 0x4FAF, 0x5019, 0x5016, 0x5149, 0x516C,
+   0x529F, 0x52B9, 0x52FE, 0x539A, 0x53E3, 0x5411},
+  {				/* category 25 */
+   0x540E, 0x5589, 0x5751, 0x57A2, 0x597D, 0x5B54, 0x5B5D, 0x5B8F,
+   0x5DE5, 0x5DE7, 0x5DF7, 0x5E78, 0x5E83, 0x5E9A, 0x5EB7, 0x5F18,
+   0x6052, 0x614C, 0x6297, 0x62D8, 0x63A7, 0x653B, 0x6602, 0x6643,
+   0x66F4, 0x676D, 0x6821, 0x6897, 0x69CB, 0x6C5F, 0x6D2A, 0x6D69,
+   0x6E2F, 0x6E9D, 0x7532, 0x7687, 0x786C, 0x7A3F, 0x7CE0, 0x7D05,
+   0x7D18, 0x7D5E, 0x7DB1, 0x8015, 0x8003, 0x80AF, 0x80B1, 0x8154,
+   0x818F, 0x822A, 0x8352, 0x884C, 0x8861, 0x8B1B, 0x8CA2, 0x8CFC,
+   0x90CA, 0x9175, 0x9271, 0x783F, 0x92FC, 0x95A4, 0x964D, 0x9805,
+   0x9999, 0x9AD8, 0x9D3B, 0x525B, 0x52AB, 0x53F7, 0x5408, 0x58D5,
+   0x62F7, 0x6FE0, 0x8C6A, 0x8F5F, 0x9EB9, 0x514B, 0x523B, 0x544A,
+   0x56FD, 0x7A40, 0x9177, 0x9D60, 0x9ED2, 0x7344, 0x6F09, 0x8170,
+   0x7511, 0x5FFD, 0x60DA, 0x9AA8, 0x72DB, 0x8FBC},
+  {				/* category 26 */
+   0x6B64, 0x9803, 0x4ECA, 0x56F0, 0x5764, 0x58BE, 0x5A5A, 0x6068,
+   0x61C7, 0x660F, 0x6606, 0x6839, 0x68B1, 0x6DF7, 0x75D5, 0x7D3A,
+   0x826E, 0x9B42, 0x4E9B, 0x4F50, 0x53C9, 0x5506, 0x5D6F, 0x5DE6,
+   0x5DEE, 0x67FB, 0x6C99, 0x7473, 0x7802, 0x8A50, 0x9396, 0x88DF,
+   0x5750, 0x5EA7, 0x632B, 0x50B5, 0x50AC, 0x518D, 0x6700, 0x54C9,
+   0x585E, 0x59BB, 0x5BB0, 0x5F69, 0x624D, 0x63A1, 0x683D, 0x6B73,
+   0x6E08, 0x707D, 0x91C7, 0x7280, 0x7815, 0x7826, 0x796D, 0x658E,
+   0x7D30, 0x83DC, 0x88C1, 0x8F09, 0x969B, 0x5264, 0x5728, 0x6750,
+   0x7F6A, 0x8CA1, 0x51B4, 0x5742, 0x962A, 0x583A, 0x698A, 0x80B4,
+   0x54B2, 0x5D0E, 0x57FC, 0x7895, 0x9DFA, 0x4F5C, 0x524A, 0x548B,
+   0x643E, 0x6628, 0x6714, 0x67F5, 0x7A84, 0x7B56, 0x7D22, 0x932F,
+   0x685C, 0x9BAD, 0x7B39, 0x5319, 0x518A, 0x5237},
+  {				/* category 27 */
+   0x5BDF, 0x62F6, 0x64AE, 0x64E6, 0x672D, 0x6BBA, 0x85A9, 0x96D1,
+   0x7690, 0x9BD6, 0x634C, 0x9306, 0x9BAB, 0x76BF, 0x6652, 0x4E09,
+   0x5098, 0x53C2, 0x5C71, 0x60E8, 0x6492, 0x6563, 0x685F, 0x71E6,
+   0x73CA, 0x7523, 0x7B97, 0x7E82, 0x8695, 0x8B83, 0x8CDB, 0x9178,
+   0x9910, 0x65AC, 0x66AB, 0x6B8B, 0x4ED5, 0x4ED4, 0x4F3A, 0x4F7F,
+   0x523A, 0x53F8, 0x53F2, 0x55E3, 0x56DB, 0x58EB, 0x59CB, 0x59C9,
+   0x59FF, 0x5B50, 0x5C4D, 0x5E02, 0x5E2B, 0x5FD7, 0x601D, 0x6307,
+   0x652F, 0x5B5C, 0x65AF, 0x65BD, 0x65E8, 0x679D, 0x6B62, 0x6B7B,
+   0x6C0F, 0x7345, 0x7949, 0x79C1, 0x7CF8, 0x7D19, 0x7D2B, 0x80A2,
+   0x8102, 0x81F3, 0x8996, 0x8A5E, 0x8A69, 0x8A66, 0x8A8C, 0x8AEE,
+   0x8CC7, 0x8CDC, 0x96CC, 0x98FC, 0x6B6F, 0x4E8B, 0x4F3C, 0x4F8D,
+   0x5150, 0x5B57, 0x5BFA, 0x6148, 0x6301, 0x6642},
+  {				/* category 28 */
+   0x6B21, 0x6ECB, 0x6CBB, 0x723E, 0x74BD, 0x75D4, 0x78C1, 0x793A,
+   0x800C, 0x8033, 0x81EA, 0x8494, 0x8F9E, 0x6C50, 0x9E7F, 0x5F0F,
+   0x8B58, 0x9D2B, 0x7AFA, 0x8EF8, 0x5B8D, 0x96EB, 0x4E03, 0x53F1,
+   0x57F7, 0x5931, 0x5AC9, 0x5BA4, 0x6089, 0x6E7F, 0x6F06, 0x75BE,
+   0x8CEA, 0x5B9F, 0x8500, 0x7BE0, 0x5072, 0x67F4, 0x829D, 0x5C61,
+   0x854A, 0x7E1E, 0x820E, 0x5199, 0x5C04, 0x6368, 0x8D66, 0x659C,
+   0x716E, 0x793E, 0x7D17, 0x8005, 0x8B1D, 0x8ECA, 0x906E, 0x86C7,
+   0x90AA, 0x501F, 0x52FA, 0x5C3A, 0x6753, 0x707C, 0x7235, 0x914C,
+   0x91C8, 0x932B, 0x82E5, 0x5BC2, 0x5F31, 0x60F9, 0x4E3B, 0x53D6,
+   0x5B88, 0x624B, 0x6731, 0x6B8A, 0x72E9, 0x73E0, 0x7A2E, 0x816B,
+   0x8DA3, 0x9152, 0x9996, 0x5112, 0x53D7, 0x546A, 0x5BFF, 0x6388,
+   0x6A39, 0x7DAC, 0x9700, 0x56DA, 0x53CE, 0x5468},
+  {				/* category 29 */
+   0x5B97, 0x5C31, 0x5DDE, 0x4FEE, 0x6101, 0x62FE, 0x6D32, 0x79C0,
+   0x79CB, 0x7D42, 0x7E4D, 0x7FD2, 0x81ED, 0x821F, 0x8490, 0x8846,
+   0x8972, 0x8B90, 0x8E74, 0x8F2F, 0x9031, 0x914B, 0x916C, 0x96C6,
+   0x919C, 0x4EC0, 0x4F4F, 0x5145, 0x5341, 0x5F93, 0x620E, 0x67D4,
+   0x6C41, 0x6E0B, 0x7363, 0x7E26, 0x91CD, 0x9283, 0x53D4, 0x5919,
+   0x5BBF, 0x6DD1, 0x795D, 0x7E2E, 0x7C9B, 0x587E, 0x719F, 0x51FA,
+   0x8853, 0x8FF0, 0x4FCA, 0x5CFB, 0x6625, 0x77AC, 0x7AE3, 0x821C,
+   0x99FF, 0x51C6, 0x5FAA, 0x65EC, 0x696F, 0x6B89, 0x6DF3, 0x6E96,
+   0x6F64, 0x76FE, 0x7D14, 0x5DE1, 0x9075, 0x9187, 0x9806, 0x51E6,
+   0x521D, 0x6240, 0x6691, 0x66D9, 0x6E1A, 0x5EB6, 0x7DD2, 0x7F72,
+   0x66F8, 0x85AF, 0x85F7, 0x8AF8, 0x52A9, 0x53D9, 0x5973, 0x5E8F,
+   0x5F90, 0x6055, 0x92E4, 0x9664, 0x50B7, 0x511F},
+  {				/* category 30 */
+   0x52DD, 0x5320, 0x5347, 0x53EC, 0x54E8, 0x5546, 0x5531, 0x5617,
+   0x5968, 0x59BE, 0x5A3C, 0x5BB5, 0x5C06, 0x5C0F, 0x5C11, 0x5C1A,
+   0x5E84, 0x5E8A, 0x5EE0, 0x5F70, 0x627F, 0x6284, 0x62DB, 0x638C,
+   0x6377, 0x6607, 0x660C, 0x662D, 0x6676, 0x677E, 0x68A2, 0x6A1F,
+   0x6A35, 0x6CBC, 0x6D88, 0x6E09, 0x6E58, 0x713C, 0x7126, 0x7167,
+   0x75C7, 0x7701, 0x785D, 0x7901, 0x7965, 0x79F0, 0x7AE0, 0x7B11,
+   0x7CA7, 0x7D39, 0x8096, 0x83D6, 0x848B, 0x8549, 0x885D, 0x88F3,
+   0x8A1F, 0x8A3C, 0x8A54, 0x8A73, 0x8C61, 0x8CDE, 0x91A4, 0x9266,
+   0x937E, 0x9418, 0x969C, 0x9798, 0x4E0A, 0x4E08, 0x4E1E, 0x4E57,
+   0x5197, 0x5270, 0x57CE, 0x5834, 0x58CC, 0x5B22, 0x5E38, 0x60C5,
+   0x64FE, 0x6761, 0x6756, 0x6D44, 0x72B6, 0x7573, 0x7A63, 0x84B8,
+   0x8B72, 0x91B8, 0x9320, 0x5631, 0x57F4, 0x98FE},
+  {				/* category 31 */
+   0x62ED, 0x690D, 0x6B96, 0x71ED, 0x7E54, 0x8077, 0x8272, 0x89E6,
+   0x98DF, 0x8755, 0x8FB1, 0x5C3B, 0x4F38, 0x4FE1, 0x4FB5, 0x5507,
+   0x5A20, 0x5BDD, 0x5BE9, 0x5FC3, 0x614E, 0x632F, 0x65B0, 0x664B,
+   0x68EE, 0x699B, 0x6D78, 0x6DF1, 0x7533, 0x75B9, 0x771F, 0x795E,
+   0x79E6, 0x7D33, 0x81E3, 0x82AF, 0x85AA, 0x89AA, 0x8A3A, 0x8EAB,
+   0x8F9B, 0x9032, 0x91DD, 0x9707, 0x4EBA, 0x4EC1, 0x5203, 0x5875,
+   0x58EC, 0x5C0B, 0x751A, 0x5C3D, 0x814E, 0x8A0A, 0x8FC5, 0x9663,
+   0x976D, 0x7B25, 0x8ACF, 0x9808, 0x9162, 0x56F3, 0x53A8, 0x9017,
+   0x5439, 0x5782, 0x5E25, 0x63A8, 0x6C34, 0x708A, 0x7761, 0x7C8B,
+   0x7FE0, 0x8870, 0x9042, 0x9154, 0x9310, 0x9318, 0x968F, 0x745E,
+   0x9AC4, 0x5D07, 0x5D69, 0x6570, 0x67A2, 0x8DA8, 0x96DB, 0x636E,
+   0x6749, 0x6919, 0x83C5, 0x9817, 0x96C0, 0x88FE},
+  {				/* category 32 */
+   0x6F84, 0x647A, 0x5BF8, 0x4E16, 0x702C, 0x755D, 0x662F, 0x51C4,
+   0x5236, 0x52E2, 0x59D3, 0x5F81, 0x6027, 0x6210, 0x653F, 0x6574,
+   0x661F, 0x6674, 0x68F2, 0x6816, 0x6B63, 0x6E05, 0x7272, 0x751F,
+   0x76DB, 0x7CBE, 0x8056, 0x58F0, 0x88FD, 0x897F, 0x8AA0, 0x8A93,
+   0x8ACB, 0x901D, 0x9192, 0x9752, 0x9759, 0x6589, 0x7A0E, 0x8106,
+   0x96BB, 0x5E2D, 0x60DC, 0x621A, 0x65A5, 0x6614, 0x6790, 0x77F3,
+   0x7A4D, 0x7C4D, 0x7E3E, 0x810A, 0x8CAC, 0x8D64, 0x8DE1, 0x8E5F,
+   0x78A9, 0x5207, 0x62D9, 0x63A5, 0x6442, 0x6298, 0x8A2D, 0x7A83,
+   0x7BC0, 0x8AAC, 0x96EA, 0x7D76, 0x820C, 0x8749, 0x4ED9, 0x5148,
+   0x5343, 0x5360, 0x5BA3, 0x5C02, 0x5C16, 0x5DDD, 0x6226, 0x6247,
+   0x64B0, 0x6813, 0x6834, 0x6CC9, 0x6D45, 0x6D17, 0x67D3, 0x6F5C,
+   0x714E, 0x717D, 0x65CB, 0x7A7F, 0x7BAD, 0x7DDA},
+  {				/* category 33 */
+   0x7E4A, 0x7FA8, 0x817A, 0x821B, 0x8239, 0x85A6, 0x8A6E, 0x8CCE,
+   0x8DF5, 0x9078, 0x9077, 0x92AD, 0x9291, 0x9583, 0x9BAE, 0x524D,
+   0x5584, 0x6F38, 0x7136, 0x5168, 0x7985, 0x7E55, 0x81B3, 0x7CCE,
+   0x564C, 0x5851, 0x5CA8, 0x63AA, 0x66FE, 0x66FD, 0x695A, 0x72D9,
+   0x758F, 0x758E, 0x790E, 0x7956, 0x79DF, 0x7C97, 0x7D20, 0x7D44,
+   0x8607, 0x8A34, 0x963B, 0x9061, 0x9F20, 0x50E7, 0x5275, 0x53CC,
+   0x53E2, 0x5009, 0x55AA, 0x58EE, 0x594F, 0x723D, 0x5B8B, 0x5C64,
+   0x531D, 0x60E3, 0x60F3, 0x635C, 0x6383, 0x633F, 0x63BB, 0x64CD,
+   0x65E9, 0x66F9, 0x5DE3, 0x69CD, 0x69FD, 0x6F15, 0x71E5, 0x4E89,
+   0x75E9, 0x76F8, 0x7A93, 0x7CDF, 0x7DCF, 0x7D9C, 0x8061, 0x8349,
+   0x8358, 0x846C, 0x84BC, 0x85FB, 0x88C5, 0x8D70, 0x9001, 0x906D,
+   0x9397, 0x971C, 0x9A12, 0x50CF, 0x5897, 0x618E},
+  {				/* category 34 */
+   0x81D3, 0x8535, 0x8D08, 0x9020, 0x4FC3, 0x5074, 0x5247, 0x5373,
+   0x606F, 0x6349, 0x675F, 0x6E2C, 0x8DB3, 0x901F, 0x4FD7, 0x5C5E,
+   0x8CCA, 0x65CF, 0x7D9A, 0x5352, 0x8896, 0x5176, 0x63C3, 0x5B58,
+   0x5B6B, 0x5C0A, 0x640D, 0x6751, 0x905C, 0x4ED6, 0x591A, 0x592A,
+   0x6C70, 0x8A51, 0x553E, 0x5815, 0x59A5, 0x60F0, 0x6253, 0x67C1,
+   0x8235, 0x6955, 0x9640, 0x99C4, 0x9A28, 0x4F53, 0x5806, 0x5BFE,
+   0x8010, 0x5CB1, 0x5E2F, 0x5F85, 0x6020, 0x614B, 0x6234, 0x66FF,
+   0x6CF0, 0x6EDE, 0x80CE, 0x817F, 0x82D4, 0x888B, 0x8CB8, 0x9000,
+   0x902E, 0x968A, 0x9EDB, 0x9BDB, 0x4EE3, 0x53F0, 0x5927, 0x7B2C,
+   0x918D, 0x984C, 0x9DF9, 0x6EDD, 0x7027, 0x5353, 0x5544, 0x5B85,
+   0x6258, 0x629E, 0x62D3, 0x6CA2, 0x6FEF, 0x7422, 0x8A17, 0x9438,
+   0x6FC1, 0x8AFE, 0x8338, 0x51E7, 0x86F8, 0x53EA},
+  {				/* category 35 */
+   0x53E9, 0x4F46, 0x9054, 0x8FB0, 0x596A, 0x8131, 0x5DFD, 0x7AEA,
+   0x8FBF, 0x68DA, 0x8C37, 0x72F8, 0x9C48, 0x6A3D, 0x8AB0, 0x4E39,
+   0x5358, 0x5606, 0x5766, 0x62C5, 0x63A2, 0x65E6, 0x6B4E, 0x6DE1,
+   0x6E5B, 0x70AD, 0x77ED, 0x7AEF, 0x7BAA, 0x7DBB, 0x803D, 0x80C6,
+   0x86CB, 0x8A95, 0x935B, 0x56E3, 0x58C7, 0x5F3E, 0x65AD, 0x6696,
+   0x6A80, 0x6BB5, 0x7537, 0x8AC7, 0x5024, 0x77E5, 0x5730, 0x5F1B,
+   0x6065, 0x667A, 0x6C60, 0x75F4, 0x7A1A, 0x7F6E, 0x81F4, 0x8718,
+   0x9045, 0x99B3, 0x7BC9, 0x755C, 0x7AF9, 0x7B51, 0x84C4, 0x9010,
+   0x79E9, 0x7A92, 0x8336, 0x5AE1, 0x7740, 0x4E2D, 0x4EF2, 0x5B99,
+   0x5FE0, 0x62BD, 0x663C, 0x67F1, 0x6CE8, 0x866B, 0x8877, 0x8A3B,
+   0x914E, 0x92F3, 0x99D0, 0x6A17, 0x7026, 0x732A, 0x82E7, 0x8457,
+   0x8CAF, 0x4E01, 0x5146, 0x51CB, 0x558B, 0x5BF5},
+  {				/* category 36 */
+   0x5E16, 0x5E33, 0x5E81, 0x5F14, 0x5F35, 0x5F6B, 0x5FB4, 0x61F2,
+   0x6311, 0x66A2, 0x671D, 0x6F6E, 0x7252, 0x753A, 0x773A, 0x8074,
+   0x8139, 0x8178, 0x8776, 0x8ABF, 0x8ADC, 0x8D85, 0x8DF3, 0x929A,
+   0x9577, 0x9802, 0x9CE5, 0x52C5, 0x6357, 0x76F4, 0x6715, 0x6C88,
+   0x73CD, 0x8CC3, 0x93AE, 0x9673, 0x6D25, 0x589C, 0x690E, 0x69CC,
+   0x8FFD, 0x939A, 0x75DB, 0x901A, 0x585A, 0x6802, 0x63B4, 0x69FB,
+   0x4F43, 0x6F2C, 0x67D8, 0x8FBB, 0x8526, 0x7DB4, 0x9354, 0x693F,
+   0x6F70, 0x576A, 0x58F7, 0x5B2C, 0x7D2C, 0x722A, 0x540A, 0x91E3,
+   0x9DB4, 0x4EAD, 0x4F4E, 0x505C, 0x5075, 0x5243, 0x8C9E, 0x5448,
+   0x5824, 0x5B9A, 0x5E1D, 0x5E95, 0x5EAD, 0x5EF7, 0x5F1F, 0x608C,
+   0x62B5, 0x633A, 0x63D0, 0x68AF, 0x6C40, 0x7887, 0x798E, 0x7A0B,
+   0x7DE0, 0x8247, 0x8A02, 0x8AE6, 0x8E44, 0x9013},
+  {				/* category 37 */
+   0x90B8, 0x912D, 0x91D8, 0x9F0E, 0x6CE5, 0x6458, 0x64E2, 0x6575,
+   0x6EF4, 0x7684, 0x7B1B, 0x9069, 0x93D1, 0x6EBA, 0x54F2, 0x5FB9,
+   0x64A4, 0x8F4D, 0x8FED, 0x9244, 0x5178, 0x586B, 0x5929, 0x5C55,
+   0x5E97, 0x6DFB, 0x7E8F, 0x751C, 0x8CBC, 0x8EE2, 0x985B, 0x70B9,
+   0x4F1D, 0x6BBF, 0x6FB1, 0x7530, 0x96FB, 0x514E, 0x5410, 0x5835,
+   0x5857, 0x59AC, 0x5C60, 0x5F92, 0x6597, 0x675C, 0x6E21, 0x767B,
+   0x83DF, 0x8CED, 0x9014, 0x90FD, 0x934D, 0x7825, 0x783A, 0x52AA,
+   0x5EA6, 0x571F, 0x5974, 0x6012, 0x5012, 0x515A, 0x51AC, 0x51CD,
+   0x5200, 0x5510, 0x5854, 0x5858, 0x5957, 0x5B95, 0x5CF6, 0x5D8B,
+   0x60BC, 0x6295, 0x642D, 0x6771, 0x6843, 0x68BC, 0x68DF, 0x76D7,
+   0x6DD8, 0x6E6F, 0x6D9B, 0x706F, 0x71C8, 0x5F53, 0x75D8, 0x7977,
+   0x7B49, 0x7B54, 0x7B52, 0x7CD6, 0x7D71, 0x5230},
+  {				/* category 38 */
+   0x8463, 0x8569, 0x85E4, 0x8A0E, 0x8B04, 0x8C46, 0x8E0F, 0x9003,
+   0x900F, 0x9419, 0x9676, 0x982D, 0x9A30, 0x95D8, 0x50CD, 0x52D5,
+   0x540C, 0x5802, 0x5C0E, 0x61A7, 0x649E, 0x6D1E, 0x77B3, 0x7AE5,
+   0x80F4, 0x8404, 0x9053, 0x9285, 0x5CE0, 0x9D07, 0x533F, 0x5F97,
+   0x5FB3, 0x6D9C, 0x7279, 0x7763, 0x79BF, 0x7BE4, 0x6BD2, 0x72EC,
+   0x8AAD, 0x6803, 0x6A61, 0x51F8, 0x7A81, 0x6934, 0x5C4A, 0x9CF6,
+   0x82EB, 0x5BC5, 0x9149, 0x701E, 0x5678, 0x5C6F, 0x60C7, 0x6566,
+   0x6C8C, 0x8C5A, 0x9041, 0x9813, 0x5451, 0x66C7, 0x920D, 0x5948,
+   0x90A3, 0x5185, 0x4E4D, 0x51EA, 0x8599, 0x8B0E, 0x7058, 0x637A,
+   0x934B, 0x6962, 0x99B4, 0x7E04, 0x7577, 0x5357, 0x6960, 0x8EDF,
+   0x96E3, 0x6C5D, 0x4E8C, 0x5C3C, 0x5F10, 0x8FE9, 0x5302, 0x8CD1,
+   0x8089, 0x8679, 0x5EFF, 0x65E5, 0x4E73, 0x5165},
+  {				/* category 39 */
+   0x5982, 0x5C3F, 0x97EE, 0x4EFB, 0x598A, 0x5FCD, 0x8A8D, 0x6FE1,
+   0x79B0, 0x7962, 0x5BE7, 0x8471, 0x732B, 0x71B1, 0x5E74, 0x5FF5,
+   0x637B, 0x649A, 0x71C3, 0x7C98, 0x4E43, 0x5EFC, 0x4E4B, 0x57DC,
+   0x56A2, 0x60A9, 0x6FC3, 0x7D0D, 0x80FD, 0x8133, 0x81BF, 0x8FB2,
+   0x8997, 0x86A4, 0x5DF4, 0x628A, 0x64AD, 0x8987, 0x6777, 0x6CE2,
+   0x6D3E, 0x7436, 0x7834, 0x5A46, 0x7F75, 0x82AD, 0x99AC, 0x4FF3,
+   0x5EC3, 0x62DD, 0x6392, 0x6557, 0x676F, 0x76C3, 0x724C, 0x80CC,
+   0x80BA, 0x8F29, 0x914D, 0x500D, 0x57F9, 0x5A92, 0x6885, 0x6973,
+   0x7164, 0x72FD, 0x8CB7, 0x58F2, 0x8CE0, 0x966A, 0x9019, 0x877F,
+   0x79E4, 0x77E7, 0x8429, 0x4F2F, 0x5265, 0x535A, 0x62CD, 0x67CF,
+   0x6CCA, 0x767D, 0x7B94, 0x7C95, 0x8236, 0x8584, 0x8FEB, 0x66DD,
+   0x6F20, 0x7206, 0x7E1B, 0x83AB, 0x99C1, 0x9EA6},
+  {				/* category 40 */
+   0x51FD, 0x7BB1, 0x7872, 0x7BB8, 0x8087, 0x7B48, 0x6AE8, 0x5E61,
+   0x808C, 0x7551, 0x7560, 0x516B, 0x9262, 0x6E8C, 0x767A, 0x9197,
+   0x9AEA, 0x4F10, 0x7F70, 0x629C, 0x7B4F, 0x95A5, 0x9CE9, 0x567A,
+   0x5859, 0x86E4, 0x96BC, 0x4F34, 0x5224, 0x534A, 0x53CD, 0x53DB,
+   0x5E06, 0x642C, 0x6591, 0x677F, 0x6C3E, 0x6C4E, 0x7248, 0x72AF,
+   0x73ED, 0x7554, 0x7E41, 0x822C, 0x85E9, 0x8CA9, 0x7BC4, 0x91C6,
+   0x7169, 0x9812, 0x98EF, 0x633D, 0x6669, 0x756A, 0x76E4, 0x78D0,
+   0x8543, 0x86EE, 0x532A, 0x5351, 0x5426, 0x5983, 0x5E87, 0x5F7C,
+   0x60B2, 0x6249, 0x6279, 0x62AB, 0x6590, 0x6BD4, 0x6CCC, 0x75B2,
+   0x76AE, 0x7891, 0x79D8, 0x7DCB, 0x7F77, 0x80A5, 0x88AB, 0x8AB9,
+   0x8CBB, 0x907F, 0x975E, 0x98DB, 0x6A0B, 0x7C38, 0x5099, 0x5C3E,
+   0x5FAE, 0x6787, 0x6BD8, 0x7435, 0x7709, 0x7F8E},
+  {				/* category 41 */
+   0x9F3B, 0x67CA, 0x7A17, 0x5339, 0x758B, 0x9AED, 0x5F66, 0x819D,
+   0x83F1, 0x8098, 0x5F3C, 0x5FC5, 0x7562, 0x7B46, 0x903C, 0x6867,
+   0x59EB, 0x5A9B, 0x7D10, 0x767E, 0x8B2C, 0x4FF5, 0x5F6A, 0x6A19,
+   0x6C37, 0x6F02, 0x74E2, 0x7968, 0x8868, 0x8A55, 0x8C79, 0x5EDF,
+   0x63CF, 0x75C5, 0x79D2, 0x82D7, 0x9328, 0x92F2, 0x849C, 0x86ED,
+   0x9C2D, 0x54C1, 0x5F6C, 0x658C, 0x6D5C, 0x7015, 0x8CA7, 0x8CD3,
+   0x983B, 0x654F, 0x74F6, 0x4E0D, 0x4ED8, 0x57E0, 0x592B, 0x5A66,
+   0x5BCC, 0x51A8, 0x5E03, 0x5E9C, 0x6016, 0x6276, 0x6577, 0x65A7,
+   0x666E, 0x6D6E, 0x7236, 0x7B26, 0x8150, 0x819A, 0x8299, 0x8B5C,
+   0x8CA0, 0x8CE6, 0x8D74, 0x961C, 0x9644, 0x4FAE, 0x64AB, 0x6B66,
+   0x821E, 0x8461, 0x856A, 0x90E8, 0x5C01, 0x6953, 0x98A8, 0x847A,
+   0x8557, 0x4F0F, 0x526F, 0x5FA9, 0x5E45, 0x670D},
+  {				/* category 42 */
+   0x798F, 0x8179, 0x8907, 0x8986, 0x6DF5, 0x5F17, 0x6255, 0x6CB8,
+   0x4ECF, 0x7269, 0x9B92, 0x5206, 0x543B, 0x5674, 0x58B3, 0x61A4,
+   0x626E, 0x711A, 0x596E, 0x7C89, 0x7CDE, 0x7D1B, 0x96F0, 0x6587,
+   0x805E, 0x4E19, 0x4F75, 0x5175, 0x5840, 0x5E63, 0x5E73, 0x5F0A,
+   0x67C4, 0x4E26, 0x853D, 0x9589, 0x965B, 0x7C73, 0x9801, 0x50FB,
+   0x58C1, 0x7656, 0x78A7, 0x5225, 0x77A5, 0x8511, 0x7B86, 0x504F,
+   0x5909, 0x7247, 0x7BC7, 0x7DE8, 0x8FBA, 0x8FD4, 0x904D, 0x4FBF,
+   0x52C9, 0x5A29, 0x5F01, 0x97AD, 0x4FDD, 0x8217, 0x92EA, 0x5703,
+   0x6355, 0x6B69, 0x752B, 0x88DC, 0x8F14, 0x7A42, 0x52DF, 0x5893,
+   0x6155, 0x620A, 0x66AE, 0x6BCD, 0x7C3F, 0x83E9, 0x5023, 0x4FF8,
+   0x5305, 0x5446, 0x5831, 0x5949, 0x5B9D, 0x5CF0, 0x5CEF, 0x5D29,
+   0x5E96, 0x62B1, 0x6367, 0x653E, 0x65B9, 0x670B},
+  {				/* category 43 */
+   0x6CD5, 0x6CE1, 0x70F9, 0x7832, 0x7E2B, 0x80DE, 0x82B3, 0x840C,
+   0x84EC, 0x8702, 0x8912, 0x8A2A, 0x8C4A, 0x90A6, 0x92D2, 0x98FD,
+   0x9CF3, 0x9D6C, 0x4E4F, 0x4EA1, 0x508D, 0x5256, 0x574A, 0x59A8,
+   0x5E3D, 0x5FD8, 0x5FD9, 0x623F, 0x66B4, 0x671B, 0x67D0, 0x68D2,
+   0x5192, 0x7D21, 0x80AA, 0x81A8, 0x8B00, 0x8C8C, 0x8CBF, 0x927E,
+   0x9632, 0x5420, 0x982C, 0x5317, 0x50D5, 0x535C, 0x58A8, 0x64B2,
+   0x6734, 0x7267, 0x7766, 0x7A46, 0x91E6, 0x52C3, 0x6CA1, 0x6B86,
+   0x5800, 0x5E4C, 0x5954, 0x672C, 0x7FFB, 0x51E1, 0x76C6, 0x6469,
+   0x78E8, 0x9B54, 0x9EBB, 0x57CB, 0x59B9, 0x6627, 0x679A, 0x6BCE,
+   0x54E9, 0x69D9, 0x5E55, 0x819C, 0x6795, 0x9BAA, 0x67FE, 0x9C52,
+   0x685D, 0x4EA6, 0x4FE3, 0x53C8, 0x62B9, 0x672B, 0x6CAB, 0x8FC4,
+   0x4FAD, 0x7E6D, 0x9EBF, 0x4E07, 0x6162, 0x6E80},
+  {				/* category 44 */
+   0x6F2B, 0x8513, 0x5473, 0x672A, 0x9B45, 0x5DF3, 0x7B95, 0x5CAC,
+   0x5BC6, 0x871C, 0x6E4A, 0x84D1, 0x7A14, 0x8108, 0x5999, 0x7C8D,
+   0x6C11, 0x7720, 0x52D9, 0x5922, 0x7121, 0x725F, 0x77DB, 0x9727,
+   0x9D61, 0x690B, 0x5A7F, 0x5A18, 0x51A5, 0x540D, 0x547D, 0x660E,
+   0x76DF, 0x8FF7, 0x9298, 0x9CF4, 0x59EA, 0x725D, 0x6EC5, 0x514D,
+   0x68C9, 0x7DBF, 0x7DEC, 0x9762, 0x9EBA, 0x6478, 0x6A21, 0x8302,
+   0x5984, 0x5B5F, 0x6BDB, 0x731B, 0x76F2, 0x7DB2, 0x8017, 0x8499,
+   0x5132, 0x6728, 0x9ED9, 0x76EE, 0x6762, 0x52FF, 0x9905, 0x5C24,
+   0x623B, 0x7C7E, 0x8CB0, 0x554F, 0x60B6, 0x7D0B, 0x9580, 0x5301,
+   0x4E5F, 0x51B6, 0x591C, 0x723A, 0x8036, 0x91CE, 0x5F25, 0x77E2,
+   0x5384, 0x5F79, 0x7D04, 0x85AC, 0x8A33, 0x8E8D, 0x9756, 0x67F3,
+   0x85AE, 0x9453, 0x6109, 0x6108, 0x6CB9, 0x7652},
+  {				/* category 45 */
+   0x8AED, 0x8F38, 0x552F, 0x4F51, 0x512A, 0x52C7, 0x53CB, 0x5BA5,
+   0x5E7D, 0x60A0, 0x6182, 0x63D6, 0x6709, 0x67DA, 0x6E67, 0x6D8C,
+   0x7336, 0x7337, 0x7531, 0x7950, 0x88D5, 0x8A98, 0x904A, 0x9091,
+   0x90F5, 0x96C4, 0x878D, 0x5915, 0x4E88, 0x4F59, 0x4E0E, 0x8A89,
+   0x8F3F, 0x9810, 0x50AD, 0x5E7C, 0x5996, 0x5BB9, 0x5EB8, 0x63DA,
+   0x63FA, 0x64C1, 0x66DC, 0x694A, 0x69D8, 0x6D0B, 0x6EB6, 0x7194,
+   0x7528, 0x7AAF, 0x7F8A, 0x8000, 0x8449, 0x84C9, 0x8981, 0x8B21,
+   0x8E0A, 0x9065, 0x967D, 0x990A, 0x617E, 0x6291, 0x6B32, 0x6C83,
+   0x6D74, 0x7FCC, 0x7FFC, 0x6DC0, 0x7F85, 0x87BA, 0x88F8, 0x6765,
+   0x83B1, 0x983C, 0x96F7, 0x6D1B, 0x7D61, 0x843D, 0x916A, 0x4E71,
+   0x5375, 0x5D50, 0x6B04, 0x6FEB, 0x85CD, 0x862D, 0x89A7, 0x5229,
+   0x540F, 0x5C65, 0x674E, 0x68A8, 0x7406, 0x7483},
+  {				/* category 46 */
+   0x75E2, 0x88CF, 0x88E1, 0x91CC, 0x96E2, 0x9678, 0x5F8B, 0x7387,
+   0x7ACB, 0x844E, 0x63A0, 0x7565, 0x5289, 0x6D41, 0x6E9C, 0x7409,
+   0x7559, 0x786B, 0x7C92, 0x9686, 0x7ADC, 0x9F8D, 0x4FB6, 0x616E,
+   0x65C5, 0x865C, 0x4E86, 0x4EAE, 0x50DA, 0x4E21, 0x51CC, 0x5BEE,
+   0x6599, 0x6881, 0x6DBC, 0x731F, 0x7642, 0x77AD, 0x7A1C, 0x7CE7,
+   0x826F, 0x8AD2, 0x907C, 0x91CF, 0x9675, 0x9818, 0x529B, 0x7DD1,
+   0x502B, 0x5398, 0x6797, 0x6DCB, 0x71D0, 0x7433, 0x81E8, 0x8F2A,
+   0x96A3, 0x9C57, 0x9E9F, 0x7460, 0x5841, 0x6D99, 0x7D2F, 0x985E,
+   0x4EE4, 0x4F36, 0x4F8B, 0x51B7, 0x52B1, 0x5DBA, 0x601C, 0x73B2,
+   0x793C, 0x82D3, 0x9234, 0x96B7, 0x96F6, 0x970A, 0x9E97, 0x9F62,
+   0x66A6, 0x6B74, 0x5217, 0x52A3, 0x70C8, 0x88C2, 0x5EC9, 0x604B,
+   0x6190, 0x6F23, 0x7149, 0x7C3E, 0x7DF4, 0x806F},
+  {				/* category 47 */
+   0x84EE, 0x9023, 0x932C, 0x5442, 0x9B6F, 0x6AD3, 0x7089, 0x8CC2,
+   0x8DEF, 0x9732, 0x52B4, 0x5A41, 0x5ECA, 0x5F04, 0x6717, 0x697C,
+   0x6994, 0x6D6A, 0x6F0F, 0x7262, 0x72FC, 0x7BED, 0x8001, 0x807E,
+   0x874B, 0x90CE, 0x516D, 0x9E93, 0x7984, 0x808B, 0x9332, 0x8AD6,
+   0x502D, 0x548C, 0x8A71, 0x6B6A, 0x8CC4, 0x8107, 0x60D1, 0x67A0,
+   0x9DF2, 0x4E99, 0x4E98, 0x9C10, 0x8A6B, 0x85C1, 0x8568, 0x6900,
+   0x6E7E, 0x7897, 0x8155, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000},
+  {				/* category 48 */
+   0x5F0C, 0x4E10, 0x4E15, 0x4E2A, 0x4E31, 0x4E36, 0x4E3C, 0x4E3F,
+   0x4E42, 0x4E56, 0x4E58, 0x4E82, 0x4E85, 0x8C6B, 0x4E8A, 0x8212,
+   0x5F0D, 0x4E8E, 0x4E9E, 0x4E9F, 0x4EA0, 0x4EA2, 0x4EB0, 0x4EB3,
+   0x4EB6, 0x4ECE, 0x4ECD, 0x4EC4, 0x4EC6, 0x4EC2, 0x4ED7, 0x4EDE,
+   0x4EED, 0x4EDF, 0x4EF7, 0x4F09, 0x4F5A, 0x4F30, 0x4F5B, 0x4F5D,
+   0x4F57, 0x4F47, 0x4F76, 0x4F88, 0x4F8F, 0x4F98, 0x4F7B, 0x4F69,
+   0x4F70, 0x4F91, 0x4F6F, 0x4F86, 0x4F96, 0x5118, 0x4FD4, 0x4FDF,
+   0x4FCE, 0x4FD8, 0x4FDB, 0x4FD1, 0x4FDA, 0x4FD0, 0x4FE4, 0x4FE5,
+   0x501A, 0x5028, 0x5014, 0x502A, 0x5025, 0x5005, 0x4F1C, 0x4FF6,
+   0x5021, 0x5029, 0x502C, 0x4FFE, 0x4FEF, 0x5011, 0x5006, 0x5043,
+   0x5047, 0x6703, 0x5055, 0x5050, 0x5048, 0x505A, 0x5056, 0x506C,
+   0x5078, 0x5080, 0x509A, 0x5085, 0x50B4, 0x50B2},
+  {				/* category 49 */
+   0x50C9, 0x50CA, 0x50B3, 0x50C2, 0x50D6, 0x50DE, 0x50E5, 0x50ED,
+   0x50E3, 0x50EE, 0x50F9, 0x50F5, 0x5109, 0x5101, 0x5102, 0x5116,
+   0x5115, 0x5114, 0x511A, 0x5121, 0x513A, 0x5137, 0x513C, 0x513B,
+   0x513F, 0x5140, 0x5152, 0x514C, 0x5154, 0x5162, 0x7AF8, 0x5169,
+   0x516A, 0x516E, 0x5180, 0x5182, 0x56D8, 0x518C, 0x5189, 0x518F,
+   0x5191, 0x5193, 0x5195, 0x5196, 0x51A4, 0x51A6, 0x51A2, 0x51A9,
+   0x51AA, 0x51AB, 0x51B3, 0x51B1, 0x51B2, 0x51B0, 0x51B5, 0x51BD,
+   0x51C5, 0x51C9, 0x51DB, 0x51E0, 0x8655, 0x51E9, 0x51ED, 0x51F0,
+   0x51F5, 0x51FE, 0x5204, 0x520B, 0x5214, 0x520E, 0x5227, 0x522A,
+   0x522E, 0x5233, 0x5239, 0x524F, 0x5244, 0x524B, 0x524C, 0x525E,
+   0x5254, 0x526A, 0x5274, 0x5269, 0x5273, 0x527F, 0x527D, 0x528D,
+   0x5294, 0x5292, 0x5271, 0x5288, 0x5291, 0x8FA8},
+  {				/* category 50 */
+   0x8FA7, 0x52AC, 0x52AD, 0x52BC, 0x52B5, 0x52C1, 0x52CD, 0x52D7,
+   0x52DE, 0x52E3, 0x52E6, 0x98ED, 0x52E0, 0x52F3, 0x52F5, 0x52F8,
+   0x52F9, 0x5306, 0x5308, 0x7538, 0x530D, 0x5310, 0x530F, 0x5315,
+   0x531A, 0x5323, 0x532F, 0x5331, 0x5333, 0x5338, 0x5340, 0x5346,
+   0x5345, 0x4E17, 0x5349, 0x534D, 0x51D6, 0x535E, 0x5369, 0x536E,
+   0x5918, 0x537B, 0x5377, 0x5382, 0x5396, 0x53A0, 0x53A6, 0x53A5,
+   0x53AE, 0x53B0, 0x53B6, 0x53C3, 0x7C12, 0x96D9, 0x53DF, 0x66FC,
+   0x71EE, 0x53EE, 0x53E8, 0x53ED, 0x53FA, 0x5401, 0x543D, 0x5440,
+   0x542C, 0x542D, 0x543C, 0x542E, 0x5436, 0x5429, 0x541D, 0x544E,
+   0x548F, 0x5475, 0x548E, 0x545F, 0x5471, 0x5477, 0x5470, 0x5492,
+   0x547B, 0x5480, 0x5476, 0x5484, 0x5490, 0x5486, 0x54C7, 0x54A2,
+   0x54B8, 0x54A5, 0x54AC, 0x54C4, 0x54C8, 0x54A8},
+  {				/* category 51 */
+   0x54AB, 0x54C2, 0x54A4, 0x54BE, 0x54BC, 0x54D8, 0x54E5, 0x54E6,
+   0x550F, 0x5514, 0x54FD, 0x54EE, 0x54ED, 0x54FA, 0x54E2, 0x5539,
+   0x5540, 0x5563, 0x554C, 0x552E, 0x555C, 0x5545, 0x5556, 0x5557,
+   0x5538, 0x5533, 0x555D, 0x5599, 0x5580, 0x54AF, 0x558A, 0x559F,
+   0x557B, 0x557E, 0x5598, 0x559E, 0x55AE, 0x557C, 0x5583, 0x55A9,
+   0x5587, 0x55A8, 0x55DA, 0x55C5, 0x55DF, 0x55C4, 0x55DC, 0x55E4,
+   0x55D4, 0x5614, 0x55F7, 0x5616, 0x55FE, 0x55FD, 0x561B, 0x55F9,
+   0x564E, 0x5650, 0x71DF, 0x5634, 0x5636, 0x5632, 0x5638, 0x566B,
+   0x5664, 0x562F, 0x566C, 0x566A, 0x5686, 0x5680, 0x568A, 0x56A0,
+   0x5694, 0x568F, 0x56A5, 0x56AE, 0x56B6, 0x56B4, 0x56C2, 0x56BC,
+   0x56C1, 0x56C3, 0x56C0, 0x56C8, 0x56CE, 0x56D1, 0x56D3, 0x56D7,
+   0x56EE, 0x56F9, 0x5700, 0x56FF, 0x5704, 0x5709},
+  {				/* category 52 */
+   0x5708, 0x570B, 0x570D, 0x5713, 0x5718, 0x5716, 0x55C7, 0x571C,
+   0x5726, 0x5737, 0x5738, 0x574E, 0x573B, 0x5740, 0x574F, 0x5769,
+   0x57C0, 0x5788, 0x5761, 0x577F, 0x5789, 0x5793, 0x57A0, 0x57B3,
+   0x57A4, 0x57AA, 0x57B0, 0x57C3, 0x57C6, 0x57D4, 0x57D2, 0x57D3,
+   0x580A, 0x57D6, 0x57E3, 0x580B, 0x5819, 0x581D, 0x5872, 0x5821,
+   0x5862, 0x584B, 0x5870, 0x6BC0, 0x5852, 0x583D, 0x5879, 0x5885,
+   0x58B9, 0x589F, 0x58AB, 0x58BA, 0x58DE, 0x58BB, 0x58B8, 0x58AE,
+   0x58C5, 0x58D3, 0x58D1, 0x58D7, 0x58D9, 0x58D8, 0x58E5, 0x58DC,
+   0x58E4, 0x58DF, 0x58EF, 0x58FA, 0x58F9, 0x58FB, 0x58FC, 0x58FD,
+   0x5902, 0x590A, 0x5910, 0x591B, 0x68A6, 0x5925, 0x592C, 0x592D,
+   0x5932, 0x5938, 0x593E, 0x7AD2, 0x5955, 0x5950, 0x594E, 0x595A,
+   0x5958, 0x5962, 0x5960, 0x5967, 0x596C, 0x5969},
+  {				/* category 53 */
+   0x5978, 0x5981, 0x599D, 0x4F5E, 0x4FAB, 0x59A3, 0x59B2, 0x59C6,
+   0x59E8, 0x59DC, 0x598D, 0x59D9, 0x59DA, 0x5A25, 0x5A1F, 0x5A11,
+   0x5A1C, 0x5A09, 0x5A1A, 0x5A40, 0x5A6C, 0x5A49, 0x5A35, 0x5A36,
+   0x5A62, 0x5A6A, 0x5A9A, 0x5ABC, 0x5ABE, 0x5ACB, 0x5AC2, 0x5ABD,
+   0x5AE3, 0x5AD7, 0x5AE6, 0x5AE9, 0x5AD6, 0x5AFA, 0x5AFB, 0x5B0C,
+   0x5B0B, 0x5B16, 0x5B32, 0x5AD0, 0x5B2A, 0x5B36, 0x5B3E, 0x5B43,
+   0x5B45, 0x5B40, 0x5B51, 0x5B55, 0x5B5A, 0x5B5B, 0x5B65, 0x5B69,
+   0x5B70, 0x5B73, 0x5B75, 0x5B78, 0x6588, 0x5B7A, 0x5B80, 0x5B83,
+   0x5BA6, 0x5BB8, 0x5BC3, 0x5BC7, 0x5BC9, 0x5BD4, 0x5BD0, 0x5BE4,
+   0x5BE6, 0x5BE2, 0x5BDE, 0x5BE5, 0x5BEB, 0x5BF0, 0x5BF6, 0x5BF3,
+   0x5C05, 0x5C07, 0x5C08, 0x5C0D, 0x5C13, 0x5C20, 0x5C22, 0x5C28,
+   0x5C38, 0x5C39, 0x5C41, 0x5C46, 0x5C4E, 0x5C53},
+  {				/* category 54 */
+   0x5C50, 0x5C4F, 0x5B71, 0x5C6C, 0x5C6E, 0x4E62, 0x5C76, 0x5C79,
+   0x5C8C, 0x5C91, 0x5C94, 0x599B, 0x5CAB, 0x5CBB, 0x5CB6, 0x5CBC,
+   0x5CB7, 0x5CC5, 0x5CBE, 0x5CC7, 0x5CD9, 0x5CE9, 0x5CFD, 0x5CFA,
+   0x5CED, 0x5D8C, 0x5CEA, 0x5D0B, 0x5D15, 0x5D17, 0x5D5C, 0x5D1F,
+   0x5D1B, 0x5D11, 0x5D14, 0x5D22, 0x5D1A, 0x5D19, 0x5D18, 0x5D4C,
+   0x5D52, 0x5D4E, 0x5D4B, 0x5D6C, 0x5D73, 0x5D76, 0x5D87, 0x5D84,
+   0x5D82, 0x5DA2, 0x5D9D, 0x5DAC, 0x5DAE, 0x5DBD, 0x5D90, 0x5DB7,
+   0x5DBC, 0x5DC9, 0x5DCD, 0x5DD3, 0x5DD2, 0x5DD6, 0x5DDB, 0x5DEB,
+   0x5DF2, 0x5DF5, 0x5E0B, 0x5E1A, 0x5E19, 0x5E11, 0x5E1B, 0x5E36,
+   0x5E37, 0x5E44, 0x5E43, 0x5E40, 0x5E4E, 0x5E57, 0x5E54, 0x5E5F,
+   0x5E62, 0x5E64, 0x5E47, 0x5E75, 0x5E76, 0x5E7A, 0x9EBC, 0x5E7F,
+   0x5EA0, 0x5EC1, 0x5EC2, 0x5EC8, 0x5ED0, 0x5ECF},
+  {				/* category 55 */
+   0x5ED6, 0x5EE3, 0x5EDD, 0x5EDA, 0x5EDB, 0x5EE2, 0x5EE1, 0x5EE8,
+   0x5EE9, 0x5EEC, 0x5EF1, 0x5EF3, 0x5EF0, 0x5EF4, 0x5EF8, 0x5EFE,
+   0x5F03, 0x5F09, 0x5F5D, 0x5F5C, 0x5F0B, 0x5F11, 0x5F16, 0x5F29,
+   0x5F2D, 0x5F38, 0x5F41, 0x5F48, 0x5F4C, 0x5F4E, 0x5F2F, 0x5F51,
+   0x5F56, 0x5F57, 0x5F59, 0x5F61, 0x5F6D, 0x5F73, 0x5F77, 0x5F83,
+   0x5F82, 0x5F7F, 0x5F8A, 0x5F88, 0x5F91, 0x5F87, 0x5F9E, 0x5F99,
+   0x5F98, 0x5FA0, 0x5FA8, 0x5FAD, 0x5FBC, 0x5FD6, 0x5FFB, 0x5FE4,
+   0x5FF8, 0x5FF1, 0x5FDD, 0x60B3, 0x5FFF, 0x6021, 0x6060, 0x6019,
+   0x6010, 0x6029, 0x600E, 0x6031, 0x601B, 0x6015, 0x602B, 0x6026,
+   0x600F, 0x603A, 0x605A, 0x6041, 0x606A, 0x6077, 0x605F, 0x604A,
+   0x6046, 0x604D, 0x6063, 0x6043, 0x6064, 0x6042, 0x606C, 0x606B,
+   0x6059, 0x6081, 0x608D, 0x60E7, 0x6083, 0x609A},
+  {				/* category 56 */
+   0x6084, 0x609B, 0x6096, 0x6097, 0x6092, 0x60A7, 0x608B, 0x60E1,
+   0x60B8, 0x60E0, 0x60D3, 0x60B4, 0x5FF0, 0x60BD, 0x60C6, 0x60B5,
+   0x60D8, 0x614D, 0x6115, 0x6106, 0x60F6, 0x60F7, 0x6100, 0x60F4,
+   0x60FA, 0x6103, 0x6121, 0x60FB, 0x60F1, 0x610D, 0x610E, 0x6147,
+   0x613E, 0x6128, 0x6127, 0x614A, 0x613F, 0x613C, 0x612C, 0x6134,
+   0x613D, 0x6142, 0x6144, 0x6173, 0x6177, 0x6158, 0x6159, 0x615A,
+   0x616B, 0x6174, 0x616F, 0x6165, 0x6171, 0x615F, 0x615D, 0x6153,
+   0x6175, 0x6199, 0x6196, 0x6187, 0x61AC, 0x6194, 0x619A, 0x618A,
+   0x6191, 0x61AB, 0x61AE, 0x61CC, 0x61CA, 0x61C9, 0x61F7, 0x61C8,
+   0x61C3, 0x61C6, 0x61BA, 0x61CB, 0x7F79, 0x61CD, 0x61E6, 0x61E3,
+   0x61F6, 0x61FA, 0x61F4, 0x61FF, 0x61FD, 0x61FC, 0x61FE, 0x6200,
+   0x6208, 0x6209, 0x620D, 0x620C, 0x6214, 0x621B},
+  {				/* category 57 */
+   0x621E, 0x6221, 0x622A, 0x622E, 0x6230, 0x6232, 0x6233, 0x6241,
+   0x624E, 0x625E, 0x6263, 0x625B, 0x6260, 0x6268, 0x627C, 0x6282,
+   0x6289, 0x627E, 0x6292, 0x6293, 0x6296, 0x62D4, 0x6283, 0x6294,
+   0x62D7, 0x62D1, 0x62BB, 0x62CF, 0x62FF, 0x62C6, 0x64D4, 0x62C8,
+   0x62DC, 0x62CC, 0x62CA, 0x62C2, 0x62C7, 0x629B, 0x62C9, 0x630C,
+   0x62EE, 0x62F1, 0x6327, 0x6302, 0x6308, 0x62EF, 0x62F5, 0x6350,
+   0x633E, 0x634D, 0x641C, 0x634F, 0x6396, 0x638E, 0x6380, 0x63AB,
+   0x6376, 0x63A3, 0x638F, 0x6389, 0x639F, 0x63B5, 0x636B, 0x6369,
+   0x63BE, 0x63E9, 0x63C0, 0x63C6, 0x63E3, 0x63C9, 0x63D2, 0x63F6,
+   0x63C4, 0x6416, 0x6434, 0x6406, 0x6413, 0x6426, 0x6436, 0x651D,
+   0x6417, 0x6428, 0x640F, 0x6467, 0x646F, 0x6476, 0x644E, 0x652A,
+   0x6495, 0x6493, 0x64A5, 0x64A9, 0x6488, 0x64BC},
+  {				/* category 58 */
+   0x64DA, 0x64D2, 0x64C5, 0x64C7, 0x64BB, 0x64D8, 0x64C2, 0x64F1,
+   0x64E7, 0x8209, 0x64E0, 0x64E1, 0x62AC, 0x64E3, 0x64EF, 0x652C,
+   0x64F6, 0x64F4, 0x64F2, 0x64FA, 0x6500, 0x64FD, 0x6518, 0x651C,
+   0x6505, 0x6524, 0x6523, 0x652B, 0x6534, 0x6535, 0x6537, 0x6536,
+   0x6538, 0x754B, 0x6548, 0x6556, 0x6555, 0x654D, 0x6558, 0x655E,
+   0x655D, 0x6572, 0x6578, 0x6582, 0x6583, 0x8B8A, 0x659B, 0x659F,
+   0x65AB, 0x65B7, 0x65C3, 0x65C6, 0x65C1, 0x65C4, 0x65CC, 0x65D2,
+   0x65DB, 0x65D9, 0x65E0, 0x65E1, 0x65F1, 0x6772, 0x660A, 0x6603,
+   0x65FB, 0x6773, 0x6635, 0x6636, 0x6634, 0x661C, 0x664F, 0x6644,
+   0x6649, 0x6641, 0x665E, 0x665D, 0x6664, 0x6667, 0x6668, 0x665F,
+   0x6662, 0x6670, 0x6683, 0x6688, 0x668E, 0x6689, 0x6684, 0x6698,
+   0x669D, 0x66C1, 0x66B9, 0x66C9, 0x66BE, 0x66BC},
+  {				/* category 59 */
+   0x66C4, 0x66B8, 0x66D6, 0x66DA, 0x66E0, 0x663F, 0x66E6, 0x66E9,
+   0x66F0, 0x66F5, 0x66F7, 0x670F, 0x6716, 0x671E, 0x6726, 0x6727,
+   0x9738, 0x672E, 0x673F, 0x6736, 0x6741, 0x6738, 0x6737, 0x6746,
+   0x675E, 0x6760, 0x6759, 0x6763, 0x6764, 0x6789, 0x6770, 0x67A9,
+   0x677C, 0x676A, 0x678C, 0x678B, 0x67A6, 0x67A1, 0x6785, 0x67B7,
+   0x67EF, 0x67B4, 0x67EC, 0x67B3, 0x67E9, 0x67B8, 0x67E4, 0x67DE,
+   0x67DD, 0x67E2, 0x67EE, 0x67B9, 0x67CE, 0x67C6, 0x67E7, 0x6A9C,
+   0x681E, 0x6846, 0x6829, 0x6840, 0x684D, 0x6832, 0x684E, 0x68B3,
+   0x682B, 0x6859, 0x6863, 0x6877, 0x687F, 0x689F, 0x688F, 0x68AD,
+   0x6894, 0x689D, 0x689B, 0x6883, 0x6AAE, 0x68B9, 0x6874, 0x68B5,
+   0x68A0, 0x68BA, 0x690F, 0x688D, 0x687E, 0x6901, 0x68CA, 0x6908,
+   0x68D8, 0x6922, 0x6926, 0x68E1, 0x690C, 0x68CD},
+  {				/* category 60 */
+   0x68D4, 0x68E7, 0x68D5, 0x6936, 0x6912, 0x6904, 0x68D7, 0x68E3,
+   0x6925, 0x68F9, 0x68E0, 0x68EF, 0x6928, 0x692A, 0x691A, 0x6923,
+   0x6921, 0x68C6, 0x6979, 0x6977, 0x695C, 0x6978, 0x696B, 0x6954,
+   0x697E, 0x696E, 0x6939, 0x6974, 0x693D, 0x6959, 0x6930, 0x6961,
+   0x695E, 0x695D, 0x6981, 0x696A, 0x69B2, 0x69AE, 0x69D0, 0x69BF,
+   0x69C1, 0x69D3, 0x69BE, 0x69CE, 0x5BE8, 0x69CA, 0x69DD, 0x69BB,
+   0x69C3, 0x69A7, 0x6A2E, 0x6991, 0x69A0, 0x699C, 0x6995, 0x69B4,
+   0x69DE, 0x69E8, 0x6A02, 0x6A1B, 0x69FF, 0x6B0A, 0x69F9, 0x69F2,
+   0x69E7, 0x6A05, 0x69B1, 0x6A1E, 0x69ED, 0x6A14, 0x69EB, 0x6A0A,
+   0x6A12, 0x6AC1, 0x6A23, 0x6A13, 0x6A44, 0x6A0C, 0x6A72, 0x6A36,
+   0x6A78, 0x6A47, 0x6A62, 0x6A59, 0x6A66, 0x6A48, 0x6A38, 0x6A22,
+   0x6A90, 0x6A8D, 0x6AA0, 0x6A84, 0x6AA2, 0x6AA3},
+  {				/* category 61 */
+   0x6A97, 0x8617, 0x6ABB, 0x6AC3, 0x6AC2, 0x6AB8, 0x6AB3, 0x6AAC,
+   0x6ADE, 0x6AD1, 0x6ADF, 0x6AAA, 0x6ADA, 0x6AEA, 0x6AFB, 0x6B05,
+   0x8616, 0x6AFA, 0x6B12, 0x6B16, 0x9B31, 0x6B1F, 0x6B38, 0x6B37,
+   0x76DC, 0x6B39, 0x98EE, 0x6B47, 0x6B43, 0x6B49, 0x6B50, 0x6B59,
+   0x6B54, 0x6B5B, 0x6B5F, 0x6B61, 0x6B78, 0x6B79, 0x6B7F, 0x6B80,
+   0x6B84, 0x6B83, 0x6B8D, 0x6B98, 0x6B95, 0x6B9E, 0x6BA4, 0x6BAA,
+   0x6BAB, 0x6BAF, 0x6BB2, 0x6BB1, 0x6BB3, 0x6BB7, 0x6BBC, 0x6BC6,
+   0x6BCB, 0x6BD3, 0x6BDF, 0x6BEC, 0x6BEB, 0x6BF3, 0x6BEF, 0x9EBE,
+   0x6C08, 0x6C13, 0x6C14, 0x6C1B, 0x6C24, 0x6C23, 0x6C5E, 0x6C55,
+   0x6C62, 0x6C6A, 0x6C82, 0x6C8D, 0x6C9A, 0x6C81, 0x6C9B, 0x6C7E,
+   0x6C68, 0x6C73, 0x6C92, 0x6C90, 0x6CC4, 0x6CF1, 0x6CD3, 0x6CBD,
+   0x6CD7, 0x6CC5, 0x6CDD, 0x6CAE, 0x6CB1, 0x6CBE},
+  {				/* category 62 */
+   0x6CBA, 0x6CDB, 0x6CEF, 0x6CD9, 0x6CEA, 0x6D1F, 0x884D, 0x6D36,
+   0x6D2B, 0x6D3D, 0x6D38, 0x6D19, 0x6D35, 0x6D33, 0x6D12, 0x6D0C,
+   0x6D63, 0x6D93, 0x6D64, 0x6D5A, 0x6D79, 0x6D59, 0x6D8E, 0x6D95,
+   0x6FE4, 0x6D85, 0x6DF9, 0x6E15, 0x6E0A, 0x6DB5, 0x6DC7, 0x6DE6,
+   0x6DB8, 0x6DC6, 0x6DEC, 0x6DDE, 0x6DCC, 0x6DE8, 0x6DD2, 0x6DC5,
+   0x6DFA, 0x6DD9, 0x6DE4, 0x6DD5, 0x6DEA, 0x6DEE, 0x6E2D, 0x6E6E,
+   0x6E2E, 0x6E19, 0x6E72, 0x6E5F, 0x6E3E, 0x6E23, 0x6E6B, 0x6E2B,
+   0x6E76, 0x6E4D, 0x6E1F, 0x6E43, 0x6E3A, 0x6E4E, 0x6E24, 0x6EFF,
+   0x6E1D, 0x6E38, 0x6E82, 0x6EAA, 0x6E98, 0x6EC9, 0x6EB7, 0x6ED3,
+   0x6EBD, 0x6EAF, 0x6EC4, 0x6EB2, 0x6ED4, 0x6ED5, 0x6E8F, 0x6EA5,
+   0x6EC2, 0x6E9F, 0x6F41, 0x6F11, 0x704C, 0x6EEC, 0x6EF8, 0x6EFE,
+   0x6F3F, 0x6EF2, 0x6F31, 0x6EEF, 0x6F32, 0x6ECC},
+  {				/* category 63 */
+   0x6F3E, 0x6F13, 0x6EF7, 0x6F86, 0x6F7A, 0x6F78, 0x6F81, 0x6F80,
+   0x6F6F, 0x6F5B, 0x6FF3, 0x6F6D, 0x6F82, 0x6F7C, 0x6F58, 0x6F8E,
+   0x6F91, 0x6FC2, 0x6F66, 0x6FB3, 0x6FA3, 0x6FA1, 0x6FA4, 0x6FB9,
+   0x6FC6, 0x6FAA, 0x6FDF, 0x6FD5, 0x6FEC, 0x6FD4, 0x6FD8, 0x6FF1,
+   0x6FEE, 0x6FDB, 0x7009, 0x700B, 0x6FFA, 0x7011, 0x7001, 0x700F,
+   0x6FFE, 0x701B, 0x701A, 0x6F74, 0x701D, 0x7018, 0x701F, 0x7030,
+   0x703E, 0x7032, 0x7051, 0x7063, 0x7099, 0x7092, 0x70AF, 0x70F1,
+   0x70AC, 0x70B8, 0x70B3, 0x70AE, 0x70DF, 0x70CB, 0x70DD, 0x70D9,
+   0x7109, 0x70FD, 0x711C, 0x7119, 0x7165, 0x7155, 0x7188, 0x7166,
+   0x7162, 0x714C, 0x7156, 0x716C, 0x718F, 0x71FB, 0x7184, 0x7195,
+   0x71A8, 0x71AC, 0x71D7, 0x71B9, 0x71BE, 0x71D2, 0x71C9, 0x71D4,
+   0x71CE, 0x71E0, 0x71EC, 0x71E7, 0x71F5, 0x71FC},
+  {				/* category 64 */
+   0x71F9, 0x71FF, 0x720D, 0x7210, 0x721B, 0x7228, 0x722D, 0x722C,
+   0x7230, 0x7232, 0x723B, 0x723C, 0x723F, 0x7240, 0x7246, 0x724B,
+   0x7258, 0x7274, 0x727E, 0x7282, 0x7281, 0x7287, 0x7292, 0x7296,
+   0x72A2, 0x72A7, 0x72B9, 0x72B2, 0x72C3, 0x72C6, 0x72C4, 0x72CE,
+   0x72D2, 0x72E2, 0x72E0, 0x72E1, 0x72F9, 0x72F7, 0x500F, 0x7317,
+   0x730A, 0x731C, 0x7316, 0x731D, 0x7334, 0x732F, 0x7329, 0x7325,
+   0x733E, 0x734E, 0x734F, 0x9ED8, 0x7357, 0x736A, 0x7368, 0x7370,
+   0x7378, 0x7375, 0x737B, 0x737A, 0x73C8, 0x73B3, 0x73CE, 0x73BB,
+   0x73C0, 0x73E5, 0x73EE, 0x73DE, 0x74A2, 0x7405, 0x746F, 0x7425,
+   0x73F8, 0x7432, 0x743A, 0x7455, 0x743F, 0x745F, 0x7459, 0x7441,
+   0x745C, 0x7469, 0x7470, 0x7463, 0x746A, 0x7476, 0x747E, 0x748B,
+   0x749E, 0x74A7, 0x74CA, 0x74CF, 0x74D4, 0x73F1},
+  {				/* category 65 */
+   0x74E0, 0x74E3, 0x74E7, 0x74E9, 0x74EE, 0x74F2, 0x74F0, 0x74F1,
+   0x74F8, 0x74F7, 0x7504, 0x7503, 0x7505, 0x750C, 0x750E, 0x750D,
+   0x7515, 0x7513, 0x751E, 0x7526, 0x752C, 0x753C, 0x7544, 0x754D,
+   0x754A, 0x7549, 0x755B, 0x7546, 0x755A, 0x7569, 0x7564, 0x7567,
+   0x756B, 0x756D, 0x7578, 0x7576, 0x7586, 0x7587, 0x7574, 0x758A,
+   0x7589, 0x7582, 0x7594, 0x759A, 0x759D, 0x75A5, 0x75A3, 0x75C2,
+   0x75B3, 0x75C3, 0x75B5, 0x75BD, 0x75B8, 0x75BC, 0x75B1, 0x75CD,
+   0x75CA, 0x75D2, 0x75D9, 0x75E3, 0x75DE, 0x75FE, 0x75FF, 0x75FC,
+   0x7601, 0x75F0, 0x75FA, 0x75F2, 0x75F3, 0x760B, 0x760D, 0x7609,
+   0x761F, 0x7627, 0x7620, 0x7621, 0x7622, 0x7624, 0x7634, 0x7630,
+   0x763B, 0x7647, 0x7648, 0x7646, 0x765C, 0x7658, 0x7661, 0x7662,
+   0x7668, 0x7669, 0x766A, 0x7667, 0x766C, 0x7670},
+  {				/* category 66 */
+   0x7672, 0x7676, 0x7678, 0x767C, 0x7680, 0x7683, 0x7688, 0x768B,
+   0x768E, 0x7696, 0x7693, 0x7699, 0x769A, 0x76B0, 0x76B4, 0x76B8,
+   0x76B9, 0x76BA, 0x76C2, 0x76CD, 0x76D6, 0x76D2, 0x76DE, 0x76E1,
+   0x76E5, 0x76E7, 0x76EA, 0x862F, 0x76FB, 0x7708, 0x7707, 0x7704,
+   0x7729, 0x7724, 0x771E, 0x7725, 0x7726, 0x771B, 0x7737, 0x7738,
+   0x7747, 0x775A, 0x7768, 0x776B, 0x775B, 0x7765, 0x777F, 0x777E,
+   0x7779, 0x778E, 0x778B, 0x7791, 0x77A0, 0x779E, 0x77B0, 0x77B6,
+   0x77B9, 0x77BF, 0x77BC, 0x77BD, 0x77BB, 0x77C7, 0x77CD, 0x77D7,
+   0x77DA, 0x77DC, 0x77E3, 0x77EE, 0x77FC, 0x780C, 0x7812, 0x7926,
+   0x7820, 0x792A, 0x7845, 0x788E, 0x7874, 0x7886, 0x787C, 0x789A,
+   0x788C, 0x78A3, 0x78B5, 0x78AA, 0x78AF, 0x78D1, 0x78C6, 0x78CB,
+   0x78D4, 0x78BE, 0x78BC, 0x78C5, 0x78CA, 0x78EC},
+  {				/* category 67 */
+   0x78E7, 0x78DA, 0x78FD, 0x78F4, 0x7907, 0x7912, 0x7911, 0x7919,
+   0x792C, 0x792B, 0x7940, 0x7960, 0x7957, 0x795F, 0x795A, 0x7955,
+   0x7953, 0x797A, 0x797F, 0x798A, 0x799D, 0x79A7, 0x9F4B, 0x79AA,
+   0x79AE, 0x79B3, 0x79B9, 0x79BA, 0x79C9, 0x79D5, 0x79E7, 0x79EC,
+   0x79E1, 0x79E3, 0x7A08, 0x7A0D, 0x7A18, 0x7A19, 0x7A20, 0x7A1F,
+   0x7980, 0x7A31, 0x7A3B, 0x7A3E, 0x7A37, 0x7A43, 0x7A57, 0x7A49,
+   0x7A61, 0x7A62, 0x7A69, 0x9F9D, 0x7A70, 0x7A79, 0x7A7D, 0x7A88,
+   0x7A97, 0x7A95, 0x7A98, 0x7A96, 0x7AA9, 0x7AC8, 0x7AB0, 0x7AB6,
+   0x7AC5, 0x7AC4, 0x7ABF, 0x9083, 0x7AC7, 0x7ACA, 0x7ACD, 0x7ACF,
+   0x7AD5, 0x7AD3, 0x7AD9, 0x7ADA, 0x7ADD, 0x7AE1, 0x7AE2, 0x7AE6,
+   0x7AED, 0x7AF0, 0x7B02, 0x7B0F, 0x7B0A, 0x7B06, 0x7B33, 0x7B18,
+   0x7B19, 0x7B1E, 0x7B35, 0x7B28, 0x7B36, 0x7B50},
+  {				/* category 68 */
+   0x7B7A, 0x7B04, 0x7B4D, 0x7B0B, 0x7B4C, 0x7B45, 0x7B75, 0x7B65,
+   0x7B74, 0x7B67, 0x7B70, 0x7B71, 0x7B6C, 0x7B6E, 0x7B9D, 0x7B98,
+   0x7B9F, 0x7B8D, 0x7B9C, 0x7B9A, 0x7B8B, 0x7B92, 0x7B8F, 0x7B5D,
+   0x7B99, 0x7BCB, 0x7BC1, 0x7BCC, 0x7BCF, 0x7BB4, 0x7BC6, 0x7BDD,
+   0x7BE9, 0x7C11, 0x7C14, 0x7BE6, 0x7BE5, 0x7C60, 0x7C00, 0x7C07,
+   0x7C13, 0x7BF3, 0x7BF7, 0x7C17, 0x7C0D, 0x7BF6, 0x7C23, 0x7C27,
+   0x7C2A, 0x7C1F, 0x7C37, 0x7C2B, 0x7C3D, 0x7C4C, 0x7C43, 0x7C54,
+   0x7C4F, 0x7C40, 0x7C50, 0x7C58, 0x7C5F, 0x7C64, 0x7C56, 0x7C65,
+   0x7C6C, 0x7C75, 0x7C83, 0x7C90, 0x7CA4, 0x7CAD, 0x7CA2, 0x7CAB,
+   0x7CA1, 0x7CA8, 0x7CB3, 0x7CB2, 0x7CB1, 0x7CAE, 0x7CB9, 0x7CBD,
+   0x7CC0, 0x7CC5, 0x7CC2, 0x7CD8, 0x7CD2, 0x7CDC, 0x7CE2, 0x9B3B,
+   0x7CEF, 0x7CF2, 0x7CF4, 0x7CF6, 0x7CFA, 0x7D06},
+  {				/* category 69 */
+   0x7D02, 0x7D1C, 0x7D15, 0x7D0A, 0x7D45, 0x7D4B, 0x7D2E, 0x7D32,
+   0x7D3F, 0x7D35, 0x7D46, 0x7D73, 0x7D56, 0x7D4E, 0x7D72, 0x7D68,
+   0x7D6E, 0x7D4F, 0x7D63, 0x7D93, 0x7D89, 0x7D5B, 0x7D8F, 0x7D7D,
+   0x7D9B, 0x7DBA, 0x7DAE, 0x7DA3, 0x7DB5, 0x7DC7, 0x7DBD, 0x7DAB,
+   0x7E3D, 0x7DA2, 0x7DAF, 0x7DDC, 0x7DB8, 0x7D9F, 0x7DB0, 0x7DD8,
+   0x7DDD, 0x7DE4, 0x7DDE, 0x7DFB, 0x7DF2, 0x7DE1, 0x7E05, 0x7E0A,
+   0x7E23, 0x7E21, 0x7E12, 0x7E31, 0x7E1F, 0x7E09, 0x7E0B, 0x7E22,
+   0x7E46, 0x7E66, 0x7E3B, 0x7E35, 0x7E39, 0x7E43, 0x7E37, 0x7E32,
+   0x7E3A, 0x7E67, 0x7E5D, 0x7E56, 0x7E5E, 0x7E59, 0x7E5A, 0x7E79,
+   0x7E6A, 0x7E69, 0x7E7C, 0x7E7B, 0x7E83, 0x7DD5, 0x7E7D, 0x8FAE,
+   0x7E7F, 0x7E88, 0x7E89, 0x7E8C, 0x7E92, 0x7E90, 0x7E93, 0x7E94,
+   0x7E96, 0x7E8E, 0x7E9B, 0x7E9C, 0x7F38, 0x7F3A},
+  {				/* category 70 */
+   0x7F45, 0x7F4C, 0x7F4D, 0x7F4E, 0x7F50, 0x7F51, 0x7F55, 0x7F54,
+   0x7F58, 0x7F5F, 0x7F60, 0x7F68, 0x7F69, 0x7F67, 0x7F78, 0x7F82,
+   0x7F86, 0x7F83, 0x7F88, 0x7F87, 0x7F8C, 0x7F94, 0x7F9E, 0x7F9D,
+   0x7F9A, 0x7FA3, 0x7FAF, 0x7FB2, 0x7FB9, 0x7FAE, 0x7FB6, 0x7FB8,
+   0x8B71, 0x7FC5, 0x7FC6, 0x7FCA, 0x7FD5, 0x7FD4, 0x7FE1, 0x7FE6,
+   0x7FE9, 0x7FF3, 0x7FF9, 0x98DC, 0x8006, 0x8004, 0x800B, 0x8012,
+   0x8018, 0x8019, 0x801C, 0x8021, 0x8028, 0x803F, 0x803B, 0x804A,
+   0x8046, 0x8052, 0x8058, 0x805A, 0x805F, 0x8062, 0x8068, 0x8073,
+   0x8072, 0x8070, 0x8076, 0x8079, 0x807D, 0x807F, 0x8084, 0x8086,
+   0x8085, 0x809B, 0x8093, 0x809A, 0x80AD, 0x5190, 0x80AC, 0x80DB,
+   0x80E5, 0x80D9, 0x80DD, 0x80C4, 0x80DA, 0x80D6, 0x8109, 0x80EF,
+   0x80F1, 0x811B, 0x8129, 0x8123, 0x812F, 0x814B},
+  {				/* category 71 */
+   0x968B, 0x8146, 0x813E, 0x8153, 0x8151, 0x80FC, 0x8171, 0x816E,
+   0x8165, 0x8166, 0x8174, 0x8183, 0x8188, 0x818A, 0x8180, 0x8182,
+   0x81A0, 0x8195, 0x81A4, 0x81A3, 0x815F, 0x8193, 0x81A9, 0x81B0,
+   0x81B5, 0x81BE, 0x81B8, 0x81BD, 0x81C0, 0x81C2, 0x81BA, 0x81C9,
+   0x81CD, 0x81D1, 0x81D9, 0x81D8, 0x81C8, 0x81DA, 0x81DF, 0x81E0,
+   0x81E7, 0x81FA, 0x81FB, 0x81FE, 0x8201, 0x8202, 0x8205, 0x8207,
+   0x820A, 0x820D, 0x8210, 0x8216, 0x8229, 0x822B, 0x8238, 0x8233,
+   0x8240, 0x8259, 0x8258, 0x825D, 0x825A, 0x825F, 0x8264, 0x8262,
+   0x8268, 0x826A, 0x826B, 0x822E, 0x8271, 0x8277, 0x8278, 0x827E,
+   0x828D, 0x8292, 0x82AB, 0x829F, 0x82BB, 0x82AC, 0x82E1, 0x82E3,
+   0x82DF, 0x82D2, 0x82F4, 0x82F3, 0x82FA, 0x8393, 0x8303, 0x82FB,
+   0x82F9, 0x82DE, 0x8306, 0x82DC, 0x8309, 0x82D9},
+  {				/* category 72 */
+   0x8335, 0x8334, 0x8316, 0x8332, 0x8331, 0x8340, 0x8339, 0x8350,
+   0x8345, 0x832F, 0x832B, 0x8317, 0x8318, 0x8385, 0x839A, 0x83AA,
+   0x839F, 0x83A2, 0x8396, 0x8323, 0x838E, 0x8387, 0x838A, 0x837C,
+   0x83B5, 0x8373, 0x8375, 0x83A0, 0x8389, 0x83A8, 0x83F4, 0x8413,
+   0x83EB, 0x83CE, 0x83FD, 0x8403, 0x83D8, 0x840B, 0x83C1, 0x83F7,
+   0x8407, 0x83E0, 0x83F2, 0x840D, 0x8422, 0x8420, 0x83BD, 0x8438,
+   0x8506, 0x83FB, 0x846D, 0x842A, 0x843C, 0x855A, 0x8484, 0x8477,
+   0x846B, 0x84AD, 0x846E, 0x8482, 0x8469, 0x8446, 0x842C, 0x846F,
+   0x8479, 0x8435, 0x84CA, 0x8462, 0x84B9, 0x84BF, 0x849F, 0x84D9,
+   0x84CD, 0x84BB, 0x84DA, 0x84D0, 0x84C1, 0x84C6, 0x84D6, 0x84A1,
+   0x8521, 0x84FF, 0x84F4, 0x8517, 0x8518, 0x852C, 0x851F, 0x8515,
+   0x8514, 0x84FC, 0x8540, 0x8563, 0x8558, 0x8548},
+  {				/* category 73 */
+   0x8541, 0x8602, 0x854B, 0x8555, 0x8580, 0x85A4, 0x8588, 0x8591,
+   0x858A, 0x85A8, 0x856D, 0x8594, 0x859B, 0x85EA, 0x8587, 0x859C,
+   0x8577, 0x857E, 0x8590, 0x85C9, 0x85BA, 0x85CF, 0x85B9, 0x85D0,
+   0x85D5, 0x85DD, 0x85E5, 0x85DC, 0x85F9, 0x860A, 0x8613, 0x860B,
+   0x85FE, 0x85FA, 0x8606, 0x8622, 0x861A, 0x8630, 0x863F, 0x864D,
+   0x4E55, 0x8654, 0x865F, 0x8667, 0x8671, 0x8693, 0x86A3, 0x86A9,
+   0x86AA, 0x868B, 0x868C, 0x86B6, 0x86AF, 0x86C4, 0x86C6, 0x86B0,
+   0x86C9, 0x8823, 0x86AB, 0x86D4, 0x86DE, 0x86E9, 0x86EC, 0x86DF,
+   0x86DB, 0x86EF, 0x8712, 0x8706, 0x8708, 0x8700, 0x8703, 0x86FB,
+   0x8711, 0x8709, 0x870D, 0x86F9, 0x870A, 0x8734, 0x873F, 0x8737,
+   0x873B, 0x8725, 0x8729, 0x871A, 0x8760, 0x875F, 0x8778, 0x874C,
+   0x874E, 0x8774, 0x8757, 0x8768, 0x876E, 0x8759},
+  {				/* category 74 */
+   0x8753, 0x8763, 0x876A, 0x8805, 0x87A2, 0x879F, 0x8782, 0x87AF,
+   0x87CB, 0x87BD, 0x87C0, 0x87D0, 0x96D6, 0x87AB, 0x87C4, 0x87B3,
+   0x87C7, 0x87C6, 0x87BB, 0x87EF, 0x87F2, 0x87E0, 0x880F, 0x880D,
+   0x87FE, 0x87F6, 0x87F7, 0x880E, 0x87D2, 0x8811, 0x8816, 0x8815,
+   0x8822, 0x8821, 0x8831, 0x8836, 0x8839, 0x8827, 0x883B, 0x8844,
+   0x8842, 0x8852, 0x8859, 0x885E, 0x8862, 0x886B, 0x8881, 0x887E,
+   0x889E, 0x8875, 0x887D, 0x88B5, 0x8872, 0x8882, 0x8897, 0x8892,
+   0x88AE, 0x8899, 0x88A2, 0x888D, 0x88A4, 0x88B0, 0x88BF, 0x88B1,
+   0x88C3, 0x88C4, 0x88D4, 0x88D8, 0x88D9, 0x88DD, 0x88F9, 0x8902,
+   0x88FC, 0x88F4, 0x88E8, 0x88F2, 0x8904, 0x890C, 0x890A, 0x8913,
+   0x8943, 0x891E, 0x8925, 0x892A, 0x892B, 0x8941, 0x8944, 0x893B,
+   0x8936, 0x8938, 0x894C, 0x891D, 0x8960, 0x895E},
+  {				/* category 75 */
+   0x8966, 0x8964, 0x896D, 0x896A, 0x896F, 0x8974, 0x8977, 0x897E,
+   0x8983, 0x8988, 0x898A, 0x8993, 0x8998, 0x89A1, 0x89A9, 0x89A6,
+   0x89AC, 0x89AF, 0x89B2, 0x89BA, 0x89BD, 0x89BF, 0x89C0, 0x89DA,
+   0x89DC, 0x89DD, 0x89E7, 0x89F4, 0x89F8, 0x8A03, 0x8A16, 0x8A10,
+   0x8A0C, 0x8A1B, 0x8A1D, 0x8A25, 0x8A36, 0x8A41, 0x8A5B, 0x8A52,
+   0x8A46, 0x8A48, 0x8A7C, 0x8A6D, 0x8A6C, 0x8A62, 0x8A85, 0x8A82,
+   0x8A84, 0x8AA8, 0x8AA1, 0x8A91, 0x8AA5, 0x8AA6, 0x8A9A, 0x8AA3,
+   0x8AC4, 0x8ACD, 0x8AC2, 0x8ADA, 0x8AEB, 0x8AF3, 0x8AE7, 0x8AE4,
+   0x8AF1, 0x8B14, 0x8AE0, 0x8AE2, 0x8AF7, 0x8ADE, 0x8ADB, 0x8B0C,
+   0x8B07, 0x8B1A, 0x8AE1, 0x8B16, 0x8B10, 0x8B17, 0x8B20, 0x8B33,
+   0x97AB, 0x8B26, 0x8B2B, 0x8B3E, 0x8B28, 0x8B41, 0x8B4C, 0x8B4F,
+   0x8B4E, 0x8B49, 0x8B56, 0x8B5B, 0x8B5A, 0x8B6B},
+  {				/* category 76 */
+   0x8B5F, 0x8B6C, 0x8B6F, 0x8B74, 0x8B7D, 0x8B80, 0x8B8C, 0x8B8E,
+   0x8B92, 0x8B93, 0x8B96, 0x8B99, 0x8B9A, 0x8C3A, 0x8C41, 0x8C3F,
+   0x8C48, 0x8C4C, 0x8C4E, 0x8C50, 0x8C55, 0x8C62, 0x8C6C, 0x8C78,
+   0x8C7A, 0x8C82, 0x8C89, 0x8C85, 0x8C8A, 0x8C8D, 0x8C8E, 0x8C94,
+   0x8C7C, 0x8C98, 0x621D, 0x8CAD, 0x8CAA, 0x8CBD, 0x8CB2, 0x8CB3,
+   0x8CAE, 0x8CB6, 0x8CC8, 0x8CC1, 0x8CE4, 0x8CE3, 0x8CDA, 0x8CFD,
+   0x8CFA, 0x8CFB, 0x8D04, 0x8D05, 0x8D0A, 0x8D07, 0x8D0F, 0x8D0D,
+   0x8D10, 0x9F4E, 0x8D13, 0x8CCD, 0x8D14, 0x8D16, 0x8D67, 0x8D6D,
+   0x8D71, 0x8D73, 0x8D81, 0x8D99, 0x8DC2, 0x8DBE, 0x8DBA, 0x8DCF,
+   0x8DDA, 0x8DD6, 0x8DCC, 0x8DDB, 0x8DCB, 0x8DEA, 0x8DEB, 0x8DDF,
+   0x8DE3, 0x8DFC, 0x8E08, 0x8E09, 0x8DFF, 0x8E1D, 0x8E1E, 0x8E10,
+   0x8E1F, 0x8E42, 0x8E35, 0x8E30, 0x8E34, 0x8E4A},
+  {				/* category 77 */
+   0x8E47, 0x8E49, 0x8E4C, 0x8E50, 0x8E48, 0x8E59, 0x8E64, 0x8E60,
+   0x8E2A, 0x8E63, 0x8E55, 0x8E76, 0x8E72, 0x8E7C, 0x8E81, 0x8E87,
+   0x8E85, 0x8E84, 0x8E8B, 0x8E8A, 0x8E93, 0x8E91, 0x8E94, 0x8E99,
+   0x8EAA, 0x8EA1, 0x8EAC, 0x8EB0, 0x8EC6, 0x8EB1, 0x8EBE, 0x8EC5,
+   0x8EC8, 0x8ECB, 0x8EDB, 0x8EE3, 0x8EFC, 0x8EFB, 0x8EEB, 0x8EFE,
+   0x8F0A, 0x8F05, 0x8F15, 0x8F12, 0x8F19, 0x8F13, 0x8F1C, 0x8F1F,
+   0x8F1B, 0x8F0C, 0x8F26, 0x8F33, 0x8F3B, 0x8F39, 0x8F45, 0x8F42,
+   0x8F3E, 0x8F4C, 0x8F49, 0x8F46, 0x8F4E, 0x8F57, 0x8F5C, 0x8F62,
+   0x8F63, 0x8F64, 0x8F9C, 0x8F9F, 0x8FA3, 0x8FAD, 0x8FAF, 0x8FB7,
+   0x8FDA, 0x8FE5, 0x8FE2, 0x8FEA, 0x8FEF, 0x9087, 0x8FF4, 0x9005,
+   0x8FF9, 0x8FFA, 0x9011, 0x9015, 0x9021, 0x900D, 0x901E, 0x9016,
+   0x900B, 0x9027, 0x9036, 0x9035, 0x9039, 0x8FF8},
+  {				/* category 78 */
+   0x904F, 0x9050, 0x9051, 0x9052, 0x900E, 0x9049, 0x903E, 0x9056,
+   0x9058, 0x905E, 0x9068, 0x906F, 0x9076, 0x96A8, 0x9072, 0x9082,
+   0x907D, 0x9081, 0x9080, 0x908A, 0x9089, 0x908F, 0x90A8, 0x90AF,
+   0x90B1, 0x90B5, 0x90E2, 0x90E4, 0x6248, 0x90DB, 0x9102, 0x9112,
+   0x9119, 0x9132, 0x9130, 0x914A, 0x9156, 0x9158, 0x9163, 0x9165,
+   0x9169, 0x9173, 0x9172, 0x918B, 0x9189, 0x9182, 0x91A2, 0x91AB,
+   0x91AF, 0x91AA, 0x91B5, 0x91B4, 0x91BA, 0x91C0, 0x91C1, 0x91C9,
+   0x91CB, 0x91D0, 0x91D6, 0x91DF, 0x91E1, 0x91DB, 0x91FC, 0x91F5,
+   0x91F6, 0x921E, 0x91FF, 0x9214, 0x922C, 0x9215, 0x9211, 0x925E,
+   0x9257, 0x9245, 0x9249, 0x9264, 0x9248, 0x9295, 0x923F, 0x924B,
+   0x9250, 0x929C, 0x9296, 0x9293, 0x929B, 0x925A, 0x92CF, 0x92B9,
+   0x92B7, 0x92E9, 0x930F, 0x92FA, 0x9344, 0x932E},
+  {				/* category 79 */
+   0x9319, 0x9322, 0x931A, 0x9323, 0x933A, 0x9335, 0x933B, 0x935C,
+   0x9360, 0x937C, 0x936E, 0x9356, 0x93B0, 0x93AC, 0x93AD, 0x9394,
+   0x93B9, 0x93D6, 0x93D7, 0x93E8, 0x93E5, 0x93D8, 0x93C3, 0x93DD,
+   0x93D0, 0x93C8, 0x93E4, 0x941A, 0x9414, 0x9413, 0x9403, 0x9407,
+   0x9410, 0x9436, 0x942B, 0x9435, 0x9421, 0x943A, 0x9441, 0x9452,
+   0x9444, 0x945B, 0x9460, 0x9462, 0x945E, 0x946A, 0x9229, 0x9470,
+   0x9475, 0x9477, 0x947D, 0x945A, 0x947C, 0x947E, 0x9481, 0x947F,
+   0x9582, 0x9587, 0x958A, 0x9594, 0x9596, 0x9598, 0x9599, 0x95A0,
+   0x95A8, 0x95A7, 0x95AD, 0x95BC, 0x95BB, 0x95B9, 0x95BE, 0x95CA,
+   0x6FF6, 0x95C3, 0x95CD, 0x95CC, 0x95D5, 0x95D4, 0x95D6, 0x95DC,
+   0x95E1, 0x95E5, 0x95E2, 0x9621, 0x9628, 0x962E, 0x962F, 0x9642,
+   0x964C, 0x964F, 0x964B, 0x9677, 0x965C, 0x965E},
+  {				/* category 80 */
+   0x965D, 0x965F, 0x9666, 0x9672, 0x966C, 0x968D, 0x9698, 0x9695,
+   0x9697, 0x96AA, 0x96A7, 0x96B1, 0x96B2, 0x96B0, 0x96B4, 0x96B6,
+   0x96B8, 0x96B9, 0x96CE, 0x96CB, 0x96C9, 0x96CD, 0x894D, 0x96DC,
+   0x970D, 0x96D5, 0x96F9, 0x9704, 0x9706, 0x9708, 0x9713, 0x970E,
+   0x9711, 0x970F, 0x9716, 0x9719, 0x9724, 0x972A, 0x9730, 0x9739,
+   0x973D, 0x973E, 0x9744, 0x9746, 0x9748, 0x9742, 0x9749, 0x975C,
+   0x9760, 0x9764, 0x9766, 0x9768, 0x52D2, 0x976B, 0x9771, 0x9779,
+   0x9785, 0x977C, 0x9781, 0x977A, 0x9786, 0x978B, 0x978F, 0x9790,
+   0x979C, 0x97A8, 0x97A6, 0x97A3, 0x97B3, 0x97B4, 0x97C3, 0x97C6,
+   0x97C8, 0x97CB, 0x97DC, 0x97ED, 0x9F4F, 0x97F2, 0x7ADF, 0x97F6,
+   0x97F5, 0x980F, 0x980C, 0x9838, 0x9824, 0x9821, 0x9837, 0x983D,
+   0x9846, 0x984F, 0x984B, 0x986B, 0x986F, 0x9870},
+  {				/* category 81 */
+   0x9871, 0x9874, 0x9873, 0x98AA, 0x98AF, 0x98B1, 0x98B6, 0x98C4,
+   0x98C3, 0x98C6, 0x98E9, 0x98EB, 0x9903, 0x9909, 0x9912, 0x9914,
+   0x9918, 0x9921, 0x991D, 0x991E, 0x9924, 0x9920, 0x992C, 0x992E,
+   0x993D, 0x993E, 0x9942, 0x9949, 0x9945, 0x9950, 0x994B, 0x9951,
+   0x9952, 0x994C, 0x9955, 0x9997, 0x9998, 0x99A5, 0x99AD, 0x99AE,
+   0x99BC, 0x99DF, 0x99DB, 0x99DD, 0x99D8, 0x99D1, 0x99ED, 0x99EE,
+   0x99F1, 0x99F2, 0x99FB, 0x99F8, 0x9A01, 0x9A0F, 0x9A05, 0x99E2,
+   0x9A19, 0x9A2B, 0x9A37, 0x9A45, 0x9A42, 0x9A40, 0x9A43, 0x9A3E,
+   0x9A55, 0x9A4D, 0x9A5B, 0x9A57, 0x9A5F, 0x9A62, 0x9A65, 0x9A64,
+   0x9A69, 0x9A6B, 0x9A6A, 0x9AAD, 0x9AB0, 0x9ABC, 0x9AC0, 0x9ACF,
+   0x9AD1, 0x9AD3, 0x9AD4, 0x9ADE, 0x9ADF, 0x9AE2, 0x9AE3, 0x9AE6,
+   0x9AEF, 0x9AEB, 0x9AEE, 0x9AF4, 0x9AF1, 0x9AF7},
+  {				/* category 82 */
+   0x9AFB, 0x9B06, 0x9B18, 0x9B1A, 0x9B1F, 0x9B22, 0x9B23, 0x9B25,
+   0x9B27, 0x9B28, 0x9B29, 0x9B2A, 0x9B2E, 0x9B2F, 0x9B32, 0x9B44,
+   0x9B43, 0x9B4F, 0x9B4D, 0x9B4E, 0x9B51, 0x9B58, 0x9B74, 0x9B93,
+   0x9B83, 0x9B91, 0x9B96, 0x9B97, 0x9B9F, 0x9BA0, 0x9BA8, 0x9BB4,
+   0x9BC0, 0x9BCA, 0x9BB9, 0x9BC6, 0x9BCF, 0x9BD1, 0x9BD2, 0x9BE3,
+   0x9BE2, 0x9BE4, 0x9BD4, 0x9BE1, 0x9C3A, 0x9BF2, 0x9BF1, 0x9BF0,
+   0x9C15, 0x9C14, 0x9C09, 0x9C13, 0x9C0C, 0x9C06, 0x9C08, 0x9C12,
+   0x9C0A, 0x9C04, 0x9C2E, 0x9C1B, 0x9C25, 0x9C24, 0x9C21, 0x9C30,
+   0x9C47, 0x9C32, 0x9C46, 0x9C3E, 0x9C5A, 0x9C60, 0x9C67, 0x9C76,
+   0x9C78, 0x9CE7, 0x9CEC, 0x9CF0, 0x9D09, 0x9D08, 0x9CEB, 0x9D03,
+   0x9D06, 0x9D2A, 0x9D26, 0x9DAF, 0x9D23, 0x9D1F, 0x9D44, 0x9D15,
+   0x9D12, 0x9D41, 0x9D3F, 0x9D3E, 0x9D46, 0x9D48},
+  {				/* category 83 */
+   0x9D5D, 0x9D5E, 0x9D64, 0x9D51, 0x9D50, 0x9D59, 0x9D72, 0x9D89,
+   0x9D87, 0x9DAB, 0x9D6F, 0x9D7A, 0x9D9A, 0x9DA4, 0x9DA9, 0x9DB2,
+   0x9DC4, 0x9DC1, 0x9DBB, 0x9DB8, 0x9DBA, 0x9DC6, 0x9DCF, 0x9DC2,
+   0x9DD9, 0x9DD3, 0x9DF8, 0x9DE6, 0x9DED, 0x9DEF, 0x9DFD, 0x9E1A,
+   0x9E1B, 0x9E1E, 0x9E75, 0x9E79, 0x9E7D, 0x9E81, 0x9E88, 0x9E8B,
+   0x9E8C, 0x9E92, 0x9E95, 0x9E91, 0x9E9D, 0x9EA5, 0x9EA9, 0x9EB8,
+   0x9EAA, 0x9EAD, 0x9761, 0x9ECC, 0x9ECE, 0x9ECF, 0x9ED0, 0x9ED4,
+   0x9EDC, 0x9EDE, 0x9EDD, 0x9EE0, 0x9EE5, 0x9EE8, 0x9EEF, 0x9EF4,
+   0x9EF6, 0x9EF7, 0x9EF9, 0x9EFB, 0x9EFC, 0x9EFD, 0x9F07, 0x9F08,
+   0x76B7, 0x9F15, 0x9F21, 0x9F2C, 0x9F3E, 0x9F4A, 0x9F52, 0x9F54,
+   0x9F63, 0x9F5F, 0x9F60, 0x9F61, 0x9F66, 0x9F67, 0x9F6C, 0x9F6A,
+   0x9F77, 0x9F72, 0x9F76, 0x9F95, 0x9F9C, 0x9FA0},
+  {				/* category 84 */
+   0x582F, 0x69C7, 0x9059, 0x7464, 0x51DC, 0x7199, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000},
+  {				/* category 85 */
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000},
+  {				/* category 86 */
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000},
+  {				/* category 87 */
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000},
+  {				/* category 88 */
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,
+   0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000},
+  {				/* category 89 */
+   0x7E8A, 0x891C, 0x9348, 0x9288, 0x84DC, 0x4FC9, 0x70BB, 0x6631,
+   0x68C8, 0x92F9, 0x66FB, 0x5F45, 0x4E28, 0x4EE1, 0x4EFC, 0x4F00,
+   0x4F03, 0x4F39, 0x4F56, 0x4F92, 0x4F8A, 0x4F9A, 0x4F94, 0x4FCD,
+   0x5040, 0x5022, 0x4FFF, 0x501E, 0x5046, 0x5070, 0x5042, 0x5094,
+   0x50F4, 0x50D8, 0x514A, 0x5164, 0x519D, 0x51BE, 0x51EC, 0x5215,
+   0x529C, 0x52A6, 0x52C0, 0x52DB, 0x5300, 0x5307, 0x5324, 0x5372,
+   0x5393, 0x53B2, 0x53DD, 0xFA0E, 0x549C, 0x548A, 0x54A9, 0x54FF,
+   0x5586, 0x5759, 0x5765, 0x57AC, 0x57C8, 0x57C7, 0xFA0F, 0xFA10,
+   0x589E, 0x58B2, 0x590B, 0x5953, 0x595B, 0x595D, 0x5963, 0x59A4,
+   0x59BA, 0x5B56, 0x5BC0, 0x752F, 0x5BD8, 0x5BEC, 0x5C1E, 0x5CA6,
+   0x5CBA, 0x5CF5, 0x5D27, 0x5D53, 0xFA11, 0x5D42, 0x5D6D, 0x5DB8,
+   0x5DB9, 0x5DD0, 0x5F21, 0x5F34, 0x5F67, 0x5FB7},
+  {				/* category 90 */
+   0x5FDE, 0x605D, 0x6085, 0x608A, 0x60DE, 0x60D5, 0x6120, 0x60F2,
+   0x6111, 0x6137, 0x6130, 0x6198, 0x6213, 0x62A6, 0x63F5, 0x6460,
+   0x649D, 0x64CE, 0x654E, 0x6600, 0x6615, 0x663B, 0x6609, 0x662E,
+   0x661E, 0x6624, 0x6665, 0x6657, 0x6659, 0xFA12, 0x6673, 0x6699,
+   0x66A0, 0x66B2, 0x66BF, 0x66FA, 0x670E, 0xF929, 0x6766, 0x67BB,
+   0x6852, 0x67C0, 0x6801, 0x6844, 0x68CF, 0xFA13, 0x6968, 0xFA14,
+   0x6998, 0x69E2, 0x6A30, 0x6A6B, 0x6A46, 0x6A73, 0x6A7E, 0x6AE2,
+   0x6AE4, 0x6BD6, 0x6C3F, 0x6C5C, 0x6C86, 0x6C6F, 0x6CDA, 0x6D04,
+   0x6D87, 0x6D6F, 0x6D96, 0x6DAC, 0x6DCF, 0x6DF8, 0x6DF2, 0x6DFC,
+   0x6E39, 0x6E5C, 0x6E27, 0x6E3C, 0x6EBF, 0x6F88, 0x6FB5, 0x6FF5,
+   0x7005, 0x7007, 0x7028, 0x7085, 0x70AB, 0x710F, 0x7104, 0x715C,
+   0x7146, 0x7147, 0xFA15, 0x71C1, 0x71FE, 0x72B1},
+  {				/* category 91 */
+   0x72BE, 0x7324, 0xFA16, 0x7377, 0x73BD, 0x73C9, 0x73D6, 0x73E3,
+   0x73D2, 0x7407, 0x73F5, 0x7426, 0x742A, 0x7429, 0x742E, 0x7462,
+   0x7489, 0x749F, 0x7501, 0x756F, 0x7682, 0x769C, 0x769E, 0x769B,
+   0x76A6, 0xFA17, 0x7746, 0x52AF, 0x7821, 0x784E, 0x7864, 0x787A,
+   0x7930, 0xFA18, 0xFA19, 0xFA1A, 0x7994, 0xFA1B, 0x799B, 0x7AD1,
+   0x7AE7, 0xFA1C, 0x7AEB, 0x7B9E, 0xFA1D, 0x7D48, 0x7D5C, 0x7DB7,
+   0x7DA0, 0x7DD6, 0x7E52, 0x7F47, 0x7FA1, 0xFA1E, 0x8301, 0x8362,
+   0x837F, 0x83C7, 0x83F6, 0x8448, 0x84B4, 0x8553, 0x8559, 0x856B,
+   0xFA1F, 0x85B0, 0xFA20, 0xFA21, 0x8807, 0x88F5, 0x8A12, 0x8A37,
+   0x8A79, 0x8AA7, 0x8ABE, 0x8ADF, 0xFA22, 0x8AF6, 0x8B53, 0x8B7F,
+   0x8CF0, 0x8CF4, 0x8D12, 0x8D76, 0xFA23, 0x8ECF, 0xFA24, 0xFA25,
+   0x9067, 0x90DE, 0xFA26, 0x9115, 0x9127, 0x91DA},
+  {				/* category 92 */
+   0x91D7, 0x91DE, 0x91ED, 0x91EE, 0x91E4, 0x91E5, 0x9206, 0x9210,
+   0x920A, 0x923A, 0x9240, 0x923C, 0x924E, 0x9259, 0x9251, 0x9239,
+   0x9267, 0x92A7, 0x9277, 0x9278, 0x92E7, 0x92D7, 0x92D9, 0x92D0,
+   0xFA27, 0x92D5, 0x92E0, 0x92D3, 0x9325, 0x9321, 0x92FB, 0xFA28,
+   0x931E, 0x92FF, 0x931D, 0x9302, 0x9370, 0x9357, 0x93A4, 0x93C6,
+   0x93DE, 0x93F8, 0x9431, 0x9445, 0x9448, 0x9592, 0xF9DC, 0xFA29,
+   0x969D, 0x96AF, 0x9733, 0x973B, 0x9743, 0x974D, 0x974F, 0x9751,
+   0x9755, 0x9857, 0x9865, 0xFA2A, 0xFA2B, 0x9927, 0xFA2C, 0x999E,
+   0x9A4E, 0x9AD9, 0x9ADC, 0x9B75, 0x9B72, 0x9B8F, 0x9BB1, 0x9BBB,
+   0x9C00, 0x9D70, 0x9D6B, 0xFA2D, 0x9E19, 0x9ED1, 0x0000, 0x0000,
+   0x2170, 0x2171, 0x2172, 0x2173, 0x2174, 0x2175, 0x2176, 0x2177,
+   0x2178, 0x2179, 0xFFE2, 0xFFE4, 0xFF07, 0xFF02}
+};
+
+#endif /* JISX0208_H */
diff --git a/collects/plot/src/all/metadefs.h b/collects/plot/src/all/metadefs.h
new file mode 100644
index 0000000000..0045c40c94
--- /dev/null
+++ b/collects/plot/src/all/metadefs.h
@@ -0,0 +1,72 @@
+/* $Id: metadefs.h,v 1.1 2004/03/01 20:54:50 cozmic Exp $
+
+	Geoffrey Furnish
+	5 May 1991
+	
+	This file contains definitions of constants and structures which
+	are needed by the PLplot metafile writer and renderer.
+*/
+
+/*
+* PLMETA_HEADER holds the magic string at head of metafile.
+* PLMETA_VERSION holds the version number (year & letter).
+* 
+* Note: All strings written into the file header are limited to a maximum
+* of 80 characters.
+*/
+
+#define PLMETA_HEADER	"PLPLOT"
+#define PLMETA_VERSION	"1993c"
+
+/* These are used by the TK driver client/server code */
+
+#define PLSERV_HEADER	"PLPLOT"
+#define PLSERV_VERSION	"1993b"
+
+/* Symbolic constants for old metafile versions (prior to 1992a). */
+/* Now these are stored in the metafile header. */
+
+#define PLMETA_X_OLD	10000
+#define PLMETA_Y_OLD	10000
+
+/* Virtual dots/mm for our virtual display space. */
+
+#define PIXEL_RES_X_OLD		42
+#define PIXEL_RES_Y_OLD		56
+
+/* Macros to make it easier to abort on nonzero return code */
+/* Can't call plexit on a write failure since that would be circular */
+
+#define plm_wr(code) \
+    if (code) { fprintf(stderr, "Unable to write to MetaFile\n"); exit(1); }
+
+#define plm_rd(code) \
+    if (code) plexit( "Unable to read from MetaFile" )
+
+/*
+   Metafile commands.
+
+   *** NOTICE !!! ***
+   If you change ANY of the following, you will wreck backward
+   backward compatibility with old metafiles.  You may add, but do
+   NOT delete !!!
+*/
+
+#define INITIALIZE	1
+#define CLOSE		2
+#define SWITCH_TO_TEXT	3	/* Obsolete, replaced by ESCAPE */
+#define SWITCH_TO_GRAPH	4	/* Obsolete, replaced by ESCAPE */
+#define EOP		5
+#define BOP		6
+#define NEW_COLOR	7	/* Obsolete, replaced by CHANGE_STATE */
+#define NEW_WIDTH	8	/* Obsolete, replaced by CHANGE_STATE */
+#define LINE		9
+#define LINETO		10
+#define ESCAPE		11
+#define ADVANCE		12	/* Obsolete, BOP/EOP used instead */
+#define POLYLINE	13
+#define NEW_COLOR0 	NEW_COLOR
+#define NEW_COLOR1	14
+#define CHANGE_STATE	15
+#define BOP0		16	/* First BOP in a file */
+#define END_OF_FIELD	255
diff --git a/collects/plot/src/all/nan.h b/collects/plot/src/all/nan.h
new file mode 100644
index 0000000000..8699d60f9c
--- /dev/null
+++ b/collects/plot/src/all/nan.h
@@ -0,0 +1,33 @@
+/******************************************************************************
+ *
+ * File:           nan.h
+ *
+ * Created:        18/10/2001
+ *
+ * Author:         Pavel Sakov
+ *                 CSIRO Marine Research
+ *
+ * Purpose:        NaN definition
+ *
+ * Description:    Should cover 64 bit machines or other machines with GCC
+ *
+ * Revisions:      None
+ *
+ *****************************************************************************/
+
+#if !defined(_NAN_H)
+#define _NAN_H
+
+#if defined(__GNUC__)
+static const double NaN = 0.0 / 0.0;
+#elif defined(BIG_ENDIAN)
+static const long long lNaN = 0x7fffffffffffffff;
+
+#define NaN (*(double*)&lNaN)
+#else
+static const long  lNaN = 0xfff8000000000000;
+
+#define NaN (*(double*)&lNaN)
+#endif
+
+#endif
diff --git a/collects/plot/src/all/pdf.h b/collects/plot/src/all/pdf.h
new file mode 100644
index 0000000000..646348d175
--- /dev/null
+++ b/collects/plot/src/all/pdf.h
@@ -0,0 +1,107 @@
+/* $Id: pdf.h,v 1.1 2004/03/01 20:54:50 cozmic Exp $
+
+    Copyright (C) 1992 by Maurice J. LeBrun
+
+    Macros and prototypes for the PDF package.
+
+    This software may be freely copied, modified and redistributed without
+    fee provided that this copyright notice is preserved intact on all
+    copies and modified copies. 
+ 
+    There is no warranty or other guarantee of fitness of this software.
+    It is provided solely "as is". The author(s) disclaim(s) all
+    responsibility and liability with respect to this software's usage or
+    its effect upon hardware or computer systems. 
+*/
+
+#ifndef __PDF_H__
+#define __PDF_H__
+
+/* Some unsigned types */
+
+#ifndef U_CHAR
+#define U_CHAR unsigned char
+#endif
+
+#ifndef U_SHORT
+#define U_SHORT unsigned short
+#endif
+
+#ifndef U_INT
+#define U_INT unsigned int
+#endif
+
+#ifndef U_LONG
+#define U_LONG unsigned long
+#endif
+
+#ifdef PLPLOT_USE_TCL_CHANNELS
+#include <tcl.h>
+#endif
+
+/* PDFstrm definition */
+/* The low level PDF i/o routines use the transfer method appropriate for */
+/* the first non-null type below */
+
+typedef struct {
+    FILE *file;				/* Filesystem */
+    unsigned char *buffer;		/* Memory buffer */
+#ifdef PLPLOT_USE_TCL_CHANNELS
+    Tcl_Channel tclChan;	        /* Tcl channel */
+#endif
+    long bp, bufmax;			/* Buffer pointer and max size */
+} PDFstrm;
+
+/* Info for the i/o device.  Only used by Tcl/TK/dp drivers for now */
+
+typedef struct {
+    int   fd;				/* I/O device file descriptor */
+    FILE  *file;			/* File handle */
+    char  *fileName;			/* Fifo or socket name (if needed) */
+    char  *fileHandle;			/* Handle for use from interpreter */
+    int   type;				/* Communication channel type */
+    char  *typeName;			/* As above, but in string form */
+} PLiodev;
+
+/* Error numbers */
+
+#define PDF_ERROR		1	/* Unknown error	*/
+#define PDF_FNOPEN		2	/* File not open	*/
+#define PDF_FAOPEN		3	/* File already open	*/
+#define PDF_BADUN		4	/* Bad unit number	*/
+#define PDF_BADNBITS		5	/* Invalid # of bits	*/
+#define PDF_RDERR		6	/* Read error		*/
+#define PDF_WRERR		7	/* Write error		*/
+#define PDF_NOTPDF		8	/* Not a valid PDF file */
+
+/* Prototypes */
+/* Use a wrapper for the prototypes for use from K&R C */
+
+void pdf_set		PLARGS((char *option, int value));
+PDFstrm *pdf_fopen	PLARGS((char *fileName, char *mode));
+PDFstrm *pdf_bopen	PLARGS((U_CHAR *buffer, long bufmax));
+PDFstrm *pdf_finit	PLARGS((FILE *file));
+PDFstrm *plLibOpenPdfstrm PLARGS((char *fn));
+int  pdf_close		PLARGS((PDFstrm *pdfs));
+
+int  pdf_putc		PLARGS((int c, PDFstrm *pdfs));
+int  pdf_getc		PLARGS((PDFstrm *pdfs));
+int  pdf_ungetc		PLARGS((int c, PDFstrm *pdfs));
+int  pdf_rdx	        PLARGS((U_CHAR *x, long nitems, PDFstrm *pdfs));
+
+int  pdf_rd_header	PLARGS((PDFstrm *pdfs, char *header));
+int  pdf_wr_header	PLARGS((PDFstrm *pdfs, char *header));
+int  pdf_wr_string	PLARGS((PDFstrm *pdfs, const char *string));
+int  pdf_rd_string	PLARGS((PDFstrm *pdfs, char *string, int nmax));
+int  pdf_wr_1byte	PLARGS((PDFstrm *pdfs, U_CHAR s));
+int  pdf_rd_1byte	PLARGS((PDFstrm *pdfs, U_CHAR *ps));
+int  pdf_wr_2bytes	PLARGS((PDFstrm *pdfs, U_SHORT s));
+int  pdf_rd_2bytes 	PLARGS((PDFstrm *pdfs, U_SHORT *ps));
+int  pdf_wr_2nbytes	PLARGS((PDFstrm *pdfs, U_SHORT *s, PLINT n));
+int  pdf_rd_2nbytes 	PLARGS((PDFstrm *pdfs, U_SHORT *s, PLINT n));
+int  pdf_wr_4bytes	PLARGS((PDFstrm *pdfs, U_LONG s));
+int  pdf_rd_4bytes 	PLARGS((PDFstrm *pdfs, U_LONG *ps));
+int  pdf_wr_ieeef	PLARGS((PDFstrm *pdfs, float f));
+int  pdf_rd_ieeef	PLARGS((PDFstrm *pdfs, float *pf));
+
+#endif	/* __PDF_H__ */
diff --git a/collects/plot/src/all/pdfutils.c b/collects/plot/src/all/pdfutils.c
new file mode 100644
index 0000000000..b9a91a73e1
--- /dev/null
+++ b/collects/plot/src/all/pdfutils.c
@@ -0,0 +1,917 @@
+/* $Id: pdfutils.c,v 1.1 2004/03/01 20:54:50 cozmic Exp $
+
+    pdf_utils.c
+
+    Copyright (C) 1992, 1993, 1994, 1995
+    Maurice LeBrun			mjl@dino.ph.utexas.edu
+    Institute for Fusion Studies	University of Texas at Austin
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Library General Public
+    License as published by the Free Software Foundation; either
+    version 2 of the License, or (at your option) any later version.
+
+    This library is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+    Library General Public License for more details.
+
+    You should have received a copy of the GNU Library General Public
+    License along with this library; if not, write to the Free
+    Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+
+    These functions do the low-level reading/writing of portable data files.
+    Data can be written to/read from either a file handle or memory buffer.
+*/
+
+#define NEED_PLDEBUG
+#include "plplotP.h"
+
+static void print_ieeef	(void *, void *);
+static int  pdf_wrx	(const U_CHAR *x, long nitems, PDFstrm *pdfs);
+
+static int debug = 0;
+
+/*--------------------------------------------------------------------------*\
+ * void pdf_set (string, value)
+ *
+ * Set an option.  Pretty sparse right now but you never know.
+\*--------------------------------------------------------------------------*/
+
+void
+pdf_set(char *option, int value)
+{
+    if ( ! strcmp(option, "debug"))
+	debug = value;
+}
+
+/*--------------------------------------------------------------------------*\
+ * pdf_fopen()
+ *
+ * Initializes a PDFstrm for a file oriented device.
+ * Used exactly like fopen().
+\*--------------------------------------------------------------------------*/
+
+PDFstrm *
+pdf_fopen(char *filename, char *mode)
+{
+    PDFstrm *pdfs;
+
+    dbug_enter("pdf_fopen");
+
+    pdfs = (PDFstrm *) malloc(sizeof(PDFstrm));
+
+    if (pdfs != NULL) {
+	pdfs->buffer = NULL;
+	pdfs->file = NULL;
+#ifdef PLPLOT_USE_TCL_CHANNELS
+	pdfs->tclChan = NULL;
+	if (1) {
+	    char new_mode[3];
+	    int binary = 0;
+	    char *m, *p;
+	    
+	    /* Copy over the mode, removing 'b' if needed */
+	    for (m = mode, p = new_mode; *m != 0; m++) {
+	        if (*m == 'b') {
+	            binary = 1;
+	        } else {
+		    *p = *m;
+		    p++;
+	        }
+	    }
+	    *p = 0;
+	    
+	    pdfs->tclChan = Tcl_OpenFileChannel(NULL, filename, new_mode, 0);
+	    if (pdfs->tclChan == NULL) {
+		pdf_close(pdfs);
+		pdfs = NULL;
+	    } else {
+		if (binary) {
+		    Tcl_SetChannelOption(NULL, pdfs->tclChan, "-translation", 
+					 "binary");
+		}
+	    }
+	}
+#else
+	pdfs->file = fopen(filename, mode);
+	if (pdfs->file == NULL) {
+	    pdf_close(pdfs);
+	    pdfs = NULL;
+	}
+#endif
+    }
+
+    return pdfs;
+}
+
+/*--------------------------------------------------------------------------*\
+ * pdf_bopen()
+ *
+ * Initializes a PDFstrm for reading/writing to a memory buffer.
+ * If buffer is NULL, a standard buffer is allocated.
+\*--------------------------------------------------------------------------*/
+
+PDFstrm *
+pdf_bopen(U_CHAR *buffer, long bufmax)
+{
+    PDFstrm *pdfs;
+
+    dbug_enter("pdf_bopen");
+
+    pdfs = (PDFstrm *) malloc(sizeof(PDFstrm));
+
+    if (pdfs != NULL) {
+	pdfs->file = NULL;
+#ifdef PLPLOT_USE_TCL_CHANNELS
+	pdfs->tclChan = NULL;
+#endif
+	pdfs->bp = 0;
+
+	if (buffer == NULL) {
+	    if (bufmax > 0)
+		pdfs->bufmax = bufmax;
+	    else
+		pdfs->bufmax = 2048;
+
+	    pdfs->buffer = (U_CHAR *) malloc(pdfs->bufmax);
+	    if (pdfs->buffer == NULL) {
+		pdf_close(pdfs);
+		pdfs = NULL;
+	    }
+	}
+	else {
+	    pdfs->bufmax = bufmax;
+	    pdfs->buffer = buffer;
+	}
+    }
+
+    return pdfs;
+}
+
+/*--------------------------------------------------------------------------*\
+ * pdf_finit()
+ *
+ * Initializes a PDFstrm for a file oriented device.
+ * Like pdf_fopen() but an existing file handle is specified.
+\*--------------------------------------------------------------------------*/
+
+PDFstrm *
+pdf_finit(FILE *file)
+{
+    PDFstrm *pdfs;
+
+    dbug_enter("pdf_finit");
+
+    pdfs = (PDFstrm *) malloc(sizeof(PDFstrm));
+
+    if (pdfs != NULL) {
+	pdfs->buffer = NULL;
+	pdfs->file = file;
+#ifdef PLPLOT_USE_TCL_CHANNELS
+	pdfs->tclChan = NULL;
+#endif
+	pdfs->bp = 0;
+    }
+
+    return pdfs;
+}
+
+/*--------------------------------------------------------------------------*\
+ * pdf_close()
+ *
+ * Closes a PDFstrm.
+ * Used exactly like fclose().
+\*--------------------------------------------------------------------------*/
+
+int
+pdf_close(PDFstrm *pdfs)
+{
+    dbug_enter("pdf_close");
+
+    if (pdfs != NULL) {
+	if (pdfs->file != NULL) {
+	    fclose(pdfs->file);
+#ifdef PLPLOT_USE_TCL_CHANNELS
+	} else if (pdfs->tclChan != NULL) {
+	    Tcl_Close(NULL, pdfs->tclChan);
+#endif
+	} else if (pdfs->buffer != NULL) {
+	    free ((void *) pdfs->buffer);
+	}
+	free((void *) pdfs);
+    }
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * int pdf_putc()
+ *
+ * Writes a single character.
+\*--------------------------------------------------------------------------*/
+
+int
+pdf_putc(int c, PDFstrm *pdfs)
+{
+    int result = EOF;
+
+    if (pdfs->file != NULL) {
+	result = putc(c, pdfs->file);
+	pdfs->bp++;
+#ifdef PLPLOT_USE_TCL_CHANNELS
+    } else if (pdfs->tclChan != NULL) {
+	result = Tcl_WriteChars(pdfs->tclChan, &c, 1);
+	pdfs->bp++;
+#endif
+    } else if (pdfs->buffer != NULL) {
+	if (pdfs->bp >= pdfs->bufmax) {
+	    pldebug("pdf_putc",
+		    "Increasing buffer to %d bytes\n", pdfs->bufmax);
+	    pdfs->bufmax += 512;
+	    pdfs->buffer = (U_CHAR *)
+		realloc((void *) pdfs->buffer, pdfs->bufmax);
+	}
+	pdfs->buffer[pdfs->bp++] = c;
+	result = c;
+    }
+    else
+	plexit("pdf_putc: Illegal operation");
+
+    return result;
+}
+
+/*--------------------------------------------------------------------------*\
+ * int pdf_getc()
+ *
+ * Reads a single character.
+\*--------------------------------------------------------------------------*/
+
+int
+pdf_getc(PDFstrm *pdfs)
+{
+    int result = EOF;
+
+    if (pdfs->file != NULL) {
+	result = getc(pdfs->file);
+	pdfs->bp++;
+#ifdef PLPLOT_USE_TCL_CHANNELS
+    } else if (pdfs->tclChan != NULL) {
+	result = Tcl_Read(pdfs->tclChan, &result, 1);
+	pdfs->bp++;
+#endif
+    } else if (pdfs->buffer != NULL) {
+	if (pdfs->bp < pdfs->bufmax)
+	    result = pdfs->buffer[pdfs->bp++];
+    }
+    else
+	plexit("pdf_getc: Illegal operation");
+
+    return result;
+}
+
+/*--------------------------------------------------------------------------*\
+ * int pdf_ungetc()
+ *
+ * Push back the last command read.
+\*--------------------------------------------------------------------------*/
+
+int
+pdf_ungetc(int c, PDFstrm *pdfs)
+{
+    int result = EOF;
+
+    if (pdfs->file != NULL) {
+	result = ungetc(c, pdfs->file);
+	if (pdfs->bp > 0) 
+	    pdfs->bp--;
+#ifdef PLPLOT_USE_TCL_CHANNELS
+    } else if (pdfs->tclChan != NULL) {
+	result = Tcl_Ungets(pdfs->tclChan, &c, 1, 0);
+	if (pdfs->bp > 0) 
+	    pdfs->bp--;
+#endif
+    } else if (pdfs->buffer != NULL) {
+	if (pdfs->bp > 0) {
+	    pdfs->buffer[--pdfs->bp] = c;
+	    result = c;
+	}
+    }
+    else
+	plexit("pdf_ungetc: Illegal operation");
+
+    return result;
+}
+
+/*--------------------------------------------------------------------------*\
+ * int pdf_wrx()
+ *
+ * Writes a record.
+\*--------------------------------------------------------------------------*/
+
+static int
+pdf_wrx(const U_CHAR *x, long nitems, PDFstrm *pdfs)
+{
+    int i, result = 0;
+
+    if (pdfs->file != NULL) {
+	result = fwrite(x, 1, nitems, pdfs->file);
+	pdfs->bp += nitems;
+#ifdef PLPLOT_USE_TCL_CHANNELS
+    } else if (pdfs->tclChan != NULL) {
+	result = Tcl_Write(pdfs->tclChan, x, nitems);
+	pdfs->bp += nitems;
+#endif
+    } else if (pdfs->buffer != NULL) {
+	for (i = 0; i < nitems; i++) {
+	    if (pdfs->bp >= pdfs->bufmax) {
+		pldebug("pdf_wrx",
+			"Increasing buffer to %d bytes\n", pdfs->bufmax);
+		pdfs->bufmax += 512;
+		pdfs->buffer = (U_CHAR *)
+		    realloc((void *) (pdfs->buffer), pdfs->bufmax);
+	    }
+	    pdfs->buffer[pdfs->bp++] = x[i];
+	}
+	result = i;
+    }
+
+    return result;
+}
+
+/*--------------------------------------------------------------------------*\
+ * int pdf_rdx()
+ *
+ * Reads a record.
+\*--------------------------------------------------------------------------*/
+
+int
+pdf_rdx(U_CHAR *x, long nitems, PDFstrm *pdfs)
+{
+    int i, result = 0;
+
+    if (pdfs->file != NULL) {
+	result = fread(x, 1, nitems, pdfs->file);
+	pdfs->bp += nitems;
+#ifdef PLPLOT_USE_TCL_CHANNELS
+    } else if (pdfs->tclChan != NULL) {
+	result = Tcl_ReadRaw(pdfs->tclChan, x, nitems);
+	pdfs->bp += nitems;
+#endif
+    } else if (pdfs->buffer != NULL) {
+	for (i = 0; i < nitems; i++) {
+	    if (pdfs->bp > pdfs->bufmax)
+		break;
+	    x[i] = pdfs->buffer[pdfs->bp++];
+	}
+	result = i;
+    }
+
+    return result;
+}
+
+/*--------------------------------------------------------------------------*\
+ * pdf_wr_header()
+ *
+ * Writes a header string.  Input string must be NULL-terminated.  The
+ * written string is terminated by a new-line, not a NULL.  This is done
+ * so you can type e.g. "% strings <file> | head" and get sensible output.
+\*--------------------------------------------------------------------------*/
+
+int
+pdf_wr_header(PDFstrm *pdfs, char *header)
+{
+    int i;
+
+    dbug_enter("pdf_wr_header");
+
+    for (i = 0; i < 79; i++) {
+	if (header[i] == '\0')
+	    break;
+	if (pdf_putc(header[i], pdfs) == EOF)
+	    return PDF_WRERR;
+    }
+    if (pdf_putc('\n', pdfs) == EOF)
+	return PDF_WRERR;
+
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * int pdf_rd_header
+ *
+ * Reads a newline-terminated header string from PDFstrm *pdfs, and
+ * converts to a usual NULL-terminated string.  80 chars maximum assumed.
+\*--------------------------------------------------------------------------*/
+
+int
+pdf_rd_header(PDFstrm *pdfs, char *header)
+{
+    int i, c;
+
+    dbug_enter("pdf_rd_header");
+
+    for (i = 0; i < 79; i++) {
+	if ((c = pdf_getc(pdfs)) == EOF)
+	    return PDF_RDERR;
+
+	header[i] = c;
+	if (header[i] == '\n')
+	    break;
+    }
+    header[i] = '\0';		/* NULL terminate */
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * pdf_wr_string()
+ *
+ * Writes a null-terminated string.
+\*--------------------------------------------------------------------------*/
+
+int
+pdf_wr_string(PDFstrm *pdfs, const char *string)
+{
+    int i;
+
+    dbug_enter("pdf_wr_string");
+
+    for (i = 0; i <= strlen(string); i++) {
+	if (pdf_putc(string[i], pdfs) == EOF)
+	    return PDF_WRERR;
+    }
+
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * int pdf_rd_string
+ *
+ * Reads a null-terminated string from PDFstrm *pdfs.
+ * A max of nmax chars are read.
+\*--------------------------------------------------------------------------*/
+
+int
+pdf_rd_string(PDFstrm *pdfs, char *string, int nmax)
+{
+    int i, c;
+
+    dbug_enter("pdf_rd_string");
+
+    for (i = 0; i < nmax; i++) {
+	if ((c = pdf_getc(pdfs)) == EOF)
+	    return PDF_RDERR;
+
+	string[i] = c;
+	if (c == '\0')
+	    break;
+    }
+    string[i] = '\0';		/* handle boundary case */
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * int pdf_wr_1byte()
+ *
+ * Writes a U_CHAR as a single byte.
+\*--------------------------------------------------------------------------*/
+
+int
+pdf_wr_1byte(PDFstrm *pdfs, U_CHAR s)
+{
+    U_CHAR x[1];
+
+    x[0] = s;
+    if (pdf_wrx(x, 1, pdfs) != 1)
+	return PDF_WRERR;
+
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * int pdf_rd_1byte()
+ *
+ * Reads a single byte, storing into a U_CHAR.
+\*--------------------------------------------------------------------------*/
+
+int
+pdf_rd_1byte(PDFstrm *pdfs, U_CHAR *ps)
+{
+    U_CHAR x[1];
+
+    if ( ! pdf_rdx(x, 1, pdfs))
+	return PDF_RDERR;
+
+    *ps = ((U_CHAR) x[0]);
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * pdf_wr_2bytes()
+ *
+ * Writes a U_SHORT as two single bytes, low end first.
+\*--------------------------------------------------------------------------*/
+
+int
+pdf_wr_2bytes(PDFstrm *pdfs, U_SHORT s)
+{
+    U_CHAR x[2];
+
+    x[0] = (U_CHAR) ((U_LONG) (s & (U_LONG) 0x00FF));
+    x[1] = (U_CHAR) ((U_LONG) (s & (U_LONG) 0xFF00) >> 8);
+
+    if (pdf_wrx(x, 2, pdfs) != 2)
+	return PDF_WRERR;
+
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * pdf_rd_2bytes()
+ *
+ * Reads a U_SHORT from two single bytes, low end first.
+\*--------------------------------------------------------------------------*/
+
+int
+pdf_rd_2bytes(PDFstrm *pdfs, U_SHORT *ps)
+{
+    U_CHAR x[2];
+
+    if ( ! pdf_rdx(x, 2, pdfs))
+	return PDF_RDERR;
+
+    *ps = 0;
+    *ps |= (U_LONG) x[0];
+    *ps |= (U_LONG) x[1] << 8;
+
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * pdf_wr_2nbytes()
+ *
+ * Writes n U_SHORT's as 2n single bytes, low end first.
+\*--------------------------------------------------------------------------*/
+
+int
+pdf_wr_2nbytes(PDFstrm *pdfs, U_SHORT *s, PLINT n)
+{
+    PLINT i;
+    U_CHAR x[2];
+
+    for (i = 0; i < n; i++) {
+	x[0] = (U_CHAR) ((U_LONG) (s[i] & (U_LONG) 0x00FF));
+	x[1] = (U_CHAR) ((U_LONG) (s[i] & (U_LONG) 0xFF00) >> 8);
+
+	if (pdf_wrx(x, 2, pdfs) != 2)
+	    return PDF_WRERR;
+    }
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * pdf_rd_2nbytes()
+ *
+ * Reads n U_SHORT's from 2n single bytes, low end first.
+\*--------------------------------------------------------------------------*/
+
+int
+pdf_rd_2nbytes(PDFstrm *pdfs, U_SHORT *s, PLINT n)
+{
+    PLINT i;
+    U_CHAR x[2];
+
+    for (i = 0; i < n; i++) {
+	if ( ! pdf_rdx(x, 2, pdfs))
+	    return PDF_RDERR;
+
+	s[i] = 0;
+	s[i] |= (U_SHORT) x[0];
+	s[i] |= (U_SHORT) x[1] << 8;
+    }
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * pdf_wr_4bytes()
+ *
+ * Writes an unsigned long as four single bytes, low end first.
+\*--------------------------------------------------------------------------*/
+
+int
+pdf_wr_4bytes(PDFstrm *pdfs, U_LONG s)
+{
+    U_CHAR x[4];
+
+    x[0] = (U_CHAR) ((s & (U_LONG) 0x000000FF));
+    x[1] = (U_CHAR) ((s & (U_LONG) 0x0000FF00) >> 8);
+    x[2] = (U_CHAR) ((s & (U_LONG) 0x00FF0000) >> 16);
+    x[3] = (U_CHAR) ((s & (U_LONG) 0xFF000000) >> 24);
+
+    if (pdf_wrx(x, 4, pdfs) != 4)
+	return PDF_WRERR;
+
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * pdf_rd_4bytes()
+ *
+ * Reads an unsigned long from 4 single bytes, low end first.
+\*--------------------------------------------------------------------------*/
+
+int
+pdf_rd_4bytes(PDFstrm *pdfs, U_LONG *ps)
+{
+    U_CHAR x[4];
+
+    if ( ! pdf_rdx(x, 4, pdfs))
+	return PDF_RDERR;
+
+    *ps = 0;
+    *ps |= (U_LONG) x[0];
+    *ps |= (U_LONG) x[1] << 8;
+    *ps |= (U_LONG) x[2] << 16;
+    *ps |= (U_LONG) x[3] << 24;
+
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * Here is the IEEE floating point specification in both 32 bit and 64 bit
+ * precisions, from page 9 of "IEEE Standard for Binary Floating-Point
+ * Arithmetic", copyright 1985, IEEE Std 754-1985:
+ * 
+ * 
+ *                             Single Format
+ * 
+ * msb means most significant bit
+ * lsb means least significant bit
+ * 
+ *   1         8                                23
+ * _____________________________________________________________________
+ * |   |                |                                              |
+ * | s |       e        |                        f                     |
+ * |___|________________|______________________________________________|
+ *      msb          lsb msb                                        lsb
+ * 
+ * 
+ * 
+ *                             Double Format
+ * 
+ * msb means most significant bit
+ * lsb means least significant bit
+ * 
+ *   1        11                                52
+ * _____________________________________________________________________
+ * |   |                |                                              |
+ * | s |       e        |                        f                     |
+ * |___|________________|______________________________________________|
+ *      msb          lsb msb                                        lsb
+ * 
+ * 
+ * (Thanks to: Andy Mai (mai@ncar.ucar.edu))
+ * 
+ * 
+ * According to "inmos: Transputer instruction set" the IEEE standard
+ * specifies the floating format as:
+ * 
+ *      s exp frac
+ * 
+ * Where: s = sign bit  (1 bit)
+ *      exp = exponent (8 bits for 32 bit float / 11 bits for 64 bit float)
+ *      frac = fraction (23 bits for 32 bit float / 52 bits for 64 bit float)
+ * 
+ * value of (s exp frac) = (-1)^s * 1.frac * 2^(exp-bias) ; if exp not 0
+ *                         (-1)^s * 0.frac * 2^(1-bias) ; if exp = 0
+ * 
+ * where bias = 127 for 32 bit float
+ *       bias = 1023 for 64 bit float
+ * 
+ * (Thanks to: Tom Bjorkholm(TBJORKHOLM@abo.fi))
+ * 
+\*--------------------------------------------------------------------------*/
+
+/*--------------------------------------------------------------------------*\
+ * int pdf_wr_ieeef()
+ *
+ * Writes a float in IEEE single precision (32 bit) format.
+\*--------------------------------------------------------------------------*/
+
+int
+pdf_wr_ieeef(PDFstrm *pdfs, float f)
+{
+    double fdbl, fmant, f_new;
+    float fsgl, f_tmp;
+    int istat, exp, e_new, e_off, bias = 127;
+    U_LONG value, s_ieee, e_ieee, f_ieee;
+
+    if (f == 0.0) {
+	value = 0;
+	return (pdf_wr_4bytes(pdfs, value));
+    }
+    fsgl = fdbl = f;
+    fmant = frexp(fdbl, &exp);
+
+    if (fmant < 0)
+	s_ieee = 1;
+    else
+	s_ieee = 0;
+
+    fmant = fabs(fmant);
+    f_new = 2 * fmant;
+    e_new = exp - 1;
+
+    if (e_new < 1 - bias) {
+	e_off = e_new - (1 - bias);
+	e_ieee = 0;
+	f_tmp = f_new * pow((double) 2.0, (double) e_off);
+    }
+    else {
+	e_ieee = e_new + bias;
+	f_tmp = f_new - 1;
+    }
+    f_ieee = f_tmp * 8388608;		/* multiply by 2^23 */
+
+    if (e_ieee > 255) {
+	if (debug)
+	    fprintf(stderr, "pdf_wr_ieeef: Warning -- overflow\n");
+	e_ieee = 255;
+    }
+
+    s_ieee = s_ieee << 31;
+    e_ieee = e_ieee << 23;
+
+    value = s_ieee | e_ieee | f_ieee;
+
+    if ((istat = pdf_wr_4bytes(pdfs, value)))
+	return (istat);
+
+    if (debug) {
+	fprintf(stderr, "Float value (written):      %g\n", fsgl);
+	print_ieeef(&fsgl, &value);
+    }
+
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * int pdf_rd_ieeef()
+ *
+ * Reads a float from a IEEE single precision (32 bit) format.
+\*--------------------------------------------------------------------------*/
+
+int
+pdf_rd_ieeef(PDFstrm *pdfs, float *pf)
+{
+    double f_new, f_tmp;
+    float fsgl;
+    int istat, exp, bias = 127;
+    U_LONG value, s_ieee, e_ieee, f_ieee;
+
+    if ((istat = pdf_rd_4bytes(pdfs, &value)))
+	return (istat);
+
+    s_ieee = (value & (U_LONG) 0x80000000) >> 31;
+    e_ieee = (value & (U_LONG) 0x7F800000) >> 23;
+    f_ieee = (value & (U_LONG) 0x007FFFFF);
+
+    f_tmp = (double) f_ieee / 8388608.0;	/* divide by 2^23 */
+
+    if (e_ieee == 0) {
+	exp = 1 - bias;
+	f_new = f_tmp;
+    }
+    else {
+	exp = (int) e_ieee - bias;
+	f_new = 1.0 + f_tmp;
+    }
+
+    fsgl = f_new * pow(2.0, (double) exp);
+    if (s_ieee == 1)
+	fsgl = -fsgl;
+
+    *pf = fsgl;
+
+    if (debug) {
+	fprintf(stderr, "Float value (read):      %g\n", fsgl);
+	print_ieeef(&fsgl, &value);
+    }
+
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * print_ieeef()
+ *
+ * Prints binary representation for numbers pointed to by arguments.
+ * The first argument is the original float, the second is the
+ * IEEE representation.  They should be the same on any machine that
+ * uses IEEE floats.
+\*--------------------------------------------------------------------------*/
+
+static void
+print_ieeef(void *vx, void *vy)
+{
+    int i;
+    U_LONG f, *x = (U_LONG *) vx, *y = (U_LONG *) vy;
+    char bitrep[33];
+
+    bitrep[32] = '\0';
+
+    f = *x;
+    for (i = 0; i < 32; i++) {
+	if (f & 1)
+	    bitrep[32 - i - 1] = '1';
+	else
+	    bitrep[32 - i - 1] = '0';
+	f = f >> 1;
+    }
+    fprintf(stderr, "Binary representation:      ");
+    fprintf(stderr, "%s\n", bitrep);
+
+    f = *y;
+    for (i = 0; i < 32; i++) {
+	if (f & 1)
+	    bitrep[32 - i - 1] = '1';
+	else
+	    bitrep[32 - i - 1] = '0';
+	f = f >> 1;
+    }
+    fprintf(stderr, "Converted representation:   ");
+    fprintf(stderr, "%s\n\n", bitrep);
+
+    return;
+}
+
+/*--------------------------------------------------------------------------*\
+ * plAlloc2dGrid()
+ *
+ * Allocates a block of memory for use as a 2-d grid of PLFLT's.
+ * Resulting array can be indexed as f[i][j] anywhere.  This is to be used
+ * instead of PLFLT f[nx][ny], which is less useful.  Note that this type
+ * of allocation is required by the PLplot functions which take a 2-d
+ * grids of PLFLT's as an argument, such as plcont() and plot3d().
+ * Example usage:
+ *
+ *   PLFLT **z;
+ *
+ *   Alloc2dGrid(&z, XPTS, YPTS);
+\*--------------------------------------------------------------------------*/
+
+void
+plAlloc2dGrid(PLFLT ***f, PLINT nx, PLINT ny)
+{
+    PLINT i;
+
+    if ((*f = (PLFLT **) calloc(nx, sizeof(PLFLT *)))==NULL)
+        plexit("Memory allocation error in \"plAlloc2dGrid\"");
+
+    for (i = 0; i < nx; i++) {
+	if (((*f)[i] = (PLFLT *) calloc(ny ,sizeof(PLFLT)))==NULL)
+	   plexit("Memory allocation error in \"plAlloc2dGrid\"");
+    }
+
+}
+
+/*--------------------------------------------------------------------------*\
+ * Free2dGrid()
+ *
+ * Frees a block of memory allocated with Alloc2dGrid().
+\*--------------------------------------------------------------------------*/
+
+void
+plFree2dGrid(PLFLT **f, PLINT nx, PLINT ny)
+{
+    PLINT i;
+
+    for (i = 0; i < nx; i++)
+	free((void *) f[i]);
+
+    free((void *) f);
+}
+
+/*--------------------------------------------------------------------------*\
+ * MinMax2dGrid()
+ *
+ * Finds the maximum and minimum of a 2d matrix allocated with plAllc2dGrid().
+\*--------------------------------------------------------------------------*/
+
+void
+plMinMax2dGrid(PLFLT **f, PLINT nx, PLINT ny, PLFLT *fmax, PLFLT *fmin)
+{
+    int i, j;
+    PLFLT m, M;
+
+    M = m = f[0][0];
+
+    for (i = 0; i < nx; i++) {
+	for (j = 0; j < ny; j++) {
+	    if (f[i][j] > M) M = f[i][j];
+	    if (f[i][j] < m) m = f[i][j];
+	}
+    }
+    *fmax = M;
+    *fmin = m;
+}
diff --git a/collects/plot/src/all/plConfig.h b/collects/plot/src/all/plConfig.h
new file mode 100644
index 0000000000..fc2fcbaeee
--- /dev/null
+++ b/collects/plot/src/all/plConfig.h
@@ -0,0 +1,9 @@
+#ifndef __PLCONFIG_H__
+#define __PLCONFIG_H__
+#define LIB_DIR "..\\..\\..\\lib"
+#define BIN_DIR "..\\..\\..\\bin"
+#define DATA_DIR "..\\..\\..\\lib"
+#define DRV_DIR "..\\..\\..\\lib"
+#define VERSION "5.2.1"
+#define PL_DOUBLE
+#endif
diff --git a/collects/plot/src/all/plDevs.h b/collects/plot/src/all/plDevs.h
new file mode 100644
index 0000000000..8abfacd988
--- /dev/null
+++ b/collects/plot/src/all/plDevs.h
@@ -0,0 +1,2 @@
+#define PLD_null
+
diff --git a/collects/plot/src/all/plargs.c b/collects/plot/src/all/plargs.c
new file mode 100644
index 0000000000..1594549feb
--- /dev/null
+++ b/collects/plot/src/all/plargs.c
@@ -0,0 +1,2213 @@
+/* $Id: plargs.c,v 1.1 2004/03/01 20:54:50 cozmic Exp $
+
+    Copyright 1993, 1994, 1995
+    Maurice LeBrun			mjl@dino.ph.utexas.edu
+    Institute for Fusion Studies	University of Texas at Austin
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Library General Public
+    License as published by the Free Software Foundation; either
+    version 2 of the License, or (at your option) any later version.
+
+    This library is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+    Library General Public License for more details.
+
+    You should have received a copy of the GNU Library General Public
+    License along with this library; if not, write to the Free
+    Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+    Some parts of this code were derived from "xterm.c" and "ParseCmd.c" of 
+    the X-windows Version 11 distribution.  The copyright notice is
+    reproduced here:
+
+Copyright 1987, 1988 by Digital Equipment Corporation, Maynard, Massachusetts,
+and the Massachusetts Institute of Technology, Cambridge, Massachusetts.
+
+                        All Rights Reserved
+
+    The full permission notice is given in the PLplot documentation.
+
+* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+
+    This file contains routines to extract & process command flags.  The
+    command flags recognized by PLplot are stored in the "ploption_table"
+    structure, along with strings giving the syntax, long help message, and
+    option handler.  
+
+    The command line parser -- plParseOpts() -- removes all recognized flags
+    (decreasing argc accordingly), so that invalid input may be readily
+    detected.  It can also be used to process user command line flags.  The
+    user can merge an option table of type PLOptionTable into the internal
+    option table info structure using plMergeOpts().  Or, the user can
+    specify that ONLY the external table(s) be parsed by calling
+    plClearOpts() before plMergeOpts().  
+
+    The default action taken by plParseOpts() is as follows:
+	- Returns with an error if an unrecognized option or badly formed
+	  option-value pair are encountered.
+	- Returns immediately (return code 0) when the first non-option
+	  command line argument is found.
+	- Returns with the return code of the option handler, if one
+	  was called.
+	- Deletes command line arguments from argv list as they are found,
+	  and decrements argc accordingly.
+	- Does not show "invisible" options in usage or help messages.
+	- Assumes the program name is contained in argv[0].
+
+    These behaviors may be controlled through the "mode" argument, which can
+    have the following bits set:
+
+    PL_PARSE_FULL -- Full parsing of command line and all error messages
+    enabled, including program exit when an error occurs.  Anything on the
+    command line that isn't recognized as a valid option or option argument
+    is flagged as an error.
+
+    PL_PARSE_QUIET -- Turns off all output except in the case of
+    errors.
+
+    PL_PARSE_NODELETE -- Turns off deletion of processed arguments.
+
+    PL_PARSE_SHOWALL -- Show invisible options 
+
+    PL_PARSE_NOPROGRAM -- Specified if argv[0] is NOT a pointer to the
+    program name.
+
+    PL_PARSE_NODASH -- Set if leading dash is NOT required.
+
+    PL_PARSE_SKIP -- Set to quietly skip over any unrecognized args.
+
+    Note: if you want to have both your option and a PLplot option of the
+    same name processed (e.g. the -v option in plrender), do the following:
+	1. Tag your option with PL_OPT_NODELETE
+	2. Give it an option handler that uses a return code of 1.
+	3. Merge your option table in.
+    By merging your table, your option will be processed before the PLplot
+    one.  The PL_OPT_NODELETE ensures that the option string is not deleted
+    from the argv list, and the return code of 1 ensures that the parser
+    continues looking for it.
+
+    See plrender.c for examples of actual usage.  */
+
+#include "plplotP.h"
+#include <ctype.h>
+
+/* Support functions */
+
+static int  ParseOpt	(int *, char ***, int *, char ***, PLOptionTable *);
+static int  ProcessOpt	(char *, PLOptionTable *, int *, char ***, int *);
+static int  GetOptarg	(char **, int *, char ***, int *);
+static void Help	(void);
+static void Syntax	(void);
+
+/* Option handlers */
+
+static int opt_h		(char *, char *, void *);
+static int opt_v		(char *, char *, void *);
+static int opt_verbose		(char *, char *, void *);
+static int opt_debug		(char *, char *, void *);
+static int opt_hack		(char *, char *, void *);
+static int opt_dev		(char *, char *, void *);
+static int opt_o		(char *, char *, void *);
+static int opt_geo		(char *, char *, void *);
+static int opt_a		(char *, char *, void *);
+static int opt_jx		(char *, char *, void *);
+static int opt_jy		(char *, char *, void *);
+static int opt_mar		(char *, char *, void *);
+static int opt_ori		(char *, char *, void *);
+static int opt_freeaspect	(char *, char *, void *);
+static int opt_portrait		(char *, char *, void *);
+static int opt_width		(char *, char *, void *);
+static int opt_bg		(char *, char *, void *);
+static int opt_ncol0		(char *, char *, void *);
+static int opt_ncol1		(char *, char *, void *);
+static int opt_fam		(char *, char *, void *);
+static int opt_fsiz		(char *, char *, void *);
+static int opt_fbeg		(char *, char *, void *);
+static int opt_finc		(char *, char *, void *);
+static int opt_fflen		(char *, char *, void *);
+static int opt_bufmax		(char *, char *, void *);
+static int opt_nopixmap		(char *, char *, void *);
+static int opt_db		(char *, char *, void *);
+static int opt_np		(char *, char *, void *);
+static int opt_px		(char *, char *, void *);
+static int opt_py		(char *, char *, void *);
+static int opt_wplt		(char *, char *, void *);
+static int opt_drvopt		(char *, char *, void *);
+
+static int opt_plserver		(char *, char *, void *);
+static int opt_plwindow		(char *, char *, void *);
+static int opt_tcl_cmd		(char *, char *, void *);
+static int opt_auto_path	(char *, char *, void *);
+static int opt_bufmax		(char *, char *, void *);
+static int opt_server_name	(char *, char *, void *);
+static int opt_server_host	(char *, char *, void *);
+static int opt_server_port	(char *, char *, void *);
+static int opt_user		(char *, char *, void *);
+static int opt_tk_file          (char *, char *, void *);
+static int opt_dpi		(char *, char *, void *);
+static int opt_dev_compression	(char *, char *, void *);
+
+/* Global variables */
+
+static char *program = NULL;
+static char *usage   = NULL;
+
+static int  mode_full;
+static int  mode_quiet;
+static int  mode_nodelete;
+static int  mode_showall;
+static int  mode_noprogram;
+static int  mode_nodash;
+static int  mode_skip;
+
+/* Temporary buffer used for parsing */
+
+#define OPTMAX 1024
+static char opttmp[OPTMAX];
+
+/*--------------------------------------------------------------------------*\
+ * PLPLOT options data structure definition.
+ *
+ * The table is defined as follows
+ *
+ * typedef struct {
+ *     char *opt;
+ *     int  (*handler)	(char *, char *, void *);
+ *     void *client_data;
+ *     void *var;
+ *     long mode;
+ *     char *syntax;
+ *     char *desc;
+ * } PLOptionTable;
+ *
+ * where each entry has the following meaning:
+ *
+ * opt		option string
+ * handler	pointer to function for processing the option and
+ *		 (optionally) its argument
+ * client_data	pointer to data that gets passed to (*handler)
+ * var		address of variable to set based on "mode"
+ * mode		governs handling of option (see below)
+ * syntax	short syntax description
+ * desc		long syntax description
+ *
+ * The syntax and or desc strings can be NULL if the option is never to be
+ * described.  Usually this is only used for obsolete arguments; those we
+ * just wish to hide from normal use are better made invisible (which are
+ * made visible by either specifying -showall first or PL_PARSE_SHOWALL).
+ *
+ * The mode bits are:
+ *
+ * PL_OPT_ARG		Option has an argment 
+ * PL_OPT_NODELETE	Don't delete after processing 
+ * PL_OPT_INVISIBLE	Make invisible (usually for debugging)
+ * PL_OPT_DISABLED	Ignore this option
+ *
+ * The following mode bits cause the option to be processed as specified:
+ *
+ * PL_OPT_FUNC		Call function handler (opt, optarg)
+ * PL_OPT_BOOL		Set *var=1
+ * PL_OPT_INT		Set *var=atoi(optarg)
+ * PL_OPT_FLOAT		Set *var=atof(optarg)
+ * PL_OPT_STRING	Set *var=optarg
+ *
+ * where opt points to the option string and optarg points to the
+ * argument string.
+ *
+\*--------------------------------------------------------------------------*/
+
+static PLOptionTable ploption_table[] = {
+{
+    "showall",			/* Turns on invisible options */
+    NULL,
+    NULL,
+    &mode_showall,
+    PL_OPT_BOOL | PL_OPT_INVISIBLE,
+    "-showall",
+    "Turns on invisible options" },
+{
+    "h",			/* Help */
+    opt_h,
+    NULL,
+    NULL,
+    PL_OPT_FUNC,
+    "-h",
+    "Print out this message" },
+{
+    "v",			/* Version */
+    opt_v,
+    NULL,
+    NULL,
+    PL_OPT_FUNC,
+    "-v",
+    "Print out the PLplot library version number" },
+{
+    "verbose",			/* Be more verbose than usual */
+    opt_verbose,
+    NULL,
+    NULL,
+    PL_OPT_FUNC,
+    "-verbose",
+    "Be more verbose than usual" },
+{
+    "debug",			/* Print debugging info */
+    opt_debug,
+    NULL,
+    NULL,
+    PL_OPT_FUNC,
+    "-debug",
+    "Print debugging info (implies -verbose)" },
+{
+    "hack",			/* Enable driver-specific hack(s) */
+    opt_hack,
+    NULL,
+    NULL,
+    PL_OPT_FUNC | PL_OPT_INVISIBLE,
+    "-hack",
+    "Enable driver-specific hack(s)" },
+{
+    "dev",			/* Output device */
+    opt_dev,
+    NULL,
+    NULL,
+    PL_OPT_FUNC | PL_OPT_ARG,
+    "-dev name",
+    "Output device name" },
+{
+    "o",			/* Output filename */
+    opt_o,
+    NULL,
+    NULL,
+    PL_OPT_FUNC | PL_OPT_ARG,
+    "-o name",
+    "Output filename" },
+{
+    "display",			/* X server */
+    opt_o,
+    NULL,
+    NULL,
+    PL_OPT_FUNC | PL_OPT_ARG,
+    "-display name",
+    "X server to contact" },
+{
+    "px",			/* Plots per page in x */
+    opt_px,
+    NULL,
+    NULL,
+    PL_OPT_FUNC | PL_OPT_ARG,
+    "-px number",
+    "Plots per page in x" },
+{
+    "py",			/* Plots per page in y */
+    opt_py,
+    NULL,
+    NULL,
+    PL_OPT_FUNC | PL_OPT_ARG,
+    "-py number",
+    "Plots per page in y" },
+{
+    "geometry",			/* Geometry */
+    opt_geo,
+    NULL,
+    NULL,
+    PL_OPT_FUNC | PL_OPT_ARG,
+    "-geometry geom",
+    "Window size, in pixels (e.g. -geometry 400x300)" },
+{
+    "geo",			/* Geometry (alias) */
+    opt_geo,
+    NULL,
+    NULL,
+    PL_OPT_FUNC | PL_OPT_ARG | PL_OPT_INVISIBLE,
+    "-geo geom",
+    "Window size, in pixels (e.g. -geo 400x300)" },
+{
+    "wplt",			/* Plot window */
+    opt_wplt,
+    NULL,
+    NULL,
+    PL_OPT_FUNC | PL_OPT_ARG,
+    "-wplt xl,yl,xr,yr",
+    "Relative coordinates [0-1] of window into plot" },
+{
+    "mar",			/* Margin */
+    opt_mar,
+    NULL,
+    NULL,
+    PL_OPT_FUNC | PL_OPT_ARG,
+    "-mar margin",
+    "Margin space in relative coordinates (0 to 0.5, def 0)" },
+{
+    "a",			/* Aspect ratio */
+    opt_a,
+    NULL,
+    NULL,
+    PL_OPT_FUNC | PL_OPT_ARG,
+    "-a aspect",
+    "Page aspect ratio (def: same as output device)"},
+{
+    "jx",			/* Justification in x */
+    opt_jx,
+    NULL,
+    NULL,
+    PL_OPT_FUNC | PL_OPT_ARG,
+    "-jx justx",
+    "Page justification in x (-0.5 to 0.5, def 0)"},
+{
+    "jy",			/* Justification in y */
+    opt_jy,
+    NULL,
+    NULL,
+    PL_OPT_FUNC | PL_OPT_ARG,
+    "-jy justy",
+    "Page justification in y (-0.5 to 0.5, def 0)"},
+{
+    "ori",			/* Orientation */
+    opt_ori,
+    NULL,
+    NULL,
+    PL_OPT_FUNC | PL_OPT_ARG,
+    "-ori orient",
+    "Plot orientation (0,1,2,3=landscape,portrait,seascape,upside-down)" },
+{
+    "freeaspect",		/* floating aspect ratio */
+    opt_freeaspect,
+    NULL,
+    NULL,
+    PL_OPT_FUNC,
+    "-freeaspect",
+    "Allow aspect ratio to adjust to orientation swaps" },
+{
+    "portrait",			/* floating aspect ratio */
+    opt_portrait,
+    NULL,
+    NULL,
+    PL_OPT_FUNC,
+    "-portrait",
+    "Sets portrait mode (both orientation and aspect ratio)" },
+{
+    "width",			/* Pen width */
+    opt_width,
+    NULL,
+    NULL,
+    PL_OPT_FUNC | PL_OPT_ARG,
+    "-width width",
+    "Sets pen width (0 <= width)" },
+{
+    "bg",			/* Background color */
+    opt_bg,
+    NULL,
+    NULL,
+    PL_OPT_FUNC | PL_OPT_ARG,
+    "-bg color",
+    "Background color (0=black, FFFFFF=white)" },
+{
+    "ncol0",			/* Allocated colors in cmap 0 */
+    opt_ncol0,
+    NULL,
+    NULL,
+    PL_OPT_FUNC | PL_OPT_ARG,
+    "-ncol0 n",
+    "Number of colors to allocate in cmap 0 (upper bound)" },
+{
+    "ncol1",			/* Allocated colors in cmap 1 */
+    opt_ncol1,
+    NULL,
+    NULL,
+    PL_OPT_FUNC | PL_OPT_ARG,
+    "-ncol1 n",
+    "Number of colors to allocate in cmap 1 (upper bound)" },
+{
+    "fam",			/* Familying on switch */
+    opt_fam,
+    NULL,
+    NULL,
+    PL_OPT_FUNC,
+    "-fam",
+    "Create a family of output files" },
+{
+    "fsiz",			/* Family file size */
+    opt_fsiz,
+    NULL,
+    NULL,
+    PL_OPT_FUNC | PL_OPT_ARG,
+    "-fsiz size[kKmMgG]",
+    "Output family file size (e.g. -fsiz 0.5G, def MB)" },
+{
+    "fbeg",			/* Family starting member */
+    opt_fbeg,
+    NULL,
+    NULL,
+    PL_OPT_FUNC | PL_OPT_ARG,
+    "-fbeg number",
+    "First family member number on output" },
+{
+    "finc",			/* Family member increment */
+    opt_finc,
+    NULL,
+    NULL,
+    PL_OPT_FUNC | PL_OPT_ARG,
+    "-finc number",
+    "Increment between family members" },
+{
+    "fflen",			/* Family member min field width */
+    opt_fflen,
+    NULL,
+    NULL,
+    PL_OPT_FUNC | PL_OPT_ARG,
+    "-fflen length",
+    "Family member number minimum field width" },
+{
+    "nopixmap",			/* Do not use pixmaps */
+    opt_nopixmap,
+    NULL,
+    NULL,
+    PL_OPT_FUNC,
+    "-nopixmap",
+    "Don't use pixmaps in X-based drivers" },
+{
+    "db",			/* Double buffering on switch */
+    opt_db,
+    NULL,
+    NULL,
+    PL_OPT_FUNC,
+    "-db",
+    "Double buffer X window output" },
+{
+    "np",			/* Page pause off switch */
+    opt_np,
+    NULL,
+    NULL,
+    PL_OPT_FUNC,
+    "-np",
+    "No pause between pages" },
+{
+    "bufmax",			/* # bytes sent before flushing output */
+    opt_bufmax,
+    NULL,
+    NULL,
+    PL_OPT_FUNC | PL_OPT_ARG | PL_OPT_INVISIBLE,
+    "-bufmax",
+    "bytes sent before flushing output" },
+{
+    "server_name",		/* Main window name of server */
+    opt_server_name,
+    NULL,
+    NULL,
+    PL_OPT_FUNC | PL_OPT_ARG,
+    "-server_name name",
+    "Main window name of PLplot server (tk driver)" },
+{
+    "server_host",		/* Host to run server on */
+    opt_server_host,
+    NULL,
+    NULL,
+    PL_OPT_FUNC | PL_OPT_ARG,
+    "-server_host name",
+    "Host to run PLplot server on (dp driver)" },
+{
+    "server_port",		/* Port to talk to server on */
+    opt_server_port,
+    NULL,
+    NULL,
+    PL_OPT_FUNC | PL_OPT_ARG,
+    "-server_port name",
+    "Port to talk to PLplot server on (dp driver)" },
+{
+    "user",			/* user name on remote node */
+    opt_user,
+    NULL,
+    NULL,
+    PL_OPT_FUNC | PL_OPT_ARG,
+    "-user name",
+    "User name on remote node (dp driver)" },
+{
+    "plserver",			/* PLplot server name */
+    opt_plserver,
+    NULL,
+    NULL,
+    PL_OPT_FUNC | PL_OPT_ARG | PL_OPT_INVISIBLE,
+    "-plserver name",
+    "Invoked name of PLplot server (tk or dp driver)" },
+{
+    "plwindow",			/* PLplot container window name */
+    opt_plwindow,
+    NULL,
+    NULL,
+    PL_OPT_FUNC | PL_OPT_ARG | PL_OPT_INVISIBLE,
+    "-plwindow name",
+    "Name of PLplot container window (tk or dp driver)" },
+{
+    "tcl_cmd",			/* TCL initialization command */
+    opt_tcl_cmd,
+    NULL,
+    NULL,
+    PL_OPT_FUNC | PL_OPT_ARG | PL_OPT_INVISIBLE,
+    "-tcl_cmd command",
+    "TCL command string run at startup (note: disabled)" },
+{
+    "auto_path",		/* Additional directory(s) to autoload */
+    opt_auto_path,
+    NULL,
+    NULL,
+    PL_OPT_FUNC | PL_OPT_ARG | PL_OPT_INVISIBLE,
+    "-auto_path dir",
+    "Additional directory(s) to autoload (tk or dp driver)" },
+{
+    "tk_file",      /* -file option for plserver */
+    opt_tk_file,
+    NULL,
+    NULL,
+    PL_OPT_FUNC | PL_OPT_ARG | PL_OPT_INVISIBLE,
+    "-tk_file file",
+    "file for plserver (tk or dp driver)" },
+{
+    "dpi",			/* Dots per inch */
+    opt_dpi,
+    NULL,
+    NULL,
+    PL_OPT_FUNC | PL_OPT_ARG,
+    "-dpi dpi",
+    "Resolution, in dots per inch (e.g. -dpi 360x360)" },
+{
+    "compression",			/* compression */
+    opt_dev_compression,
+    NULL,
+    NULL,
+    PL_OPT_FUNC | PL_OPT_ARG,
+    "-compression num",
+    "Sets compression level in supporting devices" },
+{
+    "drvopt",			/* Driver specific options */
+    opt_drvopt,
+    NULL,
+    NULL,
+    PL_OPT_ARG | PL_OPT_FUNC,
+    "-drvopt option[=value][,option[=value]]*",
+    "Driver specific options" },
+{
+    NULL,			/* option */
+    NULL,			/* handler */
+    NULL,			/* client data */
+    NULL,			/* address of variable to set */
+    0,				/* mode flag */
+    NULL,			/* short syntax */
+    NULL }			/* long syntax */
+};
+
+static char *plplot_notes[] = {
+"All parameters must be white-space delimited.  Some options are driver",
+"dependent.  Please see the PLplot reference document for more detail.",
+NULL};
+
+/*--------------------------------------------------------------------------*\
+ * Array of option tables and associated info.
+ *
+ * The user may merge up to PL_MAX_OPT_TABLES custom option tables (of type
+ * PLOptionTable) with the internal one.  The resulting treatment is simple,
+ * powerful, and robust.  The tables are parsed in the order of last added
+ * first, to the internal table last.  If multiple options of the same name
+ * occur, only the first parsed is "seen", thus, the user can easily
+ * override any PLplot internal option merely by providing the same option.
+ * This same precedence is followed when printing help and usage messages,
+ * with each set of options given separately.  See example usage in
+ * plrender.c.
+\*--------------------------------------------------------------------------*/
+
+typedef struct {
+    PLOptionTable *options;
+    char *name;
+    char **notes;
+} PLOptionInfo;
+
+PLOptionInfo ploption_info_default = {
+    ploption_table,
+    "PLplot options",
+    plplot_notes
+};
+
+#define PL_MAX_OPT_TABLES 10
+PLOptionInfo ploption_info[PL_MAX_OPT_TABLES] = { 
+    {
+	ploption_table,
+	"PLplot options",
+	plplot_notes
+    }
+};
+
+/* The structure that hold the driver specific command line options */
+
+typedef struct DrvOptCmd {
+  char *option;
+  char *value;
+  struct DrvOptCmd *next;
+} DrvOptCmd;
+
+/* the variable where opt_drvopt() stores the driver specific command line options */
+static DrvOptCmd drv_opt;
+  
+static int  tables = 1;
+
+/*--------------------------------------------------------------------------*\
+ * plSetOpt()
+ *
+ * Process input strings, treating them as an option and argument pair.
+ * Returns 1 on an error.
+\*--------------------------------------------------------------------------*/
+
+int
+c_plsetopt(char *opt, char *optarg)
+{
+    return(plSetOpt(opt, optarg));
+}
+
+int
+plSetOpt(char *opt, char *optarg)
+{
+    int mode = 0, argc = 2, status;
+    char *argv[3];
+
+    argv[0] = opt;
+    argv[1] = optarg;
+    argv[2] = NULL;
+    mode =
+	PL_PARSE_QUIET |
+	PL_PARSE_NODELETE |
+	PL_PARSE_NOPROGRAM |
+	PL_PARSE_NODASH;
+
+    status = plParseOpts(&argc, argv, mode);
+    if (status) {
+	fprintf( stderr, "plSetOpt: Unrecognized option %s\n", opt);
+    }
+    return status;
+}
+
+/*--------------------------------------------------------------------------*\
+ * plMergeOpts()
+ *
+ * Merge user option table info structure with internal one.
+\*--------------------------------------------------------------------------*/
+
+int
+plMergeOpts(PLOptionTable *options, char *name, char **notes)
+{
+    PLOptionTable *tab;
+
+    pllib_init();
+
+/* Check to make sure option table has been terminated correctly */
+
+    for (tab = options; tab->opt; tab++)
+	;
+
+/* We've reached the last table entry.  All the subentries must be NULL or 0 */
+
+    if ((tab->handler     != NULL) ||
+	(tab->client_data != NULL) ||
+	(tab->var         != NULL) ||
+	(tab->mode        != 0) ||
+	(tab->syntax      != NULL) ||
+	(tab->desc        != NULL)) {
+
+	plabort("plMergeOpts: input table improperly terminated");
+	return 1;
+    }
+
+/* No room for more tables */
+
+    if (tables++ >= PL_MAX_OPT_TABLES) {
+	plabort("plMergeOpts: max tables limit exceeded, table not merged");
+	return 1;
+    }
+
+    ploption_info[tables-1].options = options;
+    ploption_info[tables-1].name    = name;
+    ploption_info[tables-1].notes   = notes;
+
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * plClearOpts()
+ *
+ * Clear internal option table info structure.
+\*--------------------------------------------------------------------------*/
+
+void
+plClearOpts(void)
+{
+    tables = 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * plResetOpts()
+ *
+ * Reset internal option table info structure.
+\*--------------------------------------------------------------------------*/
+
+void
+plResetOpts(void)
+{
+    ploption_info[0] = ploption_info_default;
+    tables = 1;
+}
+
+/*--------------------------------------------------------------------------*\
+ * plParseOpts()
+ *
+ * Process options list using current ploptions_info structure.
+ * An error in parsing the argument list causes a program exit if
+ * mode_full is set, otherwise the function returns with an error.
+\*--------------------------------------------------------------------------*/
+
+int
+plParseOpts(int *p_argc, char **argv, PLINT mode)
+{
+    char **argsave, **argend;
+    int	i, myargc, status = 0;
+
+    pllib_init();
+
+/* Initialize */
+
+    mode_full      = mode & PL_PARSE_FULL;
+    mode_quiet     = mode & PL_PARSE_QUIET;
+    mode_nodelete  = mode & PL_PARSE_NODELETE;
+    mode_showall   = mode & PL_PARSE_SHOWALL;
+    mode_noprogram = mode & PL_PARSE_NOPROGRAM;
+    mode_nodash    = mode & PL_PARSE_NODASH;
+    mode_skip      = mode & PL_PARSE_SKIP;
+
+    /* Initialize the driver specific option linked structure */
+    drv_opt.option  = drv_opt.value  = NULL;
+    drv_opt.next  = NULL;
+
+    myargc = (*p_argc); 
+    argend = argv + myargc;
+
+/* If program name is first argument, save and advance */
+
+    if ( ! mode_noprogram) {
+	plsc->program = program = argv[0];
+	--myargc; ++argv;
+    }
+    if (myargc == 0)
+	return 0;
+
+/* Process the command line */
+
+    argsave = argv;
+    for (; myargc > 0; --myargc, ++argv) {
+
+    /* Allow for "holes" in argv list */
+
+	if (*argv == NULL || *argv[0] == '\0')
+	    continue;
+
+    /* Loop over all options tables, starting with the last */
+
+	for (i = tables-1; i >= 0; i--) {
+
+	/* Check option table for option */
+
+	    status = ParseOpt(&myargc, &argv, p_argc, &argsave,
+			      ploption_info[i].options);
+
+	    if ( ! status) break;
+	}
+
+    /* Handle error return as specified by the mode flag */
+
+	if (status == -1) {
+
+	/* No match.  Keep going if mode_skip is set, otherwise abort if
+	   fully parsing, else return without error. */
+
+	    if (mode_skip) {
+		if ( ! mode_nodelete) 
+		    *argsave++ = *argv;
+		continue;
+	    }
+	    if ( ! mode_quiet && mode_full) {
+		fprintf(stderr, "\nBad command line option \"%s\"\n", argv[0]);
+		plOptUsage();
+	    }
+	    if (mode_full) exit(1);
+
+	    status = 0;
+	    break;
+
+	} else if (status == 1) {
+
+	/* Illegal or badly formed */
+
+	    if ( ! mode_quiet) {
+		fprintf(stderr, "\nBad command line option \"%s\"\n", argv[0]);
+		plOptUsage();
+	    }
+	    if (mode_full) exit(1);
+
+	    break;
+
+	} else if (status == 2) {
+
+	/* Informational option encountered (-h or -v) */
+
+	    exit(0);
+	}
+    }
+
+/* Compress and NULL-terminate argv */
+
+    if ( ! mode_nodelete) {
+	for (i = 0; i < myargc; i++)
+	    *argsave++ = *argv++;
+
+	if (argsave < argend)
+	    *argsave = NULL;
+    }
+
+    return status;
+}
+
+/*--------------------------------------------------------------------------*\
+ * ParseOpt()
+ *
+ * Parses & determines appropriate action for input flag.
+\*--------------------------------------------------------------------------*/
+
+static int
+ParseOpt(int *p_myargc, char ***p_argv, int *p_argc, char ***p_argsave,
+	 PLOptionTable *option_table)
+{
+    PLOptionTable *tab;
+    char *opt;
+
+/* Only handle actual flags and their arguments */
+
+    if ( mode_nodash || (*p_argv)[0][0] == '-') {
+
+	opt = (*p_argv)[0];
+	if (*opt == '-') 
+	    opt++;
+
+	for (tab = option_table; tab->opt; tab++) {
+
+	/* Skip if option not enabled */
+
+	    if (tab->mode & PL_OPT_DISABLED) 
+		continue;
+
+	/* Try to match it */
+
+	    if (*opt == *tab->opt && ! strcmp(opt, tab->opt)) {
+
+	    /* Option matched, so remove from argv list if applicable. */
+
+		if ( ! mode_nodelete) {
+		    if (tab->mode & PL_OPT_NODELETE)
+			(*(*p_argsave)++) = (**p_argv);
+		    else
+			--(*p_argc);
+		}
+
+	    /* Process option (and argument if applicable) */
+
+		return (ProcessOpt(opt, tab, p_myargc, p_argv, p_argc));
+	    }
+	}
+    }
+
+    return -1;
+}
+
+/*--------------------------------------------------------------------------*\
+ * ProcessOpt()
+ *
+ * Process option (and argument if applicable).
+\*--------------------------------------------------------------------------*/
+
+static int
+ProcessOpt(char *opt, PLOptionTable *tab, int *p_myargc, char ***p_argv,
+	   int *p_argc)
+{
+    int need_arg, res;
+    char *optarg = NULL;
+
+/* Get option argument if necessary */
+
+    need_arg = PL_OPT_ARG | PL_OPT_INT | PL_OPT_FLOAT | PL_OPT_STRING;
+
+    if (tab->mode & need_arg) {
+	if (GetOptarg(&optarg, p_myargc, p_argv, p_argc))
+	    return 1;
+    }
+
+/* Process argument */
+
+    switch (tab->mode & 0xFF00) {
+
+    case PL_OPT_FUNC:
+
+    /* Call function handler to do the job */
+
+	if (tab->handler == NULL) {
+	    fprintf(stderr,
+		    "ProcessOpt: no handler specified for option %s\n",
+		    tab->opt);
+	    return 1;
+	}
+
+        if (mode_nodelete && optarg) {
+
+	/* Make a copy, since handler may mung optarg with strtok() */
+	    char *copy = 
+	      (char *) malloc((size_t)(1+strlen(optarg))*sizeof(char));
+	    if (copy == NULL) {
+	        plabort("ProcessOpt: out of memory");
+		return 1;
+	    }
+	    strcpy(copy, optarg);
+	    res = ((*tab->handler) (opt, copy, tab->client_data));
+	    free((void *) copy);
+	    return res;
+	}
+	else {
+	  return ((*tab->handler) (opt, optarg, tab->client_data));
+	}
+
+    case PL_OPT_BOOL:
+
+    /* Set *var as a boolean */
+
+	if (tab->var == NULL) {
+	    fprintf(stderr,
+		    "ProcessOpt: no variable specified for option %s\n",
+		    tab->opt);
+	    return 1;
+	}
+	*(int *)tab->var = 1;
+	break;
+
+    case PL_OPT_INT:
+
+    /* Set *var as an int */
+
+	if (tab->var == NULL) {
+	    fprintf(stderr,
+		    "ProcessOpt: no variable specified for option %s\n",
+		    tab->opt);
+	    return 1;
+	}
+	*(int *)tab->var = atoi(optarg);
+	break;
+
+    case PL_OPT_FLOAT:
+
+    /* Set *var as a float */
+
+	if (tab->var == NULL) {
+	    fprintf(stderr,
+		    "ProcessOpt: no variable specified for option %s\n",
+		    tab->opt);
+	    return 1;
+	}
+	*(PLFLT *)tab->var = atof(optarg);
+	break;
+
+    case PL_OPT_STRING:
+
+    /* Set var (can be NULL initially) to point to optarg string */
+
+	*(char **)tab->var = (char *)optarg;
+	break;
+
+    default:
+
+    /* Somebody messed up.. */
+
+	fprintf(stderr,
+		"ProcessOpt: invalid processing mode for option %s\n",
+		tab->opt);
+	return 1;
+    }
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * GetOptarg()
+ *
+ * Retrieves an option argument.
+ * If an error occurs here it is a true syntax error.
+\*--------------------------------------------------------------------------*/
+
+static int
+GetOptarg(char **poptarg, int *p_myargc, char ***p_argv, int *p_argc)
+{
+    int result = 0;
+
+    --(*p_myargc);
+
+    if ((*p_myargc) <= 0)		/* oops, no more arguments */
+	result = 1;
+
+    if ( ! result) {
+	(*p_argv)++;
+	if ((*p_argv)[0][0] == '-' && isalpha((*p_argv)[0][1])) {
+
+	    (*p_argv)--;		/* oops, next arg is a flag */
+	    result = 1;
+	}
+    }
+
+    if ( ! result) {			/* yeah, the user got it right */
+	(*p_argc)--;
+	*poptarg = (*p_argv)[0];
+    }
+    else {
+	if ( ! mode_quiet) {
+	    fprintf(stderr, "Argument missing for %s option.\n", (*p_argv)[0]);
+	    plOptUsage();
+	}
+    }
+    return result;
+}
+
+/*--------------------------------------------------------------------------*\
+ * plSetUsage()
+ *
+ * Set the strings used in usage and syntax messages.
+\*--------------------------------------------------------------------------*/
+
+void
+plSetUsage(char *program_string, char *usage_string)
+{
+    if (program_string != NULL)
+	program = program_string;
+
+    if (usage_string != NULL)
+	usage = usage_string;
+}
+
+/*--------------------------------------------------------------------------*\
+ * plOptUsage()
+ *
+ * Print usage & syntax message.
+\*--------------------------------------------------------------------------*/
+
+void
+plOptUsage(void)
+{
+    if (usage == NULL)
+	fprintf(stderr, "\nUsage:\n        %s [options]\n", program);
+    else
+	fputs(usage, stderr);
+
+    Syntax();
+
+    fprintf(stderr, "\n\nType %s -h for a full description.\n\n",
+	    program);
+}
+
+/*--------------------------------------------------------------------------*\
+ * Syntax()
+ *
+ * Print short syntax message.
+\*--------------------------------------------------------------------------*/
+
+static void
+Syntax(void)
+{
+    PLOptionTable *tab;
+    int i, col, len;
+
+/* Loop over all options tables */
+
+    for (i = tables-1; i >= 0; i--) {
+
+    /* Introducer */
+
+	if (ploption_info[i].name)
+	    fprintf(stderr, "\n%s:", ploption_info[i].name);
+	else
+	    fputs("\nUser options:", stderr);
+
+    /* Print syntax for each option */
+
+	col = 80;
+	for (tab = ploption_info[i].options; tab->opt; tab++) {
+	    if (tab->mode & PL_OPT_DISABLED)
+		continue;
+
+	    if ( ! mode_showall && (tab->mode & PL_OPT_INVISIBLE))
+		continue;
+
+	    if (tab->syntax == NULL)
+		continue;
+
+	    len = 3 + strlen(tab->syntax);		/* space [ string ] */
+	    if (col + len > 79) {
+		fprintf(stderr, "\n   ");		/* 3 spaces */
+		col = 3;
+	    }
+	    fprintf(stderr, " [%s]", tab->syntax);
+	    col += len;
+	}
+	fprintf(stderr, "\n");
+    }
+}
+
+/*--------------------------------------------------------------------------*\
+ * Help()
+ *
+ * Print long help message.
+\*--------------------------------------------------------------------------*/
+
+static void
+Help(void)
+{
+    PLOptionTable *tab;
+    char **note;
+    int i;
+    FILE *outfile = stderr;
+
+#ifdef HAVE_POPEN
+    FILE *pager = NULL;
+    if (getenv("PAGER") != NULL)
+	pager = (FILE *) popen("$PAGER", "w");
+    if (pager == NULL)
+	pager = (FILE *) popen("more", "w");
+    if (pager != NULL)
+	outfile = pager;
+#endif
+
+/* Usage line */
+
+    if (usage == NULL)
+	fprintf(outfile, "\nUsage:\n        %s [options]\n", program);
+    else
+	fputs(usage, outfile);
+
+/* Loop over all options tables */
+
+    for (i = tables-1; i >= 0; i--) {
+
+    /* Introducer */
+
+	if (ploption_info[i].name)
+	    fprintf(outfile, "\n%s:\n", ploption_info[i].name);
+	else
+	    fputs("\nUser options:\n", outfile);
+
+    /* Print description for each option */
+
+	for (tab = ploption_info[i].options; tab->opt; tab++) {
+	    if (tab->mode & PL_OPT_DISABLED)
+		continue;
+
+	    if ( ! mode_showall && (tab->mode & PL_OPT_INVISIBLE))
+		continue;
+
+	    if (tab->desc == NULL)
+		continue;
+
+	    if (tab->mode & PL_OPT_INVISIBLE) 
+		fprintf(outfile, " *  %-20s %s\n", tab->syntax, tab->desc);
+	    else 
+		fprintf(outfile, "    %-20s %s\n", tab->syntax, tab->desc);
+	}
+
+    /* Usage notes */
+
+	if (ploption_info[i].notes) {
+	    putc('\n', outfile);
+	    for (note = ploption_info[i].notes; *note; note++) {
+		fputs(*note, outfile);
+		putc('\n', outfile);
+	    }
+	}
+    }
+
+#ifdef HAVE_POPEN
+    if (pager != NULL)
+	pclose(pager);
+#endif
+}
+
+/*--------------------------------------------------------------------------*\
+ * plParseDrvOpts
+ * 
+ * Parse driver specific options
+\*--------------------------------------------------------------------------*/
+
+int
+plParseDrvOpts(DrvOpt *acc_opt) {
+  DrvOptCmd *drvp;
+  DrvOpt *t;
+  int fl;
+  char msg[80];
+
+  if (!drv_opt.option)
+    return 1;
+
+  drvp = &drv_opt;
+  do {
+    t = acc_opt; fl = 0;
+    while (t->opt) {
+      if (strcmp(drvp->option, t->opt) == 0) {
+	fl = 1;
+	switch (t->type) {
+
+	case DRV_STR:
+	  *(char **)(t->var_ptr) = (drvp->value);
+#ifdef DEBUG
+	  fprintf(stderr,"plParseDrvOpts: %s %s\n", t->opt, *(char**)t->var_ptr);
+#endif
+	  break;
+
+	case DRV_INT:
+	  if (sscanf(drvp->value, "%d", (int *)t->var_ptr) != 1) {
+	    sprintf(msg,"Incorrect argument to '%s' option", drvp->option);
+	    plexit(msg);
+	  }
+#ifdef DEBUG
+	  fprintf(stderr,"plParseDrvOpts: %s %d\n", t->opt, *(int *) t->var_ptr);
+#endif  
+	  break;
+
+	case DRV_FLT:
+	  if (sscanf(drvp->value, "%f", (float *)t->var_ptr) != 1) {
+	    sprintf(msg,"Incorrect argument to '%s' option", drvp->option);
+	    plexit(msg);
+	  }
+#ifdef DEBUG
+	  fprintf(stderr,"plParseDrvOpts: %s %f\n", t->opt, *(float *) t->var_ptr);
+#endif  
+	  break;
+	}
+      }
+    t++;
+    }
+
+    if (!fl) {
+      sprintf(msg, "Option '%s' not recognized.\n\nRecognized options for this driver are:\n", drvp->option);
+      plwarn(msg);
+      plHelpDrvOpts(acc_opt);      
+      plexit(""); 
+    }
+  }
+  while((drvp = drvp->next))
+      ;
+
+  return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * plHelpDrvOpts
+ * 
+ * Give driver specific help
+\*--------------------------------------------------------------------------*/
+
+void
+plHelpDrvOpts(DrvOpt *acc_opt) {
+  DrvOpt *t;
+
+  t = acc_opt;
+  while(t->opt) {
+    fprintf(stderr, "%s:\t%s\n", t->opt, t->hlp_msg);
+    t++;
+  }
+}
+
+/*--------------------------------------------------------------------------*\
+ * Option handlers
+\*--------------------------------------------------------------------------*/
+
+/*--------------------------------------------------------------------------*\
+ * opt_h()
+ *
+ * Performs appropriate action for option "h":
+ * Issues help message
+\*--------------------------------------------------------------------------*/
+
+static int
+opt_h(char *opt, char *optarg, void *client_data)
+{
+    if ( ! mode_quiet)
+	Help();
+
+    return 2;
+}
+
+/*--------------------------------------------------------------------------*\
+ * opt_v()
+ *
+ * Performs appropriate action for option "v":
+ * Issues version message
+\*--------------------------------------------------------------------------*/
+
+static int
+opt_v(char *opt, char *optarg, void *client_data)
+{
+    if ( ! mode_quiet) 
+	fprintf(stderr, "PLplot library version: %s\n", VERSION);
+
+    return 2;
+}
+
+/*--------------------------------------------------------------------------*\
+ * opt_verbose()
+ *
+ * Performs appropriate action for option "verbose":
+ * Turn on verbosity flag
+\*--------------------------------------------------------------------------*/
+
+static int
+opt_verbose(char *opt, char *optarg, void *client_data)
+{
+    plsc->verbose = 1;
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * opt_debug()
+ *
+ * Performs appropriate action for option "debug":
+ * Turn on debugging flag
+\*--------------------------------------------------------------------------*/
+
+static int
+opt_debug(char *opt, char *optarg, void *client_data)
+{
+    plsc->debug = 1;
+    plsc->verbose = 1;
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * opt_hack()
+ *
+ * Performs appropriate action for option "hack":
+ * Enables driver-specific hack(s)
+\*--------------------------------------------------------------------------*/
+
+static int
+opt_hack(char *opt, char *optarg, void *client_data)
+{
+    plsc->hack = 1;
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * opt_dev()
+ *
+ * Performs appropriate action for option "dev":
+ * Sets output device keyword
+\*--------------------------------------------------------------------------*/
+
+static int
+opt_dev(char *opt, char *optarg, void *client_data)
+{
+    plsdev(optarg);
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * opt_o()
+ *
+ * Performs appropriate action for option "o":
+ * Sets output file name
+\*--------------------------------------------------------------------------*/
+
+static int
+opt_o(char *opt, char *optarg, void *client_data)
+{
+    plsfnam(optarg);
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * opt_mar()
+ *
+ * Performs appropriate action for option "mar":
+ * Sets relative margin width
+\*--------------------------------------------------------------------------*/
+
+static int
+opt_mar(char *opt, char *optarg, void *client_data)
+{
+    plsdidev(atof(optarg), PL_NOTSET, PL_NOTSET, PL_NOTSET);
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * opt_a()
+ *
+ * Performs appropriate action for option "a":
+ * Sets plot aspect ratio on page
+\*--------------------------------------------------------------------------*/
+
+static int
+opt_a(char *opt, char *optarg, void *client_data)
+{
+    plsdidev(PL_NOTSET, atof(optarg), PL_NOTSET, PL_NOTSET);
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * opt_jx()
+ *
+ * Performs appropriate action for option "jx":
+ * Sets relative justification in x
+\*--------------------------------------------------------------------------*/
+
+static int
+opt_jx(char *opt, char *optarg, void *client_data)
+{
+    plsdidev(PL_NOTSET, PL_NOTSET, atof(optarg), PL_NOTSET);
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * opt_jy()
+ *
+ * Performs appropriate action for option "jy":
+ * Sets relative justification in y
+\*--------------------------------------------------------------------------*/
+
+static int
+opt_jy(char *opt, char *optarg, void *client_data)
+{
+    plsdidev(PL_NOTSET, PL_NOTSET, PL_NOTSET, atof(optarg));
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * opt_ori()
+ *
+ * Performs appropriate action for option "ori":
+ * Sets orientation
+\*--------------------------------------------------------------------------*/
+
+static int
+opt_ori(char *opt, char *optarg, void *client_data)
+{
+    plsdiori(atof(optarg));
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * opt_freeaspect()
+ *
+ * Performs appropriate action for option "freeaspect":
+ * Allow aspect ratio to adjust to orientation swaps.
+\*--------------------------------------------------------------------------*/
+
+static int
+opt_freeaspect(char *opt, char *optarg, void *client_data)
+{
+    plsc->freeaspect = 1;
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * opt_portrait()
+ *
+ * Performs appropriate action for option "portrait":
+ * Set portrait mode.  If plsc->portrait = 1, then the orientation for certain 
+ * drivers is changed by 90 deg to portrait orientation from the default
+ * landscape orientation used by PLplot while the  aspect ratio allowed to
+ * adjust using freeaspect.
+ * N.B. the driver list where this flag is honored is currently limited
+ * to ljii, ljiip, psc, ps, and pstex.  A 90 deg rotation is just not
+ * appropriate for certain other drivers.  These drivers where portrait
+ * mode is ignored include display drivers (e.g., xwin, tk), drivers 
+ * which are subequently going to be transformed to another form 
+ * (e.g., meta or pbm), or drivers which are normally used for web 
+ * publishing (e.g., png, jpeg).  That said, the case is not entirely clear
+ * for all drivers so the list of drivers where portrait mode is honored
+ * may increase in the future. To add to the list simply copy the small
+ * bit of code from  ps.c that has to do with pls->portrait to the 
+ * appropriate driver file.
+\*--------------------------------------------------------------------------*/
+
+static int
+opt_portrait(char *opt, char *optarg, void *client_data)
+{
+    plsc->portrait = 1;
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * opt_width()
+ *
+ * Performs appropriate action for option "width":
+ * Sets pen width
+\*--------------------------------------------------------------------------*/
+
+static int
+opt_width(char *opt, char *optarg, void *client_data)
+{
+    int width;
+
+    width = atoi(optarg);
+    if (width < 0) {
+	fprintf(stderr, "?invalid width\n");
+	return 1;
+    }
+    else {
+	plwid(width);
+	plsc->widthlock = 1;
+    }
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * opt_bg()
+ *
+ * Performs appropriate action for option "bg":
+ * Sets background color
+\*--------------------------------------------------------------------------*/
+
+static int
+opt_bg(char *opt, char *optarg, void *client_data)
+{
+    char *rgb;
+    long bgcolor, r, g, b;
+
+/* Always in hex!  Strip off leading "#" (TK-ism) if present. */
+
+    if (*optarg == '#')
+	rgb = optarg + 1;
+    else
+	rgb = optarg;
+
+/* Get number in hex */
+
+    bgcolor = strtol(rgb, NULL, 16);
+
+/* Must be either a 3 or 6 digit hex number */
+/* If 3 digits, each is "doubled" (i.e. ABC becomes AABBCC). */
+
+    switch (strlen(rgb)) {
+    case 3:
+	r = (bgcolor & 0xF00) >> 8;
+	g = (bgcolor & 0x0F0) >> 4;
+	b = (bgcolor & 0x00F);
+
+	r = r | (r << 4);
+	g = g | (g << 4);	/* doubling */
+	b = b | (b << 4);
+	break;
+
+    case 6:
+	r = (bgcolor & 0xFF0000) >> 16;
+	g = (bgcolor & 0x00FF00) >> 8;
+	b = (bgcolor & 0x0000FF);
+	break;
+
+    default:
+	fprintf(stderr, "Unrecognized background color value %s\n", rgb);
+	return 1;
+    }
+
+    plscolbg(r, g, b);
+
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * opt_ncol0()
+ *
+ * Performs appropriate action for option "ncol0":
+ * Sets number of colors to allocate in cmap 0 (upper bound).
+\*--------------------------------------------------------------------------*/
+
+static int
+opt_ncol0(char *opt, char *optarg, void *client_data)
+{
+    plsc->ncol0 = atoi(optarg);
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * opt_ncol1()
+ *
+ * Performs appropriate action for option "ncol1":
+ * Sets number of colors to allocate in cmap 1 (upper bound).
+\*--------------------------------------------------------------------------*/
+
+static int
+opt_ncol1(char *opt, char *optarg, void *client_data)
+{
+    plsc->ncol1 = atoi(optarg);
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * opt_wplt()
+ *
+ * Performs appropriate action for option "wplt":
+ * Sets (zoom) window into plot (e.g. "0,0,0.5,0.5")
+\*--------------------------------------------------------------------------*/
+
+static int
+opt_wplt(char *opt, char *optarg, void *client_data)
+{
+    char *field;
+    PLFLT xl, yl, xr, yr;
+
+    strncpy(opttmp, optarg, OPTMAX-1);
+
+    if ((field = strtok(opttmp, ",")) == NULL)
+	return 1;
+
+    xl = atof(field);
+
+    if ((field = strtok(NULL, ",")) == NULL)
+	return 1;
+
+    yl = atof(field);
+
+    if ((field = strtok(NULL, ",")) == NULL)
+	return 1;
+
+    xr = atof(field);
+
+    if ((field = strtok(NULL, ",")) == NULL)
+	return 1;
+
+    yr = atof(field);
+
+    plsdiplt(xl, yl, xr, yr);
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * opt_drvopt()
+ *
+ * Get driver specific options in the form <option[=value]>[,option[=value]]*
+ * If "value" is not specified, it defaults to "1".
+\*--------------------------------------------------------------------------*/
+
+static int
+opt_drvopt(char *opt, char *optarg, void *client_data)
+{
+  char t, *tt, *option, *value;
+  int fl = 0;
+  DrvOptCmd *drvp;
+
+  option = (char *) malloc((size_t)(1+strlen(optarg))*sizeof(char));
+  if (option == NULL)
+    plexit("opt_drvopt: Out of memory!?");
+
+  value = (char *) malloc((size_t)(1+1)*sizeof(char));
+  if (value == NULL)
+    plexit("opt_drvopt: Out of memory!?");
+
+  drvp = &drv_opt;
+  *option = *value = '\0';
+  tt = option;
+    while((t = *optarg++)) {
+      switch (t) {
+      case ',':
+	if (fl)
+	  fl = 0;
+	else {
+	  value[0] = '1';
+	  value[1] = '\0';
+	}
+	
+	*tt = '\0'; tt = option;
+	drvp->option = plstrdup(option); /* it should not be release, because of familying */
+	drvp->value = plstrdup(value); /* don't release */
+	drvp->next = (DrvOptCmd *) malloc(sizeof(DrvOptCmd)); /* don't release */
+	if (drvp->next == NULL)
+	  plexit("opt_drvopt: Out of memory!?\n");
+
+	drvp = drvp->next;
+	break;
+
+      case '=':
+	fl = 1;
+	*tt = '\0'; tt = value;
+	break;
+
+      default:
+	*tt++ = t;
+      }
+    }
+
+    *tt = '\0';
+    if (!fl) {
+      value[0] = '1';
+      value[1] = '\0';
+    }
+
+    drvp->option = plstrdup(option); /* don't release */
+    drvp->value = plstrdup(value); /* don't release */
+    drvp->next = NULL;
+
+#ifdef DEBUG
+    fprintf(stderr, "\nopt_drvopt: -drvopt parsed options:\n");
+    drvp = &drv_opt;
+    do 
+      fprintf(stderr, "%s %s\n", drvp->option, drvp->value);
+    while(drvp = drvp->next);
+    fprintf(stderr, "\n");
+#endif
+
+    free(option); free(value);
+
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * opt_fam()
+ *
+ * Performs appropriate action for option "fam":
+ * Enables family output files
+\*--------------------------------------------------------------------------*/
+
+static int
+opt_fam(char *opt, char *optarg, void *client_data)
+{
+    plsfam(1, -1, -1);
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * opt_fsiz()
+ *
+ * Performs appropriate action for option "fsiz":
+ * Sets size of a family member file (may be somewhat larger since eof must
+ * occur at a page break).  Also turns on familying.  Example usage:
+ *
+ *	-fsiz 5M	(5 MB)
+ *	-fsiz 300K	(300 KB)
+ *	-fsiz .3M	(same)
+ *	-fsiz .5G	(half a GB)
+ *
+ * Note case of the trailing suffix doesn't matter.
+ * If no suffix, defaults to MB.
+\*--------------------------------------------------------------------------*/
+
+static int
+opt_fsiz(char *opt, char *optarg, void *client_data)
+{
+    PLINT bytemax;
+    int len = strlen(optarg);
+    char lastchar = optarg[len-1];
+    PLFLT multiplier = 1.0e6;
+    char *spec = (char*)malloc(len+1);
+
+/* Interpret optional suffix */
+
+    switch (lastchar) {
+    case 'k':
+    case 'K':
+	multiplier = 1.0e3; len--;
+	break;
+    case 'm':
+    case 'M':
+	multiplier = 1.0e6; len--;
+	break;
+    case 'g':
+    case 'G':
+	multiplier = 1.0e9; len--;
+	break;
+    }
+    strncpy(spec, optarg, len);
+    spec[len] = '\0';
+
+    bytemax = multiplier * atof(spec);
+    if (bytemax == 0) {
+	fprintf(stderr, "?invalid bytemax\n");
+	return 1;
+    }
+    plsfam(1, -1, bytemax);
+
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * opt_fbeg()
+ *
+ * Performs appropriate action for option "fbeg":
+ * Starts with the specified family member number.
+\*--------------------------------------------------------------------------*/
+
+static int
+opt_fbeg(char *opt, char *optarg, void *client_data)
+{
+    plsc->member = atoi(optarg);
+
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * opt_finc()
+ *
+ * Performs appropriate action for option "finc":
+ * Specify increment between family members.
+\*--------------------------------------------------------------------------*/
+
+static int
+opt_finc(char *opt, char *optarg, void *client_data)
+{
+    plsc->finc = atoi(optarg);
+
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * opt_fflen()
+ *
+ * Performs appropriate action for option "fflen":
+ * Specify minimum field length for family member number.
+\*--------------------------------------------------------------------------*/
+
+static int
+opt_fflen(char *opt, char *optarg, void *client_data)
+{
+    plsc->fflen = atoi(optarg);
+
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * opt_np()
+ *
+ * Performs appropriate action for option "np":
+ * Disables pause between pages
+\*--------------------------------------------------------------------------*/
+
+static int
+opt_np(char *opt, char *optarg, void *client_data)
+{
+    plspause(0);
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * opt_nopixmap()
+ *
+ * Performs appropriate action for option "nopixmap":
+ * Disables use of pixmaps in X drivers
+\*--------------------------------------------------------------------------*/
+
+static int
+opt_nopixmap(char *opt, char *optarg, void *client_data)
+{
+    plsc->nopixmap = 1;
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * opt_db()
+ *
+ * Performs appropriate action for option "db":
+ * Double buffer X output (update only done on eop or Expose)
+\*--------------------------------------------------------------------------*/
+
+static int
+opt_db(char *opt, char *optarg, void *client_data)
+{
+    plsc->db = 1;
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * opt_bufmax()
+ *
+ * Performs appropriate action for option "bufmax":
+ * Sets size of data buffer for tk driver
+\*--------------------------------------------------------------------------*/
+
+static int
+opt_bufmax(char *opt, char *optarg, void *client_data)
+{
+    plsc->bufmax = atoi(optarg);
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * opt_server_name()
+ *
+ * Performs appropriate action for option "server_name":
+ * Sets main window name of server (Tcl/TK/DP driver only)
+\*--------------------------------------------------------------------------*/
+
+static int
+opt_server_name(char *opt, char *optarg, void *client_data)
+{
+    plsc->server_name = optarg;
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * opt_server_host()
+ *
+ * Performs appropriate action for option "server_host":
+ * Sets host to run server on (Tcl/TK/DP driver only)
+\*--------------------------------------------------------------------------*/
+
+static int
+opt_server_host(char *opt, char *optarg, void *client_data)
+{
+    plsc->server_host = optarg;
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * opt_server_port()
+ *
+ * Performs appropriate action for option "server_port":
+ * Sets port to talk to server on (Tcl/TK/DP driver only)
+\*--------------------------------------------------------------------------*/
+
+static int
+opt_server_port(char *opt, char *optarg, void *client_data)
+{
+    plsc->server_port = optarg;
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * opt_user()
+ *
+ * Performs appropriate action for option "user":
+ * Sets user name on remote node (for remsh), dp driver only
+\*--------------------------------------------------------------------------*/
+
+static int
+opt_user(char *opt, char *optarg, void *client_data)
+{
+    plsc->user = optarg;
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * opt_plserver()
+ *
+ * Performs appropriate action for option "plserver":
+ * Sets name to use when invoking server (Tcl/TK/DP driver only)
+\*--------------------------------------------------------------------------*/
+
+static int
+opt_plserver(char *opt, char *optarg, void *client_data)
+{
+    plsc->plserver = optarg;
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * opt_plwindow()
+ *
+ * Performs appropriate action for option "plwindow":
+ * Sets PLplot window name
+\*--------------------------------------------------------------------------*/
+
+static int
+opt_plwindow(char *opt, char *optarg, void *client_data)
+{
+    plsc->plwindow = (char *) malloc((size_t)(1+strlen(optarg))*sizeof(char));
+    strcpy (plsc->plwindow, optarg);
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * opt_tcl_cmd()
+ *
+ * Performs appropriate action for option "tcl_cmd":
+ * Sets TCL command(s) to eval on startup
+\*--------------------------------------------------------------------------*/
+
+static int
+opt_tcl_cmd(char *opt, char *optarg, void *client_data)
+{
+    plsc->tcl_cmd = optarg;
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * opt_auto_path()
+ *
+ * Performs appropriate action for option "auto_path":
+ * Sets additional directories to autoload
+\*--------------------------------------------------------------------------*/
+
+static int
+opt_auto_path(char *opt, char *optarg, void *client_data)
+{
+    plsc->auto_path = optarg;
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * opt_px()
+ *
+ * Performs appropriate action for option "px":
+ * Set packing in x
+\*--------------------------------------------------------------------------*/
+
+static int
+opt_px(char *opt, char *optarg, void *client_data)
+{
+    plssub(atoi(optarg), -1);
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * opt_py()
+ *
+ * Performs appropriate action for option "py":
+ * Set packing in y
+\*--------------------------------------------------------------------------*/
+
+static int
+opt_py(char *opt, char *optarg, void *client_data)
+{
+    plssub(-1, atoi(optarg));
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * opt_geo()
+ *
+ * Performs appropriate action for option "geo":
+ * Set geometry for output window
+ *   e.g.,  "-geometry 400x400+100+0"
+ * or with offsets alone "-geometry +Xoff+Yoff"
+ *   e.g., "-geometry +100+0"
+\*--------------------------------------------------------------------------*/
+
+static int
+opt_geo(char *opt, char *optarg, void *client_data)
+{
+    char *field;
+    PLFLT xdpi = 0., ydpi = 0.;
+    PLINT xwid = 0, ywid = 0, xoff = 0, yoff = 0;
+    
+/* The TK driver uses the geometry string directly */    
+
+    plsc->geometry = (char *) malloc((size_t)(1+strlen(optarg))*sizeof(char));
+    strcpy (plsc->geometry, optarg);
+
+/* Set up plplot dimensions */
+
+    strncpy(opttmp, optarg, OPTMAX-1);
+    if (strchr (opttmp, 'x')) {
+
+    /* -geometry WxH or -geometry WxH+Xoff+Yoff */
+
+	field = strtok (opttmp, "x");
+	xwid = atoi (field);
+	if (xwid == 0)
+	    fprintf (stderr, "?invalid xwid\n");
+
+	if ((field = strtok (NULL, "+")) == NULL)
+	    return 1;
+
+	ywid = atoi (field);
+	if (ywid == 0)
+	    fprintf (stderr, "?invalid ywid\n");
+
+	field = strtok (NULL, "+");
+    }
+    else {
+
+    /* -geometry +Xoff or -geometry +Xoff+Yoff only */
+
+	field = strtok (opttmp, "+");
+    }
+
+    if (field != NULL) {
+	xoff = atoi (field);
+	if ((field = strtok (NULL, "+")) != NULL)
+	    yoff = atoi (field);
+    }
+
+    plspage (xdpi, ydpi, xwid, ywid, xoff, yoff);
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * opt_tk_file()
+ *
+ * File name for plserver tk_file option
+\*--------------------------------------------------------------------------*/
+   
+static int
+opt_tk_file(char *opt, char *optarg, void *client_data)
+{
+    plsc->tk_file = (char *) malloc((size_t)(1+strlen(optarg))*sizeof(char));
+    strcpy (plsc->tk_file, optarg);
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * opt_dpi()
+ *
+ * Performs appropriate action for option "dpi":
+ * Set dpi resolution for output device
+ *   e.g.,  "-dpi 600x300", will set X dpi to 600 and Y dpi to 300
+ * 		or 
+ *   e.g., "-dpi 1200"
+ * Will set both X and Y dpi to 1200 dpi
+\*--------------------------------------------------------------------------*/
+
+static int
+opt_dpi(char *opt, char *optarg, void *client_data)
+{
+    char *field;
+    PLFLT xdpi = 0., ydpi = 0.;
+    PLINT xwid = 0, ywid = 0, xoff = 0, yoff = 0;
+    
+    strncpy(opttmp, optarg, OPTMAX-1);
+    if (strchr (opttmp, 'x')) {
+	field = strtok (opttmp, "x");
+	xdpi = atof (field);
+	if (xdpi == 0)
+	    fprintf (stderr, "?invalid xdpi\n");
+
+	if ((field = strtok (NULL, " ")) == NULL)
+	   return 1;
+	   
+        ydpi = atof (field);
+        if (ydpi == 0)
+	   fprintf (stderr, "?invalid ydpi\n");
+
+    } else {
+	xdpi = atof (opttmp);
+	ydpi=xdpi;
+	if (xdpi==0) return 1;
+    }
+
+    plspage (xdpi, ydpi, xwid, ywid, xoff, yoff);
+    return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * opt_dev_compression()
+ *
+ * Sets device compression
+\*--------------------------------------------------------------------------*/
+
+static int
+opt_dev_compression(char *opt, char *optarg, void *client_data)
+{
+    PLINT comp = 0;
+   
+    comp = atoi(optarg);
+    if (comp == 0) {
+	fprintf(stderr, "?invalid compression\n");
+	return 1;
+    }
+    plscompression (comp);
+
+    return 0;
+}
diff --git a/collects/plot/src/all/plbox.c b/collects/plot/src/all/plbox.c
new file mode 100644
index 0000000000..b55bc8fa70
--- /dev/null
+++ b/collects/plot/src/all/plbox.c
@@ -0,0 +1,1352 @@
+/* $Id: plbox.c,v 1.2 2005/03/17 21:39:21 eli Exp $
+
+	Routines for drawing axes & box around the current viewport.
+*/
+
+#include "plplotP.h"
+
+static PLFLT xlog[8] =
+{
+    0.301030, 0.477121, 0.602060, 0.698970,
+    0.778151, 0.845098, 0.903090, 0.954243
+};
+
+/* Static function prototypes */
+
+static void
+plxybx(const char *opt, const char *label, PLFLT wx1, PLFLT wy1,
+       PLFLT wx2, PLFLT wy2, PLFLT vmin, PLFLT vmax,
+       PLFLT tick, PLINT nsub, PLINT nolast, PLINT *digits);
+
+static void
+plzbx(const char *opt, const char *label, PLINT right, PLFLT dx, PLFLT dy,
+      PLFLT wx, PLFLT wy1, PLFLT wy2, PLFLT vmin, PLFLT vmax,
+      PLFLT tick, PLINT nsub, PLINT *digits);
+
+static void
+plxytx(PLFLT wx1, PLFLT wy1, PLFLT wx2, PLFLT wy2,
+       PLFLT disp, PLFLT pos, PLFLT just, const char *text);
+
+static void
+plztx(const char *opt, PLFLT dx, PLFLT dy, PLFLT wx, PLFLT wy1,
+      PLFLT wy2, PLFLT disp, PLFLT pos, PLFLT just, const char *text);
+
+static void
+plform(PLFLT value, PLINT scale, PLINT prec, char *result, PLINT ll, PLINT lf);
+
+static void
+grid_box(const char *xopt, PLFLT xtick1, PLINT nxsub1,
+	 const char *yopt, PLFLT ytick1, PLINT nysub1);
+
+static void
+label_box(const char *xopt, PLFLT xtick1, const char *yopt, PLFLT ytick1);
+
+/*--------------------------------------------------------------------------*\
+ * void plbox()
+ *
+ * This draws a box around the current viewport, complete with axes, ticks,
+ * numeric labels, and grids, according to input specification.  Just a
+ * front-end to plaxes(), which allows arbitrary placement of coordinate
+ * axes when plotted (here the origin is at 0,0).  See the documentation for
+ * plaxes() for more info.
+\*--------------------------------------------------------------------------*/
+
+void
+c_plbox(const char *xopt, PLFLT xtick, PLINT nxsub,
+	const char *yopt, PLFLT ytick, PLINT nysub)
+{
+    c_plaxes(0.0, 0.0, xopt, xtick, nxsub, yopt, ytick, nysub);
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plaxes()
+ *
+ * This draws a box around the current viewport, complete with axes,
+ * ticks, numeric labels, and grids, according to input specification.
+ *
+ * x0 and y0 specify the origin of the axes.
+ *
+ * xopt and yopt are character strings which define the box as follows:
+ *
+ * a: Draw axis (X is horizontal line Y=0, Y is vertical line X=0)
+ * b: Draw bottom (X) or left (Y) edge of frame
+ * c: Draw top (X) or right (Y) edge of frame
+ * f: Always use fixed point numeric labels
+ * g: Draws a grid at the major tick interval
+ * h: Draws a grid at the minor tick interval
+ * i: Inverts tick marks
+ * l: Logarithmic axes, major ticks at decades, minor ticks at units
+ * n: Write numeric label at conventional location
+ * m: Write numeric label at unconventional location
+ * t: Draw major tick marks
+ * s: Draw minor tick marks
+ * v: (for Y only) Label vertically
+ *
+ * xtick, ytick are the major tick intervals required, zero for
+ * automatic selection
+ *
+ * nxsub, nysub are the number of subtick intervals in a major tick
+ * interval
+\*--------------------------------------------------------------------------*/
+
+void
+c_plaxes(PLFLT x0, PLFLT y0,
+	 const char *xopt, PLFLT xtick, PLINT nxsub,
+	 const char *yopt, PLFLT ytick, PLINT nysub)
+{
+    PLINT lax, lbx, lcx, lgx, lix, llx, lsx, ltx;
+    PLINT lay, lby, lcy, lgy, liy, lly, lsy, lty;
+    PLINT xmajor, xminor, ymajor, yminor;
+    PLINT i, i1x, i2x, i3x, i4x, i1y, i2y, i3y, i4y;
+    PLINT nxsub1, nysub1;
+    PLINT lxmin, lxmax, lymin, lymax;
+    PLINT pxmin, pxmax, pymin, pymax;
+    PLINT vppxmi, vppxma, vppymi, vppyma;
+    PLFLT xtick1, ytick1, vpwxmi, vpwxma, vpwymi, vpwyma;
+    PLFLT vpwxmin, vpwxmax, vpwymin, vpwymax;
+    PLFLT xp0, yp0, tn, tp, temp;
+
+    if (plsc->level < 3) {
+	plabort("plbox: Please set up window first");
+	return;
+    }
+
+/* Open the clip limits to the subpage limits */
+
+    plP_gclp(&lxmin, &lxmax, &lymin, &lymax);
+    plP_gphy(&pxmin, &pxmax, &pymin, &pymax);
+    plP_sclp(pxmin, pxmax, pymin, pymax);
+
+    vppxmi = plsc->vppxmi;
+    vppxma = plsc->vppxma;
+    vppymi = plsc->vppymi;
+    vppyma = plsc->vppyma;
+
+/* Convert world coordinates to physical */
+
+    xp0 = plP_wcpcx(x0);
+    yp0 = plP_wcpcy(y0);
+
+/* Set plot options from input */
+
+    lax = plP_stsearch(xopt, 'a');
+    lbx = plP_stsearch(xopt, 'b');
+    lcx = plP_stsearch(xopt, 'c');
+    lgx = plP_stsearch(xopt, 'g');
+    lix = plP_stsearch(xopt, 'i');
+    llx = plP_stsearch(xopt, 'l');
+    lsx = plP_stsearch(xopt, 's');
+    ltx = plP_stsearch(xopt, 't');
+
+    lay = plP_stsearch(yopt, 'a');
+    lby = plP_stsearch(yopt, 'b');
+    lcy = plP_stsearch(yopt, 'c');
+    lgy = plP_stsearch(yopt, 'g');
+    liy = plP_stsearch(yopt, 'i');
+    lly = plP_stsearch(yopt, 'l');
+    lsy = plP_stsearch(yopt, 's');
+    lty = plP_stsearch(yopt, 't');
+
+/* Tick and subtick sizes in device coords */
+
+    xmajor = MAX(ROUND(plsc->majht * plsc->ypmm), 1);
+    ymajor = MAX(ROUND(plsc->majht * plsc->xpmm), 1);
+    xminor = MAX(ROUND(plsc->minht * plsc->ypmm), 1);
+    yminor = MAX(ROUND(plsc->minht * plsc->xpmm), 1);
+
+    nxsub1 = nxsub;
+    nysub1 = nysub;
+    xtick1 = llx ? 1.0 : xtick;
+    ytick1 = lly ? 1.0 : ytick;
+
+    plgvpw(&vpwxmin, &vpwxmax, &vpwymin, &vpwymax);
+/* n.b. large change; vpwxmi always numerically less than vpwxma, and
+ * similarly for vpwymi */
+    vpwxmi = (vpwxmax > vpwxmin) ? vpwxmin : vpwxmax;
+    vpwxma = (vpwxmax > vpwxmin) ? vpwxmax : vpwxmin;
+    vpwymi = (vpwymax > vpwymin) ? vpwymin : vpwymax;
+    vpwyma = (vpwymax > vpwymin) ? vpwymax : vpwymin;
+
+    lax = lax && vpwymi < y0 && y0 < vpwyma ;
+    lay = lay && vpwxmi < x0 && x0 < vpwxma ;
+
+/* Calculate tick spacing */
+
+    if (ltx || lgx) 
+	pldtik(vpwxmi, vpwxma, &xtick1, &nxsub1);
+
+    if (lty || lgy) 
+	pldtik(vpwymi, vpwyma, &ytick1, &nysub1);
+/* n.b. large change; xtick1, nxsub1, ytick1, nysub1 always positive. */
+
+/* Set up tick variables */
+
+    if (lix) {
+	i1x = xminor;
+	i2x = 0;
+	i3x = xmajor;
+	i4x = 0;
+    }
+    else {
+	i1x = 0;
+	i2x = xminor;
+	i3x = 0;
+	i4x = xmajor;
+    }
+
+    if (liy) {
+	i1y = yminor;
+	i2y = 0;
+	i3y = ymajor;
+	i4y = 0;
+    }
+    else {
+	i1y = 0;
+	i2y = yminor;
+	i3y = 0;
+	i4y = ymajor;
+    }
+
+/* Draw the bottom edge of the box */
+
+    if (lbx) {
+	plP_movphy(vppxmi, vppymi);
+	if (ltx) {
+	    tp = xtick1 * floor(vpwxmi / xtick1);
+	    for (;;) {
+		tn = tp + xtick1;
+		if (lsx) {
+		    if (llx) {
+			for (i = 0; i <= 7; i++) {
+			    temp = tp + xlog[i];
+			    if (BETW(temp, vpwxmi, vpwxma))
+				plxtik(plP_wcpcx(temp), vppymi, i1x, i2x);
+			}
+		    }
+		    else {
+			for (i = 1; i <= nxsub1 - 1; i++) {
+			    temp = tp + i * xtick1 / nxsub1;
+			    if (BETW(temp, vpwxmi, vpwxma))
+				plxtik(plP_wcpcx(temp), vppymi, i1x, i2x);
+			}
+		    }
+		}
+		if (!BETW(tn, vpwxmi, vpwxma))
+		    break;
+		plxtik(plP_wcpcx(tn), vppymi, i3x, i4x);
+		tp = tn;
+	    }
+	}
+	plP_draphy(vppxma, vppymi);
+    }
+
+/* Draw right-hand edge of box */
+
+    if (lcy) {
+	plP_movphy(vppxma, vppymi);
+	if (lty) {
+	    tp = ytick1 * floor(vpwymi / ytick1);
+	    for (;;) {
+		tn = tp + ytick1;
+		if (lsy) {
+		    if (lly) {
+			for (i = 0; i <= 7; i++) {
+			    temp = tp + xlog[i];
+			    if (BETW(temp, vpwymi, vpwyma))
+				plytik(vppxma, plP_wcpcy(temp), i2y, i1y);
+			}
+		    }
+		    else {
+			for (i = 1; i <= nysub1 - 1; i++) {
+			    temp = tp + i * ytick1 / nysub1;
+			    if (BETW(temp, vpwymi, vpwyma))
+				plytik(vppxma, plP_wcpcy(temp), i2y, i1y);
+			}
+		    }
+		}
+		if (!BETW(tn, vpwymi, vpwyma))
+		    break;
+		plytik(vppxma, plP_wcpcy(tn), i4y, i3y);
+		tp = tn;
+	    }
+	}
+	plP_draphy(vppxma, vppyma);
+    }
+
+/* Draw the top edge of the box */
+
+    if (lcx) {
+	plP_movphy(vppxma, vppyma);
+	if (ltx) {
+	    tp = xtick1 * (floor(vpwxma / xtick1) + 1);
+	    for (;;) {
+		tn = tp - xtick1;
+		if (lsx) {
+		    if (llx) {
+			for (i = 7; i >= 0; i--) {
+			    temp = tn + xlog[i];
+			    if (BETW(temp, vpwxmi, vpwxma))
+				plxtik(plP_wcpcx(temp), vppyma, i2x, i1x);
+			}
+		    }
+		    else {
+			for (i = nxsub1 - 1; i >= 1; i--) {
+			    temp = tn + i * xtick1 / nxsub1;
+			    if (BETW(temp, vpwxmi, vpwxma))
+				plxtik(plP_wcpcx(temp), vppyma, i2x, i1x);
+			}
+		    }
+		}
+		if (!BETW(tn, vpwxmi, vpwxma))
+		    break;
+		plxtik(plP_wcpcx(tn), vppyma, i4x, i3x);
+		tp = tn;
+	    }
+	}
+	plP_draphy(vppxmi, vppyma);
+    }
+
+/* Draw left-hand edge of box */
+
+    if (lby) {
+	plP_movphy(vppxmi, vppyma);
+	if (lty) {
+	    tp = ytick1 * (floor(vpwyma / ytick1) + 1);
+	    for (;;) {
+		tn = tp - ytick1;
+		if (lsy) {
+		    if (lly) {
+			for (i = 7; i >= 0; i--) {
+			    temp = tn + xlog[i];
+			    if (BETW(temp, vpwymi, vpwyma))
+				plytik(vppxmi, plP_wcpcy(temp), i1y, i2y);
+			}
+		    }
+		    else {
+			for (i = nysub1 - 1; i >= 1; i--) {
+			    temp = tn + i * ytick1 / nysub1;
+			    if (BETW(temp, vpwymi, vpwyma))
+				plytik(vppxmi, plP_wcpcy(temp), i1y, i2y);
+			}
+		    }
+		}
+		if (!BETW(tn, vpwymi, vpwyma))
+		    break;
+		plytik(vppxmi, plP_wcpcy(tn), i3y, i4y);
+		tp = tn;
+	    }
+	}
+	plP_draphy(vppxmi, vppymi);
+    }
+
+/* Draw the horizontal axis */
+
+    if (lax) {
+	plP_movphy(vppxmi, yp0);
+	if (ltx) {
+	    tp = xtick1 * floor(vpwxmi / xtick1);
+	    for (;;) {
+		tn = tp + xtick1;
+		if (lsx) {
+		    if (llx) {
+			for (i = 0; i <= 7; i++) {
+			    temp = tp + xlog[i];
+			    if (BETW(temp, vpwxmi, vpwxma))
+				plxtik(plP_wcpcx(temp), yp0, xminor, xminor);
+			}
+		    }
+		    else {
+			for (i = 1; i <= nxsub1 - 1; i++) {
+			    temp = tp + i * xtick1 / nxsub1;
+			    if (BETW(temp, vpwxmi, vpwxma))
+				plxtik(plP_wcpcx(temp), yp0, xminor, xminor);
+			}
+		    }
+		}
+		if (!BETW(tn, vpwxmi, vpwxma))
+		    break;
+		plxtik(plP_wcpcx(tn), yp0, xmajor, xmajor);
+		tp = tn;
+	    }
+	}
+	plP_draphy(vppxma, yp0);
+    }
+
+/* Draw the vertical axis */
+
+    if (lay) {
+	plP_movphy(xp0, vppymi);
+	if (lty) {
+	    tp = ytick1 * floor(vpwymi / ytick1);
+	    for (;;) {
+		tn = tp + ytick1;
+		if (lsy) {
+		    if (lly) {
+			for (i = 0; i <= 7; i++) {
+			    temp = tp + xlog[i];
+			    if (BETW(temp, vpwymi, vpwyma))
+				plytik(xp0, plP_wcpcy(temp), yminor, yminor);
+			}
+		    }
+		    else {
+			for (i = 1; i <= nysub1 - 1; i++) {
+			    temp = tp + i * ytick1 / nysub1;
+			    if (BETW(temp, vpwymi, vpwyma))
+				plytik(xp0, plP_wcpcy(temp), yminor, yminor);
+			}
+		    }
+		}
+		if (!BETW(tn, vpwymi, vpwyma))
+		    break;
+		plytik(xp0, plP_wcpcy(tn), ymajor, ymajor);
+		tp = tn;
+	    }
+	}
+	plP_draphy(xp0, vppyma);
+    }
+
+/* Draw grids */
+
+    grid_box(xopt, xtick1, nxsub1, yopt, ytick1, nysub1);
+
+/* Write labels */
+
+    label_box(xopt, xtick1, yopt, ytick1);
+
+/* Restore the clip limits to viewport edge */
+
+    plP_sclp(lxmin, lxmax, lymin, lymax);
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plbox3()
+ *
+ * This is the 3-d analogue of plbox().
+\*--------------------------------------------------------------------------*/
+
+MZ_DLLEXPORT
+void
+c_plbox3(const char *xopt, const char *xlabel, PLFLT xtick, PLINT nsubx,
+	 const char *yopt, const char *ylabel, PLFLT ytick, PLINT nsuby,
+	 const char *zopt, const char *zlabel, PLFLT ztick, PLINT nsubz)
+{
+    PLFLT dx, dy, tx, ty, ux, uy;
+    PLFLT xmin, xmax, ymin, ymax, zmin, zmax, zscale;
+    PLFLT cxx, cxy, cyx, cyy, cyz;
+    PLINT ln;
+    PLINT *zbflg, *zbcol;
+    PLFLT *zbtck;
+    PLINT xdigmax, xdigits;
+    PLINT ydigmax, ydigits;
+    PLINT zdigmax, zdigits;
+
+    if (plsc->level < 3) {
+	plabort("plbox3: Please set up window first");
+	return;
+    }
+
+    plP_gw3wc(&cxx, &cxy, &cyx, &cyy, &cyz);
+    plP_gdom(&xmin, &xmax, &ymin, &ymax);
+    plP_grange(&zscale, &zmin, &zmax);
+
+    plgxax(&xdigmax, &xdigits);
+    plgyax(&ydigmax, &ydigits);
+    plgzax(&zdigmax, &zdigits);
+
+    xdigits = xdigmax;
+    ydigits = ydigmax;
+    zdigits = zdigmax;
+
+/* We have to wait until after the plot is drawn to draw back */
+/* grid so store this stuff. */
+
+    plP_gzback(&zbflg, &zbcol, &zbtck);
+    *zbflg = plP_stsearch(zopt, 'd');
+    if (*zbflg) {
+	*zbtck = ztick;		/* save tick spacing */
+	*zbcol = plsc->icol0;	/* and color */
+    }
+
+    if (cxx >= 0.0 && cxy <= 0.0) {
+	ln = plP_stsearch(xopt, 'n');
+	tx = plP_w3wcx(xmin, ymin, zmin);
+	ty = plP_w3wcy(xmin, ymin, zmin);
+	ux = plP_w3wcx(xmax, ymin, zmin);
+	uy = plP_w3wcy(xmax, ymin, zmin);
+	plxybx(xopt, xlabel, tx, ty, ux, uy,
+	       xmin, xmax, xtick, nsubx, 0, &xdigits);
+
+	dx = ux - tx;
+	dy = uy - ty;
+	plzbx(zopt, zlabel, 1, dx, dy, ux, uy,
+	      plP_w3wcy(xmax, ymin, zmax), zmin, zmax, ztick, nsubz, &zdigits);
+
+	tx = plP_w3wcx(xmin, ymax, zmin);
+	ty = plP_w3wcy(xmin, ymax, zmin);
+	ux = plP_w3wcx(xmin, ymin, zmin);
+	uy = plP_w3wcy(xmin, ymin, zmin);
+	plxybx(yopt, ylabel, tx, ty, ux, uy,
+	       ymax, ymin, ytick, nsuby, ln, &ydigits);
+
+	dx = ux - tx;
+	dy = uy - ty;
+/* restore zdigits to initial value for second call */
+        zdigits = zdigmax;     
+	plzbx(zopt, zlabel, 0, dx, dy, tx, ty,
+	      plP_w3wcy(xmin, ymax, zmax), zmin, zmax, ztick, nsubz, &zdigits);
+    }
+    else if (cxx <= 0.0 && cxy <= 0.0) {
+	ln = plP_stsearch(yopt, 'n');
+	tx = plP_w3wcx(xmin, ymax, zmin);
+	ty = plP_w3wcy(xmin, ymax, zmin);
+	ux = plP_w3wcx(xmin, ymin, zmin);
+	uy = plP_w3wcy(xmin, ymin, zmin);
+	plxybx(yopt, ylabel, tx, ty, ux, uy,
+	       ymax, ymin, ytick, nsuby, 0, &ydigits);
+
+	dx = ux - tx;
+	dy = uy - ty;
+	plzbx(zopt, zlabel, 1, dx, dy, ux, uy,
+	      plP_w3wcy(xmin, ymin, zmax), zmin, zmax, ztick, nsubz, &zdigits);
+
+	tx = plP_w3wcx(xmax, ymax, zmin);
+	ty = plP_w3wcy(xmax, ymax, zmin);
+	ux = plP_w3wcx(xmin, ymax, zmin);
+	uy = plP_w3wcy(xmin, ymax, zmin);
+	plxybx(xopt, xlabel, tx, ty, ux, uy,
+	       xmax, xmin, xtick, nsubx, ln, &xdigits);
+
+	dx = ux - tx;
+	dy = uy - ty;
+/* restore zdigits to initial value for second call */
+        zdigits = zdigmax;     
+	plzbx(zopt, zlabel, 0, dx, dy, tx, ty,
+	      plP_w3wcy(xmax, ymax, zmax), zmin, zmax, ztick, nsubz, &zdigits);
+    }
+    else if (cxx <= 0.0 && cxy >= 0.0) {
+	ln = plP_stsearch(xopt, 'n');
+	tx = plP_w3wcx(xmax, ymax, zmin);
+	ty = plP_w3wcy(xmax, ymax, zmin);
+	ux = plP_w3wcx(xmin, ymax, zmin);
+	uy = plP_w3wcy(xmin, ymax, zmin);
+	plxybx(xopt, xlabel, tx, ty, ux, uy,
+	       xmax, xmin, xtick, nsubx, 0, &xdigits);
+
+	dx = ux - tx;
+	dy = uy - ty;
+	plzbx(zopt, zlabel, 1, dx, dy, ux, uy,
+	      plP_w3wcy(xmin, ymax, zmax), zmin, zmax, ztick, nsubz, &zdigits);
+
+	tx = plP_w3wcx(xmax, ymin, zmin);
+	ty = plP_w3wcy(xmax, ymin, zmin);
+	ux = plP_w3wcx(xmax, ymax, zmin);
+	uy = plP_w3wcy(xmax, ymax, zmin);
+	plxybx(yopt, ylabel, tx, ty, ux, uy,
+	       ymin, ymax, ytick, nsuby, ln, &ydigits);
+
+	dx = ux - tx;
+	dy = uy - ty;
+/* restore zdigits to initial value for second call */
+        zdigits = zdigmax;     
+	plzbx(zopt, zlabel, 0, dx, dy, tx, ty,
+	      plP_w3wcy(xmax, ymin, zmax), zmin, zmax, ztick, nsubz, &zdigits);
+    }
+    else if (cxx >= 0.0 && cxy >= 0.0) {
+	ln = plP_stsearch(yopt, 'n');
+	tx = plP_w3wcx(xmax, ymin, zmin);
+	ty = plP_w3wcy(xmax, ymin, zmin);
+	ux = plP_w3wcx(xmax, ymax, zmin);
+	uy = plP_w3wcy(xmax, ymax, zmin);
+	plxybx(yopt, ylabel, tx, ty, ux, uy,
+	       ymin, ymax, ytick, nsuby, 0, &ydigits);
+
+	dx = ux - tx;
+	dy = uy - ty;
+	plzbx(zopt, zlabel, 1, dx, dy, ux, uy,
+	      plP_w3wcy(xmax, ymax, zmax), zmin, zmax, ztick, nsubz, &zdigits);
+
+	tx = plP_w3wcx(xmin, ymin, zmin);
+	ty = plP_w3wcy(xmin, ymin, zmin);
+	ux = plP_w3wcx(xmax, ymin, zmin);
+	uy = plP_w3wcy(xmax, ymin, zmin);
+	plxybx(xopt, xlabel, tx, ty, ux, uy,
+	       xmin, xmax, xtick, nsubx, ln, &xdigits);
+
+	dx = ux - tx;
+	dy = uy - ty;
+/* restore zdigits to initial value for second call */
+        zdigits = zdigmax;     
+	plzbx(zopt, zlabel, 0, dx, dy, tx, ty,
+	      plP_w3wcy(xmin, ymin, zmax), zmin, zmax, ztick, nsubz, &zdigits);
+    }
+    plsxax(xdigmax, xdigits);
+    plsyax(ydigmax, ydigits);
+    plszax(zdigmax, zdigits);
+}
+
+/*--------------------------------------------------------------------------*\
+ * Support routines for 3d box draw.
+\*--------------------------------------------------------------------------*/
+
+/*--------------------------------------------------------------------------*\
+ * void plxybx()
+ *
+ * This draws a sloping line from (wx1,wy1) to (wx2,wy2) which represents an
+ * axis of a 3-d graph with data values from "vmin" to "vmax". Depending on
+ * "opt", vertical ticks and/or subticks are placed on the line at major tick
+ * interval "tick" with "nsub" subticks between major ticks. If "tick" and/or
+ * "nsub" is zero, automatic tick positions are computed
+ *
+ * b: Draw box boundary
+ * f: Always use fixed point numeric labels
+ * i: Inverts tick marks (i.e. drawn downwards)
+ * l: Logarithmic axes, major ticks at decades, minor ticks at units
+ * n: Write numeric label
+ * t: Draw major tick marks
+ * s: Draw minor tick marks
+ * u: Write label on line
+\*--------------------------------------------------------------------------*/
+
+static void
+plxybx(const char *opt, const char *label, PLFLT wx1, PLFLT wy1,
+       PLFLT wx2, PLFLT wy2, PLFLT vmin_in, PLFLT vmax_in,
+       PLFLT tick, PLINT nsub, PLINT nolast, PLINT *digits)
+{
+    static char string[40];
+    PLINT lb, lf, li, ll, ln, ls, lt, lu;
+    PLINT major, minor, mode, prec, scale;
+    PLINT i, i1, i2, i3, i4;
+    PLINT nsub1;
+    PLFLT pos, tn, tp, temp, height, tick1, vmin, vmax;
+/* Note that 'tspace' is the minimim distance away (in fractional number
+ * of ticks) from the boundary that an X or Y numerical label can be drawn. */
+    PLFLT dwx, dwy, lambda, tcrit, tspace = 0.1;
+   
+    vmin = (vmax_in > vmin_in) ? vmin_in : vmax_in;
+    vmax = (vmax_in > vmin_in) ? vmax_in : vmin_in;
+
+    dwx = wx2 - wx1;
+    dwy = wy2 - wy1;
+
+/* Tick and subtick sizes in device coords */
+
+    major = MAX(ROUND(plsc->majht * plsc->ypmm), 1);
+    minor = MAX(ROUND(plsc->minht * plsc->ypmm), 1);
+
+    tick1 = tick;
+    nsub1 = nsub;
+
+    lb = plP_stsearch(opt, 'b');
+    lf = plP_stsearch(opt, 'f');
+    li = plP_stsearch(opt, 'i');
+    ll = plP_stsearch(opt, 'l');
+    ln = plP_stsearch(opt, 'n');
+    ls = plP_stsearch(opt, 's');
+    lt = plP_stsearch(opt, 't');
+    lu = plP_stsearch(opt, 'u');
+
+    if (lu)
+	plxytx(wx1, wy1, wx2, wy2, 3.2, 0.5, 0.5, label);
+    if (!lb)
+	return;
+
+    if (ll)
+	tick1 = (vmax > vmin) ? 1.0 : -1.0 ;
+    if (lt)
+	pldtik(vmin, vmax, &tick1, &nsub1);
+
+    if (li) {
+	i1 = minor;
+	i2 = 0;
+	i3 = major;
+	i4 = 0;
+    }
+    else {
+	i1 = 0;
+	i2 = minor;
+	i3 = 0;
+	i4 = major;
+    }
+
+/* Draw the line */
+
+    plP_movwor(wx1, wy1);
+    if (lt) {
+	tp = tick1 * floor(vmin / tick1);
+	for (;;) {
+	    tn = tp + tick1;
+	    if (ls) {
+		if (ll) {
+		    for (i = 0; i <= 7; i++) {
+			temp = tp + xlog[i];
+			if (BETW(temp, vmin, vmax)) {
+			    lambda = (vmax_in > vmin_in)? 
+			       (temp - vmin) / (vmax - vmin):
+			       (vmax - temp) / (vmax - vmin);
+			    plxtik(plP_wcpcx((PLFLT) (wx1 + lambda * dwx)),
+				   plP_wcpcy((PLFLT) (wy1 + lambda * dwy)),
+				   i1, i2);
+			}
+		    }
+		}
+		else {
+		    for (i = 1; i <= nsub1 - 1; i++) {
+			temp = tp + i * (tn - tp) / nsub1;
+			if (BETW(temp, vmin, vmax)) {
+			    lambda = (vmax_in > vmin_in)? 
+			       (temp - vmin) / (vmax - vmin):
+			       (vmax - temp) / (vmax - vmin);
+			    plxtik(plP_wcpcx((PLFLT) (wx1 + lambda * dwx)),
+				   plP_wcpcy((PLFLT) (wy1 + lambda * dwy)),
+				   i1, i2);
+			}
+		    }
+		}
+	    }
+	    temp = tn;
+	    if (!BETW(temp, vmin, vmax))
+		break;
+
+	    lambda = (vmax_in > vmin_in)? 
+	       (temp - vmin) / (vmax - vmin):
+	       (vmax - temp) / (vmax - vmin);
+	    plxtik(plP_wcpcx((PLFLT) (wx1 + lambda * dwx)),
+		   plP_wcpcy((PLFLT) (wy1 + lambda * dwy)), i3, i4);
+	    tp = tn;
+	}
+    }
+
+    plP_drawor(wx2, wy2);
+
+/* Label the line */
+
+    if (ln && lt) {
+	pldprec(vmin, vmax, tick1, lf, &mode, &prec, *digits, &scale);
+	pos = 1.0;
+	height = 3.2;
+        tcrit = tspace*tick1;
+	tp = tick1 * (1. + floor(vmin / tick1));
+	for (tn = tp; BETW(tn, vmin, vmax); tn += tick1) {
+	   if(BETW(tn, vmin+tcrit, vmax-tcrit)) {
+	    plform(tn, scale, prec, string, ll, lf);
+	    pos = (vmax_in > vmin_in)? 
+	       (tn - vmin) / (vmax - vmin):
+	       (vmax - tn) / (vmax - vmin);
+	    plxytx(wx1, wy1, wx2, wy2, 1.5, pos, 0.5, string);
+	   }
+	}
+	*digits = 2;
+	if (!ll && mode) {
+	    sprintf(string, "(x10#u%d#d)", (int) scale);
+	    plxytx(wx1, wy1, wx2, wy2, height, 1.0, 0.5, string);
+	}
+    }
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plxytx()
+ *
+ * Prints out text along a sloping axis joining world coordinates
+ * (wx1,wy1) to (wx2,wy2). Parameters are as for plmtext.
+\*--------------------------------------------------------------------------*/
+
+static void
+plxytx(PLFLT wx1, PLFLT wy1, PLFLT wx2, PLFLT wy2,
+       PLFLT disp, PLFLT pos, PLFLT just, const char *text)
+{
+    PLINT x, y, refx, refy;
+    PLFLT shift, cc, ss, wx, wy;
+    PLFLT xdv, ydv, xmm, ymm, refxmm, refymm, xform[4], diag;
+    PLFLT dispx, dispy;
+    PLFLT chrdef, chrht;
+
+    cc = plsc->wmxscl * (wx2 - wx1);
+    ss = plsc->wmyscl * (wy2 - wy1);
+    diag = sqrt(cc * cc + ss * ss);
+    cc /= diag;
+    ss /= diag;
+    wx = wx1 + pos * (wx2 - wx1);
+    wy = wy1 + pos * (wy2 - wy1);
+
+    xform[0] = cc;
+    xform[1] = 0.0;
+    xform[2] = ss;
+    xform[3] = 1.0;
+
+    xdv = plP_wcdcx(wx);
+    ydv = plP_wcdcy(wy);
+
+    dispx = 0.;
+    dispy = -disp;
+
+    plgchr(&chrdef, &chrht);
+    shift = (just == 0.0) ? 0.0 : plstrl(text) * just;
+
+    xmm = plP_dcmmx(xdv) + dispx * chrht;
+    ymm = plP_dcmmy(ydv) + dispy * chrht;
+    refxmm = xmm - shift * xform[0];
+    refymm = ymm - shift * xform[2];
+
+    x = plP_mmpcx(xmm);
+    y = plP_mmpcy(ymm);
+    refx = plP_mmpcx(refxmm);
+    refy = plP_mmpcy(refymm);
+
+    plP_text(0, just, xform, x, y, refx, refy, text);
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plzbx()
+ *
+ * This draws a vertical line from (wx,wy1) to (wx,wy2) which represents the
+ * vertical axis of a 3-d graph with data values from "vmin" to "vmax".
+ * Depending on "opt", ticks and/or subticks are placed on the line at major
+ * tick interval "tick" with "nsub" subticks between major ticks. If "tick"
+ * and/or "nsub" is zero, automatic tick positions are computed
+ *
+ * b: Draws left-hand axis
+ * c: Draws right-hand axis
+ * f: Always use fixed point numeric labels
+ * i: Inverts tick marks (i.e. drawn to the left)
+ * l: Logarithmic axes, major ticks at decades, minor ticks at units
+ * m: Write numeric label on right axis
+ * n: Write numeric label on left axis
+ * s: Draw minor tick marks
+ * t: Draw major tick marks
+ * u: Writes left-hand label
+ * v: Writes right-hand label
+\*--------------------------------------------------------------------------*/
+
+static void
+plzbx(const char *opt, const char *label, PLINT right, PLFLT dx, PLFLT dy,
+      PLFLT wx, PLFLT wy1, PLFLT wy2, PLFLT vmin_in, PLFLT vmax_in,
+      PLFLT tick, PLINT nsub, PLINT *digits)
+{
+    static char string[40];
+    PLINT lb, lc, lf, li, ll, lm, ln, ls, lt, lu, lv;
+    PLINT i, mode, prec, scale;
+    PLINT nsub1, lstring;
+    PLFLT pos, tn, tp, temp, height, tick1;
+    PLFLT dwy, lambda, diag, major, minor, xmajor, xminor;
+    PLFLT ymajor, yminor, dxm, dym, vmin, vmax;
+
+    vmin = (vmax_in > vmin_in) ? vmin_in : vmax_in;
+    vmax = (vmax_in > vmin_in) ? vmax_in : vmin_in;
+   
+    dwy = wy2 - wy1;
+
+/* Tick and subtick sizes in device coords */
+
+    major = plsc->majht;
+    minor = plsc->minht;
+
+    tick1 = tick;
+    nsub1 = nsub;
+
+    lb = plP_stsearch(opt, 'b');
+    lc = plP_stsearch(opt, 'c');
+    lf = plP_stsearch(opt, 'f');
+    li = plP_stsearch(opt, 'i');
+    ll = plP_stsearch(opt, 'l');
+    lm = plP_stsearch(opt, 'm');
+    ln = plP_stsearch(opt, 'n');
+    ls = plP_stsearch(opt, 's');
+    lt = plP_stsearch(opt, 't');
+    lu = plP_stsearch(opt, 'u');
+    lv = plP_stsearch(opt, 'v');
+
+    if (lu && !right)
+	plztx("h", dx, dy, wx, wy1, wy2, 5.0, 0.5, 0.5, label);
+
+    if (lv && right)
+	plztx("h", dx, dy, wx, wy1, wy2, -5.0, 0.5, 0.5, label);
+    
+    if (right && !lc)
+	return;
+
+    if (!right && !lb)
+	return;
+    
+    if (ll)
+	tick1 = 1.0;
+
+    if (lt)
+	pldtik(vmin, vmax, &tick1, &nsub1);
+
+    if ((li && !right) || (!li && right)) {
+	minor = -minor;
+	major = -major;
+    }
+
+    dxm = dx * plsc->wmxscl;
+    dym = dy * plsc->wmyscl;
+    diag = sqrt(dxm * dxm + dym * dym);
+
+    xminor = minor * dxm / diag;
+    xmajor = major * dxm / diag;
+    yminor = minor * dym / diag;
+    ymajor = major * dym / diag;
+
+/* Draw the line */
+
+    plP_movwor(wx, wy1);
+    if (lt) {
+	tp = tick1 * floor(vmin / tick1);
+	for (;;) {
+	    tn = tp + tick1;
+	    if (ls) {
+		if (ll) {
+		    for (i = 0; i <= 7; i++) {
+			temp = tp + xlog[i];
+			if (BETW(temp, vmin, vmax)) {
+			    lambda = (vmax_in > vmin_in)? 
+			       (temp - vmin) / (vmax - vmin):
+			       (vmax - temp) / (vmax - vmin);
+			    plstik(plP_wcmmx(wx),
+				   plP_wcmmy((PLFLT) (wy1 + lambda * dwy)),
+				   xminor, yminor);
+			}
+		    }
+		}
+		else {
+		    for (i = 1; i <= nsub1 - 1; i++) {
+			temp = tp + i * tick1 / nsub1;
+			if (BETW(temp, vmin, vmax)) {
+			    lambda = (vmax_in > vmin_in)? 
+			       (temp - vmin) / (vmax - vmin):
+			       (vmax - temp) / (vmax - vmin);
+			    plstik(plP_wcmmx(wx),
+				   plP_wcmmy((PLFLT) (wy1 + lambda * dwy)),
+				   xminor, yminor);
+			}
+		    }
+		}
+	    }
+	    temp = tn;
+	    if (!BETW(temp, vmin, vmax))
+		break;
+	    lambda = (vmax_in > vmin_in)? 
+	        (temp - vmin) / (vmax - vmin):
+	        (vmax - temp) / (vmax - vmin);
+	    plstik(plP_wcmmx(wx), plP_wcmmy((PLFLT) (wy1 + lambda * dwy)),
+		   xmajor, ymajor);
+	    tp = tn;
+	}
+    }
+
+    plP_drawor(wx, wy2);
+
+/* Label the line */
+
+    if ((ln || lm) && lt) {
+	pldprec(vmin, vmax, tick1, lf, &mode, &prec, *digits, &scale);
+	*digits = 0;
+	tp = tick1 * floor(vmin / tick1);
+	for (tn = tp + tick1; BETW(tn, vmin, vmax); tn += tick1) {
+	    plform(tn, scale, prec, string, ll, lf);
+	    pos = (vmax_in > vmin_in)? 
+	        (tn - vmin) / (vmax - vmin):
+	        (vmax - tn) / (vmax - vmin);
+	    if (ln && !right)
+		plztx("v", dx, dy, wx, wy1, wy2, 0.5, pos, 1.0, string);
+
+	    if (lm && right)
+		plztx("v", dx, dy, wx, wy1, wy2, -0.5, pos, 0.0, string);
+
+	    lstring = strlen(string);
+	    *digits = MAX(*digits, lstring);
+	}
+	if (!ll && mode) {
+	    sprintf(string, "(x10#u%d#d)", (int) scale);
+	    pos = 1.15;
+	    height = 0.5;
+	    if (ln && !right) {
+		plztx("v", dx, dy, wx, wy1, wy2, height, pos, 0.5, string);
+	    }
+	    if (lm && right) {
+		plztx("v", dx, dy, wx, wy1, wy2,
+		      (PLFLT) -height, pos, 0.5, string);
+	    }
+	}
+    }
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plztx()
+ *
+ * Prints out text along a vertical axis for a 3d plot joining
+ * world coordinates (wx,wy1) to (wx,wy2).
+\*--------------------------------------------------------------------------*/
+
+static void
+plztx(const char *opt, PLFLT dx, PLFLT dy, PLFLT wx, PLFLT wy1,
+      PLFLT wy2, PLFLT disp, PLFLT pos, PLFLT just, const char *text)
+{
+    PLINT refx = 0, refy = 0, x = 0, y = 0, vert = 0;
+    PLFLT shift, cc, ss, wy;
+    PLFLT xdv, ydv, xmm, ymm, refxmm, refymm, xform[4], diag;
+    PLFLT dispx, dispy;
+    PLFLT chrdef, chrht;
+
+    cc = plsc->wmxscl * dx;
+    ss = plsc->wmyscl * dy;
+    diag = sqrt(cc * cc + ss * ss);
+    cc /= diag;
+    ss /= diag;
+    wy = wy1 + pos * (wy2 - wy1);
+
+    if (plP_stsearch(opt, 'v'))
+	vert = 0;
+    else if (plP_stsearch(opt, 'h'))
+	vert = 1;
+
+    if (vert) {
+	xform[0] = 0.0;
+	xform[1] = -cc;
+	xform[2] = 1.0;
+	xform[3] = -ss;
+    } else {
+	xform[0] = cc;
+	xform[1] = 0.0;
+	xform[2] = ss;
+	xform[3] = 1.0;
+    }
+
+    xdv = plP_wcdcx(wx);
+    ydv = plP_wcdcy(wy);
+
+    dispx = -disp * cc;
+    dispy = -disp * ss;
+
+    plgchr(&chrdef, &chrht);
+    shift = (just == 0.0) ? 0.0 : plstrl(text) * just;
+
+    xmm = plP_dcmmx(xdv) + dispx * chrht;
+    ymm = plP_dcmmy(ydv) + dispy * chrht;
+    refxmm = xmm - shift * xform[0];
+    refymm = ymm - shift * xform[2];
+
+    x = plP_mmpcx(xmm);
+    y = plP_mmpcy(ymm);
+    refx = plP_mmpcx(refxmm);
+    refy = plP_mmpcy(refymm);
+
+    plP_text(0, just, xform, x, y, refx, refy, text);
+}
+
+/*--------------------------------------------------------------------------*\
+ * void grid_box()
+ *
+ * Draws grids at tick locations (major and/or minor).
+ *
+ * Note that 'tspace' is the minimim distance away (in fractional number
+ * of ticks or subticks) from the boundary a grid line can be drawn.  If
+ * you are too close, it looks bad.
+\*--------------------------------------------------------------------------*/
+
+static void
+grid_box(const char *xopt, PLFLT xtick1, PLINT nxsub1,
+	 const char *yopt, PLFLT ytick1, PLINT nysub1)
+{
+    PLINT lgx, lhx, llx;
+    PLINT lgy, lhy, lly;
+    PLFLT vpwxmi, vpwxma, vpwymi, vpwyma;
+    PLFLT vpwxmin, vpwxmax, vpwymin, vpwymax;
+    PLFLT tn, temp, tcrit, tspace = 0.1;
+    PLINT i;
+
+/* Set plot options from input */
+
+    lgx = plP_stsearch(xopt, 'g');
+    lhx = plP_stsearch(xopt, 'h');
+    llx = plP_stsearch(xopt, 'l');
+
+    lgy = plP_stsearch(yopt, 'g');
+    lhy = plP_stsearch(yopt, 'h');
+    lly = plP_stsearch(yopt, 'l');
+
+    plgvpw(&vpwxmin, &vpwxmax, &vpwymin, &vpwymax);
+/* n.b. large change; vpwxmi always numerically less than vpwxma, and
+ * similarly for vpwymi */
+    vpwxmi = (vpwxmax > vpwxmin) ? vpwxmin : vpwxmax;
+    vpwxma = (vpwxmax > vpwxmin) ? vpwxmax : vpwxmin;
+    vpwymi = (vpwymax > vpwymin) ? vpwymin : vpwymax;
+    vpwyma = (vpwymax > vpwymin) ? vpwymax : vpwymin;
+
+/* Draw grid in x direction. */
+
+    if (lgx) {
+	for (tn = xtick1 * floor(vpwxmi/xtick1);
+	     tn <= vpwxma; tn += xtick1) {
+	    if (lhx) {
+		if (llx) {
+		    PLFLT otemp = tn;
+		    for (i = 0; i <= 7; i++) {
+			temp = tn + xlog[i];
+			tcrit = (temp - otemp)*tspace;
+			otemp = temp;
+			if (BETW(temp, vpwxmi+tcrit, vpwxma-tcrit))
+			    pljoin(temp, vpwymi, temp, vpwyma);
+		    }
+		}
+		else {
+		    for (i = 1; i <= nxsub1 - 1; i++) {
+			temp = tn + i * xtick1 / nxsub1;
+			tcrit = xtick1 / nxsub1 * tspace;
+			if (BETW(temp, vpwxmi+tcrit, vpwxma-tcrit))
+			    pljoin(temp, vpwymi, temp, vpwyma);
+		    }
+		}
+	    }
+	    tcrit = xtick1*tspace;
+	    if (BETW(tn, vpwxmi+tcrit, vpwxma-tcrit))
+	        pljoin(tn, vpwymi, tn, vpwyma);
+	}
+    }
+
+/* Draw grid in y direction */
+
+    if (lgy) {
+	tn = ytick1 * floor(vpwymi / ytick1 + tspace);
+	for (tn = ytick1 * floor(vpwymi/ytick1);
+	     tn <= vpwyma; tn += ytick1) {
+	    if (lhy) {
+		if (lly) {
+		    PLFLT otemp = tn;
+		    for (i = 0; i <= 7; i++) {
+			temp = tn + xlog[i];
+			tcrit = (temp - otemp)*tspace;
+			otemp = temp;
+			if (BETW(temp, vpwymi+tcrit, vpwyma-tcrit))
+			    pljoin(vpwxmi, temp, vpwxma, temp);
+		    }
+		}
+		else {
+		    for (i = 1; i <= nysub1 - 1; i++) {
+			temp = tn + i * ytick1 / nysub1;
+			tcrit = ytick1 / nysub1 * tspace;
+			if (BETW(temp, vpwymi+tcrit, vpwyma-tcrit))
+			    pljoin(vpwxmi, temp, vpwxma, temp);
+		    }
+		}
+	    }
+	    tcrit = ytick1*tspace;
+	    if (BETW(tn, vpwymi+tcrit, vpwyma-tcrit))
+	    pljoin(vpwxmi, tn, vpwxma, tn);
+	}
+    }
+}
+
+/*--------------------------------------------------------------------------*\
+ * void label_box()
+ *
+ * Writes numeric labels on side(s) of box.
+\*--------------------------------------------------------------------------*/
+
+static void
+label_box(const char *xopt, PLFLT xtick1, const char *yopt, PLFLT ytick1)
+{
+    static char string[40];
+    PLINT lfx, lix, llx, lmx, lnx, ltx;
+    PLINT lfy, liy, lly, lmy, lny, lty, lvy;
+    PLFLT vpwxmi, vpwxma, vpwymi, vpwyma;
+    PLFLT vpwxmin, vpwxmax, vpwymin, vpwymax;
+    PLFLT pos, tn, tp, offset, height;
+
+/* Set plot options from input */
+
+    lfx = plP_stsearch(xopt, 'f');
+    lix = plP_stsearch(xopt, 'i');
+    llx = plP_stsearch(xopt, 'l');
+    lmx = plP_stsearch(xopt, 'm');
+    lnx = plP_stsearch(xopt, 'n');
+    ltx = plP_stsearch(xopt, 't');
+
+    lfy = plP_stsearch(yopt, 'f');
+    liy = plP_stsearch(yopt, 'i');
+    lly = plP_stsearch(yopt, 'l');
+    lmy = plP_stsearch(yopt, 'm');
+    lny = plP_stsearch(yopt, 'n');
+    lty = plP_stsearch(yopt, 't');
+    lvy = plP_stsearch(yopt, 'v');
+
+    plgvpw(&vpwxmin, &vpwxmax, &vpwymin, &vpwymax);
+/* n.b. large change; vpwxmi always numerically less than vpwxma, and
+ * similarly for vpwymi */
+    vpwxmi = (vpwxmax > vpwxmin) ? vpwxmin : vpwxmax;
+    vpwxma = (vpwxmax > vpwxmin) ? vpwxmax : vpwxmin;
+    vpwymi = (vpwymax > vpwymin) ? vpwymin : vpwymax;
+    vpwyma = (vpwymax > vpwymin) ? vpwymax : vpwymin;
+
+/* Write horizontal label(s) */
+
+    if ((lmx || lnx) && ltx) {
+	PLINT xmode, xprec, xdigmax, xdigits, xscale;
+
+	plgxax(&xdigmax, &xdigits);
+	pldprec(vpwxmi, vpwxma, xtick1, lfx, &xmode, &xprec, xdigmax, &xscale);
+
+	tp = xtick1 * (1. + floor(vpwxmi / xtick1));
+	for (tn = tp; BETW(tn, vpwxmi, vpwxma); tn += xtick1) {
+	    plform(tn, xscale, xprec, string, llx, lfx);
+	    height = lix ? 1.75 : 1.5;
+	    pos = (vpwxmax > vpwxmin)? 
+	        (tn - vpwxmi) / (vpwxma - vpwxmi):
+	        (vpwxma - tn) / (vpwxma - vpwxmi);
+  	    if (lnx)
+		plmtex("b", height, pos, 0.5, string);
+	    if (lmx)
+		plmtex("t", height, pos, 0.5, string);
+	}
+	xdigits = 2;
+	plsxax(xdigmax, xdigits);
+
+    /* Write separate exponential label if mode = 1. */
+
+	if (!llx && xmode) {
+	    pos = 1.0;
+	    height = 3.2;
+	    sprintf(string, "(x10#u%d#d)", (int) xscale);
+	    if (lnx)
+		plmtex("b", height, pos, 0.5, string);
+	    if (lmx)
+		plmtex("t", height, pos, 0.5, string);
+	}
+    }
+
+/* Write vertical label(s) */
+
+    if ((lmy || lny) && lty) {
+	PLINT ymode, yprec, ydigmax, ydigits, yscale;
+
+	plgyax(&ydigmax, &ydigits);
+	pldprec(vpwymi, vpwyma, ytick1, lfy, &ymode, &yprec, ydigmax, &yscale);
+
+	ydigits = 0;
+	tp = ytick1 * (1. + floor(vpwymi / ytick1));
+	for (tn = tp; BETW(tn, vpwymi, vpwyma); tn += ytick1) {
+	    plform(tn, yscale, yprec, string, lly, lfy);
+	    pos = (vpwymax > vpwymin)? 
+	        (tn - vpwymi) / (vpwyma - vpwymi):
+	        (vpwyma - tn) / (vpwyma - vpwymi);
+	    if (lny) {
+		if (lvy) {
+		    height = liy ? 1.0 : 0.5;
+		    plmtex("lv", height, pos, 1.0, string);
+		} else {
+		    height = liy ? 1.75 : 1.5;
+		    plmtex("l", height, pos, 0.5, string);
+		}
+	    }
+	    if (lmy) {
+		if (lvy) {
+		    height = liy ? 1.0 : 0.5;
+		    plmtex("rv", height, pos, 0.0, string);
+		} else {
+		    height = liy ? 1.75 : 1.5;
+		    plmtex("r", height, pos, 0.5, string);
+		}
+	    }
+	    ydigits = MAX(ydigits, strlen(string));
+	}
+	if (!lvy)
+	    ydigits = 2;
+
+	plsyax(ydigmax, ydigits);
+
+    /* Write separate exponential label if mode = 1. */
+
+	if (!lly && ymode) {
+	    sprintf(string, "(x10#u%d#d)", (int) yscale);
+	    offset = 0.02;
+	    height = 2.0;
+	    if (lny) {
+		pos = 0.0 - offset;
+		plmtex("t", height, pos, 1.0, string);
+	    }
+	    if (lmy) {
+		pos = 1.0 + offset;
+		plmtex("t", height, pos, 0.0, string);
+	    }
+	}
+    }
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plform()
+ *
+ * Formats a PLFLT value in one of the following formats.
+ *
+ * If ll (logarithmic), then:
+ *
+ *    -	If lf (fixed), then used fixed point notation, i.e. .1, 1, 10, etc,
+ *	with unnecessary trailing .'s or 0's removed.
+ *
+ *    -	If !lf (default), then use exponential notation, i.e. 10^-1, etc.
+ *
+ * If !ll (linear), then:
+ *
+ *    - If scale == 0, use fixed point format with "prec" places after the
+ *	decimal point.
+ *
+ *    -	If scale == 1, use scientific notation with one place before the
+ *	decimal point and "prec" places after.  In this case, the value
+ *	must be divided by 10^scale.
+\*--------------------------------------------------------------------------*/
+
+static void
+plform(PLFLT value, PLINT scale, PLINT prec, char *string, PLINT ll, PLINT lf)
+{
+    if (ll) {
+
+    /* Logarithmic */
+
+	if (lf) {
+
+	/* Fixed point, i.e. .1, 1, 10, etc */
+
+	    int exponent = ROUND(value);
+
+	    value = pow(10.0, exponent);
+	    if (exponent < 0) {
+		char form[10];
+		sprintf(form, "%%.%df", ABS(exponent));
+		sprintf(string, form, value);
+	    }
+	    else {
+		sprintf(string, "%d", (int) value);
+	    }
+	}
+	else {
+
+	/* Exponential, i.e. 10^-1, 10^0, 10^1, etc */
+
+	    sprintf(string, "10#u%d", (int) ROUND(value));
+	}
+    }
+    else {
+
+    /* Linear */
+
+	PLINT setpre, precis;
+	char form[10], temp[30];
+	double scale2;
+
+	plP_gprec(&setpre, &precis);
+
+	if (setpre)
+	    prec = precis;
+
+	if (scale)
+	    value /= pow(10.,(double)scale);
+
+    /* This is necessary to prevent labels like "-0.0" on some systems */
+
+	scale2 = pow(10., prec);
+	value = floor((value * scale2) + .5) / scale2;
+
+	sprintf(form, "%%.%df", (int) prec);
+	sprintf(temp, form, value);
+	strcpy(string, temp);
+    }
+}
diff --git a/collects/plot/src/all/plbuf.c b/collects/plot/src/all/plbuf.c
new file mode 100644
index 0000000000..8badfd21fa
--- /dev/null
+++ b/collects/plot/src/all/plbuf.c
@@ -0,0 +1,718 @@
+/* $Id: plbuf.c,v 1.1 2004/03/01 20:54:50 cozmic Exp $
+
+    Handle plot buffer.
+
+    Copyright 1992
+    Maurice LeBrun
+
+    This software may be freely copied, modified and redistributed without
+    fee provided that this copyright notice is preserved intact on all
+    copies and modified copies.
+
+    There is no warranty or other guarantee of fitness of this software.
+    It is provided solely "as is". The author(s) disclaim(s) all
+    responsibility and liability with respect to this software's usage or
+    its effect upon hardware or computer systems.
+*/
+
+#define NEED_PLDEBUG
+#include "plplotP.h"
+#include "drivers.h"
+#include "metadefs.h"
+
+#include <string.h>
+
+/* Function prototypes */
+
+static int	rd_command	(PLStream *pls, U_CHAR *p_c);
+static int	wr_command	(PLStream *pls, U_CHAR c);
+static void	plbuf_control	(PLStream *pls, U_CHAR c);
+
+static void	rdbuf_init	(PLStream *pls);
+static void	rdbuf_line	(PLStream *pls);
+static void	rdbuf_polyline	(PLStream *pls);
+static void	rdbuf_eop	(PLStream *pls);
+static void	rdbuf_bop	(PLStream *pls);
+static void	rdbuf_state	(PLStream *pls);
+static void	rdbuf_esc	(PLStream *pls);
+
+static void	plbuf_fill	(PLStream *pls);
+static void	rdbuf_fill	(PLStream *pls);
+static void	plbuf_swin	(PLStream *pls, PLWindow *plwin);
+static void	rdbuf_swin	(PLStream *pls);
+
+/*--------------------------------------------------------------------------*\
+ * plbuf_init()
+ *
+ * Initialize device.
+ * Actually just disables writes if plot buffer is already open (occurs
+ * when one stream is cloned, as in printing).
+\*--------------------------------------------------------------------------*/
+
+void
+plbuf_init(PLStream *pls)
+{
+    dbug_enter("plbuf_init");
+
+    pls->plbuf_read = FALSE;
+    if (pls->plbufFile != NULL) 
+	pls->plbuf_write = FALSE;
+}
+
+/*--------------------------------------------------------------------------*\
+ * plbuf_line()
+ *
+ * Draw a line in the current color from (x1,y1) to (x2,y2).
+\*--------------------------------------------------------------------------*/
+
+void
+plbuf_line(PLStream *pls, short x1a, short y1a, short x2a, short y2a)
+{
+    short xpl[2], ypl[2];
+
+    dbug_enter("plbuf_line");
+
+    wr_command(pls, (U_CHAR) LINE);
+
+    xpl[0] = x1a;
+    xpl[1] = x2a;
+    ypl[0] = y1a;
+    ypl[1] = y2a;
+
+    fwrite(xpl, sizeof(short), 2, pls->plbufFile);
+    fwrite(ypl, sizeof(short), 2, pls->plbufFile);
+}
+
+/*--------------------------------------------------------------------------*\
+ * plbuf_polyline()
+ *
+ * Draw a polyline in the current color.
+\*--------------------------------------------------------------------------*/
+
+void
+plbuf_polyline(PLStream *pls, short *xa, short *ya, PLINT npts)
+{
+    dbug_enter("plbuf_polyline");
+
+    wr_command(pls, (U_CHAR) POLYLINE);
+    fwrite(&npts, sizeof(PLINT), 1, pls->plbufFile);
+
+    fwrite(xa, sizeof(short), npts, pls->plbufFile);
+    fwrite(ya, sizeof(short), npts, pls->plbufFile);
+}
+
+/*--------------------------------------------------------------------------*\
+ * plbuf_eop()
+ *
+ * End of page.
+\*--------------------------------------------------------------------------*/
+
+void
+plbuf_eop(PLStream *pls)
+{
+    dbug_enter("plbuf_eop");
+}
+
+/*--------------------------------------------------------------------------*\
+ * plbuf_bop()
+ *
+ * Set up for the next page.
+ * To avoid problems redisplaying partially filled pages, on each BOP the
+ * old file is thrown away and a new one is obtained.  This way we can just
+ * read up to EOF to get everything on the current page.
+ *
+ * Also write state information to ensure the next page is correct.
+\*--------------------------------------------------------------------------*/
+
+void
+plbuf_bop(PLStream *pls)
+{
+    dbug_enter("plbuf_bop");
+
+    plbuf_tidy(pls);
+
+    pls->plbufFile = tmpfile();
+    if (pls->plbufFile == NULL) 
+	plexit("plbuf_init: Error opening plot data storage file.");
+
+    wr_command(pls, (U_CHAR) BOP);
+    plbuf_state(pls, PLSTATE_COLOR0);
+    plbuf_state(pls, PLSTATE_WIDTH);
+}
+
+/*--------------------------------------------------------------------------*\
+ * plbuf_tidy()
+ *
+ * Close graphics file
+\*--------------------------------------------------------------------------*/
+
+void
+plbuf_tidy(PLStream *pls)
+{
+    dbug_enter("plbuf_tidy");
+
+    if (pls->plbufFile == NULL)
+	return;
+
+    fclose(pls->plbufFile);
+    pls->plbufFile = NULL;
+}
+
+/*--------------------------------------------------------------------------*\
+ * plbuf_state()
+ *
+ * Handle change in PLStream state (color, pen width, fill attribute, etc).
+\*--------------------------------------------------------------------------*/
+
+void 
+plbuf_state(PLStream *pls, PLINT op)
+{
+    dbug_enter("plbuf_state");
+
+    wr_command(pls, (U_CHAR) CHANGE_STATE);
+    wr_command(pls, (U_CHAR) op);
+
+    switch (op) {
+
+    case PLSTATE_WIDTH: {
+	U_CHAR width = pls->width;
+
+	fwrite(&width, sizeof(U_CHAR), 1, pls->plbufFile);
+	break;
+    }
+
+    case PLSTATE_COLOR0: {
+	U_CHAR icol0 = pls->icol0;
+	U_CHAR r = pls->curcolor.r;
+	U_CHAR g = pls->curcolor.g;
+	U_CHAR b = pls->curcolor.b;
+
+	fwrite(&icol0, sizeof(U_CHAR), 1, pls->plbufFile);
+	if (icol0 == PL_RGB_COLOR) {
+	    fwrite(&r, sizeof(U_CHAR), 1, pls->plbufFile);
+	    fwrite(&g, sizeof(U_CHAR), 1, pls->plbufFile);
+	    fwrite(&b, sizeof(U_CHAR), 1, pls->plbufFile);
+	}
+	break;
+    }
+
+    case PLSTATE_COLOR1: {
+	U_CHAR icol1 = pls->icol1;
+
+	fwrite(&icol1, sizeof(U_CHAR), 1, pls->plbufFile);
+	break;
+    }
+
+    case PLSTATE_FILL:{
+	signed char patt = pls->patt;
+
+	fwrite(&patt, sizeof(signed char), 1, pls->plbufFile);
+	break;
+    }
+    }
+}
+
+
+/*--------------------------------------------------------------------------*\
+ * plbuf_image()
+ *
+ * write image described in points pls->dev_x[], pls->dev_y[], pls->dev_z[].
+ *                      pls->nptsX, pls->nptsY.
+\*--------------------------------------------------------------------------*/
+
+static void
+plbuf_image(PLStream *pls, IMG_DT *img_dt)
+{
+    PLINT npts = pls->dev_nptsX * pls->dev_nptsY;
+
+    dbug_enter("plbuf_image");
+
+    fwrite(&pls->dev_nptsX, sizeof(PLINT), 1, pls->plbufFile);
+    fwrite(&pls->dev_nptsY, sizeof(PLINT), 1, pls->plbufFile);
+
+    fwrite(&img_dt->xmin, sizeof(PLFLT), 1, pls->plbufFile);
+    fwrite(&img_dt->ymin, sizeof(PLFLT), 1, pls->plbufFile);
+    fwrite(&img_dt->dx, sizeof(PLFLT), 1, pls->plbufFile);
+    fwrite(&img_dt->dy, sizeof(PLFLT), 1, pls->plbufFile);
+
+    fwrite(&pls->dev_zmin, sizeof(short), 1, pls->plbufFile);
+    fwrite(&pls->dev_zmax, sizeof(short), 1, pls->plbufFile);
+
+    fwrite(pls->dev_ix, sizeof(short), npts, pls->plbufFile);
+    fwrite(pls->dev_iy, sizeof(short), npts, pls->plbufFile);
+    fwrite(pls->dev_z, sizeof(unsigned short), (pls->dev_nptsX-1)*(pls->dev_nptsY-1), pls->plbufFile);
+}
+
+/*--------------------------------------------------------------------------*\
+ * plbuf_esc()
+ *
+ * Escape function.  Note that any data written must be in device
+ * independent form to maintain the transportability of the metafile.
+ *
+ * Functions:
+ *
+ *	PLESC_FILL	Fill polygon
+ *	PLESC_SWIN	Set plot window parameters
+ *      PLESC_IMAGE     Draw image
+\*--------------------------------------------------------------------------*/
+
+void
+plbuf_esc(PLStream *pls, PLINT op, void *ptr)
+{
+    dbug_enter("plbuf_esc");
+
+    wr_command(pls, (U_CHAR) ESCAPE);
+    wr_command(pls, (U_CHAR) op);
+
+    switch (op) {
+    case PLESC_FILL:
+	plbuf_fill(pls);
+	break;
+    case PLESC_SWIN:
+	plbuf_swin(pls, (PLWindow *) ptr);
+	break;
+    case PLESC_IMAGE:
+	plbuf_image(pls, (IMG_DT *) ptr);
+	break;
+    }
+}
+
+/*--------------------------------------------------------------------------*\
+ * plbuf_fill()
+ *
+ * Fill polygon described in points pls->dev_x[] and pls->dev_y[].
+\*--------------------------------------------------------------------------*/
+
+static void
+plbuf_fill(PLStream *pls)
+{
+    dbug_enter("plbuf_fill");
+
+    fwrite(&pls->dev_npts, sizeof(PLINT), 1, pls->plbufFile);
+    fwrite(pls->dev_x, sizeof(short), pls->dev_npts, pls->plbufFile);
+    fwrite(pls->dev_y, sizeof(short), pls->dev_npts, pls->plbufFile);
+}
+
+/*--------------------------------------------------------------------------*\
+ * plbuf_swin()
+ *
+ * Set up plot window parameters. 
+\*--------------------------------------------------------------------------*/
+
+static void
+plbuf_swin(PLStream *pls, PLWindow *plwin)
+{
+    fwrite(&plwin->dxmi, sizeof(PLFLT), 1, pls->plbufFile);
+    fwrite(&plwin->dxma, sizeof(PLFLT), 1, pls->plbufFile);
+    fwrite(&plwin->dymi, sizeof(PLFLT), 1, pls->plbufFile);
+    fwrite(&plwin->dyma, sizeof(PLFLT), 1, pls->plbufFile);
+
+    fwrite(&plwin->wxmi, sizeof(PLFLT), 1, pls->plbufFile);
+    fwrite(&plwin->wxma, sizeof(PLFLT), 1, pls->plbufFile);
+    fwrite(&plwin->wymi, sizeof(PLFLT), 1, pls->plbufFile);
+    fwrite(&plwin->wyma, sizeof(PLFLT), 1, pls->plbufFile);
+}
+
+/*--------------------------------------------------------------------------*\
+ * Routines to read from & process the plot buffer.
+\*--------------------------------------------------------------------------*/
+
+/*--------------------------------------------------------------------------*\
+ * rdbuf_init()
+ *
+ * Initialize device.
+\*--------------------------------------------------------------------------*/
+
+static void
+rdbuf_init(PLStream *pls)
+{
+    dbug_enter("rdbuf_init");
+}
+
+/*--------------------------------------------------------------------------*\
+ * rdbuf_line()
+ *
+ * Draw a line in the current color from (x1,y1) to (x2,y2).
+\*--------------------------------------------------------------------------*/
+
+static void
+rdbuf_line(PLStream *pls)
+{
+    short xpl[2], ypl[2];
+    PLINT npts = 2;
+
+    dbug_enter("rdbuf_line");
+
+    fread(xpl, sizeof(short), npts, pls->plbufFile);
+    fread(ypl, sizeof(short), npts, pls->plbufFile);
+
+    plP_line(xpl, ypl);
+}
+
+/*--------------------------------------------------------------------------*\
+ * rdbuf_polyline()
+ *
+ * Draw a polyline in the current color.
+\*--------------------------------------------------------------------------*/
+
+static void
+rdbuf_polyline(PLStream *pls)
+{
+    short xpl[PL_MAXPOLY], ypl[PL_MAXPOLY];
+    PLINT npts;
+
+    dbug_enter("rdbuf_polyline");
+
+    fread(&npts, sizeof(PLINT), 1, pls->plbufFile);
+    fread(xpl, sizeof(short), npts, pls->plbufFile);
+    fread(ypl, sizeof(short), npts, pls->plbufFile);
+
+    plP_polyline(xpl, ypl, npts);
+}
+
+/*--------------------------------------------------------------------------*\
+ * rdbuf_eop()
+ *
+ * End of page.
+\*--------------------------------------------------------------------------*/
+
+static void
+rdbuf_eop(PLStream *pls)
+{
+    dbug_enter("rdbuf_eop");
+}
+
+/*--------------------------------------------------------------------------*\
+ * rdbuf_bop()
+ *
+ * Set up for the next page.
+\*--------------------------------------------------------------------------*/
+
+static void
+rdbuf_bop(PLStream *pls)
+{
+    dbug_enter("rdbuf_bop");
+
+    pls->nplwin = 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * rdbuf_state()
+ *
+ * Handle change in PLStream state (color, pen width, fill attribute, etc).
+\*--------------------------------------------------------------------------*/
+
+static void 
+rdbuf_state(PLStream *pls)
+{
+    U_CHAR op;
+
+    dbug_enter("rdbuf_state");
+
+    fread(&op, sizeof(U_CHAR), 1, pls->plbufFile);
+
+    switch (op) {
+
+    case PLSTATE_WIDTH:{
+	U_CHAR width;
+
+	fread(&width, sizeof(U_CHAR), 1, pls->plbufFile);
+	pls->width = width;
+	plP_state(PLSTATE_WIDTH);
+
+	break;
+    }
+
+    case PLSTATE_COLOR0:{
+	U_CHAR icol0, r, g, b;
+
+	fread(&icol0, sizeof(U_CHAR), 1, pls->plbufFile);
+	if (icol0 == PL_RGB_COLOR) {
+	    fread(&r, sizeof(U_CHAR), 1, pls->plbufFile);
+	    fread(&g, sizeof(U_CHAR), 1, pls->plbufFile);
+	    fread(&b, sizeof(U_CHAR), 1, pls->plbufFile);
+	}
+	else {
+	    if ((int) icol0 > 15) {
+		plwarn("rdbuf_state: Color map 0 entry hosed");
+		icol0 = 1;
+	    }
+	    r = pls->cmap0[icol0].r;
+	    g = pls->cmap0[icol0].g;
+	    b = pls->cmap0[icol0].b;
+	}
+	pls->icol0 = icol0;
+	pls->curcolor.r = r;
+	pls->curcolor.g = g;
+	pls->curcolor.b = b;
+
+	plP_state(PLSTATE_COLOR0);
+	break;
+    }
+
+    case PLSTATE_COLOR1: {
+	U_CHAR icol1;
+
+	fread(&icol1, sizeof(U_CHAR), 1, pls->plbufFile);
+
+	pls->icol1 = icol1;
+	pls->curcolor.r = pls->cmap1[icol1].r;
+	pls->curcolor.g = pls->cmap1[icol1].g;
+	pls->curcolor.b = pls->cmap1[icol1].b;
+
+	plP_state(PLSTATE_COLOR1);
+	break;
+    }
+
+    case PLSTATE_FILL: {
+	signed char patt;
+
+	fread(&patt, sizeof(signed char), 1, pls->plbufFile);
+
+	pls->patt = patt;
+	plP_state(PLSTATE_FILL);
+	break;
+    }
+    }
+}
+
+/*--------------------------------------------------------------------------*\
+ * rdbuf_esc()
+ *
+ * Escape function.
+ * Must fill data structure with whatever data that was written,
+ * then call escape function.
+ *
+ * Note: it is best to only call the escape function for op-codes that
+ * are known to be supported.
+ *
+ * Functions:
+ *
+ *	PLESC_FILL	Fill polygon
+ *	PLESC_SWIN	Set plot window parameters
+ *      PLESC_IMAGE     Draw image
+\*--------------------------------------------------------------------------*/
+
+static void
+rdbuf_image(PLStream *pls);
+
+static void
+rdbuf_esc(PLStream *pls)
+{
+    U_CHAR op;
+
+    dbug_enter("rdbuf_esc");
+
+    fread(&op, sizeof(U_CHAR), 1, pls->plbufFile);
+
+    switch (op) {
+    case PLESC_FILL:
+	rdbuf_fill(pls);
+	break;
+    case PLESC_SWIN:
+	rdbuf_swin(pls);
+	break;
+    case PLESC_IMAGE:
+	rdbuf_image(pls);
+	break;
+    }
+}
+
+/*--------------------------------------------------------------------------*\
+ * rdbuf_fill()
+ *
+ * Fill polygon described by input points.
+\*--------------------------------------------------------------------------*/
+
+static void
+rdbuf_fill(PLStream *pls)
+{
+    short xpl[PL_MAXPOLY], ypl[PL_MAXPOLY];
+    PLINT npts;
+
+    dbug_enter("rdbuf_fill");
+
+    fread(&npts, sizeof(PLINT), 1, pls->plbufFile);
+    fread(xpl, sizeof(short), npts, pls->plbufFile);
+    fread(ypl, sizeof(short), npts, pls->plbufFile);
+    
+    plP_fill(xpl, ypl, npts);
+}
+
+/*--------------------------------------------------------------------------*\
+ * rdbuf_image()
+ *
+ * .
+\*--------------------------------------------------------------------------*/
+
+static void
+rdbuf_image(PLStream *pls)
+{
+  short *dev_ix, *dev_iy;
+  unsigned short *dev_z, dev_zmin, dev_zmax;
+  PLINT nptsX,nptsY, npts;
+  PLFLT xmin, ymin, dx, dy;
+
+    dbug_enter("rdbuf_image");
+
+    fread(&nptsX, sizeof(PLINT), 1, pls->plbufFile);
+    fread(&nptsY, sizeof(PLINT), 1, pls->plbufFile);
+    npts = nptsX*nptsY;
+
+    fread(&xmin, sizeof(PLFLT), 1, pls->plbufFile);
+    fread(&ymin, sizeof(PLFLT), 1, pls->plbufFile);
+    fread(&dx, sizeof(PLFLT), 1, pls->plbufFile);
+    fread(&dy, sizeof(PLFLT), 1, pls->plbufFile);
+
+    fread(&dev_zmin, sizeof(short), 1, pls->plbufFile);
+    fread(&dev_zmax, sizeof(short), 1, pls->plbufFile);
+
+    dev_ix=(short *)malloc(npts*sizeof(short));
+    dev_iy=(short *)malloc(npts*sizeof(short));
+    dev_z=(unsigned short *)malloc((nptsX-1)*(nptsY-1)*sizeof(unsigned short));
+
+    fread(dev_ix, sizeof(short), npts, pls->plbufFile);
+    fread(dev_iy, sizeof(short), npts, pls->plbufFile);
+    fread(dev_z, sizeof(unsigned short), (nptsX-1)*(nptsY-1), pls->plbufFile);
+
+    plP_image(dev_ix, dev_iy, dev_z, nptsX, nptsY, xmin, ymin, dx, dy, dev_zmin, dev_zmax);
+
+    free(dev_ix);
+    free(dev_iy);
+    free(dev_z);
+}
+
+/*--------------------------------------------------------------------------*\
+ * rdbuf_swin()
+ *
+ * Set up plot window parameters. 
+\*--------------------------------------------------------------------------*/
+
+static void
+rdbuf_swin(PLStream *pls)
+{
+    PLWindow plwin;
+
+    fread(&plwin.dxmi, sizeof(PLFLT), 1, pls->plbufFile);
+    fread(&plwin.dxma, sizeof(PLFLT), 1, pls->plbufFile);
+    fread(&plwin.dymi, sizeof(PLFLT), 1, pls->plbufFile);
+    fread(&plwin.dyma, sizeof(PLFLT), 1, pls->plbufFile);
+
+    fread(&plwin.wxmi, sizeof(PLFLT), 1, pls->plbufFile);
+    fread(&plwin.wxma, sizeof(PLFLT), 1, pls->plbufFile);
+    fread(&plwin.wymi, sizeof(PLFLT), 1, pls->plbufFile);
+    fread(&plwin.wyma, sizeof(PLFLT), 1, pls->plbufFile);
+
+    plP_swin(&plwin);
+}
+
+/*--------------------------------------------------------------------------*\
+ * plRemakePlot()
+ *
+ * Rebuilds plot from plot buffer, usually in response to a window
+ * resize or exposure event.
+\*--------------------------------------------------------------------------*/
+
+void
+plRemakePlot(PLStream *pls)
+{
+    U_CHAR c;
+    int plbuf_status;
+
+    dbug_enter("plRemakePlot");
+
+    if (pls->plbufFile == NULL)
+	return;
+
+    rewind(pls->plbufFile);
+
+    plbuf_status = pls->plbuf_write;
+    pls->plbuf_write = FALSE;
+    pls->plbuf_read = TRUE;
+    while (rd_command(pls, &c)) {
+	plbuf_control(pls, c);
+    }
+
+    pls->plbuf_read = FALSE;
+    pls->plbuf_write = plbuf_status;
+}
+
+/*--------------------------------------------------------------------------*\
+ * plbuf_control()
+ *
+ * Processes commands read from the plot buffer.
+\*--------------------------------------------------------------------------*/
+
+static void
+plbuf_control(PLStream *pls, U_CHAR c)
+{
+    static U_CHAR c_old = 0;
+
+    dbug_enter("plbuf_control");
+
+    switch ((int) c) {
+
+    case INITIALIZE:
+	rdbuf_init(pls);
+	break;
+
+    case EOP:
+	rdbuf_eop(pls);
+	break;
+
+    case BOP:
+	rdbuf_bop(pls);
+	break;
+
+    case CHANGE_STATE:
+	rdbuf_state(pls);
+	break;
+
+    case LINE:
+	rdbuf_line(pls);
+	break;
+
+    case POLYLINE:
+	rdbuf_polyline(pls);
+	break;
+
+    case ESCAPE:
+	rdbuf_esc(pls);
+	break;
+
+    default:
+      pldebug("plbuf_control", "Unrecognized command %d, previous %d\n", c, c_old);
+    }
+    c_old = c;
+}
+
+/*--------------------------------------------------------------------------*\
+ * rd_command()
+ *
+ * Read & return the next command
+\*--------------------------------------------------------------------------*/
+
+static int
+rd_command(PLStream *pls, U_CHAR *p_c)
+{
+    int count;
+    
+    count = fread(p_c, sizeof(U_CHAR), 1, pls->plbufFile);
+    return (count);
+}
+
+/*--------------------------------------------------------------------------*\
+ * wr_command()
+ *
+ * Write the next command
+\*--------------------------------------------------------------------------*/
+
+static int
+wr_command(PLStream *pls, U_CHAR c)
+{
+    U_CHAR c1 = c;
+    int count;
+
+    count = fwrite(&c1, sizeof(U_CHAR), 1, pls->plbufFile);
+    return (count);
+}
diff --git a/collects/plot/src/all/plcdemos.h b/collects/plot/src/all/plcdemos.h
new file mode 100644
index 0000000000..1891cd1756
--- /dev/null
+++ b/collects/plot/src/all/plcdemos.h
@@ -0,0 +1,36 @@
+/* $Id: plcdemos.h,v 1.1 2004/03/01 20:54:51 cozmic Exp $
+
+	Everything needed by the C demo programs.
+	Created to avoid junking up plplot.h with this stuff.
+*/
+
+#ifndef __PLCDEMOS_H__
+#define __PLCDEMOS_H__
+
+#include "plConfig.h"
+#include "plplot.h"
+#include <math.h>
+#include <string.h>
+#include <ctype.h>
+
+/* define PI if not defined by math.h */
+
+#ifndef PI
+#define PI 3.1415926535897932384
+#endif
+
+/* various utility macros */
+
+#ifndef MAX
+#define MAX(a,b)    (((a) > (b)) ? (a) : (b))
+#endif
+
+#ifndef MIN
+#define MIN(a,b)    (((a) < (b)) ? (a) : (b))
+#endif
+
+#ifndef ROUND
+#define ROUND(a)    (PLINT)((a)<0. ? ((a)-.5) : ((a)+.5))
+#endif
+
+#endif	/* __PLCDEMOS_H__ */
diff --git a/collects/plot/src/all/plcont.c b/collects/plot/src/all/plcont.c
new file mode 100644
index 0000000000..54b8ea2133
--- /dev/null
+++ b/collects/plot/src/all/plcont.c
@@ -0,0 +1,1296 @@
+/* $Id: plcont.c,v 1.4 2005/03/17 21:39:21 eli Exp $
+
+	Contour plotter.
+*/
+
+#include <math.h>
+
+#include "plplotP.h"
+
+#ifdef MSDOS
+#pragma optimize("",off)
+#endif
+
+/* Static function prototypes. */
+
+static void
+plcntr(PLFLT (*plf2eval) (PLINT, PLINT, PLPointer),
+       PLPointer plf2eval_data,
+       PLINT nx, PLINT ny, PLINT kx, PLINT lx,
+       PLINT ky, PLINT ly, PLFLT flev, PLINT *iscan,
+       PLINT *ixstor, PLINT *iystor, PLINT nstor,
+       void (*pltr) (PLFLT, PLFLT, PLFLT *, PLFLT *, PLPointer),
+       PLPointer pltr_data);
+
+static void
+pldrawcn(PLFLT (*plf2eval) (PLINT, PLINT, PLPointer),
+	 PLPointer plf2eval_data,
+	 PLINT nx, PLINT ny, PLINT kx, PLINT lx,
+	 PLINT ky, PLINT ly, PLFLT flev, char *flabel, PLINT kcol, PLINT krow,
+	 PLINT *p_kscan, PLINT *p_kstor, PLINT *iscan,
+	 PLINT *ixstor, PLINT *iystor, PLINT nstor,
+	 void (*pltr) (PLFLT, PLFLT, PLFLT *, PLFLT *, PLPointer),
+	 PLPointer pltr_data);
+
+static void
+plccal(PLFLT (*plf2eval) (PLINT, PLINT, PLPointer),
+       PLPointer plf2eval_data,
+       PLFLT flev, PLINT ix, PLINT iy,
+       PLINT ixg, PLINT iyg, PLFLT *dist);
+
+static void
+plr45 (PLINT *ix, PLINT *iy, PLINT isens);
+
+static void
+plr135 (PLINT *ix, PLINT *iy, PLINT isens);
+
+static void
+plfloatlabel(PLFLT value, char *string);
+
+static PLFLT
+plP_pcwcx(PLINT x);
+
+static PLFLT
+plP_pcwcy(PLINT y);
+
+static void
+pl_drawcontlabel(PLFLT tpx, PLFLT tpy, char *flabel, PLFLT *distance, PLINT *lastindex);
+
+/* Error flag for aborts */
+
+static int error;
+
+/****************************************/
+/*                                      */
+/* Defaults for contour label printing. */
+/*                                      */
+/****************************************/
+
+/* Font height for contour labels (normalized) */
+static PLFLT
+contlabel_size = 0.3;
+
+/* Offset of label from contour line (if set to 0.0, labels are printed on the lines). */
+static PLFLT
+contlabel_offset = 0.006;
+
+/* Spacing parameter for contour labels */
+static PLFLT
+contlabel_space = 0.1;
+
+/* Activate labels, default off */
+static PLINT
+contlabel_active = 0;
+
+/* If the contour label exceed 10^(limexp) or 10^(-limexp), the exponential format is used */
+static PLINT
+limexp = 4;
+
+/* Number of significant digits */
+static PLINT
+sigprec = 2;
+
+/******** contour lines storage ****************************/
+
+static CONT_LEVEL *startlev = NULL;
+static CONT_LEVEL *currlev;
+static CONT_LINE *currline;
+
+static int cont3d = 0;
+
+static CONT_LINE *
+alloc_line(CONT_LEVEL *node)
+{
+  CONT_LINE *line;
+
+  line = (CONT_LINE *) malloc(sizeof(CONT_LINE));
+  line->x = (PLFLT *) malloc(LINE_ITEMS*sizeof(PLFLT));
+  line->y = (PLFLT *) malloc(LINE_ITEMS*sizeof(PLFLT));
+  line->npts = 0;
+  line->next = NULL;
+ 
+  return line;
+}
+
+static CONT_LEVEL *
+alloc_level(PLFLT level)
+{
+  CONT_LEVEL *node;
+
+  node = (CONT_LEVEL *) malloc(sizeof(CONT_LEVEL));
+  node->level = level;
+  node->next = NULL;
+  node->line = alloc_line(node);
+
+  return node;
+}
+
+static void
+realloc_line(CONT_LINE *line)
+{
+  line->x = (PLFLT *) realloc(line->x, 
+			      (line->npts + LINE_ITEMS)*sizeof(PLFLT));
+  line->y = (PLFLT *) realloc(line->y, 
+			      (line->npts + LINE_ITEMS)*sizeof(PLFLT));
+}
+
+
+/* new contour level */
+static void
+cont_new_store(PLFLT level)
+{
+  if (cont3d) {
+    if (startlev == NULL) {
+      startlev = alloc_level(level);
+      currlev = startlev;
+    } else {
+      currlev->next = alloc_level(level);
+      currlev = currlev->next; 
+    }
+    currline = currlev->line;
+  }
+}
+
+void
+cont_clean_store(CONT_LEVEL *ct)
+{
+  CONT_LINE *tline, *cline;
+  CONT_LEVEL *tlev, *clevel;
+
+  if (ct != NULL) {
+    clevel = ct;
+
+    do {
+      cline = clevel->line;
+      do {
+#ifdef CONT_PLOT_DEBUG /* for 2D plots. For 3D plots look at plot3.c:plotsh3di() */
+	plP_movwor(cline->x[0],cline->y[0]); 
+	for (j=1; j<cline->npts; j++)
+	  plP_drawor(cline->x[j], cline->y[j]); 
+#endif
+	tline = cline->next;
+	free(cline->x);
+	free(cline->y);
+	free(cline);
+	cline = tline;
+      }
+      while(cline != NULL);
+      tlev = clevel->next;
+      free(clevel);
+      clevel = tlev;
+    }
+    while(clevel != NULL);
+    startlev = NULL;
+  }
+}
+
+static void
+cont_xy_store(PLFLT xx, PLFLT yy)
+{
+  if (cont3d) {
+    PLINT pts = currline->npts;
+
+    if (pts % LINE_ITEMS == 0)
+      realloc_line(currline);
+
+    currline->x[pts] = xx;
+    currline->y[pts] = yy;
+    currline->npts++;
+  } else 
+    plP_drawor(xx, yy);   
+}
+
+static void
+cont_mv_store(PLFLT xx, PLFLT yy)
+{
+  if (cont3d) {
+    if (currline->npts != 0) { /* not an empty list, allocate new */
+      currline->next = alloc_line(currlev);
+      currline = currline->next;
+    }
+
+    /* and fill first element */
+    currline->x[0] = xx;
+    currline->y[0] = yy;
+    currline->npts = 1;
+  } else 
+    plP_movwor(xx, yy);   
+}
+
+/* small routine to set offset and spacing of contour labels, see desciption above */
+void c_pl_setcontlabelparam(PLFLT offset, PLFLT size, PLFLT spacing, PLINT active)
+{
+    contlabel_offset = offset;
+    contlabel_size   = size;
+    contlabel_space  = spacing;
+    contlabel_active = active;
+}
+
+/* small routine to set the format of the contour labels, description of limexp and prec see above */
+void c_pl_setcontlabelformat(PLINT lexp, PLINT sigdig)
+{
+    limexp  = lexp;
+    sigprec = sigdig;
+}
+
+static void pl_drawcontlabel(PLFLT tpx, PLFLT tpy, char *flabel, PLFLT *distance, PLINT *lastindex)
+{
+    PLFLT currx_old, curry_old,	delta_x, delta_y;
+
+    delta_x = plP_pcdcx(plsc->currx)-plP_pcdcx(plP_wcpcx(tpx));
+    delta_y = plP_pcdcy(plsc->curry)-plP_pcdcy(plP_wcpcy(tpy));
+
+    currx_old = plsc->currx;
+    curry_old = plsc->curry;
+
+    *distance += sqrt(delta_x*delta_x + delta_y*delta_y);
+
+    plP_drawor(tpx, tpy);
+
+    if ((int )(fabs(*distance/contlabel_space)) > *lastindex) {
+	PLFLT scale, vec_x, vec_y, mx, my, dev_x, dev_y, off_x, off_y;
+
+	vec_x = tpx-plP_pcwcx(currx_old);
+	vec_y = tpy-plP_pcwcy(curry_old);
+
+	mx = (double )plsc->wpxscl/(double )plsc->phyxlen;
+	my = (double )plsc->wpyscl/(double )plsc->phyylen;
+
+	dev_x = -my*vec_y/mx;
+	dev_y = mx*vec_x/my;
+
+	scale = sqrt((mx*mx*dev_x*dev_x + my*my*dev_y*dev_y)/
+		     (contlabel_offset*contlabel_offset));
+
+	off_x = dev_x/scale;
+	off_y = dev_y/scale;
+
+	plptex(tpx+off_x, tpy+off_y, vec_x, vec_y, 0.5, flabel);
+	plP_movwor(tpx, tpy);
+	(*lastindex)++;
+
+    } else
+	plP_movwor(tpx, tpy);
+}
+
+
+/* Format  contour labels. Arguments:
+ * value:  floating point number to be formatted
+ * string: the formatted label, plptex must be called with it to actually
+ * print the label 
+ */
+
+static void plfloatlabel(PLFLT value, char *string)
+{
+    PLINT  setpre, precis;
+    char   form[10], tmpstring[10];
+    PLINT  exponent = 0;
+    PLFLT  mant, tmp;
+
+    PLINT  prec = sigprec;
+
+    plP_gprec(&setpre, &precis);
+
+    if (setpre)
+	prec = precis;
+
+    if (value > 0.0)
+	tmp = log10(value);
+    else if (value < 0.0)
+	tmp = log10(-value);
+    else
+	tmp = 0;
+
+    if (tmp >= 0.0)
+	exponent = (int )tmp;
+    else if (tmp < 0.0) {
+	tmp = -tmp;
+	if (floor(tmp) < tmp)
+            exponent = -(int )(floor(tmp) + 1.0);
+	else
+            exponent = -(int )(floor(tmp));
+    }
+
+    mant = value/pow(10.0, exponent);
+
+    if (mant != 0.0)
+	mant = (int )(mant*pow(10.0, prec-1) + 0.5*mant/fabs(mant))/pow(10.0, prec-1);
+
+    sprintf(form, "%%.%df", prec-1);
+    sprintf(string, form, mant);
+    /* sprintf(tmpstring, "#(229)10#u%d", exponent); */
+    sprintf(tmpstring, "#(229)10#u%d", exponent);
+    strcat(string, tmpstring);
+
+    if (abs(exponent) < limexp || value == 0.0) {
+	value = pow(10.0, exponent) * mant;
+
+	if (exponent >= 0)
+            prec = prec - 1 - exponent;
+	else
+            prec = prec - 1 + abs(exponent);
+
+	if (prec < 0)
+            prec = 0;
+
+	sprintf(form, "%%.%df", (int) prec);
+	sprintf(string, form, value);
+    }
+}
+
+/* physical coords (x) to world coords */
+
+static PLFLT
+plP_pcwcx(PLINT x)
+{
+    return ((x-plsc->wpxoff)/plsc->wpxscl);
+}
+
+/* physical coords (y) to world coords */
+
+static PLFLT
+plP_pcwcy(PLINT y)
+{
+    return ((y-plsc->wpyoff)/plsc->wpyscl);
+}
+
+
+
+/*--------------------------------------------------------------------------*\
+ * plf2eval2()
+ *
+ * Does a lookup from a 2d function array.  Array is of type (PLFLT **),
+ * and is column dominant (normal C ordering).
+\*--------------------------------------------------------------------------*/
+
+PLFLT
+plf2eval2(PLINT ix, PLINT iy, PLPointer plf2eval_data)
+{
+    PLFLT value;
+    PLfGrid2 *grid = (PLfGrid2 *) plf2eval_data;
+
+    value = grid->f[ix][iy];
+
+    return value;
+}
+
+/*--------------------------------------------------------------------------*\
+ * plf2eval()
+ *
+ * Does a lookup from a 2d function array.  Array is of type (PLFLT *), and
+ * is column dominant (normal C ordering).  You MUST fill the ny maximum
+ * array index entry in the PLfGrid struct.
+\*--------------------------------------------------------------------------*/
+
+PLFLT
+plf2eval(PLINT ix, PLINT iy, PLPointer plf2eval_data)
+{
+    PLFLT value;
+    PLfGrid *grid = (PLfGrid *) plf2eval_data;
+
+    value = grid->f[ix * grid->ny + iy];
+
+    return value;
+}
+
+/*--------------------------------------------------------------------------*\
+ * plf2evalr()
+ *
+ * Does a lookup from a 2d function array.  Array is of type (PLFLT *), and
+ * is row dominant (Fortran ordering).  You MUST fill the nx maximum array
+ * index entry in the PLfGrid struct.
+\*--------------------------------------------------------------------------*/
+
+PLFLT
+plf2evalr(PLINT ix, PLINT iy, PLPointer plf2eval_data)
+{
+    PLFLT value;
+    PLfGrid *grid = (PLfGrid *) plf2eval_data;
+
+    value = grid->f[ix + iy * grid->nx];
+
+    return value;
+}
+
+/*--------------------------------------------------------------------------*\
+ * 
+ * cont_store:
+ *
+ * Draw contour lines in memory.
+ * cont_clean_store() must be called after use to release allocated memory.
+ *
+\*--------------------------------------------------------------------------*/
+
+void
+cont_store(PLFLT *x, PLFLT *y, PLFLT **z, PLINT nx, PLINT ny, PLINT kx, PLINT lx,
+	   PLINT ky, PLINT ly, PLFLT *clevel, PLINT nlevel, CONT_LEVEL **contour)
+{
+  PLcGrid grid1;
+
+  cont3d = 1;
+
+  grid1.nx = nx; grid1.ny = ny; grid1.xg = x; grid1.yg = y;
+  plcont(z, nx, ny, 1, nx, 1, ny, clevel, nlevel,
+	 pltr1,  (void *) & grid1 );
+
+  *contour = startlev;
+  cont3d = 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plcont()
+ *
+ * Draws a contour plot from data in f(nx,ny).  Is just a front-end to
+ * plfcont, with a particular choice for f2eval and f2eval_data.
+\*--------------------------------------------------------------------------*/
+
+MZ_DLLEXPORT
+void
+c_plcont(PLFLT **f, PLINT nx, PLINT ny, PLINT kx, PLINT lx,
+	 PLINT ky, PLINT ly, PLFLT *clevel, PLINT nlevel,
+	 void (*pltr) (PLFLT, PLFLT, PLFLT *, PLFLT *, PLPointer),
+	 PLPointer pltr_data)
+{
+    PLfGrid2 grid;
+
+    grid.f = f;
+    plfcont(plf2eval2, (PLPointer) &grid,
+	    nx, ny, kx, lx, ky, ly, clevel, nlevel,
+	    pltr, pltr_data);
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plfcont()
+ *
+ * Draws a contour plot using the function evaluator f2eval and data stored
+ * by way of the f2eval_data pointer.  This allows arbitrary organizations
+ * of 2d array data to be used.
+ *
+ * The subrange of indices used for contouring is kx to lx in the x
+ * direction and from ky to ly in the y direction. The array of contour
+ * levels is clevel(nlevel), and "pltr" is the name of a function which
+ * transforms array indicies into world coordinates.
+ *
+ * Note that the fortran-like minimum and maximum indices (kx, lx, ky, ly)
+ * are translated into more C-like ones.  I've only kept them as they are
+ * for the plcontf() argument list because of backward compatibility.
+\*--------------------------------------------------------------------------*/
+
+void
+plfcont(PLFLT (*f2eval) (PLINT, PLINT, PLPointer),
+	PLPointer f2eval_data,
+	PLINT nx, PLINT ny, PLINT kx, PLINT lx,
+	PLINT ky, PLINT ly, PLFLT *clevel, PLINT nlevel,
+	void (*pltr) (PLFLT, PLFLT, PLFLT *, PLFLT *, PLPointer),
+	PLPointer pltr_data)
+{
+    PLINT i, mx, my, nstor, *heapc;
+
+    mx = lx - kx + 1;
+    my = ly - ky + 1;
+
+    if (kx < 1 || kx >= lx) {
+	plabort("plfcont: indices must satisfy  1 <= kx <= lx <= nx");
+	return;
+    }
+    if (ky < 1 || ky >= ly) {
+	plabort("plfcont: indices must satisfy  1 <= ky <= ly <= ny");
+	return;
+    }
+
+    nstor = mx * my;
+    heapc = (PLINT *) malloc((size_t) (2*mx + 10 * nstor) * sizeof(PLINT));
+    if (heapc == NULL) {
+	plabort("plfcont: out of memory in heap allocation");
+	return;
+    }
+
+    for (i = 0; i < nlevel; i++) {
+	plcntr(f2eval, f2eval_data,
+	       nx, ny, kx-1, lx-1, ky-1, ly-1, clevel[i], &heapc[0],
+	       &heapc[nx], &heapc[nx + nstor], nstor, pltr, pltr_data);
+
+	if (error) {
+	    error = 0;
+	    goto done;
+	}
+    }
+
+  done:
+    free((void *) heapc);
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plcntr()
+ *
+ * The contour for a given level is drawn here.  Note iscan has nx
+ * elements. ixstor and iystor each have nstor elements.
+\*--------------------------------------------------------------------------*/
+
+static void
+plcntr(PLFLT (*f2eval) (PLINT, PLINT, PLPointer),
+       PLPointer f2eval_data,
+       PLINT nx, PLINT ny, PLINT kx, PLINT lx,
+       PLINT ky, PLINT ly, PLFLT flev, PLINT *iscan,
+       PLINT *ixstor, PLINT *iystor, PLINT nstor,
+       void (*pltr) (PLFLT, PLFLT, PLFLT *, PLFLT *, PLPointer),
+       PLPointer pltr_data)
+{
+    PLINT kcol, krow, kstor, kscan, l, ixt, iyt, jstor, next;
+
+    char  flabel[30];
+
+    cont_new_store(flev);
+
+    /* format contour label for plptex and define the font height of the labels */
+    plfloatlabel(flev, flabel);
+    plschr(0.0, contlabel_size);
+
+    /* Initialize memory pointers */
+
+    kstor = 0;
+    kscan = 0;
+
+    for (krow = ky; krow <= ly; krow++) {
+	for (kcol = kx + 1; kcol <= lx; kcol++) {
+
+	/* Follow and draw a contour */
+
+	    pldrawcn(f2eval, f2eval_data,
+		     nx, ny, kx, lx, ky, ly, flev, flabel, kcol, krow,
+		     &kscan, &kstor, iscan, ixstor, iystor, nstor,
+		     pltr, pltr_data);
+
+	    if (error)
+		return;
+	}
+
+    /* Search of row complete */
+    /* Set up memory of next row in iscan and edit ixstor and iystor */
+
+	if (krow < ny-1) {
+	    jstor = 0;
+	    kscan = 0;
+	    next = krow + 1;
+	    for (l = 1; l <= kstor; l++) {
+		ixt = ixstor[l - 1];
+		iyt = iystor[l - 1];
+
+	    /* Memory of next row into iscan */
+
+		if (iyt == next) {
+		    kscan = kscan + 1;
+		    iscan[kscan - 1] = ixt;
+		}
+
+	    /* Retain memory of rows to come, and forget rest */
+
+		else if (iyt > next) {
+		    jstor = jstor + 1;
+		    ixstor[jstor - 1] = ixt;
+		    iystor[jstor - 1] = iyt;
+		}
+	    }
+	    kstor = jstor;
+	}
+    }
+    plschr(0.0, 1.0);
+}
+
+/*--------------------------------------------------------------------------*\
+ * void pldrawcn()
+ *
+ * Follow and draw a contour.
+\*--------------------------------------------------------------------------*/
+
+static void
+pldrawcn(PLFLT (*f2eval) (PLINT, PLINT, PLPointer),
+	 PLPointer f2eval_data,
+	 PLINT nx, PLINT ny, PLINT kx, PLINT lx,
+	 PLINT ky, PLINT ly, PLFLT flev, char *flabel, PLINT kcol, PLINT krow,
+	 PLINT *p_kscan, PLINT *p_kstor, PLINT *iscan,
+	 PLINT *ixstor, PLINT *iystor, PLINT nstor,
+	 void (*pltr) (PLFLT, PLFLT, PLFLT *, PLFLT *, PLPointer),
+	 PLPointer pltr_data)
+{
+    PLINT iwbeg, ixbeg, iybeg, izbeg;
+    PLINT iboun, iw, ix, iy, iz, ifirst, istep, ixgo, iygo;
+    PLINT l, ixg, iyg, ia, ib;
+
+    PLFLT dist, dx, dy, xnew, ynew, fxl, fxr;
+    PLFLT xlas = 0., ylas = 0., tpx, tpy, xt, yt;
+    PLFLT f1, f2, f3, f4, fcheck;
+
+    PLINT lastindex = 0;
+    PLFLT distance = 0.0;
+
+/* Check if a contour has been crossed */
+
+    fxl = f2eval(kcol-1, krow, f2eval_data);
+    fxr = f2eval(kcol, krow, f2eval_data);
+
+    if (fxl < flev && fxr >= flev) {
+	ixbeg = kcol - 1;
+	iwbeg = kcol;
+    }
+    else if (fxr < flev && fxl > flev) {
+	ixbeg = kcol;
+	iwbeg = kcol - 1;
+    }
+    else
+	return;
+
+    iybeg = krow;
+    izbeg = krow;
+
+/* A contour has been crossed. */
+/* Check to see if it is a new one. */
+
+    for (l = 0; l < *p_kscan; l++) {
+	if (ixbeg == iscan[l])
+	    return;
+    }
+
+    for (iboun = 1; iboun >= -1; iboun -= 2) {
+
+    /* Set up starting point and initial search directions */
+
+	ix = ixbeg;
+	iy = iybeg;
+	iw = iwbeg;
+	iz = izbeg;
+	ifirst = 1;
+	istep = 0;
+	ixgo = iw - ix;
+	iygo = iz - iy;
+
+	for (;;) {
+	    plccal(f2eval, f2eval_data,
+		   flev, ix, iy, ixgo, iygo, &dist);
+
+	    dx = dist * ixgo;
+	    dy = dist * iygo;
+	    xnew = ix + dx;
+	    ynew = iy + dy;
+
+	/* Has a step occured in search? */
+
+	    if (istep != 0) {
+		if (ixgo * iygo == 0) {
+
+		/* This was a diagonal step, so interpolate missed point. */
+		/* Rotating 45 degrees to get it */
+
+		    ixg = ixgo;
+		    iyg = iygo;
+		    plr45(&ixg, &iyg, iboun);
+		    ia = iw - ixg;
+		    ib = iz - iyg;
+		    plccal(f2eval, f2eval_data,
+			   flev, ia, ib, ixg, iyg, &dist);
+
+		    (*pltr) (xlas, ylas, &tpx, &tpy, pltr_data);
+
+		    if (contlabel_active)
+		      pl_drawcontlabel(tpx, tpy, flabel, &distance, &lastindex);
+		    else
+		      cont_xy_store(tpx,tpy); /* plP_drawor(tpx, tpy); */
+
+		    dx = dist * ixg;
+		    dy = dist * iyg;
+		    xlas = ia + dx;
+		    ylas = ib + dy;
+		}
+		else {
+		    if (dist > 0.5) {
+			xt = xlas;
+			xlas = xnew;
+			xnew = xt;
+			yt = ylas;
+			ylas = ynew;
+			ynew = yt;
+		    }
+		}
+	    }
+	    if (ifirst != 1) {
+		(*pltr) (xlas, ylas, &tpx, &tpy, pltr_data);
+		if (contlabel_active)
+		  pl_drawcontlabel(tpx, tpy, flabel, &distance, &lastindex);
+		else
+		  cont_xy_store(tpx,tpy); /* plP_drawor(tpx, tpy); */
+	    }
+	    else {
+		(*pltr) (xnew, ynew, &tpx, &tpy, pltr_data);
+		cont_mv_store(tpx,tpy); /* plP_movwor(tpx, tpy); */
+	    }
+	    xlas = xnew;
+	    ylas = ynew;
+
+	/* Check if the contour is closed */
+
+	    if (ifirst != 1 &&
+		ix == ixbeg && iy == iybeg && iw == iwbeg && iz == izbeg) {
+		(*pltr) (xlas, ylas, &tpx, &tpy, pltr_data);
+		if (contlabel_active)
+		  pl_drawcontlabel(tpx, tpy, flabel, &distance, &lastindex);
+		else
+		  cont_xy_store(tpx,tpy); /* plP_drawor(tpx, tpy); */
+		return;
+	    }
+	    ifirst = 0;
+
+	/* Now the rotation */
+
+	    istep = 0;
+	    plr45(&ixgo, &iygo, iboun);
+	    iw = ix + ixgo;
+	    iz = iy + iygo;
+
+	/* Check if out of bounds */
+
+	    if (iw < kx || iw > lx || iz < ky || iz > ly)
+		break;
+
+	/* Has contact been lost with the contour? */
+
+	    if (ixgo * iygo == 0)
+		fcheck = f2eval(iw, iz, f2eval_data);
+	    else {
+		f1 = f2eval(ix, iy, f2eval_data);
+		f2 = f2eval(iw, iz, f2eval_data);
+		f3 = f2eval(ix, iz, f2eval_data);
+		f4 = f2eval(iw, iy, f2eval_data);
+
+		fcheck = MAX(f2, (f1 + f2 + f3 + f4) / 4.);
+	    }
+
+	    if (fcheck < flev) {
+
+	    /* Yes, lost contact => step to new center */
+
+		istep = 1;
+		ix = iw;
+		iy = iz;
+		plr135(&ixgo, &iygo, iboun);
+		iw = ix + ixgo;
+		iz = iy + iygo;
+
+	    /* And do the contour memory */
+
+		if (iy == krow) {
+		    *p_kscan = *p_kscan + 1;
+		    iscan[*p_kscan - 1] = ix;
+		}
+		else if (iy > krow) {
+		    *p_kstor = *p_kstor + 1;
+		    if (*p_kstor > nstor) {
+			plabort("plfcont: heap exhausted");
+			error = 1;
+			return;
+		    }
+		    ixstor[*p_kstor - 1] = ix;
+		    iystor[*p_kstor - 1] = iy;
+		}
+	    }
+	}
+	/* Reach here only if boundary encountered - Draw last bit */
+
+	(*pltr) (xnew, ynew, &tpx, &tpy, pltr_data);
+        /* distance = 0.0; */
+
+	cont_xy_store(tpx,tpy); /* plP_drawor(tpx, tpy); */
+    }
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plccal()
+ *
+ * Function to interpolate the position of a contour which is known to be
+ * next to ix,iy in the direction ixg,iyg. The unscaled distance along
+ * ixg,iyg is returned as dist.
+\*--------------------------------------------------------------------------*/
+
+static void
+plccal(PLFLT (*f2eval) (PLINT, PLINT, PLPointer),
+       PLPointer f2eval_data,
+       PLFLT flev, PLINT ix, PLINT iy,
+       PLINT ixg, PLINT iyg, PLFLT *dist)
+{
+    PLINT ia, ib;
+    PLFLT dbot, dtop, fmid;
+    PLFLT fxy, fab, fay, fxb, flow;
+
+    ia = ix + ixg;
+    ib = iy + iyg;
+    fxy = f2eval(ix, iy, f2eval_data);
+    fab = f2eval(ia, ib, f2eval_data);
+    fxb = f2eval(ix, ib, f2eval_data);
+    fay = f2eval(ia, iy, f2eval_data);
+
+    if (ixg == 0 || iyg == 0) {
+	dtop = flev - fxy;
+	dbot = fab - fxy;
+	*dist = 0.0;
+	if (dbot != 0.0)
+	    *dist = dtop / dbot;
+    }
+    else {
+	fmid = (fxy + fab + fxb + fay) / 4.0;
+	*dist = 0.5;
+
+	if ((fxy - flev) * (fab - flev) <= 0.) {
+
+	    if (fmid >= flev) {
+		dtop = flev - fxy;
+		dbot = fmid - fxy;
+		if (dbot != 0.0)
+		    *dist = 0.5 * dtop / dbot;
+	    }
+	    else {
+		dtop = flev - fab;
+		dbot = fmid - fab;
+		if (dbot != 0.0)
+		    *dist = 1.0 - 0.5 * dtop / dbot;
+	    }
+	}
+	else {
+	    flow = (fxb + fay) / 2.0;
+	    dtop = fab - flev;
+	    dbot = fab + fxy - 2.0 * flow;
+	    if (dbot != 0.0)
+		*dist = 1. - dtop / dbot;
+	}
+    }
+    if (*dist > 1.)
+	*dist = 1.;
+}
+
+/*--------------------------------------------------------------------------*\
+ * Rotators
+\*--------------------------------------------------------------------------*/
+
+static void
+plr45 (PLINT *ix, PLINT *iy, PLINT isens)
+{
+    PLINT ixx, iyy;
+
+    ixx = *ix - isens * (*iy);
+    iyy = *ix * isens + *iy;
+    *ix = ixx / MAX(1, ABS(ixx));
+    *iy = iyy / MAX(1, ABS(iyy));
+}
+
+static void
+plr135 (PLINT *ix, PLINT *iy, PLINT isens)
+{
+    *ix = -*ix;
+    *iy = -*iy;
+    plr45(ix, iy, isens);
+}
+
+/*--------------------------------------------------------------------------*\
+ * pltr0()
+ *
+ * Identity transformation.
+\*--------------------------------------------------------------------------*/
+
+void
+pltr0(PLFLT x, PLFLT y, PLFLT *tx, PLFLT *ty, PLPointer pltr_data)
+{
+    *tx = x;
+    *ty = y;
+}
+
+/*--------------------------------------------------------------------------*\
+ * pltr1()
+ *
+ * Does linear interpolation from singly dimensioned coord arrays.
+ *
+ * Just abort for now if coordinates are out of bounds (don't think it's
+ * possible, but if so we could use linear extrapolation).
+\*--------------------------------------------------------------------------*/
+
+MZ_DLLEXPORT
+void
+pltr1(PLFLT x, PLFLT y, PLFLT *tx, PLFLT *ty, PLPointer pltr_data)
+{
+    PLINT ul, ur, vl, vr;
+    PLFLT du, dv;
+    PLFLT xl, xr, yl, yr;
+
+    PLcGrid *grid = (PLcGrid *) pltr_data;
+    PLFLT *xg = grid->xg;
+    PLFLT *yg = grid->yg;
+    PLINT nx = grid->nx;
+    PLINT ny = grid->ny;
+
+    ul = (PLINT) x;
+    ur = ul + 1;
+    du = x - ul;
+
+    vl = (PLINT) y;
+    vr = vl + 1;
+    dv = y - vl;
+
+    if (x < 0 || x > nx - 1 || y < 0 || y > ny - 1) {
+
+      /* fprintf(stderr, "nx : %d, ny : %d",nx,ny); */
+      plexit("pltr1: Invalid coordinates");
+    }
+
+/* Look up coordinates in row-dominant array.
+ * Have to handle right boundary specially -- if at the edge, we'd better
+ * not reference the out of bounds point.
+ */
+
+    xl = xg[ul];
+    yl = yg[vl];
+
+    if (ur == nx) {
+	*tx = xl;
+    }
+    else {
+	xr = xg[ur];
+	*tx = xl * (1 - du) + xr * du;
+    }
+    if (vr == ny) {
+	*ty = yl;
+    }
+    else {
+	yr = yg[vr];
+	*ty = yl * (1 - dv) + yr * dv;
+    }
+}
+
+/*--------------------------------------------------------------------------*\
+ * pltr2()
+ *
+ * Does linear interpolation from doubly dimensioned coord arrays (column
+ * dominant, as per normal C 2d arrays).
+ *
+ * This routine includes lots of checks for out of bounds.  This would occur
+ * occasionally due to some bugs in the contour plotter (now fixed).  If an
+ * out of bounds coordinate is obtained, the boundary value is provided
+ * along with a warning.  These checks should stay since no harm is done if
+ * if everything works correctly.
+\*--------------------------------------------------------------------------*/
+
+void
+pltr2(PLFLT x, PLFLT y, PLFLT *tx, PLFLT *ty, PLPointer pltr_data)
+{
+    PLINT ul, ur, vl, vr;
+    PLFLT du, dv;
+    PLFLT xll, xlr, xrl, xrr;
+    PLFLT yll, ylr, yrl, yrr;
+    PLFLT xmin, xmax, ymin, ymax;
+
+    PLcGrid2 *grid = (PLcGrid2 *) pltr_data;
+    PLFLT **xg = grid->xg;
+    PLFLT **yg = grid->yg;
+    PLINT nx = grid->nx;
+    PLINT ny = grid->ny;
+
+    ul = (PLINT) x;
+    ur = ul + 1;
+    du = x - ul;
+
+    vl = (PLINT) y;
+    vr = vl + 1;
+    dv = y - vl;
+
+    xmin = 0;
+    xmax = nx - 1;
+    ymin = 0;
+    ymax = ny - 1;
+
+    if (x < xmin || x > xmax || y < ymin || y > ymax) {
+	plwarn("pltr2: Invalid coordinates");
+	if (x < xmin) {
+
+	    if (y < ymin) {
+		*tx = xg[0][0];
+		*ty = yg[0][0];
+	    }
+	    else if (y > ymax) {
+		*tx = xg[0][ny-1];
+		*ty = yg[0][ny-1];
+	    }
+	    else {
+		xll = xg[0][vl];
+		yll = yg[0][vl];
+		xlr = xg[0][vr];
+		ylr = yg[0][vr];
+
+		*tx = xll * (1 - dv) + xlr * (dv);
+		*ty = yll * (1 - dv) + ylr * (dv);
+	    }
+	}
+	else if (x > xmax) {
+
+	    if (y < ymin) {
+		*tx = xg[nx-1][0];
+		*ty = yg[nx-1][0];
+	    }
+	    else if (y > ymax) {
+		*tx = xg[nx-1][ny-1];
+		*ty = yg[nx-1][ny-1];
+	    }
+	    else {
+		xll = xg[nx-1][vl];
+		yll = yg[nx-1][vl];
+		xlr = xg[nx-1][vr];
+		ylr = yg[nx-1][vr];
+
+		*tx = xll * (1 - dv) + xlr * (dv);
+		*ty = yll * (1 - dv) + ylr * (dv);
+	    }
+	}
+	else {
+	    if (y < ymin) {
+		xll = xg[ul][0];
+		xrl = xg[ur][0];
+		yll = yg[ul][0];
+		yrl = yg[ur][0];
+
+		*tx = xll * (1 - du) + xrl * (du);
+		*ty = yll * (1 - du) + yrl * (du);
+	    }
+	    else if (y > ymax) {
+		xlr = xg[ul][ny-1];
+		xrr = xg[ur][ny-1];
+		ylr = yg[ul][ny-1];
+		yrr = yg[ur][ny-1];
+
+		*tx = xlr * (1 - du) + xrr * (du);
+		*ty = ylr * (1 - du) + yrr * (du);
+	    }
+	}
+    }
+
+/* Normal case.
+ * Look up coordinates in row-dominant array.
+ * Have to handle right boundary specially -- if at the edge, we'd
+ * better not reference the out of bounds point.
+ */
+
+    else {
+
+	xll = xg[ul][vl];
+	yll = yg[ul][vl];
+
+    /* ur is out of bounds */
+
+	if (ur == nx && vr < ny) {
+
+	    xlr = xg[ul][vr];
+	    ylr = yg[ul][vr];
+
+	    *tx = xll * (1 - dv) + xlr * (dv);
+	    *ty = yll * (1 - dv) + ylr * (dv);
+	}
+
+    /* vr is out of bounds */
+
+	else if (ur < nx && vr == ny) {
+
+	    xrl = xg[ur][vl];
+	    yrl = yg[ur][vl];
+
+	    *tx = xll * (1 - du) + xrl * (du);
+	    *ty = yll * (1 - du) + yrl * (du);
+	}
+
+    /* both ur and vr are out of bounds */
+
+	else if (ur == nx && vr == ny) {
+
+	    *tx = xll;
+	    *ty = yll;
+	}
+
+    /* everything in bounds */
+
+	else {
+
+	    xrl = xg[ur][vl];
+	    xlr = xg[ul][vr];
+	    xrr = xg[ur][vr];
+
+	    yrl = yg[ur][vl];
+	    ylr = yg[ul][vr];
+	    yrr = yg[ur][vr];
+
+	    *tx = xll * (1 - du) * (1 - dv) + xlr * (1 - du) * (dv) +
+		xrl * (du) * (1 - dv) + xrr * (du) * (dv);
+
+	    *ty = yll * (1 - du) * (1 - dv) + ylr * (1 - du) * (dv) +
+		yrl * (du) * (1 - dv) + yrr * (du) * (dv);
+	}
+    }
+}
+
+/*--------------------------------------------------------------------------*\
+ * pltr2p()
+ *
+ * Just like pltr2() but uses pointer arithmetic to get coordinates from 2d
+ * grid tables.  This form of grid tables is compatible with those from
+ * PLplot 4.0.  The grid data must be pointed to by a PLcGrid structure.
+\*--------------------------------------------------------------------------*/
+
+void
+pltr2p(PLFLT x, PLFLT y, PLFLT *tx, PLFLT *ty, PLPointer pltr_data)
+{
+    PLINT ul, ur, vl, vr;
+    PLFLT du, dv;
+    PLFLT xll, xlr, xrl, xrr;
+    PLFLT yll, ylr, yrl, yrr;
+    PLFLT xmin, xmax, ymin, ymax;
+
+    PLcGrid *grid = (PLcGrid *) pltr_data;
+    PLFLT *xg = grid->xg;
+    PLFLT *yg = grid->yg;
+    PLINT nx = grid->nx;
+    PLINT ny = grid->ny;
+
+    ul = (PLINT) x;
+    ur = ul + 1;
+    du = x - ul;
+
+    vl = (PLINT) y;
+    vr = vl + 1;
+    dv = y - vl;
+
+    xmin = 0;
+    xmax = nx - 1;
+    ymin = 0;
+    ymax = ny - 1;
+
+    if (x < xmin || x > xmax || y < ymin || y > ymax) {
+	plwarn("pltr2p: Invalid coordinates");
+	if (x < xmin) {
+
+	    if (y < ymin) {
+		*tx = *xg;
+		*ty = *yg;
+	    }
+	    else if (y > ymax) {
+		*tx = *(xg + (ny - 1));
+		*ty = *(yg + (ny - 1));
+	    }
+	    else {
+		ul = 0;
+		xll = *(xg + ul * ny + vl);
+		yll = *(yg + ul * ny + vl);
+		xlr = *(xg + ul * ny + vr);
+		ylr = *(yg + ul * ny + vr);
+
+		*tx = xll * (1 - dv) + xlr * (dv);
+		*ty = yll * (1 - dv) + ylr * (dv);
+	    }
+	}
+	else if (x > xmax) {
+
+	    if (y < ymin) {
+		*tx = *(xg + (ny - 1) * nx);
+		*ty = *(yg + (ny - 1) * nx);
+	    }
+	    else if (y > ymax) {
+		*tx = *(xg + (ny - 1) + (nx - 1) * ny);
+		*ty = *(yg + (ny - 1) + (nx - 1) * ny);
+	    }
+	    else {
+		ul = nx - 1;
+		xll = *(xg + ul * ny + vl);
+		yll = *(yg + ul * ny + vl);
+		xlr = *(xg + ul * ny + vr);
+		ylr = *(yg + ul * ny + vr);
+
+		*tx = xll * (1 - dv) + xlr * (dv);
+		*ty = yll * (1 - dv) + ylr * (dv);
+	    }
+	}
+	else {
+	    if (y < ymin) {
+		vl = 0;
+		xll = *(xg + ul * ny + vl);
+		xrl = *(xg + ur * ny + vl);
+		yll = *(yg + ul * ny + vl);
+		yrl = *(yg + ur * ny + vl);
+
+		*tx = xll * (1 - du) + xrl * (du);
+		*ty = yll * (1 - du) + yrl * (du);
+	    }
+	    else if (y > ymax) {
+		vr = ny - 1;
+		xlr = *(xg + ul * ny + vr);
+		xrr = *(xg + ur * ny + vr);
+		ylr = *(yg + ul * ny + vr);
+		yrr = *(yg + ur * ny + vr);
+
+		*tx = xlr * (1 - du) + xrr * (du);
+		*ty = ylr * (1 - du) + yrr * (du);
+	    }
+	}
+    }
+
+/* Normal case.
+ * Look up coordinates in row-dominant array.
+ * Have to handle right boundary specially -- if at the edge, we'd better
+ * not reference the out of bounds point.
+ */
+
+    else {
+
+	xll = *(xg + ul * ny + vl);
+	yll = *(yg + ul * ny + vl);
+
+    /* ur is out of bounds */
+
+	if (ur == nx && vr < ny) {
+
+	    xlr = *(xg + ul * ny + vr);
+	    ylr = *(yg + ul * ny + vr);
+
+	    *tx = xll * (1 - dv) + xlr * (dv);
+	    *ty = yll * (1 - dv) + ylr * (dv);
+	}
+
+    /* vr is out of bounds */
+
+	else if (ur < nx && vr == ny) {
+
+	    xrl = *(xg + ur * ny + vl);
+	    yrl = *(yg + ur * ny + vl);
+
+	    *tx = xll * (1 - du) + xrl * (du);
+	    *ty = yll * (1 - du) + yrl * (du);
+	}
+
+    /* both ur and vr are out of bounds */
+
+	else if (ur == nx && vr == ny) {
+
+	    *tx = xll;
+	    *ty = yll;
+	}
+
+    /* everything in bounds */
+
+	else {
+
+	    xrl = *(xg + ur * ny + vl);
+	    xlr = *(xg + ul * ny + vr);
+	    xrr = *(xg + ur * ny + vr);
+
+	    yrl = *(yg + ur * ny + vl);
+	    ylr = *(yg + ul * ny + vr);
+	    yrr = *(yg + ur * ny + vr);
+
+	    *tx = xll * (1 - du) * (1 - dv) + xlr * (1 - du) * (dv) +
+		xrl * (du) * (1 - dv) + xrr * (du) * (dv);
+
+	    *ty = yll * (1 - du) * (1 - dv) + ylr * (1 - du) * (dv) +
+		yrl * (du) * (1 - dv) + yrr * (du) * (dv);
+	}
+    }
+}
diff --git a/collects/plot/src/all/plcore.c b/collects/plot/src/all/plcore.c
new file mode 100644
index 0000000000..e3f2362af4
--- /dev/null
+++ b/collects/plot/src/all/plcore.c
@@ -0,0 +1,2829 @@
+/* $Id: plcore.c,v 1.2 2005/03/17 21:39:21 eli Exp $
+
+	Central dispatch facility for PLplot.
+	Also contains the PLplot main data structures, external access
+	routines, and initialization calls.
+
+	This stuff used to be in "dispatch.h", "dispatch.c", and "base.c".
+*/
+
+#define DEBUG
+
+#define NEED_PLDEBUG
+#include "plcore.h"
+
+#ifdef ENABLE_DYNDRIVERS
+#include <ltdl.h>
+#endif
+
+/*--------------------------------------------------------------------------*\
+ * Driver Interface
+ *
+ * These routines are the low-level interface to the driver -- all calls to
+ * driver functions must pass through here.  For implementing driver-
+ * specific functions, the escape function is provided.  The command stream
+ * gets duplicated to the plot buffer here.
+ *
+ * All functions that result in graphics actually being plotted (rather than
+ * just a change of state) are filtered as necessary before being passed on.
+ * The default settings do not require any filtering, i.e.  PLplot physical
+ * coordinates are the same as the device physical coordinates (currently
+ * this can't be changed anyway), and a global view equal to the entire page
+ * is used.
+ *
+ * The reason one wants to put view-specific filtering here is that if
+ * enabled, the plot buffer should receive the unfiltered data stream.  This
+ * allows a specific view to be used from an interactive device (e.g. TCL/TK
+ * driver) but be restored to the full view at any time merely by
+ * reprocessing the contents of the plot buffer.
+ *
+ * The metafile, on the other hand, *should* be affected by changes in the
+ * view, since this is a crucial editing capability.  It is recommended that
+ * the initial metafile be created without a restricted global view, and
+ * modification of the view done on a per-plot basis as desired during
+ * subsequent processing.
+ *
+\*--------------------------------------------------------------------------*/
+
+enum {AT_BOP, DRAWING, AT_EOP};
+
+/* Initialize device. */
+/* The plot buffer must be called last */
+
+void
+plP_init(void)
+{
+    plsc->page_status = AT_EOP;
+
+    (*plsc->dispatch_table->pl_init) ((struct PLStream_struct *) plsc);
+
+    if (plsc->plbuf_write)
+	plbuf_init(plsc);
+}
+
+/* End of page */
+/* The plot buffer must be called first */
+/* Ignore instruction if there's nothing drawn */
+
+void
+plP_eop(void)
+{
+    int skip_driver_eop = 0;
+
+    if (plsc->page_status != DRAWING)
+	return;
+
+    plsc->page_status = AT_EOP;
+
+    if (plsc->plbuf_write)
+	plbuf_eop(plsc);
+
+/* Call user eop handler if present. */
+
+    if (plsc->eop_handler != NULL)
+	(*plsc->eop_handler) (plsc->eop_data, &skip_driver_eop);
+
+    if (!skip_driver_eop)
+	(*plsc->dispatch_table->pl_eop) ((struct PLStream_struct *) plsc);
+}
+
+/* Set up new page. */
+/* The plot buffer must be called last */
+/* Ignore if the bop was already issued. */
+/* It's not actually necessary to be AT_EOP here, so don't check for it. */
+
+void
+plP_bop(void)
+{
+    int skip_driver_bop = 0;
+
+    plP_subpInit();
+    if (plsc->page_status == AT_BOP)
+	return;
+
+    plsc->page_status = AT_BOP;
+    plsc->nplwin = 0;
+
+/* Call user bop handler if present. */
+
+    if (plsc->bop_handler != NULL)
+	(*plsc->bop_handler) (plsc->bop_data, &skip_driver_bop);
+
+    if (!skip_driver_bop)
+	(*plsc->dispatch_table->pl_bop) ((struct PLStream_struct *) plsc);
+
+    if (plsc->plbuf_write)
+	plbuf_bop(plsc);
+}
+
+/* Tidy up device (flush buffers, close file, etc). */
+
+void
+plP_tidy(void)
+{
+    if (plsc->tidy) {
+	(*plsc->tidy) (plsc->tidy_data);
+	plsc->tidy = NULL;
+	plsc->tidy_data = NULL;
+    }
+
+    (*plsc->dispatch_table->pl_tidy) ((struct PLStream_struct *) plsc);
+
+    if (plsc->plbuf_write)
+	plbuf_tidy(plsc);
+
+    plsc->OutFile = NULL;
+    free_mem(plsc->FileName);
+}
+
+/* Change state. */
+
+void
+plP_state(PLINT op)
+{
+    (*plsc->dispatch_table->pl_state) ((struct PLStream_struct *) plsc, op);
+
+    if (plsc->plbuf_write)
+	plbuf_state(plsc, op);
+}
+
+/* Escape function, for driver-specific commands. */
+
+void
+plP_esc(PLINT op, void *ptr)
+{
+    (*plsc->dispatch_table->pl_esc) ((struct PLStream_struct *) plsc, op, ptr);
+
+    if (plsc->plbuf_write)
+	plbuf_esc(plsc, op, ptr);
+}
+
+/* Set up plot window parameters. */
+/* The plot buffer must be called first */
+/* Some drivers (metafile, Tk) need access to this data */
+
+void
+plP_swin(PLWindow *plwin)
+{
+    PLWindow *w;
+    PLINT clpxmi, clpxma, clpymi, clpyma;
+
+/* Provide plot buffer with unfiltered window data */
+
+    if (plsc->plbuf_write)
+	plbuf_esc(plsc, PLESC_SWIN, (void *) plwin);
+
+    w = &plsc->plwin[plsc->nplwin++ % PL_MAXWINDOWS];
+
+    w->dxmi = plwin->dxmi;
+    w->dxma = plwin->dxma;
+    w->dymi = plwin->dymi;
+    w->dyma = plwin->dyma;
+
+    if (plsc->difilt) {
+	xscl[0] = plP_dcpcx(w->dxmi);
+	xscl[1] = plP_dcpcx(w->dxma);
+	yscl[0] = plP_dcpcy(w->dymi);
+	yscl[1] = plP_dcpcy(w->dyma);
+
+	difilt(xscl, yscl, 2, &clpxmi, &clpxma, &clpymi, &clpyma);
+
+	w->dxmi = plP_pcdcx(xscl[0]);
+	w->dxma = plP_pcdcx(xscl[1]);
+	w->dymi = plP_pcdcy(yscl[0]);
+	w->dyma = plP_pcdcy(yscl[1]);
+    }
+
+    w->wxmi = plwin->wxmi;
+    w->wxma = plwin->wxma;
+    w->wymi = plwin->wymi;
+    w->wyma = plwin->wyma;
+
+/* If the driver wants to process swin commands, call it now */
+/* It must use the filtered data, which it can get from *plsc */
+
+    if (plsc->dev_swin) {
+	(*plsc->dispatch_table->pl_esc) ( (struct PLStream_struct *) plsc,
+                                          PLESC_SWIN, NULL );
+    }
+}
+
+/*--------------------------------------------------------------------------*\
+ *  Drawing commands.
+\*--------------------------------------------------------------------------*/
+
+/* Draw line between two points */
+/* The plot buffer must be called first so it gets the unfiltered data */
+
+void
+plP_line(short *x, short *y)
+{
+    PLINT i, npts = 2, clpxmi, clpxma, clpymi, clpyma;
+
+    plsc->page_status = DRAWING;
+
+    if (plsc->plbuf_write)
+	plbuf_line(plsc, x[0], y[0], x[1], y[1]);
+
+    if (plsc->difilt) {
+	for (i = 0; i < npts; i++) {
+	    xscl[i] = x[i];
+	    yscl[i] = y[i];
+	}
+	difilt(xscl, yscl, npts, &clpxmi, &clpxma, &clpymi, &clpyma);
+	plP_pllclp(xscl, yscl, npts, clpxmi, clpxma, clpymi, clpyma, grline);
+    }
+    else {
+	grline(x, y, npts);
+    }
+}
+
+/* Draw polyline */
+/* The plot buffer must be called first */
+
+void
+plP_polyline(short *x, short *y, PLINT npts)
+{
+    PLINT i, clpxmi, clpxma, clpymi, clpyma;
+
+    plsc->page_status = DRAWING;
+
+    if (plsc->plbuf_write)
+	plbuf_polyline(plsc, x, y, npts);
+
+    if (plsc->difilt) {
+	for (i = 0; i < npts; i++) {
+	    xscl[i] = x[i];
+	    yscl[i] = y[i];
+	}
+	difilt(xscl, yscl, npts, &clpxmi, &clpxma, &clpymi, &clpyma);
+	plP_pllclp(xscl, yscl, npts, clpxmi, clpxma, clpymi, clpyma,
+		   grpolyline);
+    }
+    else {
+	grpolyline(x, y, npts);
+    }
+}
+
+/* Fill polygon */
+/* The plot buffer must be called first */
+/* Here if the desired area fill capability isn't present, we mock up */
+/* something in software */
+
+static int foo;
+
+void
+plP_fill(short *x, short *y, PLINT npts)
+{
+    PLINT i, clpxmi, clpxma, clpymi, clpyma;
+
+    plsc->page_status = DRAWING;
+
+    if (plsc->plbuf_write) {
+	plsc->dev_npts = npts;
+	plsc->dev_x = x;
+	plsc->dev_y = y;
+	plbuf_esc(plsc, PLESC_FILL, NULL);
+    }
+
+/* Account for driver ability to do fills */
+
+    if (plsc->patt == 0 && ! plsc->dev_fill0) {
+	if ( ! foo) {
+	    plwarn("Driver does not support hardware solid fills, switching to software fill.\n");
+	    foo = 1;
+	}
+	plsc->patt = 8;
+	plpsty(plsc->patt);
+    }
+    if (plsc->dev_fill1) {
+	plsc->patt = -ABS(plsc->patt);
+    }
+
+/* Perform fill.  Here we MUST NOT allow the software fill to pass through the
+   driver interface filtering twice, else we get the infamous 2*rotation for
+   software fills on orientation swaps. 
+*/
+
+    if (plsc->patt > 0)
+	plfill_soft(x, y, npts);
+
+    else {
+	if (plsc->difilt) {
+	    for (i = 0; i < npts; i++) {
+		xscl[i] = x[i];
+		yscl[i] = y[i];
+	    }
+	    difilt(xscl, yscl, npts, &clpxmi, &clpxma, &clpymi, &clpyma);
+	    plP_plfclp(xscl, yscl, npts, clpxmi, clpxma, clpymi, clpyma,
+		       grfill);
+	}
+	else {
+	    grfill(x, y, npts);
+	}
+    }
+}
+
+/* Account for driver ability to draw text itself */
+/*
+#define DEBUG_TEXT
+*/
+
+void
+plP_text(PLINT base, PLFLT just, PLFLT *xform, PLINT x, PLINT y,
+	 PLINT refx, PLINT refy, const char *string)
+{
+    if (plsc->dev_text) {
+	EscText args;
+
+	args.base = base;
+	args.just = just;
+	args.xform = xform;
+	args.x = x;
+	args.y = y;
+	args.refx = refx;
+	args.refy = refy;
+	args.string = string;
+
+	if (plsc->plbuf_write)
+	    plbuf_esc(plsc, PLESC_HAS_TEXT, &args);
+
+	plP_esc(PLESC_HAS_TEXT, &args);
+#ifndef DEBUG_TEXT
+    } else {
+#endif
+	plstr(base, xform, refx, refy, string);
+    }
+}
+
+static void
+grline(short *x, short *y, PLINT npts)
+{
+    (*plsc->dispatch_table->pl_line) ( (struct PLStream_struct *) plsc,
+                                       x[0], y[0], x[1], y[1] );
+}
+
+static void
+grpolyline(short *x, short *y, PLINT npts)
+{
+    (*plsc->dispatch_table->pl_polyline) ( (struct PLStream_struct *) plsc,
+                                           x, y, npts );
+}
+
+static void
+grfill(short *x, short *y, PLINT npts)
+{
+    plsc->dev_npts = npts;
+    plsc->dev_x = x;
+    plsc->dev_y = y;
+
+    (*plsc->dispatch_table->pl_esc) ( (struct PLStream_struct *) plsc,
+                                      PLESC_FILL, NULL );
+}
+
+/*--------------------------------------------------------------------------*\
+ * void difilt
+ *
+ * Driver interface filter -- passes all coordinates through a variety
+ * of filters.  These include filters to change :
+ *
+ *	- mapping of meta to physical coordinates
+ *	- plot orientation
+ *	- window into plot (zooms)
+ *	- window into device (i.e set margins)
+ *
+ * The filters are applied in the order specified above.  Because the
+ * orientation change comes first, subsequent window specifications affect
+ * the new coordinates (i.e. after a 90 degree flip, what was x is now y).
+ * This is the only way that makes sense from a graphical interface
+ * (e.g. TCL/TK driver).
+ *
+ * Where appropriate, the page clip limits are modified.
+\*--------------------------------------------------------------------------*/
+
+void
+difilt(PLINT *xscl, PLINT *yscl, PLINT npts,
+       PLINT *clpxmi, PLINT *clpxma, PLINT *clpymi, PLINT *clpyma)
+{
+    PLINT i, x, y;
+
+/* Map meta coordinates to physical coordinates */
+
+    if (plsc->difilt & PLDI_MAP) {
+	for (i = 0; i < npts; i++) {
+	    xscl[i] = plsc->dimxax * xscl[i] + plsc->dimxb;
+	    yscl[i] = plsc->dimyay * yscl[i] + plsc->dimyb;
+	}
+    }
+
+/* Change orientation */
+
+    if (plsc->difilt & PLDI_ORI) {
+	for (i = 0; i < npts; i++) {
+	    x = plsc->dioxax * xscl[i] + plsc->dioxay * yscl[i] + plsc->dioxb;
+	    y = plsc->dioyax * xscl[i] + plsc->dioyay * yscl[i] + plsc->dioyb;
+	    xscl[i] = x;
+	    yscl[i] = y;
+	}
+    }
+
+/* Change window into plot space */
+
+    if (plsc->difilt & PLDI_PLT) {
+	for (i = 0; i < npts; i++) {
+	    xscl[i] = plsc->dipxax * xscl[i] + plsc->dipxb;
+	    yscl[i] = plsc->dipyay * yscl[i] + plsc->dipyb;
+	}
+    }
+
+/* Change window into device space and set clip limits */
+/* (this is the only filter that modifies them) */
+
+    if (plsc->difilt & PLDI_DEV) {
+	for (i = 0; i < npts; i++) {
+	    xscl[i] = plsc->didxax * xscl[i] + plsc->didxb;
+	    yscl[i] = plsc->didyay * yscl[i] + plsc->didyb;
+	}
+	*clpxmi = plsc->diclpxmi;
+	*clpxma = plsc->diclpxma;
+	*clpymi = plsc->diclpymi;
+	*clpyma = plsc->diclpyma;
+    }
+    else {
+      *clpxmi = plsc->phyxmi;
+      *clpxma = plsc->phyxma;
+      *clpymi = plsc->phyymi;
+      *clpyma = plsc->phyyma;
+    }
+}
+
+void
+sdifilt(short *xscl, short *yscl, PLINT npts,
+       PLINT *clpxmi, PLINT *clpxma, PLINT *clpymi, PLINT *clpyma)
+{
+  int i;
+  short x, y;
+
+/* Map meta coordinates to physical coordinates */
+
+    if (plsc->difilt & PLDI_MAP) {
+    for (i = 0; i < npts; i++) {
+        xscl[i] = plsc->dimxax * xscl[i] + plsc->dimxb;
+        yscl[i] = plsc->dimyay * yscl[i] + plsc->dimyb;
+    }
+    }
+
+/* Change orientation */
+
+    if (plsc->difilt & PLDI_ORI) {
+    for (i = 0; i < npts; i++) {
+        x = plsc->dioxax * xscl[i] + plsc->dioxay * yscl[i] + plsc->dioxb;
+        y = plsc->dioyax * xscl[i] + plsc->dioyay * yscl[i] + plsc->dioyb;
+        xscl[i] = x;
+        yscl[i] = y;
+    }
+    }
+
+/* Change window into plot space */
+
+    if (plsc->difilt & PLDI_PLT) {
+    for (i = 0; i < npts; i++) {
+        xscl[i] = plsc->dipxax * xscl[i] + plsc->dipxb;
+        yscl[i] = plsc->dipyay * yscl[i] + plsc->dipyb;
+    }
+    }
+
+/* Change window into device space and set clip limits */
+/* (this is the only filter that modifies them) */
+
+    if (plsc->difilt & PLDI_DEV) {
+    for (i = 0; i < npts; i++) {
+        xscl[i] = plsc->didxax * xscl[i] + plsc->didxb;
+        yscl[i] = plsc->didyay * yscl[i] + plsc->didyb;
+    }
+    *clpxmi = plsc->diclpxmi;
+    *clpxma = plsc->diclpxma;
+    *clpymi = plsc->diclpymi;
+    *clpyma = plsc->diclpyma;
+    }
+    else {
+    *clpxmi = plsc->phyxmi;
+    *clpxma = plsc->phyxma;
+    *clpymi = plsc->phyymi;
+    *clpyma = plsc->phyyma;
+    }
+}
+
+/*--------------------------------------------------------------------------*\
+ * void pldi_ini
+ *
+ * Updates driver interface, making sure everything is in order.
+ * Even if filter is not being used, the defaults need to be set up.
+\*--------------------------------------------------------------------------*/
+
+static void
+setdef_diplt()
+{
+    plsc->dipxmin = 0.0;
+    plsc->dipxmax = 1.0;
+    plsc->dipymin = 0.0;
+    plsc->dipymax = 1.0;
+}
+
+static void
+setdef_didev()
+{
+    plsc->mar = 0.0;
+    plsc->aspect = 0.0;
+    plsc->jx = 0.0;
+    plsc->jy = 0.0;
+}
+
+static void
+setdef_diori()
+{
+    plsc->diorot = 0.;
+}
+
+static void
+pldi_ini(void)
+{
+    if (plsc->level >= 1) {
+	if (plsc->difilt & PLDI_MAP)	/* Coordinate mapping */
+	    calc_dimap();
+
+	if (plsc->difilt & PLDI_ORI)	/* Orientation */
+	    calc_diori();
+	else
+	    setdef_diori();
+
+	if (plsc->difilt & PLDI_PLT) 	/* Plot window */
+	    calc_diplt();
+	else
+	    setdef_diplt();
+
+	if (plsc->difilt & PLDI_DEV)	/* Device window */
+	    calc_didev();
+	else
+	    setdef_didev();
+    }
+}
+
+/*--------------------------------------------------------------------------*\
+ * void pldid2pc
+ *
+ * Converts input values from relative device coordinates to relative plot
+ * coordinates.  This function must be called when selecting a plot window
+ * from a display driver, since the coordinates chosen by the user are
+ * necessarily device-specific.
+\*--------------------------------------------------------------------------*/
+
+void
+pldid2pc(PLFLT *xmin, PLFLT *ymin, PLFLT *xmax, PLFLT *ymax)
+{
+    PLFLT pxmin, pymin, pxmax, pymax;
+    PLFLT sxmin, symin, sxmax, symax;
+    PLFLT rxmin, rymin, rxmax, rymax;
+
+    if (plsc->difilt & PLDI_DEV) {
+
+	pldebug("pldid2pc",
+		"Relative device coordinates (in): %f, %f, %f, %f\n",
+		*xmin, *ymin, *xmax, *ymax);
+
+	pxmin = plP_dcpcx(*xmin);
+	pymin = plP_dcpcy(*ymin);
+	pxmax = plP_dcpcx(*xmax);
+	pymax = plP_dcpcy(*ymax);
+
+	sxmin = (pxmin - plsc->didxb) / plsc->didxax;
+	symin = (pymin - plsc->didyb) / plsc->didyay;
+	sxmax = (pxmax - plsc->didxb) / plsc->didxax;
+	symax = (pymax - plsc->didyb) / plsc->didyay;
+
+	rxmin = plP_pcdcx(sxmin);
+	rymin = plP_pcdcy(symin);
+	rxmax = plP_pcdcx(sxmax);
+	rymax = plP_pcdcy(symax);
+
+	*xmin = (rxmin < 0) ? 0 : rxmin;
+	*xmax = (rxmax > 1) ? 1 : rxmax;
+	*ymin = (rymin < 0) ? 0 : rymin;
+	*ymax = (rymax > 1) ? 1 : rymax;
+
+	pldebug("pldid2pc",
+		"Relative plot coordinates (out): %f, %f, %f, %f\n",
+		rxmin, rymin, rxmax, rymax);
+    }
+}
+
+/*--------------------------------------------------------------------------*\
+ * void pldip2dc
+ *
+ * Converts input values from relative plot coordinates to relative
+ * device coordinates.
+\*--------------------------------------------------------------------------*/
+
+void
+pldip2dc(PLFLT *xmin, PLFLT *ymin, PLFLT *xmax, PLFLT *ymax)
+{
+    PLFLT pxmin, pymin, pxmax, pymax;
+    PLFLT sxmin, symin, sxmax, symax;
+    PLFLT rxmin, rymin, rxmax, rymax;
+
+    if (plsc->difilt & PLDI_DEV) {
+
+	pldebug("pldip2pc",
+		"Relative plot coordinates (in): %f, %f, %f, %f\n",
+		*xmin, *ymin, *xmax, *ymax);
+
+	pxmin = plP_dcpcx(*xmin);
+	pymin = plP_dcpcy(*ymin);
+	pxmax = plP_dcpcx(*xmax);
+	pymax = plP_dcpcy(*ymax);
+
+	sxmin = pxmin * plsc->didxax + plsc->didxb;
+	symin = pymin * plsc->didyay + plsc->didyb;
+	sxmax = pxmax * plsc->didxax + plsc->didxb;
+	symax = pymax * plsc->didyay + plsc->didyb;
+
+	rxmin = plP_pcdcx(sxmin);
+	rymin = plP_pcdcy(symin);
+	rxmax = plP_pcdcx(sxmax);
+	rymax = plP_pcdcy(symax);
+
+	*xmin = (rxmin < 0) ? 0 : rxmin;
+	*xmax = (rxmax > 1) ? 1 : rxmax;
+	*ymin = (rymin < 0) ? 0 : rymin;
+	*ymax = (rymax > 1) ? 1 : rymax;
+
+	pldebug("pldip2pc",
+		"Relative device coordinates (out): %f, %f, %f, %f\n",
+		rxmin, rymin, rxmax, rymax);
+    }
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plsdiplt
+ *
+ * Set window into plot space
+\*--------------------------------------------------------------------------*/
+
+void
+c_plsdiplt(PLFLT xmin, PLFLT ymin, PLFLT xmax, PLFLT ymax)
+{
+    plsc->dipxmin = (xmin < xmax) ? xmin : xmax;
+    plsc->dipxmax = (xmin < xmax) ? xmax : xmin;
+    plsc->dipymin = (ymin < ymax) ? ymin : ymax;
+    plsc->dipymax = (ymin < ymax) ? ymax : ymin;
+
+    if (xmin == 0. && xmax == 1. && ymin == 0. && ymax == 1.)  {
+	plsc->difilt &= ~PLDI_PLT;
+	return;
+    }
+
+    plsc->difilt |= PLDI_PLT;
+    pldi_ini();
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plsdiplz
+ *
+ * Set window into plot space incrementally (zoom)
+\*--------------------------------------------------------------------------*/
+
+void
+c_plsdiplz(PLFLT xmin, PLFLT ymin, PLFLT xmax, PLFLT ymax)
+{
+    if (plsc->difilt & PLDI_PLT) {
+	xmin = plsc->dipxmin + (plsc->dipxmax - plsc->dipxmin) * xmin;
+	ymin = plsc->dipymin + (plsc->dipymax - plsc->dipymin) * ymin;
+	xmax = plsc->dipxmin + (plsc->dipxmax - plsc->dipxmin) * xmax;
+	ymax = plsc->dipymin + (plsc->dipymax - plsc->dipymin) * ymax;
+    }
+
+    plsdiplt(xmin, ymin, xmax, ymax);
+}
+
+/*--------------------------------------------------------------------------*\
+ * void calc_diplt
+ *
+ * Calculate transformation coefficients to set window into plot space.
+ *
+ * Note: if driver has requested to handle these commands itself, we must
+ * send the appropriate escape command.  If the driver succeeds it will
+ * cancel the filter operation.  The command is deferred until this point
+ * to ensure that the driver has been initialized.
+\*--------------------------------------------------------------------------*/
+
+static void
+calc_diplt(void)
+{
+    PLINT pxmin, pxmax, pymin, pymax, pxlen, pylen;
+
+    if (plsc->dev_di) {
+	(*plsc->dispatch_table->pl_esc) ( (struct PLStream_struct *) plsc,
+                                          PLESC_DI, NULL );
+    }
+
+    if ( ! (plsc->difilt & PLDI_PLT))
+	return;
+
+    pxmin = plP_dcpcx(plsc->dipxmin);
+    pxmax = plP_dcpcx(plsc->dipxmax);
+    pymin = plP_dcpcy(plsc->dipymin);
+    pymax = plP_dcpcy(plsc->dipymax);
+
+    pxlen = pxmax - pxmin;
+    pylen = pymax - pymin;
+    pxlen = MAX(1, pxlen);
+    pylen = MAX(1, pylen);
+
+    plsc->dipxax = plsc->phyxlen / (double) pxlen;
+    plsc->dipyay = plsc->phyylen / (double) pylen;
+    plsc->dipxb = plsc->phyxmi - plsc->dipxax * pxmin;
+    plsc->dipyb = plsc->phyymi - plsc->dipyay * pymin;
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plgdiplt
+ *
+ * Retrieve current window into plot space
+\*--------------------------------------------------------------------------*/
+
+void
+c_plgdiplt(PLFLT *p_xmin, PLFLT *p_ymin, PLFLT *p_xmax, PLFLT *p_ymax)
+{
+    *p_xmin = plsc->dipxmin;
+    *p_xmax = plsc->dipxmax;
+    *p_ymin = plsc->dipymin;
+    *p_ymax = plsc->dipymax;
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plsdidev
+ *
+ * Set window into device space using margin, aspect ratio, and
+ * justification.  If you want to just use the previous value for any of
+ * these, just pass in the magic value PL_NOTSET.
+ *
+ * It is unlikely that one should ever need to change the aspect ratio
+ * but it's in there for completeness.
+\*--------------------------------------------------------------------------*/
+
+void
+c_plsdidev(PLFLT mar, PLFLT aspect, PLFLT jx, PLFLT jy)
+{
+    plsetvar(plsc->mar, mar);
+    plsetvar(plsc->aspect, aspect);
+    plsetvar(plsc->jx, jx);
+    plsetvar(plsc->jy, jy);
+
+    if (mar == 0. && aspect == 0. && jx == 0. && jy == 0. && 
+	! (plsc->difilt & PLDI_ORI)) {
+	plsc->difilt &= ~PLDI_DEV;
+	return;
+    }
+
+    plsc->difilt |= PLDI_DEV;
+    pldi_ini();
+}
+
+/*--------------------------------------------------------------------------*\
+ * void calc_didev
+ *
+ * Calculate transformation coefficients to set window into device space.
+ * Calculates relative window bounds and calls plsdidxy to finish the job.
+\*--------------------------------------------------------------------------*/
+
+static void
+calc_didev(void)
+{
+    PLFLT lx, ly, aspect, aspdev;
+    PLFLT xmin, xmax, xlen, ymin, ymax, ylen;
+    PLINT pxmin, pxmax, pymin, pymax, pxlen, pylen;
+
+    if (plsc->dev_di) {
+	(*plsc->dispatch_table->pl_esc) ( (struct PLStream_struct *) plsc,
+                                          PLESC_DI, NULL );
+    }
+
+    if ( ! (plsc->difilt & PLDI_DEV))
+	return;
+
+/* Calculate aspect ratio of physical device */
+
+    lx = plsc->phyxlen / plsc->xpmm;
+    ly = plsc->phyylen / plsc->ypmm;
+    aspdev = lx / ly;
+
+    if (plsc->difilt & PLDI_ORI)
+	aspect = plsc->aspori;
+    else
+	aspect = plsc->aspect;
+
+    if (aspect <= 0.)
+	aspect = plsc->aspdev;
+
+/* Failsafe */
+
+    plsc->mar = (plsc->mar > 0.5) ? 0.5 : plsc->mar;
+    plsc->mar = (plsc->mar < 0.0) ? 0.0 : plsc->mar;
+    plsc->jx = (plsc->jx >  0.5) ?  0.5 : plsc->jx;
+    plsc->jx = (plsc->jx < -0.5) ? -0.5 : plsc->jx;
+    plsc->jy = (plsc->jy >  0.5) ?  0.5 : plsc->jy;
+    plsc->jy = (plsc->jy < -0.5) ? -0.5 : plsc->jy;
+
+/* Relative device coordinates that neutralize aspect ratio difference */
+
+    xlen = (aspect < aspdev) ? (aspect / aspdev) : 1.0;
+    ylen = (aspect < aspdev) ? 1.0 : (aspdev / aspect);
+
+    xlen *= (1.0 - 2.*plsc->mar);
+    ylen *= (1.0 - 2.*plsc->mar);
+
+    xmin = (1. - xlen) * (0.5 + plsc->jx);
+    xmax = xmin + xlen;
+
+    ymin = (1. - ylen) * (0.5 + plsc->jy);
+    ymax = ymin + ylen;
+
+/* Calculate transformation coefficients */
+
+    pxmin = plP_dcpcx(xmin);
+    pxmax = plP_dcpcx(xmax);
+    pymin = plP_dcpcy(ymin);
+    pymax = plP_dcpcy(ymax);
+
+    pxlen = pxmax - pxmin;
+    pylen = pymax - pymin;
+    pxlen = MAX(1, pxlen);
+    pylen = MAX(1, pylen);
+
+    plsc->didxax = pxlen / (double) plsc->phyxlen;
+    plsc->didyay = pylen / (double) plsc->phyylen;
+    plsc->didxb = pxmin - plsc->didxax * plsc->phyxmi;
+    plsc->didyb = pymin - plsc->didyay * plsc->phyymi;
+
+/* Set clip limits to conform to new page size */
+
+    plsc->diclpxmi = plsc->didxax * plsc->phyxmi + plsc->didxb;
+    plsc->diclpxma = plsc->didxax * plsc->phyxma + plsc->didxb;
+    plsc->diclpymi = plsc->didyay * plsc->phyymi + plsc->didyb;
+    plsc->diclpyma = plsc->didyay * plsc->phyyma + plsc->didyb;
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plgdidev
+ *
+ * Retrieve current window into device space
+\*--------------------------------------------------------------------------*/
+
+void
+c_plgdidev(PLFLT *p_mar, PLFLT *p_aspect, PLFLT *p_jx, PLFLT *p_jy)
+{
+    *p_mar = plsc->mar;
+    *p_aspect = plsc->aspect;
+    *p_jx = plsc->jx;
+    *p_jy = plsc->jy;
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plsdiori
+ *
+ * Set plot orientation, specifying rotation in units of pi/2.
+\*--------------------------------------------------------------------------*/
+
+void
+c_plsdiori(PLFLT rot)
+{
+    plsc->diorot = rot;
+    if (rot == 0.) {
+	plsc->difilt &= ~PLDI_ORI;
+	pldi_ini();
+	return;
+    }
+
+    plsc->difilt |= PLDI_ORI;
+    pldi_ini();
+}
+
+/*--------------------------------------------------------------------------*\
+ * void calc_diori
+ *
+ * Calculate transformation coefficients to arbitrarily orient plot.
+ * Preserve aspect ratios so the output doesn't suck.
+\*--------------------------------------------------------------------------*/
+
+static void
+calc_diori(void)
+{
+    PLFLT r11, r21, r12, r22, cost, sint;
+    PLFLT x0, y0, lx, ly, aspect;
+
+    if (plsc->dev_di) {
+	(*plsc->dispatch_table->pl_esc) ( (struct PLStream_struct *) plsc,
+                                          PLESC_DI, NULL );
+    }
+
+    if ( ! (plsc->difilt & PLDI_ORI))
+	return;
+
+/* Center point of rotation */
+
+    x0 = (plsc->phyxma + plsc->phyxmi) / 2.;
+    y0 = (plsc->phyyma + plsc->phyymi) / 2.;
+
+/* Rotation matrix */
+
+    r11 = cos(plsc->diorot * PI / 2.);
+    r21 = sin(plsc->diorot * PI / 2.);
+    r12 = -r21;
+    r22 = r11;
+
+    cost = ABS(r11);
+    sint = ABS(r21);
+
+/* Flip aspect ratio as necessary.  Grungy but I don't see a better way */
+
+    aspect = plsc->aspect;
+    if (aspect == 0.)
+	aspect = plsc->aspdev;
+
+    if (plsc->freeaspect)
+	plsc->aspori = aspect;
+    else
+	plsc->aspori = (aspect * cost + sint) / (aspect * sint + cost);
+
+    if ( ! (plsc->difilt & PLDI_DEV)) {
+	plsc->difilt |= PLDI_DEV;
+	setdef_didev();
+    }
+    calc_didev();
+
+/* Compute scale factors */
+
+    lx = plsc->phyxlen;
+    ly = plsc->phyylen;
+
+/* Transformation coefficients */
+
+    plsc->dioxax = r11;
+    plsc->dioxay = r21 * (lx / ly);
+    plsc->dioxb = (1. - r11) * x0 - r21 * y0 * (lx / ly);
+
+    plsc->dioyax = r12 * (ly / lx);
+    plsc->dioyay = r22;
+    plsc->dioyb = (1. - r22) * y0 - r12 * x0 * (ly / lx);
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plgdiori
+ *
+ * Get plot orientation
+\*--------------------------------------------------------------------------*/
+
+void
+c_plgdiori(PLFLT *p_rot)
+{
+    *p_rot = plsc->diorot;
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plsdimap
+ *
+ * Set up transformation from metafile coordinates.  The size of the plot is
+ * scaled so as to preserve aspect ratio.  This isn't intended to be a
+ * general-purpose facility just yet (not sure why the user would need it,
+ * for one).
+\*--------------------------------------------------------------------------*/
+
+void
+c_plsdimap(PLINT dimxmin, PLINT dimxmax, PLINT dimymin, PLINT dimymax,
+	   PLFLT dimxpmm, PLFLT dimypmm)
+{
+    plsetvar(plsc->dimxmin, dimxmin);
+    plsetvar(plsc->dimxmax, dimxmax);
+    plsetvar(plsc->dimymin, dimymin);
+    plsetvar(plsc->dimymax, dimymax);
+    plsetvar(plsc->dimxpmm, dimxpmm);
+    plsetvar(plsc->dimypmm, dimypmm);
+
+    plsc->difilt |= PLDI_MAP;
+    pldi_ini();
+}
+
+/*--------------------------------------------------------------------------*\
+ * void calc_dimap
+ *
+ * Set up transformation from metafile coordinates.  The size of the plot is
+ * scaled so as to preserve aspect ratio.  This isn't intended to be a
+ * general-purpose facility just yet (not sure why the user would need it,
+ * for one).
+\*--------------------------------------------------------------------------*/
+
+static void
+calc_dimap()
+{
+    PLFLT lx, ly;
+    PLINT pxmin, pxmax, pymin, pymax;
+    PLFLT dimxlen, dimylen, pxlen, pylen;
+
+    if ((plsc->dimxmin == plsc->phyxmi) && (plsc->dimxmax == plsc->phyxma) &&
+	(plsc->dimymin == plsc->phyymi) && (plsc->dimymax == plsc->phyyma) &&
+	(plsc->dimxpmm == plsc->xpmm) && (plsc->dimypmm == plsc->ypmm)) {
+	plsc->difilt &= ~PLDI_MAP;
+	return;
+    }
+
+/* Set default aspect ratio */
+
+    lx = (plsc->dimxmax - plsc->dimxmin + 1) / plsc->dimxpmm;
+    ly = (plsc->dimymax - plsc->dimymin + 1) / plsc->dimypmm;
+
+    plsc->aspdev = lx / ly;
+
+/* Build transformation to correct physical coordinates */
+
+    dimxlen = plsc->dimxmax - plsc->dimxmin;
+    dimylen = plsc->dimymax - plsc->dimymin;
+
+    pxmin = plsc->phyxmi;
+    pxmax = plsc->phyxma;
+    pymin = plsc->phyymi;
+    pymax = plsc->phyyma;
+    pxlen = pxmax - pxmin;
+    pylen = pymax - pymin;
+
+    plsc->dimxax = pxlen / dimxlen;
+    plsc->dimyay = pylen / dimylen;
+    plsc->dimxb = pxmin - pxlen * plsc->dimxmin / dimxlen;
+    plsc->dimyb = pymin - pylen * plsc->dimymin / dimylen;
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plflush()
+ *
+ * Flushes the output stream.  Use sparingly, if at all.
+\*--------------------------------------------------------------------------*/
+
+void
+c_plflush(void)
+{
+    if (plsc->dev_flush) {
+	(*plsc->dispatch_table->pl_esc) ( (struct PLStream_struct *) plsc,
+                                          PLESC_FLUSH, NULL );
+    }
+    else {
+	if (plsc->OutFile != NULL)
+	    fflush(plsc->OutFile);
+    }
+}
+
+/*--------------------------------------------------------------------------*\
+ * Startup routines.
+\*--------------------------------------------------------------------------*/
+
+/*--------------------------------------------------------------------------*\
+ * void pllib_init()
+ *
+ * Initialize library.  Called internally by every startup routine.
+ * Everything you want to always be initialized before plinit() is called
+ * you should put here.  E.g. dispatch table setup, rcfile read, etc.
+\*--------------------------------------------------------------------------*/
+
+void
+pllib_init()
+{
+    if (lib_initialized) return;
+    lib_initialized = 1;
+
+#ifdef ENABLE_DYNDRIVERS
+/* Create libltdl resources */
+        lt_dlinit();   
+#endif
+
+/* Initialize the dispatch table with the info from the static drivers table
+   and the available dynamic drivers. */
+
+    plInitDispatchTable();
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plstar(nx, ny)
+ *
+ * Initialize PLplot, passing in the windows/page settings.
+\*--------------------------------------------------------------------------*/
+
+void
+c_plstar(PLINT nx, PLINT ny)
+{
+    pllib_init();
+
+    if (plsc->level != 0)
+	plend1();
+
+    plssub(nx, ny);
+
+    c_plinit();
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plstart(devname, nx, ny)
+ *
+ * Initialize PLplot, passing the device name and windows/page settings. 
+\*--------------------------------------------------------------------------*/
+
+void
+c_plstart(const char *devname, PLINT nx, PLINT ny)
+{
+    pllib_init();
+
+    if (plsc->level != 0)
+	plend1();
+
+    plssub(nx, ny);
+    plsdev(devname);
+
+    c_plinit();
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plinit()
+ *
+ * Initializes PLplot, using preset or default options.
+\*--------------------------------------------------------------------------*/
+
+MZ_DLLEXPORT
+void
+c_plinit(void)
+{
+    PLFLT lx, ly, xpmm_loc, ypmm_loc, aspect_old, aspect_new;
+    PLINT mk = 0, sp = 0, inc = 0, del = 2000;
+
+    pllib_init();
+
+    if (plsc->level != 0)
+	plend1();
+
+/* Set stream number */
+
+    plsc->ipls = ipls;
+
+/* Set up devices */
+
+    pllib_devinit();
+
+/* Auxiliary stream setup */
+
+    plstrm_init();
+
+/* Initialize device & first page */
+
+    plP_init();
+    plP_bop();
+    plsc->level = 1;
+
+/* Calculate factor such that the character aspect ratio is preserved 
+ * when the overall aspect ratio is changed, i.e., if portrait mode is
+ * requested (only honored for subset of drivers) or if the aspect ratio
+ * is specified in any way, or if a 90 deg rotation occurs with
+ * -freeaspect. */
+   
+/* Case where plsc->aspect has a value.... (e.g., -a aspect on the
+ * command line or 2nd parameter of plsdidev specified) */
+    if (plsc->aspect > 0.) {
+       lx = plsc->phyxlen / plsc->xpmm;
+       ly = plsc->phyylen / plsc->ypmm;
+       aspect_old = lx / ly;
+       aspect_new = plsc->aspect;
+       plsc->caspfactor = sqrt(aspect_old/aspect_new);
+    }
+/* Case of 90 deg rotations with -freeaspect (this is also how portraite
+ * mode is implemented for the drivers that honor -portrait). */
+    else if (plsc->freeaspect && ABS(cos(plsc->diorot * PI / 2.)) <= 1.e-5) {
+       lx = plsc->phyxlen / plsc->xpmm;
+       ly = plsc->phyylen / plsc->ypmm;
+       aspect_old = lx / ly;
+       aspect_new = ly / lx;
+       plsc->caspfactor = sqrt(aspect_old/aspect_new);
+    }
+
+    else
+       plsc->caspfactor = 1.;
+
+/* Load fonts */
+
+    plsc->cfont = 1;
+    plfntld(initfont);
+
+/* Set up subpages */
+
+    plP_subpInit();
+
+/* Set up number of allowed digits before switching to scientific notation */
+/* The user can always change this */
+
+    if (plsc->xdigmax == 0)
+	plsc->xdigmax = 4;
+
+    if (plsc->ydigmax == 0)
+	plsc->ydigmax = 4;
+
+    if (plsc->zdigmax == 0)
+	plsc->zdigmax = 3;
+
+/* Switch to graphics mode and set color */
+
+    plgra();
+    plcol(1);
+
+    plstyl(0, &mk, &sp);
+    plpat(1, &inc, &del);
+
+/* Set clip limits. */
+
+    plsc->clpxmi = plsc->phyxmi;
+    plsc->clpxma = plsc->phyxma;
+    plsc->clpymi = plsc->phyymi;
+    plsc->clpyma = plsc->phyyma;
+
+/* Page aspect ratio. */
+
+    lx = plsc->phyxlen / plsc->xpmm;
+    ly = plsc->phyylen / plsc->ypmm;
+    plsc->aspdev = lx / ly;
+
+/* Initialize driver interface */
+
+    pldi_ini();
+
+/* Apply compensating factor to original xpmm and ypmm so that 
+ * character aspect ratio is preserved when overall aspect ratio
+ * is changed.  This must appear here in the code because previous
+ * code in this routine and in routines that it calls must use the original
+ * values of xpmm and ypmm before the compensating factor is applied.  */
+
+    plP_gpixmm(&xpmm_loc, &ypmm_loc);
+    plP_setpxl(xpmm_loc*plsc->caspfactor, ypmm_loc/plsc->caspfactor); 
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plend()
+ *
+ * End a plotting session for all open streams.
+\*--------------------------------------------------------------------------*/
+
+MZ_DLLEXPORT
+void
+c_plend(void)
+{
+    PLINT i;
+
+    for (i = PL_NSTREAMS-1; i >= 0; i--) {
+	if (pls[i] != NULL) {
+	    plsstrm(i);
+	    c_plend1();
+	}
+    }
+    plfontrel();
+#ifdef ENABLE_DYNDRIVERS
+/* Release the libltdl resources */
+    lt_dlexit();
+#endif
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plend1()
+ *
+ * End a plotting session for the current stream only.  After the stream is
+ * ended the memory associated with the stream's PLStream data structure is
+ * freed (for stream > 0), and the stream counter is set to 0 (the default).
+\*--------------------------------------------------------------------------*/
+
+void
+c_plend1(void)
+{
+    if (plsc->level > 0) {
+	plP_eop();
+	plP_tidy();
+	plsc->level = 0;
+    }
+
+/* Free all malloc'ed stream memory */
+
+    free_mem(plsc->cmap0);
+    free_mem(plsc->cmap1);
+    free_mem(plsc->plwindow);
+    free_mem(plsc->geometry);
+    free_mem(plsc->dev);
+    free_mem(plsc->BaseName);
+
+/* Free malloc'ed stream if not in initial stream, else clear it out */
+
+    if (ipls > 0) {
+	free_mem(plsc);
+	pls[ipls] = NULL;
+	plsstrm(0);
+    }
+    else {
+	memset((char *) pls[ipls], 0, sizeof(PLStream));
+    }
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plsstrm
+ *
+ * Set stream number.  If the data structure for a new stream is
+ * unallocated, we allocate it here.
+\*--------------------------------------------------------------------------*/
+
+void
+c_plsstrm(PLINT strm)
+{
+    if (strm < 0 || strm >= PL_NSTREAMS) {
+	fprintf(stderr,
+		"plsstrm: Illegal stream number %d, must be in [0, %d]\n",
+		(int) strm, PL_NSTREAMS);
+    }
+    else {
+	ipls = strm;
+	if (pls[ipls] == NULL) {
+	    pls[ipls] = (PLStream *) malloc((size_t) sizeof(PLStream));
+	    if (pls[ipls] == NULL)
+		plexit("plsstrm: Out of memory.");
+
+	    memset((char *) pls[ipls], 0, sizeof(PLStream));
+	}
+	plsc = pls[ipls];
+	plsc->ipls = ipls;
+    }
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plgstrm
+ *
+ * Get current stream number.
+\*--------------------------------------------------------------------------*/
+
+void
+c_plgstrm(PLINT *p_strm)
+{
+    *p_strm = ipls;
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plmkstrm
+ *
+ * Creates a new stream and makes it the default.  Differs from using
+ * plsstrm(), in that a free stream number is found, and returned.
+ *
+ * Unfortunately, I /have/ to start at stream 1 and work upward, since
+ * stream 0 is preallocated.  One of the BIG flaws in the PLplot API is
+ * that no initial, library-opening call is required.  So stream 0 must be
+ * preallocated, and there is no simple way of determining whether it is
+ * already in use or not.
+\*--------------------------------------------------------------------------*/
+
+void
+c_plmkstrm(PLINT *p_strm)
+{
+    int i;
+
+    for (i = 1; i < PL_NSTREAMS; i++) {
+	if (pls[i] == NULL)
+	    break;
+    }
+
+    if (i == PL_NSTREAMS) {
+	fprintf(stderr, "plmkstrm: Cannot create new stream\n");
+	*p_strm = -1;
+    }
+    else {
+	*p_strm = i;
+	plsstrm(i);
+    }
+    plstrm_init();
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plstrm_init
+ *
+ * Does required startup initialization of a stream.  Should be called right
+ * after creating one (for allocating extra memory, etc).  Users shouldn't
+ * need to call this directly.
+ *
+ * This function can be called multiple times for a given stream, in which
+ * case only the first call produces any effect.  For streams >= 1, which
+ * are created dynamically, this is called by the routine that allocates
+ * the stream.  Stream 0, which is preallocated, is much harder to deal with
+ * because any of a number of different calls may be the first call to the
+ * library.  This is handled by just calling plstrm_init() from every
+ * function that might be called first.  Sucks, but it should work.
+\*--------------------------------------------------------------------------*/
+
+void
+plstrm_init(void)
+{
+    if ( ! plsc->initialized) {
+	plsc->initialized = 1;
+
+	if (plsc->cmap0 == NULL)
+	    plscmap0n(0);
+
+	if (plsc->cmap1 == NULL)
+	    plscmap1n(0);
+    }
+}
+
+/*--------------------------------------------------------------------------*\
+ * pl_cpcolor
+ *
+ * Utility to copy one PLColor to another.
+\*--------------------------------------------------------------------------*/
+
+void
+pl_cpcolor(PLColor *to, PLColor *from)
+{
+    to->r = from->r;
+    to->g = from->g;
+    to->b = from->b;
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plcpstrm
+ *
+ * Copies state parameters from the reference stream to the current stream.
+ * Tell driver interface to map device coordinates unless flags == 1.
+ *
+ * This function is used for making save files of selected plots (e.g.
+ * from the TK driver).  After initializing, you can get a copy of the
+ * current plot to the specified device by switching to this stream and
+ * issuing a plcpstrm() and a plreplot(), with calls to plbop() and
+ * pleop() as appropriate.  The plot buffer must have previously been
+ * enabled (done automatically by some display drivers, such as X).
+\*--------------------------------------------------------------------------*/
+
+void
+c_plcpstrm(PLINT iplsr, PLINT flags)
+{
+    int i;
+    PLStream *plsr;
+
+    plsr = pls[iplsr];
+    if (plsr == NULL) {
+	fprintf(stderr, "plcpstrm: stream %d not in use\n", (int) iplsr);
+	return;
+    }
+
+/* May be debugging */
+
+    plsc->debug = plsr->debug;
+
+/* Plot buffer -- need to copy file pointer so that plreplot() works */
+/* This also prevents inadvertent writes into the plot buffer */
+
+    plsc->plbufFile = plsr->plbufFile;
+
+/* Driver interface */
+/* Transformation must be recalculated in current driver coordinates */
+
+    if (plsr->difilt & PLDI_PLT) 
+	plsdiplt(plsr->dipxmin, plsr->dipymin, plsr->dipxmax, plsr->dipymax);
+
+    if (plsr->difilt & PLDI_DEV)
+	plsdidev(plsr->mar, plsr->aspect, plsr->jx, plsr->jy);
+
+    if (plsr->difilt & PLDI_ORI)
+	plsdiori(plsr->diorot);
+
+/* Map device coordinates */
+
+    if ( ! (flags & 0x01)) {
+	pldebug("plcpstrm", "mapping parameters: %d %d %d %d %f %f\n",
+		plsr->phyxmi, plsr->phyxma, plsr->phyymi, plsr->phyyma,
+		plsr->xpmm, plsr->ypmm);
+	plsdimap(plsr->phyxmi, plsr->phyxma, plsr->phyymi, plsr->phyyma,
+		 plsr->xpmm, plsr->ypmm);
+    }
+
+/* current color */
+
+    pl_cpcolor(&plsc->curcolor, &plsr->curcolor);
+
+/* cmap 0 */
+
+    plsc->icol0 = plsr->icol0;
+    plsc->ncol0 = plsr->ncol0;
+    if (plsc->cmap0 != NULL)
+	free((void *) plsc->cmap0);
+
+    plsc->cmap0 = (PLColor *) calloc(1, plsc->ncol0 * sizeof(PLColor));
+    for (i = 0; i < plsc->ncol0; i++)
+	pl_cpcolor(&plsc->cmap0[i], &plsr->cmap0[i]);
+
+/* cmap 1 */
+
+    plsc->icol1 = plsr->icol1;
+    plsc->ncol1 = plsr->ncol1;
+    if (plsc->cmap1 != NULL)
+	free((void *) plsc->cmap1);
+
+    plsc->cmap1 = (PLColor *) calloc(1, plsc->ncol1 * sizeof(PLColor));
+    for (i = 0; i < plsc->ncol1; i++) 
+	pl_cpcolor(&plsc->cmap1[i], &plsr->cmap1[i]);
+
+/* Initialize if it hasn't been done yet. */
+
+    if (plsc->level == 0)
+	plinit();
+}
+
+/*--------------------------------------------------------------------------*\
+ * pllib_devinit()
+ *
+ * Does preliminary setup of device driver.
+ *
+ * This function (previously plGetDev) used to be what is now shown as
+ * plSelectDev below.  However, the situation is a bit more complicated now in
+ * the dynloadable drivers era.  We now have to:
+ *
+ * 1) Make sure the dispatch table is initialized to the union of static
+ *    drivers and available dynamic drivers (done from pllib_init now).
+ * 2) Allow the user to select the desired device.
+ * 3) Initialize the dispatch table entries for the selected device, in the
+ *    case that it is a dynloadable driver that has not yet been loaded.
+ *
+ * Also made non-static, in order to allow some device calls to be made prior
+ * to calling plinit().  E.g. plframe needs to tell the X driver to create its
+ * internal data structure during widget construction time (using the escape
+ * function), but doesn't call plinit() until the plframe is actually mapped.
+\*--------------------------------------------------------------------------*/
+
+void
+pllib_devinit()
+{
+    if (plsc->dev_initialized) return;
+    plsc->dev_initialized = 1;
+
+    plSelectDev();
+
+    plLoadDriver();
+
+/* offset by one since table is zero-based, but input list is not */
+    plsc->dispatch_table = dispatch_table[plsc->device - 1];
+}
+
+#ifdef ENABLE_DYNDRIVERS
+
+static char*
+plGetDrvDir ()
+{
+    char* drvdir;
+
+/* Get drivers directory in PLPLOT_DRV_DIR or DATA_DIR/DRV_DIR, 
+ *  on this order
+ */
+ 
+    pldebug("plGetDrvDir", "Trying to read env var PLPLOT_DRV_DIR\n");
+    drvdir = getenv ("PLPLOT_DRV_DIR");
+
+    if (drvdir == NULL) {
+        pldebug("plGetDrvDir", 
+	        "Will use drivers dir: " DATA_DIR "/" DRV_DIR "\n");
+        drvdir = DATA_DIR "/" DRV_DIR;
+    }
+    
+    return drvdir;
+}    
+
+#endif
+
+
+/*--------------------------------------------------------------------------*\
+ * void plInitDispatchTable()
+ *
+ * ...
+\*--------------------------------------------------------------------------*/
+
+static int plDispatchSequencer( const void *p1, const void *p2 )
+{
+    const PLDispatchTable* t1 = *(PLDispatchTable **) p1;
+    const PLDispatchTable* t2 = *(PLDispatchTable **) p2;
+
+/*     printf( "sorting: t1.name=%s t1.seq=%d t2.name=%s t2.seq=%d\n", */
+/*             t1->pl_DevName, t1->pl_seq, t2->pl_DevName, t2->pl_seq ); */
+
+    return t1->pl_seq - t2->pl_seq;
+}
+
+static void
+plInitDispatchTable()
+{
+    int n;
+
+#ifdef ENABLE_DYNDRIVERS
+    char buf[300];
+    char* drvdir;
+    char *devnam, *devdesc, *devtype, *driver, *tag, *seqstr;
+    int seq;
+    int i, j, driver_found, done=0;
+    FILE *fp_drvdb = NULL;
+    DIR* dp_drvdir = NULL;
+    struct dirent* entry;
+    lt_dlhandle dlhand;
+
+/* Open a temporary file in which all the plD_DEVICE_INFO_<driver> strings
+   will be stored */
+    fp_drvdb = tmpfile ();
+
+/* Open the drivers directory */
+    drvdir = plGetDrvDir ();
+    dp_drvdir = opendir (drvdir);
+    if (dp_drvdir == NULL)
+      plabort ("plInitDispatchTable: Could not open drivers directory");
+
+/* Loop over each entry in the drivers directory */
+
+    pldebug ("plInitDispatchTable", "Scanning dyndrivers dir\n");
+    while ((entry = readdir (dp_drvdir)) != NULL) 
+    {
+        char* name = entry->d_name;
+        int len = strlen (name) - 3;
+
+            pldebug ("plInitDispatchTable", 
+                     "Consider file %s\n", name);
+
+/* Only consider entries that have the ".rc" suffix */
+	if ((len > 0) && (strcmp (name + len, ".rc") == 0)) {
+	    char path[300];
+	    char buf[300];
+            FILE* fd;
+	 
+/* Open the driver's info file */
+            sprintf (path, "%s/%s", drvdir, name);
+            fd = fopen (path, "r");
+            if (fd == NULL) {
+	        sprintf (buf,
+                  "plInitDispatchTable: Could not open driver info file %s\n",
+                  name);
+	        plabort (buf);
+	    }
+
+/* Each line in the <driver>.rc file corresponds to a specific device.
+ * Write it to the drivers db file and take care of leading newline 
+ * character */
+ 
+            pldebug ("plInitDispatchTable", 
+                     "Opened driver info file %s\n", name);
+            while (fgets (buf, 300, fd) != NULL) 
+	    {
+                fprintf (fp_drvdb, "%s", buf);
+		if ( buf [strlen (buf) - 1] != '\n' )
+		    fprintf (fp_drvdb, "\n");
+                npldynamicdevices++;
+	    }
+	    fclose (fd);
+	}
+    }
+    
+/* Make sure that the temporary file containing the driversr database 
+ * is ready to read and close the directory handle */
+    fflush (fp_drvdb);
+    closedir (dp_drvdir);
+
+#endif
+
+/* Allocate space for the dispatch table. */
+    dispatch_table = (PLDispatchTable **) 
+	malloc( (nplstaticdevices + npldynamicdevices) * sizeof(PLDispatchTable *) );
+
+/* Initialize the dispatch table entries for the static devices by calling
+   the dispatch table initialization function for each static device.  This
+   is the same function that would be called at load time for dynamic
+   drivers. */
+
+    for( n=0; n < nplstaticdevices; n++ )
+    {
+        dispatch_table[n] = (PLDispatchTable *)malloc( sizeof(PLDispatchTable) );
+
+        (*static_device_initializers[n])( dispatch_table[n] );
+    }
+    npldrivers = nplstaticdevices;
+
+#ifdef ENABLE_DYNDRIVERS
+
+/* Allocate space for the device and driver specs.  We may not use all of
+ * these driver descriptors, but we obviously won't need more drivers than
+ * devices... */
+    loadable_device_list = malloc( npldynamicdevices * sizeof(PLLoadableDevice) );
+    loadable_driver_list = malloc( npldynamicdevices * sizeof(PLLoadableDriver) );
+
+    rewind( fp_drvdb );
+
+    i = 0;
+    done = !(i < npldynamicdevices);
+    while( !done ) {
+        char *p = fgets( buf, 300, fp_drvdb );
+
+        if (p == 0) {
+            done = 1;
+            continue;
+        }
+
+        devnam  = strtok( buf, ":" );
+        devdesc = strtok( 0, ":" );
+        devtype = strtok( 0, ":" );
+        driver  = strtok( 0, ":" );
+        seqstr  = strtok( 0, ":" );
+        tag     = strtok( 0, "\n" );
+
+        seq     = atoi(seqstr);
+
+        n = npldrivers++;
+
+        dispatch_table[n] = malloc( sizeof(PLDispatchTable) );
+
+    /* Fill in the dispatch table entries. */
+        dispatch_table[n]->pl_MenuStr = plstrdup(devdesc);
+        dispatch_table[n]->pl_DevName = plstrdup(devnam);
+        dispatch_table[n]->pl_type = atoi(devtype);
+        dispatch_table[n]->pl_seq = seq;
+        dispatch_table[n]->pl_init = 0;
+        dispatch_table[n]->pl_line = 0;
+        dispatch_table[n]->pl_polyline = 0;
+        dispatch_table[n]->pl_eop = 0;
+        dispatch_table[n]->pl_bop = 0;
+        dispatch_table[n]->pl_tidy = 0;
+        dispatch_table[n]->pl_state = 0;
+        dispatch_table[n]->pl_esc = 0;
+
+    /* Add a record to the loadable device list */
+        loadable_device_list[i].devnam = plstrdup(devnam);
+        loadable_device_list[i].description = plstrdup(devdesc);
+        loadable_device_list[i].drvnam = plstrdup(driver);
+        loadable_device_list[i].tag = plstrdup(tag);
+
+    /* Now see if this driver has been seen before.  If not, add a driver
+     * entry for it. */
+        driver_found = 0;
+        for( j=0; j < nloadabledrivers; j++ )
+            if (strcmp( driver, loadable_driver_list[j].drvnam) == 0)
+            {
+                driver_found = 1;
+                break;
+            }
+
+        if (!driver_found)
+        {
+            loadable_driver_list[nloadabledrivers].drvnam = plstrdup(driver);
+            loadable_driver_list[nloadabledrivers].dlhand = 0;
+            nloadabledrivers++;
+        }
+
+        loadable_device_list[i].drvidx = j;
+
+    /* Get ready for next loadable device spec */
+        i++;
+    }
+    
+/* RML: close fp_drvdb */
+    fclose (fp_drvdb);
+
+#endif
+
+/* Finally, we need to sort the list into presentation order, based on the
+   sequence number in the dispatch ttable entries. */
+
+    qsort( dispatch_table, npldrivers, sizeof(PLDispatchTable*),
+           plDispatchSequencer );
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plSelectDev()
+ *
+ * If the user has not already specified the output device, or the
+ * one specified is either: (a) not available, (b) "?", or (c) NULL, the
+ * user is prompted for it.
+ *
+ * Prompting quits after 10 unsuccessful tries in case the user has
+ * run the program in the background with insufficient input.
+\*--------------------------------------------------------------------------*/
+
+static void
+plSelectDev()
+{
+    int dev, i, count, length;
+    char response[80];
+
+/* Device name already specified.  See if it is valid. */
+
+    if (*(plsc->DevName) != '\0' && *(plsc->DevName) != '?') {
+	length = strlen(plsc->DevName);
+	for (i = 0; i < npldrivers; i++) {
+	    if ((*plsc->DevName == *dispatch_table[i]->pl_DevName) &&
+		(strncmp(plsc->DevName,
+			 dispatch_table[i]->pl_DevName, length) == 0))
+		break;
+	}
+	if (i < npldrivers) {
+	    plsc->device = i + 1;
+	    return;
+	}
+	else {
+	    fprintf(stderr, "Requested device %s not available\n",
+		    plsc->DevName);
+	}
+    }
+
+    dev = 0;
+    count = 0;
+
+    if (npldrivers == 1)
+	dev = 1;
+
+/* User hasn't specified it correctly yet, so we prompt */
+
+    while (dev < 1 || dev > npldrivers) {
+	fprintf(stdout, "\nPlotting Options:\n");
+	for (i = 0; i < npldrivers; i++) {
+	    fprintf(stdout, " <%2d> %-10s %s\n", i + 1,
+		    dispatch_table[i]->pl_DevName,
+		    dispatch_table[i]->pl_MenuStr);
+	}
+	if (ipls == 0)
+	    fprintf(stdout, "\nEnter device number or keyword: ");
+	else
+	    fprintf(stdout, "\nEnter device number or keyword (stream %d): ",
+		   (int) ipls);
+
+	fgets(response, sizeof(response), stdin);
+
+    /* First check to see if device keyword was entered. */
+    /* Final "\n" in response messes things up, so ignore it.  */
+
+	length = strlen(response);
+	if (*(response - 1 + length) == '\n')
+	    length--;
+
+	for (i = 0; i < npldrivers; i++) {
+	    if ( ! strncmp(response, dispatch_table[i]->pl_DevName,
+			   (unsigned int) length))
+		break;
+	}
+	if (i < npldrivers) {
+	    dev = i + 1;
+	}
+	else {
+	    if ((dev = atoi(response)) < 1) {
+		fprintf(stdout, "\nInvalid device: %s", response);
+		dev = 0;
+	    }
+	}
+	if (count++ > 10)
+	    plexit("plSelectDev: Too many tries.");
+    }
+    plsc->device = dev;
+    strcpy(plsc->DevName, dispatch_table[dev - 1]->pl_DevName);
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plLoadDriver()
+ *
+ * Make sure the selected driver is loaded.  Static drivers are already
+ * loaded, but if the user selected a dynamically loadable driver, we may
+ * have to take care of that now.
+\*--------------------------------------------------------------------------*/
+
+static void
+plLoadDriver(void)
+{
+#ifdef ENABLE_DYNDRIVERS
+    int i, drvidx;
+    char sym[60];
+    char *tag;
+
+    int n=plsc->device - 1;
+    PLDispatchTable *dev = dispatch_table[n];
+    PLLoadableDriver *driver = 0;
+
+/* If the dispatch table is already filled in, then either the device was
+ * linked in statically, or else perhaps it was already loaded.  In either
+ * case, we have nothing left to do. */
+    if (dev->pl_init)
+        return;
+
+    pldebug("plLoadDriver", "Device not loaded!\n");
+
+/* Now search through the list of loadable devices, looking for the record
+ * that corresponds to the requested device. */
+    for( i=0; i < npldynamicdevices; i++ )
+        if (strcmp( dev->pl_DevName, loadable_device_list[i].devnam ) == 0)
+            break;
+
+/* If we couldn't find such a record, then there is some sort of internal
+ * logic flaw since plSelectDev is supposed to only select a valid device.
+ */
+    if (i == npldynamicdevices) {
+        fprintf( stderr, "No such device: %s.\n", dev->pl_DevName );
+        plexit("plLoadDriver detected device logic screwup");
+    }
+
+/* Note the device tag, and the driver index. Note that a given driver could
+ * supply multiple devices, each with a unique tag to distinguish the driver
+ * entry points for the differnet supported devices. */
+    tag = loadable_device_list[i].tag;
+    drvidx = loadable_device_list[i].drvidx;
+
+    pldebug("plLoadDriver", "tag=%s, drvidx=%d\n", tag, drvidx ); 
+
+    driver = &loadable_driver_list[drvidx];
+
+/* Load the driver if it hasn't been loaded yet. */
+    if (!driver->dlhand)
+    {
+        char drvspec[ 400 ];
+        sprintf( drvspec, "%s/%s", plGetDrvDir (), driver->drvnam );
+
+	pldebug("plLoadDriver", "Trying to load %s on %s\n",
+		driver->drvnam, drvspec );
+
+        driver->dlhand = lt_dlopenext( drvspec);
+    }
+
+/* If it still isn't loaded, then we're doomed. */
+    if (!driver->dlhand)
+    {
+        pldebug("plLoadDriver", "lt_dlopenext failed because of "
+		 "the following reason:\n%s\n", lt_dlerror ());
+        fprintf( stderr, "Unable to load driver: %s.\n", driver->drvnam );
+        plexit("Unable to load driver");
+    }
+
+/* Now we are ready to ask the driver's device dispatch init function to
+   initialize the entries in the dispatch table. */
+
+    sprintf( sym, "plD_dispatch_init_%s", tag );
+    {
+        PLDispatchInit dispatch_init = (PLDispatchInit) lt_dlsym( driver->dlhand, sym );
+        if (!dispatch_init)
+        {
+            fprintf( stderr,
+                     "Unable to locate dispatch table initialization function for driver: %s.\n", 
+		     driver->drvnam );
+            return;
+        }
+
+        (*dispatch_init)( dev );
+    }
+#endif
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plfontld()
+ *
+ * Load specified font set.
+\*--------------------------------------------------------------------------*/
+
+void
+c_plfontld(PLINT ifont)
+{
+    if (ifont != 0)
+	ifont = 1;
+
+    if (plsc->level > 0)
+	plfntld(ifont);
+    else
+	initfont = ifont;
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plreplot()
+ *
+ * Replays contents of plot buffer to current device/file.
+\*--------------------------------------------------------------------------*/
+
+void
+c_plreplot(void)
+{
+    if (plsc->plbufFile != NULL) {
+	plRemakePlot(plsc);
+    }
+    else {
+	plwarn("plreplot: plot buffer not available");
+    }
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plgFileDevs()
+ *
+ * Returns a list of file-oriented device names and their menu strings,
+ * for use in a graphical interface.  The caller must allocate enough
+ * space for (*p_menustr) and (*p_devname) to hold a pointer for each
+ * device -- 20 or so is plenty.  E.g. char *menustr[20].  The size of
+ * these arrays should be passed in *p_ndev, which, on exit, holds the
+ * number of devices actually present.
+\*--------------------------------------------------------------------------*/
+
+void
+plgFileDevs(char ***p_menustr, char ***p_devname, int *p_ndev)
+{
+    plgdevlst(*p_menustr, *p_devname, p_ndev, 0);
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plgDevs()
+ *
+ * Like plgFileDevs(), but returns names and menu strings for all devices.
+\*--------------------------------------------------------------------------*/
+
+void
+plgDevs(char ***p_menustr, char ***p_devname, int *p_ndev)
+{
+    plgdevlst(*p_menustr, *p_devname, p_ndev, -1);
+}
+
+static void
+plgdevlst(char **p_menustr, char **p_devname, int *p_ndev, int type)
+{
+    int i, j;
+
+    pllib_init();
+
+    for (i = j = 0; i < npldrivers; i++) {
+	if (type < 0 || dispatch_table[i]->pl_type == type) {
+	    p_menustr[j] = dispatch_table[i]->pl_MenuStr;
+	    p_devname[j] = dispatch_table[i]->pl_DevName;
+	    if (++j + 1 >= *p_ndev) {
+	        plwarn("plgdevlst:  too many devices");
+		break;
+	      }
+	}
+    }
+    p_menustr[j] = NULL;
+    p_devname[j] = NULL;
+    *p_ndev = j;
+}
+
+/*--------------------------------------------------------------------------*\
+ *  Various external access routines.
+\*--------------------------------------------------------------------------*/
+
+/* Get output device parameters. */
+
+void
+c_plgpage(PLFLT *p_xp, PLFLT *p_yp,
+	  PLINT *p_xleng, PLINT *p_yleng, PLINT *p_xoff, PLINT *p_yoff)
+{
+    *p_xp = plsc->xdpi;
+    *p_yp = plsc->ydpi;
+    *p_xleng = plsc->xlength;
+    *p_yleng = plsc->ylength;
+    *p_xoff = plsc->xoffset;
+    *p_yoff = plsc->yoffset;
+}
+
+/* Set output device parameters.  Usually ignored by the driver. */
+
+MZ_DLLEXPORT
+void
+c_plspage(PLFLT xp, PLFLT yp, PLINT xleng, PLINT yleng, PLINT xoff, PLINT yoff)
+{
+    if (xp)
+	plsc->xdpi = xp;
+    if (yp)
+	plsc->ydpi = yp;
+
+    if (xleng)
+	plsc->xlength = xleng;
+    if (yleng)
+	plsc->ylength = yleng;
+
+    if (xoff)
+	plsc->xoffset = xoff;
+    if (yoff)
+	plsc->yoffset = yoff;
+
+    plsc->pageset = 1;
+}
+
+/* Set the number of subwindows in x and y */
+
+void
+c_plssub(PLINT nx, PLINT ny)
+{
+    if (nx > 0)
+	plsc->nsubx = nx;
+    if (ny > 0)
+	plsc->nsuby = ny;
+
+/* Force a page advance */
+
+    if (plsc->level > 0) {
+        plP_subpInit();
+/*AWI	plP_eop();
+	plP_bop();*/
+    }
+}
+
+/* Set the device (keyword) name */
+
+MZ_DLLEXPORT
+void
+c_plsdev(const char *devname)
+{
+    if (plsc->level > 0) {
+	plwarn("plsdev: Must be called before plinit.");
+	return;
+    }
+    if (devname != NULL) {
+	strncpy(plsc->DevName, devname, sizeof(plsc->DevName) - 1);
+	plsc->DevName[sizeof(plsc->DevName) - 1] = '\0';
+    }
+}
+
+/* Get the current device (keyword) name */
+/* Note: you MUST have allocated space for this (80 characters is safe) */
+
+void
+c_plgdev(char *p_dev)
+{
+    strcpy(p_dev, plsc->DevName);
+}
+
+/* Set the memory area to be plotted (with the 'mem' driver) as the 'dev'
+   member of the stream structure.  Also set the number
+   of pixels in the memory passed in in 'plotmem'.
+   Plotmem is a block of memory maxy by maxx by 3 bytes long, say:
+   480 x 640 x 3 (Y, X, RGB)
+
+   This memory will be freed by the user!
+*/
+
+void
+c_plsmem(PLINT maxx, PLINT maxy, void *plotmem)
+{
+    plsc->dev = plotmem;
+    plP_setphy (0, maxx, 0, maxy);
+}
+
+/* Get the current stream pointer */
+
+void
+plgpls(PLStream **p_pls)
+{
+    *p_pls = plsc;
+}
+
+/* Get the (current) run level. 
+ * Valid settings are:
+ *   0	uninitialized 
+ *   1	initialized
+ *   2	viewport defined
+ *   3	world coords defined 
+ */
+
+void
+c_plglevel(PLINT *p_level)
+{
+    *p_level = plsc->level;
+}
+
+/* Set the function pointer for the keyboard event handler */
+
+void
+plsKeyEH(void (*KeyEH) (PLGraphicsIn *, void *, int *),
+	 void *KeyEH_data)
+{
+    plsc->KeyEH = KeyEH;
+    plsc->KeyEH_data = KeyEH_data;
+}
+
+/* Set the function pointer for the (mouse) button event handler */
+
+void
+plsButtonEH(void (*ButtonEH) (PLGraphicsIn *, void *, int *),
+	    void *ButtonEH_data)
+{
+    plsc->ButtonEH = ButtonEH;
+    plsc->ButtonEH_data = ButtonEH_data;
+}
+
+/* Sets an optional user bop handler. */
+
+void
+plsbopH(void (*handler) (void *, int *), void *handler_data)
+{
+    plsc->bop_handler = handler;
+    plsc->bop_data = handler_data;
+}
+
+/* Sets an optional user eop handler. */
+
+void
+plseopH(void (*handler) (void *, int *), void *handler_data)
+{
+    plsc->eop_handler = handler;
+    plsc->eop_data = handler_data;
+}
+
+/* Set the variables to be used for storing error info */
+
+void
+plsError(PLINT *errcode, char *errmsg)
+{
+    if (errcode != NULL)
+	plsc->errcode = errcode;
+
+    if (errmsg != NULL)
+	plsc->errmsg = errmsg;
+}
+
+/* Set orientation.  Must be done before calling plinit. */
+
+void
+c_plsori(PLINT ori)
+{
+    plsdiori((PLFLT) ori);
+}
+
+/*
+ * Set pen width.  Can be done any time, but before calling plinit is best
+ * since otherwise it may be volatile (i.e. reset on next page advance). 
+ * If width < 0 or is unchanged by the call, nothing is done.
+ */
+
+MZ_DLLEXPORT
+void
+c_plwid(PLINT width)
+{
+    if (width != plsc->width && width >= 0) {
+	plsc->width = width;
+
+	if (plsc->level > 0) {
+	    if ( ! plsc->widthlock) 
+		plP_state(PLSTATE_WIDTH);
+	}
+    }
+}
+
+/* Set the output file pointer */
+
+void
+plgfile(FILE **p_file)
+{
+    *p_file = plsc->OutFile;
+}
+
+/* Get the output file pointer */
+
+void
+plsfile(FILE *file)
+{
+    plsc->OutFile = file;
+}
+
+/* Get the (current) output file name.  Must be preallocated to >=80 bytes */
+/* Beyond that, I truncate it.  You have been warned. */
+
+void
+c_plgfnam(char *fnam)
+{
+    if (fnam == NULL) {
+	plabort("filename string must be preallocated to >=80 bytes");
+	return;
+    }
+
+    *fnam = '\0';
+    if (plsc->FileName != NULL) {
+	strncpy(fnam, plsc->FileName, 79);
+	fnam[79] = '\0';
+    }
+}
+
+/* Set the output file name. */
+
+MZ_DLLEXPORT
+void
+c_plsfnam(const char *fnam)
+{
+    plP_sfnam(plsc, fnam);
+}
+
+/* Set the pause (on end-of-page) status */
+
+void
+c_plspause(PLINT pause)
+{
+    plsc->nopause = ! pause;
+}
+
+/* Set the floating point precision (in number of places) in numeric labels. */
+
+void
+c_plprec(PLINT setp, PLINT prec)
+{
+    plsc->setpre = setp;
+    plsc->precis = prec;
+}
+
+/* Get the floating point precision (in number of places) in numeric labels. */
+
+void
+plP_gprec(PLINT *p_setp, PLINT *p_prec)
+{
+    *p_setp = plsc->setpre;
+    *p_prec = plsc->precis;
+}
+
+/*
+ * Set the escape character for text strings.
+ * From C you can pass as a character, from Fortran it needs to be the decimal
+ * ASCII value.  Only selected characters are allowed to prevent the user from
+ * shooting himself in the foot (a '\' isn't allowed since it conflicts with
+ * C's use of backslash as a character escape).
+ */
+
+void
+c_plsesc(char esc)
+{
+    switch (esc) {
+	case '!':		/* ASCII 33 */
+	case '#':		/* ASCII 35 */
+	case '$':		/* ASCII 36 */
+	case '%':		/* ASCII 37 */
+	case '&':		/* ASCII 38 */
+	case '*':		/* ASCII 42 */
+	case '@':		/* ASCII 64 */
+	case '^':		/* ASCII 94 */
+	case '~':		/* ASCII 126 */
+	plsc->esc = esc;
+	break;
+
+      default:
+	plwarn("plsesc: Invalid escape character, ignoring.");
+    }
+}
+
+/* Get the escape character for text strings. */
+
+void
+plgesc(char *p_esc)
+{
+    if (plsc->esc == '\0')
+	plsc->esc = '#';
+
+    *p_esc = plsc->esc;
+}
+
+/* Get the current library version number */
+/* Note: you MUST have allocated space for this (80 characters is safe) */
+
+void
+c_plgver(char *p_ver)
+{
+    strcpy(p_ver, VERSION);
+}
+
+/* Set inferior X window */
+
+void
+plsxwin(PLINT window_id)
+{
+    plsc->window_id = window_id;
+}
+
+/*--------------------------------------------------------------------------*\
+ *  These set/get information for family files, and may be called prior
+ *  to plinit to set up the necessary parameters.  Arguments:
+ *
+ *	fam	familying flag (boolean)
+ *	num	member number
+ *	bmax	maximum member size
+\*--------------------------------------------------------------------------*/
+
+/* Get family file parameters */
+
+void
+c_plgfam(PLINT *p_fam, PLINT *p_num, PLINT *p_bmax)
+{
+    *p_fam = plsc->family;
+    *p_num = plsc->member;
+    *p_bmax = plsc->bytemax;
+}
+
+/* Set family file parameters */
+
+void
+c_plsfam(PLINT fam, PLINT num, PLINT bmax)
+{
+    if (plsc->level > 0)
+	plwarn("plsfam: Must be called before plinit.");
+
+    if (fam >= 0)
+	plsc->family = fam;
+    if (num >= 0)
+	plsc->member = num;
+    if (bmax >= 0)
+	plsc->bytemax = bmax;
+}
+
+/* Advance to the next family file on the next new page */
+
+void
+c_plfamadv(void)
+{
+    plsc->famadv = 1;
+}
+
+/*--------------------------------------------------------------------------*\
+ *  Interface routines for axis labling parameters.
+ *  See pldtik.c for more info.
+\*--------------------------------------------------------------------------*/
+
+/* Get x axis labeling parameters */
+
+void
+c_plgxax(PLINT *p_digmax, PLINT *p_digits)
+{
+    *p_digmax = plsc->xdigmax;
+    *p_digits = plsc->xdigits;
+}
+
+/* Set x axis labeling parameters */
+
+void
+c_plsxax(PLINT digmax, PLINT digits)
+{
+    plsc->xdigmax = digmax;
+    plsc->xdigits = digits;
+}
+
+/* Get y axis labeling parameters */
+
+void
+c_plgyax(PLINT *p_digmax, PLINT *p_digits)
+{
+    *p_digmax = plsc->ydigmax;
+    *p_digits = plsc->ydigits;
+}
+
+/* Set y axis labeling parameters */
+
+void
+c_plsyax(PLINT digmax, PLINT digits)
+{
+    plsc->ydigmax = digmax;
+    plsc->ydigits = digits;
+}
+
+/* Get z axis labeling parameters */
+
+void
+c_plgzax(PLINT *p_digmax, PLINT *p_digits)
+{
+    *p_digmax = plsc->zdigmax;
+    *p_digits = plsc->zdigits;
+}
+
+/* Set z axis labeling parameters */
+
+void
+c_plszax(PLINT digmax, PLINT digits)
+{
+    plsc->zdigmax = digmax;
+    plsc->zdigits = digits;
+}
+
+/* Get character default height and current (scaled) height */
+
+void
+c_plgchr(PLFLT *p_def, PLFLT *p_ht)
+{
+    *p_def = plsc->chrdef;
+    *p_ht = plsc->chrht;
+}
+
+/* Get viewport boundaries in normalized device coordinates */
+
+void
+c_plgvpd(PLFLT *p_xmin, PLFLT *p_xmax, PLFLT *p_ymin, PLFLT *p_ymax)
+{
+    *p_xmin = plsc->vpdxmi;
+    *p_xmax = plsc->vpdxma;
+    *p_ymin = plsc->vpdymi;
+    *p_ymax = plsc->vpdyma;
+}
+
+/* Get viewport boundaries in world coordinates */
+
+void
+c_plgvpw(PLFLT *p_xmin, PLFLT *p_xmax, PLFLT *p_ymin, PLFLT *p_ymax)
+{
+    *p_xmin = plsc->vpwxmi;
+    *p_xmax = plsc->vpwxma;
+    *p_ymin = plsc->vpwymi;
+    *p_ymax = plsc->vpwyma;
+}
+
+/*--------------------------------------------------------------------------*\
+ *  These should not be called by the user.
+\*--------------------------------------------------------------------------*/
+
+/* Get x-y domain in world coordinates for 3d plots */
+
+void
+plP_gdom(PLFLT *p_xmin, PLFLT *p_xmax, PLFLT *p_ymin, PLFLT *p_ymax)
+{
+    *p_xmin = plsc->domxmi;
+    *p_xmax = plsc->domxma;
+    *p_ymin = plsc->domymi;
+    *p_ymax = plsc->domyma;
+}
+
+/* Get vertical (z) scale parameters for 3-d plot */
+
+void
+plP_grange(PLFLT *p_zscl, PLFLT *p_zmin, PLFLT *p_zmax)
+{
+    *p_zscl = plsc->zzscl;
+    *p_zmin = plsc->ranmi;
+    *p_zmax = plsc->ranma;
+}
+
+/* Get parameters used in 3d plots */
+
+void
+plP_gw3wc(PLFLT *p_dxx, PLFLT *p_dxy, PLFLT *p_dyx, PLFLT *p_dyy, PLFLT *p_dyz)
+{
+    *p_dxx = plsc->cxx;
+    *p_dxy = plsc->cxy;
+    *p_dyx = plsc->cyx;
+    *p_dyy = plsc->cyy;
+    *p_dyz = plsc->cyz;
+}
+
+/* Get clip boundaries in physical coordinates */
+
+void
+plP_gclp(PLINT *p_ixmin, PLINT *p_ixmax, PLINT *p_iymin, PLINT *p_iymax)
+{
+    *p_ixmin = plsc->clpxmi;
+    *p_ixmax = plsc->clpxma;
+    *p_iymin = plsc->clpymi;
+    *p_iymax = plsc->clpyma;
+}
+
+/* Set clip boundaries in physical coordinates */
+
+void
+plP_sclp(PLINT ixmin, PLINT ixmax, PLINT iymin, PLINT iymax)
+{
+    plsc->clpxmi = ixmin;
+    plsc->clpxma = ixmax;
+    plsc->clpymi = iymin;
+    plsc->clpyma = iymax;
+}
+
+/* Get physical device limits in physical coordinates */
+
+void
+plP_gphy(PLINT *p_ixmin, PLINT *p_ixmax, PLINT *p_iymin, PLINT *p_iymax)
+{
+    *p_ixmin = plsc->phyxmi;
+    *p_ixmax = plsc->phyxma;
+    *p_iymin = plsc->phyymi;
+    *p_iymax = plsc->phyyma;
+}
+
+/* Get number of subpages on physical device and current subpage */
+
+void
+plP_gsub(PLINT *p_nx, PLINT *p_ny, PLINT *p_cs)
+{
+    *p_nx = plsc->nsubx;
+    *p_ny = plsc->nsuby;
+    *p_cs = plsc->cursub;
+}
+
+/* Set number of subpages on physical device and current subpage */
+
+void
+plP_ssub(PLINT nx, PLINT ny, PLINT cs)
+{
+    plsc->nsubx = nx;
+    plsc->nsuby = ny;
+    plsc->cursub = cs;
+}
+
+/* Get number of pixels to a millimeter */
+
+void
+plP_gpixmm(PLFLT *p_x, PLFLT *p_y)
+{
+    *p_x = plsc->xpmm;
+    *p_y = plsc->ypmm;
+}
+
+/* All the drivers call this to set physical pixels/mm. */
+
+void
+plP_setpxl(PLFLT xpmm, PLFLT ypmm)
+{
+    plsc->xpmm = xpmm;
+    plsc->ypmm = ypmm;
+    plsc->umx = 1000.0 / plsc->xpmm;
+    plsc->umy = 1000.0 / plsc->ypmm;
+}
+
+/* Sets up physical limits of plotting device. */
+
+void
+plP_setphy(PLINT xmin, PLINT xmax, PLINT ymin, PLINT ymax)
+{
+    if (xmin > xmax || ymin > ymax)
+	plexit("plP_setphy: device minima must not exceed maxima");
+
+    plsc->phyxmi = xmin;
+    plsc->phyxma = xmax;
+    plsc->phyymi = ymin;
+    plsc->phyyma = ymax;
+    plsc->phyxlen = xmax - xmin;
+    plsc->phyylen = ymax - ymin;
+}
+
+/*--------------------------------------------------------------------------*\
+ * void c_plscompression()
+ *
+ * Set compression. 
+ * Has to be done before plinit.
+\*--------------------------------------------------------------------------*/
+
+void
+c_plscompression(PLINT compression)
+{
+  if (plsc->level <= 0) 
+     {
+      plsc->dev_compression=compression;
+     }
+}
+
+/*--------------------------------------------------------------------------*\
+ * void c_plgcompression()
+ *
+ * Get compression
+\*--------------------------------------------------------------------------*/
+
+void
+c_plgcompression(PLINT *compression)
+{
+    *compression = plsc->dev_compression;
+}
+
+
+/*--------------------------------------------------------------------------*\
+ * void plP_getinitdriverlist()
+ *
+ * Check to see if a driver/stream has been initialised
+ * Returns a space separated list of matches streams/drivers
+ * If more than one stream uses the same device, then the device name
+ * will be returned for each stream.
+ * Caller must allocate enough memory for "names" to hold the answer.
+\*--------------------------------------------------------------------------*/
+
+void
+plP_getinitdriverlist(char *names)
+{
+int i;
+
+for (i=0;i<PL_NSTREAMS;++i)
+   {
+    if (pls[i]!=NULL)
+       {
+       if (i==0)
+          strcpy(names,pls[i]->DevName);
+       else
+          { 
+          strcat(names," ");
+          strcat(names,pls[i]->DevName);
+          }
+       }
+    else 
+       break;
+   }
+}
+
+
+/*--------------------------------------------------------------------------*\
+ * PLINT plP_checkdriverinit()
+ *
+ * Checks from a list of given drivers which ones have been initialised
+ * and returns the number of devices matching the list, or -1 if in error.
+ * Effectively returns the number of streams matching the given stream.
+\*--------------------------------------------------------------------------*/
+
+PLINT plP_checkdriverinit( char *names)
+{
+char *buff;
+char *tok=NULL;
+PLINT ret=0;   /* set up return code to 0, the value if no devices match*/
+
+buff=(char *)malloc((size_t) PL_NSTREAMS*8); /* Allocate enough memory for 8 
+                                                characters for each possible stream */
+
+if (buff!=NULL)
+   {
+    memset(buff,0,PL_NSTREAMS*8);    /* Make sure we clear it               */
+    plP_getinitdriverlist(buff);     /* Get the list of initialised devices */
+
+    for (tok = strtok(buff, " ,");   /* Check each device against the "name" */
+         tok; tok=strtok(0, " ,"))   /* supplied to the subroutine   */
+        {
+        if (strstr(names,tok)!=NULL)  /* Check to see if the device has been initialised */
+           {
+            ret++;                   /* Bump the return code if it has      */
+           }                    
+        }
+    free(buff);                      /* Clear up that memory we allocated   */
+    }
+else 
+   ret=-1;                           /* Error flag */
+
+return(ret);
+}
+
+
+/*--------------------------------------------------------------------------*\
+ * plP_image
+ *
+ * Author: Alessandro Mirone, Nov 2001
+ * 
+ * 
+ * 
+\*--------------------------------------------------------------------------*/
+
+void
+plP_image(short *x, short *y, unsigned short *z , PLINT nx, PLINT ny, PLFLT xmin, PLFLT ymin, PLFLT dx, PLFLT dy, unsigned short zmin, unsigned short zmax)
+{
+  PLINT i, npts;
+  short *xscl, *yscl;
+  int   plbuf_write;
+
+  plsc->page_status = DRAWING;
+
+  if (plsc->dev_fastimg == 0) {
+    plimageslow(x, y, z, nx-1, ny-1, 
+         xmin, ymin, dx, dy, zmin, zmax);
+    return ;
+  }
+
+  if (plsc->plbuf_write) {
+    IMG_DT img_dt;
+
+    img_dt.xmin=xmin;
+    img_dt.ymin=ymin;
+    img_dt.dx=dx;
+    img_dt.dy=dy;
+
+    plsc->dev_ix = x;
+    plsc->dev_iy = y;
+    plsc->dev_z = z;
+    plsc->dev_nptsX = nx;
+    plsc->dev_nptsY = ny;
+    plsc->dev_zmin = zmin;
+    plsc->dev_zmax = zmax;
+
+    plbuf_esc(plsc, PLESC_IMAGE, &img_dt);
+  }
+
+  /* avoid re-saving plot buffer while in plP_esc() */
+  plbuf_write = plsc->plbuf_write;
+  plsc->plbuf_write = 0; 
+
+  npts = nx*ny;
+  if (plsc->difilt) { /* isn't this odd? when replaying the plot buffer, e.g., when resizing the window, difilt() is caled again! the plot buffer should already contain the transformed data--it would save a lot of time! (and allow for differently oriented plots when in multiplot mode) */
+    PLINT clpxmi, clpxma, clpymi, clpyma;
+    
+    xscl = (short *) malloc(nx*ny*sizeof(short));
+    yscl = (short *) malloc(nx*ny*sizeof(short));
+    for (i = 0; i < npts; i++) {
+      xscl[i] = x[i];
+      yscl[i] = y[i];
+    }
+    sdifilt(xscl, yscl, npts, &clpxmi, &clpxma, &clpymi, &clpyma);
+    plsc->imclxmin = clpxmi;
+    plsc->imclymin = clpymi;
+    plsc->imclxmax = clpxma;
+    plsc->imclymax = clpyma;
+    grimage(xscl, yscl, z, nx, ny);    
+    free(xscl);
+    free(yscl);
+  } else { 
+    plsc->imclxmin = plsc->phyxmi;
+    plsc->imclymin = plsc->phyymi;
+    plsc->imclxmax = plsc->phyxma;
+    plsc->imclymax = plsc->phyyma;
+    grimage(x, y, z, nx, ny );
+  }
+  plsc->plbuf_write = plbuf_write;
+}
diff --git a/collects/plot/src/all/plcore.h b/collects/plot/src/all/plcore.h
new file mode 100644
index 0000000000..9f619ce4b4
--- /dev/null
+++ b/collects/plot/src/all/plcore.h
@@ -0,0 +1,254 @@
+/* $Id: plcore.h,v 1.1 2004/03/01 20:54:51 cozmic Exp $
+
+	Contains declarations for core plplot data structures.  This file
+	should be included only by plcore.c.
+*/
+
+#ifndef __PLCORE_H__
+#define __PLCORE_H__
+
+#include "plplotP.h"
+#include "drivers.h"
+#include "plDevs.h"
+#include "disptab.h"
+
+#ifdef ENABLE_DYNDRIVERS
+#include <ltdl.h>
+typedef lt_ptr (*PLDispatchInit)( PLDispatchTable *pdt );
+#else
+typedef void (*PLDispatchInit)( PLDispatchTable *pdt );
+#endif
+    
+
+
+/* Static function prototypes */
+
+static void	grline		(short *, short *, PLINT);
+static void	grpolyline	(short *, short *, PLINT);
+static void	grfill		(short *, short *, PLINT);
+static void	plSelectDev	(void);
+static void	pldi_ini	(void);
+static void	calc_diplt	(void);
+static void	calc_didev	(void);
+static void	calc_diori	(void);
+static void	calc_dimap	(void);
+static void	plgdevlst	(char **, char **, int *, int);
+
+static void	plInitDispatchTable	(void);
+
+static void	plLoadDriver	(void);
+
+/* Static variables */
+
+static PLINT xscl[PL_MAXPOLY], yscl[PL_MAXPOLY];
+
+static PLINT initfont = 1;	/* initial font: extended by default */
+
+static PLINT lib_initialized = 0;
+
+/*--------------------------------------------------------------------------*\
+ * Allocate a PLStream data structure (defined in plstrm.h).
+ *
+ * This struct contains a copy of every variable that is stream dependent.
+ * Only the first [index=0] stream is statically allocated; the rest
+ * are dynamically allocated when you switch streams (yes, it is legal
+ * to only initialize the first element of the array of pointers).
+\*--------------------------------------------------------------------------*/
+
+static PLStream pls0;			/* preallocated stream */
+static PLINT ipls;			/* current stream number */
+
+static PLStream *pls[PL_NSTREAMS] = {&pls0};	/* Array of stream pointers */
+
+/* Current stream pointer.  Global, for easier access to state info */
+
+PLStream *plsc = &pls0;
+
+/* Only now can we include this */
+
+#include "pldebug.h"
+
+/*--------------------------------------------------------------------------*\
+ * Initialize dispatch table.
+ *
+ * Each device is selected by the appropriate define, passed in from the
+ * makefile.  When installing plplot you may wish to exclude devices not 
+ * present on your system in order to reduce screen clutter.
+ *
+ * If you hit a <CR> in response to the plinit() prompt, you get the FIRST
+ * one active below, so arrange them accordingly for your system (i.e. all
+ * the system-specific ones should go first, since they won't appear on
+ * most systems.)
+\*--------------------------------------------------------------------------*/
+
+static PLDispatchTable **dispatch_table = 0;
+static int npldrivers = 0;
+
+static PLDispatchInit static_device_initializers[] = {
+#ifdef PLD_mac
+    plD_dispatch_init_mac8,
+    plD_dispatch_init_mac1,
+#endif
+#ifdef PLD_next
+    plD_dispatch_init_nx,
+#endif
+#ifdef PLD_os2pm
+    plD_dispatch_init_os2,
+#endif
+#if defined(PLD_xwin) && !defined(ENABLE_DYNDRIVERS)
+    plD_dispatch_init_xw,
+#endif
+#if defined(PLD_gnome) && !defined(ENABLE_DYNDRIVERS)
+    plD_dispatch_init_gnome,
+#endif
+#if defined(PLD_tk) && !defined(ENABLE_DYNDRIVERS)
+    plD_dispatch_init_tk,
+#endif
+#if defined(PLD_linuxvga) && !defined(ENABLE_DYNDRIVERS)
+    plD_dispatch_init_vga,
+#endif
+#ifdef PLD_mgr
+    plD_dispatch_init_mgr,
+#endif
+#ifdef PLD_win3
+    plD_dispatch_init_win3,
+#endif
+#if defined (_MSC_VER) && defined (VGA)         /* graphics for msc */
+    plD_dispatch_init_vga,
+#endif
+#ifdef PLD_bgi
+    plD_dispatch_init_vga,
+#endif
+#ifdef PLD_gnusvga
+    plD_dispatch_init_vga,
+#endif
+#ifdef PLD_tiff
+    plD_dispatch_init_tiff,
+#endif
+#if defined(PLD_jpg)
+    plD_dispatch_init_jpg,
+#endif
+#if defined(PLD_bmp)  && !defined(ENABLE_DYNDRIVERS)
+    plD_dispatch_init_bmp,
+#endif
+#ifdef PLD_emxvga		       /* graphics for emx+gcc */
+    plD_dispatch_init_vga,
+#endif
+#if defined(PLD_xterm) && !defined(ENABLE_DYNDRIVERS) 
+    plD_dispatch_init_xterm,
+#endif
+#if defined(PLD_tek4010) && !defined(ENABLE_DYNDRIVERS) 
+    plD_dispatch_init_tekt,
+#endif
+#if defined(PLD_tek4107) && !defined(ENABLE_DYNDRIVERS) 
+    plD_dispatch_init_tek4107t,
+#endif
+#if defined(PLD_mskermit) && !defined(ENABLE_DYNDRIVERS) 
+    plD_dispatch_init_mskermit,
+#endif
+#if defined(PLD_versaterm) && !defined(ENABLE_DYNDRIVERS) 
+    plD_dispatch_init_versaterm,
+#endif
+#if defined(PLD_vlt) && !defined(ENABLE_DYNDRIVERS) 
+    plD_dispatch_init_vlt,
+#endif
+#if defined(PLD_conex) && !defined(ENABLE_DYNDRIVERS) 
+    plD_dispatch_init_conex,
+#endif
+#if defined(PLD_dg300) && !defined(ENABLE_DYNDRIVERS)
+    plD_dispatch_init_dg,
+#endif
+#if defined(PLD_plmeta) && !defined(ENABLE_DYNDRIVERS)
+    plD_dispatch_init_plm,
+#endif
+#if defined(PLD_tek4010f) && !defined(ENABLE_DYNDRIVERS) 
+    plD_dispatch_init_tekf,
+#endif
+#if defined(PLD_tek4107f) && !defined(ENABLE_DYNDRIVERS) 
+    plD_dispatch_init_tek4107f,
+#endif
+#if defined(PLD_ps) && !defined(ENABLE_DYNDRIVERS)
+    plD_dispatch_init_psm,
+    plD_dispatch_init_psc,
+#endif
+#if defined(PLD_xfig) && !defined(ENABLE_DYNDRIVERS)
+    plD_dispatch_init_xfig,
+#endif
+#if defined(PLD_ljiip) && !defined(ENABLE_DYNDRIVERS)
+    plD_dispatch_init_ljiip,
+#endif
+#if defined(PLD_ljii) && !defined(ENABLE_DYNDRIVERS)
+    plD_dispatch_init_ljii,
+#endif
+#if defined( PLD_hp7470) && !defined(ENABLE_DYNDRIVERS)
+    plD_dispatch_init_hp7470,
+#endif
+#if defined( PLD_hp7580) && !defined(ENABLE_DYNDRIVERS)
+    plD_dispatch_init_hp7580,
+#endif
+#if defined( PLD_lj_hpgl) && !defined(ENABLE_DYNDRIVERS)
+    plD_dispatch_init_hpgl,
+#endif
+#if defined( PLD_imp) && !defined(ENABLE_DYNDRIVERS)
+    plD_dispatch_init_imp,
+#endif
+#if defined( PLD_pbm) && !defined(ENABLE_DYNDRIVERS)
+    plD_dispatch_init_pbm,
+#endif
+#if defined(PLD_png) && !defined(ENABLE_DYNDRIVERS)
+    plD_dispatch_init_png,
+#endif
+#if defined(PLD_jpeg) && !defined(ENABLE_DYNDRIVERS)
+    //plD_dispatch_init_jpeg,
+#endif
+#if defined(PLD_pstex) && !defined(ENABLE_DYNDRIVERS)
+    plD_dispatch_init_pstex,
+#endif
+#if defined(PLD_ntk) && !defined(ENABLE_DYNDRIVERS)
+    plD_dispatch_init_ntk,
+#endif
+#if defined(PLD_cgm) && !defined(ENABLE_DYNDRIVERS)
+    plD_dispatch_init_cgm,
+#endif
+#if defined(PLD_mem) && !defined(ENABLE_DYNDRIVERS)
+     plD_dispatch_init_mem,
+#endif
+#if defined(PLD_null) && !defined(ENABLE_DYNDRIVERS)
+    //plD_dispatch_init_null,
+#endif
+#if defined(PLD_tkwin) && !defined(ENABLE_DYNDRIVERS)
+    plD_dispatch_init_tkwin,
+#endif
+    NULL
+};
+
+static int nplstaticdevices = ( sizeof(static_device_initializers) /
+                                sizeof(PLDispatchInit) ) - 1;
+static int npldynamicdevices = 0;
+
+/*--------------------------------------------------------------------------*\
+ * Stuff to support the loadable device drivers.
+\*--------------------------------------------------------------------------*/
+
+#ifdef ENABLE_DYNDRIVERS
+typedef struct {
+    char *devnam;
+    char *description;
+    char *drvnam;
+    char *tag;
+    int drvidx;
+} PLLoadableDevice;
+
+typedef struct {
+    char *drvnam;
+    lt_dlhandle dlhand;
+    
+} PLLoadableDriver;
+
+static PLLoadableDevice *loadable_device_list;
+static PLLoadableDriver *loadable_driver_list;
+#endif
+
+static int nloadabledrivers = 0;
+
+#endif	/* __PLCORE_H__ */
diff --git a/collects/plot/src/all/plctrl.c b/collects/plot/src/all/plctrl.c
new file mode 100644
index 0000000000..b83ef0ed77
--- /dev/null
+++ b/collects/plot/src/all/plctrl.c
@@ -0,0 +1,1739 @@
+/* $Id: plctrl.c,v 1.3 2005/03/18 20:32:41 eli Exp $
+
+	Misc. control routines, like begin, end, exit, change graphics/text
+	mode, change color.  Includes some spillage from plcore.c.  If you
+	don't know where it should go, put it here.  
+*/
+
+#define DEBUG
+
+#define NEED_PLDEBUG
+#include "plplotP.h"
+#ifdef macintosh
+#include "mac.h"
+/* for plMacLibOpen prototype; used in plLibOpen */
+#endif
+
+#ifdef DJGPP			/* dos386/djgpp */
+#ifdef __unix
+#undef __unix
+#endif
+#endif
+
+#ifdef __unix
+#include <sys/types.h>
+#include <sys/stat.h>
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+#include <errno.h>
+#endif
+
+/* Static functions */
+
+/* Used by any external init code to suggest a path */
+MZ_DLLEXPORT
+char* plplotLibDir = 0;
+
+static void
+color_set(PLINT i, U_CHAR r, U_CHAR g, U_CHAR b, char *name );
+
+static void
+strcat_delim(char *dirspec);
+
+static int
+(*exit_handler) (char *errormsg);
+
+static void
+plcmap0_def(int imin, int imax);
+
+static void
+plcmap1_def(void);
+
+static PLFLT
+value(double n1, double n2, double hue);
+
+/* An additional hardwired location for lib files. */
+/* I have no plans to change these again, ever. */
+
+#if defined(DJGPP)
+#ifndef PLLIBDEV
+#define PLLIBDEV "c:/plplot/lib"
+#endif
+
+#elif defined(MSDOS)
+#ifndef PLLIBDEV
+#define PLLIBDEV "c:\\plplot\\lib"
+#endif
+
+#else
+
+/* Anything else is assumed to be Unix */
+
+#ifndef PLLIBDEV
+#define PLLIBDEV "/usr/local/plplot/lib"
+#endif
+
+#endif
+
+/*--------------------------------------------------------------------------*\
+ *  Routines that deal with colors & color maps.
+\*--------------------------------------------------------------------------*/
+
+/*--------------------------------------------------------------------------*\
+ * plcol0()
+ *
+ * Set color, map 0.  Argument is integer between 0 and plsc->ncol0.
+\*--------------------------------------------------------------------------*/
+
+MZ_DLLEXPORT
+void
+c_plcol0(PLINT icol0)
+{
+    if (plsc->level < 1) {
+	plabort("plcol0: Please call plinit first");
+	return;
+    }
+    if (icol0 < 0 || icol0 >= plsc->ncol0) {
+	char buffer[256];
+	sprintf(buffer, "plcol0: Invalid color map entry: %d", (int) icol0);
+	plabort(buffer);
+	return;
+    }
+
+    plsc->icol0 = icol0;
+    plsc->curcolor.r = plsc->cmap0[icol0].r;
+    plsc->curcolor.g = plsc->cmap0[icol0].g;
+    plsc->curcolor.b = plsc->cmap0[icol0].b;
+
+    plsc->curcmap = 0;
+    plP_state(PLSTATE_COLOR0);
+}
+
+/*--------------------------------------------------------------------------*\
+ * plcol1()
+ *
+ * Set color, map 1.  Argument is a float between 0. and 1.
+\*--------------------------------------------------------------------------*/
+
+void
+c_plcol1(PLFLT col1)
+{
+    PLINT icol1;
+
+    if (plsc->level < 1) {
+	plabort("plcol1: Please call plinit first");
+	return;
+    }
+    if (col1 < 0 || col1 > 1) {
+	char buffer[256];
+	sprintf(buffer, "plcol1: Invalid color map position: %f", (PLFLT) col1);
+	plabort(buffer);
+	return;
+    }
+
+    icol1 = col1 * plsc->ncol1;
+    icol1 = MIN(icol1, plsc->ncol1-1);
+
+    plsc->icol1 = icol1;
+    plsc->curcolor.r = plsc->cmap1[plsc->icol1].r;
+    plsc->curcolor.g = plsc->cmap1[plsc->icol1].g;
+    plsc->curcolor.b = plsc->cmap1[plsc->icol1].b;
+
+    plsc->curcmap = 1;
+    plP_state(PLSTATE_COLOR1);
+}
+
+/*--------------------------------------------------------------------------*\
+ * plscolbg()
+ *
+ * Set the background color (cmap0[0]) by 8 bit RGB value
+\*--------------------------------------------------------------------------*/
+
+MZ_DLLEXPORT
+void
+c_plscolbg(PLINT r, PLINT g, PLINT b)
+{
+    plscol0(0, r, g, b);
+}
+
+/*--------------------------------------------------------------------------*\
+ * plgcolbg()
+ *
+ * Returns the background color (cmap0[0]) by 8 bit RGB value
+\*--------------------------------------------------------------------------*/
+
+void
+c_plgcolbg(PLINT *r, PLINT *g, PLINT *b)
+{
+    plgcol0(0, r, g, b);
+}
+
+/*--------------------------------------------------------------------------*\
+ * plscol0()
+ *
+ * Set a given color from color map 0 by 8 bit RGB value
+ * Does not result in any additional cells to be allocated.
+\*--------------------------------------------------------------------------*/
+
+MZ_DLLEXPORT
+void
+c_plscol0(PLINT icol0, PLINT r, PLINT g, PLINT b)
+{
+    if (plsc->cmap0 == NULL)
+	plscmap0n(0);
+
+    if (icol0 < 0 || icol0 >= plsc->ncol0) {
+	char buffer[256];
+	sprintf(buffer, "plscol0: Illegal color table value: %d", (int) icol0);
+	plabort(buffer);
+	return;
+    }
+    if ((r < 0 || r > 255) || (g < 0 || g > 255) || (b < 0 || b > 255)) {
+	char buffer[256];
+	sprintf(buffer, "plscol0: Invalid RGB color: %d, %d, %d",
+		(int) r, (int) g, (int) b);
+	plabort(buffer);
+	return;
+    }
+
+    plsc->cmap0[icol0].r = r;
+    plsc->cmap0[icol0].g = g;
+    plsc->cmap0[icol0].b = b;
+
+    if (plsc->level > 0)
+	plP_state(PLSTATE_CMAP0);
+}
+
+/*--------------------------------------------------------------------------*\
+ * plgcol0()
+ *
+ * Returns 8 bit RGB values for given color from color map 0
+ * Values are negative if an invalid color id is given
+\*--------------------------------------------------------------------------*/
+
+void
+c_plgcol0(PLINT icol0, PLINT *r, PLINT *g, PLINT *b)
+{
+    if (plsc->cmap0 == NULL)
+	plscmap0n(0);
+
+    *r = -1;
+    *g = -1;
+    *b = -1;
+
+    if (icol0 < 0 || icol0 > plsc->ncol0) {
+	char buffer[256];
+	sprintf(buffer, "plgcol0: Invalid color index: %d", (int) icol0);
+	plabort(buffer);
+	return;
+    }
+
+    *r = plsc->cmap0[icol0].r;
+    *g = plsc->cmap0[icol0].g;
+    *b = plsc->cmap0[icol0].b;
+
+    return;
+}
+
+/*--------------------------------------------------------------------------*\
+ * plscmap0()
+ *
+ * Set color map 0 colors by 8 bit RGB values.  This sets the entire color
+ * map -- only as many colors as specified will be allocated.
+\*--------------------------------------------------------------------------*/
+
+void
+c_plscmap0(PLINT *r, PLINT *g, PLINT *b, PLINT ncol0)
+{
+    int i;
+
+    plscmap0n(ncol0);
+
+    for (i = 0; i < plsc->ncol0; i++) {
+	if ((r[i] < 0 || r[i] > 255) ||
+	    (g[i] < 0 || g[i] > 255) ||
+	    (b[i] < 0 || b[i] > 255)) {
+
+	    char buffer[256];
+	    sprintf(buffer, "plscmap0: Invalid RGB color: %d, %d, %d",
+		    (int) r[i], (int) g[i], (int) b[i]);
+	    plabort(buffer);
+	    return;
+	}
+
+	plsc->cmap0[i].r = r[i];
+	plsc->cmap0[i].g = g[i];
+	plsc->cmap0[i].b = b[i];
+    }
+
+    if (plsc->level > 0)
+	plP_state(PLSTATE_CMAP0);
+}
+
+/*--------------------------------------------------------------------------*\
+ * plscmap1()
+ *
+ * Set color map 1 colors by 8 bit RGB values
+ * This also sets the number of colors.
+\*--------------------------------------------------------------------------*/
+
+void
+c_plscmap1(PLINT *r, PLINT *g, PLINT *b, PLINT ncol1)
+{
+    int i;
+
+    plscmap1n(ncol1);
+
+    for (i = 0; i < plsc->ncol1; i++) {
+	if ((r[i] < 0 || r[i] > 255) ||
+	    (g[i] < 0 || g[i] > 255) ||
+	    (b[i] < 0 || b[i] > 255)) {
+
+	    char buffer[256];
+	    sprintf(buffer, "plscmap1: Invalid RGB color: %d, %d, %d",
+		    (int) r[i], (int) g[i], (int) b[i]);
+	    plabort(buffer);
+	    return;
+	}
+	plsc->cmap1[i].r = r[i];
+	plsc->cmap1[i].g = g[i];
+	plsc->cmap1[i].b = b[i];
+    }
+
+    if (plsc->level > 0)
+	plP_state(PLSTATE_CMAP1);
+}
+
+/*--------------------------------------------------------------------------*\
+ * plscmap1l()
+ *
+ * Set color map 1 colors using a piece-wise linear relationship between
+ * position in the color map (from 0 to 1) and position in HLS or RGB color
+ * space.  May be called at any time.
+ *
+ * The idea here is to specify a number of control points that specify the
+ * mapping between HLS (or RGB or CMY) and palette 1 value.  Between these
+ * points, linear interpolation is used.  By mapping position in the color
+ * map to function value, this gives a smooth variation of color with
+ * intensity.  Any number of control points may be specified, located at
+ * arbitrary positions (intensities), although typically 2 - 4 are enough.
+ * Another way of stating this is that we are traversing a given number of
+ * lines through HLS (or RGB) space as we move through cmap 1 entries.  The
+ * control points at the minimum and maximum intensity (0 and 1) must
+ * always be specified.  By adding more control points you can get more
+ * variation.  One good technique for plotting functions that vary about
+ * some expected average is to use an additional 2 control points in the
+ * center (intensity ~= 0.5) that are the same color as the background
+ * (typically white for paper output, black for crt), and same hue as the
+ * boundary control points.  This allows the highs and lows to be very
+ * easily distinguished.
+ *
+ * Each control point must specify the position in cmap 1 as well as three
+ * coordinates in HLS or RGB space.  The first point MUST correspond to
+ * position = 0, and the last to position = 1.  
+ *
+ * The hue is interpolated around the "front" of the color wheel
+ * (red<->green<->blue<->red) unless the "rev" flag is set, in which case
+ * interpolation proceeds around the back (reverse) side.  Specifying
+ * rev=NULL is equivalent to setting rev[]=0 for every control point.
+ *
+ * Bounds on RGB coordinates:
+ *	R,G,B		[0, 1]		magnitude
+ *
+ * Bounds on HLS coordinates:
+ *	hue		[0, 360]	degrees
+ *	lightness	[0, 1]		magnitude
+ *	saturation	[0, 1]		magnitude
+ *
+ * The inputs are:
+ *	itype		0: HLS, 1: RGB
+ *	npts		number of control points
+ *	pos[]		position for each control point
+ *	coord1[]	first coordinate for each control point
+ *	coord2[]	second coordinate for each control point
+ *	coord3[]	third coordinate for each control point 
+ *	rev[]		reverse flag for each control point
+\*--------------------------------------------------------------------------*/
+
+MZ_DLLEXPORT
+void
+c_plscmap1l(PLINT itype, PLINT npts, PLFLT *pos,
+	    PLFLT *coord1, PLFLT *coord2, PLFLT *coord3, PLINT *rev)
+{
+    int n;
+    PLFLT h, l, s, r, g, b;
+
+    if (npts < 2) {
+	plabort("plscmap1l: Must specify at least two control points");
+	return;
+    }
+
+    if ( (pos[0] != 0) || (pos[npts-1] != 1)) {
+	plabort("plscmap1l: First, last control points must lie on boundary");
+	return;
+    }
+
+    if ( npts > PL_MAX_CMAP1CP ) {
+	plabort("plscmap1l: exceeded maximum number of control points");
+	return;
+    }
+
+/* Allocate if not done yet */
+
+    if (plsc->cmap1 == NULL)
+	plscmap1n(0);
+
+/* Save control points */
+
+    plsc->ncp1 = npts;
+
+    for (n = 0; n < npts; n++) {
+
+	if (itype == 0) {
+	    h = coord1[n];
+	    l = coord2[n];
+	    s = coord3[n];
+	}
+	else {
+	    r = coord1[n];
+	    g = coord2[n];
+	    b = coord3[n];
+	    plRGB_HLS(r, g, b, &h, &l, &s);
+	}
+
+	plsc->cmap1cp[n].h = h;
+	plsc->cmap1cp[n].l = l;
+	plsc->cmap1cp[n].s = s;
+	plsc->cmap1cp[n].p = pos[n];
+
+	if (rev == NULL)
+	    plsc->cmap1cp[n].rev = 0;
+	else
+	    plsc->cmap1cp[n].rev = rev[n];
+    }
+
+/* Calculate and set color map */
+
+    plcmap1_calc();
+}
+
+/*--------------------------------------------------------------------------*\
+ * plcmap1_calc()
+ *
+ * Bin up cmap 1 space and assign colors to make inverse mapping easy.
+ * Always do interpolation in HLS space.
+\*--------------------------------------------------------------------------*/
+
+void
+plcmap1_calc(void)
+{
+    int i, n;
+    PLFLT delta, dp, dh, dl, ds;
+    PLFLT h, l, s, p, r, g, b;
+
+/* Loop over all control point pairs */
+
+    for (n = 0; n < plsc->ncp1-1; n++) {
+
+	if ( plsc->cmap1cp[n].p == plsc->cmap1cp[n+1].p )
+	    continue;
+
+    /* Differences in p, h, l, s between ctrl pts */
+
+	dp = plsc->cmap1cp[n+1].p - plsc->cmap1cp[n].p;
+	dh = plsc->cmap1cp[n+1].h - plsc->cmap1cp[n].h;
+	dl = plsc->cmap1cp[n+1].l - plsc->cmap1cp[n].l;
+	ds = plsc->cmap1cp[n+1].s - plsc->cmap1cp[n].s;
+
+    /* Adjust dh if we are to go around "the back side" */
+
+	if (plsc->cmap1cp[n].rev)
+	    dh = (dh > 0) ? dh-360 : dh+360;
+
+    /* Loop over all color cells.  Only interested in cells located (in */
+    /* cmap1 space)  between n_th and n+1_th control points */
+
+	for (i = 0; i < plsc->ncol1; i++) {
+	    p = (double) i / (plsc->ncol1 - 1.0);
+	    if ( (p < plsc->cmap1cp[n].p) ||
+		 (p > plsc->cmap1cp[n+1].p) )
+		continue;
+
+	/* Interpolate based on position of color cell in cmap1 space */
+
+	    delta = (p - plsc->cmap1cp[n].p) / dp;
+
+	/* Linearly interpolate to get color cell h, l, s values */
+
+	    h = plsc->cmap1cp[n].h + dh * delta;
+	    l = plsc->cmap1cp[n].l + dl * delta;
+	    s = plsc->cmap1cp[n].s + ds * delta;
+
+	    while (h >= 360.)
+		h -= 360.;
+
+	    while (h < 0.)
+		h += 360.;
+
+	    plHLS_RGB(h, l, s, &r, &g, &b);
+
+	    plsc->cmap1[i].r = MAX(0, MIN(255, (int) (256. * r)));
+	    plsc->cmap1[i].g = MAX(0, MIN(255, (int) (256. * g)));
+	    plsc->cmap1[i].b = MAX(0, MIN(255, (int) (256. * b)));
+	}
+    }
+
+    if (plsc->level > 0)
+	plP_state(PLSTATE_CMAP1);
+}
+
+/*--------------------------------------------------------------------------*\
+ * plscmap0n()
+ *
+ * Set number of colors in cmap 0, (re-)allocate cmap 0, and fill with
+ * default values for those colors not previously allocated (and less
+ * than index 15, after that you just get grey).
+ *
+ * The driver is not guaranteed to support all of these.
+\*--------------------------------------------------------------------------*/
+
+void
+c_plscmap0n(PLINT ncol0)
+{
+    int ncol, size, imin, imax;
+
+/* No change */
+
+    if (ncol0 > 0 && plsc->ncol0 == ncol0)
+	return;
+
+/* Handle all possible startup conditions */
+
+    if (plsc->ncol0 <= 0 && ncol0 <= 0)
+	ncol = 16;
+    else if (ncol0 <= 0)
+	ncol = plsc->ncol0;
+    else
+        ncol = ncol0;
+
+    imax = ncol-1;
+    size = ncol * sizeof(PLColor);
+
+/* Allocate the space */
+
+    if (plsc->cmap0 == NULL) {
+	plsc->cmap0 = (PLColor *) calloc(1, size);
+	imin = 0;
+    }
+    else {
+	plsc->cmap0 = (PLColor *) realloc(plsc->cmap0, size);
+	imin = plsc->ncol0;
+    }
+
+/* Fill in default entries */
+
+    plsc->ncol0 = ncol;
+    plcmap0_def(imin, imax);
+}
+
+/*--------------------------------------------------------------------------*\
+ * plscmap1n()
+ *
+ * Set number of colors in cmap 1, (re-)allocate cmap 1, and set default
+ * values if this is the first allocation.
+ *
+ * Note that the driver is allowed to disregard this number.
+ * In particular, most use fewer than we use internally.
+\*--------------------------------------------------------------------------*/
+
+MZ_DLLEXPORT
+void
+c_plscmap1n(PLINT ncol1)
+{
+    int ncol, size;
+
+/* No change */
+
+    if (ncol1 > 0 && plsc->ncol1 == ncol1)
+	return;
+
+/* Handle all possible startup conditions */
+
+    if (plsc->ncol1 <= 0 && ncol1 <= 0)
+	ncol = 128;
+    else if (ncol1 <= 0)
+	ncol = plsc->ncol1;
+    else
+        ncol = ncol1;
+
+    size = ncol * sizeof(PLColor);
+
+/* Allocate the space */
+
+    if (plsc->ncol1 > 0) 
+	plsc->cmap1 = (PLColor *) realloc(plsc->cmap1, size);
+    else 
+	plsc->cmap1 = (PLColor *) calloc(ncol, sizeof(PLColor));
+
+/* Fill in default entries */
+
+    plsc->ncol1 = ncol;
+    if (plsc->ncp1 == 0)
+	plcmap1_def();
+    else
+	plcmap1_calc();
+}
+
+/*--------------------------------------------------------------------------*\
+ * color_set()
+ *
+ * Initializes color table entry by RGB values.
+\*--------------------------------------------------------------------------*/
+
+static void
+color_set(PLINT i, U_CHAR r, U_CHAR g, U_CHAR b, char *name )
+{
+    plsc->cmap0[i].r = r;
+    plsc->cmap0[i].g = g;
+    plsc->cmap0[i].b = b;
+    plsc->cmap0[i].name = name;
+}
+
+/*--------------------------------------------------------------------------*\
+ * plcmap0_def()
+ *
+ * Initializes specified color map 0 color entry to its default.
+ *
+ * Initial RGB values for color map 0 taken from X11R6 
+ * (XFree86-3.3.6) X-windows 
+ * rgb.txt file, and may not accurately represent the described colors on 
+ * all systems.
+\*--------------------------------------------------------------------------*/
+
+#define color_def(i, r, g, b, n) \
+if (i >= imin && i <= imax) color_set(i, r, g, b, n);
+
+static void
+plcmap0_def(int imin, int imax)
+{
+    int i;
+
+    color_def(0,    0,   0,   0, "black" );	/* black */
+    color_def(1,  255,   0,   0, "red");	/* red */
+    color_def(2,  255, 255,   0, "yellow" );	/* yellow */
+    color_def(3,    0, 255,   0, "green" );	/* green */
+    color_def(4,  127, 255, 212, "aquamarine" );	/* aquamarine */
+    color_def(5,  255, 192, 203, "pink" );	/* pink */
+    color_def(6,  245, 222, 179, "wheat" );	/* wheat */
+    color_def(7,  190, 190, 190, "grey" );	/* grey */
+    color_def(8,  165,  42,  42, "brown" );	/* brown */
+    color_def(9,    0,   0, 255, "blue" );	/* blue */
+    color_def(10, 138,  43, 226, "BlueViolet" );	/* Blue Violet */
+    color_def(11,   0, 255, 255, "cyan" );	/* cyan */
+    color_def(12,  64, 224, 208, "turquoise" );	/* turquoise */
+    color_def(13, 255,   0, 255, "magenta" );	/* magenta */
+    color_def(14, 250, 128, 114, "salmon" );	/* salmon */
+    color_def(15, 255, 255, 255, "white" );	/* white */
+
+/* Any others are just arbitrarily set */
+
+    for (i = 16; i <= imax; i++)
+	color_def(i, 255, 0, 0, "red"); 	/* red */
+}
+
+/*--------------------------------------------------------------------------*\
+ * plcmap1_def()
+ *
+ * Initializes color map 1.
+ *
+ * The default initialization uses 6 control points in HLS space, the inner
+ * ones being very close to one of the vertices of the HLS double cone.  The
+ * vertex used (black or white) is chosen to be the closer to the background
+ * color.  The 6 points were chosen over the older 4 points in order to make 
+ * weaker structures more easily visible, and give more control through the
+ * palette editor.  If you don't like these settings.. change them!
+\*--------------------------------------------------------------------------*/
+
+static void
+plcmap1_def(void)
+{
+    PLFLT i[6], h[6], l[6], s[6], midpt = 0., vertex = 0.;
+
+/* Positions of control points */
+
+    i[0] = 0;		/* left boundary */
+    i[1] = 0.44;	/* a little left of center */
+    i[2] = 0.50;	/* at center */
+    i[3] = 0.50;	/* at center */
+    i[4] = 0.56;	/* a little right of center */
+    i[5] = 1;		/* right boundary */
+
+/* For center control points, pick black or white, whichever is closer to bg */
+/* Be carefult to pick just short of top or bottom else hue info is lost */
+
+    if (plsc->cmap0 != NULL)
+	vertex = ((PLFLT) plsc->cmap0[0].r +
+		  (PLFLT) plsc->cmap0[0].g +
+		  (PLFLT) plsc->cmap0[0].b) / 3. / 255.;
+
+    if (vertex < 0.5) {
+	vertex = 0.01;
+	midpt  = 0.10;
+    } else {
+	vertex = 0.99;
+	midpt  = 0.90;
+    }
+
+/* Set hue */
+
+    h[0] = 260;		/* low: blue-violet */
+    h[1] = 260;		/* only change as we go over vertex */
+    h[2] = 260;		/* only change as we go over vertex */
+    h[3] = 0;		/* high: red */
+    h[4] = 0;		/* high: red */
+    h[5] = 0;		/* keep fixed */
+
+/* Set lightness */
+
+    l[0] = 0.5;		/* low */
+    l[1] = midpt;	/* midpoint value */
+    l[2] = vertex;	/* bg */
+    l[3] = vertex;	/* bg */
+    l[4] = midpt;	/* midpoint value */
+    l[5] = 0.5;		/* high */
+
+/* Set saturation -- keep at maximum */
+
+    s[0] = 1;
+    s[1] = 1;
+    s[2] = 1;
+    s[3] = 1;
+    s[4] = 1;
+    s[5] = 1;
+
+    c_plscmap1l(0, 6, i, h, l, s, NULL);
+}
+
+/*--------------------------------------------------------------------------*\
+ * plscolor()
+ *
+ * Used to globally turn color output on/off
+\*--------------------------------------------------------------------------*/
+
+void
+c_plscolor(PLINT color)
+{
+    plsc->colorset = 1;
+    plsc->color = color;
+}
+
+/*--------------------------------------------------------------------------*\
+ * plrgb()
+ *
+ * Set line color by red, green, blue from  0. to 1.
+ * Do NOT use this.  Only retained for backward compatibility
+\*--------------------------------------------------------------------------*/
+
+void
+c_plrgb(PLFLT r, PLFLT g, PLFLT b)
+{
+    if (plsc->level < 1) {
+	plabort("plrgb: Please call plinit first");
+	return;
+    }
+
+    plsc->icol0 = PL_RGB_COLOR;
+    plsc->curcolor.r = MAX(0, MIN(255, (int) (256. * r)));
+    plsc->curcolor.g = MAX(0, MIN(255, (int) (256. * g)));
+    plsc->curcolor.b = MAX(0, MIN(255, (int) (256. * b)));
+
+    plsc->curcmap = 0;
+    plP_state(PLSTATE_COLOR0);
+}
+
+/*--------------------------------------------------------------------------*\
+ * plrgb1()
+ *
+ * Set line color by 8 bit RGB values.
+ * Do NOT use this.  Only retained for backward compatibility
+\*--------------------------------------------------------------------------*/
+
+void
+c_plrgb1(PLINT r, PLINT g, PLINT b)
+{
+    if (plsc->level < 1) {
+	plabort("plrgb1: Please call plinit first");
+	return;
+    }
+    if ((r < 0 || r > 255) || (g < 0 || g > 255) || (b < 0 || b > 255)) {
+	plabort("plrgb1: Invalid color");
+	return;
+    }
+
+    plsc->icol0 = PL_RGB_COLOR;
+    plsc->curcolor.r = r;
+    plsc->curcolor.g = g;
+    plsc->curcolor.b = b;
+
+    plsc->curcmap = 0;
+    plP_state(PLSTATE_COLOR0);
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plhls()
+ *
+ * Set current color by hue, lightness, and saturation.
+ * Convert hls color coordinates to rgb, then call plrgb.
+ * Do NOT use this.  Only retained for backward compatibility
+\*--------------------------------------------------------------------------*/
+
+void
+c_plhls(PLFLT h, PLFLT l, PLFLT s)
+{
+    PLFLT r, g, b;
+
+    plHLS_RGB(h, l, s, &r, &g, &b);
+    plrgb(r, g, b);
+}
+
+/*--------------------------------------------------------------------------*\
+ * void value()
+ *
+ * Auxiliary function used by plHLS_RGB().
+\*--------------------------------------------------------------------------*/
+
+static PLFLT
+value(double n1, double n2, double hue)
+{
+    PLFLT val;
+
+    while (hue >= 360.)
+	hue -= 360.;
+    while (hue < 0.)
+	hue += 360.;
+
+    if (hue < 60.)
+	val = n1 + (n2 - n1) * hue / 60.;
+    else if (hue < 180.)
+	val = n2;
+    else if (hue < 240.)
+	val = n1 + (n2 - n1) * (240. - hue) / 60.;
+    else
+	val = n1;
+
+    return (val);
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plHLS_RGB()
+ *
+ * Convert HLS color to RGB color.
+ * Bounds on HLS (input):
+ *	hue		[0., 360.]	degrees
+ *	lightness	[0., 1.]	magnitude
+ *	saturation	[0., 1.]	magnitude
+ *
+ * Hue is always mapped onto the interval [0., 360.] regardless of input.
+ * Bounds on RGB (output) is always [0., 1.].  Convert to RGB color values
+ * by multiplying by 2**nbits (nbits typically 8).
+\*--------------------------------------------------------------------------*/
+
+void
+plHLS_RGB(PLFLT h, PLFLT l, PLFLT s, PLFLT *p_r, PLFLT *p_g, PLFLT *p_b)
+{
+    PLFLT m1, m2;
+
+    if (l <= .5)
+	m2 = l * (s + 1.);
+    else
+	m2 = l + s - l * s;
+
+    m1 = 2 * l - m2;
+
+    *p_r = value(m1, m2, h + 120.);
+    *p_g = value(m1, m2, h);
+    *p_b = value(m1, m2, h - 120.);
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plRGB_HLS()
+ *
+ * Convert RGB color to HLS color.
+ * Bounds on RGB (input) is always [0., 1.].  
+ * Bounds on HLS (output):
+ *	hue		[0., 360.]	degrees
+ *	lightness	[0., 1.]	magnitude
+ *	saturation	[0., 1.]	magnitude
+\*--------------------------------------------------------------------------*/
+
+void
+plRGB_HLS(PLFLT r, PLFLT g, PLFLT b, PLFLT *p_h, PLFLT *p_l, PLFLT *p_s)
+{
+    PLFLT h, l, s, d, rc, gc, bc, rgb_min, rgb_max;
+
+    rgb_min = MIN( r, MIN( g, b ));
+    rgb_max = MAX( r, MAX( g, b ));
+
+    l = (rgb_min+rgb_max) / 2.0;
+
+    if (rgb_min == rgb_max) {
+	s = 0;
+	h = 0;
+    } 
+    else {
+	d = rgb_max - rgb_min;
+	if (l < 0.5)
+	    s = 0.5 * d / l;
+	else 
+	    s = 0.5* d / (1.-l);
+
+	rc = (rgb_max-r) / d;
+	gc = (rgb_max-g) / d;
+	bc = (rgb_max-b) / d;
+
+	if (r == rgb_max)
+	    h = bc-gc;
+	else if (g == rgb_max)
+	    h = rc-bc+2;
+	else
+	    h = gc-rc-2;
+
+	h = h*60;
+	if (h <  0)
+	    h = h+360;
+	else if (h >= 360)
+	    h = h-360;
+    }
+    *p_h = h;
+    *p_l = l;
+    *p_s = s;
+}
+
+/*--------------------------------------------------------------------------*\
+ * A grab-bag of various control routines.
+\*--------------------------------------------------------------------------*/
+
+/*--------------------------------------------------------------------------*\
+ * void plwarn()
+ *
+ * A handy way to issue warnings, if need be.
+\*--------------------------------------------------------------------------*/
+
+void
+plwarn(char *errormsg)
+{
+    int was_gfx = 0;
+
+    if (plsc->graphx == 1) {
+	was_gfx = 1;
+	pltext();
+    }
+
+    fprintf(stderr, "\n*** PLPLOT WARNING ***\n");
+    if (*errormsg != '\0')
+	fprintf(stderr, "%s\n", errormsg);
+
+    if (was_gfx == 1)
+	plgra();
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plabort()
+ *
+ * Much the same as plwarn(), but appends ", aborting operation" to the
+ * error message.  Helps to keep source code uncluttered and provides a
+ * convention for error aborts.
+\*--------------------------------------------------------------------------*/
+
+void
+plabort(char *errormsg)
+{
+    if (plsc->errcode != NULL)
+	*(plsc->errcode) = 1;
+
+    if (plsc->errmsg != NULL) {
+	sprintf(plsc->errmsg, "\n*** PLPLOT ERROR ***\n");
+	if (*errormsg != '\0')
+	    sprintf(plsc->errmsg, "%s, aborting operation\n", errormsg);
+
+    } else {
+	int was_gfx = 0;
+
+	if (plsc->graphx == 1) {
+	    was_gfx = 1;
+	    pltext();
+	}
+
+	fprintf(stderr, "\n*** PLPLOT ERROR ***\n");
+	if (*errormsg != '\0')
+	    fprintf(stderr, "%s, aborting operation\n", errormsg);
+
+	if (was_gfx == 1)
+	    plgra();
+    }
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plexit()
+ *
+ * In case of an abort this routine is called.  It just prints out an error
+ * message and tries to clean up as much as possible.  It's best to turn
+ * off pause and then restore previous setting before returning.
+ *
+ * If cleanup needs to be done in the main program, the user should write
+ * his/her own exit handler and pass it in via plsexit().  This function
+ * should should either call plend() before exiting, or simply return.
+\*--------------------------------------------------------------------------*/
+
+void
+plexit(char *errormsg)
+{
+    int status = 1;
+
+    if (exit_handler != NULL)
+	status = (*exit_handler)(errormsg);
+
+    plsc->nopause = 1;
+    if (*errormsg != '\0') {
+	fprintf(stderr, "\n*** PLPLOT ERROR ***\n");
+	fprintf(stderr, "%s\n", errormsg);
+    }
+    plend();
+
+    fprintf(stderr, "Program aborted\n");
+    exit(status);
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plsexit()
+ *
+ * Sets an optional user exit handler.
+\*--------------------------------------------------------------------------*/
+
+void
+plsexit(int (*handler) (char *))
+{
+    exit_handler = handler;
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plgra()
+ *
+ * Switches to graphics screen.  
+ *
+ * Here and in pltext() it's a good idea to return silently if plinit()
+ * hasn't yet been called, since plwarn() calls pltext() and plgra(), and
+ * plwarn() may be called at any time.
+\*--------------------------------------------------------------------------*/
+
+void
+c_plgra(void)
+{
+    if (plsc->level > 0)
+	plP_esc(PLESC_GRAPH, NULL);
+}
+
+void
+c_plxormod(PLINT mode, PLINT *status)	/* xor mode */
+{
+  static int ostate = 0;
+
+  if (!plsc->dev_xor) {
+    *status = 0;
+    return;
+  }
+
+  if (plsc->level > 0) {
+    plP_esc(PLESC_XORMOD, &mode);
+    if (mode) {
+      ostate = plsc->plbuf_write;
+      plsc->plbuf_write = 0;
+    } else
+      plsc->plbuf_write = ostate;
+  } 
+  *status = 1;
+}
+
+/*--------------------------------------------------------------------------*\
+ * void pltext()
+ *
+ * Switches to text screen.
+\*--------------------------------------------------------------------------*/
+
+void
+c_pltext(void)
+{
+    if (plsc->level > 0)
+	plP_esc(PLESC_TEXT, NULL);
+}
+
+/*--------------------------------------------------------------------------*\
+ * void pl_cmd()
+ *
+ * Front-end to driver escape function.
+ * In principle this can be used to pass just about anything directly
+ * to the driver.
+\*--------------------------------------------------------------------------*/
+
+void
+pl_cmd(PLINT op, void *ptr)
+{
+    plP_esc(op, ptr);
+}
+
+/*--------------------------------------------------------------------------*\
+ * char *plFindCommand
+ *
+ * Looks for the specified executable file.  Search path:
+ *	PLPLOT_BIN_ENV = $(PLPLOT_BIN)
+ *	current directory
+ *	PLPLOT_HOME_ENV/bin = $(PLPLOT_HOME)/bin
+ *	BIN_DIR
+ *
+ * The caller must free the returned pointer (points to malloc'ed memory)
+ * when finished with it.
+\*--------------------------------------------------------------------------*/
+
+char *
+plFindCommand(char *fn)
+{
+    char *fs = NULL, *dn;
+
+/* PLPLOT_BIN_ENV = $(PLPLOT_BIN) */
+
+#if defined(PLPLOT_BIN_ENV)
+    if ((dn = getenv(PLPLOT_BIN_ENV)) != NULL) {
+        plGetName(dn, "", fn, &fs);
+        if ( ! plFindName(fs))
+            return fs;
+        fprintf(stderr, PLPLOT_BIN_ENV"=\"%s\"\n", dn); /* what IS set? */
+    }
+#endif  /* PLPLOT_BIN_ENV */
+
+/* Current directory */
+
+    plGetName(".", "", fn, &fs);
+    if ( ! plFindName(fs))
+	return fs;
+
+/* PLPLOT_HOME_ENV/bin = $(PLPLOT_HOME)/bin */
+
+#if defined(PLPLOT_HOME_ENV)
+    if ((dn = getenv(PLPLOT_HOME_ENV)) != NULL) {
+        plGetName(dn, "bin", fn, &fs);
+        if ( ! plFindName(fs))
+            return fs;
+        fprintf(stderr, PLPLOT_HOME_ENV"=\"%s\"\n",dn); /* what IS set? */
+    }
+#endif  /* PLPLOT_HOME_ENV */
+
+/* BIN_DIR */
+
+#if defined (BIN_DIR)
+    plGetName(BIN_DIR, "", fn, &fs);
+    if ( ! plFindName(fs))
+	return fs;
+#endif
+
+/* Crapped out */
+
+    free_mem(fs);
+    fprintf(stderr, "plFindCommand: cannot locate command: %s\n", fn);
+#if defined (BIN_DIR)
+    fprintf(stderr, "bin dir=\"" BIN_DIR "\"\n" );      /* what WAS set? */
+#endif  /* BIN_DIR */
+    return NULL;
+}
+
+/*--------------------------------------------------------------------------*\
+ * FILE *plLibOpen(fn)
+ *
+ * Return file pointer to lib file.
+ * Locations checked:
+ *	PLPLOT_LIB_ENV = $(PLPLOT_LIB)
+ *	current directory
+ *	PLPLOT_HOME_ENV/lib = $(PLPLOT_HOME)/lib
+ *	DATA_DIR
+ *	PLLIBDEV
+\*--------------------------------------------------------------------------*/
+
+FILE *
+plLibOpen(char *fn)
+{
+    FILE *ret = NULL;
+    
+    PDFstrm *pdfs = plLibOpenPdfstrm(fn);
+    if (pdfs == NULL) {
+        return NULL;
+    }
+    if (pdfs->file != NULL) {
+        ret = pdfs->file;
+	pdfs->file = NULL;
+    }
+    pdf_close(pdfs);
+    return ret;
+}
+
+PDFstrm *
+plLibOpenPdfstrm(char *fn)
+{
+    PDFstrm *file;
+    char *fs = NULL, *dn = NULL;
+
+/****	search PLPLOT_LIB_ENV = $(PLPLOT_LIB)	****/
+
+#if defined(PLPLOT_LIB_ENV)
+    if ((dn = getenv(PLPLOT_LIB_ENV)) != NULL) {
+        plGetName(dn, "", fn, &fs);
+
+        if ((file = pdf_fopen(fs, "rb")) != NULL)
+            goto done;
+
+        fprintf(stderr, PLPLOT_LIB_ENV"=\"%s\"\n", dn); /* what IS set? */
+    }
+#endif  /* PLPLOT_LIB_ENV */
+
+/****	search current directory	****/
+
+    if ((file = pdf_fopen(fn, "rb")) != NULL)
+        goto done;
+
+/****	search PLPLOT_HOME_ENV/lib = $(PLPLOT_HOME)/lib	****/
+
+#if defined (PLPLOT_HOME_ENV)
+    if ((dn = getenv(PLPLOT_HOME_ENV)) != NULL) {
+        plGetName(dn, "lib", fn, &fs);
+
+        if ((file = pdf_fopen(fs, "rb")) != NULL)
+            goto done;
+        fprintf(stderr, PLPLOT_HOME_ENV"=\"%s\"\n",dn); /* what IS set? */
+    }
+#endif  /* PLPLOT_HOME_ENV/lib */
+
+/**** 	search installed location	****/
+
+#if defined (DATA_DIR)
+    plGetName(DATA_DIR, "", fn, &fs);
+
+    if ((file = pdf_fopen(fs, "rb")) != NULL)
+        goto done;
+#endif  /* DATA_DIR */
+
+/**** 	search hardwired location	****/
+
+#ifdef PLLIBDEV
+    plGetName(PLLIBDEV, "", fn, &fs);
+
+    if ((file = pdf_fopen(fs, "rb")) != NULL)
+	goto done;
+#endif	/* PLLIBDEV */
+
+#ifdef macintosh
+    file = plMacLibOpen(fn);
+    if (file != NULL)
+        goto done;
+#endif /* macintosh */
+
+    if (plplotLibDir != NULL) {
+	plGetName(plplotLibDir, "", fn, &fs);
+	if ((file = pdf_fopen(fs, "rb")) != NULL)
+	    goto done;
+
+    }
+    
+/**** 	not found, give up 	****/
+
+    return NULL;
+
+ done:
+    free_mem(fs);
+    return (file);
+}
+
+/*--------------------------------------------------------------------------*\
+ * int plFindName
+ *
+ * Authors: Paul Dubois (LLNL), others?
+ * This function is in the public domain.
+ *
+ * Given a pathname, determine if it is a symbolic link.  If so, continue
+ * searching to the ultimate terminus - there may be more than one link.
+ * Use the error value to determine when the terminus is reached, and to
+ * determine if the pathname really exists.  Then stat it to determine
+ * whether it's executable.  Return 0 for an executable, errno otherwise.
+ * Note that 'p' _must_ have at least one '/' character - it does by
+ * construction in this program.  The contents of the array pointed to by
+ * 'p' are changed to the actual pathname if findname is successful.
+ *
+ * This function is only defined under Unix for now.
+\*--------------------------------------------------------------------------*/
+
+#ifdef do_not_do // changed, this is unnessisary in this build anyway
+int 
+plFindName(char *p)
+{
+    int n;
+    char buf[1024], *cp;
+    extern int errno;
+    struct stat sbuf;
+
+    pldebug("plFindName", "Trying to find %s\n", p);
+    while ((n = readlink(p, buf, 1024)) > 0) {
+	pldebug("plFindName", "Readlink read %d chars at: %s\n", n, p);
+	if (buf[0] == '/') {
+	/* Link is an absolute path */
+
+	    strncpy(p, buf, n);
+	    p[n] = '\0';
+	    pldebug("plFindName", "Link is absolute: %s\n", p);
+	}
+	else {
+	/* Link is relative to its directory; make it absolute */
+
+	    cp = 1 + strrchr(p, '/');
+	    strncpy(cp, buf, n);
+	    cp[n] = '\0';
+	    pldebug("plFindName",
+		    "Link is relative: %s\n\tTotal path:%s\n", cp, p);
+	}
+    }
+
+/* This macro not defined on the NEC SX-3 */
+
+#ifdef SX
+#define S_ISREG(mode)   (mode & S_IFREG)
+#endif
+
+/* SGI machines return ENXIO instead of EINVAL Dubois 11/92 */
+
+    if (errno == EINVAL || errno == ENXIO) {
+	pldebug("plFindName", "%s may be the one...\n", p);
+	if ((stat(p, &sbuf) == 0) && S_ISREG(sbuf.st_mode)) {
+	    pldebug("plFindName", "%s is a regular file\n", p);
+	    return (access(p, X_OK));
+	}
+    }
+    pldebug("plFindName", "%s found but is not executable\n", p);
+    return (errno ? errno : -1);
+}
+
+#else
+int 
+plFindName(char *p)
+{
+    return 1;
+}
+#endif
+
+/*--------------------------------------------------------------------------*\
+ * void plGetName()
+ *
+ * Gets search name for file by concatenating the dir, subdir, and file
+ * name, allocating memory as needed.  The appropriate delimiter is added
+ * after the dir specification as necessary.  The caller is responsible
+ * for freeing the malloc'ed memory.
+\*--------------------------------------------------------------------------*/
+
+void
+plGetName(char *dir, char *subdir, char *filename, char **filespec)
+{
+    int lfilespec;
+
+/* Malloc space for filespec */
+
+    free_mem(*filespec);
+    lfilespec = 10;
+    lfilespec = strlen(dir) + strlen(subdir) + strlen(filename) + 10;
+    *filespec = (char *) malloc(lfilespec);
+
+    strcpy(*filespec, dir);
+
+    if (*subdir != '\0') {
+	strcat_delim(*filespec);
+	strcat(*filespec, subdir);
+    }
+    if (*filename != '\0') {
+	strcat_delim(*filespec);
+	strcat(*filespec, filename);
+    }
+}
+
+/*--------------------------------------------------------------------------*\
+ * void strcat_delim()
+ *
+ * Append path name deliminator if necessary (does not add one if one's
+ * there already, or if dealing with a colon-terminated device name).
+\*--------------------------------------------------------------------------*/
+
+static void
+strcat_delim(char *dirspec)
+{
+    int ldirspec = strlen(dirspec);
+#if defined (MSDOS)
+    if (dirspec[ldirspec-1] != '\\')
+	strcat(dirspec, "\\");
+#elif defined (macintosh)
+    if (dirspec[ldirspec-1] != ':')
+        strcat(dirspec, ":");
+#else           /* unix is the default */
+    if (dirspec[ldirspec-1] != '/')
+	strcat(dirspec, "/");
+#endif
+}
+
+/*--------------------------------------------------------------------------*\
+ * plcol_interp()
+ *
+ * Initializes device cmap 1 entry by interpolation from pls->cmap1
+ * entries.  Returned PLColor is supposed to represent the i_th color
+ * out of a total of ncol colors in the current color scheme.
+\*--------------------------------------------------------------------------*/
+
+void
+plcol_interp(PLStream *pls, PLColor *newcolor, int i, int ncol)
+{
+    PLFLT x, delta;
+    int il, ir;
+
+    x = (double) (i * (pls->ncol1-1)) / (double) (ncol-1);
+    il = x;
+    ir = il + 1;
+    delta = x - il;
+
+    if (ir > pls->ncol1 || il < 0)
+	fprintf(stderr, "Invalid color\n");
+
+    else if (ir == pls->ncol1 || (delta == 0.)) {
+	newcolor->r = pls->cmap1[il].r;
+	newcolor->g = pls->cmap1[il].g;
+	newcolor->b = pls->cmap1[il].b;
+    }
+    else {
+	newcolor->r = (1.-delta) * pls->cmap1[il].r + delta * pls->cmap1[ir].r;
+	newcolor->g = (1.-delta) * pls->cmap1[il].g + delta * pls->cmap1[ir].g;
+	newcolor->b = (1.-delta) * pls->cmap1[il].b + delta * pls->cmap1[ir].b;
+    }
+}
+
+/*--------------------------------------------------------------------------*\
+ * plOpenFile()
+ *
+ * Opens file for output, prompting if not set.
+ * Prints extra newline at end to make output look better in batch runs.
+ * A file name of "-" indicates output to stdout.
+\*--------------------------------------------------------------------------*/
+
+#define MAX_NUM_TRIES	10
+void
+plOpenFile(PLStream *pls)
+{
+    int i = 0, count = 0;
+    size_t len;
+    char line[256];
+
+    while (pls->OutFile == NULL) {
+
+/* Setting pls->FileName = NULL forces creation of a new family member */
+/* You should also free the memory associated with it if you do this */
+
+	if (pls->family && pls->BaseName != NULL)
+	    plP_getmember(pls);
+
+/* Prompt if filename still not known */
+
+	if (pls->FileName == NULL) {
+	    do {
+		fprintf(stdout, "Enter graphics output file name: ");
+		fgets(line, sizeof(line), stdin);
+		len = strlen(line);
+		if (len)
+		    len--;
+		line[len] = '\0';	/* strip new-line */
+		count++;		/* count zero entries */
+	    } while (!len && count < MAX_NUM_TRIES);
+	    plP_sfnam(pls, line);
+	}
+
+/* If name is "-", send to stdout */
+
+	if ( ! strcmp(pls->FileName, "-")) {
+	    pls->OutFile = stdout;
+	    pls->output_type = 1;
+	    break;
+	}
+
+/* Need this here again, for prompted family initialization */
+
+	if (pls->family && pls->BaseName != NULL) 
+	    plP_getmember(pls);
+
+	if (i++ > 10)
+	    plexit("Too many tries.");
+
+	if ((pls->OutFile = fopen(pls->FileName, "wb+")) == NULL) 
+	    fprintf(stdout, "Can't open %s.\n", pls->FileName);
+	else
+	  {
+//	    fprintf(stderr, "Opened %s\n", pls->FileName);
+// 	    this is not needed
+	  }
+    }
+}
+
+/*--------------------------------------------------------------------------*\
+ * plP_getmember()
+ *
+ * Sets up next file member name (in pls->FileName), but does not open it.
+\*--------------------------------------------------------------------------*/
+
+void
+plP_getmember(PLStream *pls)
+{
+    char tmp[256];
+
+    if (pls->FileName == NULL)
+	pls->FileName = (char *) malloc(10 + strlen(pls->BaseName));
+
+    sprintf(tmp, "%s.%%0%1ii", pls->BaseName, (int) pls->fflen);
+    sprintf(pls->FileName, tmp, pls->member);
+}
+
+/*--------------------------------------------------------------------------*\
+ * plP_sfnam()
+ *
+ * Sets up file name & family stem name.
+ * Reserve some extra space (5 chars) to hold an optional member number.
+\*--------------------------------------------------------------------------*/
+
+void
+plP_sfnam(PLStream *pls, const char *fnam)
+{
+    pls->OutFile = NULL;
+
+    if (pls->FileName != NULL)
+	free((void *) pls->FileName);
+
+    pls->FileName = (char *) malloc(10 + strlen(fnam));
+
+    strcpy(pls->FileName, fnam);
+
+    if (pls->BaseName != NULL)
+	free((void *) pls->BaseName);
+
+    pls->BaseName = (char *) malloc(10 + strlen(fnam));
+
+    strcpy(pls->BaseName, fnam);
+}
+
+/*--------------------------------------------------------------------------*\
+ * plFamInit()
+ *
+ * Initializes family file parameters.
+\*--------------------------------------------------------------------------*/
+
+void
+plFamInit(PLStream *pls)
+{
+    if (pls->family) {
+	pls->bytecnt = 0;
+	if ( ! pls->member)
+	    pls->member = 1;
+	if ( ! pls->finc)
+	    pls->finc = 1;
+	if ( ! pls->fflen)
+	    pls->fflen = 1;
+	if ( ! pls->bytemax)
+	    pls->bytemax = PL_FILESIZE_KB * 1000;
+    }
+}
+
+/*--------------------------------------------------------------------------*\
+ * plGetFam()
+ *
+ * Starts new member file of family file set if necessary.
+ *
+ * Note each member file is a complete graphics file (can be printed
+ * individually), although 'plrender' will treat a family as a single
+ * logical file if given the family name instead of the member name.
+\*--------------------------------------------------------------------------*/
+
+void
+plGetFam(PLStream *pls)
+{
+    PLFLT xpmm_loc, ypmm_loc;
+    if (pls->family) {
+	if (pls->bytecnt > pls->bytemax || pls->famadv) {
+	    plP_tidy();
+	    pls->member += pls->finc;
+	    pls->famadv = 0;
+	    plP_init();
+	   /* Apply compensating factor to original xpmm and ypmm so that 
+	    * character aspect ratio is preserved when overall aspect ratio
+	    * is changed. */
+	    plP_gpixmm(&xpmm_loc, &ypmm_loc);
+	    plP_setpxl(xpmm_loc*plsc->caspfactor, ypmm_loc/plsc->caspfactor); 
+	    return;
+	}
+    }
+}
+
+/*--------------------------------------------------------------------------*\
+ * plRotPhy()
+ *
+ * Rotates physical coordinates if necessary for given orientation.
+ * Each time orient is incremented, the plot is rotated 90 deg clockwise.
+ * Note: this is now used only to rotate by 90 degrees for devices that
+ * expect portrait mode.
+\*--------------------------------------------------------------------------*/
+
+void
+plRotPhy(PLINT orient, PLINT xmin, PLINT ymin, PLINT xmax, PLINT ymax,
+	 int *px, int *py)
+{
+    int x, y;
+
+    x = *px;
+    y = *py;
+
+    switch (orient%4) {
+
+    case 1:
+	*px = xmin + (y - ymin);
+	*py = ymin + (xmax - x);
+	break;
+
+    case 2:
+	*px = xmin + (xmax - x);
+	*py = ymin + (ymax - y);
+	break;
+
+    case 3:
+	*px = xmin + (ymax - y);
+	*py = ymin + (x - xmin);
+	break;
+
+    default:
+	break;			/* do nothing */
+    }
+}
+
+/*--------------------------------------------------------------------------*\
+ * plAllocDev()
+ *
+ * Allocates a standard PLDev structure for device-specific data, stores
+ * the address in pls->dev, and returns the address as well.
+\*--------------------------------------------------------------------------*/
+
+PLDev *
+plAllocDev(PLStream *pls)
+{
+    if (pls->dev != NULL)
+	free((void *) pls->dev);
+
+    pls->dev = calloc(1, (size_t) sizeof(PLDev));
+    if (pls->dev == NULL)
+	plexit("plAllocDev: cannot allocate memory\n");
+
+    return (PLDev *) pls->dev;
+}
+
+/*--------------------------------------------------------------------------*\
+ * plGinInit()
+ *
+ * Just fills in the PLGraphicsIn with appropriate initial values.
+\*--------------------------------------------------------------------------*/
+
+void
+plGinInit(PLGraphicsIn *gin)
+{
+    gin->type = 0;
+    gin->state = 0;
+    gin->keysym = 0;
+    gin->button = 0;
+    gin->string[0] = '\0';
+    gin->pX = gin->pY = -1;
+    gin->dX = gin->dY = 0.;
+    gin->wX = gin->wY = 0.;
+}
+
+/*--------------------------------------------------------------------------*\
+ * plGetInt()
+ *
+ * Prompts human to input an integer in response to given message.
+\*--------------------------------------------------------------------------*/
+
+PLINT
+plGetInt(char *s)
+{
+    int m;
+    int i = 0;
+    char line[256];
+
+    while (i++ < 10) {
+	fprintf(stdout, s);
+	fgets(line, sizeof(line), stdin);
+#ifdef MSDOS
+	m = atoi(line);
+	return (m);
+#else
+	if (sscanf(line, "%d", &m) == 1)
+	    return (m);
+	fprintf(stdout, "No value or value out of range; please try again\n");
+#endif
+    }
+    plexit("Too many tries.");
+    return (0);
+}
+
+/*--------------------------------------------------------------------------*\
+ * plGetFlt()
+ *
+ * Prompts human to input a float in response to given message.
+\*--------------------------------------------------------------------------*/
+
+PLFLT
+plGetFlt(char *s)
+{
+    PLFLT m;
+    double m1;
+    int i = 0;
+    char line[256];
+
+    while (i++ < 10) {
+	fprintf(stdout, s);
+	fgets(line, sizeof(line), stdin);
+#ifdef MSDOS
+	m = atof(line);
+	return (m);
+#else
+	if (sscanf(line, "%lf", &m1) == 1) {
+	    m = (PLFLT) m1;
+	    return (m);
+	}
+	fprintf(stdout, "No value or value out of range; please try again\n");
+#endif
+    }
+    plexit("Too many tries.");
+    return (0.);
+}
+
+/*--------------------------------------------------------------------------*\
+ * plstrdup()
+ *
+ * A replacement for strdup(), which isn't portable.
+ * Caller responsible for freeing the allocated memory.
+\*--------------------------------------------------------------------------*/
+
+char *
+plstrdup(const char *src)
+{
+    char *dest = (char *) malloc( (strlen(src) + 1) * sizeof(char) );
+    if (dest != NULL)
+	strcpy(dest, src);
+    else
+	plabort("Out of memory");
+
+    return dest;
+}
+ 
diff --git a/collects/plot/src/all/plcvt.c b/collects/plot/src/all/plcvt.c
new file mode 100644
index 0000000000..9b99c453fd
--- /dev/null
+++ b/collects/plot/src/all/plcvt.c
@@ -0,0 +1,205 @@
+/* $Id: plcvt.c,v 1.1 2004/03/01 20:54:51 cozmic Exp $
+
+	Coordinate transformation routines.
+*/
+
+#include "plplotP.h"
+
+/*--------------------------------------------------------------------------*\
+ * Transformations returning physical coordinates.
+\*--------------------------------------------------------------------------*/
+
+/* device coords to physical coords (x) */
+
+PLINT
+plP_dcpcx(PLFLT x)
+{
+    return (ROUND(plsc->phyxmi + plsc->phyxlen * x));
+}
+
+/* device coords to physical coords (y) */
+
+PLINT
+plP_dcpcy(PLFLT y)
+{
+    return (ROUND(plsc->phyymi + plsc->phyylen * y));
+}
+
+/* millimeters from bottom left-hand corner to physical coords (x) */
+
+PLINT
+plP_mmpcx(PLFLT x)
+{
+    return (ROUND(plsc->phyxmi + plsc->xpmm * x));
+}
+
+/* millimeters from bottom left-hand corner to physical coords (y) */
+
+PLINT
+plP_mmpcy(PLFLT y)
+{
+    return (ROUND(plsc->phyymi + plsc->ypmm * y));
+}
+
+/* world coords to physical coords (x) */
+
+PLINT
+plP_wcpcx(PLFLT x)
+{
+    return (ROUND(plsc->wpxoff + plsc->wpxscl * x));
+}
+
+/* world coords to physical coords (y) */
+
+PLINT
+plP_wcpcy(PLFLT y)
+{
+    return (ROUND(plsc->wpyoff + plsc->wpyscl * y));
+}
+
+/*--------------------------------------------------------------------------*\
+ * Transformations returning device coordinates.
+\*--------------------------------------------------------------------------*/
+
+/* physical coords to device coords (x) */
+
+PLFLT
+plP_pcdcx(PLINT x)
+{
+    return (PLFLT) ((x - plsc->phyxmi) / (double) plsc->phyxlen);
+}
+
+/* physical coords to device coords (y) */
+
+PLFLT
+plP_pcdcy(PLINT y)
+{
+    return (PLFLT) ((y - plsc->phyymi) / (double) plsc->phyylen);
+}
+
+/* millimeters from bottom left corner to device coords (x) */
+
+PLFLT
+plP_mmdcx(PLFLT x)
+{
+    return ((PLFLT) (x * plsc->xpmm / ABS(plsc->phyxma - plsc->phyxmi)));
+}
+
+/* millimeters from bottom left corner to device coords (y) */
+
+PLFLT
+plP_mmdcy(PLFLT y)
+{
+    return ((PLFLT) (y * plsc->ypmm / ABS(plsc->phyyma - plsc->phyymi)));
+}
+
+/* world coords into device coords (x) */
+
+PLFLT
+plP_wcdcx(PLFLT x)
+{
+    return ((PLFLT) (plsc->wdxoff + plsc->wdxscl * x));
+}
+
+/* world coords into device coords (y) */
+
+PLFLT
+plP_wcdcy(PLFLT y)
+{
+    return ((PLFLT) (plsc->wdyoff + plsc->wdyscl * y));
+}
+
+/* subpage coords to device coords (x) */
+
+PLFLT
+plP_scdcx(PLFLT x)
+{
+    return ((PLFLT) (plsc->spdxmi + (plsc->spdxma - plsc->spdxmi) * x));
+}
+
+/* subpage coords to device coords (y) */
+
+PLFLT
+plP_scdcy(PLFLT y)
+{
+    return ((PLFLT) (plsc->spdymi + (plsc->spdyma - plsc->spdymi) * y));
+}
+
+/*--------------------------------------------------------------------------*\
+ * Transformations returning millimeters.
+\*--------------------------------------------------------------------------*/
+
+/* device coords to millimeters from bottom left-hand corner (x) */
+
+PLFLT
+plP_dcmmx(PLFLT x)
+{
+    return ((PLFLT) (x * ABS(plsc->phyxma - plsc->phyxmi) / plsc->xpmm));
+}
+
+/* device coords to millimeters from bottom left-hand corner (y) */
+
+PLFLT
+plP_dcmmy(PLFLT y)
+{
+    return ((PLFLT) (y * ABS(plsc->phyyma - plsc->phyymi) / plsc->ypmm));
+}
+
+/* world coords into millimeters (x) */
+
+PLFLT
+plP_wcmmx(PLFLT x)
+{
+    return ((PLFLT) (plsc->wmxoff + plsc->wmxscl * x));
+}
+
+/* world coords into millimeters (y) */
+
+PLFLT
+plP_wcmmy(PLFLT y)
+{
+    return ((PLFLT) (plsc->wmyoff + plsc->wmyscl * y));
+}
+
+/*--------------------------------------------------------------------------*\
+ * Transformations returning subpage coordinates.
+\*--------------------------------------------------------------------------*/
+
+/* device coords to subpage coords (x) */
+
+PLFLT
+plP_dcscx(PLFLT x)
+{
+    return ((PLFLT) ((x - plsc->spdxmi) / (plsc->spdxma - plsc->spdxmi)));
+}
+
+/* device coords to subpage coords (y) */
+
+PLFLT
+plP_dcscy(PLFLT y)
+{
+    return ((PLFLT) ((y - plsc->spdymi) / (plsc->spdyma - plsc->spdymi)));
+}
+
+/*--------------------------------------------------------------------------*\
+ * 3-d plot transformations.
+\*--------------------------------------------------------------------------*/
+
+/* 3-d coords to 2-d projection (x) */
+
+PLFLT
+plP_w3wcx(PLFLT x, PLFLT y, PLFLT z)
+{
+    return ((PLFLT) ((x - plsc->basecx) * plsc->cxx +
+		     (y - plsc->basecy) * plsc->cxy));
+}
+
+/* 3-d coords to 2-d projection (y) */
+
+PLFLT
+plP_w3wcy(PLFLT x, PLFLT y, PLFLT z)
+{
+    return ((PLFLT) ((x - plsc->basecx) * plsc->cyx +
+		     (y - plsc->basecy) * plsc->cyy +
+		     (z - plsc->ranmi) * plsc->cyz));
+}
diff --git a/collects/plot/src/all/pldebug.h b/collects/plot/src/all/pldebug.h
new file mode 100644
index 0000000000..fb358efb8d
--- /dev/null
+++ b/collects/plot/src/all/pldebug.h
@@ -0,0 +1,91 @@
+/* $Id: pldebug.h,v 1.1 2004/03/01 20:54:51 cozmic Exp $
+
+    Copyright (C) 1995 by Maurice J. LeBrun
+
+    Debugging support for PLplot.
+
+    This software may be freely copied, modified and redistributed without
+    fee provided that this copyright notice is preserved intact on all
+    copies and modified copies. 
+ 
+    There is no warranty or other guarantee of fitness of this software.
+    It is provided solely "as is". The author(s) disclaim(s) all
+    responsibility and liability with respect to this software's usage or
+    its effect upon hardware or computer systems. 
+*/
+
+#ifndef __PLDEBUG_H__
+#define __PLDEBUG_H__
+
+#include <stdarg.h>
+
+/* For the truly desperate debugging task */
+
+#ifdef DEBUG_ENTER
+#define dbug_enter(a) \
+if (plsc->debug) \
+    fprintf(stderr, "    entered %s (%s, line %d)\n", a, __FILE__, __LINE__);
+
+#else
+#define dbug_enter(a)
+#endif
+
+/* If we're using a debugging malloc, include the header file here */
+
+#ifdef DEBUGGING_MALLOC
+#include <malloc.h>
+#endif
+
+/*--------------------------------------------------------------------------*\
+ * pldebug()
+ *
+ * Included into every plplot source file to control debugging output.  To
+ * enable printing of debugging output, you must #define DEBUG before
+ * including plplotP.h or specify -DDEBUG in the compile line, for each file
+ * that you want to have debug output enabled.  When running the program you
+ * must in addition specify -debug.  This allows debugging output to tailored
+ * to many different circumstances but otherwise be fairly unobtrusive. 
+ *
+ * Note, any file that actually uses pldebug() must also define NEED_PLDEBUG
+ * before the plplotP.h include.  This is to eliminate warnings caused by
+ * those files in which this is defined but never referenced.  All this could
+ * be much nicer if CPP had the abilities of m4, sigh.. 
+ *
+ * Syntax:
+ *	pldebug(label, format [, arg1, arg2, ...] );
+ *
+ * The label is typically the calling function name.
+\*--------------------------------------------------------------------------*/
+
+#ifdef NEED_PLDEBUG
+static void
+pldebug( const char *label, ... )
+{
+#ifdef DEBUG
+    va_list args;
+    char *fmt;
+
+    if (plsc->debug) {
+	if (plsc->termin)
+	    c_pltext();
+	va_start(args, label);
+
+    /* print out identifying tag */
+
+	fprintf(stderr, "%s: ", label);
+
+    /* print out remainder of message */
+    /* Need to get fmt BEFORE it's used in the vfprintf */
+
+	fmt = (char *) va_arg(args, char *);
+	vfprintf(stderr, fmt, args);
+
+	va_end(args);
+	if (plsc->termin)
+	    c_plgra();
+    }
+#endif	/* DEBUG */
+}
+#endif	/* NEED_PLDEBUG */
+
+#endif	/* __PLDEBUG_H__ */
diff --git a/collects/plot/src/all/pldtik.c b/collects/plot/src/all/pldtik.c
new file mode 100644
index 0000000000..ff64ab944c
--- /dev/null
+++ b/collects/plot/src/all/pldtik.c
@@ -0,0 +1,209 @@
+/* $Id: pldtik.c,v 1.1 2004/03/01 20:54:51 cozmic Exp $
+
+	Determines tick spacing and mode (fixed or floating) of
+	numeric axis labels.
+*/
+
+#include "plplotP.h"
+
+/*----------------------------------------------------------------------*\
+ * void pldtik()
+ *
+ * Determine tick spacing: works out a "nice" interval (if tick == 0) such
+ * that there are between 3 and 7.5 major tick intervals in the input
+ * range vmin to vmax.  The recommended number of subticks is returned in
+ * "nsubt" unless the routine is entered with a non-zero value of "nsubt".
+ * n.b. big change: now returns only positive values of tick and nsubt
+\*----------------------------------------------------------------------*/
+
+void
+pldtik(PLFLT vmin, PLFLT vmax, PLFLT *tick, PLINT *nsubt)
+{
+    PLFLT t1, t2, tick_reasonable;
+    PLINT np, ns;
+
+/* Magnitude of min/max difference to get tick spacing */
+
+    t1 = (PLFLT) log10(ABS(vmax - vmin));
+    np = (PLINT) floor(t1);
+    t1 = t1 - np;
+
+/* Get tick spacing. */
+
+    if (t1 > 0.7781512503) {
+	t2 = 2.0;
+	ns = 4;
+    }
+    else if (t1 > 0.4771212549) {
+	t2 = 1.0;
+	ns = 5;
+    }
+    else if (t1 > 0.1760912591) {
+	t2 = 5.0;
+	ns = 5;
+	np = np - 1;
+    }
+    else {
+	t2 = 2.0;
+	ns = 4;
+	np = np - 1;
+    }
+
+/* Now compute reasonable tick spacing */
+
+    tick_reasonable = t2 * pow(10.0, (double) np);
+    if (*tick == 0) {
+	*tick = t2 * pow(10.0, (double) np);
+    }
+    else {
+        *tick = ABS(*tick);
+        if(*tick < 1.e-4*tick_reasonable) {
+	   plexit("pldtik: magnitude of specified tick spacing is much too small");
+	   return;
+	}
+    }
+    if (*nsubt == 0)
+	*nsubt = ns;
+
+    *nsubt = ABS(*nsubt);
+}
+
+/*----------------------------------------------------------------------*\
+ * void pldprec()
+ *
+ * Determine precision: the output variable "mode" is set to 0 if labels
+ * are to be written in floating-point format, or to 1 if they are to be
+ * written in scientific format.  For mode = 1, the exponent will be
+ * placed at:
+ *
+ * 	top left	for vertical axis on left
+ * 	top right	for vertical axis on right
+ * 	bottom right	for horizontal axis
+ *
+ * The digmax flag can be set by the user, and represents the maximum
+ * number of digits a label may occupy including sign and decimal point.
+ * digmin, calculated internally, is the maximum number of digits
+ * labels at vmin and vmax would occupy if floating point.
+ * If digmax<0, it is disregarded,
+ * and if digmax=0 the default value is used.  For digmax>0, mode=1 is
+ * chosen if there is insufficient room for the label within the specified
+ * # of digits (digmin > digfix, where digfix is determined from digmax with
+ * fuzz factors).
+ *
+ * In the case of mode=0, the actual # of digits will become too large
+ * when the magnitude of the labels become too large.  The mode=1 case
+ * offers the greatest precision for the smallest field length.
+ *
+ * The determination of maximum length for fixed point quantities is
+ * complicated by the fact that very long fixed point representations look
+ * much worse than the same sized floating point representation.  Further,
+ * a fixed point number with a large negative exponent will actually gain
+ * in precision when written as floating point.  Thus we use certain fuzz
+ * factors to get 'digfix' from 'digmax', however it will always be true
+ * that digfix<=digmax.
+ *
+ * Finally, if 'digmax' is set, 'prec' is reduced in size if necessary so
+ * that the labels fit the requested field length, where prec is the number of 
+ * places after the decimal place.
+\*----------------------------------------------------------------------*/
+
+#define MIN_FLTDIG	3	/* disregarded if fractional part is 0 */
+#define MAX_FIXDIG_POS	6
+#define MAX_FIXDIG_NEG	4
+#define DIGMAX_DEF	5
+
+void
+pldprec(PLFLT vmin, PLFLT vmax, PLFLT tick, PLINT lf, 
+	PLINT *mode, PLINT *prec, PLINT digmax, PLINT *scale)
+{
+    PLFLT chosen, notchosen, vmod, t0;
+    PLINT msd, notmsd, np, digmin, digfix;
+
+    *mode = 0;
+    *scale = 0;
+
+    if (digmax == 0)
+	digmax = DIGMAX_DEF;
+
+/* Choose vmin or vmax depending on magnitudes of vmin and vmax. */
+    chosen = (ABS(vmax) >= ABS(vmin))? vmax: vmin;
+    notchosen = (ABS(vmax) >= ABS(vmin))? vmin: vmax;
+/* Magnitute of chosen to get number of significant digits */
+
+    if(ABS(chosen) > 0.) {
+        vmod = ABS(chosen);
+        t0 = (PLFLT) log10(vmod);
+        msd = (PLINT) floor(t0);
+    }
+    else {
+/* this branch occurs only when 0. --- 0. range put in */
+        vmod = 1.;
+        t0 = (PLFLT) log10(vmod);
+        msd = (PLINT) floor(t0);
+    }
+        
+    if(ABS(notchosen) > 0.)
+	notmsd = (PLINT) floor( (PLFLT) log10(ABS(notchosen)));
+    else
+	notmsd = msd;
+/* Autoselect the mode flag */
+/* 'digmin' is the minimum number of places taken up by the label */
+
+    if (msd >= 0) {
+/* n.b. no decimal point in the minimal case  */
+	digmin = msd + 1;
+	digfix = MAX_FIXDIG_POS;
+	if (digmax > 0)
+	    digfix = MIN(digmax, MAX_FIXDIG_POS);
+    }
+    else {
+/* adjust digmin to account for leading 0 and decimal point */
+	digmin = -msd + 2;
+	digfix = MAX_FIXDIG_NEG;
+	if (digmax > 0)
+	    digfix = MIN(digmax, MAX_FIXDIG_NEG);
+    }
+/* adjust digmin to account for sign on the chosen end of axis or sign on the 
+ * nonchosen end of axis if notmsd = msd or (msd <= 0 and notmsd < 0)
+ * For the latter case the notchosen label starts with "-0."
+ * For checking for the latter case, the notmsd < 0 condition is redundant
+ * since notmsd <= msd always and the equal part is selected by the first
+ * condition.
+ */
+    if(chosen < 0.||(notchosen < 0. && (notmsd == msd || msd <= 0)))
+        digmin = digmin + 1;
+
+    if (digmin > digfix && !lf) {
+	*mode = 1;
+	*scale = msd;
+    }
+
+/* Establish precision.  */
+/* It must be fine enough to resolve the tick spacing */
+
+    np = (PLINT) floor(log10(ABS(tick)));
+
+    if (*mode != 0)
+	*prec = msd - np;
+    else
+	*prec = MAX(-np, 0);
+
+/* One last hack required: if exponent < 0, i.e. number has leading '0.',
+ * it's better to change to floating point form if the number of digits
+ * is insufficient to represent the tick spacing.
+*/
+    if (*mode == 0 && digmax > 0 && !lf) {
+	if (t0 < 0.0) {
+	    if (digmax - 2 - *prec < 0) {
+		*mode = 1;
+		*scale = msd;
+	    }
+	}
+	else
+	    *prec = MAX(MIN(*prec, digmax - msd - 1), 0);
+    }
+    if (*mode != 0) {
+	*prec = msd - np;
+	*prec = MAX(MIN(*prec, MAX(digmax-1, MIN_FLTDIG)), 0);
+    }
+}
diff --git a/collects/plot/src/all/plevent.h b/collects/plot/src/all/plevent.h
new file mode 100644
index 0000000000..6dba6c0ced
--- /dev/null
+++ b/collects/plot/src/all/plevent.h
@@ -0,0 +1,205 @@
+/* $Id: plevent.h,v 1.1 2004/03/01 20:54:51 cozmic Exp $
+
+    Input event (especially keyboard) definitions for use from plplot
+    event handlers.
+
+    Key definitions are taken from the X11/keysymdef.h include file, with
+    some changes:
+        - only the control keys are retained
+	- the XK prefix has been changed to PLK
+	- control keys with ASCII equivalents use the ASCII code
+
+    By using the ASCII equivalent (if it exists) for all control keys, it
+    is easier to handle keyboard input from any device which is ASCII based.
+    Devices which use some other kind of key encoding must translate the raw
+    keycodes to those used here.
+*/
+
+#ifndef __PLEVENT_H__
+#define __PLEVENT_H__
+
+/* Key definitions */
+
+/***********************************************************
+Copyright 1987 by Digital Equipment Corporation, Maynard, Massachusetts,
+and the Massachusetts Institute of Technology, Cambridge, Massachusetts.
+
+                        All Rights Reserved
+
+Permission to use, copy, modify, and distribute this software and its
+documentation for any purpose and without fee is hereby granted,
+provided that the above copyright notice appear in all copies and that
+both that copyright notice and this permission notice appear in
+supporting documentation, and that the names of Digital or MIT not be
+used in advertising or publicity pertaining to distribution of the
+software without specific, written prior permission.
+
+DIGITAL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
+ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
+DIGITAL BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
+ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
+ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
+SOFTWARE.
+
+******************************************************************/
+
+/* Miscellaneous control keys, those with ASCII equivalents */
+
+#define PLK_BackSpace		0x08	/* back space, back char */
+#define PLK_Tab			0x09
+#define PLK_Linefeed		0x0A	/* Linefeed, LF */
+#define PLK_Return		0x0D	/* Return, enter */
+#define PLK_Escape		0x1B
+#define PLK_Delete		0xFF	/* Delete, rubout */
+
+/* Those without ASCII equivalents */
+
+#define PLK_Clear		0xFF0B
+#define PLK_Pause		0xFF13	/* Pause, hold */
+#define PLK_Scroll_Lock		0xFF14
+
+/* Cursor control & motion */
+
+#define PLK_Home		0xFF50
+#define PLK_Left		0xFF51	/* Move left, left arrow */
+#define PLK_Up			0xFF52	/* Move up, up arrow */
+#define PLK_Right		0xFF53	/* Move right, right arrow */
+#define PLK_Down		0xFF54	/* Move down, down arrow */
+#define PLK_Prior		0xFF55	/* Prior, previous (Page Up) */
+#define PLK_Next		0xFF56	/* Next (Page Down) */
+#define PLK_End			0xFF57	/* EOL */
+#define PLK_Begin		0xFF58	/* BOL */
+
+/* Misc Functions */
+
+#define PLK_Select		0xFF60	/* Select, mark */
+#define PLK_Print		0xFF61
+#define PLK_Execute		0xFF62	/* Execute, run, do */
+#define PLK_Insert		0xFF63	/* Insert, insert here */
+#define PLK_Undo		0xFF65	/* Undo, oops */
+#define PLK_Redo		0xFF66	/* redo, again */
+#define PLK_Menu		0xFF67
+#define PLK_Find		0xFF68	/* Find, search */
+#define PLK_Cancel		0xFF69	/* Cancel, stop, abort, exit */
+#define PLK_Help		0xFF6A	/* Help, ? */
+#define PLK_Break		0xFF6B
+#define PLK_Mode_switch		0xFF7E	/* Character set switch */
+#define PLK_script_switch	0xFF7E  /* Alias for mode_switch */
+#define PLK_Num_Lock		0xFF7F
+
+/* Keypad Functions, keypad numbers cleverly chosen to map to ascii */
+
+#define PLK_KP_Space		0xFF80	/* space */
+#define PLK_KP_Tab		0xFF89
+#define PLK_KP_Enter		0xFF8D	/* enter */
+#define PLK_KP_F1		0xFF91	/* PF1, KP_A, ... */
+#define PLK_KP_F2		0xFF92
+#define PLK_KP_F3		0xFF93
+#define PLK_KP_F4		0xFF94
+#define PLK_KP_Equal		0xFFBD	/* equals */
+#define PLK_KP_Multiply		0xFFAA
+#define PLK_KP_Add		0xFFAB
+#define PLK_KP_Separator	0xFFAC	/* separator, often comma */
+#define PLK_KP_Subtract		0xFFAD
+#define PLK_KP_Decimal		0xFFAE
+#define PLK_KP_Divide		0xFFAF
+
+#define PLK_KP_0		0xFFB0
+#define PLK_KP_1		0xFFB1
+#define PLK_KP_2		0xFFB2
+#define PLK_KP_3		0xFFB3
+#define PLK_KP_4		0xFFB4
+#define PLK_KP_5		0xFFB5
+#define PLK_KP_6		0xFFB6
+#define PLK_KP_7		0xFFB7
+#define PLK_KP_8		0xFFB8
+#define PLK_KP_9		0xFFB9
+
+/*
+ * Auxilliary Functions; note the duplicate definitions for left and right
+ * function keys;  Sun keyboards and a few other manufactures have such
+ * function key groups on the left and/or right sides of the keyboard.
+ * We've not found a keyboard with more than 35 function keys total.
+ */
+
+#define PLK_F1			0xFFBE
+#define PLK_F2			0xFFBF
+#define PLK_F3			0xFFC0
+#define PLK_F4			0xFFC1
+#define PLK_F5			0xFFC2
+#define PLK_F6			0xFFC3
+#define PLK_F7			0xFFC4
+#define PLK_F8			0xFFC5
+#define PLK_F9			0xFFC6
+#define PLK_F10			0xFFC7
+#define PLK_F11			0xFFC8
+#define PLK_L1			0xFFC8
+#define PLK_F12			0xFFC9
+#define PLK_L2			0xFFC9
+#define PLK_F13			0xFFCA
+#define PLK_L3			0xFFCA
+#define PLK_F14			0xFFCB
+#define PLK_L4			0xFFCB
+#define PLK_F15			0xFFCC
+#define PLK_L5			0xFFCC
+#define PLK_F16			0xFFCD
+#define PLK_L6			0xFFCD
+#define PLK_F17			0xFFCE
+#define PLK_L7			0xFFCE
+#define PLK_F18			0xFFCF
+#define PLK_L8			0xFFCF
+#define PLK_F19			0xFFD0
+#define PLK_L9			0xFFD0
+#define PLK_F20			0xFFD1
+#define PLK_L10			0xFFD1
+#define PLK_F21			0xFFD2
+#define PLK_R1			0xFFD2
+#define PLK_F22			0xFFD3
+#define PLK_R2			0xFFD3
+#define PLK_F23			0xFFD4
+#define PLK_R3			0xFFD4
+#define PLK_F24			0xFFD5
+#define PLK_R4			0xFFD5
+#define PLK_F25			0xFFD6
+#define PLK_R5			0xFFD6
+#define PLK_F26			0xFFD7
+#define PLK_R6			0xFFD7
+#define PLK_F27			0xFFD8
+#define PLK_R7			0xFFD8
+#define PLK_F28			0xFFD9
+#define PLK_R8			0xFFD9
+#define PLK_F29			0xFFDA
+#define PLK_R9			0xFFDA
+#define PLK_F30			0xFFDB
+#define PLK_R10			0xFFDB
+#define PLK_F31			0xFFDC
+#define PLK_R11			0xFFDC
+#define PLK_F32			0xFFDD
+#define PLK_R12			0xFFDD
+#define PLK_R13			0xFFDE
+#define PLK_F33			0xFFDE
+#define PLK_F34			0xFFDF
+#define PLK_R14			0xFFDF
+#define PLK_F35			0xFFE0
+#define PLK_R15			0xFFE0
+
+/* Modifiers */
+
+#define PLK_Shift_L		0xFFE1	/* Left shift */
+#define PLK_Shift_R		0xFFE2	/* Right shift */
+#define PLK_Control_L		0xFFE3	/* Left control */
+#define PLK_Control_R		0xFFE4	/* Right control */
+#define PLK_Caps_Lock		0xFFE5	/* Caps lock */
+#define PLK_Shift_Lock		0xFFE6	/* Shift lock */
+
+#define PLK_Meta_L		0xFFE7	/* Left meta */
+#define PLK_Meta_R		0xFFE8	/* Right meta */
+#define PLK_Alt_L		0xFFE9	/* Left alt */
+#define PLK_Alt_R		0xFFEA	/* Right alt */
+#define PLK_Super_L		0xFFEB	/* Left super */
+#define PLK_Super_R		0xFFEC	/* Right super */
+#define PLK_Hyper_L		0xFFED	/* Left hyper */
+#define PLK_Hyper_R		0xFFEE	/* Right hyper */
+
+#endif	/* __PLEVENT_H__ */
diff --git a/collects/plot/src/all/plfill.c b/collects/plot/src/all/plfill.c
new file mode 100644
index 0000000000..351d4959b2
--- /dev/null
+++ b/collects/plot/src/all/plfill.c
@@ -0,0 +1,341 @@
+/* $Id: plfill.c,v 1.2 2005/03/17 21:39:21 eli Exp $
+
+	Polygon pattern fill.
+*/
+
+#include "plplotP.h"
+
+#define DTOR            0.0174533
+#define BINC            50
+
+struct point {
+    PLINT x, y;
+};
+static PLINT bufferleng, buffersize, *buffer;
+
+/* Static function prototypes */
+/* INDENT OFF */
+
+static int   compar	(const void *, const void *);
+static void  addcoord	(PLINT, PLINT);
+static void  tran	(PLINT *, PLINT *, PLFLT, PLFLT);
+static void  buildlist	(PLINT, PLINT, PLINT, PLINT, PLINT, PLINT, PLINT);
+
+/* INDENT ON */
+
+/*----------------------------------------------------------------------*\
+ * void plfill()
+ *
+ * Pattern fills the polygon bounded by the input points.
+ * If hardware fill is used, a maximum of PL_MAXPOLY-1 vertices is allowed.
+ * The final point is explicitly added if it doesn't match up to the first,
+ * to prevent clipping problems.
+\*----------------------------------------------------------------------*/
+
+MZ_DLLEXPORT
+void
+c_plfill(PLINT n, PLFLT *x, PLFLT *y)
+{
+    PLINT xpoly[PL_MAXPOLY], ypoly[PL_MAXPOLY];
+    PLINT i;
+
+    if (plsc->level < 3) {
+	plabort("plfill: Please set up window first");
+	return;
+    }
+    if (n < 3) {
+	plabort("plfill: Not enough points in object");
+	return;
+    }
+    if (n > PL_MAXPOLY-1) {
+	plwarn("plfill: too many points in polygon");
+	n = PL_MAXPOLY;
+    }
+    for (i = 0; i < n; i++) {
+	xpoly[i] = plP_wcpcx(x[i]);
+	ypoly[i] = plP_wcpcy(y[i]);
+    }
+
+    if (x[0] != x[n-1] || y[0] != y[n-1]) {
+	n++;
+	xpoly[n-1] = plP_wcpcx(x[0]);
+	ypoly[n-1] = plP_wcpcy(y[0]);
+    }
+
+    plP_plfclp(xpoly, ypoly, n, plsc->clpxmi, plsc->clpxma,
+	       plsc->clpymi, plsc->clpyma, plP_fill);
+}
+
+/*----------------------------------------------------------------------*\
+ * void plfill3()
+ *
+ * Pattern fills the polygon in 3d bounded by the input points.
+ * If hardware fill is used, a maximum of PL_MAXPOLY-1 vertices is allowed.
+ * The final point is explicitly added if it doesn't match up to the first,
+ * to prevent clipping problems.
+\*----------------------------------------------------------------------*/
+
+void
+c_plfill3(PLINT n, PLFLT *x, PLFLT *y, PLFLT *z)
+{
+    PLFLT tx[PL_MAXPOLY], ty[PL_MAXPOLY], tz[PL_MAXPOLY];
+    PLFLT *V[3];
+    PLINT xpoly[PL_MAXPOLY], ypoly[PL_MAXPOLY];
+    PLINT i;
+    PLFLT xmin, xmax, ymin, ymax, zmin, zmax, zscale;
+
+    if (plsc->level < 3) {
+	plabort("plfill3: Please set up window first");
+	return;
+    }
+    if (n < 3) {
+	plabort("plfill3: Not enough points in object");
+	return;
+    }
+    if (n > PL_MAXPOLY-1) {
+	plwarn("plfill3: too many points in polygon");
+	n = PL_MAXPOLY;
+    }
+
+    plP_gdom(&xmin, &xmax, &ymin, &ymax);
+    plP_grange(&zscale, &zmin, &zmax);
+    
+    /* copy the vertices so we can clip without corrupting the input */
+    for( i=0; i < n; i++ ) {
+      tx[i] = x[i]; ty[i] = y[i]; tz[i] = z[i];
+    }
+    if (tx[0] != tx[n-1] || ty[0] != ty[n-1] || tz[0] != tz[n-1]) {
+      tx[n] = tx[0]; ty[n] = ty[0]; tz[n] = tz[0];
+      n++;
+    }
+    V[0] = tx; V[1] = ty; V[2] = tz;
+    n = plP_clip_poly(n, V, 0,  1, -xmin);
+    n = plP_clip_poly(n, V, 0, -1,  xmax);
+    n = plP_clip_poly(n, V, 1,  1, -ymin);
+    n = plP_clip_poly(n, V, 1, -1,  ymax);
+    n = plP_clip_poly(n, V, 2,  1, -zmin);
+    n = plP_clip_poly(n, V, 2, -1,  zmax);
+    for( i=0; i < n; i++ ) {
+	xpoly[i] = plP_wcpcx(plP_w3wcx( tx[i], ty[i], tz[i] ));
+	ypoly[i] = plP_wcpcy(plP_w3wcy( tx[i], ty[i], tz[i] ));
+	}
+
+/* AWI: in the past we have used
+ *  plP_fill(xpoly, ypoly, n);
+ * here, but our educated guess is this fill should be done via the clipping
+ * interface instead as below.
+ * No example tests this code so one of our users will end up inadvertently
+ * testing this for us. 
+ *
+ * jc: I have checked, and both versions does give the same result, i.e., clipping
+ * to the window boundaries. The reason is that the above plP_clip_poly() does
+ * the clipping. To check this, is enough to diminish the x/y/z min/max arguments in
+ * plw3d() in x08c. But let's keep it, although 10% slower...
+ */
+    plP_plfclp(xpoly, ypoly, n, plsc->clpxmi, plsc->clpxma,
+           plsc->clpymi, plsc->clpyma, plP_fill);
+}
+
+/*----------------------------------------------------------------------*\
+ * void plfill_soft()
+ *
+ * Pattern fills in software the polygon bounded by the input points.
+\*----------------------------------------------------------------------*/
+
+void
+plfill_soft(short *x, short *y, PLINT n)
+{
+    PLINT i, j;
+    PLINT xp1, yp1, xp2, yp2, xp3, yp3;
+    PLINT k, dinc;
+    PLFLT ci, si;
+    double temp;
+
+    buffersize = 2 * BINC;
+    buffer = (PLINT *) malloc((size_t) buffersize * sizeof(PLINT));
+    if ( ! buffer) {
+	plabort("plfill: Out of memory");
+	return;
+    }
+
+/* Loop over sets of lines in pattern */
+
+    for (k = 0; k < plsc->nps; k++) {
+	bufferleng = 0;
+
+        temp = DTOR * plsc->inclin[k] * 0.1;
+        si = sin(temp) * plsc->ypmm;
+        ci = cos(temp) * plsc->xpmm;
+
+	/* normalize: 1 = si*si + ci*ci */
+
+        temp = sqrt((double) (si*si + ci*ci));
+	si /= temp;
+	ci /= temp;
+
+	dinc = plsc->delta[k] * SSQR(plsc->ypmm * ABS(ci),
+				     plsc->xpmm * ABS(si)) / 1000.;
+
+	if (dinc < 0) dinc = -dinc;
+	if (dinc == 0) dinc = 1;
+
+	xp1 = x[n-2];
+	yp1 = y[n-2];
+	tran(&xp1, &yp1, (PLFLT) ci, (PLFLT) si);
+
+	xp2 = x[n-1];
+	yp2 = y[n-1];
+	tran(&xp2, &yp2, (PLFLT) ci, (PLFLT) si);
+
+/* Loop over points in polygon */
+
+	for (i = 0; i < n; i++) {
+	    xp3 = x[i];
+	    yp3 = y[i];
+	    tran(&xp3, &yp3, (PLFLT) ci, (PLFLT) si);
+	    buildlist(xp1, yp1, xp2, yp2, xp3, yp3, dinc);
+	    xp1 = xp2;
+	    yp1 = yp2;
+	    xp2 = xp3;
+	    yp2 = yp3;
+	}
+
+/* Sort list by y then x */
+
+	qsort((void *) buffer, (size_t) bufferleng / 2,
+	      (size_t) sizeof(struct point), compar);
+
+/* OK, now do the hatching */
+
+	i = 0;
+
+	while (i < bufferleng) {
+	    xp1 = buffer[i];
+	    yp1 = buffer[i + 1];
+	    i += 2;
+	    xp2 = xp1;
+	    yp2 = yp1;
+	    tran(&xp1, &yp1, (PLFLT) ci, (PLFLT) (-si));
+	    plP_movphy(xp1, yp1);
+	    xp1 = buffer[i];
+	    yp1 = buffer[i + 1];
+	    i += 2;
+	    if (yp2 != yp1) {
+		fprintf(stderr, "plfill: oh oh we are lost\n");
+		for (j = 0; j < bufferleng; j+=2) {
+		    fprintf(stderr, "plfill: %d %d\n",
+			    (int) buffer[j], (int) buffer[j+1]);
+		}
+		continue;	/* Uh oh we're lost */
+	    }
+	    tran(&xp1, &yp1, (PLFLT) ci, (PLFLT) (-si));
+	    plP_draphy(xp1, yp1);
+	}
+    }
+    free((void *) buffer);
+}
+
+/*----------------------------------------------------------------------*\
+ * Utility functions
+\*----------------------------------------------------------------------*/
+
+static void
+tran(PLINT *a, PLINT *b, PLFLT c, PLFLT d)
+{
+    PLINT ta, tb;
+
+    ta = *a;
+    tb = *b;
+
+    *a = floor((double) (ta * c + tb * d + 0.5));
+    *b = floor((double) (tb * c - ta * d + 0.5));
+}
+
+static void
+buildlist(PLINT xp1, PLINT yp1, PLINT xp2, PLINT yp2, PLINT xp3, PLINT yp3,
+	  PLINT dinc)
+{
+    PLINT min_y, max_y;
+    PLINT dx, dy, cstep, nstep, ploty, plotx;
+
+    dx = xp2 - xp1;
+    dy = yp2 - yp1;
+
+    if (dy == 0) {
+	if (yp2 > yp3 && ((yp2 % dinc) == 0)) 
+	    addcoord(xp2, yp2);
+	return;
+    }
+
+    if (dy > 0) {
+	cstep = 1;
+	min_y = yp1;
+	max_y = yp2;
+    }
+    else {
+	cstep = -1;
+	min_y = yp2;
+	max_y = yp1;
+    }
+
+    nstep = (yp3 > yp2 ? 1 : -1);
+    if (yp3 == yp2) nstep = 0;
+
+    /* Build coordinate list */
+
+    ploty = (min_y / dinc) * dinc;
+    if (ploty < min_y) ploty += dinc;
+
+    for (; ploty <= max_y; ploty += dinc) {
+	if (ploty == yp1) continue;
+	if (ploty == yp2) {
+	    if (cstep == -nstep) continue;
+	    if (yp2 == yp3 && yp1 > yp2) continue;
+	}
+	plotx = xp1 + floor(((double) (ploty - yp1) * dx) / dy + 0.5);
+	addcoord(plotx, ploty);
+    }
+}
+
+static void
+addcoord(PLINT xp1, PLINT yp1)
+{
+    PLINT *temp;
+
+    if (bufferleng + 2 > buffersize) {
+	buffersize += 2 * BINC;
+	temp = (PLINT *) realloc((void *) buffer,
+				 (size_t) buffersize * sizeof(PLINT));
+	if (!temp) {
+	    free((void *) buffer);
+	    plexit("plfill: Out of memory!");
+	}
+	buffer = temp;
+    }
+
+    buffer[bufferleng++] = xp1;
+    buffer[bufferleng++] = yp1;
+}
+
+static int
+compar(const void *pnum1, const void *pnum2)
+{
+    const struct point *pnt1, *pnt2;
+
+    pnt1 = (const struct point *) pnum1;
+    pnt2 = (const struct point *) pnum2;
+
+    if (pnt1->y < pnt2->y)
+	return -1;
+    else if (pnt1->y > pnt2->y)
+	return 1;
+
+    /* Only reach here if y coords are equal, so sort by x */
+
+    if (pnt1->x < pnt2->x)
+	return -1;
+    else if (pnt1->x > pnt2->x)
+	return 1;
+
+    return 0;
+}
diff --git a/collects/plot/src/all/plfreetype.h b/collects/plot/src/all/plfreetype.h
new file mode 100644
index 0000000000..15dfc8768b
--- /dev/null
+++ b/collects/plot/src/all/plfreetype.h
@@ -0,0 +1,126 @@
+/* $Id: plfreetype.h,v 1.1 2004/03/01 20:54:51 cozmic Exp $
+ *
+ *    Header file for Support routines for freetype font engine
+ *
+ *    See plfreetype.c for more details
+ */
+
+#ifndef __PLFREETY_H__
+#define __PLFREETY_H__
+
+#ifdef HAVE_FREETYPE
+
+#include <ft2build.h>
+#include FT_FREETYPE_H
+#include FT_GLYPH_H
+#include FT_OUTLINE_H
+
+#define FT_Data _FT_Data_
+
+typedef void (*plD_pixel_fp)     (PLStream *, PLINT, PLINT);
+
+/*--------------------------------------------------------------------------*\
+ * Define the FT_Data data structure.
+ *
+ * These are the "globalish" variables used by Freetype
+ * They are kept here so they are moderately thread safe, and stream specific
+\*--------------------------------------------------------------------------*/
+
+typedef struct FT_Data {
+    short               x;
+    short               y;
+
+    char *textbuf;		/* temporary string buffer */
+
+    PLFLT		scale;
+/*
+ *  If set to 1, scale won't do anything, but this is an "arbitrary" scale
+ *  factor for the transformation between virtual and real coordinates. This
+ *  is included to fix up the problem with the "hidden line removal bug" of
+ *  the 3D plots, which is fixed by providing a super-scaled image. This
+ *  should be a mirror, for example, of dev->scale in the PNG driver. If I
+ *  was thinking 12 months ahead, I would have put that scale factor in
+ *  "pls", not "dev", but at this late stage, we can just live with it
+ *  now...
+ */
+
+    unsigned char       greek;
+
+    unsigned char       invert_y;
+/*
+ *  Set "invert_y" to 1 if the y coordinates need to be inverted for
+ *  plotting. Most bitmaps will need this.
+ */
+
+    short               ymax;
+/*
+ *  ymax should be equal to, what it says - the maximum y coordinate of the
+ *  bitmap. This is used in the process of calculating the inversion of the
+ *  bitmap when invert_y is set to 1. If invert_y isn't set, this setting is
+ *  ignored.
+ */
+
+
+    plD_pixel_fp        pixel;          /* pointer to a function which draws a single pixel */
+
+
+    int want_smooth_text; /* flag to request text smoothing (won't */
+                          /* necessarily get it though */
+    int smooth_text;      /* Flag to indicate type of anti-aliasing used, if freetype text is active */
+
+
+    char                font_name[5][1024];
+/*
+ *  List of font names and paths corresponding to the "predefined" fonts of
+ *  plplot. 1024 chars is presumably generous for each one's length, but at
+ *  least we probably won't get in trouble this way.
+ */
+
+
+    PLINT               cfont;
+/*
+ *  This is a mirror of pls->cfont and is basically used for detecting when
+ *  fonts have been changed .
+ */
+
+
+    FT_Matrix           matrix;         /* used for rotating etc... the font. */
+    FT_Vector           pos;            /* used for calculating offsets of text boxes/sizes */
+
+
+/*
+ *  The next few variables hold the original size of CMAP0, the number of
+ *  extra slots added for anti-aliasing, and the "width" of the table used
+ *  for anti-aliasing.
+ */
+
+    PLINT ncol0_org;            /* Original number of colours in CMAP0 */
+    PLINT ncol0_xtra;           /* number of extra colours defined in CMAP0 for anti-aliasing */
+    PLINT ncol0_width;          /* Number of greyscale levels for each of the original colours */
+    PLINT last_icol0;           /* Last colour in cmap0, which should be one of the originals */
+
+
+/*
+ *  The rest of the variables should be considered very much PRIVATE, and
+ *  more to the point, subject to change.
+ *
+ *  Don't rely on them existing in future versions of plplot's freetype
+ *  support. If/when the Freetype cache manager is added to plplot, most, if
+ *  not all, of these variables will move elsewhere.
+ */
+
+    FT_Library          library;        /* pointer to freetype library      */
+    FT_Face             face;           /* pointer to a font face           */
+    FT_GlyphSlot        slot;           /* pointer to a glyph slot          */
+    FT_Glyph            image;          /* bitmap or outline image of font  */
+
+    short               colour;         /* depreciated ?? must check code */
+
+    PLINT shade, col_idx;		/* Used for antialiasing */
+
+} FT_Data;
+
+#endif
+
+
+#endif /* __PLFREETY_H__ */
diff --git a/collects/plot/src/all/plgridd.c b/collects/plot/src/all/plgridd.c
new file mode 100644
index 0000000000..030a4bcc0b
--- /dev/null
+++ b/collects/plot/src/all/plgridd.c
@@ -0,0 +1,843 @@
+
+#include "plplotP.h"
+
+#ifdef WITH_CSA
+#include "csa.h"
+#endif
+#include "nan.h" /* this is handy */
+
+#ifdef HAVE_QHULL
+#include "../lib/nn/nn.h"
+#include <qhull/qhull_a.h>
+#endif
+
+#if !defined(HAVE_ISNAN)
+#define isnan(x) ((x) != (x))
+#endif
+
+/* forward declarations */
+static void
+grid_nnaidw (PLFLT *x, PLFLT *y, PLFLT *z, int npts,
+	     PLFLT *xg, int nptsx, PLFLT *yg,  int nptsy, PLFLT **zg);
+
+static void
+grid_nnli (PLFLT *x, PLFLT *y, PLFLT *z, int npts,
+	   PLFLT *xg, int nptsx, PLFLT *yg,  int nptsy, PLFLT **zg,
+	   PLFLT threshold);
+
+static void
+grid_nnidw (PLFLT *x, PLFLT *y, PLFLT *z, int npts,
+	    PLFLT *xg, int nptsx, PLFLT *yg,  int nptsy, PLFLT **zg,
+	    int knn_order);
+
+#ifdef WITH_CSA
+static void
+grid_csa (PLFLT *x, PLFLT *y, PLFLT *z, int npts,
+	  PLFLT *xg, int nptsx, PLFLT *yg,  int nptsy, PLFLT **zg);
+#endif
+
+#ifdef HAVE_QHULL
+static void
+grid_nni (PLFLT *x, PLFLT *y, PLFLT *z, int npts,
+	  PLFLT *xg, int nptsx, PLFLT *yg,  int nptsy, PLFLT **zg,
+	  PLFLT wmin);
+
+static void
+grid_dtli (PLFLT *x, PLFLT *y, PLFLT *z, int npts,
+	   PLFLT *xg, int nptsx, PLFLT *yg,  int nptsy, PLFLT **zg);
+#endif
+
+static void
+dist1(PLFLT gx, PLFLT gy, PLFLT *x, PLFLT *y, int npts, int knn_order);
+static void
+dist2(PLFLT gx, PLFLT gy, PLFLT *x, PLFLT *y, int npts);
+
+#define KNN_MAX_ORDER 100
+
+typedef struct pt{
+  PLFLT dist;
+  int   item;
+}PT;
+
+static PT items[KNN_MAX_ORDER];
+
+/*----------------------------------------------------------------------*\
+ *
+ * plgriddata(): grids data from irregularly sampled data.
+ *
+ *    Real world data is frequently irregularly sampled, but most 3D plots
+ *    require regularly gridded data. This function does exactly this
+ *    using several methods:
+ *    Irregularly sampled data x[npts], y[npts], z[npts] is gridded into
+ *    zg[nptsx, nptsy] according to methode 'type' and grid information
+ *    xg[nptsx], yg[nptsy].
+ *
+ *    'type' can be:
+ *
+ *       GRID_CSA:    Bivariate Cubic Spline approximation (1)
+ *       GRID_NNIDW:  Nearest Neighbors Inverse Distance Weighted
+ *       GRID_NNLI:   Nearest Neighbors Linear Interpolation
+ *       GRID_NNAIDW: Nearest Neighbors Around Inverse Distance Weighted
+ *       GRID_DTLI:   Delaunay Triangulation Linear Interpolation (2)
+ *       GRID_NNI:    Natural Neighbors interpolation (2)
+ * 
+ * (1): Copyright 2000-2002 CSIRO Marine Research, Pavel Sakov's csa library
+ * (2): Copyright 2002 CSIRO Marine Research, Pavel Sakov's nn library
+ *
+\*----------------------------------------------------------------------*/
+
+void
+c_plgriddata(PLFLT *x, PLFLT *y, PLFLT *z, int npts,
+	   PLFLT *xg, int nptsx, PLFLT *yg,  int nptsy,
+	   PLFLT **zg, int type, PLFLT data)
+{
+  int i, j;
+
+  if(npts < 1 || nptsx < 1 || nptsy < 1) {
+    plabort("plgriddata: Bad array dimensions"); 
+    return;
+  }
+
+  /* Check that points in xg and in yg are strictly increasing */
+
+  for (i = 0; i < nptsx - 1; i++) {
+    if (xg[i] >= xg[i + 1]) {
+      plabort("plgriddata: xg array must be strictly increasing");
+      return;
+    }
+  }
+  for (i = 0; i < nptsy - 1; i++) {
+    if (yg[i] >= yg[i + 1]) {
+      plabort("plgriddata: yg array must be strictly increasing");
+      return;
+    }
+  }
+
+  /* clear array to return */
+  for(i=0; i<nptsx; i++)
+    for(j=0; j<nptsy; j++)
+      zg[i][j] = 0.; /* NaN signals a not processed grid point */
+
+  switch (type) {
+    
+  case (GRID_CSA):     /*  Bivariate Cubic Spline Approximation */
+#ifdef WITH_CSA
+    grid_csa(x, y, z, npts, xg, nptsx, yg, nptsy, zg);
+#else
+    plabort("plgriddata(): PLplot was configured to not use GRID_CSA.");
+#endif
+    break;
+
+  case (GRID_NNIDW): /* Nearest Neighbors Inverse Distance Weighted */
+    grid_nnidw(x, y, z, npts, xg, nptsx, yg, nptsy, zg, (int) data);
+    break;
+
+  case (GRID_NNLI): /* Nearest Neighbors Linear Interpolation */
+    grid_nnli(x, y, z, npts, xg, nptsx, yg, nptsy, zg, data);
+    break;
+
+  case (GRID_NNAIDW): /* Nearest Neighbors "Around" Inverse Distance Weighted */
+    grid_nnaidw(x, y, z, npts, xg, nptsx, yg, nptsy, zg);
+    break;
+
+  case (GRID_DTLI): /* Delaunay Triangulation Linear Interpolation */
+#ifdef HAVE_QHULL
+    grid_dtli(x, y, z, npts, xg, nptsx, yg, nptsy, zg);
+#else
+    plabort("plgriddata(): you must have Qhull to use GRID_DTLI.");
+#endif
+    break;
+
+  case (GRID_NNI): /* Natural Neighbors */
+#ifdef HAVE_QHULL
+    grid_nni(x, y, z, npts, xg, nptsx, yg, nptsy, zg, data);
+#else
+    plabort("plgriddata(): you must have Qhull to use GRID_NNI.");
+#endif
+    break;
+
+  default:
+    plabort("plgriddata: unknown algorithm type"); 
+  }
+}
+
+#ifdef WITH_CSA
+/* 
+ * Bivariate Cubic Spline Approximation using Pavel Sakov's csa package
+ *
+ * NaNs are returned where no interpolation can be done.
+ */
+
+static void
+grid_csa (PLFLT *x, PLFLT *y, PLFLT *z, int npts,
+	  PLFLT *xg, int nptsx, PLFLT *yg,  int nptsy, PLFLT **zg)
+{
+  PLFLT *xt, *yt, *zt;
+  point *pin, *pgrid, *pt;
+  csa* a = NULL;
+  int i, j, nptsg;
+
+  pin = (point *) malloc(npts * sizeof(point));
+
+  xt = x; yt = y; zt = z; pt = pin;
+  for(i=0; i<npts; i++) {
+    pt->x = (double) *xt++;
+    pt->y = (double) *yt++;
+    pt->z = (double) *zt++;
+    pt++;
+  }
+
+  nptsg = nptsx * nptsy;
+  pgrid =  (point *) malloc(nptsg * sizeof(point));
+
+  yt = yg; pt = pgrid;
+  for(j=0; j<nptsy; j++) {
+    xt = xg;
+    for(i=0; i<nptsx; i++) {
+      pt->x = (double) *xt++;
+      pt->y = (double) *yt;
+      pt++;
+    }
+    yt++;
+  }
+
+  a = csa_create();
+  csa_addpoints(a, npts, pin);
+  csa_calculatespline(a);
+  csa_approximate_points(a, nptsg, pgrid);
+
+  for(i=0; i<nptsx; i++) {
+    for(j=0; j<nptsy; j++) {
+      pt = &pgrid[j*nptsx + i];
+      zg[i][j] = (PLFLT) pt->z;
+    }
+  }
+
+  csa_destroy(a);
+  free(pin);
+  free(pgrid); 
+}
+#endif /* WITH_CSA */
+
+/* Nearest Neighbors Inverse Distance Weighted, brute force approach.
+ *
+ * The z value at the grid position will be the weighted average
+ * of the z values of the KNN points found. The weigth is the
+ * inverse squared distance between the grid point and each
+ * neighbor.
+ */
+
+static void
+grid_nnidw (PLFLT *x, PLFLT *y, PLFLT *z, int npts,
+	    PLFLT *xg, int nptsx, PLFLT *yg,  int nptsy, PLFLT **zg,
+	    int knn_order)
+{
+  int i, j, k;
+  PLFLT wi, nt;
+
+  if (knn_order > KNN_MAX_ORDER) {
+    plabort("plgriddata(): GRID_NNIDW: knn_order too big"); /* make sure it is smaller that KNN_MAX_ORDER */
+    return;
+  }
+
+  if (knn_order == 0) {
+    plwarn("plgriddata(): GRID_NNIDW: knn_order must be specified with 'data' arg. Using 15");
+    knn_order = 15;;
+  }
+
+  for (i=0; i<nptsx; i++) {
+    for (j=0; j<nptsy; j++) {
+      dist1(xg[i], yg[j], x, y, npts, knn_order);
+
+#ifdef GMS /* alternative weight coeficients. I Don't like the results */
+      /* find the maximum distance */
+      md = items[0].dist;
+      for (k=1; k<knn_order; k++)
+	if (items[k].dist > md)
+	  md = items[k].dist;
+#endif
+      zg[i][j] = 0.;
+      nt = 0.;
+
+      for (k=0; k<knn_order; k++) {
+	if(items[k].item == -1) /* not enough neighbors found ?! */
+	  continue;
+#ifdef GMS
+	wi = (md - items[k].dist)/(md * items[k].dist);
+	wi = wi*wi;
+#else
+	wi = 1./(items[k].dist*items[k].dist);
+#endif
+	zg[i][j] += wi * z[items[k].item];
+	nt += wi;
+      }
+      if (nt != 0.)
+	zg[i][j] /= nt;
+      else
+	zg[i][j] = NaN;
+    }
+  }
+}
+
+/* Nearest Neighbors Linear Interpolation
+ *
+ * The z value at the grid position will be interpolated from the
+ * plane passing through the 3 nearest neighbors.
+ */
+
+static void
+grid_nnli (PLFLT *x, PLFLT *y, PLFLT *z, int npts,
+	   PLFLT *xg, int nptsx, PLFLT *yg,  int nptsy, PLFLT **zg,
+	   PLFLT threshold)
+{
+  PLFLT xx[4], yy[4], zz[4], t, A, B, C, D, d1, d2, d3, max_thick;
+  int i, j, ii, excl, cnt, excl_item;
+      
+  if (threshold == 0.) {
+    plwarn("plgriddata(): GRID_NNLI: threshold must be specified with 'data' arg. Using 1.001");
+    threshold = 1.001;
+  } else if ( threshold > 2. ||  threshold < 1.) {
+    plabort("plgriddata(): GRID_NNLI: 1. < threshold < 2.");
+    return;
+  }
+
+  for (i=0; i<nptsx; i++) {
+    for (j=0; j<nptsy; j++) {
+      dist1(xg[i], yg[j], x, y, npts, 3);
+
+      /* see if the triangle is a thin one */
+      for (ii=0; ii<3; ii++) {
+	xx[ii] = x[items[ii].item];
+	yy[ii] = y[items[ii].item];
+	zz[ii] = z[items[ii].item];
+      }
+
+      d1 = sqrt((xx[1]-xx[0])*(xx[1]-xx[0]) + (yy[1]-yy[0])*(yy[1]-yy[0]));
+      d2 = sqrt((xx[2]-xx[1])*(xx[2]-xx[1]) + (yy[2]-yy[1])*(yy[2]-yy[1]));
+      d3 = sqrt((xx[0]-xx[2])*(xx[0]-xx[2]) + (yy[0]-yy[2])*(yy[0]-yy[2]));
+
+      if (d1 == 0. || d2 == 0. || d3 == 0.) { /* coincident points */
+	zg[i][j] = NaN; 
+	continue;
+      }
+
+      /* make d1 < d2 */
+      if (d1 > d2) {
+	t = d1; d1 = d2; d2 = t;
+      }
+
+      /* and d2 < d3 */
+      if (d2 > d3) {
+	t = d2; d2 = d3; d3 = t;
+      }
+
+      if ((d1+d2)/d3 < threshold) { /* thin triangle! */
+	zg[i][j] = NaN; /* deal with it latter */
+      } else {  /* calculate the plane passing through the three points */
+	 	 
+	A = yy[0]*(zz[1]-zz[2]) + yy[1]*(zz[2]-zz[0]) + yy[2]*(zz[0]-zz[1]);
+	B = zz[0]*(xx[1]-xx[2]) + zz[1]*(xx[2]-xx[0]) + zz[2]*(xx[0]-xx[1]);
+	C = xx[0]*(yy[1]-yy[2]) + xx[1]*(yy[2]-yy[0]) + xx[2]*(yy[0]-yy[1]);
+	D = - A*xx[0] - B*yy[0] - C*zz[0];
+
+	/* and interpolate (or extrapolate...) */
+	zg[i][j] = - xg[i]*A/C - yg[j]*B/C - D/C;
+      }
+    }
+  }
+
+  /* now deal with NaNs resulting from thin triangles. The idea is
+   * to use the 4 KNN points and exclude one at a time, creating
+   * four triangles, evaluating their thickness and choosing the
+   * most thick as the final one from where the interpolating
+   * plane will be build.  Now that I'm talking of interpolating,
+   * one should really check that the target point is interior to
+   * the candidate triangle... otherwise one is extrapolating
+   */
+
+  { 
+    for (i=0; i<nptsx; i++) {
+      for (j=0; j<nptsy; j++) {
+
+	if (isnan(zg[i][j])) {
+	  dist1(xg[i], yg[j], x, y, npts, 4);
+
+	  /* sort by distances. Not really needed! 
+	     for (ii=3; ii>0; ii--) {
+	     for (jj=0; jj<ii; jj++) {
+	     if (items[jj].dist > items[jj+1].dist) {
+	     t = items[jj].dist;
+	     items[jj].dist = items[jj+1].dist;
+	     items[jj+1].dist = t;
+	     }
+	     }
+	     } 	     
+	  */
+
+	  max_thick = 0.; excl_item = -1;
+	  for (excl=0; excl<4; excl++) { /* the excluded point */
+	      
+	    cnt = 0;
+	    for (ii=0; ii<4; ii++) {
+	      if (ii != excl) {
+		xx[cnt] = x[items[ii].item];
+		yy[cnt] = y[items[ii].item];
+		cnt++;
+	      }
+	    }
+
+	    d1 = sqrt((xx[1]-xx[0])*(xx[1]-xx[0]) + (yy[1]-yy[0])*(yy[1]-yy[0]));
+	    d2 = sqrt((xx[2]-xx[1])*(xx[2]-xx[1]) + (yy[2]-yy[1])*(yy[2]-yy[1]));
+	    d3 = sqrt((xx[0]-xx[2])*(xx[0]-xx[2]) + (yy[0]-yy[2])*(yy[0]-yy[2]));
+	    if (d1 == 0. || d2 == 0. || d3 == 0.) /* coincident points */	 		  continue;
+
+	    /* make d1 < d2 */
+	    if (d1 > d2) {
+	      t = d1; d1 = d2; d2 = t;
+	    }
+	    /* and d2 < d3 */
+	    if (d2 > d3) {
+	      t = d2; d2 = d3; d3 = t;
+	    }
+
+	    t = (d1+d2)/d3;
+	    if ( t > max_thick) {
+	      max_thick = t;
+	      excl_item = excl;
+	    }
+	  }
+
+	  if (excl_item == -1) /* all points are coincident? */
+	    continue;
+
+	  /* one has the thicker triangle constructed from the 4 KNN */
+	  cnt = 0;
+	  for (ii=0; ii<4; ii++) {
+	    if (ii != excl_item) {
+	      xx[cnt] = x[items[ii].item];
+	      yy[cnt] = y[items[ii].item];
+	      zz[cnt] = z[items[ii].item];
+	      cnt++;
+	    }
+	  }
+	 
+	  A = yy[0]*(zz[1]-zz[2]) + yy[1]*(zz[2]-zz[0]) + yy[2]*(zz[0]-zz[1]);
+	  B = zz[0]*(xx[1]-xx[2]) + zz[1]*(xx[2]-xx[0]) + zz[2]*(xx[0]-xx[1]);
+	  C = xx[0]*(yy[1]-yy[2]) + xx[1]*(yy[2]-yy[0]) + xx[2]*(yy[0]-yy[1]);
+	  D = - A*xx[0] - B*yy[0] - C*zz[0];
+
+	  /* and interpolate (or extrapolate...) */
+	  zg[i][j] = - xg[i]*A/C - yg[j]*B/C - D/C;
+
+	}
+      }
+    }
+  }
+}
+
+/* 
+ * Nearest Neighbors "Around" Inverse Distance Weighted, brute force approach.
+ * 
+ * This uses the 1-KNN in each quadrant around the grid point, then
+ * Inverse Distance Weighted is used as in GRID_NNIDW.
+ */
+
+static void
+grid_nnaidw (PLFLT *x, PLFLT *y, PLFLT *z, int npts,
+	     PLFLT *xg, int nptsx, PLFLT *yg,  int nptsy, PLFLT **zg)
+{
+  PLFLT d, nt;
+  int i, j, k;
+
+  for (i=0; i<nptsx; i++) {
+    for (j=0; j<nptsy; j++) {
+      dist2(xg[i], yg[j], x, y, npts);
+      zg[i][j] = 0.;
+      nt = 0.;
+      for (k=0; k<4; k++) {
+	if (items[k].item != -1) { /* was found */
+	  d = 1./(items[k].dist * items[k].dist); /* 1/square distance */
+	  zg[i][j] += d * z[items[k].item];
+	  nt += d;
+	}
+      }
+      if (nt == 0.) /* no points found?! */
+	zg[i][j] = NaN;
+      else
+	zg[i][j] /= nt;
+    }
+  }
+}
+
+#ifdef HAVE_QHULL
+/*
+ * Delaunay Triangulation Linear Interpolation using Pavel Sakov's nn package
+ *
+ * The Delaunay Triangulation on the data points is build and for
+ * each grid point the triangle where it is enclosed found and a
+ * linear interpolation performed.
+ *
+ * Points exterior to the convex hull of the data points cannot
+ * be interpolated and are set to NaN.
+ */
+
+static void
+grid_dtli(PLFLT *x, PLFLT *y, PLFLT *z, int npts,
+	  PLFLT *xg, int nptsx, PLFLT *yg,  int nptsy, PLFLT **zg)
+{
+  point *pin, *pgrid, *pt;
+  PLFLT *xt, *yt, *zt;
+  int i, j, nptsg;
+
+  if (sizeof(realT) != sizeof(double)) {
+    plabort("plgridata: QHull was compiled for floats instead of doubles");
+    return;
+  }
+
+  pin = (point *) malloc(npts * sizeof(point));
+
+  xt = x; yt = y; zt = z; pt = pin;
+  for(i=0; i<npts; i++) {
+    pt->x = (double) *xt++;
+    pt->y = (double) *yt++;
+    pt->z = (double) *zt++;
+    pt++;
+  }
+
+  nptsg = nptsx * nptsy;
+  pgrid =  (point *) malloc(nptsg * sizeof(point));
+
+  yt = yg; pt = pgrid;
+  for(j=0; j<nptsy; j++) {
+    xt = xg;
+    for(i=0; i<nptsx; i++) {
+      pt->x = (double) *xt++;
+      pt->y = (double) *yt;
+      pt++;
+    }
+    yt++;
+  }
+
+  lpi_interpolate_points(npts, pin, nptsg, pgrid);
+  for(i=0; i<nptsx; i++) {
+    for(j=0; j<nptsy; j++) {
+      pt = &pgrid[j*nptsx + i];
+      zg[i][j] = (PLFLT) pt->z;
+    }
+  }
+
+  free(pin);
+  free(pgrid); 
+}
+
+/*
+ * Natural Neighbors using Pavel Sakov's nn package
+ *
+ * Points exterior to the convex hull of the data points cannot
+ * be interpolated and are set to NaN.
+ */
+
+static void
+grid_nni (PLFLT *x, PLFLT *y, PLFLT *z, int npts,
+	  PLFLT *xg, int nptsx, PLFLT *yg,  int nptsy, PLFLT **zg,
+	  PLFLT wmin)
+{
+  PLFLT *xt, *yt, *zt;
+  point *pin, *pgrid, *pt;
+  int i, j, nptsg;
+  nn_algorithm = NON_SIBSONIAN;
+
+  if (sizeof(realT) != sizeof(double)) {
+    plabort("plgridata: QHull was compiled for floats instead of doubles");
+    return;
+  }
+
+  if (wmin == 0.) {/* only accept weights greater than wmin */
+   plwarn("plgriddata(): GRID_NNI: wmin must be specified with 'data' arg. Using -PLFLT_MAX"); 
+    wmin =  -PLFLT_MAX;
+  }
+
+  pin = (point *) malloc(npts * sizeof(point));
+
+  xt = x; yt = y; zt = z; pt = pin;
+  for(i=0; i<npts; i++) {
+    pt->x = (double) *xt++;
+    pt->y = (double) *yt++;
+    pt->z = (double) *zt++;
+    pt++;
+  }
+
+  nptsg = nptsx * nptsy;
+  pgrid =  (point *) malloc(nptsg * sizeof(point));
+
+  yt = yg; pt = pgrid;
+  for(j=0; j<nptsy; j++) {
+    xt = xg;
+    for(i=0; i<nptsx; i++) {
+      pt->x = (double) *xt++;
+      pt->y = (double) *yt;
+      pt++;
+    }
+    yt++;
+  }
+
+  nnpi_interpolate_points(npts, pin, wmin, nptsg, pgrid);
+  for(i=0; i<nptsx; i++) {
+    for(j=0; j<nptsy; j++) {
+      pt = &pgrid[j*nptsx + i];
+      zg[i][j] = (PLFLT) pt->z;
+    }
+  }
+
+  free(pin);
+  free(pgrid); 
+}
+#endif /* HAVE_QHULL*/
+
+/* 
+ * this function just calculates the K Nearest Neighbors of grid point
+ * [gx, gy].
+ */
+
+static void
+dist1(PLFLT gx, PLFLT gy, PLFLT *x, PLFLT *y, int npts, int knn_order)
+{
+
+  PLFLT d, max_dist;
+  int   max_slot, i, j;
+
+  max_dist = PLFLT_MAX;
+  max_slot = 0;
+
+  for (i=0; i<knn_order; i++) {
+    items[i].dist = PLFLT_MAX;
+    items[i].item = -1;
+  }
+
+  for (i=0; i<npts; i++) {
+    d = ((gx - x[i])*(gx - x[i]) + (gy - y[i])*(gy - y[i])); /* save sqrt() time */
+    
+    if (d < max_dist) {
+      /* found an item with a distance smaller than the
+       * maximum distance found so far. Replace.
+       */
+
+      items[max_slot].dist = d;
+      items[max_slot].item = i;
+
+      /* find new maximum distance */
+      max_dist = items[0].dist;
+      max_slot = 0;
+      for (j=1; j<knn_order; j++) {
+	if (items[j].dist > max_dist) {
+	  max_dist = items[j].dist;
+	  max_slot = j;
+	}
+      }
+    }
+  }
+  for (j=0; j<knn_order; j++)
+    items[j].dist = sqrt(items[j].dist); /* now calculate the distance */
+}
+
+/*
+ * This function searchs the 1-nearest neighbor in each quadrant around
+ * the grid point.
+ */
+
+static void
+dist2(PLFLT gx, PLFLT gy, PLFLT *x, PLFLT *y, int npts)
+{
+
+  PLFLT d;
+  int   i, quad;
+
+  for (i=0; i<4; i++) {
+    items[i].dist = PLFLT_MAX;
+    items[i].item = -1;
+  }
+
+  for (i=0; i<npts; i++) {
+    d = ((gx - x[i])*(gx - x[i]) + (gy - y[i])*(gy - y[i])); /* save sqrt() time */
+
+    /* trick to quickly compute a quadrant. The determined quadrants will be
+     * miss-assigned, i.e., 1->2, 2->0, 3->1, 4->3, but that is not important,
+     * speed is. */
+
+    quad = 2*(x[i] > gx) +  (y[i] < gy);
+
+    /* try to use the octants around the grid point, as it will give smoother
+     * (and slower) results.
+     * Hint: use the quadrant info plus x[i]/y[i] to determine the octant */
+
+    if (d < items[quad].dist) {
+      items[quad].dist = d;
+      items[quad].item = i;
+    }
+  }
+
+  for (i=0; i<4; i++)
+    if (items[i].item != -1)
+      items[i].dist = sqrt(items[i].dist); /* now calculate the distance */
+}
+
+#ifdef NONN /* another DTLI, based only on QHULL, not nn */ 
+static void
+grid_adtli (PLFLT *x, PLFLT *y, PLFLT *z, int npts,
+	   PLFLT *xg, int nptsx, PLFLT *yg,  int nptsy, PLFLT **zg)
+{
+  coordT *points;           /* array of coordinates for each point */
+  boolT ismalloc = False;   /* True if qhull should free points */
+  char flags[250];          /* option flags for qhull */
+  facetT *facet;	    /* set by FORALLfacets */
+  vertexT *vertex, **vertexp;
+  facetT *neighbor,**neighborp;
+  int curlong, totlong;	    /* memory remaining after qh_memfreeshort */
+  FILE *outfile = NULL;
+  FILE *errfile = stderr;   /* error messages from qhull code */
+
+  int exitcode;
+  int i, j, k, l;
+  int dim = 2;
+  PLFLT xt[3], yt[3], zt[3];
+  PLFLT A, B, C, D;
+  coordT point[3];
+  boolT isoutside;
+  realT bestdist;
+  int totpart=0;
+  int numfacets, numsimplicial, numridges;
+  int totneighbors, numcoplanars, numtricoplanars;	 
+      
+  plwarn("plgriddata: GRID_DTLI, If you have QHull knowledge, FIXME.");
+
+  /* Could pass extra args to qhull through the 'data' argument of
+     plgriddata() */
+  sprintf(flags, "qhull d Qbb Qt"); 
+  points = (coordT *) malloc(npts * (dim+1) * sizeof(coordT));
+
+  for (i=0; i<npts; i++) {
+    points[i*dim] = x[i];
+    points[i*dim+1] = y[i];
+  }
+
+#if 1 /* easy way */
+  exitcode = qh_new_qhull (dim, npts, points, ismalloc,
+			   flags, outfile, errfile); 
+#else
+  qh_init_A (stdin, stdout, stderr, 0, NULL);
+  exitcode = setjmp (qh errexit);
+  if (!exitcode) {
+    qh_initflags (flags);
+    qh PROJECTdelaunay = True;
+    qh_init_B (points, npts, dim, ismalloc);
+    qh_qhull();
+  }
+#endif
+  if (!exitcode) {                  /* if no error */
+
+#if 0 /* print the triangles vertices */
+    printf("Triangles\n");
+    FORALLfacets {
+      if (!facet->upperdelaunay) {
+	FOREACHvertex_(facet->vertices)
+	  printf (" %d", qh_pointid (vertex->point)); /* vertices index */
+	printf ("\n");
+      }
+    }
+#endif
+
+#if 0 /* print each triangle neighbors */
+    printf("Neigbors\n");
+
+    qh_findgood_all (qh facet_list);
+    qh_countfacets (qh facet_list, NULL, !qh_ALL, &numfacets, &numsimplicial, 
+		    &totneighbors, &numridges, &numcoplanars, &numtricoplanars);
+
+    FORALLfacets {
+      if (!facet->upperdelaunay) {
+	FOREACHneighbor_(facet) 
+	  printf (" %d", neighbor->visitid ? neighbor->visitid - 1: - neighbor->id);
+	printf ("\n");
+      }
+    }
+#endif
+
+    /* Without the setjmp(), Qhull will exit() after reporting an error */
+    exitcode = setjmp (qh errexit);  
+    if (!exitcode) {
+      qh NOerrexit= False;
+      for(i=0; i<nptsx; i++)
+	for(j=0; j<nptsy; j++){
+	  l = 0;
+	  point[0] = xg[i];
+	  point[1] = yg[j];
+	  qh_setdelaunay (3, 1, point);
+
+
+	  /* several ways to find the triangle given a point follow.
+	     None but brute force works */
+#if 0
+	  facet = qh_findbestfacet (point, qh_ALL, &bestdist, &isoutside);
+#endif
+
+#if 0
+	  facet = qh_findbest (point, qh facet_list, qh_ALL,
+			       !qh_ISnewfacets, /*qh_ALL*/ qh_NOupper,
+			       &bestdist, &isoutside, &totpart);
+#endif
+	
+#if 0
+	  vertex = qh_nearvertex (facet, point, &bestdist);
+#endif
+
+	  /* Until someone implements a working qh_findbestfacet(),
+	   * do an exautive search!
+	   *
+	   * As far as I understand it, qh_findbestfacet() and
+	   * qh_findbest() fails when 'point' does not belongs to
+	   * the convex hull, i.e., when the search becomes blocked
+	   * when a facet is upperdelaunay (although the error
+	   * message says that the facet may be upperdelaynay or
+	   * flipped, I never found a flipped one).
+	   *
+	   * Another possibility is to implement the 'walking
+	   * triangle algorithm */
+		 
+	  facet = qh_findfacet_all( point, &bestdist, &isoutside, &totpart );
+
+	  if (facet->upperdelaunay)
+	    zg[i][j] = NaN;
+	  else {	      
+	    FOREACHvertex_(facet->vertices) {
+	      k = qh_pointid(vertex->point);
+	      xt[l] = x[k];
+	      yt[l] = y[k];
+	      zt[l] = z[k];
+	      l++;
+	    }
+
+	    /* calculate the plane passing through the three points */
+
+	    A = yt[0]*(zt[1]-zt[2]) + yt[1]*(zt[2]-zt[0]) + yt[2]*(zt[0]-zt[1]);
+	    B = zt[0]*(xt[1]-xt[2]) + zt[1]*(xt[2]-xt[0]) + zt[2]*(xt[0]-xt[1]);
+	    C = xt[0]*(yt[1]-yt[2]) + xt[1]*(yt[2]-yt[0]) + xt[2]*(yt[0]-yt[1]);
+	    D = - A*xt[0] - B*yt[0] - C*zt[0];
+
+	    /* and interpolate */
+	    zg[i][j] = - xg[i]*A/C - yg[j]*B/C - D/C;
+
+	  } 
+	}
+    }
+    qh NOerrexit= True;
+  }
+
+  free(points);
+  qh_freeqhull(!qh_ALL);                 /* free long memory */
+  qh_memfreeshort (&curlong, &totlong);  /* free short memory and memory allocator */
+  if (curlong || totlong) 
+    fprintf (errfile,
+	     "qhull: did not free %d bytes of long memory (%d pieces)\n",
+	     totlong, curlong);
+}
+#endif /* NONN */
diff --git a/collects/plot/src/all/plhist.c b/collects/plot/src/all/plhist.c
new file mode 100644
index 0000000000..7ff741de64
--- /dev/null
+++ b/collects/plot/src/all/plhist.c
@@ -0,0 +1,180 @@
+/* $Id: plhist.c,v 1.1 2004/03/01 20:54:52 cozmic Exp $
+
+	Histogram plotter.
+*/
+
+#include "plplotP.h"
+
+/*----------------------------------------------------------------------*\
+ * void plhist()
+ *
+ * Draws a histogram of n values of a variable in array data[0..n-1] in
+ * the range datmin to datmax using nbin bins. If "flags"'s first bit is 1, the
+ * histogram is plotted in the current window. If not, the routine calls
+ * "plenv" to set up the graphics environment.
+ * 
+ * If flags's second bit is set, then items which fall outside the bin
+ * range are ignored.
+ * 
+ * If flags's third bit is set, the outside bars are the same size
+ * as the rest.  The default old behaviour was for the first and last
+ * bars to expand visually to fill the entire available space.
+\*----------------------------------------------------------------------*/
+
+void
+c_plhist(PLINT n, PLFLT *data, PLFLT datmin, PLFLT datmax,
+	 PLINT nbin, PLINT flags)
+{
+    PLINT i, bin;
+    PLFLT *x, *y, dx, ymax;
+
+    if (plsc->level < 1) {
+	plabort("plhist: Please call plinit first");
+	return;
+    }
+    if (plsc->level < 3 && (flags & 1)) {
+	plabort("plhist: Please set up window first");
+	return;
+    }
+    if (datmin >= datmax) {
+	plabort("plhist: Data range invalid");
+	return;
+    }
+    if ( ! (x = (PLFLT *) malloc((size_t) nbin * sizeof(PLFLT)))) {
+	plabort("plhist: Out of memory");
+	return;
+    }
+    if ( ! (y = (PLFLT *) malloc((size_t) nbin * sizeof(PLFLT)))) {
+	free((void *) x);
+	plabort("plhist: Out of memory");
+	return;
+    }
+
+    dx = (datmax - datmin) / nbin;
+    for (i = 0; i < nbin; i++) {
+	x[i] = datmin + i * dx;
+	y[i] = 0.0;
+    }
+
+    for (i = 0; i < n; i++) {
+	bin = (data[i] - datmin) / dx;
+	if ((flags & 2) == 0) {
+	    bin = bin > 0 ? bin : 0;
+	    bin = bin < nbin ? bin : nbin - 1;
+	    y[bin]++;
+	} else {
+	    if(bin >= 0 && bin < nbin) {
+		y[bin]++;
+	    }
+	}
+    }
+
+    if (!(flags & 1)) {
+	ymax = 0.0;
+	for (i = 0; i < nbin; i++)
+	    ymax = MAX(ymax, y[i]);
+
+	plenv(datmin, datmax, (PLFLT) 0.0, (PLFLT) (1.1 * ymax), 0, 0);
+    }
+    /* We pass on the highest couple of bits to the 'plbin' routine */
+    plbin(nbin, x, y, (flags & (4+8+16+32)) >> 2);
+    free((void *) x);
+    free((void *) y);
+}
+
+/*----------------------------------------------------------------------*\
+ * void plbin()
+ *
+ * Plot a histogram using the arrays x and y to represent data values
+ * and frequencies respectively. If flags first bit is false, x values 
+ * denote the lower edge of the bin, and if it is true, they denote 
+ * the center of the bin.  If flags second bit is true, then we assume 
+ * the edge bins are the same size as the rest (i.e. the edge bins 
+ * needn't go as far as the variables vpwxmi, vpwxma below).
+\*----------------------------------------------------------------------*/
+
+void
+c_plbin(PLINT nbin, PLFLT *x, PLFLT *y, PLINT flags)
+{
+    PLINT i;
+    PLFLT xmin, xmax, vpwxmi, vpwxma, vpwymi, vpwyma;
+
+    if (plsc->level < 3) {
+	plabort("plbin: Please set up window first");
+	return;
+    }
+
+    /* Check x[i] are in ascending order */
+
+    for (i = 0; i < nbin - 1; i++) {
+	if (x[i] >= x[i + 1]) {
+	    plabort("plbin: Elements of x array must be increasing");
+	    return;
+	}
+    }
+
+    plgvpw(&vpwxmi, &vpwxma, &vpwymi, &vpwyma);
+    if (!(flags & 1)) {
+	for (i = 0; i < nbin - 1; i++) {
+	    if (!(flags & 4) || (y[i] != vpwymi)) {
+		pljoin(x[i], vpwymi, x[i], y[i]);
+		pljoin(x[i], y[i], x[i + 1], y[i]);
+		pljoin(x[i + 1], y[i], x[i + 1], vpwymi);
+	    }
+	}
+	if (flags & 2) {
+	    if (!(flags & 4) || (y[i] != vpwymi)) {
+		int xm = x[i] + (x[i] - x[i-1]);
+		pljoin(x[i], vpwymi, x[i], y[i]);
+		pljoin(x[i], y[i], xm, y[i]);
+		pljoin(xm, y[i], xm, vpwymi);
+	    }
+	} else {
+	    if (x[i] < vpwxma) {
+		if (!(flags & 4) || (y[i] != vpwymi)) {
+		    pljoin(x[i], vpwymi, x[i], y[i]);
+		    pljoin(x[i], y[i], vpwxma, y[i]);
+		    pljoin(vpwxma, y[i], vpwxma, vpwymi);
+		}
+	    }
+	}
+    } else {
+	if (nbin < 2)
+	    return;
+	if (flags & 2) {
+	    xmin = MAX(vpwxmi, 0.5 * (3 * x[0] - x[1]));
+	} else {
+	    xmin = vpwxmi;
+	}
+	/* Vince fixed bug May 1998 */
+	xmax = MAX(0.5 * (x[0] + x[1]), vpwxmi);
+	if (xmin < xmax) {
+	    pljoin(xmin, vpwymi, xmin, y[0]);
+	    pljoin(xmin, y[0], xmax, y[0]);
+	    pljoin(xmax, y[0], xmax, vpwymi);
+	}
+	for (i = 1; i < nbin - 1; i++) {
+	    xmin = xmax;
+	    xmax = MIN(0.5 * (x[i] + x[i + 1]), vpwxma);
+	    if (!(flags & 4) || (y[i] != vpwymi)) {
+		pljoin(xmin, vpwymi, xmin, y[i]);
+		pljoin(xmin, y[i], xmax, y[i]);
+		pljoin(xmax, y[i], xmax, vpwymi);
+	    }
+	}
+	xmin = xmax;
+	xmax = vpwxma;
+	if (flags & 2) {
+	    xmax = MIN(vpwxma, 0.5 * (3 * x[i] - x[i-1]));
+	} else {
+	    xmax = vpwxma;
+	}
+	if (xmin < xmax) {
+	    if (!(flags & 4) || (y[i] != vpwymi)) {
+		pljoin(xmin, vpwymi, xmin, y[i]);
+		pljoin(xmin, y[i], xmax, y[i]);
+		pljoin(xmax, y[i], xmax, vpwymi);
+	    }
+	}
+    }
+}
diff --git a/collects/plot/src/all/plimage.c b/collects/plot/src/all/plimage.c
new file mode 100644
index 0000000000..b800578a91
--- /dev/null
+++ b/collects/plot/src/all/plimage.c
@@ -0,0 +1,235 @@
+/* plimage() 
+ *
+ * Author: Alessandro Mirone, Nov 2001
+ * Adapted: Joao Cardoso
+ */
+
+#include "plplotP.h"
+
+/* Get better names, those are too criptic!
+ * 
+ * ZEROW2B: zero writing to buffer ?
+ * ZEROW2D: zero writing to display ?
+ * ONEW2B: set writing to buffer ?
+ * ONEW2D: set writing to display ?
+ */
+
+void
+NoBufferNoPixmap()
+{
+  PLINT op = ZEROW2B; 
+
+  plsc->plbuf_write = 0; /* TODO: store previous state */
+  plP_esc(PLESC_EXPOSE, NULL);
+  plP_esc(PLESC_IMAGEOPS, &op);
+}
+
+void
+RestoreWrite2BufferPixmap()
+{
+  PLINT op = ONEW2B;
+
+  plsc->plbuf_write = 1; /* TODO: revert from previous state */
+  plP_esc(PLESC_IMAGEOPS, &op);
+}
+
+void
+disabledisplay()
+{
+  PLINT op = ZEROW2D;
+
+  plP_esc(PLESC_IMAGEOPS, &op);
+}
+
+void
+enabledisplay()
+{
+  PLINT op = ONEW2D;
+
+  plP_esc(PLESC_IMAGEOPS, &op);
+  plP_esc(PLESC_EXPOSE, NULL); 
+}
+
+
+
+void
+plimageslow(short *x, short *y, unsigned short *data, PLINT nx, PLINT ny, 
+	    PLFLT xmin, PLFLT ymin, PLFLT dx, PLFLT dy,
+	    unsigned short zmin, unsigned short zmax)
+{
+  PLINT ix, iy, i;
+  PLFLT xf[4], yf[4];
+  short xs[5], ys[5];
+  int corners[4];
+  unsigned short col;
+
+  for (ix = 0; ix < nx ; ix++) {
+    for (iy = 0; iy < ny ; iy++) {
+
+      col = data[ix*ny+iy];
+      /* only plot points within zmin/zmax range */
+      if (col < zmin || col > zmax)
+	continue;
+
+      plcol1(col/(float)USHRT_MAX);
+
+      if (plsc->plbuf_read == 1) {
+	/* buffer read, is a replot to a slow device. */
+
+	corners[0] = ix*(ny+1)+iy;       /* [ix][iy] */
+	corners[1] = (ix+1)*(ny+1)+iy;   /* [ix+1][iy] */
+	corners[2] = (ix+1)*(ny+1)+iy+1; /* [ix+1][iy+1] */
+	corners[3] = ix*(ny+1)+iy+1;     /* [ix][iy+1] */
+
+	for (i = 0; i < 4; i++) {
+	  xs[i] = x[corners[i]];
+	  ys[i] = y[corners[i]];
+	}
+	xs[4] = xs[0]; ys[4] = ys[0];
+	plP_fill(xs, ys, 5);
+
+      } else {
+
+	xf[0] = xf[1] = ix;
+	xf[2] = xf[3] = ix+1;
+	yf[0] = yf[3] = iy;
+	yf[1] = yf[2] = iy+1;
+
+	for (i = 0; i < 4; i++) {
+	  xf[i] = xmin + xf[i]*dx;
+	  yf[i] = ymin + yf[i]*dy;
+	}
+	plfill(4, xf, yf);
+      }
+    }
+  }
+}
+
+void
+grimage(short *x, short *y, unsigned short *z, PLINT nx, PLINT ny)
+{
+    plsc->dev_ix = x;
+    plsc->dev_iy = y;
+    plsc->dev_z = z;
+    plsc->dev_nptsX = nx;
+    plsc->dev_nptsY = ny;
+
+    plP_esc(PLESC_IMAGE, NULL);
+}
+
+/*-------------------------------------------------------------------------*\
+ * plimage
+ *           (***** SUBJECT TO CHANGE ******)
+ *
+ * arguments are
+ *   data: array containing image data
+ *   nx: dimension of the array in the X axis.        
+ *   ny: dimension of the  array in the Y axis 
+ *   The array data is indexed like data[ix][iy]
+ *
+ *   xmin, xmax, ymin, ymax:
+ *       data[0][0] corresponds to (xmin,ymin)
+ *       data[nx-1][ny-1] to (xmax,ymax)
+ *
+ *   zmin, zmax:
+ *       only data within bounds zmin <= data <= zmax will be
+ *       plotted. If zmin == zmax, all data will be ploted.
+ *
+ *   Dxmin, Dxmax, Dymin, Dymax:
+ *       plots only the window of points whose(x,y)'s fall
+ *       inside the [Dxmin->Dxmax]X[Dymin->Dymax] window
+ *
+\*-------------------------------------------------------------------------*/
+
+void
+plimage(PLFLT **idata, PLINT nx, PLINT ny, 
+	PLFLT xmin, PLFLT xmax, PLFLT ymin, PLFLT ymax, PLFLT zmin, PLFLT zmax,
+	PLFLT Dxmin, PLFLT Dxmax, PLFLT Dymin, PLFLT Dymax)
+{
+  PLINT nnx, nny, ix, iy, ixx, iyy, xm, ym;
+  PLFLT dx, dy;
+  unsigned short *Zf, szmin, szmax;
+  short *Xf, *Yf;
+  PLFLT lzmin, lzmax, tz;
+  
+  if (plsc->level < 3) {
+    plabort("plimage: window must be set up first");
+    return;
+  }
+
+  if (nx <= 0 || ny <= 0) {
+    plabort("plimage: nx and ny must be positive");
+    return;
+  }
+
+  if (Dxmin < xmin || Dxmax > xmax || Dymin < ymin || Dymax > ymax){
+    plabort("plimage: Dxmin or Dxmax or Dymin or Dymax not compatible with xminor xmax or ymin or ymax.");
+    return;
+  }
+
+  dx = (xmax - xmin) / (nx - 1);
+  dy = (ymax - ymin) / (ny - 1);
+  nnx = (Dxmax-Dxmin)/dx + 1;
+  nny = (Dymax-Dymin)/dy + 1;
+
+  Zf = (unsigned short *) malloc(nny*nnx*sizeof(unsigned short));
+
+  xm = floor((Dxmin-xmin)/dx); ym = floor((Dymin-ymin)/dy);
+  lzmin = lzmax = idata[xm][ym];
+  
+  for (ix=xm; ix<xm+nnx; ix++) {
+    for (iy=ym; iy<ym+nny; iy++) {
+      tz = idata[ix][iy];
+      if (lzmax < tz)
+	lzmax = tz;
+      if (lzmin > tz)
+	lzmin = tz;
+    }
+  }
+
+  ixx=-1;
+  for (ix=xm; ix<xm+nnx; ix++) {
+    ixx++; iyy=0;
+    for (iy=ym; iy<ym+nny; iy++)
+      Zf[ixx*nny+iyy++] = (idata[ix][iy] - lzmin)/(lzmax-lzmin)*USHRT_MAX;
+  }
+
+  if (zmin == zmax) {
+    zmin = lzmin;
+    zmax = lzmax;
+  } else {
+    if (zmin < lzmin)
+      zmin = lzmin;
+
+    if (zmax > lzmax)
+      zmax = lzmax;
+  }
+
+  szmin = (zmin - lzmin)/(lzmax-lzmin)*USHRT_MAX;
+  szmax = (zmax - lzmin)/(lzmax-lzmin)*USHRT_MAX;
+
+  xmin = Dxmin;  xmax = Dxmax;
+  ymin = Dymin;  ymax = Dymax;
+
+  /* The X and Y arrays has size nnx*nny */
+  nnx++; nny++;
+
+  Xf = (short *) malloc(nny*nnx*sizeof(short));
+  Yf = (short *) malloc(nny*nnx*sizeof(short));
+
+  /* adjust the step for the X/Y arrays */
+  dx = dx*(nx-1)/nx;
+  dy = dy*(ny-1)/ny;
+
+  for (ix = 0; ix < nnx; ix++)
+    for (iy = 0; iy < nny; iy++) {      
+      Xf[ix*nny+iy] =  plP_wcpcx(xmin + ix*dx);
+      Yf[ix*nny+iy] =  plP_wcpcy(ymin + iy*dy);
+    }
+
+  plP_image(Xf, Yf, Zf, nnx, nny, xmin, ymin, dx, dy, szmin, szmax);
+
+  free(Xf);
+  free(Yf);
+  free(Zf);
+}
diff --git a/collects/plot/src/all/plline.c b/collects/plot/src/all/plline.c
new file mode 100644
index 0000000000..4c608c09ef
--- /dev/null
+++ b/collects/plot/src/all/plline.c
@@ -0,0 +1,927 @@
+/* $Id: plline.c,v 1.2 2005/03/17 21:39:21 eli Exp $
+
+	Routines dealing with line generation.
+*/
+
+#include "plplotP.h"
+
+#define INSIDE(ix,iy) (BETW(ix,xmin,xmax) && BETW(iy,ymin,ymax))
+
+static PLINT xline[PL_MAXPOLY], yline[PL_MAXPOLY];
+
+static PLINT lastx = PL_UNDEFINED, lasty = PL_UNDEFINED;
+
+/* Function prototypes */
+
+/* Draws a polyline within the clip limits. */
+
+static void
+pllclp(PLINT *x, PLINT *y, PLINT npts);
+
+/* Get clipped endpoints */
+
+static int
+clipline(PLINT *p_x1, PLINT *p_y1, PLINT *p_x2, PLINT *p_y2,
+	 PLINT xmin, PLINT xmax, PLINT ymin, PLINT ymax);
+
+/* General line-drawing routine.  Takes line styles into account. */
+
+static void
+genlin(short *x, short *y, PLINT npts);
+
+/* Draws a dashed line to the specified point from the previous one. */
+
+static void
+grdashline(short *x, short *y);
+
+/*----------------------------------------------------------------------*\
+ * void pljoin()
+ *
+ * Draws a line segment from (x1, y1) to (x2, y2).
+\*----------------------------------------------------------------------*/
+
+MZ_DLLEXPORT
+void
+c_pljoin(PLFLT x1, PLFLT y1, PLFLT x2, PLFLT y2)
+{
+    plP_movwor(x1, y1);
+    plP_drawor(x2, y2);
+}
+
+/*----------------------------------------------------------------------*\
+ * void plline()
+ *
+ * Draws line segments connecting a series of points.
+\*----------------------------------------------------------------------*/
+
+MZ_DLLEXPORT
+void
+c_plline(PLINT n, PLFLT *x, PLFLT *y)
+{
+    if (plsc->level < 3) {
+	plabort("plline: Please set up window first");
+	return;
+    }
+    plP_drawor_poly(x, y, n);
+}
+
+/*----------------------------------------------------------------------*\
+ * void plline3(n, x, y, z)
+ *
+ * Draws a line in 3 space.  You must first set up the viewport, the
+ * 2d viewing window (in world coordinates), and the 3d normalized
+ * coordinate box.  See x18c.c for more info.
+ *
+ * This version adds clipping against the 3d bounding box specified in plw3d
+
+ MZ_DLLEXPORT\*----------------------------------------------------------------------*/
+void
+c_plline3(PLINT n, PLFLT *x, PLFLT *y, PLFLT *z)
+{
+    int i;
+    PLFLT vmin[3], vmax[3], zscale;
+
+    if (plsc->level < 3) {
+	plabort("plline3: Please set up window first");
+	return;
+    }
+
+    /* get the bounding box in 3d */
+    plP_gdom(&vmin[0], &vmax[0], &vmin[1], &vmax[1]);
+    plP_grange(&zscale, &vmin[2], &vmax[2]);
+
+    /* interate over the vertices */
+    for( i=0; i < n-1; i++ ) {
+      PLFLT p0[3], p1[3];
+      int axis;
+
+      /* copy the end points of the segment to allow clipping */
+      p0[0] = x[i]; p0[1] = y[i]; p0[2] = z[i];
+      p1[0] = x[i+1]; p1[1] = y[i+1]; p1[2] = z[i+1];
+
+      /* check against each axis of the bounding box */
+      for(axis = 0; axis < 3; axis++) {
+	if(p0[axis] < vmin[axis]) { /* first out */
+	  if(p1[axis] < vmin[axis]) {
+	    break; /* both endpoints out so quit */
+	  } else {
+	    int j;
+	    /* interpolate to find intersection with box */
+	    PLFLT t = (vmin[axis] - p0[axis]) / (p1[axis] - p0[axis]);
+	    p0[axis] = vmin[axis];
+	    for(j = 1; j<3; j++) {
+	      int k = (axis+j)%3;
+	      p0[k] = (1-t)*p0[k] + t*p1[k];
+	    }
+	  }
+	} else if(p1[axis] < vmin[axis]) { /* second out */
+	  int j;
+	  /* interpolate to find intersection with box */
+	  PLFLT t = (vmin[axis] - p0[axis]) / (p1[axis] - p0[axis]);
+	  p1[axis] = vmin[axis];
+	  for(j = 1; j<3; j++) {
+	    int k = (axis+j)%3;
+	    p1[k] = (1-t)*p0[k] + t*p1[k];
+	  }
+	}
+	if(p0[axis] > vmax[axis]) { /* first out */
+	  if(p1[axis] > vmax[axis]) {
+	    break; /* both out so quit */
+	  } else {
+	    int j;
+	    /* interpolate to find intersection with box */
+	    PLFLT t = (vmax[axis] - p0[axis]) / (p1[axis] - p0[axis]);
+	    p0[axis] = vmax[axis];
+	    for(j = 1; j<3; j++) {
+	      int k = (axis+j)%3;
+	      p0[k] = (1-t)*p0[k] + t*p1[k];
+	    }
+	  }
+	} else if(p1[axis] > vmax[axis]) { /* second out */
+	  int j;
+	  /* interpolate to find intersection with box */
+	  PLFLT t = (vmax[axis] - p0[axis]) / (p1[axis] - p0[axis]);
+	  p1[axis] = vmax[axis];
+	  for(j = 1; j<3; j++) {
+	    int k = (axis+j)%3;
+	    p1[k] = (1-t)*p0[k] + t*p1[k];
+	  }
+	}
+      }
+      /* if we made it to here without "break"ing out of the loop, the 
+	 remaining segment is visible */
+      if( axis == 3 ) { /*  not clipped away */
+	PLFLT u0, v0, u1, v1;
+	u0 = plP_wcpcx(plP_w3wcx( p0[0], p0[1], p0[2] ));
+	v0 = plP_wcpcy(plP_w3wcy( p0[0], p0[1], p0[2] ));
+	u1 = plP_wcpcx(plP_w3wcx( p1[0], p1[1], p1[2] ));
+	v1 = plP_wcpcy(plP_w3wcy( p1[0], p1[1], p1[2] ));
+	plP_movphy(u0,v0);
+	plP_draphy(u1,v1);
+      }
+    }
+    return;
+}
+/*----------------------------------------------------------------------*\
+ * void plpoly3( n, x, y, z, draw, ifcc )
+ *
+ * Draws a polygon in 3 space.  This differs from plline3() in that
+ * this attempts to determine if the polygon is viewable.  If the back
+ * of polygon is facing the viewer, then it isn't drawn.  If this
+ * isn't what you want, then use plline3 instead.
+ *
+ * n specifies the number of points.  They are assumed to be in a
+ * plane, and the directionality of the plane is determined from the
+ * first three points.  Additional points do not /have/ to lie on the
+ * plane defined by the first three, but if they do not, then the
+ * determiniation of visibility obviously can't be 100% accurate...
+ * So if you're 3 space polygons are too far from planar, consider
+ * breaking them into smaller polygons.  "3 points define a plane" :-).
+ *
+ * For ifcc == 1, the directionality of the polygon is determined by assuming
+ * the points are laid out in counter-clockwise order.
+ *
+ * For ifcc == 0, the directionality of the polygon is determined by assuming
+ * the points are laid out in clockwise order.
+ *
+ * BUGS:  If one of the first two segments is of zero length, or if
+ * they are colinear, the calculation of visibility has a 50/50 chance
+ * of being correct.  Avoid such situations :-).  See x18c for an
+ * example of this problem.  (Search for "20.1").
+\*----------------------------------------------------------------------*/
+
+MZ_DLLEXPORT
+void
+c_plpoly3(PLINT n, PLFLT *x, PLFLT *y, PLFLT *z, PLINT *draw, PLINT ifcc)
+{
+    int i;
+    PLFLT vmin[3], vmax[3], zscale;
+    PLFLT u1, v1, u2, v2, u3, v3;
+    PLFLT c;
+
+    if (plsc->level < 3) {
+	plabort("plpoly3: Please set up window first");
+	return;
+    }
+
+    if ( n < 3 ) {
+	plabort("plpoly3: Must specify at least 3 points");
+	return;
+    }
+
+/* Now figure out which side this is. */
+
+    u1 = plP_wcpcx(plP_w3wcx( x[0], y[0], z[0] ));
+    v1 = plP_wcpcy(plP_w3wcy( x[0], y[0], z[0] ));
+
+    u2 = plP_wcpcx(plP_w3wcx( x[1], y[1], z[1] ));
+    v2 = plP_wcpcy(plP_w3wcy( x[1], y[1], z[1] ));
+
+    u3 = plP_wcpcx(plP_w3wcx( x[2], y[2], z[2] ));
+    v3 = plP_wcpcy(plP_w3wcy( x[2], y[2], z[2] ));
+
+    c = (u1-u2)*(v3-v2)-(v1-v2)*(u3-u2);
+
+    if ( c *(1 - 2*ifcc) < 0. )
+        return;
+
+    /* get the bounding box in 3d */
+    plP_gdom(&vmin[0], &vmax[0], &vmin[1], &vmax[1]);
+    plP_grange(&zscale, &vmin[2], &vmax[2]);
+
+    /* interate over the vertices */
+    for( i=0; i < n-1; i++ ) {
+      PLFLT p0[3], p1[3];
+      int axis;
+
+      /* copy the end points of the segment to allow clipping */
+      p0[0] = x[i]; p0[1] = y[i]; p0[2] = z[i];
+      p1[0] = x[i+1]; p1[1] = y[i+1]; p1[2] = z[i+1];
+
+      /* check against each axis of the bounding box */
+      for(axis = 0; axis < 3; axis++) {
+	if(p0[axis] < vmin[axis]) { /* first out */
+	  if(p1[axis] < vmin[axis]) {
+	    break; /* both endpoints out so quit */
+	  } else {
+	    int j;
+	    /* interpolate to find intersection with box */
+	    PLFLT t = (vmin[axis] - p0[axis]) / (p1[axis] - p0[axis]);
+	    p0[axis] = vmin[axis];
+	    for(j = 1; j<3; j++) {
+	      int k = (axis+j)%3;
+	      p0[k] = (1-t)*p0[k] + t*p1[k];
+	    }
+	  }
+	} else if(p1[axis] < vmin[axis]) { /* second out */
+	  int j;
+	  /* interpolate to find intersection with box */
+	  PLFLT t = (vmin[axis] - p0[axis]) / (p1[axis] - p0[axis]);
+	  p1[axis] = vmin[axis];
+	  for(j = 1; j<3; j++) {
+	    int k = (axis+j)%3;
+	    p1[k] = (1-t)*p0[k] + t*p1[k];
+	  }
+	}
+	if(p0[axis] > vmax[axis]) { /* first out */
+	  if(p1[axis] > vmax[axis]) {
+	    break; /* both out so quit */
+	  } else {
+	    int j;
+	    /* interpolate to find intersection with box */
+	    PLFLT t = (vmax[axis] - p0[axis]) / (p1[axis] - p0[axis]);
+	    p0[axis] = vmax[axis];
+	    for(j = 1; j<3; j++) {
+	      int k = (axis+j)%3;
+	      p0[k] = (1-t)*p0[k] + t*p1[k];
+	    }
+	  }
+	} else if(p1[axis] > vmax[axis]) { /* second out */
+	  int j;
+	  /* interpolate to find intersection with box */
+	  PLFLT t = (vmax[axis] - p0[axis]) / (p1[axis] - p0[axis]);
+	  p1[axis] = vmax[axis];
+	  for(j = 1; j<3; j++) {
+	    int k = (axis+j)%3;
+	    p1[k] = (1-t)*p0[k] + t*p1[k];
+	  }
+	}
+      }
+      /* if we made it to here without "break"ing out of the loop, the 
+	 remaining segment is visible */
+      if( axis == 3 && draw[i] ) { /*  not clipped away */
+	PLFLT u0, v0, u1, v1;
+	u0 = plP_wcpcx(plP_w3wcx( p0[0], p0[1], p0[2] ));
+	v0 = plP_wcpcy(plP_w3wcy( p0[0], p0[1], p0[2] ));
+	u1 = plP_wcpcx(plP_w3wcx( p1[0], p1[1], p1[2] ));
+	v1 = plP_wcpcy(plP_w3wcy( p1[0], p1[1], p1[2] ));
+	plP_movphy(u0,v0);
+	plP_draphy(u1,v1);
+      }
+    }
+    return;
+}
+
+/*----------------------------------------------------------------------*\
+ * void plstyl()
+ *
+ * Set up a new line style of "nms" elements, with mark and space
+ * lengths given by arrays "mark" and "space".
+\*----------------------------------------------------------------------*/
+
+void
+c_plstyl(PLINT nms, PLINT *mark, PLINT *space)
+{
+    short int i;
+
+    if (plsc->level < 1) {
+	plabort("plstyl: Please call plinit first");
+	return;
+    }
+    if ((nms < 0) || (nms > 10)) {
+	plabort("plstyl: Broken lines cannot have <0 or >10 elements");
+	return;
+    }
+    for (i = 0; i < nms; i++) {
+	if ((mark[i] < 0) || (space[i] < 0)) {
+	    plabort("plstyl: Mark and space lengths must be > 0");
+	    return;
+	}
+    }
+
+    plsc->nms = nms;
+    for (i = 0; i < nms; i++) {
+	plsc->mark[i] = mark[i];
+	plsc->space[i] = space[i];
+    }
+
+    plsc->curel = 0;
+    plsc->pendn = 1;
+    plsc->timecnt = 0;
+    plsc->alarm = nms > 0 ? mark[0] : 0;
+}
+
+/*----------------------------------------------------------------------*\
+ * void plP_movphy()
+ *
+ * Move to physical coordinates (x,y).
+\*----------------------------------------------------------------------*/
+
+void
+plP_movphy(PLINT x, PLINT y)
+{
+    plsc->currx = x;
+    plsc->curry = y;
+}
+
+/*----------------------------------------------------------------------*\
+ * void plP_draphy()
+ *
+ * Draw to physical coordinates (x,y).
+\*----------------------------------------------------------------------*/
+
+void
+plP_draphy(PLINT x, PLINT y)
+{
+    xline[0] = plsc->currx;
+    xline[1] = x;
+    yline[0] = plsc->curry;
+    yline[1] = y;
+
+    pllclp(xline, yline, 2);
+}
+
+/*----------------------------------------------------------------------*\
+ * void plP_movwor()
+ *
+ * Move to world coordinates (x,y).
+\*----------------------------------------------------------------------*/
+
+void
+plP_movwor(PLFLT x, PLFLT y)
+{
+    plsc->currx = plP_wcpcx(x);
+    plsc->curry = plP_wcpcy(y);
+}
+
+/*----------------------------------------------------------------------*\
+ * void plP_drawor()
+ *
+ * Draw to world coordinates (x,y).
+\*----------------------------------------------------------------------*/
+
+void
+plP_drawor(PLFLT x, PLFLT y)
+{
+    xline[0] = plsc->currx;
+    xline[1] = plP_wcpcx(x);
+    yline[0] = plsc->curry;
+    yline[1] = plP_wcpcy(y);
+
+    pllclp(xline, yline, 2);
+}
+
+/*----------------------------------------------------------------------*\
+ * void plP_draphy_poly()
+ *
+ * Draw polyline in physical coordinates.
+ * Need to draw buffers in increments of (PL_MAXPOLY-1) since the
+ * last point must be repeated (for solid lines).
+\*----------------------------------------------------------------------*/
+
+void
+plP_draphy_poly(PLINT *x, PLINT *y, PLINT n)
+{
+    PLINT i, j, ib, ilim;
+
+    for (ib = 0; ib < n; ib += PL_MAXPOLY - 1) {
+	ilim = MIN(PL_MAXPOLY, n - ib);
+
+	for (i = 0; i < ilim; i++) {
+	    j = ib + i;
+	    xline[i] = x[j];
+	    yline[i] = y[j];
+	}
+	pllclp(xline, yline, ilim);
+    }
+}
+
+/*----------------------------------------------------------------------*\
+ * void plP_drawor_poly()
+ *
+ * Draw polyline in world coordinates.
+ * Need to draw buffers in increments of (PL_MAXPOLY-1) since the
+ * last point must be repeated (for solid lines).
+\*----------------------------------------------------------------------*/
+
+void
+plP_drawor_poly(PLFLT *x, PLFLT *y, PLINT n)
+{
+    PLINT i, j, ib, ilim;
+
+    for (ib = 0; ib < n; ib += PL_MAXPOLY - 1) {
+	ilim = MIN(PL_MAXPOLY, n - ib);
+
+	for (i = 0; i < ilim; i++) {
+	    j = ib + i;
+	    xline[i] = plP_wcpcx(x[j]);
+	    yline[i] = plP_wcpcy(y[j]);
+	}
+	pllclp(xline, yline, ilim);
+    }
+}
+
+/*----------------------------------------------------------------------*\
+ * void pllclp()
+ *
+ * Draws a polyline within the clip limits.
+ * Merely a front-end to plP_pllclp().
+\*----------------------------------------------------------------------*/
+
+static void
+pllclp(PLINT *x, PLINT *y, PLINT npts)
+{
+    plP_pllclp(x, y, npts, plsc->clpxmi, plsc->clpxma,
+	       plsc->clpymi, plsc->clpyma, genlin);
+}
+
+/*----------------------------------------------------------------------*\
+ * void plP_pllclp()
+ *
+ * Draws a polyline within the clip limits.
+\*----------------------------------------------------------------------*/
+
+void
+plP_pllclp(PLINT *x, PLINT *y, PLINT npts,
+	   PLINT xmin, PLINT xmax, PLINT ymin, PLINT ymax, 
+	   void (*draw) (short *, short *, PLINT))
+{
+    PLINT x1, x2, y1, y2;
+    PLINT i, iclp = 0;
+    short xclp[PL_MAXPOLY], yclp[PL_MAXPOLY];
+    int drawable;
+
+    for (i = 0; i < npts - 1; i++) {
+	x1 = x[i];
+	x2 = x[i + 1];
+	y1 = y[i];
+	y2 = y[i + 1];
+
+	drawable = (INSIDE(x1, y1) && INSIDE(x2, y2));
+	if ( ! drawable)
+	    drawable = ! clipline(&x1, &y1, &x2, &y2, xmin, xmax, ymin, ymax);
+
+	if (drawable) {
+
+/* First point of polyline. */
+
+	    if (iclp == 0) {
+		xclp[iclp] = x1;
+		yclp[iclp] = y1;
+		iclp++;
+		xclp[iclp] = x2;
+		yclp[iclp] = y2;
+	    }
+
+/* Not first point.  Check if first point of this segment matches up to 
+   previous point, and if so, add it to the current polyline buffer. */
+
+	    else if (x1 == xclp[iclp] && y1 == yclp[iclp]) {
+		iclp++;
+		xclp[iclp] = x2;
+		yclp[iclp] = y2;
+	    }
+
+/* Otherwise it's time to start a new polyline */
+
+	    else {
+		if (iclp + 1 >= 2)
+		    (*draw)(xclp, yclp, iclp + 1);
+		iclp = 0;
+		xclp[iclp] = x1;
+		yclp[iclp] = y1;
+		iclp++;
+		xclp[iclp] = x2;
+		yclp[iclp] = y2;
+	    }
+	}
+    }
+
+/* Handle remaining polyline */
+
+    if (iclp + 1 >= 2)
+	(*draw)(xclp, yclp, iclp + 1);
+
+    plsc->currx = x[npts-1];
+    plsc->curry = y[npts-1];
+}
+
+/*----------------------------------------------------------------------*\
+ * void plP_plfclp()
+ *
+ * Fills a polygon within the clip limits.
+\*----------------------------------------------------------------------*/
+
+void
+plP_plfclp(PLINT *x, PLINT *y, PLINT npts,
+	   PLINT xmin, PLINT xmax, PLINT ymin, PLINT ymax, 
+	   void (*draw) (short *, short *, PLINT))
+{
+    PLINT x1, x2, y1, y2;
+    PLINT i, iclp = -1;
+    short xclp[PL_MAXPOLY], yclp[PL_MAXPOLY];
+    int drawable;
+
+    for (i = 0; i < npts - 1; i++) {
+	x1 = x[i];
+	x2 = x[i + 1];
+	y1 = y[i];
+	y2 = y[i + 1];
+
+	drawable = (INSIDE(x1, y1) && INSIDE(x2, y2));
+	if ( ! drawable)
+	    drawable = ! clipline(&x1, &y1, &x2, &y2, xmin, xmax, ymin, ymax);
+
+	if (drawable) {
+
+/* Not first point.  If first point of this segment matches up to the
+   previous point, just add it.  */
+
+	    if (iclp >= 0 && x1 == xclp[iclp] && y1 == yclp[iclp]) {
+		iclp++;
+		xclp[iclp] = x2;
+		yclp[iclp] = y2;
+	    }
+
+/* First point of polyline, OR . */
+
+/* If not, we need to add both points, to connect the points in the
+ * polygon along the clip boundary.  If any of the previous points were
+ * outside one of the 4 corners, assume the corner was encircled and add
+ * it first. 
+ */
+	    else {
+		iclp++;
+		xclp[iclp] = x1;
+		yclp[iclp] = y1;
+
+		if ((x1 == xmin && y2 == ymin) ||
+		    (x2 == xmin && y1 == ymin)) {
+		    iclp++;
+		    xclp[iclp] = xmin;
+		    yclp[iclp] = ymin;
+		}
+		else if ((x1 == xmax && y2 == ymin) ||
+			 (x2 == xmax && y1 == ymin)) {
+		    iclp++;
+		    xclp[iclp] = xmax;
+		    yclp[iclp] = ymin;
+		}
+		else if ((x1 == xmax && y2 == ymax) ||
+			 (x2 == xmax && y1 == ymax)) {
+		    iclp++;
+		    xclp[iclp] = xmax;
+		    yclp[iclp] = ymax;
+		}
+		else if ((x1 == xmin && y2 == ymax) ||
+			 (x2 == xmin && y1 == ymax)) {
+		    iclp++;
+		    xclp[iclp] = xmin;
+		    yclp[iclp] = ymax;
+		}
+	    /* Experimental code from way back.
+	       Polygon clipping is HARD.
+		{
+		    int j;
+		    for (j = 0; j < i; j++) {
+			if (x[j] < xmin && y[j] < ymin) {
+			    break;
+			}
+			else if (x[j] < xmin && y[j] > ymax) {
+			    iclp++;
+			    xclp[iclp] = xmin;
+			    yclp[iclp] = ymax;
+			    break;
+			}
+			else if (x[j] > xmax && y[j] < ymin) {
+			    iclp++;
+			    xclp[iclp] = xmax;
+			    yclp[iclp] = ymin;
+			    break;
+			}
+			else if (x[j] > xmax && y[j] > ymax) {
+			    iclp++;
+			    xclp[iclp] = xmax;
+			    yclp[iclp] = ymax;
+			    break;
+			}
+		    }
+		}
+	    */
+		iclp++;
+		xclp[iclp] = x2;
+		yclp[iclp] = y2;
+	    }
+	}
+    }
+
+/* Draw the sucker */
+
+    if (iclp + 1 >= 2) {
+	if ((xclp[0] == xmin && yclp[iclp] == ymin) ||
+	    (xclp[iclp] == xmin && yclp[0] == ymin)) {
+	    iclp++;
+	    xclp[iclp] = xmin;
+	    yclp[iclp] = ymin;
+	}
+	else if ((xclp[0] == xmax && yclp[iclp] == ymin) ||
+		 (xclp[iclp] == xmax && yclp[0] == ymin)) {
+	    iclp++;
+	    xclp[iclp] = xmax;
+	    yclp[iclp] = ymin;
+	}
+	else if ((xclp[0] == xmax && yclp[iclp] == ymax) ||
+		 (xclp[iclp] == xmax && yclp[0] == ymax)) {
+	    iclp++;
+	    xclp[iclp] = xmax;
+	    yclp[iclp] = ymax;
+	}
+	else if ((xclp[0] == xmin && yclp[iclp] == ymax) ||
+		 (xclp[iclp] == xmin && yclp[0] == ymax)) {
+	    iclp++;
+	    xclp[iclp] = xmin;
+	    yclp[iclp] = ymax;
+	}
+    }
+    if (iclp + 1 >= 3) {
+      if(draw)
+	(*draw)(xclp, yclp, iclp + 1);
+    }
+}
+
+/*----------------------------------------------------------------------*\
+ * int clipline()
+ *
+ * Get clipped endpoints
+\*----------------------------------------------------------------------*/
+
+static int
+clipline(PLINT *p_x1, PLINT *p_y1, PLINT *p_x2, PLINT *p_y2,
+	 PLINT xmin, PLINT xmax, PLINT ymin, PLINT ymax)
+{
+    PLINT t, dx, dy, flipx, flipy;
+    double dydx = 0, dxdy = 0;
+
+/* If both points are outside clip region with no hope of intersection,
+   return with an error */
+
+    if ((*p_x1 <= xmin && *p_x2 <= xmin) ||
+	(*p_x1 >= xmax && *p_x2 >= xmax) ||
+	(*p_y1 <= ymin && *p_y2 <= ymin) ||
+	(*p_y1 >= ymax && *p_y2 >= ymax))
+	return 1;
+
+    flipx = 0;
+    flipy = 0;
+
+    if (*p_x2 < *p_x1) {
+	*p_x1 = 2 * xmin - *p_x1;
+	*p_x2 = 2 * xmin - *p_x2;
+	xmax = 2 * xmin - xmax;
+	t = xmax;
+	xmax = xmin;
+	xmin = t;
+	flipx = 1;
+    }
+
+    if (*p_y2 < *p_y1) {
+	*p_y1 = 2 * ymin - *p_y1;
+	*p_y2 = 2 * ymin - *p_y2;
+	ymax = 2 * ymin - ymax;
+	t = ymax;
+	ymax = ymin;
+	ymin = t;
+	flipy = 1;
+    }
+
+    dx = *p_x2 - *p_x1;
+    dy = *p_y2 - *p_y1;
+
+    if (dx != 0 && dy != 0) {
+	dydx = (double) dy / (double) dx;
+	dxdy = 1./ dydx;
+    }
+
+    if (*p_x1 < xmin) {
+	if (dx != 0 && dy != 0)
+	    *p_y1 = *p_y1 + ROUND((xmin - *p_x1) * dydx);
+	*p_x1 = xmin;
+    }
+
+    if (*p_y1 < ymin) {
+	if (dx != 0 && dy != 0)
+	    *p_x1 = *p_x1 + ROUND((ymin - *p_y1) * dxdy);
+	*p_y1 = ymin;
+    }
+
+    if (*p_x1 >= xmax || *p_y1 >= ymax)
+	return 1;
+
+    if (*p_y2 > ymax) {
+	if (dx != 0 && dy != 0)
+	    *p_x2 = *p_x2 - ROUND((*p_y2 - ymax) * dxdy);
+	*p_y2 = ymax;
+    }
+
+    if (*p_x2 > xmax) {
+	if (dx != 0 && dy != 0)
+	    *p_y2 = *p_y2 - ROUND((*p_x2 - xmax) * dydx);
+	*p_x2 = xmax;
+    }
+
+    if (flipx) {
+	*p_x1 = 2 * xmax - *p_x1;
+	*p_x2 = 2 * xmax - *p_x2;
+    }
+
+    if (flipy) {
+	*p_y1 = 2 * ymax - *p_y1;
+	*p_y2 = 2 * ymax - *p_y2;
+    }
+
+    return 0;
+}
+
+/*----------------------------------------------------------------------*\
+ * void genlin()
+ *
+ * General line-drawing routine.  Takes line styles into account.
+ * If only 2 points are in the polyline, it is more efficient to use
+ * plP_line() rather than plP_polyline().
+\*----------------------------------------------------------------------*/
+
+static void
+genlin(short *x, short *y, PLINT npts)
+{
+/* Check for solid line */
+
+    if (plsc->nms == 0) {
+	if (npts== 2)
+	    plP_line(x, y);
+	else
+	    plP_polyline(x, y, npts);
+    }
+
+/* Right now dashed lines don't use polyline capability -- this
+   should be improved */
+
+    else {
+
+	PLINT i;
+
+        /* Call escape sequence to draw dashed lines, only for drivers
+	   that have this capability */
+        if (plsc->dev_dash) {
+	    plsc->dev_npts = npts;
+	    plsc->dev_x = x;
+	    plsc->dev_y = y;
+	    plP_esc(PLESC_DASH, NULL);
+            return;
+        }
+
+	for (i = 0; i < npts - 1; i++) {
+	    grdashline(x+i, y+i);
+	}
+    }
+}
+
+/*----------------------------------------------------------------------*\
+ * void grdashline()
+ *
+ * Draws a dashed line to the specified point from the previous one.
+\*----------------------------------------------------------------------*/
+
+static void
+grdashline(short *x, short *y)
+{
+    PLINT nx, ny, nxp, nyp, incr, temp;
+    PLINT modulo, dx, dy, i, xtmp, ytmp;
+    PLINT tstep, pix_distance, j;
+    int loop_x;
+    short xl[2], yl[2];
+    double nxstep, nystep;
+
+/* Check if pattern needs to be restarted */
+
+    if (x[0] != lastx || y[0] != lasty) {
+	plsc->curel = 0;
+	plsc->pendn = 1;
+	plsc->timecnt = 0;
+	plsc->alarm = plsc->mark[0];
+    }
+
+    lastx = xtmp = x[0];
+    lasty = ytmp = y[0];
+
+    if (x[0] == x[1] && y[0] == y[1])
+	return;
+
+    nx = x[1] - x[0];
+    dx = (nx > 0) ? 1 : -1;
+    nxp = ABS(nx);
+
+    ny = y[1] - y[0];
+    dy = (ny > 0) ? 1 : -1;
+    nyp = ABS(ny);
+
+    if (nyp > nxp) {
+	modulo = nyp;
+	incr = nxp;
+	loop_x = 0;
+    }
+    else {
+	modulo = nxp;
+	incr = nyp;
+	loop_x = 1;
+    }
+
+    temp = modulo / 2;
+
+/* Compute the timer step */
+
+    nxstep = nxp * plsc->umx;
+    nystep = nyp * plsc->umy;
+    tstep = sqrt( nxstep * nxstep + nystep * nystep ) / modulo;
+    if (tstep < 1) tstep = 1;
+
+    /* tstep is distance per pixel moved */
+
+    i = 0;
+    while (i < modulo) {
+        pix_distance = (plsc->alarm - plsc->timecnt + tstep - 1) / tstep;
+	i += pix_distance;
+	if (i > modulo)
+	    pix_distance -= (i - modulo);
+	plsc->timecnt += pix_distance * tstep;
+
+	temp += pix_distance * incr;
+	j = temp / modulo;
+	temp = temp % modulo;
+
+	if (loop_x) {
+	    xtmp += pix_distance * dx;
+	    ytmp += j * dy;
+	}
+	else {
+	    xtmp += j * dx;
+	    ytmp += pix_distance * dy;
+	}
+	if (plsc->pendn != 0) {
+	    xl[0] = lastx;
+	    yl[0] = lasty;
+	    xl[1] = xtmp;
+	    yl[1] = ytmp;
+	    plP_line(xl, yl);
+	}
+
+/* Update line style variables when alarm goes off */
+
+	while (plsc->timecnt >= plsc->alarm) {
+	    if (plsc->pendn != 0) {
+		plsc->pendn = 0;
+		plsc->timecnt -= plsc->alarm;
+		plsc->alarm = plsc->space[plsc->curel];
+	    }
+	    else {
+		plsc->pendn = 1;
+		plsc->timecnt -= plsc->alarm;
+		plsc->curel++;
+		if (plsc->curel >= plsc->nms)
+		    plsc->curel = 0;
+		plsc->alarm = plsc->mark[plsc->curel];
+	    }
+	}
+	lastx = xtmp;
+	lasty = ytmp;
+    }
+}
diff --git a/collects/plot/src/all/plmap.c b/collects/plot/src/all/plmap.c
new file mode 100644
index 0000000000..52cc62982a
--- /dev/null
+++ b/collects/plot/src/all/plmap.c
@@ -0,0 +1,312 @@
+/* $Id: plmap.c,v 1.1 2004/03/01 20:54:52 cozmic Exp $
+
+	Continental Outline and Political Boundary Backgrounds
+
+	Some plots need a geographical background such as the global
+	surface temperatures or the population density.  The routine
+	plmap() will draw one of the following backgrounds: continental
+	outlines, political boundaries, the United States, and the United
+	States with the continental outlines.  The routine plmeridians()
+	will add the latitudes and longitudes to the background.  After
+	the background has been drawn, one can use a contour routine or a
+	symbol plotter to finish off the plot.
+
+	Copyright (C) 1991, 1993, 1994  Wesley Ebisuzaki
+        Copyright (C) 1994, 2000, 2001  Maurice LeBrun
+        Copyright (C) 1999  Geoffrey Furnish
+        Copyright (C) 2000, 2001, 2002  Alan W. Irwin
+        Copyright (C) 2001  Andrew Roach
+        Copyright (C) 2001  Rafael Laboissiere
+        Copyright (C) 2002  Vincent Darley
+        Copyright (C) 2003  Joao Cardoso
+
+        This file is part of PLplot.
+
+	PLplot is free software; you can redistribute it and/or modify
+	it under the terms of the GNU Library General Public License
+	as published by the Free Software Foundation; version 2 of the
+	License.
+
+	PLplot is distributed in the hope that it will be useful, but
+	WITHOUT ANY WARRANTY; without even the implied warranty of
+	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+	GNU Library General Public License for more details.
+
+	You should have received a copy of the GNU Library General Public
+	License along with this library; if not, write to the Free Software
+	Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307
+        USA
+
+*/
+
+#include "plplotP.h"
+
+/*----------------------------------------------------------------------*\
+ * void plmap(void (*mapform)(PLINT, PLFLT *, PLFLT *), char *type,
+ *            PLFLT minlong, PLFLT maxlong, PLFLT minlat, PLFLT maxlat);
+ *
+ * plot continental outline in world coordinates
+ *
+ * v1.4: machine independant version
+ * v1.3: replaced plcontinent by plmap, added plmeridians
+ * v1.2: 2 arguments:  mapform, type of plot
+ *
+ * mapform(PLINT n, PLFLT *x, PLFLT *y) is a routine to transform the
+ * coordinate longitudes and latitudes to a plot coordinate system.  By
+ * using this transform, we can change from a longitude, latitude
+ * coordinate to a polar stereographic project, for example.  Initially,
+ * x[0]..[n-1] are the longitudes and y[0]..y[n-1] are the corresponding
+ * latitudes.  After the call to mapform(), x[] and y[] should be replaced
+ * by the corresponding plot coordinates.  If no transform is desired,
+ * mapform can be replaced by NULL.
+ * 
+ * type is a character string. The value of this parameter determines the
+ * type of background. The possible values are,
+ *
+ * 	"globe"		continental outlines
+ * 	"usa"		USA and state boundaries
+ * 	"cglobe"	continental outlines and countries
+ * 	"usaglobe"	USA, state boundaries and continental outlines
+ * 
+ * minlong, maxlong are the values of the longitude on the left and right
+ * side of the plot, respectively. The value of minlong must be less than
+ * the values of maxlong, and the values of maxlong-minlong must be less
+ * or equal to 360.
+ * 
+ * minlat, maxlat are the minimum and maximum latitudes to be plotted on
+ * the background.  One can always use -90.0 and 90.0 as the boundary
+ * outside the plot window will be automatically eliminated.  However, the
+ * program will be faster if one can reduce the size of the background
+ * plotted.
+\*----------------------------------------------------------------------*/
+
+#define MAP_FILE ".map"
+#define OFFSET (180*100)
+#define SCALE 100.0
+#define W_BUFSIZ	(32*1024)
+
+void
+plmap( void (*mapform)(PLINT, PLFLT *, PLFLT *), char *type,
+         PLFLT minlong, PLFLT maxlong, PLFLT minlat, PLFLT maxlat )
+{
+    PLINT wrap, sign;
+    int i, j;
+    PLFLT bufx[200], bufy[200], x[2], y[2];
+    short int test[400];
+    register PDFstrm *in;
+    char filename[100];
+
+    unsigned char n_buff[2], buff[800];
+    int n;
+    long int t;
+
+    /*
+     * read map outline 
+     */
+    strcpy(filename,type);
+    strcat(filename,MAP_FILE);
+
+    if ((in = plLibOpenPdfstrm(filename)) == NULL)
+	return;
+
+    for (;;) {
+	/* read in # points in segment */
+	if (pdf_rdx(n_buff, sizeof (unsigned char)* 2, in) == 0) break;
+	n = (n_buff[0] << 8) + n_buff[1];
+	if (n == 0) break;
+
+	pdf_rdx(buff, sizeof (unsigned char)*4*n, in);
+	if (n == 1) continue;
+
+	for (j = i = 0; i < n; i++, j += 2) {
+	    t = (buff[j] << 8) + buff[j+1];
+	    bufx[i] = (t - OFFSET) / SCALE;
+	}
+	for (i = 0; i < n; i++, j += 2) {
+	    t = (buff[j] << 8) + buff[j+1];
+	    bufy[i] = (t - OFFSET) / SCALE;
+	}
+
+	for (i = 0; i < n; i++) {
+	    while (bufx[i] < minlong) {
+		bufx[i] += 360.0;
+	    }
+	    while (bufx[i] > maxlong) {
+		bufx[i] -= 360.0;
+	    }
+	}
+
+	/* remove last 2 points if both outside of domain and won't plot */
+
+/* AR: 18/11/01 
+*       I have commented out the next section which supposedly
+*       removes points that do not plot within the domain. 
+*       
+*       This code appears at any rate to be superseded by the next
+*       block of code that checks for wrapping problems. Removing
+*       this code seems to have fixed up the problems with mapping
+*       function, but I do not wish to delete it outright just now in
+*       case I have managed to miss something.
+*/
+
+/*	while (n > 1) {
+	    if ((bufx[n-1] < minlong && bufx[n-2] < minlong) ||
+		(bufx[n-1] > maxlong && bufx[n-2] > maxlong) ||
+		(bufy[n-1] < minlat && bufy[n-2] < minlat) ||
+		(bufy[n-1] > maxlat && bufy[n-2] > maxlat)) {
+		n--;
+	    }
+	    else {
+		break;
+	    }
+	}
+	if (n <= 1) continue;
+*/
+
+       if (mapform != NULL) (*mapform)(n,bufx,bufy); /* moved transformation to here   */
+                                                     /* so bound-checking worked right */
+
+	wrap = 0;
+	/* check for wrap around problems */
+	for (i = 0; i < n-1; i++) {
+
+	  /* jc: this code is wrong, as the bufx/y are floats that are
+	     converted to ints before abs() is called. Thus, small
+	     differences are masked off. The proof that it is wrong is
+	     that when replacing abs() with fabs(), as it should be,
+	     the code works the wrong way. What a proof :-)
+
+	    test[i] = abs((bufx[i]-bufx[i+1])) > abs(bufy[i]/3);
+
+	    If the intended behaviour is *really* that, than an
+	    explicit cast should be used to help other programmers, as
+	    is done bellow!!!
+	  */
+
+	    test[i] = abs((int)(bufx[i]-bufx[i+1])) > abs((int)bufy[i]/3); /* Changed this from 30 degrees so it is now "polar sensitive" */
+	    if (test[i]) wrap = 1;
+	}
+
+	if (wrap == 0) {	
+	    plline(n,bufx,bufy);
+	}
+	else {
+	    for (i = 0; i < n-1; i++) {
+		x[0] = bufx[i];
+		x[1] = bufx[i+1];
+		y[0] = bufy[i];
+		y[1] = bufy[i+1];
+		if (test[i] == 0) {
+		    plline(2,x,y);
+		}
+		else {  /* this code seems to supercede the block commented out above */
+		    /* segment goes off the edge */
+		    sign = (x[1] > x[0]) ? 1 : -1;
+		    x[1] -= sign * 360.0;
+		    plline(2,x,y);
+		    x[0] = bufx[i];
+		    x[1] = bufx[i+1];
+		    y[0] = bufy[i];
+		    y[1] = bufy[i+1];
+		    x[0] += sign * 360.0;
+		    plline(2,x,y);
+		}
+	    }
+	}
+    }
+}
+
+/*----------------------------------------------------------------------*\
+ * void plmeridians(void (*mapform)(PLINT, PLFLT *, PLFLT *), 
+ *		    PLFLT dlong, PLFLT dlat, PLFLT minlong, PLFLT maxlong, 
+ *		    PLFLT minlat, PLFLT maxlat);
+ *
+ * Plot the latitudes and longitudes on the background.  The lines 
+ * are plotted in the current color and line style.
+ * 
+ * mapform(PLINT n, PLFLT *x, PLFLT *y) is a routine to transform the
+ * coordinate longitudes and latitudes to a plot coordinate system.  By
+ * using this transform, we can change from a longitude, latitude
+ * coordinate to a polar stereographic project, for example.  Initially,
+ * x[0]..x[n-1] are the longitudes and y[0]..y[n-1] are the corresponding
+ * latitudes.  After the call to mapform(), x[] and y[] should be replaced
+ * by the corresponding plot coordinates.  If no transform is desired,
+ * mapform can be replaced by NULL.
+ * 
+ * dlat, dlong are the interval in degrees that the latitude and longitude
+ * lines are to be plotted. 
+ * 
+ * minlong, maxlong are the values of the longitude on the left and right
+ * side of the plot, respectively. The value of minlong must be less than
+ * the values of maxlong, and the values of maxlong-minlong must be less
+ * or equal to 360.
+ * 
+ * minlat, maxlat are the minimum and maximum latitudes to be plotted on
+ * the background.  One can always use -90.0 and 90.0 as the boundary
+ * outside the plot window will be automatically eliminated.  However, the
+ * program will be faster if one can reduce the size of the background
+ * plotted.
+\*----------------------------------------------------------------------*/
+
+#define NSEG 100
+
+void 
+plmeridians( void (*mapform)(PLINT, PLFLT *, PLFLT *), 
+               PLFLT dlong, PLFLT dlat,
+               PLFLT minlong, PLFLT maxlong, PLFLT minlat, PLFLT maxlat )
+{
+    PLFLT yy, xx, temp, x[2], y[2], dx, dy;
+
+    if (minlong > maxlong) {
+	temp = minlong;
+	minlong = maxlong;
+	maxlong = temp;
+    }
+    if (minlat > maxlat) {
+	temp = minlat;
+	minlat = maxlat;
+	maxlat = temp;
+    }
+    dx = (maxlong - minlong) / NSEG;
+    dy = (maxlat - minlat) / NSEG;
+
+    /* latitudes */
+
+    for (yy = dlat * ceil(minlat/dlat); yy <= maxlat; yy += dlat) {
+	if (mapform == NULL) {
+	    y[0] = y[1] = yy;
+	    x[0] = minlong;
+	    x[1] = maxlong;
+	    plline(2,x,y);
+	}
+	else {
+	    for (xx = minlong; xx < maxlong; xx += dx) {
+	        y[0] = y[1] = yy;
+		x[0] = xx;
+		x[1] = xx + dx;
+	 	(*mapform)(2,x,y);
+		plline(2,x,y);
+	    }
+	}
+    }
+
+    /* longitudes */
+ 
+    for (xx = dlong * ceil(minlong/dlong); xx <= maxlong; xx += dlong) {
+        if (mapform == NULL) {
+            x[0] = x[1] = xx;
+            y[0] = minlat;
+            y[1] = maxlat;
+            plline(2,x,y);
+        }
+        else {
+            for (yy = minlat; yy < maxlat; yy += dy) {
+                x[0] = x[1] = xx;
+                y[0] = yy;
+                y[1] = yy + dy;
+                (*mapform)(2,x,y);
+                plline(2,x,y);
+            }
+        }
+    }
+}
diff --git a/collects/plot/src/all/plmeta.c b/collects/plot/src/all/plmeta.c
new file mode 100644
index 0000000000..d3fe9b8b8e
--- /dev/null
+++ b/collects/plot/src/all/plmeta.c
@@ -0,0 +1,707 @@
+/* $Id: plmeta.c,v 1.1 2004/03/01 20:54:52 cozmic Exp $
+
+    Copyright 1991, 1992, 1993, 1994, 1995
+    Geoffrey Furnish			furnish@dino.ph.utexas.edu
+    Maurice LeBrun			mjl@dino.ph.utexas.edu
+    Institute for Fusion Studies	University of Texas at Austin
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Library General Public
+    License as published by the Free Software Foundation; either
+    version 2 of the License, or (at your option) any later version.
+
+    This library is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+    Library General Public License for more details.
+
+    You should have received a copy of the GNU Library General Public
+    License along with this library; if not, write to the Free
+    Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+	
+    This is a metafile writer for PLplot.
+
+*/
+#include "plDevs.h"
+
+/*#define DEBUG*/
+
+#ifdef PLD_plmeta
+
+#define NEED_PLDEBUG
+#include "plplotP.h"
+#include "drivers.h"
+#include "metadefs.h"
+#include <string.h>
+
+/* Device info */
+char* plD_DEVICE_INFO_plmeta = "plmeta:PLplot Native Meta-File:0:plmeta:26:plm";
+
+
+void plD_dispatch_init_plm	( PLDispatchTable *pdt );
+
+void plD_init_plm		(PLStream *);
+void plD_line_plm		(PLStream *, short, short, short, short);
+void plD_polyline_plm		(PLStream *, short *, short *, PLINT);
+void plD_eop_plm		(PLStream *);
+void plD_bop_plm		(PLStream *);
+void plD_tidy_plm		(PLStream *);
+void plD_state_plm		(PLStream *, PLINT);
+void plD_esc_plm		(PLStream *, PLINT, void *);
+
+/* Struct to hold device-specific info. */
+
+typedef struct {
+    PLFLT pxlx, pxly;
+    PLINT xold, yold;
+
+    PLINT xmin, xmax, xlen;
+    PLINT ymin, ymax, ylen;
+
+    FPOS_T lp_offset, index_offset;
+
+    int notfirst;
+} PLmDev;
+
+/* Used for constructing error messages */
+
+static char buffer[256];
+
+/* Function prototypes */
+
+static void WriteFileHeader	(PLStream *pls);
+static void UpdatePrevPagehdr	(PLStream *pls);
+static void WritePageInfo	(PLStream *pls, FPOS_T pp_offset);
+static void UpdateIndex		(PLStream *pls, FPOS_T cp_offset);
+static void plm_fill		(PLStream *pls);
+static void plm_swin		(PLStream *pls);
+
+/* A little function to help with debugging */
+
+#ifdef DEBUG
+#define DEBUG_PRINT_LOCATION(a) PrintLocation(pls, a)
+
+static void PrintLocation(PLStream *pls, char *tag)
+{
+    int isfile = (pls->output_type == 0);
+    if (isfile) {
+	FILE *file = pls->OutFile;
+	FPOS_T current_offset;
+
+	if (pl_fgetpos(file, &current_offset))
+	    plexit("PrintLocation (plmeta.c): fgetpos call failed");
+
+	pldebug(tag, "at offset %d in file %s\n",
+		(int) current_offset, pls->FileName);
+    }
+}
+#else
+#define DEBUG_PRINT_LOCATION(a)
+#endif
+
+void plD_dispatch_init_plm( PLDispatchTable *pdt )
+{
+    pdt->pl_MenuStr  = "PLplot Native Meta-File";
+    pdt->pl_DevName  = "plmeta";
+    pdt->pl_type     = plDevType_FileOriented;
+    pdt->pl_seq      = 26;
+    pdt->pl_init     = (plD_init_fp)     plD_init_plm;
+    pdt->pl_line     = (plD_line_fp)     plD_line_plm;
+    pdt->pl_polyline = (plD_polyline_fp) plD_polyline_plm;
+    pdt->pl_eop      = (plD_eop_fp)      plD_eop_plm;
+    pdt->pl_bop      = (plD_bop_fp)      plD_bop_plm;
+    pdt->pl_tidy     = (plD_tidy_fp)     plD_tidy_plm;
+    pdt->pl_state    = (plD_state_fp)    plD_state_plm;
+    pdt->pl_esc      = (plD_esc_fp)      plD_esc_plm;
+}
+
+/*--------------------------------------------------------------------------*\
+ * plD_init_plm()
+ *
+ * Initialize device.
+\*--------------------------------------------------------------------------*/
+
+void
+plD_init_plm(PLStream *pls)
+{
+    PLmDev *dev;
+    U_CHAR c = (U_CHAR) INITIALIZE;
+
+    dbug_enter("plD_init_plm");
+
+    pls->color = 1;		/* Is a color device */
+    pls->dev_fill0 = 1;		/* Handle solid fills */
+    pls->dev_fill1 = 1;		/* Handle pattern fills */
+
+/* Initialize family file info */
+
+    plFamInit(pls);
+
+/* Prompt for a file name if not already set */
+
+    plOpenFile(pls);
+    pls->pdfs = pdf_finit(pls->OutFile);
+
+/* Allocate and initialize device-specific data */
+
+    pls->dev = calloc(1, (size_t) sizeof(PLmDev));
+    if (pls->dev == NULL)
+	plexit("plD_init_plm: Out of memory.");
+
+    dev = (PLmDev *) pls->dev;
+
+    dev->xold = PL_UNDEFINED;
+    dev->yold = PL_UNDEFINED;
+
+    dev->xmin = 0;
+    dev->xmax = PIXELS_X - 1;
+    dev->ymin = 0;
+    dev->ymax = PIXELS_Y - 1;
+
+    dev->pxlx = (double) PIXELS_X / (double) LPAGE_X;
+    dev->pxly = (double) PIXELS_Y / (double) LPAGE_Y;
+
+    plP_setpxl(dev->pxlx, dev->pxly);
+    plP_setphy(dev->xmin, dev->xmax, dev->ymin, dev->ymax);
+
+/* Write Metafile header. */
+
+    WriteFileHeader(pls);
+
+/* Write color map state info */
+
+    plD_state_plm(pls, PLSTATE_CMAP0);
+    plD_state_plm(pls, PLSTATE_CMAP1);
+
+/* Write initialization command. */
+
+    DEBUG_PRINT_LOCATION("before init");
+    plm_wr( pdf_wr_1byte(pls->pdfs, c) );
+}
+
+/*--------------------------------------------------------------------------*\
+ * plD_line_plm()
+ *
+ * Draw a line in the current color from (x1,y1) to (x2,y2).
+\*--------------------------------------------------------------------------*/
+
+void
+plD_line_plm(PLStream *pls, short x1, short y1, short x2, short y2)
+{
+    PLmDev *dev = (PLmDev *) pls->dev;
+    U_CHAR c;
+    U_SHORT xy[4];
+
+    /* dbug_enter("plD_line_plm"); */
+
+    /* Failsafe check */
+
+#ifdef DEBUG
+    if (x1 < dev->xmin || x1 > dev->xmax ||
+	x2 < dev->xmin || x2 > dev->xmax ||
+	y1 < dev->ymin || y1 > dev->ymax ||
+	y2 < dev->ymin || y2 > dev->ymax) {
+
+	pldebug("plD_line_plm",
+		"coordinates out of bounds -- \nActual: (%i,%i), (%i,%i) Bounds: (%i,%i,%i,%i)\n", 
+		x1, y1, x2, y2, dev->xmin, dev->xmax, dev->ymin, dev->ymax);
+    }
+#endif
+
+/* If continuation of previous line send the LINETO command, which uses
+   the previous (x,y) point as it's starting location.  This results in a
+   storage reduction of not quite 50%, since the instruction length for
+   a LINETO is 5/9 of that for the LINE command, and given that most
+   graphics applications use this command heavily.
+
+   Still not quite as efficient as tektronix format since we also send the
+   command each time (so shortest command is 25% larger), but a lot easier
+   to implement than the tek method.  
+ */
+    if (x1 == dev->xold && y1 == dev->yold) {
+
+	c = (U_CHAR) LINETO;
+	plm_wr( pdf_wr_1byte(pls->pdfs, c) );
+
+	xy[0] = x2;
+	xy[1] = y2;
+	plm_wr( pdf_wr_2nbytes(pls->pdfs, xy, 2) );
+    }
+    else {
+	c = (U_CHAR) LINE;
+	plm_wr( pdf_wr_1byte(pls->pdfs, c) );
+
+	xy[0] = x1;
+	xy[1] = y1;
+	xy[2] = x2;
+	xy[3] = y2;
+	plm_wr( pdf_wr_2nbytes(pls->pdfs, xy, 4) );
+    }
+    dev->xold = x2;
+    dev->yold = y2;
+}
+
+/*--------------------------------------------------------------------------*\
+ * plD_polyline_plm()
+ *
+ * Draw a polyline in the current color.
+\*--------------------------------------------------------------------------*/
+
+void
+plD_polyline_plm(PLStream *pls, short *xa, short *ya, PLINT npts)
+{
+    PLmDev *dev = (PLmDev *) pls->dev;
+    U_CHAR c = (U_CHAR) POLYLINE;
+
+    dbug_enter("plD_polyline_plm");
+
+    plm_wr( pdf_wr_1byte(pls->pdfs, c) );
+
+    plm_wr( pdf_wr_2bytes(pls->pdfs, (U_SHORT) npts) );
+
+    plm_wr( pdf_wr_2nbytes(pls->pdfs, (U_SHORT *) xa, npts) );
+    plm_wr( pdf_wr_2nbytes(pls->pdfs, (U_SHORT *) ya, npts) );
+
+    dev->xold = xa[npts - 1];
+    dev->yold = ya[npts - 1];
+}
+
+/*--------------------------------------------------------------------------*\
+ * plD_eop_plm()
+ *
+ * End of page.
+\*--------------------------------------------------------------------------*/
+
+void
+plD_eop_plm(PLStream *pls)
+{
+    U_CHAR c = (U_CHAR) EOP;
+
+    plm_wr( pdf_wr_1byte(pls->pdfs, c) );
+}
+
+/*--------------------------------------------------------------------------*\
+ * plD_bop_plm()
+ *
+ * Set up for the next page.
+ *
+ * Page header layout as follows:
+ *
+ * BOP			(U_CHAR)
+ * page number		(U_SHORT)
+ * prev page offset	(U_LONG)
+ * next page offset	(U_LONG)
+ *
+ * Each call after the first is responsible for updating the table of
+ * contents and the next page offset from the previous page.
+\*--------------------------------------------------------------------------*/
+
+void
+plD_bop_plm(PLStream *pls)
+{
+    PLmDev *dev = (PLmDev *) pls->dev;
+    int isfile = (pls->output_type == 0);
+    FPOS_T pp_offset = dev->lp_offset;;
+
+    dbug_enter("plD_bop_plm");
+
+    dev->xold = PL_UNDEFINED;
+    dev->yold = PL_UNDEFINED;
+
+/* Update previous page header */
+
+    if (isfile)
+	UpdatePrevPagehdr(pls);
+
+/* Start next family file if necessary. */
+
+    pls->bytecnt = pls->pdfs->bp;
+    plGetFam(pls);
+
+/* Update page counter */
+
+    pls->page++;
+
+/* Update table of contents info & write new page header. */
+
+    WritePageInfo(pls, pp_offset);
+}
+
+/*--------------------------------------------------------------------------*\
+ * WritePageInfo()
+ *
+ * Update table of contents info & write new page header.
+\*--------------------------------------------------------------------------*/
+
+static void
+WritePageInfo(PLStream *pls, FPOS_T pp_offset)
+{
+    PLmDev *dev = (PLmDev *) pls->dev;
+    FILE *file = pls->OutFile;
+    int isfile = (pls->output_type == 0);
+    U_CHAR c;
+    FPOS_T cp_offset=0;
+
+/* Update table of contents. */
+
+    if (isfile) {
+	if (pl_fgetpos(file, &cp_offset))
+	    plexit("WritePageInfo (plmeta.c): fgetpos call failed");
+
+	UpdateIndex(pls, cp_offset);
+    }
+
+/* Write new page header */
+
+    if (dev->notfirst)
+	c = BOP;
+    else {
+	c = BOP0;
+	dev->notfirst = 1;
+    }
+    plm_wr( pdf_wr_1byte(pls->pdfs,  c) );
+    plm_wr( pdf_wr_2bytes(pls->pdfs, (U_SHORT) pls->page) );
+    plm_wr( pdf_wr_4bytes(pls->pdfs, (U_LONG) pp_offset) );
+    plm_wr( pdf_wr_4bytes(pls->pdfs, (U_LONG) 0) );
+
+/* Update last page offset with current page value */
+
+    dev->lp_offset = cp_offset;
+
+/* Write some page state information just to make things nice later on */
+/* Eventually there will be more */
+
+    plD_state_plm(pls, PLSTATE_COLOR0);
+}
+
+/*--------------------------------------------------------------------------*\
+ * UpdatePrevPagehdr()
+ *
+ * Update previous page header.
+\*--------------------------------------------------------------------------*/
+
+static void
+UpdatePrevPagehdr(PLStream *pls)
+{
+    PLmDev *dev = (PLmDev *) pls->dev;
+    FILE *file = pls->OutFile;
+    FPOS_T cp_offset=0;
+
+    fflush(file);
+
+/* Determine where we are */
+
+    if (pl_fgetpos(file, &cp_offset))
+	plexit("plD_bop_plm: fgetpos call failed");
+
+/* Seek back to previous page header. */
+
+    if (dev->lp_offset > 0) {
+	FPOS_T fwbyte_offset=0;
+
+	pldebug("UpdatePrevPagehdr 1 (plmeta.c)",
+		"Location: %d, seeking to: %d\n",
+		(int) cp_offset, (int) dev->lp_offset);
+
+    /* The forward byte offset is located exactly 7 bytes after the BOP */
+	fwbyte_offset = dev->lp_offset + 7;
+	if (pl_fsetpos(file, &fwbyte_offset)) {
+	    sprintf(buffer, "UpdatePrevPagehdr (plmeta.c): fsetpos to fwbyte_offset (%d) failed",
+		    (int) fwbyte_offset);
+	    plexit(buffer);
+	}
+
+    /* DEBUG: verify current location */
+
+#ifdef DEBUG
+	if (pl_fgetpos(file, &fwbyte_offset))
+	    plexit("UpdatePrevPagehdr (plmeta.c): fgetpos call failed");
+
+	pldebug("UpdatePrevPagehdr 2 (plmeta.c)",
+		"Now at: %d, to write: %d\n", 
+		(int) fwbyte_offset, (int) cp_offset);
+#endif
+
+    /* Write forward byte offset into previous page header. */
+
+	plm_wr( pdf_wr_4bytes(pls->pdfs, (U_LONG) cp_offset) );
+	fflush(file);
+
+    /* DEBUG: move back to before the write & read it to verify */
+
+#ifdef DEBUG
+	if (pl_fsetpos(file, &fwbyte_offset)) {
+	    sprintf(buffer, "UpdatePrevPagehdr (plmeta.c): fsetpos to fwbyte_offset (%d) failed",
+		    (int) fwbyte_offset);
+	    plexit(buffer);
+	}
+	{
+	    U_LONG read_offset;
+	    plm_rd(pdf_rd_4bytes(pls->pdfs, &read_offset));
+	    pldebug("UpdatePrevPagehdr 3 (plmeta.c)",
+		    "Value read as: %d\n", read_offset);
+	}
+#endif
+
+    /* Return to current page offset */
+
+	if (pl_fsetpos(file, &cp_offset)) {
+	    sprintf(buffer, "UpdatePrevPagehdr (plmeta.c): fsetpos to cp_offset (%d) failed",
+		    (int) cp_offset);
+	    plexit(buffer);
+	}
+    }
+}
+
+/*--------------------------------------------------------------------------*\
+ * UpdateIndex()
+ *
+ * Update file index.
+\*--------------------------------------------------------------------------*/
+
+static void
+UpdateIndex(PLStream *pls, FPOS_T cp_offset)
+{
+    PLmDev *dev = (PLmDev *) pls->dev;
+    FILE *file = pls->OutFile;
+
+/* Update file index.  Right now only number of pages. */
+/* The ordering here is critical */
+
+    if (dev->index_offset > 0) {
+	pldebug("UpdateIndex (plmeta.c)",
+		"Location: %d, seeking to: %d\n",
+		(int) cp_offset, (int) dev->lp_offset);
+
+	if (pl_fsetpos(file, &dev->index_offset)) {
+	    sprintf(buffer, "UpdateIndex (plmeta.c): fsetpos to index_offset (%d) failed",
+		    (int) dev->index_offset);
+	    plexit(buffer);
+	}
+	plm_wr( pdf_wr_header(pls->pdfs, "pages") );
+	plm_wr( pdf_wr_2bytes(pls->pdfs, (U_SHORT) pls->page) );
+
+	pldebug("UpdateIndex (plmeta.c)",
+		"Location: %d, seeking to: %d\n",
+		(int) dev->lp_offset, (int) cp_offset);
+
+	if (pl_fsetpos(file, &cp_offset)) {
+	    sprintf(buffer, "UpdateIndex (plmeta.c): fsetpos to cp_offset (%d) failed",
+		    (int) cp_offset);
+	    plexit(buffer);
+	}
+    }
+}
+
+/*--------------------------------------------------------------------------*\
+ * plD_tidy_plm()
+ *
+ * Close graphics file
+\*--------------------------------------------------------------------------*/
+
+void
+plD_tidy_plm(PLStream *pls)
+{
+    U_CHAR c = (U_CHAR) CLOSE;
+
+    dbug_enter("plD_tidy_plm");
+
+    plm_wr( pdf_wr_1byte(pls->pdfs, c) );
+    pdf_close(pls->pdfs);
+    free_mem(pls->dev);
+}
+
+/*--------------------------------------------------------------------------*\
+ * plD_state_plm()
+ *
+ * Handle change in PLStream state (color, pen width, fill attribute, etc).
+\*--------------------------------------------------------------------------*/
+
+void 
+plD_state_plm(PLStream *pls, PLINT op)
+{
+    U_CHAR c = (U_CHAR) CHANGE_STATE;
+    int i;
+
+    dbug_enter("plD_state_plm");
+
+    plm_wr( pdf_wr_1byte(pls->pdfs, c) );
+    plm_wr( pdf_wr_1byte(pls->pdfs, op) );
+
+    switch (op) {
+
+    case PLSTATE_WIDTH:
+	plm_wr( pdf_wr_2bytes(pls->pdfs, (U_SHORT) (pls->width)) );
+	break;
+
+    case PLSTATE_COLOR0:
+	plm_wr( pdf_wr_1byte(pls->pdfs, (U_CHAR) pls->icol0) );
+
+	if (pls->icol0 == PL_RGB_COLOR) {
+	    plm_wr( pdf_wr_1byte(pls->pdfs, pls->curcolor.r) );
+	    plm_wr( pdf_wr_1byte(pls->pdfs, pls->curcolor.g) );
+	    plm_wr( pdf_wr_1byte(pls->pdfs, pls->curcolor.b) );
+	}
+	break;
+
+    case PLSTATE_COLOR1:
+	plm_wr( pdf_wr_2bytes(pls->pdfs, (U_SHORT) pls->icol1) );
+	break;
+
+    case PLSTATE_FILL:
+	plm_wr( pdf_wr_1byte(pls->pdfs, (U_CHAR) pls->patt) );
+	break;
+
+    case PLSTATE_CMAP0:
+	plm_wr( pdf_wr_1byte(pls->pdfs, (U_CHAR) pls->ncol0) );
+	for (i = 0; i < pls->ncol0; i++) {
+	    plm_wr( pdf_wr_1byte(pls->pdfs, pls->cmap0[i].r) );
+	    plm_wr( pdf_wr_1byte(pls->pdfs, pls->cmap0[i].g) );
+	    plm_wr( pdf_wr_1byte(pls->pdfs, pls->cmap0[i].b) );
+	}
+	break;
+
+    case PLSTATE_CMAP1:
+	plm_wr( pdf_wr_2bytes(pls->pdfs, (U_SHORT) pls->ncol1) );
+	for (i = 0; i < pls->ncol1; i++) {
+	    plm_wr( pdf_wr_1byte(pls->pdfs, pls->cmap1[i].r) );
+	    plm_wr( pdf_wr_1byte(pls->pdfs, pls->cmap1[i].g) );
+	    plm_wr( pdf_wr_1byte(pls->pdfs, pls->cmap1[i].b) );
+	}
+	break;
+    }
+}
+
+/*--------------------------------------------------------------------------*\
+ * plD_esc_plm()
+ *
+ * Escape function.  Note that any data written must be in device
+ * independent form to maintain the transportability of the metafile.
+ *
+ * Functions:
+ *
+ *	PLESC_FILL	Fill polygon
+ *	PLESC_SWIN	Set window parameters
+ *
+\*--------------------------------------------------------------------------*/
+
+void
+plD_esc_plm(PLStream *pls, PLINT op, void *ptr)
+{
+    U_CHAR c = (U_CHAR) ESCAPE;
+
+    dbug_enter("plD_esc_plm");
+
+    plm_wr( pdf_wr_1byte(pls->pdfs, c) );
+    plm_wr( pdf_wr_1byte(pls->pdfs, (U_CHAR) op) );
+
+    switch (op) {
+    case PLESC_FILL:
+	plm_fill(pls);
+	break;
+
+    case PLESC_SWIN:
+	plm_swin(pls);
+	break;
+    }
+}
+
+/*--------------------------------------------------------------------------*\
+ * plm_fill()
+ *
+ * Fill polygon described in points pls->dev_x[] and pls->dev_y[].
+\*--------------------------------------------------------------------------*/
+
+static void
+plm_fill(PLStream *pls)
+{
+    PLmDev *dev = (PLmDev *) pls->dev;
+
+    dbug_enter("plm_fill");
+
+    plm_wr( pdf_wr_2bytes(pls->pdfs, (U_SHORT) pls->dev_npts) );
+
+    plm_wr( pdf_wr_2nbytes(pls->pdfs, (U_SHORT *) pls->dev_x, pls->dev_npts) );
+    plm_wr( pdf_wr_2nbytes(pls->pdfs, (U_SHORT *) pls->dev_y, pls->dev_npts) );
+
+    dev->xold = PL_UNDEFINED;
+    dev->yold = PL_UNDEFINED;
+}
+
+/*--------------------------------------------------------------------------*\
+ * plm_swin()
+ *
+ * Set window parameters.
+ * Each parameter or group of parameters is tagged to make backward
+ * compatibility easier.
+\*--------------------------------------------------------------------------*/
+
+static void
+plm_swin(PLStream *pls)
+{
+    dbug_enter("plm_swin");
+}
+
+/*--------------------------------------------------------------------------*\
+ * WriteFileHeader()
+ *
+ * Writes Metafile header.
+\*--------------------------------------------------------------------------*/
+
+static void
+WriteFileHeader(PLStream *pls)
+{
+    PLmDev *dev = (PLmDev *) pls->dev;
+    FILE *file = pls->OutFile;
+    int isfile = (pls->output_type == 0);
+
+    dbug_enter("WriteFileHeader(PLStream *pls");
+
+    plm_wr( pdf_wr_header(pls->pdfs, PLMETA_HEADER) );
+    plm_wr( pdf_wr_header(pls->pdfs, PLMETA_VERSION) );
+
+/* Write file index info.  Right now only number of pages. */
+/* The order here is critical */
+
+    if (isfile) {
+	if (pl_fgetpos(file, &dev->index_offset))
+	    plexit("WriteFileHeader: fgetpos call failed");
+    }
+
+    plm_wr( pdf_wr_header(pls->pdfs, "pages") );
+    plm_wr( pdf_wr_2bytes(pls->pdfs, (U_SHORT) 0) );
+
+/* Write initialization info.  Tag via strings to make backward
+   compatibility with old metafiles as easy as possible. */
+
+    plm_wr( pdf_wr_header(pls->pdfs, "xmin") );
+    plm_wr( pdf_wr_2bytes(pls->pdfs, (U_SHORT) dev->xmin) );
+
+    plm_wr( pdf_wr_header(pls->pdfs, "xmax") );
+    plm_wr( pdf_wr_2bytes(pls->pdfs, (U_SHORT) dev->xmax) );
+
+    plm_wr( pdf_wr_header(pls->pdfs, "ymin") );
+    plm_wr( pdf_wr_2bytes(pls->pdfs, (U_SHORT) dev->ymin) );
+
+    plm_wr( pdf_wr_header(pls->pdfs, "ymax") );
+    plm_wr( pdf_wr_2bytes(pls->pdfs, (U_SHORT) dev->ymax) );
+
+    plm_wr( pdf_wr_header(pls->pdfs, "pxlx") );
+    plm_wr( pdf_wr_ieeef(pls->pdfs, (float) dev->pxlx) );
+
+    plm_wr( pdf_wr_header(pls->pdfs, "pxly") );
+    plm_wr( pdf_wr_ieeef(pls->pdfs, (float) dev->pxly) );
+
+    plm_wr( pdf_wr_header(pls->pdfs, "") );
+}
+
+#else
+int 
+pldummy_plmeta()
+{
+    return 0;
+}
+
+#endif				/* PLD_plmeta */
diff --git a/collects/plot/src/all/plot3d.c b/collects/plot/src/all/plot3d.c
new file mode 100644
index 0000000000..2c64cf218b
--- /dev/null
+++ b/collects/plot/src/all/plot3d.c
@@ -0,0 +1,2087 @@
+/* $Id: plot3d.c,v 1.2 2005/03/17 21:39:21 eli Exp $
+
+	3d plot routines.
+*/
+
+#include "plplotP.h"
+
+/* Internal constants */
+
+#define  BINC      50		/* Block size for memory allocation */
+
+static PLINT pl3mode = 0;	/* 0 3d solid; 1 mesh plot */
+static PLINT pl3upv = 1;	/* 1 update view; 0 no update */
+
+static PLINT zbflg = 0, zbcol;
+static PLFLT zbtck;
+
+static PLINT *oldhiview = NULL;
+static PLINT *oldloview = NULL;
+static PLINT *newhiview = NULL;
+static PLINT *newloview = NULL;
+static PLINT *utmp = NULL;
+static PLINT *vtmp = NULL;
+static PLFLT *ctmp = NULL;
+
+static PLINT mhi, xxhi, newhisize;
+static PLINT mlo, xxlo, newlosize;
+
+/* Light source for shading */
+static PLFLT xlight, ylight, zlight;
+static PLINT falsecolor=0;
+static PLFLT fc_minz, fc_maxz;
+
+/* Prototypes for static functions */
+
+static void plgrid3	(PLFLT);
+static void plnxtv (PLINT *, PLINT *, PLFLT*, PLINT, PLINT);
+static void plside3	(PLFLT *, PLFLT *, PLFLT **, PLINT, PLINT, PLINT);
+static void plt3zz	(PLINT, PLINT, PLINT, PLINT, 
+			 PLINT, PLINT *, PLFLT *, PLFLT *, PLFLT **, 
+			   PLINT, PLINT, PLINT *, PLINT *, PLFLT*);
+static void plnxtvhi (PLINT *, PLINT *, PLFLT*, PLINT, PLINT);
+static void plnxtvlo (PLINT *, PLINT *, PLFLT*, PLINT, PLINT);
+static void plnxtvhi_draw(PLINT *u, PLINT *v, PLFLT* c, PLINT n);
+
+static void savehipoint	(PLINT, PLINT);
+static void savelopoint	(PLINT, PLINT);
+static void swaphiview	(void);
+static void swaploview	(void);
+static void myexit	(char *);
+static void myabort	(char *);
+static void freework	(void);
+static int  plabv	(PLINT, PLINT, PLINT, PLINT, PLINT, PLINT);
+static void pl3cut	(PLINT, PLINT, PLINT, PLINT, PLINT, 
+				PLINT, PLINT, PLINT, PLINT *, PLINT *);
+static PLFLT plGetAngleToLight(PLFLT* x, PLFLT* y, PLFLT* z);
+static void plP_draw3d(PLINT x, PLINT y, PLFLT *c, PLINT j, PLINT move);
+
+/* #define MJL_HACK 1 */
+#if MJL_HACK
+static void plP_fill3(PLINT x0, PLINT y0, PLINT x1, PLINT y1,
+		      PLINT x2, PLINT y2, PLINT j);
+static void plP_fill4(PLINT x0, PLINT y0, PLINT x1, PLINT y1,
+		      PLINT x2, PLINT y2, PLINT x3, PLINT y3, PLINT j);
+#endif
+
+/*--------------------------------------------------------------------------*\
+ * void plsetlightsource(x, y, z)
+ *
+ * Sets the position of the light source.
+\*--------------------------------------------------------------------------*/
+
+void
+c_pllightsource(PLFLT x, PLFLT y, PLFLT z)
+{
+    xlight = x;
+    ylight = y;
+    zlight = z;
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plmesh(x, y, z, nx, ny, opt)
+ *
+ * Plots a mesh representation of the function z[x][y]. The x values
+ * are stored as x[0..nx-1], the y values as y[0..ny-1], and the
+ * z values are in the 2-d array z[][]. The integer "opt" specifies:
+ * see plmeshc() bellow.
+\*--------------------------------------------------------------------------*/
+
+void
+c_plmesh(PLFLT *x, PLFLT *y, PLFLT **z, PLINT nx, PLINT ny, PLINT opt)
+{
+  c_plot3dc(x, y, z, nx, ny, opt | MESH, NULL, 0);
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plmeshc(x, y, z, nx, ny, opt, clevel, nlevel)
+ *
+ * Plots a mesh representation of the function z[x][y]. The x values
+ * are stored as x[0..nx-1], the y values as y[0..ny-1], and the
+ * z values are in the 2-d array z[][]. The integer "opt" specifies:
+ *
+ * DRAW_LINEX   draw lines parallel to the X axis
+ * DRAW_LINEY   draw lines parallel to the Y axis
+ * DRAW_LINEXY  draw lines parallel to both the X and Y axis
+ * MAG_COLOR    draw the mesh with a color dependent of the magnitude
+ * BASE_CONT    draw contour plot at bottom xy plane
+ * TOP_CONT     draw contour plot at top xy plane (not yet)
+ * DRAW_SIDES   draw sides
+ * 
+ * or any bitwise combination, e.g. "MAG_COLOR | DRAW_LINEX"
+ *
+\*--------------------------------------------------------------------------*/
+
+MZ_DLLEXPORT
+void
+c_plmeshc(PLFLT *x, PLFLT *y, PLFLT **z, PLINT nx, PLINT ny, PLINT opt,
+	 PLFLT *clevel, PLINT nlevel)
+{
+    plot3dc(x, y, z, nx, ny, opt | MESH, clevel, nlevel);
+}
+
+/* clipping helper for 3d polygons */
+
+int
+plP_clip_poly(int Ni, PLFLT *Vi[3], int axis, PLFLT dir, PLFLT offset)
+{
+  int anyout = 0;
+  PLFLT in[PL_MAXPOLY], T[3][PL_MAXPOLY];
+  int No = 0;
+  int i, j, k;
+
+  for(i=0; i<Ni; i++) {
+    in[i] = Vi[axis][i] * dir + offset;
+    anyout += in[i] < 0;
+  }
+
+  /* none out */
+  if(anyout == 0)
+    return Ni;
+
+  /* all out */
+  if(anyout == Ni) {
+    return 0;
+  }
+
+  /* some out */
+  /* copy over to a temp vector */
+  for(i=0; i<3; i++) {
+    for(j=0; j<Ni; j++) {
+      T[i][j] = Vi[i][j];
+    }
+  }
+  /* copy back selectively */
+  for(i=0; i<Ni; i++) {
+    j = (i+1) % Ni;
+
+    if(in[i]>=0 && in[j]>=0) {
+      for(k=0; k<3; k++)
+	Vi[k][No] = T[k][j];
+      No++;
+    } else if(in[i]>=0 && in[j]<0) {
+      PLFLT u = in[i] / (in[i] - in[j]);
+      for(k = 0; k<3; k++)
+	Vi[k][No] = T[k][i]*(1-u) + T[k][j]*u;
+      No++;
+    } else if(in[i]<0 && in[j]>=0) {
+      PLFLT u = in[i] / (in[i] - in[j]);
+      for(k = 0; k<3; k++)
+	Vi[k][No] = T[k][i]*(1-u) + T[k][j]*u;
+      No++;
+      for(k=0; k<3; k++)
+	Vi[k][No] = T[k][j];
+      No++;
+    }
+  }
+  return No;
+}
+
+/* helper for plsurf3d, similar to c_plfill3() */
+static void
+shade_triangle(PLFLT x0, PLFLT y0, PLFLT z0,
+			   PLFLT x1, PLFLT y1, PLFLT z1,
+			   PLFLT x2, PLFLT y2, PLFLT z2)
+{
+  int i;
+  /* arrays for interface to core functions */
+  short u[6], v[6];
+  PLFLT x[6], y[6], z[6], c;
+  int n;
+  PLFLT xmin, xmax, ymin, ymax, zmin, zmax, zscale;
+  PLFLT *V[3];
+
+  plP_gdom(&xmin, &xmax, &ymin, &ymax);
+  plP_grange(&zscale, &zmin, &zmax);
+
+  x[0] = x0; x[1] = x1; x[2] = x2;
+  y[0] = y0; y[1] = y1; y[2] = y2;
+  z[0] = z0; z[1] = z1; z[2] = z2;
+  n = 3;
+
+  if (falsecolor)
+      plcol1(((z[0] + z[1] + z[2]) /3. - fc_minz) / (fc_maxz - fc_minz));
+  else
+    plcol1(plGetAngleToLight(x, y, z));
+
+  V[0] = x; V[1] = y; V[2] = z;
+
+  n = plP_clip_poly(n, V, 0,  1, -xmin);
+  n = plP_clip_poly(n, V, 0, -1,  xmax);
+  n = plP_clip_poly(n, V, 1,  1, -ymin);
+  n = plP_clip_poly(n, V, 1, -1,  ymax);
+  n = plP_clip_poly(n, V, 2,  1, -zmin);
+  n = plP_clip_poly(n, V, 2, -1,  zmax);
+
+  for(i=0; i<n; i++) {
+    u[i] = plP_wcpcx(plP_w3wcx(x[i], y[i], z[i]));
+    v[i] = plP_wcpcy(plP_w3wcy(x[i], y[i], z[i]));
+    }
+  u[n] = u[0];
+  v[n] = v[0];
+
+#ifdef SHADE_DEBUG /* show triangles */
+  plcol0(1);
+  x[3]=x[0]; y[3]=y[0]; z[3]=z[0]; 
+  plline3(4,x,y,z);
+#else /* fill triangles */
+  plP_fill(u, v, n+1);
+#endif
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plotsurf3d(x, y, z, nx, ny, opt, clevel, nlevel)
+ *
+ * Plots the 3-d surface representation of the function z[x][y].
+ * The x values are stored as x[0..nx-1], the y values as y[0..ny-1],
+ *  and the z values are in the 2-d array z[][].
+ *
+ *
+ * DRAW_LINEX   draw lines parallel to the X axis
+ * DRAW_LINEY   draw lines parallel to the Y axis
+ * DRAW_LINEXY  draw lines parallel to both the X and Y axis
+ * BASE_CONT    draw contour plot at bottom xy plane
+ * TOP_CONT     draw contour plot at top xy plane
+ * SURF_CONT    draw contour at surface
+ * FACETED      each square that makes up the surface is faceted
+ * DRAW_SIDES   draw sides
+ * MAG_COLOR    the surface is colored according to the value of z;
+ *               if not defined, the surface is colored according to the
+ *               intensity of the reflected light in the surface from a light
+ *               source whose position is set using c_pllightsource()
+ *
+ * or any bitwise combination, e.g. "MAG_COLOR | SURF_CONT | SURF_BASE"
+ *
+ * This code is a complete departure from the approach taken in the old version
+ * of this routine. Formerly to code attempted to use the logic for the hidden
+ * line algorithm to draw the hidden surface. This was really hard. This code
+ * below uses a simple back to front (painters) algorithm. All the
+ * triangles are drawn.
+ *
+ * There are multitude of ways this code could be optimized. Given the
+ * problems with the old code, I tried to focus on clarity here. 
+\*--------------------------------------------------------------------------*/
+
+void
+plsurf3d(PLFLT *x, PLFLT *y, PLFLT **z, PLINT nx, PLINT ny,
+	  PLINT opt, PLFLT *clevel, PLINT nlevel)
+{
+  PLFLT cxx, cxy, cyx, cyy, cyz;
+  PLINT i, j, k;
+  PLINT ixDir, ixOrigin, iyDir, iyOrigin, nFast, nSlow;
+  PLINT ixFast, ixSlow, iyFast, iySlow;
+  PLINT iFast, iSlow;
+  PLFLT xmin, xmax, ymin, ymax, zmin, zmax, zscale;
+  PLFLT xm, ym, zm;
+  PLINT ixmin=0, ixmax=nx, iymin=0, iymax=ny;
+  PLFLT xx[3],yy[3],zz[3];
+  PLFLT px[4], py[4], pz[4];
+  CONT_LEVEL *cont, *clev;
+  CONT_LINE *cline;
+  int   ct, ix, iy;
+
+  if (plsc->level < 3) {
+    myabort("plsurf3d: Please set up window first");
+    return;
+  }
+    
+  if (nx <= 0 || ny <= 0) {
+    myabort("plsurf3d: Bad array dimensions.");
+    return;
+  }
+
+  /*  
+   * Don't use the data z value to scale the color, use the z axis
+   * values set by plw3d()
+   *
+   * plMinMax2dGrid(z, nx, ny, &fc_maxz, &fc_minz);
+   */
+
+  fc_minz = plsc->ranmi;
+  fc_maxz = plsc->ranma;
+  if (fc_maxz == fc_minz) {
+    plwarn("plsurf3d.c: Maximum and minimum Z values are equal! \"fixing\"...");
+    fc_maxz = fc_minz + 1e-6;
+  }
+
+  if (opt & MAG_COLOR)
+    falsecolor = 1;
+  else
+    falsecolor = 0;
+    
+  plP_gdom(&xmin, &xmax, &ymin, &ymax);
+  plP_grange(&zscale, &zmin, &zmax);
+  if(zmin > zmax) {
+    PLFLT t = zmin;
+    zmin = zmax;
+    zmax = t;
+  }
+
+  /* Check that points in x and in y are strictly increasing  and in range */
+
+  for (i = 0; i < nx - 1; i++) {
+    if (x[i] >= x[i + 1]) {
+      myabort("plsurf3d: X array must be strictly increasing");
+      return;
+    }
+    if (x[i] < xmin && x[i+1] >= xmin)
+      ixmin = i;
+    if (x[i+1] > xmax && x[i] <= xmax)
+      ixmax = i+2;
+  }
+  for (i = 0; i < ny - 1; i++) {
+    if (y[i] >= y[i + 1]) {
+      myabort("plsurf3d: Y array must be strictly increasing");
+      return;
+    }
+    if (y[i] < ymin && y[i+1] >= ymin)
+      iymin = i;
+    if (y[i+1] > ymax && y[i] <= ymax)
+      iymax = i+2;
+  }
+
+  /* get the viewing parameters */
+  plP_gw3wc(&cxx, &cxy, &cyx, &cyy, &cyz);
+
+  /* we're going to draw from back to front */
+
+  /* iFast will index the dominant (fastest changing) dimension
+     iSlow will index the slower changing dimension
+
+     iX indexes the X dimension
+     iY indexes the Y dimension */
+
+  /* get direction for X */
+  if(cxy >= 0) {
+    ixDir = 1;	/* direction in X */
+    ixOrigin = ixmin;	/* starting point */
+  } else {
+    ixDir = -1;
+    ixOrigin = ixmax - 1;
+  }
+  /* get direction for Y */
+  if(cxx >= 0) {
+    iyDir = -1;
+    iyOrigin = iymax - 1;
+  } else {
+    iyDir = 1;
+    iyOrigin = iymin;
+  }
+  /* figure out which dimension is dominant */
+  if (fabs(cxx) > fabs(cxy)) {
+    /* X is dominant */
+    nFast = ixmax - ixmin;	/* samples in the Fast direction */
+    nSlow = iymax - iymin;	/* samples in the Slow direction */
+      
+    ixFast = ixDir; ixSlow = 0;
+    iyFast = 0;     iySlow = iyDir;
+  } else {
+    nFast = iymax - iymin;
+    nSlow = ixmax - ixmin;
+
+    ixFast = 0;     ixSlow = ixDir;
+    iyFast = iyDir; iySlow = 0;
+  }
+
+  /* we've got to draw the background grid first, hidden line code has to draw it last */
+  if (zbflg) {
+    PLINT color = plsc->icol0;
+    PLFLT bx[3], by[3], bz[3];
+    PLFLT tick=0, tp;
+    PLINT nsub=0;
+
+    /* get the tick spacing */
+    pldtik(zmin, zmax, &tick, &nsub);
+
+    /* determine the vertices for the background grid line */
+    bx[0] = (ixOrigin!=ixmin && ixFast==0) || ixFast > 0 ? xmax : xmin;
+    by[0] = (iyOrigin!=iymin && iyFast==0) || iyFast > 0 ? ymax : ymin;
+    bx[1] = ixOrigin!=ixmin ? xmax : xmin;
+    by[1] = iyOrigin!=iymin ? ymax : ymin;
+    bx[2] = (ixOrigin!=ixmin && ixSlow==0) || ixSlow > 0 ? xmax : xmin;
+    by[2] = (iyOrigin!=iymin && iySlow==0) || iySlow > 0 ? ymax : ymin;
+
+    plcol(zbcol);
+    for(tp = tick * floor(zmin / tick) + tick; tp <= zmax; tp += tick) {
+      bz[0] = bz[1] = bz[2] = tp;
+      plline3(3, bx, by, bz);	
+    }
+    /* draw the vertical line at the back corner */
+    bx[0] = bx[1];
+    by[0] = by[1];
+    bz[0] = zmin;
+    plline3(2, bx, by, bz);
+    plcol(color);
+  }
+
+  /* If enabled, draw the contour at the base */
+
+  /* The contour ploted at the base will be identical to the one obtained
+   * with c_plcont(). The contour ploted at the surface is simple minded, but
+   * can be improved by using the contour data available.
+   */
+  
+  if (clevel != NULL && opt & BASE_CONT) {
+#define NPTS 100
+    int np = NPTS;
+    PLFLT *zz = (PLFLT *) malloc(NPTS*sizeof(PLFLT));
+
+    /* get the contour lines */
+    cont_store(x, y, z,  nx, ny, 1, nx, 1, ny, clevel, nlevel, &cont);
+
+    /* follow the contour levels and lines */
+    clev = cont;
+    do { /* for each contour level */
+      cline = clev->line;
+      do { /* there are several lines that make up the contour */
+	if (cline->npts > np) {
+	  np = cline->npts;
+	  zz = (PLFLT *) realloc(zz, np*sizeof(PLFLT));
+	}
+	for (j=0; j<cline->npts; j++)
+	  zz[j] = plsc->ranmi;
+	plcol1((clev->level-fc_minz)/(fc_maxz-fc_minz));
+	plline3(cline->npts, cline->x, cline->y, zz);
+	cline = cline->next;
+      }
+      while(cline != NULL);
+      clev = clev->next;
+    }
+    while(clev != NULL);
+  
+    cont_clean_store(cont); /* now release the memory */
+    free(zz);
+  }
+
+  /* Now we can iterate over the grid drawing the quads */
+  for(iSlow=0; iSlow < nSlow-1; iSlow++) {
+    for(iFast=0; iFast < nFast-1; iFast++) {
+      /* get the 4 corners of the Quad, which are
+       *      
+       *       0--2
+       *       |  |
+       *       1--3
+       */
+
+      xm = ym = zm = 0.;
+
+      for(i=0; i<2; i++) {
+	for(j=0; j<2; j++) {
+	  /* we're transforming from Fast/Slow coordinates to x/y coordinates */
+	  /* note, these are the indices, not the values */
+	  ix = ixFast * (iFast+i) + ixSlow * (iSlow+j) + ixOrigin;
+	  iy = iyFast * (iFast+i) + iySlow * (iSlow+j) + iyOrigin;
+
+	  xm += px[2*i+j] = x[ix];
+	  ym += py[2*i+j] = y[iy];
+	  zm += pz[2*i+j] = z[ix][iy];
+	}
+      }
+
+      /* the "mean point" of the quad, common to all four triangles
+	 -- perhaps not a good thing to do for the light shading */
+
+      xm /= 4.; ym /= 4.; zm /= 4.;
+
+      /* now draw the quad as four triangles */
+
+      for (i=1; i<3; i++) {
+	for (j=0; j<4; j+=3) {
+	  shade_triangle(px[j], py[j], pz[j], xm, ym, zm, px[i], py[i], pz[i]);
+
+	  /* after shading, see if the triangle crosses	one contour plane */
+
+#define min3(a,b,c) (MIN((MIN(a,b)),c))
+#define max3(a,b,c) (MAX((MAX(a,b)),c))
+
+	  if (clevel != NULL && (opt & SURF_CONT)) {
+	    for (k=0; k<nlevel; k++) {
+	      if (clevel[k] >= min3(pz[i],zm,pz[j]) && clevel[k] < max3(pz[i],zm,pz[j])) {
+		ct = 0;
+		if (clevel[k] >= MIN(pz[i],zm) && clevel[k] < MAX(pz[i],zm)) { /* p0-pm */
+		  xx[ct] = ((clevel[k] - pz[i])*(xm-px[i]))/(zm-pz[i]) + px[i];
+		  yy[ct] = ((clevel[k] - pz[i])*(ym-py[i]))/(zm-pz[i]) + py[i];
+		  ct++;
+		}
+
+		if (clevel[k] >= MIN(pz[i],pz[j]) && clevel[k] < MAX(pz[i],pz[j])) { /* p0-p1 */
+		  xx[ct] = ((clevel[k] - pz[i])*(px[j]-px[i]))/(pz[j]-pz[i]) + px[i];
+		  yy[ct] = ((clevel[k] - pz[i])*(py[j]-py[i]))/(pz[j]-pz[i]) + py[i];
+		  ct++;
+		}
+
+		if (clevel[k] >= MIN(pz[j],zm) && clevel[k] < MAX(pz[j],zm)) { /* p1-pm */
+		  xx[ct] = ((clevel[k] - pz[j])*(xm-px[j]))/(zm-pz[j]) + px[j];
+		  yy[ct] = ((clevel[k] - pz[j])*(ym-py[j]))/(zm-pz[j]) + py[j];
+		  ct++;
+		}
+		
+		if (ct == 2) {
+
+		  /* yes, xx and yy are the intersection points of the triangle with
+		   * the contour line -- draw a straight line betweeen the points
+		   * -- at the end this will make up the contour line */
+
+		  if (opt & SURF_CONT) {
+		    /* surface contour with black color (suggestions?) */
+		    plcol0(0);
+		    zz[0] = zz[1] = clevel[k]; 
+		    plline3(2, xx, yy, zz);
+		  }
+
+		  /* don't break; one triangle can span various contour levels */
+
+		} else
+		  plwarn("plot3d.c:plsurf3d() ***ERROR***\n");
+	      } 
+	    }
+	  }
+	}
+      }
+    }
+  }
+
+  if (opt & FACETED) {
+    plcol0(0);
+    plot3dc(x, y, z, nx, ny, MESH | DRAW_LINEXY, NULL, 0);
+  }
+
+  if (opt & DRAW_SIDES) { /* the sides look ugly !!! */
+    /* draw one more row with all the Z's set to zmin */
+    PLFLT zscale, zmin, zmax;
+
+    plP_grange(&zscale, &zmin, &zmax);
+    
+    iSlow = nSlow-1;
+    for(iFast=0; iFast < nFast-1; iFast++) {
+      for(i=0; i<2; i++) {
+	ix = ixFast * (iFast+i) + ixSlow * iSlow + ixOrigin;
+	iy = iyFast * (iFast+i) + iySlow * iSlow + iyOrigin;
+	px[2*i] = x[ix]; 
+	py[2*i] = y[iy];
+	pz[2*i] = z[ix][iy];
+      }
+      /* now draw the quad as two triangles (4 might be better) */
+	 
+      shade_triangle(px[0], py[0], pz[0], px[2], py[2], pz[2], px[0], py[0], zmin);
+      shade_triangle(px[2], py[2], pz[2], px[2], py[2], zmin,  px[0], py[0], zmin);
+    }
+    
+    iFast = nFast-1;
+    for(iSlow=0; iSlow < nSlow-1; iSlow++) {
+      for(i=0; i<2; i++) {
+	  ix = ixFast * iFast + ixSlow * (iSlow+i) + ixOrigin;
+	  iy = iyFast * iFast + iySlow * (iSlow+i) + iyOrigin;
+	  px[2*i] = x[ix];
+	  py[2*i] = y[iy];
+	  pz[2*i] = z[ix][iy];
+	}
+
+      /* now draw the quad as two triangles (4 might be better) */
+      shade_triangle(px[0], py[0], pz[0], px[2], py[2], pz[2], px[0], py[0], zmin);
+      shade_triangle(px[2], py[2], pz[2], px[2], py[2], zmin,  px[0], py[0], zmin);
+    }
+  }
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plot3d(x, y, z, nx, ny, opt, side)
+ *
+ * Plots a 3-d representation of the function z[x][y]. The x values
+ * are stored as x[0..nx-1], the y values as y[0..ny-1], and the z
+ * values are in the 2-d array z[][]. The integer "opt" specifies:
+ * see plot3dc() bellow
+\*--------------------------------------------------------------------------*/
+
+MZ_DLLEXPORT
+void
+c_plot3d(PLFLT *x, PLFLT *y, PLFLT **z,
+	 PLINT nx, PLINT ny, PLINT opt, PLINT side)
+{
+  c_plot3dc( x, y, z, nx, ny, opt | (side == 1 ? DRAW_SIDES : 0), NULL, 0);
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plot3dc(x, y, z, nx, ny, opt, clevel, nlevel)
+ *
+ * Plots a 3-d representation of the function z[x][y]. The x values
+ * are stored as x[0..nx-1], the y values as y[0..ny-1], and the z
+ * values are in the 2-d array z[][]. The integer "opt" specifies:
+ *
+ *  DRAW_LINEX :  Draw lines parallel to x-axis
+ *  DRAW_LINEY :  Draw lines parallel to y-axis
+ *  DRAW_LINEXY:  Draw lines parallel to both axes
+ *  MAG_COLOR:    Magnitude coloring of wire frame
+ *  BASE_CONT:    Draw contour at bottom xy plane 
+ *  TOP_CONT:     Draw contour at top xy plane (not yet)
+ *  DRAW_SIDES:   Draw sides around the plot
+ *  MESH:       Draw the "under" side of the plot
+ *
+ * or any bitwise combination, e.g. "MAG_COLOR | DRAW_LINEX"
+ *
+\*--------------------------------------------------------------------------*/
+
+void
+c_plot3dc(PLFLT *x, PLFLT *y, PLFLT **z,
+	 PLINT nx, PLINT ny, PLINT opt,
+	 PLFLT *clevel, PLINT nlevel)
+{
+    PLFLT cxx, cxy, cyx, cyy, cyz;
+    PLINT init, i, ix, iy, color;
+    PLFLT xmin, xmax, ymin, ymax, zmin, zmax, zscale;
+    PLINT ixmin=0, ixmax=nx-1, iymin=0, iymax=ny-1;
+    PLINT clipped = 0, base_cont = 0, side = 0;
+
+    pl3mode = 0;
+
+    if (plsc->level < 3) {
+	myabort("plot3dc: Please set up window first");
+	return;
+    }
+
+    if (opt < 1) {
+	myabort("plot3dc: Bad option");
+	return;
+    }
+
+    if (nx <= 0 || ny <= 0) {
+	myabort("plot3dc: Bad array dimensions.");
+	return;
+    }
+
+    plP_gdom(&xmin, &xmax, &ymin, &ymax);
+    plP_grange(&zscale, &zmin, &zmax);
+    if(zmin > zmax) {
+      PLFLT t = zmin;
+      zmin = zmax;
+      zmax = t;
+    }
+
+/* Check that points in x and in y are strictly increasing */
+
+    for (i = 0; i < nx - 1; i++) {
+	if (x[i] >= x[i + 1]) {
+	    myabort("plot3dc: X array must be strictly increasing");
+	    return;
+	}
+    }
+    for (i = 0; i < ny - 1; i++) {
+	if (y[i] >= y[i + 1]) {
+	    myabort("plot3dc: Y array must be strictly increasing");
+	    return;
+	}
+    }
+
+    if (opt & MESH)
+      pl3mode = 1;
+
+    if (opt & DRAW_SIDES)
+      side = 1;
+
+    /* figure out the part of the data to use */
+    if (xmin < x[0])
+      xmin = x[0];
+    if (xmax > x[nx-1])
+      xmax = x[nx-1];
+    if (ymin < y[0])
+      ymin = y[0];
+    if (ymax > y[ny-1])
+      ymax = y[ny-1];
+    for (ixmin = 0; ixmin < nx-1 && x[ixmin+1] < xmin; ixmin++) {}
+    for (ixmax = nx-1; ixmax > 0 && x[ixmax-1] > xmax; ixmax--) {}
+    for (iymin = 0; iymin < ny-1 && y[iymin+1] < ymin; iymin++) {}
+    for (iymax = ny-1; iymax > 0 && y[iymax-1] > ymax; iymax--) {}
+    /*fprintf(stderr, "(%d,%d) %d %d %d %d\n", nx, ny, ixmin, ixmax, iymin, iymax);*/
+    /* do we need to clip? */
+    if(ixmin > 0 || ixmax < nx-1 || iymin > 0 || iymax < ny-1) {
+      /* adjust the input so it stays within bounds */
+      int _nx = ixmax - ixmin + 1;
+      int _ny = iymax - iymin + 1;
+      PLFLT *_x, *_y, **_z;
+      PLFLT ty0, ty1, tx0, tx1;
+      int i, j;
+
+      if(_nx <= 1 || _ny <= 1) {
+	fprintf(stderr, "bail\n");
+	return;
+      }
+
+      /* allocate storage for new versions of the input vectors */
+      _x = (PLFLT*)malloc(_nx * sizeof(PLFLT));
+      _y = (PLFLT*)malloc(_ny * sizeof(PLFLT));
+      _z = (PLFLT**)malloc(_nx * sizeof(PLFLT*));
+
+      clipped = 1;
+
+      /* copy over the independent variables */
+      _x[0] = xmin;
+      _x[_nx-1] = xmax;
+      for(i=1; i<_nx-1; i++)
+	_x[i] = x[ixmin+i];
+      _y[0] = ymin;
+      _y[_ny-1] = ymax;
+      for(i=1; i<_ny-1; i++)
+	_y[i] = y[iymin+i];
+
+      /* copy the data array so we can interpolate around the edges */
+      for(i=0; i<_nx; i++)
+	_z[i] = (PLFLT*)malloc(_ny * sizeof(PLFLT));
+
+      /* interpolation factors for the 4 edges */
+      ty0 = (_y[0] - y[iymin]) / (y[iymin+1] - y[iymin]);
+      ty1 = (_y[_ny-1] - y[iymax-1]) / (y[iymax] - y[iymax-1]);
+      tx0 = (_x[0] - x[ixmin]) / (x[ixmin+1] - x[ixmin]);
+      tx1 = (_x[_nx-1] - x[ixmax-1]) / (x[ixmax] - x[ixmax-1]);
+      for(i=0; i<_nx; i++) {
+	if(i==0) {
+	  _z[i][0] = z[ixmin][iymin]*(1-ty0)*(1-tx0) + z[ixmin][iymin+1]*(1-tx0)*ty0
+	    + z[ixmin+1][iymin]*tx0*(1-ty0) + z[ixmin+1][iymin+1]*tx0*ty0;
+	  for(j=1; j<_ny-1; j++)
+	    _z[i][j] = z[ixmin][iymin+j]*(1-tx0) + z[ixmin+1][iymin+j]*tx0;
+	  _z[i][_ny-1] = z[ixmin][iymax-1]*(1-tx0)*(1-ty1) + z[ixmin][iymax]*(1-tx0)*ty1
+	    + z[ixmin+1][iymax-1]*tx0*(1-ty1) + z[ixmin+1][iymax]*tx0*ty1;
+	} else if(i==_nx-1) {
+	  _z[i][0] = z[ixmax-1][iymin]*(1-tx1)*(1-ty0) + z[ixmax-1][iymin+1]*(1-tx1)*ty0
+	    + z[ixmax][iymin]*tx1*(1-ty0) + z[ixmax][iymin+1]*tx1*ty0;
+	  for(j=1; j<_ny-1; j++)
+	    _z[i][j] = z[ixmax-1][iymin+j]*(1-tx1) + z[ixmax][iymin+j]*tx1;
+	  _z[i][_ny-1] = z[ixmax-1][iymax-1]*(1-tx1)*(1-ty1) + z[ixmax][iymax]*(1-tx1)*ty1
+	    + z[ixmax][iymax-1]*tx1*(1-ty1) + z[ixmax][iymax]*tx1*ty1;
+	} else {
+	  _z[i][0] = z[ixmin+i][iymin]*(1-ty0) + z[ixmin+i][iymin+1]*ty0;
+	  for(j=1; j<_ny-1; j++)
+	    _z[i][j] = z[ixmin+i][iymin+j];
+	  _z[i][_ny-1] = z[ixmin+i][iymax-1]*(1-ty1) + z[ixmin+i][iymax]*ty1;
+	}
+	for(j=0; j<_ny; j++) {
+	  if(_z[i][j] < zmin)
+	    _z[i][j] = zmin;
+	  else if(_z[i][j] > zmax)
+	    _z[i][j] = zmax;
+	}
+      }
+      /* replace the input with our clipped versions */
+      x = _x;
+      y = _y;
+      z = _z;
+      nx = _nx;
+      ny = _ny;	  
+    }
+
+   if (opt & BASE_CONT || opt & TOP_CONT || opt && MAG_COLOR ) { 
+     /*  
+      * Don't use the data z value to scale the color, use the z axis
+      * values set by plw3d()
+      *
+      * plMinMax2dGrid(z, nx, ny, &fc_maxz, &fc_minz);
+      */
+     
+     fc_minz = plsc->ranmi;
+     fc_maxz = plsc->ranma;     
+
+     if (fc_maxz == fc_minz) {
+       plwarn("plot3dc: Maximum and minimum Z values are equal! \"fixing\"...");
+       fc_maxz = fc_minz + 1e-6;
+     }
+   }
+ 
+   if (opt & BASE_CONT) {     /* If enabled, draw the contour at the base.  */
+     if (clevel != NULL && nlevel != 0) {
+       base_cont = 1;
+       /* even if MESH is not set, "set it",
+	  as the base contour can only be done in this case */
+       pl3mode = 1; 
+     }
+   }
+
+   if (opt & MAG_COLOR) {     /* If enabled, use magnitude colored wireframe  */
+     ctmp = (PLFLT *) malloc((size_t) (2 * MAX(nx, ny) * sizeof(PLFLT)));
+   } else
+     ctmp = NULL;
+
+   /* next logic only knows opt = 1 | 2 | 3, make sure that it only gets that */
+   opt &= DRAW_LINEXY;
+
+    /* Allocate work arrays */
+
+    utmp = (PLINT *) malloc((size_t) (2 * MAX(nx, ny) * sizeof(PLINT)));
+    vtmp = (PLINT *) malloc((size_t) (2 * MAX(nx, ny) * sizeof(PLINT)));
+
+    if ( ! utmp || ! vtmp)
+	myexit("plot3dc: Out of memory.");
+
+    plP_gw3wc(&cxx, &cxy, &cyx, &cyy, &cyz);
+    init = 1;
+/* Call 3d line plotter.  Each viewing quadrant 
+   (perpendicular to x-y plane) must be handled separately. */ 
+
+    if (cxx >= 0.0 && cxy <= 0.0) {
+	if (opt == DRAW_LINEY) 
+	    plt3zz(1, ny, 1, -1, -opt, &init, x, y, z, nx, ny, utmp, vtmp,ctmp);
+	else {
+	    for (iy = 2; iy <= ny; iy++)
+		plt3zz(1, iy, 1, -1, -opt, &init, x, y, z, nx, ny, utmp, vtmp,ctmp);
+	}
+	if (opt == DRAW_LINEX)
+	    plt3zz(1, ny, 1, -1, opt, &init, x, y, z, nx, ny, utmp, vtmp, ctmp);
+	else {
+	    for (ix = 1; ix <= nx - 1; ix++)
+		plt3zz(ix, ny, 1, -1, opt, &init, x, y, z, nx, ny, utmp, vtmp, ctmp);
+	}
+    }
+
+    else if (cxx <= 0.0 && cxy <= 0.0) {
+        if (opt == DRAW_LINEX)
+	    plt3zz(nx, ny, -1, -1, opt, &init, x, y, z, nx, ny, utmp, vtmp, ctmp);
+	else {
+	    for (ix = 2; ix <= nx; ix++) 
+		plt3zz(ix, ny, -1, -1, opt, &init, x, y, z, nx, ny, utmp, vtmp, ctmp);
+	}
+	if (opt == DRAW_LINEY)
+	    plt3zz(nx, ny, -1, -1, -opt, &init, x, y, z, nx, ny, utmp, vtmp, ctmp);
+	else {
+	    for (iy = ny; iy >= 2; iy--)
+	      plt3zz(nx, iy, -1, -1, -opt, &init, x, y, z, nx, ny, utmp, vtmp, ctmp);
+	}
+    }
+
+    else if (cxx <= 0.0 && cxy >= 0.0) {
+	if (opt == DRAW_LINEY) 
+	    plt3zz(nx, 1, -1, 1, -opt, &init, x, y, z, nx, ny, utmp, vtmp, ctmp);
+	else {
+	    for (iy = ny - 1; iy >= 1; iy--) 
+		plt3zz(nx, iy, -1, 1, -opt, &init, x, y, z, nx, ny, utmp, vtmp, ctmp);
+	}
+	if (opt == DRAW_LINEX)
+	    plt3zz(nx, 1, -1, 1, opt, &init, x, y, z, nx, ny, utmp, vtmp, ctmp);
+	else {
+	    for (ix = nx; ix >= 2; ix--)
+		plt3zz(ix, 1, -1, 1, opt, &init, x, y, z, nx, ny, utmp, vtmp, ctmp);
+	}
+    }
+
+    else if (cxx >= 0.0 && cxy >= 0.0) {
+	if (opt == DRAW_LINEX) 
+	    plt3zz(1, 1, 1, 1, opt, &init, x, y, z, nx, ny, utmp, vtmp, ctmp);
+	else {
+	    for (ix = nx - 1; ix >= 1; ix--) 
+		plt3zz(ix, 1, 1, 1, opt, &init, x, y, z, nx, ny, utmp, vtmp, ctmp);
+	}
+	if (opt == DRAW_LINEY)
+	    plt3zz(1, 1, 1, 1, -opt, &init, x, y, z, nx, ny, utmp, vtmp, ctmp);
+	else {
+	    for (iy = 1; iy <= ny - 1; iy++)
+		plt3zz(1, iy, 1, 1, -opt, &init, x, y, z, nx, ny, utmp, vtmp, ctmp);
+	}
+    }
+
+    /* draw contour at the base. Not 100%! Why? */
+ 
+    if (base_cont){
+      int np = NPTS, j;
+      CONT_LEVEL *cont, *clev;
+      CONT_LINE *cline;
+
+      PLINT *uu = (PLINT *) malloc(NPTS*sizeof(PLINT));
+      PLINT *vv = (PLINT *) malloc(NPTS*sizeof(PLINT));
+
+      pl3upv = 0;
+
+      /* get the contour lines */
+      cont_store(x, y, z,  nx, ny, 1, nx, 1, ny, clevel, nlevel, &cont);
+
+      /* follow the contour levels and lines */
+      clev = cont;
+      do { /* for each contour level */
+	cline = clev->line;
+	do { /* there are several lines that make up each contour */
+	  int cx, i, k, l, m, start, end;
+	  PLFLT tx, ty;
+	  if (cline->npts > np) {
+	    np = cline->npts;
+	    uu = (PLINT *) realloc(uu, np*sizeof(PLINT));
+	    vv = (PLINT *) realloc(vv, np*sizeof(PLINT));
+	  }
+
+	  /* the hidden line plotter plnxtv() only works OK if the x points are in increasing order.
+	     As this does not always happens, the situation must be detected and the line segment
+	     must be reversed before being plotted */
+
+	  plcol1((clev->level-fc_minz)/(fc_maxz-fc_minz));
+ 	  i = 0;
+	  do { 
+	    cx =  plP_wcpcx(plP_w3wcx(cline->x[i],cline->y[i], plsc->ranmi));
+	    for (j=i; j < cline->npts; j++) {  /* convert to 2D coordinates */
+	      uu[j] = plP_wcpcx(plP_w3wcx(cline->x[j],cline->y[j], plsc->ranmi)); 
+	      vv[j] = plP_wcpcy(plP_w3wcy(cline->x[j],cline->y[j], plsc->ranmi)); 
+	      if (uu[j] < cx) /* find turn back point */
+		break;
+	      else
+		cx = uu[j];
+	    }
+	    plnxtv(&uu[i], &vv[i], NULL, j-i, 0); /* plot line with increasing x */
+
+	    if (j < cline->npts) { /* line not yet finished, */
+	      start = j-1;
+	      for (i = start; i < cline->npts; i++) {  /* search turn forward point */
+		uu[i] = plP_wcpcx(plP_w3wcx(cline->x[i],cline->y[i], plsc->ranmi));
+		if (uu[i] > cx)
+		  break;
+		else
+		  cx = uu[i];
+	      }
+	      end = i-1;
+
+	      for (k=0; k < (end-start+1)/2; k++) { /* reverse line segment */
+		l = start+k;
+		m = end-k;
+		tx = cline->x[l];
+		ty = cline->y[l];
+		cline->x[l] = cline->x[m];
+		cline->y[l] = cline->y[m];
+		cline->x[m] = tx;
+		cline->y[m] = ty;
+	      }
+
+	      /* convert to 2D coordinates */
+	      for (j=start; j <= end; j++) {
+		uu[j] = plP_wcpcx(plP_w3wcx(cline->x[j],cline->y[j], plsc->ranmi)); 
+		vv[j] = plP_wcpcy(plP_w3wcy(cline->x[j],cline->y[j], plsc->ranmi)); 
+	      }
+	      plnxtv(&uu[start], &vv[start], NULL, end-start+1, 0); /* and plot it */
+
+	      i = end+1; /* restart where it was left */
+	    }
+	  } while (j < cline->npts && i < cline->npts);
+	  cline = cline->next;
+	}
+	while(cline != NULL);
+	clev = clev->next;
+      }
+      while(clev != NULL);
+
+      cont_clean_store(cont); /* now release the contour memory */
+      pl3upv = 1;
+      free(uu);
+      free(vv);
+    }
+
+/* Finish up by drawing sides, background grid (both are optional) */
+
+    if (side)
+	plside3(x, y, z, nx, ny, opt);
+
+    if (zbflg) {
+	color = plsc->icol0;
+	plcol(zbcol);
+	plgrid3(zbtck);
+	plcol(color);
+    }
+
+    freework();
+
+    if(clipped) {
+      free(x);
+      free(y);
+      for(i=0; i<nx; i++)
+	free(z[i]);
+      free(z);
+    }
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plP_gzback()
+ *
+ * Get background parameters for 3d plot.
+\*--------------------------------------------------------------------------*/
+
+void
+plP_gzback(PLINT **zbf, PLINT **zbc, PLFLT **zbt)
+{
+    *zbf = &zbflg;
+    *zbc = &zbcol;
+    *zbt = &zbtck;
+}
+
+/*--------------------------------------------------------------------------*\
+ * PLFLT plGetAngleToLight()
+ *
+ * Gets cos of angle between normal to a polygon and a light source.
+ * Requires at least 3 elements, forming non-parallel lines 
+ * in the arrays.
+\*--------------------------------------------------------------------------*/
+
+static PLFLT
+plGetAngleToLight(PLFLT* x, PLFLT* y, PLFLT* z)
+{
+    PLFLT vx1, vx2, vy1, vy2, vz1, vz2;
+    PLFLT px, py, pz;
+    PLFLT vlx, vly, vlz;
+    PLFLT mag1, mag2;
+    PLFLT cosangle;
+
+    vx1 = x[1] - x[0];
+    vx2 = x[2] - x[1];
+    vy1 = y[1] - y[0];
+    vy2 = y[2] - y[1];
+    vz1 = z[1] - z[0];
+    vz2 = z[2] - z[1];
+
+/* Find vector perpendicular to the face */
+    px = vy1*vz2 - vz1*vy2;
+    py = vz1*vx2 - vx1*vz2;
+    pz = vx1*vy2 - vy1*vx2;
+    mag1 = px*px + py*py + pz*pz;
+
+/* Vectors were parallel! */
+    if (mag1 == 0) 
+	return 1;
+
+    vlx = xlight - x[0];
+    vly = ylight - y[0];
+    vlz = zlight - z[0];
+    mag2 = vlx*vlx + vly*vly + vlz*vlz;
+    if (mag2 ==0) 
+	return 1;
+
+/* Now have 3 vectors going through the first point on the given surface */
+    cosangle = fabs( (vlx*px + vly*py + vlz*pz) / sqrt(mag1*mag2) );
+
+/* In case of numerical rounding */
+    if (cosangle > 1) cosangle = 1;
+    return cosangle;
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plt3zz()
+ *
+ * Draws the next zig-zag line for a 3-d plot.  The data is stored in array
+ * z[][] as a function of x[] and y[], and is plotted out starting at index
+ * (x0,y0).
+ *
+ * Depending on the state of "flag", the sequence of data points sent to
+ * plnxtv is altered so as to allow cross-hatch plotting, or plotting
+ * parallel to either the x-axis or the y-axis.
+\*--------------------------------------------------------------------------*/
+
+static void
+plt3zz(PLINT x0, PLINT y0, PLINT dx, PLINT dy, PLINT flag, PLINT *init,
+       PLFLT *x, PLFLT *y, PLFLT **z, PLINT nx, PLINT ny, 
+       PLINT *u, PLINT *v, PLFLT* c)
+{
+    PLINT n = 0;
+    PLFLT x2d, y2d;
+
+    while (1 <= x0 && x0 <= nx && 1 <= y0 && y0 <= ny) {
+	x2d = plP_w3wcx(x[x0 - 1], y[y0 - 1], z[x0 - 1][y0 - 1]);
+	y2d = plP_w3wcy(x[x0 - 1], y[y0 - 1], z[x0 - 1][y0 - 1]);
+	u[n] = plP_wcpcx(x2d);
+	v[n] = plP_wcpcy(y2d);
+	if (c != NULL)
+	  c[n] = (z[x0 - 1][y0 - 1] - fc_minz)/(fc_maxz-fc_minz);
+
+	switch (flag) {
+	case -3:
+	    y0 += dy;
+	    flag = -flag;
+	    break;
+	case -2:
+	    y0 += dy;
+	    break;
+	case -1:
+	    y0 += dy;
+	    flag = -flag;
+	    break;
+	case 1:
+	    x0 += dx;
+	    break;
+	case 2:
+	    x0 += dx;
+	    flag = -flag;
+	    break;
+	case 3:
+	    x0 += dx;
+	    flag = -flag;
+	    break;
+	}
+	n++;
+    }
+
+    if (flag == 1 || flag == -2) {
+	if (flag == 1) {
+	    x0 -= dx;
+	    y0 += dy;
+	}
+	else if (flag == -2) {
+	    y0 -= dy;
+	    x0 += dx;
+	}
+	if (1 <= x0 && x0 <= nx && 1 <= y0 && y0 <= ny) {
+	    x2d = plP_w3wcx( x[x0 - 1], y[y0 - 1], z[x0 - 1][y0 - 1]);
+	    y2d = plP_w3wcy( x[x0 - 1], y[y0 - 1], z[x0 - 1][y0 - 1]);
+	    u[n] = plP_wcpcx(x2d);
+	    v[n] = plP_wcpcy(y2d);
+	    if (c != NULL)
+	      c[n] = (z[x0 - 1][y0 - 1] - fc_minz)/(fc_maxz-fc_minz);
+	    n++;
+	}
+    }
+
+/* All the setup is done.  Time to do the work. */
+
+    plnxtv(u, v, c, n, *init);
+    *init = 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plside3()
+ *
+ * This routine draws sides around the front of the 3d plot so that
+ * it does not appear to float.
+\*--------------------------------------------------------------------------*/
+
+static void
+plside3(PLFLT *x, PLFLT *y, PLFLT **z, PLINT nx, PLINT ny, PLINT opt)
+{
+    PLINT i;
+    PLFLT cxx, cxy, cyx, cyy, cyz;
+    PLFLT xmin, ymin, zmin, xmax, ymax, zmax, zscale;
+    PLFLT tx, ty, ux, uy;
+
+    plP_gw3wc(&cxx, &cxy, &cyx, &cyy, &cyz);
+    plP_gdom(&xmin, &xmax, &ymin, &ymax);
+    plP_grange(&zscale, &zmin, &zmax);
+
+/* Get x, y coordinates of legs and plot */
+
+    if (cxx >= 0.0 && cxy <= 0.0) {
+	if (opt != 1) {
+	    for (i = 0; i < nx; i++) {
+		tx = plP_w3wcx(x[i], y[0], zmin);
+		ty = plP_w3wcy(x[i], y[0], zmin);
+		ux = plP_w3wcx(x[i], y[0], z[i][0]);
+		uy = plP_w3wcy(x[i], y[0], z[i][0]);
+		pljoin(tx, ty, ux, uy);
+	    }
+	}
+	if (opt != 2) {
+	    for (i = 0; i < ny; i++) {
+		tx = plP_w3wcx(x[0], y[i], zmin);
+		ty = plP_w3wcy(x[0], y[i], zmin);
+		ux = plP_w3wcx(x[0], y[i], z[0][i]);
+		uy = plP_w3wcy(x[0], y[i], z[0][i]);
+		pljoin(tx, ty, ux, uy);
+	    }
+	}
+    }
+    else if (cxx <= 0.0 && cxy <= 0.0) {
+	if (opt != 1) {
+	    for (i = 0; i < nx; i++) {
+		tx = plP_w3wcx(x[i], y[ny - 1], zmin);
+		ty = plP_w3wcy(x[i], y[ny - 1], zmin);
+		ux = plP_w3wcx(x[i], y[ny - 1], z[i][ny - 1]);
+		uy = plP_w3wcy(x[i], y[ny - 1], z[i][ny - 1]);
+		pljoin(tx, ty, ux, uy);
+	    }
+	}
+	if (opt != 2) {
+	    for (i = 0; i < ny; i++) {
+		tx = plP_w3wcx(x[0], y[i], zmin);
+		ty = plP_w3wcy(x[0], y[i], zmin);
+		ux = plP_w3wcx(x[0], y[i], z[0][i]);
+		uy = plP_w3wcy(x[0], y[i], z[0][i]);
+		pljoin(tx, ty, ux, uy);
+	    }
+	}
+    }
+    else if (cxx <= 0.0 && cxy >= 0.0) {
+	if (opt != 1) {
+	    for (i = 0; i < nx; i++) {
+		tx = plP_w3wcx(x[i], y[ny - 1], zmin);
+		ty = plP_w3wcy(x[i], y[ny - 1], zmin);
+		ux = plP_w3wcx(x[i], y[ny - 1], z[i][ny - 1]);
+		uy = plP_w3wcy(x[i], y[ny - 1], z[i][ny - 1]);
+		pljoin(tx, ty, ux, uy);
+	    }
+	}
+	if (opt != 2) {
+	    for (i = 0; i < ny; i++) {
+		tx = plP_w3wcx(x[nx - 1], y[i], zmin);
+		ty = plP_w3wcy(x[nx - 1], y[i], zmin);
+		ux = plP_w3wcx(x[nx - 1], y[i], z[nx - 1][i]);
+		uy = plP_w3wcy(x[nx - 1], y[i], z[nx - 1][i]);
+		pljoin(tx, ty, ux, uy);
+	    }
+	}
+    }
+    else if (cxx >= 0.0 && cxy >= 0.0) {
+	if (opt != 1) {
+	    for (i = 0; i < nx; i++) {
+		tx = plP_w3wcx(x[i], y[0], zmin);
+		ty = plP_w3wcy(x[i], y[0], zmin);
+		ux = plP_w3wcx(x[i], y[0], z[i][0]);
+		uy = plP_w3wcy(x[i], y[0], z[i][0]);
+		pljoin(tx, ty, ux, uy);
+	    }
+	}
+	if (opt != 2) {
+	    for (i = 0; i < ny; i++) {
+		tx = plP_w3wcx(x[nx - 1], y[i], zmin);
+		ty = plP_w3wcy(x[nx - 1], y[i], zmin);
+		ux = plP_w3wcx(x[nx - 1], y[i], z[nx - 1][i]);
+		uy = plP_w3wcy(x[nx - 1], y[i], z[nx - 1][i]);
+		pljoin(tx, ty, ux, uy);
+	    }
+	}
+    }
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plgrid3()
+ *
+ * This routine draws a grid around the back side of the 3d plot with
+ * hidden line removal.
+\*--------------------------------------------------------------------------*/
+
+static void
+plgrid3(PLFLT tick)
+{
+    PLFLT xmin, ymin, zmin, xmax, ymax, zmax, zscale;
+    PLFLT cxx, cxy, cyx, cyy, cyz, zmin_in, zmax_in;
+    PLINT u[3], v[3];
+    PLINT nsub = 0;
+    PLFLT tp;
+
+    plP_gw3wc(&cxx, &cxy, &cyx, &cyy, &cyz);
+    plP_gdom(&xmin, &xmax, &ymin, &ymax);
+    plP_grange(&zscale, &zmin_in, &zmax_in);
+    zmin = (zmax_in > zmin_in) ? zmin_in: zmax_in;
+    zmax = (zmax_in > zmin_in) ? zmax_in: zmin_in;
+
+    pldtik(zmin, zmax, &tick, &nsub);
+    tp = tick * floor(zmin / tick) + tick;
+    pl3upv = 0;
+
+    if (cxx >= 0.0 && cxy <= 0.0) {
+	while (tp <= zmax) {
+	    u[0] = plP_wcpcx(plP_w3wcx(xmin, ymax, tp));
+	    v[0] = plP_wcpcy(plP_w3wcy(xmin, ymax, tp));
+	    u[1] = plP_wcpcx(plP_w3wcx(xmax, ymax, tp));
+	    v[1] = plP_wcpcy(plP_w3wcy(xmax, ymax, tp));
+	    u[2] = plP_wcpcx(plP_w3wcx(xmax, ymin, tp));
+	    v[2] = plP_wcpcy(plP_w3wcy(xmax, ymin, tp));
+	    plnxtv(u, v, 0, 3, 0);
+
+	    tp += tick;
+	}
+	u[0] = plP_wcpcx(plP_w3wcx(xmax, ymax, zmin));
+	v[0] = plP_wcpcy(plP_w3wcy(xmax, ymax, zmin));
+	u[1] = plP_wcpcx(plP_w3wcx(xmax, ymax, zmax));
+	v[1] = plP_wcpcy(plP_w3wcy(xmax, ymax, zmax));
+	plnxtv(u, v, 0, 2, 0);
+    }
+    else if (cxx <= 0.0 && cxy <= 0.0) {
+	while (tp <= zmax) {
+	    u[0] = plP_wcpcx(plP_w3wcx(xmax, ymax, tp));
+	    v[0] = plP_wcpcy(plP_w3wcy(xmax, ymax, tp));
+	    u[1] = plP_wcpcx(plP_w3wcx(xmax, ymin, tp));
+	    v[1] = plP_wcpcy(plP_w3wcy(xmax, ymin, tp));
+	    u[2] = plP_wcpcx(plP_w3wcx(xmin, ymin, tp));
+	    v[2] = plP_wcpcy(plP_w3wcy(xmin, ymin, tp));
+	    plnxtv(u, v, 0,3, 0);
+
+	    tp += tick;
+	}
+	u[0] = plP_wcpcx(plP_w3wcx(xmax, ymin, zmin));
+	v[0] = plP_wcpcy(plP_w3wcy(xmax, ymin, zmin));
+	u[1] = plP_wcpcx(plP_w3wcx(xmax, ymin, zmax));
+	v[1] = plP_wcpcy(plP_w3wcy(xmax, ymin, zmax));
+	plnxtv(u, v, 0,2, 0);
+    }
+    else if (cxx <= 0.0 && cxy >= 0.0) {
+	while (tp <= zmax) {
+	    u[0] = plP_wcpcx(plP_w3wcx(xmax, ymin, tp));
+	    v[0] = plP_wcpcy(plP_w3wcy(xmax, ymin, tp));
+	    u[1] = plP_wcpcx(plP_w3wcx(xmin, ymin, tp));
+	    v[1] = plP_wcpcy(plP_w3wcy(xmin, ymin, tp));
+	    u[2] = plP_wcpcx(plP_w3wcx(xmin, ymax, tp));
+	    v[2] = plP_wcpcy(plP_w3wcy(xmin, ymax, tp));
+	    plnxtv(u, v, 0,3, 0);
+
+	    tp += tick;
+	}
+	u[0] = plP_wcpcx(plP_w3wcx(xmin, ymin, zmin));
+	v[0] = plP_wcpcy(plP_w3wcy(xmin, ymin, zmin));
+	u[1] = plP_wcpcx(plP_w3wcx(xmin, ymin, zmax));
+	v[1] = plP_wcpcy(plP_w3wcy(xmin, ymin, zmax));
+	plnxtv(u, v, 0,2, 0);
+    }
+    else if (cxx >= 0.0 && cxy >= 0.0) {
+	while (tp <= zmax) {
+	    u[0] = plP_wcpcx(plP_w3wcx(xmin, ymin, tp));
+	    v[0] = plP_wcpcy(plP_w3wcy(xmin, ymin, tp));
+	    u[1] = plP_wcpcx(plP_w3wcx(xmin, ymax, tp));
+	    v[1] = plP_wcpcy(plP_w3wcy(xmin, ymax, tp));
+	    u[2] = plP_wcpcx(plP_w3wcx(xmax, ymax, tp));
+	    v[2] = plP_wcpcy(plP_w3wcy(xmax, ymax, tp));
+	    plnxtv(u, v, 0,3, 0);
+
+	    tp += tick;
+	}
+	u[0] = plP_wcpcx(plP_w3wcx(xmin, ymax, zmin));
+	v[0] = plP_wcpcy(plP_w3wcy(xmin, ymax, zmin));
+	u[1] = plP_wcpcx(plP_w3wcx(xmin, ymax, zmax));
+	v[1] = plP_wcpcy(plP_w3wcy(xmin, ymax, zmax));
+	plnxtv(u, v, 0,2, 0);
+    }
+    pl3upv = 1;
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plnxtv()
+ *
+ * Draw the next view of a 3-d plot. The physical coordinates of the
+ * points for the next view are placed in the n points of arrays u and
+ * v. The silhouette found so far is stored in the heap as a set of m peak
+ * points.
+ *
+ * These routines dynamically allocate memory for hidden line removal.
+ * Memory is allocated in blocks of 2*BINC*sizeof(PLINT) bytes.  Large
+ * values of BINC give better performance but also allocate more memory
+ * than is needed. If your 3D plots are very "spiky" or you are working
+ * with very large matrices then you will probably want to increase BINC.
+\*--------------------------------------------------------------------------*/
+
+static void
+plnxtv(PLINT *u, PLINT *v, PLFLT* c, PLINT n, PLINT init)
+{
+    plnxtvhi(u, v, c, n, init);
+
+    if (pl3mode)
+	plnxtvlo(u, v, c, n, init);
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plnxtvhi()
+ *
+ * Draw the top side of the 3-d plot.
+\*--------------------------------------------------------------------------*/
+
+static void
+plnxtvhi(PLINT *u, PLINT *v, PLFLT* c, PLINT n, PLINT init)
+{
+  /*
+   * For the initial set of points, just display them and store them as the
+   * peak points.
+   */
+  if (init == 1) {
+    int i;
+    oldhiview = (PLINT *) malloc((size_t) (2 * n * sizeof(PLINT)));
+    if ( ! oldhiview)
+      myexit("plnxtvhi: Out of memory.");
+
+    oldhiview[0] = u[0];
+    oldhiview[1] = v[0];
+    plP_draw3d(u[0], v[0], c, 0, 1);
+    for (i = 1; i < n; i++) {
+      oldhiview[2 * i] = u[i];
+      oldhiview[2 * i + 1] = v[i];
+      plP_draw3d(u[i], v[i], c, i, 0);
+    }
+    mhi = n;
+    return;
+  }
+
+  /*
+   * Otherwise, we need to consider hidden-line removal problem. We scan
+   * over the points in both the old (i.e. oldhiview[]) and new (i.e. u[]
+   * and v[]) arrays in order of increasing x coordinate.  At each stage, we
+   * find the line segment in the other array (if one exists) that straddles
+   * the x coordinate of the point. We have to determine if the point lies
+   * above or below the line segment, and to check if the below/above status
+   * has changed since the last point.
+   *
+   * If pl3upv = 0 we do not update the view, this is useful for drawing
+   * lines on the graph after we are done plotting points.  Hidden line
+   * removal is still done, but the view is not updated.
+   */
+  xxhi = 0;
+  if (pl3upv != 0) {
+    newhisize = 2 * (mhi + BINC);
+    if (newhiview != NULL) {
+      newhiview = 
+	(PLINT *) realloc((void *) newhiview,
+			  (size_t) (newhisize * sizeof(PLINT)));
+    }
+    else {
+      newhiview = 
+	(PLINT *) malloc((size_t) (newhisize * sizeof(PLINT)));
+    }
+    if ( ! newhiview)
+      myexit("plnxtvhi: Out of memory.");
+  }
+
+  /* Do the draw or shading with hidden line removal */
+
+  plnxtvhi_draw(u, v, c, n);
+
+  /* Set oldhiview */
+
+  swaphiview();
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plnxtvhi_draw()
+ *
+ * Draw the top side of the 3-d plot.
+\*--------------------------------------------------------------------------*/
+
+static void
+plnxtvhi_draw(PLINT *u, PLINT *v, PLFLT* c, PLINT n)
+{
+    PLINT i = 0, j = 0, first = 1;
+    PLINT sx1 = 0, sx2 = 0, sy1 = 0, sy2 = 0;
+    PLINT su1, su2, sv1, sv2;
+    PLINT cx, cy, px, py;
+    PLINT seg, ptold, lstold = 0, pthi, pnewhi = 0, newhi, change, ochange = 0;
+
+/*
+ * (oldhiview[2*i], oldhiview[2*i]) is the i'th point in the old array
+ * (u[j], v[j]) is the j'th point in the new array
+ */
+
+/* 
+ * First attempt at 3d shading.  It works ok for simple plots, but
+ * will just not draw faces, or draw them overlapping for very
+ * jagged plots
+ */
+
+    while (i < mhi || j < n) {
+
+    /*
+     * The coordinates of the point under consideration are (px,py).  The
+     * line segment joins (sx1,sy1) to (sx2,sy2).  "ptold" is true if the
+     * point lies in the old array. We set it by comparing the x coordinates
+     * of the i'th old point and the j'th new point, being careful if we
+     * have fallen past the edges. Having found the point, load up the point
+     * and segment coordinates appropriately.
+     */
+
+    ptold = (j >= n || (i < mhi && oldhiview[2 * i] < u[j]));
+    if (ptold) {
+      px = oldhiview[2 * i];
+      py = oldhiview[2 * i + 1];
+      seg = j > 0 && j < n;
+      if (seg) {
+	sx1 = u[j - 1];
+	sy1 = v[j - 1];
+	sx2 = u[j];
+	sy2 = v[j];
+      }
+    } else {
+      px = u[j];
+      py = v[j];
+      seg = i > 0 && i < mhi;
+      if (seg) {
+	sx1 = oldhiview[2 * (i - 1)];
+	sy1 = oldhiview[2 * (i - 1) + 1];
+	sx2 = oldhiview[2 * i];
+	sy2 = oldhiview[2 * i + 1];
+      }
+    }
+
+    /*
+     * Now determine if the point is higher than the segment, using the
+     * logical function "above". We also need to know if it is the old view
+     * or the new view that is higher. "newhi" is set true if the new view
+     * is higher than the old.
+     */
+    if (seg)
+      pthi = plabv(px, py, sx1, sy1, sx2, sy2);
+    else
+      pthi = 1;
+
+    newhi = (ptold && !pthi) || (!ptold && pthi);
+    /*
+     * The last point and this point lie on different sides of
+     * the current silouette
+     */
+    change = (newhi && !pnewhi) || (!newhi && pnewhi);
+
+    /*
+     * There is a new intersection point to put in the peak array if the
+     * state of "newhi" changes.
+     */
+    if (first) {
+      plP_draw3d(px, py, c, j, 1);
+      first = 0;
+      lstold = ptold;
+      savehipoint(px, py);
+      pthi = 0;
+      ochange = 0;
+    } else if (change) {
+
+      /*
+       * Take care of special cases at end of arrays.  If pl3upv is 0 the
+       * endpoints are not connected to the old view.
+       */
+      if (pl3upv == 0 && ((!ptold && j == 0) || (ptold && i == 0))) {
+	plP_draw3d(px, py, c, j, 1);
+	lstold = ptold;
+	pthi = 0;
+	ochange = 0;
+      } else if (pl3upv == 0 &&
+		 (( ! ptold && i >= mhi) || (ptold && j >= n))) {
+	plP_draw3d(px, py, c, j, 1);
+	lstold = ptold;
+	pthi = 0;
+	ochange = 0;
+      } else {
+
+	/*
+	 * If pl3upv is not 0 then we do want to connect the current line
+	 * with the previous view at the endpoints.  Also find intersection
+	 * point with old view.
+	 */
+	if (i == 0) {
+	  sx1 = oldhiview[0];
+	  sy1 = -1;
+	  sx2 = oldhiview[0];
+	  sy2 = oldhiview[1];
+	} else if (i >= mhi) {
+	  sx1 = oldhiview[2 * (mhi - 1)];
+	  sy1 = oldhiview[2 * (mhi - 1) + 1];
+	  sx2 = oldhiview[2 * (mhi - 1)];
+	  sy2 = -1;
+	} else {
+	  sx1 = oldhiview[2 * (i - 1)];
+	  sy1 = oldhiview[2 * (i - 1) + 1];
+	  sx2 = oldhiview[2 * i];
+	  sy2 = oldhiview[2 * i + 1];
+	}
+
+	if (j == 0) {
+	  su1 = u[0];
+	  sv1 = -1;
+	  su2 = u[0];
+	  sv2 = v[0];
+	} else if (j >= n) {
+	  su1 = u[n - 1];
+	  sv1 = v[n - 1];
+	  su2 = u[n - 1];
+	  sv2 = -1;
+	} else {
+	  su1 = u[j - 1];
+	  sv1 = v[j - 1];
+	  su2 = u[j];
+	  sv2 = v[j];
+	}
+
+	/* Determine the intersection */
+
+	pl3cut(sx1, sy1, sx2, sy2, su1, sv1, su2, sv2, &cx, &cy);
+	if (cx == px && cy == py) {
+	  if (lstold && !ochange)
+	    plP_draw3d(px, py, c, j, 1);
+	  else
+	    plP_draw3d(px, py, c, j, 0);
+
+	  savehipoint(px, py);
+	  lstold = 1;
+	  pthi = 0;
+	} else {
+	  if (lstold && !ochange)
+	    plP_draw3d(cx, cy, c, j, 1);
+	  else
+	    plP_draw3d(cx, cy, c, j, 0);
+
+	  lstold = 1;
+	  savehipoint(cx, cy);
+	}
+	ochange = 1;
+      }
+    }
+
+    /* If point is high then draw plot to point and update view. */
+
+    if (pthi) {
+      if (lstold && ptold)
+	plP_draw3d(px, py, c, j, 1);
+      else
+	plP_draw3d(px, py, c, j, 0);
+
+      savehipoint(px, py);
+      lstold = ptold;
+      ochange = 0;
+    }
+    pnewhi = newhi;
+
+    if (ptold)
+      i++;
+    else
+      j++;
+  }
+}
+
+/*--------------------------------------------------------------------------*\
+ * void  plP_draw3d()
+ *
+ * Does a simple move or line draw.
+\*--------------------------------------------------------------------------*/
+
+static void
+plP_draw3d(PLINT x, PLINT y, PLFLT *c, PLINT j, PLINT move)
+{
+    if (move)
+      plP_movphy(x, y);
+    else {
+      if (c != NULL)
+	plcol1(c[j-1]);
+      plP_draphy(x, y);
+    }
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plnxtvlo()
+ *
+ * Draw the bottom side of the 3-d plot.
+\*--------------------------------------------------------------------------*/
+
+static void
+plnxtvlo(PLINT *u, PLINT *v, PLFLT*c, PLINT n, PLINT init)
+{
+  PLINT i, j, first;
+  PLINT sx1 = 0, sx2 = 0, sy1 = 0, sy2 = 0;
+  PLINT su1, su2, sv1, sv2;
+  PLINT cx, cy, px, py;
+  PLINT seg, ptold, lstold = 0, ptlo, pnewlo, newlo, change, ochange = 0;
+
+  first = 1;
+  pnewlo = 0;
+
+  /*
+   * For the initial set of points, just display them and store them as the
+   * peak points.
+   */
+  if (init == 1) {
+
+    oldloview = (PLINT *) malloc((size_t) (2 * n * sizeof(PLINT)));
+    if ( ! oldloview)
+      myexit("\nplnxtvlo: Out of memory.");
+
+    plP_draw3d(u[0], v[0], c, 0, 1);
+    oldloview[0] = u[0];
+    oldloview[1] = v[0];
+    for (i = 1; i < n; i++) {
+      plP_draw3d(u[i], v[i], c, i, 0);
+      oldloview[2 * i] = u[i];
+      oldloview[2 * i + 1] = v[i];
+    }
+    mlo = n;
+    return;
+  }
+
+  /*
+   * Otherwise, we need to consider hidden-line removal problem. We scan
+   * over the points in both the old (i.e. oldloview[]) and new (i.e. u[]
+   * and v[]) arrays in order of increasing x coordinate.  At each stage, we
+   * find the line segment in the other array (if one exists) that straddles
+   * the x coordinate of the point. We have to determine if the point lies
+   * above or below the line segment, and to check if the below/above status
+   * has changed since the last point.
+   *
+   * If pl3upv = 0 we do not update the view, this is useful for drawing
+   * lines on the graph after we are done plotting points.  Hidden line
+   * removal is still done, but the view is not updated.
+   */
+  xxlo = 0;
+  i = 0;
+  j = 0;
+  if (pl3upv != 0) {
+    newlosize = 2 * (mlo + BINC);
+    if (newloview != NULL) {
+      newloview = 
+	(PLINT *) realloc((void *) newloview,
+			  (size_t) (newlosize * sizeof(PLINT)));
+    }
+    else {
+      newloview = 
+	(PLINT *) malloc((size_t) (newlosize * sizeof(PLINT)));
+    }
+    if ( ! newloview)
+      myexit("plnxtvlo: Out of memory.");
+  }
+
+  /*
+   * (oldloview[2*i], oldloview[2*i]) is the i'th point in the old array
+   * (u[j], v[j]) is the j'th point in the new array.
+   */
+  while (i < mlo || j < n) {
+
+    /*
+     * The coordinates of the point under consideration are (px,py).  The
+     * line segment joins (sx1,sy1) to (sx2,sy2).  "ptold" is true if the
+     * point lies in the old array. We set it by comparing the x coordinates
+     * of the i'th old point and the j'th new point, being careful if we
+     * have fallen past the edges. Having found the point, load up the point
+     * and segment coordinates appropriately.
+     */
+    ptold = (j >= n || (i < mlo && oldloview[2 * i] < u[j]));
+    if (ptold) {
+      px = oldloview[2 * i];
+      py = oldloview[2 * i + 1];
+      seg = j > 0 && j < n;
+      if (seg) {
+	sx1 = u[j - 1];
+	sy1 = v[j - 1];
+	sx2 = u[j];
+	sy2 = v[j];
+      }
+    }
+    else {
+      px = u[j];
+      py = v[j];
+      seg = i > 0 && i < mlo;
+      if (seg) {
+	sx1 = oldloview[2 * (i - 1)];
+	sy1 = oldloview[2 * (i - 1) + 1];
+	sx2 = oldloview[2 * i];
+	sy2 = oldloview[2 * i + 1];
+      }
+    }
+
+    /*
+     * Now determine if the point is lower than the segment, using the
+     * logical function "above". We also need to know if it is the old view
+     * or the new view that is lower. "newlo" is set true if the new view is
+     * lower than the old.
+     */
+    if (seg)
+      ptlo = !plabv(px, py, sx1, sy1, sx2, sy2);
+    else
+      ptlo = 1;
+
+    newlo = (ptold && !ptlo) || (!ptold && ptlo);
+    change = (newlo && !pnewlo) || (!newlo && pnewlo);
+
+    /*
+     * There is a new intersection point to put in the peak array if the
+     * state of "newlo" changes.
+     */
+    if (first) {
+      plP_draw3d(px, py, c, j, 1);
+      first = 0;
+      lstold = ptold;
+      savelopoint(px, py);
+      ptlo = 0;
+      ochange = 0;
+    }
+    else if (change) {
+
+      /*
+       * Take care of special cases at end of arrays.  If pl3upv is 0 the
+       * endpoints are not connected to the old view.
+       */
+      if (pl3upv == 0 && ((!ptold && j == 0) || (ptold && i == 0))) {
+	plP_draw3d(px, py, c, j, 1);
+	lstold = ptold;
+	ptlo = 0;
+	ochange = 0;
+      }
+      else if (pl3upv == 0 &&
+	       (( ! ptold && i >= mlo) || (ptold && j >= n))) {
+	plP_draw3d(px, py, c, j, 1);
+	lstold = ptold;
+	ptlo = 0;
+	ochange = 0;
+      }
+
+      /*
+       * If pl3upv is not 0 then we do want to connect the current line
+       * with the previous view at the endpoints.  Also find intersection
+       * point with old view.
+       */
+      else {
+	if (i == 0) {
+	  sx1 = oldloview[0];
+	  sy1 = 100000;
+	  sx2 = oldloview[0];
+	  sy2 = oldloview[1];
+	}
+	else if (i >= mlo) {
+	  sx1 = oldloview[2 * (mlo - 1)];
+	  sy1 = oldloview[2 * (mlo - 1) + 1];
+	  sx2 = oldloview[2 * (mlo - 1)];
+	  sy2 = 100000;
+	}
+	else {
+	  sx1 = oldloview[2 * (i - 1)];
+	  sy1 = oldloview[2 * (i - 1) + 1];
+	  sx2 = oldloview[2 * i];
+	  sy2 = oldloview[2 * i + 1];
+	}
+
+	if (j == 0) {
+	  su1 = u[0];
+	  sv1 = 100000;
+	  su2 = u[0];
+	  sv2 = v[0];
+	}
+	else if (j >= n) {
+	  su1 = u[n - 1];
+	  sv1 = v[n - 1];
+	  su2 = u[n];
+	  sv2 = 100000;
+	}
+	else {
+	  su1 = u[j - 1];
+	  sv1 = v[j - 1];
+	  su2 = u[j];
+	  sv2 = v[j];
+	}
+
+	/* Determine the intersection */
+
+	pl3cut(sx1, sy1, sx2, sy2, su1, sv1, su2, sv2, &cx, &cy);
+	if (cx == px && cy == py) {
+	  if (lstold && !ochange)
+	    plP_draw3d(px, py, c, j, 1);
+	  else
+	    plP_draw3d(px, py, c, j, 0);
+
+	  savelopoint(px, py);
+	  lstold = 1;
+	  ptlo = 0;
+	}
+	else {
+	  if (lstold && !ochange)
+	    plP_draw3d(cx, cy, c, j, 1);
+	  else
+	    plP_draw3d(cx, cy, c, j, 0);
+
+	  lstold = 1;
+	  savelopoint(cx, cy);
+	}
+	ochange = 1;
+      }
+    }
+
+    /* If point is low then draw plot to point and update view. */
+
+    if (ptlo) {
+      if (lstold && ptold)
+	plP_draw3d(px, py, c, j, 1);
+      else
+	plP_draw3d(px, py, c, j, 0);
+
+      savelopoint(px, py);
+      lstold = ptold;
+      ochange = 0;
+    }
+
+    pnewlo = newlo;
+
+    if (ptold)
+      i = i + 1;
+    else
+      j = j + 1;
+  }
+
+  /* Set oldloview */
+
+  swaploview();
+}
+
+/*--------------------------------------------------------------------------*\
+ * savehipoint
+ * savelopoint
+ *
+ * Add a point to the list of currently visible peaks/valleys, when
+ * drawing the top/bottom surface, respectively.
+\*--------------------------------------------------------------------------*/
+
+static void
+savehipoint(PLINT px, PLINT py)
+{
+    if (pl3upv == 0)
+	return;
+
+    if (xxhi >= newhisize) {	/* allocate additional space */
+	newhisize += 2 * BINC;
+	newhiview = (PLINT *) realloc((void *) newhiview,
+				      (size_t) (newhisize * sizeof(PLINT)));
+	if ( ! newhiview) 
+	    myexit("savehipoint: Out of memory.");
+    }
+
+    newhiview[xxhi] = px;
+    xxhi++;
+    newhiview[xxhi] = py;
+    xxhi++;
+}
+
+static void
+savelopoint(PLINT px, PLINT py)
+{
+    if (pl3upv == 0)
+	return;
+
+    if (xxlo >= newlosize) {	/* allocate additional space */
+	newlosize += 2 * BINC;
+	newloview = (PLINT *) realloc((void *) newloview,
+				      (size_t) (newlosize * sizeof(PLINT)));
+	if ( ! newloview)
+	    myexit("savelopoint: Out of memory.");
+    }
+
+    newloview[xxlo] = px;
+    xxlo++;
+    newloview[xxlo] = py;
+    xxlo++;
+}
+
+/*--------------------------------------------------------------------------*\
+ * swaphiview
+ * swaploview
+ *
+ * Swaps the top/bottom views.  Need to do a real swap so that the 
+ * memory cleanup routine really frees everything (and only once).
+\*--------------------------------------------------------------------------*/
+
+static void
+swaphiview(void)
+{
+    PLINT *tmp;
+
+    if (pl3upv != 0) {
+	mhi = xxhi / 2;
+	tmp = oldhiview;
+	oldhiview = newhiview;
+	newhiview = tmp;
+    }
+}
+
+static void
+swaploview(void)
+{
+    PLINT *tmp;
+
+    if (pl3upv != 0) {
+	mlo = xxlo / 2;
+	tmp = oldloview;
+	oldloview = newloview;
+	newloview = tmp;
+    }
+}
+
+/*--------------------------------------------------------------------------*\
+ * freework
+ *
+ * Frees memory associated with work arrays
+\*--------------------------------------------------------------------------*/
+
+static void
+freework(void)
+{
+    free_mem(oldhiview);
+    free_mem(oldloview);
+    free_mem(newhiview);
+    free_mem(newloview);
+    free_mem(vtmp);
+    free_mem(utmp);
+    free_mem(ctmp);
+}
+
+/*--------------------------------------------------------------------------*\
+ * myexit
+ *
+ * Calls plexit, cleaning up first.
+\*--------------------------------------------------------------------------*/
+
+static void
+myexit(char *msg)
+{
+    freework();
+    plexit(msg);
+}
+
+/*--------------------------------------------------------------------------*\
+ * myabort
+ *
+ * Calls plabort, cleaning up first.
+ * Caller should return to the user program.
+\*--------------------------------------------------------------------------*/
+
+static void
+myabort(char *msg)
+{
+    freework();
+    plabort(msg);
+}
+
+/*--------------------------------------------------------------------------*\
+ * int plabv()
+ *
+ * Determines if point (px,py) lies above the line joining (sx1,sy1) to
+ * (sx2,sy2). It only works correctly if sx1 <= px <= sx2.
+\*--------------------------------------------------------------------------*/
+
+static int
+plabv(PLINT px, PLINT py, PLINT sx1, PLINT sy1, PLINT sx2, PLINT sy2)
+{
+    int above;
+
+    if (py >= sy1 && py >= sy2)
+	above = 1;
+    else if (py < sy1 && py < sy2)
+	above = 0;
+    else if ((double) (sx2 - sx1) * (py - sy1) >=
+	     (double) (px - sx1) * (sy2 - sy1))
+	above = 1;
+    else
+	above = 0;
+
+    return above;
+}
+
+/*--------------------------------------------------------------------------*\
+ * void pl3cut()
+ *
+ * Determines the point of intersection (cx,cy) between the line joining
+ * (sx1,sy1) to (sx2,sy2) and the line joining (su1,sv1) to (su2,sv2).
+\*--------------------------------------------------------------------------*/
+
+static void
+pl3cut(PLINT sx1, PLINT sy1, PLINT sx2, PLINT sy2,
+       PLINT su1, PLINT sv1, PLINT su2, PLINT sv2, PLINT *cx, PLINT *cy)
+{
+    PLINT x21, y21, u21, v21, yv1, xu1, a, b;
+    double fa, fb;
+
+    x21 = sx2 - sx1;
+    y21 = sy2 - sy1;
+    u21 = su2 - su1;
+    v21 = sv2 - sv1;
+    yv1 = sy1 - sv1;
+    xu1 = sx1 - su1;
+
+    a = x21 * v21 - y21 * u21;
+    fa = (double) a;
+    if (a == 0) {
+	if (sx2 < su2) {
+	    *cx = sx2;
+	    *cy = sy2;
+	}
+	else {
+	    *cx = su2;
+	    *cy = sv2;
+	}
+	return;
+    }
+    else {
+	b = yv1 * u21 - xu1 * v21;
+	fb = (double) b;
+	*cx = (PLINT) (sx1 + (fb * x21) / fa + .5);
+	*cy = (PLINT) (sy1 + (fb * y21) / fa + .5);
+    }
+}
diff --git a/collects/plot/src/all/plpage.c b/collects/plot/src/all/plpage.c
new file mode 100644
index 0000000000..e05a751d03
--- /dev/null
+++ b/collects/plot/src/all/plpage.c
@@ -0,0 +1,282 @@
+/* $Id: plpage.c,v 1.1 2004/03/01 20:54:52 cozmic Exp $
+
+	Page/subpage handling routines
+*/
+
+#include "plplotP.h"
+
+/*--------------------------------------------------------------------------*\
+ * void pladv()
+ *
+ * Advance to subpage "page", or to the next one if "page" = 0.
+\*--------------------------------------------------------------------------*/
+
+void
+c_pladv(PLINT page)
+{
+    if (plsc->level < 1) {
+	plabort("pladv: Please call plinit first");
+	return;
+    }
+
+    if (page > 0 && page <= plsc->nsubx * plsc->nsuby)
+	plsc->cursub = page;
+
+    else if (page == 0) {
+	if (plsc->cursub >= plsc->nsubx * plsc->nsuby) {
+	    plP_eop();
+	    plP_bop();
+	    plsc->cursub = 1;
+	}
+	else
+	    plsc->cursub++;
+    }
+    else {
+	plabort("pladv: Invalid subpage number");
+	return;
+    }
+
+    plP_setsub();
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plclear()
+ *
+ * Clear current subpage.  Subpages can be set with pladv before 
+ * calling plclear. Not all drivers support this.
+\*--------------------------------------------------------------------------*/
+
+void
+c_plclear(void)
+{
+    if (plsc->level < 1) {
+	plabort("plclear: Please call plinit first");
+	return;
+    }
+
+    if (plsc->dev_clear)
+      plP_esc(PLESC_CLEAR, NULL);
+    else { /* driver does not support clear, fill using background color */
+
+	  short x[5], y[5];
+	  int ocolor = plsc->icol0;
+
+	  x[0] = x[3] = x[4] = plsc->sppxmi;
+	  x[1] = x[2] = plsc->sppxma;
+	  y[0] = y[1] = y[4] = plsc->sppymi;
+	  y[2] = y[3] = plsc->sppyma;
+	  plcol0(0);
+	  plP_fill(x, y, 5);
+	  plcol0(ocolor);
+    }
+}
+
+/*--------------------------------------------------------------------------*\
+ * void pleop()
+ *
+ * End current page.
+\*--------------------------------------------------------------------------*/
+
+void
+c_pleop(void)
+{
+    if (plsc->level < 1) {
+	plabort("pleop: Please call plinit first");
+	return;
+    }
+
+    plsc->cursub = plsc->nsubx * plsc->nsuby;
+    plP_eop();
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plbop()
+ *
+ * Start new page.  Should only be used with pleop().
+\*--------------------------------------------------------------------------*/
+
+void
+c_plbop(void)
+{
+    if (plsc->level < 1) {
+	plabort("pladv: Please call plinit first");
+	return;
+    }
+    plP_bop();
+    plsc->cursub = 1;
+    plP_setsub();
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plP_subpInit()
+ *
+ * Set up plot parameters according to the number of subpages.
+\*--------------------------------------------------------------------------*/
+
+void
+plP_subpInit(void)
+{
+    PLFLT scale, size_chr, size_sym, size_maj, size_min;
+
+/* Subpage checks */
+
+    if (plsc->nsubx <= 0)
+	plsc->nsubx = 1;
+    if (plsc->nsuby <= 0)
+	plsc->nsuby = 1;
+
+    plsc->cursub = 0;
+
+/*
+ * Set default sizes
+ * Global scaling:
+ *	Normalize to the page length for more uniform results.
+ * 	A virtual page length of 200 mm is assumed.
+ * Subpage scaling:
+ *	Reduce sizes with plot area (non-proportional, so that character
+ *	size doesn't get too small).
+ */
+    scale = 0.5 *
+	((plsc->phyxma - plsc->phyxmi) / plsc->xpmm +
+	 (plsc->phyyma - plsc->phyymi) / plsc->ypmm) / 200.0;
+
+    if (plsc->nsuby > 1)
+	scale /= sqrt((double) plsc->nsuby);
+
+    size_chr = 4.0;
+    size_sym = 4.0;		/* All these in virtual plot units */
+    size_maj = 3.0;
+    size_min = 1.5;
+
+    plsc->chrdef = plsc->chrht = size_chr * scale;
+    plsc->symdef = plsc->symht = size_sym * scale;
+    plsc->majdef = plsc->majht = size_maj * scale;
+    plsc->mindef = plsc->minht = size_min * scale;
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plP_setsub()
+ *
+ * Set up the subpage boundaries according to the current subpage selected.
+\*--------------------------------------------------------------------------*/
+
+void
+plP_setsub(void)
+{
+    PLINT ix, iy;
+
+    ix = (plsc->cursub - 1) % plsc->nsubx;
+    iy = plsc->nsuby - (plsc->cursub - 1) / plsc->nsubx;
+
+    plsc->spdxmi = (PLFLT) (ix)     / (PLFLT) (plsc->nsubx);
+    plsc->spdxma = (PLFLT) (ix + 1) / (PLFLT) (plsc->nsubx);
+    plsc->spdymi = (PLFLT) (iy - 1) / (PLFLT) (plsc->nsuby);
+    plsc->spdyma = (PLFLT) (iy)     / (PLFLT) (plsc->nsuby);
+
+    plsc->sppxmi = plP_dcpcx(plsc->spdxmi);
+    plsc->sppxma = plP_dcpcx(plsc->spdxma);
+    plsc->sppymi = plP_dcpcy(plsc->spdymi);
+    plsc->sppyma = plP_dcpcy(plsc->spdyma);
+
+    plP_sclp(plsc->sppxmi, plsc->sppxma, plsc->sppymi, plsc->sppyma);
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plgspa()
+ *
+ * Get subpage boundaries in absolute coordinates (mm from bottom
+ * left-hand corner of page.
+\*--------------------------------------------------------------------------*/
+
+void
+c_plgspa(PLFLT *xmin, PLFLT *xmax, PLFLT *ymin, PLFLT *ymax)
+{
+    if (plsc->level < 1) {
+	plabort("plgspa: Please call plinit first");
+	return;
+    }
+    *xmin = plP_dcmmx(plsc->spdxmi);
+    *xmax = plP_dcmmx(plsc->spdxma);
+    *ymin = plP_dcmmy(plsc->spdymi);
+    *ymax = plP_dcmmy(plsc->spdyma);
+}
+
+/*--------------------------------------------------------------------------*\
+ * int plGetCursor()
+ *
+ * Wait for graphics input event and translate to world coordinates.
+ * Returns 0 if no translation to world coordinates is possible.  
+ * Written by Paul Casteels.
+\*--------------------------------------------------------------------------*/
+
+int
+plGetCursor(PLGraphicsIn *plg)
+{
+    plP_esc(PLESC_GETC, plg);
+    return plTranslateCursor(plg);
+}
+
+/*--------------------------------------------------------------------------*\
+ * int plTranslateCursor()
+ *
+ * Translates cursor position from relative device coordinates to world
+ * coordinates.  Returns 0 if no translation to world coordinates is
+ * possible.  Written by Paul Casteels and modified by Alan W. Irwin.
+\*--------------------------------------------------------------------------*/
+
+int
+plTranslateCursor(PLGraphicsIn *plg)
+{
+    int window;
+    c_plcalc_world(plg->dX, plg->dY, &plg->wX, &plg->wY, 
+		   (PLINT *) &window);
+    if ( window >= 0 ) { 
+	plg->subwindow = window;
+	return 1;
+    }
+    else
+	return 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * void c_plcalc_world
+ *
+ * Calculate world coordinates wx, and wy from relative device coordinates, rx
+ * and ry.  Also, return the window index for which the world coordinates 
+ * are valid. window is set to -1 and wx and wy to 0. if rx and ry do not 
+ * correspond to valid world coordinates for any currently existing window.
+ * Originally written by Paul Casteels and modified by Alan W. Irwin.
+\*--------------------------------------------------------------------------*/
+
+void
+c_plcalc_world(PLFLT rx, PLFLT ry, PLFLT *wx, PLFLT *wy, PLINT *window)
+{
+    int i;
+    int lastwin = plsc->nplwin - 1;
+    int firstwin = MAX(plsc->nplwin - PL_MAXWINDOWS, 0);
+    PLWindow *w;
+
+    for (i = lastwin; i >= firstwin; i--) {
+	w = &plsc->plwin[i % PL_MAXWINDOWS];
+	if ((rx >= w->dxmi) &&
+	    (rx <= w->dxma) &&
+	    (ry >= w->dymi) &&
+	    (ry <= w->dyma) ) {
+
+	    *wx = w->wxmi + (rx - w->dxmi) * 
+		(w->wxma - w->wxmi) / (w->dxma - w->dxmi);
+
+	    *wy = w->wymi + (ry - w->dymi) * 
+		(w->wyma - w->wymi) / (w->dyma - w->dymi);
+	   
+	    *window = i;
+
+	    return;
+	}
+    }
+    /* No valid window found with these relative coordinates. */
+    *wx = 0.;
+    *wy = 0.;
+    *window = -1;
+    return;
+}
diff --git a/collects/plot/src/all/plplot.h b/collects/plot/src/all/plplot.h
new file mode 100644
index 0000000000..a8ac98f155
--- /dev/null
+++ b/collects/plot/src/all/plplot.h
@@ -0,0 +1,1774 @@
+/* $Id: plplot.h,v 1.2 2005/03/17 21:39:21 eli Exp $
+
+    Copyright (C) 1992 by 
+    Maurice J. LeBrun, Geoff Furnish, Tony Richardson.
+
+    Macros and prototypes for the PLplot package.  This header file must
+    be included by all user codes.
+
+    This software may be freely copied, modified and redistributed
+    without fee provided that this copyright notice is preserved intact
+    on all copies and modified copies.
+
+    There is no warranty or other guarantee of fitness of this software.
+    It is provided solely "as is". The author(s) disclaim(s) all
+    responsibility and liability with respect to this software's usage
+    or its effect upon hardware or computer systems.
+
+    Note: some systems allow the Fortran & C namespaces to clobber each
+    other.  So for PLplot to work from Fortran, we do some rather nasty
+    things to the externally callable C function names.  This shouldn't
+    affect any user programs in C as long as this file is included. 
+*/
+
+#ifndef __PLPLOT_H__
+#define __PLPLOT_H__
+
+#include "scheme.h"
+
+#include "plConfig.h"
+
+/*--------------------------------------------------------------------------*\
+ *    USING PLplot
+ * 
+ * To use PLplot from C or C++, it is only necessary to 
+ * 
+ *      #include "plplot.h"
+ * 
+ * This file does all the necessary setup to make PLplot accessible to
+ * your program as documented in the manual.  Additionally, this file
+ * allows you to request certain behavior by defining certain symbols
+ * before inclusion.  At the moment the only one is:
+ *
+ * #define DOUBLE	or..
+ * #define PL_DOUBLE
+ *
+ * This causes PLplot to use doubles instead of floats.  Use the type
+ * PLFLT everywhere in your code, and it will always be the right thing.
+ *
+ * Note: most of the functions visible here begin with "pl", while all
+ * of the data types and switches begin with "PL".  Eventually everything
+ * will conform to this rule in order to keep namespace pollution of the
+ * user code to a minimum.  All the PLplot source files actually include
+ * "plplotP.h", which includes this file as well as all the internally-
+ * visible declarations, etc.  
+\*--------------------------------------------------------------------------*/
+
+/* The majority of PLplot source files require these, so.. */
+/* Under ANSI C, they can be included any number of times. */
+
+#include <stdio.h>
+#include <stdlib.h>
+
+/*--------------------------------------------------------------------------*\
+ *        SYSTEM IDENTIFICATION
+ *
+ * Several systems are supported directly by PLplot.  In order to avoid
+ * confusion, one id macro per system is used.  Since different compilers
+ * may predefine different system id macros, we need to check all the
+ * possibilities, and then set the one we will be referencing.  These are:
+ *
+ * __cplusplus                Any C++ compiler
+ * __unix                     Any Unix-like system
+ * __hpux                     Any HP/UX system
+ * __aix                      Any AIX system
+ * __linux                    Linux for i386
+ * (others...)
+ *
+\*--------------------------------------------------------------------------*/
+
+#ifdef unix			/* the old way */
+#ifndef __unix
+#define __unix
+#endif
+#endif
+
+/* Make sure Unix systems define "__unix" */
+
+#if defined(SX)	||				/* NEC Super-UX */      \
+    (defined(_IBMR2) && defined(_AIX)) ||	/* AIX */               \
+    defined(__hpux) ||				/* HP/UX */             \
+    defined(sun) ||				/* SUN */               \
+    defined(CRAY) ||				/* Cray */              \
+    defined(__convexc__) ||			/* CONVEX */            \
+    (defined(__alpha) && defined(__osf__))	/* DEC Alpha AXP/OSF */
+
+#ifndef __unix
+#define __unix
+#endif
+#endif
+
+/* A wrapper used in some header files so they can be compiled with cc */
+
+#define PLARGS(a)	a
+
+/*--------------------------------------------------------------------------*\
+ * Base types for PLplot
+ *
+ * Only those that are necessary for function prototypes are defined here.
+ * Notes:
+ *
+ * PLINT is typedef'd to an int by default.  This is a change from some
+ * previous versions, where a long was used.  Under MSDOS, a PLINT is
+ * typedef'd to a long, since 16 bits is too inaccurate for some PLplot
+ * functions.  So under MSDOS you must use type PLINT for integer array
+ * arguments to PLplot functions, but on other systems you can just use
+ * an int.
+ *
+ * short is currently used for device page coordinates, so they are
+ * bounded by (-32767, 32767).  This gives a max resolution of about 3000
+ * dpi, and improves performance in some areas over using a PLINT.
+\*--------------------------------------------------------------------------*/
+
+#if defined(PL_DOUBLE) || defined(DOUBLE)
+typedef double PLFLT;
+#define PLFLT_MAX DBL_MAX
+#define PLFLT_MIN DBL_MIN
+#else
+typedef float PLFLT;
+#define PLFLT_MAX  FLT_MAX
+#define PLFLT_MIN  FLT_MIN
+#endif
+
+#if defined(MSDOS) && !defined(__WIN32__)
+typedef long PLINT;
+#else
+typedef int PLINT;
+#endif
+
+/* For passing user data, as with X's XtPointer */
+
+typedef void* PLPointer;
+
+/*--------------------------------------------------------------------------*\
+ * Complex data types and other good stuff
+\*--------------------------------------------------------------------------*/
+
+/* Switches for escape function call. */
+/* Some of these are obsolete but are retained in order to process
+   old metafiles */
+
+#define PLESC_SET_RGB		1	/* obsolete */
+#define PLESC_ALLOC_NCOL	2	/* obsolete */
+#define PLESC_SET_LPB		3	/* obsolete */
+#define PLESC_EXPOSE		4	/* handle window expose */
+#define PLESC_RESIZE		5	/* handle window resize */
+#define PLESC_REDRAW		6	/* handle window redraw */
+#define PLESC_TEXT		7	/* switch to text screen */
+#define PLESC_GRAPH		8	/* switch to graphics screen */
+#define PLESC_FILL		9	/* fill polygon */
+#define PLESC_DI		10	/* handle DI command */
+#define PLESC_FLUSH		11	/* flush output */
+#define PLESC_EH		12      /* handle Window events */
+#define PLESC_GETC		13	/* get cursor position */
+#define PLESC_SWIN		14	/* set window parameters */
+#define PLESC_DOUBLEBUFFERING	15	/* configure double buffering */
+#define PLESC_XORMOD		16	/* set xor mode */
+#define PLESC_SET_COMPRESSION	17	/* AFR: set compression */
+#define PLESC_CLEAR		18      /* RL: clear graphics region */
+#define PLESC_DASH		19	/* RL: draw dashed line */
+#define PLESC_HAS_TEXT		20	/* driver draws text */
+#define PLESC_IMAGE		21	/* handle image */
+#define PLESC_IMAGEOPS          22      /* plimage related operations */
+#define PLESC_PL2DEVCOL		23	/* convert PLColor to device color */
+#define PLESC_DEV2PLCOL		24	/* convert device color to PLColor */
+#define PLESC_SETBGFG		25	/* set BG, FG colors */
+#define PLESC_DEVINIT		26	/* alternate device initialization */
+
+/* image operations */
+#define ZEROW2B   1
+#define ZEROW2D   2
+#define ONEW2B    3
+#define ONEW2D    4
+
+/* Window parameter tags */
+
+#define PLSWIN_DEVICE		1	/* device coordinates */
+#define PLSWIN_WORLD		2	/* world coordinates */
+
+/* PLplot Option table & support constants */
+
+/* Option-specific settings */
+
+#define PL_OPT_ENABLED		0x0001	/* Obsolete */
+#define PL_OPT_ARG		0x0002	/* Option has an argment */
+#define PL_OPT_NODELETE		0x0004	/* Don't delete after processing */
+#define PL_OPT_INVISIBLE	0x0008	/* Make invisible */
+#define PL_OPT_DISABLED		0x0010	/* Processing is disabled */
+
+/* Option-processing settings -- mutually exclusive */
+
+#define PL_OPT_FUNC		0x0100	/* Call handler function */
+#define PL_OPT_BOOL		0x0200	/* Set *var = 1 */
+#define PL_OPT_INT		0x0400	/* Set *var = atoi(optarg) */
+#define PL_OPT_FLOAT		0x0800	/* Set *var = atof(optarg) */
+#define PL_OPT_STRING		0x1000	/* Set var = optarg */
+
+/* Global mode settings */
+/* These override per-option settings */
+
+#define PL_PARSE_PARTIAL	0x0000	/* For backward compatibility */
+#define PL_PARSE_FULL		0x0001	/* Process fully & exit if error */
+#define PL_PARSE_QUIET		0x0002	/* Don't issue messages */
+#define PL_PARSE_NODELETE	0x0004	/* Don't delete options after */
+					/* processing */
+#define PL_PARSE_SHOWALL	0x0008	/* Show invisible options */
+#define PL_PARSE_OVERRIDE	0x0010	/* Obsolete */
+#define PL_PARSE_NOPROGRAM	0x0020	/* Program name NOT in *argv[0].. */
+#define PL_PARSE_NODASH		0x0040	/* Set if leading dash NOT required */
+#define PL_PARSE_SKIP		0x0080	/* Skip over unrecognized args */
+
+/* Obsolete names */
+
+#define plParseInternalOpts(a, b, c)	plParseOpts(a, b, c)
+#define plSetInternalOpt(a, b)		plSetOpt(a, b)
+
+/* Option table definition */
+
+typedef struct {
+    char *opt;
+    int  (*handler)	(char *, char *, void *);
+    void *client_data;
+    void *var;
+    long mode;
+    char *syntax;
+    char *desc;
+} PLOptionTable;
+
+/* PLplot Graphics Input structure */
+
+#define PL_MAXKEY 16
+
+typedef struct {
+    int type;			/* of event (CURRENTLY UNUSED) */
+    unsigned int state;		/* key or button mask */
+    unsigned int keysym;	/* key selected */
+    unsigned int button;	/* mouse button selected */
+    PLINT subwindow;            /* subwindow (alias subpage, alias subplot) number */
+    char string[PL_MAXKEY];	/* translated string */
+    int pX, pY;			/* absolute device coordinates of pointer */
+    PLFLT dX, dY;		/* relative device coordinates of pointer */
+    PLFLT wX, wY;		/* world coordinates of pointer */
+} PLGraphicsIn;
+
+/* Structure for describing the plot window */
+
+#define PL_MAXWINDOWS	64	/* Max number of windows/page tracked */
+
+typedef struct {
+    PLFLT dxmi, dxma, dymi, dyma;	/* min, max window rel dev coords */
+    PLFLT wxmi, wxma, wymi, wyma;	/* min, max window world coords */
+} PLWindow;
+
+/* Structure for doing display-oriented operations via escape commands */
+/* May add other attributes in time */
+
+typedef struct {
+    unsigned int x, y;			/* upper left hand corner */
+    unsigned int width, height;		/* window dimensions */
+} PLDisplay;
+
+/* Macro used (in some cases) to ignore value of argument */
+/* I don't plan on changing the value so you can hard-code it */
+
+#define PL_NOTSET (-42)
+
+/* See plcont.c for examples of the following */
+
+/*
+ * PLfGrid is for passing (as a pointer to the first element) an arbitrarily
+ * dimensioned array.  The grid dimensions MUST be stored, with a maximum of 3
+ * dimensions assumed for now.
+ */
+
+typedef struct {
+    PLFLT *f;
+    PLINT nx, ny, nz;
+} PLfGrid;
+
+/*
+ * PLfGrid2 is for passing (as an array of pointers) a 2d function array.  The
+ * grid dimensions are passed for possible bounds checking.
+ */
+
+typedef struct {
+    PLFLT **f;
+    PLINT nx, ny;
+} PLfGrid2;
+
+/*
+ * NOTE: a PLfGrid3 is a good idea here but there is no way to exploit it yet
+ * so I'll leave it out for now.
+ */
+
+/*
+ * PLcGrid is for passing (as a pointer to the first element) arbitrarily
+ * dimensioned coordinate transformation arrays.  The grid dimensions MUST be
+ * stored, with a maximum of 3 dimensions assumed for now.
+ */
+
+typedef struct {
+    PLFLT *xg, *yg, *zg;
+    PLINT nx, ny, nz;
+} PLcGrid;
+
+/*
+ * PLcGrid2 is for passing (as arrays of pointers) 2d coordinate
+ * transformation arrays.  The grid dimensions are passed for possible bounds
+ * checking.
+ */
+
+typedef struct {
+    PLFLT **xg, **yg, **zg;
+    PLINT nx, ny;
+} PLcGrid2;
+
+/*
+ * NOTE: a PLcGrid3 is a good idea here but there is no way to exploit it yet
+ * so I'll leave it out for now.
+ */
+
+/* PLColor is the usual way to pass an rgb color value. */
+
+typedef struct {
+    unsigned char r;		/* red */
+    unsigned char g;		/* green */
+    unsigned char b;		/* blue */
+    char *name;
+} PLColor;
+
+/* PLControlPt is how cmap1 control points are represented. */
+
+typedef struct {
+    PLFLT h;			/* hue */
+    PLFLT l;			/* lightness */
+    PLFLT s;			/* saturation */
+    PLFLT p;			/* position */
+    int rev;			/* if set, interpolate through h=0 */
+} PLControlPt;
+
+/* A PLBufferingCB is a control block for interacting with devices
+   that support double buffering. */
+
+typedef struct {
+    PLINT cmd;
+    PLINT result;
+} PLBufferingCB;
+
+#define PLESC_DOUBLEBUFFERING_ENABLE     1
+#define PLESC_DOUBLEBUFFERING_DISABLE    2
+#define PLESC_DOUBLEBUFFERING_QUERY      3
+
+
+/*--------------------------------------------------------------------------*\
+ *		BRAINDEAD-ness
+ *
+ * Some systems allow the Fortran & C namespaces to clobber each other.
+ * For PLplot to work from Fortran on these systems, we must name the the
+ * externally callable C functions something other than their Fortran entry
+ * names.  In order to make this as easy as possible for the casual user,
+ * yet reversible to those who abhor my solution, I have done the
+ * following:
+ *
+ *	The C-language bindings are actually different from those
+ *	described in the manual.  Macros are used to convert the
+ *	documented names to the names used in this package.  The
+ *	user MUST include plplot.h in order to get the name
+ *	redefinition correct.
+ *
+ * Sorry to have to resort to such an ugly kludge, but it is really the
+ * best way to handle the situation at present.  If all available
+ * compilers offer a way to correct this stupidity, then perhaps we can
+ * eventually reverse it (there is a way now, by defining NOBRAINDEAD, but
+ * be careful because this will totally hose the Fortran interface on some
+ * systems).  If you feel like screaming at someone (I sure do), please
+ * direct it at your nearest system vendor who has a braindead shared
+ * C/Fortran namespace.  Some vendors do offer compiler switches that
+ * change the object names, but then everybody who wants to use the
+ * package must throw these same switches, leading to no end of trouble.
+ *
+ * Note that this definition should not cause any noticable effects except
+ * when debugging PLplot calls, in which case you will need to remember
+ * the real function names (same as before but with a 'c_' prepended).
+ *
+ * Also, to avoid macro conflicts, the BRAINDEAD part must not be expanded
+ * in the stub routines.
+ *
+ * Aside: the reason why a shared Fortran/C namespace is deserving of the
+ * BRAINDEAD characterization is that it completely precludes the the kind
+ * of universal API that is attempted (more or less) with PLplot, without
+ * Herculean efforts (e.g. remapping all of the C bindings by macros as
+ * done here).  The vendors of such a scheme, in order to allow a SINGLE
+ * type of argument to be passed transparently between C and Fortran,
+ * namely, a pointer to a conformable data type, have slammed the door on
+ * insertion of stub routines to handle the conversions needed for other
+ * data types.  Intelligent linkers could solve this problem, but these are
+ * not anywhere close to becoming universal.  So meanwhile, one must live
+ * with either stub routines for the inevitable data conversions, or a
+ * different API.  The former is what is used here, but is made far more
+ * difficult in a braindead shared Fortran/C namespace.
+\*--------------------------------------------------------------------------*/
+
+#ifndef BRAINDEAD
+#define BRAINDEAD
+#endif
+
+#ifdef NOBRAINDEAD
+#undef BRAINDEAD
+#endif
+
+#ifdef BRAINDEAD
+
+#ifndef __PLSTUBS_H__	/* i.e. do not expand this in the stubs */
+
+#define    pl_setcontlabelformat c_pl_setcontlabelformat
+#define    pl_setcontlabelparam c_pl_setcontlabelparam
+#define    pladv	c_pladv
+#define    plaxes	c_plaxes
+#define    plbin	c_plbin
+#define    plbop	c_plbop
+#define    plbox	c_plbox
+#define    plbox3	c_plbox3
+#define    plcalc_world	c_plcalc_world
+#define    plclear	c_plclear
+#define    plcol0	c_plcol0
+#define    plcol1	c_plcol1
+#define    plcont	c_plcont
+#define    plcpstrm	c_plcpstrm
+#define    plend	c_plend
+#define    plend1	c_plend1
+#define    plenv	c_plenv
+#define    plenv0	c_plenv0
+#define    pleop	c_pleop
+#define    plerrx	c_plerrx
+#define    plerry	c_plerry
+#define    plfamadv	c_plfamadv
+#define    plfill	c_plfill
+#define    plfill3	c_plfill3
+#define    plflush	c_plflush
+#define    plfont	c_plfont
+#define    plfontld	c_plfontld
+#define    plgchr	c_plgchr
+#define    plgcol0	c_plgcol0
+#define    plgcolbg	c_plgcolbg
+#define    plgcompression	c_plgcompression
+#define    plgdev	c_plgdev
+#define    plgdidev	c_plgdidev
+#define    plgdiori	c_plgdiori
+#define    plgdiplt	c_plgdiplt
+#define    plgfam	c_plgfam
+#define    plgfnam	c_plgfnam
+#define    plglevel	c_plglevel
+#define    plgpage	c_plgpage
+#define    plgra	c_plgra
+#define    plgriddata   c_plgriddata
+#define    plgspa	c_plgspa
+#define    plgstrm	c_plgstrm
+#define    plgver	c_plgver
+#define    plgvpd	c_plgvpd
+#define    plgvpw	c_plgvpw
+#define    plgxax	c_plgxax
+#define    plgyax	c_plgyax
+#define    plgzax	c_plgzax
+#define    plhist	c_plhist
+#define    plhls        c_plhls
+#define    plinit	c_plinit
+#define    pljoin	c_pljoin
+#define    pllab	c_pllab
+#define    pllightsource	c_pllightsource
+#define    plline	c_plline
+#define    plline3	c_plline3
+#define    pllsty	c_pllsty
+#define    plmesh	c_plmesh
+#define    plmeshc	c_plmeshc
+#define    plmkstrm	c_plmkstrm
+#define    plmtex	c_plmtex
+#define    plot3d	c_plot3d
+#define    plot3dc	c_plot3dc
+#define    plsurf3d	c_plsurf3d
+#define    plpat	c_plpat
+#define    plpoin	c_plpoin
+#define    plpoin3	c_plpoin3
+#define    plpoly3	c_plpoly3
+#define    plprec	c_plprec
+#define    plpsty	c_plpsty
+#define    plptex	c_plptex
+#define    plreplot	c_plreplot
+#define    plrgb	c_plrgb
+#define    plrgb1	c_plrgb1
+#define    plschr	c_plschr
+#define    plscmap0	c_plscmap0
+#define    plscmap1	c_plscmap1
+#define    plscmap0n	c_plscmap0n
+#define    plscmap1n	c_plscmap1n
+#define    plscmap1l	c_plscmap1l
+#define    plscol0	c_plscol0
+#define    plscolbg	c_plscolbg
+#define    plscolor	c_plscolor
+#define    plscompression	c_plscompression
+#define    plsdev	c_plsdev
+#define    plsdiplt	c_plsdiplt
+#define    plsdiplz	c_plsdiplz
+#define    plsdidev	c_plsdidev
+#define    plsdimap	c_plsdimap
+#define    plsdiori	c_plsdiori
+#define    plsetopt	c_plsetopt
+#define    plsesc	c_plsesc
+#define    plsfam	c_plsfam
+#define    plsfnam	c_plsfnam
+#define    plshades	c_plshades
+#define    plshade	c_plshade
+#define    plshade1	c_plshade1
+#define    plsmaj	c_plsmaj
+#define    plsmem	c_plsmem
+#define    plsmin	c_plsmin
+#define    plsori	c_plsori
+#define    plspage	c_plspage
+#define    plspause	c_plspause
+#define    plsstrm	c_plsstrm
+#define    plssub	c_plssub
+#define    plssym	c_plssym
+#define    plstar	c_plstar
+#define    plstart	c_plstart
+#define    plstripa	c_plstripa
+#define    plstripc	c_plstripc
+#define    plstripd	c_plstripd
+#define    plstyl	c_plstyl
+#define    plsvpa	c_plsvpa
+#define    plsxax	c_plsxax
+#define    plsyax	c_plsyax
+#define    plsym	c_plsym
+#define    plszax	c_plszax
+#define    pltext	c_pltext
+#define    plvasp	c_plvasp
+#define    plvpas	c_plvpas
+#define    plvpor	c_plvpor
+#define    plvsta	c_plvsta
+#define    plw3d	c_plw3d
+#define    plwid	c_plwid
+#define    plwind	c_plwind
+#define    plxormod	c_plxormod
+
+#endif /* __PLSTUBS_H__ */
+
+#else
+
+#define    c_pl_setcontlabelformat pl_setcontlabelformat
+#define    c_pl_setcontlabelparam pl_setcontlabelparam
+#define    c_pladv	pladv
+#define    c_plaxes	plaxes
+#define    c_plbin	plbin
+#define    c_plbop	plbop
+#define    c_plbox	plbox
+#define    c_plbox3	plbox3
+#define    c_plcalc_world	plcalc_world
+#define    c_plclear	plclear
+#define    c_plcol0	plcol0
+#define    c_plcol1	plcol1
+#define    c_plcpstrm	plcpstrm
+#define    c_plcont	plcont
+#define    c_plend	plend
+#define    c_plend1	plend1
+#define    c_plenv	plenv
+#define    c_plenv0	plenv0
+#define    c_pleop	pleop
+#define    c_plerrx	plerrx
+#define    c_plerry	plerry
+#define    c_plfamadv	plfamadv
+#define    c_plfill	plfill
+#define    c_plfill3	plfill3
+#define    c_plflush	plflush
+#define    c_plfont	plfont
+#define    c_plfontld	plfontld
+#define    c_plgchr	plgchr
+#define    c_plgcol0	plgcol0
+#define    c_plgcolbg	plgcolbg
+#define    c_plgcompression	plgcompression
+#define    c_plgdev	plgdev
+#define    c_plgdidev	plgdidev
+#define    c_plgdiori	plgdiori
+#define    c_plgdiplt	plgdiplt
+#define    c_plgfam	plgfam
+#define    c_plgfnam	plgfnam
+#define    c_plglevel	plglevel
+#define    c_plgpage	plgpage
+#define    c_plgra	plgra
+#define    c_plgriddata plgriddata   
+#define    c_plgspa	plgspa
+#define    c_plgstrm	plgstrm
+#define    c_plgver	plgver
+#define    c_plgvpd	plgvpd
+#define    c_plgvpw	plgvpw
+#define    c_plgxax	plgxax
+#define    c_plgyax	plgyax
+#define    c_plgzax	plgzax
+#define    c_plhist	plhist
+#define    c_plhls	plhls       
+#define    c_plinit	plinit
+#define    c_pljoin	pljoin
+#define    c_pllab	pllab
+#define    c_pllightsource pllightsource
+#define    c_plline	plline
+#define    c_plline3	plline3
+#define    c_pllsty	pllsty
+#define    c_plmesh	plmesh
+#define    c_plmeshc	plmeshc
+#define    c_plmkstrm	plmkstrm
+#define    c_plmtex	plmtex
+#define    c_plot3d	plot3d
+#define    c_plot3dc	plot3dc
+#define    c_plsurf3d	plsurf3d
+#define    c_plpat	plpat
+#define    c_plpoin	plpoin
+#define    c_plpoin3	plpoin3
+#define    c_plpoly3	plpoly3
+#define    c_plprec	plprec
+#define    c_plpsty	plpsty
+#define    c_plptex	plptex
+#define    c_plreplot	plreplot
+#define    c_plrgb	plrgb
+#define    c_plrgb1	plrgb1
+#define    c_plschr	plschr
+#define    c_plscmap0	plscmap0
+#define    c_plscmap1	plscmap1
+#define    c_plscmap0n	plscmap0n
+#define    c_plscmap1n	plscmap1n
+#define    c_plscmap1l	plscmap1l
+#define    c_plscol0	plscol0
+#define    c_plscolbg	plscolbg
+#define    c_plscolor	plscolor
+#define    c_plscompression	plscompression
+#define    c_plsdev	plsdev
+#define    c_plsdiplt	plsdiplt
+#define    c_plsdiplz	plsdiplz
+#define    c_plsdidev	plsdidev
+#define    c_plsdimap	plsdimap
+#define    c_plsdiori	plsdiori
+#define    c_plsetopt	plsetopt
+#define    c_plsesc	plsesc
+#define    c_plsfam	plsfam
+#define    c_plsfnam	plsfnam
+#define    c_plshades	plshades
+#define    c_plshade	plshade
+#define    c_plshade1	plshade1
+#define    c_plsmaj	plsmaj
+#define    c_plsmin	plsmin
+#define    c_plsori	plsori
+#define    c_plspage	plspage
+#define    c_plspause	plspause
+#define    c_plsstrm	plsstrm
+#define    c_plssub	plssub
+#define    c_plssym	plssym
+#define    c_plstar	plstar
+#define    c_plstart	plstart
+#define    c_plstripa	plstripa
+#define    c_plstripc	plstripc
+#define    c_plstripd	plstripd
+#define    c_plstyl	plstyl
+#define    c_plsvpa	plsvpa
+#define    c_plsxax	plsxax
+#define    c_plsyax	plsyax
+#define    c_plsym	plsym
+#define    c_plszax	plszax
+#define    c_pltext	pltext
+#define    c_plvasp	plvasp
+#define    c_plvpas	plvpas
+#define    c_plvpor	plvpor
+#define    c_plvsta	plvsta
+#define    c_plw3d	plw3d
+#define    c_plwid	plwid
+#define    c_plwind	plwind
+#define    c_plxormod	plxormod
+
+#endif	/* BRAINDEAD */
+
+/* Redefine some old function names for backward compatibility */
+
+#ifndef __PLSTUBS_H__	/* i.e. do not expand this in the stubs */
+
+#define    plclr	pleop
+#define    plpage	plbop
+#define    plcol	plcol0
+#define    plcontf	plfcont
+#define	   Alloc2dGrid	plAlloc2dGrid
+#define	   Free2dGrid	plFree2dGrid
+#define    MinMax2dGrid plMinMax2dGrid
+#define    plP_gvpd	plgvpd
+#define    plP_gvpw	plgvpw
+#define    plotsh3d(x,y,z,nx,ny,opt)     plsurf3d(x,y,z,nx,ny,opt, NULL, 0)
+
+#endif /* __PLSTUBS_H__ */
+
+/*--------------------------------------------------------------------------*\
+ *		Function Prototypes
+\*--------------------------------------------------------------------------*/
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+	/* All void types */
+
+	/* C routines callable from stub routines come first */
+
+/* set the format of the contour labels */
+
+void
+c_pl_setcontlabelformat(PLINT lexp, PLINT sigdig);
+
+/* set offset and spacing of contour labels */
+
+void
+c_pl_setcontlabelparam(PLFLT offset, PLFLT size, PLFLT spacing, PLINT active);
+
+/* Advance to subpage "page", or to the next one if "page" = 0. */
+
+void
+c_pladv(PLINT page);
+
+/* simple arrow plotter. */
+
+void
+plarrows(PLFLT *u, PLFLT *v, PLFLT *x, PLFLT *y, PLINT n,
+         PLFLT scale, PLFLT dx, PLFLT dy) ;
+
+/* This functions similarly to plbox() except that the origin of the axes */
+/* is placed at the user-specified point (x0, y0). */
+
+void
+c_plaxes(PLFLT x0, PLFLT y0, const char *xopt, PLFLT xtick, PLINT nxsub,
+	 const char *yopt, PLFLT ytick, PLINT nysub);
+
+/* Plot a histogram using x to store data values and y to store frequencies */
+
+void
+c_plbin(PLINT nbin, PLFLT *x, PLFLT *y, PLINT center);
+
+/* Start new page.  Should only be used with pleop(). */
+
+void
+c_plbop(void);
+
+/* This draws a box around the current viewport. */
+
+void
+c_plbox(const char *xopt, PLFLT xtick, PLINT nxsub,
+	const char *yopt, PLFLT ytick, PLINT nysub);
+
+/* This is the 3-d analogue of plbox(). */
+
+MZ_DLLEXPORT
+void
+c_plbox3(const char *xopt, const char *xlabel, PLFLT xtick, PLINT nsubx,
+	 const char *yopt, const char *ylabel, PLFLT ytick, PLINT nsuby,
+	 const char *zopt, const char *zlabel, PLFLT ztick, PLINT nsubz);
+
+/* Calculate world coordinates and subpage from relative device coordinates. */
+
+void
+c_plcalc_world(PLFLT rx, PLFLT ry, PLFLT *wx, PLFLT *wy, PLINT *window);
+   
+/* Clear current subpage. */
+   
+void
+c_plclear(void);
+
+/* Set color, map 0.  Argument is integer between 0 and 15. */
+
+MZ_DLLEXPORT
+void
+c_plcol0(PLINT icol0);
+
+/* Set color, map 1.  Argument is a float between 0. and 1. */
+
+void
+c_plcol1(PLFLT col1);
+
+/* Draws a contour plot from data in f(nx,ny).  Is just a front-end to
+ * plfcont, with a particular choice for f2eval and f2eval_data. 
+ */
+
+ MZ_DLLEXPORT
+void
+c_plcont(PLFLT **f, PLINT nx, PLINT ny, PLINT kx, PLINT lx,
+	 PLINT ky, PLINT ly, PLFLT *clevel, PLINT nlevel,
+	 void (*pltr) (PLFLT, PLFLT, PLFLT *, PLFLT *, PLPointer),
+	 PLPointer pltr_data);
+
+/* Draws a contour plot using the function evaluator f2eval and data stored
+ * by way of the f2eval_data pointer.  This allows arbitrary organizations
+ * of 2d array data to be used. 
+ */
+
+void
+plfcont(PLFLT (*f2eval) (PLINT, PLINT, PLPointer),
+	PLPointer f2eval_data,
+	PLINT nx, PLINT ny, PLINT kx, PLINT lx,
+	PLINT ky, PLINT ly, PLFLT *clevel, PLINT nlevel,
+	void (*pltr) (PLFLT, PLFLT, PLFLT *, PLFLT *, PLPointer),
+	PLPointer pltr_data);
+
+/* Copies state parameters from the reference stream to the current stream. */
+
+void
+c_plcpstrm(PLINT iplsr, PLINT flags);
+
+/* Converts input values from relative device coordinates to relative plot */
+/* coordinates. */
+
+void
+pldid2pc(PLFLT *xmin, PLFLT *ymin, PLFLT *xmax, PLFLT *ymax);
+
+/* Converts input values from relative plot coordinates to relative */
+/* device coordinates. */
+
+void
+pldip2dc(PLFLT *xmin, PLFLT *ymin, PLFLT *xmax, PLFLT *ymax);
+
+/* End a plotting session for all open streams. */
+
+MZ_DLLEXPORT
+void
+c_plend(void);
+
+/* End a plotting session for the current stream only. */
+
+void
+c_plend1(void);
+
+/* Simple interface for defining viewport and window. */
+
+MZ_DLLEXPORT
+void
+c_plenv(PLFLT xmin, PLFLT xmax, PLFLT ymin, PLFLT ymax,
+	PLINT just, PLINT axis);
+
+
+/* similar to plenv() above, but in multiplot mode does not advance the subpage,
+ instead the current subpage is cleared */
+
+void
+c_plenv0(PLFLT xmin, PLFLT xmax, PLFLT ymin, PLFLT ymax,
+	PLINT just, PLINT axis);
+
+/* End current page.  Should only be used with plbop(). */
+
+void
+c_pleop(void);
+
+/* Plot horizontal error bars (xmin(i),y(i)) to (xmax(i),y(i)) */
+
+MZ_DLLEXPORT
+void
+c_plerrx(PLINT n, PLFLT *xmin, PLFLT *xmax, PLFLT *y);
+
+/* Plot vertical error bars (x,ymin(i)) to (x(i),ymax(i)) */
+
+MZ_DLLEXPORT
+void
+c_plerry(PLINT n, PLFLT *x, PLFLT *ymin, PLFLT *ymax);
+
+/* Advance to the next family file on the next new page */
+
+void
+c_plfamadv(void);
+
+/* Pattern fills the polygon bounded by the input points. */
+
+
+MZ_DLLEXPORT
+void
+c_plfill(PLINT n, PLFLT *x, PLFLT *y);
+
+/* Pattern fills the 3d polygon bounded by the input points. */
+
+void
+c_plfill3(PLINT n, PLFLT *x, PLFLT *y, PLFLT *z);
+
+/* Flushes the output stream.  Use sparingly, if at all. */
+
+void
+c_plflush(void);
+
+/* Sets the global font flag to 'ifont'. */
+
+void
+c_plfont(PLINT ifont);
+
+/* Load specified font set. */
+
+void
+c_plfontld(PLINT fnt);
+
+/* Get character default height and current (scaled) height */
+
+void
+c_plgchr(PLFLT *p_def, PLFLT *p_ht);
+
+/* Returns 8 bit RGB values for given color from color map 0 */
+
+void
+c_plgcol0(PLINT icol0, PLINT *r, PLINT *g, PLINT *b);
+
+/* Returns the background color by 8 bit RGB value */
+
+void
+c_plgcolbg(PLINT *r, PLINT *g, PLINT *b);
+
+/* Returns the current compression setting */
+
+void
+c_plgcompression(PLINT *compression);
+
+/* Get the current device (keyword) name */
+
+void
+c_plgdev(char *p_dev);
+
+/* Retrieve current window into device space */
+
+void
+c_plgdidev(PLFLT *p_mar, PLFLT *p_aspect, PLFLT *p_jx, PLFLT *p_jy);
+
+/* Get plot orientation */
+
+void
+c_plgdiori(PLFLT *p_rot);
+
+/* Retrieve current window into plot space */
+
+void
+c_plgdiplt(PLFLT *p_xmin, PLFLT *p_ymin, PLFLT *p_xmax, PLFLT *p_ymax);
+
+/* Get family file parameters */
+
+void
+c_plgfam(PLINT *p_fam, PLINT *p_num, PLINT *p_bmax);
+
+/* Get the (current) output file name.  Must be preallocated to >80 bytes */
+
+void
+c_plgfnam(char *fnam);
+
+/* Get the (current) run level.  */
+
+void
+c_plglevel(PLINT *p_level);
+
+/* Get output device parameters. */
+
+void
+c_plgpage(PLFLT *p_xp, PLFLT *p_yp,
+	  PLINT *p_xleng, PLINT *p_yleng, PLINT *p_xoff, PLINT *p_yoff);
+
+/* Switches to graphics screen. */
+
+void
+c_plgra(void);
+
+  /* grid irregularly sampled data */
+
+void
+c_plgriddata(PLFLT *x, PLFLT *y, PLFLT *z, int npts,
+	   PLFLT *xg, int nptsx, PLFLT *yg,  int nptsy,
+	   PLFLT **zg, int type, PLFLT data);
+
+  /* type of gridding algorithm for plgriddata() */
+
+#define GRID_CSA    1 /* Bivariate Cubic Spline approximation */
+#define GRID_DTLI   2 /* Delaunay Triangulation Linear Interpolation */
+#define GRID_NNI    3 /* Natural Neighbors Interpolation */
+#define GRID_NNIDW  4 /* Nearest Neighbors Inverse Distance Weighted */
+#define GRID_NNLI   5 /* Nearest Neighbors Linear Interpolation */
+#define GRID_NNAIDW 6 /* Nearest Neighbors Around Inverse Distance Weighted  */
+
+/* Get subpage boundaries in absolute coordinates */
+
+void
+c_plgspa(PLFLT *xmin, PLFLT *xmax, PLFLT *ymin, PLFLT *ymax);
+
+/* Get current stream number. */
+
+void
+c_plgstrm(PLINT *p_strm);
+
+/* Get the current library version number */
+
+void
+c_plgver(char *p_ver);
+
+/* Get viewport boundaries in normalized device coordinates */
+
+void
+c_plgvpd(PLFLT *p_xmin, PLFLT *p_xmax, PLFLT *p_ymin, PLFLT *p_ymax);
+
+/* Get viewport boundaries in world coordinates */
+
+void
+c_plgvpw(PLFLT *p_xmin, PLFLT *p_xmax, PLFLT *p_ymin, PLFLT *p_ymax);
+
+/* Get x axis labeling parameters */
+
+void
+c_plgxax(PLINT *p_digmax, PLINT *p_digits);
+
+/* Get y axis labeling parameters */
+
+void
+c_plgyax(PLINT *p_digmax, PLINT *p_digits);
+
+/* Get z axis labeling parameters */
+
+void
+c_plgzax(PLINT *p_digmax, PLINT *p_digits);
+
+/* Draws a histogram of n values of a variable in array data[0..n-1] */
+
+void
+c_plhist(PLINT n, PLFLT *data, PLFLT datmin, PLFLT datmax,
+	 PLINT nbin, PLINT oldwin);
+
+/* Set current color (map 0) by hue, lightness, and saturation. */
+
+void
+c_plhls(PLFLT h, PLFLT l, PLFLT s);
+
+/* Initializes PLplot, using preset or default options */
+
+MZ_DLLEXPORT
+void
+c_plinit(void);
+
+/* Draws a line segment from (x1, y1) to (x2, y2). */
+
+MZ_DLLEXPORT
+void
+c_pljoin(PLFLT x1, PLFLT y1, PLFLT x2, PLFLT y2);
+
+/* Simple routine for labelling graphs. */
+
+MZ_DLLEXPORT
+void
+c_pllab(const char *xlabel, const char *ylabel, const char *tlabel);
+
+/* Sets position of the light source */
+void
+c_pllightsource(PLFLT x, PLFLT y, PLFLT z);
+
+/* Draws line segments connecting a series of points. */
+
+MZ_DLLEXPORT
+void
+c_plline(PLINT n, PLFLT *x, PLFLT *y);
+
+/* Draws a line in 3 space.  */
+
+MZ_DLLEXPORT
+void
+c_plline3(PLINT n, PLFLT *x, PLFLT *y, PLFLT *z);
+
+/* Set line style. */
+
+void
+c_pllsty(PLINT lin);
+
+/* plot continental outline in world coordinates */
+
+void
+plmap( void (*mapform)(PLINT, PLFLT *, PLFLT *), char *type,
+         PLFLT minlong, PLFLT maxlong, PLFLT minlat, PLFLT maxlat );
+
+/* Plot the latitudes and longitudes on the background. */
+
+void 
+plmeridians( void (*mapform)(PLINT, PLFLT *, PLFLT *), 
+               PLFLT dlong, PLFLT dlat,
+               PLFLT minlong, PLFLT maxlong, PLFLT minlat, PLFLT maxlat );
+
+/* Plots a mesh representation of the function z[x][y]. */
+
+void
+c_plmesh(PLFLT *x, PLFLT *y, PLFLT **z, PLINT nx, PLINT ny, PLINT opt);
+
+/* Plots a mesh representation of the function z[x][y] with contour */
+
+MZ_DLLEXPORT
+void
+c_plmeshc(PLFLT *x, PLFLT *y, PLFLT **z, PLINT nx, PLINT ny, PLINT opt,
+	  PLFLT *clevel, PLINT nlevel);
+
+/* Creates a new stream and makes it the default.  */
+
+void
+c_plmkstrm(PLINT *p_strm);
+
+/* Prints out "text" at specified position relative to viewport */
+
+void
+c_plmtex(const char *side, PLFLT disp, PLFLT pos, PLFLT just,
+	 const char *text);
+
+/* Plots a 3-d representation of the function z[x][y]. */
+
+MZ_DLLEXPORT
+void
+c_plot3d(PLFLT *x, PLFLT *y, PLFLT **z,
+	 PLINT nx, PLINT ny, PLINT opt, PLINT side);
+
+/* Plots a 3-d representation of the function z[x][y] with contour. */
+
+void
+c_plot3dc(PLFLT *x, PLFLT *y, PLFLT **z,
+	 PLINT nx, PLINT ny, PLINT opt,
+	 PLFLT *clevel, PLINT nlevel);
+
+/* 
+ * definitions for the opt argument in plot3dc() and plsurf3d()
+ * 
+ * DRAW_LINEX *must* be 1 and DRAW_LINEY *must* be 2, because of legacy code!
+ */
+
+#define DRAW_LINEX  (1 << 0) /* draw lines parallel to the X axis */
+#define DRAW_LINEY  (1 << 1) /* draw lines parallel to the Y axis */
+#define DRAW_LINEXY (DRAW_LINEX | DRAW_LINEY) /* draw lines parallel to both the X and Y axis */
+#define MAG_COLOR   (1 << 2) /* draw the mesh with a color dependent of the magnitude */
+#define BASE_CONT   (1 << 3) /* draw contour plot at bottom xy plane */
+#define TOP_CONT    (1 << 4) /* draw contour plot at top xy plane */
+#define SURF_CONT   (1 << 5) /* draw contour plot at surface */
+#define DRAW_SIDES  (1 << 6) /* draw sides */
+#define FACETED     (1 << 7) /* draw outline for each square that makes up the surface */
+#define MESH        (1 << 8) /* draw mesh */
+
+  /*
+   *  valid options for plot3dc():
+   *
+   *  DRAW_SIDES, BASE_CONT, TOP_CONT (not yet),
+   *  MAG_COLOR, DRAW_LINEX, DRAW_LINEY, DRAW_LINEXY.
+   *
+   *  valid options for plsurf3dc():
+   *
+   *  MAG_COLOR, BASE_CONT, SURF_CONT, FACETED, DRAW_SIDES.
+   */
+
+/* Plots the 3d surface representation of the function z[x][y]. */
+
+void
+c_plsurf3d(PLFLT *x, PLFLT *y, PLFLT **z, PLINT nx, PLINT ny,
+	   PLINT opt, PLFLT *clevel, PLINT nlevel);
+
+/* Set fill pattern directly. */
+
+void
+c_plpat(PLINT nlin, PLINT *inc, PLINT *del);
+
+/* Plots array y against x for n points using ASCII code "code".*/
+
+MZ_DLLEXPORT
+void
+c_plpoin(PLINT n, PLFLT *x, PLFLT *y, PLINT code);
+
+/* Draws a series of points in 3 space. */
+
+void
+c_plpoin3(PLINT n, PLFLT *x, PLFLT *y, PLFLT *z, PLINT code);
+
+/* Draws a polygon in 3 space.  */
+
+MZ_DLLEXPORT
+void
+c_plpoly3(PLINT n, PLFLT *x, PLFLT *y, PLFLT *z, PLINT *draw, PLINT ifcc);
+
+/* Set the floating point precision (in number of places) in numeric labels. */
+
+void
+c_plprec(PLINT setp, PLINT prec);
+
+/* Set fill pattern, using one of the predefined patterns.*/
+
+void
+c_plpsty(PLINT patt);
+
+/* Prints out "text" at world cooordinate (x,y). */
+
+MZ_DLLEXPORT
+void
+c_plptex(PLFLT x, PLFLT y, PLFLT dx, PLFLT dy, PLFLT just, const char *text);
+
+/* Replays contents of plot buffer to current device/file. */
+
+void
+c_plreplot(void);
+
+/* Set line color by red, green, blue from  0. to 1. */
+
+void
+c_plrgb(PLFLT r, PLFLT g, PLFLT b);
+
+/* Set line color by 8 bit RGB values. */
+
+void
+c_plrgb1(PLINT r, PLINT g, PLINT b);
+
+/* Set character height. */
+
+void
+c_plschr(PLFLT def, PLFLT scale);
+
+/* Set number of colors in cmap 0 */
+
+void
+c_plscmap0n(PLINT ncol0);
+
+/* Set number of colors in cmap 1 */
+
+MZ_DLLEXPORT
+void
+c_plscmap1n(PLINT ncol1);
+
+/* Set color map 0 colors by 8 bit RGB values */
+
+void
+c_plscmap0(PLINT *r, PLINT *g, PLINT *b, PLINT ncol0);
+
+/* Set color map 1 colors by 8 bit RGB values */
+
+void
+c_plscmap1(PLINT *r, PLINT *g, PLINT *b, PLINT ncol1);
+
+/* Set color map 1 colors using a piece-wise linear relationship between */
+/* intensity [0,1] (cmap 1 index) and position in HLS or RGB color space. */
+
+MZ_DLLEXPORT
+void
+c_plscmap1l(PLINT itype, PLINT npts, PLFLT *intensity,
+	    PLFLT *coord1, PLFLT *coord2, PLFLT *coord3, PLINT *rev);
+
+/* Set a given color from color map 0 by 8 bit RGB value */
+
+MZ_DLLEXPORT
+void
+c_plscol0(PLINT icol0, PLINT r, PLINT g, PLINT b);
+
+/* Set the background color by 8 bit RGB value */
+
+MZ_DLLEXPORT
+void
+c_plscolbg(PLINT r, PLINT g, PLINT b);
+
+/* Used to globally turn color output on/off */
+
+void
+c_plscolor(PLINT color);
+
+/* Set the compression level */
+
+void
+c_plscompression(PLINT compression);
+
+/* Set the device (keyword) name */
+
+MZ_DLLEXPORT
+void
+c_plsdev(const char *devname);
+
+/* Set window into device space using margin, aspect ratio, and */
+/* justification */
+
+void
+c_plsdidev(PLFLT mar, PLFLT aspect, PLFLT jx, PLFLT jy);
+
+/* Set up transformation from metafile coordinates. */
+
+void
+c_plsdimap(PLINT dimxmin, PLINT dimxmax, PLINT dimymin, PLINT dimymax,
+	   PLFLT dimxpmm, PLFLT dimypmm);
+
+/* Set plot orientation, specifying rotation in units of pi/2. */
+
+void
+c_plsdiori(PLFLT rot);
+
+/* Set window into plot space */
+
+void
+c_plsdiplt(PLFLT xmin, PLFLT ymin, PLFLT xmax, PLFLT ymax);
+
+/* Set window into plot space incrementally (zoom) */
+
+void
+c_plsdiplz(PLFLT xmin, PLFLT ymin, PLFLT xmax, PLFLT ymax);
+
+/* Set the escape character for text strings. */
+
+void
+c_plsesc(char esc);
+
+/* Set family file parameters */
+
+void
+c_plsfam(PLINT fam, PLINT num, PLINT bmax);
+
+/* Set the output file name. */
+
+MZ_DLLEXPORT
+void
+c_plsfnam(const char *fnam);
+
+
+/* Shade region. */
+MZ_DLLEXPORT
+void
+c_plshades( PLFLT **a, PLINT nx, PLINT ny, PLINT (*defined) (PLFLT, PLFLT),
+	  PLFLT xmin, PLFLT xmax, PLFLT ymin, PLFLT ymax,
+	  PLFLT *clevel, PLINT nlevel, PLINT fill_width,
+	  PLINT cont_color, PLINT cont_width,
+	  void (*fill) (PLINT, PLFLT *, PLFLT *), PLINT rectangular,
+	  void (*pltr) (PLFLT, PLFLT, PLFLT *, PLFLT *, PLPointer),
+	  PLPointer pltr_data);
+
+   
+void 
+c_plshade(PLFLT **a, PLINT nx, PLINT ny, PLINT (*defined) (PLFLT, PLFLT),
+	  PLFLT left, PLFLT right, PLFLT bottom, PLFLT top,
+	  PLFLT shade_min, PLFLT shade_max,
+	  PLINT sh_cmap, PLFLT sh_color, PLINT sh_width,
+	  PLINT min_color, PLINT min_width,
+	  PLINT max_color, PLINT max_width,
+	  void (*fill) (PLINT, PLFLT *, PLFLT *), PLINT rectangular,
+	  void (*pltr) (PLFLT, PLFLT, PLFLT *, PLFLT *, PLPointer),
+	  PLPointer pltr_data);
+
+void 
+plshade1(PLFLT *a, PLINT nx, PLINT ny, PLINT (*defined) (PLFLT, PLFLT),
+	 PLFLT left, PLFLT right, PLFLT bottom, PLFLT top,
+	 PLFLT shade_min, PLFLT shade_max,
+	 PLINT sh_cmap, PLFLT sh_color, PLINT sh_width,
+	 PLINT min_color, PLINT min_width,
+	 PLINT max_color, PLINT max_width,
+	 void (*fill) (PLINT, PLFLT *, PLFLT *), PLINT rectangular,
+	 void (*pltr) (PLFLT, PLFLT, PLFLT *, PLFLT *, PLPointer),
+	 PLPointer pltr_data);
+
+void 
+plfshade(PLFLT (*f2eval) (PLINT, PLINT, PLPointer),
+	 PLPointer f2eval_data,
+	 PLFLT (*c2eval) (PLINT, PLINT, PLPointer),
+	 PLPointer c2eval_data,
+	 PLINT nx, PLINT ny, 
+	 PLFLT left, PLFLT right, PLFLT bottom, PLFLT top,
+	 PLFLT shade_min, PLFLT shade_max,
+	 PLINT sh_cmap, PLFLT sh_color, PLINT sh_width,
+	 PLINT min_color, PLINT min_width,
+	 PLINT max_color, PLINT max_width,
+	 void (*fill) (PLINT, PLFLT *, PLFLT *), PLINT rectangular,
+	 void (*pltr) (PLFLT, PLFLT, PLFLT *, PLFLT *, PLPointer),
+	 PLPointer pltr_data);
+
+/* Set up lengths of major tick marks. */
+
+void
+c_plsmaj(PLFLT def, PLFLT scale);
+
+/* Set the memory area to be plotted (with the 'mem' driver) */
+
+void
+c_plsmem(PLINT maxx, PLINT maxy, void *plotmem);
+
+/* Set up lengths of minor tick marks. */
+
+void
+c_plsmin(PLFLT def, PLFLT scale);
+
+/* Set orientation.  Must be done before calling plinit. */
+
+void
+c_plsori(PLINT ori);
+
+/* Set output device parameters.  Usually ignored by the driver. */
+
+MZ_DLLEXPORT
+void
+c_plspage(PLFLT xp, PLFLT yp, PLINT xleng, PLINT yleng,
+	  PLINT xoff, PLINT yoff);
+
+/* Set the pause (on end-of-page) status */
+
+void
+c_plspause(PLINT pause);
+
+/* Set stream number.  */
+
+void
+c_plsstrm(PLINT strm);
+
+/* Set the number of subwindows in x and y */
+
+void
+c_plssub(PLINT nx, PLINT ny);
+
+/* Set symbol height. */
+
+void
+c_plssym(PLFLT def, PLFLT scale);
+
+/* Initialize PLplot, passing in the windows/page settings. */
+
+void
+c_plstar(PLINT nx, PLINT ny);
+
+/* Initialize PLplot, passing the device name and windows/page settings. */
+
+void
+c_plstart(const char *devname, PLINT nx, PLINT ny);
+
+/* Create 1d stripchart */
+
+void
+c_plstripc(PLINT *id, char *xspec, char *yspec,
+	PLFLT xmin, PLFLT xmax, PLFLT xjump, PLFLT ymin, PLFLT ymax,
+	PLFLT xlpos, PLFLT ylpos,
+	PLINT y_ascl, PLINT acc,
+	PLINT colbox, PLINT collab,
+	PLINT colline[], PLINT styline[], char *legline[],
+	char *labx, char *laby, char *labtop);
+
+/* Add a point to a stripchart.  */
+
+void
+c_plstripa(PLINT id, PLINT pen, PLFLT x, PLFLT y);
+
+/* Deletes and releases memory used by a stripchart.  */
+
+void
+c_plstripd(PLINT id);
+
+  /* plots a 2d image (or a matrix too large for plshade() ) */
+
+void
+plimage( PLFLT **data, PLINT nx, PLINT ny, 
+	 PLFLT xmin, PLFLT xmax, PLFLT ymin, PLFLT ymax, PLFLT zmin, PLFLT zmax,
+	 PLFLT Dxmin, PLFLT Dxmax, PLFLT Dymin, PLFLT Dymax);
+
+/* Set up a new line style */
+
+void
+c_plstyl(PLINT nms, PLINT *mark, PLINT *space);
+
+/* Sets the edges of the viewport to the specified absolute coordinates */
+
+void
+c_plsvpa(PLFLT xmin, PLFLT xmax, PLFLT ymin, PLFLT ymax);
+
+/* Set x axis labeling parameters */
+
+void
+c_plsxax(PLINT digmax, PLINT digits);
+
+/* Set inferior X window */
+
+void
+plsxwin(PLINT window_id);
+
+/* Set y axis labeling parameters */
+
+void
+c_plsyax(PLINT digmax, PLINT digits);
+
+/* Plots array y against x for n points using Hershey symbol "code" */
+
+void
+c_plsym(PLINT n, PLFLT *x, PLFLT *y, PLINT code);
+
+/* Set z axis labeling parameters */
+
+void
+c_plszax(PLINT digmax, PLINT digits);
+
+/* Switches to text screen. */
+
+void
+c_pltext(void);
+
+/* Sets the edges of the viewport with the given aspect ratio, leaving */
+/* room for labels. */
+
+void
+c_plvasp(PLFLT aspect);
+
+/* Creates the largest viewport of the specified aspect ratio that fits */
+/* within the specified normalized subpage coordinates. */
+
+void
+c_plvpas(PLFLT xmin, PLFLT xmax, PLFLT ymin, PLFLT ymax, PLFLT aspect);
+
+/* Creates a viewport with the specified normalized subpage coordinates. */
+
+void
+c_plvpor(PLFLT xmin, PLFLT xmax, PLFLT ymin, PLFLT ymax);
+
+/* Defines a "standard" viewport with seven character heights for */
+/* the left margin and four character heights everywhere else. */
+
+void
+c_plvsta(void);
+
+/* Set up a window for three-dimensional plotting. */
+
+MZ_DLLEXPORT
+void
+c_plw3d(PLFLT basex, PLFLT basey, PLFLT height, PLFLT xmin0,
+	PLFLT xmax0, PLFLT ymin0, PLFLT ymax0, PLFLT zmin0,
+	PLFLT zmax0, PLFLT alt, PLFLT az);
+
+/* Set pen width. */
+
+MZ_DLLEXPORT
+void
+c_plwid(PLINT width);
+
+/* Set up world coordinates of the viewport boundaries (2d plots). */
+
+void
+c_plwind(PLFLT xmin, PLFLT xmax, PLFLT ymin, PLFLT ymax);
+
+/*  set xor mode; mode = 1-enter, 0-leave, status = 0 if not interactive device  */
+
+void
+c_plxormod(PLINT mode, PLINT *status);
+
+/*--------------------------------------------------------------------------*\
+ *		Functions for use from C or C++ only
+\*--------------------------------------------------------------------------*/
+
+/* Returns a list of file-oriented device names and their menu strings */
+
+void
+plgFileDevs(char ***p_menustr, char ***p_devname, int *p_ndev);
+
+/* Returns a list of all device names and their menu strings */
+
+void
+plgDevs(char ***p_menustr, char ***p_devname, int *p_ndev);
+
+/* Set the function pointer for the keyboard event handler */
+
+void
+plsKeyEH(void (*KeyEH) (PLGraphicsIn *, void *, int *), void *KeyEH_data);
+
+/* Set the function pointer for the (mouse) button event handler */
+
+void
+plsButtonEH(void (*ButtonEH) (PLGraphicsIn *, void *, int *),
+	    void *ButtonEH_data);
+
+/* Sets an optional user bop handler */
+
+void
+plsbopH(void (*handler) (void *, int *), void *handler_data);
+
+/* Sets an optional user eop handler */
+
+void
+plseopH(void (*handler) (void *, int *), void *handler_data);
+
+/* Set the variables to be used for storing error info */
+
+void
+plsError(PLINT *errcode, char *errmsg);
+
+/* Sets an optional user exit handler. */
+
+void
+plsexit(int (*handler) (char *));
+
+	/* Transformation routines */
+
+/* Identity transformation. */
+
+void
+pltr0(PLFLT x, PLFLT y, PLFLT *tx, PLFLT *ty, PLPointer pltr_data);
+
+/* Does linear interpolation from singly dimensioned coord arrays. */
+
+MZ_DLLEXPORT
+void
+pltr1(PLFLT x, PLFLT y, PLFLT *tx, PLFLT *ty, PLPointer pltr_data);
+
+/* Does linear interpolation from doubly dimensioned coord arrays */
+/* (column dominant, as per normal C 2d arrays). */
+
+void
+pltr2(PLFLT x, PLFLT y, PLFLT *tx, PLFLT *ty, PLPointer pltr_data);
+
+/* Just like pltr2() but uses pointer arithmetic to get coordinates from */
+/* 2d grid tables.  */
+
+void
+pltr2p(PLFLT x, PLFLT y, PLFLT *tx, PLFLT *ty, PLPointer pltr_data);
+
+/* Identity transformation for plots from Fortran. */
+
+void
+pltr0f(PLFLT x, PLFLT y, PLFLT *tx, PLFLT *ty, void *pltr_data);
+
+/* Does linear interpolation from doubly dimensioned coord arrays */
+/* (row dominant, i.e. Fortran ordering). */
+
+void
+pltr2f(PLFLT x, PLFLT y, PLFLT *tx, PLFLT *ty, void *pltr_data);
+
+/* Example linear transformation function for contour plotter. */
+
+void 
+xform(PLFLT x, PLFLT y, PLFLT * tx, PLFLT * ty);
+
+	/* Function evaluators */
+
+/* Does a lookup from a 2d function array.  Array is of type (PLFLT **), */
+/* and is column dominant (normal C ordering). */
+
+PLFLT
+plf2eval2(PLINT ix, PLINT iy, PLPointer plf2eval_data);
+
+/* Does a lookup from a 2d function array.  Array is of type (PLFLT *), */
+/* and is column dominant (normal C ordering). */
+
+PLFLT
+plf2eval(PLINT ix, PLINT iy, PLPointer plf2eval_data);
+
+/* Does a lookup from a 2d function array.  Array is of type (PLFLT *), */
+/* and is row dominant (Fortran ordering). */
+
+PLFLT
+plf2evalr(PLINT ix, PLINT iy, PLPointer plf2eval_data);
+
+	/* Command line parsing utilities */
+
+/* Clear internal option table info structure. */
+
+void
+plClearOpts(void);
+
+/* Reset internal option table info structure. */
+
+void
+plResetOpts(void);
+
+/* Merge user option table into internal info structure. */
+
+int
+plMergeOpts(PLOptionTable *options, char *name, char **notes);
+
+/* Set the strings used in usage and syntax messages. */
+
+void
+plSetUsage(char *program_string, char *usage_string);
+
+/* Process input strings, treating them as an option and argument pair. */
+/* The first is for the external API, the second the work routine declared
+   here for backward compatibilty. */
+
+int
+c_plsetopt(char *opt, char *optarg);
+
+int
+plSetOpt(char *opt, char *optarg);
+
+/* Process options list using current options info. */
+
+int
+plParseOpts(int *p_argc, char **argv, PLINT mode);
+
+/* Print usage & syntax message. */
+
+void
+plOptUsage(void);
+
+	/* Miscellaneous */
+
+/* Set the output file pointer */
+
+void
+plgfile(FILE **p_file);
+
+/* Get the output file pointer */
+
+void
+plsfile(FILE *file);
+
+/* Get the escape character for text strings. */
+
+void
+plgesc(char *p_esc);
+
+/* Front-end to driver escape function. */
+
+void
+pl_cmd(PLINT op, void *ptr);
+
+/* Return full pathname for given file if executable */
+
+int 
+plFindName(char *p);
+
+/* Looks for the specified executable file according to usual search path. */
+
+char *
+plFindCommand(char *fn);
+
+/* Gets search name for file by concatenating the dir, subdir, and file */
+/* name, allocating memory as needed.  */
+
+void
+plGetName(char *dir, char *subdir, char *filename, char **filespec);
+
+/* Prompts human to input an integer in response to given message. */
+
+PLINT
+plGetInt(char *s);
+
+/* Prompts human to input a float in response to given message. */
+
+PLFLT
+plGetFlt(char *s);
+
+	/* Nice way to allocate space for a vectored 2d grid */
+
+/* Allocates a block of memory for use as a 2-d grid of PLFLT's.  */
+
+void
+plAlloc2dGrid(PLFLT ***f, PLINT nx, PLINT ny);
+
+/* Frees a block of memory allocated with plAlloc2dGrid(). */
+
+void
+plFree2dGrid(PLFLT **f, PLINT nx, PLINT ny);
+
+/* Find the maximum and minimum of a 2d matrix allocated with plAllc2dGrid(). */
+
+void
+plMinMax2dGrid(PLFLT **f, PLINT nx, PLINT ny, PLFLT *fmax, PLFLT *fmin);
+
+/* Functions for converting between HLS and RGB color space */
+
+void
+plHLS_RGB(PLFLT h, PLFLT l, PLFLT s, PLFLT *p_r, PLFLT *p_g, PLFLT *p_b);
+
+void
+plRGB_HLS(PLFLT r, PLFLT g, PLFLT b, PLFLT *p_h, PLFLT *p_l, PLFLT *p_s);
+
+/* Wait for graphics input event and translate to world coordinates */
+
+int
+plGetCursor(PLGraphicsIn *gin);
+
+/* Translates relative device coordinates to world coordinates.  */
+
+int
+plTranslateCursor(PLGraphicsIn *gin);
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif	/* __PLPLOT_H__ */
diff --git a/collects/plot/src/all/plplotP.h b/collects/plot/src/all/plplotP.h
new file mode 100644
index 0000000000..71b5c636aa
--- /dev/null
+++ b/collects/plot/src/all/plplotP.h
@@ -0,0 +1,872 @@
+/* $Id: plplotP.h,v 1.1 2004/03/01 20:54:52 cozmic Exp $
+
+    Copyright (C) 1993, 1994, 1995  by 
+    Maurice J. LeBrun, Geoff Furnish, Tony Richardson.
+
+    Internal (private) macros and prototypes for the PLplot package.  This
+    header file must be included before all others, including system header
+    files.  This file is typically needed when including driver specific
+    header files (e.g. pltkd.h).
+
+    This software may be freely copied, modified and redistributed without
+    fee provided that this copyright notice is preserved intact on all
+    copies and modified copies. 
+ 
+    There is no warranty or other guarantee of fitness of this software.
+    It is provided solely "as is". The author(s) disclaim(s) all
+    responsibility and liability with respect to this software's usage or
+    its effect upon hardware or computer systems. 
+*/
+
+#ifndef __PLPLOTP_H__
+#define __PLPLOTP_H__
+
+/*--------------------------------------------------------------------------*\
+ * Select environment.  Must be done before anything else.
+ *
+ * Basically we want the widest range of system services that are available.
+ * Fortunately on many systems, that is the default.  To get "everything",
+ * one of the following must be defined, as appropriate:
+ *
+ * _GNU_SOURCE     on Linux (default) 
+ * _OSF_SOURCE     on OSF1 (default) 
+ * _HPUX_SOURCE    on HP (not default) 
+ * _ALL_SOURCE     on AIX (no idea) 
+ *
+ * To see where these are set, do the following:
+ *
+ *    cd /usr/include; grep SOURCE *.h | fgrep 'define '
+ *
+ * and the file containing lots of these is the one you want (features.h on
+ * Linux, standards.h on OSF1, etc).  Follow the logic to see what needs to be
+ * defined to get "everything", i.e. POSIX.*, XOPEN, etc.
+ *
+ * Note that for specific functionality, we test using autoconf.  Still it's
+ * best to stick to ANSI C, POSIX.1, and POSIX.2, in that order, for maximum
+ * portability.
+\*--------------------------------------------------------------------------*/
+
+/* HPUX - if this is no longer needed, please remove it */
+#ifdef _HPUX
+#define _HPUX_SOURCE
+#endif
+
+/* A/IX - if this is no longer needed, please remove it */
+#ifdef _AIX
+#define _ALL_SOURCE
+#endif
+
+/* Add others here as needed. */
+
+/*--------------------------------------------------------------------------*\
+ *	Configuration settings
+ * 
+ * Some of the macros set during configuration are described here.
+ *
+ * If HAVE_TERMIOS_H is set, we employ POSIX.1 tty terminal I/O.  One purpose
+ * of this is to select character-oriented (CBREAK) i/o in the tek driver and
+ * all its variants.  It is usable without this but not as powerful.  The
+ * reason for using this is that some supported systems are still not
+ * POSIX.1 compliant (and some may never be).
+ *
+ * If STDC_HEADERS is defined, the system's libc is ANSI-compliant.
+ * ANSI libc calls are used for: (a) setting up handlers to be called
+ * before program exit (via the "atexit" call), and (b) for seek
+ * operations.  Again, the code is usable without these.  An ANSI libc
+ * should be available, given the requirement of an ANSI compiler.  Some
+ * reasons why not: (a) the vendor didn't supply a complete ANSI
+ * environment, or (b) the ANSI libc calls are buggy, or (c) you ported
+ * gcc to your system but not glibc (for whatever reason).  Note: without
+ * an ANSI C lib, if you ^C out of a program using one of the PLplot tek
+ * drivers, your terminal may be left in a strange state.
+\*--------------------------------------------------------------------------*/
+
+#include "plConfig.h"
+#ifdef caddr_t
+#undef caddr_t
+#ifndef __USE_BSD
+typedef char * caddr_t;
+#endif
+#endif
+
+/* System headers */
+
+#include <ctype.h>
+#include <math.h>
+#include <string.h>
+#include <limits.h>
+#include <float.h>
+
+#if HAVE_DIRENT_H
+# include <dirent.h>
+# define NAMLEN(dirent) strlen((dirent)->d_name)
+#else
+# define dirent direct
+# define NAMLEN(dirent) (dirent)->d_namlen
+# if HAVE_SYS_NDIR_H
+#  include <sys/ndir.h>
+# endif
+# if HAVE_SYS_DIR_H
+#  include <sys/dir.h>
+# endif
+# if HAVE_NDIR_H
+#  include <ndir.h>
+# endif
+#endif
+
+/*
+ * Macros for file positioning.  I tried switching to f[sg]etpos() because I
+ * like the semantics better, but ran into the problem that fpos_t is not
+ * always a base type (it may be a struct).  This is a problem because the
+ * metafile driver needs to write relative offsets into the file itself.  So
+ * instead we use f{seek,tell} at a low level but keep the f[sg]etpos
+ * semantics using these macros. 
+ */
+
+#ifdef STDC_FPOS_T
+#undef STDC_FPOS_T
+#endif
+
+#ifdef STDC_FPOS_T
+#define FPOS_T fpos_t
+#define pl_fsetpos(a,b) fsetpos(a, b)
+#define pl_fgetpos(a,b) fgetpos(a, b)
+
+#else
+#define FPOS_T long
+#define pl_fsetpos(a,b) fseek(a, *b, 0)
+#define pl_fgetpos(a,b) (-1L == (*b = ftell(a)))
+#endif
+
+/* Include all externally-visible definitions and prototypes */
+/* plplot.h also includes some handy system header files */
+
+#include "plplot.h"
+
+/* plstream definition */
+
+#include "plstrm.h"
+
+/* If not including this file from inside of plcore.h, declare plsc */
+
+#ifndef __PLCORE_H__
+#ifdef __cplusplus
+extern "C" {
+#endif
+extern PLStream	*plsc;
+#ifdef __cplusplus
+}
+#endif
+#include "pldebug.h"
+#endif
+
+/*--------------------------------------------------------------------------*\
+ *                       Utility macros
+\*--------------------------------------------------------------------------*/
+
+#ifndef TRUE
+#define TRUE  1
+#define FALSE 0
+#endif
+
+/* Used to help ensure everything malloc'ed gets freed */
+
+#define free_mem(a) \
+    if (a != NULL) { free((void *) a); a = NULL; }
+
+/* Allows multi-argument setup calls to not affect selected arguments */
+
+#define plsetvar(a, b) \
+    if (b != PL_NOTSET) a = b;
+
+/* Lots of cool math macros */
+
+#ifndef MAX
+#define MAX(a,b)    (((a) > (b)) ? (a) : (b))
+#endif
+#ifndef MIN
+#define MIN(a,b)    (((a) < (b)) ? (a) : (b))
+#endif
+#ifndef ABS
+#define ABS(a)      ((a)<0 ? -(a) : (a))
+#endif
+#ifndef ROUND
+#define ROUND(a)    (PLINT)((a)<0. ? ((a)-.5) : ((a)+.5))
+#endif
+#ifndef BETW
+#define BETW(ix,ia,ib)  (((ix)<=(ia)&&(ix)>=(ib)) || ((ix)>=(ia)&&(ix)<=(ib)))
+#endif
+#ifndef SSQR
+#define SSQR(a,b)       sqrt((a)*(a)+(b)*(b))
+#endif
+#ifndef SIGN
+#define SIGN(a)         ((a)<0 ? -1 : 1)
+#endif
+
+/* A coordinate value that should never occur */
+
+#define PL_UNDEFINED -9999999
+
+/*--------------------------------------------------------------------------*\
+ *                       PLPLOT control macros
+\*--------------------------------------------------------------------------*/
+
+/* Some constants */
+
+#define PL_MAXPOLY	256	/* Max segments in polyline or polygon */
+#define PL_NSTREAMS	100	/* Max number of concurrent streams. */
+#define PL_RGB_COLOR	1<<7	/* A hack */
+
+#define TEXT_MODE	0
+#define GRAPHICS_MODE	1
+#ifndef PI
+#define PI		3.1415926535897932384
+#endif
+
+/* These define the virtual coordinate system used by the metafile driver.
+   Others are free to use it, or some variation, or define their own. */
+
+/* Note desktop monitors of reasonable quality typically have 0.25 mm spacing 
+ * between dots which corresponds to 4.0 dots per mm.  The parameters here
+ * roughly correspond to a 14" monitor at 1024x768 resolution, which should
+ * work fine at other sizes/resolutions.  The number of virtual dots per mm is
+ * scaled by a factor of 32, with pixels scaled accordingly.  The customary
+ * x/y ratio of 4:3 is used.
+ */
+
+#define PIXELS_X	32768		/* Number of virtual pixels in x */
+#define PIXELS_Y	24576		/* Number of virtual pixels in x */
+#define DPMM		4.		/* dots per mm */
+#define VDPMM	      (DPMM*32)		/* virtual dots per mm */
+#define LPAGE_X	    (PIXELS_X/VDPMM)	/* virtual page length in x in mm (256) */
+#define LPAGE_Y	    (PIXELS_Y/VDPMM)	/* virtual page length in y in mm (192) */
+
+/* This defines the first argument of the plRotPhy invocation that is made
+ * in a number of device drivers (e.g., found in ljii.c, ljiip.c, ps.c,
+ * and pstex.c) to rotate them "permanently" from portrait mode to non-
+ * portrait mode.  ORIENTATION of 1 corresponds to seascape mode (90 deg
+ * clockwise rotation from portrait).  This is the traditional value 
+ * effectively used in all older versions of PLplot. ORIENTATION of 3 
+ * corresponds to landscape mode (90 deg *counter*-clockwise rotation from 
+ * portrait) which is the new default non-portrait orientation. */
+
+#define ORIENTATION	3
+
+/* Switches for state function call. */
+
+#define PLSTATE_WIDTH		1	/* pen width */
+#define PLSTATE_COLOR0		2	/* change to color in cmap 0 */
+#define PLSTATE_COLOR1		3	/* change to color in cmap 1 */
+#define PLSTATE_FILL		4	/* set area fill attribute */
+#define PLSTATE_CMAP0		5	/* change to cmap 0 */
+#define PLSTATE_CMAP1		6	/* change to cmap 1 */
+
+/* Bit switches used in the driver interface */
+
+#define PLDI_MAP	0x01
+#define PLDI_ORI	0x02
+#define PLDI_PLT	0x04
+#define PLDI_DEV	0x08
+
+/* Default size for family files, in KB. */
+
+#ifndef PL_FILESIZE_KB
+#define PL_FILESIZE_KB 1000
+#endif
+
+/* Font file names. */
+
+#define PLPLOT5_FONTS
+
+#ifdef PLPLOT5_FONTS
+#define PL_XFONT	"plxtnd5.fnt"
+#define PL_SFONT	"plstnd5.fnt"
+#else
+#define PL_XFONT	"plxtnd4.fnt"
+#define PL_SFONT	"plstnd4.fnt"
+#endif
+
+/*--------------------------------------------------------------------------*\
+ * The following environment variables are defined:
+ * 
+ *	PLPLOT_BIN      # where to find executables
+ *	PLPLOT_LIB      # where to find library files (fonts, maps, etc)
+ *	PLPLOT_TCL      # where to find tcl scripts
+ *
+ *	PLPLOT_HOME     # basename of plplot hierarchy
+ *
+ * search order:
+ *	1)	the most specific possible locators, one of
+ *			$(PLPLOT_BIN)
+ *			$(PLPLOT_LIB)
+ *			$(PLPLOT_TCL)
+ *		as appropriate
+ *
+ *	2)	the current directory
+ *
+ *	3)	one of  $(PLPLOT_HOME)/bin
+ *			$(PLPLOT_HOME)/lib
+ *			$(PLPLOT_HOME)/tcl
+ *		as appropriate
+ *
+ *	4)	as appropriate, the compile-time (Makefile)
+ *		BIN_DIR, LIB_DIR, TCL_DIR
+ *
+ *  8 Jun 1994  mj olesen (olesen@weber.me.queensu.ca)
+ *
+ * Other notes:
+ *
+ * In addition to the directories above, the following are also used:
+ *
+ * Lib file search path: PLLIBDEV (see plctrl.c).  This is checked last,
+ * and is a system-dependent hardwired location.
+ *
+ * Tcl search path: $HOME/tcl is searched before the install location,
+ * TCL_DIR.
+\*--------------------------------------------------------------------------*/
+
+#define PLPLOT_BIN_ENV          "PLPLOT_BIN"
+#define PLPLOT_LIB_ENV          "PLPLOT_LIB"
+#define PLPLOT_TCL_ENV          "PLPLOT_TCL"
+#define PLPLOT_HOME_ENV         "PLPLOT_HOME"
+
+/*--------------------------------------------------------------------------*\
+ *		Function Prototypes
+ *
+ * These typically should not be called directly by the user.
+\*--------------------------------------------------------------------------*/
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+/* Determines interval between numeric labels */
+
+void
+pldtik(PLFLT vmin, PLFLT vmax, PLFLT *tick, PLINT *nsubt);
+
+/* Determines precision of box labels */
+
+void
+pldprec(PLFLT vmin, PLFLT vmax, PLFLT tick, PLINT lf, 
+	PLINT *mode, PLINT *prec, PLINT digmax, PLINT *scale);
+
+/* Draws a polyline within the clip limits. */
+
+void
+plP_pllclp(PLINT *x, PLINT *y, PLINT npts,
+	   PLINT xmin, PLINT xmax, PLINT ymin, PLINT ymax, 
+	   void (*draw) (short *, short *, PLINT));
+
+/* Fills a polygon within the clip limits. */
+
+void
+plP_plfclp(PLINT *x, PLINT *y, PLINT npts,
+	   PLINT xmin, PLINT xmax, PLINT ymin, PLINT ymax, 
+	   void (*draw) (short *, short *, PLINT));
+
+  /* Clip a polygon to the 3d bounding plane */
+int
+plP_clip_poly(int Ni, PLFLT *Vi[3], int axis, PLFLT dir, PLFLT offset);
+
+/* Pattern fills in software the polygon bounded by the input points. */
+
+void
+plfill_soft(short *x, short *y, PLINT npts);
+
+/* In case of an abort this routine is called.  It just prints out an */
+/* error message and tries to clean up as much as possible. */
+
+void
+plexit(char *errormsg);
+
+/* Just a front-end to exit().  */
+
+void
+pl_exit(void);
+
+/* A handy way to issue warnings, if need be. */
+
+void
+plwarn(char *errormsg);
+
+/* Same as plwarn(), but appends ", aborting plot" to the error message */
+
+void
+plabort(char *errormsg);
+
+/* Loads either the standard or extended font. */
+
+void
+plfntld(PLINT fnt);
+
+/* Release memory for fonts. */
+
+void
+plfontrel(void);
+
+/* A replacement for strdup(), which isn't portable. */
+
+char *
+plstrdup(const char *src);
+
+/* Bin up cmap 1 space and assign colors to make inverse mapping easy. */
+
+void
+plcmap1_calc(void);
+
+/* Draws a slanting tick at position (mx,my) (measured in mm) of */
+/* vector length (dx,dy). */
+
+void 
+plstik(PLFLT mx, PLFLT my, PLFLT dx, PLFLT dy);
+
+/* Prints out a "string" at reference position with physical coordinates */
+/* (refx,refy). */
+
+void
+plstr(PLINT base, PLFLT *xform, PLINT refx, PLINT refy, const char *string);
+
+/* Draws a tick parallel to x. */
+
+void
+plxtik(PLINT x, PLINT y, PLINT below, PLINT above);
+
+/* Draws a tick parallel to y. */
+
+void
+plytik(PLINT x, PLINT y, PLINT left, PLINT right);
+
+  /* Driver interface filter -- 
+     passes all coordinates through a variety of filters. */
+
+void
+difilt(PLINT *, PLINT *, PLINT,
+       PLINT *, PLINT *, PLINT *, PLINT *);
+
+  /* Driver draws text */
+
+void
+plP_text(PLINT base, PLFLT just, PLFLT *xform, PLINT x, PLINT y,
+		 PLINT refx, PLINT refy, const char *string);
+
+  /* where should structure definitions that must be seen by drivers and core source files, be? */
+
+  /* structure to be used by plcore.c and anydriver.c, related to plP_text() */
+
+typedef struct {
+  PLINT base; /* ref point at base(1) or center(0) of text. Currently plplot only use 0 */
+  PLFLT just; /* continuos justification, 0 left, 0.5 center, 1 right */
+  PLFLT *xform; /* transformation (rotation) matrix */
+  PLINT x; /* raw reference point--after any transformation */
+  PLINT y;
+  PLINT refx; /* processed ref. point--after justification, displacement, etc, processing */
+  PLINT refy;
+  const char *string; /* text to draw */
+}EscText;
+
+/* 
+ * structure that contains driver specific information, to be used by plargs.c and anydriver.c,
+ * related to plParseDrvOpts() and plHelpDrvOpts()
+ */
+
+typedef struct {
+  char *opt;     /* a string with the name of the option */
+  PLINT type;    /* the type of the variable to be set, see bellow the available types */
+  void *var_ptr; /* a pointer to the variable to be set */
+  char *hlp_msg; /* help message of the option */
+} DrvOpt;
+
+  /* the available variable types, DrvOpt.type, for driver specific options */
+
+enum {DRV_INT, DRV_FLT, DRV_STR};
+
+  /* parse driver specific options, as in -drvopt <option[=value]>* */
+
+int
+plParseDrvOpts(DrvOpt *);
+
+  /* give help on driver specific options */
+
+void
+plHelpDrvOpts(DrvOpt *);
+
+  /*
+   * structures to store contour lines
+   */
+
+#define LINE_ITEMS 20
+
+typedef struct cont_line {
+  PLFLT *x;
+  PLFLT *y;
+  PLINT npts;
+  struct cont_line *next;
+} CONT_LINE;
+
+typedef struct cont_level {
+  PLFLT level;
+  struct cont_line *line; /* contour line */
+  struct cont_level *next; /* contour level */
+} CONT_LEVEL;
+
+void
+cont_store(PLFLT *x, PLFLT *y, PLFLT **f, PLINT nx, PLINT ny, PLINT kx, PLINT lx,
+	   PLINT ky, PLINT ly, PLFLT *clevel, PLINT nlevel, CONT_LEVEL **contour);
+void
+cont_clean_store(CONT_LEVEL *ct);
+
+/* Get x-y domain in world coordinates for 3d plots */
+
+void
+plP_gdom(PLFLT *p_xmin, PLFLT *p_xmax, PLFLT *p_ymin, PLFLT *p_ymax);
+
+/* Get vertical (z) scale parameters for 3-d plot */
+
+void
+plP_grange(PLFLT *p_zscl, PLFLT *p_zmin, PLFLT *p_zmax);
+
+/* Get parameters used in 3d plots */
+
+void
+plP_gw3wc(PLFLT *p_dxx, PLFLT *p_dxy, PLFLT *p_dyx, PLFLT *p_dyy,
+	  PLFLT *p_dyz);
+
+/* Get clip boundaries in physical coordinates */
+
+void
+plP_gclp(PLINT *p_ixmin, PLINT *p_ixmax, PLINT *p_iymin, PLINT *p_iymax);
+
+/* Set clip boundaries in physical coordinates */
+
+void
+plP_sclp(PLINT ixmin, PLINT ixmax, PLINT iymin, PLINT iymax);
+
+/* Get physical device limits in physical coordinates */
+
+void
+plP_gphy(PLINT *p_ixmin, PLINT *p_ixmax, PLINT *p_iymin, PLINT *p_iymax);
+
+/* Get number of subpages on physical device and current subpage */
+
+void
+plP_gsub(PLINT *p_nx, PLINT *p_ny, PLINT *p_cs);
+
+/* Set number of subpages on physical device and current subpage */
+
+void
+plP_ssub(PLINT nx, PLINT ny, PLINT cs);
+
+/* Set up plot parameters according to the number of subpages. */
+
+void
+plP_subpInit(void);
+
+/* Get number of pixels to a millimeter */
+
+void
+plP_gpixmm(PLFLT *p_x, PLFLT *p_y);
+
+/* All the drivers call this to set physical pixels/mm. */
+
+void
+plP_setpxl(PLFLT xpmm0, PLFLT ypmm0);
+
+/* Get background parameters for 3d plot. */
+
+void
+plP_gzback(PLINT **zbf, PLINT **zbc, PLFLT **zbt);
+
+/* Move to physical coordinates (x,y). */
+
+void
+plP_movphy(PLINT x, PLINT y);
+
+/* Draw to physical coordinates (x,y). */
+
+void
+plP_draphy(PLINT x, PLINT y);
+
+/* Move to world coordinates (x,y). */
+
+void
+plP_movwor(PLFLT x, PLFLT y);
+
+/* Draw to world coordinates (x,y). */
+
+void
+plP_drawor(PLFLT x, PLFLT y);
+
+/* Draw polyline in physical coordinates. */
+
+void
+plP_draphy_poly(PLINT *x, PLINT *y, PLINT n);
+
+/* Draw polyline in world coordinates. */
+
+void
+plP_drawor_poly(PLFLT *x, PLFLT *y, PLINT n);
+
+/* Sets up physical limits of plotting device. */
+
+void
+plP_setphy(PLINT xmin, PLINT xmax, PLINT ymin, PLINT ymax);
+
+/* Set up the subpage boundaries according to the current subpage selected */
+
+void
+plP_setsub(void);
+
+/* Get the floating point precision (in number of places) in numeric labels. */
+
+void
+plP_gprec(PLINT *p_setp, PLINT *p_prec);
+
+/* Computes the length of a string in mm, including escape sequences. */
+
+PLFLT
+plstrl(const char *string);
+
+/* Similar to strpos, but searches for occurence of string str2. */
+
+PLINT
+plP_stindex(const char *str1, const char *str2);
+
+/* Searches string str for first occurence of character chr.  */
+
+PLINT
+plP_strpos(char *str, int chr);
+
+/* Searches string str for character chr (case insensitive). */
+
+PLINT
+plP_stsearch(const char *str, int chr);
+
+	/* Conversion functions */
+
+/* device coords to physical coords (x) */
+
+PLINT
+plP_dcpcx(PLFLT x);
+
+/* device coords to physical coords (y) */
+
+PLINT
+plP_dcpcy(PLFLT y);
+
+/* millimeters from bottom left-hand corner to physical coords (x) */
+
+PLINT
+plP_mmpcx(PLFLT x);
+
+/* millimeters from bottom left-hand corner to physical coords (y) */
+
+PLINT
+plP_mmpcy(PLFLT y);
+
+/* world coords to physical coords (x) */
+
+PLINT
+plP_wcpcx(PLFLT x);
+
+/* world coords to physical coords (y) */
+
+PLINT
+plP_wcpcy(PLFLT y);
+
+/* physical coords to device coords (x) */
+
+PLFLT
+plP_pcdcx(PLINT x);
+
+/* physical coords to device coords (y) */
+
+PLFLT
+plP_pcdcy(PLINT y);
+
+/* millimeters from bottom left corner to device coords (x) */
+
+PLFLT
+plP_mmdcx(PLFLT x);
+
+/* millimeters from bottom left corner to device coords (y) */
+
+PLFLT
+plP_mmdcy(PLFLT y);
+
+/* world coords into device coords (x) */
+
+PLFLT
+plP_wcdcx(PLFLT x);
+
+/* world coords into device coords (y) */
+
+PLFLT
+plP_wcdcy(PLFLT y);
+
+/* subpage coords to device coords (x) */
+
+PLFLT
+plP_scdcx(PLFLT x);
+
+/* subpage coords to device coords (y) */
+
+PLFLT
+plP_scdcy(PLFLT y);
+
+/* device coords to millimeters from bottom left-hand corner (x) */
+
+PLFLT
+plP_dcmmx(PLFLT x);
+
+/* device coords to millimeters from bottom left-hand corner (y) */
+
+PLFLT
+plP_dcmmy(PLFLT y);
+
+/* world coords into millimeters (x) */
+
+PLFLT
+plP_wcmmx(PLFLT x);
+
+/* world coords into millimeters (y) */
+
+PLFLT
+plP_wcmmy(PLFLT y);
+
+/* device coords to subpage coords (x) */
+
+PLFLT
+plP_dcscx(PLFLT x);
+
+/* device coords to subpage coords (y) */
+
+PLFLT
+plP_dcscy(PLFLT y);
+
+/* 3-d coords to 2-d projection (x) */
+
+PLFLT
+plP_w3wcx(PLFLT x, PLFLT y, PLFLT z);
+
+/* 3-d coords to 2-d projection (y) */
+
+PLFLT
+plP_w3wcy(PLFLT x, PLFLT y, PLFLT z);
+
+	/* Driver calls */
+
+/* Initialize device. */
+
+void
+plP_init(void);
+
+/* Draw line between two points */
+
+void
+plP_line(short *x, short *y);
+
+/* Draw polyline */
+
+void
+plP_polyline(short *x, short *y, PLINT npts);
+
+/* Fill polygon */
+
+void
+plP_fill(short *x, short *y, PLINT npts);
+
+/* draw image */
+
+void
+plP_image(short *x, short *y, unsigned short *z, PLINT nx, PLINT ny, PLFLT xmin, PLFLT ymin, PLFLT dx, PLFLT dy, unsigned short zmin, unsigned short zmax);
+
+/* End of page */
+
+void
+plP_eop(void);
+
+/* End of page */
+
+void
+plP_bop(void);
+
+/* Tidy up device (flush buffers, close file, etc.) */
+
+void
+plP_tidy(void);
+
+/* Change state. */
+
+void
+plP_state(PLINT op);
+
+/* Escape function, for driver-specific commands. */
+
+void
+plP_esc(PLINT op, void *ptr);
+
+/* Set up plot window parameters. */
+
+void
+plP_swin(PLWindow *plwin);
+
+/* Return file pointer to lib file. */
+
+FILE *
+plLibOpen(char *fn);
+
+/* Does required startup initialization of library.  */
+
+void
+pllib_init(void);
+
+/* Does preliminary setup of device driver. */
+
+void
+pllib_devinit(void);
+
+/* Utility to copy one PLColor to another. */
+
+void
+pl_cpcolor(PLColor *to, PLColor *from);
+
+/* Does required startup initialization of a stream.  */
+
+void
+plstrm_init(void);
+
+/* Builds a list of the active devices/streams by device name */
+
+void
+plP_getinitdriverlist(char *names);
+
+/* Checks a give list of device names against active streams and returns the number of matches */
+
+PLINT 
+plP_checkdriverinit( char *names);
+
+  /* disable writing to plot buffer and pixmap */
+void
+NoBufferNoPixmap(void);
+
+  /* restart writing to plot buffer and pixmap */
+void
+RestoreWrite2BufferPixmap(void);
+
+void
+grimage(short *x, short *y, unsigned short *z, PLINT nx, PLINT ny);
+
+void
+plimageslow(short *x, short *y, unsigned short *data, PLINT nx, PLINT ny, 
+	    PLFLT xmin, PLFLT ymin, PLFLT dx, PLFLT dy,
+	    unsigned short zmin,  unsigned short zmax);
+
+typedef struct {
+  PLFLT xmin, ymin, dx, dy;} IMG_DT;
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif	/* __PLPLOTP_H__ */
diff --git a/collects/plot/src/all/plsdef.c b/collects/plot/src/all/plsdef.c
new file mode 100644
index 0000000000..0f91ad0506
--- /dev/null
+++ b/collects/plot/src/all/plsdef.c
@@ -0,0 +1,335 @@
+/* $Id: plsdef.c,v 1.1 2004/03/01 20:54:52 cozmic Exp $
+
+	Routines to set various plplot parameters, such as char height,
+	symbol size, tick length, line and fill patterns, etc.
+*/
+
+#include "plplotP.h"
+
+/* Line pattern defaults */
+
+static struct line {
+    PLINT nels;
+    PLINT mark[4];
+    PLINT space[4];
+} line[] = {
+
+    {
+	0,			/* Continuous line */
+	{
+	    0, 0, 0, 0
+	},
+	{
+	    0, 0, 0, 0
+	}
+    },
+    {
+	1,
+	{
+	    1000, 0, 0, 0
+	},
+	{
+	    1000, 0, 0, 0
+	}
+    },
+    {
+	1,
+	{
+	    2000, 0, 0, 0
+	},
+	{
+	    2000, 0, 0, 0
+	}
+    },
+    {
+	1,
+	{
+	    2000, 0, 0, 0
+	},
+	{
+	    1000, 0, 0, 0
+	}
+    },
+    {
+	2,
+	{
+	    2500, 1000, 0, 0
+	},
+	{
+	    1000, 1000, 0, 0
+	}
+    },
+    {
+	2,
+	{
+	    2000, 1000, 0, 0
+	},
+	{
+	    2000, 1000, 0, 0
+	}
+    },
+    {
+	3,
+	{
+	    1000, 1500, 2000, 0
+	},
+	{
+	    1000, 1500, 2000, 0
+	}
+    },
+    {
+	3,
+	{
+	    1000, 1500, 2000, 0
+	},
+	{
+	    1000, 1000, 1000, 0
+	}
+    }
+};
+
+/* Fill pattern defaults */
+
+static struct pattern {
+    PLINT nlines;		/* Number of lines in pattern (1 or 2) */
+    PLINT inc[2];		/* Inclination 10 ths of degrees */
+    PLINT del[2];		/* Spacing for each line */
+} pattern[] = {
+
+    {
+	1,
+	{
+	    0, 0
+	},
+	{
+	    2000, 0
+	}
+    },
+    {
+	1,
+	{
+	    900, 0
+	},
+	{
+	    2000, 0
+	}
+    },
+    {
+	1,
+	{
+	    450, 0
+	},
+	{
+	    2000, 0
+	}
+    },
+    {
+	1,
+	{
+	    -450, 0
+	},
+	{
+	    2000, 0
+	}
+    },
+    {
+	1,
+	{
+	    300, 0
+	},
+	{
+	    2000, 0
+	}
+    },
+    {
+	1,
+	{
+	    -300, 0
+	},
+	{
+	    2000, 0
+	}
+    },
+    {
+	2,
+	{
+	    0, 900
+	},
+	{
+	    2000, 2000
+	}
+    },
+    {
+	2,
+	{
+	    450, -450
+	},
+	{
+	    2000, 2000
+	}
+    }
+};
+
+/* Set defining parameters for pattern fill */
+
+static void
+spat(PLINT inc[], PLINT del[], PLINT nlin);
+
+/*----------------------------------------------------------------------*\
+ * void plschr()
+ *
+ * Set character height.
+\*----------------------------------------------------------------------*/
+
+void
+c_plschr(PLFLT def, PLFLT scale)
+{
+    if (def != 0.0) 
+	plsc->chrdef = def;
+
+    plsc->chrht = scale * plsc->chrdef;
+}
+
+/*----------------------------------------------------------------------*\
+ * void plsmin()
+ *
+ * Set up lengths of minor tick marks.
+\*----------------------------------------------------------------------*/
+
+void
+c_plsmin(PLFLT def, PLFLT scale)
+{
+    if (def != 0.0) 
+	plsc->mindef = def;
+
+    plsc->minht = scale * plsc->mindef;
+}
+
+/*----------------------------------------------------------------------*\
+ * void plsmaj()
+ *
+ * Set up lengths of major tick marks.
+\*----------------------------------------------------------------------*/
+
+void
+c_plsmaj(PLFLT def, PLFLT scale)
+{
+    if (def != 0.0) 
+	plsc->majdef = def;
+
+    plsc->majht = scale * plsc->majdef;
+}
+
+/*----------------------------------------------------------------------*\
+ * void plssym()
+ *
+ * Set symbol height.
+\*----------------------------------------------------------------------*/
+
+void
+c_plssym(PLFLT def, PLFLT scale)
+{
+    if (def != 0.0) 
+	plsc->symdef = def;
+
+    plsc->symht = scale * plsc->symdef;
+}
+
+/*----------------------------------------------------------------------*\
+ * void pllsty()
+ *
+ * Set line style.
+\*----------------------------------------------------------------------*/
+
+void
+c_pllsty(PLINT lin)
+{
+    if (plsc->level < 1) {
+	plabort("pllsty: Please call plinit first");
+	return;
+    }
+    if (lin < 1 || lin > 8) {
+	plabort("pllsty: Invalid line style");
+	return;
+    }
+
+    plstyl(line[lin - 1].nels,
+	   &line[lin - 1].mark[0], &line[lin - 1].space[0]);
+}
+
+/*----------------------------------------------------------------------*\
+ * void plpat()
+ *
+ * Set fill pattern directly.
+\*----------------------------------------------------------------------*/
+
+void
+c_plpat(PLINT nlin, PLINT *inc, PLINT *del)
+{
+    PLINT i;
+
+    if (plsc->level < 1) {
+	plabort("plpat: Please call plinit first");
+	return;
+    }
+    if (nlin < 1 || nlin > 2) {
+	plabort("plpat: Only 1 or 2 line styles allowed");
+	return;
+    }
+    for (i = 0; i < nlin; i++) {
+	if (del[i] < 0) {
+	    plabort("plpat: Line spacing must be greater than 0");
+	    return;
+	}
+    }
+    spat(inc, del, nlin);
+}
+
+/*----------------------------------------------------------------------*\
+ * void plpsty()
+ *
+ * Set fill pattern, using one of the predefined patterns.
+ * A fill pattern <= 0 indicates hardware fill.
+\*----------------------------------------------------------------------*/
+
+void
+c_plpsty(PLINT patt)
+{
+    if (plsc->level < 1) {
+	plabort("plpsty: Please call plinit first");
+	return;
+    }
+    if (patt > 8) {
+	plabort("plpsty: Invalid pattern");
+	return;
+    }
+    if (patt != plsc->patt) {
+	plsc->patt = patt;
+
+	if (plsc->level > 0) {
+	    plP_state(PLSTATE_FILL);
+	}
+    }
+    if (patt > 0) {
+	spat(&pattern[patt - 1].inc[0], &pattern[patt - 1].del[0],
+	     pattern[patt - 1].nlines);
+    }
+}
+
+/*----------------------------------------------------------------------*\
+ * void spat()
+ *
+ * Set defining parameters for pattern fill 
+\*----------------------------------------------------------------------*/
+
+static void
+spat(PLINT inc[], PLINT del[], PLINT nlin)
+{
+    PLINT i;
+
+    plsc->nps = nlin;
+    for (i = 0; i < nlin; i++) {
+	plsc->inclin[i] = inc[i];
+	plsc->delta[i] = del[i];
+    }
+}
diff --git a/collects/plot/src/all/plshade.c b/collects/plot/src/all/plshade.c
new file mode 100644
index 0000000000..b2cb7843b0
--- /dev/null
+++ b/collects/plot/src/all/plshade.c
@@ -0,0 +1,1115 @@
+/* $Id: plshade.c,v 1.2 2005/03/17 21:39:21 eli Exp $
+
+	Functions to shade regions on the basis of value.
+	Can be used to shade contour plots or alone.
+	Copyright 1993 Wesley Ebisuzaki 
+*/
+
+/*----------------------------------------------------------------------*\
+ * Call syntax for plshade():
+ * 
+ * void plshade(PLFLT *a, PLINT nx, PLINT ny, char *defined, 
+ *	PLFLT xmin, PLFLT xmax, PLFLT ymin, PLFLT ymax, 
+ * 	PLFLT shade_min, PLFLT shade_max, 
+ * 	PLINT sh_color, PLINT sh_width, PLINT min_color, PLINT min_width,
+ * 	PLINT max_color, PLINT max_width, void (*fill)(), PLINT
+ * 	rectangular, ...)
+ * 
+ * arguments:
+ * 
+ * 	PLFLT &(a[0][0])
+ * 
+ * Contains array to be plotted. The array must have been declared as
+ * PLFLT a[nx][ny].  See following note on fortran-style arrays.
+ * 
+ * 	PLINT nx, ny
+ * 
+ * Dimension of array "a".
+ * 
+ * 	char &(defined[0][0])
+ * 
+ * Contains array of flags, 1 = data is valid, 0 = data is not valid.
+ * This array determines which sections of the data is to be plotted.
+ * This argument can be NULL if all the values are valid.  Must have been
+ * declared as char defined[nx][ny].
+ * 
+ * 	PLFLT xmin, xmax, ymin, ymax
+ * 
+ * Defines the "grid" coordinates.  The data a[0][0] has a position of
+ * (xmin,ymin).
+ * 
+ * 	void (*mapform)()
+ * 
+ * Transformation from `grid' coordinates to world coordinates.  This
+ * pointer to a function can be NULL in which case the grid coordinates
+ * are the same as the world coordinates.
+ * 
+ * 	PLFLT shade_min, shade_max
+ * 
+ * Defines the interval to be shaded. If shade_max <= shade_min, plshade
+ * does nothing.
+ * 
+ *	PLINT sh_cmap, PLFLT sh_color, PLINT sh_width
+ * 
+ * Defines color map, color map index, and width used by the fill pattern.
+ * 
+ * 	PLINT min_color, min_width, max_color, max_width
+ * 
+ * Defines pen color, width used by the boundary of shaded region. The min
+ * values are used for the shade_min boundary, and the max values are used
+ * on the shade_max boundary.  Set color and width to zero for no plotted
+ * boundaries.
+ * 
+ * 	void (*fill)()
+ * 
+ * Routine used to fill the region.  Use plfill.  Future version of plplot
+ * may have other fill routines.
+ * 
+ * 	PLINT rectangular
+ * 
+ * Flag. Set to 1 if rectangles map to rectangles after (*mapform)() else
+ * set to zero. If rectangular is set to 1, plshade tries to save time by
+ * filling large rectangles.  This optimization fails if (*mapform)()
+ * distorts the shape of rectangles.  For example a plot in polor
+ * coordinates has to have rectangular set to zero.
+ * 
+ * Example mapform's:
+ * 
+ * Grid to world coordinate transformation.
+ * This example goes from a r-theta to x-y for a polar plot.
+ *
+ * void mapform(PLINT n, PLFLT *x, PLFLT *y) {
+ * 	int i;
+ * 	double r, theta;
+ * 	for (i = 0; i < n; i++) {
+ * 	    r = x[i];
+ * 	    theta = y[i];
+ * 	    x[i] = r*cos(theta);
+ * 	    y[i] = r*sin(theta);	
+ * 	}
+ * }
+ * 
+ * Grid was in cm, convert to world coordinates in inches.
+ * Expands in x direction.
+ *
+ * void mapform(PLINT n, PLFLT *x, PLFLT *y) {
+ * 	int i;
+ * 	for (i = 0; i < n; i++) {
+ * 		x[i] = (1.0 / 2.5) * x[i];
+ * 		y[i] = (1.0 / 2.5) * y[i];
+ * 	}
+ * }
+ *
+\*----------------------------------------------------------------------*/
+
+#include "plplotP.h"
+#include <float.h>
+
+#define MISSING_MIN_DEF (PLFLT) 1.0
+#define MISSING_MAX_DEF (PLFLT) -1.0
+
+
+#define NEG  1
+#define POS  8
+#define OK   0
+#define UNDEF 64
+
+#define linear(val1, val2, level)  ((level - val1) / (val2 - val1))
+
+/* Global variables */
+
+static PLFLT sh_max, sh_min;
+static int min_points, max_points, n_point;
+static int min_pts[4], max_pts[4];
+static PLINT pen_col_min, pen_col_max;
+static PLINT pen_wd_min, pen_wd_max;
+static PLFLT int_val;
+
+/* Function prototypes */
+
+static void 
+set_cond(register int *cond, register PLFLT *a, register PLINT n);
+
+static int 
+find_interval(PLFLT a0, PLFLT a1, PLINT c0, PLINT c1, PLFLT *x);
+
+static void 
+poly(void (*fill) (PLINT, PLFLT *, PLFLT *),
+     PLINT (*defined) (PLFLT, PLFLT),     
+     PLFLT *x, PLFLT *y, PLINT v1, PLINT v2, PLINT v3, PLINT v4);
+
+static void 
+exfill(void (*fill) (PLINT, PLFLT *, PLFLT *),
+       PLINT (*defined) (PLFLT, PLFLT),
+       int n, PLFLT *x, PLFLT *y);
+
+static void 
+big_recl(int *cond_code, register int ny, int dx, int dy,
+	 int *ix, int *iy);
+
+static void 
+draw_boundary(PLINT slope, PLFLT *x, PLFLT *y);
+
+static PLINT 
+plctest(PLFLT *x, PLFLT level);
+
+static PLINT 
+plctestez(PLFLT *a, PLINT nx, PLINT ny, PLINT ix,
+	  PLINT iy, PLFLT level);
+
+static void
+plshade_int(PLFLT (*f2eval) (PLINT, PLINT, PLPointer),
+	PLPointer f2eval_data,
+	PLFLT (*c2eval) (PLINT, PLINT, PLPointer),
+	PLPointer c2eval_data, 
+	PLINT (*defined) (PLFLT, PLFLT),
+	PLFLT missing_min, PLFLT missing_max,
+	PLINT nx, PLINT ny, 
+	PLFLT xmin, PLFLT xmax, PLFLT ymin, PLFLT ymax,
+	PLFLT shade_min, PLFLT shade_max,
+	PLINT sh_cmap, PLFLT sh_color, PLINT sh_width,
+	PLINT min_color, PLINT min_width,
+	PLINT max_color, PLINT max_width,
+	void (*fill) (PLINT, PLFLT *, PLFLT *), PLINT rectangular,
+	void (*pltr) (PLFLT, PLFLT, PLFLT *, PLFLT *, PLPointer),
+	PLPointer pltr_data);
+
+/*----------------------------------------------------------------------*\
+ * plshades()
+ *
+ * Shade regions via a series of calls to plshade.
+ * All arguments are the same as plshade except the following:
+ * clevel is a pointer to an array of values representing 
+ * the shade edge values, nlevel-1 is
+ * the number of different shades, (nlevel is the number of shade edges),
+ * fill_width is the pattern fill width, and cont_color and cont_width
+ * are the color and width of the contour drawn at each shade edge.
+ * (if cont_color <= 0 or cont_width <=0, no such contours are drawn).
+
+\*----------------------------------------------------------------------*/
+
+MZ_DLLEXPORT
+void c_plshades( PLFLT **a, PLINT nx, PLINT ny, PLINT (*defined) (PLFLT, PLFLT),
+		PLFLT xmin, PLFLT xmax, PLFLT ymin, PLFLT ymax,
+		PLFLT *clevel, PLINT nlevel, PLINT fill_width,
+		PLINT cont_color, PLINT cont_width,
+		void (*fill) (PLINT, PLFLT *, PLFLT *), PLINT rectangular,
+		void (*pltr) (PLFLT, PLFLT, PLFLT *, PLFLT *, PLPointer),
+		PLPointer pltr_data )
+{
+   PLFLT shade_min, shade_max, shade_color;
+   PLINT i, init_color, init_width;
+
+   for (i = 0; i < nlevel-1; i++) {
+      shade_min = clevel[i];
+      shade_max = clevel[i+1];
+      shade_color = i / (PLFLT) (nlevel-2);
+      /* The constants in order mean 
+       * (1) color map1,
+       * (0, 0, 0, 0) all edge effects will be done with plcont rather
+       * than the normal plshade drawing which gets partially blocked
+       * when sequential shading is done as in the present case */
+      
+      plshade(a, nx, ny, defined, xmin, xmax, ymin, ymax,
+	      shade_min, shade_max,
+	      1, shade_color, fill_width,
+	      0, 0, 0, 0,
+	      fill, rectangular, pltr, pltr_data);
+   }
+   if(cont_color > 0 && cont_width > 0) {
+      init_color = plsc->icol0;
+      init_width = plsc->width;
+      plcol0(cont_color);
+      plwid(cont_width);
+      plcont(a, nx, ny, 1, nx, 1, ny, clevel, nlevel, pltr, pltr_data);
+      plcol0(init_color);
+      plwid(init_width);
+   }
+}
+   
+/*----------------------------------------------------------------------*\
+ * plshade()
+ *
+ * Shade region.
+ * This interface to plfshade() assumes the 2d function array is passed
+ * via a (PLFLT **), and is column-dominant (normal C ordering).
+\*----------------------------------------------------------------------*/
+
+void c_plshade( PLFLT **a, PLINT nx, PLINT ny, PLINT (*defined) (PLFLT, PLFLT),
+                 PLFLT xmin, PLFLT xmax, PLFLT ymin, PLFLT ymax,
+                 PLFLT shade_min, PLFLT shade_max,
+                 PLINT sh_cmap, PLFLT sh_color, PLINT sh_width,
+                 PLINT min_color, PLINT min_width,
+                 PLINT max_color, PLINT max_width,
+                 void (*fill) (PLINT, PLFLT *, PLFLT *), PLINT rectangular,
+                 void (*pltr) (PLFLT, PLFLT, PLFLT *, PLFLT *, PLPointer),
+                 PLPointer pltr_data )
+{
+    PLfGrid2 grid;
+
+    grid.f = a;
+    grid.nx = nx;
+    grid.ny = ny;
+
+    plshade_int( plf2eval2, (PLPointer) &grid,
+                 NULL, NULL,
+/*	     plc2eval, (PLPointer) &cgrid,*/
+                 defined, MISSING_MIN_DEF, MISSING_MAX_DEF, nx, ny, xmin, 
+                 xmax, ymin, ymax, shade_min, shade_max,
+                 sh_cmap, sh_color, sh_width,
+                 min_color, min_width, max_color, max_width,
+                 fill, rectangular, pltr, pltr_data );
+}
+
+/*----------------------------------------------------------------------*\
+ * plshade1()
+ *
+ * Shade region.
+ * This interface to plfshade() assumes the 2d function array is passed
+ * via a (PLFLT *), and is column-dominant (normal C ordering).
+\*----------------------------------------------------------------------*/
+
+void c_plshade1( PLFLT *a, PLINT nx, PLINT ny, PLINT (*defined) (PLFLT, PLFLT),
+                 PLFLT xmin, PLFLT xmax, PLFLT ymin, PLFLT ymax,
+                 PLFLT shade_min, PLFLT shade_max,
+                 PLINT sh_cmap, PLFLT sh_color, PLINT sh_width,
+                 PLINT min_color, PLINT min_width,
+                 PLINT max_color, PLINT max_width,
+                 void (*fill) (PLINT, PLFLT *, PLFLT *), PLINT rectangular,
+                 void (*pltr) (PLFLT, PLFLT, PLFLT *, PLFLT *, PLPointer),
+                 PLPointer pltr_data )
+{
+    PLfGrid grid;
+
+    grid.f = a;
+    grid.nx = nx;
+    grid.ny = ny;
+
+    plshade_int( plf2eval, (PLPointer) &grid,
+                 NULL, NULL,
+/*	     plc2eval, (PLPointer) &cgrid,*/
+                 defined, MISSING_MIN_DEF, MISSING_MAX_DEF, nx, ny, xmin, 
+                 xmax, ymin, ymax, shade_min, shade_max,
+                 sh_cmap, sh_color, sh_width,
+                 min_color, min_width, max_color, max_width,
+                 fill, rectangular, pltr, pltr_data );
+}
+
+/*----------------------------------------------------------------------*\
+ * plfshade()
+ *
+ * Shade region.  
+ * Array values are determined by the input function and the passed data.
+\*----------------------------------------------------------------------*/
+
+void 
+plfshade(PLFLT (*f2eval) (PLINT, PLINT, PLPointer),
+	 PLPointer f2eval_data,
+	 PLFLT (*c2eval) (PLINT, PLINT, PLPointer),
+	 PLPointer c2eval_data,
+	 PLINT nx, PLINT ny, 
+	 PLFLT xmin, PLFLT xmax, PLFLT ymin, PLFLT ymax,
+	 PLFLT shade_min, PLFLT shade_max,
+	 PLINT sh_cmap, PLFLT sh_color, PLINT sh_width,
+	 PLINT min_color, PLINT min_width,
+	 PLINT max_color, PLINT max_width,
+	 void (*fill) (PLINT, PLFLT *, PLFLT *), PLINT rectangular,
+	 void (*pltr) (PLFLT, PLFLT, PLFLT *, PLFLT *, PLPointer),
+	 PLPointer pltr_data)
+{
+    plshade_int(f2eval,  f2eval_data, c2eval, c2eval_data, 
+	 NULL, MISSING_MIN_DEF, MISSING_MAX_DEF,
+	 nx, ny, xmin, xmax, ymin, ymax,
+	 shade_min, shade_max, sh_cmap, sh_color, sh_width,
+	 min_color, min_width, max_color, max_width,
+	 fill, rectangular, pltr, pltr_data);
+}
+
+
+/*----------------------------------------------------------------------*\
+ * plshade_int()
+ *
+ * Shade region -- this routine does all the work
+ *
+ * This routine is internal so the arguments can and will change.
+ * To retain some compatibility between versions, you must go through
+ * some stub routine!
+ *
+ * 4/95
+ *
+ * new: missing_min, missing_max
+ *
+ *     if data <= missing_max and data >= missing_min
+ *       then the data will beconsidered to be missing
+ *     this allows 2nd way to set undefined points (good for ftn)
+ *     if missing feature is not used, set missing_max < missing_min
+ *
+ * parameters:
+ *
+ * f2eval, f2eval_data:  data to plot
+ * c2eval, c2eval_data:  defined mask (not implimented)
+ * defined: defined mask (old API - implimented)
+ * missing_min, missing_max: yet another way to set data to undefined
+ * nx, ny: array dimensions
+ * xmin, xmax, ymin, ymax: grid coordinates
+ * shade_min, shade_max: shade region with values between ...
+ * sh_cmap, sh_color, sh_width: shading parameters, width is only for hatching
+ * min_color, min_width: line parameters for boundary (minimum)
+ * max_color, max_width: line parameters for boundary (maximum)
+ *     set min_width == 0 and max_width == 0 for no contours
+ * fill: fill function, set to NULL for no shading (contour plot)
+ * rectangular: flag set to 1 if pltr() maps rectangles to rectangles
+ *     this helps optimize the plotting
+ * pltr: function to map from grid to plot coordinates
+ *
+ *
+\*----------------------------------------------------------------------*/
+
+static void
+plshade_int(PLFLT (*f2eval) (PLINT, PLINT, PLPointer),
+	PLPointer f2eval_data,
+	PLFLT (*c2eval) (PLINT, PLINT, PLPointer),
+	PLPointer c2eval_data, 
+	PLINT (*defined) (PLFLT, PLFLT),
+	PLFLT missing_min, PLFLT missing_max,
+	PLINT nx, PLINT ny, 
+	PLFLT xmin, PLFLT xmax, PLFLT ymin, PLFLT ymax,
+	PLFLT shade_min, PLFLT shade_max,
+	PLINT sh_cmap, PLFLT sh_color, PLINT sh_width,
+	PLINT min_color, PLINT min_width,
+	PLINT max_color, PLINT max_width,
+	void (*fill) (PLINT, PLFLT *, PLFLT *), PLINT rectangular,
+	void (*pltr) (PLFLT, PLFLT, PLFLT *, PLFLT *, PLPointer),
+	PLPointer pltr_data)
+{
+
+    PLINT init_width, n, slope = 0, ix, iy;
+    int count, i, j, nxny;
+    PLFLT *a, *a0, *a1, dx, dy;
+    PLFLT x[8], y[8], xp[2], tx, ty;
+    int *c, *c0, *c1;
+
+    if (plsc->level < 3) {
+	plabort("plfshade: window must be set up first");
+	return;
+    }
+
+    if (nx <= 0 || ny <= 0) {
+	plabort("plfshade: nx and ny must be positive");
+	return;
+    }
+
+    if (shade_min >= shade_max) {
+	plabort("plfshade: shade_max must exceed shade_min");
+	return;
+    }
+
+    if (pltr == NULL || pltr_data == NULL)
+	rectangular = 1;
+
+    int_val = shade_max - shade_min;
+    init_width = plsc->width;
+
+    pen_col_min = min_color;
+    pen_col_max = max_color;
+
+    pen_wd_min = min_width;
+    pen_wd_max = max_width;
+
+    plstyl((PLINT) 0, NULL, NULL);
+    plwid(sh_width); 
+    if (fill != NULL) {
+        switch (sh_cmap) {
+        case 0:
+            plcol0((PLINT) sh_color);
+	    break;
+        case 1:
+	    plcol1(sh_color);
+	    break;
+        default:
+	    plabort("plfshade: invalid color map selection");
+	    return;
+        }
+    }
+    /* alloc space for value array, and initialize */
+    /* This is only a temporary kludge */
+    nxny = nx * ny;
+    if ((a = (PLFLT *) malloc(nxny * sizeof(PLFLT))) == NULL) {
+	plabort("plfshade: unable to allocate memory for value array");
+	return;
+    }
+
+    for (ix = 0; ix < nx; ix++) 
+	for (iy = 0; iy < ny; iy++) 
+	    a[iy + ix*ny] = f2eval(ix, iy, f2eval_data);
+
+    /* alloc space for condition codes */
+
+    if ((c = (int *) malloc(nxny * sizeof(int))) == NULL) {
+	plabort("plfshade: unable to allocate memory for condition codes");
+	free(a);
+	return;
+    }
+
+    sh_min = shade_min;
+    sh_max = shade_max;
+
+    set_cond(c, a, nxny);
+    dx = (xmax - xmin) / (nx - 1);
+    dy = (ymax - ymin) / (ny - 1);
+    a0 = a;
+    a1 = a + ny;
+    c0 = c;
+    c1 = c + ny;
+
+    for (ix = 0; ix < nx - 1; ix++) {
+
+	for (iy = 0; iy < ny - 1; iy++) {
+
+	    count = c0[iy] + c0[iy + 1] + c1[iy] + c1[iy + 1];
+
+	    /* No filling needs to be done for these cases */
+
+	    if (count >= UNDEF)
+		continue;
+	    if (count == 4 * POS)
+		continue;
+	    if (count == 4 * NEG)
+		continue;
+
+	    /* Entire rectangle can be filled */
+
+	    if (count == 4 * OK) {
+		/* find biggest rectangle that fits */
+		if (rectangular) {
+		    big_recl(c0 + iy, ny, nx - ix, ny - iy, &i, &j);
+		}
+		else {
+		    i = j = 1;
+		}
+		x[0] = x[1] = ix;
+		x[2] = x[3] = ix+i;
+		y[0] = y[3] = iy;
+		y[1] = y[2] = iy+j;
+
+		if (pltr && pltr_data) {
+		    for (i = 0; i < 4; i++) {
+			(*pltr) (x[i], y[i], &tx, &ty, pltr_data);
+			x[i] = tx;
+			y[i] = ty;
+		    }
+		}
+		else {
+		    for (i = 0; i < 4; i++) {
+			x[i] = xmin + x[i]*dx;
+			y[i] = ymin + y[i]*dy;
+		    }
+		}
+		if (fill != NULL)
+		    exfill (fill, defined, (PLINT) 4, x, y);
+		iy += j - 1;
+		continue;
+	    }
+
+	    /* Only part of rectangle can be filled */
+
+	    n_point = min_points = max_points = 0;
+	    n = find_interval(a0[iy], a0[iy + 1], c0[iy], c0[iy + 1], xp);
+	    for (j = 0; j < n; j++) {
+		x[j] = ix;
+		y[j] = iy + xp[j];
+	    }
+
+	    i = find_interval(a0[iy + 1], a1[iy + 1],
+			      c0[iy + 1], c1[iy + 1], xp);
+
+	    for (j = 0; j < i; j++) {
+		x[j + n] = ix + xp[j];
+		y[j + n] = iy + 1;
+	    }
+	    n += i;
+
+	    i = find_interval(a1[iy + 1], a1[iy], c1[iy + 1], c1[iy], xp);
+	    for (j = 0; j < i; j++) {
+		x[n + j] = ix + 1;
+		y[n + j] = iy + 1 - xp[j];
+	    }
+	    n += i;
+
+	    i = find_interval(a1[iy], a0[iy], c1[iy], c0[iy], xp);
+	    for (j = 0; j < i; j++) {
+		x[n + j] = ix + 1 - xp[j];
+		y[n + j] = iy;
+	    }
+	    n += i;
+
+	    if (pltr && pltr_data) {
+		for (i = 0; i < n; i++) {
+		    (*pltr) (x[i], y[i], &tx, &ty, pltr_data);
+		    x[i] = tx;
+		    y[i] = ty;
+		}
+	    }
+	    else {
+		for (i = 0; i < n; i++) {
+		    x[i] = xmin + x[i]*dx;
+		    y[i] = ymin + y[i]*dy;
+		}
+	    }
+
+	    if (min_points == 4)
+		slope = plctestez(a, nx, ny, ix, iy, shade_min);
+	    if (max_points == 4)
+		slope = plctestez(a, nx, ny, ix, iy, shade_max);
+
+	    /* n = number of end of line segments */
+	    /* min_points = number times shade_min meets edge */
+	    /* max_points = number times shade_max meets edge */
+
+	    /* special cases: check number of times a contour is in a box */
+
+	    switch ((min_points << 3) + max_points) {
+	      case 000:
+	      case 020:
+	      case 002:
+	      case 022:
+		if (fill != NULL && n > 0)
+		    exfill (fill, defined, n, x, y);
+		break;
+	      case 040:	/* 2 contour lines in box */
+	      case 004:
+		if (n != 6)
+		    fprintf(stderr, "plfshade err n=%d !6", (int) n);
+		if (slope == 1 && c0[iy] == OK) {
+		    if (fill != NULL)
+			exfill (fill, defined, n, x, y);
+		}
+		else if (slope == 1) {
+		    poly(fill, defined, x, y, 0, 1, 2, -1);
+		    poly(fill, defined, x, y, 3, 4, 5, -1);
+		}
+		else if (c0[iy + 1] == OK) {
+		    if (fill != NULL)
+			exfill (fill, defined, n, x, y);
+		}
+		else {
+		    poly(fill, defined, x, y, 0, 1, 5, -1);
+		    poly(fill, defined, x, y, 2, 3, 4, -1);
+		}
+		break;
+	      case 044:
+		if (n != 8)
+		    fprintf(stderr, "plfshade err n=%d !8", (int) n);
+		if (slope == 1) {
+		    poly(fill, defined, x, y, 0, 1, 2, 3);
+		    poly(fill, defined, x, y, 4, 5, 6, 7);
+		}
+		else {
+		    poly(fill, defined, x, y, 0, 1, 6, 7);
+		    poly(fill, defined, x, y, 2, 3, 4, 5);
+		}
+		break;
+	      case 024:
+	      case 042:
+		/* 3 contours */
+		if (n != 7)
+		    fprintf(stderr, "plfshade err n=%d !7", (int) n);
+
+		if ((c0[iy] == OK || c1[iy+1] == OK) && slope == 1) {
+		    if (fill != NULL)
+		        exfill (fill, defined, n, x, y);
+		}
+		else if ((c0[iy+1] == OK || c1[iy] == OK) && slope == 0) {
+		    if (fill !=NULL)
+		        exfill (fill, defined, n, x, y);
+		}
+
+		else if (c0[iy] == OK) {
+		    poly(fill, defined, x, y, 0, 1, 6, -1);
+		    poly(fill, defined, x, y, 2, 3, 4, 5);
+		}
+		else if (c0[iy+1] == OK) {
+		    poly(fill, defined, x, y, 0, 1, 2, -1);
+		    poly(fill, defined, x, y, 3, 4, 5, 6);
+		}
+		else if (c1[iy+1] == OK) {
+		    poly(fill, defined, x, y, 0, 1, 5, 6);
+		    poly(fill, defined, x, y, 2, 3, 4, -1);
+		}
+		else if (c1[iy] == OK) {
+		    poly(fill, defined, x, y, 0, 1, 2, 3);
+		    poly(fill, defined, x, y, 4, 5, 6, -1);
+		}
+		else {
+		    fprintf(stderr, "plfshade err logic case 024:042\n");
+		}
+		break;
+	      default:
+		fprintf(stderr, "prog err switch\n");
+		break;
+	    }
+	    draw_boundary(slope, x, y);
+
+	    if (fill != NULL) {
+	        plwid(sh_width);
+		if (sh_cmap == 0) plcol0((PLINT) sh_color);
+		else if (sh_cmap == 1) plcol1(sh_color);
+	    }
+	}
+
+	a0 = a1;
+	c0 = c1;
+	a1 += ny;
+	c1 += ny;
+    }
+
+    free(c);
+    free(a);
+    plwid(init_width);
+}
+
+/*----------------------------------------------------------------------*\
+ * set_cond()
+ *
+ * Fills out condition code array.
+\*----------------------------------------------------------------------*/
+
+static void 
+set_cond(register int *cond, register PLFLT *a, register PLINT n)
+{
+    while (n--) {
+        if (*a < sh_min)
+	    *cond++ = NEG;
+	else if (*a > sh_max)
+	    *cond++ = POS;
+	else
+	    *cond++ = OK;
+	a++;
+    }
+}
+
+/*----------------------------------------------------------------------*\
+ * find_interval()
+ *
+ * Two points x(0) = a0, (condition code c0) x(1) = a1, (condition code c1)
+ * return interval on the line that are shaded
+ * 
+ * returns 0 : no points to be shaded 1 : x[0] <= x < 1 is the interval 2 :
+ * x[0] <= x <= x[1] < 1 interval to be shaded n_point, max_points,
+ * min_points are incremented location of min/max_points are stored 
+\*----------------------------------------------------------------------*/
+
+static int 
+find_interval(PLFLT a0, PLFLT a1, PLINT c0, PLINT c1, PLFLT *x)
+{
+    register int n;
+
+    n = 0;
+    if (c0 == OK) {
+	x[n++] = 0.0;
+	n_point++;
+    }
+    if (c0 == c1)
+	return n;
+
+    if (c0 == NEG || c1 == POS) {
+	if (c0 == NEG) {
+	    x[n++] = linear(a0, a1, sh_min);
+	    min_pts[min_points++] = n_point++;
+	}
+	if (c1 == POS) {
+	    x[n++] = linear(a0, a1, sh_max);
+	    max_pts[max_points++] = n_point++;
+	}
+    }
+    if (c0 == POS || c1 == NEG) {
+	if (c0 == POS) {
+	    x[n++] = linear(a0, a1, sh_max);
+	    max_pts[max_points++] = n_point++;
+	}
+	if (c1 == NEG) {
+	    x[n++] = linear(a0, a1, sh_min);
+	    min_pts[min_points++] = n_point++;
+	}
+    }
+    return n;
+}
+
+/*----------------------------------------------------------------------*\
+ * poly()
+ *
+ * Draws a polygon from points in x[] and y[].
+ * Point selected by v1..v4 
+\*----------------------------------------------------------------------*/
+
+static void 
+poly(void (*fill) (PLINT, PLFLT *, PLFLT *),
+     PLINT (*defined) (PLFLT, PLFLT),
+     PLFLT *x, PLFLT *y, PLINT v1, PLINT v2, PLINT v3, PLINT v4)
+{
+    register PLINT n = 0;
+    PLFLT xx[4], yy[4];
+
+    if (fill == NULL)
+	return;
+    if (v1 >= 0) {
+	xx[n] = x[v1];
+	yy[n++] = y[v1];
+    }
+    if (v2 >= 0) {
+	xx[n] = x[v2];
+	yy[n++] = y[v2];
+    }
+    if (v3 >= 0) {
+	xx[n] = x[v3];
+	yy[n++] = y[v3];
+    }
+    if (v4 >= 0) {
+	xx[n] = x[v4];
+	yy[n++] = y[v4];
+    }
+    exfill (fill, defined, n, xx, yy);
+}
+
+/*----------------------------------------------------------------------*\
+ * bisect()
+ *
+ * Find boundary recursively by bisection.  
+ * (x1, y1) is in the defined region, while (x2, y2) in the undefined one.
+ * The result is returned in 
+\*----------------------------------------------------------------------*/
+
+static void 
+bisect(PLINT (*defined) (PLFLT, PLFLT), PLINT niter,
+       PLFLT x1, PLFLT y1, PLFLT x2, PLFLT y2, PLFLT* xb, PLFLT* yb)
+{
+    PLFLT xm;
+    PLFLT ym;
+
+    if (niter == 0) {
+        *xb = x1;
+        *yb = y1;
+        return;
+    }
+
+    xm = (x1 + x2) / 2;
+    ym = (y1 + y2) / 2;
+
+    if (defined (xm, ym))
+      bisect (defined, niter - 1, xm, ym, x2, y2, xb, yb);
+    else
+      bisect (defined, niter - 1, x1, y1, xm, ym, xb, yb);      
+}
+
+/*----------------------------------------------------------------------*\
+ * exfill()
+ *
+ * Draws a polygon from points in x[] and y[] by taking into account 
+ * eventual exclusions
+\*----------------------------------------------------------------------*/
+
+static void 
+exfill(void (*fill) (PLINT, PLFLT *, PLFLT *),
+       PLINT (*defined) (PLFLT, PLFLT),
+       int n, PLFLT *x, PLFLT *y)
+{
+    if (defined == NULL)
+
+        (*fill) (n, x, y);
+
+    else {
+        PLFLT xx[16];  
+	PLFLT yy[16];
+	PLFLT xb, yb;  
+	PLINT count = 0;
+	PLINT is_inside = defined (x[n-1], y[n-1]);
+	PLINT i;
+
+        for (i = 0; i < n; i++) {
+
+	    if (defined(x[i], y[i])) {
+	        if (!is_inside) {
+		    if (i > 0)
+		        bisect (defined, 10,
+				x[i], y[i], x[i-1], y[i-1], &xb, &yb);
+		    else
+		        bisect (defined, 10,
+				x[i], y[i], x[n-1], y[n-1], &xb, &yb);
+		    xx[count] = xb;
+		    yy[count++] = yb;
+		}
+		xx[count] = x[i];
+		yy[count++] = y[i];
+		is_inside = 1;
+	    }
+	    else {
+	        if (is_inside) {
+		    if (i > 0)
+		        bisect (defined, 10,
+				x[i-1], y[i-1], x[i], y[i], &xb, &yb);
+		    else
+		        bisect (defined, 10,
+				x[n-1], y[n-1], x[i], y[i], &xb, &yb);
+		    xx[count] = xb;
+		    yy[count++] = yb;
+		    is_inside = 0;
+		}
+	    }
+	}
+	
+	if (count)
+  	    (*fill) (count, xx, yy);
+    }
+}
+
+/*----------------------------------------------------------------------*\
+ * big_recl()
+ *
+ * find a big rectangle for shading
+ *
+ * 2 goals: minimize calls to (*fill)()
+ *  keep ratio 1:3 for biggest rectangle
+ *
+ * only called by plshade()
+ *
+ * assumed that a 1 x 1 square already fits
+ *
+ * c[] = condition codes
+ * ny = c[1][0] == c[ny]  (you know what I mean)
+ *
+ * returns ix, iy = length of rectangle in grid units
+ *
+ * ix < dx - 1
+ * iy < dy - 1
+ *
+ * If iy == 1 -> ix = 1 (so that cond code can be set to skip)
+\*----------------------------------------------------------------------*/
+
+#define RATIO 3
+#define COND(x,y) cond_code[x*ny + y]
+
+static void 
+big_recl(int *cond_code, register int ny, int dx, int dy,
+	 int *ix, int *iy)
+{
+
+    int ok_x, ok_y, j;
+    register int i, x, y;
+    register int *cond;
+
+    /* ok_x = ok to expand in x direction */
+    /* x = current number of points in x direction */
+
+    ok_x = ok_y = 1;
+    x = y = 2;
+
+    while (ok_x || ok_y) {
+#ifdef RATIO
+	if (RATIO * x <= y || RATIO * y <= x)
+	    break;
+#endif
+	if (ok_y) {
+	    /* expand in vertical */
+	    ok_y = 0;
+	    if (y == dy)
+		continue;
+	    cond = &COND(0, y);
+	    for (i = 0; i < x; i++) {
+		if (*cond != OK)
+		    break;
+		cond += ny;
+	    }
+	    if (i == x) {
+		/* row is ok */
+		y++;
+		ok_y = 1;
+	    }
+	}
+	if (ok_x) {
+	    if (y == 2)
+		break;
+	    /* expand in x direction */
+	    ok_x = 0;
+	    if (x == dx)
+		continue;
+	    cond = &COND(x, 0);
+	    for (i = 0; i < y; i++) {
+		if (*cond++ != OK)
+		    break;
+	    }
+	    if (i == y) {
+		/* column is OK */
+		x++;
+		ok_x = 1;
+	    }
+	}
+    }
+
+    /* found the largest rectangle of 'ix' by 'iy' */
+    *ix = --x;
+    *iy = --y;
+
+    /* set condition code to UNDEF in interior of rectangle */
+
+    for (i = 1; i < x; i++) {
+	cond = &COND(i, 1);
+	for (j = 1; j < y; j++) {
+	    *cond++ = UNDEF;
+	}
+    }
+}
+
+/*----------------------------------------------------------------------*\
+ * draw_boundary()
+ *
+ * Draw boundaries of contour regions based on min_pts[], and max_pts[].
+\*----------------------------------------------------------------------*/
+
+static void 
+draw_boundary(PLINT slope, PLFLT *x, PLFLT *y)
+{
+    int i;
+
+    if (pen_col_min != 0 && pen_wd_min != 0 && min_points != 0) {
+	plcol0(pen_col_min);
+	plwid(pen_wd_min);
+	if (min_points == 4 && slope == 0) {
+	    /* swap points 1 and 3 */
+	    i = min_pts[1];
+	    min_pts[1] = min_pts[3];
+	    min_pts[3] = i;
+	}
+	pljoin(x[min_pts[0]], y[min_pts[0]], x[min_pts[1]], y[min_pts[1]]);
+	if (min_points == 4) {
+	    pljoin(x[min_pts[2]], y[min_pts[2]], x[min_pts[3]],
+		   y[min_pts[3]]);
+	}
+    }
+    if (pen_col_max != 0 && pen_wd_max != 0 && max_points != 0) {
+	plcol0(pen_col_max);
+	plwid(pen_wd_max);
+	if (max_points == 4 && slope == 0) {
+	    /* swap points 1 and 3 */
+	    i = max_pts[1];
+	    max_pts[1] = max_pts[3];
+	    max_pts[3] = i;
+	}
+	pljoin(x[max_pts[0]], y[max_pts[0]], x[max_pts[1]], y[max_pts[1]]);
+	if (max_points == 4) {
+	    pljoin(x[max_pts[2]], y[max_pts[2]], x[max_pts[3]],
+		   y[max_pts[3]]);
+	}
+    }
+}
+
+/*----------------------------------------------------------------------*\
+ *
+ * plctest( &(x[0][0]), PLFLT level)
+ * where x was defined as PLFLT x[4][4];
+ *
+ * determines if the contours associated with level have
+ * positive slope or negative slope in the box:
+ *
+ *  (2,3)   (3,3)
+ *
+ *  (2,2)   (3,2)
+ *
+ * this is heuristic and can be changed by the user
+ *
+ * return 1 if positive slope
+ *        0 if negative slope
+ *
+ * algorithmn:
+ *      1st test:
+ *	find length of contours assuming positive and negative slopes
+ *      if the length of the negative slope contours is much bigger
+ *	than the positive slope, then the slope is positive.
+ *      (and vice versa)
+ *      (this test tries to minimize the length of contours)
+ *
+ *      2nd test:
+ *      if abs((top-right corner) - (bottom left corner)) >
+ *	   abs((top-left corner) - (bottom right corner)) ) then
+ *		return negatiave slope.
+ *      (this test tries to keep the slope for different contour levels
+ *	the same)
+\*----------------------------------------------------------------------*/
+
+#define X(a,b) (x[a*4+b])
+#define POSITIVE_SLOPE (PLINT) 1
+#define NEGATIVE_SLOPE (PLINT) 0
+#define RATIO_SQ 6.0
+
+static PLINT 
+plctest(PLFLT *x, PLFLT level)
+{
+    int i, j;
+    double t[4], sorted[4], temp;
+
+    sorted[0] = t[0] = X(1,1);
+    sorted[1] = t[1] = X(2,2);
+    sorted[2] = t[2] = X(1,2);
+    sorted[3] = t[3] = X(2,1);
+
+    for (j = 1; j < 4; j++) {
+	temp = sorted[j];
+	i = j - 1;
+	while (i >= 0 && sorted[i] > temp) {
+	    sorted[i+1] = sorted[i];
+	    i--;
+	}
+	sorted[i+1] = temp;
+    }
+    /* sorted[0] == min */
+
+    /* find min contour */
+    temp = int_val * ceil(sorted[0]/int_val);
+    if (temp < sorted[1]) {
+	/* one contour line */
+	for (i = 0; i < 4; i++) {
+	    if (t[i] < temp) return i/2;
+	}
+    }
+	
+    /* find max contour */
+    temp = int_val * floor(sorted[3]/int_val);
+    if (temp > sorted[2]) {
+	/* one contour line */
+	for (i = 0; i < 4; i++) {
+	    if (t[i] > temp) return i/2;
+	}
+    }
+    /* nothing better to do - be consistant */
+    return POSITIVE_SLOPE;
+}
+
+/*----------------------------------------------------------------------*\
+ * plctestez
+ *
+ * second routine - easier to use
+ * fills in x[4][4] and calls plctest
+ *
+ * test location a[ix][iy] (lower left corner)
+\*----------------------------------------------------------------------*/
+
+static PLINT 
+plctestez(PLFLT *a, PLINT nx, PLINT ny, PLINT ix,
+	  PLINT iy, PLFLT level)
+{
+
+    PLFLT x[4][4];
+    int i, j, ii, jj;
+
+    for (i = 0; i < 4; i++) {
+	ii = ix + i - 1;
+	ii = MAX(0, ii);
+	ii = MIN(ii, nx - 1);
+	for (j = 0; j < 4; j++) {
+	    jj = iy + j - 1;
+	    jj = MAX(0, jj);
+	    jj = MIN(jj, ny - 1);
+	    x[i][j] = a[ii * ny + jj];
+	}
+    }
+    return plctest(&(x[0][0]), level);
+}
diff --git a/collects/plot/src/all/plstripc.c b/collects/plot/src/all/plstripc.c
new file mode 100644
index 0000000000..5977ef4298
--- /dev/null
+++ b/collects/plot/src/all/plstripc.c
@@ -0,0 +1,318 @@
+/* $Id: plstripc.c,v 1.1 2004/03/01 20:54:53 cozmic Exp $
+
+ * Plots a simple stripchart.
+
+ * ToDo: better way of clearing plot. search for `plvsta'.
+ */
+
+#include "plplotP.h"
+
+/* Data declarations for stripcharts. */
+
+#define PEN	4
+
+typedef struct {
+    PLFLT xmin, xmax, ymin, ymax, xjump, xlen;
+    PLFLT wxmin, wxmax, wymin, wymax;	/* FIXME - some redundancy might exist */
+    char *xspec, *yspec, *labx, *laby, *labtop;
+    PLINT y_ascl, acc, colbox, collab;
+    PLFLT xlpos, ylpos;
+    PLFLT *x[PEN], *y[PEN];
+    PLINT npts[PEN], nptsmax[PEN];
+    PLINT colline[PEN], styline[PEN];
+    char *legline[PEN];
+} PLStrip;
+
+static int sid;				/* strip id number */
+#define MAX_STRIPC 1000			/* Max allowed */
+static PLStrip *strip[MAX_STRIPC];	/* Array of pointers */
+static PLStrip *stripc;			/* current strip chart */
+
+/* Generates a complete stripchart plot.  */
+
+static void
+plstrip_gen(PLStrip *strip);
+
+/* draw legend */
+
+static void
+plstrip_legend(PLStrip *strip, int flag);
+
+/*--------------------------------------------------------------------------*\
+ * plstripc
+ *
+ * Create 1d stripchart.
+\*--------------------------------------------------------------------------*/
+
+void
+c_plstripc( PLINT *id, char *xspec, char *yspec,
+            PLFLT xmin, PLFLT xmax, PLFLT xjump, PLFLT ymin, PLFLT ymax,
+            PLFLT xlpos, PLFLT ylpos,
+            PLINT y_ascl, PLINT acc,
+            PLINT colbox,  PLINT collab,
+            PLINT *colline,  PLINT *styline, char *legline[],
+            char *labx, char *laby, char *labtop )
+{
+    int i;
+
+    if (!plsc->termin) {
+	plabort("Stripchart plot requires a terminal output device");
+	return;
+    }
+
+/* Get a free strip id and allocate it */
+
+    for (i = 0; i < MAX_STRIPC; i++)
+	if (strip[i] == NULL)
+	    break;
+
+    if (i == MAX_STRIPC) {
+	plabort("plstripc: Cannot create new strip chart");
+	*id = -1;
+	return;
+    }
+    else {
+	sid = *id = i;
+	strip[sid] = (PLStrip *) calloc(1, (size_t) sizeof(PLStrip));
+	if (strip[sid] == NULL) {
+	    plabort("plstripc: Out of memory.");
+	    *id = -1;
+	    return;
+	}
+    }
+
+/* Fill up the struct with all relevant info */
+
+    stripc = strip[sid];
+
+    for (i=0; i<PEN; i++) {
+	stripc->npts[i] =  0;
+	stripc->nptsmax[i] =  100;
+	stripc->colline[i] = colline[i];
+	stripc->styline[i] = styline[i];
+	stripc->legline[i] = plstrdup(legline[i]);
+	stripc->x[i] = (PLFLT *) malloc((size_t) sizeof(PLFLT) * stripc->nptsmax[i]);;
+	stripc->y[i] = (PLFLT *) malloc((size_t) sizeof(PLFLT) * stripc->nptsmax[i]);;
+	if (stripc->x[i] == NULL || stripc->y[i] == NULL) {
+	    plabort("plstripc: Out of memory.");
+	    plstripd(sid);
+	    *id = -1;
+	    return;
+	}
+    }
+
+    stripc->xlpos = xlpos;	/* legend position [0..1] */
+    stripc->ylpos = ylpos;	
+    stripc->xmin = xmin;	/* initial bounding box */
+    stripc->xmax = xmax;
+    stripc->ymin = ymin;
+    stripc->ymax = ymax;
+    stripc->xjump = xjump;	/* jump x step(%) when x attains xmax (xmax is then set to xmax+xjump) */
+    stripc->xlen = xmax - xmin;	/* length of x scale */
+    stripc->y_ascl = y_ascl;	/* autoscale y between x jump scale */
+    stripc->acc = acc;		/* accumulate plot (not really stripchart) */
+    stripc->xspec = plstrdup(xspec); /* x axis specification */
+    stripc->yspec = plstrdup(yspec);
+    stripc->labx = plstrdup(labx); /* x label */
+    stripc->laby = plstrdup(laby);
+    stripc->labtop = plstrdup(labtop); /* title */
+    stripc->colbox = colbox;	/* box color */
+    stripc->collab = collab;	/* label color */
+
+/* Generate the plot */
+
+    plstrip_gen(stripc);
+    plstrip_legend(stripc,1);
+}
+
+static void plstrip_legend(PLStrip *stripc, int first)
+{
+    int i;
+    PLFLT sc, dy;
+
+/* draw legend */
+	
+    plgchr(&sc, &dy);
+    sc = dy = dy/100;
+    plwind(-0.01, 1.01, -0.01, 1.01);
+    for (i=0; i<PEN; i++) {
+	if (stripc->npts[i] || first) {
+	    plcol(stripc->colline[i]); pllsty(stripc->styline[i]);
+	    pljoin(stripc->xlpos, stripc->ylpos - sc, stripc->xlpos + 0.1, stripc->ylpos - sc);
+	    plcol(stripc->collab);
+	    plptex(stripc->xlpos + 0.11, stripc->ylpos - sc, 0., 0., 0, stripc->legline[i]);sc += dy;
+	}
+    }
+    plwind(stripc->xmin, stripc->xmax, stripc->ymin, stripc->ymax);
+    plflush();
+}
+
+/*--------------------------------------------------------------------------*\
+ * plstrip_gen
+ *
+ * Generates a complete stripchart plot.  Used either initially or
+ * during rescaling.
+\*--------------------------------------------------------------------------*/
+
+PLFLT oxm,oxM, oym,oyM;
+static void plstrip_gen( PLStrip *strip )
+{
+    int i;
+    PLFLT x[]={0.,1.,1.,0.}, y[]={0.,0.,1.,1.};
+
+/* Set up window */
+
+    plvpor(0,1,0,1);
+    plwind(0,1,0,1);
+    plcol(0);plpsty(0);
+    plfill(4, &x[0], &y[0]);
+    plvsta();
+
+/* Draw box and same window dimensions */
+    strip->wxmin=strip->xmin; strip->wxmax=strip->xmax;
+    strip->wymin=strip->ymin; strip->wymax=strip->ymax; /* FIXME - can exist some redundancy here */
+
+    plwind(strip->xmin, strip->xmax, strip->ymin, strip->ymax);
+    
+    pllsty(1);
+    plcol(strip->colbox);
+    plbox(strip->xspec, 0.0, 0, strip->yspec, 0.0, 0);
+
+    plcol(strip->collab);
+    pllab(strip->labx, strip->laby, strip->labtop);
+	 
+    for (i=0; i<PEN; i++) {
+        if (strip->npts[i] > 0) {
+            plcol(strip->colline[i]);pllsty(strip->styline[i]);
+            plline(strip->npts[i], strip->x[i], strip->y[i]);
+        }
+    }
+
+    plstrip_legend(strip,0);
+}
+
+/*--------------------------------------------------------------------------*\
+ * plstripa
+ *
+ * Add a point to a stripchart.  
+ * Allocates memory and rescales as necessary.
+\*--------------------------------------------------------------------------*/
+
+void c_plstripa( PLINT id, PLINT p, PLFLT x, PLFLT y )
+{
+    int j, yasc=0, istart;
+
+    if (p >= PEN) {
+    	plabort("Non existent pen");
+    	return;
+    }
+
+    if ((id < 0) || (id >= MAX_STRIPC) || 
+	((stripc = strip[id]) == NULL)) {
+    	plabort("Non existent stripchart");
+    	return;
+    }
+
+/* Add new point, allocating memory if necessary */
+
+    if (++stripc->npts[p] > stripc->nptsmax[p]) {
+	stripc->nptsmax[p] += 32;
+	stripc->x[p] = (PLFLT *) realloc((void *) stripc->x[p], sizeof(PLFLT)*stripc->nptsmax[p]);
+	stripc->y[p] = (PLFLT *) realloc((void *) stripc->y[p], sizeof(PLFLT)*stripc->nptsmax[p]);
+	if (stripc->x[p] == NULL || stripc->y[p] == NULL) {
+	    plabort("plstripc: Out of memory.");
+	    plstripd(id);
+	    return;
+	}
+    }
+    
+    stripc->x[p][stripc->npts[p]-1] = x;
+    stripc->y[p][stripc->npts[p]-1] = y;
+
+    stripc->xmax = x;
+	    
+    if (stripc->y_ascl == 1 && (y > stripc->ymax || y < stripc->ymin))
+	yasc=1;
+
+    if (y > stripc->ymax)
+	stripc->ymax = stripc->ymin + 1.1*(y - stripc->ymin);
+	if (y < stripc->ymin)
+	  stripc->ymin = stripc->ymax - 1.1*(stripc->ymax - y);
+
+/* Now either plot new point or regenerate plot */
+
+        if (stripc->xmax - stripc->xmin < stripc->xlen) {
+            if( yasc == 0) {
+
+            /* If user has changed subwindow, make shure we have the correct one */
+                plvsta();
+                plwind(stripc->wxmin, stripc->wxmax, stripc->wymin, stripc->wymax); /* FIXME - can exist some redundancy here */
+		plcol(stripc->colline[p]); pllsty(stripc->styline[p]);
+		if ((stripc->npts[p]-2) < 0)
+		  plP_movwor(stripc->x[p][stripc->npts[p]-1], stripc->y[p][stripc->npts[p]-1]);
+		else
+		  plP_movwor(stripc->x[p][stripc->npts[p]-2], stripc->y[p][stripc->npts[p]-2]);
+		plP_drawor(stripc->x[p][stripc->npts[p]-1], stripc->y[p][stripc->npts[p]-1]);
+		plflush();
+            }
+            else {
+		stripc->xmax = stripc->xmin + stripc->xlen;
+                plstrip_gen(stripc);
+	    }
+	}
+    else {
+/* Regenerating plot */
+	if (stripc->acc == 0) {
+	    for (j=0; j<PEN; j++) {
+		if (stripc->npts[j] > 0) {
+		    istart = 0;
+		    while (stripc->x[j][istart] < stripc->xmin + stripc->xlen*stripc->xjump)
+			istart++;
+			
+		    stripc->npts[j] = stripc->npts[j] - istart;
+		    memcpy( &stripc->x[j][0], &stripc->x[j][istart], (stripc->npts[j])*sizeof(PLFLT));
+		    memcpy( &stripc->y[j][0], &stripc->y[j][istart], (stripc->npts[j])*sizeof(PLFLT));
+		}
+	    }
+	} else
+	    stripc->xlen = stripc->xlen * (1 + stripc->xjump);
+
+	stripc->xmin = stripc->x[p][0];
+	stripc->xmax = stripc->xmax + stripc->xlen*stripc->xjump;
+
+	plstrip_gen(stripc);
+    }
+}
+
+/*--------------------------------------------------------------------------*\
+ * plstripd
+ *
+ * Deletes and releases memory used by a stripchart.  
+\*--------------------------------------------------------------------------*/
+
+void c_plstripd( PLINT id )
+{
+    int i;
+
+    if ((id < 0) || (id >= MAX_STRIPC) || 
+	((stripc = strip[id]) == NULL)) {
+    	plabort("Non existent stripchart");
+    	return;
+    }
+
+    for (i=0; i<PEN; i++) {
+    	if (stripc->npts[i]) {
+            free((void *) stripc->x[i]);
+            free((void *) stripc->y[i]);
+            free(stripc->legline[i]);
+        }
+    }
+
+    free(stripc->xspec);
+    free(stripc->yspec);
+    free(stripc->labx);
+    free(stripc->laby);
+    free(stripc->labtop);    
+    free((void *) stripc);
+    strip[id] = NULL;
+}
diff --git a/collects/plot/src/all/plstrm.h b/collects/plot/src/all/plstrm.h
new file mode 100644
index 0000000000..6ed6cbe302
--- /dev/null
+++ b/collects/plot/src/all/plstrm.h
@@ -0,0 +1,681 @@
+/* $Id: plstrm.h,v 1.1 2004/03/01 20:54:53 cozmic Exp $
+ *
+ *	Contains declarations for PLStream and PLDev structs.
+ *	Also prototypes for stream & device utility functions.
+*/
+
+#include "pdf.h"
+
+#ifndef __PLSTRM_H__
+#define __PLSTRM_H__
+
+#include "disptab.h"
+
+/*--------------------------------------------------------------------------*\
+ * Define the PLDev data structure.
+ *
+ * These are all quantities that must be saved on a per-device basis.
+ * Some drivers (xwin, tk) allocate structures defined internally.
+\*--------------------------------------------------------------------------*/
+
+typedef struct {
+    PLFLT pxlx, pxly;
+    PLINT xold, yold;
+
+    PLINT xmin, xmax, xlen;
+    PLINT ymin, ymax, ylen;
+
+    PLINT xmin_dev, xmax_dev, xlen_dev;
+    PLINT ymin_dev, ymax_dev, ylen_dev;
+
+    PLFLT xscale_dev, yscale_dev;
+} PLDev;
+
+/*--------------------------------------------------------------------------*\
+ * Define the PLStream data structure.
+ *
+ * This contains a copy of every variable that is stream dependent, which
+ * tends to be those which are settable by the user and persist for longer
+ * than one plot.
+ *
+ * Only those quantities listed in the PLStream struct will be preserved
+ * for an individual stream.  Note that the lack of every plplot constant
+ * means that one should only switch streams at a fairly high level, i.e.
+ * on the scale of an entire plot.  Otherwise intermediate quantities
+ * will be confused between the streams, possibly resulting in garbage plots.
+ * This structure may be expanded in time to improve intra-stream independence,
+ * but it is doubtful streams will ever be fully independent (perhaps
+ * neither necessary nor desirable? -- time will tell).
+ *
+ * There are undoubtably some inconsistencies in the declaration & use of
+ * the variables below.  This is a result of the continuing evolution of
+ * plplot and the numerous authors involved.  Hopefully in time the function
+ * of all variables can be fully documented and made more consistent.
+ *
+ * The quantities in each stream are as follows:
+ *
+ ***************************************************************************
+ *
+ * Misc control variables
+ *
+ * ipls		PLINT	Stream number
+ * level	PLINT	Initialization level
+ * program	char*	Program name
+ * verbose	PLINT	Be more verbose than usual
+ * debug	PLINT	Generate debugging output
+ * initialized	PLINT	Set if the stream has been initialized
+ * dev_initialized PLINT Set if the device driver has been loaded
+ *
+ ***************************************************************************
+ *
+ * Palettes (two of them)
+ *
+ * Color map 0 is intended for static objects, such as boxes, lines, points,
+ * labels, etc.  These should be allocated before calling plinit (else you
+ * get 16 by default, which can be undesirable on some platforms).  These
+ * are then explicitly selected by number (in order of allocation).  The
+ * lowest number is 0, but this is used for the background color, so all
+ * color drivers start with 1 as the default color.
+ *
+ * Color map 1 is for continuous-tone plots, where color is used to
+ * represent function value or intensity.  These are set in a relative way
+ * only, for increased portability and flexibility.  The actual number of
+ * colors used to represent intensity levels is determined by the driver.
+ * Note that it is only necessary to specify intensity (on a scale from 0
+ * to 1) to get an appropriate color.  Drivers incapable of fine shading
+ * will do the best job they can.
+ *
+ * A palette selection tool for both palettes is available for the Tk
+ * driver.  Direct writing of RGB values (i.e.  banging on the hardware) is
+ * supported but highly discouraged (colors so written will be affected
+ * unpredictably by the palette tools).
+ *
+ * icol0	PLINT	Color map 0 entry, current color (0 <= icol0 <= ncol0)
+ * ncol0	PLINT	Number of colors allocated in color map 0.
+ * icol1	PLINT	Color map 1 entry, current color (0 <= icol1 <= ncol1)
+ * ncol1	PLINT	Number of colors allocated in color map 1.
+ * ncol1cp	PLINT	Number of control points in cmap1 allocation (max PL_MAX_CMAP1CP)
+ * lcol1cp	PLFLT	Locations of control points in cmap1 [0,1]
+ * curcmap	PLINT	Current color map
+ * curcolor	RGB[]	Current color
+ * tmpcolor	RGB[]	Temporary color storage
+ * cmap0 	RGB[]	Color map 0: maximum of ncol0 RGB 8-bit values
+ * cmap1 	RGB[]	Color map 1: maximum of ncol1 RGB 8-bit values
+ *
+ ***************************************************************************
+ *
+ * Variables governing pen width
+ *
+ * width	Current pen width
+ * widthset	Set if pen width was specified
+ * widthlock	Set if pen width is locked
+ *
+ ***************************************************************************
+ *
+ * Variables used to pass information between the core and the driver
+ *
+ * It would be nice to use the "dev_" prefix uniformly but changing
+ * all that old code would be quite a lot of work..
+ *
+ * device	PLINT	Graphics device id number
+ * dev_minor	PLINT	Minor device id (for variations on one type)
+ * color	PLINT	Set if color is available
+ * colorset	PLINT	Set if "color" was set prior to calling plinit
+ * plbuf_read	PLINT	Set during a plot buffer redraw
+ * plbuf_write	PLINT	Set if driver needs to use the plot buffer
+ * dev_fill0	PLINT	Set if driver can do solid area fills
+ * dev_text	PLINT	Set if driver want to do it's only text drawing
+ * dev_fill1	PLINT	Set if driver can do pattern area fills
+ * dev_dash     PLINT   Set if driver can do dashed lines
+ * dev_di	PLINT	Set if driver wants to handle DI commands
+ * dev_flush	PLINT	Set if driver wants to handle flushes itself
+ * dev_swin	PLINT	Set if driver wants to handle 'set window' commands
+ * dev_fastimg  PLINT   Set if driver has fast image drawing capabilities
+ * dev_xor      PLINT   Set if driver supports xor mode.
+ * dev_clear    PLINT   Set if driver support clear.
+ * termin	PLINT	Set for interactive devices
+ * graphx	PLINT	Set if currently in graphics mode
+ * nopause	PLINT	Set if we are skipping the pause between frames
+ * family	PLINT	Set if familying is enabled
+ * member	PLINT	Number of current family member file open
+ * finc		PLINT	Number to increment between member files
+ * fflen	PLINT	Minimum field length to use in member file number
+ * bytemax	PLINT	Number of bytes maximum per member file
+ * famadv	PLINT	Set to advance to the next family member
+ * DevName	char*	Device name
+ * OutFile	FILE	Output file pointer
+ * BaseName	char*	Output base name (i.e. family)
+ * FileName	char*	Output file name
+ * output_type	int	0 for file, 1 for stream
+ * bytecnt	PLINT	Byte count for output stream
+ * page		PLINT	Page count for output stream
+ * linepos	PLINT	Line count for output stream
+ * pdfs		PDFstrm* PDF stream pointer
+ *
+ * These are used by the escape function (for area fill, etc).
+ *
+ * dev_npts	PLINT	Number of points we are plotting
+ * dev_x	short*	Pointer to array of x values
+ * dev_y	short*	Pointer to array of x values
+ *
+ * For images
+ * dev_nptsX	PLINT	Number of points we are plotting in X
+ * dev_nptsY	PLINT	Number of points we are plotting in Y
+ * dev_z	ushort*	Pointer to array of z values for the color
+ * dev_zmin,
+ * dev_zmax     ushort  Min and max values of z to plot
+ *
+ * The following pointer is for drivers that require device-specific
+ * data.  At initialization the driver should malloc the necessary
+ * space and set pls->dev to point to this area.  This way there can
+ * be multiple streams using the same driver without conflict.
+ *
+ * dev		void*	pointer to device-specific data (malloc'ed)
+ *
+ * User-supplied event handlers for use by interactive drivers (e.g. X).
+ * Can be used to take various actions depending on input.  Currently
+ * only a keyboard event handler is supported.
+ *
+ * KeyEH	void*	Keyboard event handler
+ * KeyEH_data	void*	Pointer to client data to pass
+ *
+ * ButtonEH	void*	(Mouse) Button event handler
+ * ButtonEH_data void*	Pointer to client data to pass
+ *
+ * bop_handler	void*	bop handler
+ * bop_data	void*	Pointer to client data to pass
+ *
+ * eop_handler	void*	eop handler
+ * eop_data	void*	Pointer to client data to pass
+ *
+ * Variables used for direct specification of device characteristics
+ * Not supported by all drivers (or even very many)
+ *
+ * xdpi..	PLFLT	Device DPI settings in x and y
+ * xlength..	PLINT	Device output lengths in x and y
+ * xoffset..	PLINT	Device offsets from upper left hand corner
+ * pageset	PLINT	Set if page dimensions were specified
+ * hack		PLINT	Enables driver-specific hack(s) if set
+ *
+ ***************************************************************************
+ *
+ * User customization tidy routine.  This is called before closing a stream
+ * to do any program specific cleanup.
+ *
+ * tidy		void*   pointer to cleanup routine
+ * tidy_data	void*   pointer to client data to pass
+ *
+ ****************************************************************************
+ *
+ * User error control variables.  Pass in a pointer for either to be set
+ * in exceptional conditions.  The caller is responsible for clearing the
+ * error code.
+ *
+ * errcode	PLINT*	pointer to variable to assign error code
+ * errmsg	char*	pointer to error message buffer (must be >= 160 bytes)
+ *
+ ****************************************************************************
+ *
+ * Stuff used by Xlib driver
+ *
+ * geometry	char*	Window geometry (malloc'ed)
+ * window_id	long	X-window window ID
+ * nopixmap	int	Set if you want to forbid allocation of pixmaps
+ * db		int	Set if you want to double buffer output
+ *			(only pixmap is drawn to directly; it is blitted
+ *			to output window on EOP or an Expose)
+ ***************************************************************************
+ *
+ * These are for support of the TK driver.
+ *
+ * server_name	char*	Main window name of server
+ * server_host	char*	Name of host to run server on
+ * server_port	char*	Port to talk to server on
+ * user		char*	Your user name on remote host (for remsh command)
+ * plserver	char*	Name of server
+ * plwindow	char*	Name of reference server window (malloc'ed)
+ * tcl_cmd	char*	TCL command(s) to eval on startup
+ * tk_file	char*   File for plserver use with its -file option
+ * auto_path	char*	Additional directories to autoload
+ * bufmax	int	Number of bytes sent before output buffer is flushed
+ * dp		int	Use Tcl-DP for communication, if set
+ * server_nokill int	Don't kill plserver on a ^C if set
+ *
+ ***************************************************************************
+ *
+ * Variables for use by the plot buffer
+ *
+ * plbufFile	FILE	Plot buffer file pointer
+ * plbufOwner	int	Typically set; only zero if current stream is cloned.
+ *
+ ***************************************************************************
+ *
+ * Driver interface (DI)
+ *
+ * difilt	PLINT	Driver interface filter flag
+ *
+ * dipxmin	PLFLT
+ * dipymin	PLFLT	Min, max relative plot coordinates
+ * dipxmax	PLFLT
+ * dipymax	PLFLT
+ * dipxax 	PLFLT	Plot window transformation:
+ * dipxb 	PLFLT	  x' = dipxax * x + dipxb
+ * dipyay 	PLFLT
+ * dipyb 	PLFLT	  y' = dipyay * y + dipyb
+ *
+ * aspdev	PLFLT	Original device aspect ratio
+ * aspect	PLFLT	Page aspect ratio
+ * aspori	PLFLT	Rotation-induced aspect ratio
+ * caspfactor	PLFLT	Factor applied to preserve character aspect ratio
+ * freeaspect	PLINT	Allow aspect ratio to adjust to orientation swaps
+ * 			when overall aspect ratio is changed.
+ * portrait	PLINT	Portrait mode (orientation and aspect ratio)
+ * mar		PLFLT	Page margin (minimum)
+ * jx		PLFLT	Page justification in x
+ * jy		PLFLT	Page justification in y
+ *
+ * didxax 	PLFLT	Device window transformation:
+ * didxb 	PLFLT	  x' = didxax * x + didxb
+ * didyay 	PLFLT
+ * didyb 	PLFLT	  y' = didyay * y + didyb
+ *
+ * diclpxmi	PLINT
+ * diclpxma	PLINT	Device clip limits
+ * diclpymi	PLINT
+ * diclpyma	PLINT
+ *
+ * diorot	PLFLT	Rotation angle (in units of pi/2)
+ * dioxax	PLFLT	Orientation transformation:
+ * dioxay	PLFLT	  x' = dioxax * x + dioxay * y + dioxb
+ * dioxb 	PLFLT
+ * dioyax	PLFLT	  y' = dioyax * x + dioyay * y + dioyb
+ * dioyay	PLFLT
+ * dioyb 	PLFLT
+ *
+ * dimxmin	PLFLT
+ * dimymin	PLFLT	Target coordinate system parameters.
+ * dimxmax	PLFLT
+ * dimymax	PLFLT
+ * dimxpmm	PLFLT
+ * dimypmm	PLFLT
+ * dimxax 	PLFLT	Map meta to physical coordinates:
+ * dimxb 	PLFLT	  x' = dimxax * x + dimxb
+ * dimyay 	PLFLT
+ * dimyb 	PLFLT	  y' = dimyay * y + dimyb
+ *
+ * page_status	PLINT	Flag to indicate current action
+ *
+ ***************************************************************************
+ *
+ * Fill pattern state information.
+ * patt < 0: Hardware fill, if available (not implemented yet)
+ * patt ==0: Hardware fill, if available, solid
+ * patt > 0: Software fill
+ *
+ * patt		Fill pattern number
+ * inclin	Array of inclinations in tenths of degree for fill lines
+ * delta	Array of spacings in micrometers between fill lines
+ * nps		Number of distinct line styles for fills
+ *
+ ***************************************************************************
+ *
+ * Variables used in line drawing
+ *
+ * currx	Physical x-coordinate of current point
+ * curry	Physical y-coordinate of current point
+ * mark		Array of mark lengths in micrometers for broken lines
+ * space	Array of space lengths in micrometers for broken lines
+ * nms		Number of elements for current broken line style
+ * timecnt	Timer for broken lines
+ * alarm	Alarm indicating change of broken line status
+ * pendn	Flag indicating if pen is up or down
+ * curel	Current element within broken line
+ *
+ ***************************************************************************
+ *
+ * Variables governing character strings
+ *
+ * esc		Text string escape character
+ *
+ ***************************************************************************
+ *
+ * Scale factors for characters, symbols, and tick marks.
+ *
+ * scale	Scaling factor for chr, sym, maj, min.
+ * chr...	Character default height and current (scaled) height
+ * sym...	Symbol    default height and current (scaled) height
+ * maj...	Major tick default height and current (scaled) height
+ * min...	Minor tick default height and current (scaled) height
+ *
+ ***************************************************************************
+ *
+ * Variables governing numeric axis label appearance
+ *
+ * setpre	Non-zero to set precision using "prec"
+ * precis	User-specified precision
+ * xdigmax..	Allowed #digits in axes labels
+ * xdigits..	Actual field widths (returned)
+ *
+ ***************************************************************************
+ *
+ * Variables governing physical coordinate system
+ *
+ * vpp..	Viewport boundaries in physical coordinates
+ * spp..	Subpage  boundaries in physical coordinates
+ * clp..	Clip     boundaries in physical coordinates
+ * phy...	Physical device limits in physical coordinates
+ * um.		Number of micrometers in a pixel
+ * pmm		Number of pixels to a millimeter
+ *
+ ***************************************************************************
+ *
+ * State variables for 3d plots
+ *
+ * base3.	World coordinate size of base for 3-d plot
+ * basec.	Position of centre of base for 3-d plot
+ * dom...	Minimum and maximum values for domain
+ * zzscl	Vertical (z) scale for 3-d plot
+ * ran..	Minimum and maximum z values for 3-d plot
+ * c..		Coordinate transformation from 3-d to 2-d
+ *
+ ***************************************************************************
+ *
+ * Variables for keeping track of world coordinate windows on a page.
+ *
+ * nCWindows	Number of coordinate windows on current page
+ * windows	Array of plCWindow's for current page
+ *
+ ***************************************************************************
+ *
+ * Variables governing subpages and viewports.
+ *
+ * nsub...	Number of subpages on physical device
+ * cursub	Current subpage
+ * spd...	Subpage  boundaries in normalized device coordinates
+ * vpd...	Viewport boundaries in normalized device coordinates
+ * vpw...	Viewport boundaries in world coordinates
+ *
+ ***************************************************************************
+ *
+ * Transformation variables
+ *
+ * wp....	Transformation variables for world  to physical conversion
+ * wm....	Transformation variables for world coordinates to mm
+ *
+ ****************************************************************************
+ *
+ * Other variables
+ *
+ * dev_compression Compression level for supporting devices
+ *
+ ****************************************************************************
+ *
+ * Font related variables
+ *
+ * cfont           Current font number, replaces global 'font' in plsym.c
+ *                 This can be latter extended for font shape, series, family and size
+ *
+\*--------------------------------------------------------------------------*/
+
+#define PL_MAX_CMAP1CP 256
+
+typedef struct {
+
+/* Misc control information */
+
+    PLINT ipls, level, verbose, debug, initialized, dev_initialized;
+    char *program;
+
+/* Colormaps */
+
+    PLINT icol0, ncol0, icol1, ncol1, ncp1, curcmap;
+
+    PLColor curcolor, tmpcolor;
+    PLColor *cmap0;
+    PLColor *cmap1;
+
+    PLControlPt cmap1cp[PL_MAX_CMAP1CP];
+
+/* Variables governing pen width */
+
+    PLINT width;
+    PLINT widthset, widthlock;
+
+/* Driver dispatch table, obsoletes "device" member below. */
+
+    PLDispatchTable *dispatch_table;
+
+/* Variables used for interacting with or by device driver */
+
+    PLINT plbuf_read, plbuf_write;
+    PLINT device, dev_minor, termin, graphx, nopause;
+    PLINT color, colorset;
+    PLINT family, member, finc, fflen, bytemax, famadv;
+    PLINT dev_fill0, dev_fill1, dev_dash, dev_di, dev_flush, dev_swin;
+    PLINT dev_text, dev_xor, dev_clear, dev_fastimg;
+
+    char DevName[80];
+    FILE *OutFile;
+    char *BaseName, *FileName;
+    int  output_type;
+    PLINT bytecnt, page, linepos;
+    PDFstrm *pdfs;
+
+    PLINT dev_npts;
+    short *dev_x, *dev_y;
+
+  /* variables for plimage() */
+
+    PLINT dev_nptsX, dev_nptsY;
+    short *dev_ix, *dev_iy;
+    unsigned short *dev_z;
+    unsigned short dev_zmin, dev_zmax;
+    PLINT imclxmin, imclxmax, imclymin, imclymax;
+
+  /* end of variables for plimage() */
+
+    void *dev;
+
+    void (*KeyEH)	(PLGraphicsIn *gin, void *KeyEH_data,
+			 int *exit_eventloop);
+    void *KeyEH_data;
+
+    void (*ButtonEH)	(PLGraphicsIn *gin, void *ButtonEH_data,
+			 int *exit_eventloop);
+    void *ButtonEH_data;
+
+    void (*LocateEH)	(PLGraphicsIn *gin, void *LocateEH_data,
+			 int *locate_mode);
+    void *LocateEH_data;
+
+    void (*bop_handler)	(void *bop_data, int *skip_driver_bop);
+    void *bop_data;
+
+    void (*eop_handler)	(void *eop_data, int *skip_driver_eop);
+    void *eop_data;
+
+    PLFLT xdpi, ydpi;
+    PLINT xlength, ylength;
+    PLINT xoffset, yoffset;
+    PLINT pageset, hack;
+
+/* Per stream tidy function. */
+
+    void (*tidy)    (void *);
+    void *tidy_data;
+
+/* Error info */
+
+    PLINT *errcode;
+    char *errmsg;
+
+/* Stuff used by Xlib driver */
+
+    char *geometry;
+    long window_id;
+    int  nopixmap, db;
+
+/* Stuff used by TK, DP drivers */
+
+    char *server_name, *server_host, *server_port, *user;
+    char *plserver, *plwindow;
+    char *tcl_cmd, *auto_path;
+    char *tk_file;  /* plserver -file option */
+    int  bufmax, dp, server_nokill;
+
+/* Plot buffer settings */
+
+    FILE *plbufFile;
+    int  plbufOwner;
+
+/* Driver interface (DI) */
+
+    PLINT difilt, diclpxmi, diclpxma, diclpymi, diclpyma;
+    PLFLT dipxmin, dipymin, dipxmax, dipymax;
+    PLFLT dipxax, dipxb, dipyay, dipyb;
+    PLFLT aspdev, aspect, aspori, caspfactor, mar, jx, jy;
+    PLFLT didxax, didxb, didyay, didyb;
+    PLFLT diorot;
+    PLFLT dioxax, dioxay, dioxb, dioyax, dioyay, dioyb;
+    PLFLT dimxax, dimxb, dimyay, dimyb;
+    PLFLT dimxmin, dimymin, dimxmax, dimymax, dimxpmm, dimypmm;
+    PLINT page_status, freeaspect, portrait;
+
+/* Fill pattern info */
+
+    PLINT patt, inclin[2], delta[2], nps;
+
+/* Variables used in line drawing */
+
+    PLINT currx, curry;
+    PLINT mark[10], space[10], nms;
+    PLINT timecnt, alarm, pendn, curel;
+
+/* Variables governing character strings */
+
+    char  esc;
+
+/* Scale factors for characters, symbols, and tick marks. */
+
+    PLFLT scale;
+    PLFLT chrdef, chrht;
+    PLFLT symdef, symht;
+    PLFLT majdef, majht;
+    PLFLT mindef, minht;
+
+/* Variables governing numeric axis label appearance */
+
+    PLINT setpre, precis;
+    PLINT xdigmax, ydigmax, zdigmax;
+    PLINT xdigits, ydigits, zdigits;
+
+/* Variables governing physical coordinate system */
+
+    PLINT vppxmi, vppxma, vppymi, vppyma;
+    PLINT sppxmi, sppxma, sppymi, sppyma;
+    PLINT clpxmi, clpxma, clpymi, clpyma;
+    PLINT phyxmi, phyxma, phyxlen, phyymi, phyyma, phyylen;
+    PLINT umx, umy;
+    PLFLT xpmm, ypmm;
+
+/* State variables for 3d plots */
+
+    PLFLT base3x, base3y, basecx, basecy;
+    PLFLT domxmi, domxma, domymi, domyma;
+    PLFLT zzscl, ranmi, ranma;
+    PLFLT cxx, cxy, cyx, cyy, cyz;
+
+/* Variables for keeping track of windows on a page. */
+
+    int nplwin;
+    PLWindow plwin[PL_MAXWINDOWS];
+
+/* Variables governing subpages and viewports. */
+
+    PLINT nsubx, nsuby, cursub;
+    PLFLT spdxmi, spdxma, spdymi, spdyma;
+    PLFLT vpdxmi, vpdxma, vpdymi, vpdyma;
+    PLFLT vpwxmi, vpwxma, vpwymi, vpwyma;
+
+/* Transformation variables */
+
+    PLFLT wpxscl, wpxoff, wpyscl, wpyoff;
+    PLFLT wmxscl, wmxoff, wmyscl, wmyoff;
+    PLFLT wdxscl, wdxoff, wdyscl, wdyoff;
+
+/* Other variables */
+
+  PLINT dev_compression;
+  PLINT cfont;
+  
+  void *FT;
+
+/* Stuff used by the Tkwin driver for Plframe */
+  struct PlPlotter *plPlotterPtr;
+
+} PLStream;
+
+/*--------------------------------------------------------------------------*\
+ * Prototypes for stream & device utility functions.
+\*--------------------------------------------------------------------------*/
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+/* Get the current stream pointer */
+
+void
+plgpls(PLStream **p_pls);
+
+/* Initializes device cmap 1 entry by interpolation from pls->cmap1 entries */
+
+void
+plcol_interp(PLStream *pls, PLColor *newcolor, int i, int ncol);
+
+/* Opens file for output, prompting if not set. */
+
+void
+plOpenFile(PLStream *pls);
+
+/* Sets up next file member name (in pls->FileName), but does not open it. */
+
+void
+plP_getmember(PLStream *pls);
+
+/* Sets up file name & family stem name. */
+
+void
+plP_sfnam(PLStream *pls, const char *fnam);
+
+/* Initializes family file parameters. */
+
+void
+plFamInit(PLStream *pls);
+
+/* Starts new member file of family file set if necessary. */
+
+void
+plGetFam(PLStream *pls);
+
+/* Rotates physical coordinates if necessary for given orientation. */
+
+void
+plRotPhy(PLINT orient, PLINT xmin, PLINT ymin, PLINT xmax, PLINT ymax,
+	 int *px, int *py);
+
+/* Allocates a standard PLDev structure for device-specific data */
+
+PLDev *
+plAllocDev(PLStream *pls);
+
+/* Just fills in the PLGraphicsIn with appropriate initial values. */
+
+void
+plGinInit(PLGraphicsIn *gin);
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif	/* __PLSTRM_H__ */
diff --git a/collects/plot/src/all/plsym.c b/collects/plot/src/all/plsym.c
new file mode 100644
index 0000000000..4cc195e785
--- /dev/null
+++ b/collects/plot/src/all/plsym.c
@@ -0,0 +1,1081 @@
+/* $Id: plsym.c,v 1.2 2005/03/17 21:39:21 eli Exp $
+
+	Point, symbol, and string plotting routines.
+	Also font management code.  See the description of plLibOpen() for
+	the search path used in finding the font files.
+*/
+
+#define NEED_PLDEBUG
+#include "plplotP.h"
+#include <float.h>
+#include <ctype.h>
+
+/* Declarations */
+
+static short int *fntlkup;
+static short int *fntindx;
+static signed char *fntbffr;
+static short int numberfonts, numberchars;
+static short int indxleng;
+
+static short fontloaded = 0;
+/* moved to plstr.h, plsc->cfont  static PLINT font = 1;  current font */
+
+#define PLMAXSTR	300
+#define STLEN		250
+
+static char font_types[] = "nris";
+static char greek[] = "ABGDEZYHIKLMNCOPRSTUFXQWabgdezyhiklmncoprstufxqw";
+
+static short symbol_buffer[PLMAXSTR];
+static signed char xygrid[STLEN];
+
+/* Static function prototypes */
+
+static void
+pldeco(short int **sym, PLINT *length, const char *text);
+
+static void
+plchar(signed char *xygrid, PLFLT *xform, PLINT base, PLINT oline, PLINT uline,
+       PLINT refx, PLINT refy, PLFLT scale, PLFLT xpmm, PLFLT ypmm,
+       PLFLT *p_xorg, PLFLT *p_yorg, PLFLT *p_width);
+
+static PLINT
+plcvec(PLINT ch, signed char **xygr);
+
+static void
+plhrsh(PLINT ch, PLINT x, PLINT y);
+
+/*--------------------------------------------------------------------------*\
+ * void plsym()
+ *
+ * Plots array y against x for n points using Hershey symbol "code".
+\*--------------------------------------------------------------------------*/
+
+void
+c_plsym(PLINT n, PLFLT *x, PLFLT *y, PLINT code)
+{
+    PLINT i;
+
+    if (plsc->level < 3) {
+	plabort("plsym: Please set up window first");
+	return;
+    }
+    if (code < 0) {
+	plabort("plsym: Invalid code");
+	return;
+    }
+
+    for (i = 0; i < n; i++)
+	plhrsh(code, plP_wcpcx(x[i]), plP_wcpcy(y[i]));
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plpoin()
+ *
+ * Plots array y against x for n points using ASCII code "code".
+ *
+ * code=-1 means try to just draw a point.  Right now it's just a move and
+ * a draw at the same place.  Not ideal, since a sufficiently intelligent
+ * output device may optimize it away, or there may be faster ways of
+ * doing it.  This is OK for now, though, and offers a 4X speedup over
+ * drawing a Hershey font "point" (which is actually diamond shaped and
+ * therefore takes 4 strokes to draw).
+\*--------------------------------------------------------------------------*/
+
+MZ_DLLEXPORT
+void
+c_plpoin(PLINT n, PLFLT *x, PLFLT *y, PLINT code)
+{
+    PLINT i, sym, ifont = plsc->cfont;
+
+    if (plsc->level < 3) {
+	plabort("plpoin: Please set up window first");
+	return;
+    }
+    if (code < -1 || code > 127) {
+	plabort("plpoin: Invalid code");
+	return;
+    }
+
+    if (code == -1) {
+	for (i = 0; i < n; i++)
+	    pljoin(x[i], y[i], x[i], y[i]);
+    }
+    else {
+        if (ifont > numberfonts)
+	    ifont = 1;
+	sym = *(fntlkup + (ifont - 1) * numberchars + code);
+
+	for (i = 0; i < n; i++)
+	    plhrsh(sym, plP_wcpcx(x[i]), plP_wcpcy(y[i]));
+    }
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plpoin3(n, x, y, z, code)
+ *
+ * Draws a series of points in 3 space.  Setup similar to plline3().
+\*--------------------------------------------------------------------------*/
+
+void
+c_plpoin3(PLINT n, PLFLT *x, PLFLT *y, PLFLT *z, PLINT code)
+{
+    PLINT i, sym, ifont = plsc->cfont;
+    PLFLT u, v;
+    PLFLT xmin, xmax, ymin, ymax, zmin, zmax, zscale;
+
+    if (plsc->level < 3) {
+	plabort("plpoin3: Please set up window first");
+	return;
+    }
+    if (code < -1 || code > 127) {
+	plabort("plpoin3: Invalid code");
+	return;
+    }
+
+    plP_gdom(&xmin, &xmax, &ymin, &ymax);
+    plP_grange(&zscale, &zmin, &zmax);
+
+    if (code == -1) {
+	for (i = 0; i < n; i++) {
+ 	  if(x[i] >= xmin && x[i] <= xmax &&
+ 	     y[i] >= ymin && y[i] <= ymax &&
+	     z[i] >= zmin && z[i] <= zmax) {
+	    u = plP_wcpcx(plP_w3wcx( x[i], y[i], z[i] ));
+	    v = plP_wcpcy(plP_w3wcy( x[i], y[i], z[i] ));
+	    plP_movphy(u,v);
+	    plP_draphy(u,v);
+	  }
+	}
+    }
+    else {
+        if (ifont > numberfonts)
+	    ifont = 1;
+	sym = *(fntlkup + (ifont - 1) * numberchars + code);
+
+	for( i=0; i < n; i++ ) {
+ 	  if(x[i] >= xmin && x[i] <= xmax &&
+ 	     y[i] >= ymin && y[i] <= ymax &&
+	     z[i] >= zmin && z[i] <= zmax) {
+	    u = plP_wcpcx(plP_w3wcx( x[i], y[i], z[i] ));
+	    v = plP_wcpcy(plP_w3wcy( x[i], y[i], z[i] ));
+	    plhrsh(sym, u, v);
+	  }
+	}
+    }
+    return;
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plhrsh()
+ *
+ * Writes the Hershey symbol "ch" centred at the physical coordinate (x,y).
+\*--------------------------------------------------------------------------*/
+
+static void
+plhrsh(PLINT ch, PLINT x, PLINT y)
+{
+    PLINT cx, cy, k, penup, style;
+    signed char *vxygrid = 0;
+    PLFLT scale, xscale, yscale;
+    PLINT llx[STLEN], lly[STLEN], l = 0;
+
+    penup = 1;
+    scale = 0.05 * plsc->symht;
+
+    if ( ! plcvec(ch, &vxygrid)) {
+	plP_movphy(x, y);
+	return;
+    }
+
+/* Line style must be continuous */
+
+    style = plsc->nms;
+    plsc->nms = 0;
+
+/* Compute how many physical pixels correspond to a character pixel */
+
+    xscale = scale * plsc->xpmm;
+    yscale = scale * plsc->ypmm;
+
+    k = 4;
+    for (;;) {
+	cx = vxygrid[k++];
+	cy = vxygrid[k++];
+	if (cx == 64 && cy == 64) {
+	  if (l) {
+	    plP_draphy_poly(llx, lly, l);
+	    l = 0;
+	  }
+	  plP_movphy(x, y);
+	  plsc->nms = style;
+	  return;
+	}
+	else if (cx == 64 && cy == 0)
+	    penup = 1;
+	else {
+	    if (penup == 1) {
+             if (l) {
+	       plP_draphy_poly(llx, lly, l);
+	       l = 0;
+	     }
+             llx[l] = ROUND(x+ xscale * cx);
+	     lly[l++] = ROUND(y + yscale * cy);
+             plP_movphy(llx[l-1], lly[l-1]);
+	     penup = 0;
+	    }
+	    else {
+	      llx[l] = ROUND(x+ xscale * cx);
+	      lly[l++] = ROUND(y + yscale * cy);
+	    }
+	}
+    }
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plarrows()
+ *
+ * simple arrow plotter
+ * copyright 1993 Wesley Ebisuzaki
+ *
+ * an arrow is defined by its location (x, y) and its direction (u, v)
+ *
+ * inputs:
+ *   u[i], v[i]      arrow's horizontal and vertical projection
+ *   x[i], y[i]      arrow's location (world coordinates)
+ *   n               number of arrows to draw
+ *   scale           > 0  scaling factor for arrows
+ *                   0    default scaling factor
+ *                   < 0  default scaling factor * (-scale)
+ *   dx, dy          distance between arrows
+ *                   used when calculating the default arrow scaling
+ *                   so that arrows don't overlap
+ *
+\*--------------------------------------------------------------------------*/
+
+#define SCALE0 2.0
+
+/* definition of original arrow: 2 line segments */
+
+static PLFLT arrow_x[4] = {0.5, -0.5, -0.27, -0.5};
+static PLFLT arrow_y[4] = {0.0, 0.0, 0.0, 0.20};
+
+void 
+plarrows(PLFLT *u, PLFLT *v, PLFLT *x, PLFLT *y, PLINT n,
+	 PLFLT scale, PLFLT dx, PLFLT dy) 
+{
+    PLFLT uu, vv;
+    PLINT i, j;
+    PLINT px0, py0, dpx, dpy;
+    PLINT a_x[4], a_y[4];
+    PLFLT max_u, max_v;
+    double t;
+
+    if (n <= 0) return;
+
+    if (scale <= 0.0) {
+
+    /* automatic scaling */
+    /* find max / min values of data */
+
+	max_u = u[0];
+	max_v = v[0];
+	for (i = 1; i < n; i++) {
+	    t = fabs((double) u[i]);
+	    max_u = t > max_u ? t : max_u;
+	    t = fabs((double) v[i]);
+	    max_v = t > max_v ? t : max_v;
+	}
+
+    /* measure distance in grid boxs */
+
+	max_u = max_u / fabs( (double) dx);
+	max_v = max_v / fabs( (double) dy);
+
+	t = (max_u > max_v ? max_u : max_v);
+	t = SCALE0 / t;
+	if (scale < 0) {
+	    scale = -scale * t;
+	}
+	else {
+	    scale = t;
+	}
+    }
+    pldebug("plarrows", "scale factor=%lf n=%d\n", scale,n);
+
+    for (i = 0; i < n; i++) {
+	uu = scale * u[i];
+	vv = scale * v[i];
+	if (uu == 0.0 && uu == 0.0) continue;
+
+    /* conversion to physical coordinates */
+
+	px0 = plP_wcpcx(x[i]);
+	py0 = plP_wcpcy(y[i]);
+
+	pldebug("plarrows", "%f %f %d %d\n",x[i],y[i],px0,py0);
+
+	dpx = plP_wcpcx(x[i] + 0.5*uu) - px0;
+	dpy = plP_wcpcy(y[i] + 0.5*vv) - py0;
+
+    /* transform arrow -> a */
+
+	for (j = 0; j < 4; j++) {
+	    a_x[j] = arrow_x[j] * dpx -
+		arrow_y[j] * dpy + px0;
+	    a_y[j] = arrow_x[j] * dpy +
+		arrow_y[j] * dpx + py0;
+	}
+
+    /* draw the arrow */
+
+	plP_movphy(a_x[0], a_y[0]);
+	plP_draphy(a_x[1], a_y[1]);
+	plP_movphy(a_x[2], a_y[2]);
+	plP_draphy(a_x[3], a_y[3]);
+    }
+}
+
+/*--------------------------------------------------------------------------*\
+ * void pllab()
+ *
+ * Simple routine for labelling graphs.
+\*--------------------------------------------------------------------------*/
+
+MZ_DLLEXPORT
+void
+c_pllab(const char *xlabel, const char *ylabel, const char *tlabel)
+{
+    if (plsc->level < 2) {
+	plabort("pllab: Please set up viewport first");
+	return;
+    }
+
+    plmtex("t", (PLFLT) 2.0, (PLFLT) 0.5, (PLFLT) 0.5, tlabel);
+    plmtex("b", (PLFLT) 3.2, (PLFLT) 0.5, (PLFLT) 0.5, xlabel);
+    plmtex("l", (PLFLT) 5.0, (PLFLT) 0.5, (PLFLT) 0.5, ylabel);
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plmtex()
+ *
+ * Prints out "text" at specified position relative to viewport
+ * (may be inside or outside)
+ *
+ * side	String which is one of the following:
+ *	B or b  :  Bottom of viewport
+ *	T or t  :  Top of viewport
+ *	BV or bv : Bottom of viewport, vertical text
+ *	TV or tv : Top of viewport, vertical text
+ *	L or l  :  Left of viewport
+ *	R or r  :  Right of viewport
+ *	LV or lv : Left of viewport, vertical text
+ *	RV or rv : Right of viewport, vertical text
+ *
+ * disp Displacement from specified edge of viewport, measured outwards from
+ *	the viewport in units of the current character height. The
+ *	centerlines of the characters are aligned with the specified
+ *	position.
+ *
+ * pos	Position of the reference point of the string relative to the
+ *	viewport edge, ranging from 0.0 (left-hand edge) to 1.0 (right-hand
+ *	edge)
+ *
+ * just	Justification of string relative to reference point
+ *	just = 0.0 => left hand edge of string is at reference
+ *	just = 1.0 => right hand edge of string is at reference
+ *	just = 0.5 => center of string is at reference
+\*--------------------------------------------------------------------------*/
+
+void
+c_plmtex(const char *side, PLFLT disp, PLFLT pos, PLFLT just,
+	 const char *text)
+{
+    PLINT clpxmi, clpxma, clpymi, clpyma;
+    PLINT vert, refx, refy, x, y;
+    PLFLT xdv, ydv, xmm, ymm, refxmm, refymm, shift, xform[4];
+    PLFLT chrdef, chrht;
+    PLFLT dispx, dispy;
+
+    if (plsc->level < 2) {
+	plabort("plmtex: Please set up viewport first");
+	return;
+    }
+
+/* Open clip limits to subpage limits */
+
+    plP_gclp(&clpxmi, &clpxma, &clpymi, &clpyma); /* get and store current clip limits */
+    plP_sclp(plsc->sppxmi, plsc->sppxma, plsc->sppymi, plsc->sppyma);
+
+    if (plP_stindex(side, "BV") != -1 || plP_stindex(side, "bv") != -1) {
+	vert = 1;
+	xdv  = plsc->vpdxmi + (plsc->vpdxma - plsc->vpdxmi) * pos;
+	ydv  = plsc->vpdymi;
+	dispx = 0;
+	dispy = -disp;
+    }
+    else if (plP_stindex(side, "TV") != -1 || plP_stindex(side, "tv") != -1) {
+	vert = 1;
+	xdv  = plsc->vpdxmi + (plsc->vpdxma - plsc->vpdxmi) * pos;
+	ydv  = plsc->vpdyma;
+	dispx = 0;
+	dispy = disp;
+    }
+    else if (plP_stsearch(side, 'b')) {
+	vert = 0;
+	xdv = plsc->vpdxmi + (plsc->vpdxma - plsc->vpdxmi) * pos;
+	ydv = plsc->vpdymi;
+	dispx = 0;
+	dispy = -disp;
+
+    } else if (plP_stsearch(side, 't')) {
+	vert = 0;
+	xdv = plsc->vpdxmi + (plsc->vpdxma - plsc->vpdxmi) * pos;
+	ydv = plsc->vpdyma;
+	dispx = 0;
+	dispy = disp;
+
+    } else if (plP_stindex(side, "LV") != -1 || plP_stindex(side, "lv") != -1) {
+	vert = 0;
+	xdv = plsc->vpdxmi;
+	ydv = plsc->vpdymi + (plsc->vpdyma - plsc->vpdymi) * pos;
+	dispx = -disp;
+	dispy = 0;
+
+    } else if (plP_stindex(side, "RV") != -1 || plP_stindex(side, "rv") != -1) {
+	vert = 0;
+	xdv = plsc->vpdxma;
+	ydv = plsc->vpdymi + (plsc->vpdyma - plsc->vpdymi) * pos;
+	dispx = disp;
+	dispy = 0;
+
+    } else if (plP_stsearch(side, 'l')) {
+	vert = 1;
+	xdv = plsc->vpdxmi;
+	ydv = plsc->vpdymi + (plsc->vpdyma - plsc->vpdymi) * pos;
+	dispx = -disp;
+	dispy = 0;
+
+    } else if (plP_stsearch(side, 'r')) {
+	vert = 1;
+	xdv = plsc->vpdxma;
+	ydv = plsc->vpdymi + (plsc->vpdyma - plsc->vpdymi) * pos;
+	dispx = disp;
+	dispy = 0;
+
+    } else {
+	plP_sclp(clpxmi, clpxma, clpymi, clpyma); /* restore initial clip limits */
+	return;
+    }
+
+/* Transformation matrix */
+
+    if (vert != 0) {
+	xform[0] = 0.0;
+	xform[1] = -1.0;
+	xform[2] = 1.0;
+	xform[3] = 0.0;
+    } else {
+	xform[0] = 1.0;
+	xform[1] = 0.0;
+	xform[2] = 0.0;
+	xform[3] = 1.0;
+    }
+
+/* Convert to physical units (mm) and compute shifts */
+
+    plgchr(&chrdef, &chrht);
+    shift = (just == 0.0) ? 0.0 : plstrl(text) * just;
+
+    xmm = plP_dcmmx(xdv) + dispx * chrht;
+    ymm = plP_dcmmy(ydv) + dispy * chrht;
+    refxmm = xmm - shift * xform[0];
+    refymm = ymm - shift * xform[2];
+
+/* Convert to device units (pixels) and call text plotter */
+
+    x = plP_mmpcx(xmm);
+    y = plP_mmpcy(ymm);
+    refx = plP_mmpcx(refxmm);
+    refy = plP_mmpcy(refymm);
+
+    plP_text(0, just, xform, x, y, refx, refy, text);
+    plP_sclp(clpxmi, clpxma, clpymi, clpyma); /* restore clip limits */
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plptex()
+ *
+ * Prints out "text" at world cooordinate (wx,wy). The text may be
+ * at any angle "angle" relative to the horizontal. The parameter
+ * "just" adjusts the horizontal justification of the string:
+ *	just = 0.0 => left hand edge of string is at (wx,wy)
+ *	just = 1.0 => right hand edge of string is at (wx,wy)
+ *	just = 0.5 => center of string is at (wx,wy) etc.
+\*--------------------------------------------------------------------------*/
+
+MZ_DLLEXPORT
+void
+c_plptex(PLFLT wx, PLFLT wy, PLFLT dx, PLFLT dy, PLFLT just, const char *text)
+{
+    PLINT x, y, refx, refy;
+    PLFLT xdv, ydv, xmm, ymm, refxmm, refymm, shift, cc, ss;
+    PLFLT xform[4], diag;
+    PLFLT chrdef, chrht;
+    PLFLT dispx, dispy;
+
+    if (plsc->level < 3) {
+	plabort("plptex: Please set up window first");
+	return;
+    }
+
+    if (dx == 0.0 && dy == 0.0) {
+	dx = 1.0;
+	dy = 0.0;
+    }
+    cc = plsc->wmxscl * dx;
+    ss = plsc->wmyscl * dy;
+    diag = sqrt(cc * cc + ss * ss);
+    cc /= diag;
+    ss /= diag;
+
+    xform[0] = cc;
+    xform[1] = -ss;
+    xform[2] = ss;
+    xform[3] = cc;
+
+    xdv = plP_wcdcx(wx);
+    ydv = plP_wcdcy(wy);
+
+    dispx = 0.;
+    dispy = 0.;
+
+/* Convert to physical units (mm) and compute shifts */
+
+    plgchr(&chrdef, &chrht);
+    shift = (just == 0.0) ? 0.0 : plstrl(text) * just;
+
+    xmm = plP_dcmmx(xdv) + dispx * chrht;
+    ymm = plP_dcmmy(ydv) + dispy * chrht;
+    refxmm = xmm - shift * xform[0];
+    refymm = ymm - shift * xform[2];
+
+    x = plP_mmpcx(xmm);
+    y = plP_mmpcy(ymm);
+    refx = plP_mmpcx(refxmm);
+    refy = plP_mmpcy(refymm);
+
+    plP_text(0, just, xform, x, y, refx, refy, text);      
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plstr()
+ *
+ * Prints out a "string" at reference position with physical coordinates
+ * (refx,refy). The coordinates of the vectors defining the string are
+ * passed through the linear mapping defined by the 2 x 2 matrix xform()
+ * before being plotted.  The reference position is at the left-hand edge of
+ * the string. If base = 1, it is aligned with the baseline of the string.
+ * If base = 0, it is aligned with the center of the character box.
+ *
+ * Note, all calculations are done in terms of millimetres. These are scaled
+ * as necessary before plotting the string on the page.
+\*--------------------------------------------------------------------------*/
+
+void
+plstr(PLINT base, PLFLT *xform, PLINT refx, PLINT refy, const char *string)
+{
+    short int *symbol;
+    signed char *vxygrid = 0;
+    
+    PLINT ch, i, length, level = 0, style, oline = 0, uline = 0;
+    PLFLT width = 0., xorg = 0., yorg = 0., def, ht, dscale, scale;
+
+    plgchr(&def, &ht);
+    dscale = 0.05 * ht;
+    scale = dscale;
+
+/* Line style must be continuous */
+
+    style = plsc->nms;
+    plsc->nms = 0;
+
+    pldeco(&symbol, &length, string);
+
+    for (i = 0; i < length; i++) {
+	ch = symbol[i];
+	if (ch == -1) { /* super-script */
+	    level++;
+	    yorg += 16.0 * scale;
+	    scale = dscale * pow(0.75, (double) ABS(level));
+	}
+	else if (ch == -2) { /* sub-script */
+	    level--; 
+	    scale = dscale * pow(0.75, (double) ABS(level));
+	    yorg -= 16.0 * scale;
+	}
+	else if (ch == -3) /* back-char */
+	    xorg -= width * scale;
+	else if (ch == -4) /* toogle overline */
+	    oline = !oline; 
+	else if (ch == -5)  /* toogle underline */
+	    uline = !uline;
+	else {
+	    if (plcvec(ch, &vxygrid))
+		plchar(vxygrid, xform, base, oline, uline, refx, refy, scale,
+		       plsc->xpmm, plsc->ypmm, &xorg, &yorg, &width);
+	}
+    }
+    plsc->nms = style;
+}
+
+/*--------------------------------------------------------------------------*\
+ * plchar()
+ *
+ * Plots out a given stroke font character.
+\*--------------------------------------------------------------------------*/
+
+static void
+plchar(signed char *vxygrid, PLFLT *xform, PLINT base, PLINT oline, PLINT uline,
+       PLINT refx, PLINT refy, PLFLT scale, PLFLT xpmm, PLFLT ypmm,
+       PLFLT *p_xorg, PLFLT *p_yorg, PLFLT *p_width)
+{
+    PLINT xbase, ybase, ydisp, lx, ly, cx, cy;
+    PLINT k, penup;
+    PLFLT x, y;
+    PLINT llx[STLEN], lly[STLEN], l = 0;
+
+    xbase = vxygrid[2];
+    *p_width = vxygrid[3] - xbase;
+    if (base == 0) {
+	ybase = 0;
+	ydisp = vxygrid[0];
+    }
+    else {
+	ybase = vxygrid[0];
+	ydisp = 0;
+    }
+    k = 4;
+    penup = 1;
+
+    for (;;) {
+	cx = vxygrid[k++];
+	cy = vxygrid[k++];
+	if (cx == 64 && cy == 64) {
+	  if (l) {
+	    plP_draphy_poly(llx, lly, l);
+	    l = 0;
+	  }
+	  break;
+	}
+	if (cx == 64 && cy == 0) {
+	  if (l) {
+	    plP_draphy_poly(llx, lly, l);
+	    l = 0;
+	  }
+	  penup = 1;
+	}
+	else {
+	    x = *p_xorg + (cx - xbase) * scale;
+	    y = *p_yorg + (cy - ybase) * scale;
+	    lx = refx + ROUND(xpmm * (xform[0] * x + xform[1] * y));
+	    ly = refy + ROUND(ypmm * (xform[2] * x + xform[3] * y));
+	    if (penup == 1) {
+	      if (l) {
+		plP_draphy_poly(llx, lly, l);
+		l = 0;
+	      }
+	      llx[l] = lx;
+	      lly[l++] = ly; /* store 1st point ! */
+	      plP_movphy(lx, ly);
+	      penup = 0;
+	    }
+	    else {
+	      llx[l] = lx;
+	      lly[l++] = ly;
+	    }
+	}
+    }
+
+    if (oline) {
+	x = *p_xorg;
+	y = *p_yorg + (30 + ydisp) * scale;
+	lx = refx + ROUND(xpmm * (xform[0] * x + xform[1] * y));
+	ly = refy + ROUND(ypmm * (xform[2] * x + xform[3] * y));
+	plP_movphy(lx, ly);
+	x = *p_xorg + *p_width * scale;
+	lx = refx + ROUND(xpmm * (xform[0] * x + xform[1] * y));
+	ly = refy + ROUND(ypmm * (xform[2] * x + xform[3] * y));
+	plP_draphy(lx, ly);
+    }
+    if (uline) {
+	x = *p_xorg;
+	y = *p_yorg + (-5 + ydisp) * scale;
+	lx = refx + ROUND(xpmm * (xform[0] * x + xform[1] * y));
+	ly = refy + ROUND(ypmm * (xform[2] * x + xform[3] * y));
+	plP_movphy(lx, ly);
+	x = *p_xorg + *p_width * scale;
+	lx = refx + ROUND(xpmm * (xform[0] * x + xform[1] * y));
+	ly = refy + ROUND(ypmm * (xform[2] * x + xform[3] * y));
+	plP_draphy(lx, ly);
+    }
+    *p_xorg = *p_xorg + *p_width * scale;
+}
+
+/*--------------------------------------------------------------------------*\
+ * PLFLT plstrl()
+ *
+ * Computes the length of a string in mm, including escape sequences.
+\*--------------------------------------------------------------------------*/
+
+PLFLT
+plstrl(const char *string)
+{
+    short int *symbol;
+    signed char *vxygrid = 0;
+    PLINT ch, i, length, level = 0;
+    PLFLT width = 0., xorg = 0., dscale, scale, def, ht;
+
+    plgchr(&def, &ht);
+    dscale = 0.05 * ht;
+    scale = dscale;
+    pldeco(&symbol, &length, string);
+
+    for (i = 0; i < length; i++) {
+	ch = symbol[i];
+	if (ch == -1) {
+	    level++;
+	    scale = dscale * pow(0.75, (double) ABS(level));
+	}
+	else if (ch == -2) {
+	    level--;
+	    scale = dscale * pow(0.75, (double) ABS(level));
+	}
+	else if (ch == -3)
+	    xorg -= width * scale;
+	else if (ch == -4 || ch == -5);
+	else {
+	    if (plcvec(ch, &vxygrid)) {
+		width = vxygrid[3] - vxygrid[2];
+		xorg += width * scale;
+	    }
+	}
+    }
+    return (PLFLT) xorg;
+}
+
+/*--------------------------------------------------------------------------*\
+ * PLINT plcvec()
+ *
+ * Gets the character digitisation of Hershey table entry "char".
+ * Returns 1 if there is a valid entry.
+\*--------------------------------------------------------------------------*/
+
+static PLINT
+plcvec(PLINT ch, signed char **xygr)
+{
+    PLINT k = 0, ib;
+    signed char x, y;
+
+    ch--;
+    if (ch < 0 || ch >= indxleng)
+	return (PLINT) 0;
+    ib = fntindx[ch] - 2;
+    if (ib == -2)
+	return (PLINT) 0;
+
+    do {
+	ib++;
+	x = fntbffr[2 * ib];
+	y = fntbffr[2 * ib + 1];
+	xygrid[k++] = x;
+	xygrid[k++] = y;
+    } while ((x != 64 || y != 64) && k <= (STLEN - 2));
+
+    if (k == (STLEN-1)) {
+	/* This is bad if we get here */
+	xygrid[k] = 64;
+	xygrid[k] = 64;
+    }
+    
+    *xygr = xygrid;
+    return (PLINT) 1;
+}
+
+/*--------------------------------------------------------------------------*\
+ * void pldeco()
+ *
+ * Decode a character string, and return an array of float integer symbol
+ * numbers. This routine is responsible for interpreting all escape sequences.
+ * At present the following escape sequences are defined (the letter following
+ * the <esc> may be either upper or lower case):
+ *
+ * <esc>u	: up one level (returns -1)
+ * <esc>d	: down one level (returns -2)
+ * <esc>b	: backspace (returns -3)
+ * <esc>+	: toggles overline mode (returns -4)
+ * <esc>-	: toggles underline mode (returns -5)
+ * <esc><esc>	: <esc>
+ * <esc>gx	: greek letter corresponding to roman letter x
+ * <esc>fn	: switch to Normal font
+ * <esc>fr	: switch to Roman font
+ * <esc>fi	: switch to Italic font
+ * <esc>fs	: switch to Script font
+ * <esc>(nnn)	: Hershey symbol number nnn (any number of digits)
+ *
+ * The escape character defaults to '#', but can be changed to any of
+ * [!#$%&*@^~] via a call to plsesc.
+\*--------------------------------------------------------------------------*/
+
+static void
+pldeco(short int **symbol, PLINT *length, const char *text)
+{
+    PLINT ch, ifont = plsc->cfont, ig, j = 0, lentxt = strlen(text);
+    char test, esc;
+    short int *sym = symbol_buffer;
+
+/* Initialize parameters. */
+
+    *length = 0;
+    *symbol = symbol_buffer;
+    plgesc(&esc);
+    if (ifont > numberfonts)
+	ifont = 1;
+
+/* Get next character; treat non-printing characters as spaces. */
+
+    while (j < lentxt) {
+	if (*length >= PLMAXSTR)
+	    return;
+	test = text[j++];
+	ch = test;
+	if (ch < 0 || ch > 175)
+	    ch = 32;
+
+    /* Test for escape sequence (#) */
+
+	if (ch == esc && (lentxt - j) >= 1) {
+	    test = text[j++];
+	    if (test == esc)
+		sym[(*length)++] = *(fntlkup + (ifont - 1) * numberchars + ch);
+
+	    else if (test == 'u' || test == 'U')
+		sym[(*length)++] = -1;
+
+	    else if (test == 'd' || test == 'D')
+		sym[(*length)++] = -2;
+
+	    else if (test == 'b' || test == 'B')
+		sym[(*length)++] = -3;
+
+	    else if (test == '+')
+		sym[(*length)++] = -4;
+
+	    else if (test == '-')
+		sym[(*length)++] = -5;
+
+	    else if (test == '(') {
+		sym[*length] = 0;
+		while ('0' <= text[j] && text[j] <= '9') {
+		    sym[*length] = sym[*length] * 10 + text[j] - '0';
+		    j++;
+		}
+		(*length)++;
+		if (text[j] == ')')
+		    j++;
+	    }
+	    else if (test == 'f' || test == 'F') {
+		test = text[j++];
+		ifont = 1 + plP_strpos(font_types,
+				       isupper(test) ? tolower(test) : test);
+		if (ifont == 0 || ifont > numberfonts)
+		    ifont = 1;
+	    }
+	    else if (test == 'g' || test == 'G') {
+		test = text[j++];
+		ig = plP_strpos(greek, test) + 1;
+		sym[(*length)++] = 
+		    *(fntlkup + (ifont - 1) * numberchars + 127 + ig);
+	    }
+	    else {
+		;
+	    }
+	}
+	else {
+
+	/* Decode character. */
+	/* >>PC<< removed increment from following expression to fix */
+	/* compiler bug */ 
+
+	    sym[(*length)] = *(fntlkup + (ifont - 1) * numberchars + ch);
+	    (*length)++;
+	}
+    }
+}
+
+/*--------------------------------------------------------------------------*\
+ * PLINT plP_strpos()
+ *
+ * Searches string str for first occurence of character chr.  If found
+ * the position of the character in the string is returned (the first
+ * character has position 0).  If the character is not found a -1 is
+ * returned.
+\*--------------------------------------------------------------------------*/
+
+PLINT
+plP_strpos(char *str, int chr)
+{
+    char *temp;
+
+    if ((temp = strchr(str, chr)))
+	return (PLINT) (temp - str);
+    else
+	return (PLINT) -1;
+}
+
+/*--------------------------------------------------------------------------*\
+ * PLINT plP_stindex()
+ *
+ * Similar to strpos, but searches for occurence of string str2.
+\*--------------------------------------------------------------------------*/
+
+PLINT
+plP_stindex(const char *str1, const char *str2)
+{
+    PLINT base, str1ind, str2ind;
+
+    for (base = 0; *(str1 + base) != '\0'; base++) {
+	for (str1ind = base, str2ind = 0; *(str2 + str2ind) != '\0' &&
+	     *(str2 + str2ind) == *(str1 + str1ind); str1ind++, str2ind++)
+	    ;
+
+	if (*(str2 + str2ind) == '\0')
+	    return (PLINT) base;
+    }
+    return (PLINT) -1;		/* search failed */
+}
+
+/*--------------------------------------------------------------------------*\
+ * PLINT plP_stsearch()
+ *
+ * Searches string str for character chr (case insensitive).
+\*--------------------------------------------------------------------------*/
+
+PLINT
+plP_stsearch(const char *str, int chr)
+{
+    if (strchr(str, chr))
+	return (PLINT) 1;
+    else if (strchr(str, toupper(chr)))
+	return (PLINT) 1;
+    else
+	return (PLINT) 0;
+}
+
+/*--------------------------------------------------------------------------*\
+ * void c_plfont(ifont)
+ *
+ * Sets the global font flag to 'ifont'.
+\*--------------------------------------------------------------------------*/
+
+void
+c_plfont(PLINT ifont)
+{
+    if (plsc->level < 1) {
+	plabort("plfont: Please call plinit first");
+	return;
+    }
+    if (ifont < 1 || ifont > 4) {
+	plabort("plfont: Invalid font");
+	return;
+    }
+
+    plsc->cfont = ifont;
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plfntld(fnt)
+ *
+ * Loads either the standard or extended font.
+\*--------------------------------------------------------------------------*/
+
+void
+plfntld(PLINT fnt)
+{
+    static PLINT charset;
+    short bffrleng;
+    PDFstrm *pdfs;
+
+    if (fontloaded && (charset == fnt))
+	return;
+
+    plfontrel();
+    fontloaded = 1;
+    charset = fnt;
+
+    if (fnt)
+	pdfs = plLibOpenPdfstrm(PL_XFONT);
+    else
+	pdfs = plLibOpenPdfstrm(PL_SFONT);
+
+    if (pdfs == NULL)
+	plexit("Unable to open or allocate memory for font file");
+
+/* Read fntlkup[] */
+
+    pdf_rd_2bytes(pdfs, (U_SHORT *) &bffrleng);
+    numberfonts = bffrleng / 256;
+    numberchars = bffrleng & 0xff;
+    bffrleng = numberfonts * numberchars;
+    fntlkup = (short int *) malloc(bffrleng * sizeof(short int));
+    if ( ! fntlkup)
+	plexit("plfntld: Out of memory while allocating font buffer.");
+
+    pdf_rd_2nbytes(pdfs, (U_SHORT *) fntlkup, bffrleng);
+
+/* Read fntindx[] */
+
+    pdf_rd_2bytes(pdfs, (U_SHORT *) &indxleng);
+    fntindx = (short int *) malloc(indxleng * sizeof(short int));
+    if ( ! fntindx)
+	plexit("plfntld: Out of memory while allocating font buffer.");
+
+    pdf_rd_2nbytes(pdfs, (U_SHORT *) fntindx, indxleng);
+
+/* Read fntbffr[] */
+/* Since this is an array of char, there are no endian problems */
+
+    pdf_rd_2bytes(pdfs, (U_SHORT *) &bffrleng);
+    fntbffr = (signed char *) malloc(2 * bffrleng * sizeof(signed char));
+    if ( ! fntbffr)
+	plexit("plfntld: Out of memory while allocating font buffer.");
+
+#if PLPLOT_USE_TCL_CHANNELS
+    pdf_rdx(fntbffr, sizeof(signed char)*(2 * bffrleng), pdfs);
+#else
+    fread((void *) fntbffr, (size_t) sizeof(signed char),
+	  (size_t) (2 * bffrleng), pdfs->file);
+#endif
+
+/* Done */
+
+    pdf_close(pdfs);
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plfontrel()
+ *
+ * Release memory for fonts.
+\*--------------------------------------------------------------------------*/
+
+void
+plfontrel(void)
+{
+    if (fontloaded) {
+	free_mem(fntindx)
+	free_mem(fntbffr)
+	free_mem(fntlkup)
+	fontloaded = 0;
+    }
+}
diff --git a/collects/plot/src/all/pltick.c b/collects/plot/src/all/pltick.c
new file mode 100644
index 0000000000..f429ea944d
--- /dev/null
+++ b/collects/plot/src/all/pltick.c
@@ -0,0 +1,139 @@
+/* $Id: pltick.c,v 1.2 2005/03/17 21:39:21 eli Exp $
+
+	Routines for drawing error bars and tick marks.
+*/
+
+#include "plplotP.h"
+
+/*----------------------------------------------------------------------*\
+ * void plxtik()
+ *
+ * Draws a tick parallel to x.
+\*----------------------------------------------------------------------*/
+
+void
+plxtik(PLINT x, PLINT y, PLINT below, PLINT above)
+{
+    plP_draphy(x, y);
+
+    if (below != 0)
+	plP_draphy(x, y - below);
+
+    if (above != 0)
+	plP_draphy(x, y + above);
+
+    plP_draphy(x, y);
+}
+
+/*----------------------------------------------------------------------*\
+ * void plytik()
+ *
+ * Draws a tick parallel to y.
+\*----------------------------------------------------------------------*/
+
+void
+plytik(PLINT x, PLINT y, PLINT left, PLINT right)
+{
+    plP_draphy(x, y);
+
+    if (left != 0)
+	plP_draphy(x - left, y);
+
+    if (right != 0)
+	plP_draphy(x + right, y);
+
+    plP_draphy(x, y);
+}
+
+/*----------------------------------------------------------------------*\
+ * void plstik()
+ *
+ * Draws a slanting tick at position (mx,my) (measured in mm) of
+ * vector length (dx,dy).
+\*----------------------------------------------------------------------*/
+
+void 
+plstik(PLFLT mx, PLFLT my, PLFLT dx, PLFLT dy)
+{
+    plP_draphy(plP_mmpcx(mx), plP_mmpcy(my));
+    plP_draphy(plP_mmpcx((PLFLT) (mx + dx)), plP_mmpcy((PLFLT) (my + dy)));
+    plP_draphy(plP_mmpcx(mx), plP_mmpcy(my));
+}
+
+/*----------------------------------------------------------------------*\
+ * void plerx1()
+ *
+ * Plot single horizontal error bar.
+\*----------------------------------------------------------------------*/
+
+static void
+plerx1(PLFLT xmin, PLFLT xmax, PLFLT y)
+{
+    PLINT yminor;
+
+    yminor = MAX(1.0, plsc->minht * plsc->ypmm);
+    plP_movwor(xmin, y);
+    plxtik(plP_wcpcx(xmin), plP_wcpcy(y), yminor, yminor);
+    plP_drawor(xmax, y);
+    plxtik(plP_wcpcx(xmax), plP_wcpcy(y), yminor, yminor);
+}
+
+/*----------------------------------------------------------------------*\
+ * void plery1()
+ *
+ * Plot single vertical error bar.
+\*----------------------------------------------------------------------*/
+
+static void
+plery1(PLFLT x, PLFLT ymin, PLFLT ymax)
+{
+    PLINT xminor;
+
+    xminor = MAX(1.0, plsc->minht * plsc->xpmm);
+    plP_movwor(x, ymin);
+    plytik(plP_wcpcx(x), plP_wcpcy(ymin), xminor, xminor);
+    plP_drawor(x, ymax);
+    plytik(plP_wcpcx(x), plP_wcpcy(ymax), xminor, xminor);
+}
+
+/*----------------------------------------------------------------------*\
+ * void plerrx()
+ *
+ * Plot horizontal error bars (xmin(i),y(i)) to (xmax(i),y(i)).
+\*----------------------------------------------------------------------*/
+
+MZ_DLLEXPORT
+void
+c_plerrx(PLINT n, PLFLT *xmin, PLFLT *xmax, PLFLT *y)
+{
+    PLINT i;
+
+    if (plsc->level < 3) {
+	plabort("plerrx: Please set up window first");
+	return;
+    }
+
+    for (i = 0; i < n; i++)
+	plerx1(xmin[i], xmax[i], y[i]);
+}
+
+/*----------------------------------------------------------------------*\
+ * void plerry()
+ *
+ * Plot vertical error bars (x,ymin(i)) to (x(i),ymax(i)).
+\*----------------------------------------------------------------------*/
+
+MZ_DLLEXPORT
+void
+c_plerry(PLINT n, PLFLT *x, PLFLT *ymin, PLFLT *ymax)
+{
+    PLINT i;
+
+    if (plsc->level < 3) {
+	plabort("plerry: Please set up window first");
+	return;
+    }
+
+    for (i = 0; i < n; i++)
+	plery1(x[i], ymin[i], ymax[i]);
+}
diff --git a/collects/plot/src/all/plvpor.c b/collects/plot/src/all/plvpor.c
new file mode 100644
index 0000000000..dbe8cad77e
--- /dev/null
+++ b/collects/plot/src/all/plvpor.c
@@ -0,0 +1,444 @@
+/* $Id: plvpor.c,v 1.2 2005/03/17 21:39:22 eli Exp $
+
+	Functions dealing with viewports.
+*/
+
+#include "plplotP.h"
+
+static void
+c_plenvi(PLFLT xmin, PLFLT xmax, PLFLT ymin, PLFLT ymax,
+	 PLINT just, PLINT axis, PLINT old);
+
+/*--------------------------------------------------------------------------*\
+ * void plenv()
+ *
+ * Simple interface for defining viewport and window. 
+ *
+ * The "just" parameter control how the axes will be scaled:
+ *
+ *       just=-1 : The scales will not be set, the user must set up the scale
+ *                   before calling plenv() using plsvpa(), plvasp() or other;
+ *       just= 0 : The scales will be set up to optimize plot area;
+ *       just= 1 : The scales will be the same; 
+ *       just= 2 : The axes will be equal, the plot box will be square.
+ * 
+ * The "axis" parameter is interpreted as follows:
+ *
+ *	axis=-2 : draw no box, no tick marks, no numeric tick labels, no axes.
+ *	axis=-1 : draw box only.
+ *	axis= 0 : Draw box, ticks, and numeric tick labels.
+ *	axis= 1 : Also draw coordinate axes at X=0, and Y=0.
+ *	axis= 2 : Also draw a grid at major tick positions in both coordinates.
+ *	axis= 3 : Same as 2, but the grid will be also at the minor ticks.
+ *	axis=10 : Same as 0 except Logarithmic X tick marks. (The X data have
+ *      to be converted to logarithms separately.)
+ *	axis=11 : Same as 1 except Logarithmic X tick marks. (The X data have
+ *      to be converted to logarithms separately.)
+ *	axis=12 : Same as 2 except Logarithmic X tick marks. (The X data have
+ *      to be converted to logarithms separately.)
+ *      axis=13 : Same as 12, but the grid will be also at the minor ticks.
+ *	axis=20 : Same as 0 except Logarithmic Y tick marks. (The Y data have
+ *      to be converted to logarithms separately.)
+ *	axis=21 : Same as 1 except Logarithmic Y tick marks. (The Y data have
+ *      to be converted to logarithms separately.)
+ *	axis=22 : Same as 2 except Logarithmic Y tick marks. (The Y data have
+ *      to be converted to logarithms separately.)
+ *      axis=23 : Same as 22, but the grid will be also at the minor ticks.
+ *	axis=30 : Same as 0 except Logarithmic X,Y tick marks. (The X,Y data have
+ *      to be converted to logarithms separately.)
+ *	axis=31 : Same as 1 except Logarithmic X,Y tick marks. (The X,Y data have
+ *      to be converted to logarithms separately.)
+ *	axis=32 : Same as 2 except Logarithmic X,Y tick marks. (The X,Y data have
+ *      to be converted to logarithms separately.)
+ *      axis=33 : Same as 32, but the grid will be also at the minor ticks.
+\*--------------------------------------------------------------------------*/
+
+MZ_DLLEXPORT
+void
+c_plenv(PLFLT xmin, PLFLT xmax, PLFLT ymin, PLFLT ymax,
+	PLINT just, PLINT axis)
+{
+  c_plenvi(xmin, xmax, ymin, ymax, just, axis, 1); 
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plenv0()
+ *
+ * same as plenv() above, but if in multiplot mode does not advance the subpage,
+ * instead clears it.
+\*--------------------------------------------------------------------------*/
+
+void
+c_plenv0(PLFLT xmin, PLFLT xmax, PLFLT ymin, PLFLT ymax,
+	PLINT just, PLINT axis)
+{
+  c_plenvi(xmin, xmax, ymin, ymax, just, axis, 0); 
+}
+
+
+static void
+c_plenvi(PLFLT xmin, PLFLT xmax, PLFLT ymin, PLFLT ymax,
+	PLINT just, PLINT axis, PLINT old)
+{
+    PLFLT lb, rb, tb, bb, dx, dy;
+    PLFLT xsize, ysize, size, xscale, yscale, scale;
+    PLFLT spxmin, spxmax, spymin, spymax;
+    PLFLT vpxmin, vpxmax, vpymin, vpymax;
+
+    if (plsc->level < 1) {
+	plabort("plenv: Please call plinit first");
+	return;
+    }
+    if (xmin == xmax) {
+	plabort("plenv: Invalid xmin and xmax arguments");
+	return;
+    }
+    if (ymin == ymax) {
+	plabort("plenv: Invalid ymin and ymax arguments");
+	return;
+    }
+    if (just < -1 || just > 2) {
+	plabort("plenv: Invalid just option");
+	return;
+    }
+
+    if (plsc->nsubx * plsc->nsuby == 1) /* not multiplot mode */
+      old = 1;
+
+    if (old == 1)
+      pladv(0);
+    else 
+      plclear();
+
+    if (just == 0)
+	plvsta();
+    else  if (just == 1){
+	lb = 8.0 * plsc->chrht;
+	rb = 5.0 * plsc->chrht;
+	tb = 5.0 * plsc->chrht;
+	bb = 5.0 * plsc->chrht;
+	dx = ABS(xmax - xmin);
+	dy = ABS(ymax - ymin);
+	plgspa(&spxmin, &spxmax, &spymin, &spymax);
+	xsize = spxmax - spxmin;
+	ysize = spymax - spymin;
+	xscale = dx / (xsize - lb - rb);
+	yscale = dy / (ysize - tb - bb);
+	scale = MAX(xscale, yscale);
+	vpxmin = MAX(lb, 0.5 * (xsize - dx / scale));
+	vpxmax = vpxmin + (dx / scale);
+	vpymin = MAX(bb, 0.5 * (ysize - dy / scale));
+	vpymax = vpymin + (dy / scale);
+	plsvpa(vpxmin, vpxmax, vpymin, vpymax);
+    } else if(just == 2) {
+        lb = 8.0 * plsc->chrht;
+        rb = 5.0 * plsc->chrht;
+	tb = 5.0 * plsc->chrht;
+	bb = 5.0 * plsc->chrht;
+	plgspa(&spxmin, &spxmax, &spymin, &spymax);
+	xsize = spxmax - spxmin;
+	ysize = spymax - spymin;
+	size = MIN(xsize-lb-rb, ysize-tb-bb);
+	dx = (xsize-size-lb-rb)/2;
+	vpxmin = lb + dx;
+	vpxmax = vpxmin + size;
+	dy = (ysize-size-bb-tb)/2;
+	vpymin = bb + dy;
+	vpymax = vpymin + size;
+	plsvpa(vpxmin, vpxmax, vpymin, vpymax);
+    }
+
+    plwind(xmin, xmax, ymin, ymax);
+
+    switch (axis) {
+    case -2:
+	break;
+    case -1:
+	plbox("bc", (PLFLT) 0.0, 0, "bc", (PLFLT) 0.0, 0);
+	break;
+    case 0:
+	plbox("bcnst", (PLFLT) 0.0, 0, "bcnstv", (PLFLT) 0.0, 0);
+	break;
+    case 1:
+	plbox("abcnst", (PLFLT) 0.0, 0, "abcnstv", (PLFLT) 0.0, 0);
+	break;
+    case 2:
+	plbox("abcgnst", (PLFLT) 0.0, 0, "abcgnstv", (PLFLT) 0.0, 0);
+	break;
+    case 3:
+	plbox("abcgnsth", (PLFLT) 0.0, 0, "abcgnstvh", (PLFLT) 0.0, 0);
+	break;
+    case 10:
+	plbox("bclnst", (PLFLT) 0.0, 0, "bcnstv", (PLFLT) 0.0, 0);
+	break;
+    case 11:
+	plbox("abclnst", (PLFLT) 0.0, 0, "abcnstv", (PLFLT) 0.0, 0);
+	break;
+    case 12:
+	plbox("abcglnst", (PLFLT) 0.0, 0, "abcgnstv", (PLFLT) 0.0, 0);
+	break;
+    case 13:
+	plbox("abcglnsth", (PLFLT) 0.0, 0, "abcgnstvh", (PLFLT) 0.0, 0);
+	break;
+    case 20:
+	plbox("bcnst", (PLFLT) 0.0, 0, "bclnstv", (PLFLT) 0.0, 0);
+	break;
+    case 21:
+	plbox("abcnst", (PLFLT) 0.0, 0, "abclnstv", (PLFLT) 0.0, 0);
+	break;
+    case 22:
+	plbox("abcgnst", (PLFLT) 0.0, 0, "abcglnstv", (PLFLT) 0.0, 0);
+	break;	
+    case 23:
+	plbox("abcgnsth", (PLFLT) 0.0, 0, "abcglnstvh", (PLFLT) 0.0, 0);
+	break;	
+    case 30:
+	plbox("bclnst", (PLFLT) 0.0, 0, "bclnstv", (PLFLT) 0.0, 0);
+	break;
+    case 31:
+	plbox("abclnst", (PLFLT) 0.0, 0, "abclnstv", (PLFLT) 0.0, 0);
+	break;
+    case 32:
+	plbox("abcglnst", (PLFLT) 0.0, 0, "abcglnstv", (PLFLT) 0.0, 0);
+	break;	
+    case 33:
+	plbox("abcglnsth", (PLFLT) 0.0, 0, "abcglnstvh", (PLFLT) 0.0, 0);
+	break;	
+    default:
+	plwarn("plenv: Invalid axis argument");
+    }
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plvsta()
+ *
+ * Defines a "standard" viewport with seven character heights for
+ * the left margin and four character heights everywhere else.
+\*--------------------------------------------------------------------------*/
+
+void
+c_plvsta(void)
+{
+    PLFLT xmin, xmax, ymin, ymax;
+    PLFLT lb, rb, tb, bb;
+
+    if (plsc->level < 1) {
+	plabort("plvsta: Please call plinit first");
+	return;
+    }
+
+/*  Find out position of subpage boundaries in millimetres, reduce by */
+/*  the desired border, and convert back into normalized subpage */
+/*  coordinates */
+
+    lb = 8.0 * plsc->chrht;
+    rb = 5.0 * plsc->chrht;
+    tb = 5.0 * plsc->chrht;
+    bb = 5.0 * plsc->chrht;
+
+    xmin = plP_dcscx(plP_mmdcx((PLFLT) (plP_dcmmx(plsc->spdxmi) + lb)));
+    xmax = plP_dcscx(plP_mmdcx((PLFLT) (plP_dcmmx(plsc->spdxma) - rb)));
+    ymin = plP_dcscy(plP_mmdcy((PLFLT) (plP_dcmmy(plsc->spdymi) + tb)));
+    ymax = plP_dcscy(plP_mmdcy((PLFLT) (plP_dcmmy(plsc->spdyma) - bb)));
+
+    plvpor(xmin, xmax, ymin, ymax);
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plvpor()
+ *
+ * Creates a viewport with the specified normalized subpage coordinates.
+\*--------------------------------------------------------------------------*/
+
+void
+c_plvpor(PLFLT xmin, PLFLT xmax, PLFLT ymin, PLFLT ymax)
+{
+    if (plsc->level < 1) {
+	plabort("plvpor: Please call plinit first");
+	return;
+    }
+    if ((xmin >= xmax) || (ymin >= ymax)) {
+	plabort("plvpor: Invalid limits");
+	return;
+    }
+    if ((plsc->cursub <= 0) || (plsc->cursub > (plsc->nsubx * plsc->nsuby))) {
+	plabort("plvpor: Please call pladv or plenv to go to a subpage");
+	return;
+    }
+
+    plsc->vpdxmi = plsc->spdxmi + (plsc->spdxma - plsc->spdxmi) * xmin;
+    plsc->vpdxma = plsc->spdxmi + (plsc->spdxma - plsc->spdxmi) * xmax;
+    plsc->vpdymi = plsc->spdymi + (plsc->spdyma - plsc->spdymi) * ymin;
+    plsc->vpdyma = plsc->spdymi + (plsc->spdyma - plsc->spdymi) * ymax;
+
+    plsc->vppxmi = plP_dcpcx(plsc->vpdxmi);
+    plsc->vppxma = plP_dcpcx(plsc->vpdxma);
+    plsc->vppymi = plP_dcpcy(plsc->vpdymi);
+    plsc->vppyma = plP_dcpcy(plsc->vpdyma);
+
+    plsc->clpxmi = MAX(plsc->vppxmi, plsc->phyxmi);
+    plsc->clpxma = MIN(plsc->vppxma, plsc->phyxma);
+    plsc->clpymi = MAX(plsc->vppymi, plsc->phyymi);
+    plsc->clpyma = MIN(plsc->vppyma, plsc->phyyma);
+
+    plsc->level = 2;
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plvpas()
+ *
+ * Creates the largest viewport of the specified aspect ratio that fits
+ * within the specified normalized subpage coordinates.
+\*--------------------------------------------------------------------------*/
+
+void
+c_plvpas(PLFLT xmin, PLFLT xmax, PLFLT ymin, PLFLT ymax, PLFLT aspect)
+{
+    PLFLT vpxmi, vpxma, vpymi, vpyma;
+    PLFLT vpxmid, vpymid, vpxlen, vpylen, w_aspect, ratio;
+
+    if (plsc->level < 1) {
+	plabort("plvpas: Please call plinit first");
+	return;
+    }
+    if ((xmin >= xmax) || (ymin >= ymax)) {
+	plabort("plvpas: Invalid limits");
+	return;
+    }
+
+    if (aspect <= 0.0) {
+	c_plvpor(xmin, xmax, ymin, ymax);
+	return;
+    }
+
+    vpxmi = plP_dcmmx(xmin);
+    vpxma = plP_dcmmx(xmax);
+    vpymi = plP_dcmmy(ymin);
+    vpyma = plP_dcmmy(ymax);
+
+    vpxmid = (vpxmi + vpxma) / 2.;
+    vpymid = (vpymi + vpyma) / 2.;
+
+    vpxlen = vpxma - vpxmi;
+    vpylen = vpyma - vpymi;
+
+    w_aspect = vpylen / vpxlen;
+    ratio = aspect / w_aspect;
+
+/*
+ * If ratio < 1, you are requesting an aspect ratio (y/x) less than the natural
+ * aspect ratio of the specified window, and you will need to reduce the length
+ * in y correspondingly.  Similarly, for ratio > 1, x length must be reduced.
+ */
+
+    if (ratio <= 0.) {
+	plabort("plvpas: Error in aspect ratio setting");
+	return;
+    }
+    else if (ratio < 1.)
+	vpylen = vpylen * ratio;
+    else
+	vpxlen = vpxlen / ratio;
+
+    vpxmi = vpxmid - vpxlen / 2.;
+    vpxma = vpxmid + vpxlen / 2.;
+    vpymi = vpymid - vpylen / 2.;
+    vpyma = vpymid + vpylen / 2.;
+
+    plsvpa(vpxmi, vpxma, vpymi, vpyma);
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plvasp()
+ *
+ * Sets the edges of the viewport with the given aspect ratio, leaving
+ * room for labels.
+\*--------------------------------------------------------------------------*/
+
+void
+c_plvasp(PLFLT aspect)
+{
+    PLFLT spxmin, spxmax, spymin, spymax;
+    PLFLT vpxmin, vpxmax, vpymin, vpymax;
+    PLFLT xsize, ysize, nxsize, nysize;
+    PLFLT lb, rb, tb, bb;
+
+    if (plsc->level < 1) {
+	plabort("plvasp: Please call plinit first");
+	return;
+    }
+
+    lb = 8.0 * plsc->chrht;
+    rb = 5.0 * plsc->chrht;
+    tb = 5.0 * plsc->chrht;
+    bb = 5.0 * plsc->chrht;
+
+    plgspa(&spxmin, &spxmax, &spymin, &spymax);
+    xsize = spxmax - spxmin;
+    ysize = spymax - spymin;
+    xsize -= lb + rb;		/* adjust for labels */
+    ysize -= bb + tb;
+    if (aspect * xsize > ysize) {
+	nxsize = ysize / aspect;
+	nysize = ysize;
+    }
+    else {
+	nxsize = xsize;
+	nysize = xsize * aspect;
+    }
+
+/* center plot within page */
+
+    vpxmin = .5 * (xsize - nxsize) + lb;
+    vpxmax = vpxmin + nxsize;
+    vpymin = .5 * (ysize - nysize) + bb;
+    vpymax = vpymin + nysize;
+
+    plsvpa(vpxmin, vpxmax, vpymin, vpymax);
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plsvpa()
+ *
+ * Sets the edges of the viewport to the specified absolute coordinates
+ * (mm), measured with respect to the current subpage boundaries.
+\*--------------------------------------------------------------------------*/
+
+void
+c_plsvpa(PLFLT xmin, PLFLT xmax, PLFLT ymin, PLFLT ymax)
+{
+    PLFLT sxmin, symin;
+
+    if (plsc->level < 1) {
+	plabort("plsvpa: Please call plinit first");
+	return;
+    }
+    if ((xmin >= xmax) || (ymin >= ymax)) {
+	plabort("plsvpa: Invalid limits");
+	return;
+    }
+    if ((plsc->cursub <= 0) || (plsc->cursub > (plsc->nsubx * plsc->nsuby))) {
+	plabort("plsvpa: Please call pladv or plenv to go to a subpage");
+	return;
+    }
+
+    sxmin = plP_dcmmx(plsc->spdxmi);
+    symin = plP_dcmmy(plsc->spdymi);
+
+    plsc->vpdxmi = plP_mmdcx((PLFLT) (sxmin + xmin));
+    plsc->vpdxma = plP_mmdcx((PLFLT) (sxmin + xmax));
+    plsc->vpdymi = plP_mmdcy((PLFLT) (symin + ymin));
+    plsc->vpdyma = plP_mmdcy((PLFLT) (symin + ymax));
+
+    plsc->vppxmi = plP_dcpcx(plsc->vpdxmi);
+    plsc->vppxma = plP_dcpcx(plsc->vpdxma);
+    plsc->vppymi = plP_dcpcy(plsc->vpdymi);
+    plsc->vppyma = plP_dcpcy(plsc->vpdyma);
+
+    plsc->clpxmi = plP_dcpcx(plsc->vpdxmi);
+    plsc->clpxma = plP_dcpcx(plsc->vpdxma);
+    plsc->clpymi = plP_dcpcy(plsc->vpdymi);
+    plsc->clpyma = plP_dcpcy(plsc->vpdyma);
+
+    plsc->level = 2;
+}
diff --git a/collects/plot/src/all/plwind.c b/collects/plot/src/all/plwind.c
new file mode 100644
index 0000000000..c5a62a42f6
--- /dev/null
+++ b/collects/plot/src/all/plwind.c
@@ -0,0 +1,178 @@
+/* $Id: plwind.c,v 1.2 2005/03/17 21:39:22 eli Exp $
+
+	Routines for setting up world coordinates of the current viewport.
+*/
+
+#include "plplotP.h"
+
+#define  dtr   0.01745329252
+
+/*--------------------------------------------------------------------------*\
+ * void plwind()
+ *
+ * Set up world coordinates of the viewport boundaries (2d plots).
+\*--------------------------------------------------------------------------*/
+
+void
+c_plwind(PLFLT xmin, PLFLT xmax, PLFLT ymin, PLFLT ymax)
+{
+    PLFLT dx, dy, mmxmi, mmxma, mmymi, mmyma;
+    PLWindow w;
+
+    if (plsc->level < 2) {
+	plabort("plwind: Please set up viewport first");
+	return;
+    }
+
+/* Best to just warn and recover on bounds errors */
+
+    if (xmin == xmax) {
+	plwarn("plwind: Invalid window limits in x.");
+	xmin--; xmax++;
+    }
+    if (ymin == ymax) {
+	plwarn("plwind: Invalid window limits in y.");
+	ymin--; ymax++;
+    }
+
+    dx = (xmax - xmin) * 1.0e-5;
+    dy = (ymax - ymin) * 1.0e-5;
+
+/* The true plot window is made slightly larger than requested so that */
+/* the end limits will be on the graph  */
+
+    plsc->vpwxmi = xmin - dx;
+    plsc->vpwxma = xmax + dx;
+    plsc->vpwymi = ymin - dy;
+    plsc->vpwyma = ymax + dy;
+
+/* Compute the scaling between coordinate systems */
+
+    dx = plsc->vpwxma - plsc->vpwxmi;
+    dy = plsc->vpwyma - plsc->vpwymi;
+
+    plsc->wpxscl = (plsc->vppxma - plsc->vppxmi) / dx;
+    plsc->wpxoff = (xmax * plsc->vppxmi - xmin * plsc->vppxma) / dx;
+    plsc->wpyscl = (plsc->vppyma - plsc->vppymi) / dy;
+    plsc->wpyoff = (ymax * plsc->vppymi - ymin * plsc->vppyma) / dy;
+
+    mmxmi = plP_dcmmx(plsc->vpdxmi);
+    mmxma = plP_dcmmx(plsc->vpdxma);
+    mmymi = plP_dcmmy(plsc->vpdymi);
+    mmyma = plP_dcmmy(plsc->vpdyma);
+
+/* Set transformation variables for world coordinates to mm */
+
+    plsc->wmxscl = (mmxma - mmxmi) / dx;
+    plsc->wmxoff = (xmax * mmxmi - xmin * mmxma) / dx;
+    plsc->wmyscl = (mmyma - mmymi) / dy;
+    plsc->wmyoff = (ymax * mmymi - ymin * mmyma) / dy;
+
+/* Set transformation variables for world coordinates to device coords */
+
+    plsc->wdxscl = plsc->wmxscl * plsc->xpmm / (plsc->phyxma - plsc->phyxmi);
+    plsc->wdxoff = plsc->wmxoff * plsc->xpmm / (plsc->phyxma - plsc->phyxmi);
+    plsc->wdyscl = plsc->wmyscl * plsc->ypmm / (plsc->phyyma - plsc->phyymi);
+    plsc->wdyoff = plsc->wmyoff * plsc->ypmm / (plsc->phyyma - plsc->phyymi);
+
+/* Register plot window attributes */
+
+    w.dxmi = plsc->vpdxmi;
+    w.dxma = plsc->vpdxma;
+    w.dymi = plsc->vpdymi;
+    w.dyma = plsc->vpdyma;
+
+    w.wxmi = plsc->vpwxmi;
+    w.wxma = plsc->vpwxma;
+    w.wymi = plsc->vpwymi;
+    w.wyma = plsc->vpwyma;
+
+    plP_swin(&w);
+
+/* Go to level 3 */
+
+    plsc->level = 3;
+}
+
+/*--------------------------------------------------------------------------*\
+ * void plw3d()
+ *
+ * Set up a window for three-dimensional plotting. The data are mapped
+ * into a box with world coordinate size "basex" by "basey" by "height",
+ * with the base being symmetrically positioned about zero. Thus
+ * the mapping between data 3-d and world 3-d coordinates is given by:
+ *
+ *   x = xmin   =>   wx = -0.5*basex
+ *   x = xmax   =>   wx =  0.5*basex
+ *   y = ymin   =>   wy = -0.5*basey
+ *   y = ymax   =>   wy =  0.5*basey
+ *   z = zmin   =>   wz =  0.0
+ *   z = zmax   =>   wz =  height
+ *
+ * The world coordinate box is then viewed from position "alt"-"az",
+ * measured in degrees. For proper operation, 0 <= alt <= 90 degrees,
+ * but az can be any value.
+\*--------------------------------------------------------------------------*/
+
+MZ_DLLEXPORT
+void
+c_plw3d(PLFLT basex, PLFLT basey, PLFLT height, PLFLT xmin0,
+	PLFLT xmax0, PLFLT ymin0, PLFLT ymax0, PLFLT zmin0,
+	PLFLT zmax0, PLFLT alt, PLFLT az)
+{
+    PLFLT xmin, xmax, ymin, ymax, zmin, zmax, d;
+    PLFLT cx, cy, saz, caz, salt, calt, zscale;
+
+    if (plsc->level < 3) {
+	plabort("plw3d: Please set up 2-d window first");
+	return;
+    }
+    if (basex <= 0.0 || basey <= 0.0 || height <= 0.0) {
+	plabort("plw3d: Invalid world coordinate boxsize");
+	return;
+    }
+    if (xmin0 == xmax0 || ymin0 == ymax0 || zmin0 == zmax0) {
+	plabort("plw3d: Invalid axis range");
+	return;
+    }
+    if (alt < 0.0 || alt > 90.0) {
+	plabort("plw3d: Altitude must be between 0 and 90 degrees");
+	return;
+    }
+
+    d = 1.0e-5 * (xmax0 - xmin0);
+    xmax = xmax0 + d;
+    xmin = xmin0 - d;
+    d = 1.0e-5 * (ymax0 - ymin0);
+    ymax = ymax0 + d;
+    ymin = ymin0 - d;
+    d = 1.0e-5 * (zmax0 - zmin0);
+    zmax = zmax0 + d;
+    zmin = zmin0 - d;
+    cx = basex / (xmax - xmin);
+    cy = basey / (ymax - ymin);
+    zscale = height / (zmax - zmin);
+    saz = sin(dtr * az);
+    caz = cos(dtr * az);
+    salt = sin(dtr * alt);
+    calt = cos(dtr * alt);
+
+    plsc->domxmi = xmin;
+    plsc->domxma = xmax;
+    plsc->domymi = ymin;
+    plsc->domyma = ymax;
+    plsc->zzscl = zscale;
+    plsc->ranmi = zmin;
+    plsc->ranma = zmax;
+
+    plsc->base3x = basex;
+    plsc->base3y = basey;
+    plsc->basecx = 0.5 * (xmin + xmax);
+    plsc->basecy = 0.5 * (ymin + ymax);
+
+    plsc->cxx = cx * caz;
+    plsc->cxy = -cy * saz;
+    plsc->cyx = cx * saz * salt;
+    plsc->cyy = cy * caz * salt;
+    plsc->cyz = zscale * calt;
+}
diff --git a/collects/plot/src/all/plxwd.h b/collects/plot/src/all/plxwd.h
new file mode 100644
index 0000000000..05c33c0a2c
--- /dev/null
+++ b/collects/plot/src/all/plxwd.h
@@ -0,0 +1,108 @@
+/* $Id: plxwd.h,v 1.1 2004/03/01 20:54:53 cozmic Exp $
+
+	Holds system header includes, prototypes of xwin driver
+	utility functions, and definition of the state structure.
+*/
+
+#ifndef __PLXWD_H__
+#define __PLXWD_H__
+
+#include "plplot.h"
+#include "plstrm.h"
+#ifdef HAVE_PTHREAD
+#include <pthread.h>
+#endif
+
+/* System headers */
+
+#include <stdlib.h>
+#include <string.h>
+#include <sys/types.h>
+
+#include <X11/Xlib.h>
+#include <X11/Xutil.h>
+#include <X11/cursorfont.h>
+#include <X11/keysym.h>
+
+/* Specify max number of displays in use */
+
+#define PLXDISPLAYS 100
+
+/* Set constants for dealing with colormap.  In brief:
+ *
+ * ccmap		When set, turns on custom color map
+ *
+ * See Init_CustomCmap() and  Init_DefaultCmap() for more info.
+ * Set ccmap at your own risk -- still under development.
+ */
+
+static int plplot_ccmap = 0;
+
+
+/* One of these holds the display info, shared by all streams on a given */
+/* display */
+
+typedef struct {
+    int		nstreams;		/* Number of streams using display */
+    int		ixwd;			/* Specifies xwDisplay number */
+    char	*displayName;		/* Name of X display */
+    int		screen;			/* X screen */
+    Display	*display;		/* X display */
+    Visual	*visual;		/* X Visual */
+    GC		gcXor;			/* Graphics context for XOR draws */
+    Colormap	map;			/* Colormap */
+    unsigned	depth;			/* display depth */
+    int		color;			/* Set to 1 if a color output device */
+    int		ncol0;			/* Number of cmap 0 colors allocated */
+    int		ncol1;			/* Number of cmap 1 colors allocated */
+    XColor	cmap0[16];		/* Color entries for cmap 0 */
+    XColor	cmap1[256];		/* Color entries for cmap 1 */
+    XColor	fgcolor;		/* Foreground color (if grayscale) */
+    Cursor	xhair_cursor;		/* Crosshair cursor */
+    int		rw_cmap;		/* Can we allocate r/w color cells? */
+} XwDisplay;
+
+/* One of these holds the X driver state information */
+
+typedef struct {
+    XwDisplay	*xwd;			/* Pointer to display info */
+
+    int		is_main;		/* Set if the toplevel X window */
+    Window	window;			/* X window id */
+    Pixmap	pixmap;			/* Off-screen pixmap */
+    GC		gc;			/* Graphics context */
+    XColor	curcolor;		/* Current pen color */
+
+    long	event_mask;		/* Event mask */
+    int		exit_eventloop;		/* Breaks the event loop when set */
+    long	init_width;		/* Initial window width */
+    long	init_height;		/* Initial window height */
+
+    unsigned	width, height, border;	/* Current window dimensions */
+
+    double	xscale_init;		/* initial pixels/lx (virt. coords) */
+    double	yscale_init;		/* initial pixels/ly (virt. coords) */
+    double	xscale;			/* as above, but current value */
+    double	yscale;			/*  (after possible resizing)  */
+
+    short	xlen, ylen;		/* Lengths of device coord space */
+
+    int		write_to_window;	/* Set if plotting direct to window */
+    int		write_to_pixmap;	/* Set if plotting to pixmap */
+
+    int		instr;			/* Instruction timer */
+    int		max_instr;		/* Limit before X server is queried */
+
+    PLGraphicsIn gin;			/* Graphics input structure */
+
+    int		locate_mode;		/* Set while in locate mode */
+    int		drawing_xhairs;		/* Set during xhair draws */
+    XPoint	xhair_x[2], xhair_y[2];	/* Crosshair lines */
+
+    void (*MasterEH) (PLStream *, XEvent *);	/* Master X event handler */
+#ifdef HAVE_PTHREAD
+  pthread_t updater;                    /* The X events updater thread id */
+#endif
+} XwDev;
+
+#endif	/* __PLXWD_H__ */
diff --git a/collects/plot/src/all/png.c b/collects/plot/src/all/png.c
new file mode 100644
index 0000000000..2a55ccb798
--- /dev/null
+++ b/collects/plot/src/all/png.c
@@ -0,0 +1,805 @@
+
+/* png.c - location for general purpose libpng functions
+ *
+ * libpng version 1.2.5 - October 3, 2002
+ * Copyright (c) 1998-2002 Glenn Randers-Pehrson
+ * (Version 0.96 Copyright (c) 1996, 1997 Andreas Dilger)
+ * (Version 0.88 Copyright (c) 1995, 1996 Guy Eric Schalnat, Group 42, Inc.)
+ *
+ */
+
+#define PNG_INTERNAL
+#define PNG_NO_EXTERN
+#include "png.h"
+
+/* Generate a compiler error if there is an old png.h in the search path. */
+typedef version_1_2_5 Your_png_h_is_not_version_1_2_5;
+
+/* Version information for C files.  This had better match the version
+ * string defined in png.h.  */
+
+#ifdef PNG_USE_GLOBAL_ARRAYS
+/* png_libpng_ver was changed to a function in version 1.0.5c */
+const char png_libpng_ver[18] = "1.2.5";
+
+/* png_sig was changed to a function in version 1.0.5c */
+/* Place to hold the signature string for a PNG file. */
+const png_byte FARDATA png_sig[8] = {137, 80, 78, 71, 13, 10, 26, 10};
+
+/* Invoke global declarations for constant strings for known chunk types */
+PNG_IHDR;
+PNG_IDAT;
+PNG_IEND;
+PNG_PLTE;
+PNG_bKGD;
+PNG_cHRM;
+PNG_gAMA;
+PNG_hIST;
+PNG_iCCP;
+PNG_iTXt;
+PNG_oFFs;
+PNG_pCAL;
+PNG_sCAL;
+PNG_pHYs;
+PNG_sBIT;
+PNG_sPLT;
+PNG_sRGB;
+PNG_tEXt;
+PNG_tIME;
+PNG_tRNS;
+PNG_zTXt;
+
+/* arrays to facilitate easy interlacing - use pass (0 - 6) as index */
+
+/* start of interlace block */
+const int FARDATA png_pass_start[] = {0, 4, 0, 2, 0, 1, 0};
+
+/* offset to next interlace block */
+const int FARDATA png_pass_inc[] = {8, 8, 4, 4, 2, 2, 1};
+
+/* start of interlace block in the y direction */
+const int FARDATA png_pass_ystart[] = {0, 0, 4, 0, 2, 0, 1};
+
+/* offset to next interlace block in the y direction */
+const int FARDATA png_pass_yinc[] = {8, 8, 8, 4, 4, 2, 2};
+
+/* width of interlace block (used in assembler routines only) */
+#ifdef PNG_HAVE_ASSEMBLER_COMBINE_ROW
+const int FARDATA png_pass_width[] = {8, 4, 4, 2, 2, 1, 1};
+#endif
+
+/* Height of interlace block.  This is not currently used - if you need
+ * it, uncomment it here and in png.h
+const int FARDATA png_pass_height[] = {8, 8, 4, 4, 2, 2, 1};
+*/
+
+/* Mask to determine which pixels are valid in a pass */
+const int FARDATA png_pass_mask[] = {0x80, 0x08, 0x88, 0x22, 0xaa, 0x55, 0xff};
+
+/* Mask to determine which pixels to overwrite while displaying */
+const int FARDATA png_pass_dsp_mask[]
+   = {0xff, 0x0f, 0xff, 0x33, 0xff, 0x55, 0xff};
+
+#endif
+
+/* Tells libpng that we have already handled the first "num_bytes" bytes
+ * of the PNG file signature.  If the PNG data is embedded into another
+ * stream we can set num_bytes = 8 so that libpng will not attempt to read
+ * or write any of the magic bytes before it starts on the IHDR.
+ */
+
+void PNGAPI
+png_set_sig_bytes(png_structp png_ptr, int num_bytes)
+{
+   png_debug(1, "in png_set_sig_bytes\n");
+   if (num_bytes > 8)
+      png_error(png_ptr, "Too many bytes for PNG signature.");
+
+   png_ptr->sig_bytes = (png_byte)(num_bytes < 0 ? 0 : num_bytes);
+}
+
+/* Checks whether the supplied bytes match the PNG signature.  We allow
+ * checking less than the full 8-byte signature so that those apps that
+ * already read the first few bytes of a file to determine the file type
+ * can simply check the remaining bytes for extra assurance.  Returns
+ * an integer less than, equal to, or greater than zero if sig is found,
+ * respectively, to be less than, to match, or be greater than the correct
+ * PNG signature (this is the same behaviour as strcmp, memcmp, etc).
+ */
+int PNGAPI
+png_sig_cmp(png_bytep sig, png_size_t start, png_size_t num_to_check)
+{
+   png_byte png_signature[8] = {137, 80, 78, 71, 13, 10, 26, 10};
+   if (num_to_check > 8)
+      num_to_check = 8;
+   else if (num_to_check < 1)
+      return (0);
+
+   if (start > 7)
+      return (0);
+
+   if (start + num_to_check > 8)
+      num_to_check = 8 - start;
+
+   return ((int)(png_memcmp(&sig[start], &png_signature[start], num_to_check)));
+}
+
+/* (Obsolete) function to check signature bytes.  It does not allow one
+ * to check a partial signature.  This function might be removed in the
+ * future - use png_sig_cmp().  Returns true (nonzero) if the file is a PNG.
+ */
+int PNGAPI
+png_check_sig(png_bytep sig, int num)
+{
+  return ((int)!png_sig_cmp(sig, (png_size_t)0, (png_size_t)num));
+}
+
+/* Function to allocate memory for zlib and clear it to 0. */
+#ifdef PNG_1_0_X
+voidpf PNGAPI
+#else
+voidpf /* private */
+#endif
+png_zalloc(voidpf png_ptr, uInt items, uInt size)
+{
+   png_uint_32 num_bytes = (png_uint_32)items * size;
+   png_voidp ptr;
+   png_structp p=png_ptr;
+   png_uint_32 save_flags=p->flags;
+
+   p->flags|=PNG_FLAG_MALLOC_NULL_MEM_OK;
+   ptr = (png_voidp)png_malloc((png_structp)png_ptr, num_bytes);
+   p->flags=save_flags;
+
+#ifndef PNG_NO_ZALLOC_ZERO
+   if (ptr == NULL)
+       return ((voidpf)ptr);
+
+   if (num_bytes > (png_uint_32)0x8000L)
+   {
+      png_memset(ptr, 0, (png_size_t)0x8000L);
+      png_memset((png_bytep)ptr + (png_size_t)0x8000L, 0,
+         (png_size_t)(num_bytes - (png_uint_32)0x8000L));
+   }
+   else
+   {
+      png_memset(ptr, 0, (png_size_t)num_bytes);
+   }
+#endif
+   return ((voidpf)ptr);
+}
+
+/* function to free memory for zlib */
+#ifdef PNG_1_0_X
+void PNGAPI
+#else
+void /* private */
+#endif
+png_zfree(voidpf png_ptr, voidpf ptr)
+{
+   png_free((png_structp)png_ptr, (png_voidp)ptr);
+}
+
+/* Reset the CRC variable to 32 bits of 1's.  Care must be taken
+ * in case CRC is > 32 bits to leave the top bits 0.
+ */
+void /* PRIVATE */
+png_reset_crc(png_structp png_ptr)
+{
+   png_ptr->crc = crc32(0, Z_NULL, 0);
+}
+
+/* Calculate the CRC over a section of data.  We can only pass as
+ * much data to this routine as the largest single buffer size.  We
+ * also check that this data will actually be used before going to the
+ * trouble of calculating it.
+ */
+void /* PRIVATE */
+png_calculate_crc(png_structp png_ptr, png_bytep ptr, png_size_t length)
+{
+   int need_crc = 1;
+
+   if (png_ptr->chunk_name[0] & 0x20)                     /* ancillary */
+   {
+      if ((png_ptr->flags & PNG_FLAG_CRC_ANCILLARY_MASK) ==
+          (PNG_FLAG_CRC_ANCILLARY_USE | PNG_FLAG_CRC_ANCILLARY_NOWARN))
+         need_crc = 0;
+   }
+   else                                                    /* critical */
+   {
+      if (png_ptr->flags & PNG_FLAG_CRC_CRITICAL_IGNORE)
+         need_crc = 0;
+   }
+
+   if (need_crc)
+      png_ptr->crc = crc32(png_ptr->crc, ptr, (uInt)length);
+}
+
+/* Allocate the memory for an info_struct for the application.  We don't
+ * really need the png_ptr, but it could potentially be useful in the
+ * future.  This should be used in favour of malloc(sizeof(png_info))
+ * and png_info_init() so that applications that want to use a shared
+ * libpng don't have to be recompiled if png_info changes size.
+ */
+png_infop PNGAPI
+png_create_info_struct(png_structp png_ptr)
+{
+   png_infop info_ptr;
+
+   png_debug(1, "in png_create_info_struct\n");
+   if(png_ptr == NULL) return (NULL);
+#ifdef PNG_USER_MEM_SUPPORTED
+   info_ptr = (png_infop)png_create_struct_2(PNG_STRUCT_INFO,
+      png_ptr->malloc_fn, png_ptr->mem_ptr);
+#else
+   info_ptr = (png_infop)png_create_struct(PNG_STRUCT_INFO);
+#endif
+   if (info_ptr != NULL)
+      png_info_init_3(&info_ptr, sizeof(png_info));
+
+   return (info_ptr);
+}
+
+/* This function frees the memory associated with a single info struct.
+ * Normally, one would use either png_destroy_read_struct() or
+ * png_destroy_write_struct() to free an info struct, but this may be
+ * useful for some applications.
+ */
+void PNGAPI
+png_destroy_info_struct(png_structp png_ptr, png_infopp info_ptr_ptr)
+{
+   png_infop info_ptr = NULL;
+
+   png_debug(1, "in png_destroy_info_struct\n");
+   if (info_ptr_ptr != NULL)
+      info_ptr = *info_ptr_ptr;
+
+   if (info_ptr != NULL)
+   {
+      png_info_destroy(png_ptr, info_ptr);
+
+#ifdef PNG_USER_MEM_SUPPORTED
+      png_destroy_struct_2((png_voidp)info_ptr, png_ptr->free_fn,
+          png_ptr->mem_ptr);
+#else
+      png_destroy_struct((png_voidp)info_ptr);
+#endif
+      *info_ptr_ptr = NULL;
+   }
+}
+
+/* Initialize the info structure.  This is now an internal function (0.89)
+ * and applications using it are urged to use png_create_info_struct()
+ * instead.
+ */
+#undef png_info_init
+void PNGAPI
+png_info_init(png_infop info_ptr)
+{
+   /* We only come here via pre-1.0.12-compiled applications */
+   png_info_init_3(&info_ptr, 0);
+}
+
+void PNGAPI
+png_info_init_3(png_infopp ptr_ptr, png_size_t png_info_struct_size)
+{
+   png_infop info_ptr = *ptr_ptr;
+
+   png_debug(1, "in png_info_init_3\n");
+
+   if(sizeof(png_info) > png_info_struct_size)
+     {
+       png_destroy_struct(info_ptr);
+       info_ptr = (png_infop)png_create_struct(PNG_STRUCT_INFO);
+       *ptr_ptr = info_ptr;
+     }
+
+   /* set everything to 0 */
+   png_memset(info_ptr, 0, sizeof (png_info));
+}
+
+#ifdef PNG_FREE_ME_SUPPORTED
+void PNGAPI
+png_data_freer(png_structp png_ptr, png_infop info_ptr,
+   int freer, png_uint_32 mask)
+{
+   png_debug(1, "in png_data_freer\n");
+   if (png_ptr == NULL || info_ptr == NULL)
+      return;
+   if(freer == PNG_DESTROY_WILL_FREE_DATA)
+      info_ptr->free_me |= mask;
+   else if(freer == PNG_USER_WILL_FREE_DATA)
+      info_ptr->free_me &= ~mask;
+   else
+      png_warning(png_ptr,
+         "Unknown freer parameter in png_data_freer.");
+}
+#endif
+
+void PNGAPI
+png_free_data(png_structp png_ptr, png_infop info_ptr, png_uint_32 mask,
+   int num)
+{
+   png_debug(1, "in png_free_data\n");
+   if (png_ptr == NULL || info_ptr == NULL)
+      return;
+
+#if defined(PNG_TEXT_SUPPORTED)
+/* free text item num or (if num == -1) all text items */
+#ifdef PNG_FREE_ME_SUPPORTED
+if ((mask & PNG_FREE_TEXT) & info_ptr->free_me)
+#else
+if (mask & PNG_FREE_TEXT)
+#endif
+{
+   if (num != -1)
+   {
+     if (info_ptr->text && info_ptr->text[num].key)
+     {
+         png_free(png_ptr, info_ptr->text[num].key);
+         info_ptr->text[num].key = NULL;
+     }
+   }
+   else
+   {
+       int i;
+       for (i = 0; i < info_ptr->num_text; i++)
+           png_free_data(png_ptr, info_ptr, PNG_FREE_TEXT, i);
+       png_free(png_ptr, info_ptr->text);
+       info_ptr->text = NULL;
+       info_ptr->num_text=0;
+   }
+}
+#endif
+
+#if defined(PNG_tRNS_SUPPORTED)
+/* free any tRNS entry */
+#ifdef PNG_FREE_ME_SUPPORTED
+if ((mask & PNG_FREE_TRNS) & info_ptr->free_me)
+#else
+if ((mask & PNG_FREE_TRNS) && (png_ptr->flags & PNG_FLAG_FREE_TRNS))
+#endif
+{
+    png_free(png_ptr, info_ptr->trans);
+    info_ptr->valid &= ~PNG_INFO_tRNS;
+#ifndef PNG_FREE_ME_SUPPORTED
+    png_ptr->flags &= ~PNG_FLAG_FREE_TRNS;
+#endif
+    info_ptr->trans = NULL;
+}
+#endif
+
+#if defined(PNG_sCAL_SUPPORTED)
+/* free any sCAL entry */
+#ifdef PNG_FREE_ME_SUPPORTED
+if ((mask & PNG_FREE_SCAL) & info_ptr->free_me)
+#else
+if (mask & PNG_FREE_SCAL)
+#endif
+{
+#if defined(PNG_FIXED_POINT_SUPPORTED) && !defined(PNG_FLOATING_POINT_SUPPORTED)
+    png_free(png_ptr, info_ptr->scal_s_width);
+    png_free(png_ptr, info_ptr->scal_s_height);
+    info_ptr->scal_s_width = NULL;
+    info_ptr->scal_s_height = NULL;
+#endif
+    info_ptr->valid &= ~PNG_INFO_sCAL;
+}
+#endif
+
+#if defined(PNG_pCAL_SUPPORTED)
+/* free any pCAL entry */
+#ifdef PNG_FREE_ME_SUPPORTED
+if ((mask & PNG_FREE_PCAL) & info_ptr->free_me)
+#else
+if (mask & PNG_FREE_PCAL)
+#endif
+{
+    png_free(png_ptr, info_ptr->pcal_purpose);
+    png_free(png_ptr, info_ptr->pcal_units);
+    info_ptr->pcal_purpose = NULL;
+    info_ptr->pcal_units = NULL;
+    if (info_ptr->pcal_params != NULL)
+    {
+        int i;
+        for (i = 0; i < (int)info_ptr->pcal_nparams; i++)
+        {
+          png_free(png_ptr, info_ptr->pcal_params[i]);
+          info_ptr->pcal_params[i]=NULL;
+        }
+        png_free(png_ptr, info_ptr->pcal_params);
+        info_ptr->pcal_params = NULL;
+    }
+    info_ptr->valid &= ~PNG_INFO_pCAL;
+}
+#endif
+
+#if defined(PNG_iCCP_SUPPORTED)
+/* free any iCCP entry */
+#ifdef PNG_FREE_ME_SUPPORTED
+if ((mask & PNG_FREE_ICCP) & info_ptr->free_me)
+#else
+if (mask & PNG_FREE_ICCP)
+#endif
+{
+    png_free(png_ptr, info_ptr->iccp_name);
+    png_free(png_ptr, info_ptr->iccp_profile);
+    info_ptr->iccp_name = NULL;
+    info_ptr->iccp_profile = NULL;
+    info_ptr->valid &= ~PNG_INFO_iCCP;
+}
+#endif
+
+#if defined(PNG_sPLT_SUPPORTED)
+/* free a given sPLT entry, or (if num == -1) all sPLT entries */
+#ifdef PNG_FREE_ME_SUPPORTED
+if ((mask & PNG_FREE_SPLT) & info_ptr->free_me)
+#else
+if (mask & PNG_FREE_SPLT)
+#endif
+{
+   if (num != -1)
+   {
+      if(info_ptr->splt_palettes)
+      {
+          png_free(png_ptr, info_ptr->splt_palettes[num].name);
+          png_free(png_ptr, info_ptr->splt_palettes[num].entries);
+          info_ptr->splt_palettes[num].name = NULL;
+          info_ptr->splt_palettes[num].entries = NULL;
+      }
+   }
+   else
+   {
+       if(info_ptr->splt_palettes_num)
+       {
+         int i;
+         for (i = 0; i < (int)info_ptr->splt_palettes_num; i++)
+            png_free_data(png_ptr, info_ptr, PNG_FREE_SPLT, i);
+
+         png_free(png_ptr, info_ptr->splt_palettes);
+         info_ptr->splt_palettes = NULL;
+         info_ptr->splt_palettes_num = 0;
+       }
+       info_ptr->valid &= ~PNG_INFO_sPLT;
+   }
+}
+#endif
+
+#if defined(PNG_UNKNOWN_CHUNKS_SUPPORTED)
+#ifdef PNG_FREE_ME_SUPPORTED
+if ((mask & PNG_FREE_UNKN) & info_ptr->free_me)
+#else
+if (mask & PNG_FREE_UNKN)
+#endif
+{
+   if (num != -1)
+   {
+       if(info_ptr->unknown_chunks)
+       {
+          png_free(png_ptr, info_ptr->unknown_chunks[num].data);
+          info_ptr->unknown_chunks[num].data = NULL;
+       }
+   }
+   else
+   {
+       int i;
+
+       if(info_ptr->unknown_chunks_num)
+       {
+         for (i = 0; i < (int)info_ptr->unknown_chunks_num; i++)
+            png_free_data(png_ptr, info_ptr, PNG_FREE_UNKN, i);
+
+         png_free(png_ptr, info_ptr->unknown_chunks);
+         info_ptr->unknown_chunks = NULL;
+         info_ptr->unknown_chunks_num = 0;
+       }
+   }
+}
+#endif
+
+#if defined(PNG_hIST_SUPPORTED)
+/* free any hIST entry */
+#ifdef PNG_FREE_ME_SUPPORTED
+if ((mask & PNG_FREE_HIST)  & info_ptr->free_me)
+#else
+if ((mask & PNG_FREE_HIST) && (png_ptr->flags & PNG_FLAG_FREE_HIST))
+#endif
+{
+    png_free(png_ptr, info_ptr->hist);
+    info_ptr->hist = NULL;
+    info_ptr->valid &= ~PNG_INFO_hIST;
+#ifndef PNG_FREE_ME_SUPPORTED
+    png_ptr->flags &= ~PNG_FLAG_FREE_HIST;
+#endif
+}
+#endif
+
+/* free any PLTE entry that was internally allocated */
+#ifdef PNG_FREE_ME_SUPPORTED
+if ((mask & PNG_FREE_PLTE) & info_ptr->free_me)
+#else
+if ((mask & PNG_FREE_PLTE) && (png_ptr->flags & PNG_FLAG_FREE_PLTE))
+#endif
+{
+    png_zfree(png_ptr, info_ptr->palette);
+    info_ptr->palette = NULL;
+    info_ptr->valid &= ~PNG_INFO_PLTE;
+#ifndef PNG_FREE_ME_SUPPORTED
+    png_ptr->flags &= ~PNG_FLAG_FREE_PLTE;
+#endif
+    info_ptr->num_palette = 0;
+}
+
+#if defined(PNG_INFO_IMAGE_SUPPORTED)
+/* free any image bits attached to the info structure */
+#ifdef PNG_FREE_ME_SUPPORTED
+if ((mask & PNG_FREE_ROWS) & info_ptr->free_me)
+#else
+if (mask & PNG_FREE_ROWS)
+#endif
+{
+    if(info_ptr->row_pointers)
+    {
+       int row;
+       for (row = 0; row < (int)info_ptr->height; row++)
+       {
+          png_free(png_ptr, info_ptr->row_pointers[row]);
+          info_ptr->row_pointers[row]=NULL;
+       }
+       png_free(png_ptr, info_ptr->row_pointers);
+       info_ptr->row_pointers=NULL;
+    }
+    info_ptr->valid &= ~PNG_INFO_IDAT;
+}
+#endif
+
+#ifdef PNG_FREE_ME_SUPPORTED
+   if(num == -1)
+     info_ptr->free_me &= ~mask;
+   else
+     info_ptr->free_me &= ~(mask & ~PNG_FREE_MUL);
+#endif
+}
+
+/* This is an internal routine to free any memory that the info struct is
+ * pointing to before re-using it or freeing the struct itself.  Recall
+ * that png_free() checks for NULL pointers for us.
+ */
+void /* PRIVATE */
+png_info_destroy(png_structp png_ptr, png_infop info_ptr)
+{
+   png_debug(1, "in png_info_destroy\n");
+
+   png_free_data(png_ptr, info_ptr, PNG_FREE_ALL, -1);
+
+#if defined(PNG_UNKNOWN_CHUNKS_SUPPORTED)
+   if (png_ptr->num_chunk_list)
+   {
+       png_free(png_ptr, png_ptr->chunk_list);
+       png_ptr->chunk_list=NULL;
+       png_ptr->num_chunk_list=0;
+   }
+#endif
+
+   png_info_init_3(&info_ptr, sizeof(png_info));
+}
+
+/* This function returns a pointer to the io_ptr associated with the user
+ * functions.  The application should free any memory associated with this
+ * pointer before png_write_destroy() or png_read_destroy() are called.
+ */
+png_voidp PNGAPI
+png_get_io_ptr(png_structp png_ptr)
+{
+   return (png_ptr->io_ptr);
+}
+
+#if !defined(PNG_NO_STDIO)
+/* Initialize the default input/output functions for the PNG file.  If you
+ * use your own read or write routines, you can call either png_set_read_fn()
+ * or png_set_write_fn() instead of png_init_io().  If you have defined
+ * PNG_NO_STDIO, you must use a function of your own because "FILE *" isn't
+ * necessarily available.
+ */
+void PNGAPI
+png_init_io(png_structp png_ptr, png_FILE_p fp)
+{
+   png_debug(1, "in png_init_io\n");
+   png_ptr->io_ptr = (png_voidp)fp;
+}
+#endif
+
+#if defined(PNG_TIME_RFC1123_SUPPORTED)
+/* Convert the supplied time into an RFC 1123 string suitable for use in
+ * a "Creation Time" or other text-based time string.
+ */
+png_charp PNGAPI
+png_convert_to_rfc1123(png_structp png_ptr, png_timep ptime)
+{
+   static PNG_CONST char short_months[12][4] =
+        {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
+         "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
+
+   if (png_ptr->time_buffer == NULL)
+   {
+      png_ptr->time_buffer = (png_charp)png_malloc(png_ptr, (png_uint_32)(29*
+         sizeof(char)));
+   }
+
+#if defined(_WIN32_WCE)
+   {
+      wchar_t time_buf[29];
+      wsprintf(time_buf, TEXT("%d %S %d %02d:%02d:%02d +0000"),
+          ptime->day % 32, short_months[(ptime->month - 1) % 12],
+        ptime->year, ptime->hour % 24, ptime->minute % 60,
+          ptime->second % 61);
+      WideCharToMultiByte(CP_ACP, 0, time_buf, -1, png_ptr->time_buffer, 29,
+          NULL, NULL);
+   }
+#else
+#ifdef USE_FAR_KEYWORD
+   {
+      char near_time_buf[29];
+      sprintf(near_time_buf, "%d %s %d %02d:%02d:%02d +0000",
+          ptime->day % 32, short_months[(ptime->month - 1) % 12],
+          ptime->year, ptime->hour % 24, ptime->minute % 60,
+          ptime->second % 61);
+      png_memcpy(png_ptr->time_buffer, near_time_buf,
+          29*sizeof(char));
+   }
+#else
+   sprintf(png_ptr->time_buffer, "%d %s %d %02d:%02d:%02d +0000",
+       ptime->day % 32, short_months[(ptime->month - 1) % 12],
+       ptime->year, ptime->hour % 24, ptime->minute % 60,
+       ptime->second % 61);
+#endif
+#endif /* _WIN32_WCE */
+   return ((png_charp)png_ptr->time_buffer);
+}
+#endif /* PNG_TIME_RFC1123_SUPPORTED */
+
+#if 0
+/* Signature string for a PNG file. */
+png_bytep PNGAPI
+png_sig_bytes(void)
+{
+   return ((png_bytep)"\211\120\116\107\015\012\032\012");
+}
+#endif
+
+png_charp PNGAPI
+png_get_copyright(png_structp png_ptr)
+{
+   if (png_ptr != NULL || png_ptr == NULL)  /* silence compiler warning */
+   return ((png_charp) "\n libpng version 1.2.5 - October 3, 2002\n\
+   Copyright (c) 1998-2002 Glenn Randers-Pehrson\n\
+   Copyright (c) 1996-1997 Andreas Dilger\n\
+   Copyright (c) 1995-1996 Guy Eric Schalnat, Group 42, Inc.\n");
+   return ((png_charp) "");
+}
+
+/* The following return the library version as a short string in the
+ * format 1.0.0 through 99.99.99zz.  To get the version of *.h files used
+ * with your application, print out PNG_LIBPNG_VER_STRING, which is defined
+ * in png.h.
+ */
+
+png_charp PNGAPI
+png_get_libpng_ver(png_structp png_ptr)
+{
+   /* Version of *.c files used when building libpng */
+   if(png_ptr != NULL) /* silence compiler warning about unused png_ptr */
+      return((png_charp) "1.2.5");
+   return((png_charp) "1.2.5");
+}
+
+png_charp PNGAPI
+png_get_header_ver(png_structp png_ptr)
+{
+   /* Version of *.h files used when building libpng */
+   if(png_ptr != NULL) /* silence compiler warning about unused png_ptr */
+      return((png_charp) PNG_LIBPNG_VER_STRING);
+   return((png_charp) PNG_LIBPNG_VER_STRING);
+}
+
+png_charp PNGAPI
+png_get_header_version(png_structp png_ptr)
+{
+   /* Returns longer string containing both version and date */
+   if(png_ptr != NULL) /* silence compiler warning about unused png_ptr */
+      return((png_charp) PNG_HEADER_VERSION_STRING);
+   return((png_charp) PNG_HEADER_VERSION_STRING);
+}
+
+#ifdef PNG_HANDLE_AS_UNKNOWN_SUPPORTED
+int PNGAPI
+png_handle_as_unknown(png_structp png_ptr, png_bytep chunk_name)
+{
+   /* check chunk_name and return "keep" value if it's on the list, else 0 */
+   int i;
+   png_bytep p;
+   if((png_ptr == NULL && chunk_name == NULL) || png_ptr->num_chunk_list<=0)
+      return 0;
+   p=png_ptr->chunk_list+png_ptr->num_chunk_list*5-5;
+   for (i = png_ptr->num_chunk_list; i; i--, p-=5)
+      if (!png_memcmp(chunk_name, p, 4))
+        return ((int)*(p+4));
+   return 0;
+}
+#endif
+
+/* This function, added to libpng-1.0.6g, is untested. */
+int PNGAPI
+png_reset_zstream(png_structp png_ptr)
+{
+   return (inflateReset(&png_ptr->zstream));
+}
+
+/* This function was added to libpng-1.0.7 */
+png_uint_32 PNGAPI
+png_access_version_number(void)
+{
+   /* Version of *.c files used when building libpng */
+   return((png_uint_32) 10205L);
+}
+
+
+#if !defined(PNG_1_0_X)
+#if defined(PNG_ASSEMBLER_CODE_SUPPORTED)
+    /* GRR:  could add this:   && defined(PNG_MMX_CODE_SUPPORTED) */
+/* this INTERNAL function was added to libpng 1.2.0 */
+void /* PRIVATE */
+png_init_mmx_flags (png_structp png_ptr)
+{
+    png_ptr->mmx_rowbytes_threshold = 0;
+    png_ptr->mmx_bitdepth_threshold = 0;
+
+#  if (defined(PNG_USE_PNGVCRD) || defined(PNG_USE_PNGGCCRD))
+
+    png_ptr->asm_flags |= PNG_ASM_FLAG_MMX_SUPPORT_COMPILED;
+
+    if (png_mmx_support() > 0) {
+        png_ptr->asm_flags |= PNG_ASM_FLAG_MMX_SUPPORT_IN_CPU
+#    ifdef PNG_HAVE_ASSEMBLER_COMBINE_ROW
+                              | PNG_ASM_FLAG_MMX_READ_COMBINE_ROW
+#    endif
+#    ifdef PNG_HAVE_ASSEMBLER_READ_INTERLACE
+                              | PNG_ASM_FLAG_MMX_READ_INTERLACE
+#    endif
+#    ifndef PNG_HAVE_ASSEMBLER_READ_FILTER_ROW
+                              ;
+#    else
+                              | PNG_ASM_FLAG_MMX_READ_FILTER_SUB
+                              | PNG_ASM_FLAG_MMX_READ_FILTER_UP
+                              | PNG_ASM_FLAG_MMX_READ_FILTER_AVG
+                              | PNG_ASM_FLAG_MMX_READ_FILTER_PAETH ;
+
+        png_ptr->mmx_rowbytes_threshold = PNG_MMX_ROWBYTES_THRESHOLD_DEFAULT;
+        png_ptr->mmx_bitdepth_threshold = PNG_MMX_BITDEPTH_THRESHOLD_DEFAULT;
+#    endif
+    } else {
+        png_ptr->asm_flags &= ~( PNG_ASM_FLAG_MMX_SUPPORT_IN_CPU
+                               | PNG_MMX_READ_FLAGS
+                               | PNG_MMX_WRITE_FLAGS );
+    }
+
+#  else /* !((PNGVCRD || PNGGCCRD) && PNG_ASSEMBLER_CODE_SUPPORTED)) */
+
+    /* clear all MMX flags; no support is compiled in */
+    png_ptr->asm_flags &= ~( PNG_MMX_FLAGS );
+
+#  endif /* ?(PNGVCRD || PNGGCCRD) */
+}
+
+#endif /* !(PNG_ASSEMBLER_CODE_SUPPORTED) */
+
+/* this function was added to libpng 1.2.0 */
+#if !defined(PNG_USE_PNGGCCRD) && \
+    !(defined(PNG_ASSEMBLER_CODE_SUPPORTED) && defined(PNG_USE_PNGVCRD))
+int PNGAPI
+png_mmx_support(void)
+{
+    return -1;
+}
+#endif
+#endif /* PNG_1_0_X */
diff --git a/collects/plot/src/all/png.h b/collects/plot/src/all/png.h
new file mode 100644
index 0000000000..f059910e62
--- /dev/null
+++ b/collects/plot/src/all/png.h
@@ -0,0 +1,3283 @@
+/* png.h - header file for PNG reference library
+ *
+ * libpng version 1.2.5 - October 3, 2002
+ * Copyright (c) 1998-2002 Glenn Randers-Pehrson
+ * (Version 0.96 Copyright (c) 1996, 1997 Andreas Dilger)
+ * (Version 0.88 Copyright (c) 1995, 1996 Guy Eric Schalnat, Group 42, Inc.)
+ *
+ * Authors and maintainers:
+ *  libpng versions 0.71, May 1995, through 0.88, January 1996: Guy Schalnat
+ *  libpng versions 0.89c, June 1996, through 0.96, May 1997: Andreas Dilger
+ *  libpng versions 0.97, January 1998, through 1.2.5 - October 3, 2002: Glenn
+ *  See also "Contributing Authors", below.
+ *
+ * Note about libpng version numbers:
+ *
+ *    Due to various miscommunications, unforeseen code incompatibilities
+ *    and occasional factors outside the authors' control, version numbering
+ *    on the library has not always been consistent and straightforward.
+ *    The following table summarizes matters since version 0.89c, which was
+ *    the first widely used release:
+ *
+ *    source                 png.h  png.h  shared-lib
+ *    version                string   int  version
+ *    -------                ------ -----  ----------
+ *    0.89c "1.0 beta 3"     0.89      89  1.0.89
+ *    0.90  "1.0 beta 4"     0.90      90  0.90  [should have been 2.0.90]
+ *    0.95  "1.0 beta 5"     0.95      95  0.95  [should have been 2.0.95]
+ *    0.96  "1.0 beta 6"     0.96      96  0.96  [should have been 2.0.96]
+ *    0.97b "1.00.97 beta 7" 1.00.97   97  1.0.1 [should have been 2.0.97]
+ *    0.97c                  0.97      97  2.0.97
+ *    0.98                   0.98      98  2.0.98
+ *    0.99                   0.99      98  2.0.99
+ *    0.99a-m                0.99      99  2.0.99
+ *    1.00                   1.00     100  2.1.0 [100 should be 10000]
+ *    1.0.0      (from here on, the   100  2.1.0 [100 should be 10000]
+ *    1.0.1       png.h string is   10001  2.1.0
+ *    1.0.1a-e    identical to the  10002  from here on, the shared library
+ *    1.0.2       source version)   10002  is 2.V where V is the source code
+ *    1.0.2a-b                      10003  version, except as noted.
+ *    1.0.3                         10003
+ *    1.0.3a-d                      10004
+ *    1.0.4                         10004
+ *    1.0.4a-f                      10005
+ *    1.0.5 (+ 2 patches)           10005
+ *    1.0.5a-d                      10006
+ *    1.0.5e-r                      10100 (not source compatible)
+ *    1.0.5s-v                      10006 (not binary compatible)
+ *    1.0.6 (+ 3 patches)           10006 (still binary incompatible)
+ *    1.0.6d-f                      10007 (still binary incompatible)
+ *    1.0.6g                        10007
+ *    1.0.6h                        10007  10.6h (testing xy.z so-numbering)
+ *    1.0.6i                        10007  10.6i
+ *    1.0.6j                        10007  2.1.0.6j (incompatible with 1.0.0)
+ *    1.0.7beta11-14        DLLNUM  10007  2.1.0.7beta11-14 (binary compatible)
+ *    1.0.7beta15-18           1    10007  2.1.0.7beta15-18 (binary compatible)
+ *    1.0.7rc1-2               1    10007  2.1.0.7rc1-2 (binary compatible)
+ *    1.0.7                    1    10007  (still compatible)
+ *    1.0.8beta1-4             1    10008  2.1.0.8beta1-4
+ *    1.0.8rc1                 1    10008  2.1.0.8rc1
+ *    1.0.8                    1    10008  2.1.0.8
+ *    1.0.9beta1-6             1    10009  2.1.0.9beta1-6
+ *    1.0.9rc1                 1    10009  2.1.0.9rc1
+ *    1.0.9beta7-10            1    10009  2.1.0.9beta7-10
+ *    1.0.9rc2                 1    10009  2.1.0.9rc2
+ *    1.0.9                    1    10009  2.1.0.9
+ *    1.0.10beta1              1    10010  2.1.0.10beta1
+ *    1.0.10rc1                1    10010  2.1.0.10rc1
+ *    1.0.10                   1    10010  2.1.0.10
+ *    1.0.11beta1-3            1    10011  2.1.0.11beta1-3
+ *    1.0.11rc1                1    10011  2.1.0.11rc1
+ *    1.0.11                   1    10011  2.1.0.11
+ *    1.0.12beta1-2            2    10012  2.1.0.12beta1-2
+ *    1.0.12rc1                2    10012  2.1.0.12rc1
+ *    1.0.12                   2    10012  2.1.0.12
+ *    1.1.0a-f                 -    10100  2.1.1.0a-f (branch abandoned)
+ *    1.2.0beta1-2             2    10200  2.1.2.0beta1-2
+ *    1.2.0beta3-5             3    10200  3.1.2.0beta3-5
+ *    1.2.0rc1                 3    10200  3.1.2.0rc1
+ *    1.2.0                    3    10200  3.1.2.0
+ *    1.2.1beta1-4             3    10201  3.1.2.1beta1-4
+ *    1.2.1rc1-2               3    10201  3.1.2.1rc1-2
+ *    1.2.1                    3    10201  3.1.2.1
+ *    1.2.2beta1-6            12    10202  12.so.0.1.2.2beta1-6
+ *    1.0.13beta1             10    10013  10.so.0.1.0.13beta1
+ *    1.0.13rc1               10    10013  10.so.0.1.0.13rc1
+ *    1.2.2rc1                12    10202  12.so.0.1.2.2rc1
+ *    1.0.13                  10    10013  10.so.0.1.0.13
+ *    1.2.2                   12    10202  12.so.0.1.2.2
+ *    1.2.3rc1-6              12    10203  12.so.0.1.2.3rc1-6
+ *    1.2.3                   12    10203  12.so.0.1.2.3
+ *    1.2.4beta1-3            13    10204  12.so.0.1.2.4beta1-3
+ *    1.0.14rc1               13    10014  10.so.0.1.0.14rc1
+ *    1.2.4rc1                13    10204  12.so.0.1.2.4rc1
+ *    1.0.14                  10    10014  10.so.0.1.0.14
+ *    1.2.4                   13    10204  12.so.0.1.2.4
+ *    1.2.5beta1-2            13    10205  12.so.0.1.2.5beta1-2
+ *    1.0.15rc1-3             10    10015  10.so.0.1.0.15rc1-3
+ *    1.2.5rc1-3              13    10205  12.so.0.1.2.5rc1-3
+ *    1.0.15                  10    10015  10.so.0.1.0.15
+ *    1.2.5                   13    10205  12.so.0.1.2.5
+ *
+ *    Henceforth the source version will match the shared-library major
+ *    and minor numbers; the shared-library major version number will be
+ *    used for changes in backward compatibility, as it is intended.  The
+ *    PNG_LIBPNG_VER macro, which is not used within libpng but is available
+ *    for applications, is an unsigned integer of the form xyyzz corresponding
+ *    to the source version x.y.z (leading zeros in y and z).  Beta versions
+ *    were given the previous public release number plus a letter, until
+ *    version 1.0.6j; from then on they were given the upcoming public
+ *    release number plus "betaNN" or "rcN".
+ *
+ *    Binary incompatibility exists only when applications make direct access
+ *    to the info_ptr or png_ptr members through png.h, and the compiled
+ *    application is loaded with a different version of the library.
+ *
+ *    DLLNUM will change each time there are forward or backward changes
+ *    in binary compatibility (e.g., when a new feature is added).
+ *
+ * See libpng.txt or libpng.3 for more information.  The PNG specification
+ * is available as RFC 2083 <ftp://ftp.uu.net/graphics/png/documents/>
+ * and as a W3C Recommendation <http://www.w3.org/TR/REC.png.html>
+ */
+
+/*
+ * COPYRIGHT NOTICE, DISCLAIMER, and LICENSE:
+ *
+ * If you modify libpng you may insert additional notices immediately following
+ * this sentence.
+ *
+ * libpng versions 1.0.7, July 1, 2000, through 1.2.5, October 3, 2002, are
+ * Copyright (c) 2000-2002 Glenn Randers-Pehrson, and are
+ * distributed according to the same disclaimer and license as libpng-1.0.6
+ * with the following individuals added to the list of Contributing Authors
+ *
+ *    Simon-Pierre Cadieux
+ *    Eric S. Raymond
+ *    Gilles Vollant
+ *
+ * and with the following additions to the disclaimer:
+ *
+ *    There is no warranty against interference with your enjoyment of the
+ *    library or against infringement.  There is no warranty that our
+ *    efforts or the library will fulfill any of your particular purposes
+ *    or needs.  This library is provided with all faults, and the entire
+ *    risk of satisfactory quality, performance, accuracy, and effort is with
+ *    the user.
+ *
+ * libpng versions 0.97, January 1998, through 1.0.6, March 20, 2000, are
+ * Copyright (c) 1998, 1999, 2000 Glenn Randers-Pehrson
+ * Distributed according to the same disclaimer and license as libpng-0.96,
+ * with the following individuals added to the list of Contributing Authors:
+ *
+ *    Tom Lane
+ *    Glenn Randers-Pehrson
+ *    Willem van Schaik
+ *
+ * libpng versions 0.89, June 1996, through 0.96, May 1997, are
+ * Copyright (c) 1996, 1997 Andreas Dilger
+ * Distributed according to the same disclaimer and license as libpng-0.88,
+ * with the following individuals added to the list of Contributing Authors:
+ *
+ *    John Bowler
+ *    Kevin Bracey
+ *    Sam Bushell
+ *    Magnus Holmgren
+ *    Greg Roelofs
+ *    Tom Tanner
+ *
+ * libpng versions 0.5, May 1995, through 0.88, January 1996, are
+ * Copyright (c) 1995, 1996 Guy Eric Schalnat, Group 42, Inc.
+ *
+ * For the purposes of this copyright and license, "Contributing Authors"
+ * is defined as the following set of individuals:
+ *
+ *    Andreas Dilger
+ *    Dave Martindale
+ *    Guy Eric Schalnat
+ *    Paul Schmidt
+ *    Tim Wegner
+ *
+ * The PNG Reference Library is supplied "AS IS".  The Contributing Authors
+ * and Group 42, Inc. disclaim all warranties, expressed or implied,
+ * including, without limitation, the warranties of merchantability and of
+ * fitness for any purpose.  The Contributing Authors and Group 42, Inc.
+ * assume no liability for direct, indirect, incidental, special, exemplary,
+ * or consequential damages, which may result from the use of the PNG
+ * Reference Library, even if advised of the possibility of such damage.
+ *
+ * Permission is hereby granted to use, copy, modify, and distribute this
+ * source code, or portions hereof, for any purpose, without fee, subject
+ * to the following restrictions:
+ *
+ * 1. The origin of this source code must not be misrepresented.
+ *
+ * 2. Altered versions must be plainly marked as such and
+ * must not be misrepresented as being the original source.
+ *
+ * 3. This Copyright notice may not be removed or altered from
+ *    any source or altered source distribution.
+ *
+ * The Contributing Authors and Group 42, Inc. specifically permit, without
+ * fee, and encourage the use of this source code as a component to
+ * supporting the PNG file format in commercial products.  If you use this
+ * source code in a product, acknowledgment is not required but would be
+ * appreciated.
+ */
+
+/*
+ * A "png_get_copyright" function is available, for convenient use in "about"
+ * boxes and the like:
+ *
+ * printf("%s",png_get_copyright(NULL));
+ *
+ * Also, the PNG logo (in PNG format, of course) is supplied in the
+ * files "pngbar.png" and "pngbar.jpg (88x31) and "pngnow.png" (98x31).
+ */
+
+/*
+ * Libpng is OSI Certified Open Source Software.  OSI Certified is a
+ * certification mark of the Open Source Initiative.
+ */
+
+/*
+ * The contributing authors would like to thank all those who helped
+ * with testing, bug fixes, and patience.  This wouldn't have been
+ * possible without all of you.
+ *
+ * Thanks to Frank J. T. Wojcik for helping with the documentation.
+ */
+
+/*
+ * Y2K compliance in libpng:
+ * =========================
+ *
+ *    October 3, 2002
+ *
+ *    Since the PNG Development group is an ad-hoc body, we can't make
+ *    an official declaration.
+ *
+ *    This is your unofficial assurance that libpng from version 0.71 and
+ *    upward through 1.2.5 are Y2K compliant.  It is my belief that earlier
+ *    versions were also Y2K compliant.
+ *
+ *    Libpng only has three year fields.  One is a 2-byte unsigned integer
+ *    that will hold years up to 65535.  The other two hold the date in text
+ *    format, and will hold years up to 9999.
+ *
+ *    The integer is
+ *        "png_uint_16 year" in png_time_struct.
+ *
+ *    The strings are
+ *        "png_charp time_buffer" in png_struct and
+ *        "near_time_buffer", which is a local character string in png.c.
+ *
+ *    There are seven time-related functions:
+ *        png.c: png_convert_to_rfc_1123() in png.c
+ *          (formerly png_convert_to_rfc_1152() in error)
+ *        png_convert_from_struct_tm() in pngwrite.c, called in pngwrite.c
+ *        png_convert_from_time_t() in pngwrite.c
+ *        png_get_tIME() in pngget.c
+ *        png_handle_tIME() in pngrutil.c, called in pngread.c
+ *        png_set_tIME() in pngset.c
+ *        png_write_tIME() in pngwutil.c, called in pngwrite.c
+ *
+ *    All handle dates properly in a Y2K environment.  The
+ *    png_convert_from_time_t() function calls gmtime() to convert from system
+ *    clock time, which returns (year - 1900), which we properly convert to
+ *    the full 4-digit year.  There is a possibility that applications using
+ *    libpng are not passing 4-digit years into the png_convert_to_rfc_1123()
+ *    function, or that they are incorrectly passing only a 2-digit year
+ *    instead of "year - 1900" into the png_convert_from_struct_tm() function,
+ *    but this is not under our control.  The libpng documentation has always
+ *    stated that it works with 4-digit years, and the APIs have been
+ *    documented as such.
+ *
+ *    The tIME chunk itself is also Y2K compliant.  It uses a 2-byte unsigned
+ *    integer to hold the year, and can hold years as large as 65535.
+ *
+ *    zlib, upon which libpng depends, is also Y2K compliant.  It contains
+ *    no date-related code.
+ *
+ *       Glenn Randers-Pehrson
+ *       libpng maintainer
+ *       PNG Development Group
+ */
+
+#ifndef PNG_H
+#define PNG_H
+
+/* This is not the place to learn how to use libpng.  The file libpng.txt
+ * describes how to use libpng, and the file example.c summarizes it
+ * with some code on which to build.  This file is useful for looking
+ * at the actual function definitions and structure components.
+ */
+
+/* Version information for png.h - this should match the version in png.c */
+#define PNG_LIBPNG_VER_STRING "1.2.5"
+
+#define PNG_LIBPNG_VER_SONUM   0
+#define PNG_LIBPNG_VER_DLLNUM  %DLLNUM%
+
+/* These should match the first 3 components of PNG_LIBPNG_VER_STRING: */
+#define PNG_LIBPNG_VER_MAJOR   1
+#define PNG_LIBPNG_VER_MINOR   2
+#define PNG_LIBPNG_VER_RELEASE 5
+/* This should match the numeric part of the final component of
+ * PNG_LIBPNG_VER_STRING, omitting any leading zero: */
+
+#define PNG_LIBPNG_VER_BUILD  0
+
+#define PNG_LIBPNG_BUILD_ALPHA    1
+#define PNG_LIBPNG_BUILD_BETA     2
+#define PNG_LIBPNG_BUILD_RC       3
+#define PNG_LIBPNG_BUILD_STABLE   4
+#define PNG_LIBPNG_BUILD_TYPEMASK 7
+#define PNG_LIBPNG_BUILD_PATCH    8 /* Can be OR'ed with STABLE only */
+#define PNG_LIBPNG_BUILD_TYPE 4
+
+/* Careful here.  At one time, Guy wanted to use 082, but that would be octal.
+ * We must not include leading zeros.
+ * Versions 0.7 through 1.0.0 were in the range 0 to 100 here (only
+ * version 1.0.0 was mis-numbered 100 instead of 10000).  From
+ * version 1.0.1 it's    xxyyzz, where x=major, y=minor, z=release */
+#define PNG_LIBPNG_VER 10205 /* 1.2.5 */
+
+#ifndef PNG_VERSION_INFO_ONLY
+
+/* include the compression library's header */
+#include "zlib.h"
+
+/* include all user configurable info, including optional assembler routines */
+#include "pngconf.h"
+
+/* Inhibit C++ name-mangling for libpng functions but not for system calls. */
+#ifdef __cplusplus
+extern "C" {
+#endif /* __cplusplus */
+
+/* This file is arranged in several sections.  The first section contains
+ * structure and type definitions.  The second section contains the external
+ * library functions, while the third has the internal library functions,
+ * which applications aren't expected to use directly.
+ */
+
+#ifndef PNG_NO_TYPECAST_NULL
+#define int_p_NULL                (int *)NULL
+#define png_bytep_NULL            (png_bytep)NULL
+#define png_bytepp_NULL           (png_bytepp)NULL
+#define png_doublep_NULL          (png_doublep)NULL
+#define png_error_ptr_NULL        (png_error_ptr)NULL
+#define png_flush_ptr_NULL        (png_flush_ptr)NULL
+#define png_free_ptr_NULL         (png_free_ptr)NULL
+#define png_infopp_NULL           (png_infopp)NULL
+#define png_malloc_ptr_NULL       (png_malloc_ptr)NULL
+#define png_read_status_ptr_NULL  (png_read_status_ptr)NULL
+#define png_rw_ptr_NULL           (png_rw_ptr)NULL
+#define png_structp_NULL          (png_structp)NULL
+#define png_uint_16p_NULL         (png_uint_16p)NULL
+#define png_voidp_NULL            (png_voidp)NULL
+#define png_write_status_ptr_NULL (png_write_status_ptr)NULL
+#else
+#define int_p_NULL                NULL
+#define png_bytep_NULL            NULL
+#define png_bytepp_NULL           NULL
+#define png_doublep_NULL          NULL
+#define png_error_ptr_NULL        NULL
+#define png_flush_ptr_NULL        NULL
+#define png_free_ptr_NULL         NULL
+#define png_infopp_NULL           NULL
+#define png_malloc_ptr_NULL       NULL
+#define png_read_status_ptr_NULL  NULL
+#define png_rw_ptr_NULL           NULL
+#define png_structp_NULL          NULL
+#define png_uint_16p_NULL         NULL
+#define png_voidp_NULL            NULL
+#define png_write_status_ptr_NULL NULL
+#endif
+
+/* variables declared in png.c - only it needs to define PNG_NO_EXTERN */
+#if !defined(PNG_NO_EXTERN) || defined(PNG_ALWAYS_EXTERN)
+/* Version information for C files, stored in png.c.  This had better match
+ * the version above.
+ */
+#ifdef PNG_USE_GLOBAL_ARRAYS
+PNG_EXPORT_VAR (const char) png_libpng_ver[18];
+  /* need room for 99.99.99beta99z */
+#else
+#define png_libpng_ver png_get_header_ver(NULL)
+#endif
+
+#ifdef PNG_USE_GLOBAL_ARRAYS
+/* This was removed in version 1.0.5c */
+/* Structures to facilitate easy interlacing.  See png.c for more details */
+PNG_EXPORT_VAR (const int FARDATA) png_pass_start[7];
+PNG_EXPORT_VAR (const int FARDATA) png_pass_inc[7];
+PNG_EXPORT_VAR (const int FARDATA) png_pass_ystart[7];
+PNG_EXPORT_VAR (const int FARDATA) png_pass_yinc[7];
+PNG_EXPORT_VAR (const int FARDATA) png_pass_mask[7];
+PNG_EXPORT_VAR (const int FARDATA) png_pass_dsp_mask[7];
+#ifdef PNG_HAVE_ASSEMBLER_COMBINE_ROW
+PNG_EXPORT_VAR (const int FARDATA) png_pass_width[7];
+#endif
+/* This isn't currently used.  If you need it, see png.c for more details.
+PNG_EXPORT_VAR (const int FARDATA) png_pass_height[7];
+*/
+#endif
+
+#endif /* PNG_NO_EXTERN */
+
+/* Three color definitions.  The order of the red, green, and blue, (and the
+ * exact size) is not important, although the size of the fields need to
+ * be png_byte or png_uint_16 (as defined below).
+ */
+typedef struct png_color_struct
+{
+   png_byte red;
+   png_byte green;
+   png_byte blue;
+} png_color;
+typedef png_color FAR * png_colorp;
+typedef png_color FAR * FAR * png_colorpp;
+
+typedef struct png_color_16_struct
+{
+   png_byte index;    /* used for palette files */
+   png_uint_16 red;   /* for use in red green blue files */
+   png_uint_16 green;
+   png_uint_16 blue;
+   png_uint_16 gray;  /* for use in grayscale files */
+} png_color_16;
+typedef png_color_16 FAR * png_color_16p;
+typedef png_color_16 FAR * FAR * png_color_16pp;
+
+typedef struct png_color_8_struct
+{
+   png_byte red;   /* for use in red green blue files */
+   png_byte green;
+   png_byte blue;
+   png_byte gray;  /* for use in grayscale files */
+   png_byte alpha; /* for alpha channel files */
+} png_color_8;
+typedef png_color_8 FAR * png_color_8p;
+typedef png_color_8 FAR * FAR * png_color_8pp;
+
+/*
+ * The following two structures are used for the in-core representation
+ * of sPLT chunks.
+ */
+typedef struct png_sPLT_entry_struct
+{
+   png_uint_16 red;
+   png_uint_16 green;
+   png_uint_16 blue;
+   png_uint_16 alpha;
+   png_uint_16 frequency;
+} png_sPLT_entry;
+typedef png_sPLT_entry FAR * png_sPLT_entryp;
+typedef png_sPLT_entry FAR * FAR * png_sPLT_entrypp;
+
+/*  When the depth of the sPLT palette is 8 bits, the color and alpha samples
+ *  occupy the LSB of their respective members, and the MSB of each member
+ *  is zero-filled.  The frequency member always occupies the full 16 bits.
+ */
+
+typedef struct png_sPLT_struct
+{
+   png_charp name;           /* palette name */
+   png_byte depth;           /* depth of palette samples */
+   png_sPLT_entryp entries;  /* palette entries */
+   png_int_32 nentries;      /* number of palette entries */
+} png_sPLT_t;
+typedef png_sPLT_t FAR * png_sPLT_tp;
+typedef png_sPLT_t FAR * FAR * png_sPLT_tpp;
+
+#ifdef PNG_TEXT_SUPPORTED
+/* png_text holds the contents of a text/ztxt/itxt chunk in a PNG file,
+ * and whether that contents is compressed or not.  The "key" field
+ * points to a regular zero-terminated C string.  The "text", "lang", and
+ * "lang_key" fields can be regular C strings, empty strings, or NULL pointers.
+ * However, the * structure returned by png_get_text() will always contain
+ * regular zero-terminated C strings (possibly empty), never NULL pointers,
+ * so they can be safely used in printf() and other string-handling functions.
+ */
+typedef struct png_text_struct
+{
+   int  compression;       /* compression value:
+                             -1: tEXt, none
+                              0: zTXt, deflate
+                              1: iTXt, none
+                              2: iTXt, deflate  */
+   png_charp key;          /* keyword, 1-79 character description of "text" */
+   png_charp text;         /* comment, may be an empty string (ie "")
+                              or a NULL pointer */
+   png_size_t text_length; /* length of the text string */
+#ifdef PNG_iTXt_SUPPORTED
+   png_size_t itxt_length; /* length of the itxt string */
+   png_charp lang;         /* language code, 0-79 characters
+                              or a NULL pointer */
+   png_charp lang_key;     /* keyword translated UTF-8 string, 0 or more
+                              chars or a NULL pointer */
+#endif
+} png_text;
+typedef png_text FAR * png_textp;
+typedef png_text FAR * FAR * png_textpp;
+#endif
+
+/* Supported compression types for text in PNG files (tEXt, and zTXt).
+ * The values of the PNG_TEXT_COMPRESSION_ defines should NOT be changed. */
+#define PNG_TEXT_COMPRESSION_NONE_WR -3
+#define PNG_TEXT_COMPRESSION_zTXt_WR -2
+#define PNG_TEXT_COMPRESSION_NONE    -1
+#define PNG_TEXT_COMPRESSION_zTXt     0
+#define PNG_ITXT_COMPRESSION_NONE     1
+#define PNG_ITXT_COMPRESSION_zTXt     2
+#define PNG_TEXT_COMPRESSION_LAST     3  /* Not a valid value */
+
+/* png_time is a way to hold the time in an machine independent way.
+ * Two conversions are provided, both from time_t and struct tm.  There
+ * is no portable way to convert to either of these structures, as far
+ * as I know.  If you know of a portable way, send it to me.  As a side
+ * note - PNG has always been Year 2000 compliant!
+ */
+typedef struct png_time_struct
+{
+   png_uint_16 year; /* full year, as in, 1995 */
+   png_byte month;   /* month of year, 1 - 12 */
+   png_byte day;     /* day of month, 1 - 31 */
+   png_byte hour;    /* hour of day, 0 - 23 */
+   png_byte minute;  /* minute of hour, 0 - 59 */
+   png_byte second;  /* second of minute, 0 - 60 (for leap seconds) */
+} png_time;
+typedef png_time FAR * png_timep;
+typedef png_time FAR * FAR * png_timepp;
+
+#if defined(PNG_UNKNOWN_CHUNKS_SUPPORTED)
+/* png_unknown_chunk is a structure to hold queued chunks for which there is
+ * no specific support.  The idea is that we can use this to queue
+ * up private chunks for output even though the library doesn't actually
+ * know about their semantics.
+ */
+typedef struct png_unknown_chunk_t
+{
+    png_byte name[5];
+    png_byte *data;
+    png_size_t size;
+
+    /* libpng-using applications should NOT directly modify this byte. */
+    png_byte location; /* mode of operation at read time */
+}
+png_unknown_chunk;
+typedef png_unknown_chunk FAR * png_unknown_chunkp;
+typedef png_unknown_chunk FAR * FAR * png_unknown_chunkpp;
+#endif
+
+/* png_info is a structure that holds the information in a PNG file so
+ * that the application can find out the characteristics of the image.
+ * If you are reading the file, this structure will tell you what is
+ * in the PNG file.  If you are writing the file, fill in the information
+ * you want to put into the PNG file, then call png_write_info().
+ * The names chosen should be very close to the PNG specification, so
+ * consult that document for information about the meaning of each field.
+ *
+ * With libpng < 0.95, it was only possible to directly set and read the
+ * the values in the png_info_struct, which meant that the contents and
+ * order of the values had to remain fixed.  With libpng 0.95 and later,
+ * however, there are now functions that abstract the contents of
+ * png_info_struct from the application, so this makes it easier to use
+ * libpng with dynamic libraries, and even makes it possible to use
+ * libraries that don't have all of the libpng ancillary chunk-handing
+ * functionality.
+ *
+ * In any case, the order of the parameters in png_info_struct should NOT
+ * be changed for as long as possible to keep compatibility with applications
+ * that use the old direct-access method with png_info_struct.
+ *
+ * The following members may have allocated storage attached that should be
+ * cleaned up before the structure is discarded: palette, trans, text,
+ * pcal_purpose, pcal_units, pcal_params, hist, iccp_name, iccp_profile,
+ * splt_palettes, scal_unit, row_pointers, and unknowns.   By default, these
+ * are automatically freed when the info structure is deallocated, if they were
+ * allocated internally by libpng.  This behavior can be changed by means
+ * of the png_data_freer() function.
+ *
+ * More allocation details: all the chunk-reading functions that
+ * change these members go through the corresponding png_set_*
+ * functions.  A function to clear these members is available: see
+ * png_free_data().  The png_set_* functions do not depend on being
+ * able to point info structure members to any of the storage they are
+ * passed (they make their own copies), EXCEPT that the png_set_text
+ * functions use the same storage passed to them in the text_ptr or
+ * itxt_ptr structure argument, and the png_set_rows and png_set_unknowns
+ * functions do not make their own copies.
+ */
+typedef struct png_info_struct
+{
+   /* the following are necessary for every PNG file */
+   png_uint_32 width;       /* width of image in pixels (from IHDR) */
+   png_uint_32 height;      /* height of image in pixels (from IHDR) */
+   png_uint_32 valid;       /* valid chunk data (see PNG_INFO_ below) */
+   png_uint_32 rowbytes;    /* bytes needed to hold an untransformed row */
+   png_colorp palette;      /* array of color values (valid & PNG_INFO_PLTE) */
+   png_uint_16 num_palette; /* number of color entries in "palette" (PLTE) */
+   png_uint_16 num_trans;   /* number of transparent palette color (tRNS) */
+   png_byte bit_depth;      /* 1, 2, 4, 8, or 16 bits/channel (from IHDR) */
+   png_byte color_type;     /* see PNG_COLOR_TYPE_ below (from IHDR) */
+   /* The following three should have been named *_method not *_type */
+   png_byte compression_type; /* must be PNG_COMPRESSION_TYPE_BASE (IHDR) */
+   png_byte filter_type;    /* must be PNG_FILTER_TYPE_BASE (from IHDR) */
+   png_byte interlace_type; /* One of PNG_INTERLACE_NONE, PNG_INTERLACE_ADAM7 */
+
+   /* The following is informational only on read, and not used on writes. */
+   png_byte channels;       /* number of data channels per pixel (1, 2, 3, 4) */
+   png_byte pixel_depth;    /* number of bits per pixel */
+   png_byte spare_byte;     /* to align the data, and for future use */
+   png_byte signature[8];   /* magic bytes read by libpng from start of file */
+
+   /* The rest of the data is optional.  If you are reading, check the
+    * valid field to see if the information in these are valid.  If you
+    * are writing, set the valid field to those chunks you want written,
+    * and initialize the appropriate fields below.
+    */
+
+#if defined(PNG_gAMA_SUPPORTED) && defined(PNG_FLOATING_POINT_SUPPORTED)
+   /* The gAMA chunk describes the gamma characteristics of the system
+    * on which the image was created, normally in the range [1.0, 2.5].
+    * Data is valid if (valid & PNG_INFO_gAMA) is non-zero.
+    */
+   float gamma; /* gamma value of image, if (valid & PNG_INFO_gAMA) */
+#endif
+
+#if defined(PNG_sRGB_SUPPORTED)
+    /* GR-P, 0.96a */
+    /* Data valid if (valid & PNG_INFO_sRGB) non-zero. */
+   png_byte srgb_intent; /* sRGB rendering intent [0, 1, 2, or 3] */
+#endif
+
+#if defined(PNG_TEXT_SUPPORTED)
+   /* The tEXt, and zTXt chunks contain human-readable textual data in
+    * uncompressed, compressed, and optionally compressed forms, respectively.
+    * The data in "text" is an array of pointers to uncompressed,
+    * null-terminated C strings. Each chunk has a keyword that describes the
+    * textual data contained in that chunk.  Keywords are not required to be
+    * unique, and the text string may be empty.  Any number of text chunks may
+    * be in an image.
+    */
+   int num_text; /* number of comments read/to write */
+   int max_text; /* current size of text array */
+   png_textp text; /* array of comments read/to write */
+#endif /* PNG_TEXT_SUPPORTED */
+
+#if defined(PNG_tIME_SUPPORTED)
+   /* The tIME chunk holds the last time the displayed image data was
+    * modified.  See the png_time struct for the contents of this struct.
+    */
+   png_time mod_time;
+#endif
+
+#if defined(PNG_sBIT_SUPPORTED)
+   /* The sBIT chunk specifies the number of significant high-order bits
+    * in the pixel data.  Values are in the range [1, bit_depth], and are
+    * only specified for the channels in the pixel data.  The contents of
+    * the low-order bits is not specified.  Data is valid if
+    * (valid & PNG_INFO_sBIT) is non-zero.
+    */
+   png_color_8 sig_bit; /* significant bits in color channels */
+#endif
+
+#if defined(PNG_tRNS_SUPPORTED) || defined(PNG_READ_EXPAND_SUPPORTED) || \
+defined(PNG_READ_BACKGROUND_SUPPORTED)
+   /* The tRNS chunk supplies transparency data for paletted images and
+    * other image types that don't need a full alpha channel.  There are
+    * "num_trans" transparency values for a paletted image, stored in the
+    * same order as the palette colors, starting from index 0.  Values
+    * for the data are in the range [0, 255], ranging from fully transparent
+    * to fully opaque, respectively.  For non-paletted images, there is a
+    * single color specified that should be treated as fully transparent.
+    * Data is valid if (valid & PNG_INFO_tRNS) is non-zero.
+    */
+   png_bytep trans; /* transparent values for paletted image */
+   png_color_16 trans_values; /* transparent color for non-palette image */
+#endif
+
+#if defined(PNG_bKGD_SUPPORTED) || defined(PNG_READ_BACKGROUND_SUPPORTED)
+   /* The bKGD chunk gives the suggested image background color if the
+    * display program does not have its own background color and the image
+    * is needs to composited onto a background before display.  The colors
+    * in "background" are normally in the same color space/depth as the
+    * pixel data.  Data is valid if (valid & PNG_INFO_bKGD) is non-zero.
+    */
+   png_color_16 background;
+#endif
+
+#if defined(PNG_oFFs_SUPPORTED)
+   /* The oFFs chunk gives the offset in "offset_unit_type" units rightwards
+    * and downwards from the top-left corner of the display, page, or other
+    * application-specific co-ordinate space.  See the PNG_OFFSET_ defines
+    * below for the unit types.  Valid if (valid & PNG_INFO_oFFs) non-zero.
+    */
+   png_int_32 x_offset; /* x offset on page */
+   png_int_32 y_offset; /* y offset on page */
+   png_byte offset_unit_type; /* offset units type */
+#endif
+
+#if defined(PNG_pHYs_SUPPORTED)
+   /* The pHYs chunk gives the physical pixel density of the image for
+    * display or printing in "phys_unit_type" units (see PNG_RESOLUTION_
+    * defines below).  Data is valid if (valid & PNG_INFO_pHYs) is non-zero.
+    */
+   png_uint_32 x_pixels_per_unit; /* horizontal pixel density */
+   png_uint_32 y_pixels_per_unit; /* vertical pixel density */
+   png_byte phys_unit_type; /* resolution type (see PNG_RESOLUTION_ below) */
+#endif
+
+#if defined(PNG_hIST_SUPPORTED)
+   /* The hIST chunk contains the relative frequency or importance of the
+    * various palette entries, so that a viewer can intelligently select a
+    * reduced-color palette, if required.  Data is an array of "num_palette"
+    * values in the range [0,65535]. Data valid if (valid & PNG_INFO_hIST)
+    * is non-zero.
+    */
+   png_uint_16p hist;
+#endif
+
+#ifdef PNG_cHRM_SUPPORTED
+   /* The cHRM chunk describes the CIE color characteristics of the monitor
+    * on which the PNG was created.  This data allows the viewer to do gamut
+    * mapping of the input image to ensure that the viewer sees the same
+    * colors in the image as the creator.  Values are in the range
+    * [0.0, 0.8].  Data valid if (valid & PNG_INFO_cHRM) non-zero.
+    */
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+   float x_white;
+   float y_white;
+   float x_red;
+   float y_red;
+   float x_green;
+   float y_green;
+   float x_blue;
+   float y_blue;
+#endif
+#endif
+
+#if defined(PNG_pCAL_SUPPORTED)
+   /* The pCAL chunk describes a transformation between the stored pixel
+    * values and original physical data values used to create the image.
+    * The integer range [0, 2^bit_depth - 1] maps to the floating-point
+    * range given by [pcal_X0, pcal_X1], and are further transformed by a
+    * (possibly non-linear) transformation function given by "pcal_type"
+    * and "pcal_params" into "pcal_units".  Please see the PNG_EQUATION_
+    * defines below, and the PNG-Group's PNG extensions document for a
+    * complete description of the transformations and how they should be
+    * implemented, and for a description of the ASCII parameter strings.
+    * Data values are valid if (valid & PNG_INFO_pCAL) non-zero.
+    */
+   png_charp pcal_purpose;  /* pCAL chunk description string */
+   png_int_32 pcal_X0;      /* minimum value */
+   png_int_32 pcal_X1;      /* maximum value */
+   png_charp pcal_units;    /* Latin-1 string giving physical units */
+   png_charpp pcal_params;  /* ASCII strings containing parameter values */
+   png_byte pcal_type;      /* equation type (see PNG_EQUATION_ below) */
+   png_byte pcal_nparams;   /* number of parameters given in pcal_params */
+#endif
+
+/* New members added in libpng-1.0.6 */
+#ifdef PNG_FREE_ME_SUPPORTED
+   png_uint_32 free_me;     /* flags items libpng is responsible for freeing */
+#endif
+
+#if defined(PNG_UNKNOWN_CHUNKS_SUPPORTED)
+   /* storage for unknown chunks that the library doesn't recognize. */
+   png_unknown_chunkp unknown_chunks;
+   png_size_t unknown_chunks_num;
+#endif
+
+#if defined(PNG_iCCP_SUPPORTED)
+   /* iCCP chunk data. */
+   png_charp iccp_name;     /* profile name */
+   png_charp iccp_profile;  /* International Color Consortium profile data */
+                            /* Note to maintainer: should be png_bytep */
+   png_uint_32 iccp_proflen;  /* ICC profile data length */
+   png_byte iccp_compression; /* Always zero */
+#endif
+
+#if defined(PNG_sPLT_SUPPORTED)
+   /* data on sPLT chunks (there may be more than one). */
+   png_sPLT_tp splt_palettes;
+   png_uint_32 splt_palettes_num;
+#endif
+
+#if defined(PNG_sCAL_SUPPORTED)
+   /* The sCAL chunk describes the actual physical dimensions of the
+    * subject matter of the graphic.  The chunk contains a unit specification
+    * a byte value, and two ASCII strings representing floating-point
+    * values.  The values are width and height corresponsing to one pixel
+    * in the image.  This external representation is converted to double
+    * here.  Data values are valid if (valid & PNG_INFO_sCAL) is non-zero.
+    */
+   png_byte scal_unit;         /* unit of physical scale */
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+   double scal_pixel_width;    /* width of one pixel */
+   double scal_pixel_height;   /* height of one pixel */
+#endif
+#ifdef PNG_FIXED_POINT_SUPPORTED
+   png_charp scal_s_width;     /* string containing height */
+   png_charp scal_s_height;    /* string containing width */
+#endif
+#endif
+
+#if defined(PNG_INFO_IMAGE_SUPPORTED)
+   /* Memory has been allocated if (valid & PNG_ALLOCATED_INFO_ROWS) non-zero */
+   /* Data valid if (valid & PNG_INFO_IDAT) non-zero */
+   png_bytepp row_pointers;        /* the image bits */
+#endif
+
+#if defined(PNG_FIXED_POINT_SUPPORTED) && defined(PNG_gAMA_SUPPORTED)
+   png_fixed_point int_gamma; /* gamma of image, if (valid & PNG_INFO_gAMA) */
+#endif
+
+#if defined(PNG_cHRM_SUPPORTED) && defined(PNG_FIXED_POINT_SUPPORTED)
+   png_fixed_point int_x_white;
+   png_fixed_point int_y_white;
+   png_fixed_point int_x_red;
+   png_fixed_point int_y_red;
+   png_fixed_point int_x_green;
+   png_fixed_point int_y_green;
+   png_fixed_point int_x_blue;
+   png_fixed_point int_y_blue;
+#endif
+
+} png_info;
+
+typedef png_info FAR * png_infop;
+typedef png_info FAR * FAR * png_infopp;
+
+/* Maximum positive integer used in PNG is (2^31)-1 */
+#define PNG_MAX_UINT ((png_uint_32)0x7fffffffL)
+
+/* These describe the color_type field in png_info. */
+/* color type masks */
+#define PNG_COLOR_MASK_PALETTE    1
+#define PNG_COLOR_MASK_COLOR      2
+#define PNG_COLOR_MASK_ALPHA      4
+
+/* color types.  Note that not all combinations are legal */
+#define PNG_COLOR_TYPE_GRAY 0
+#define PNG_COLOR_TYPE_PALETTE  (PNG_COLOR_MASK_COLOR | PNG_COLOR_MASK_PALETTE)
+#define PNG_COLOR_TYPE_RGB        (PNG_COLOR_MASK_COLOR)
+#define PNG_COLOR_TYPE_RGB_ALPHA  (PNG_COLOR_MASK_COLOR | PNG_COLOR_MASK_ALPHA)
+#define PNG_COLOR_TYPE_GRAY_ALPHA (PNG_COLOR_MASK_ALPHA)
+/* aliases */
+#define PNG_COLOR_TYPE_RGBA  PNG_COLOR_TYPE_RGB_ALPHA
+#define PNG_COLOR_TYPE_GA  PNG_COLOR_TYPE_GRAY_ALPHA
+
+/* This is for compression type. PNG 1.0-1.2 only define the single type. */
+#define PNG_COMPRESSION_TYPE_BASE 0 /* Deflate method 8, 32K window */
+#define PNG_COMPRESSION_TYPE_DEFAULT PNG_COMPRESSION_TYPE_BASE
+
+/* This is for filter type. PNG 1.0-1.2 only define the single type. */
+#define PNG_FILTER_TYPE_BASE      0 /* Single row per-byte filtering */
+#define PNG_INTRAPIXEL_DIFFERENCING 64 /* Used only in MNG datastreams */
+#define PNG_FILTER_TYPE_DEFAULT   PNG_FILTER_TYPE_BASE
+
+/* These are for the interlacing type.  These values should NOT be changed. */
+#define PNG_INTERLACE_NONE        0 /* Non-interlaced image */
+#define PNG_INTERLACE_ADAM7       1 /* Adam7 interlacing */
+#define PNG_INTERLACE_LAST        2 /* Not a valid value */
+
+/* These are for the oFFs chunk.  These values should NOT be changed. */
+#define PNG_OFFSET_PIXEL          0 /* Offset in pixels */
+#define PNG_OFFSET_MICROMETER     1 /* Offset in micrometers (1/10^6 meter) */
+#define PNG_OFFSET_LAST           2 /* Not a valid value */
+
+/* These are for the pCAL chunk.  These values should NOT be changed. */
+#define PNG_EQUATION_LINEAR       0 /* Linear transformation */
+#define PNG_EQUATION_BASE_E       1 /* Exponential base e transform */
+#define PNG_EQUATION_ARBITRARY    2 /* Arbitrary base exponential transform */
+#define PNG_EQUATION_HYPERBOLIC   3 /* Hyperbolic sine transformation */
+#define PNG_EQUATION_LAST         4 /* Not a valid value */
+
+/* These are for the sCAL chunk.  These values should NOT be changed. */
+#define PNG_SCALE_UNKNOWN         0 /* unknown unit (image scale) */
+#define PNG_SCALE_METER           1 /* meters per pixel */
+#define PNG_SCALE_RADIAN          2 /* radians per pixel */
+#define PNG_SCALE_LAST            3 /* Not a valid value */
+
+/* These are for the pHYs chunk.  These values should NOT be changed. */
+#define PNG_RESOLUTION_UNKNOWN    0 /* pixels/unknown unit (aspect ratio) */
+#define PNG_RESOLUTION_METER      1 /* pixels/meter */
+#define PNG_RESOLUTION_LAST       2 /* Not a valid value */
+
+/* These are for the sRGB chunk.  These values should NOT be changed. */
+#define PNG_sRGB_INTENT_PERCEPTUAL 0
+#define PNG_sRGB_INTENT_RELATIVE   1
+#define PNG_sRGB_INTENT_SATURATION 2
+#define PNG_sRGB_INTENT_ABSOLUTE   3
+#define PNG_sRGB_INTENT_LAST       4 /* Not a valid value */
+
+/* This is for text chunks */
+#define PNG_KEYWORD_MAX_LENGTH     79
+
+/* Maximum number of entries in PLTE/sPLT/tRNS arrays */
+#define PNG_MAX_PALETTE_LENGTH    256
+
+/* These determine if an ancillary chunk's data has been successfully read
+ * from the PNG header, or if the application has filled in the corresponding
+ * data in the info_struct to be written into the output file.  The values
+ * of the PNG_INFO_<chunk> defines should NOT be changed.
+ */
+#define PNG_INFO_gAMA 0x0001
+#define PNG_INFO_sBIT 0x0002
+#define PNG_INFO_cHRM 0x0004
+#define PNG_INFO_PLTE 0x0008
+#define PNG_INFO_tRNS 0x0010
+#define PNG_INFO_bKGD 0x0020
+#define PNG_INFO_hIST 0x0040
+#define PNG_INFO_pHYs 0x0080
+#define PNG_INFO_oFFs 0x0100
+#define PNG_INFO_tIME 0x0200
+#define PNG_INFO_pCAL 0x0400
+#define PNG_INFO_sRGB 0x0800   /* GR-P, 0.96a */
+#define PNG_INFO_iCCP 0x1000   /* ESR, 1.0.6 */
+#define PNG_INFO_sPLT 0x2000   /* ESR, 1.0.6 */
+#define PNG_INFO_sCAL 0x4000   /* ESR, 1.0.6 */
+#define PNG_INFO_IDAT 0x8000L  /* ESR, 1.0.6 */
+
+/* This is used for the transformation routines, as some of them
+ * change these values for the row.  It also should enable using
+ * the routines for other purposes.
+ */
+typedef struct png_row_info_struct
+{
+   png_uint_32 width; /* width of row */
+   png_uint_32 rowbytes; /* number of bytes in row */
+   png_byte color_type; /* color type of row */
+   png_byte bit_depth; /* bit depth of row */
+   png_byte channels; /* number of channels (1, 2, 3, or 4) */
+   png_byte pixel_depth; /* bits per pixel (depth * channels) */
+} png_row_info;
+
+typedef png_row_info FAR * png_row_infop;
+typedef png_row_info FAR * FAR * png_row_infopp;
+
+/* These are the function types for the I/O functions and for the functions
+ * that allow the user to override the default I/O functions with his or her
+ * own.  The png_error_ptr type should match that of user-supplied warning
+ * and error functions, while the png_rw_ptr type should match that of the
+ * user read/write data functions.
+ */
+typedef struct png_struct_def png_struct;
+typedef png_struct FAR * png_structp;
+
+typedef void (PNGAPI *png_error_ptr) PNGARG((png_structp, png_const_charp));
+typedef void (PNGAPI *png_rw_ptr) PNGARG((png_structp, png_bytep, png_size_t));
+typedef void (PNGAPI *png_flush_ptr) PNGARG((png_structp));
+typedef void (PNGAPI *png_read_status_ptr) PNGARG((png_structp, png_uint_32,
+   int));
+typedef void (PNGAPI *png_write_status_ptr) PNGARG((png_structp, png_uint_32,
+   int));
+
+#ifdef PNG_PROGRESSIVE_READ_SUPPORTED
+typedef void (PNGAPI *png_progressive_info_ptr) PNGARG((png_structp, png_infop));
+typedef void (PNGAPI *png_progressive_end_ptr) PNGARG((png_structp, png_infop));
+typedef void (PNGAPI *png_progressive_row_ptr) PNGARG((png_structp, png_bytep,
+   png_uint_32, int));
+#endif
+
+#if defined(PNG_READ_USER_TRANSFORM_SUPPORTED) || \
+    defined(PNG_WRITE_USER_TRANSFORM_SUPPORTED) || \
+    defined(PNG_LEGACY_SUPPORTED)
+typedef void (PNGAPI *png_user_transform_ptr) PNGARG((png_structp,
+    png_row_infop, png_bytep));
+#endif
+
+#if defined(PNG_USER_CHUNKS_SUPPORTED)
+typedef int (PNGAPI *png_user_chunk_ptr) PNGARG((png_structp, png_unknown_chunkp));
+#endif
+#if defined(PNG_UNKNOWN_CHUNKS_SUPPORTED)
+typedef void (PNGAPI *png_unknown_chunk_ptr) PNGARG((png_structp));
+#endif
+
+/* Transform masks for the high-level interface */
+#define PNG_TRANSFORM_IDENTITY       0x0000    /* read and write */
+#define PNG_TRANSFORM_STRIP_16       0x0001    /* read only */
+#define PNG_TRANSFORM_STRIP_ALPHA    0x0002    /* read only */
+#define PNG_TRANSFORM_PACKING        0x0004    /* read and write */
+#define PNG_TRANSFORM_PACKSWAP       0x0008    /* read and write */
+#define PNG_TRANSFORM_EXPAND         0x0010    /* read only */
+#define PNG_TRANSFORM_INVERT_MONO    0x0020    /* read and write */
+#define PNG_TRANSFORM_SHIFT          0x0040    /* read and write */
+#define PNG_TRANSFORM_BGR            0x0080    /* read and write */
+#define PNG_TRANSFORM_SWAP_ALPHA     0x0100    /* read and write */
+#define PNG_TRANSFORM_SWAP_ENDIAN    0x0200    /* read and write */
+#define PNG_TRANSFORM_INVERT_ALPHA   0x0400    /* read and write */
+#define PNG_TRANSFORM_STRIP_FILLER   0x0800    /* WRITE only */
+
+/* Flags for MNG supported features */
+#define PNG_FLAG_MNG_EMPTY_PLTE     0x01
+#define PNG_FLAG_MNG_FILTER_64      0x04
+#define PNG_ALL_MNG_FEATURES        0x05
+
+typedef png_voidp (*png_malloc_ptr) PNGARG((png_structp, png_size_t));
+typedef void (*png_free_ptr) PNGARG((png_structp, png_voidp));
+
+/* The structure that holds the information to read and write PNG files.
+ * The only people who need to care about what is inside of this are the
+ * people who will be modifying the library for their own special needs.
+ * It should NOT be accessed directly by an application, except to store
+ * the jmp_buf.
+ */
+
+struct png_struct_def
+{
+#ifdef PNG_SETJMP_SUPPORTED
+   jmp_buf jmpbuf;            /* used in png_error */
+#endif
+   png_error_ptr error_fn;    /* function for printing errors and aborting */
+   png_error_ptr warning_fn;  /* function for printing warnings */
+   png_voidp error_ptr;       /* user supplied struct for error functions */
+   png_rw_ptr write_data_fn;  /* function for writing output data */
+   png_rw_ptr read_data_fn;   /* function for reading input data */
+   png_voidp io_ptr;          /* ptr to application struct for I/O functions */
+
+#if defined(PNG_READ_USER_TRANSFORM_SUPPORTED)
+   png_user_transform_ptr read_user_transform_fn; /* user read transform */
+#endif
+
+#if defined(PNG_WRITE_USER_TRANSFORM_SUPPORTED)
+   png_user_transform_ptr write_user_transform_fn; /* user write transform */
+#endif
+
+/* These were added in libpng-1.0.2 */
+#if defined(PNG_USER_TRANSFORM_PTR_SUPPORTED)
+#if defined(PNG_READ_USER_TRANSFORM_SUPPORTED) || \
+    defined(PNG_WRITE_USER_TRANSFORM_SUPPORTED)
+   png_voidp user_transform_ptr; /* user supplied struct for user transform */
+   png_byte user_transform_depth;    /* bit depth of user transformed pixels */
+   png_byte user_transform_channels; /* channels in user transformed pixels */
+#endif
+#endif
+
+   png_uint_32 mode;          /* tells us where we are in the PNG file */
+   png_uint_32 flags;         /* flags indicating various things to libpng */
+   png_uint_32 transformations; /* which transformations to perform */
+
+   z_stream zstream;          /* pointer to decompression structure (below) */
+   png_bytep zbuf;            /* buffer for zlib */
+   png_size_t zbuf_size;      /* size of zbuf */
+   int zlib_level;            /* holds zlib compression level */
+   int zlib_method;           /* holds zlib compression method */
+   int zlib_window_bits;      /* holds zlib compression window bits */
+   int zlib_mem_level;        /* holds zlib compression memory level */
+   int zlib_strategy;         /* holds zlib compression strategy */
+
+   png_uint_32 width;         /* width of image in pixels */
+   png_uint_32 height;        /* height of image in pixels */
+   png_uint_32 num_rows;      /* number of rows in current pass */
+   png_uint_32 usr_width;     /* width of row at start of write */
+   png_uint_32 rowbytes;      /* size of row in bytes */
+   png_uint_32 irowbytes;     /* size of current interlaced row in bytes */
+   png_uint_32 iwidth;        /* width of current interlaced row in pixels */
+   png_uint_32 row_number;    /* current row in interlace pass */
+   png_bytep prev_row;        /* buffer to save previous (unfiltered) row */
+   png_bytep row_buf;         /* buffer to save current (unfiltered) row */
+   png_bytep sub_row;         /* buffer to save "sub" row when filtering */
+   png_bytep up_row;          /* buffer to save "up" row when filtering */
+   png_bytep avg_row;         /* buffer to save "avg" row when filtering */
+   png_bytep paeth_row;       /* buffer to save "Paeth" row when filtering */
+   png_row_info row_info;     /* used for transformation routines */
+
+   png_uint_32 idat_size;     /* current IDAT size for read */
+   png_uint_32 crc;           /* current chunk CRC value */
+   png_colorp palette;        /* palette from the input file */
+   png_uint_16 num_palette;   /* number of color entries in palette */
+   png_uint_16 num_trans;     /* number of transparency values */
+   png_byte chunk_name[5];    /* null-terminated name of current chunk */
+   png_byte compression;      /* file compression type (always 0) */
+   png_byte filter;           /* file filter type (always 0) */
+   png_byte interlaced;       /* PNG_INTERLACE_NONE, PNG_INTERLACE_ADAM7 */
+   png_byte pass;             /* current interlace pass (0 - 6) */
+   png_byte do_filter;        /* row filter flags (see PNG_FILTER_ below ) */
+   png_byte color_type;       /* color type of file */
+   png_byte bit_depth;        /* bit depth of file */
+   png_byte usr_bit_depth;    /* bit depth of users row */
+   png_byte pixel_depth;      /* number of bits per pixel */
+   png_byte channels;         /* number of channels in file */
+   png_byte usr_channels;     /* channels at start of write */
+   png_byte sig_bytes;        /* magic bytes read/written from start of file */
+
+#if defined(PNG_READ_FILLER_SUPPORTED) || defined(PNG_WRITE_FILLER_SUPPORTED)
+#ifdef PNG_LEGACY_SUPPORTED
+   png_byte filler;           /* filler byte for pixel expansion */
+#else
+   png_uint_16 filler;           /* filler bytes for pixel expansion */
+#endif
+#endif
+
+#if defined(PNG_bKGD_SUPPORTED)
+   png_byte background_gamma_type;
+#  ifdef PNG_FLOATING_POINT_SUPPORTED
+   float background_gamma;
+#  endif
+   png_color_16 background;   /* background color in screen gamma space */
+#if defined(PNG_READ_GAMMA_SUPPORTED)
+   png_color_16 background_1; /* background normalized to gamma 1.0 */
+#endif
+#endif /* PNG_bKGD_SUPPORTED */
+
+#if defined(PNG_WRITE_FLUSH_SUPPORTED)
+   png_flush_ptr output_flush_fn;/* Function for flushing output */
+   png_uint_32 flush_dist;    /* how many rows apart to flush, 0 - no flush */
+   png_uint_32 flush_rows;    /* number of rows written since last flush */
+#endif
+
+#if defined(PNG_READ_GAMMA_SUPPORTED) || defined(PNG_READ_BACKGROUND_SUPPORTED)
+   int gamma_shift;      /* number of "insignificant" bits 16-bit gamma */
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+   float gamma;          /* file gamma value */
+   float screen_gamma;   /* screen gamma value (display_exponent) */
+#endif
+#endif
+
+#if defined(PNG_READ_GAMMA_SUPPORTED) || defined(PNG_READ_BACKGROUND_SUPPORTED)
+   png_bytep gamma_table;     /* gamma table for 8-bit depth files */
+   png_bytep gamma_from_1;    /* converts from 1.0 to screen */
+   png_bytep gamma_to_1;      /* converts from file to 1.0 */
+   png_uint_16pp gamma_16_table; /* gamma table for 16-bit depth files */
+   png_uint_16pp gamma_16_from_1; /* converts from 1.0 to screen */
+   png_uint_16pp gamma_16_to_1; /* converts from file to 1.0 */
+#endif
+
+#if defined(PNG_READ_GAMMA_SUPPORTED) || defined(PNG_sBIT_SUPPORTED)
+   png_color_8 sig_bit;       /* significant bits in each available channel */
+#endif
+
+#if defined(PNG_READ_SHIFT_SUPPORTED) || defined(PNG_WRITE_SHIFT_SUPPORTED)
+   png_color_8 shift;         /* shift for significant bit tranformation */
+#endif
+
+#if defined(PNG_tRNS_SUPPORTED) || defined(PNG_READ_BACKGROUND_SUPPORTED) \
+ || defined(PNG_READ_EXPAND_SUPPORTED) || defined(PNG_READ_BACKGROUND_SUPPORTED)
+   png_bytep trans;           /* transparency values for paletted files */
+   png_color_16 trans_values; /* transparency values for non-paletted files */
+#endif
+
+   png_read_status_ptr read_row_fn;   /* called after each row is decoded */
+   png_write_status_ptr write_row_fn; /* called after each row is encoded */
+#ifdef PNG_PROGRESSIVE_READ_SUPPORTED
+   png_progressive_info_ptr info_fn; /* called after header data fully read */
+   png_progressive_row_ptr row_fn;   /* called after each prog. row is decoded */
+   png_progressive_end_ptr end_fn;   /* called after image is complete */
+   png_bytep save_buffer_ptr;        /* current location in save_buffer */
+   png_bytep save_buffer;            /* buffer for previously read data */
+   png_bytep current_buffer_ptr;     /* current location in current_buffer */
+   png_bytep current_buffer;         /* buffer for recently used data */
+   png_uint_32 push_length;          /* size of current input chunk */
+   png_uint_32 skip_length;          /* bytes to skip in input data */
+   png_size_t save_buffer_size;      /* amount of data now in save_buffer */
+   png_size_t save_buffer_max;       /* total size of save_buffer */
+   png_size_t buffer_size;           /* total amount of available input data */
+   png_size_t current_buffer_size;   /* amount of data now in current_buffer */
+   int process_mode;                 /* what push library is currently doing */
+   int cur_palette;                  /* current push library palette index */
+
+#  if defined(PNG_TEXT_SUPPORTED)
+     png_size_t current_text_size;   /* current size of text input data */
+     png_size_t current_text_left;   /* how much text left to read in input */
+     png_charp current_text;         /* current text chunk buffer */
+     png_charp current_text_ptr;     /* current location in current_text */
+#  endif /* PNG_PROGRESSIVE_READ_SUPPORTED && PNG_TEXT_SUPPORTED */
+
+#endif /* PNG_PROGRESSIVE_READ_SUPPORTED */
+
+#if defined(__TURBOC__) && !defined(_Windows) && !defined(__FLAT__)
+/* for the Borland special 64K segment handler */
+   png_bytepp offset_table_ptr;
+   png_bytep offset_table;
+   png_uint_16 offset_table_number;
+   png_uint_16 offset_table_count;
+   png_uint_16 offset_table_count_free;
+#endif
+
+#if defined(PNG_READ_DITHER_SUPPORTED)
+   png_bytep palette_lookup;         /* lookup table for dithering */
+   png_bytep dither_index;           /* index translation for palette files */
+#endif
+
+#if defined(PNG_READ_DITHER_SUPPORTED) || defined(PNG_hIST_SUPPORTED)
+   png_uint_16p hist;                /* histogram */
+#endif
+
+#if defined(PNG_WRITE_WEIGHTED_FILTER_SUPPORTED)
+   png_byte heuristic_method;        /* heuristic for row filter selection */
+   png_byte num_prev_filters;        /* number of weights for previous rows */
+   png_bytep prev_filters;           /* filter type(s) of previous row(s) */
+   png_uint_16p filter_weights;      /* weight(s) for previous line(s) */
+   png_uint_16p inv_filter_weights;  /* 1/weight(s) for previous line(s) */
+   png_uint_16p filter_costs;        /* relative filter calculation cost */
+   png_uint_16p inv_filter_costs;    /* 1/relative filter calculation cost */
+#endif
+
+#if defined(PNG_TIME_RFC1123_SUPPORTED)
+   png_charp time_buffer;            /* String to hold RFC 1123 time text */
+#endif
+
+/* New members added in libpng-1.0.6 */
+
+#ifdef PNG_FREE_ME_SUPPORTED
+   png_uint_32 free_me;       /* flags items libpng is responsible for freeing */
+#endif
+
+#if defined(PNG_USER_CHUNKS_SUPPORTED)
+   png_voidp user_chunk_ptr;
+   png_user_chunk_ptr read_user_chunk_fn; /* user read chunk handler */
+#endif
+
+#if defined(PNG_UNKNOWN_CHUNKS_SUPPORTED)
+   int num_chunk_list;
+   png_bytep chunk_list;
+#endif
+
+/* New members added in libpng-1.0.3 */
+#if defined(PNG_READ_RGB_TO_GRAY_SUPPORTED)
+   png_byte rgb_to_gray_status;
+   /* These were changed from png_byte in libpng-1.0.6 */
+   png_uint_16 rgb_to_gray_red_coeff;
+   png_uint_16 rgb_to_gray_green_coeff;
+   png_uint_16 rgb_to_gray_blue_coeff;
+#endif
+
+/* New member added in libpng-1.0.4 (renamed in 1.0.9) */
+#if defined(PNG_MNG_FEATURES_SUPPORTED) || \
+    defined(PNG_READ_EMPTY_PLTE_SUPPORTED) || \
+    defined(PNG_WRITE_EMPTY_PLTE_SUPPORTED)
+/* changed from png_byte to png_uint_32 at version 1.2.0 */
+#ifdef PNG_1_0_X
+   png_byte mng_features_permitted;
+#else
+   png_uint_32 mng_features_permitted;
+#endif /* PNG_1_0_X */
+#endif
+
+/* New member added in libpng-1.0.7 */
+#if defined(PNG_READ_GAMMA_SUPPORTED) || defined(PNG_READ_BACKGROUND_SUPPORTED)
+   png_fixed_point int_gamma;
+#endif
+
+/* New member added in libpng-1.0.9, ifdef'ed out in 1.0.12, enabled in 1.2.0 */
+#if defined(PNG_MNG_FEATURES_SUPPORTED)
+   png_byte filter_type;
+#endif
+
+#if defined(PNG_1_0_X) || (defined(PNG_DEBUG) && defined(PNG_USE_PNGGCCRD))
+/* New member added in libpng-1.0.10, ifdef'ed out in 1.2.0 */
+   png_uint_32 row_buf_size;
+#endif
+
+/* New members added in libpng-1.2.0 */
+#if !defined(PNG_1_0_X) && defined(PNG_ASSEMBLER_CODE_SUPPORTED)
+   png_byte     mmx_bitdepth_threshold;
+   png_uint_32  mmx_rowbytes_threshold;
+   png_uint_32  asm_flags;
+#endif
+
+/* New members added in libpng-1.0.2 but first enabled by default in 1.2.0 */
+#ifdef PNG_USER_MEM_SUPPORTED
+   png_voidp mem_ptr;                /* user supplied struct for mem functions */
+   png_malloc_ptr malloc_fn;         /* function for allocating memory */
+   png_free_ptr free_fn;             /* function for freeing memory */
+#endif
+
+/* New member added in libpng-1.0.13 and 1.2.0 */
+   png_bytep big_row_buf;         /* buffer to save current (unfiltered) row */
+
+#if defined(PNG_READ_DITHER_SUPPORTED)
+/* The following three members were added at version 1.0.14 and 1.2.4 */
+   png_bytep dither_sort;            /* working sort array */
+   png_bytep index_to_palette;       /* where the original index currently is */
+                                     /* in the palette */
+   png_bytep palette_to_index;       /* which original index points to this */
+                                     /* palette color */
+#endif
+
+};
+
+
+/* This prevents a compiler error in png.c if png.c and png.h are both at
+   version 1.2.5
+ */
+typedef png_structp version_1_2_5;
+
+typedef png_struct FAR * FAR * png_structpp;
+
+/* Here are the function definitions most commonly used.  This is not
+ * the place to find out how to use libpng.  See libpng.txt for the
+ * full explanation, see example.c for the summary.  This just provides
+ * a simple one line description of the use of each function.
+ */
+
+/* Returns the version number of the library */
+extern PNG_EXPORT(png_uint_32,png_access_version_number) PNGARG((void));
+
+/* Tell lib we have already handled the first <num_bytes> magic bytes.
+ * Handling more than 8 bytes from the beginning of the file is an error.
+ */
+extern PNG_EXPORT(void,png_set_sig_bytes) PNGARG((png_structp png_ptr,
+   int num_bytes));
+
+/* Check sig[start] through sig[start + num_to_check - 1] to see if it's a
+ * PNG file.  Returns zero if the supplied bytes match the 8-byte PNG
+ * signature, and non-zero otherwise.  Having num_to_check == 0 or
+ * start > 7 will always fail (ie return non-zero).
+ */
+extern PNG_EXPORT(int,png_sig_cmp) PNGARG((png_bytep sig, png_size_t start,
+   png_size_t num_to_check));
+
+/* Simple signature checking function.  This is the same as calling
+ * png_check_sig(sig, n) := !png_sig_cmp(sig, 0, n).
+ */
+extern PNG_EXPORT(int,png_check_sig) PNGARG((png_bytep sig, int num));
+
+/* Allocate and initialize png_ptr struct for reading, and any other memory. */
+extern PNG_EXPORT(png_structp,png_create_read_struct)
+   PNGARG((png_const_charp user_png_ver, png_voidp error_ptr,
+   png_error_ptr error_fn, png_error_ptr warn_fn));
+
+/* Allocate and initialize png_ptr struct for writing, and any other memory */
+extern PNG_EXPORT(png_structp,png_create_write_struct)
+   PNGARG((png_const_charp user_png_ver, png_voidp error_ptr,
+   png_error_ptr error_fn, png_error_ptr warn_fn));
+
+extern PNG_EXPORT(png_uint_32,png_get_compression_buffer_size)
+   PNGARG((png_structp png_ptr));
+
+extern PNG_EXPORT(void,png_set_compression_buffer_size)
+   PNGARG((png_structp png_ptr, png_uint_32 size));
+
+/* Reset the compression stream */
+extern PNG_EXPORT(int,png_reset_zstream) PNGARG((png_structp png_ptr));
+
+/* New functions added in libpng-1.0.2 (not enabled by default until 1.2.0) */
+#ifdef PNG_USER_MEM_SUPPORTED
+extern PNG_EXPORT(png_structp,png_create_read_struct_2)
+   PNGARG((png_const_charp user_png_ver, png_voidp error_ptr,
+   png_error_ptr error_fn, png_error_ptr warn_fn, png_voidp mem_ptr,
+   png_malloc_ptr malloc_fn, png_free_ptr free_fn));
+extern PNG_EXPORT(png_structp,png_create_write_struct_2)
+   PNGARG((png_const_charp user_png_ver, png_voidp error_ptr,
+   png_error_ptr error_fn, png_error_ptr warn_fn, png_voidp mem_ptr,
+   png_malloc_ptr malloc_fn, png_free_ptr free_fn));
+#endif
+
+/* Write a PNG chunk - size, type, (optional) data, CRC. */
+extern PNG_EXPORT(void,png_write_chunk) PNGARG((png_structp png_ptr,
+   png_bytep chunk_name, png_bytep data, png_size_t length));
+
+/* Write the start of a PNG chunk - length and chunk name. */
+extern PNG_EXPORT(void,png_write_chunk_start) PNGARG((png_structp png_ptr,
+   png_bytep chunk_name, png_uint_32 length));
+
+/* Write the data of a PNG chunk started with png_write_chunk_start(). */
+extern PNG_EXPORT(void,png_write_chunk_data) PNGARG((png_structp png_ptr,
+   png_bytep data, png_size_t length));
+
+/* Finish a chunk started with png_write_chunk_start() (includes CRC). */
+extern PNG_EXPORT(void,png_write_chunk_end) PNGARG((png_structp png_ptr));
+
+/* Allocate and initialize the info structure */
+extern PNG_EXPORT(png_infop,png_create_info_struct)
+   PNGARG((png_structp png_ptr));
+
+/* Initialize the info structure (old interface - DEPRECATED) */
+extern PNG_EXPORT(void,png_info_init) PNGARG((png_infop info_ptr));
+#undef png_info_init
+#define png_info_init(info_ptr) png_info_init_3(&info_ptr, sizeof(png_info));
+extern PNG_EXPORT(void,png_info_init_3) PNGARG((png_infopp info_ptr,
+    png_size_t png_info_struct_size));
+
+/* Writes all the PNG information before the image. */
+extern PNG_EXPORT(void,png_write_info_before_PLTE) PNGARG((png_structp png_ptr,
+   png_infop info_ptr));
+extern PNG_EXPORT(void,png_write_info) PNGARG((png_structp png_ptr,
+   png_infop info_ptr));
+
+/* read the information before the actual image data. */
+extern PNG_EXPORT(void,png_read_info) PNGARG((png_structp png_ptr,
+   png_infop info_ptr));
+
+#if defined(PNG_TIME_RFC1123_SUPPORTED)
+extern PNG_EXPORT(png_charp,png_convert_to_rfc1123)
+   PNGARG((png_structp png_ptr, png_timep ptime));
+#endif
+
+#if !defined(_WIN32_WCE)
+/* "time.h" functions are not supported on WindowsCE */
+#if defined(PNG_WRITE_tIME_SUPPORTED)
+/* convert from a struct tm to png_time */
+extern PNG_EXPORT(void,png_convert_from_struct_tm) PNGARG((png_timep ptime,
+   struct tm FAR * ttime));
+
+/* convert from time_t to png_time.  Uses gmtime() */
+extern PNG_EXPORT(void,png_convert_from_time_t) PNGARG((png_timep ptime,
+   time_t ttime));
+#endif /* PNG_WRITE_tIME_SUPPORTED */
+#endif /* _WIN32_WCE */
+
+#if defined(PNG_READ_EXPAND_SUPPORTED)
+/* Expand data to 24-bit RGB, or 8-bit grayscale, with alpha if available. */
+extern PNG_EXPORT(void,png_set_expand) PNGARG((png_structp png_ptr));
+extern PNG_EXPORT(void,png_set_gray_1_2_4_to_8) PNGARG((png_structp png_ptr));
+extern PNG_EXPORT(void,png_set_palette_to_rgb) PNGARG((png_structp png_ptr));
+extern PNG_EXPORT(void,png_set_tRNS_to_alpha) PNGARG((png_structp png_ptr));
+#endif
+
+#if defined(PNG_READ_BGR_SUPPORTED) || defined(PNG_WRITE_BGR_SUPPORTED)
+/* Use blue, green, red order for pixels. */
+extern PNG_EXPORT(void,png_set_bgr) PNGARG((png_structp png_ptr));
+#endif
+
+#if defined(PNG_READ_GRAY_TO_RGB_SUPPORTED)
+/* Expand the grayscale to 24-bit RGB if necessary. */
+extern PNG_EXPORT(void,png_set_gray_to_rgb) PNGARG((png_structp png_ptr));
+#endif
+
+#if defined(PNG_READ_RGB_TO_GRAY_SUPPORTED)
+/* Reduce RGB to grayscale. */
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+extern PNG_EXPORT(void,png_set_rgb_to_gray) PNGARG((png_structp png_ptr,
+   int error_action, double red, double green ));
+#endif
+extern PNG_EXPORT(void,png_set_rgb_to_gray_fixed) PNGARG((png_structp png_ptr,
+   int error_action, png_fixed_point red, png_fixed_point green ));
+extern PNG_EXPORT(png_byte,png_get_rgb_to_gray_status) PNGARG((png_structp
+   png_ptr));
+#endif
+
+extern PNG_EXPORT(void,png_build_grayscale_palette) PNGARG((int bit_depth,
+   png_colorp palette));
+
+#if defined(PNG_READ_STRIP_ALPHA_SUPPORTED)
+extern PNG_EXPORT(void,png_set_strip_alpha) PNGARG((png_structp png_ptr));
+#endif
+
+#if defined(PNG_READ_SWAP_ALPHA_SUPPORTED) || \
+    defined(PNG_WRITE_SWAP_ALPHA_SUPPORTED)
+extern PNG_EXPORT(void,png_set_swap_alpha) PNGARG((png_structp png_ptr));
+#endif
+
+#if defined(PNG_READ_INVERT_ALPHA_SUPPORTED) || \
+    defined(PNG_WRITE_INVERT_ALPHA_SUPPORTED)
+extern PNG_EXPORT(void,png_set_invert_alpha) PNGARG((png_structp png_ptr));
+#endif
+
+#if defined(PNG_READ_FILLER_SUPPORTED) || defined(PNG_WRITE_FILLER_SUPPORTED)
+/* Add a filler byte to 24-bit RGB images. */
+extern PNG_EXPORT(void,png_set_filler) PNGARG((png_structp png_ptr,
+   png_uint_32 filler, int flags));
+/* The values of the PNG_FILLER_ defines should NOT be changed */
+#define PNG_FILLER_BEFORE 0
+#define PNG_FILLER_AFTER 1
+#endif /* PNG_READ_FILLER_SUPPORTED || PNG_WRITE_FILLER_SUPPORTED */
+
+#if defined(PNG_READ_SWAP_SUPPORTED) || defined(PNG_WRITE_SWAP_SUPPORTED)
+/* Swap bytes in 16-bit depth files. */
+extern PNG_EXPORT(void,png_set_swap) PNGARG((png_structp png_ptr));
+#endif
+
+#if defined(PNG_READ_PACK_SUPPORTED) || defined(PNG_WRITE_PACK_SUPPORTED)
+/* Use 1 byte per pixel in 1, 2, or 4-bit depth files. */
+extern PNG_EXPORT(void,png_set_packing) PNGARG((png_structp png_ptr));
+#endif
+
+#if defined(PNG_READ_PACKSWAP_SUPPORTED) || defined(PNG_WRITE_PACKSWAP_SUPPORTED)
+/* Swap packing order of pixels in bytes. */
+extern PNG_EXPORT(void,png_set_packswap) PNGARG((png_structp png_ptr));
+#endif
+
+#if defined(PNG_READ_SHIFT_SUPPORTED) || defined(PNG_WRITE_SHIFT_SUPPORTED)
+/* Converts files to legal bit depths. */
+extern PNG_EXPORT(void,png_set_shift) PNGARG((png_structp png_ptr,
+   png_color_8p true_bits));
+#endif
+
+#if defined(PNG_READ_INTERLACING_SUPPORTED) || \
+    defined(PNG_WRITE_INTERLACING_SUPPORTED)
+/* Have the code handle the interlacing.  Returns the number of passes. */
+extern PNG_EXPORT(int,png_set_interlace_handling) PNGARG((png_structp png_ptr));
+#endif
+
+#if defined(PNG_READ_INVERT_SUPPORTED) || defined(PNG_WRITE_INVERT_SUPPORTED)
+/* Invert monochrome files */
+extern PNG_EXPORT(void,png_set_invert_mono) PNGARG((png_structp png_ptr));
+#endif
+
+#if defined(PNG_READ_BACKGROUND_SUPPORTED)
+/* Handle alpha and tRNS by replacing with a background color. */
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+extern PNG_EXPORT(void,png_set_background) PNGARG((png_structp png_ptr,
+   png_color_16p background_color, int background_gamma_code,
+   int need_expand, double background_gamma));
+#endif
+#define PNG_BACKGROUND_GAMMA_UNKNOWN 0
+#define PNG_BACKGROUND_GAMMA_SCREEN  1
+#define PNG_BACKGROUND_GAMMA_FILE    2
+#define PNG_BACKGROUND_GAMMA_UNIQUE  3
+#endif
+
+#if defined(PNG_READ_16_TO_8_SUPPORTED)
+/* strip the second byte of information from a 16-bit depth file. */
+extern PNG_EXPORT(void,png_set_strip_16) PNGARG((png_structp png_ptr));
+#endif
+
+#if defined(PNG_READ_DITHER_SUPPORTED)
+/* Turn on dithering, and reduce the palette to the number of colors available. */
+extern PNG_EXPORT(void,png_set_dither) PNGARG((png_structp png_ptr,
+   png_colorp palette, int num_palette, int maximum_colors,
+   png_uint_16p histogram, int full_dither));
+#endif
+
+#if defined(PNG_READ_GAMMA_SUPPORTED)
+/* Handle gamma correction. Screen_gamma=(display_exponent) */
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+extern PNG_EXPORT(void,png_set_gamma) PNGARG((png_structp png_ptr,
+   double screen_gamma, double default_file_gamma));
+#endif
+#endif
+
+#if defined(PNG_READ_EMPTY_PLTE_SUPPORTED) || \
+    defined(PNG_WRITE_EMPTY_PLTE_SUPPORTED)
+/* Permit or disallow empty PLTE (0: not permitted, 1: permitted) */
+/* Deprecated and will be removed.  Use png_permit_mng_features() instead. */
+extern PNG_EXPORT(void,png_permit_empty_plte) PNGARG((png_structp png_ptr,
+   int empty_plte_permitted));
+#endif
+
+#if defined(PNG_WRITE_FLUSH_SUPPORTED)
+/* Set how many lines between output flushes - 0 for no flushing */
+extern PNG_EXPORT(void,png_set_flush) PNGARG((png_structp png_ptr, int nrows));
+/* Flush the current PNG output buffer */
+extern PNG_EXPORT(void,png_write_flush) PNGARG((png_structp png_ptr));
+#endif
+
+/* optional update palette with requested transformations */
+extern PNG_EXPORT(void,png_start_read_image) PNGARG((png_structp png_ptr));
+
+/* optional call to update the users info structure */
+extern PNG_EXPORT(void,png_read_update_info) PNGARG((png_structp png_ptr,
+   png_infop info_ptr));
+
+/* read one or more rows of image data. */
+extern PNG_EXPORT(void,png_read_rows) PNGARG((png_structp png_ptr,
+   png_bytepp row, png_bytepp display_row, png_uint_32 num_rows));
+
+/* read a row of data. */
+extern PNG_EXPORT(void,png_read_row) PNGARG((png_structp png_ptr,
+   png_bytep row,
+   png_bytep display_row));
+
+/* read the whole image into memory at once. */
+extern PNG_EXPORT(void,png_read_image) PNGARG((png_structp png_ptr,
+   png_bytepp image));
+
+/* write a row of image data */
+extern PNG_EXPORT(void,png_write_row) PNGARG((png_structp png_ptr,
+   png_bytep row));
+
+/* write a few rows of image data */
+extern PNG_EXPORT(void,png_write_rows) PNGARG((png_structp png_ptr,
+   png_bytepp row, png_uint_32 num_rows));
+
+/* write the image data */
+extern PNG_EXPORT(void,png_write_image) PNGARG((png_structp png_ptr,
+   png_bytepp image));
+
+/* writes the end of the PNG file. */
+extern PNG_EXPORT(void,png_write_end) PNGARG((png_structp png_ptr,
+   png_infop info_ptr));
+
+/* read the end of the PNG file. */
+extern PNG_EXPORT(void,png_read_end) PNGARG((png_structp png_ptr,
+   png_infop info_ptr));
+
+/* free any memory associated with the png_info_struct */
+extern PNG_EXPORT(void,png_destroy_info_struct) PNGARG((png_structp png_ptr,
+   png_infopp info_ptr_ptr));
+
+/* free any memory associated with the png_struct and the png_info_structs */
+extern PNG_EXPORT(void,png_destroy_read_struct) PNGARG((png_structpp
+   png_ptr_ptr, png_infopp info_ptr_ptr, png_infopp end_info_ptr_ptr));
+
+/* free all memory used by the read (old method - NOT DLL EXPORTED) */
+extern void png_read_destroy PNGARG((png_structp png_ptr, png_infop info_ptr,
+   png_infop end_info_ptr));
+
+/* free any memory associated with the png_struct and the png_info_structs */
+extern PNG_EXPORT(void,png_destroy_write_struct)
+   PNGARG((png_structpp png_ptr_ptr, png_infopp info_ptr_ptr));
+
+/* free any memory used in png_ptr struct (old method - NOT DLL EXPORTED) */
+extern void png_write_destroy PNGARG((png_structp png_ptr));
+
+/* set the libpng method of handling chunk CRC errors */
+extern PNG_EXPORT(void,png_set_crc_action) PNGARG((png_structp png_ptr,
+   int crit_action, int ancil_action));
+
+/* Values for png_set_crc_action() to say how to handle CRC errors in
+ * ancillary and critical chunks, and whether to use the data contained
+ * therein.  Note that it is impossible to "discard" data in a critical
+ * chunk.  For versions prior to 0.90, the action was always error/quit,
+ * whereas in version 0.90 and later, the action for CRC errors in ancillary
+ * chunks is warn/discard.  These values should NOT be changed.
+ *
+ *      value                       action:critical     action:ancillary
+ */
+#define PNG_CRC_DEFAULT       0  /* error/quit          warn/discard data */
+#define PNG_CRC_ERROR_QUIT    1  /* error/quit          error/quit        */
+#define PNG_CRC_WARN_DISCARD  2  /* (INVALID)           warn/discard data */
+#define PNG_CRC_WARN_USE      3  /* warn/use data       warn/use data     */
+#define PNG_CRC_QUIET_USE     4  /* quiet/use data      quiet/use data    */
+#define PNG_CRC_NO_CHANGE     5  /* use current value   use current value */
+
+/* These functions give the user control over the scan-line filtering in
+ * libpng and the compression methods used by zlib.  These functions are
+ * mainly useful for testing, as the defaults should work with most users.
+ * Those users who are tight on memory or want faster performance at the
+ * expense of compression can modify them.  See the compression library
+ * header file (zlib.h) for an explination of the compression functions.
+ */
+
+/* set the filtering method(s) used by libpng.  Currently, the only valid
+ * value for "method" is 0.
+ */
+extern PNG_EXPORT(void,png_set_filter) PNGARG((png_structp png_ptr, int method,
+   int filters));
+
+/* Flags for png_set_filter() to say which filters to use.  The flags
+ * are chosen so that they don't conflict with real filter types
+ * below, in case they are supplied instead of the #defined constants.
+ * These values should NOT be changed.
+ */
+#define PNG_NO_FILTERS     0x00
+#define PNG_FILTER_NONE    0x08
+#define PNG_FILTER_SUB     0x10
+#define PNG_FILTER_UP      0x20
+#define PNG_FILTER_AVG     0x40
+#define PNG_FILTER_PAETH   0x80
+#define PNG_ALL_FILTERS (PNG_FILTER_NONE | PNG_FILTER_SUB | PNG_FILTER_UP | \
+                         PNG_FILTER_AVG | PNG_FILTER_PAETH)
+
+/* Filter values (not flags) - used in pngwrite.c, pngwutil.c for now.
+ * These defines should NOT be changed.
+ */
+#define PNG_FILTER_VALUE_NONE  0
+#define PNG_FILTER_VALUE_SUB   1
+#define PNG_FILTER_VALUE_UP    2
+#define PNG_FILTER_VALUE_AVG   3
+#define PNG_FILTER_VALUE_PAETH 4
+#define PNG_FILTER_VALUE_LAST  5
+
+#if defined(PNG_WRITE_WEIGHTED_FILTER_SUPPORTED) /* EXPERIMENTAL */
+/* The "heuristic_method" is given by one of the PNG_FILTER_HEURISTIC_
+ * defines, either the default (minimum-sum-of-absolute-differences), or
+ * the experimental method (weighted-minimum-sum-of-absolute-differences).
+ *
+ * Weights are factors >= 1.0, indicating how important it is to keep the
+ * filter type consistent between rows.  Larger numbers mean the current
+ * filter is that many times as likely to be the same as the "num_weights"
+ * previous filters.  This is cumulative for each previous row with a weight.
+ * There needs to be "num_weights" values in "filter_weights", or it can be
+ * NULL if the weights aren't being specified.  Weights have no influence on
+ * the selection of the first row filter.  Well chosen weights can (in theory)
+ * improve the compression for a given image.
+ *
+ * Costs are factors >= 1.0 indicating the relative decoding costs of a
+ * filter type.  Higher costs indicate more decoding expense, and are
+ * therefore less likely to be selected over a filter with lower computational
+ * costs.  There needs to be a value in "filter_costs" for each valid filter
+ * type (given by PNG_FILTER_VALUE_LAST), or it can be NULL if you aren't
+ * setting the costs.  Costs try to improve the speed of decompression without
+ * unduly increasing the compressed image size.
+ *
+ * A negative weight or cost indicates the default value is to be used, and
+ * values in the range [0.0, 1.0) indicate the value is to remain unchanged.
+ * The default values for both weights and costs are currently 1.0, but may
+ * change if good general weighting/cost heuristics can be found.  If both
+ * the weights and costs are set to 1.0, this degenerates the WEIGHTED method
+ * to the UNWEIGHTED method, but with added encoding time/computation.
+ */
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+extern PNG_EXPORT(void,png_set_filter_heuristics) PNGARG((png_structp png_ptr,
+   int heuristic_method, int num_weights, png_doublep filter_weights,
+   png_doublep filter_costs));
+#endif
+#endif /*  PNG_WRITE_WEIGHTED_FILTER_SUPPORTED */
+
+/* Heuristic used for row filter selection.  These defines should NOT be
+ * changed.
+ */
+#define PNG_FILTER_HEURISTIC_DEFAULT    0  /* Currently "UNWEIGHTED" */
+#define PNG_FILTER_HEURISTIC_UNWEIGHTED 1  /* Used by libpng < 0.95 */
+#define PNG_FILTER_HEURISTIC_WEIGHTED   2  /* Experimental feature */
+#define PNG_FILTER_HEURISTIC_LAST       3  /* Not a valid value */
+
+/* Set the library compression level.  Currently, valid values range from
+ * 0 - 9, corresponding directly to the zlib compression levels 0 - 9
+ * (0 - no compression, 9 - "maximal" compression).  Note that tests have
+ * shown that zlib compression levels 3-6 usually perform as well as level 9
+ * for PNG images, and do considerably fewer caclulations.  In the future,
+ * these values may not correspond directly to the zlib compression levels.
+ */
+extern PNG_EXPORT(void,png_set_compression_level) PNGARG((png_structp png_ptr,
+   int level));
+
+extern PNG_EXPORT(void,png_set_compression_mem_level)
+   PNGARG((png_structp png_ptr, int mem_level));
+
+extern PNG_EXPORT(void,png_set_compression_strategy)
+   PNGARG((png_structp png_ptr, int strategy));
+
+extern PNG_EXPORT(void,png_set_compression_window_bits)
+   PNGARG((png_structp png_ptr, int window_bits));
+
+extern PNG_EXPORT(void,png_set_compression_method) PNGARG((png_structp png_ptr,
+   int method));
+
+/* These next functions are called for input/output, memory, and error
+ * handling.  They are in the file pngrio.c, pngwio.c, and pngerror.c,
+ * and call standard C I/O routines such as fread(), fwrite(), and
+ * fprintf().  These functions can be made to use other I/O routines
+ * at run time for those applications that need to handle I/O in a
+ * different manner by calling png_set_???_fn().  See libpng.txt for
+ * more information.
+ */
+
+#if !defined(PNG_NO_STDIO)
+/* Initialize the input/output for the PNG file to the default functions. */
+extern PNG_EXPORT(void,png_init_io) PNGARG((png_structp png_ptr, png_FILE_p fp));
+#endif
+
+/* Replace the (error and abort), and warning functions with user
+ * supplied functions.  If no messages are to be printed you must still
+ * write and use replacement functions. The replacement error_fn should
+ * still do a longjmp to the last setjmp location if you are using this
+ * method of error handling.  If error_fn or warning_fn is NULL, the
+ * default function will be used.
+ */
+
+extern PNG_EXPORT(void,png_set_error_fn) PNGARG((png_structp png_ptr,
+   png_voidp error_ptr, png_error_ptr error_fn, png_error_ptr warning_fn));
+
+/* Return the user pointer associated with the error functions */
+extern PNG_EXPORT(png_voidp,png_get_error_ptr) PNGARG((png_structp png_ptr));
+
+/* Replace the default data output functions with a user supplied one(s).
+ * If buffered output is not used, then output_flush_fn can be set to NULL.
+ * If PNG_WRITE_FLUSH_SUPPORTED is not defined at libpng compile time
+ * output_flush_fn will be ignored (and thus can be NULL).
+ */
+extern PNG_EXPORT(void,png_set_write_fn) PNGARG((png_structp png_ptr,
+   png_voidp io_ptr, png_rw_ptr write_data_fn, png_flush_ptr output_flush_fn));
+
+/* Replace the default data input function with a user supplied one. */
+extern PNG_EXPORT(void,png_set_read_fn) PNGARG((png_structp png_ptr,
+   png_voidp io_ptr, png_rw_ptr read_data_fn));
+
+/* Return the user pointer associated with the I/O functions */
+extern PNG_EXPORT(png_voidp,png_get_io_ptr) PNGARG((png_structp png_ptr));
+
+extern PNG_EXPORT(void,png_set_read_status_fn) PNGARG((png_structp png_ptr,
+   png_read_status_ptr read_row_fn));
+
+extern PNG_EXPORT(void,png_set_write_status_fn) PNGARG((png_structp png_ptr,
+   png_write_status_ptr write_row_fn));
+
+#ifdef PNG_USER_MEM_SUPPORTED
+/* Replace the default memory allocation functions with user supplied one(s). */
+extern PNG_EXPORT(void,png_set_mem_fn) PNGARG((png_structp png_ptr,
+   png_voidp mem_ptr, png_malloc_ptr malloc_fn, png_free_ptr free_fn));
+/* Return the user pointer associated with the memory functions */
+extern PNG_EXPORT(png_voidp,png_get_mem_ptr) PNGARG((png_structp png_ptr));
+#endif
+
+#if defined(PNG_READ_USER_TRANSFORM_SUPPORTED) || \
+    defined(PNG_LEGACY_SUPPORTED)
+extern PNG_EXPORT(void,png_set_read_user_transform_fn) PNGARG((png_structp
+   png_ptr, png_user_transform_ptr read_user_transform_fn));
+#endif
+
+#if defined(PNG_WRITE_USER_TRANSFORM_SUPPORTED) || \
+    defined(PNG_LEGACY_SUPPORTED)
+extern PNG_EXPORT(void,png_set_write_user_transform_fn) PNGARG((png_structp
+   png_ptr, png_user_transform_ptr write_user_transform_fn));
+#endif
+
+#if defined(PNG_READ_USER_TRANSFORM_SUPPORTED) || \
+    defined(PNG_WRITE_USER_TRANSFORM_SUPPORTED) || \
+    defined(PNG_LEGACY_SUPPORTED)
+extern PNG_EXPORT(void,png_set_user_transform_info) PNGARG((png_structp
+   png_ptr, png_voidp user_transform_ptr, int user_transform_depth,
+   int user_transform_channels));
+/* Return the user pointer associated with the user transform functions */
+extern PNG_EXPORT(png_voidp,png_get_user_transform_ptr)
+   PNGARG((png_structp png_ptr));
+#endif
+
+#ifdef PNG_USER_CHUNKS_SUPPORTED
+extern PNG_EXPORT(void,png_set_read_user_chunk_fn) PNGARG((png_structp png_ptr,
+   png_voidp user_chunk_ptr, png_user_chunk_ptr read_user_chunk_fn));
+extern PNG_EXPORT(png_voidp,png_get_user_chunk_ptr) PNGARG((png_structp
+   png_ptr));
+#endif
+
+#ifdef PNG_PROGRESSIVE_READ_SUPPORTED
+/* Sets the function callbacks for the push reader, and a pointer to a
+ * user-defined structure available to the callback functions.
+ */
+extern PNG_EXPORT(void,png_set_progressive_read_fn) PNGARG((png_structp png_ptr,
+   png_voidp progressive_ptr,
+   png_progressive_info_ptr info_fn, png_progressive_row_ptr row_fn,
+   png_progressive_end_ptr end_fn));
+
+/* returns the user pointer associated with the push read functions */
+extern PNG_EXPORT(png_voidp,png_get_progressive_ptr)
+   PNGARG((png_structp png_ptr));
+
+/* function to be called when data becomes available */
+extern PNG_EXPORT(void,png_process_data) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, png_bytep buffer, png_size_t buffer_size));
+
+/* function that combines rows.  Not very much different than the
+ * png_combine_row() call.  Is this even used?????
+ */
+extern PNG_EXPORT(void,png_progressive_combine_row) PNGARG((png_structp png_ptr,
+   png_bytep old_row, png_bytep new_row));
+#endif /* PNG_PROGRESSIVE_READ_SUPPORTED */
+
+extern PNG_EXPORT(png_voidp,png_malloc) PNGARG((png_structp png_ptr,
+   png_uint_32 size));
+
+#if defined(PNG_1_0_X)
+#  define png_malloc_warn png_malloc
+#else
+/* Added at libpng version 1.2.4 */
+extern PNG_EXPORT(png_voidp,png_malloc_warn) PNGARG((png_structp png_ptr,
+   png_uint_32 size));
+#endif
+
+/* frees a pointer allocated by png_malloc() */
+extern PNG_EXPORT(void,png_free) PNGARG((png_structp png_ptr, png_voidp ptr));
+
+#if defined(PNG_1_0_X)
+/* Function to allocate memory for zlib. */
+extern PNG_EXPORT(voidpf,png_zalloc) PNGARG((voidpf png_ptr, uInt items,
+   uInt size));
+
+/* Function to free memory for zlib */
+extern PNG_EXPORT(void,png_zfree) PNGARG((voidpf png_ptr, voidpf ptr));
+#endif
+
+/* Free data that was allocated internally */
+extern PNG_EXPORT(void,png_free_data) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, png_uint_32 free_me, int num));
+#ifdef PNG_FREE_ME_SUPPORTED
+/* Reassign responsibility for freeing existing data, whether allocated
+ * by libpng or by the application */
+extern PNG_EXPORT(void,png_data_freer) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, int freer, png_uint_32 mask));
+#endif
+/* assignments for png_data_freer */
+#define PNG_DESTROY_WILL_FREE_DATA 1
+#define PNG_SET_WILL_FREE_DATA 1
+#define PNG_USER_WILL_FREE_DATA 2
+/* Flags for png_ptr->free_me and info_ptr->free_me */
+#define PNG_FREE_HIST 0x0008
+#define PNG_FREE_ICCP 0x0010
+#define PNG_FREE_SPLT 0x0020
+#define PNG_FREE_ROWS 0x0040
+#define PNG_FREE_PCAL 0x0080
+#define PNG_FREE_SCAL 0x0100
+#define PNG_FREE_UNKN 0x0200
+#define PNG_FREE_LIST 0x0400
+#define PNG_FREE_PLTE 0x1000
+#define PNG_FREE_TRNS 0x2000
+#define PNG_FREE_TEXT 0x4000
+#define PNG_FREE_ALL  0x7fff
+#define PNG_FREE_MUL  0x4220 /* PNG_FREE_SPLT|PNG_FREE_TEXT|PNG_FREE_UNKN */
+
+#ifdef PNG_USER_MEM_SUPPORTED
+extern PNG_EXPORT(png_voidp,png_malloc_default) PNGARG((png_structp png_ptr,
+   png_uint_32 size));
+extern PNG_EXPORT(void,png_free_default) PNGARG((png_structp png_ptr,
+   png_voidp ptr));
+#endif
+
+extern PNG_EXPORT(png_voidp,png_memcpy_check) PNGARG((png_structp png_ptr,
+   png_voidp s1, png_voidp s2, png_uint_32 size));
+
+extern PNG_EXPORT(png_voidp,png_memset_check) PNGARG((png_structp png_ptr,
+   png_voidp s1, int value, png_uint_32 size));
+
+#if defined(USE_FAR_KEYWORD)  /* memory model conversion function */
+extern void *png_far_to_near PNGARG((png_structp png_ptr,png_voidp ptr,
+   int check));
+#endif /* USE_FAR_KEYWORD */
+
+/* Fatal error in PNG image of libpng - can't continue */
+extern PNG_EXPORT(void,png_error) PNGARG((png_structp png_ptr,
+   png_const_charp error_message));
+
+/* The same, but the chunk name is prepended to the error string. */
+extern PNG_EXPORT(void,png_chunk_error) PNGARG((png_structp png_ptr,
+   png_const_charp error_message));
+
+/* Non-fatal error in libpng.  Can continue, but may have a problem. */
+extern PNG_EXPORT(void,png_warning) PNGARG((png_structp png_ptr,
+   png_const_charp warning_message));
+
+/* Non-fatal error in libpng, chunk name is prepended to message. */
+extern PNG_EXPORT(void,png_chunk_warning) PNGARG((png_structp png_ptr,
+   png_const_charp warning_message));
+
+/* The png_set_<chunk> functions are for storing values in the png_info_struct.
+ * Similarly, the png_get_<chunk> calls are used to read values from the
+ * png_info_struct, either storing the parameters in the passed variables, or
+ * setting pointers into the png_info_struct where the data is stored.  The
+ * png_get_<chunk> functions return a non-zero value if the data was available
+ * in info_ptr, or return zero and do not change any of the parameters if the
+ * data was not available.
+ *
+ * These functions should be used instead of directly accessing png_info
+ * to avoid problems with future changes in the size and internal layout of
+ * png_info_struct.
+ */
+/* Returns "flag" if chunk data is valid in info_ptr. */
+extern PNG_EXPORT(png_uint_32,png_get_valid) PNGARG((png_structp png_ptr,
+png_infop info_ptr, png_uint_32 flag));
+
+/* Returns number of bytes needed to hold a transformed row. */
+extern PNG_EXPORT(png_uint_32,png_get_rowbytes) PNGARG((png_structp png_ptr,
+png_infop info_ptr));
+
+#if defined(PNG_INFO_IMAGE_SUPPORTED)
+/* Returns row_pointers, which is an array of pointers to scanlines that was
+returned from png_read_png(). */
+extern PNG_EXPORT(png_bytepp,png_get_rows) PNGARG((png_structp png_ptr,
+png_infop info_ptr));
+/* Set row_pointers, which is an array of pointers to scanlines for use
+by png_write_png(). */
+extern PNG_EXPORT(void,png_set_rows) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, png_bytepp row_pointers));
+#endif
+
+/* Returns number of color channels in image. */
+extern PNG_EXPORT(png_byte,png_get_channels) PNGARG((png_structp png_ptr,
+png_infop info_ptr));
+
+#ifdef PNG_EASY_ACCESS_SUPPORTED
+/* Returns image width in pixels. */
+extern PNG_EXPORT(png_uint_32, png_get_image_width) PNGARG((png_structp
+png_ptr, png_infop info_ptr));
+
+/* Returns image height in pixels. */
+extern PNG_EXPORT(png_uint_32, png_get_image_height) PNGARG((png_structp
+png_ptr, png_infop info_ptr));
+
+/* Returns image bit_depth. */
+extern PNG_EXPORT(png_byte, png_get_bit_depth) PNGARG((png_structp
+png_ptr, png_infop info_ptr));
+
+/* Returns image color_type. */
+extern PNG_EXPORT(png_byte, png_get_color_type) PNGARG((png_structp
+png_ptr, png_infop info_ptr));
+
+/* Returns image filter_type. */
+extern PNG_EXPORT(png_byte, png_get_filter_type) PNGARG((png_structp
+png_ptr, png_infop info_ptr));
+
+/* Returns image interlace_type. */
+extern PNG_EXPORT(png_byte, png_get_interlace_type) PNGARG((png_structp
+png_ptr, png_infop info_ptr));
+
+/* Returns image compression_type. */
+extern PNG_EXPORT(png_byte, png_get_compression_type) PNGARG((png_structp
+png_ptr, png_infop info_ptr));
+
+/* Returns image resolution in pixels per meter, from pHYs chunk data. */
+extern PNG_EXPORT(png_uint_32, png_get_pixels_per_meter) PNGARG((png_structp
+png_ptr, png_infop info_ptr));
+extern PNG_EXPORT(png_uint_32, png_get_x_pixels_per_meter) PNGARG((png_structp
+png_ptr, png_infop info_ptr));
+extern PNG_EXPORT(png_uint_32, png_get_y_pixels_per_meter) PNGARG((png_structp
+png_ptr, png_infop info_ptr));
+
+/* Returns pixel aspect ratio, computed from pHYs chunk data.  */
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+extern PNG_EXPORT(float, png_get_pixel_aspect_ratio) PNGARG((png_structp
+png_ptr, png_infop info_ptr));
+#endif
+
+/* Returns image x, y offset in pixels or microns, from oFFs chunk data. */
+extern PNG_EXPORT(png_int_32, png_get_x_offset_pixels) PNGARG((png_structp
+png_ptr, png_infop info_ptr));
+extern PNG_EXPORT(png_int_32, png_get_y_offset_pixels) PNGARG((png_structp
+png_ptr, png_infop info_ptr));
+extern PNG_EXPORT(png_int_32, png_get_x_offset_microns) PNGARG((png_structp
+png_ptr, png_infop info_ptr));
+extern PNG_EXPORT(png_int_32, png_get_y_offset_microns) PNGARG((png_structp
+png_ptr, png_infop info_ptr));
+
+#endif /* PNG_EASY_ACCESS_SUPPORTED */
+
+/* Returns pointer to signature string read from PNG header */
+extern PNG_EXPORT(png_bytep,png_get_signature) PNGARG((png_structp png_ptr,
+png_infop info_ptr));
+
+#if defined(PNG_bKGD_SUPPORTED)
+extern PNG_EXPORT(png_uint_32,png_get_bKGD) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, png_color_16p *background));
+#endif
+
+#if defined(PNG_bKGD_SUPPORTED)
+extern PNG_EXPORT(void,png_set_bKGD) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, png_color_16p background));
+#endif
+
+#if defined(PNG_cHRM_SUPPORTED)
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+extern PNG_EXPORT(png_uint_32,png_get_cHRM) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, double *white_x, double *white_y, double *red_x,
+   double *red_y, double *green_x, double *green_y, double *blue_x,
+   double *blue_y));
+#endif
+#ifdef PNG_FIXED_POINT_SUPPORTED
+extern PNG_EXPORT(png_uint_32,png_get_cHRM_fixed) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, png_fixed_point *int_white_x, png_fixed_point
+   *int_white_y, png_fixed_point *int_red_x, png_fixed_point *int_red_y,
+   png_fixed_point *int_green_x, png_fixed_point *int_green_y, png_fixed_point
+   *int_blue_x, png_fixed_point *int_blue_y));
+#endif
+#endif
+
+#if defined(PNG_cHRM_SUPPORTED)
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+extern PNG_EXPORT(void,png_set_cHRM) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, double white_x, double white_y, double red_x,
+   double red_y, double green_x, double green_y, double blue_x, double blue_y));
+#endif
+#ifdef PNG_FIXED_POINT_SUPPORTED
+extern PNG_EXPORT(void,png_set_cHRM_fixed) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, png_fixed_point int_white_x, png_fixed_point int_white_y,
+   png_fixed_point int_red_x, png_fixed_point int_red_y, png_fixed_point
+   int_green_x, png_fixed_point int_green_y, png_fixed_point int_blue_x,
+   png_fixed_point int_blue_y));
+#endif
+#endif
+
+#if defined(PNG_gAMA_SUPPORTED)
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+extern PNG_EXPORT(png_uint_32,png_get_gAMA) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, double *file_gamma));
+#endif
+extern PNG_EXPORT(png_uint_32,png_get_gAMA_fixed) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, png_fixed_point *int_file_gamma));
+#endif
+
+#if defined(PNG_gAMA_SUPPORTED)
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+extern PNG_EXPORT(void,png_set_gAMA) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, double file_gamma));
+#endif
+extern PNG_EXPORT(void,png_set_gAMA_fixed) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, png_fixed_point int_file_gamma));
+#endif
+
+#if defined(PNG_hIST_SUPPORTED)
+extern PNG_EXPORT(png_uint_32,png_get_hIST) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, png_uint_16p *hist));
+#endif
+
+#if defined(PNG_hIST_SUPPORTED)
+extern PNG_EXPORT(void,png_set_hIST) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, png_uint_16p hist));
+#endif
+
+extern PNG_EXPORT(png_uint_32,png_get_IHDR) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, png_uint_32 *width, png_uint_32 *height,
+   int *bit_depth, int *color_type, int *interlace_method,
+   int *compression_method, int *filter_method));
+
+extern PNG_EXPORT(void,png_set_IHDR) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, png_uint_32 width, png_uint_32 height, int bit_depth,
+   int color_type, int interlace_method, int compression_method,
+   int filter_method));
+
+#if defined(PNG_oFFs_SUPPORTED)
+extern PNG_EXPORT(png_uint_32,png_get_oFFs) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, png_int_32 *offset_x, png_int_32 *offset_y,
+   int *unit_type));
+#endif
+
+#if defined(PNG_oFFs_SUPPORTED)
+extern PNG_EXPORT(void,png_set_oFFs) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, png_int_32 offset_x, png_int_32 offset_y,
+   int unit_type));
+#endif
+
+#if defined(PNG_pCAL_SUPPORTED)
+extern PNG_EXPORT(png_uint_32,png_get_pCAL) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, png_charp *purpose, png_int_32 *X0, png_int_32 *X1,
+   int *type, int *nparams, png_charp *units, png_charpp *params));
+#endif
+
+#if defined(PNG_pCAL_SUPPORTED)
+extern PNG_EXPORT(void,png_set_pCAL) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, png_charp purpose, png_int_32 X0, png_int_32 X1,
+   int type, int nparams, png_charp units, png_charpp params));
+#endif
+
+#if defined(PNG_pHYs_SUPPORTED)
+extern PNG_EXPORT(png_uint_32,png_get_pHYs) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, png_uint_32 *res_x, png_uint_32 *res_y, int *unit_type));
+#endif
+
+#if defined(PNG_pHYs_SUPPORTED)
+extern PNG_EXPORT(void,png_set_pHYs) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, png_uint_32 res_x, png_uint_32 res_y, int unit_type));
+#endif
+
+extern PNG_EXPORT(png_uint_32,png_get_PLTE) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, png_colorp *palette, int *num_palette));
+
+extern PNG_EXPORT(void,png_set_PLTE) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, png_colorp palette, int num_palette));
+
+#if defined(PNG_sBIT_SUPPORTED)
+extern PNG_EXPORT(png_uint_32,png_get_sBIT) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, png_color_8p *sig_bit));
+#endif
+
+#if defined(PNG_sBIT_SUPPORTED)
+extern PNG_EXPORT(void,png_set_sBIT) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, png_color_8p sig_bit));
+#endif
+
+#if defined(PNG_sRGB_SUPPORTED)
+extern PNG_EXPORT(png_uint_32,png_get_sRGB) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, int *intent));
+#endif
+
+#if defined(PNG_sRGB_SUPPORTED)
+extern PNG_EXPORT(void,png_set_sRGB) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, int intent));
+extern PNG_EXPORT(void,png_set_sRGB_gAMA_and_cHRM) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, int intent));
+#endif
+
+#if defined(PNG_iCCP_SUPPORTED)
+extern PNG_EXPORT(png_uint_32,png_get_iCCP) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, png_charpp name, int *compression_type,
+   png_charpp profile, png_uint_32 *proflen));
+   /* Note to maintainer: profile should be png_bytepp */
+#endif
+
+#if defined(PNG_iCCP_SUPPORTED)
+extern PNG_EXPORT(void,png_set_iCCP) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, png_charp name, int compression_type,
+   png_charp profile, png_uint_32 proflen));
+   /* Note to maintainer: profile should be png_bytep */
+#endif
+
+#if defined(PNG_sPLT_SUPPORTED)
+extern PNG_EXPORT(png_uint_32,png_get_sPLT) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, png_sPLT_tpp entries));
+#endif
+
+#if defined(PNG_sPLT_SUPPORTED)
+extern PNG_EXPORT(void,png_set_sPLT) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, png_sPLT_tp entries, int nentries));
+#endif
+
+#if defined(PNG_TEXT_SUPPORTED)
+/* png_get_text also returns the number of text chunks in *num_text */
+extern PNG_EXPORT(png_uint_32,png_get_text) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, png_textp *text_ptr, int *num_text));
+#endif
+
+/*
+ *  Note while png_set_text() will accept a structure whose text,
+ *  language, and  translated keywords are NULL pointers, the structure
+ *  returned by png_get_text will always contain regular
+ *  zero-terminated C strings.  They might be empty strings but
+ *  they will never be NULL pointers.
+ */
+
+#if defined(PNG_TEXT_SUPPORTED)
+extern PNG_EXPORT(void,png_set_text) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, png_textp text_ptr, int num_text));
+#endif
+
+#if defined(PNG_tIME_SUPPORTED)
+extern PNG_EXPORT(png_uint_32,png_get_tIME) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, png_timep *mod_time));
+#endif
+
+#if defined(PNG_tIME_SUPPORTED)
+extern PNG_EXPORT(void,png_set_tIME) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, png_timep mod_time));
+#endif
+
+#if defined(PNG_tRNS_SUPPORTED)
+extern PNG_EXPORT(png_uint_32,png_get_tRNS) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, png_bytep *trans, int *num_trans,
+   png_color_16p *trans_values));
+#endif
+
+#if defined(PNG_tRNS_SUPPORTED)
+extern PNG_EXPORT(void,png_set_tRNS) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, png_bytep trans, int num_trans,
+   png_color_16p trans_values));
+#endif
+
+#if defined(PNG_tRNS_SUPPORTED)
+#endif
+
+#if defined(PNG_sCAL_SUPPORTED)
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+extern PNG_EXPORT(png_uint_32,png_get_sCAL) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, int *unit, double *width, double *height));
+#else
+#ifdef PNG_FIXED_POINT_SUPPORTED
+extern PNG_EXPORT(png_uint_32,png_get_sCAL_s) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, int *unit, png_charpp swidth, png_charpp sheight));
+#endif
+#endif
+#endif /* PNG_sCAL_SUPPORTED */
+
+#if defined(PNG_sCAL_SUPPORTED)
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+extern PNG_EXPORT(void,png_set_sCAL) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, int unit, double width, double height));
+#endif
+#ifdef PNG_FIXED_POINT_SUPPORTED
+extern PNG_EXPORT(void,png_set_sCAL_s) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, int unit, png_charp swidth, png_charp sheight));
+#endif
+#endif /* PNG_sCAL_SUPPORTED || PNG_WRITE_sCAL_SUPPORTED */
+
+#if defined(PNG_UNKNOWN_CHUNKS_SUPPORTED)
+/* provide a list of chunks and how they are to be handled, if the built-in
+   handling or default unknown chunk handling is not desired.  Any chunks not
+   listed will be handled in the default manner.  The IHDR and IEND chunks
+   must not be listed.
+      keep = 0: follow default behavour
+           = 1: do not keep
+           = 2: keep only if safe-to-copy
+           = 3: keep even if unsafe-to-copy
+*/
+extern PNG_EXPORT(void, png_set_keep_unknown_chunks) PNGARG((png_structp
+   png_ptr, int keep, png_bytep chunk_list, int num_chunks));
+extern PNG_EXPORT(void, png_set_unknown_chunks) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, png_unknown_chunkp unknowns, int num_unknowns));
+extern PNG_EXPORT(void, png_set_unknown_chunk_location)
+   PNGARG((png_structp png_ptr, png_infop info_ptr, int chunk, int location));
+extern PNG_EXPORT(png_uint_32,png_get_unknown_chunks) PNGARG((png_structp
+   png_ptr, png_infop info_ptr, png_unknown_chunkpp entries));
+#endif
+#ifdef PNG_HANDLE_AS_UNKNOWN_SUPPORTED
+PNG_EXPORT(int,png_handle_as_unknown) PNGARG((png_structp png_ptr, png_bytep
+   chunk_name));
+#endif
+
+/* Png_free_data() will turn off the "valid" flag for anything it frees.
+   If you need to turn it off for a chunk that your application has freed,
+   you can use png_set_invalid(png_ptr, info_ptr, PNG_INFO_CHNK); */
+extern PNG_EXPORT(void, png_set_invalid) PNGARG((png_structp png_ptr,
+   png_infop info_ptr, int mask));
+
+#if defined(PNG_INFO_IMAGE_SUPPORTED)
+/* The "params" pointer is currently not used and is for future expansion. */
+extern PNG_EXPORT(void, png_read_png) PNGARG((png_structp png_ptr,
+                        png_infop info_ptr,
+                        int transforms,
+                        png_voidp params));
+extern PNG_EXPORT(void, png_write_png) PNGARG((png_structp png_ptr,
+                        png_infop info_ptr,
+                        int transforms,
+                        png_voidp params));
+#endif
+
+/* Define PNG_DEBUG at compile time for debugging information.  Higher
+ * numbers for PNG_DEBUG mean more debugging information.  This has
+ * only been added since version 0.95 so it is not implemented throughout
+ * libpng yet, but more support will be added as needed.
+ */
+#ifdef PNG_DEBUG
+#if (PNG_DEBUG > 0)
+#if !defined(PNG_DEBUG_FILE) && defined(_MSC_VER)
+#include <crtdbg.h>
+#if (PNG_DEBUG > 1)
+#define png_debug(l,m)  _RPT0(_CRT_WARN,m)
+#define png_debug1(l,m,p1)  _RPT1(_CRT_WARN,m,p1)
+#define png_debug2(l,m,p1,p2) _RPT2(_CRT_WARN,m,p1,p2)
+#endif
+#else /* PNG_DEBUG_FILE || !_MSC_VER */
+#ifndef PNG_DEBUG_FILE
+#define PNG_DEBUG_FILE stderr
+#endif /* PNG_DEBUG_FILE */
+#if (PNG_DEBUG > 1)
+#define png_debug(l,m) \
+{ \
+     int num_tabs=l; \
+     fprintf(PNG_DEBUG_FILE,"%s"m,(num_tabs==1 ? "\t" : \
+       (num_tabs==2 ? "\t\t":(num_tabs>2 ? "\t\t\t":"")))); \
+}
+#define png_debug1(l,m,p1) \
+{ \
+     int num_tabs=l; \
+     fprintf(PNG_DEBUG_FILE,"%s"m,(num_tabs==1 ? "\t" : \
+       (num_tabs==2 ? "\t\t":(num_tabs>2 ? "\t\t\t":""))),p1); \
+}
+#define png_debug2(l,m,p1,p2) \
+{ \
+     int num_tabs=l; \
+     fprintf(PNG_DEBUG_FILE,"%s"m,(num_tabs==1 ? "\t" : \
+       (num_tabs==2 ? "\t\t":(num_tabs>2 ? "\t\t\t":""))),p1,p2); \
+}
+#endif /* (PNG_DEBUG > 1) */
+#endif /* _MSC_VER */
+#endif /* (PNG_DEBUG > 0) */
+#endif /* PNG_DEBUG */
+#ifndef png_debug
+#define png_debug(l, m)
+#endif
+#ifndef png_debug1
+#define png_debug1(l, m, p1)
+#endif
+#ifndef png_debug2
+#define png_debug2(l, m, p1, p2)
+#endif
+
+extern PNG_EXPORT(png_bytep,png_sig_bytes) PNGARG((void));
+
+extern PNG_EXPORT(png_charp,png_get_copyright) PNGARG((png_structp png_ptr));
+extern PNG_EXPORT(png_charp,png_get_header_ver) PNGARG((png_structp png_ptr));
+extern PNG_EXPORT(png_charp,png_get_header_version) PNGARG((png_structp png_ptr));
+extern PNG_EXPORT(png_charp,png_get_libpng_ver) PNGARG((png_structp png_ptr));
+
+#ifdef PNG_MNG_FEATURES_SUPPORTED
+extern PNG_EXPORT(png_uint_32,png_permit_mng_features) PNGARG((png_structp
+   png_ptr, png_uint_32 mng_features_permitted));
+#endif
+
+/* Added to version 1.2.0 */
+#if defined(PNG_ASSEMBLER_CODE_SUPPORTED)
+#define PNG_ASM_FLAG_MMX_SUPPORT_COMPILED  0x01  /* not user-settable */
+#define PNG_ASM_FLAG_MMX_SUPPORT_IN_CPU    0x02  /* not user-settable */
+#define PNG_ASM_FLAG_MMX_READ_COMBINE_ROW  0x04
+#define PNG_ASM_FLAG_MMX_READ_INTERLACE    0x08
+#define PNG_ASM_FLAG_MMX_READ_FILTER_SUB   0x10
+#define PNG_ASM_FLAG_MMX_READ_FILTER_UP    0x20
+#define PNG_ASM_FLAG_MMX_READ_FILTER_AVG   0x40
+#define PNG_ASM_FLAG_MMX_READ_FILTER_PAETH 0x80
+#define PNG_ASM_FLAGS_INITIALIZED          0x80000000  /* not user-settable */
+
+#define PNG_MMX_READ_FLAGS ( PNG_ASM_FLAG_MMX_READ_COMBINE_ROW  \
+                           | PNG_ASM_FLAG_MMX_READ_INTERLACE    \
+                           | PNG_ASM_FLAG_MMX_READ_FILTER_SUB   \
+                           | PNG_ASM_FLAG_MMX_READ_FILTER_UP    \
+                           | PNG_ASM_FLAG_MMX_READ_FILTER_AVG   \
+                           | PNG_ASM_FLAG_MMX_READ_FILTER_PAETH )
+#define PNG_MMX_WRITE_FLAGS ( 0 )
+
+#define PNG_MMX_FLAGS ( PNG_ASM_FLAG_MMX_SUPPORT_COMPILED \
+                      | PNG_ASM_FLAG_MMX_SUPPORT_IN_CPU   \
+                      | PNG_MMX_READ_FLAGS                \
+                      | PNG_MMX_WRITE_FLAGS )
+
+#define PNG_SELECT_READ   1
+#define PNG_SELECT_WRITE  2
+
+
+#if !defined(PNG_1_0_X)
+/* pngget.c */
+extern PNG_EXPORT(png_uint_32,png_get_mmx_flagmask)
+   PNGARG((int flag_select, int *compilerID));
+
+/* pngget.c */
+extern PNG_EXPORT(png_uint_32,png_get_asm_flagmask)
+   PNGARG((int flag_select));
+
+/* pngget.c */
+extern PNG_EXPORT(png_uint_32,png_get_asm_flags)
+   PNGARG((png_structp png_ptr));
+
+/* pngget.c */
+extern PNG_EXPORT(png_byte,png_get_mmx_bitdepth_threshold)
+   PNGARG((png_structp png_ptr));
+
+/* pngget.c */
+extern PNG_EXPORT(png_uint_32,png_get_mmx_rowbytes_threshold)
+   PNGARG((png_structp png_ptr));
+
+/* pngset.c */
+extern PNG_EXPORT(void,png_set_asm_flags)
+   PNGARG((png_structp png_ptr, png_uint_32 asm_flags));
+
+/* pngset.c */
+extern PNG_EXPORT(void,png_set_mmx_thresholds)
+   PNGARG((png_structp png_ptr, png_byte mmx_bitdepth_threshold,
+   png_uint_32 mmx_rowbytes_threshold));
+
+#endif /* PNG_1_0_X */
+#endif /* PNG_ASSEMBLER_CODE_SUPPORTED */
+
+#if !defined(PNG_1_0_X)
+/* png.c, pnggccrd.c, or pngvcrd.c */
+extern PNG_EXPORT(int,png_mmx_support) PNGARG((void));
+
+/* Strip the prepended error numbers ("#nnn ") from error and warning
+ * messages before passing them to the error or warning handler. */
+#ifdef PNG_ERROR_NUMBERS_SUPPORTED
+extern PNG_EXPORT(void,png_set_strip_error_numbers) PNGARG((png_structp
+   png_ptr, png_uint_32 strip_mode));
+#endif
+#endif /* PNG_1_0_X */
+
+/* Maintainer: Put new public prototypes here ^, in libpng.3, and project defs */
+
+#define PNG_HEADER_VERSION_STRING \
+   " libpng version 1.2.5 - October 3, 2002 (header)\n"
+
+#ifdef PNG_READ_COMPOSITE_NODIV_SUPPORTED
+/* With these routines we avoid an integer divide, which will be slower on
+ * most machines.  However, it does take more operations than the corresponding
+ * divide method, so it may be slower on a few RISC systems.  There are two
+ * shifts (by 8 or 16 bits) and an addition, versus a single integer divide.
+ *
+ * Note that the rounding factors are NOT supposed to be the same!  128 and
+ * 32768 are correct for the NODIV code; 127 and 32767 are correct for the
+ * standard method.
+ *
+ * [Optimized code by Greg Roelofs and Mark Adler...blame us for bugs. :-) ]
+ */
+
+ /* fg and bg should be in `gamma 1.0' space; alpha is the opacity          */
+
+#  define png_composite(composite, fg, alpha, bg)                            \
+     { png_uint_16 temp = (png_uint_16)((png_uint_16)(fg) * (png_uint_16)(alpha) \
+                        +        (png_uint_16)(bg)*(png_uint_16)(255 -       \
+                        (png_uint_16)(alpha)) + (png_uint_16)128);           \
+       (composite) = (png_byte)((temp + (temp >> 8)) >> 8); }
+
+#  define png_composite_16(composite, fg, alpha, bg)                         \
+     { png_uint_32 temp = (png_uint_32)((png_uint_32)(fg) * (png_uint_32)(alpha) \
+                        + (png_uint_32)(bg)*(png_uint_32)(65535L -           \
+                        (png_uint_32)(alpha)) + (png_uint_32)32768L);        \
+       (composite) = (png_uint_16)((temp + (temp >> 16)) >> 16); }
+
+#else  /* standard method using integer division */
+
+#  define png_composite(composite, fg, alpha, bg)                            \
+     (composite) = (png_byte)(((png_uint_16)(fg) * (png_uint_16)(alpha) +    \
+       (png_uint_16)(bg) * (png_uint_16)(255 - (png_uint_16)(alpha)) +       \
+       (png_uint_16)127) / 255)
+
+#  define png_composite_16(composite, fg, alpha, bg)                         \
+     (composite) = (png_uint_16)(((png_uint_32)(fg) * (png_uint_32)(alpha) + \
+       (png_uint_32)(bg)*(png_uint_32)(65535L - (png_uint_32)(alpha)) +      \
+       (png_uint_32)32767) / (png_uint_32)65535L)
+
+#endif /* PNG_READ_COMPOSITE_NODIV_SUPPORTED */
+
+/* These next functions are used internally in the code.  They generally
+ * shouldn't be used unless you are writing code to add or replace some
+ * functionality in libpng.  More information about most functions can
+ * be found in the files where the functions are located.
+ */
+
+#if defined(PNG_INTERNAL)
+
+/* Various modes of operation.  Note that after an init, mode is set to
+ * zero automatically when the structure is created.
+ */
+#define PNG_HAVE_IHDR               0x01
+#define PNG_HAVE_PLTE               0x02
+#define PNG_HAVE_IDAT               0x04
+#define PNG_AFTER_IDAT              0x08
+#define PNG_HAVE_IEND               0x10
+#define PNG_HAVE_gAMA               0x20
+#define PNG_HAVE_cHRM               0x40
+#define PNG_HAVE_sRGB               0x80
+#define PNG_HAVE_CHUNK_HEADER      0x100
+#define PNG_WROTE_tIME             0x200
+#define PNG_WROTE_INFO_BEFORE_PLTE 0x400
+#define PNG_BACKGROUND_IS_GRAY     0x800
+#define PNG_HAVE_PNG_SIGNATURE    0x1000
+
+/* flags for the transformations the PNG library does on the image data */
+#define PNG_BGR                0x0001
+#define PNG_INTERLACE          0x0002
+#define PNG_PACK               0x0004
+#define PNG_SHIFT              0x0008
+#define PNG_SWAP_BYTES         0x0010
+#define PNG_INVERT_MONO        0x0020
+#define PNG_DITHER             0x0040
+#define PNG_BACKGROUND         0x0080
+#define PNG_BACKGROUND_EXPAND  0x0100
+                          /*   0x0200 unused */
+#define PNG_16_TO_8            0x0400
+#define PNG_RGBA               0x0800
+#define PNG_EXPAND             0x1000
+#define PNG_GAMMA              0x2000
+#define PNG_GRAY_TO_RGB        0x4000
+#define PNG_FILLER             0x8000L
+#define PNG_PACKSWAP          0x10000L
+#define PNG_SWAP_ALPHA        0x20000L
+#define PNG_STRIP_ALPHA       0x40000L
+#define PNG_INVERT_ALPHA      0x80000L
+#define PNG_USER_TRANSFORM   0x100000L
+#define PNG_RGB_TO_GRAY_ERR  0x200000L
+#define PNG_RGB_TO_GRAY_WARN 0x400000L
+#define PNG_RGB_TO_GRAY      0x600000L  /* two bits, RGB_TO_GRAY_ERR|WARN */
+
+/* flags for png_create_struct */
+#define PNG_STRUCT_PNG   0x0001
+#define PNG_STRUCT_INFO  0x0002
+
+/* Scaling factor for filter heuristic weighting calculations */
+#define PNG_WEIGHT_SHIFT 8
+#define PNG_WEIGHT_FACTOR (1<<(PNG_WEIGHT_SHIFT))
+#define PNG_COST_SHIFT 3
+#define PNG_COST_FACTOR (1<<(PNG_COST_SHIFT))
+
+/* flags for the png_ptr->flags rather than declaring a byte for each one */
+#define PNG_FLAG_ZLIB_CUSTOM_STRATEGY     0x0001
+#define PNG_FLAG_ZLIB_CUSTOM_LEVEL        0x0002
+#define PNG_FLAG_ZLIB_CUSTOM_MEM_LEVEL    0x0004
+#define PNG_FLAG_ZLIB_CUSTOM_WINDOW_BITS  0x0008
+#define PNG_FLAG_ZLIB_CUSTOM_METHOD       0x0010
+#define PNG_FLAG_ZLIB_FINISHED            0x0020
+#define PNG_FLAG_ROW_INIT                 0x0040
+#define PNG_FLAG_FILLER_AFTER             0x0080
+#define PNG_FLAG_CRC_ANCILLARY_USE        0x0100
+#define PNG_FLAG_CRC_ANCILLARY_NOWARN     0x0200
+#define PNG_FLAG_CRC_CRITICAL_USE         0x0400
+#define PNG_FLAG_CRC_CRITICAL_IGNORE      0x0800
+#define PNG_FLAG_FREE_PLTE                0x1000
+#define PNG_FLAG_FREE_TRNS                0x2000
+#define PNG_FLAG_FREE_HIST                0x4000
+#define PNG_FLAG_KEEP_UNKNOWN_CHUNKS      0x8000L
+#define PNG_FLAG_KEEP_UNSAFE_CHUNKS       0x10000L
+#define PNG_FLAG_LIBRARY_MISMATCH         0x20000L
+#define PNG_FLAG_STRIP_ERROR_NUMBERS      0x40000L
+#define PNG_FLAG_STRIP_ERROR_TEXT         0x80000L
+#define PNG_FLAG_MALLOC_NULL_MEM_OK       0x100000L
+
+/* For use in png_set_keep_unknown, png_handle_as_unknown */
+#define HANDLE_CHUNK_AS_DEFAULT   0
+#define HANDLE_CHUNK_NEVER        1
+#define HANDLE_CHUNK_IF_SAFE      2
+#define HANDLE_CHUNK_ALWAYS       3
+
+#define PNG_FLAG_CRC_ANCILLARY_MASK (PNG_FLAG_CRC_ANCILLARY_USE | \
+                                     PNG_FLAG_CRC_ANCILLARY_NOWARN)
+
+#define PNG_FLAG_CRC_CRITICAL_MASK  (PNG_FLAG_CRC_CRITICAL_USE | \
+                                     PNG_FLAG_CRC_CRITICAL_IGNORE)
+
+#define PNG_FLAG_CRC_MASK           (PNG_FLAG_CRC_ANCILLARY_MASK | \
+                                     PNG_FLAG_CRC_CRITICAL_MASK)
+
+/* save typing and make code easier to understand */
+#define PNG_COLOR_DIST(c1, c2) (abs((int)((c1).red) - (int)((c2).red)) + \
+   abs((int)((c1).green) - (int)((c2).green)) + \
+   abs((int)((c1).blue) - (int)((c2).blue)))
+
+/* variables declared in png.c - only it needs to define PNG_NO_EXTERN */
+#if !defined(PNG_NO_EXTERN) || defined(PNG_ALWAYS_EXTERN)
+/* place to hold the signature string for a PNG file. */
+#ifdef PNG_USE_GLOBAL_ARRAYS
+   PNG_EXPORT_VAR (const png_byte FARDATA) png_sig[8];
+#else
+#define png_sig png_sig_bytes(NULL)
+#endif
+#endif /* PNG_NO_EXTERN */
+
+/* Constant strings for known chunk types.  If you need to add a chunk,
+ * define the name here, and add an invocation of the macro in png.c and
+ * wherever it's needed.
+ */
+#define PNG_IHDR const png_byte png_IHDR[5] = { 73,  72,  68,  82, '\0'}
+#define PNG_IDAT const png_byte png_IDAT[5] = { 73,  68,  65,  84, '\0'}
+#define PNG_IEND const png_byte png_IEND[5] = { 73,  69,  78,  68, '\0'}
+#define PNG_PLTE const png_byte png_PLTE[5] = { 80,  76,  84,  69, '\0'}
+#define PNG_bKGD const png_byte png_bKGD[5] = { 98,  75,  71,  68, '\0'}
+#define PNG_cHRM const png_byte png_cHRM[5] = { 99,  72,  82,  77, '\0'}
+#define PNG_gAMA const png_byte png_gAMA[5] = {103,  65,  77,  65, '\0'}
+#define PNG_hIST const png_byte png_hIST[5] = {104,  73,  83,  84, '\0'}
+#define PNG_iCCP const png_byte png_iCCP[5] = {105,  67,  67,  80, '\0'}
+#define PNG_iTXt const png_byte png_iTXt[5] = {105,  84,  88, 116, '\0'}
+#define PNG_oFFs const png_byte png_oFFs[5] = {111,  70,  70, 115, '\0'}
+#define PNG_pCAL const png_byte png_pCAL[5] = {112,  67,  65,  76, '\0'}
+#define PNG_sCAL const png_byte png_sCAL[5] = {115,  67,  65,  76, '\0'}
+#define PNG_pHYs const png_byte png_pHYs[5] = {112,  72,  89, 115, '\0'}
+#define PNG_sBIT const png_byte png_sBIT[5] = {115,  66,  73,  84, '\0'}
+#define PNG_sPLT const png_byte png_sPLT[5] = {115,  80,  76,  84, '\0'}
+#define PNG_sRGB const png_byte png_sRGB[5] = {115,  82,  71,  66, '\0'}
+#define PNG_tEXt const png_byte png_tEXt[5] = {116,  69,  88, 116, '\0'}
+#define PNG_tIME const png_byte png_tIME[5] = {116,  73,  77,  69, '\0'}
+#define PNG_tRNS const png_byte png_tRNS[5] = {116,  82,  78,  83, '\0'}
+#define PNG_zTXt const png_byte png_zTXt[5] = {122,  84,  88, 116, '\0'}
+
+#ifdef PNG_USE_GLOBAL_ARRAYS
+PNG_EXPORT_VAR (const png_byte FARDATA) png_IHDR[5];
+PNG_EXPORT_VAR (const png_byte FARDATA) png_IDAT[5];
+PNG_EXPORT_VAR (const png_byte FARDATA) png_IEND[5];
+PNG_EXPORT_VAR (const png_byte FARDATA) png_PLTE[5];
+PNG_EXPORT_VAR (const png_byte FARDATA) png_bKGD[5];
+PNG_EXPORT_VAR (const png_byte FARDATA) png_cHRM[5];
+PNG_EXPORT_VAR (const png_byte FARDATA) png_gAMA[5];
+PNG_EXPORT_VAR (const png_byte FARDATA) png_hIST[5];
+PNG_EXPORT_VAR (const png_byte FARDATA) png_iCCP[5];
+PNG_EXPORT_VAR (const png_byte FARDATA) png_iTXt[5];
+PNG_EXPORT_VAR (const png_byte FARDATA) png_oFFs[5];
+PNG_EXPORT_VAR (const png_byte FARDATA) png_pCAL[5];
+PNG_EXPORT_VAR (const png_byte FARDATA) png_sCAL[5];
+PNG_EXPORT_VAR (const png_byte FARDATA) png_pHYs[5];
+PNG_EXPORT_VAR (const png_byte FARDATA) png_sBIT[5];
+PNG_EXPORT_VAR (const png_byte FARDATA) png_sPLT[5];
+PNG_EXPORT_VAR (const png_byte FARDATA) png_sRGB[5];
+PNG_EXPORT_VAR (const png_byte FARDATA) png_tEXt[5];
+PNG_EXPORT_VAR (const png_byte FARDATA) png_tIME[5];
+PNG_EXPORT_VAR (const png_byte FARDATA) png_tRNS[5];
+PNG_EXPORT_VAR (const png_byte FARDATA) png_zTXt[5];
+#endif /* PNG_USE_GLOBAL_ARRAYS */
+
+
+/* Inline macros to do direct reads of bytes from the input buffer.  These
+ * require that you are using an architecture that uses PNG byte ordering
+ * (MSB first) and supports unaligned data storage.  I think that PowerPC
+ * in big-endian mode and 680x0 are the only ones that will support this.
+ * The x86 line of processors definitely do not.  The png_get_int_32()
+ * routine also assumes we are using two's complement format for negative
+ * values, which is almost certainly true.
+ */
+#if defined(PNG_READ_BIG_ENDIAN_SUPPORTED)
+#  if defined(PNG_pCAL_SUPPORTED) || defined(PNG_oFFs_SUPPORTED)
+#    define png_get_int_32(buf) ( *((png_int_32p) (buf)))
+#  endif
+#  define png_get_uint_32(buf) ( *((png_uint_32p) (buf)))
+#  define png_get_uint_16(buf) ( *((png_uint_16p) (buf)))
+#else
+#  if defined(PNG_pCAL_SUPPORTED) || defined(PNG_oFFs_SUPPORTED)
+PNG_EXTERN png_int_32 png_get_int_32 PNGARG((png_bytep buf));
+#  endif
+PNG_EXTERN png_uint_32 png_get_uint_32 PNGARG((png_bytep buf));
+PNG_EXTERN png_uint_16 png_get_uint_16 PNGARG((png_bytep buf));
+#endif /* !PNG_READ_BIG_ENDIAN_SUPPORTED */
+
+/* Initialize png_ptr struct for reading, and allocate any other memory.
+ * (old interface - DEPRECATED - use png_create_read_struct instead).
+ */
+extern PNG_EXPORT(void,png_read_init) PNGARG((png_structp png_ptr));
+#undef png_read_init
+#define png_read_init(png_ptr) png_read_init_3(&png_ptr, \
+    PNG_LIBPNG_VER_STRING,  sizeof(png_struct));
+extern PNG_EXPORT(void,png_read_init_3) PNGARG((png_structpp ptr_ptr,
+    png_const_charp user_png_ver, png_size_t png_struct_size));
+extern PNG_EXPORT(void,png_read_init_2) PNGARG((png_structp png_ptr,
+    png_const_charp user_png_ver, png_size_t png_struct_size, png_size_t
+    png_info_size));
+
+/* Initialize png_ptr struct for writing, and allocate any other memory.
+ * (old interface - DEPRECATED - use png_create_write_struct instead).
+ */
+extern PNG_EXPORT(void,png_write_init) PNGARG((png_structp png_ptr));
+#undef png_write_init
+#define png_write_init(png_ptr) png_write_init_3(&png_ptr, \
+    PNG_LIBPNG_VER_STRING, sizeof(png_struct));
+extern PNG_EXPORT(void,png_write_init_3) PNGARG((png_structpp ptr_ptr,
+    png_const_charp user_png_ver, png_size_t png_struct_size));
+extern PNG_EXPORT(void,png_write_init_2) PNGARG((png_structp png_ptr,
+    png_const_charp user_png_ver, png_size_t png_struct_size, png_size_t
+    png_info_size));
+
+/* Allocate memory for an internal libpng struct */
+PNG_EXTERN png_voidp png_create_struct PNGARG((int type));
+
+/* Free memory from internal libpng struct */
+PNG_EXTERN void png_destroy_struct PNGARG((png_voidp struct_ptr));
+
+PNG_EXTERN png_voidp png_create_struct_2 PNGARG((int type, png_malloc_ptr
+  malloc_fn, png_voidp mem_ptr));
+PNG_EXTERN void png_destroy_struct_2 PNGARG((png_voidp struct_ptr,
+   png_free_ptr free_fn, png_voidp mem_ptr));
+
+/* Free any memory that info_ptr points to and reset struct. */
+PNG_EXTERN void png_info_destroy PNGARG((png_structp png_ptr,
+   png_infop info_ptr));
+
+#ifndef PNG_1_0_X
+/* Function to allocate memory for zlib. */
+PNG_EXTERN voidpf png_zalloc PNGARG((voidpf png_ptr, uInt items, uInt size));
+
+/* Function to free memory for zlib */
+PNG_EXTERN void png_zfree PNGARG((voidpf png_ptr, voidpf ptr));
+
+/* Next four functions are used internally as callbacks.  PNGAPI is required
+ * but not PNG_EXPORT.  PNGAPI added at libpng version 1.2.3. */
+
+PNG_EXTERN void PNGAPI png_default_read_data PNGARG((png_structp png_ptr,
+   png_bytep data, png_size_t length));
+
+#ifdef PNG_PROGRESSIVE_READ_SUPPORTED
+PNG_EXTERN void PNGAPI png_push_fill_buffer PNGARG((png_structp png_ptr,
+   png_bytep buffer, png_size_t length));
+#endif
+
+PNG_EXTERN void PNGAPI png_default_write_data PNGARG((png_structp png_ptr,
+   png_bytep data, png_size_t length));
+
+#if defined(PNG_WRITE_FLUSH_SUPPORTED)
+#if !defined(PNG_NO_STDIO)
+PNG_EXTERN void PNGAPI png_default_flush PNGARG((png_structp png_ptr));
+#endif
+#endif
+#else /* PNG_1_0_X */
+#ifdef PNG_PROGRESSIVE_READ_SUPPORTED
+PNG_EXTERN void png_push_fill_buffer PNGARG((png_structp png_ptr,
+   png_bytep buffer, png_size_t length));
+#endif
+#endif /* PNG_1_0_X */
+
+/* Reset the CRC variable */
+PNG_EXTERN void png_reset_crc PNGARG((png_structp png_ptr));
+
+/* Write the "data" buffer to whatever output you are using. */
+PNG_EXTERN void png_write_data PNGARG((png_structp png_ptr, png_bytep data,
+   png_size_t length));
+
+/* Read data from whatever input you are using into the "data" buffer */
+PNG_EXTERN void png_read_data PNGARG((png_structp png_ptr, png_bytep data,
+   png_size_t length));
+
+/* Read bytes into buf, and update png_ptr->crc */
+PNG_EXTERN void png_crc_read PNGARG((png_structp png_ptr, png_bytep buf,
+   png_size_t length));
+
+/* Decompress data in a chunk that uses compression */
+#if defined(PNG_zTXt_SUPPORTED) || defined(PNG_iTXt_SUPPORTED) || \
+    defined(PNG_iCCP_SUPPORTED) || defined(PNG_sPLT_SUPPORTED)
+PNG_EXTERN png_charp png_decompress_chunk PNGARG((png_structp png_ptr,
+   int comp_type, png_charp chunkdata, png_size_t chunklength,
+   png_size_t prefix_length, png_size_t *data_length));
+#endif
+
+/* Read "skip" bytes, read the file crc, and (optionally) verify png_ptr->crc */
+PNG_EXTERN int png_crc_finish PNGARG((png_structp png_ptr, png_uint_32 skip));
+
+/* Read the CRC from the file and compare it to the libpng calculated CRC */
+PNG_EXTERN int png_crc_error PNGARG((png_structp png_ptr));
+
+/* Calculate the CRC over a section of data.  Note that we are only
+ * passing a maximum of 64K on systems that have this as a memory limit,
+ * since this is the maximum buffer size we can specify.
+ */
+PNG_EXTERN void png_calculate_crc PNGARG((png_structp png_ptr, png_bytep ptr,
+   png_size_t length));
+
+#if defined(PNG_WRITE_FLUSH_SUPPORTED)
+PNG_EXTERN void png_flush PNGARG((png_structp png_ptr));
+#endif
+
+
+/* Place a 32-bit number into a buffer in PNG byte order (big-endian).
+ * The only currently known PNG chunks that use signed numbers are
+ * the ancillary extension chunks, oFFs and pCAL.
+ */
+PNG_EXTERN void png_save_uint_32 PNGARG((png_bytep buf, png_uint_32 i));
+
+#if defined(PNG_WRITE_pCAL_SUPPORTED) || defined(PNG_WRITE_oFFs_SUPPORTED)
+PNG_EXTERN void png_save_int_32 PNGARG((png_bytep buf, png_int_32 i));
+#endif
+
+/* Place a 16-bit number into a buffer in PNG byte order.
+ * The parameter is declared unsigned int, not png_uint_16,
+ * just to avoid potential problems on pre-ANSI C compilers.
+ */
+PNG_EXTERN void png_save_uint_16 PNGARG((png_bytep buf, unsigned int i));
+
+/* simple function to write the signature */
+PNG_EXTERN void png_write_sig PNGARG((png_structp png_ptr));
+
+/* write various chunks */
+
+/* Write the IHDR chunk, and update the png_struct with the necessary
+ * information.
+ */
+PNG_EXTERN void png_write_IHDR PNGARG((png_structp png_ptr, png_uint_32 width,
+   png_uint_32 height,
+   int bit_depth, int color_type, int compression_method, int filter_method,
+   int interlace_method));
+
+PNG_EXTERN void png_write_PLTE PNGARG((png_structp png_ptr, png_colorp palette,
+   png_uint_32 num_pal));
+
+PNG_EXTERN void png_write_IDAT PNGARG((png_structp png_ptr, png_bytep data,
+   png_size_t length));
+
+PNG_EXTERN void png_write_IEND PNGARG((png_structp png_ptr));
+
+#if defined(PNG_WRITE_gAMA_SUPPORTED)
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+PNG_EXTERN void png_write_gAMA PNGARG((png_structp png_ptr, double file_gamma));
+#endif
+#ifdef PNG_FIXED_POINT_SUPPORTED
+PNG_EXTERN void png_write_gAMA_fixed PNGARG((png_structp png_ptr, png_fixed_point
+    file_gamma));
+#endif
+#endif
+
+#if defined(PNG_WRITE_sBIT_SUPPORTED)
+PNG_EXTERN void png_write_sBIT PNGARG((png_structp png_ptr, png_color_8p sbit,
+   int color_type));
+#endif
+
+#if defined(PNG_WRITE_cHRM_SUPPORTED)
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+PNG_EXTERN void png_write_cHRM PNGARG((png_structp png_ptr,
+   double white_x, double white_y,
+   double red_x, double red_y, double green_x, double green_y,
+   double blue_x, double blue_y));
+#endif
+#ifdef PNG_FIXED_POINT_SUPPORTED
+PNG_EXTERN void png_write_cHRM_fixed PNGARG((png_structp png_ptr,
+   png_fixed_point int_white_x, png_fixed_point int_white_y,
+   png_fixed_point int_red_x, png_fixed_point int_red_y, png_fixed_point
+   int_green_x, png_fixed_point int_green_y, png_fixed_point int_blue_x,
+   png_fixed_point int_blue_y));
+#endif
+#endif
+
+#if defined(PNG_WRITE_sRGB_SUPPORTED)
+PNG_EXTERN void png_write_sRGB PNGARG((png_structp png_ptr,
+   int intent));
+#endif
+
+#if defined(PNG_WRITE_iCCP_SUPPORTED)
+PNG_EXTERN void png_write_iCCP PNGARG((png_structp png_ptr,
+   png_charp name, int compression_type,
+   png_charp profile, int proflen));
+   /* Note to maintainer: profile should be png_bytep */
+#endif
+
+#if defined(PNG_WRITE_sPLT_SUPPORTED)
+PNG_EXTERN void png_write_sPLT PNGARG((png_structp png_ptr,
+   png_sPLT_tp palette));
+#endif
+
+#if defined(PNG_WRITE_tRNS_SUPPORTED)
+PNG_EXTERN void png_write_tRNS PNGARG((png_structp png_ptr, png_bytep trans,
+   png_color_16p values, int number, int color_type));
+#endif
+
+#if defined(PNG_WRITE_bKGD_SUPPORTED)
+PNG_EXTERN void png_write_bKGD PNGARG((png_structp png_ptr,
+   png_color_16p values, int color_type));
+#endif
+
+#if defined(PNG_WRITE_hIST_SUPPORTED)
+PNG_EXTERN void png_write_hIST PNGARG((png_structp png_ptr, png_uint_16p hist,
+   int num_hist));
+#endif
+
+#if defined(PNG_WRITE_TEXT_SUPPORTED) || defined(PNG_WRITE_pCAL_SUPPORTED) || \
+    defined(PNG_WRITE_iCCP_SUPPORTED) || defined(PNG_WRITE_sPLT_SUPPORTED)
+PNG_EXTERN png_size_t png_check_keyword PNGARG((png_structp png_ptr,
+   png_charp key, png_charpp new_key));
+#endif
+
+#if defined(PNG_WRITE_tEXt_SUPPORTED)
+PNG_EXTERN void png_write_tEXt PNGARG((png_structp png_ptr, png_charp key,
+   png_charp text, png_size_t text_len));
+#endif
+
+#if defined(PNG_WRITE_zTXt_SUPPORTED)
+PNG_EXTERN void png_write_zTXt PNGARG((png_structp png_ptr, png_charp key,
+   png_charp text, png_size_t text_len, int compression));
+#endif
+
+#if defined(PNG_WRITE_iTXt_SUPPORTED)
+PNG_EXTERN void png_write_iTXt PNGARG((png_structp png_ptr,
+   int compression, png_charp key, png_charp lang, png_charp lang_key,
+   png_charp text));
+#endif
+
+#if defined(PNG_TEXT_SUPPORTED)  /* Added at version 1.0.14 and 1.2.4 */
+PNG_EXTERN int png_set_text_2 PNGARG((png_structp png_ptr,
+   png_infop info_ptr, png_textp text_ptr, int num_text));
+#endif
+
+#if defined(PNG_WRITE_oFFs_SUPPORTED)
+PNG_EXTERN void png_write_oFFs PNGARG((png_structp png_ptr,
+   png_int_32 x_offset, png_int_32 y_offset, int unit_type));
+#endif
+
+#if defined(PNG_WRITE_pCAL_SUPPORTED)
+PNG_EXTERN void png_write_pCAL PNGARG((png_structp png_ptr, png_charp purpose,
+   png_int_32 X0, png_int_32 X1, int type, int nparams,
+   png_charp units, png_charpp params));
+#endif
+
+#if defined(PNG_WRITE_pHYs_SUPPORTED)
+PNG_EXTERN void png_write_pHYs PNGARG((png_structp png_ptr,
+   png_uint_32 x_pixels_per_unit, png_uint_32 y_pixels_per_unit,
+   int unit_type));
+#endif
+
+#if defined(PNG_WRITE_tIME_SUPPORTED)
+PNG_EXTERN void png_write_tIME PNGARG((png_structp png_ptr,
+   png_timep mod_time));
+#endif
+
+#if defined(PNG_WRITE_sCAL_SUPPORTED)
+#if defined(PNG_FLOATING_POINT_SUPPORTED) && !defined(PNG_NO_STDIO)
+PNG_EXTERN void png_write_sCAL PNGARG((png_structp png_ptr,
+   int unit, double width, double height));
+#else
+#ifdef PNG_FIXED_POINT_SUPPORTED
+PNG_EXTERN void png_write_sCAL_s PNGARG((png_structp png_ptr,
+   int unit, png_charp width, png_charp height));
+#endif
+#endif
+#endif
+
+/* Called when finished processing a row of data */
+PNG_EXTERN void png_write_finish_row PNGARG((png_structp png_ptr));
+
+/* Internal use only.   Called before first row of data */
+PNG_EXTERN void png_write_start_row PNGARG((png_structp png_ptr));
+
+#if defined(PNG_READ_GAMMA_SUPPORTED)
+PNG_EXTERN void png_build_gamma_table PNGARG((png_structp png_ptr));
+#endif
+
+/* combine a row of data, dealing with alpha, etc. if requested */
+PNG_EXTERN void png_combine_row PNGARG((png_structp png_ptr, png_bytep row,
+   int mask));
+
+#if defined(PNG_READ_INTERLACING_SUPPORTED)
+/* expand an interlaced row */
+/* OLD pre-1.0.9 interface:
+PNG_EXTERN void png_do_read_interlace PNGARG((png_row_infop row_info,
+   png_bytep row, int pass, png_uint_32 transformations));
+ */
+PNG_EXTERN void png_do_read_interlace PNGARG((png_structp png_ptr));
+#endif
+
+/* GRR TO DO (2.0 or whenever):  simplify other internal calling interfaces */
+
+#if defined(PNG_WRITE_INTERLACING_SUPPORTED)
+/* grab pixels out of a row for an interlaced pass */
+PNG_EXTERN void png_do_write_interlace PNGARG((png_row_infop row_info,
+   png_bytep row, int pass));
+#endif
+
+/* unfilter a row */
+PNG_EXTERN void png_read_filter_row PNGARG((png_structp png_ptr,
+   png_row_infop row_info, png_bytep row, png_bytep prev_row, int filter));
+
+/* Choose the best filter to use and filter the row data */
+PNG_EXTERN void png_write_find_filter PNGARG((png_structp png_ptr,
+   png_row_infop row_info));
+
+/* Write out the filtered row. */
+PNG_EXTERN void png_write_filtered_row PNGARG((png_structp png_ptr,
+   png_bytep filtered_row));
+/* finish a row while reading, dealing with interlacing passes, etc. */
+PNG_EXTERN void png_read_finish_row PNGARG((png_structp png_ptr));
+
+/* initialize the row buffers, etc. */
+PNG_EXTERN void png_read_start_row PNGARG((png_structp png_ptr));
+/* optional call to update the users info structure */
+PNG_EXTERN void png_read_transform_info PNGARG((png_structp png_ptr,
+   png_infop info_ptr));
+
+/* these are the functions that do the transformations */
+#if defined(PNG_READ_FILLER_SUPPORTED)
+PNG_EXTERN void png_do_read_filler PNGARG((png_row_infop row_info,
+   png_bytep row, png_uint_32 filler, png_uint_32 flags));
+#endif
+
+#if defined(PNG_READ_SWAP_ALPHA_SUPPORTED)
+PNG_EXTERN void png_do_read_swap_alpha PNGARG((png_row_infop row_info,
+   png_bytep row));
+#endif
+
+#if defined(PNG_WRITE_SWAP_ALPHA_SUPPORTED)
+PNG_EXTERN void png_do_write_swap_alpha PNGARG((png_row_infop row_info,
+   png_bytep row));
+#endif
+
+#if defined(PNG_READ_INVERT_ALPHA_SUPPORTED)
+PNG_EXTERN void png_do_read_invert_alpha PNGARG((png_row_infop row_info,
+   png_bytep row));
+#endif
+
+#if defined(PNG_WRITE_INVERT_ALPHA_SUPPORTED)
+PNG_EXTERN void png_do_write_invert_alpha PNGARG((png_row_infop row_info,
+   png_bytep row));
+#endif
+
+#if defined(PNG_WRITE_FILLER_SUPPORTED) || \
+    defined(PNG_READ_STRIP_ALPHA_SUPPORTED)
+PNG_EXTERN void png_do_strip_filler PNGARG((png_row_infop row_info,
+   png_bytep row, png_uint_32 flags));
+#endif
+
+#if defined(PNG_READ_SWAP_SUPPORTED) || defined(PNG_WRITE_SWAP_SUPPORTED)
+PNG_EXTERN void png_do_swap PNGARG((png_row_infop row_info, png_bytep row));
+#endif
+
+#if defined(PNG_READ_PACKSWAP_SUPPORTED) || defined(PNG_WRITE_PACKSWAP_SUPPORTED)
+PNG_EXTERN void png_do_packswap PNGARG((png_row_infop row_info, png_bytep row));
+#endif
+
+#if defined(PNG_READ_RGB_TO_GRAY_SUPPORTED)
+PNG_EXTERN int png_do_rgb_to_gray PNGARG((png_structp png_ptr, png_row_infop
+   row_info, png_bytep row));
+#endif
+
+#if defined(PNG_READ_GRAY_TO_RGB_SUPPORTED)
+PNG_EXTERN void png_do_gray_to_rgb PNGARG((png_row_infop row_info,
+   png_bytep row));
+#endif
+
+#if defined(PNG_READ_PACK_SUPPORTED)
+PNG_EXTERN void png_do_unpack PNGARG((png_row_infop row_info, png_bytep row));
+#endif
+
+#if defined(PNG_READ_SHIFT_SUPPORTED)
+PNG_EXTERN void png_do_unshift PNGARG((png_row_infop row_info, png_bytep row,
+   png_color_8p sig_bits));
+#endif
+
+#if defined(PNG_READ_INVERT_SUPPORTED) || defined(PNG_WRITE_INVERT_SUPPORTED)
+PNG_EXTERN void png_do_invert PNGARG((png_row_infop row_info, png_bytep row));
+#endif
+
+#if defined(PNG_READ_16_TO_8_SUPPORTED)
+PNG_EXTERN void png_do_chop PNGARG((png_row_infop row_info, png_bytep row));
+#endif
+
+#if defined(PNG_READ_DITHER_SUPPORTED)
+PNG_EXTERN void png_do_dither PNGARG((png_row_infop row_info,
+   png_bytep row, png_bytep palette_lookup, png_bytep dither_lookup));
+
+#  if defined(PNG_CORRECT_PALETTE_SUPPORTED)
+PNG_EXTERN void png_correct_palette PNGARG((png_structp png_ptr,
+   png_colorp palette, int num_palette));
+#  endif
+#endif
+
+#if defined(PNG_READ_BGR_SUPPORTED) || defined(PNG_WRITE_BGR_SUPPORTED)
+PNG_EXTERN void png_do_bgr PNGARG((png_row_infop row_info, png_bytep row));
+#endif
+
+#if defined(PNG_WRITE_PACK_SUPPORTED)
+PNG_EXTERN void png_do_pack PNGARG((png_row_infop row_info,
+   png_bytep row, png_uint_32 bit_depth));
+#endif
+
+#if defined(PNG_WRITE_SHIFT_SUPPORTED)
+PNG_EXTERN void png_do_shift PNGARG((png_row_infop row_info, png_bytep row,
+   png_color_8p bit_depth));
+#endif
+
+#if defined(PNG_READ_BACKGROUND_SUPPORTED)
+#if defined(PNG_READ_GAMMA_SUPPORTED)
+PNG_EXTERN void png_do_background PNGARG((png_row_infop row_info, png_bytep row,
+   png_color_16p trans_values, png_color_16p background,
+   png_color_16p background_1,
+   png_bytep gamma_table, png_bytep gamma_from_1, png_bytep gamma_to_1,
+   png_uint_16pp gamma_16, png_uint_16pp gamma_16_from_1,
+   png_uint_16pp gamma_16_to_1, int gamma_shift));
+#else
+PNG_EXTERN void png_do_background PNGARG((png_row_infop row_info, png_bytep row,
+   png_color_16p trans_values, png_color_16p background));
+#endif
+#endif
+
+#if defined(PNG_READ_GAMMA_SUPPORTED)
+PNG_EXTERN void png_do_gamma PNGARG((png_row_infop row_info, png_bytep row,
+   png_bytep gamma_table, png_uint_16pp gamma_16_table,
+   int gamma_shift));
+#endif
+
+#if defined(PNG_READ_EXPAND_SUPPORTED)
+PNG_EXTERN void png_do_expand_palette PNGARG((png_row_infop row_info,
+   png_bytep row, png_colorp palette, png_bytep trans, int num_trans));
+PNG_EXTERN void png_do_expand PNGARG((png_row_infop row_info,
+   png_bytep row, png_color_16p trans_value));
+#endif
+
+/* The following decodes the appropriate chunks, and does error correction,
+ * then calls the appropriate callback for the chunk if it is valid.
+ */
+
+/* decode the IHDR chunk */
+PNG_EXTERN void png_handle_IHDR PNGARG((png_structp png_ptr, png_infop info_ptr,
+   png_uint_32 length));
+PNG_EXTERN void png_handle_PLTE PNGARG((png_structp png_ptr, png_infop info_ptr,
+   png_uint_32 length));
+PNG_EXTERN void png_handle_IEND PNGARG((png_structp png_ptr, png_infop info_ptr,
+   png_uint_32 length));
+
+#if defined(PNG_READ_bKGD_SUPPORTED)
+PNG_EXTERN void png_handle_bKGD PNGARG((png_structp png_ptr, png_infop info_ptr,
+   png_uint_32 length));
+#endif
+
+#if defined(PNG_READ_cHRM_SUPPORTED)
+PNG_EXTERN void png_handle_cHRM PNGARG((png_structp png_ptr, png_infop info_ptr,
+   png_uint_32 length));
+#endif
+
+#if defined(PNG_READ_gAMA_SUPPORTED)
+PNG_EXTERN void png_handle_gAMA PNGARG((png_structp png_ptr, png_infop info_ptr,
+   png_uint_32 length));
+#endif
+
+#if defined(PNG_READ_hIST_SUPPORTED)
+PNG_EXTERN void png_handle_hIST PNGARG((png_structp png_ptr, png_infop info_ptr,
+   png_uint_32 length));
+#endif
+
+#if defined(PNG_READ_iCCP_SUPPORTED)
+extern void png_handle_iCCP PNGARG((png_structp png_ptr, png_infop info_ptr,
+   png_uint_32 length));
+#endif /* PNG_READ_iCCP_SUPPORTED */
+
+#if defined(PNG_READ_iTXt_SUPPORTED)
+PNG_EXTERN void png_handle_iTXt PNGARG((png_structp png_ptr, png_infop info_ptr,
+   png_uint_32 length));
+#endif
+
+#if defined(PNG_READ_oFFs_SUPPORTED)
+PNG_EXTERN void png_handle_oFFs PNGARG((png_structp png_ptr, png_infop info_ptr,
+   png_uint_32 length));
+#endif
+
+#if defined(PNG_READ_pCAL_SUPPORTED)
+PNG_EXTERN void png_handle_pCAL PNGARG((png_structp png_ptr, png_infop info_ptr,
+   png_uint_32 length));
+#endif
+
+#if defined(PNG_READ_pHYs_SUPPORTED)
+PNG_EXTERN void png_handle_pHYs PNGARG((png_structp png_ptr, png_infop info_ptr,
+   png_uint_32 length));
+#endif
+
+#if defined(PNG_READ_sBIT_SUPPORTED)
+PNG_EXTERN void png_handle_sBIT PNGARG((png_structp png_ptr, png_infop info_ptr,
+   png_uint_32 length));
+#endif
+
+#if defined(PNG_READ_sCAL_SUPPORTED)
+PNG_EXTERN void png_handle_sCAL PNGARG((png_structp png_ptr, png_infop info_ptr,
+   png_uint_32 length));
+#endif
+
+#if defined(PNG_READ_sPLT_SUPPORTED)
+extern void png_handle_sPLT PNGARG((png_structp png_ptr, png_infop info_ptr,
+   png_uint_32 length));
+#endif /* PNG_READ_sPLT_SUPPORTED */
+
+#if defined(PNG_READ_sRGB_SUPPORTED)
+PNG_EXTERN void png_handle_sRGB PNGARG((png_structp png_ptr, png_infop info_ptr,
+   png_uint_32 length));
+#endif
+
+#if defined(PNG_READ_tEXt_SUPPORTED)
+PNG_EXTERN void png_handle_tEXt PNGARG((png_structp png_ptr, png_infop info_ptr,
+   png_uint_32 length));
+#endif
+
+#if defined(PNG_READ_tIME_SUPPORTED)
+PNG_EXTERN void png_handle_tIME PNGARG((png_structp png_ptr, png_infop info_ptr,
+   png_uint_32 length));
+#endif
+
+#if defined(PNG_READ_tRNS_SUPPORTED)
+PNG_EXTERN void png_handle_tRNS PNGARG((png_structp png_ptr, png_infop info_ptr,
+   png_uint_32 length));
+#endif
+
+#if defined(PNG_READ_zTXt_SUPPORTED)
+PNG_EXTERN void png_handle_zTXt PNGARG((png_structp png_ptr, png_infop info_ptr,
+   png_uint_32 length));
+#endif
+
+PNG_EXTERN void png_handle_unknown PNGARG((png_structp png_ptr,
+   png_infop info_ptr, png_uint_32 length));
+
+PNG_EXTERN void png_check_chunk_name PNGARG((png_structp png_ptr,
+   png_bytep chunk_name));
+
+/* handle the transformations for reading and writing */
+PNG_EXTERN void png_do_read_transformations PNGARG((png_structp png_ptr));
+PNG_EXTERN void png_do_write_transformations PNGARG((png_structp png_ptr));
+
+PNG_EXTERN void png_init_read_transformations PNGARG((png_structp png_ptr));
+
+#ifdef PNG_PROGRESSIVE_READ_SUPPORTED
+PNG_EXTERN void png_push_read_chunk PNGARG((png_structp png_ptr,
+   png_infop info_ptr));
+PNG_EXTERN void png_push_read_sig PNGARG((png_structp png_ptr,
+   png_infop info_ptr));
+PNG_EXTERN void png_push_check_crc PNGARG((png_structp png_ptr));
+PNG_EXTERN void png_push_crc_skip PNGARG((png_structp png_ptr,
+   png_uint_32 length));
+PNG_EXTERN void png_push_crc_finish PNGARG((png_structp png_ptr));
+PNG_EXTERN void png_push_save_buffer PNGARG((png_structp png_ptr));
+PNG_EXTERN void png_push_restore_buffer PNGARG((png_structp png_ptr,
+   png_bytep buffer, png_size_t buffer_length));
+PNG_EXTERN void png_push_read_IDAT PNGARG((png_structp png_ptr));
+PNG_EXTERN void png_process_IDAT_data PNGARG((png_structp png_ptr,
+   png_bytep buffer, png_size_t buffer_length));
+PNG_EXTERN void png_push_process_row PNGARG((png_structp png_ptr));
+PNG_EXTERN void png_push_handle_unknown PNGARG((png_structp png_ptr,
+   png_infop info_ptr, png_uint_32 length));
+PNG_EXTERN void png_push_have_info PNGARG((png_structp png_ptr,
+   png_infop info_ptr));
+PNG_EXTERN void png_push_have_end PNGARG((png_structp png_ptr,
+   png_infop info_ptr));
+PNG_EXTERN void png_push_have_row PNGARG((png_structp png_ptr, png_bytep row));
+PNG_EXTERN void png_push_read_end PNGARG((png_structp png_ptr,
+   png_infop info_ptr));
+PNG_EXTERN void png_process_some_data PNGARG((png_structp png_ptr,
+   png_infop info_ptr));
+PNG_EXTERN void png_read_push_finish_row PNGARG((png_structp png_ptr));
+#if defined(PNG_READ_tEXt_SUPPORTED)
+PNG_EXTERN void png_push_handle_tEXt PNGARG((png_structp png_ptr,
+   png_infop info_ptr, png_uint_32 length));
+PNG_EXTERN void png_push_read_tEXt PNGARG((png_structp png_ptr,
+   png_infop info_ptr));
+#endif
+#if defined(PNG_READ_zTXt_SUPPORTED)
+PNG_EXTERN void png_push_handle_zTXt PNGARG((png_structp png_ptr,
+   png_infop info_ptr, png_uint_32 length));
+PNG_EXTERN void png_push_read_zTXt PNGARG((png_structp png_ptr,
+   png_infop info_ptr));
+#endif
+#if defined(PNG_READ_iTXt_SUPPORTED)
+PNG_EXTERN void png_push_handle_iTXt PNGARG((png_structp png_ptr,
+   png_infop info_ptr, png_uint_32 length));
+PNG_EXTERN void png_push_read_iTXt PNGARG((png_structp png_ptr,
+   png_infop info_ptr));
+#endif
+
+#endif /* PNG_PROGRESSIVE_READ_SUPPORTED */
+
+#ifdef PNG_MNG_FEATURES_SUPPORTED
+PNG_EXTERN void png_do_read_intrapixel PNGARG((png_row_infop row_info,
+   png_bytep row));
+PNG_EXTERN void png_do_write_intrapixel PNGARG((png_row_infop row_info,
+   png_bytep row));
+#endif
+
+#if defined(PNG_ASSEMBLER_CODE_SUPPORTED)
+/* png.c */ /* PRIVATE */
+PNG_EXTERN void png_init_mmx_flags PNGARG((png_structp png_ptr));
+#endif
+/* Maintainer: Put new private prototypes here ^ and in libpngpf.3 */
+
+#endif /* PNG_INTERNAL */
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* PNG_VERSION_INFO_ONLY */
+/* do not put anything past this line */
+#endif /* PNG_H */
diff --git a/collects/plot/src/all/pngasmrd.h b/collects/plot/src/all/pngasmrd.h
new file mode 100644
index 0000000000..d086d8c4dd
--- /dev/null
+++ b/collects/plot/src/all/pngasmrd.h
@@ -0,0 +1,11 @@
+/* pngasmrd.h - assembler version of utilities to read a PNG file
+ *
+ * libpng 1.2.5 - October 3, 2002
+ * For conditions of distribution and use, see copyright notice in png.h
+ * Copyright (c) 2002 Glenn Randers-Pehrson
+ *
+ */
+
+/* This file is obsolete in libpng-1.0.9 and later; its contents now appear
+ * at the end of pngconf.h.
+ */
diff --git a/collects/plot/src/all/pngconf.h b/collects/plot/src/all/pngconf.h
new file mode 100644
index 0000000000..95835ec2c4
--- /dev/null
+++ b/collects/plot/src/all/pngconf.h
@@ -0,0 +1,1348 @@
+/* pngconf.h - machine configurable file for libpng
+ *
+ * libpng 1.2.5 - October 3, 2002
+ * For conditions of distribution and use, see copyright notice in png.h
+ * Copyright (c) 1998-2002 Glenn Randers-Pehrson
+ * (Version 0.96 Copyright (c) 1996, 1997 Andreas Dilger)
+ * (Version 0.88 Copyright (c) 1995, 1996 Guy Eric Schalnat, Group 42, Inc.)
+ */
+
+/* Any machine specific code is near the front of this file, so if you
+ * are configuring libpng for a machine, you may want to read the section
+ * starting here down to where it starts to typedef png_color, png_text,
+ * and png_info.
+ */
+
+#ifndef PNGCONF_H
+#define PNGCONF_H
+
+/* This is the size of the compression buffer, and thus the size of
+ * an IDAT chunk.  Make this whatever size you feel is best for your
+ * machine.  One of these will be allocated per png_struct.  When this
+ * is full, it writes the data to the disk, and does some other
+ * calculations.  Making this an extremely small size will slow
+ * the library down, but you may want to experiment to determine
+ * where it becomes significant, if you are concerned with memory
+ * usage.  Note that zlib allocates at least 32Kb also.  For readers,
+ * this describes the size of the buffer available to read the data in.
+ * Unless this gets smaller than the size of a row (compressed),
+ * it should not make much difference how big this is.
+ */
+
+#ifndef PNG_ZBUF_SIZE
+#  define PNG_ZBUF_SIZE 8192
+#endif
+
+/* Enable if you want a write-only libpng */
+
+#ifndef PNG_NO_READ_SUPPORTED
+#  define PNG_READ_SUPPORTED
+#endif
+
+/* Enable if you want a read-only libpng */
+
+#ifndef PNG_NO_WRITE_SUPPORTED
+#  define PNG_WRITE_SUPPORTED
+#endif
+
+/* Enabled by default in 1.2.0.  You can disable this if you don't need to
+   support PNGs that are embedded in MNG datastreams */
+#if !defined(PNG_1_0_X) && !defined(PNG_NO_MNG_FEATURES)
+#  ifndef PNG_MNG_FEATURES_SUPPORTED
+#    define PNG_MNG_FEATURES_SUPPORTED
+#  endif
+#endif
+
+#ifndef PNG_NO_FLOATING_POINT_SUPPORTED
+#  ifndef PNG_FLOATING_POINT_SUPPORTED
+#    define PNG_FLOATING_POINT_SUPPORTED
+#  endif
+#endif
+
+/* If you are running on a machine where you cannot allocate more
+ * than 64K of memory at once, uncomment this.  While libpng will not
+ * normally need that much memory in a chunk (unless you load up a very
+ * large file), zlib needs to know how big of a chunk it can use, and
+ * libpng thus makes sure to check any memory allocation to verify it
+ * will fit into memory.
+#define PNG_MAX_MALLOC_64K
+ */
+#if defined(MAXSEG_64K) && !defined(PNG_MAX_MALLOC_64K)
+#  define PNG_MAX_MALLOC_64K
+#endif
+
+/* Special munging to support doing things the 'cygwin' way:
+ * 'Normal' png-on-win32 defines/defaults:
+ *   PNG_BUILD_DLL -- building dll
+ *   PNG_USE_DLL   -- building an application, linking to dll
+ *   (no define)   -- building static library, or building an
+ *                    application and linking to the static lib
+ * 'Cygwin' defines/defaults:
+ *   PNG_BUILD_DLL -- (ignored) building the dll
+ *   (no define)   -- (ignored) building an application, linking to the dll
+ *   PNG_STATIC    -- (ignored) building the static lib, or building an 
+ *                    application that links to the static lib.
+ *   ALL_STATIC    -- (ignored) building various static libs, or building an 
+ *                    application that links to the static libs.
+ * Thus,
+ * a cygwin user should define either PNG_BUILD_DLL or PNG_STATIC, and
+ * this bit of #ifdefs will define the 'correct' config variables based on
+ * that. If a cygwin user *wants* to define 'PNG_USE_DLL' that's okay, but
+ * unnecessary.
+ *
+ * Also, the precedence order is:
+ *   ALL_STATIC (since we can't #undef something outside our namespace)
+ *   PNG_BUILD_DLL
+ *   PNG_STATIC
+ *   (nothing) == PNG_USE_DLL
+ * 
+ * CYGWIN (2002-01-20): The preceding is now obsolete. With the advent
+ *   of auto-import in binutils, we no longer need to worry about 
+ *   __declspec(dllexport) / __declspec(dllimport) and friends.  Therefore,
+ *   we don't need to worry about PNG_STATIC or ALL_STATIC when it comes
+ *   to __declspec() stuff.  However, we DO need to worry about 
+ *   PNG_BUILD_DLL and PNG_STATIC because those change some defaults
+ *   such as CONSOLE_IO and whether GLOBAL_ARRAYS are allowed.
+ */
+#if defined(__CYGWIN__)
+#  if defined(ALL_STATIC)
+#    if defined(PNG_BUILD_DLL)
+#      undef PNG_BUILD_DLL
+#    endif
+#    if defined(PNG_USE_DLL)
+#      undef PNG_USE_DLL
+#    endif
+#    if defined(PNG_DLL)
+#      undef PNG_DLL
+#    endif
+#    if !defined(PNG_STATIC)
+#      define PNG_STATIC
+#    endif
+#  else
+#    if defined (PNG_BUILD_DLL)
+#      if defined(PNG_STATIC)
+#        undef PNG_STATIC
+#      endif
+#      if defined(PNG_USE_DLL)
+#        undef PNG_USE_DLL
+#      endif
+#      if !defined(PNG_DLL)
+#        define PNG_DLL
+#      endif
+#    else
+#      if defined(PNG_STATIC)
+#        if defined(PNG_USE_DLL)
+#          undef PNG_USE_DLL
+#        endif
+#        if defined(PNG_DLL)
+#          undef PNG_DLL
+#        endif
+#      else
+#        if !defined(PNG_USE_DLL)
+#          define PNG_USE_DLL
+#        endif
+#        if !defined(PNG_DLL)
+#          define PNG_DLL
+#        endif
+#      endif  
+#    endif  
+#  endif
+#endif
+
+/* This protects us against compilers that run on a windowing system
+ * and thus don't have or would rather us not use the stdio types:
+ * stdin, stdout, and stderr.  The only one currently used is stderr
+ * in png_error() and png_warning().  #defining PNG_NO_CONSOLE_IO will
+ * prevent these from being compiled and used. #defining PNG_NO_STDIO
+ * will also prevent these, plus will prevent the entire set of stdio
+ * macros and functions (FILE *, printf, etc.) from being compiled and used,
+ * unless (PNG_DEBUG > 0) has been #defined.
+ *
+ * #define PNG_NO_CONSOLE_IO
+ * #define PNG_NO_STDIO
+ */
+
+#if defined(_WIN32_WCE)
+#  include <windows.h>
+   /* Console I/O functions are not supported on WindowsCE */
+#  define PNG_NO_CONSOLE_IO
+#  ifdef PNG_DEBUG
+#    undef PNG_DEBUG
+#  endif
+#endif
+
+#ifdef PNG_BUILD_DLL
+#  ifndef PNG_CONSOLE_IO_SUPPORTED
+#    ifndef PNG_NO_CONSOLE_IO
+#      define PNG_NO_CONSOLE_IO
+#    endif
+#  endif
+#endif
+
+#  ifdef PNG_NO_STDIO
+#    ifndef PNG_NO_CONSOLE_IO
+#      define PNG_NO_CONSOLE_IO
+#    endif
+#    ifdef PNG_DEBUG
+#      if (PNG_DEBUG > 0)
+#        include <stdio.h>
+#      endif
+#    endif
+#  else
+#    if !defined(_WIN32_WCE)
+/* "stdio.h" functions are not supported on WindowsCE */
+#      include <stdio.h>
+#    endif
+#  endif
+
+/* This macro protects us against machines that don't have function
+ * prototypes (ie K&R style headers).  If your compiler does not handle
+ * function prototypes, define this macro and use the included ansi2knr.
+ * I've always been able to use _NO_PROTO as the indicator, but you may
+ * need to drag the empty declaration out in front of here, or change the
+ * ifdef to suit your own needs.
+ */
+#ifndef PNGARG
+
+#ifdef OF /* zlib prototype munger */
+#  define PNGARG(arglist) OF(arglist)
+#else
+
+#ifdef _NO_PROTO
+#  define PNGARG(arglist) ()
+#  ifndef PNG_TYPECAST_NULL
+#     define PNG_TYPECAST_NULL
+#  endif
+#else
+#  define PNGARG(arglist) arglist
+#endif /* _NO_PROTO */
+
+#endif /* OF */
+
+#endif /* PNGARG */
+
+/* Try to determine if we are compiling on a Mac.  Note that testing for
+ * just __MWERKS__ is not good enough, because the Codewarrior is now used
+ * on non-Mac platforms.
+ */
+#ifndef MACOS
+#  if (defined(__MWERKS__) && defined(macintosh)) || defined(applec) || \
+  defined(THINK_C) || defined(__SC__) || defined(TARGET_OS_MAC) || defined(FOR_MAC)
+#    define MACOS
+#  endif
+#endif
+
+/* enough people need this for various reasons to include it here */
+#if !defined(MACOS) && !defined(RISCOS) && !defined(_WIN32_WCE)
+#  include <sys/types.h>
+#endif
+
+#if !defined(PNG_SETJMP_NOT_SUPPORTED) && !defined(PNG_NO_SETJMP_SUPPORTED)
+#  define PNG_SETJMP_SUPPORTED
+#endif
+
+#ifdef PNG_SETJMP_SUPPORTED
+/* This is an attempt to force a single setjmp behaviour on Linux.  If
+ * the X config stuff didn't define _BSD_SOURCE we wouldn't need this.
+ */
+
+#  ifdef __linux__
+#    ifdef _BSD_SOURCE
+#      define PNG_SAVE_BSD_SOURCE
+#      undef _BSD_SOURCE
+#    endif
+#    ifdef _SETJMP_H
+      __png.h__ already includes setjmp.h;
+      __dont__ include it again.;
+#    endif
+#  endif /* __linux__ */
+
+   /* include setjmp.h for error handling */
+#  include <setjmp.h>
+
+#  ifdef __linux__
+#    ifdef PNG_SAVE_BSD_SOURCE
+#      define _BSD_SOURCE
+#      undef PNG_SAVE_BSD_SOURCE
+#    endif
+#  endif /* __linux__ */
+#endif /* PNG_SETJMP_SUPPORTED */
+
+#ifdef BSD
+#  include <strings.h>
+#else
+#  include <string.h>
+#endif
+
+/* Other defines for things like memory and the like can go here.  */
+#ifdef PNG_INTERNAL
+
+#include <stdlib.h>
+
+/* The functions exported by PNG_EXTERN are PNG_INTERNAL functions, which
+ * aren't usually used outside the library (as far as I know), so it is
+ * debatable if they should be exported at all.  In the future, when it is
+ * possible to have run-time registry of chunk-handling functions, some of
+ * these will be made available again.
+#define PNG_EXTERN extern
+ */
+#define PNG_EXTERN
+
+/* Other defines specific to compilers can go here.  Try to keep
+ * them inside an appropriate ifdef/endif pair for portability.
+ */
+
+#if defined(PNG_FLOATING_POINT_SUPPORTED)
+#  if defined(MACOS)
+     /* We need to check that <math.h> hasn't already been included earlier
+      * as it seems it doesn't agree with <fp.h>, yet we should really use
+      * <fp.h> if possible.
+      */
+#    if !defined(__MATH_H__) && !defined(__MATH_H) && !defined(__cmath__)
+#      include <fp.h>
+#    endif
+#  else
+#    include <math.h>
+#  endif
+#  if defined(_AMIGA) && defined(__SASC) && defined(_M68881)
+     /* Amiga SAS/C: We must include builtin FPU functions when compiling using
+      * MATH=68881
+      */
+#    include <m68881.h>
+#  endif
+#endif
+
+/* Codewarrior on NT has linking problems without this. */
+#if (defined(__MWERKS__) && defined(WIN32)) || defined(__STDC__)
+#  define PNG_ALWAYS_EXTERN
+#endif
+
+/* For some reason, Borland C++ defines memcmp, etc. in mem.h, not
+ * stdlib.h like it should (I think).  Or perhaps this is a C++
+ * "feature"?
+ */
+#ifdef __TURBOC__
+#  include <mem.h>
+#  include "alloc.h"
+#endif
+
+#if defined(_MSC_VER) && (defined(WIN32) || defined(_Windows) || \
+    defined(_WINDOWS) || defined(_WIN32) || defined(__WIN32__))
+#  include <malloc.h>
+#endif
+
+/* This controls how fine the dithering gets.  As this allocates
+ * a largish chunk of memory (32K), those who are not as concerned
+ * with dithering quality can decrease some or all of these.
+ */
+#ifndef PNG_DITHER_RED_BITS
+#  define PNG_DITHER_RED_BITS 5
+#endif
+#ifndef PNG_DITHER_GREEN_BITS
+#  define PNG_DITHER_GREEN_BITS 5
+#endif
+#ifndef PNG_DITHER_BLUE_BITS
+#  define PNG_DITHER_BLUE_BITS 5
+#endif
+
+/* This controls how fine the gamma correction becomes when you
+ * are only interested in 8 bits anyway.  Increasing this value
+ * results in more memory being used, and more pow() functions
+ * being called to fill in the gamma tables.  Don't set this value
+ * less then 8, and even that may not work (I haven't tested it).
+ */
+
+#ifndef PNG_MAX_GAMMA_8
+#  define PNG_MAX_GAMMA_8 11
+#endif
+
+/* This controls how much a difference in gamma we can tolerate before
+ * we actually start doing gamma conversion.
+ */
+#ifndef PNG_GAMMA_THRESHOLD
+#  define PNG_GAMMA_THRESHOLD 0.05
+#endif
+
+#endif /* PNG_INTERNAL */
+
+/* The following uses const char * instead of char * for error
+ * and warning message functions, so some compilers won't complain.
+ * If you do not want to use const, define PNG_NO_CONST here.
+ */
+
+#ifndef PNG_NO_CONST
+#  define PNG_CONST const
+#else
+#  define PNG_CONST
+#endif
+
+/* The following defines give you the ability to remove code from the
+ * library that you will not be using.  I wish I could figure out how to
+ * automate this, but I can't do that without making it seriously hard
+ * on the users.  So if you are not using an ability, change the #define
+ * to and #undef, and that part of the library will not be compiled.  If
+ * your linker can't find a function, you may want to make sure the
+ * ability is defined here.  Some of these depend upon some others being
+ * defined.  I haven't figured out all the interactions here, so you may
+ * have to experiment awhile to get everything to compile.  If you are
+ * creating or using a shared library, you probably shouldn't touch this,
+ * as it will affect the size of the structures, and this will cause bad
+ * things to happen if the library and/or application ever change.
+ */
+
+/* Any features you will not be using can be undef'ed here */
+
+/* GR-P, 0.96a: Set "*TRANSFORMS_SUPPORTED as default but allow user
+ * to turn it off with "*TRANSFORMS_NOT_SUPPORTED" or *PNG_NO_*_TRANSFORMS
+ * on the compile line, then pick and choose which ones to define without
+ * having to edit this file. It is safe to use the *TRANSFORMS_NOT_SUPPORTED
+ * if you only want to have a png-compliant reader/writer but don't need
+ * any of the extra transformations.  This saves about 80 kbytes in a
+ * typical installation of the library. (PNG_NO_* form added in version
+ * 1.0.1c, for consistency)
+ */
+
+/* The size of the png_text structure changed in libpng-1.0.6 when
+ * iTXt is supported.  It is turned off by default, to support old apps
+ * that malloc the png_text structure instead of calling png_set_text()
+ * and letting libpng malloc it.  It will be turned on by default in
+ * libpng-1.3.0.
+ */
+
+#ifndef PNG_iTXt_SUPPORTED
+#  if !defined(PNG_READ_iTXt_SUPPORTED) && !defined(PNG_NO_READ_iTXt)
+#    define PNG_NO_READ_iTXt
+#  endif
+#  if !defined(PNG_WRITE_iTXt_SUPPORTED) && !defined(PNG_NO_WRITE_iTXt)
+#    define PNG_NO_WRITE_iTXt
+#  endif
+#endif
+
+/* The following support, added after version 1.0.0, can be turned off here en
+ * masse by defining PNG_LEGACY_SUPPORTED in case you need binary compatibility
+ * with old applications that require the length of png_struct and png_info
+ * to remain unchanged.
+ */
+
+#ifdef PNG_LEGACY_SUPPORTED
+#  define PNG_NO_FREE_ME
+#  define PNG_NO_READ_UNKNOWN_CHUNKS
+#  define PNG_NO_WRITE_UNKNOWN_CHUNKS
+#  define PNG_NO_READ_USER_CHUNKS
+#  define PNG_NO_READ_iCCP
+#  define PNG_NO_WRITE_iCCP
+#  define PNG_NO_READ_iTXt
+#  define PNG_NO_WRITE_iTXt
+#  define PNG_NO_READ_sCAL
+#  define PNG_NO_WRITE_sCAL
+#  define PNG_NO_READ_sPLT
+#  define PNG_NO_WRITE_sPLT
+#  define PNG_NO_INFO_IMAGE
+#  define PNG_NO_READ_RGB_TO_GRAY
+#  define PNG_NO_READ_USER_TRANSFORM
+#  define PNG_NO_WRITE_USER_TRANSFORM
+#  define PNG_NO_USER_MEM
+#  define PNG_NO_READ_EMPTY_PLTE
+#  define PNG_NO_MNG_FEATURES
+#  define PNG_NO_FIXED_POINT_SUPPORTED
+#endif
+
+/* Ignore attempt to turn off both floating and fixed point support */
+#if !defined(PNG_FLOATING_POINT_SUPPORTED) || \
+    !defined(PNG_NO_FIXED_POINT_SUPPORTED)
+#  define PNG_FIXED_POINT_SUPPORTED
+#endif
+
+#ifndef PNG_NO_FREE_ME
+#  define PNG_FREE_ME_SUPPORTED
+#endif
+
+#if defined(PNG_READ_SUPPORTED)
+
+#if !defined(PNG_READ_TRANSFORMS_NOT_SUPPORTED) && \
+      !defined(PNG_NO_READ_TRANSFORMS)
+#  define PNG_READ_TRANSFORMS_SUPPORTED
+#endif
+
+#ifdef PNG_READ_TRANSFORMS_SUPPORTED
+#  ifndef PNG_NO_READ_EXPAND
+#    define PNG_READ_EXPAND_SUPPORTED
+#  endif
+#  ifndef PNG_NO_READ_SHIFT
+#    define PNG_READ_SHIFT_SUPPORTED
+#  endif
+#  ifndef PNG_NO_READ_PACK
+#    define PNG_READ_PACK_SUPPORTED
+#  endif
+#  ifndef PNG_NO_READ_BGR
+#    define PNG_READ_BGR_SUPPORTED
+#  endif
+#  ifndef PNG_NO_READ_SWAP
+#    define PNG_READ_SWAP_SUPPORTED
+#  endif
+#  ifndef PNG_NO_READ_PACKSWAP
+#    define PNG_READ_PACKSWAP_SUPPORTED
+#  endif
+#  ifndef PNG_NO_READ_INVERT
+#    define PNG_READ_INVERT_SUPPORTED
+#  endif
+#  ifndef PNG_NO_READ_DITHER
+#    define PNG_READ_DITHER_SUPPORTED
+#  endif
+#  ifndef PNG_NO_READ_BACKGROUND
+#    define PNG_READ_BACKGROUND_SUPPORTED
+#  endif
+#  ifndef PNG_NO_READ_16_TO_8
+#    define PNG_READ_16_TO_8_SUPPORTED
+#  endif
+#  ifndef PNG_NO_READ_FILLER
+#    define PNG_READ_FILLER_SUPPORTED
+#  endif
+#  ifndef PNG_NO_READ_GAMMA
+#    define PNG_READ_GAMMA_SUPPORTED
+#  endif
+#  ifndef PNG_NO_READ_GRAY_TO_RGB
+#    define PNG_READ_GRAY_TO_RGB_SUPPORTED
+#  endif
+#  ifndef PNG_NO_READ_SWAP_ALPHA
+#    define PNG_READ_SWAP_ALPHA_SUPPORTED
+#  endif
+#  ifndef PNG_NO_READ_INVERT_ALPHA
+#    define PNG_READ_INVERT_ALPHA_SUPPORTED
+#  endif
+#  ifndef PNG_NO_READ_STRIP_ALPHA
+#    define PNG_READ_STRIP_ALPHA_SUPPORTED
+#  endif
+#  ifndef PNG_NO_READ_USER_TRANSFORM
+#    define PNG_READ_USER_TRANSFORM_SUPPORTED
+#  endif
+#  ifndef PNG_NO_READ_RGB_TO_GRAY
+#    define PNG_READ_RGB_TO_GRAY_SUPPORTED
+#  endif
+#endif /* PNG_READ_TRANSFORMS_SUPPORTED */
+
+#if !defined(PNG_NO_PROGRESSIVE_READ) && \
+ !defined(PNG_PROGRESSIVE_READ_NOT_SUPPORTED)  /* if you don't do progressive */
+#  define PNG_PROGRESSIVE_READ_SUPPORTED     /* reading.  This is not talking */
+#endif                               /* about interlacing capability!  You'll */
+              /* still have interlacing unless you change the following line: */
+
+#define PNG_READ_INTERLACING_SUPPORTED /* required for PNG-compliant decoders */
+
+#ifndef PNG_NO_READ_COMPOSITE_NODIV
+#  ifndef PNG_NO_READ_COMPOSITED_NODIV  /* libpng-1.0.x misspelling */
+#    define PNG_READ_COMPOSITE_NODIV_SUPPORTED   /* well tested on Intel, SGI */
+#  endif
+#endif
+
+/* Deprecated, will be removed from version 2.0.0.
+   Use PNG_MNG_FEATURES_SUPPORTED instead. */
+#ifndef PNG_NO_READ_EMPTY_PLTE
+#  define PNG_READ_EMPTY_PLTE_SUPPORTED
+#endif
+
+#endif /* PNG_READ_SUPPORTED */
+
+#if defined(PNG_WRITE_SUPPORTED)
+
+# if !defined(PNG_WRITE_TRANSFORMS_NOT_SUPPORTED) && \
+    !defined(PNG_NO_WRITE_TRANSFORMS)
+#  define PNG_WRITE_TRANSFORMS_SUPPORTED
+#endif
+
+#ifdef PNG_WRITE_TRANSFORMS_SUPPORTED
+#  ifndef PNG_NO_WRITE_SHIFT
+#    define PNG_WRITE_SHIFT_SUPPORTED
+#  endif
+#  ifndef PNG_NO_WRITE_PACK
+#    define PNG_WRITE_PACK_SUPPORTED
+#  endif
+#  ifndef PNG_NO_WRITE_BGR
+#    define PNG_WRITE_BGR_SUPPORTED
+#  endif
+#  ifndef PNG_NO_WRITE_SWAP
+#    define PNG_WRITE_SWAP_SUPPORTED
+#  endif
+#  ifndef PNG_NO_WRITE_PACKSWAP
+#    define PNG_WRITE_PACKSWAP_SUPPORTED
+#  endif
+#  ifndef PNG_NO_WRITE_INVERT
+#    define PNG_WRITE_INVERT_SUPPORTED
+#  endif
+#  ifndef PNG_NO_WRITE_FILLER
+#    define PNG_WRITE_FILLER_SUPPORTED   /* same as WRITE_STRIP_ALPHA */
+#  endif
+#  ifndef PNG_NO_WRITE_SWAP_ALPHA
+#    define PNG_WRITE_SWAP_ALPHA_SUPPORTED
+#  endif
+#  ifndef PNG_NO_WRITE_INVERT_ALPHA
+#    define PNG_WRITE_INVERT_ALPHA_SUPPORTED
+#  endif
+#  ifndef PNG_NO_WRITE_USER_TRANSFORM
+#    define PNG_WRITE_USER_TRANSFORM_SUPPORTED
+#  endif
+#endif /* PNG_WRITE_TRANSFORMS_SUPPORTED */
+
+#if defined(PNG_READ_USER_TRANSFORM_SUPPORTED) || \
+    defined(PNG_WRITE_USER_TRANSFORM_SUPPORTED)
+#  ifndef PNG_NO_USER_TRANSFORM_PTR
+#    define PNG_USER_TRANSFORM_PTR_SUPPORTED
+#  endif
+#endif
+
+#define PNG_WRITE_INTERLACING_SUPPORTED  /* not required for PNG-compliant
+                                            encoders, but can cause trouble
+                                            if left undefined */
+
+#if !defined(PNG_NO_WRITE_WEIGHTED_FILTER) && \
+     defined(PNG_FLOATING_POINT_SUPPORTED)
+#  define PNG_WRITE_WEIGHTED_FILTER_SUPPORTED
+#endif
+
+#ifndef PNG_1_0_X
+#ifndef PNG_NO_ERROR_NUMBERS
+#define PNG_ERROR_NUMBERS_SUPPORTED
+#endif
+#endif /* PNG_1_0_X */
+
+#ifndef PNG_NO_WRITE_FLUSH
+#  define PNG_WRITE_FLUSH_SUPPORTED
+#endif
+
+/* Deprecated, see PNG_MNG_FEATURES_SUPPORTED, above */
+#ifndef PNG_NO_WRITE_EMPTY_PLTE
+#  define PNG_WRITE_EMPTY_PLTE_SUPPORTED
+#endif
+
+#endif /* PNG_WRITE_SUPPORTED */
+
+#ifndef PNG_NO_STDIO
+#  define PNG_TIME_RFC1123_SUPPORTED
+#endif
+
+/* This adds extra functions in pngget.c for accessing data from the
+ * info pointer (added in version 0.99)
+ * png_get_image_width()
+ * png_get_image_height()
+ * png_get_bit_depth()
+ * png_get_color_type()
+ * png_get_compression_type()
+ * png_get_filter_type()
+ * png_get_interlace_type()
+ * png_get_pixel_aspect_ratio()
+ * png_get_pixels_per_meter()
+ * png_get_x_offset_pixels()
+ * png_get_y_offset_pixels()
+ * png_get_x_offset_microns()
+ * png_get_y_offset_microns()
+ */
+#if !defined(PNG_NO_EASY_ACCESS) && !defined(PNG_EASY_ACCESS_SUPPORTED)
+#  define PNG_EASY_ACCESS_SUPPORTED
+#endif
+
+/* PNG_ASSEMBLER_CODE was enabled by default in version 1.2.0 
+   even when PNG_USE_PNGVCRD or PNG_USE_PNGGCCRD is not defined */
+#if defined(PNG_READ_SUPPORTED) && !defined(PNG_NO_ASSEMBLER_CODE)
+#  ifndef PNG_ASSEMBLER_CODE_SUPPORTED
+#    define PNG_ASSEMBLER_CODE_SUPPORTED
+#  endif
+#  if !defined(PNG_MMX_CODE_SUPPORTED) && !defined(PNG_NO_MMX_CODE)
+#    define PNG_MMX_CODE_SUPPORTED
+#  endif
+#endif
+
+/* If you are sure that you don't need thread safety and you are compiling
+   with PNG_USE_PNGCCRD for an MMX application, you can define this for
+   faster execution.  See pnggccrd.c.
+#define PNG_THREAD_UNSAFE_OK
+*/
+
+#if !defined(PNG_1_0_X)
+#if !defined(PNG_NO_USER_MEM) && !defined(PNG_USER_MEM_SUPPORTED)
+#  define PNG_USER_MEM_SUPPORTED
+#endif
+#endif /* PNG_1_0_X */
+
+/* These are currently experimental features, define them if you want */
+
+/* very little testing */
+/*
+#ifdef PNG_READ_SUPPORTED
+#  ifndef PNG_READ_16_TO_8_ACCURATE_SCALE_SUPPORTED
+#    define PNG_READ_16_TO_8_ACCURATE_SCALE_SUPPORTED
+#  endif
+#endif
+*/
+
+/* This is only for PowerPC big-endian and 680x0 systems */
+/* some testing */
+/*
+#ifdef PNG_READ_SUPPORTED
+#  ifndef PNG_PNG_READ_BIG_ENDIAN_SUPPORTED
+#    define PNG_READ_BIG_ENDIAN_SUPPORTED
+#  endif
+#endif
+*/
+
+/* Buggy compilers (e.g., gcc 2.7.2.2) need this */
+/*
+#define PNG_NO_POINTER_INDEXING
+*/
+
+/* These functions are turned off by default, as they will be phased out. */
+/*
+#define  PNG_USELESS_TESTS_SUPPORTED
+#define  PNG_CORRECT_PALETTE_SUPPORTED
+*/
+
+/* Any chunks you are not interested in, you can undef here.  The
+ * ones that allocate memory may be expecially important (hIST,
+ * tEXt, zTXt, tRNS, pCAL).  Others will just save time and make png_info
+ * a bit smaller.
+ */
+
+#if defined(PNG_READ_SUPPORTED) && \
+    !defined(PNG_READ_ANCILLARY_CHUNKS_NOT_SUPPORTED) && \
+    !defined(PNG_NO_READ_ANCILLARY_CHUNKS)
+#  define PNG_READ_ANCILLARY_CHUNKS_SUPPORTED
+#endif
+
+#if defined(PNG_WRITE_SUPPORTED) && \
+    !defined(PNG_WRITE_ANCILLARY_CHUNKS_NOT_SUPPORTED) && \
+    !defined(PNG_NO_WRITE_ANCILLARY_CHUNKS)
+#  define PNG_WRITE_ANCILLARY_CHUNKS_SUPPORTED
+#endif
+
+#ifdef PNG_READ_ANCILLARY_CHUNKS_SUPPORTED
+
+#ifdef PNG_NO_READ_TEXT
+#  define PNG_NO_READ_iTXt
+#  define PNG_NO_READ_tEXt
+#  define PNG_NO_READ_zTXt
+#endif
+#ifndef PNG_NO_READ_bKGD
+#  define PNG_READ_bKGD_SUPPORTED
+#  define PNG_bKGD_SUPPORTED
+#endif
+#ifndef PNG_NO_READ_cHRM
+#  define PNG_READ_cHRM_SUPPORTED
+#  define PNG_cHRM_SUPPORTED
+#endif
+#ifndef PNG_NO_READ_gAMA
+#  define PNG_READ_gAMA_SUPPORTED
+#  define PNG_gAMA_SUPPORTED
+#endif
+#ifndef PNG_NO_READ_hIST
+#  define PNG_READ_hIST_SUPPORTED
+#  define PNG_hIST_SUPPORTED
+#endif
+#ifndef PNG_NO_READ_iCCP
+#  define PNG_READ_iCCP_SUPPORTED
+#  define PNG_iCCP_SUPPORTED
+#endif
+#ifndef PNG_NO_READ_iTXt
+#  ifndef PNG_READ_iTXt_SUPPORTED
+#    define PNG_READ_iTXt_SUPPORTED
+#  endif
+#  ifndef PNG_iTXt_SUPPORTED
+#    define PNG_iTXt_SUPPORTED
+#  endif
+#endif
+#ifndef PNG_NO_READ_oFFs
+#  define PNG_READ_oFFs_SUPPORTED
+#  define PNG_oFFs_SUPPORTED
+#endif
+#ifndef PNG_NO_READ_pCAL
+#  define PNG_READ_pCAL_SUPPORTED
+#  define PNG_pCAL_SUPPORTED
+#endif
+#ifndef PNG_NO_READ_sCAL
+#  define PNG_READ_sCAL_SUPPORTED
+#  define PNG_sCAL_SUPPORTED
+#endif
+#ifndef PNG_NO_READ_pHYs
+#  define PNG_READ_pHYs_SUPPORTED
+#  define PNG_pHYs_SUPPORTED
+#endif
+#ifndef PNG_NO_READ_sBIT
+#  define PNG_READ_sBIT_SUPPORTED
+#  define PNG_sBIT_SUPPORTED
+#endif
+#ifndef PNG_NO_READ_sPLT
+#  define PNG_READ_sPLT_SUPPORTED
+#  define PNG_sPLT_SUPPORTED
+#endif
+#ifndef PNG_NO_READ_sRGB
+#  define PNG_READ_sRGB_SUPPORTED
+#  define PNG_sRGB_SUPPORTED
+#endif
+#ifndef PNG_NO_READ_tEXt
+#  define PNG_READ_tEXt_SUPPORTED
+#  define PNG_tEXt_SUPPORTED
+#endif
+#ifndef PNG_NO_READ_tIME
+#  define PNG_READ_tIME_SUPPORTED
+#  define PNG_tIME_SUPPORTED
+#endif
+#ifndef PNG_NO_READ_tRNS
+#  define PNG_READ_tRNS_SUPPORTED
+#  define PNG_tRNS_SUPPORTED
+#endif
+#ifndef PNG_NO_READ_zTXt
+#  define PNG_READ_zTXt_SUPPORTED
+#  define PNG_zTXt_SUPPORTED
+#endif
+#ifndef PNG_NO_READ_UNKNOWN_CHUNKS
+#  define PNG_READ_UNKNOWN_CHUNKS_SUPPORTED
+#  ifndef PNG_UNKNOWN_CHUNKS_SUPPORTED
+#    define PNG_UNKNOWN_CHUNKS_SUPPORTED
+#  endif
+#  ifndef PNG_NO_HANDLE_AS_UNKNOWN
+#    define PNG_HANDLE_AS_UNKNOWN_SUPPORTED
+#  endif
+#endif
+#if !defined(PNG_NO_READ_USER_CHUNKS) && \
+     defined(PNG_READ_UNKNOWN_CHUNKS_SUPPORTED)
+#  define PNG_READ_USER_CHUNKS_SUPPORTED
+#  define PNG_USER_CHUNKS_SUPPORTED
+#  ifdef PNG_NO_READ_UNKNOWN_CHUNKS
+#    undef PNG_NO_READ_UNKNOWN_CHUNKS
+#  endif
+#  ifdef PNG_NO_HANDLE_AS_UNKNOWN
+#    undef PNG_NO_HANDLE_AS_UNKNOWN
+#  endif
+#endif
+#ifndef PNG_NO_READ_OPT_PLTE
+#  define PNG_READ_OPT_PLTE_SUPPORTED /* only affects support of the */
+#endif                      /* optional PLTE chunk in RGB and RGBA images */
+#if defined(PNG_READ_iTXt_SUPPORTED) || defined(PNG_READ_tEXt_SUPPORTED) || \
+    defined(PNG_READ_zTXt_SUPPORTED)
+#  define PNG_READ_TEXT_SUPPORTED
+#  define PNG_TEXT_SUPPORTED
+#endif
+
+#endif /* PNG_READ_ANCILLARY_CHUNKS_SUPPORTED */
+
+#ifdef PNG_WRITE_ANCILLARY_CHUNKS_SUPPORTED
+
+#ifdef PNG_NO_WRITE_TEXT
+#  define PNG_NO_WRITE_iTXt
+#  define PNG_NO_WRITE_tEXt
+#  define PNG_NO_WRITE_zTXt
+#endif
+#ifndef PNG_NO_WRITE_bKGD
+#  define PNG_WRITE_bKGD_SUPPORTED
+#  ifndef PNG_bKGD_SUPPORTED
+#    define PNG_bKGD_SUPPORTED
+#  endif
+#endif
+#ifndef PNG_NO_WRITE_cHRM
+#  define PNG_WRITE_cHRM_SUPPORTED
+#  ifndef PNG_cHRM_SUPPORTED
+#    define PNG_cHRM_SUPPORTED
+#  endif
+#endif
+#ifndef PNG_NO_WRITE_gAMA
+#  define PNG_WRITE_gAMA_SUPPORTED
+#  ifndef PNG_gAMA_SUPPORTED
+#    define PNG_gAMA_SUPPORTED
+#  endif
+#endif
+#ifndef PNG_NO_WRITE_hIST
+#  define PNG_WRITE_hIST_SUPPORTED
+#  ifndef PNG_hIST_SUPPORTED
+#    define PNG_hIST_SUPPORTED
+#  endif
+#endif
+#ifndef PNG_NO_WRITE_iCCP
+#  define PNG_WRITE_iCCP_SUPPORTED
+#  ifndef PNG_iCCP_SUPPORTED
+#    define PNG_iCCP_SUPPORTED
+#  endif
+#endif
+#ifndef PNG_NO_WRITE_iTXt
+#  ifndef PNG_WRITE_iTXt_SUPPORTED
+#    define PNG_WRITE_iTXt_SUPPORTED
+#  endif
+#  ifndef PNG_iTXt_SUPPORTED
+#    define PNG_iTXt_SUPPORTED
+#  endif
+#endif
+#ifndef PNG_NO_WRITE_oFFs
+#  define PNG_WRITE_oFFs_SUPPORTED
+#  ifndef PNG_oFFs_SUPPORTED
+#    define PNG_oFFs_SUPPORTED
+#  endif
+#endif
+#ifndef PNG_NO_WRITE_pCAL
+#  define PNG_WRITE_pCAL_SUPPORTED
+#  ifndef PNG_pCAL_SUPPORTED
+#    define PNG_pCAL_SUPPORTED
+#  endif
+#endif
+#ifndef PNG_NO_WRITE_sCAL
+#  define PNG_WRITE_sCAL_SUPPORTED
+#  ifndef PNG_sCAL_SUPPORTED
+#    define PNG_sCAL_SUPPORTED
+#  endif
+#endif
+#ifndef PNG_NO_WRITE_pHYs
+#  define PNG_WRITE_pHYs_SUPPORTED
+#  ifndef PNG_pHYs_SUPPORTED
+#    define PNG_pHYs_SUPPORTED
+#  endif
+#endif
+#ifndef PNG_NO_WRITE_sBIT
+#  define PNG_WRITE_sBIT_SUPPORTED
+#  ifndef PNG_sBIT_SUPPORTED
+#    define PNG_sBIT_SUPPORTED
+#  endif
+#endif
+#ifndef PNG_NO_WRITE_sPLT
+#  define PNG_WRITE_sPLT_SUPPORTED
+#  ifndef PNG_sPLT_SUPPORTED
+#    define PNG_sPLT_SUPPORTED
+#  endif
+#endif
+#ifndef PNG_NO_WRITE_sRGB
+#  define PNG_WRITE_sRGB_SUPPORTED
+#  ifndef PNG_sRGB_SUPPORTED
+#    define PNG_sRGB_SUPPORTED
+#  endif
+#endif
+#ifndef PNG_NO_WRITE_tEXt
+#  define PNG_WRITE_tEXt_SUPPORTED
+#  ifndef PNG_tEXt_SUPPORTED
+#    define PNG_tEXt_SUPPORTED
+#  endif
+#endif
+#ifndef PNG_NO_WRITE_tIME
+#  define PNG_WRITE_tIME_SUPPORTED
+#  ifndef PNG_tIME_SUPPORTED
+#    define PNG_tIME_SUPPORTED
+#  endif
+#endif
+#ifndef PNG_NO_WRITE_tRNS
+#  define PNG_WRITE_tRNS_SUPPORTED
+#  ifndef PNG_tRNS_SUPPORTED
+#    define PNG_tRNS_SUPPORTED
+#  endif
+#endif
+#ifndef PNG_NO_WRITE_zTXt
+#  define PNG_WRITE_zTXt_SUPPORTED
+#  ifndef PNG_zTXt_SUPPORTED
+#    define PNG_zTXt_SUPPORTED
+#  endif
+#endif
+#ifndef PNG_NO_WRITE_UNKNOWN_CHUNKS
+#  define PNG_WRITE_UNKNOWN_CHUNKS_SUPPORTED
+#  ifndef PNG_UNKNOWN_CHUNKS_SUPPORTED
+#    define PNG_UNKNOWN_CHUNKS_SUPPORTED
+#  endif
+#  ifndef PNG_NO_HANDLE_AS_UNKNOWN
+#     ifndef PNG_HANDLE_AS_UNKNOWN_SUPPORTED
+#       define PNG_HANDLE_AS_UNKNOWN_SUPPORTED
+#     endif
+#  endif
+#endif
+#if defined(PNG_WRITE_iTXt_SUPPORTED) || defined(PNG_WRITE_tEXt_SUPPORTED) || \
+    defined(PNG_WRITE_zTXt_SUPPORTED)
+#  define PNG_WRITE_TEXT_SUPPORTED
+#  ifndef PNG_TEXT_SUPPORTED
+#    define PNG_TEXT_SUPPORTED
+#  endif
+#endif
+
+#endif /* PNG_WRITE_ANCILLARY_CHUNKS_SUPPORTED */
+
+/* Turn this off to disable png_read_png() and
+ * png_write_png() and leave the row_pointers member
+ * out of the info structure.
+ */
+#ifndef PNG_NO_INFO_IMAGE
+#  define PNG_INFO_IMAGE_SUPPORTED
+#endif
+
+/* need the time information for reading tIME chunks */
+#if defined(PNG_tIME_SUPPORTED)
+#  if !defined(_WIN32_WCE)
+     /* "time.h" functions are not supported on WindowsCE */
+#    include <time.h>
+#  endif
+#endif
+
+/* Some typedefs to get us started.  These should be safe on most of the
+ * common platforms.  The typedefs should be at least as large as the
+ * numbers suggest (a png_uint_32 must be at least 32 bits long), but they
+ * don't have to be exactly that size.  Some compilers dislike passing
+ * unsigned shorts as function parameters, so you may be better off using
+ * unsigned int for png_uint_16.  Likewise, for 64-bit systems, you may
+ * want to have unsigned int for png_uint_32 instead of unsigned long.
+ */
+
+typedef unsigned long png_uint_32;
+typedef long png_int_32;
+typedef unsigned short png_uint_16;
+typedef short png_int_16;
+typedef unsigned char png_byte;
+
+/* This is usually size_t.  It is typedef'ed just in case you need it to
+   change (I'm not sure if you will or not, so I thought I'd be safe) */
+typedef size_t png_size_t;
+
+/* The following is needed for medium model support.  It cannot be in the
+ * PNG_INTERNAL section.  Needs modification for other compilers besides
+ * MSC.  Model independent support declares all arrays and pointers to be
+ * large using the far keyword.  The zlib version used must also support
+ * model independent data.  As of version zlib 1.0.4, the necessary changes
+ * have been made in zlib.  The USE_FAR_KEYWORD define triggers other
+ * changes that are needed. (Tim Wegner)
+ */
+
+/* Separate compiler dependencies (problem here is that zlib.h always
+   defines FAR. (SJT) */
+#ifdef __BORLANDC__
+#  if defined(__LARGE__) || defined(__HUGE__) || defined(__COMPACT__)
+#    define LDATA 1
+#  else
+#    define LDATA 0
+#  endif
+   /* GRR:  why is Cygwin in here?  Cygwin is not Borland C... */
+#  if !defined(__WIN32__) && !defined(__FLAT__) && !defined(__CYGWIN__)
+#    define PNG_MAX_MALLOC_64K
+#    if (LDATA != 1)
+#      ifndef FAR
+#        define FAR __far
+#      endif
+#      define USE_FAR_KEYWORD
+#    endif   /* LDATA != 1 */
+     /* Possibly useful for moving data out of default segment.
+      * Uncomment it if you want. Could also define FARDATA as
+      * const if your compiler supports it. (SJT)
+#    define FARDATA FAR
+      */
+#  endif  /* __WIN32__, __FLAT__, __CYGWIN__ */
+#endif   /* __BORLANDC__ */
+
+
+/* Suggest testing for specific compiler first before testing for
+ * FAR.  The Watcom compiler defines both __MEDIUM__ and M_I86MM,
+ * making reliance oncertain keywords suspect. (SJT)
+ */
+
+/* MSC Medium model */
+#if defined(FAR)
+#  if defined(M_I86MM)
+#    define USE_FAR_KEYWORD
+#    define FARDATA FAR
+#    include <dos.h>
+#  endif
+#endif
+
+/* SJT: default case */
+#ifndef FAR
+#  define FAR
+#endif
+
+/* At this point FAR is always defined */
+#ifndef FARDATA
+#  define FARDATA
+#endif
+
+/* Typedef for floating-point numbers that are converted
+   to fixed-point with a multiple of 100,000, e.g., int_gamma */
+typedef png_int_32 png_fixed_point;
+
+/* Add typedefs for pointers */
+typedef void            FAR * png_voidp;
+typedef png_byte        FAR * png_bytep;
+typedef png_uint_32     FAR * png_uint_32p;
+typedef png_int_32      FAR * png_int_32p;
+typedef png_uint_16     FAR * png_uint_16p;
+typedef png_int_16      FAR * png_int_16p;
+typedef PNG_CONST char  FAR * png_const_charp;
+typedef char            FAR * png_charp;
+typedef png_fixed_point FAR * png_fixed_point_p;
+
+#ifndef PNG_NO_STDIO
+#if defined(_WIN32_WCE)
+typedef HANDLE                png_FILE_p;
+#else
+typedef FILE                * png_FILE_p;
+#endif
+#endif
+
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+typedef double          FAR * png_doublep;
+#endif
+
+/* Pointers to pointers; i.e. arrays */
+typedef png_byte        FAR * FAR * png_bytepp;
+typedef png_uint_32     FAR * FAR * png_uint_32pp;
+typedef png_int_32      FAR * FAR * png_int_32pp;
+typedef png_uint_16     FAR * FAR * png_uint_16pp;
+typedef png_int_16      FAR * FAR * png_int_16pp;
+typedef PNG_CONST char  FAR * FAR * png_const_charpp;
+typedef char            FAR * FAR * png_charpp;
+typedef png_fixed_point FAR * FAR * png_fixed_point_pp;
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+typedef double          FAR * FAR * png_doublepp;
+#endif
+
+/* Pointers to pointers to pointers; i.e., pointer to array */
+typedef char            FAR * FAR * FAR * png_charppp;
+
+/* libpng typedefs for types in zlib. If zlib changes
+ * or another compression library is used, then change these.
+ * Eliminates need to change all the source files.
+ */
+typedef charf *         png_zcharp;
+typedef charf * FAR *   png_zcharpp;
+typedef z_stream FAR *  png_zstreamp;
+
+/*
+ * Define PNG_BUILD_DLL if the module being built is a Windows
+ * LIBPNG DLL.
+ *
+ * Define PNG_USE_DLL if you want to *link* to the Windows LIBPNG DLL.
+ * It is equivalent to Microsoft predefined macro _DLL that is
+ * automatically defined when you compile using the share
+ * version of the CRT (C Run-Time library)
+ *
+ * The cygwin mods make this behavior a little different:
+ * Define PNG_BUILD_DLL if you are building a dll for use with cygwin
+ * Define PNG_STATIC if you are building a static library for use with cygwin,
+ *   -or- if you are building an application that you want to link to the
+ *   static library.
+ * PNG_USE_DLL is defined by default (no user action needed) unless one of
+ *   the other flags is defined.
+ */
+
+#if !defined(PNG_DLL) && (defined(PNG_BUILD_DLL) || defined(PNG_USE_DLL))
+#  define PNG_DLL
+#endif
+/* If CYGWIN, then disallow GLOBAL ARRAYS unless building a static lib.
+ * When building a static lib, default to no GLOBAL ARRAYS, but allow
+ * command-line override
+ */
+#if defined(__CYGWIN__)
+#  if !defined(PNG_STATIC)
+#    if defined(PNG_USE_GLOBAL_ARRAYS)
+#      undef PNG_USE_GLOBAL_ARRAYS
+#    endif
+#    if !defined(PNG_USE_LOCAL_ARRAYS)
+#      define PNG_USE_LOCAL_ARRAYS
+#    endif
+#  else
+#    if defined(PNG_USE_LOCAL_ARRAYS) || defined(PNG_NO_GLOBAL_ARRAYS)
+#      if defined(PNG_USE_GLOBAL_ARRAYS)
+#        undef PNG_USE_GLOBAL_ARRAYS
+#      endif
+#    endif
+#  endif
+#  if !defined(PNG_USE_LOCAL_ARRAYS) && !defined(PNG_USE_GLOBAL_ARRAYS)
+#    define PNG_USE_LOCAL_ARRAYS
+#  endif
+#endif
+
+/* Do not use global arrays (helps with building DLL's)
+ * They are no longer used in libpng itself, since version 1.0.5c,
+ * but might be required for some pre-1.0.5c applications.
+ */
+#if !defined(PNG_USE_LOCAL_ARRAYS) && !defined(PNG_USE_GLOBAL_ARRAYS)
+#  if defined(PNG_NO_GLOBAL_ARRAYS) || (defined(__GNUC__) && defined(PNG_DLL))
+#    define PNG_USE_LOCAL_ARRAYS
+#  else
+#    define PNG_USE_GLOBAL_ARRAYS
+#  endif
+#endif
+
+#if defined(__CYGWIN__)
+#  undef PNGAPI
+#  define PNGAPI __cdecl
+#  undef PNG_IMPEXP
+#  define PNG_IMPEXP
+#endif  
+
+/* If you define PNGAPI, e.g., with compiler option "-DPNGAPI=__stdcall",
+ * you may get warnings regarding the linkage of png_zalloc and png_zfree.
+ * Don't ignore those warnings; you must also reset the default calling
+ * convention in your compiler to match your PNGAPI, and you must build
+ * zlib and your applications the same way you build libpng.
+ */
+
+#ifndef PNGAPI
+
+#if defined(__MINGW32__) && !defined(PNG_MODULEDEF)
+#  ifndef PNG_NO_MODULEDEF
+#    define PNG_NO_MODULEDEF
+#  endif
+#endif
+
+#if !defined(PNG_IMPEXP) && defined(PNG_BUILD_DLL) && !defined(PNG_NO_MODULEDEF)
+#  define PNG_IMPEXP
+#endif
+
+#if defined(PNG_DLL) || defined(_DLL) || defined(__DLL__ ) || \
+    (( defined(_Windows) || defined(_WINDOWS) || \
+       defined(WIN32) || defined(_WIN32) || defined(__WIN32__) ))
+
+#  if defined(__GNUC__) || (defined (_MSC_VER) && (_MSC_VER >= 800))
+#    define PNGAPI __cdecl
+#  else
+#    define PNGAPI _cdecl
+#  endif
+
+#  if !defined(PNG_IMPEXP) && (!defined(PNG_DLL) || \
+       0 /* WINCOMPILER_WITH_NO_SUPPORT_FOR_DECLIMPEXP */)
+#     define PNG_IMPEXP
+#  endif
+
+#  if !defined(PNG_IMPEXP)
+
+#     define PNG_EXPORT_TYPE1(type,symbol)  PNG_IMPEXP type PNGAPI symbol
+#     define PNG_EXPORT_TYPE2(type,symbol)  type PNG_IMPEXP PNGAPI symbol
+
+      /* Borland/Microsoft */
+#     if defined(_MSC_VER) || defined(__BORLANDC__)
+#        if (_MSC_VER >= 800) || (__BORLANDC__ >= 0x500)
+#           define PNG_EXPORT PNG_EXPORT_TYPE1
+#        else
+#           define PNG_EXPORT PNG_EXPORT_TYPE2
+#           if defined(PNG_BUILD_DLL)
+#              define PNG_IMPEXP __export
+#           else
+#              define PNG_IMPEXP /*__import */ /* doesn't exist AFAIK in
+                                                 VC++ */
+#           endif                             /* Exists in Borland C++ for
+                                                 C++ classes (== huge) */
+#        endif
+#     endif
+
+#     if !defined(PNG_IMPEXP)
+#        if defined(PNG_BUILD_DLL)
+#           define PNG_IMPEXP __declspec(dllexport)
+#        else
+#           define PNG_IMPEXP __declspec(dllimport)
+#        endif
+#     endif
+#  endif  /* PNG_IMPEXP */
+#else /* !(DLL || non-cygwin WINDOWS) */
+#    if (defined(__IBMC__) || defined(IBMCPP__)) && defined(__OS2__)
+#      define PNGAPI _System
+#      define PNG_IMPEXP
+#    else
+#      if 0 /* ... other platforms, with other meanings */
+#      else
+#        define PNGAPI
+#        define PNG_IMPEXP
+#      endif
+#    endif
+#endif
+#endif
+
+#ifndef PNGAPI
+#  define PNGAPI
+#endif
+#ifndef PNG_IMPEXP
+#  define PNG_IMPEXP
+#endif
+
+#ifndef PNG_EXPORT
+#  define PNG_EXPORT(type,symbol) PNG_IMPEXP type PNGAPI symbol
+#endif
+
+#ifdef PNG_USE_GLOBAL_ARRAYS
+#  ifndef PNG_EXPORT_VAR
+#    define PNG_EXPORT_VAR(type) extern PNG_IMPEXP type
+#  endif
+#endif
+
+/* User may want to use these so they are not in PNG_INTERNAL. Any library
+ * functions that are passed far data must be model independent.
+ */
+
+#ifndef PNG_ABORT
+#  define PNG_ABORT() abort()
+#endif
+
+#ifdef PNG_SETJMP_SUPPORTED
+#  define png_jmpbuf(png_ptr) ((png_ptr)->jmpbuf)
+#else
+#  define png_jmpbuf(png_ptr) \
+   (LIBPNG_WAS_COMPILED_WITH__PNG_SETJMP_NOT_SUPPORTED)
+#endif
+
+#if defined(USE_FAR_KEYWORD)  /* memory model independent fns */
+/* use this to make far-to-near assignments */
+#  define CHECK   1
+#  define NOCHECK 0
+#  define CVT_PTR(ptr) (png_far_to_near(png_ptr,ptr,CHECK))
+#  define CVT_PTR_NOCHECK(ptr) (png_far_to_near(png_ptr,ptr,NOCHECK))
+#  define png_strcpy _fstrcpy
+#  define png_strlen _fstrlen
+#  define png_memcmp _fmemcmp      /* SJT: added */
+#  define png_memcpy _fmemcpy
+#  define png_memset _fmemset
+#else /* use the usual functions */
+#  define CVT_PTR(ptr)         (ptr)
+#  define CVT_PTR_NOCHECK(ptr) (ptr)
+#  define png_strcpy strcpy
+#  define png_strlen strlen
+#  define png_memcmp memcmp     /* SJT: added */
+#  define png_memcpy memcpy
+#  define png_memset memset
+#endif
+/* End of memory model independent support */
+
+/* Just a little check that someone hasn't tried to define something
+ * contradictory.
+ */
+#if (PNG_ZBUF_SIZE > 65536) && defined(PNG_MAX_MALLOC_64K)
+#  undef PNG_ZBUF_SIZE
+#  define PNG_ZBUF_SIZE 65536
+#endif
+
+#ifdef PNG_READ_SUPPORTED
+/* Prior to libpng-1.0.9, this block was in pngasmrd.h */
+#if defined(PNG_INTERNAL)
+
+/* These are the default thresholds before the MMX code kicks in; if either
+ * rowbytes or bitdepth is below the threshold, plain C code is used.  These
+ * can be overridden at runtime via the png_set_mmx_thresholds() call in
+ * libpng 1.2.0 and later.  The values below were chosen by Intel.
+ */
+
+#ifndef PNG_MMX_ROWBYTES_THRESHOLD_DEFAULT
+#  define PNG_MMX_ROWBYTES_THRESHOLD_DEFAULT  128  /*  >=  */
+#endif
+#ifndef PNG_MMX_BITDEPTH_THRESHOLD_DEFAULT
+#  define PNG_MMX_BITDEPTH_THRESHOLD_DEFAULT  9    /*  >=  */   
+#endif
+
+/* Set this in the makefile for VC++ on Pentium, not here. */
+/* Platform must be Pentium.  Makefile must assemble and load pngvcrd.c .
+ * MMX will be detected at run time and used if present.
+ */
+#ifdef PNG_USE_PNGVCRD
+#  define PNG_HAVE_ASSEMBLER_COMBINE_ROW
+#  define PNG_HAVE_ASSEMBLER_READ_INTERLACE
+#  define PNG_HAVE_ASSEMBLER_READ_FILTER_ROW
+#endif
+
+/* Set this in the makefile for gcc/as on Pentium, not here. */
+/* Platform must be Pentium.  Makefile must assemble and load pnggccrd.c .
+ * MMX will be detected at run time and used if present.
+ */
+#ifdef PNG_USE_PNGGCCRD
+#  define PNG_HAVE_ASSEMBLER_COMBINE_ROW
+#  define PNG_HAVE_ASSEMBLER_READ_INTERLACE
+#  define PNG_HAVE_ASSEMBLER_READ_FILTER_ROW
+#endif
+/* - see pnggccrd.c for info about what is currently enabled */
+
+#endif /* PNG_INTERNAL */
+#endif /* PNG_READ_SUPPORTED */
+
+#endif /* PNGCONF_H */
+
diff --git a/collects/plot/src/all/pngerror.c b/collects/plot/src/all/pngerror.c
new file mode 100644
index 0000000000..fc3c304779
--- /dev/null
+++ b/collects/plot/src/all/pngerror.c
@@ -0,0 +1,291 @@
+
+/* pngerror.c - stub functions for i/o and memory allocation
+ *
+ * libpng 1.2.5 - October 3, 2002
+ * For conditions of distribution and use, see copyright notice in png.h
+ * Copyright (c) 1998-2002 Glenn Randers-Pehrson
+ * (Version 0.96 Copyright (c) 1996, 1997 Andreas Dilger)
+ * (Version 0.88 Copyright (c) 1995, 1996 Guy Eric Schalnat, Group 42, Inc.)
+ *
+ * This file provides a location for all error handling.  Users who
+ * need special error handling are expected to write replacement functions
+ * and use png_set_error_fn() to use those functions.  See the instructions
+ * at each function.
+ */
+
+#define PNG_INTERNAL
+#include "png.h"
+
+static void /* PRIVATE */
+png_default_error PNGARG((png_structp png_ptr,
+  png_const_charp error_message));
+static void /* PRIVATE */
+png_default_warning PNGARG((png_structp png_ptr,
+  png_const_charp warning_message));
+
+/* This function is called whenever there is a fatal error.  This function
+ * should not be changed.  If there is a need to handle errors differently,
+ * you should supply a replacement error function and use png_set_error_fn()
+ * to replace the error function at run-time.
+ */
+void PNGAPI
+png_error(png_structp png_ptr, png_const_charp error_message)
+{
+#ifdef PNG_ERROR_NUMBERS_SUPPORTED
+   char msg[16];
+   if (png_ptr->flags&(PNG_FLAG_STRIP_ERROR_NUMBERS|PNG_FLAG_STRIP_ERROR_TEXT))
+   {
+     int offset = 0;
+     if (*error_message == '#')
+     {
+         for (offset=1; offset<15; offset++)
+            if (*(error_message+offset) == ' ')
+                break;
+         if (png_ptr->flags&PNG_FLAG_STRIP_ERROR_TEXT)
+         {
+            int i;
+            for (i=0; i<offset-1; i++)
+               msg[i]=error_message[i+1];
+            msg[i]='\0';
+            error_message=msg;
+         }
+         else
+            error_message+=offset;
+     }
+     else
+     {
+         if (png_ptr->flags&PNG_FLAG_STRIP_ERROR_TEXT)
+         {
+            msg[0]='0';        
+            msg[1]='\0';
+            error_message=msg;
+         }
+     }
+   }
+#endif
+   if (png_ptr->error_fn != NULL)
+      (*(png_ptr->error_fn))(png_ptr, error_message);
+
+   /* if the following returns or doesn't exist, use the default function,
+      which will not return */
+   png_default_error(png_ptr, error_message);
+}
+
+/* This function is called whenever there is a non-fatal error.  This function
+ * should not be changed.  If there is a need to handle warnings differently,
+ * you should supply a replacement warning function and use
+ * png_set_error_fn() to replace the warning function at run-time.
+ */
+void PNGAPI
+png_warning(png_structp png_ptr, png_const_charp warning_message)
+{
+     int offset = 0;
+#ifdef PNG_ERROR_NUMBERS_SUPPORTED
+   if (png_ptr->flags&(PNG_FLAG_STRIP_ERROR_NUMBERS|PNG_FLAG_STRIP_ERROR_TEXT))
+#endif
+   {
+     if (*warning_message == '#')
+     {
+         for (offset=1; offset<15; offset++)
+            if (*(warning_message+offset) == ' ')
+                break;
+     }
+   }
+   if (png_ptr->warning_fn != NULL)
+      (*(png_ptr->warning_fn))(png_ptr,
+         (png_const_charp)(warning_message+offset));
+   else
+      png_default_warning(png_ptr, (png_const_charp)(warning_message+offset));
+}
+
+/* These utilities are used internally to build an error message that relates
+ * to the current chunk.  The chunk name comes from png_ptr->chunk_name,
+ * this is used to prefix the message.  The message is limited in length
+ * to 63 bytes, the name characters are output as hex digits wrapped in []
+ * if the character is invalid.
+ */
+#define isnonalpha(c) ((c) < 41 || (c) > 122 || ((c) > 90 && (c) < 97))
+static PNG_CONST char png_digit[16] = {
+   '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E',
+   'F' };
+
+static void /* PRIVATE */
+png_format_buffer(png_structp png_ptr, png_charp buffer, png_const_charp
+   error_message)
+{
+   int iout = 0, iin = 0;
+
+   while (iin < 4)
+   {
+      int c = png_ptr->chunk_name[iin++];
+      if (isnonalpha(c))
+      {
+         buffer[iout++] = '[';
+         buffer[iout++] = png_digit[(c & 0xf0) >> 4];
+         buffer[iout++] = png_digit[c & 0x0f];
+         buffer[iout++] = ']';
+      }
+      else
+      {
+         buffer[iout++] = (png_byte)c;
+      }
+   }
+
+   if (error_message == NULL)
+      buffer[iout] = 0;
+   else
+   {
+      buffer[iout++] = ':';
+      buffer[iout++] = ' ';
+      png_memcpy(buffer+iout, error_message, 64);
+      buffer[iout+63] = 0;
+   }
+}
+
+void PNGAPI
+png_chunk_error(png_structp png_ptr, png_const_charp error_message)
+{
+   char msg[18+64];
+   png_format_buffer(png_ptr, msg, error_message);
+   png_error(png_ptr, msg);
+}
+
+void PNGAPI
+png_chunk_warning(png_structp png_ptr, png_const_charp warning_message)
+{
+   char msg[18+64];
+   png_format_buffer(png_ptr, msg, warning_message);
+   png_warning(png_ptr, msg);
+}
+
+/* This is the default error handling function.  Note that replacements for
+ * this function MUST NOT RETURN, or the program will likely crash.  This
+ * function is used by default, or if the program supplies NULL for the
+ * error function pointer in png_set_error_fn().
+ */
+static void /* PRIVATE */
+png_default_error(png_structp png_ptr, png_const_charp error_message)
+{
+#ifndef PNG_NO_CONSOLE_IO
+#ifdef PNG_ERROR_NUMBERS_SUPPORTED
+   if (*error_message == '#')
+   {
+     int offset;
+     char error_number[16];
+     for (offset=0; offset<15; offset++)
+     {
+         error_number[offset] = *(error_message+offset+1);
+         if (*(error_message+offset) == ' ')
+             break;
+     }
+     if((offset > 1) && (offset < 15))
+     {
+       error_number[offset-1]='\0';
+       fprintf(stderr, "libpng error no. %s: %s\n", error_number,
+          error_message+offset);
+     }
+     else
+       fprintf(stderr, "libpng error: %s, offset=%d\n", error_message,offset);
+   }
+   else
+#endif
+   fprintf(stderr, "libpng error: %s\n", error_message);
+#else
+   if (error_message)
+     /* make compiler happy */ ;
+#endif
+
+#ifdef PNG_SETJMP_SUPPORTED
+#  ifdef USE_FAR_KEYWORD
+   {
+      jmp_buf jmpbuf;
+      png_memcpy(jmpbuf,png_ptr->jmpbuf,sizeof(jmp_buf));
+      longjmp(jmpbuf, 1);
+   }
+#  else
+   longjmp(png_ptr->jmpbuf, 1);
+# endif
+#else
+   if (png_ptr)
+     /* make compiler happy */ ;
+   PNG_ABORT();
+#endif
+}
+
+/* This function is called when there is a warning, but the library thinks
+ * it can continue anyway.  Replacement functions don't have to do anything
+ * here if you don't want them to.  In the default configuration, png_ptr is
+ * not used, but it is passed in case it may be useful.
+ */
+static void /* PRIVATE */
+png_default_warning(png_structp png_ptr, png_const_charp warning_message)
+{
+#ifndef PNG_NO_CONSOLE_IO
+#  ifdef PNG_ERROR_NUMBERS_SUPPORTED
+   if (*warning_message == '#')
+   {
+     int offset;
+     char warning_number[16];
+     for (offset=0; offset<15; offset++)
+     {
+        warning_number[offset]=*(warning_message+offset+1);
+        if (*(warning_message+offset) == ' ')
+            break;
+     }
+     if((offset > 1) && (offset < 15))
+     {
+       warning_number[offset-1]='\0';
+       fprintf(stderr, "libpng warning no. %s: %s\n", warning_number,
+          warning_message+offset);
+     }
+     else
+       fprintf(stderr, "libpng warning: %s\n", warning_message);
+   }
+   else
+#  endif
+     fprintf(stderr, "libpng warning: %s\n", warning_message);
+#else
+   if (warning_message)
+     /* appease compiler */ ;
+#endif
+   if (png_ptr)
+      return;
+}
+
+/* This function is called when the application wants to use another method
+ * of handling errors and warnings.  Note that the error function MUST NOT
+ * return to the calling routine or serious problems will occur.  The return
+ * method used in the default routine calls longjmp(png_ptr->jmpbuf, 1)
+ */
+void PNGAPI
+png_set_error_fn(png_structp png_ptr, png_voidp error_ptr,
+   png_error_ptr error_fn, png_error_ptr warning_fn)
+{
+   png_ptr->error_ptr = error_ptr;
+   png_ptr->error_fn = error_fn;
+   png_ptr->warning_fn = warning_fn;
+}
+
+
+/* This function returns a pointer to the error_ptr associated with the user
+ * functions.  The application should free any memory associated with this
+ * pointer before png_write_destroy and png_read_destroy are called.
+ */
+png_voidp PNGAPI
+png_get_error_ptr(png_structp png_ptr)
+{
+   return ((png_voidp)png_ptr->error_ptr);
+}
+
+
+#ifdef PNG_ERROR_NUMBERS_SUPPORTED
+void PNGAPI
+png_set_strip_error_numbers(png_structp png_ptr, png_uint_32 strip_mode)
+{
+   if(png_ptr != NULL)
+   {
+     png_ptr->flags &=
+       ((~(PNG_FLAG_STRIP_ERROR_NUMBERS|PNG_FLAG_STRIP_ERROR_TEXT))&strip_mode);
+   }
+}
+#endif
diff --git a/collects/plot/src/all/pnggccrd.c b/collects/plot/src/all/pnggccrd.c
new file mode 100644
index 0000000000..8d81c31471
--- /dev/null
+++ b/collects/plot/src/all/pnggccrd.c
@@ -0,0 +1,5397 @@
+/* pnggccrd.c - mixed C/assembler version of utilities to read a PNG file
+ *
+ * For Intel x86 CPU (Pentium-MMX or later) and GNU C compiler.
+ *
+ *     See http://www.intel.com/drg/pentiumII/appnotes/916/916.htm
+ *     and http://www.intel.com/drg/pentiumII/appnotes/923/923.htm
+ *     for Intel's performance analysis of the MMX vs. non-MMX code.
+ *
+ * libpng version 1.2.5 - October 3, 2002
+ * For conditions of distribution and use, see copyright notice in png.h
+ * Copyright (c) 1998-2002 Glenn Randers-Pehrson
+ * Copyright (c) 1998, Intel Corporation
+ *
+ * Based on MSVC code contributed by Nirav Chhatrapati, Intel Corp., 1998.
+ * Interface to libpng contributed by Gilles Vollant, 1999.
+ * GNU C port by Greg Roelofs, 1999-2001.
+ *
+ * Lines 2350-4300 converted in place with intel2gas 1.3.1:
+ *
+ *   intel2gas -mdI pnggccrd.c.partially-msvc -o pnggccrd.c
+ *
+ * and then cleaned up by hand.  See http://hermes.terminal.at/intel2gas/ .
+ *
+ * NOTE:  A sufficiently recent version of GNU as (or as.exe under DOS/Windows)
+ *        is required to assemble the newer MMX instructions such as movq.
+ *        For djgpp, see
+ *
+ *           ftp://ftp.simtel.net/pub/simtelnet/gnu/djgpp/v2gnu/bnu281b.zip
+ *
+ *        (or a later version in the same directory).  For Linux, check your
+ *        distribution's web site(s) or try these links:
+ *
+ *           http://rufus.w3.org/linux/RPM/binutils.html
+ *           http://www.debian.org/Packages/stable/devel/binutils.html
+ *           ftp://ftp.slackware.com/pub/linux/slackware/slackware/slakware/d1/
+ *             binutils.tgz
+ *
+ *        For other platforms, see the main GNU site:
+ *
+ *           ftp://ftp.gnu.org/pub/gnu/binutils/
+ *
+ *        Version 2.5.2l.15 is definitely too old...
+ */
+
+/*
+ * TEMPORARY PORTING NOTES AND CHANGELOG (mostly by Greg Roelofs)
+ * =====================================
+ *
+ * 19991006:
+ *  - fixed sign error in post-MMX cleanup code (16- & 32-bit cases)
+ *
+ * 19991007:
+ *  - additional optimizations (possible or definite):
+ *     x [DONE] write MMX code for 64-bit case (pixel_bytes == 8) [not tested]
+ *     - write MMX code for 48-bit case (pixel_bytes == 6)
+ *     - figure out what's up with 24-bit case (pixel_bytes == 3):
+ *        why subtract 8 from width_mmx in the pass 4/5 case?
+ *        (only width_mmx case) (near line 1606)
+ *     x [DONE] replace pixel_bytes within each block with the true
+ *        constant value (or are compilers smart enough to do that?)
+ *     - rewrite all MMX interlacing code so it's aligned with
+ *        the *beginning* of the row buffer, not the end.  This
+ *        would not only allow one to eliminate half of the memory
+ *        writes for odd passes (that is, pass == odd), it may also
+ *        eliminate some unaligned-data-access exceptions (assuming
+ *        there's a penalty for not aligning 64-bit accesses on
+ *        64-bit boundaries).  The only catch is that the "leftover"
+ *        pixel(s) at the end of the row would have to be saved,
+ *        but there are enough unused MMX registers in every case,
+ *        so this is not a problem.  A further benefit is that the
+ *        post-MMX cleanup code (C code) in at least some of the
+ *        cases could be done within the assembler block.
+ *  x [DONE] the "v3 v2 v1 v0 v7 v6 v5 v4" comments are confusing,
+ *     inconsistent, and don't match the MMX Programmer's Reference
+ *     Manual conventions anyway.  They should be changed to
+ *     "b7 b6 b5 b4 b3 b2 b1 b0," where b0 indicates the byte that
+ *     was lowest in memory (e.g., corresponding to a left pixel)
+ *     and b7 is the byte that was highest (e.g., a right pixel).
+ *
+ * 19991016:
+ *  - Brennan's Guide notwithstanding, gcc under Linux does *not*
+ *     want globals prefixed by underscores when referencing them--
+ *     i.e., if the variable is const4, then refer to it as const4,
+ *     not _const4.  This seems to be a djgpp-specific requirement.
+ *     Also, such variables apparently *must* be declared outside
+ *     of functions; neither static nor automatic variables work if
+ *     defined within the scope of a single function, but both
+ *     static and truly global (multi-module) variables work fine.
+ *
+ * 19991023:
+ *  - fixed png_combine_row() non-MMX replication bug (odd passes only?)
+ *  - switched from string-concatenation-with-macros to cleaner method of
+ *     renaming global variables for djgpp--i.e., always use prefixes in
+ *     inlined assembler code (== strings) and conditionally rename the
+ *     variables, not the other way around.  Hence _const4, _mask8_0, etc.
+ *
+ * 19991024:
+ *  - fixed mmxsupport()/png_do_read_interlace() first-row bug
+ *     This one was severely weird:  even though mmxsupport() doesn't touch
+ *     ebx (where "row" pointer was stored), it nevertheless managed to zero
+ *     the register (even in static/non-fPIC code--see below), which in turn
+ *     caused png_do_read_interlace() to return prematurely on the first row of
+ *     interlaced images (i.e., without expanding the interlaced pixels).
+ *     Inspection of the generated assembly code didn't turn up any clues,
+ *     although it did point at a minor optimization (i.e., get rid of
+ *     mmx_supported_local variable and just use eax).  Possibly the CPUID
+ *     instruction is more destructive than it looks?  (Not yet checked.)
+ *  - "info gcc" was next to useless, so compared fPIC and non-fPIC assembly
+ *     listings...  Apparently register spillage has to do with ebx, since
+ *     it's used to index the global offset table.  Commenting it out of the
+ *     input-reg lists in png_combine_row() eliminated compiler barfage, so
+ *     ifdef'd with __PIC__ macro:  if defined, use a global for unmask
+ *
+ * 19991107:
+ *  - verified CPUID clobberage:  12-char string constant ("GenuineIntel",
+ *     "AuthenticAMD", etc.) placed in ebx:ecx:edx.  Still need to polish.
+ *
+ * 19991120:
+ *  - made "diff" variable (now "_dif") global to simplify conversion of
+ *     filtering routines (running out of regs, sigh).  "diff" is still used
+ *     in interlacing routines, however.
+ *  - fixed up both versions of mmxsupport() (ORIG_THAT_USED_TO_CLOBBER_EBX
+ *     macro determines which is used); original not yet tested.
+ *
+ * 20000213:
+ *  - when compiling with gcc, be sure to use  -fomit-frame-pointer
+ *
+ * 20000319:
+ *  - fixed a register-name typo in png_do_read_interlace(), default (MMX) case,
+ *     pass == 4 or 5, that caused visible corruption of interlaced images
+ *
+ * 20000623:
+ *  - Various problems were reported with gcc 2.95.2 in the Cygwin environment,
+ *     many of the form "forbidden register 0 (ax) was spilled for class AREG."
+ *     This is explained at http://gcc.gnu.org/fom_serv/cache/23.html, and
+ *     Chuck Wilson supplied a patch involving dummy output registers.  See
+ *     http://sourceforge.net/bugs/?func=detailbug&bug_id=108741&group_id=5624
+ *     for the original (anonymous) SourceForge bug report.
+ *
+ * 20000706:
+ *  - Chuck Wilson passed along these remaining gcc 2.95.2 errors:
+ *       pnggccrd.c: In function `png_combine_row':
+ *       pnggccrd.c:525: more than 10 operands in `asm'
+ *       pnggccrd.c:669: more than 10 operands in `asm'
+ *       pnggccrd.c:828: more than 10 operands in `asm'
+ *       pnggccrd.c:994: more than 10 operands in `asm'
+ *       pnggccrd.c:1177: more than 10 operands in `asm'
+ *     They are all the same problem and can be worked around by using the
+ *     global _unmask variable unconditionally, not just in the -fPIC case.
+ *     Reportedly earlier versions of gcc also have the problem with more than
+ *     10 operands; they just don't report it.  Much strangeness ensues, etc.
+ *
+ * 20000729:
+ *  - enabled png_read_filter_row_mmx_up() (shortest remaining unconverted
+ *     MMX routine); began converting png_read_filter_row_mmx_sub()
+ *  - to finish remaining sections:
+ *     - clean up indentation and comments
+ *     - preload local variables
+ *     - add output and input regs (order of former determines numerical
+ *        mapping of latter)
+ *     - avoid all usage of ebx (including bx, bh, bl) register [20000823]
+ *     - remove "$" from addressing of Shift and Mask variables [20000823]
+ *
+ * 20000731:
+ *  - global union vars causing segfaults in png_read_filter_row_mmx_sub()?
+ *
+ * 20000822:
+ *  - ARGH, stupid png_read_filter_row_mmx_sub() segfault only happens with
+ *     shared-library (-fPIC) version!  Code works just fine as part of static
+ *     library.  Damn damn damn damn damn, should have tested that sooner.
+ *     ebx is getting clobbered again (explicitly this time); need to save it
+ *     on stack or rewrite asm code to avoid using it altogether.  Blargh!
+ *
+ * 20000823:
+ *  - first section was trickiest; all remaining sections have ebx -> edx now.
+ *     (-fPIC works again.)  Also added missing underscores to various Shift*
+ *     and *Mask* globals and got rid of leading "$" signs.
+ *
+ * 20000826:
+ *  - added visual separators to help navigate microscopic printed copies
+ *     (http://pobox.com/~newt/code/gpr-latest.zip, mode 10); started working
+ *     on png_read_filter_row_mmx_avg()
+ *
+ * 20000828:
+ *  - finished png_read_filter_row_mmx_avg():  only Paeth left! (930 lines...)
+ *     What the hell, did png_read_filter_row_mmx_paeth(), too.  Comments not
+ *     cleaned up/shortened in either routine, but functionality is complete
+ *     and seems to be working fine.
+ *
+ * 20000829:
+ *  - ahhh, figured out last(?) bit of gcc/gas asm-fu:  if register is listed
+ *     as an input reg (with dummy output variables, etc.), then it *cannot*
+ *     also appear in the clobber list or gcc 2.95.2 will barf.  The solution
+ *     is simple enough...
+ *
+ * 20000914:
+ *  - bug in png_read_filter_row_mmx_avg():  16-bit grayscale not handled
+ *     correctly (but 48-bit RGB just fine)
+ *
+ * 20000916:
+ *  - fixed bug in png_read_filter_row_mmx_avg(), bpp == 2 case; three errors:
+ *     - "_ShiftBpp.use = 24;"      should have been   "_ShiftBpp.use = 16;"
+ *     - "_ShiftRem.use = 40;"      should have been   "_ShiftRem.use = 48;"
+ *     - "psllq _ShiftRem, %%mm2"   should have been   "psrlq _ShiftRem, %%mm2"
+ *
+ * 20010101:
+ *  - added new png_init_mmx_flags() function (here only because it needs to
+ *     call mmxsupport(), which should probably become global png_mmxsupport());
+ *     modified other MMX routines to run conditionally (png_ptr->asm_flags)
+ *
+ * 20010103:
+ *  - renamed mmxsupport() to png_mmx_support(), with auto-set of mmx_supported,
+ *     and made it public; moved png_init_mmx_flags() to png.c as internal func
+ *
+ * 20010104:
+ *  - removed dependency on png_read_filter_row_c() (C code already duplicated
+ *     within MMX version of png_read_filter_row()) so no longer necessary to
+ *     compile it into pngrutil.o
+ *
+ * 20010310:
+ *  - fixed buffer-overrun bug in png_combine_row() C code (non-MMX)
+ *
+ * 20020304:
+ *  - eliminated incorrect use of width_mmx in pixel_bytes == 8 case
+ *
+ * STILL TO DO:
+ *     - test png_do_read_interlace() 64-bit case (pixel_bytes == 8)
+ *     - write MMX code for 48-bit case (pixel_bytes == 6)
+ *     - figure out what's up with 24-bit case (pixel_bytes == 3):
+ *        why subtract 8 from width_mmx in the pass 4/5 case?
+ *        (only width_mmx case) (near line 1606)
+ *     - rewrite all MMX interlacing code so it's aligned with beginning
+ *        of the row buffer, not the end (see 19991007 for details)
+ *     x pick one version of mmxsupport() and get rid of the other
+ *     - add error messages to any remaining bogus default cases
+ *     - enable pixel_depth == 8 cases in png_read_filter_row()? (test speed)
+ *     x add support for runtime enable/disable/query of various MMX routines
+ */
+
+#define PNG_INTERNAL
+#include "png.h"
+
+#if defined(PNG_USE_PNGGCCRD)
+
+int PNGAPI png_mmx_support(void);
+
+#ifdef PNG_USE_LOCAL_ARRAYS
+static const int FARDATA png_pass_start[7] = {0, 4, 0, 2, 0, 1, 0};
+static const int FARDATA png_pass_inc[7]   = {8, 8, 4, 4, 2, 2, 1};
+static const int FARDATA png_pass_width[7] = {8, 4, 4, 2, 2, 1, 1};
+#endif
+
+#if defined(PNG_ASSEMBLER_CODE_SUPPORTED)
+/* djgpp, Win32, and Cygwin add their own underscores to global variables,
+ * so define them without: */
+#if defined(__DJGPP__) || defined(WIN32) || defined(__CYGWIN__)
+#  define _mmx_supported  mmx_supported
+#  define _const4         const4
+#  define _const6         const6
+#  define _mask8_0        mask8_0
+#  define _mask16_1       mask16_1
+#  define _mask16_0       mask16_0
+#  define _mask24_2       mask24_2
+#  define _mask24_1       mask24_1
+#  define _mask24_0       mask24_0
+#  define _mask32_3       mask32_3
+#  define _mask32_2       mask32_2
+#  define _mask32_1       mask32_1
+#  define _mask32_0       mask32_0
+#  define _mask48_5       mask48_5
+#  define _mask48_4       mask48_4
+#  define _mask48_3       mask48_3
+#  define _mask48_2       mask48_2
+#  define _mask48_1       mask48_1
+#  define _mask48_0       mask48_0
+#  define _LBCarryMask    LBCarryMask
+#  define _HBClearMask    HBClearMask
+#  define _ActiveMask     ActiveMask
+#  define _ActiveMask2    ActiveMask2
+#  define _ActiveMaskEnd  ActiveMaskEnd
+#  define _ShiftBpp       ShiftBpp
+#  define _ShiftRem       ShiftRem
+#ifdef PNG_THREAD_UNSAFE_OK
+#  define _unmask         unmask
+#  define _FullLength     FullLength
+#  define _MMXLength      MMXLength
+#  define _dif            dif
+#  define _patemp         patemp
+#  define _pbtemp         pbtemp
+#  define _pctemp         pctemp
+#endif
+#endif
+
+
+/* These constants are used in the inlined MMX assembly code.
+   Ignore gcc's "At top level: defined but not used" warnings. */
+
+/* GRR 20000706:  originally _unmask was needed only when compiling with -fPIC,
+ *  since that case uses the %ebx register for indexing the Global Offset Table
+ *  and there were no other registers available.  But gcc 2.95 and later emit
+ *  "more than 10 operands in `asm'" errors when %ebx is used to preload unmask
+ *  in the non-PIC case, so we'll just use the global unconditionally now.
+ */
+#ifdef PNG_THREAD_UNSAFE_OK
+static int _unmask;
+#endif
+
+static unsigned long long _mask8_0  = 0x0102040810204080LL;
+
+static unsigned long long _mask16_1 = 0x0101020204040808LL;
+static unsigned long long _mask16_0 = 0x1010202040408080LL;
+
+static unsigned long long _mask24_2 = 0x0101010202020404LL;
+static unsigned long long _mask24_1 = 0x0408080810101020LL;
+static unsigned long long _mask24_0 = 0x2020404040808080LL;
+
+static unsigned long long _mask32_3 = 0x0101010102020202LL;
+static unsigned long long _mask32_2 = 0x0404040408080808LL;
+static unsigned long long _mask32_1 = 0x1010101020202020LL;
+static unsigned long long _mask32_0 = 0x4040404080808080LL;
+
+static unsigned long long _mask48_5 = 0x0101010101010202LL;
+static unsigned long long _mask48_4 = 0x0202020204040404LL;
+static unsigned long long _mask48_3 = 0x0404080808080808LL;
+static unsigned long long _mask48_2 = 0x1010101010102020LL;
+static unsigned long long _mask48_1 = 0x2020202040404040LL;
+static unsigned long long _mask48_0 = 0x4040808080808080LL;
+
+static unsigned long long _const4   = 0x0000000000FFFFFFLL;
+//static unsigned long long _const5 = 0x000000FFFFFF0000LL;     // NOT USED
+static unsigned long long _const6   = 0x00000000000000FFLL;
+
+// These are used in the row-filter routines and should/would be local
+//  variables if not for gcc addressing limitations.
+// WARNING: Their presence probably defeats the thread safety of libpng.
+
+#ifdef PNG_THREAD_UNSAFE_OK
+static png_uint_32  _FullLength;
+static png_uint_32  _MMXLength;
+static int          _dif;
+static int          _patemp; // temp variables for Paeth routine
+static int          _pbtemp;
+static int          _pctemp;
+#endif
+
+void /* PRIVATE */
+png_squelch_warnings(void)
+{
+#ifdef PNG_THREAD_UNSAFE_OK
+   _dif = _dif;
+   _patemp = _patemp;
+   _pbtemp = _pbtemp;
+   _pctemp = _pctemp;
+   _MMXLength = _MMXLength;
+#endif
+   _const4  = _const4;
+   _const6  = _const6;
+   _mask8_0  = _mask8_0;
+   _mask16_1 = _mask16_1;
+   _mask16_0 = _mask16_0;
+   _mask24_2 = _mask24_2;
+   _mask24_1 = _mask24_1;
+   _mask24_0 = _mask24_0;
+   _mask32_3 = _mask32_3;
+   _mask32_2 = _mask32_2;
+   _mask32_1 = _mask32_1;
+   _mask32_0 = _mask32_0;
+   _mask48_5 = _mask48_5;
+   _mask48_4 = _mask48_4;
+   _mask48_3 = _mask48_3;
+   _mask48_2 = _mask48_2;
+   _mask48_1 = _mask48_1;
+   _mask48_0 = _mask48_0;
+}
+#endif /* PNG_ASSEMBLER_CODE_SUPPORTED */
+
+
+static int _mmx_supported = 2;
+
+/*===========================================================================*/
+/*                                                                           */
+/*                       P N G _ C O M B I N E _ R O W                       */
+/*                                                                           */
+/*===========================================================================*/
+
+#if defined(PNG_HAVE_ASSEMBLER_COMBINE_ROW)
+
+#define BPP2  2
+#define BPP3  3 /* bytes per pixel (a.k.a. pixel_bytes) */
+#define BPP4  4
+#define BPP6  6 /* (defined only to help avoid cut-and-paste errors) */
+#define BPP8  8
+
+/* Combines the row recently read in with the previous row.
+   This routine takes care of alpha and transparency if requested.
+   This routine also handles the two methods of progressive display
+   of interlaced images, depending on the mask value.
+   The mask value describes which pixels are to be combined with
+   the row.  The pattern always repeats every 8 pixels, so just 8
+   bits are needed.  A one indicates the pixel is to be combined; a
+   zero indicates the pixel is to be skipped.  This is in addition
+   to any alpha or transparency value associated with the pixel.
+   If you want all pixels to be combined, pass 0xff (255) in mask. */
+
+/* Use this routine for the x86 platform - it uses a faster MMX routine
+   if the machine supports MMX. */
+
+void /* PRIVATE */
+png_combine_row(png_structp png_ptr, png_bytep row, int mask)
+{
+   png_debug(1, "in png_combine_row (pnggccrd.c)\n");
+
+#if defined(PNG_ASSEMBLER_CODE_SUPPORTED)
+   if (_mmx_supported == 2) {
+       /* this should have happened in png_init_mmx_flags() already */
+       png_warning(png_ptr, "asm_flags may not have been initialized");
+       png_mmx_support();
+   }
+#endif
+
+   if (mask == 0xff)
+   {
+      png_debug(2,"mask == 0xff:  doing single png_memcpy()\n");
+      png_memcpy(row, png_ptr->row_buf + 1,
+       (png_size_t)((png_ptr->width * png_ptr->row_info.pixel_depth + 7) >> 3));
+   }
+   else   /* (png_combine_row() is never called with mask == 0) */
+   {
+      switch (png_ptr->row_info.pixel_depth)
+      {
+         case 1:        /* png_ptr->row_info.pixel_depth */
+         {
+            png_bytep sp;
+            png_bytep dp;
+            int s_inc, s_start, s_end;
+            int m;
+            int shift;
+            png_uint_32 i;
+
+            sp = png_ptr->row_buf + 1;
+            dp = row;
+            m = 0x80;
+#if defined(PNG_READ_PACKSWAP_SUPPORTED)
+            if (png_ptr->transformations & PNG_PACKSWAP)
+            {
+                s_start = 0;
+                s_end = 7;
+                s_inc = 1;
+            }
+            else
+#endif
+            {
+                s_start = 7;
+                s_end = 0;
+                s_inc = -1;
+            }
+
+            shift = s_start;
+
+            for (i = 0; i < png_ptr->width; i++)
+            {
+               if (m & mask)
+               {
+                  int value;
+
+                  value = (*sp >> shift) & 0x1;
+                  *dp &= (png_byte)((0x7f7f >> (7 - shift)) & 0xff);
+                  *dp |= (png_byte)(value << shift);
+               }
+
+               if (shift == s_end)
+               {
+                  shift = s_start;
+                  sp++;
+                  dp++;
+               }
+               else
+                  shift += s_inc;
+
+               if (m == 1)
+                  m = 0x80;
+               else
+                  m >>= 1;
+            }
+            break;
+         }
+
+         case 2:        /* png_ptr->row_info.pixel_depth */
+         {
+            png_bytep sp;
+            png_bytep dp;
+            int s_start, s_end, s_inc;
+            int m;
+            int shift;
+            png_uint_32 i;
+            int value;
+
+            sp = png_ptr->row_buf + 1;
+            dp = row;
+            m = 0x80;
+#if defined(PNG_READ_PACKSWAP_SUPPORTED)
+            if (png_ptr->transformations & PNG_PACKSWAP)
+            {
+               s_start = 0;
+               s_end = 6;
+               s_inc = 2;
+            }
+            else
+#endif
+            {
+               s_start = 6;
+               s_end = 0;
+               s_inc = -2;
+            }
+
+            shift = s_start;
+
+            for (i = 0; i < png_ptr->width; i++)
+            {
+               if (m & mask)
+               {
+                  value = (*sp >> shift) & 0x3;
+                  *dp &= (png_byte)((0x3f3f >> (6 - shift)) & 0xff);
+                  *dp |= (png_byte)(value << shift);
+               }
+
+               if (shift == s_end)
+               {
+                  shift = s_start;
+                  sp++;
+                  dp++;
+               }
+               else
+                  shift += s_inc;
+               if (m == 1)
+                  m = 0x80;
+               else
+                  m >>= 1;
+            }
+            break;
+         }
+
+         case 4:        /* png_ptr->row_info.pixel_depth */
+         {
+            png_bytep sp;
+            png_bytep dp;
+            int s_start, s_end, s_inc;
+            int m;
+            int shift;
+            png_uint_32 i;
+            int value;
+
+            sp = png_ptr->row_buf + 1;
+            dp = row;
+            m = 0x80;
+#if defined(PNG_READ_PACKSWAP_SUPPORTED)
+            if (png_ptr->transformations & PNG_PACKSWAP)
+            {
+               s_start = 0;
+               s_end = 4;
+               s_inc = 4;
+            }
+            else
+#endif
+            {
+               s_start = 4;
+               s_end = 0;
+               s_inc = -4;
+            }
+            shift = s_start;
+
+            for (i = 0; i < png_ptr->width; i++)
+            {
+               if (m & mask)
+               {
+                  value = (*sp >> shift) & 0xf;
+                  *dp &= (png_byte)((0xf0f >> (4 - shift)) & 0xff);
+                  *dp |= (png_byte)(value << shift);
+               }
+
+               if (shift == s_end)
+               {
+                  shift = s_start;
+                  sp++;
+                  dp++;
+               }
+               else
+                  shift += s_inc;
+               if (m == 1)
+                  m = 0x80;
+               else
+                  m >>= 1;
+            }
+            break;
+         }
+
+         case 8:        /* png_ptr->row_info.pixel_depth */
+         {
+            png_bytep srcptr;
+            png_bytep dstptr;
+
+#if defined(PNG_ASSEMBLER_CODE_SUPPORTED) && defined(PNG_THREAD_UNSAFE_OK)
+#if !defined(PNG_1_0_X)
+            if ((png_ptr->asm_flags & PNG_ASM_FLAG_MMX_READ_COMBINE_ROW)
+                /* && _mmx_supported */ )
+#else
+            if (_mmx_supported)
+#endif
+            {
+               png_uint_32 len;
+               int diff;
+               int dummy_value_a;   // fix 'forbidden register spilled' error
+               int dummy_value_d;
+               int dummy_value_c;
+               int dummy_value_S;
+               int dummy_value_D;
+               _unmask = ~mask;            // global variable for -fPIC version
+               srcptr = png_ptr->row_buf + 1;
+               dstptr = row;
+               len  = png_ptr->width &~7;  // reduce to multiple of 8
+               diff = (int) (png_ptr->width & 7);  // amount lost
+
+               __asm__ __volatile__ (
+                  "movd      _unmask, %%mm7  \n\t" // load bit pattern
+                  "psubb     %%mm6, %%mm6    \n\t" // zero mm6
+                  "punpcklbw %%mm7, %%mm7    \n\t"
+                  "punpcklwd %%mm7, %%mm7    \n\t"
+                  "punpckldq %%mm7, %%mm7    \n\t" // fill reg with 8 masks
+
+                  "movq      _mask8_0, %%mm0 \n\t"
+                  "pand      %%mm7, %%mm0    \n\t" // nonzero if keep byte
+                  "pcmpeqb   %%mm6, %%mm0    \n\t" // zeros->1s, v versa
+
+// preload        "movl      len, %%ecx      \n\t" // load length of line
+// preload        "movl      srcptr, %%esi   \n\t" // load source
+// preload        "movl      dstptr, %%edi   \n\t" // load dest
+
+                  "cmpl      $0, %%ecx       \n\t" // len == 0 ?
+                  "je        mainloop8end    \n\t"
+
+                "mainloop8:                  \n\t"
+                  "movq      (%%esi), %%mm4  \n\t" // *srcptr
+                  "pand      %%mm0, %%mm4    \n\t"
+                  "movq      %%mm0, %%mm6    \n\t"
+                  "pandn     (%%edi), %%mm6  \n\t" // *dstptr
+                  "por       %%mm6, %%mm4    \n\t"
+                  "movq      %%mm4, (%%edi)  \n\t"
+                  "addl      $8, %%esi       \n\t" // inc by 8 bytes processed
+                  "addl      $8, %%edi       \n\t"
+                  "subl      $8, %%ecx       \n\t" // dec by 8 pixels processed
+                  "ja        mainloop8       \n\t"
+
+                "mainloop8end:               \n\t"
+// preload        "movl      diff, %%ecx     \n\t" // (diff is in eax)
+                  "movl      %%eax, %%ecx    \n\t"
+                  "cmpl      $0, %%ecx       \n\t"
+                  "jz        end8            \n\t"
+// preload        "movl      mask, %%edx     \n\t"
+                  "sall      $24, %%edx      \n\t" // make low byte, high byte
+
+                "secondloop8:                \n\t"
+                  "sall      %%edx           \n\t" // move high bit to CF
+                  "jnc       skip8           \n\t" // if CF = 0
+                  "movb      (%%esi), %%al   \n\t"
+                  "movb      %%al, (%%edi)   \n\t"
+
+                "skip8:                      \n\t"
+                  "incl      %%esi           \n\t"
+                  "incl      %%edi           \n\t"
+                  "decl      %%ecx           \n\t"
+                  "jnz       secondloop8     \n\t"
+
+                "end8:                       \n\t"
+                  "EMMS                      \n\t"  // DONE
+
+                  : "=a" (dummy_value_a),           // output regs (dummy)
+                    "=d" (dummy_value_d),
+                    "=c" (dummy_value_c),
+                    "=S" (dummy_value_S),
+                    "=D" (dummy_value_D)
+
+                  : "3" (srcptr),      // esi       // input regs
+                    "4" (dstptr),      // edi
+                    "0" (diff),        // eax
+// was (unmask)     "b"    RESERVED    // ebx       // Global Offset Table idx
+                    "2" (len),         // ecx
+                    "1" (mask)         // edx
+
+#if 0  /* MMX regs (%mm0, etc.) not supported by gcc 2.7.2.3 or egcs 1.1 */
+                  : "%mm0", "%mm4", "%mm6", "%mm7"  // clobber list
+#endif
+               );
+            }
+            else /* mmx _not supported - Use modified C routine */
+#endif /* PNG_ASSEMBLER_CODE_SUPPORTED */
+            {
+               register png_uint_32 i;
+               png_uint_32 initial_val = png_pass_start[png_ptr->pass];
+                 /* png.c:  png_pass_start[] = {0, 4, 0, 2, 0, 1, 0}; */
+               register int stride = png_pass_inc[png_ptr->pass];
+                 /* png.c:  png_pass_inc[] = {8, 8, 4, 4, 2, 2, 1}; */
+               register int rep_bytes = png_pass_width[png_ptr->pass];
+                 /* png.c:  png_pass_width[] = {8, 4, 4, 2, 2, 1, 1}; */
+               png_uint_32 len = png_ptr->width &~7;  /* reduce to mult. of 8 */
+               int diff = (int) (png_ptr->width & 7); /* amount lost */
+               register png_uint_32 final_val = len;  /* GRR bugfix */
+
+               srcptr = png_ptr->row_buf + 1 + initial_val;
+               dstptr = row + initial_val;
+
+               for (i = initial_val; i < final_val; i += stride)
+               {
+                  png_memcpy(dstptr, srcptr, rep_bytes);
+                  srcptr += stride;
+                  dstptr += stride;
+               }
+               if (diff)  /* number of leftover pixels:  3 for pngtest */
+               {
+                  final_val+=diff /* *BPP1 */ ;
+                  for (; i < final_val; i += stride)
+                  {
+                     if (rep_bytes > (int)(final_val-i))
+                        rep_bytes = (int)(final_val-i);
+                     png_memcpy(dstptr, srcptr, rep_bytes);
+                     srcptr += stride;
+                     dstptr += stride;
+                  }
+               }
+
+            } /* end of else (_mmx_supported) */
+
+            break;
+         }       /* end 8 bpp */
+
+         case 16:       /* png_ptr->row_info.pixel_depth */
+         {
+            png_bytep srcptr;
+            png_bytep dstptr;
+
+#if defined(PNG_ASSEMBLER_CODE_SUPPORTED) && defined(PNG_THREAD_UNSAFE_OK)
+#if !defined(PNG_1_0_X)
+            if ((png_ptr->asm_flags & PNG_ASM_FLAG_MMX_READ_COMBINE_ROW)
+                /* && _mmx_supported */ )
+#else
+            if (_mmx_supported)
+#endif
+            {
+               png_uint_32 len;
+               int diff;
+               int dummy_value_a;   // fix 'forbidden register spilled' error
+               int dummy_value_d;
+               int dummy_value_c;
+               int dummy_value_S;
+               int dummy_value_D;
+               _unmask = ~mask;            // global variable for -fPIC version
+               srcptr = png_ptr->row_buf + 1;
+               dstptr = row;
+               len  = png_ptr->width &~7;  // reduce to multiple of 8
+               diff = (int) (png_ptr->width & 7); // amount lost //
+
+               __asm__ __volatile__ (
+                  "movd      _unmask, %%mm7   \n\t" // load bit pattern
+                  "psubb     %%mm6, %%mm6     \n\t" // zero mm6
+                  "punpcklbw %%mm7, %%mm7     \n\t"
+                  "punpcklwd %%mm7, %%mm7     \n\t"
+                  "punpckldq %%mm7, %%mm7     \n\t" // fill reg with 8 masks
+
+                  "movq      _mask16_0, %%mm0 \n\t"
+                  "movq      _mask16_1, %%mm1 \n\t"
+
+                  "pand      %%mm7, %%mm0     \n\t"
+                  "pand      %%mm7, %%mm1     \n\t"
+
+                  "pcmpeqb   %%mm6, %%mm0     \n\t"
+                  "pcmpeqb   %%mm6, %%mm1     \n\t"
+
+// preload        "movl      len, %%ecx       \n\t" // load length of line
+// preload        "movl      srcptr, %%esi    \n\t" // load source
+// preload        "movl      dstptr, %%edi    \n\t" // load dest
+
+                  "cmpl      $0, %%ecx        \n\t"
+                  "jz        mainloop16end    \n\t"
+
+                "mainloop16:                  \n\t"
+                  "movq      (%%esi), %%mm4   \n\t"
+                  "pand      %%mm0, %%mm4     \n\t"
+                  "movq      %%mm0, %%mm6     \n\t"
+                  "movq      (%%edi), %%mm7   \n\t"
+                  "pandn     %%mm7, %%mm6     \n\t"
+                  "por       %%mm6, %%mm4     \n\t"
+                  "movq      %%mm4, (%%edi)   \n\t"
+
+                  "movq      8(%%esi), %%mm5  \n\t"
+                  "pand      %%mm1, %%mm5     \n\t"
+                  "movq      %%mm1, %%mm7     \n\t"
+                  "movq      8(%%edi), %%mm6  \n\t"
+                  "pandn     %%mm6, %%mm7     \n\t"
+                  "por       %%mm7, %%mm5     \n\t"
+                  "movq      %%mm5, 8(%%edi)  \n\t"
+
+                  "addl      $16, %%esi       \n\t" // inc by 16 bytes processed
+                  "addl      $16, %%edi       \n\t"
+                  "subl      $8, %%ecx        \n\t" // dec by 8 pixels processed
+                  "ja        mainloop16       \n\t"
+
+                "mainloop16end:               \n\t"
+// preload        "movl      diff, %%ecx      \n\t" // (diff is in eax)
+                  "movl      %%eax, %%ecx     \n\t"
+                  "cmpl      $0, %%ecx        \n\t"
+                  "jz        end16            \n\t"
+// preload        "movl      mask, %%edx      \n\t"
+                  "sall      $24, %%edx       \n\t" // make low byte, high byte
+
+                "secondloop16:                \n\t"
+                  "sall      %%edx            \n\t" // move high bit to CF
+                  "jnc       skip16           \n\t" // if CF = 0
+                  "movw      (%%esi), %%ax    \n\t"
+                  "movw      %%ax, (%%edi)    \n\t"
+
+                "skip16:                      \n\t"
+                  "addl      $2, %%esi        \n\t"
+                  "addl      $2, %%edi        \n\t"
+                  "decl      %%ecx            \n\t"
+                  "jnz       secondloop16     \n\t"
+
+                "end16:                       \n\t"
+                  "EMMS                       \n\t" // DONE
+
+                  : "=a" (dummy_value_a),           // output regs (dummy)
+                    "=c" (dummy_value_c),
+                    "=d" (dummy_value_d),
+                    "=S" (dummy_value_S),
+                    "=D" (dummy_value_D)
+
+                  : "0" (diff),        // eax       // input regs
+// was (unmask)     " "    RESERVED    // ebx       // Global Offset Table idx
+                    "1" (len),         // ecx
+                    "2" (mask),        // edx
+                    "3" (srcptr),      // esi
+                    "4" (dstptr)       // edi
+
+#if 0  /* MMX regs (%mm0, etc.) not supported by gcc 2.7.2.3 or egcs 1.1 */
+                  : "%mm0", "%mm1", "%mm4"          // clobber list
+                  , "%mm5", "%mm6", "%mm7"
+#endif
+               );
+            }
+            else /* mmx _not supported - Use modified C routine */
+#endif /* PNG_ASSEMBLER_CODE_SUPPORTED */
+            {
+               register png_uint_32 i;
+               png_uint_32 initial_val = BPP2 * png_pass_start[png_ptr->pass];
+                 /* png.c:  png_pass_start[] = {0, 4, 0, 2, 0, 1, 0}; */
+               register int stride = BPP2 * png_pass_inc[png_ptr->pass];
+                 /* png.c:  png_pass_inc[] = {8, 8, 4, 4, 2, 2, 1}; */
+               register int rep_bytes = BPP2 * png_pass_width[png_ptr->pass];
+                 /* png.c:  png_pass_width[] = {8, 4, 4, 2, 2, 1, 1}; */
+               png_uint_32 len = png_ptr->width &~7;  /* reduce to mult. of 8 */
+               int diff = (int) (png_ptr->width & 7); /* amount lost */
+               register png_uint_32 final_val = BPP2 * len;   /* GRR bugfix */
+
+               srcptr = png_ptr->row_buf + 1 + initial_val;
+               dstptr = row + initial_val;
+
+               for (i = initial_val; i < final_val; i += stride)
+               {
+                  png_memcpy(dstptr, srcptr, rep_bytes);
+                  srcptr += stride;
+                  dstptr += stride;
+               }
+               if (diff)  /* number of leftover pixels:  3 for pngtest */
+               {
+                  final_val+=diff*BPP2;
+                  for (; i < final_val; i += stride)
+                  {
+                     if (rep_bytes > (int)(final_val-i))
+                        rep_bytes = (int)(final_val-i);
+                     png_memcpy(dstptr, srcptr, rep_bytes);
+                     srcptr += stride;
+                     dstptr += stride;
+                  }
+               }
+            } /* end of else (_mmx_supported) */
+
+            break;
+         }       /* end 16 bpp */
+
+         case 24:       /* png_ptr->row_info.pixel_depth */
+         {
+            png_bytep srcptr;
+            png_bytep dstptr;
+
+#if defined(PNG_ASSEMBLER_CODE_SUPPORTED) && defined(PNG_THREAD_UNSAFE_OK)
+#if !defined(PNG_1_0_X)
+            if ((png_ptr->asm_flags & PNG_ASM_FLAG_MMX_READ_COMBINE_ROW)
+                /* && _mmx_supported */ )
+#else
+            if (_mmx_supported)
+#endif
+            {
+               png_uint_32 len;
+               int diff;
+               int dummy_value_a;   // fix 'forbidden register spilled' error
+               int dummy_value_d;
+               int dummy_value_c;
+               int dummy_value_S;
+               int dummy_value_D;
+               _unmask = ~mask;            // global variable for -fPIC version
+               srcptr = png_ptr->row_buf + 1;
+               dstptr = row;
+               len  = png_ptr->width &~7;  // reduce to multiple of 8
+               diff = (int) (png_ptr->width & 7); // amount lost //
+
+               __asm__ __volatile__ (
+                  "movd      _unmask, %%mm7   \n\t" // load bit pattern
+                  "psubb     %%mm6, %%mm6     \n\t" // zero mm6
+                  "punpcklbw %%mm7, %%mm7     \n\t"
+                  "punpcklwd %%mm7, %%mm7     \n\t"
+                  "punpckldq %%mm7, %%mm7     \n\t" // fill reg with 8 masks
+
+                  "movq      _mask24_0, %%mm0 \n\t"
+                  "movq      _mask24_1, %%mm1 \n\t"
+                  "movq      _mask24_2, %%mm2 \n\t"
+
+                  "pand      %%mm7, %%mm0     \n\t"
+                  "pand      %%mm7, %%mm1     \n\t"
+                  "pand      %%mm7, %%mm2     \n\t"
+
+                  "pcmpeqb   %%mm6, %%mm0     \n\t"
+                  "pcmpeqb   %%mm6, %%mm1     \n\t"
+                  "pcmpeqb   %%mm6, %%mm2     \n\t"
+
+// preload        "movl      len, %%ecx       \n\t" // load length of line
+// preload        "movl      srcptr, %%esi    \n\t" // load source
+// preload        "movl      dstptr, %%edi    \n\t" // load dest
+
+                  "cmpl      $0, %%ecx        \n\t"
+                  "jz        mainloop24end    \n\t"
+
+                "mainloop24:                  \n\t"
+                  "movq      (%%esi), %%mm4   \n\t"
+                  "pand      %%mm0, %%mm4     \n\t"
+                  "movq      %%mm0, %%mm6     \n\t"
+                  "movq      (%%edi), %%mm7   \n\t"
+                  "pandn     %%mm7, %%mm6     \n\t"
+                  "por       %%mm6, %%mm4     \n\t"
+                  "movq      %%mm4, (%%edi)   \n\t"
+
+                  "movq      8(%%esi), %%mm5  \n\t"
+                  "pand      %%mm1, %%mm5     \n\t"
+                  "movq      %%mm1, %%mm7     \n\t"
+                  "movq      8(%%edi), %%mm6  \n\t"
+                  "pandn     %%mm6, %%mm7     \n\t"
+                  "por       %%mm7, %%mm5     \n\t"
+                  "movq      %%mm5, 8(%%edi)  \n\t"
+
+                  "movq      16(%%esi), %%mm6 \n\t"
+                  "pand      %%mm2, %%mm6     \n\t"
+                  "movq      %%mm2, %%mm4     \n\t"
+                  "movq      16(%%edi), %%mm7 \n\t"
+                  "pandn     %%mm7, %%mm4     \n\t"
+                  "por       %%mm4, %%mm6     \n\t"
+                  "movq      %%mm6, 16(%%edi) \n\t"
+
+                  "addl      $24, %%esi       \n\t" // inc by 24 bytes processed
+                  "addl      $24, %%edi       \n\t"
+                  "subl      $8, %%ecx        \n\t" // dec by 8 pixels processed
+
+                  "ja        mainloop24       \n\t"
+
+                "mainloop24end:               \n\t"
+// preload        "movl      diff, %%ecx      \n\t" // (diff is in eax)
+                  "movl      %%eax, %%ecx     \n\t"
+                  "cmpl      $0, %%ecx        \n\t"
+                  "jz        end24            \n\t"
+// preload        "movl      mask, %%edx      \n\t"
+                  "sall      $24, %%edx       \n\t" // make low byte, high byte
+
+                "secondloop24:                \n\t"
+                  "sall      %%edx            \n\t" // move high bit to CF
+                  "jnc       skip24           \n\t" // if CF = 0
+                  "movw      (%%esi), %%ax    \n\t"
+                  "movw      %%ax, (%%edi)    \n\t"
+                  "xorl      %%eax, %%eax     \n\t"
+                  "movb      2(%%esi), %%al   \n\t"
+                  "movb      %%al, 2(%%edi)   \n\t"
+
+                "skip24:                      \n\t"
+                  "addl      $3, %%esi        \n\t"
+                  "addl      $3, %%edi        \n\t"
+                  "decl      %%ecx            \n\t"
+                  "jnz       secondloop24     \n\t"
+
+                "end24:                       \n\t"
+                  "EMMS                       \n\t" // DONE
+
+                  : "=a" (dummy_value_a),           // output regs (dummy)
+                    "=d" (dummy_value_d),
+                    "=c" (dummy_value_c),
+                    "=S" (dummy_value_S),
+                    "=D" (dummy_value_D)
+
+                  : "3" (srcptr),      // esi       // input regs
+                    "4" (dstptr),      // edi
+                    "0" (diff),        // eax
+// was (unmask)     "b"    RESERVED    // ebx       // Global Offset Table idx
+                    "2" (len),         // ecx
+                    "1" (mask)         // edx
+
+#if 0  /* MMX regs (%mm0, etc.) not supported by gcc 2.7.2.3 or egcs 1.1 */
+                  : "%mm0", "%mm1", "%mm2"          // clobber list
+                  , "%mm4", "%mm5", "%mm6", "%mm7"
+#endif
+               );
+            }
+            else /* mmx _not supported - Use modified C routine */
+#endif /* PNG_ASSEMBLER_CODE_SUPPORTED */
+            {
+               register png_uint_32 i;
+               png_uint_32 initial_val = BPP3 * png_pass_start[png_ptr->pass];
+                 /* png.c:  png_pass_start[] = {0, 4, 0, 2, 0, 1, 0}; */
+               register int stride = BPP3 * png_pass_inc[png_ptr->pass];
+                 /* png.c:  png_pass_inc[] = {8, 8, 4, 4, 2, 2, 1}; */
+               register int rep_bytes = BPP3 * png_pass_width[png_ptr->pass];
+                 /* png.c:  png_pass_width[] = {8, 4, 4, 2, 2, 1, 1}; */
+               png_uint_32 len = png_ptr->width &~7;  /* reduce to mult. of 8 */
+               int diff = (int) (png_ptr->width & 7); /* amount lost */
+               register png_uint_32 final_val = BPP3 * len;   /* GRR bugfix */
+
+               srcptr = png_ptr->row_buf + 1 + initial_val;
+               dstptr = row + initial_val;
+
+               for (i = initial_val; i < final_val; i += stride)
+               {
+                  png_memcpy(dstptr, srcptr, rep_bytes);
+                  srcptr += stride;
+                  dstptr += stride;
+               }
+               if (diff)  /* number of leftover pixels:  3 for pngtest */
+               {
+                  final_val+=diff*BPP3;
+                  for (; i < final_val; i += stride)
+                  {
+                     if (rep_bytes > (int)(final_val-i))
+                        rep_bytes = (int)(final_val-i);
+                     png_memcpy(dstptr, srcptr, rep_bytes);
+                     srcptr += stride;
+                     dstptr += stride;
+                  }
+               }
+            } /* end of else (_mmx_supported) */
+
+            break;
+         }       /* end 24 bpp */
+
+         case 32:       /* png_ptr->row_info.pixel_depth */
+         {
+            png_bytep srcptr;
+            png_bytep dstptr;
+
+#if defined(PNG_ASSEMBLER_CODE_SUPPORTED) && defined(PNG_THREAD_UNSAFE_OK)
+#if !defined(PNG_1_0_X)
+            if ((png_ptr->asm_flags & PNG_ASM_FLAG_MMX_READ_COMBINE_ROW)
+                /* && _mmx_supported */ )
+#else
+            if (_mmx_supported)
+#endif
+            {
+               png_uint_32 len;
+               int diff;
+               int dummy_value_a;   // fix 'forbidden register spilled' error
+               int dummy_value_d;
+               int dummy_value_c;
+               int dummy_value_S;
+               int dummy_value_D;
+               _unmask = ~mask;            // global variable for -fPIC version
+               srcptr = png_ptr->row_buf + 1;
+               dstptr = row;
+               len  = png_ptr->width &~7;  // reduce to multiple of 8
+               diff = (int) (png_ptr->width & 7); // amount lost //
+
+               __asm__ __volatile__ (
+                  "movd      _unmask, %%mm7   \n\t" // load bit pattern
+                  "psubb     %%mm6, %%mm6     \n\t" // zero mm6
+                  "punpcklbw %%mm7, %%mm7     \n\t"
+                  "punpcklwd %%mm7, %%mm7     \n\t"
+                  "punpckldq %%mm7, %%mm7     \n\t" // fill reg with 8 masks
+
+                  "movq      _mask32_0, %%mm0 \n\t"
+                  "movq      _mask32_1, %%mm1 \n\t"
+                  "movq      _mask32_2, %%mm2 \n\t"
+                  "movq      _mask32_3, %%mm3 \n\t"
+
+                  "pand      %%mm7, %%mm0     \n\t"
+                  "pand      %%mm7, %%mm1     \n\t"
+                  "pand      %%mm7, %%mm2     \n\t"
+                  "pand      %%mm7, %%mm3     \n\t"
+
+                  "pcmpeqb   %%mm6, %%mm0     \n\t"
+                  "pcmpeqb   %%mm6, %%mm1     \n\t"
+                  "pcmpeqb   %%mm6, %%mm2     \n\t"
+                  "pcmpeqb   %%mm6, %%mm3     \n\t"
+
+// preload        "movl      len, %%ecx       \n\t" // load length of line
+// preload        "movl      srcptr, %%esi    \n\t" // load source
+// preload        "movl      dstptr, %%edi    \n\t" // load dest
+
+                  "cmpl      $0, %%ecx        \n\t" // lcr
+                  "jz        mainloop32end    \n\t"
+
+                "mainloop32:                  \n\t"
+                  "movq      (%%esi), %%mm4   \n\t"
+                  "pand      %%mm0, %%mm4     \n\t"
+                  "movq      %%mm0, %%mm6     \n\t"
+                  "movq      (%%edi), %%mm7   \n\t"
+                  "pandn     %%mm7, %%mm6     \n\t"
+                  "por       %%mm6, %%mm4     \n\t"
+                  "movq      %%mm4, (%%edi)   \n\t"
+
+                  "movq      8(%%esi), %%mm5  \n\t"
+                  "pand      %%mm1, %%mm5     \n\t"
+                  "movq      %%mm1, %%mm7     \n\t"
+                  "movq      8(%%edi), %%mm6  \n\t"
+                  "pandn     %%mm6, %%mm7     \n\t"
+                  "por       %%mm7, %%mm5     \n\t"
+                  "movq      %%mm5, 8(%%edi)  \n\t"
+
+                  "movq      16(%%esi), %%mm6 \n\t"
+                  "pand      %%mm2, %%mm6     \n\t"
+                  "movq      %%mm2, %%mm4     \n\t"
+                  "movq      16(%%edi), %%mm7 \n\t"
+                  "pandn     %%mm7, %%mm4     \n\t"
+                  "por       %%mm4, %%mm6     \n\t"
+                  "movq      %%mm6, 16(%%edi) \n\t"
+
+                  "movq      24(%%esi), %%mm7 \n\t"
+                  "pand      %%mm3, %%mm7     \n\t"
+                  "movq      %%mm3, %%mm5     \n\t"
+                  "movq      24(%%edi), %%mm4 \n\t"
+                  "pandn     %%mm4, %%mm5     \n\t"
+                  "por       %%mm5, %%mm7     \n\t"
+                  "movq      %%mm7, 24(%%edi) \n\t"
+
+                  "addl      $32, %%esi       \n\t" // inc by 32 bytes processed
+                  "addl      $32, %%edi       \n\t"
+                  "subl      $8, %%ecx        \n\t" // dec by 8 pixels processed
+                  "ja        mainloop32       \n\t"
+
+                "mainloop32end:               \n\t"
+// preload        "movl      diff, %%ecx      \n\t" // (diff is in eax)
+                  "movl      %%eax, %%ecx     \n\t"
+                  "cmpl      $0, %%ecx        \n\t"
+                  "jz        end32            \n\t"
+// preload        "movl      mask, %%edx      \n\t"
+                  "sall      $24, %%edx       \n\t" // low byte => high byte
+
+                "secondloop32:                \n\t"
+                  "sall      %%edx            \n\t" // move high bit to CF
+                  "jnc       skip32           \n\t" // if CF = 0
+                  "movl      (%%esi), %%eax   \n\t"
+                  "movl      %%eax, (%%edi)   \n\t"
+
+                "skip32:                      \n\t"
+                  "addl      $4, %%esi        \n\t"
+                  "addl      $4, %%edi        \n\t"
+                  "decl      %%ecx            \n\t"
+                  "jnz       secondloop32     \n\t"
+
+                "end32:                       \n\t"
+                  "EMMS                       \n\t" // DONE
+
+                  : "=a" (dummy_value_a),           // output regs (dummy)
+                    "=d" (dummy_value_d),
+                    "=c" (dummy_value_c),
+                    "=S" (dummy_value_S),
+                    "=D" (dummy_value_D)
+
+                  : "3" (srcptr),      // esi       // input regs
+                    "4" (dstptr),      // edi
+                    "0" (diff),        // eax
+// was (unmask)     "b"    RESERVED    // ebx       // Global Offset Table idx
+                    "2" (len),         // ecx
+                    "1" (mask)         // edx
+
+#if 0  /* MMX regs (%mm0, etc.) not supported by gcc 2.7.2.3 or egcs 1.1 */
+                  : "%mm0", "%mm1", "%mm2", "%mm3"  // clobber list
+                  , "%mm4", "%mm5", "%mm6", "%mm7"
+#endif
+               );
+            }
+            else /* mmx _not supported - Use modified C routine */
+#endif /* PNG_ASSEMBLER_CODE_SUPPORTED */
+            {
+               register png_uint_32 i;
+               png_uint_32 initial_val = BPP4 * png_pass_start[png_ptr->pass];
+                 /* png.c:  png_pass_start[] = {0, 4, 0, 2, 0, 1, 0}; */
+               register int stride = BPP4 * png_pass_inc[png_ptr->pass];
+                 /* png.c:  png_pass_inc[] = {8, 8, 4, 4, 2, 2, 1}; */
+               register int rep_bytes = BPP4 * png_pass_width[png_ptr->pass];
+                 /* png.c:  png_pass_width[] = {8, 4, 4, 2, 2, 1, 1}; */
+               png_uint_32 len = png_ptr->width &~7;  /* reduce to mult. of 8 */
+               int diff = (int) (png_ptr->width & 7); /* amount lost */
+               register png_uint_32 final_val = BPP4 * len;   /* GRR bugfix */
+
+               srcptr = png_ptr->row_buf + 1 + initial_val;
+               dstptr = row + initial_val;
+
+               for (i = initial_val; i < final_val; i += stride)
+               {
+                  png_memcpy(dstptr, srcptr, rep_bytes);
+                  srcptr += stride;
+                  dstptr += stride;
+               }
+               if (diff)  /* number of leftover pixels:  3 for pngtest */
+               {
+                  final_val+=diff*BPP4;
+                  for (; i < final_val; i += stride)
+                  {
+                     if (rep_bytes > (int)(final_val-i))
+                        rep_bytes = (int)(final_val-i);
+                     png_memcpy(dstptr, srcptr, rep_bytes);
+                     srcptr += stride;
+                     dstptr += stride;
+                  }
+               }
+            } /* end of else (_mmx_supported) */
+
+            break;
+         }       /* end 32 bpp */
+
+         case 48:       /* png_ptr->row_info.pixel_depth */
+         {
+            png_bytep srcptr;
+            png_bytep dstptr;
+
+#if defined(PNG_ASSEMBLER_CODE_SUPPORTED) && defined(PNG_THREAD_UNSAFE_OK)
+#if !defined(PNG_1_0_X)
+            if ((png_ptr->asm_flags & PNG_ASM_FLAG_MMX_READ_COMBINE_ROW)
+                /* && _mmx_supported */ )
+#else
+            if (_mmx_supported)
+#endif
+            {
+               png_uint_32 len;
+               int diff;
+               int dummy_value_a;   // fix 'forbidden register spilled' error
+               int dummy_value_d;
+               int dummy_value_c;
+               int dummy_value_S;
+               int dummy_value_D;
+               _unmask = ~mask;            // global variable for -fPIC version
+               srcptr = png_ptr->row_buf + 1;
+               dstptr = row;
+               len  = png_ptr->width &~7;  // reduce to multiple of 8
+               diff = (int) (png_ptr->width & 7); // amount lost //
+
+               __asm__ __volatile__ (
+                  "movd      _unmask, %%mm7   \n\t" // load bit pattern
+                  "psubb     %%mm6, %%mm6     \n\t" // zero mm6
+                  "punpcklbw %%mm7, %%mm7     \n\t"
+                  "punpcklwd %%mm7, %%mm7     \n\t"
+                  "punpckldq %%mm7, %%mm7     \n\t" // fill reg with 8 masks
+
+                  "movq      _mask48_0, %%mm0 \n\t"
+                  "movq      _mask48_1, %%mm1 \n\t"
+                  "movq      _mask48_2, %%mm2 \n\t"
+                  "movq      _mask48_3, %%mm3 \n\t"
+                  "movq      _mask48_4, %%mm4 \n\t"
+                  "movq      _mask48_5, %%mm5 \n\t"
+
+                  "pand      %%mm7, %%mm0     \n\t"
+                  "pand      %%mm7, %%mm1     \n\t"
+                  "pand      %%mm7, %%mm2     \n\t"
+                  "pand      %%mm7, %%mm3     \n\t"
+                  "pand      %%mm7, %%mm4     \n\t"
+                  "pand      %%mm7, %%mm5     \n\t"
+
+                  "pcmpeqb   %%mm6, %%mm0     \n\t"
+                  "pcmpeqb   %%mm6, %%mm1     \n\t"
+                  "pcmpeqb   %%mm6, %%mm2     \n\t"
+                  "pcmpeqb   %%mm6, %%mm3     \n\t"
+                  "pcmpeqb   %%mm6, %%mm4     \n\t"
+                  "pcmpeqb   %%mm6, %%mm5     \n\t"
+
+// preload        "movl      len, %%ecx       \n\t" // load length of line
+// preload        "movl      srcptr, %%esi    \n\t" // load source
+// preload        "movl      dstptr, %%edi    \n\t" // load dest
+
+                  "cmpl      $0, %%ecx        \n\t"
+                  "jz        mainloop48end    \n\t"
+
+                "mainloop48:                  \n\t"
+                  "movq      (%%esi), %%mm7   \n\t"
+                  "pand      %%mm0, %%mm7     \n\t"
+                  "movq      %%mm0, %%mm6     \n\t"
+                  "pandn     (%%edi), %%mm6   \n\t"
+                  "por       %%mm6, %%mm7     \n\t"
+                  "movq      %%mm7, (%%edi)   \n\t"
+
+                  "movq      8(%%esi), %%mm6  \n\t"
+                  "pand      %%mm1, %%mm6     \n\t"
+                  "movq      %%mm1, %%mm7     \n\t"
+                  "pandn     8(%%edi), %%mm7  \n\t"
+                  "por       %%mm7, %%mm6     \n\t"
+                  "movq      %%mm6, 8(%%edi)  \n\t"
+
+                  "movq      16(%%esi), %%mm6 \n\t"
+                  "pand      %%mm2, %%mm6     \n\t"
+                  "movq      %%mm2, %%mm7     \n\t"
+                  "pandn     16(%%edi), %%mm7 \n\t"
+                  "por       %%mm7, %%mm6     \n\t"
+                  "movq      %%mm6, 16(%%edi) \n\t"
+
+                  "movq      24(%%esi), %%mm7 \n\t"
+                  "pand      %%mm3, %%mm7     \n\t"
+                  "movq      %%mm3, %%mm6     \n\t"
+                  "pandn     24(%%edi), %%mm6 \n\t"
+                  "por       %%mm6, %%mm7     \n\t"
+                  "movq      %%mm7, 24(%%edi) \n\t"
+
+                  "movq      32(%%esi), %%mm6 \n\t"
+                  "pand      %%mm4, %%mm6     \n\t"
+                  "movq      %%mm4, %%mm7     \n\t"
+                  "pandn     32(%%edi), %%mm7 \n\t"
+                  "por       %%mm7, %%mm6     \n\t"
+                  "movq      %%mm6, 32(%%edi) \n\t"
+
+                  "movq      40(%%esi), %%mm7 \n\t"
+                  "pand      %%mm5, %%mm7     \n\t"
+                  "movq      %%mm5, %%mm6     \n\t"
+                  "pandn     40(%%edi), %%mm6 \n\t"
+                  "por       %%mm6, %%mm7     \n\t"
+                  "movq      %%mm7, 40(%%edi) \n\t"
+
+                  "addl      $48, %%esi       \n\t" // inc by 48 bytes processed
+                  "addl      $48, %%edi       \n\t"
+                  "subl      $8, %%ecx        \n\t" // dec by 8 pixels processed
+
+                  "ja        mainloop48       \n\t"
+
+                "mainloop48end:               \n\t"
+// preload        "movl      diff, %%ecx      \n\t" // (diff is in eax)
+                  "movl      %%eax, %%ecx     \n\t"
+                  "cmpl      $0, %%ecx        \n\t"
+                  "jz        end48            \n\t"
+// preload        "movl      mask, %%edx      \n\t"
+                  "sall      $24, %%edx       \n\t" // make low byte, high byte
+
+                "secondloop48:                \n\t"
+                  "sall      %%edx            \n\t" // move high bit to CF
+                  "jnc       skip48           \n\t" // if CF = 0
+                  "movl      (%%esi), %%eax   \n\t"
+                  "movl      %%eax, (%%edi)   \n\t"
+
+                "skip48:                      \n\t"
+                  "addl      $4, %%esi        \n\t"
+                  "addl      $4, %%edi        \n\t"
+                  "decl      %%ecx            \n\t"
+                  "jnz       secondloop48     \n\t"
+
+                "end48:                       \n\t"
+                  "EMMS                       \n\t" // DONE
+
+                  : "=a" (dummy_value_a),           // output regs (dummy)
+                    "=d" (dummy_value_d),
+                    "=c" (dummy_value_c),
+                    "=S" (dummy_value_S),
+                    "=D" (dummy_value_D)
+
+                  : "3" (srcptr),      // esi       // input regs
+                    "4" (dstptr),      // edi
+                    "0" (diff),        // eax
+// was (unmask)     "b"    RESERVED    // ebx       // Global Offset Table idx
+                    "2" (len),         // ecx
+                    "1" (mask)         // edx
+
+#if 0  /* MMX regs (%mm0, etc.) not supported by gcc 2.7.2.3 or egcs 1.1 */
+                  : "%mm0", "%mm1", "%mm2", "%mm3"  // clobber list
+                  , "%mm4", "%mm5", "%mm6", "%mm7"
+#endif
+               );
+            }
+            else /* mmx _not supported - Use modified C routine */
+#endif /* PNG_ASSEMBLER_CODE_SUPPORTED */
+            {
+               register png_uint_32 i;
+               png_uint_32 initial_val = BPP6 * png_pass_start[png_ptr->pass];
+                 /* png.c:  png_pass_start[] = {0, 4, 0, 2, 0, 1, 0}; */
+               register int stride = BPP6 * png_pass_inc[png_ptr->pass];
+                 /* png.c:  png_pass_inc[] = {8, 8, 4, 4, 2, 2, 1}; */
+               register int rep_bytes = BPP6 * png_pass_width[png_ptr->pass];
+                 /* png.c:  png_pass_width[] = {8, 4, 4, 2, 2, 1, 1}; */
+               png_uint_32 len = png_ptr->width &~7;  /* reduce to mult. of 8 */
+               int diff = (int) (png_ptr->width & 7); /* amount lost */
+               register png_uint_32 final_val = BPP6 * len;   /* GRR bugfix */
+
+               srcptr = png_ptr->row_buf + 1 + initial_val;
+               dstptr = row + initial_val;
+
+               for (i = initial_val; i < final_val; i += stride)
+               {
+                  png_memcpy(dstptr, srcptr, rep_bytes);
+                  srcptr += stride;
+                  dstptr += stride;
+               }
+               if (diff)  /* number of leftover pixels:  3 for pngtest */
+               {
+                  final_val+=diff*BPP6;
+                  for (; i < final_val; i += stride)
+                  {
+                     if (rep_bytes > (int)(final_val-i))
+                        rep_bytes = (int)(final_val-i);
+                     png_memcpy(dstptr, srcptr, rep_bytes);
+                     srcptr += stride;
+                     dstptr += stride;
+                  }
+               }
+            } /* end of else (_mmx_supported) */
+
+            break;
+         }       /* end 48 bpp */
+
+         case 64:       /* png_ptr->row_info.pixel_depth */
+         {
+            png_bytep srcptr;
+            png_bytep dstptr;
+            register png_uint_32 i;
+            png_uint_32 initial_val = BPP8 * png_pass_start[png_ptr->pass];
+              /* png.c:  png_pass_start[] = {0, 4, 0, 2, 0, 1, 0}; */
+            register int stride = BPP8 * png_pass_inc[png_ptr->pass];
+              /* png.c:  png_pass_inc[] = {8, 8, 4, 4, 2, 2, 1}; */
+            register int rep_bytes = BPP8 * png_pass_width[png_ptr->pass];
+              /* png.c:  png_pass_width[] = {8, 4, 4, 2, 2, 1, 1}; */
+            png_uint_32 len = png_ptr->width &~7;  /* reduce to mult. of 8 */
+            int diff = (int) (png_ptr->width & 7); /* amount lost */
+            register png_uint_32 final_val = BPP8 * len;   /* GRR bugfix */
+
+            srcptr = png_ptr->row_buf + 1 + initial_val;
+            dstptr = row + initial_val;
+
+            for (i = initial_val; i < final_val; i += stride)
+            {
+               png_memcpy(dstptr, srcptr, rep_bytes);
+               srcptr += stride;
+               dstptr += stride;
+            }
+            if (diff)  /* number of leftover pixels:  3 for pngtest */
+            {
+               final_val+=diff*BPP8;
+               for (; i < final_val; i += stride)
+               {
+                  if (rep_bytes > (int)(final_val-i))
+                     rep_bytes = (int)(final_val-i);
+                  png_memcpy(dstptr, srcptr, rep_bytes);
+                  srcptr += stride;
+                  dstptr += stride;
+               }
+            }
+
+            break;
+         }       /* end 64 bpp */
+
+         default: /* png_ptr->row_info.pixel_depth != 1,2,4,8,16,24,32,48,64 */
+         {
+            /* this should never happen */
+            png_warning(png_ptr, "Invalid row_info.pixel_depth in pnggccrd");
+            break;
+         }
+      } /* end switch (png_ptr->row_info.pixel_depth) */
+
+   } /* end if (non-trivial mask) */
+
+} /* end png_combine_row() */
+
+#endif /* PNG_HAVE_ASSEMBLER_COMBINE_ROW */
+
+
+
+
+/*===========================================================================*/
+/*                                                                           */
+/*                 P N G _ D O _ R E A D _ I N T E R L A C E                 */
+/*                                                                           */
+/*===========================================================================*/
+
+#if defined(PNG_READ_INTERLACING_SUPPORTED)
+#if defined(PNG_HAVE_ASSEMBLER_READ_INTERLACE)
+
+/* png_do_read_interlace() is called after any 16-bit to 8-bit conversion
+ * has taken place.  [GRR: what other steps come before and/or after?]
+ */
+
+void /* PRIVATE */
+png_do_read_interlace(png_structp png_ptr)
+{
+   png_row_infop row_info = &(png_ptr->row_info);
+   png_bytep row = png_ptr->row_buf + 1;
+   int pass = png_ptr->pass;
+#if defined(PNG_READ_PACKSWAP_SUPPORTED)
+   png_uint_32 transformations = png_ptr->transformations;
+#endif
+
+   png_debug(1, "in png_do_read_interlace (pnggccrd.c)\n");
+
+#if defined(PNG_ASSEMBLER_CODE_SUPPORTED)
+   if (_mmx_supported == 2) {
+#if !defined(PNG_1_0_X)
+       /* this should have happened in png_init_mmx_flags() already */
+       png_warning(png_ptr, "asm_flags may not have been initialized");
+#endif
+       png_mmx_support();
+   }
+#endif
+
+   if (row != NULL && row_info != NULL)
+   {
+      png_uint_32 final_width;
+
+      final_width = row_info->width * png_pass_inc[pass];
+
+      switch (row_info->pixel_depth)
+      {
+         case 1:
+         {
+            png_bytep sp, dp;
+            int sshift, dshift;
+            int s_start, s_end, s_inc;
+            png_byte v;
+            png_uint_32 i;
+            int j;
+
+            sp = row + (png_size_t)((row_info->width - 1) >> 3);
+            dp = row + (png_size_t)((final_width - 1) >> 3);
+#if defined(PNG_READ_PACKSWAP_SUPPORTED)
+            if (transformations & PNG_PACKSWAP)
+            {
+               sshift = (int)((row_info->width + 7) & 7);
+               dshift = (int)((final_width + 7) & 7);
+               s_start = 7;
+               s_end = 0;
+               s_inc = -1;
+            }
+            else
+#endif
+            {
+               sshift = 7 - (int)((row_info->width + 7) & 7);
+               dshift = 7 - (int)((final_width + 7) & 7);
+               s_start = 0;
+               s_end = 7;
+               s_inc = 1;
+            }
+
+            for (i = row_info->width; i; i--)
+            {
+               v = (png_byte)((*sp >> sshift) & 0x1);
+               for (j = 0; j < png_pass_inc[pass]; j++)
+               {
+                  *dp &= (png_byte)((0x7f7f >> (7 - dshift)) & 0xff);
+                  *dp |= (png_byte)(v << dshift);
+                  if (dshift == s_end)
+                  {
+                     dshift = s_start;
+                     dp--;
+                  }
+                  else
+                     dshift += s_inc;
+               }
+               if (sshift == s_end)
+               {
+                  sshift = s_start;
+                  sp--;
+               }
+               else
+                  sshift += s_inc;
+            }
+            break;
+         }
+
+         case 2:
+         {
+            png_bytep sp, dp;
+            int sshift, dshift;
+            int s_start, s_end, s_inc;
+            png_uint_32 i;
+
+            sp = row + (png_size_t)((row_info->width - 1) >> 2);
+            dp = row + (png_size_t)((final_width - 1) >> 2);
+#if defined(PNG_READ_PACKSWAP_SUPPORTED)
+            if (transformations & PNG_PACKSWAP)
+            {
+               sshift = (png_size_t)(((row_info->width + 3) & 3) << 1);
+               dshift = (png_size_t)(((final_width + 3) & 3) << 1);
+               s_start = 6;
+               s_end = 0;
+               s_inc = -2;
+            }
+            else
+#endif
+            {
+               sshift = (png_size_t)((3 - ((row_info->width + 3) & 3)) << 1);
+               dshift = (png_size_t)((3 - ((final_width + 3) & 3)) << 1);
+               s_start = 0;
+               s_end = 6;
+               s_inc = 2;
+            }
+
+            for (i = row_info->width; i; i--)
+            {
+               png_byte v;
+               int j;
+
+               v = (png_byte)((*sp >> sshift) & 0x3);
+               for (j = 0; j < png_pass_inc[pass]; j++)
+               {
+                  *dp &= (png_byte)((0x3f3f >> (6 - dshift)) & 0xff);
+                  *dp |= (png_byte)(v << dshift);
+                  if (dshift == s_end)
+                  {
+                     dshift = s_start;
+                     dp--;
+                  }
+                  else
+                     dshift += s_inc;
+               }
+               if (sshift == s_end)
+               {
+                  sshift = s_start;
+                  sp--;
+               }
+               else
+                  sshift += s_inc;
+            }
+            break;
+         }
+
+         case 4:
+         {
+            png_bytep sp, dp;
+            int sshift, dshift;
+            int s_start, s_end, s_inc;
+            png_uint_32 i;
+
+            sp = row + (png_size_t)((row_info->width - 1) >> 1);
+            dp = row + (png_size_t)((final_width - 1) >> 1);
+#if defined(PNG_READ_PACKSWAP_SUPPORTED)
+            if (transformations & PNG_PACKSWAP)
+            {
+               sshift = (png_size_t)(((row_info->width + 1) & 1) << 2);
+               dshift = (png_size_t)(((final_width + 1) & 1) << 2);
+               s_start = 4;
+               s_end = 0;
+               s_inc = -4;
+            }
+            else
+#endif
+            {
+               sshift = (png_size_t)((1 - ((row_info->width + 1) & 1)) << 2);
+               dshift = (png_size_t)((1 - ((final_width + 1) & 1)) << 2);
+               s_start = 0;
+               s_end = 4;
+               s_inc = 4;
+            }
+
+            for (i = row_info->width; i; i--)
+            {
+               png_byte v;
+               int j;
+
+               v = (png_byte)((*sp >> sshift) & 0xf);
+               for (j = 0; j < png_pass_inc[pass]; j++)
+               {
+                  *dp &= (png_byte)((0xf0f >> (4 - dshift)) & 0xff);
+                  *dp |= (png_byte)(v << dshift);
+                  if (dshift == s_end)
+                  {
+                     dshift = s_start;
+                     dp--;
+                  }
+                  else
+                     dshift += s_inc;
+               }
+               if (sshift == s_end)
+               {
+                  sshift = s_start;
+                  sp--;
+               }
+               else
+                  sshift += s_inc;
+            }
+            break;
+         }
+
+       /*====================================================================*/
+
+         default: /* 8-bit or larger (this is where the routine is modified) */
+         {
+#if 0
+//          static unsigned long long _const4 = 0x0000000000FFFFFFLL;  no good
+//          static unsigned long long const4 = 0x0000000000FFFFFFLL;   no good
+//          unsigned long long _const4 = 0x0000000000FFFFFFLL;         no good
+//          unsigned long long const4 = 0x0000000000FFFFFFLL;          no good
+#endif
+            png_bytep sptr, dp;
+            png_uint_32 i;
+            png_size_t pixel_bytes;
+            int width = (int)row_info->width;
+
+            pixel_bytes = (row_info->pixel_depth >> 3);
+
+            /* point sptr at the last pixel in the pre-expanded row: */
+            sptr = row + (width - 1) * pixel_bytes;
+
+            /* point dp at the last pixel position in the expanded row: */
+            dp = row + (final_width - 1) * pixel_bytes;
+
+            /* New code by Nirav Chhatrapati - Intel Corporation */
+
+#if defined(PNG_ASSEMBLER_CODE_SUPPORTED)
+#if !defined(PNG_1_0_X)
+            if ((png_ptr->asm_flags & PNG_ASM_FLAG_MMX_READ_INTERLACE)
+                /* && _mmx_supported */ )
+#else
+            if (_mmx_supported)
+#endif
+            {
+               //--------------------------------------------------------------
+               if (pixel_bytes == 3)
+               {
+                  if (((pass == 0) || (pass == 1)) && width)
+                  {
+                     int dummy_value_c;   // fix 'forbidden register spilled'
+                     int dummy_value_S;
+                     int dummy_value_D;
+
+                     __asm__ __volatile__ (
+                        "subl $21, %%edi         \n\t"
+                                     // (png_pass_inc[pass] - 1)*pixel_bytes
+
+                     ".loop3_pass0:              \n\t"
+                        "movd (%%esi), %%mm0     \n\t" // x x x x x 2 1 0
+                        "pand _const4, %%mm0     \n\t" // z z z z z 2 1 0
+                        "movq %%mm0, %%mm1       \n\t" // z z z z z 2 1 0
+                        "psllq $16, %%mm0        \n\t" // z z z 2 1 0 z z
+                        "movq %%mm0, %%mm2       \n\t" // z z z 2 1 0 z z
+                        "psllq $24, %%mm0        \n\t" // 2 1 0 z z z z z
+                        "psrlq $8, %%mm1         \n\t" // z z z z z z 2 1
+                        "por %%mm2, %%mm0        \n\t" // 2 1 0 2 1 0 z z
+                        "por %%mm1, %%mm0        \n\t" // 2 1 0 2 1 0 2 1
+                        "movq %%mm0, %%mm3       \n\t" // 2 1 0 2 1 0 2 1
+                        "psllq $16, %%mm0        \n\t" // 0 2 1 0 2 1 z z
+                        "movq %%mm3, %%mm4       \n\t" // 2 1 0 2 1 0 2 1
+                        "punpckhdq %%mm0, %%mm3  \n\t" // 0 2 1 0 2 1 0 2
+                        "movq %%mm4, 16(%%edi)   \n\t"
+                        "psrlq $32, %%mm0        \n\t" // z z z z 0 2 1 0
+                        "movq %%mm3, 8(%%edi)    \n\t"
+                        "punpckldq %%mm4, %%mm0  \n\t" // 1 0 2 1 0 2 1 0
+                        "subl $3, %%esi          \n\t"
+                        "movq %%mm0, (%%edi)     \n\t"
+                        "subl $24, %%edi         \n\t"
+                        "decl %%ecx              \n\t"
+                        "jnz .loop3_pass0        \n\t"
+                        "EMMS                    \n\t" // DONE
+
+                        : "=c" (dummy_value_c),        // output regs (dummy)
+                          "=S" (dummy_value_S),
+                          "=D" (dummy_value_D)
+
+                        : "1" (sptr),      // esi      // input regs
+                          "2" (dp),        // edi
+                          "0" (width)      // ecx
+// doesn't work           "i" (0x0000000000FFFFFFLL)   // %1 (a.k.a. _const4)
+
+#if 0  /* %mm0, ..., %mm4 not supported by gcc 2.7.2.3 or egcs 1.1 */
+                        : "%mm0", "%mm1", "%mm2"       // clobber list
+                        , "%mm3", "%mm4"
+#endif
+                     );
+                  }
+                  else if (((pass == 2) || (pass == 3)) && width)
+                  {
+                     int dummy_value_c;   // fix 'forbidden register spilled'
+                     int dummy_value_S;
+                     int dummy_value_D;
+
+                     __asm__ __volatile__ (
+                        "subl $9, %%edi          \n\t"
+                                     // (png_pass_inc[pass] - 1)*pixel_bytes
+
+                     ".loop3_pass2:              \n\t"
+                        "movd (%%esi), %%mm0     \n\t" // x x x x x 2 1 0
+                        "pand _const4, %%mm0     \n\t" // z z z z z 2 1 0
+                        "movq %%mm0, %%mm1       \n\t" // z z z z z 2 1 0
+                        "psllq $16, %%mm0        \n\t" // z z z 2 1 0 z z
+                        "movq %%mm0, %%mm2       \n\t" // z z z 2 1 0 z z
+                        "psllq $24, %%mm0        \n\t" // 2 1 0 z z z z z
+                        "psrlq $8, %%mm1         \n\t" // z z z z z z 2 1
+                        "por %%mm2, %%mm0        \n\t" // 2 1 0 2 1 0 z z
+                        "por %%mm1, %%mm0        \n\t" // 2 1 0 2 1 0 2 1
+                        "movq %%mm0, 4(%%edi)    \n\t"
+                        "psrlq $16, %%mm0        \n\t" // z z 2 1 0 2 1 0
+                        "subl $3, %%esi          \n\t"
+                        "movd %%mm0, (%%edi)     \n\t"
+                        "subl $12, %%edi         \n\t"
+                        "decl %%ecx              \n\t"
+                        "jnz .loop3_pass2        \n\t"
+                        "EMMS                    \n\t" // DONE
+
+                        : "=c" (dummy_value_c),        // output regs (dummy)
+                          "=S" (dummy_value_S),
+                          "=D" (dummy_value_D)
+
+                        : "1" (sptr),      // esi      // input regs
+                          "2" (dp),        // edi
+                          "0" (width)      // ecx
+
+#if 0  /* %mm0, ..., %mm2 not supported by gcc 2.7.2.3 or egcs 1.1 */
+                        : "%mm0", "%mm1", "%mm2"       // clobber list
+#endif
+                     );
+                  }
+                  else if (width) /* && ((pass == 4) || (pass == 5)) */
+                  {
+                     int width_mmx = ((width >> 1) << 1) - 8;   // GRR:  huh?
+                     if (width_mmx < 0)
+                         width_mmx = 0;
+                     width -= width_mmx;        // 8 or 9 pix, 24 or 27 bytes
+                     if (width_mmx)
+                     {
+                        // png_pass_inc[] = {8, 8, 4, 4, 2, 2, 1};
+                        // sptr points at last pixel in pre-expanded row
+                        // dp points at last pixel position in expanded row
+                        int dummy_value_c;  // fix 'forbidden register spilled'
+                        int dummy_value_S;
+                        int dummy_value_D;
+
+                        __asm__ __volatile__ (
+                           "subl $3, %%esi          \n\t"
+                           "subl $9, %%edi          \n\t"
+                                        // (png_pass_inc[pass] + 1)*pixel_bytes
+
+                        ".loop3_pass4:              \n\t"
+                           "movq (%%esi), %%mm0     \n\t" // x x 5 4 3 2 1 0
+                           "movq %%mm0, %%mm1       \n\t" // x x 5 4 3 2 1 0
+                           "movq %%mm0, %%mm2       \n\t" // x x 5 4 3 2 1 0
+                           "psllq $24, %%mm0        \n\t" // 4 3 2 1 0 z z z
+                           "pand _const4, %%mm1     \n\t" // z z z z z 2 1 0
+                           "psrlq $24, %%mm2        \n\t" // z z z x x 5 4 3
+                           "por %%mm1, %%mm0        \n\t" // 4 3 2 1 0 2 1 0
+                           "movq %%mm2, %%mm3       \n\t" // z z z x x 5 4 3
+                           "psllq $8, %%mm2         \n\t" // z z x x 5 4 3 z
+                           "movq %%mm0, (%%edi)     \n\t"
+                           "psrlq $16, %%mm3        \n\t" // z z z z z x x 5
+                           "pand _const6, %%mm3     \n\t" // z z z z z z z 5
+                           "por %%mm3, %%mm2        \n\t" // z z x x 5 4 3 5
+                           "subl $6, %%esi          \n\t"
+                           "movd %%mm2, 8(%%edi)    \n\t"
+                           "subl $12, %%edi         \n\t"
+                           "subl $2, %%ecx          \n\t"
+                           "jnz .loop3_pass4        \n\t"
+                           "EMMS                    \n\t" // DONE
+
+                           : "=c" (dummy_value_c),        // output regs (dummy)
+                             "=S" (dummy_value_S),
+                             "=D" (dummy_value_D)
+
+                           : "1" (sptr),      // esi      // input regs
+                             "2" (dp),        // edi
+                             "0" (width_mmx)  // ecx
+
+#if 0  /* %mm0, ..., %mm3 not supported by gcc 2.7.2.3 or egcs 1.1 */
+                           : "%mm0", "%mm1"               // clobber list
+                           , "%mm2", "%mm3"
+#endif
+                        );
+                     }
+
+                     sptr -= width_mmx*3;
+                     dp -= width_mmx*6;
+                     for (i = width; i; i--)
+                     {
+                        png_byte v[8];
+                        int j;
+
+                        png_memcpy(v, sptr, 3);
+                        for (j = 0; j < png_pass_inc[pass]; j++)
+                        {
+                           png_memcpy(dp, v, 3);
+                           dp -= 3;
+                        }
+                        sptr -= 3;
+                     }
+                  }
+               } /* end of pixel_bytes == 3 */
+
+               //--------------------------------------------------------------
+               else if (pixel_bytes == 1)
+               {
+                  if (((pass == 0) || (pass == 1)) && width)
+                  {
+                     int width_mmx = ((width >> 2) << 2);
+                     width -= width_mmx;        // 0-3 pixels => 0-3 bytes
+                     if (width_mmx)
+                     {
+                        int dummy_value_c;  // fix 'forbidden register spilled'
+                        int dummy_value_S;
+                        int dummy_value_D;
+
+                        __asm__ __volatile__ (
+                           "subl $3, %%esi          \n\t"
+                           "subl $31, %%edi         \n\t"
+
+                        ".loop1_pass0:              \n\t"
+                           "movd (%%esi), %%mm0     \n\t" // x x x x 3 2 1 0
+                           "movq %%mm0, %%mm1       \n\t" // x x x x 3 2 1 0
+                           "punpcklbw %%mm0, %%mm0  \n\t" // 3 3 2 2 1 1 0 0
+                           "movq %%mm0, %%mm2       \n\t" // 3 3 2 2 1 1 0 0
+                           "punpcklwd %%mm0, %%mm0  \n\t" // 1 1 1 1 0 0 0 0
+                           "movq %%mm0, %%mm3       \n\t" // 1 1 1 1 0 0 0 0
+                           "punpckldq %%mm0, %%mm0  \n\t" // 0 0 0 0 0 0 0 0
+                           "punpckhdq %%mm3, %%mm3  \n\t" // 1 1 1 1 1 1 1 1
+                           "movq %%mm0, (%%edi)     \n\t"
+                           "punpckhwd %%mm2, %%mm2  \n\t" // 3 3 3 3 2 2 2 2
+                           "movq %%mm3, 8(%%edi)    \n\t"
+                           "movq %%mm2, %%mm4       \n\t" // 3 3 3 3 2 2 2 2
+                           "punpckldq %%mm2, %%mm2  \n\t" // 2 2 2 2 2 2 2 2
+                           "punpckhdq %%mm4, %%mm4  \n\t" // 3 3 3 3 3 3 3 3
+                           "movq %%mm2, 16(%%edi)   \n\t"
+                           "subl $4, %%esi          \n\t"
+                           "movq %%mm4, 24(%%edi)   \n\t"
+                           "subl $32, %%edi         \n\t"
+                           "subl $4, %%ecx          \n\t"
+                           "jnz .loop1_pass0        \n\t"
+                           "EMMS                    \n\t" // DONE
+
+                           : "=c" (dummy_value_c),        // output regs (dummy)
+                             "=S" (dummy_value_S),
+                             "=D" (dummy_value_D)
+
+                           : "1" (sptr),      // esi      // input regs
+                             "2" (dp),        // edi
+                             "0" (width_mmx)  // ecx
+
+#if 0  /* %mm0, ..., %mm4 not supported by gcc 2.7.2.3 or egcs 1.1 */
+                           : "%mm0", "%mm1", "%mm2"       // clobber list
+                           , "%mm3", "%mm4"
+#endif
+                        );
+                     }
+
+                     sptr -= width_mmx;
+                     dp -= width_mmx*8;
+                     for (i = width; i; i--)
+                     {
+                        int j;
+
+                       /* I simplified this part in version 1.0.4e
+                        * here and in several other instances where
+                        * pixel_bytes == 1  -- GR-P
+                        *
+                        * Original code:
+                        *
+                        * png_byte v[8];
+                        * png_memcpy(v, sptr, pixel_bytes);
+                        * for (j = 0; j < png_pass_inc[pass]; j++)
+                        * {
+                        *    png_memcpy(dp, v, pixel_bytes);
+                        *    dp -= pixel_bytes;
+                        * }
+                        * sptr -= pixel_bytes;
+                        *
+                        * Replacement code is in the next three lines:
+                        */
+
+                        for (j = 0; j < png_pass_inc[pass]; j++)
+                        {
+                           *dp-- = *sptr;
+                        }
+                        --sptr;
+                     }
+                  }
+                  else if (((pass == 2) || (pass == 3)) && width)
+                  {
+                     int width_mmx = ((width >> 2) << 2);
+                     width -= width_mmx;        // 0-3 pixels => 0-3 bytes
+                     if (width_mmx)
+                     {
+                        int dummy_value_c;  // fix 'forbidden register spilled'
+                        int dummy_value_S;
+                        int dummy_value_D;
+
+                        __asm__ __volatile__ (
+                           "subl $3, %%esi          \n\t"
+                           "subl $15, %%edi         \n\t"
+
+                        ".loop1_pass2:              \n\t"
+                           "movd (%%esi), %%mm0     \n\t" // x x x x 3 2 1 0
+                           "punpcklbw %%mm0, %%mm0  \n\t" // 3 3 2 2 1 1 0 0
+                           "movq %%mm0, %%mm1       \n\t" // 3 3 2 2 1 1 0 0
+                           "punpcklwd %%mm0, %%mm0  \n\t" // 1 1 1 1 0 0 0 0
+                           "punpckhwd %%mm1, %%mm1  \n\t" // 3 3 3 3 2 2 2 2
+                           "movq %%mm0, (%%edi)     \n\t"
+                           "subl $4, %%esi          \n\t"
+                           "movq %%mm1, 8(%%edi)    \n\t"
+                           "subl $16, %%edi         \n\t"
+                           "subl $4, %%ecx          \n\t"
+                           "jnz .loop1_pass2        \n\t"
+                           "EMMS                    \n\t" // DONE
+
+                           : "=c" (dummy_value_c),        // output regs (dummy)
+                             "=S" (dummy_value_S),
+                             "=D" (dummy_value_D)
+
+                           : "1" (sptr),      // esi      // input regs
+                             "2" (dp),        // edi
+                             "0" (width_mmx)  // ecx
+
+#if 0  /* %mm0, %mm1 not supported by gcc 2.7.2.3 or egcs 1.1 */
+                           : "%mm0", "%mm1"               // clobber list
+#endif
+                        );
+                     }
+
+                     sptr -= width_mmx;
+                     dp -= width_mmx*4;
+                     for (i = width; i; i--)
+                     {
+                        int j;
+
+                        for (j = 0; j < png_pass_inc[pass]; j++)
+                        {
+                           *dp-- = *sptr;
+                        }
+                        --sptr;
+                     }
+                  }
+                  else if (width)  /* && ((pass == 4) || (pass == 5)) */
+                  {
+                     int width_mmx = ((width >> 3) << 3);
+                     width -= width_mmx;        // 0-3 pixels => 0-3 bytes
+                     if (width_mmx)
+                     {
+                        int dummy_value_c;  // fix 'forbidden register spilled'
+                        int dummy_value_S;
+                        int dummy_value_D;
+
+                        __asm__ __volatile__ (
+                           "subl $7, %%esi          \n\t"
+                           "subl $15, %%edi         \n\t"
+
+                        ".loop1_pass4:              \n\t"
+                           "movq (%%esi), %%mm0     \n\t" // 7 6 5 4 3 2 1 0
+                           "movq %%mm0, %%mm1       \n\t" // 7 6 5 4 3 2 1 0
+                           "punpcklbw %%mm0, %%mm0  \n\t" // 3 3 2 2 1 1 0 0
+                           "punpckhbw %%mm1, %%mm1  \n\t" // 7 7 6 6 5 5 4 4
+                           "movq %%mm1, 8(%%edi)    \n\t"
+                           "subl $8, %%esi          \n\t"
+                           "movq %%mm0, (%%edi)     \n\t"
+                           "subl $16, %%edi         \n\t"
+                           "subl $8, %%ecx          \n\t"
+                           "jnz .loop1_pass4        \n\t"
+                           "EMMS                    \n\t" // DONE
+
+                           : "=c" (dummy_value_c),        // output regs (none)
+                             "=S" (dummy_value_S),
+                             "=D" (dummy_value_D)
+
+                           : "1" (sptr),      // esi      // input regs
+                             "2" (dp),        // edi
+                             "0" (width_mmx)  // ecx
+
+#if 0  /* %mm0, %mm1 not supported by gcc 2.7.2.3 or egcs 1.1 */
+                           : "%mm0", "%mm1"               // clobber list
+#endif
+                        );
+                     }
+
+                     sptr -= width_mmx;
+                     dp -= width_mmx*2;
+                     for (i = width; i; i--)
+                     {
+                        int j;
+
+                        for (j = 0; j < png_pass_inc[pass]; j++)
+                        {
+                           *dp-- = *sptr;
+                        }
+                        --sptr;
+                     }
+                  }
+               } /* end of pixel_bytes == 1 */
+
+               //--------------------------------------------------------------
+               else if (pixel_bytes == 2)
+               {
+                  if (((pass == 0) || (pass == 1)) && width)
+                  {
+                     int width_mmx = ((width >> 1) << 1);
+                     width -= width_mmx;        // 0,1 pixels => 0,2 bytes
+                     if (width_mmx)
+                     {
+                        int dummy_value_c;  // fix 'forbidden register spilled'
+                        int dummy_value_S;
+                        int dummy_value_D;
+
+                        __asm__ __volatile__ (
+                           "subl $2, %%esi          \n\t"
+                           "subl $30, %%edi         \n\t"
+
+                        ".loop2_pass0:              \n\t"
+                           "movd (%%esi), %%mm0     \n\t" // x x x x 3 2 1 0
+                           "punpcklwd %%mm0, %%mm0  \n\t" // 3 2 3 2 1 0 1 0
+                           "movq %%mm0, %%mm1       \n\t" // 3 2 3 2 1 0 1 0
+                           "punpckldq %%mm0, %%mm0  \n\t" // 1 0 1 0 1 0 1 0
+                           "punpckhdq %%mm1, %%mm1  \n\t" // 3 2 3 2 3 2 3 2
+                           "movq %%mm0, (%%edi)     \n\t"
+                           "movq %%mm0, 8(%%edi)    \n\t"
+                           "movq %%mm1, 16(%%edi)   \n\t"
+                           "subl $4, %%esi          \n\t"
+                           "movq %%mm1, 24(%%edi)   \n\t"
+                           "subl $32, %%edi         \n\t"
+                           "subl $2, %%ecx          \n\t"
+                           "jnz .loop2_pass0        \n\t"
+                           "EMMS                    \n\t" // DONE
+
+                           : "=c" (dummy_value_c),        // output regs (dummy)
+                             "=S" (dummy_value_S),
+                             "=D" (dummy_value_D)
+
+                           : "1" (sptr),      // esi      // input regs
+                             "2" (dp),        // edi
+                             "0" (width_mmx)  // ecx
+
+#if 0  /* %mm0, %mm1 not supported by gcc 2.7.2.3 or egcs 1.1 */
+                           : "%mm0", "%mm1"               // clobber list
+#endif
+                        );
+                     }
+
+                     sptr -= (width_mmx*2 - 2); // sign fixed
+                     dp -= (width_mmx*16 - 2);  // sign fixed
+                     for (i = width; i; i--)
+                     {
+                        png_byte v[8];
+                        int j;
+                        sptr -= 2;
+                        png_memcpy(v, sptr, 2);
+                        for (j = 0; j < png_pass_inc[pass]; j++)
+                        {
+                           dp -= 2;
+                           png_memcpy(dp, v, 2);
+                        }
+                     }
+                  }
+                  else if (((pass == 2) || (pass == 3)) && width)
+                  {
+                     int width_mmx = ((width >> 1) << 1) ;
+                     width -= width_mmx;        // 0,1 pixels => 0,2 bytes
+                     if (width_mmx)
+                     {
+                        int dummy_value_c;  // fix 'forbidden register spilled'
+                        int dummy_value_S;
+                        int dummy_value_D;
+
+                        __asm__ __volatile__ (
+                           "subl $2, %%esi          \n\t"
+                           "subl $14, %%edi         \n\t"
+
+                        ".loop2_pass2:              \n\t"
+                           "movd (%%esi), %%mm0     \n\t" // x x x x 3 2 1 0
+                           "punpcklwd %%mm0, %%mm0  \n\t" // 3 2 3 2 1 0 1 0
+                           "movq %%mm0, %%mm1       \n\t" // 3 2 3 2 1 0 1 0
+                           "punpckldq %%mm0, %%mm0  \n\t" // 1 0 1 0 1 0 1 0
+                           "punpckhdq %%mm1, %%mm1  \n\t" // 3 2 3 2 3 2 3 2
+                           "movq %%mm0, (%%edi)     \n\t"
+                           "subl $4, %%esi          \n\t"
+                           "movq %%mm1, 8(%%edi)    \n\t"
+                           "subl $16, %%edi         \n\t"
+                           "subl $2, %%ecx          \n\t"
+                           "jnz .loop2_pass2        \n\t"
+                           "EMMS                    \n\t" // DONE
+
+                           : "=c" (dummy_value_c),        // output regs (dummy)
+                             "=S" (dummy_value_S),
+                             "=D" (dummy_value_D)
+
+                           : "1" (sptr),      // esi      // input regs
+                             "2" (dp),        // edi
+                             "0" (width_mmx)  // ecx
+
+#if 0  /* %mm0, %mm1 not supported by gcc 2.7.2.3 or egcs 1.1 */
+                           : "%mm0", "%mm1"               // clobber list
+#endif
+                        );
+                     }
+
+                     sptr -= (width_mmx*2 - 2); // sign fixed
+                     dp -= (width_mmx*8 - 2);   // sign fixed
+                     for (i = width; i; i--)
+                     {
+                        png_byte v[8];
+                        int j;
+                        sptr -= 2;
+                        png_memcpy(v, sptr, 2);
+                        for (j = 0; j < png_pass_inc[pass]; j++)
+                        {
+                           dp -= 2;
+                           png_memcpy(dp, v, 2);
+                        }
+                     }
+                  }
+                  else if (width)  // pass == 4 or 5
+                  {
+                     int width_mmx = ((width >> 1) << 1) ;
+                     width -= width_mmx;        // 0,1 pixels => 0,2 bytes
+                     if (width_mmx)
+                     {
+                        int dummy_value_c;  // fix 'forbidden register spilled'
+                        int dummy_value_S;
+                        int dummy_value_D;
+
+                        __asm__ __volatile__ (
+                           "subl $2, %%esi          \n\t"
+                           "subl $6, %%edi          \n\t"
+
+                        ".loop2_pass4:              \n\t"
+                           "movd (%%esi), %%mm0     \n\t" // x x x x 3 2 1 0
+                           "punpcklwd %%mm0, %%mm0  \n\t" // 3 2 3 2 1 0 1 0
+                           "subl $4, %%esi          \n\t"
+                           "movq %%mm0, (%%edi)     \n\t"
+                           "subl $8, %%edi          \n\t"
+                           "subl $2, %%ecx          \n\t"
+                           "jnz .loop2_pass4        \n\t"
+                           "EMMS                    \n\t" // DONE
+
+                           : "=c" (dummy_value_c),        // output regs (dummy)
+                             "=S" (dummy_value_S),
+                             "=D" (dummy_value_D)
+
+                           : "1" (sptr),      // esi      // input regs
+                             "2" (dp),        // edi
+                             "0" (width_mmx)  // ecx
+
+#if 0  /* %mm0 not supported by gcc 2.7.2.3 or egcs 1.1 */
+                           : "%mm0"                       // clobber list
+#endif
+                        );
+                     }
+
+                     sptr -= (width_mmx*2 - 2); // sign fixed
+                     dp -= (width_mmx*4 - 2);   // sign fixed
+                     for (i = width; i; i--)
+                     {
+                        png_byte v[8];
+                        int j;
+                        sptr -= 2;
+                        png_memcpy(v, sptr, 2);
+                        for (j = 0; j < png_pass_inc[pass]; j++)
+                        {
+                           dp -= 2;
+                           png_memcpy(dp, v, 2);
+                        }
+                     }
+                  }
+               } /* end of pixel_bytes == 2 */
+
+               //--------------------------------------------------------------
+               else if (pixel_bytes == 4)
+               {
+                  if (((pass == 0) || (pass == 1)) && width)
+                  {
+                     int width_mmx = ((width >> 1) << 1);
+                     width -= width_mmx;        // 0,1 pixels => 0,4 bytes
+                     if (width_mmx)
+                     {
+                        int dummy_value_c;  // fix 'forbidden register spilled'
+                        int dummy_value_S;
+                        int dummy_value_D;
+
+                        __asm__ __volatile__ (
+                           "subl $4, %%esi          \n\t"
+                           "subl $60, %%edi         \n\t"
+
+                        ".loop4_pass0:              \n\t"
+                           "movq (%%esi), %%mm0     \n\t" // 7 6 5 4 3 2 1 0
+                           "movq %%mm0, %%mm1       \n\t" // 7 6 5 4 3 2 1 0
+                           "punpckldq %%mm0, %%mm0  \n\t" // 3 2 1 0 3 2 1 0
+                           "punpckhdq %%mm1, %%mm1  \n\t" // 7 6 5 4 7 6 5 4
+                           "movq %%mm0, (%%edi)     \n\t"
+                           "movq %%mm0, 8(%%edi)    \n\t"
+                           "movq %%mm0, 16(%%edi)   \n\t"
+                           "movq %%mm0, 24(%%edi)   \n\t"
+                           "movq %%mm1, 32(%%edi)   \n\t"
+                           "movq %%mm1, 40(%%edi)   \n\t"
+                           "movq %%mm1, 48(%%edi)   \n\t"
+                           "subl $8, %%esi          \n\t"
+                           "movq %%mm1, 56(%%edi)   \n\t"
+                           "subl $64, %%edi         \n\t"
+                           "subl $2, %%ecx          \n\t"
+                           "jnz .loop4_pass0        \n\t"
+                           "EMMS                    \n\t" // DONE
+
+                           : "=c" (dummy_value_c),        // output regs (dummy)
+                             "=S" (dummy_value_S),
+                             "=D" (dummy_value_D)
+
+                           : "1" (sptr),      // esi      // input regs
+                             "2" (dp),        // edi
+                             "0" (width_mmx)  // ecx
+
+#if 0  /* %mm0, %mm1 not supported by gcc 2.7.2.3 or egcs 1.1 */
+                           : "%mm0", "%mm1"               // clobber list
+#endif
+                        );
+                     }
+
+                     sptr -= (width_mmx*4 - 4); // sign fixed
+                     dp -= (width_mmx*32 - 4);  // sign fixed
+                     for (i = width; i; i--)
+                     {
+                        png_byte v[8];
+                        int j;
+                        sptr -= 4;
+                        png_memcpy(v, sptr, 4);
+                        for (j = 0; j < png_pass_inc[pass]; j++)
+                        {
+                           dp -= 4;
+                           png_memcpy(dp, v, 4);
+                        }
+                     }
+                  }
+                  else if (((pass == 2) || (pass == 3)) && width)
+                  {
+                     int width_mmx = ((width >> 1) << 1);
+                     width -= width_mmx;        // 0,1 pixels => 0,4 bytes
+                     if (width_mmx)
+                     {
+                        int dummy_value_c;  // fix 'forbidden register spilled'
+                        int dummy_value_S;
+                        int dummy_value_D;
+
+                        __asm__ __volatile__ (
+                           "subl $4, %%esi          \n\t"
+                           "subl $28, %%edi         \n\t"
+
+                        ".loop4_pass2:              \n\t"
+                           "movq (%%esi), %%mm0     \n\t" // 7 6 5 4 3 2 1 0
+                           "movq %%mm0, %%mm1       \n\t" // 7 6 5 4 3 2 1 0
+                           "punpckldq %%mm0, %%mm0  \n\t" // 3 2 1 0 3 2 1 0
+                           "punpckhdq %%mm1, %%mm1  \n\t" // 7 6 5 4 7 6 5 4
+                           "movq %%mm0, (%%edi)     \n\t"
+                           "movq %%mm0, 8(%%edi)    \n\t"
+                           "movq %%mm1, 16(%%edi)   \n\t"
+                           "movq %%mm1, 24(%%edi)   \n\t"
+                           "subl $8, %%esi          \n\t"
+                           "subl $32, %%edi         \n\t"
+                           "subl $2, %%ecx          \n\t"
+                           "jnz .loop4_pass2        \n\t"
+                           "EMMS                    \n\t" // DONE
+
+                           : "=c" (dummy_value_c),        // output regs (dummy)
+                             "=S" (dummy_value_S),
+                             "=D" (dummy_value_D)
+
+                           : "1" (sptr),      // esi      // input regs
+                             "2" (dp),        // edi
+                             "0" (width_mmx)  // ecx
+
+#if 0  /* %mm0, %mm1 not supported by gcc 2.7.2.3 or egcs 1.1 */
+                           : "%mm0", "%mm1"               // clobber list
+#endif
+                        );
+                     }
+
+                     sptr -= (width_mmx*4 - 4); // sign fixed
+                     dp -= (width_mmx*16 - 4);  // sign fixed
+                     for (i = width; i; i--)
+                     {
+                        png_byte v[8];
+                        int j;
+                        sptr -= 4;
+                        png_memcpy(v, sptr, 4);
+                        for (j = 0; j < png_pass_inc[pass]; j++)
+                        {
+                           dp -= 4;
+                           png_memcpy(dp, v, 4);
+                        }
+                     }
+                  }
+                  else if (width)  // pass == 4 or 5
+                  {
+                     int width_mmx = ((width >> 1) << 1) ;
+                     width -= width_mmx;        // 0,1 pixels => 0,4 bytes
+                     if (width_mmx)
+                     {
+                        int dummy_value_c;  // fix 'forbidden register spilled'
+                        int dummy_value_S;
+                        int dummy_value_D;
+
+                        __asm__ __volatile__ (
+                           "subl $4, %%esi          \n\t"
+                           "subl $12, %%edi         \n\t"
+
+                        ".loop4_pass4:              \n\t"
+                           "movq (%%esi), %%mm0     \n\t" // 7 6 5 4 3 2 1 0
+                           "movq %%mm0, %%mm1       \n\t" // 7 6 5 4 3 2 1 0
+                           "punpckldq %%mm0, %%mm0  \n\t" // 3 2 1 0 3 2 1 0
+                           "punpckhdq %%mm1, %%mm1  \n\t" // 7 6 5 4 7 6 5 4
+                           "movq %%mm0, (%%edi)     \n\t"
+                           "subl $8, %%esi          \n\t"
+                           "movq %%mm1, 8(%%edi)    \n\t"
+                           "subl $16, %%edi         \n\t"
+                           "subl $2, %%ecx          \n\t"
+                           "jnz .loop4_pass4        \n\t"
+                           "EMMS                    \n\t" // DONE
+
+                           : "=c" (dummy_value_c),        // output regs (dummy)
+                             "=S" (dummy_value_S),
+                             "=D" (dummy_value_D)
+
+                           : "1" (sptr),      // esi      // input regs
+                             "2" (dp),        // edi
+                             "0" (width_mmx)  // ecx
+
+#if 0  /* %mm0, %mm1 not supported by gcc 2.7.2.3 or egcs 1.1 */
+                           : "%mm0", "%mm1"               // clobber list
+#endif
+                        );
+                     }
+
+                     sptr -= (width_mmx*4 - 4); // sign fixed
+                     dp -= (width_mmx*8 - 4);   // sign fixed
+                     for (i = width; i; i--)
+                     {
+                        png_byte v[8];
+                        int j;
+                        sptr -= 4;
+                        png_memcpy(v, sptr, 4);
+                        for (j = 0; j < png_pass_inc[pass]; j++)
+                        {
+                           dp -= 4;
+                           png_memcpy(dp, v, 4);
+                        }
+                     }
+                  }
+               } /* end of pixel_bytes == 4 */
+
+               //--------------------------------------------------------------
+               else if (pixel_bytes == 8)
+               {
+// GRR TEST:  should work, but needs testing (special 64-bit version of rpng2?)
+                  // GRR NOTE:  no need to combine passes here!
+                  if (((pass == 0) || (pass == 1)) && width)
+                  {
+                     int dummy_value_c;  // fix 'forbidden register spilled'
+                     int dummy_value_S;
+                     int dummy_value_D;
+
+                     // source is 8-byte RRGGBBAA
+                     // dest is 64-byte RRGGBBAA RRGGBBAA RRGGBBAA RRGGBBAA ...
+                     __asm__ __volatile__ (
+                        "subl $56, %%edi         \n\t" // start of last block
+
+                     ".loop8_pass0:              \n\t"
+                        "movq (%%esi), %%mm0     \n\t" // 7 6 5 4 3 2 1 0
+                        "movq %%mm0, (%%edi)     \n\t"
+                        "movq %%mm0, 8(%%edi)    \n\t"
+                        "movq %%mm0, 16(%%edi)   \n\t"
+                        "movq %%mm0, 24(%%edi)   \n\t"
+                        "movq %%mm0, 32(%%edi)   \n\t"
+                        "movq %%mm0, 40(%%edi)   \n\t"
+                        "movq %%mm0, 48(%%edi)   \n\t"
+                        "subl $8, %%esi          \n\t"
+                        "movq %%mm0, 56(%%edi)   \n\t"
+                        "subl $64, %%edi         \n\t"
+                        "decl %%ecx              \n\t"
+                        "jnz .loop8_pass0        \n\t"
+                        "EMMS                    \n\t" // DONE
+
+                        : "=c" (dummy_value_c),        // output regs (dummy)
+                          "=S" (dummy_value_S),
+                          "=D" (dummy_value_D)
+
+                        : "1" (sptr),      // esi      // input regs
+                          "2" (dp),        // edi
+                          "0" (width)      // ecx
+
+#if 0  /* %mm0 not supported by gcc 2.7.2.3 or egcs 1.1 */
+                        : "%mm0"                       // clobber list
+#endif
+                     );
+                  }
+                  else if (((pass == 2) || (pass == 3)) && width)
+                  {
+                     // source is 8-byte RRGGBBAA
+                     // dest is 32-byte RRGGBBAA RRGGBBAA RRGGBBAA RRGGBBAA
+                     // (recall that expansion is _in place_:  sptr and dp
+                     //  both point at locations within same row buffer)
+                     {
+                        int dummy_value_c;  // fix 'forbidden register spilled'
+                        int dummy_value_S;
+                        int dummy_value_D;
+
+                        __asm__ __volatile__ (
+                           "subl $24, %%edi         \n\t" // start of last block
+
+                        ".loop8_pass2:              \n\t"
+                           "movq (%%esi), %%mm0     \n\t" // 7 6 5 4 3 2 1 0
+                           "movq %%mm0, (%%edi)     \n\t"
+                           "movq %%mm0, 8(%%edi)    \n\t"
+                           "movq %%mm0, 16(%%edi)   \n\t"
+                           "subl $8, %%esi          \n\t"
+                           "movq %%mm0, 24(%%edi)   \n\t"
+                           "subl $32, %%edi         \n\t"
+                           "decl %%ecx              \n\t"
+                           "jnz .loop8_pass2        \n\t"
+                           "EMMS                    \n\t" // DONE
+
+                           : "=c" (dummy_value_c),        // output regs (dummy)
+                             "=S" (dummy_value_S),
+                             "=D" (dummy_value_D)
+
+                           : "1" (sptr),      // esi      // input regs
+                             "2" (dp),        // edi
+                             "0" (width)      // ecx
+
+#if 0  /* %mm0 not supported by gcc 2.7.2.3 or egcs 1.1 */
+                           : "%mm0"                       // clobber list
+#endif
+                        );
+                     }
+                  }
+                  else if (width)  // pass == 4 or 5
+                  {
+                     // source is 8-byte RRGGBBAA
+                     // dest is 16-byte RRGGBBAA RRGGBBAA
+                     {
+                        int dummy_value_c;  // fix 'forbidden register spilled'
+                        int dummy_value_S;
+                        int dummy_value_D;
+
+                        __asm__ __volatile__ (
+                           "subl $8, %%edi          \n\t" // start of last block
+
+                        ".loop8_pass4:              \n\t"
+                           "movq (%%esi), %%mm0     \n\t" // 7 6 5 4 3 2 1 0
+                           "movq %%mm0, (%%edi)     \n\t"
+                           "subl $8, %%esi          \n\t"
+                           "movq %%mm0, 8(%%edi)    \n\t"
+                           "subl $16, %%edi         \n\t"
+                           "decl %%ecx              \n\t"
+                           "jnz .loop8_pass4        \n\t"
+                           "EMMS                    \n\t" // DONE
+
+                           : "=c" (dummy_value_c),        // output regs (dummy)
+                             "=S" (dummy_value_S),
+                             "=D" (dummy_value_D)
+
+                           : "1" (sptr),      // esi      // input regs
+                             "2" (dp),        // edi
+                             "0" (width)      // ecx
+
+#if 0  /* %mm0 not supported by gcc 2.7.2.3 or egcs 1.1 */
+                           : "%mm0"                       // clobber list
+#endif
+                        );
+                     }
+                  }
+
+               } /* end of pixel_bytes == 8 */
+
+               //--------------------------------------------------------------
+               else if (pixel_bytes == 6)
+               {
+                  for (i = width; i; i--)
+                  {
+                     png_byte v[8];
+                     int j;
+                     png_memcpy(v, sptr, 6);
+                     for (j = 0; j < png_pass_inc[pass]; j++)
+                     {
+                        png_memcpy(dp, v, 6);
+                        dp -= 6;
+                     }
+                     sptr -= 6;
+                  }
+               } /* end of pixel_bytes == 6 */
+
+               //--------------------------------------------------------------
+               else
+               {
+                  for (i = width; i; i--)
+                  {
+                     png_byte v[8];
+                     int j;
+                     png_memcpy(v, sptr, pixel_bytes);
+                     for (j = 0; j < png_pass_inc[pass]; j++)
+                     {
+                        png_memcpy(dp, v, pixel_bytes);
+                        dp -= pixel_bytes;
+                     }
+                     sptr-= pixel_bytes;
+                  }
+               }
+            } // end of _mmx_supported ========================================
+
+            else /* MMX not supported:  use modified C code - takes advantage
+                  *   of inlining of png_memcpy for a constant */
+                 /* GRR 19991007:  does it?  or should pixel_bytes in each
+                  *   block be replaced with immediate value (e.g., 1)? */
+                 /* GRR 19991017:  replaced with constants in each case */
+#endif /* PNG_ASSEMBLER_CODE_SUPPORTED */
+            {
+               if (pixel_bytes == 1)
+               {
+                  for (i = width; i; i--)
+                  {
+                     int j;
+                     for (j = 0; j < png_pass_inc[pass]; j++)
+                     {
+                        *dp-- = *sptr;
+                     }
+                     --sptr;
+                  }
+               }
+               else if (pixel_bytes == 3)
+               {
+                  for (i = width; i; i--)
+                  {
+                     png_byte v[8];
+                     int j;
+                     png_memcpy(v, sptr, 3);
+                     for (j = 0; j < png_pass_inc[pass]; j++)
+                     {
+                        png_memcpy(dp, v, 3);
+                        dp -= 3;
+                     }
+                     sptr -= 3;
+                  }
+               }
+               else if (pixel_bytes == 2)
+               {
+                  for (i = width; i; i--)
+                  {
+                     png_byte v[8];
+                     int j;
+                     png_memcpy(v, sptr, 2);
+                     for (j = 0; j < png_pass_inc[pass]; j++)
+                     {
+                        png_memcpy(dp, v, 2);
+                        dp -= 2;
+                     }
+                     sptr -= 2;
+                  }
+               }
+               else if (pixel_bytes == 4)
+               {
+                  for (i = width; i; i--)
+                  {
+                     png_byte v[8];
+                     int j;
+                     png_memcpy(v, sptr, 4);
+                     for (j = 0; j < png_pass_inc[pass]; j++)
+                     {
+#ifdef PNG_DEBUG
+                        if (dp < row || dp+3 > row+png_ptr->row_buf_size)
+                        {
+                           printf("dp out of bounds: row=%d, dp=%d, rp=%d\n",
+                             row, dp, row+png_ptr->row_buf_size);
+                           printf("row_buf=%d\n",png_ptr->row_buf_size);
+                        }
+#endif
+                        png_memcpy(dp, v, 4);
+                        dp -= 4;
+                     }
+                     sptr -= 4;
+                  }
+               }
+               else if (pixel_bytes == 6)
+               {
+                  for (i = width; i; i--)
+                  {
+                     png_byte v[8];
+                     int j;
+                     png_memcpy(v, sptr, 6);
+                     for (j = 0; j < png_pass_inc[pass]; j++)
+                     {
+                        png_memcpy(dp, v, 6);
+                        dp -= 6;
+                     }
+                     sptr -= 6;
+                  }
+               }
+               else if (pixel_bytes == 8)
+               {
+                  for (i = width; i; i--)
+                  {
+                     png_byte v[8];
+                     int j;
+                     png_memcpy(v, sptr, 8);
+                     for (j = 0; j < png_pass_inc[pass]; j++)
+                     {
+                        png_memcpy(dp, v, 8);
+                        dp -= 8;
+                     }
+                     sptr -= 8;
+                  }
+               }
+               else     /* GRR:  should never be reached */
+               {
+                  for (i = width; i; i--)
+                  {
+                     png_byte v[8];
+                     int j;
+                     png_memcpy(v, sptr, pixel_bytes);
+                     for (j = 0; j < png_pass_inc[pass]; j++)
+                     {
+                        png_memcpy(dp, v, pixel_bytes);
+                        dp -= pixel_bytes;
+                     }
+                     sptr -= pixel_bytes;
+                  }
+               }
+
+            } /* end if (MMX not supported) */
+            break;
+         }
+      } /* end switch (row_info->pixel_depth) */
+
+      row_info->width = final_width;
+      row_info->rowbytes = ((final_width *
+         (png_uint_32)row_info->pixel_depth + 7) >> 3);
+   }
+
+} /* end png_do_read_interlace() */
+
+#endif /* PNG_HAVE_ASSEMBLER_READ_INTERLACE */
+#endif /* PNG_READ_INTERLACING_SUPPORTED */
+
+
+
+#if defined(PNG_HAVE_ASSEMBLER_READ_FILTER_ROW)
+#if defined(PNG_ASSEMBLER_CODE_SUPPORTED)
+
+// These variables are utilized in the functions below.  They are declared
+// globally here to ensure alignment on 8-byte boundaries.
+
+union uAll {
+   long long use;
+   double  align;
+} _LBCarryMask = {0x0101010101010101LL},
+  _HBClearMask = {0x7f7f7f7f7f7f7f7fLL},
+  _ActiveMask, _ActiveMask2, _ActiveMaskEnd, _ShiftBpp, _ShiftRem;
+
+#ifdef PNG_THREAD_UNSAFE_OK
+//===========================================================================//
+//                                                                           //
+//           P N G _ R E A D _ F I L T E R _ R O W _ M M X _ A V G           //
+//                                                                           //
+//===========================================================================//
+
+// Optimized code for PNG Average filter decoder
+
+static void /* PRIVATE */
+png_read_filter_row_mmx_avg(png_row_infop row_info, png_bytep row,
+                            png_bytep prev_row)
+{
+   int bpp;
+   int dummy_value_c;   // fix 'forbidden register 2 (cx) was spilled' error
+   int dummy_value_S;
+   int dummy_value_D;
+
+   bpp = (row_info->pixel_depth + 7) >> 3;  // get # bytes per pixel
+   _FullLength  = row_info->rowbytes;       // # of bytes to filter
+
+   __asm__ __volatile__ (
+      // initialize address pointers and offset
+#ifdef __PIC__
+      "pushl %%ebx                 \n\t" // save index to Global Offset Table
+#endif
+//pre "movl row, %%edi             \n\t" // edi:  Avg(x)
+      "xorl %%ebx, %%ebx           \n\t" // ebx:  x
+      "movl %%edi, %%edx           \n\t"
+//pre "movl prev_row, %%esi        \n\t" // esi:  Prior(x)
+//pre "subl bpp, %%edx             \n\t" // (bpp is preloaded into ecx)
+      "subl %%ecx, %%edx           \n\t" // edx:  Raw(x-bpp)
+
+      "xorl %%eax,%%eax            \n\t"
+
+      // Compute the Raw value for the first bpp bytes
+      //    Raw(x) = Avg(x) + (Prior(x)/2)
+   "avg_rlp:                       \n\t"
+      "movb (%%esi,%%ebx,),%%al    \n\t" // load al with Prior(x)
+      "incl %%ebx                  \n\t"
+      "shrb %%al                   \n\t" // divide by 2
+      "addb -1(%%edi,%%ebx,),%%al  \n\t" // add Avg(x); -1 to offset inc ebx
+//pre "cmpl bpp, %%ebx             \n\t" // (bpp is preloaded into ecx)
+      "cmpl %%ecx, %%ebx           \n\t"
+      "movb %%al,-1(%%edi,%%ebx,)  \n\t" // write Raw(x); -1 to offset inc ebx
+      "jb avg_rlp                  \n\t" // mov does not affect flags
+
+      // get # of bytes to alignment
+      "movl %%edi, _dif            \n\t" // take start of row
+      "addl %%ebx, _dif            \n\t" // add bpp
+      "addl $0xf, _dif             \n\t" // add 7+8 to incr past alignment bdry
+      "andl $0xfffffff8, _dif      \n\t" // mask to alignment boundary
+      "subl %%edi, _dif            \n\t" // subtract from start => value ebx at
+      "jz avg_go                   \n\t" //  alignment
+
+      // fix alignment
+      // Compute the Raw value for the bytes up to the alignment boundary
+      //    Raw(x) = Avg(x) + ((Raw(x-bpp) + Prior(x))/2)
+      "xorl %%ecx, %%ecx           \n\t"
+
+   "avg_lp1:                       \n\t"
+      "xorl %%eax, %%eax           \n\t"
+      "movb (%%esi,%%ebx,), %%cl   \n\t" // load cl with Prior(x)
+      "movb (%%edx,%%ebx,), %%al   \n\t" // load al with Raw(x-bpp)
+      "addw %%cx, %%ax             \n\t"
+      "incl %%ebx                  \n\t"
+      "shrw %%ax                   \n\t" // divide by 2
+      "addb -1(%%edi,%%ebx,), %%al \n\t" // add Avg(x); -1 to offset inc ebx
+      "cmpl _dif, %%ebx            \n\t" // check if at alignment boundary
+      "movb %%al, -1(%%edi,%%ebx,) \n\t" // write Raw(x); -1 to offset inc ebx
+      "jb avg_lp1                  \n\t" // repeat until at alignment boundary
+
+   "avg_go:                        \n\t"
+      "movl _FullLength, %%eax     \n\t"
+      "movl %%eax, %%ecx           \n\t"
+      "subl %%ebx, %%eax           \n\t" // subtract alignment fix
+      "andl $0x00000007, %%eax     \n\t" // calc bytes over mult of 8
+      "subl %%eax, %%ecx           \n\t" // drop over bytes from original length
+      "movl %%ecx, _MMXLength      \n\t"
+#ifdef __PIC__
+      "popl %%ebx                  \n\t" // restore index to Global Offset Table
+#endif
+
+      : "=c" (dummy_value_c),            // output regs (dummy)
+        "=S" (dummy_value_S),
+        "=D" (dummy_value_D)
+
+      : "0" (bpp),       // ecx          // input regs
+        "1" (prev_row),  // esi
+        "2" (row)        // edi
+
+      : "%eax", "%edx"                   // clobber list
+#ifndef __PIC__
+      , "%ebx"
+#endif
+      // GRR: INCLUDE "memory" as clobbered? (_dif, _MMXLength)
+      // (seems to work fine without...)
+   );
+
+   // now do the math for the rest of the row
+   switch (bpp)
+   {
+      case 3:
+      {
+         _ActiveMask.use  = 0x0000000000ffffffLL;
+         _ShiftBpp.use = 24;    // == 3 * 8
+         _ShiftRem.use = 40;    // == 64 - 24
+
+         __asm__ __volatile__ (
+            // re-init address pointers and offset
+            "movq _ActiveMask, %%mm7      \n\t"
+            "movl _dif, %%ecx             \n\t" // ecx:  x = offset to
+            "movq _LBCarryMask, %%mm5     \n\t" //  alignment boundary
+// preload  "movl row, %%edi              \n\t" // edi:  Avg(x)
+            "movq _HBClearMask, %%mm4     \n\t"
+// preload  "movl prev_row, %%esi         \n\t" // esi:  Prior(x)
+
+            // prime the pump:  load the first Raw(x-bpp) data set
+            "movq -8(%%edi,%%ecx,), %%mm2 \n\t" // load previous aligned 8 bytes
+                                                // (correct pos. in loop below)
+         "avg_3lp:                        \n\t"
+            "movq (%%edi,%%ecx,), %%mm0   \n\t" // load mm0 with Avg(x)
+            "movq %%mm5, %%mm3            \n\t"
+            "psrlq _ShiftRem, %%mm2       \n\t" // correct position Raw(x-bpp)
+                                                // data
+            "movq (%%esi,%%ecx,), %%mm1   \n\t" // load mm1 with Prior(x)
+            "movq %%mm7, %%mm6            \n\t"
+            "pand %%mm1, %%mm3            \n\t" // get lsb for each prev_row byte
+            "psrlq $1, %%mm1              \n\t" // divide prev_row bytes by 2
+            "pand  %%mm4, %%mm1           \n\t" // clear invalid bit 7 of each
+                                                // byte
+            "paddb %%mm1, %%mm0           \n\t" // add (Prev_row/2) to Avg for
+                                                // each byte
+            // add 1st active group (Raw(x-bpp)/2) to average with LBCarry
+            "movq %%mm3, %%mm1            \n\t" // now use mm1 for getting
+                                                // LBCarrys
+            "pand %%mm2, %%mm1            \n\t" // get LBCarrys for each byte
+                                                // where both
+                               // lsb's were == 1 (only valid for active group)
+            "psrlq $1, %%mm2              \n\t" // divide raw bytes by 2
+            "pand  %%mm4, %%mm2           \n\t" // clear invalid bit 7 of each
+                                                // byte
+            "paddb %%mm1, %%mm2           \n\t" // add LBCarrys to (Raw(x-bpp)/2)
+                                                // for each byte
+            "pand %%mm6, %%mm2            \n\t" // leave only Active Group 1
+                                                // bytes to add to Avg
+            "paddb %%mm2, %%mm0           \n\t" // add (Raw/2) + LBCarrys to
+                                                // Avg for each Active
+                               //  byte
+            // add 2nd active group (Raw(x-bpp)/2) to average with _LBCarry
+            "psllq _ShiftBpp, %%mm6       \n\t" // shift the mm6 mask to cover
+                                                // bytes 3-5
+            "movq %%mm0, %%mm2            \n\t" // mov updated Raws to mm2
+            "psllq _ShiftBpp, %%mm2       \n\t" // shift data to pos. correctly
+            "movq %%mm3, %%mm1            \n\t" // now use mm1 for getting
+                                                // LBCarrys
+            "pand %%mm2, %%mm1            \n\t" // get LBCarrys for each byte
+                                                // where both
+                               // lsb's were == 1 (only valid for active group)
+            "psrlq $1, %%mm2              \n\t" // divide raw bytes by 2
+            "pand  %%mm4, %%mm2           \n\t" // clear invalid bit 7 of each
+                                                // byte
+            "paddb %%mm1, %%mm2           \n\t" // add LBCarrys to (Raw(x-bpp)/2)
+                                                // for each byte
+            "pand %%mm6, %%mm2            \n\t" // leave only Active Group 2
+                                                // bytes to add to Avg
+            "paddb %%mm2, %%mm0           \n\t" // add (Raw/2) + LBCarrys to
+                                                // Avg for each Active
+                               //  byte
+
+            // add 3rd active group (Raw(x-bpp)/2) to average with _LBCarry
+            "psllq _ShiftBpp, %%mm6       \n\t" // shift mm6 mask to cover last
+                                                // two
+                                 // bytes
+            "movq %%mm0, %%mm2            \n\t" // mov updated Raws to mm2
+            "psllq _ShiftBpp, %%mm2       \n\t" // shift data to pos. correctly
+                              // Data only needs to be shifted once here to
+                              // get the correct x-bpp offset.
+            "movq %%mm3, %%mm1            \n\t" // now use mm1 for getting
+                                                // LBCarrys
+            "pand %%mm2, %%mm1            \n\t" // get LBCarrys for each byte
+                                                // where both
+                              // lsb's were == 1 (only valid for active group)
+            "psrlq $1, %%mm2              \n\t" // divide raw bytes by 2
+            "pand  %%mm4, %%mm2           \n\t" // clear invalid bit 7 of each
+                                                // byte
+            "paddb %%mm1, %%mm2           \n\t" // add LBCarrys to (Raw(x-bpp)/2)
+                                                // for each byte
+            "pand %%mm6, %%mm2            \n\t" // leave only Active Group 2
+                                                // bytes to add to Avg
+            "addl $8, %%ecx               \n\t"
+            "paddb %%mm2, %%mm0           \n\t" // add (Raw/2) + LBCarrys to
+                                                // Avg for each Active
+                                                // byte
+            // now ready to write back to memory
+            "movq %%mm0, -8(%%edi,%%ecx,) \n\t"
+            // move updated Raw(x) to use as Raw(x-bpp) for next loop
+            "cmpl _MMXLength, %%ecx       \n\t"
+            "movq %%mm0, %%mm2            \n\t" // mov updated Raw(x) to mm2
+            "jb avg_3lp                   \n\t"
+
+            : "=S" (dummy_value_S),             // output regs (dummy)
+              "=D" (dummy_value_D)
+
+            : "0" (prev_row),  // esi           // input regs
+              "1" (row)        // edi
+
+            : "%ecx"                            // clobber list
+#if 0  /* %mm0, ..., %mm7 not supported by gcc 2.7.2.3 or egcs 1.1 */
+            , "%mm0", "%mm1", "%mm2", "%mm3"
+            , "%mm4", "%mm5", "%mm6", "%mm7"
+#endif
+         );
+      }
+      break;  // end 3 bpp
+
+      case 6:
+      case 4:
+      //case 7:   // who wrote this?  PNG doesn't support 5 or 7 bytes/pixel
+      //case 5:   // GRR BOGUS
+      {
+         _ActiveMask.use  = 0xffffffffffffffffLL; // use shift below to clear
+                                                  // appropriate inactive bytes
+         _ShiftBpp.use = bpp << 3;
+         _ShiftRem.use = 64 - _ShiftBpp.use;
+
+         __asm__ __volatile__ (
+            "movq _HBClearMask, %%mm4    \n\t"
+
+            // re-init address pointers and offset
+            "movl _dif, %%ecx            \n\t" // ecx:  x = offset to
+                                               // alignment boundary
+
+            // load _ActiveMask and clear all bytes except for 1st active group
+            "movq _ActiveMask, %%mm7     \n\t"
+// preload  "movl row, %%edi             \n\t" // edi:  Avg(x)
+            "psrlq _ShiftRem, %%mm7      \n\t"
+// preload  "movl prev_row, %%esi        \n\t" // esi:  Prior(x)
+            "movq %%mm7, %%mm6           \n\t"
+            "movq _LBCarryMask, %%mm5    \n\t"
+            "psllq _ShiftBpp, %%mm6      \n\t" // create mask for 2nd active
+                                               // group
+
+            // prime the pump:  load the first Raw(x-bpp) data set
+            "movq -8(%%edi,%%ecx,), %%mm2 \n\t" // load previous aligned 8 bytes
+                                          // (we correct pos. in loop below)
+         "avg_4lp:                       \n\t"
+            "movq (%%edi,%%ecx,), %%mm0  \n\t"
+            "psrlq _ShiftRem, %%mm2      \n\t" // shift data to pos. correctly
+            "movq (%%esi,%%ecx,), %%mm1  \n\t"
+            // add (Prev_row/2) to average
+            "movq %%mm5, %%mm3           \n\t"
+            "pand %%mm1, %%mm3           \n\t" // get lsb for each prev_row byte
+            "psrlq $1, %%mm1             \n\t" // divide prev_row bytes by 2
+            "pand  %%mm4, %%mm1          \n\t" // clear invalid bit 7 of each
+                                               // byte
+            "paddb %%mm1, %%mm0          \n\t" // add (Prev_row/2) to Avg for
+                                               // each byte
+            // add 1st active group (Raw(x-bpp)/2) to average with _LBCarry
+            "movq %%mm3, %%mm1           \n\t" // now use mm1 for getting
+                                               // LBCarrys
+            "pand %%mm2, %%mm1           \n\t" // get LBCarrys for each byte
+                                               // where both
+                              // lsb's were == 1 (only valid for active group)
+            "psrlq $1, %%mm2             \n\t" // divide raw bytes by 2
+            "pand  %%mm4, %%mm2          \n\t" // clear invalid bit 7 of each
+                                               // byte
+            "paddb %%mm1, %%mm2          \n\t" // add LBCarrys to (Raw(x-bpp)/2)
+                                               // for each byte
+            "pand %%mm7, %%mm2           \n\t" // leave only Active Group 1
+                                               // bytes to add to Avg
+            "paddb %%mm2, %%mm0          \n\t" // add (Raw/2) + LBCarrys to Avg
+                                               // for each Active
+                              // byte
+            // add 2nd active group (Raw(x-bpp)/2) to average with _LBCarry
+            "movq %%mm0, %%mm2           \n\t" // mov updated Raws to mm2
+            "psllq _ShiftBpp, %%mm2      \n\t" // shift data to pos. correctly
+            "addl $8, %%ecx              \n\t"
+            "movq %%mm3, %%mm1           \n\t" // now use mm1 for getting
+                                               // LBCarrys
+            "pand %%mm2, %%mm1           \n\t" // get LBCarrys for each byte
+                                               // where both
+                              // lsb's were == 1 (only valid for active group)
+            "psrlq $1, %%mm2             \n\t" // divide raw bytes by 2
+            "pand  %%mm4, %%mm2          \n\t" // clear invalid bit 7 of each
+                                               // byte
+            "paddb %%mm1, %%mm2          \n\t" // add LBCarrys to (Raw(x-bpp)/2)
+                                               // for each byte
+            "pand %%mm6, %%mm2           \n\t" // leave only Active Group 2
+                                               // bytes to add to Avg
+            "paddb %%mm2, %%mm0          \n\t" // add (Raw/2) + LBCarrys to
+                                               // Avg for each Active
+                              // byte
+            "cmpl _MMXLength, %%ecx      \n\t"
+            // now ready to write back to memory
+            "movq %%mm0, -8(%%edi,%%ecx,) \n\t"
+            // prep Raw(x-bpp) for next loop
+            "movq %%mm0, %%mm2           \n\t" // mov updated Raws to mm2
+            "jb avg_4lp                  \n\t"
+
+            : "=S" (dummy_value_S),            // output regs (dummy)
+              "=D" (dummy_value_D)
+
+            : "0" (prev_row),  // esi          // input regs
+              "1" (row)        // edi
+
+            : "%ecx"                           // clobber list
+#if 0  /* %mm0, ..., %mm7 not supported by gcc 2.7.2.3 or egcs 1.1 */
+            , "%mm0", "%mm1", "%mm2", "%mm3"
+            , "%mm4", "%mm5", "%mm6", "%mm7"
+#endif
+         );
+      }
+      break;  // end 4,6 bpp
+
+      case 2:
+      {
+         _ActiveMask.use  = 0x000000000000ffffLL;
+         _ShiftBpp.use = 16;   // == 2 * 8
+         _ShiftRem.use = 48;   // == 64 - 16
+
+         __asm__ __volatile__ (
+            // load _ActiveMask
+            "movq _ActiveMask, %%mm7     \n\t"
+            // re-init address pointers and offset
+            "movl _dif, %%ecx            \n\t" // ecx:  x = offset to alignment
+                                               // boundary
+            "movq _LBCarryMask, %%mm5    \n\t"
+// preload  "movl row, %%edi             \n\t" // edi:  Avg(x)
+            "movq _HBClearMask, %%mm4    \n\t"
+// preload  "movl prev_row, %%esi        \n\t" // esi:  Prior(x)
+
+            // prime the pump:  load the first Raw(x-bpp) data set
+            "movq -8(%%edi,%%ecx,), %%mm2 \n\t" // load previous aligned 8 bytes
+                              // (we correct pos. in loop below)
+         "avg_2lp:                       \n\t"
+            "movq (%%edi,%%ecx,), %%mm0  \n\t"
+            "psrlq _ShiftRem, %%mm2      \n\t" // shift data to pos. correctly
+            "movq (%%esi,%%ecx,), %%mm1  \n\t" //  (GRR BUGFIX:  was psllq)
+            // add (Prev_row/2) to average
+            "movq %%mm5, %%mm3           \n\t"
+            "pand %%mm1, %%mm3           \n\t" // get lsb for each prev_row byte
+            "psrlq $1, %%mm1             \n\t" // divide prev_row bytes by 2
+            "pand  %%mm4, %%mm1          \n\t" // clear invalid bit 7 of each
+                                               // byte
+            "movq %%mm7, %%mm6           \n\t"
+            "paddb %%mm1, %%mm0          \n\t" // add (Prev_row/2) to Avg for
+                                               // each byte
+
+            // add 1st active group (Raw(x-bpp)/2) to average with _LBCarry
+            "movq %%mm3, %%mm1           \n\t" // now use mm1 for getting
+                                               // LBCarrys
+            "pand %%mm2, %%mm1           \n\t" // get LBCarrys for each byte
+                                               // where both
+                                               // lsb's were == 1 (only valid
+                                               // for active group)
+            "psrlq $1, %%mm2             \n\t" // divide raw bytes by 2
+            "pand  %%mm4, %%mm2          \n\t" // clear invalid bit 7 of each
+                                               // byte
+            "paddb %%mm1, %%mm2          \n\t" // add LBCarrys to (Raw(x-bpp)/2)
+                                               // for each byte
+            "pand %%mm6, %%mm2           \n\t" // leave only Active Group 1
+                                               // bytes to add to Avg
+            "paddb %%mm2, %%mm0          \n\t" // add (Raw/2) + LBCarrys to Avg
+                                               // for each Active byte
+
+            // add 2nd active group (Raw(x-bpp)/2) to average with _LBCarry
+            "psllq _ShiftBpp, %%mm6      \n\t" // shift the mm6 mask to cover
+                                               // bytes 2 & 3
+            "movq %%mm0, %%mm2           \n\t" // mov updated Raws to mm2
+            "psllq _ShiftBpp, %%mm2      \n\t" // shift data to pos. correctly
+            "movq %%mm3, %%mm1           \n\t" // now use mm1 for getting
+                                               // LBCarrys
+            "pand %%mm2, %%mm1           \n\t" // get LBCarrys for each byte
+                                               // where both
+                                               // lsb's were == 1 (only valid
+                                               // for active group)
+            "psrlq $1, %%mm2             \n\t" // divide raw bytes by 2
+            "pand  %%mm4, %%mm2          \n\t" // clear invalid bit 7 of each
+                                               // byte
+            "paddb %%mm1, %%mm2          \n\t" // add LBCarrys to (Raw(x-bpp)/2)
+                                               // for each byte
+            "pand %%mm6, %%mm2           \n\t" // leave only Active Group 2
+                                               // bytes to add to Avg
+            "paddb %%mm2, %%mm0          \n\t" // add (Raw/2) + LBCarrys to
+                                               // Avg for each Active byte
+
+            // add 3rd active group (Raw(x-bpp)/2) to average with _LBCarry
+            "psllq _ShiftBpp, %%mm6      \n\t" // shift the mm6 mask to cover
+                                               // bytes 4 & 5
+            "movq %%mm0, %%mm2           \n\t" // mov updated Raws to mm2
+            "psllq _ShiftBpp, %%mm2      \n\t" // shift data to pos. correctly
+            "movq %%mm3, %%mm1           \n\t" // now use mm1 for getting
+                                               // LBCarrys
+            "pand %%mm2, %%mm1           \n\t" // get LBCarrys for each byte
+                                               // where both lsb's were == 1
+                                               // (only valid for active group)
+            "psrlq $1, %%mm2             \n\t" // divide raw bytes by 2
+            "pand  %%mm4, %%mm2          \n\t" // clear invalid bit 7 of each
+                                               // byte
+            "paddb %%mm1, %%mm2          \n\t" // add LBCarrys to (Raw(x-bpp)/2)
+                                               // for each byte
+            "pand %%mm6, %%mm2           \n\t" // leave only Active Group 2
+                                               // bytes to add to Avg
+            "paddb %%mm2, %%mm0          \n\t" // add (Raw/2) + LBCarrys to
+                                               // Avg for each Active byte
+
+            // add 4th active group (Raw(x-bpp)/2) to average with _LBCarry
+            "psllq _ShiftBpp, %%mm6      \n\t" // shift the mm6 mask to cover
+                                               // bytes 6 & 7
+            "movq %%mm0, %%mm2           \n\t" // mov updated Raws to mm2
+            "psllq _ShiftBpp, %%mm2      \n\t" // shift data to pos. correctly
+            "addl $8, %%ecx              \n\t"
+            "movq %%mm3, %%mm1           \n\t" // now use mm1 for getting
+                                               // LBCarrys
+            "pand %%mm2, %%mm1           \n\t" // get LBCarrys for each byte
+                                               // where both
+                                               // lsb's were == 1 (only valid
+                                               // for active group)
+            "psrlq $1, %%mm2             \n\t" // divide raw bytes by 2
+            "pand  %%mm4, %%mm2          \n\t" // clear invalid bit 7 of each
+                                               // byte
+            "paddb %%mm1, %%mm2          \n\t" // add LBCarrys to (Raw(x-bpp)/2)
+                                               // for each byte
+            "pand %%mm6, %%mm2           \n\t" // leave only Active Group 2
+                                               // bytes to add to Avg
+            "paddb %%mm2, %%mm0          \n\t" // add (Raw/2) + LBCarrys to
+                                               // Avg for each Active byte
+
+            "cmpl _MMXLength, %%ecx      \n\t"
+            // now ready to write back to memory
+            "movq %%mm0, -8(%%edi,%%ecx,) \n\t"
+            // prep Raw(x-bpp) for next loop
+            "movq %%mm0, %%mm2           \n\t" // mov updated Raws to mm2
+            "jb avg_2lp                  \n\t"
+
+            : "=S" (dummy_value_S),            // output regs (dummy)
+              "=D" (dummy_value_D)
+
+            : "0" (prev_row),  // esi          // input regs
+              "1" (row)        // edi
+
+            : "%ecx"                           // clobber list
+#if 0  /* %mm0, ..., %mm7 not supported by gcc 2.7.2.3 or egcs 1.1 */
+            , "%mm0", "%mm1", "%mm2", "%mm3"
+            , "%mm4", "%mm5", "%mm6", "%mm7"
+#endif
+         );
+      }
+      break;  // end 2 bpp
+
+      case 1:
+      {
+         __asm__ __volatile__ (
+            // re-init address pointers and offset
+#ifdef __PIC__
+            "pushl %%ebx                 \n\t" // save Global Offset Table index
+#endif
+            "movl _dif, %%ebx            \n\t" // ebx:  x = offset to alignment
+                                               // boundary
+// preload  "movl row, %%edi             \n\t" // edi:  Avg(x)
+            "cmpl _FullLength, %%ebx     \n\t" // test if offset at end of array
+            "jnb avg_1end                \n\t"
+            // do Paeth decode for remaining bytes
+// preload  "movl prev_row, %%esi        \n\t" // esi:  Prior(x)
+            "movl %%edi, %%edx           \n\t"
+// preload  "subl bpp, %%edx             \n\t" // (bpp is preloaded into ecx)
+            "subl %%ecx, %%edx           \n\t" // edx:  Raw(x-bpp)
+            "xorl %%ecx, %%ecx           \n\t" // zero ecx before using cl & cx
+                                               //  in loop below
+         "avg_1lp:                       \n\t"
+            // Raw(x) = Avg(x) + ((Raw(x-bpp) + Prior(x))/2)
+            "xorl %%eax, %%eax           \n\t"
+            "movb (%%esi,%%ebx,), %%cl   \n\t" // load cl with Prior(x)
+            "movb (%%edx,%%ebx,), %%al   \n\t" // load al with Raw(x-bpp)
+            "addw %%cx, %%ax             \n\t"
+            "incl %%ebx                  \n\t"
+            "shrw %%ax                   \n\t" // divide by 2
+            "addb -1(%%edi,%%ebx,), %%al \n\t" // add Avg(x); -1 to offset
+                                               // inc ebx
+            "cmpl _FullLength, %%ebx     \n\t" // check if at end of array
+            "movb %%al, -1(%%edi,%%ebx,) \n\t" // write back Raw(x);
+                         // mov does not affect flags; -1 to offset inc ebx
+            "jb avg_1lp                  \n\t"
+
+         "avg_1end:                      \n\t"
+#ifdef __PIC__
+            "popl %%ebx                  \n\t" // Global Offset Table index
+#endif
+
+            : "=c" (dummy_value_c),            // output regs (dummy)
+              "=S" (dummy_value_S),
+              "=D" (dummy_value_D)
+
+            : "0" (bpp),       // ecx          // input regs
+              "1" (prev_row),  // esi
+              "2" (row)        // edi
+
+            : "%eax", "%edx"                   // clobber list
+#ifndef __PIC__
+            , "%ebx"
+#endif
+         );
+      }
+      return;  // end 1 bpp
+
+      case 8:
+      {
+         __asm__ __volatile__ (
+            // re-init address pointers and offset
+            "movl _dif, %%ecx            \n\t" // ecx:  x == offset to alignment
+            "movq _LBCarryMask, %%mm5    \n\t" //            boundary
+// preload  "movl row, %%edi             \n\t" // edi:  Avg(x)
+            "movq _HBClearMask, %%mm4    \n\t"
+// preload  "movl prev_row, %%esi        \n\t" // esi:  Prior(x)
+
+            // prime the pump:  load the first Raw(x-bpp) data set
+            "movq -8(%%edi,%%ecx,), %%mm2 \n\t" // load previous aligned 8 bytes
+                                      // (NO NEED to correct pos. in loop below)
+
+         "avg_8lp:                       \n\t"
+            "movq (%%edi,%%ecx,), %%mm0  \n\t"
+            "movq %%mm5, %%mm3           \n\t"
+            "movq (%%esi,%%ecx,), %%mm1  \n\t"
+            "addl $8, %%ecx              \n\t"
+            "pand %%mm1, %%mm3           \n\t" // get lsb for each prev_row byte
+            "psrlq $1, %%mm1             \n\t" // divide prev_row bytes by 2
+            "pand %%mm2, %%mm3           \n\t" // get LBCarrys for each byte
+                                               //  where both lsb's were == 1
+            "psrlq $1, %%mm2             \n\t" // divide raw bytes by 2
+            "pand  %%mm4, %%mm1          \n\t" // clear invalid bit 7, each byte
+            "paddb %%mm3, %%mm0          \n\t" // add LBCarrys to Avg, each byte
+            "pand  %%mm4, %%mm2          \n\t" // clear invalid bit 7, each byte
+            "paddb %%mm1, %%mm0          \n\t" // add (Prev_row/2) to Avg, each
+            "paddb %%mm2, %%mm0          \n\t" // add (Raw/2) to Avg for each
+            "cmpl _MMXLength, %%ecx      \n\t"
+            "movq %%mm0, -8(%%edi,%%ecx,) \n\t"
+            "movq %%mm0, %%mm2           \n\t" // reuse as Raw(x-bpp)
+            "jb avg_8lp                  \n\t"
+
+            : "=S" (dummy_value_S),            // output regs (dummy)
+              "=D" (dummy_value_D)
+
+            : "0" (prev_row),  // esi          // input regs
+              "1" (row)        // edi
+
+            : "%ecx"                           // clobber list
+#if 0  /* %mm0, ..., %mm5 not supported by gcc 2.7.2.3 or egcs 1.1 */
+            , "%mm0", "%mm1", "%mm2"
+            , "%mm3", "%mm4", "%mm5"
+#endif
+         );
+      }
+      break;  // end 8 bpp
+
+      default:                  // bpp greater than 8 (!= 1,2,3,4,[5],6,[7],8)
+      {
+
+#ifdef PNG_DEBUG
+         // GRR:  PRINT ERROR HERE:  SHOULD NEVER BE REACHED
+        png_debug(1,
+        "Internal logic error in pnggccrd (png_read_filter_row_mmx_avg())\n");
+#endif
+
+#if 0
+        __asm__ __volatile__ (
+            "movq _LBCarryMask, %%mm5    \n\t"
+            // re-init address pointers and offset
+            "movl _dif, %%ebx            \n\t" // ebx:  x = offset to
+                                               // alignment boundary
+            "movl row, %%edi             \n\t" // edi:  Avg(x)
+            "movq _HBClearMask, %%mm4    \n\t"
+            "movl %%edi, %%edx           \n\t"
+            "movl prev_row, %%esi        \n\t" // esi:  Prior(x)
+            "subl bpp, %%edx             \n\t" // edx:  Raw(x-bpp)
+         "avg_Alp:                       \n\t"
+            "movq (%%edi,%%ebx,), %%mm0  \n\t"
+            "movq %%mm5, %%mm3           \n\t"
+            "movq (%%esi,%%ebx,), %%mm1  \n\t"
+            "pand %%mm1, %%mm3           \n\t" // get lsb for each prev_row byte
+            "movq (%%edx,%%ebx,), %%mm2  \n\t"
+            "psrlq $1, %%mm1             \n\t" // divide prev_row bytes by 2
+            "pand %%mm2, %%mm3           \n\t" // get LBCarrys for each byte
+                                               // where both lsb's were == 1
+            "psrlq $1, %%mm2             \n\t" // divide raw bytes by 2
+            "pand  %%mm4, %%mm1          \n\t" // clear invalid bit 7 of each
+                                               // byte
+            "paddb %%mm3, %%mm0          \n\t" // add LBCarrys to Avg for each
+                                               // byte
+            "pand  %%mm4, %%mm2          \n\t" // clear invalid bit 7 of each
+                                               // byte
+            "paddb %%mm1, %%mm0          \n\t" // add (Prev_row/2) to Avg for
+                                               // each byte
+            "addl $8, %%ebx              \n\t"
+            "paddb %%mm2, %%mm0          \n\t" // add (Raw/2) to Avg for each
+                                               // byte
+            "cmpl _MMXLength, %%ebx      \n\t"
+            "movq %%mm0, -8(%%edi,%%ebx,) \n\t"
+            "jb avg_Alp                  \n\t"
+
+            : // FIXASM: output regs/vars go here, e.g.:  "=m" (memory_var)
+
+            : // FIXASM: input regs, e.g.:  "c" (count), "S" (src), "D" (dest)
+
+            : "%ebx", "%edx", "%edi", "%esi" // CHECKASM: clobber list
+         );
+#endif /* 0 - NEVER REACHED */
+      }
+      break;
+
+   } // end switch (bpp)
+
+   __asm__ __volatile__ (
+      // MMX acceleration complete; now do clean-up
+      // check if any remaining bytes left to decode
+#ifdef __PIC__
+      "pushl %%ebx                 \n\t" // save index to Global Offset Table
+#endif
+      "movl _MMXLength, %%ebx      \n\t" // ebx:  x == offset bytes after MMX
+//pre "movl row, %%edi             \n\t" // edi:  Avg(x)
+      "cmpl _FullLength, %%ebx     \n\t" // test if offset at end of array
+      "jnb avg_end                 \n\t"
+
+      // do Avg decode for remaining bytes
+//pre "movl prev_row, %%esi        \n\t" // esi:  Prior(x)
+      "movl %%edi, %%edx           \n\t"
+//pre "subl bpp, %%edx             \n\t" // (bpp is preloaded into ecx)
+      "subl %%ecx, %%edx           \n\t" // edx:  Raw(x-bpp)
+      "xorl %%ecx, %%ecx           \n\t" // zero ecx before using cl & cx below
+
+   "avg_lp2:                       \n\t"
+      // Raw(x) = Avg(x) + ((Raw(x-bpp) + Prior(x))/2)
+      "xorl %%eax, %%eax           \n\t"
+      "movb (%%esi,%%ebx,), %%cl   \n\t" // load cl with Prior(x)
+      "movb (%%edx,%%ebx,), %%al   \n\t" // load al with Raw(x-bpp)
+      "addw %%cx, %%ax             \n\t"
+      "incl %%ebx                  \n\t"
+      "shrw %%ax                   \n\t" // divide by 2
+      "addb -1(%%edi,%%ebx,), %%al \n\t" // add Avg(x); -1 to offset inc ebx
+      "cmpl _FullLength, %%ebx     \n\t" // check if at end of array
+      "movb %%al, -1(%%edi,%%ebx,) \n\t" // write back Raw(x) [mov does not
+      "jb avg_lp2                  \n\t" //  affect flags; -1 to offset inc ebx]
+
+   "avg_end:                       \n\t"
+      "EMMS                        \n\t" // end MMX; prep for poss. FP instrs.
+#ifdef __PIC__
+      "popl %%ebx                  \n\t" // restore index to Global Offset Table
+#endif
+
+      : "=c" (dummy_value_c),            // output regs (dummy)
+        "=S" (dummy_value_S),
+        "=D" (dummy_value_D)
+
+      : "0" (bpp),       // ecx          // input regs
+        "1" (prev_row),  // esi
+        "2" (row)        // edi
+
+      : "%eax", "%edx"                   // clobber list
+#ifndef __PIC__
+      , "%ebx"
+#endif
+   );
+
+} /* end png_read_filter_row_mmx_avg() */
+#endif
+
+
+
+#ifdef PNG_THREAD_UNSAFE_OK
+//===========================================================================//
+//                                                                           //
+//         P N G _ R E A D _ F I L T E R _ R O W _ M M X _ P A E T H         //
+//                                                                           //
+//===========================================================================//
+
+// Optimized code for PNG Paeth filter decoder
+
+static void /* PRIVATE */
+png_read_filter_row_mmx_paeth(png_row_infop row_info, png_bytep row,
+                              png_bytep prev_row)
+{
+   int bpp;
+   int dummy_value_c;   // fix 'forbidden register 2 (cx) was spilled' error
+   int dummy_value_S;
+   int dummy_value_D;
+
+   bpp = (row_info->pixel_depth + 7) >> 3; // Get # bytes per pixel
+   _FullLength  = row_info->rowbytes; // # of bytes to filter
+
+   __asm__ __volatile__ (
+#ifdef __PIC__
+      "pushl %%ebx                 \n\t" // save index to Global Offset Table
+#endif
+      "xorl %%ebx, %%ebx           \n\t" // ebx:  x offset
+//pre "movl row, %%edi             \n\t"
+      "xorl %%edx, %%edx           \n\t" // edx:  x-bpp offset
+//pre "movl prev_row, %%esi        \n\t"
+      "xorl %%eax, %%eax           \n\t"
+
+      // Compute the Raw value for the first bpp bytes
+      // Note: the formula works out to be always
+      //   Paeth(x) = Raw(x) + Prior(x)      where x < bpp
+   "paeth_rlp:                     \n\t"
+      "movb (%%edi,%%ebx,), %%al   \n\t"
+      "addb (%%esi,%%ebx,), %%al   \n\t"
+      "incl %%ebx                  \n\t"
+//pre "cmpl bpp, %%ebx             \n\t" (bpp is preloaded into ecx)
+      "cmpl %%ecx, %%ebx           \n\t"
+      "movb %%al, -1(%%edi,%%ebx,) \n\t"
+      "jb paeth_rlp                \n\t"
+      // get # of bytes to alignment
+      "movl %%edi, _dif            \n\t" // take start of row
+      "addl %%ebx, _dif            \n\t" // add bpp
+      "xorl %%ecx, %%ecx           \n\t"
+      "addl $0xf, _dif             \n\t" // add 7 + 8 to incr past alignment
+                                         // boundary
+      "andl $0xfffffff8, _dif      \n\t" // mask to alignment boundary
+      "subl %%edi, _dif            \n\t" // subtract from start ==> value ebx
+                                         // at alignment
+      "jz paeth_go                 \n\t"
+      // fix alignment
+
+   "paeth_lp1:                     \n\t"
+      "xorl %%eax, %%eax           \n\t"
+      // pav = p - a = (a + b - c) - a = b - c
+      "movb (%%esi,%%ebx,), %%al   \n\t" // load Prior(x) into al
+      "movb (%%esi,%%edx,), %%cl   \n\t" // load Prior(x-bpp) into cl
+      "subl %%ecx, %%eax           \n\t" // subtract Prior(x-bpp)
+      "movl %%eax, _patemp         \n\t" // Save pav for later use
+      "xorl %%eax, %%eax           \n\t"
+      // pbv = p - b = (a + b - c) - b = a - c
+      "movb (%%edi,%%edx,), %%al   \n\t" // load Raw(x-bpp) into al
+      "subl %%ecx, %%eax           \n\t" // subtract Prior(x-bpp)
+      "movl %%eax, %%ecx           \n\t"
+      // pcv = p - c = (a + b - c) -c = (a - c) + (b - c) = pav + pbv
+      "addl _patemp, %%eax         \n\t" // pcv = pav + pbv
+      // pc = abs(pcv)
+      "testl $0x80000000, %%eax    \n\t"
+      "jz paeth_pca                \n\t"
+      "negl %%eax                  \n\t" // reverse sign of neg values
+
+   "paeth_pca:                     \n\t"
+      "movl %%eax, _pctemp         \n\t" // save pc for later use
+      // pb = abs(pbv)
+      "testl $0x80000000, %%ecx    \n\t"
+      "jz paeth_pba                \n\t"
+      "negl %%ecx                  \n\t" // reverse sign of neg values
+
+   "paeth_pba:                     \n\t"
+      "movl %%ecx, _pbtemp         \n\t" // save pb for later use
+      // pa = abs(pav)
+      "movl _patemp, %%eax         \n\t"
+      "testl $0x80000000, %%eax    \n\t"
+      "jz paeth_paa                \n\t"
+      "negl %%eax                  \n\t" // reverse sign of neg values
+
+   "paeth_paa:                     \n\t"
+      "movl %%eax, _patemp         \n\t" // save pa for later use
+      // test if pa <= pb
+      "cmpl %%ecx, %%eax           \n\t"
+      "jna paeth_abb               \n\t"
+      // pa > pb; now test if pb <= pc
+      "cmpl _pctemp, %%ecx         \n\t"
+      "jna paeth_bbc               \n\t"
+      // pb > pc; Raw(x) = Paeth(x) + Prior(x-bpp)
+      "movb (%%esi,%%edx,), %%cl   \n\t" // load Prior(x-bpp) into cl
+      "jmp paeth_paeth             \n\t"
+
+   "paeth_bbc:                     \n\t"
+      // pb <= pc; Raw(x) = Paeth(x) + Prior(x)
+      "movb (%%esi,%%ebx,), %%cl   \n\t" // load Prior(x) into cl
+      "jmp paeth_paeth             \n\t"
+
+   "paeth_abb:                     \n\t"
+      // pa <= pb; now test if pa <= pc
+      "cmpl _pctemp, %%eax         \n\t"
+      "jna paeth_abc               \n\t"
+      // pa > pc; Raw(x) = Paeth(x) + Prior(x-bpp)
+      "movb (%%esi,%%edx,), %%cl   \n\t" // load Prior(x-bpp) into cl
+      "jmp paeth_paeth             \n\t"
+
+   "paeth_abc:                     \n\t"
+      // pa <= pc; Raw(x) = Paeth(x) + Raw(x-bpp)
+      "movb (%%edi,%%edx,), %%cl   \n\t" // load Raw(x-bpp) into cl
+
+   "paeth_paeth:                   \n\t"
+      "incl %%ebx                  \n\t"
+      "incl %%edx                  \n\t"
+      // Raw(x) = (Paeth(x) + Paeth_Predictor( a, b, c )) mod 256
+      "addb %%cl, -1(%%edi,%%ebx,) \n\t"
+      "cmpl _dif, %%ebx            \n\t"
+      "jb paeth_lp1                \n\t"
+
+   "paeth_go:                      \n\t"
+      "movl _FullLength, %%ecx     \n\t"
+      "movl %%ecx, %%eax           \n\t"
+      "subl %%ebx, %%eax           \n\t" // subtract alignment fix
+      "andl $0x00000007, %%eax     \n\t" // calc bytes over mult of 8
+      "subl %%eax, %%ecx           \n\t" // drop over bytes from original length
+      "movl %%ecx, _MMXLength      \n\t"
+#ifdef __PIC__
+      "popl %%ebx                  \n\t" // restore index to Global Offset Table
+#endif
+
+      : "=c" (dummy_value_c),            // output regs (dummy)
+        "=S" (dummy_value_S),
+        "=D" (dummy_value_D)
+
+      : "0" (bpp),       // ecx          // input regs
+        "1" (prev_row),  // esi
+        "2" (row)        // edi
+
+      : "%eax", "%edx"                   // clobber list
+#ifndef __PIC__
+      , "%ebx"
+#endif
+   );
+
+   // now do the math for the rest of the row
+   switch (bpp)
+   {
+      case 3:
+      {
+         _ActiveMask.use = 0x0000000000ffffffLL;
+         _ActiveMaskEnd.use = 0xffff000000000000LL;
+         _ShiftBpp.use = 24;    // == bpp(3) * 8
+         _ShiftRem.use = 40;    // == 64 - 24
+
+         __asm__ __volatile__ (
+            "movl _dif, %%ecx            \n\t"
+// preload  "movl row, %%edi             \n\t"
+// preload  "movl prev_row, %%esi        \n\t"
+            "pxor %%mm0, %%mm0           \n\t"
+            // prime the pump:  load the first Raw(x-bpp) data set
+            "movq -8(%%edi,%%ecx,), %%mm1 \n\t"
+         "paeth_3lp:                     \n\t"
+            "psrlq _ShiftRem, %%mm1      \n\t" // shift last 3 bytes to 1st
+                                               // 3 bytes
+            "movq (%%esi,%%ecx,), %%mm2  \n\t" // load b=Prior(x)
+            "punpcklbw %%mm0, %%mm1      \n\t" // unpack High bytes of a
+            "movq -8(%%esi,%%ecx,), %%mm3 \n\t" // prep c=Prior(x-bpp) bytes
+            "punpcklbw %%mm0, %%mm2      \n\t" // unpack High bytes of b
+            "psrlq _ShiftRem, %%mm3      \n\t" // shift last 3 bytes to 1st
+                                               // 3 bytes
+            // pav = p - a = (a + b - c) - a = b - c
+            "movq %%mm2, %%mm4           \n\t"
+            "punpcklbw %%mm0, %%mm3      \n\t" // unpack High bytes of c
+            // pbv = p - b = (a + b - c) - b = a - c
+            "movq %%mm1, %%mm5           \n\t"
+            "psubw %%mm3, %%mm4          \n\t"
+            "pxor %%mm7, %%mm7           \n\t"
+            // pcv = p - c = (a + b - c) -c = (a - c) + (b - c) = pav + pbv
+            "movq %%mm4, %%mm6           \n\t"
+            "psubw %%mm3, %%mm5          \n\t"
+
+            // pa = abs(p-a) = abs(pav)
+            // pb = abs(p-b) = abs(pbv)
+            // pc = abs(p-c) = abs(pcv)
+            "pcmpgtw %%mm4, %%mm0        \n\t" // create mask pav bytes < 0
+            "paddw %%mm5, %%mm6          \n\t"
+            "pand %%mm4, %%mm0           \n\t" // only pav bytes < 0 in mm7
+            "pcmpgtw %%mm5, %%mm7        \n\t" // create mask pbv bytes < 0
+            "psubw %%mm0, %%mm4          \n\t"
+            "pand %%mm5, %%mm7           \n\t" // only pbv bytes < 0 in mm0
+            "psubw %%mm0, %%mm4          \n\t"
+            "psubw %%mm7, %%mm5          \n\t"
+            "pxor %%mm0, %%mm0           \n\t"
+            "pcmpgtw %%mm6, %%mm0        \n\t" // create mask pcv bytes < 0
+            "pand %%mm6, %%mm0           \n\t" // only pav bytes < 0 in mm7
+            "psubw %%mm7, %%mm5          \n\t"
+            "psubw %%mm0, %%mm6          \n\t"
+            //  test pa <= pb
+            "movq %%mm4, %%mm7           \n\t"
+            "psubw %%mm0, %%mm6          \n\t"
+            "pcmpgtw %%mm5, %%mm7        \n\t" // pa > pb?
+            "movq %%mm7, %%mm0           \n\t"
+            // use mm7 mask to merge pa & pb
+            "pand %%mm7, %%mm5           \n\t"
+            // use mm0 mask copy to merge a & b
+            "pand %%mm0, %%mm2           \n\t"
+            "pandn %%mm4, %%mm7          \n\t"
+            "pandn %%mm1, %%mm0          \n\t"
+            "paddw %%mm5, %%mm7          \n\t"
+            "paddw %%mm2, %%mm0          \n\t"
+            //  test  ((pa <= pb)? pa:pb) <= pc
+            "pcmpgtw %%mm6, %%mm7        \n\t" // pab > pc?
+            "pxor %%mm1, %%mm1           \n\t"
+            "pand %%mm7, %%mm3           \n\t"
+            "pandn %%mm0, %%mm7          \n\t"
+            "paddw %%mm3, %%mm7          \n\t"
+            "pxor %%mm0, %%mm0           \n\t"
+            "packuswb %%mm1, %%mm7       \n\t"
+            "movq (%%esi,%%ecx,), %%mm3  \n\t" // load c=Prior(x-bpp)
+            "pand _ActiveMask, %%mm7     \n\t"
+            "movq %%mm3, %%mm2           \n\t" // load b=Prior(x) step 1
+            "paddb (%%edi,%%ecx,), %%mm7 \n\t" // add Paeth predictor with Raw(x)
+            "punpcklbw %%mm0, %%mm3      \n\t" // unpack High bytes of c
+            "movq %%mm7, (%%edi,%%ecx,)  \n\t" // write back updated value
+            "movq %%mm7, %%mm1           \n\t" // now mm1 will be used as
+                                               // Raw(x-bpp)
+            // now do Paeth for 2nd set of bytes (3-5)
+            "psrlq _ShiftBpp, %%mm2      \n\t" // load b=Prior(x) step 2
+            "punpcklbw %%mm0, %%mm1      \n\t" // unpack High bytes of a
+            "pxor %%mm7, %%mm7           \n\t"
+            "punpcklbw %%mm0, %%mm2      \n\t" // unpack High bytes of b
+            // pbv = p - b = (a + b - c) - b = a - c
+            "movq %%mm1, %%mm5           \n\t"
+            // pav = p - a = (a + b - c) - a = b - c
+            "movq %%mm2, %%mm4           \n\t"
+            "psubw %%mm3, %%mm5          \n\t"
+            "psubw %%mm3, %%mm4          \n\t"
+            // pcv = p - c = (a + b - c) -c = (a - c) + (b - c) =
+            //       pav + pbv = pbv + pav
+            "movq %%mm5, %%mm6           \n\t"
+            "paddw %%mm4, %%mm6          \n\t"
+
+            // pa = abs(p-a) = abs(pav)
+            // pb = abs(p-b) = abs(pbv)
+            // pc = abs(p-c) = abs(pcv)
+            "pcmpgtw %%mm5, %%mm0        \n\t" // create mask pbv bytes < 0
+            "pcmpgtw %%mm4, %%mm7        \n\t" // create mask pav bytes < 0
+            "pand %%mm5, %%mm0           \n\t" // only pbv bytes < 0 in mm0
+            "pand %%mm4, %%mm7           \n\t" // only pav bytes < 0 in mm7
+            "psubw %%mm0, %%mm5          \n\t"
+            "psubw %%mm7, %%mm4          \n\t"
+            "psubw %%mm0, %%mm5          \n\t"
+            "psubw %%mm7, %%mm4          \n\t"
+            "pxor %%mm0, %%mm0           \n\t"
+            "pcmpgtw %%mm6, %%mm0        \n\t" // create mask pcv bytes < 0
+            "pand %%mm6, %%mm0           \n\t" // only pav bytes < 0 in mm7
+            "psubw %%mm0, %%mm6          \n\t"
+            //  test pa <= pb
+            "movq %%mm4, %%mm7           \n\t"
+            "psubw %%mm0, %%mm6          \n\t"
+            "pcmpgtw %%mm5, %%mm7        \n\t" // pa > pb?
+            "movq %%mm7, %%mm0           \n\t"
+            // use mm7 mask to merge pa & pb
+            "pand %%mm7, %%mm5           \n\t"
+            // use mm0 mask copy to merge a & b
+            "pand %%mm0, %%mm2           \n\t"
+            "pandn %%mm4, %%mm7          \n\t"
+            "pandn %%mm1, %%mm0          \n\t"
+            "paddw %%mm5, %%mm7          \n\t"
+            "paddw %%mm2, %%mm0          \n\t"
+            //  test  ((pa <= pb)? pa:pb) <= pc
+            "pcmpgtw %%mm6, %%mm7        \n\t" // pab > pc?
+            "movq (%%esi,%%ecx,), %%mm2  \n\t" // load b=Prior(x)
+            "pand %%mm7, %%mm3           \n\t"
+            "pandn %%mm0, %%mm7          \n\t"
+            "pxor %%mm1, %%mm1           \n\t"
+            "paddw %%mm3, %%mm7          \n\t"
+            "pxor %%mm0, %%mm0           \n\t"
+            "packuswb %%mm1, %%mm7       \n\t"
+            "movq %%mm2, %%mm3           \n\t" // load c=Prior(x-bpp) step 1
+            "pand _ActiveMask, %%mm7     \n\t"
+            "punpckhbw %%mm0, %%mm2      \n\t" // unpack High bytes of b
+            "psllq _ShiftBpp, %%mm7      \n\t" // shift bytes to 2nd group of
+                                               // 3 bytes
+             // pav = p - a = (a + b - c) - a = b - c
+            "movq %%mm2, %%mm4           \n\t"
+            "paddb (%%edi,%%ecx,), %%mm7 \n\t" // add Paeth predictor with Raw(x)
+            "psllq _ShiftBpp, %%mm3      \n\t" // load c=Prior(x-bpp) step 2
+            "movq %%mm7, (%%edi,%%ecx,)  \n\t" // write back updated value
+            "movq %%mm7, %%mm1           \n\t"
+            "punpckhbw %%mm0, %%mm3      \n\t" // unpack High bytes of c
+            "psllq _ShiftBpp, %%mm1      \n\t" // shift bytes
+                                    // now mm1 will be used as Raw(x-bpp)
+            // now do Paeth for 3rd, and final, set of bytes (6-7)
+            "pxor %%mm7, %%mm7           \n\t"
+            "punpckhbw %%mm0, %%mm1      \n\t" // unpack High bytes of a
+            "psubw %%mm3, %%mm4          \n\t"
+            // pbv = p - b = (a + b - c) - b = a - c
+            "movq %%mm1, %%mm5           \n\t"
+            // pcv = p - c = (a + b - c) -c = (a - c) + (b - c) = pav + pbv
+            "movq %%mm4, %%mm6           \n\t"
+            "psubw %%mm3, %%mm5          \n\t"
+            "pxor %%mm0, %%mm0           \n\t"
+            "paddw %%mm5, %%mm6          \n\t"
+
+            // pa = abs(p-a) = abs(pav)
+            // pb = abs(p-b) = abs(pbv)
+            // pc = abs(p-c) = abs(pcv)
+            "pcmpgtw %%mm4, %%mm0        \n\t" // create mask pav bytes < 0
+            "pcmpgtw %%mm5, %%mm7        \n\t" // create mask pbv bytes < 0
+            "pand %%mm4, %%mm0           \n\t" // only pav bytes < 0 in mm7
+            "pand %%mm5, %%mm7           \n\t" // only pbv bytes < 0 in mm0
+            "psubw %%mm0, %%mm4          \n\t"
+            "psubw %%mm7, %%mm5          \n\t"
+            "psubw %%mm0, %%mm4          \n\t"
+            "psubw %%mm7, %%mm5          \n\t"
+            "pxor %%mm0, %%mm0           \n\t"
+            "pcmpgtw %%mm6, %%mm0        \n\t" // create mask pcv bytes < 0
+            "pand %%mm6, %%mm0           \n\t" // only pav bytes < 0 in mm7
+            "psubw %%mm0, %%mm6          \n\t"
+            //  test pa <= pb
+            "movq %%mm4, %%mm7           \n\t"
+            "psubw %%mm0, %%mm6          \n\t"
+            "pcmpgtw %%mm5, %%mm7        \n\t" // pa > pb?
+            "movq %%mm7, %%mm0           \n\t"
+            // use mm0 mask copy to merge a & b
+            "pand %%mm0, %%mm2           \n\t"
+            // use mm7 mask to merge pa & pb
+            "pand %%mm7, %%mm5           \n\t"
+            "pandn %%mm1, %%mm0          \n\t"
+            "pandn %%mm4, %%mm7          \n\t"
+            "paddw %%mm2, %%mm0          \n\t"
+            "paddw %%mm5, %%mm7          \n\t"
+            //  test  ((pa <= pb)? pa:pb) <= pc
+            "pcmpgtw %%mm6, %%mm7        \n\t" // pab > pc?
+            "pand %%mm7, %%mm3           \n\t"
+            "pandn %%mm0, %%mm7          \n\t"
+            "paddw %%mm3, %%mm7          \n\t"
+            "pxor %%mm1, %%mm1           \n\t"
+            "packuswb %%mm7, %%mm1       \n\t"
+            // step ecx to next set of 8 bytes and repeat loop til done
+            "addl $8, %%ecx              \n\t"
+            "pand _ActiveMaskEnd, %%mm1  \n\t"
+            "paddb -8(%%edi,%%ecx,), %%mm1 \n\t" // add Paeth predictor with
+                                                 // Raw(x)
+
+            "cmpl _MMXLength, %%ecx      \n\t"
+            "pxor %%mm0, %%mm0           \n\t" // pxor does not affect flags
+            "movq %%mm1, -8(%%edi,%%ecx,) \n\t" // write back updated value
+                                 // mm1 will be used as Raw(x-bpp) next loop
+                           // mm3 ready to be used as Prior(x-bpp) next loop
+            "jb paeth_3lp                \n\t"
+
+            : "=S" (dummy_value_S),             // output regs (dummy)
+              "=D" (dummy_value_D)
+
+            : "0" (prev_row),  // esi           // input regs
+              "1" (row)        // edi
+
+            : "%ecx"                            // clobber list
+#if 0  /* %mm0, ..., %mm7 not supported by gcc 2.7.2.3 or egcs 1.1 */
+            , "%mm0", "%mm1", "%mm2", "%mm3"
+            , "%mm4", "%mm5", "%mm6", "%mm7"
+#endif
+         );
+      }
+      break;  // end 3 bpp
+
+      case 6:
+      //case 7:   // GRR BOGUS
+      //case 5:   // GRR BOGUS
+      {
+         _ActiveMask.use  = 0x00000000ffffffffLL;
+         _ActiveMask2.use = 0xffffffff00000000LL;
+         _ShiftBpp.use = bpp << 3;    // == bpp * 8
+         _ShiftRem.use = 64 - _ShiftBpp.use;
+
+         __asm__ __volatile__ (
+            "movl _dif, %%ecx            \n\t"
+// preload  "movl row, %%edi             \n\t"
+// preload  "movl prev_row, %%esi        \n\t"
+            // prime the pump:  load the first Raw(x-bpp) data set
+            "movq -8(%%edi,%%ecx,), %%mm1 \n\t"
+            "pxor %%mm0, %%mm0           \n\t"
+
+         "paeth_6lp:                     \n\t"
+            // must shift to position Raw(x-bpp) data
+            "psrlq _ShiftRem, %%mm1      \n\t"
+            // do first set of 4 bytes
+            "movq -8(%%esi,%%ecx,), %%mm3 \n\t" // read c=Prior(x-bpp) bytes
+            "punpcklbw %%mm0, %%mm1      \n\t" // unpack Low bytes of a
+            "movq (%%esi,%%ecx,), %%mm2  \n\t" // load b=Prior(x)
+            "punpcklbw %%mm0, %%mm2      \n\t" // unpack Low bytes of b
+            // must shift to position Prior(x-bpp) data
+            "psrlq _ShiftRem, %%mm3      \n\t"
+            // pav = p - a = (a + b - c) - a = b - c
+            "movq %%mm2, %%mm4           \n\t"
+            "punpcklbw %%mm0, %%mm3      \n\t" // unpack Low bytes of c
+            // pbv = p - b = (a + b - c) - b = a - c
+            "movq %%mm1, %%mm5           \n\t"
+            "psubw %%mm3, %%mm4          \n\t"
+            "pxor %%mm7, %%mm7           \n\t"
+            // pcv = p - c = (a + b - c) -c = (a - c) + (b - c) = pav + pbv
+            "movq %%mm4, %%mm6           \n\t"
+            "psubw %%mm3, %%mm5          \n\t"
+            // pa = abs(p-a) = abs(pav)
+            // pb = abs(p-b) = abs(pbv)
+            // pc = abs(p-c) = abs(pcv)
+            "pcmpgtw %%mm4, %%mm0        \n\t" // create mask pav bytes < 0
+            "paddw %%mm5, %%mm6          \n\t"
+            "pand %%mm4, %%mm0           \n\t" // only pav bytes < 0 in mm7
+            "pcmpgtw %%mm5, %%mm7        \n\t" // create mask pbv bytes < 0
+            "psubw %%mm0, %%mm4          \n\t"
+            "pand %%mm5, %%mm7           \n\t" // only pbv bytes < 0 in mm0
+            "psubw %%mm0, %%mm4          \n\t"
+            "psubw %%mm7, %%mm5          \n\t"
+            "pxor %%mm0, %%mm0           \n\t"
+            "pcmpgtw %%mm6, %%mm0        \n\t" // create mask pcv bytes < 0
+            "pand %%mm6, %%mm0           \n\t" // only pav bytes < 0 in mm7
+            "psubw %%mm7, %%mm5          \n\t"
+            "psubw %%mm0, %%mm6          \n\t"
+            //  test pa <= pb
+            "movq %%mm4, %%mm7           \n\t"
+            "psubw %%mm0, %%mm6          \n\t"
+            "pcmpgtw %%mm5, %%mm7        \n\t" // pa > pb?
+            "movq %%mm7, %%mm0           \n\t"
+            // use mm7 mask to merge pa & pb
+            "pand %%mm7, %%mm5           \n\t"
+            // use mm0 mask copy to merge a & b
+            "pand %%mm0, %%mm2           \n\t"
+            "pandn %%mm4, %%mm7          \n\t"
+            "pandn %%mm1, %%mm0          \n\t"
+            "paddw %%mm5, %%mm7          \n\t"
+            "paddw %%mm2, %%mm0          \n\t"
+            //  test  ((pa <= pb)? pa:pb) <= pc
+            "pcmpgtw %%mm6, %%mm7        \n\t" // pab > pc?
+            "pxor %%mm1, %%mm1           \n\t"
+            "pand %%mm7, %%mm3           \n\t"
+            "pandn %%mm0, %%mm7          \n\t"
+            "paddw %%mm3, %%mm7          \n\t"
+            "pxor %%mm0, %%mm0           \n\t"
+            "packuswb %%mm1, %%mm7       \n\t"
+            "movq -8(%%esi,%%ecx,), %%mm3 \n\t" // load c=Prior(x-bpp)
+            "pand _ActiveMask, %%mm7     \n\t"
+            "psrlq _ShiftRem, %%mm3      \n\t"
+            "movq (%%esi,%%ecx,), %%mm2  \n\t" // load b=Prior(x) step 1
+            "paddb (%%edi,%%ecx,), %%mm7 \n\t" // add Paeth predictor and Raw(x)
+            "movq %%mm2, %%mm6           \n\t"
+            "movq %%mm7, (%%edi,%%ecx,)  \n\t" // write back updated value
+            "movq -8(%%edi,%%ecx,), %%mm1 \n\t"
+            "psllq _ShiftBpp, %%mm6      \n\t"
+            "movq %%mm7, %%mm5           \n\t"
+            "psrlq _ShiftRem, %%mm1      \n\t"
+            "por %%mm6, %%mm3            \n\t"
+            "psllq _ShiftBpp, %%mm5      \n\t"
+            "punpckhbw %%mm0, %%mm3      \n\t" // unpack High bytes of c
+            "por %%mm5, %%mm1            \n\t"
+            // do second set of 4 bytes
+            "punpckhbw %%mm0, %%mm2      \n\t" // unpack High bytes of b
+            "punpckhbw %%mm0, %%mm1      \n\t" // unpack High bytes of a
+            // pav = p - a = (a + b - c) - a = b - c
+            "movq %%mm2, %%mm4           \n\t"
+            // pbv = p - b = (a + b - c) - b = a - c
+            "movq %%mm1, %%mm5           \n\t"
+            "psubw %%mm3, %%mm4          \n\t"
+            "pxor %%mm7, %%mm7           \n\t"
+            // pcv = p - c = (a + b - c) -c = (a - c) + (b - c) = pav + pbv
+            "movq %%mm4, %%mm6           \n\t"
+            "psubw %%mm3, %%mm5          \n\t"
+            // pa = abs(p-a) = abs(pav)
+            // pb = abs(p-b) = abs(pbv)
+            // pc = abs(p-c) = abs(pcv)
+            "pcmpgtw %%mm4, %%mm0        \n\t" // create mask pav bytes < 0
+            "paddw %%mm5, %%mm6          \n\t"
+            "pand %%mm4, %%mm0           \n\t" // only pav bytes < 0 in mm7
+            "pcmpgtw %%mm5, %%mm7        \n\t" // create mask pbv bytes < 0
+            "psubw %%mm0, %%mm4          \n\t"
+            "pand %%mm5, %%mm7           \n\t" // only pbv bytes < 0 in mm0
+            "psubw %%mm0, %%mm4          \n\t"
+            "psubw %%mm7, %%mm5          \n\t"
+            "pxor %%mm0, %%mm0           \n\t"
+            "pcmpgtw %%mm6, %%mm0        \n\t" // create mask pcv bytes < 0
+            "pand %%mm6, %%mm0           \n\t" // only pav bytes < 0 in mm7
+            "psubw %%mm7, %%mm5          \n\t"
+            "psubw %%mm0, %%mm6          \n\t"
+            //  test pa <= pb
+            "movq %%mm4, %%mm7           \n\t"
+            "psubw %%mm0, %%mm6          \n\t"
+            "pcmpgtw %%mm5, %%mm7        \n\t" // pa > pb?
+            "movq %%mm7, %%mm0           \n\t"
+            // use mm7 mask to merge pa & pb
+            "pand %%mm7, %%mm5           \n\t"
+            // use mm0 mask copy to merge a & b
+            "pand %%mm0, %%mm2           \n\t"
+            "pandn %%mm4, %%mm7          \n\t"
+            "pandn %%mm1, %%mm0          \n\t"
+            "paddw %%mm5, %%mm7          \n\t"
+            "paddw %%mm2, %%mm0          \n\t"
+            //  test  ((pa <= pb)? pa:pb) <= pc
+            "pcmpgtw %%mm6, %%mm7        \n\t" // pab > pc?
+            "pxor %%mm1, %%mm1           \n\t"
+            "pand %%mm7, %%mm3           \n\t"
+            "pandn %%mm0, %%mm7          \n\t"
+            "pxor %%mm1, %%mm1           \n\t"
+            "paddw %%mm3, %%mm7          \n\t"
+            "pxor %%mm0, %%mm0           \n\t"
+            // step ecx to next set of 8 bytes and repeat loop til done
+            "addl $8, %%ecx              \n\t"
+            "packuswb %%mm7, %%mm1       \n\t"
+            "paddb -8(%%edi,%%ecx,), %%mm1 \n\t" // add Paeth predictor with Raw(x)
+            "cmpl _MMXLength, %%ecx      \n\t"
+            "movq %%mm1, -8(%%edi,%%ecx,) \n\t" // write back updated value
+                                // mm1 will be used as Raw(x-bpp) next loop
+            "jb paeth_6lp                \n\t"
+
+            : "=S" (dummy_value_S),             // output regs (dummy)
+              "=D" (dummy_value_D)
+
+            : "0" (prev_row),  // esi           // input regs
+              "1" (row)        // edi
+
+            : "%ecx"                            // clobber list
+#if 0  /* %mm0, ..., %mm7 not supported by gcc 2.7.2.3 or egcs 1.1 */
+            , "%mm0", "%mm1", "%mm2", "%mm3"
+            , "%mm4", "%mm5", "%mm6", "%mm7"
+#endif
+         );
+      }
+      break;  // end 6 bpp
+
+      case 4:
+      {
+         _ActiveMask.use  = 0x00000000ffffffffLL;
+
+         __asm__ __volatile__ (
+            "movl _dif, %%ecx            \n\t"
+// preload  "movl row, %%edi             \n\t"
+// preload  "movl prev_row, %%esi        \n\t"
+            "pxor %%mm0, %%mm0           \n\t"
+            // prime the pump:  load the first Raw(x-bpp) data set
+            "movq -8(%%edi,%%ecx,), %%mm1 \n\t" // only time should need to read
+                                     //  a=Raw(x-bpp) bytes
+         "paeth_4lp:                     \n\t"
+            // do first set of 4 bytes
+            "movq -8(%%esi,%%ecx,), %%mm3 \n\t" // read c=Prior(x-bpp) bytes
+            "punpckhbw %%mm0, %%mm1      \n\t" // unpack Low bytes of a
+            "movq (%%esi,%%ecx,), %%mm2  \n\t" // load b=Prior(x)
+            "punpcklbw %%mm0, %%mm2      \n\t" // unpack High bytes of b
+            // pav = p - a = (a + b - c) - a = b - c
+            "movq %%mm2, %%mm4           \n\t"
+            "punpckhbw %%mm0, %%mm3      \n\t" // unpack High bytes of c
+            // pbv = p - b = (a + b - c) - b = a - c
+            "movq %%mm1, %%mm5           \n\t"
+            "psubw %%mm3, %%mm4          \n\t"
+            "pxor %%mm7, %%mm7           \n\t"
+            // pcv = p - c = (a + b - c) -c = (a - c) + (b - c) = pav + pbv
+            "movq %%mm4, %%mm6           \n\t"
+            "psubw %%mm3, %%mm5          \n\t"
+            // pa = abs(p-a) = abs(pav)
+            // pb = abs(p-b) = abs(pbv)
+            // pc = abs(p-c) = abs(pcv)
+            "pcmpgtw %%mm4, %%mm0        \n\t" // create mask pav bytes < 0
+            "paddw %%mm5, %%mm6          \n\t"
+            "pand %%mm4, %%mm0           \n\t" // only pav bytes < 0 in mm7
+            "pcmpgtw %%mm5, %%mm7        \n\t" // create mask pbv bytes < 0
+            "psubw %%mm0, %%mm4          \n\t"
+            "pand %%mm5, %%mm7           \n\t" // only pbv bytes < 0 in mm0
+            "psubw %%mm0, %%mm4          \n\t"
+            "psubw %%mm7, %%mm5          \n\t"
+            "pxor %%mm0, %%mm0           \n\t"
+            "pcmpgtw %%mm6, %%mm0        \n\t" // create mask pcv bytes < 0
+            "pand %%mm6, %%mm0           \n\t" // only pav bytes < 0 in mm7
+            "psubw %%mm7, %%mm5          \n\t"
+            "psubw %%mm0, %%mm6          \n\t"
+            //  test pa <= pb
+            "movq %%mm4, %%mm7           \n\t"
+            "psubw %%mm0, %%mm6          \n\t"
+            "pcmpgtw %%mm5, %%mm7        \n\t" // pa > pb?
+            "movq %%mm7, %%mm0           \n\t"
+            // use mm7 mask to merge pa & pb
+            "pand %%mm7, %%mm5           \n\t"
+            // use mm0 mask copy to merge a & b
+            "pand %%mm0, %%mm2           \n\t"
+            "pandn %%mm4, %%mm7          \n\t"
+            "pandn %%mm1, %%mm0          \n\t"
+            "paddw %%mm5, %%mm7          \n\t"
+            "paddw %%mm2, %%mm0          \n\t"
+            //  test  ((pa <= pb)? pa:pb) <= pc
+            "pcmpgtw %%mm6, %%mm7        \n\t" // pab > pc?
+            "pxor %%mm1, %%mm1           \n\t"
+            "pand %%mm7, %%mm3           \n\t"
+            "pandn %%mm0, %%mm7          \n\t"
+            "paddw %%mm3, %%mm7          \n\t"
+            "pxor %%mm0, %%mm0           \n\t"
+            "packuswb %%mm1, %%mm7       \n\t"
+            "movq (%%esi,%%ecx,), %%mm3  \n\t" // load c=Prior(x-bpp)
+            "pand _ActiveMask, %%mm7     \n\t"
+            "movq %%mm3, %%mm2           \n\t" // load b=Prior(x) step 1
+            "paddb (%%edi,%%ecx,), %%mm7 \n\t" // add Paeth predictor with Raw(x)
+            "punpcklbw %%mm0, %%mm3      \n\t" // unpack High bytes of c
+            "movq %%mm7, (%%edi,%%ecx,)  \n\t" // write back updated value
+            "movq %%mm7, %%mm1           \n\t" // now mm1 will be used as Raw(x-bpp)
+            // do second set of 4 bytes
+            "punpckhbw %%mm0, %%mm2      \n\t" // unpack Low bytes of b
+            "punpcklbw %%mm0, %%mm1      \n\t" // unpack Low bytes of a
+            // pav = p - a = (a + b - c) - a = b - c
+            "movq %%mm2, %%mm4           \n\t"
+            // pbv = p - b = (a + b - c) - b = a - c
+            "movq %%mm1, %%mm5           \n\t"
+            "psubw %%mm3, %%mm4          \n\t"
+            "pxor %%mm7, %%mm7           \n\t"
+            // pcv = p - c = (a + b - c) -c = (a - c) + (b - c) = pav + pbv
+            "movq %%mm4, %%mm6           \n\t"
+            "psubw %%mm3, %%mm5          \n\t"
+            // pa = abs(p-a) = abs(pav)
+            // pb = abs(p-b) = abs(pbv)
+            // pc = abs(p-c) = abs(pcv)
+            "pcmpgtw %%mm4, %%mm0        \n\t" // create mask pav bytes < 0
+            "paddw %%mm5, %%mm6          \n\t"
+            "pand %%mm4, %%mm0           \n\t" // only pav bytes < 0 in mm7
+            "pcmpgtw %%mm5, %%mm7        \n\t" // create mask pbv bytes < 0
+            "psubw %%mm0, %%mm4          \n\t"
+            "pand %%mm5, %%mm7           \n\t" // only pbv bytes < 0 in mm0
+            "psubw %%mm0, %%mm4          \n\t"
+            "psubw %%mm7, %%mm5          \n\t"
+            "pxor %%mm0, %%mm0           \n\t"
+            "pcmpgtw %%mm6, %%mm0        \n\t" // create mask pcv bytes < 0
+            "pand %%mm6, %%mm0           \n\t" // only pav bytes < 0 in mm7
+            "psubw %%mm7, %%mm5          \n\t"
+            "psubw %%mm0, %%mm6          \n\t"
+            //  test pa <= pb
+            "movq %%mm4, %%mm7           \n\t"
+            "psubw %%mm0, %%mm6          \n\t"
+            "pcmpgtw %%mm5, %%mm7        \n\t" // pa > pb?
+            "movq %%mm7, %%mm0           \n\t"
+            // use mm7 mask to merge pa & pb
+            "pand %%mm7, %%mm5           \n\t"
+            // use mm0 mask copy to merge a & b
+            "pand %%mm0, %%mm2           \n\t"
+            "pandn %%mm4, %%mm7          \n\t"
+            "pandn %%mm1, %%mm0          \n\t"
+            "paddw %%mm5, %%mm7          \n\t"
+            "paddw %%mm2, %%mm0          \n\t"
+            //  test  ((pa <= pb)? pa:pb) <= pc
+            "pcmpgtw %%mm6, %%mm7        \n\t" // pab > pc?
+            "pxor %%mm1, %%mm1           \n\t"
+            "pand %%mm7, %%mm3           \n\t"
+            "pandn %%mm0, %%mm7          \n\t"
+            "pxor %%mm1, %%mm1           \n\t"
+            "paddw %%mm3, %%mm7          \n\t"
+            "pxor %%mm0, %%mm0           \n\t"
+            // step ecx to next set of 8 bytes and repeat loop til done
+            "addl $8, %%ecx              \n\t"
+            "packuswb %%mm7, %%mm1       \n\t"
+            "paddb -8(%%edi,%%ecx,), %%mm1 \n\t" // add predictor with Raw(x)
+            "cmpl _MMXLength, %%ecx      \n\t"
+            "movq %%mm1, -8(%%edi,%%ecx,) \n\t" // write back updated value
+                                // mm1 will be used as Raw(x-bpp) next loop
+            "jb paeth_4lp                \n\t"
+
+            : "=S" (dummy_value_S),             // output regs (dummy)
+              "=D" (dummy_value_D)
+
+            : "0" (prev_row),  // esi           // input regs
+              "1" (row)        // edi
+
+            : "%ecx"                            // clobber list
+#if 0  /* %mm0, ..., %mm7 not supported by gcc 2.7.2.3 or egcs 1.1 */
+            , "%mm0", "%mm1", "%mm2", "%mm3"
+            , "%mm4", "%mm5", "%mm6", "%mm7"
+#endif
+         );
+      }
+      break;  // end 4 bpp
+
+      case 8:                          // bpp == 8
+      {
+         _ActiveMask.use  = 0x00000000ffffffffLL;
+
+         __asm__ __volatile__ (
+            "movl _dif, %%ecx            \n\t"
+// preload  "movl row, %%edi             \n\t"
+// preload  "movl prev_row, %%esi        \n\t"
+            "pxor %%mm0, %%mm0           \n\t"
+            // prime the pump:  load the first Raw(x-bpp) data set
+            "movq -8(%%edi,%%ecx,), %%mm1 \n\t" // only time should need to read
+                                       //  a=Raw(x-bpp) bytes
+         "paeth_8lp:                     \n\t"
+            // do first set of 4 bytes
+            "movq -8(%%esi,%%ecx,), %%mm3 \n\t" // read c=Prior(x-bpp) bytes
+            "punpcklbw %%mm0, %%mm1      \n\t" // unpack Low bytes of a
+            "movq (%%esi,%%ecx,), %%mm2  \n\t" // load b=Prior(x)
+            "punpcklbw %%mm0, %%mm2      \n\t" // unpack Low bytes of b
+            // pav = p - a = (a + b - c) - a = b - c
+            "movq %%mm2, %%mm4           \n\t"
+            "punpcklbw %%mm0, %%mm3      \n\t" // unpack Low bytes of c
+            // pbv = p - b = (a + b - c) - b = a - c
+            "movq %%mm1, %%mm5           \n\t"
+            "psubw %%mm3, %%mm4          \n\t"
+            "pxor %%mm7, %%mm7           \n\t"
+            // pcv = p - c = (a + b - c) -c = (a - c) + (b - c) = pav + pbv
+            "movq %%mm4, %%mm6           \n\t"
+            "psubw %%mm3, %%mm5          \n\t"
+            // pa = abs(p-a) = abs(pav)
+            // pb = abs(p-b) = abs(pbv)
+            // pc = abs(p-c) = abs(pcv)
+            "pcmpgtw %%mm4, %%mm0        \n\t" // create mask pav bytes < 0
+            "paddw %%mm5, %%mm6          \n\t"
+            "pand %%mm4, %%mm0           \n\t" // only pav bytes < 0 in mm7
+            "pcmpgtw %%mm5, %%mm7        \n\t" // create mask pbv bytes < 0
+            "psubw %%mm0, %%mm4          \n\t"
+            "pand %%mm5, %%mm7           \n\t" // only pbv bytes < 0 in mm0
+            "psubw %%mm0, %%mm4          \n\t"
+            "psubw %%mm7, %%mm5          \n\t"
+            "pxor %%mm0, %%mm0           \n\t"
+            "pcmpgtw %%mm6, %%mm0        \n\t" // create mask pcv bytes < 0
+            "pand %%mm6, %%mm0           \n\t" // only pav bytes < 0 in mm7
+            "psubw %%mm7, %%mm5          \n\t"
+            "psubw %%mm0, %%mm6          \n\t"
+            //  test pa <= pb
+            "movq %%mm4, %%mm7           \n\t"
+            "psubw %%mm0, %%mm6          \n\t"
+            "pcmpgtw %%mm5, %%mm7        \n\t" // pa > pb?
+            "movq %%mm7, %%mm0           \n\t"
+            // use mm7 mask to merge pa & pb
+            "pand %%mm7, %%mm5           \n\t"
+            // use mm0 mask copy to merge a & b
+            "pand %%mm0, %%mm2           \n\t"
+            "pandn %%mm4, %%mm7          \n\t"
+            "pandn %%mm1, %%mm0          \n\t"
+            "paddw %%mm5, %%mm7          \n\t"
+            "paddw %%mm2, %%mm0          \n\t"
+            //  test  ((pa <= pb)? pa:pb) <= pc
+            "pcmpgtw %%mm6, %%mm7        \n\t" // pab > pc?
+            "pxor %%mm1, %%mm1           \n\t"
+            "pand %%mm7, %%mm3           \n\t"
+            "pandn %%mm0, %%mm7          \n\t"
+            "paddw %%mm3, %%mm7          \n\t"
+            "pxor %%mm0, %%mm0           \n\t"
+            "packuswb %%mm1, %%mm7       \n\t"
+            "movq -8(%%esi,%%ecx,), %%mm3 \n\t" // read c=Prior(x-bpp) bytes
+            "pand _ActiveMask, %%mm7     \n\t"
+            "movq (%%esi,%%ecx,), %%mm2  \n\t" // load b=Prior(x)
+            "paddb (%%edi,%%ecx,), %%mm7 \n\t" // add Paeth predictor with Raw(x)
+            "punpckhbw %%mm0, %%mm3      \n\t" // unpack High bytes of c
+            "movq %%mm7, (%%edi,%%ecx,)  \n\t" // write back updated value
+            "movq -8(%%edi,%%ecx,), %%mm1 \n\t" // read a=Raw(x-bpp) bytes
+
+            // do second set of 4 bytes
+            "punpckhbw %%mm0, %%mm2      \n\t" // unpack High bytes of b
+            "punpckhbw %%mm0, %%mm1      \n\t" // unpack High bytes of a
+            // pav = p - a = (a + b - c) - a = b - c
+            "movq %%mm2, %%mm4           \n\t"
+            // pbv = p - b = (a + b - c) - b = a - c
+            "movq %%mm1, %%mm5           \n\t"
+            "psubw %%mm3, %%mm4          \n\t"
+            "pxor %%mm7, %%mm7           \n\t"
+            // pcv = p - c = (a + b - c) -c = (a - c) + (b - c) = pav + pbv
+            "movq %%mm4, %%mm6           \n\t"
+            "psubw %%mm3, %%mm5          \n\t"
+            // pa = abs(p-a) = abs(pav)
+            // pb = abs(p-b) = abs(pbv)
+            // pc = abs(p-c) = abs(pcv)
+            "pcmpgtw %%mm4, %%mm0        \n\t" // create mask pav bytes < 0
+            "paddw %%mm5, %%mm6          \n\t"
+            "pand %%mm4, %%mm0           \n\t" // only pav bytes < 0 in mm7
+            "pcmpgtw %%mm5, %%mm7        \n\t" // create mask pbv bytes < 0
+            "psubw %%mm0, %%mm4          \n\t"
+            "pand %%mm5, %%mm7           \n\t" // only pbv bytes < 0 in mm0
+            "psubw %%mm0, %%mm4          \n\t"
+            "psubw %%mm7, %%mm5          \n\t"
+            "pxor %%mm0, %%mm0           \n\t"
+            "pcmpgtw %%mm6, %%mm0        \n\t" // create mask pcv bytes < 0
+            "pand %%mm6, %%mm0           \n\t" // only pav bytes < 0 in mm7
+            "psubw %%mm7, %%mm5          \n\t"
+            "psubw %%mm0, %%mm6          \n\t"
+            //  test pa <= pb
+            "movq %%mm4, %%mm7           \n\t"
+            "psubw %%mm0, %%mm6          \n\t"
+            "pcmpgtw %%mm5, %%mm7        \n\t" // pa > pb?
+            "movq %%mm7, %%mm0           \n\t"
+            // use mm7 mask to merge pa & pb
+            "pand %%mm7, %%mm5           \n\t"
+            // use mm0 mask copy to merge a & b
+            "pand %%mm0, %%mm2           \n\t"
+            "pandn %%mm4, %%mm7          \n\t"
+            "pandn %%mm1, %%mm0          \n\t"
+            "paddw %%mm5, %%mm7          \n\t"
+            "paddw %%mm2, %%mm0          \n\t"
+            //  test  ((pa <= pb)? pa:pb) <= pc
+            "pcmpgtw %%mm6, %%mm7        \n\t" // pab > pc?
+            "pxor %%mm1, %%mm1           \n\t"
+            "pand %%mm7, %%mm3           \n\t"
+            "pandn %%mm0, %%mm7          \n\t"
+            "pxor %%mm1, %%mm1           \n\t"
+            "paddw %%mm3, %%mm7          \n\t"
+            "pxor %%mm0, %%mm0           \n\t"
+            // step ecx to next set of 8 bytes and repeat loop til done
+            "addl $8, %%ecx              \n\t"
+            "packuswb %%mm7, %%mm1       \n\t"
+            "paddb -8(%%edi,%%ecx,), %%mm1 \n\t" // add Paeth predictor with Raw(x)
+            "cmpl _MMXLength, %%ecx      \n\t"
+            "movq %%mm1, -8(%%edi,%%ecx,) \n\t" // write back updated value
+                            // mm1 will be used as Raw(x-bpp) next loop
+            "jb paeth_8lp                \n\t"
+
+            : "=S" (dummy_value_S),             // output regs (dummy)
+              "=D" (dummy_value_D)
+
+            : "0" (prev_row),  // esi           // input regs
+              "1" (row)        // edi
+
+            : "%ecx"                            // clobber list
+#if 0  /* %mm0, ..., %mm7 not supported by gcc 2.7.2.3 or egcs 1.1 */
+            , "%mm0", "%mm1", "%mm2", "%mm3"
+            , "%mm4", "%mm5", "%mm6", "%mm7"
+#endif
+         );
+      }
+      break;  // end 8 bpp
+
+      case 1:                // bpp = 1
+      case 2:                // bpp = 2
+      default:               // bpp > 8
+      {
+         __asm__ __volatile__ (
+#ifdef __PIC__
+            "pushl %%ebx                 \n\t" // save Global Offset Table index
+#endif
+            "movl _dif, %%ebx            \n\t"
+            "cmpl _FullLength, %%ebx     \n\t"
+            "jnb paeth_dend              \n\t"
+
+// preload  "movl row, %%edi             \n\t"
+// preload  "movl prev_row, %%esi        \n\t"
+            // do Paeth decode for remaining bytes
+            "movl %%ebx, %%edx           \n\t"
+// preload  "subl bpp, %%edx             \n\t" // (bpp is preloaded into ecx)
+            "subl %%ecx, %%edx           \n\t" // edx = ebx - bpp
+            "xorl %%ecx, %%ecx           \n\t" // zero ecx before using cl & cx
+
+         "paeth_dlp:                     \n\t"
+            "xorl %%eax, %%eax           \n\t"
+            // pav = p - a = (a + b - c) - a = b - c
+            "movb (%%esi,%%ebx,), %%al   \n\t" // load Prior(x) into al
+            "movb (%%esi,%%edx,), %%cl   \n\t" // load Prior(x-bpp) into cl
+            "subl %%ecx, %%eax           \n\t" // subtract Prior(x-bpp)
+            "movl %%eax, _patemp         \n\t" // Save pav for later use
+            "xorl %%eax, %%eax           \n\t"
+            // pbv = p - b = (a + b - c) - b = a - c
+            "movb (%%edi,%%edx,), %%al   \n\t" // load Raw(x-bpp) into al
+            "subl %%ecx, %%eax           \n\t" // subtract Prior(x-bpp)
+            "movl %%eax, %%ecx           \n\t"
+            // pcv = p - c = (a + b - c) -c = (a - c) + (b - c) = pav + pbv
+            "addl _patemp, %%eax         \n\t" // pcv = pav + pbv
+            // pc = abs(pcv)
+            "testl $0x80000000, %%eax    \n\t"
+            "jz paeth_dpca               \n\t"
+            "negl %%eax                  \n\t" // reverse sign of neg values
+
+         "paeth_dpca:                    \n\t"
+            "movl %%eax, _pctemp         \n\t" // save pc for later use
+            // pb = abs(pbv)
+            "testl $0x80000000, %%ecx    \n\t"
+            "jz paeth_dpba               \n\t"
+            "negl %%ecx                  \n\t" // reverse sign of neg values
+
+         "paeth_dpba:                    \n\t"
+            "movl %%ecx, _pbtemp         \n\t" // save pb for later use
+            // pa = abs(pav)
+            "movl _patemp, %%eax         \n\t"
+            "testl $0x80000000, %%eax    \n\t"
+            "jz paeth_dpaa               \n\t"
+            "negl %%eax                  \n\t" // reverse sign of neg values
+
+         "paeth_dpaa:                    \n\t"
+            "movl %%eax, _patemp         \n\t" // save pa for later use
+            // test if pa <= pb
+            "cmpl %%ecx, %%eax           \n\t"
+            "jna paeth_dabb              \n\t"
+            // pa > pb; now test if pb <= pc
+            "cmpl _pctemp, %%ecx         \n\t"
+            "jna paeth_dbbc              \n\t"
+            // pb > pc; Raw(x) = Paeth(x) + Prior(x-bpp)
+            "movb (%%esi,%%edx,), %%cl   \n\t" // load Prior(x-bpp) into cl
+            "jmp paeth_dpaeth            \n\t"
+
+         "paeth_dbbc:                    \n\t"
+            // pb <= pc; Raw(x) = Paeth(x) + Prior(x)
+            "movb (%%esi,%%ebx,), %%cl   \n\t" // load Prior(x) into cl
+            "jmp paeth_dpaeth            \n\t"
+
+         "paeth_dabb:                    \n\t"
+            // pa <= pb; now test if pa <= pc
+            "cmpl _pctemp, %%eax         \n\t"
+            "jna paeth_dabc              \n\t"
+            // pa > pc; Raw(x) = Paeth(x) + Prior(x-bpp)
+            "movb (%%esi,%%edx,), %%cl   \n\t" // load Prior(x-bpp) into cl
+            "jmp paeth_dpaeth            \n\t"
+
+         "paeth_dabc:                    \n\t"
+            // pa <= pc; Raw(x) = Paeth(x) + Raw(x-bpp)
+            "movb (%%edi,%%edx,), %%cl   \n\t" // load Raw(x-bpp) into cl
+
+         "paeth_dpaeth:                  \n\t"
+            "incl %%ebx                  \n\t"
+            "incl %%edx                  \n\t"
+            // Raw(x) = (Paeth(x) + Paeth_Predictor( a, b, c )) mod 256
+            "addb %%cl, -1(%%edi,%%ebx,) \n\t"
+            "cmpl _FullLength, %%ebx     \n\t"
+            "jb paeth_dlp                \n\t"
+
+         "paeth_dend:                    \n\t"
+#ifdef __PIC__
+            "popl %%ebx                  \n\t" // index to Global Offset Table
+#endif
+
+            : "=c" (dummy_value_c),            // output regs (dummy)
+              "=S" (dummy_value_S),
+              "=D" (dummy_value_D)
+
+            : "0" (bpp),       // ecx          // input regs
+              "1" (prev_row),  // esi
+              "2" (row)        // edi
+
+            : "%eax", "%edx"                   // clobber list
+#ifndef __PIC__
+            , "%ebx"
+#endif
+         );
+      }
+      return;                   // No need to go further with this one
+
+   } // end switch (bpp)
+
+   __asm__ __volatile__ (
+      // MMX acceleration complete; now do clean-up
+      // check if any remaining bytes left to decode
+#ifdef __PIC__
+      "pushl %%ebx                 \n\t" // save index to Global Offset Table
+#endif
+      "movl _MMXLength, %%ebx      \n\t"
+      "cmpl _FullLength, %%ebx     \n\t"
+      "jnb paeth_end               \n\t"
+//pre "movl row, %%edi             \n\t"
+//pre "movl prev_row, %%esi        \n\t"
+      // do Paeth decode for remaining bytes
+      "movl %%ebx, %%edx           \n\t"
+//pre "subl bpp, %%edx             \n\t" // (bpp is preloaded into ecx)
+      "subl %%ecx, %%edx           \n\t" // edx = ebx - bpp
+      "xorl %%ecx, %%ecx           \n\t" // zero ecx before using cl & cx below
+
+   "paeth_lp2:                     \n\t"
+      "xorl %%eax, %%eax           \n\t"
+      // pav = p - a = (a + b - c) - a = b - c
+      "movb (%%esi,%%ebx,), %%al   \n\t" // load Prior(x) into al
+      "movb (%%esi,%%edx,), %%cl   \n\t" // load Prior(x-bpp) into cl
+      "subl %%ecx, %%eax           \n\t" // subtract Prior(x-bpp)
+      "movl %%eax, _patemp         \n\t" // Save pav for later use
+      "xorl %%eax, %%eax           \n\t"
+      // pbv = p - b = (a + b - c) - b = a - c
+      "movb (%%edi,%%edx,), %%al   \n\t" // load Raw(x-bpp) into al
+      "subl %%ecx, %%eax           \n\t" // subtract Prior(x-bpp)
+      "movl %%eax, %%ecx           \n\t"
+      // pcv = p - c = (a + b - c) -c = (a - c) + (b - c) = pav + pbv
+      "addl _patemp, %%eax         \n\t" // pcv = pav + pbv
+      // pc = abs(pcv)
+      "testl $0x80000000, %%eax    \n\t"
+      "jz paeth_pca2               \n\t"
+      "negl %%eax                  \n\t" // reverse sign of neg values
+
+   "paeth_pca2:                    \n\t"
+      "movl %%eax, _pctemp         \n\t" // save pc for later use
+      // pb = abs(pbv)
+      "testl $0x80000000, %%ecx    \n\t"
+      "jz paeth_pba2               \n\t"
+      "negl %%ecx                  \n\t" // reverse sign of neg values
+
+   "paeth_pba2:                    \n\t"
+      "movl %%ecx, _pbtemp         \n\t" // save pb for later use
+      // pa = abs(pav)
+      "movl _patemp, %%eax         \n\t"
+      "testl $0x80000000, %%eax    \n\t"
+      "jz paeth_paa2               \n\t"
+      "negl %%eax                  \n\t" // reverse sign of neg values
+
+   "paeth_paa2:                    \n\t"
+      "movl %%eax, _patemp         \n\t" // save pa for later use
+      // test if pa <= pb
+      "cmpl %%ecx, %%eax           \n\t"
+      "jna paeth_abb2              \n\t"
+      // pa > pb; now test if pb <= pc
+      "cmpl _pctemp, %%ecx         \n\t"
+      "jna paeth_bbc2              \n\t"
+      // pb > pc; Raw(x) = Paeth(x) + Prior(x-bpp)
+      "movb (%%esi,%%edx,), %%cl   \n\t" // load Prior(x-bpp) into cl
+      "jmp paeth_paeth2            \n\t"
+
+   "paeth_bbc2:                    \n\t"
+      // pb <= pc; Raw(x) = Paeth(x) + Prior(x)
+      "movb (%%esi,%%ebx,), %%cl   \n\t" // load Prior(x) into cl
+      "jmp paeth_paeth2            \n\t"
+
+   "paeth_abb2:                    \n\t"
+      // pa <= pb; now test if pa <= pc
+      "cmpl _pctemp, %%eax         \n\t"
+      "jna paeth_abc2              \n\t"
+      // pa > pc; Raw(x) = Paeth(x) + Prior(x-bpp)
+      "movb (%%esi,%%edx,), %%cl   \n\t" // load Prior(x-bpp) into cl
+      "jmp paeth_paeth2            \n\t"
+
+   "paeth_abc2:                    \n\t"
+      // pa <= pc; Raw(x) = Paeth(x) + Raw(x-bpp)
+      "movb (%%edi,%%edx,), %%cl   \n\t" // load Raw(x-bpp) into cl
+
+   "paeth_paeth2:                  \n\t"
+      "incl %%ebx                  \n\t"
+      "incl %%edx                  \n\t"
+      // Raw(x) = (Paeth(x) + Paeth_Predictor( a, b, c )) mod 256
+      "addb %%cl, -1(%%edi,%%ebx,) \n\t"
+      "cmpl _FullLength, %%ebx     \n\t"
+      "jb paeth_lp2                \n\t"
+
+   "paeth_end:                     \n\t"
+      "EMMS                        \n\t" // end MMX; prep for poss. FP instrs.
+#ifdef __PIC__
+      "popl %%ebx                  \n\t" // restore index to Global Offset Table
+#endif
+
+      : "=c" (dummy_value_c),            // output regs (dummy)
+        "=S" (dummy_value_S),
+        "=D" (dummy_value_D)
+
+      : "0" (bpp),       // ecx          // input regs
+        "1" (prev_row),  // esi
+        "2" (row)        // edi
+
+      : "%eax", "%edx"                   // clobber list (no input regs!)
+#ifndef __PIC__
+      , "%ebx"
+#endif
+   );
+
+} /* end png_read_filter_row_mmx_paeth() */
+#endif
+
+
+
+
+#ifdef PNG_THREAD_UNSAFE_OK
+//===========================================================================//
+//                                                                           //
+//           P N G _ R E A D _ F I L T E R _ R O W _ M M X _ S U B           //
+//                                                                           //
+//===========================================================================//
+
+// Optimized code for PNG Sub filter decoder
+
+static void /* PRIVATE */
+png_read_filter_row_mmx_sub(png_row_infop row_info, png_bytep row)
+{
+   int bpp;
+   int dummy_value_a;
+   int dummy_value_D;
+
+   bpp = (row_info->pixel_depth + 7) >> 3;   // calc number of bytes per pixel
+   _FullLength = row_info->rowbytes - bpp;   // number of bytes to filter
+
+   __asm__ __volatile__ (
+//pre "movl row, %%edi             \n\t"
+      "movl %%edi, %%esi           \n\t" // lp = row
+//pre "movl bpp, %%eax             \n\t"
+      "addl %%eax, %%edi           \n\t" // rp = row + bpp
+//irr "xorl %%eax, %%eax           \n\t"
+      // get # of bytes to alignment
+      "movl %%edi, _dif            \n\t" // take start of row
+      "addl $0xf, _dif             \n\t" // add 7 + 8 to incr past
+                                         //  alignment boundary
+      "xorl %%ecx, %%ecx           \n\t"
+      "andl $0xfffffff8, _dif      \n\t" // mask to alignment boundary
+      "subl %%edi, _dif            \n\t" // subtract from start ==> value
+      "jz sub_go                   \n\t" //  ecx at alignment
+
+   "sub_lp1:                       \n\t" // fix alignment
+      "movb (%%esi,%%ecx,), %%al   \n\t"
+      "addb %%al, (%%edi,%%ecx,)   \n\t"
+      "incl %%ecx                  \n\t"
+      "cmpl _dif, %%ecx            \n\t"
+      "jb sub_lp1                  \n\t"
+
+   "sub_go:                        \n\t"
+      "movl _FullLength, %%eax     \n\t"
+      "movl %%eax, %%edx           \n\t"
+      "subl %%ecx, %%edx           \n\t" // subtract alignment fix
+      "andl $0x00000007, %%edx     \n\t" // calc bytes over mult of 8
+      "subl %%edx, %%eax           \n\t" // drop over bytes from length
+      "movl %%eax, _MMXLength      \n\t"
+
+      : "=a" (dummy_value_a),   // 0      // output regs (dummy)
+        "=D" (dummy_value_D)    // 1
+
+      : "0" (bpp),              // eax    // input regs
+        "1" (row)               // edi
+
+      : "%ebx", "%ecx", "%edx"            // clobber list
+      , "%esi"
+
+#if 0  /* MMX regs (%mm0, etc.) not supported by gcc 2.7.2.3 or egcs 1.1 */
+      , "%mm0", "%mm1", "%mm2", "%mm3"
+      , "%mm4", "%mm5", "%mm6", "%mm7"
+#endif
+   );
+
+   // now do the math for the rest of the row
+   switch (bpp)
+   {
+      case 3:
+      {
+         _ActiveMask.use  = 0x0000ffffff000000LL;
+         _ShiftBpp.use = 24;       // == 3 * 8
+         _ShiftRem.use  = 40;      // == 64 - 24
+
+         __asm__ __volatile__ (
+// preload  "movl row, %%edi              \n\t"
+            "movq _ActiveMask, %%mm7       \n\t" // load _ActiveMask for 2nd
+                                                //  active byte group
+            "movl %%edi, %%esi            \n\t" // lp = row
+// preload  "movl bpp, %%eax              \n\t"
+            "addl %%eax, %%edi            \n\t" // rp = row + bpp
+            "movq %%mm7, %%mm6            \n\t"
+            "movl _dif, %%edx             \n\t"
+            "psllq _ShiftBpp, %%mm6       \n\t" // move mask in mm6 to cover
+                                                //  3rd active byte group
+            // prime the pump:  load the first Raw(x-bpp) data set
+            "movq -8(%%edi,%%edx,), %%mm1 \n\t"
+
+         "sub_3lp:                        \n\t" // shift data for adding first
+            "psrlq _ShiftRem, %%mm1       \n\t" //  bpp bytes (no need for mask;
+                                                //  shift clears inactive bytes)
+            // add 1st active group
+            "movq (%%edi,%%edx,), %%mm0   \n\t"
+            "paddb %%mm1, %%mm0           \n\t"
+
+            // add 2nd active group
+            "movq %%mm0, %%mm1            \n\t" // mov updated Raws to mm1
+            "psllq _ShiftBpp, %%mm1       \n\t" // shift data to pos. correctly
+            "pand %%mm7, %%mm1            \n\t" // mask to use 2nd active group
+            "paddb %%mm1, %%mm0           \n\t"
+
+            // add 3rd active group
+            "movq %%mm0, %%mm1            \n\t" // mov updated Raws to mm1
+            "psllq _ShiftBpp, %%mm1       \n\t" // shift data to pos. correctly
+            "pand %%mm6, %%mm1            \n\t" // mask to use 3rd active group
+            "addl $8, %%edx               \n\t"
+            "paddb %%mm1, %%mm0           \n\t"
+
+            "cmpl _MMXLength, %%edx       \n\t"
+            "movq %%mm0, -8(%%edi,%%edx,) \n\t" // write updated Raws to array
+            "movq %%mm0, %%mm1            \n\t" // prep 1st add at top of loop
+            "jb sub_3lp                   \n\t"
+
+            : "=a" (dummy_value_a),   // 0      // output regs (dummy)
+              "=D" (dummy_value_D)    // 1
+
+            : "0" (bpp),              // eax    // input regs
+              "1" (row)               // edi
+
+            : "%edx", "%esi"                    // clobber list
+#if 0  /* MMX regs (%mm0, etc.) not supported by gcc 2.7.2.3 or egcs 1.1 */
+            , "%mm0", "%mm1", "%mm6", "%mm7"
+#endif
+         );
+      }
+      break;
+
+      case 1:
+      {
+         __asm__ __volatile__ (
+            "movl _dif, %%edx            \n\t"
+// preload  "movl row, %%edi             \n\t"
+            "cmpl _FullLength, %%edx     \n\t"
+            "jnb sub_1end                \n\t"
+            "movl %%edi, %%esi           \n\t" // lp = row
+            "xorl %%eax, %%eax           \n\t"
+// preload  "movl bpp, %%eax             \n\t"
+            "addl %%eax, %%edi           \n\t" // rp = row + bpp
+
+         "sub_1lp:                       \n\t"
+            "movb (%%esi,%%edx,), %%al   \n\t"
+            "addb %%al, (%%edi,%%edx,)   \n\t"
+            "incl %%edx                  \n\t"
+            "cmpl _FullLength, %%edx     \n\t"
+            "jb sub_1lp                  \n\t"
+
+         "sub_1end:                      \n\t"
+
+            : "=a" (dummy_value_a),   // 0      // output regs (dummy)
+              "=D" (dummy_value_D)    // 1
+
+            : "0" (bpp),              // eax    // input regs
+              "1" (row)               // edi
+
+            : "%edx", "%esi"                    // clobber list
+         );
+      }
+      return;
+
+      case 6:
+      case 4:
+      //case 7:   // GRR BOGUS
+      //case 5:   // GRR BOGUS
+      {
+         _ShiftBpp.use = bpp << 3;
+         _ShiftRem.use = 64 - _ShiftBpp.use;
+
+         __asm__ __volatile__ (
+// preload  "movl row, %%edi              \n\t"
+            "movl _dif, %%edx             \n\t"
+            "movl %%edi, %%esi            \n\t" // lp = row
+// preload  "movl bpp, %%eax              \n\t"
+            "addl %%eax, %%edi            \n\t" // rp = row + bpp
+
+            // prime the pump:  load the first Raw(x-bpp) data set
+            "movq -8(%%edi,%%edx,), %%mm1 \n\t"
+
+         "sub_4lp:                        \n\t" // shift data for adding first
+            "psrlq _ShiftRem, %%mm1       \n\t" //  bpp bytes (no need for mask;
+                                                //  shift clears inactive bytes)
+            "movq (%%edi,%%edx,), %%mm0   \n\t"
+            "paddb %%mm1, %%mm0           \n\t"
+
+            // add 2nd active group
+            "movq %%mm0, %%mm1            \n\t" // mov updated Raws to mm1
+            "psllq _ShiftBpp, %%mm1       \n\t" // shift data to pos. correctly
+            "addl $8, %%edx               \n\t"
+            "paddb %%mm1, %%mm0           \n\t"
+
+            "cmpl _MMXLength, %%edx       \n\t"
+            "movq %%mm0, -8(%%edi,%%edx,) \n\t"
+            "movq %%mm0, %%mm1            \n\t" // prep 1st add at top of loop
+            "jb sub_4lp                   \n\t"
+
+            : "=a" (dummy_value_a),   // 0      // output regs (dummy)
+              "=D" (dummy_value_D)    // 1
+
+            : "0" (bpp),              // eax    // input regs
+              "1" (row)               // edi
+
+            : "%edx", "%esi"                    // clobber list
+#if 0  /* MMX regs (%mm0, etc.) not supported by gcc 2.7.2.3 or egcs 1.1 */
+            , "%mm0", "%mm1"
+#endif
+         );
+      }
+      break;
+
+      case 2:
+      {
+         _ActiveMask.use = 0x00000000ffff0000LL;
+         _ShiftBpp.use = 16;       // == 2 * 8
+         _ShiftRem.use = 48;       // == 64 - 16
+
+         __asm__ __volatile__ (
+            "movq _ActiveMask, %%mm7      \n\t" // load _ActiveMask for 2nd
+                                                //  active byte group
+            "movl _dif, %%edx             \n\t"
+            "movq %%mm7, %%mm6            \n\t"
+// preload  "movl row, %%edi              \n\t"
+            "psllq _ShiftBpp, %%mm6       \n\t" // move mask in mm6 to cover
+                                                //  3rd active byte group
+            "movl %%edi, %%esi            \n\t" // lp = row
+            "movq %%mm6, %%mm5            \n\t"
+// preload  "movl bpp, %%eax              \n\t"
+            "addl %%eax, %%edi            \n\t" // rp = row + bpp
+            "psllq _ShiftBpp, %%mm5       \n\t" // move mask in mm5 to cover
+                                                //  4th active byte group
+            // prime the pump:  load the first Raw(x-bpp) data set
+            "movq -8(%%edi,%%edx,), %%mm1 \n\t"
+
+         "sub_2lp:                        \n\t" // shift data for adding first
+            "psrlq _ShiftRem, %%mm1       \n\t" //  bpp bytes (no need for mask;
+                                                //  shift clears inactive bytes)
+            // add 1st active group
+            "movq (%%edi,%%edx,), %%mm0   \n\t"
+            "paddb %%mm1, %%mm0           \n\t"
+
+            // add 2nd active group
+            "movq %%mm0, %%mm1            \n\t" // mov updated Raws to mm1
+            "psllq _ShiftBpp, %%mm1       \n\t" // shift data to pos. correctly
+            "pand %%mm7, %%mm1            \n\t" // mask to use 2nd active group
+            "paddb %%mm1, %%mm0           \n\t"
+
+            // add 3rd active group
+            "movq %%mm0, %%mm1            \n\t" // mov updated Raws to mm1
+            "psllq _ShiftBpp, %%mm1       \n\t" // shift data to pos. correctly
+            "pand %%mm6, %%mm1            \n\t" // mask to use 3rd active group
+            "paddb %%mm1, %%mm0           \n\t"
+
+            // add 4th active group
+            "movq %%mm0, %%mm1            \n\t" // mov updated Raws to mm1
+            "psllq _ShiftBpp, %%mm1       \n\t" // shift data to pos. correctly
+            "pand %%mm5, %%mm1            \n\t" // mask to use 4th active group
+            "addl $8, %%edx               \n\t"
+            "paddb %%mm1, %%mm0           \n\t"
+            "cmpl _MMXLength, %%edx       \n\t"
+            "movq %%mm0, -8(%%edi,%%edx,) \n\t" // write updated Raws to array
+            "movq %%mm0, %%mm1            \n\t" // prep 1st add at top of loop
+            "jb sub_2lp                   \n\t"
+
+            : "=a" (dummy_value_a),   // 0      // output regs (dummy)
+              "=D" (dummy_value_D)    // 1
+
+            : "0" (bpp),              // eax    // input regs
+              "1" (row)               // edi
+
+            : "%edx", "%esi"                    // clobber list
+#if 0  /* MMX regs (%mm0, etc.) not supported by gcc 2.7.2.3 or egcs 1.1 */
+            , "%mm0", "%mm1", "%mm5", "%mm6", "%mm7"
+#endif
+         );
+      }
+      break;
+
+      case 8:
+      {
+         __asm__ __volatile__ (
+// preload  "movl row, %%edi              \n\t"
+            "movl _dif, %%edx             \n\t"
+            "movl %%edi, %%esi            \n\t" // lp = row
+// preload  "movl bpp, %%eax              \n\t"
+            "addl %%eax, %%edi            \n\t" // rp = row + bpp
+            "movl _MMXLength, %%ecx       \n\t"
+
+            // prime the pump:  load the first Raw(x-bpp) data set
+            "movq -8(%%edi,%%edx,), %%mm7 \n\t"
+            "andl $0x0000003f, %%ecx      \n\t" // calc bytes over mult of 64
+
+         "sub_8lp:                        \n\t"
+            "movq (%%edi,%%edx,), %%mm0   \n\t" // load Sub(x) for 1st 8 bytes
+            "paddb %%mm7, %%mm0           \n\t"
+            "movq 8(%%edi,%%edx,), %%mm1  \n\t" // load Sub(x) for 2nd 8 bytes
+            "movq %%mm0, (%%edi,%%edx,)   \n\t" // write Raw(x) for 1st 8 bytes
+
+            // Now mm0 will be used as Raw(x-bpp) for the 2nd group of 8 bytes.
+            // This will be repeated for each group of 8 bytes with the 8th
+            // group being used as the Raw(x-bpp) for the 1st group of the
+            // next loop.
+
+            "paddb %%mm0, %%mm1           \n\t"
+            "movq 16(%%edi,%%edx,), %%mm2 \n\t" // load Sub(x) for 3rd 8 bytes
+            "movq %%mm1, 8(%%edi,%%edx,)  \n\t" // write Raw(x) for 2nd 8 bytes
+            "paddb %%mm1, %%mm2           \n\t"
+            "movq 24(%%edi,%%edx,), %%mm3 \n\t" // load Sub(x) for 4th 8 bytes
+            "movq %%mm2, 16(%%edi,%%edx,) \n\t" // write Raw(x) for 3rd 8 bytes
+            "paddb %%mm2, %%mm3           \n\t"
+            "movq 32(%%edi,%%edx,), %%mm4 \n\t" // load Sub(x) for 5th 8 bytes
+            "movq %%mm3, 24(%%edi,%%edx,) \n\t" // write Raw(x) for 4th 8 bytes
+            "paddb %%mm3, %%mm4           \n\t"
+            "movq 40(%%edi,%%edx,), %%mm5 \n\t" // load Sub(x) for 6th 8 bytes
+            "movq %%mm4, 32(%%edi,%%edx,) \n\t" // write Raw(x) for 5th 8 bytes
+            "paddb %%mm4, %%mm5           \n\t"
+            "movq 48(%%edi,%%edx,), %%mm6 \n\t" // load Sub(x) for 7th 8 bytes
+            "movq %%mm5, 40(%%edi,%%edx,) \n\t" // write Raw(x) for 6th 8 bytes
+            "paddb %%mm5, %%mm6           \n\t"
+            "movq 56(%%edi,%%edx,), %%mm7 \n\t" // load Sub(x) for 8th 8 bytes
+            "movq %%mm6, 48(%%edi,%%edx,) \n\t" // write Raw(x) for 7th 8 bytes
+            "addl $64, %%edx              \n\t"
+            "paddb %%mm6, %%mm7           \n\t"
+            "cmpl %%ecx, %%edx            \n\t"
+            "movq %%mm7, -8(%%edi,%%edx,) \n\t" // write Raw(x) for 8th 8 bytes
+            "jb sub_8lp                   \n\t"
+
+            "cmpl _MMXLength, %%edx       \n\t"
+            "jnb sub_8lt8                 \n\t"
+
+         "sub_8lpA:                       \n\t"
+            "movq (%%edi,%%edx,), %%mm0   \n\t"
+            "addl $8, %%edx               \n\t"
+            "paddb %%mm7, %%mm0           \n\t"
+            "cmpl _MMXLength, %%edx       \n\t"
+            "movq %%mm0, -8(%%edi,%%edx,) \n\t" // -8 to offset early addl edx
+            "movq %%mm0, %%mm7            \n\t" // move calculated Raw(x) data
+                                                //  to mm1 to be new Raw(x-bpp)
+                                                //  for next loop
+            "jb sub_8lpA                  \n\t"
+
+         "sub_8lt8:                       \n\t"
+
+            : "=a" (dummy_value_a),   // 0      // output regs (dummy)
+              "=D" (dummy_value_D)    // 1
+
+            : "0" (bpp),              // eax    // input regs
+              "1" (row)               // edi
+
+            : "%ecx", "%edx", "%esi"            // clobber list
+#if 0  /* MMX regs (%mm0, etc.) not supported by gcc 2.7.2.3 or egcs 1.1 */
+            , "%mm0", "%mm1", "%mm2", "%mm3", "%mm4", "%mm5", "%mm6", "%mm7"
+#endif
+         );
+      }
+      break;
+
+      default:                // bpp greater than 8 bytes   GRR BOGUS
+      {
+         __asm__ __volatile__ (
+            "movl _dif, %%edx             \n\t"
+// preload  "movl row, %%edi              \n\t"
+            "movl %%edi, %%esi            \n\t" // lp = row
+// preload  "movl bpp, %%eax              \n\t"
+            "addl %%eax, %%edi            \n\t" // rp = row + bpp
+
+         "sub_Alp:                        \n\t"
+            "movq (%%edi,%%edx,), %%mm0   \n\t"
+            "movq (%%esi,%%edx,), %%mm1   \n\t"
+            "addl $8, %%edx               \n\t"
+            "paddb %%mm1, %%mm0           \n\t"
+            "cmpl _MMXLength, %%edx       \n\t"
+            "movq %%mm0, -8(%%edi,%%edx,) \n\t" // mov does not affect flags;
+                                                //  -8 to offset addl edx
+            "jb sub_Alp                   \n\t"
+
+            : "=a" (dummy_value_a),   // 0      // output regs (dummy)
+              "=D" (dummy_value_D)    // 1
+
+            : "0" (bpp),              // eax    // input regs
+              "1" (row)               // edi
+
+            : "%edx", "%esi"                    // clobber list
+#if 0  /* MMX regs (%mm0, etc.) not supported by gcc 2.7.2.3 or egcs 1.1 */
+            , "%mm0", "%mm1"
+#endif
+         );
+      }
+      break;
+
+   } // end switch (bpp)
+
+   __asm__ __volatile__ (
+      "movl _MMXLength, %%edx       \n\t"
+//pre "movl row, %%edi              \n\t"
+      "cmpl _FullLength, %%edx      \n\t"
+      "jnb sub_end                  \n\t"
+
+      "movl %%edi, %%esi            \n\t" // lp = row
+//pre "movl bpp, %%eax              \n\t"
+      "addl %%eax, %%edi            \n\t" // rp = row + bpp
+      "xorl %%eax, %%eax            \n\t"
+
+   "sub_lp2:                        \n\t"
+      "movb (%%esi,%%edx,), %%al    \n\t"
+      "addb %%al, (%%edi,%%edx,)    \n\t"
+      "incl %%edx                   \n\t"
+      "cmpl _FullLength, %%edx      \n\t"
+      "jb sub_lp2                   \n\t"
+
+   "sub_end:                        \n\t"
+      "EMMS                         \n\t" // end MMX instructions
+
+      : "=a" (dummy_value_a),   // 0      // output regs (dummy)
+        "=D" (dummy_value_D)    // 1
+
+      : "0" (bpp),              // eax    // input regs
+        "1" (row)               // edi
+
+      : "%edx", "%esi"                    // clobber list
+   );
+
+} // end of png_read_filter_row_mmx_sub()
+#endif
+
+
+
+
+//===========================================================================//
+//                                                                           //
+//            P N G _ R E A D _ F I L T E R _ R O W _ M M X _ U P            //
+//                                                                           //
+//===========================================================================//
+
+// Optimized code for PNG Up filter decoder
+
+static void /* PRIVATE */
+png_read_filter_row_mmx_up(png_row_infop row_info, png_bytep row,
+                           png_bytep prev_row)
+{
+   png_uint_32 len;
+   int dummy_value_d;   // fix 'forbidden register 3 (dx) was spilled' error
+   int dummy_value_S;
+   int dummy_value_D;
+
+   len = row_info->rowbytes;              // number of bytes to filter
+
+   __asm__ __volatile__ (
+//pre "movl row, %%edi              \n\t"
+      // get # of bytes to alignment
+#ifdef __PIC__
+      "pushl %%ebx                  \n\t"
+#endif
+      "movl %%edi, %%ecx            \n\t"
+      "xorl %%ebx, %%ebx            \n\t"
+      "addl $0x7, %%ecx             \n\t"
+      "xorl %%eax, %%eax            \n\t"
+      "andl $0xfffffff8, %%ecx      \n\t"
+//pre "movl prev_row, %%esi         \n\t"
+      "subl %%edi, %%ecx            \n\t"
+      "jz up_go                     \n\t"
+
+   "up_lp1:                         \n\t" // fix alignment
+      "movb (%%edi,%%ebx,), %%al    \n\t"
+      "addb (%%esi,%%ebx,), %%al    \n\t"
+      "incl %%ebx                   \n\t"
+      "cmpl %%ecx, %%ebx            \n\t"
+      "movb %%al, -1(%%edi,%%ebx,)  \n\t" // mov does not affect flags; -1 to
+      "jb up_lp1                    \n\t" //  offset incl ebx
+
+   "up_go:                          \n\t"
+//pre "movl len, %%edx              \n\t"
+      "movl %%edx, %%ecx            \n\t"
+      "subl %%ebx, %%edx            \n\t" // subtract alignment fix
+      "andl $0x0000003f, %%edx      \n\t" // calc bytes over mult of 64
+      "subl %%edx, %%ecx            \n\t" // drop over bytes from length
+
+      // unrolled loop - use all MMX registers and interleave to reduce
+      // number of branch instructions (loops) and reduce partial stalls
+   "up_loop:                        \n\t"
+      "movq (%%esi,%%ebx,), %%mm1   \n\t"
+      "movq (%%edi,%%ebx,), %%mm0   \n\t"
+      "movq 8(%%esi,%%ebx,), %%mm3  \n\t"
+      "paddb %%mm1, %%mm0           \n\t"
+      "movq 8(%%edi,%%ebx,), %%mm2  \n\t"
+      "movq %%mm0, (%%edi,%%ebx,)   \n\t"
+      "paddb %%mm3, %%mm2           \n\t"
+      "movq 16(%%esi,%%ebx,), %%mm5 \n\t"
+      "movq %%mm2, 8(%%edi,%%ebx,)  \n\t"
+      "movq 16(%%edi,%%ebx,), %%mm4 \n\t"
+      "movq 24(%%esi,%%ebx,), %%mm7 \n\t"
+      "paddb %%mm5, %%mm4           \n\t"
+      "movq 24(%%edi,%%ebx,), %%mm6 \n\t"
+      "movq %%mm4, 16(%%edi,%%ebx,) \n\t"
+      "paddb %%mm7, %%mm6           \n\t"
+      "movq 32(%%esi,%%ebx,), %%mm1 \n\t"
+      "movq %%mm6, 24(%%edi,%%ebx,) \n\t"
+      "movq 32(%%edi,%%ebx,), %%mm0 \n\t"
+      "movq 40(%%esi,%%ebx,), %%mm3 \n\t"
+      "paddb %%mm1, %%mm0           \n\t"
+      "movq 40(%%edi,%%ebx,), %%mm2 \n\t"
+      "movq %%mm0, 32(%%edi,%%ebx,) \n\t"
+      "paddb %%mm3, %%mm2           \n\t"
+      "movq 48(%%esi,%%ebx,), %%mm5 \n\t"
+      "movq %%mm2, 40(%%edi,%%ebx,) \n\t"
+      "movq 48(%%edi,%%ebx,), %%mm4 \n\t"
+      "movq 56(%%esi,%%ebx,), %%mm7 \n\t"
+      "paddb %%mm5, %%mm4           \n\t"
+      "movq 56(%%edi,%%ebx,), %%mm6 \n\t"
+      "movq %%mm4, 48(%%edi,%%ebx,) \n\t"
+      "addl $64, %%ebx              \n\t"
+      "paddb %%mm7, %%mm6           \n\t"
+      "cmpl %%ecx, %%ebx            \n\t"
+      "movq %%mm6, -8(%%edi,%%ebx,) \n\t" // (+56)movq does not affect flags;
+      "jb up_loop                   \n\t" //  -8 to offset addl ebx
+
+      "cmpl $0, %%edx               \n\t" // test for bytes over mult of 64
+      "jz up_end                    \n\t"
+
+      "cmpl $8, %%edx               \n\t" // test for less than 8 bytes
+      "jb up_lt8                    \n\t" //  [added by lcreeve@netins.net]
+
+      "addl %%edx, %%ecx            \n\t"
+      "andl $0x00000007, %%edx      \n\t" // calc bytes over mult of 8
+      "subl %%edx, %%ecx            \n\t" // drop over bytes from length
+      "jz up_lt8                    \n\t"
+
+   "up_lpA:                         \n\t" // use MMX regs to update 8 bytes sim.
+      "movq (%%esi,%%ebx,), %%mm1   \n\t"
+      "movq (%%edi,%%ebx,), %%mm0   \n\t"
+      "addl $8, %%ebx               \n\t"
+      "paddb %%mm1, %%mm0           \n\t"
+      "cmpl %%ecx, %%ebx            \n\t"
+      "movq %%mm0, -8(%%edi,%%ebx,) \n\t" // movq does not affect flags; -8 to
+      "jb up_lpA                    \n\t" //  offset add ebx
+      "cmpl $0, %%edx               \n\t" // test for bytes over mult of 8
+      "jz up_end                    \n\t"
+
+   "up_lt8:                         \n\t"
+      "xorl %%eax, %%eax            \n\t"
+      "addl %%edx, %%ecx            \n\t" // move over byte count into counter
+
+   "up_lp2:                         \n\t" // use x86 regs for remaining bytes
+      "movb (%%edi,%%ebx,), %%al    \n\t"
+      "addb (%%esi,%%ebx,), %%al    \n\t"
+      "incl %%ebx                   \n\t"
+      "cmpl %%ecx, %%ebx            \n\t"
+      "movb %%al, -1(%%edi,%%ebx,)  \n\t" // mov does not affect flags; -1 to
+      "jb up_lp2                    \n\t" //  offset inc ebx
+
+   "up_end:                         \n\t"
+      "EMMS                         \n\t" // conversion of filtered row complete
+#ifdef __PIC__
+      "popl %%ebx                   \n\t"
+#endif
+
+      : "=d" (dummy_value_d),   // 0      // output regs (dummy)
+        "=S" (dummy_value_S),   // 1
+        "=D" (dummy_value_D)    // 2
+
+      : "0" (len),              // edx    // input regs
+        "1" (prev_row),         // esi
+        "2" (row)               // edi
+
+      : "%eax", "%ebx", "%ecx"            // clobber list (no input regs!)
+
+#if 0  /* MMX regs (%mm0, etc.) not supported by gcc 2.7.2.3 or egcs 1.1 */
+      , "%mm0", "%mm1", "%mm2", "%mm3"
+      , "%mm4", "%mm5", "%mm6", "%mm7"
+#endif
+   );
+
+} // end of png_read_filter_row_mmx_up()
+
+#endif /* PNG_ASSEMBLER_CODE_SUPPORTED */
+
+
+
+
+/*===========================================================================*/
+/*                                                                           */
+/*                   P N G _ R E A D _ F I L T E R _ R O W                   */
+/*                                                                           */
+/*===========================================================================*/
+
+
+/* Optimized png_read_filter_row routines */
+
+void /* PRIVATE */
+png_read_filter_row(png_structp png_ptr, png_row_infop row_info, png_bytep
+   row, png_bytep prev_row, int filter)
+{
+#ifdef PNG_DEBUG
+   char filnm[10];
+#endif
+
+#if defined(PNG_ASSEMBLER_CODE_SUPPORTED)
+/* GRR:  these are superseded by png_ptr->asm_flags: */
+#define UseMMX_sub    1   // GRR:  converted 20000730
+#define UseMMX_up     1   // GRR:  converted 20000729
+#define UseMMX_avg    1   // GRR:  converted 20000828 (+ 16-bit bugfix 20000916)
+#define UseMMX_paeth  1   // GRR:  converted 20000828
+
+   if (_mmx_supported == 2) {
+       /* this should have happened in png_init_mmx_flags() already */
+#if !defined(PNG_1_0_X)
+       png_warning(png_ptr, "asm_flags may not have been initialized");
+#endif
+       png_mmx_support();
+   }
+#endif /* PNG_ASSEMBLER_CODE_SUPPORTED */
+
+#ifdef PNG_DEBUG
+   png_debug(1, "in png_read_filter_row (pnggccrd.c)\n");
+   switch (filter)
+   {
+      case 0: sprintf(filnm, "none");
+         break;
+      case 1: sprintf(filnm, "sub-%s",
+#if defined(PNG_ASSEMBLER_CODE_SUPPORTED) && defined(PNG_THREAD_UNSAFE_OK)
+#if !defined(PNG_1_0_X)
+        (png_ptr->asm_flags & PNG_ASM_FLAG_MMX_READ_FILTER_SUB)? "MMX" : 
+#endif
+#endif
+"x86");
+         break;
+      case 2: sprintf(filnm, "up-%s",
+#ifdef PNG_ASSEMBLER_CODE_SUPPORTED
+#if !defined(PNG_1_0_X)
+        (png_ptr->asm_flags & PNG_ASM_FLAG_MMX_READ_FILTER_UP)? "MMX" :
+#endif
+#endif
+ "x86");
+         break;
+      case 3: sprintf(filnm, "avg-%s",
+#if defined(PNG_ASSEMBLER_CODE_SUPPORTED) && defined(PNG_THREAD_UNSAFE_OK)
+#if !defined(PNG_1_0_X)
+        (png_ptr->asm_flags & PNG_ASM_FLAG_MMX_READ_FILTER_AVG)? "MMX" :
+#endif
+#endif
+ "x86");
+         break;
+      case 4: sprintf(filnm, "Paeth-%s",
+#if defined(PNG_ASSEMBLER_CODE_SUPPORTED) && defined(PNG_THREAD_UNSAFE_OK)
+#if !defined(PNG_1_0_X)
+        (png_ptr->asm_flags & PNG_ASM_FLAG_MMX_READ_FILTER_PAETH)? "MMX":
+#endif
+#endif
+"x86");
+         break;
+      default: sprintf(filnm, "unknw");
+         break;
+   }
+   png_debug2(0, "row_number=%5ld, %5s, ", png_ptr->row_number, filnm);
+   png_debug1(0, "row=0x%08lx, ", (unsigned long)row);
+   png_debug2(0, "pixdepth=%2d, bytes=%d, ", (int)row_info->pixel_depth,
+      (int)((row_info->pixel_depth + 7) >> 3));
+   png_debug1(0,"rowbytes=%8ld\n", row_info->rowbytes);
+#endif /* PNG_DEBUG */
+
+   switch (filter)
+   {
+      case PNG_FILTER_VALUE_NONE:
+         break;
+
+      case PNG_FILTER_VALUE_SUB:
+#if defined(PNG_ASSEMBLER_CODE_SUPPORTED) && defined(PNG_THREAD_UNSAFE_OK)
+#if !defined(PNG_1_0_X)
+         if ((png_ptr->asm_flags & PNG_ASM_FLAG_MMX_READ_FILTER_SUB) &&
+             (row_info->pixel_depth >= png_ptr->mmx_bitdepth_threshold) &&
+             (row_info->rowbytes >= png_ptr->mmx_rowbytes_threshold))
+#else
+         if (_mmx_supported)
+#endif
+         {
+            png_read_filter_row_mmx_sub(row_info, row);
+         }
+         else
+#endif /* PNG_ASSEMBLER_CODE_SUPPORTED */
+         {
+            png_uint_32 i;
+            png_uint_32 istop = row_info->rowbytes;
+            png_uint_32 bpp = (row_info->pixel_depth + 7) >> 3;
+            png_bytep rp = row + bpp;
+            png_bytep lp = row;
+
+            for (i = bpp; i < istop; i++)
+            {
+               *rp = (png_byte)(((int)(*rp) + (int)(*lp++)) & 0xff);
+               rp++;
+            }
+         }  /* end !UseMMX_sub */
+         break;
+
+      case PNG_FILTER_VALUE_UP:
+#if defined(PNG_ASSEMBLER_CODE_SUPPORTED)
+#if !defined(PNG_1_0_X)
+         if ((png_ptr->asm_flags & PNG_ASM_FLAG_MMX_READ_FILTER_UP) &&
+             (row_info->pixel_depth >= png_ptr->mmx_bitdepth_threshold) &&
+             (row_info->rowbytes >= png_ptr->mmx_rowbytes_threshold))
+#else
+         if (_mmx_supported)
+#endif
+         {
+            png_read_filter_row_mmx_up(row_info, row, prev_row);
+         }
+          else
+#endif /* PNG_ASSEMBLER_CODE_SUPPORTED */
+         {
+            png_uint_32 i;
+            png_uint_32 istop = row_info->rowbytes;
+            png_bytep rp = row;
+            png_bytep pp = prev_row;
+
+            for (i = 0; i < istop; ++i)
+            {
+               *rp = (png_byte)(((int)(*rp) + (int)(*pp++)) & 0xff);
+               rp++;
+            }
+         }  /* end !UseMMX_up */
+         break;
+
+      case PNG_FILTER_VALUE_AVG:
+#if defined(PNG_ASSEMBLER_CODE_SUPPORTED) && defined(PNG_THREAD_UNSAFE_OK)
+#if !defined(PNG_1_0_X)
+         if ((png_ptr->asm_flags & PNG_ASM_FLAG_MMX_READ_FILTER_AVG) &&
+             (row_info->pixel_depth >= png_ptr->mmx_bitdepth_threshold) &&
+             (row_info->rowbytes >= png_ptr->mmx_rowbytes_threshold))
+#else
+         if (_mmx_supported)
+#endif
+         {
+            png_read_filter_row_mmx_avg(row_info, row, prev_row);
+         }
+         else
+#endif /* PNG_ASSEMBLER_CODE_SUPPORTED */
+         {
+            png_uint_32 i;
+            png_bytep rp = row;
+            png_bytep pp = prev_row;
+            png_bytep lp = row;
+            png_uint_32 bpp = (row_info->pixel_depth + 7) >> 3;
+            png_uint_32 istop = row_info->rowbytes - bpp;
+
+            for (i = 0; i < bpp; i++)
+            {
+               *rp = (png_byte)(((int)(*rp) +
+                  ((int)(*pp++) >> 1)) & 0xff);
+               rp++;
+            }
+
+            for (i = 0; i < istop; i++)
+            {
+               *rp = (png_byte)(((int)(*rp) +
+                  ((int)(*pp++ + *lp++) >> 1)) & 0xff);
+               rp++;
+            }
+         }  /* end !UseMMX_avg */
+         break;
+
+      case PNG_FILTER_VALUE_PAETH:
+#if defined(PNG_ASSEMBLER_CODE_SUPPORTED) && defined(PNG_THREAD_UNSAFE_OK)
+#if !defined(PNG_1_0_X)
+         if ((png_ptr->asm_flags & PNG_ASM_FLAG_MMX_READ_FILTER_PAETH) &&
+             (row_info->pixel_depth >= png_ptr->mmx_bitdepth_threshold) &&
+             (row_info->rowbytes >= png_ptr->mmx_rowbytes_threshold))
+#else
+         if (_mmx_supported)
+#endif
+         {
+            png_read_filter_row_mmx_paeth(row_info, row, prev_row);
+         }
+         else
+#endif /* PNG_ASSEMBLER_CODE_SUPPORTED */
+         {
+            png_uint_32 i;
+            png_bytep rp = row;
+            png_bytep pp = prev_row;
+            png_bytep lp = row;
+            png_bytep cp = prev_row;
+            png_uint_32 bpp = (row_info->pixel_depth + 7) >> 3;
+            png_uint_32 istop = row_info->rowbytes - bpp;
+
+            for (i = 0; i < bpp; i++)
+            {
+               *rp = (png_byte)(((int)(*rp) + (int)(*pp++)) & 0xff);
+               rp++;
+            }
+
+            for (i = 0; i < istop; i++)   /* use leftover rp,pp */
+            {
+               int a, b, c, pa, pb, pc, p;
+
+               a = *lp++;
+               b = *pp++;
+               c = *cp++;
+
+               p = b - c;
+               pc = a - c;
+
+#ifdef PNG_USE_ABS
+               pa = abs(p);
+               pb = abs(pc);
+               pc = abs(p + pc);
+#else
+               pa = p < 0 ? -p : p;
+               pb = pc < 0 ? -pc : pc;
+               pc = (p + pc) < 0 ? -(p + pc) : p + pc;
+#endif
+
+               /*
+                  if (pa <= pb && pa <= pc)
+                     p = a;
+                  else if (pb <= pc)
+                     p = b;
+                  else
+                     p = c;
+                */
+
+               p = (pa <= pb && pa <= pc) ? a : (pb <= pc) ? b : c;
+
+               *rp = (png_byte)(((int)(*rp) + p) & 0xff);
+               rp++;
+            }
+         }  /* end !UseMMX_paeth */
+         break;
+
+      default:
+         png_warning(png_ptr, "Ignoring bad row-filter type");
+         *row=0;
+         break;
+   }
+}
+
+#endif /* PNG_HAVE_ASSEMBLER_READ_FILTER_ROW */
+
+
+/*===========================================================================*/
+/*                                                                           */
+/*                      P N G _ M M X _ S U P P O R T                        */
+/*                                                                           */
+/*===========================================================================*/
+
+/* GRR NOTES:  (1) the following code assumes 386 or better (pushfl/popfl)
+ *             (2) all instructions compile with gcc 2.7.2.3 and later
+ *             (3) the function is moved down here to prevent gcc from
+ *                  inlining it in multiple places and then barfing be-
+ *                  cause the ".NOT_SUPPORTED" label is multiply defined
+ *             [is there a way to signal that a *single* function should
+ *              not be inlined?  is there a way to modify the label for
+ *              each inlined instance, e.g., by appending _1, _2, etc.?
+ *              maybe if don't use leading "." in label name? (nope...sigh)]
+ */
+
+int PNGAPI
+png_mmx_support(void)
+{
+#if defined(PNG_MMX_CODE_SUPPORTED)
+    __asm__ __volatile__ (
+        "pushl %%ebx          \n\t"  // ebx gets clobbered by CPUID instruction
+        "pushl %%ecx          \n\t"  // so does ecx...
+        "pushl %%edx          \n\t"  // ...and edx (but ecx & edx safe on Linux)
+//      ".byte  0x66          \n\t"  // convert 16-bit pushf to 32-bit pushfd
+//      "pushf                \n\t"  // 16-bit pushf
+        "pushfl               \n\t"  // save Eflag to stack
+        "popl %%eax           \n\t"  // get Eflag from stack into eax
+        "movl %%eax, %%ecx    \n\t"  // make another copy of Eflag in ecx
+        "xorl $0x200000, %%eax \n\t" // toggle ID bit in Eflag (i.e., bit 21)
+        "pushl %%eax          \n\t"  // save modified Eflag back to stack
+//      ".byte  0x66          \n\t"  // convert 16-bit popf to 32-bit popfd
+//      "popf                 \n\t"  // 16-bit popf
+        "popfl                \n\t"  // restore modified value to Eflag reg
+        "pushfl               \n\t"  // save Eflag to stack
+        "popl %%eax           \n\t"  // get Eflag from stack
+        "pushl %%ecx          \n\t"  // save original Eflag to stack
+        "popfl                \n\t"  // restore original Eflag
+        "xorl %%ecx, %%eax    \n\t"  // compare new Eflag with original Eflag
+        "jz 0f                \n\t"  // if same, CPUID instr. is not supported
+
+        "xorl %%eax, %%eax    \n\t"  // set eax to zero
+//      ".byte  0x0f, 0xa2    \n\t"  // CPUID instruction (two-byte opcode)
+        "cpuid                \n\t"  // get the CPU identification info
+        "cmpl $1, %%eax       \n\t"  // make sure eax return non-zero value
+        "jl 0f                \n\t"  // if eax is zero, MMX is not supported
+
+        "xorl %%eax, %%eax    \n\t"  // set eax to zero and...
+        "incl %%eax           \n\t"  // ...increment eax to 1.  This pair is
+                                     // faster than the instruction "mov eax, 1"
+        "cpuid                \n\t"  // get the CPU identification info again
+        "andl $0x800000, %%edx \n\t" // mask out all bits but MMX bit (23)
+        "cmpl $0, %%edx       \n\t"  // 0 = MMX not supported
+        "jz 0f                \n\t"  // non-zero = yes, MMX IS supported
+
+        "movl $1, %%eax       \n\t"  // set return value to 1
+        "jmp  1f              \n\t"  // DONE:  have MMX support
+
+    "0:                       \n\t"  // .NOT_SUPPORTED: target label for jump instructions
+        "movl $0, %%eax       \n\t"  // set return value to 0
+    "1:                       \n\t"  // .RETURN: target label for jump instructions
+        "movl %%eax, _mmx_supported \n\t" // save in global static variable, too
+        "popl %%edx           \n\t"  // restore edx
+        "popl %%ecx           \n\t"  // restore ecx
+        "popl %%ebx           \n\t"  // restore ebx
+
+//      "ret                  \n\t"  // DONE:  no MMX support
+                                     // (fall through to standard C "ret")
+
+        :                            // output list (none)
+
+        :                            // any variables used on input (none)
+
+        : "%eax"                     // clobber list
+//      , "%ebx", "%ecx", "%edx"     // GRR:  we handle these manually
+//      , "memory"   // if write to a variable gcc thought was in a reg
+//      , "cc"       // "condition codes" (flag bits)
+    );
+#else     
+    _mmx_supported = 0;
+#endif /* PNG_MMX_CODE_SUPPORTED */
+
+    return _mmx_supported;
+}
+
+
+#endif /* PNG_USE_PNGGCCRD */
diff --git a/collects/plot/src/all/pngget.c b/collects/plot/src/all/pngget.c
new file mode 100644
index 0000000000..f7f5c6702b
--- /dev/null
+++ b/collects/plot/src/all/pngget.c
@@ -0,0 +1,927 @@
+
+/* pngget.c - retrieval of values from info struct
+ *
+ * libpng 1.2.5 - October 3, 2002
+ * For conditions of distribution and use, see copyright notice in png.h
+ * Copyright (c) 1998-2002 Glenn Randers-Pehrson
+ * (Version 0.96 Copyright (c) 1996, 1997 Andreas Dilger)
+ * (Version 0.88 Copyright (c) 1995, 1996 Guy Eric Schalnat, Group 42, Inc.)
+ */
+
+#define PNG_INTERNAL
+#include "png.h"
+
+png_uint_32 PNGAPI
+png_get_valid(png_structp png_ptr, png_infop info_ptr, png_uint_32 flag)
+{
+   if (png_ptr != NULL && info_ptr != NULL)
+      return(info_ptr->valid & flag);
+   else
+      return(0);
+}
+
+png_uint_32 PNGAPI
+png_get_rowbytes(png_structp png_ptr, png_infop info_ptr)
+{
+   if (png_ptr != NULL && info_ptr != NULL)
+      return(info_ptr->rowbytes);
+   else
+      return(0);
+}
+
+#if defined(PNG_INFO_IMAGE_SUPPORTED)
+png_bytepp PNGAPI
+png_get_rows(png_structp png_ptr, png_infop info_ptr)
+{
+   if (png_ptr != NULL && info_ptr != NULL)
+      return(info_ptr->row_pointers);
+   else
+      return(0);
+}
+#endif
+
+#ifdef PNG_EASY_ACCESS_SUPPORTED
+/* easy access to info, added in libpng-0.99 */
+png_uint_32 PNGAPI
+png_get_image_width(png_structp png_ptr, png_infop info_ptr)
+{
+   if (png_ptr != NULL && info_ptr != NULL)
+   {
+      return info_ptr->width;
+   }
+   return (0);
+}
+
+png_uint_32 PNGAPI
+png_get_image_height(png_structp png_ptr, png_infop info_ptr)
+{
+   if (png_ptr != NULL && info_ptr != NULL)
+   {
+      return info_ptr->height;
+   }
+   return (0);
+}
+
+png_byte PNGAPI
+png_get_bit_depth(png_structp png_ptr, png_infop info_ptr)
+{
+   if (png_ptr != NULL && info_ptr != NULL)
+   {
+      return info_ptr->bit_depth;
+   }
+   return (0);
+}
+
+png_byte PNGAPI
+png_get_color_type(png_structp png_ptr, png_infop info_ptr)
+{
+   if (png_ptr != NULL && info_ptr != NULL)
+   {
+      return info_ptr->color_type;
+   }
+   return (0);
+}
+
+png_byte PNGAPI
+png_get_filter_type(png_structp png_ptr, png_infop info_ptr)
+{
+   if (png_ptr != NULL && info_ptr != NULL)
+   {
+      return info_ptr->filter_type;
+   }
+   return (0);
+}
+
+png_byte PNGAPI
+png_get_interlace_type(png_structp png_ptr, png_infop info_ptr)
+{
+   if (png_ptr != NULL && info_ptr != NULL)
+   {
+      return info_ptr->interlace_type;
+   }
+   return (0);
+}
+
+png_byte PNGAPI
+png_get_compression_type(png_structp png_ptr, png_infop info_ptr)
+{
+   if (png_ptr != NULL && info_ptr != NULL)
+   {
+      return info_ptr->compression_type;
+   }
+   return (0);
+}
+
+png_uint_32 PNGAPI
+png_get_x_pixels_per_meter(png_structp png_ptr, png_infop info_ptr)
+{
+   if (png_ptr != NULL && info_ptr != NULL)
+#if defined(PNG_pHYs_SUPPORTED)
+   if (info_ptr->valid & PNG_INFO_pHYs)
+   {
+      png_debug1(1, "in %s retrieval function\n", "png_get_x_pixels_per_meter");
+      if(info_ptr->phys_unit_type != PNG_RESOLUTION_METER)
+          return (0);
+      else return (info_ptr->x_pixels_per_unit);
+   }
+#else
+   return (0);
+#endif
+   return (0);
+}
+
+png_uint_32 PNGAPI
+png_get_y_pixels_per_meter(png_structp png_ptr, png_infop info_ptr)
+{
+   if (png_ptr != NULL && info_ptr != NULL)
+#if defined(PNG_pHYs_SUPPORTED)
+   if (info_ptr->valid & PNG_INFO_pHYs)
+   {
+      png_debug1(1, "in %s retrieval function\n", "png_get_y_pixels_per_meter");
+      if(info_ptr->phys_unit_type != PNG_RESOLUTION_METER)
+          return (0);
+      else return (info_ptr->y_pixels_per_unit);
+   }
+#else
+   return (0);
+#endif
+   return (0);
+}
+
+png_uint_32 PNGAPI
+png_get_pixels_per_meter(png_structp png_ptr, png_infop info_ptr)
+{
+   if (png_ptr != NULL && info_ptr != NULL)
+#if defined(PNG_pHYs_SUPPORTED)
+   if (info_ptr->valid & PNG_INFO_pHYs)
+   {
+      png_debug1(1, "in %s retrieval function\n", "png_get_pixels_per_meter");
+      if(info_ptr->phys_unit_type != PNG_RESOLUTION_METER ||
+         info_ptr->x_pixels_per_unit != info_ptr->y_pixels_per_unit)
+          return (0);
+      else return (info_ptr->x_pixels_per_unit);
+   }
+#else
+   return (0);
+#endif
+   return (0);
+}
+
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+float PNGAPI
+png_get_pixel_aspect_ratio(png_structp png_ptr, png_infop info_ptr)
+   {
+   if (png_ptr != NULL && info_ptr != NULL)
+#if defined(PNG_pHYs_SUPPORTED)
+   if (info_ptr->valid & PNG_INFO_pHYs)
+   {
+      png_debug1(1, "in %s retrieval function\n", "png_get_aspect_ratio");
+      if (info_ptr->x_pixels_per_unit == 0)
+         return ((float)0.0);
+      else
+         return ((float)((float)info_ptr->y_pixels_per_unit
+            /(float)info_ptr->x_pixels_per_unit));
+   }
+#else
+   return (0.0);
+#endif
+   return ((float)0.0);
+}
+#endif
+
+png_int_32 PNGAPI
+png_get_x_offset_microns(png_structp png_ptr, png_infop info_ptr)
+{
+   if (png_ptr != NULL && info_ptr != NULL)
+#if defined(PNG_oFFs_SUPPORTED)
+   if (info_ptr->valid & PNG_INFO_oFFs)
+   {
+      png_debug1(1, "in %s retrieval function\n", "png_get_x_offset_microns");
+      if(info_ptr->offset_unit_type != PNG_OFFSET_MICROMETER)
+          return (0);
+      else return (info_ptr->x_offset);
+   }
+#else
+   return (0);
+#endif
+   return (0);
+}
+
+png_int_32 PNGAPI
+png_get_y_offset_microns(png_structp png_ptr, png_infop info_ptr)
+{
+   if (png_ptr != NULL && info_ptr != NULL)
+#if defined(PNG_oFFs_SUPPORTED)
+   if (info_ptr->valid & PNG_INFO_oFFs)
+   {
+      png_debug1(1, "in %s retrieval function\n", "png_get_y_offset_microns");
+      if(info_ptr->offset_unit_type != PNG_OFFSET_MICROMETER)
+          return (0);
+      else return (info_ptr->y_offset);
+   }
+#else
+   return (0);
+#endif
+   return (0);
+}
+
+png_int_32 PNGAPI
+png_get_x_offset_pixels(png_structp png_ptr, png_infop info_ptr)
+{
+   if (png_ptr != NULL && info_ptr != NULL)
+#if defined(PNG_oFFs_SUPPORTED)
+   if (info_ptr->valid & PNG_INFO_oFFs)
+   {
+      png_debug1(1, "in %s retrieval function\n", "png_get_x_offset_microns");
+      if(info_ptr->offset_unit_type != PNG_OFFSET_PIXEL)
+          return (0);
+      else return (info_ptr->x_offset);
+   }
+#else
+   return (0);
+#endif
+   return (0);
+}
+
+png_int_32 PNGAPI
+png_get_y_offset_pixels(png_structp png_ptr, png_infop info_ptr)
+{
+   if (png_ptr != NULL && info_ptr != NULL)
+#if defined(PNG_oFFs_SUPPORTED)
+   if (info_ptr->valid & PNG_INFO_oFFs)
+   {
+      png_debug1(1, "in %s retrieval function\n", "png_get_y_offset_microns");
+      if(info_ptr->offset_unit_type != PNG_OFFSET_PIXEL)
+          return (0);
+      else return (info_ptr->y_offset);
+   }
+#else
+   return (0);
+#endif
+   return (0);
+}
+
+#if defined(PNG_INCH_CONVERSIONS) && defined(PNG_FLOATING_POINT_SUPPORTED)
+png_uint_32 PNGAPI
+png_get_pixels_per_inch(png_structp png_ptr, png_infop info_ptr)
+{
+   return ((png_uint_32)((float)png_get_pixels_per_meter(png_ptr, info_ptr)
+     *.0254 +.5));
+}
+
+png_uint_32 PNGAPI
+png_get_x_pixels_per_inch(png_structp png_ptr, png_infop info_ptr)
+{
+   return ((png_uint_32)((float)png_get_x_pixels_per_meter(png_ptr, info_ptr)
+     *.0254 +.5));
+}
+
+png_uint_32 PNGAPI
+png_get_y_pixels_per_inch(png_structp png_ptr, png_infop info_ptr)
+{
+   return ((png_uint_32)((float)png_get_y_pixels_per_meter(png_ptr, info_ptr)
+     *.0254 +.5));
+}
+
+float PNGAPI
+png_get_x_offset_inches(png_structp png_ptr, png_infop info_ptr)
+{
+   return ((float)png_get_x_offset_microns(png_ptr, info_ptr)
+     *.00003937);
+}
+
+float PNGAPI
+png_get_y_offset_inches(png_structp png_ptr, png_infop info_ptr)
+{
+   return ((float)png_get_y_offset_microns(png_ptr, info_ptr)
+     *.00003937);
+}
+
+#if defined(PNG_pHYs_SUPPORTED)
+png_uint_32 PNGAPI
+png_get_pHYs_dpi(png_structp png_ptr, png_infop info_ptr,
+   png_uint_32 *res_x, png_uint_32 *res_y, int *unit_type)
+{
+   png_uint_32 retval = 0;
+
+   if (png_ptr != NULL && info_ptr != NULL && (info_ptr->valid & PNG_INFO_pHYs))
+   {
+      png_debug1(1, "in %s retrieval function\n", "pHYs");
+      if (res_x != NULL)
+      {
+         *res_x = info_ptr->x_pixels_per_unit;
+         retval |= PNG_INFO_pHYs;
+      }
+      if (res_y != NULL)
+      {
+         *res_y = info_ptr->y_pixels_per_unit;
+         retval |= PNG_INFO_pHYs;
+      }
+      if (unit_type != NULL)
+      {
+         *unit_type = (int)info_ptr->phys_unit_type;
+         retval |= PNG_INFO_pHYs;
+         if(*unit_type == 1)
+         {
+            if (res_x != NULL) *res_x = (png_uint_32)(*res_x * .0254 + .50);
+            if (res_y != NULL) *res_y = (png_uint_32)(*res_y * .0254 + .50);
+         }
+      }
+   }
+   return (retval);
+}
+#endif /* PNG_pHYs_SUPPORTED */
+#endif  /* PNG_INCH_CONVERSIONS && PNG_FLOATING_POINT_SUPPORTED */
+
+/* png_get_channels really belongs in here, too, but it's been around longer */
+
+#endif  /* PNG_EASY_ACCESS_SUPPORTED */
+
+png_byte PNGAPI
+png_get_channels(png_structp png_ptr, png_infop info_ptr)
+{
+   if (png_ptr != NULL && info_ptr != NULL)
+      return(info_ptr->channels);
+   else
+      return (0);
+}
+
+png_bytep PNGAPI
+png_get_signature(png_structp png_ptr, png_infop info_ptr)
+{
+   if (png_ptr != NULL && info_ptr != NULL)
+      return(info_ptr->signature);
+   else
+      return (NULL);
+}
+
+#if defined(PNG_bKGD_SUPPORTED)
+png_uint_32 PNGAPI
+png_get_bKGD(png_structp png_ptr, png_infop info_ptr,
+   png_color_16p *background)
+{
+   if (png_ptr != NULL && info_ptr != NULL && (info_ptr->valid & PNG_INFO_bKGD)
+      && background != NULL)
+   {
+      png_debug1(1, "in %s retrieval function\n", "bKGD");
+      *background = &(info_ptr->background);
+      return (PNG_INFO_bKGD);
+   }
+   return (0);
+}
+#endif
+
+#if defined(PNG_cHRM_SUPPORTED)
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+png_uint_32 PNGAPI
+png_get_cHRM(png_structp png_ptr, png_infop info_ptr,
+   double *white_x, double *white_y, double *red_x, double *red_y,
+   double *green_x, double *green_y, double *blue_x, double *blue_y)
+{
+   if (png_ptr != NULL && info_ptr != NULL && (info_ptr->valid & PNG_INFO_cHRM))
+   {
+      png_debug1(1, "in %s retrieval function\n", "cHRM");
+      if (white_x != NULL)
+         *white_x = (double)info_ptr->x_white;
+      if (white_y != NULL)
+         *white_y = (double)info_ptr->y_white;
+      if (red_x != NULL)
+         *red_x = (double)info_ptr->x_red;
+      if (red_y != NULL)
+         *red_y = (double)info_ptr->y_red;
+      if (green_x != NULL)
+         *green_x = (double)info_ptr->x_green;
+      if (green_y != NULL)
+         *green_y = (double)info_ptr->y_green;
+      if (blue_x != NULL)
+         *blue_x = (double)info_ptr->x_blue;
+      if (blue_y != NULL)
+         *blue_y = (double)info_ptr->y_blue;
+      return (PNG_INFO_cHRM);
+   }
+   return (0);
+}
+#endif
+#ifdef PNG_FIXED_POINT_SUPPORTED
+png_uint_32 PNGAPI
+png_get_cHRM_fixed(png_structp png_ptr, png_infop info_ptr,
+   png_fixed_point *white_x, png_fixed_point *white_y, png_fixed_point *red_x,
+   png_fixed_point *red_y, png_fixed_point *green_x, png_fixed_point *green_y,
+   png_fixed_point *blue_x, png_fixed_point *blue_y)
+{
+   if (png_ptr != NULL && info_ptr != NULL && (info_ptr->valid & PNG_INFO_cHRM))
+   {
+      png_debug1(1, "in %s retrieval function\n", "cHRM");
+      if (white_x != NULL)
+         *white_x = info_ptr->int_x_white;
+      if (white_y != NULL)
+         *white_y = info_ptr->int_y_white;
+      if (red_x != NULL)
+         *red_x = info_ptr->int_x_red;
+      if (red_y != NULL)
+         *red_y = info_ptr->int_y_red;
+      if (green_x != NULL)
+         *green_x = info_ptr->int_x_green;
+      if (green_y != NULL)
+         *green_y = info_ptr->int_y_green;
+      if (blue_x != NULL)
+         *blue_x = info_ptr->int_x_blue;
+      if (blue_y != NULL)
+         *blue_y = info_ptr->int_y_blue;
+      return (PNG_INFO_cHRM);
+   }
+   return (0);
+}
+#endif
+#endif
+
+#if defined(PNG_gAMA_SUPPORTED)
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+png_uint_32 PNGAPI
+png_get_gAMA(png_structp png_ptr, png_infop info_ptr, double *file_gamma)
+{
+   if (png_ptr != NULL && info_ptr != NULL && (info_ptr->valid & PNG_INFO_gAMA)
+      && file_gamma != NULL)
+   {
+      png_debug1(1, "in %s retrieval function\n", "gAMA");
+      *file_gamma = (double)info_ptr->gamma;
+      return (PNG_INFO_gAMA);
+   }
+   return (0);
+}
+#endif
+#ifdef PNG_FIXED_POINT_SUPPORTED
+png_uint_32 PNGAPI
+png_get_gAMA_fixed(png_structp png_ptr, png_infop info_ptr,
+    png_fixed_point *int_file_gamma)
+{
+   if (png_ptr != NULL && info_ptr != NULL && (info_ptr->valid & PNG_INFO_gAMA)
+      && int_file_gamma != NULL)
+   {
+      png_debug1(1, "in %s retrieval function\n", "gAMA");
+      *int_file_gamma = info_ptr->int_gamma;
+      return (PNG_INFO_gAMA);
+   }
+   return (0);
+}
+#endif
+#endif
+
+#if defined(PNG_sRGB_SUPPORTED)
+png_uint_32 PNGAPI
+png_get_sRGB(png_structp png_ptr, png_infop info_ptr, int *file_srgb_intent)
+{
+   if (png_ptr != NULL && info_ptr != NULL && (info_ptr->valid & PNG_INFO_sRGB)
+      && file_srgb_intent != NULL)
+   {
+      png_debug1(1, "in %s retrieval function\n", "sRGB");
+      *file_srgb_intent = (int)info_ptr->srgb_intent;
+      return (PNG_INFO_sRGB);
+   }
+   return (0);
+}
+#endif
+
+#if defined(PNG_iCCP_SUPPORTED)
+png_uint_32 PNGAPI
+png_get_iCCP(png_structp png_ptr, png_infop info_ptr,
+             png_charpp name, int *compression_type,
+             png_charpp profile, png_uint_32 *proflen)
+{
+   if (png_ptr != NULL && info_ptr != NULL && (info_ptr->valid & PNG_INFO_iCCP)
+      && name != NULL && profile != NULL && proflen != NULL)
+   {
+      png_debug1(1, "in %s retrieval function\n", "iCCP");
+      *name = info_ptr->iccp_name;
+      *profile = info_ptr->iccp_profile;
+      /* compression_type is a dummy so the API won't have to change
+         if we introduce multiple compression types later. */
+      *proflen = (int)info_ptr->iccp_proflen;
+      *compression_type = (int)info_ptr->iccp_compression;
+      return (PNG_INFO_iCCP);
+   }
+   return (0);
+}
+#endif
+
+#if defined(PNG_sPLT_SUPPORTED)
+png_uint_32 PNGAPI
+png_get_sPLT(png_structp png_ptr, png_infop info_ptr,
+             png_sPLT_tpp spalettes)
+{
+   if (png_ptr != NULL && info_ptr != NULL && spalettes != NULL)
+     *spalettes = info_ptr->splt_palettes;
+   return ((png_uint_32)info_ptr->splt_palettes_num);
+}
+#endif
+
+#if defined(PNG_hIST_SUPPORTED)
+png_uint_32 PNGAPI
+png_get_hIST(png_structp png_ptr, png_infop info_ptr, png_uint_16p *hist)
+{
+   if (png_ptr != NULL && info_ptr != NULL && (info_ptr->valid & PNG_INFO_hIST)
+      && hist != NULL)
+   {
+      png_debug1(1, "in %s retrieval function\n", "hIST");
+      *hist = info_ptr->hist;
+      return (PNG_INFO_hIST);
+   }
+   return (0);
+}
+#endif
+
+png_uint_32 PNGAPI
+png_get_IHDR(png_structp png_ptr, png_infop info_ptr,
+   png_uint_32 *width, png_uint_32 *height, int *bit_depth,
+   int *color_type, int *interlace_type, int *compression_type,
+   int *filter_type)
+
+{
+   if (png_ptr != NULL && info_ptr != NULL && width != NULL && height != NULL &&
+      bit_depth != NULL && color_type != NULL)
+   {
+      int pixel_depth, channels;
+      png_uint_32 rowbytes_per_pixel;
+
+      png_debug1(1, "in %s retrieval function\n", "IHDR");
+      *width = info_ptr->width;
+      *height = info_ptr->height;
+      *bit_depth = info_ptr->bit_depth;
+      if (info_ptr->bit_depth < 1 || info_ptr->bit_depth > 16)
+        png_error(png_ptr, "Invalid bit depth");
+      *color_type = info_ptr->color_type;
+      if (info_ptr->color_type > 6)
+        png_error(png_ptr, "Invalid color type");
+      if (compression_type != NULL)
+         *compression_type = info_ptr->compression_type;
+      if (filter_type != NULL)
+         *filter_type = info_ptr->filter_type;
+      if (interlace_type != NULL)
+         *interlace_type = info_ptr->interlace_type;
+
+      /* check for potential overflow of rowbytes */
+      if (*color_type == PNG_COLOR_TYPE_PALETTE)
+         channels = 1;
+      else if (*color_type & PNG_COLOR_MASK_COLOR)
+         channels = 3;
+      else
+         channels = 1;
+      if (*color_type & PNG_COLOR_MASK_ALPHA)
+         channels++;
+      pixel_depth = *bit_depth * channels;
+      rowbytes_per_pixel = (pixel_depth + 7) >> 3;
+      if (width == 0 || *width > PNG_MAX_UINT)
+        png_error(png_ptr, "Invalid image width");
+      if (height == 0 || *height > PNG_MAX_UINT)
+        png_error(png_ptr, "Invalid image height");
+      if (*width > PNG_MAX_UINT/rowbytes_per_pixel - 64)
+      {
+         png_error(png_ptr,
+            "Width too large for libpng to process image data.");
+      }
+      return (1);
+   }
+   return (0);
+}
+
+#if defined(PNG_oFFs_SUPPORTED)
+png_uint_32 PNGAPI
+png_get_oFFs(png_structp png_ptr, png_infop info_ptr,
+   png_int_32 *offset_x, png_int_32 *offset_y, int *unit_type)
+{
+   if (png_ptr != NULL && info_ptr != NULL && (info_ptr->valid & PNG_INFO_oFFs)
+      && offset_x != NULL && offset_y != NULL && unit_type != NULL)
+   {
+      png_debug1(1, "in %s retrieval function\n", "oFFs");
+      *offset_x = info_ptr->x_offset;
+      *offset_y = info_ptr->y_offset;
+      *unit_type = (int)info_ptr->offset_unit_type;
+      return (PNG_INFO_oFFs);
+   }
+   return (0);
+}
+#endif
+
+#if defined(PNG_pCAL_SUPPORTED)
+png_uint_32 PNGAPI
+png_get_pCAL(png_structp png_ptr, png_infop info_ptr,
+   png_charp *purpose, png_int_32 *X0, png_int_32 *X1, int *type, int *nparams,
+   png_charp *units, png_charpp *params)
+{
+   if (png_ptr != NULL && info_ptr != NULL && (info_ptr->valid & PNG_INFO_pCAL)
+      && purpose != NULL && X0 != NULL && X1 != NULL && type != NULL &&
+      nparams != NULL && units != NULL && params != NULL)
+   {
+      png_debug1(1, "in %s retrieval function\n", "pCAL");
+      *purpose = info_ptr->pcal_purpose;
+      *X0 = info_ptr->pcal_X0;
+      *X1 = info_ptr->pcal_X1;
+      *type = (int)info_ptr->pcal_type;
+      *nparams = (int)info_ptr->pcal_nparams;
+      *units = info_ptr->pcal_units;
+      *params = info_ptr->pcal_params;
+      return (PNG_INFO_pCAL);
+   }
+   return (0);
+}
+#endif
+
+#if defined(PNG_sCAL_SUPPORTED)
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+png_uint_32 PNGAPI
+png_get_sCAL(png_structp png_ptr, png_infop info_ptr,
+             int *unit, double *width, double *height)
+{
+    if (png_ptr != NULL && info_ptr != NULL &&
+       (info_ptr->valid & PNG_INFO_sCAL))
+    {
+        *unit = info_ptr->scal_unit;
+        *width = info_ptr->scal_pixel_width;
+        *height = info_ptr->scal_pixel_height;
+        return (PNG_INFO_sCAL);
+    }
+    return(0);
+}
+#else
+#ifdef PNG_FIXED_POINT_SUPPORTED
+png_uint_32 PNGAPI
+png_get_sCAL_s(png_structp png_ptr, png_infop info_ptr,
+             int *unit, png_charpp width, png_charpp height)
+{
+    if (png_ptr != NULL && info_ptr != NULL &&
+       (info_ptr->valid & PNG_INFO_sCAL))
+    {
+        *unit = info_ptr->scal_unit;
+        *width = info_ptr->scal_s_width;
+        *height = info_ptr->scal_s_height;
+        return (PNG_INFO_sCAL);
+    }
+    return(0);
+}
+#endif
+#endif
+#endif
+
+#if defined(PNG_pHYs_SUPPORTED)
+png_uint_32 PNGAPI
+png_get_pHYs(png_structp png_ptr, png_infop info_ptr,
+   png_uint_32 *res_x, png_uint_32 *res_y, int *unit_type)
+{
+   png_uint_32 retval = 0;
+
+   if (png_ptr != NULL && info_ptr != NULL &&
+      (info_ptr->valid & PNG_INFO_pHYs))
+   {
+      png_debug1(1, "in %s retrieval function\n", "pHYs");
+      if (res_x != NULL)
+      {
+         *res_x = info_ptr->x_pixels_per_unit;
+         retval |= PNG_INFO_pHYs;
+      }
+      if (res_y != NULL)
+      {
+         *res_y = info_ptr->y_pixels_per_unit;
+         retval |= PNG_INFO_pHYs;
+      }
+      if (unit_type != NULL)
+      {
+         *unit_type = (int)info_ptr->phys_unit_type;
+         retval |= PNG_INFO_pHYs;
+      }
+   }
+   return (retval);
+}
+#endif
+
+png_uint_32 PNGAPI
+png_get_PLTE(png_structp png_ptr, png_infop info_ptr, png_colorp *palette,
+   int *num_palette)
+{
+   if (png_ptr != NULL && info_ptr != NULL && (info_ptr->valid & PNG_INFO_PLTE)
+       && palette != NULL)
+   {
+      png_debug1(1, "in %s retrieval function\n", "PLTE");
+      *palette = info_ptr->palette;
+      *num_palette = info_ptr->num_palette;
+      png_debug1(3, "num_palette = %d\n", *num_palette);
+      return (PNG_INFO_PLTE);
+   }
+   return (0);
+}
+
+#if defined(PNG_sBIT_SUPPORTED)
+png_uint_32 PNGAPI
+png_get_sBIT(png_structp png_ptr, png_infop info_ptr, png_color_8p *sig_bit)
+{
+   if (png_ptr != NULL && info_ptr != NULL && (info_ptr->valid & PNG_INFO_sBIT)
+      && sig_bit != NULL)
+   {
+      png_debug1(1, "in %s retrieval function\n", "sBIT");
+      *sig_bit = &(info_ptr->sig_bit);
+      return (PNG_INFO_sBIT);
+   }
+   return (0);
+}
+#endif
+
+#if defined(PNG_TEXT_SUPPORTED)
+png_uint_32 PNGAPI
+png_get_text(png_structp png_ptr, png_infop info_ptr, png_textp *text_ptr,
+   int *num_text)
+{
+   if (png_ptr != NULL && info_ptr != NULL && info_ptr->num_text > 0)
+   {
+      png_debug1(1, "in %s retrieval function\n",
+         (png_ptr->chunk_name[0] == '\0' ? "text"
+             : (png_const_charp)png_ptr->chunk_name));
+      if (text_ptr != NULL)
+         *text_ptr = info_ptr->text;
+      if (num_text != NULL)
+         *num_text = info_ptr->num_text;
+      return ((png_uint_32)info_ptr->num_text);
+   }
+   if (num_text != NULL)
+     *num_text = 0;
+   return(0);
+}
+#endif
+
+#if defined(PNG_tIME_SUPPORTED)
+png_uint_32 PNGAPI
+png_get_tIME(png_structp png_ptr, png_infop info_ptr, png_timep *mod_time)
+{
+   if (png_ptr != NULL && info_ptr != NULL && (info_ptr->valid & PNG_INFO_tIME)
+       && mod_time != NULL)
+   {
+      png_debug1(1, "in %s retrieval function\n", "tIME");
+      *mod_time = &(info_ptr->mod_time);
+      return (PNG_INFO_tIME);
+   }
+   return (0);
+}
+#endif
+
+#if defined(PNG_tRNS_SUPPORTED)
+png_uint_32 PNGAPI
+png_get_tRNS(png_structp png_ptr, png_infop info_ptr,
+   png_bytep *trans, int *num_trans, png_color_16p *trans_values)
+{
+   png_uint_32 retval = 0;
+   if (png_ptr != NULL && info_ptr != NULL && (info_ptr->valid & PNG_INFO_tRNS))
+   {
+      png_debug1(1, "in %s retrieval function\n", "tRNS");
+      if (info_ptr->color_type == PNG_COLOR_TYPE_PALETTE)
+      {
+          if (trans != NULL)
+          {
+             *trans = info_ptr->trans;
+             retval |= PNG_INFO_tRNS;
+          }
+          if (trans_values != NULL)
+             *trans_values = &(info_ptr->trans_values);
+      }
+      else /* if (info_ptr->color_type != PNG_COLOR_TYPE_PALETTE) */
+      {
+          if (trans_values != NULL)
+          {
+             *trans_values = &(info_ptr->trans_values);
+             retval |= PNG_INFO_tRNS;
+          }
+          if(trans != NULL)
+             *trans = NULL;
+      }
+      if(num_trans != NULL)
+      {
+         *num_trans = info_ptr->num_trans;
+         retval |= PNG_INFO_tRNS;
+      }
+   }
+   return (retval);
+}
+#endif
+
+#if defined(PNG_UNKNOWN_CHUNKS_SUPPORTED)
+png_uint_32 PNGAPI
+png_get_unknown_chunks(png_structp png_ptr, png_infop info_ptr,
+             png_unknown_chunkpp unknowns)
+{
+   if (png_ptr != NULL && info_ptr != NULL && unknowns != NULL)
+     *unknowns = info_ptr->unknown_chunks;
+   return ((png_uint_32)info_ptr->unknown_chunks_num);
+}
+#endif
+
+#if defined(PNG_READ_RGB_TO_GRAY_SUPPORTED)
+png_byte PNGAPI
+png_get_rgb_to_gray_status (png_structp png_ptr)
+{
+   return (png_byte)(png_ptr? png_ptr->rgb_to_gray_status : 0);
+}
+#endif
+
+#if defined(PNG_USER_CHUNKS_SUPPORTED)
+png_voidp PNGAPI
+png_get_user_chunk_ptr(png_structp png_ptr)
+{
+   return (png_ptr? png_ptr->user_chunk_ptr : NULL);
+}
+#endif
+
+
+png_uint_32 PNGAPI
+png_get_compression_buffer_size(png_structp png_ptr)
+{
+   return (png_uint_32)(png_ptr? png_ptr->zbuf_size : 0L);
+}
+
+
+#ifndef PNG_1_0_X
+#ifdef PNG_ASSEMBLER_CODE_SUPPORTED
+/* this function was added to libpng 1.2.0 and should exist by default */
+png_uint_32 PNGAPI
+png_get_asm_flags (png_structp png_ptr)
+{
+    return (png_uint_32)(png_ptr? png_ptr->asm_flags : 0L);
+}
+
+/* this function was added to libpng 1.2.0 and should exist by default */
+png_uint_32 PNGAPI
+png_get_asm_flagmask (int flag_select)
+{
+    png_uint_32 settable_asm_flags = 0;
+
+    if (flag_select & PNG_SELECT_READ)
+        settable_asm_flags |=
+          PNG_ASM_FLAG_MMX_READ_COMBINE_ROW  |
+          PNG_ASM_FLAG_MMX_READ_INTERLACE    |
+          PNG_ASM_FLAG_MMX_READ_FILTER_SUB   |
+          PNG_ASM_FLAG_MMX_READ_FILTER_UP    |
+          PNG_ASM_FLAG_MMX_READ_FILTER_AVG   |
+          PNG_ASM_FLAG_MMX_READ_FILTER_PAETH ;
+          /* no non-MMX flags yet */
+
+#if 0
+    /* GRR:  no write-flags yet, either, but someday... */
+    if (flag_select & PNG_SELECT_WRITE)
+        settable_asm_flags |=
+          PNG_ASM_FLAG_MMX_WRITE_ [whatever] ;
+#endif /* 0 */
+
+    return settable_asm_flags;  /* _theoretically_ settable capabilities only */
+}
+#endif /* PNG_ASSEMBLER_CODE_SUPPORTED */
+
+
+#if defined(PNG_ASSEMBLER_CODE_SUPPORTED)
+    /* GRR:  could add this:   && defined(PNG_MMX_CODE_SUPPORTED) */
+/* this function was added to libpng 1.2.0 */
+png_uint_32 PNGAPI
+png_get_mmx_flagmask (int flag_select, int *compilerID)
+{
+    png_uint_32 settable_mmx_flags = 0;
+
+    if (flag_select & PNG_SELECT_READ)
+        settable_mmx_flags |=
+          PNG_ASM_FLAG_MMX_READ_COMBINE_ROW  |
+          PNG_ASM_FLAG_MMX_READ_INTERLACE    |
+          PNG_ASM_FLAG_MMX_READ_FILTER_SUB   |
+          PNG_ASM_FLAG_MMX_READ_FILTER_UP    |
+          PNG_ASM_FLAG_MMX_READ_FILTER_AVG   |
+          PNG_ASM_FLAG_MMX_READ_FILTER_PAETH ;
+#if 0
+    /* GRR:  no MMX write support yet, but someday... */
+    if (flag_select & PNG_SELECT_WRITE)
+        settable_mmx_flags |=
+          PNG_ASM_FLAG_MMX_WRITE_ [whatever] ;
+#endif /* 0 */
+
+    if (compilerID != NULL) {
+#ifdef PNG_USE_PNGVCRD
+        *compilerID = 1;    /* MSVC */
+#else
+#ifdef PNG_USE_PNGGCCRD
+        *compilerID = 2;    /* gcc/gas */
+#else
+        *compilerID = -1;   /* unknown (i.e., no asm/MMX code compiled) */
+#endif
+#endif
+    }
+
+    return settable_mmx_flags;  /* _theoretically_ settable capabilities only */
+}
+
+/* this function was added to libpng 1.2.0 */
+png_byte PNGAPI
+png_get_mmx_bitdepth_threshold (png_structp png_ptr)
+{
+    return (png_byte)(png_ptr? png_ptr->mmx_bitdepth_threshold : 0);
+}
+
+/* this function was added to libpng 1.2.0 */
+png_uint_32 PNGAPI
+png_get_mmx_rowbytes_threshold (png_structp png_ptr)
+{
+    return (png_uint_32)(png_ptr? png_ptr->mmx_rowbytes_threshold : 0L);
+}
+#endif /* PNG_ASSEMBLER_CODE_SUPPORTED */
+#endif /* PNG_1_0_X */
diff --git a/collects/plot/src/all/pngmem.c b/collects/plot/src/all/pngmem.c
new file mode 100644
index 0000000000..66eec0b09f
--- /dev/null
+++ b/collects/plot/src/all/pngmem.c
@@ -0,0 +1,566 @@
+
+/* pngmem.c - stub functions for memory allocation
+ *
+ * libpng 1.2.5 - October 3, 2002
+ * For conditions of distribution and use, see copyright notice in png.h
+ * Copyright (c) 1998-2002 Glenn Randers-Pehrson
+ * (Version 0.96 Copyright (c) 1996, 1997 Andreas Dilger)
+ * (Version 0.88 Copyright (c) 1995, 1996 Guy Eric Schalnat, Group 42, Inc.)
+ *
+ * This file provides a location for all memory allocation.  Users who
+ * need special memory handling are expected to supply replacement
+ * functions for png_malloc() and png_free(), and to use
+ * png_create_read_struct_2() and png_create_write_struct_2() to
+ * identify the replacement functions.
+ */
+
+#define PNG_INTERNAL
+#include "png.h"
+
+/* Borland DOS special memory handler */
+#if defined(__TURBOC__) && !defined(_Windows) && !defined(__FLAT__)
+/* if you change this, be sure to change the one in png.h also */
+
+/* Allocate memory for a png_struct.  The malloc and memset can be replaced
+   by a single call to calloc() if this is thought to improve performance. */
+png_voidp /* PRIVATE */
+png_create_struct(int type)
+{
+#ifdef PNG_USER_MEM_SUPPORTED
+   return (png_create_struct_2(type, png_malloc_ptr_NULL, png_voidp_NULL));
+}
+
+/* Alternate version of png_create_struct, for use with user-defined malloc. */
+png_voidp /* PRIVATE */
+png_create_struct_2(int type, png_malloc_ptr malloc_fn, png_voidp mem_ptr)
+{
+#endif /* PNG_USER_MEM_SUPPORTED */
+   png_size_t size;
+   png_voidp struct_ptr;
+
+   if (type == PNG_STRUCT_INFO)
+     size = sizeof(png_info);
+   else if (type == PNG_STRUCT_PNG)
+     size = sizeof(png_struct);
+   else
+     return (png_get_copyright());
+
+#ifdef PNG_USER_MEM_SUPPORTED
+   if(malloc_fn != NULL)
+   {
+      png_struct dummy_struct;
+      png_structp png_ptr = &dummy_struct;
+      png_ptr->mem_ptr=mem_ptr;
+      struct_ptr = (*(malloc_fn))(png_ptr, (png_uint_32)size);
+   }
+   else
+#endif /* PNG_USER_MEM_SUPPORTED */
+      struct_ptr = (png_voidp)farmalloc(size));
+   if (struct_ptr != NULL)
+      png_memset(struct_ptr, 0, size);
+   return (struct_ptr);
+}
+
+/* Free memory allocated by a png_create_struct() call */
+void /* PRIVATE */
+png_destroy_struct(png_voidp struct_ptr)
+{
+#ifdef PNG_USER_MEM_SUPPORTED
+   png_destroy_struct_2(struct_ptr, png_free_ptr_NULL, png_voidp_NULL);
+}
+
+/* Free memory allocated by a png_create_struct() call */
+void /* PRIVATE */
+png_destroy_struct_2(png_voidp struct_ptr, png_free_ptr free_fn,
+    png_voidp mem_ptr)
+{
+#endif
+   if (struct_ptr != NULL)
+   {
+#ifdef PNG_USER_MEM_SUPPORTED
+      if(free_fn != NULL)
+      {
+         png_struct dummy_struct;
+         png_structp png_ptr = &dummy_struct;
+         png_ptr->mem_ptr=mem_ptr;
+         (*(free_fn))(png_ptr, struct_ptr);
+         return;
+      }
+#endif /* PNG_USER_MEM_SUPPORTED */
+      farfree (struct_ptr);
+   }
+}
+
+/* Allocate memory.  For reasonable files, size should never exceed
+ * 64K.  However, zlib may allocate more then 64K if you don't tell
+ * it not to.  See zconf.h and png.h for more information. zlib does
+ * need to allocate exactly 64K, so whatever you call here must
+ * have the ability to do that.
+ *
+ * Borland seems to have a problem in DOS mode for exactly 64K.
+ * It gives you a segment with an offset of 8 (perhaps to store its
+ * memory stuff).  zlib doesn't like this at all, so we have to
+ * detect and deal with it.  This code should not be needed in
+ * Windows or OS/2 modes, and only in 16 bit mode.  This code has
+ * been updated by Alexander Lehmann for version 0.89 to waste less
+ * memory.
+ *
+ * Note that we can't use png_size_t for the "size" declaration,
+ * since on some systems a png_size_t is a 16-bit quantity, and as a
+ * result, we would be truncating potentially larger memory requests
+ * (which should cause a fatal error) and introducing major problems.
+ */
+
+png_voidp PNGAPI
+png_malloc(png_structp png_ptr, png_uint_32 size)
+{
+   png_voidp ret;
+
+   if (png_ptr == NULL || size == 0)
+      return (NULL);
+
+#ifdef PNG_USER_MEM_SUPPORTED
+   if(png_ptr->malloc_fn != NULL)
+   {
+       ret = ((png_voidp)(*(png_ptr->malloc_fn))(png_ptr, (png_size_t)size));
+       if (ret == NULL && (png_ptr->flags&PNG_FLAG_MALLOC_NULL_MEM_OK) == 0)
+          png_error(png_ptr, "Out of memory!");
+       return (ret);
+   }
+   else
+       return png_malloc_default(png_ptr, size);
+}
+
+png_voidp PNGAPI
+png_malloc_default(png_structp png_ptr, png_uint_32 size)
+{
+   png_voidp ret;
+#endif /* PNG_USER_MEM_SUPPORTED */
+
+#ifdef PNG_MAX_MALLOC_64K
+   if (size > (png_uint_32)65536L)
+      png_error(png_ptr, "Cannot Allocate > 64K");
+#endif
+
+   if (size == (png_uint_32)65536L)
+   {
+      if (png_ptr->offset_table == NULL)
+      {
+         /* try to see if we need to do any of this fancy stuff */
+         ret = farmalloc(size);
+         if (ret == NULL || ((png_size_t)ret & 0xffff))
+         {
+            int num_blocks;
+            png_uint_32 total_size;
+            png_bytep table;
+            int i;
+            png_byte huge * hptr;
+
+            if (ret != NULL)
+            {
+               farfree(ret);
+               ret = NULL;
+            }
+
+            if(png_ptr->zlib_window_bits > 14)
+               num_blocks = (int)(1 << (png_ptr->zlib_window_bits - 14));
+            else
+               num_blocks = 1;
+            if (png_ptr->zlib_mem_level >= 7)
+               num_blocks += (int)(1 << (png_ptr->zlib_mem_level - 7));
+            else
+               num_blocks++;
+
+            total_size = ((png_uint_32)65536L) * (png_uint_32)num_blocks+16;
+
+            table = farmalloc(total_size);
+
+            if (table == NULL)
+            {
+               if (png_ptr->flags&PNG_FLAG_MALLOC_NULL_MEM_OK) == 0)
+                  png_error(png_ptr, "Out Of Memory."); /* Note "O" and "M" */
+               else
+                  png_warning(png_ptr, "Out Of Memory.");
+               return (NULL);
+            }
+
+            if ((png_size_t)table & 0xfff0)
+            {
+               if (png_ptr->flags&PNG_FLAG_MALLOC_NULL_MEM_OK) == 0)
+                  png_error(png_ptr,
+                    "Farmalloc didn't return normalized pointer");
+               else
+                  png_warning(png_ptr,
+                    "Farmalloc didn't return normalized pointer");
+               return (NULL);
+            }
+
+            png_ptr->offset_table = table;
+            png_ptr->offset_table_ptr = farmalloc(num_blocks *
+               sizeof (png_bytep));
+
+            if (png_ptr->offset_table_ptr == NULL)
+            {
+               if (png_ptr->flags&PNG_FLAG_MALLOC_NULL_MEM_OK) == 0)
+                  png_error(png_ptr, "Out Of memory."); /* Note "O" and "M" */
+               else
+                  png_warning(png_ptr, "Out Of memory.");
+               return (NULL);
+            }
+
+            hptr = (png_byte huge *)table;
+            if ((png_size_t)hptr & 0xf)
+            {
+               hptr = (png_byte huge *)((long)(hptr) & 0xfffffff0L);
+               hptr = hptr + 16L;  /* "hptr += 16L" fails on Turbo C++ 3.0 */
+            }
+            for (i = 0; i < num_blocks; i++)
+            {
+               png_ptr->offset_table_ptr[i] = (png_bytep)hptr;
+               hptr = hptr + (png_uint_32)65536L;  /* "+=" fails on TC++3.0 */
+            }
+
+            png_ptr->offset_table_number = num_blocks;
+            png_ptr->offset_table_count = 0;
+            png_ptr->offset_table_count_free = 0;
+         }
+      }
+
+      if (png_ptr->offset_table_count >= png_ptr->offset_table_number)
+      {
+         if (png_ptr->flags&PNG_FLAG_MALLOC_NULL_MEM_OK) == 0)
+            png_error(png_ptr, "Out of Memory."); /* Note "o" and "M" */
+         else
+            png_warning(png_ptr, "Out of Memory.");
+         return (NULL);
+      }
+
+      ret = png_ptr->offset_table_ptr[png_ptr->offset_table_count++];
+   }
+   else
+      ret = farmalloc(size);
+
+   if (ret == NULL)
+   {
+      if (png_ptr->flags&PNG_FLAG_MALLOC_NULL_MEM_OK) == 0)
+         png_error(png_ptr, "Out of memory."); /* Note "o" and "m" */
+      else
+         png_warning(png_ptr, "Out of memory."); /* Note "o" and "m" */
+   }
+
+   return (ret);
+}
+
+/* free a pointer allocated by png_malloc().  In the default
+   configuration, png_ptr is not used, but is passed in case it
+   is needed.  If ptr is NULL, return without taking any action. */
+void PNGAPI
+png_free(png_structp png_ptr, png_voidp ptr)
+{
+   if (png_ptr == NULL || ptr == NULL)
+      return;
+
+#ifdef PNG_USER_MEM_SUPPORTED
+   if (png_ptr->free_fn != NULL)
+   {
+      (*(png_ptr->free_fn))(png_ptr, ptr);
+      return;
+   }
+   else png_free_default(png_ptr, ptr);
+}
+
+void PNGAPI
+png_free_default(png_structp png_ptr, png_voidp ptr)
+{
+#endif /* PNG_USER_MEM_SUPPORTED */
+
+   if (png_ptr->offset_table != NULL)
+   {
+      int i;
+
+      for (i = 0; i < png_ptr->offset_table_count; i++)
+      {
+         if (ptr == png_ptr->offset_table_ptr[i])
+         {
+            ptr = NULL;
+            png_ptr->offset_table_count_free++;
+            break;
+         }
+      }
+      if (png_ptr->offset_table_count_free == png_ptr->offset_table_count)
+      {
+         farfree(png_ptr->offset_table);
+         farfree(png_ptr->offset_table_ptr);
+         png_ptr->offset_table = NULL;
+         png_ptr->offset_table_ptr = NULL;
+      }
+   }
+
+   if (ptr != NULL)
+   {
+      farfree(ptr);
+   }
+}
+
+#else /* Not the Borland DOS special memory handler */
+
+/* Allocate memory for a png_struct or a png_info.  The malloc and
+   memset can be replaced by a single call to calloc() if this is thought
+   to improve performance noticably. */
+png_voidp /* PRIVATE */
+png_create_struct(int type)
+{
+#ifdef PNG_USER_MEM_SUPPORTED
+   return (png_create_struct_2(type, png_malloc_ptr_NULL, png_voidp_NULL));
+}
+
+/* Allocate memory for a png_struct or a png_info.  The malloc and
+   memset can be replaced by a single call to calloc() if this is thought
+   to improve performance noticably. */
+png_voidp /* PRIVATE */
+png_create_struct_2(int type, png_malloc_ptr malloc_fn, png_voidp mem_ptr)
+{
+#endif /* PNG_USER_MEM_SUPPORTED */
+   png_size_t size;
+   png_voidp struct_ptr;
+
+   if (type == PNG_STRUCT_INFO)
+      size = sizeof(png_info);
+   else if (type == PNG_STRUCT_PNG)
+      size = sizeof(png_struct);
+   else
+      return (NULL);
+
+#ifdef PNG_USER_MEM_SUPPORTED
+   if(malloc_fn != NULL)
+   {
+      png_struct dummy_struct;
+      png_structp png_ptr = &dummy_struct;
+      png_ptr->mem_ptr=mem_ptr;
+      struct_ptr = (*(malloc_fn))(png_ptr, size);
+      if (struct_ptr != NULL)
+         png_memset(struct_ptr, 0, size);
+      return (struct_ptr);
+   }
+#endif /* PNG_USER_MEM_SUPPORTED */
+
+#if defined(__TURBOC__) && !defined(__FLAT__)
+   if ((struct_ptr = (png_voidp)farmalloc(size)) != NULL)
+#else
+# if defined(_MSC_VER) && defined(MAXSEG_64K)
+   if ((struct_ptr = (png_voidp)halloc(size,1)) != NULL)
+# else
+   if ((struct_ptr = (png_voidp)malloc(size)) != NULL)
+# endif
+#endif
+   {
+      png_memset(struct_ptr, 0, size);
+   }
+
+   return (struct_ptr);
+}
+
+
+/* Free memory allocated by a png_create_struct() call */
+void /* PRIVATE */
+png_destroy_struct(png_voidp struct_ptr)
+{
+#ifdef PNG_USER_MEM_SUPPORTED
+   png_destroy_struct_2(struct_ptr, png_free_ptr_NULL, png_voidp_NULL);
+}
+
+/* Free memory allocated by a png_create_struct() call */
+void /* PRIVATE */
+png_destroy_struct_2(png_voidp struct_ptr, png_free_ptr free_fn,
+    png_voidp mem_ptr)
+{
+#endif /* PNG_USER_MEM_SUPPORTED */
+   if (struct_ptr != NULL)
+   {
+#ifdef PNG_USER_MEM_SUPPORTED
+      if(free_fn != NULL)
+      {
+         png_struct dummy_struct;
+         png_structp png_ptr = &dummy_struct;
+         png_ptr->mem_ptr=mem_ptr;
+         (*(free_fn))(png_ptr, struct_ptr);
+         return;
+      }
+#endif /* PNG_USER_MEM_SUPPORTED */
+#if defined(__TURBOC__) && !defined(__FLAT__)
+      farfree(struct_ptr);
+#else
+# if defined(_MSC_VER) && defined(MAXSEG_64K)
+      hfree(struct_ptr);
+# else
+      free(struct_ptr);
+# endif
+#endif
+   }
+}
+
+/* Allocate memory.  For reasonable files, size should never exceed
+   64K.  However, zlib may allocate more then 64K if you don't tell
+   it not to.  See zconf.h and png.h for more information.  zlib does
+   need to allocate exactly 64K, so whatever you call here must
+   have the ability to do that. */
+
+png_voidp PNGAPI
+png_malloc(png_structp png_ptr, png_uint_32 size)
+{
+   png_voidp ret;
+
+   if (png_ptr == NULL || size == 0)
+      return (NULL);
+
+#ifdef PNG_USER_MEM_SUPPORTED
+   if(png_ptr->malloc_fn != NULL)
+   {
+       ret = ((png_voidp)(*(png_ptr->malloc_fn))(png_ptr, (png_size_t)size));
+       if (ret == NULL && (png_ptr->flags&PNG_FLAG_MALLOC_NULL_MEM_OK) == 0)
+          png_error(png_ptr, "Out of Memory!");
+       return (ret);
+   }
+   else
+       return (png_malloc_default(png_ptr, size));
+}
+
+png_voidp PNGAPI
+png_malloc_default(png_structp png_ptr, png_uint_32 size)
+{
+   png_voidp ret;
+#endif /* PNG_USER_MEM_SUPPORTED */
+
+#ifdef PNG_MAX_MALLOC_64K
+   if (size > (png_uint_32)65536L)
+   {
+      if(png_ptr->flags&PNG_FLAG_MALLOC_NULL_MEM_OK) == 0)
+         png_error(png_ptr, "Cannot Allocate > 64K");
+      else
+         return NULL;
+   }
+#endif
+
+#if defined(__TURBOC__) && !defined(__FLAT__)
+   ret = farmalloc(size);
+#else
+# if defined(_MSC_VER) && defined(MAXSEG_64K)
+   ret = halloc(size, 1);
+# else
+   ret = malloc((size_t)size);
+# endif
+#endif
+
+   if (ret == NULL && (png_ptr->flags&PNG_FLAG_MALLOC_NULL_MEM_OK) == 0)
+      png_error(png_ptr, "Out of Memory");
+
+   return (ret);
+}
+
+/* Free a pointer allocated by png_malloc().  If ptr is NULL, return
+   without taking any action. */
+void PNGAPI
+png_free(png_structp png_ptr, png_voidp ptr)
+{
+   if (png_ptr == NULL || ptr == NULL)
+      return;
+
+#ifdef PNG_USER_MEM_SUPPORTED
+   if (png_ptr->free_fn != NULL)
+   {
+      (*(png_ptr->free_fn))(png_ptr, ptr);
+      return;
+   }
+   else png_free_default(png_ptr, ptr);
+}
+void PNGAPI
+png_free_default(png_structp png_ptr, png_voidp ptr)
+{
+   if (png_ptr == NULL || ptr == NULL)
+      return;
+
+#endif /* PNG_USER_MEM_SUPPORTED */
+
+#if defined(__TURBOC__) && !defined(__FLAT__)
+   farfree(ptr);
+#else
+# if defined(_MSC_VER) && defined(MAXSEG_64K)
+   hfree(ptr);
+# else
+   free(ptr);
+# endif
+#endif
+}
+
+#endif /* Not Borland DOS special memory handler */
+
+#if defined(PNG_1_0_X)
+#  define png_malloc_warn png_malloc
+#else
+/* This function was added at libpng version 1.2.3.  The png_malloc_warn()
+ * function will issue a png_warning and return NULL instead of issuing a
+ * png_error, if it fails to allocate the requested memory.
+ */
+png_voidp PNGAPI
+png_malloc_warn(png_structp png_ptr, png_uint_32 size)
+{
+   png_voidp ptr;
+   png_uint_32 save_flags=png_ptr->flags;
+
+   png_ptr->flags|=PNG_FLAG_MALLOC_NULL_MEM_OK;
+   ptr = (png_voidp)png_malloc((png_structp)png_ptr, size);
+   png_ptr->flags=save_flags;
+   return(ptr);
+}
+#endif
+
+png_voidp PNGAPI
+png_memcpy_check (png_structp png_ptr, png_voidp s1, png_voidp s2,
+   png_uint_32 length)
+{
+   png_size_t size;
+
+   size = (png_size_t)length;
+   if ((png_uint_32)size != length)
+      png_error(png_ptr,"Overflow in png_memcpy_check.");
+
+   return(png_memcpy (s1, s2, size));
+}
+
+png_voidp PNGAPI
+png_memset_check (png_structp png_ptr, png_voidp s1, int value,
+   png_uint_32 length)
+{
+   png_size_t size;
+
+   size = (png_size_t)length;
+   if ((png_uint_32)size != length)
+      png_error(png_ptr,"Overflow in png_memset_check.");
+
+   return (png_memset (s1, value, size));
+
+}
+
+#ifdef PNG_USER_MEM_SUPPORTED
+/* This function is called when the application wants to use another method
+ * of allocating and freeing memory.
+ */
+void PNGAPI
+png_set_mem_fn(png_structp png_ptr, png_voidp mem_ptr, png_malloc_ptr
+  malloc_fn, png_free_ptr free_fn)
+{
+   png_ptr->mem_ptr = mem_ptr;
+   png_ptr->malloc_fn = malloc_fn;
+   png_ptr->free_fn = free_fn;
+}
+
+/* This function returns a pointer to the mem_ptr associated with the user
+ * functions.  The application should free any memory associated with this
+ * pointer before png_write_destroy and png_read_destroy are called.
+ */
+png_voidp PNGAPI
+png_get_mem_ptr(png_structp png_ptr)
+{
+   return ((png_voidp)png_ptr->mem_ptr);
+}
+#endif /* PNG_USER_MEM_SUPPORTED */
diff --git a/collects/plot/src/all/pngpread.c b/collects/plot/src/all/pngpread.c
new file mode 100644
index 0000000000..9f924c34cc
--- /dev/null
+++ b/collects/plot/src/all/pngpread.c
@@ -0,0 +1,1543 @@
+
+/* pngpread.c - read a png file in push mode
+ *
+ * libpng 1.2.5 - October 3, 2002
+ * For conditions of distribution and use, see copyright notice in png.h
+ * Copyright (c) 1998-2002 Glenn Randers-Pehrson
+ * (Version 0.96 Copyright (c) 1996, 1997 Andreas Dilger)
+ * (Version 0.88 Copyright (c) 1995, 1996 Guy Eric Schalnat, Group 42, Inc.)
+ */
+
+#define PNG_INTERNAL
+#include "png.h"
+
+#ifdef PNG_PROGRESSIVE_READ_SUPPORTED
+
+/* push model modes */
+#define PNG_READ_SIG_MODE   0
+#define PNG_READ_CHUNK_MODE 1
+#define PNG_READ_IDAT_MODE  2
+#define PNG_SKIP_MODE       3
+#define PNG_READ_tEXt_MODE  4
+#define PNG_READ_zTXt_MODE  5
+#define PNG_READ_DONE_MODE  6
+#define PNG_READ_iTXt_MODE  7
+#define PNG_ERROR_MODE      8
+
+void PNGAPI
+png_process_data(png_structp png_ptr, png_infop info_ptr,
+   png_bytep buffer, png_size_t buffer_size)
+{
+   png_push_restore_buffer(png_ptr, buffer, buffer_size);
+
+   while (png_ptr->buffer_size)
+   {
+      png_process_some_data(png_ptr, info_ptr);
+   }
+}
+
+/* What we do with the incoming data depends on what we were previously
+ * doing before we ran out of data...
+ */
+void /* PRIVATE */
+png_process_some_data(png_structp png_ptr, png_infop info_ptr)
+{
+   switch (png_ptr->process_mode)
+   {
+      case PNG_READ_SIG_MODE:
+      {
+         png_push_read_sig(png_ptr, info_ptr);
+         break;
+      }
+      case PNG_READ_CHUNK_MODE:
+      {
+         png_push_read_chunk(png_ptr, info_ptr);
+         break;
+      }
+      case PNG_READ_IDAT_MODE:
+      {
+         png_push_read_IDAT(png_ptr);
+         break;
+      }
+#if defined(PNG_READ_tEXt_SUPPORTED)
+      case PNG_READ_tEXt_MODE:
+      {
+         png_push_read_tEXt(png_ptr, info_ptr);
+         break;
+      }
+#endif
+#if defined(PNG_READ_zTXt_SUPPORTED)
+      case PNG_READ_zTXt_MODE:
+      {
+         png_push_read_zTXt(png_ptr, info_ptr);
+         break;
+      }
+#endif
+#if defined(PNG_READ_iTXt_SUPPORTED)
+      case PNG_READ_iTXt_MODE:
+      {
+         png_push_read_iTXt(png_ptr, info_ptr);
+         break;
+      }
+#endif
+      case PNG_SKIP_MODE:
+      {
+         png_push_crc_finish(png_ptr);
+         break;
+      }
+      default:
+      {
+         png_ptr->buffer_size = 0;
+         break;
+      }
+   }
+}
+
+/* Read any remaining signature bytes from the stream and compare them with
+ * the correct PNG signature.  It is possible that this routine is called
+ * with bytes already read from the signature, either because they have been
+ * checked by the calling application, or because of multiple calls to this
+ * routine.
+ */
+void /* PRIVATE */
+png_push_read_sig(png_structp png_ptr, png_infop info_ptr)
+{
+   png_size_t num_checked = png_ptr->sig_bytes,
+             num_to_check = 8 - num_checked;
+
+   if (png_ptr->buffer_size < num_to_check)
+   {
+      num_to_check = png_ptr->buffer_size;
+   }
+
+   png_push_fill_buffer(png_ptr, &(info_ptr->signature[num_checked]),
+      num_to_check);
+   png_ptr->sig_bytes = (png_byte)(png_ptr->sig_bytes+num_to_check);
+
+   if (png_sig_cmp(info_ptr->signature, num_checked, num_to_check))
+   {
+      if (num_checked < 4 &&
+          png_sig_cmp(info_ptr->signature, num_checked, num_to_check - 4))
+         png_error(png_ptr, "Not a PNG file");
+      else
+         png_error(png_ptr, "PNG file corrupted by ASCII conversion");
+   }
+   else
+   {
+      if (png_ptr->sig_bytes >= 8)
+      {
+         png_ptr->process_mode = PNG_READ_CHUNK_MODE;
+      }
+   }
+}
+
+void /* PRIVATE */
+png_push_read_chunk(png_structp png_ptr, png_infop info_ptr)
+{
+#ifdef PNG_USE_LOCAL_ARRAYS
+      PNG_IHDR;
+      PNG_IDAT;
+      PNG_IEND;
+      PNG_PLTE;
+#if defined(PNG_READ_bKGD_SUPPORTED)
+      PNG_bKGD;
+#endif
+#if defined(PNG_READ_cHRM_SUPPORTED)
+      PNG_cHRM;
+#endif
+#if defined(PNG_READ_gAMA_SUPPORTED)
+      PNG_gAMA;
+#endif
+#if defined(PNG_READ_hIST_SUPPORTED)
+      PNG_hIST;
+#endif
+#if defined(PNG_READ_iCCP_SUPPORTED)
+      PNG_iCCP;
+#endif
+#if defined(PNG_READ_iTXt_SUPPORTED)
+      PNG_iTXt;
+#endif
+#if defined(PNG_READ_oFFs_SUPPORTED)
+      PNG_oFFs;
+#endif
+#if defined(PNG_READ_pCAL_SUPPORTED)
+      PNG_pCAL;
+#endif
+#if defined(PNG_READ_pHYs_SUPPORTED)
+      PNG_pHYs;
+#endif
+#if defined(PNG_READ_sBIT_SUPPORTED)
+      PNG_sBIT;
+#endif
+#if defined(PNG_READ_sCAL_SUPPORTED)
+      PNG_sCAL;
+#endif
+#if defined(PNG_READ_sRGB_SUPPORTED)
+      PNG_sRGB;
+#endif
+#if defined(PNG_READ_sPLT_SUPPORTED)
+      PNG_sPLT;
+#endif
+#if defined(PNG_READ_tEXt_SUPPORTED)
+      PNG_tEXt;
+#endif
+#if defined(PNG_READ_tIME_SUPPORTED)
+      PNG_tIME;
+#endif
+#if defined(PNG_READ_tRNS_SUPPORTED)
+      PNG_tRNS;
+#endif
+#if defined(PNG_READ_zTXt_SUPPORTED)
+      PNG_zTXt;
+#endif
+#endif /* PNG_USE_LOCAL_ARRAYS */
+   /* First we make sure we have enough data for the 4 byte chunk name
+    * and the 4 byte chunk length before proceeding with decoding the
+    * chunk data.  To fully decode each of these chunks, we also make
+    * sure we have enough data in the buffer for the 4 byte CRC at the
+    * end of every chunk (except IDAT, which is handled separately).
+    */
+   if (!(png_ptr->mode & PNG_HAVE_CHUNK_HEADER))
+   {
+      png_byte chunk_length[4];
+
+      if (png_ptr->buffer_size < 8)
+      {
+         png_push_save_buffer(png_ptr);
+         return;
+      }
+
+      png_push_fill_buffer(png_ptr, chunk_length, 4);
+      png_ptr->push_length = png_get_uint_32(chunk_length);
+      png_reset_crc(png_ptr);
+      png_crc_read(png_ptr, png_ptr->chunk_name, 4);
+      png_ptr->mode |= PNG_HAVE_CHUNK_HEADER;
+   }
+
+   if (!png_memcmp(png_ptr->chunk_name, png_IHDR, 4))
+   {
+      if (png_ptr->push_length + 4 > png_ptr->buffer_size)
+      {
+         png_push_save_buffer(png_ptr);
+         return;
+      }
+      png_handle_IHDR(png_ptr, info_ptr, png_ptr->push_length);
+   }
+   else if (!png_memcmp(png_ptr->chunk_name, png_PLTE, 4))
+   {
+      if (png_ptr->push_length + 4 > png_ptr->buffer_size)
+      {
+         png_push_save_buffer(png_ptr);
+         return;
+      }
+      png_handle_PLTE(png_ptr, info_ptr, png_ptr->push_length);
+   }
+   else if (!png_memcmp(png_ptr->chunk_name, (png_bytep)png_IDAT, 4))
+   {
+      /* If we reach an IDAT chunk, this means we have read all of the
+       * header chunks, and we can start reading the image (or if this
+       * is called after the image has been read - we have an error).
+       */
+     if (!(png_ptr->mode & PNG_HAVE_IHDR))
+       png_error(png_ptr, "Missing IHDR before IDAT");
+     else if (png_ptr->color_type == PNG_COLOR_TYPE_PALETTE &&
+         !(png_ptr->mode & PNG_HAVE_PLTE))
+       png_error(png_ptr, "Missing PLTE before IDAT");
+
+      if (png_ptr->mode & PNG_HAVE_IDAT)
+      {
+         if (png_ptr->push_length == 0)
+            return;
+
+         if (png_ptr->mode & PNG_AFTER_IDAT)
+            png_error(png_ptr, "Too many IDAT's found");
+      }
+
+      png_ptr->idat_size = png_ptr->push_length;
+      png_ptr->mode |= PNG_HAVE_IDAT;
+      png_ptr->process_mode = PNG_READ_IDAT_MODE;
+      png_push_have_info(png_ptr, info_ptr);
+      png_ptr->zstream.avail_out = (uInt)png_ptr->irowbytes;
+      png_ptr->zstream.next_out = png_ptr->row_buf;
+      return;
+   }
+   else if (!png_memcmp(png_ptr->chunk_name, png_IEND, 4))
+   {
+      if (png_ptr->push_length + 4 > png_ptr->buffer_size)
+      {
+         png_push_save_buffer(png_ptr);
+         return;
+      }
+      png_handle_IEND(png_ptr, info_ptr, png_ptr->push_length);
+
+      png_ptr->process_mode = PNG_READ_DONE_MODE;
+      png_push_have_end(png_ptr, info_ptr);
+   }
+#if defined(PNG_READ_gAMA_SUPPORTED)
+   else if (!png_memcmp(png_ptr->chunk_name, png_gAMA, 4))
+   {
+      if (png_ptr->push_length + 4 > png_ptr->buffer_size)
+      {
+         png_push_save_buffer(png_ptr);
+         return;
+      }
+      png_handle_gAMA(png_ptr, info_ptr, png_ptr->push_length);
+   }
+#endif
+#if defined(PNG_READ_sBIT_SUPPORTED)
+   else if (!png_memcmp(png_ptr->chunk_name, png_sBIT, 4))
+   {
+      if (png_ptr->push_length + 4 > png_ptr->buffer_size)
+      {
+         png_push_save_buffer(png_ptr);
+         return;
+      }
+      png_handle_sBIT(png_ptr, info_ptr, png_ptr->push_length);
+   }
+#endif
+#if defined(PNG_READ_cHRM_SUPPORTED)
+   else if (!png_memcmp(png_ptr->chunk_name, png_cHRM, 4))
+   {
+      if (png_ptr->push_length + 4 > png_ptr->buffer_size)
+      {
+         png_push_save_buffer(png_ptr);
+         return;
+      }
+      png_handle_cHRM(png_ptr, info_ptr, png_ptr->push_length);
+   }
+#endif
+#if defined(PNG_READ_sRGB_SUPPORTED)
+   else if (!png_memcmp(png_ptr->chunk_name, png_sRGB, 4))
+   {
+      if (png_ptr->push_length + 4 > png_ptr->buffer_size)
+      {
+         png_push_save_buffer(png_ptr);
+         return;
+      }
+      png_handle_sRGB(png_ptr, info_ptr, png_ptr->push_length);
+   }
+#endif
+#if defined(PNG_READ_iCCP_SUPPORTED)
+   else if (!png_memcmp(png_ptr->chunk_name, png_iCCP, 4))
+   {
+      if (png_ptr->push_length + 4 > png_ptr->buffer_size)
+      {
+         png_push_save_buffer(png_ptr);
+         return;
+      }
+      png_handle_iCCP(png_ptr, info_ptr, png_ptr->push_length);
+   }
+#endif
+#if defined(PNG_READ_sPLT_SUPPORTED)
+   else if (!png_memcmp(png_ptr->chunk_name, png_sPLT, 4))
+   {
+      if (png_ptr->push_length + 4 > png_ptr->buffer_size)
+      {
+         png_push_save_buffer(png_ptr);
+         return;
+      }
+      png_handle_sPLT(png_ptr, info_ptr, png_ptr->push_length);
+   }
+#endif
+#if defined(PNG_READ_tRNS_SUPPORTED)
+   else if (!png_memcmp(png_ptr->chunk_name, png_tRNS, 4))
+   {
+      if (png_ptr->push_length + 4 > png_ptr->buffer_size)
+      {
+         png_push_save_buffer(png_ptr);
+         return;
+      }
+      png_handle_tRNS(png_ptr, info_ptr, png_ptr->push_length);
+   }
+#endif
+#if defined(PNG_READ_bKGD_SUPPORTED)
+   else if (!png_memcmp(png_ptr->chunk_name, png_bKGD, 4))
+   {
+      if (png_ptr->push_length + 4 > png_ptr->buffer_size)
+      {
+         png_push_save_buffer(png_ptr);
+         return;
+      }
+      png_handle_bKGD(png_ptr, info_ptr, png_ptr->push_length);
+   }
+#endif
+#if defined(PNG_READ_hIST_SUPPORTED)
+   else if (!png_memcmp(png_ptr->chunk_name, png_hIST, 4))
+   {
+      if (png_ptr->push_length + 4 > png_ptr->buffer_size)
+      {
+         png_push_save_buffer(png_ptr);
+         return;
+      }
+      png_handle_hIST(png_ptr, info_ptr, png_ptr->push_length);
+   }
+#endif
+#if defined(PNG_READ_pHYs_SUPPORTED)
+   else if (!png_memcmp(png_ptr->chunk_name, png_pHYs, 4))
+   {
+      if (png_ptr->push_length + 4 > png_ptr->buffer_size)
+      {
+         png_push_save_buffer(png_ptr);
+         return;
+      }
+      png_handle_pHYs(png_ptr, info_ptr, png_ptr->push_length);
+   }
+#endif
+#if defined(PNG_READ_oFFs_SUPPORTED)
+   else if (!png_memcmp(png_ptr->chunk_name, png_oFFs, 4))
+   {
+      if (png_ptr->push_length + 4 > png_ptr->buffer_size)
+      {
+         png_push_save_buffer(png_ptr);
+         return;
+      }
+      png_handle_oFFs(png_ptr, info_ptr, png_ptr->push_length);
+   }
+#endif
+#if defined(PNG_READ_pCAL_SUPPORTED)
+   else if (!png_memcmp(png_ptr->chunk_name, png_pCAL, 4))
+   {
+      if (png_ptr->push_length + 4 > png_ptr->buffer_size)
+      {
+         png_push_save_buffer(png_ptr);
+         return;
+      }
+      png_handle_pCAL(png_ptr, info_ptr, png_ptr->push_length);
+   }
+#endif
+#if defined(PNG_READ_sCAL_SUPPORTED)
+   else if (!png_memcmp(png_ptr->chunk_name, png_sCAL, 4))
+   {
+      if (png_ptr->push_length + 4 > png_ptr->buffer_size)
+      {
+         png_push_save_buffer(png_ptr);
+         return;
+      }
+      png_handle_sCAL(png_ptr, info_ptr, png_ptr->push_length);
+   }
+#endif
+#if defined(PNG_READ_tIME_SUPPORTED)
+   else if (!png_memcmp(png_ptr->chunk_name, png_tIME, 4))
+   {
+      if (png_ptr->push_length + 4 > png_ptr->buffer_size)
+      {
+         png_push_save_buffer(png_ptr);
+         return;
+      }
+      png_handle_tIME(png_ptr, info_ptr, png_ptr->push_length);
+   }
+#endif
+#if defined(PNG_READ_tEXt_SUPPORTED)
+   else if (!png_memcmp(png_ptr->chunk_name, png_tEXt, 4))
+   {
+      if (png_ptr->push_length + 4 > png_ptr->buffer_size)
+      {
+         png_push_save_buffer(png_ptr);
+         return;
+      }
+      png_push_handle_tEXt(png_ptr, info_ptr, png_ptr->push_length);
+   }
+#endif
+#if defined(PNG_READ_zTXt_SUPPORTED)
+   else if (!png_memcmp(png_ptr->chunk_name, png_zTXt, 4))
+   {
+      if (png_ptr->push_length + 4 > png_ptr->buffer_size)
+      {
+         png_push_save_buffer(png_ptr);
+         return;
+      }
+      png_push_handle_zTXt(png_ptr, info_ptr, png_ptr->push_length);
+   }
+#endif
+#if defined(PNG_READ_iTXt_SUPPORTED)
+   else if (!png_memcmp(png_ptr->chunk_name, png_iTXt, 4))
+   {
+      if (png_ptr->push_length + 4 > png_ptr->buffer_size)
+      {
+         png_push_save_buffer(png_ptr);
+         return;
+      }
+      png_push_handle_iTXt(png_ptr, info_ptr, png_ptr->push_length);
+   }
+#endif
+   else
+   {
+      if (png_ptr->push_length + 4 > png_ptr->buffer_size)
+      {
+         png_push_save_buffer(png_ptr);
+         return;
+      }
+      png_push_handle_unknown(png_ptr, info_ptr, png_ptr->push_length);
+   }
+
+   png_ptr->mode &= ~PNG_HAVE_CHUNK_HEADER;
+}
+
+void /* PRIVATE */
+png_push_crc_skip(png_structp png_ptr, png_uint_32 skip)
+{
+   png_ptr->process_mode = PNG_SKIP_MODE;
+   png_ptr->skip_length = skip;
+}
+
+void /* PRIVATE */
+png_push_crc_finish(png_structp png_ptr)
+{
+   if (png_ptr->skip_length && png_ptr->save_buffer_size)
+   {
+      png_size_t save_size;
+
+      if (png_ptr->skip_length < (png_uint_32)png_ptr->save_buffer_size)
+         save_size = (png_size_t)png_ptr->skip_length;
+      else
+         save_size = png_ptr->save_buffer_size;
+
+      png_calculate_crc(png_ptr, png_ptr->save_buffer_ptr, save_size);
+
+      png_ptr->skip_length -= save_size;
+      png_ptr->buffer_size -= save_size;
+      png_ptr->save_buffer_size -= save_size;
+      png_ptr->save_buffer_ptr += save_size;
+   }
+   if (png_ptr->skip_length && png_ptr->current_buffer_size)
+   {
+      png_size_t save_size;
+
+      if (png_ptr->skip_length < (png_uint_32)png_ptr->current_buffer_size)
+         save_size = (png_size_t)png_ptr->skip_length;
+      else
+         save_size = png_ptr->current_buffer_size;
+
+      png_calculate_crc(png_ptr, png_ptr->current_buffer_ptr, save_size);
+
+      png_ptr->skip_length -= save_size;
+      png_ptr->buffer_size -= save_size;
+      png_ptr->current_buffer_size -= save_size;
+      png_ptr->current_buffer_ptr += save_size;
+   }
+   if (!png_ptr->skip_length)
+   {
+      if (png_ptr->buffer_size < 4)
+      {
+         png_push_save_buffer(png_ptr);
+         return;
+      }
+
+      png_crc_finish(png_ptr, 0);
+      png_ptr->process_mode = PNG_READ_CHUNK_MODE;
+   }
+}
+
+void PNGAPI
+png_push_fill_buffer(png_structp png_ptr, png_bytep buffer, png_size_t length)
+{
+   png_bytep ptr;
+
+   ptr = buffer;
+   if (png_ptr->save_buffer_size)
+   {
+      png_size_t save_size;
+
+      if (length < png_ptr->save_buffer_size)
+         save_size = length;
+      else
+         save_size = png_ptr->save_buffer_size;
+
+      png_memcpy(ptr, png_ptr->save_buffer_ptr, save_size);
+      length -= save_size;
+      ptr += save_size;
+      png_ptr->buffer_size -= save_size;
+      png_ptr->save_buffer_size -= save_size;
+      png_ptr->save_buffer_ptr += save_size;
+   }
+   if (length && png_ptr->current_buffer_size)
+   {
+      png_size_t save_size;
+
+      if (length < png_ptr->current_buffer_size)
+         save_size = length;
+      else
+         save_size = png_ptr->current_buffer_size;
+
+      png_memcpy(ptr, png_ptr->current_buffer_ptr, save_size);
+      png_ptr->buffer_size -= save_size;
+      png_ptr->current_buffer_size -= save_size;
+      png_ptr->current_buffer_ptr += save_size;
+   }
+}
+
+void /* PRIVATE */
+png_push_save_buffer(png_structp png_ptr)
+{
+   if (png_ptr->save_buffer_size)
+   {
+      if (png_ptr->save_buffer_ptr != png_ptr->save_buffer)
+      {
+         png_size_t i,istop;
+         png_bytep sp;
+         png_bytep dp;
+
+         istop = png_ptr->save_buffer_size;
+         for (i = 0, sp = png_ptr->save_buffer_ptr, dp = png_ptr->save_buffer;
+            i < istop; i++, sp++, dp++)
+         {
+            *dp = *sp;
+         }
+      }
+   }
+   if (png_ptr->save_buffer_size + png_ptr->current_buffer_size >
+      png_ptr->save_buffer_max)
+   {
+      png_size_t new_max;
+      png_bytep old_buffer;
+
+      new_max = png_ptr->save_buffer_size + png_ptr->current_buffer_size + 256;
+      old_buffer = png_ptr->save_buffer;
+      png_ptr->save_buffer = (png_bytep)png_malloc(png_ptr,
+         (png_uint_32)new_max);
+      png_memcpy(png_ptr->save_buffer, old_buffer, png_ptr->save_buffer_size);
+      png_free(png_ptr, old_buffer);
+      png_ptr->save_buffer_max = new_max;
+   }
+   if (png_ptr->current_buffer_size)
+   {
+      png_memcpy(png_ptr->save_buffer + png_ptr->save_buffer_size,
+         png_ptr->current_buffer_ptr, png_ptr->current_buffer_size);
+      png_ptr->save_buffer_size += png_ptr->current_buffer_size;
+      png_ptr->current_buffer_size = 0;
+   }
+   png_ptr->save_buffer_ptr = png_ptr->save_buffer;
+   png_ptr->buffer_size = 0;
+}
+
+void /* PRIVATE */
+png_push_restore_buffer(png_structp png_ptr, png_bytep buffer,
+   png_size_t buffer_length)
+{
+   png_ptr->current_buffer = buffer;
+   png_ptr->current_buffer_size = buffer_length;
+   png_ptr->buffer_size = buffer_length + png_ptr->save_buffer_size;
+   png_ptr->current_buffer_ptr = png_ptr->current_buffer;
+}
+
+void /* PRIVATE */
+png_push_read_IDAT(png_structp png_ptr)
+{
+#ifdef PNG_USE_LOCAL_ARRAYS
+   PNG_IDAT;
+#endif
+   if (!(png_ptr->mode & PNG_HAVE_CHUNK_HEADER))
+   {
+      png_byte chunk_length[4];
+
+      if (png_ptr->buffer_size < 8)
+      {
+         png_push_save_buffer(png_ptr);
+         return;
+      }
+
+      png_push_fill_buffer(png_ptr, chunk_length, 4);
+      png_ptr->push_length = png_get_uint_32(chunk_length);
+
+      png_reset_crc(png_ptr);
+      png_crc_read(png_ptr, png_ptr->chunk_name, 4);
+      png_ptr->mode |= PNG_HAVE_CHUNK_HEADER;
+
+      if (png_memcmp(png_ptr->chunk_name, (png_bytep)png_IDAT, 4))
+      {
+         png_ptr->process_mode = PNG_READ_CHUNK_MODE;
+         if (!(png_ptr->flags & PNG_FLAG_ZLIB_FINISHED))
+            png_error(png_ptr, "Not enough compressed data");
+         return;
+      }
+
+      png_ptr->idat_size = png_ptr->push_length;
+   }
+   if (png_ptr->idat_size && png_ptr->save_buffer_size)
+   {
+      png_size_t save_size;
+
+      if (png_ptr->idat_size < (png_uint_32)png_ptr->save_buffer_size)
+      {
+         save_size = (png_size_t)png_ptr->idat_size;
+         /* check for overflow */
+         if((png_uint_32)save_size != png_ptr->idat_size)
+            png_error(png_ptr, "save_size overflowed in pngpread");
+      }
+      else
+         save_size = png_ptr->save_buffer_size;
+
+      png_calculate_crc(png_ptr, png_ptr->save_buffer_ptr, save_size);
+      if (!(png_ptr->flags & PNG_FLAG_ZLIB_FINISHED))
+         png_process_IDAT_data(png_ptr, png_ptr->save_buffer_ptr, save_size);
+      png_ptr->idat_size -= save_size;
+      png_ptr->buffer_size -= save_size;
+      png_ptr->save_buffer_size -= save_size;
+      png_ptr->save_buffer_ptr += save_size;
+   }
+   if (png_ptr->idat_size && png_ptr->current_buffer_size)
+   {
+      png_size_t save_size;
+
+      if (png_ptr->idat_size < (png_uint_32)png_ptr->current_buffer_size)
+      {
+         save_size = (png_size_t)png_ptr->idat_size;
+         /* check for overflow */
+         if((png_uint_32)save_size != png_ptr->idat_size)
+            png_error(png_ptr, "save_size overflowed in pngpread");
+      }
+      else
+         save_size = png_ptr->current_buffer_size;
+
+      png_calculate_crc(png_ptr, png_ptr->current_buffer_ptr, save_size);
+      if (!(png_ptr->flags & PNG_FLAG_ZLIB_FINISHED))
+        png_process_IDAT_data(png_ptr, png_ptr->current_buffer_ptr, save_size);
+
+      png_ptr->idat_size -= save_size;
+      png_ptr->buffer_size -= save_size;
+      png_ptr->current_buffer_size -= save_size;
+      png_ptr->current_buffer_ptr += save_size;
+   }
+   if (!png_ptr->idat_size)
+   {
+      if (png_ptr->buffer_size < 4)
+      {
+         png_push_save_buffer(png_ptr);
+         return;
+      }
+
+      png_crc_finish(png_ptr, 0);
+      png_ptr->mode &= ~PNG_HAVE_CHUNK_HEADER;
+      png_ptr->mode |= PNG_AFTER_IDAT;
+   }
+}
+
+void /* PRIVATE */
+png_process_IDAT_data(png_structp png_ptr, png_bytep buffer,
+   png_size_t buffer_length)
+{
+   int ret;
+
+   if ((png_ptr->flags & PNG_FLAG_ZLIB_FINISHED) && buffer_length)
+      png_error(png_ptr, "Extra compression data");
+
+   png_ptr->zstream.next_in = buffer;
+   png_ptr->zstream.avail_in = (uInt)buffer_length;
+   for(;;)
+   {
+      ret = inflate(&png_ptr->zstream, Z_PARTIAL_FLUSH);
+      if (ret != Z_OK)
+      {
+         if (ret == Z_STREAM_END)
+         {
+            if (png_ptr->zstream.avail_in)
+               png_error(png_ptr, "Extra compressed data");
+            if (!(png_ptr->zstream.avail_out))
+            {
+               png_push_process_row(png_ptr);
+            }
+
+            png_ptr->mode |= PNG_AFTER_IDAT;
+            png_ptr->flags |= PNG_FLAG_ZLIB_FINISHED;
+            break;
+         }
+         else if (ret == Z_BUF_ERROR)
+            break;
+         else
+            png_error(png_ptr, "Decompression Error");
+      }
+      if (!(png_ptr->zstream.avail_out))
+      {
+         if ((
+#if defined(PNG_READ_INTERLACING_SUPPORTED)
+             png_ptr->interlaced && png_ptr->pass > 6) ||
+             (!png_ptr->interlaced &&
+#endif
+             png_ptr->row_number == png_ptr->num_rows-1))
+         {
+           if (png_ptr->zstream.avail_in)
+             png_warning(png_ptr, "Too much data in IDAT chunks");
+           png_ptr->flags |= PNG_FLAG_ZLIB_FINISHED;
+           break;
+         }
+         png_push_process_row(png_ptr);
+         png_ptr->zstream.avail_out = (uInt)png_ptr->irowbytes;
+         png_ptr->zstream.next_out = png_ptr->row_buf;
+      }
+      else
+         break;
+   }
+}
+
+void /* PRIVATE */
+png_push_process_row(png_structp png_ptr)
+{
+   png_ptr->row_info.color_type = png_ptr->color_type;
+   png_ptr->row_info.width = png_ptr->iwidth;
+   png_ptr->row_info.channels = png_ptr->channels;
+   png_ptr->row_info.bit_depth = png_ptr->bit_depth;
+   png_ptr->row_info.pixel_depth = png_ptr->pixel_depth;
+
+   png_ptr->row_info.rowbytes = ((png_ptr->row_info.width *
+      (png_uint_32)png_ptr->row_info.pixel_depth + 7) >> 3);
+
+   png_read_filter_row(png_ptr, &(png_ptr->row_info),
+      png_ptr->row_buf + 1, png_ptr->prev_row + 1,
+      (int)(png_ptr->row_buf[0]));
+
+   png_memcpy_check(png_ptr, png_ptr->prev_row, png_ptr->row_buf,
+      png_ptr->rowbytes + 1);
+
+   if (png_ptr->transformations)
+      png_do_read_transformations(png_ptr);
+
+#if defined(PNG_READ_INTERLACING_SUPPORTED)
+   /* blow up interlaced rows to full size */
+   if (png_ptr->interlaced && (png_ptr->transformations & PNG_INTERLACE))
+   {
+      if (png_ptr->pass < 6)
+/*       old interface (pre-1.0.9):
+         png_do_read_interlace(&(png_ptr->row_info),
+            png_ptr->row_buf + 1, png_ptr->pass, png_ptr->transformations);
+ */
+         png_do_read_interlace(png_ptr);
+
+    switch (png_ptr->pass)
+    {
+         case 0:
+         {
+            int i;
+            for (i = 0; i < 8 && png_ptr->pass == 0; i++)
+            {
+               png_push_have_row(png_ptr, png_ptr->row_buf + 1);
+               png_read_push_finish_row(png_ptr); /* updates png_ptr->pass */
+            }
+            if (png_ptr->pass == 2) /* pass 1 might be empty */
+            {
+               for (i = 0; i < 4 && png_ptr->pass == 2; i++)
+               {
+                  png_push_have_row(png_ptr, png_bytep_NULL);
+                  png_read_push_finish_row(png_ptr);
+               }
+            }
+            if (png_ptr->pass == 4 && png_ptr->height <= 4)
+            {
+               for (i = 0; i < 2 && png_ptr->pass == 4; i++)
+               {
+                  png_push_have_row(png_ptr, png_bytep_NULL);
+                  png_read_push_finish_row(png_ptr);
+               }
+            }
+            if (png_ptr->pass == 6 && png_ptr->height <= 4)
+            {
+                png_push_have_row(png_ptr, png_bytep_NULL);
+                png_read_push_finish_row(png_ptr);
+            }
+            break;
+         }
+         case 1:
+         {
+            int i;
+            for (i = 0; i < 8 && png_ptr->pass == 1; i++)
+            {
+               png_push_have_row(png_ptr, png_ptr->row_buf + 1);
+               png_read_push_finish_row(png_ptr);
+            }
+            if (png_ptr->pass == 2) /* skip top 4 generated rows */
+            {
+               for (i = 0; i < 4 && png_ptr->pass == 2; i++)
+               {
+                  png_push_have_row(png_ptr, png_bytep_NULL);
+                  png_read_push_finish_row(png_ptr);
+               }
+            }
+            break;
+         }
+         case 2:
+         {
+            int i;
+            for (i = 0; i < 4 && png_ptr->pass == 2; i++)
+            {
+               png_push_have_row(png_ptr, png_ptr->row_buf + 1);
+               png_read_push_finish_row(png_ptr);
+            }
+            for (i = 0; i < 4 && png_ptr->pass == 2; i++)
+            {
+               png_push_have_row(png_ptr, png_bytep_NULL);
+               png_read_push_finish_row(png_ptr);
+            }
+            if (png_ptr->pass == 4) /* pass 3 might be empty */
+            {
+               for (i = 0; i < 2 && png_ptr->pass == 4; i++)
+               {
+                  png_push_have_row(png_ptr, png_bytep_NULL);
+                  png_read_push_finish_row(png_ptr);
+               }
+            }
+            break;
+         }
+         case 3:
+         {
+            int i;
+            for (i = 0; i < 4 && png_ptr->pass == 3; i++)
+            {
+               png_push_have_row(png_ptr, png_ptr->row_buf + 1);
+               png_read_push_finish_row(png_ptr);
+            }
+            if (png_ptr->pass == 4) /* skip top two generated rows */
+            {
+               for (i = 0; i < 2 && png_ptr->pass == 4; i++)
+               {
+                  png_push_have_row(png_ptr, png_bytep_NULL);
+                  png_read_push_finish_row(png_ptr);
+               }
+            }
+            break;
+         }
+         case 4:
+         {
+            int i;
+            for (i = 0; i < 2 && png_ptr->pass == 4; i++)
+            {
+               png_push_have_row(png_ptr, png_ptr->row_buf + 1);
+               png_read_push_finish_row(png_ptr);
+            }
+            for (i = 0; i < 2 && png_ptr->pass == 4; i++)
+            {
+               png_push_have_row(png_ptr, png_bytep_NULL);
+               png_read_push_finish_row(png_ptr);
+            }
+            if (png_ptr->pass == 6) /* pass 5 might be empty */
+            {
+               png_push_have_row(png_ptr, png_bytep_NULL);
+               png_read_push_finish_row(png_ptr);
+            }
+            break;
+         }
+         case 5:
+         {
+            int i;
+            for (i = 0; i < 2 && png_ptr->pass == 5; i++)
+            {
+               png_push_have_row(png_ptr, png_ptr->row_buf + 1);
+               png_read_push_finish_row(png_ptr);
+            }
+            if (png_ptr->pass == 6) /* skip top generated row */
+            {
+               png_push_have_row(png_ptr, png_bytep_NULL);
+               png_read_push_finish_row(png_ptr);
+            }
+            break;
+         }
+         case 6:
+         {
+            png_push_have_row(png_ptr, png_ptr->row_buf + 1);
+            png_read_push_finish_row(png_ptr);
+            if (png_ptr->pass != 6)
+               break;
+            png_push_have_row(png_ptr, png_bytep_NULL);
+            png_read_push_finish_row(png_ptr);
+         }
+      }
+   }
+   else
+#endif
+   {
+      png_push_have_row(png_ptr, png_ptr->row_buf + 1);
+      png_read_push_finish_row(png_ptr);
+   }
+}
+
+void /* PRIVATE */
+png_read_push_finish_row(png_structp png_ptr)
+{
+#ifdef PNG_USE_LOCAL_ARRAYS
+   /* arrays to facilitate easy interlacing - use pass (0 - 6) as index */
+
+   /* start of interlace block */
+   const int FARDATA png_pass_start[] = {0, 4, 0, 2, 0, 1, 0};
+
+   /* offset to next interlace block */
+   const int FARDATA png_pass_inc[] = {8, 8, 4, 4, 2, 2, 1};
+
+   /* start of interlace block in the y direction */
+   const int FARDATA png_pass_ystart[] = {0, 0, 4, 0, 2, 0, 1};
+
+   /* offset to next interlace block in the y direction */
+   const int FARDATA png_pass_yinc[] = {8, 8, 8, 4, 4, 2, 2};
+
+   /* Width of interlace block.  This is not currently used - if you need
+    * it, uncomment it here and in png.h
+   const int FARDATA png_pass_width[] = {8, 4, 4, 2, 2, 1, 1};
+   */
+
+   /* Height of interlace block.  This is not currently used - if you need
+    * it, uncomment it here and in png.h
+   const int FARDATA png_pass_height[] = {8, 8, 4, 4, 2, 2, 1};
+   */
+#endif
+
+   png_ptr->row_number++;
+   if (png_ptr->row_number < png_ptr->num_rows)
+      return;
+
+   if (png_ptr->interlaced)
+   {
+      png_ptr->row_number = 0;
+      png_memset_check(png_ptr, png_ptr->prev_row, 0,
+         png_ptr->rowbytes + 1);
+      do
+      {
+         png_ptr->pass++;
+         if ((png_ptr->pass == 1 && png_ptr->width < 5) ||
+             (png_ptr->pass == 3 && png_ptr->width < 3) ||
+             (png_ptr->pass == 5 && png_ptr->width < 2))
+           png_ptr->pass++;
+
+         if (png_ptr->pass > 7)
+            png_ptr->pass--;
+         if (png_ptr->pass >= 7)
+            break;
+
+         png_ptr->iwidth = (png_ptr->width +
+            png_pass_inc[png_ptr->pass] - 1 -
+            png_pass_start[png_ptr->pass]) /
+            png_pass_inc[png_ptr->pass];
+
+         png_ptr->irowbytes = ((png_ptr->iwidth *
+            png_ptr->pixel_depth + 7) >> 3) + 1;
+
+         if (png_ptr->transformations & PNG_INTERLACE)
+            break;
+
+         png_ptr->num_rows = (png_ptr->height +
+            png_pass_yinc[png_ptr->pass] - 1 -
+            png_pass_ystart[png_ptr->pass]) /
+            png_pass_yinc[png_ptr->pass];
+
+      } while (png_ptr->iwidth == 0 || png_ptr->num_rows == 0);
+   }
+}
+
+#if defined(PNG_READ_tEXt_SUPPORTED)
+void /* PRIVATE */
+png_push_handle_tEXt(png_structp png_ptr, png_infop info_ptr, png_uint_32
+   length)
+{
+   if (!(png_ptr->mode & PNG_HAVE_IHDR) || (png_ptr->mode & PNG_HAVE_IEND))
+      {
+         png_error(png_ptr, "Out of place tEXt");
+         /* to quiet some compiler warnings */
+         if(info_ptr == NULL) return;
+      }
+
+#ifdef PNG_MAX_MALLOC_64K
+   png_ptr->skip_length = 0;  /* This may not be necessary */
+
+   if (length > (png_uint_32)65535L) /* Can't hold entire string in memory */
+   {
+      png_warning(png_ptr, "tEXt chunk too large to fit in memory");
+      png_ptr->skip_length = length - (png_uint_32)65535L;
+      length = (png_uint_32)65535L;
+   }
+#endif
+
+   png_ptr->current_text = (png_charp)png_malloc(png_ptr,
+         (png_uint_32)(length+1));
+   png_ptr->current_text[length] = '\0';
+   png_ptr->current_text_ptr = png_ptr->current_text;
+   png_ptr->current_text_size = (png_size_t)length;
+   png_ptr->current_text_left = (png_size_t)length;
+   png_ptr->process_mode = PNG_READ_tEXt_MODE;
+}
+
+void /* PRIVATE */
+png_push_read_tEXt(png_structp png_ptr, png_infop info_ptr)
+{
+   if (png_ptr->buffer_size && png_ptr->current_text_left)
+   {
+      png_size_t text_size;
+
+      if (png_ptr->buffer_size < png_ptr->current_text_left)
+         text_size = png_ptr->buffer_size;
+      else
+         text_size = png_ptr->current_text_left;
+      png_crc_read(png_ptr, (png_bytep)png_ptr->current_text_ptr, text_size);
+      png_ptr->current_text_left -= text_size;
+      png_ptr->current_text_ptr += text_size;
+   }
+   if (!(png_ptr->current_text_left))
+   {
+      png_textp text_ptr;
+      png_charp text;
+      png_charp key;
+      int ret;
+
+      if (png_ptr->buffer_size < 4)
+      {
+         png_push_save_buffer(png_ptr);
+         return;
+      }
+
+      png_push_crc_finish(png_ptr);
+
+#if defined(PNG_MAX_MALLOC_64K)
+      if (png_ptr->skip_length)
+         return;
+#endif
+
+      key = png_ptr->current_text;
+
+      for (text = key; *text; text++)
+         /* empty loop */ ;
+
+      if (text != key + png_ptr->current_text_size)
+         text++;
+
+      text_ptr = (png_textp)png_malloc(png_ptr, (png_uint_32)sizeof(png_text));
+      text_ptr->compression = PNG_TEXT_COMPRESSION_NONE;
+      text_ptr->key = key;
+#ifdef PNG_iTXt_SUPPORTED
+      text_ptr->lang = NULL;
+      text_ptr->lang_key = NULL;
+#endif
+      text_ptr->text = text;
+
+      ret = png_set_text_2(png_ptr, info_ptr, text_ptr, 1);
+
+      png_free(png_ptr, key);
+      png_free(png_ptr, text_ptr);
+      png_ptr->current_text = NULL;
+
+      if (ret)
+        png_warning(png_ptr, "Insufficient memory to store text chunk.");
+   }
+}
+#endif
+
+#if defined(PNG_READ_zTXt_SUPPORTED)
+void /* PRIVATE */
+png_push_handle_zTXt(png_structp png_ptr, png_infop info_ptr, png_uint_32
+   length)
+{
+   if (!(png_ptr->mode & PNG_HAVE_IHDR) || (png_ptr->mode & PNG_HAVE_IEND))
+      {
+         png_error(png_ptr, "Out of place zTXt");
+         /* to quiet some compiler warnings */
+         if(info_ptr == NULL) return;
+      }
+
+#ifdef PNG_MAX_MALLOC_64K
+   /* We can't handle zTXt chunks > 64K, since we don't have enough space
+    * to be able to store the uncompressed data.  Actually, the threshold
+    * is probably around 32K, but it isn't as definite as 64K is.
+    */
+   if (length > (png_uint_32)65535L)
+   {
+      png_warning(png_ptr, "zTXt chunk too large to fit in memory");
+      png_push_crc_skip(png_ptr, length);
+      return;
+   }
+#endif
+
+   png_ptr->current_text = (png_charp)png_malloc(png_ptr,
+       (png_uint_32)(length+1));
+   png_ptr->current_text[length] = '\0';
+   png_ptr->current_text_ptr = png_ptr->current_text;
+   png_ptr->current_text_size = (png_size_t)length;
+   png_ptr->current_text_left = (png_size_t)length;
+   png_ptr->process_mode = PNG_READ_zTXt_MODE;
+}
+
+void /* PRIVATE */
+png_push_read_zTXt(png_structp png_ptr, png_infop info_ptr)
+{
+   if (png_ptr->buffer_size && png_ptr->current_text_left)
+   {
+      png_size_t text_size;
+
+      if (png_ptr->buffer_size < (png_uint_32)png_ptr->current_text_left)
+         text_size = png_ptr->buffer_size;
+      else
+         text_size = png_ptr->current_text_left;
+      png_crc_read(png_ptr, (png_bytep)png_ptr->current_text_ptr, text_size);
+      png_ptr->current_text_left -= text_size;
+      png_ptr->current_text_ptr += text_size;
+   }
+   if (!(png_ptr->current_text_left))
+   {
+      png_textp text_ptr;
+      png_charp text;
+      png_charp key;
+      int ret;
+      png_size_t text_size, key_size;
+
+      if (png_ptr->buffer_size < 4)
+      {
+         png_push_save_buffer(png_ptr);
+         return;
+      }
+
+      png_push_crc_finish(png_ptr);
+
+      key = png_ptr->current_text;
+
+      for (text = key; *text; text++)
+         /* empty loop */ ;
+
+      /* zTXt can't have zero text */
+      if (text == key + png_ptr->current_text_size)
+      {
+         png_ptr->current_text = NULL;
+         png_free(png_ptr, key);
+         return;
+      }
+
+      text++;
+
+      if (*text != PNG_TEXT_COMPRESSION_zTXt) /* check compression byte */
+      {
+         png_ptr->current_text = NULL;
+         png_free(png_ptr, key);
+         return;
+      }
+
+      text++;
+
+      png_ptr->zstream.next_in = (png_bytep )text;
+      png_ptr->zstream.avail_in = (uInt)(png_ptr->current_text_size -
+         (text - key));
+      png_ptr->zstream.next_out = png_ptr->zbuf;
+      png_ptr->zstream.avail_out = (uInt)png_ptr->zbuf_size;
+
+      key_size = text - key;
+      text_size = 0;
+      text = NULL;
+      ret = Z_STREAM_END;
+
+      while (png_ptr->zstream.avail_in)
+      {
+         ret = inflate(&png_ptr->zstream, Z_PARTIAL_FLUSH);
+         if (ret != Z_OK && ret != Z_STREAM_END)
+         {
+            inflateReset(&png_ptr->zstream);
+            png_ptr->zstream.avail_in = 0;
+            png_ptr->current_text = NULL;
+            png_free(png_ptr, key);
+            png_free(png_ptr, text);
+            return;
+         }
+         if (!(png_ptr->zstream.avail_out) || ret == Z_STREAM_END)
+         {
+            if (text == NULL)
+            {
+               text = (png_charp)png_malloc(png_ptr,
+                  (png_uint_32)(png_ptr->zbuf_size - png_ptr->zstream.avail_out
+                     + key_size + 1));
+               png_memcpy(text + key_size, png_ptr->zbuf,
+                  png_ptr->zbuf_size - png_ptr->zstream.avail_out);
+               png_memcpy(text, key, key_size);
+               text_size = key_size + png_ptr->zbuf_size -
+                  png_ptr->zstream.avail_out;
+               *(text + text_size) = '\0';
+            }
+            else
+            {
+               png_charp tmp;
+
+               tmp = text;
+               text = (png_charp)png_malloc(png_ptr, text_size +
+                  (png_uint_32)(png_ptr->zbuf_size - png_ptr->zstream.avail_out
+                   + 1));
+               png_memcpy(text, tmp, text_size);
+               png_free(png_ptr, tmp);
+               png_memcpy(text + text_size, png_ptr->zbuf,
+                  png_ptr->zbuf_size - png_ptr->zstream.avail_out);
+               text_size += png_ptr->zbuf_size - png_ptr->zstream.avail_out;
+               *(text + text_size) = '\0';
+            }
+            if (ret != Z_STREAM_END)
+            {
+               png_ptr->zstream.next_out = png_ptr->zbuf;
+               png_ptr->zstream.avail_out = (uInt)png_ptr->zbuf_size;
+            }
+         }
+         else
+         {
+            break;
+         }
+
+         if (ret == Z_STREAM_END)
+            break;
+      }
+
+      inflateReset(&png_ptr->zstream);
+      png_ptr->zstream.avail_in = 0;
+
+      if (ret != Z_STREAM_END)
+      {
+         png_ptr->current_text = NULL;
+         png_free(png_ptr, key);
+         png_free(png_ptr, text);
+         return;
+      }
+
+      png_ptr->current_text = NULL;
+      png_free(png_ptr, key);
+      key = text;
+      text += key_size;
+
+      text_ptr = (png_textp)png_malloc(png_ptr, (png_uint_32)sizeof(png_text));
+      text_ptr->compression = PNG_TEXT_COMPRESSION_zTXt;
+      text_ptr->key = key;
+#ifdef PNG_iTXt_SUPPORTED
+      text_ptr->lang = NULL;
+      text_ptr->lang_key = NULL;
+#endif
+      text_ptr->text = text;
+
+      ret = png_set_text_2(png_ptr, info_ptr, text_ptr, 1);
+
+      png_free(png_ptr, key);
+      png_free(png_ptr, text_ptr);
+
+      if (ret)
+        png_warning(png_ptr, "Insufficient memory to store text chunk.");
+   }
+}
+#endif
+
+#if defined(PNG_READ_iTXt_SUPPORTED)
+void /* PRIVATE */
+png_push_handle_iTXt(png_structp png_ptr, png_infop info_ptr, png_uint_32
+   length)
+{
+   if (!(png_ptr->mode & PNG_HAVE_IHDR) || (png_ptr->mode & PNG_HAVE_IEND))
+      {
+         png_error(png_ptr, "Out of place iTXt");
+         /* to quiet some compiler warnings */
+         if(info_ptr == NULL) return;
+      }
+
+#ifdef PNG_MAX_MALLOC_64K
+   png_ptr->skip_length = 0;  /* This may not be necessary */
+
+   if (length > (png_uint_32)65535L) /* Can't hold entire string in memory */
+   {
+      png_warning(png_ptr, "iTXt chunk too large to fit in memory");
+      png_ptr->skip_length = length - (png_uint_32)65535L;
+      length = (png_uint_32)65535L;
+   }
+#endif
+
+   png_ptr->current_text = (png_charp)png_malloc(png_ptr,
+         (png_uint_32)(length+1));
+   png_ptr->current_text[length] = '\0';
+   png_ptr->current_text_ptr = png_ptr->current_text;
+   png_ptr->current_text_size = (png_size_t)length;
+   png_ptr->current_text_left = (png_size_t)length;
+   png_ptr->process_mode = PNG_READ_iTXt_MODE;
+}
+
+void /* PRIVATE */
+png_push_read_iTXt(png_structp png_ptr, png_infop info_ptr)
+{
+
+   if (png_ptr->buffer_size && png_ptr->current_text_left)
+   {
+      png_size_t text_size;
+
+      if (png_ptr->buffer_size < png_ptr->current_text_left)
+         text_size = png_ptr->buffer_size;
+      else
+         text_size = png_ptr->current_text_left;
+      png_crc_read(png_ptr, (png_bytep)png_ptr->current_text_ptr, text_size);
+      png_ptr->current_text_left -= text_size;
+      png_ptr->current_text_ptr += text_size;
+   }
+   if (!(png_ptr->current_text_left))
+   {
+      png_textp text_ptr;
+      png_charp key;
+      int comp_flag;
+      png_charp lang;
+      png_charp lang_key;
+      png_charp text;
+      int ret;
+
+      if (png_ptr->buffer_size < 4)
+      {
+         png_push_save_buffer(png_ptr);
+         return;
+      }
+
+      png_push_crc_finish(png_ptr);
+
+#if defined(PNG_MAX_MALLOC_64K)
+      if (png_ptr->skip_length)
+         return;
+#endif
+
+      key = png_ptr->current_text;
+
+      for (lang = key; *lang; lang++)
+         /* empty loop */ ;
+
+      if (lang != key + png_ptr->current_text_size)
+         lang++;
+
+      comp_flag = *lang++;
+      lang++;     /* skip comp_type, always zero */
+
+      for (lang_key = lang; *lang_key; lang_key++)
+         /* empty loop */ ;
+      lang_key++;        /* skip NUL separator */
+
+      for (text = lang_key; *text; text++)
+         /* empty loop */ ;
+
+      if (text != key + png_ptr->current_text_size)
+         text++;
+
+      text_ptr = (png_textp)png_malloc(png_ptr, (png_uint_32)sizeof(png_text));
+      text_ptr->compression = comp_flag + 2;
+      text_ptr->key = key;
+      text_ptr->lang = lang;
+      text_ptr->lang_key = lang_key;
+      text_ptr->text = text;
+      text_ptr->text_length = 0;
+      text_ptr->itxt_length = png_strlen(text);
+
+      ret = png_set_text_2(png_ptr, info_ptr, text_ptr, 1);
+
+      png_ptr->current_text = NULL;
+
+      png_free(png_ptr, text_ptr);
+      if (ret)
+        png_warning(png_ptr, "Insufficient memory to store iTXt chunk.");
+   }
+}
+#endif
+
+/* This function is called when we haven't found a handler for this
+ * chunk.  If there isn't a problem with the chunk itself (ie a bad chunk
+ * name or a critical chunk), the chunk is (currently) silently ignored.
+ */
+void /* PRIVATE */
+png_push_handle_unknown(png_structp png_ptr, png_infop info_ptr, png_uint_32
+   length)
+{
+   png_uint_32 skip=0;
+   png_check_chunk_name(png_ptr, png_ptr->chunk_name);
+
+   if (!(png_ptr->chunk_name[0] & 0x20))
+   {
+#if defined(PNG_READ_UNKNOWN_CHUNKS_SUPPORTED)
+      if(png_handle_as_unknown(png_ptr, png_ptr->chunk_name) !=
+           HANDLE_CHUNK_ALWAYS
+#if defined(PNG_READ_USER_CHUNKS_SUPPORTED)
+           && png_ptr->read_user_chunk_fn == NULL
+#endif
+         )
+#endif
+         png_chunk_error(png_ptr, "unknown critical chunk");
+
+      /* to quiet compiler warnings about unused info_ptr */
+      if (info_ptr == NULL)
+         return;
+   }
+
+#if defined(PNG_READ_UNKNOWN_CHUNKS_SUPPORTED)
+   if (png_ptr->flags & PNG_FLAG_KEEP_UNKNOWN_CHUNKS)
+   {
+       png_unknown_chunk chunk;
+
+#ifdef PNG_MAX_MALLOC_64K
+       if (length > (png_uint_32)65535L)
+       {
+           png_warning(png_ptr, "unknown chunk too large to fit in memory");
+           skip = length - (png_uint_32)65535L;
+           length = (png_uint_32)65535L;
+       }
+#endif
+
+       png_strcpy((png_charp)chunk.name, (png_charp)png_ptr->chunk_name);
+       chunk.data = (png_bytep)png_malloc(png_ptr, length);
+       png_crc_read(png_ptr, chunk.data, length);
+       chunk.size = length;
+#if defined(PNG_READ_USER_CHUNKS_SUPPORTED)
+       if(png_ptr->read_user_chunk_fn != NULL)
+       {
+          /* callback to user unknown chunk handler */
+          if ((*(png_ptr->read_user_chunk_fn)) (png_ptr, &chunk) <= 0)
+          {
+             if (!(png_ptr->chunk_name[0] & 0x20))
+                if(png_handle_as_unknown(png_ptr, png_ptr->chunk_name) !=
+                     HANDLE_CHUNK_ALWAYS)
+                   png_chunk_error(png_ptr, "unknown critical chunk");
+          }
+             png_set_unknown_chunks(png_ptr, info_ptr, &chunk, 1);
+       }
+       else
+#endif
+          png_set_unknown_chunks(png_ptr, info_ptr, &chunk, 1);
+       png_free(png_ptr, chunk.data);
+   }
+   else
+#endif
+      skip=length;
+   png_push_crc_skip(png_ptr, skip);
+}
+
+void /* PRIVATE */
+png_push_have_info(png_structp png_ptr, png_infop info_ptr)
+{
+   if (png_ptr->info_fn != NULL)
+      (*(png_ptr->info_fn))(png_ptr, info_ptr);
+}
+
+void /* PRIVATE */
+png_push_have_end(png_structp png_ptr, png_infop info_ptr)
+{
+   if (png_ptr->end_fn != NULL)
+      (*(png_ptr->end_fn))(png_ptr, info_ptr);
+}
+
+void /* PRIVATE */
+png_push_have_row(png_structp png_ptr, png_bytep row)
+{
+   if (png_ptr->row_fn != NULL)
+      (*(png_ptr->row_fn))(png_ptr, row, png_ptr->row_number,
+         (int)png_ptr->pass);
+}
+
+void PNGAPI
+png_progressive_combine_row (png_structp png_ptr,
+   png_bytep old_row, png_bytep new_row)
+{
+#ifdef PNG_USE_LOCAL_ARRAYS
+   const int FARDATA png_pass_dsp_mask[7] =
+      {0xff, 0x0f, 0xff, 0x33, 0xff, 0x55, 0xff};
+#endif
+   if (new_row != NULL)    /* new_row must == png_ptr->row_buf here. */
+      png_combine_row(png_ptr, old_row, png_pass_dsp_mask[png_ptr->pass]);
+}
+
+void PNGAPI
+png_set_progressive_read_fn(png_structp png_ptr, png_voidp progressive_ptr,
+   png_progressive_info_ptr info_fn, png_progressive_row_ptr row_fn,
+   png_progressive_end_ptr end_fn)
+{
+   png_ptr->info_fn = info_fn;
+   png_ptr->row_fn = row_fn;
+   png_ptr->end_fn = end_fn;
+
+   png_set_read_fn(png_ptr, progressive_ptr, png_push_fill_buffer);
+}
+
+png_voidp PNGAPI
+png_get_progressive_ptr(png_structp png_ptr)
+{
+   return png_ptr->io_ptr;
+}
+#endif /* PNG_PROGRESSIVE_READ_SUPPORTED */
diff --git a/collects/plot/src/all/pngread.c b/collects/plot/src/all/pngread.c
new file mode 100644
index 0000000000..e91d3e89ca
--- /dev/null
+++ b/collects/plot/src/all/pngread.c
@@ -0,0 +1,1424 @@
+
+/* pngread.c - read a PNG file
+ *
+ * libpng 1.2.5 - October 3, 2002
+ * For conditions of distribution and use, see copyright notice in png.h
+ * Copyright (c) 1998-2002 Glenn Randers-Pehrson
+ * (Version 0.96 Copyright (c) 1996, 1997 Andreas Dilger)
+ * (Version 0.88 Copyright (c) 1995, 1996 Guy Eric Schalnat, Group 42, Inc.)
+ *
+ * This file contains routines that an application calls directly to
+ * read a PNG file or stream.
+ */
+
+#define PNG_INTERNAL
+#include "png.h"
+
+/* Create a PNG structure for reading, and allocate any memory needed. */
+png_structp PNGAPI
+png_create_read_struct(png_const_charp user_png_ver, png_voidp error_ptr,
+   png_error_ptr error_fn, png_error_ptr warn_fn)
+{
+
+#ifdef PNG_USER_MEM_SUPPORTED
+   return (png_create_read_struct_2(user_png_ver, error_ptr, error_fn,
+      warn_fn, png_voidp_NULL, png_malloc_ptr_NULL, png_free_ptr_NULL));
+}
+
+/* Alternate create PNG structure for reading, and allocate any memory needed. */
+png_structp PNGAPI
+png_create_read_struct_2(png_const_charp user_png_ver, png_voidp error_ptr,
+   png_error_ptr error_fn, png_error_ptr warn_fn, png_voidp mem_ptr,
+   png_malloc_ptr malloc_fn, png_free_ptr free_fn)
+{
+#endif /* PNG_USER_MEM_SUPPORTED */
+
+   png_structp png_ptr;
+
+#ifdef PNG_SETJMP_SUPPORTED
+#ifdef USE_FAR_KEYWORD
+   jmp_buf jmpbuf;
+#endif
+#endif
+
+   int i;
+
+   png_debug(1, "in png_create_read_struct\n");
+#ifdef PNG_USER_MEM_SUPPORTED
+   png_ptr = (png_structp)png_create_struct_2(PNG_STRUCT_PNG,
+      (png_malloc_ptr)malloc_fn, (png_voidp)mem_ptr);
+#else
+   png_ptr = (png_structp)png_create_struct(PNG_STRUCT_PNG);
+#endif
+   if (png_ptr == NULL)
+      return (NULL);
+
+#if !defined(PNG_1_0_X)
+#ifdef PNG_ASSEMBLER_CODE_SUPPORTED
+   png_init_mmx_flags(png_ptr);   /* 1.2.0 addition */
+#endif
+#endif /* PNG_1_0_X */
+
+#ifdef PNG_SETJMP_SUPPORTED
+#ifdef USE_FAR_KEYWORD
+   if (setjmp(jmpbuf))
+#else
+   if (setjmp(png_ptr->jmpbuf))
+#endif
+   {
+      png_free(png_ptr, png_ptr->zbuf);
+      png_ptr->zbuf=NULL;
+#ifdef PNG_USER_MEM_SUPPORTED
+      png_destroy_struct_2((png_voidp)png_ptr, 
+         (png_free_ptr)free_fn, (png_voidp)mem_ptr);
+#else
+      png_destroy_struct((png_voidp)png_ptr);
+#endif
+      return (NULL);
+   }
+#ifdef USE_FAR_KEYWORD
+   png_memcpy(png_ptr->jmpbuf,jmpbuf,sizeof(jmp_buf));
+#endif
+#endif
+
+#ifdef PNG_USER_MEM_SUPPORTED
+   png_set_mem_fn(png_ptr, mem_ptr, malloc_fn, free_fn);
+#endif
+
+   png_set_error_fn(png_ptr, error_ptr, error_fn, warn_fn);
+
+   i=0;
+   do
+   {
+     if(user_png_ver[i] != png_libpng_ver[i])
+        png_ptr->flags |= PNG_FLAG_LIBRARY_MISMATCH;
+   } while (png_libpng_ver[i++]);
+
+   if (png_ptr->flags & PNG_FLAG_LIBRARY_MISMATCH)
+   {
+     /* Libpng 0.90 and later are binary incompatible with libpng 0.89, so
+      * we must recompile any applications that use any older library version.
+      * For versions after libpng 1.0, we will be compatible, so we need
+      * only check the first digit.
+      */
+     if (user_png_ver == NULL || user_png_ver[0] != png_libpng_ver[0] ||
+         (user_png_ver[0] == '1' && user_png_ver[2] != png_libpng_ver[2]) ||
+         (user_png_ver[0] == '0' && user_png_ver[2] < '9'))
+     {
+#if !defined(PNG_NO_STDIO) && !defined(_WIN32_WCE)
+        char msg[80];
+        if (user_png_ver)
+        {
+          sprintf(msg, "Application was compiled with png.h from libpng-%.20s",
+             user_png_ver);
+          png_warning(png_ptr, msg);
+        }
+        sprintf(msg, "Application  is  running with png.c from libpng-%.20s",
+           png_libpng_ver);
+        png_warning(png_ptr, msg);
+#endif
+#ifdef PNG_ERROR_NUMBERS_SUPPORTED
+        png_ptr->flags=0;
+#endif
+        png_error(png_ptr,
+           "Incompatible libpng version in application and library");
+     }
+   }
+
+   /* initialize zbuf - compression buffer */
+   png_ptr->zbuf_size = PNG_ZBUF_SIZE;
+   png_ptr->zbuf = (png_bytep)png_malloc(png_ptr,
+     (png_uint_32)png_ptr->zbuf_size);
+   png_ptr->zstream.zalloc = png_zalloc;
+   png_ptr->zstream.zfree = png_zfree;
+   png_ptr->zstream.opaque = (voidpf)png_ptr;
+
+   switch (inflateInit(&png_ptr->zstream))
+   {
+     case Z_OK: /* Do nothing */ break;
+     case Z_MEM_ERROR:
+     case Z_STREAM_ERROR: png_error(png_ptr, "zlib memory error"); break;
+     case Z_VERSION_ERROR: png_error(png_ptr, "zlib version error"); break;
+     default: png_error(png_ptr, "Unknown zlib error");
+   }
+
+   png_ptr->zstream.next_out = png_ptr->zbuf;
+   png_ptr->zstream.avail_out = (uInt)png_ptr->zbuf_size;
+
+   png_set_read_fn(png_ptr, png_voidp_NULL, png_rw_ptr_NULL);
+
+#ifdef PNG_SETJMP_SUPPORTED
+/* Applications that neglect to set up their own setjmp() and then encounter
+   a png_error() will longjmp here.  Since the jmpbuf is then meaningless we
+   abort instead of returning. */
+#ifdef USE_FAR_KEYWORD
+   if (setjmp(jmpbuf))
+      PNG_ABORT();
+   png_memcpy(png_ptr->jmpbuf,jmpbuf,sizeof(jmp_buf));
+#else
+   if (setjmp(png_ptr->jmpbuf))
+      PNG_ABORT();
+#endif
+#endif
+   return (png_ptr);
+}
+
+/* Initialize PNG structure for reading, and allocate any memory needed.
+   This interface is deprecated in favour of the png_create_read_struct(),
+   and it will eventually disappear. */
+#undef png_read_init
+void PNGAPI
+png_read_init(png_structp png_ptr)
+{
+   /* We only come here via pre-1.0.7-compiled applications */
+   png_read_init_2(png_ptr, "1.0.6 or earlier", 0, 0);
+}
+
+void PNGAPI
+png_read_init_2(png_structp png_ptr, png_const_charp user_png_ver,
+   png_size_t png_struct_size, png_size_t png_info_size)
+{
+   /* We only come here via pre-1.0.12-compiled applications */
+#if !defined(PNG_NO_STDIO) && !defined(_WIN32_WCE)
+   if(sizeof(png_struct) > png_struct_size || sizeof(png_info) > png_info_size)
+   {
+      char msg[80];
+      png_ptr->warning_fn=NULL;
+      if (user_png_ver)
+      {
+        sprintf(msg, "Application was compiled with png.h from libpng-%.20s",
+           user_png_ver);
+        png_warning(png_ptr, msg);
+      }
+      sprintf(msg, "Application  is  running with png.c from libpng-%.20s",
+         png_libpng_ver);
+      png_warning(png_ptr, msg);
+   }
+#endif
+   if(sizeof(png_struct) > png_struct_size)
+     {
+       png_ptr->error_fn=NULL;
+#ifdef PNG_ERROR_NUMBERS_SUPPORTED
+       png_ptr->flags=0;
+#endif
+       png_error(png_ptr,
+       "The png struct allocated by the application for reading is too small.");
+     }
+   if(sizeof(png_info) > png_info_size)
+     {
+       png_ptr->error_fn=NULL;
+#ifdef PNG_ERROR_NUMBERS_SUPPORTED
+       png_ptr->flags=0;
+#endif
+       png_error(png_ptr,
+         "The info struct allocated by application for reading is too small.");
+     }
+   png_read_init_3(&png_ptr, user_png_ver, png_struct_size);
+}
+
+void PNGAPI
+png_read_init_3(png_structpp ptr_ptr, png_const_charp user_png_ver,
+   png_size_t png_struct_size)
+{
+#ifdef PNG_SETJMP_SUPPORTED
+   jmp_buf tmp_jmp;  /* to save current jump buffer */
+#endif
+
+   int i=0;
+
+   png_structp png_ptr=*ptr_ptr;
+
+   do
+   {
+     if(user_png_ver[i] != png_libpng_ver[i])
+     {
+#ifdef PNG_LEGACY_SUPPORTED
+       png_ptr->flags |= PNG_FLAG_LIBRARY_MISMATCH;
+#else
+       png_ptr->warning_fn=NULL;
+       png_warning(png_ptr,
+        "Application uses deprecated png_read_init() and should be recompiled.");
+       break;
+#endif
+     }
+   } while (png_libpng_ver[i++]);
+
+   png_debug(1, "in png_read_init_3\n");
+
+#ifdef PNG_SETJMP_SUPPORTED
+   /* save jump buffer and error functions */
+   png_memcpy(tmp_jmp, png_ptr->jmpbuf, sizeof (jmp_buf));
+#endif
+
+   if(sizeof(png_struct) > png_struct_size)
+     {
+       png_destroy_struct(png_ptr);
+       *ptr_ptr = (png_structp)png_create_struct(PNG_STRUCT_PNG);
+       png_ptr = *ptr_ptr;
+     }
+
+   /* reset all variables to 0 */
+   png_memset(png_ptr, 0, sizeof (png_struct));
+
+#ifdef PNG_SETJMP_SUPPORTED
+   /* restore jump buffer */
+   png_memcpy(png_ptr->jmpbuf, tmp_jmp, sizeof (jmp_buf));
+#endif
+
+   /* initialize zbuf - compression buffer */
+   png_ptr->zbuf_size = PNG_ZBUF_SIZE;
+   png_ptr->zbuf = (png_bytep)png_malloc(png_ptr,
+     (png_uint_32)png_ptr->zbuf_size);
+   png_ptr->zstream.zalloc = png_zalloc;
+   png_ptr->zstream.zfree = png_zfree;
+   png_ptr->zstream.opaque = (voidpf)png_ptr;
+
+   switch (inflateInit(&png_ptr->zstream))
+   {
+     case Z_OK: /* Do nothing */ break;
+     case Z_MEM_ERROR:
+     case Z_STREAM_ERROR: png_error(png_ptr, "zlib memory"); break;
+     case Z_VERSION_ERROR: png_error(png_ptr, "zlib version"); break;
+     default: png_error(png_ptr, "Unknown zlib error");
+   }
+
+   png_ptr->zstream.next_out = png_ptr->zbuf;
+   png_ptr->zstream.avail_out = (uInt)png_ptr->zbuf_size;
+
+   png_set_read_fn(png_ptr, png_voidp_NULL, png_rw_ptr_NULL);
+}
+
+/* Read the information before the actual image data.  This has been
+ * changed in v0.90 to allow reading a file that already has the magic
+ * bytes read from the stream.  You can tell libpng how many bytes have
+ * been read from the beginning of the stream (up to the maximum of 8)
+ * via png_set_sig_bytes(), and we will only check the remaining bytes
+ * here.  The application can then have access to the signature bytes we
+ * read if it is determined that this isn't a valid PNG file.
+ */
+void PNGAPI
+png_read_info(png_structp png_ptr, png_infop info_ptr)
+{
+   png_debug(1, "in png_read_info\n");
+   /* If we haven't checked all of the PNG signature bytes, do so now. */
+   if (png_ptr->sig_bytes < 8)
+   {
+      png_size_t num_checked = png_ptr->sig_bytes,
+                 num_to_check = 8 - num_checked;
+
+      png_read_data(png_ptr, &(info_ptr->signature[num_checked]), num_to_check);
+      png_ptr->sig_bytes = 8;
+
+      if (png_sig_cmp(info_ptr->signature, num_checked, num_to_check))
+      {
+         if (num_checked < 4 &&
+             png_sig_cmp(info_ptr->signature, num_checked, num_to_check - 4))
+            png_error(png_ptr, "Not a PNG file");
+         else
+            png_error(png_ptr, "PNG file corrupted by ASCII conversion");
+      }
+      if (num_checked < 3)
+         png_ptr->mode |= PNG_HAVE_PNG_SIGNATURE;
+   }
+
+   for(;;)
+   {
+#ifdef PNG_USE_LOCAL_ARRAYS
+      PNG_IHDR;
+      PNG_IDAT;
+      PNG_IEND;
+      PNG_PLTE;
+#if defined(PNG_READ_bKGD_SUPPORTED)
+      PNG_bKGD;
+#endif
+#if defined(PNG_READ_cHRM_SUPPORTED)
+      PNG_cHRM;
+#endif
+#if defined(PNG_READ_gAMA_SUPPORTED)
+      PNG_gAMA;
+#endif
+#if defined(PNG_READ_hIST_SUPPORTED)
+      PNG_hIST;
+#endif
+#if defined(PNG_READ_iCCP_SUPPORTED)
+      PNG_iCCP;
+#endif
+#if defined(PNG_READ_iTXt_SUPPORTED)
+      PNG_iTXt;
+#endif
+#if defined(PNG_READ_oFFs_SUPPORTED)
+      PNG_oFFs;
+#endif
+#if defined(PNG_READ_pCAL_SUPPORTED)
+      PNG_pCAL;
+#endif
+#if defined(PNG_READ_pHYs_SUPPORTED)
+      PNG_pHYs;
+#endif
+#if defined(PNG_READ_sBIT_SUPPORTED)
+      PNG_sBIT;
+#endif
+#if defined(PNG_READ_sCAL_SUPPORTED)
+      PNG_sCAL;
+#endif
+#if defined(PNG_READ_sPLT_SUPPORTED)
+      PNG_sPLT;
+#endif
+#if defined(PNG_READ_sRGB_SUPPORTED)
+      PNG_sRGB;
+#endif
+#if defined(PNG_READ_tEXt_SUPPORTED)
+      PNG_tEXt;
+#endif
+#if defined(PNG_READ_tIME_SUPPORTED)
+      PNG_tIME;
+#endif
+#if defined(PNG_READ_tRNS_SUPPORTED)
+      PNG_tRNS;
+#endif
+#if defined(PNG_READ_zTXt_SUPPORTED)
+      PNG_zTXt;
+#endif
+#endif /* PNG_GLOBAL_ARRAYS */
+      png_byte chunk_length[4];
+      png_uint_32 length;
+
+      png_read_data(png_ptr, chunk_length, 4);
+      length = png_get_uint_32(chunk_length);
+
+      png_reset_crc(png_ptr);
+      png_crc_read(png_ptr, png_ptr->chunk_name, 4);
+
+      png_debug2(0, "Reading %s chunk, length=%lu.\n", png_ptr->chunk_name,
+         length);
+
+      if (length > PNG_MAX_UINT)
+         png_error(png_ptr, "Invalid chunk length.");
+
+      /* This should be a binary subdivision search or a hash for
+       * matching the chunk name rather than a linear search.
+       */
+      if (!png_memcmp(png_ptr->chunk_name, png_IHDR, 4))
+         png_handle_IHDR(png_ptr, info_ptr, length);
+      else if (!png_memcmp(png_ptr->chunk_name, png_IEND, 4))
+         png_handle_IEND(png_ptr, info_ptr, length);
+#ifdef PNG_HANDLE_AS_UNKNOWN_SUPPORTED
+      else if (png_handle_as_unknown(png_ptr, png_ptr->chunk_name))
+      {
+         if (!png_memcmp(png_ptr->chunk_name, png_IDAT, 4))
+            png_ptr->mode |= PNG_HAVE_IDAT;
+         png_handle_unknown(png_ptr, info_ptr, length);
+         if (!png_memcmp(png_ptr->chunk_name, png_PLTE, 4))
+            png_ptr->mode |= PNG_HAVE_PLTE;
+         else if (!png_memcmp(png_ptr->chunk_name, png_IDAT, 4))
+         {
+            if (!(png_ptr->mode & PNG_HAVE_IHDR))
+               png_error(png_ptr, "Missing IHDR before IDAT");
+            else if (png_ptr->color_type == PNG_COLOR_TYPE_PALETTE &&
+                     !(png_ptr->mode & PNG_HAVE_PLTE))
+               png_error(png_ptr, "Missing PLTE before IDAT");
+            break;
+         }
+      }
+#endif
+      else if (!png_memcmp(png_ptr->chunk_name, png_PLTE, 4))
+         png_handle_PLTE(png_ptr, info_ptr, length);
+      else if (!png_memcmp(png_ptr->chunk_name, png_IDAT, 4))
+      {
+         if (!(png_ptr->mode & PNG_HAVE_IHDR))
+            png_error(png_ptr, "Missing IHDR before IDAT");
+         else if (png_ptr->color_type == PNG_COLOR_TYPE_PALETTE &&
+                  !(png_ptr->mode & PNG_HAVE_PLTE))
+            png_error(png_ptr, "Missing PLTE before IDAT");
+
+         png_ptr->idat_size = length;
+         png_ptr->mode |= PNG_HAVE_IDAT;
+         break;
+      }
+#if defined(PNG_READ_bKGD_SUPPORTED)
+      else if (!png_memcmp(png_ptr->chunk_name, png_bKGD, 4))
+         png_handle_bKGD(png_ptr, info_ptr, length);
+#endif
+#if defined(PNG_READ_cHRM_SUPPORTED)
+      else if (!png_memcmp(png_ptr->chunk_name, png_cHRM, 4))
+         png_handle_cHRM(png_ptr, info_ptr, length);
+#endif
+#if defined(PNG_READ_gAMA_SUPPORTED)
+      else if (!png_memcmp(png_ptr->chunk_name, png_gAMA, 4))
+         png_handle_gAMA(png_ptr, info_ptr, length);
+#endif
+#if defined(PNG_READ_hIST_SUPPORTED)
+      else if (!png_memcmp(png_ptr->chunk_name, png_hIST, 4))
+         png_handle_hIST(png_ptr, info_ptr, length);
+#endif
+#if defined(PNG_READ_oFFs_SUPPORTED)
+      else if (!png_memcmp(png_ptr->chunk_name, png_oFFs, 4))
+         png_handle_oFFs(png_ptr, info_ptr, length);
+#endif
+#if defined(PNG_READ_pCAL_SUPPORTED)
+      else if (!png_memcmp(png_ptr->chunk_name, png_pCAL, 4))
+         png_handle_pCAL(png_ptr, info_ptr, length);
+#endif
+#if defined(PNG_READ_sCAL_SUPPORTED)
+      else if (!png_memcmp(png_ptr->chunk_name, png_sCAL, 4))
+         png_handle_sCAL(png_ptr, info_ptr, length);
+#endif
+#if defined(PNG_READ_pHYs_SUPPORTED)
+      else if (!png_memcmp(png_ptr->chunk_name, png_pHYs, 4))
+         png_handle_pHYs(png_ptr, info_ptr, length);
+#endif
+#if defined(PNG_READ_sBIT_SUPPORTED)
+      else if (!png_memcmp(png_ptr->chunk_name, png_sBIT, 4))
+         png_handle_sBIT(png_ptr, info_ptr, length);
+#endif
+#if defined(PNG_READ_sRGB_SUPPORTED)
+      else if (!png_memcmp(png_ptr->chunk_name, png_sRGB, 4))
+         png_handle_sRGB(png_ptr, info_ptr, length);
+#endif
+#if defined(PNG_READ_iCCP_SUPPORTED)
+      else if (!png_memcmp(png_ptr->chunk_name, png_iCCP, 4))
+         png_handle_iCCP(png_ptr, info_ptr, length);
+#endif
+#if defined(PNG_READ_sPLT_SUPPORTED)
+      else if (!png_memcmp(png_ptr->chunk_name, png_sPLT, 4))
+         png_handle_sPLT(png_ptr, info_ptr, length);
+#endif
+#if defined(PNG_READ_tEXt_SUPPORTED)
+      else if (!png_memcmp(png_ptr->chunk_name, png_tEXt, 4))
+         png_handle_tEXt(png_ptr, info_ptr, length);
+#endif
+#if defined(PNG_READ_tIME_SUPPORTED)
+      else if (!png_memcmp(png_ptr->chunk_name, png_tIME, 4))
+         png_handle_tIME(png_ptr, info_ptr, length);
+#endif
+#if defined(PNG_READ_tRNS_SUPPORTED)
+      else if (!png_memcmp(png_ptr->chunk_name, png_tRNS, 4))
+         png_handle_tRNS(png_ptr, info_ptr, length);
+#endif
+#if defined(PNG_READ_zTXt_SUPPORTED)
+      else if (!png_memcmp(png_ptr->chunk_name, png_zTXt, 4))
+         png_handle_zTXt(png_ptr, info_ptr, length);
+#endif
+#if defined(PNG_READ_iTXt_SUPPORTED)
+      else if (!png_memcmp(png_ptr->chunk_name, png_iTXt, 4))
+         png_handle_iTXt(png_ptr, info_ptr, length);
+#endif
+      else
+         png_handle_unknown(png_ptr, info_ptr, length);
+   }
+}
+
+/* optional call to update the users info_ptr structure */
+void PNGAPI
+png_read_update_info(png_structp png_ptr, png_infop info_ptr)
+{
+   png_debug(1, "in png_read_update_info\n");
+   if (!(png_ptr->flags & PNG_FLAG_ROW_INIT))
+      png_read_start_row(png_ptr);
+   else
+      png_warning(png_ptr,
+      "Ignoring extra png_read_update_info() call; row buffer not reallocated");
+   png_read_transform_info(png_ptr, info_ptr);
+}
+
+/* Initialize palette, background, etc, after transformations
+ * are set, but before any reading takes place.  This allows
+ * the user to obtain a gamma-corrected palette, for example.
+ * If the user doesn't call this, we will do it ourselves.
+ */
+void PNGAPI
+png_start_read_image(png_structp png_ptr)
+{
+   png_debug(1, "in png_start_read_image\n");
+   if (!(png_ptr->flags & PNG_FLAG_ROW_INIT))
+      png_read_start_row(png_ptr);
+}
+
+void PNGAPI
+png_read_row(png_structp png_ptr, png_bytep row, png_bytep dsp_row)
+{
+#ifdef PNG_USE_LOCAL_ARRAYS
+   PNG_IDAT;
+   const int png_pass_dsp_mask[7] = {0xff, 0x0f, 0xff, 0x33, 0xff, 0x55, 0xff};
+   const int png_pass_mask[7] = {0x80, 0x08, 0x88, 0x22, 0xaa, 0x55, 0xff};
+#endif
+   int ret;
+   png_debug2(1, "in png_read_row (row %lu, pass %d)\n",
+      png_ptr->row_number, png_ptr->pass);
+   if (!(png_ptr->flags & PNG_FLAG_ROW_INIT))
+      png_read_start_row(png_ptr);
+   if (png_ptr->row_number == 0 && png_ptr->pass == 0)
+   {
+   /* check for transforms that have been set but were defined out */
+#if defined(PNG_WRITE_INVERT_SUPPORTED) && !defined(PNG_READ_INVERT_SUPPORTED)
+   if (png_ptr->transformations & PNG_INVERT_MONO)
+      png_warning(png_ptr, "PNG_READ_INVERT_SUPPORTED is not defined.");
+#endif
+#if defined(PNG_WRITE_FILLER_SUPPORTED) && !defined(PNG_READ_FILLER_SUPPORTED)
+   if (png_ptr->transformations & PNG_FILLER)
+      png_warning(png_ptr, "PNG_READ_FILLER_SUPPORTED is not defined.");
+#endif
+#if defined(PNG_WRITE_PACKSWAP_SUPPORTED) && !defined(PNG_READ_PACKSWAP_SUPPORTED)
+   if (png_ptr->transformations & PNG_PACKSWAP)
+      png_warning(png_ptr, "PNG_READ_PACKSWAP_SUPPORTED is not defined.");
+#endif
+#if defined(PNG_WRITE_PACK_SUPPORTED) && !defined(PNG_READ_PACK_SUPPORTED)
+   if (png_ptr->transformations & PNG_PACK)
+      png_warning(png_ptr, "PNG_READ_PACK_SUPPORTED is not defined.");
+#endif
+#if defined(PNG_WRITE_SHIFT_SUPPORTED) && !defined(PNG_READ_SHIFT_SUPPORTED)
+   if (png_ptr->transformations & PNG_SHIFT)
+      png_warning(png_ptr, "PNG_READ_SHIFT_SUPPORTED is not defined.");
+#endif
+#if defined(PNG_WRITE_BGR_SUPPORTED) && !defined(PNG_READ_BGR_SUPPORTED)
+   if (png_ptr->transformations & PNG_BGR)
+      png_warning(png_ptr, "PNG_READ_BGR_SUPPORTED is not defined.");
+#endif
+#if defined(PNG_WRITE_SWAP_SUPPORTED) && !defined(PNG_READ_SWAP_SUPPORTED)
+   if (png_ptr->transformations & PNG_SWAP_BYTES)
+      png_warning(png_ptr, "PNG_READ_SWAP_SUPPORTED is not defined.");
+#endif
+   }
+
+#if defined(PNG_READ_INTERLACING_SUPPORTED)
+   /* if interlaced and we do not need a new row, combine row and return */
+   if (png_ptr->interlaced && (png_ptr->transformations & PNG_INTERLACE))
+   {
+      switch (png_ptr->pass)
+      {
+         case 0:
+            if (png_ptr->row_number & 0x07)
+            {
+               if (dsp_row != NULL)
+                  png_combine_row(png_ptr, dsp_row,
+                     png_pass_dsp_mask[png_ptr->pass]);
+               png_read_finish_row(png_ptr);
+               return;
+            }
+            break;
+         case 1:
+            if ((png_ptr->row_number & 0x07) || png_ptr->width < 5)
+            {
+               if (dsp_row != NULL)
+                  png_combine_row(png_ptr, dsp_row,
+                     png_pass_dsp_mask[png_ptr->pass]);
+               png_read_finish_row(png_ptr);
+               return;
+            }
+            break;
+         case 2:
+            if ((png_ptr->row_number & 0x07) != 4)
+            {
+               if (dsp_row != NULL && (png_ptr->row_number & 4))
+                  png_combine_row(png_ptr, dsp_row,
+                     png_pass_dsp_mask[png_ptr->pass]);
+               png_read_finish_row(png_ptr);
+               return;
+            }
+            break;
+         case 3:
+            if ((png_ptr->row_number & 3) || png_ptr->width < 3)
+            {
+               if (dsp_row != NULL)
+                  png_combine_row(png_ptr, dsp_row,
+                     png_pass_dsp_mask[png_ptr->pass]);
+               png_read_finish_row(png_ptr);
+               return;
+            }
+            break;
+         case 4:
+            if ((png_ptr->row_number & 3) != 2)
+            {
+               if (dsp_row != NULL && (png_ptr->row_number & 2))
+                  png_combine_row(png_ptr, dsp_row,
+                     png_pass_dsp_mask[png_ptr->pass]);
+               png_read_finish_row(png_ptr);
+               return;
+            }
+            break;
+         case 5:
+            if ((png_ptr->row_number & 1) || png_ptr->width < 2)
+            {
+               if (dsp_row != NULL)
+                  png_combine_row(png_ptr, dsp_row,
+                     png_pass_dsp_mask[png_ptr->pass]);
+               png_read_finish_row(png_ptr);
+               return;
+            }
+            break;
+         case 6:
+            if (!(png_ptr->row_number & 1))
+            {
+               png_read_finish_row(png_ptr);
+               return;
+            }
+            break;
+      }
+   }
+#endif
+
+   if (!(png_ptr->mode & PNG_HAVE_IDAT))
+      png_error(png_ptr, "Invalid attempt to read row data");
+
+   png_ptr->zstream.next_out = png_ptr->row_buf;
+   png_ptr->zstream.avail_out = (uInt)png_ptr->irowbytes;
+   do
+   {
+      if (!(png_ptr->zstream.avail_in))
+      {
+         while (!png_ptr->idat_size)
+         {
+            png_byte chunk_length[4];
+
+            png_crc_finish(png_ptr, 0);
+
+            png_read_data(png_ptr, chunk_length, 4);
+            png_ptr->idat_size = png_get_uint_32(chunk_length);
+
+            if (png_ptr->idat_size > PNG_MAX_UINT)
+              png_error(png_ptr, "Invalid chunk length.");
+
+            png_reset_crc(png_ptr);
+            png_crc_read(png_ptr, png_ptr->chunk_name, 4);
+            if (png_memcmp(png_ptr->chunk_name, png_IDAT, 4))
+               png_error(png_ptr, "Not enough image data");
+         }
+         png_ptr->zstream.avail_in = (uInt)png_ptr->zbuf_size;
+         png_ptr->zstream.next_in = png_ptr->zbuf;
+         if (png_ptr->zbuf_size > png_ptr->idat_size)
+            png_ptr->zstream.avail_in = (uInt)png_ptr->idat_size;
+         png_crc_read(png_ptr, png_ptr->zbuf,
+            (png_size_t)png_ptr->zstream.avail_in);
+         png_ptr->idat_size -= png_ptr->zstream.avail_in;
+      }
+      ret = inflate(&png_ptr->zstream, Z_PARTIAL_FLUSH);
+      if (ret == Z_STREAM_END)
+      {
+         if (png_ptr->zstream.avail_out || png_ptr->zstream.avail_in ||
+            png_ptr->idat_size)
+            png_error(png_ptr, "Extra compressed data");
+         png_ptr->mode |= PNG_AFTER_IDAT;
+         png_ptr->flags |= PNG_FLAG_ZLIB_FINISHED;
+         break;
+      }
+      if (ret != Z_OK)
+         png_error(png_ptr, png_ptr->zstream.msg ? png_ptr->zstream.msg :
+                   "Decompression error");
+
+   } while (png_ptr->zstream.avail_out);
+
+   png_ptr->row_info.color_type = png_ptr->color_type;
+   png_ptr->row_info.width = png_ptr->iwidth;
+   png_ptr->row_info.channels = png_ptr->channels;
+   png_ptr->row_info.bit_depth = png_ptr->bit_depth;
+   png_ptr->row_info.pixel_depth = png_ptr->pixel_depth;
+   png_ptr->row_info.rowbytes = ((png_ptr->row_info.width *
+      (png_uint_32)png_ptr->row_info.pixel_depth + 7) >> 3);
+
+   if(png_ptr->row_buf[0])
+   png_read_filter_row(png_ptr, &(png_ptr->row_info),
+      png_ptr->row_buf + 1, png_ptr->prev_row + 1,
+      (int)(png_ptr->row_buf[0]));
+
+   png_memcpy_check(png_ptr, png_ptr->prev_row, png_ptr->row_buf,
+      png_ptr->rowbytes + 1);
+   
+#if defined(PNG_MNG_FEATURES_SUPPORTED)
+   if((png_ptr->mng_features_permitted & PNG_FLAG_MNG_FILTER_64) &&
+      (png_ptr->filter_type == PNG_INTRAPIXEL_DIFFERENCING))
+   {
+      /* Intrapixel differencing */
+      png_do_read_intrapixel(&(png_ptr->row_info), png_ptr->row_buf + 1);
+   }
+#endif
+
+   if (png_ptr->transformations)
+      png_do_read_transformations(png_ptr);
+
+#if defined(PNG_READ_INTERLACING_SUPPORTED)
+   /* blow up interlaced rows to full size */
+   if (png_ptr->interlaced &&
+      (png_ptr->transformations & PNG_INTERLACE))
+   {
+      if (png_ptr->pass < 6)
+/*       old interface (pre-1.0.9):
+         png_do_read_interlace(&(png_ptr->row_info),
+            png_ptr->row_buf + 1, png_ptr->pass, png_ptr->transformations);
+ */
+         png_do_read_interlace(png_ptr);
+
+      if (dsp_row != NULL)
+         png_combine_row(png_ptr, dsp_row,
+            png_pass_dsp_mask[png_ptr->pass]);
+      if (row != NULL)
+         png_combine_row(png_ptr, row,
+            png_pass_mask[png_ptr->pass]);
+   }
+   else
+#endif
+   {
+      if (row != NULL)
+         png_combine_row(png_ptr, row, 0xff);
+      if (dsp_row != NULL)
+         png_combine_row(png_ptr, dsp_row, 0xff);
+   }
+   png_read_finish_row(png_ptr);
+
+   if (png_ptr->read_row_fn != NULL)
+      (*(png_ptr->read_row_fn))(png_ptr, png_ptr->row_number, png_ptr->pass);
+}
+
+/* Read one or more rows of image data.  If the image is interlaced,
+ * and png_set_interlace_handling() has been called, the rows need to
+ * contain the contents of the rows from the previous pass.  If the
+ * image has alpha or transparency, and png_handle_alpha()[*] has been
+ * called, the rows contents must be initialized to the contents of the
+ * screen.
+ *
+ * "row" holds the actual image, and pixels are placed in it
+ * as they arrive.  If the image is displayed after each pass, it will
+ * appear to "sparkle" in.  "display_row" can be used to display a
+ * "chunky" progressive image, with finer detail added as it becomes
+ * available.  If you do not want this "chunky" display, you may pass
+ * NULL for display_row.  If you do not want the sparkle display, and
+ * you have not called png_handle_alpha(), you may pass NULL for rows.
+ * If you have called png_handle_alpha(), and the image has either an
+ * alpha channel or a transparency chunk, you must provide a buffer for
+ * rows.  In this case, you do not have to provide a display_row buffer
+ * also, but you may.  If the image is not interlaced, or if you have
+ * not called png_set_interlace_handling(), the display_row buffer will
+ * be ignored, so pass NULL to it.
+ *
+ * [*] png_handle_alpha() does not exist yet, as of libpng version 1.2.5
+ */
+
+void PNGAPI
+png_read_rows(png_structp png_ptr, png_bytepp row,
+   png_bytepp display_row, png_uint_32 num_rows)
+{
+   png_uint_32 i;
+   png_bytepp rp;
+   png_bytepp dp;
+
+   png_debug(1, "in png_read_rows\n");
+   rp = row;
+   dp = display_row;
+   if (rp != NULL && dp != NULL)
+      for (i = 0; i < num_rows; i++)
+      {
+         png_bytep rptr = *rp++;
+         png_bytep dptr = *dp++;
+
+         png_read_row(png_ptr, rptr, dptr);
+      }
+   else if(rp != NULL)
+      for (i = 0; i < num_rows; i++)
+      {
+         png_bytep rptr = *rp;
+         png_read_row(png_ptr, rptr, png_bytep_NULL);
+         rp++;
+      }
+   else if(dp != NULL)
+      for (i = 0; i < num_rows; i++)
+      {
+         png_bytep dptr = *dp;
+         png_read_row(png_ptr, png_bytep_NULL, dptr);
+         dp++;
+      }
+}
+
+/* Read the entire image.  If the image has an alpha channel or a tRNS
+ * chunk, and you have called png_handle_alpha()[*], you will need to
+ * initialize the image to the current image that PNG will be overlaying.
+ * We set the num_rows again here, in case it was incorrectly set in
+ * png_read_start_row() by a call to png_read_update_info() or
+ * png_start_read_image() if png_set_interlace_handling() wasn't called
+ * prior to either of these functions like it should have been.  You can
+ * only call this function once.  If you desire to have an image for
+ * each pass of a interlaced image, use png_read_rows() instead.
+ *
+ * [*] png_handle_alpha() does not exist yet, as of libpng version 1.2.5
+ */
+void PNGAPI
+png_read_image(png_structp png_ptr, png_bytepp image)
+{
+   png_uint_32 i,image_height;
+   int pass, j;
+   png_bytepp rp;
+
+   png_debug(1, "in png_read_image\n");
+
+#ifdef PNG_READ_INTERLACING_SUPPORTED
+   pass = png_set_interlace_handling(png_ptr);
+#else
+   if (png_ptr->interlaced)
+      png_error(png_ptr,
+        "Cannot read interlaced image -- interlace handler disabled.");
+   pass = 1;
+#endif
+
+
+   image_height=png_ptr->height;
+   png_ptr->num_rows = image_height; /* Make sure this is set correctly */
+
+   for (j = 0; j < pass; j++)
+   {
+      rp = image;
+      for (i = 0; i < image_height; i++)
+      {
+         png_read_row(png_ptr, *rp, png_bytep_NULL);
+         rp++;
+      }
+   }
+}
+
+/* Read the end of the PNG file.  Will not read past the end of the
+ * file, will verify the end is accurate, and will read any comments
+ * or time information at the end of the file, if info is not NULL.
+ */
+void PNGAPI
+png_read_end(png_structp png_ptr, png_infop info_ptr)
+{
+   png_byte chunk_length[4];
+   png_uint_32 length;
+
+   png_debug(1, "in png_read_end\n");
+   png_crc_finish(png_ptr, 0); /* Finish off CRC from last IDAT chunk */
+
+   do
+   {
+#ifdef PNG_USE_LOCAL_ARRAYS
+      PNG_IHDR;
+      PNG_IDAT;
+      PNG_IEND;
+      PNG_PLTE;
+#if defined(PNG_READ_bKGD_SUPPORTED)
+      PNG_bKGD;
+#endif
+#if defined(PNG_READ_cHRM_SUPPORTED)
+      PNG_cHRM;
+#endif
+#if defined(PNG_READ_gAMA_SUPPORTED)
+      PNG_gAMA;
+#endif
+#if defined(PNG_READ_hIST_SUPPORTED)
+      PNG_hIST;
+#endif
+#if defined(PNG_READ_iCCP_SUPPORTED)
+      PNG_iCCP;
+#endif
+#if defined(PNG_READ_iTXt_SUPPORTED)
+      PNG_iTXt;
+#endif
+#if defined(PNG_READ_oFFs_SUPPORTED)
+      PNG_oFFs;
+#endif
+#if defined(PNG_READ_pCAL_SUPPORTED)
+      PNG_pCAL;
+#endif
+#if defined(PNG_READ_pHYs_SUPPORTED)
+      PNG_pHYs;
+#endif
+#if defined(PNG_READ_sBIT_SUPPORTED)
+      PNG_sBIT;
+#endif
+#if defined(PNG_READ_sCAL_SUPPORTED)
+      PNG_sCAL;
+#endif
+#if defined(PNG_READ_sPLT_SUPPORTED)
+      PNG_sPLT;
+#endif
+#if defined(PNG_READ_sRGB_SUPPORTED)
+      PNG_sRGB;
+#endif
+#if defined(PNG_READ_tEXt_SUPPORTED)
+      PNG_tEXt;
+#endif
+#if defined(PNG_READ_tIME_SUPPORTED)
+      PNG_tIME;
+#endif
+#if defined(PNG_READ_tRNS_SUPPORTED)
+      PNG_tRNS;
+#endif
+#if defined(PNG_READ_zTXt_SUPPORTED)
+      PNG_zTXt;
+#endif
+#endif /* PNG_GLOBAL_ARRAYS */
+
+      png_read_data(png_ptr, chunk_length, 4);
+      length = png_get_uint_32(chunk_length);
+
+      png_reset_crc(png_ptr);
+      png_crc_read(png_ptr, png_ptr->chunk_name, 4);
+
+      png_debug1(0, "Reading %s chunk.\n", png_ptr->chunk_name);
+
+      if (length > PNG_MAX_UINT)
+         png_error(png_ptr, "Invalid chunk length.");
+
+      if (!png_memcmp(png_ptr->chunk_name, png_IHDR, 4))
+         png_handle_IHDR(png_ptr, info_ptr, length);
+      else if (!png_memcmp(png_ptr->chunk_name, png_IEND, 4))
+         png_handle_IEND(png_ptr, info_ptr, length);
+#ifdef PNG_HANDLE_AS_UNKNOWN_SUPPORTED
+      else if (png_handle_as_unknown(png_ptr, png_ptr->chunk_name))
+      {
+         if (!png_memcmp(png_ptr->chunk_name, png_IDAT, 4))
+         {
+            if (length > 0 || png_ptr->mode & PNG_AFTER_IDAT)
+               png_error(png_ptr, "Too many IDAT's found");
+         }
+         else
+            png_ptr->mode |= PNG_AFTER_IDAT;
+         png_handle_unknown(png_ptr, info_ptr, length);
+         if (!png_memcmp(png_ptr->chunk_name, png_PLTE, 4))
+            png_ptr->mode |= PNG_HAVE_PLTE;
+      }
+#endif
+      else if (!png_memcmp(png_ptr->chunk_name, png_IDAT, 4))
+      {
+         /* Zero length IDATs are legal after the last IDAT has been
+          * read, but not after other chunks have been read.
+          */
+         if (length > 0 || png_ptr->mode & PNG_AFTER_IDAT)
+            png_error(png_ptr, "Too many IDAT's found");
+         png_crc_finish(png_ptr, length);
+      }
+      else if (!png_memcmp(png_ptr->chunk_name, png_PLTE, 4))
+         png_handle_PLTE(png_ptr, info_ptr, length);
+#if defined(PNG_READ_bKGD_SUPPORTED)
+      else if (!png_memcmp(png_ptr->chunk_name, png_bKGD, 4))
+         png_handle_bKGD(png_ptr, info_ptr, length);
+#endif
+#if defined(PNG_READ_cHRM_SUPPORTED)
+      else if (!png_memcmp(png_ptr->chunk_name, png_cHRM, 4))
+         png_handle_cHRM(png_ptr, info_ptr, length);
+#endif
+#if defined(PNG_READ_gAMA_SUPPORTED)
+      else if (!png_memcmp(png_ptr->chunk_name, png_gAMA, 4))
+         png_handle_gAMA(png_ptr, info_ptr, length);
+#endif
+#if defined(PNG_READ_hIST_SUPPORTED)
+      else if (!png_memcmp(png_ptr->chunk_name, png_hIST, 4))
+         png_handle_hIST(png_ptr, info_ptr, length);
+#endif
+#if defined(PNG_READ_oFFs_SUPPORTED)
+      else if (!png_memcmp(png_ptr->chunk_name, png_oFFs, 4))
+         png_handle_oFFs(png_ptr, info_ptr, length);
+#endif
+#if defined(PNG_READ_pCAL_SUPPORTED)
+      else if (!png_memcmp(png_ptr->chunk_name, png_pCAL, 4))
+         png_handle_pCAL(png_ptr, info_ptr, length);
+#endif
+#if defined(PNG_READ_sCAL_SUPPORTED)
+      else if (!png_memcmp(png_ptr->chunk_name, png_sCAL, 4))
+         png_handle_sCAL(png_ptr, info_ptr, length);
+#endif
+#if defined(PNG_READ_pHYs_SUPPORTED)
+      else if (!png_memcmp(png_ptr->chunk_name, png_pHYs, 4))
+         png_handle_pHYs(png_ptr, info_ptr, length);
+#endif
+#if defined(PNG_READ_sBIT_SUPPORTED)
+      else if (!png_memcmp(png_ptr->chunk_name, png_sBIT, 4))
+         png_handle_sBIT(png_ptr, info_ptr, length);
+#endif
+#if defined(PNG_READ_sRGB_SUPPORTED)
+      else if (!png_memcmp(png_ptr->chunk_name, png_sRGB, 4))
+         png_handle_sRGB(png_ptr, info_ptr, length);
+#endif
+#if defined(PNG_READ_iCCP_SUPPORTED)
+      else if (!png_memcmp(png_ptr->chunk_name, png_iCCP, 4))
+         png_handle_iCCP(png_ptr, info_ptr, length);
+#endif
+#if defined(PNG_READ_sPLT_SUPPORTED)
+      else if (!png_memcmp(png_ptr->chunk_name, png_sPLT, 4))
+         png_handle_sPLT(png_ptr, info_ptr, length);
+#endif
+#if defined(PNG_READ_tEXt_SUPPORTED)
+      else if (!png_memcmp(png_ptr->chunk_name, png_tEXt, 4))
+         png_handle_tEXt(png_ptr, info_ptr, length);
+#endif
+#if defined(PNG_READ_tIME_SUPPORTED)
+      else if (!png_memcmp(png_ptr->chunk_name, png_tIME, 4))
+         png_handle_tIME(png_ptr, info_ptr, length);
+#endif
+#if defined(PNG_READ_tRNS_SUPPORTED)
+      else if (!png_memcmp(png_ptr->chunk_name, png_tRNS, 4))
+         png_handle_tRNS(png_ptr, info_ptr, length);
+#endif
+#if defined(PNG_READ_zTXt_SUPPORTED)
+      else if (!png_memcmp(png_ptr->chunk_name, png_zTXt, 4))
+         png_handle_zTXt(png_ptr, info_ptr, length);
+#endif
+#if defined(PNG_READ_iTXt_SUPPORTED)
+      else if (!png_memcmp(png_ptr->chunk_name, png_iTXt, 4))
+         png_handle_iTXt(png_ptr, info_ptr, length);
+#endif
+      else
+         png_handle_unknown(png_ptr, info_ptr, length);
+   } while (!(png_ptr->mode & PNG_HAVE_IEND));
+}
+
+/* free all memory used by the read */
+void PNGAPI
+png_destroy_read_struct(png_structpp png_ptr_ptr, png_infopp info_ptr_ptr,
+   png_infopp end_info_ptr_ptr)
+{
+   png_structp png_ptr = NULL;
+   png_infop info_ptr = NULL, end_info_ptr = NULL;
+#ifdef PNG_USER_MEM_SUPPORTED
+   png_free_ptr free_fn = NULL;
+   png_voidp mem_ptr = NULL;
+#endif
+
+   png_debug(1, "in png_destroy_read_struct\n");
+   if (png_ptr_ptr != NULL)
+      png_ptr = *png_ptr_ptr;
+
+   if (info_ptr_ptr != NULL)
+      info_ptr = *info_ptr_ptr;
+
+   if (end_info_ptr_ptr != NULL)
+      end_info_ptr = *end_info_ptr_ptr;
+
+#ifdef PNG_USER_MEM_SUPPORTED
+   free_fn = png_ptr->free_fn;
+   mem_ptr = png_ptr->mem_ptr;
+#endif
+
+   png_read_destroy(png_ptr, info_ptr, end_info_ptr);
+
+   if (info_ptr != NULL)
+   {
+#if defined(PNG_TEXT_SUPPORTED)
+      png_free_data(png_ptr, info_ptr, PNG_FREE_TEXT, -1);
+#endif
+
+#ifdef PNG_USER_MEM_SUPPORTED
+      png_destroy_struct_2((png_voidp)info_ptr, (png_free_ptr)free_fn,
+          (png_voidp)mem_ptr);
+#else
+      png_destroy_struct((png_voidp)info_ptr);
+#endif
+      *info_ptr_ptr = NULL;
+   }
+
+   if (end_info_ptr != NULL)
+   {
+#if defined(PNG_READ_TEXT_SUPPORTED)
+      png_free_data(png_ptr, end_info_ptr, PNG_FREE_TEXT, -1);
+#endif
+#ifdef PNG_USER_MEM_SUPPORTED
+      png_destroy_struct_2((png_voidp)end_info_ptr, (png_free_ptr)free_fn,
+         (png_voidp)mem_ptr);
+#else
+      png_destroy_struct((png_voidp)end_info_ptr);
+#endif
+      *end_info_ptr_ptr = NULL;
+   }
+
+   if (png_ptr != NULL)
+   {
+#ifdef PNG_USER_MEM_SUPPORTED
+      png_destroy_struct_2((png_voidp)png_ptr, (png_free_ptr)free_fn,
+          (png_voidp)mem_ptr);
+#else
+      png_destroy_struct((png_voidp)png_ptr);
+#endif
+      *png_ptr_ptr = NULL;
+   }
+}
+
+/* free all memory used by the read (old method) */
+void /* PRIVATE */
+png_read_destroy(png_structp png_ptr, png_infop info_ptr, png_infop end_info_ptr)
+{
+#ifdef PNG_SETJMP_SUPPORTED
+   jmp_buf tmp_jmp;
+#endif
+   png_error_ptr error_fn;
+   png_error_ptr warning_fn;
+   png_voidp error_ptr;
+#ifdef PNG_USER_MEM_SUPPORTED
+   png_free_ptr free_fn;
+#endif
+
+   png_debug(1, "in png_read_destroy\n");
+   if (info_ptr != NULL)
+      png_info_destroy(png_ptr, info_ptr);
+
+   if (end_info_ptr != NULL)
+      png_info_destroy(png_ptr, end_info_ptr);
+
+   png_free(png_ptr, png_ptr->zbuf);
+   png_free(png_ptr, png_ptr->big_row_buf);
+   png_free(png_ptr, png_ptr->prev_row);
+#if defined(PNG_READ_DITHER_SUPPORTED)
+   png_free(png_ptr, png_ptr->palette_lookup);
+   png_free(png_ptr, png_ptr->dither_index);
+#endif
+#if defined(PNG_READ_GAMMA_SUPPORTED)
+   png_free(png_ptr, png_ptr->gamma_table);
+#endif
+#if defined(PNG_READ_BACKGROUND_SUPPORTED)
+   png_free(png_ptr, png_ptr->gamma_from_1);
+   png_free(png_ptr, png_ptr->gamma_to_1);
+#endif
+#ifdef PNG_FREE_ME_SUPPORTED
+   if (png_ptr->free_me & PNG_FREE_PLTE)
+      png_zfree(png_ptr, png_ptr->palette);
+   png_ptr->free_me &= ~PNG_FREE_PLTE;
+#else
+   if (png_ptr->flags & PNG_FLAG_FREE_PLTE)
+      png_zfree(png_ptr, png_ptr->palette);
+   png_ptr->flags &= ~PNG_FLAG_FREE_PLTE;
+#endif
+#if defined(PNG_tRNS_SUPPORTED) || \
+    defined(PNG_READ_EXPAND_SUPPORTED) || defined(PNG_READ_BACKGROUND_SUPPORTED)
+#ifdef PNG_FREE_ME_SUPPORTED
+   if (png_ptr->free_me & PNG_FREE_TRNS)
+      png_free(png_ptr, png_ptr->trans);
+   png_ptr->free_me &= ~PNG_FREE_TRNS;
+#else
+   if (png_ptr->flags & PNG_FLAG_FREE_TRNS)
+      png_free(png_ptr, png_ptr->trans);
+   png_ptr->flags &= ~PNG_FLAG_FREE_TRNS;
+#endif
+#endif
+#if defined(PNG_READ_hIST_SUPPORTED)
+#ifdef PNG_FREE_ME_SUPPORTED
+   if (png_ptr->free_me & PNG_FREE_HIST)
+      png_free(png_ptr, png_ptr->hist);
+   png_ptr->free_me &= ~PNG_FREE_HIST;
+#else
+   if (png_ptr->flags & PNG_FLAG_FREE_HIST)
+      png_free(png_ptr, png_ptr->hist);
+   png_ptr->flags &= ~PNG_FLAG_FREE_HIST;
+#endif
+#endif
+#if defined(PNG_READ_GAMMA_SUPPORTED)
+   if (png_ptr->gamma_16_table != NULL)
+   {
+      int i;
+      int istop = (1 << (8 - png_ptr->gamma_shift));
+      for (i = 0; i < istop; i++)
+      {
+         png_free(png_ptr, png_ptr->gamma_16_table[i]);
+      }
+   png_free(png_ptr, png_ptr->gamma_16_table);
+   }
+#if defined(PNG_READ_BACKGROUND_SUPPORTED)
+   if (png_ptr->gamma_16_from_1 != NULL)
+   {
+      int i;
+      int istop = (1 << (8 - png_ptr->gamma_shift));
+      for (i = 0; i < istop; i++)
+      {
+         png_free(png_ptr, png_ptr->gamma_16_from_1[i]);
+      }
+   png_free(png_ptr, png_ptr->gamma_16_from_1);
+   }
+   if (png_ptr->gamma_16_to_1 != NULL)
+   {
+      int i;
+      int istop = (1 << (8 - png_ptr->gamma_shift));
+      for (i = 0; i < istop; i++)
+      {
+         png_free(png_ptr, png_ptr->gamma_16_to_1[i]);
+      }
+   png_free(png_ptr, png_ptr->gamma_16_to_1);
+   }
+#endif
+#endif
+#if defined(PNG_TIME_RFC1123_SUPPORTED)
+   png_free(png_ptr, png_ptr->time_buffer);
+#endif
+
+   inflateEnd(&png_ptr->zstream);
+#ifdef PNG_PROGRESSIVE_READ_SUPPORTED
+   png_free(png_ptr, png_ptr->save_buffer);
+#endif
+
+#ifdef PNG_PROGRESSIVE_READ_SUPPORTED
+#ifdef PNG_TEXT_SUPPORTED
+   png_free(png_ptr, png_ptr->current_text);
+#endif /* PNG_TEXT_SUPPORTED */
+#endif /* PNG_PROGRESSIVE_READ_SUPPORTED */
+
+   /* Save the important info out of the png_struct, in case it is
+    * being used again.
+    */
+#ifdef PNG_SETJMP_SUPPORTED
+   png_memcpy(tmp_jmp, png_ptr->jmpbuf, sizeof (jmp_buf));
+#endif
+
+   error_fn = png_ptr->error_fn;
+   warning_fn = png_ptr->warning_fn;
+   error_ptr = png_ptr->error_ptr;
+#ifdef PNG_USER_MEM_SUPPORTED
+   free_fn = png_ptr->free_fn;
+#endif
+
+   png_memset(png_ptr, 0, sizeof (png_struct));
+
+   png_ptr->error_fn = error_fn;
+   png_ptr->warning_fn = warning_fn;
+   png_ptr->error_ptr = error_ptr;
+#ifdef PNG_USER_MEM_SUPPORTED
+   png_ptr->free_fn = free_fn;
+#endif
+
+#ifdef PNG_SETJMP_SUPPORTED
+   png_memcpy(png_ptr->jmpbuf, tmp_jmp, sizeof (jmp_buf));
+#endif
+
+}
+
+void PNGAPI
+png_set_read_status_fn(png_structp png_ptr, png_read_status_ptr read_row_fn)
+{
+   png_ptr->read_row_fn = read_row_fn;
+}
+
+#if defined(PNG_INFO_IMAGE_SUPPORTED)
+void PNGAPI
+png_read_png(png_structp png_ptr, png_infop info_ptr,
+                           int transforms,
+                           voidp params)
+{
+   int row;
+
+#if defined(PNG_READ_INVERT_ALPHA_SUPPORTED)
+   /* invert the alpha channel from opacity to transparency */
+   if (transforms & PNG_TRANSFORM_INVERT_ALPHA)
+       png_set_invert_alpha(png_ptr);
+#endif
+
+   /* The call to png_read_info() gives us all of the information from the
+    * PNG file before the first IDAT (image data chunk).
+    */
+   png_read_info(png_ptr, info_ptr);
+
+   /* -------------- image transformations start here ------------------- */
+
+#if defined(PNG_READ_16_TO_8_SUPPORTED)
+   /* tell libpng to strip 16 bit/color files down to 8 bits/color */
+   if (transforms & PNG_TRANSFORM_STRIP_16)
+       png_set_strip_16(png_ptr);
+#endif
+
+#if defined(PNG_READ_STRIP_ALPHA_SUPPORTED)
+   /* Strip alpha bytes from the input data without combining with the
+    * background (not recommended).
+    */
+   if (transforms & PNG_TRANSFORM_STRIP_ALPHA)
+       png_set_strip_alpha(png_ptr);
+#endif
+
+#if defined(PNG_READ_PACK_SUPPORTED) && !defined(PNG_READ_EXPAND_SUPPORTED)
+   /* Extract multiple pixels with bit depths of 1, 2, and 4 from a single
+    * byte into separate bytes (useful for paletted and grayscale images).
+    */
+   if (transforms & PNG_TRANSFORM_PACKING)
+       png_set_packing(png_ptr);
+#endif
+
+#if defined(PNG_READ_PACKSWAP_SUPPORTED)
+   /* Change the order of packed pixels to least significant bit first
+    * (not useful if you are using png_set_packing). */
+   if (transforms & PNG_TRANSFORM_PACKSWAP)
+       png_set_packswap(png_ptr);
+#endif
+
+#if defined(PNG_READ_EXPAND_SUPPORTED)
+   /* Expand paletted colors into true RGB triplets
+    * Expand grayscale images to full 8 bits from 1, 2, or 4 bits/pixel
+    * Expand paletted or RGB images with transparency to full alpha
+    * channels so the data will be available as RGBA quartets.
+    */
+   if (transforms & PNG_TRANSFORM_EXPAND)
+       if ((png_ptr->bit_depth < 8) ||
+           (png_ptr->color_type == PNG_COLOR_TYPE_PALETTE) ||
+           (png_get_valid(png_ptr, info_ptr, PNG_INFO_tRNS)))
+         png_set_expand(png_ptr);
+#endif
+
+   /* We don't handle background color or gamma transformation or dithering. */
+
+#if defined(PNG_READ_INVERT_SUPPORTED)
+   /* invert monochrome files to have 0 as white and 1 as black */
+   if (transforms & PNG_TRANSFORM_INVERT_MONO)
+       png_set_invert_mono(png_ptr);
+#endif
+
+#if defined(PNG_READ_SHIFT_SUPPORTED)
+   /* If you want to shift the pixel values from the range [0,255] or
+    * [0,65535] to the original [0,7] or [0,31], or whatever range the
+    * colors were originally in:
+    */
+   if ((transforms & PNG_TRANSFORM_SHIFT)
+       && png_get_valid(png_ptr, info_ptr, PNG_INFO_sBIT))
+   {
+      png_color_8p sig_bit;
+
+      png_get_sBIT(png_ptr, info_ptr, &sig_bit);
+      png_set_shift(png_ptr, sig_bit);
+   }
+#endif
+
+#if defined(PNG_READ_BGR_SUPPORTED)
+   /* flip the RGB pixels to BGR (or RGBA to BGRA) */
+   if (transforms & PNG_TRANSFORM_BGR)
+       png_set_bgr(png_ptr);
+#endif
+
+#if defined(PNG_READ_SWAP_ALPHA_SUPPORTED)
+   /* swap the RGBA or GA data to ARGB or AG (or BGRA to ABGR) */
+   if (transforms & PNG_TRANSFORM_SWAP_ALPHA)
+       png_set_swap_alpha(png_ptr);
+#endif
+
+#if defined(PNG_READ_SWAP_SUPPORTED)
+   /* swap bytes of 16 bit files to least significant byte first */
+   if (transforms & PNG_TRANSFORM_SWAP_ENDIAN)
+       png_set_swap(png_ptr);
+#endif
+
+   /* We don't handle adding filler bytes */
+
+   /* Optional call to gamma correct and add the background to the palette
+    * and update info structure.  REQUIRED if you are expecting libpng to
+    * update the palette for you (i.e., you selected such a transform above).
+    */
+   png_read_update_info(png_ptr, info_ptr);
+
+   /* -------------- image transformations end here ------------------- */
+
+#ifdef PNG_FREE_ME_SUPPORTED
+   png_free_data(png_ptr, info_ptr, PNG_FREE_ROWS, 0);
+#endif
+   if(info_ptr->row_pointers == NULL)
+   {
+      info_ptr->row_pointers = (png_bytepp)png_malloc(png_ptr,
+         info_ptr->height * sizeof(png_bytep));
+#ifdef PNG_FREE_ME_SUPPORTED
+      info_ptr->free_me |= PNG_FREE_ROWS;
+#endif
+      for (row = 0; row < (int)info_ptr->height; row++)
+      {
+         info_ptr->row_pointers[row] = (png_bytep)png_malloc(png_ptr,
+            png_get_rowbytes(png_ptr, info_ptr));
+      }
+   }
+
+   png_read_image(png_ptr, info_ptr->row_pointers);
+   info_ptr->valid |= PNG_INFO_IDAT;
+
+   /* read rest of file, and get additional chunks in info_ptr - REQUIRED */
+   png_read_end(png_ptr, info_ptr);
+
+   if(transforms == 0 || params == NULL)
+      /* quiet compiler warnings */ return;
+
+}
+#endif
diff --git a/collects/plot/src/all/pngrio.c b/collects/plot/src/all/pngrio.c
new file mode 100644
index 0000000000..c33b1cdce3
--- /dev/null
+++ b/collects/plot/src/all/pngrio.c
@@ -0,0 +1,161 @@
+
+/* pngrio.c - functions for data input
+ *
+ * libpng 1.2.5 - October 3, 2002
+ * For conditions of distribution and use, see copyright notice in png.h
+ * Copyright (c) 1998-2002 Glenn Randers-Pehrson
+ * (Version 0.96 Copyright (c) 1996, 1997 Andreas Dilger)
+ * (Version 0.88 Copyright (c) 1995, 1996 Guy Eric Schalnat, Group 42, Inc.)
+ *
+ * This file provides a location for all input.  Users who need
+ * special handling are expected to write a function that has the same
+ * arguments as this and performs a similar function, but that possibly
+ * has a different input method.  Note that you shouldn't change this
+ * function, but rather write a replacement function and then make
+ * libpng use it at run time with png_set_read_fn(...).
+ */
+
+#define PNG_INTERNAL
+#include "png.h"
+
+/* Read the data from whatever input you are using.  The default routine
+   reads from a file pointer.  Note that this routine sometimes gets called
+   with very small lengths, so you should implement some kind of simple
+   buffering if you are using unbuffered reads.  This should never be asked
+   to read more then 64K on a 16 bit machine. */
+void /* PRIVATE */
+png_read_data(png_structp png_ptr, png_bytep data, png_size_t length)
+{
+   png_debug1(4,"reading %d bytes\n", (int)length);
+   if (png_ptr->read_data_fn != NULL)
+      (*(png_ptr->read_data_fn))(png_ptr, data, length);
+   else
+      png_error(png_ptr, "Call to NULL read function");
+}
+
+#if !defined(PNG_NO_STDIO)
+/* This is the function that does the actual reading of data.  If you are
+   not reading from a standard C stream, you should create a replacement
+   read_data function and use it at run time with png_set_read_fn(), rather
+   than changing the library. */
+#ifndef USE_FAR_KEYWORD
+void PNGAPI
+png_default_read_data(png_structp png_ptr, png_bytep data, png_size_t length)
+{
+   png_size_t check;
+
+   /* fread() returns 0 on error, so it is OK to store this in a png_size_t
+    * instead of an int, which is what fread() actually returns.
+    */
+#if defined(_WIN32_WCE)
+   if ( !ReadFile((HANDLE)(png_ptr->io_ptr), data, length, &check, NULL) )
+      check = 0;
+#else
+   check = (png_size_t)fread(data, (png_size_t)1, length,
+      (png_FILE_p)png_ptr->io_ptr);
+#endif
+
+   if (check != length)
+      png_error(png_ptr, "Read Error");
+}
+#else
+/* this is the model-independent version. Since the standard I/O library
+   can't handle far buffers in the medium and small models, we have to copy
+   the data.
+*/
+
+#define NEAR_BUF_SIZE 1024
+#define MIN(a,b) (a <= b ? a : b)
+
+static void /* PRIVATE */
+png_default_read_data(png_structp png_ptr, png_bytep data, png_size_t length)
+{
+   int check;
+   png_byte *n_data;
+   png_FILE_p io_ptr;
+
+   /* Check if data really is near. If so, use usual code. */
+   n_data = (png_byte *)CVT_PTR_NOCHECK(data);
+   io_ptr = (png_FILE_p)CVT_PTR(png_ptr->io_ptr);
+   if ((png_bytep)n_data == data)
+   {
+#if defined(_WIN32_WCE)
+      if ( !ReadFile((HANDLE)(png_ptr->io_ptr), data, length, &check, NULL) )
+         check = 0;
+#else
+      check = fread(n_data, 1, length, io_ptr);
+#endif
+   }
+   else
+   {
+      png_byte buf[NEAR_BUF_SIZE];
+      png_size_t read, remaining, err;
+      check = 0;
+      remaining = length;
+      do
+      {
+         read = MIN(NEAR_BUF_SIZE, remaining);
+#if defined(_WIN32_WCE)
+         if ( !ReadFile((HANDLE)(io_ptr), buf, read, &err, NULL) )
+            err = 0;
+#else
+         err = fread(buf, (png_size_t)1, read, io_ptr);
+#endif
+         png_memcpy(data, buf, read); /* copy far buffer to near buffer */
+         if(err != read)
+            break;
+         else
+            check += err;
+         data += read;
+         remaining -= read;
+      }
+      while (remaining != 0);
+   }
+   if ((png_uint_32)check != (png_uint_32)length)
+      png_error(png_ptr, "read Error");
+}
+#endif
+#endif
+
+/* This function allows the application to supply a new input function
+   for libpng if standard C streams aren't being used.
+
+   This function takes as its arguments:
+   png_ptr      - pointer to a png input data structure
+   io_ptr       - pointer to user supplied structure containing info about
+                  the input functions.  May be NULL.
+   read_data_fn - pointer to a new input function that takes as its
+                  arguments a pointer to a png_struct, a pointer to
+                  a location where input data can be stored, and a 32-bit
+                  unsigned int that is the number of bytes to be read.
+                  To exit and output any fatal error messages the new write
+                  function should call png_error(png_ptr, "Error msg"). */
+void PNGAPI
+png_set_read_fn(png_structp png_ptr, png_voidp io_ptr,
+   png_rw_ptr read_data_fn)
+{
+   png_ptr->io_ptr = io_ptr;
+
+#if !defined(PNG_NO_STDIO)
+   if (read_data_fn != NULL)
+      png_ptr->read_data_fn = read_data_fn;
+   else
+      png_ptr->read_data_fn = png_default_read_data;
+#else
+   png_ptr->read_data_fn = read_data_fn;
+#endif
+
+   /* It is an error to write to a read device */
+   if (png_ptr->write_data_fn != NULL)
+   {
+      png_ptr->write_data_fn = NULL;
+      png_warning(png_ptr,
+         "It's an error to set both read_data_fn and write_data_fn in the ");
+      png_warning(png_ptr,
+         "same structure.  Resetting write_data_fn to NULL.");
+   }
+
+#if defined(PNG_WRITE_FLUSH_SUPPORTED)
+   png_ptr->output_flush_fn = NULL;
+#endif
+}
diff --git a/collects/plot/src/all/pngrtran.c b/collects/plot/src/all/pngrtran.c
new file mode 100644
index 0000000000..3de91202c1
--- /dev/null
+++ b/collects/plot/src/all/pngrtran.c
@@ -0,0 +1,4175 @@
+
+/* pngrtran.c - transforms the data in a row for PNG readers
+ *
+ * libpng 1.2.5 - October 3, 2002
+ * For conditions of distribution and use, see copyright notice in png.h
+ * Copyright (c) 1998-2002 Glenn Randers-Pehrson
+ * (Version 0.96 Copyright (c) 1996, 1997 Andreas Dilger)
+ * (Version 0.88 Copyright (c) 1995, 1996 Guy Eric Schalnat, Group 42, Inc.)
+ *
+ * This file contains functions optionally called by an application
+ * in order to tell libpng how to handle data when reading a PNG.
+ * Transformations that are used in both reading and writing are
+ * in pngtrans.c.
+ */
+
+#define PNG_INTERNAL
+#include "png.h"
+
+/* Set the action on getting a CRC error for an ancillary or critical chunk. */
+void PNGAPI
+png_set_crc_action(png_structp png_ptr, int crit_action, int ancil_action)
+{
+   png_debug(1, "in png_set_crc_action\n");
+   /* Tell libpng how we react to CRC errors in critical chunks */
+   switch (crit_action)
+   {
+      case PNG_CRC_NO_CHANGE:                        /* leave setting as is */
+         break;
+      case PNG_CRC_WARN_USE:                               /* warn/use data */
+         png_ptr->flags &= ~PNG_FLAG_CRC_CRITICAL_MASK;
+         png_ptr->flags |= PNG_FLAG_CRC_CRITICAL_USE;
+         break;
+      case PNG_CRC_QUIET_USE:                             /* quiet/use data */
+         png_ptr->flags &= ~PNG_FLAG_CRC_CRITICAL_MASK;
+         png_ptr->flags |= PNG_FLAG_CRC_CRITICAL_USE |
+                           PNG_FLAG_CRC_CRITICAL_IGNORE;
+         break;
+      case PNG_CRC_WARN_DISCARD:    /* not a valid action for critical data */
+         png_warning(png_ptr, "Can't discard critical data on CRC error.");
+      case PNG_CRC_ERROR_QUIT:                                /* error/quit */
+      case PNG_CRC_DEFAULT:
+      default:
+         png_ptr->flags &= ~PNG_FLAG_CRC_CRITICAL_MASK;
+         break;
+   }
+
+   switch (ancil_action)
+   {
+      case PNG_CRC_NO_CHANGE:                       /* leave setting as is */
+         break;
+      case PNG_CRC_WARN_USE:                              /* warn/use data */
+         png_ptr->flags &= ~PNG_FLAG_CRC_ANCILLARY_MASK;
+         png_ptr->flags |= PNG_FLAG_CRC_ANCILLARY_USE;
+         break;
+      case PNG_CRC_QUIET_USE:                            /* quiet/use data */
+         png_ptr->flags &= ~PNG_FLAG_CRC_ANCILLARY_MASK;
+         png_ptr->flags |= PNG_FLAG_CRC_ANCILLARY_USE |
+                           PNG_FLAG_CRC_ANCILLARY_NOWARN;
+         break;
+      case PNG_CRC_ERROR_QUIT:                               /* error/quit */
+         png_ptr->flags &= ~PNG_FLAG_CRC_ANCILLARY_MASK;
+         png_ptr->flags |= PNG_FLAG_CRC_ANCILLARY_NOWARN;
+         break;
+      case PNG_CRC_WARN_DISCARD:                      /* warn/discard data */
+      case PNG_CRC_DEFAULT:
+      default:
+         png_ptr->flags &= ~PNG_FLAG_CRC_ANCILLARY_MASK;
+         break;
+   }
+}
+
+#if defined(PNG_READ_BACKGROUND_SUPPORTED) && \
+    defined(PNG_FLOATING_POINT_SUPPORTED)
+/* handle alpha and tRNS via a background color */
+void PNGAPI
+png_set_background(png_structp png_ptr,
+   png_color_16p background_color, int background_gamma_code,
+   int need_expand, double background_gamma)
+{
+   png_debug(1, "in png_set_background\n");
+   if (background_gamma_code == PNG_BACKGROUND_GAMMA_UNKNOWN)
+   {
+      png_warning(png_ptr, "Application must supply a known background gamma");
+      return;
+   }
+
+   png_ptr->transformations |= PNG_BACKGROUND;
+   png_memcpy(&(png_ptr->background), background_color, sizeof(png_color_16));
+   png_ptr->background_gamma = (float)background_gamma;
+   png_ptr->background_gamma_type = (png_byte)(background_gamma_code);
+   png_ptr->transformations |= (need_expand ? PNG_BACKGROUND_EXPAND : 0);
+
+   /* Note:  if need_expand is set and color_type is either RGB or RGB_ALPHA
+    * (in which case need_expand is superfluous anyway), the background color
+    * might actually be gray yet not be flagged as such. This is not a problem
+    * for the current code, which uses PNG_BACKGROUND_IS_GRAY only to
+    * decide when to do the png_do_gray_to_rgb() transformation.
+    */
+   if ((need_expand && !(png_ptr->color_type & PNG_COLOR_MASK_COLOR)) ||
+       (!need_expand && background_color->red == background_color->green &&
+        background_color->red == background_color->blue))
+      png_ptr->mode |= PNG_BACKGROUND_IS_GRAY;
+}
+#endif
+
+#if defined(PNG_READ_16_TO_8_SUPPORTED)
+/* strip 16 bit depth files to 8 bit depth */
+void PNGAPI
+png_set_strip_16(png_structp png_ptr)
+{
+   png_debug(1, "in png_set_strip_16\n");
+   png_ptr->transformations |= PNG_16_TO_8;
+}
+#endif
+
+#if defined(PNG_READ_STRIP_ALPHA_SUPPORTED)
+void PNGAPI
+png_set_strip_alpha(png_structp png_ptr)
+{
+   png_debug(1, "in png_set_strip_alpha\n");
+   png_ptr->transformations |= PNG_STRIP_ALPHA;
+}
+#endif
+
+#if defined(PNG_READ_DITHER_SUPPORTED)
+/* Dither file to 8 bit.  Supply a palette, the current number
+ * of elements in the palette, the maximum number of elements
+ * allowed, and a histogram if possible.  If the current number
+ * of colors is greater then the maximum number, the palette will be
+ * modified to fit in the maximum number.  "full_dither" indicates
+ * whether we need a dithering cube set up for RGB images, or if we
+ * simply are reducing the number of colors in a paletted image.
+ */
+
+typedef struct png_dsort_struct
+{
+   struct png_dsort_struct FAR * next;
+   png_byte left;
+   png_byte right;
+} png_dsort;
+typedef png_dsort FAR *       png_dsortp;
+typedef png_dsort FAR * FAR * png_dsortpp;
+
+void PNGAPI
+png_set_dither(png_structp png_ptr, png_colorp palette,
+   int num_palette, int maximum_colors, png_uint_16p histogram,
+   int full_dither)
+{
+   png_debug(1, "in png_set_dither\n");
+   png_ptr->transformations |= PNG_DITHER;
+
+   if (!full_dither)
+   {
+      int i;
+
+      png_ptr->dither_index = (png_bytep)png_malloc(png_ptr,
+         (png_uint_32)(num_palette * sizeof (png_byte)));
+      for (i = 0; i < num_palette; i++)
+         png_ptr->dither_index[i] = (png_byte)i;
+   }
+
+   if (num_palette > maximum_colors)
+   {
+      if (histogram != NULL)
+      {
+         /* This is easy enough, just throw out the least used colors.
+            Perhaps not the best solution, but good enough. */
+
+         int i;
+
+         /* initialize an array to sort colors */
+         png_ptr->dither_sort = (png_bytep)png_malloc(png_ptr,
+            (png_uint_32)(num_palette * sizeof (png_byte)));
+
+         /* initialize the dither_sort array */
+         for (i = 0; i < num_palette; i++)
+            png_ptr->dither_sort[i] = (png_byte)i;
+
+         /* Find the least used palette entries by starting a
+            bubble sort, and running it until we have sorted
+            out enough colors.  Note that we don't care about
+            sorting all the colors, just finding which are
+            least used. */
+
+         for (i = num_palette - 1; i >= maximum_colors; i--)
+         {
+            int done; /* to stop early if the list is pre-sorted */
+            int j;
+
+            done = 1;
+            for (j = 0; j < i; j++)
+            {
+               if (histogram[png_ptr->dither_sort[j]]
+                   < histogram[png_ptr->dither_sort[j + 1]])
+               {
+                  png_byte t;
+
+                  t = png_ptr->dither_sort[j];
+                  png_ptr->dither_sort[j] = png_ptr->dither_sort[j + 1];
+                  png_ptr->dither_sort[j + 1] = t;
+                  done = 0;
+               }
+            }
+            if (done)
+               break;
+         }
+
+         /* swap the palette around, and set up a table, if necessary */
+         if (full_dither)
+         {
+            int j = num_palette;
+
+            /* put all the useful colors within the max, but don't
+               move the others */
+            for (i = 0; i < maximum_colors; i++)
+            {
+               if ((int)png_ptr->dither_sort[i] >= maximum_colors)
+               {
+                  do
+                     j--;
+                  while ((int)png_ptr->dither_sort[j] >= maximum_colors);
+                  palette[i] = palette[j];
+               }
+            }
+         }
+         else
+         {
+            int j = num_palette;
+
+            /* move all the used colors inside the max limit, and
+               develop a translation table */
+            for (i = 0; i < maximum_colors; i++)
+            {
+               /* only move the colors we need to */
+               if ((int)png_ptr->dither_sort[i] >= maximum_colors)
+               {
+                  png_color tmp_color;
+
+                  do
+                     j--;
+                  while ((int)png_ptr->dither_sort[j] >= maximum_colors);
+
+                  tmp_color = palette[j];
+                  palette[j] = palette[i];
+                  palette[i] = tmp_color;
+                  /* indicate where the color went */
+                  png_ptr->dither_index[j] = (png_byte)i;
+                  png_ptr->dither_index[i] = (png_byte)j;
+               }
+            }
+
+            /* find closest color for those colors we are not using */
+            for (i = 0; i < num_palette; i++)
+            {
+               if ((int)png_ptr->dither_index[i] >= maximum_colors)
+               {
+                  int min_d, k, min_k, d_index;
+
+                  /* find the closest color to one we threw out */
+                  d_index = png_ptr->dither_index[i];
+                  min_d = PNG_COLOR_DIST(palette[d_index], palette[0]);
+                  for (k = 1, min_k = 0; k < maximum_colors; k++)
+                  {
+                     int d;
+
+                     d = PNG_COLOR_DIST(palette[d_index], palette[k]);
+
+                     if (d < min_d)
+                     {
+                        min_d = d;
+                        min_k = k;
+                     }
+                  }
+                  /* point to closest color */
+                  png_ptr->dither_index[i] = (png_byte)min_k;
+               }
+            }
+         }
+         png_free(png_ptr, png_ptr->dither_sort);
+         png_ptr->dither_sort=NULL;
+      }
+      else
+      {
+         /* This is much harder to do simply (and quickly).  Perhaps
+            we need to go through a median cut routine, but those
+            don't always behave themselves with only a few colors
+            as input.  So we will just find the closest two colors,
+            and throw out one of them (chosen somewhat randomly).
+            [We don't understand this at all, so if someone wants to
+             work on improving it, be our guest - AED, GRP]
+            */
+         int i;
+         int max_d;
+         int num_new_palette;
+         png_dsortp t;
+         png_dsortpp hash;
+
+         t=NULL;
+
+         /* initialize palette index arrays */
+         png_ptr->index_to_palette = (png_bytep)png_malloc(png_ptr,
+            (png_uint_32)(num_palette * sizeof (png_byte)));
+         png_ptr->palette_to_index = (png_bytep)png_malloc(png_ptr,
+            (png_uint_32)(num_palette * sizeof (png_byte)));
+
+         /* initialize the sort array */
+         for (i = 0; i < num_palette; i++)
+         {
+            png_ptr->index_to_palette[i] = (png_byte)i;
+            png_ptr->palette_to_index[i] = (png_byte)i;
+         }
+
+         hash = (png_dsortpp)png_malloc(png_ptr, (png_uint_32)(769 *
+            sizeof (png_dsortp)));
+         for (i = 0; i < 769; i++)
+            hash[i] = NULL;
+/*         png_memset(hash, 0, 769 * sizeof (png_dsortp)); */
+
+         num_new_palette = num_palette;
+
+         /* initial wild guess at how far apart the farthest pixel
+            pair we will be eliminating will be.  Larger
+            numbers mean more areas will be allocated, Smaller
+            numbers run the risk of not saving enough data, and
+            having to do this all over again.
+
+            I have not done extensive checking on this number.
+            */
+         max_d = 96;
+
+         while (num_new_palette > maximum_colors)
+         {
+            for (i = 0; i < num_new_palette - 1; i++)
+            {
+               int j;
+
+               for (j = i + 1; j < num_new_palette; j++)
+               {
+                  int d;
+
+                  d = PNG_COLOR_DIST(palette[i], palette[j]);
+
+                  if (d <= max_d)
+                  {
+
+                     t = (png_dsortp)png_malloc_warn(png_ptr,
+                         (png_uint_32)(sizeof(png_dsort)));
+                     if (t == NULL)
+                         break;
+                     t->next = hash[d];
+                     t->left = (png_byte)i;
+                     t->right = (png_byte)j;
+                     hash[d] = t;
+                  }
+               }
+               if (t == NULL)
+                  break;
+            }
+
+            if (t != NULL)
+            for (i = 0; i <= max_d; i++)
+            {
+               if (hash[i] != NULL)
+               {
+                  png_dsortp p;
+
+                  for (p = hash[i]; p; p = p->next)
+                  {
+                     if ((int)png_ptr->index_to_palette[p->left]
+                        < num_new_palette &&
+                        (int)png_ptr->index_to_palette[p->right]
+                        < num_new_palette)
+                     {
+                        int j, next_j;
+
+                        if (num_new_palette & 0x01)
+                        {
+                           j = p->left;
+                           next_j = p->right;
+                        }
+                        else
+                        {
+                           j = p->right;
+                           next_j = p->left;
+                        }
+
+                        num_new_palette--;
+                        palette[png_ptr->index_to_palette[j]]
+                          = palette[num_new_palette];
+                        if (!full_dither)
+                        {
+                           int k;
+
+                           for (k = 0; k < num_palette; k++)
+                           {
+                              if (png_ptr->dither_index[k] ==
+                                 png_ptr->index_to_palette[j])
+                                 png_ptr->dither_index[k] =
+                                    png_ptr->index_to_palette[next_j];
+                              if ((int)png_ptr->dither_index[k] ==
+                                 num_new_palette)
+                                 png_ptr->dither_index[k] =
+                                    png_ptr->index_to_palette[j];
+                           }
+                        }
+
+                        png_ptr->index_to_palette[png_ptr->palette_to_index
+                           [num_new_palette]] = png_ptr->index_to_palette[j];
+                        png_ptr->palette_to_index[png_ptr->index_to_palette[j]]
+                           = png_ptr->palette_to_index[num_new_palette];
+
+                        png_ptr->index_to_palette[j] = (png_byte)num_new_palette;
+                        png_ptr->palette_to_index[num_new_palette] = (png_byte)j;
+                     }
+                     if (num_new_palette <= maximum_colors)
+                        break;
+                  }
+                  if (num_new_palette <= maximum_colors)
+                     break;
+               }
+            }
+
+            for (i = 0; i < 769; i++)
+            {
+               if (hash[i] != NULL)
+               {
+                  png_dsortp p = hash[i];
+                  while (p)
+                  {
+                     t = p->next;
+                     png_free(png_ptr, p);
+                     p = t;
+                  }
+               }
+               hash[i] = 0;
+            }
+            max_d += 96;
+         }
+         png_free(png_ptr, hash);
+         png_free(png_ptr, png_ptr->palette_to_index);
+         png_free(png_ptr, png_ptr->index_to_palette);
+         png_ptr->palette_to_index=NULL;
+         png_ptr->index_to_palette=NULL;
+      }
+      num_palette = maximum_colors;
+   }
+   if (png_ptr->palette == NULL)
+   {
+      png_ptr->palette = palette;
+   }
+   png_ptr->num_palette = (png_uint_16)num_palette;
+
+   if (full_dither)
+   {
+      int i;
+      png_bytep distance;
+      int total_bits = PNG_DITHER_RED_BITS + PNG_DITHER_GREEN_BITS +
+         PNG_DITHER_BLUE_BITS;
+      int num_red = (1 << PNG_DITHER_RED_BITS);
+      int num_green = (1 << PNG_DITHER_GREEN_BITS);
+      int num_blue = (1 << PNG_DITHER_BLUE_BITS);
+      png_size_t num_entries = ((png_size_t)1 << total_bits);
+
+      png_ptr->palette_lookup = (png_bytep )png_malloc(png_ptr,
+         (png_uint_32)(num_entries * sizeof (png_byte)));
+
+      png_memset(png_ptr->palette_lookup, 0, num_entries * sizeof (png_byte));
+
+      distance = (png_bytep)png_malloc(png_ptr, (png_uint_32)(num_entries *
+         sizeof(png_byte)));
+
+      png_memset(distance, 0xff, num_entries * sizeof(png_byte));
+
+      for (i = 0; i < num_palette; i++)
+      {
+         int ir, ig, ib;
+         int r = (palette[i].red >> (8 - PNG_DITHER_RED_BITS));
+         int g = (palette[i].green >> (8 - PNG_DITHER_GREEN_BITS));
+         int b = (palette[i].blue >> (8 - PNG_DITHER_BLUE_BITS));
+
+         for (ir = 0; ir < num_red; ir++)
+         {
+            int dr = abs(ir - r);
+            int index_r = (ir << (PNG_DITHER_BLUE_BITS + PNG_DITHER_GREEN_BITS));
+
+            for (ig = 0; ig < num_green; ig++)
+            {
+               int dg = abs(ig - g);
+               int dt = dr + dg;
+               int dm = ((dr > dg) ? dr : dg);
+               int index_g = index_r | (ig << PNG_DITHER_BLUE_BITS);
+
+               for (ib = 0; ib < num_blue; ib++)
+               {
+                  int d_index = index_g | ib;
+                  int db = abs(ib - b);
+                  int dmax = ((dm > db) ? dm : db);
+                  int d = dmax + dt + db;
+
+                  if (d < (int)distance[d_index])
+                  {
+                     distance[d_index] = (png_byte)d;
+                     png_ptr->palette_lookup[d_index] = (png_byte)i;
+                  }
+               }
+            }
+         }
+      }
+
+      png_free(png_ptr, distance);
+   }
+}
+#endif
+
+#if defined(PNG_READ_GAMMA_SUPPORTED) && defined(PNG_FLOATING_POINT_SUPPORTED)
+/* Transform the image from the file_gamma to the screen_gamma.  We
+ * only do transformations on images where the file_gamma and screen_gamma
+ * are not close reciprocals, otherwise it slows things down slightly, and
+ * also needlessly introduces small errors.
+ *
+ * We will turn off gamma transformation later if no semitransparent entries
+ * are present in the tRNS array for palette images.  We can't do it here
+ * because we don't necessarily have the tRNS chunk yet.
+ */
+void PNGAPI
+png_set_gamma(png_structp png_ptr, double scrn_gamma, double file_gamma)
+{
+   png_debug(1, "in png_set_gamma\n");
+   if ((fabs(scrn_gamma * file_gamma - 1.0) > PNG_GAMMA_THRESHOLD) ||
+       (png_ptr->color_type & PNG_COLOR_MASK_ALPHA) ||
+       (png_ptr->color_type == PNG_COLOR_TYPE_PALETTE))
+     png_ptr->transformations |= PNG_GAMMA;
+   png_ptr->gamma = (float)file_gamma;
+   png_ptr->screen_gamma = (float)scrn_gamma;
+}
+#endif
+
+#if defined(PNG_READ_EXPAND_SUPPORTED)
+/* Expand paletted images to RGB, expand grayscale images of
+ * less than 8-bit depth to 8-bit depth, and expand tRNS chunks
+ * to alpha channels.
+ */
+void PNGAPI
+png_set_expand(png_structp png_ptr)
+{
+   png_debug(1, "in png_set_expand\n");
+   png_ptr->transformations |= PNG_EXPAND;
+}
+
+/* GRR 19990627:  the following three functions currently are identical
+ *  to png_set_expand().  However, it is entirely reasonable that someone
+ *  might wish to expand an indexed image to RGB but *not* expand a single,
+ *  fully transparent palette entry to a full alpha channel--perhaps instead
+ *  convert tRNS to the grayscale/RGB format (16-bit RGB value), or replace
+ *  the transparent color with a particular RGB value, or drop tRNS entirely.
+ *  IOW, a future version of the library may make the transformations flag
+ *  a bit more fine-grained, with separate bits for each of these three
+ *  functions.
+ *
+ *  More to the point, these functions make it obvious what libpng will be
+ *  doing, whereas "expand" can (and does) mean any number of things.
+ */
+
+/* Expand paletted images to RGB. */
+void PNGAPI
+png_set_palette_to_rgb(png_structp png_ptr)
+{
+   png_debug(1, "in png_set_expand\n");
+   png_ptr->transformations |= PNG_EXPAND;
+}
+
+/* Expand grayscale images of less than 8-bit depth to 8 bits. */
+void PNGAPI
+png_set_gray_1_2_4_to_8(png_structp png_ptr)
+{
+   png_debug(1, "in png_set_expand\n");
+   png_ptr->transformations |= PNG_EXPAND;
+}
+
+/* Expand tRNS chunks to alpha channels. */
+void PNGAPI
+png_set_tRNS_to_alpha(png_structp png_ptr)
+{
+   png_debug(1, "in png_set_expand\n");
+   png_ptr->transformations |= PNG_EXPAND;
+}
+#endif /* defined(PNG_READ_EXPAND_SUPPORTED) */
+
+#if defined(PNG_READ_GRAY_TO_RGB_SUPPORTED)
+void PNGAPI
+png_set_gray_to_rgb(png_structp png_ptr)
+{
+   png_debug(1, "in png_set_gray_to_rgb\n");
+   png_ptr->transformations |= PNG_GRAY_TO_RGB;
+}
+#endif
+
+#if defined(PNG_READ_RGB_TO_GRAY_SUPPORTED)
+#if defined(PNG_FLOATING_POINT_SUPPORTED)
+/* Convert a RGB image to a grayscale of the same width.  This allows us,
+ * for example, to convert a 24 bpp RGB image into an 8 bpp grayscale image.
+ */
+
+void PNGAPI
+png_set_rgb_to_gray(png_structp png_ptr, int error_action, double red,
+   double green)
+{
+      int red_fixed = (int)((float)red*100000.0 + 0.5);
+      int green_fixed = (int)((float)green*100000.0 + 0.5);
+      png_set_rgb_to_gray_fixed(png_ptr, error_action, red_fixed, green_fixed);
+}
+#endif
+
+void PNGAPI
+png_set_rgb_to_gray_fixed(png_structp png_ptr, int error_action,
+   png_fixed_point red, png_fixed_point green)
+{
+   png_debug(1, "in png_set_rgb_to_gray\n");
+   switch(error_action)
+   {
+      case 1: png_ptr->transformations |= PNG_RGB_TO_GRAY;
+              break;
+      case 2: png_ptr->transformations |= PNG_RGB_TO_GRAY_WARN;
+              break;
+      case 3: png_ptr->transformations |= PNG_RGB_TO_GRAY_ERR;
+   }
+   if (png_ptr->color_type == PNG_COLOR_TYPE_PALETTE)
+#if defined(PNG_READ_EXPAND_SUPPORTED)
+      png_ptr->transformations |= PNG_EXPAND;
+#else
+   {
+      png_warning(png_ptr, "Cannot do RGB_TO_GRAY without EXPAND_SUPPORTED.");
+      png_ptr->transformations &= ~PNG_RGB_TO_GRAY;
+   }
+#endif
+   {
+      png_uint_16 red_int, green_int;
+      if(red < 0 || green < 0)
+      {
+         red_int   =  6968; /* .212671 * 32768 + .5 */
+         green_int = 23434; /* .715160 * 32768 + .5 */
+      }
+      else if(red + green < 100000L)
+      {
+        red_int = (png_uint_16)(((png_uint_32)red*32768L)/100000L);
+        green_int = (png_uint_16)(((png_uint_32)green*32768L)/100000L);
+      }
+      else
+      {
+         png_warning(png_ptr, "ignoring out of range rgb_to_gray coefficients");
+         red_int   =  6968;
+         green_int = 23434;
+      }
+      png_ptr->rgb_to_gray_red_coeff   = red_int;
+      png_ptr->rgb_to_gray_green_coeff = green_int;
+      png_ptr->rgb_to_gray_blue_coeff  = (png_uint_16)(32768-red_int-green_int);
+   }
+}
+#endif
+
+#if defined(PNG_READ_USER_TRANSFORM_SUPPORTED) || \
+    defined(PNG_WRITE_USER_TRANSFORM_SUPPORTED) || \
+    defined(PNG_LEGACY_SUPPORTED)
+void PNGAPI
+png_set_read_user_transform_fn(png_structp png_ptr, png_user_transform_ptr
+   read_user_transform_fn)
+{
+   png_debug(1, "in png_set_read_user_transform_fn\n");
+#if defined(PNG_READ_USER_TRANSFORM_SUPPORTED)
+   png_ptr->transformations |= PNG_USER_TRANSFORM;
+   png_ptr->read_user_transform_fn = read_user_transform_fn;
+#endif
+#ifdef PNG_LEGACY_SUPPORTED
+   if(read_user_transform_fn)
+      png_warning(png_ptr,
+        "This version of libpng does not support user transforms");
+#endif
+}
+#endif
+
+/* Initialize everything needed for the read.  This includes modifying
+ * the palette.
+ */
+void /* PRIVATE */
+png_init_read_transformations(png_structp png_ptr)
+{
+   png_debug(1, "in png_init_read_transformations\n");
+#if defined(PNG_USELESS_TESTS_SUPPORTED)
+   if(png_ptr != NULL)
+#endif
+  {
+#if defined(PNG_READ_BACKGROUND_SUPPORTED) || defined(PNG_READ_SHIFT_SUPPORTED) \
+ || defined(PNG_READ_GAMMA_SUPPORTED)
+   int color_type = png_ptr->color_type;
+#endif
+
+#if defined(PNG_READ_EXPAND_SUPPORTED) && defined(PNG_READ_BACKGROUND_SUPPORTED)
+   if ((png_ptr->transformations & PNG_BACKGROUND_EXPAND) &&
+       (png_ptr->transformations & PNG_EXPAND))
+   {
+      if (!(color_type & PNG_COLOR_MASK_COLOR))  /* i.e., GRAY or GRAY_ALPHA */
+      {
+         /* expand background chunk. */
+         switch (png_ptr->bit_depth)
+         {
+            case 1:
+               png_ptr->background.gray *= (png_uint_16)0xff;
+               png_ptr->background.red = png_ptr->background.green
+                 =  png_ptr->background.blue = png_ptr->background.gray;
+               break;
+            case 2:
+               png_ptr->background.gray *= (png_uint_16)0x55;
+               png_ptr->background.red = png_ptr->background.green
+                 = png_ptr->background.blue = png_ptr->background.gray;
+               break;
+            case 4:
+               png_ptr->background.gray *= (png_uint_16)0x11;
+               png_ptr->background.red = png_ptr->background.green
+                 = png_ptr->background.blue = png_ptr->background.gray;
+               break;
+            case 8:
+            case 16:
+               png_ptr->background.red = png_ptr->background.green
+                 = png_ptr->background.blue = png_ptr->background.gray;
+               break;
+         }
+      }
+      else if (color_type == PNG_COLOR_TYPE_PALETTE)
+      {
+         png_ptr->background.red   =
+            png_ptr->palette[png_ptr->background.index].red;
+         png_ptr->background.green =
+            png_ptr->palette[png_ptr->background.index].green;
+         png_ptr->background.blue  =
+            png_ptr->palette[png_ptr->background.index].blue;
+
+#if defined(PNG_READ_INVERT_ALPHA_SUPPORTED)
+        if (png_ptr->transformations & PNG_INVERT_ALPHA)
+        {
+#if defined(PNG_READ_EXPAND_SUPPORTED)
+           if (!(png_ptr->transformations & PNG_EXPAND))
+#endif
+           {
+           /* invert the alpha channel (in tRNS) unless the pixels are
+              going to be expanded, in which case leave it for later */
+              int i,istop;
+              istop=(int)png_ptr->num_trans;
+              for (i=0; i<istop; i++)
+                 png_ptr->trans[i] = (png_byte)(255 - png_ptr->trans[i]);
+           }
+        }
+#endif
+
+      }
+   }
+#endif
+
+#if defined(PNG_READ_BACKGROUND_SUPPORTED) && defined(PNG_READ_GAMMA_SUPPORTED)
+   png_ptr->background_1 = png_ptr->background;
+#endif
+#if defined(PNG_READ_GAMMA_SUPPORTED) && defined(PNG_FLOATING_POINT_SUPPORTED)
+
+   if ((color_type == PNG_COLOR_TYPE_PALETTE && png_ptr->num_trans != 0)
+       && (fabs(png_ptr->screen_gamma * png_ptr->gamma - 1.0)
+         < PNG_GAMMA_THRESHOLD))
+   {
+    int i,k;
+    k=0;
+    for (i=0; i<png_ptr->num_trans; i++)
+    {
+      if (png_ptr->trans[i] != 0 && png_ptr->trans[i] != 0xff)
+        k=1; /* partial transparency is present */
+    }
+    if (k == 0)
+      png_ptr->transformations &= (~PNG_GAMMA);
+   }
+
+   if (png_ptr->transformations & (PNG_GAMMA | PNG_RGB_TO_GRAY))
+   {
+      png_build_gamma_table(png_ptr);
+#if defined(PNG_READ_BACKGROUND_SUPPORTED)
+      if (png_ptr->transformations & PNG_BACKGROUND)
+      {
+         if (color_type == PNG_COLOR_TYPE_PALETTE)
+         {
+           /* could skip if no transparency and 
+           */
+            png_color back, back_1;
+            png_colorp palette = png_ptr->palette;
+            int num_palette = png_ptr->num_palette;
+            int i;
+            if (png_ptr->background_gamma_type == PNG_BACKGROUND_GAMMA_FILE)
+            {
+               back.red = png_ptr->gamma_table[png_ptr->background.red];
+               back.green = png_ptr->gamma_table[png_ptr->background.green];
+               back.blue = png_ptr->gamma_table[png_ptr->background.blue];
+
+               back_1.red = png_ptr->gamma_to_1[png_ptr->background.red];
+               back_1.green = png_ptr->gamma_to_1[png_ptr->background.green];
+               back_1.blue = png_ptr->gamma_to_1[png_ptr->background.blue];
+            }
+            else
+            {
+               double g, gs;
+
+               switch (png_ptr->background_gamma_type)
+               {
+                  case PNG_BACKGROUND_GAMMA_SCREEN:
+                     g = (png_ptr->screen_gamma);
+                     gs = 1.0;
+                     break;
+                  case PNG_BACKGROUND_GAMMA_FILE:
+                     g = 1.0 / (png_ptr->gamma);
+                     gs = 1.0 / (png_ptr->gamma * png_ptr->screen_gamma);
+                     break;
+                  case PNG_BACKGROUND_GAMMA_UNIQUE:
+                     g = 1.0 / (png_ptr->background_gamma);
+                     gs = 1.0 / (png_ptr->background_gamma *
+                                 png_ptr->screen_gamma);
+                     break;
+                  default:
+                     g = 1.0;    /* back_1 */
+                     gs = 1.0;   /* back */
+               }
+
+               if ( fabs(gs - 1.0) < PNG_GAMMA_THRESHOLD)
+               {
+                  back.red   = (png_byte)png_ptr->background.red;
+                  back.green = (png_byte)png_ptr->background.green;
+                  back.blue  = (png_byte)png_ptr->background.blue;
+               }
+               else
+               {
+                  back.red = (png_byte)(pow(
+                     (double)png_ptr->background.red/255, gs) * 255.0 + .5);
+                  back.green = (png_byte)(pow(
+                     (double)png_ptr->background.green/255, gs) * 255.0 + .5);
+                  back.blue = (png_byte)(pow(
+                     (double)png_ptr->background.blue/255, gs) * 255.0 + .5);
+               }
+
+               back_1.red = (png_byte)(pow(
+                  (double)png_ptr->background.red/255, g) * 255.0 + .5);
+               back_1.green = (png_byte)(pow(
+                  (double)png_ptr->background.green/255, g) * 255.0 + .5);
+               back_1.blue = (png_byte)(pow(
+                  (double)png_ptr->background.blue/255, g) * 255.0 + .5);
+            }
+            for (i = 0; i < num_palette; i++)
+            {
+               if (i < (int)png_ptr->num_trans && png_ptr->trans[i] != 0xff)
+               {
+                  if (png_ptr->trans[i] == 0)
+                  {
+                     palette[i] = back;
+                  }
+                  else /* if (png_ptr->trans[i] != 0xff) */
+                  {
+                     png_byte v, w;
+
+                     v = png_ptr->gamma_to_1[palette[i].red];
+                     png_composite(w, v, png_ptr->trans[i], back_1.red);
+                     palette[i].red = png_ptr->gamma_from_1[w];
+
+                     v = png_ptr->gamma_to_1[palette[i].green];
+                     png_composite(w, v, png_ptr->trans[i], back_1.green);
+                     palette[i].green = png_ptr->gamma_from_1[w];
+
+                     v = png_ptr->gamma_to_1[palette[i].blue];
+                     png_composite(w, v, png_ptr->trans[i], back_1.blue);
+                     palette[i].blue = png_ptr->gamma_from_1[w];
+                  }
+               }
+               else
+               {
+                  palette[i].red = png_ptr->gamma_table[palette[i].red];
+                  palette[i].green = png_ptr->gamma_table[palette[i].green];
+                  palette[i].blue = png_ptr->gamma_table[palette[i].blue];
+               }
+            }
+         }
+         /* if (png_ptr->background_gamma_type!=PNG_BACKGROUND_GAMMA_UNKNOWN) */
+         else
+         /* color_type != PNG_COLOR_TYPE_PALETTE */
+         {
+            double m = (double)(((png_uint_32)1 << png_ptr->bit_depth) - 1);
+            double g = 1.0;
+            double gs = 1.0;
+
+            switch (png_ptr->background_gamma_type)
+            {
+               case PNG_BACKGROUND_GAMMA_SCREEN:
+                  g = (png_ptr->screen_gamma);
+                  gs = 1.0;
+                  break;
+               case PNG_BACKGROUND_GAMMA_FILE:
+                  g = 1.0 / (png_ptr->gamma);
+                  gs = 1.0 / (png_ptr->gamma * png_ptr->screen_gamma);
+                  break;
+               case PNG_BACKGROUND_GAMMA_UNIQUE:
+                  g = 1.0 / (png_ptr->background_gamma);
+                  gs = 1.0 / (png_ptr->background_gamma *
+                     png_ptr->screen_gamma);
+                  break;
+            }
+
+            png_ptr->background_1.gray = (png_uint_16)(pow(
+               (double)png_ptr->background.gray / m, g) * m + .5);
+            png_ptr->background.gray = (png_uint_16)(pow(
+               (double)png_ptr->background.gray / m, gs) * m + .5);
+
+            if ((png_ptr->background.red != png_ptr->background.green) ||
+                (png_ptr->background.red != png_ptr->background.blue) ||
+                (png_ptr->background.red != png_ptr->background.gray))
+            {
+               /* RGB or RGBA with color background */
+               png_ptr->background_1.red = (png_uint_16)(pow(
+                  (double)png_ptr->background.red / m, g) * m + .5);
+               png_ptr->background_1.green = (png_uint_16)(pow(
+                  (double)png_ptr->background.green / m, g) * m + .5);
+               png_ptr->background_1.blue = (png_uint_16)(pow(
+                  (double)png_ptr->background.blue / m, g) * m + .5);
+               png_ptr->background.red = (png_uint_16)(pow(
+                  (double)png_ptr->background.red / m, gs) * m + .5);
+               png_ptr->background.green = (png_uint_16)(pow(
+                  (double)png_ptr->background.green / m, gs) * m + .5);
+               png_ptr->background.blue = (png_uint_16)(pow(
+                  (double)png_ptr->background.blue / m, gs) * m + .5);
+            }
+            else
+            {
+               /* GRAY, GRAY ALPHA, RGB, or RGBA with gray background */
+               png_ptr->background_1.red = png_ptr->background_1.green
+                 = png_ptr->background_1.blue = png_ptr->background_1.gray;
+               png_ptr->background.red = png_ptr->background.green
+                 = png_ptr->background.blue = png_ptr->background.gray;
+            }
+         }
+      }
+      else
+      /* transformation does not include PNG_BACKGROUND */
+#endif /* PNG_READ_BACKGROUND_SUPPORTED */
+      if (color_type == PNG_COLOR_TYPE_PALETTE)
+      {
+         png_colorp palette = png_ptr->palette;
+         int num_palette = png_ptr->num_palette;
+         int i;
+
+         for (i = 0; i < num_palette; i++)
+         {
+            palette[i].red = png_ptr->gamma_table[palette[i].red];
+            palette[i].green = png_ptr->gamma_table[palette[i].green];
+            palette[i].blue = png_ptr->gamma_table[palette[i].blue];
+         }
+      }
+   }
+#if defined(PNG_READ_BACKGROUND_SUPPORTED)
+   else
+#endif
+#endif /* PNG_READ_GAMMA_SUPPORTED && PNG_FLOATING_POINT_SUPPORTED */
+#if defined(PNG_READ_BACKGROUND_SUPPORTED)
+   /* No GAMMA transformation */
+   if ((png_ptr->transformations & PNG_BACKGROUND) &&
+       (color_type == PNG_COLOR_TYPE_PALETTE))
+   {
+      int i;
+      int istop = (int)png_ptr->num_trans;
+      png_color back;
+      png_colorp palette = png_ptr->palette;
+
+      back.red   = (png_byte)png_ptr->background.red;
+      back.green = (png_byte)png_ptr->background.green;
+      back.blue  = (png_byte)png_ptr->background.blue;
+
+      for (i = 0; i < istop; i++)
+      {
+         if (png_ptr->trans[i] == 0)
+         {
+            palette[i] = back;
+         }
+         else if (png_ptr->trans[i] != 0xff)
+         {
+            /* The png_composite() macro is defined in png.h */
+            png_composite(palette[i].red, palette[i].red,
+               png_ptr->trans[i], back.red);
+            png_composite(palette[i].green, palette[i].green,
+               png_ptr->trans[i], back.green);
+            png_composite(palette[i].blue, palette[i].blue,
+               png_ptr->trans[i], back.blue);
+         }
+      }
+   }
+#endif /* PNG_READ_BACKGROUND_SUPPORTED */
+
+#if defined(PNG_READ_SHIFT_SUPPORTED)
+   if ((png_ptr->transformations & PNG_SHIFT) &&
+      (color_type == PNG_COLOR_TYPE_PALETTE))
+   {
+      png_uint_16 i;
+      png_uint_16 istop = png_ptr->num_palette;
+      int sr = 8 - png_ptr->sig_bit.red;
+      int sg = 8 - png_ptr->sig_bit.green;
+      int sb = 8 - png_ptr->sig_bit.blue;
+
+      if (sr < 0 || sr > 8)
+         sr = 0;
+      if (sg < 0 || sg > 8)
+         sg = 0;
+      if (sb < 0 || sb > 8)
+         sb = 0;
+      for (i = 0; i < istop; i++)
+      {
+         png_ptr->palette[i].red >>= sr;
+         png_ptr->palette[i].green >>= sg;
+         png_ptr->palette[i].blue >>= sb;
+      }
+   }
+#endif  /* PNG_READ_SHIFT_SUPPORTED */
+ }
+#if !defined(PNG_READ_GAMMA_SUPPORTED) && !defined(PNG_READ_SHIFT_SUPPORTED) \
+ && !defined(PNG_READ_BACKGROUND_SUPPORTED)
+   if(png_ptr)
+      return;
+#endif
+}
+
+/* Modify the info structure to reflect the transformations.  The
+ * info should be updated so a PNG file could be written with it,
+ * assuming the transformations result in valid PNG data.
+ */
+void /* PRIVATE */
+png_read_transform_info(png_structp png_ptr, png_infop info_ptr)
+{
+   png_debug(1, "in png_read_transform_info\n");
+#if defined(PNG_READ_EXPAND_SUPPORTED)
+   if (png_ptr->transformations & PNG_EXPAND)
+   {
+      if (info_ptr->color_type == PNG_COLOR_TYPE_PALETTE)
+      {
+         if (png_ptr->num_trans)
+            info_ptr->color_type = PNG_COLOR_TYPE_RGB_ALPHA;
+         else
+            info_ptr->color_type = PNG_COLOR_TYPE_RGB;
+         info_ptr->bit_depth = 8;
+         info_ptr->num_trans = 0;
+      }
+      else
+      {
+         if (png_ptr->num_trans)
+            info_ptr->color_type |= PNG_COLOR_MASK_ALPHA;
+         if (info_ptr->bit_depth < 8)
+            info_ptr->bit_depth = 8;
+         info_ptr->num_trans = 0;
+      }
+   }
+#endif
+
+#if defined(PNG_READ_BACKGROUND_SUPPORTED)
+   if (png_ptr->transformations & PNG_BACKGROUND)
+   {
+      info_ptr->color_type &= ~PNG_COLOR_MASK_ALPHA;
+      info_ptr->num_trans = 0;
+      info_ptr->background = png_ptr->background;
+   }
+#endif
+
+#if defined(PNG_READ_GAMMA_SUPPORTED)
+   if (png_ptr->transformations & PNG_GAMMA)
+   {
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+      info_ptr->gamma = png_ptr->gamma;
+#endif
+#ifdef PNG_FIXED_POINT_SUPPORTED
+      info_ptr->int_gamma = png_ptr->int_gamma;
+#endif
+   }
+#endif
+
+#if defined(PNG_READ_16_TO_8_SUPPORTED)
+   if ((png_ptr->transformations & PNG_16_TO_8) && (info_ptr->bit_depth == 16))
+      info_ptr->bit_depth = 8;
+#endif
+
+#if defined(PNG_READ_DITHER_SUPPORTED)
+   if (png_ptr->transformations & PNG_DITHER)
+   {
+      if (((info_ptr->color_type == PNG_COLOR_TYPE_RGB) ||
+         (info_ptr->color_type == PNG_COLOR_TYPE_RGB_ALPHA)) &&
+         png_ptr->palette_lookup && info_ptr->bit_depth == 8)
+      {
+         info_ptr->color_type = PNG_COLOR_TYPE_PALETTE;
+      }
+   }
+#endif
+
+#if defined(PNG_READ_PACK_SUPPORTED)
+   if ((png_ptr->transformations & PNG_PACK) && (info_ptr->bit_depth < 8))
+      info_ptr->bit_depth = 8;
+#endif
+
+#if defined(PNG_READ_GRAY_TO_RGB_SUPPORTED)
+   if (png_ptr->transformations & PNG_GRAY_TO_RGB)
+      info_ptr->color_type |= PNG_COLOR_MASK_COLOR;
+#endif
+
+#if defined(PNG_READ_RGB_TO_GRAY_SUPPORTED)
+   if (png_ptr->transformations & PNG_RGB_TO_GRAY)
+      info_ptr->color_type &= ~PNG_COLOR_MASK_COLOR;
+#endif
+
+   if (info_ptr->color_type == PNG_COLOR_TYPE_PALETTE)
+      info_ptr->channels = 1;
+   else if (info_ptr->color_type & PNG_COLOR_MASK_COLOR)
+      info_ptr->channels = 3;
+   else
+      info_ptr->channels = 1;
+
+#if defined(PNG_READ_STRIP_ALPHA_SUPPORTED)
+   if (png_ptr->transformations & PNG_STRIP_ALPHA)
+      info_ptr->color_type &= ~PNG_COLOR_MASK_ALPHA;
+#endif
+
+   if (info_ptr->color_type & PNG_COLOR_MASK_ALPHA)
+      info_ptr->channels++;
+
+#if defined(PNG_READ_FILLER_SUPPORTED)
+   /* STRIP_ALPHA and FILLER allowed:  MASK_ALPHA bit stripped above */
+   if ((png_ptr->transformations & PNG_FILLER) &&
+       ((info_ptr->color_type == PNG_COLOR_TYPE_RGB) ||
+       (info_ptr->color_type == PNG_COLOR_TYPE_GRAY)))
+   {
+      info_ptr->channels++;
+#if 0 /* if adding a true alpha channel not just filler */
+      info_ptr->color_type |= PNG_COLOR_MASK_ALPHA;
+#endif
+   }
+#endif
+
+#if defined(PNG_USER_TRANSFORM_PTR_SUPPORTED) && \
+defined(PNG_READ_USER_TRANSFORM_SUPPORTED)
+   if(png_ptr->transformations & PNG_USER_TRANSFORM)
+     {
+       if(info_ptr->bit_depth < png_ptr->user_transform_depth)
+         info_ptr->bit_depth = png_ptr->user_transform_depth;
+       if(info_ptr->channels < png_ptr->user_transform_channels)
+         info_ptr->channels = png_ptr->user_transform_channels;
+     }
+#endif
+
+   info_ptr->pixel_depth = (png_byte)(info_ptr->channels *
+      info_ptr->bit_depth);
+   info_ptr->rowbytes = ((info_ptr->width * info_ptr->pixel_depth + 7) >> 3);
+
+#if !defined(PNG_READ_EXPAND_SUPPORTED)
+   if(png_ptr)
+      return;
+#endif
+}
+
+/* Transform the row.  The order of transformations is significant,
+ * and is very touchy.  If you add a transformation, take care to
+ * decide how it fits in with the other transformations here.
+ */
+void /* PRIVATE */
+png_do_read_transformations(png_structp png_ptr)
+{
+   png_debug(1, "in png_do_read_transformations\n");
+#if !defined(PNG_USELESS_TESTS_SUPPORTED)
+   if (png_ptr->row_buf == NULL)
+   {
+#if !defined(PNG_NO_STDIO) && !defined(_WIN32_WCE)
+      char msg[50];
+
+      sprintf(msg, "NULL row buffer for row %ld, pass %d", png_ptr->row_number,
+         png_ptr->pass);
+      png_error(png_ptr, msg);
+#else
+      png_error(png_ptr, "NULL row buffer");
+#endif
+   }
+#endif
+
+#if defined(PNG_READ_EXPAND_SUPPORTED)
+   if (png_ptr->transformations & PNG_EXPAND)
+   {
+      if (png_ptr->row_info.color_type == PNG_COLOR_TYPE_PALETTE)
+      {
+         png_do_expand_palette(&(png_ptr->row_info), png_ptr->row_buf + 1,
+            png_ptr->palette, png_ptr->trans, png_ptr->num_trans);
+      }
+      else
+      {
+         if (png_ptr->num_trans)
+            png_do_expand(&(png_ptr->row_info), png_ptr->row_buf + 1,
+               &(png_ptr->trans_values));
+         else
+            png_do_expand(&(png_ptr->row_info), png_ptr->row_buf + 1,
+               NULL);
+      }
+   }
+#endif
+
+#if defined(PNG_READ_STRIP_ALPHA_SUPPORTED)
+   if (png_ptr->transformations & PNG_STRIP_ALPHA)
+      png_do_strip_filler(&(png_ptr->row_info), png_ptr->row_buf + 1,
+         PNG_FLAG_FILLER_AFTER);
+#endif
+
+#if defined(PNG_READ_RGB_TO_GRAY_SUPPORTED)
+   if (png_ptr->transformations & PNG_RGB_TO_GRAY)
+   {
+      int rgb_error =
+         png_do_rgb_to_gray(png_ptr, &(png_ptr->row_info), png_ptr->row_buf + 1);
+      if(rgb_error)
+      {
+         png_ptr->rgb_to_gray_status=1;
+         if(png_ptr->transformations == PNG_RGB_TO_GRAY_WARN)
+            png_warning(png_ptr, "png_do_rgb_to_gray found nongray pixel");
+         if(png_ptr->transformations == PNG_RGB_TO_GRAY_ERR)
+            png_error(png_ptr, "png_do_rgb_to_gray found nongray pixel");
+      }
+   }
+#endif
+
+/*
+From Andreas Dilger e-mail to png-implement, 26 March 1998:
+
+  In most cases, the "simple transparency" should be done prior to doing
+  gray-to-RGB, or you will have to test 3x as many bytes to check if a
+  pixel is transparent.  You would also need to make sure that the
+  transparency information is upgraded to RGB.
+
+  To summarize, the current flow is:
+  - Gray + simple transparency -> compare 1 or 2 gray bytes and composite
+                                  with background "in place" if transparent,
+                                  convert to RGB if necessary
+  - Gray + alpha -> composite with gray background and remove alpha bytes,
+                                  convert to RGB if necessary
+
+  To support RGB backgrounds for gray images we need:
+  - Gray + simple transparency -> convert to RGB + simple transparency, compare
+                                  3 or 6 bytes and composite with background
+                                  "in place" if transparent (3x compare/pixel
+                                  compared to doing composite with gray bkgrnd)
+  - Gray + alpha -> convert to RGB + alpha, composite with background and
+                                  remove alpha bytes (3x float operations/pixel
+                                  compared with composite on gray background)
+
+  Greg's change will do this.  The reason it wasn't done before is for
+  performance, as this increases the per-pixel operations.  If we would check
+  in advance if the background was gray or RGB, and position the gray-to-RGB
+  transform appropriately, then it would save a lot of work/time.
+ */
+
+#if defined(PNG_READ_GRAY_TO_RGB_SUPPORTED)
+   /* if gray -> RGB, do so now only if background is non-gray; else do later
+    * for performance reasons */
+   if ((png_ptr->transformations & PNG_GRAY_TO_RGB) &&
+       !(png_ptr->mode & PNG_BACKGROUND_IS_GRAY))
+      png_do_gray_to_rgb(&(png_ptr->row_info), png_ptr->row_buf + 1);
+#endif
+
+#if defined(PNG_READ_BACKGROUND_SUPPORTED)
+   if ((png_ptr->transformations & PNG_BACKGROUND) &&
+      ((png_ptr->num_trans != 0 ) ||
+      (png_ptr->color_type & PNG_COLOR_MASK_ALPHA)))
+      png_do_background(&(png_ptr->row_info), png_ptr->row_buf + 1,
+         &(png_ptr->trans_values), &(png_ptr->background)
+#if defined(PNG_READ_GAMMA_SUPPORTED)
+         , &(png_ptr->background_1),
+         png_ptr->gamma_table, png_ptr->gamma_from_1,
+         png_ptr->gamma_to_1, png_ptr->gamma_16_table,
+         png_ptr->gamma_16_from_1, png_ptr->gamma_16_to_1,
+         png_ptr->gamma_shift
+#endif
+);
+#endif
+
+#if defined(PNG_READ_GAMMA_SUPPORTED)
+   if ((png_ptr->transformations & PNG_GAMMA) &&
+#if defined(PNG_READ_BACKGROUND_SUPPORTED)
+      !((png_ptr->transformations & PNG_BACKGROUND) &&
+      ((png_ptr->num_trans != 0) ||
+      (png_ptr->color_type & PNG_COLOR_MASK_ALPHA))) &&
+#endif
+      (png_ptr->color_type != PNG_COLOR_TYPE_PALETTE))
+      png_do_gamma(&(png_ptr->row_info), png_ptr->row_buf + 1,
+         png_ptr->gamma_table, png_ptr->gamma_16_table,
+         png_ptr->gamma_shift);
+#endif
+
+#if defined(PNG_READ_16_TO_8_SUPPORTED)
+   if (png_ptr->transformations & PNG_16_TO_8)
+      png_do_chop(&(png_ptr->row_info), png_ptr->row_buf + 1);
+#endif
+
+#if defined(PNG_READ_DITHER_SUPPORTED)
+   if (png_ptr->transformations & PNG_DITHER)
+   {
+      png_do_dither((png_row_infop)&(png_ptr->row_info), png_ptr->row_buf + 1,
+         png_ptr->palette_lookup, png_ptr->dither_index);
+      if(png_ptr->row_info.rowbytes == (png_uint_32)0)
+         png_error(png_ptr, "png_do_dither returned rowbytes=0");
+   }
+#endif
+
+#if defined(PNG_READ_INVERT_SUPPORTED)
+   if (png_ptr->transformations & PNG_INVERT_MONO)
+      png_do_invert(&(png_ptr->row_info), png_ptr->row_buf + 1);
+#endif
+
+#if defined(PNG_READ_SHIFT_SUPPORTED)
+   if (png_ptr->transformations & PNG_SHIFT)
+      png_do_unshift(&(png_ptr->row_info), png_ptr->row_buf + 1,
+         &(png_ptr->shift));
+#endif
+
+#if defined(PNG_READ_PACK_SUPPORTED)
+   if (png_ptr->transformations & PNG_PACK)
+      png_do_unpack(&(png_ptr->row_info), png_ptr->row_buf + 1);
+#endif
+
+#if defined(PNG_READ_BGR_SUPPORTED)
+   if (png_ptr->transformations & PNG_BGR)
+      png_do_bgr(&(png_ptr->row_info), png_ptr->row_buf + 1);
+#endif
+
+#if defined(PNG_READ_PACKSWAP_SUPPORTED)
+   if (png_ptr->transformations & PNG_PACKSWAP)
+      png_do_packswap(&(png_ptr->row_info), png_ptr->row_buf + 1);
+#endif
+
+#if defined(PNG_READ_GRAY_TO_RGB_SUPPORTED)
+   /* if gray -> RGB, do so now only if we did not do so above */
+   if ((png_ptr->transformations & PNG_GRAY_TO_RGB) &&
+       (png_ptr->mode & PNG_BACKGROUND_IS_GRAY))
+      png_do_gray_to_rgb(&(png_ptr->row_info), png_ptr->row_buf + 1);
+#endif
+
+#if defined(PNG_READ_FILLER_SUPPORTED)
+   if (png_ptr->transformations & PNG_FILLER)
+      png_do_read_filler(&(png_ptr->row_info), png_ptr->row_buf + 1,
+         (png_uint_32)png_ptr->filler, png_ptr->flags);
+#endif
+
+#if defined(PNG_READ_INVERT_ALPHA_SUPPORTED)
+   if (png_ptr->transformations & PNG_INVERT_ALPHA)
+      png_do_read_invert_alpha(&(png_ptr->row_info), png_ptr->row_buf + 1);
+#endif
+
+#if defined(PNG_READ_SWAP_ALPHA_SUPPORTED)
+   if (png_ptr->transformations & PNG_SWAP_ALPHA)
+      png_do_read_swap_alpha(&(png_ptr->row_info), png_ptr->row_buf + 1);
+#endif
+
+#if defined(PNG_READ_SWAP_SUPPORTED)
+   if (png_ptr->transformations & PNG_SWAP_BYTES)
+      png_do_swap(&(png_ptr->row_info), png_ptr->row_buf + 1);
+#endif
+
+#if defined(PNG_READ_USER_TRANSFORM_SUPPORTED)
+   if (png_ptr->transformations & PNG_USER_TRANSFORM)
+    {
+      if(png_ptr->read_user_transform_fn != NULL)
+        (*(png_ptr->read_user_transform_fn)) /* user read transform function */
+          (png_ptr,                    /* png_ptr */
+           &(png_ptr->row_info),       /* row_info:     */
+             /*  png_uint_32 width;          width of row */
+             /*  png_uint_32 rowbytes;       number of bytes in row */
+             /*  png_byte color_type;        color type of pixels */
+             /*  png_byte bit_depth;         bit depth of samples */
+             /*  png_byte channels;          number of channels (1-4) */
+             /*  png_byte pixel_depth;       bits per pixel (depth*channels) */
+           png_ptr->row_buf + 1);      /* start of pixel data for row */
+#if defined(PNG_USER_TRANSFORM_PTR_SUPPORTED)
+      if(png_ptr->user_transform_depth)
+         png_ptr->row_info.bit_depth = png_ptr->user_transform_depth;
+      if(png_ptr->user_transform_channels)
+         png_ptr->row_info.channels = png_ptr->user_transform_channels;
+#endif
+      png_ptr->row_info.pixel_depth = (png_byte)(png_ptr->row_info.bit_depth *
+         png_ptr->row_info.channels);
+      png_ptr->row_info.rowbytes = (png_ptr->row_info.width *
+         png_ptr->row_info.pixel_depth+7)>>3;
+   }
+#endif
+
+}
+
+#if defined(PNG_READ_PACK_SUPPORTED)
+/* Unpack pixels of 1, 2, or 4 bits per pixel into 1 byte per pixel,
+ * without changing the actual values.  Thus, if you had a row with
+ * a bit depth of 1, you would end up with bytes that only contained
+ * the numbers 0 or 1.  If you would rather they contain 0 and 255, use
+ * png_do_shift() after this.
+ */
+void /* PRIVATE */
+png_do_unpack(png_row_infop row_info, png_bytep row)
+{
+   png_debug(1, "in png_do_unpack\n");
+#if defined(PNG_USELESS_TESTS_SUPPORTED)
+   if (row != NULL && row_info != NULL && row_info->bit_depth < 8)
+#else
+   if (row_info->bit_depth < 8)
+#endif
+   {
+      png_uint_32 i;
+      png_uint_32 row_width=row_info->width;
+
+      switch (row_info->bit_depth)
+      {
+         case 1:
+         {
+            png_bytep sp = row + (png_size_t)((row_width - 1) >> 3);
+            png_bytep dp = row + (png_size_t)row_width - 1;
+            png_uint_32 shift = 7 - (int)((row_width + 7) & 0x07);
+            for (i = 0; i < row_width; i++)
+            {
+               *dp = (png_byte)((*sp >> shift) & 0x01);
+               if (shift == 7)
+               {
+                  shift = 0;
+                  sp--;
+               }
+               else
+                  shift++;
+
+               dp--;
+            }
+            break;
+         }
+         case 2:
+         {
+
+            png_bytep sp = row + (png_size_t)((row_width - 1) >> 2);
+            png_bytep dp = row + (png_size_t)row_width - 1;
+            png_uint_32 shift = (int)((3 - ((row_width + 3) & 0x03)) << 1);
+            for (i = 0; i < row_width; i++)
+            {
+               *dp = (png_byte)((*sp >> shift) & 0x03);
+               if (shift == 6)
+               {
+                  shift = 0;
+                  sp--;
+               }
+               else
+                  shift += 2;
+
+               dp--;
+            }
+            break;
+         }
+         case 4:
+         {
+            png_bytep sp = row + (png_size_t)((row_width - 1) >> 1);
+            png_bytep dp = row + (png_size_t)row_width - 1;
+            png_uint_32 shift = (int)((1 - ((row_width + 1) & 0x01)) << 2);
+            for (i = 0; i < row_width; i++)
+            {
+               *dp = (png_byte)((*sp >> shift) & 0x0f);
+               if (shift == 4)
+               {
+                  shift = 0;
+                  sp--;
+               }
+               else
+                  shift = 4;
+
+               dp--;
+            }
+            break;
+         }
+      }
+      row_info->bit_depth = 8;
+      row_info->pixel_depth = (png_byte)(8 * row_info->channels);
+      row_info->rowbytes = row_width * row_info->channels;
+   }
+}
+#endif
+
+#if defined(PNG_READ_SHIFT_SUPPORTED)
+/* Reverse the effects of png_do_shift.  This routine merely shifts the
+ * pixels back to their significant bits values.  Thus, if you have
+ * a row of bit depth 8, but only 5 are significant, this will shift
+ * the values back to 0 through 31.
+ */
+void /* PRIVATE */
+png_do_unshift(png_row_infop row_info, png_bytep row, png_color_8p sig_bits)
+{
+   png_debug(1, "in png_do_unshift\n");
+   if (
+#if defined(PNG_USELESS_TESTS_SUPPORTED)
+       row != NULL && row_info != NULL && sig_bits != NULL &&
+#endif
+       row_info->color_type != PNG_COLOR_TYPE_PALETTE)
+   {
+      int shift[4];
+      int channels = 0;
+      int c;
+      png_uint_16 value = 0;
+      png_uint_32 row_width = row_info->width;
+
+      if (row_info->color_type & PNG_COLOR_MASK_COLOR)
+      {
+         shift[channels++] = row_info->bit_depth - sig_bits->red;
+         shift[channels++] = row_info->bit_depth - sig_bits->green;
+         shift[channels++] = row_info->bit_depth - sig_bits->blue;
+      }
+      else
+      {
+         shift[channels++] = row_info->bit_depth - sig_bits->gray;
+      }
+      if (row_info->color_type & PNG_COLOR_MASK_ALPHA)
+      {
+         shift[channels++] = row_info->bit_depth - sig_bits->alpha;
+      }
+
+      for (c = 0; c < channels; c++)
+      {
+         if (shift[c] <= 0)
+            shift[c] = 0;
+         else
+            value = 1;
+      }
+
+      if (!value)
+         return;
+
+      switch (row_info->bit_depth)
+      {
+         case 2:
+         {
+            png_bytep bp;
+            png_uint_32 i;
+            png_uint_32 istop = row_info->rowbytes;
+
+            for (bp = row, i = 0; i < istop; i++)
+            {
+               *bp >>= 1;
+               *bp++ &= 0x55;
+            }
+            break;
+         }
+         case 4:
+         {
+            png_bytep bp = row;
+            png_uint_32 i;
+            png_uint_32 istop = row_info->rowbytes;
+            png_byte mask = (png_byte)((((int)0xf0 >> shift[0]) & (int)0xf0) |
+               (png_byte)((int)0xf >> shift[0]));
+
+            for (i = 0; i < istop; i++)
+            {
+               *bp >>= shift[0];
+               *bp++ &= mask;
+            }
+            break;
+         }
+         case 8:
+         {
+            png_bytep bp = row;
+            png_uint_32 i;
+            png_uint_32 istop = row_width * channels;
+
+            for (i = 0; i < istop; i++)
+            {
+               *bp++ >>= shift[i%channels];
+            }
+            break;
+         }
+         case 16:
+         {
+            png_bytep bp = row;
+            png_uint_32 i;
+            png_uint_32 istop = channels * row_width;
+
+            for (i = 0; i < istop; i++)
+            {
+               value = (png_uint_16)((*bp << 8) + *(bp + 1));
+               value >>= shift[i%channels];
+               *bp++ = (png_byte)(value >> 8);
+               *bp++ = (png_byte)(value & 0xff);
+            }
+            break;
+         }
+      }
+   }
+}
+#endif
+
+#if defined(PNG_READ_16_TO_8_SUPPORTED)
+/* chop rows of bit depth 16 down to 8 */
+void /* PRIVATE */
+png_do_chop(png_row_infop row_info, png_bytep row)
+{
+   png_debug(1, "in png_do_chop\n");
+#if defined(PNG_USELESS_TESTS_SUPPORTED)
+   if (row != NULL && row_info != NULL && row_info->bit_depth == 16)
+#else
+   if (row_info->bit_depth == 16)
+#endif
+   {
+      png_bytep sp = row;
+      png_bytep dp = row;
+      png_uint_32 i;
+      png_uint_32 istop = row_info->width * row_info->channels;
+
+      for (i = 0; i<istop; i++, sp += 2, dp++)
+      {
+#if defined(PNG_READ_16_TO_8_ACCURATE_SCALE_SUPPORTED)
+      /* This does a more accurate scaling of the 16-bit color
+       * value, rather than a simple low-byte truncation.
+       *
+       * What the ideal calculation should be:
+       *   *dp = (((((png_uint_32)(*sp) << 8) |
+       *          (png_uint_32)(*(sp + 1))) * 255 + 127) / (png_uint_32)65535L;
+       *
+       * GRR: no, I think this is what it really should be:
+       *   *dp = (((((png_uint_32)(*sp) << 8) |
+       *           (png_uint_32)(*(sp + 1))) + 128L) / (png_uint_32)257L;
+       *
+       * GRR: here's the exact calculation with shifts:
+       *   temp = (((png_uint_32)(*sp) << 8) | (png_uint_32)(*(sp + 1))) + 128L;
+       *   *dp = (temp - (temp >> 8)) >> 8;
+       *
+       * Approximate calculation with shift/add instead of multiply/divide:
+       *   *dp = ((((png_uint_32)(*sp) << 8) |
+       *          (png_uint_32)((int)(*(sp + 1)) - *sp)) + 128) >> 8;
+       *
+       * What we actually do to avoid extra shifting and conversion:
+       */
+
+         *dp = *sp + ((((int)(*(sp + 1)) - *sp) > 128) ? 1 : 0);
+#else
+       /* Simply discard the low order byte */
+         *dp = *sp;
+#endif
+      }
+      row_info->bit_depth = 8;
+      row_info->pixel_depth = (png_byte)(8 * row_info->channels);
+      row_info->rowbytes = row_info->width * row_info->channels;
+   }
+}
+#endif
+
+#if defined(PNG_READ_SWAP_ALPHA_SUPPORTED)
+void /* PRIVATE */
+png_do_read_swap_alpha(png_row_infop row_info, png_bytep row)
+{
+   png_debug(1, "in png_do_read_swap_alpha\n");
+#if defined(PNG_USELESS_TESTS_SUPPORTED)
+   if (row != NULL && row_info != NULL)
+#endif
+   {
+      png_uint_32 row_width = row_info->width;
+      if (row_info->color_type == PNG_COLOR_TYPE_RGB_ALPHA)
+      {
+         /* This converts from RGBA to ARGB */
+         if (row_info->bit_depth == 8)
+         {
+            png_bytep sp = row + row_info->rowbytes;
+            png_bytep dp = sp;
+            png_byte save;
+            png_uint_32 i;
+
+            for (i = 0; i < row_width; i++)
+            {
+               save = *(--sp);
+               *(--dp) = *(--sp);
+               *(--dp) = *(--sp);
+               *(--dp) = *(--sp);
+               *(--dp) = save;
+            }
+         }
+         /* This converts from RRGGBBAA to AARRGGBB */
+         else
+         {
+            png_bytep sp = row + row_info->rowbytes;
+            png_bytep dp = sp;
+            png_byte save[2];
+            png_uint_32 i;
+
+            for (i = 0; i < row_width; i++)
+            {
+               save[0] = *(--sp);
+               save[1] = *(--sp);
+               *(--dp) = *(--sp);
+               *(--dp) = *(--sp);
+               *(--dp) = *(--sp);
+               *(--dp) = *(--sp);
+               *(--dp) = *(--sp);
+               *(--dp) = *(--sp);
+               *(--dp) = save[0];
+               *(--dp) = save[1];
+            }
+         }
+      }
+      else if (row_info->color_type == PNG_COLOR_TYPE_GRAY_ALPHA)
+      {
+         /* This converts from GA to AG */
+         if (row_info->bit_depth == 8)
+         {
+            png_bytep sp = row + row_info->rowbytes;
+            png_bytep dp = sp;
+            png_byte save;
+            png_uint_32 i;
+
+            for (i = 0; i < row_width; i++)
+            {
+               save = *(--sp);
+               *(--dp) = *(--sp);
+               *(--dp) = save;
+            }
+         }
+         /* This converts from GGAA to AAGG */
+         else
+         {
+            png_bytep sp = row + row_info->rowbytes;
+            png_bytep dp = sp;
+            png_byte save[2];
+            png_uint_32 i;
+
+            for (i = 0; i < row_width; i++)
+            {
+               save[0] = *(--sp);
+               save[1] = *(--sp);
+               *(--dp) = *(--sp);
+               *(--dp) = *(--sp);
+               *(--dp) = save[0];
+               *(--dp) = save[1];
+            }
+         }
+      }
+   }
+}
+#endif
+
+#if defined(PNG_READ_INVERT_ALPHA_SUPPORTED)
+void /* PRIVATE */
+png_do_read_invert_alpha(png_row_infop row_info, png_bytep row)
+{
+   png_debug(1, "in png_do_read_invert_alpha\n");
+#if defined(PNG_USELESS_TESTS_SUPPORTED)
+   if (row != NULL && row_info != NULL)
+#endif
+   {
+      png_uint_32 row_width = row_info->width;
+      if (row_info->color_type == PNG_COLOR_TYPE_RGB_ALPHA)
+      {
+         /* This inverts the alpha channel in RGBA */
+         if (row_info->bit_depth == 8)
+         {
+            png_bytep sp = row + row_info->rowbytes;
+            png_bytep dp = sp;
+            png_uint_32 i;
+
+            for (i = 0; i < row_width; i++)
+            {
+               *(--dp) = (png_byte)(255 - *(--sp));
+
+/*             This does nothing:
+               *(--dp) = *(--sp);
+               *(--dp) = *(--sp);
+               *(--dp) = *(--sp);
+               We can replace it with:
+*/
+               sp-=3;
+               dp=sp;
+            }
+         }
+         /* This inverts the alpha channel in RRGGBBAA */
+         else
+         {
+            png_bytep sp = row + row_info->rowbytes;
+            png_bytep dp = sp;
+            png_uint_32 i;
+
+            for (i = 0; i < row_width; i++)
+            {
+               *(--dp) = (png_byte)(255 - *(--sp));
+               *(--dp) = (png_byte)(255 - *(--sp));
+
+/*             This does nothing:
+               *(--dp) = *(--sp);
+               *(--dp) = *(--sp);
+               *(--dp) = *(--sp);
+               *(--dp) = *(--sp);
+               *(--dp) = *(--sp);
+               *(--dp) = *(--sp);
+               We can replace it with:
+*/
+               sp-=6;
+               dp=sp;
+            }
+         }
+      }
+      else if (row_info->color_type == PNG_COLOR_TYPE_GRAY_ALPHA)
+      {
+         /* This inverts the alpha channel in GA */
+         if (row_info->bit_depth == 8)
+         {
+            png_bytep sp = row + row_info->rowbytes;
+            png_bytep dp = sp;
+            png_uint_32 i;
+
+            for (i = 0; i < row_width; i++)
+            {
+               *(--dp) = (png_byte)(255 - *(--sp));
+               *(--dp) = *(--sp);
+            }
+         }
+         /* This inverts the alpha channel in GGAA */
+         else
+         {
+            png_bytep sp  = row + row_info->rowbytes;
+            png_bytep dp = sp;
+            png_uint_32 i;
+
+            for (i = 0; i < row_width; i++)
+            {
+               *(--dp) = (png_byte)(255 - *(--sp));
+               *(--dp) = (png_byte)(255 - *(--sp));
+/*
+               *(--dp) = *(--sp);
+               *(--dp) = *(--sp);
+*/
+               sp-=2;
+               dp=sp;
+            }
+         }
+      }
+   }
+}
+#endif
+
+#if defined(PNG_READ_FILLER_SUPPORTED)
+/* Add filler channel if we have RGB color */
+void /* PRIVATE */
+png_do_read_filler(png_row_infop row_info, png_bytep row,
+   png_uint_32 filler, png_uint_32 flags)
+{
+   png_uint_32 i;
+   png_uint_32 row_width = row_info->width;
+
+   png_byte hi_filler = (png_byte)((filler>>8) & 0xff);
+   png_byte lo_filler = (png_byte)(filler & 0xff);
+
+   png_debug(1, "in png_do_read_filler\n");
+   if (
+#if defined(PNG_USELESS_TESTS_SUPPORTED)
+       row != NULL  && row_info != NULL &&
+#endif
+       row_info->color_type == PNG_COLOR_TYPE_GRAY)
+   {
+      if(row_info->bit_depth == 8)
+      {
+         /* This changes the data from G to GX */
+         if (flags & PNG_FLAG_FILLER_AFTER)
+         {
+            png_bytep sp = row + (png_size_t)row_width;
+            png_bytep dp =  sp + (png_size_t)row_width;
+            for (i = 1; i < row_width; i++)
+            {
+               *(--dp) = lo_filler;
+               *(--dp) = *(--sp);
+            }
+            *(--dp) = lo_filler;
+            row_info->channels = 2;
+            row_info->pixel_depth = 16;
+            row_info->rowbytes = row_width * 2;
+         }
+      /* This changes the data from G to XG */
+         else
+         {
+            png_bytep sp = row + (png_size_t)row_width;
+            png_bytep dp = sp  + (png_size_t)row_width;
+            for (i = 0; i < row_width; i++)
+            {
+               *(--dp) = *(--sp);
+               *(--dp) = lo_filler;
+            }
+            row_info->channels = 2;
+            row_info->pixel_depth = 16;
+            row_info->rowbytes = row_width * 2;
+         }
+      }
+      else if(row_info->bit_depth == 16)
+      {
+         /* This changes the data from GG to GGXX */
+         if (flags & PNG_FLAG_FILLER_AFTER)
+         {
+            png_bytep sp = row + (png_size_t)row_width;
+            png_bytep dp = sp  + (png_size_t)row_width;
+            for (i = 1; i < row_width; i++)
+            {
+               *(--dp) = hi_filler;
+               *(--dp) = lo_filler;
+               *(--dp) = *(--sp);
+               *(--dp) = *(--sp);
+            }
+            *(--dp) = hi_filler;
+            *(--dp) = lo_filler;
+            row_info->channels = 2;
+            row_info->pixel_depth = 32;
+            row_info->rowbytes = row_width * 4;
+         }
+         /* This changes the data from GG to XXGG */
+         else
+         {
+            png_bytep sp = row + (png_size_t)row_width;
+            png_bytep dp = sp  + (png_size_t)row_width;
+            for (i = 0; i < row_width; i++)
+            {
+               *(--dp) = *(--sp);
+               *(--dp) = *(--sp);
+               *(--dp) = hi_filler;
+               *(--dp) = lo_filler;
+            }
+            row_info->channels = 2;
+            row_info->pixel_depth = 32;
+            row_info->rowbytes = row_width * 4;
+         }
+      }
+   } /* COLOR_TYPE == GRAY */
+   else if (row_info->color_type == PNG_COLOR_TYPE_RGB)
+   {
+      if(row_info->bit_depth == 8)
+      {
+         /* This changes the data from RGB to RGBX */
+         if (flags & PNG_FLAG_FILLER_AFTER)
+         {
+            png_bytep sp = row + (png_size_t)row_width * 3;
+            png_bytep dp = sp  + (png_size_t)row_width;
+            for (i = 1; i < row_width; i++)
+            {
+               *(--dp) = lo_filler;
+               *(--dp) = *(--sp);
+               *(--dp) = *(--sp);
+               *(--dp) = *(--sp);
+            }
+            *(--dp) = lo_filler;
+            row_info->channels = 4;
+            row_info->pixel_depth = 32;
+            row_info->rowbytes = row_width * 4;
+         }
+      /* This changes the data from RGB to XRGB */
+         else
+         {
+            png_bytep sp = row + (png_size_t)row_width * 3;
+            png_bytep dp = sp + (png_size_t)row_width;
+            for (i = 0; i < row_width; i++)
+            {
+               *(--dp) = *(--sp);
+               *(--dp) = *(--sp);
+               *(--dp) = *(--sp);
+               *(--dp) = lo_filler;
+            }
+            row_info->channels = 4;
+            row_info->pixel_depth = 32;
+            row_info->rowbytes = row_width * 4;
+         }
+      }
+      else if(row_info->bit_depth == 16)
+      {
+         /* This changes the data from RRGGBB to RRGGBBXX */
+         if (flags & PNG_FLAG_FILLER_AFTER)
+         {
+            png_bytep sp = row + (png_size_t)row_width * 3;
+            png_bytep dp = sp  + (png_size_t)row_width;
+            for (i = 1; i < row_width; i++)
+            {
+               *(--dp) = hi_filler;
+               *(--dp) = lo_filler;
+               *(--dp) = *(--sp);
+               *(--dp) = *(--sp);
+               *(--dp) = *(--sp);
+               *(--dp) = *(--sp);
+               *(--dp) = *(--sp);
+               *(--dp) = *(--sp);
+            }
+            *(--dp) = hi_filler;
+            *(--dp) = lo_filler;
+            row_info->channels = 4;
+            row_info->pixel_depth = 64;
+            row_info->rowbytes = row_width * 8;
+         }
+         /* This changes the data from RRGGBB to XXRRGGBB */
+         else
+         {
+            png_bytep sp = row + (png_size_t)row_width * 3;
+            png_bytep dp = sp  + (png_size_t)row_width;
+            for (i = 0; i < row_width; i++)
+            {
+               *(--dp) = *(--sp);
+               *(--dp) = *(--sp);
+               *(--dp) = *(--sp);
+               *(--dp) = *(--sp);
+               *(--dp) = *(--sp);
+               *(--dp) = *(--sp);
+               *(--dp) = hi_filler;
+               *(--dp) = lo_filler;
+            }
+            row_info->channels = 4;
+            row_info->pixel_depth = 64;
+            row_info->rowbytes = row_width * 8;
+         }
+      }
+   } /* COLOR_TYPE == RGB */
+}
+#endif
+
+#if defined(PNG_READ_GRAY_TO_RGB_SUPPORTED)
+/* expand grayscale files to RGB, with or without alpha */
+void /* PRIVATE */
+png_do_gray_to_rgb(png_row_infop row_info, png_bytep row)
+{
+   png_uint_32 i;
+   png_uint_32 row_width = row_info->width;
+
+   png_debug(1, "in png_do_gray_to_rgb\n");
+   if (row_info->bit_depth >= 8 &&
+#if defined(PNG_USELESS_TESTS_SUPPORTED)
+       row != NULL && row_info != NULL &&
+#endif
+      !(row_info->color_type & PNG_COLOR_MASK_COLOR))
+   {
+      if (row_info->color_type == PNG_COLOR_TYPE_GRAY)
+      {
+         if (row_info->bit_depth == 8)
+         {
+            png_bytep sp = row + (png_size_t)row_width - 1;
+            png_bytep dp = sp  + (png_size_t)row_width * 2;
+            for (i = 0; i < row_width; i++)
+            {
+               *(dp--) = *sp;
+               *(dp--) = *sp;
+               *(dp--) = *(sp--);
+            }
+         }
+         else
+         {
+            png_bytep sp = row + (png_size_t)row_width * 2 - 1;
+            png_bytep dp = sp  + (png_size_t)row_width * 4;
+            for (i = 0; i < row_width; i++)
+            {
+               *(dp--) = *sp;
+               *(dp--) = *(sp - 1);
+               *(dp--) = *sp;
+               *(dp--) = *(sp - 1);
+               *(dp--) = *(sp--);
+               *(dp--) = *(sp--);
+            }
+         }
+      }
+      else if (row_info->color_type == PNG_COLOR_TYPE_GRAY_ALPHA)
+      {
+         if (row_info->bit_depth == 8)
+         {
+            png_bytep sp = row + (png_size_t)row_width * 2 - 1;
+            png_bytep dp = sp  + (png_size_t)row_width * 2;
+            for (i = 0; i < row_width; i++)
+            {
+               *(dp--) = *(sp--);
+               *(dp--) = *sp;
+               *(dp--) = *sp;
+               *(dp--) = *(sp--);
+            }
+         }
+         else
+         {
+            png_bytep sp = row + (png_size_t)row_width * 4 - 1;
+            png_bytep dp = sp  + (png_size_t)row_width * 4;
+            for (i = 0; i < row_width; i++)
+            {
+               *(dp--) = *(sp--);
+               *(dp--) = *(sp--);
+               *(dp--) = *sp;
+               *(dp--) = *(sp - 1);
+               *(dp--) = *sp;
+               *(dp--) = *(sp - 1);
+               *(dp--) = *(sp--);
+               *(dp--) = *(sp--);
+            }
+         }
+      }
+      row_info->channels += (png_byte)2;
+      row_info->color_type |= PNG_COLOR_MASK_COLOR;
+      row_info->pixel_depth = (png_byte)(row_info->channels *
+         row_info->bit_depth);
+      row_info->rowbytes = ((row_width *
+         row_info->pixel_depth + 7) >> 3);
+   }
+}
+#endif
+
+#if defined(PNG_READ_RGB_TO_GRAY_SUPPORTED)
+/* reduce RGB files to grayscale, with or without alpha
+ * using the equation given in Poynton's ColorFAQ at
+ * <http://www.inforamp.net/~poynton/>
+ * Copyright (c) 1998-01-04 Charles Poynton poynton@inforamp.net
+ *
+ *     Y = 0.212671 * R + 0.715160 * G + 0.072169 * B
+ *
+ *  We approximate this with
+ *
+ *     Y = 0.21268 * R    + 0.7151 * G    + 0.07217 * B
+ *
+ *  which can be expressed with integers as
+ *
+ *     Y = (6969 * R + 23434 * G + 2365 * B)/32768
+ *
+ *  The calculation is to be done in a linear colorspace.
+ *
+ *  Other integer coefficents can be used via png_set_rgb_to_gray().
+ */
+int /* PRIVATE */
+png_do_rgb_to_gray(png_structp png_ptr, png_row_infop row_info, png_bytep row)
+
+{
+   png_uint_32 i;
+
+   png_uint_32 row_width = row_info->width;
+   int rgb_error = 0;
+
+   png_debug(1, "in png_do_rgb_to_gray\n");
+   if (
+#if defined(PNG_USELESS_TESTS_SUPPORTED)
+       row != NULL && row_info != NULL &&
+#endif
+      (row_info->color_type & PNG_COLOR_MASK_COLOR))
+   {
+      png_uint_32 rc = png_ptr->rgb_to_gray_red_coeff;
+      png_uint_32 gc = png_ptr->rgb_to_gray_green_coeff;
+      png_uint_32 bc = png_ptr->rgb_to_gray_blue_coeff;
+
+      if (row_info->color_type == PNG_COLOR_TYPE_RGB)
+      {
+         if (row_info->bit_depth == 8)
+         {
+#if defined(PNG_READ_GAMMA_SUPPORTED) || defined(PNG_READ_BACKGROUND_SUPPORTED)
+            if (png_ptr->gamma_from_1 != NULL && png_ptr->gamma_to_1 != NULL)
+            {
+               png_bytep sp = row;
+               png_bytep dp = row;
+
+               for (i = 0; i < row_width; i++)
+               {
+                  png_byte red   = png_ptr->gamma_to_1[*(sp++)];
+                  png_byte green = png_ptr->gamma_to_1[*(sp++)];
+                  png_byte blue  = png_ptr->gamma_to_1[*(sp++)];
+                  if(red != green || red != blue)
+                  {
+                     rgb_error |= 1;
+                     *(dp++) = png_ptr->gamma_from_1[
+                       (rc*red+gc*green+bc*blue)>>15];
+                  }
+                  else
+                     *(dp++) = *(sp-1);
+               }
+            }
+            else
+#endif
+            {
+               png_bytep sp = row;
+               png_bytep dp = row;
+               for (i = 0; i < row_width; i++)
+               {
+                  png_byte red   = *(sp++);
+                  png_byte green = *(sp++);
+                  png_byte blue  = *(sp++);
+                  if(red != green || red != blue)
+                  {
+                     rgb_error |= 1;
+                     *(dp++) = (png_byte)((rc*red+gc*green+bc*blue)>>15);
+                  }
+                  else
+                     *(dp++) = *(sp-1);
+               }
+            }
+         }
+
+         else /* RGB bit_depth == 16 */
+         {
+#if defined(PNG_READ_GAMMA_SUPPORTED) || defined(PNG_READ_BACKGROUND_SUPPORTED)
+            if (png_ptr->gamma_16_to_1 != NULL &&
+                png_ptr->gamma_16_from_1 != NULL)
+            {
+               png_bytep sp = row;
+               png_bytep dp = row;
+               for (i = 0; i < row_width; i++)
+               {
+                  png_uint_16 red, green, blue, w;
+
+                  red   = (png_uint_16)(((*(sp))<<8) | *(sp+1)); sp+=2;
+                  green = (png_uint_16)(((*(sp))<<8) | *(sp+1)); sp+=2;
+                  blue  = (png_uint_16)(((*(sp))<<8) | *(sp+1)); sp+=2;
+
+                  if(red == green && red == blue)
+                     w = red;
+                  else
+                  {
+                     png_uint_16 red_1   = png_ptr->gamma_16_to_1[(red&0xff) >>
+                                  png_ptr->gamma_shift][red>>8];
+                     png_uint_16 green_1 = png_ptr->gamma_16_to_1[(green&0xff) >>
+                                  png_ptr->gamma_shift][green>>8];
+                     png_uint_16 blue_1  = png_ptr->gamma_16_to_1[(blue&0xff) >>
+                                  png_ptr->gamma_shift][blue>>8];
+                     png_uint_16 gray16  = (png_uint_16)((rc*red_1 + gc*green_1
+                                  + bc*blue_1)>>15);
+                     w = png_ptr->gamma_16_from_1[(gray16&0xff) >>
+                         png_ptr->gamma_shift][gray16 >> 8];
+                     rgb_error |= 1;
+                  }
+
+                  *(dp++) = (png_byte)((w>>8) & 0xff);
+                  *(dp++) = (png_byte)(w & 0xff);
+               }
+            }
+            else
+#endif
+            {
+               png_bytep sp = row;
+               png_bytep dp = row;
+               for (i = 0; i < row_width; i++)
+               {
+                  png_uint_16 red, green, blue, gray16;
+
+                  red   = (png_uint_16)(((*(sp))<<8) | *(sp+1)); sp+=2;
+                  green = (png_uint_16)(((*(sp))<<8) | *(sp+1)); sp+=2;
+                  blue  = (png_uint_16)(((*(sp))<<8) | *(sp+1)); sp+=2;
+
+                  if(red != green || red != blue)
+                     rgb_error |= 1;
+                  gray16  = (png_uint_16)((rc*red + gc*green + bc*blue)>>15);
+                  *(dp++) = (png_byte)((gray16>>8) & 0xff);
+                  *(dp++) = (png_byte)(gray16 & 0xff);
+               }
+            }
+         }
+      }
+      if (row_info->color_type == PNG_COLOR_TYPE_RGB_ALPHA)
+      {
+         if (row_info->bit_depth == 8)
+         {
+#if defined(PNG_READ_GAMMA_SUPPORTED) || defined(PNG_READ_BACKGROUND_SUPPORTED)
+            if (png_ptr->gamma_from_1 != NULL && png_ptr->gamma_to_1 != NULL)
+            {
+               png_bytep sp = row;
+               png_bytep dp = row;
+               for (i = 0; i < row_width; i++)
+               {
+                  png_byte red   = png_ptr->gamma_to_1[*(sp++)];
+                  png_byte green = png_ptr->gamma_to_1[*(sp++)];
+                  png_byte blue  = png_ptr->gamma_to_1[*(sp++)];
+                  if(red != green || red != blue)
+                     rgb_error |= 1;
+                  *(dp++) =  png_ptr->gamma_from_1
+                             [(rc*red + gc*green + bc*blue)>>15];
+                  *(dp++) = *(sp++);  /* alpha */
+               }
+            }
+            else
+#endif
+            {
+               png_bytep sp = row;
+               png_bytep dp = row;
+               for (i = 0; i < row_width; i++)
+               {
+                  png_byte red   = *(sp++);
+                  png_byte green = *(sp++);
+                  png_byte blue  = *(sp++);
+                  if(red != green || red != blue)
+                     rgb_error |= 1;
+                  *(dp++) =  (png_byte)((gc*red + gc*green + bc*blue)>>8);
+                  *(dp++) = *(sp++);  /* alpha */
+               }
+            }
+         }
+         else /* RGBA bit_depth == 16 */
+         {
+#if defined(PNG_READ_GAMMA_SUPPORTED) || defined(PNG_READ_BACKGROUND_SUPPORTED)
+            if (png_ptr->gamma_16_to_1 != NULL &&
+                png_ptr->gamma_16_from_1 != NULL)
+            {
+               png_bytep sp = row;
+               png_bytep dp = row;
+               for (i = 0; i < row_width; i++)
+               {
+                  png_uint_16 red, green, blue, w;
+
+                  red   = (png_uint_16)(((*(sp))<<8) | *(sp+1)); sp+=2;
+                  green = (png_uint_16)(((*(sp))<<8) | *(sp+1)); sp+=2;
+                  blue  = (png_uint_16)(((*(sp))<<8) | *(sp+1)); sp+=2;
+
+                  if(red == green && red == blue)
+                     w = red;
+                  else
+                  {
+                     png_uint_16 red_1   = png_ptr->gamma_16_to_1[(red&0xff) >>
+                                  png_ptr->gamma_shift][red>>8];
+                     png_uint_16 green_1 = png_ptr->gamma_16_to_1[(green&0xff) >>
+                                  png_ptr->gamma_shift][green>>8];
+                     png_uint_16 blue_1  = png_ptr->gamma_16_to_1[(blue&0xff) >>
+                                  png_ptr->gamma_shift][blue>>8];
+                     png_uint_16 gray16  = (png_uint_16)((rc * red_1
+                                  + gc * green_1 + bc * blue_1)>>15);
+                     w = png_ptr->gamma_16_from_1[(gray16&0xff) >>
+                         png_ptr->gamma_shift][gray16 >> 8];
+                     rgb_error |= 1;
+                  }
+
+                  *(dp++) = (png_byte)((w>>8) & 0xff);
+                  *(dp++) = (png_byte)(w & 0xff);
+                  *(dp++) = *(sp++);  /* alpha */
+                  *(dp++) = *(sp++);
+               }
+            }
+            else
+#endif
+            {
+               png_bytep sp = row;
+               png_bytep dp = row;
+               for (i = 0; i < row_width; i++)
+               {
+                  png_uint_16 red, green, blue, gray16;
+                  red   = (png_uint_16)((*(sp)<<8) | *(sp+1)); sp+=2;
+                  green = (png_uint_16)((*(sp)<<8) | *(sp+1)); sp+=2;
+                  blue  = (png_uint_16)((*(sp)<<8) | *(sp+1)); sp+=2;
+                  if(red != green || red != blue)
+                     rgb_error |= 1;
+                  gray16  = (png_uint_16)((rc*red + gc*green + bc*blue)>>15);
+                  *(dp++) = (png_byte)((gray16>>8) & 0xff);
+                  *(dp++) = (png_byte)(gray16 & 0xff);
+                  *(dp++) = *(sp++);  /* alpha */
+                  *(dp++) = *(sp++);
+               }
+            }
+         }
+      }
+   row_info->channels -= (png_byte)2;
+      row_info->color_type &= ~PNG_COLOR_MASK_COLOR;
+      row_info->pixel_depth = (png_byte)(row_info->channels *
+         row_info->bit_depth);
+      row_info->rowbytes = ((row_width *
+         row_info->pixel_depth + 7) >> 3);
+   }
+   return rgb_error;
+}
+#endif
+
+/* Build a grayscale palette.  Palette is assumed to be 1 << bit_depth
+ * large of png_color.  This lets grayscale images be treated as
+ * paletted.  Most useful for gamma correction and simplification
+ * of code.
+ */
+void PNGAPI
+png_build_grayscale_palette(int bit_depth, png_colorp palette)
+{
+   int num_palette;
+   int color_inc;
+   int i;
+   int v;
+
+   png_debug(1, "in png_do_build_grayscale_palette\n");
+   if (palette == NULL)
+      return;
+
+   switch (bit_depth)
+   {
+      case 1:
+         num_palette = 2;
+         color_inc = 0xff;
+         break;
+      case 2:
+         num_palette = 4;
+         color_inc = 0x55;
+         break;
+      case 4:
+         num_palette = 16;
+         color_inc = 0x11;
+         break;
+      case 8:
+         num_palette = 256;
+         color_inc = 1;
+         break;
+      default:
+         num_palette = 0;
+         color_inc = 0;
+         break;
+   }
+
+   for (i = 0, v = 0; i < num_palette; i++, v += color_inc)
+   {
+      palette[i].red = (png_byte)v;
+      palette[i].green = (png_byte)v;
+      palette[i].blue = (png_byte)v;
+   }
+}
+
+/* This function is currently unused.  Do we really need it? */
+#if defined(PNG_READ_DITHER_SUPPORTED) && defined(PNG_CORRECT_PALETTE_SUPPORTED)
+void /* PRIVATE */
+png_correct_palette(png_structp png_ptr, png_colorp palette,
+   int num_palette)
+{
+   png_debug(1, "in png_correct_palette\n");
+#if defined(PNG_READ_BACKGROUND_SUPPORTED) && \
+    defined(PNG_READ_GAMMA_SUPPORTED) && defined(PNG_FLOATING_POINT_SUPPORTED)
+   if (png_ptr->transformations & (PNG_GAMMA | PNG_BACKGROUND))
+   {
+      png_color back, back_1;
+
+      if (png_ptr->background_gamma_type == PNG_BACKGROUND_GAMMA_FILE)
+      {
+         back.red = png_ptr->gamma_table[png_ptr->background.red];
+         back.green = png_ptr->gamma_table[png_ptr->background.green];
+         back.blue = png_ptr->gamma_table[png_ptr->background.blue];
+
+         back_1.red = png_ptr->gamma_to_1[png_ptr->background.red];
+         back_1.green = png_ptr->gamma_to_1[png_ptr->background.green];
+         back_1.blue = png_ptr->gamma_to_1[png_ptr->background.blue];
+      }
+      else
+      {
+         double g;
+
+         g = 1.0 / (png_ptr->background_gamma * png_ptr->screen_gamma);
+
+         if (png_ptr->background_gamma_type == PNG_BACKGROUND_GAMMA_SCREEN ||
+             fabs(g - 1.0) < PNG_GAMMA_THRESHOLD)
+         {
+            back.red = png_ptr->background.red;
+            back.green = png_ptr->background.green;
+            back.blue = png_ptr->background.blue;
+         }
+         else
+         {
+            back.red =
+               (png_byte)(pow((double)png_ptr->background.red/255, g) *
+                255.0 + 0.5);
+            back.green =
+               (png_byte)(pow((double)png_ptr->background.green/255, g) *
+                255.0 + 0.5);
+            back.blue =
+               (png_byte)(pow((double)png_ptr->background.blue/255, g) *
+                255.0 + 0.5);
+         }
+
+         g = 1.0 / png_ptr->background_gamma;
+
+         back_1.red =
+            (png_byte)(pow((double)png_ptr->background.red/255, g) *
+             255.0 + 0.5);
+         back_1.green =
+            (png_byte)(pow((double)png_ptr->background.green/255, g) *
+             255.0 + 0.5);
+         back_1.blue =
+            (png_byte)(pow((double)png_ptr->background.blue/255, g) *
+             255.0 + 0.5);
+      }
+
+      if (png_ptr->color_type == PNG_COLOR_TYPE_PALETTE)
+      {
+         png_uint_32 i;
+
+         for (i = 0; i < (png_uint_32)num_palette; i++)
+         {
+            if (i < png_ptr->num_trans && png_ptr->trans[i] == 0)
+            {
+               palette[i] = back;
+            }
+            else if (i < png_ptr->num_trans && png_ptr->trans[i] != 0xff)
+            {
+               png_byte v, w;
+
+               v = png_ptr->gamma_to_1[png_ptr->palette[i].red];
+               png_composite(w, v, png_ptr->trans[i], back_1.red);
+               palette[i].red = png_ptr->gamma_from_1[w];
+
+               v = png_ptr->gamma_to_1[png_ptr->palette[i].green];
+               png_composite(w, v, png_ptr->trans[i], back_1.green);
+               palette[i].green = png_ptr->gamma_from_1[w];
+
+               v = png_ptr->gamma_to_1[png_ptr->palette[i].blue];
+               png_composite(w, v, png_ptr->trans[i], back_1.blue);
+               palette[i].blue = png_ptr->gamma_from_1[w];
+            }
+            else
+            {
+               palette[i].red = png_ptr->gamma_table[palette[i].red];
+               palette[i].green = png_ptr->gamma_table[palette[i].green];
+               palette[i].blue = png_ptr->gamma_table[palette[i].blue];
+            }
+         }
+      }
+      else
+      {
+         int i;
+
+         for (i = 0; i < num_palette; i++)
+         {
+            if (palette[i].red == (png_byte)png_ptr->trans_values.gray)
+            {
+               palette[i] = back;
+            }
+            else
+            {
+               palette[i].red = png_ptr->gamma_table[palette[i].red];
+               palette[i].green = png_ptr->gamma_table[palette[i].green];
+               palette[i].blue = png_ptr->gamma_table[palette[i].blue];
+            }
+         }
+      }
+   }
+   else
+#endif
+#if defined(PNG_READ_GAMMA_SUPPORTED)
+   if (png_ptr->transformations & PNG_GAMMA)
+   {
+      int i;
+
+      for (i = 0; i < num_palette; i++)
+      {
+         palette[i].red = png_ptr->gamma_table[palette[i].red];
+         palette[i].green = png_ptr->gamma_table[palette[i].green];
+         palette[i].blue = png_ptr->gamma_table[palette[i].blue];
+      }
+   }
+#if defined(PNG_READ_BACKGROUND_SUPPORTED)
+   else
+#endif
+#endif
+#if defined(PNG_READ_BACKGROUND_SUPPORTED)
+   if (png_ptr->transformations & PNG_BACKGROUND)
+   {
+      if (png_ptr->color_type == PNG_COLOR_TYPE_PALETTE)
+      {
+         png_color back;
+
+         back.red   = (png_byte)png_ptr->background.red;
+         back.green = (png_byte)png_ptr->background.green;
+         back.blue  = (png_byte)png_ptr->background.blue;
+
+         for (i = 0; i < (int)png_ptr->num_trans; i++)
+         {
+            if (png_ptr->trans[i] == 0)
+            {
+               palette[i].red = back.red;
+               palette[i].green = back.green;
+               palette[i].blue = back.blue;
+            }
+            else if (png_ptr->trans[i] != 0xff)
+            {
+               png_composite(palette[i].red, png_ptr->palette[i].red,
+                  png_ptr->trans[i], back.red);
+               png_composite(palette[i].green, png_ptr->palette[i].green,
+                  png_ptr->trans[i], back.green);
+               png_composite(palette[i].blue, png_ptr->palette[i].blue,
+                  png_ptr->trans[i], back.blue);
+            }
+         }
+      }
+      else /* assume grayscale palette (what else could it be?) */
+      {
+         int i;
+
+         for (i = 0; i < num_palette; i++)
+         {
+            if (i == (png_byte)png_ptr->trans_values.gray)
+            {
+               palette[i].red = (png_byte)png_ptr->background.red;
+               palette[i].green = (png_byte)png_ptr->background.green;
+               palette[i].blue = (png_byte)png_ptr->background.blue;
+            }
+         }
+      }
+   }
+#endif
+}
+#endif
+
+#if defined(PNG_READ_BACKGROUND_SUPPORTED)
+/* Replace any alpha or transparency with the supplied background color.
+ * "background" is already in the screen gamma, while "background_1" is
+ * at a gamma of 1.0.  Paletted files have already been taken care of.
+ */
+void /* PRIVATE */
+png_do_background(png_row_infop row_info, png_bytep row,
+   png_color_16p trans_values, png_color_16p background
+#if defined(PNG_READ_GAMMA_SUPPORTED)
+   , png_color_16p background_1,
+   png_bytep gamma_table, png_bytep gamma_from_1, png_bytep gamma_to_1,
+   png_uint_16pp gamma_16, png_uint_16pp gamma_16_from_1,
+   png_uint_16pp gamma_16_to_1, int gamma_shift
+#endif
+   )
+{
+   png_bytep sp, dp;
+   png_uint_32 i;
+   png_uint_32 row_width=row_info->width;
+   int shift;
+
+   png_debug(1, "in png_do_background\n");
+   if (background != NULL &&
+#if defined(PNG_USELESS_TESTS_SUPPORTED)
+       row != NULL && row_info != NULL &&
+#endif
+      (!(row_info->color_type & PNG_COLOR_MASK_ALPHA) ||
+      (row_info->color_type != PNG_COLOR_TYPE_PALETTE && trans_values)))
+   {
+      switch (row_info->color_type)
+      {
+         case PNG_COLOR_TYPE_GRAY:
+         {
+            switch (row_info->bit_depth)
+            {
+               case 1:
+               {
+                  sp = row;
+                  shift = 7;
+                  for (i = 0; i < row_width; i++)
+                  {
+                     if ((png_uint_16)((*sp >> shift) & 0x01)
+                        == trans_values->gray)
+                     {
+                        *sp &= (png_byte)((0x7f7f >> (7 - shift)) & 0xff);
+                        *sp |= (png_byte)(background->gray << shift);
+                     }
+                     if (!shift)
+                     {
+                        shift = 7;
+                        sp++;
+                     }
+                     else
+                        shift--;
+                  }
+                  break;
+               }
+               case 2:
+               {
+#if defined(PNG_READ_GAMMA_SUPPORTED)
+                  if (gamma_table != NULL)
+                  {
+                     sp = row;
+                     shift = 6;
+                     for (i = 0; i < row_width; i++)
+                     {
+                        if ((png_uint_16)((*sp >> shift) & 0x03)
+                            == trans_values->gray)
+                        {
+                           *sp &= (png_byte)((0x3f3f >> (6 - shift)) & 0xff);
+                           *sp |= (png_byte)(background->gray << shift);
+                        }
+                        else
+                        {
+                           png_byte p = (png_byte)((*sp >> shift) & 0x03);
+                           png_byte g = (png_byte)((gamma_table [p | (p << 2) |
+                               (p << 4) | (p << 6)] >> 6) & 0x03);
+                           *sp &= (png_byte)((0x3f3f >> (6 - shift)) & 0xff);
+                           *sp |= (png_byte)(g << shift);
+                        }
+                        if (!shift)
+                        {
+                           shift = 6;
+                           sp++;
+                        }
+                        else
+                           shift -= 2;
+                     }
+                  }
+                  else
+#endif
+                  {
+                     sp = row;
+                     shift = 6;
+                     for (i = 0; i < row_width; i++)
+                     {
+                        if ((png_uint_16)((*sp >> shift) & 0x03)
+                            == trans_values->gray)
+                        {
+                           *sp &= (png_byte)((0x3f3f >> (6 - shift)) & 0xff);
+                           *sp |= (png_byte)(background->gray << shift);
+                        }
+                        if (!shift)
+                        {
+                           shift = 6;
+                           sp++;
+                        }
+                        else
+                           shift -= 2;
+                     }
+                  }
+                  break;
+               }
+               case 4:
+               {
+#if defined(PNG_READ_GAMMA_SUPPORTED)
+                  if (gamma_table != NULL)
+                  {
+                     sp = row;
+                     shift = 4;
+                     for (i = 0; i < row_width; i++)
+                     {
+                        if ((png_uint_16)((*sp >> shift) & 0x0f)
+                            == trans_values->gray)
+                        {
+                           *sp &= (png_byte)((0xf0f >> (4 - shift)) & 0xff);
+                           *sp |= (png_byte)(background->gray << shift);
+                        }
+                        else
+                        {
+                           png_byte p = (png_byte)((*sp >> shift) & 0x0f);
+                           png_byte g = (png_byte)((gamma_table[p |
+                             (p << 4)] >> 4) & 0x0f);
+                           *sp &= (png_byte)((0xf0f >> (4 - shift)) & 0xff);
+                           *sp |= (png_byte)(g << shift);
+                        }
+                        if (!shift)
+                        {
+                           shift = 4;
+                           sp++;
+                        }
+                        else
+                           shift -= 4;
+                     }
+                  }
+                  else
+#endif
+                  {
+                     sp = row;
+                     shift = 4;
+                     for (i = 0; i < row_width; i++)
+                     {
+                        if ((png_uint_16)((*sp >> shift) & 0x0f)
+                            == trans_values->gray)
+                        {
+                           *sp &= (png_byte)((0xf0f >> (4 - shift)) & 0xff);
+                           *sp |= (png_byte)(background->gray << shift);
+                        }
+                        if (!shift)
+                        {
+                           shift = 4;
+                           sp++;
+                        }
+                        else
+                           shift -= 4;
+                     }
+                  }
+                  break;
+               }
+               case 8:
+               {
+#if defined(PNG_READ_GAMMA_SUPPORTED)
+                  if (gamma_table != NULL)
+                  {
+                     sp = row;
+                     for (i = 0; i < row_width; i++, sp++)
+                     {
+                        if (*sp == trans_values->gray)
+                        {
+                           *sp = (png_byte)background->gray;
+                        }
+                        else
+                        {
+                           *sp = gamma_table[*sp];
+                        }
+                     }
+                  }
+                  else
+#endif
+                  {
+                     sp = row;
+                     for (i = 0; i < row_width; i++, sp++)
+                     {
+                        if (*sp == trans_values->gray)
+                        {
+                           *sp = (png_byte)background->gray;
+                        }
+                     }
+                  }
+                  break;
+               }
+               case 16:
+               {
+#if defined(PNG_READ_GAMMA_SUPPORTED)
+                  if (gamma_16 != NULL)
+                  {
+                     sp = row;
+                     for (i = 0; i < row_width; i++, sp += 2)
+                     {
+                        png_uint_16 v;
+
+                        v = (png_uint_16)(((*sp) << 8) + *(sp + 1));
+                        if (v == trans_values->gray)
+                        {
+                           /* background is already in screen gamma */
+                           *sp = (png_byte)((background->gray >> 8) & 0xff);
+                           *(sp + 1) = (png_byte)(background->gray & 0xff);
+                        }
+                        else
+                        {
+                           v = gamma_16[*(sp + 1) >> gamma_shift][*sp];
+                           *sp = (png_byte)((v >> 8) & 0xff);
+                           *(sp + 1) = (png_byte)(v & 0xff);
+                        }
+                     }
+                  }
+                  else
+#endif
+                  {
+                     sp = row;
+                     for (i = 0; i < row_width; i++, sp += 2)
+                     {
+                        png_uint_16 v;
+
+                        v = (png_uint_16)(((*sp) << 8) + *(sp + 1));
+                        if (v == trans_values->gray)
+                        {
+                           *sp = (png_byte)((background->gray >> 8) & 0xff);
+                           *(sp + 1) = (png_byte)(background->gray & 0xff);
+                        }
+                     }
+                  }
+                  break;
+               }
+            }
+            break;
+         }
+         case PNG_COLOR_TYPE_RGB:
+         {
+            if (row_info->bit_depth == 8)
+            {
+#if defined(PNG_READ_GAMMA_SUPPORTED)
+               if (gamma_table != NULL)
+               {
+                  sp = row;
+                  for (i = 0; i < row_width; i++, sp += 3)
+                  {
+                     if (*sp == trans_values->red &&
+                        *(sp + 1) == trans_values->green &&
+                        *(sp + 2) == trans_values->blue)
+                     {
+                        *sp = (png_byte)background->red;
+                        *(sp + 1) = (png_byte)background->green;
+                        *(sp + 2) = (png_byte)background->blue;
+                     }
+                     else
+                     {
+                        *sp = gamma_table[*sp];
+                        *(sp + 1) = gamma_table[*(sp + 1)];
+                        *(sp + 2) = gamma_table[*(sp + 2)];
+                     }
+                  }
+               }
+               else
+#endif
+               {
+                  sp = row;
+                  for (i = 0; i < row_width; i++, sp += 3)
+                  {
+                     if (*sp == trans_values->red &&
+                        *(sp + 1) == trans_values->green &&
+                        *(sp + 2) == trans_values->blue)
+                     {
+                        *sp = (png_byte)background->red;
+                        *(sp + 1) = (png_byte)background->green;
+                        *(sp + 2) = (png_byte)background->blue;
+                     }
+                  }
+               }
+            }
+            else /* if (row_info->bit_depth == 16) */
+            {
+#if defined(PNG_READ_GAMMA_SUPPORTED)
+               if (gamma_16 != NULL)
+               {
+                  sp = row;
+                  for (i = 0; i < row_width; i++, sp += 6)
+                  {
+                     png_uint_16 r = (png_uint_16)(((*sp) << 8) + *(sp + 1));
+                     png_uint_16 g = (png_uint_16)(((*(sp+2)) << 8) + *(sp+3));
+                     png_uint_16 b = (png_uint_16)(((*(sp+4)) << 8) + *(sp+5));
+                     if (r == trans_values->red && g == trans_values->green &&
+                        b == trans_values->blue)
+                     {
+                        /* background is already in screen gamma */
+                        *sp = (png_byte)((background->red >> 8) & 0xff);
+                        *(sp + 1) = (png_byte)(background->red & 0xff);
+                        *(sp + 2) = (png_byte)((background->green >> 8) & 0xff);
+                        *(sp + 3) = (png_byte)(background->green & 0xff);
+                        *(sp + 4) = (png_byte)((background->blue >> 8) & 0xff);
+                        *(sp + 5) = (png_byte)(background->blue & 0xff);
+                     }
+                     else
+                     {
+                        png_uint_16 v = gamma_16[*(sp + 1) >> gamma_shift][*sp];
+                        *sp = (png_byte)((v >> 8) & 0xff);
+                        *(sp + 1) = (png_byte)(v & 0xff);
+                        v = gamma_16[*(sp + 3) >> gamma_shift][*(sp + 2)];
+                        *(sp + 2) = (png_byte)((v >> 8) & 0xff);
+                        *(sp + 3) = (png_byte)(v & 0xff);
+                        v = gamma_16[*(sp + 5) >> gamma_shift][*(sp + 4)];
+                        *(sp + 4) = (png_byte)((v >> 8) & 0xff);
+                        *(sp + 5) = (png_byte)(v & 0xff);
+                     }
+                  }
+               }
+               else
+#endif
+               {
+                  sp = row;
+                  for (i = 0; i < row_width; i++, sp += 6)
+                  {
+                     png_uint_16 r = (png_uint_16)(((*sp) << 8) + *(sp+1));
+                     png_uint_16 g = (png_uint_16)(((*(sp+2)) << 8) + *(sp+3));
+                     png_uint_16 b = (png_uint_16)(((*(sp+4)) << 8) + *(sp+5));
+
+                     if (r == trans_values->red && g == trans_values->green &&
+                        b == trans_values->blue)
+                     {
+                        *sp = (png_byte)((background->red >> 8) & 0xff);
+                        *(sp + 1) = (png_byte)(background->red & 0xff);
+                        *(sp + 2) = (png_byte)((background->green >> 8) & 0xff);
+                        *(sp + 3) = (png_byte)(background->green & 0xff);
+                        *(sp + 4) = (png_byte)((background->blue >> 8) & 0xff);
+                        *(sp + 5) = (png_byte)(background->blue & 0xff);
+                     }
+                  }
+               }
+            }
+            break;
+         }
+         case PNG_COLOR_TYPE_GRAY_ALPHA:
+         {
+            if (row_info->bit_depth == 8)
+            {
+#if defined(PNG_READ_GAMMA_SUPPORTED)
+               if (gamma_to_1 != NULL && gamma_from_1 != NULL &&
+                   gamma_table != NULL)
+               {
+                  sp = row;
+                  dp = row;
+                  for (i = 0; i < row_width; i++, sp += 2, dp++)
+                  {
+                     png_uint_16 a = *(sp + 1);
+
+                     if (a == 0xff)
+                     {
+                        *dp = gamma_table[*sp];
+                     }
+                     else if (a == 0)
+                     {
+                        /* background is already in screen gamma */
+                        *dp = (png_byte)background->gray;
+                     }
+                     else
+                     {
+                        png_byte v, w;
+
+                        v = gamma_to_1[*sp];
+                        png_composite(w, v, a, background_1->gray);
+                        *dp = gamma_from_1[w];
+                     }
+                  }
+               }
+               else
+#endif
+               {
+                  sp = row;
+                  dp = row;
+                  for (i = 0; i < row_width; i++, sp += 2, dp++)
+                  {
+                     png_byte a = *(sp + 1);
+
+                     if (a == 0xff)
+                     {
+                        *dp = *sp;
+                     }
+#if defined(PNG_READ_GAMMA_SUPPORTED)
+                     else if (a == 0)
+                     {
+                        *dp = (png_byte)background->gray;
+                     }
+                     else
+                     {
+                        png_composite(*dp, *sp, a, background_1->gray);
+                     }
+#else
+                     *dp = (png_byte)background->gray;
+#endif
+                  }
+               }
+            }
+            else /* if (png_ptr->bit_depth == 16) */
+            {
+#if defined(PNG_READ_GAMMA_SUPPORTED)
+               if (gamma_16 != NULL && gamma_16_from_1 != NULL &&
+                   gamma_16_to_1 != NULL)
+               {
+                  sp = row;
+                  dp = row;
+                  for (i = 0; i < row_width; i++, sp += 4, dp += 2)
+                  {
+                     png_uint_16 a = (png_uint_16)(((*(sp+2)) << 8) + *(sp+3));
+
+                     if (a == (png_uint_16)0xffff)
+                     {
+                        png_uint_16 v;
+
+                        v = gamma_16[*(sp + 1) >> gamma_shift][*sp];
+                        *dp = (png_byte)((v >> 8) & 0xff);
+                        *(dp + 1) = (png_byte)(v & 0xff);
+                     }
+#if defined(PNG_READ_GAMMA_SUPPORTED)
+                     else if (a == 0)
+#else
+                     else
+#endif
+                     {
+                        /* background is already in screen gamma */
+                        *dp = (png_byte)((background->gray >> 8) & 0xff);
+                        *(dp + 1) = (png_byte)(background->gray & 0xff);
+                     }
+#if defined(PNG_READ_GAMMA_SUPPORTED)
+                     else
+                     {
+                        png_uint_16 g, v, w;
+
+                        g = gamma_16_to_1[*(sp + 1) >> gamma_shift][*sp];
+                        png_composite_16(v, g, a, background_1->gray);
+                        w = gamma_16_from_1[(v&0xff) >> gamma_shift][v >> 8];
+                        *dp = (png_byte)((w >> 8) & 0xff);
+                        *(dp + 1) = (png_byte)(w & 0xff);
+                     }
+#endif
+                  }
+               }
+               else
+#endif
+               {
+                  sp = row;
+                  dp = row;
+                  for (i = 0; i < row_width; i++, sp += 4, dp += 2)
+                  {
+                     png_uint_16 a = (png_uint_16)(((*(sp+2)) << 8) + *(sp+3));
+                     if (a == (png_uint_16)0xffff)
+                     {
+                        png_memcpy(dp, sp, 2);
+                     }
+#if defined(PNG_READ_GAMMA_SUPPORTED)
+                     else if (a == 0)
+#else
+                     else
+#endif
+                     {
+                        *dp = (png_byte)((background->gray >> 8) & 0xff);
+                        *(dp + 1) = (png_byte)(background->gray & 0xff);
+                     }
+#if defined(PNG_READ_GAMMA_SUPPORTED)
+                     else
+                     {
+                        png_uint_16 g, v;
+
+                        g = (png_uint_16)(((*sp) << 8) + *(sp + 1));
+                        png_composite_16(v, g, a, background_1->gray);
+                        *dp = (png_byte)((v >> 8) & 0xff);
+                        *(dp + 1) = (png_byte)(v & 0xff);
+                     }
+#endif
+                  }
+               }
+            }
+            break;
+         }
+         case PNG_COLOR_TYPE_RGB_ALPHA:
+         {
+            if (row_info->bit_depth == 8)
+            {
+#if defined(PNG_READ_GAMMA_SUPPORTED)
+               if (gamma_to_1 != NULL && gamma_from_1 != NULL &&
+                   gamma_table != NULL)
+               {
+                  sp = row;
+                  dp = row;
+                  for (i = 0; i < row_width; i++, sp += 4, dp += 3)
+                  {
+                     png_byte a = *(sp + 3);
+
+                     if (a == 0xff)
+                     {
+                        *dp = gamma_table[*sp];
+                        *(dp + 1) = gamma_table[*(sp + 1)];
+                        *(dp + 2) = gamma_table[*(sp + 2)];
+                     }
+                     else if (a == 0)
+                     {
+                        /* background is already in screen gamma */
+                        *dp = (png_byte)background->red;
+                        *(dp + 1) = (png_byte)background->green;
+                        *(dp + 2) = (png_byte)background->blue;
+                     }
+                     else
+                     {
+                        png_byte v, w;
+
+                        v = gamma_to_1[*sp];
+                        png_composite(w, v, a, background_1->red);
+                        *dp = gamma_from_1[w];
+                        v = gamma_to_1[*(sp + 1)];
+                        png_composite(w, v, a, background_1->green);
+                        *(dp + 1) = gamma_from_1[w];
+                        v = gamma_to_1[*(sp + 2)];
+                        png_composite(w, v, a, background_1->blue);
+                        *(dp + 2) = gamma_from_1[w];
+                     }
+                  }
+               }
+               else
+#endif
+               {
+                  sp = row;
+                  dp = row;
+                  for (i = 0; i < row_width; i++, sp += 4, dp += 3)
+                  {
+                     png_byte a = *(sp + 3);
+
+                     if (a == 0xff)
+                     {
+                        *dp = *sp;
+                        *(dp + 1) = *(sp + 1);
+                        *(dp + 2) = *(sp + 2);
+                     }
+                     else if (a == 0)
+                     {
+                        *dp = (png_byte)background->red;
+                        *(dp + 1) = (png_byte)background->green;
+                        *(dp + 2) = (png_byte)background->blue;
+                     }
+                     else
+                     {
+                        png_composite(*dp, *sp, a, background->red);
+                        png_composite(*(dp + 1), *(sp + 1), a,
+                           background->green);
+                        png_composite(*(dp + 2), *(sp + 2), a,
+                           background->blue);
+                     }
+                  }
+               }
+            }
+            else /* if (row_info->bit_depth == 16) */
+            {
+#if defined(PNG_READ_GAMMA_SUPPORTED)
+               if (gamma_16 != NULL && gamma_16_from_1 != NULL &&
+                   gamma_16_to_1 != NULL)
+               {
+                  sp = row;
+                  dp = row;
+                  for (i = 0; i < row_width; i++, sp += 8, dp += 6)
+                  {
+                     png_uint_16 a = (png_uint_16)(((png_uint_16)(*(sp + 6))
+                         << 8) + (png_uint_16)(*(sp + 7)));
+                     if (a == (png_uint_16)0xffff)
+                     {
+                        png_uint_16 v;
+
+                        v = gamma_16[*(sp + 1) >> gamma_shift][*sp];
+                        *dp = (png_byte)((v >> 8) & 0xff);
+                        *(dp + 1) = (png_byte)(v & 0xff);
+                        v = gamma_16[*(sp + 3) >> gamma_shift][*(sp + 2)];
+                        *(dp + 2) = (png_byte)((v >> 8) & 0xff);
+                        *(dp + 3) = (png_byte)(v & 0xff);
+                        v = gamma_16[*(sp + 5) >> gamma_shift][*(sp + 4)];
+                        *(dp + 4) = (png_byte)((v >> 8) & 0xff);
+                        *(dp + 5) = (png_byte)(v & 0xff);
+                     }
+                     else if (a == 0)
+                     {
+                        /* background is already in screen gamma */
+                        *dp = (png_byte)((background->red >> 8) & 0xff);
+                        *(dp + 1) = (png_byte)(background->red & 0xff);
+                        *(dp + 2) = (png_byte)((background->green >> 8) & 0xff);
+                        *(dp + 3) = (png_byte)(background->green & 0xff);
+                        *(dp + 4) = (png_byte)((background->blue >> 8) & 0xff);
+                        *(dp + 5) = (png_byte)(background->blue & 0xff);
+                     }
+                     else
+                     {
+                        png_uint_16 v, w, x;
+
+                        v = gamma_16_to_1[*(sp + 1) >> gamma_shift][*sp];
+                        png_composite_16(w, v, a, background_1->red);
+                        x = gamma_16_from_1[((w&0xff) >> gamma_shift)][w >> 8];
+                        *dp = (png_byte)((x >> 8) & 0xff);
+                        *(dp + 1) = (png_byte)(x & 0xff);
+                        v = gamma_16_to_1[*(sp + 3) >> gamma_shift][*(sp + 2)];
+                        png_composite_16(w, v, a, background_1->green);
+                        x = gamma_16_from_1[((w&0xff) >> gamma_shift)][w >> 8];
+                        *(dp + 2) = (png_byte)((x >> 8) & 0xff);
+                        *(dp + 3) = (png_byte)(x & 0xff);
+                        v = gamma_16_to_1[*(sp + 5) >> gamma_shift][*(sp + 4)];
+                        png_composite_16(w, v, a, background_1->blue);
+                        x = gamma_16_from_1[(w & 0xff) >> gamma_shift][w >> 8];
+                        *(dp + 4) = (png_byte)((x >> 8) & 0xff);
+                        *(dp + 5) = (png_byte)(x & 0xff);
+                     }
+                  }
+               }
+               else
+#endif
+               {
+                  sp = row;
+                  dp = row;
+                  for (i = 0; i < row_width; i++, sp += 8, dp += 6)
+                  {
+                     png_uint_16 a = (png_uint_16)(((png_uint_16)(*(sp + 6))
+                        << 8) + (png_uint_16)(*(sp + 7)));
+                     if (a == (png_uint_16)0xffff)
+                     {
+                        png_memcpy(dp, sp, 6);
+                     }
+                     else if (a == 0)
+                     {
+                        *dp = (png_byte)((background->red >> 8) & 0xff);
+                        *(dp + 1) = (png_byte)(background->red & 0xff);
+                        *(dp + 2) = (png_byte)((background->green >> 8) & 0xff);
+                        *(dp + 3) = (png_byte)(background->green & 0xff);
+                        *(dp + 4) = (png_byte)((background->blue >> 8) & 0xff);
+                        *(dp + 5) = (png_byte)(background->blue & 0xff);
+                     }
+                     else
+                     {
+                        png_uint_16 v;
+
+                        png_uint_16 r = (png_uint_16)(((*sp) << 8) + *(sp + 1));
+                        png_uint_16 g = (png_uint_16)(((*(sp + 2)) << 8)
+                            + *(sp + 3));
+                        png_uint_16 b = (png_uint_16)(((*(sp + 4)) << 8)
+                            + *(sp + 5));
+
+                        png_composite_16(v, r, a, background->red);
+                        *dp = (png_byte)((v >> 8) & 0xff);
+                        *(dp + 1) = (png_byte)(v & 0xff);
+                        png_composite_16(v, g, a, background->green);
+                        *(dp + 2) = (png_byte)((v >> 8) & 0xff);
+                        *(dp + 3) = (png_byte)(v & 0xff);
+                        png_composite_16(v, b, a, background->blue);
+                        *(dp + 4) = (png_byte)((v >> 8) & 0xff);
+                        *(dp + 5) = (png_byte)(v & 0xff);
+                     }
+                  }
+               }
+            }
+            break;
+         }
+      }
+
+      if (row_info->color_type & PNG_COLOR_MASK_ALPHA)
+      {
+         row_info->color_type &= ~PNG_COLOR_MASK_ALPHA;
+         row_info->channels--;
+         row_info->pixel_depth = (png_byte)(row_info->channels *
+            row_info->bit_depth);
+         row_info->rowbytes = ((row_width *
+            row_info->pixel_depth + 7) >> 3);
+      }
+   }
+}
+#endif
+
+#if defined(PNG_READ_GAMMA_SUPPORTED)
+/* Gamma correct the image, avoiding the alpha channel.  Make sure
+ * you do this after you deal with the transparency issue on grayscale
+ * or RGB images. If your bit depth is 8, use gamma_table, if it
+ * is 16, use gamma_16_table and gamma_shift.  Build these with
+ * build_gamma_table().
+ */
+void /* PRIVATE */
+png_do_gamma(png_row_infop row_info, png_bytep row,
+   png_bytep gamma_table, png_uint_16pp gamma_16_table,
+   int gamma_shift)
+{
+   png_bytep sp;
+   png_uint_32 i;
+   png_uint_32 row_width=row_info->width;
+
+   png_debug(1, "in png_do_gamma\n");
+   if (
+#if defined(PNG_USELESS_TESTS_SUPPORTED)
+       row != NULL && row_info != NULL &&
+#endif
+       ((row_info->bit_depth <= 8 && gamma_table != NULL) ||
+        (row_info->bit_depth == 16 && gamma_16_table != NULL)))
+   {
+      switch (row_info->color_type)
+      {
+         case PNG_COLOR_TYPE_RGB:
+         {
+            if (row_info->bit_depth == 8)
+            {
+               sp = row;
+               for (i = 0; i < row_width; i++)
+               {
+                  *sp = gamma_table[*sp];
+                  sp++;
+                  *sp = gamma_table[*sp];
+                  sp++;
+                  *sp = gamma_table[*sp];
+                  sp++;
+               }
+            }
+            else /* if (row_info->bit_depth == 16) */
+            {
+               sp = row;
+               for (i = 0; i < row_width; i++)
+               {
+                  png_uint_16 v;
+
+                  v = gamma_16_table[*(sp + 1) >> gamma_shift][*sp];
+                  *sp = (png_byte)((v >> 8) & 0xff);
+                  *(sp + 1) = (png_byte)(v & 0xff);
+                  sp += 2;
+                  v = gamma_16_table[*(sp + 1) >> gamma_shift][*sp];
+                  *sp = (png_byte)((v >> 8) & 0xff);
+                  *(sp + 1) = (png_byte)(v & 0xff);
+                  sp += 2;
+                  v = gamma_16_table[*(sp + 1) >> gamma_shift][*sp];
+                  *sp = (png_byte)((v >> 8) & 0xff);
+                  *(sp + 1) = (png_byte)(v & 0xff);
+                  sp += 2;
+               }
+            }
+            break;
+         }
+         case PNG_COLOR_TYPE_RGB_ALPHA:
+         {
+            if (row_info->bit_depth == 8)
+            {
+               sp = row;
+               for (i = 0; i < row_width; i++)
+               {
+                  *sp = gamma_table[*sp];
+                  sp++;
+                  *sp = gamma_table[*sp];
+                  sp++;
+                  *sp = gamma_table[*sp];
+                  sp++;
+                  sp++;
+               }
+            }
+            else /* if (row_info->bit_depth == 16) */
+            {
+               sp = row;
+               for (i = 0; i < row_width; i++)
+               {
+                  png_uint_16 v = gamma_16_table[*(sp + 1) >> gamma_shift][*sp];
+                  *sp = (png_byte)((v >> 8) & 0xff);
+                  *(sp + 1) = (png_byte)(v & 0xff);
+                  sp += 2;
+                  v = gamma_16_table[*(sp + 1) >> gamma_shift][*sp];
+                  *sp = (png_byte)((v >> 8) & 0xff);
+                  *(sp + 1) = (png_byte)(v & 0xff);
+                  sp += 2;
+                  v = gamma_16_table[*(sp + 1) >> gamma_shift][*sp];
+                  *sp = (png_byte)((v >> 8) & 0xff);
+                  *(sp + 1) = (png_byte)(v & 0xff);
+                  sp += 4;
+               }
+            }
+            break;
+         }
+         case PNG_COLOR_TYPE_GRAY_ALPHA:
+         {
+            if (row_info->bit_depth == 8)
+            {
+               sp = row;
+               for (i = 0; i < row_width; i++)
+               {
+                  *sp = gamma_table[*sp];
+                  sp += 2;
+               }
+            }
+            else /* if (row_info->bit_depth == 16) */
+            {
+               sp = row;
+               for (i = 0; i < row_width; i++)
+               {
+                  png_uint_16 v = gamma_16_table[*(sp + 1) >> gamma_shift][*sp];
+                  *sp = (png_byte)((v >> 8) & 0xff);
+                  *(sp + 1) = (png_byte)(v & 0xff);
+                  sp += 4;
+               }
+            }
+            break;
+         }
+         case PNG_COLOR_TYPE_GRAY:
+         {
+            if (row_info->bit_depth == 2)
+            {
+               sp = row;
+               for (i = 0; i < row_width; i += 4)
+               {
+                  int a = *sp & 0xc0;
+                  int b = *sp & 0x30;
+                  int c = *sp & 0x0c;
+                  int d = *sp & 0x03;
+
+                  *sp = (png_byte)(
+                        ((((int)gamma_table[a|(a>>2)|(a>>4)|(a>>6)])   ) & 0xc0)|
+                        ((((int)gamma_table[(b<<2)|b|(b>>2)|(b>>4)])>>2) & 0x30)|
+                        ((((int)gamma_table[(c<<4)|(c<<2)|c|(c>>2)])>>4) & 0x0c)|
+                        ((((int)gamma_table[(d<<6)|(d<<4)|(d<<2)|d])>>6) ));
+                  sp++;
+               }
+            }
+            if (row_info->bit_depth == 4)
+            {
+               sp = row;
+               for (i = 0; i < row_width; i += 2)
+               {
+                  int msb = *sp & 0xf0;
+                  int lsb = *sp & 0x0f;
+
+                  *sp = (png_byte)((((int)gamma_table[msb | (msb >> 4)]) & 0xf0)
+                          | (((int)gamma_table[(lsb << 4) | lsb]) >> 4));
+                  sp++;
+               }
+            }
+            else if (row_info->bit_depth == 8)
+            {
+               sp = row;
+               for (i = 0; i < row_width; i++)
+               {
+                  *sp = gamma_table[*sp];
+                  sp++;
+               }
+            }
+            else if (row_info->bit_depth == 16)
+            {
+               sp = row;
+               for (i = 0; i < row_width; i++)
+               {
+                  png_uint_16 v = gamma_16_table[*(sp + 1) >> gamma_shift][*sp];
+                  *sp = (png_byte)((v >> 8) & 0xff);
+                  *(sp + 1) = (png_byte)(v & 0xff);
+                  sp += 2;
+               }
+            }
+            break;
+         }
+      }
+   }
+}
+#endif
+
+#if defined(PNG_READ_EXPAND_SUPPORTED)
+/* Expands a palette row to an RGB or RGBA row depending
+ * upon whether you supply trans and num_trans.
+ */
+void /* PRIVATE */
+png_do_expand_palette(png_row_infop row_info, png_bytep row,
+   png_colorp palette, png_bytep trans, int num_trans)
+{
+   int shift, value;
+   png_bytep sp, dp;
+   png_uint_32 i;
+   png_uint_32 row_width=row_info->width;
+
+   png_debug(1, "in png_do_expand_palette\n");
+   if (
+#if defined(PNG_USELESS_TESTS_SUPPORTED)
+       row != NULL && row_info != NULL &&
+#endif
+       row_info->color_type == PNG_COLOR_TYPE_PALETTE)
+   {
+      if (row_info->bit_depth < 8)
+      {
+         switch (row_info->bit_depth)
+         {
+            case 1:
+            {
+               sp = row + (png_size_t)((row_width - 1) >> 3);
+               dp = row + (png_size_t)row_width - 1;
+               shift = 7 - (int)((row_width + 7) & 0x07);
+               for (i = 0; i < row_width; i++)
+               {
+                  if ((*sp >> shift) & 0x01)
+                     *dp = 1;
+                  else
+                     *dp = 0;
+                  if (shift == 7)
+                  {
+                     shift = 0;
+                     sp--;
+                  }
+                  else
+                     shift++;
+
+                  dp--;
+               }
+               break;
+            }
+            case 2:
+            {
+               sp = row + (png_size_t)((row_width - 1) >> 2);
+               dp = row + (png_size_t)row_width - 1;
+               shift = (int)((3 - ((row_width + 3) & 0x03)) << 1);
+               for (i = 0; i < row_width; i++)
+               {
+                  value = (*sp >> shift) & 0x03;
+                  *dp = (png_byte)value;
+                  if (shift == 6)
+                  {
+                     shift = 0;
+                     sp--;
+                  }
+                  else
+                     shift += 2;
+
+                  dp--;
+               }
+               break;
+            }
+            case 4:
+            {
+               sp = row + (png_size_t)((row_width - 1) >> 1);
+               dp = row + (png_size_t)row_width - 1;
+               shift = (int)((row_width & 0x01) << 2);
+               for (i = 0; i < row_width; i++)
+               {
+                  value = (*sp >> shift) & 0x0f;
+                  *dp = (png_byte)value;
+                  if (shift == 4)
+                  {
+                     shift = 0;
+                     sp--;
+                  }
+                  else
+                     shift += 4;
+
+                  dp--;
+               }
+               break;
+            }
+         }
+         row_info->bit_depth = 8;
+         row_info->pixel_depth = 8;
+         row_info->rowbytes = row_width;
+      }
+      switch (row_info->bit_depth)
+      {
+         case 8:
+         {
+            if (trans != NULL)
+            {
+               sp = row + (png_size_t)row_width - 1;
+               dp = row + (png_size_t)(row_width << 2) - 1;
+
+               for (i = 0; i < row_width; i++)
+               {
+                  if ((int)(*sp) >= num_trans)
+                     *dp-- = 0xff;
+                  else
+                     *dp-- = trans[*sp];
+                  *dp-- = palette[*sp].blue;
+                  *dp-- = palette[*sp].green;
+                  *dp-- = palette[*sp].red;
+                  sp--;
+               }
+               row_info->bit_depth = 8;
+               row_info->pixel_depth = 32;
+               row_info->rowbytes = row_width * 4;
+               row_info->color_type = 6;
+               row_info->channels = 4;
+            }
+            else
+            {
+               sp = row + (png_size_t)row_width - 1;
+               dp = row + (png_size_t)(row_width * 3) - 1;
+
+               for (i = 0; i < row_width; i++)
+               {
+                  *dp-- = palette[*sp].blue;
+                  *dp-- = palette[*sp].green;
+                  *dp-- = palette[*sp].red;
+                  sp--;
+               }
+               row_info->bit_depth = 8;
+               row_info->pixel_depth = 24;
+               row_info->rowbytes = row_width * 3;
+               row_info->color_type = 2;
+               row_info->channels = 3;
+            }
+            break;
+         }
+      }
+   }
+}
+
+/* If the bit depth < 8, it is expanded to 8.  Also, if the
+ * transparency value is supplied, an alpha channel is built.
+ */
+void /* PRIVATE */
+png_do_expand(png_row_infop row_info, png_bytep row,
+   png_color_16p trans_value)
+{
+   int shift, value;
+   png_bytep sp, dp;
+   png_uint_32 i;
+   png_uint_32 row_width=row_info->width;
+
+   png_debug(1, "in png_do_expand\n");
+#if defined(PNG_USELESS_TESTS_SUPPORTED)
+   if (row != NULL && row_info != NULL)
+#endif
+   {
+      if (row_info->color_type == PNG_COLOR_TYPE_GRAY)
+      {
+         png_uint_16 gray = (png_uint_16)(trans_value ? trans_value->gray : 0);
+
+         if (row_info->bit_depth < 8)
+         {
+            switch (row_info->bit_depth)
+            {
+               case 1:
+               {
+                  gray = (png_uint_16)(gray*0xff);
+                  sp = row + (png_size_t)((row_width - 1) >> 3);
+                  dp = row + (png_size_t)row_width - 1;
+                  shift = 7 - (int)((row_width + 7) & 0x07);
+                  for (i = 0; i < row_width; i++)
+                  {
+                     if ((*sp >> shift) & 0x01)
+                        *dp = 0xff;
+                     else
+                        *dp = 0;
+                     if (shift == 7)
+                     {
+                        shift = 0;
+                        sp--;
+                     }
+                     else
+                        shift++;
+
+                     dp--;
+                  }
+                  break;
+               }
+               case 2:
+               {
+                  gray = (png_uint_16)(gray*0x55);
+                  sp = row + (png_size_t)((row_width - 1) >> 2);
+                  dp = row + (png_size_t)row_width - 1;
+                  shift = (int)((3 - ((row_width + 3) & 0x03)) << 1);
+                  for (i = 0; i < row_width; i++)
+                  {
+                     value = (*sp >> shift) & 0x03;
+                     *dp = (png_byte)(value | (value << 2) | (value << 4) |
+                        (value << 6));
+                     if (shift == 6)
+                     {
+                        shift = 0;
+                        sp--;
+                     }
+                     else
+                        shift += 2;
+
+                     dp--;
+                  }
+                  break;
+               }
+               case 4:
+               {
+                  gray = (png_uint_16)(gray*0x11);
+                  sp = row + (png_size_t)((row_width - 1) >> 1);
+                  dp = row + (png_size_t)row_width - 1;
+                  shift = (int)((1 - ((row_width + 1) & 0x01)) << 2);
+                  for (i = 0; i < row_width; i++)
+                  {
+                     value = (*sp >> shift) & 0x0f;
+                     *dp = (png_byte)(value | (value << 4));
+                     if (shift == 4)
+                     {
+                        shift = 0;
+                        sp--;
+                     }
+                     else
+                        shift = 4;
+
+                     dp--;
+                  }
+                  break;
+               }
+            }
+            row_info->bit_depth = 8;
+            row_info->pixel_depth = 8;
+            row_info->rowbytes = row_width;
+         }
+
+         if (trans_value != NULL)
+         {
+            if (row_info->bit_depth == 8)
+            {
+               sp = row + (png_size_t)row_width - 1;
+               dp = row + (png_size_t)(row_width << 1) - 1;
+               for (i = 0; i < row_width; i++)
+               {
+                  if (*sp == gray)
+                     *dp-- = 0;
+                  else
+                     *dp-- = 0xff;
+                  *dp-- = *sp--;
+               }
+            }
+            else if (row_info->bit_depth == 16)
+            {
+               sp = row + row_info->rowbytes - 1;
+               dp = row + (row_info->rowbytes << 1) - 1;
+               for (i = 0; i < row_width; i++)
+               {
+                  if (((png_uint_16)*(sp) |
+                     ((png_uint_16)*(sp - 1) << 8)) == gray)
+                  {
+                     *dp-- = 0;
+                     *dp-- = 0;
+                  }
+                  else
+                  {
+                     *dp-- = 0xff;
+                     *dp-- = 0xff;
+                  }
+                  *dp-- = *sp--;
+                  *dp-- = *sp--;
+               }
+            }
+            row_info->color_type = PNG_COLOR_TYPE_GRAY_ALPHA;
+            row_info->channels = 2;
+            row_info->pixel_depth = (png_byte)(row_info->bit_depth << 1);
+            row_info->rowbytes =
+               ((row_width * row_info->pixel_depth) >> 3);
+         }
+      }
+      else if (row_info->color_type == PNG_COLOR_TYPE_RGB && trans_value)
+      {
+         if (row_info->bit_depth == 8)
+         {
+            sp = row + (png_size_t)row_info->rowbytes - 1;
+            dp = row + (png_size_t)(row_width << 2) - 1;
+            for (i = 0; i < row_width; i++)
+            {
+               if (*(sp - 2) == trans_value->red &&
+                  *(sp - 1) == trans_value->green &&
+                  *(sp - 0) == trans_value->blue)
+                  *dp-- = 0;
+               else
+                  *dp-- = 0xff;
+               *dp-- = *sp--;
+               *dp-- = *sp--;
+               *dp-- = *sp--;
+            }
+         }
+         else if (row_info->bit_depth == 16)
+         {
+            sp = row + row_info->rowbytes - 1;
+            dp = row + (png_size_t)(row_width << 3) - 1;
+            for (i = 0; i < row_width; i++)
+            {
+               if ((((png_uint_16)*(sp - 4) |
+                  ((png_uint_16)*(sp - 5) << 8)) == trans_value->red) &&
+                  (((png_uint_16)*(sp - 2) |
+                  ((png_uint_16)*(sp - 3) << 8)) == trans_value->green) &&
+                  (((png_uint_16)*(sp - 0) |
+                  ((png_uint_16)*(sp - 1) << 8)) == trans_value->blue))
+               {
+                  *dp-- = 0;
+                  *dp-- = 0;
+               }
+               else
+               {
+                  *dp-- = 0xff;
+                  *dp-- = 0xff;
+               }
+               *dp-- = *sp--;
+               *dp-- = *sp--;
+               *dp-- = *sp--;
+               *dp-- = *sp--;
+               *dp-- = *sp--;
+               *dp-- = *sp--;
+            }
+         }
+         row_info->color_type = PNG_COLOR_TYPE_RGB_ALPHA;
+         row_info->channels = 4;
+         row_info->pixel_depth = (png_byte)(row_info->bit_depth << 2);
+         row_info->rowbytes =
+            ((row_width * row_info->pixel_depth) >> 3);
+      }
+   }
+}
+#endif
+
+#if defined(PNG_READ_DITHER_SUPPORTED)
+void /* PRIVATE */
+png_do_dither(png_row_infop row_info, png_bytep row,
+    png_bytep palette_lookup, png_bytep dither_lookup)
+{
+   png_bytep sp, dp;
+   png_uint_32 i;
+   png_uint_32 row_width=row_info->width;
+
+   png_debug(1, "in png_do_dither\n");
+#if defined(PNG_USELESS_TESTS_SUPPORTED)
+   if (row != NULL && row_info != NULL)
+#endif
+   {
+      if (row_info->color_type == PNG_COLOR_TYPE_RGB &&
+         palette_lookup && row_info->bit_depth == 8)
+      {
+         int r, g, b, p;
+         sp = row;
+         dp = row;
+         for (i = 0; i < row_width; i++)
+         {
+            r = *sp++;
+            g = *sp++;
+            b = *sp++;
+
+            /* this looks real messy, but the compiler will reduce
+               it down to a reasonable formula.  For example, with
+               5 bits per color, we get:
+               p = (((r >> 3) & 0x1f) << 10) |
+                  (((g >> 3) & 0x1f) << 5) |
+                  ((b >> 3) & 0x1f);
+               */
+            p = (((r >> (8 - PNG_DITHER_RED_BITS)) &
+               ((1 << PNG_DITHER_RED_BITS) - 1)) <<
+               (PNG_DITHER_GREEN_BITS + PNG_DITHER_BLUE_BITS)) |
+               (((g >> (8 - PNG_DITHER_GREEN_BITS)) &
+               ((1 << PNG_DITHER_GREEN_BITS) - 1)) <<
+               (PNG_DITHER_BLUE_BITS)) |
+               ((b >> (8 - PNG_DITHER_BLUE_BITS)) &
+               ((1 << PNG_DITHER_BLUE_BITS) - 1));
+
+            *dp++ = palette_lookup[p];
+         }
+         row_info->color_type = PNG_COLOR_TYPE_PALETTE;
+         row_info->channels = 1;
+         row_info->pixel_depth = row_info->bit_depth;
+         row_info->rowbytes =
+             ((row_width * row_info->pixel_depth + 7) >> 3);
+      }
+      else if (row_info->color_type == PNG_COLOR_TYPE_RGB_ALPHA &&
+         palette_lookup != NULL && row_info->bit_depth == 8)
+      {
+         int r, g, b, p;
+         sp = row;
+         dp = row;
+         for (i = 0; i < row_width; i++)
+         {
+            r = *sp++;
+            g = *sp++;
+            b = *sp++;
+            sp++;
+
+            p = (((r >> (8 - PNG_DITHER_RED_BITS)) &
+               ((1 << PNG_DITHER_RED_BITS) - 1)) <<
+               (PNG_DITHER_GREEN_BITS + PNG_DITHER_BLUE_BITS)) |
+               (((g >> (8 - PNG_DITHER_GREEN_BITS)) &
+               ((1 << PNG_DITHER_GREEN_BITS) - 1)) <<
+               (PNG_DITHER_BLUE_BITS)) |
+               ((b >> (8 - PNG_DITHER_BLUE_BITS)) &
+               ((1 << PNG_DITHER_BLUE_BITS) - 1));
+
+            *dp++ = palette_lookup[p];
+         }
+         row_info->color_type = PNG_COLOR_TYPE_PALETTE;
+         row_info->channels = 1;
+         row_info->pixel_depth = row_info->bit_depth;
+         row_info->rowbytes =
+            ((row_width * row_info->pixel_depth + 7) >> 3);
+      }
+      else if (row_info->color_type == PNG_COLOR_TYPE_PALETTE &&
+         dither_lookup && row_info->bit_depth == 8)
+      {
+         sp = row;
+         for (i = 0; i < row_width; i++, sp++)
+         {
+            *sp = dither_lookup[*sp];
+         }
+      }
+   }
+}
+#endif
+
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+#if defined(PNG_READ_GAMMA_SUPPORTED)
+static int png_gamma_shift[] =
+   {0x10, 0x21, 0x42, 0x84, 0x110, 0x248, 0x550, 0xff0};
+
+/* We build the 8- or 16-bit gamma tables here.  Note that for 16-bit
+ * tables, we don't make a full table if we are reducing to 8-bit in
+ * the future.  Note also how the gamma_16 tables are segmented so that
+ * we don't need to allocate > 64K chunks for a full 16-bit table.
+ */
+void /* PRIVATE */
+png_build_gamma_table(png_structp png_ptr)
+{
+  png_debug(1, "in png_build_gamma_table\n");
+  if(png_ptr->gamma != 0.0)
+  {
+   if (png_ptr->bit_depth <= 8)
+   {
+      int i;
+      double g;
+
+      if (png_ptr->screen_gamma > .000001)
+         g = 1.0 / (png_ptr->gamma * png_ptr->screen_gamma);
+      else
+         g = 1.0;
+
+      png_ptr->gamma_table = (png_bytep)png_malloc(png_ptr,
+         (png_uint_32)256);
+
+      for (i = 0; i < 256; i++)
+      {
+         png_ptr->gamma_table[i] = (png_byte)(pow((double)i / 255.0,
+            g) * 255.0 + .5);
+      }
+
+#if defined(PNG_READ_BACKGROUND_SUPPORTED) || \
+    defined(PNG_READ_RGB_TO_GRAY_SUPPORTED)
+      if (png_ptr->transformations & ((PNG_BACKGROUND) | PNG_RGB_TO_GRAY))
+      {
+
+         g = 1.0 / (png_ptr->gamma);
+
+         png_ptr->gamma_to_1 = (png_bytep)png_malloc(png_ptr,
+            (png_uint_32)256);
+
+         for (i = 0; i < 256; i++)
+         {
+            png_ptr->gamma_to_1[i] = (png_byte)(pow((double)i / 255.0,
+               g) * 255.0 + .5);
+         }
+
+
+         png_ptr->gamma_from_1 = (png_bytep)png_malloc(png_ptr,
+            (png_uint_32)256);
+
+         if(png_ptr->screen_gamma > 0.000001)
+            g = 1.0 / png_ptr->screen_gamma;
+         else
+            g = png_ptr->gamma;   /* probably doing rgb_to_gray */
+
+         for (i = 0; i < 256; i++)
+         {
+            png_ptr->gamma_from_1[i] = (png_byte)(pow((double)i / 255.0,
+               g) * 255.0 + .5);
+
+         }
+      }
+#endif /* PNG_READ_BACKGROUND_SUPPORTED || PNG_RGB_TO_GRAY_SUPPORTED */
+   }
+   else
+   {
+      double g;
+      int i, j, shift, num;
+      int sig_bit;
+      png_uint_32 ig;
+
+      if (png_ptr->color_type & PNG_COLOR_MASK_COLOR)
+      {
+         sig_bit = (int)png_ptr->sig_bit.red;
+         if ((int)png_ptr->sig_bit.green > sig_bit)
+            sig_bit = png_ptr->sig_bit.green;
+         if ((int)png_ptr->sig_bit.blue > sig_bit)
+            sig_bit = png_ptr->sig_bit.blue;
+      }
+      else
+      {
+         sig_bit = (int)png_ptr->sig_bit.gray;
+      }
+
+      if (sig_bit > 0)
+         shift = 16 - sig_bit;
+      else
+         shift = 0;
+
+      if (png_ptr->transformations & PNG_16_TO_8)
+      {
+         if (shift < (16 - PNG_MAX_GAMMA_8))
+            shift = (16 - PNG_MAX_GAMMA_8);
+      }
+
+      if (shift > 8)
+         shift = 8;
+      if (shift < 0)
+         shift = 0;
+
+      png_ptr->gamma_shift = (png_byte)shift;
+
+      num = (1 << (8 - shift));
+
+      if (png_ptr->screen_gamma > .000001)
+         g = 1.0 / (png_ptr->gamma * png_ptr->screen_gamma);
+      else
+         g = 1.0;
+
+      png_ptr->gamma_16_table = (png_uint_16pp)png_malloc(png_ptr,
+         (png_uint_32)(num * sizeof (png_uint_16p)));
+
+      if (png_ptr->transformations & (PNG_16_TO_8 | PNG_BACKGROUND))
+      {
+         double fin, fout;
+         png_uint_32 last, max;
+
+         for (i = 0; i < num; i++)
+         {
+            png_ptr->gamma_16_table[i] = (png_uint_16p)png_malloc(png_ptr,
+               (png_uint_32)(256 * sizeof (png_uint_16)));
+         }
+
+         g = 1.0 / g;
+         last = 0;
+         for (i = 0; i < 256; i++)
+         {
+            fout = ((double)i + 0.5) / 256.0;
+            fin = pow(fout, g);
+            max = (png_uint_32)(fin * (double)((png_uint_32)num << 8));
+            while (last <= max)
+            {
+               png_ptr->gamma_16_table[(int)(last & (0xff >> shift))]
+                  [(int)(last >> (8 - shift))] = (png_uint_16)(
+                  (png_uint_16)i | ((png_uint_16)i << 8));
+               last++;
+            }
+         }
+         while (last < ((png_uint_32)num << 8))
+         {
+            png_ptr->gamma_16_table[(int)(last & (0xff >> shift))]
+               [(int)(last >> (8 - shift))] = (png_uint_16)65535L;
+            last++;
+         }
+      }
+      else
+      {
+         for (i = 0; i < num; i++)
+         {
+            png_ptr->gamma_16_table[i] = (png_uint_16p)png_malloc(png_ptr,
+               (png_uint_32)(256 * sizeof (png_uint_16)));
+
+            ig = (((png_uint_32)i * (png_uint_32)png_gamma_shift[shift]) >> 4);
+            for (j = 0; j < 256; j++)
+            {
+               png_ptr->gamma_16_table[i][j] =
+                  (png_uint_16)(pow((double)(ig + ((png_uint_32)j << 8)) /
+                     65535.0, g) * 65535.0 + .5);
+            }
+         }
+      }
+
+#if defined(PNG_READ_BACKGROUND_SUPPORTED) || \
+    defined(PNG_READ_RGB_TO_GRAY_SUPPORTED)
+      if (png_ptr->transformations & (PNG_BACKGROUND | PNG_RGB_TO_GRAY))
+      {
+
+         g = 1.0 / (png_ptr->gamma);
+
+         png_ptr->gamma_16_to_1 = (png_uint_16pp)png_malloc(png_ptr,
+            (png_uint_32)(num * sizeof (png_uint_16p )));
+
+         for (i = 0; i < num; i++)
+         {
+            png_ptr->gamma_16_to_1[i] = (png_uint_16p)png_malloc(png_ptr,
+               (png_uint_32)(256 * sizeof (png_uint_16)));
+
+            ig = (((png_uint_32)i *
+               (png_uint_32)png_gamma_shift[shift]) >> 4);
+            for (j = 0; j < 256; j++)
+            {
+               png_ptr->gamma_16_to_1[i][j] =
+                  (png_uint_16)(pow((double)(ig + ((png_uint_32)j << 8)) /
+                     65535.0, g) * 65535.0 + .5);
+            }
+         }
+
+         if(png_ptr->screen_gamma > 0.000001)
+            g = 1.0 / png_ptr->screen_gamma;
+         else
+            g = png_ptr->gamma;   /* probably doing rgb_to_gray */
+
+         png_ptr->gamma_16_from_1 = (png_uint_16pp)png_malloc(png_ptr,
+            (png_uint_32)(num * sizeof (png_uint_16p)));
+
+         for (i = 0; i < num; i++)
+         {
+            png_ptr->gamma_16_from_1[i] = (png_uint_16p)png_malloc(png_ptr,
+               (png_uint_32)(256 * sizeof (png_uint_16)));
+
+            ig = (((png_uint_32)i *
+               (png_uint_32)png_gamma_shift[shift]) >> 4);
+            for (j = 0; j < 256; j++)
+            {
+               png_ptr->gamma_16_from_1[i][j] =
+                  (png_uint_16)(pow((double)(ig + ((png_uint_32)j << 8)) /
+                     65535.0, g) * 65535.0 + .5);
+            }
+         }
+      }
+#endif /* PNG_READ_BACKGROUND_SUPPORTED || PNG_RGB_TO_GRAY_SUPPORTED */
+   }
+ }
+}
+#endif
+/* To do: install integer version of png_build_gamma_table here */
+#endif
+
+#if defined(PNG_MNG_FEATURES_SUPPORTED)
+/* undoes intrapixel differencing  */
+void /* PRIVATE */
+png_do_read_intrapixel(png_row_infop row_info, png_bytep row)
+{
+   png_debug(1, "in png_do_read_intrapixel\n");
+   if (
+#if defined(PNG_USELESS_TESTS_SUPPORTED)
+       row != NULL && row_info != NULL &&
+#endif
+       (row_info->color_type & PNG_COLOR_MASK_COLOR))
+   {
+      int bytes_per_pixel;
+      png_uint_32 row_width = row_info->width;
+      if (row_info->bit_depth == 8)
+      {
+         png_bytep rp;
+         png_uint_32 i;
+
+         if (row_info->color_type == PNG_COLOR_TYPE_RGB)
+            bytes_per_pixel = 3;
+         else if (row_info->color_type == PNG_COLOR_TYPE_RGB_ALPHA)
+            bytes_per_pixel = 4;
+         else
+            return;
+
+         for (i = 0, rp = row; i < row_width; i++, rp += bytes_per_pixel)
+         {
+            *(rp) = (png_byte)((256 + *rp + *(rp+1))&0xff);
+            *(rp+2) = (png_byte)((256 + *(rp+2) + *(rp+1))&0xff);
+         }
+      }
+      else if (row_info->bit_depth == 16)
+      {
+         png_bytep rp;
+         png_uint_32 i;
+
+         if (row_info->color_type == PNG_COLOR_TYPE_RGB)
+            bytes_per_pixel = 6;
+         else if (row_info->color_type == PNG_COLOR_TYPE_RGB_ALPHA)
+            bytes_per_pixel = 8;
+         else
+            return;
+
+         for (i = 0, rp = row; i < row_width; i++, rp += bytes_per_pixel)
+         {
+            png_uint_32 s0=*(rp  )<<8 | *(rp+1);
+            png_uint_32 s1=*(rp+2)<<8 | *(rp+3);
+            png_uint_32 s2=*(rp+4)<<8 | *(rp+5);
+            png_uint_32 red=(65536+s0+s1)&0xffff;
+            png_uint_32 blue=(65536+s2+s1)&0xffff;
+            *(rp  ) = (png_byte)((red>>8)&0xff);
+            *(rp+1) = (png_byte)(red&0xff);
+            *(rp+4) = (png_byte)((blue>>8)&0xff);
+            *(rp+5) = (png_byte)(blue&0xff);
+         }
+      }
+   }
+}
+#endif /* PNG_MNG_FEATURES_SUPPORTED */
diff --git a/collects/plot/src/all/pngrutil.c b/collects/plot/src/all/pngrutil.c
new file mode 100644
index 0000000000..9cbfed65f0
--- /dev/null
+++ b/collects/plot/src/all/pngrutil.c
@@ -0,0 +1,3101 @@
+
+/* pngrutil.c - utilities to read a PNG file
+ *
+ * libpng 1.2.5 - October 3, 2002
+ * For conditions of distribution and use, see copyright notice in png.h
+ * Copyright (c) 1998-2002 Glenn Randers-Pehrson
+ * (Version 0.96 Copyright (c) 1996, 1997 Andreas Dilger)
+ * (Version 0.88 Copyright (c) 1995, 1996 Guy Eric Schalnat, Group 42, Inc.)
+ *
+ * This file contains routines that are only called from within
+ * libpng itself during the course of reading an image.
+ */
+
+#define PNG_INTERNAL
+#include "png.h"
+
+#if defined(_WIN32_WCE)
+/* strtod() function is not supported on WindowsCE */
+#  ifdef PNG_FLOATING_POINT_SUPPORTED
+__inline double strtod(const char *nptr, char **endptr)
+{
+   double result = 0;
+   int len;
+   wchar_t *str, *end;
+
+   len = MultiByteToWideChar(CP_ACP, 0, nptr, -1, NULL, 0);
+   str = (wchar_t *)malloc(len * sizeof(wchar_t));
+   if ( NULL != str )
+   {
+      MultiByteToWideChar(CP_ACP, 0, nptr, -1, str, len);
+      result = wcstod(str, &end);
+      len = WideCharToMultiByte(CP_ACP, 0, end, -1, NULL, 0, NULL, NULL);
+      *endptr = (char *)nptr + (png_strlen(nptr) - len + 1);
+      free(str);
+   }
+   return result;
+}
+#  endif
+#endif
+
+#ifndef PNG_READ_BIG_ENDIAN_SUPPORTED
+/* Grab an unsigned 32-bit integer from a buffer in big-endian format. */
+png_uint_32 /* PRIVATE */
+png_get_uint_32(png_bytep buf)
+{
+   png_uint_32 i = ((png_uint_32)(*buf) << 24) +
+      ((png_uint_32)(*(buf + 1)) << 16) +
+      ((png_uint_32)(*(buf + 2)) << 8) +
+      (png_uint_32)(*(buf + 3));
+
+   return (i);
+}
+
+#if defined(PNG_READ_pCAL_SUPPORTED) || defined(PNG_READ_oFFs_SUPPORTED)
+/* Grab a signed 32-bit integer from a buffer in big-endian format.  The
+ * data is stored in the PNG file in two's complement format, and it is
+ * assumed that the machine format for signed integers is the same. */
+png_int_32 /* PRIVATE */
+png_get_int_32(png_bytep buf)
+{
+   png_int_32 i = ((png_int_32)(*buf) << 24) +
+      ((png_int_32)(*(buf + 1)) << 16) +
+      ((png_int_32)(*(buf + 2)) << 8) +
+      (png_int_32)(*(buf + 3));
+
+   return (i);
+}
+#endif /* PNG_READ_pCAL_SUPPORTED */
+
+/* Grab an unsigned 16-bit integer from a buffer in big-endian format. */
+png_uint_16 /* PRIVATE */
+png_get_uint_16(png_bytep buf)
+{
+   png_uint_16 i = (png_uint_16)(((png_uint_16)(*buf) << 8) +
+      (png_uint_16)(*(buf + 1)));
+
+   return (i);
+}
+#endif /* PNG_READ_BIG_ENDIAN_SUPPORTED */
+
+/* Read data, and (optionally) run it through the CRC. */
+void /* PRIVATE */
+png_crc_read(png_structp png_ptr, png_bytep buf, png_size_t length)
+{
+   png_read_data(png_ptr, buf, length);
+   png_calculate_crc(png_ptr, buf, length);
+}
+
+/* Optionally skip data and then check the CRC.  Depending on whether we
+   are reading a ancillary or critical chunk, and how the program has set
+   things up, we may calculate the CRC on the data and print a message.
+   Returns '1' if there was a CRC error, '0' otherwise. */
+int /* PRIVATE */
+png_crc_finish(png_structp png_ptr, png_uint_32 skip)
+{
+   png_size_t i;
+   png_size_t istop = png_ptr->zbuf_size;
+
+   for (i = (png_size_t)skip; i > istop; i -= istop)
+   {
+      png_crc_read(png_ptr, png_ptr->zbuf, png_ptr->zbuf_size);
+   }
+   if (i)
+   {
+      png_crc_read(png_ptr, png_ptr->zbuf, i);
+   }
+
+   if (png_crc_error(png_ptr))
+   {
+      if (((png_ptr->chunk_name[0] & 0x20) &&                /* Ancillary */
+           !(png_ptr->flags & PNG_FLAG_CRC_ANCILLARY_NOWARN)) ||
+          (!(png_ptr->chunk_name[0] & 0x20) &&             /* Critical  */
+          (png_ptr->flags & PNG_FLAG_CRC_CRITICAL_USE)))
+      {
+         png_chunk_warning(png_ptr, "CRC error");
+      }
+      else
+      {
+         png_chunk_error(png_ptr, "CRC error");
+      }
+      return (1);
+   }
+
+   return (0);
+}
+
+/* Compare the CRC stored in the PNG file with that calculated by libpng from
+   the data it has read thus far. */
+int /* PRIVATE */
+png_crc_error(png_structp png_ptr)
+{
+   png_byte crc_bytes[4];
+   png_uint_32 crc;
+   int need_crc = 1;
+
+   if (png_ptr->chunk_name[0] & 0x20)                     /* ancillary */
+   {
+      if ((png_ptr->flags & PNG_FLAG_CRC_ANCILLARY_MASK) ==
+          (PNG_FLAG_CRC_ANCILLARY_USE | PNG_FLAG_CRC_ANCILLARY_NOWARN))
+         need_crc = 0;
+   }
+   else                                                    /* critical */
+   {
+      if (png_ptr->flags & PNG_FLAG_CRC_CRITICAL_IGNORE)
+         need_crc = 0;
+   }
+
+   png_read_data(png_ptr, crc_bytes, 4);
+
+   if (need_crc)
+   {
+      crc = png_get_uint_32(crc_bytes);
+      return ((int)(crc != png_ptr->crc));
+   }
+   else
+      return (0);
+}
+
+#if defined(PNG_READ_zTXt_SUPPORTED) || defined(PNG_READ_iTXt_SUPPORTED) || \
+    defined(PNG_READ_iCCP_SUPPORTED)
+/*
+ * Decompress trailing data in a chunk.  The assumption is that chunkdata
+ * points at an allocated area holding the contents of a chunk with a
+ * trailing compressed part.  What we get back is an allocated area
+ * holding the original prefix part and an uncompressed version of the
+ * trailing part (the malloc area passed in is freed).
+ */
+png_charp /* PRIVATE */
+png_decompress_chunk(png_structp png_ptr, int comp_type,
+                              png_charp chunkdata, png_size_t chunklength,
+                              png_size_t prefix_size, png_size_t *newlength)
+{
+   static char msg[] = "Error decoding compressed text";
+   png_charp text = NULL;
+   png_size_t text_size;
+
+   if (comp_type == PNG_COMPRESSION_TYPE_BASE)
+   {
+      int ret = Z_OK;
+      png_ptr->zstream.next_in = (png_bytep)(chunkdata + prefix_size);
+      png_ptr->zstream.avail_in = (uInt)(chunklength - prefix_size);
+      png_ptr->zstream.next_out = png_ptr->zbuf;
+      png_ptr->zstream.avail_out = (uInt)png_ptr->zbuf_size;
+
+      text_size = 0;
+      text = NULL;
+
+      while (png_ptr->zstream.avail_in)
+      {
+         ret = inflate(&png_ptr->zstream, Z_PARTIAL_FLUSH);
+         if (ret != Z_OK && ret != Z_STREAM_END)
+         {
+            if (png_ptr->zstream.msg != NULL)
+               png_warning(png_ptr, png_ptr->zstream.msg);
+            else
+               png_warning(png_ptr, msg);
+            inflateReset(&png_ptr->zstream);
+            png_ptr->zstream.avail_in = 0;
+
+            if (text ==  NULL)
+            {
+               text_size = prefix_size + sizeof(msg) + 1;
+               text = (png_charp)png_malloc_warn(png_ptr, text_size);
+               if (text ==  NULL)
+                 {
+                    png_free(png_ptr,chunkdata);
+                    png_error(png_ptr,"Not enough memory to decompress chunk");
+                 }
+               png_memcpy(text, chunkdata, prefix_size);
+            }
+
+            text[text_size - 1] = 0x00;
+
+            /* Copy what we can of the error message into the text chunk */
+            text_size = (png_size_t)(chunklength - (text - chunkdata) - 1);
+            text_size = sizeof(msg) > text_size ? text_size : sizeof(msg);
+            png_memcpy(text + prefix_size, msg, text_size + 1);
+            break;
+         }
+         if (!png_ptr->zstream.avail_out || ret == Z_STREAM_END)
+         {
+            if (text == NULL)
+            {
+               text_size = prefix_size +
+                   png_ptr->zbuf_size - png_ptr->zstream.avail_out;
+               text = (png_charp)png_malloc_warn(png_ptr, text_size + 1);
+               if (text ==  NULL)
+                 {
+                    png_free(png_ptr,chunkdata);
+                    png_error(png_ptr,"Not enough memory to decompress chunk.");
+                 }
+               png_memcpy(text + prefix_size, png_ptr->zbuf,
+                    text_size - prefix_size);
+               png_memcpy(text, chunkdata, prefix_size);
+               *(text + text_size) = 0x00;
+            }
+            else
+            {
+               png_charp tmp;
+
+               tmp = text;
+               text = (png_charp)png_malloc_warn(png_ptr,
+                  (png_uint_32)(text_size +
+                  png_ptr->zbuf_size - png_ptr->zstream.avail_out + 1));
+               if (text == NULL)
+               {
+                  png_free(png_ptr, tmp);
+                  png_free(png_ptr, chunkdata);
+                  png_error(png_ptr,"Not enough memory to decompress chunk..");
+               }
+               png_memcpy(text, tmp, text_size);
+               png_free(png_ptr, tmp);
+               png_memcpy(text + text_size, png_ptr->zbuf,
+                  (png_ptr->zbuf_size - png_ptr->zstream.avail_out));
+               text_size += png_ptr->zbuf_size - png_ptr->zstream.avail_out;
+               *(text + text_size) = 0x00;
+            }
+            if (ret == Z_STREAM_END)
+               break;
+            else
+            {
+               png_ptr->zstream.next_out = png_ptr->zbuf;
+               png_ptr->zstream.avail_out = (uInt)png_ptr->zbuf_size;
+            }
+         }
+      }
+      if (ret != Z_STREAM_END)
+      {
+#if !defined(PNG_NO_STDIO) && !defined(_WIN32_WCE)
+         char umsg[50];
+
+         if (ret == Z_BUF_ERROR)
+            sprintf(umsg,"Buffer error in compressed datastream in %s chunk",
+                png_ptr->chunk_name);
+         else if (ret == Z_DATA_ERROR)
+            sprintf(umsg,"Data error in compressed datastream in %s chunk",
+                png_ptr->chunk_name);
+         else
+            sprintf(umsg,"Incomplete compressed datastream in %s chunk",
+                png_ptr->chunk_name);
+         png_warning(png_ptr, umsg);
+#else
+         png_warning(png_ptr,
+            "Incomplete compressed datastream in chunk other than IDAT");
+#endif
+         text_size=prefix_size;
+         if (text ==  NULL)
+         {
+            text = (png_charp)png_malloc_warn(png_ptr, text_size+1);
+            if (text == NULL)
+              {
+                png_free(png_ptr, chunkdata);
+                png_error(png_ptr,"Not enough memory for text.");
+              }
+            png_memcpy(text, chunkdata, prefix_size);
+         }
+         *(text + text_size) = 0x00;
+      }
+
+      inflateReset(&png_ptr->zstream);
+      png_ptr->zstream.avail_in = 0;
+
+      png_free(png_ptr, chunkdata);
+      chunkdata = text;
+      *newlength=text_size;
+   }
+   else /* if (comp_type != PNG_COMPRESSION_TYPE_BASE) */
+   {
+#if !defined(PNG_NO_STDIO) && !defined(_WIN32_WCE)
+      char umsg[50];
+
+      sprintf(umsg, "Unknown zTXt compression type %d", comp_type);
+      png_warning(png_ptr, umsg);
+#else
+      png_warning(png_ptr, "Unknown zTXt compression type");
+#endif
+
+      *(chunkdata + prefix_size) = 0x00;
+      *newlength=prefix_size;
+   }
+
+   return chunkdata;
+}
+#endif
+
+/* read and check the IDHR chunk */
+void /* PRIVATE */
+png_handle_IHDR(png_structp png_ptr, png_infop info_ptr, png_uint_32 length)
+{
+   png_byte buf[13];
+   png_uint_32 width, height;
+   int bit_depth, color_type, compression_type, filter_type;
+   int interlace_type;
+
+   png_debug(1, "in png_handle_IHDR\n");
+
+   if (png_ptr->mode & PNG_HAVE_IHDR)
+      png_error(png_ptr, "Out of place IHDR");
+
+   /* check the length */
+   if (length != 13)
+      png_error(png_ptr, "Invalid IHDR chunk");
+
+   png_ptr->mode |= PNG_HAVE_IHDR;
+
+   png_crc_read(png_ptr, buf, 13);
+   png_crc_finish(png_ptr, 0);
+
+   width = png_get_uint_32(buf);
+   height = png_get_uint_32(buf + 4);
+   bit_depth = buf[8];
+   color_type = buf[9];
+   compression_type = buf[10];
+   filter_type = buf[11];
+   interlace_type = buf[12];
+
+
+   /* set internal variables */
+   png_ptr->width = width;
+   png_ptr->height = height;
+   png_ptr->bit_depth = (png_byte)bit_depth;
+   png_ptr->interlaced = (png_byte)interlace_type;
+   png_ptr->color_type = (png_byte)color_type;
+#if defined(PNG_MNG_FEATURES_SUPPORTED)
+   png_ptr->filter_type = (png_byte)filter_type;
+#endif
+
+   /* find number of channels */
+   switch (png_ptr->color_type)
+   {
+      case PNG_COLOR_TYPE_GRAY:
+      case PNG_COLOR_TYPE_PALETTE:
+         png_ptr->channels = 1;
+         break;
+      case PNG_COLOR_TYPE_RGB:
+         png_ptr->channels = 3;
+         break;
+      case PNG_COLOR_TYPE_GRAY_ALPHA:
+         png_ptr->channels = 2;
+         break;
+      case PNG_COLOR_TYPE_RGB_ALPHA:
+         png_ptr->channels = 4;
+         break;
+   }
+
+   /* set up other useful info */
+   png_ptr->pixel_depth = (png_byte)(png_ptr->bit_depth *
+   png_ptr->channels);
+   png_ptr->rowbytes = ((png_ptr->width *
+      (png_uint_32)png_ptr->pixel_depth + 7) >> 3);
+   png_debug1(3,"bit_depth = %d\n", png_ptr->bit_depth);
+   png_debug1(3,"channels = %d\n", png_ptr->channels);
+   png_debug1(3,"rowbytes = %lu\n", png_ptr->rowbytes);
+   png_set_IHDR(png_ptr, info_ptr, width, height, bit_depth,
+      color_type, interlace_type, compression_type, filter_type);
+}
+
+/* read and check the palette */
+void /* PRIVATE */
+png_handle_PLTE(png_structp png_ptr, png_infop info_ptr, png_uint_32 length)
+{
+   png_color palette[PNG_MAX_PALETTE_LENGTH];
+   int num, i;
+#ifndef PNG_NO_POINTER_INDEXING
+   png_colorp pal_ptr;
+#endif
+
+   png_debug(1, "in png_handle_PLTE\n");
+
+   if (!(png_ptr->mode & PNG_HAVE_IHDR))
+      png_error(png_ptr, "Missing IHDR before PLTE");
+   else if (png_ptr->mode & PNG_HAVE_IDAT)
+   {
+      png_warning(png_ptr, "Invalid PLTE after IDAT");
+      png_crc_finish(png_ptr, length);
+      return;
+   }
+   else if (png_ptr->mode & PNG_HAVE_PLTE)
+      png_error(png_ptr, "Duplicate PLTE chunk");
+
+   png_ptr->mode |= PNG_HAVE_PLTE;
+
+   if (!(png_ptr->color_type&PNG_COLOR_MASK_COLOR))
+   {
+      png_warning(png_ptr,
+        "Ignoring PLTE chunk in grayscale PNG");
+      png_crc_finish(png_ptr, length);
+      return;
+   }
+#if !defined(PNG_READ_OPT_PLTE_SUPPORTED)
+   if (png_ptr->color_type != PNG_COLOR_TYPE_PALETTE)
+   {
+      png_crc_finish(png_ptr, length);
+      return;
+   }
+#endif
+
+   if (length > 3*PNG_MAX_PALETTE_LENGTH || length % 3)
+   {
+      if (png_ptr->color_type != PNG_COLOR_TYPE_PALETTE)
+      {
+         png_warning(png_ptr, "Invalid palette chunk");
+         png_crc_finish(png_ptr, length);
+         return;
+      }
+      else
+      {
+         png_error(png_ptr, "Invalid palette chunk");
+      }
+   }
+
+   num = (int)length / 3;
+
+#ifndef PNG_NO_POINTER_INDEXING
+   for (i = 0, pal_ptr = palette; i < num; i++, pal_ptr++)
+   {
+      png_byte buf[3];
+
+      png_crc_read(png_ptr, buf, 3);
+      pal_ptr->red = buf[0];
+      pal_ptr->green = buf[1];
+      pal_ptr->blue = buf[2];
+   }
+#else
+   for (i = 0; i < num; i++)
+   {
+      png_byte buf[3];
+
+      png_crc_read(png_ptr, buf, 3);
+      /* don't depend upon png_color being any order */
+      palette[i].red = buf[0];
+      palette[i].green = buf[1];
+      palette[i].blue = buf[2];
+   }
+#endif
+
+   /* If we actually NEED the PLTE chunk (ie for a paletted image), we do
+      whatever the normal CRC configuration tells us.  However, if we
+      have an RGB image, the PLTE can be considered ancillary, so
+      we will act as though it is. */
+#if !defined(PNG_READ_OPT_PLTE_SUPPORTED)
+   if (png_ptr->color_type == PNG_COLOR_TYPE_PALETTE)
+#endif
+   {
+      png_crc_finish(png_ptr, 0);
+   }
+#if !defined(PNG_READ_OPT_PLTE_SUPPORTED)
+   else if (png_crc_error(png_ptr))  /* Only if we have a CRC error */
+   {
+      /* If we don't want to use the data from an ancillary chunk,
+         we have two options: an error abort, or a warning and we
+         ignore the data in this chunk (which should be OK, since
+         it's considered ancillary for a RGB or RGBA image). */
+      if (!(png_ptr->flags & PNG_FLAG_CRC_ANCILLARY_USE))
+      {
+         if (png_ptr->flags & PNG_FLAG_CRC_ANCILLARY_NOWARN)
+         {
+            png_chunk_error(png_ptr, "CRC error");
+         }
+         else
+         {
+            png_chunk_warning(png_ptr, "CRC error");
+            return;
+         }
+      }
+      /* Otherwise, we (optionally) emit a warning and use the chunk. */
+      else if (!(png_ptr->flags & PNG_FLAG_CRC_ANCILLARY_NOWARN))
+      {
+         png_chunk_warning(png_ptr, "CRC error");
+      }
+   }
+#endif
+
+   png_set_PLTE(png_ptr, info_ptr, palette, num);
+
+#if defined(PNG_READ_tRNS_SUPPORTED)
+   if (png_ptr->color_type == PNG_COLOR_TYPE_PALETTE)
+   {
+      if (info_ptr != NULL && (info_ptr->valid & PNG_INFO_tRNS))
+      {
+         if (png_ptr->num_trans > (png_uint_16)num)
+         {
+            png_warning(png_ptr, "Truncating incorrect tRNS chunk length");
+            png_ptr->num_trans = (png_uint_16)num;
+         }
+         if (info_ptr->num_trans > (png_uint_16)num)
+         {
+            png_warning(png_ptr, "Truncating incorrect info tRNS chunk length");
+            info_ptr->num_trans = (png_uint_16)num;
+         }
+      }
+   }
+#endif
+
+}
+
+void /* PRIVATE */
+png_handle_IEND(png_structp png_ptr, png_infop info_ptr, png_uint_32 length)
+{
+   png_debug(1, "in png_handle_IEND\n");
+
+   if (!(png_ptr->mode & PNG_HAVE_IHDR) || !(png_ptr->mode & PNG_HAVE_IDAT))
+   {
+      png_error(png_ptr, "No image in file");
+
+      info_ptr = info_ptr; /* quiet compiler warnings about unused info_ptr */
+   }
+
+   png_ptr->mode |= (PNG_AFTER_IDAT | PNG_HAVE_IEND);
+
+   if (length != 0)
+   {
+      png_warning(png_ptr, "Incorrect IEND chunk length");
+   }
+   png_crc_finish(png_ptr, length);
+}
+
+#if defined(PNG_READ_gAMA_SUPPORTED)
+void /* PRIVATE */
+png_handle_gAMA(png_structp png_ptr, png_infop info_ptr, png_uint_32 length)
+{
+   png_fixed_point igamma;
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+   float file_gamma;
+#endif
+   png_byte buf[4];
+
+   png_debug(1, "in png_handle_gAMA\n");
+
+   if (!(png_ptr->mode & PNG_HAVE_IHDR))
+      png_error(png_ptr, "Missing IHDR before gAMA");
+   else if (png_ptr->mode & PNG_HAVE_IDAT)
+   {
+      png_warning(png_ptr, "Invalid gAMA after IDAT");
+      png_crc_finish(png_ptr, length);
+      return;
+   }
+   else if (png_ptr->mode & PNG_HAVE_PLTE)
+      /* Should be an error, but we can cope with it */
+      png_warning(png_ptr, "Out of place gAMA chunk");
+
+   else if (info_ptr != NULL && (info_ptr->valid & PNG_INFO_gAMA)
+#if defined(PNG_READ_sRGB_SUPPORTED)
+      && !(info_ptr->valid & PNG_INFO_sRGB)
+#endif
+      )
+   {
+      png_warning(png_ptr, "Duplicate gAMA chunk");
+      png_crc_finish(png_ptr, length);
+      return;
+   }
+
+   if (length != 4)
+   {
+      png_warning(png_ptr, "Incorrect gAMA chunk length");
+      png_crc_finish(png_ptr, length);
+      return;
+   }
+
+   png_crc_read(png_ptr, buf, 4);
+   if (png_crc_finish(png_ptr, 0))
+      return;
+
+   igamma = (png_fixed_point)png_get_uint_32(buf);
+   /* check for zero gamma */
+   if (igamma == 0)
+      {
+         png_warning(png_ptr,
+           "Ignoring gAMA chunk with gamma=0");
+         return;
+      }
+
+#if defined(PNG_READ_sRGB_SUPPORTED)
+   if (info_ptr->valid & PNG_INFO_sRGB)
+      if(igamma < 45000L || igamma > 46000L)
+      {
+         png_warning(png_ptr,
+           "Ignoring incorrect gAMA value when sRGB is also present");
+#ifndef PNG_NO_CONSOLE_IO
+         fprintf(stderr, "gamma = (%d/100000)\n", (int)igamma);
+#endif
+         return;
+      }
+#endif /* PNG_READ_sRGB_SUPPORTED */
+
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+   file_gamma = (float)igamma / (float)100000.0;
+#  ifdef PNG_READ_GAMMA_SUPPORTED
+     png_ptr->gamma = file_gamma;
+#  endif
+     png_set_gAMA(png_ptr, info_ptr, file_gamma);
+#endif
+#ifdef PNG_FIXED_POINT_SUPPORTED
+   png_set_gAMA_fixed(png_ptr, info_ptr, igamma);
+#endif
+}
+#endif
+
+#if defined(PNG_READ_sBIT_SUPPORTED)
+void /* PRIVATE */
+png_handle_sBIT(png_structp png_ptr, png_infop info_ptr, png_uint_32 length)
+{
+   png_size_t truelen;
+   png_byte buf[4];
+
+   png_debug(1, "in png_handle_sBIT\n");
+
+   buf[0] = buf[1] = buf[2] = buf[3] = 0;
+
+   if (!(png_ptr->mode & PNG_HAVE_IHDR))
+      png_error(png_ptr, "Missing IHDR before sBIT");
+   else if (png_ptr->mode & PNG_HAVE_IDAT)
+   {
+      png_warning(png_ptr, "Invalid sBIT after IDAT");
+      png_crc_finish(png_ptr, length);
+      return;
+   }
+   else if (png_ptr->mode & PNG_HAVE_PLTE)
+   {
+      /* Should be an error, but we can cope with it */
+      png_warning(png_ptr, "Out of place sBIT chunk");
+   }
+   else if (info_ptr != NULL && (info_ptr->valid & PNG_INFO_sBIT))
+   {
+      png_warning(png_ptr, "Duplicate sBIT chunk");
+      png_crc_finish(png_ptr, length);
+      return;
+   }
+
+   if (png_ptr->color_type == PNG_COLOR_TYPE_PALETTE)
+      truelen = 3;
+   else
+      truelen = (png_size_t)png_ptr->channels;
+
+   if (length != truelen)
+   {
+      png_warning(png_ptr, "Incorrect sBIT chunk length");
+      png_crc_finish(png_ptr, length);
+      return;
+   }
+
+   png_crc_read(png_ptr, buf, truelen);
+   if (png_crc_finish(png_ptr, 0))
+      return;
+
+   if (png_ptr->color_type & PNG_COLOR_MASK_COLOR)
+   {
+      png_ptr->sig_bit.red = buf[0];
+      png_ptr->sig_bit.green = buf[1];
+      png_ptr->sig_bit.blue = buf[2];
+      png_ptr->sig_bit.alpha = buf[3];
+   }
+   else
+   {
+      png_ptr->sig_bit.gray = buf[0];
+      png_ptr->sig_bit.red = buf[0];
+      png_ptr->sig_bit.green = buf[0];
+      png_ptr->sig_bit.blue = buf[0];
+      png_ptr->sig_bit.alpha = buf[1];
+   }
+   png_set_sBIT(png_ptr, info_ptr, &(png_ptr->sig_bit));
+}
+#endif
+
+#if defined(PNG_READ_cHRM_SUPPORTED)
+void /* PRIVATE */
+png_handle_cHRM(png_structp png_ptr, png_infop info_ptr, png_uint_32 length)
+{
+   png_byte buf[4];
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+   float white_x, white_y, red_x, red_y, green_x, green_y, blue_x, blue_y;
+#endif
+   png_fixed_point int_x_white, int_y_white, int_x_red, int_y_red, int_x_green,
+      int_y_green, int_x_blue, int_y_blue;
+
+   png_uint_32 uint_x, uint_y;
+
+   png_debug(1, "in png_handle_cHRM\n");
+
+   if (!(png_ptr->mode & PNG_HAVE_IHDR))
+      png_error(png_ptr, "Missing IHDR before cHRM");
+   else if (png_ptr->mode & PNG_HAVE_IDAT)
+   {
+      png_warning(png_ptr, "Invalid cHRM after IDAT");
+      png_crc_finish(png_ptr, length);
+      return;
+   }
+   else if (png_ptr->mode & PNG_HAVE_PLTE)
+      /* Should be an error, but we can cope with it */
+      png_warning(png_ptr, "Missing PLTE before cHRM");
+
+   else if (info_ptr != NULL && (info_ptr->valid & PNG_INFO_cHRM)
+#if defined(PNG_READ_sRGB_SUPPORTED)
+      && !(info_ptr->valid & PNG_INFO_sRGB)
+#endif
+      )
+   {
+      png_warning(png_ptr, "Duplicate cHRM chunk");
+      png_crc_finish(png_ptr, length);
+      return;
+   }
+
+   if (length != 32)
+   {
+      png_warning(png_ptr, "Incorrect cHRM chunk length");
+      png_crc_finish(png_ptr, length);
+      return;
+   }
+
+   png_crc_read(png_ptr, buf, 4);
+   uint_x = png_get_uint_32(buf);
+
+   png_crc_read(png_ptr, buf, 4);
+   uint_y = png_get_uint_32(buf);
+
+   if (uint_x > 80000L || uint_y > 80000L ||
+      uint_x + uint_y > 100000L)
+   {
+      png_warning(png_ptr, "Invalid cHRM white point");
+      png_crc_finish(png_ptr, 24);
+      return;
+   }
+   int_x_white = (png_fixed_point)uint_x;
+   int_y_white = (png_fixed_point)uint_y;
+
+   png_crc_read(png_ptr, buf, 4);
+   uint_x = png_get_uint_32(buf);
+
+   png_crc_read(png_ptr, buf, 4);
+   uint_y = png_get_uint_32(buf);
+
+   if (uint_x > 80000L || uint_y > 80000L ||
+      uint_x + uint_y > 100000L)
+   {
+      png_warning(png_ptr, "Invalid cHRM red point");
+      png_crc_finish(png_ptr, 16);
+      return;
+   }
+   int_x_red = (png_fixed_point)uint_x;
+   int_y_red = (png_fixed_point)uint_y;
+
+   png_crc_read(png_ptr, buf, 4);
+   uint_x = png_get_uint_32(buf);
+
+   png_crc_read(png_ptr, buf, 4);
+   uint_y = png_get_uint_32(buf);
+
+   if (uint_x > 80000L || uint_y > 80000L ||
+      uint_x + uint_y > 100000L)
+   {
+      png_warning(png_ptr, "Invalid cHRM green point");
+      png_crc_finish(png_ptr, 8);
+      return;
+   }
+   int_x_green = (png_fixed_point)uint_x;
+   int_y_green = (png_fixed_point)uint_y;
+
+   png_crc_read(png_ptr, buf, 4);
+   uint_x = png_get_uint_32(buf);
+
+   png_crc_read(png_ptr, buf, 4);
+   uint_y = png_get_uint_32(buf);
+
+   if (uint_x > 80000L || uint_y > 80000L ||
+      uint_x + uint_y > 100000L)
+   {
+      png_warning(png_ptr, "Invalid cHRM blue point");
+      png_crc_finish(png_ptr, 0);
+      return;
+   }
+   int_x_blue = (png_fixed_point)uint_x;
+   int_y_blue = (png_fixed_point)uint_y;
+
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+   white_x = (float)int_x_white / (float)100000.0;
+   white_y = (float)int_y_white / (float)100000.0;
+   red_x   = (float)int_x_red   / (float)100000.0;
+   red_y   = (float)int_y_red   / (float)100000.0;
+   green_x = (float)int_x_green / (float)100000.0;
+   green_y = (float)int_y_green / (float)100000.0;
+   blue_x  = (float)int_x_blue  / (float)100000.0;
+   blue_y  = (float)int_y_blue  / (float)100000.0;
+#endif
+
+#if defined(PNG_READ_sRGB_SUPPORTED)
+   if (info_ptr->valid & PNG_INFO_sRGB)
+      {
+      if (abs(int_x_white - 31270L) > 1000 ||
+          abs(int_y_white - 32900L) > 1000 ||
+          abs(int_x_red   - 64000L) > 1000 ||
+          abs(int_y_red   - 33000L) > 1000 ||
+          abs(int_x_green - 30000L) > 1000 ||
+          abs(int_y_green - 60000L) > 1000 ||
+          abs(int_x_blue  - 15000L) > 1000 ||
+          abs(int_y_blue  -  6000L) > 1000)
+         {
+
+            png_warning(png_ptr,
+              "Ignoring incorrect cHRM value when sRGB is also present");
+#ifndef PNG_NO_CONSOLE_IO
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+            fprintf(stderr,"wx=%f, wy=%f, rx=%f, ry=%f\n",
+               white_x, white_y, red_x, red_y);
+            fprintf(stderr,"gx=%f, gy=%f, bx=%f, by=%f\n",
+               green_x, green_y, blue_x, blue_y);
+#else
+            fprintf(stderr,"wx=%ld, wy=%ld, rx=%ld, ry=%ld\n",
+               int_x_white, int_y_white, int_x_red, int_y_red);
+            fprintf(stderr,"gx=%ld, gy=%ld, bx=%ld, by=%ld\n",
+               int_x_green, int_y_green, int_x_blue, int_y_blue);
+#endif
+#endif /* PNG_NO_CONSOLE_IO */
+         }
+         png_crc_finish(png_ptr, 0);
+         return;
+      }
+#endif /* PNG_READ_sRGB_SUPPORTED */
+
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+   png_set_cHRM(png_ptr, info_ptr,
+      white_x, white_y, red_x, red_y, green_x, green_y, blue_x, blue_y);
+#endif
+#ifdef PNG_FIXED_POINT_SUPPORTED
+   png_set_cHRM_fixed(png_ptr, info_ptr,
+      int_x_white, int_y_white, int_x_red, int_y_red, int_x_green,
+      int_y_green, int_x_blue, int_y_blue);
+#endif
+   if (png_crc_finish(png_ptr, 0))
+      return;
+}
+#endif
+
+#if defined(PNG_READ_sRGB_SUPPORTED)
+void /* PRIVATE */
+png_handle_sRGB(png_structp png_ptr, png_infop info_ptr, png_uint_32 length)
+{
+   int intent;
+   png_byte buf[1];
+
+   png_debug(1, "in png_handle_sRGB\n");
+
+   if (!(png_ptr->mode & PNG_HAVE_IHDR))
+      png_error(png_ptr, "Missing IHDR before sRGB");
+   else if (png_ptr->mode & PNG_HAVE_IDAT)
+   {
+      png_warning(png_ptr, "Invalid sRGB after IDAT");
+      png_crc_finish(png_ptr, length);
+      return;
+   }
+   else if (png_ptr->mode & PNG_HAVE_PLTE)
+      /* Should be an error, but we can cope with it */
+      png_warning(png_ptr, "Out of place sRGB chunk");
+
+   else if (info_ptr != NULL && (info_ptr->valid & PNG_INFO_sRGB))
+   {
+      png_warning(png_ptr, "Duplicate sRGB chunk");
+      png_crc_finish(png_ptr, length);
+      return;
+   }
+
+   if (length != 1)
+   {
+      png_warning(png_ptr, "Incorrect sRGB chunk length");
+      png_crc_finish(png_ptr, length);
+      return;
+   }
+
+   png_crc_read(png_ptr, buf, 1);
+   if (png_crc_finish(png_ptr, 0))
+      return;
+
+   intent = buf[0];
+   /* check for bad intent */
+   if (intent >= PNG_sRGB_INTENT_LAST)
+   {
+      png_warning(png_ptr, "Unknown sRGB intent");
+      return;
+   }
+
+#if defined(PNG_READ_gAMA_SUPPORTED) && defined(PNG_READ_GAMMA_SUPPORTED)
+   if ((info_ptr->valid & PNG_INFO_gAMA))
+   {
+   int igamma;
+#ifdef PNG_FIXED_POINT_SUPPORTED
+      igamma=(int)info_ptr->int_gamma;
+#else
+#  ifdef PNG_FLOATING_POINT_SUPPORTED
+      igamma=(int)(info_ptr->gamma * 100000.);
+#  endif
+#endif
+      if(igamma < 45000L || igamma > 46000L)
+      {
+         png_warning(png_ptr,
+           "Ignoring incorrect gAMA value when sRGB is also present");
+#ifndef PNG_NO_CONSOLE_IO
+#  ifdef PNG_FIXED_POINT_SUPPORTED
+         fprintf(stderr,"incorrect gamma=(%d/100000)\n",(int)png_ptr->int_gamma);
+#  else
+#    ifdef PNG_FLOATING_POINT_SUPPORTED
+         fprintf(stderr,"incorrect gamma=%f\n",png_ptr->gamma);
+#    endif
+#  endif
+#endif
+      }
+   }
+#endif /* PNG_READ_gAMA_SUPPORTED */
+
+#ifdef PNG_READ_cHRM_SUPPORTED
+#ifdef PNG_FIXED_POINT_SUPPORTED
+   if (info_ptr->valid & PNG_INFO_cHRM)
+      if (abs(info_ptr->int_x_white - 31270L) > 1000 ||
+          abs(info_ptr->int_y_white - 32900L) > 1000 ||
+          abs(info_ptr->int_x_red   - 64000L) > 1000 ||
+          abs(info_ptr->int_y_red   - 33000L) > 1000 ||
+          abs(info_ptr->int_x_green - 30000L) > 1000 ||
+          abs(info_ptr->int_y_green - 60000L) > 1000 ||
+          abs(info_ptr->int_x_blue  - 15000L) > 1000 ||
+          abs(info_ptr->int_y_blue  -  6000L) > 1000)
+         {
+            png_warning(png_ptr,
+              "Ignoring incorrect cHRM value when sRGB is also present");
+         }
+#endif /* PNG_FIXED_POINT_SUPPORTED */
+#endif /* PNG_READ_cHRM_SUPPORTED */
+
+   png_set_sRGB_gAMA_and_cHRM(png_ptr, info_ptr, intent);
+}
+#endif /* PNG_READ_sRGB_SUPPORTED */
+
+#if defined(PNG_READ_iCCP_SUPPORTED)
+void /* PRIVATE */
+png_handle_iCCP(png_structp png_ptr, png_infop info_ptr, png_uint_32 length)
+/* Note: this does not properly handle chunks that are > 64K under DOS */
+{
+   png_charp chunkdata;
+   png_byte compression_type;
+   png_bytep pC;
+   png_charp profile;
+   png_uint_32 skip = 0;
+   png_uint_32 profile_size = 0;
+   png_uint_32 profile_length = 0;
+   png_size_t slength, prefix_length, data_length;
+
+   png_debug(1, "in png_handle_iCCP\n");
+
+   if (!(png_ptr->mode & PNG_HAVE_IHDR))
+      png_error(png_ptr, "Missing IHDR before iCCP");
+   else if (png_ptr->mode & PNG_HAVE_IDAT)
+   {
+      png_warning(png_ptr, "Invalid iCCP after IDAT");
+      png_crc_finish(png_ptr, length);
+      return;
+   }
+   else if (png_ptr->mode & PNG_HAVE_PLTE)
+      /* Should be an error, but we can cope with it */
+      png_warning(png_ptr, "Out of place iCCP chunk");
+
+   else if (info_ptr != NULL && (info_ptr->valid & PNG_INFO_iCCP))
+   {
+      png_warning(png_ptr, "Duplicate iCCP chunk");
+      png_crc_finish(png_ptr, length);
+      return;
+   }
+
+#ifdef PNG_MAX_MALLOC_64K
+   if (length > (png_uint_32)65535L)
+   {
+      png_warning(png_ptr, "iCCP chunk too large to fit in memory");
+      skip = length - (png_uint_32)65535L;
+      length = (png_uint_32)65535L;
+   }
+#endif
+
+   chunkdata = (png_charp)png_malloc(png_ptr, length + 1);
+   slength = (png_size_t)length;
+   png_crc_read(png_ptr, (png_bytep)chunkdata, slength);
+
+   if (png_crc_finish(png_ptr, skip))
+   {
+      png_free(png_ptr, chunkdata);
+      return;
+   }
+
+   chunkdata[slength] = 0x00;
+
+   for (profile = chunkdata; *profile; profile++)
+      /* empty loop to find end of name */ ;
+
+   ++profile;
+
+   /* there should be at least one zero (the compression type byte)
+      following the separator, and we should be on it  */
+   if ( profile >= chunkdata + slength)
+   {
+      png_free(png_ptr, chunkdata);
+      png_warning(png_ptr, "Malformed iCCP chunk");
+      return;
+   }
+
+   /* compression_type should always be zero */
+   compression_type = *profile++;
+   if (compression_type)
+   {
+      png_warning(png_ptr, "Ignoring nonzero compression type in iCCP chunk");
+      compression_type=0x00;  /* Reset it to zero (libpng-1.0.6 through 1.0.8
+                                 wrote nonzero) */
+   }
+
+   prefix_length = profile - chunkdata;
+   chunkdata = png_decompress_chunk(png_ptr, compression_type, chunkdata,
+                                    slength, prefix_length, &data_length);
+
+   profile_length = data_length - prefix_length;
+
+   if ( prefix_length > data_length || profile_length < 4)
+   {
+      png_free(png_ptr, chunkdata);
+      png_warning(png_ptr, "Profile size field missing from iCCP chunk");
+      return;
+   }
+
+   /* Check the profile_size recorded in the first 32 bits of the ICC profile */
+   pC = (png_bytep)(chunkdata+prefix_length);
+   profile_size = ((*(pC  ))<<24) |
+                  ((*(pC+1))<<16) |
+                  ((*(pC+2))<< 8) |
+                  ((*(pC+3))    );
+
+   if(profile_size < profile_length)
+      profile_length = profile_size;
+
+   if(profile_size > profile_length)
+   {
+      png_free(png_ptr, chunkdata);
+      png_warning(png_ptr, "Ignoring truncated iCCP profile.\n");
+      return;
+   }
+
+   png_set_iCCP(png_ptr, info_ptr, chunkdata, compression_type,
+                chunkdata + prefix_length, profile_length);
+   png_free(png_ptr, chunkdata);
+}
+#endif /* PNG_READ_iCCP_SUPPORTED */
+
+#if defined(PNG_READ_sPLT_SUPPORTED)
+void /* PRIVATE */
+png_handle_sPLT(png_structp png_ptr, png_infop info_ptr, png_uint_32 length)
+/* Note: this does not properly handle chunks that are > 64K under DOS */
+{
+   png_bytep chunkdata;
+   png_bytep entry_start;
+   png_sPLT_t new_palette;
+#ifdef PNG_NO_POINTER_INDEXING
+   png_sPLT_entryp pp;
+#endif
+   int data_length, entry_size, i;
+   png_uint_32 skip = 0;
+   png_size_t slength;
+
+   png_debug(1, "in png_handle_sPLT\n");
+
+   if (!(png_ptr->mode & PNG_HAVE_IHDR))
+      png_error(png_ptr, "Missing IHDR before sPLT");
+   else if (png_ptr->mode & PNG_HAVE_IDAT)
+   {
+      png_warning(png_ptr, "Invalid sPLT after IDAT");
+      png_crc_finish(png_ptr, length);
+      return;
+   }
+
+#ifdef PNG_MAX_MALLOC_64K
+   if (length > (png_uint_32)65535L)
+   {
+      png_warning(png_ptr, "sPLT chunk too large to fit in memory");
+      skip = length - (png_uint_32)65535L;
+      length = (png_uint_32)65535L;
+   }
+#endif
+
+   chunkdata = (png_bytep)png_malloc(png_ptr, length + 1);
+   slength = (png_size_t)length;
+   png_crc_read(png_ptr, (png_bytep)chunkdata, slength);
+
+   if (png_crc_finish(png_ptr, skip))
+   {
+      png_free(png_ptr, chunkdata);
+      return;
+   }
+
+   chunkdata[slength] = 0x00;
+
+   for (entry_start = chunkdata; *entry_start; entry_start++)
+      /* empty loop to find end of name */ ;
+   ++entry_start;
+
+   /* a sample depth should follow the separator, and we should be on it  */
+   if (entry_start > chunkdata + slength)
+   {
+      png_free(png_ptr, chunkdata);
+      png_warning(png_ptr, "malformed sPLT chunk");
+      return;
+   }
+
+   new_palette.depth = *entry_start++;
+   entry_size = (new_palette.depth == 8 ? 6 : 10);
+   data_length = (slength - (entry_start - chunkdata));
+
+   /* integrity-check the data length */
+   if (data_length % entry_size)
+   {
+      png_free(png_ptr, chunkdata);
+      png_warning(png_ptr, "sPLT chunk has bad length");
+      return;
+   }
+
+   new_palette.nentries = data_length / entry_size;
+   new_palette.entries = (png_sPLT_entryp)png_malloc(
+       png_ptr, new_palette.nentries * sizeof(png_sPLT_entry));
+
+#ifndef PNG_NO_POINTER_INDEXING
+   for (i = 0; i < new_palette.nentries; i++)
+   {
+      png_sPLT_entryp pp = new_palette.entries + i;
+
+      if (new_palette.depth == 8)
+      {
+          pp->red = *entry_start++;
+          pp->green = *entry_start++;
+          pp->blue = *entry_start++;
+          pp->alpha = *entry_start++;
+      }
+      else
+      {
+          pp->red   = png_get_uint_16(entry_start); entry_start += 2;
+          pp->green = png_get_uint_16(entry_start); entry_start += 2;
+          pp->blue  = png_get_uint_16(entry_start); entry_start += 2;
+          pp->alpha = png_get_uint_16(entry_start); entry_start += 2;
+      }
+      pp->frequency = png_get_uint_16(entry_start); entry_start += 2;
+   }
+#else
+   pp = new_palette.entries;
+   for (i = 0; i < new_palette.nentries; i++)
+   {
+
+      if (new_palette.depth == 8)
+      {
+          pp[i].red   = *entry_start++;
+          pp[i].green = *entry_start++;
+          pp[i].blue  = *entry_start++;
+          pp[i].alpha = *entry_start++;
+      }
+      else
+      {
+          pp[i].red   = png_get_uint_16(entry_start); entry_start += 2;
+          pp[i].green = png_get_uint_16(entry_start); entry_start += 2;
+          pp[i].blue  = png_get_uint_16(entry_start); entry_start += 2;
+          pp[i].alpha = png_get_uint_16(entry_start); entry_start += 2;
+      }
+      pp->frequency = png_get_uint_16(entry_start); entry_start += 2;
+   }
+#endif
+
+   /* discard all chunk data except the name and stash that */
+   new_palette.name = (png_charp)chunkdata;
+
+   png_set_sPLT(png_ptr, info_ptr, &new_palette, 1);
+
+   png_free(png_ptr, chunkdata);
+   png_free(png_ptr, new_palette.entries);
+}
+#endif /* PNG_READ_sPLT_SUPPORTED */
+
+#if defined(PNG_READ_tRNS_SUPPORTED)
+void /* PRIVATE */
+png_handle_tRNS(png_structp png_ptr, png_infop info_ptr, png_uint_32 length)
+{
+   png_byte readbuf[PNG_MAX_PALETTE_LENGTH];
+
+   png_debug(1, "in png_handle_tRNS\n");
+
+   if (!(png_ptr->mode & PNG_HAVE_IHDR))
+      png_error(png_ptr, "Missing IHDR before tRNS");
+   else if (png_ptr->mode & PNG_HAVE_IDAT)
+   {
+      png_warning(png_ptr, "Invalid tRNS after IDAT");
+      png_crc_finish(png_ptr, length);
+      return;
+   }
+   else if (info_ptr != NULL && (info_ptr->valid & PNG_INFO_tRNS))
+   {
+      png_warning(png_ptr, "Duplicate tRNS chunk");
+      png_crc_finish(png_ptr, length);
+      return;
+   }
+
+   if (png_ptr->color_type == PNG_COLOR_TYPE_PALETTE)
+   {
+      if (!(png_ptr->mode & PNG_HAVE_PLTE))
+      {
+         /* Should be an error, but we can cope with it */
+         png_warning(png_ptr, "Missing PLTE before tRNS");
+      }
+      else if (length > (png_uint_32)png_ptr->num_palette)
+      {
+         png_warning(png_ptr, "Incorrect tRNS chunk length");
+         png_crc_finish(png_ptr, length);
+         return;
+      }
+      if (length == 0)
+      {
+         png_warning(png_ptr, "Zero length tRNS chunk");
+         png_crc_finish(png_ptr, length);
+         return;
+      }
+
+      png_crc_read(png_ptr, readbuf, (png_size_t)length);
+      png_ptr->num_trans = (png_uint_16)length;
+   }
+   else if (png_ptr->color_type == PNG_COLOR_TYPE_RGB)
+   {
+      png_byte buf[6];
+
+      if (length != 6)
+      {
+         png_warning(png_ptr, "Incorrect tRNS chunk length");
+         png_crc_finish(png_ptr, length);
+         return;
+      }
+
+      png_crc_read(png_ptr, buf, (png_size_t)length);
+      png_ptr->num_trans = 1;
+      png_ptr->trans_values.red = png_get_uint_16(buf);
+      png_ptr->trans_values.green = png_get_uint_16(buf + 2);
+      png_ptr->trans_values.blue = png_get_uint_16(buf + 4);
+   }
+   else if (png_ptr->color_type == PNG_COLOR_TYPE_GRAY)
+   {
+      png_byte buf[6];
+
+      if (length != 2)
+      {
+         png_warning(png_ptr, "Incorrect tRNS chunk length");
+         png_crc_finish(png_ptr, length);
+         return;
+      }
+
+      png_crc_read(png_ptr, buf, 2);
+      png_ptr->num_trans = 1;
+      png_ptr->trans_values.gray = png_get_uint_16(buf);
+   }
+   else
+   {
+      png_warning(png_ptr, "tRNS chunk not allowed with alpha channel");
+      png_crc_finish(png_ptr, length);
+      return;
+   }
+
+   if (png_crc_finish(png_ptr, 0))
+      return;
+
+   png_set_tRNS(png_ptr, info_ptr, readbuf, png_ptr->num_trans,
+      &(png_ptr->trans_values));
+}
+#endif
+
+#if defined(PNG_READ_bKGD_SUPPORTED)
+void /* PRIVATE */
+png_handle_bKGD(png_structp png_ptr, png_infop info_ptr, png_uint_32 length)
+{
+   png_size_t truelen;
+   png_byte buf[6];
+
+   png_debug(1, "in png_handle_bKGD\n");
+
+   if (!(png_ptr->mode & PNG_HAVE_IHDR))
+      png_error(png_ptr, "Missing IHDR before bKGD");
+   else if (png_ptr->mode & PNG_HAVE_IDAT)
+   {
+      png_warning(png_ptr, "Invalid bKGD after IDAT");
+      png_crc_finish(png_ptr, length);
+      return;
+   }
+   else if (png_ptr->color_type == PNG_COLOR_TYPE_PALETTE &&
+            !(png_ptr->mode & PNG_HAVE_PLTE))
+   {
+      png_warning(png_ptr, "Missing PLTE before bKGD");
+      png_crc_finish(png_ptr, length);
+      return;
+   }
+   else if (info_ptr != NULL && (info_ptr->valid & PNG_INFO_bKGD))
+   {
+      png_warning(png_ptr, "Duplicate bKGD chunk");
+      png_crc_finish(png_ptr, length);
+      return;
+   }
+
+   if (png_ptr->color_type == PNG_COLOR_TYPE_PALETTE)
+      truelen = 1;
+   else if (png_ptr->color_type & PNG_COLOR_MASK_COLOR)
+      truelen = 6;
+   else
+      truelen = 2;
+
+   if (length != truelen)
+   {
+      png_warning(png_ptr, "Incorrect bKGD chunk length");
+      png_crc_finish(png_ptr, length);
+      return;
+   }
+
+   png_crc_read(png_ptr, buf, truelen);
+   if (png_crc_finish(png_ptr, 0))
+      return;
+
+   /* We convert the index value into RGB components so that we can allow
+    * arbitrary RGB values for background when we have transparency, and
+    * so it is easy to determine the RGB values of the background color
+    * from the info_ptr struct. */
+   if (png_ptr->color_type == PNG_COLOR_TYPE_PALETTE)
+   {
+      png_ptr->background.index = buf[0];
+      if(info_ptr->num_palette)
+      {
+          if(buf[0] > info_ptr->num_palette)
+          {
+             png_warning(png_ptr, "Incorrect bKGD chunk index value");
+             return;
+          }
+          png_ptr->background.red =
+             (png_uint_16)png_ptr->palette[buf[0]].red;
+          png_ptr->background.green =
+             (png_uint_16)png_ptr->palette[buf[0]].green;
+          png_ptr->background.blue =
+             (png_uint_16)png_ptr->palette[buf[0]].blue;
+      }
+   }
+   else if (!(png_ptr->color_type & PNG_COLOR_MASK_COLOR)) /* GRAY */
+   {
+      png_ptr->background.red =
+      png_ptr->background.green =
+      png_ptr->background.blue =
+      png_ptr->background.gray = png_get_uint_16(buf);
+   }
+   else
+   {
+      png_ptr->background.red = png_get_uint_16(buf);
+      png_ptr->background.green = png_get_uint_16(buf + 2);
+      png_ptr->background.blue = png_get_uint_16(buf + 4);
+   }
+
+   png_set_bKGD(png_ptr, info_ptr, &(png_ptr->background));
+}
+#endif
+
+#if defined(PNG_READ_hIST_SUPPORTED)
+void /* PRIVATE */
+png_handle_hIST(png_structp png_ptr, png_infop info_ptr, png_uint_32 length)
+{
+   int num, i;
+   png_uint_16 readbuf[PNG_MAX_PALETTE_LENGTH];
+
+   png_debug(1, "in png_handle_hIST\n");
+
+   if (!(png_ptr->mode & PNG_HAVE_IHDR))
+      png_error(png_ptr, "Missing IHDR before hIST");
+   else if (png_ptr->mode & PNG_HAVE_IDAT)
+   {
+      png_warning(png_ptr, "Invalid hIST after IDAT");
+      png_crc_finish(png_ptr, length);
+      return;
+   }
+   else if (!(png_ptr->mode & PNG_HAVE_PLTE))
+   {
+      png_warning(png_ptr, "Missing PLTE before hIST");
+      png_crc_finish(png_ptr, length);
+      return;
+   }
+   else if (info_ptr != NULL && (info_ptr->valid & PNG_INFO_hIST))
+   {
+      png_warning(png_ptr, "Duplicate hIST chunk");
+      png_crc_finish(png_ptr, length);
+      return;
+   }
+
+   num = (int)length / 2 ;
+   if (num != png_ptr->num_palette)
+   {
+      png_warning(png_ptr, "Incorrect hIST chunk length");
+      png_crc_finish(png_ptr, length);
+      return;
+   }
+
+   for (i = 0; i < num; i++)
+   {
+      png_byte buf[2];
+
+      png_crc_read(png_ptr, buf, 2);
+      readbuf[i] = png_get_uint_16(buf);
+   }
+
+   if (png_crc_finish(png_ptr, 0))
+      return;
+
+   png_set_hIST(png_ptr, info_ptr, readbuf);
+}
+#endif
+
+#if defined(PNG_READ_pHYs_SUPPORTED)
+void /* PRIVATE */
+png_handle_pHYs(png_structp png_ptr, png_infop info_ptr, png_uint_32 length)
+{
+   png_byte buf[9];
+   png_uint_32 res_x, res_y;
+   int unit_type;
+
+   png_debug(1, "in png_handle_pHYs\n");
+
+   if (!(png_ptr->mode & PNG_HAVE_IHDR))
+      png_error(png_ptr, "Missing IHDR before pHYs");
+   else if (png_ptr->mode & PNG_HAVE_IDAT)
+   {
+      png_warning(png_ptr, "Invalid pHYs after IDAT");
+      png_crc_finish(png_ptr, length);
+      return;
+   }
+   else if (info_ptr != NULL && (info_ptr->valid & PNG_INFO_pHYs))
+   {
+      png_warning(png_ptr, "Duplicate pHYs chunk");
+      png_crc_finish(png_ptr, length);
+      return;
+   }
+
+   if (length != 9)
+   {
+      png_warning(png_ptr, "Incorrect pHYs chunk length");
+      png_crc_finish(png_ptr, length);
+      return;
+   }
+
+   png_crc_read(png_ptr, buf, 9);
+   if (png_crc_finish(png_ptr, 0))
+      return;
+
+   res_x = png_get_uint_32(buf);
+   res_y = png_get_uint_32(buf + 4);
+   unit_type = buf[8];
+   png_set_pHYs(png_ptr, info_ptr, res_x, res_y, unit_type);
+}
+#endif
+
+#if defined(PNG_READ_oFFs_SUPPORTED)
+void /* PRIVATE */
+png_handle_oFFs(png_structp png_ptr, png_infop info_ptr, png_uint_32 length)
+{
+   png_byte buf[9];
+   png_int_32 offset_x, offset_y;
+   int unit_type;
+
+   png_debug(1, "in png_handle_oFFs\n");
+
+   if (!(png_ptr->mode & PNG_HAVE_IHDR))
+      png_error(png_ptr, "Missing IHDR before oFFs");
+   else if (png_ptr->mode & PNG_HAVE_IDAT)
+   {
+      png_warning(png_ptr, "Invalid oFFs after IDAT");
+      png_crc_finish(png_ptr, length);
+      return;
+   }
+   else if (info_ptr != NULL && (info_ptr->valid & PNG_INFO_oFFs))
+   {
+      png_warning(png_ptr, "Duplicate oFFs chunk");
+      png_crc_finish(png_ptr, length);
+      return;
+   }
+
+   if (length != 9)
+   {
+      png_warning(png_ptr, "Incorrect oFFs chunk length");
+      png_crc_finish(png_ptr, length);
+      return;
+   }
+
+   png_crc_read(png_ptr, buf, 9);
+   if (png_crc_finish(png_ptr, 0))
+      return;
+
+   offset_x = png_get_int_32(buf);
+   offset_y = png_get_int_32(buf + 4);
+   unit_type = buf[8];
+   png_set_oFFs(png_ptr, info_ptr, offset_x, offset_y, unit_type);
+}
+#endif
+
+#if defined(PNG_READ_pCAL_SUPPORTED)
+/* read the pCAL chunk (described in the PNG Extensions document) */
+void /* PRIVATE */
+png_handle_pCAL(png_structp png_ptr, png_infop info_ptr, png_uint_32 length)
+{
+   png_charp purpose;
+   png_int_32 X0, X1;
+   png_byte type, nparams;
+   png_charp buf, units, endptr;
+   png_charpp params;
+   png_size_t slength;
+   int i;
+
+   png_debug(1, "in png_handle_pCAL\n");
+
+   if (!(png_ptr->mode & PNG_HAVE_IHDR))
+      png_error(png_ptr, "Missing IHDR before pCAL");
+   else if (png_ptr->mode & PNG_HAVE_IDAT)
+   {
+      png_warning(png_ptr, "Invalid pCAL after IDAT");
+      png_crc_finish(png_ptr, length);
+      return;
+   }
+   else if (info_ptr != NULL && (info_ptr->valid & PNG_INFO_pCAL))
+   {
+      png_warning(png_ptr, "Duplicate pCAL chunk");
+      png_crc_finish(png_ptr, length);
+      return;
+   }
+
+   png_debug1(2, "Allocating and reading pCAL chunk data (%lu bytes)\n",
+      length + 1);
+   purpose = (png_charp)png_malloc_warn(png_ptr, length + 1);
+   if (purpose == NULL)
+     {
+       png_warning(png_ptr, "No memory for pCAL purpose.");
+       return;
+     }
+   slength = (png_size_t)length;
+   png_crc_read(png_ptr, (png_bytep)purpose, slength);
+
+   if (png_crc_finish(png_ptr, 0))
+   {
+      png_free(png_ptr, purpose);
+      return;
+   }
+
+   purpose[slength] = 0x00; /* null terminate the last string */
+
+   png_debug(3, "Finding end of pCAL purpose string\n");
+   for (buf = purpose; *buf; buf++)
+      /* empty loop */ ;
+
+   endptr = purpose + slength;
+
+   /* We need to have at least 12 bytes after the purpose string
+      in order to get the parameter information. */
+   if (endptr <= buf + 12)
+   {
+      png_warning(png_ptr, "Invalid pCAL data");
+      png_free(png_ptr, purpose);
+      return;
+   }
+
+   png_debug(3, "Reading pCAL X0, X1, type, nparams, and units\n");
+   X0 = png_get_int_32((png_bytep)buf+1);
+   X1 = png_get_int_32((png_bytep)buf+5);
+   type = buf[9];
+   nparams = buf[10];
+   units = buf + 11;
+
+   png_debug(3, "Checking pCAL equation type and number of parameters\n");
+   /* Check that we have the right number of parameters for known
+      equation types. */
+   if ((type == PNG_EQUATION_LINEAR && nparams != 2) ||
+       (type == PNG_EQUATION_BASE_E && nparams != 3) ||
+       (type == PNG_EQUATION_ARBITRARY && nparams != 3) ||
+       (type == PNG_EQUATION_HYPERBOLIC && nparams != 4))
+   {
+      png_warning(png_ptr, "Invalid pCAL parameters for equation type");
+      png_free(png_ptr, purpose);
+      return;
+   }
+   else if (type >= PNG_EQUATION_LAST)
+   {
+      png_warning(png_ptr, "Unrecognized equation type for pCAL chunk");
+   }
+
+   for (buf = units; *buf; buf++)
+      /* Empty loop to move past the units string. */ ;
+
+   png_debug(3, "Allocating pCAL parameters array\n");
+   params = (png_charpp)png_malloc_warn(png_ptr, (png_uint_32)(nparams
+      *sizeof(png_charp))) ;
+   if (params == NULL)
+     {
+       png_free(png_ptr, purpose);
+       png_warning(png_ptr, "No memory for pCAL params.");
+       return;
+     }
+
+   /* Get pointers to the start of each parameter string. */
+   for (i = 0; i < (int)nparams; i++)
+   {
+      buf++; /* Skip the null string terminator from previous parameter. */
+
+      png_debug1(3, "Reading pCAL parameter %d\n", i);
+      for (params[i] = buf; *buf != 0x00 && buf <= endptr; buf++)
+         /* Empty loop to move past each parameter string */ ;
+
+      /* Make sure we haven't run out of data yet */
+      if (buf > endptr)
+      {
+         png_warning(png_ptr, "Invalid pCAL data");
+         png_free(png_ptr, purpose);
+         png_free(png_ptr, params);
+         return;
+      }
+   }
+
+   png_set_pCAL(png_ptr, info_ptr, purpose, X0, X1, type, nparams,
+      units, params);
+
+   png_free(png_ptr, purpose);
+   png_free(png_ptr, params);
+}
+#endif
+
+#if defined(PNG_READ_sCAL_SUPPORTED)
+/* read the sCAL chunk */
+void /* PRIVATE */
+png_handle_sCAL(png_structp png_ptr, png_infop info_ptr, png_uint_32 length)
+{
+   png_charp buffer, ep;
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+   double width, height;
+   png_charp vp;
+#else
+#ifdef PNG_FIXED_POINT_SUPPORTED
+   png_charp swidth, sheight;
+#endif
+#endif
+   png_size_t slength;
+
+   png_debug(1, "in png_handle_sCAL\n");
+
+   if (!(png_ptr->mode & PNG_HAVE_IHDR))
+      png_error(png_ptr, "Missing IHDR before sCAL");
+   else if (png_ptr->mode & PNG_HAVE_IDAT)
+   {
+      png_warning(png_ptr, "Invalid sCAL after IDAT");
+      png_crc_finish(png_ptr, length);
+      return;
+   }
+   else if (info_ptr != NULL && (info_ptr->valid & PNG_INFO_sCAL))
+   {
+      png_warning(png_ptr, "Duplicate sCAL chunk");
+      png_crc_finish(png_ptr, length);
+      return;
+   }
+
+   png_debug1(2, "Allocating and reading sCAL chunk data (%lu bytes)\n",
+      length + 1);
+   buffer = (png_charp)png_malloc_warn(png_ptr, length + 1);
+   if (buffer == NULL)
+     {
+       png_warning(png_ptr, "Out of memory while processing sCAL chunk");
+       return;
+     }
+   slength = (png_size_t)length;
+   png_crc_read(png_ptr, (png_bytep)buffer, slength);
+
+   if (png_crc_finish(png_ptr, 0))
+   {
+      png_free(png_ptr, buffer);
+      return;
+   }
+
+   buffer[slength] = 0x00; /* null terminate the last string */
+
+   ep = buffer + 1;        /* skip unit byte */
+
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+   width = strtod(ep, &vp);
+   if (*vp)
+   {
+       png_warning(png_ptr, "malformed width string in sCAL chunk");
+       return;
+   }
+#else
+#ifdef PNG_FIXED_POINT_SUPPORTED
+   swidth = (png_charp)png_malloc_warn(png_ptr, png_strlen(ep) + 1);
+   if (swidth == NULL)
+     {
+       png_warning(png_ptr, "Out of memory while processing sCAL chunk width");
+       return;
+     }
+   png_memcpy(swidth, ep, (png_size_t)png_strlen(ep));
+#endif
+#endif
+
+   for (ep = buffer; *ep; ep++)
+      /* empty loop */ ;
+   ep++;
+
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+   height = strtod(ep, &vp);
+   if (*vp)
+   {
+       png_warning(png_ptr, "malformed height string in sCAL chunk");
+       return;
+   }
+#else
+#ifdef PNG_FIXED_POINT_SUPPORTED
+   sheight = (png_charp)png_malloc_warn(png_ptr, png_strlen(ep) + 1);
+   if (swidth == NULL)
+     {
+       png_warning(png_ptr, "Out of memory while processing sCAL chunk height");
+       return;
+     }
+   png_memcpy(sheight, ep, (png_size_t)png_strlen(ep));
+#endif
+#endif
+
+   if (buffer + slength < ep
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+      || width <= 0. || height <= 0.
+#endif
+      )
+   {
+      png_warning(png_ptr, "Invalid sCAL data");
+      png_free(png_ptr, buffer);
+#if defined(PNG_FIXED_POINT_SUPPORTED) && !defined(PNG_FLOATING_POINT_SUPPORTED)
+      png_free(png_ptr, swidth);
+      png_free(png_ptr, sheight);
+#endif
+      return;
+   }
+
+
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+   png_set_sCAL(png_ptr, info_ptr, buffer[0], width, height);
+#else
+#ifdef PNG_FIXED_POINT_SUPPORTED
+   png_set_sCAL_s(png_ptr, info_ptr, buffer[0], swidth, sheight);
+#endif
+#endif
+
+   png_free(png_ptr, buffer);
+#if defined(PNG_FIXED_POINT_SUPPORTED) && !defined(PNG_FLOATING_POINT_SUPPORTED)
+   png_free(png_ptr, swidth);
+   png_free(png_ptr, sheight);
+#endif
+}
+#endif
+
+#if defined(PNG_READ_tIME_SUPPORTED)
+void /* PRIVATE */
+png_handle_tIME(png_structp png_ptr, png_infop info_ptr, png_uint_32 length)
+{
+   png_byte buf[7];
+   png_time mod_time;
+
+   png_debug(1, "in png_handle_tIME\n");
+
+   if (!(png_ptr->mode & PNG_HAVE_IHDR))
+      png_error(png_ptr, "Out of place tIME chunk");
+   else if (info_ptr != NULL && (info_ptr->valid & PNG_INFO_tIME))
+   {
+      png_warning(png_ptr, "Duplicate tIME chunk");
+      png_crc_finish(png_ptr, length);
+      return;
+   }
+
+   if (png_ptr->mode & PNG_HAVE_IDAT)
+      png_ptr->mode |= PNG_AFTER_IDAT;
+
+   if (length != 7)
+   {
+      png_warning(png_ptr, "Incorrect tIME chunk length");
+      png_crc_finish(png_ptr, length);
+      return;
+   }
+
+   png_crc_read(png_ptr, buf, 7);
+   if (png_crc_finish(png_ptr, 0))
+      return;
+
+   mod_time.second = buf[6];
+   mod_time.minute = buf[5];
+   mod_time.hour = buf[4];
+   mod_time.day = buf[3];
+   mod_time.month = buf[2];
+   mod_time.year = png_get_uint_16(buf);
+
+   png_set_tIME(png_ptr, info_ptr, &mod_time);
+}
+#endif
+
+#if defined(PNG_READ_tEXt_SUPPORTED)
+/* Note: this does not properly handle chunks that are > 64K under DOS */
+void /* PRIVATE */
+png_handle_tEXt(png_structp png_ptr, png_infop info_ptr, png_uint_32 length)
+{
+   png_textp text_ptr;
+   png_charp key;
+   png_charp text;
+   png_uint_32 skip = 0;
+   png_size_t slength;
+   int ret;
+
+   png_debug(1, "in png_handle_tEXt\n");
+
+   if (!(png_ptr->mode & PNG_HAVE_IHDR))
+      png_error(png_ptr, "Missing IHDR before tEXt");
+
+   if (png_ptr->mode & PNG_HAVE_IDAT)
+      png_ptr->mode |= PNG_AFTER_IDAT;
+
+#ifdef PNG_MAX_MALLOC_64K
+   if (length > (png_uint_32)65535L)
+   {
+      png_warning(png_ptr, "tEXt chunk too large to fit in memory");
+      skip = length - (png_uint_32)65535L;
+      length = (png_uint_32)65535L;
+   }
+#endif
+
+   key = (png_charp)png_malloc_warn(png_ptr, length + 1);
+   if (key == NULL)
+   {
+     png_warning(png_ptr, "No memory to process text chunk.");
+     return;
+   }
+   slength = (png_size_t)length;
+   png_crc_read(png_ptr, (png_bytep)key, slength);
+
+   if (png_crc_finish(png_ptr, skip))
+   {
+      png_free(png_ptr, key);
+      return;
+   }
+
+   key[slength] = 0x00;
+
+   for (text = key; *text; text++)
+      /* empty loop to find end of key */ ;
+
+   if (text != key + slength)
+      text++;
+
+   text_ptr = (png_textp)png_malloc_warn(png_ptr, (png_uint_32)sizeof(png_text));
+   if (text_ptr == NULL)
+   {
+     png_warning(png_ptr, "Not enough memory to process text chunk.");
+     png_free(png_ptr, key);
+     return;
+   }
+   text_ptr->compression = PNG_TEXT_COMPRESSION_NONE;
+   text_ptr->key = key;
+#ifdef PNG_iTXt_SUPPORTED
+   text_ptr->lang = NULL;
+   text_ptr->lang_key = NULL;
+   text_ptr->itxt_length = 0;
+#endif
+   text_ptr->text = text;
+   text_ptr->text_length = png_strlen(text);
+
+   ret=png_set_text_2(png_ptr, info_ptr, text_ptr, 1);
+
+   png_free(png_ptr, key);
+   png_free(png_ptr, text_ptr);
+   if (ret)
+     png_warning(png_ptr, "Insufficient memory to process text chunk.");
+}
+#endif
+
+#if defined(PNG_READ_zTXt_SUPPORTED)
+/* note: this does not correctly handle chunks that are > 64K under DOS */
+void /* PRIVATE */
+png_handle_zTXt(png_structp png_ptr, png_infop info_ptr, png_uint_32 length)
+{
+   png_textp text_ptr;
+   png_charp chunkdata;
+   png_charp text;
+   int comp_type;
+   int ret;
+   png_size_t slength, prefix_len, data_len;
+
+   png_debug(1, "in png_handle_zTXt\n");
+   if (!(png_ptr->mode & PNG_HAVE_IHDR))
+      png_error(png_ptr, "Missing IHDR before zTXt");
+
+   if (png_ptr->mode & PNG_HAVE_IDAT)
+      png_ptr->mode |= PNG_AFTER_IDAT;
+
+#ifdef PNG_MAX_MALLOC_64K
+   /* We will no doubt have problems with chunks even half this size, but
+      there is no hard and fast rule to tell us where to stop. */
+   if (length > (png_uint_32)65535L)
+   {
+     png_warning(png_ptr,"zTXt chunk too large to fit in memory");
+     png_crc_finish(png_ptr, length);
+     return;
+   }
+#endif
+
+   chunkdata = (png_charp)png_malloc_warn(png_ptr, length + 1);
+   if (chunkdata == NULL)
+   {
+     png_warning(png_ptr,"Out of memory processing zTXt chunk.");
+     return;
+   }
+   slength = (png_size_t)length;
+   png_crc_read(png_ptr, (png_bytep)chunkdata, slength);
+   if (png_crc_finish(png_ptr, 0))
+   {
+      png_free(png_ptr, chunkdata);
+      return;
+   }
+
+   chunkdata[slength] = 0x00;
+
+   for (text = chunkdata; *text; text++)
+      /* empty loop */ ;
+
+   /* zTXt must have some text after the chunkdataword */
+   if (text == chunkdata + slength)
+   {
+      comp_type = PNG_TEXT_COMPRESSION_NONE;
+      png_warning(png_ptr, "Zero length zTXt chunk");
+   }
+   else
+   {
+       comp_type = *(++text);
+       if (comp_type != PNG_TEXT_COMPRESSION_zTXt)
+       {
+          png_warning(png_ptr, "Unknown compression type in zTXt chunk");
+          comp_type = PNG_TEXT_COMPRESSION_zTXt;
+       }
+       text++;        /* skip the compression_method byte */
+   }
+   prefix_len = text - chunkdata;
+
+   chunkdata = (png_charp)png_decompress_chunk(png_ptr, comp_type, chunkdata,
+                                    (png_size_t)length, prefix_len, &data_len);
+
+   text_ptr = (png_textp)png_malloc_warn(png_ptr, (png_uint_32)sizeof(png_text));
+   if (text_ptr == NULL)
+   {
+     png_warning(png_ptr,"Not enough memory to process zTXt chunk.");
+     png_free(png_ptr, chunkdata);
+     return;
+   }
+   text_ptr->compression = comp_type;
+   text_ptr->key = chunkdata;
+#ifdef PNG_iTXt_SUPPORTED
+   text_ptr->lang = NULL;
+   text_ptr->lang_key = NULL;
+   text_ptr->itxt_length = 0;
+#endif
+   text_ptr->text = chunkdata + prefix_len;
+   text_ptr->text_length = data_len;
+
+   ret=png_set_text_2(png_ptr, info_ptr, text_ptr, 1);
+
+   png_free(png_ptr, text_ptr);
+   png_free(png_ptr, chunkdata);
+   if (ret)
+     png_error(png_ptr, "Insufficient memory to store zTXt chunk.");
+}
+#endif
+
+#if defined(PNG_READ_iTXt_SUPPORTED)
+/* note: this does not correctly handle chunks that are > 64K under DOS */
+void /* PRIVATE */
+png_handle_iTXt(png_structp png_ptr, png_infop info_ptr, png_uint_32 length)
+{
+   png_textp text_ptr;
+   png_charp chunkdata;
+   png_charp key, lang, text, lang_key;
+   int comp_flag;
+   int comp_type = 0;
+   int ret;
+   png_size_t slength, prefix_len, data_len;
+
+   png_debug(1, "in png_handle_iTXt\n");
+
+   if (!(png_ptr->mode & PNG_HAVE_IHDR))
+      png_error(png_ptr, "Missing IHDR before iTXt");
+
+   if (png_ptr->mode & PNG_HAVE_IDAT)
+      png_ptr->mode |= PNG_AFTER_IDAT;
+
+#ifdef PNG_MAX_MALLOC_64K
+   /* We will no doubt have problems with chunks even half this size, but
+      there is no hard and fast rule to tell us where to stop. */
+   if (length > (png_uint_32)65535L)
+   {
+     png_warning(png_ptr,"iTXt chunk too large to fit in memory");
+     png_crc_finish(png_ptr, length);
+     return;
+   }
+#endif
+
+   chunkdata = (png_charp)png_malloc_warn(png_ptr, length + 1);
+   if (chunkdata == NULL)
+   {
+     png_warning(png_ptr, "No memory to process iTXt chunk.");
+     return;
+   }
+   slength = (png_size_t)length;
+   png_crc_read(png_ptr, (png_bytep)chunkdata, slength);
+   if (png_crc_finish(png_ptr, 0))
+   {
+      png_free(png_ptr, chunkdata);
+      return;
+   }
+
+   chunkdata[slength] = 0x00;
+
+   for (lang = chunkdata; *lang; lang++)
+      /* empty loop */ ;
+   lang++;        /* skip NUL separator */
+
+   /* iTXt must have a language tag (possibly empty), two compression bytes,
+      translated keyword (possibly empty), and possibly some text after the
+      keyword */
+
+   if (lang >= chunkdata + slength)
+   {
+      comp_flag = PNG_TEXT_COMPRESSION_NONE;
+      png_warning(png_ptr, "Zero length iTXt chunk");
+   }
+   else
+   {
+       comp_flag = *lang++;
+       comp_type = *lang++;
+   }
+
+   for (lang_key = lang; *lang_key; lang_key++)
+      /* empty loop */ ;
+   lang_key++;        /* skip NUL separator */
+
+   for (text = lang_key; *text; text++)
+      /* empty loop */ ;
+   text++;        /* skip NUL separator */
+
+   prefix_len = text - chunkdata;
+
+   key=chunkdata;
+   if (comp_flag)
+       chunkdata = png_decompress_chunk(png_ptr, comp_type, chunkdata,
+          (size_t)length, prefix_len, &data_len);
+   else
+       data_len=png_strlen(chunkdata + prefix_len);
+   text_ptr = (png_textp)png_malloc_warn(png_ptr, (png_uint_32)sizeof(png_text));
+   if (text_ptr == NULL)
+   {
+     png_warning(png_ptr,"Not enough memory to process iTXt chunk.");
+     png_free(png_ptr, chunkdata);
+     return;
+   }
+   text_ptr->compression = (int)comp_flag + 1;
+   text_ptr->lang_key = chunkdata+(lang_key-key);
+   text_ptr->lang = chunkdata+(lang-key);
+   text_ptr->itxt_length = data_len;
+   text_ptr->text_length = 0;
+   text_ptr->key = chunkdata;
+   text_ptr->text = chunkdata + prefix_len;
+
+   ret=png_set_text_2(png_ptr, info_ptr, text_ptr, 1);
+
+   png_free(png_ptr, text_ptr);
+   png_free(png_ptr, chunkdata);
+   if (ret)
+     png_error(png_ptr, "Insufficient memory to store iTXt chunk.");
+}
+#endif
+
+/* This function is called when we haven't found a handler for a
+   chunk.  If there isn't a problem with the chunk itself (ie bad
+   chunk name, CRC, or a critical chunk), the chunk is silently ignored
+   -- unless the PNG_FLAG_UNKNOWN_CHUNKS_SUPPORTED flag is on in which
+   case it will be saved away to be written out later. */
+void /* PRIVATE */
+png_handle_unknown(png_structp png_ptr, png_infop info_ptr, png_uint_32 length)
+{
+   png_uint_32 skip = 0;
+
+   png_debug(1, "in png_handle_unknown\n");
+
+   if (png_ptr->mode & PNG_HAVE_IDAT)
+   {
+#ifdef PNG_USE_LOCAL_ARRAYS
+      PNG_IDAT;
+#endif
+      if (png_memcmp(png_ptr->chunk_name, png_IDAT, 4))  /* not an IDAT */
+         png_ptr->mode |= PNG_AFTER_IDAT;
+   }
+
+   png_check_chunk_name(png_ptr, png_ptr->chunk_name);
+
+   if (!(png_ptr->chunk_name[0] & 0x20))
+   {
+#if defined(PNG_READ_UNKNOWN_CHUNKS_SUPPORTED)
+      if(png_handle_as_unknown(png_ptr, png_ptr->chunk_name) !=
+           HANDLE_CHUNK_ALWAYS
+#if defined(PNG_READ_USER_CHUNKS_SUPPORTED)
+           && png_ptr->read_user_chunk_fn == NULL
+#endif
+        )
+#endif
+          png_chunk_error(png_ptr, "unknown critical chunk");
+   }
+
+#if defined(PNG_READ_UNKNOWN_CHUNKS_SUPPORTED)
+   if (png_ptr->flags & PNG_FLAG_KEEP_UNKNOWN_CHUNKS)
+   {
+       png_unknown_chunk chunk;
+
+#ifdef PNG_MAX_MALLOC_64K
+       if (length > (png_uint_32)65535L)
+       {
+           png_warning(png_ptr, "unknown chunk too large to fit in memory");
+           skip = length - (png_uint_32)65535L;
+           length = (png_uint_32)65535L;
+       }
+#endif
+       png_strcpy((png_charp)chunk.name, (png_charp)png_ptr->chunk_name);
+       chunk.data = (png_bytep)png_malloc(png_ptr, length);
+       chunk.size = (png_size_t)length;
+       png_crc_read(png_ptr, (png_bytep)chunk.data, length);
+#if defined(PNG_READ_USER_CHUNKS_SUPPORTED)
+       if(png_ptr->read_user_chunk_fn != NULL)
+       {
+          /* callback to user unknown chunk handler */
+          if ((*(png_ptr->read_user_chunk_fn)) (png_ptr, &chunk) <= 0)
+          {
+             if (!(png_ptr->chunk_name[0] & 0x20))
+                if(png_handle_as_unknown(png_ptr, png_ptr->chunk_name) !=
+                     HANDLE_CHUNK_ALWAYS)
+                 {
+                   png_free(png_ptr, chunk.data);
+                   png_chunk_error(png_ptr, "unknown critical chunk");
+                 }
+             png_set_unknown_chunks(png_ptr, info_ptr, &chunk, 1);
+          }
+       }
+       else
+#endif
+          png_set_unknown_chunks(png_ptr, info_ptr, &chunk, 1);
+       png_free(png_ptr, chunk.data);
+   }
+   else
+#endif
+      skip = length;
+
+   png_crc_finish(png_ptr, skip);
+
+#if !defined(PNG_READ_USER_CHUNKS_SUPPORTED)
+   info_ptr = info_ptr; /* quiet compiler warnings about unused info_ptr */
+#endif
+}
+
+/* This function is called to verify that a chunk name is valid.
+   This function can't have the "critical chunk check" incorporated
+   into it, since in the future we will need to be able to call user
+   functions to handle unknown critical chunks after we check that
+   the chunk name itself is valid. */
+
+#define isnonalpha(c) ((c) < 41 || (c) > 122 || ((c) > 90 && (c) < 97))
+
+void /* PRIVATE */
+png_check_chunk_name(png_structp png_ptr, png_bytep chunk_name)
+{
+   png_debug(1, "in png_check_chunk_name\n");
+   if (isnonalpha(chunk_name[0]) || isnonalpha(chunk_name[1]) ||
+       isnonalpha(chunk_name[2]) || isnonalpha(chunk_name[3]))
+   {
+      png_chunk_error(png_ptr, "invalid chunk type");
+   }
+}
+
+/* Combines the row recently read in with the existing pixels in the
+   row.  This routine takes care of alpha and transparency if requested.
+   This routine also handles the two methods of progressive display
+   of interlaced images, depending on the mask value.
+   The mask value describes which pixels are to be combined with
+   the row.  The pattern always repeats every 8 pixels, so just 8
+   bits are needed.  A one indicates the pixel is to be combined,
+   a zero indicates the pixel is to be skipped.  This is in addition
+   to any alpha or transparency value associated with the pixel.  If
+   you want all pixels to be combined, pass 0xff (255) in mask.  */
+#ifndef PNG_HAVE_ASSEMBLER_COMBINE_ROW
+void /* PRIVATE */
+png_combine_row(png_structp png_ptr, png_bytep row, int mask)
+{
+   png_debug(1,"in png_combine_row\n");
+   if (mask == 0xff)
+   {
+      png_memcpy(row, png_ptr->row_buf + 1,
+         (png_size_t)((png_ptr->width *
+         png_ptr->row_info.pixel_depth + 7) >> 3));
+   }
+   else
+   {
+      switch (png_ptr->row_info.pixel_depth)
+      {
+         case 1:
+         {
+            png_bytep sp = png_ptr->row_buf + 1;
+            png_bytep dp = row;
+            int s_inc, s_start, s_end;
+            int m = 0x80;
+            int shift;
+            png_uint_32 i;
+            png_uint_32 row_width = png_ptr->width;
+
+#if defined(PNG_READ_PACKSWAP_SUPPORTED)
+            if (png_ptr->transformations & PNG_PACKSWAP)
+            {
+                s_start = 0;
+                s_end = 7;
+                s_inc = 1;
+            }
+            else
+#endif
+            {
+                s_start = 7;
+                s_end = 0;
+                s_inc = -1;
+            }
+
+            shift = s_start;
+
+            for (i = 0; i < row_width; i++)
+            {
+               if (m & mask)
+               {
+                  int value;
+
+                  value = (*sp >> shift) & 0x01;
+                  *dp &= (png_byte)((0x7f7f >> (7 - shift)) & 0xff);
+                  *dp |= (png_byte)(value << shift);
+               }
+
+               if (shift == s_end)
+               {
+                  shift = s_start;
+                  sp++;
+                  dp++;
+               }
+               else
+                  shift += s_inc;
+
+               if (m == 1)
+                  m = 0x80;
+               else
+                  m >>= 1;
+            }
+            break;
+         }
+         case 2:
+         {
+            png_bytep sp = png_ptr->row_buf + 1;
+            png_bytep dp = row;
+            int s_start, s_end, s_inc;
+            int m = 0x80;
+            int shift;
+            png_uint_32 i;
+            png_uint_32 row_width = png_ptr->width;
+            int value;
+
+#if defined(PNG_READ_PACKSWAP_SUPPORTED)
+            if (png_ptr->transformations & PNG_PACKSWAP)
+            {
+               s_start = 0;
+               s_end = 6;
+               s_inc = 2;
+            }
+            else
+#endif
+            {
+               s_start = 6;
+               s_end = 0;
+               s_inc = -2;
+            }
+
+            shift = s_start;
+
+            for (i = 0; i < row_width; i++)
+            {
+               if (m & mask)
+               {
+                  value = (*sp >> shift) & 0x03;
+                  *dp &= (png_byte)((0x3f3f >> (6 - shift)) & 0xff);
+                  *dp |= (png_byte)(value << shift);
+               }
+
+               if (shift == s_end)
+               {
+                  shift = s_start;
+                  sp++;
+                  dp++;
+               }
+               else
+                  shift += s_inc;
+               if (m == 1)
+                  m = 0x80;
+               else
+                  m >>= 1;
+            }
+            break;
+         }
+         case 4:
+         {
+            png_bytep sp = png_ptr->row_buf + 1;
+            png_bytep dp = row;
+            int s_start, s_end, s_inc;
+            int m = 0x80;
+            int shift;
+            png_uint_32 i;
+            png_uint_32 row_width = png_ptr->width;
+            int value;
+
+#if defined(PNG_READ_PACKSWAP_SUPPORTED)
+            if (png_ptr->transformations & PNG_PACKSWAP)
+            {
+               s_start = 0;
+               s_end = 4;
+               s_inc = 4;
+            }
+            else
+#endif
+            {
+               s_start = 4;
+               s_end = 0;
+               s_inc = -4;
+            }
+            shift = s_start;
+
+            for (i = 0; i < row_width; i++)
+            {
+               if (m & mask)
+               {
+                  value = (*sp >> shift) & 0xf;
+                  *dp &= (png_byte)((0xf0f >> (4 - shift)) & 0xff);
+                  *dp |= (png_byte)(value << shift);
+               }
+
+               if (shift == s_end)
+               {
+                  shift = s_start;
+                  sp++;
+                  dp++;
+               }
+               else
+                  shift += s_inc;
+               if (m == 1)
+                  m = 0x80;
+               else
+                  m >>= 1;
+            }
+            break;
+         }
+         default:
+         {
+            png_bytep sp = png_ptr->row_buf + 1;
+            png_bytep dp = row;
+            png_size_t pixel_bytes = (png_ptr->row_info.pixel_depth >> 3);
+            png_uint_32 i;
+            png_uint_32 row_width = png_ptr->width;
+            png_byte m = 0x80;
+
+
+            for (i = 0; i < row_width; i++)
+            {
+               if (m & mask)
+               {
+                  png_memcpy(dp, sp, pixel_bytes);
+               }
+
+               sp += pixel_bytes;
+               dp += pixel_bytes;
+
+               if (m == 1)
+                  m = 0x80;
+               else
+                  m >>= 1;
+            }
+            break;
+         }
+      }
+   }
+}
+#endif /* !PNG_HAVE_ASSEMBLER_COMBINE_ROW */
+
+#ifdef PNG_READ_INTERLACING_SUPPORTED
+#ifndef PNG_HAVE_ASSEMBLER_READ_INTERLACE   /* else in pngvcrd.c, pnggccrd.c */
+/* OLD pre-1.0.9 interface:
+void png_do_read_interlace(png_row_infop row_info, png_bytep row, int pass,
+   png_uint_32 transformations)
+ */
+void /* PRIVATE */
+png_do_read_interlace(png_structp png_ptr)
+{
+   png_row_infop row_info = &(png_ptr->row_info);
+   png_bytep row = png_ptr->row_buf + 1;
+   int pass = png_ptr->pass;
+   png_uint_32 transformations = png_ptr->transformations;
+#ifdef PNG_USE_LOCAL_ARRAYS
+   /* arrays to facilitate easy interlacing - use pass (0 - 6) as index */
+   /* offset to next interlace block */
+   const int png_pass_inc[7] = {8, 8, 4, 4, 2, 2, 1};
+#endif
+
+   png_debug(1,"in png_do_read_interlace (stock C version)\n");
+   if (row != NULL && row_info != NULL)
+   {
+      png_uint_32 final_width;
+
+      final_width = row_info->width * png_pass_inc[pass];
+
+      switch (row_info->pixel_depth)
+      {
+         case 1:
+         {
+            png_bytep sp = row + (png_size_t)((row_info->width - 1) >> 3);
+            png_bytep dp = row + (png_size_t)((final_width - 1) >> 3);
+            int sshift, dshift;
+            int s_start, s_end, s_inc;
+            int jstop = png_pass_inc[pass];
+            png_byte v;
+            png_uint_32 i;
+            int j;
+
+#if defined(PNG_READ_PACKSWAP_SUPPORTED)
+            if (transformations & PNG_PACKSWAP)
+            {
+                sshift = (int)((row_info->width + 7) & 0x07);
+                dshift = (int)((final_width + 7) & 0x07);
+                s_start = 7;
+                s_end = 0;
+                s_inc = -1;
+            }
+            else
+#endif
+            {
+                sshift = 7 - (int)((row_info->width + 7) & 0x07);
+                dshift = 7 - (int)((final_width + 7) & 0x07);
+                s_start = 0;
+                s_end = 7;
+                s_inc = 1;
+            }
+
+            for (i = 0; i < row_info->width; i++)
+            {
+               v = (png_byte)((*sp >> sshift) & 0x01);
+               for (j = 0; j < jstop; j++)
+               {
+                  *dp &= (png_byte)((0x7f7f >> (7 - dshift)) & 0xff);
+                  *dp |= (png_byte)(v << dshift);
+                  if (dshift == s_end)
+                  {
+                     dshift = s_start;
+                     dp--;
+                  }
+                  else
+                     dshift += s_inc;
+               }
+               if (sshift == s_end)
+               {
+                  sshift = s_start;
+                  sp--;
+               }
+               else
+                  sshift += s_inc;
+            }
+            break;
+         }
+         case 2:
+         {
+            png_bytep sp = row + (png_uint_32)((row_info->width - 1) >> 2);
+            png_bytep dp = row + (png_uint_32)((final_width - 1) >> 2);
+            int sshift, dshift;
+            int s_start, s_end, s_inc;
+            int jstop = png_pass_inc[pass];
+            png_uint_32 i;
+
+#if defined(PNG_READ_PACKSWAP_SUPPORTED)
+            if (transformations & PNG_PACKSWAP)
+            {
+               sshift = (int)(((row_info->width + 3) & 0x03) << 1);
+               dshift = (int)(((final_width + 3) & 0x03) << 1);
+               s_start = 6;
+               s_end = 0;
+               s_inc = -2;
+            }
+            else
+#endif
+            {
+               sshift = (int)((3 - ((row_info->width + 3) & 0x03)) << 1);
+               dshift = (int)((3 - ((final_width + 3) & 0x03)) << 1);
+               s_start = 0;
+               s_end = 6;
+               s_inc = 2;
+            }
+
+            for (i = 0; i < row_info->width; i++)
+            {
+               png_byte v;
+               int j;
+
+               v = (png_byte)((*sp >> sshift) & 0x03);
+               for (j = 0; j < jstop; j++)
+               {
+                  *dp &= (png_byte)((0x3f3f >> (6 - dshift)) & 0xff);
+                  *dp |= (png_byte)(v << dshift);
+                  if (dshift == s_end)
+                  {
+                     dshift = s_start;
+                     dp--;
+                  }
+                  else
+                     dshift += s_inc;
+               }
+               if (sshift == s_end)
+               {
+                  sshift = s_start;
+                  sp--;
+               }
+               else
+                  sshift += s_inc;
+            }
+            break;
+         }
+         case 4:
+         {
+            png_bytep sp = row + (png_size_t)((row_info->width - 1) >> 1);
+            png_bytep dp = row + (png_size_t)((final_width - 1) >> 1);
+            int sshift, dshift;
+            int s_start, s_end, s_inc;
+            png_uint_32 i;
+            int jstop = png_pass_inc[pass];
+
+#if defined(PNG_READ_PACKSWAP_SUPPORTED)
+            if (transformations & PNG_PACKSWAP)
+            {
+               sshift = (int)(((row_info->width + 1) & 0x01) << 2);
+               dshift = (int)(((final_width + 1) & 0x01) << 2);
+               s_start = 4;
+               s_end = 0;
+               s_inc = -4;
+            }
+            else
+#endif
+            {
+               sshift = (int)((1 - ((row_info->width + 1) & 0x01)) << 2);
+               dshift = (int)((1 - ((final_width + 1) & 0x01)) << 2);
+               s_start = 0;
+               s_end = 4;
+               s_inc = 4;
+            }
+
+            for (i = 0; i < row_info->width; i++)
+            {
+               png_byte v = (png_byte)((*sp >> sshift) & 0xf);
+               int j;
+
+               for (j = 0; j < jstop; j++)
+               {
+                  *dp &= (png_byte)((0xf0f >> (4 - dshift)) & 0xff);
+                  *dp |= (png_byte)(v << dshift);
+                  if (dshift == s_end)
+                  {
+                     dshift = s_start;
+                     dp--;
+                  }
+                  else
+                     dshift += s_inc;
+               }
+               if (sshift == s_end)
+               {
+                  sshift = s_start;
+                  sp--;
+               }
+               else
+                  sshift += s_inc;
+            }
+            break;
+         }
+         default:
+         {
+            png_size_t pixel_bytes = (row_info->pixel_depth >> 3);
+            png_bytep sp = row + (png_size_t)(row_info->width - 1) * pixel_bytes;
+            png_bytep dp = row + (png_size_t)(final_width - 1) * pixel_bytes;
+
+            int jstop = png_pass_inc[pass];
+            png_uint_32 i;
+
+            for (i = 0; i < row_info->width; i++)
+            {
+               png_byte v[8];
+               int j;
+
+               png_memcpy(v, sp, pixel_bytes);
+               for (j = 0; j < jstop; j++)
+               {
+                  png_memcpy(dp, v, pixel_bytes);
+                  dp -= pixel_bytes;
+               }
+               sp -= pixel_bytes;
+            }
+            break;
+         }
+      }
+      row_info->width = final_width;
+      row_info->rowbytes = ((final_width *
+         (png_uint_32)row_info->pixel_depth + 7) >> 3);
+   }
+#if !defined(PNG_READ_PACKSWAP_SUPPORTED)
+   transformations = transformations; /* silence compiler warning */
+#endif
+}
+#endif /* !PNG_HAVE_ASSEMBLER_READ_INTERLACE */
+#endif /* PNG_READ_INTERLACING_SUPPORTED */
+
+#ifndef PNG_HAVE_ASSEMBLER_READ_FILTER_ROW
+void /* PRIVATE */
+png_read_filter_row(png_structp png_ptr, png_row_infop row_info, png_bytep row,
+   png_bytep prev_row, int filter)
+{
+   png_debug(1, "in png_read_filter_row\n");
+   png_debug2(2,"row = %lu, filter = %d\n", png_ptr->row_number, filter);
+   switch (filter)
+   {
+      case PNG_FILTER_VALUE_NONE:
+         break;
+      case PNG_FILTER_VALUE_SUB:
+      {
+         png_uint_32 i;
+         png_uint_32 istop = row_info->rowbytes;
+         png_uint_32 bpp = (row_info->pixel_depth + 7) >> 3;
+         png_bytep rp = row + bpp;
+         png_bytep lp = row;
+
+         for (i = bpp; i < istop; i++)
+         {
+            *rp = (png_byte)(((int)(*rp) + (int)(*lp++)) & 0xff);
+            rp++;
+         }
+         break;
+      }
+      case PNG_FILTER_VALUE_UP:
+      {
+         png_uint_32 i;
+         png_uint_32 istop = row_info->rowbytes;
+         png_bytep rp = row;
+         png_bytep pp = prev_row;
+
+         for (i = 0; i < istop; i++)
+         {
+            *rp = (png_byte)(((int)(*rp) + (int)(*pp++)) & 0xff);
+            rp++;
+         }
+         break;
+      }
+      case PNG_FILTER_VALUE_AVG:
+      {
+         png_uint_32 i;
+         png_bytep rp = row;
+         png_bytep pp = prev_row;
+         png_bytep lp = row;
+         png_uint_32 bpp = (row_info->pixel_depth + 7) >> 3;
+         png_uint_32 istop = row_info->rowbytes - bpp;
+
+         for (i = 0; i < bpp; i++)
+         {
+            *rp = (png_byte)(((int)(*rp) +
+               ((int)(*pp++) / 2 )) & 0xff);
+            rp++;
+         }
+
+         for (i = 0; i < istop; i++)
+         {
+            *rp = (png_byte)(((int)(*rp) +
+               (int)(*pp++ + *lp++) / 2 ) & 0xff);
+            rp++;
+         }
+         break;
+      }
+      case PNG_FILTER_VALUE_PAETH:
+      {
+         png_uint_32 i;
+         png_bytep rp = row;
+         png_bytep pp = prev_row;
+         png_bytep lp = row;
+         png_bytep cp = prev_row;
+         png_uint_32 bpp = (row_info->pixel_depth + 7) >> 3;
+         png_uint_32 istop=row_info->rowbytes - bpp;
+
+         for (i = 0; i < bpp; i++)
+         {
+            *rp = (png_byte)(((int)(*rp) + (int)(*pp++)) & 0xff);
+            rp++;
+         }
+
+         for (i = 0; i < istop; i++)   /* use leftover rp,pp */
+         {
+            int a, b, c, pa, pb, pc, p;
+
+            a = *lp++;
+            b = *pp++;
+            c = *cp++;
+
+            p = b - c;
+            pc = a - c;
+
+#ifdef PNG_USE_ABS
+            pa = abs(p);
+            pb = abs(pc);
+            pc = abs(p + pc);
+#else
+            pa = p < 0 ? -p : p;
+            pb = pc < 0 ? -pc : pc;
+            pc = (p + pc) < 0 ? -(p + pc) : p + pc;
+#endif
+
+            /*
+               if (pa <= pb && pa <= pc)
+                  p = a;
+               else if (pb <= pc)
+                  p = b;
+               else
+                  p = c;
+             */
+
+            p = (pa <= pb && pa <=pc) ? a : (pb <= pc) ? b : c;
+
+            *rp = (png_byte)(((int)(*rp) + p) & 0xff);
+            rp++;
+         }
+         break;
+      }
+      default:
+         png_warning(png_ptr, "Ignoring bad adaptive filter type");
+         *row=0;
+         break;
+   }
+}
+#endif /* !PNG_HAVE_ASSEMBLER_READ_FILTER_ROW */
+
+void /* PRIVATE */
+png_read_finish_row(png_structp png_ptr)
+{
+#ifdef PNG_USE_LOCAL_ARRAYS
+   /* arrays to facilitate easy interlacing - use pass (0 - 6) as index */
+
+   /* start of interlace block */
+   const int png_pass_start[7] = {0, 4, 0, 2, 0, 1, 0};
+
+   /* offset to next interlace block */
+   const int png_pass_inc[7] = {8, 8, 4, 4, 2, 2, 1};
+
+   /* start of interlace block in the y direction */
+   const int png_pass_ystart[7] = {0, 0, 4, 0, 2, 0, 1};
+
+   /* offset to next interlace block in the y direction */
+   const int png_pass_yinc[7] = {8, 8, 8, 4, 4, 2, 2};
+#endif
+
+   png_debug(1, "in png_read_finish_row\n");
+   png_ptr->row_number++;
+   if (png_ptr->row_number < png_ptr->num_rows)
+      return;
+
+   if (png_ptr->interlaced)
+   {
+      png_ptr->row_number = 0;
+      png_memset_check(png_ptr, png_ptr->prev_row, 0, png_ptr->rowbytes + 1);
+      do
+      {
+         png_ptr->pass++;
+         if (png_ptr->pass >= 7)
+            break;
+         png_ptr->iwidth = (png_ptr->width +
+            png_pass_inc[png_ptr->pass] - 1 -
+            png_pass_start[png_ptr->pass]) /
+            png_pass_inc[png_ptr->pass];
+            png_ptr->irowbytes = ((png_ptr->iwidth *
+               (png_uint_32)png_ptr->pixel_depth + 7) >> 3) +1;
+
+         if (!(png_ptr->transformations & PNG_INTERLACE))
+         {
+            png_ptr->num_rows = (png_ptr->height +
+               png_pass_yinc[png_ptr->pass] - 1 -
+               png_pass_ystart[png_ptr->pass]) /
+               png_pass_yinc[png_ptr->pass];
+            if (!(png_ptr->num_rows))
+               continue;
+         }
+         else  /* if (png_ptr->transformations & PNG_INTERLACE) */
+            break;
+      } while (png_ptr->iwidth == 0);
+
+      if (png_ptr->pass < 7)
+         return;
+   }
+
+   if (!(png_ptr->flags & PNG_FLAG_ZLIB_FINISHED))
+   {
+#ifdef PNG_USE_LOCAL_ARRAYS
+      PNG_IDAT;
+#endif
+      char extra;
+      int ret;
+
+      png_ptr->zstream.next_out = (Byte *)&extra;
+      png_ptr->zstream.avail_out = (uInt)1;
+      for(;;)
+      {
+         if (!(png_ptr->zstream.avail_in))
+         {
+            while (!png_ptr->idat_size)
+            {
+               png_byte chunk_length[4];
+
+               png_crc_finish(png_ptr, 0);
+
+               png_read_data(png_ptr, chunk_length, 4);
+               png_ptr->idat_size = png_get_uint_32(chunk_length);
+
+               png_reset_crc(png_ptr);
+               png_crc_read(png_ptr, png_ptr->chunk_name, 4);
+               if (png_memcmp(png_ptr->chunk_name, (png_bytep)png_IDAT, 4))
+                  png_error(png_ptr, "Not enough image data");
+
+            }
+            png_ptr->zstream.avail_in = (uInt)png_ptr->zbuf_size;
+            png_ptr->zstream.next_in = png_ptr->zbuf;
+            if (png_ptr->zbuf_size > png_ptr->idat_size)
+               png_ptr->zstream.avail_in = (uInt)png_ptr->idat_size;
+            png_crc_read(png_ptr, png_ptr->zbuf, png_ptr->zstream.avail_in);
+            png_ptr->idat_size -= png_ptr->zstream.avail_in;
+         }
+         ret = inflate(&png_ptr->zstream, Z_PARTIAL_FLUSH);
+         if (ret == Z_STREAM_END)
+         {
+            if (!(png_ptr->zstream.avail_out) || png_ptr->zstream.avail_in ||
+               png_ptr->idat_size)
+               png_warning(png_ptr, "Extra compressed data");
+            png_ptr->mode |= PNG_AFTER_IDAT;
+            png_ptr->flags |= PNG_FLAG_ZLIB_FINISHED;
+            break;
+         }
+         if (ret != Z_OK)
+            png_error(png_ptr, png_ptr->zstream.msg ? png_ptr->zstream.msg :
+                      "Decompression Error");
+
+         if (!(png_ptr->zstream.avail_out))
+         {
+            png_warning(png_ptr, "Extra compressed data.");
+            png_ptr->mode |= PNG_AFTER_IDAT;
+            png_ptr->flags |= PNG_FLAG_ZLIB_FINISHED;
+            break;
+         }
+
+      }
+      png_ptr->zstream.avail_out = 0;
+   }
+
+   if (png_ptr->idat_size || png_ptr->zstream.avail_in)
+      png_warning(png_ptr, "Extra compression data");
+
+   inflateReset(&png_ptr->zstream);
+
+   png_ptr->mode |= PNG_AFTER_IDAT;
+}
+
+void /* PRIVATE */
+png_read_start_row(png_structp png_ptr)
+{
+#ifdef PNG_USE_LOCAL_ARRAYS
+   /* arrays to facilitate easy interlacing - use pass (0 - 6) as index */
+
+   /* start of interlace block */
+   const int png_pass_start[7] = {0, 4, 0, 2, 0, 1, 0};
+
+   /* offset to next interlace block */
+   const int png_pass_inc[7] = {8, 8, 4, 4, 2, 2, 1};
+
+   /* start of interlace block in the y direction */
+   const int png_pass_ystart[7] = {0, 0, 4, 0, 2, 0, 1};
+
+   /* offset to next interlace block in the y direction */
+   const int png_pass_yinc[7] = {8, 8, 8, 4, 4, 2, 2};
+#endif
+
+   int max_pixel_depth;
+   png_uint_32 row_bytes;
+
+   png_debug(1, "in png_read_start_row\n");
+   png_ptr->zstream.avail_in = 0;
+   png_init_read_transformations(png_ptr);
+   if (png_ptr->interlaced)
+   {
+      if (!(png_ptr->transformations & PNG_INTERLACE))
+         png_ptr->num_rows = (png_ptr->height + png_pass_yinc[0] - 1 -
+            png_pass_ystart[0]) / png_pass_yinc[0];
+      else
+         png_ptr->num_rows = png_ptr->height;
+
+      png_ptr->iwidth = (png_ptr->width +
+         png_pass_inc[png_ptr->pass] - 1 -
+         png_pass_start[png_ptr->pass]) /
+         png_pass_inc[png_ptr->pass];
+
+         row_bytes = ((png_ptr->iwidth *
+            (png_uint_32)png_ptr->pixel_depth + 7) >> 3) +1;
+         png_ptr->irowbytes = (png_size_t)row_bytes;
+         if((png_uint_32)png_ptr->irowbytes != row_bytes)
+            png_error(png_ptr, "Rowbytes overflow in png_read_start_row");
+   }
+   else
+   {
+      png_ptr->num_rows = png_ptr->height;
+      png_ptr->iwidth = png_ptr->width;
+      png_ptr->irowbytes = png_ptr->rowbytes + 1;
+   }
+   max_pixel_depth = png_ptr->pixel_depth;
+
+#if defined(PNG_READ_PACK_SUPPORTED)
+   if ((png_ptr->transformations & PNG_PACK) && png_ptr->bit_depth < 8)
+      max_pixel_depth = 8;
+#endif
+
+#if defined(PNG_READ_EXPAND_SUPPORTED)
+   if (png_ptr->transformations & PNG_EXPAND)
+   {
+      if (png_ptr->color_type == PNG_COLOR_TYPE_PALETTE)
+      {
+         if (png_ptr->num_trans)
+            max_pixel_depth = 32;
+         else
+            max_pixel_depth = 24;
+      }
+      else if (png_ptr->color_type == PNG_COLOR_TYPE_GRAY)
+      {
+         if (max_pixel_depth < 8)
+            max_pixel_depth = 8;
+         if (png_ptr->num_trans)
+            max_pixel_depth *= 2;
+      }
+      else if (png_ptr->color_type == PNG_COLOR_TYPE_RGB)
+      {
+         if (png_ptr->num_trans)
+         {
+            max_pixel_depth *= 4;
+            max_pixel_depth /= 3;
+         }
+      }
+   }
+#endif
+
+#if defined(PNG_READ_FILLER_SUPPORTED)
+   if (png_ptr->transformations & (PNG_FILLER))
+   {
+      if (png_ptr->color_type == PNG_COLOR_TYPE_PALETTE)
+         max_pixel_depth = 32;
+      else if (png_ptr->color_type == PNG_COLOR_TYPE_GRAY)
+      {
+         if (max_pixel_depth <= 8)
+            max_pixel_depth = 16;
+         else
+            max_pixel_depth = 32;
+      }
+      else if (png_ptr->color_type == PNG_COLOR_TYPE_RGB)
+      {
+         if (max_pixel_depth <= 32)
+            max_pixel_depth = 32;
+         else
+            max_pixel_depth = 64;
+      }
+   }
+#endif
+
+#if defined(PNG_READ_GRAY_TO_RGB_SUPPORTED)
+   if (png_ptr->transformations & PNG_GRAY_TO_RGB)
+   {
+      if (
+#if defined(PNG_READ_EXPAND_SUPPORTED)
+        (png_ptr->num_trans && (png_ptr->transformations & PNG_EXPAND)) ||
+#endif
+#if defined(PNG_READ_FILLER_SUPPORTED)
+        (png_ptr->transformations & (PNG_FILLER)) ||
+#endif
+        png_ptr->color_type == PNG_COLOR_TYPE_GRAY_ALPHA)
+      {
+         if (max_pixel_depth <= 16)
+            max_pixel_depth = 32;
+         else
+            max_pixel_depth = 64;
+      }
+      else
+      {
+         if (max_pixel_depth <= 8)
+           {
+             if (png_ptr->color_type == PNG_COLOR_TYPE_RGB_ALPHA)
+               max_pixel_depth = 32;
+             else
+               max_pixel_depth = 24;
+           }
+         else if (png_ptr->color_type == PNG_COLOR_TYPE_RGB_ALPHA)
+            max_pixel_depth = 64;
+         else
+            max_pixel_depth = 48;
+      }
+   }
+#endif
+
+#if defined(PNG_READ_USER_TRANSFORM_SUPPORTED) && \
+defined(PNG_USER_TRANSFORM_PTR_SUPPORTED)
+   if(png_ptr->transformations & PNG_USER_TRANSFORM)
+     {
+       int user_pixel_depth=png_ptr->user_transform_depth*
+         png_ptr->user_transform_channels;
+       if(user_pixel_depth > max_pixel_depth)
+         max_pixel_depth=user_pixel_depth;
+     }
+#endif
+
+   /* align the width on the next larger 8 pixels.  Mainly used
+      for interlacing */
+   row_bytes = ((png_ptr->width + 7) & ~((png_uint_32)7));
+   /* calculate the maximum bytes needed, adding a byte and a pixel
+      for safety's sake */
+   row_bytes = ((row_bytes * (png_uint_32)max_pixel_depth + 7) >> 3) +
+      1 + ((max_pixel_depth + 7) >> 3);
+#ifdef PNG_MAX_MALLOC_64K
+   if (row_bytes > (png_uint_32)65536L)
+      png_error(png_ptr, "This image requires a row greater than 64KB");
+#endif
+   png_ptr->big_row_buf = (png_bytep)png_malloc(png_ptr, row_bytes+64);
+   png_ptr->row_buf = png_ptr->big_row_buf+32;
+#if defined(PNG_DEBUG) && defined(PNG_USE_PNGGCCRD)
+   png_ptr->row_buf_size = row_bytes;
+#endif
+
+#ifdef PNG_MAX_MALLOC_64K
+   if ((png_uint_32)png_ptr->rowbytes + 1 > (png_uint_32)65536L)
+      png_error(png_ptr, "This image requires a row greater than 64KB");
+#endif
+   png_ptr->prev_row = (png_bytep)png_malloc(png_ptr, (png_uint_32)(
+      png_ptr->rowbytes + 1));
+
+   png_memset_check(png_ptr, png_ptr->prev_row, 0, png_ptr->rowbytes + 1);
+
+   png_debug1(3, "width = %lu,\n", png_ptr->width);
+   png_debug1(3, "height = %lu,\n", png_ptr->height);
+   png_debug1(3, "iwidth = %lu,\n", png_ptr->iwidth);
+   png_debug1(3, "num_rows = %lu\n", png_ptr->num_rows);
+   png_debug1(3, "rowbytes = %lu,\n", png_ptr->rowbytes);
+   png_debug1(3, "irowbytes = %lu,\n", png_ptr->irowbytes);
+
+   png_ptr->flags |= PNG_FLAG_ROW_INIT;
+}
diff --git a/collects/plot/src/all/pngset.c b/collects/plot/src/all/pngset.c
new file mode 100644
index 0000000000..8e4e6197c9
--- /dev/null
+++ b/collects/plot/src/all/pngset.c
@@ -0,0 +1,1160 @@
+
+/* pngset.c - storage of image information into info struct
+ *
+ * libpng 1.2.5 - October 3, 2002
+ * For conditions of distribution and use, see copyright notice in png.h
+ * Copyright (c) 1998-2002 Glenn Randers-Pehrson
+ * (Version 0.96 Copyright (c) 1996, 1997 Andreas Dilger)
+ * (Version 0.88 Copyright (c) 1995, 1996 Guy Eric Schalnat, Group 42, Inc.)
+ *
+ * The functions here are used during reads to store data from the file
+ * into the info struct, and during writes to store application data
+ * into the info struct for writing into the file.  This abstracts the
+ * info struct and allows us to change the structure in the future.
+ */
+
+#define PNG_INTERNAL
+#include "png.h"
+
+#if defined(PNG_bKGD_SUPPORTED)
+void PNGAPI
+png_set_bKGD(png_structp png_ptr, png_infop info_ptr, png_color_16p background)
+{
+   png_debug1(1, "in %s storage function\n", "bKGD");
+   if (png_ptr == NULL || info_ptr == NULL)
+      return;
+
+   png_memcpy(&(info_ptr->background), background, sizeof(png_color_16));
+   info_ptr->valid |= PNG_INFO_bKGD;
+}
+#endif
+
+#if defined(PNG_cHRM_SUPPORTED)
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+void PNGAPI
+png_set_cHRM(png_structp png_ptr, png_infop info_ptr,
+   double white_x, double white_y, double red_x, double red_y,
+   double green_x, double green_y, double blue_x, double blue_y)
+{
+   png_debug1(1, "in %s storage function\n", "cHRM");
+   if (png_ptr == NULL || info_ptr == NULL)
+      return;
+
+   if (white_x < 0.0 || white_y < 0.0 ||
+         red_x < 0.0 ||   red_y < 0.0 ||
+       green_x < 0.0 || green_y < 0.0 ||
+        blue_x < 0.0 ||  blue_y < 0.0)
+   {
+      png_warning(png_ptr,
+        "Ignoring attempt to set negative chromaticity value");
+      return;
+   }
+   if (white_x > 21474.83 || white_y > 21474.83 ||
+         red_x > 21474.83 ||   red_y > 21474.83 ||
+       green_x > 21474.83 || green_y > 21474.83 ||
+        blue_x > 21474.83 ||  blue_y > 21474.83)
+   {
+      png_warning(png_ptr,
+        "Ignoring attempt to set chromaticity value exceeding 21474.83");
+      return;
+   }
+
+   info_ptr->x_white = (float)white_x;
+   info_ptr->y_white = (float)white_y;
+   info_ptr->x_red   = (float)red_x;
+   info_ptr->y_red   = (float)red_y;
+   info_ptr->x_green = (float)green_x;
+   info_ptr->y_green = (float)green_y;
+   info_ptr->x_blue  = (float)blue_x;
+   info_ptr->y_blue  = (float)blue_y;
+#ifdef PNG_FIXED_POINT_SUPPORTED
+   info_ptr->int_x_white = (png_fixed_point)(white_x*100000.+0.5);
+   info_ptr->int_y_white = (png_fixed_point)(white_y*100000.+0.5);
+   info_ptr->int_x_red   = (png_fixed_point)(  red_x*100000.+0.5);
+   info_ptr->int_y_red   = (png_fixed_point)(  red_y*100000.+0.5);
+   info_ptr->int_x_green = (png_fixed_point)(green_x*100000.+0.5);
+   info_ptr->int_y_green = (png_fixed_point)(green_y*100000.+0.5);
+   info_ptr->int_x_blue  = (png_fixed_point)( blue_x*100000.+0.5);
+   info_ptr->int_y_blue  = (png_fixed_point)( blue_y*100000.+0.5);
+#endif
+   info_ptr->valid |= PNG_INFO_cHRM;
+}
+#endif
+#ifdef PNG_FIXED_POINT_SUPPORTED
+void PNGAPI
+png_set_cHRM_fixed(png_structp png_ptr, png_infop info_ptr,
+   png_fixed_point white_x, png_fixed_point white_y, png_fixed_point red_x,
+   png_fixed_point red_y, png_fixed_point green_x, png_fixed_point green_y,
+   png_fixed_point blue_x, png_fixed_point blue_y)
+{
+   png_debug1(1, "in %s storage function\n", "cHRM");
+   if (png_ptr == NULL || info_ptr == NULL)
+      return;
+
+   if (white_x < 0 || white_y < 0 ||
+         red_x < 0 ||   red_y < 0 ||
+       green_x < 0 || green_y < 0 ||
+        blue_x < 0 ||  blue_y < 0)
+   {
+      png_warning(png_ptr,
+        "Ignoring attempt to set negative chromaticity value");
+      return;
+   }
+   if (white_x > (double) PNG_MAX_UINT || white_y > (double) PNG_MAX_UINT ||
+         red_x > (double) PNG_MAX_UINT ||   red_y > (double) PNG_MAX_UINT ||
+       green_x > (double) PNG_MAX_UINT || green_y > (double) PNG_MAX_UINT ||
+        blue_x > (double) PNG_MAX_UINT ||  blue_y > (double) PNG_MAX_UINT)
+   {
+      png_warning(png_ptr,
+        "Ignoring attempt to set chromaticity value exceeding 21474.83");
+      return;
+   }
+   info_ptr->int_x_white = white_x;
+   info_ptr->int_y_white = white_y;
+   info_ptr->int_x_red   = red_x;
+   info_ptr->int_y_red   = red_y;
+   info_ptr->int_x_green = green_x;
+   info_ptr->int_y_green = green_y;
+   info_ptr->int_x_blue  = blue_x;
+   info_ptr->int_y_blue  = blue_y;
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+   info_ptr->x_white = (float)(white_x/100000.);
+   info_ptr->y_white = (float)(white_y/100000.);
+   info_ptr->x_red   = (float)(  red_x/100000.);
+   info_ptr->y_red   = (float)(  red_y/100000.);
+   info_ptr->x_green = (float)(green_x/100000.);
+   info_ptr->y_green = (float)(green_y/100000.);
+   info_ptr->x_blue  = (float)( blue_x/100000.);
+   info_ptr->y_blue  = (float)( blue_y/100000.);
+#endif
+   info_ptr->valid |= PNG_INFO_cHRM;
+}
+#endif
+#endif
+
+#if defined(PNG_gAMA_SUPPORTED)
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+void PNGAPI
+png_set_gAMA(png_structp png_ptr, png_infop info_ptr, double file_gamma)
+{
+   double gamma;
+   png_debug1(1, "in %s storage function\n", "gAMA");
+   if (png_ptr == NULL || info_ptr == NULL)
+      return;
+
+   /* Check for overflow */
+   if (file_gamma > 21474.83)
+   {
+      png_warning(png_ptr, "Limiting gamma to 21474.83");
+      gamma=21474.83;
+   }
+   else
+      gamma=file_gamma;
+   info_ptr->gamma = (float)gamma;
+#ifdef PNG_FIXED_POINT_SUPPORTED
+   info_ptr->int_gamma = (int)(gamma*100000.+.5);
+#endif
+   info_ptr->valid |= PNG_INFO_gAMA;
+   if(gamma == 0.0)
+      png_warning(png_ptr, "Setting gamma=0");
+}
+#endif
+void PNGAPI
+png_set_gAMA_fixed(png_structp png_ptr, png_infop info_ptr, png_fixed_point
+   int_gamma)
+{
+   png_fixed_point gamma;
+
+   png_debug1(1, "in %s storage function\n", "gAMA");
+   if (png_ptr == NULL || info_ptr == NULL)
+      return;
+
+   if (int_gamma > (png_fixed_point) PNG_MAX_UINT)
+   {
+     png_warning(png_ptr, "Limiting gamma to 21474.83");
+     gamma=PNG_MAX_UINT;
+   }
+   else
+   {
+     if (int_gamma < 0)
+     {
+       png_warning(png_ptr, "Setting negative gamma to zero");
+       gamma=0;
+     }
+     else
+       gamma=int_gamma;
+   }
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+   info_ptr->gamma = (float)(gamma/100000.);
+#endif
+#ifdef PNG_FIXED_POINT_SUPPORTED
+   info_ptr->int_gamma = gamma;
+#endif
+   info_ptr->valid |= PNG_INFO_gAMA;
+   if(gamma == 0)
+      png_warning(png_ptr, "Setting gamma=0");
+}
+#endif
+
+#if defined(PNG_hIST_SUPPORTED)
+void PNGAPI
+png_set_hIST(png_structp png_ptr, png_infop info_ptr, png_uint_16p hist)
+{
+   int i;
+
+   png_debug1(1, "in %s storage function\n", "hIST");
+   if (png_ptr == NULL || info_ptr == NULL)
+      return;
+   if (info_ptr->num_palette == 0)
+   {
+       png_warning(png_ptr,
+          "Palette size 0, hIST allocation skipped.");
+       return;
+   }
+
+#ifdef PNG_FREE_ME_SUPPORTED
+   png_free_data(png_ptr, info_ptr, PNG_FREE_HIST, 0);
+#endif
+   /* Changed from info->num_palette to 256 in version 1.2.1 */
+   png_ptr->hist = (png_uint_16p)png_malloc_warn(png_ptr,
+      (png_uint_32)(256 * sizeof (png_uint_16)));
+   if (png_ptr->hist == NULL)
+     {
+       png_warning(png_ptr, "Insufficient memory for hIST chunk data.");
+       return;
+     }
+
+   for (i = 0; i < info_ptr->num_palette; i++)
+       png_ptr->hist[i] = hist[i];
+   info_ptr->hist = png_ptr->hist;
+   info_ptr->valid |= PNG_INFO_hIST;
+
+#ifdef PNG_FREE_ME_SUPPORTED
+   info_ptr->free_me |= PNG_FREE_HIST;
+#else
+   png_ptr->flags |= PNG_FLAG_FREE_HIST;
+#endif
+}
+#endif
+
+void PNGAPI
+png_set_IHDR(png_structp png_ptr, png_infop info_ptr,
+   png_uint_32 width, png_uint_32 height, int bit_depth,
+   int color_type, int interlace_type, int compression_type,
+   int filter_type)
+{
+   int rowbytes_per_pixel;
+   png_debug1(1, "in %s storage function\n", "IHDR");
+   if (png_ptr == NULL || info_ptr == NULL)
+      return;
+
+   /* check for width and height valid values */
+   if (width == 0 || height == 0)
+      png_error(png_ptr, "Image width or height is zero in IHDR");
+   if (width > PNG_MAX_UINT || height > PNG_MAX_UINT)
+      png_error(png_ptr, "Invalid image size in IHDR");
+
+   /* check other values */
+   if (bit_depth != 1 && bit_depth != 2 && bit_depth != 4 &&
+      bit_depth != 8 && bit_depth != 16)
+      png_error(png_ptr, "Invalid bit depth in IHDR");
+
+   if (color_type < 0 || color_type == 1 ||
+      color_type == 5 || color_type > 6)
+      png_error(png_ptr, "Invalid color type in IHDR");
+
+   if (((color_type == PNG_COLOR_TYPE_PALETTE) && bit_depth > 8) ||
+       ((color_type == PNG_COLOR_TYPE_RGB ||
+         color_type == PNG_COLOR_TYPE_GRAY_ALPHA ||
+         color_type == PNG_COLOR_TYPE_RGB_ALPHA) && bit_depth < 8))
+      png_error(png_ptr, "Invalid color type/bit depth combination in IHDR");
+
+   if (interlace_type >= PNG_INTERLACE_LAST)
+      png_error(png_ptr, "Unknown interlace method in IHDR");
+
+   if (compression_type != PNG_COMPRESSION_TYPE_BASE)
+      png_error(png_ptr, "Unknown compression method in IHDR");
+
+#if defined(PNG_MNG_FEATURES_SUPPORTED)
+   /* Accept filter_method 64 (intrapixel differencing) only if
+    * 1. Libpng was compiled with PNG_MNG_FEATURES_SUPPORTED and
+    * 2. Libpng did not read a PNG signature (this filter_method is only
+    *    used in PNG datastreams that are embedded in MNG datastreams) and
+    * 3. The application called png_permit_mng_features with a mask that
+    *    included PNG_FLAG_MNG_FILTER_64 and
+    * 4. The filter_method is 64 and
+    * 5. The color_type is RGB or RGBA
+    */
+   if((png_ptr->mode&PNG_HAVE_PNG_SIGNATURE)&&png_ptr->mng_features_permitted)
+      png_warning(png_ptr,"MNG features are not allowed in a PNG datastream\n");
+   if(filter_type != PNG_FILTER_TYPE_BASE)
+   {
+     if(!((png_ptr->mng_features_permitted & PNG_FLAG_MNG_FILTER_64) &&
+        (filter_type == PNG_INTRAPIXEL_DIFFERENCING) &&
+        ((png_ptr->mode&PNG_HAVE_PNG_SIGNATURE) == 0) &&
+        (color_type == PNG_COLOR_TYPE_RGB || 
+         color_type == PNG_COLOR_TYPE_RGB_ALPHA)))
+        png_error(png_ptr, "Unknown filter method in IHDR");
+     if(png_ptr->mode&PNG_HAVE_PNG_SIGNATURE)
+        png_warning(png_ptr, "Invalid filter method in IHDR");
+   }
+#else
+   if(filter_type != PNG_FILTER_TYPE_BASE)
+      png_error(png_ptr, "Unknown filter method in IHDR");
+#endif
+
+   info_ptr->width = width;
+   info_ptr->height = height;
+   info_ptr->bit_depth = (png_byte)bit_depth;
+   info_ptr->color_type =(png_byte) color_type;
+   info_ptr->compression_type = (png_byte)compression_type;
+   info_ptr->filter_type = (png_byte)filter_type;
+   info_ptr->interlace_type = (png_byte)interlace_type;
+   if (info_ptr->color_type == PNG_COLOR_TYPE_PALETTE)
+      info_ptr->channels = 1;
+   else if (info_ptr->color_type & PNG_COLOR_MASK_COLOR)
+      info_ptr->channels = 3;
+   else
+      info_ptr->channels = 1;
+   if (info_ptr->color_type & PNG_COLOR_MASK_ALPHA)
+      info_ptr->channels++;
+   info_ptr->pixel_depth = (png_byte)(info_ptr->channels * info_ptr->bit_depth);
+
+   /* check for overflow */
+   rowbytes_per_pixel = (info_ptr->pixel_depth + 7) >> 3;
+   if ( width > PNG_MAX_UINT/rowbytes_per_pixel - 64)
+   {
+      png_warning(png_ptr,
+         "Width too large to process image data; rowbytes will overflow.");
+      info_ptr->rowbytes = (png_size_t)0;
+   }
+   else
+      info_ptr->rowbytes = (info_ptr->width * info_ptr->pixel_depth + 7) >> 3;
+}
+
+#if defined(PNG_oFFs_SUPPORTED)
+void PNGAPI
+png_set_oFFs(png_structp png_ptr, png_infop info_ptr,
+   png_int_32 offset_x, png_int_32 offset_y, int unit_type)
+{
+   png_debug1(1, "in %s storage function\n", "oFFs");
+   if (png_ptr == NULL || info_ptr == NULL)
+      return;
+
+   info_ptr->x_offset = offset_x;
+   info_ptr->y_offset = offset_y;
+   info_ptr->offset_unit_type = (png_byte)unit_type;
+   info_ptr->valid |= PNG_INFO_oFFs;
+}
+#endif
+
+#if defined(PNG_pCAL_SUPPORTED)
+void PNGAPI
+png_set_pCAL(png_structp png_ptr, png_infop info_ptr,
+   png_charp purpose, png_int_32 X0, png_int_32 X1, int type, int nparams,
+   png_charp units, png_charpp params)
+{
+   png_uint_32 length;
+   int i;
+
+   png_debug1(1, "in %s storage function\n", "pCAL");
+   if (png_ptr == NULL || info_ptr == NULL)
+      return;
+
+   length = png_strlen(purpose) + 1;
+   png_debug1(3, "allocating purpose for info (%lu bytes)\n", length);
+   info_ptr->pcal_purpose = (png_charp)png_malloc_warn(png_ptr, length);
+   if (info_ptr->pcal_purpose == NULL)
+     {
+       png_warning(png_ptr, "Insufficient memory for pCAL purpose.");
+       return;
+     }
+   png_memcpy(info_ptr->pcal_purpose, purpose, (png_size_t)length);
+
+   png_debug(3, "storing X0, X1, type, and nparams in info\n");
+   info_ptr->pcal_X0 = X0;
+   info_ptr->pcal_X1 = X1;
+   info_ptr->pcal_type = (png_byte)type;
+   info_ptr->pcal_nparams = (png_byte)nparams;
+
+   length = png_strlen(units) + 1;
+   png_debug1(3, "allocating units for info (%lu bytes)\n", length);
+   info_ptr->pcal_units = (png_charp)png_malloc_warn(png_ptr, length);
+   if (info_ptr->pcal_units == NULL)
+     {
+       png_warning(png_ptr, "Insufficient memory for pCAL units.");
+       return;
+     }
+   png_memcpy(info_ptr->pcal_units, units, (png_size_t)length);
+
+   info_ptr->pcal_params = (png_charpp)png_malloc_warn(png_ptr,
+      (png_uint_32)((nparams + 1) * sizeof(png_charp)));
+   if (info_ptr->pcal_params == NULL)
+     {
+       png_warning(png_ptr, "Insufficient memory for pCAL params.");
+       return;
+     }
+
+   info_ptr->pcal_params[nparams] = NULL;
+
+   for (i = 0; i < nparams; i++)
+   {
+      length = png_strlen(params[i]) + 1;
+      png_debug2(3, "allocating parameter %d for info (%lu bytes)\n", i, length);
+      info_ptr->pcal_params[i] = (png_charp)png_malloc_warn(png_ptr, length);
+      if (info_ptr->pcal_params[i] == NULL)
+        {
+          png_warning(png_ptr, "Insufficient memory for pCAL parameter.");
+          return;
+        }
+      png_memcpy(info_ptr->pcal_params[i], params[i], (png_size_t)length);
+   }
+
+   info_ptr->valid |= PNG_INFO_pCAL;
+#ifdef PNG_FREE_ME_SUPPORTED
+   info_ptr->free_me |= PNG_FREE_PCAL;
+#endif
+}
+#endif
+
+#if defined(PNG_READ_sCAL_SUPPORTED) || defined(PNG_WRITE_sCAL_SUPPORTED)
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+void PNGAPI
+png_set_sCAL(png_structp png_ptr, png_infop info_ptr,
+             int unit, double width, double height)
+{
+   png_debug1(1, "in %s storage function\n", "sCAL");
+   if (png_ptr == NULL || info_ptr == NULL)
+      return;
+
+   info_ptr->scal_unit = (png_byte)unit;
+   info_ptr->scal_pixel_width = width;
+   info_ptr->scal_pixel_height = height;
+
+   info_ptr->valid |= PNG_INFO_sCAL;
+}
+#else
+#ifdef PNG_FIXED_POINT_SUPPORTED
+void PNGAPI
+png_set_sCAL_s(png_structp png_ptr, png_infop info_ptr,
+             int unit, png_charp swidth, png_charp sheight)
+{
+   png_uint_32 length;
+
+   png_debug1(1, "in %s storage function\n", "sCAL");
+   if (png_ptr == NULL || info_ptr == NULL)
+      return;
+
+   info_ptr->scal_unit = (png_byte)unit;
+
+   length = png_strlen(swidth) + 1;
+   png_debug1(3, "allocating unit for info (%d bytes)\n", length);
+   info_ptr->scal_s_width = (png_charp)png_malloc(png_ptr, length);
+   png_memcpy(info_ptr->scal_s_width, swidth, (png_size_t)length);
+
+   length = png_strlen(sheight) + 1;
+   png_debug1(3, "allocating unit for info (%d bytes)\n", length);
+   info_ptr->scal_s_height = (png_charp)png_malloc(png_ptr, length);
+   png_memcpy(info_ptr->scal_s_height, sheight, (png_size_t)length);
+
+   info_ptr->valid |= PNG_INFO_sCAL;
+#ifdef PNG_FREE_ME_SUPPORTED
+   info_ptr->free_me |= PNG_FREE_SCAL;
+#endif
+}
+#endif
+#endif
+#endif
+
+#if defined(PNG_pHYs_SUPPORTED)
+void PNGAPI
+png_set_pHYs(png_structp png_ptr, png_infop info_ptr,
+   png_uint_32 res_x, png_uint_32 res_y, int unit_type)
+{
+   png_debug1(1, "in %s storage function\n", "pHYs");
+   if (png_ptr == NULL || info_ptr == NULL)
+      return;
+
+   info_ptr->x_pixels_per_unit = res_x;
+   info_ptr->y_pixels_per_unit = res_y;
+   info_ptr->phys_unit_type = (png_byte)unit_type;
+   info_ptr->valid |= PNG_INFO_pHYs;
+}
+#endif
+
+void PNGAPI
+png_set_PLTE(png_structp png_ptr, png_infop info_ptr,
+   png_colorp palette, int num_palette)
+{
+
+   png_debug1(1, "in %s storage function\n", "PLTE");
+   if (png_ptr == NULL || info_ptr == NULL)
+      return;
+
+   /*
+    * It may not actually be necessary to set png_ptr->palette here;
+    * we do it for backward compatibility with the way the png_handle_tRNS
+    * function used to do the allocation.
+    */
+#ifdef PNG_FREE_ME_SUPPORTED
+   png_free_data(png_ptr, info_ptr, PNG_FREE_PLTE, 0);
+#endif
+   /* Changed in libpng-1.2.1 to allocate 256 instead of num_palette entries,
+      in case of an invalid PNG file that has too-large sample values. */
+   png_ptr->palette = (png_colorp)png_zalloc(png_ptr, (uInt)256,
+      sizeof (png_color));
+   if (png_ptr->palette == NULL)
+      png_error(png_ptr, "Unable to malloc palette");
+   png_memcpy(png_ptr->palette, palette, num_palette * sizeof (png_color));
+   info_ptr->palette = png_ptr->palette;
+   info_ptr->num_palette = png_ptr->num_palette = (png_uint_16)num_palette;
+
+#ifdef PNG_FREE_ME_SUPPORTED
+   info_ptr->free_me |= PNG_FREE_PLTE;
+#else
+   png_ptr->flags |= PNG_FLAG_FREE_PLTE;
+#endif
+
+   info_ptr->valid |= PNG_INFO_PLTE;
+}
+
+#if defined(PNG_sBIT_SUPPORTED)
+void PNGAPI
+png_set_sBIT(png_structp png_ptr, png_infop info_ptr,
+   png_color_8p sig_bit)
+{
+   png_debug1(1, "in %s storage function\n", "sBIT");
+   if (png_ptr == NULL || info_ptr == NULL)
+      return;
+
+   png_memcpy(&(info_ptr->sig_bit), sig_bit, sizeof (png_color_8));
+   info_ptr->valid |= PNG_INFO_sBIT;
+}
+#endif
+
+#if defined(PNG_sRGB_SUPPORTED)
+void PNGAPI
+png_set_sRGB(png_structp png_ptr, png_infop info_ptr, int intent)
+{
+   png_debug1(1, "in %s storage function\n", "sRGB");
+   if (png_ptr == NULL || info_ptr == NULL)
+      return;
+
+   info_ptr->srgb_intent = (png_byte)intent;
+   info_ptr->valid |= PNG_INFO_sRGB;
+}
+
+void PNGAPI
+png_set_sRGB_gAMA_and_cHRM(png_structp png_ptr, png_infop info_ptr,
+   int intent)
+{
+#if defined(PNG_gAMA_SUPPORTED)
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+   float file_gamma;
+#endif
+#ifdef PNG_FIXED_POINT_SUPPORTED
+   png_fixed_point int_file_gamma;
+#endif
+#endif
+#if defined(PNG_cHRM_SUPPORTED)
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+   float white_x, white_y, red_x, red_y, green_x, green_y, blue_x, blue_y;
+#endif
+#ifdef PNG_FIXED_POINT_SUPPORTED
+   png_fixed_point int_white_x, int_white_y, int_red_x, int_red_y, int_green_x,
+      int_green_y, int_blue_x, int_blue_y;
+#endif
+#endif
+   png_debug1(1, "in %s storage function\n", "sRGB_gAMA_and_cHRM");
+   if (png_ptr == NULL || info_ptr == NULL)
+      return;
+
+   png_set_sRGB(png_ptr, info_ptr, intent);
+
+#if defined(PNG_gAMA_SUPPORTED)
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+   file_gamma = (float).45455;
+   png_set_gAMA(png_ptr, info_ptr, file_gamma);
+#endif
+#ifdef PNG_FIXED_POINT_SUPPORTED
+   int_file_gamma = 45455L;
+   png_set_gAMA_fixed(png_ptr, info_ptr, int_file_gamma);
+#endif
+#endif
+
+#if defined(PNG_cHRM_SUPPORTED)
+#ifdef PNG_FIXED_POINT_SUPPORTED
+   int_white_x = 31270L;
+   int_white_y = 32900L;
+   int_red_x   = 64000L;
+   int_red_y   = 33000L;
+   int_green_x = 30000L;
+   int_green_y = 60000L;
+   int_blue_x  = 15000L;
+   int_blue_y  =  6000L;
+
+   png_set_cHRM_fixed(png_ptr, info_ptr,
+      int_white_x, int_white_y, int_red_x, int_red_y, int_green_x, int_green_y,
+      int_blue_x, int_blue_y);
+#endif
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+   white_x = (float).3127;
+   white_y = (float).3290;
+   red_x   = (float).64;
+   red_y   = (float).33;
+   green_x = (float).30;
+   green_y = (float).60;
+   blue_x  = (float).15;
+   blue_y  = (float).06;
+
+   png_set_cHRM(png_ptr, info_ptr,
+      white_x, white_y, red_x, red_y, green_x, green_y, blue_x, blue_y);
+#endif
+#endif
+}
+#endif
+
+
+#if defined(PNG_iCCP_SUPPORTED)
+void PNGAPI
+png_set_iCCP(png_structp png_ptr, png_infop info_ptr,
+             png_charp name, int compression_type,
+             png_charp profile, png_uint_32 proflen)
+{
+   png_charp new_iccp_name;
+   png_charp new_iccp_profile;
+
+   png_debug1(1, "in %s storage function\n", "iCCP");
+   if (png_ptr == NULL || info_ptr == NULL || name == NULL || profile == NULL)
+      return;
+
+   new_iccp_name = (png_charp)png_malloc(png_ptr, png_strlen(name)+1);
+   png_strcpy(new_iccp_name, name);
+   new_iccp_profile = (png_charp)png_malloc(png_ptr, proflen);
+   png_memcpy(new_iccp_profile, profile, (png_size_t)proflen);
+
+   png_free_data(png_ptr, info_ptr, PNG_FREE_ICCP, 0);
+
+   info_ptr->iccp_proflen = proflen;
+   info_ptr->iccp_name = new_iccp_name;
+   info_ptr->iccp_profile = new_iccp_profile;
+   /* Compression is always zero but is here so the API and info structure
+    * does not have to change if we introduce multiple compression types */
+   info_ptr->iccp_compression = (png_byte)compression_type;
+#ifdef PNG_FREE_ME_SUPPORTED
+   info_ptr->free_me |= PNG_FREE_ICCP;
+#endif
+   info_ptr->valid |= PNG_INFO_iCCP;
+}
+#endif
+
+#if defined(PNG_TEXT_SUPPORTED)
+void PNGAPI
+png_set_text(png_structp png_ptr, png_infop info_ptr, png_textp text_ptr,
+   int num_text)
+{
+   int ret;
+   ret=png_set_text_2(png_ptr, info_ptr, text_ptr, num_text);
+   if (ret)
+     png_error(png_ptr, "Insufficient memory to store text");
+}
+
+int /* PRIVATE */
+png_set_text_2(png_structp png_ptr, png_infop info_ptr, png_textp text_ptr,
+   int num_text)
+{
+   int i;
+
+   png_debug1(1, "in %s storage function\n", (png_ptr->chunk_name[0] == '\0' ?
+      "text" : (png_const_charp)png_ptr->chunk_name));
+
+   if (png_ptr == NULL || info_ptr == NULL || num_text == 0)
+      return(0);
+
+   /* Make sure we have enough space in the "text" array in info_struct
+    * to hold all of the incoming text_ptr objects.
+    */
+   if (info_ptr->num_text + num_text > info_ptr->max_text)
+   {
+      if (info_ptr->text != NULL)
+      {
+         png_textp old_text;
+         int old_max;
+
+         old_max = info_ptr->max_text;
+         info_ptr->max_text = info_ptr->num_text + num_text + 8;
+         old_text = info_ptr->text;
+         info_ptr->text = (png_textp)png_malloc_warn(png_ptr,
+            (png_uint_32)(info_ptr->max_text * sizeof (png_text)));
+         if (info_ptr->text == NULL)
+           {
+             png_free(png_ptr, old_text);
+             return(1);
+           }
+         png_memcpy(info_ptr->text, old_text, (png_size_t)(old_max *
+            sizeof(png_text)));
+         png_free(png_ptr, old_text);
+      }
+      else
+      {
+         info_ptr->max_text = num_text + 8;
+         info_ptr->num_text = 0;
+         info_ptr->text = (png_textp)png_malloc_warn(png_ptr,
+            (png_uint_32)(info_ptr->max_text * sizeof (png_text)));
+         if (info_ptr->text == NULL)
+           return(1);
+#ifdef PNG_FREE_ME_SUPPORTED
+         info_ptr->free_me |= PNG_FREE_TEXT;
+#endif
+      }
+      png_debug1(3, "allocated %d entries for info_ptr->text\n",
+         info_ptr->max_text);
+   }
+   for (i = 0; i < num_text; i++)
+   {
+      png_size_t text_length,key_len;
+      png_size_t lang_len,lang_key_len;
+      png_textp textp = &(info_ptr->text[info_ptr->num_text]);
+
+      if (text_ptr[i].key == NULL)
+          continue;
+
+      key_len = png_strlen(text_ptr[i].key);
+
+      if(text_ptr[i].compression <= 0)
+      {
+        lang_len = 0;
+        lang_key_len = 0;
+      }
+      else
+#ifdef PNG_iTXt_SUPPORTED
+      {
+        /* set iTXt data */
+        if (text_ptr[i].lang != NULL)
+          lang_len = png_strlen(text_ptr[i].lang);
+        else
+          lang_len = 0;
+        if (text_ptr[i].lang_key != NULL)
+          lang_key_len = png_strlen(text_ptr[i].lang_key);
+        else
+          lang_key_len = 0;
+      }
+#else
+      {
+        png_warning(png_ptr, "iTXt chunk not supported.");
+        continue;
+      }
+#endif
+
+      if (text_ptr[i].text == NULL || text_ptr[i].text[0] == '\0')
+      {
+         text_length = 0;
+#ifdef PNG_iTXt_SUPPORTED
+         if(text_ptr[i].compression > 0)
+            textp->compression = PNG_ITXT_COMPRESSION_NONE;
+         else
+#endif
+            textp->compression = PNG_TEXT_COMPRESSION_NONE;
+      }
+      else
+      {
+         text_length = png_strlen(text_ptr[i].text);
+         textp->compression = text_ptr[i].compression;
+      }
+
+      textp->key = (png_charp)png_malloc_warn(png_ptr,
+         (png_uint_32)(key_len + text_length + lang_len + lang_key_len + 4));
+      if (textp->key == NULL)
+        return(1);
+      png_debug2(2, "Allocated %lu bytes at %x in png_set_text\n",
+         (png_uint_32)(key_len + lang_len + lang_key_len + text_length + 4),
+         (int)textp->key);
+
+      png_memcpy(textp->key, text_ptr[i].key,
+         (png_size_t)(key_len));
+      *(textp->key+key_len) = '\0';
+#ifdef PNG_iTXt_SUPPORTED
+      if (text_ptr[i].compression > 0)
+      {
+         textp->lang=textp->key + key_len + 1;
+         png_memcpy(textp->lang, text_ptr[i].lang, lang_len);
+         *(textp->lang+lang_len) = '\0';
+         textp->lang_key=textp->lang + lang_len + 1;
+         png_memcpy(textp->lang_key, text_ptr[i].lang_key, lang_key_len);
+         *(textp->lang_key+lang_key_len) = '\0';
+         textp->text=textp->lang_key + lang_key_len + 1;
+      }
+      else
+#endif
+      {
+#ifdef PNG_iTXt_SUPPORTED
+         textp->lang=NULL;
+         textp->lang_key=NULL;
+#endif
+         textp->text=textp->key + key_len + 1;
+      }
+      if(text_length)
+         png_memcpy(textp->text, text_ptr[i].text,
+            (png_size_t)(text_length));
+      *(textp->text+text_length) = '\0';
+
+#ifdef PNG_iTXt_SUPPORTED
+      if(textp->compression > 0)
+      {
+         textp->text_length = 0;
+         textp->itxt_length = text_length;
+      }
+      else
+#endif
+      {
+         textp->text_length = text_length;
+#ifdef PNG_iTXt_SUPPORTED
+         textp->itxt_length = 0;
+#endif
+      }
+      info_ptr->text[info_ptr->num_text]= *textp;
+      info_ptr->num_text++;
+      png_debug1(3, "transferred text chunk %d\n", info_ptr->num_text);
+   }
+   return(0);
+}
+#endif
+
+#if defined(PNG_tIME_SUPPORTED)
+void PNGAPI
+png_set_tIME(png_structp png_ptr, png_infop info_ptr, png_timep mod_time)
+{
+   png_debug1(1, "in %s storage function\n", "tIME");
+   if (png_ptr == NULL || info_ptr == NULL ||
+       (png_ptr->mode & PNG_WROTE_tIME))
+      return;
+
+   png_memcpy(&(info_ptr->mod_time), mod_time, sizeof (png_time));
+   info_ptr->valid |= PNG_INFO_tIME;
+}
+#endif
+
+#if defined(PNG_tRNS_SUPPORTED)
+void PNGAPI
+png_set_tRNS(png_structp png_ptr, png_infop info_ptr,
+   png_bytep trans, int num_trans, png_color_16p trans_values)
+{
+   png_debug1(1, "in %s storage function\n", "tRNS");
+   if (png_ptr == NULL || info_ptr == NULL)
+      return;
+
+   if (trans != NULL)
+   {
+       /*
+        * It may not actually be necessary to set png_ptr->trans here;
+        * we do it for backward compatibility with the way the png_handle_tRNS
+        * function used to do the allocation.
+        */
+#ifdef PNG_FREE_ME_SUPPORTED
+       png_free_data(png_ptr, info_ptr, PNG_FREE_TRNS, 0);
+#endif
+       /* Changed from num_trans to 256 in version 1.2.1 */
+       png_ptr->trans = info_ptr->trans = (png_bytep)png_malloc(png_ptr,
+           (png_uint_32)256);
+       png_memcpy(info_ptr->trans, trans, (png_size_t)num_trans);
+#ifdef PNG_FREE_ME_SUPPORTED
+       info_ptr->free_me |= PNG_FREE_TRNS;
+#else
+       png_ptr->flags |= PNG_FLAG_FREE_TRNS;
+#endif
+   }
+
+   if (trans_values != NULL)
+   {
+      png_memcpy(&(info_ptr->trans_values), trans_values,
+         sizeof(png_color_16));
+      if (num_trans == 0)
+        num_trans = 1;
+   }
+   info_ptr->num_trans = (png_uint_16)num_trans;
+   info_ptr->valid |= PNG_INFO_tRNS;
+}
+#endif
+
+#if defined(PNG_sPLT_SUPPORTED)
+void PNGAPI
+png_set_sPLT(png_structp png_ptr,
+             png_infop info_ptr, png_sPLT_tp entries, int nentries)
+{
+    png_sPLT_tp np;
+    int i;
+
+    np = (png_sPLT_tp)png_malloc_warn(png_ptr,
+        (info_ptr->splt_palettes_num + nentries) * sizeof(png_sPLT_t));
+    if (np == NULL)
+    {
+      png_warning(png_ptr, "No memory for sPLT palettes.");
+      return;
+    }
+
+    png_memcpy(np, info_ptr->splt_palettes,
+           info_ptr->splt_palettes_num * sizeof(png_sPLT_t));
+    png_free(png_ptr, info_ptr->splt_palettes);
+    info_ptr->splt_palettes=NULL;
+
+    for (i = 0; i < nentries; i++)
+    {
+        png_sPLT_tp to = np + info_ptr->splt_palettes_num + i;
+        png_sPLT_tp from = entries + i;
+
+        to->name = (png_charp)png_malloc(png_ptr,
+            png_strlen(from->name) + 1);
+        png_strcpy(to->name, from->name);
+        to->entries = (png_sPLT_entryp)png_malloc(png_ptr,
+            from->nentries * sizeof(png_sPLT_t));
+        png_memcpy(to->entries, from->entries,
+            from->nentries * sizeof(png_sPLT_t));
+        to->nentries = from->nentries;
+        to->depth = from->depth;
+    }
+
+    info_ptr->splt_palettes = np;
+    info_ptr->splt_palettes_num += nentries;
+    info_ptr->valid |= PNG_INFO_sPLT;
+#ifdef PNG_FREE_ME_SUPPORTED
+    info_ptr->free_me |= PNG_FREE_SPLT;
+#endif
+}
+#endif /* PNG_sPLT_SUPPORTED */
+
+#if defined(PNG_UNKNOWN_CHUNKS_SUPPORTED)
+void PNGAPI
+png_set_unknown_chunks(png_structp png_ptr,
+   png_infop info_ptr, png_unknown_chunkp unknowns, int num_unknowns)
+{
+    png_unknown_chunkp np;
+    int i;
+
+    if (png_ptr == NULL || info_ptr == NULL || num_unknowns == 0)
+        return;
+
+    np = (png_unknown_chunkp)png_malloc_warn(png_ptr,
+        (info_ptr->unknown_chunks_num + num_unknowns) *
+        sizeof(png_unknown_chunk));
+    if (np == NULL)
+    {
+       png_warning(png_ptr, "Out of memory while processing unknown chunk.");
+       return;
+    }
+
+    png_memcpy(np, info_ptr->unknown_chunks,
+           info_ptr->unknown_chunks_num * sizeof(png_unknown_chunk));
+    png_free(png_ptr, info_ptr->unknown_chunks);
+    info_ptr->unknown_chunks=NULL;
+
+    for (i = 0; i < num_unknowns; i++)
+    {
+        png_unknown_chunkp to = np + info_ptr->unknown_chunks_num + i;
+        png_unknown_chunkp from = unknowns + i;
+
+        png_strcpy((png_charp)to->name, (png_charp)from->name);
+        to->data = (png_bytep)png_malloc(png_ptr, from->size);
+        if (to->data == NULL)
+           png_warning(png_ptr, "Out of memory while processing unknown chunk.");
+        else
+        {
+          png_memcpy(to->data, from->data, from->size);
+          to->size = from->size;
+
+          /* note our location in the read or write sequence */
+          to->location = (png_byte)(png_ptr->mode & 0xff);
+        }
+    }
+
+    info_ptr->unknown_chunks = np;
+    info_ptr->unknown_chunks_num += num_unknowns;
+#ifdef PNG_FREE_ME_SUPPORTED
+    info_ptr->free_me |= PNG_FREE_UNKN;
+#endif
+}
+void PNGAPI
+png_set_unknown_chunk_location(png_structp png_ptr, png_infop info_ptr,
+   int chunk, int location)
+{
+   if(png_ptr != NULL && info_ptr != NULL && chunk >= 0 && chunk <
+         (int)info_ptr->unknown_chunks_num)
+      info_ptr->unknown_chunks[chunk].location = (png_byte)location;
+}
+#endif
+
+#if defined(PNG_READ_EMPTY_PLTE_SUPPORTED) || \
+    defined(PNG_WRITE_EMPTY_PLTE_SUPPORTED)
+void PNGAPI
+png_permit_empty_plte (png_structp png_ptr, int empty_plte_permitted)
+{
+   /* This function is deprecated in favor of png_permit_mng_features()
+      and will be removed from libpng-2.0.0 */
+   png_debug(1, "in png_permit_empty_plte, DEPRECATED.\n");
+   if (png_ptr == NULL)
+      return;
+   png_ptr->mng_features_permitted = (png_byte)
+     ((png_ptr->mng_features_permitted & (~(PNG_FLAG_MNG_EMPTY_PLTE))) |
+     ((empty_plte_permitted & PNG_FLAG_MNG_EMPTY_PLTE)));
+}
+#endif
+
+#if defined(PNG_MNG_FEATURES_SUPPORTED)
+png_uint_32 PNGAPI
+png_permit_mng_features (png_structp png_ptr, png_uint_32 mng_features)
+{
+   png_debug(1, "in png_permit_mng_features\n");
+   if (png_ptr == NULL)
+      return (png_uint_32)0;
+   png_ptr->mng_features_permitted =
+     (png_byte)(mng_features & PNG_ALL_MNG_FEATURES);
+   return (png_uint_32)png_ptr->mng_features_permitted;
+}
+#endif
+
+#if defined(PNG_UNKNOWN_CHUNKS_SUPPORTED)
+void PNGAPI
+png_set_keep_unknown_chunks(png_structp png_ptr, int keep, png_bytep
+   chunk_list, int num_chunks)
+{
+    png_bytep new_list, p;
+    int i, old_num_chunks;
+    if (num_chunks == 0)
+    {
+      if(keep == HANDLE_CHUNK_ALWAYS || keep == HANDLE_CHUNK_IF_SAFE)
+        png_ptr->flags |= PNG_FLAG_KEEP_UNKNOWN_CHUNKS;
+      else
+        png_ptr->flags &= ~PNG_FLAG_KEEP_UNKNOWN_CHUNKS;
+
+      if(keep == HANDLE_CHUNK_ALWAYS)
+        png_ptr->flags |= PNG_FLAG_KEEP_UNSAFE_CHUNKS;
+      else
+        png_ptr->flags &= ~PNG_FLAG_KEEP_UNSAFE_CHUNKS;
+      return;
+    }
+    if (chunk_list == NULL)
+      return;
+    old_num_chunks=png_ptr->num_chunk_list;
+    new_list=(png_bytep)png_malloc(png_ptr,
+       (png_uint_32)(5*(num_chunks+old_num_chunks)));
+    if(png_ptr->chunk_list != NULL)
+    {
+       png_memcpy(new_list, png_ptr->chunk_list,
+          (png_size_t)(5*old_num_chunks));
+       png_free(png_ptr, png_ptr->chunk_list);
+       png_ptr->chunk_list=NULL;
+    }
+    png_memcpy(new_list+5*old_num_chunks, chunk_list,
+       (png_size_t)(5*num_chunks));
+    for (p=new_list+5*old_num_chunks+4, i=0; i<num_chunks; i++, p+=5)
+       *p=(png_byte)keep;
+    png_ptr->num_chunk_list=old_num_chunks+num_chunks;
+    png_ptr->chunk_list=new_list;
+#ifdef PNG_FREE_ME_SUPPORTED
+    png_ptr->free_me |= PNG_FREE_LIST;
+#endif
+}
+#endif
+
+#if defined(PNG_READ_USER_CHUNKS_SUPPORTED)
+void PNGAPI
+png_set_read_user_chunk_fn(png_structp png_ptr, png_voidp user_chunk_ptr,
+   png_user_chunk_ptr read_user_chunk_fn)
+{
+   png_debug(1, "in png_set_read_user_chunk_fn\n");
+   png_ptr->read_user_chunk_fn = read_user_chunk_fn;
+   png_ptr->user_chunk_ptr = user_chunk_ptr;
+}
+#endif
+
+#if defined(PNG_INFO_IMAGE_SUPPORTED)
+void PNGAPI
+png_set_rows(png_structp png_ptr, png_infop info_ptr, png_bytepp row_pointers)
+{
+   png_debug1(1, "in %s storage function\n", "rows");
+
+   if (png_ptr == NULL || info_ptr == NULL)
+      return;
+
+   if(info_ptr->row_pointers && (info_ptr->row_pointers != row_pointers))
+      png_free_data(png_ptr, info_ptr, PNG_FREE_ROWS, 0);
+   info_ptr->row_pointers = row_pointers;
+   if(row_pointers)
+      info_ptr->valid |= PNG_INFO_IDAT;
+}
+#endif
+
+void PNGAPI
+png_set_compression_buffer_size(png_structp png_ptr, png_uint_32 size)
+{
+    if(png_ptr->zbuf)
+       png_free(png_ptr, png_ptr->zbuf);
+    png_ptr->zbuf_size = (png_size_t)size;
+    png_ptr->zbuf = (png_bytep)png_malloc(png_ptr, size);
+    png_ptr->zstream.next_out = png_ptr->zbuf;
+    png_ptr->zstream.avail_out = (uInt)png_ptr->zbuf_size;
+}
+
+void PNGAPI
+png_set_invalid(png_structp png_ptr, png_infop info_ptr, int mask)
+{
+   if (png_ptr && info_ptr)
+      info_ptr->valid &= ~(mask);
+}
+
+
+#ifndef PNG_1_0_X
+#ifdef PNG_ASSEMBLER_CODE_SUPPORTED
+/* this function was added to libpng 1.2.0 and should always exist by default */
+void PNGAPI
+png_set_asm_flags (png_structp png_ptr, png_uint_32 asm_flags)
+{
+    png_uint_32 settable_asm_flags;
+    png_uint_32 settable_mmx_flags;
+
+    settable_mmx_flags =
+#ifdef PNG_HAVE_ASSEMBLER_COMBINE_ROW
+                         PNG_ASM_FLAG_MMX_READ_COMBINE_ROW  |
+#endif
+#ifdef PNG_HAVE_ASSEMBLER_READ_INTERLACE
+                         PNG_ASM_FLAG_MMX_READ_INTERLACE    |
+#endif
+#ifdef PNG_HAVE_ASSEMBLER_READ_FILTER_ROW
+                         PNG_ASM_FLAG_MMX_READ_FILTER_SUB   |
+                         PNG_ASM_FLAG_MMX_READ_FILTER_UP    |
+                         PNG_ASM_FLAG_MMX_READ_FILTER_AVG   |
+                         PNG_ASM_FLAG_MMX_READ_FILTER_PAETH |
+#endif
+                         0;
+
+    /* could be some non-MMX ones in the future, but not currently: */
+    settable_asm_flags = settable_mmx_flags;
+
+    if (!(png_ptr->asm_flags & PNG_ASM_FLAG_MMX_SUPPORT_COMPILED) ||
+        !(png_ptr->asm_flags & PNG_ASM_FLAG_MMX_SUPPORT_IN_CPU))
+    {
+        /* clear all MMX flags if MMX isn't supported */
+        settable_asm_flags &= ~settable_mmx_flags;
+        png_ptr->asm_flags &= ~settable_mmx_flags;
+    }
+
+    /* we're replacing the settable bits with those passed in by the user,
+     * so first zero them out of the master copy, then logical-OR in the
+     * allowed subset that was requested */
+
+    png_ptr->asm_flags &= ~settable_asm_flags;               /* zero them */
+    png_ptr->asm_flags |= (asm_flags & settable_asm_flags);  /* set them */
+}
+#endif /* ?PNG_ASSEMBLER_CODE_SUPPORTED */
+
+#ifdef PNG_ASSEMBLER_CODE_SUPPORTED
+/* this function was added to libpng 1.2.0 */
+void PNGAPI
+png_set_mmx_thresholds (png_structp png_ptr,
+                        png_byte mmx_bitdepth_threshold,
+                        png_uint_32 mmx_rowbytes_threshold)
+{
+    png_ptr->mmx_bitdepth_threshold = mmx_bitdepth_threshold;
+    png_ptr->mmx_rowbytes_threshold = mmx_rowbytes_threshold;
+}
+#endif /* ?PNG_ASSEMBLER_CODE_SUPPORTED */
+#endif /* ?PNG_1_0_X */
diff --git a/collects/plot/src/all/pngtrans.c b/collects/plot/src/all/pngtrans.c
new file mode 100644
index 0000000000..f08fb4ecfe
--- /dev/null
+++ b/collects/plot/src/all/pngtrans.c
@@ -0,0 +1,640 @@
+
+/* pngtrans.c - transforms the data in a row (used by both readers and writers)
+ *
+ * libpng 1.2.5 - October 3, 2002
+ * For conditions of distribution and use, see copyright notice in png.h
+ * Copyright (c) 1998-2002 Glenn Randers-Pehrson
+ * (Version 0.96 Copyright (c) 1996, 1997 Andreas Dilger)
+ * (Version 0.88 Copyright (c) 1995, 1996 Guy Eric Schalnat, Group 42, Inc.)
+ */
+
+#define PNG_INTERNAL
+#include "png.h"
+
+#if defined(PNG_READ_BGR_SUPPORTED) || defined(PNG_WRITE_BGR_SUPPORTED)
+/* turn on BGR-to-RGB mapping */
+void PNGAPI
+png_set_bgr(png_structp png_ptr)
+{
+   png_debug(1, "in png_set_bgr\n");
+   png_ptr->transformations |= PNG_BGR;
+}
+#endif
+
+#if defined(PNG_READ_SWAP_SUPPORTED) || defined(PNG_WRITE_SWAP_SUPPORTED)
+/* turn on 16 bit byte swapping */
+void PNGAPI
+png_set_swap(png_structp png_ptr)
+{
+   png_debug(1, "in png_set_swap\n");
+   if (png_ptr->bit_depth == 16)
+      png_ptr->transformations |= PNG_SWAP_BYTES;
+}
+#endif
+
+#if defined(PNG_READ_PACK_SUPPORTED) || defined(PNG_WRITE_PACK_SUPPORTED)
+/* turn on pixel packing */
+void PNGAPI
+png_set_packing(png_structp png_ptr)
+{
+   png_debug(1, "in png_set_packing\n");
+   if (png_ptr->bit_depth < 8)
+   {
+      png_ptr->transformations |= PNG_PACK;
+      png_ptr->usr_bit_depth = 8;
+   }
+}
+#endif
+
+#if defined(PNG_READ_PACKSWAP_SUPPORTED)||defined(PNG_WRITE_PACKSWAP_SUPPORTED)
+/* turn on packed pixel swapping */
+void PNGAPI
+png_set_packswap(png_structp png_ptr)
+{
+   png_debug(1, "in png_set_packswap\n");
+   if (png_ptr->bit_depth < 8)
+      png_ptr->transformations |= PNG_PACKSWAP;
+}
+#endif
+
+#if defined(PNG_READ_SHIFT_SUPPORTED) || defined(PNG_WRITE_SHIFT_SUPPORTED)
+void PNGAPI
+png_set_shift(png_structp png_ptr, png_color_8p true_bits)
+{
+   png_debug(1, "in png_set_shift\n");
+   png_ptr->transformations |= PNG_SHIFT;
+   png_ptr->shift = *true_bits;
+}
+#endif
+
+#if defined(PNG_READ_INTERLACING_SUPPORTED) || \
+    defined(PNG_WRITE_INTERLACING_SUPPORTED)
+int PNGAPI
+png_set_interlace_handling(png_structp png_ptr)
+{
+   png_debug(1, "in png_set_interlace handling\n");
+   if (png_ptr->interlaced)
+   {
+      png_ptr->transformations |= PNG_INTERLACE;
+      return (7);
+   }
+
+   return (1);
+}
+#endif
+
+#if defined(PNG_READ_FILLER_SUPPORTED) || defined(PNG_WRITE_FILLER_SUPPORTED)
+/* Add a filler byte on read, or remove a filler or alpha byte on write.
+ * The filler type has changed in v0.95 to allow future 2-byte fillers
+ * for 48-bit input data, as well as to avoid problems with some compilers
+ * that don't like bytes as parameters.
+ */
+void PNGAPI
+png_set_filler(png_structp png_ptr, png_uint_32 filler, int filler_loc)
+{
+   png_debug(1, "in png_set_filler\n");
+   png_ptr->transformations |= PNG_FILLER;
+   png_ptr->filler = (png_byte)filler;
+   if (filler_loc == PNG_FILLER_AFTER)
+      png_ptr->flags |= PNG_FLAG_FILLER_AFTER;
+   else
+      png_ptr->flags &= ~PNG_FLAG_FILLER_AFTER;
+
+   /* This should probably go in the "do_filler" routine.
+    * I attempted to do that in libpng-1.0.1a but that caused problems
+    * so I restored it in libpng-1.0.2a
+   */
+
+   if (png_ptr->color_type == PNG_COLOR_TYPE_RGB)
+   {
+      png_ptr->usr_channels = 4;
+   }
+
+   /* Also I added this in libpng-1.0.2a (what happens when we expand
+    * a less-than-8-bit grayscale to GA? */
+
+   if (png_ptr->color_type == PNG_COLOR_TYPE_GRAY && png_ptr->bit_depth >= 8)
+   {
+      png_ptr->usr_channels = 2;
+   }
+}
+#endif
+
+#if defined(PNG_READ_SWAP_ALPHA_SUPPORTED) || \
+    defined(PNG_WRITE_SWAP_ALPHA_SUPPORTED)
+void PNGAPI
+png_set_swap_alpha(png_structp png_ptr)
+{
+   png_debug(1, "in png_set_swap_alpha\n");
+   png_ptr->transformations |= PNG_SWAP_ALPHA;
+}
+#endif
+
+#if defined(PNG_READ_INVERT_ALPHA_SUPPORTED) || \
+    defined(PNG_WRITE_INVERT_ALPHA_SUPPORTED)
+void PNGAPI
+png_set_invert_alpha(png_structp png_ptr)
+{
+   png_debug(1, "in png_set_invert_alpha\n");
+   png_ptr->transformations |= PNG_INVERT_ALPHA;
+}
+#endif
+
+#if defined(PNG_READ_INVERT_SUPPORTED) || defined(PNG_WRITE_INVERT_SUPPORTED)
+void PNGAPI
+png_set_invert_mono(png_structp png_ptr)
+{
+   png_debug(1, "in png_set_invert_mono\n");
+   png_ptr->transformations |= PNG_INVERT_MONO;
+}
+
+/* invert monochrome grayscale data */
+void /* PRIVATE */
+png_do_invert(png_row_infop row_info, png_bytep row)
+{
+   png_debug(1, "in png_do_invert\n");
+  /* This test removed from libpng version 1.0.13 and 1.2.0:
+   *   if (row_info->bit_depth == 1 &&
+   */
+#if defined(PNG_USELESS_TESTS_SUPPORTED)
+   if (row == NULL || row_info == NULL)
+     return;
+#endif
+   if (row_info->color_type == PNG_COLOR_TYPE_GRAY)
+   {
+      png_bytep rp = row;
+      png_uint_32 i;
+      png_uint_32 istop = row_info->rowbytes;
+
+      for (i = 0; i < istop; i++)
+      {
+         *rp = (png_byte)(~(*rp));
+         rp++;
+      }
+   }
+   else if (row_info->color_type == PNG_COLOR_TYPE_GRAY_ALPHA &&
+      row_info->bit_depth == 8)
+   {
+      png_bytep rp = row;
+      png_uint_32 i;
+      png_uint_32 istop = row_info->rowbytes;
+
+      for (i = 0; i < istop; i+=2)
+      {
+         *rp = (png_byte)(~(*rp));
+         rp+=2;
+      }
+   }
+   else if (row_info->color_type == PNG_COLOR_TYPE_GRAY_ALPHA &&
+      row_info->bit_depth == 16)
+   {
+      png_bytep rp = row;
+      png_uint_32 i;
+      png_uint_32 istop = row_info->rowbytes;
+
+      for (i = 0; i < istop; i+=4)
+      {
+         *rp = (png_byte)(~(*rp));
+         *(rp+1) = (png_byte)(~(*(rp+1)));
+         rp+=4;
+      }
+   }
+}
+#endif
+
+#if defined(PNG_READ_SWAP_SUPPORTED) || defined(PNG_WRITE_SWAP_SUPPORTED)
+/* swaps byte order on 16 bit depth images */
+void /* PRIVATE */
+png_do_swap(png_row_infop row_info, png_bytep row)
+{
+   png_debug(1, "in png_do_swap\n");
+   if (
+#if defined(PNG_USELESS_TESTS_SUPPORTED)
+       row != NULL && row_info != NULL &&
+#endif
+       row_info->bit_depth == 16)
+   {
+      png_bytep rp = row;
+      png_uint_32 i;
+      png_uint_32 istop= row_info->width * row_info->channels;
+
+      for (i = 0; i < istop; i++, rp += 2)
+      {
+         png_byte t = *rp;
+         *rp = *(rp + 1);
+         *(rp + 1) = t;
+      }
+   }
+}
+#endif
+
+#if defined(PNG_READ_PACKSWAP_SUPPORTED)||defined(PNG_WRITE_PACKSWAP_SUPPORTED)
+static png_byte onebppswaptable[256] = {
+   0x00, 0x80, 0x40, 0xC0, 0x20, 0xA0, 0x60, 0xE0,
+   0x10, 0x90, 0x50, 0xD0, 0x30, 0xB0, 0x70, 0xF0,
+   0x08, 0x88, 0x48, 0xC8, 0x28, 0xA8, 0x68, 0xE8,
+   0x18, 0x98, 0x58, 0xD8, 0x38, 0xB8, 0x78, 0xF8,
+   0x04, 0x84, 0x44, 0xC4, 0x24, 0xA4, 0x64, 0xE4,
+   0x14, 0x94, 0x54, 0xD4, 0x34, 0xB4, 0x74, 0xF4,
+   0x0C, 0x8C, 0x4C, 0xCC, 0x2C, 0xAC, 0x6C, 0xEC,
+   0x1C, 0x9C, 0x5C, 0xDC, 0x3C, 0xBC, 0x7C, 0xFC,
+   0x02, 0x82, 0x42, 0xC2, 0x22, 0xA2, 0x62, 0xE2,
+   0x12, 0x92, 0x52, 0xD2, 0x32, 0xB2, 0x72, 0xF2,
+   0x0A, 0x8A, 0x4A, 0xCA, 0x2A, 0xAA, 0x6A, 0xEA,
+   0x1A, 0x9A, 0x5A, 0xDA, 0x3A, 0xBA, 0x7A, 0xFA,
+   0x06, 0x86, 0x46, 0xC6, 0x26, 0xA6, 0x66, 0xE6,
+   0x16, 0x96, 0x56, 0xD6, 0x36, 0xB6, 0x76, 0xF6,
+   0x0E, 0x8E, 0x4E, 0xCE, 0x2E, 0xAE, 0x6E, 0xEE,
+   0x1E, 0x9E, 0x5E, 0xDE, 0x3E, 0xBE, 0x7E, 0xFE,
+   0x01, 0x81, 0x41, 0xC1, 0x21, 0xA1, 0x61, 0xE1,
+   0x11, 0x91, 0x51, 0xD1, 0x31, 0xB1, 0x71, 0xF1,
+   0x09, 0x89, 0x49, 0xC9, 0x29, 0xA9, 0x69, 0xE9,
+   0x19, 0x99, 0x59, 0xD9, 0x39, 0xB9, 0x79, 0xF9,
+   0x05, 0x85, 0x45, 0xC5, 0x25, 0xA5, 0x65, 0xE5,
+   0x15, 0x95, 0x55, 0xD5, 0x35, 0xB5, 0x75, 0xF5,
+   0x0D, 0x8D, 0x4D, 0xCD, 0x2D, 0xAD, 0x6D, 0xED,
+   0x1D, 0x9D, 0x5D, 0xDD, 0x3D, 0xBD, 0x7D, 0xFD,
+   0x03, 0x83, 0x43, 0xC3, 0x23, 0xA3, 0x63, 0xE3,
+   0x13, 0x93, 0x53, 0xD3, 0x33, 0xB3, 0x73, 0xF3,
+   0x0B, 0x8B, 0x4B, 0xCB, 0x2B, 0xAB, 0x6B, 0xEB,
+   0x1B, 0x9B, 0x5B, 0xDB, 0x3B, 0xBB, 0x7B, 0xFB,
+   0x07, 0x87, 0x47, 0xC7, 0x27, 0xA7, 0x67, 0xE7,
+   0x17, 0x97, 0x57, 0xD7, 0x37, 0xB7, 0x77, 0xF7,
+   0x0F, 0x8F, 0x4F, 0xCF, 0x2F, 0xAF, 0x6F, 0xEF,
+   0x1F, 0x9F, 0x5F, 0xDF, 0x3F, 0xBF, 0x7F, 0xFF
+};
+
+static png_byte twobppswaptable[256] = {
+   0x00, 0x40, 0x80, 0xC0, 0x10, 0x50, 0x90, 0xD0,
+   0x20, 0x60, 0xA0, 0xE0, 0x30, 0x70, 0xB0, 0xF0,
+   0x04, 0x44, 0x84, 0xC4, 0x14, 0x54, 0x94, 0xD4,
+   0x24, 0x64, 0xA4, 0xE4, 0x34, 0x74, 0xB4, 0xF4,
+   0x08, 0x48, 0x88, 0xC8, 0x18, 0x58, 0x98, 0xD8,
+   0x28, 0x68, 0xA8, 0xE8, 0x38, 0x78, 0xB8, 0xF8,
+   0x0C, 0x4C, 0x8C, 0xCC, 0x1C, 0x5C, 0x9C, 0xDC,
+   0x2C, 0x6C, 0xAC, 0xEC, 0x3C, 0x7C, 0xBC, 0xFC,
+   0x01, 0x41, 0x81, 0xC1, 0x11, 0x51, 0x91, 0xD1,
+   0x21, 0x61, 0xA1, 0xE1, 0x31, 0x71, 0xB1, 0xF1,
+   0x05, 0x45, 0x85, 0xC5, 0x15, 0x55, 0x95, 0xD5,
+   0x25, 0x65, 0xA5, 0xE5, 0x35, 0x75, 0xB5, 0xF5,
+   0x09, 0x49, 0x89, 0xC9, 0x19, 0x59, 0x99, 0xD9,
+   0x29, 0x69, 0xA9, 0xE9, 0x39, 0x79, 0xB9, 0xF9,
+   0x0D, 0x4D, 0x8D, 0xCD, 0x1D, 0x5D, 0x9D, 0xDD,
+   0x2D, 0x6D, 0xAD, 0xED, 0x3D, 0x7D, 0xBD, 0xFD,
+   0x02, 0x42, 0x82, 0xC2, 0x12, 0x52, 0x92, 0xD2,
+   0x22, 0x62, 0xA2, 0xE2, 0x32, 0x72, 0xB2, 0xF2,
+   0x06, 0x46, 0x86, 0xC6, 0x16, 0x56, 0x96, 0xD6,
+   0x26, 0x66, 0xA6, 0xE6, 0x36, 0x76, 0xB6, 0xF6,
+   0x0A, 0x4A, 0x8A, 0xCA, 0x1A, 0x5A, 0x9A, 0xDA,
+   0x2A, 0x6A, 0xAA, 0xEA, 0x3A, 0x7A, 0xBA, 0xFA,
+   0x0E, 0x4E, 0x8E, 0xCE, 0x1E, 0x5E, 0x9E, 0xDE,
+   0x2E, 0x6E, 0xAE, 0xEE, 0x3E, 0x7E, 0xBE, 0xFE,
+   0x03, 0x43, 0x83, 0xC3, 0x13, 0x53, 0x93, 0xD3,
+   0x23, 0x63, 0xA3, 0xE3, 0x33, 0x73, 0xB3, 0xF3,
+   0x07, 0x47, 0x87, 0xC7, 0x17, 0x57, 0x97, 0xD7,
+   0x27, 0x67, 0xA7, 0xE7, 0x37, 0x77, 0xB7, 0xF7,
+   0x0B, 0x4B, 0x8B, 0xCB, 0x1B, 0x5B, 0x9B, 0xDB,
+   0x2B, 0x6B, 0xAB, 0xEB, 0x3B, 0x7B, 0xBB, 0xFB,
+   0x0F, 0x4F, 0x8F, 0xCF, 0x1F, 0x5F, 0x9F, 0xDF,
+   0x2F, 0x6F, 0xAF, 0xEF, 0x3F, 0x7F, 0xBF, 0xFF
+};
+
+static png_byte fourbppswaptable[256] = {
+   0x00, 0x10, 0x20, 0x30, 0x40, 0x50, 0x60, 0x70,
+   0x80, 0x90, 0xA0, 0xB0, 0xC0, 0xD0, 0xE0, 0xF0,
+   0x01, 0x11, 0x21, 0x31, 0x41, 0x51, 0x61, 0x71,
+   0x81, 0x91, 0xA1, 0xB1, 0xC1, 0xD1, 0xE1, 0xF1,
+   0x02, 0x12, 0x22, 0x32, 0x42, 0x52, 0x62, 0x72,
+   0x82, 0x92, 0xA2, 0xB2, 0xC2, 0xD2, 0xE2, 0xF2,
+   0x03, 0x13, 0x23, 0x33, 0x43, 0x53, 0x63, 0x73,
+   0x83, 0x93, 0xA3, 0xB3, 0xC3, 0xD3, 0xE3, 0xF3,
+   0x04, 0x14, 0x24, 0x34, 0x44, 0x54, 0x64, 0x74,
+   0x84, 0x94, 0xA4, 0xB4, 0xC4, 0xD4, 0xE4, 0xF4,
+   0x05, 0x15, 0x25, 0x35, 0x45, 0x55, 0x65, 0x75,
+   0x85, 0x95, 0xA5, 0xB5, 0xC5, 0xD5, 0xE5, 0xF5,
+   0x06, 0x16, 0x26, 0x36, 0x46, 0x56, 0x66, 0x76,
+   0x86, 0x96, 0xA6, 0xB6, 0xC6, 0xD6, 0xE6, 0xF6,
+   0x07, 0x17, 0x27, 0x37, 0x47, 0x57, 0x67, 0x77,
+   0x87, 0x97, 0xA7, 0xB7, 0xC7, 0xD7, 0xE7, 0xF7,
+   0x08, 0x18, 0x28, 0x38, 0x48, 0x58, 0x68, 0x78,
+   0x88, 0x98, 0xA8, 0xB8, 0xC8, 0xD8, 0xE8, 0xF8,
+   0x09, 0x19, 0x29, 0x39, 0x49, 0x59, 0x69, 0x79,
+   0x89, 0x99, 0xA9, 0xB9, 0xC9, 0xD9, 0xE9, 0xF9,
+   0x0A, 0x1A, 0x2A, 0x3A, 0x4A, 0x5A, 0x6A, 0x7A,
+   0x8A, 0x9A, 0xAA, 0xBA, 0xCA, 0xDA, 0xEA, 0xFA,
+   0x0B, 0x1B, 0x2B, 0x3B, 0x4B, 0x5B, 0x6B, 0x7B,
+   0x8B, 0x9B, 0xAB, 0xBB, 0xCB, 0xDB, 0xEB, 0xFB,
+   0x0C, 0x1C, 0x2C, 0x3C, 0x4C, 0x5C, 0x6C, 0x7C,
+   0x8C, 0x9C, 0xAC, 0xBC, 0xCC, 0xDC, 0xEC, 0xFC,
+   0x0D, 0x1D, 0x2D, 0x3D, 0x4D, 0x5D, 0x6D, 0x7D,
+   0x8D, 0x9D, 0xAD, 0xBD, 0xCD, 0xDD, 0xED, 0xFD,
+   0x0E, 0x1E, 0x2E, 0x3E, 0x4E, 0x5E, 0x6E, 0x7E,
+   0x8E, 0x9E, 0xAE, 0xBE, 0xCE, 0xDE, 0xEE, 0xFE,
+   0x0F, 0x1F, 0x2F, 0x3F, 0x4F, 0x5F, 0x6F, 0x7F,
+   0x8F, 0x9F, 0xAF, 0xBF, 0xCF, 0xDF, 0xEF, 0xFF
+};
+
+/* swaps pixel packing order within bytes */
+void /* PRIVATE */
+png_do_packswap(png_row_infop row_info, png_bytep row)
+{
+   png_debug(1, "in png_do_packswap\n");
+   if (
+#if defined(PNG_USELESS_TESTS_SUPPORTED)
+       row != NULL && row_info != NULL &&
+#endif
+       row_info->bit_depth < 8)
+   {
+      png_bytep rp, end, table;
+
+      end = row + row_info->rowbytes;
+
+      if (row_info->bit_depth == 1)
+         table = onebppswaptable;
+      else if (row_info->bit_depth == 2)
+         table = twobppswaptable;
+      else if (row_info->bit_depth == 4)
+         table = fourbppswaptable;
+      else
+         return;
+
+      for (rp = row; rp < end; rp++)
+         *rp = table[*rp];
+   }
+}
+#endif /* PNG_READ_PACKSWAP_SUPPORTED or PNG_WRITE_PACKSWAP_SUPPORTED */
+
+#if defined(PNG_WRITE_FILLER_SUPPORTED) || \
+    defined(PNG_READ_STRIP_ALPHA_SUPPORTED)
+/* remove filler or alpha byte(s) */
+void /* PRIVATE */
+png_do_strip_filler(png_row_infop row_info, png_bytep row, png_uint_32 flags)
+{
+   png_debug(1, "in png_do_strip_filler\n");
+#if defined(PNG_USELESS_TESTS_SUPPORTED)
+   if (row != NULL && row_info != NULL)
+#endif
+   {
+/*
+      if (row_info->color_type == PNG_COLOR_TYPE_RGB ||
+          row_info->color_type == PNG_COLOR_TYPE_RGB_ALPHA)
+*/
+      png_bytep sp=row;
+      png_bytep dp=row;
+      png_uint_32 row_width=row_info->width;
+      png_uint_32 i;
+
+      if (row_info->channels == 4)
+      {
+         if (row_info->bit_depth == 8)
+         {
+            /* This converts from RGBX or RGBA to RGB */
+            if (flags & PNG_FLAG_FILLER_AFTER)
+            {
+               dp+=3; sp+=4;
+               for (i = 1; i < row_width; i++)
+               {
+                  *dp++ = *sp++;
+                  *dp++ = *sp++;
+                  *dp++ = *sp++;
+                  sp++;
+               }
+            }
+            /* This converts from XRGB or ARGB to RGB */
+            else
+            {
+               for (i = 0; i < row_width; i++)
+               {
+                  sp++;
+                  *dp++ = *sp++;
+                  *dp++ = *sp++;
+                  *dp++ = *sp++;
+               }
+            }
+            row_info->pixel_depth = 24;
+            row_info->rowbytes = row_width * 3;
+         }
+         else /* if (row_info->bit_depth == 16) */
+         {
+            if (flags & PNG_FLAG_FILLER_AFTER)
+            {
+               /* This converts from RRGGBBXX or RRGGBBAA to RRGGBB */
+               sp += 8; dp += 6;
+               for (i = 1; i < row_width; i++)
+               {
+                  /* This could be (although png_memcpy is probably slower):
+                  png_memcpy(dp, sp, 6);
+                  sp += 8;
+                  dp += 6;
+                  */
+
+                  *dp++ = *sp++;
+                  *dp++ = *sp++;
+                  *dp++ = *sp++;
+                  *dp++ = *sp++;
+                  *dp++ = *sp++;
+                  *dp++ = *sp++;
+                  sp += 2;
+               }
+            }
+            else
+            {
+               /* This converts from XXRRGGBB or AARRGGBB to RRGGBB */
+               for (i = 0; i < row_width; i++)
+               {
+                  /* This could be (although png_memcpy is probably slower):
+                  png_memcpy(dp, sp, 6);
+                  sp += 8;
+                  dp += 6;
+                  */
+
+                  sp+=2;
+                  *dp++ = *sp++;
+                  *dp++ = *sp++;
+                  *dp++ = *sp++;
+                  *dp++ = *sp++;
+                  *dp++ = *sp++;
+                  *dp++ = *sp++;
+               }
+            }
+            row_info->pixel_depth = 48;
+            row_info->rowbytes = row_width * 6;
+         }
+         row_info->channels = 3;
+         row_info->color_type &= ~PNG_COLOR_MASK_ALPHA;
+      }
+/*
+      else if (row_info->color_type == PNG_COLOR_TYPE_GRAY ||
+               row_info->color_type == PNG_COLOR_TYPE_GRAY_ALPHA)
+*/
+      else if (row_info->channels == 2)
+      {
+         if (row_info->bit_depth == 8)
+         {
+            /* This converts from GX or GA to G */
+            if (flags & PNG_FLAG_FILLER_AFTER)
+            {
+               for (i = 0; i < row_width; i++)
+               {
+                  *dp++ = *sp++;
+                  sp++;
+               }
+            }
+            /* This converts from XG or AG to G */
+            else
+            {
+               for (i = 0; i < row_width; i++)
+               {
+                  sp++;
+                  *dp++ = *sp++;
+               }
+            }
+            row_info->pixel_depth = 8;
+            row_info->rowbytes = row_width;
+         }
+         else /* if (row_info->bit_depth == 16) */
+         {
+            if (flags & PNG_FLAG_FILLER_AFTER)
+            {
+               /* This converts from GGXX or GGAA to GG */
+               sp += 4; dp += 2;
+               for (i = 1; i < row_width; i++)
+               {
+                  *dp++ = *sp++;
+                  *dp++ = *sp++;
+                  sp += 2;
+               }
+            }
+            else
+            {
+               /* This converts from XXGG or AAGG to GG */
+               for (i = 0; i < row_width; i++)
+               {
+                  sp += 2;
+                  *dp++ = *sp++;
+                  *dp++ = *sp++;
+               }
+            }
+            row_info->pixel_depth = 16;
+            row_info->rowbytes = row_width * 2;
+         }
+         row_info->channels = 1;
+         row_info->color_type &= ~PNG_COLOR_MASK_ALPHA;
+      }
+   }
+}
+#endif
+
+#if defined(PNG_READ_BGR_SUPPORTED) || defined(PNG_WRITE_BGR_SUPPORTED)
+/* swaps red and blue bytes within a pixel */
+void /* PRIVATE */
+png_do_bgr(png_row_infop row_info, png_bytep row)
+{
+   png_debug(1, "in png_do_bgr\n");
+   if (
+#if defined(PNG_USELESS_TESTS_SUPPORTED)
+       row != NULL && row_info != NULL &&
+#endif
+       (row_info->color_type & PNG_COLOR_MASK_COLOR))
+   {
+      png_uint_32 row_width = row_info->width;
+      if (row_info->bit_depth == 8)
+      {
+         if (row_info->color_type == PNG_COLOR_TYPE_RGB)
+         {
+            png_bytep rp;
+            png_uint_32 i;
+
+            for (i = 0, rp = row; i < row_width; i++, rp += 3)
+            {
+               png_byte save = *rp;
+               *rp = *(rp + 2);
+               *(rp + 2) = save;
+            }
+         }
+         else if (row_info->color_type == PNG_COLOR_TYPE_RGB_ALPHA)
+         {
+            png_bytep rp;
+            png_uint_32 i;
+
+            for (i = 0, rp = row; i < row_width; i++, rp += 4)
+            {
+               png_byte save = *rp;
+               *rp = *(rp + 2);
+               *(rp + 2) = save;
+            }
+         }
+      }
+      else if (row_info->bit_depth == 16)
+      {
+         if (row_info->color_type == PNG_COLOR_TYPE_RGB)
+         {
+            png_bytep rp;
+            png_uint_32 i;
+
+            for (i = 0, rp = row; i < row_width; i++, rp += 6)
+            {
+               png_byte save = *rp;
+               *rp = *(rp + 4);
+               *(rp + 4) = save;
+               save = *(rp + 1);
+               *(rp + 1) = *(rp + 5);
+               *(rp + 5) = save;
+            }
+         }
+         else if (row_info->color_type == PNG_COLOR_TYPE_RGB_ALPHA)
+         {
+            png_bytep rp;
+            png_uint_32 i;
+
+            for (i = 0, rp = row; i < row_width; i++, rp += 8)
+            {
+               png_byte save = *rp;
+               *rp = *(rp + 4);
+               *(rp + 4) = save;
+               save = *(rp + 1);
+               *(rp + 1) = *(rp + 5);
+               *(rp + 5) = save;
+            }
+         }
+      }
+   }
+}
+#endif /* PNG_READ_BGR_SUPPORTED or PNG_WRITE_BGR_SUPPORTED */
+
+#if defined(PNG_READ_USER_TRANSFORM_SUPPORTED) || \
+    defined(PNG_WRITE_USER_TRANSFORM_SUPPORTED) || \
+    defined(PNG_LEGACY_SUPPORTED)
+void PNGAPI
+png_set_user_transform_info(png_structp png_ptr, png_voidp
+   user_transform_ptr, int user_transform_depth, int user_transform_channels)
+{
+   png_debug(1, "in png_set_user_transform_info\n");
+#if defined(PNG_USER_TRANSFORM_PTR_SUPPORTED)
+   png_ptr->user_transform_ptr = user_transform_ptr;
+   png_ptr->user_transform_depth = (png_byte)user_transform_depth;
+   png_ptr->user_transform_channels = (png_byte)user_transform_channels;
+#else
+   if(user_transform_ptr || user_transform_depth || user_transform_channels)
+      png_warning(png_ptr,
+        "This version of libpng does not support user transform info");
+#endif
+}
+#endif
+
+/* This function returns a pointer to the user_transform_ptr associated with
+ * the user transform functions.  The application should free any memory
+ * associated with this pointer before png_write_destroy and png_read_destroy
+ * are called.
+ */
+png_voidp PNGAPI
+png_get_user_transform_ptr(png_structp png_ptr)
+{
+#if defined(PNG_USER_TRANSFORM_PTR_SUPPORTED)
+   return ((png_voidp)png_ptr->user_transform_ptr);
+#else
+   if(png_ptr)
+     return (NULL);
+   return (NULL);
+#endif
+}
diff --git a/collects/plot/src/all/pngvcrd.c b/collects/plot/src/all/pngvcrd.c
new file mode 100644
index 0000000000..4f513eb4d9
--- /dev/null
+++ b/collects/plot/src/all/pngvcrd.c
@@ -0,0 +1,3845 @@
+/* pngvcrd.c - mixed C/assembler version of utilities to read a PNG file
+ *
+ * For Intel x86 CPU and Microsoft Visual C++ compiler
+ *
+ * libpng version 1.2.5 - October 3, 2002
+ * For conditions of distribution and use, see copyright notice in png.h
+ * Copyright (c) 1998-2002 Glenn Randers-Pehrson
+ * Copyright (c) 1998, Intel Corporation
+ *
+ * Contributed by Nirav Chhatrapati, Intel Corporation, 1998
+ * Interface to libpng contributed by Gilles Vollant, 1999
+ *
+ *
+ * In png_do_read_interlace() in libpng versions 1.0.3a through 1.0.4d,
+ * a sign error in the post-MMX cleanup code for each pixel_depth resulted
+ * in bad pixels at the beginning of some rows of some images, and also
+ * (due to out-of-range memory reads and writes) caused heap corruption
+ * when compiled with MSVC 6.0.  The error was fixed in version 1.0.4e.
+ *
+ * [png_read_filter_row_mmx_avg() bpp == 2 bugfix, GRR 20000916]
+ *
+ * [runtime MMX configuration, GRR 20010102]
+ *
+ */
+
+#define PNG_INTERNAL
+#include "png.h"
+
+#if defined(PNG_ASSEMBLER_CODE_SUPPORTED) && defined(PNG_USE_PNGVCRD)
+
+static int mmx_supported=2;
+
+
+int PNGAPI
+png_mmx_support(void)
+{
+  int mmx_supported_local = 0;
+  _asm {
+    push ebx          //CPUID will trash these
+    push ecx
+    push edx
+
+    pushfd            //Save Eflag to stack
+    pop eax           //Get Eflag from stack into eax
+    mov ecx, eax      //Make another copy of Eflag in ecx
+    xor eax, 0x200000 //Toggle ID bit in Eflag [i.e. bit(21)]
+    push eax          //Save modified Eflag back to stack
+
+    popfd             //Restored modified value back to Eflag reg
+    pushfd            //Save Eflag to stack
+    pop eax           //Get Eflag from stack
+    push ecx          // save original Eflag to stack
+    popfd             // restore original Eflag
+    xor eax, ecx      //Compare the new Eflag with the original Eflag
+    jz NOT_SUPPORTED  //If the same, CPUID instruction is not supported,
+                      //skip following instructions and jump to
+                      //NOT_SUPPORTED label
+
+    xor eax, eax      //Set eax to zero
+
+    _asm _emit 0x0f   //CPUID instruction  (two bytes opcode)
+    _asm _emit 0xa2
+
+    cmp eax, 1        //make sure eax return non-zero value
+    jl NOT_SUPPORTED  //If eax is zero, mmx not supported
+
+    xor eax, eax      //set eax to zero
+    inc eax           //Now increment eax to 1.  This instruction is
+                      //faster than the instruction "mov eax, 1"
+
+    _asm _emit 0x0f   //CPUID instruction
+    _asm _emit 0xa2
+
+    and edx, 0x00800000  //mask out all bits but mmx bit(24)
+    cmp edx, 0        // 0 = mmx not supported
+    jz  NOT_SUPPORTED // non-zero = Yes, mmx IS supported
+
+    mov  mmx_supported_local, 1  //set return value to 1
+
+NOT_SUPPORTED:
+    mov  eax, mmx_supported_local  //move return value to eax
+    pop edx          //CPUID trashed these
+    pop ecx
+    pop ebx
+  }
+
+  //mmx_supported_local=0; // test code for force don't support MMX
+  //printf("MMX : %u (1=MMX supported)\n",mmx_supported_local);
+
+  mmx_supported = mmx_supported_local;
+  return mmx_supported_local;
+}
+
+/* Combines the row recently read in with the previous row.
+   This routine takes care of alpha and transparency if requested.
+   This routine also handles the two methods of progressive display
+   of interlaced images, depending on the mask value.
+   The mask value describes which pixels are to be combined with
+   the row.  The pattern always repeats every 8 pixels, so just 8
+   bits are needed.  A one indicates the pixel is to be combined; a
+   zero indicates the pixel is to be skipped.  This is in addition
+   to any alpha or transparency value associated with the pixel.  If
+   you want all pixels to be combined, pass 0xff (255) in mask.  */
+
+/* Use this routine for x86 platform - uses faster MMX routine if machine
+   supports MMX */
+
+void /* PRIVATE */
+png_combine_row(png_structp png_ptr, png_bytep row, int mask)
+{
+#ifdef PNG_USE_LOCAL_ARRAYS
+   const int png_pass_inc[7] = {8, 8, 4, 4, 2, 2, 1};
+#endif
+
+   png_debug(1,"in png_combine_row_asm\n");
+
+   if (mmx_supported == 2) {
+       /* this should have happened in png_init_mmx_flags() already */
+       png_warning(png_ptr, "asm_flags may not have been initialized");
+       png_mmx_support();
+   }
+
+   if (mask == 0xff)
+   {
+      png_memcpy(row, png_ptr->row_buf + 1,
+       (png_size_t)((png_ptr->width * png_ptr->row_info.pixel_depth + 7) >> 3));
+   }
+   /* GRR:  add "else if (mask == 0)" case?
+    *       or does png_combine_row() not even get called in that case? */
+   else
+   {
+      switch (png_ptr->row_info.pixel_depth)
+      {
+         case 1:
+         {
+            png_bytep sp;
+            png_bytep dp;
+            int s_inc, s_start, s_end;
+            int m;
+            int shift;
+            png_uint_32 i;
+
+            sp = png_ptr->row_buf + 1;
+            dp = row;
+            m = 0x80;
+#if defined(PNG_READ_PACKSWAP_SUPPORTED)
+            if (png_ptr->transformations & PNG_PACKSWAP)
+            {
+                s_start = 0;
+                s_end = 7;
+                s_inc = 1;
+            }
+            else
+#endif
+            {
+                s_start = 7;
+                s_end = 0;
+                s_inc = -1;
+            }
+
+            shift = s_start;
+
+            for (i = 0; i < png_ptr->width; i++)
+            {
+               if (m & mask)
+               {
+                  int value;
+
+                  value = (*sp >> shift) & 0x1;
+                  *dp &= (png_byte)((0x7f7f >> (7 - shift)) & 0xff);
+                  *dp |= (png_byte)(value << shift);
+               }
+
+               if (shift == s_end)
+               {
+                  shift = s_start;
+                  sp++;
+                  dp++;
+               }
+               else
+                  shift += s_inc;
+
+               if (m == 1)
+                  m = 0x80;
+               else
+                  m >>= 1;
+            }
+            break;
+         }
+
+         case 2:
+         {
+            png_bytep sp;
+            png_bytep dp;
+            int s_start, s_end, s_inc;
+            int m;
+            int shift;
+            png_uint_32 i;
+            int value;
+
+            sp = png_ptr->row_buf + 1;
+            dp = row;
+            m = 0x80;
+#if defined(PNG_READ_PACKSWAP_SUPPORTED)
+            if (png_ptr->transformations & PNG_PACKSWAP)
+            {
+               s_start = 0;
+               s_end = 6;
+               s_inc = 2;
+            }
+            else
+#endif
+            {
+               s_start = 6;
+               s_end = 0;
+               s_inc = -2;
+            }
+
+            shift = s_start;
+
+            for (i = 0; i < png_ptr->width; i++)
+            {
+               if (m & mask)
+               {
+                  value = (*sp >> shift) & 0x3;
+                  *dp &= (png_byte)((0x3f3f >> (6 - shift)) & 0xff);
+                  *dp |= (png_byte)(value << shift);
+               }
+
+               if (shift == s_end)
+               {
+                  shift = s_start;
+                  sp++;
+                  dp++;
+               }
+               else
+                  shift += s_inc;
+               if (m == 1)
+                  m = 0x80;
+               else
+                  m >>= 1;
+            }
+            break;
+         }
+
+         case 4:
+         {
+            png_bytep sp;
+            png_bytep dp;
+            int s_start, s_end, s_inc;
+            int m;
+            int shift;
+            png_uint_32 i;
+            int value;
+
+            sp = png_ptr->row_buf + 1;
+            dp = row;
+            m = 0x80;
+#if defined(PNG_READ_PACKSWAP_SUPPORTED)
+            if (png_ptr->transformations & PNG_PACKSWAP)
+            {
+               s_start = 0;
+               s_end = 4;
+               s_inc = 4;
+            }
+            else
+#endif
+            {
+               s_start = 4;
+               s_end = 0;
+               s_inc = -4;
+            }
+            shift = s_start;
+
+            for (i = 0; i < png_ptr->width; i++)
+            {
+               if (m & mask)
+               {
+                  value = (*sp >> shift) & 0xf;
+                  *dp &= (png_byte)((0xf0f >> (4 - shift)) & 0xff);
+                  *dp |= (png_byte)(value << shift);
+               }
+
+               if (shift == s_end)
+               {
+                  shift = s_start;
+                  sp++;
+                  dp++;
+               }
+               else
+                  shift += s_inc;
+               if (m == 1)
+                  m = 0x80;
+               else
+                  m >>= 1;
+            }
+            break;
+         }
+
+         case 8:
+         {
+            png_bytep srcptr;
+            png_bytep dstptr;
+            png_uint_32 len;
+            int m;
+            int diff, unmask;
+
+            __int64 mask0=0x0102040810204080;
+
+            if ((png_ptr->asm_flags & PNG_ASM_FLAG_MMX_READ_COMBINE_ROW)
+                /* && mmx_supported */ )
+            {
+               srcptr = png_ptr->row_buf + 1;
+               dstptr = row;
+               m = 0x80;
+               unmask = ~mask;
+               len  = png_ptr->width &~7;  //reduce to multiple of 8
+               diff = png_ptr->width & 7;  //amount lost
+
+               _asm
+               {
+                  movd       mm7, unmask   //load bit pattern
+                  psubb      mm6,mm6       //zero mm6
+                  punpcklbw  mm7,mm7
+                  punpcklwd  mm7,mm7
+                  punpckldq  mm7,mm7       //fill register with 8 masks
+
+                  movq       mm0,mask0
+
+                  pand       mm0,mm7       //nonzero if keep byte
+                  pcmpeqb    mm0,mm6       //zeros->1s, v versa
+
+                  mov        ecx,len       //load length of line (pixels)
+                  mov        esi,srcptr    //load source
+                  mov        ebx,dstptr    //load dest
+                  cmp        ecx,0         //lcr
+                  je         mainloop8end
+
+mainloop8:
+                  movq       mm4,[esi]
+                  pand       mm4,mm0
+                  movq       mm6,mm0
+                  pandn      mm6,[ebx]
+                  por        mm4,mm6
+                  movq       [ebx],mm4
+
+                  add        esi,8         //inc by 8 bytes processed
+                  add        ebx,8
+                  sub        ecx,8         //dec by 8 pixels processed
+
+                  ja         mainloop8
+mainloop8end:
+
+                  mov        ecx,diff
+                  cmp        ecx,0
+                  jz         end8
+
+                  mov        edx,mask
+                  sal        edx,24        //make low byte the high byte
+
+secondloop8:
+                  sal        edx,1         //move high bit to CF
+                  jnc        skip8         //if CF = 0
+                  mov        al,[esi]
+                  mov        [ebx],al
+skip8:
+                  inc        esi
+                  inc        ebx
+
+                  dec        ecx
+                  jnz        secondloop8
+end8:
+                  emms
+               }
+            }
+            else /* mmx not supported - use modified C routine */
+            {
+               register unsigned int incr1, initial_val, final_val;
+               png_size_t pixel_bytes;
+               png_uint_32 i;
+               register int disp = png_pass_inc[png_ptr->pass];
+               int offset_table[7] = {0, 4, 0, 2, 0, 1, 0};
+
+               pixel_bytes = (png_ptr->row_info.pixel_depth >> 3);
+               srcptr = png_ptr->row_buf + 1 + offset_table[png_ptr->pass]*
+                  pixel_bytes;
+               dstptr = row + offset_table[png_ptr->pass]*pixel_bytes;
+               initial_val = offset_table[png_ptr->pass]*pixel_bytes;
+               final_val = png_ptr->width*pixel_bytes;
+               incr1 = (disp)*pixel_bytes;
+               for (i = initial_val; i < final_val; i += incr1)
+               {
+                  png_memcpy(dstptr, srcptr, pixel_bytes);
+                  srcptr += incr1;
+                  dstptr += incr1;
+               }
+            } /* end of else */
+
+            break;
+         }       // end 8 bpp
+
+         case 16:
+         {
+            png_bytep srcptr;
+            png_bytep dstptr;
+            png_uint_32 len;
+            int unmask, diff;
+            __int64 mask1=0x0101020204040808,
+                    mask0=0x1010202040408080;
+
+            if ((png_ptr->asm_flags & PNG_ASM_FLAG_MMX_READ_COMBINE_ROW)
+                /* && mmx_supported */ )
+            {
+               srcptr = png_ptr->row_buf + 1;
+               dstptr = row;
+
+               unmask = ~mask;
+               len     = (png_ptr->width)&~7;
+               diff = (png_ptr->width)&7;
+               _asm
+               {
+                  movd       mm7, unmask       //load bit pattern
+                  psubb      mm6,mm6           //zero mm6
+                  punpcklbw  mm7,mm7
+                  punpcklwd  mm7,mm7
+                  punpckldq  mm7,mm7           //fill register with 8 masks
+
+                  movq       mm0,mask0
+                  movq       mm1,mask1
+
+                  pand       mm0,mm7
+                  pand       mm1,mm7
+
+                  pcmpeqb    mm0,mm6
+                  pcmpeqb    mm1,mm6
+
+                  mov        ecx,len           //load length of line
+                  mov        esi,srcptr        //load source
+                  mov        ebx,dstptr        //load dest
+                  cmp        ecx,0             //lcr
+                  jz         mainloop16end
+
+mainloop16:
+                  movq       mm4,[esi]
+                  pand       mm4,mm0
+                  movq       mm6,mm0
+                  movq       mm7,[ebx]
+                  pandn      mm6,mm7
+                  por        mm4,mm6
+                  movq       [ebx],mm4
+
+                  movq       mm5,[esi+8]
+                  pand       mm5,mm1
+                  movq       mm7,mm1
+                  movq       mm6,[ebx+8]
+                  pandn      mm7,mm6
+                  por        mm5,mm7
+                  movq       [ebx+8],mm5
+
+                  add        esi,16            //inc by 16 bytes processed
+                  add        ebx,16
+                  sub        ecx,8             //dec by 8 pixels processed
+
+                  ja         mainloop16
+
+mainloop16end:
+                  mov        ecx,diff
+                  cmp        ecx,0
+                  jz         end16
+
+                  mov        edx,mask
+                  sal        edx,24            //make low byte the high byte
+secondloop16:
+                  sal        edx,1             //move high bit to CF
+                  jnc        skip16            //if CF = 0
+                  mov        ax,[esi]
+                  mov        [ebx],ax
+skip16:
+                  add        esi,2
+                  add        ebx,2
+
+                  dec        ecx
+                  jnz        secondloop16
+end16:
+                  emms
+               }
+            }
+            else /* mmx not supported - use modified C routine */
+            {
+               register unsigned int incr1, initial_val, final_val;
+               png_size_t pixel_bytes;
+               png_uint_32 i;
+               register int disp = png_pass_inc[png_ptr->pass];
+               int offset_table[7] = {0, 4, 0, 2, 0, 1, 0};
+
+               pixel_bytes = (png_ptr->row_info.pixel_depth >> 3);
+               srcptr = png_ptr->row_buf + 1 + offset_table[png_ptr->pass]*
+                  pixel_bytes;
+               dstptr = row + offset_table[png_ptr->pass]*pixel_bytes;
+               initial_val = offset_table[png_ptr->pass]*pixel_bytes;
+               final_val = png_ptr->width*pixel_bytes;
+               incr1 = (disp)*pixel_bytes;
+               for (i = initial_val; i < final_val; i += incr1)
+               {
+                  png_memcpy(dstptr, srcptr, pixel_bytes);
+                  srcptr += incr1;
+                  dstptr += incr1;
+               }
+            } /* end of else */
+
+            break;
+         }       // end 16 bpp
+
+         case 24:
+         {
+            png_bytep srcptr;
+            png_bytep dstptr;
+            png_uint_32 len;
+            int unmask, diff;
+
+            __int64 mask2=0x0101010202020404,  //24bpp
+                    mask1=0x0408080810101020,
+                    mask0=0x2020404040808080;
+
+            srcptr = png_ptr->row_buf + 1;
+            dstptr = row;
+
+            unmask = ~mask;
+            len     = (png_ptr->width)&~7;
+            diff = (png_ptr->width)&7;
+
+            if ((png_ptr->asm_flags & PNG_ASM_FLAG_MMX_READ_COMBINE_ROW)
+                /* && mmx_supported */ )
+            {
+               _asm
+               {
+                  movd       mm7, unmask       //load bit pattern
+                  psubb      mm6,mm6           //zero mm6
+                  punpcklbw  mm7,mm7
+                  punpcklwd  mm7,mm7
+                  punpckldq  mm7,mm7           //fill register with 8 masks
+
+                  movq       mm0,mask0
+                  movq       mm1,mask1
+                  movq       mm2,mask2
+
+                  pand       mm0,mm7
+                  pand       mm1,mm7
+                  pand       mm2,mm7
+
+                  pcmpeqb    mm0,mm6
+                  pcmpeqb    mm1,mm6
+                  pcmpeqb    mm2,mm6
+
+                  mov        ecx,len           //load length of line
+                  mov        esi,srcptr        //load source
+                  mov        ebx,dstptr        //load dest
+                  cmp        ecx,0
+                  jz         mainloop24end
+
+mainloop24:
+                  movq       mm4,[esi]
+                  pand       mm4,mm0
+                  movq       mm6,mm0
+                  movq       mm7,[ebx]
+                  pandn      mm6,mm7
+                  por        mm4,mm6
+                  movq       [ebx],mm4
+
+
+                  movq       mm5,[esi+8]
+                  pand       mm5,mm1
+                  movq       mm7,mm1
+                  movq       mm6,[ebx+8]
+                  pandn      mm7,mm6
+                  por        mm5,mm7
+                  movq       [ebx+8],mm5
+
+                  movq       mm6,[esi+16]
+                  pand       mm6,mm2
+                  movq       mm4,mm2
+                  movq       mm7,[ebx+16]
+                  pandn      mm4,mm7
+                  por        mm6,mm4
+                  movq       [ebx+16],mm6
+
+                  add        esi,24            //inc by 24 bytes processed
+                  add        ebx,24
+                  sub        ecx,8             //dec by 8 pixels processed
+
+                  ja         mainloop24
+
+mainloop24end:
+                  mov        ecx,diff
+                  cmp        ecx,0
+                  jz         end24
+
+                  mov        edx,mask
+                  sal        edx,24            //make low byte the high byte
+secondloop24:
+                  sal        edx,1             //move high bit to CF
+                  jnc        skip24            //if CF = 0
+                  mov        ax,[esi]
+                  mov        [ebx],ax
+                  xor        eax,eax
+                  mov        al,[esi+2]
+                  mov        [ebx+2],al
+skip24:
+                  add        esi,3
+                  add        ebx,3
+
+                  dec        ecx
+                  jnz        secondloop24
+
+end24:
+                  emms
+               }
+            }
+            else /* mmx not supported - use modified C routine */
+            {
+               register unsigned int incr1, initial_val, final_val;
+               png_size_t pixel_bytes;
+               png_uint_32 i;
+               register int disp = png_pass_inc[png_ptr->pass];
+               int offset_table[7] = {0, 4, 0, 2, 0, 1, 0};
+
+               pixel_bytes = (png_ptr->row_info.pixel_depth >> 3);
+               srcptr = png_ptr->row_buf + 1 + offset_table[png_ptr->pass]*
+                  pixel_bytes;
+               dstptr = row + offset_table[png_ptr->pass]*pixel_bytes;
+               initial_val = offset_table[png_ptr->pass]*pixel_bytes;
+               final_val = png_ptr->width*pixel_bytes;
+               incr1 = (disp)*pixel_bytes;
+               for (i = initial_val; i < final_val; i += incr1)
+               {
+                  png_memcpy(dstptr, srcptr, pixel_bytes);
+                  srcptr += incr1;
+                  dstptr += incr1;
+               }
+            } /* end of else */
+
+            break;
+         }       // end 24 bpp
+
+         case 32:
+         {
+            png_bytep srcptr;
+            png_bytep dstptr;
+            png_uint_32 len;
+            int unmask, diff;
+
+            __int64 mask3=0x0101010102020202,  //32bpp
+                    mask2=0x0404040408080808,
+                    mask1=0x1010101020202020,
+                    mask0=0x4040404080808080;
+
+            srcptr = png_ptr->row_buf + 1;
+            dstptr = row;
+
+            unmask = ~mask;
+            len     = (png_ptr->width)&~7;
+            diff = (png_ptr->width)&7;
+
+            if ((png_ptr->asm_flags & PNG_ASM_FLAG_MMX_READ_COMBINE_ROW)
+                /* && mmx_supported */ )
+            {
+               _asm
+               {
+                  movd       mm7, unmask       //load bit pattern
+                  psubb      mm6,mm6           //zero mm6
+                  punpcklbw  mm7,mm7
+                  punpcklwd  mm7,mm7
+                  punpckldq  mm7,mm7           //fill register with 8 masks
+
+                  movq       mm0,mask0
+                  movq       mm1,mask1
+                  movq       mm2,mask2
+                  movq       mm3,mask3
+
+                  pand       mm0,mm7
+                  pand       mm1,mm7
+                  pand       mm2,mm7
+                  pand       mm3,mm7
+
+                  pcmpeqb    mm0,mm6
+                  pcmpeqb    mm1,mm6
+                  pcmpeqb    mm2,mm6
+                  pcmpeqb    mm3,mm6
+
+                  mov        ecx,len           //load length of line
+                  mov        esi,srcptr        //load source
+                  mov        ebx,dstptr        //load dest
+
+                  cmp        ecx,0             //lcr
+                  jz         mainloop32end
+
+mainloop32:
+                  movq       mm4,[esi]
+                  pand       mm4,mm0
+                  movq       mm6,mm0
+                  movq       mm7,[ebx]
+                  pandn      mm6,mm7
+                  por        mm4,mm6
+                  movq       [ebx],mm4
+
+                  movq       mm5,[esi+8]
+                  pand       mm5,mm1
+                  movq       mm7,mm1
+                  movq       mm6,[ebx+8]
+                  pandn      mm7,mm6
+                  por        mm5,mm7
+                  movq       [ebx+8],mm5
+
+                  movq       mm6,[esi+16]
+                  pand       mm6,mm2
+                  movq       mm4,mm2
+                  movq       mm7,[ebx+16]
+                  pandn      mm4,mm7
+                  por        mm6,mm4
+                  movq       [ebx+16],mm6
+
+                  movq       mm7,[esi+24]
+                  pand       mm7,mm3
+                  movq       mm5,mm3
+                  movq       mm4,[ebx+24]
+                  pandn      mm5,mm4
+                  por        mm7,mm5
+                  movq       [ebx+24],mm7
+
+                  add        esi,32            //inc by 32 bytes processed
+                  add        ebx,32
+                  sub        ecx,8             //dec by 8 pixels processed
+
+                  ja         mainloop32
+
+mainloop32end:
+                  mov        ecx,diff
+                  cmp        ecx,0
+                  jz         end32
+
+                  mov        edx,mask
+                  sal        edx,24            //make low byte the high byte
+secondloop32:
+                  sal        edx,1             //move high bit to CF
+                  jnc        skip32            //if CF = 0
+                  mov        eax,[esi]
+                  mov        [ebx],eax
+skip32:
+                  add        esi,4
+                  add        ebx,4
+
+                  dec        ecx
+                  jnz        secondloop32
+
+end32:
+                  emms
+               }
+            }
+            else /* mmx _not supported - Use modified C routine */
+            {
+               register unsigned int incr1, initial_val, final_val;
+               png_size_t pixel_bytes;
+               png_uint_32 i;
+               register int disp = png_pass_inc[png_ptr->pass];
+               int offset_table[7] = {0, 4, 0, 2, 0, 1, 0};
+
+               pixel_bytes = (png_ptr->row_info.pixel_depth >> 3);
+               srcptr = png_ptr->row_buf + 1 + offset_table[png_ptr->pass]*
+                  pixel_bytes;
+               dstptr = row + offset_table[png_ptr->pass]*pixel_bytes;
+               initial_val = offset_table[png_ptr->pass]*pixel_bytes;
+               final_val = png_ptr->width*pixel_bytes;
+               incr1 = (disp)*pixel_bytes;
+               for (i = initial_val; i < final_val; i += incr1)
+               {
+                  png_memcpy(dstptr, srcptr, pixel_bytes);
+                  srcptr += incr1;
+                  dstptr += incr1;
+               }
+            } /* end of else */
+
+            break;
+         }       // end 32 bpp
+
+         case 48:
+         {
+            png_bytep srcptr;
+            png_bytep dstptr;
+            png_uint_32 len;
+            int unmask, diff;
+
+            __int64 mask5=0x0101010101010202,
+                    mask4=0x0202020204040404,
+                    mask3=0x0404080808080808,
+                    mask2=0x1010101010102020,
+                    mask1=0x2020202040404040,
+                    mask0=0x4040808080808080;
+
+            if ((png_ptr->asm_flags & PNG_ASM_FLAG_MMX_READ_COMBINE_ROW)
+                /* && mmx_supported */ )
+            {
+               srcptr = png_ptr->row_buf + 1;
+               dstptr = row;
+
+               unmask = ~mask;
+               len     = (png_ptr->width)&~7;
+               diff = (png_ptr->width)&7;
+               _asm
+               {
+                  movd       mm7, unmask       //load bit pattern
+                  psubb      mm6,mm6           //zero mm6
+                  punpcklbw  mm7,mm7
+                  punpcklwd  mm7,mm7
+                  punpckldq  mm7,mm7           //fill register with 8 masks
+
+                  movq       mm0,mask0
+                  movq       mm1,mask1
+                  movq       mm2,mask2
+                  movq       mm3,mask3
+                  movq       mm4,mask4
+                  movq       mm5,mask5
+
+                  pand       mm0,mm7
+                  pand       mm1,mm7
+                  pand       mm2,mm7
+                  pand       mm3,mm7
+                  pand       mm4,mm7
+                  pand       mm5,mm7
+
+                  pcmpeqb    mm0,mm6
+                  pcmpeqb    mm1,mm6
+                  pcmpeqb    mm2,mm6
+                  pcmpeqb    mm3,mm6
+                  pcmpeqb    mm4,mm6
+                  pcmpeqb    mm5,mm6
+
+                  mov        ecx,len           //load length of line
+                  mov        esi,srcptr        //load source
+                  mov        ebx,dstptr        //load dest
+
+                  cmp        ecx,0
+                  jz         mainloop48end
+
+mainloop48:
+                  movq       mm7,[esi]
+                  pand       mm7,mm0
+                  movq       mm6,mm0
+                  pandn      mm6,[ebx]
+                  por        mm7,mm6
+                  movq       [ebx],mm7
+
+                  movq       mm6,[esi+8]
+                  pand       mm6,mm1
+                  movq       mm7,mm1
+                  pandn      mm7,[ebx+8]
+                  por        mm6,mm7
+                  movq       [ebx+8],mm6
+
+                  movq       mm6,[esi+16]
+                  pand       mm6,mm2
+                  movq       mm7,mm2
+                  pandn      mm7,[ebx+16]
+                  por        mm6,mm7
+                  movq       [ebx+16],mm6
+
+                  movq       mm7,[esi+24]
+                  pand       mm7,mm3
+                  movq       mm6,mm3
+                  pandn      mm6,[ebx+24]
+                  por        mm7,mm6
+                  movq       [ebx+24],mm7
+
+                  movq       mm6,[esi+32]
+                  pand       mm6,mm4
+                  movq       mm7,mm4
+                  pandn      mm7,[ebx+32]
+                  por        mm6,mm7
+                  movq       [ebx+32],mm6
+
+                  movq       mm7,[esi+40]
+                  pand       mm7,mm5
+                  movq       mm6,mm5
+                  pandn      mm6,[ebx+40]
+                  por        mm7,mm6
+                  movq       [ebx+40],mm7
+
+                  add        esi,48            //inc by 32 bytes processed
+                  add        ebx,48
+                  sub        ecx,8             //dec by 8 pixels processed
+
+                  ja         mainloop48
+mainloop48end:
+
+                  mov        ecx,diff
+                  cmp        ecx,0
+                  jz         end48
+
+                  mov        edx,mask
+                  sal        edx,24            //make low byte the high byte
+
+secondloop48:
+                  sal        edx,1             //move high bit to CF
+                  jnc        skip48            //if CF = 0
+                  mov        eax,[esi]
+                  mov        [ebx],eax
+skip48:
+                  add        esi,4
+                  add        ebx,4
+
+                  dec        ecx
+                  jnz        secondloop48
+
+end48:
+                  emms
+               }
+            }
+            else /* mmx _not supported - Use modified C routine */
+            {
+               register unsigned int incr1, initial_val, final_val;
+               png_size_t pixel_bytes;
+               png_uint_32 i;
+               register int disp = png_pass_inc[png_ptr->pass];
+               int offset_table[7] = {0, 4, 0, 2, 0, 1, 0};
+
+               pixel_bytes = (png_ptr->row_info.pixel_depth >> 3);
+               srcptr = png_ptr->row_buf + 1 + offset_table[png_ptr->pass]*
+                  pixel_bytes;
+               dstptr = row + offset_table[png_ptr->pass]*pixel_bytes;
+               initial_val = offset_table[png_ptr->pass]*pixel_bytes;
+               final_val = png_ptr->width*pixel_bytes;
+               incr1 = (disp)*pixel_bytes;
+               for (i = initial_val; i < final_val; i += incr1)
+               {
+                  png_memcpy(dstptr, srcptr, pixel_bytes);
+                  srcptr += incr1;
+                  dstptr += incr1;
+               }
+            } /* end of else */
+
+            break;
+         }       // end 48 bpp
+
+         default:
+         {
+            png_bytep sptr;
+            png_bytep dp;
+            png_size_t pixel_bytes;
+            int offset_table[7] = {0, 4, 0, 2, 0, 1, 0};
+            unsigned int i;
+            register int disp = png_pass_inc[png_ptr->pass];  // get the offset
+            register unsigned int incr1, initial_val, final_val;
+
+            pixel_bytes = (png_ptr->row_info.pixel_depth >> 3);
+            sptr = png_ptr->row_buf + 1 + offset_table[png_ptr->pass]*
+               pixel_bytes;
+            dp = row + offset_table[png_ptr->pass]*pixel_bytes;
+            initial_val = offset_table[png_ptr->pass]*pixel_bytes;
+            final_val = png_ptr->width*pixel_bytes;
+            incr1 = (disp)*pixel_bytes;
+            for (i = initial_val; i < final_val; i += incr1)
+            {
+               png_memcpy(dp, sptr, pixel_bytes);
+               sptr += incr1;
+               dp += incr1;
+            }
+            break;
+         }
+      } /* end switch (png_ptr->row_info.pixel_depth) */
+   } /* end if (non-trivial mask) */
+
+} /* end png_combine_row() */
+
+
+#if defined(PNG_READ_INTERLACING_SUPPORTED)
+
+void /* PRIVATE */
+png_do_read_interlace(png_structp png_ptr)
+{
+   png_row_infop row_info = &(png_ptr->row_info);
+   png_bytep row = png_ptr->row_buf + 1;
+   int pass = png_ptr->pass;
+   png_uint_32 transformations = png_ptr->transformations;
+#ifdef PNG_USE_LOCAL_ARRAYS
+   const int png_pass_inc[7] = {8, 8, 4, 4, 2, 2, 1};
+#endif
+
+   png_debug(1,"in png_do_read_interlace\n");
+
+   if (mmx_supported == 2) {
+       /* this should have happened in png_init_mmx_flags() already */
+       png_warning(png_ptr, "asm_flags may not have been initialized");
+       png_mmx_support();
+   }
+
+   if (row != NULL && row_info != NULL)
+   {
+      png_uint_32 final_width;
+
+      final_width = row_info->width * png_pass_inc[pass];
+
+      switch (row_info->pixel_depth)
+      {
+         case 1:
+         {
+            png_bytep sp, dp;
+            int sshift, dshift;
+            int s_start, s_end, s_inc;
+            png_byte v;
+            png_uint_32 i;
+            int j;
+
+            sp = row + (png_size_t)((row_info->width - 1) >> 3);
+            dp = row + (png_size_t)((final_width - 1) >> 3);
+#if defined(PNG_READ_PACKSWAP_SUPPORTED)
+            if (transformations & PNG_PACKSWAP)
+            {
+               sshift = (int)((row_info->width + 7) & 7);
+               dshift = (int)((final_width + 7) & 7);
+               s_start = 7;
+               s_end = 0;
+               s_inc = -1;
+            }
+            else
+#endif
+            {
+               sshift = 7 - (int)((row_info->width + 7) & 7);
+               dshift = 7 - (int)((final_width + 7) & 7);
+               s_start = 0;
+               s_end = 7;
+               s_inc = 1;
+            }
+
+            for (i = row_info->width; i; i--)
+            {
+               v = (png_byte)((*sp >> sshift) & 0x1);
+               for (j = 0; j < png_pass_inc[pass]; j++)
+               {
+                  *dp &= (png_byte)((0x7f7f >> (7 - dshift)) & 0xff);
+                  *dp |= (png_byte)(v << dshift);
+                  if (dshift == s_end)
+                  {
+                     dshift = s_start;
+                     dp--;
+                  }
+                  else
+                     dshift += s_inc;
+               }
+               if (sshift == s_end)
+               {
+                  sshift = s_start;
+                  sp--;
+               }
+               else
+                  sshift += s_inc;
+            }
+            break;
+         }
+
+         case 2:
+         {
+            png_bytep sp, dp;
+            int sshift, dshift;
+            int s_start, s_end, s_inc;
+            png_uint_32 i;
+
+            sp = row + (png_size_t)((row_info->width - 1) >> 2);
+            dp = row + (png_size_t)((final_width - 1) >> 2);
+#if defined(PNG_READ_PACKSWAP_SUPPORTED)
+            if (transformations & PNG_PACKSWAP)
+            {
+               sshift = (png_size_t)(((row_info->width + 3) & 3) << 1);
+               dshift = (png_size_t)(((final_width + 3) & 3) << 1);
+               s_start = 6;
+               s_end = 0;
+               s_inc = -2;
+            }
+            else
+#endif
+            {
+               sshift = (png_size_t)((3 - ((row_info->width + 3) & 3)) << 1);
+               dshift = (png_size_t)((3 - ((final_width + 3) & 3)) << 1);
+               s_start = 0;
+               s_end = 6;
+               s_inc = 2;
+            }
+
+            for (i = row_info->width; i; i--)
+            {
+               png_byte v;
+               int j;
+
+               v = (png_byte)((*sp >> sshift) & 0x3);
+               for (j = 0; j < png_pass_inc[pass]; j++)
+               {
+                  *dp &= (png_byte)((0x3f3f >> (6 - dshift)) & 0xff);
+                  *dp |= (png_byte)(v << dshift);
+                  if (dshift == s_end)
+                  {
+                     dshift = s_start;
+                     dp--;
+                  }
+                  else
+                     dshift += s_inc;
+               }
+               if (sshift == s_end)
+               {
+                  sshift = s_start;
+                  sp--;
+               }
+               else
+                  sshift += s_inc;
+            }
+            break;
+         }
+
+         case 4:
+         {
+            png_bytep sp, dp;
+            int sshift, dshift;
+            int s_start, s_end, s_inc;
+            png_uint_32 i;
+
+            sp = row + (png_size_t)((row_info->width - 1) >> 1);
+            dp = row + (png_size_t)((final_width - 1) >> 1);
+#if defined(PNG_READ_PACKSWAP_SUPPORTED)
+            if (transformations & PNG_PACKSWAP)
+            {
+               sshift = (png_size_t)(((row_info->width + 1) & 1) << 2);
+               dshift = (png_size_t)(((final_width + 1) & 1) << 2);
+               s_start = 4;
+               s_end = 0;
+               s_inc = -4;
+            }
+            else
+#endif
+            {
+               sshift = (png_size_t)((1 - ((row_info->width + 1) & 1)) << 2);
+               dshift = (png_size_t)((1 - ((final_width + 1) & 1)) << 2);
+               s_start = 0;
+               s_end = 4;
+               s_inc = 4;
+            }
+
+            for (i = row_info->width; i; i--)
+            {
+               png_byte v;
+               int j;
+
+               v = (png_byte)((*sp >> sshift) & 0xf);
+               for (j = 0; j < png_pass_inc[pass]; j++)
+               {
+                  *dp &= (png_byte)((0xf0f >> (4 - dshift)) & 0xff);
+                  *dp |= (png_byte)(v << dshift);
+                  if (dshift == s_end)
+                  {
+                     dshift = s_start;
+                     dp--;
+                  }
+                  else
+                     dshift += s_inc;
+               }
+               if (sshift == s_end)
+               {
+                  sshift = s_start;
+                  sp--;
+               }
+               else
+                  sshift += s_inc;
+            }
+            break;
+         }
+
+         default:         // This is the place where the routine is modified
+         {
+            __int64 const4 = 0x0000000000FFFFFF;
+            // __int64 const5 = 0x000000FFFFFF0000;  // unused...
+            __int64 const6 = 0x00000000000000FF;
+            png_bytep sptr, dp;
+            png_uint_32 i;
+            png_size_t pixel_bytes;
+            int width = row_info->width;
+
+            pixel_bytes = (row_info->pixel_depth >> 3);
+
+            sptr = row + (width - 1) * pixel_bytes;
+            dp = row + (final_width - 1) * pixel_bytes;
+            // New code by Nirav Chhatrapati - Intel Corporation
+            // sign fix by GRR
+            // NOTE:  there is NO MMX code for 48-bit and 64-bit images
+
+            // use MMX routine if machine supports it
+            if ((png_ptr->asm_flags & PNG_ASM_FLAG_MMX_READ_INTERLACE)
+                /* && mmx_supported */ )
+            {
+               if (pixel_bytes == 3)
+               {
+                  if (((pass == 0) || (pass == 1)) && width)
+                  {
+                     _asm
+                     {
+                        mov esi, sptr
+                        mov edi, dp
+                        mov ecx, width
+                        sub edi, 21   // (png_pass_inc[pass] - 1)*pixel_bytes
+loop_pass0:
+                        movd mm0, [esi]     ; X X X X X v2 v1 v0
+                        pand mm0, const4    ; 0 0 0 0 0 v2 v1 v0
+                        movq mm1, mm0       ; 0 0 0 0 0 v2 v1 v0
+                        psllq mm0, 16       ; 0 0 0 v2 v1 v0 0 0
+                        movq mm2, mm0       ; 0 0 0 v2 v1 v0 0 0
+                        psllq mm0, 24       ; v2 v1 v0 0 0 0 0 0
+                        psrlq mm1, 8        ; 0 0 0 0 0 0 v2 v1
+                        por mm0, mm2        ; v2 v1 v0 v2 v1 v0 0 0
+                        por mm0, mm1        ; v2 v1 v0 v2 v1 v0 v2 v1
+                        movq mm3, mm0       ; v2 v1 v0 v2 v1 v0 v2 v1
+                        psllq mm0, 16       ; v0 v2 v1 v0 v2 v1 0 0
+                        movq mm4, mm3       ; v2 v1 v0 v2 v1 v0 v2 v1
+                        punpckhdq mm3, mm0  ; v0 v2 v1 v0 v2 v1 v0 v2
+                        movq [edi+16] , mm4
+                        psrlq mm0, 32       ; 0 0 0 0 v0 v2 v1 v0
+                        movq [edi+8] , mm3
+                        punpckldq mm0, mm4  ; v1 v0 v2 v1 v0 v2 v1 v0
+                        sub esi, 3
+                        movq [edi], mm0
+                        sub edi, 24
+                        //sub esi, 3
+                        dec ecx
+                        jnz loop_pass0
+                        EMMS
+                     }
+                  }
+                  else if (((pass == 2) || (pass == 3)) && width)
+                  {
+                     _asm
+                     {
+                        mov esi, sptr
+                        mov edi, dp
+                        mov ecx, width
+                        sub edi, 9   // (png_pass_inc[pass] - 1)*pixel_bytes
+loop_pass2:
+                        movd mm0, [esi]     ; X X X X X v2 v1 v0
+                        pand mm0, const4    ; 0 0 0 0 0 v2 v1 v0
+                        movq mm1, mm0       ; 0 0 0 0 0 v2 v1 v0
+                        psllq mm0, 16       ; 0 0 0 v2 v1 v0 0 0
+                        movq mm2, mm0       ; 0 0 0 v2 v1 v0 0 0
+                        psllq mm0, 24       ; v2 v1 v0 0 0 0 0 0
+                        psrlq mm1, 8        ; 0 0 0 0 0 0 v2 v1
+                        por mm0, mm2        ; v2 v1 v0 v2 v1 v0 0 0
+                        por mm0, mm1        ; v2 v1 v0 v2 v1 v0 v2 v1
+                        movq [edi+4], mm0   ; move to memory
+                        psrlq mm0, 16       ; 0 0 v2 v1 v0 v2 v1 v0
+                        movd [edi], mm0     ; move to memory
+                        sub esi, 3
+                        sub edi, 12
+                        dec ecx
+                        jnz loop_pass2
+                        EMMS
+                     }
+                  }
+                  else if (width) /* && ((pass == 4) || (pass == 5)) */
+                  {
+                     int width_mmx = ((width >> 1) << 1) - 8;
+                     if (width_mmx < 0)
+                         width_mmx = 0;
+                     width -= width_mmx;        // 8 or 9 pix, 24 or 27 bytes
+                     if (width_mmx)
+                     {
+                        _asm
+                        {
+                           mov esi, sptr
+                           mov edi, dp
+                           mov ecx, width_mmx
+                           sub esi, 3
+                           sub edi, 9
+loop_pass4:
+                           movq mm0, [esi]     ; X X v2 v1 v0 v5 v4 v3
+                           movq mm7, mm0       ; X X v2 v1 v0 v5 v4 v3
+                           movq mm6, mm0       ; X X v2 v1 v0 v5 v4 v3
+                           psllq mm0, 24       ; v1 v0 v5 v4 v3 0 0 0
+                           pand mm7, const4    ; 0 0 0 0 0 v5 v4 v3
+                           psrlq mm6, 24       ; 0 0 0 X X v2 v1 v0
+                           por mm0, mm7        ; v1 v0 v5 v4 v3 v5 v4 v3
+                           movq mm5, mm6       ; 0 0 0 X X v2 v1 v0
+                           psllq mm6, 8        ; 0 0 X X v2 v1 v0 0
+                           movq [edi], mm0     ; move quad to memory
+                           psrlq mm5, 16       ; 0 0 0 0 0 X X v2
+                           pand mm5, const6    ; 0 0 0 0 0 0 0 v2
+                           por mm6, mm5        ; 0 0 X X v2 v1 v0 v2
+                           movd [edi+8], mm6   ; move double to memory
+                           sub esi, 6
+                           sub edi, 12
+                           sub ecx, 2
+                           jnz loop_pass4
+                           EMMS
+                        }
+                     }
+
+                     sptr -= width_mmx*3;
+                     dp -= width_mmx*6;
+                     for (i = width; i; i--)
+                     {
+                        png_byte v[8];
+                        int j;
+
+                        png_memcpy(v, sptr, 3);
+                        for (j = 0; j < png_pass_inc[pass]; j++)
+                        {
+                           png_memcpy(dp, v, 3);
+                           dp -= 3;
+                        }
+                        sptr -= 3;
+                     }
+                  }
+               } /* end of pixel_bytes == 3 */
+
+               else if (pixel_bytes == 1)
+               {
+                  if (((pass == 0) || (pass == 1)) && width)
+                  {
+                     int width_mmx = ((width >> 2) << 2);
+                     width -= width_mmx;
+                     if (width_mmx)
+                     {
+                        _asm
+                        {
+                           mov esi, sptr
+                           mov edi, dp
+                           mov ecx, width_mmx
+                           sub edi, 31
+                           sub esi, 3
+loop1_pass0:
+                           movd mm0, [esi]     ; X X X X v0 v1 v2 v3
+                           movq mm1, mm0       ; X X X X v0 v1 v2 v3
+                           punpcklbw mm0, mm0  ; v0 v0 v1 v1 v2 v2 v3 v3
+                           movq mm2, mm0       ; v0 v0 v1 v1 v2 v2 v3 v3
+                           punpcklwd mm0, mm0  ; v2 v2 v2 v2 v3 v3 v3 v3
+                           movq mm3, mm0       ; v2 v2 v2 v2 v3 v3 v3 v3
+                           punpckldq mm0, mm0  ; v3 v3 v3 v3 v3 v3 v3 v3
+                           punpckhdq mm3, mm3  ; v2 v2 v2 v2 v2 v2 v2 v2
+                           movq [edi], mm0     ; move to memory v3
+                           punpckhwd mm2, mm2  ; v0 v0 v0 v0 v1 v1 v1 v1
+                           movq [edi+8], mm3   ; move to memory v2
+                           movq mm4, mm2       ; v0 v0 v0 v0 v1 v1 v1 v1
+                           punpckldq mm2, mm2  ; v1 v1 v1 v1 v1 v1 v1 v1
+                           punpckhdq mm4, mm4  ; v0 v0 v0 v0 v0 v0 v0 v0
+                           movq [edi+16], mm2  ; move to memory v1
+                           movq [edi+24], mm4  ; move to memory v0
+                           sub esi, 4
+                           sub edi, 32
+                           sub ecx, 4
+                           jnz loop1_pass0
+                           EMMS
+                        }
+                     }
+
+                     sptr -= width_mmx;
+                     dp -= width_mmx*8;
+                     for (i = width; i; i--)
+                     {
+                        int j;
+
+                       /* I simplified this part in version 1.0.4e
+                        * here and in several other instances where
+                        * pixel_bytes == 1  -- GR-P
+                        *
+                        * Original code:
+                        *
+                        * png_byte v[8];
+                        * png_memcpy(v, sptr, pixel_bytes);
+                        * for (j = 0; j < png_pass_inc[pass]; j++)
+                        * {
+                        *    png_memcpy(dp, v, pixel_bytes);
+                        *    dp -= pixel_bytes;
+                        * }
+                        * sptr -= pixel_bytes;
+                        *
+                        * Replacement code is in the next three lines:
+                        */
+
+                        for (j = 0; j < png_pass_inc[pass]; j++)
+                           *dp-- = *sptr;
+                        sptr--;
+                     }
+                  }
+                  else if (((pass == 2) || (pass == 3)) && width)
+                  {
+                     int width_mmx = ((width >> 2) << 2);
+                     width -= width_mmx;
+                     if (width_mmx)
+                     {
+                        _asm
+                        {
+                           mov esi, sptr
+                           mov edi, dp
+                           mov ecx, width_mmx
+                           sub edi, 15
+                           sub esi, 3
+loop1_pass2:
+                           movd mm0, [esi]     ; X X X X v0 v1 v2 v3
+                           punpcklbw mm0, mm0  ; v0 v0 v1 v1 v2 v2 v3 v3
+                           movq mm1, mm0       ; v0 v0 v1 v1 v2 v2 v3 v3
+                           punpcklwd mm0, mm0  ; v2 v2 v2 v2 v3 v3 v3 v3
+                           punpckhwd mm1, mm1  ; v0 v0 v0 v0 v1 v1 v1 v1
+                           movq [edi], mm0     ; move to memory v2 and v3
+                           sub esi, 4
+                           movq [edi+8], mm1   ; move to memory v1     and v0
+                           sub edi, 16
+                           sub ecx, 4
+                           jnz loop1_pass2
+                           EMMS
+                        }
+                     }
+
+                     sptr -= width_mmx;
+                     dp -= width_mmx*4;
+                     for (i = width; i; i--)
+                     {
+                        int j;
+
+                        for (j = 0; j < png_pass_inc[pass]; j++)
+                        {
+                           *dp-- = *sptr;
+                        }
+                        sptr --;
+                     }
+                  }
+                  else if (width) /* && ((pass == 4) || (pass == 5))) */
+                  {
+                     int width_mmx = ((width >> 3) << 3);
+                     width -= width_mmx;
+                     if (width_mmx)
+                     {
+                        _asm
+                        {
+                           mov esi, sptr
+                           mov edi, dp
+                           mov ecx, width_mmx
+                           sub edi, 15
+                           sub esi, 7
+loop1_pass4:
+                           movq mm0, [esi]     ; v0 v1 v2 v3 v4 v5 v6 v7
+                           movq mm1, mm0       ; v0 v1 v2 v3 v4 v5 v6 v7
+                           punpcklbw mm0, mm0  ; v4 v4 v5 v5 v6 v6 v7 v7
+                           //movq mm1, mm0     ; v0 v0 v1 v1 v2 v2 v3 v3
+                           punpckhbw mm1, mm1  ;v0 v0 v1 v1 v2 v2 v3 v3
+                           movq [edi+8], mm1   ; move to memory v0 v1 v2 and v3
+                           sub esi, 8
+                           movq [edi], mm0     ; move to memory v4 v5 v6 and v7
+                           //sub esi, 4
+                           sub edi, 16
+                           sub ecx, 8
+                           jnz loop1_pass4
+                           EMMS
+                        }
+                     }
+
+                     sptr -= width_mmx;
+                     dp -= width_mmx*2;
+                     for (i = width; i; i--)
+                     {
+                        int j;
+
+                        for (j = 0; j < png_pass_inc[pass]; j++)
+                        {
+                           *dp-- = *sptr;
+                        }
+                        sptr --;
+                     }
+                  }
+               } /* end of pixel_bytes == 1 */
+
+               else if (pixel_bytes == 2)
+               {
+                  if (((pass == 0) || (pass == 1)) && width)
+                  {
+                     int width_mmx = ((width >> 1) << 1);
+                     width -= width_mmx;
+                     if (width_mmx)
+                     {
+                        _asm
+                        {
+                           mov esi, sptr
+                           mov edi, dp
+                           mov ecx, width_mmx
+                           sub esi, 2
+                           sub edi, 30
+loop2_pass0:
+                           movd mm0, [esi]        ; X X X X v1 v0 v3 v2
+                           punpcklwd mm0, mm0     ; v1 v0 v1 v0 v3 v2 v3 v2
+                           movq mm1, mm0          ; v1 v0 v1 v0 v3 v2 v3 v2
+                           punpckldq mm0, mm0     ; v3 v2 v3 v2 v3 v2 v3 v2
+                           punpckhdq mm1, mm1     ; v1 v0 v1 v0 v1 v0 v1 v0
+                           movq [edi], mm0
+                           movq [edi + 8], mm0
+                           movq [edi + 16], mm1
+                           movq [edi + 24], mm1
+                           sub esi, 4
+                           sub edi, 32
+                           sub ecx, 2
+                           jnz loop2_pass0
+                           EMMS
+                        }
+                     }
+
+                     sptr -= (width_mmx*2 - 2);            // sign fixed
+                     dp -= (width_mmx*16 - 2);            // sign fixed
+                     for (i = width; i; i--)
+                     {
+                        png_byte v[8];
+                        int j;
+                        sptr -= 2;
+                        png_memcpy(v, sptr, 2);
+                        for (j = 0; j < png_pass_inc[pass]; j++)
+                        {
+                           dp -= 2;
+                           png_memcpy(dp, v, 2);
+                        }
+                     }
+                  }
+                  else if (((pass == 2) || (pass == 3)) && width)
+                  {
+                     int width_mmx = ((width >> 1) << 1) ;
+                     width -= width_mmx;
+                     if (width_mmx)
+                     {
+                        _asm
+                        {
+                           mov esi, sptr
+                           mov edi, dp
+                           mov ecx, width_mmx
+                           sub esi, 2
+                           sub edi, 14
+loop2_pass2:
+                           movd mm0, [esi]        ; X X X X v1 v0 v3 v2
+                           punpcklwd mm0, mm0     ; v1 v0 v1 v0 v3 v2 v3 v2
+                           movq mm1, mm0          ; v1 v0 v1 v0 v3 v2 v3 v2
+                           punpckldq mm0, mm0     ; v3 v2 v3 v2 v3 v2 v3 v2
+                           punpckhdq mm1, mm1     ; v1 v0 v1 v0 v1 v0 v1 v0
+                           movq [edi], mm0
+                           sub esi, 4
+                           movq [edi + 8], mm1
+                           //sub esi, 4
+                           sub edi, 16
+                           sub ecx, 2
+                           jnz loop2_pass2
+                           EMMS
+                        }
+                     }
+
+                     sptr -= (width_mmx*2 - 2);            // sign fixed
+                     dp -= (width_mmx*8 - 2);            // sign fixed
+                     for (i = width; i; i--)
+                     {
+                        png_byte v[8];
+                        int j;
+                        sptr -= 2;
+                        png_memcpy(v, sptr, 2);
+                        for (j = 0; j < png_pass_inc[pass]; j++)
+                        {
+                           dp -= 2;
+                           png_memcpy(dp, v, 2);
+                        }
+                     }
+                  }
+                  else if (width)  // pass == 4 or 5
+                  {
+                     int width_mmx = ((width >> 1) << 1) ;
+                     width -= width_mmx;
+                     if (width_mmx)
+                     {
+                        _asm
+                        {
+                           mov esi, sptr
+                           mov edi, dp
+                           mov ecx, width_mmx
+                           sub esi, 2
+                           sub edi, 6
+loop2_pass4:
+                           movd mm0, [esi]        ; X X X X v1 v0 v3 v2
+                           punpcklwd mm0, mm0     ; v1 v0 v1 v0 v3 v2 v3 v2
+                           sub esi, 4
+                           movq [edi], mm0
+                           sub edi, 8
+                           sub ecx, 2
+                           jnz loop2_pass4
+                           EMMS
+                        }
+                     }
+
+                     sptr -= (width_mmx*2 - 2);            // sign fixed
+                     dp -= (width_mmx*4 - 2);            // sign fixed
+                     for (i = width; i; i--)
+                     {
+                        png_byte v[8];
+                        int j;
+                        sptr -= 2;
+                        png_memcpy(v, sptr, 2);
+                        for (j = 0; j < png_pass_inc[pass]; j++)
+                        {
+                           dp -= 2;
+                           png_memcpy(dp, v, 2);
+                        }
+                     }
+                  }
+               } /* end of pixel_bytes == 2 */
+
+               else if (pixel_bytes == 4)
+               {
+                  if (((pass == 0) || (pass == 1)) && width)
+                  {
+                     int width_mmx = ((width >> 1) << 1) ;
+                     width -= width_mmx;
+                     if (width_mmx)
+                     {
+                        _asm
+                        {
+                           mov esi, sptr
+                           mov edi, dp
+                           mov ecx, width_mmx
+                           sub esi, 4
+                           sub edi, 60
+loop4_pass0:
+                           movq mm0, [esi]        ; v3 v2 v1 v0 v7 v6 v5 v4
+                           movq mm1, mm0          ; v3 v2 v1 v0 v7 v6 v5 v4
+                           punpckldq mm0, mm0     ; v7 v6 v5 v4 v7 v6 v5 v4
+                           punpckhdq mm1, mm1     ; v3 v2 v1 v0 v3 v2 v1 v0
+                           movq [edi], mm0
+                           movq [edi + 8], mm0
+                           movq [edi + 16], mm0
+                           movq [edi + 24], mm0
+                           movq [edi+32], mm1
+                           movq [edi + 40], mm1
+                           movq [edi+ 48], mm1
+                           sub esi, 8
+                           movq [edi + 56], mm1
+                           sub edi, 64
+                           sub ecx, 2
+                           jnz loop4_pass0
+                           EMMS
+                        }
+                     }
+
+                     sptr -= (width_mmx*4 - 4);            // sign fixed
+                     dp -= (width_mmx*32 - 4);            // sign fixed
+                     for (i = width; i; i--)
+                     {
+                        png_byte v[8];
+                        int j;
+                        sptr -= 4;
+                        png_memcpy(v, sptr, 4);
+                        for (j = 0; j < png_pass_inc[pass]; j++)
+                        {
+                           dp -= 4;
+                           png_memcpy(dp, v, 4);
+                        }
+                     }
+                  }
+                  else if (((pass == 2) || (pass == 3)) && width)
+                  {
+                     int width_mmx = ((width >> 1) << 1) ;
+                     width -= width_mmx;
+                     if (width_mmx)
+                     {
+                        _asm
+                        {
+                           mov esi, sptr
+                           mov edi, dp
+                           mov ecx, width_mmx
+                           sub esi, 4
+                           sub edi, 28
+loop4_pass2:
+                           movq mm0, [esi]      ; v3 v2 v1 v0 v7 v6 v5 v4
+                           movq mm1, mm0        ; v3 v2 v1 v0 v7 v6 v5 v4
+                           punpckldq mm0, mm0   ; v7 v6 v5 v4 v7 v6 v5 v4
+                           punpckhdq mm1, mm1   ; v3 v2 v1 v0 v3 v2 v1 v0
+                           movq [edi], mm0
+                           movq [edi + 8], mm0
+                           movq [edi+16], mm1
+                           movq [edi + 24], mm1
+                           sub esi, 8
+                           sub edi, 32
+                           sub ecx, 2
+                           jnz loop4_pass2
+                           EMMS
+                        }
+                     }
+
+                     sptr -= (width_mmx*4 - 4);            // sign fixed
+                     dp -= (width_mmx*16 - 4);            // sign fixed
+                     for (i = width; i; i--)
+                     {
+                        png_byte v[8];
+                        int j;
+                        sptr -= 4;
+                        png_memcpy(v, sptr, 4);
+                        for (j = 0; j < png_pass_inc[pass]; j++)
+                        {
+                           dp -= 4;
+                           png_memcpy(dp, v, 4);
+                        }
+                     }
+                  }
+                  else if (width)  // pass == 4 or 5
+                  {
+                     int width_mmx = ((width >> 1) << 1) ;
+                     width -= width_mmx;
+                     if (width_mmx)
+                     {
+                        _asm
+                        {
+                           mov esi, sptr
+                           mov edi, dp
+                           mov ecx, width_mmx
+                           sub esi, 4
+                           sub edi, 12
+loop4_pass4:
+                           movq mm0, [esi]      ; v3 v2 v1 v0 v7 v6 v5 v4
+                           movq mm1, mm0        ; v3 v2 v1 v0 v7 v6 v5 v4
+                           punpckldq mm0, mm0   ; v7 v6 v5 v4 v7 v6 v5 v4
+                           punpckhdq mm1, mm1   ; v3 v2 v1 v0 v3 v2 v1 v0
+                           movq [edi], mm0
+                           sub esi, 8
+                           movq [edi + 8], mm1
+                           sub edi, 16
+                           sub ecx, 2
+                           jnz loop4_pass4
+                           EMMS
+                        }
+                     }
+
+                     sptr -= (width_mmx*4 - 4);          // sign fixed
+                     dp -= (width_mmx*8 - 4);            // sign fixed
+                     for (i = width; i; i--)
+                     {
+                        png_byte v[8];
+                        int j;
+                        sptr -= 4;
+                        png_memcpy(v, sptr, 4);
+                        for (j = 0; j < png_pass_inc[pass]; j++)
+                        {
+                           dp -= 4;
+                           png_memcpy(dp, v, 4);
+                        }
+                     }
+                  }
+
+               } /* end of pixel_bytes == 4 */
+
+               else if (pixel_bytes == 6)
+               {
+                  for (i = width; i; i--)
+                  {
+                     png_byte v[8];
+                     int j;
+                     png_memcpy(v, sptr, 6);
+                     for (j = 0; j < png_pass_inc[pass]; j++)
+                     {
+                        png_memcpy(dp, v, 6);
+                        dp -= 6;
+                     }
+                     sptr -= 6;
+                  }
+               } /* end of pixel_bytes == 6 */
+
+               else
+               {
+                  for (i = width; i; i--)
+                  {
+                     png_byte v[8];
+                     int j;
+                     png_memcpy(v, sptr, pixel_bytes);
+                     for (j = 0; j < png_pass_inc[pass]; j++)
+                     {
+                        png_memcpy(dp, v, pixel_bytes);
+                        dp -= pixel_bytes;
+                     }
+                     sptr-= pixel_bytes;
+                  }
+               }
+            } /* end of mmx_supported */
+
+            else /* MMX not supported:  use modified C code - takes advantage
+                  * of inlining of memcpy for a constant */
+            {
+               if (pixel_bytes == 1)
+               {
+                  for (i = width; i; i--)
+                  {
+                     int j;
+                     for (j = 0; j < png_pass_inc[pass]; j++)
+                        *dp-- = *sptr;
+                     sptr--;
+                  }
+               }
+               else if (pixel_bytes == 3)
+               {
+                  for (i = width; i; i--)
+                  {
+                     png_byte v[8];
+                     int j;
+                     png_memcpy(v, sptr, pixel_bytes);
+                     for (j = 0; j < png_pass_inc[pass]; j++)
+                     {
+                        png_memcpy(dp, v, pixel_bytes);
+                        dp -= pixel_bytes;
+                     }
+                     sptr -= pixel_bytes;
+                  }
+               }
+               else if (pixel_bytes == 2)
+               {
+                  for (i = width; i; i--)
+                  {
+                     png_byte v[8];
+                     int j;
+                     png_memcpy(v, sptr, pixel_bytes);
+                     for (j = 0; j < png_pass_inc[pass]; j++)
+                     {
+                        png_memcpy(dp, v, pixel_bytes);
+                        dp -= pixel_bytes;
+                     }
+                     sptr -= pixel_bytes;
+                  }
+               }
+               else if (pixel_bytes == 4)
+               {
+                  for (i = width; i; i--)
+                  {
+                     png_byte v[8];
+                     int j;
+                     png_memcpy(v, sptr, pixel_bytes);
+                     for (j = 0; j < png_pass_inc[pass]; j++)
+                     {
+                        png_memcpy(dp, v, pixel_bytes);
+                        dp -= pixel_bytes;
+                     }
+                     sptr -= pixel_bytes;
+                  }
+               }
+               else if (pixel_bytes == 6)
+               {
+                  for (i = width; i; i--)
+                  {
+                     png_byte v[8];
+                     int j;
+                     png_memcpy(v, sptr, pixel_bytes);
+                     for (j = 0; j < png_pass_inc[pass]; j++)
+                     {
+                        png_memcpy(dp, v, pixel_bytes);
+                        dp -= pixel_bytes;
+                     }
+                     sptr -= pixel_bytes;
+                  }
+               }
+               else
+               {
+                  for (i = width; i; i--)
+                  {
+                     png_byte v[8];
+                     int j;
+                     png_memcpy(v, sptr, pixel_bytes);
+                     for (j = 0; j < png_pass_inc[pass]; j++)
+                     {
+                        png_memcpy(dp, v, pixel_bytes);
+                        dp -= pixel_bytes;
+                     }
+                     sptr -= pixel_bytes;
+                  }
+               }
+
+            } /* end of MMX not supported */
+            break;
+         }
+      } /* end switch (row_info->pixel_depth) */
+
+      row_info->width = final_width;
+      row_info->rowbytes = ((final_width *
+         (png_uint_32)row_info->pixel_depth + 7) >> 3);
+   }
+
+}
+
+#endif /* PNG_READ_INTERLACING_SUPPORTED */
+
+
+// These variables are utilized in the functions below.  They are declared
+// globally here to ensure alignment on 8-byte boundaries.
+
+union uAll {
+   __int64 use;
+   double  align;
+} LBCarryMask = {0x0101010101010101},
+  HBClearMask = {0x7f7f7f7f7f7f7f7f},
+  ActiveMask, ActiveMask2, ActiveMaskEnd, ShiftBpp, ShiftRem;
+
+
+// Optimized code for PNG Average filter decoder
+void /* PRIVATE */
+png_read_filter_row_mmx_avg(png_row_infop row_info, png_bytep row
+                            , png_bytep prev_row)
+{
+   int bpp;
+   png_uint_32 FullLength;
+   png_uint_32 MMXLength;
+   //png_uint_32 len;
+   int diff;
+
+   bpp = (row_info->pixel_depth + 7) >> 3; // Get # bytes per pixel
+   FullLength  = row_info->rowbytes; // # of bytes to filter
+   _asm {
+         // Init address pointers and offset
+         mov edi, row          // edi ==> Avg(x)
+         xor ebx, ebx          // ebx ==> x
+         mov edx, edi
+         mov esi, prev_row           // esi ==> Prior(x)
+         sub edx, bpp          // edx ==> Raw(x-bpp)
+
+         xor eax, eax
+         // Compute the Raw value for the first bpp bytes
+         //    Raw(x) = Avg(x) + (Prior(x)/2)
+davgrlp:
+         mov al, [esi + ebx]   // Load al with Prior(x)
+         inc ebx
+         shr al, 1             // divide by 2
+         add al, [edi+ebx-1]   // Add Avg(x); -1 to offset inc ebx
+         cmp ebx, bpp
+         mov [edi+ebx-1], al    // Write back Raw(x);
+                            // mov does not affect flags; -1 to offset inc ebx
+         jb davgrlp
+         // get # of bytes to alignment
+         mov diff, edi         // take start of row
+         add diff, ebx         // add bpp
+         add diff, 0xf         // add 7 + 8 to incr past alignment boundary
+         and diff, 0xfffffff8  // mask to alignment boundary
+         sub diff, edi         // subtract from start ==> value ebx at alignment
+         jz davggo
+         // fix alignment
+         // Compute the Raw value for the bytes upto the alignment boundary
+         //    Raw(x) = Avg(x) + ((Raw(x-bpp) + Prior(x))/2)
+         xor ecx, ecx
+davglp1:
+         xor eax, eax
+         mov cl, [esi + ebx]        // load cl with Prior(x)
+         mov al, [edx + ebx]  // load al with Raw(x-bpp)
+         add ax, cx
+         inc ebx
+         shr ax, 1            // divide by 2
+         add al, [edi+ebx-1]  // Add Avg(x); -1 to offset inc ebx
+         cmp ebx, diff              // Check if at alignment boundary
+         mov [edi+ebx-1], al        // Write back Raw(x);
+                            // mov does not affect flags; -1 to offset inc ebx
+         jb davglp1               // Repeat until at alignment boundary
+davggo:
+         mov eax, FullLength
+         mov ecx, eax
+         sub eax, ebx          // subtract alignment fix
+         and eax, 0x00000007   // calc bytes over mult of 8
+         sub ecx, eax          // drop over bytes from original length
+         mov MMXLength, ecx
+   } // end _asm block
+   // Now do the math for the rest of the row
+   switch ( bpp )
+   {
+      case 3:
+      {
+         ActiveMask.use  = 0x0000000000ffffff;
+         ShiftBpp.use = 24;    // == 3 * 8
+         ShiftRem.use = 40;    // == 64 - 24
+         _asm {
+            // Re-init address pointers and offset
+            movq mm7, ActiveMask
+            mov ebx, diff      // ebx ==> x = offset to alignment boundary
+            movq mm5, LBCarryMask
+            mov edi, row       // edi ==> Avg(x)
+            movq mm4, HBClearMask
+            mov esi, prev_row        // esi ==> Prior(x)
+            // PRIME the pump (load the first Raw(x-bpp) data set
+            movq mm2, [edi + ebx - 8]  // Load previous aligned 8 bytes
+                               // (we correct position in loop below)
+davg3lp:
+            movq mm0, [edi + ebx]      // Load mm0 with Avg(x)
+            // Add (Prev_row/2) to Average
+            movq mm3, mm5
+            psrlq mm2, ShiftRem      // Correct position Raw(x-bpp) data
+            movq mm1, [esi + ebx]    // Load mm1 with Prior(x)
+            movq mm6, mm7
+            pand mm3, mm1      // get lsb for each prev_row byte
+            psrlq mm1, 1       // divide prev_row bytes by 2
+            pand  mm1, mm4     // clear invalid bit 7 of each byte
+            paddb mm0, mm1     // add (Prev_row/2) to Avg for each byte
+            // Add 1st active group (Raw(x-bpp)/2) to Average with LBCarry
+            movq mm1, mm3      // now use mm1 for getting LBCarrys
+            pand mm1, mm2      // get LBCarrys for each byte where both
+                               // lsb's were == 1 (Only valid for active group)
+            psrlq mm2, 1       // divide raw bytes by 2
+            pand  mm2, mm4     // clear invalid bit 7 of each byte
+            paddb mm2, mm1     // add LBCarrys to (Raw(x-bpp)/2) for each byte
+            pand mm2, mm6      // Leave only Active Group 1 bytes to add to Avg
+            paddb mm0, mm2     // add (Raw/2) + LBCarrys to Avg for each Active
+                               //  byte
+            // Add 2nd active group (Raw(x-bpp)/2) to Average with LBCarry
+            psllq mm6, ShiftBpp  // shift the mm6 mask to cover bytes 3-5
+            movq mm2, mm0        // mov updated Raws to mm2
+            psllq mm2, ShiftBpp  // shift data to position correctly
+            movq mm1, mm3        // now use mm1 for getting LBCarrys
+            pand mm1, mm2      // get LBCarrys for each byte where both
+                               // lsb's were == 1 (Only valid for active group)
+            psrlq mm2, 1       // divide raw bytes by 2
+            pand  mm2, mm4     // clear invalid bit 7 of each byte
+            paddb mm2, mm1     // add LBCarrys to (Raw(x-bpp)/2) for each byte
+            pand mm2, mm6      // Leave only Active Group 2 bytes to add to Avg
+            paddb mm0, mm2     // add (Raw/2) + LBCarrys to Avg for each Active
+                               //  byte
+
+            // Add 3rd active group (Raw(x-bpp)/2) to Average with LBCarry
+            psllq mm6, ShiftBpp  // shift the mm6 mask to cover the last two
+                                 // bytes
+            movq mm2, mm0        // mov updated Raws to mm2
+            psllq mm2, ShiftBpp  // shift data to position correctly
+                              // Data only needs to be shifted once here to
+                              // get the correct x-bpp offset.
+            movq mm1, mm3     // now use mm1 for getting LBCarrys
+            pand mm1, mm2     // get LBCarrys for each byte where both
+                              // lsb's were == 1 (Only valid for active group)
+            psrlq mm2, 1      // divide raw bytes by 2
+            pand  mm2, mm4    // clear invalid bit 7 of each byte
+            paddb mm2, mm1    // add LBCarrys to (Raw(x-bpp)/2) for each byte
+            pand mm2, mm6     // Leave only Active Group 2 bytes to add to Avg
+            add ebx, 8
+            paddb mm0, mm2    // add (Raw/2) + LBCarrys to Avg for each Active
+                              // byte
+
+            // Now ready to write back to memory
+            movq [edi + ebx - 8], mm0
+            // Move updated Raw(x) to use as Raw(x-bpp) for next loop
+            cmp ebx, MMXLength
+            movq mm2, mm0     // mov updated Raw(x) to mm2
+            jb davg3lp
+         } // end _asm block
+      }
+      break;
+
+      case 6:
+      case 4:
+      case 7:
+      case 5:
+      {
+         ActiveMask.use  = 0xffffffffffffffff;  // use shift below to clear
+                                                // appropriate inactive bytes
+         ShiftBpp.use = bpp << 3;
+         ShiftRem.use = 64 - ShiftBpp.use;
+         _asm {
+            movq mm4, HBClearMask
+            // Re-init address pointers and offset
+            mov ebx, diff       // ebx ==> x = offset to alignment boundary
+            // Load ActiveMask and clear all bytes except for 1st active group
+            movq mm7, ActiveMask
+            mov edi, row         // edi ==> Avg(x)
+            psrlq mm7, ShiftRem
+            mov esi, prev_row    // esi ==> Prior(x)
+            movq mm6, mm7
+            movq mm5, LBCarryMask
+            psllq mm6, ShiftBpp  // Create mask for 2nd active group
+            // PRIME the pump (load the first Raw(x-bpp) data set
+            movq mm2, [edi + ebx - 8]  // Load previous aligned 8 bytes
+                                 // (we correct position in loop below)
+davg4lp:
+            movq mm0, [edi + ebx]
+            psrlq mm2, ShiftRem  // shift data to position correctly
+            movq mm1, [esi + ebx]
+            // Add (Prev_row/2) to Average
+            movq mm3, mm5
+            pand mm3, mm1     // get lsb for each prev_row byte
+            psrlq mm1, 1      // divide prev_row bytes by 2
+            pand  mm1, mm4    // clear invalid bit 7 of each byte
+            paddb mm0, mm1    // add (Prev_row/2) to Avg for each byte
+            // Add 1st active group (Raw(x-bpp)/2) to Average with LBCarry
+            movq mm1, mm3     // now use mm1 for getting LBCarrys
+            pand mm1, mm2     // get LBCarrys for each byte where both
+                              // lsb's were == 1 (Only valid for active group)
+            psrlq mm2, 1      // divide raw bytes by 2
+            pand  mm2, mm4    // clear invalid bit 7 of each byte
+            paddb mm2, mm1    // add LBCarrys to (Raw(x-bpp)/2) for each byte
+            pand mm2, mm7     // Leave only Active Group 1 bytes to add to Avg
+            paddb mm0, mm2    // add (Raw/2) + LBCarrys to Avg for each Active
+                              // byte
+            // Add 2nd active group (Raw(x-bpp)/2) to Average with LBCarry
+            movq mm2, mm0     // mov updated Raws to mm2
+            psllq mm2, ShiftBpp // shift data to position correctly
+            add ebx, 8
+            movq mm1, mm3     // now use mm1 for getting LBCarrys
+            pand mm1, mm2     // get LBCarrys for each byte where both
+                              // lsb's were == 1 (Only valid for active group)
+            psrlq mm2, 1      // divide raw bytes by 2
+            pand  mm2, mm4    // clear invalid bit 7 of each byte
+            paddb mm2, mm1    // add LBCarrys to (Raw(x-bpp)/2) for each byte
+            pand mm2, mm6     // Leave only Active Group 2 bytes to add to Avg
+            paddb mm0, mm2    // add (Raw/2) + LBCarrys to Avg for each Active
+                              // byte
+            cmp ebx, MMXLength
+            // Now ready to write back to memory
+            movq [edi + ebx - 8], mm0
+            // Prep Raw(x-bpp) for next loop
+            movq mm2, mm0     // mov updated Raws to mm2
+            jb davg4lp
+         } // end _asm block
+      }
+      break;
+      case 2:
+      {
+         ActiveMask.use  = 0x000000000000ffff;
+         ShiftBpp.use = 16;   // == 2 * 8     [BUGFIX]
+         ShiftRem.use = 48;   // == 64 - 16   [BUGFIX]
+         _asm {
+            // Load ActiveMask
+            movq mm7, ActiveMask
+            // Re-init address pointers and offset
+            mov ebx, diff     // ebx ==> x = offset to alignment boundary
+            movq mm5, LBCarryMask
+            mov edi, row      // edi ==> Avg(x)
+            movq mm4, HBClearMask
+            mov esi, prev_row  // esi ==> Prior(x)
+            // PRIME the pump (load the first Raw(x-bpp) data set
+            movq mm2, [edi + ebx - 8]  // Load previous aligned 8 bytes
+                              // (we correct position in loop below)
+davg2lp:
+            movq mm0, [edi + ebx]
+            psrlq mm2, ShiftRem  // shift data to position correctly   [BUGFIX]
+            movq mm1, [esi + ebx]
+            // Add (Prev_row/2) to Average
+            movq mm3, mm5
+            pand mm3, mm1     // get lsb for each prev_row byte
+            psrlq mm1, 1      // divide prev_row bytes by 2
+            pand  mm1, mm4    // clear invalid bit 7 of each byte
+            movq mm6, mm7
+            paddb mm0, mm1    // add (Prev_row/2) to Avg for each byte
+            // Add 1st active group (Raw(x-bpp)/2) to Average with LBCarry
+            movq mm1, mm3     // now use mm1 for getting LBCarrys
+            pand mm1, mm2     // get LBCarrys for each byte where both
+                              // lsb's were == 1 (Only valid for active group)
+            psrlq mm2, 1      // divide raw bytes by 2
+            pand  mm2, mm4    // clear invalid bit 7 of each byte
+            paddb mm2, mm1    // add LBCarrys to (Raw(x-bpp)/2) for each byte
+            pand mm2, mm6     // Leave only Active Group 1 bytes to add to Avg
+            paddb mm0, mm2 // add (Raw/2) + LBCarrys to Avg for each Active byte
+            // Add 2nd active group (Raw(x-bpp)/2) to Average with LBCarry
+            psllq mm6, ShiftBpp // shift the mm6 mask to cover bytes 2 & 3
+            movq mm2, mm0       // mov updated Raws to mm2
+            psllq mm2, ShiftBpp // shift data to position correctly
+            movq mm1, mm3       // now use mm1 for getting LBCarrys
+            pand mm1, mm2       // get LBCarrys for each byte where both
+                                // lsb's were == 1 (Only valid for active group)
+            psrlq mm2, 1        // divide raw bytes by 2
+            pand  mm2, mm4      // clear invalid bit 7 of each byte
+            paddb mm2, mm1      // add LBCarrys to (Raw(x-bpp)/2) for each byte
+            pand mm2, mm6       // Leave only Active Group 2 bytes to add to Avg
+            paddb mm0, mm2 // add (Raw/2) + LBCarrys to Avg for each Active byte
+
+            // Add rdd active group (Raw(x-bpp)/2) to Average with LBCarry
+            psllq mm6, ShiftBpp // shift the mm6 mask to cover bytes 4 & 5
+            movq mm2, mm0       // mov updated Raws to mm2
+            psllq mm2, ShiftBpp // shift data to position correctly
+                                // Data only needs to be shifted once here to
+                                // get the correct x-bpp offset.
+            movq mm1, mm3       // now use mm1 for getting LBCarrys
+            pand mm1, mm2       // get LBCarrys for each byte where both
+                                // lsb's were == 1 (Only valid for active group)
+            psrlq mm2, 1        // divide raw bytes by 2
+            pand  mm2, mm4      // clear invalid bit 7 of each byte
+            paddb mm2, mm1      // add LBCarrys to (Raw(x-bpp)/2) for each byte
+            pand mm2, mm6       // Leave only Active Group 2 bytes to add to Avg
+            paddb mm0, mm2 // add (Raw/2) + LBCarrys to Avg for each Active byte
+
+            // Add 4th active group (Raw(x-bpp)/2) to Average with LBCarry
+            psllq mm6, ShiftBpp  // shift the mm6 mask to cover bytes 6 & 7
+            movq mm2, mm0        // mov updated Raws to mm2
+            psllq mm2, ShiftBpp  // shift data to position correctly
+                                 // Data only needs to be shifted once here to
+                                 // get the correct x-bpp offset.
+            add ebx, 8
+            movq mm1, mm3    // now use mm1 for getting LBCarrys
+            pand mm1, mm2    // get LBCarrys for each byte where both
+                             // lsb's were == 1 (Only valid for active group)
+            psrlq mm2, 1     // divide raw bytes by 2
+            pand  mm2, mm4   // clear invalid bit 7 of each byte
+            paddb mm2, mm1   // add LBCarrys to (Raw(x-bpp)/2) for each byte
+            pand mm2, mm6    // Leave only Active Group 2 bytes to add to Avg
+            paddb mm0, mm2 // add (Raw/2) + LBCarrys to Avg for each Active byte
+
+            cmp ebx, MMXLength
+            // Now ready to write back to memory
+            movq [edi + ebx - 8], mm0
+            // Prep Raw(x-bpp) for next loop
+            movq mm2, mm0    // mov updated Raws to mm2
+            jb davg2lp
+        } // end _asm block
+      }
+      break;
+
+      case 1:                 // bpp == 1
+      {
+         _asm {
+            // Re-init address pointers and offset
+            mov ebx, diff     // ebx ==> x = offset to alignment boundary
+            mov edi, row      // edi ==> Avg(x)
+            cmp ebx, FullLength  // Test if offset at end of array
+            jnb davg1end
+            // Do Paeth decode for remaining bytes
+            mov esi, prev_row    // esi ==> Prior(x)
+            mov edx, edi
+            xor ecx, ecx         // zero ecx before using cl & cx in loop below
+            sub edx, bpp         // edx ==> Raw(x-bpp)
+davg1lp:
+            // Raw(x) = Avg(x) + ((Raw(x-bpp) + Prior(x))/2)
+            xor eax, eax
+            mov cl, [esi + ebx]  // load cl with Prior(x)
+            mov al, [edx + ebx]  // load al with Raw(x-bpp)
+            add ax, cx
+            inc ebx
+            shr ax, 1            // divide by 2
+            add al, [edi+ebx-1]  // Add Avg(x); -1 to offset inc ebx
+            cmp ebx, FullLength  // Check if at end of array
+            mov [edi+ebx-1], al  // Write back Raw(x);
+                         // mov does not affect flags; -1 to offset inc ebx
+            jb davg1lp
+davg1end:
+         } // end _asm block
+      }
+      return;
+
+      case 8:             // bpp == 8
+      {
+         _asm {
+            // Re-init address pointers and offset
+            mov ebx, diff           // ebx ==> x = offset to alignment boundary
+            movq mm5, LBCarryMask
+            mov edi, row            // edi ==> Avg(x)
+            movq mm4, HBClearMask
+            mov esi, prev_row       // esi ==> Prior(x)
+            // PRIME the pump (load the first Raw(x-bpp) data set
+            movq mm2, [edi + ebx - 8]  // Load previous aligned 8 bytes
+                                // (NO NEED to correct position in loop below)
+davg8lp:
+            movq mm0, [edi + ebx]
+            movq mm3, mm5
+            movq mm1, [esi + ebx]
+            add ebx, 8
+            pand mm3, mm1       // get lsb for each prev_row byte
+            psrlq mm1, 1        // divide prev_row bytes by 2
+            pand mm3, mm2       // get LBCarrys for each byte where both
+                                // lsb's were == 1
+            psrlq mm2, 1        // divide raw bytes by 2
+            pand  mm1, mm4      // clear invalid bit 7 of each byte
+            paddb mm0, mm3      // add LBCarrys to Avg for each byte
+            pand  mm2, mm4      // clear invalid bit 7 of each byte
+            paddb mm0, mm1      // add (Prev_row/2) to Avg for each byte
+            paddb mm0, mm2      // add (Raw/2) to Avg for each byte
+            cmp ebx, MMXLength
+            movq [edi + ebx - 8], mm0
+            movq mm2, mm0       // reuse as Raw(x-bpp)
+            jb davg8lp
+        } // end _asm block
+      }
+      break;
+      default:                  // bpp greater than 8
+      {
+        _asm {
+            movq mm5, LBCarryMask
+            // Re-init address pointers and offset
+            mov ebx, diff       // ebx ==> x = offset to alignment boundary
+            mov edi, row        // edi ==> Avg(x)
+            movq mm4, HBClearMask
+            mov edx, edi
+            mov esi, prev_row   // esi ==> Prior(x)
+            sub edx, bpp        // edx ==> Raw(x-bpp)
+davgAlp:
+            movq mm0, [edi + ebx]
+            movq mm3, mm5
+            movq mm1, [esi + ebx]
+            pand mm3, mm1       // get lsb for each prev_row byte
+            movq mm2, [edx + ebx]
+            psrlq mm1, 1        // divide prev_row bytes by 2
+            pand mm3, mm2       // get LBCarrys for each byte where both
+                                // lsb's were == 1
+            psrlq mm2, 1        // divide raw bytes by 2
+            pand  mm1, mm4      // clear invalid bit 7 of each byte
+            paddb mm0, mm3      // add LBCarrys to Avg for each byte
+            pand  mm2, mm4      // clear invalid bit 7 of each byte
+            paddb mm0, mm1      // add (Prev_row/2) to Avg for each byte
+            add ebx, 8
+            paddb mm0, mm2      // add (Raw/2) to Avg for each byte
+            cmp ebx, MMXLength
+            movq [edi + ebx - 8], mm0
+            jb davgAlp
+        } // end _asm block
+      }
+      break;
+   }                         // end switch ( bpp )
+
+   _asm {
+         // MMX acceleration complete now do clean-up
+         // Check if any remaining bytes left to decode
+         mov ebx, MMXLength    // ebx ==> x = offset bytes remaining after MMX
+         mov edi, row          // edi ==> Avg(x)
+         cmp ebx, FullLength   // Test if offset at end of array
+         jnb davgend
+         // Do Paeth decode for remaining bytes
+         mov esi, prev_row     // esi ==> Prior(x)
+         mov edx, edi
+         xor ecx, ecx          // zero ecx before using cl & cx in loop below
+         sub edx, bpp          // edx ==> Raw(x-bpp)
+davglp2:
+         // Raw(x) = Avg(x) + ((Raw(x-bpp) + Prior(x))/2)
+         xor eax, eax
+         mov cl, [esi + ebx]   // load cl with Prior(x)
+         mov al, [edx + ebx]   // load al with Raw(x-bpp)
+         add ax, cx
+         inc ebx
+         shr ax, 1              // divide by 2
+         add al, [edi+ebx-1]    // Add Avg(x); -1 to offset inc ebx
+         cmp ebx, FullLength    // Check if at end of array
+         mov [edi+ebx-1], al    // Write back Raw(x);
+                          // mov does not affect flags; -1 to offset inc ebx
+         jb davglp2
+davgend:
+         emms             // End MMX instructions; prep for possible FP instrs.
+   } // end _asm block
+}
+
+// Optimized code for PNG Paeth filter decoder
+void /* PRIVATE */
+png_read_filter_row_mmx_paeth(png_row_infop row_info, png_bytep row,
+                              png_bytep prev_row)
+{
+   png_uint_32 FullLength;
+   png_uint_32 MMXLength;
+   //png_uint_32 len;
+   int bpp;
+   int diff;
+   //int ptemp;
+   int patemp, pbtemp, pctemp;
+
+   bpp = (row_info->pixel_depth + 7) >> 3; // Get # bytes per pixel
+   FullLength  = row_info->rowbytes; // # of bytes to filter
+   _asm
+   {
+         xor ebx, ebx        // ebx ==> x offset
+         mov edi, row
+         xor edx, edx        // edx ==> x-bpp offset
+         mov esi, prev_row
+         xor eax, eax
+
+         // Compute the Raw value for the first bpp bytes
+         // Note: the formula works out to be always
+         //   Paeth(x) = Raw(x) + Prior(x)      where x < bpp
+dpthrlp:
+         mov al, [edi + ebx]
+         add al, [esi + ebx]
+         inc ebx
+         cmp ebx, bpp
+         mov [edi + ebx - 1], al
+         jb dpthrlp
+         // get # of bytes to alignment
+         mov diff, edi         // take start of row
+         add diff, ebx         // add bpp
+         xor ecx, ecx
+         add diff, 0xf         // add 7 + 8 to incr past alignment boundary
+         and diff, 0xfffffff8  // mask to alignment boundary
+         sub diff, edi         // subtract from start ==> value ebx at alignment
+         jz dpthgo
+         // fix alignment
+dpthlp1:
+         xor eax, eax
+         // pav = p - a = (a + b - c) - a = b - c
+         mov al, [esi + ebx]   // load Prior(x) into al
+         mov cl, [esi + edx]   // load Prior(x-bpp) into cl
+         sub eax, ecx          // subtract Prior(x-bpp)
+         mov patemp, eax       // Save pav for later use
+         xor eax, eax
+         // pbv = p - b = (a + b - c) - b = a - c
+         mov al, [edi + edx]   // load Raw(x-bpp) into al
+         sub eax, ecx          // subtract Prior(x-bpp)
+         mov ecx, eax
+         // pcv = p - c = (a + b - c) -c = (a - c) + (b - c) = pav + pbv
+         add eax, patemp       // pcv = pav + pbv
+         // pc = abs(pcv)
+         test eax, 0x80000000
+         jz dpthpca
+         neg eax               // reverse sign of neg values
+dpthpca:
+         mov pctemp, eax       // save pc for later use
+         // pb = abs(pbv)
+         test ecx, 0x80000000
+         jz dpthpba
+         neg ecx               // reverse sign of neg values
+dpthpba:
+         mov pbtemp, ecx       // save pb for later use
+         // pa = abs(pav)
+         mov eax, patemp
+         test eax, 0x80000000
+         jz dpthpaa
+         neg eax               // reverse sign of neg values
+dpthpaa:
+         mov patemp, eax       // save pa for later use
+         // test if pa <= pb
+         cmp eax, ecx
+         jna dpthabb
+         // pa > pb; now test if pb <= pc
+         cmp ecx, pctemp
+         jna dpthbbc
+         // pb > pc; Raw(x) = Paeth(x) + Prior(x-bpp)
+         mov cl, [esi + edx]  // load Prior(x-bpp) into cl
+         jmp dpthpaeth
+dpthbbc:
+         // pb <= pc; Raw(x) = Paeth(x) + Prior(x)
+         mov cl, [esi + ebx]   // load Prior(x) into cl
+         jmp dpthpaeth
+dpthabb:
+         // pa <= pb; now test if pa <= pc
+         cmp eax, pctemp
+         jna dpthabc
+         // pa > pc; Raw(x) = Paeth(x) + Prior(x-bpp)
+         mov cl, [esi + edx]  // load Prior(x-bpp) into cl
+         jmp dpthpaeth
+dpthabc:
+         // pa <= pc; Raw(x) = Paeth(x) + Raw(x-bpp)
+         mov cl, [edi + edx]  // load Raw(x-bpp) into cl
+dpthpaeth:
+         inc ebx
+         inc edx
+         // Raw(x) = (Paeth(x) + Paeth_Predictor( a, b, c )) mod 256
+         add [edi + ebx - 1], cl
+         cmp ebx, diff
+         jb dpthlp1
+dpthgo:
+         mov ecx, FullLength
+         mov eax, ecx
+         sub eax, ebx          // subtract alignment fix
+         and eax, 0x00000007   // calc bytes over mult of 8
+         sub ecx, eax          // drop over bytes from original length
+         mov MMXLength, ecx
+   } // end _asm block
+   // Now do the math for the rest of the row
+   switch ( bpp )
+   {
+      case 3:
+      {
+         ActiveMask.use = 0x0000000000ffffff;
+         ActiveMaskEnd.use = 0xffff000000000000;
+         ShiftBpp.use = 24;    // == bpp(3) * 8
+         ShiftRem.use = 40;    // == 64 - 24
+         _asm
+         {
+            mov ebx, diff
+            mov edi, row
+            mov esi, prev_row
+            pxor mm0, mm0
+            // PRIME the pump (load the first Raw(x-bpp) data set
+            movq mm1, [edi+ebx-8]
+dpth3lp:
+            psrlq mm1, ShiftRem     // shift last 3 bytes to 1st 3 bytes
+            movq mm2, [esi + ebx]   // load b=Prior(x)
+            punpcklbw mm1, mm0      // Unpack High bytes of a
+            movq mm3, [esi+ebx-8]   // Prep c=Prior(x-bpp) bytes
+            punpcklbw mm2, mm0      // Unpack High bytes of b
+            psrlq mm3, ShiftRem     // shift last 3 bytes to 1st 3 bytes
+            // pav = p - a = (a + b - c) - a = b - c
+            movq mm4, mm2
+            punpcklbw mm3, mm0      // Unpack High bytes of c
+            // pbv = p - b = (a + b - c) - b = a - c
+            movq mm5, mm1
+            psubw mm4, mm3
+            pxor mm7, mm7
+            // pcv = p - c = (a + b - c) -c = (a - c) + (b - c) = pav + pbv
+            movq mm6, mm4
+            psubw mm5, mm3
+
+            // pa = abs(p-a) = abs(pav)
+            // pb = abs(p-b) = abs(pbv)
+            // pc = abs(p-c) = abs(pcv)
+            pcmpgtw mm0, mm4    // Create mask pav bytes < 0
+            paddw mm6, mm5
+            pand mm0, mm4       // Only pav bytes < 0 in mm7
+            pcmpgtw mm7, mm5    // Create mask pbv bytes < 0
+            psubw mm4, mm0
+            pand mm7, mm5       // Only pbv bytes < 0 in mm0
+            psubw mm4, mm0
+            psubw mm5, mm7
+            pxor mm0, mm0
+            pcmpgtw mm0, mm6    // Create mask pcv bytes < 0
+            pand mm0, mm6       // Only pav bytes < 0 in mm7
+            psubw mm5, mm7
+            psubw mm6, mm0
+            //  test pa <= pb
+            movq mm7, mm4
+            psubw mm6, mm0
+            pcmpgtw mm7, mm5    // pa > pb?
+            movq mm0, mm7
+            // use mm7 mask to merge pa & pb
+            pand mm5, mm7
+            // use mm0 mask copy to merge a & b
+            pand mm2, mm0
+            pandn mm7, mm4
+            pandn mm0, mm1
+            paddw mm7, mm5
+            paddw mm0, mm2
+            //  test  ((pa <= pb)? pa:pb) <= pc
+            pcmpgtw mm7, mm6       // pab > pc?
+            pxor mm1, mm1
+            pand mm3, mm7
+            pandn mm7, mm0
+            paddw mm7, mm3
+            pxor mm0, mm0
+            packuswb mm7, mm1
+            movq mm3, [esi + ebx]   // load c=Prior(x-bpp)
+            pand mm7, ActiveMask
+            movq mm2, mm3           // load b=Prior(x) step 1
+            paddb mm7, [edi + ebx]  // add Paeth predictor with Raw(x)
+            punpcklbw mm3, mm0      // Unpack High bytes of c
+            movq [edi + ebx], mm7   // write back updated value
+            movq mm1, mm7           // Now mm1 will be used as Raw(x-bpp)
+            // Now do Paeth for 2nd set of bytes (3-5)
+            psrlq mm2, ShiftBpp     // load b=Prior(x) step 2
+            punpcklbw mm1, mm0      // Unpack High bytes of a
+            pxor mm7, mm7
+            punpcklbw mm2, mm0      // Unpack High bytes of b
+            // pbv = p - b = (a + b - c) - b = a - c
+            movq mm5, mm1
+            // pav = p - a = (a + b - c) - a = b - c
+            movq mm4, mm2
+            psubw mm5, mm3
+            psubw mm4, mm3
+            // pcv = p - c = (a + b - c) -c = (a - c) + (b - c) =
+            //       pav + pbv = pbv + pav
+            movq mm6, mm5
+            paddw mm6, mm4
+
+            // pa = abs(p-a) = abs(pav)
+            // pb = abs(p-b) = abs(pbv)
+            // pc = abs(p-c) = abs(pcv)
+            pcmpgtw mm0, mm5       // Create mask pbv bytes < 0
+            pcmpgtw mm7, mm4       // Create mask pav bytes < 0
+            pand mm0, mm5          // Only pbv bytes < 0 in mm0
+            pand mm7, mm4          // Only pav bytes < 0 in mm7
+            psubw mm5, mm0
+            psubw mm4, mm7
+            psubw mm5, mm0
+            psubw mm4, mm7
+            pxor mm0, mm0
+            pcmpgtw mm0, mm6       // Create mask pcv bytes < 0
+            pand mm0, mm6          // Only pav bytes < 0 in mm7
+            psubw mm6, mm0
+            //  test pa <= pb
+            movq mm7, mm4
+            psubw mm6, mm0
+            pcmpgtw mm7, mm5       // pa > pb?
+            movq mm0, mm7
+            // use mm7 mask to merge pa & pb
+            pand mm5, mm7
+            // use mm0 mask copy to merge a & b
+            pand mm2, mm0
+            pandn mm7, mm4
+            pandn mm0, mm1
+            paddw mm7, mm5
+            paddw mm0, mm2
+            //  test  ((pa <= pb)? pa:pb) <= pc
+            pcmpgtw mm7, mm6       // pab > pc?
+            movq mm2, [esi + ebx]  // load b=Prior(x)
+            pand mm3, mm7
+            pandn mm7, mm0
+            pxor mm1, mm1
+            paddw mm7, mm3
+            pxor mm0, mm0
+            packuswb mm7, mm1
+            movq mm3, mm2           // load c=Prior(x-bpp) step 1
+            pand mm7, ActiveMask
+            punpckhbw mm2, mm0      // Unpack High bytes of b
+            psllq mm7, ShiftBpp     // Shift bytes to 2nd group of 3 bytes
+             // pav = p - a = (a + b - c) - a = b - c
+            movq mm4, mm2
+            paddb mm7, [edi + ebx]  // add Paeth predictor with Raw(x)
+            psllq mm3, ShiftBpp     // load c=Prior(x-bpp) step 2
+            movq [edi + ebx], mm7   // write back updated value
+            movq mm1, mm7
+            punpckhbw mm3, mm0      // Unpack High bytes of c
+            psllq mm1, ShiftBpp     // Shift bytes
+                                    // Now mm1 will be used as Raw(x-bpp)
+            // Now do Paeth for 3rd, and final, set of bytes (6-7)
+            pxor mm7, mm7
+            punpckhbw mm1, mm0      // Unpack High bytes of a
+            psubw mm4, mm3
+            // pbv = p - b = (a + b - c) - b = a - c
+            movq mm5, mm1
+            // pcv = p - c = (a + b - c) -c = (a - c) + (b - c) = pav + pbv
+            movq mm6, mm4
+            psubw mm5, mm3
+            pxor mm0, mm0
+            paddw mm6, mm5
+
+            // pa = abs(p-a) = abs(pav)
+            // pb = abs(p-b) = abs(pbv)
+            // pc = abs(p-c) = abs(pcv)
+            pcmpgtw mm0, mm4    // Create mask pav bytes < 0
+            pcmpgtw mm7, mm5    // Create mask pbv bytes < 0
+            pand mm0, mm4       // Only pav bytes < 0 in mm7
+            pand mm7, mm5       // Only pbv bytes < 0 in mm0
+            psubw mm4, mm0
+            psubw mm5, mm7
+            psubw mm4, mm0
+            psubw mm5, mm7
+            pxor mm0, mm0
+            pcmpgtw mm0, mm6    // Create mask pcv bytes < 0
+            pand mm0, mm6       // Only pav bytes < 0 in mm7
+            psubw mm6, mm0
+            //  test pa <= pb
+            movq mm7, mm4
+            psubw mm6, mm0
+            pcmpgtw mm7, mm5    // pa > pb?
+            movq mm0, mm7
+            // use mm0 mask copy to merge a & b
+            pand mm2, mm0
+            // use mm7 mask to merge pa & pb
+            pand mm5, mm7
+            pandn mm0, mm1
+            pandn mm7, mm4
+            paddw mm0, mm2
+            paddw mm7, mm5
+            //  test  ((pa <= pb)? pa:pb) <= pc
+            pcmpgtw mm7, mm6    // pab > pc?
+            pand mm3, mm7
+            pandn mm7, mm0
+            paddw mm7, mm3
+            pxor mm1, mm1
+            packuswb mm1, mm7
+            // Step ebx to next set of 8 bytes and repeat loop til done
+            add ebx, 8
+            pand mm1, ActiveMaskEnd
+            paddb mm1, [edi + ebx - 8] // add Paeth predictor with Raw(x)
+
+            cmp ebx, MMXLength
+            pxor mm0, mm0              // pxor does not affect flags
+            movq [edi + ebx - 8], mm1  // write back updated value
+                                 // mm1 will be used as Raw(x-bpp) next loop
+                           // mm3 ready to be used as Prior(x-bpp) next loop
+            jb dpth3lp
+         } // end _asm block
+      }
+      break;
+
+      case 6:
+      case 7:
+      case 5:
+      {
+         ActiveMask.use  = 0x00000000ffffffff;
+         ActiveMask2.use = 0xffffffff00000000;
+         ShiftBpp.use = bpp << 3;    // == bpp * 8
+         ShiftRem.use = 64 - ShiftBpp.use;
+         _asm
+         {
+            mov ebx, diff
+            mov edi, row
+            mov esi, prev_row
+            // PRIME the pump (load the first Raw(x-bpp) data set
+            movq mm1, [edi+ebx-8]
+            pxor mm0, mm0
+dpth6lp:
+            // Must shift to position Raw(x-bpp) data
+            psrlq mm1, ShiftRem
+            // Do first set of 4 bytes
+            movq mm3, [esi+ebx-8]      // read c=Prior(x-bpp) bytes
+            punpcklbw mm1, mm0      // Unpack Low bytes of a
+            movq mm2, [esi + ebx]   // load b=Prior(x)
+            punpcklbw mm2, mm0      // Unpack Low bytes of b
+            // Must shift to position Prior(x-bpp) data
+            psrlq mm3, ShiftRem
+            // pav = p - a = (a + b - c) - a = b - c
+            movq mm4, mm2
+            punpcklbw mm3, mm0      // Unpack Low bytes of c
+            // pbv = p - b = (a + b - c) - b = a - c
+            movq mm5, mm1
+            psubw mm4, mm3
+            pxor mm7, mm7
+            // pcv = p - c = (a + b - c) -c = (a - c) + (b - c) = pav + pbv
+            movq mm6, mm4
+            psubw mm5, mm3
+            // pa = abs(p-a) = abs(pav)
+            // pb = abs(p-b) = abs(pbv)
+            // pc = abs(p-c) = abs(pcv)
+            pcmpgtw mm0, mm4    // Create mask pav bytes < 0
+            paddw mm6, mm5
+            pand mm0, mm4       // Only pav bytes < 0 in mm7
+            pcmpgtw mm7, mm5    // Create mask pbv bytes < 0
+            psubw mm4, mm0
+            pand mm7, mm5       // Only pbv bytes < 0 in mm0
+            psubw mm4, mm0
+            psubw mm5, mm7
+            pxor mm0, mm0
+            pcmpgtw mm0, mm6    // Create mask pcv bytes < 0
+            pand mm0, mm6       // Only pav bytes < 0 in mm7
+            psubw mm5, mm7
+            psubw mm6, mm0
+            //  test pa <= pb
+            movq mm7, mm4
+            psubw mm6, mm0
+            pcmpgtw mm7, mm5    // pa > pb?
+            movq mm0, mm7
+            // use mm7 mask to merge pa & pb
+            pand mm5, mm7
+            // use mm0 mask copy to merge a & b
+            pand mm2, mm0
+            pandn mm7, mm4
+            pandn mm0, mm1
+            paddw mm7, mm5
+            paddw mm0, mm2
+            //  test  ((pa <= pb)? pa:pb) <= pc
+            pcmpgtw mm7, mm6    // pab > pc?
+            pxor mm1, mm1
+            pand mm3, mm7
+            pandn mm7, mm0
+            paddw mm7, mm3
+            pxor mm0, mm0
+            packuswb mm7, mm1
+            movq mm3, [esi + ebx - 8]  // load c=Prior(x-bpp)
+            pand mm7, ActiveMask
+            psrlq mm3, ShiftRem
+            movq mm2, [esi + ebx]      // load b=Prior(x) step 1
+            paddb mm7, [edi + ebx]     // add Paeth predictor with Raw(x)
+            movq mm6, mm2
+            movq [edi + ebx], mm7      // write back updated value
+            movq mm1, [edi+ebx-8]
+            psllq mm6, ShiftBpp
+            movq mm5, mm7
+            psrlq mm1, ShiftRem
+            por mm3, mm6
+            psllq mm5, ShiftBpp
+            punpckhbw mm3, mm0         // Unpack High bytes of c
+            por mm1, mm5
+            // Do second set of 4 bytes
+            punpckhbw mm2, mm0         // Unpack High bytes of b
+            punpckhbw mm1, mm0         // Unpack High bytes of a
+            // pav = p - a = (a + b - c) - a = b - c
+            movq mm4, mm2
+            // pbv = p - b = (a + b - c) - b = a - c
+            movq mm5, mm1
+            psubw mm4, mm3
+            pxor mm7, mm7
+            // pcv = p - c = (a + b - c) -c = (a - c) + (b - c) = pav + pbv
+            movq mm6, mm4
+            psubw mm5, mm3
+            // pa = abs(p-a) = abs(pav)
+            // pb = abs(p-b) = abs(pbv)
+            // pc = abs(p-c) = abs(pcv)
+            pcmpgtw mm0, mm4       // Create mask pav bytes < 0
+            paddw mm6, mm5
+            pand mm0, mm4          // Only pav bytes < 0 in mm7
+            pcmpgtw mm7, mm5       // Create mask pbv bytes < 0
+            psubw mm4, mm0
+            pand mm7, mm5          // Only pbv bytes < 0 in mm0
+            psubw mm4, mm0
+            psubw mm5, mm7
+            pxor mm0, mm0
+            pcmpgtw mm0, mm6       // Create mask pcv bytes < 0
+            pand mm0, mm6          // Only pav bytes < 0 in mm7
+            psubw mm5, mm7
+            psubw mm6, mm0
+            //  test pa <= pb
+            movq mm7, mm4
+            psubw mm6, mm0
+            pcmpgtw mm7, mm5       // pa > pb?
+            movq mm0, mm7
+            // use mm7 mask to merge pa & pb
+            pand mm5, mm7
+            // use mm0 mask copy to merge a & b
+            pand mm2, mm0
+            pandn mm7, mm4
+            pandn mm0, mm1
+            paddw mm7, mm5
+            paddw mm0, mm2
+            //  test  ((pa <= pb)? pa:pb) <= pc
+            pcmpgtw mm7, mm6           // pab > pc?
+            pxor mm1, mm1
+            pand mm3, mm7
+            pandn mm7, mm0
+            pxor mm1, mm1
+            paddw mm7, mm3
+            pxor mm0, mm0
+            // Step ex to next set of 8 bytes and repeat loop til done
+            add ebx, 8
+            packuswb mm1, mm7
+            paddb mm1, [edi + ebx - 8]     // add Paeth predictor with Raw(x)
+            cmp ebx, MMXLength
+            movq [edi + ebx - 8], mm1      // write back updated value
+                                // mm1 will be used as Raw(x-bpp) next loop
+            jb dpth6lp
+         } // end _asm block
+      }
+      break;
+
+      case 4:
+      {
+         ActiveMask.use  = 0x00000000ffffffff;
+         _asm {
+            mov ebx, diff
+            mov edi, row
+            mov esi, prev_row
+            pxor mm0, mm0
+            // PRIME the pump (load the first Raw(x-bpp) data set
+            movq mm1, [edi+ebx-8]    // Only time should need to read
+                                     //  a=Raw(x-bpp) bytes
+dpth4lp:
+            // Do first set of 4 bytes
+            movq mm3, [esi+ebx-8]    // read c=Prior(x-bpp) bytes
+            punpckhbw mm1, mm0       // Unpack Low bytes of a
+            movq mm2, [esi + ebx]    // load b=Prior(x)
+            punpcklbw mm2, mm0       // Unpack High bytes of b
+            // pav = p - a = (a + b - c) - a = b - c
+            movq mm4, mm2
+            punpckhbw mm3, mm0       // Unpack High bytes of c
+            // pbv = p - b = (a + b - c) - b = a - c
+            movq mm5, mm1
+            psubw mm4, mm3
+            pxor mm7, mm7
+            // pcv = p - c = (a + b - c) -c = (a - c) + (b - c) = pav + pbv
+            movq mm6, mm4
+            psubw mm5, mm3
+            // pa = abs(p-a) = abs(pav)
+            // pb = abs(p-b) = abs(pbv)
+            // pc = abs(p-c) = abs(pcv)
+            pcmpgtw mm0, mm4       // Create mask pav bytes < 0
+            paddw mm6, mm5
+            pand mm0, mm4          // Only pav bytes < 0 in mm7
+            pcmpgtw mm7, mm5       // Create mask pbv bytes < 0
+            psubw mm4, mm0
+            pand mm7, mm5          // Only pbv bytes < 0 in mm0
+            psubw mm4, mm0
+            psubw mm5, mm7
+            pxor mm0, mm0
+            pcmpgtw mm0, mm6       // Create mask pcv bytes < 0
+            pand mm0, mm6          // Only pav bytes < 0 in mm7
+            psubw mm5, mm7
+            psubw mm6, mm0
+            //  test pa <= pb
+            movq mm7, mm4
+            psubw mm6, mm0
+            pcmpgtw mm7, mm5       // pa > pb?
+            movq mm0, mm7
+            // use mm7 mask to merge pa & pb
+            pand mm5, mm7
+            // use mm0 mask copy to merge a & b
+            pand mm2, mm0
+            pandn mm7, mm4
+            pandn mm0, mm1
+            paddw mm7, mm5
+            paddw mm0, mm2
+            //  test  ((pa <= pb)? pa:pb) <= pc
+            pcmpgtw mm7, mm6       // pab > pc?
+            pxor mm1, mm1
+            pand mm3, mm7
+            pandn mm7, mm0
+            paddw mm7, mm3
+            pxor mm0, mm0
+            packuswb mm7, mm1
+            movq mm3, [esi + ebx]      // load c=Prior(x-bpp)
+            pand mm7, ActiveMask
+            movq mm2, mm3              // load b=Prior(x) step 1
+            paddb mm7, [edi + ebx]     // add Paeth predictor with Raw(x)
+            punpcklbw mm3, mm0         // Unpack High bytes of c
+            movq [edi + ebx], mm7      // write back updated value
+            movq mm1, mm7              // Now mm1 will be used as Raw(x-bpp)
+            // Do second set of 4 bytes
+            punpckhbw mm2, mm0         // Unpack Low bytes of b
+            punpcklbw mm1, mm0         // Unpack Low bytes of a
+            // pav = p - a = (a + b - c) - a = b - c
+            movq mm4, mm2
+            // pbv = p - b = (a + b - c) - b = a - c
+            movq mm5, mm1
+            psubw mm4, mm3
+            pxor mm7, mm7
+            // pcv = p - c = (a + b - c) -c = (a - c) + (b - c) = pav + pbv
+            movq mm6, mm4
+            psubw mm5, mm3
+            // pa = abs(p-a) = abs(pav)
+            // pb = abs(p-b) = abs(pbv)
+            // pc = abs(p-c) = abs(pcv)
+            pcmpgtw mm0, mm4       // Create mask pav bytes < 0
+            paddw mm6, mm5
+            pand mm0, mm4          // Only pav bytes < 0 in mm7
+            pcmpgtw mm7, mm5       // Create mask pbv bytes < 0
+            psubw mm4, mm0
+            pand mm7, mm5          // Only pbv bytes < 0 in mm0
+            psubw mm4, mm0
+            psubw mm5, mm7
+            pxor mm0, mm0
+            pcmpgtw mm0, mm6       // Create mask pcv bytes < 0
+            pand mm0, mm6          // Only pav bytes < 0 in mm7
+            psubw mm5, mm7
+            psubw mm6, mm0
+            //  test pa <= pb
+            movq mm7, mm4
+            psubw mm6, mm0
+            pcmpgtw mm7, mm5       // pa > pb?
+            movq mm0, mm7
+            // use mm7 mask to merge pa & pb
+            pand mm5, mm7
+            // use mm0 mask copy to merge a & b
+            pand mm2, mm0
+            pandn mm7, mm4
+            pandn mm0, mm1
+            paddw mm7, mm5
+            paddw mm0, mm2
+            //  test  ((pa <= pb)? pa:pb) <= pc
+            pcmpgtw mm7, mm6       // pab > pc?
+            pxor mm1, mm1
+            pand mm3, mm7
+            pandn mm7, mm0
+            pxor mm1, mm1
+            paddw mm7, mm3
+            pxor mm0, mm0
+            // Step ex to next set of 8 bytes and repeat loop til done
+            add ebx, 8
+            packuswb mm1, mm7
+            paddb mm1, [edi + ebx - 8]     // add Paeth predictor with Raw(x)
+            cmp ebx, MMXLength
+            movq [edi + ebx - 8], mm1      // write back updated value
+                                // mm1 will be used as Raw(x-bpp) next loop
+            jb dpth4lp
+         } // end _asm block
+      }
+      break;
+      case 8:                          // bpp == 8
+      {
+         ActiveMask.use  = 0x00000000ffffffff;
+         _asm {
+            mov ebx, diff
+            mov edi, row
+            mov esi, prev_row
+            pxor mm0, mm0
+            // PRIME the pump (load the first Raw(x-bpp) data set
+            movq mm1, [edi+ebx-8]      // Only time should need to read
+                                       //  a=Raw(x-bpp) bytes
+dpth8lp:
+            // Do first set of 4 bytes
+            movq mm3, [esi+ebx-8]      // read c=Prior(x-bpp) bytes
+            punpcklbw mm1, mm0         // Unpack Low bytes of a
+            movq mm2, [esi + ebx]      // load b=Prior(x)
+            punpcklbw mm2, mm0         // Unpack Low bytes of b
+            // pav = p - a = (a + b - c) - a = b - c
+            movq mm4, mm2
+            punpcklbw mm3, mm0         // Unpack Low bytes of c
+            // pbv = p - b = (a + b - c) - b = a - c
+            movq mm5, mm1
+            psubw mm4, mm3
+            pxor mm7, mm7
+            // pcv = p - c = (a + b - c) -c = (a - c) + (b - c) = pav + pbv
+            movq mm6, mm4
+            psubw mm5, mm3
+            // pa = abs(p-a) = abs(pav)
+            // pb = abs(p-b) = abs(pbv)
+            // pc = abs(p-c) = abs(pcv)
+            pcmpgtw mm0, mm4       // Create mask pav bytes < 0
+            paddw mm6, mm5
+            pand mm0, mm4          // Only pav bytes < 0 in mm7
+            pcmpgtw mm7, mm5       // Create mask pbv bytes < 0
+            psubw mm4, mm0
+            pand mm7, mm5          // Only pbv bytes < 0 in mm0
+            psubw mm4, mm0
+            psubw mm5, mm7
+            pxor mm0, mm0
+            pcmpgtw mm0, mm6       // Create mask pcv bytes < 0
+            pand mm0, mm6          // Only pav bytes < 0 in mm7
+            psubw mm5, mm7
+            psubw mm6, mm0
+            //  test pa <= pb
+            movq mm7, mm4
+            psubw mm6, mm0
+            pcmpgtw mm7, mm5       // pa > pb?
+            movq mm0, mm7
+            // use mm7 mask to merge pa & pb
+            pand mm5, mm7
+            // use mm0 mask copy to merge a & b
+            pand mm2, mm0
+            pandn mm7, mm4
+            pandn mm0, mm1
+            paddw mm7, mm5
+            paddw mm0, mm2
+            //  test  ((pa <= pb)? pa:pb) <= pc
+            pcmpgtw mm7, mm6       // pab > pc?
+            pxor mm1, mm1
+            pand mm3, mm7
+            pandn mm7, mm0
+            paddw mm7, mm3
+            pxor mm0, mm0
+            packuswb mm7, mm1
+            movq mm3, [esi+ebx-8]    // read c=Prior(x-bpp) bytes
+            pand mm7, ActiveMask
+            movq mm2, [esi + ebx]    // load b=Prior(x)
+            paddb mm7, [edi + ebx]   // add Paeth predictor with Raw(x)
+            punpckhbw mm3, mm0       // Unpack High bytes of c
+            movq [edi + ebx], mm7    // write back updated value
+            movq mm1, [edi+ebx-8]    // read a=Raw(x-bpp) bytes
+
+            // Do second set of 4 bytes
+            punpckhbw mm2, mm0       // Unpack High bytes of b
+            punpckhbw mm1, mm0       // Unpack High bytes of a
+            // pav = p - a = (a + b - c) - a = b - c
+            movq mm4, mm2
+            // pbv = p - b = (a + b - c) - b = a - c
+            movq mm5, mm1
+            psubw mm4, mm3
+            pxor mm7, mm7
+            // pcv = p - c = (a + b - c) -c = (a - c) + (b - c) = pav + pbv
+            movq mm6, mm4
+            psubw mm5, mm3
+            // pa = abs(p-a) = abs(pav)
+            // pb = abs(p-b) = abs(pbv)
+            // pc = abs(p-c) = abs(pcv)
+            pcmpgtw mm0, mm4       // Create mask pav bytes < 0
+            paddw mm6, mm5
+            pand mm0, mm4          // Only pav bytes < 0 in mm7
+            pcmpgtw mm7, mm5       // Create mask pbv bytes < 0
+            psubw mm4, mm0
+            pand mm7, mm5          // Only pbv bytes < 0 in mm0
+            psubw mm4, mm0
+            psubw mm5, mm7
+            pxor mm0, mm0
+            pcmpgtw mm0, mm6       // Create mask pcv bytes < 0
+            pand mm0, mm6          // Only pav bytes < 0 in mm7
+            psubw mm5, mm7
+            psubw mm6, mm0
+            //  test pa <= pb
+            movq mm7, mm4
+            psubw mm6, mm0
+            pcmpgtw mm7, mm5       // pa > pb?
+            movq mm0, mm7
+            // use mm7 mask to merge pa & pb
+            pand mm5, mm7
+            // use mm0 mask copy to merge a & b
+            pand mm2, mm0
+            pandn mm7, mm4
+            pandn mm0, mm1
+            paddw mm7, mm5
+            paddw mm0, mm2
+            //  test  ((pa <= pb)? pa:pb) <= pc
+            pcmpgtw mm7, mm6       // pab > pc?
+            pxor mm1, mm1
+            pand mm3, mm7
+            pandn mm7, mm0
+            pxor mm1, mm1
+            paddw mm7, mm3
+            pxor mm0, mm0
+            // Step ex to next set of 8 bytes and repeat loop til done
+            add ebx, 8
+            packuswb mm1, mm7
+            paddb mm1, [edi + ebx - 8]     // add Paeth predictor with Raw(x)
+            cmp ebx, MMXLength
+            movq [edi + ebx - 8], mm1      // write back updated value
+                            // mm1 will be used as Raw(x-bpp) next loop
+            jb dpth8lp
+         } // end _asm block
+      }
+      break;
+
+      case 1:                // bpp = 1
+      case 2:                // bpp = 2
+      default:               // bpp > 8
+      {
+         _asm {
+            mov ebx, diff
+            cmp ebx, FullLength
+            jnb dpthdend
+            mov edi, row
+            mov esi, prev_row
+            // Do Paeth decode for remaining bytes
+            mov edx, ebx
+            xor ecx, ecx        // zero ecx before using cl & cx in loop below
+            sub edx, bpp        // Set edx = ebx - bpp
+dpthdlp:
+            xor eax, eax
+            // pav = p - a = (a + b - c) - a = b - c
+            mov al, [esi + ebx]        // load Prior(x) into al
+            mov cl, [esi + edx]        // load Prior(x-bpp) into cl
+            sub eax, ecx                 // subtract Prior(x-bpp)
+            mov patemp, eax                 // Save pav for later use
+            xor eax, eax
+            // pbv = p - b = (a + b - c) - b = a - c
+            mov al, [edi + edx]        // load Raw(x-bpp) into al
+            sub eax, ecx                 // subtract Prior(x-bpp)
+            mov ecx, eax
+            // pcv = p - c = (a + b - c) -c = (a - c) + (b - c) = pav + pbv
+            add eax, patemp                 // pcv = pav + pbv
+            // pc = abs(pcv)
+            test eax, 0x80000000
+            jz dpthdpca
+            neg eax                     // reverse sign of neg values
+dpthdpca:
+            mov pctemp, eax             // save pc for later use
+            // pb = abs(pbv)
+            test ecx, 0x80000000
+            jz dpthdpba
+            neg ecx                     // reverse sign of neg values
+dpthdpba:
+            mov pbtemp, ecx             // save pb for later use
+            // pa = abs(pav)
+            mov eax, patemp
+            test eax, 0x80000000
+            jz dpthdpaa
+            neg eax                     // reverse sign of neg values
+dpthdpaa:
+            mov patemp, eax             // save pa for later use
+            // test if pa <= pb
+            cmp eax, ecx
+            jna dpthdabb
+            // pa > pb; now test if pb <= pc
+            cmp ecx, pctemp
+            jna dpthdbbc
+            // pb > pc; Raw(x) = Paeth(x) + Prior(x-bpp)
+            mov cl, [esi + edx]  // load Prior(x-bpp) into cl
+            jmp dpthdpaeth
+dpthdbbc:
+            // pb <= pc; Raw(x) = Paeth(x) + Prior(x)
+            mov cl, [esi + ebx]        // load Prior(x) into cl
+            jmp dpthdpaeth
+dpthdabb:
+            // pa <= pb; now test if pa <= pc
+            cmp eax, pctemp
+            jna dpthdabc
+            // pa > pc; Raw(x) = Paeth(x) + Prior(x-bpp)
+            mov cl, [esi + edx]  // load Prior(x-bpp) into cl
+            jmp dpthdpaeth
+dpthdabc:
+            // pa <= pc; Raw(x) = Paeth(x) + Raw(x-bpp)
+            mov cl, [edi + edx]  // load Raw(x-bpp) into cl
+dpthdpaeth:
+            inc ebx
+            inc edx
+            // Raw(x) = (Paeth(x) + Paeth_Predictor( a, b, c )) mod 256
+            add [edi + ebx - 1], cl
+            cmp ebx, FullLength
+            jb dpthdlp
+dpthdend:
+         } // end _asm block
+      }
+      return;                   // No need to go further with this one
+   }                         // end switch ( bpp )
+   _asm
+   {
+         // MMX acceleration complete now do clean-up
+         // Check if any remaining bytes left to decode
+         mov ebx, MMXLength
+         cmp ebx, FullLength
+         jnb dpthend
+         mov edi, row
+         mov esi, prev_row
+         // Do Paeth decode for remaining bytes
+         mov edx, ebx
+         xor ecx, ecx         // zero ecx before using cl & cx in loop below
+         sub edx, bpp         // Set edx = ebx - bpp
+dpthlp2:
+         xor eax, eax
+         // pav = p - a = (a + b - c) - a = b - c
+         mov al, [esi + ebx]  // load Prior(x) into al
+         mov cl, [esi + edx]  // load Prior(x-bpp) into cl
+         sub eax, ecx         // subtract Prior(x-bpp)
+         mov patemp, eax      // Save pav for later use
+         xor eax, eax
+         // pbv = p - b = (a + b - c) - b = a - c
+         mov al, [edi + edx]  // load Raw(x-bpp) into al
+         sub eax, ecx         // subtract Prior(x-bpp)
+         mov ecx, eax
+         // pcv = p - c = (a + b - c) -c = (a - c) + (b - c) = pav + pbv
+         add eax, patemp      // pcv = pav + pbv
+         // pc = abs(pcv)
+         test eax, 0x80000000
+         jz dpthpca2
+         neg eax              // reverse sign of neg values
+dpthpca2:
+         mov pctemp, eax      // save pc for later use
+         // pb = abs(pbv)
+         test ecx, 0x80000000
+         jz dpthpba2
+         neg ecx              // reverse sign of neg values
+dpthpba2:
+         mov pbtemp, ecx      // save pb for later use
+         // pa = abs(pav)
+         mov eax, patemp
+         test eax, 0x80000000
+         jz dpthpaa2
+         neg eax              // reverse sign of neg values
+dpthpaa2:
+         mov patemp, eax      // save pa for later use
+         // test if pa <= pb
+         cmp eax, ecx
+         jna dpthabb2
+         // pa > pb; now test if pb <= pc
+         cmp ecx, pctemp
+         jna dpthbbc2
+         // pb > pc; Raw(x) = Paeth(x) + Prior(x-bpp)
+         mov cl, [esi + edx]  // load Prior(x-bpp) into cl
+         jmp dpthpaeth2
+dpthbbc2:
+         // pb <= pc; Raw(x) = Paeth(x) + Prior(x)
+         mov cl, [esi + ebx]        // load Prior(x) into cl
+         jmp dpthpaeth2
+dpthabb2:
+         // pa <= pb; now test if pa <= pc
+         cmp eax, pctemp
+         jna dpthabc2
+         // pa > pc; Raw(x) = Paeth(x) + Prior(x-bpp)
+         mov cl, [esi + edx]  // load Prior(x-bpp) into cl
+         jmp dpthpaeth2
+dpthabc2:
+         // pa <= pc; Raw(x) = Paeth(x) + Raw(x-bpp)
+         mov cl, [edi + edx]  // load Raw(x-bpp) into cl
+dpthpaeth2:
+         inc ebx
+         inc edx
+         // Raw(x) = (Paeth(x) + Paeth_Predictor( a, b, c )) mod 256
+         add [edi + ebx - 1], cl
+         cmp ebx, FullLength
+         jb dpthlp2
+dpthend:
+         emms             // End MMX instructions; prep for possible FP instrs.
+   } // end _asm block
+}
+
+// Optimized code for PNG Sub filter decoder
+void /* PRIVATE */
+png_read_filter_row_mmx_sub(png_row_infop row_info, png_bytep row)
+{
+   //int test;
+   int bpp;
+   png_uint_32 FullLength;
+   png_uint_32 MMXLength;
+   int diff;
+
+   bpp = (row_info->pixel_depth + 7) >> 3; // Get # bytes per pixel
+   FullLength  = row_info->rowbytes - bpp; // # of bytes to filter
+   _asm {
+        mov edi, row
+        mov esi, edi               // lp = row
+        add edi, bpp               // rp = row + bpp
+        xor eax, eax
+        // get # of bytes to alignment
+        mov diff, edi               // take start of row
+        add diff, 0xf               // add 7 + 8 to incr past
+                                        // alignment boundary
+        xor ebx, ebx
+        and diff, 0xfffffff8        // mask to alignment boundary
+        sub diff, edi               // subtract from start ==> value
+                                        //  ebx at alignment
+        jz dsubgo
+        // fix alignment
+dsublp1:
+        mov al, [esi+ebx]
+        add [edi+ebx], al
+        inc ebx
+        cmp ebx, diff
+        jb dsublp1
+dsubgo:
+        mov ecx, FullLength
+        mov edx, ecx
+        sub edx, ebx                  // subtract alignment fix
+        and edx, 0x00000007           // calc bytes over mult of 8
+        sub ecx, edx                  // drop over bytes from length
+        mov MMXLength, ecx
+   } // end _asm block
+
+   // Now do the math for the rest of the row
+   switch ( bpp )
+   {
+        case 3:
+        {
+         ActiveMask.use  = 0x0000ffffff000000;
+         ShiftBpp.use = 24;       // == 3 * 8
+         ShiftRem.use  = 40;      // == 64 - 24
+         _asm {
+            mov edi, row
+            movq mm7, ActiveMask  // Load ActiveMask for 2nd active byte group
+            mov esi, edi              // lp = row
+            add edi, bpp          // rp = row + bpp
+            movq mm6, mm7
+            mov ebx, diff
+            psllq mm6, ShiftBpp   // Move mask in mm6 to cover 3rd active
+                                  // byte group
+            // PRIME the pump (load the first Raw(x-bpp) data set
+            movq mm1, [edi+ebx-8]
+dsub3lp:
+            psrlq mm1, ShiftRem   // Shift data for adding 1st bpp bytes
+                          // no need for mask; shift clears inactive bytes
+            // Add 1st active group
+            movq mm0, [edi+ebx]
+            paddb mm0, mm1
+            // Add 2nd active group
+            movq mm1, mm0         // mov updated Raws to mm1
+            psllq mm1, ShiftBpp   // shift data to position correctly
+            pand mm1, mm7         // mask to use only 2nd active group
+            paddb mm0, mm1
+            // Add 3rd active group
+            movq mm1, mm0         // mov updated Raws to mm1
+            psllq mm1, ShiftBpp   // shift data to position correctly
+            pand mm1, mm6         // mask to use only 3rd active group
+            add ebx, 8
+            paddb mm0, mm1
+            cmp ebx, MMXLength
+            movq [edi+ebx-8], mm0     // Write updated Raws back to array
+            // Prep for doing 1st add at top of loop
+            movq mm1, mm0
+            jb dsub3lp
+         } // end _asm block
+      }
+      break;
+
+      case 1:
+      {
+         // Placed here just in case this is a duplicate of the
+         // non-MMX code for the SUB filter in png_read_filter_row below
+         //
+         //         png_bytep rp;
+         //         png_bytep lp;
+         //         png_uint_32 i;
+         //         bpp = (row_info->pixel_depth + 7) >> 3;
+         //         for (i = (png_uint_32)bpp, rp = row + bpp, lp = row;
+         //            i < row_info->rowbytes; i++, rp++, lp++)
+         //      {
+         //            *rp = (png_byte)(((int)(*rp) + (int)(*lp)) & 0xff);
+         //      }
+         _asm {
+            mov ebx, diff
+            mov edi, row
+            cmp ebx, FullLength
+            jnb dsub1end
+            mov esi, edi          // lp = row
+            xor eax, eax
+            add edi, bpp      // rp = row + bpp
+dsub1lp:
+            mov al, [esi+ebx]
+            add [edi+ebx], al
+            inc ebx
+            cmp ebx, FullLength
+            jb dsub1lp
+dsub1end:
+         } // end _asm block
+      }
+      return;
+
+      case 6:
+      case 7:
+      case 4:
+      case 5:
+      {
+         ShiftBpp.use = bpp << 3;
+         ShiftRem.use = 64 - ShiftBpp.use;
+         _asm {
+            mov edi, row
+            mov ebx, diff
+            mov esi, edi               // lp = row
+            add edi, bpp           // rp = row + bpp
+            // PRIME the pump (load the first Raw(x-bpp) data set
+            movq mm1, [edi+ebx-8]
+dsub4lp:
+            psrlq mm1, ShiftRem // Shift data for adding 1st bpp bytes
+                          // no need for mask; shift clears inactive bytes
+            movq mm0, [edi+ebx]
+            paddb mm0, mm1
+            // Add 2nd active group
+            movq mm1, mm0          // mov updated Raws to mm1
+            psllq mm1, ShiftBpp    // shift data to position correctly
+                                   // there is no need for any mask
+                                   // since shift clears inactive bits/bytes
+            add ebx, 8
+            paddb mm0, mm1
+            cmp ebx, MMXLength
+            movq [edi+ebx-8], mm0
+            movq mm1, mm0          // Prep for doing 1st add at top of loop
+            jb dsub4lp
+         } // end _asm block
+      }
+      break;
+
+      case 2:
+      {
+         ActiveMask.use  = 0x00000000ffff0000;
+         ShiftBpp.use = 16;       // == 2 * 8
+         ShiftRem.use = 48;       // == 64 - 16
+         _asm {
+            movq mm7, ActiveMask  // Load ActiveMask for 2nd active byte group
+            mov ebx, diff
+            movq mm6, mm7
+            mov edi, row
+            psllq mm6, ShiftBpp     // Move mask in mm6 to cover 3rd active
+                                    //  byte group
+            mov esi, edi            // lp = row
+            movq mm5, mm6
+            add edi, bpp            // rp = row + bpp
+            psllq mm5, ShiftBpp     // Move mask in mm5 to cover 4th active
+                                    //  byte group
+            // PRIME the pump (load the first Raw(x-bpp) data set
+            movq mm1, [edi+ebx-8]
+dsub2lp:
+            // Add 1st active group
+            psrlq mm1, ShiftRem     // Shift data for adding 1st bpp bytes
+                                    // no need for mask; shift clears inactive
+                                    //  bytes
+            movq mm0, [edi+ebx]
+            paddb mm0, mm1
+            // Add 2nd active group
+            movq mm1, mm0           // mov updated Raws to mm1
+            psllq mm1, ShiftBpp     // shift data to position correctly
+            pand mm1, mm7           // mask to use only 2nd active group
+            paddb mm0, mm1
+            // Add 3rd active group
+            movq mm1, mm0           // mov updated Raws to mm1
+            psllq mm1, ShiftBpp     // shift data to position correctly
+            pand mm1, mm6           // mask to use only 3rd active group
+            paddb mm0, mm1
+            // Add 4th active group
+            movq mm1, mm0           // mov updated Raws to mm1
+            psllq mm1, ShiftBpp     // shift data to position correctly
+            pand mm1, mm5           // mask to use only 4th active group
+            add ebx, 8
+            paddb mm0, mm1
+            cmp ebx, MMXLength
+            movq [edi+ebx-8], mm0   // Write updated Raws back to array
+            movq mm1, mm0           // Prep for doing 1st add at top of loop
+            jb dsub2lp
+         } // end _asm block
+      }
+      break;
+      case 8:
+      {
+         _asm {
+            mov edi, row
+            mov ebx, diff
+            mov esi, edi            // lp = row
+            add edi, bpp            // rp = row + bpp
+            mov ecx, MMXLength
+            movq mm7, [edi+ebx-8]   // PRIME the pump (load the first
+                                    // Raw(x-bpp) data set
+            and ecx, 0x0000003f     // calc bytes over mult of 64
+dsub8lp:
+            movq mm0, [edi+ebx]     // Load Sub(x) for 1st 8 bytes
+            paddb mm0, mm7
+            movq mm1, [edi+ebx+8]   // Load Sub(x) for 2nd 8 bytes
+            movq [edi+ebx], mm0    // Write Raw(x) for 1st 8 bytes
+                                   // Now mm0 will be used as Raw(x-bpp) for
+                                   // the 2nd group of 8 bytes.  This will be
+                                   // repeated for each group of 8 bytes with
+                                   // the 8th group being used as the Raw(x-bpp)
+                                   // for the 1st group of the next loop.
+            paddb mm1, mm0
+            movq mm2, [edi+ebx+16]  // Load Sub(x) for 3rd 8 bytes
+            movq [edi+ebx+8], mm1   // Write Raw(x) for 2nd 8 bytes
+            paddb mm2, mm1
+            movq mm3, [edi+ebx+24]  // Load Sub(x) for 4th 8 bytes
+            movq [edi+ebx+16], mm2  // Write Raw(x) for 3rd 8 bytes
+            paddb mm3, mm2
+            movq mm4, [edi+ebx+32]  // Load Sub(x) for 5th 8 bytes
+            movq [edi+ebx+24], mm3  // Write Raw(x) for 4th 8 bytes
+            paddb mm4, mm3
+            movq mm5, [edi+ebx+40]  // Load Sub(x) for 6th 8 bytes
+            movq [edi+ebx+32], mm4  // Write Raw(x) for 5th 8 bytes
+            paddb mm5, mm4
+            movq mm6, [edi+ebx+48]  // Load Sub(x) for 7th 8 bytes
+            movq [edi+ebx+40], mm5  // Write Raw(x) for 6th 8 bytes
+            paddb mm6, mm5
+            movq mm7, [edi+ebx+56]  // Load Sub(x) for 8th 8 bytes
+            movq [edi+ebx+48], mm6  // Write Raw(x) for 7th 8 bytes
+            add ebx, 64
+            paddb mm7, mm6
+            cmp ebx, ecx
+            movq [edi+ebx-8], mm7   // Write Raw(x) for 8th 8 bytes
+            jb dsub8lp
+            cmp ebx, MMXLength
+            jnb dsub8lt8
+dsub8lpA:
+            movq mm0, [edi+ebx]
+            add ebx, 8
+            paddb mm0, mm7
+            cmp ebx, MMXLength
+            movq [edi+ebx-8], mm0   // use -8 to offset early add to ebx
+            movq mm7, mm0           // Move calculated Raw(x) data to mm1 to
+                                    // be the new Raw(x-bpp) for the next loop
+            jb dsub8lpA
+dsub8lt8:
+         } // end _asm block
+      }
+      break;
+
+      default:                // bpp greater than 8 bytes
+      {
+         _asm {
+            mov ebx, diff
+            mov edi, row
+            mov esi, edi           // lp = row
+            add edi, bpp           // rp = row + bpp
+dsubAlp:
+            movq mm0, [edi+ebx]
+            movq mm1, [esi+ebx]
+            add ebx, 8
+            paddb mm0, mm1
+            cmp ebx, MMXLength
+            movq [edi+ebx-8], mm0  // mov does not affect flags; -8 to offset
+                                   //  add ebx
+            jb dsubAlp
+         } // end _asm block
+      }
+      break;
+
+   } // end switch ( bpp )
+
+   _asm {
+        mov ebx, MMXLength
+        mov edi, row
+        cmp ebx, FullLength
+        jnb dsubend
+        mov esi, edi               // lp = row
+        xor eax, eax
+        add edi, bpp               // rp = row + bpp
+dsublp2:
+        mov al, [esi+ebx]
+        add [edi+ebx], al
+        inc ebx
+        cmp ebx, FullLength
+        jb dsublp2
+dsubend:
+        emms             // End MMX instructions; prep for possible FP instrs.
+   } // end _asm block
+}
+
+// Optimized code for PNG Up filter decoder
+void /* PRIVATE */
+png_read_filter_row_mmx_up(png_row_infop row_info, png_bytep row,
+   png_bytep prev_row)
+{
+   png_uint_32 len;
+   len  = row_info->rowbytes;       // # of bytes to filter
+   _asm {
+      mov edi, row
+      // get # of bytes to alignment
+      mov ecx, edi
+      xor ebx, ebx
+      add ecx, 0x7
+      xor eax, eax
+      and ecx, 0xfffffff8
+      mov esi, prev_row
+      sub ecx, edi
+      jz dupgo
+      // fix alignment
+duplp1:
+      mov al, [edi+ebx]
+      add al, [esi+ebx]
+      inc ebx
+      cmp ebx, ecx
+      mov [edi + ebx-1], al  // mov does not affect flags; -1 to offset inc ebx
+      jb duplp1
+dupgo:
+      mov ecx, len
+      mov edx, ecx
+      sub edx, ebx                  // subtract alignment fix
+      and edx, 0x0000003f           // calc bytes over mult of 64
+      sub ecx, edx                  // drop over bytes from length
+      // Unrolled loop - use all MMX registers and interleave to reduce
+      // number of branch instructions (loops) and reduce partial stalls
+duploop:
+      movq mm1, [esi+ebx]
+      movq mm0, [edi+ebx]
+      movq mm3, [esi+ebx+8]
+      paddb mm0, mm1
+      movq mm2, [edi+ebx+8]
+      movq [edi+ebx], mm0
+      paddb mm2, mm3
+      movq mm5, [esi+ebx+16]
+      movq [edi+ebx+8], mm2
+      movq mm4, [edi+ebx+16]
+      movq mm7, [esi+ebx+24]
+      paddb mm4, mm5
+      movq mm6, [edi+ebx+24]
+      movq [edi+ebx+16], mm4
+      paddb mm6, mm7
+      movq mm1, [esi+ebx+32]
+      movq [edi+ebx+24], mm6
+      movq mm0, [edi+ebx+32]
+      movq mm3, [esi+ebx+40]
+      paddb mm0, mm1
+      movq mm2, [edi+ebx+40]
+      movq [edi+ebx+32], mm0
+      paddb mm2, mm3
+      movq mm5, [esi+ebx+48]
+      movq [edi+ebx+40], mm2
+      movq mm4, [edi+ebx+48]
+      movq mm7, [esi+ebx+56]
+      paddb mm4, mm5
+      movq mm6, [edi+ebx+56]
+      movq [edi+ebx+48], mm4
+      add ebx, 64
+      paddb mm6, mm7
+      cmp ebx, ecx
+      movq [edi+ebx-8], mm6 // (+56)movq does not affect flags;
+                                     // -8 to offset add ebx
+      jb duploop
+
+      cmp edx, 0                     // Test for bytes over mult of 64
+      jz dupend
+
+
+      // 2 lines added by lcreeve@netins.net
+      // (mail 11 Jul 98 in png-implement list)
+      cmp edx, 8 //test for less than 8 bytes
+      jb duplt8
+
+
+      add ecx, edx
+      and edx, 0x00000007           // calc bytes over mult of 8
+      sub ecx, edx                  // drop over bytes from length
+      jz duplt8
+      // Loop using MMX registers mm0 & mm1 to update 8 bytes simultaneously
+duplpA:
+      movq mm1, [esi+ebx]
+      movq mm0, [edi+ebx]
+      add ebx, 8
+      paddb mm0, mm1
+      cmp ebx, ecx
+      movq [edi+ebx-8], mm0 // movq does not affect flags; -8 to offset add ebx
+      jb duplpA
+      cmp edx, 0            // Test for bytes over mult of 8
+      jz dupend
+duplt8:
+      xor eax, eax
+      add ecx, edx          // move over byte count into counter
+      // Loop using x86 registers to update remaining bytes
+duplp2:
+      mov al, [edi + ebx]
+      add al, [esi + ebx]
+      inc ebx
+      cmp ebx, ecx
+      mov [edi + ebx-1], al // mov does not affect flags; -1 to offset inc ebx
+      jb duplp2
+dupend:
+      // Conversion of filtered row completed
+      emms          // End MMX instructions; prep for possible FP instrs.
+   } // end _asm block
+}
+
+
+// Optimized png_read_filter_row routines
+void /* PRIVATE */
+png_read_filter_row(png_structp png_ptr, png_row_infop row_info, png_bytep
+   row, png_bytep prev_row, int filter)
+{
+#ifdef PNG_DEBUG
+   char filnm[10];
+#endif
+
+   if (mmx_supported == 2) {
+       /* this should have happened in png_init_mmx_flags() already */
+       png_warning(png_ptr, "asm_flags may not have been initialized");
+       png_mmx_support();
+   }
+
+#ifdef PNG_DEBUG
+   png_debug(1, "in png_read_filter_row\n");
+   switch (filter)
+   {
+      case 0: sprintf(filnm, "none");
+         break;
+      case 1: sprintf(filnm, "sub-%s",
+        (png_ptr->asm_flags & PNG_ASM_FLAG_MMX_READ_FILTER_SUB)? "MMX" : "x86");
+         break;
+      case 2: sprintf(filnm, "up-%s",
+        (png_ptr->asm_flags & PNG_ASM_FLAG_MMX_READ_FILTER_UP)? "MMX" : "x86");
+         break;
+      case 3: sprintf(filnm, "avg-%s",
+        (png_ptr->asm_flags & PNG_ASM_FLAG_MMX_READ_FILTER_AVG)? "MMX" : "x86");
+         break;
+      case 4: sprintf(filnm, "Paeth-%s",
+        (png_ptr->asm_flags & PNG_ASM_FLAG_MMX_READ_FILTER_PAETH)? "MMX":"x86");
+         break;
+      default: sprintf(filnm, "unknw");
+         break;
+   }
+   png_debug2(0,"row=%5d, %s, ", png_ptr->row_number, filnm);
+   png_debug2(0, "pd=%2d, b=%d, ", (int)row_info->pixel_depth,
+      (int)((row_info->pixel_depth + 7) >> 3));
+   png_debug1(0,"len=%8d, ", row_info->rowbytes);
+#endif /* PNG_DEBUG */
+
+   switch (filter)
+   {
+      case PNG_FILTER_VALUE_NONE:
+         break;
+
+      case PNG_FILTER_VALUE_SUB:
+      {
+         if ((png_ptr->asm_flags & PNG_ASM_FLAG_MMX_READ_FILTER_SUB) &&
+             (row_info->pixel_depth >= png_ptr->mmx_bitdepth_threshold) &&
+             (row_info->rowbytes >= png_ptr->mmx_rowbytes_threshold))
+         {
+            png_read_filter_row_mmx_sub(row_info, row);
+         }
+         else
+         {
+            png_uint_32 i;
+            png_uint_32 istop = row_info->rowbytes;
+            png_uint_32 bpp = (row_info->pixel_depth + 7) >> 3;
+            png_bytep rp = row + bpp;
+            png_bytep lp = row;
+
+            for (i = bpp; i < istop; i++)
+            {
+               *rp = (png_byte)(((int)(*rp) + (int)(*lp++)) & 0xff);
+               rp++;
+            }
+         }
+         break;
+      }
+
+      case PNG_FILTER_VALUE_UP:
+      {
+         if ((png_ptr->asm_flags & PNG_ASM_FLAG_MMX_READ_FILTER_UP) &&
+             (row_info->pixel_depth >= png_ptr->mmx_bitdepth_threshold) &&
+             (row_info->rowbytes >= png_ptr->mmx_rowbytes_threshold))
+         {
+            png_read_filter_row_mmx_up(row_info, row, prev_row);
+         }
+         else
+         {
+            png_uint_32 i;
+            png_uint_32 istop = row_info->rowbytes;
+            png_bytep rp = row;
+            png_bytep pp = prev_row;
+
+            for (i = 0; i < istop; ++i)
+            {
+               *rp = (png_byte)(((int)(*rp) + (int)(*pp++)) & 0xff);
+               rp++;
+            }
+         }
+         break;
+      }
+
+      case PNG_FILTER_VALUE_AVG:
+      {
+         if ((png_ptr->asm_flags & PNG_ASM_FLAG_MMX_READ_FILTER_AVG) &&
+             (row_info->pixel_depth >= png_ptr->mmx_bitdepth_threshold) &&
+             (row_info->rowbytes >= png_ptr->mmx_rowbytes_threshold))
+         {
+            png_read_filter_row_mmx_avg(row_info, row, prev_row);
+         }
+         else
+         {
+            png_uint_32 i;
+            png_bytep rp = row;
+            png_bytep pp = prev_row;
+            png_bytep lp = row;
+            png_uint_32 bpp = (row_info->pixel_depth + 7) >> 3;
+            png_uint_32 istop = row_info->rowbytes - bpp;
+
+            for (i = 0; i < bpp; i++)
+            {
+               *rp = (png_byte)(((int)(*rp) +
+                  ((int)(*pp++) >> 1)) & 0xff);
+               rp++;
+            }
+
+            for (i = 0; i < istop; i++)
+            {
+               *rp = (png_byte)(((int)(*rp) +
+                  ((int)(*pp++ + *lp++) >> 1)) & 0xff);
+               rp++;
+            }
+         }
+         break;
+      }
+
+      case PNG_FILTER_VALUE_PAETH:
+      {
+         if ((png_ptr->asm_flags & PNG_ASM_FLAG_MMX_READ_FILTER_PAETH) &&
+             (row_info->pixel_depth >= png_ptr->mmx_bitdepth_threshold) &&
+             (row_info->rowbytes >= png_ptr->mmx_rowbytes_threshold))
+         {
+            png_read_filter_row_mmx_paeth(row_info, row, prev_row);
+         }
+         else
+         {
+            png_uint_32 i;
+            png_bytep rp = row;
+            png_bytep pp = prev_row;
+            png_bytep lp = row;
+            png_bytep cp = prev_row;
+            png_uint_32 bpp = (row_info->pixel_depth + 7) >> 3;
+            png_uint_32 istop=row_info->rowbytes - bpp;
+
+            for (i = 0; i < bpp; i++)
+            {
+               *rp = (png_byte)(((int)(*rp) + (int)(*pp++)) & 0xff);
+               rp++;
+            }
+
+            for (i = 0; i < istop; i++)   // use leftover rp,pp
+            {
+               int a, b, c, pa, pb, pc, p;
+
+               a = *lp++;
+               b = *pp++;
+               c = *cp++;
+
+               p = b - c;
+               pc = a - c;
+
+#ifdef PNG_USE_ABS
+               pa = abs(p);
+               pb = abs(pc);
+               pc = abs(p + pc);
+#else
+               pa = p < 0 ? -p : p;
+               pb = pc < 0 ? -pc : pc;
+               pc = (p + pc) < 0 ? -(p + pc) : p + pc;
+#endif
+
+               /*
+                  if (pa <= pb && pa <= pc)
+                     p = a;
+                  else if (pb <= pc)
+                     p = b;
+                  else
+                     p = c;
+                */
+
+               p = (pa <= pb && pa <=pc) ? a : (pb <= pc) ? b : c;
+
+               *rp = (png_byte)(((int)(*rp) + p) & 0xff);
+               rp++;
+            }
+         }
+         break;
+      }
+
+      default:
+         png_warning(png_ptr, "Ignoring bad row filter type");
+         *row=0;
+         break;
+   }
+}
+
+#endif /* PNG_ASSEMBLER_CODE_SUPPORTED && PNG_USE_PNGVCRD */
diff --git a/collects/plot/src/all/pngwio.c b/collects/plot/src/all/pngwio.c
new file mode 100644
index 0000000000..b39b4145f0
--- /dev/null
+++ b/collects/plot/src/all/pngwio.c
@@ -0,0 +1,228 @@
+
+/* pngwio.c - functions for data output
+ *
+ * libpng 1.2.5 - October 3, 2002
+ * For conditions of distribution and use, see copyright notice in png.h
+ * Copyright (c) 1998-2002 Glenn Randers-Pehrson
+ * (Version 0.96 Copyright (c) 1996, 1997 Andreas Dilger)
+ * (Version 0.88 Copyright (c) 1995, 1996 Guy Eric Schalnat, Group 42, Inc.)
+ *
+ * This file provides a location for all output.  Users who need
+ * special handling are expected to write functions that have the same
+ * arguments as these and perform similar functions, but that possibly
+ * use different output methods.  Note that you shouldn't change these
+ * functions, but rather write replacement functions and then change
+ * them at run time with png_set_write_fn(...).
+ */
+
+#define PNG_INTERNAL
+#include "png.h"
+#ifdef PNG_WRITE_SUPPORTED
+
+/* Write the data to whatever output you are using.  The default routine
+   writes to a file pointer.  Note that this routine sometimes gets called
+   with very small lengths, so you should implement some kind of simple
+   buffering if you are using unbuffered writes.  This should never be asked
+   to write more than 64K on a 16 bit machine.  */
+
+void /* PRIVATE */
+png_write_data(png_structp png_ptr, png_bytep data, png_size_t length)
+{
+   if (png_ptr->write_data_fn != NULL )
+      (*(png_ptr->write_data_fn))(png_ptr, data, length);
+   else
+      png_error(png_ptr, "Call to NULL write function");
+}
+
+#if !defined(PNG_NO_STDIO)
+/* This is the function that does the actual writing of data.  If you are
+   not writing to a standard C stream, you should create a replacement
+   write_data function and use it at run time with png_set_write_fn(), rather
+   than changing the library. */
+#ifndef USE_FAR_KEYWORD
+void PNGAPI
+png_default_write_data(png_structp png_ptr, png_bytep data, png_size_t length)
+{
+   png_uint_32 check;
+
+#if defined(_WIN32_WCE)
+   if ( !WriteFile((HANDLE)(png_ptr->io_ptr), data, length, &check, NULL) )
+      check = 0;
+#else
+   check = fwrite(data, 1, length, (png_FILE_p)(png_ptr->io_ptr));
+#endif
+   if (check != length)
+      png_error(png_ptr, "Write Error");
+}
+#else
+/* this is the model-independent version. Since the standard I/O library
+   can't handle far buffers in the medium and small models, we have to copy
+   the data.
+*/
+
+#define NEAR_BUF_SIZE 1024
+#define MIN(a,b) (a <= b ? a : b)
+
+void PNGAPI
+png_default_write_data(png_structp png_ptr, png_bytep data, png_size_t length)
+{
+   png_uint_32 check;
+   png_byte *near_data;  /* Needs to be "png_byte *" instead of "png_bytep" */
+   png_FILE_p io_ptr;
+
+   /* Check if data really is near. If so, use usual code. */
+   near_data = (png_byte *)CVT_PTR_NOCHECK(data);
+   io_ptr = (png_FILE_p)CVT_PTR(png_ptr->io_ptr);
+   if ((png_bytep)near_data == data)
+   {
+#if defined(_WIN32_WCE)
+      if ( !WriteFile(io_ptr, near_data, length, &check, NULL) )
+         check = 0;
+#else
+      check = fwrite(near_data, 1, length, io_ptr);
+#endif
+   }
+   else
+   {
+      png_byte buf[NEAR_BUF_SIZE];
+      png_size_t written, remaining, err;
+      check = 0;
+      remaining = length;
+      do
+      {
+         written = MIN(NEAR_BUF_SIZE, remaining);
+         png_memcpy(buf, data, written); /* copy far buffer to near buffer */
+#if defined(_WIN32_WCE)
+         if ( !WriteFile(io_ptr, buf, written, &err, NULL) )
+            err = 0;
+#else
+         err = fwrite(buf, 1, written, io_ptr);
+#endif
+         if (err != written)
+            break;
+         else
+            check += err;
+         data += written;
+         remaining -= written;
+      }
+      while (remaining != 0);
+   }
+   if (check != length)
+      png_error(png_ptr, "Write Error");
+}
+
+#endif
+#endif
+
+/* This function is called to output any data pending writing (normally
+   to disk).  After png_flush is called, there should be no data pending
+   writing in any buffers. */
+#if defined(PNG_WRITE_FLUSH_SUPPORTED)
+void /* PRIVATE */
+png_flush(png_structp png_ptr)
+{
+   if (png_ptr->output_flush_fn != NULL)
+      (*(png_ptr->output_flush_fn))(png_ptr);
+}
+
+#if !defined(PNG_NO_STDIO)
+void PNGAPI
+png_default_flush(png_structp png_ptr)
+{
+#if !defined(_WIN32_WCE)
+   png_FILE_p io_ptr;
+   io_ptr = (png_FILE_p)CVT_PTR((png_ptr->io_ptr));
+   if (io_ptr != NULL)
+      fflush(io_ptr);
+#endif
+}
+#endif
+#endif
+
+/* This function allows the application to supply new output functions for
+   libpng if standard C streams aren't being used.
+
+   This function takes as its arguments:
+   png_ptr       - pointer to a png output data structure
+   io_ptr        - pointer to user supplied structure containing info about
+                   the output functions.  May be NULL.
+   write_data_fn - pointer to a new output function that takes as its
+                   arguments a pointer to a png_struct, a pointer to
+                   data to be written, and a 32-bit unsigned int that is
+                   the number of bytes to be written.  The new write
+                   function should call png_error(png_ptr, "Error msg")
+                   to exit and output any fatal error messages.
+   flush_data_fn - pointer to a new flush function that takes as its
+                   arguments a pointer to a png_struct.  After a call to
+                   the flush function, there should be no data in any buffers
+                   or pending transmission.  If the output method doesn't do
+                   any buffering of ouput, a function prototype must still be
+                   supplied although it doesn't have to do anything.  If
+                   PNG_WRITE_FLUSH_SUPPORTED is not defined at libpng compile
+                   time, output_flush_fn will be ignored, although it must be
+                   supplied for compatibility. */
+void PNGAPI
+png_set_write_fn(png_structp png_ptr, png_voidp io_ptr,
+   png_rw_ptr write_data_fn, png_flush_ptr output_flush_fn)
+{
+   png_ptr->io_ptr = io_ptr;
+
+#if !defined(PNG_NO_STDIO)
+   if (write_data_fn != NULL)
+      png_ptr->write_data_fn = write_data_fn;
+   else
+      png_ptr->write_data_fn = png_default_write_data;
+#else
+   png_ptr->write_data_fn = write_data_fn;
+#endif
+
+#if defined(PNG_WRITE_FLUSH_SUPPORTED)
+#if !defined(PNG_NO_STDIO)
+   if (output_flush_fn != NULL)
+      png_ptr->output_flush_fn = output_flush_fn;
+   else
+      png_ptr->output_flush_fn = png_default_flush;
+#else
+   png_ptr->output_flush_fn = output_flush_fn;
+#endif
+#endif /* PNG_WRITE_FLUSH_SUPPORTED */
+
+   /* It is an error to read while writing a png file */
+   if (png_ptr->read_data_fn != NULL)
+   {
+      png_ptr->read_data_fn = NULL;
+      png_warning(png_ptr,
+         "Attempted to set both read_data_fn and write_data_fn in");
+      png_warning(png_ptr,
+         "the same structure.  Resetting read_data_fn to NULL.");
+   }
+}
+
+#if defined(USE_FAR_KEYWORD)
+#if defined(_MSC_VER)
+void *png_far_to_near(png_structp png_ptr,png_voidp ptr, int check)
+{
+   void *near_ptr;
+   void FAR *far_ptr;
+   FP_OFF(near_ptr) = FP_OFF(ptr);
+   far_ptr = (void FAR *)near_ptr;
+   if(check != 0)
+      if(FP_SEG(ptr) != FP_SEG(far_ptr))
+         png_error(png_ptr,"segment lost in conversion");
+   return(near_ptr);
+}
+#  else
+void *png_far_to_near(png_structp png_ptr,png_voidp ptr, int check)
+{
+   void *near_ptr;
+   void FAR *far_ptr;
+   near_ptr = (void FAR *)ptr;
+   far_ptr = (void FAR *)near_ptr;
+   if(check != 0)
+      if(far_ptr != ptr)
+         png_error(png_ptr,"segment lost in conversion");
+   return(near_ptr);
+}
+#   endif
+#   endif
+#endif /* PNG_WRITE_SUPPORTED */
diff --git a/collects/plot/src/all/pngwrite.c b/collects/plot/src/all/pngwrite.c
new file mode 100644
index 0000000000..10c9ea4068
--- /dev/null
+++ b/collects/plot/src/all/pngwrite.c
@@ -0,0 +1,1450 @@
+
+/* pngwrite.c - general routines to write a PNG file
+ *
+ * libpng 1.2.5 - October 3, 2002
+ * For conditions of distribution and use, see copyright notice in png.h
+ * Copyright (c) 1998-2002 Glenn Randers-Pehrson
+ * (Version 0.96 Copyright (c) 1996, 1997 Andreas Dilger)
+ * (Version 0.88 Copyright (c) 1995, 1996 Guy Eric Schalnat, Group 42, Inc.)
+ */
+
+/* get internal access to png.h */
+#define PNG_INTERNAL
+#include "png.h"
+#ifdef PNG_WRITE_SUPPORTED
+
+/* Writes all the PNG information.  This is the suggested way to use the
+ * library.  If you have a new chunk to add, make a function to write it,
+ * and put it in the correct location here.  If you want the chunk written
+ * after the image data, put it in png_write_end().  I strongly encourage
+ * you to supply a PNG_INFO_ flag, and check info_ptr->valid before writing
+ * the chunk, as that will keep the code from breaking if you want to just
+ * write a plain PNG file.  If you have long comments, I suggest writing
+ * them in png_write_end(), and compressing them.
+ */
+void PNGAPI
+png_write_info_before_PLTE(png_structp png_ptr, png_infop info_ptr)
+{
+   png_debug(1, "in png_write_info_before_PLTE\n");
+   if (!(png_ptr->mode & PNG_WROTE_INFO_BEFORE_PLTE))
+   {
+   png_write_sig(png_ptr); /* write PNG signature */
+#if defined(PNG_MNG_FEATURES_SUPPORTED)
+   if((png_ptr->mode&PNG_HAVE_PNG_SIGNATURE)&&(png_ptr->mng_features_permitted))
+   {
+      png_warning(png_ptr,"MNG features are not allowed in a PNG datastream\n");
+      png_ptr->mng_features_permitted=0;
+   }
+#endif
+   /* write IHDR information. */
+   png_write_IHDR(png_ptr, info_ptr->width, info_ptr->height,
+      info_ptr->bit_depth, info_ptr->color_type, info_ptr->compression_type,
+      info_ptr->filter_type,
+#if defined(PNG_WRITE_INTERLACING_SUPPORTED)
+      info_ptr->interlace_type);
+#else
+      0);
+#endif
+   /* the rest of these check to see if the valid field has the appropriate
+      flag set, and if it does, writes the chunk. */
+#if defined(PNG_WRITE_gAMA_SUPPORTED)
+   if (info_ptr->valid & PNG_INFO_gAMA)
+   {
+#  ifdef PNG_FLOATING_POINT_SUPPORTED
+      png_write_gAMA(png_ptr, info_ptr->gamma);
+#else
+#ifdef PNG_FIXED_POINT_SUPPORTED
+      png_write_gAMA_fixed(png_ptr, info_ptr->int_gamma);
+#  endif
+#endif
+   }
+#endif
+#if defined(PNG_WRITE_sRGB_SUPPORTED)
+   if (info_ptr->valid & PNG_INFO_sRGB)
+      png_write_sRGB(png_ptr, (int)info_ptr->srgb_intent);
+#endif
+#if defined(PNG_WRITE_iCCP_SUPPORTED)
+   if (info_ptr->valid & PNG_INFO_iCCP)
+      png_write_iCCP(png_ptr, info_ptr->iccp_name, PNG_COMPRESSION_TYPE_BASE,
+                     info_ptr->iccp_profile, (int)info_ptr->iccp_proflen);
+#endif
+#if defined(PNG_WRITE_sBIT_SUPPORTED)
+   if (info_ptr->valid & PNG_INFO_sBIT)
+      png_write_sBIT(png_ptr, &(info_ptr->sig_bit), info_ptr->color_type);
+#endif
+#if defined(PNG_WRITE_cHRM_SUPPORTED)
+   if (info_ptr->valid & PNG_INFO_cHRM)
+   {
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+      png_write_cHRM(png_ptr,
+         info_ptr->x_white, info_ptr->y_white,
+         info_ptr->x_red, info_ptr->y_red,
+         info_ptr->x_green, info_ptr->y_green,
+         info_ptr->x_blue, info_ptr->y_blue);
+#else
+#  ifdef PNG_FIXED_POINT_SUPPORTED
+      png_write_cHRM_fixed(png_ptr,
+         info_ptr->int_x_white, info_ptr->int_y_white,
+         info_ptr->int_x_red, info_ptr->int_y_red,
+         info_ptr->int_x_green, info_ptr->int_y_green,
+         info_ptr->int_x_blue, info_ptr->int_y_blue);
+#  endif
+#endif
+   }
+#endif
+#if defined(PNG_WRITE_UNKNOWN_CHUNKS_SUPPORTED)
+   if (info_ptr->unknown_chunks_num)
+   {
+       png_unknown_chunk *up;
+
+       png_debug(5, "writing extra chunks\n");
+
+       for (up = info_ptr->unknown_chunks;
+            up < info_ptr->unknown_chunks + info_ptr->unknown_chunks_num;
+            up++)
+       {
+         int keep=png_handle_as_unknown(png_ptr, up->name);
+         if (keep != HANDLE_CHUNK_NEVER &&
+            up->location && (!(up->location & PNG_HAVE_PLTE)) &&
+            ((up->name[3] & 0x20) || keep == HANDLE_CHUNK_ALWAYS ||
+            (png_ptr->flags & PNG_FLAG_KEEP_UNSAFE_CHUNKS)))
+         {
+            png_write_chunk(png_ptr, up->name, up->data, up->size);
+         }
+       }
+   }
+#endif
+      png_ptr->mode |= PNG_WROTE_INFO_BEFORE_PLTE;
+   }
+}
+
+void PNGAPI
+png_write_info(png_structp png_ptr, png_infop info_ptr)
+{
+#if defined(PNG_WRITE_TEXT_SUPPORTED) || defined(PNG_WRITE_sPLT_SUPPORTED)
+   int i;
+#endif
+
+   png_debug(1, "in png_write_info\n");
+
+   png_write_info_before_PLTE(png_ptr, info_ptr);
+
+   if (info_ptr->valid & PNG_INFO_PLTE)
+      png_write_PLTE(png_ptr, info_ptr->palette,
+         (png_uint_32)info_ptr->num_palette);
+   else if (info_ptr->color_type == PNG_COLOR_TYPE_PALETTE)
+      png_error(png_ptr, "Valid palette required for paletted images\n");
+
+#if defined(PNG_WRITE_tRNS_SUPPORTED)
+   if (info_ptr->valid & PNG_INFO_tRNS)
+      {
+#if defined(PNG_WRITE_INVERT_ALPHA_SUPPORTED)
+         /* invert the alpha channel (in tRNS) */
+         if ((png_ptr->transformations & PNG_INVERT_ALPHA) &&
+            info_ptr->color_type == PNG_COLOR_TYPE_PALETTE)
+         {
+            int j;
+            for (j=0; j<(int)info_ptr->num_trans; j++)
+               info_ptr->trans[j] = (png_byte)(255 - info_ptr->trans[j]);
+         }
+#endif
+      png_write_tRNS(png_ptr, info_ptr->trans, &(info_ptr->trans_values),
+         info_ptr->num_trans, info_ptr->color_type);
+      }
+#endif
+#if defined(PNG_WRITE_bKGD_SUPPORTED)
+   if (info_ptr->valid & PNG_INFO_bKGD)
+      png_write_bKGD(png_ptr, &(info_ptr->background), info_ptr->color_type);
+#endif
+#if defined(PNG_WRITE_hIST_SUPPORTED)
+   if (info_ptr->valid & PNG_INFO_hIST)
+      png_write_hIST(png_ptr, info_ptr->hist, info_ptr->num_palette);
+#endif
+#if defined(PNG_WRITE_oFFs_SUPPORTED)
+   if (info_ptr->valid & PNG_INFO_oFFs)
+      png_write_oFFs(png_ptr, info_ptr->x_offset, info_ptr->y_offset,
+         info_ptr->offset_unit_type);
+#endif
+#if defined(PNG_WRITE_pCAL_SUPPORTED)
+   if (info_ptr->valid & PNG_INFO_pCAL)
+      png_write_pCAL(png_ptr, info_ptr->pcal_purpose, info_ptr->pcal_X0,
+         info_ptr->pcal_X1, info_ptr->pcal_type, info_ptr->pcal_nparams,
+         info_ptr->pcal_units, info_ptr->pcal_params);
+#endif
+#if defined(PNG_WRITE_sCAL_SUPPORTED)
+   if (info_ptr->valid & PNG_INFO_sCAL)
+#if defined(PNG_FLOATING_POINT_SUPPORTED) && !defined(PNG_NO_STDIO)
+      png_write_sCAL(png_ptr, (int)info_ptr->scal_unit,
+          info_ptr->scal_pixel_width, info_ptr->scal_pixel_height);
+#else
+#ifdef PNG_FIXED_POINT_SUPPORTED
+      png_write_sCAL_s(png_ptr, (int)info_ptr->scal_unit,
+          info_ptr->scal_s_width, info_ptr->scal_s_height);
+#else
+      png_warning(png_ptr,
+          "png_write_sCAL not supported; sCAL chunk not written.\n");
+#endif
+#endif
+#endif
+#if defined(PNG_WRITE_pHYs_SUPPORTED)
+   if (info_ptr->valid & PNG_INFO_pHYs)
+      png_write_pHYs(png_ptr, info_ptr->x_pixels_per_unit,
+         info_ptr->y_pixels_per_unit, info_ptr->phys_unit_type);
+#endif
+#if defined(PNG_WRITE_tIME_SUPPORTED)
+   if (info_ptr->valid & PNG_INFO_tIME)
+   {
+      png_write_tIME(png_ptr, &(info_ptr->mod_time));
+      png_ptr->mode |= PNG_WROTE_tIME;
+   }
+#endif
+#if defined(PNG_WRITE_sPLT_SUPPORTED)
+   if (info_ptr->valid & PNG_INFO_sPLT)
+     for (i = 0; i < (int)info_ptr->splt_palettes_num; i++)
+       png_write_sPLT(png_ptr, info_ptr->splt_palettes + i);
+#endif
+#if defined(PNG_WRITE_TEXT_SUPPORTED)
+   /* Check to see if we need to write text chunks */
+   for (i = 0; i < info_ptr->num_text; i++)
+   {
+      png_debug2(2, "Writing header text chunk %d, type %d\n", i,
+         info_ptr->text[i].compression);
+      /* an internationalized chunk? */
+      if (info_ptr->text[i].compression > 0)
+      {
+#if defined(PNG_WRITE_iTXt_SUPPORTED)
+          /* write international chunk */
+          png_write_iTXt(png_ptr,
+                         info_ptr->text[i].compression,
+                         info_ptr->text[i].key,
+                         info_ptr->text[i].lang,
+                         info_ptr->text[i].lang_key,
+                         info_ptr->text[i].text);
+#else
+          png_warning(png_ptr, "Unable to write international text\n");
+#endif
+          /* Mark this chunk as written */
+          info_ptr->text[i].compression = PNG_TEXT_COMPRESSION_NONE_WR;
+      }
+      /* If we want a compressed text chunk */
+      else if (info_ptr->text[i].compression == PNG_TEXT_COMPRESSION_zTXt)
+      {
+#if defined(PNG_WRITE_zTXt_SUPPORTED)
+         /* write compressed chunk */
+         png_write_zTXt(png_ptr, info_ptr->text[i].key,
+            info_ptr->text[i].text, 0,
+            info_ptr->text[i].compression);
+#else
+         png_warning(png_ptr, "Unable to write compressed text\n");
+#endif
+         /* Mark this chunk as written */
+         info_ptr->text[i].compression = PNG_TEXT_COMPRESSION_zTXt_WR;
+      }
+      else if (info_ptr->text[i].compression == PNG_TEXT_COMPRESSION_NONE)
+      {
+#if defined(PNG_WRITE_tEXt_SUPPORTED)
+         /* write uncompressed chunk */
+         png_write_tEXt(png_ptr, info_ptr->text[i].key,
+                         info_ptr->text[i].text,
+                         0);
+#else
+         png_warning(png_ptr, "Unable to write uncompressed text\n");
+#endif
+         /* Mark this chunk as written */
+         info_ptr->text[i].compression = PNG_TEXT_COMPRESSION_NONE_WR;
+      }
+   }
+#endif
+#if defined(PNG_WRITE_UNKNOWN_CHUNKS_SUPPORTED)
+   if (info_ptr->unknown_chunks_num)
+   {
+       png_unknown_chunk *up;
+
+       png_debug(5, "writing extra chunks\n");
+
+       for (up = info_ptr->unknown_chunks;
+            up < info_ptr->unknown_chunks + info_ptr->unknown_chunks_num;
+            up++)
+       {
+         int keep=png_handle_as_unknown(png_ptr, up->name);
+         if (keep != HANDLE_CHUNK_NEVER &&
+            up->location && (up->location & PNG_HAVE_PLTE) &&
+            !(up->location & PNG_HAVE_IDAT) &&
+            ((up->name[3] & 0x20) || keep == HANDLE_CHUNK_ALWAYS ||
+            (png_ptr->flags & PNG_FLAG_KEEP_UNSAFE_CHUNKS)))
+         {
+            png_write_chunk(png_ptr, up->name, up->data, up->size);
+         }
+       }
+   }
+#endif
+}
+
+/* Writes the end of the PNG file.  If you don't want to write comments or
+ * time information, you can pass NULL for info.  If you already wrote these
+ * in png_write_info(), do not write them again here.  If you have long
+ * comments, I suggest writing them here, and compressing them.
+ */
+void PNGAPI
+png_write_end(png_structp png_ptr, png_infop info_ptr)
+{
+   png_debug(1, "in png_write_end\n");
+   if (!(png_ptr->mode & PNG_HAVE_IDAT))
+      png_error(png_ptr, "No IDATs written into file");
+
+   /* see if user wants us to write information chunks */
+   if (info_ptr != NULL)
+   {
+#if defined(PNG_WRITE_TEXT_SUPPORTED)
+      int i; /* local index variable */
+#endif
+#if defined(PNG_WRITE_tIME_SUPPORTED)
+      /* check to see if user has supplied a time chunk */
+      if ((info_ptr->valid & PNG_INFO_tIME) &&
+         !(png_ptr->mode & PNG_WROTE_tIME))
+         png_write_tIME(png_ptr, &(info_ptr->mod_time));
+#endif
+#if defined(PNG_WRITE_TEXT_SUPPORTED)
+      /* loop through comment chunks */
+      for (i = 0; i < info_ptr->num_text; i++)
+      {
+         png_debug2(2, "Writing trailer text chunk %d, type %d\n", i,
+            info_ptr->text[i].compression);
+         /* an internationalized chunk? */
+         if (info_ptr->text[i].compression > 0)
+         {
+#if defined(PNG_WRITE_iTXt_SUPPORTED)
+             /* write international chunk */
+             png_write_iTXt(png_ptr,
+                         info_ptr->text[i].compression,
+                         info_ptr->text[i].key,
+                         info_ptr->text[i].lang,
+                         info_ptr->text[i].lang_key,
+                         info_ptr->text[i].text);
+#else
+             png_warning(png_ptr, "Unable to write international text\n");
+#endif
+             /* Mark this chunk as written */
+             info_ptr->text[i].compression = PNG_TEXT_COMPRESSION_NONE_WR;
+         }
+         else if (info_ptr->text[i].compression >= PNG_TEXT_COMPRESSION_zTXt)
+         {
+#if defined(PNG_WRITE_zTXt_SUPPORTED)
+            /* write compressed chunk */
+            png_write_zTXt(png_ptr, info_ptr->text[i].key,
+               info_ptr->text[i].text, 0,
+               info_ptr->text[i].compression);
+#else
+            png_warning(png_ptr, "Unable to write compressed text\n");
+#endif
+            /* Mark this chunk as written */
+            info_ptr->text[i].compression = PNG_TEXT_COMPRESSION_zTXt_WR;
+         }
+         else if (info_ptr->text[i].compression == PNG_TEXT_COMPRESSION_NONE)
+         {
+#if defined(PNG_WRITE_tEXt_SUPPORTED)
+            /* write uncompressed chunk */
+            png_write_tEXt(png_ptr, info_ptr->text[i].key,
+               info_ptr->text[i].text, 0);
+#else
+            png_warning(png_ptr, "Unable to write uncompressed text\n");
+#endif
+
+            /* Mark this chunk as written */
+            info_ptr->text[i].compression = PNG_TEXT_COMPRESSION_NONE_WR;
+         }
+      }
+#endif
+#if defined(PNG_WRITE_UNKNOWN_CHUNKS_SUPPORTED)
+   if (info_ptr->unknown_chunks_num)
+   {
+       png_unknown_chunk *up;
+
+       png_debug(5, "writing extra chunks\n");
+
+       for (up = info_ptr->unknown_chunks;
+            up < info_ptr->unknown_chunks + info_ptr->unknown_chunks_num;
+            up++)
+       {
+         int keep=png_handle_as_unknown(png_ptr, up->name);
+         if (keep != HANDLE_CHUNK_NEVER &&
+            up->location && (up->location & PNG_AFTER_IDAT) &&
+            ((up->name[3] & 0x20) || keep == HANDLE_CHUNK_ALWAYS ||
+            (png_ptr->flags & PNG_FLAG_KEEP_UNSAFE_CHUNKS)))
+         {
+            png_write_chunk(png_ptr, up->name, up->data, up->size);
+         }
+       }
+   }
+#endif
+   }
+
+   png_ptr->mode |= PNG_AFTER_IDAT;
+
+   /* write end of PNG file */
+   png_write_IEND(png_ptr);
+#if 0
+/* This flush, added in libpng-1.0.8,  causes some applications to crash
+   because they do not set png_ptr->output_flush_fn */
+   png_flush(png_ptr);
+#endif
+}
+
+#if defined(PNG_WRITE_tIME_SUPPORTED)
+#if !defined(_WIN32_WCE)
+/* "time.h" functions are not supported on WindowsCE */
+void PNGAPI
+png_convert_from_struct_tm(png_timep ptime, struct tm FAR * ttime)
+{
+   png_debug(1, "in png_convert_from_struct_tm\n");
+   ptime->year = (png_uint_16)(1900 + ttime->tm_year);
+   ptime->month = (png_byte)(ttime->tm_mon + 1);
+   ptime->day = (png_byte)ttime->tm_mday;
+   ptime->hour = (png_byte)ttime->tm_hour;
+   ptime->minute = (png_byte)ttime->tm_min;
+   ptime->second = (png_byte)ttime->tm_sec;
+}
+
+void PNGAPI
+png_convert_from_time_t(png_timep ptime, time_t ttime)
+{
+   struct tm *tbuf;
+
+   png_debug(1, "in png_convert_from_time_t\n");
+   tbuf = gmtime(&ttime);
+   png_convert_from_struct_tm(ptime, tbuf);
+}
+#endif
+#endif
+
+/* Initialize png_ptr structure, and allocate any memory needed */
+png_structp PNGAPI
+png_create_write_struct(png_const_charp user_png_ver, png_voidp error_ptr,
+   png_error_ptr error_fn, png_error_ptr warn_fn)
+{
+#ifdef PNG_USER_MEM_SUPPORTED
+   return (png_create_write_struct_2(user_png_ver, error_ptr, error_fn,
+      warn_fn, png_voidp_NULL, png_malloc_ptr_NULL, png_free_ptr_NULL));
+}
+
+/* Alternate initialize png_ptr structure, and allocate any memory needed */
+png_structp PNGAPI
+png_create_write_struct_2(png_const_charp user_png_ver, png_voidp error_ptr,
+   png_error_ptr error_fn, png_error_ptr warn_fn, png_voidp mem_ptr,
+   png_malloc_ptr malloc_fn, png_free_ptr free_fn)
+{
+#endif /* PNG_USER_MEM_SUPPORTED */
+   png_structp png_ptr;
+#ifdef PNG_SETJMP_SUPPORTED
+#ifdef USE_FAR_KEYWORD
+   jmp_buf jmpbuf;
+#endif
+#endif
+   int i;
+   png_debug(1, "in png_create_write_struct\n");
+#ifdef PNG_USER_MEM_SUPPORTED
+   png_ptr = (png_structp)png_create_struct_2(PNG_STRUCT_PNG,
+      (png_malloc_ptr)malloc_fn, (png_voidp)mem_ptr);
+#else
+   png_ptr = (png_structp)png_create_struct(PNG_STRUCT_PNG);
+#endif /* PNG_USER_MEM_SUPPORTED */
+   if (png_ptr == NULL)
+      return (NULL);
+
+#if !defined(PNG_1_0_X)
+#ifdef PNG_ASSEMBLER_CODE_SUPPORTED
+   png_init_mmx_flags(png_ptr);   /* 1.2.0 addition */
+#endif
+#endif /* PNG_1_0_X */
+
+#ifdef PNG_SETJMP_SUPPORTED
+#ifdef USE_FAR_KEYWORD
+   if (setjmp(jmpbuf))
+#else
+   if (setjmp(png_ptr->jmpbuf))
+#endif
+   {
+      png_free(png_ptr, png_ptr->zbuf);
+      png_ptr->zbuf=NULL;
+      png_destroy_struct(png_ptr);
+      return (NULL);
+   }
+#ifdef USE_FAR_KEYWORD
+   png_memcpy(png_ptr->jmpbuf,jmpbuf,sizeof(jmp_buf));
+#endif
+#endif
+
+#ifdef PNG_USER_MEM_SUPPORTED
+   png_set_mem_fn(png_ptr, mem_ptr, malloc_fn, free_fn);
+#endif /* PNG_USER_MEM_SUPPORTED */
+   png_set_error_fn(png_ptr, error_ptr, error_fn, warn_fn);
+
+   i=0;
+   do
+   {
+     if(user_png_ver[i] != png_libpng_ver[i])
+        png_ptr->flags |= PNG_FLAG_LIBRARY_MISMATCH;
+   } while (png_libpng_ver[i++]);
+
+   if (png_ptr->flags & PNG_FLAG_LIBRARY_MISMATCH)
+   {
+     /* Libpng 0.90 and later are binary incompatible with libpng 0.89, so
+      * we must recompile any applications that use any older library version.
+      * For versions after libpng 1.0, we will be compatible, so we need
+      * only check the first digit.
+      */
+     if (user_png_ver == NULL || user_png_ver[0] != png_libpng_ver[0] ||
+         (user_png_ver[0] == '1' && user_png_ver[2] != png_libpng_ver[2]) ||
+         (user_png_ver[0] == '0' && user_png_ver[2] < '9'))
+     {
+#if !defined(PNG_NO_STDIO) && !defined(_WIN32_WCE)
+        char msg[80];
+        if (user_png_ver)
+        {
+          sprintf(msg, "Application was compiled with png.h from libpng-%.20s",
+             user_png_ver);
+          png_warning(png_ptr, msg);
+        }
+        sprintf(msg, "Application  is  running with png.c from libpng-%.20s",
+           png_libpng_ver);
+        png_warning(png_ptr, msg);
+#endif
+#ifdef PNG_ERROR_NUMBERS_SUPPORTED
+        png_ptr->flags=0;
+#endif
+        png_error(png_ptr,
+           "Incompatible libpng version in application and library");
+     }
+   }
+
+   /* initialize zbuf - compression buffer */
+   png_ptr->zbuf_size = PNG_ZBUF_SIZE;
+   png_ptr->zbuf = (png_bytep)png_malloc(png_ptr,
+      (png_uint_32)png_ptr->zbuf_size);
+
+   png_set_write_fn(png_ptr, png_voidp_NULL, png_rw_ptr_NULL,
+      png_flush_ptr_NULL);
+
+#if defined(PNG_WRITE_WEIGHTED_FILTER_SUPPORTED)
+   png_set_filter_heuristics(png_ptr, PNG_FILTER_HEURISTIC_DEFAULT,
+      1, png_doublep_NULL, png_doublep_NULL);
+#endif
+
+#ifdef PNG_SETJMP_SUPPORTED
+/* Applications that neglect to set up their own setjmp() and then encounter
+   a png_error() will longjmp here.  Since the jmpbuf is then meaningless we
+   abort instead of returning. */
+#ifdef USE_FAR_KEYWORD
+   if (setjmp(jmpbuf))
+      PNG_ABORT();
+   png_memcpy(png_ptr->jmpbuf,jmpbuf,sizeof(jmp_buf));
+#else
+   if (setjmp(png_ptr->jmpbuf))
+      PNG_ABORT();
+#endif
+#endif
+   return (png_ptr);
+}
+
+/* Initialize png_ptr structure, and allocate any memory needed */
+#undef png_write_init
+void PNGAPI
+png_write_init(png_structp png_ptr)
+{
+   /* We only come here via pre-1.0.7-compiled applications */
+   png_write_init_2(png_ptr, "1.0.6 or earlier", 0, 0);
+}
+
+void PNGAPI
+png_write_init_2(png_structp png_ptr, png_const_charp user_png_ver,
+   png_size_t png_struct_size, png_size_t png_info_size)
+{
+   /* We only come here via pre-1.0.12-compiled applications */
+#if !defined(PNG_NO_STDIO) && !defined(_WIN32_WCE)
+   if(sizeof(png_struct) > png_struct_size || sizeof(png_info) > png_info_size)
+   {
+      char msg[80];
+      png_ptr->warning_fn=NULL;
+      if (user_png_ver)
+      {
+        sprintf(msg, "Application was compiled with png.h from libpng-%.20s",
+           user_png_ver);
+        png_warning(png_ptr, msg);
+      }
+      sprintf(msg, "Application  is  running with png.c from libpng-%.20s",
+         png_libpng_ver);
+      png_warning(png_ptr, msg);
+   }
+#endif
+   if(sizeof(png_struct) > png_struct_size)
+     {
+       png_ptr->error_fn=NULL;
+#ifdef PNG_ERROR_NUMBERS_SUPPORTED
+       png_ptr->flags=0;
+#endif
+       png_error(png_ptr,
+       "The png struct allocated by the application for writing is too small.");
+     }
+   if(sizeof(png_info) > png_info_size)
+     {
+       png_ptr->error_fn=NULL;
+#ifdef PNG_ERROR_NUMBERS_SUPPORTED
+       png_ptr->flags=0;
+#endif
+       png_error(png_ptr,
+       "The info struct allocated by the application for writing is too small.");
+     }
+   png_write_init_3(&png_ptr, user_png_ver, png_struct_size);
+}
+
+
+void PNGAPI
+png_write_init_3(png_structpp ptr_ptr, png_const_charp user_png_ver,
+   png_size_t png_struct_size)
+{
+   png_structp png_ptr=*ptr_ptr;
+#ifdef PNG_SETJMP_SUPPORTED
+   jmp_buf tmp_jmp; /* to save current jump buffer */
+#endif
+   int i = 0;
+   do
+   {
+     if (user_png_ver[i] != png_libpng_ver[i])
+     {
+#ifdef PNG_LEGACY_SUPPORTED
+       png_ptr->flags |= PNG_FLAG_LIBRARY_MISMATCH;
+#else
+       png_ptr->warning_fn=NULL;
+       png_warning(png_ptr,
+     "Application uses deprecated png_write_init() and should be recompiled.");
+       break;
+#endif
+     }
+   } while (png_libpng_ver[i++]);
+
+   png_debug(1, "in png_write_init_3\n");
+
+#ifdef PNG_SETJMP_SUPPORTED
+   /* save jump buffer and error functions */
+   png_memcpy(tmp_jmp, png_ptr->jmpbuf, sizeof (jmp_buf));
+#endif
+
+   if (sizeof(png_struct) > png_struct_size)
+     {
+       png_destroy_struct(png_ptr);
+       png_ptr = (png_structp)png_create_struct(PNG_STRUCT_PNG);
+       *ptr_ptr = png_ptr;
+     }
+
+   /* reset all variables to 0 */
+   png_memset(png_ptr, 0, sizeof (png_struct));
+
+#if !defined(PNG_1_0_X)
+#ifdef PNG_ASSEMBLER_CODE_SUPPORTED
+   png_init_mmx_flags(png_ptr);   /* 1.2.0 addition */
+#endif
+#endif /* PNG_1_0_X */
+
+#ifdef PNG_SETJMP_SUPPORTED
+   /* restore jump buffer */
+   png_memcpy(png_ptr->jmpbuf, tmp_jmp, sizeof (jmp_buf));
+#endif
+
+   png_set_write_fn(png_ptr, png_voidp_NULL, png_rw_ptr_NULL,
+      png_flush_ptr_NULL);
+
+   /* initialize zbuf - compression buffer */
+   png_ptr->zbuf_size = PNG_ZBUF_SIZE;
+   png_ptr->zbuf = (png_bytep)png_malloc(png_ptr,
+      (png_uint_32)png_ptr->zbuf_size);
+
+#if defined(PNG_WRITE_WEIGHTED_FILTER_SUPPORTED)
+   png_set_filter_heuristics(png_ptr, PNG_FILTER_HEURISTIC_DEFAULT,
+      1, png_doublep_NULL, png_doublep_NULL);
+#endif
+}
+
+/* Write a few rows of image data.  If the image is interlaced,
+ * either you will have to write the 7 sub images, or, if you
+ * have called png_set_interlace_handling(), you will have to
+ * "write" the image seven times.
+ */
+void PNGAPI
+png_write_rows(png_structp png_ptr, png_bytepp row,
+   png_uint_32 num_rows)
+{
+   png_uint_32 i; /* row counter */
+   png_bytepp rp; /* row pointer */
+
+   png_debug(1, "in png_write_rows\n");
+   /* loop through the rows */
+   for (i = 0, rp = row; i < num_rows; i++, rp++)
+   {
+      png_write_row(png_ptr, *rp);
+   }
+}
+
+/* Write the image.  You only need to call this function once, even
+ * if you are writing an interlaced image.
+ */
+void PNGAPI
+png_write_image(png_structp png_ptr, png_bytepp image)
+{
+   png_uint_32 i; /* row index */
+   int pass, num_pass; /* pass variables */
+   png_bytepp rp; /* points to current row */
+
+   png_debug(1, "in png_write_image\n");
+#if defined(PNG_WRITE_INTERLACING_SUPPORTED)
+   /* intialize interlace handling.  If image is not interlaced,
+      this will set pass to 1 */
+   num_pass = png_set_interlace_handling(png_ptr);
+#else
+   num_pass = 1;
+#endif
+   /* loop through passes */
+   for (pass = 0; pass < num_pass; pass++)
+   {
+      /* loop through image */
+      for (i = 0, rp = image; i < png_ptr->height; i++, rp++)
+      {
+         png_write_row(png_ptr, *rp);
+      }
+   }
+}
+
+/* called by user to write a row of image data */
+void PNGAPI
+png_write_row(png_structp png_ptr, png_bytep row)
+{
+   png_debug2(1, "in png_write_row (row %ld, pass %d)\n",
+      png_ptr->row_number, png_ptr->pass);
+   /* initialize transformations and other stuff if first time */
+   if (png_ptr->row_number == 0 && png_ptr->pass == 0)
+   {
+   /* make sure we wrote the header info */
+   if (!(png_ptr->mode & PNG_WROTE_INFO_BEFORE_PLTE))
+      png_error(png_ptr,
+         "png_write_info was never called before png_write_row.");
+
+   /* check for transforms that have been set but were defined out */
+#if !defined(PNG_WRITE_INVERT_SUPPORTED) && defined(PNG_READ_INVERT_SUPPORTED)
+   if (png_ptr->transformations & PNG_INVERT_MONO)
+      png_warning(png_ptr, "PNG_WRITE_INVERT_SUPPORTED is not defined.");
+#endif
+#if !defined(PNG_WRITE_FILLER_SUPPORTED) && defined(PNG_READ_FILLER_SUPPORTED)
+   if (png_ptr->transformations & PNG_FILLER)
+      png_warning(png_ptr, "PNG_WRITE_FILLER_SUPPORTED is not defined.");
+#endif
+#if !defined(PNG_WRITE_PACKSWAP_SUPPORTED) && defined(PNG_READ_PACKSWAP_SUPPORTED)
+   if (png_ptr->transformations & PNG_PACKSWAP)
+      png_warning(png_ptr, "PNG_WRITE_PACKSWAP_SUPPORTED is not defined.");
+#endif
+#if !defined(PNG_WRITE_PACK_SUPPORTED) && defined(PNG_READ_PACK_SUPPORTED)
+   if (png_ptr->transformations & PNG_PACK)
+      png_warning(png_ptr, "PNG_WRITE_PACK_SUPPORTED is not defined.");
+#endif
+#if !defined(PNG_WRITE_SHIFT_SUPPORTED) && defined(PNG_READ_SHIFT_SUPPORTED)
+   if (png_ptr->transformations & PNG_SHIFT)
+      png_warning(png_ptr, "PNG_WRITE_SHIFT_SUPPORTED is not defined.");
+#endif
+#if !defined(PNG_WRITE_BGR_SUPPORTED) && defined(PNG_READ_BGR_SUPPORTED)
+   if (png_ptr->transformations & PNG_BGR)
+      png_warning(png_ptr, "PNG_WRITE_BGR_SUPPORTED is not defined.");
+#endif
+#if !defined(PNG_WRITE_SWAP_SUPPORTED) && defined(PNG_READ_SWAP_SUPPORTED)
+   if (png_ptr->transformations & PNG_SWAP_BYTES)
+      png_warning(png_ptr, "PNG_WRITE_SWAP_SUPPORTED is not defined.");
+#endif
+
+      png_write_start_row(png_ptr);
+   }
+
+#if defined(PNG_WRITE_INTERLACING_SUPPORTED)
+   /* if interlaced and not interested in row, return */
+   if (png_ptr->interlaced && (png_ptr->transformations & PNG_INTERLACE))
+   {
+      switch (png_ptr->pass)
+      {
+         case 0:
+            if (png_ptr->row_number & 0x07)
+            {
+               png_write_finish_row(png_ptr);
+               return;
+            }
+            break;
+         case 1:
+            if ((png_ptr->row_number & 0x07) || png_ptr->width < 5)
+            {
+               png_write_finish_row(png_ptr);
+               return;
+            }
+            break;
+         case 2:
+            if ((png_ptr->row_number & 0x07) != 4)
+            {
+               png_write_finish_row(png_ptr);
+               return;
+            }
+            break;
+         case 3:
+            if ((png_ptr->row_number & 0x03) || png_ptr->width < 3)
+            {
+               png_write_finish_row(png_ptr);
+               return;
+            }
+            break;
+         case 4:
+            if ((png_ptr->row_number & 0x03) != 2)
+            {
+               png_write_finish_row(png_ptr);
+               return;
+            }
+            break;
+         case 5:
+            if ((png_ptr->row_number & 0x01) || png_ptr->width < 2)
+            {
+               png_write_finish_row(png_ptr);
+               return;
+            }
+            break;
+         case 6:
+            if (!(png_ptr->row_number & 0x01))
+            {
+               png_write_finish_row(png_ptr);
+               return;
+            }
+            break;
+      }
+   }
+#endif
+
+   /* set up row info for transformations */
+   png_ptr->row_info.color_type = png_ptr->color_type;
+   png_ptr->row_info.width = png_ptr->usr_width;
+   png_ptr->row_info.channels = png_ptr->usr_channels;
+   png_ptr->row_info.bit_depth = png_ptr->usr_bit_depth;
+   png_ptr->row_info.pixel_depth = (png_byte)(png_ptr->row_info.bit_depth *
+      png_ptr->row_info.channels);
+
+   png_ptr->row_info.rowbytes = ((png_ptr->row_info.width *
+      (png_uint_32)png_ptr->row_info.pixel_depth + 7) >> 3);
+
+   png_debug1(3, "row_info->color_type = %d\n", png_ptr->row_info.color_type);
+   png_debug1(3, "row_info->width = %lu\n", png_ptr->row_info.width);
+   png_debug1(3, "row_info->channels = %d\n", png_ptr->row_info.channels);
+   png_debug1(3, "row_info->bit_depth = %d\n", png_ptr->row_info.bit_depth);
+   png_debug1(3, "row_info->pixel_depth = %d\n", png_ptr->row_info.pixel_depth);
+   png_debug1(3, "row_info->rowbytes = %lu\n", png_ptr->row_info.rowbytes);
+
+   /* Copy user's row into buffer, leaving room for filter byte. */
+   png_memcpy_check(png_ptr, png_ptr->row_buf + 1, row,
+      png_ptr->row_info.rowbytes);
+
+#if defined(PNG_WRITE_INTERLACING_SUPPORTED)
+   /* handle interlacing */
+   if (png_ptr->interlaced && png_ptr->pass < 6 &&
+      (png_ptr->transformations & PNG_INTERLACE))
+   {
+      png_do_write_interlace(&(png_ptr->row_info),
+         png_ptr->row_buf + 1, png_ptr->pass);
+      /* this should always get caught above, but still ... */
+      if (!(png_ptr->row_info.width))
+      {
+         png_write_finish_row(png_ptr);
+         return;
+      }
+   }
+#endif
+
+   /* handle other transformations */
+   if (png_ptr->transformations)
+      png_do_write_transformations(png_ptr);
+
+#if defined(PNG_MNG_FEATURES_SUPPORTED)
+   /* Write filter_method 64 (intrapixel differencing) only if
+    * 1. Libpng was compiled with PNG_MNG_FEATURES_SUPPORTED and
+    * 2. Libpng did not write a PNG signature (this filter_method is only
+    *    used in PNG datastreams that are embedded in MNG datastreams) and
+    * 3. The application called png_permit_mng_features with a mask that
+    *    included PNG_FLAG_MNG_FILTER_64 and
+    * 4. The filter_method is 64 and
+    * 5. The color_type is RGB or RGBA
+    */
+   if((png_ptr->mng_features_permitted & PNG_FLAG_MNG_FILTER_64) &&
+      (png_ptr->filter_type == PNG_INTRAPIXEL_DIFFERENCING))
+   {
+      /* Intrapixel differencing */
+      png_do_write_intrapixel(&(png_ptr->row_info), png_ptr->row_buf + 1);
+   }
+#endif
+
+   /* Find a filter if necessary, filter the row and write it out. */
+   png_write_find_filter(png_ptr, &(png_ptr->row_info));
+
+   if (png_ptr->write_row_fn != NULL)
+      (*(png_ptr->write_row_fn))(png_ptr, png_ptr->row_number, png_ptr->pass);
+}
+
+#if defined(PNG_WRITE_FLUSH_SUPPORTED)
+/* Set the automatic flush interval or 0 to turn flushing off */
+void PNGAPI
+png_set_flush(png_structp png_ptr, int nrows)
+{
+   png_debug(1, "in png_set_flush\n");
+   png_ptr->flush_dist = (nrows < 0 ? 0 : nrows);
+}
+
+/* flush the current output buffers now */
+void PNGAPI
+png_write_flush(png_structp png_ptr)
+{
+   int wrote_IDAT;
+
+   png_debug(1, "in png_write_flush\n");
+   /* We have already written out all of the data */
+   if (png_ptr->row_number >= png_ptr->num_rows)
+     return;
+
+   do
+   {
+      int ret;
+
+      /* compress the data */
+      ret = deflate(&png_ptr->zstream, Z_SYNC_FLUSH);
+      wrote_IDAT = 0;
+
+      /* check for compression errors */
+      if (ret != Z_OK)
+      {
+         if (png_ptr->zstream.msg != NULL)
+            png_error(png_ptr, png_ptr->zstream.msg);
+         else
+            png_error(png_ptr, "zlib error");
+      }
+
+      if (!(png_ptr->zstream.avail_out))
+      {
+         /* write the IDAT and reset the zlib output buffer */
+         png_write_IDAT(png_ptr, png_ptr->zbuf,
+                        png_ptr->zbuf_size);
+         png_ptr->zstream.next_out = png_ptr->zbuf;
+         png_ptr->zstream.avail_out = (uInt)png_ptr->zbuf_size;
+         wrote_IDAT = 1;
+      }
+   } while(wrote_IDAT == 1);
+
+   /* If there is any data left to be output, write it into a new IDAT */
+   if (png_ptr->zbuf_size != png_ptr->zstream.avail_out)
+   {
+      /* write the IDAT and reset the zlib output buffer */
+      png_write_IDAT(png_ptr, png_ptr->zbuf,
+                     png_ptr->zbuf_size - png_ptr->zstream.avail_out);
+      png_ptr->zstream.next_out = png_ptr->zbuf;
+      png_ptr->zstream.avail_out = (uInt)png_ptr->zbuf_size;
+   }
+   png_ptr->flush_rows = 0;
+   png_flush(png_ptr);
+}
+#endif /* PNG_WRITE_FLUSH_SUPPORTED */
+
+/* free all memory used by the write */
+void PNGAPI
+png_destroy_write_struct(png_structpp png_ptr_ptr, png_infopp info_ptr_ptr)
+{
+   png_structp png_ptr = NULL;
+   png_infop info_ptr = NULL;
+#ifdef PNG_USER_MEM_SUPPORTED
+   png_free_ptr free_fn = NULL;
+   png_voidp mem_ptr = NULL;
+#endif
+
+   png_debug(1, "in png_destroy_write_struct\n");
+   if (png_ptr_ptr != NULL)
+   {
+      png_ptr = *png_ptr_ptr;
+#ifdef PNG_USER_MEM_SUPPORTED
+      free_fn = png_ptr->free_fn;
+      mem_ptr = png_ptr->mem_ptr;
+#endif
+   }
+
+   if (info_ptr_ptr != NULL)
+      info_ptr = *info_ptr_ptr;
+
+   if (info_ptr != NULL)
+   {
+      png_free_data(png_ptr, info_ptr, PNG_FREE_ALL, -1);
+
+#if defined(PNG_UNKNOWN_CHUNKS_SUPPORTED)
+      if (png_ptr->num_chunk_list)
+      {
+         png_free(png_ptr, png_ptr->chunk_list);
+         png_ptr->chunk_list=NULL;
+         png_ptr->num_chunk_list=0;
+      }
+#endif
+
+#ifdef PNG_USER_MEM_SUPPORTED
+      png_destroy_struct_2((png_voidp)info_ptr, (png_free_ptr)free_fn,
+         (png_voidp)mem_ptr);
+#else
+      png_destroy_struct((png_voidp)info_ptr);
+#endif
+      *info_ptr_ptr = NULL;
+   }
+
+   if (png_ptr != NULL)
+   {
+      png_write_destroy(png_ptr);
+#ifdef PNG_USER_MEM_SUPPORTED
+      png_destroy_struct_2((png_voidp)png_ptr, (png_free_ptr)free_fn,
+         (png_voidp)mem_ptr);
+#else
+      png_destroy_struct((png_voidp)png_ptr);
+#endif
+      *png_ptr_ptr = NULL;
+   }
+}
+
+
+/* Free any memory used in png_ptr struct (old method) */
+void /* PRIVATE */
+png_write_destroy(png_structp png_ptr)
+{
+#ifdef PNG_SETJMP_SUPPORTED
+   jmp_buf tmp_jmp; /* save jump buffer */
+#endif
+   png_error_ptr error_fn;
+   png_error_ptr warning_fn;
+   png_voidp error_ptr;
+#ifdef PNG_USER_MEM_SUPPORTED
+   png_free_ptr free_fn;
+#endif
+
+   png_debug(1, "in png_write_destroy\n");
+   /* free any memory zlib uses */
+   deflateEnd(&png_ptr->zstream);
+
+   /* free our memory.  png_free checks NULL for us. */
+   png_free(png_ptr, png_ptr->zbuf);
+   png_free(png_ptr, png_ptr->row_buf);
+   png_free(png_ptr, png_ptr->prev_row);
+   png_free(png_ptr, png_ptr->sub_row);
+   png_free(png_ptr, png_ptr->up_row);
+   png_free(png_ptr, png_ptr->avg_row);
+   png_free(png_ptr, png_ptr->paeth_row);
+
+#if defined(PNG_TIME_RFC1123_SUPPORTED)
+   png_free(png_ptr, png_ptr->time_buffer);
+#endif
+
+#if defined(PNG_WRITE_WEIGHTED_FILTER_SUPPORTED)
+   png_free(png_ptr, png_ptr->prev_filters);
+   png_free(png_ptr, png_ptr->filter_weights);
+   png_free(png_ptr, png_ptr->inv_filter_weights);
+   png_free(png_ptr, png_ptr->filter_costs);
+   png_free(png_ptr, png_ptr->inv_filter_costs);
+#endif
+
+#ifdef PNG_SETJMP_SUPPORTED
+   /* reset structure */
+   png_memcpy(tmp_jmp, png_ptr->jmpbuf, sizeof (jmp_buf));
+#endif
+
+   error_fn = png_ptr->error_fn;
+   warning_fn = png_ptr->warning_fn;
+   error_ptr = png_ptr->error_ptr;
+#ifdef PNG_USER_MEM_SUPPORTED
+   free_fn = png_ptr->free_fn;
+#endif
+
+   png_memset(png_ptr, 0, sizeof (png_struct));
+
+   png_ptr->error_fn = error_fn;
+   png_ptr->warning_fn = warning_fn;
+   png_ptr->error_ptr = error_ptr;
+#ifdef PNG_USER_MEM_SUPPORTED
+   png_ptr->free_fn = free_fn;
+#endif
+
+#ifdef PNG_SETJMP_SUPPORTED
+   png_memcpy(png_ptr->jmpbuf, tmp_jmp, sizeof (jmp_buf));
+#endif
+}
+
+/* Allow the application to select one or more row filters to use. */
+void PNGAPI
+png_set_filter(png_structp png_ptr, int method, int filters)
+{
+   png_debug(1, "in png_set_filter\n");
+#if defined(PNG_MNG_FEATURES_SUPPORTED)
+   if((png_ptr->mng_features_permitted & PNG_FLAG_MNG_FILTER_64) &&
+      (method == PNG_INTRAPIXEL_DIFFERENCING))
+         method = PNG_FILTER_TYPE_BASE;
+#endif
+   if (method == PNG_FILTER_TYPE_BASE)
+   {
+      switch (filters & (PNG_ALL_FILTERS | 0x07))
+      {
+         case 5:
+         case 6:
+         case 7: png_warning(png_ptr, "Unknown row filter for method 0");
+         case PNG_FILTER_VALUE_NONE:  png_ptr->do_filter=PNG_FILTER_NONE; break;
+         case PNG_FILTER_VALUE_SUB:   png_ptr->do_filter=PNG_FILTER_SUB;  break;
+         case PNG_FILTER_VALUE_UP:    png_ptr->do_filter=PNG_FILTER_UP;   break;
+         case PNG_FILTER_VALUE_AVG:   png_ptr->do_filter=PNG_FILTER_AVG;  break;
+         case PNG_FILTER_VALUE_PAETH: png_ptr->do_filter=PNG_FILTER_PAETH;break;
+         default: png_ptr->do_filter = (png_byte)filters; break;
+      }
+
+      /* If we have allocated the row_buf, this means we have already started
+       * with the image and we should have allocated all of the filter buffers
+       * that have been selected.  If prev_row isn't already allocated, then
+       * it is too late to start using the filters that need it, since we
+       * will be missing the data in the previous row.  If an application
+       * wants to start and stop using particular filters during compression,
+       * it should start out with all of the filters, and then add and
+       * remove them after the start of compression.
+       */
+      if (png_ptr->row_buf != NULL)
+      {
+         if ((png_ptr->do_filter & PNG_FILTER_SUB) && png_ptr->sub_row == NULL)
+         {
+            png_ptr->sub_row = (png_bytep)png_malloc(png_ptr,
+              (png_ptr->rowbytes + 1));
+            png_ptr->sub_row[0] = PNG_FILTER_VALUE_SUB;
+         }
+
+         if ((png_ptr->do_filter & PNG_FILTER_UP) && png_ptr->up_row == NULL)
+         {
+            if (png_ptr->prev_row == NULL)
+            {
+               png_warning(png_ptr, "Can't add Up filter after starting");
+               png_ptr->do_filter &= ~PNG_FILTER_UP;
+            }
+            else
+            {
+               png_ptr->up_row = (png_bytep)png_malloc(png_ptr,
+                  (png_ptr->rowbytes + 1));
+               png_ptr->up_row[0] = PNG_FILTER_VALUE_UP;
+            }
+         }
+
+         if ((png_ptr->do_filter & PNG_FILTER_AVG) && png_ptr->avg_row == NULL)
+         {
+            if (png_ptr->prev_row == NULL)
+            {
+               png_warning(png_ptr, "Can't add Average filter after starting");
+               png_ptr->do_filter &= ~PNG_FILTER_AVG;
+            }
+            else
+            {
+               png_ptr->avg_row = (png_bytep)png_malloc(png_ptr,
+                  (png_ptr->rowbytes + 1));
+               png_ptr->avg_row[0] = PNG_FILTER_VALUE_AVG;
+            }
+         }
+
+         if ((png_ptr->do_filter & PNG_FILTER_PAETH) &&
+             png_ptr->paeth_row == NULL)
+         {
+            if (png_ptr->prev_row == NULL)
+            {
+               png_warning(png_ptr, "Can't add Paeth filter after starting");
+               png_ptr->do_filter &= (png_byte)(~PNG_FILTER_PAETH);
+            }
+            else
+            {
+               png_ptr->paeth_row = (png_bytep)png_malloc(png_ptr,
+                  (png_ptr->rowbytes + 1));
+               png_ptr->paeth_row[0] = PNG_FILTER_VALUE_PAETH;
+            }
+         }
+
+         if (png_ptr->do_filter == PNG_NO_FILTERS)
+            png_ptr->do_filter = PNG_FILTER_NONE;
+      }
+   }
+   else
+      png_error(png_ptr, "Unknown custom filter method");
+}
+
+/* This allows us to influence the way in which libpng chooses the "best"
+ * filter for the current scanline.  While the "minimum-sum-of-absolute-
+ * differences metric is relatively fast and effective, there is some
+ * question as to whether it can be improved upon by trying to keep the
+ * filtered data going to zlib more consistent, hopefully resulting in
+ * better compression.
+ */
+#if defined(PNG_WRITE_WEIGHTED_FILTER_SUPPORTED)      /* GRR 970116 */
+void PNGAPI
+png_set_filter_heuristics(png_structp png_ptr, int heuristic_method,
+   int num_weights, png_doublep filter_weights,
+   png_doublep filter_costs)
+{
+   int i;
+
+   png_debug(1, "in png_set_filter_heuristics\n");
+   if (heuristic_method >= PNG_FILTER_HEURISTIC_LAST)
+   {
+      png_warning(png_ptr, "Unknown filter heuristic method");
+      return;
+   }
+
+   if (heuristic_method == PNG_FILTER_HEURISTIC_DEFAULT)
+   {
+      heuristic_method = PNG_FILTER_HEURISTIC_UNWEIGHTED;
+   }
+
+   if (num_weights < 0 || filter_weights == NULL ||
+      heuristic_method == PNG_FILTER_HEURISTIC_UNWEIGHTED)
+   {
+      num_weights = 0;
+   }
+
+   png_ptr->num_prev_filters = (png_byte)num_weights;
+   png_ptr->heuristic_method = (png_byte)heuristic_method;
+
+   if (num_weights > 0)
+   {
+      if (png_ptr->prev_filters == NULL)
+      {
+         png_ptr->prev_filters = (png_bytep)png_malloc(png_ptr,
+            (png_uint_32)(sizeof(png_byte) * num_weights));
+
+         /* To make sure that the weighting starts out fairly */
+         for (i = 0; i < num_weights; i++)
+         {
+            png_ptr->prev_filters[i] = 255;
+         }
+      }
+
+      if (png_ptr->filter_weights == NULL)
+      {
+         png_ptr->filter_weights = (png_uint_16p)png_malloc(png_ptr,
+            (png_uint_32)(sizeof(png_uint_16) * num_weights));
+
+         png_ptr->inv_filter_weights = (png_uint_16p)png_malloc(png_ptr,
+            (png_uint_32)(sizeof(png_uint_16) * num_weights));
+         for (i = 0; i < num_weights; i++)
+         {
+            png_ptr->inv_filter_weights[i] =
+            png_ptr->filter_weights[i] = PNG_WEIGHT_FACTOR;
+         }
+      }
+
+      for (i = 0; i < num_weights; i++)
+      {
+         if (filter_weights[i] < 0.0)
+         {
+            png_ptr->inv_filter_weights[i] =
+            png_ptr->filter_weights[i] = PNG_WEIGHT_FACTOR;
+         }
+         else
+         {
+            png_ptr->inv_filter_weights[i] =
+               (png_uint_16)((double)PNG_WEIGHT_FACTOR*filter_weights[i]+0.5);
+            png_ptr->filter_weights[i] =
+               (png_uint_16)((double)PNG_WEIGHT_FACTOR/filter_weights[i]+0.5);
+         }
+      }
+   }
+
+   /* If, in the future, there are other filter methods, this would
+    * need to be based on png_ptr->filter.
+    */
+   if (png_ptr->filter_costs == NULL)
+   {
+      png_ptr->filter_costs = (png_uint_16p)png_malloc(png_ptr,
+         (png_uint_32)(sizeof(png_uint_16) * PNG_FILTER_VALUE_LAST));
+
+      png_ptr->inv_filter_costs = (png_uint_16p)png_malloc(png_ptr,
+         (png_uint_32)(sizeof(png_uint_16) * PNG_FILTER_VALUE_LAST));
+
+      for (i = 0; i < PNG_FILTER_VALUE_LAST; i++)
+      {
+         png_ptr->inv_filter_costs[i] =
+         png_ptr->filter_costs[i] = PNG_COST_FACTOR;
+      }
+   }
+
+   /* Here is where we set the relative costs of the different filters.  We
+    * should take the desired compression level into account when setting
+    * the costs, so that Paeth, for instance, has a high relative cost at low
+    * compression levels, while it has a lower relative cost at higher
+    * compression settings.  The filter types are in order of increasing
+    * relative cost, so it would be possible to do this with an algorithm.
+    */
+   for (i = 0; i < PNG_FILTER_VALUE_LAST; i++)
+   {
+      if (filter_costs == NULL || filter_costs[i] < 0.0)
+      {
+         png_ptr->inv_filter_costs[i] =
+         png_ptr->filter_costs[i] = PNG_COST_FACTOR;
+      }
+      else if (filter_costs[i] >= 1.0)
+      {
+         png_ptr->inv_filter_costs[i] =
+            (png_uint_16)((double)PNG_COST_FACTOR / filter_costs[i] + 0.5);
+         png_ptr->filter_costs[i] =
+            (png_uint_16)((double)PNG_COST_FACTOR * filter_costs[i] + 0.5);
+      }
+   }
+}
+#endif /* PNG_WRITE_WEIGHTED_FILTER_SUPPORTED */
+
+void PNGAPI
+png_set_compression_level(png_structp png_ptr, int level)
+{
+   png_debug(1, "in png_set_compression_level\n");
+   png_ptr->flags |= PNG_FLAG_ZLIB_CUSTOM_LEVEL;
+   png_ptr->zlib_level = level;
+}
+
+void PNGAPI
+png_set_compression_mem_level(png_structp png_ptr, int mem_level)
+{
+   png_debug(1, "in png_set_compression_mem_level\n");
+   png_ptr->flags |= PNG_FLAG_ZLIB_CUSTOM_MEM_LEVEL;
+   png_ptr->zlib_mem_level = mem_level;
+}
+
+void PNGAPI
+png_set_compression_strategy(png_structp png_ptr, int strategy)
+{
+   png_debug(1, "in png_set_compression_strategy\n");
+   png_ptr->flags |= PNG_FLAG_ZLIB_CUSTOM_STRATEGY;
+   png_ptr->zlib_strategy = strategy;
+}
+
+void PNGAPI
+png_set_compression_window_bits(png_structp png_ptr, int window_bits)
+{
+   if (window_bits > 15)
+      png_warning(png_ptr, "Only compression windows <= 32k supported by PNG");
+   else if (window_bits < 8)
+      png_warning(png_ptr, "Only compression windows >= 256 supported by PNG");
+#ifndef WBITS_8_OK
+   /* avoid libpng bug with 256-byte windows */
+   if (window_bits == 8)
+     {
+       png_warning(png_ptr, "Compression window is being reset to 512");
+       window_bits=9;
+     }
+#endif
+   png_ptr->flags |= PNG_FLAG_ZLIB_CUSTOM_WINDOW_BITS;
+   png_ptr->zlib_window_bits = window_bits;
+}
+
+void PNGAPI
+png_set_compression_method(png_structp png_ptr, int method)
+{
+   png_debug(1, "in png_set_compression_method\n");
+   if (method != 8)
+      png_warning(png_ptr, "Only compression method 8 is supported by PNG");
+   png_ptr->flags |= PNG_FLAG_ZLIB_CUSTOM_METHOD;
+   png_ptr->zlib_method = method;
+}
+
+void PNGAPI
+png_set_write_status_fn(png_structp png_ptr, png_write_status_ptr write_row_fn)
+{
+   png_ptr->write_row_fn = write_row_fn;
+}
+
+#if defined(PNG_WRITE_USER_TRANSFORM_SUPPORTED)
+void PNGAPI
+png_set_write_user_transform_fn(png_structp png_ptr, png_user_transform_ptr
+   write_user_transform_fn)
+{
+   png_debug(1, "in png_set_write_user_transform_fn\n");
+   png_ptr->transformations |= PNG_USER_TRANSFORM;
+   png_ptr->write_user_transform_fn = write_user_transform_fn;
+}
+#endif
+
+
+#if defined(PNG_INFO_IMAGE_SUPPORTED)
+void PNGAPI
+png_write_png(png_structp png_ptr, png_infop info_ptr,
+              int transforms, voidp params)
+{
+#if defined(PNG_WRITE_INVERT_ALPHA_SUPPORTED)
+   /* invert the alpha channel from opacity to transparency */
+   if (transforms & PNG_TRANSFORM_INVERT_ALPHA)
+       png_set_invert_alpha(png_ptr);
+#endif
+
+   /* Write the file header information. */
+   png_write_info(png_ptr, info_ptr);
+
+   /* ------ these transformations don't touch the info structure ------- */
+
+#if defined(PNG_WRITE_INVERT_SUPPORTED)
+   /* invert monochrome pixels */
+   if (transforms & PNG_TRANSFORM_INVERT_MONO)
+       png_set_invert_mono(png_ptr);
+#endif
+
+#if defined(PNG_WRITE_SHIFT_SUPPORTED)
+   /* Shift the pixels up to a legal bit depth and fill in
+    * as appropriate to correctly scale the image.
+    */
+   if ((transforms & PNG_TRANSFORM_SHIFT)
+               && (info_ptr->valid & PNG_INFO_sBIT))
+       png_set_shift(png_ptr, &info_ptr->sig_bit);
+#endif
+
+#if defined(PNG_WRITE_PACK_SUPPORTED)
+   /* pack pixels into bytes */
+   if (transforms & PNG_TRANSFORM_PACKING)
+       png_set_packing(png_ptr);
+#endif
+
+#if defined(PNG_WRITE_SWAP_ALPHA_SUPPORTED)
+   /* swap location of alpha bytes from ARGB to RGBA */
+   if (transforms & PNG_TRANSFORM_SWAP_ALPHA)
+       png_set_swap_alpha(png_ptr);
+#endif
+
+#if defined(PNG_WRITE_FILLER_SUPPORTED)
+   /* Get rid of filler (OR ALPHA) bytes, pack XRGB/RGBX/ARGB/RGBA into
+    * RGB (4 channels -> 3 channels). The second parameter is not used.
+    */
+   if (transforms & PNG_TRANSFORM_STRIP_FILLER)
+       png_set_filler(png_ptr, 0, PNG_FILLER_BEFORE);
+#endif
+
+#if defined(PNG_WRITE_BGR_SUPPORTED)
+   /* flip BGR pixels to RGB */
+   if (transforms & PNG_TRANSFORM_BGR)
+       png_set_bgr(png_ptr);
+#endif
+
+#if defined(PNG_WRITE_SWAP_SUPPORTED)
+   /* swap bytes of 16-bit files to most significant byte first */
+   if (transforms & PNG_TRANSFORM_SWAP_ENDIAN)
+       png_set_swap(png_ptr);
+#endif
+
+#if defined(PNG_WRITE_PACKSWAP_SUPPORTED)
+   /* swap bits of 1, 2, 4 bit packed pixel formats */
+   if (transforms & PNG_TRANSFORM_PACKSWAP)
+       png_set_packswap(png_ptr);
+#endif
+
+   /* ----------------------- end of transformations ------------------- */
+
+   /* write the bits */
+   if (info_ptr->valid & PNG_INFO_IDAT)
+       png_write_image(png_ptr, info_ptr->row_pointers);
+
+   /* It is REQUIRED to call this to finish writing the rest of the file */
+   png_write_end(png_ptr, info_ptr);
+
+   if(transforms == 0 || params == NULL)
+      /* quiet compiler warnings */ return;
+}
+#endif
+#endif /* PNG_WRITE_SUPPORTED */
diff --git a/collects/plot/src/all/pngwtran.c b/collects/plot/src/all/pngwtran.c
new file mode 100644
index 0000000000..c28da116b7
--- /dev/null
+++ b/collects/plot/src/all/pngwtran.c
@@ -0,0 +1,563 @@
+
+/* pngwtran.c - transforms the data in a row for PNG writers
+ *
+ * libpng 1.2.5 - October 3, 2002
+ * For conditions of distribution and use, see copyright notice in png.h
+ * Copyright (c) 1998-2002 Glenn Randers-Pehrson
+ * (Version 0.96 Copyright (c) 1996, 1997 Andreas Dilger)
+ * (Version 0.88 Copyright (c) 1995, 1996 Guy Eric Schalnat, Group 42, Inc.)
+ */
+
+#define PNG_INTERNAL
+#include "png.h"
+#ifdef PNG_WRITE_SUPPORTED
+
+/* Transform the data according to the user's wishes.  The order of
+ * transformations is significant.
+ */
+void /* PRIVATE */
+png_do_write_transformations(png_structp png_ptr)
+{
+   png_debug(1, "in png_do_write_transformations\n");
+
+   if (png_ptr == NULL)
+      return;
+
+#if defined(PNG_WRITE_USER_TRANSFORM_SUPPORTED)
+   if (png_ptr->transformations & PNG_USER_TRANSFORM)
+      if(png_ptr->write_user_transform_fn != NULL)
+        (*(png_ptr->write_user_transform_fn)) /* user write transform function */
+          (png_ptr,                    /* png_ptr */
+           &(png_ptr->row_info),       /* row_info:     */
+             /*  png_uint_32 width;          width of row */
+             /*  png_uint_32 rowbytes;       number of bytes in row */
+             /*  png_byte color_type;        color type of pixels */
+             /*  png_byte bit_depth;         bit depth of samples */
+             /*  png_byte channels;          number of channels (1-4) */
+             /*  png_byte pixel_depth;       bits per pixel (depth*channels) */
+           png_ptr->row_buf + 1);      /* start of pixel data for row */
+#endif
+#if defined(PNG_WRITE_FILLER_SUPPORTED)
+   if (png_ptr->transformations & PNG_FILLER)
+      png_do_strip_filler(&(png_ptr->row_info), png_ptr->row_buf + 1,
+         png_ptr->flags);
+#endif
+#if defined(PNG_WRITE_PACKSWAP_SUPPORTED)
+   if (png_ptr->transformations & PNG_PACKSWAP)
+      png_do_packswap(&(png_ptr->row_info), png_ptr->row_buf + 1);
+#endif
+#if defined(PNG_WRITE_PACK_SUPPORTED)
+   if (png_ptr->transformations & PNG_PACK)
+      png_do_pack(&(png_ptr->row_info), png_ptr->row_buf + 1,
+         (png_uint_32)png_ptr->bit_depth);
+#endif
+#if defined(PNG_WRITE_SWAP_SUPPORTED)
+   if (png_ptr->transformations & PNG_SWAP_BYTES)
+      png_do_swap(&(png_ptr->row_info), png_ptr->row_buf + 1);
+#endif
+#if defined(PNG_WRITE_SHIFT_SUPPORTED)
+   if (png_ptr->transformations & PNG_SHIFT)
+      png_do_shift(&(png_ptr->row_info), png_ptr->row_buf + 1,
+         &(png_ptr->shift));
+#endif
+#if defined(PNG_WRITE_INVERT_ALPHA_SUPPORTED)
+   if (png_ptr->transformations & PNG_INVERT_ALPHA)
+      png_do_write_invert_alpha(&(png_ptr->row_info), png_ptr->row_buf + 1);
+#endif
+#if defined(PNG_WRITE_SWAP_ALPHA_SUPPORTED)
+   if (png_ptr->transformations & PNG_SWAP_ALPHA)
+      png_do_write_swap_alpha(&(png_ptr->row_info), png_ptr->row_buf + 1);
+#endif
+#if defined(PNG_WRITE_BGR_SUPPORTED)
+   if (png_ptr->transformations & PNG_BGR)
+      png_do_bgr(&(png_ptr->row_info), png_ptr->row_buf + 1);
+#endif
+#if defined(PNG_WRITE_INVERT_SUPPORTED)
+   if (png_ptr->transformations & PNG_INVERT_MONO)
+      png_do_invert(&(png_ptr->row_info), png_ptr->row_buf + 1);
+#endif
+}
+
+#if defined(PNG_WRITE_PACK_SUPPORTED)
+/* Pack pixels into bytes.  Pass the true bit depth in bit_depth.  The
+ * row_info bit depth should be 8 (one pixel per byte).  The channels
+ * should be 1 (this only happens on grayscale and paletted images).
+ */
+void /* PRIVATE */
+png_do_pack(png_row_infop row_info, png_bytep row, png_uint_32 bit_depth)
+{
+   png_debug(1, "in png_do_pack\n");
+   if (row_info->bit_depth == 8 &&
+#if defined(PNG_USELESS_TESTS_SUPPORTED)
+       row != NULL && row_info != NULL &&
+#endif
+      row_info->channels == 1)
+   {
+      switch ((int)bit_depth)
+      {
+         case 1:
+         {
+            png_bytep sp, dp;
+            int mask, v;
+            png_uint_32 i;
+            png_uint_32 row_width = row_info->width;
+
+            sp = row;
+            dp = row;
+            mask = 0x80;
+            v = 0;
+
+            for (i = 0; i < row_width; i++)
+            {
+               if (*sp != 0)
+                  v |= mask;
+               sp++;
+               if (mask > 1)
+                  mask >>= 1;
+               else
+               {
+                  mask = 0x80;
+                  *dp = (png_byte)v;
+                  dp++;
+                  v = 0;
+               }
+            }
+            if (mask != 0x80)
+               *dp = (png_byte)v;
+            break;
+         }
+         case 2:
+         {
+            png_bytep sp, dp;
+            int shift, v;
+            png_uint_32 i;
+            png_uint_32 row_width = row_info->width;
+
+            sp = row;
+            dp = row;
+            shift = 6;
+            v = 0;
+            for (i = 0; i < row_width; i++)
+            {
+               png_byte value;
+
+               value = (png_byte)(*sp & 0x03);
+               v |= (value << shift);
+               if (shift == 0)
+               {
+                  shift = 6;
+                  *dp = (png_byte)v;
+                  dp++;
+                  v = 0;
+               }
+               else
+                  shift -= 2;
+               sp++;
+            }
+            if (shift != 6)
+               *dp = (png_byte)v;
+            break;
+         }
+         case 4:
+         {
+            png_bytep sp, dp;
+            int shift, v;
+            png_uint_32 i;
+            png_uint_32 row_width = row_info->width;
+
+            sp = row;
+            dp = row;
+            shift = 4;
+            v = 0;
+            for (i = 0; i < row_width; i++)
+            {
+               png_byte value;
+
+               value = (png_byte)(*sp & 0x0f);
+               v |= (value << shift);
+
+               if (shift == 0)
+               {
+                  shift = 4;
+                  *dp = (png_byte)v;
+                  dp++;
+                  v = 0;
+               }
+               else
+                  shift -= 4;
+
+               sp++;
+            }
+            if (shift != 4)
+               *dp = (png_byte)v;
+            break;
+         }
+      }
+      row_info->bit_depth = (png_byte)bit_depth;
+      row_info->pixel_depth = (png_byte)(bit_depth * row_info->channels);
+      row_info->rowbytes =
+         ((row_info->width * row_info->pixel_depth + 7) >> 3);
+   }
+}
+#endif
+
+#if defined(PNG_WRITE_SHIFT_SUPPORTED)
+/* Shift pixel values to take advantage of whole range.  Pass the
+ * true number of bits in bit_depth.  The row should be packed
+ * according to row_info->bit_depth.  Thus, if you had a row of
+ * bit depth 4, but the pixels only had values from 0 to 7, you
+ * would pass 3 as bit_depth, and this routine would translate the
+ * data to 0 to 15.
+ */
+void /* PRIVATE */
+png_do_shift(png_row_infop row_info, png_bytep row, png_color_8p bit_depth)
+{
+   png_debug(1, "in png_do_shift\n");
+#if defined(PNG_USELESS_TESTS_SUPPORTED)
+   if (row != NULL && row_info != NULL &&
+#else
+   if (
+#endif
+      row_info->color_type != PNG_COLOR_TYPE_PALETTE)
+   {
+      int shift_start[4], shift_dec[4];
+      int channels = 0;
+
+      if (row_info->color_type & PNG_COLOR_MASK_COLOR)
+      {
+         shift_start[channels] = row_info->bit_depth - bit_depth->red;
+         shift_dec[channels] = bit_depth->red;
+         channels++;
+         shift_start[channels] = row_info->bit_depth - bit_depth->green;
+         shift_dec[channels] = bit_depth->green;
+         channels++;
+         shift_start[channels] = row_info->bit_depth - bit_depth->blue;
+         shift_dec[channels] = bit_depth->blue;
+         channels++;
+      }
+      else
+      {
+         shift_start[channels] = row_info->bit_depth - bit_depth->gray;
+         shift_dec[channels] = bit_depth->gray;
+         channels++;
+      }
+      if (row_info->color_type & PNG_COLOR_MASK_ALPHA)
+      {
+         shift_start[channels] = row_info->bit_depth - bit_depth->alpha;
+         shift_dec[channels] = bit_depth->alpha;
+         channels++;
+      }
+
+      /* with low row depths, could only be grayscale, so one channel */
+      if (row_info->bit_depth < 8)
+      {
+         png_bytep bp = row;
+         png_uint_32 i;
+         png_byte mask;
+         png_uint_32 row_bytes = row_info->rowbytes;
+
+         if (bit_depth->gray == 1 && row_info->bit_depth == 2)
+            mask = 0x55;
+         else if (row_info->bit_depth == 4 && bit_depth->gray == 3)
+            mask = 0x11;
+         else
+            mask = 0xff;
+
+         for (i = 0; i < row_bytes; i++, bp++)
+         {
+            png_uint_16 v;
+            int j;
+
+            v = *bp;
+            *bp = 0;
+            for (j = shift_start[0]; j > -shift_dec[0]; j -= shift_dec[0])
+            {
+               if (j > 0)
+                  *bp |= (png_byte)((v << j) & 0xff);
+               else
+                  *bp |= (png_byte)((v >> (-j)) & mask);
+            }
+         }
+      }
+      else if (row_info->bit_depth == 8)
+      {
+         png_bytep bp = row;
+         png_uint_32 i;
+         png_uint_32 istop = channels * row_info->width;
+
+         for (i = 0; i < istop; i++, bp++)
+         {
+
+            png_uint_16 v;
+            int j;
+            int c = (int)(i%channels);
+
+            v = *bp;
+            *bp = 0;
+            for (j = shift_start[c]; j > -shift_dec[c]; j -= shift_dec[c])
+            {
+               if (j > 0)
+                  *bp |= (png_byte)((v << j) & 0xff);
+               else
+                  *bp |= (png_byte)((v >> (-j)) & 0xff);
+            }
+         }
+      }
+      else
+      {
+         png_bytep bp;
+         png_uint_32 i;
+         png_uint_32 istop = channels * row_info->width;
+
+         for (bp = row, i = 0; i < istop; i++)
+         {
+            int c = (int)(i%channels);
+            png_uint_16 value, v;
+            int j;
+
+            v = (png_uint_16)(((png_uint_16)(*bp) << 8) + *(bp + 1));
+            value = 0;
+            for (j = shift_start[c]; j > -shift_dec[c]; j -= shift_dec[c])
+            {
+               if (j > 0)
+                  value |= (png_uint_16)((v << j) & (png_uint_16)0xffff);
+               else
+                  value |= (png_uint_16)((v >> (-j)) & (png_uint_16)0xffff);
+            }
+            *bp++ = (png_byte)(value >> 8);
+            *bp++ = (png_byte)(value & 0xff);
+         }
+      }
+   }
+}
+#endif
+
+#if defined(PNG_WRITE_SWAP_ALPHA_SUPPORTED)
+void /* PRIVATE */
+png_do_write_swap_alpha(png_row_infop row_info, png_bytep row)
+{
+   png_debug(1, "in png_do_write_swap_alpha\n");
+#if defined(PNG_USELESS_TESTS_SUPPORTED)
+   if (row != NULL && row_info != NULL)
+#endif
+   {
+      if (row_info->color_type == PNG_COLOR_TYPE_RGB_ALPHA)
+      {
+         /* This converts from ARGB to RGBA */
+         if (row_info->bit_depth == 8)
+         {
+            png_bytep sp, dp;
+            png_uint_32 i;
+            png_uint_32 row_width = row_info->width;
+            for (i = 0, sp = dp = row; i < row_width; i++)
+            {
+               png_byte save = *(sp++);
+               *(dp++) = *(sp++);
+               *(dp++) = *(sp++);
+               *(dp++) = *(sp++);
+               *(dp++) = save;
+            }
+         }
+         /* This converts from AARRGGBB to RRGGBBAA */
+         else
+         {
+            png_bytep sp, dp;
+            png_uint_32 i;
+            png_uint_32 row_width = row_info->width;
+
+            for (i = 0, sp = dp = row; i < row_width; i++)
+            {
+               png_byte save[2];
+               save[0] = *(sp++);
+               save[1] = *(sp++);
+               *(dp++) = *(sp++);
+               *(dp++) = *(sp++);
+               *(dp++) = *(sp++);
+               *(dp++) = *(sp++);
+               *(dp++) = *(sp++);
+               *(dp++) = *(sp++);
+               *(dp++) = save[0];
+               *(dp++) = save[1];
+            }
+         }
+      }
+      else if (row_info->color_type == PNG_COLOR_TYPE_GRAY_ALPHA)
+      {
+         /* This converts from AG to GA */
+         if (row_info->bit_depth == 8)
+         {
+            png_bytep sp, dp;
+            png_uint_32 i;
+            png_uint_32 row_width = row_info->width;
+
+            for (i = 0, sp = dp = row; i < row_width; i++)
+            {
+               png_byte save = *(sp++);
+               *(dp++) = *(sp++);
+               *(dp++) = save;
+            }
+         }
+         /* This converts from AAGG to GGAA */
+         else
+         {
+            png_bytep sp, dp;
+            png_uint_32 i;
+            png_uint_32 row_width = row_info->width;
+
+            for (i = 0, sp = dp = row; i < row_width; i++)
+            {
+               png_byte save[2];
+               save[0] = *(sp++);
+               save[1] = *(sp++);
+               *(dp++) = *(sp++);
+               *(dp++) = *(sp++);
+               *(dp++) = save[0];
+               *(dp++) = save[1];
+            }
+         }
+      }
+   }
+}
+#endif
+
+#if defined(PNG_WRITE_INVERT_ALPHA_SUPPORTED)
+void /* PRIVATE */
+png_do_write_invert_alpha(png_row_infop row_info, png_bytep row)
+{
+   png_debug(1, "in png_do_write_invert_alpha\n");
+#if defined(PNG_USELESS_TESTS_SUPPORTED)
+   if (row != NULL && row_info != NULL)
+#endif
+   {
+      if (row_info->color_type == PNG_COLOR_TYPE_RGB_ALPHA)
+      {
+         /* This inverts the alpha channel in RGBA */
+         if (row_info->bit_depth == 8)
+         {
+            png_bytep sp, dp;
+            png_uint_32 i;
+            png_uint_32 row_width = row_info->width;
+            for (i = 0, sp = dp = row; i < row_width; i++)
+            {
+               *(dp++) = *(sp++);
+               *(dp++) = *(sp++);
+               *(dp++) = *(sp++);
+               *(dp++) = (png_byte)(255 - *(sp++));
+            }
+         }
+         /* This inverts the alpha channel in RRGGBBAA */
+         else
+         {
+            png_bytep sp, dp;
+            png_uint_32 i;
+            png_uint_32 row_width = row_info->width;
+
+            for (i = 0, sp = dp = row; i < row_width; i++)
+            {
+               *(dp++) = *(sp++);
+               *(dp++) = *(sp++);
+               *(dp++) = *(sp++);
+               *(dp++) = *(sp++);
+               *(dp++) = *(sp++);
+               *(dp++) = *(sp++);
+               *(dp++) = (png_byte)(255 - *(sp++));
+               *(dp++) = (png_byte)(255 - *(sp++));
+            }
+         }
+      }
+      else if (row_info->color_type == PNG_COLOR_TYPE_GRAY_ALPHA)
+      {
+         /* This inverts the alpha channel in GA */
+         if (row_info->bit_depth == 8)
+         {
+            png_bytep sp, dp;
+            png_uint_32 i;
+            png_uint_32 row_width = row_info->width;
+
+            for (i = 0, sp = dp = row; i < row_width; i++)
+            {
+               *(dp++) = *(sp++);
+               *(dp++) = (png_byte)(255 - *(sp++));
+            }
+         }
+         /* This inverts the alpha channel in GGAA */
+         else
+         {
+            png_bytep sp, dp;
+            png_uint_32 i;
+            png_uint_32 row_width = row_info->width;
+
+            for (i = 0, sp = dp = row; i < row_width; i++)
+            {
+               *(dp++) = *(sp++);
+               *(dp++) = *(sp++);
+               *(dp++) = (png_byte)(255 - *(sp++));
+               *(dp++) = (png_byte)(255 - *(sp++));
+            }
+         }
+      }
+   }
+}
+#endif
+
+#if defined(PNG_MNG_FEATURES_SUPPORTED)
+/* undoes intrapixel differencing  */
+void /* PRIVATE */
+png_do_write_intrapixel(png_row_infop row_info, png_bytep row)
+{
+   png_debug(1, "in png_do_write_intrapixel\n");
+   if (
+#if defined(PNG_USELESS_TESTS_SUPPORTED)
+       row != NULL && row_info != NULL &&
+#endif
+       (row_info->color_type & PNG_COLOR_MASK_COLOR))
+   {
+      int bytes_per_pixel;
+      png_uint_32 row_width = row_info->width;
+      if (row_info->bit_depth == 8)
+      {
+         png_bytep rp;
+         png_uint_32 i;
+
+         if (row_info->color_type == PNG_COLOR_TYPE_RGB)
+            bytes_per_pixel = 3;
+         else if (row_info->color_type == PNG_COLOR_TYPE_RGB_ALPHA)
+            bytes_per_pixel = 4;
+         else
+            return;
+
+         for (i = 0, rp = row; i < row_width; i++, rp += bytes_per_pixel)
+         {
+            *(rp)   = (png_byte)((*rp     - *(rp+1))&0xff);
+            *(rp+2) = (png_byte)((*(rp+2) - *(rp+1))&0xff);
+         }
+      }
+      else if (row_info->bit_depth == 16)
+      {
+         png_bytep rp;
+         png_uint_32 i;
+
+         if (row_info->color_type == PNG_COLOR_TYPE_RGB)
+            bytes_per_pixel = 6;
+         else if (row_info->color_type == PNG_COLOR_TYPE_RGB_ALPHA)
+            bytes_per_pixel = 8;
+         else
+            return;
+
+         for (i = 0, rp = row; i < row_width; i++, rp += bytes_per_pixel)
+         {
+            png_uint_32 s0=*(rp  )<<8 | *(rp+1);
+            png_uint_32 s1=*(rp+2)<<8 | *(rp+3);
+            png_uint_32 s2=*(rp+4)<<8 | *(rp+5);
+            png_uint_32 red=(s0-s1)&0xffff;
+            png_uint_32 blue=(s2-s1)&0xffff;
+            *(rp  ) = (png_byte)((red>>8)&0xff);
+            *(rp+1) = (png_byte)(red&0xff);
+            *(rp+4) = (png_byte)((blue>>8)&0xff);
+            *(rp+5) = (png_byte)(blue&0xff);
+         }
+      }
+   }
+}
+#endif /* PNG_MNG_FEATURES_SUPPORTED */
+#endif /* PNG_WRITE_SUPPORTED */
diff --git a/collects/plot/src/all/pngwutil.c b/collects/plot/src/all/pngwutil.c
new file mode 100644
index 0000000000..4b5ab6c87e
--- /dev/null
+++ b/collects/plot/src/all/pngwutil.c
@@ -0,0 +1,2675 @@
+
+/* pngwutil.c - utilities to write a PNG file
+ *
+ * libpng 1.2.5 - October 3, 2002
+ * For conditions of distribution and use, see copyright notice in png.h
+ * Copyright (c) 1998-2002 Glenn Randers-Pehrson
+ * (Version 0.96 Copyright (c) 1996, 1997 Andreas Dilger)
+ * (Version 0.88 Copyright (c) 1995, 1996 Guy Eric Schalnat, Group 42, Inc.)
+ */
+
+#define PNG_INTERNAL
+#include "png.h"
+#ifdef PNG_WRITE_SUPPORTED
+
+/* Place a 32-bit number into a buffer in PNG byte order.  We work
+ * with unsigned numbers for convenience, although one supported
+ * ancillary chunk uses signed (two's complement) numbers.
+ */
+void /* PRIVATE */
+png_save_uint_32(png_bytep buf, png_uint_32 i)
+{
+   buf[0] = (png_byte)((i >> 24) & 0xff);
+   buf[1] = (png_byte)((i >> 16) & 0xff);
+   buf[2] = (png_byte)((i >> 8) & 0xff);
+   buf[3] = (png_byte)(i & 0xff);
+}
+
+#if defined(PNG_WRITE_pCAL_SUPPORTED) || defined(PNG_WRITE_oFFs_SUPPORTED)
+/* The png_save_int_32 function assumes integers are stored in two's
+ * complement format.  If this isn't the case, then this routine needs to
+ * be modified to write data in two's complement format.
+ */
+void /* PRIVATE */
+png_save_int_32(png_bytep buf, png_int_32 i)
+{
+   buf[0] = (png_byte)((i >> 24) & 0xff);
+   buf[1] = (png_byte)((i >> 16) & 0xff);
+   buf[2] = (png_byte)((i >> 8) & 0xff);
+   buf[3] = (png_byte)(i & 0xff);
+}
+#endif
+
+/* Place a 16-bit number into a buffer in PNG byte order.
+ * The parameter is declared unsigned int, not png_uint_16,
+ * just to avoid potential problems on pre-ANSI C compilers.
+ */
+void /* PRIVATE */
+png_save_uint_16(png_bytep buf, unsigned int i)
+{
+   buf[0] = (png_byte)((i >> 8) & 0xff);
+   buf[1] = (png_byte)(i & 0xff);
+}
+
+/* Write a PNG chunk all at once.  The type is an array of ASCII characters
+ * representing the chunk name.  The array must be at least 4 bytes in
+ * length, and does not need to be null terminated.  To be safe, pass the
+ * pre-defined chunk names here, and if you need a new one, define it
+ * where the others are defined.  The length is the length of the data.
+ * All the data must be present.  If that is not possible, use the
+ * png_write_chunk_start(), png_write_chunk_data(), and png_write_chunk_end()
+ * functions instead.
+ */
+void PNGAPI
+png_write_chunk(png_structp png_ptr, png_bytep chunk_name,
+   png_bytep data, png_size_t length)
+{
+   png_write_chunk_start(png_ptr, chunk_name, (png_uint_32)length);
+   png_write_chunk_data(png_ptr, data, length);
+   png_write_chunk_end(png_ptr);
+}
+
+/* Write the start of a PNG chunk.  The type is the chunk type.
+ * The total_length is the sum of the lengths of all the data you will be
+ * passing in png_write_chunk_data().
+ */
+void PNGAPI
+png_write_chunk_start(png_structp png_ptr, png_bytep chunk_name,
+   png_uint_32 length)
+{
+   png_byte buf[4];
+   png_debug2(0, "Writing %s chunk (%lu bytes)\n", chunk_name, length);
+
+   /* write the length */
+   png_save_uint_32(buf, length);
+   png_write_data(png_ptr, buf, (png_size_t)4);
+
+   /* write the chunk name */
+   png_write_data(png_ptr, chunk_name, (png_size_t)4);
+   /* reset the crc and run it over the chunk name */
+   png_reset_crc(png_ptr);
+   png_calculate_crc(png_ptr, chunk_name, (png_size_t)4);
+}
+
+/* Write the data of a PNG chunk started with png_write_chunk_start().
+ * Note that multiple calls to this function are allowed, and that the
+ * sum of the lengths from these calls *must* add up to the total_length
+ * given to png_write_chunk_start().
+ */
+void PNGAPI
+png_write_chunk_data(png_structp png_ptr, png_bytep data, png_size_t length)
+{
+   /* write the data, and run the CRC over it */
+   if (data != NULL && length > 0)
+   {
+      png_calculate_crc(png_ptr, data, length);
+      png_write_data(png_ptr, data, length);
+   }
+}
+
+/* Finish a chunk started with png_write_chunk_start(). */
+void PNGAPI
+png_write_chunk_end(png_structp png_ptr)
+{
+   png_byte buf[4];
+
+   /* write the crc */
+   png_save_uint_32(buf, png_ptr->crc);
+
+   png_write_data(png_ptr, buf, (png_size_t)4);
+}
+
+/* Simple function to write the signature.  If we have already written
+ * the magic bytes of the signature, or more likely, the PNG stream is
+ * being embedded into another stream and doesn't need its own signature,
+ * we should call png_set_sig_bytes() to tell libpng how many of the
+ * bytes have already been written.
+ */
+void /* PRIVATE */
+png_write_sig(png_structp png_ptr)
+{
+   png_byte png_signature[8] = {137, 80, 78, 71, 13, 10, 26, 10};
+   /* write the rest of the 8 byte signature */
+   png_write_data(png_ptr, &png_signature[png_ptr->sig_bytes],
+      (png_size_t)8 - png_ptr->sig_bytes);
+   if(png_ptr->sig_bytes < 3)
+      png_ptr->mode |= PNG_HAVE_PNG_SIGNATURE;
+}
+
+#if defined(PNG_WRITE_TEXT_SUPPORTED) || defined(PNG_WRITE_iCCP_SUPPORTED)
+/*
+ * This pair of functions encapsulates the operation of (a) compressing a
+ * text string, and (b) issuing it later as a series of chunk data writes.
+ * The compression_state structure is shared context for these functions
+ * set up by the caller in order to make the whole mess thread-safe.
+ */
+
+typedef struct
+{
+    char *input;   /* the uncompressed input data */
+    int input_len;   /* its length */
+    int num_output_ptr; /* number of output pointers used */
+    int max_output_ptr; /* size of output_ptr */
+    png_charpp output_ptr; /* array of pointers to output */
+} compression_state;
+
+/* compress given text into storage in the png_ptr structure */
+static int /* PRIVATE */
+png_text_compress(png_structp png_ptr,
+        png_charp text, png_size_t text_len, int compression,
+        compression_state *comp)
+{
+   int ret;
+
+   comp->num_output_ptr = comp->max_output_ptr = 0;
+   comp->output_ptr = NULL;
+   comp->input = NULL;
+
+   /* we may just want to pass the text right through */
+   if (compression == PNG_TEXT_COMPRESSION_NONE)
+   {
+       comp->input = text;
+       comp->input_len = text_len;
+       return((int)text_len);
+   }
+
+   if (compression >= PNG_TEXT_COMPRESSION_LAST)
+   {
+#if !defined(PNG_NO_STDIO) && !defined(_WIN32_WCE)
+      char msg[50];
+      sprintf(msg, "Unknown compression type %d", compression);
+      png_warning(png_ptr, msg);
+#else
+      png_warning(png_ptr, "Unknown compression type");
+#endif
+   }
+
+   /* We can't write the chunk until we find out how much data we have,
+    * which means we need to run the compressor first and save the
+    * output.  This shouldn't be a problem, as the vast majority of
+    * comments should be reasonable, but we will set up an array of
+    * malloc'd pointers to be sure.
+    *
+    * If we knew the application was well behaved, we could simplify this
+    * greatly by assuming we can always malloc an output buffer large
+    * enough to hold the compressed text ((1001 * text_len / 1000) + 12)
+    * and malloc this directly.  The only time this would be a bad idea is
+    * if we can't malloc more than 64K and we have 64K of random input
+    * data, or if the input string is incredibly large (although this
+    * wouldn't cause a failure, just a slowdown due to swapping).
+    */
+
+   /* set up the compression buffers */
+   png_ptr->zstream.avail_in = (uInt)text_len;
+   png_ptr->zstream.next_in = (Bytef *)text;
+   png_ptr->zstream.avail_out = (uInt)png_ptr->zbuf_size;
+   png_ptr->zstream.next_out = (Bytef *)png_ptr->zbuf;
+
+   /* this is the same compression loop as in png_write_row() */
+   do
+   {
+      /* compress the data */
+      ret = deflate(&png_ptr->zstream, Z_NO_FLUSH);
+      if (ret != Z_OK)
+      {
+         /* error */
+         if (png_ptr->zstream.msg != NULL)
+            png_error(png_ptr, png_ptr->zstream.msg);
+         else
+            png_error(png_ptr, "zlib error");
+      }
+      /* check to see if we need more room */
+      if (!png_ptr->zstream.avail_out && png_ptr->zstream.avail_in)
+      {
+         /* make sure the output array has room */
+         if (comp->num_output_ptr >= comp->max_output_ptr)
+         {
+            int old_max;
+
+            old_max = comp->max_output_ptr;
+            comp->max_output_ptr = comp->num_output_ptr + 4;
+            if (comp->output_ptr != NULL)
+            {
+               png_charpp old_ptr;
+
+               old_ptr = comp->output_ptr;
+               comp->output_ptr = (png_charpp)png_malloc(png_ptr,
+                  (png_uint_32)(comp->max_output_ptr * sizeof (png_charpp)));
+               png_memcpy(comp->output_ptr, old_ptr, old_max
+                  * sizeof (png_charp));
+               png_free(png_ptr, old_ptr);
+            }
+            else
+               comp->output_ptr = (png_charpp)png_malloc(png_ptr,
+                  (png_uint_32)(comp->max_output_ptr * sizeof (png_charp)));
+         }
+
+         /* save the data */
+         comp->output_ptr[comp->num_output_ptr] = (png_charp)png_malloc(png_ptr,
+            (png_uint_32)png_ptr->zbuf_size);
+         png_memcpy(comp->output_ptr[comp->num_output_ptr], png_ptr->zbuf,
+            png_ptr->zbuf_size);
+         comp->num_output_ptr++;
+
+         /* and reset the buffer */
+         png_ptr->zstream.avail_out = (uInt)png_ptr->zbuf_size;
+         png_ptr->zstream.next_out = png_ptr->zbuf;
+      }
+   /* continue until we don't have any more to compress */
+   } while (png_ptr->zstream.avail_in);
+
+   /* finish the compression */
+   do
+   {
+      /* tell zlib we are finished */
+      ret = deflate(&png_ptr->zstream, Z_FINISH);
+
+      if (ret == Z_OK)
+      {
+         /* check to see if we need more room */
+         if (!(png_ptr->zstream.avail_out))
+         {
+            /* check to make sure our output array has room */
+            if (comp->num_output_ptr >= comp->max_output_ptr)
+            {
+               int old_max;
+
+               old_max = comp->max_output_ptr;
+               comp->max_output_ptr = comp->num_output_ptr + 4;
+               if (comp->output_ptr != NULL)
+               {
+                  png_charpp old_ptr;
+
+                  old_ptr = comp->output_ptr;
+                  /* This could be optimized to realloc() */
+                  comp->output_ptr = (png_charpp)png_malloc(png_ptr,
+                     (png_uint_32)(comp->max_output_ptr * sizeof (png_charpp)));
+                  png_memcpy(comp->output_ptr, old_ptr,
+                     old_max * sizeof (png_charp));
+                  png_free(png_ptr, old_ptr);
+               }
+               else
+                  comp->output_ptr = (png_charpp)png_malloc(png_ptr,
+                     (png_uint_32)(comp->max_output_ptr * sizeof (png_charp)));
+            }
+
+            /* save off the data */
+            comp->output_ptr[comp->num_output_ptr] =
+               (png_charp)png_malloc(png_ptr, (png_uint_32)png_ptr->zbuf_size);
+            png_memcpy(comp->output_ptr[comp->num_output_ptr], png_ptr->zbuf,
+               png_ptr->zbuf_size);
+            comp->num_output_ptr++;
+
+            /* and reset the buffer pointers */
+            png_ptr->zstream.avail_out = (uInt)png_ptr->zbuf_size;
+            png_ptr->zstream.next_out = png_ptr->zbuf;
+         }
+      }
+      else if (ret != Z_STREAM_END)
+      {
+         /* we got an error */
+         if (png_ptr->zstream.msg != NULL)
+            png_error(png_ptr, png_ptr->zstream.msg);
+         else
+            png_error(png_ptr, "zlib error");
+      }
+   } while (ret != Z_STREAM_END);
+
+   /* text length is number of buffers plus last buffer */
+   text_len = png_ptr->zbuf_size * comp->num_output_ptr;
+   if (png_ptr->zstream.avail_out < png_ptr->zbuf_size)
+      text_len += png_ptr->zbuf_size - (png_size_t)png_ptr->zstream.avail_out;
+
+   return((int)text_len);
+}
+
+/* ship the compressed text out via chunk writes */
+static void /* PRIVATE */
+png_write_compressed_data_out(png_structp png_ptr, compression_state *comp)
+{
+   int i;
+
+   /* handle the no-compression case */
+   if (comp->input)
+   {
+       png_write_chunk_data(png_ptr, (png_bytep)comp->input,
+                            (png_size_t)comp->input_len);
+       return;
+   }
+
+   /* write saved output buffers, if any */
+   for (i = 0; i < comp->num_output_ptr; i++)
+   {
+      png_write_chunk_data(png_ptr,(png_bytep)comp->output_ptr[i],
+         png_ptr->zbuf_size);
+      png_free(png_ptr, comp->output_ptr[i]);
+      comp->output_ptr[i]=NULL;
+   }
+   if (comp->max_output_ptr != 0)
+      png_free(png_ptr, comp->output_ptr);
+      comp->output_ptr=NULL;
+   /* write anything left in zbuf */
+   if (png_ptr->zstream.avail_out < (png_uint_32)png_ptr->zbuf_size)
+      png_write_chunk_data(png_ptr, png_ptr->zbuf,
+         png_ptr->zbuf_size - png_ptr->zstream.avail_out);
+
+   /* reset zlib for another zTXt/iTXt or the image data */
+   deflateReset(&png_ptr->zstream);
+
+}
+#endif
+
+/* Write the IHDR chunk, and update the png_struct with the necessary
+ * information.  Note that the rest of this code depends upon this
+ * information being correct.
+ */
+void /* PRIVATE */
+png_write_IHDR(png_structp png_ptr, png_uint_32 width, png_uint_32 height,
+   int bit_depth, int color_type, int compression_type, int filter_type,
+   int interlace_type)
+{
+#ifdef PNG_USE_LOCAL_ARRAYS
+   PNG_IHDR;
+#endif
+   png_byte buf[13]; /* buffer to store the IHDR info */
+
+   png_debug(1, "in png_write_IHDR\n");
+   /* Check that we have valid input data from the application info */
+   switch (color_type)
+   {
+      case PNG_COLOR_TYPE_GRAY:
+         switch (bit_depth)
+         {
+            case 1:
+            case 2:
+            case 4:
+            case 8:
+            case 16: png_ptr->channels = 1; break;
+            default: png_error(png_ptr,"Invalid bit depth for grayscale image");
+         }
+         break;
+      case PNG_COLOR_TYPE_RGB:
+         if (bit_depth != 8 && bit_depth != 16)
+            png_error(png_ptr, "Invalid bit depth for RGB image");
+         png_ptr->channels = 3;
+         break;
+      case PNG_COLOR_TYPE_PALETTE:
+         switch (bit_depth)
+         {
+            case 1:
+            case 2:
+            case 4:
+            case 8: png_ptr->channels = 1; break;
+            default: png_error(png_ptr, "Invalid bit depth for paletted image");
+         }
+         break;
+      case PNG_COLOR_TYPE_GRAY_ALPHA:
+         if (bit_depth != 8 && bit_depth != 16)
+            png_error(png_ptr, "Invalid bit depth for grayscale+alpha image");
+         png_ptr->channels = 2;
+         break;
+      case PNG_COLOR_TYPE_RGB_ALPHA:
+         if (bit_depth != 8 && bit_depth != 16)
+            png_error(png_ptr, "Invalid bit depth for RGBA image");
+         png_ptr->channels = 4;
+         break;
+      default:
+         png_error(png_ptr, "Invalid image color type specified");
+   }
+
+   if (compression_type != PNG_COMPRESSION_TYPE_BASE)
+   {
+      png_warning(png_ptr, "Invalid compression type specified");
+      compression_type = PNG_COMPRESSION_TYPE_BASE;
+   }
+
+   /* Write filter_method 64 (intrapixel differencing) only if
+    * 1. Libpng was compiled with PNG_MNG_FEATURES_SUPPORTED and
+    * 2. Libpng did not write a PNG signature (this filter_method is only
+    *    used in PNG datastreams that are embedded in MNG datastreams) and
+    * 3. The application called png_permit_mng_features with a mask that
+    *    included PNG_FLAG_MNG_FILTER_64 and
+    * 4. The filter_method is 64 and
+    * 5. The color_type is RGB or RGBA
+    */
+   if (
+#if defined(PNG_MNG_FEATURES_SUPPORTED)
+      !((png_ptr->mng_features_permitted & PNG_FLAG_MNG_FILTER_64) &&
+      ((png_ptr->mode&PNG_HAVE_PNG_SIGNATURE) == 0) &&
+      (color_type == PNG_COLOR_TYPE_RGB ||
+       color_type == PNG_COLOR_TYPE_RGB_ALPHA) &&
+      (filter_type == PNG_INTRAPIXEL_DIFFERENCING)) &&
+#endif
+      filter_type != PNG_FILTER_TYPE_BASE)
+   {
+      png_warning(png_ptr, "Invalid filter type specified");
+      filter_type = PNG_FILTER_TYPE_BASE;
+   }
+
+#ifdef PNG_WRITE_INTERLACING_SUPPORTED
+   if (interlace_type != PNG_INTERLACE_NONE &&
+      interlace_type != PNG_INTERLACE_ADAM7)
+   {
+      png_warning(png_ptr, "Invalid interlace type specified");
+      interlace_type = PNG_INTERLACE_ADAM7;
+   }
+#else
+   interlace_type=PNG_INTERLACE_NONE;
+#endif
+
+   /* save off the relevent information */
+   png_ptr->bit_depth = (png_byte)bit_depth;
+   png_ptr->color_type = (png_byte)color_type;
+   png_ptr->interlaced = (png_byte)interlace_type;
+#if defined(PNG_MNG_FEATURES_SUPPORTED)
+   png_ptr->filter_type = (png_byte)filter_type;
+#endif
+   png_ptr->width = width;
+   png_ptr->height = height;
+
+   png_ptr->pixel_depth = (png_byte)(bit_depth * png_ptr->channels);
+   png_ptr->rowbytes = ((width * (png_size_t)png_ptr->pixel_depth + 7) >> 3);
+   /* set the usr info, so any transformations can modify it */
+   png_ptr->usr_width = png_ptr->width;
+   png_ptr->usr_bit_depth = png_ptr->bit_depth;
+   png_ptr->usr_channels = png_ptr->channels;
+
+   /* pack the header information into the buffer */
+   png_save_uint_32(buf, width);
+   png_save_uint_32(buf + 4, height);
+   buf[8] = (png_byte)bit_depth;
+   buf[9] = (png_byte)color_type;
+   buf[10] = (png_byte)compression_type;
+   buf[11] = (png_byte)filter_type;
+   buf[12] = (png_byte)interlace_type;
+
+   /* write the chunk */
+   png_write_chunk(png_ptr, (png_bytep)png_IHDR, buf, (png_size_t)13);
+
+   /* initialize zlib with PNG info */
+   png_ptr->zstream.zalloc = png_zalloc;
+   png_ptr->zstream.zfree = png_zfree;
+   png_ptr->zstream.opaque = (voidpf)png_ptr;
+   if (!(png_ptr->do_filter))
+   {
+      if (png_ptr->color_type == PNG_COLOR_TYPE_PALETTE ||
+         png_ptr->bit_depth < 8)
+         png_ptr->do_filter = PNG_FILTER_NONE;
+      else
+         png_ptr->do_filter = PNG_ALL_FILTERS;
+   }
+   if (!(png_ptr->flags & PNG_FLAG_ZLIB_CUSTOM_STRATEGY))
+   {
+      if (png_ptr->do_filter != PNG_FILTER_NONE)
+         png_ptr->zlib_strategy = Z_FILTERED;
+      else
+         png_ptr->zlib_strategy = Z_DEFAULT_STRATEGY;
+   }
+   if (!(png_ptr->flags & PNG_FLAG_ZLIB_CUSTOM_LEVEL))
+      png_ptr->zlib_level = Z_DEFAULT_COMPRESSION;
+   if (!(png_ptr->flags & PNG_FLAG_ZLIB_CUSTOM_MEM_LEVEL))
+      png_ptr->zlib_mem_level = 8;
+   if (!(png_ptr->flags & PNG_FLAG_ZLIB_CUSTOM_WINDOW_BITS))
+      png_ptr->zlib_window_bits = 15;
+   if (!(png_ptr->flags & PNG_FLAG_ZLIB_CUSTOM_METHOD))
+      png_ptr->zlib_method = 8;
+   deflateInit2(&png_ptr->zstream, png_ptr->zlib_level,
+      png_ptr->zlib_method, png_ptr->zlib_window_bits,
+      png_ptr->zlib_mem_level, png_ptr->zlib_strategy);
+   png_ptr->zstream.next_out = png_ptr->zbuf;
+   png_ptr->zstream.avail_out = (uInt)png_ptr->zbuf_size;
+
+   png_ptr->mode = PNG_HAVE_IHDR;
+}
+
+/* write the palette.  We are careful not to trust png_color to be in the
+ * correct order for PNG, so people can redefine it to any convenient
+ * structure.
+ */
+void /* PRIVATE */
+png_write_PLTE(png_structp png_ptr, png_colorp palette, png_uint_32 num_pal)
+{
+#ifdef PNG_USE_LOCAL_ARRAYS
+   PNG_PLTE;
+#endif
+   png_uint_32 i;
+   png_colorp pal_ptr;
+   png_byte buf[3];
+
+   png_debug(1, "in png_write_PLTE\n");
+   if ((
+#if defined(PNG_MNG_FEATURES_SUPPORTED)
+        !(png_ptr->mng_features_permitted & PNG_FLAG_MNG_EMPTY_PLTE) &&
+#endif
+        num_pal == 0) || num_pal > 256)
+   {
+     if (png_ptr->color_type == PNG_COLOR_TYPE_PALETTE)
+     {
+        png_error(png_ptr, "Invalid number of colors in palette");
+     }
+     else
+     {
+        png_warning(png_ptr, "Invalid number of colors in palette");
+        return;
+     }
+   }
+
+   if (!(png_ptr->color_type&PNG_COLOR_MASK_COLOR))
+   {
+      png_warning(png_ptr,
+        "Ignoring request to write a PLTE chunk in grayscale PNG");
+      return;
+   }
+
+   png_ptr->num_palette = (png_uint_16)num_pal;
+   png_debug1(3, "num_palette = %d\n", png_ptr->num_palette);
+
+   png_write_chunk_start(png_ptr, (png_bytep)png_PLTE, num_pal * 3);
+#ifndef PNG_NO_POINTER_INDEXING
+   for (i = 0, pal_ptr = palette; i < num_pal; i++, pal_ptr++)
+   {
+      buf[0] = pal_ptr->red;
+      buf[1] = pal_ptr->green;
+      buf[2] = pal_ptr->blue;
+      png_write_chunk_data(png_ptr, buf, (png_size_t)3);
+   }
+#else
+   /* This is a little slower but some buggy compilers need to do this instead */
+   pal_ptr=palette;
+   for (i = 0; i < num_pal; i++)
+   {
+      buf[0] = pal_ptr[i].red;
+      buf[1] = pal_ptr[i].green;
+      buf[2] = pal_ptr[i].blue;
+      png_write_chunk_data(png_ptr, buf, (png_size_t)3);
+   }
+#endif
+   png_write_chunk_end(png_ptr);
+   png_ptr->mode |= PNG_HAVE_PLTE;
+}
+
+/* write an IDAT chunk */
+void /* PRIVATE */
+png_write_IDAT(png_structp png_ptr, png_bytep data, png_size_t length)
+{
+#ifdef PNG_USE_LOCAL_ARRAYS
+   PNG_IDAT;
+#endif
+   png_debug(1, "in png_write_IDAT\n");
+   png_write_chunk(png_ptr, (png_bytep)png_IDAT, data, length);
+   png_ptr->mode |= PNG_HAVE_IDAT;
+}
+
+/* write an IEND chunk */
+void /* PRIVATE */
+png_write_IEND(png_structp png_ptr)
+{
+#ifdef PNG_USE_LOCAL_ARRAYS
+   PNG_IEND;
+#endif
+   png_debug(1, "in png_write_IEND\n");
+   png_write_chunk(png_ptr, (png_bytep)png_IEND, png_bytep_NULL,
+     (png_size_t)0);
+   png_ptr->mode |= PNG_HAVE_IEND;
+}
+
+#if defined(PNG_WRITE_gAMA_SUPPORTED)
+/* write a gAMA chunk */
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+void /* PRIVATE */
+png_write_gAMA(png_structp png_ptr, double file_gamma)
+{
+#ifdef PNG_USE_LOCAL_ARRAYS
+   PNG_gAMA;
+#endif
+   png_uint_32 igamma;
+   png_byte buf[4];
+
+   png_debug(1, "in png_write_gAMA\n");
+   /* file_gamma is saved in 1/100,000ths */
+   igamma = (png_uint_32)(file_gamma * 100000.0 + 0.5);
+   png_save_uint_32(buf, igamma);
+   png_write_chunk(png_ptr, (png_bytep)png_gAMA, buf, (png_size_t)4);
+}
+#endif
+#ifdef PNG_FIXED_POINT_SUPPORTED
+void /* PRIVATE */
+png_write_gAMA_fixed(png_structp png_ptr, png_fixed_point file_gamma)
+{
+#ifdef PNG_USE_LOCAL_ARRAYS
+   PNG_gAMA;
+#endif
+   png_byte buf[4];
+
+   png_debug(1, "in png_write_gAMA\n");
+   /* file_gamma is saved in 1/100,000ths */
+   png_save_uint_32(buf, (png_uint_32)file_gamma);
+   png_write_chunk(png_ptr, (png_bytep)png_gAMA, buf, (png_size_t)4);
+}
+#endif
+#endif
+
+#if defined(PNG_WRITE_sRGB_SUPPORTED)
+/* write a sRGB chunk */
+void /* PRIVATE */
+png_write_sRGB(png_structp png_ptr, int srgb_intent)
+{
+#ifdef PNG_USE_LOCAL_ARRAYS
+   PNG_sRGB;
+#endif
+   png_byte buf[1];
+
+   png_debug(1, "in png_write_sRGB\n");
+   if(srgb_intent >= PNG_sRGB_INTENT_LAST)
+         png_warning(png_ptr,
+            "Invalid sRGB rendering intent specified");
+   buf[0]=(png_byte)srgb_intent;
+   png_write_chunk(png_ptr, (png_bytep)png_sRGB, buf, (png_size_t)1);
+}
+#endif
+
+#if defined(PNG_WRITE_iCCP_SUPPORTED)
+/* write an iCCP chunk */
+void /* PRIVATE */
+png_write_iCCP(png_structp png_ptr, png_charp name, int compression_type,
+   png_charp profile, int profile_len)
+{
+#ifdef PNG_USE_LOCAL_ARRAYS
+   PNG_iCCP;
+#endif
+   png_size_t name_len;
+   png_charp new_name;
+   compression_state comp;
+
+   png_debug(1, "in png_write_iCCP\n");
+   if (name == NULL || (name_len = png_check_keyword(png_ptr, name,
+      &new_name)) == 0)
+   {
+      png_warning(png_ptr, "Empty keyword in iCCP chunk");
+      return;
+   }
+
+   if (compression_type != PNG_COMPRESSION_TYPE_BASE)
+      png_warning(png_ptr, "Unknown compression type in iCCP chunk");
+
+   if (profile == NULL)
+      profile_len = 0;
+
+   if (profile_len)
+       profile_len = png_text_compress(png_ptr, profile, (png_size_t)profile_len,
+          PNG_COMPRESSION_TYPE_BASE, &comp);
+
+   /* make sure we include the NULL after the name and the compression type */
+   png_write_chunk_start(png_ptr, (png_bytep)png_iCCP,
+          (png_uint_32)name_len+profile_len+2);
+   new_name[name_len+1]=0x00;
+   png_write_chunk_data(png_ptr, (png_bytep)new_name, name_len + 2);
+
+   if (profile_len)
+      png_write_compressed_data_out(png_ptr, &comp);
+
+   png_write_chunk_end(png_ptr);
+   png_free(png_ptr, new_name);
+}
+#endif
+
+#if defined(PNG_WRITE_sPLT_SUPPORTED)
+/* write a sPLT chunk */
+void /* PRIVATE */
+png_write_sPLT(png_structp png_ptr, png_sPLT_tp spalette)
+{
+#ifdef PNG_USE_LOCAL_ARRAYS
+   PNG_sPLT;
+#endif
+   png_size_t name_len;
+   png_charp new_name;
+   png_byte entrybuf[10];
+   int entry_size = (spalette->depth == 8 ? 6 : 10);
+   int palette_size = entry_size * spalette->nentries;
+   png_sPLT_entryp ep;
+#ifdef PNG_NO_POINTER_INDEXING
+   int i;
+#endif
+
+   png_debug(1, "in png_write_sPLT\n");
+   if (spalette->name == NULL || (name_len = png_check_keyword(png_ptr,
+      spalette->name, &new_name))==0)
+   {
+      png_warning(png_ptr, "Empty keyword in sPLT chunk");
+      return;
+   }
+
+   /* make sure we include the NULL after the name */
+   png_write_chunk_start(png_ptr, (png_bytep)png_sPLT,
+          (png_uint_32)(name_len + 2 + palette_size));
+   png_write_chunk_data(png_ptr, (png_bytep)new_name, name_len + 1);
+   png_write_chunk_data(png_ptr, (png_bytep)&spalette->depth, 1);
+
+   /* loop through each palette entry, writing appropriately */
+#ifndef PNG_NO_POINTER_INDEXING
+   for (ep = spalette->entries; ep<spalette->entries+spalette->nentries; ep++)
+   {
+       if (spalette->depth == 8)
+       {
+           entrybuf[0] = (png_byte)ep->red;
+           entrybuf[1] = (png_byte)ep->green;
+           entrybuf[2] = (png_byte)ep->blue;
+           entrybuf[3] = (png_byte)ep->alpha;
+           png_save_uint_16(entrybuf + 4, ep->frequency);
+       }
+       else
+       {
+           png_save_uint_16(entrybuf + 0, ep->red);
+           png_save_uint_16(entrybuf + 2, ep->green);
+           png_save_uint_16(entrybuf + 4, ep->blue);
+           png_save_uint_16(entrybuf + 6, ep->alpha);
+           png_save_uint_16(entrybuf + 8, ep->frequency);
+       }
+       png_write_chunk_data(png_ptr, entrybuf, (png_size_t)entry_size);
+   }
+#else
+   ep=spalette->entries;
+   for (i=0; i>spalette->nentries; i++)
+   {
+       if (spalette->depth == 8)
+       {
+           entrybuf[0] = (png_byte)ep[i].red;
+           entrybuf[1] = (png_byte)ep[i].green;
+           entrybuf[2] = (png_byte)ep[i].blue;
+           entrybuf[3] = (png_byte)ep[i].alpha;
+           png_save_uint_16(entrybuf + 4, ep[i].frequency);
+       }
+       else
+       {
+           png_save_uint_16(entrybuf + 0, ep[i].red);
+           png_save_uint_16(entrybuf + 2, ep[i].green);
+           png_save_uint_16(entrybuf + 4, ep[i].blue);
+           png_save_uint_16(entrybuf + 6, ep[i].alpha);
+           png_save_uint_16(entrybuf + 8, ep[i].frequency);
+       }
+       png_write_chunk_data(png_ptr, entrybuf, entry_size);
+   }
+#endif
+
+   png_write_chunk_end(png_ptr);
+   png_free(png_ptr, new_name);
+}
+#endif
+
+#if defined(PNG_WRITE_sBIT_SUPPORTED)
+/* write the sBIT chunk */
+void /* PRIVATE */
+png_write_sBIT(png_structp png_ptr, png_color_8p sbit, int color_type)
+{
+#ifdef PNG_USE_LOCAL_ARRAYS
+   PNG_sBIT;
+#endif
+   png_byte buf[4];
+   png_size_t size;
+
+   png_debug(1, "in png_write_sBIT\n");
+   /* make sure we don't depend upon the order of PNG_COLOR_8 */
+   if (color_type & PNG_COLOR_MASK_COLOR)
+   {
+      png_byte maxbits;
+
+      maxbits = (png_byte)(color_type==PNG_COLOR_TYPE_PALETTE ? 8 :
+                png_ptr->usr_bit_depth);
+      if (sbit->red == 0 || sbit->red > maxbits ||
+          sbit->green == 0 || sbit->green > maxbits ||
+          sbit->blue == 0 || sbit->blue > maxbits)
+      {
+         png_warning(png_ptr, "Invalid sBIT depth specified");
+         return;
+      }
+      buf[0] = sbit->red;
+      buf[1] = sbit->green;
+      buf[2] = sbit->blue;
+      size = 3;
+   }
+   else
+   {
+      if (sbit->gray == 0 || sbit->gray > png_ptr->usr_bit_depth)
+      {
+         png_warning(png_ptr, "Invalid sBIT depth specified");
+         return;
+      }
+      buf[0] = sbit->gray;
+      size = 1;
+   }
+
+   if (color_type & PNG_COLOR_MASK_ALPHA)
+   {
+      if (sbit->alpha == 0 || sbit->alpha > png_ptr->usr_bit_depth)
+      {
+         png_warning(png_ptr, "Invalid sBIT depth specified");
+         return;
+      }
+      buf[size++] = sbit->alpha;
+   }
+
+   png_write_chunk(png_ptr, (png_bytep)png_sBIT, buf, size);
+}
+#endif
+
+#if defined(PNG_WRITE_cHRM_SUPPORTED)
+/* write the cHRM chunk */
+#ifdef PNG_FLOATING_POINT_SUPPORTED
+void /* PRIVATE */
+png_write_cHRM(png_structp png_ptr, double white_x, double white_y,
+   double red_x, double red_y, double green_x, double green_y,
+   double blue_x, double blue_y)
+{
+#ifdef PNG_USE_LOCAL_ARRAYS
+   PNG_cHRM;
+#endif
+   png_byte buf[32];
+   png_uint_32 itemp;
+
+   png_debug(1, "in png_write_cHRM\n");
+   /* each value is saved in 1/100,000ths */
+   if (white_x < 0 || white_x > 0.8 || white_y < 0 || white_y > 0.8 ||
+       white_x + white_y > 1.0)
+   {
+      png_warning(png_ptr, "Invalid cHRM white point specified");
+#if !defined(PNG_NO_CONSOLE_IO)
+      fprintf(stderr,"white_x=%f, white_y=%f\n",white_x, white_y);
+#endif
+      return;
+   }
+   itemp = (png_uint_32)(white_x * 100000.0 + 0.5);
+   png_save_uint_32(buf, itemp);
+   itemp = (png_uint_32)(white_y * 100000.0 + 0.5);
+   png_save_uint_32(buf + 4, itemp);
+
+   if (red_x < 0 || red_x > 0.8 || red_y < 0 || red_y > 0.8 ||
+       red_x + red_y > 1.0)
+   {
+      png_warning(png_ptr, "Invalid cHRM red point specified");
+      return;
+   }
+   itemp = (png_uint_32)(red_x * 100000.0 + 0.5);
+   png_save_uint_32(buf + 8, itemp);
+   itemp = (png_uint_32)(red_y * 100000.0 + 0.5);
+   png_save_uint_32(buf + 12, itemp);
+
+   if (green_x < 0 || green_x > 0.8 || green_y < 0 || green_y > 0.8 ||
+       green_x + green_y > 1.0)
+   {
+      png_warning(png_ptr, "Invalid cHRM green point specified");
+      return;
+   }
+   itemp = (png_uint_32)(green_x * 100000.0 + 0.5);
+   png_save_uint_32(buf + 16, itemp);
+   itemp = (png_uint_32)(green_y * 100000.0 + 0.5);
+   png_save_uint_32(buf + 20, itemp);
+
+   if (blue_x < 0 || blue_x > 0.8 || blue_y < 0 || blue_y > 0.8 ||
+       blue_x + blue_y > 1.0)
+   {
+      png_warning(png_ptr, "Invalid cHRM blue point specified");
+      return;
+   }
+   itemp = (png_uint_32)(blue_x * 100000.0 + 0.5);
+   png_save_uint_32(buf + 24, itemp);
+   itemp = (png_uint_32)(blue_y * 100000.0 + 0.5);
+   png_save_uint_32(buf + 28, itemp);
+
+   png_write_chunk(png_ptr, (png_bytep)png_cHRM, buf, (png_size_t)32);
+}
+#endif
+#ifdef PNG_FIXED_POINT_SUPPORTED
+void /* PRIVATE */
+png_write_cHRM_fixed(png_structp png_ptr, png_fixed_point white_x,
+   png_fixed_point white_y, png_fixed_point red_x, png_fixed_point red_y,
+   png_fixed_point green_x, png_fixed_point green_y, png_fixed_point blue_x,
+   png_fixed_point blue_y)
+{
+#ifdef PNG_USE_LOCAL_ARRAYS
+   PNG_cHRM;
+#endif
+   png_byte buf[32];
+
+   png_debug(1, "in png_write_cHRM\n");
+   /* each value is saved in 1/100,000ths */
+   if (white_x > 80000L || white_y > 80000L || white_x + white_y > 100000L)
+   {
+      png_warning(png_ptr, "Invalid fixed cHRM white point specified");
+#if !defined(PNG_NO_CONSOLE_IO)
+      fprintf(stderr,"white_x=%ld, white_y=%ld\n",white_x, white_y);
+#endif
+      return;
+   }
+   png_save_uint_32(buf, (png_uint_32)white_x);
+   png_save_uint_32(buf + 4, (png_uint_32)white_y);
+
+   if (red_x > 80000L || red_y > 80000L || red_x + red_y > 100000L)
+   {
+      png_warning(png_ptr, "Invalid cHRM fixed red point specified");
+      return;
+   }
+   png_save_uint_32(buf + 8, (png_uint_32)red_x);
+   png_save_uint_32(buf + 12, (png_uint_32)red_y);
+
+   if (green_x > 80000L || green_y > 80000L || green_x + green_y > 100000L)
+   {
+      png_warning(png_ptr, "Invalid fixed cHRM green point specified");
+      return;
+   }
+   png_save_uint_32(buf + 16, (png_uint_32)green_x);
+   png_save_uint_32(buf + 20, (png_uint_32)green_y);
+
+   if (blue_x > 80000L || blue_y > 80000L || blue_x + blue_y > 100000L)
+   {
+      png_warning(png_ptr, "Invalid fixed cHRM blue point specified");
+      return;
+   }
+   png_save_uint_32(buf + 24, (png_uint_32)blue_x);
+   png_save_uint_32(buf + 28, (png_uint_32)blue_y);
+
+   png_write_chunk(png_ptr, (png_bytep)png_cHRM, buf, (png_size_t)32);
+}
+#endif
+#endif
+
+#if defined(PNG_WRITE_tRNS_SUPPORTED)
+/* write the tRNS chunk */
+void /* PRIVATE */
+png_write_tRNS(png_structp png_ptr, png_bytep trans, png_color_16p tran,
+   int num_trans, int color_type)
+{
+#ifdef PNG_USE_LOCAL_ARRAYS
+   PNG_tRNS;
+#endif
+   png_byte buf[6];
+
+   png_debug(1, "in png_write_tRNS\n");
+   if (color_type == PNG_COLOR_TYPE_PALETTE)
+   {
+      if (num_trans <= 0 || num_trans > (int)png_ptr->num_palette)
+      {
+         png_warning(png_ptr,"Invalid number of transparent colors specified");
+         return;
+      }
+      /* write the chunk out as it is */
+      png_write_chunk(png_ptr, (png_bytep)png_tRNS, trans, (png_size_t)num_trans);
+   }
+   else if (color_type == PNG_COLOR_TYPE_GRAY)
+   {
+      /* one 16 bit value */
+      if(tran->gray >= (1 << png_ptr->bit_depth))
+      {
+         png_warning(png_ptr,
+           "Ignoring attempt to write tRNS chunk out-of-range for bit_depth");
+         return;
+      }
+      png_save_uint_16(buf, tran->gray);
+      png_write_chunk(png_ptr, (png_bytep)png_tRNS, buf, (png_size_t)2);
+   }
+   else if (color_type == PNG_COLOR_TYPE_RGB)
+   {
+      /* three 16 bit values */
+      png_save_uint_16(buf, tran->red);
+      png_save_uint_16(buf + 2, tran->green);
+      png_save_uint_16(buf + 4, tran->blue);
+      if(png_ptr->bit_depth == 8 && (buf[0] | buf[2] | buf[4]))
+         {
+            png_warning(png_ptr,
+              "Ignoring attempt to write 16-bit tRNS chunk when bit_depth is 8");
+            return;
+         }
+      png_write_chunk(png_ptr, (png_bytep)png_tRNS, buf, (png_size_t)6);
+   }
+   else
+   {
+      png_warning(png_ptr, "Can't write tRNS with an alpha channel");
+   }
+}
+#endif
+
+#if defined(PNG_WRITE_bKGD_SUPPORTED)
+/* write the background chunk */
+void /* PRIVATE */
+png_write_bKGD(png_structp png_ptr, png_color_16p back, int color_type)
+{
+#ifdef PNG_USE_LOCAL_ARRAYS
+   PNG_bKGD;
+#endif
+   png_byte buf[6];
+
+   png_debug(1, "in png_write_bKGD\n");
+   if (color_type == PNG_COLOR_TYPE_PALETTE)
+   {
+      if (
+#if defined(PNG_MNG_FEATURES_SUPPORTED)
+          (png_ptr->num_palette ||
+          (!(png_ptr->mng_features_permitted & PNG_FLAG_MNG_EMPTY_PLTE))) &&
+#endif
+         back->index > png_ptr->num_palette)
+      {
+         png_warning(png_ptr, "Invalid background palette index");
+         return;
+      }
+      buf[0] = back->index;
+      png_write_chunk(png_ptr, (png_bytep)png_bKGD, buf, (png_size_t)1);
+   }
+   else if (color_type & PNG_COLOR_MASK_COLOR)
+   {
+      png_save_uint_16(buf, back->red);
+      png_save_uint_16(buf + 2, back->green);
+      png_save_uint_16(buf + 4, back->blue);
+      if(png_ptr->bit_depth == 8 && (buf[0] | buf[2] | buf[4]))
+         {
+            png_warning(png_ptr,
+              "Ignoring attempt to write 16-bit bKGD chunk when bit_depth is 8");
+            return;
+         }
+      png_write_chunk(png_ptr, (png_bytep)png_bKGD, buf, (png_size_t)6);
+   }
+   else
+   {
+      if(back->gray >= (1 << png_ptr->bit_depth))
+      {
+         png_warning(png_ptr,
+           "Ignoring attempt to write bKGD chunk out-of-range for bit_depth");
+         return;
+      }
+      png_save_uint_16(buf, back->gray);
+      png_write_chunk(png_ptr, (png_bytep)png_bKGD, buf, (png_size_t)2);
+   }
+}
+#endif
+
+#if defined(PNG_WRITE_hIST_SUPPORTED)
+/* write the histogram */
+void /* PRIVATE */
+png_write_hIST(png_structp png_ptr, png_uint_16p hist, int num_hist)
+{
+#ifdef PNG_USE_LOCAL_ARRAYS
+   PNG_hIST;
+#endif
+   int i;
+   png_byte buf[3];
+
+   png_debug(1, "in png_write_hIST\n");
+   if (num_hist > (int)png_ptr->num_palette)
+   {
+      png_debug2(3, "num_hist = %d, num_palette = %d\n", num_hist,
+         png_ptr->num_palette);
+      png_warning(png_ptr, "Invalid number of histogram entries specified");
+      return;
+   }
+
+   png_write_chunk_start(png_ptr, (png_bytep)png_hIST, (png_uint_32)(num_hist * 2));
+   for (i = 0; i < num_hist; i++)
+   {
+      png_save_uint_16(buf, hist[i]);
+      png_write_chunk_data(png_ptr, buf, (png_size_t)2);
+   }
+   png_write_chunk_end(png_ptr);
+}
+#endif
+
+#if defined(PNG_WRITE_TEXT_SUPPORTED) || defined(PNG_WRITE_pCAL_SUPPORTED) || \
+    defined(PNG_WRITE_iCCP_SUPPORTED) || defined(PNG_WRITE_sPLT_SUPPORTED)
+/* Check that the tEXt or zTXt keyword is valid per PNG 1.0 specification,
+ * and if invalid, correct the keyword rather than discarding the entire
+ * chunk.  The PNG 1.0 specification requires keywords 1-79 characters in
+ * length, forbids leading or trailing whitespace, multiple internal spaces,
+ * and the non-break space (0x80) from ISO 8859-1.  Returns keyword length.
+ *
+ * The new_key is allocated to hold the corrected keyword and must be freed
+ * by the calling routine.  This avoids problems with trying to write to
+ * static keywords without having to have duplicate copies of the strings.
+ */
+png_size_t /* PRIVATE */
+png_check_keyword(png_structp png_ptr, png_charp key, png_charpp new_key)
+{
+   png_size_t key_len;
+   png_charp kp, dp;
+   int kflag;
+   int kwarn=0;
+
+   png_debug(1, "in png_check_keyword\n");
+   *new_key = NULL;
+
+   if (key == NULL || (key_len = png_strlen(key)) == 0)
+   {
+      png_warning(png_ptr, "zero length keyword");
+      return ((png_size_t)0);
+   }
+
+   png_debug1(2, "Keyword to be checked is '%s'\n", key);
+
+   *new_key = (png_charp)png_malloc(png_ptr, (png_uint_32)(key_len + 2));
+
+   /* Replace non-printing characters with a blank and print a warning */
+   for (kp = key, dp = *new_key; *kp != '\0'; kp++, dp++)
+   {
+      if (*kp < 0x20 || (*kp > 0x7E && (png_byte)*kp < 0xA1))
+      {
+#if !defined(PNG_NO_STDIO) && !defined(_WIN32_WCE)
+         char msg[40];
+
+         sprintf(msg, "invalid keyword character 0x%02X", *kp);
+         png_warning(png_ptr, msg);
+#else
+         png_warning(png_ptr, "invalid character in keyword");
+#endif
+         *dp = ' ';
+      }
+      else
+      {
+         *dp = *kp;
+      }
+   }
+   *dp = '\0';
+
+   /* Remove any trailing white space. */
+   kp = *new_key + key_len - 1;
+   if (*kp == ' ')
+   {
+      png_warning(png_ptr, "trailing spaces removed from keyword");
+
+      while (*kp == ' ')
+      {
+        *(kp--) = '\0';
+        key_len--;
+      }
+   }
+
+   /* Remove any leading white space. */
+   kp = *new_key;
+   if (*kp == ' ')
+   {
+      png_warning(png_ptr, "leading spaces removed from keyword");
+
+      while (*kp == ' ')
+      {
+        kp++;
+        key_len--;
+      }
+   }
+
+   png_debug1(2, "Checking for multiple internal spaces in '%s'\n", kp);
+
+   /* Remove multiple internal spaces. */
+   for (kflag = 0, dp = *new_key; *kp != '\0'; kp++)
+   {
+      if (*kp == ' ' && kflag == 0)
+      {
+         *(dp++) = *kp;
+         kflag = 1;
+      }
+      else if (*kp == ' ')
+      {
+         key_len--;
+         kwarn=1;
+      }
+      else
+      {
+         *(dp++) = *kp;
+         kflag = 0;
+      }
+   }
+   *dp = '\0';
+   if(kwarn)
+      png_warning(png_ptr, "extra interior spaces removed from keyword");
+
+   if (key_len == 0)
+   {
+      png_free(png_ptr, *new_key);
+      *new_key=NULL;
+      png_warning(png_ptr, "Zero length keyword");
+   }
+
+   if (key_len > 79)
+   {
+      png_warning(png_ptr, "keyword length must be 1 - 79 characters");
+      new_key[79] = '\0';
+      key_len = 79;
+   }
+
+   return (key_len);
+}
+#endif
+
+#if defined(PNG_WRITE_tEXt_SUPPORTED)
+/* write a tEXt chunk */
+void /* PRIVATE */
+png_write_tEXt(png_structp png_ptr, png_charp key, png_charp text,
+   png_size_t text_len)
+{
+#ifdef PNG_USE_LOCAL_ARRAYS
+   PNG_tEXt;
+#endif
+   png_size_t key_len;
+   png_charp new_key;
+
+   png_debug(1, "in png_write_tEXt\n");
+   if (key == NULL || (key_len = png_check_keyword(png_ptr, key, &new_key))==0)
+   {
+      png_warning(png_ptr, "Empty keyword in tEXt chunk");
+      return;
+   }
+
+   if (text == NULL || *text == '\0')
+      text_len = 0;
+   else
+      text_len = png_strlen(text);
+
+   /* make sure we include the 0 after the key */
+   png_write_chunk_start(png_ptr, (png_bytep)png_tEXt, (png_uint_32)key_len+text_len+1);
+   /*
+    * We leave it to the application to meet PNG-1.0 requirements on the
+    * contents of the text.  PNG-1.0 through PNG-1.2 discourage the use of
+    * any non-Latin-1 characters except for NEWLINE.  ISO PNG will forbid them.
+    * The NUL character is forbidden by PNG-1.0 through PNG-1.2 and ISO PNG.
+    */
+   png_write_chunk_data(png_ptr, (png_bytep)new_key, key_len + 1);
+   if (text_len)
+      png_write_chunk_data(png_ptr, (png_bytep)text, text_len);
+
+   png_write_chunk_end(png_ptr);
+   png_free(png_ptr, new_key);
+}
+#endif
+
+#if defined(PNG_WRITE_zTXt_SUPPORTED)
+/* write a compressed text chunk */
+void /* PRIVATE */
+png_write_zTXt(png_structp png_ptr, png_charp key, png_charp text,
+   png_size_t text_len, int compression)
+{
+#ifdef PNG_USE_LOCAL_ARRAYS
+   PNG_zTXt;
+#endif
+   png_size_t key_len;
+   char buf[1];
+   png_charp new_key;
+   compression_state comp;
+
+   png_debug(1, "in png_write_zTXt\n");
+
+   if (key == NULL || (key_len = png_check_keyword(png_ptr, key, &new_key))==0)
+   {
+      png_warning(png_ptr, "Empty keyword in zTXt chunk");
+      return;
+   }
+
+   if (text == NULL || *text == '\0' || compression==PNG_TEXT_COMPRESSION_NONE)
+   {
+      png_write_tEXt(png_ptr, new_key, text, (png_size_t)0);
+      png_free(png_ptr, new_key);
+      return;
+   }
+
+   text_len = png_strlen(text);
+
+   png_free(png_ptr, new_key);
+
+   /* compute the compressed data; do it now for the length */
+   text_len = png_text_compress(png_ptr, text, text_len, compression,
+       &comp);
+
+   /* write start of chunk */
+   png_write_chunk_start(png_ptr, (png_bytep)png_zTXt, (png_uint_32)
+      (key_len+text_len+2));
+   /* write key */
+   png_write_chunk_data(png_ptr, (png_bytep)key, key_len + 1);
+   buf[0] = (png_byte)compression;
+   /* write compression */
+   png_write_chunk_data(png_ptr, (png_bytep)buf, (png_size_t)1);
+   /* write the compressed data */
+   png_write_compressed_data_out(png_ptr, &comp);
+
+   /* close the chunk */
+   png_write_chunk_end(png_ptr);
+}
+#endif
+
+#if defined(PNG_WRITE_iTXt_SUPPORTED)
+/* write an iTXt chunk */
+void /* PRIVATE */
+png_write_iTXt(png_structp png_ptr, int compression, png_charp key,
+    png_charp lang, png_charp lang_key, png_charp text)
+{
+#ifdef PNG_USE_LOCAL_ARRAYS
+   PNG_iTXt;
+#endif
+   png_size_t lang_len, key_len, lang_key_len, text_len;
+   png_charp new_lang, new_key;
+   png_byte cbuf[2];
+   compression_state comp;
+
+   png_debug(1, "in png_write_iTXt\n");
+
+   if (key == NULL || (key_len = png_check_keyword(png_ptr, key, &new_key))==0)
+   {
+      png_warning(png_ptr, "Empty keyword in iTXt chunk");
+      return;
+   }
+   if (lang == NULL || (lang_len = png_check_keyword(png_ptr, lang, &new_lang))==0)
+   {
+      png_warning(png_ptr, "Empty language field in iTXt chunk");
+      new_lang = NULL;
+      lang_len = 0;      
+   }
+
+   if (lang_key == NULL)
+     lang_key_len = 0;
+   else
+     lang_key_len = png_strlen(lang_key);
+
+   if (text == NULL)
+      text_len = 0;
+   else
+     text_len = png_strlen(text);
+
+   /* compute the compressed data; do it now for the length */
+   text_len = png_text_compress(png_ptr, text, text_len, compression-2,
+      &comp);
+
+
+   /* make sure we include the compression flag, the compression byte,
+    * and the NULs after the key, lang, and lang_key parts */
+
+   png_write_chunk_start(png_ptr, (png_bytep)png_iTXt,
+          (png_uint_32)(
+        5 /* comp byte, comp flag, terminators for key, lang and lang_key */
+        + key_len
+        + lang_len
+        + lang_key_len
+        + text_len));
+
+   /*
+    * We leave it to the application to meet PNG-1.0 requirements on the
+    * contents of the text.  PNG-1.0 through PNG-1.2 discourage the use of
+    * any non-Latin-1 characters except for NEWLINE.  ISO PNG will forbid them.
+    * The NUL character is forbidden by PNG-1.0 through PNG-1.2 and ISO PNG.
+    */
+   png_write_chunk_data(png_ptr, (png_bytep)new_key, key_len + 1);
+
+   /* set the compression flag */
+   if (compression == PNG_ITXT_COMPRESSION_NONE || \
+       compression == PNG_TEXT_COMPRESSION_NONE)
+       cbuf[0] = 0;
+   else /* compression == PNG_ITXT_COMPRESSION_zTXt */
+       cbuf[0] = 1;
+   /* set the compression method */
+   cbuf[1] = 0;
+   png_write_chunk_data(png_ptr, cbuf, 2);
+
+   cbuf[0] = 0;
+   png_write_chunk_data(png_ptr, (new_lang ? (png_bytep)new_lang : cbuf), lang_len + 1);
+   png_write_chunk_data(png_ptr, (lang_key ? (png_bytep)lang_key : cbuf), lang_key_len + 1);
+   png_write_compressed_data_out(png_ptr, &comp);
+
+   png_write_chunk_end(png_ptr);
+   png_free(png_ptr, new_key);
+   if (new_lang)
+     png_free(png_ptr, new_lang);
+}
+#endif
+
+#if defined(PNG_WRITE_oFFs_SUPPORTED)
+/* write the oFFs chunk */
+void /* PRIVATE */
+png_write_oFFs(png_structp png_ptr, png_int_32 x_offset, png_int_32 y_offset,
+   int unit_type)
+{
+#ifdef PNG_USE_LOCAL_ARRAYS
+   PNG_oFFs;
+#endif
+   png_byte buf[9];
+
+   png_debug(1, "in png_write_oFFs\n");
+   if (unit_type >= PNG_OFFSET_LAST)
+      png_warning(png_ptr, "Unrecognized unit type for oFFs chunk");
+
+   png_save_int_32(buf, x_offset);
+   png_save_int_32(buf + 4, y_offset);
+   buf[8] = (png_byte)unit_type;
+
+   png_write_chunk(png_ptr, (png_bytep)png_oFFs, buf, (png_size_t)9);
+}
+#endif
+
+#if defined(PNG_WRITE_pCAL_SUPPORTED)
+/* write the pCAL chunk (described in the PNG extensions document) */
+void /* PRIVATE */
+png_write_pCAL(png_structp png_ptr, png_charp purpose, png_int_32 X0,
+   png_int_32 X1, int type, int nparams, png_charp units, png_charpp params)
+{
+#ifdef PNG_USE_LOCAL_ARRAYS
+   PNG_pCAL;
+#endif
+   png_size_t purpose_len, units_len, total_len;
+   png_uint_32p params_len;
+   png_byte buf[10];
+   png_charp new_purpose;
+   int i;
+
+   png_debug1(1, "in png_write_pCAL (%d parameters)\n", nparams);
+   if (type >= PNG_EQUATION_LAST)
+      png_warning(png_ptr, "Unrecognized equation type for pCAL chunk");
+
+   purpose_len = png_check_keyword(png_ptr, purpose, &new_purpose) + 1;
+   png_debug1(3, "pCAL purpose length = %d\n", (int)purpose_len);
+   units_len = png_strlen(units) + (nparams == 0 ? 0 : 1);
+   png_debug1(3, "pCAL units length = %d\n", (int)units_len);
+   total_len = purpose_len + units_len + 10;
+
+   params_len = (png_uint_32p)png_malloc(png_ptr, (png_uint_32)(nparams
+      *sizeof(png_uint_32)));
+
+   /* Find the length of each parameter, making sure we don't count the
+      null terminator for the last parameter. */
+   for (i = 0; i < nparams; i++)
+   {
+      params_len[i] = png_strlen(params[i]) + (i == nparams - 1 ? 0 : 1);
+      png_debug2(3, "pCAL parameter %d length = %lu\n", i, params_len[i]);
+      total_len += (png_size_t)params_len[i];
+   }
+
+   png_debug1(3, "pCAL total length = %d\n", (int)total_len);
+   png_write_chunk_start(png_ptr, (png_bytep)png_pCAL, (png_uint_32)total_len);
+   png_write_chunk_data(png_ptr, (png_bytep)new_purpose, purpose_len);
+   png_save_int_32(buf, X0);
+   png_save_int_32(buf + 4, X1);
+   buf[8] = (png_byte)type;
+   buf[9] = (png_byte)nparams;
+   png_write_chunk_data(png_ptr, buf, (png_size_t)10);
+   png_write_chunk_data(png_ptr, (png_bytep)units, (png_size_t)units_len);
+
+   png_free(png_ptr, new_purpose);
+
+   for (i = 0; i < nparams; i++)
+   {
+      png_write_chunk_data(png_ptr, (png_bytep)params[i],
+         (png_size_t)params_len[i]);
+   }
+
+   png_free(png_ptr, params_len);
+   png_write_chunk_end(png_ptr);
+}
+#endif
+
+#if defined(PNG_WRITE_sCAL_SUPPORTED)
+/* write the sCAL chunk */
+#if defined(PNG_FLOATING_POINT_SUPPORTED) && !defined(PNG_NO_STDIO)
+void /* PRIVATE */
+png_write_sCAL(png_structp png_ptr, int unit, double width,double height)
+{
+#ifdef PNG_USE_LOCAL_ARRAYS
+   PNG_sCAL;
+#endif
+   png_size_t total_len;
+   char wbuf[32], hbuf[32];
+
+   png_debug(1, "in png_write_sCAL\n");
+
+#if defined(_WIN32_WCE)
+/* sprintf() function is not supported on WindowsCE */
+   {
+      wchar_t wc_buf[32];
+      swprintf(wc_buf, TEXT("%12.12e"), width);
+      WideCharToMultiByte(CP_ACP, 0, wc_buf, -1, wbuf, 32, NULL, NULL);
+      swprintf(wc_buf, TEXT("%12.12e"), height);
+      WideCharToMultiByte(CP_ACP, 0, wc_buf, -1, hbuf, 32, NULL, NULL);
+   }
+#else
+   sprintf(wbuf, "%12.12e", width);
+   sprintf(hbuf, "%12.12e", height);
+#endif
+   total_len = 1 + png_strlen(wbuf)+1 + png_strlen(hbuf);
+
+   png_debug1(3, "sCAL total length = %d\n", (int)total_len);
+   png_write_chunk_start(png_ptr, (png_bytep)png_sCAL, (png_uint_32)total_len);
+   png_write_chunk_data(png_ptr, (png_bytep)&unit, 1);
+   png_write_chunk_data(png_ptr, (png_bytep)wbuf, png_strlen(wbuf)+1);
+   png_write_chunk_data(png_ptr, (png_bytep)hbuf, png_strlen(hbuf));
+
+   png_write_chunk_end(png_ptr);
+}
+#else
+#ifdef PNG_FIXED_POINT_SUPPORTED
+void /* PRIVATE */
+png_write_sCAL_s(png_structp png_ptr, int unit, png_charp width,
+   png_charp height)
+{
+#ifdef PNG_USE_LOCAL_ARRAYS
+   PNG_sCAL;
+#endif
+   png_size_t total_len;
+   char wbuf[32], hbuf[32];
+
+   png_debug(1, "in png_write_sCAL_s\n");
+
+   png_strcpy(wbuf,(const char *)width);
+   png_strcpy(hbuf,(const char *)height);
+   total_len = 1 + png_strlen(wbuf)+1 + png_strlen(hbuf);
+
+   png_debug1(3, "sCAL total length = %d\n", total_len);
+   png_write_chunk_start(png_ptr, (png_bytep)png_sCAL, (png_uint_32)total_len);
+   png_write_chunk_data(png_ptr, (png_bytep)&unit, 1);
+   png_write_chunk_data(png_ptr, (png_bytep)wbuf, png_strlen(wbuf)+1);
+   png_write_chunk_data(png_ptr, (png_bytep)hbuf, png_strlen(hbuf));
+
+   png_write_chunk_end(png_ptr);
+}
+#endif
+#endif
+#endif
+
+#if defined(PNG_WRITE_pHYs_SUPPORTED)
+/* write the pHYs chunk */
+void /* PRIVATE */
+png_write_pHYs(png_structp png_ptr, png_uint_32 x_pixels_per_unit,
+   png_uint_32 y_pixels_per_unit,
+   int unit_type)
+{
+#ifdef PNG_USE_LOCAL_ARRAYS
+   PNG_pHYs;
+#endif
+   png_byte buf[9];
+
+   png_debug(1, "in png_write_pHYs\n");
+   if (unit_type >= PNG_RESOLUTION_LAST)
+      png_warning(png_ptr, "Unrecognized unit type for pHYs chunk");
+
+   png_save_uint_32(buf, x_pixels_per_unit);
+   png_save_uint_32(buf + 4, y_pixels_per_unit);
+   buf[8] = (png_byte)unit_type;
+
+   png_write_chunk(png_ptr, (png_bytep)png_pHYs, buf, (png_size_t)9);
+}
+#endif
+
+#if defined(PNG_WRITE_tIME_SUPPORTED)
+/* Write the tIME chunk.  Use either png_convert_from_struct_tm()
+ * or png_convert_from_time_t(), or fill in the structure yourself.
+ */
+void /* PRIVATE */
+png_write_tIME(png_structp png_ptr, png_timep mod_time)
+{
+#ifdef PNG_USE_LOCAL_ARRAYS
+   PNG_tIME;
+#endif
+   png_byte buf[7];
+
+   png_debug(1, "in png_write_tIME\n");
+   if (mod_time->month  > 12 || mod_time->month  < 1 ||
+       mod_time->day    > 31 || mod_time->day    < 1 ||
+       mod_time->hour   > 23 || mod_time->second > 60)
+   {
+      png_warning(png_ptr, "Invalid time specified for tIME chunk");
+      return;
+   }
+
+   png_save_uint_16(buf, mod_time->year);
+   buf[2] = mod_time->month;
+   buf[3] = mod_time->day;
+   buf[4] = mod_time->hour;
+   buf[5] = mod_time->minute;
+   buf[6] = mod_time->second;
+
+   png_write_chunk(png_ptr, (png_bytep)png_tIME, buf, (png_size_t)7);
+}
+#endif
+
+/* initializes the row writing capability of libpng */
+void /* PRIVATE */
+png_write_start_row(png_structp png_ptr)
+{
+#ifdef PNG_USE_LOCAL_ARRAYS
+   /* arrays to facilitate easy interlacing - use pass (0 - 6) as index */
+
+   /* start of interlace block */
+   int png_pass_start[7] = {0, 4, 0, 2, 0, 1, 0};
+
+   /* offset to next interlace block */
+   int png_pass_inc[7] = {8, 8, 4, 4, 2, 2, 1};
+
+   /* start of interlace block in the y direction */
+   int png_pass_ystart[7] = {0, 0, 4, 0, 2, 0, 1};
+
+   /* offset to next interlace block in the y direction */
+   int png_pass_yinc[7] = {8, 8, 8, 4, 4, 2, 2};
+#endif
+
+   png_size_t buf_size;
+
+   png_debug(1, "in png_write_start_row\n");
+   buf_size = (png_size_t)(((png_ptr->width * png_ptr->usr_channels *
+                            png_ptr->usr_bit_depth + 7) >> 3) + 1);
+
+   /* set up row buffer */
+   png_ptr->row_buf = (png_bytep)png_malloc(png_ptr, (png_uint_32)buf_size);
+   png_ptr->row_buf[0] = PNG_FILTER_VALUE_NONE;
+
+   /* set up filtering buffer, if using this filter */
+   if (png_ptr->do_filter & PNG_FILTER_SUB)
+   {
+      png_ptr->sub_row = (png_bytep)png_malloc(png_ptr,
+         (png_ptr->rowbytes + 1));
+      png_ptr->sub_row[0] = PNG_FILTER_VALUE_SUB;
+   }
+
+   /* We only need to keep the previous row if we are using one of these. */
+   if (png_ptr->do_filter & (PNG_FILTER_AVG | PNG_FILTER_UP | PNG_FILTER_PAETH))
+   {
+     /* set up previous row buffer */
+      png_ptr->prev_row = (png_bytep)png_malloc(png_ptr, (png_uint_32)buf_size);
+      png_memset(png_ptr->prev_row, 0, buf_size);
+
+      if (png_ptr->do_filter & PNG_FILTER_UP)
+      {
+         png_ptr->up_row = (png_bytep )png_malloc(png_ptr,
+            (png_ptr->rowbytes + 1));
+         png_ptr->up_row[0] = PNG_FILTER_VALUE_UP;
+      }
+
+      if (png_ptr->do_filter & PNG_FILTER_AVG)
+      {
+         png_ptr->avg_row = (png_bytep)png_malloc(png_ptr,
+            (png_ptr->rowbytes + 1));
+         png_ptr->avg_row[0] = PNG_FILTER_VALUE_AVG;
+      }
+
+      if (png_ptr->do_filter & PNG_FILTER_PAETH)
+      {
+         png_ptr->paeth_row = (png_bytep )png_malloc(png_ptr,
+            (png_ptr->rowbytes + 1));
+         png_ptr->paeth_row[0] = PNG_FILTER_VALUE_PAETH;
+      }
+   }
+
+#ifdef PNG_WRITE_INTERLACING_SUPPORTED
+   /* if interlaced, we need to set up width and height of pass */
+   if (png_ptr->interlaced)
+   {
+      if (!(png_ptr->transformations & PNG_INTERLACE))
+      {
+         png_ptr->num_rows = (png_ptr->height + png_pass_yinc[0] - 1 -
+            png_pass_ystart[0]) / png_pass_yinc[0];
+         png_ptr->usr_width = (png_ptr->width + png_pass_inc[0] - 1 -
+            png_pass_start[0]) / png_pass_inc[0];
+      }
+      else
+      {
+         png_ptr->num_rows = png_ptr->height;
+         png_ptr->usr_width = png_ptr->width;
+      }
+   }
+   else
+#endif
+   {
+      png_ptr->num_rows = png_ptr->height;
+      png_ptr->usr_width = png_ptr->width;
+   }
+   png_ptr->zstream.avail_out = (uInt)png_ptr->zbuf_size;
+   png_ptr->zstream.next_out = png_ptr->zbuf;
+}
+
+/* Internal use only.  Called when finished processing a row of data. */
+void /* PRIVATE */
+png_write_finish_row(png_structp png_ptr)
+{
+#ifdef PNG_USE_LOCAL_ARRAYS
+   /* arrays to facilitate easy interlacing - use pass (0 - 6) as index */
+
+   /* start of interlace block */
+   int png_pass_start[7] = {0, 4, 0, 2, 0, 1, 0};
+
+   /* offset to next interlace block */
+   int png_pass_inc[7] = {8, 8, 4, 4, 2, 2, 1};
+
+   /* start of interlace block in the y direction */
+   int png_pass_ystart[7] = {0, 0, 4, 0, 2, 0, 1};
+
+   /* offset to next interlace block in the y direction */
+   int png_pass_yinc[7] = {8, 8, 8, 4, 4, 2, 2};
+#endif
+
+   int ret;
+
+   png_debug(1, "in png_write_finish_row\n");
+   /* next row */
+   png_ptr->row_number++;
+
+   /* see if we are done */
+   if (png_ptr->row_number < png_ptr->num_rows)
+      return;
+
+#ifdef PNG_WRITE_INTERLACING_SUPPORTED
+   /* if interlaced, go to next pass */
+   if (png_ptr->interlaced)
+   {
+      png_ptr->row_number = 0;
+      if (png_ptr->transformations & PNG_INTERLACE)
+      {
+         png_ptr->pass++;
+      }
+      else
+      {
+         /* loop until we find a non-zero width or height pass */
+         do
+         {
+            png_ptr->pass++;
+            if (png_ptr->pass >= 7)
+               break;
+            png_ptr->usr_width = (png_ptr->width +
+               png_pass_inc[png_ptr->pass] - 1 -
+               png_pass_start[png_ptr->pass]) /
+               png_pass_inc[png_ptr->pass];
+            png_ptr->num_rows = (png_ptr->height +
+               png_pass_yinc[png_ptr->pass] - 1 -
+               png_pass_ystart[png_ptr->pass]) /
+               png_pass_yinc[png_ptr->pass];
+            if (png_ptr->transformations & PNG_INTERLACE)
+               break;
+         } while (png_ptr->usr_width == 0 || png_ptr->num_rows == 0);
+
+      }
+
+      /* reset the row above the image for the next pass */
+      if (png_ptr->pass < 7)
+      {
+         if (png_ptr->prev_row != NULL)
+            png_memset(png_ptr->prev_row, 0,
+               (png_size_t) (((png_uint_32)png_ptr->usr_channels *
+               (png_uint_32)png_ptr->usr_bit_depth *
+               png_ptr->width + 7) >> 3) + 1);
+         return;
+      }
+   }
+#endif
+
+   /* if we get here, we've just written the last row, so we need
+      to flush the compressor */
+   do
+   {
+      /* tell the compressor we are done */
+      ret = deflate(&png_ptr->zstream, Z_FINISH);
+      /* check for an error */
+      if (ret == Z_OK)
+      {
+         /* check to see if we need more room */
+         if (!(png_ptr->zstream.avail_out))
+         {
+            png_write_IDAT(png_ptr, png_ptr->zbuf, png_ptr->zbuf_size);
+            png_ptr->zstream.next_out = png_ptr->zbuf;
+            png_ptr->zstream.avail_out = (uInt)png_ptr->zbuf_size;
+         }
+      }
+      else if (ret != Z_STREAM_END)
+      {
+         if (png_ptr->zstream.msg != NULL)
+            png_error(png_ptr, png_ptr->zstream.msg);
+         else
+            png_error(png_ptr, "zlib error");
+      }
+   } while (ret != Z_STREAM_END);
+
+   /* write any extra space */
+   if (png_ptr->zstream.avail_out < png_ptr->zbuf_size)
+   {
+      png_write_IDAT(png_ptr, png_ptr->zbuf, png_ptr->zbuf_size -
+         png_ptr->zstream.avail_out);
+   }
+
+   deflateReset(&png_ptr->zstream);
+}
+
+#if defined(PNG_WRITE_INTERLACING_SUPPORTED)
+/* Pick out the correct pixels for the interlace pass.
+ * The basic idea here is to go through the row with a source
+ * pointer and a destination pointer (sp and dp), and copy the
+ * correct pixels for the pass.  As the row gets compacted,
+ * sp will always be >= dp, so we should never overwrite anything.
+ * See the default: case for the easiest code to understand.
+ */
+void /* PRIVATE */
+png_do_write_interlace(png_row_infop row_info, png_bytep row, int pass)
+{
+#ifdef PNG_USE_LOCAL_ARRAYS
+   /* arrays to facilitate easy interlacing - use pass (0 - 6) as index */
+
+   /* start of interlace block */
+   int png_pass_start[7] = {0, 4, 0, 2, 0, 1, 0};
+
+   /* offset to next interlace block */
+   int png_pass_inc[7] = {8, 8, 4, 4, 2, 2, 1};
+#endif
+
+   png_debug(1, "in png_do_write_interlace\n");
+   /* we don't have to do anything on the last pass (6) */
+#if defined(PNG_USELESS_TESTS_SUPPORTED)
+   if (row != NULL && row_info != NULL && pass < 6)
+#else
+   if (pass < 6)
+#endif
+   {
+      /* each pixel depth is handled separately */
+      switch (row_info->pixel_depth)
+      {
+         case 1:
+         {
+            png_bytep sp;
+            png_bytep dp;
+            int shift;
+            int d;
+            int value;
+            png_uint_32 i;
+            png_uint_32 row_width = row_info->width;
+
+            dp = row;
+            d = 0;
+            shift = 7;
+            for (i = png_pass_start[pass]; i < row_width;
+               i += png_pass_inc[pass])
+            {
+               sp = row + (png_size_t)(i >> 3);
+               value = (int)(*sp >> (7 - (int)(i & 0x07))) & 0x01;
+               d |= (value << shift);
+
+               if (shift == 0)
+               {
+                  shift = 7;
+                  *dp++ = (png_byte)d;
+                  d = 0;
+               }
+               else
+                  shift--;
+
+            }
+            if (shift != 7)
+               *dp = (png_byte)d;
+            break;
+         }
+         case 2:
+         {
+            png_bytep sp;
+            png_bytep dp;
+            int shift;
+            int d;
+            int value;
+            png_uint_32 i;
+            png_uint_32 row_width = row_info->width;
+
+            dp = row;
+            shift = 6;
+            d = 0;
+            for (i = png_pass_start[pass]; i < row_width;
+               i += png_pass_inc[pass])
+            {
+               sp = row + (png_size_t)(i >> 2);
+               value = (*sp >> ((3 - (int)(i & 0x03)) << 1)) & 0x03;
+               d |= (value << shift);
+
+               if (shift == 0)
+               {
+                  shift = 6;
+                  *dp++ = (png_byte)d;
+                  d = 0;
+               }
+               else
+                  shift -= 2;
+            }
+            if (shift != 6)
+                   *dp = (png_byte)d;
+            break;
+         }
+         case 4:
+         {
+            png_bytep sp;
+            png_bytep dp;
+            int shift;
+            int d;
+            int value;
+            png_uint_32 i;
+            png_uint_32 row_width = row_info->width;
+
+            dp = row;
+            shift = 4;
+            d = 0;
+            for (i = png_pass_start[pass]; i < row_width;
+               i += png_pass_inc[pass])
+            {
+               sp = row + (png_size_t)(i >> 1);
+               value = (*sp >> ((1 - (int)(i & 0x01)) << 2)) & 0x0f;
+               d |= (value << shift);
+
+               if (shift == 0)
+               {
+                  shift = 4;
+                  *dp++ = (png_byte)d;
+                  d = 0;
+               }
+               else
+                  shift -= 4;
+            }
+            if (shift != 4)
+               *dp = (png_byte)d;
+            break;
+         }
+         default:
+         {
+            png_bytep sp;
+            png_bytep dp;
+            png_uint_32 i;
+            png_uint_32 row_width = row_info->width;
+            png_size_t pixel_bytes;
+
+            /* start at the beginning */
+            dp = row;
+            /* find out how many bytes each pixel takes up */
+            pixel_bytes = (row_info->pixel_depth >> 3);
+            /* loop through the row, only looking at the pixels that
+               matter */
+            for (i = png_pass_start[pass]; i < row_width;
+               i += png_pass_inc[pass])
+            {
+               /* find out where the original pixel is */
+               sp = row + (png_size_t)i * pixel_bytes;
+               /* move the pixel */
+               if (dp != sp)
+                  png_memcpy(dp, sp, pixel_bytes);
+               /* next pixel */
+               dp += pixel_bytes;
+            }
+            break;
+         }
+      }
+      /* set new row width */
+      row_info->width = (row_info->width +
+         png_pass_inc[pass] - 1 -
+         png_pass_start[pass]) /
+         png_pass_inc[pass];
+         row_info->rowbytes = ((row_info->width *
+            row_info->pixel_depth + 7) >> 3);
+   }
+}
+#endif
+
+/* This filters the row, chooses which filter to use, if it has not already
+ * been specified by the application, and then writes the row out with the
+ * chosen filter.
+ */
+#define PNG_MAXSUM (~((png_uint_32)0) >> 1)
+#define PNG_HISHIFT 10
+#define PNG_LOMASK ((png_uint_32)0xffffL)
+#define PNG_HIMASK ((png_uint_32)(~PNG_LOMASK >> PNG_HISHIFT))
+void /* PRIVATE */
+png_write_find_filter(png_structp png_ptr, png_row_infop row_info)
+{
+   png_bytep prev_row, best_row, row_buf;
+   png_uint_32 mins, bpp;
+   png_byte filter_to_do = png_ptr->do_filter;
+   png_uint_32 row_bytes = row_info->rowbytes;
+#if defined(PNG_WRITE_WEIGHTED_FILTER_SUPPORTED)
+   int num_p_filters = (int)png_ptr->num_prev_filters;
+#endif
+
+   png_debug(1, "in png_write_find_filter\n");
+   /* find out how many bytes offset each pixel is */
+   bpp = (row_info->pixel_depth + 7) / 8;
+
+   prev_row = png_ptr->prev_row;
+   best_row = row_buf = png_ptr->row_buf;
+   mins = PNG_MAXSUM;
+
+   /* The prediction method we use is to find which method provides the
+    * smallest value when summing the absolute values of the distances
+    * from zero, using anything >= 128 as negative numbers.  This is known
+    * as the "minimum sum of absolute differences" heuristic.  Other
+    * heuristics are the "weighted minimum sum of absolute differences"
+    * (experimental and can in theory improve compression), and the "zlib
+    * predictive" method (not implemented yet), which does test compressions
+    * of lines using different filter methods, and then chooses the
+    * (series of) filter(s) that give minimum compressed data size (VERY
+    * computationally expensive).
+    *
+    * GRR 980525:  consider also
+    *   (1) minimum sum of absolute differences from running average (i.e.,
+    *       keep running sum of non-absolute differences & count of bytes)
+    *       [track dispersion, too?  restart average if dispersion too large?]
+    *  (1b) minimum sum of absolute differences from sliding average, probably
+    *       with window size <= deflate window (usually 32K)
+    *   (2) minimum sum of squared differences from zero or running average
+    *       (i.e., ~ root-mean-square approach)
+    */
+
+
+   /* We don't need to test the 'no filter' case if this is the only filter
+    * that has been chosen, as it doesn't actually do anything to the data.
+    */
+   if ((filter_to_do & PNG_FILTER_NONE) &&
+       filter_to_do != PNG_FILTER_NONE)
+   {
+      png_bytep rp;
+      png_uint_32 sum = 0;
+      png_uint_32 i;
+      int v;
+
+      for (i = 0, rp = row_buf + 1; i < row_bytes; i++, rp++)
+      {
+         v = *rp;
+         sum += (v < 128) ? v : 256 - v;
+      }
+
+#if defined(PNG_WRITE_WEIGHTED_FILTER_SUPPORTED)
+      if (png_ptr->heuristic_method == PNG_FILTER_HEURISTIC_WEIGHTED)
+      {
+         png_uint_32 sumhi, sumlo;
+         int j;
+         sumlo = sum & PNG_LOMASK;
+         sumhi = (sum >> PNG_HISHIFT) & PNG_HIMASK; /* Gives us some footroom */
+
+         /* Reduce the sum if we match any of the previous rows */
+         for (j = 0; j < num_p_filters; j++)
+         {
+            if (png_ptr->prev_filters[j] == PNG_FILTER_VALUE_NONE)
+            {
+               sumlo = (sumlo * png_ptr->filter_weights[j]) >>
+                  PNG_WEIGHT_SHIFT;
+               sumhi = (sumhi * png_ptr->filter_weights[j]) >>
+                  PNG_WEIGHT_SHIFT;
+            }
+         }
+
+         /* Factor in the cost of this filter (this is here for completeness,
+          * but it makes no sense to have a "cost" for the NONE filter, as
+          * it has the minimum possible computational cost - none).
+          */
+         sumlo = (sumlo * png_ptr->filter_costs[PNG_FILTER_VALUE_NONE]) >>
+            PNG_COST_SHIFT;
+         sumhi = (sumhi * png_ptr->filter_costs[PNG_FILTER_VALUE_NONE]) >>
+            PNG_COST_SHIFT;
+
+         if (sumhi > PNG_HIMASK)
+            sum = PNG_MAXSUM;
+         else
+            sum = (sumhi << PNG_HISHIFT) + sumlo;
+      }
+#endif
+      mins = sum;
+   }
+
+   /* sub filter */
+   if (filter_to_do == PNG_FILTER_SUB)
+   /* it's the only filter so no testing is needed */
+   {
+      png_bytep rp, lp, dp;
+      png_uint_32 i;
+      for (i = 0, rp = row_buf + 1, dp = png_ptr->sub_row + 1; i < bpp;
+           i++, rp++, dp++)
+      {
+         *dp = *rp;
+      }
+      for (lp = row_buf + 1; i < row_bytes;
+         i++, rp++, lp++, dp++)
+      {
+         *dp = (png_byte)(((int)*rp - (int)*lp) & 0xff);
+      }
+      best_row = png_ptr->sub_row;
+   }
+
+   else if (filter_to_do & PNG_FILTER_SUB)
+   {
+      png_bytep rp, dp, lp;
+      png_uint_32 sum = 0, lmins = mins;
+      png_uint_32 i;
+      int v;
+
+#if defined(PNG_WRITE_WEIGHTED_FILTER_SUPPORTED)
+      /* We temporarily increase the "minimum sum" by the factor we
+       * would reduce the sum of this filter, so that we can do the
+       * early exit comparison without scaling the sum each time.
+       */
+      if (png_ptr->heuristic_method == PNG_FILTER_HEURISTIC_WEIGHTED)
+      {
+         int j;
+         png_uint_32 lmhi, lmlo;
+         lmlo = lmins & PNG_LOMASK;
+         lmhi = (lmins >> PNG_HISHIFT) & PNG_HIMASK;
+
+         for (j = 0; j < num_p_filters; j++)
+         {
+            if (png_ptr->prev_filters[j] == PNG_FILTER_VALUE_SUB)
+            {
+               lmlo = (lmlo * png_ptr->inv_filter_weights[j]) >>
+                  PNG_WEIGHT_SHIFT;
+               lmhi = (lmhi * png_ptr->inv_filter_weights[j]) >>
+                  PNG_WEIGHT_SHIFT;
+            }
+         }
+
+         lmlo = (lmlo * png_ptr->inv_filter_costs[PNG_FILTER_VALUE_SUB]) >>
+            PNG_COST_SHIFT;
+         lmhi = (lmhi * png_ptr->inv_filter_costs[PNG_FILTER_VALUE_SUB]) >>
+            PNG_COST_SHIFT;
+
+         if (lmhi > PNG_HIMASK)
+            lmins = PNG_MAXSUM;
+         else
+            lmins = (lmhi << PNG_HISHIFT) + lmlo;
+      }
+#endif
+
+      for (i = 0, rp = row_buf + 1, dp = png_ptr->sub_row + 1; i < bpp;
+           i++, rp++, dp++)
+      {
+         v = *dp = *rp;
+
+         sum += (v < 128) ? v : 256 - v;
+      }
+      for (lp = row_buf + 1; i < row_info->rowbytes;
+         i++, rp++, lp++, dp++)
+      {
+         v = *dp = (png_byte)(((int)*rp - (int)*lp) & 0xff);
+
+         sum += (v < 128) ? v : 256 - v;
+
+         if (sum > lmins)  /* We are already worse, don't continue. */
+            break;
+      }
+
+#if defined(PNG_WRITE_WEIGHTED_FILTER_SUPPORTED)
+      if (png_ptr->heuristic_method == PNG_FILTER_HEURISTIC_WEIGHTED)
+      {
+         int j;
+         png_uint_32 sumhi, sumlo;
+         sumlo = sum & PNG_LOMASK;
+         sumhi = (sum >> PNG_HISHIFT) & PNG_HIMASK;
+
+         for (j = 0; j < num_p_filters; j++)
+         {
+            if (png_ptr->prev_filters[j] == PNG_FILTER_VALUE_SUB)
+            {
+               sumlo = (sumlo * png_ptr->inv_filter_weights[j]) >>
+                  PNG_WEIGHT_SHIFT;
+               sumhi = (sumhi * png_ptr->inv_filter_weights[j]) >>
+                  PNG_WEIGHT_SHIFT;
+            }
+         }
+
+         sumlo = (sumlo * png_ptr->inv_filter_costs[PNG_FILTER_VALUE_SUB]) >>
+            PNG_COST_SHIFT;
+         sumhi = (sumhi * png_ptr->inv_filter_costs[PNG_FILTER_VALUE_SUB]) >>
+            PNG_COST_SHIFT;
+
+         if (sumhi > PNG_HIMASK)
+            sum = PNG_MAXSUM;
+         else
+            sum = (sumhi << PNG_HISHIFT) + sumlo;
+      }
+#endif
+
+      if (sum < mins)
+      {
+         mins = sum;
+         best_row = png_ptr->sub_row;
+      }
+   }
+
+   /* up filter */
+   if (filter_to_do == PNG_FILTER_UP)
+   {
+      png_bytep rp, dp, pp;
+      png_uint_32 i;
+
+      for (i = 0, rp = row_buf + 1, dp = png_ptr->up_row + 1,
+           pp = prev_row + 1; i < row_bytes;
+           i++, rp++, pp++, dp++)
+      {
+         *dp = (png_byte)(((int)*rp - (int)*pp) & 0xff);
+      }
+      best_row = png_ptr->up_row;
+   }
+
+   else if (filter_to_do & PNG_FILTER_UP)
+   {
+      png_bytep rp, dp, pp;
+      png_uint_32 sum = 0, lmins = mins;
+      png_uint_32 i;
+      int v;
+
+
+#if defined(PNG_WRITE_WEIGHTED_FILTER_SUPPORTED)
+      if (png_ptr->heuristic_method == PNG_FILTER_HEURISTIC_WEIGHTED)
+      {
+         int j;
+         png_uint_32 lmhi, lmlo;
+         lmlo = lmins & PNG_LOMASK;
+         lmhi = (lmins >> PNG_HISHIFT) & PNG_HIMASK;
+
+         for (j = 0; j < num_p_filters; j++)
+         {
+            if (png_ptr->prev_filters[j] == PNG_FILTER_VALUE_UP)
+            {
+               lmlo = (lmlo * png_ptr->inv_filter_weights[j]) >>
+                  PNG_WEIGHT_SHIFT;
+               lmhi = (lmhi * png_ptr->inv_filter_weights[j]) >>
+                  PNG_WEIGHT_SHIFT;
+            }
+         }
+
+         lmlo = (lmlo * png_ptr->inv_filter_costs[PNG_FILTER_VALUE_UP]) >>
+            PNG_COST_SHIFT;
+         lmhi = (lmhi * png_ptr->inv_filter_costs[PNG_FILTER_VALUE_UP]) >>
+            PNG_COST_SHIFT;
+
+         if (lmhi > PNG_HIMASK)
+            lmins = PNG_MAXSUM;
+         else
+            lmins = (lmhi << PNG_HISHIFT) + lmlo;
+      }
+#endif
+
+      for (i = 0, rp = row_buf + 1, dp = png_ptr->up_row + 1,
+           pp = prev_row + 1; i < row_bytes; i++)
+      {
+         v = *dp++ = (png_byte)(((int)*rp++ - (int)*pp++) & 0xff);
+
+         sum += (v < 128) ? v : 256 - v;
+
+         if (sum > lmins)  /* We are already worse, don't continue. */
+            break;
+      }
+
+#if defined(PNG_WRITE_WEIGHTED_FILTER_SUPPORTED)
+      if (png_ptr->heuristic_method == PNG_FILTER_HEURISTIC_WEIGHTED)
+      {
+         int j;
+         png_uint_32 sumhi, sumlo;
+         sumlo = sum & PNG_LOMASK;
+         sumhi = (sum >> PNG_HISHIFT) & PNG_HIMASK;
+
+         for (j = 0; j < num_p_filters; j++)
+         {
+            if (png_ptr->prev_filters[j] == PNG_FILTER_VALUE_UP)
+            {
+               sumlo = (sumlo * png_ptr->filter_weights[j]) >>
+                  PNG_WEIGHT_SHIFT;
+               sumhi = (sumhi * png_ptr->filter_weights[j]) >>
+                  PNG_WEIGHT_SHIFT;
+            }
+         }
+
+         sumlo = (sumlo * png_ptr->filter_costs[PNG_FILTER_VALUE_UP]) >>
+            PNG_COST_SHIFT;
+         sumhi = (sumhi * png_ptr->filter_costs[PNG_FILTER_VALUE_UP]) >>
+            PNG_COST_SHIFT;
+
+         if (sumhi > PNG_HIMASK)
+            sum = PNG_MAXSUM;
+         else
+            sum = (sumhi << PNG_HISHIFT) + sumlo;
+      }
+#endif
+
+      if (sum < mins)
+      {
+         mins = sum;
+         best_row = png_ptr->up_row;
+      }
+   }
+
+   /* avg filter */
+   if (filter_to_do == PNG_FILTER_AVG)
+   {
+      png_bytep rp, dp, pp, lp;
+      png_uint_32 i;
+      for (i = 0, rp = row_buf + 1, dp = png_ptr->avg_row + 1,
+           pp = prev_row + 1; i < bpp; i++)
+      {
+         *dp++ = (png_byte)(((int)*rp++ - ((int)*pp++ / 2)) & 0xff);
+      }
+      for (lp = row_buf + 1; i < row_bytes; i++)
+      {
+         *dp++ = (png_byte)(((int)*rp++ - (((int)*pp++ + (int)*lp++) / 2))
+                 & 0xff);
+      }
+      best_row = png_ptr->avg_row;
+   }
+
+   else if (filter_to_do & PNG_FILTER_AVG)
+   {
+      png_bytep rp, dp, pp, lp;
+      png_uint_32 sum = 0, lmins = mins;
+      png_uint_32 i;
+      int v;
+
+#if defined(PNG_WRITE_WEIGHTED_FILTER_SUPPORTED)
+      if (png_ptr->heuristic_method == PNG_FILTER_HEURISTIC_WEIGHTED)
+      {
+         int j;
+         png_uint_32 lmhi, lmlo;
+         lmlo = lmins & PNG_LOMASK;
+         lmhi = (lmins >> PNG_HISHIFT) & PNG_HIMASK;
+
+         for (j = 0; j < num_p_filters; j++)
+         {
+            if (png_ptr->prev_filters[j] == PNG_FILTER_VALUE_AVG)
+            {
+               lmlo = (lmlo * png_ptr->inv_filter_weights[j]) >>
+                  PNG_WEIGHT_SHIFT;
+               lmhi = (lmhi * png_ptr->inv_filter_weights[j]) >>
+                  PNG_WEIGHT_SHIFT;
+            }
+         }
+
+         lmlo = (lmlo * png_ptr->inv_filter_costs[PNG_FILTER_VALUE_AVG]) >>
+            PNG_COST_SHIFT;
+         lmhi = (lmhi * png_ptr->inv_filter_costs[PNG_FILTER_VALUE_AVG]) >>
+            PNG_COST_SHIFT;
+
+         if (lmhi > PNG_HIMASK)
+            lmins = PNG_MAXSUM;
+         else
+            lmins = (lmhi << PNG_HISHIFT) + lmlo;
+      }
+#endif
+
+      for (i = 0, rp = row_buf + 1, dp = png_ptr->avg_row + 1,
+           pp = prev_row + 1; i < bpp; i++)
+      {
+         v = *dp++ = (png_byte)(((int)*rp++ - ((int)*pp++ / 2)) & 0xff);
+
+         sum += (v < 128) ? v : 256 - v;
+      }
+      for (lp = row_buf + 1; i < row_bytes; i++)
+      {
+         v = *dp++ =
+          (png_byte)(((int)*rp++ - (((int)*pp++ + (int)*lp++) / 2)) & 0xff);
+
+         sum += (v < 128) ? v : 256 - v;
+
+         if (sum > lmins)  /* We are already worse, don't continue. */
+            break;
+      }
+
+#if defined(PNG_WRITE_WEIGHTED_FILTER_SUPPORTED)
+      if (png_ptr->heuristic_method == PNG_FILTER_HEURISTIC_WEIGHTED)
+      {
+         int j;
+         png_uint_32 sumhi, sumlo;
+         sumlo = sum & PNG_LOMASK;
+         sumhi = (sum >> PNG_HISHIFT) & PNG_HIMASK;
+
+         for (j = 0; j < num_p_filters; j++)
+         {
+            if (png_ptr->prev_filters[j] == PNG_FILTER_VALUE_NONE)
+            {
+               sumlo = (sumlo * png_ptr->filter_weights[j]) >>
+                  PNG_WEIGHT_SHIFT;
+               sumhi = (sumhi * png_ptr->filter_weights[j]) >>
+                  PNG_WEIGHT_SHIFT;
+            }
+         }
+
+         sumlo = (sumlo * png_ptr->filter_costs[PNG_FILTER_VALUE_AVG]) >>
+            PNG_COST_SHIFT;
+         sumhi = (sumhi * png_ptr->filter_costs[PNG_FILTER_VALUE_AVG]) >>
+            PNG_COST_SHIFT;
+
+         if (sumhi > PNG_HIMASK)
+            sum = PNG_MAXSUM;
+         else
+            sum = (sumhi << PNG_HISHIFT) + sumlo;
+      }
+#endif
+
+      if (sum < mins)
+      {
+         mins = sum;
+         best_row = png_ptr->avg_row;
+      }
+   }
+
+   /* Paeth filter */
+   if (filter_to_do == PNG_FILTER_PAETH)
+   {
+      png_bytep rp, dp, pp, cp, lp;
+      png_uint_32 i;
+      for (i = 0, rp = row_buf + 1, dp = png_ptr->paeth_row + 1,
+           pp = prev_row + 1; i < bpp; i++)
+      {
+         *dp++ = (png_byte)(((int)*rp++ - (int)*pp++) & 0xff);
+      }
+
+      for (lp = row_buf + 1, cp = prev_row + 1; i < row_bytes; i++)
+      {
+         int a, b, c, pa, pb, pc, p;
+
+         b = *pp++;
+         c = *cp++;
+         a = *lp++;
+
+         p = b - c;
+         pc = a - c;
+
+#ifdef PNG_USE_ABS
+         pa = abs(p);
+         pb = abs(pc);
+         pc = abs(p + pc);
+#else
+         pa = p < 0 ? -p : p;
+         pb = pc < 0 ? -pc : pc;
+         pc = (p + pc) < 0 ? -(p + pc) : p + pc;
+#endif
+
+         p = (pa <= pb && pa <=pc) ? a : (pb <= pc) ? b : c;
+
+         *dp++ = (png_byte)(((int)*rp++ - p) & 0xff);
+      }
+      best_row = png_ptr->paeth_row;
+   }
+
+   else if (filter_to_do & PNG_FILTER_PAETH)
+   {
+      png_bytep rp, dp, pp, cp, lp;
+      png_uint_32 sum = 0, lmins = mins;
+      png_uint_32 i;
+      int v;
+
+#if defined(PNG_WRITE_WEIGHTED_FILTER_SUPPORTED)
+      if (png_ptr->heuristic_method == PNG_FILTER_HEURISTIC_WEIGHTED)
+      {
+         int j;
+         png_uint_32 lmhi, lmlo;
+         lmlo = lmins & PNG_LOMASK;
+         lmhi = (lmins >> PNG_HISHIFT) & PNG_HIMASK;
+
+         for (j = 0; j < num_p_filters; j++)
+         {
+            if (png_ptr->prev_filters[j] == PNG_FILTER_VALUE_PAETH)
+            {
+               lmlo = (lmlo * png_ptr->inv_filter_weights[j]) >>
+                  PNG_WEIGHT_SHIFT;
+               lmhi = (lmhi * png_ptr->inv_filter_weights[j]) >>
+                  PNG_WEIGHT_SHIFT;
+            }
+         }
+
+         lmlo = (lmlo * png_ptr->inv_filter_costs[PNG_FILTER_VALUE_PAETH]) >>
+            PNG_COST_SHIFT;
+         lmhi = (lmhi * png_ptr->inv_filter_costs[PNG_FILTER_VALUE_PAETH]) >>
+            PNG_COST_SHIFT;
+
+         if (lmhi > PNG_HIMASK)
+            lmins = PNG_MAXSUM;
+         else
+            lmins = (lmhi << PNG_HISHIFT) + lmlo;
+      }
+#endif
+
+      for (i = 0, rp = row_buf + 1, dp = png_ptr->paeth_row + 1,
+           pp = prev_row + 1; i < bpp; i++)
+      {
+         v = *dp++ = (png_byte)(((int)*rp++ - (int)*pp++) & 0xff);
+
+         sum += (v < 128) ? v : 256 - v;
+      }
+
+      for (lp = row_buf + 1, cp = prev_row + 1; i < row_bytes; i++)
+      {
+         int a, b, c, pa, pb, pc, p;
+
+         b = *pp++;
+         c = *cp++;
+         a = *lp++;
+
+#ifndef PNG_SLOW_PAETH
+         p = b - c;
+         pc = a - c;
+#ifdef PNG_USE_ABS
+         pa = abs(p);
+         pb = abs(pc);
+         pc = abs(p + pc);
+#else
+         pa = p < 0 ? -p : p;
+         pb = pc < 0 ? -pc : pc;
+         pc = (p + pc) < 0 ? -(p + pc) : p + pc;
+#endif
+         p = (pa <= pb && pa <=pc) ? a : (pb <= pc) ? b : c;
+#else /* PNG_SLOW_PAETH */
+         p = a + b - c;
+         pa = abs(p - a);
+         pb = abs(p - b);
+         pc = abs(p - c);
+         if (pa <= pb && pa <= pc)
+            p = a;
+         else if (pb <= pc)
+            p = b;
+         else
+            p = c;
+#endif /* PNG_SLOW_PAETH */
+
+         v = *dp++ = (png_byte)(((int)*rp++ - p) & 0xff);
+
+         sum += (v < 128) ? v : 256 - v;
+
+         if (sum > lmins)  /* We are already worse, don't continue. */
+            break;
+      }
+
+#if defined(PNG_WRITE_WEIGHTED_FILTER_SUPPORTED)
+      if (png_ptr->heuristic_method == PNG_FILTER_HEURISTIC_WEIGHTED)
+      {
+         int j;
+         png_uint_32 sumhi, sumlo;
+         sumlo = sum & PNG_LOMASK;
+         sumhi = (sum >> PNG_HISHIFT) & PNG_HIMASK;
+
+         for (j = 0; j < num_p_filters; j++)
+         {
+            if (png_ptr->prev_filters[j] == PNG_FILTER_VALUE_PAETH)
+            {
+               sumlo = (sumlo * png_ptr->filter_weights[j]) >>
+                  PNG_WEIGHT_SHIFT;
+               sumhi = (sumhi * png_ptr->filter_weights[j]) >>
+                  PNG_WEIGHT_SHIFT;
+            }
+         }
+
+         sumlo = (sumlo * png_ptr->filter_costs[PNG_FILTER_VALUE_PAETH]) >>
+            PNG_COST_SHIFT;
+         sumhi = (sumhi * png_ptr->filter_costs[PNG_FILTER_VALUE_PAETH]) >>
+            PNG_COST_SHIFT;
+
+         if (sumhi > PNG_HIMASK)
+            sum = PNG_MAXSUM;
+         else
+            sum = (sumhi << PNG_HISHIFT) + sumlo;
+      }
+#endif
+
+      if (sum < mins)
+      {
+         best_row = png_ptr->paeth_row;
+      }
+   }
+
+   /* Do the actual writing of the filtered row data from the chosen filter. */
+
+   png_write_filtered_row(png_ptr, best_row);
+
+#if defined(PNG_WRITE_WEIGHTED_FILTER_SUPPORTED)
+   /* Save the type of filter we picked this time for future calculations */
+   if (png_ptr->num_prev_filters > 0)
+   {
+      int j;
+      for (j = 1; j < num_p_filters; j++)
+      {
+         png_ptr->prev_filters[j] = png_ptr->prev_filters[j - 1];
+      }
+      png_ptr->prev_filters[j] = best_row[0];
+   }
+#endif
+}
+
+
+/* Do the actual writing of a previously filtered row. */
+void /* PRIVATE */
+png_write_filtered_row(png_structp png_ptr, png_bytep filtered_row)
+{
+   png_debug(1, "in png_write_filtered_row\n");
+   png_debug1(2, "filter = %d\n", filtered_row[0]);
+   /* set up the zlib input buffer */
+
+   png_ptr->zstream.next_in = filtered_row;
+   png_ptr->zstream.avail_in = (uInt)png_ptr->row_info.rowbytes + 1;
+   /* repeat until we have compressed all the data */
+   do
+   {
+      int ret; /* return of zlib */
+
+      /* compress the data */
+      ret = deflate(&png_ptr->zstream, Z_NO_FLUSH);
+      /* check for compression errors */
+      if (ret != Z_OK)
+      {
+         if (png_ptr->zstream.msg != NULL)
+            png_error(png_ptr, png_ptr->zstream.msg);
+         else
+            png_error(png_ptr, "zlib error");
+      }
+
+      /* see if it is time to write another IDAT */
+      if (!(png_ptr->zstream.avail_out))
+      {
+         /* write the IDAT and reset the zlib output buffer */
+         png_write_IDAT(png_ptr, png_ptr->zbuf, png_ptr->zbuf_size);
+         png_ptr->zstream.next_out = png_ptr->zbuf;
+         png_ptr->zstream.avail_out = (uInt)png_ptr->zbuf_size;
+      }
+   /* repeat until all data has been compressed */
+   } while (png_ptr->zstream.avail_in);
+
+   /* swap the current and previous rows */
+   if (png_ptr->prev_row != NULL)
+   {
+      png_bytep tptr;
+
+      tptr = png_ptr->prev_row;
+      png_ptr->prev_row = png_ptr->row_buf;
+      png_ptr->row_buf = tptr;
+   }
+
+   /* finish row - updates counters and flushes zlib if last row */
+   png_write_finish_row(png_ptr);
+
+#if defined(PNG_WRITE_FLUSH_SUPPORTED)
+   png_ptr->flush_rows++;
+
+   if (png_ptr->flush_dist > 0 &&
+       png_ptr->flush_rows >= png_ptr->flush_dist)
+   {
+      png_write_flush(png_ptr);
+   }
+#endif
+}
+#endif /* PNG_WRITE_SUPPORTED */
diff --git a/collects/plot/src/all/ps.h b/collects/plot/src/all/ps.h
new file mode 100644
index 0000000000..a672f0ca66
--- /dev/null
+++ b/collects/plot/src/all/ps.h
@@ -0,0 +1,70 @@
+/*
+ * These definitions are for the Postscript (ps.c) and 
+ * Postscript/LaTeX (pstex.c) drivers
+ */
+
+#ifndef __PS_H__
+#define __PS_H__
+
+/* top level declarations */
+
+#define LINELENGTH      78
+#define COPIES          1
+#define XSIZE           540		/* 7.5 x 10 [inches]    */
+#define YSIZE           720		/* (72 points = 1 inch) */
+#define ENLARGE         5
+#define XPSSIZE         ENLARGE*XSIZE
+#define YPSSIZE         ENLARGE*YSIZE
+#define XOFFSET         32		/* Margins --     */
+#define YOFFSET         32		/* .5 inches each */
+#define PSX             XPSSIZE-1
+#define PSY             YPSSIZE-1
+#define OF		pls->OutFile
+#define MIN_WIDTH	1		/* Minimum pen width */
+#define MAX_WIDTH	30		/* Maximum pen width */
+#define DEF_WIDTH	3		/* Default pen width */
+
+/* These are for covering the page with the background color */
+
+#define XMIN		-XOFFSET*ENLARGE
+#define XMAX		PSX+XOFFSET*ENLARGE
+#define YMIN		-XOFFSET*ENLARGE
+#define YMAX		PSY+XOFFSET*ENLARGE
+
+/* Struct to hold device-specific info. */
+
+typedef struct {
+    PLFLT pxlx, pxly;
+    PLINT xold, yold;
+
+    PLINT xmin, xmax, xlen;
+    PLINT ymin, ymax, ylen;
+
+    PLINT xmin_dev, xmax_dev, xlen_dev;
+    PLINT ymin_dev, ymax_dev, ylen_dev;
+
+    PLFLT xscale_dev, yscale_dev;
+
+    int llx, lly, urx, ury, ptcnt;
+} PSDev;
+
+void plD_init_pstex		(PLStream *);
+void plD_line_pstex		(PLStream *, short, short, short, short);
+void plD_polyline_pstex		(PLStream *, short *, short *, PLINT);
+void plD_eop_pstex		(PLStream *);
+void plD_bop_pstex		(PLStream *);
+void plD_tidy_pstex		(PLStream *);
+void plD_state_pstex		(PLStream *, PLINT);
+void plD_esc_pstex		(PLStream *, PLINT, void *);
+
+void plD_init_psm		(PLStream *);
+void plD_init_psc		(PLStream *);
+void plD_line_ps		(PLStream *, short, short, short, short);
+void plD_polyline_ps	        (PLStream *, short *, short *, PLINT);
+void plD_eop_ps		        (PLStream *);
+void plD_bop_ps			(PLStream *);
+void plD_tidy_ps		(PLStream *);
+void plD_state_ps	        (PLStream *, PLINT);
+void plD_esc_ps			(PLStream *, PLINT, void *);
+
+#endif /* __PS_H__ */
diff --git a/collects/plot/src/all/resource.h b/collects/plot/src/all/resource.h
new file mode 100644
index 0000000000..0ea8298b8a
--- /dev/null
+++ b/collects/plot/src/all/resource.h
@@ -0,0 +1,24 @@
+//{{NO_DEPENDENCIES}}
+// Microsoft Developer Studio generated include file.
+// Used by plplot.rc
+//
+#define IDR_MENU1                       101
+#define IDI_ICON1                       102
+#define PLCOMMANDS                      106
+#define PLICON                          107
+#define CM_NEXTPLOT                     40002
+#define CM_PRINTPLOT                    40003
+#define CM_EDITCOPY                     40004
+#define CM_ABOUT                        40005
+
+// Next default values for new objects
+// 
+#ifdef APSTUDIO_INVOKED
+#ifndef APSTUDIO_READONLY_SYMBOLS
+#define _APS_NO_MFC                     1
+#define _APS_NEXT_RESOURCE_VALUE        108
+#define _APS_NEXT_COMMAND_VALUE         40006
+#define _APS_NEXT_CONTROL_VALUE         1000
+#define _APS_NEXT_SYMED_VALUE           101
+#endif
+#endif
diff --git a/collects/plot/src/all/trees.c b/collects/plot/src/all/trees.c
new file mode 100644
index 0000000000..ea29ca1e4a
--- /dev/null
+++ b/collects/plot/src/all/trees.c
@@ -0,0 +1,1214 @@
+/* trees.c -- output deflated data using Huffman coding
+ * Copyright (C) 1995-2002 Jean-loup Gailly
+ * For conditions of distribution and use, see copyright notice in zlib.h 
+ */
+
+/*
+ *  ALGORITHM
+ *
+ *      The "deflation" process uses several Huffman trees. The more
+ *      common source values are represented by shorter bit sequences.
+ *
+ *      Each code tree is stored in a compressed form which is itself
+ * a Huffman encoding of the lengths of all the code strings (in
+ * ascending order by source values).  The actual code strings are
+ * reconstructed from the lengths in the inflate process, as described
+ * in the deflate specification.
+ *
+ *  REFERENCES
+ *
+ *      Deutsch, L.P.,"'Deflate' Compressed Data Format Specification".
+ *      Available in ftp.uu.net:/pub/archiving/zip/doc/deflate-1.1.doc
+ *
+ *      Storer, James A.
+ *          Data Compression:  Methods and Theory, pp. 49-50.
+ *          Computer Science Press, 1988.  ISBN 0-7167-8156-5.
+ *
+ *      Sedgewick, R.
+ *          Algorithms, p290.
+ *          Addison-Wesley, 1983. ISBN 0-201-06672-6.
+ */
+
+/* @(#) $Id: trees.c,v 1.1 2004/03/01 20:54:55 cozmic Exp $ */
+
+/* #define GEN_TREES_H */
+
+#include "deflate.h"
+
+#ifdef DEBUG
+#  include <ctype.h>
+#endif
+
+/* ===========================================================================
+ * Constants
+ */
+
+#define MAX_BL_BITS 7
+/* Bit length codes must not exceed MAX_BL_BITS bits */
+
+#define END_BLOCK 256
+/* end of block literal code */
+
+#define REP_3_6      16
+/* repeat previous bit length 3-6 times (2 bits of repeat count) */
+
+#define REPZ_3_10    17
+/* repeat a zero length 3-10 times  (3 bits of repeat count) */
+
+#define REPZ_11_138  18
+/* repeat a zero length 11-138 times  (7 bits of repeat count) */
+
+local const int extra_lbits[LENGTH_CODES] /* extra bits for each length code */
+   = {0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,3,3,3,3,4,4,4,4,5,5,5,5,0};
+
+local const int extra_dbits[D_CODES] /* extra bits for each distance code */
+   = {0,0,0,0,1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8,9,9,10,10,11,11,12,12,13,13};
+
+local const int extra_blbits[BL_CODES]/* extra bits for each bit length code */
+   = {0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,2,3,7};
+
+local const uch bl_order[BL_CODES]
+   = {16,17,18,0,8,7,9,6,10,5,11,4,12,3,13,2,14,1,15};
+/* The lengths of the bit length codes are sent in order of decreasing
+ * probability, to avoid transmitting the lengths for unused bit length codes.
+ */
+
+#define Buf_size (8 * 2*sizeof(char))
+/* Number of bits used within bi_buf. (bi_buf might be implemented on
+ * more than 16 bits on some systems.)
+ */
+
+/* ===========================================================================
+ * Local data. These are initialized only once.
+ */
+
+#define DIST_CODE_LEN  512 /* see definition of array dist_code below */
+
+#if defined(GEN_TREES_H) || !defined(STDC)
+/* non ANSI compilers may not accept trees.h */
+
+local ct_data static_ltree[L_CODES+2];
+/* The static literal tree. Since the bit lengths are imposed, there is no
+ * need for the L_CODES extra codes used during heap construction. However
+ * The codes 286 and 287 are needed to build a canonical tree (see _tr_init
+ * below).
+ */
+
+local ct_data static_dtree[D_CODES];
+/* The static distance tree. (Actually a trivial tree since all codes use
+ * 5 bits.)
+ */
+
+uch _dist_code[DIST_CODE_LEN];
+/* Distance codes. The first 256 values correspond to the distances
+ * 3 .. 258, the last 256 values correspond to the top 8 bits of
+ * the 15 bit distances.
+ */
+
+uch _length_code[MAX_MATCH-MIN_MATCH+1];
+/* length code for each normalized match length (0 == MIN_MATCH) */
+
+local int base_length[LENGTH_CODES];
+/* First normalized length for each code (0 = MIN_MATCH) */
+
+local int base_dist[D_CODES];
+/* First normalized distance for each code (0 = distance of 1) */
+
+#else
+#  include "trees.h"
+#endif /* GEN_TREES_H */
+
+struct static_tree_desc_s {
+    const ct_data *static_tree;  /* static tree or NULL */
+    const intf *extra_bits;      /* extra bits for each code or NULL */
+    int     extra_base;          /* base index for extra_bits */
+    int     elems;               /* max number of elements in the tree */
+    int     max_length;          /* max bit length for the codes */
+};
+
+local static_tree_desc  static_l_desc =
+{static_ltree, extra_lbits, LITERALS+1, L_CODES, MAX_BITS};
+
+local static_tree_desc  static_d_desc =
+{static_dtree, extra_dbits, 0,          D_CODES, MAX_BITS};
+
+local static_tree_desc  static_bl_desc =
+{(const ct_data *)0, extra_blbits, 0,   BL_CODES, MAX_BL_BITS};
+
+/* ===========================================================================
+ * Local (static) routines in this file.
+ */
+
+local void tr_static_init OF((void));
+local void init_block     OF((deflate_state *s));
+local void pqdownheap     OF((deflate_state *s, ct_data *tree, int k));
+local void gen_bitlen     OF((deflate_state *s, tree_desc *desc));
+local void gen_codes      OF((ct_data *tree, int max_code, ushf *bl_count));
+local void build_tree     OF((deflate_state *s, tree_desc *desc));
+local void scan_tree      OF((deflate_state *s, ct_data *tree, int max_code));
+local void send_tree      OF((deflate_state *s, ct_data *tree, int max_code));
+local int  build_bl_tree  OF((deflate_state *s));
+local void send_all_trees OF((deflate_state *s, int lcodes, int dcodes,
+                              int blcodes));
+local void compress_block OF((deflate_state *s, ct_data *ltree,
+                              ct_data *dtree));
+local void set_data_type  OF((deflate_state *s));
+local unsigned bi_reverse OF((unsigned value, int length));
+local void bi_windup      OF((deflate_state *s));
+local void bi_flush       OF((deflate_state *s));
+local void copy_block     OF((deflate_state *s, charf *buf, unsigned len,
+                              int header));
+
+#ifdef GEN_TREES_H
+local void gen_trees_header OF((void));
+#endif
+
+#ifndef DEBUG
+#  define send_code(s, c, tree) send_bits(s, tree[c].Code, tree[c].Len)
+   /* Send a code of the given tree. c and tree must not have side effects */
+
+#else /* DEBUG */
+#  define send_code(s, c, tree) \
+     { if (z_verbose>2) fprintf(stderr,"\ncd %3d ",(c)); \
+       send_bits(s, tree[c].Code, tree[c].Len); }
+#endif
+
+/* ===========================================================================
+ * Output a short LSB first on the stream.
+ * IN assertion: there is enough room in pendingBuf.
+ */
+#define put_short(s, w) { \
+    put_byte(s, (uch)((w) & 0xff)); \
+    put_byte(s, (uch)((ush)(w) >> 8)); \
+}
+
+/* ===========================================================================
+ * Send a value on a given number of bits.
+ * IN assertion: length <= 16 and value fits in length bits.
+ */
+#ifdef DEBUG
+local void send_bits      OF((deflate_state *s, int value, int length));
+
+local void send_bits(s, value, length)
+    deflate_state *s;
+    int value;  /* value to send */
+    int length; /* number of bits */
+{
+    Tracevv((stderr," l %2d v %4x ", length, value));
+    Assert(length > 0 && length <= 15, "invalid length");
+    s->bits_sent += (ulg)length;
+
+    /* If not enough room in bi_buf, use (valid) bits from bi_buf and
+     * (16 - bi_valid) bits from value, leaving (width - (16-bi_valid))
+     * unused bits in value.
+     */
+    if (s->bi_valid > (int)Buf_size - length) {
+        s->bi_buf |= (value << s->bi_valid);
+        put_short(s, s->bi_buf);
+        s->bi_buf = (ush)value >> (Buf_size - s->bi_valid);
+        s->bi_valid += length - Buf_size;
+    } else {
+        s->bi_buf |= value << s->bi_valid;
+        s->bi_valid += length;
+    }
+}
+#else /* !DEBUG */
+
+#define send_bits(s, value, length) \
+{ int len = length;\
+  if (s->bi_valid > (int)Buf_size - len) {\
+    int val = value;\
+    s->bi_buf |= (val << s->bi_valid);\
+    put_short(s, s->bi_buf);\
+    s->bi_buf = (ush)val >> (Buf_size - s->bi_valid);\
+    s->bi_valid += len - Buf_size;\
+  } else {\
+    s->bi_buf |= (value) << s->bi_valid;\
+    s->bi_valid += len;\
+  }\
+}
+#endif /* DEBUG */
+
+
+#define MAX(a,b) (a >= b ? a : b)
+/* the arguments must not have side effects */
+
+/* ===========================================================================
+ * Initialize the various 'constant' tables.
+ */
+local void tr_static_init()
+{
+#if defined(GEN_TREES_H) || !defined(STDC)
+    static int static_init_done = 0;
+    int n;        /* iterates over tree elements */
+    int bits;     /* bit counter */
+    int length;   /* length value */
+    int code;     /* code value */
+    int dist;     /* distance index */
+    ush bl_count[MAX_BITS+1];
+    /* number of codes at each bit length for an optimal tree */
+
+    if (static_init_done) return;
+
+    /* For some embedded targets, global variables are not initialized: */
+    static_l_desc.static_tree = static_ltree;
+    static_l_desc.extra_bits = extra_lbits;
+    static_d_desc.static_tree = static_dtree;
+    static_d_desc.extra_bits = extra_dbits;
+    static_bl_desc.extra_bits = extra_blbits;
+
+    /* Initialize the mapping length (0..255) -> length code (0..28) */
+    length = 0;
+    for (code = 0; code < LENGTH_CODES-1; code++) {
+        base_length[code] = length;
+        for (n = 0; n < (1<<extra_lbits[code]); n++) {
+            _length_code[length++] = (uch)code;
+        }
+    }
+    Assert (length == 256, "tr_static_init: length != 256");
+    /* Note that the length 255 (match length 258) can be represented
+     * in two different ways: code 284 + 5 bits or code 285, so we
+     * overwrite length_code[255] to use the best encoding:
+     */
+    _length_code[length-1] = (uch)code;
+
+    /* Initialize the mapping dist (0..32K) -> dist code (0..29) */
+    dist = 0;
+    for (code = 0 ; code < 16; code++) {
+        base_dist[code] = dist;
+        for (n = 0; n < (1<<extra_dbits[code]); n++) {
+            _dist_code[dist++] = (uch)code;
+        }
+    }
+    Assert (dist == 256, "tr_static_init: dist != 256");
+    dist >>= 7; /* from now on, all distances are divided by 128 */
+    for ( ; code < D_CODES; code++) {
+        base_dist[code] = dist << 7;
+        for (n = 0; n < (1<<(extra_dbits[code]-7)); n++) {
+            _dist_code[256 + dist++] = (uch)code;
+        }
+    }
+    Assert (dist == 256, "tr_static_init: 256+dist != 512");
+
+    /* Construct the codes of the static literal tree */
+    for (bits = 0; bits <= MAX_BITS; bits++) bl_count[bits] = 0;
+    n = 0;
+    while (n <= 143) static_ltree[n++].Len = 8, bl_count[8]++;
+    while (n <= 255) static_ltree[n++].Len = 9, bl_count[9]++;
+    while (n <= 279) static_ltree[n++].Len = 7, bl_count[7]++;
+    while (n <= 287) static_ltree[n++].Len = 8, bl_count[8]++;
+    /* Codes 286 and 287 do not exist, but we must include them in the
+     * tree construction to get a canonical Huffman tree (longest code
+     * all ones)
+     */
+    gen_codes((ct_data *)static_ltree, L_CODES+1, bl_count);
+
+    /* The static distance tree is trivial: */
+    for (n = 0; n < D_CODES; n++) {
+        static_dtree[n].Len = 5;
+        static_dtree[n].Code = bi_reverse((unsigned)n, 5);
+    }
+    static_init_done = 1;
+
+#  ifdef GEN_TREES_H
+    gen_trees_header();
+#  endif
+#endif /* defined(GEN_TREES_H) || !defined(STDC) */
+}
+
+/* ===========================================================================
+ * Genererate the file trees.h describing the static trees.
+ */
+#ifdef GEN_TREES_H
+#  ifndef DEBUG
+#    include <stdio.h>
+#  endif
+
+#  define SEPARATOR(i, last, width) \
+      ((i) == (last)? "\n};\n\n" :    \
+       ((i) % (width) == (width)-1 ? ",\n" : ", "))
+
+void gen_trees_header()
+{
+    FILE *header = fopen("trees.h", "w");
+    int i;
+
+    Assert (header != NULL, "Can't open trees.h");
+    fprintf(header,
+	    "/* header created automatically with -DGEN_TREES_H */\n\n");
+
+    fprintf(header, "local const ct_data static_ltree[L_CODES+2] = {\n");
+    for (i = 0; i < L_CODES+2; i++) {
+	fprintf(header, "{{%3u},{%3u}}%s", static_ltree[i].Code,
+		static_ltree[i].Len, SEPARATOR(i, L_CODES+1, 5));
+    }
+
+    fprintf(header, "local const ct_data static_dtree[D_CODES] = {\n");
+    for (i = 0; i < D_CODES; i++) {
+	fprintf(header, "{{%2u},{%2u}}%s", static_dtree[i].Code,
+		static_dtree[i].Len, SEPARATOR(i, D_CODES-1, 5));
+    }
+
+    fprintf(header, "const uch _dist_code[DIST_CODE_LEN] = {\n");
+    for (i = 0; i < DIST_CODE_LEN; i++) {
+	fprintf(header, "%2u%s", _dist_code[i],
+		SEPARATOR(i, DIST_CODE_LEN-1, 20));
+    }
+
+    fprintf(header, "const uch _length_code[MAX_MATCH-MIN_MATCH+1]= {\n");
+    for (i = 0; i < MAX_MATCH-MIN_MATCH+1; i++) {
+	fprintf(header, "%2u%s", _length_code[i],
+		SEPARATOR(i, MAX_MATCH-MIN_MATCH, 20));
+    }
+
+    fprintf(header, "local const int base_length[LENGTH_CODES] = {\n");
+    for (i = 0; i < LENGTH_CODES; i++) {
+	fprintf(header, "%1u%s", base_length[i],
+		SEPARATOR(i, LENGTH_CODES-1, 20));
+    }
+
+    fprintf(header, "local const int base_dist[D_CODES] = {\n");
+    for (i = 0; i < D_CODES; i++) {
+	fprintf(header, "%5u%s", base_dist[i],
+		SEPARATOR(i, D_CODES-1, 10));
+    }
+
+    fclose(header);
+}
+#endif /* GEN_TREES_H */
+
+/* ===========================================================================
+ * Initialize the tree data structures for a new zlib stream.
+ */
+void _tr_init(s)
+    deflate_state *s;
+{
+    tr_static_init();
+
+    s->l_desc.dyn_tree = s->dyn_ltree;
+    s->l_desc.stat_desc = &static_l_desc;
+
+    s->d_desc.dyn_tree = s->dyn_dtree;
+    s->d_desc.stat_desc = &static_d_desc;
+
+    s->bl_desc.dyn_tree = s->bl_tree;
+    s->bl_desc.stat_desc = &static_bl_desc;
+
+    s->bi_buf = 0;
+    s->bi_valid = 0;
+    s->last_eob_len = 8; /* enough lookahead for inflate */
+#ifdef DEBUG
+    s->compressed_len = 0L;
+    s->bits_sent = 0L;
+#endif
+
+    /* Initialize the first block of the first file: */
+    init_block(s);
+}
+
+/* ===========================================================================
+ * Initialize a new block.
+ */
+local void init_block(s)
+    deflate_state *s;
+{
+    int n; /* iterates over tree elements */
+
+    /* Initialize the trees. */
+    for (n = 0; n < L_CODES;  n++) s->dyn_ltree[n].Freq = 0;
+    for (n = 0; n < D_CODES;  n++) s->dyn_dtree[n].Freq = 0;
+    for (n = 0; n < BL_CODES; n++) s->bl_tree[n].Freq = 0;
+
+    s->dyn_ltree[END_BLOCK].Freq = 1;
+    s->opt_len = s->static_len = 0L;
+    s->last_lit = s->matches = 0;
+}
+
+#define SMALLEST 1
+/* Index within the heap array of least frequent node in the Huffman tree */
+
+
+/* ===========================================================================
+ * Remove the smallest element from the heap and recreate the heap with
+ * one less element. Updates heap and heap_len.
+ */
+#define pqremove(s, tree, top) \
+{\
+    top = s->heap[SMALLEST]; \
+    s->heap[SMALLEST] = s->heap[s->heap_len--]; \
+    pqdownheap(s, tree, SMALLEST); \
+}
+
+/* ===========================================================================
+ * Compares to subtrees, using the tree depth as tie breaker when
+ * the subtrees have equal frequency. This minimizes the worst case length.
+ */
+#define smaller(tree, n, m, depth) \
+   (tree[n].Freq < tree[m].Freq || \
+   (tree[n].Freq == tree[m].Freq && depth[n] <= depth[m]))
+
+/* ===========================================================================
+ * Restore the heap property by moving down the tree starting at node k,
+ * exchanging a node with the smallest of its two sons if necessary, stopping
+ * when the heap property is re-established (each father smaller than its
+ * two sons).
+ */
+local void pqdownheap(s, tree, k)
+    deflate_state *s;
+    ct_data *tree;  /* the tree to restore */
+    int k;               /* node to move down */
+{
+    int v = s->heap[k];
+    int j = k << 1;  /* left son of k */
+    while (j <= s->heap_len) {
+        /* Set j to the smallest of the two sons: */
+        if (j < s->heap_len &&
+            smaller(tree, s->heap[j+1], s->heap[j], s->depth)) {
+            j++;
+        }
+        /* Exit if v is smaller than both sons */
+        if (smaller(tree, v, s->heap[j], s->depth)) break;
+
+        /* Exchange v with the smallest son */
+        s->heap[k] = s->heap[j];  k = j;
+
+        /* And continue down the tree, setting j to the left son of k */
+        j <<= 1;
+    }
+    s->heap[k] = v;
+}
+
+/* ===========================================================================
+ * Compute the optimal bit lengths for a tree and update the total bit length
+ * for the current block.
+ * IN assertion: the fields freq and dad are set, heap[heap_max] and
+ *    above are the tree nodes sorted by increasing frequency.
+ * OUT assertions: the field len is set to the optimal bit length, the
+ *     array bl_count contains the frequencies for each bit length.
+ *     The length opt_len is updated; static_len is also updated if stree is
+ *     not null.
+ */
+local void gen_bitlen(s, desc)
+    deflate_state *s;
+    tree_desc *desc;    /* the tree descriptor */
+{
+    ct_data *tree        = desc->dyn_tree;
+    int max_code         = desc->max_code;
+    const ct_data *stree = desc->stat_desc->static_tree;
+    const intf *extra    = desc->stat_desc->extra_bits;
+    int base             = desc->stat_desc->extra_base;
+    int max_length       = desc->stat_desc->max_length;
+    int h;              /* heap index */
+    int n, m;           /* iterate over the tree elements */
+    int bits;           /* bit length */
+    int xbits;          /* extra bits */
+    ush f;              /* frequency */
+    int overflow = 0;   /* number of elements with bit length too large */
+
+    for (bits = 0; bits <= MAX_BITS; bits++) s->bl_count[bits] = 0;
+
+    /* In a first pass, compute the optimal bit lengths (which may
+     * overflow in the case of the bit length tree).
+     */
+    tree[s->heap[s->heap_max]].Len = 0; /* root of the heap */
+
+    for (h = s->heap_max+1; h < HEAP_SIZE; h++) {
+        n = s->heap[h];
+        bits = tree[tree[n].Dad].Len + 1;
+        if (bits > max_length) bits = max_length, overflow++;
+        tree[n].Len = (ush)bits;
+        /* We overwrite tree[n].Dad which is no longer needed */
+
+        if (n > max_code) continue; /* not a leaf node */
+
+        s->bl_count[bits]++;
+        xbits = 0;
+        if (n >= base) xbits = extra[n-base];
+        f = tree[n].Freq;
+        s->opt_len += (ulg)f * (bits + xbits);
+        if (stree) s->static_len += (ulg)f * (stree[n].Len + xbits);
+    }
+    if (overflow == 0) return;
+
+    Trace((stderr,"\nbit length overflow\n"));
+    /* This happens for example on obj2 and pic of the Calgary corpus */
+
+    /* Find the first bit length which could increase: */
+    do {
+        bits = max_length-1;
+        while (s->bl_count[bits] == 0) bits--;
+        s->bl_count[bits]--;      /* move one leaf down the tree */
+        s->bl_count[bits+1] += 2; /* move one overflow item as its brother */
+        s->bl_count[max_length]--;
+        /* The brother of the overflow item also moves one step up,
+         * but this does not affect bl_count[max_length]
+         */
+        overflow -= 2;
+    } while (overflow > 0);
+
+    /* Now recompute all bit lengths, scanning in increasing frequency.
+     * h is still equal to HEAP_SIZE. (It is simpler to reconstruct all
+     * lengths instead of fixing only the wrong ones. This idea is taken
+     * from 'ar' written by Haruhiko Okumura.)
+     */
+    for (bits = max_length; bits != 0; bits--) {
+        n = s->bl_count[bits];
+        while (n != 0) {
+            m = s->heap[--h];
+            if (m > max_code) continue;
+            if (tree[m].Len != (unsigned) bits) {
+                Trace((stderr,"code %d bits %d->%d\n", m, tree[m].Len, bits));
+                s->opt_len += ((long)bits - (long)tree[m].Len)
+                              *(long)tree[m].Freq;
+                tree[m].Len = (ush)bits;
+            }
+            n--;
+        }
+    }
+}
+
+/* ===========================================================================
+ * Generate the codes for a given tree and bit counts (which need not be
+ * optimal).
+ * IN assertion: the array bl_count contains the bit length statistics for
+ * the given tree and the field len is set for all tree elements.
+ * OUT assertion: the field code is set for all tree elements of non
+ *     zero code length.
+ */
+local void gen_codes (tree, max_code, bl_count)
+    ct_data *tree;             /* the tree to decorate */
+    int max_code;              /* largest code with non zero frequency */
+    ushf *bl_count;            /* number of codes at each bit length */
+{
+    ush next_code[MAX_BITS+1]; /* next code value for each bit length */
+    ush code = 0;              /* running code value */
+    int bits;                  /* bit index */
+    int n;                     /* code index */
+
+    /* The distribution counts are first used to generate the code values
+     * without bit reversal.
+     */
+    for (bits = 1; bits <= MAX_BITS; bits++) {
+        next_code[bits] = code = (code + bl_count[bits-1]) << 1;
+    }
+    /* Check that the bit counts in bl_count are consistent. The last code
+     * must be all ones.
+     */
+    Assert (code + bl_count[MAX_BITS]-1 == (1<<MAX_BITS)-1,
+            "inconsistent bit counts");
+    Tracev((stderr,"\ngen_codes: max_code %d ", max_code));
+
+    for (n = 0;  n <= max_code; n++) {
+        int len = tree[n].Len;
+        if (len == 0) continue;
+        /* Now reverse the bits */
+        tree[n].Code = bi_reverse(next_code[len]++, len);
+
+        Tracecv(tree != static_ltree, (stderr,"\nn %3d %c l %2d c %4x (%x) ",
+             n, (isgraph(n) ? n : ' '), len, tree[n].Code, next_code[len]-1));
+    }
+}
+
+/* ===========================================================================
+ * Construct one Huffman tree and assigns the code bit strings and lengths.
+ * Update the total bit length for the current block.
+ * IN assertion: the field freq is set for all tree elements.
+ * OUT assertions: the fields len and code are set to the optimal bit length
+ *     and corresponding code. The length opt_len is updated; static_len is
+ *     also updated if stree is not null. The field max_code is set.
+ */
+local void build_tree(s, desc)
+    deflate_state *s;
+    tree_desc *desc; /* the tree descriptor */
+{
+    ct_data *tree         = desc->dyn_tree;
+    const ct_data *stree  = desc->stat_desc->static_tree;
+    int elems             = desc->stat_desc->elems;
+    int n, m;          /* iterate over heap elements */
+    int max_code = -1; /* largest code with non zero frequency */
+    int node;          /* new node being created */
+
+    /* Construct the initial heap, with least frequent element in
+     * heap[SMALLEST]. The sons of heap[n] are heap[2*n] and heap[2*n+1].
+     * heap[0] is not used.
+     */
+    s->heap_len = 0, s->heap_max = HEAP_SIZE;
+
+    for (n = 0; n < elems; n++) {
+        if (tree[n].Freq != 0) {
+            s->heap[++(s->heap_len)] = max_code = n;
+            s->depth[n] = 0;
+        } else {
+            tree[n].Len = 0;
+        }
+    }
+
+    /* The pkzip format requires that at least one distance code exists,
+     * and that at least one bit should be sent even if there is only one
+     * possible code. So to avoid special checks later on we force at least
+     * two codes of non zero frequency.
+     */
+    while (s->heap_len < 2) {
+        node = s->heap[++(s->heap_len)] = (max_code < 2 ? ++max_code : 0);
+        tree[node].Freq = 1;
+        s->depth[node] = 0;
+        s->opt_len--; if (stree) s->static_len -= stree[node].Len;
+        /* node is 0 or 1 so it does not have extra bits */
+    }
+    desc->max_code = max_code;
+
+    /* The elements heap[heap_len/2+1 .. heap_len] are leaves of the tree,
+     * establish sub-heaps of increasing lengths:
+     */
+    for (n = s->heap_len/2; n >= 1; n--) pqdownheap(s, tree, n);
+
+    /* Construct the Huffman tree by repeatedly combining the least two
+     * frequent nodes.
+     */
+    node = elems;              /* next internal node of the tree */
+    do {
+        pqremove(s, tree, n);  /* n = node of least frequency */
+        m = s->heap[SMALLEST]; /* m = node of next least frequency */
+
+        s->heap[--(s->heap_max)] = n; /* keep the nodes sorted by frequency */
+        s->heap[--(s->heap_max)] = m;
+
+        /* Create a new node father of n and m */
+        tree[node].Freq = tree[n].Freq + tree[m].Freq;
+        s->depth[node] = (uch) (MAX(s->depth[n], s->depth[m]) + 1);
+        tree[n].Dad = tree[m].Dad = (ush)node;
+#ifdef DUMP_BL_TREE
+        if (tree == s->bl_tree) {
+            fprintf(stderr,"\nnode %d(%d), sons %d(%d) %d(%d)",
+                    node, tree[node].Freq, n, tree[n].Freq, m, tree[m].Freq);
+        }
+#endif
+        /* and insert the new node in the heap */
+        s->heap[SMALLEST] = node++;
+        pqdownheap(s, tree, SMALLEST);
+
+    } while (s->heap_len >= 2);
+
+    s->heap[--(s->heap_max)] = s->heap[SMALLEST];
+
+    /* At this point, the fields freq and dad are set. We can now
+     * generate the bit lengths.
+     */
+    gen_bitlen(s, (tree_desc *)desc);
+
+    /* The field len is now set, we can generate the bit codes */
+    gen_codes ((ct_data *)tree, max_code, s->bl_count);
+}
+
+/* ===========================================================================
+ * Scan a literal or distance tree to determine the frequencies of the codes
+ * in the bit length tree.
+ */
+local void scan_tree (s, tree, max_code)
+    deflate_state *s;
+    ct_data *tree;   /* the tree to be scanned */
+    int max_code;    /* and its largest code of non zero frequency */
+{
+    int n;                     /* iterates over all tree elements */
+    int prevlen = -1;          /* last emitted length */
+    int curlen;                /* length of current code */
+    int nextlen = tree[0].Len; /* length of next code */
+    int count = 0;             /* repeat count of the current code */
+    int max_count = 7;         /* max repeat count */
+    int min_count = 4;         /* min repeat count */
+
+    if (nextlen == 0) max_count = 138, min_count = 3;
+    tree[max_code+1].Len = (ush)0xffff; /* guard */
+
+    for (n = 0; n <= max_code; n++) {
+        curlen = nextlen; nextlen = tree[n+1].Len;
+        if (++count < max_count && curlen == nextlen) {
+            continue;
+        } else if (count < min_count) {
+            s->bl_tree[curlen].Freq += count;
+        } else if (curlen != 0) {
+            if (curlen != prevlen) s->bl_tree[curlen].Freq++;
+            s->bl_tree[REP_3_6].Freq++;
+        } else if (count <= 10) {
+            s->bl_tree[REPZ_3_10].Freq++;
+        } else {
+            s->bl_tree[REPZ_11_138].Freq++;
+        }
+        count = 0; prevlen = curlen;
+        if (nextlen == 0) {
+            max_count = 138, min_count = 3;
+        } else if (curlen == nextlen) {
+            max_count = 6, min_count = 3;
+        } else {
+            max_count = 7, min_count = 4;
+        }
+    }
+}
+
+/* ===========================================================================
+ * Send a literal or distance tree in compressed form, using the codes in
+ * bl_tree.
+ */
+local void send_tree (s, tree, max_code)
+    deflate_state *s;
+    ct_data *tree; /* the tree to be scanned */
+    int max_code;       /* and its largest code of non zero frequency */
+{
+    int n;                     /* iterates over all tree elements */
+    int prevlen = -1;          /* last emitted length */
+    int curlen;                /* length of current code */
+    int nextlen = tree[0].Len; /* length of next code */
+    int count = 0;             /* repeat count of the current code */
+    int max_count = 7;         /* max repeat count */
+    int min_count = 4;         /* min repeat count */
+
+    /* tree[max_code+1].Len = -1; */  /* guard already set */
+    if (nextlen == 0) max_count = 138, min_count = 3;
+
+    for (n = 0; n <= max_code; n++) {
+        curlen = nextlen; nextlen = tree[n+1].Len;
+        if (++count < max_count && curlen == nextlen) {
+            continue;
+        } else if (count < min_count) {
+            do { send_code(s, curlen, s->bl_tree); } while (--count != 0);
+
+        } else if (curlen != 0) {
+            if (curlen != prevlen) {
+                send_code(s, curlen, s->bl_tree); count--;
+            }
+            Assert(count >= 3 && count <= 6, " 3_6?");
+            send_code(s, REP_3_6, s->bl_tree); send_bits(s, count-3, 2);
+
+        } else if (count <= 10) {
+            send_code(s, REPZ_3_10, s->bl_tree); send_bits(s, count-3, 3);
+
+        } else {
+            send_code(s, REPZ_11_138, s->bl_tree); send_bits(s, count-11, 7);
+        }
+        count = 0; prevlen = curlen;
+        if (nextlen == 0) {
+            max_count = 138, min_count = 3;
+        } else if (curlen == nextlen) {
+            max_count = 6, min_count = 3;
+        } else {
+            max_count = 7, min_count = 4;
+        }
+    }
+}
+
+/* ===========================================================================
+ * Construct the Huffman tree for the bit lengths and return the index in
+ * bl_order of the last bit length code to send.
+ */
+local int build_bl_tree(s)
+    deflate_state *s;
+{
+    int max_blindex;  /* index of last bit length code of non zero freq */
+
+    /* Determine the bit length frequencies for literal and distance trees */
+    scan_tree(s, (ct_data *)s->dyn_ltree, s->l_desc.max_code);
+    scan_tree(s, (ct_data *)s->dyn_dtree, s->d_desc.max_code);
+
+    /* Build the bit length tree: */
+    build_tree(s, (tree_desc *)(&(s->bl_desc)));
+    /* opt_len now includes the length of the tree representations, except
+     * the lengths of the bit lengths codes and the 5+5+4 bits for the counts.
+     */
+
+    /* Determine the number of bit length codes to send. The pkzip format
+     * requires that at least 4 bit length codes be sent. (appnote.txt says
+     * 3 but the actual value used is 4.)
+     */
+    for (max_blindex = BL_CODES-1; max_blindex >= 3; max_blindex--) {
+        if (s->bl_tree[bl_order[max_blindex]].Len != 0) break;
+    }
+    /* Update opt_len to include the bit length tree and counts */
+    s->opt_len += 3*(max_blindex+1) + 5+5+4;
+    Tracev((stderr, "\ndyn trees: dyn %ld, stat %ld",
+            s->opt_len, s->static_len));
+
+    return max_blindex;
+}
+
+/* ===========================================================================
+ * Send the header for a block using dynamic Huffman trees: the counts, the
+ * lengths of the bit length codes, the literal tree and the distance tree.
+ * IN assertion: lcodes >= 257, dcodes >= 1, blcodes >= 4.
+ */
+local void send_all_trees(s, lcodes, dcodes, blcodes)
+    deflate_state *s;
+    int lcodes, dcodes, blcodes; /* number of codes for each tree */
+{
+    int rank;                    /* index in bl_order */
+
+    Assert (lcodes >= 257 && dcodes >= 1 && blcodes >= 4, "not enough codes");
+    Assert (lcodes <= L_CODES && dcodes <= D_CODES && blcodes <= BL_CODES,
+            "too many codes");
+    Tracev((stderr, "\nbl counts: "));
+    send_bits(s, lcodes-257, 5); /* not +255 as stated in appnote.txt */
+    send_bits(s, dcodes-1,   5);
+    send_bits(s, blcodes-4,  4); /* not -3 as stated in appnote.txt */
+    for (rank = 0; rank < blcodes; rank++) {
+        Tracev((stderr, "\nbl code %2d ", bl_order[rank]));
+        send_bits(s, s->bl_tree[bl_order[rank]].Len, 3);
+    }
+    Tracev((stderr, "\nbl tree: sent %ld", s->bits_sent));
+
+    send_tree(s, (ct_data *)s->dyn_ltree, lcodes-1); /* literal tree */
+    Tracev((stderr, "\nlit tree: sent %ld", s->bits_sent));
+
+    send_tree(s, (ct_data *)s->dyn_dtree, dcodes-1); /* distance tree */
+    Tracev((stderr, "\ndist tree: sent %ld", s->bits_sent));
+}
+
+/* ===========================================================================
+ * Send a stored block
+ */
+void _tr_stored_block(s, buf, stored_len, eof)
+    deflate_state *s;
+    charf *buf;       /* input block */
+    ulg stored_len;   /* length of input block */
+    int eof;          /* true if this is the last block for a file */
+{
+    send_bits(s, (STORED_BLOCK<<1)+eof, 3);  /* send block type */
+#ifdef DEBUG
+    s->compressed_len = (s->compressed_len + 3 + 7) & (ulg)~7L;
+    s->compressed_len += (stored_len + 4) << 3;
+#endif
+    copy_block(s, buf, (unsigned)stored_len, 1); /* with header */
+}
+
+/* ===========================================================================
+ * Send one empty static block to give enough lookahead for inflate.
+ * This takes 10 bits, of which 7 may remain in the bit buffer.
+ * The current inflate code requires 9 bits of lookahead. If the
+ * last two codes for the previous block (real code plus EOB) were coded
+ * on 5 bits or less, inflate may have only 5+3 bits of lookahead to decode
+ * the last real code. In this case we send two empty static blocks instead
+ * of one. (There are no problems if the previous block is stored or fixed.)
+ * To simplify the code, we assume the worst case of last real code encoded
+ * on one bit only.
+ */
+void _tr_align(s)
+    deflate_state *s;
+{
+    send_bits(s, STATIC_TREES<<1, 3);
+    send_code(s, END_BLOCK, static_ltree);
+#ifdef DEBUG
+    s->compressed_len += 10L; /* 3 for block type, 7 for EOB */
+#endif
+    bi_flush(s);
+    /* Of the 10 bits for the empty block, we have already sent
+     * (10 - bi_valid) bits. The lookahead for the last real code (before
+     * the EOB of the previous block) was thus at least one plus the length
+     * of the EOB plus what we have just sent of the empty static block.
+     */
+    if (1 + s->last_eob_len + 10 - s->bi_valid < 9) {
+        send_bits(s, STATIC_TREES<<1, 3);
+        send_code(s, END_BLOCK, static_ltree);
+#ifdef DEBUG
+        s->compressed_len += 10L;
+#endif
+        bi_flush(s);
+    }
+    s->last_eob_len = 7;
+}
+
+/* ===========================================================================
+ * Determine the best encoding for the current block: dynamic trees, static
+ * trees or store, and output the encoded block to the zip file.
+ */
+void _tr_flush_block(s, buf, stored_len, eof)
+    deflate_state *s;
+    charf *buf;       /* input block, or NULL if too old */
+    ulg stored_len;   /* length of input block */
+    int eof;          /* true if this is the last block for a file */
+{
+    ulg opt_lenb, static_lenb; /* opt_len and static_len in bytes */
+    int max_blindex = 0;  /* index of last bit length code of non zero freq */
+
+    /* Build the Huffman trees unless a stored block is forced */
+    if (s->level > 0) {
+
+	 /* Check if the file is ascii or binary */
+	if (s->data_type == Z_UNKNOWN) set_data_type(s);
+
+	/* Construct the literal and distance trees */
+	build_tree(s, (tree_desc *)(&(s->l_desc)));
+	Tracev((stderr, "\nlit data: dyn %ld, stat %ld", s->opt_len,
+		s->static_len));
+
+	build_tree(s, (tree_desc *)(&(s->d_desc)));
+	Tracev((stderr, "\ndist data: dyn %ld, stat %ld", s->opt_len,
+		s->static_len));
+	/* At this point, opt_len and static_len are the total bit lengths of
+	 * the compressed block data, excluding the tree representations.
+	 */
+
+	/* Build the bit length tree for the above two trees, and get the index
+	 * in bl_order of the last bit length code to send.
+	 */
+	max_blindex = build_bl_tree(s);
+
+	/* Determine the best encoding. Compute first the block length in bytes*/
+	opt_lenb = (s->opt_len+3+7)>>3;
+	static_lenb = (s->static_len+3+7)>>3;
+
+	Tracev((stderr, "\nopt %lu(%lu) stat %lu(%lu) stored %lu lit %u ",
+		opt_lenb, s->opt_len, static_lenb, s->static_len, stored_len,
+		s->last_lit));
+
+	if (static_lenb <= opt_lenb) opt_lenb = static_lenb;
+
+    } else {
+        Assert(buf != (char*)0, "lost buf");
+	opt_lenb = static_lenb = stored_len + 5; /* force a stored block */
+    }
+
+#ifdef FORCE_STORED
+    if (buf != (char*)0) { /* force stored block */
+#else
+    if (stored_len+4 <= opt_lenb && buf != (char*)0) {
+                       /* 4: two words for the lengths */
+#endif
+        /* The test buf != NULL is only necessary if LIT_BUFSIZE > WSIZE.
+         * Otherwise we can't have processed more than WSIZE input bytes since
+         * the last block flush, because compression would have been
+         * successful. If LIT_BUFSIZE <= WSIZE, it is never too late to
+         * transform a block into a stored block.
+         */
+        _tr_stored_block(s, buf, stored_len, eof);
+
+#ifdef FORCE_STATIC
+    } else if (static_lenb >= 0) { /* force static trees */
+#else
+    } else if (static_lenb == opt_lenb) {
+#endif
+        send_bits(s, (STATIC_TREES<<1)+eof, 3);
+        compress_block(s, (ct_data *)static_ltree, (ct_data *)static_dtree);
+#ifdef DEBUG
+        s->compressed_len += 3 + s->static_len;
+#endif
+    } else {
+        send_bits(s, (DYN_TREES<<1)+eof, 3);
+        send_all_trees(s, s->l_desc.max_code+1, s->d_desc.max_code+1,
+                       max_blindex+1);
+        compress_block(s, (ct_data *)s->dyn_ltree, (ct_data *)s->dyn_dtree);
+#ifdef DEBUG
+        s->compressed_len += 3 + s->opt_len;
+#endif
+    }
+    Assert (s->compressed_len == s->bits_sent, "bad compressed size");
+    /* The above check is made mod 2^32, for files larger than 512 MB
+     * and uLong implemented on 32 bits.
+     */
+    init_block(s);
+
+    if (eof) {
+        bi_windup(s);
+#ifdef DEBUG
+        s->compressed_len += 7;  /* align on byte boundary */
+#endif
+    }
+    Tracev((stderr,"\ncomprlen %lu(%lu) ", s->compressed_len>>3,
+           s->compressed_len-7*eof));
+}
+
+/* ===========================================================================
+ * Save the match info and tally the frequency counts. Return true if
+ * the current block must be flushed.
+ */
+int _tr_tally (s, dist, lc)
+    deflate_state *s;
+    unsigned dist;  /* distance of matched string */
+    unsigned lc;    /* match length-MIN_MATCH or unmatched char (if dist==0) */
+{
+    s->d_buf[s->last_lit] = (ush)dist;
+    s->l_buf[s->last_lit++] = (uch)lc;
+    if (dist == 0) {
+        /* lc is the unmatched char */
+        s->dyn_ltree[lc].Freq++;
+    } else {
+        s->matches++;
+        /* Here, lc is the match length - MIN_MATCH */
+        dist--;             /* dist = match distance - 1 */
+        Assert((ush)dist < (ush)MAX_DIST(s) &&
+               (ush)lc <= (ush)(MAX_MATCH-MIN_MATCH) &&
+               (ush)d_code(dist) < (ush)D_CODES,  "_tr_tally: bad match");
+
+        s->dyn_ltree[_length_code[lc]+LITERALS+1].Freq++;
+        s->dyn_dtree[d_code(dist)].Freq++;
+    }
+
+#ifdef TRUNCATE_BLOCK
+    /* Try to guess if it is profitable to stop the current block here */
+    if ((s->last_lit & 0x1fff) == 0 && s->level > 2) {
+        /* Compute an upper bound for the compressed length */
+        ulg out_length = (ulg)s->last_lit*8L;
+        ulg in_length = (ulg)((long)s->strstart - s->block_start);
+        int dcode;
+        for (dcode = 0; dcode < D_CODES; dcode++) {
+            out_length += (ulg)s->dyn_dtree[dcode].Freq *
+                (5L+extra_dbits[dcode]);
+        }
+        out_length >>= 3;
+        Tracev((stderr,"\nlast_lit %u, in %ld, out ~%ld(%ld%%) ",
+               s->last_lit, in_length, out_length,
+               100L - out_length*100L/in_length));
+        if (s->matches < s->last_lit/2 && out_length < in_length/2) return 1;
+    }
+#endif
+    return (s->last_lit == s->lit_bufsize-1);
+    /* We avoid equality with lit_bufsize because of wraparound at 64K
+     * on 16 bit machines and because stored blocks are restricted to
+     * 64K-1 bytes.
+     */
+}
+
+/* ===========================================================================
+ * Send the block data compressed using the given Huffman trees
+ */
+local void compress_block(s, ltree, dtree)
+    deflate_state *s;
+    ct_data *ltree; /* literal tree */
+    ct_data *dtree; /* distance tree */
+{
+    unsigned dist;      /* distance of matched string */
+    int lc;             /* match length or unmatched char (if dist == 0) */
+    unsigned lx = 0;    /* running index in l_buf */
+    unsigned code;      /* the code to send */
+    int extra;          /* number of extra bits to send */
+
+    if (s->last_lit != 0) do {
+        dist = s->d_buf[lx];
+        lc = s->l_buf[lx++];
+        if (dist == 0) {
+            send_code(s, lc, ltree); /* send a literal byte */
+            Tracecv(isgraph(lc), (stderr," '%c' ", lc));
+        } else {
+            /* Here, lc is the match length - MIN_MATCH */
+            code = _length_code[lc];
+            send_code(s, code+LITERALS+1, ltree); /* send the length code */
+            extra = extra_lbits[code];
+            if (extra != 0) {
+                lc -= base_length[code];
+                send_bits(s, lc, extra);       /* send the extra length bits */
+            }
+            dist--; /* dist is now the match distance - 1 */
+            code = d_code(dist);
+            Assert (code < D_CODES, "bad d_code");
+
+            send_code(s, code, dtree);       /* send the distance code */
+            extra = extra_dbits[code];
+            if (extra != 0) {
+                dist -= base_dist[code];
+                send_bits(s, dist, extra);   /* send the extra distance bits */
+            }
+        } /* literal or match pair ? */
+
+        /* Check that the overlay between pending_buf and d_buf+l_buf is ok: */
+        Assert(s->pending < s->lit_bufsize + 2*lx, "pendingBuf overflow");
+
+    } while (lx < s->last_lit);
+
+    send_code(s, END_BLOCK, ltree);
+    s->last_eob_len = ltree[END_BLOCK].Len;
+}
+
+/* ===========================================================================
+ * Set the data type to ASCII or BINARY, using a crude approximation:
+ * binary if more than 20% of the bytes are <= 6 or >= 128, ascii otherwise.
+ * IN assertion: the fields freq of dyn_ltree are set and the total of all
+ * frequencies does not exceed 64K (to fit in an int on 16 bit machines).
+ */
+local void set_data_type(s)
+    deflate_state *s;
+{
+    int n = 0;
+    unsigned ascii_freq = 0;
+    unsigned bin_freq = 0;
+    while (n < 7)        bin_freq += s->dyn_ltree[n++].Freq;
+    while (n < 128)    ascii_freq += s->dyn_ltree[n++].Freq;
+    while (n < LITERALS) bin_freq += s->dyn_ltree[n++].Freq;
+    s->data_type = (Byte)(bin_freq > (ascii_freq >> 2) ? Z_BINARY : Z_ASCII);
+}
+
+/* ===========================================================================
+ * Reverse the first len bits of a code, using straightforward code (a faster
+ * method would use a table)
+ * IN assertion: 1 <= len <= 15
+ */
+local unsigned bi_reverse(code, len)
+    unsigned code; /* the value to invert */
+    int len;       /* its bit length */
+{
+    register unsigned res = 0;
+    do {
+        res |= code & 1;
+        code >>= 1, res <<= 1;
+    } while (--len > 0);
+    return res >> 1;
+}
+
+/* ===========================================================================
+ * Flush the bit buffer, keeping at most 7 bits in it.
+ */
+local void bi_flush(s)
+    deflate_state *s;
+{
+    if (s->bi_valid == 16) {
+        put_short(s, s->bi_buf);
+        s->bi_buf = 0;
+        s->bi_valid = 0;
+    } else if (s->bi_valid >= 8) {
+        put_byte(s, (Byte)s->bi_buf);
+        s->bi_buf >>= 8;
+        s->bi_valid -= 8;
+    }
+}
+
+/* ===========================================================================
+ * Flush the bit buffer and align the output on a byte boundary
+ */
+local void bi_windup(s)
+    deflate_state *s;
+{
+    if (s->bi_valid > 8) {
+        put_short(s, s->bi_buf);
+    } else if (s->bi_valid > 0) {
+        put_byte(s, (Byte)s->bi_buf);
+    }
+    s->bi_buf = 0;
+    s->bi_valid = 0;
+#ifdef DEBUG
+    s->bits_sent = (s->bits_sent+7) & ~7;
+#endif
+}
+
+/* ===========================================================================
+ * Copy a stored block, storing first the length and its
+ * one's complement if requested.
+ */
+local void copy_block(s, buf, len, header)
+    deflate_state *s;
+    charf    *buf;    /* the input data */
+    unsigned len;     /* its length */
+    int      header;  /* true if block header must be written */
+{
+    bi_windup(s);        /* align on byte boundary */
+    s->last_eob_len = 8; /* enough lookahead for inflate */
+
+    if (header) {
+        put_short(s, (ush)len);   
+        put_short(s, (ush)~len);
+#ifdef DEBUG
+        s->bits_sent += 2*16;
+#endif
+    }
+#ifdef DEBUG
+    s->bits_sent += (ulg)len<<3;
+#endif
+    while (len--) {
+        put_byte(s, *buf++);
+    }
+}
diff --git a/collects/plot/src/all/trees.h b/collects/plot/src/all/trees.h
new file mode 100644
index 0000000000..72facf900f
--- /dev/null
+++ b/collects/plot/src/all/trees.h
@@ -0,0 +1,128 @@
+/* header created automatically with -DGEN_TREES_H */
+
+local const ct_data static_ltree[L_CODES+2] = {
+{{ 12},{  8}}, {{140},{  8}}, {{ 76},{  8}}, {{204},{  8}}, {{ 44},{  8}},
+{{172},{  8}}, {{108},{  8}}, {{236},{  8}}, {{ 28},{  8}}, {{156},{  8}},
+{{ 92},{  8}}, {{220},{  8}}, {{ 60},{  8}}, {{188},{  8}}, {{124},{  8}},
+{{252},{  8}}, {{  2},{  8}}, {{130},{  8}}, {{ 66},{  8}}, {{194},{  8}},
+{{ 34},{  8}}, {{162},{  8}}, {{ 98},{  8}}, {{226},{  8}}, {{ 18},{  8}},
+{{146},{  8}}, {{ 82},{  8}}, {{210},{  8}}, {{ 50},{  8}}, {{178},{  8}},
+{{114},{  8}}, {{242},{  8}}, {{ 10},{  8}}, {{138},{  8}}, {{ 74},{  8}},
+{{202},{  8}}, {{ 42},{  8}}, {{170},{  8}}, {{106},{  8}}, {{234},{  8}},
+{{ 26},{  8}}, {{154},{  8}}, {{ 90},{  8}}, {{218},{  8}}, {{ 58},{  8}},
+{{186},{  8}}, {{122},{  8}}, {{250},{  8}}, {{  6},{  8}}, {{134},{  8}},
+{{ 70},{  8}}, {{198},{  8}}, {{ 38},{  8}}, {{166},{  8}}, {{102},{  8}},
+{{230},{  8}}, {{ 22},{  8}}, {{150},{  8}}, {{ 86},{  8}}, {{214},{  8}},
+{{ 54},{  8}}, {{182},{  8}}, {{118},{  8}}, {{246},{  8}}, {{ 14},{  8}},
+{{142},{  8}}, {{ 78},{  8}}, {{206},{  8}}, {{ 46},{  8}}, {{174},{  8}},
+{{110},{  8}}, {{238},{  8}}, {{ 30},{  8}}, {{158},{  8}}, {{ 94},{  8}},
+{{222},{  8}}, {{ 62},{  8}}, {{190},{  8}}, {{126},{  8}}, {{254},{  8}},
+{{  1},{  8}}, {{129},{  8}}, {{ 65},{  8}}, {{193},{  8}}, {{ 33},{  8}},
+{{161},{  8}}, {{ 97},{  8}}, {{225},{  8}}, {{ 17},{  8}}, {{145},{  8}},
+{{ 81},{  8}}, {{209},{  8}}, {{ 49},{  8}}, {{177},{  8}}, {{113},{  8}},
+{{241},{  8}}, {{  9},{  8}}, {{137},{  8}}, {{ 73},{  8}}, {{201},{  8}},
+{{ 41},{  8}}, {{169},{  8}}, {{105},{  8}}, {{233},{  8}}, {{ 25},{  8}},
+{{153},{  8}}, {{ 89},{  8}}, {{217},{  8}}, {{ 57},{  8}}, {{185},{  8}},
+{{121},{  8}}, {{249},{  8}}, {{  5},{  8}}, {{133},{  8}}, {{ 69},{  8}},
+{{197},{  8}}, {{ 37},{  8}}, {{165},{  8}}, {{101},{  8}}, {{229},{  8}},
+{{ 21},{  8}}, {{149},{  8}}, {{ 85},{  8}}, {{213},{  8}}, {{ 53},{  8}},
+{{181},{  8}}, {{117},{  8}}, {{245},{  8}}, {{ 13},{  8}}, {{141},{  8}},
+{{ 77},{  8}}, {{205},{  8}}, {{ 45},{  8}}, {{173},{  8}}, {{109},{  8}},
+{{237},{  8}}, {{ 29},{  8}}, {{157},{  8}}, {{ 93},{  8}}, {{221},{  8}},
+{{ 61},{  8}}, {{189},{  8}}, {{125},{  8}}, {{253},{  8}}, {{ 19},{  9}},
+{{275},{  9}}, {{147},{  9}}, {{403},{  9}}, {{ 83},{  9}}, {{339},{  9}},
+{{211},{  9}}, {{467},{  9}}, {{ 51},{  9}}, {{307},{  9}}, {{179},{  9}},
+{{435},{  9}}, {{115},{  9}}, {{371},{  9}}, {{243},{  9}}, {{499},{  9}},
+{{ 11},{  9}}, {{267},{  9}}, {{139},{  9}}, {{395},{  9}}, {{ 75},{  9}},
+{{331},{  9}}, {{203},{  9}}, {{459},{  9}}, {{ 43},{  9}}, {{299},{  9}},
+{{171},{  9}}, {{427},{  9}}, {{107},{  9}}, {{363},{  9}}, {{235},{  9}},
+{{491},{  9}}, {{ 27},{  9}}, {{283},{  9}}, {{155},{  9}}, {{411},{  9}},
+{{ 91},{  9}}, {{347},{  9}}, {{219},{  9}}, {{475},{  9}}, {{ 59},{  9}},
+{{315},{  9}}, {{187},{  9}}, {{443},{  9}}, {{123},{  9}}, {{379},{  9}},
+{{251},{  9}}, {{507},{  9}}, {{  7},{  9}}, {{263},{  9}}, {{135},{  9}},
+{{391},{  9}}, {{ 71},{  9}}, {{327},{  9}}, {{199},{  9}}, {{455},{  9}},
+{{ 39},{  9}}, {{295},{  9}}, {{167},{  9}}, {{423},{  9}}, {{103},{  9}},
+{{359},{  9}}, {{231},{  9}}, {{487},{  9}}, {{ 23},{  9}}, {{279},{  9}},
+{{151},{  9}}, {{407},{  9}}, {{ 87},{  9}}, {{343},{  9}}, {{215},{  9}},
+{{471},{  9}}, {{ 55},{  9}}, {{311},{  9}}, {{183},{  9}}, {{439},{  9}},
+{{119},{  9}}, {{375},{  9}}, {{247},{  9}}, {{503},{  9}}, {{ 15},{  9}},
+{{271},{  9}}, {{143},{  9}}, {{399},{  9}}, {{ 79},{  9}}, {{335},{  9}},
+{{207},{  9}}, {{463},{  9}}, {{ 47},{  9}}, {{303},{  9}}, {{175},{  9}},
+{{431},{  9}}, {{111},{  9}}, {{367},{  9}}, {{239},{  9}}, {{495},{  9}},
+{{ 31},{  9}}, {{287},{  9}}, {{159},{  9}}, {{415},{  9}}, {{ 95},{  9}},
+{{351},{  9}}, {{223},{  9}}, {{479},{  9}}, {{ 63},{  9}}, {{319},{  9}},
+{{191},{  9}}, {{447},{  9}}, {{127},{  9}}, {{383},{  9}}, {{255},{  9}},
+{{511},{  9}}, {{  0},{  7}}, {{ 64},{  7}}, {{ 32},{  7}}, {{ 96},{  7}},
+{{ 16},{  7}}, {{ 80},{  7}}, {{ 48},{  7}}, {{112},{  7}}, {{  8},{  7}},
+{{ 72},{  7}}, {{ 40},{  7}}, {{104},{  7}}, {{ 24},{  7}}, {{ 88},{  7}},
+{{ 56},{  7}}, {{120},{  7}}, {{  4},{  7}}, {{ 68},{  7}}, {{ 36},{  7}},
+{{100},{  7}}, {{ 20},{  7}}, {{ 84},{  7}}, {{ 52},{  7}}, {{116},{  7}},
+{{  3},{  8}}, {{131},{  8}}, {{ 67},{  8}}, {{195},{  8}}, {{ 35},{  8}},
+{{163},{  8}}, {{ 99},{  8}}, {{227},{  8}}
+};
+
+local const ct_data static_dtree[D_CODES] = {
+{{ 0},{ 5}}, {{16},{ 5}}, {{ 8},{ 5}}, {{24},{ 5}}, {{ 4},{ 5}},
+{{20},{ 5}}, {{12},{ 5}}, {{28},{ 5}}, {{ 2},{ 5}}, {{18},{ 5}},
+{{10},{ 5}}, {{26},{ 5}}, {{ 6},{ 5}}, {{22},{ 5}}, {{14},{ 5}},
+{{30},{ 5}}, {{ 1},{ 5}}, {{17},{ 5}}, {{ 9},{ 5}}, {{25},{ 5}},
+{{ 5},{ 5}}, {{21},{ 5}}, {{13},{ 5}}, {{29},{ 5}}, {{ 3},{ 5}},
+{{19},{ 5}}, {{11},{ 5}}, {{27},{ 5}}, {{ 7},{ 5}}, {{23},{ 5}}
+};
+
+const uch _dist_code[DIST_CODE_LEN] = {
+ 0,  1,  2,  3,  4,  4,  5,  5,  6,  6,  6,  6,  7,  7,  7,  7,  8,  8,  8,  8,
+ 8,  8,  8,  8,  9,  9,  9,  9,  9,  9,  9,  9, 10, 10, 10, 10, 10, 10, 10, 10,
+10, 10, 10, 10, 10, 10, 10, 10, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11,
+11, 11, 11, 11, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12,
+12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 13, 13, 13, 13,
+13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13,
+13, 13, 13, 13, 13, 13, 13, 13, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 15, 15, 15, 15, 15, 15, 15, 15,
+15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
+15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
+15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,  0,  0, 16, 17,
+18, 18, 19, 19, 20, 20, 20, 20, 21, 21, 21, 21, 22, 22, 22, 22, 22, 22, 22, 22,
+23, 23, 23, 23, 23, 23, 23, 23, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24,
+24, 24, 24, 24, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25,
+26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26,
+26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 27, 27, 27, 27, 27, 27, 27, 27,
+27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27,
+27, 27, 27, 27, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28,
+28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28,
+28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28,
+28, 28, 28, 28, 28, 28, 28, 28, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29,
+29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29,
+29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29,
+29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29
+};
+
+const uch _length_code[MAX_MATCH-MIN_MATCH+1]= {
+ 0,  1,  2,  3,  4,  5,  6,  7,  8,  8,  9,  9, 10, 10, 11, 11, 12, 12, 12, 12,
+13, 13, 13, 13, 14, 14, 14, 14, 15, 15, 15, 15, 16, 16, 16, 16, 16, 16, 16, 16,
+17, 17, 17, 17, 17, 17, 17, 17, 18, 18, 18, 18, 18, 18, 18, 18, 19, 19, 19, 19,
+19, 19, 19, 19, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20,
+21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 22, 22, 22, 22,
+22, 22, 22, 22, 22, 22, 22, 22, 22, 22, 22, 22, 23, 23, 23, 23, 23, 23, 23, 23,
+23, 23, 23, 23, 23, 23, 23, 23, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24,
+24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24,
+25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25,
+25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 26, 26, 26, 26, 26, 26, 26, 26,
+26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26,
+26, 26, 26, 26, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27,
+27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 28
+};
+
+local const int base_length[LENGTH_CODES] = {
+0, 1, 2, 3, 4, 5, 6, 7, 8, 10, 12, 14, 16, 20, 24, 28, 32, 40, 48, 56,
+64, 80, 96, 112, 128, 160, 192, 224, 0
+};
+
+local const int base_dist[D_CODES] = {
+    0,     1,     2,     3,     4,     6,     8,    12,    16,    24,
+   32,    48,    64,    96,   128,   192,   256,   384,   512,   768,
+ 1024,  1536,  2048,  3072,  4096,  6144,  8192, 12288, 16384, 24576
+};
+
diff --git a/collects/plot/src/all/uncompr.c b/collects/plot/src/all/uncompr.c
new file mode 100644
index 0000000000..47c37ca002
--- /dev/null
+++ b/collects/plot/src/all/uncompr.c
@@ -0,0 +1,58 @@
+/* uncompr.c -- decompress a memory buffer
+ * Copyright (C) 1995-2002 Jean-loup Gailly.
+ * For conditions of distribution and use, see copyright notice in zlib.h 
+ */
+
+/* @(#) $Id: uncompr.c,v 1.1 2004/03/01 20:54:55 cozmic Exp $ */
+
+#include "zlib.h"
+
+/* ===========================================================================
+     Decompresses the source buffer into the destination buffer.  sourceLen is
+   the byte length of the source buffer. Upon entry, destLen is the total
+   size of the destination buffer, which must be large enough to hold the
+   entire uncompressed data. (The size of the uncompressed data must have
+   been saved previously by the compressor and transmitted to the decompressor
+   by some mechanism outside the scope of this compression library.)
+   Upon exit, destLen is the actual size of the compressed buffer.
+     This function can be used to decompress a whole file at once if the
+   input file is mmap'ed.
+
+     uncompress returns Z_OK if success, Z_MEM_ERROR if there was not
+   enough memory, Z_BUF_ERROR if there was not enough room in the output
+   buffer, or Z_DATA_ERROR if the input data was corrupted.
+*/
+int ZEXPORT uncompress (dest, destLen, source, sourceLen)
+    Bytef *dest;
+    uLongf *destLen;
+    const Bytef *source;
+    uLong sourceLen;
+{
+    z_stream stream;
+    int err;
+
+    stream.next_in = (Bytef*)source;
+    stream.avail_in = (uInt)sourceLen;
+    /* Check for source > 64K on 16-bit machine: */
+    if ((uLong)stream.avail_in != sourceLen) return Z_BUF_ERROR;
+
+    stream.next_out = dest;
+    stream.avail_out = (uInt)*destLen;
+    if ((uLong)stream.avail_out != *destLen) return Z_BUF_ERROR;
+
+    stream.zalloc = (alloc_func)0;
+    stream.zfree = (free_func)0;
+
+    err = inflateInit(&stream);
+    if (err != Z_OK) return err;
+
+    err = inflate(&stream, Z_FINISH);
+    if (err != Z_STREAM_END) {
+        inflateEnd(&stream);
+        return err == Z_OK ? Z_BUF_ERROR : err;
+    }
+    *destLen = stream.total_out;
+
+    err = inflateEnd(&stream);
+    return err;
+}
diff --git a/collects/plot/src/all/version.h b/collects/plot/src/all/version.h
new file mode 100644
index 0000000000..efaba71e49
--- /dev/null
+++ b/collects/plot/src/all/version.h
@@ -0,0 +1,19 @@
+/******************************************************************************
+ *
+ * File:           version.h
+ *
+ * Created:        16/10/2002
+ *
+ * Author:         Pavel Sakov
+ *                 CSIRO Marine Research
+ *
+ * Purpose:        Version string for csa library
+ *
+ *****************************************************************************/
+
+#if !defined(_VERSION_H)
+#define _VERSION_H
+
+char* csa_version = "0.05";
+
+#endif
diff --git a/collects/plot/src/all/wbmp.c b/collects/plot/src/all/wbmp.c
new file mode 100644
index 0000000000..850f095845
--- /dev/null
+++ b/collects/plot/src/all/wbmp.c
@@ -0,0 +1,376 @@
+
+/* WBMP
+   ** ----
+   ** WBMP Level 0: B/W, Uncompressed
+   ** This implements the WBMP format as specified in WAPSpec 1.1 and 1.2.
+   ** It does not support ExtHeaders as defined in the spec. The spec states
+   ** that a WAP client does not need to implement ExtHeaders.
+   **
+   ** (c) 2000 Johan Van den Brande <johan@vandenbrande.com>
+ */
+
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+
+#include <stdio.h>
+#include <stddef.h>
+#include <stdlib.h>
+#include <string.h>
+
+#include "wbmp.h"
+#include "gd.h"
+#include "gdhelpers.h"
+
+#ifdef NOTDEF
+#define __TEST			/* Compile with main function */
+#define __DEBUG			/* Extra verbose when with __TEST */
+#define __WRITE			/* readwbmp and writewbmp(stdout) */
+#define __VIEW			/* view the wbmp on stdout */
+#endif
+
+/* getmbi
+   ** ------
+   ** Get a multibyte integer from a generic getin function 
+   ** 'getin' can be getc, with in = NULL
+   ** you can find getin as a function just above the main function
+   ** This way you gain a lot of flexibilty about how this package
+   ** reads a wbmp file.
+ */
+int
+getmbi (int (*getin) (void *in), void *in)
+{
+  int i, mbi = 0;
+
+  do
+    {
+      i = getin (in);
+      if (i < 0)
+	return (-1);
+      mbi = (mbi << 7) | (i & 0x7f);
+    }
+  while (i & 0x80);
+
+  return (mbi);
+}
+
+
+/* putmbi
+   ** ------
+   ** Put a multibyte intgerer in some kind of output stream
+   ** I work here with a function pointer, to make it as generic
+   ** as possible. Look at this function as an iterator on the
+   ** mbi integers it spits out.
+   **
+ */
+void
+putmbi (int i, void (*putout) (int c, void *out), void *out)
+{
+  int cnt, l, accu;
+
+  /* Get number of septets */
+  cnt = 0;
+  accu = 0;
+  while (accu != i)
+    accu += i & 0x7f << 7 * cnt++;
+
+  /* Produce the multibyte output */
+  for (l = cnt - 1; l > 0; l--)
+    putout (0x80 | (i & 0x7f << 7 * l) >> 7 * l, out);
+
+  putout (i & 0x7f, out);
+
+}
+
+
+
+/* skipheader
+   ** ----------
+   ** Skips the ExtHeader. Not needed for the moment
+   **
+ */
+int
+skipheader (int (*getin) (void *in), void *in)
+{
+  int i;
+
+  do
+    {
+      i = getin (in);
+      if (i < 0)
+	return (-1);
+    }
+  while (i & 0x80);
+
+  return (0);
+}
+
+/* create wbmp
+   ** -----------
+   ** create an empty wbmp
+   **
+ */
+Wbmp *
+createwbmp (int width, int height, int color)
+{
+  int i;
+
+  Wbmp *wbmp;
+  if ((wbmp = (Wbmp *) gdMalloc (sizeof (Wbmp))) == NULL)
+    return (NULL);
+
+  if ((wbmp->bitmap =
+       (int *) gdMalloc (sizeof (int) * width * height)) == NULL)
+    {
+      gdFree (wbmp);
+      return (NULL);
+    }
+
+  wbmp->width = width;
+  wbmp->height = height;
+
+  for (i = 0; i < width * height; wbmp->bitmap[i++] = color);
+
+  return (wbmp);
+}
+
+
+
+/* readwbmp
+   ** -------
+   ** Actually reads the WBMP format from an open file descriptor
+   ** It goes along by returning a pointer to a WBMP struct.
+   **
+ */
+int
+readwbmp (int (*getin) (void *in), void *in, Wbmp ** return_wbmp)
+{
+  int row, col, byte, pel, pos;
+  Wbmp *wbmp;
+
+  if ((wbmp = (Wbmp *) gdMalloc (sizeof (Wbmp))) == NULL)
+    return (-1);
+
+  wbmp->type = getin (in);
+  if (wbmp->type != 0)
+    {
+      gdFree (wbmp);
+      return (-1);
+    }
+
+  if (skipheader (getin, in))
+    return (-1);
+
+
+  wbmp->width = getmbi (getin, in);
+  if (wbmp->width == -1)
+    {
+      gdFree (wbmp);
+      return (-1);
+    }
+
+  wbmp->height = getmbi (getin, in);
+  if (wbmp->height == -1)
+    {
+      gdFree (wbmp);
+      return (-1);
+    }
+
+#ifdef __DEBUG
+  printf ("W: %d, H: %d\n", wbmp->width, wbmp->height);
+#endif
+
+  if ((wbmp->bitmap =
+       (int *) gdMalloc (sizeof (int) * wbmp->width * wbmp->height)) == NULL)
+    {
+      gdFree (wbmp);
+      return (-1);
+    }
+
+#ifdef __DEBUG
+  printf ("DATA CONSTRUCTED\n");
+#endif
+
+  pos = 0;
+  for (row = 0; row < wbmp->height; row++)
+    {
+      for (col = 0; col < wbmp->width;)
+	{
+	  byte = getin (in);
+
+	  for (pel = 7; pel >= 0; pel--)
+	    {
+	      if (col++ < wbmp->width)
+		{
+		  if (byte & 1 << pel)
+		    {
+		      wbmp->bitmap[pos] = WBMP_WHITE;
+		    }
+		  else
+		    {
+		      wbmp->bitmap[pos] = WBMP_BLACK;
+		    }
+		  pos++;
+		}
+	    }
+	}
+    }
+
+  *return_wbmp = wbmp;
+
+  return (0);
+}
+
+
+/* writewbmp
+   ** ---------
+   ** Write a wbmp to a file descriptor
+   **
+   ** Why not just giving a filedescriptor to this function?
+   ** Well, the incentive to write this function was the complete
+   ** integration in gd library from www.boutell.com. They use
+   ** their own io functions, so the passing of a function seemed to be 
+   ** a logic(?) decision ...
+   **
+ */
+int
+writewbmp (Wbmp * wbmp, void (*putout) (int c, void *out), void *out)
+{
+  int row, col;
+  int bitpos, octet;
+
+  /* Generate the header */
+  putout (0, out);		/* WBMP Type 0: B/W, Uncompressed bitmap */
+  putout (0, out);		/* FixHeaderField */
+
+
+
+  /* Size of the image */
+  putmbi (wbmp->width, putout, out);	/* width */
+  putmbi (wbmp->height, putout, out);	/* height */
+
+
+  /* Image data */
+  for (row = 0; row < wbmp->height; row++)
+    {
+      bitpos = 8;
+      octet = 0;
+      for (col = 0; col < wbmp->width; col++)
+	{
+	  octet |=
+	    ((wbmp->bitmap[row * wbmp->width + col] ==
+	      1) ? WBMP_WHITE : WBMP_BLACK) << --bitpos;
+	  if (bitpos == 0)
+	    {
+	      bitpos = 8;
+	      putout (octet, out);
+	      octet = 0;
+	    }
+	}
+      if (bitpos != 8)
+	putout (octet, out);
+
+    }
+  return (0);
+
+}
+
+
+/* freewbmp
+   ** --------
+   ** gdFrees up memory occupied by a WBMP structure
+   **
+ */
+void
+freewbmp (Wbmp * wbmp)
+{
+  gdFree (wbmp->bitmap);
+  gdFree (wbmp);
+}
+
+
+/* printwbmp
+   ** ---------
+   ** print a WBMP to stdout for visualisation
+   **
+ */
+void
+printwbmp (Wbmp * wbmp)
+{
+  int row, col;
+  for (row = 0; row < wbmp->height; row++)
+    {
+      for (col = 0; col < wbmp->width; col++)
+	{
+	  if (wbmp->bitmap[wbmp->width * row + col] == WBMP_BLACK)
+	    {
+	      putchar ('#');
+	    }
+	  else
+	    {
+	      putchar (' ');
+	    }
+	}
+      putchar ('\n');
+    }
+}
+
+#ifdef __TEST
+
+/* putout to file descriptor
+   ** -------------------------
+ */
+int
+putout (int c, void *out)
+{
+  return (putc (c, (FILE *) out));
+}
+
+/* getin from file descriptor 
+   ** --------------------------
+ */
+int
+getin (void *in)
+{
+  return (getc ((FILE *) in));
+}
+
+
+/* Main function
+   ** -------------
+   **
+ */
+int
+main (int argc, char *argv[])
+{
+  FILE *wbmp_file;
+  Wbmp *wbmp;
+
+  wbmp_file = fopen (argv[1], "rb");
+  if (wbmp_file)
+    {
+      readwbmp (&getin, wbmp_file, &wbmp);
+
+#ifdef __VIEW
+
+#ifdef __DEBUG
+      printf ("\nVIEWING IMAGE\n");
+#endif
+
+      printwbmp (wbmp);
+#endif
+
+#ifdef __WRITE
+
+#ifdef __DEBUG
+      printf ("\nDUMPING WBMP to STDOUT\n");
+#endif
+
+      writewbmp (wbmp, &putout, stdout);
+#endif
+
+      freewbmp (wbmp);
+      fclose (wbmp_file);
+    }
+}
+#endif
diff --git a/collects/plot/src/all/wbmp.h b/collects/plot/src/all/wbmp.h
new file mode 100644
index 0000000000..3cb3de6366
--- /dev/null
+++ b/collects/plot/src/all/wbmp.h
@@ -0,0 +1,48 @@
+/* WBMP
+** ----
+** WBMP Level 0: B/W, Uncompressed
+** This implements the WBMP format as specified in WAPSpec 1.1 and 1.2.
+** It does not support ExtHeaders as defined in the spec. The spec states
+** that a WAP client does not need to implement ExtHeaders.
+**
+** (c) 2000 Johan Van den Brande <johan@vandenbrande.com>
+**
+** Header file
+*/
+#ifndef __WBMP_H
+#define __WBMP_H	1
+
+
+/* WBMP struct
+** -----------
+** A Wireless bitmap structure
+**
+*/
+
+typedef struct Wbmp_
+{
+  int type;			/* type of the wbmp */
+  int width;			/* width of the image */
+  int height;			/* height of the image */
+  int *bitmap;			/* pointer to data: 0 = WHITE , 1 = BLACK */
+}
+Wbmp;
+
+#define WBMP_WHITE  1
+#define WBMP_BLACK  0
+
+
+/* Proto's
+** -------
+**
+*/
+void putmbi (int i, void (*putout) (int c, void *out), void *out);
+int getmbi (int (*getin) (void *in), void *in);
+int skipheader (int (*getin) (void *in), void *in);
+Wbmp *createwbmp (int width, int height, int color);
+int readwbmp (int (*getin) (void *in), void *in, Wbmp ** wbmp);
+int writewbmp (Wbmp * wbmp, void (*putout) (int c, void *out), void *out);
+void freewbmp (Wbmp * wbmp);
+void printwbmp (Wbmp * wbmp);
+
+#endif
diff --git a/collects/plot/src/all/zconf.h b/collects/plot/src/all/zconf.h
new file mode 100644
index 0000000000..91f72c1c17
--- /dev/null
+++ b/collects/plot/src/all/zconf.h
@@ -0,0 +1,279 @@
+/* zconf.h -- configuration of the zlib compression library
+ * Copyright (C) 1995-2002 Jean-loup Gailly.
+ * For conditions of distribution and use, see copyright notice in zlib.h 
+ */
+
+/* @(#) $Id: zconf.h,v 1.1 2004/03/01 20:54:56 cozmic Exp $ */
+
+#ifndef _ZCONF_H
+#define _ZCONF_H
+
+/*
+ * If you *really* need a unique prefix for all types and library functions,
+ * compile with -DZ_PREFIX. The "standard" zlib should be compiled without it.
+ */
+#ifdef Z_PREFIX
+#  define deflateInit_	z_deflateInit_
+#  define deflate	z_deflate
+#  define deflateEnd	z_deflateEnd
+#  define inflateInit_ 	z_inflateInit_
+#  define inflate	z_inflate
+#  define inflateEnd	z_inflateEnd
+#  define deflateInit2_	z_deflateInit2_
+#  define deflateSetDictionary z_deflateSetDictionary
+#  define deflateCopy	z_deflateCopy
+#  define deflateReset	z_deflateReset
+#  define deflateParams	z_deflateParams
+#  define inflateInit2_	z_inflateInit2_
+#  define inflateSetDictionary z_inflateSetDictionary
+#  define inflateSync	z_inflateSync
+#  define inflateSyncPoint z_inflateSyncPoint
+#  define inflateReset	z_inflateReset
+#  define compress	z_compress
+#  define compress2	z_compress2
+#  define uncompress	z_uncompress
+#  define adler32	z_adler32
+#  define crc32		z_crc32
+#  define get_crc_table z_get_crc_table
+
+#  define Byte		z_Byte
+#  define uInt		z_uInt
+#  define uLong		z_uLong
+#  define Bytef	        z_Bytef
+#  define charf		z_charf
+#  define intf		z_intf
+#  define uIntf		z_uIntf
+#  define uLongf	z_uLongf
+#  define voidpf	z_voidpf
+#  define voidp		z_voidp
+#endif
+
+#if (defined(_WIN32) || defined(__WIN32__)) && !defined(WIN32)
+#  define WIN32
+#endif
+#if defined(__GNUC__) || defined(WIN32) || defined(__386__) || defined(i386)
+#  ifndef __32BIT__
+#    define __32BIT__
+#  endif
+#endif
+#if defined(__MSDOS__) && !defined(MSDOS)
+#  define MSDOS
+#endif
+
+/*
+ * Compile with -DMAXSEG_64K if the alloc function cannot allocate more
+ * than 64k bytes at a time (needed on systems with 16-bit int).
+ */
+#if defined(MSDOS) && !defined(__32BIT__)
+#  define MAXSEG_64K
+#endif
+#ifdef MSDOS
+#  define UNALIGNED_OK
+#endif
+
+#if (defined(MSDOS) || defined(_WINDOWS) || defined(WIN32))  && !defined(STDC)
+#  define STDC
+#endif
+#if defined(__STDC__) || defined(__cplusplus) || defined(__OS2__)
+#  ifndef STDC
+#    define STDC
+#  endif
+#endif
+
+#ifndef STDC
+#  ifndef const /* cannot use !defined(STDC) && !defined(const) on Mac */
+#    define const
+#  endif
+#endif
+
+/* Some Mac compilers merge all .h files incorrectly: */
+#if defined(__MWERKS__) || defined(applec) ||defined(THINK_C) ||defined(__SC__)
+#  define NO_DUMMY_DECL
+#endif
+
+/* Old Borland C incorrectly complains about missing returns: */
+#if defined(__BORLANDC__) && (__BORLANDC__ < 0x500)
+#  define NEED_DUMMY_RETURN
+#endif
+
+
+/* Maximum value for memLevel in deflateInit2 */
+#ifndef MAX_MEM_LEVEL
+#  ifdef MAXSEG_64K
+#    define MAX_MEM_LEVEL 8
+#  else
+#    define MAX_MEM_LEVEL 9
+#  endif
+#endif
+
+/* Maximum value for windowBits in deflateInit2 and inflateInit2.
+ * WARNING: reducing MAX_WBITS makes minigzip unable to extract .gz files
+ * created by gzip. (Files created by minigzip can still be extracted by
+ * gzip.)
+ */
+#ifndef MAX_WBITS
+#  define MAX_WBITS   15 /* 32K LZ77 window */
+#endif
+
+/* The memory requirements for deflate are (in bytes):
+            (1 << (windowBits+2)) +  (1 << (memLevel+9))
+ that is: 128K for windowBits=15  +  128K for memLevel = 8  (default values)
+ plus a few kilobytes for small objects. For example, if you want to reduce
+ the default memory requirements from 256K to 128K, compile with
+     make CFLAGS="-O -DMAX_WBITS=14 -DMAX_MEM_LEVEL=7"
+ Of course this will generally degrade compression (there's no free lunch).
+
+   The memory requirements for inflate are (in bytes) 1 << windowBits
+ that is, 32K for windowBits=15 (default value) plus a few kilobytes
+ for small objects.
+*/
+
+                        /* Type declarations */
+
+#ifndef OF /* function prototypes */
+#  ifdef STDC
+#    define OF(args)  args
+#  else
+#    define OF(args)  ()
+#  endif
+#endif
+
+/* The following definitions for FAR are needed only for MSDOS mixed
+ * model programming (small or medium model with some far allocations).
+ * This was tested only with MSC; for other MSDOS compilers you may have
+ * to define NO_MEMCPY in zutil.h.  If you don't need the mixed model,
+ * just define FAR to be empty.
+ */
+#if (defined(M_I86SM) || defined(M_I86MM)) && !defined(__32BIT__)
+   /* MSC small or medium model */
+#  define SMALL_MEDIUM
+#  ifdef _MSC_VER
+#    define FAR _far
+#  else
+#    define FAR far
+#  endif
+#endif
+#if defined(__BORLANDC__) && (defined(__SMALL__) || defined(__MEDIUM__))
+#  ifndef __32BIT__
+#    define SMALL_MEDIUM
+#    define FAR _far
+#  endif
+#endif
+
+/* Compile with -DZLIB_DLL for Windows DLL support */
+#if defined(ZLIB_DLL)
+#  if defined(_WINDOWS) || defined(WINDOWS)
+#    ifdef FAR
+#      undef FAR
+#    endif
+#    include <windows.h>
+#    define ZEXPORT  WINAPI
+#    ifdef WIN32
+#      define ZEXPORTVA  WINAPIV
+#    else
+#      define ZEXPORTVA  FAR _cdecl _export
+#    endif
+#  endif
+#  if defined (__BORLANDC__)
+#    if (__BORLANDC__ >= 0x0500) && defined (WIN32)
+#      include <windows.h>
+#      define ZEXPORT __declspec(dllexport) WINAPI
+#      define ZEXPORTRVA __declspec(dllexport) WINAPIV
+#    else
+#      if defined (_Windows) && defined (__DLL__)
+#        define ZEXPORT _export
+#        define ZEXPORTVA _export
+#      endif
+#    endif
+#  endif
+#endif
+
+#if defined (__BEOS__)
+#  if defined (ZLIB_DLL)
+#    define ZEXTERN extern __declspec(dllexport)
+#  else
+#    define ZEXTERN extern __declspec(dllimport)
+#  endif
+#endif
+
+#ifndef ZEXPORT
+#  define ZEXPORT
+#endif
+#ifndef ZEXPORTVA
+#  define ZEXPORTVA
+#endif
+#ifndef ZEXTERN
+#  define ZEXTERN extern
+#endif
+
+#ifndef FAR
+#   define FAR
+#endif
+
+#if !defined(MACOS) && !defined(TARGET_OS_MAC)
+typedef unsigned char  Byte;  /* 8 bits */
+#endif
+typedef unsigned int   uInt;  /* 16 bits or more */
+typedef unsigned long  uLong; /* 32 bits or more */
+
+#ifdef SMALL_MEDIUM
+   /* Borland C/C++ and some old MSC versions ignore FAR inside typedef */
+#  define Bytef Byte FAR
+#else
+   typedef Byte  FAR Bytef;
+#endif
+typedef char  FAR charf;
+typedef int   FAR intf;
+typedef uInt  FAR uIntf;
+typedef uLong FAR uLongf;
+
+#ifdef STDC
+   typedef void FAR *voidpf;
+   typedef void     *voidp;
+#else
+   typedef Byte FAR *voidpf;
+   typedef Byte     *voidp;
+#endif
+
+#ifdef HAVE_UNISTD_H
+#  include <sys/types.h> /* for off_t */
+#  include <unistd.h>    /* for SEEK_* and off_t */
+#  define z_off_t  off_t
+#endif
+#ifndef SEEK_SET
+#  define SEEK_SET        0       /* Seek from beginning of file.  */
+#  define SEEK_CUR        1       /* Seek from current position.  */
+#  define SEEK_END        2       /* Set file pointer to EOF plus "offset" */
+#endif
+#ifndef z_off_t
+#  define  z_off_t long
+#endif
+
+/* MVS linker does not support external names larger than 8 bytes */
+#if defined(__MVS__)
+#   pragma map(deflateInit_,"DEIN")
+#   pragma map(deflateInit2_,"DEIN2")
+#   pragma map(deflateEnd,"DEEND")
+#   pragma map(inflateInit_,"ININ")
+#   pragma map(inflateInit2_,"ININ2")
+#   pragma map(inflateEnd,"INEND")
+#   pragma map(inflateSync,"INSY")
+#   pragma map(inflateSetDictionary,"INSEDI")
+#   pragma map(inflate_blocks,"INBL")
+#   pragma map(inflate_blocks_new,"INBLNE")
+#   pragma map(inflate_blocks_free,"INBLFR")
+#   pragma map(inflate_blocks_reset,"INBLRE")
+#   pragma map(inflate_codes_free,"INCOFR")
+#   pragma map(inflate_codes,"INCO")
+#   pragma map(inflate_fast,"INFA")
+#   pragma map(inflate_flush,"INFLU")
+#   pragma map(inflate_mask,"INMA")
+#   pragma map(inflate_set_dictionary,"INSEDI2")
+#   pragma map(inflate_copyright,"INCOPY")
+#   pragma map(inflate_trees_bits,"INTRBI")
+#   pragma map(inflate_trees_dynamic,"INTRDY")
+#   pragma map(inflate_trees_fixed,"INTRFI")
+#   pragma map(inflate_trees_free,"INTRFR")
+#endif
+
+#endif /* _ZCONF_H */
diff --git a/collects/plot/src/all/zlib.h b/collects/plot/src/all/zlib.h
new file mode 100644
index 0000000000..52cb529f6f
--- /dev/null
+++ b/collects/plot/src/all/zlib.h
@@ -0,0 +1,893 @@
+/* zlib.h -- interface of the 'zlib' general purpose compression library
+  version 1.1.4, March 11th, 2002
+
+  Copyright (C) 1995-2002 Jean-loup Gailly and Mark Adler
+
+  This software is provided 'as-is', without any express or implied
+  warranty.  In no event will the authors be held liable for any damages
+  arising from the use of this software.
+
+  Permission is granted to anyone to use this software for any purpose,
+  including commercial applications, and to alter it and redistribute it
+  freely, subject to the following restrictions:
+
+  1. The origin of this software must not be misrepresented; you must not
+     claim that you wrote the original software. If you use this software
+     in a product, an acknowledgment in the product documentation would be
+     appreciated but is not required.
+  2. Altered source versions must be plainly marked as such, and must not be
+     misrepresented as being the original software.
+  3. This notice may not be removed or altered from any source distribution.
+
+  Jean-loup Gailly        Mark Adler
+  jloup@gzip.org          madler@alumni.caltech.edu
+
+
+  The data format used by the zlib library is described by RFCs (Request for
+  Comments) 1950 to 1952 in the files ftp://ds.internic.net/rfc/rfc1950.txt
+  (zlib format), rfc1951.txt (deflate format) and rfc1952.txt (gzip format).
+*/
+
+#ifndef _ZLIB_H
+#define _ZLIB_H
+
+#include "zconf.h"
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#define ZLIB_VERSION "1.1.4"
+
+/* 
+     The 'zlib' compression library provides in-memory compression and
+  decompression functions, including integrity checks of the uncompressed
+  data.  This version of the library supports only one compression method
+  (deflation) but other algorithms will be added later and will have the same
+  stream interface.
+
+     Compression can be done in a single step if the buffers are large
+  enough (for example if an input file is mmap'ed), or can be done by
+  repeated calls of the compression function.  In the latter case, the
+  application must provide more input and/or consume the output
+  (providing more output space) before each call.
+
+     The library also supports reading and writing files in gzip (.gz) format
+  with an interface similar to that of stdio.
+
+     The library does not install any signal handler. The decoder checks
+  the consistency of the compressed data, so the library should never
+  crash even in case of corrupted input.
+*/
+
+typedef voidpf (*alloc_func) OF((voidpf opaque, uInt items, uInt size));
+typedef void   (*free_func)  OF((voidpf opaque, voidpf address));
+
+struct internal_state;
+
+typedef struct z_stream_s {
+    Bytef    *next_in;  /* next input byte */
+    uInt     avail_in;  /* number of bytes available at next_in */
+    uLong    total_in;  /* total nb of input bytes read so far */
+
+    Bytef    *next_out; /* next output byte should be put there */
+    uInt     avail_out; /* remaining free space at next_out */
+    uLong    total_out; /* total nb of bytes output so far */
+
+    char     *msg;      /* last error message, NULL if no error */
+    struct internal_state FAR *state; /* not visible by applications */
+
+    alloc_func zalloc;  /* used to allocate the internal state */
+    free_func  zfree;   /* used to free the internal state */
+    voidpf     opaque;  /* private data object passed to zalloc and zfree */
+
+    int     data_type;  /* best guess about the data type: ascii or binary */
+    uLong   adler;      /* adler32 value of the uncompressed data */
+    uLong   reserved;   /* reserved for future use */
+} z_stream;
+
+typedef z_stream FAR *z_streamp;
+
+/*
+   The application must update next_in and avail_in when avail_in has
+   dropped to zero. It must update next_out and avail_out when avail_out
+   has dropped to zero. The application must initialize zalloc, zfree and
+   opaque before calling the init function. All other fields are set by the
+   compression library and must not be updated by the application.
+
+   The opaque value provided by the application will be passed as the first
+   parameter for calls of zalloc and zfree. This can be useful for custom
+   memory management. The compression library attaches no meaning to the
+   opaque value.
+
+   zalloc must return Z_NULL if there is not enough memory for the object.
+   If zlib is used in a multi-threaded application, zalloc and zfree must be
+   thread safe.
+
+   On 16-bit systems, the functions zalloc and zfree must be able to allocate
+   exactly 65536 bytes, but will not be required to allocate more than this
+   if the symbol MAXSEG_64K is defined (see zconf.h). WARNING: On MSDOS,
+   pointers returned by zalloc for objects of exactly 65536 bytes *must*
+   have their offset normalized to zero. The default allocation function
+   provided by this library ensures this (see zutil.c). To reduce memory
+   requirements and avoid any allocation of 64K objects, at the expense of
+   compression ratio, compile the library with -DMAX_WBITS=14 (see zconf.h).
+
+   The fields total_in and total_out can be used for statistics or
+   progress reports. After compression, total_in holds the total size of
+   the uncompressed data and may be saved for use in the decompressor
+   (particularly if the decompressor wants to decompress everything in
+   a single step).
+*/
+
+                        /* constants */
+
+#define Z_NO_FLUSH      0
+#define Z_PARTIAL_FLUSH 1 /* will be removed, use Z_SYNC_FLUSH instead */
+#define Z_SYNC_FLUSH    2
+#define Z_FULL_FLUSH    3
+#define Z_FINISH        4
+/* Allowed flush values; see deflate() below for details */
+
+#define Z_OK            0
+#define Z_STREAM_END    1
+#define Z_NEED_DICT     2
+#define Z_ERRNO        (-1)
+#define Z_STREAM_ERROR (-2)
+#define Z_DATA_ERROR   (-3)
+#define Z_MEM_ERROR    (-4)
+#define Z_BUF_ERROR    (-5)
+#define Z_VERSION_ERROR (-6)
+/* Return codes for the compression/decompression functions. Negative
+ * values are errors, positive values are used for special but normal events.
+ */
+
+#define Z_NO_COMPRESSION         0
+#define Z_BEST_SPEED             1
+#define Z_BEST_COMPRESSION       9
+#define Z_DEFAULT_COMPRESSION  (-1)
+/* compression levels */
+
+#define Z_FILTERED            1
+#define Z_HUFFMAN_ONLY        2
+#define Z_DEFAULT_STRATEGY    0
+/* compression strategy; see deflateInit2() below for details */
+
+#define Z_BINARY   0
+#define Z_ASCII    1
+#define Z_UNKNOWN  2
+/* Possible values of the data_type field */
+
+#define Z_DEFLATED   8
+/* The deflate compression method (the only one supported in this version) */
+
+#define Z_NULL  0  /* for initializing zalloc, zfree, opaque */
+
+#define zlib_version zlibVersion()
+/* for compatibility with versions < 1.0.2 */
+
+                        /* basic functions */
+
+ZEXTERN const char * ZEXPORT zlibVersion OF((void));
+/* The application can compare zlibVersion and ZLIB_VERSION for consistency.
+   If the first character differs, the library code actually used is
+   not compatible with the zlib.h header file used by the application.
+   This check is automatically made by deflateInit and inflateInit.
+ */
+
+/* 
+ZEXTERN int ZEXPORT deflateInit OF((z_streamp strm, int level));
+
+     Initializes the internal stream state for compression. The fields
+   zalloc, zfree and opaque must be initialized before by the caller.
+   If zalloc and zfree are set to Z_NULL, deflateInit updates them to
+   use default allocation functions.
+
+     The compression level must be Z_DEFAULT_COMPRESSION, or between 0 and 9:
+   1 gives best speed, 9 gives best compression, 0 gives no compression at
+   all (the input data is simply copied a block at a time).
+   Z_DEFAULT_COMPRESSION requests a default compromise between speed and
+   compression (currently equivalent to level 6).
+
+     deflateInit returns Z_OK if success, Z_MEM_ERROR if there was not
+   enough memory, Z_STREAM_ERROR if level is not a valid compression level,
+   Z_VERSION_ERROR if the zlib library version (zlib_version) is incompatible
+   with the version assumed by the caller (ZLIB_VERSION).
+   msg is set to null if there is no error message.  deflateInit does not
+   perform any compression: this will be done by deflate().
+*/
+
+
+ZEXTERN int ZEXPORT deflate OF((z_streamp strm, int flush));
+/*
+    deflate compresses as much data as possible, and stops when the input
+  buffer becomes empty or the output buffer becomes full. It may introduce some
+  output latency (reading input without producing any output) except when
+  forced to flush.
+
+    The detailed semantics are as follows. deflate performs one or both of the
+  following actions:
+
+  - Compress more input starting at next_in and update next_in and avail_in
+    accordingly. If not all input can be processed (because there is not
+    enough room in the output buffer), next_in and avail_in are updated and
+    processing will resume at this point for the next call of deflate().
+
+  - Provide more output starting at next_out and update next_out and avail_out
+    accordingly. This action is forced if the parameter flush is non zero.
+    Forcing flush frequently degrades the compression ratio, so this parameter
+    should be set only when necessary (in interactive applications).
+    Some output may be provided even if flush is not set.
+
+  Before the call of deflate(), the application should ensure that at least
+  one of the actions is possible, by providing more input and/or consuming
+  more output, and updating avail_in or avail_out accordingly; avail_out
+  should never be zero before the call. The application can consume the
+  compressed output when it wants, for example when the output buffer is full
+  (avail_out == 0), or after each call of deflate(). If deflate returns Z_OK
+  and with zero avail_out, it must be called again after making room in the
+  output buffer because there might be more output pending.
+
+    If the parameter flush is set to Z_SYNC_FLUSH, all pending output is
+  flushed to the output buffer and the output is aligned on a byte boundary, so
+  that the decompressor can get all input data available so far. (In particular
+  avail_in is zero after the call if enough output space has been provided
+  before the call.)  Flushing may degrade compression for some compression
+  algorithms and so it should be used only when necessary.
+
+    If flush is set to Z_FULL_FLUSH, all output is flushed as with
+  Z_SYNC_FLUSH, and the compression state is reset so that decompression can
+  restart from this point if previous compressed data has been damaged or if
+  random access is desired. Using Z_FULL_FLUSH too often can seriously degrade
+  the compression.
+
+    If deflate returns with avail_out == 0, this function must be called again
+  with the same value of the flush parameter and more output space (updated
+  avail_out), until the flush is complete (deflate returns with non-zero
+  avail_out).
+
+    If the parameter flush is set to Z_FINISH, pending input is processed,
+  pending output is flushed and deflate returns with Z_STREAM_END if there
+  was enough output space; if deflate returns with Z_OK, this function must be
+  called again with Z_FINISH and more output space (updated avail_out) but no
+  more input data, until it returns with Z_STREAM_END or an error. After
+  deflate has returned Z_STREAM_END, the only possible operations on the
+  stream are deflateReset or deflateEnd.
+  
+    Z_FINISH can be used immediately after deflateInit if all the compression
+  is to be done in a single step. In this case, avail_out must be at least
+  0.1% larger than avail_in plus 12 bytes.  If deflate does not return
+  Z_STREAM_END, then it must be called again as described above.
+
+    deflate() sets strm->adler to the adler32 checksum of all input read
+  so far (that is, total_in bytes).
+
+    deflate() may update data_type if it can make a good guess about
+  the input data type (Z_ASCII or Z_BINARY). In doubt, the data is considered
+  binary. This field is only for information purposes and does not affect
+  the compression algorithm in any manner.
+
+    deflate() returns Z_OK if some progress has been made (more input
+  processed or more output produced), Z_STREAM_END if all input has been
+  consumed and all output has been produced (only when flush is set to
+  Z_FINISH), Z_STREAM_ERROR if the stream state was inconsistent (for example
+  if next_in or next_out was NULL), Z_BUF_ERROR if no progress is possible
+  (for example avail_in or avail_out was zero).
+*/
+
+
+ZEXTERN int ZEXPORT deflateEnd OF((z_streamp strm));
+/*
+     All dynamically allocated data structures for this stream are freed.
+   This function discards any unprocessed input and does not flush any
+   pending output.
+
+     deflateEnd returns Z_OK if success, Z_STREAM_ERROR if the
+   stream state was inconsistent, Z_DATA_ERROR if the stream was freed
+   prematurely (some input or output was discarded). In the error case,
+   msg may be set but then points to a static string (which must not be
+   deallocated).
+*/
+
+
+/* 
+ZEXTERN int ZEXPORT inflateInit OF((z_streamp strm));
+
+     Initializes the internal stream state for decompression. The fields
+   next_in, avail_in, zalloc, zfree and opaque must be initialized before by
+   the caller. If next_in is not Z_NULL and avail_in is large enough (the exact
+   value depends on the compression method), inflateInit determines the
+   compression method from the zlib header and allocates all data structures
+   accordingly; otherwise the allocation will be deferred to the first call of
+   inflate.  If zalloc and zfree are set to Z_NULL, inflateInit updates them to
+   use default allocation functions.
+
+     inflateInit returns Z_OK if success, Z_MEM_ERROR if there was not enough
+   memory, Z_VERSION_ERROR if the zlib library version is incompatible with the
+   version assumed by the caller.  msg is set to null if there is no error
+   message. inflateInit does not perform any decompression apart from reading
+   the zlib header if present: this will be done by inflate().  (So next_in and
+   avail_in may be modified, but next_out and avail_out are unchanged.)
+*/
+
+
+ZEXTERN int ZEXPORT inflate OF((z_streamp strm, int flush));
+/*
+    inflate decompresses as much data as possible, and stops when the input
+  buffer becomes empty or the output buffer becomes full. It may some
+  introduce some output latency (reading input without producing any output)
+  except when forced to flush.
+
+  The detailed semantics are as follows. inflate performs one or both of the
+  following actions:
+
+  - Decompress more input starting at next_in and update next_in and avail_in
+    accordingly. If not all input can be processed (because there is not
+    enough room in the output buffer), next_in is updated and processing
+    will resume at this point for the next call of inflate().
+
+  - Provide more output starting at next_out and update next_out and avail_out
+    accordingly.  inflate() provides as much output as possible, until there
+    is no more input data or no more space in the output buffer (see below
+    about the flush parameter).
+
+  Before the call of inflate(), the application should ensure that at least
+  one of the actions is possible, by providing more input and/or consuming
+  more output, and updating the next_* and avail_* values accordingly.
+  The application can consume the uncompressed output when it wants, for
+  example when the output buffer is full (avail_out == 0), or after each
+  call of inflate(). If inflate returns Z_OK and with zero avail_out, it
+  must be called again after making room in the output buffer because there
+  might be more output pending.
+
+    If the parameter flush is set to Z_SYNC_FLUSH, inflate flushes as much
+  output as possible to the output buffer. The flushing behavior of inflate is
+  not specified for values of the flush parameter other than Z_SYNC_FLUSH
+  and Z_FINISH, but the current implementation actually flushes as much output
+  as possible anyway.
+
+    inflate() should normally be called until it returns Z_STREAM_END or an
+  error. However if all decompression is to be performed in a single step
+  (a single call of inflate), the parameter flush should be set to
+  Z_FINISH. In this case all pending input is processed and all pending
+  output is flushed; avail_out must be large enough to hold all the
+  uncompressed data. (The size of the uncompressed data may have been saved
+  by the compressor for this purpose.) The next operation on this stream must
+  be inflateEnd to deallocate the decompression state. The use of Z_FINISH
+  is never required, but can be used to inform inflate that a faster routine
+  may be used for the single inflate() call.
+
+     If a preset dictionary is needed at this point (see inflateSetDictionary
+  below), inflate sets strm-adler to the adler32 checksum of the
+  dictionary chosen by the compressor and returns Z_NEED_DICT; otherwise 
+  it sets strm->adler to the adler32 checksum of all output produced
+  so far (that is, total_out bytes) and returns Z_OK, Z_STREAM_END or
+  an error code as described below. At the end of the stream, inflate()
+  checks that its computed adler32 checksum is equal to that saved by the
+  compressor and returns Z_STREAM_END only if the checksum is correct.
+
+    inflate() returns Z_OK if some progress has been made (more input processed
+  or more output produced), Z_STREAM_END if the end of the compressed data has
+  been reached and all uncompressed output has been produced, Z_NEED_DICT if a
+  preset dictionary is needed at this point, Z_DATA_ERROR if the input data was
+  corrupted (input stream not conforming to the zlib format or incorrect
+  adler32 checksum), Z_STREAM_ERROR if the stream structure was inconsistent
+  (for example if next_in or next_out was NULL), Z_MEM_ERROR if there was not
+  enough memory, Z_BUF_ERROR if no progress is possible or if there was not
+  enough room in the output buffer when Z_FINISH is used. In the Z_DATA_ERROR
+  case, the application may then call inflateSync to look for a good
+  compression block.
+*/
+
+
+ZEXTERN int ZEXPORT inflateEnd OF((z_streamp strm));
+/*
+     All dynamically allocated data structures for this stream are freed.
+   This function discards any unprocessed input and does not flush any
+   pending output.
+
+     inflateEnd returns Z_OK if success, Z_STREAM_ERROR if the stream state
+   was inconsistent. In the error case, msg may be set but then points to a
+   static string (which must not be deallocated).
+*/
+
+                        /* Advanced functions */
+
+/*
+    The following functions are needed only in some special applications.
+*/
+
+/*   
+ZEXTERN int ZEXPORT deflateInit2 OF((z_streamp strm,
+                                     int  level,
+                                     int  method,
+                                     int  windowBits,
+                                     int  memLevel,
+                                     int  strategy));
+
+     This is another version of deflateInit with more compression options. The
+   fields next_in, zalloc, zfree and opaque must be initialized before by
+   the caller.
+
+     The method parameter is the compression method. It must be Z_DEFLATED in
+   this version of the library.
+
+     The windowBits parameter is the base two logarithm of the window size
+   (the size of the history buffer).  It should be in the range 8..15 for this
+   version of the library. Larger values of this parameter result in better
+   compression at the expense of memory usage. The default value is 15 if
+   deflateInit is used instead.
+
+     The memLevel parameter specifies how much memory should be allocated
+   for the internal compression state. memLevel=1 uses minimum memory but
+   is slow and reduces compression ratio; memLevel=9 uses maximum memory
+   for optimal speed. The default value is 8. See zconf.h for total memory
+   usage as a function of windowBits and memLevel.
+
+     The strategy parameter is used to tune the compression algorithm. Use the
+   value Z_DEFAULT_STRATEGY for normal data, Z_FILTERED for data produced by a
+   filter (or predictor), or Z_HUFFMAN_ONLY to force Huffman encoding only (no
+   string match).  Filtered data consists mostly of small values with a
+   somewhat random distribution. In this case, the compression algorithm is
+   tuned to compress them better. The effect of Z_FILTERED is to force more
+   Huffman coding and less string matching; it is somewhat intermediate
+   between Z_DEFAULT and Z_HUFFMAN_ONLY. The strategy parameter only affects
+   the compression ratio but not the correctness of the compressed output even
+   if it is not set appropriately.
+
+      deflateInit2 returns Z_OK if success, Z_MEM_ERROR if there was not enough
+   memory, Z_STREAM_ERROR if a parameter is invalid (such as an invalid
+   method). msg is set to null if there is no error message.  deflateInit2 does
+   not perform any compression: this will be done by deflate().
+*/
+                            
+ZEXTERN int ZEXPORT deflateSetDictionary OF((z_streamp strm,
+                                             const Bytef *dictionary,
+                                             uInt  dictLength));
+/*
+     Initializes the compression dictionary from the given byte sequence
+   without producing any compressed output. This function must be called
+   immediately after deflateInit, deflateInit2 or deflateReset, before any
+   call of deflate. The compressor and decompressor must use exactly the same
+   dictionary (see inflateSetDictionary).
+
+     The dictionary should consist of strings (byte sequences) that are likely
+   to be encountered later in the data to be compressed, with the most commonly
+   used strings preferably put towards the end of the dictionary. Using a
+   dictionary is most useful when the data to be compressed is short and can be
+   predicted with good accuracy; the data can then be compressed better than
+   with the default empty dictionary.
+
+     Depending on the size of the compression data structures selected by
+   deflateInit or deflateInit2, a part of the dictionary may in effect be
+   discarded, for example if the dictionary is larger than the window size in
+   deflate or deflate2. Thus the strings most likely to be useful should be
+   put at the end of the dictionary, not at the front.
+
+     Upon return of this function, strm->adler is set to the Adler32 value
+   of the dictionary; the decompressor may later use this value to determine
+   which dictionary has been used by the compressor. (The Adler32 value
+   applies to the whole dictionary even if only a subset of the dictionary is
+   actually used by the compressor.)
+
+     deflateSetDictionary returns Z_OK if success, or Z_STREAM_ERROR if a
+   parameter is invalid (such as NULL dictionary) or the stream state is
+   inconsistent (for example if deflate has already been called for this stream
+   or if the compression method is bsort). deflateSetDictionary does not
+   perform any compression: this will be done by deflate().
+*/
+
+ZEXTERN int ZEXPORT deflateCopy OF((z_streamp dest,
+                                    z_streamp source));
+/*
+     Sets the destination stream as a complete copy of the source stream.
+
+     This function can be useful when several compression strategies will be
+   tried, for example when there are several ways of pre-processing the input
+   data with a filter. The streams that will be discarded should then be freed
+   by calling deflateEnd.  Note that deflateCopy duplicates the internal
+   compression state which can be quite large, so this strategy is slow and
+   can consume lots of memory.
+
+     deflateCopy returns Z_OK if success, Z_MEM_ERROR if there was not
+   enough memory, Z_STREAM_ERROR if the source stream state was inconsistent
+   (such as zalloc being NULL). msg is left unchanged in both source and
+   destination.
+*/
+
+ZEXTERN int ZEXPORT deflateReset OF((z_streamp strm));
+/*
+     This function is equivalent to deflateEnd followed by deflateInit,
+   but does not free and reallocate all the internal compression state.
+   The stream will keep the same compression level and any other attributes
+   that may have been set by deflateInit2.
+
+      deflateReset returns Z_OK if success, or Z_STREAM_ERROR if the source
+   stream state was inconsistent (such as zalloc or state being NULL).
+*/
+
+ZEXTERN int ZEXPORT deflateParams OF((z_streamp strm,
+				      int level,
+				      int strategy));
+/*
+     Dynamically update the compression level and compression strategy.  The
+   interpretation of level and strategy is as in deflateInit2.  This can be
+   used to switch between compression and straight copy of the input data, or
+   to switch to a different kind of input data requiring a different
+   strategy. If the compression level is changed, the input available so far
+   is compressed with the old level (and may be flushed); the new level will
+   take effect only at the next call of deflate().
+
+     Before the call of deflateParams, the stream state must be set as for
+   a call of deflate(), since the currently available input may have to
+   be compressed and flushed. In particular, strm->avail_out must be non-zero.
+
+     deflateParams returns Z_OK if success, Z_STREAM_ERROR if the source
+   stream state was inconsistent or if a parameter was invalid, Z_BUF_ERROR
+   if strm->avail_out was zero.
+*/
+
+/*   
+ZEXTERN int ZEXPORT inflateInit2 OF((z_streamp strm,
+                                     int  windowBits));
+
+     This is another version of inflateInit with an extra parameter. The
+   fields next_in, avail_in, zalloc, zfree and opaque must be initialized
+   before by the caller.
+
+     The windowBits parameter is the base two logarithm of the maximum window
+   size (the size of the history buffer).  It should be in the range 8..15 for
+   this version of the library. The default value is 15 if inflateInit is used
+   instead. If a compressed stream with a larger window size is given as
+   input, inflate() will return with the error code Z_DATA_ERROR instead of
+   trying to allocate a larger window.
+
+      inflateInit2 returns Z_OK if success, Z_MEM_ERROR if there was not enough
+   memory, Z_STREAM_ERROR if a parameter is invalid (such as a negative
+   memLevel). msg is set to null if there is no error message.  inflateInit2
+   does not perform any decompression apart from reading the zlib header if
+   present: this will be done by inflate(). (So next_in and avail_in may be
+   modified, but next_out and avail_out are unchanged.)
+*/
+
+ZEXTERN int ZEXPORT inflateSetDictionary OF((z_streamp strm,
+                                             const Bytef *dictionary,
+                                             uInt  dictLength));
+/*
+     Initializes the decompression dictionary from the given uncompressed byte
+   sequence. This function must be called immediately after a call of inflate
+   if this call returned Z_NEED_DICT. The dictionary chosen by the compressor
+   can be determined from the Adler32 value returned by this call of
+   inflate. The compressor and decompressor must use exactly the same
+   dictionary (see deflateSetDictionary).
+
+     inflateSetDictionary returns Z_OK if success, Z_STREAM_ERROR if a
+   parameter is invalid (such as NULL dictionary) or the stream state is
+   inconsistent, Z_DATA_ERROR if the given dictionary doesn't match the
+   expected one (incorrect Adler32 value). inflateSetDictionary does not
+   perform any decompression: this will be done by subsequent calls of
+   inflate().
+*/
+
+ZEXTERN int ZEXPORT inflateSync OF((z_streamp strm));
+/* 
+    Skips invalid compressed data until a full flush point (see above the
+  description of deflate with Z_FULL_FLUSH) can be found, or until all
+  available input is skipped. No output is provided.
+
+    inflateSync returns Z_OK if a full flush point has been found, Z_BUF_ERROR
+  if no more input was provided, Z_DATA_ERROR if no flush point has been found,
+  or Z_STREAM_ERROR if the stream structure was inconsistent. In the success
+  case, the application may save the current current value of total_in which
+  indicates where valid compressed data was found. In the error case, the
+  application may repeatedly call inflateSync, providing more input each time,
+  until success or end of the input data.
+*/
+
+ZEXTERN int ZEXPORT inflateReset OF((z_streamp strm));
+/*
+     This function is equivalent to inflateEnd followed by inflateInit,
+   but does not free and reallocate all the internal decompression state.
+   The stream will keep attributes that may have been set by inflateInit2.
+
+      inflateReset returns Z_OK if success, or Z_STREAM_ERROR if the source
+   stream state was inconsistent (such as zalloc or state being NULL).
+*/
+
+
+                        /* utility functions */
+
+/*
+     The following utility functions are implemented on top of the
+   basic stream-oriented functions. To simplify the interface, some
+   default options are assumed (compression level and memory usage,
+   standard memory allocation functions). The source code of these
+   utility functions can easily be modified if you need special options.
+*/
+
+ZEXTERN int ZEXPORT compress OF((Bytef *dest,   uLongf *destLen,
+                                 const Bytef *source, uLong sourceLen));
+/*
+     Compresses the source buffer into the destination buffer.  sourceLen is
+   the byte length of the source buffer. Upon entry, destLen is the total
+   size of the destination buffer, which must be at least 0.1% larger than
+   sourceLen plus 12 bytes. Upon exit, destLen is the actual size of the
+   compressed buffer.
+     This function can be used to compress a whole file at once if the
+   input file is mmap'ed.
+     compress returns Z_OK if success, Z_MEM_ERROR if there was not
+   enough memory, Z_BUF_ERROR if there was not enough room in the output
+   buffer.
+*/
+
+ZEXTERN int ZEXPORT compress2 OF((Bytef *dest,   uLongf *destLen,
+                                  const Bytef *source, uLong sourceLen,
+                                  int level));
+/*
+     Compresses the source buffer into the destination buffer. The level
+   parameter has the same meaning as in deflateInit.  sourceLen is the byte
+   length of the source buffer. Upon entry, destLen is the total size of the
+   destination buffer, which must be at least 0.1% larger than sourceLen plus
+   12 bytes. Upon exit, destLen is the actual size of the compressed buffer.
+
+     compress2 returns Z_OK if success, Z_MEM_ERROR if there was not enough
+   memory, Z_BUF_ERROR if there was not enough room in the output buffer,
+   Z_STREAM_ERROR if the level parameter is invalid.
+*/
+
+ZEXTERN int ZEXPORT uncompress OF((Bytef *dest,   uLongf *destLen,
+                                   const Bytef *source, uLong sourceLen));
+/*
+     Decompresses the source buffer into the destination buffer.  sourceLen is
+   the byte length of the source buffer. Upon entry, destLen is the total
+   size of the destination buffer, which must be large enough to hold the
+   entire uncompressed data. (The size of the uncompressed data must have
+   been saved previously by the compressor and transmitted to the decompressor
+   by some mechanism outside the scope of this compression library.)
+   Upon exit, destLen is the actual size of the compressed buffer.
+     This function can be used to decompress a whole file at once if the
+   input file is mmap'ed.
+
+     uncompress returns Z_OK if success, Z_MEM_ERROR if there was not
+   enough memory, Z_BUF_ERROR if there was not enough room in the output
+   buffer, or Z_DATA_ERROR if the input data was corrupted.
+*/
+
+
+typedef voidp gzFile;
+
+ZEXTERN gzFile ZEXPORT gzopen  OF((const char *path, const char *mode));
+/*
+     Opens a gzip (.gz) file for reading or writing. The mode parameter
+   is as in fopen ("rb" or "wb") but can also include a compression level
+   ("wb9") or a strategy: 'f' for filtered data as in "wb6f", 'h' for
+   Huffman only compression as in "wb1h". (See the description
+   of deflateInit2 for more information about the strategy parameter.)
+
+     gzopen can be used to read a file which is not in gzip format; in this
+   case gzread will directly read from the file without decompression.
+
+     gzopen returns NULL if the file could not be opened or if there was
+   insufficient memory to allocate the (de)compression state; errno
+   can be checked to distinguish the two cases (if errno is zero, the
+   zlib error is Z_MEM_ERROR).  */
+
+ZEXTERN gzFile ZEXPORT gzdopen  OF((int fd, const char *mode));
+/*
+     gzdopen() associates a gzFile with the file descriptor fd.  File
+   descriptors are obtained from calls like open, dup, creat, pipe or
+   fileno (in the file has been previously opened with fopen).
+   The mode parameter is as in gzopen.
+     The next call of gzclose on the returned gzFile will also close the
+   file descriptor fd, just like fclose(fdopen(fd), mode) closes the file
+   descriptor fd. If you want to keep fd open, use gzdopen(dup(fd), mode).
+     gzdopen returns NULL if there was insufficient memory to allocate
+   the (de)compression state.
+*/
+
+ZEXTERN int ZEXPORT gzsetparams OF((gzFile file, int level, int strategy));
+/*
+     Dynamically update the compression level or strategy. See the description
+   of deflateInit2 for the meaning of these parameters.
+     gzsetparams returns Z_OK if success, or Z_STREAM_ERROR if the file was not
+   opened for writing.
+*/
+
+ZEXTERN int ZEXPORT    gzread  OF((gzFile file, voidp buf, unsigned len));
+/*
+     Reads the given number of uncompressed bytes from the compressed file.
+   If the input file was not in gzip format, gzread copies the given number
+   of bytes into the buffer.
+     gzread returns the number of uncompressed bytes actually read (0 for
+   end of file, -1 for error). */
+
+ZEXTERN int ZEXPORT    gzwrite OF((gzFile file, 
+				   const voidp buf, unsigned len));
+/*
+     Writes the given number of uncompressed bytes into the compressed file.
+   gzwrite returns the number of uncompressed bytes actually written
+   (0 in case of error).
+*/
+
+ZEXTERN int ZEXPORTVA   gzprintf OF((gzFile file, const char *format, ...));
+/*
+     Converts, formats, and writes the args to the compressed file under
+   control of the format string, as in fprintf. gzprintf returns the number of
+   uncompressed bytes actually written (0 in case of error).
+*/
+
+ZEXTERN int ZEXPORT gzputs OF((gzFile file, const char *s));
+/*
+      Writes the given null-terminated string to the compressed file, excluding
+   the terminating null character.
+      gzputs returns the number of characters written, or -1 in case of error.
+*/
+
+ZEXTERN char * ZEXPORT gzgets OF((gzFile file, char *buf, int len));
+/*
+      Reads bytes from the compressed file until len-1 characters are read, or
+   a newline character is read and transferred to buf, or an end-of-file
+   condition is encountered.  The string is then terminated with a null
+   character.
+      gzgets returns buf, or Z_NULL in case of error.
+*/
+
+ZEXTERN int ZEXPORT    gzputc OF((gzFile file, int c));
+/*
+      Writes c, converted to an unsigned char, into the compressed file.
+   gzputc returns the value that was written, or -1 in case of error.
+*/
+
+ZEXTERN int ZEXPORT    gzgetc OF((gzFile file));
+/*
+      Reads one byte from the compressed file. gzgetc returns this byte
+   or -1 in case of end of file or error.
+*/
+
+ZEXTERN int ZEXPORT    gzflush OF((gzFile file, int flush));
+/*
+     Flushes all pending output into the compressed file. The parameter
+   flush is as in the deflate() function. The return value is the zlib
+   error number (see function gzerror below). gzflush returns Z_OK if
+   the flush parameter is Z_FINISH and all output could be flushed.
+     gzflush should be called only when strictly necessary because it can
+   degrade compression.
+*/
+
+ZEXTERN z_off_t ZEXPORT    gzseek OF((gzFile file,
+				      z_off_t offset, int whence));
+/* 
+      Sets the starting position for the next gzread or gzwrite on the
+   given compressed file. The offset represents a number of bytes in the
+   uncompressed data stream. The whence parameter is defined as in lseek(2);
+   the value SEEK_END is not supported.
+     If the file is opened for reading, this function is emulated but can be
+   extremely slow. If the file is opened for writing, only forward seeks are
+   supported; gzseek then compresses a sequence of zeroes up to the new
+   starting position.
+
+      gzseek returns the resulting offset location as measured in bytes from
+   the beginning of the uncompressed stream, or -1 in case of error, in
+   particular if the file is opened for writing and the new starting position
+   would be before the current position.
+*/
+
+ZEXTERN int ZEXPORT    gzrewind OF((gzFile file));
+/*
+     Rewinds the given file. This function is supported only for reading.
+
+   gzrewind(file) is equivalent to (int)gzseek(file, 0L, SEEK_SET)
+*/
+
+ZEXTERN z_off_t ZEXPORT    gztell OF((gzFile file));
+/*
+     Returns the starting position for the next gzread or gzwrite on the
+   given compressed file. This position represents a number of bytes in the
+   uncompressed data stream.
+
+   gztell(file) is equivalent to gzseek(file, 0L, SEEK_CUR)
+*/
+
+ZEXTERN int ZEXPORT gzeof OF((gzFile file));
+/*
+     Returns 1 when EOF has previously been detected reading the given
+   input stream, otherwise zero.
+*/
+
+ZEXTERN int ZEXPORT    gzclose OF((gzFile file));
+/*
+     Flushes all pending output if necessary, closes the compressed file
+   and deallocates all the (de)compression state. The return value is the zlib
+   error number (see function gzerror below).
+*/
+
+ZEXTERN const char * ZEXPORT gzerror OF((gzFile file, int *errnum));
+/*
+     Returns the error message for the last error which occurred on the
+   given compressed file. errnum is set to zlib error number. If an
+   error occurred in the file system and not in the compression library,
+   errnum is set to Z_ERRNO and the application may consult errno
+   to get the exact error code.
+*/
+
+                        /* checksum functions */
+
+/*
+     These functions are not related to compression but are exported
+   anyway because they might be useful in applications using the
+   compression library.
+*/
+
+ZEXTERN uLong ZEXPORT adler32 OF((uLong adler, const Bytef *buf, uInt len));
+
+/*
+     Update a running Adler-32 checksum with the bytes buf[0..len-1] and
+   return the updated checksum. If buf is NULL, this function returns
+   the required initial value for the checksum.
+   An Adler-32 checksum is almost as reliable as a CRC32 but can be computed
+   much faster. Usage example:
+
+     uLong adler = adler32(0L, Z_NULL, 0);
+
+     while (read_buffer(buffer, length) != EOF) {
+       adler = adler32(adler, buffer, length);
+     }
+     if (adler != original_adler) error();
+*/
+
+ZEXTERN uLong ZEXPORT crc32   OF((uLong crc, const Bytef *buf, uInt len));
+/*
+     Update a running crc with the bytes buf[0..len-1] and return the updated
+   crc. If buf is NULL, this function returns the required initial value
+   for the crc. Pre- and post-conditioning (one's complement) is performed
+   within this function so it shouldn't be done by the application.
+   Usage example:
+
+     uLong crc = crc32(0L, Z_NULL, 0);
+
+     while (read_buffer(buffer, length) != EOF) {
+       crc = crc32(crc, buffer, length);
+     }
+     if (crc != original_crc) error();
+*/
+
+
+                        /* various hacks, don't look :) */
+
+/* deflateInit and inflateInit are macros to allow checking the zlib version
+ * and the compiler's view of z_stream:
+ */
+ZEXTERN int ZEXPORT deflateInit_ OF((z_streamp strm, int level,
+                                     const char *version, int stream_size));
+ZEXTERN int ZEXPORT inflateInit_ OF((z_streamp strm,
+                                     const char *version, int stream_size));
+ZEXTERN int ZEXPORT deflateInit2_ OF((z_streamp strm, int  level, int  method,
+                                      int windowBits, int memLevel,
+                                      int strategy, const char *version,
+                                      int stream_size));
+ZEXTERN int ZEXPORT inflateInit2_ OF((z_streamp strm, int  windowBits,
+                                      const char *version, int stream_size));
+#define deflateInit(strm, level) \
+        deflateInit_((strm), (level),       ZLIB_VERSION, sizeof(z_stream))
+#define inflateInit(strm) \
+        inflateInit_((strm),                ZLIB_VERSION, sizeof(z_stream))
+#define deflateInit2(strm, level, method, windowBits, memLevel, strategy) \
+        deflateInit2_((strm),(level),(method),(windowBits),(memLevel),\
+                      (strategy),           ZLIB_VERSION, sizeof(z_stream))
+#define inflateInit2(strm, windowBits) \
+        inflateInit2_((strm), (windowBits), ZLIB_VERSION, sizeof(z_stream))
+
+
+#if !defined(_Z_UTIL_H) && !defined(NO_DUMMY_DECL)
+    struct internal_state {int dummy;}; /* hack for buggy compilers */
+#endif
+
+ZEXTERN const char   * ZEXPORT zError           OF((int err));
+ZEXTERN int            ZEXPORT inflateSyncPoint OF((z_streamp z));
+ZEXTERN const uLongf * ZEXPORT get_crc_table    OF((void));
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* _ZLIB_H */
diff --git a/collects/plot/src/all/zutil.c b/collects/plot/src/all/zutil.c
new file mode 100644
index 0000000000..f8f2d3ac19
--- /dev/null
+++ b/collects/plot/src/all/zutil.c
@@ -0,0 +1,225 @@
+/* zutil.c -- target dependent utility functions for the compression library
+ * Copyright (C) 1995-2002 Jean-loup Gailly.
+ * For conditions of distribution and use, see copyright notice in zlib.h 
+ */
+
+/* @(#) $Id: zutil.c,v 1.1 2004/03/01 20:54:56 cozmic Exp $ */
+
+#include "zutil.h"
+
+struct internal_state      {int dummy;}; /* for buggy compilers */
+
+#ifndef STDC
+extern void exit OF((int));
+#endif
+
+const char *z_errmsg[10] = {
+"need dictionary",     /* Z_NEED_DICT       2  */
+"stream end",          /* Z_STREAM_END      1  */
+"",                    /* Z_OK              0  */
+"file error",          /* Z_ERRNO         (-1) */
+"stream error",        /* Z_STREAM_ERROR  (-2) */
+"data error",          /* Z_DATA_ERROR    (-3) */
+"insufficient memory", /* Z_MEM_ERROR     (-4) */
+"buffer error",        /* Z_BUF_ERROR     (-5) */
+"incompatible version",/* Z_VERSION_ERROR (-6) */
+""};
+
+
+const char * ZEXPORT zlibVersion()
+{
+    return ZLIB_VERSION;
+}
+
+#ifdef DEBUG
+
+#  ifndef verbose
+#    define verbose 0
+#  endif
+int z_verbose = verbose;
+
+void z_error (m)
+    char *m;
+{
+    fprintf(stderr, "%s\n", m);
+    exit(1);
+}
+#endif
+
+/* exported to allow conversion of error code to string for compress() and
+ * uncompress()
+ */
+const char * ZEXPORT zError(err)
+    int err;
+{
+    return ERR_MSG(err);
+}
+
+
+#ifndef HAVE_MEMCPY
+
+void zmemcpy(dest, source, len)
+    Bytef* dest;
+    const Bytef* source;
+    uInt  len;
+{
+    if (len == 0) return;
+    do {
+        *dest++ = *source++; /* ??? to be unrolled */
+    } while (--len != 0);
+}
+
+int zmemcmp(s1, s2, len)
+    const Bytef* s1;
+    const Bytef* s2;
+    uInt  len;
+{
+    uInt j;
+
+    for (j = 0; j < len; j++) {
+        if (s1[j] != s2[j]) return 2*(s1[j] > s2[j])-1;
+    }
+    return 0;
+}
+
+void zmemzero(dest, len)
+    Bytef* dest;
+    uInt  len;
+{
+    if (len == 0) return;
+    do {
+        *dest++ = 0;  /* ??? to be unrolled */
+    } while (--len != 0);
+}
+#endif
+
+#ifdef __TURBOC__
+#if (defined( __BORLANDC__) || !defined(SMALL_MEDIUM)) && !defined(__32BIT__)
+/* Small and medium model in Turbo C are for now limited to near allocation
+ * with reduced MAX_WBITS and MAX_MEM_LEVEL
+ */
+#  define MY_ZCALLOC
+
+/* Turbo C malloc() does not allow dynamic allocation of 64K bytes
+ * and farmalloc(64K) returns a pointer with an offset of 8, so we
+ * must fix the pointer. Warning: the pointer must be put back to its
+ * original form in order to free it, use zcfree().
+ */
+
+#define MAX_PTR 10
+/* 10*64K = 640K */
+
+local int next_ptr = 0;
+
+typedef struct ptr_table_s {
+    voidpf org_ptr;
+    voidpf new_ptr;
+} ptr_table;
+
+local ptr_table table[MAX_PTR];
+/* This table is used to remember the original form of pointers
+ * to large buffers (64K). Such pointers are normalized with a zero offset.
+ * Since MSDOS is not a preemptive multitasking OS, this table is not
+ * protected from concurrent access. This hack doesn't work anyway on
+ * a protected system like OS/2. Use Microsoft C instead.
+ */
+
+voidpf zcalloc (voidpf opaque, unsigned items, unsigned size)
+{
+    voidpf buf = opaque; /* just to make some compilers happy */
+    ulg bsize = (ulg)items*size;
+
+    /* If we allocate less than 65520 bytes, we assume that farmalloc
+     * will return a usable pointer which doesn't have to be normalized.
+     */
+    if (bsize < 65520L) {
+        buf = farmalloc(bsize);
+        if (*(ush*)&buf != 0) return buf;
+    } else {
+        buf = farmalloc(bsize + 16L);
+    }
+    if (buf == NULL || next_ptr >= MAX_PTR) return NULL;
+    table[next_ptr].org_ptr = buf;
+
+    /* Normalize the pointer to seg:0 */
+    *((ush*)&buf+1) += ((ush)((uch*)buf-0) + 15) >> 4;
+    *(ush*)&buf = 0;
+    table[next_ptr++].new_ptr = buf;
+    return buf;
+}
+
+void  zcfree (voidpf opaque, voidpf ptr)
+{
+    int n;
+    if (*(ush*)&ptr != 0) { /* object < 64K */
+        farfree(ptr);
+        return;
+    }
+    /* Find the original pointer */
+    for (n = 0; n < next_ptr; n++) {
+        if (ptr != table[n].new_ptr) continue;
+
+        farfree(table[n].org_ptr);
+        while (++n < next_ptr) {
+            table[n-1] = table[n];
+        }
+        next_ptr--;
+        return;
+    }
+    ptr = opaque; /* just to make some compilers happy */
+    Assert(0, "zcfree: ptr not found");
+}
+#endif
+#endif /* __TURBOC__ */
+
+
+#if defined(M_I86) && !defined(__32BIT__)
+/* Microsoft C in 16-bit mode */
+
+#  define MY_ZCALLOC
+
+#if (!defined(_MSC_VER) || (_MSC_VER <= 600))
+#  define _halloc  halloc
+#  define _hfree   hfree
+#endif
+
+voidpf zcalloc (voidpf opaque, unsigned items, unsigned size)
+{
+    if (opaque) opaque = 0; /* to make compiler happy */
+    return _halloc((long)items, size);
+}
+
+void  zcfree (voidpf opaque, voidpf ptr)
+{
+    if (opaque) opaque = 0; /* to make compiler happy */
+    _hfree(ptr);
+}
+
+#endif /* MSC */
+
+
+#ifndef MY_ZCALLOC /* Any system without a special alloc function */
+
+#ifndef STDC
+extern voidp  calloc OF((uInt items, uInt size));
+extern void   free   OF((voidpf ptr));
+#endif
+
+voidpf zcalloc (opaque, items, size)
+    voidpf opaque;
+    unsigned items;
+    unsigned size;
+{
+    if (opaque) items += size - size; /* make compiler happy */
+    return (voidpf)calloc(items, size);
+}
+
+void  zcfree (opaque, ptr)
+    voidpf opaque;
+    voidpf ptr;
+{
+    free(ptr);
+    if (opaque) return; /* make compiler happy */
+}
+
+#endif /* MY_ZCALLOC */
diff --git a/collects/plot/src/all/zutil.h b/collects/plot/src/all/zutil.h
new file mode 100644
index 0000000000..1f443e8cb3
--- /dev/null
+++ b/collects/plot/src/all/zutil.h
@@ -0,0 +1,220 @@
+/* zutil.h -- internal interface and configuration of the compression library
+ * Copyright (C) 1995-2002 Jean-loup Gailly.
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ */
+
+/* WARNING: this file should *not* be used by applications. It is
+   part of the implementation of the compression library and is
+   subject to change. Applications should only use zlib.h.
+ */
+
+/* @(#) $Id: zutil.h,v 1.1 2004/03/01 20:54:56 cozmic Exp $ */
+
+#ifndef _Z_UTIL_H
+#define _Z_UTIL_H
+
+#include "zlib.h"
+
+#ifdef STDC
+#  include <stddef.h>
+#  include <string.h>
+#  include <stdlib.h>
+#endif
+#ifdef NO_ERRNO_H
+    extern int errno;
+#else
+#   include <errno.h>
+#endif
+
+#ifndef local
+#  define local static
+#endif
+/* compile with -Dlocal if your debugger can't find static symbols */
+
+typedef unsigned char  uch;
+typedef uch FAR uchf;
+typedef unsigned short ush;
+typedef ush FAR ushf;
+typedef unsigned long  ulg;
+
+extern const char *z_errmsg[10]; /* indexed by 2-zlib_error */
+/* (size given to avoid silly warnings with Visual C++) */
+
+#define ERR_MSG(err) z_errmsg[Z_NEED_DICT-(err)]
+
+#define ERR_RETURN(strm,err) \
+  return (strm->msg = (char*)ERR_MSG(err), (err))
+/* To be used only when the state is known to be valid */
+
+        /* common constants */
+
+#ifndef DEF_WBITS
+#  define DEF_WBITS MAX_WBITS
+#endif
+/* default windowBits for decompression. MAX_WBITS is for compression only */
+
+#if MAX_MEM_LEVEL >= 8
+#  define DEF_MEM_LEVEL 8
+#else
+#  define DEF_MEM_LEVEL  MAX_MEM_LEVEL
+#endif
+/* default memLevel */
+
+#define STORED_BLOCK 0
+#define STATIC_TREES 1
+#define DYN_TREES    2
+/* The three kinds of block type */
+
+#define MIN_MATCH  3
+#define MAX_MATCH  258
+/* The minimum and maximum match lengths */
+
+#define PRESET_DICT 0x20 /* preset dictionary flag in zlib header */
+
+        /* target dependencies */
+
+#ifdef MSDOS
+#  define OS_CODE  0x00
+#  if defined(__TURBOC__) || defined(__BORLANDC__)
+#    if(__STDC__ == 1) && (defined(__LARGE__) || defined(__COMPACT__))
+       /* Allow compilation with ANSI keywords only enabled */
+       void _Cdecl farfree( void *block );
+       void *_Cdecl farmalloc( unsigned long nbytes );
+#    else
+#     include <alloc.h>
+#    endif
+#  else /* MSC or DJGPP */
+#    include <malloc.h>
+#  endif
+#endif
+
+#ifdef OS2
+#  define OS_CODE  0x06
+#endif
+
+#ifdef WIN32 /* Window 95 & Windows NT */
+#  define OS_CODE  0x0b
+#endif
+
+#if defined(VAXC) || defined(VMS)
+#  define OS_CODE  0x02
+#  define F_OPEN(name, mode) \
+     fopen((name), (mode), "mbc=60", "ctx=stm", "rfm=fix", "mrs=512")
+#endif
+
+#ifdef AMIGA
+#  define OS_CODE  0x01
+#endif
+
+#if defined(ATARI) || defined(atarist)
+#  define OS_CODE  0x05
+#endif
+
+#if defined(MACOS) || defined(TARGET_OS_MAC)
+#  define OS_CODE  0x07
+#  if defined(__MWERKS__) && __dest_os != __be_os && __dest_os != __win32_os
+#    include <unix.h> /* for fdopen */
+#  else
+#    ifndef fdopen
+#      define fdopen(fd,mode) NULL /* No fdopen() */
+#    endif
+#  endif
+#endif
+
+#ifdef __50SERIES /* Prime/PRIMOS */
+#  define OS_CODE  0x0F
+#endif
+
+#ifdef TOPS20
+#  define OS_CODE  0x0a
+#endif
+
+#if defined(_BEOS_) || defined(RISCOS)
+#  define fdopen(fd,mode) NULL /* No fdopen() */
+#endif
+
+#if (defined(_MSC_VER) && (_MSC_VER > 600))
+#  define fdopen(fd,type)  _fdopen(fd,type)
+#endif
+
+
+        /* Common defaults */
+
+#ifndef OS_CODE
+#  define OS_CODE  0x03  /* assume Unix */
+#endif
+
+#ifndef F_OPEN
+#  define F_OPEN(name, mode) fopen((name), (mode))
+#endif
+
+         /* functions */
+
+#ifdef HAVE_STRERROR
+   extern char *strerror OF((int));
+#  define zstrerror(errnum) strerror(errnum)
+#else
+#  define zstrerror(errnum) ""
+#endif
+
+#if defined(pyr)
+#  define NO_MEMCPY
+#endif
+#if defined(SMALL_MEDIUM) && !defined(_MSC_VER) && !defined(__SC__)
+ /* Use our own functions for small and medium model with MSC <= 5.0.
+  * You may have to use the same strategy for Borland C (untested).
+  * The __SC__ check is for Symantec.
+  */
+#  define NO_MEMCPY
+#endif
+#if defined(STDC) && !defined(HAVE_MEMCPY) && !defined(NO_MEMCPY)
+#  define HAVE_MEMCPY
+#endif
+#ifdef HAVE_MEMCPY
+#  ifdef SMALL_MEDIUM /* MSDOS small or medium model */
+#    define zmemcpy _fmemcpy
+#    define zmemcmp _fmemcmp
+#    define zmemzero(dest, len) _fmemset(dest, 0, len)
+#  else
+#    define zmemcpy memcpy
+#    define zmemcmp memcmp
+#    define zmemzero(dest, len) memset(dest, 0, len)
+#  endif
+#else
+   extern void zmemcpy  OF((Bytef* dest, const Bytef* source, uInt len));
+   extern int  zmemcmp  OF((const Bytef* s1, const Bytef* s2, uInt len));
+   extern void zmemzero OF((Bytef* dest, uInt len));
+#endif
+
+/* Diagnostic functions */
+#ifdef DEBUG
+#  include <stdio.h>
+   extern int z_verbose;
+   extern void z_error    OF((char *m));
+#  define Assert(cond,msg) {if(!(cond)) z_error(msg);}
+#  define Trace(x) {if (z_verbose>=0) fprintf x ;}
+#  define Tracev(x) {if (z_verbose>0) fprintf x ;}
+#  define Tracevv(x) {if (z_verbose>1) fprintf x ;}
+#  define Tracec(c,x) {if (z_verbose>0 && (c)) fprintf x ;}
+#  define Tracecv(c,x) {if (z_verbose>1 && (c)) fprintf x ;}
+#else
+#  define Assert(cond,msg)
+#  define Trace(x)
+#  define Tracev(x)
+#  define Tracevv(x)
+#  define Tracec(c,x)
+#  define Tracecv(c,x)
+#endif
+
+
+typedef uLong (ZEXPORT *check_func) OF((uLong check, const Bytef *buf,
+				       uInt len));
+voidpf zcalloc OF((voidpf opaque, unsigned items, unsigned size));
+void   zcfree  OF((voidpf opaque, voidpf ptr));
+
+#define ZALLOC(strm, items, size) \
+           (*((strm)->zalloc))((strm)->opaque, (items), (size))
+#define ZFREE(strm, addr)  (*((strm)->zfree))((strm)->opaque, (voidpf)(addr))
+#define TRY_FREE(s, p) {if (p) ZFREE(s, p);}
+
+#endif /* _Z_UTIL_H */
diff --git a/collects/plot/src/fit/fit.c b/collects/plot/src/fit/fit.c
new file mode 100644
index 0000000000..e14df85085
--- /dev/null
+++ b/collects/plot/src/fit/fit.c
@@ -0,0 +1,749 @@
+/*  NOTICE: Change of Copyright Status
+ *
+ *  The author of this module, Carsten Grammes, has expressed in
+ *  personal email that he has no more interest in this code, and
+ *  doesn't claim any copyright. He has agreed to put this module
+ *  into the public domain.
+ *
+ *  Lars Hecking  15-02-1999
+ */
+
+/*
+ *    Nonlinear least squares fit according to the
+ *      Marquardt-Levenberg-algorithm
+ *
+ *      added as Patch to Gnuplot (v3.2 and higher)
+ *      by Carsten Grammes
+ *      Experimental Physics, University of Saarbruecken, Germany
+ *
+ *      Internet address: cagr@rz.uni-sb.de
+ *
+ *      Copyright of this module:  1993, 1998  Carsten Grammes
+ *
+ *      Permission to use, copy, and distribute this software and its
+ *      documentation for any purpose with or without fee is hereby granted,
+ *      provided that the above copyright notice appear in all copies and
+ *      that both that copyright notice and this permission notice appear
+ *      in supporting documentation.
+ *
+ *      This software is provided "as is" without express or implied warranty.
+ *
+ *      930726:     Recoding of the Unix-like raw console I/O routines by:
+ *                  Michele Marziani (marziani@ferrara.infn.it)
+ * drd: start unitialised variables at 1 rather than NEARLY_ZERO
+ *  (fit is more likely to converge if started from 1 than 1e-30 ?)
+ *
+ * HBB (Broeker@physik.rwth-aachen.de) : fit didn't calculate the errors
+ * in the 'physically correct' (:-) way, if a third data column containing
+ * the errors (or 'uncertainties') of the input data was given. I think
+ * I've fixed that, but I'm not sure I really understood the M-L-algo well
+ * enough to get it right. I deduced my change from the final steps of the
+ * equivalent algorithm for the linear case, which is much easier to
+ * understand. (I also made some minor, mostly cosmetic changes)
+ *
+ * HBB (again): added error checking for negative covar[i][i] values and
+ * for too many parameters being specified.
+ *
+ * drd: allow 3d fitting. Data value is now called fit_z internally,
+ * ie a 2d fit is z vs x, and a 3d fit is z vs x and y.
+ *
+ * Lars Hecking : review update command, for VMS in particular, where
+ * it is not necessary to rename the old file.
+ *
+ * HBB, 971023: lifted fixed limit on number of datapoints, and number
+ * of parameters.
+ */
+
+
+#define FIT_MAIN
+
+#define NULL 0
+
+//#include <scheme.h>
+
+
+
+#include "matrix.h"
+#include "fit.h"
+
+/* #define STANDARD stderr */
+
+
+enum marq_res {
+    OK, ERROR, BETTER, WORSE
+};
+typedef enum marq_res marq_res_t;
+
+#ifdef INFINITY
+# undef INFINITY
+#endif
+
+#define INFINITY    1e30
+#define NEARLY_ZERO 1e-30
+
+
+/* Relative change for derivatives */
+#define DELTA	    0.001
+
+#define MAX_DATA    2048
+#define MAX_PARAMS  32
+#define MAX_LAMBDA  1e20
+#define MIN_LAMBDA  1e-20
+#define LAMBDA_UP_FACTOR 10
+#define LAMBDA_DOWN_FACTOR 10
+
+#define TBOOLEAN int
+
+# define PLUSMINUS   "+/-"
+
+
+
+/* HBB 971023: new, allow for dynamic adjustment of these: */
+static int max_data;
+static int max_params;
+
+static double epsilon = 1e-5;	/* convergence limit */
+static int maxiter = 0;		/* HBB 970304: maxiter patch */
+
+static char *FIXED = "# FIXED";
+static char *GNUFITLOG = "FIT_LOG";
+static char *FITLIMIT = "FIT_LIMIT";
+static char *FITSTARTLAMBDA = "FIT_START_LAMBDA";
+static char *FITLAMBDAFACTOR = "FIT_LAMBDA_FACTOR";
+static char *FITMAXITER = "FIT_MAXITER";	/* HBB 970304: maxiter patch */
+static char *FITSCRIPT = "FIT_SCRIPT";
+static char *DEFAULT_CMD = "replot";	/* if no fitscript spec. */
+
+
+static int num_data, num_params;
+static int columns;
+static double  *fit_x;
+static double    *fit_y;
+static double  *fit_z ;
+static double   *err_data;
+static double *a;
+
+
+/* static fixstr * par_name; */
+
+static double startup_lambda = 0;
+static double lambda_down_factor = LAMBDA_DOWN_FACTOR;
+static double lambda_up_factor = LAMBDA_UP_FACTOR;
+
+
+static void * current_fun;
+
+
+/*****************************************************************
+			 internal vars to store results of fit
+*****************************************************************/
+
+double rms = 0;
+double varience = 0;
+double *asym_error;
+double *asym_error_percent;
+
+MZ_DLLEXPORT
+double get_rms()
+{return rms;}
+
+MZ_DLLEXPORT
+double get_varience()
+{return varience;}
+
+MZ_DLLEXPORT
+double * get_asym_error()
+{return asym_error;}
+
+MZ_DLLEXPORT
+double * get_asym_error_percent()
+{return asym_error_percent;}
+
+
+/*****************************************************************
+			 internal Prototypes
+*****************************************************************/
+
+/*static void printmatrix __PROTO((double **C, int m, int n)); */
+static void print_matrix_and_vectors (double **C, double *d, double *r, int m, int n);
+static marq_res_t marquardt (double a[], double **alpha, double *chisq, 
+			     double *lambda); 
+static TBOOLEAN analyze (double a[], double **alpha, double beta[], 
+			 double *chisq);
+static void calculate (double *zfunc, double **dzda, double a[]);
+static void call_scheme (double *par, double *data);
+
+static TBOOLEAN regress (double a[]);
+//static void show_fit (int i, double chisq, double last_chisq, double *a, 
+//			      double lambda, FILE * device); 
+
+
+/*****************************************************************
+    New utility routine: print a matrix (for debugging the alg.)
+*****************************************************************/
+static void printmatrix(C, m, n)
+double **C;
+int m, n;
+{
+    int i, j;
+
+    for (i = 0; i < m; i++) {
+	for (j = 0; j < n - 1; j++);
+	  /* Dblf2("%.8g |", C[i][j]); */
+	/* Dblf2("%.8g\n", C[i][j]); */
+    }
+    /* Dblf("\n"); */
+}
+
+/**************************************************************************
+    Yet another debugging aid: print matrix, with diff. and residue vector
+**************************************************************************/
+static void print_matrix_and_vectors(C, d, r, m, n)
+double **C;
+double *d, *r;
+int m, n;
+{
+    int i, j;
+
+    for (i = 0; i < m; i++) {
+	for (j = 0; j < n; j++);
+	  /* Dblf2("%8g ", C[i][j]); */
+	  /* Dblf3("| %8g | %8g\n", d[i], r[i]); */
+    }
+    /* Dblf("\n"); */
+}
+
+
+/*****************************************************************
+    Marquardt's nonlinear least squares fit
+*****************************************************************/
+static marq_res_t marquardt(a, C, chisq, lambda)
+double a[];
+double **C;
+double *chisq;
+double *lambda;
+{
+    int i, j;
+    static double *da = 0,	/* delta-step of the parameter */
+    *temp_a = 0,		/* temptative new params set   */
+    *d = 0, *tmp_d = 0, **tmp_C = 0, *residues = 0;
+    double tmp_chisq;
+
+    /* Initialization when lambda == -1 */
+
+    if (*lambda == -1) {	/* Get first chi-square check */
+	TBOOLEAN analyze_ret;
+
+	temp_a = vec(num_params);
+	d = vec(num_data + num_params);
+	tmp_d = vec(num_data + num_params);
+	da = vec(num_params);
+	residues = vec(num_data + num_params);
+	tmp_C = matr(num_data + num_params, num_params);
+
+	analyze_ret = analyze(a, C, d, chisq);
+
+	/* Calculate a useful startup value for lambda, as given by Schwarz */
+	/* FIXME: this is doesn't turn out to be much better, really... */
+	if (startup_lambda != 0)
+	    *lambda = startup_lambda;
+	else {
+	    *lambda = 0;
+	    for (i = 0; i < num_data; i++)
+		for (j = 0; j < num_params; j++)
+		    *lambda += C[i][j] * C[i][j];
+	    *lambda = sqrt(*lambda / num_data / num_params);
+	}
+
+	/* Fill in the lower square part of C (the diagonal is filled in on
+	   each iteration, see below) */
+	for (i = 0; i < num_params; i++)
+	    for (j = 0; j < i; j++)
+		C[num_data + i][j] = 0, C[num_data + j][i] = 0;
+	/* printmatrix(C, num_data+num_params, num_params); */
+	return analyze_ret ? OK : ERROR;
+    }
+    /* once converged, free dynamic allocated vars */
+
+    if (*lambda == -2) {
+	return OK;
+    }
+    /* Givens calculates in-place, so make working copies of C and d */
+
+    for (j = 0; j < num_data + num_params; j++)
+	memcpy(tmp_C[j], C[j], num_params * sizeof(double));
+    memcpy(tmp_d, d, num_data * sizeof(double));
+
+    /* fill in additional parts of tmp_C, tmp_d */
+
+    for (i = 0; i < num_params; i++) {
+	/* fill in low diag. of tmp_C ... */
+	tmp_C[num_data + i][i] = *lambda;
+	/* ... and low part of tmp_d */
+	tmp_d[num_data + i] = 0;
+    }
+    /* printmatrix(tmp_C, num_data+num_params, num_params); */
+
+    /* FIXME: residues[] isn't used at all. Why? Should it be used? */
+
+    Givens(tmp_C, tmp_d, da, residues, num_params + num_data, num_params, 1);
+    /*print_matrix_and_vectors (tmp_C, tmp_d, residues,
+       num_params+num_data, num_params); */
+
+    /* check if trial did ameliorate sum of squares */
+
+    for (j = 0; j < num_params; j++)
+	temp_a[j] = a[j] + da[j];
+
+    if (!analyze(temp_a, tmp_C, tmp_d, &tmp_chisq)) {
+	/* FIXME: will never be reached: always returns TRUE */
+	return ERROR;
+    }
+
+    if (tmp_chisq < *chisq) {	/* Success, accept new solution */
+	if (*lambda > MIN_LAMBDA) {
+	  /* (void) putc('/', stderr); */
+          *lambda /= lambda_down_factor;
+	}
+	*chisq = tmp_chisq;
+	for (j = 0; j < num_data; j++) {
+	    memcpy(C[j], tmp_C[j], num_params * sizeof(double));
+	    d[j] = tmp_d[j];
+	}
+	for (j = 0; j < num_params; j++)
+	    a[j] = temp_a[j];
+	return BETTER;
+    } else {			/* failure, increase lambda and return */
+      /* (void) putc('*', stderr); */
+      *lambda *= lambda_up_factor;
+      return WORSE;
+    }
+}
+
+
+/* FIXME: in the new code, this function doesn't really do enough to be
+ * useful. Maybe it ought to be deleted, i.e. integrated with
+ * calculate() ?
+ */
+/*****************************************************************
+    compute chi-square and numeric derivations
+*****************************************************************/
+static TBOOLEAN analyze(a, C, d, chisq)
+double a[];
+double **C;
+double d[];
+double *chisq;
+{
+/*
+ *  used by marquardt to evaluate the linearized fitting matrix C
+ *  and vector d, fills in only the top part of C and d
+ *  I don't use a temporary array zfunc[] any more. Just use
+ *  d[] instead.
+ */
+    int i, j;
+
+    *chisq = 0;
+    calculate(d, C, a);
+
+    for (i = 0; i < num_data; i++) {
+	/* note: order reversed, as used by Schwarz */
+	d[i] = (d[i] - fit_z[i]) / err_data[i];
+	*chisq += d[i] * d[i];
+	for (j = 0; j < num_params; j++)
+	    C[i][j] /= err_data[i];
+    }
+    /* FIXME: why return a value that is always TRUE ? */
+    return 1;
+}
+
+
+/* To use the more exact, but slower two-side formula, activate the
+   following line: */
+
+#define TWO_SIDE_DIFFERENTIATION 
+
+/*****************************************************************
+    compute function values and partial derivatives of chi-square
+*****************************************************************/
+static void calculate(zfunc, dzda, a)
+double *zfunc;
+double **dzda;
+double a[];
+{
+    int k, p;
+    double tmp_a;
+    double *tmp_high, *tmp_pars;
+#ifdef TWO_SIDE_DIFFERENTIATION
+    double *tmp_low;
+#endif
+
+    tmp_high = vec(num_data);	/* numeric derivations */
+#ifdef TWO_SIDE_DIFFERENTIATION
+    tmp_low = vec(num_data);
+#endif
+    tmp_pars = vec(num_params);
+
+    /* first function values */
+
+    call_scheme(a, zfunc);
+
+    /* then derivatives */
+
+    for (p = 0; p < num_params; p++)
+	tmp_pars[p] = a[p];
+    for (p = 0; p < num_params; p++) {
+	tmp_a = fabs(a[p]) < NEARLY_ZERO ? NEARLY_ZERO : a[p];
+	tmp_pars[p] = tmp_a * (1 + DELTA);
+	call_scheme(tmp_pars, tmp_high);
+#ifdef TWO_SIDE_DIFFERENTIATION
+	tmp_pars[p] = tmp_a * (1 - DELTA);
+	call_scheme(tmp_pars, tmp_low);
+#endif
+	for (k = 0; k < num_data; k++)
+#ifdef TWO_SIDE_DIFFERENTIATION
+	    dzda[k][p] = (tmp_high[k] - tmp_low[k]) / (2 * tmp_a * DELTA);
+#else
+	    dzda[k][p] = (tmp_high[k] - zfunc[k]) / (tmp_a * DELTA);
+#endif
+	tmp_pars[p] = a[p];
+    }
+
+}
+
+
+/*****************************************************************
+    evaluate the scheme function
+*****************************************************************/
+static void call_scheme(par, data)
+double *par;
+double *data;
+{
+  int rators = 2 + num_params;
+  double * rands =
+    (double *) malloc(rators * sizeof(double));
+
+  int i;
+
+  /* set up the constant params */
+  for(i = 0 ; i< num_params; i++) {
+    rands[i+2] = par[i];
+  }
+
+  /* now calculate the function at the existing points */
+  for (i = 0; i < num_data; i++) {
+    rands[0] = fit_x[i];
+    rands[1] = fit_y[i];
+
+    data[i] = ((double (*) (int, double *) )current_fun) // ouch!
+               (rators, rands);
+  }
+
+  free(rands);
+
+}
+
+/* /\***************************************************************** */
+/*     evaluate the scheme function */
+/* *****************************************************************\/ */
+/* static void call_scheme(par, data) */
+/* double *par; */
+/* double *data; */
+/* { */
+/*   int rators = 2 + num_params; */
+/*   Scheme_Object ** rands =  */
+/*     scheme_malloc(rators * sizeof(Scheme_Object)); */
+
+/*   int i; */
+
+/*   /\* set up the constant params *\/ */
+/*   for(i = 0 ; i< num_params; i++) { */
+/*     rands[i+2] = scheme_make_double(par[i]); */
+/*   } */
+
+/*   /\* now calculate the function at the existing points *\/ */
+/*     for (i = 0; i < num_data; i++) { */
+/*       rands[0] = scheme_make_double(fit_x[i]); */
+/*       rands[1] = scheme_make_double(fit_y[i]); */
+
+/*       data[i] = scheme_real_to_double(scheme_apply(current_fun, rators, rands)); */
+/*     } */
+/* } */
+
+/*****************************************************************
+    Frame routine for the marquardt-fit
+*****************************************************************/
+static TBOOLEAN regress(a)
+    double a[];
+{
+  double **covar, *dpar, **C, chisq, last_chisq, lambda;
+  int iter, i, j;
+  marq_res_t res;
+  
+  chisq = last_chisq = INFINITY;
+  C = matr(num_data + num_params, num_params);
+  lambda = -1;          /* use sign as flag */
+  iter = 0;             /* iteration counter  */
+
+  /* Initialize internal variables and 1st chi-square check */
+
+  if ((res = marquardt(a, C, &chisq, &lambda)) == ERROR)
+    return 0; /* an error occurded */
+
+  res = BETTER;
+
+  /* show_fit(iter, chisq, chisq, a, lambda, STANDARD); */
+
+  /* MAIN FIT LOOP: do the regression iteration */
+
+  do {
+    if (res == BETTER) {
+      iter++;
+      last_chisq = chisq;
+    }
+    if ((res = marquardt(a, C, &chisq, &lambda)) == BETTER)
+      {};
+    /* show_fit(iter, chisq, last_chisq, a, lambda, STANDARD); */
+  } while ((res != ERROR)
+	   && (lambda < MAX_LAMBDA)
+	   && ((maxiter == 0) || (iter <= maxiter))
+	   && (res == WORSE
+	       || ((chisq > NEARLY_ZERO)
+		   ? ((last_chisq - chisq) / chisq)
+		   : (last_chisq - chisq)) > epsilon
+	       )
+	   );
+
+    /* fit done */
+
+  /* save all the info that was otherwise printed out */
+
+  rms = sqrt(chisq / (num_data - num_params));
+  varience = chisq / (num_data - num_params);
+  asym_error = malloc (num_params * sizeof (double));  
+  asym_error_percent = malloc (num_params * sizeof (double)) ;
+
+  /* don't know what the following code does... */
+
+  /* compute covar[][] directly from C */ 
+  Givens(C, 0, 0, 0, num_data, num_params, 0); 
+  covar = C + num_data; 
+  Invert_RtR(C, covar, num_params);
+  
+  dpar = vec(num_params); 
+  for (i = 0; i < num_params; i++) {
+    /* FIXME: can this still happen ? */
+      if (covar[i][i] <= 0.0)	/* HBB: prevent floating point exception later on */
+	return 0;  /* Eex("Calculation error: non-positive diagonal element in covar. matrix"); */
+    dpar[i] = sqrt(covar[i][i]);
+  }  
+
+  /* transform covariances into correlations */
+  for (i = 0; i < num_params; i++) {
+    /* only lower triangle needs to be handled */
+      for (j = 0; j <= i; j++)
+      covar[i][j] /= dpar[i] * dpar[j];
+  }
+
+  /* scale parameter errors based on chisq */
+  chisq = sqrt(chisq / (num_data - num_params));
+  for (i = 0; i < num_params; i++)
+    dpar[i] *= chisq;
+
+  for(i = 0; i< num_params; i++)
+    {
+      double temp = 
+	(fabs(a[i]) < NEARLY_ZERO) ? 0.0 : fabs(100.0 * dpar[i] / a[i]);
+      asym_error[i] = dpar[i];
+      asym_error_percent[i] = temp;
+    }
+
+  return 1;
+
+
+    /******** CRAP LEFT OVER FROM GNUPLOT ***********/
+
+    /* HBB 970304: the maxiter patch: */
+    /*
+    if ((maxiter > 0) && (iter > maxiter)) {
+	Dblf2("\nMaximum iteration count (%d) reached. Fit stopped.\n", maxiter);
+    } else  {
+	Dblf2("\nAfter %d iterations the fit converged.\n", iter);
+    }
+
+    Dblf2("final sum of squares of residuals : %g\n", chisq);
+    if (chisq > NEARLY_ZERO) {
+	Dblf2("rel. change during last iteration : %g\n\n", (chisq - last_chisq) / chisq);
+    } else {
+	Dblf2("abs. change during last iteration : %g\n\n", (chisq - last_chisq));
+    }
+
+    if (res == ERROR)
+      // Eex("FIT: error occurred during fit");
+    */
+    /* compute errors in the parameters */
+
+  /*   if (num_data == num_params) { */
+/* 	int i; */
+
+/* 	Dblf("\nExactly as many data points as there are parameters.\n"); */
+/* 	Dblf("In this degenerate case, all errors are zero by definition.\n\n"); */
+/* 	Dblf("Final set of parameters \n"); */
+/* 	Dblf("======================= \n\n"); */
+/* 	for (i = 0; i < num_params; i++) */
+/* 	    Dblf3("%-15.15s = %-15g\n", par_name[i], a[i]); */
+/*     } else if (chisq < NEARLY_ZERO) { */
+/* 	int i; */
+
+/* 	Dblf("\nHmmmm.... Sum of squared residuals is zero. Can't compute errors.\n\n"); */
+/* 	Dblf("Final set of parameters \n"); */
+/* 	Dblf("======================= \n\n"); */
+/* 	for (i = 0; i < num_params; i++) */
+/* 	    Dblf3("%-15.15s = %-15g\n", par_name[i], a[i]); */
+/*     } else { */
+/* 	Dblf2("degrees of freedom (ndf) : %d\n",  num_data - num_params); */
+/* 	Dblf2("rms of residuals      (stdfit) = sqrt(WSSR/ndf)      : %g\n", sqrt(chisq / (num_data - num_params))); */
+/*  	Dblf2("variance of residuals (reduced chisquare) = WSSR/ndf : %g\n\n", chisq / (num_data - num_params)); */
+ 
+/* 	/\* get covariance-, Korrelations- and Kurvature-Matrix *\/ */
+/* 	/\* and errors in the parameters                     *\/ */
+
+/* 	/\* compute covar[][] directly from C *\/ */
+/* 	Givens(C, 0, 0, 0, num_data, num_params, 0); */
+/* 	/\*printmatrix(C, num_params, num_params); *\/ */
+
+/* 	/\* Use lower square of C for covar *\/ */
+/* 	covar = C + num_data; */
+/* 	Invert_RtR(C, covar, num_params); */
+/* 	/\*printmatrix(covar, num_params, num_params); *\/ */
+
+/* 	/\* calculate unscaled parameter errors in dpar[]: *\/ */
+/* 	dpar = vec(num_params); */
+/* 	for (i = 0; i < num_params; i++) { */
+/* 	    /\* FIXME: can this still happen ? *\/ */
+/* 	    if (covar[i][i] <= 0.0)	/\* HBB: prevent floating point exception later on *\/ */
+/* 		Eex("Calculation error: non-positive diagonal element in covar. matrix"); */
+/* 	    dpar[i] = sqrt(covar[i][i]); */
+/* 	} */
+
+/* 	/\* transform covariances into correlations *\/ */
+/* 	for (i = 0; i < num_params; i++) { */
+/* 	    /\* only lower triangle needs to be handled *\/ */
+/* 	    for (j = 0; j <= i; j++) */
+/* 		covar[i][j] /= dpar[i] * dpar[j]; */
+/* 	} */
+
+/* 	/\* scale parameter errors based on chisq *\/ */
+/* 	chisq = sqrt(chisq / (num_data - num_params)); */
+/* 	for (i = 0; i < num_params; i++) */
+/* 	    dpar[i] *= chisq; */
+
+/* 	Dblf("Final set of parameters            Asymptotic Standard Error\n"); */
+/* 	Dblf("=======================            ==========================\n\n"); */
+
+/* 	for (i = 0; i < num_params; i++) { */
+/* 	    double temp = */
+/* 	    (fabs(a[i]) < NEARLY_ZERO) ? 0.0 : fabs(100.0 * dpar[i] / a[i]); */
+/* 	    Dblf6("%-15.15s = %-15g  %-3.3s %-12.4g (%.4g%%)\n", */
+/* 		  par_name[i], a[i], PLUSMINUS, dpar[i], temp); */
+/* 	} */
+
+/* 	Dblf("\n\ncorrelation matrix of the fit parameters:\n\n"); */
+/* 	Dblf("               "); */
+
+/* 	for (j = 0; j < num_params; j++) */
+/* 	    Dblf2("%-6.6s ", par_name[j]); */
+
+/* 	Dblf("\n"); */
+/* 	for (i = 0; i < num_params; i++) { */
+/* 	    Dblf2("%-15.15s", par_name[i]); */
+/* 	    for (j = 0; j <= i; j++) { */
+/* 		/\* Only print lower triangle of symmetric matrix *\/ */
+/* 		Dblf2("%6.3f ", covar[i][j]); */
+/* 	    } */
+/* 	    Dblf("\n"); */
+/* 	} */
+
+/* 	free(dpar); */
+/*     } */
+
+    return 1;
+}
+
+
+/*****************************************************************
+    display actual state of the fit
+*****************************************************************/
+/* static void show_fit(i, chisq, last_chisq, a, lambda, device) */
+/* int i; */
+/* double chisq; */
+/* double last_chisq; */
+/* double *a; */
+/* double lambda; */
+/* FILE *device; */
+//{
+  /*
+    int k;
+
+    fprintf(device, "\n\n\
+Iteration %d\n\
+WSSR        : %-15g   delta(WSSR)/WSSR   : %g\n\
+delta(WSSR) : %-15g   limit for stopping : %g\n\
+lambda	  : %g\n\n%s parameter values\n\n",
+      i, chisq, chisq > NEARLY_ZERO ? (chisq - last_chisq) / chisq : 0.0,
+	    chisq - last_chisq, epsilon, lambda,
+	    (i > 0 ? "resultant" : "initial set of free"));
+    for (k = 0; k < num_params; k++)
+	fprintf(device, "%-15.15s = %g\n", par_name[k], a[k]);
+  */
+//}
+
+
+
+
+
+
+/*****************************************************************
+    Interface to scheme
+*****************************************************************/
+MZ_DLLEXPORT
+double * do_fit(void * function,
+		int n_values,
+		double * x_values,
+		double * y_values,
+		double * z_values,
+		double * errors,
+		int n_parameters,
+		double * parameters) {
+
+  /* reset lambda and other parameters if desired */
+  int i;
+  current_fun = function;
+
+  num_data = n_values;
+  fit_x = x_values;
+  fit_y = y_values;
+  fit_z = z_values; /* value is stored in z */
+  err_data = errors;
+
+  a = parameters;
+  num_params = n_parameters;
+
+  /* redim_vec(&a, num_params); */
+  /* par_name = (fixstr *) gp_realloc(par_name, (num_params + 1) * sizeof(fixstr), "fit param"); */
+
+  /* avoid parameters being equal to zero */
+  for (i = 0; i < num_params; i++) {
+    if (a[i] == 0) {
+      a[i] = NEARLY_ZERO; 
+    }
+  }
+  
+  if(regress(a)) {
+    gc_cleanup();
+    return a;
+  }
+  else { /* something went wrong */
+    gc_cleanup(); 
+    return NULL;
+  }
+}
diff --git a/collects/plot/src/fit/fit.h b/collects/plot/src/fit/fit.h
new file mode 100644
index 0000000000..594084c9ac
--- /dev/null
+++ b/collects/plot/src/fit/fit.h
@@ -0,0 +1,56 @@
+/* $Id: fit.h,v 1.5 2005/03/15 23:19:40 eli Exp $ */
+
+/* GNUPLOT - fit.h */
+
+/*  NOTICE: Change of Copyright Status
+ *
+ *  The author of this module, Carsten Grammes, has expressed in
+ *  personal email that he has no more interest in this code, and
+ *  doesn't claim any copyright. He has agreed to put this module
+ *  into the public domain.
+ *
+ *  Lars Hecking  15-02-1999
+ */
+
+/*
+ *	Header file: public functions in fit.c
+ *
+ *
+ *	Copyright of this module:   Carsten Grammes, 1993
+ *      Experimental Physics, University of Saarbruecken, Germany
+ *
+ *	Internet address: cagr@rz.uni-sb.de
+ *
+ *	Permission to use, copy, and distribute this software and its
+ *	documentation for any purpose with or without fee is hereby granted,
+ *	provided that the above copyright notice appear in all copies and
+ *	that both that copyright notice and this permission notice appear
+ *	in supporting documentation.
+ *
+ *      This software is provided "as is" without express or implied warranty.
+ */
+
+#include <scheme.h>
+
+MZ_DLLEXPORT
+double * do_fit(void * function,
+		int n_values,
+		double * x_values,
+		double * y_values,
+		double * z_values,
+		double * errors,
+		int n_parameters,
+		double * parameters);
+
+
+MZ_DLLEXPORT
+double get_rms();
+
+MZ_DLLEXPORT
+double get_varience();
+
+MZ_DLLEXPORT
+double * get_asym_error();
+
+MZ_DLLEXPORT
+double * get_asym_error_percent();
diff --git a/collects/plot/src/fit/matrix.c b/collects/plot/src/fit/matrix.c
new file mode 100644
index 0000000000..0977376132
--- /dev/null
+++ b/collects/plot/src/fit/matrix.c
@@ -0,0 +1,318 @@
+#ifndef lint
+static char *RCSid = "$Id: matrix.c,v 1.4 2005/03/15 23:21:26 eli Exp $";
+#endif
+
+/*  NOTICE: Change of Copyright Status
+ *
+ *  The author of this module, Carsten Grammes, has expressed in
+ *  personal email that he has no more interest in this code, and
+ *  doesn't claim any copyright. He has agreed to put this module
+ *  into the public domain.
+ *
+ *  Lars Hecking  15-02-1999
+ */
+
+/*
+ *	Matrix algebra, part of
+ *
+ *	Nonlinear least squares fit according to the
+ *	Marquardt-Levenberg-algorithm
+ *
+ *	added as Patch to Gnuplot (v3.2 and higher)
+ *	by Carsten Grammes
+ *	Experimental Physics, University of Saarbruecken, Germany
+ *
+ *	Internet address: cagr@rz.uni-sb.de
+ *
+ *	Copyright of this module:   Carsten Grammes, 1993
+ *
+ *	Permission to use, copy, and distribute this software and its
+ *	documentation for any purpose with or without fee is hereby granted,
+ *	provided that the above copyright notice appear in all copies and
+ *	that both that copyright notice and this permission notice appear
+ *	in supporting documentation.
+ *
+ *	This software is provided "as is" without express or implied warranty.
+ */
+
+#define NULL 0
+#define null 0
+
+#include "fit.h"
+#include "matrix.h"
+
+
+// create a simple gc malloc...
+typedef struct {
+  struct Node * next;
+  void * ptr;
+} Node;
+
+Node * head = null;
+
+void * my_gc_malloc(int size) {
+  void * ptr = malloc(size);
+  Node * n = (Node *)malloc(sizeof (Node));
+  n->ptr = ptr;
+  n->next = head;
+  head = n;
+  return ptr;
+}
+
+void gc_cleanup(){
+  while(head) {
+    Node * current = head;
+    head = current->next;
+    free(current->ptr);
+    free(current);
+  }
+}
+
+
+
+/*****************************************************************/
+
+#define Swap(a,b)   {double temp = (a); (a) = (b); (b) = temp;}
+#define WINZIG	      1e-30
+
+
+/*****************************************************************
+    internal prototypes
+*****************************************************************/
+
+static int fsign (double x);
+
+/*****************************************************************
+    first straightforward vector and matrix allocation functions
+*****************************************************************/
+MZ_DLLEXPORT
+double *vec (n)
+int n;
+{
+    /* allocates a double vector with n elements */
+    double *dp;
+    if( n < 1 )
+	return (double *) NULL;
+    dp = (double *) my_gc_malloc (n * sizeof(double));
+    return dp;
+}
+
+
+MZ_DLLEXPORT
+double **matr (rows, cols)
+int rows;
+int cols;
+{
+    /* allocates a double matrix */
+
+    register int i;
+    register double **m;
+
+    if ( rows < 1  ||  cols < 1 )
+        return NULL;
+    m = (double **) my_gc_malloc (rows * sizeof(double *));
+    m[0] = (double *) my_gc_malloc (rows * cols * sizeof(double));
+    for ( i = 1; i<rows ; i++ )
+    	m[i] = m[i-1] + cols;
+    return m;
+}
+
+
+void free_matr (m)
+double **m;
+{
+    free (m[0]);
+    free (m);
+}
+
+
+MZ_DLLEXPORT
+double *redim_vec (v, n)
+double **v;
+int n;
+{
+    if ( n < 1 ) 
+      *v = NULL;
+    else       
+      *v = (double *) my_gc_malloc( n * sizeof(double));
+    return *v;
+}
+
+MZ_DLLEXPORT
+void redim_ivec (v, n)
+int **v;
+int n;
+{
+    if ( n < 1 ) {
+	*v = NULL;
+	return;
+    }
+    *v = (int *) my_gc_malloc ( n * sizeof(int));
+}
+
+
+/* HBB: TODO: is there a better value for 'epsilon'? how to specify
+ * 'inline'?  is 'fsign' really not available elsewhere? use
+ * row-oriented version (p. 309) instead?
+ */
+
+static int fsign(x)
+  double x;
+{
+    return( x>0 ? 1 : (x < 0) ? -1 : 0) ;
+}
+
+/*****************************************************************
+
+     Solve least squares Problem C*x+d = r, |r| = min!, by Given rotations
+     (QR-decomposition). Direct implementation of the algorithm
+     presented in H.R.Schwarz: Numerische Mathematik, 'equation'
+     number (7.33)
+
+     If 'd == NULL', d is not accesed: the routine just computes the QR
+     decomposition of C and exits.
+
+     If 'want_r == 0', r is not rotated back (\hat{r} is returned
+     instead).
+
+*****************************************************************/
+
+MZ_DLLEXPORT
+void Givens (C, d, x, r, N, n, want_r)
+double **C;
+double *d;
+double *x;
+double *r;
+int N;
+int n;
+int want_r;
+{
+    int i, j, k;
+    double w, gamma, sigma, rho, temp;
+    double epsilon = 1e-5; /* FIXME (?)*/
+
+/* 
+ * First, construct QR decomposition of C, by 'rotating away'
+ * all elements of C below the diagonal. The rotations are
+ * stored in place as Givens coefficients rho.
+ * Vector d is also rotated in this same turn, if it exists 
+ */
+    for (j = 0; j<n; j++) 
+    	for (i = j+1; i<N; i++) 
+    	    if (C[i][j]) {
+    	    	if (fabs(C[j][j])<epsilon*fabs(C[i][j])) { /* find the rotation parameters */
+    	    	    w = -C[i][j];
+    	    	    gamma = 0;
+    	    	    sigma = 1;
+    	    	    rho = 1;
+		} else {
+		    w = fsign(C[j][j])*sqrt(C[j][j]*C[j][j] + C[i][j]*C[i][j]);
+		    if (w == 0) {
+		      //			Eex3 ( "w = 0 in Givens();  Cjj = %g,  Cij = %g", C[j][j], C[i][j]);
+		    }
+		    gamma = C[j][j]/w;
+		    sigma = -C[i][j]/w;
+		    rho = (fabs(sigma)<gamma) ? sigma : fsign(sigma)/gamma;
+		}
+		C[j][j] = w;
+		C[i][j] = rho;           /* store rho in place, for later use */
+		for (k = j+1; k<n; k++) {   /* rotation on index pair (i,j) */
+		    temp =    gamma*C[j][k] - sigma*C[i][k];
+		    C[i][k] = sigma*C[j][k] + gamma*C[i][k];
+		    C[j][k] = temp;
+		    
+		}
+		if (d) {               /* if no d vector given, don't use it */
+		    temp = gamma*d[j] - sigma*d[i];  /* rotate d */
+		    d[i] = sigma*d[j] + gamma*d[i];
+		    d[j] = temp;
+	        }
+	    }
+    if (!d)               /* stop here if no d was specified */
+         return;
+
+    for (i = n-1; i >= 0; i--) {   /* solve R*x+d = 0, by backsubstitution */
+        double s = d[i];
+        r[i] = 0;              /* ... and also set r[i] = 0 for i<n */
+        for (k = i+1; k<n; k++) 
+            s += C[i][k]*x[k];
+	if (C[i][i] == 0) {
+	  //Eex ( "Singular matrix in Givens()");
+	}
+        x[i] = - s / C[i][i];
+	}
+    for (i = n; i < N; i++) 
+    	r[i] = d[i];	     	/* set the other r[i] to d[i] */
+    	
+    if (!want_r)        	/* if r isn't needed, stop here */
+    	return;
+    	
+    /* rotate back the r vector */
+    for (j = n-1; j >= 0; j--)
+    	for (i = N-1; i >= 0; i--) {
+    	    if ((rho = C[i][j]) == 1) { /* reconstruct gamma, sigma from stored rho */
+    	     	gamma = 0;
+    	     	sigma = 1;
+    	    } else if (fabs(rho)<1) {
+    	    	sigma = rho; 
+    	    	gamma = sqrt(1-sigma*sigma);
+    	    } else {
+    	    	gamma = 1/fabs(rho);
+    	    	sigma = fsign(rho)*sqrt(1-gamma*gamma);
+    	    }
+	    temp = gamma*r[j] + sigma*r[i];	/* rotate back indices (i,j) */
+	    r[i] = -sigma*r[j] + gamma*r[i];
+	    r[j] = temp;
+    }
+}
+
+
+/* Given a triangular Matrix R, compute (R^T * R)^(-1), by forward
+ * then back substitution
+ * 
+ * R, I are n x n Matrices, I is for the result. Both must already be
+ * allocated.
+ * 
+ * Will only calculate the lower triangle of I, as it is symmetric 
+ */
+
+MZ_DLLEXPORT
+void Invert_RtR ( R, I, n)
+double **R;
+double **I;
+int n;
+{
+  int i, j, k;
+
+  /* fill in the I matrix, and check R for regularity : */
+
+  for (i = 0; i<n; i++) {
+    for (j = 0; j<i; j++)  /* upper triangle isn't needed */
+      I[i][j] = 0;
+    I[i][i] = 1;
+    if (! R[i][i])
+      {
+      //      Eex ("Singular matrix in Invert_RtR");
+      }
+      }
+  
+  /* Forward substitution: Solve R^T * B = I, store B in place of I */
+  
+  for (k = 0; k<n; k++) 
+    for (i = k; i<n; i++) {  /* upper half needn't be computed */
+      double s = I[i][k];
+      for (j = k; j<i; j++)  /* for j<k, I[j][k] always stays zero! */
+	s -= R[j][i] * I[j][k];
+      I[i][k] = s / R[i][i];
+    }
+
+  /* Backward substitution: Solve R * A = B, store A in place of B */
+
+  for (k = 0; k<n; k++)
+    for (i = n-1; i >= k; i--) {  /* don't compute upper triangle of A */
+      double s = I[i][k];
+      for (j = i+1; j<n; j++)
+	s -= R[i][j] * I[j][k];
+      I[i][k] = s / R[i][i]; 
+    }
+}
diff --git a/collects/plot/src/fit/matrix.h b/collects/plot/src/fit/matrix.h
new file mode 100644
index 0000000000..415703aa5e
--- /dev/null
+++ b/collects/plot/src/fit/matrix.h
@@ -0,0 +1,75 @@
+/* $Id: matrix.h,v 1.5 2005/03/15 23:23:56 eli Exp $ */
+
+/* GNUPLOT - matrix.h */
+
+/*  NOTICE: Change of Copyright Status
+ *
+ *  The author of this module, Carsten Grammes, has expressed in
+ *  personal email that he has no more interest in this code, and
+ *  doesn't claim any copyright. He has agreed to put this module
+ *  into the public domain.
+ *
+ *  Lars Hecking  15-02-1999
+ */
+
+/*
+ *	Header file: public functions in matrix.c
+ *
+ *
+ *	Copyright of this module:   Carsten Grammes, 1993
+ *      Experimental Physics, University of Saarbruecken, Germany
+ *
+ *	Internet address: cagr@rz.uni-sb.de
+ *
+ *	Permission to use, copy, and distribute this software and its
+ *	documentation for any purpose with or without fee is hereby granted,
+ *	provided that the above copyright notice appear in all copies and
+ *	that both that copyright notice and this permission notice appear
+ *	in supporting documentation.
+ *
+ *      This software is provided "as is" without express or implied warranty.
+ */
+
+
+#ifndef MATRIX_H
+#define MATRIX_H
+
+#include <scheme.h>
+
+
+#ifdef EXT
+#undef EXT
+#endif
+
+#ifdef MATRIX_MAIN
+#define EXT
+#else
+#define EXT extern
+#endif
+
+
+/******* public functions ******/
+
+MZ_DLLEXPORT
+EXT double  *vec (int n);
+MZ_DLLEXPORT
+EXT int     *ivec (int n);
+MZ_DLLEXPORT
+EXT double  **matr (int r, int c);
+MZ_DLLEXPORT
+EXT double  *redim_vec (double **v, int n);
+MZ_DLLEXPORT
+EXT void    redim_ivec (int **v, int n);
+EXT void    solve (double **a, int n, double **b, int m);
+MZ_DLLEXPORT
+EXT void    Givens (double **C, double *d, double *x, double *r, int N, int n, int want_r); 
+MZ_DLLEXPORT
+EXT void    Invert_RtR (double **R, double **I, int n);
+
+#endif
+
+// a kludgy version of a malloc
+
+void * my_gc_malloc(int size);
+void gc_cleanup();
+
diff --git a/collects/plot/view.ss b/collects/plot/view.ss
new file mode 100644
index 0000000000..7a3518cc0d
--- /dev/null
+++ b/collects/plot/view.ss
@@ -0,0 +1,335 @@
+(module view mzscheme
+  (require 
+   (lib "plplot.ss" "plot")
+   (lib "math.ss" "plot")
+   (lib "class.ss")
+   (lib "file.ss")
+   (lib "mred.ss" "mred")
+   (lib "math.ss")
+   ;(lib "4.ss" "srfi")
+   )
+  
+  
+  ; macro for creating a field in a class with a getter and a setter
+  (define-syntax (fields-with-accessors stx) 
+    (define (join-identifier prefix ident)
+      (datum->syntax-object 
+       ident 
+       (string->symbol (string-append (symbol->string prefix )(symbol->string (syntax-e ident)))) ))
+    (syntax-case stx ()
+      [(_ (field init) ... )
+       (let ((accessors (map (lambda (id) (join-identifier 'get- id)) (syntax-e #'(field ...))))
+             (setters (map (lambda (id) (join-identifier 'set- id)) (syntax-e #'(field ...)))))
+         (with-syntax (((accessor ... ) accessors)
+                       ((setter ...) setters))
+           #'(fields-with-accessors-helper (accessor setter field init) ...)))]))
+  
+  ; for accessors
+  (define-syntax fields-with-accessors-helper
+    (syntax-rules ()
+      [(_ (accessor setter field init) ...)
+       (begin 
+         (init-field (field init)) ...
+         (define (accessor) field) ...
+         (define (setter val) (set! field val)) ...) ]))
+  
+
+  ; base class for a plot view
+  ; 
+  (define plot-view%
+    (class* image-snip% ()
+      (public 
+        set-line-color
+        set-line-width                       
+        set-plot-environment
+        reset-to-default
+        get-x-min
+        get-x-max
+        get-y-min
+        get-y-max
+        
+        get-x-label
+        get-y-label
+        get-title 
+        start-plot 
+        finish-plot
+        
+        get-renderer
+        
+        get-height
+        get-width)
+      
+      (init-field
+       renderer)
+      
+      (fields-with-accessors
+       (height 300)
+       (width 400)
+       (x-min -5)
+       (x-max 5)
+       (y-min -5)
+       (y-max 5)
+       (x-label "X axis")
+       (y-label "Y axis")
+       (title "")
+       (device 'png)
+       (fgcolor '( 0 0 0))
+       (bgcolor '(255 255 255))
+       (lncolor '(255 0 0 ))
+       )   
+     
+      (define bitmap #f)
+      (define x-size 400)
+      (define y-size 300)
+     
+      (inherit 
+        set-bitmap
+        load-file)
+      
+      (define (get-renderer) renderer)
+      
+      ; set the initial environment 
+      (define (set-plot-environment x-min x-max y-min y-max just other)
+        (pl-set-plot-environment x-min x-max y-min y-max just other))
+      
+      ; changes the *initial* colormap to match the colors
+      ; this should probably be done dynamically
+      (define (init-colors)
+        (apply pl-set-colormap0-index 0 bgcolor) ; 0 to white
+        (apply pl-set-colormap0-index 1 fgcolor) ; 1 to black
+        (apply pl-set-colormap0-index 15 lncolor)) ; 15 to red
+      
+      ; these are the colors to whitch the plot will be initialzed
+      (define colors '((white 0) (black 1) (yellow 2) (green 3) 
+                       (aqua 4) (pink 5) (wheat 6) (grey 7) 
+                       (brown 8) (blue 9) (violet 10) (cyan 11)
+                       (turquoise 12) (magenta 13) (salmon 14) (red 15)))
+      
+      ; set-line-width : number -> nothing
+      (define (set-line-width width) (pl-set-line-width width))
+      
+      ; reset-to-default : void
+      ; resets some of the state to default
+      (define (reset-to-default) 
+        (init-colors)
+        (set-line-color 'black)
+        (set-line-width 0))
+                                        
+      ;set-line-color : symbol -> nothing
+      (define (set-line-color color)
+        (let ((index (cond [(assq color colors ) => cadr]
+                           [else (error (string-append "color \"" color "\" not found"))])))
+          (pl-select-colormap0-index index)))
+      
+      ; start the plot
+      ; does housekeeping/setup for plplot
+      (define (start-plot)
+        (cond
+          [(eq? device 'png)
+           (set! bitmap (make-temporary-file))
+           (init-colors)
+           (pl-setup-page  width height)
+           (pl-set-device "png")
+           (pl-set-output-file (path->string bitmap))
+           (pl-init-plot)]
+;          [(eq? device 'mem)
+;           (init-colors)
+;           (set! bitmap (make-u8vector (* x-size y-size 4) 255))
+;           (pl-setup-memory x-size y-size bitmap)
+;           (pl-set-device "mem")
+;           (pl-init-plot)]
+          [else
+           (error "Incorrect device specified")]))
+
+      ; finish the plot.. loads the file
+      (define (finish-plot)
+        (cond
+          [(eq? device 'png)
+           (pl-finish-plot)
+           (load-file bitmap)
+           (delete-file bitmap)]
+;          [(eq? device 'mem)
+;           (pl-finish-plot)
+;           (set-bitmap (bits->bitmap-dc% bitmap))]
+          [else
+           (error "Incorrect device specified")]))
+      
+      ;(define (bits->bitmap-dc% bitmap)
+      ;  (let ((bmdc (instantiate bitmap-dc% () (bitmap (make-object bitmap% x-size y-size #f))))
+      ;        (result-string (u8vec->scheme-string bitmap)))
+      ;    (send bmdc set-argb-pixels 0 0  x-size y-size result-string)
+      ;    (begin0
+      ;      (send bmdc get-bitmap)
+      ;      (send bmdc set-bitmap #f))))
+           
+      (super-instantiate ())))
+        
+  ;; a 2d plot view
+  (define 2d-view% 
+    (class* plot-view% ()
+      (public 
+        set-labels 
+        plot-y-errors
+        plot-vector
+        plot-vectors      
+        plot-points
+        plot-line
+        plot-contours
+        plot-shades
+        fill
+                )
+      
+      ; set-labels : string string string -> nothing
+      ; sets the x, y and title lables
+      (define (set-labels x-label y-label title)
+        (pl-set-labels x-label y-label title))
+
+      ; plot-contours: listoflistof number, listof-number, listof-number, listof-number
+      (define (plot-contours z x-vals y-vals levels)
+        (pl-2d-contour-plot z x-vals y-vals levels))
+      
+      ; plot-shades: listoflistof number, listof-number, listof-number, listof-number
+      (define (plot-shades z x-vals y-vals levels)
+        (pl-2d-shade-plot z x-vals y-vals levels))
+  
+      ; plot-line : (listof vector) -> void
+      ; plots a line with the given points
+      (define (plot-line points)        
+        (pl-plot-line (length points) 
+                      (map vector-x points)
+                      (map vector-y points)))
+      
+      ; plot-points : (listof vector) -> void
+      ; plots given points with a . symbol
+      (define (plot-points points sym)
+        (pl-plot-points (length points) 
+                        (map vector-x points)
+                        (map vector-y points)
+                        sym))
+
+      (define v-head-ratio 1/4) ; size of the vector head
+      (define rot (* 5 pi 1/6))
+      
+      ; plot-vectors: (listof (list vector vector)) - > void
+      (define (plot-vectors from delta)
+        (for-each (lambda (f d) (send this plot-vector f d)) from delta))
+      
+      ; plot-vector : vector vector -> nothing
+      (define (plot-vector from delta)
+        (unless (= 0 (vector-magnitude delta))
+          (let* ((x (vector-x from)) (x2 (+ x (vector-x delta)))
+                 (y (vector-y from)) (y2 (+ y (vector-y delta)))
+                 (ang (atan  (vector-y delta) (vector-x delta)))
+                 (len (vector-magnitude delta))
+                 (x3 (+ x2 (* len v-head-ratio (cos (+ ang rot))))) 
+                 (x4 (+ x2 (* len v-head-ratio (cos (- ang rot)))))
+                 (y3 (+ y2 (* len v-head-ratio (sin (+ ang rot))))) 
+                 (y4 (+ y2 (* len v-head-ratio (sin (- ang rot))))))         
+            (plot-line (list from 
+                             (vector x2 y2) 
+                             (vector x3 y3) 
+                             (vector x4 y4) 
+                             (vector x2 y2))))))
+      
+      ; fill : (list-of number) (list-of number) -> void
+      (define (fill xs ys)
+        (pl-fill (length xs) xs ys))
+      
+      ; plot-y-errors (listof (vector x y-min y-max)) ->nothing
+      ; plots y error bars given a vector containing the x y and z (error magnitude) points
+      (define (plot-y-errors errlist)
+        (pl-y-error-bars (length errlist) (map vector-x errlist) (map vector-y errlist) (map vector-z errlist)))
+      
+      
+      
+      (inherit start-plot set-plot-environment finish-plot 
+               get-x-min get-x-max get-y-min get-y-max get-renderer 
+               get-x-label get-y-label get-title)
+      (define (plot)
+        (start-plot)
+        (set-plot-environment (get-x-min) (get-x-max) (get-y-min) (get-y-max) 0 1)
+        (set-labels (get-x-label) (get-y-label) (get-title))
+        (with-handlers ((exn? (lambda (ex) (finish-plot) (raise ex))))
+          ((get-renderer) this))
+        (finish-plot)
+        this)
+
+      (super-instantiate ())
+      (plot)))
+  
+  ; 3d view
+  ; for making meshes and stuff
+  
+  (define 3d-view%
+    (class* plot-view% ()
+      (public         
+        plot-polygon        
+        plot-line
+        plot-surface
+        plot-3dmesh
+        get-z-min
+        get-z-max
+        get-alt
+        get-az)
+      
+      
+      (fields-with-accessors      
+       (z-min -5) 
+       (z-max 5) 
+       (alt 30) 
+       (az 45)
+       (z-label "Z-Axis"))
+      
+      ; define the 3d world
+      (define (world3d x y z xmin xmax ymin ymax zmin zmax alt az)
+        (pl-world-3d x y z xmin xmax ymin ymax zmin zmax alt az))
+      
+      ; set up the axies box
+      (define (box3d 
+               xopts xlabel xticks nxsub
+               yopts ylabel yticks nysub
+               zopts zlabel zticks nzsub)
+        (pl-box3 xopts xlabel xticks nxsub
+                 yopts ylabel yticks nysub
+                 zopts zlabel zticks nzsub))
+      
+      ; draw a simple 3d surface plot
+      (define (plot-surface x y z)
+        (pl-plot3d x y z))
+      
+      ; plot-3dmesh
+      (define (plot-3dmesh x y z lines? colored? contours? sides? levels)
+        (pl-mesh3dc x y z lines? colored? contours? sides? levels))
+      
+      (inherit start-plot set-plot-environment finish-plot get-x-min 
+               get-x-max get-y-min get-y-max get-renderer get-x-label get-y-label)
+      (define (plot)
+        (start-plot)
+        (set-plot-environment -1 1 -1 1 0 -2)
+        (world3d 1 1 1 (get-x-min) (get-x-max) (get-y-min) (get-y-max) z-min z-max alt az)
+        (box3d 
+         "bnstu" (get-x-label) 0 0
+         "bnstu" (get-y-label) 0 0
+         "bnstu" z-label 0 0)
+        (with-handlers ((exn? (lambda (ex) (finish-plot) (raise ex))))
+          ((get-renderer) this))
+        (finish-plot)
+        this)
+      
+      ; plot a polygon in 3 space
+      (define (plot-polygon x y z draw ifc)
+        (pl-poly3  x y z draw ifc))
+      
+      
+      ; plot a line in 3 space
+      ; x y and z are lists of equal length
+      (define (plot-line x y z)
+        (pl-line3 x y z))
+      
+      
+      (super-instantiate ())
+      (plot)))
+ 
+  (provide
+   2d-view%
+   3d-view%))
diff --git a/collects/preprocessor/doc.txt b/collects/preprocessor/doc.txt
new file mode 100644
index 0000000000..5c80185263
--- /dev/null
+++ b/collects/preprocessor/doc.txt
@@ -0,0 +1,700 @@
+========================================================================
+                             _preprocessor_
+========================================================================
+
+The "preprocessor" collection defines two MzScheme-based preprocessors
+for texts that can have embedded Scheme code.  The two processors share
+a few features, like several command-line flags and the fact that
+embedded Scheme code is case-sensitive by default.
+
+Note that these processors are *not* intended as preprocessors for
+Scheme code -- you have macros to do that.
+
+The preprocessors can be invoked from Scheme programs, but the main
+usage should be through the launchers.  Both launchers use code from
+_pp-run.ss_ that allows a special invocation mode through the `--run'
+flag.
+
+The _--run_ is a convenient way of making the preprocessors cooperate
+with some other command, making it possible to use preprocessed text
+without an additional glue script or a makefile.  The following examples
+use `mzpp', but they work with `mztext' too.  `--run' uses a single
+argument which is a string specifying a command to run:
+
+1. In its simplest form, the command string specifies some shell command
+   which will be executed with its standard input piped in from the
+   preprocessor's output.  For example, "mzpp --run pr foo" is the same
+   as "mzpp foo | pr".  An error is raised if an output file is
+   specified with such an argument.
+
+2. If the command string contains a "*" and an output file is specified,
+   then the command will be executed on this output file after it is
+   generated.  For example, "mzpp --run 'pr *' -o foo x y z" is the same
+   as "mzpp -o foo x y z; pr foo".
+
+3. If the command string contains a "*", and no output file is
+   specified, and there is exactly one input file, then a temporary file
+   will be used to save the original while the command is running.  For
+   example, "mzpp --run 'pr *' foo" is the same as "mv foo
+   foo-mzpp-temporary; mzpp -o foo foo-mzpp-temporary; pr foo; rm foo;
+   mv foo-mzpp-temporary foo".  If there is an error while mzpp is
+   running, the working file will be erased and the original will be
+   renamed back.
+
+4. Any other cases where the command string contains a "*" are invalid.
+
+If an executed command fails with a return status different than 0, the
+preprocessor execution will signal a failure by returning 1.
+
+
+========================================================================
+                                 _mzpp_
+========================================================================
+
+`mzpp' is a simple preprocessor that allows mixing Scheme code with text
+files in a similar way to PHP or BRL.  Processing of input files works
+by translating the input file to Scheme code that prints the contents,
+except for marked portions that contain Scheme code.  The Scheme parts
+of a file are marked with "<<" and ">>" tokens by default.  The Scheme
+code is then passed through a read-eval-print loop that is similar to a
+normal REPL with a few differences in how values are printed.
+
+Invoking mzpp
+-------------
+
+Use the `-h' flag to get the available flags.  SEE above for an
+explanation of the `--run' flag.
+
+mzpp files
+----------
+
+Here is a sample file that mzpp can process, using the default beginning
+and ending markers:
+
+  |<< (define bar "BAR") >>
+  |foo1
+  |foo2 << bar newline* bar >> baz
+  |foo3
+
+First, this file is converted to the following Scheme code:
+
+  |(thunk (cd "tmp/") (current-file "foo"))
+  |(thunk (push-indentation ""))
+  | (define bar "BAR") (thunk (pop-indentation))
+  |newline*
+  |"foo1"
+  |newline*
+  |"foo2 "
+  |(thunk (push-indentation "     "))
+  | bar newline* bar (thunk (pop-indentation))
+  |" baz"
+  |newline*
+  |"foo3"
+  |newline*
+  |(thunk (cd "/home/eli") (current-file #f))
+
+which is then fed to the REPL, resulting in the following output:
+
+  |foo1
+  |foo2 BAR
+  |     BAR baz
+  |foo3
+
+To see the processed input that the REPL receives, use the `--debug'
+flag.  Note that the processed code contains expressions that have no
+side-effects, only values -- see below for an explanation of the REPL
+printing behavior.  Some expressions produce values that change the REPL
+environment, for example, the indentation commands are used to keep
+track of the column where the Scheme marker was found, and `cd' is used
+to switch to the directory where the file is (here it was in
+"/home/foo/tmp") so including a relative file works.  Also, note that
+the first `newline*' did not generate a newline, and that the one in the
+embedded Scheme code added the appropriate spaces for indentation.
+
+It is possible to temporarily switch from Scheme to text-mode and back
+in a way that does not respect a complete Scheme expression, but you
+should be aware that text is converted to a *sequence* of side-effect
+free expressions (not to a single string, and not expression that uses
+side effects).  For example:
+
+  |<< (if (zero? (random 2))
+  |     (list >>foo1<<)
+  |     (list >>foo2<<))
+  |>>
+  |<< (if (zero? (random 2)) (list >>
+  |foo1
+  |<<) (list >>
+  |foo2
+  |<<)) >>
+
+will print two lines, each containing "foo1" or "foo2" (the first
+approach plays better with the smart space handling).  `show' can be
+used instead of `list' with the same results since it will print out the
+values in the same way the REPL does.  The conversion process does not
+transform every continuous piece of text into a single Scheme string
+because doing this:
+
+* the Scheme process will need to allocating big strings which makes
+  this unfeasible for big files,
+
+* it will not play well with "interactive" input feeding, for example,
+  piping in the output of some process will show results only on Scheme
+  marker boundaries,
+
+* special treatment for newlines in these strings will become expensive.
+
+(Note that this is different from the BRL approach.)
+
+Raw preprocessing directives
+----------------------------
+
+Some preprocessing directives happen at the "raw level" -- the stage
+where text is transformed into Scheme expressions.  These directives
+cannot be changed from withing transformed text because they change the
+way this transformation happens.  Some of these transformation
+
+* Skipping input:
+
+  First, the processing can be modified by specifying a `skip-to' string
+  that disables any output until a certain line is seen.  This is useful
+  for script files that use themselves for input.  For example, the
+  following script:
+
+    |#!/bin/sh
+    |echo shell output
+    |exec mzpp -s "---TEXT-START---" "$0"
+    |exit 1
+    |---TEXT-START---
+    |Some preprocessed text
+    |123*456*789 = << (* 123 456 789) >>
+
+  will produce this output:
+
+    |shell output
+    |Some preprocessed text
+    |123*456*789 = 44253432
+
+* Quoting the markers:
+
+  In case you need to use the actual text of the markers, you can quote
+  them.  A backslash before a beginning or an ending marker will make
+  the marker treated as text, it can also quote a sequence of
+  backslashes and a marker.  For example, using the default markers,
+  "\<<\>>" will output "<<>>", "\\<<\\\>>" will output "\<<\\>>" and
+  "\a\b\<<" will output "\a\b<<".
+
+* Modifying the markers:
+
+  Finally, if the markers collide with a certain file contents, it is
+  possible to change them.  This is done by a line with a special
+  structure -- if the current Scheme markers are "<beg1>" and "<end1>"
+  then a line that contains exactly:
+
+    <beg1><beg2><beg1><end1><end2><end1>
+
+  will change the markers to "<beg2>" and "<end2>".  It is possible to
+  change the markers from the Scheme side (see below), but this will not
+  change already-transformed text, which is the reason for this special
+  format.
+
+The mzpp read-eval-print loop
+-----------------------------
+
+The REPL is initialized by requiring "mzpp.ss", so the same module
+provides both the preprocessor functionality as well as bindings for
+embedded Scheme code in processed files.  The REPL is then fed the
+transformed Scheme code that is generated from the source text (the same
+code that `--debug' shows).  Each expression is evaluated and its result
+is printed using the `show' function (multiple values are all printed).
+`show' works in the following way:
+
+* `void' and `#f' values are ignored.
+
+* Structures of pairs are recursively scanned and their parts printed
+  (no spaces are used, so to produce Scheme code as output you must use
+  format strings -- again, this is not intended for preprocessing Scheme
+  code).
+
+* Procedures are applied to zero arguments (so a procedure that doesn't
+  accept zero arguments will cause an error) and the result is sent back
+  to `show'.  This is useful for using thunks to wrap side-effects as
+  values (e.g, the `thunk' wraps shown by the debug output above).
+
+* Promises are forced and the result is sent again to `show'.
+
+* All other values are printed with `display'.  No newlines are used
+  after printing values.
+
+Provided bindings
+-----------------
+
+First, bindings that are mainly useful for invoking the preprocessor:
+
+> (preprocess . files-and-ports)
+
+  This is the main entry point to the preprocessor -- invoking it on the
+  given list of files and input ports.  This is quite similar to
+  `include', but it adds some setup of the preprocessed code environment
+  (like requiring the mzpp module).
+
+> skip-to
+
+  A string parameter -- when the preprocessor is started, it ignores
+  everything until a line that contains exactly this string is
+  encountered.  This is primarily useful through a command-line flag for
+  scripts that extract some text from their own body.
+
+> debug?
+
+  A boolean parameter.  If true, then the REPL is not invoked, instead,
+  the converted Scheme code is printed as is.
+
+> no-spaces?
+
+  A boolean parameter.  If true, then the "smart" preprocessing of
+  spaces is turned off.
+
+> beg-mark
+> end-mark
+
+  These two parameters are used to specify the Scheme beginning and end
+  markers.
+
+All of the above are accessible in preprocessed texts, but the only one
+that might make any sense to use is `preprocess' and `include' is a
+better choice.  When `include' is used, it can be wrapped with parameter
+settings, which is why they are available.  Note in particular that
+these parameters change the way that the text transformation works and
+have no effect over the current preprocessed document (for example, the
+Scheme marks are used in a different thread, and `skip-to' cannot be
+re-set when processing has already began).  The only one that could be
+used is `no-spaces?' but even that makes little sense on selected parts.
+
+The following are bindings that are used in preprocessed texts:
+
+> (push-indentation str)
+> (pop-indentation)
+
+  These two calls are used to save the indentation column where the
+  Scheme beginning mark was found, and will be used by `newline*'
+  (unless smart space handling mode is disabled).
+
+> (show ...)
+
+  The arguments are displayed as specified above.
+
+> (newline*)
+
+  This is similar to `newline' except that it tries to handle spaces in
+  a "smart" way -- it will print a newline and then spaces to reach the
+  left margin of the opening "<<".  (Actually, it tries a bit more, for
+  example, it won't print the spaces if nothing is printed before
+  another newline.)  Setting `no-spaces?' to true disable this leaving
+  it equivalent to `newline'.
+
+> (include files...)
+
+  This is the preferred way of including another file in the processing.
+  File names are searched relatively to the current preprocessed file,
+  and during processing the current directory is temporarily changed to
+  make this work.  In addition to file names, the arguments can be input
+  ports (the current directory is not changed in this case).  The files
+  that will be incorporated can use any current Scheme bindings etc, and
+  will use the current markers -- but the included files cannot change
+  any of the parameter settings for the current processing
+  (specifically, the marks and the working directory will be restored
+  when the included files are processed).
+
+  Note that when a sequence of files are processed (through command-line
+  arguments or through a single `include' expression), then they are all
+  taken as one textual unit -- so changes to the markers, working
+  directory etc in one file can modify the way sequential files are
+  processed.  This means that including two files in a single `include'
+  expression can be different than using two expressions.
+
+Miscellaneous:
+
+> stdin
+> stdout
+> stderr
+> cd
+
+  These are shorter names for the corresponding port parameters and
+  `current-directory'.
+
+> current-file
+
+  This is a parameter that holds the name of the currently processed
+  file, or #f if none.
+
+
+========================================================================
+                                _mztext_
+========================================================================
+
+`mztext' is another MzScheme-based preprocessing language.  It can be
+used as a preprocessor in a similar way to `mzpp' since it also uses
+`pp-run' functionality.  However, `mztext' uses a completely different
+processing principle, it is similar to TeX rather than the simple
+interleaving of text and Scheme code done by `mzpp'.
+
+Text is being input from file(s), and by default copied to the standard
+output.  However, there are some `magic' sequences that trigger handlers
+that can take over this process -- these handlers gain complete control
+over what is being read and what is printed, and at some point they hand
+control back to the main loop.  On a high-level point of view, this is
+similar to "programming" in TeX, where macros accept as input the
+current input stream.  The basic mechanism that makes this programming
+is a `composite input port' which is a prependable input port -- so
+handlers are not limited to processing input and printing output, they
+can append their output back on the current input which will be
+reprocessed.
+
+The bottom line of all this is that `mztext' is can perform more
+powerful preprocessing than the `mzpp', since you can define your own
+language as the file is processed.
+
+Invoking mztext
+---------------
+
+Use the `-h' flag to get the available flags.  SEE above for an
+explanation of the `--run' flag.
+
+mztext processing: the standard command dispatcher
+--------------------------------------------------
+
+`mztext' can use arbitrary magic sequences, but for convenience, there
+is a default built-in dispatcher that connects Scheme code with the
+preprocessed text -- by default, it is triggered by "@".  When file
+processing encounters this marker, control is transfered to the command
+dispatcher.  In its turn, the command dispatcher reads a Scheme
+expression (using `read'), evaluates it, and decides what to do next.
+In case of a simple Scheme value, it is converted to a string and pushed
+back on the preprocessed input.  For example, the following text:
+
+  |foo
+  |@"bar"
+  |@(+ 1 2)
+  |@"@(* 3 4)"
+  |@(/ (read) 3)12
+
+generates this output:
+
+  |foo
+  |bar
+  |3
+  |12
+  |4
+
+An explanation of a few lines:
+* @"bar", @(+ 1 2) -- the Scheme objects that is read is evaluated and
+  displayed back on the input port which is then printed.
+* @"@(* 3 4)" -- this demonstrates that the results are "printed" back
+  on the input: the string that in this case contains another use of "@"
+  which will then get read back in, evaluated, and displayed.
+* @(/ (read) 3)12 -- this demonstrates that the Scheme code can do
+  anything with the current input.
+
+The complete behavior of the command dispatcher follows:
+
+* If the marker sequence is followed by itself, then it is simply
+  displayed, using the default, "@@" outputs a "@".
+
+* Otherwise a Scheme expression is read and evaluated, and the result is
+  processed as follows:
+
+  * If the result consists of multiple values, each one is processed,
+
+  * If it is `void' or `#f', nothing is done,
+
+  * If it is a structure of pairs, this structure is processed
+    recursively,
+
+  * If it is a promise, it is forced and its value is used instead,
+
+  * Strings, bytes, and paths are pushed back on the input stream,
+
+  * Symbols, numbers, and characters are converted to strings and pushed
+    back on the input,
+
+  * An input port will be perpended to the input, both processed as a
+    single input,
+
+  * Procedures of one or zero arity are treated in a special way -- see
+    below, other procedures cause an error,
+
+  * All other values are ignored.
+
+* When this processing is done, and printable results have been re-added
+  to the input port, control is returned to the main processing loop.
+
+A built-in convenient behavior is that if the evaluation of the Scheme
+expression returned a `void' or `#f' value (or multiple values that are
+all `void' or `#f'), then the next newline is swallowed using
+`swallow-newline' (see below) if there is just white spaces before it.
+
+During evaluation, printed output is displayed as is, without
+re-processing.  It is not hard to do that, but it is a little expensive,
+so the choice is to ignore it.  (A nice thing to do is to redesign this
+so each evaluation is taken as a real filter, which is done in its own
+thread, so when a Scheme expression is about to evaluated, it is done in
+a new thread, and the current input is wired to that thread's output.
+However, this is much too heavy for a "simple" preprocesser...)
+
+So far, we get a language that is roughly the same as we get from `mzpp'
+(with the added benefit of reprocessing generated text, which could be
+done in a better way using macros).  The special treatment of procedure
+values is what allows more powerful constructs.  There are handled by
+their arity (preferring a the nullary treatment over the unary one):
+
+* A procedure of arity 0 is simply invoked, and its resulting value is
+  used.  The procedure can freely use the input stream to retrieve
+  arguments.  For example, here is how to define a standard C function
+  header for use in a MzScheme extension file:
+
+    |@(define (cfunc)
+    |   (format
+    |    "static Scheme_Object *~a(int argc, Scheme_Object *argv[])\n"
+    |    (read-line)))
+    |@cfunc foo
+    |@cfunc bar
+
+  ==>
+
+    |static Scheme_Object * foo(int argc, Scheme_Object *argv[])
+    |static Scheme_Object * bar(int argc, Scheme_Object *argv[])
+
+  Note how `read-line' is used to retrieve an argument, and how this
+  results in an extra space in the actual argument value.  Replacing
+  this with `read' will work slightly better, except that input will
+  have to be a Scheme token (in addition, this will not consume the
+  final newline so the extra one in the format string should be
+  removed).  The `get-arg' function can be used to retrieve arguments
+  more easily -- by default, it will return any text enclosed by
+  parenthesis, brackets, braces, or angle brackets (see below).  For
+  example:
+
+    |@(define (tt)
+    |   (format "<tt>~a</tt>" (get-arg)))
+    |@(define (ref)
+    |   (format "<a href=~s>~a</a>" (get-arg) (get-arg)))
+    |@(define (ttref)
+    |   (format "<a href=~s>@tt{~a}</a>" (get-arg) (get-arg)))
+    |@(define (reftt)
+    |   (format "<a href=~s>~a</a>" (get-arg) (tt)))
+    |@ttref{www.plt-scheme.edu}{PLT Scheme}
+    |@reftt{www.plt-scheme.edu}{PLT Scheme}
+
+  ==>
+
+    |<a href="www.plt-scheme.edu"><tt>PLT Scheme</tt></a>
+    |<a href="www.plt-scheme.edu"><tt>PLT Scheme</tt></a>
+
+  Note that in `reftt' we use `tt' without arguments since it will
+  retrieve its own arguments.  This makes `ttref's approach more
+  natural, except that "calling" `tt' through a Scheme string doesn't
+  seem natural.  For this there is a `defcommand' command (see below)
+  that can be used to define such functions without using Scheme code:
+
+    |@defcommand{tt}{X}{<tt>X</tt>}
+    |@defcommand{ref}{url text}{<a href="url">text</a>}
+    |@defcommand{ttref}{url text}{<a href="url">@tt{text}</a>}
+    |@ttref{www.plt-scheme.edu}{PLT Scheme}
+
+  ==>
+
+    |<a href="www.plt-scheme.edu"><tt>PLT Scheme</tt></a>
+
+* A procedure of arity 1 is invoked differently -- it is applied on a
+  thunk that holds the "processing continuation".  This application is
+  not expected to return, instead, the procedure can decide to hand over
+  control back to the main loop by using this thunk.  This is a powerful
+  facility that is rarely needed, similarly to the fact that `call/cc'
+  is rarely needed in Scheme.
+
+Remember that when procedures are used, generated output is not
+reprocessed, just like evaluating other expressions.
+
+Provided bindings
+-----------------
+
+Similarly to `mzpp', "mztext.ss" contains both the implementation as
+well as user-visible bindings.
+
+Dispatching-related bindings:
+
+> command-marker
+
+  A string parameter-like procedure that can be used to set a different
+  command marker string.  Defaults to "@".  It can also be set to `#f'
+  which will disable the command dispatcher altogether.  Note that this
+  is a procedure -- it cannot be used with `parameterize'.
+
+> dispatchers
+
+  A parameter-like procedure (same as `command-marker') holding a list
+  of lists -- each one a dispatcher regexp and a handler function.  The
+  regexp should not have any parenthesized subgroups, use "(?:...)" for
+  grouping.  The handler function is invoked whenever the regexp is seen
+  on the input stream: it is invoked on two arguments -- the matched
+  string and a continuation thunk.  It is then responsible for the rest
+  of the processing, usually invoking the continuation thunk to resume
+  the default preprocessing.  For example:
+
+    |@(define (foo-handler str cont)
+    |   (add-to-input (list->string (reverse (string->list (get-arg)))))
+    |   (cont))
+    |@(dispatchers (cons (list "foo" foo-handler) (dispatchers)))
+    |foo{>Foo<oof}
+
+  ==>
+
+    |Foo
+
+  Note that the standard command dispatcher uses the same facility, and
+  it is added by default to the dispatcher list unless `command-marker'
+  is set to `#f'.
+
+Input and "output":
+
+> (make-composite-input values ...)
+
+  Creates a composite input port, initialized by the given values (input
+  ports, strings, etc).  The resulting port will read data from each of
+  the values in sequence, appending them together to form a single input
+  port.  This is very similar to `input-port-append' from "port.ss", but
+  it is extended to allow perpending additional values to the beginning
+  of the port using `add-to-input'.  mztext relies on this functionality
+  to be able to push text back on the input when it is supposed to be
+  reprocessed, so use only such ports for the current input port.
+
+> (add-to-input value ...)
+
+  This should be used to "output" a string (or an input port) back on
+  the current composite input port.  As a special case, thunks can be
+  added to the input too -- they will be executed when the "read header"
+  goes past them, and their output will be added back instead.  This is
+  used to plant handlers that happen when reading beyond a specific
+  point (for example, this is how the directory is changed to the
+  processed file to allow relative includes).  Other simple values are
+  converted to strings using `format' but this might change.
+
+> paren-pairs
+
+  This is a parameter holding a list of lists, each one holding two
+  strings which are matching open/close tokens for `get-arg'.
+
+> get-arg-reads-word?
+
+  A parameter that holds a boolean value defaulting to `#f'.  If true,
+  then `get-arg' will read a whole word (non-whitespace string delimited
+  by whitespaces) for arguments that are not parenthesized with a pair
+  in `paren-pairs'.
+
+> (get-arg)
+
+  This function will retrieve a text argument surrounded by a paren pair
+  specified by `paren-pairs'.  First, an open-pattern is searched, and
+  then text is assembled making sure that open-close patterns are
+  respected, until a matching close-pattern is found.  When this scan is
+  performed, other parens are ignored, so if the input stream has
+  "{[(}", the return value will be "[(".  It is possible for both tokens
+  to be the same, which will have no nesting possible.  If no
+  open-pattern is found, the first non-whitespace character is used, and
+  if that is also not found before the end of the input, an `eof' value
+  is returned.  For example (using `defcommand' which uses `get-arg'):
+
+    |@(paren-pairs (cons (list "|" "|") (paren-pairs)))
+    |@defcommand{verb}{X}{<tt>X</tt>}
+    |@verb abc
+    |@(get-arg-reads-word? #t)
+    |@verb abc
+    |@verb |FOO|
+    |@verb
+
+  ==>
+
+    |<tt>a</tt>bc
+    |<tt>abc</tt>
+    |<tt>FOO</tt>
+    |verb: expecting an argument for `X'
+
+> (get-arg*)
+
+  Similar to `get-arg', except that the resulting text is first
+  processed.  Since arguments are usually text strings, "programming"
+  can be considered as lazy evaluation, which sometimes can be too
+  inefficient (TeX suffers from the same problem).  `get-arg*' can be
+  used to reduce some inputs immediately after they have been read.
+
+> (swallow-newline)
+
+  This is a simple command that simply does this:
+
+    (regexp-match/fail-without-reading #rx"^[ \t]*\r?\n" (stdin))
+
+  The result is that a newline will be swallowed if there is only
+  whitespace from the current location to the end of the line.  Note
+  that as a general principle `regexp-match/fail-without-reading' (from
+  "string.ss") should be preferred over `regexp-match' for `mztext's
+  preprocessing.
+
+Defining new commands:
+
+> defcommand
+
+  This is a command that can be used to define simple template
+  commands.  It should be used as a command, not from Scheme code
+  directly, and it should receive three arguments:
+  * The name for the new command (the contents of this argument is
+    converted to a string,
+  * The list of arguments (the contents of this is turned to a list of
+    identifiers),
+  * Arbitrary text, with *textual* instances of of the variables that
+    denote places they are used.
+  For example, the sample code above:
+
+    |@defcommand{ttref}{url text}{<a href="url">@tt{text}</a>}
+
+  is translated to the following definition expression:
+
+    |(define (ttref)
+    |  (let ((url (get-arg)) (text (get-arg)))
+    |    (list "<a href=\"" url "\">@tt{" text "}</a>")))
+
+  which is then evaluated.  Note that the arguments play a role as both
+  Scheme identifiers and textual markers.
+
+Invoking the preprocessor:
+
+> (include [files...])
+
+  This will add all of the given inputs to the composite port and run
+  the preprocessor loop.  In addition to the given inputs, some thunks
+  are added to the input port (see `add-to-input' above) to change
+  directory so relative includes work.
+
+  If it is called with no arguments, it will use `get-arg' to get an
+  input filename, therefore making it possible to use this as a
+  dispatcher command as well.
+
+> (preprocess . files-and-ports)
+
+  This is the main entry point to the preprocessor -- creating a new
+  composite port, setting internal parameters, then calling `include' to
+  start the preprocessing.
+
+Miscellaneous:
+
+> stdin
+> stdout
+> stderr
+> cd
+
+  These are shorter names for the corresponding port parameters and
+  `current-directory'.
+
+> current-file
+
+  This is a parameter that holds the name of the currently processed
+  file, or #f if none.
diff --git a/collects/preprocessor/info.ss b/collects/preprocessor/info.ss
new file mode 100644
index 0000000000..44be121774
--- /dev/null
+++ b/collects/preprocessor/info.ss
@@ -0,0 +1,5 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Preprocessor")
+  (define doc.txt "doc.txt")
+  (define mzscheme-launcher-names     '("mzpp"        "mztext"))
+  (define mzscheme-launcher-libraries '("mzpp-run.ss" "mztext-run.ss")))
diff --git a/collects/preprocessor/mzpp-run.ss b/collects/preprocessor/mzpp-run.ss
new file mode 100644
index 0000000000..df56c9771a
--- /dev/null
+++ b/collects/preprocessor/mzpp-run.ss
@@ -0,0 +1,37 @@
+(module mzpp-run mzscheme
+
+(require (lib "mzpp.ss" "preprocessor")
+         (lib "pp-run.ss" "preprocessor")
+         (lib "cmdline.ss")
+         (lib "process.ss"))
+
+(let ([output #f] [run-cmd #f])
+  (command-line
+   "mzpp"
+   (current-command-line-arguments)
+   (once-each
+    [("-o" "--output") file "output file (defaults to standard output)"
+     (set! output file)]
+    [("-b" "--begin-mark") beg "Scheme beginning marker (defaults to \"<<\")"
+     (beg-mark beg)]
+    [("-e" "--end-mark") end "Scheme ending marker (defaults to \">>\")"
+     (end-mark end)]
+    [("-s" "--skip-to") skip "skip processing to a line with only this string"
+     (skip-to skip)]
+    [("--no-spaces") "disable \"smart\" handling of spaces"
+     (no-spaces? #t)]
+    [("--run") cmd "run the command string on a single preprocessed input file"
+     (set! run-cmd cmd)])
+   (help-labels "   (see the documentation for this option)")
+   (multi
+    [("-E" "--eval") expr "evaluates <expr> before processing starts"
+     (parameterize ([read-case-sensitive #t])
+       (add-eval (read (open-input-string expr))))])
+   (once-each
+    [("--debug") "show preprocessed Scheme code (for debugging)"
+     (debug? #t)])
+   (=> (lambda (_ . files) (run preprocess run-cmd output files))
+       '("input-file")
+       (more-help 'mzpp "a MzScheme-based preprocessor"))))
+
+)
diff --git a/collects/preprocessor/mzpp.ss b/collects/preprocessor/mzpp.ss
new file mode 100644
index 0000000000..bb1857e842
--- /dev/null
+++ b/collects/preprocessor/mzpp.ss
@@ -0,0 +1,177 @@
+(module mzpp mzscheme
+
+(require (lib "pp-utils.ss" "preprocessor"))
+(provide (all-from (lib "pp-utils.ss" "preprocessor")))
+
+(provide beg-mark end-mark skip-to no-spaces? debug?)
+(define beg-mark   (make-parameter "<<"))
+(define end-mark   (make-parameter ">>"))
+(define skip-to    (make-parameter #f))
+(define no-spaces? (make-parameter #f))
+(define debug?     (make-parameter #f))
+
+(define current-indentation (make-parameter '()))
+(define current-spaces      (make-parameter #f))
+(define current-newline?    (make-parameter #f))
+
+(provide thunk)
+(define-syntax thunk
+  (syntax-rules () [(thunk body0 body1 ...) (lambda () body0 body1 ...)]))
+
+(provide push-indentation pop-indentation)
+(define (push-indentation i)
+  (current-indentation (cons i (current-indentation))))
+(define (pop-indentation)
+  (current-indentation (cdr (current-indentation)))
+  (current-spaces 'x))
+
+(provide newline*)
+(define (newline*)
+  (cond
+   [(no-spaces?) (newline)]
+   [(eq? '- (current-spaces)) (current-spaces #f)]
+   [(and (current-newline?) (eq? 'x (current-spaces))) (current-spaces #f)]
+   [else (newline)
+         (let ([i (current-indentation)] [s (current-spaces)])
+           (when (string? s) (display s))
+           (current-spaces (and (pair? i) (car i)))
+           (current-newline? #t))]))
+
+(provide show)
+(define (show . args)
+  (define (show x)
+    (cond [(or (void? x) (not x) (null? x))]
+          [(procedure? x)
+           (if (procedure-arity-includes? x 0)
+             (call-with-values x show)
+             (error 'mzpp "got a bad procedure value: ~e" x))]
+          [(promise? x) (show (force x))]
+          [(pair? x) (show (car x)) (show (cdr x))]
+          [else (if (no-spaces?)
+                  (display x)
+                  (let ([spc1 (current-spaces)]
+                        [spc2 (and (string? x) (regexp-match #rx"^ *$" x))])
+                    (when (string? spc1) (display spc1))
+                    (current-spaces (and spc2 (car spc2)))
+                    (unless spc2 (display x))
+                    (current-newline? #f)))]))
+  (for-each show args))
+
+(define (process)
+  (define scheme? #t)
+  (define (open)
+    (when scheme? (error 'mzpp "unexpected meta-open token"))
+    (set! scheme? #t))
+  (define (close)
+    (unless scheme? (error 'mzpp "unexpected meta-close token"))
+    (set! scheme? #f))
+  (define (writeln x) (write x) (newline))
+  (define (newln)
+    (if scheme? (newline) (writeln `newline*)))
+  (define (disp x)
+    ((if scheme? display writeln) x))
+  (define token-re #f)
+  (define token-change-string #f)
+  (define (re-quote str . args)
+    (regexp
+     (apply format str
+            (map (lambda (x) (regexp-replace* "[][()|+*?.^$\\]" x "\\\\\\0"))
+                 args))))
+  (define (set-markers beg end)
+    (beg-mark beg)
+    (end-mark end)
+    (set! token-re (re-quote "(\\\\+)?(~a|~a)" beg end))
+    (set! token-change-string
+          (re-quote "^ *~a(.*)~a~a(.*)~a *$" beg beg end end)))
+  (define skip-to-re (and (skip-to) (re-quote "^~a$" (skip-to))))
+  (set-markers (beg-mark) (end-mark))
+  (close)
+  (let loop ([str (read-line)] [k 0])
+    (cond
+     [(eof-object? str)]
+     [skip-to-re
+      (when (regexp-match skip-to-re str)
+        (set! skip-to-re #f) (skip-to #f))
+      (loop (read-line) 0)]
+     [(and (zero? k) (regexp-match token-change-string str)) =>
+      (lambda (m)
+        (set-markers (cadr m) (caddr m))
+        ;; the follwing has no effect on the current text, but will on included
+        ;; texts
+        (writeln `(thunk (beg-mark ,(cadr m)) (end-mark ,(caddr m))))
+        (loop (read-line) 0))]
+     [(regexp-match-positions token-re str k) =>
+      (lambda (m)
+        (let ([token (substring str (caar m) (cdar m))])
+          (unless (= k (caar m)) (disp (substring str k (caar m))))
+          (cond [(cadr m) (disp (substring str (+ 1 (caadr m)) (cdar m)))]
+                [(equal? token (beg-mark))
+                 (open)
+                 (writeln `(thunk (push-indentation
+                                   ,(regexp-replace* #rx"[^ \t\n]"
+                                                     (substring str 0 (caar m))
+                                                     " "))))]
+                [(equal? token (end-mark))
+                 (close) (writeln `(thunk (pop-indentation)))]
+                [else (disp token)])
+          (loop str (cdar m))))]
+     [else (cond [(= k (string-length str))]
+                 [(zero? k) (disp str)]
+                 [else (disp (substring str k))])
+           (newln)
+           (loop (read-line) 0)]))
+  (open))
+
+(define (pp-repl)
+  (let loop ()
+    (let ([x (read)])
+      (unless (eof-object? x)
+        (call-with-values (lambda () (eval x)) show)
+        (loop)))))
+
+(define (run files)
+  (define (do-files)
+    (for-each
+     (lambda (file)
+       (if (input-port? file)
+         (parameterize ([stdin file]) (process))
+         (let-values ([(dir name _) (split-path file)])
+           (printf "~s\n"
+                   `(thunk (cd ,(path->string (if (path? dir) dir (cd))))
+                           (current-file ,(path->string name))))
+           (with-input-from-file file process)
+           (printf "~s\n"
+                   `(thunk (cd ,(path->string (cd))) ; return to original dir
+                           (current-file #f))))))
+     files))
+  (if (debug?)
+    (do-files)
+    (let-values ([(in out) (make-pipe)])
+      (define (done) (close-input-port in) (close-output-port out))
+      (define (abort-handler thunk)
+        (with-handlers ([void (lambda (e) (done) (raise e))])
+          (thunk)))
+      (thread (lambda ()
+                (parameterize ([stdout out]) (abort-handler do-files))
+                (close-output-port out)))
+      (parameterize ([stdin in]) (abort-handler pp-repl))
+      (done)))
+  (current-spaces '-))
+
+(provide include)
+(define (include . files)
+  ;; run the files but don't let them change the current environment
+  (parameterize ([skip-to #f]
+                 [beg-mark (beg-mark)]
+                 [end-mark (end-mark)]
+                 [cd (cd)])
+    (run files)))
+
+(provide preprocess)
+(define (preprocess . files)
+  (read-case-sensitive #t)
+  (namespace-require '(lib "mzpp.ss" "preprocessor"))
+  (do-evals)
+  (run files))
+
+)
diff --git a/collects/preprocessor/mztext-run.ss b/collects/preprocessor/mztext-run.ss
new file mode 100644
index 0000000000..bc1a0494e7
--- /dev/null
+++ b/collects/preprocessor/mztext-run.ss
@@ -0,0 +1,27 @@
+(module mztext-run mzscheme
+
+(require (lib "mztext.ss" "preprocessor")
+         (lib "pp-run.ss" "preprocessor")
+         (lib "cmdline.ss"))
+
+(let ([output #f] [run-cmd #f])
+  (command-line
+   "mztext"
+   (current-command-line-arguments)
+   (once-each
+    [("-o" "--output") file "output file (defaults to standard output)"
+     (set! output file)]
+    [("-c" "--command-marker") marker "command marker (defaults to \"@\")"
+     (command-marker marker)]
+    [("--run") cmd "run the command string on a single preprocessed input file"
+     (set! run-cmd cmd)])
+   (help-labels "   (see the documentation for this option)")
+   (multi
+    [("-E" "--eval") expr "evaluates <expr> before processing starts"
+     (parameterize ([read-case-sensitive #t])
+       (add-eval (read (open-input-string expr))))])
+   (=> (lambda (_ . files) (run preprocess run-cmd output files))
+       '("input-file")
+       (more-help 'mztext "a MzScheme-based preprocessing language"))))
+
+)
diff --git a/collects/preprocessor/mztext.ss b/collects/preprocessor/mztext.ss
new file mode 100644
index 0000000000..c784a20bb1
--- /dev/null
+++ b/collects/preprocessor/mztext.ss
@@ -0,0 +1,347 @@
+(module mztext mzscheme
+
+(require (lib "string.ss") (lib "port.ss") (lib "pp-utils.ss" "preprocessor"))
+(provide (all-from (lib "pp-utils.ss" "preprocessor")))
+
+;;=============================================================================
+;; Composite port
+;; A composite port is an input port and a procedure that can be used to
+;; prepend stuff to this port.  The implementation uses a custom input port
+;; that implements its own peeking, because peeking is not always consistent
+;; (in case stuff was prepended, previous peeks are invalidated), so we cannot
+;; rely on the internal default peek.  The port holds a list of input ports and
+;; strings, which are being used as necessary when input is required.  This
+;; list can also hold thunk values -- these thunks will be executed when
+;; reading input goes past them (when peeking goes past them, nothing happens).
+
+(provide make-composite-input)
+(define (make-composite-input . ports)
+  ;; don't care about concurrency, since multiple uses should use different
+  ;; input ports.
+  (define (pop-port!)
+    (begin0 (car ports) (set! ports (cdr ports))))
+  (define (add! x)
+    (cond [(pair? x) (add! (cdr x)) (add! (car x))]
+          [(null? x) #t]
+          [(void? x) #t]
+          [(not x) #t]
+          [(or (input-port? x)
+               (and (procedure? x) (procedure-arity-includes? x 0)))
+           (set! ports (cons x ports))]
+          [(bytes?  x) (add! (open-input-bytes x))]
+          [(string? x) (add! (open-input-string x))]
+          [(path?   x) (add! (path->bytes x))]
+          [(symbol? x) (add! (symbol->string x))]
+          [(number? x) (add! (number->string x))]
+          [(char?   x) (add! (string x))]
+          [else (error 'composite-input "bad object: ~e" x)]))
+  ;; Large parts taken from `input-port-append'.
+  (define (read bstr)
+    (let loop ()
+      (cond [(null? ports) eof]
+            [(procedure? (car ports)) ; reading past a thunk: execute it
+             (add! ((pop-port!)))
+             (loop)]
+            [else
+             (let ([n (read-bytes-avail!* bstr (car ports))])
+               (cond [(eq? n 0) (wrap-evt (car ports) (lambda (x) 0))]
+                     [(eof-object? n) (close-input-port (pop-port!)) (loop)]
+                     [else n]))])))
+  (define (peek bstr skip evt)
+    ;; Peeking is more difficult, due to skips.
+    (let loop ([ports ports] [skip skip])
+      (cond
+       [(null? ports) eof]
+       [(procedure? (car ports)) (loop (cdr ports) skip)]
+       [else (let ([n (peek-bytes-avail!* bstr skip evt (car ports))])
+               (cond [(eq? n 0)
+                      ;; Not ready, yet.
+                      (peek-bytes-avail!-evt bstr skip evt (car ports))]
+                     [(eof-object? n)
+                      ;; Port is exhausted, or we skipped past its input.
+                      ;; If skip is not zero, we need to figure out
+                      ;;  how many chars were skipped.
+                      (loop (cdr ports)
+                            (- skip (compute-avail-to-skip skip (car ports))))]
+                     [else n]))])))
+  (define (close)
+    (for-each (lambda (p) (when (input-port? p) (close-input-port p))) ports))
+  (let ([ps ports]) (set! ports '()) (add! ps))
+  (let ([p (make-input-port 'composite-input read peek close)])
+    (port->adder-op p 'set! add!)
+    p))
+;; Helper for input-port-append; given a skip count
+;;  and an input port, determine how many characters
+;;  (up to upto) are left in the port. We figure this
+;;  out using binary search.
+(define (compute-avail-to-skip upto p)
+  (let ([str (make-bytes 1)])
+    (let loop ([upto upto][skip 0])
+      (if (zero? upto)
+        skip
+        (let* ([half (quotient upto 2)]
+               [n (peek-bytes-avail!* str (+ skip half) #f p)])
+          (if (eq? n 1)
+            (loop (- upto half 1) (+ skip half 1))
+            (loop half skip)))))))
+
+(provide add-to-input)
+(define (add-to-input . args)
+  (port->adder-op (stdin) 'add args))
+
+(define port->adder-op
+  (let ([table (make-hash-table 'weak)])
+    (lambda (port msg . args)
+      (case msg
+        [(add) (apply (hash-table-get table port
+                        (lambda ()
+                          (error 'add-to-input
+                                 "current input is not a composite port")))
+                      args)]
+        [(set!) (hash-table-put! table port (car args))]
+        [(get?) (hash-table-get table port (lambda () #f))]
+        [else (error 'port->adder-op "unknown message: ~e" msg)]))))
+
+;;=============================================================================
+;; Dispatching
+;; A dispatcher is a pair of a regexp and a list of dispatch functions.  The
+;; regexp should have some parenthesized subexpressions, and the one that
+;; actually matched is used to select the dispatching functions, which is
+;; invoked on the match.  This functionality is used for the main loop (with
+;; the default single dispatcher for "@") and for `get-arg'.
+
+(define (dispatch dispatcher continue failure . copy?)
+  (let ([m (if (and (pair? copy?) (car copy?))
+             (regexp-match (car dispatcher) (stdin) 0 #f (stdout))
+             (regexp-match/fail-without-reading (car dispatcher) (stdin)))])
+    (if m
+      (ormap (lambda (x y) (and x (y x continue))) (cdr m) (cdr dispatcher))
+      (failure))))
+
+;; dispatchers is a list of (string dispatcher) lists
+(define (make-dispatcher prefix dispatchers . regexps?)
+  (define re
+    (if (and (pair? regexps?) (car regexps?)) (lambda (x) x) regexp-quote))
+  (cons (regexp (string-append
+                 prefix "(?:"
+                 (apply string-append
+                        (cdr (apply append
+                                    (map (lambda (d)
+                                           (list "|" (format "(~a)"
+                                                             (re (car d)))))
+                                         dispatchers))))
+                 ")"))
+        (map cadr dispatchers)))
+
+;;=============================================================================
+;; Dispatchers
+
+(provide dispatchers)
+(define dispatchers
+  (let ([dispatchers (make-thread-cell '() #t)])
+    (case-lambda
+     [() (thread-cell-ref dispatchers)]
+     [(new) (thread-cell-set! dispatchers new) (rebuild-dispatcher-table)])))
+(define dispatcher-table (make-parameter #f))
+
+(provide command-marker)
+(define command-marker
+  (let ([marker (make-thread-cell #f #t)])
+    (case-lambda
+     [() (thread-cell-ref marker)]
+     [(new)
+      (thread-cell-set! marker new)
+      (command-marker-here-re
+       (and marker (regexp (string-append "^" (regexp-quote new)))))
+      (rebuild-dispatcher-table)])))
+(define command-marker-here-re (make-parameter #f))
+
+(define (rebuild-dispatcher-table)
+  (dispatcher-table
+   (make-dispatcher
+    "" (if (command-marker)
+         `(,@(dispatchers)
+           (,(regexp-quote (command-marker)) ,command-dispatcher))
+         (dispatchers))
+    #t)))
+
+(define (command-dispatcher match cont)
+  (define (do-thunk thunk)
+    (call-with-values thunk
+      (lambda vs
+        (define (value->cont v cont)
+          (cond [(or (void? v) (not v) (null? v)) cont]
+                [(pair? v) (value->cont (car v) (value->cont (cdr v) cont))]
+                [(promise? v) (value->cont (force v) cont)]
+                [(not (procedure? v))
+                 (when (or (bytes? v) (string? v) (path? v) (symbol? v)
+                           (number? v) (char? v) (input-port? v))
+                   (add-to-input v))
+                 cont]
+                [(procedure-arity-includes? v 0) (do-thunk v) cont]
+                [(procedure-arity-includes? v 1) (lambda () (v cont))]
+                [else (error 'mztext "got a bad procedure value: ~e" v)]))
+        ((if (andmap (lambda (x) (or (not x) (void? x))) vs)
+           (begin (swallow-newline) cont)
+           (value->cont vs cont))))))
+  (cond [(regexp-match/fail-without-reading (command-marker-here-re) (stdin))
+         => (lambda (here) (display (car here)) (cont))]
+        [else (let ((r (read))) (do-thunk (lambda () (eval r))))]))
+
+(provide paren-pairs)
+(define paren-pairs
+  (make-parameter '(("(" ")") ("[" "]") ("{" "}") ("<" ">"))))
+
+(provide get-arg-reads-word?)
+(define get-arg-reads-word? (make-parameter #f))
+
+;; A list of an open regexp for any openning, and then a list of thunks, each
+;; one for retreiving a piece of text by some paren pair.
+(define arg-dispatcher
+  (let ([dispatcher #f] [pairs #f])
+    (lambda ()
+      (unless (eq? pairs (paren-pairs))
+        (set! pairs (paren-pairs))
+        (set! dispatcher
+              (make-dispatcher
+               "^[ \t\r\n\f]*"
+               (map (lambda (p) (list (car p) (apply make-arg-getter p)))
+                    pairs))))
+      dispatcher)))
+
+(define (make-arg-getter open close)
+  (let ([re (regexp (if (equal? open close)
+                      (begin (set! open close) (regexp-quote close))
+                      (format "(~a)|(~a)"
+                              (regexp-quote close) (regexp-quote open))))])
+    (lambda (match cont)
+      (let loop ([level 0] [pos 0])
+        (let ([m (regexp-match-peek-positions re (stdin) pos)])
+          (unless m (error 'get-arg "missing ~s" close))
+          ;; (cadr m) => close, (caddr m) => open
+          (cond [(or (eq? open close) (and (zero? level) (cadr m)))
+                 (begin0 (read-string (caar m))
+                   (regexp-match-positions re (stdin)))]
+                [(caddr m) (loop (add1 level) (cdar m))]
+                [(cadr m)  (loop (sub1 level) (cdar m))]
+                [else (error 'get-arg "internal error")]))))))
+
+(provide get-arg)
+(define (get-arg)
+  (dispatch
+   (arg-dispatcher)
+   #f
+   (lambda ()
+     (cond [(regexp-match/fail-without-reading
+             (if (get-arg-reads-word?) #rx"[^ \t\r\n]+" #rx"[^ \t\r\n]")
+             (stdin))
+            => car]
+           [else eof]))))
+
+(provide get-arg*)
+(define (get-arg*)
+  (let ([arg (get-arg)])
+    (if (eof-object? arg)
+      arg
+      (let ([buf (open-output-string)])
+        (parameterize ([stdout buf] [stdin (make-composite-input arg)])
+          (run) (flush-output buf))
+        (get-output-string buf)))))
+
+;;=============================================================================
+;; User functionality
+
+(provide swallow-newline)
+(define (swallow-newline)
+  ;; careful: if there's no match, we don't want to consume the input
+  (regexp-match/fail-without-reading #rx"^[ \t]*\r?\n" (stdin))
+  (void))
+
+(define (string->substlist args str)
+  (if (null? args)
+    str
+    (let* ([re (map (lambda (x) (regexp-quote (symbol->string x))) args)]
+           [re (regexp (string-append
+                        "(" (car re)
+                        (apply string-append
+                               (map (lambda (x) (string-append "|" x))
+                                    (cdr re)))
+                        ")"))]
+           [posns (regexp-match-positions* re str)])
+      (define (sub n . m) (apply substring str n m))
+      (let loop ([pos 0] [posns posns] [r '()])
+        (cond [(null? posns)
+               (cons 'list (reverse! (if (= pos (string-length str))
+                                       r (cons (sub pos) r))))]
+              [(= pos (caar posns))
+               (loop (cdar posns) (cdr posns)
+                     (cons (string->symbol (sub (caar posns) (cdar posns)))
+                           r))]
+              [else (loop (caar posns) posns
+                          (cons (sub pos (caar posns)) r))])))))
+
+(provide defcommand)
+(define (defcommand)
+  (let ([name (get-arg)] [args (get-arg)] [body (get-arg)])
+    (cond
+     [(eof-object? name) (error 'defcommand "no name")]
+     [(eof-object? args) (error 'defcommand "no args for `~a'" name)]
+     [(eof-object? body) (error 'defcommand "no body for `~a'" name)]
+     [else
+      (let ([name (string->symbol name)]
+            [args (read-from-string-all args)]
+            [body body])
+        (define (get-arg! a)
+          (let ([x (get-arg)])
+            (if (eof-object? x)
+              (error name "expecting an argument for `~s'" a)
+              x)))
+        (unless (and (list? args) (andmap symbol? args))
+          (error 'defcommand "bad arguments for ~s: ~e" name args))
+        (eval `(define (,name)
+                 (let ,(map (lambda (a) `[,a (,get-arg! ',a)]) args)
+                   ,(string->substlist args body)))))])))
+
+;;=============================================================================
+;; Invocation
+
+(define (initialize)
+  (read-case-sensitive #t)
+  (unless (command-marker) (command-marker "@"))
+  (namespace-require '(lib "mztext.ss" "preprocessor"))
+  (do-evals))
+
+(define (run)
+  (dispatch (dispatcher-table) run void #t))
+
+(provide include)
+(define (include . files)
+  (define inputs (if (null? files)
+                   (let ([arg (get-arg)])
+                     (if (eof-object? arg)
+                       (error 'include "expecting a file argument")
+                       (list (get-arg))))
+                   files))
+  (define curdir (cd))
+  (define (cd+file f)
+    (let*-values ([(dir name dir?)
+                   (if (input-port? f) (values #f #f #f) (split-path f))]
+                  [(dir) (if (path? dir) dir (cd))])
+      ;; could `add-to-input' and then `run' if we wrap this by a (cd dir), but
+      ;; instead, plant cd-thunks in the input stream.
+      (add-to-input
+       (lambda () (cd dir) (current-file (and (string? name) name)))
+       (if (input-port? f) f (open-input-file f))
+       (lambda () (cd curdir) (current-file #f)))))
+  (swallow-newline) ; swallow *before* more stuff is added
+  (for-each cd+file (reverse inputs))
+  (run))
+
+(provide preprocess)
+(define (preprocess . files)
+  (initialize)
+  (unless (null? files)
+    (parameterize ([stdin (make-composite-input)])
+      (apply include files))))
+
+)
diff --git a/collects/preprocessor/pp-run.ss b/collects/preprocessor/pp-run.ss
new file mode 100644
index 0000000000..e353f321c7
--- /dev/null
+++ b/collects/preprocessor/pp-run.ss
@@ -0,0 +1,57 @@
+(module pp-run mzscheme
+
+(require (lib "process.ss"))
+
+(provide more-help)
+(define (more-help name top-line)
+  (lambda (help)
+    (printf "This is `~a', ~a.\nUsage: " name top-line)
+    (display (regexp-replace
+              #rx"\n where" help
+              "\n where an \"-\" input file specifies standard input\n and"))
+    (display "See \"plt/preprocessor/doc.txt\" for more details.\n")
+    (exit 0)))
+
+(provide run)
+(define (run preprocess run-cmd output files)
+  (let ([files (map (lambda (f) (if (equal? f "-") (current-input-port) f))
+                    (if (null? files) '("-") files))]
+        [exit-code 0])
+    (define (do-run-subst f)
+      (set! exit-code (system/exit-code (regexp-replace
+                                         #rx"\\*" run-cmd (format "~s" f)))))
+    (cond
+     [(and run-cmd (not (regexp-match #rx"\\*" run-cmd)))
+      (when output
+        (error 'mzpp "cannot run a command with piped stdin when an ~a"
+               "output name is specified"))
+      (let ([p (process/ports (current-output-port) #f (current-error-port)
+                              run-cmd)])
+        (parameterize ([current-output-port (list-ref p 1)])
+          (apply preprocess files))
+        (close-output-port (list-ref p 1))
+        ((list-ref p 4) 'wait)
+        (set! exit-code ((list-ref p 4) 'exit-code)))]
+     [(and run-cmd (not (or (= 1 (length files)) output)))
+      (error 'mzpp "cannot run a command that expects a filename with ~a"
+             "multiple input files and no output name")]
+     [(and run-cmd (not output))
+      (let* ([file (car files)]
+             [temp (format "~a-mzpp-temporary" file)])
+        (when (file-exists? temp)
+          (error 'mzpp "~s already exists!" temp))
+        (dynamic-wind
+          (lambda () (rename-file-or-directory file temp))
+          (lambda ()
+            (with-output-to-file file (lambda () (preprocess temp)))
+            (do-run-subst file))
+          (lambda ()
+            (delete-file file)
+            (rename-file-or-directory temp file))))]
+     [output
+      (with-output-to-file output (lambda () (apply preprocess files)) 'replace)
+      (when run-cmd (do-run-subst output))]
+     [else (apply preprocess files)])
+    (exit exit-code)))
+
+)
diff --git a/collects/preprocessor/pp-utils.ss b/collects/preprocessor/pp-utils.ss
new file mode 100644
index 0000000000..0b6bdac7a6
--- /dev/null
+++ b/collects/preprocessor/pp-utils.ss
@@ -0,0 +1,16 @@
+(module pp-utils mzscheme
+
+(provide stdin stdout stderr cd)
+(define stdin  current-input-port)
+(define stdout current-output-port)
+(define stderr current-error-port)
+(define cd     current-directory)
+
+(provide current-file)
+(define current-file (make-parameter #f))
+
+(provide add-eval do-evals)
+(define evals (make-parameter '()))
+(define (add-eval expr) (evals (cons expr (evals))))
+(define (do-evals) (for-each eval (reverse (evals))))
+)
diff --git a/collects/profj/ast.ss b/collects/profj/ast.ss
new file mode 100644
index 0000000000..2b4702234c
--- /dev/null
+++ b/collects/profj/ast.ss
@@ -0,0 +1,287 @@
+;;Kathy Gray, December 2001
+;;Abstract syntax tree for Java
+
+#cs
+(module ast mzscheme
+  
+  ;Macro to allow structure definition and provision
+  (define-syntax p-define-struct
+    (syntax-rules ()
+	          [(_ (name inherit) fields)
+		   (begin
+		     (provide (struct name fields))
+                     (define-struct (name inherit) fields (make-inspector)))]
+                  [(_ name fields)
+                   (begin
+                     (provide (struct name fields))
+                     (define-struct name fields (make-inspector)))]))
+
+  
+  ;(make-src int int int int loc)
+  (p-define-struct src (line col pos span file))
+  
+  ;;(make-package (U #f name) (list import) (list (U class-def interface-def)))
+  (p-define-struct package (name imports defs))
+
+  ;;(make-name id (list id) src)
+  (p-define-struct name (id path src))
+  
+  ;;(make-id string src)
+  (p-define-struct id (string src))
+  
+  ;; import java.lang.* -> (make-import (make-name "lang" `("java") ...) #t ...)
+  ;;(make-import name bool src src string)
+  (p-define-struct import (name star key-src src file))
+  
+  (provide def-name)
+  (define (def-name d)
+    (header-id (def-header d)))
+  
+  ;;(make-def header (list member) src src string symbol (list req) symbol (list id))
+  (p-define-struct def (header members key-src src file level uses kind closure-args))
+  
+  ;;(make-class-def header (list member) src src string symbol (list req) symbol)
+  ;; members in file order
+  (p-define-struct (class-def def) ())
+
+  ;;(make-interface-def header (list member) src src string symbol (list req) symbol)
+  (p-define-struct (interface-def def) ())
+  
+  ;;(make-req string (list string))
+  (p-define-struct req (class path))
+  
+  ;;(make-header id (list modifier) (list name) (list name) (list gj-info) src)
+  (p-define-struct header (id modifiers extends implements type-parms src))
+  
+  ;;(make-modifier symbol src)
+  (p-define-struct modifier (kind src))
+    
+  ;;member = var-decl
+  ;;       | var-init
+  ;;       | method
+  ;;       | initialize
+  ;;       | class-def
+  ;;       | interface-def
+  
+  ;;(make-type-spec (U name type-var symbol) int src)
+  ;; dim is for array dimensions
+  (p-define-struct type-spec (name dim src))
+  
+  ;;(make-type-var symbol (U #f type-spec) src)
+  (p-define-struct type-var (name bound src))
+
+  ;;Code for accessing fields: var-decl and var-init
+  (provide field? field-name field-modifiers field-type field-src)
+  (define (field? v) (or (var-decl? v) (var-init? v)))
+  (define (field-name v) (var-decl-name (if (var-init? v) (var-init-var-decl v) v)))
+  (define (field-modifiers v) (var-decl-modifiers (if (var-init? v) (var-init-var-decl v) v)))
+  (define (field-type v) (var-decl-type (if (var-init? v) (var-init-var-decl v) v)))
+  (define (field-src v) (var-decl-src (if (var-init? v) (var-init-var-decl v) v)))
+  
+  ;;(make-var-decl id (list modifier) type-spec src)
+  (p-define-struct var-decl (name modifiers type src))
+
+  ;;(make-var-init var-decl (U array-init expression) src)
+  (p-define-struct var-init (var-decl init src))
+  
+  ;;(make-array-init (list (U expression array-init)) src)
+  (p-define-struct array-init (vals src))
+  
+  ;;(make-method (list modifier) type-spec null id (list var-decl) (list name) Statement bool method-record src)
+  (p-define-struct method (modifiers type type-parms name parms throws body all-tail? rec src))
+  
+  ;;(make-initialize bool block src)
+  (p-define-struct initialize (static block src))
+
+  (provide statement?)
+  
+  ;statement? 'a -> bool
+  (define (statement? stmt)
+    (or (ifS? stmt) (throw? stmt) (return? stmt) (while? stmt) (doS? stmt)
+        (for? stmt) (try? stmt) (switch? stmt) (block? stmt) (break? stmt)
+        (continue? stmt) (label? stmt) (synchronized? stmt) (statement-expression? stmt)))
+    
+  ;statement => if
+  ;           | throw
+  ;           | return 
+  ;           | while
+  ;           | do
+  ;           | for
+  ;           | try
+  ;           | switch
+  ;           | block
+  ;           | break
+  ;           | continue
+  ;           | label
+  ;           | synchronized
+  ;           | StatementExpression
+  
+  ;StatementExpression => call
+  ;                     |  post-expr
+  ;                     |  preExpr
+  ;                     |  assignment
+  ;                     |  class-alloc
+
+  ;(make-ifS Expression Statement Statement src src)
+  (p-define-struct ifS (cond then else key-src src))
+  
+  ;(make-throw Expression src src)
+  (p-define-struct throw (expr key-src src))
+
+  ;(make-return Expression boolean src)
+  (p-define-struct return (expr in-tail? src))
+  
+  ;(make-while Expression Statement src)
+  (p-define-struct while (cond loop src))
+  
+  ;(make-do Statement Expression src)
+  (p-define-struct doS (loop cond src))
+  
+  ;(make-for forInit Expression (list Expression) Statement src)
+  (p-define-struct for (init cond incr loop src))  
+
+  ;forInit => (list (U var-init var-decl))
+  ;         | (list StatementExpression)
+  
+  ;(make-try Block (list Catch) (U #f statement) src src)
+  (p-define-struct try (body catches finally key-src src))
+  
+  ;(make-catch var-decl statement src)
+  (p-define-struct catch (cond body src))
+  
+  ;(make-switch Expression CaseStatements src)
+  (p-define-struct switch (expr cases src))
+  
+  ;CaseStatements = (list case)
+  ;(make-case (list (U ConstantExpression `default)) (list (U var-decl var-init Statement)) src)
+  (p-define-struct caseS (constant body src))
+  
+  ;(make-block (list (U var-decl var-init Statement)) src)
+  (p-define-struct block (stmts src))
+  
+  ;(make-break (U #f id) src)
+  (p-define-struct break (label src))
+
+  ;(make-continue (U #f id) src)
+  (p-define-struct continue (label src))
+
+  ;(make-label id statement src)
+  (p-define-struct label (label stmt src))
+  
+  ;(make-synchronized expression statement src)
+  (p-define-struct synchronized (expr stmt src))
+
+  (provide statement-expression?)
+  ;statement-expression?: StatementExpression -> bool
+  (define (statement-expression? stmt)
+    (or (call? stmt)
+        (post-expr? stmt)
+        (pre-expr? stmt)
+        (unary? stmt)
+        (assignment? stmt)
+        (class-alloc? stmt)
+        (inner-alloc? stmt)))
+  
+  ;(make-expr (U #f type) src)
+  (p-define-struct expr (types src)) 
+
+  ;Expression => literal
+  ;           |  bin-op
+  ;           |  access
+  ;           |  special-name
+  ;           |  specified-this
+  ;           |  call
+  ;           |  class-alloc
+  ;           |  array-alloc
+  ;           |  cond-expression
+  ;           |  array-access
+  ;           |  post-expr
+  ;           |  pre-expr
+  ;           |  unary
+  ;           |  cast
+  ;           |  instanceof
+  ;           |  assignment
+
+  ;(make-literal (U #f type) src value)
+  (p-define-struct (literal expr) (val))
+  
+  ;value => number | string
+  
+  ;(make-bin-op (U #f type) src binary-op Expression Expression src)
+  (p-define-struct (bin-op expr) (op left right key-src))
+  
+  ;binary-op => + - * / % << >> >>> < > <= >= == != & ^ or && oror 
+  
+  ;(make-access (U #f type) src (U (list id) field-access local-access))
+  ;Types before check
+  ;After check, (list id) -> (U field-access local-access)
+  (p-define-struct (access expr) (name))
+  
+  ;(make-field-access (U Expression #f) id var-access)
+  (p-define-struct field-access (object field access))
+  
+  ;;(make-var-access bool bool bool symbol string)
+  (p-define-struct var-access (static? final? init? access class))
+  
+  ;(make-local-access id)
+  (p-define-struct local-access (name))
+  
+  ;(make-special-name (U #f type) src string)
+  (p-define-struct (special-name expr) (name))
+  
+  ;(make-specified-this (U #f type) src name (U string #f))
+  (p-define-struct (specified-this expr) (class var))
+  
+  ;(make-call (U #f type) src (U #f expression) MethodName (list Expression) (U #f method-record))
+  (p-define-struct (call expr) (expr method-name args method-record))
+  
+  ;MethodName => special-name
+  ;           |  id
+  
+  ;(make-class-alloc (U #f type) src name (list Expression) (U #f method-record) bool)
+  (p-define-struct (class-alloc expr) (name args ctor-record class-inner? local-inner?))
+  
+  ;(make-inner-alloc (U #f type) src expr name (list Expression) (U #f method-record))
+  (p-define-struct (inner-alloc expr) (obj name args ctor-record))
+  
+  ;(make-array-alloc (U #f type) src type-spec (list Expression) int)
+  (p-define-struct (array-alloc expr) (name size dim))
+
+  ;;(make-array-alloc-init (U #f type) src type-spec int array-init)
+  (p-define-struct (array-alloc-init expr) (name dim init))
+
+  
+  ;(make-cond-expression (U #f type) src Expression Expression Expression src)
+  (p-define-struct (cond-expression expr) (cond then else key-src))
+  
+  ;(make-array-access (U #f type) src expression Expression)
+  (p-define-struct (array-access expr) (name index))
+  
+  ;(make-post-expr (U #f type) src Expression PrePost src)
+  (p-define-struct (post-expr expr) (expr op key-src))
+  
+  ;PrePost => ++ --
+  
+  ;(make-pre-expr (U #f type) src PrePost Expression src)
+  (p-define-struct (pre-expr expr) (op expr key-src))
+  
+  ;(make-unary (U #f type) src UnaryOp Expression src)
+  (p-define-struct (unary expr) (op expr key-src))
+  
+  ;UnaryOp => + - ~ !
+  
+  ;(make-cast (U #f type) src type-spec Expression)
+  (p-define-struct (cast expr) (type expr))
+  
+  ;(make-instanceof (U #f type) src Expression type-spec src)
+  (p-define-struct (instanceof expr) (expr type key))
+  
+  ;Note: lefthand side might be incorrect
+  ;(make-assignment (U #f type) src (U access array-access) symbol Expression src)
+  (p-define-struct (assignment expr) (left op right key-src))
+  
+  ;Op -> = *= /= %= += -= <<= >>= >>>= &= ^= or=  
+ 
+  
+  
+)
diff --git a/collects/profj/build-info.ss b/collects/profj/build-info.ss
new file mode 100644
index 0000000000..3e48c2d7da
--- /dev/null
+++ b/collects/profj/build-info.ss
@@ -0,0 +1,1554 @@
+(module build-info mzscheme
+  
+  (require (lib "class.ss") (lib "file.ss") (lib "list.ss")
+           "ast.ss" "types.ss" "error-messaging.ss" "parameters.ss" 
+           "restrictions.ss" "parser.ss" "profj-pref.ss")
+
+  (provide build-info build-interactions-info build-inner-info find-implicit-import load-lang)
+  
+  ;-------------------------------------------------------------------------------
+  ;General helper functions for building information
+  
+  ;; name->list: name -> (list string)
+  (define (name->list n)
+    (cons (id-string (name-id n)) (map id-string (name-path n))))
+  
+  ;same-base-dir?: path path -> bool
+  (define (same-base-dir? full sub)
+    (with-handlers ((exn? (lambda (e) #f)))
+      (letrec ((full-ex (explode-path full))
+               (sub-ex (explode-path sub))
+               (first-of?
+                (lambda (full sub)
+                  (or (null? sub)
+                      (and (equal? (car full) (car sub))
+                           (first-of? (cdr full) (cdr sub)))))))
+        (and (< (length sub-ex) (length full-ex))
+             (first-of? full-ex sub-ex)))))
+  
+  ;build-require-syntax: string (list string) dir bool bool-> (list syntax)
+  (define (build-require-syntax name path dir local? scheme?)
+    (let* ((syn (lambda (acc) (datum->syntax-object #f acc #f)))
+           (profj-lib? (ormap (lambda (p) (same-base-dir? dir p))
+                              (map (lambda (p) (build-path p "profj" "libs"))
+                                   (current-library-collection-paths))))
+           (htdch-lib? (ormap (lambda (p) (same-base-dir? dir p))
+                              (map (lambda (p) (build-path p "htdch"))
+                                   (current-library-collection-paths))))
+           (access (lambda (name)
+                     (cond
+                       (profj-lib? `(lib ,name "profj" "libs" ,@path))
+                       (htdch-lib? `(lib ,name "htdch" ,@path))
+                       ((and local? (not (to-file))) name)
+                       (else `(file ,(path->string (build-path dir name)))))))
+           (make-name (lambda ()
+                        (if (or (not local?) profj-lib? htdch-lib? (to-file))
+                            (string-append name ".ss")
+                            (string->symbol name)))))
+      (if scheme?
+          (list (syn `(prefix ,(string->symbol
+                                (apply string-append
+                                       (append (map (lambda (s) (string-append s ".")) path)
+                                               (list name "-"))))
+                              ,(syn (access (make-name)))))
+                (syn `(prefix ,(string->symbol (string-append name "-")) ,(syn (access (make-name))))))
+          (list (syn `(prefix ,(string->symbol (apply string-append
+                                                      (map (lambda (s) (string-append s ".")) path)))
+                              ,(syn (access (make-name)))))
+                (syn (access (make-name)))))))
+  
+  ;-------------------------------------------------------------------------------
+  ;Main functions
+
+  ;; build-info: package symbol type-records (opt symbol)-> void
+  (define (build-info prog level type-recs . args)
+    (let* ((pname (if (package-name prog)
+                      (append (map id-string (name-path (package-name prog)))
+                              (list (id-string (name-id (package-name prog)))))
+                      null))
+           (lang-pack `("java" "lang"))
+           (lang (filter (lambda (class)
+                           (not (forbidden-lang-class? class level)))                  
+                         (send type-recs get-package-contents lang-pack 
+                               (lambda () (error 'type-recs "Internal error: Type record not set with lang")))))
+           (defs (let loop ((cur-defs (package-defs prog)))
+                   (cond
+                     ((null? cur-defs) null)
+                     ((def? (car cur-defs)) (cons (car cur-defs) (loop (cdr cur-defs))))
+                     (else 
+                      (when (execution?) 
+                        (send type-recs add-interactions-box (car cur-defs)))
+                      (loop (cdr cur-defs))))))
+           (current-loc (cond
+                          ((not (null? defs)) (def-file (car defs)))
+                          ((not (null? (package-imports prog))) 
+                           (import-file (car (package-imports prog)))))))
+      (set-package-defs! prog defs)
+      
+      ;Add lang to local environment
+      (for-each (lambda (class) (send type-recs add-to-env class lang-pack current-loc)) lang)
+      (for-each (lambda (class) (send type-recs add-class-req (cons class lang-pack) #f current-loc)) lang)
+      (send type-recs add-class-req (list 'array) #f current-loc)
+      
+      ;Set location for type error messages
+      (build-info-location current-loc)      
+      
+      (let loop ((cur-defs defs))
+        (unless (null? cur-defs)
+          (when (member (id-string (def-name (car cur-defs)))
+                        (map (lambda (d) (id-string (def-name d))) (cdr cur-defs)))
+            (repeated-def-name-error (def-name (car cur-defs))
+                                     (class-def? (car cur-defs))
+                                     level
+                                     (id-src (def-name (car cur-defs)))))
+          (loop (cdr cur-defs))))
+                        
+      ;Add all defs in this file to environment
+      (for-each (lambda (def) (add-def-info def pname type-recs current-loc (null? args) level)) defs)
+
+      ;Set the package of the interactions window to that of the definitions window
+      (when (execution?) 
+        (send type-recs set-interactions-package pname)
+        (send type-recs set-execution-loc! current-loc))
+      
+      ;All further definitions do not come from the execution window
+      (execution? #f)
+      
+      ;Add package information to environment
+      (when (memq level '(advanced full))
+        (add-my-package type-recs pname (package-defs prog) current-loc level))
+      
+      ;Add import information
+      (for-each (lambda (imp) (process-import type-recs imp level)) (package-imports prog))
+
+      ;Build jinfo information for each def in this file
+      (for-each (lambda (def) (process-class/iface def pname type-recs (null? args) #t level)) defs)
+
+      ;Add these to the list for type checking
+      (add-to-queue defs)))
+
+  ;build-interactions-info: ast location type-records -> void
+  (define (build-interactions-info prog level loc type-recs)
+    (build-info-location loc)
+    (send type-recs give-interaction-execution-names)
+    (if (list? prog)
+        (for-each (lambda (f) (build-interactions-info f level loc type-recs)) prog)
+        (when (field? prog)
+          (send type-recs add-interactions-field 
+                (process-field prog '("scheme-interactions") type-recs level)))))
+  
+  ;add-def-info: def (list string) type-records loc bool symbol . (list syntax)-> void
+  (define (add-def-info def pname type-recs current-loc look-in-table level . inner-req)
+    (let* ((name (id-string (def-name def)))
+           (defname (cons name pname))
+           (native-name (cons (string-append name "-native-methods") pname))
+           (dir (dir-path-path (find-directory pname (lambda () 
+                                                       (make-dir-path (build-path 'same) #f))))))
+      (unless (memq 'private (map modifier-kind (header-modifiers (def-header def))))
+        (send type-recs add-to-env name pname current-loc)
+        (when (execution?) (send type-recs add-to-env name pname 'interactions)))
+      (let ((req-syn (if (null? inner-req) (build-require-syntax name pname dir #t #f) (car inner-req))))
+        (send type-recs add-class-req defname #f current-loc)
+        (send type-recs add-require-syntax defname req-syn)
+        (send type-recs add-class-req native-name #f current-loc)
+        (send type-recs add-require-syntax native-name 
+              (build-require-syntax (car native-name) pname dir #f #f))
+        (send type-recs add-to-records defname
+              (lambda () (process-class/iface def pname type-recs look-in-table #t level)))
+        ;;get info for Inner member classes
+        (let ([prefix (format "~a." name)])
+          (for-each (lambda (member)
+                      (when (class-def? member)
+                        ;; Adjust id to attach the prefix:
+                        (let ([id (def-name member)])
+                          (set-id-string! id (string-append prefix (id-string id))))
+                        (add-def-info member pname type-recs current-loc #f (def-level def) req-syn)))
+                    (def-members def))))))
+  
+  ;build-inner-info: def (U void string) (list string) symbol type-records loc bool -> class-record
+  (define (build-inner-info def unique-name pname level type-recs current-loc look-in-table?)
+    ;(add-def-info def pname type-recs current-loc look-in-table? level)
+    (let ((record (process-class/iface def pname type-recs #f #f level)))
+      (when (string? unique-name) (set-class-record-name! record (list unique-name)))
+      (send type-recs add-to-records 
+            (if (eq? (def-kind def) 'statement) (list unique-name) (id-string (def-name def)))
+            record)
+      record))
+  
+  ;add-to-queue: (list definition) -> void
+  (define (add-to-queue defs)
+    (check-list (append defs (check-list))))  
+  
+  ;-----------------------------------------------------------------------------------
+  ;Import processing/General loading
+
+  ;;process-import: type-records import symbol -> void
+  (define (process-import type-recs imp level)
+    (let* ((star? (import-star imp))
+           (file (import-file imp))
+           (name (id-string (name-id (import-name imp))))
+           (name-path (map id-string (name-path (import-name imp))))
+           (path (if star? (append name-path (list name)) name-path))
+           (err (lambda () (import-error (import-name imp) (import-src imp)))))
+      (if star?
+          (let ((classes (send type-recs get-package-contents path (lambda () #f))))
+            (if classes
+                (for-each (lambda (class) (send type-recs add-to-env class path file)) classes)
+                (let* ((dir (find-directory path err))
+                       (classes (get-class-list dir)))
+                  (for-each (lambda (class) 
+                              (import-class class path dir file type-recs level (import-src imp) #t))
+                            classes)
+                  (send type-recs add-package-contents path classes))))
+          (import-class name path (find-directory path err) file type-recs level (import-src imp) #t))))
+  
+  ;import-class: string (list string) dir-path location type-records symbol src bool-> void
+  (define (import-class class path in-dir loc type-recs level caller-src add-to-env)
+    (let* ((dir (dir-path-path in-dir))
+           (class-name (cons class path))
+           (type-path (build-path dir "compiled" (string-append class ".jinfo")))
+           (new-level (box level))
+           (class-exists? (check-file-exists? class dir new-level))
+           (suffix (case (unbox new-level)
+                     ((beginner) ".bjava")
+                     ((intermediate) ".ijava")
+                     ((advanced) ".ajava")
+                     ((full) ".java")))
+           (file-path (build-path dir (string-append class suffix))))
+      (cond
+        ((is-import-restricted? class path level) (used-restricted-import class path caller-src))
+        ((send type-recs get-class-record class-name #f (lambda () #f)) void)
+        ((and (file-exists? type-path)
+              (or (core? class-name) (older-than? file-path type-path)) (read-record type-path))
+         =>
+         (lambda (record)
+           (send type-recs add-class-record record)
+           (send type-recs add-require-syntax class-name (build-require-syntax class path dir #f #f))
+           (map (lambda (ancestor)
+                  (import-class (car ancestor) (cdr ancestor)
+                                (find-directory 
+                                 (cdr ancestor)
+                                 (lambda () (error 'internal-error "Compiled parent's directory is not found")))
+                                loc type-recs level caller-src add-to-env))
+                (append (class-record-parents record) (class-record-ifaces record)))
+           ))
+        ((and (scheme-ok?) (dir-path-scheme? in-dir) (check-scheme-file-exists? class dir))
+         (send type-recs add-to-records class-name (make-scheme-record class (cdr path) dir null))
+         (send type-recs add-require-syntax class-name (build-require-syntax class path dir #f #t)))
+        (class-exists?
+         (send type-recs add-to-records 
+               class-name
+               (lambda () 
+                 (let* ((location (string-append class suffix))
+                        (ast (call-with-input-file file-path (lambda (p) (parse p location (unbox new-level))))))
+                   (send type-recs set-compilation-location location (build-path dir "compiled"))
+                   (build-info ast (unbox new-level) type-recs 'not_look_up)
+                   (send type-recs get-class-record class-name #f (lambda () 'internal-error "Failed to add record"))
+                   )))
+         (send type-recs add-require-syntax class-name (build-require-syntax class path dir #t #f)))
+        (else (file-error 'file (cons class path) caller-src level)))
+      (when add-to-env (send type-recs add-to-env class path loc))
+      (send type-recs add-class-req class-name (not add-to-env) loc)))
+
+  ;determines if file a is older than file b
+  ;older-than?: path path -> bool
+  (define (older-than? file-a file-b)
+    (and (file-exists? file-a)
+         (file-exists? file-b)
+         (<= (file-or-directory-modify-seconds file-a)
+            (file-or-directory-modify-seconds file-b))))
+  
+  ;core: (list string) -> bool
+  ;Determines if the given class is a core class not written in Java
+  (define (core? class)
+    (member class `(("Object" "java" "lang")
+                   ("String" "java" "lang")
+                   ("Throwable" "java" "lang")
+                   ("Comparable" "java" "lang")
+                   ("Serializable" "java" "io"))))
+  
+  ;check-file-exists?: string path box -> bool
+  ;side-effect: modifies contents of box
+  (define (check-file-exists? class path level)
+    (let ((exists? 
+           (lambda (suffix lang)
+             (and (file-exists? (build-path path (string-append class suffix)))
+                  (set-box! level lang)))))
+      (or (exists? ".java" 'full)
+          (exists? ".bjava" 'beginner)
+          (exists? ".ijava" 'intermediate)
+          (exists? ".ajava" 'advanced))))
+    
+  ;check-scheme-file-exists? string path -> bool
+  (define (check-scheme-file-exists? name path)
+    (or (file-exists? (build-path path (string-append name ".ss")))
+        (file-exists? (build-path path (string-append name ".scm")))))
+  
+  (define (create-scheme-type-rec mod-name req-path) 'scheme-types)
+    
+  ;add-my-package: type-records (list string) (list defs) loc symbol-> void
+  (define (add-my-package type-recs package defs loc level)
+    (let* ((dir (find-directory package 
+                                (lambda () 
+                                  (let-values (((base cur dir?) (split-path (current-directory))))
+                                    (and (equal? (apply build-path package) cur)
+                                         (make-dir-path (build-path 'same) #f))))))
+           (classes (if dir (get-class-list dir) null)))
+      ;(printf "~n~nadd-my-package package ~a~n" package)
+      ;(printf "add-my-package: dir ~a class ~a~n" dir classes)
+      (for-each (lambda (c) 
+                  (import-class c package dir loc type-recs level #f #t)
+                  (send type-recs add-to-env c package loc))
+                (filter (lambda (c) (not (contained-in? defs c))) classes))
+      (send type-recs add-package-contents package classes)))
+      
+  ;contained-in? (list definition) definition -> bool
+  (define (contained-in? defs class)
+    (and (not (null? defs))
+         (or (equal? class (id-string (def-name (car defs))))
+             (contained-in? (cdr defs) class))))
+  
+  ;find-implicit-import: (list string) type-records symbol src-> ( -> record )
+  (define (find-implicit-import name type-recs level call-src)
+    (lambda ()
+      (let ((original-loc (send type-recs get-location))
+            (dir (find-directory (cdr name) (lambda () (file-error 'dir name call-src level)))))
+        (when (memq level '(beginner intermediate))
+          (file-error 'file name call-src level))
+        (import-class (car name) (cdr name) dir original-loc type-recs level call-src #f)
+        (begin0 (get-record (send type-recs get-class-record name) type-recs)
+                (send type-recs set-location! original-loc)))))
+  
+  ;(make-directory path bool)
+  (define-struct dir-path (path scheme?))
+  
+  ;find-directory: (list string) ( -> void) -> dir-path
+  (define (find-directory path fail)
+    (cond
+      ((null? path) (make-dir-path (build-path 'same) #f))
+      ((and (scheme-ok?) (equal? (car path) "scheme"))
+       (cond
+         ((null? (cdr path)) (make-dir-path (build-path 'same) #t))
+         ((not (equal? (cadr path) "lib")) 
+          (let ((dir (find-directory (cdr path) fail)))
+            (make-dir-path dir #t)))
+         ((and (equal? (cadr path) "lib") (not (null? (cddr path))))
+          (make-dir-path (apply collection-path (cddr path)) #t))
+         (else (make-dir-path (list "mzlib") #t))))
+      (else
+       (when (null? (classpath)) (classpath (get-classpath)))
+       (let-values (((search)
+                     (lambda ()
+                       (let loop ((paths (classpath)))
+                         (cond
+                           ((null? paths) (fail))
+                            ((and (directory-exists? (build-path (car paths) 
+                                                                 (apply build-path path))))
+                             (make-dir-path (build-path (car paths) (apply build-path path)) #f))
+                            (else (loop (cdr paths)))))))
+                    ((cur-path-base cur-path dir?) 
+                     (split-path (simplify-path (path->complete-path (build-path 'same))))))
+         (cond
+           ((equal? (car path) (path->string cur-path))
+            (if (null? (cdr path))
+                (make-dir-path (build-path 'same) #f)
+                (if (directory-exists? (build-path (build-path 'same) (apply build-path (cdr path))))
+                    (make-dir-path (build-path (build-path 'same) (apply build-path (cdr path))) #f)
+                    (search))))
+           (else (search)))))))
+
+  ;get-class-list: dir-path -> (list string)
+  (define (get-class-list dir)
+    (if (and (scheme-ok?) (dir-path-scheme? dir))
+        (filter (lambda (f) (or (equal? (filename-extension f) #".ss")
+                                (equal? (filename-extension f) #".scm")))
+                (directory-list (dir-path-path dir)))
+        (filter (lambda (c-name) (not (equal? c-name "")))
+                (map (lambda (fn) (substring fn 0 (- (string-length fn) 5)))
+                     (map path->string
+                          (filter (lambda (f) (equal? (filename-extension f) #"java"))
+                                  (directory-list (dir-path-path dir))))))))
+  
+  ;load-lang: type-records -> void (adds lang to type-recs)
+  (define (load-lang type-recs)
+    (let* ((lang `("java" "lang"))
+           (dir (find-directory lang (lambda () (error 'load-lang "Internal-error: Lang not accessible"))))
+           (class-list (map (lambda (fn) (substring fn 0 (- (string-length fn) 6)))
+                            (map path->string
+                                 (filter (lambda (f) (equal? (filename-extension f) #"jinfo"))
+                                         (directory-list (build-path (dir-path-path dir) "compiled"))))))
+           (array (datum->syntax-object #f `(lib "array.ss" "profj" "libs" "java" "lang") #f)))
+      (send type-recs add-package-contents lang class-list)
+      (for-each (lambda (c) (import-class c lang dir #f type-recs 'full #f #f)) class-list)
+      (send type-recs add-require-syntax (list 'array) (list array array))
+      
+      ;Add lang to interactions environment
+      (for-each (lambda (class) (send type-recs add-to-env class lang 'interactions)) class-list)
+      (send type-recs set-location! 'interactions)
+      (for-each (lambda (class) (send type-recs add-class-req (cons class lang) #f 'interactions)) class-list)
+      (send type-recs add-class-req (list 'array) #f 'interactions)
+      ))
+        
+  ;------------------------------------------------------------------------------------
+  ;Functions for processing classes and interfaces
+  
+  ;; process-class/iface: (U class-def interface-def) (list string) type-records bool bool symbol -> class-record
+  (define (process-class/iface ci package-name type-recs look-in-table put-in-table level)
+    (cond
+      ((interface-def? ci) 
+       (process-interface ci package-name type-recs look-in-table put-in-table level))
+      ((class-def? ci) 
+       (process-class ci package-name type-recs look-in-table put-in-table level))))
+  
+  ;;get-parent-record: (list string) name (list string) type-records (list string) -> record
+  (define (get-parent-record name n child-name level type-recs)
+    (when (equal? name child-name)
+      (dependence-error 'immediate (name-id n) (name-src n)))
+    (let ((record (send type-recs get-class-record name)))
+      (cond
+        ((class-record? record) record)
+        ((procedure? record) 
+         (let ((cur-src-loc (build-info-location)))
+           (begin0 (get-record record type-recs)
+                   (build-info-location cur-src-loc))))
+        ((eq? record 'in-progress)
+         (dependence-error 'cycle (name-id n) (name-src n)))
+        (else 
+         (let ((cur-src-loc (build-info-location)))
+           (begin0
+             (get-record (find-implicit-import name type-recs level (name-src n)) type-recs)
+             (build-info-location cur-src-loc)))))))
+  
+  (define (class-specific-field? field)
+    (not (memq 'private 
+               (field-record-modifiers field))))
+  
+  (define (class-specific-method? method new-methods)
+    (not (or (memq 'static (method-record-modifiers method))
+             (memq 'private (method-record-modifiers method))
+             (eq? 'ctor (method-record-rtype method))
+             (over-riden? method new-methods))))
+    
+  (define (over-riden? m listm)
+    (and (not (null? listm))
+         (let ((m2 (car listm)))
+           (or (and (equal? (method-record-name m)
+                            (method-record-name m2))
+                    (type=? (method-record-rtype m)
+                            (method-record-rtype m2))
+                    (and (= (length (method-record-atypes m))
+                            (length (method-record-atypes m2)))
+                         (andmap type=? (method-record-atypes m)
+                                 (method-record-atypes m2)))
+                    (and (= (length (method-record-modifiers m))
+                            (length (method-record-modifiers m2)))
+                         (andmap eq? (method-record-modifiers m)
+                                     (method-record-modifiers m2))))
+               (over-riden? m (cdr listm))))))
+  
+  ;; process-class: class-def (list string) type-records bool bool symbol -> class-record
+  (define (process-class class package-name type-recs look-in-table? put-in-table? level)
+    (let* ((info (def-header class))
+           (cname (cons (id-string (header-id info)) package-name)))
+      (send type-recs set-location! (def-file class))
+      (let ((build-record
+             (lambda ()
+               (when put-in-table? (send type-recs add-to-records cname 'in-progress))
+               (let* ((super (if (null? (header-extends info)) null (car (header-extends info))))
+                      (super-name (if (null? super) 
+                                      '("Object" "java" "lang") 
+                                      (if (null? (name-path super))
+                                          (cons (id-string (name-id super))
+                                                (send type-recs lookup-path (id-string (name-id super)) (lambda () null)))
+                                          (name->list super))))
+                      (super-record (get-parent-record super-name super cname level type-recs))
+                      (iface-records (map (lambda (i)
+                                            (get-parent-record (name->list i) i #f level type-recs))
+                                          (header-implements info)))
+                      (members (def-members class))
+                      (modifiers (header-modifiers info))
+                      (test-mods (map modifier-kind modifiers))
+                      (reqs (map (lambda (name-list)
+                                   (if (= (length name-list) 1)
+                                       (make-req (car name-list) 
+                                                 (send type-recs lookup-path (car name-list) (lambda () null)))
+                                       (make-req (car name-list) (cdr name-list))))
+                                 (cons super-name (map name->list (header-implements info))))))
+                 
+                 (send type-recs set-location! (def-file class))
+                 (set-def-uses! class reqs)
+                 
+                 (when (eq? level 'full)
+                   (when (memq 'final (class-record-modifiers super-record))
+                     (extension-error 'final (header-id info) super (id-src super))))
+                   
+                 (unless (class-record-class? super-record)
+                   (extension-error 'class-iface (header-id info) super (name-src super)))
+                 
+                 (when (ormap class-record-class? iface-records)
+                   (letrec ((find-class
+                             (lambda (recs names)
+                               (if (class-record-class? (car recs))
+                                   (car names)
+                                   (find-class (cdr recs) (cdr names)))))
+                            (name (find-class iface-records (header-implements info))))
+                     (extension-error 'implement-class (header-id info) name (name-src name))))
+                 
+                 (valid-iface-implement? iface-records (header-implements info))
+                                  
+                 (let*-values (((old-methods) (class-record-methods super-record))
+                               ((f m i) 
+                                (if (memq 'strictfp test-mods)
+                                    (process-members members old-methods cname type-recs level 
+                                                     (find-strictfp modifiers))
+                                    (process-members members old-methods cname type-recs level)))
+                               ((ctor?) (has-ctor? m)))
+                                      
+                   (unless ctor?
+                     (when (and (eq? level 'beginner) (not (memq 'abstract test-mods)))
+                       (beginner-ctor-error 'none (header-id info) (id-src (header-id info))))
+                     (add-ctor class (lambda (rec) (set! m (cons rec m))) old-methods (header-id info) level))
+                   
+                   (when (and ctor? (eq? level 'beginner) (memq 'abstract test-mods))
+                     (beginner-ctor-error 'abstract (header-id info) (id-src (header-id info))))
+
+                   (valid-field-names? (if (memq level '(beginner intermediate advanced)) 
+                                           (append f (class-record-fields super-record)) f)
+                                       members m level type-recs)
+                   (valid-method-sigs? m members level type-recs)
+
+                   (when (not (memq 'abstract test-mods))
+                     (and (class-fully-implemented? super-record super 
+                                                    iface-records (header-implements info)
+                                                    m level)
+                          (no-abstract-methods m members level type-recs)))
+                   
+                   (valid-inherited-methods? (cons super-record iface-records)
+                                             (cons (if (null? super)
+                                                       (make-name (make-id "Object" #f) null #f)
+                                                       super)
+                                                   (header-implements info))
+                                             level
+                                             type-recs)
+                   (check-current-methods (cons super-record iface-records)
+                                          m
+                                          members
+                                          level
+                                          type-recs)
+                   
+                   (let ((record
+                          (make-class-record 
+                           cname
+                           (check-class-modifiers level (def-kind class) modifiers)
+                           #t
+                           #t
+                           (append f (filter class-specific-field? (class-record-fields super-record)))
+                           (append m (filter (lambda (meth)
+                                               (class-specific-method? meth m))
+                                             (class-record-methods super-record)))
+                           (append i (filter (lambda (i-r)
+                                               (not (memq 'private (inner-record-modifiers i-r))))
+                                             (class-record-inners super-record)))
+                           (cons super-name (class-record-parents super-record))
+                           (map (lambda (iface)
+                                  (if (null? (cdr iface))
+                                      (cons (car iface) 
+                                            (send type-recs lookup-path (car iface) (lambda () null)))
+                                      iface))
+                                (filter (lambda (iface) (not (null? iface)))
+                                        (append (map name->list (header-implements info))
+                                                (map class-record-parents iface-records)
+                                                (class-record-ifaces super-record)))))))
+                     (when put-in-table? (send type-recs add-class-record record))
+                     
+                     (for-each (lambda (member)
+			     (when (def? member)
+			       (process-class/iface member package-name type-recs #f put-in-table? level)))
+			   members)
+                     
+                     record))))))
+        (cond
+          ((class-record? (send type-recs get-class-record cname)) => 
+           (lambda (rec) rec))
+          (look-in-table?
+           (get-record (send type-recs get-class-record cname #f build-record) type-recs))
+          (else (build-record))))))
+  
+  ;find-strictfp (list modifier) -> modifier
+  (define (find-strictfp mods)
+    (if (null? mods)
+        null
+        (if (eq? 'strictfp (modifier-kind (car mods)))
+            (car mods)
+            (find-strictfp (cdr mods)))))
+  
+  ;has-ctor?: (list method-record)-> bool
+  (define (has-ctor? methods)
+    (and (not (null? methods))
+         (or (eq? (method-record-rtype (car methods)) 'ctor)
+             (has-ctor? (cdr methods)))))
+  
+  ;add-ctor: class-def (method-record -> void) (list method-record) id symbol-> void
+  (define (add-ctor class add-rec super-methods name level) 
+    (let ((super-ctor (find-default-ctor super-methods)))
+      (cond
+        ((not super-ctor)
+         (default-ctor-error 'non-accessible name (car (method-record-class (car super-methods))) (id-src name) level))
+        ((memq 'private (method-record-modifiers super-ctor))
+         (default-ctor-error 'private name (method-record-class super-ctor) (id-src name) level))
+        ((and (memq level '(advanced full))
+              (not (null? (method-record-throws super-ctor))))
+         (default-ctor-error 'throws name (method-record-class super-ctor) (id-src name) level))
+        (else
+         (let* ((rec (make-method-record (id-string name) `(public) 'ctor null null #f (list (id-string name))))
+                (method (make-method (list (make-modifier 'public #f))
+                                     (make-type-spec 'ctor 0 #f)
+                                     null
+                                     (make-id (id-string name) #f)
+                                     null
+                                     null
+                                     (make-block 
+                                     (list (make-call #f #f #f (make-special-name #f #f "super") null #f)) #f)
+                                    #t
+                                    rec
+                                    #f)))
+           (set-def-members! class (cons method (def-members class)))
+           (add-rec rec))))))
+
+  ;find-default-ctor: (list method-record) -> (U boolean method-record)
+  (define (find-default-ctor methods)
+    (and (not (null? methods))
+         (or (and (eq? (method-record-rtype (car methods)) 'ctor)
+                  (null? (method-record-atypes (car methods)))
+                  (car methods))
+             (find-default-ctor (cdr methods)))))
+  
+  ;; process-interface: interface-def (list string) type-records bool bool symbol -> class-record
+  (define (process-interface iface package-name type-recs look-in-table? put-in-table? level)
+    (let* ((info (def-header iface))
+           (iname (cons (id-string (header-id info)) package-name)))
+      (send type-recs set-location! (def-file iface))
+      (let ((build-record 
+             (lambda ()
+               (send type-recs add-to-records iname 'in-progress)
+               (let* ((super-names (map name->list (header-extends info)))
+                      (super-records (map (lambda (n sc) (get-parent-record n sc iname level type-recs))
+                                          super-names
+                                          (header-extends info)))
+                      (members (def-members iface))
+                      (reqs (map (lambda (name-list) (make-req (car name-list) (cdr name-list)))
+                                 super-names)))
+                 (send type-recs set-location! (def-file iface))
+                 (set-def-uses! iface reqs)                 
+                 
+                 (when (ormap class-record-class? super-records)
+                   (letrec ((find-class
+                             (lambda (recs names)
+                               (if (class-record-class? (car recs))
+                                   (car names)
+                                   (find-class (cdr recs) (cdr names)))))
+                            (name (find-class super-records (header-extends info))))
+                     (extension-error 'iface-class (header-id info) name (name-src name))))
+                 
+                 (valid-iface-extend? super-records (header-extends info))
+                 
+                 (let-values (((f m i) (process-members members null iname type-recs level)))
+                   
+                   (valid-field-names? f members m level type-recs)
+                   (valid-method-sigs? m members level type-recs)
+                   (valid-inherited-methods? super-records (header-extends info) level type-recs)
+                   (check-current-methods super-records m members level type-recs)
+                   
+                   (let ((record
+                          (make-class-record 
+                           iname
+                           (check-interface-modifiers level (header-modifiers info))
+                           #f
+                           #t
+                           (apply append (cons f (map class-record-fields super-records)))
+                           (apply append (cons m (map class-record-methods super-records)))
+                           (apply append (cons i (map class-record-inners super-records)))
+                           (apply append (cons super-names 
+                                               (map class-record-parents super-records)))
+                           null)))
+                     (send type-recs add-class-record record)
+                     record))))))
+        (if look-in-table?
+            (get-record (send type-recs get-class-record iname #f build-record) type-recs)
+            (build-record)))))
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;Code to check for conflicts in method/field/class naming (including types)
+  
+  (define (valid-iface-extend? records extends)
+    (or (null? records)
+        (and (memq (car records) (cdr records))
+             (extension-error 'ifaces #f (car extends) (name-src (car extends))))
+        (valid-iface-extend? (cdr records) (cdr extends))))
+  
+  (define (valid-iface-implement? records implements)
+    (or (null? records)
+        (and (memq (car records) (cdr records))
+             (extension-error 'implement #f (car implements) (name-src (car implements))))
+        (valid-iface-implement? (cdr records) (cdr implements))))
+  
+  ;valid-field-names? (list field-record) (list member) (list method-record) symbol type-records -> bool
+  (define (valid-field-names? fields members methods level type-recs)
+    (or (null? fields)
+        (and (field-member? (car fields) (cdr fields))
+             (let ((f (find-member (car fields) members level type-recs)))
+               (if (method? f)
+                   (field-name-error 'inherited-conflict-method
+                                     (method-name f)
+                                     level
+                                     (method-src f))
+                   (field-name-error 'field (field-name f) level (field-src f)))))
+        (and (memq level '(beginner intermediate))
+             (or (and (shared-name? (car fields) methods)
+                      (let ((f (find-member (car fields) members level type-recs)))
+                        (if (method? f)
+                            (field-name-error 'inherited-conflict-method
+                                              (method-name f)
+                                              level
+                                              (method-src f))
+                            (field-name-error 'method (field-name f) level (field-src f)))))
+                 (and (shared-class-name? (car fields) (send type-recs get-class-env))
+                      (let ((f (find-member (car fields) members level type-recs)))
+                        (if (method? f)
+                            (field-name-error 'inherited-conflict-method
+                                              (method-name f)
+                                              level
+                                              (method-src f))
+                            (field-name-error 'class (field-name f) level (field-src f)))))))
+        (valid-field-names? (cdr fields) members methods level type-recs)))
+  
+  ;field-member: field-record (list field-record) -> bool
+  (define (field-member? field fields)
+    (and (not (null? fields))
+         (or (equal? (field-record-name field)
+                     (field-record-name (car fields)))
+             (field-member? field (cdr fields)))))
+  
+  ;shared-name field-record (list method-record) -> bool
+  (define (shared-name? field methods)
+    (and (not (null? methods))
+         (or (equal? (field-record-name field)
+                     (method-record-name (car methods)))
+             (shared-name? field (cdr methods)))))
+  
+  ;shared-class-name?: (U field-record method-record) (list string) -> bool
+  (define (shared-class-name? member classes)
+    (and (not (null? classes))
+         (or (equal? ((if (field-record? member) field-record-name method-record-name) member)
+                      (car classes))
+             (shared-class-name? member (cdr classes)))))
+  
+  ;find-member: (U field-record method-record) (list member) symbol type-records -> member
+  (define (find-member member-record members level type-recs)
+    (when (null? members)
+      (printf "~a~n" member-record)
+      (error 'internal-error "Find-member given a member that is not contained in the member list"))
+    (cond
+      ((and (field-record? member-record)
+            (field? (car members)))
+       (if (equal? (id-string (field-name (car members)))
+                   (field-record-name member-record))
+           (car members)
+           (find-member member-record (cdr members) level type-recs)))
+      ((and (method-record? member-record)
+            (method? (car members)))
+       (if (and (equal? (id-string (method-name (car members)))
+                        (method-record-name member-record))
+                (= (length (method-record-atypes member-record))
+                   (length (method-parms (car members))))
+                (andmap type=?
+                        (method-record-atypes member-record)
+                        (map (lambda (t)
+                               (type-spec-to-type t (method-record-class member-record)  level type-recs))
+                             (map field-type (method-parms (car members)))))
+                (type=? (method-record-rtype member-record)
+                        (type-spec-to-type (method-type (car members)) (method-record-class member-record) level type-recs)))
+           (car members)
+           (find-member member-record (cdr members) level type-recs)))
+      ((memq level '(beginner intermediate advanced))
+       (let ((given-name ((if (field-record? member-record) field-record-name method-record-name) member-record))
+             (looking-at (id-string ((if (field? (car members)) field-name method-name) (car members)))))
+         (if (equal? given-name looking-at)
+             (car members)
+             (find-member member-record (cdr members) level type-recs))))
+      (else
+       (find-member member-record (cdr members) level type-recs))))
+  
+  ;valid-method-sigs? (list method-record) (list member) symbol type-records -> bool
+  (define (valid-method-sigs? methods members level type-recs)
+    (or (null? methods)
+        (and (method-member? (car methods) (cdr methods) level)
+             (let ((m (find-member (car methods) members level type-recs))
+                   (class (method-record-class (car methods))))
+               (if (field? m)
+                   (method-error 'inherited-conflict-field
+                                 (field-name m)
+                                 null
+                                 (car class)
+                                 (field-src m)
+                                 #f)
+                   (method-error 'repeated 
+                             (method-name m)
+                             (map (lambda (t)
+                                    (type-spec-to-type (field-type t) class level type-recs))
+                                  (method-parms m))
+                             (car class)
+                             (method-src m)
+                             (eq? (method-record-rtype (car methods)) 'ctor)))))
+        (and (equal? (method-record-name (car methods)) 
+                     (method-record-class (car methods)))
+             (not (eq? (method-record-rtype (car methods)) 'ctor))
+             (let ((m (find-member (car methods) members level type-recs))
+                   (class (method-record-class (car methods))))
+               (if (field? m)
+                   (method-error 'inherited-conflict-field
+                                 (field-name m)
+                                 null
+                                 (car class)
+                                 (field-src m)
+                                 #f)
+                   (method-error 'ctor-ret-value 
+                                 (method-name m)
+                                 (map (lambda (t) (type-spec-to-type (field-type t) class level type-recs))
+                                      (method-parms m))
+                                 (car class)
+                                 (method-src m)
+                                 #f))))
+        (and (memq level `(beginner intermediate))
+             (not (eq? (method-record-rtype (car methods)) 'ctor))
+             (shared-class-name? (car methods) (send type-recs get-class-env))
+             (let ((m (find-member (car methods) members level type-recs))
+                   (class (method-record-class (car methods))))
+               (if (field? m)
+                   (method-error 'inherited-conflict-field
+                                 (field-name m)
+                                 null
+                                 (car class)
+                                 (field-src m)
+                                 #f)
+                   (method-error 'class-name
+                                 (method-name m)
+                                 (map (lambda (t) (type-spec-to-type (field-type t) class level type-recs))
+                                      (method-parms m))
+                                 (car class)
+                                 (method-src m)
+                                 (eq? (method-record-rtype (car methods)) 'ctor)))))
+        (valid-method-sigs? (cdr methods) members level type-recs)))
+  
+  (define (method-member? method methods level)
+    (and (not (null? methods))
+         (or (and (equal? (method-record-name method)
+                          (method-record-name (car methods)))
+                  (type=? (method-record-rtype method) (method-record-rtype (car methods)))
+                  (or (or (eq? level 'beginner) (eq? level 'intermediate))
+                      (and (= (length (method-record-atypes method))
+                              (length (method-record-atypes (car methods))))
+                           (andmap type=? (method-record-atypes method) 
+                                   (method-record-atypes (car methods))))))
+             (method-member? method (cdr methods) level))))                              
+ 
+  ;valid-inherited-methods?: (list class-record) (list name) symbol type-records -> bool
+  (define (valid-inherited-methods? records extends level type-recs)
+    (or (null? records)
+        (and (check-inherited-method (class-record-methods (car records))
+                                     (cdr records)
+                                     (car extends)
+                                     level
+                                     type-recs)
+             (valid-inherited-methods? (cdr records) (cdr extends) level type-recs))))
+  
+  ;check-inherited-method: (list method-record) (list class-record) name symbol type-records -> bool
+  (define (check-inherited-method methods records from level type-recs)
+    (or (null? methods)
+        (and (method-conflicts? (car methods) 
+                                (apply append (map class-record-methods records))
+                                level)
+             (method-error 'inherit-conflict 
+                           (method-record-name (car methods))
+                           (method-record-atypes (car methods))
+                           (id-string (name-id from))
+                           (name-src from)
+                           #f))
+        (check-inherited-method (cdr methods) records from level type-recs)))
+
+  ;method-conflicts?: method-record (list method-record) symbol -> bool
+  (define (method-conflicts? method methods level)
+    (and (not (null? methods))
+         (or (and (equal? (method-record-name method)
+                          (method-record-name (car methods)))
+                  (or (or (eq? level 'beginner) (eq? level 'intermediate))
+                      (and (= (length (method-record-atypes method)) (length (method-record-atypes (car methods))))
+                           (andmap type=? (method-record-atypes method) (method-record-atypes (car methods)))))
+                  (not (type=? (method-record-rtype method) (method-record-rtype (car methods)))))
+             (method-conflicts? method (cdr methods) level))))                              
+
+  (define (check-current-methods records methods members level type-recs)
+    (or (null? records)
+        (and (check-for-conflicts methods (car records) members level type-recs)
+             (check-current-methods (cdr records) methods members level type-recs))))
+  
+  (define (check-for-conflicts methods record members level type-recs)
+    (or (null? methods)
+        (and (method-conflicts? (car methods)
+                                (class-record-methods record)
+                                level)
+             (let ((method (find-member (car methods) members level type-recs))
+                   (class (class-record-name record)))
+               (if (field? method)
+                   (method-error 'inherited-conflict-field
+                                 (field-name method)
+                                 null
+                                 (car class)
+                                 (field-src method)
+                                 #f)
+                   (method-error 'conflict
+                                 (method-name method)
+                                 (map (lambda (t)
+                                        (type-spec-to-type (field-type t) class level type-recs))
+                                      (method-parms method))
+                                 (car class)
+                                 (method-src method)
+                                 #f))))
+        (check-for-conflicts (cdr methods) record members level type-recs)))
+  
+  ;class-fully-implemented? class-record id (list class-record) (list id) (list method) symbol -> bool
+  (define (class-fully-implemented? super super-name ifaces ifaces-name methods level) 
+    (when (memq 'abstract (class-record-modifiers super))
+      (implements-all? (get-methods-need-implementing (class-record-methods super))
+                       methods super-name level))
+    (andmap (lambda (iface iface-name)
+              (implements-all? (class-record-methods iface) methods iface-name level))
+            ifaces
+            ifaces-name))
+  
+  ;get-methods-need-implementing: (list method-record) -> (list method-record)
+  (define (get-methods-need-implementing methods)
+    (let ((abstract-methods (filter (lambda (m) (memq 'abstract (method-record-modifiers m))) methods))
+          (non-abstract-methods (filter (lambda (m) (not (memq 'abstract (method-record-modifiers m)))) methods)))
+      (filter (lambda (m)
+                (not (member m (map method-record-override non-abstract-methods))))
+              abstract-methods)))
+  
+  ;implements-all? (list method-record) (list method) name symbol -> bool
+  (define (implements-all? inherit-methods methods name level)
+    (or (null? inherit-methods)
+        (and (not (method-member? (car inherit-methods) methods level))
+             (method-error 'not-implement 
+                           (make-id (method-record-name (car inherit-methods)) #f)
+                           (method-record-atypes (car inherit-methods))
+                           (id-string (name-id name))
+                           (id-src (name-id name))
+                           #f))
+        (implements-all? (cdr inherit-methods) methods name level)))
+  
+  (define (no-abstract-methods methods members level type-recs)
+    (or (null? methods)
+        (and (memq 'abstract (method-record-modifiers (car methods)))
+             (let ((method (find-member (car methods) members level type-recs))
+                   (class (method-record-class (car methods))))
+               (method-error 'illegal-abstract 
+                             (method-name method) 
+                             (map (lambda (t)
+                                    (type-spec-to-type (field-type t) class level type-recs))
+                                  (method-parms method)) 
+                             (car class)
+                             (method-src method)
+                             #f)))
+        (no-abstract-methods (cdr methods) members level type-recs)))
+    
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;Methods to process fields and methods
+  
+  ;; process-members: (list members) (list method-record) (list string) type-records symbol -> 
+  ;;                     (values (list field-record) (list method-record) (list inner-record))
+  (define (process-members members inherited-methods cname type-recs level . args)
+    (let loop ((members members)
+               (fields null)
+               (methods null)
+               (inners null))
+      (cond
+        ((null? members) (values fields methods inners))
+        ((field? (car members))
+         (loop (cdr members)
+               (cons (process-field (car members) cname type-recs level) fields)
+               methods
+               inners))
+        ((method? (car members))
+         (loop (cdr members)
+               fields
+               (cons (if (null? args)
+                         (process-method (car members) inherited-methods cname type-recs level)
+                         (process-method (car members) inherited-methods cname type-recs level (car args)))
+                         methods)
+               inners))
+        ((def? (car members))
+         (loop (cdr members)
+               fields
+               methods
+               (cons (process-inner (car members) cname type-recs level) inners)))
+        (else
+         (loop (cdr members)
+               fields
+               methods
+               inners)))))
+  
+  ;; process-field: field (string list) type-records symbol -> field-record
+  (define (process-field field cname type-recs level)
+    (make-field-record (id-string (field-name field)) 
+                       (check-field-modifiers level (field-modifiers field)) 
+                       (var-init? field)
+                       cname 
+                       (type-spec-to-type (field-type field) cname level type-recs)))
+                  
+  ;; process-method: method (list method-record) (list string) type-records symbol -> method-record  
+  (define (process-method method inherited-methods cname type-recs level . args)
+    (let* ((name (id-string (method-name method)))
+           (parms (map (lambda (p)
+                         (type-spec-to-type (field-type p) cname level type-recs))
+                       (method-parms method)))
+           (mods (if (null? args) (method-modifiers method) (cons (car args) (method-modifiers method))))
+           (ret (type-spec-to-type (method-type method) cname level type-recs))
+           (throws (filter (lambda (n)
+                             (not (or (is-eq-subclass? n runtime-exn-type type-recs))))
+                           ;(is-eq-subclass? n error-type type-recs))))
+                           (map (lambda (t)
+                                  (let ((n (make-ref-type (id-string (name-id t))
+                                                          (map id-string (name-path t)))))
+                                    (if (is-eq-subclass? n throw-type type-recs)
+                                        n
+                                        (throws-error (name-id t) (name-src t)))))
+                                (method-throws method))))
+           (over? (overrides? name parms inherited-methods)))
+
+      (when (and (memq level '(beginner intermediate))
+                 (member name (map method-record-name inherited-methods))
+                 (not over?))
+        (inherited-overload-error name parms (method-record-atypes 
+                                              (car (filter (lambda (m) (equal? (method-record-name m) name))
+                                                           inherited-methods)))
+                                  (id-src (method-name method))))        
+            
+      (when (eq? ret 'ctor)
+        (if (regexp-match "\\." (car cname))
+            (begin
+              (unless (equal? name (filename-extension (car cname)))
+                (not-ctor-error name (car cname) (id-src (method-name method))))
+              (set! name (car cname))
+              (set-id-string! (method-name method) (car cname)))
+            (unless (equal? name (car cname))
+              (not-ctor-error name (car cname) (id-src (method-name method))))))
+            
+      (check-parm-names (method-parms method) name cname)
+      
+      (when over?
+        (when (memq level `(advanced full))
+          (check-gtequal-access mods name parms cname over? (method-src method)))
+        
+        (unless (type=? ret (method-record-rtype over?))
+          (override-return-error name parms cname ret 
+                        (method-record-rtype over?)
+                        (type-spec-src (method-type method))))
+        
+        (when (memq 'final (method-record-modifiers over?))
+          (override-access-error 'final level 
+                                 name parms cname (method-record-class over?) 
+                                (id-src (method-name method))))
+        
+        (when (and (memq level '(advanced full))
+                   (memq 'static (method-record-modifiers over?)))
+          (override-access-error 'static level
+                                 name parms cname (method-record-class over?)
+                                 (id-src (method-name method))))
+        (when (eq? level 'full)
+          (check-throws-match throws method cname over? type-recs)))
+      
+      (let ((record (make-method-record name
+                                        (check-method-modifiers level mods (eq? 'ctor ret))
+                                        ret
+                                        parms
+                                        throws
+                                        over?
+                                        cname)))
+        (set-method-rec! method record)
+        record)))
+  
+  ;process-inner def (list name) type-records symbol -> inner-record
+  (define (process-inner def cname type-recs level)
+    (make-inner-record (filename-extension (id-string (def-name def)))
+                       (map modifier-kind (header-modifiers (def-header def)))
+                       (class-def? def)))
+
+  ;overrides?: string (list type) (list method-record) -> (U bool method-record)
+  (define (overrides? mname parms methods)
+    (and (not (null? methods))
+         (if (and (equal? mname
+                          (method-record-name (car methods)))
+                  (= (length parms)
+                     (length (method-record-atypes (car methods))))
+                  (andmap type=? parms (method-record-atypes (car methods))))
+             (car methods)
+             (overrides? mname parms (cdr methods)))))
+    
+  ;check-parm-names: (list field) string (list string) -> void
+  (define (check-parm-names parms meth class)
+    (or (null? parms)
+        (and (parm-member? (car parms) (cdr parms))
+             (repeated-parm-error (car parms) meth class))
+        (check-parm-names (cdr parms) meth class)))
+
+  ;parm-member? field (list field) -> bool
+  (define (parm-member? p parms)
+    (and (not (null? parms))
+         (or (equal? (id-string (field-name p))
+                     (id-string (field-name (car parms))))
+             (parm-member? p (cdr parms)))))
+  
+  ;check-gtequal-access: (list modifier) string (list type) (list string) method-record src -> void
+  (define (check-gtequal-access mods name parms class over src)
+    (let ((old-mods (method-record-modifiers over))
+          (old-class (method-record-class over)))
+      (cond
+        ((memq 'public old-mods)
+         (unless (memq 'public (map modifier-kind mods))
+           (override-access-error 'public 'full name parms class (method-record-class over) src)))
+        ((memq 'protected old-mods) 
+         (unless (or (memq 'public (map modifier-kind mods))
+                     (memq 'protected (map modifier-kind mods)))
+           (override-access-error 'protected 'full name parms class (method-record-class over) src)))
+        (else 
+         (unless (or (memq 'public (map modifier-kind mods))
+                     (not (memq 'private (map modifier-kind mods)))
+                     (not (memq 'protected (map modifier-kind mods))))
+           (override-access-error 'package 'full name parms class (method-record-class over) src))))))
+
+  ;check-throws-same: (list type) method (list string) method-record type-records -> void
+  (define (check-throws-match throws method cname over type-recs)
+    (if (= 0 (length (method-record-throws over)))
+        (for-each (lambda (t) 
+                    (unless (is-subclass-of1? t (method-record-throws over) type-recs)
+                      (inherited-throw-error 'subclass 
+                                        (method-name method)
+                                        (method-parms method)
+                                        cname
+                                        (method-record-class over)
+                                        t
+                                        (id-src (find-type t (method-throws method))))))
+                  throws)
+        (inherited-throw-error 'num (method-name method) (method-parms method) cname
+                          (method-record-class over) #t (method-src method))))
+    
+  ;is-subclass-of1?: type (list type) type-records-> bool
+  (define (is-subclass-of1? throw thrown type-recs)
+    (and (not (null? thrown))
+         (or (is-eq-subclass? throw (car thrown) type-recs)
+             (is-subclass-of1? throw (cdr thrown) type-recs))))
+  
+  ;find-type type (list name) -> src
+  (define (find-type throw throws)
+    (or (and (equal? (ref-type-class/iface throw)
+                     (id-string (name-id (car throws))))
+             (name-id (car throws)))
+        (find-type throw (cdr throws))))  
+  
+  ;-----------------------------------------------------------------------------------
+  ;Code to check modifiers
+  
+  ;check-class-modifiers: symbol symbol (list modifier) -> (list symbol)
+  (define (check-class-modifiers level kind mods)
+    (when (and ((valid-class-mods? kind) level mods)
+               (not (final-and-abstract? mods))
+               (not (duplicate-mods? mods)))
+      (map modifier-kind mods)))
+  
+  ;check-interface-modifiers: (list modifier) symbol -> (list symbol)
+  (define (check-interface-modifiers level mods)
+    (when (and (valid-interface-mods? level mods)
+               (not (duplicate-mods? mods)))
+      (map modifier-kind mods)))
+
+  ;check-method-modifiers: symbol (list modifier) -> (list symbol)
+  (define (check-method-modifiers level mods ctor?)
+    (when (and (not (duplicate-mods? mods))
+               (one-of-access? mods)
+               (if ctor?
+                   (valid-method-mods? 'ctor mods)
+                   (valid-method-mods? level mods))
+               (not (native-and-fp? mods))
+               (or (not (memq 'abstract (map modifier-kind mods)))
+                   (valid-method-mods? 'abstract mods)))
+      (map modifier-kind mods)))
+  
+  ;check-field-modifiers: symbol (list modifier) -> (list symbol)
+  (define (check-field-modifiers level mods)
+    (when (and (not (duplicate-mods? mods))
+               (one-of-access? mods)
+               (valid-field-mods? level mods)
+               (not (volatile-and-final? mods)))
+      (map modifier-kind mods)))
+  
+  ;make-valid-mods: (symbol -> (list symbol)) (symbol -> symbol) -> (symbol (list modifier) -> bool)
+  (define (make-valid-mods valids-choice error-type)
+    (letrec ((tester
+              (lambda (level mods)
+                (or (null? mods)
+                    (and (not (memq (modifier-kind (car mods)) (valids-choice level)))
+                         (modifier-error (error-type level) (car mods)))
+                    (tester level (cdr mods))))))
+      tester))
+
+  ;valid-*-mods?: symbol -> (symbol (list modifier) -> bool)
+  (define (valid-class-mods? kind)
+    (make-valid-mods 
+     (lambda (level)
+       (case kind
+         ((top) '(public abstract final strictfp))
+         ((member) '(public private protected abstract final static))
+         ((anon) '())
+         ((statement) '(public private protected abstract final))))
+     (lambda (x) 'invalid-class)))
+  (define valid-interface-mods?
+    (make-valid-mods (lambda (x) '(public abstract strictfp))
+                     (lambda (x) 'invalid-iface)))
+  (define valid-field-mods?
+    (make-valid-mods
+     (lambda (level)
+       (case level
+         ((beginner) '(public final))
+         ((intermediate) '(public))
+         ((advanced) '(public protected private static))
+         ((full) `(public protected private static final transient volatile))))
+     (lambda (x) 'invalid-field)))  
+  (define valid-method-mods?
+    (make-valid-mods
+     (lambda (level)
+       (case level
+         ((beginner intermediate) '(public abstract))
+         ((advanced) `(public protected private abstract static final))
+         ((full) '(public protected private abstract static final synchronized native strictfp))
+         ((abstract) '(public protected abstract))
+         ((ctor) '(public protected private))))
+     (lambda (level)
+       (case level
+         ((abstract) 'invalid-abstract)
+         ((ctor) 'invalid-ctor)
+         (else 'invalid-method)))))
+  
+  ;one-access: symbol symbol symbol (list modifiers) -> bool
+  (define (one-access is check1 check2 mods)
+    (and (eq? is (modifier-kind (car mods)))
+         (or (memq check1 (map modifier-kind (cdr mods)))
+             (memq check2 (map modifier-kind (cdr mods))))
+         (modifier-error 'access (car mods))))
+
+  ;one-of-access?: (list modifier) -> bool
+  (define (one-of-access? mods)
+    (or (null? mods)
+        (one-access 'public 'private 'protected mods)
+        (one-access 'private 'public 'protected mods)
+        (one-access 'protected 'private 'public mods)
+        (one-of-access? (cdr mods))))
+
+  ;make-not-two: symbol symbol symbol -> ((list modifier) -> bool)
+  (define (make-not-two first second error)
+    (letrec ((tester
+              (lambda (mods)
+                (and (not (null? mods))
+                     (or (and (eq? first (modifier-kind (car mods)))
+                              (memq second (map modifier-kind (cdr mods)))
+                              (modifier-error error (car mods)))
+                         (and (eq? second (modifier-kind (car mods)))
+                              (memq first (map modifier-kind (cdr mods)))
+                              (modifier-error error (car mods)))
+                         (tester (cdr mods)))))))
+      tester))
+  
+  (define final-and-abstract? (make-not-two 'final 'abstract 'final-abstract))
+  (define volatile-and-final? (make-not-two 'volatile 'final 'final-volatile))
+  (define native-and-fp? (make-not-two 'native 'strictfp 'native-strictfp))
+    
+  ;duplicate-mods?: (list modifier) -> bool
+  (define (duplicate-mods? mods)
+    (and (not (null? mods))
+         (or (and (memq (modifier-kind (car mods))
+                        (map modifier-kind (cdr mods)))
+                  (modifier-error 'dups (car mods)))
+             (duplicate-mods? (cdr mods)))))
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;Error raising code: code that takes information about the error message and throws the error
+  
+  ;repeated-def-name-error: id bool symbol src -> void
+  (define (repeated-def-name-error name class? level src)
+    (let ((n (id->ext-name name)))
+      (raise-error n
+                   (format "~a ~a shares a name with another class~a. ~a names may not be repeated"
+                           (if class? "Class" "Interface") n (if (eq? level 'beginner) "" " or interface")
+                           (if (eq? level 'beginner) "Class" "Class and interface "))
+                   n src)))
+  
+  ;modifier-error: symbol modifier -> void
+  (define (modifier-error kind mod)
+    (let ((m (modifier-kind mod))
+          (src (modifier-src mod)))
+      (raise-error m
+                   (case kind
+                     ((dups) 
+                      (format "Modifier ~a may only appear once in a declaration, it occurs multiple times here." m))
+                     ((access)
+                      "Declaration may only be one of public, private, or protected, more than one occurs here")
+                     ((invalid-iface)
+                      (format "Modifier ~a is not valid for interfaces" m))
+                     ((invalid-class)
+                      (format "Modifier ~a is not valid for classes" m))
+                     ((invalid-field)
+                      (format "Modifier ~a is not valid for fields" m))
+                     ((invalid-method)
+                      (format "Modifier ~a is not valid for methods" m))
+                     ((invalid-ctor)
+                      (format "Modifier ~a is not valid for constructors" m))
+                     ((invalid-abstract)
+                      (format "Modifier ~a is not valid for an abstract method" m))
+                     ((final-abstract) "Class declared final and abstract which is not allowed")
+                     ((final-volatile) "Field declared final and volatile which is not allowed")
+                     ((native-strictfp) "Method declared native and strictfp which is not allowed"))
+                   m src)))
+
+  ;dependence-error: symbol id src -> void
+  (define (dependence-error kind name src)
+    (let ((n (id->ext-name name)))
+      (raise-error n
+                   (case kind
+                     ((immediate) (format "~a may not extend itself, which it does here" n))
+                     ((cycle) 
+                      (format "~a is illegally dependent on itself, potentially through other definitions" n)))
+                   n src)))
+
+  ;extension-error: symbol id name src -> void
+  (define (extension-error kind name super src) 
+    (let ((n (if name (id->ext-name name) name))
+          (s (id->ext-name (name-id super))))
+      (raise-error 
+       s
+       (case kind
+         ((final) 
+          (format "Final classes may never be extended, therefore final class ~a may not be extended by ~a" s n))
+         ((implement) 
+          (format 
+           "A class may only declare an implemented interface once, this class declares it is implementing ~a more than once"
+           s))
+         ((ifaces) 
+          (format "An interface may only declare each extended interface once, ~a declares this interface more than once" s))
+         ((iface-class) 
+          (format "Interfaces may never extend classes, interface ~a has attemped to extend ~a, which is a class" n s))
+         ((class-iface) 
+          (format "Classes may never extend interfaces, class ~a has attempted to extend ~a, which is an interface" n s))
+         ((implement-class) 
+          (format "Only interfaces may be implemented, class ~a has attempted to implement class ~a" n s)))
+       s src)))
+
+  ;method-error: symbol id (list type) string src bool -> void
+  (define (method-error kind name parms class src ctor?)
+    (if (eq? kind 'inherited-conflict-field)
+        (let ((n (id->ext-name name)))
+          (raise-error n (format "Field ~a conflicts with a method of the same name from ~a" n class) n src))
+        (let ((m-name (method-name->ext-name (id-string name) parms)))
+          (raise-error 
+           m-name
+           (case kind
+             ((illegal-abstract)
+              (format 
+               "Abstract method ~a is not allowed in non-abstract class ~a, abstract methods must be in abstract classes" 
+               m-name class))
+             ((repeated)
+              (format "~a ~a has already been written in this class (~a) and cannot be written again" 
+                      (if ctor? "Constructor" "Method") m-name class))
+             ((inherit-conflict)
+              (format "Inherited method ~a from ~a conflicts with another method of the same name" m-name class))
+             ((conflict)
+              (format "Method ~a conflicts with a method inherited from ~a" m-name class))
+             ((not-implement) (format "Method ~a from ~a should be implemented and was not" m-name class))
+             ((ctor-ret-value)
+              (format "Constructor ~a for class ~a has a return type, which is not allowed" m-name class))
+             ((class-name)
+              (format "Method ~a from ~a has the same name as a class, which is not allowed" m-name class)))
+           m-name src))))
+
+  ;inherited-overload-error: string (list type) (list type) src -> void
+  (define (inherited-overload-error name new-type inherit-type src)
+    (let ((n (string->symbol name))
+          (nt (map type->ext-name new-type))
+          (gt (map type->ext-name inherit-type)))
+      (raise-error n
+                   (string-append 
+                    (format "Attempted to override method ~a, but it should have ~a arguments with types ~a.~n"
+                            n (length inherit-type) gt)                                      
+                    (format "Given ~a arguments with types ~a" (length new-type) nt))
+                   n src)))                               
+  
+  ;not-ctor-error: string string src -> void
+  (define (not-ctor-error meth class src)
+    (let ((n (string->symbol meth)))
+      (raise-error 
+       n
+       (format "~a~n~a"
+               (format "Method ~a has no return type and does not have the same name as the class, ~a"
+                       n class)
+               "Only constructors may have no return type, but must have the name of the class")
+       n src)))
+
+  ;beginner-ctor-error: symbol id src -> void
+  (define (beginner-ctor-error kind class src) 
+    (let ((n (id->ext-name class)))
+      (raise-error n (case kind
+                       ((none) (format "Class ~a must have a constructor" n))
+                       ((abstract) (format "Abstract class ~a may not have a constructor" n))) n src)))
+
+  ;default-ctor-error symbol id string src symbol -> void
+  (define (default-ctor-error kind name parent src level)
+    (let ((n (id->ext-name name)))
+      (raise-error n
+                   (case kind
+                     ((private)
+                      (if (memq level '(beginner intermediate))
+                          (format "Class ~a cannot extend ~a" n parent)
+                          (format "Class ~a cannot access the default constructor of ~a, which is private" n parent)))
+                     ((non-accessible)
+                      (if (memq level '(beginner intermediate))
+                          (format "Class ~a must have a constructor due to its extension of class ~a" n parent)
+                          (format "Class ~a cannot access a default constructor for ~a" n parent)))
+                     ((throws)
+                      (format "Class ~a cannot use the default constructor for ~a, as ~a's default contains a throws clause"
+                              n parent parent)))
+                   n src)))
+  
+  ;inherited-throw-error:symbol string (list type) (list string) string type src -> void
+  (define (inherited-throw-error kind m-name parms class parent throw src)
+    (raise-error 
+     'throws
+     (case kind
+       ((num) 
+        (format 
+         "Method ~a in ~a overrides a method from ~a: Method in ~a should throw no types if original doesn't"
+         (method-name->ext-name m-name parms) (car class) parent (car class)))
+       ((subclass)
+        (let ((line1 (format "Method ~a in ~a overrides from a method from ~a"
+                             (method-name->ext-name m-name parms) (car class) parent))
+              (line2 
+               (format 
+                "All types thrown by overriding method in ~a must be subtypes of original throws: ~a is not"
+                (car class) (type->ext-name throw))))
+          (format "~a~n~a" line1 line2))))
+     'throws src))
+                      
+  ;return-error string (list type) (list string) type type src -> void
+  (define (override-return-error name parms class ret old-ret src)
+    (let ((name (string->symbol name))
+          (m-name (method-name->ext-name name parms)))
+      (raise-error 
+       name
+       (format 
+        "~a~n~a"
+        (format "Method ~a of class ~a overrides an inherited method, in overriding the return type must remain the same"
+                m-name (car class))
+        (format "~a's return has changed from ~a to ~a" m-name (type->ext-name old-ret) (type->ext-name ret)))
+       name src)))
+  
+  ;override-access-error symbol symbol string (list type) (list string) string src -> void
+  (define (override-access-error kind level name parms class parent src)
+    (let ((name (string->symbol name))
+          (m-name (method-name->ext-name name parms)))
+      (raise-error name
+                   (case kind
+                     ((final) 
+                      (if (eq? level 'full)
+                          (format 
+                           "Method ~a in ~a attempts to override final method from ~a, final methods may not be overridden"
+                           m-name (car class) parent)
+                          (format "Method ~a from ~a cannot be overridden in ~a" m-name parent (car class))))
+                     ((static)
+                      (format "Method ~a in ~a attempts to override static method from ~a, which is not allowed"
+                              m-name (car class) parent))
+                     ((public) 
+                      (format "Method ~a in ~a must be public to override public method from ~a, ~a is not public" 
+                              m-name (car class) parent m-name))
+                     ((protected) 
+                      (format 
+                       "Method ~a in ~a must be public or protected to override protected method from ~a, it is neither"
+                       m-name (car class) parent))
+                     ((package) 
+                      (format "Method ~a in ~a must be public, or have no access modifier, to override method from ~a"
+                              m-name (car class) parent)))
+                   name src)))
+  
+  ;repeated-parm-error: field string (list string) -> void
+  (define (repeated-parm-error parm meth class)
+    (let ((name (id->ext-name (field-name parm))))
+      (raise-error name
+                   (format 
+                    "Method parameters may not share names, ~a in ~a cannot have multiple parameters with the name ~a"
+                    meth (car class) name)
+                   name (id-src (field-name parm)))))
+
+  ;field-name-error: symbol id symbol src -> void
+  (define (field-name-error kind name level src)
+    (let ((n (id->ext-name name)))
+      (raise-error n
+                   (case kind
+                     ((field) 
+                      (format 
+                       "Each field in a class must have a unique name. Multiple fields have been declared with the name ~a" 
+                       n))
+                     ((method) 
+                      (format "~a has been declared as a field and a method, which is not allowed" n))
+                     ((class) 
+                      (format "~a has been declared as a field and a ~a, which is not allowed" n
+                              (if (eq? level 'intermediate) "class or interface" "class")))
+                     ((inherited-conflict-method)
+                      (format "Method ~a conflicts with an inherited field of the same name" n)))
+                   n src)))
+  
+  ;import-error: name src -> void
+  (define (import-error imp src)
+    (raise-error 'import
+                 (format "Import ~a not found" (path->ext (name->path imp)))
+                 'import src))
+
+  ;file-error: symbol (list string) src symbol -> void
+  (define (file-error kind path src level)
+    (if (eq? level 'full)
+        (let ((k (if (eq? kind 'file) 'file-not-found 'directory-not-found)))
+          (raise-error k
+                       (case kind
+                         ((file) (format "Required file ~a not found" (path->ext path)))
+                         ((dir) (format "Required directory ~a not found" (path->ext path))))
+                       k src))
+        (raise-error (string->symbol (car path))
+                     (case kind
+                       ((file) (format "Class ~a is not known" (path->ext path)))
+                       ((dir) (format "Directory to search, ~a, is not known" (path->ext path))))
+                     (string->symbol (car path))
+                     src)))
+
+  ;used-restricted-import: string (list string) src -> void
+  (define (used-restricted-import class path src)
+    (raise-error 'import
+                 (format "Imported class, ~a, cannot be imported or used" (path->ext (cons class path)))
+                 'import src))
+
+  
+  ;throws-error id src -> void
+  (define (throws-error t src)
+    (raise-error 'throws
+                 (format "Thrown class must be a subtype of Throwable: Given ~a" (id->ext-name t))
+                 'throws src))
+        
+  (define build-info-location (make-parameter #f))
+  (define raise-error (make-error-pass build-info-location))
+  
+  )
+  
\ No newline at end of file
diff --git a/collects/profj/check.ss b/collects/profj/check.ss
new file mode 100644
index 0000000000..0569ff31fb
--- /dev/null
+++ b/collects/profj/check.ss
@@ -0,0 +1,3175 @@
+(module check mzscheme
+
+  (require "ast.ss"
+           "types.ss"
+           "parameters.ss"
+           "error-messaging.ss"
+           "restrictions.ss"
+           "profj-pref.ss"
+           "build-info.ss"
+           (lib "class.ss") (lib "list.ss") 
+           (prefix srfi: (lib "1.ss" "srfi")) (lib "string.ss"))
+  (provide check-defs check-interactions-types)
+  
+  ;symbol-remove-last: symbol->symbol
+  (define (symbol-remove-last s)
+    (let ((str (symbol->string s)))
+      (string->symbol (substring str 0 (sub1 (string-length str))))))
+
+  (define update-class-with-inner (make-parameter (lambda (x) (void))))
+  (define current-method (make-parameter ""))
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;Environment functions
+
+  ;env =>
+  ;(make-environment (list var-type) (list string) (list type) (list string) (list inner-rec))
+  (define-struct environment (types set-vars exns labels local-inners) (make-inspector))
+  
+  ;Constant empty environment
+  (define empty-env (make-environment null null null null null))
+
+  ;; var-type => (make-var-type string type properties)
+  (define-struct var-type (var type properties) (make-inspector))
+  
+  ;;inner-rec ==> (make-inner-rec string (U symbol void) class-rec)
+  (define-struct inner-rec (name unique-name record))
+  
+  ;;Environment variable properties
+  ;;(make-properties bool bool bool bool bool bool)
+  (define-struct properties (parm? field? static? settable? final? usable?))
+  (define parm (make-properties #t #f #f #t #f #t))
+  (define final-parm (make-properties #t #f #f #f #t #t))
+  (define method-var (make-properties #f #f #f #t #f #t))
+  (define final-method-var (make-properties #f #f #f #f #t #t))
+  (define obj-field (make-properties #f #t #f #t #f #t))
+  (define (final-field settable) (make-properties #f #t #f settable #t #t))
+  (define class-field (make-properties #f #t #t #f #t #t))
+  (define (final-class-field settable) (make-properties #f #t #t settable #t #t))
+  (define inherited-conflict (make-properties #f #t #f #f #f #f))
+  
+  ;; add-var-to-env: string type properties env -> env
+  (define (add-var-to-env name type properties env)
+    (make-environment (cons (make-var-type name type properties) (environment-types env))
+                      (environment-set-vars env)
+                      (environment-exns env)
+                      (environment-labels env)
+                      (environment-local-inners env)))
+  
+  ;; lookup-var-in-env: string env -> (U var-type boolean)
+  (define (lookup-var-in-env name env)
+    (letrec ((lookup
+              (lambda (env)
+                (and (not (null? env))
+                     (if (string=? name (var-type-var (car env)))
+                         (car env)
+                         (lookup (cdr env)))))))
+      (lookup (environment-types env))))
+
+  ;lookup-specific-this: name env symbol type-records -> bool
+  (define (lookup-enclosing-this name env level type-recs)
+    (letrec ((type (name->type name #f (name-src name) level type-recs))
+             (lookup
+              (lambda (env)
+                (and (not (null? env))
+                     (if (and (or (string=? "this" (var-type-var (car env)))
+                                  (regexp-match "encl-this-" (var-type-var (car env))))
+                              (type=? type (var-type-type (car env))))
+                         (car env)
+                         (lookup (cdr env)))))))
+      (lookup (environment-types env))))
+                               
+  ;remove-var-from-env string env -> env
+  (define (remove-var-from-env name env)
+    (letrec ((remove-from-env
+              (lambda (env)
+                (cond
+                  ((null? env) null)
+                  ((equal? name (var-type-var (car env)))
+                   (remove-from-env (cdr env)))
+                  (else (cons (car env) (remove-from-env (cdr env))))))))
+      (make-environment (remove-from-env (environment-types env))
+                        (environment-set-vars env)
+                        (environment-exns env)
+                        (environment-labels env)
+                        (environment-local-inners env))))
+  
+  ;;lookup-containing-class-depth: string env -> num
+  (define (lookup-containing-class-depth name env)
+    (letrec ((lookup
+              (lambda (env)
+                (and (not (null? env))
+                     (cond
+		      [(string=? name (var-type-var (car env))) 0]
+		      [(regexp-match "encl-this-" (var-type-var (car env)))
+		       (add1 (lookup (cdr env)))]
+		      [else (lookup (cdr env))])))))
+      (lookup (environment-types env))))
+  
+  ;update-env-for-inner: env -> env
+  (define (update-env-for-inner env)
+    (letrec ((str "encl-this-")
+             (update-env
+              (lambda (env)
+                (cond
+                  ((null? env) null)
+                  ((equal? (var-type-var (car env)) "this") 
+                   (update-env (cdr env)))
+                  ((regexp-match str (var-type-var (car env)))
+                   (let ((var (car env)))
+                     (cons (make-var-type (format "encl-this-~a" 
+                                                  (add1 (string->number (regexp-replace str (var-type-var var) ""))))
+                                          (var-type-type var)
+                                          (var-type-properties var))
+                           (update-env (cdr env)))))
+                  ((properties-final? (var-type-properties (car env)))
+                   (cons (car env) (update-env (cdr env))))
+                  (else (update-env (cdr env)))))))
+      (make-environment (update-env (environment-types env))
+                        (environment-set-vars env)
+                        (environment-exns env)
+                        (environment-labels env)
+                        (environment-local-inners env))))
+
+  ;;add-set-to-env: string env -> env
+  (define (add-set-to-env name env)
+    (make-environment (environment-types env)
+                      (if (not (member name (environment-set-vars env)))
+                          (cons name (environment-set-vars env))
+                          (environment-set-vars env))
+                      (environment-exns env)
+                      (environment-labels env)
+                      (environment-local-inners env)))
+  
+  ;;var-set?: string env -> bool
+  (define (var-set? name env)
+    (member name (environment-set-vars env)))
+  
+  ;;intersect-var-sets: base-env env env -> env
+  ;;Intersects the list of set variables for the two env, creating a new env with the remainder from base
+  (define (intersect-var-sets base-env env-1 env-2)
+    (make-environment (environment-types base-env)
+                      (cond
+                        ((null? (environment-set-vars env-1)) (environment-set-vars env-2))
+                        ((null? (environment-set-vars env-2)) (environment-set-vars env-1))
+                        ((equal? (environment-set-vars env-1) (environment-set-vars env-2))
+                         (environment-set-vars env-1))
+                        (else
+                         (srfi:lset-intersection equal? (environment-set-vars env-1)
+                                                 (environment-set-vars env-2))))
+                      (environment-exns base-env)
+                      (environment-labels base-env)
+                      (environment-local-inners base-env)))
+  
+  ;;add-exn-to-env: type env -> env
+  (define (add-exn-to-env exn env)
+    (make-environment (environment-types env)
+                      (environment-set-vars env)
+                      (cons exn (environment-exns env))
+                      (environment-labels env)
+                      (environment-local-inners env)))
+  
+  ;;add-exns-to-env: (list type) env -> env
+  (define (add-exns-to-env exns env)
+    (if (null? exns)
+        env
+        (add-exns-to-env (cdr exns)
+                         (add-exn-to-env (car exns) env))))
+  
+  ;;lookup-exn: type env type-records symbol-> bool
+  (define (lookup-exn type env type-recs level)
+    (ormap (lambda (lookup)
+             (assignment-conversion lookup type type-recs))
+           (environment-exns env)))
+  
+  ;;add-label-to-env: string env -> env
+  (define (add-label-to-env label env)
+    (make-environment (environment-types env)
+                      (environment-set-vars env)
+                      (environment-exns env)
+                      (cons label (environment-labels env))
+                      (environment-local-inners env)))
+  
+  ;;lookup-label: string env -> bool
+  (define (lookup-label label env)
+    (member label (environment-labels env)))
+
+  ;;add-local-inner-to-env: string symbol class-rec env -> env
+  (define (add-local-inner-to-env name unique-name rec env)
+    (make-environment (environment-types env)
+                      (environment-set-vars env)
+                      (environment-exns env)
+                      (environment-labels env)
+                      (cons (make-inner-rec name unique-name rec) (environment-local-inners env))))
+  
+  ;;lookup-local-inner: string env -> (U inner-rec #f)
+  (define (lookup-local-inner name env)
+    (letrec ((lookup 
+              (lambda (l)
+                (and (not (null? l))
+                    (or (and (equal? name (inner-rec-name (car l)))
+                             (car l))
+                        (lookup (cdr l)))))))
+      (lookup (environment-local-inners env))))
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;Generic helper functions
+
+  ;;(make-type/env type env)
+  (define-struct type/env (t e))
+  
+  ;; set-expr-type: exp (U type type/env) -> (U type type/env)
+  (define (set-expr-type exp t)
+    (set-expr-types! exp (if (type/env? t) (type/env-t t) t)) t)
+
+  ;lookup-this type-records env -> class-record
+  (define (lookup-this type-recs env)
+    (let ((this (lookup-var-in-env "this" env)))
+      (if this 
+          (send type-recs get-class-record (var-type-type this))
+          interactions-record)))
+  
+  ;add-required (list string) string (list string) type-records -> void
+  (define (add-required test-class class path type-recs)
+    (unless (equal? (car test-class) class)
+      (send type-recs add-req (make-req class path))))
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;Checking functions
+
+  ;check-def: ast symbol type-records -> void
+  (define (check-defs def level type-recs)
+    (when (not (null? (check-list)))
+      (check-list (cdr (check-list))))
+    (send type-recs set-location! (def-file def))
+    (check-location (def-file def))
+    (let ((package-name 
+           (send type-recs lookup-path 
+                 (id-string (def-name def))
+                 (lambda () 
+                   (error 'check-defs 
+                          "Internal error: Current def does not have a record entry")))))
+      (if (interface-def? def)
+          (check-interface def package-name (def-level def) type-recs)
+          (check-class def package-name (def-level def) type-recs empty-env)))
+    (packages (cons def (packages)))
+    (when (not (null? (check-list)))
+      (check-defs (car (check-list)) level type-recs)))
+  
+  ;check-interactions-types: ast symbol location type-records -> void
+  (define (check-interactions-types prog level loc type-recs)
+    (check-location loc)
+    (send type-recs set-location! 'interactions)
+    (send type-recs set-class-reqs null)
+    (let ((env (create-field-env (send type-recs get-interactions-fields) empty-env "scheme-interactions"))
+          (c-class (list "scheme-interactions")))
+      (cond
+        ((pair? prog)
+         (for-each (lambda (p)
+                     (check-interactions-types p level loc type-recs)) prog))
+        ((var-init? prog) 
+         (let* ((name (id-string (field-name prog)))
+                (check-env (remove-var-from-env name env)))
+           (check-var-init (var-init-init prog)
+                           (lambda (e env) 
+                             (check-expr e env level type-recs c-class #f #t #t #f))
+                           check-env
+                           (type-spec-to-type (field-type prog) #f level type-recs)
+                           (string->symbol name)
+                           type-recs)))
+        ((var-decl? prog) (void))
+        ((statement? prog)
+         (check-statement prog null env level type-recs c-class #f #t #f #f #t))
+        ((expr? prog)
+         (check-expr prog env level type-recs c-class #f #t #t #f))
+        (else
+         (error 'check-interactions "Internal error: check-interactions-types got ~a" prog)))))
+  
+  ;check-class: class-def (list string) symbol type-records env -> void
+  (define (check-class class package-name level type-recs class-env)
+    (let ((old-reqs (send type-recs get-class-reqs))
+          (old-update (update-class-with-inner))
+          (name (id-string (def-name class))))
+      (update-class-with-inner (lambda (inner)
+                                 (set-def-members! class (cons inner (def-members class)))))
+      (send type-recs set-class-reqs (def-uses class))
+      (let ((this-ref (make-ref-type name package-name)))
+        (check-members (def-members class)
+                       (add-var-to-env "this" this-ref parm class-env)
+                       level
+                       type-recs 
+                       (cons name package-name)
+                       #f 
+                       (memq 'abstract (map modifier-kind (header-modifiers (def-header class))))
+                       (def-kind class)
+                       (if (null? (header-extends (def-header class))) #f
+                           (name-src (car (header-extends (def-header class)))))
+                       ))
+      (set-def-uses! class (send type-recs get-class-reqs))
+      (update-class-with-inner old-update)
+      (send type-recs set-class-reqs old-reqs)))
+
+  ;check-interface: interface-def (list string) symbol type-recs -> void
+  (define (check-interface iface p-name level type-recs)
+    (let ((old-reqs (send type-recs get-class-reqs))
+          (old-update (update-class-with-inner)))
+      (update-class-with-inner (lambda (inner)
+                                 (set-def-members! iface (cons inner (def-members iface)))))
+      (send type-recs set-class-reqs (def-uses iface))
+      (check-members (def-members iface) empty-env level type-recs 
+                     (cons (id-string (def-name iface)) p-name) #t #f (def-kind iface) #f)
+      (set-def-uses! iface (send type-recs get-class-reqs))
+      (update-class-with-inner old-update)
+      (send type-recs set-class-reqs old-reqs)))
+  
+  ;check-inner def symbol type-records (list string) env -> (U (list symbol class-record) void)
+  (define (check-inner-def def level type-recs c-class env)
+    (let* ((statement-inner? (eq? (def-kind def) 'statement))
+           (local-inner? (or (eq? (def-kind def) 'anon) statement-inner?))
+           (p-name (if local-inner? null (cdr c-class)))
+           (inner-env (update-env-for-inner env))
+           (this-type (var-type-type (lookup-var-in-env "this" env)))
+           (unique-name 
+            (when statement-inner? (symbol->string (gensym (string-append (id-string (def-name def)) "-")))))
+           (inner-rec
+            (when local-inner?
+              (build-inner-info def unique-name p-name level type-recs (def-file def) #t))))
+      (when local-inner? (add-init-args def env))
+      (when statement-inner?
+        (set-id-string! (header-id (def-header def)) unique-name))
+      (if (interface-def? def)
+          (check-interface def p-name level type-recs)
+          (check-class def p-name level type-recs (add-var-to-env "encl-this-1" this-type final-parm inner-env)))
+        ;; Propagate uses in internal defn to enclosing defn:
+      (for-each (lambda (use)
+                  (add-required c-class (req-class use) (req-path use) type-recs))
+                (def-uses def))
+      (list unique-name inner-rec)))
+    
+  ;add-init-args: def env -> void
+  ;Updates the inner class with the names of the final variables visible within the class
+  (define (add-init-args def env)
+    (set-def-closure-args! def
+                           (map (lambda (type-var)
+                                  (make-id (var-type-var type-var) #f))
+                                (filter (lambda (type-var)
+                                          (or (eq? (var-type-properties type-var) final-parm)
+                                              (eq? (var-type-properties type-var) final-method-var)))
+                                        (environment-types env)))))
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;Member checking methods
+  
+  ;check-members: (list member) env symbol type-records (list string) bool bool src-> void
+  (define (check-members members env level type-recs c-class iface? abst-class? class-kind extend-src)
+    (let* ((class-record (lookup-this type-recs env))
+           (fields (class-record-fields class-record))
+           (field-env (create-field-env fields env (car c-class)))
+           (base-fields (create-field-env (filter (lambda (field)
+                                                    (not (equal? (field-record-class field) (car c-class))))
+                                                  fields) env (car c-class)))
+           (ctor-throw-env (if iface? field-env
+                               (consolidate-throws 
+                                (get-constructors (class-record-methods class-record)) field-env)))
+           (static-env (get-static-fields-env field-env))
+           (setting-fields null)
+           (inherited-fields null))
+      (when (eq? level 'beginner)
+        (let ((parent (send type-recs get-class-record (car (class-record-parents class-record)))))
+          (when (memq 'abstract (class-record-modifiers parent))
+            (set! inherited-fields 
+                  (filter (lambda (f) (not (field-record-init? f))) (get-field-records parent))))))
+      (let loop ((rest members) (statics empty-env) (fields base-fields))
+        (unless (null? rest)
+          (let ((member (car rest)))
+            (cond
+              ((method? member)
+               (if (memq 'static (map modifier-kind (method-modifiers member)))
+                   (check-method member static-env level type-recs c-class #t iface?)
+                   (check-method member field-env level type-recs c-class #f iface?))
+               (loop (cdr rest) statics fields))
+              ((initialize? member)
+               (if (initialize-static member)
+                   (check-statement (initialize-block member) 'void static-env
+                                    level type-recs c-class #f #t #f #f #f)
+                   (check-statement (initialize-block member) 'void ctor-throw-env level
+                                    type-recs c-class #f #f #f #f #f))
+               (loop (cdr rest) statics fields))
+              ((field? member)
+               (let ((static? (memq 'static (map modifier-kind (field-modifiers member))))
+                     (name (id-string (field-name member)))
+                     (type (type-spec-to-type (field-type member) c-class level type-recs)))
+                 (if (var-init? member)
+                     (check-var-init (var-init-init member)
+                                     (lambda (e env) 
+                                       (check-expr e env
+                                                   level type-recs c-class #f 
+                                                   static? #f #f))
+                                     (if static? statics fields)
+                                     type
+                                     (string->symbol name)
+                                     type-recs)
+                     (when (field-needs-set? member level abst-class?)
+                       (set! setting-fields (cons member setting-fields))))
+                 (if static?
+                     (loop (cdr rest) 
+                           (add-var-to-env name type class-field statics) 
+                           (add-var-to-env name type class-field fields))
+                     (loop (cdr rest) statics 
+                           (add-var-to-env name type obj-field fields)))))
+              ((def? member)
+               (check-inner-def member level type-recs c-class field-env)
+               (loop (cdr rest) statics fields))
+              ))))
+      (let ((assigns (get-assigns members level (car c-class)))
+            (static-assigns (get-static-assigns members level)))
+        (when (eq? level 'beginner)
+          (for-each (lambda (f)
+                      (andmap (lambda (assign)
+                                (inherited-field-set? f assign extend-src))
+                              assigns))
+                    inherited-fields))
+        (for-each (lambda (field)
+                    (if (memq 'static (map modifier-kind (field-modifiers field)))
+                        (andmap
+                         (lambda (assign)
+                           (field-set? field assign (car c-class) level #t)) static-assigns)
+                        (andmap
+                         (lambda (assign)
+                           (field-set? field assign (car c-class) level #f)) assigns)))
+                  setting-fields))))
+    
+  ;create-field-env: (list field-record) env string -> env
+  (define (create-field-env fields env class)
+    (cond
+      ((null? fields) env)
+      (else
+       (let* ((field (car fields))
+              (name (field-record-name field))
+              (in-env? (lookup-var-in-env name env))
+              (static? (memq 'static (field-record-modifiers field)))
+              (final? (memq 'final (field-record-modifiers field)))
+              (current? (equal? class (car (field-record-class field)))))
+         (add-var-to-env name
+                         (field-record-type field)
+                         (cond
+                           ((and in-env? (not current?)) inherited-conflict)
+                           ((and (not static?) (not final?)) obj-field)
+                           ((and (not static?) final?) (final-field current?))
+                           ((and static? (not final?)) class-field)
+                           ((and static? final?) (final-class-field current?)))
+                         (create-field-env (cdr fields) env class))))))
+  
+  ;get-constrcutors: (list method-record) -> (list method-record)
+  (define (get-constructors methods)
+    (filter (lambda (mr)
+              (eq? 'ctor (method-record-rtype mr))) methods))
+
+  ;consolidate-throws: (list method-record) env -> env
+  (define (consolidate-throws mrs env)
+    (let ((first-throws (method-record-throws (car mrs)))
+          (other-throws (map method-record-throws (cdr mrs))))
+      (add-exns-to-env (filter (lambda (throw)
+                                 (andmap (lambda (throws)
+                                           (member throw throws))
+                                         other-throws))
+                               first-throws) env)))
+  
+  ;get-static-fields-env: env -> env
+  (define (get-static-fields-env env)
+    (make-environment (filter (lambda (t) (properties-static? (var-type-properties t)))
+                              (environment-types env))
+                      (environment-set-vars env)
+                      (environment-exns env)
+                      (environment-labels env)
+                      (environment-local-inners env)))
+
+  ;field-needs-set?: field symbol bool-> bool
+  (define (field-needs-set? field level abst-class?)
+    (cond
+      ((and (eq? level 'beginner) (not abst-class?) #t))
+      ((memq 'final (map modifier-kind (field-modifiers field))) #t)
+      (else #f)))
+  
+  ;get-assigns: (list member) symbol string -> (list (list assignment))
+  (define (get-assigns members level class)
+    (if (eq? level 'beginner)
+        (list (get-beginner-assigns members class))
+        (get-instance-assigns members)))
+  
+  ;get-beginner-assigns: (list member) string-> (list assignment)
+  (define (get-beginner-assigns members class)
+    (cond
+      ((null? members) null)
+      ((field? (car members)) (get-beginner-assigns (cdr members) class))
+      ((method? (car members)) 
+       (if (eq? (type-spec-name (method-type (car members))) 'ctor)
+           (if (block? (method-body (car members)))
+               (get-b-assigns (block-stmts (method-body (car members))) class)
+               null)
+           (get-beginner-assigns (cdr members) class)))))
+  
+  ;get-b-assigns: (list statement) string-> (list assignment)
+  (define (get-b-assigns stmts class)
+    (cond
+      ((null? stmts) null)
+      ((ifS? (car stmts)) 
+       (beginner-ctor-error class (car stmts) (ifS-src (car stmts))))
+      ((return? (car stmts)) 
+       (beginner-ctor-error class (car stmts) (ifS-src (car stmts))))
+      (else (append (get-b-assigns-expr (car stmts) class)
+                    (get-b-assigns (cdr stmts) class)))))
+  
+  ;get-b-assigns-expr: Expression string -> assignment
+  (define (get-b-assigns-expr body class)
+    (cond
+      ((assignment? body) 
+       (unless (and (field-access? (access-name (assignment-left body)))
+                    (special-name? (field-access-object (access-name (assignment-left body))))
+                    (expr-src (field-access-object (access-name (assignment-left body)))))
+         (beginner-assn-error 'not-left-this (expr-src (assignment-left body)))) 
+       (when (and (access? (assignment-right body))
+                  (field-access? (access-name (assignment-right body)))
+                  (special-name? (field-access-object (access-name (assignment-right body)))))
+         (beginner-assn-error 'right-this (expr-src (assignment-right body))))
+       (list body))
+      ((call? body) 
+       (if (not (and (special-name? (call-method-name body)) 
+                     (equal? "super" (special-name-name (call-method-name body)))))
+           (beginner-ctor-error class body (expr-src body))
+           null))
+      (else 
+       (beginner-ctor-error class body (expr-src body)))))
+  
+  ;get-instance-assigns: (list member) -> (list (list assignment))
+  (define (get-instance-assigns members)
+    (cond
+      ((null? members) null)
+      ((method? (car members))
+       (if (eq? 'ctor (method-type (car members)))
+           (cons (get-stmt-assigns (method-body (car members)))
+                 (get-instance-assigns (cdr members)))
+           (get-instance-assigns (cdr members))))
+      (else (get-instance-assigns (cdr members)))))
+  
+  ;get-stmt-assigns: statement -> (list assign)
+  (define (get-stmt-assigns b)
+    (cond
+      ((or (not b) (switch? b) (break? b) (continue? b)) null)
+      ((ifS? b)
+       (append (get-assigns-exp (ifS-cond b))
+               (get-stmt-assigns (ifS-then b))
+               (get-stmt-assigns (ifS-else b))))
+      ((throw? b) (get-assigns-exp (throw-expr b)))
+      ((return? b) (get-assigns-exp (return-expr b)))
+      ((while? b) (append (get-assigns-exp (while-cond b))
+                          (get-stmt-assigns (while-loop b))))
+      ((doS? b) (append (get-assigns-exp (doS-cond b))
+                        (get-stmt-assigns (doS-loop b))))
+      ((for? b) (append (get-assigns-forInit (for-init b))
+                        (get-assigns-exp (for-cond b))
+                        (apply append (map get-assigns-exp (for-incr b)))
+                        (get-stmt-assigns (for-loop b))))
+      ((try? b) (get-stmt-assigns (try-body b)))
+      ((block? b) (get-assigns-body (block-stmts b)))
+      ((label? b) (get-stmt-assigns (label-stmt b)))
+      ((synchronized? b) (append (get-assigns-exp (synchronized-expr b))
+                                 (get-stmt-assigns (synchronized-stmt b))))
+      (else (get-assigns-exp b))))
+  
+  ;get-assigns-forInit: (list forInit) -> (list assignment)
+  (define (get-assigns-forInit b-list)
+    (cond
+      ((null? b-list) null)
+      ((field? (car b-list)) null)
+      (else (apply append (map get-assigns-exp b-list)))))
+  
+  ;get-assigns-body: (list statement) -> (list assignment)
+  (define (get-assigns-body b-list)
+    (cond
+      ((null? b-list) null)
+      ((field? (car b-list)) (get-assigns-body (cdr b-list)))
+      (else (append (get-stmt-assigns (car b-list))
+                    (get-assigns-body (cdr b-list))))))
+
+  ;get-assigns-exp: expression -> (list assignment) 
+  (define (get-assigns-exp exp)
+    (cond
+      ((or (not exp) (literal? exp) (special-name? exp)
+           (class-alloc? exp) (inner-alloc? exp)) null)
+      ((bin-op? exp) (append (get-assigns-exp (bin-op-left exp))
+                             (get-assigns-exp (bin-op-right exp))))
+      ((access? exp) (if (field-access? (access-name exp))
+                         (get-assigns-exp (field-access-object (access-name exp)))
+                         null))
+      ((call? exp) (get-assigns-exp (call-expr exp)))
+      ((array-alloc? exp) (apply append (map get-assigns-exp (array-alloc-size exp))))
+      ((array-alloc-init? exp) (get-init-assigns (array-init-vals (array-alloc-init-init exp))))
+      ((cond-expression? exp)
+       (append (get-assigns-exp (cond-expression-cond exp))
+               (get-assigns-exp (cond-expression-then exp))
+               (get-assigns-exp (cond-expression-else exp))))
+      ((array-access? exp)
+       (append (get-assigns-exp (array-access-name exp))
+               (get-assigns-exp (array-access-index exp))))
+      ((post-expr? exp) (get-assigns-exp (post-expr-expr exp)))
+      ((pre-expr? exp) (get-assigns-exp (pre-expr-expr exp)))
+      ((unary? exp) (get-assigns-exp (unary-expr exp)))
+      ((cast? exp) (get-assigns-exp (cast-expr exp)))
+      ((instanceof? exp) (get-assigns-exp (instanceof-expr exp)))
+      ((assignment? exp) (list exp))))
+  
+  ;get-init-assigns: (list (U Expression array-init)) -> (list assignment)
+  (define (get-init-assigns inits)
+    (cond
+      ((null? inits) null)
+      ((expr? (car inits))
+       (apply append (map get-assigns-exp inits)))
+      (else
+       (apply append (map get-init-assigns (map array-init-vals inits))))))
+          
+  (define (get-static-assigns m l) null)
+  
+  ;field-set?: field (list assignment) string symbol bool -> bool
+  (define (field-set? field assigns class level static?)
+    (if (null? assigns) 
+        (field-not-set-error (field-name field)
+                             class
+                             (if (memq level '(beginner intermediate))
+                                 level
+                                 (if static? 'static 'instance))
+                             (field-src field))
+        (let* ((assign (car assigns))
+               (left (access-name (assignment-left assign))))
+          (or (cond
+                ((local-access? left) 
+                 (equal? (id-string (local-access-name left))
+                         (id-string (field-name field))))
+                ((field-access? left)
+                 (and (special-name? (field-access-object left))
+                      (equal? "this" (special-name-name (field-access-object left)))
+                      (equal? (id-string (field-access-field left))
+                              (id-string (field-name field))))))
+              (field-set? field
+                          (if (assignment? (assignment-right assign))
+                              (cons (assignment-right assign)
+                                    (cdr assigns))
+                              (cdr assigns))
+                          class level static?)))))
+  
+  ;inherited-field-set? field-record (list assignment) src -> bool
+  (define (inherited-field-set? field assigns src)
+    (if (null? assigns)
+        (inherited-field-not-set-error (field-record-name field) src)
+        (let* ((assign (car assigns))
+               (left (assignment-left assign)))
+          (when (access? left)
+            (set! left (access-name left)))
+          (or (cond
+                ((local-access? left)
+                 (equal? (id-string (local-access-name left))
+                         (field-record-name field)))
+                ((field-access? left)
+                 (and (special-name? (field-access-object left))
+                      (equal? "this" (special-name-name (field-access-object left)))
+                      (equal? (id-string (field-access-field left)) (field-record-name field)))))
+              (inherited-field-set? field (cdr assigns) src)))))
+  
+  (define (inherited-field-not-set-error name src)
+    (raise-error (string->symbol name)
+                 (format "Inherited field ~a must be set in the constructor for the current class" name)
+                 (string->symbol name) src))
+  
+  ;check-method: method env type-records (list string) boolean boolean-> void
+  (define (check-method method env level type-recs c-class static? iface?)
+    (let* ((ctor? (eq? 'ctor (type-spec-name (method-type method))))
+           (name (method-name method))
+           (sym-name (string->symbol (id-string name)))
+           (body (method-body method))
+           (mods (map modifier-kind (method-modifiers method)))
+           (return (if ctor? 
+                       'void
+                       (type-spec-to-type (method-type method) c-class level type-recs))))
+      (when iface? (set! mods (cons 'abstract mods)))
+      (when (memq 'native mods)
+        (send type-recs add-req (make-req (string-append (car c-class) "-native-methods") (cdr c-class))))
+      (if (or (memq 'abstract mods) (memq 'native mods))
+          (when body
+            (method-error (if (memq 'abstract mods) 'abstract 'native) sym-name (id-src name)))
+          (begin
+            (when (not body) (method-error 'no-body sym-name (id-src name)))
+            (when (and (not (eq? return 'void))
+                       (or (not (memq 'abstract mods))
+                           (not (memq 'native mods)))
+                       (not (reachable-return? body)))
+              (method-error 'no-reachable sym-name (id-src name)))
+            (check-statement body
+                             return
+                             (add-exns-to-env (map (lambda (n)
+                                                     (name->type n c-class (name-src n) level type-recs))
+                                                   (method-throws method))
+                                              (build-method-env (method-parms method) env level c-class type-recs))
+                             level
+                             type-recs
+                             c-class
+                             ctor?
+                             static?
+                             #f
+                             #f
+                             #f)
+            ))))
+  
+  ;build-method-env: (list field) env symbol (list string) type-records-> env
+  (define (build-method-env parms env level c-class type-recs)
+    (cond
+      ((null? parms) env)
+      (else
+       (build-method-env (cdr parms)
+                         (add-var-to-env (id-string (field-name (car parms)))
+                                         (type-spec-to-type (field-type (car parms)) c-class level type-recs)
+                                         (if (memq 'final (field-modifiers (car parms)))
+                                             final-parm
+                                             parm)
+                                         env)
+                         level
+                         c-class
+                         type-recs))))
+
+  ;reachable-return?: statement -> bool
+  (define (reachable-return? body)
+    (cond
+      ((ifS? body) 
+       (if (ifS-else body)
+           (and (reachable-return? (ifS-then body))
+                (reachable-return? (ifS-else body)))))
+      ((throw? body) #t)
+      ((return? body) #t)
+      ((while? body) (reachable-return? (while-loop body)))
+      ((doS? body) (reachable-return? (doS-loop body)))
+      ((for? body) (reachable-return? (for-loop body)))
+      ((try? body) 
+       (and (reachable-return? (try-body body))
+            (or (and (try-finally body)
+                     (reachable-return? (try-finally body)))
+                #t)
+            (andmap reachable-return? (map catch-body (try-catches body)))))
+      ((switch? body) #f)
+      ((block? body)
+       (if (null? (block-stmts body))
+           #f
+           (reachable-return? (list-ref (block-stmts body)
+                                        (sub1 (length (block-stmts body)))))))
+      ((break? body) #f)
+      ((continue? body) #f)
+      ((label? body) (reachable-return? (label-stmt body)))
+      ((synchronized? body) (reachable-return? (synchronized-stmt body)))
+      (else #f)))
+
+  ;check-var-init: expression (exp env -> type/env) type symbol type-records -> type/env
+  (define (check-var-init init check-e env dec-type name type-recs)
+    (let ((type (if (array-init? init)
+                    (if (array-type? dec-type)
+                        (begin
+                          (send type-recs add-req (make-req 'array null))
+                          (check-array-init (array-init-vals init) check-e env
+                                            (array-type-type dec-type) type-recs))
+                        (var-init-error 'array name dec-type #f (array-init-src init)))
+                    (check-e init env))))
+      (unless (assignment-conversion dec-type (type/env-t type) type-recs)
+        (var-init-error 'other name dec-type (type/env-t type) (expr-src init)))
+      type))
+  
+  ;check-array-init (U (list array-init) (list exp)) (exp env->type) type type-records -> type/env
+  (define (check-array-init inits check-e env dec-type type-recs)
+    (cond
+      ((null? inits) (make-type/env (make-array-type dec-type 1) env))
+      ((array-init? (car inits))
+       (let ((array-type/env (check-array-init-sub-inits inits check-e env dec-type type-recs)))
+         (make-type/env 
+          (make-array-type dec-type (add1 (array-type-dim (type/env-t array-type/env))))
+          (type/env-e array-type/env))))
+      (else
+       (let loop ((exps inits) (env env))
+         (cond 
+           ((null? exps) (make-type/env (make-array-type dec-type 1) env))
+           (else
+            (let ((new-type/env (check-e (car exps) env)))
+              (unless (assignment-conversion dec-type (type/env-t new-type/env) type-recs)
+                (array-init-error dec-type (type/env-t new-type/env) (expr-src (car exps))))
+              (loop (cdr exps) (type/env-t new-type/env)))))))))
+  
+  ;check-array-init-sub-inits: (list array-init) (exp env -> type/env) env type type-records -> type/env
+  (define (check-array-init-sub-inits inits check-e env type type-recs)
+    (cond
+      ((null? (cdr inits))
+       (check-array-init (array-init-vals (car inits)) check-e env type type-recs))
+      (else
+       (check-array-init-sub-inits (cdr inits) check-e
+                                   (check-array-init (array-init-vals (car inits)) check-e env type type-recs)
+                                   type type-recs))))
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;Member errors
+
+  (define (method-error kind method src)
+    (raise-error method
+                 (case kind
+                   ((no-reachable) (format "method ~a does not have a reachable return" method))
+                   ((abstract)
+                    (let ((line1 
+                           (format "abstract method ~a has an implementation, abstract methods may not have implementations"
+                                   method))
+                          (line2 "Either a ';'should come after the header, or the method should not be abstract"))
+                      (format "~a~n~a" line1 line2)))
+                   ((native) (format "native method ~a has an implementation which is not allowed" method))
+                   ((no-body) (format "method ~a has no implementation and is not abstract" method)))
+                 method src))
+  
+  ;var-init-error: symbol symbol type type src -> void
+  (define (var-init-error kind name dec-type given src)
+    (raise-error name
+                 (case kind
+                   ((array)
+                    (format "Expected ~a to be of declared type ~a, given an array" 
+                            name (type->ext-name dec-type)))
+                   ((other)
+                    (format "Expected ~a to be assignable to declared type ~a, given ~a which is unrelated"
+                            name (type->ext-name dec-type) (type->ext-name given))))
+                 name src))
+
+  ;array-init-error: type type src -> void
+  (define (array-init-error dec-type given src)
+    (let ((d (type->ext-name dec-type))
+          (g (type->ext-name given)))
+      (raise-error g
+                   (format "Error initializing declared array of ~a, given element with incompatible type ~a"
+                           d g)
+                   d src)))
+
+  ;field-not-set-error: id string symbol src
+  (define (field-not-set-error name class kind src)
+    (let ((n (id->ext-name name)))
+      (raise-error n
+                   (format "Field ~a from ~a must be set in the ~a and is not"
+                           n
+                           class
+                           (case kind
+                             ((beginner intermediate) "constructor")
+                             ((instance) "constructor or instance initialization")
+                             ((static) "static initialization")))
+                   n src)))
+
+  ;beginner-ctor-error: string statement src -> void
+  (define (beginner-ctor-error class kind src)
+    (let ((exp (statement->ext-name kind)))
+      (raise-error exp
+                   (format "Constructor for ~a may only assign the fields of ~a. Found illegal statement ~a"
+                           class class exp)
+                   exp src)))
+  
+  ;beginner-assn-error: sym src -> void
+  (define (beginner-assn-error kind src)
+    (raise-error 
+     '=
+     (case kind
+       ((not-left-this)
+        "Constructor must assign the class's fields. This expression is not a field of this class and maynot be assigned")
+       ((right-this)
+        "The constructor maynot assign fields with other of its fields. Other values must be used"))
+     '= src))          
+
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;Statement checking functions
+  
+  ;;check-statement: statement type env symbol type-records (U #f string) bool bool bool bool bool-> type/env
+  (define (check-statement statement return env level type-recs c-c ctor? static? in-loop? in-switch? interactions?)
+    (let* ((check-s (lambda (stmt env in-l? in-s?)
+                      (check-statement stmt return env level type-recs c-c ctor? static? in-l? in-s? interactions?)))
+           (check-s-env-change (lambda (smt env) (check-s smt env in-loop? in-switch?)))
+           (check-s-no-change (lambda (stmt) (check-s stmt env in-loop? in-switch?)))
+           (check-e (lambda (exp env)
+                      (check-expr exp env level type-recs c-c ctor? static? interactions? #f)))
+           (check-e-no-change (lambda (exp) (check-e exp env))))
+      (cond
+        ((ifS? statement) 
+         (check-ifS (check-e-no-change (ifS-cond statement))
+                    (expr-src (ifS-cond statement))
+                    check-s-env-change
+                    (ifS-then statement)
+                    (ifS-else statement)))
+        ((throw? statement)
+         (check-throw (check-e-no-change (throw-expr statement))
+                      (expr-src (throw-expr statement))
+                      env
+                      interactions?
+                      type-recs))
+        ((return? statement)
+         (check-return (return-expr statement)
+                       return
+                       check-e-no-change
+                       (return-src statement)
+                       interactions?
+                       level
+                       type-recs))
+        ((while? statement) 
+         (check-while (check-e-no-change (while-cond statement))
+                      (expr-src (while-cond statement))
+                      check-s
+                      (while-loop statement)))
+        ((doS? statement) 
+         (check-do check-e
+                   (doS-cond statement)
+                   (expr-src (doS-cond statement))
+                   (check-s (doS-loop statement) env #t #f)))
+        ((for? statement)
+         (check-for (for-init statement)
+                    (for-cond statement)
+                    (for-incr statement)
+                    (for-loop statement)
+                    check-e
+                    check-s
+                    env
+                    level
+                    c-c
+                    type-recs
+                    in-switch?))
+        ((try? statement) 
+         (check-try (try-body statement)
+                    (try-catches statement)
+                    (try-finally statement)
+                    env
+                    check-s-env-change
+                    type-recs))
+        ((switch? statement)
+         (check-switch (check-e-no-change (switch-expr statement))
+                       (expr-src (switch-expr statement))
+                       (switch-cases statement)
+                       in-loop?
+                       env
+                       check-e-no-change
+                       check-s))
+        ((block? statement)
+         (check-block (block-stmts statement)
+                      env
+                      check-s-env-change
+                      check-e
+                      level
+                      c-c
+                      type-recs))
+        ((def? statement) 
+         (check-local-inner statement
+                                env
+                                level
+                                c-c
+                                type-recs))
+        ((break? statement)
+         (check-break (break-label statement)
+                      (break-src statement)
+                      in-loop?
+                      in-switch?
+                      level
+                      env))
+        ((continue? statement)
+         (check-continue (continue-label statement)
+                         (continue-src statement)
+                         env
+                         in-loop?))
+        ((label? statement)
+         (check-label (label-stmt statement)
+                      (label-label statement)
+                      check-s-env-change
+                      env))
+        ((synchronized? statement)
+         (check-synchronized (check-e-no-change (synchronized-expr statement))
+                             (expr-src (synchronized-expr statement)))
+         (check-s-no-change (synchronized-stmt statement)))
+        ((statement-expression? statement)
+         (check-e-no-change statement)))))
+  
+  ;check-cond: symbol -> (type src -> void)
+  (define (check-cond kind)
+    (lambda (cond? cond-src)
+      (let ((check 
+             (lambda (t) 
+               (unless (eq? 'boolean t)
+                 (kind-condition-error kind t cond-src)))))
+        (cond
+          ((and (scheme-val? cond?) (scheme-val-type cond?)) => check)
+          ((scheme-val? cond?) (set-scheme-val-type! cond? 'boolean))
+          (else (check cond?))))))
+        
+  ;check-ifS: type/env src (stmt env -> type/env) stmt (U stmt #f) -> type/env
+  (define (check-ifS cond-t/e src check-s then else)
+    ((check-cond 'if) (type/env-t cond-t/e) src)
+    (let ((then/env (check-s then (type/env-e cond-t/e)))
+          (else/env (and else (check-s else (type/env-e cond-t/e)))))
+      (if else/env
+          (make-type/env 'void 
+                         (intersect-var-sets 
+                          (type/env-e cond-t/e) (type/env-e then/env) (type/env-e else/env)))
+          cond-t/e)))
+        
+  ;check-throw: type/env src env bool type-records -> type/env
+  (define (check-throw exp/env src env interact? type-recs)
+    (let ((exp-type (type/env-t exp/env)))
+      (cond
+        ((and (scheme-val? exp-type) (scheme-val-type exp-type)) 
+         =>
+         (lambda (t) (check-throw t src env interact? type-recs)))
+        ((scheme-val? exp-type) (set-scheme-val-type! throw-type))
+        ((or (not (ref-type? exp-type))
+             (not (is-eq-subclass? exp-type throw-type type-recs)))
+         (throw-error 'not-throwable exp-type src))
+        ((not (is-eq-subclass? exp-type runtime-exn-type type-recs))
+         (unless (or interact? (lookup-exn exp-type env type-recs 'full))
+           (throw-error 'not-declared exp-type src)))
+        (else
+         (send type-recs add-req (make-req "Throwable" (list "java" "lang")))))
+      exp/env))
+    
+  ;check-return: expression type (expression -> type/env) src bool symbol type-records -> type/env
+  (define (check-return ret-expr return check src interact? level type-recs)
+    (cond
+      (interact? (void))
+      ((and ret-expr (not (eq? 'void return)))
+         (let ((ret/env (check ret-expr)))
+           (if (assignment-conversion return (type/env-t ret/env) type-recs)
+               ret/env
+               (return-error 'not-equal (type/env-t ret/env) return src))))
+      ((and ret-expr (eq? 'void return) (not (eq? level 'full)))
+       (return-error 'void #f return src))
+      ((and (not ret-expr) (not (eq? 'void return)))
+       (return-error 'val #f return src))))
+  
+  ;check-while: type/env  src -> void
+  (define (check-while cond/env src check-s loop-body)
+    ((check-cond 'while) (type/env-t cond/env) src)
+    (check-s loop-body (type/env-e cond/env) #t #f))
+        
+  ;check-do: (exp env -> type/env) exp src type/env -> type/env
+  (define (check-do check-e exp src loop/env)
+    (let ((cond/env (check-e exp (type/env-e loop/env))))
+      ((check-cond 'do) (type/env-t cond/env) src)
+      cond/env))
+    
+  ;check-for: forInit exp (list exp) stmt (exp env -> type/env) 
+  ;           (stmt env bool bool-> type/env) env symbol (list string) type-records bool -> type/env
+  (define (check-for init cond incr loop check-e check-s env level c-class type-recs in-switch?)
+    (let* ((inits-env (if (and (not (null? init)) (field? (car init)))
+                          (check-for-vars init env check-e level c-class type-recs)
+                          (check-for-exps init env check-e)))
+           (cond/env (check-e cond inits-env)))
+      ((check-cond 'for) (type/env-t cond/env) (expr-src cond))
+      (check-s loop (check-for-exps incr inits-env check-e) #t in-switch?)))
+
+  ;check-for-vars: (list field) env (expression env -> type/env) symbol (list string) type-records -> env
+  (define (check-for-vars vars env check-e level c-class types)
+    (or (and (null? vars) env)
+        (check-for-vars (cdr vars) 
+                        (check-local-var (car vars) env check-e level c-class types) 
+                        check-e level c-class types)))
+  
+  ;check-for-exps (list exp) env (exp env -> type/env) -> env
+  (define (check-for-exps exps env check-e)
+    (or (and (null? exps) env)
+        (check-for-exps (cdr exps)
+                        (type/env-e (check-e (car exps) env))
+                        check-e)))
+  
+  ;check-local-var: field env (exp env -> type/env) symbol (list string) type-records -> env
+  (define (check-local-var local env check-e level c-class type-recs)
+    (let* ((is-var-init? (var-init? local))
+           (name (id-string (field-name local)))
+           (in-env? (lookup-var-in-env name env))
+           (sym-name (string->symbol name))
+           (type (type-spec-to-type (field-type local) c-class level type-recs))
+           (new-env (lambda (extend-env) (add-var-to-env name type method-var extend-env))))
+      (when (and in-env? (not (properties-field? (var-type-properties in-env?))))
+        (illegal-redefinition (field-name local) (field-src local)))
+      (if is-var-init?
+          (let ((new-type/env (check-var-init (var-init-init local) check-e env type sym-name type-recs)))
+            (unless (assignment-conversion type (type/env-t new-type/env) type-recs)
+              (variable-type-error (field-name local) (type/env-t new-type/env) type (var-init-src local)))
+            (add-set-to-env name (new-env (type/env-e new-type/env))))
+          (new-env env))))
+
+  ;check-try: statement (list catch) (U #f statement) env (statement env -> type/env) type-records -> type-env
+  (define (check-try body catches finally env check-s type-recs)
+    (let* ((new-env
+            (let loop ((catches catches) (new-env env))
+              (if (null? catches)
+                  new-env
+                  (let* ((catch (car catches))
+                         (type (field-type (catch-cond catch))))
+                    (unless (and (ref-type? type)
+                                 (is-eq-subclass? type throw-type type-recs))
+                      (catch-error type (field-src (catch-cond catch))))
+                    (loop (cdr catches) (add-exn-to-env type env))))))
+           (body-res (check-s body new-env)))
+      (for-each (lambda (catch)
+                  (let* ((field (catch-cond catch))
+                         (name (id-string (field-name field)))
+                         (in-env? (lookup-var-in-env name env)))
+                    (if (and in-env? (not (properties-field? (var-type-properties in-env?))))
+                        (illegal-redefinition (field-name field) (field-src field))
+                        (check-s (catch-body catch)
+                                 (add-var-to-env name (field-type field) parm env)))))
+                catches)
+      (when finally (check-s finally env)
+        body-res)))
+
+  ;INCORRECT!!! This doesn't properly type check and I'm just raising an error for now
+  ;Skipping proper checks of the statements + proper checking that constants aren't repeated
+  ;check-switch: type src (list caseS) bool env (expression -> type) (statement env bool bool -> void) -> void
+  (define (check-switch expr-type expr-src cases in-loop? env check-e check-s)
+    (error 'internal-error "check-switch: Switch statements are not correctly implemented")
+    (when (or (eq? expr-type 'long)
+              (not (prim-integral-type? expr-type)))
+      (switch-error 'switch-type 'switch expr-type #f expr-src))
+    (for-each (lambda (case)
+                (let* ((constant (caseS-constant case))
+                       (cons-type (unless (eq? 'default constant) (check-e constant))))
+                  (if (or (eq? 'default constant)
+                          (type=? cons-type expr-type))
+                      void
+                      (switch-error 'incompat 'case cons-type expr-type (expr-src constant)))))
+              cases))
+  
+  ;check-block: (list (U stmt field)) env (stmt env -> type/env) (expr env -> type/env) symbol 
+  ;             (list string) type-records -> type/env
+  (define (check-block stmts env check-s check-e level c-class type-recs)
+    (let loop ((stmts stmts) (block-env env))
+      (cond 
+        ((null? stmts) (make-type/env 'void block-env))
+        ((field? (car stmts))
+         (loop (cdr stmts) 
+               (check-local-var (car stmts) block-env check-e level c-class type-recs)))
+        (else
+         (loop (cdr stmts) (type/env-e (check-s (car stmts) block-env)))))))
+      
+  ;check-local-inner: def env symbol (list string) type-records -> type/env
+  (define (check-local-inner def env level c-class type-recs)
+    ((update-class-with-inner) def)
+    (let ((original-name (id-string (def-name def)))
+          (rec/new-name (check-inner-def def level type-recs c-class env)))
+      (make-type/env 
+       (make-ref-type original-name null) 
+       (add-local-inner-to-env original-name (car rec/new-name) (cadr rec/new-name) env))))
+  
+  ;check-break: (U id #f) src bool bool symbol env-> type/env
+  (define (check-break label src in-loop? in-switch? level env)
+    (cond
+      (label
+       (unless (lookup-label (id-string label) env)
+         (illegal-label 'break (id-string label) (id-src label))))
+      ((not (or in-loop? in-switch?)) (break-error src level)))
+    (make-type/env 'void env))
+  
+  ;check-continue: (U id #f) src env bool -> type/env
+  (define (check-continue label src env in-loop?)
+    (cond
+      (label
+       (unless (lookup-label (id-string label) env)
+         (illegal-label 'continue (id-string label) (id-src label))))
+      ((not in-loop?) (continue-error src)))
+    (make-type/env 'void env))
+  
+  ;check-label: statement string (statement env -> void) env -> type/env
+  (define (check-label stmt label check-s env)
+    (check-s stmt (add-label-to-env label env)))
+
+  ;check-synchronized: type/env src -> type/env
+  (define (check-synchronized e-type e-src)
+    (unless (reference-type? (type/env-t e-type))
+      (synch-error (type/env-t e-type) e-src))
+    e-type)
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;Statement error messages
+
+  ;make-condition-error: symbol type src -> void
+  (define (kind-condition-error kind cond src)
+    (raise-error kind
+                 (format "~a condition must be a boolean: Given ~a" 
+                         kind (type->ext-name cond))
+                 kind src))
+    
+  ;throw-error: symbol type src -> void
+  (define (throw-error kind thrown src)
+    (let ((t (type->ext-name thrown)))
+      (raise-error 'throw
+                   (case kind
+                     ((not-throwable)
+                      (format "Expression for throw must be a subtype of Throwable: given ~a" t))
+                     ((not-declared)
+                      (format "Thrown type ~a must be declared as thrown or caught" t)))
+                   'throw src)))
+  
+  ;return-error: symbol type type src -> void
+  (define (return-error kind given expected src)
+    (let ((g (type->ext-name given))
+          (e (type->ext-name expected)))
+      (raise-error 
+       'return
+       (case kind
+         ((not-equal)
+          (let ((line1 
+                 (format "The return expression's type must be equal to or a subclass of the method's return ~a." e))
+                (line2
+                 (format "The given expression has type ~a which is not equivalent to the declared return" g)))
+            (format "~a~n~a" line1 line2)))
+         ((void) "No value should be returned from void method, found a returned value")
+         ((val)
+          (format "Expected a return value assignable to ~a. No value was given" e)))
+       'return src)))
+
+  ;illegal-redefinition: id src -> void
+  (define (illegal-redefinition field src)
+    (let ((f (id->ext-name field)))
+      (raise-error 
+       f
+       (format "Variable name ~a has already been used and may not be reused. Another name must be chosen" f)
+       f src)))
+  
+  ;variable-type-error: id type type src -> void
+  (define (variable-type-error field given expt src)
+    (let ((f (id->ext-name field)))
+      (raise-error 
+       f
+       (format "Variable ~a was declared to be ~a, which is incompatible with the initial value type of ~a"
+               f (type->ext-name expt) (type->ext-name given))
+       f src)))
+
+  ;catch-error: type src -> void
+  (define (catch-error given src)
+    (raise-error 'catch
+                 (format "catch clause must catch an argument of subclass Throwable: Given ~a"
+                         (type->ext-name given))
+                 'catch src))
+  
+  ;switch-error symbol symbol type type src -> void
+  (define (switch-error kind syn given expected src)
+    (raise-error
+     syn
+     (case kind
+       ((switch-type) 
+        (format "switch expression must be of type byte, short, int or char. Given: ~a" 
+                (type->ext-name given)))
+       ((incompat)
+        (format "switch case must be same type as switch expression. Given ~a: expected ~a"
+                (type->ext-name given) (type->ext-name expected))))
+     syn src))
+  
+  ;illegal-label: symbol string src -> void
+  (define (illegal-label kind label src)
+    (raise-error kind
+                 (format "~a references label ~a, no enclosing statement has this label"
+                         kind label)
+                 kind src))
+                 
+  ;break-error: src -> void
+  (define (break-error src level)
+    (raise-error 'break (if (eq? level 'full) 
+                            "break must be in either a loop or a switch"
+                            "break must be in a loop")
+                 'break src))
+  (define (continue-error src)
+    (raise-error 'continue "continue must be in a loop" 'continue src))
+
+  ;synch-error: type src -> void
+  (define (synch-error given src)
+    (raise-error 'synchronize
+                 (format "synchronization expression must be a subtype of Object: Given ~a"
+                         (type->ext-name given))
+                 'synchronize src))                                        
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;Expression checking functions
+  
+  ;; check-expr: expression env symbol type-records (U string #f) bool bool bool bool-> type/env
+  (define (check-expr exp env level type-recs c-class ctor? static? interact? assign-left?)
+    (let ((check-sub-expr 
+           (lambda (expr env) (check-expr expr env level type-recs c-class ctor? static? interact? assign-left?)))
+          (check-assign-left
+           (lambda (expr env) (check-expr expr env level type-recs c-class ctor? static? interact? #t))))
+      (cond
+        ((literal? exp)
+         (make-type/env
+          (if (memq (expr-types exp) `(String string))
+              (begin (add-required c-class "String" `("java" "lang") type-recs)
+                     (set-expr-type exp string-type))
+              (expr-types exp)) env))
+        ((bin-op? exp)
+         (set-expr-type exp 
+                        (check-bin-op (bin-op-op exp) (bin-op-left exp) (bin-op-right exp)
+                                      check-sub-expr env
+                                      (expr-src exp)
+                                      level type-recs)))
+        ((access? exp)
+         (set-expr-type exp
+                        (check-access exp check-sub-expr env level type-recs c-class interact? static? assign-left?)))
+        ((special-name? exp)
+         (make-type/env (set-expr-type exp (check-special-name exp env static? interact?)) env))
+        ((specified-this? exp)
+         (make-type/env (set-expr-type exp (check-specified-this exp env static? interact? level type-recs)) env))
+        ((call? exp)
+         (set-expr-type exp (check-call exp
+                                        (call-args exp)
+                                        check-sub-expr
+                                        c-class
+                                        level
+                                        env type-recs
+                                        ctor? static? interact?)))
+        ((class-alloc? exp)
+         (set-expr-type exp
+                        (check-class-alloc exp
+                                           (class-alloc-name exp)
+                                           (class-alloc-args exp)
+                                           check-sub-expr
+                                           (expr-src exp)
+                                           type-recs
+                                           c-class
+                                           env level static?)))
+        ((inner-alloc? exp)
+         (set-expr-type exp
+                        (check-inner-alloc exp 
+                                           (inner-alloc-obj exp)
+                                           (inner-alloc-name exp)
+                                           (inner-alloc-args exp)
+                                           check-sub-expr
+                                           (expr-src exp)
+                                           type-recs
+                                           c-class
+                                           env
+                                           level static?)))
+        ((def? exp) 
+         (set-expr-type exp
+                        (check-local-inner exp type-recs c-class env level)))
+        ((array-alloc? exp)
+         (set-expr-type exp
+                        (check-array-alloc (array-alloc-name exp)
+                                           (array-alloc-size exp)
+                                           (array-alloc-dim exp)
+                                           (expr-src exp)
+                                           check-sub-expr
+                                           env
+                                           level
+                                           c-class
+                                           type-recs)))
+        ((array-alloc-init? exp)
+         (set-expr-type exp
+                        (check-array-alloc-init (array-alloc-init-name exp)
+                                                (array-alloc-init-dim exp)
+                                                (array-alloc-init-init exp)
+                                                (expr-src exp)
+                                                check-sub-expr
+                                                env
+                                                level
+                                                c-class
+                                                type-recs)))
+        ((cond-expression? exp)
+         (set-expr-type exp
+                        (check-cond-expr (check-sub-expr (cond-expression-cond exp) env)
+                                         (cond-expression-then exp)
+                                         (cond-expression-else exp)
+                                         check-sub-expr
+                                         (expr-src exp)
+                                         (expr-src (cond-expression-cond exp))
+                                         level
+                                         type-recs)))
+        ((array-access? exp)
+         (set-expr-type exp
+                        (check-array-access (check-sub-expr (array-access-name exp) env)
+                                            (array-access-index exp)
+                                            check-sub-expr
+                                            (expr-src exp)
+                                            type-recs)))
+        ((post-expr? exp)
+         (set-expr-type exp
+                        (check-pre-post-expr (check-sub-expr (post-expr-expr exp) env)
+                                             (post-expr-op exp)
+                                             (expr-src exp))))
+        ((pre-expr? exp)
+         (set-expr-type exp
+                        (check-pre-post-expr (check-sub-expr (pre-expr-expr exp) env)
+                                             (pre-expr-op exp)
+                                             (expr-src exp))))      
+        ((unary? exp)
+         (set-expr-type exp
+                        (check-unary (check-sub-expr (unary-expr exp) env)
+                                     (unary-op exp)
+                                     (expr-src exp))))
+        ((cast? exp)
+         (set-expr-type exp
+                        (check-cast (check-sub-expr (cast-expr exp) env)
+                                    (cast-type exp)
+                                    (expr-src exp)
+                                    level
+                                    c-class 
+                                    type-recs)))
+        ((instanceof? exp)
+         (set-expr-type exp
+                        (check-instanceof (check-sub-expr (instanceof-expr exp) env) 
+                                          (instanceof-type exp)
+                                          (expr-src exp)
+                                          level
+                                          c-class
+                                          type-recs)))
+        ((assignment? exp)
+         (set-expr-type exp
+                        (check-assignment (assignment-op exp)
+                                          (assignment-left exp)
+                                          (assignment-right exp)
+                                          check-assign-left
+                                          check-sub-expr
+                                          (expr-src exp)
+                                          ctor?
+                                          #f ; static-init?
+                                          c-class
+                                          level
+                                          type-recs
+                                          env))))))
+
+  ;;check-bin-op: symbol exp exp (exp env -> type/env) env src-loc symbol type-records -> type/env
+  ;;Fully checks bin-ops, including checking the subexpressions
+  (define (check-bin-op op left right check-e env src level type-recs)
+    (let* ((l/env (check-e left env))
+           (r/env (check-e right (type/env-e l/env))))
+      (make-type/env 
+       (bin-op-type-check op (type/env-t l/env) (type/env-t r/env) src level type-recs)
+       (type/env-e r/env))))
+
+  ;;bin-op-type-check: symbol type type src symbol type-recs -> type
+  ;Just verifies the types of the operation, used by bin-op and assignment
+  (define (bin-op-type-check op l r src level type-recs)
+    (case op
+      ((* / % *= /= %=)       ;; 15.17
+       (prim-check prim-numeric-type? binary-promotion 'num l r op src))
+      ((+ - += -=)      ;; 15.18
+       (if (and (memq level '(advanced full))
+                (eq? '+ op) (or (is-string-type? l) (is-string-type? r)))
+           string-type
+           (prim-check prim-numeric-type? binary-promotion 'num l r op src)))
+      ((<< >> >>> <<= >>= >>>=)      ;; 15.19
+       (prim-check prim-integral-type? 
+                   (lambda (l r) (unary-promotion l)) 'int l r op src))
+      ((< > <= >=)      ;; 15.20
+       (prim-check prim-numeric-type? (lambda (l r) 'boolean) 'num l r op src))
+      ((== !=)      ;; 15.21
+       (cond
+         ((eq? level 'beginner)
+          (if (or (and (prim-integral-type? l) (prim-integral-type? r))
+                  (and (eq? 'boolean l) (eq? 'boolean r)))
+              'boolean
+              (bin-op-beginner-error op l r src)))
+         ((or (and (prim-numeric-type? l) (prim-numeric-type? r))
+              (and (eq? 'boolean l) (eq? 'boolean r)))
+          'boolean)
+         ((and (reference-type? l) (reference-type? r))
+          (let ((right-to-left (assignment-conversion l r type-recs))
+                (left-to-right (assignment-conversion r l type-recs)))
+            (cond
+              ((or right-to-left left-to-right) 'boolean)
+              (else (bin-op-equality-error 'both op l r src)))))
+         (else 
+          (bin-op-equality-error 'prim op l r src))))
+      ((& ^ or &= ^= or=)      ;; 15.22
+       (cond
+         ((and (prim-numeric-type? l) (prim-numeric-type? r)) (binary-promotion l r))
+         ((and (eq? 'boolean l) (eq? 'boolean r)) 'boolean)
+         (else (bin-op-bitwise-error op l r src))))
+      ((&& oror)      ;; 15.23, 15.24
+       (prim-check (lambda (b) (eq? b 'boolean)) 
+                   (lambda (l r) 'boolean) 'bool l r op src))))
+
+  
+  ;prim-check: (type -> bool) (type type -> type) type type src -> type
+  (define (prim-check ok? return expt l r op src)
+    (cond
+      ((and (ok? l) (ok? r)) (return l r))
+      ((ok? l) (bin-op-prim-error 'right op expt l r src))
+      ((ok? r) (bin-op-prim-error 'left op expt l r src))
+      (else (bin-op-prim-error 'both op expt l r src))))
+
+  ;; 5.6.1
+  ;;unary-promotion: type -> symbol
+  (define (unary-promotion t)
+    (cond
+      ((and (scheme-val? t) (scheme-val-type t))
+       (unary-promotion (scheme-val-type t)))
+      ((scheme-val? t) 
+       (set-scheme-val-type! t 'int) 'int)
+      (else 
+       (case t ((byte short char) 'int) (else t)))))
+  
+  ;; 5.6.2
+  ;; binary-promotion: type type -> type
+  (define (binary-promotion t1 t2)
+    (cond
+      ((and (scheme-val? t1) (scheme-val? t2))
+       (cond
+         ((and (scheme-val-type t1) (scheme-val-type t2))
+          (binary-promotion (scheme-val-type t1) (scheme-val-type t2)))
+         ((or (scheme-val-type t1) (scheme-val-type t2))
+          (error 'internal-error "Binary promotion does not know how to handle this situation yet"))
+         (else (make-scheme-val (gensym 'unnamed) #f #f #f))))
+      ((scheme-val? t1)
+       (cond
+         ((scheme-val-type t1) (binary-promotion (scheme-val-type t1) t2))
+         (else (set-scheme-val-type! t1 t2) t2)))
+      ((scheme-val? t2)
+       (cond
+         ((scheme-val-type t2) (binary-promotion t1 (scheme-val-type t2)))
+         (else (set-scheme-val-type! t2 t1) t1)))
+      ((or (eq? 'double t1) (eq? 'double t2)) 'double)
+      ((or (eq? 'float t1) (eq? 'float t2)) 'float)
+      ((or (eq? 'long t1) (eq? 'long t2)) 'long)
+      (else 'int)))
+
+  ;;check-access: expression (expr env -> type/env) env symbol type-records (list string) bool bool bool -> type/env
+  (define (check-access exp check-e env level type-recs c-class interact? static? assign-left?)
+    (let ((acc (access-name exp)))
+      (cond
+        ((field-access? acc)
+         (let* ((obj (field-access-object acc))
+                (obj-type/env (check-e obj env))
+                (fname (id-string (field-access-field acc)))
+                (src (id-src (field-access-field acc)))
+                (class-rec null)
+                (record null))
+           (set! record 
+                 (if obj
+                     (field-lookup fname (type/env-t obj-type/env) obj src level type-recs)
+                     (let* ((name (var-access-class (field-access-access acc))))
+                       (set! class-rec
+                             ;First clause: static field of a local inner class
+                             (or (and (or (string? name) (= 1 (length name)))
+                                      (let ((rec? (lookup-local-inner (if (pair? name) (car name) name) env)))
+                                        (and rec? (inner-rec-record rec?))))
+                                 (get-record (send type-recs get-class-record 
+                                                   (if (pair? name) name (list name))
+                                                   #f
+                                                   ((get-importer type-recs) name type-recs level src))
+                                             type-recs)))
+                       (cond
+                         ((class-record? class-rec)
+                          (get-field-record fname class-rec
+                                            (lambda () 
+                                              (let* ((class? (member fname (send type-recs get-class-env)))
+                                                     (method? (not (null? (get-method-records fname class-rec)))))
+                                                (field-lookup-error (if class? 'class-name 
+                                                                        (if method? 'method-name 'not-found))
+                                                                    (string->symbol fname)
+                                                                    (make-ref-type (if (pair? name) (car name) name) null)
+                                                                    src)))))
+                         ((scheme-record? class-rec)
+                          (lookup-scheme class-rec fname 
+                                         (lambda () (field-lookup-error 'not-found
+                                                                        (string->symbol fname)
+                                                                        (make-ref-type (if (pair? name) (car name) name) 
+                                                                                       (list "scheme"))
+                                                                        src))))))))
+           (cond 
+             ((field-record? record)
+              (let* ((field-class (if (null? (cdr (field-record-class record))) 
+                                      (cons (car (field-record-class record))
+                                            (send type-recs lookup-path 
+                                                  (car (field-record-class record)) (lambda () null)))
+                                      (field-record-class record)))
+                     (mods (field-record-modifiers record))
+                     (public? (memq 'public mods))
+                     (private? (memq 'private mods))
+                     (protected? (memq 'protected mods))
+                     (local-inner-field-class? 
+                      (and (null? (cdr field-class))
+                           (lookup-local-inner (car field-class) env))))
+                
+                (when (and (special-name? obj)
+                           (not (lookup-var-in-env fname env)))
+                  (access-before-define (string->symbol fname) src))
+                
+                (when (and (field-access-access acc)
+                           (var-access-static? (field-access-access acc)))
+                  (unless (memq 'static mods)
+                    (not-static-field-access-error (string->symbol fname) level src)))
+                
+                (when (and (eq? level 'beginner)
+                           (eq? (car c-class) (car field-class))
+                           (or (not obj) (and (special-name? obj) (not (expr-src obj)))))
+                  (beginner-field-access-error (string->symbol fname) src))
+           
+                (when (and private? (not (equal? c-class field-class)))
+                  (illegal-field-access 'private (string->symbol fname) level (car field-class) src))
+                
+                (when (and protected? 
+                           (not (or (equal? c-class field-class)
+                                    (is-subclass? c-class (make-ref-type (car field-class) (cdr field-class)) type-recs)
+                                    (package-members? c-class field-class type-recs))))
+                  (illegal-field-access 'protected (string->symbol fname) level (car field-class) src))
+                          
+                (when (and (not private?) (not protected?) 
+                           (not public?) (not (package-members? c-class field-class type-recs)))
+                  (illegal-field-access 'package (string->symbol fname) level (car field-class) src))
+           
+                (set-field-access-access! acc (make-var-access (memq 'static mods)
+                                                               (memq 'final mods)
+                                                               (field-record-init? record)
+                                                               (cond
+                                                                 (private? 'private)
+                                                                 (public? 'public)
+                                                                 (protected? 'protected)
+                                                                 (else 'package))
+                                                               (if local-inner-field-class?
+                                                                   (inner-rec-unique-name local-inner-field-class?)
+                                                                   (car field-class))))
+                (unless local-inner-field-class?
+                  (add-required c-class (car field-class) (cdr field-class) type-recs))
+                (unless (eq? level 'full)
+                  (when (is-field-restricted? fname field-class)
+                    (restricted-field-access-err (field-access-field acc) field-class src)))
+                (make-type/env (field-record-type record) 
+                               (if (type/env? obj-type/env) (type/env-e obj-type/env) env))))
+             ((and (scheme-val? record) (scheme-val-instance? record))
+              (set-field-access-access! acc (make-var-access #f #t #t 'public 'unknown))
+              (make-type/env record (type/env-e obj-type/env)))
+             ((scheme-val? record)
+              (add-required c-class (scheme-record-name class-rec) 
+                            (cons "scheme" (scheme-record-path class-rec)) type-recs)
+              (set-field-access-access! acc (make-var-access #t #t #t 'public (scheme-record-name class-rec)))
+              (make-type/env record (type/env-e obj-type/env)))
+             (else 
+              (error 'internal-error "field-access given unknown form of field information")))))
+        ((local-access? acc) 
+         (let ((var (lookup-var-in-env (id-string (local-access-name acc)) env)))
+           (unless (properties-usable? (var-type-properties var))
+             (unusable-var-error (string->symbol (var-type-var var)) (id-src (local-access-name acc))))
+           (unless interact?
+             (unless assign-left?
+               (unless (properties-parm? (var-type-properties var))
+                 (unless (var-set? (var-type-var var) env)
+                   (unset-var-error (string->symbol (var-type-var var)) (id-src (local-access-name acc)))))))
+           (make-type/env (var-type-type var) env)))
+        
+        (else
+         (let* ((first-acc (id-string (car acc)))
+                (first-binding (lookup-var-in-env first-acc env))
+                (new-acc
+                 (cond
+                   ((and (eq? level 'full) (not first-binding) (> (length acc) 1))
+                    (let* ((static-class (find-static-class acc level type-recs))
+                           (accs (cadr static-class)))
+                      (build-field-accesses 
+                       (make-access #f (expr-src exp)
+                                    (make-field-access 
+                                     #f
+                                     (car accs)
+                                     (make-var-access #t #f #f 'temp 
+                                                      (if (class-record? (car static-class))
+                                                          (class-record-name (car static-class))
+                                                          (cons (scheme-record-name (car static-class))
+                                                                (cons "scheme"
+                                                                      (scheme-record-path (car static-class))))))))
+                       (cdr accs))))
+                   ((and (memq level '(beginner intermediate advanced)) (not first-binding) (> (length acc) 1)
+                         (with-handlers ((exn:fail:syntax? (lambda (e) #f)))
+                           (type-exists? first-acc null c-class (id-src (car acc)) level type-recs)))
+                    (build-field-accesses
+                     (make-access #f
+                                  (expr-src exp)
+                                  (make-field-access #f
+                                                     (cadr acc)
+                                                     (make-var-access #t #f #f 'temp first-acc)))
+                     (cddr acc)))
+                   ((and first-binding (not (properties-field? (var-type-properties first-binding))))
+                    (build-field-accesses
+                     (make-access #f (expr-src exp) (make-local-access (car acc)))
+                     (cdr acc)))
+                   (first-binding
+                    (let* ((encl-depth (lookup-containing-class-depth (id-string (car acc)) env))
+                           (encl-type (unless (or interact? static?)
+                                        (if (= encl-depth 0) 
+                                            (var-type-type (lookup-var-in-env "this" env))
+                                            (var-type-type (lookup-var-in-env (format "encl-this-~a" encl-depth) env)))))
+                           (encl-class (if static?
+                                           c-class
+                                           (unless interact?
+                                             (cons (ref-type-class/iface encl-type) (ref-type-path encl-type))))))
+                      (if (properties-static? (var-type-properties first-binding))
+                          (build-field-accesses
+                           (make-access #f (expr-src exp)
+                                        (make-field-access #f
+                                                           (car acc)
+                                                           (make-var-access #t #f #f 'temp encl-class)))
+                           (cdr acc))
+                          (if interact?
+                              (build-field-accesses (make-access #f (expr-src exp) (make-local-access (car acc)))
+                                                    (cdr acc))
+                              (build-field-accesses
+                               (make-access #f (expr-src exp)
+                                            (make-field-access 
+                                             (if (= encl-depth 0)
+                                                 (make-special-name #f #f "this")
+                                                 (make-access #f (expr-src exp) 
+                                                              (make-local-access 
+                                                               (make-id (format "encl-this-~a" encl-depth)
+                                                                        (expr-src exp)))))
+                                             (car acc)
+                                             #f))
+                               (cdr acc))))))
+                   (else 
+                    (let ((class? (member (id-string (car acc)) (send type-recs get-class-env)))
+                          (method? (not (null? (get-method-records (id-string (car acc)) (lookup-this type-recs env))))))
+                      (cond
+                        ((or class? method?)
+                         (variable-not-found-error (if class? 'class-name 'method-name) (car acc) (id-src (car acc))))
+                        ((close-to-keyword? (id-string (car acc)))
+                         (close-to-keyword-error 'field (car acc) (id-src (car acc))))
+                        (else
+                         (variable-not-found-error 'not-found (car acc) (id-src (car acc))))))))))
+           (set-access-name! exp new-acc)
+           (check-e exp env))))))
+  
+  ;package-members? (list string) (list string) type-records -> bool
+  (define (package-members? class1 class2 type-recs)
+    (cond
+      ((equal? (car class1) "scheme-interactions") 
+       (equal? (send type-recs get-interactions-package) (cdr class2)))
+      ((equal? (car class2) "scheme-interactions")
+       (equal? (send type-recs get-interactions-package) (cdr class1)))
+      (else (equal? (cdr class1) (cdr class2)))))
+  
+  ;; field-lookup: string type expression src symbol type-records -> (U field-record scheme-val)
+  (define (field-lookup fname obj-type obj src level type-recs)
+    (let ((obj-src (expr-src obj))
+          (name (string->symbol fname)))
+      (cond
+        ((and (scheme-val? obj-type) (scheme-val-type obj-type))
+         (field-lookup fname (scheme-val-type obj-type) obj src level type-recs))
+        ((scheme-val? obj-type)
+         (let ((field-c (make-scheme-val fname #t #t #f)))
+           (set-scheme-val-type! (make-unknown-ref null (list field-c)))
+           field-c))
+        ((unknown-ref? obj-type)
+         (cond
+           ((field-contract-lookup fname (unknown-ref-fields obj-type)) => (lambda (x) x))
+           (else
+            (let ((field-c (make-scheme-val fname #t #t #f)))
+              (set-unknown-ref-fields! obj-type (cons field-c (unknown-ref-fields obj-type)))
+              field-c))))
+        ((reference-type? obj-type)
+         (let ((obj-record (get-record (send type-recs get-class-record obj-type #f
+                                             ((get-importer type-recs) obj-type type-recs level obj-src))
+                                       type-recs)))
+           (get-field-record fname obj-record
+                             (lambda () 
+                               (let* ((class? (member fname (send type-recs get-class-env)))
+                                      (method? (not (null? (get-method-records fname obj-record)))))
+                                 (field-lookup-error 
+                                  (if class? 'class-name 
+                                      (if method? 'method-name 'not-found)) name obj-type src))))))
+        ((array-type? obj-type)
+         (unless (equal? fname "length")
+           (field-lookup-error 'array name obj-type src))
+         (make-field-record "length" `(public) #f `(array) 'int))
+        (else (field-lookup-error 'primitive name obj-type obj-src)))))
+  
+  ;; build-field-accesses: access (list id) -> field-access
+  (define (build-field-accesses start accesses)
+    (cond
+      ((null? accesses) (access-name start))
+      (else
+       (build-field-accesses
+        (make-access #f (expr-src start) 
+                     (make-field-access start (car accesses) #f))
+        (cdr accesses)))))
+  
+  ;;find-static-class: (list access) symbol type-recs -> (list class-record (list access))
+  (define (find-static-class accs level type-recs)
+    (let ((path (send type-recs lookup-path (id-string (car accs)) (lambda () #f))))
+      (if path
+          (list (let* ((name (cons (id-string (car accs)) path))
+                       (record (get-record 
+                                (send type-recs get-class-record name #f
+                                      ((get-importer type-recs) name type-recs level (id-src (car accs))))
+                                type-recs)))
+                  record)
+                (cdr accs))
+          (let ((found? (find-static (list (car accs)) (cdr accs))))
+            (if (car found?)
+                (list (get-record (send type-recs get-class-record (car found?)) type-recs)
+                      (cdr found?))
+                (class-lookup-error (caadr found?) (id-src (car accs))))))))
+    
+  ;find-static: (list id) (list id) -> (list (U #f (list id)) (list string)))
+  (define (find-static test-path remainder)
+    (let ((string-path (map id-string test-path)))
+      (cond
+        ((null? (cdr remainder))
+         (list #f (list (apply build-path string-path))))
+        ((find-directory string-path) =>
+         (lambda (directory)
+           (if (class-exists? directory (id-string (car remainder)))
+               (list (cdr remainder) (cons (id-string (car remainder)) string-path))
+               (find-static (append string-path (list (id-string (car remainder))))
+                            (cdr remainder)))))
+      (else (list #f (apply build-path (append string-path (list (id-string (car remainder))))))))))
+  
+  ;find-directory: (list string) -> (U string bool)
+  (define (find-directory path)
+    (if (null? path)
+        (build-path 'same)
+        (let loop ((paths (get-classpath)))
+          (cond
+            ((null? paths) #f)
+            ((directory-exists? (build-path (car paths)
+                                            (apply build-path path)))
+             (build-path (car paths) (apply build-path path)))
+            (else (loop (cdr paths)))))))
+  
+  ;class-exists?: string string -> bool
+  (define (class-exists? path class)
+    (or (file-exists? (string-append (build-path path class) ".java"))
+        (file-exists? (string-append (build-path path "compiled" class) ".jinfo"))))
+  
+  ;check-special-name: expression env bool bool-> type
+  (define (check-special-name exp env static? interact?)
+    (when static? 
+      (special-error (expr-src exp) interact?))
+    (var-type-type (lookup-var-in-env "this" env)))
+  
+  ;check-specified-this: expression env bool bool -> type
+  (define (check-specified-this exp env static? interact? level type-recs)
+    (when static?
+      (special-error (expr-src exp) interact?))
+    (let ((var (lookup-enclosing-this (specified-this-class exp) env level type-recs)))
+      (set-specified-this-var! exp (var-type-var var))
+      (var-type-type var)))
+    
+  ;check-args: (list exp) (expr env -> type/env) env -> (list (list type) env)
+  (define (check-args args check-e env)
+    (let loop ((args args) (arg-types null) (env env))
+      (cond
+        ((null? args) (list (reverse arg-types) env))
+        (else 
+         (let ((arg/env (check-e (car args) env)))
+           (loop (cdr args) (cons (type/env-t arg/env) arg-types) (type/env-e arg/env)))))))
+    
+  ;; 15.12
+  ;check-call: exp (list exp) (expr env ->type/env) (list string) symbol env type-records bool bool-> type/env
+  (define (check-call call arg-exps check-sub c-class level env type-recs ctor? static? interact?)
+    (let* ((this (unless static? (lookup-this type-recs env)))
+           (src (expr-src call))
+           (name (call-method-name call))
+           (expr (call-expr call))
+           (exp-type #f)
+           (handle-call-error 
+            (lambda (exn)
+              (when (not (access? expr)) (raise exn))
+              (when (or (field-access? (access-name expr)) (local-access? expr)) (raise exn))
+              (if (eq? level 'full)
+                  (let ((record (car (find-static-class (append (access-name expr) (list name))
+                                                        level type-recs))))
+                    (set-call-expr! call #f)
+                    (cond
+                      ((class-record? record)
+                       (unless (equal? (class-record-name record) c-class)
+                         (send type-recs add-req (make-req (car (class-record-name record))
+                                                           (if (null? (cdr (class-record-name record)))
+                                                               (send type-recs lookup-path 
+                                                                     (car (class-record-name record))
+                                                                     (lambda () null))
+                                                               (cdr (class-record-name record))))))
+                       (get-method-records (id-string name) record))
+                      ((scheme-record? record)
+                       (let ((result 
+                              (lookup-scheme record (id-string name) 
+                                             (lambda () (no-method-error 'class 'not-found
+                                                                         (string->symbol (id-string name))
+                                                                         (make-ref-type (if (pair? name) (car name) name) 
+                                                                                        (list "scheme"))
+                                                                         src)))))
+                         (if (scheme-val-type result)
+                             (if (method-contract? (scheme-val-type result))
+                                 (list (scheme-val-type result))
+                                 (no-method-error 'class 'field (string->symbol (id-string name))
+                                                  (make-ref-type (if (pair? name) (car name) name) 
+                                                                 (list "scheme"))
+                                                  src))
+                             (let ((m-c 
+                                    (make-method-contract (id-string name) 
+                                                          (make-scheme-val 'method-result #t #f #f) #f)))
+                               (set-scheme-val-type! result m-c)
+                               (list m-c)))))))
+                  (if (and (= (length (access-name expr)) 1)
+                           (with-handlers ((exn:fail:syntax? (lambda (exn) #f)))
+                             (type-exists? (id-string (car (access-name expr)))
+                                           null c-class
+                                           (id-src (car (access-name expr)))
+                                           level type-recs)))
+                      (let ((record (send type-recs get-class-record (list (id-string (car (access-name expr)))))))
+                        (set-call-expr! call #f)
+                        (cond 
+                          ((class-record? record)
+                           (unless (equal? (class-record-name record) c-class)
+                             (send type-recs add-req (make-req (car (class-record-name record))
+                                                               (send type-recs lookup-path 
+                                                                     (car (class-record-name record))
+                                                                     (lambda () null)))))
+                           (let ((methods (get-method-records (id-string name) record)))
+                             (unless (andmap (lambda (x) x) 
+                                             (map (lambda (mrec) (memq 'static (method-record-modifiers mrec)))
+                                                  methods))
+                               (class-as-object-call level (id-string (car (access-name expr))) name (id-src name)))
+                             methods))
+                          ((scheme-record? record) (raise exn))))
+                      (raise exn)))))
+           (methods 
+            (cond 
+              ((special-name? name)
+               (let ((n (special-name-name name)))
+                 (unless ctor? (illegal-ctor-call n src level))
+                 (if (string=? n "super")
+                     (let ((parent (car (class-record-parents this))))
+                       (get-method-records (car parent)
+                                           (get-record (send type-recs get-class-record parent) type-recs)))
+                     (get-method-records (car (class-record-name this)) this))))
+              (else
+               (cond
+                 ((special-name? expr)
+                  (if (equal? (special-name-name expr) "super")
+                      (let ((parent (car (class-record-parents this))))
+                        (set! exp-type 'super)
+                        (get-method-records (id-string name)
+                                            (send type-recs get-class-record parent)))
+                      (get-method-records (id-string name) this)))
+                 (expr
+                  (let* ((call-exp/env 
+                          (with-handlers ((exn:fail:syntax? handle-call-error))
+                            (check-sub expr env)))
+                         (call-exp 
+                          (if (type/env? call-exp/env) 
+                              (begin (set! env (type/env-e call-exp/env))
+                                     (type/env-t call-exp/env))
+                              call-exp/env)))
+                    (cond
+                      ;List of methods found
+                      ((list? call-exp) call-exp)
+                      ((array-type? call-exp)
+                       (set! exp-type call-exp)
+                       (get-method-records (id-string name)
+                                           (send type-recs get-class-record object-type)))
+                      ((and (scheme-val? call-exp) (scheme-val-type call-exp) 
+                            (unknown-ref? (scheme-val-type call-exp)))
+                       (set! exp-type call-exp)
+                       (get-method-contracts (id-string name) (scheme-val-type call-exp)))
+                      ((and (scheme-val? call-exp) (not (scheme-val-type call-exp)))
+                       (let ((m-contract (make-method-contract (id-string name) 
+                                                               (make-scheme-val 'method-return #t #f #f) #f)))
+                         (set! exp-type call-exp)
+                         (set-scheme-val-type! call-exp (make-unknown-ref (list m-contract) null))
+                         (list m-contract)))                           
+                      ((reference-type? call-exp)
+                       (set! exp-type call-exp)
+                       (get-method-records (id-string name)
+                                           (get-record 
+                                            (send type-recs get-class-record call-exp #f
+                                                  ((get-importer type-recs) 
+                                                   (cons (ref-type-class/iface call-exp) (ref-type-path call-exp))
+                                                   type-recs level src))
+                                            type-recs)))
+                      (else (prim-call-error call-exp name src level)))))
+                 (else 
+                  (if (eq? level 'beginner)
+                      (beginner-method-access-error name (id-src name))
+                      (let ((rec (if static? (send type-recs get-class-record c-class) this)))
+                        (if (null? rec) null
+                            (get-method-records (id-string name) rec))))))))))
+      
+      (when (null? methods)
+        (let* ((rec (if exp-type 
+                        (send type-recs get-class-record exp-type)
+                        (if static? (send type-recs get-class-record c-class) this)))
+               (class? (member (id-string name) (send type-recs get-class-env)))
+               (field? (cond
+                         ((array-type? exp-type) (equal? (id-string name) "length"))
+                         ((null? rec) 
+                          (member (id-string name) 
+                                  (map field-record-name (send type-recs get-interactions-fields))))
+                         (else (member (id-string name) (map field-record-name (get-field-records rec))))))
+               (sub-kind (if class? 'class-name (if field? 'field-name 'not-found))))
+        (cond 
+          ((eq? exp-type 'super) (no-method-error 'super sub-kind exp-type name src))
+          (exp-type (no-method-error 'class sub-kind exp-type name src))
+          (else 
+           (cond
+             ((close-to-keyword? (id-string name))
+              (close-to-keyword-error 'method name src))
+             (interact? (interaction-call-error name src level))
+             (else
+              (no-method-error 'this sub-kind exp-type name src)))))))
+                  
+      (when (and (not ctor?)
+                 (eq? (method-record-rtype (car methods)) 'ctor))
+        (ctor-called-error exp-type name src))
+      
+      (let* ((args/env (check-args arg-exps check-sub 
+                                   env))
+             (args (car args/env))
+             (method-record 
+              (cond
+                ((method-contract? (car methods))
+                 (set-method-contract-args! (car methods) args)
+                 (car methods))
+                ((memq level '(full advanced))
+                 (resolve-overloading methods 
+                                      args
+                                      (lambda () (call-arg-error 'number name args exp-type src))
+                                      (lambda () (call-arg-error 'conflict name args exp-type src))
+                                      (lambda () (call-arg-error 'no-match name args exp-type src))
+                                      type-recs))
+                ((> (length methods) 1)
+                 (let ((teaching-error
+                        (lambda (kind)
+                          (if (error-file-exists? (method-record-class (car methods)) type-recs)
+                              (call-provided-error (id-string name) args kind)
+                              (teaching-call-error kind #f name args exp-type src methods)))))
+                   (resolve-overloading methods
+                                        args
+                                        (lambda () (teaching-error 'number))
+                                        (lambda () (teaching-error 'type))
+                                        (lambda () (teaching-error 'type))
+                                        type-recs)))
+                (else
+                 (when 
+                     (check-method-args args (method-record-atypes (car methods)) name exp-type src type-recs)
+                   (car methods)))))
+             (mods (when (method-record? method-record) (method-record-modifiers method-record))))
+        
+        (cond 
+          ((method-record? method-record)        
+           (when (and static? (not (memq 'static mods)) (not expr))
+             (non-static-called-error name c-class src level))
+           
+           (when (and (memq 'protected mods) (reference-type? exp-type) 
+                      (or (not (is-eq-subclass? this exp-type type-recs))
+                          (not (package-members? c-class (cons (ref-type-class/iface exp-type) (ref-type-path exp-type))
+                                                 type-recs))))
+             (call-access-error 'pro level name exp-type src))
+           (when (and (memq 'private mods)
+                      (reference-type? exp-type)
+                      (if static?
+                          (not (and (equal? (ref-type-class/iface exp-type) (car c-class))
+                                    (equal? (ref-type-path exp-type) (cdr c-class))))
+                          (not (eq? this (send type-recs get-class-record exp-type)))))
+             (call-access-error 'pri level name exp-type src))
+           (when (and (not (memq 'private mods)) (not (memq 'public mods)) 
+                      (not (memq 'protected mods)) (reference-type? exp-type)
+                      (not (package-members? c-class (cons (ref-type-class/iface exp-type) 
+                                                           (ref-type-path exp-type)) type-recs)))
+             (call-access-error 'pac level name exp-type src))
+           (when (eq? level 'full)
+             (for-each (lambda (thrown)
+                         (unless (lookup-exn thrown env type-recs level)
+                           (thrown-error (ref-type-class/iface thrown) name exp-type src)))
+                       (method-record-throws method-record)))
+           (when (and (eq? level 'beginner)
+                      (eq? 'void (method-record-rtype method-record)))
+             (beginner-call-error name src))
+           (unless (eq? level 'full)
+             (when (and (id? name) (is-method-restricted? (id-string name) (method-record-class method-record)))
+               (restricted-method-call name (method-record-class method-record) src)))
+           (set-call-method-record! call method-record)
+           (make-type/env (method-record-rtype method-record) (cadr args/env)))
+          ((method-contract? method-record)
+           (set-call-method-record! call method-record)
+           (make-type/env (method-contract-return method-record) (cadr args/env)))))))
+    
+  ;close-to-keyword: string -> bool
+  (define (close-to-keyword? str)
+    (let ((s (string-copy str)))
+      (string-lowercase! s)
+      (member s `("if" "return"))))
+  
+  (define (error-file-exists? class type-recs) #f)
+  (define (call-provided-error) null)
+  
+  ;check-method-args: (list type) (list type) id type src type-records -> void
+  (define (check-method-args args atypes name exp-type src type-recs)
+    (let ((bad-length? (not (= (length args) (length atypes)))))
+      (cond
+        ((and (special-name? name) (not (expr-src name)) bad-length?)
+         (method-arg-error 'implicit-ctor args atypes name exp-type src))
+        (bad-length?
+         (method-arg-error 'number args atypes name exp-type src))
+        (else
+         (for-each (lambda (arg atype)
+                     (unless (assignment-conversion atype arg type-recs)
+                       (method-arg-error 'type (list arg) (cons atype atypes) name exp-type src)))
+                   args atypes)))))
+  
+  ;; 15.9
+  ;;check-class-alloc: expr (U name identifier) (list exp) (exp env -> type/env) src type-records 
+  ;                   (list string) env symbol bool-> type/env
+  (define (check-class-alloc exp name/def arg-exps check-e src type-recs c-class env level static?)
+    (let* ((args/env (check-args arg-exps check-e env))
+           (args (car args/env))
+           (name (cond
+                   ((def? name/def)
+                    (check-inner-def name/def level type-recs c-class env)
+                    (make-name (def-name name/def) null (id-src (def-name name/def))))
+                   ((id? name/def) (make-name name/def null (id-src name/def)))
+                   (else name/def)))
+           (inner-lookup? (lookup-local-inner (id-string (name-id name)) env))      
+           (type (if inner-lookup?
+                     (make-ref-type (inner-rec-unique-name inner-lookup?) null)
+                     (name->type name c-class (name-src name) level type-recs)))
+           (class-record 
+            (if inner-lookup?
+                (inner-rec-record inner-lookup?)
+                (get-record (send type-recs get-class-record type c-class) type-recs)))
+           (methods (get-method-records (id-string (name-id name)) class-record)))
+      (unless (or (equal? (car (class-record-name class-record)) (ref-type-class/iface type)))
+        (set-id-string! (name-id name) (car (class-record-name class-record)))
+        (set-class-alloc-class-inner?! exp #t))
+      (when inner-lookup?
+        (set-id-string! (name-id name) (inner-rec-unique-name inner-lookup?))
+        (set-class-alloc-local-inner?! exp #t))
+      (unless (or (equal? (ref-type-class/iface type) (car c-class))
+                  (equal? (car (class-record-name class-record))
+                          (format "~a.~a" (car c-class) (ref-type-class/iface type)))
+                  (class-alloc-class-inner? exp)
+                  (class-alloc-local-inner? exp)
+                  (inner-alloc? exp))
+        (send type-recs add-req (make-req (ref-type-class/iface type) (ref-type-path type))))
+      (when (memq 'abstract (class-record-modifiers class-record))
+        (class-alloc-error 'abstract type (name-src name)))
+      (unless (class-record-class? class-record)
+        (class-alloc-error 'interface type (name-src name)))
+      (let* ((const (if (memq level `(full advanced))
+                        (resolve-overloading methods 
+                                             args
+                                             (lambda () (ctor-overload-error 'number type args src))
+                                             (lambda () (ctor-overload-error 'conflict type args src))
+                                             (lambda () (ctor-overload-error 'no-match type args src))
+                                             type-recs)
+                        (if (> (length methods) 1)
+                            (let ((teaching-error
+                                   (lambda (kind)
+                                     (if (error-file-exists? class-record type-recs)
+                                         (call-provided-error (id-string (name-id name)) args kind)
+                                         (teaching-call-error kind #t (name-id name) args #f src methods)))))
+                              (resolve-overloading methods
+                                                   args
+                                                   (lambda () (teaching-error 'number))
+                                                   (lambda () (teaching-error 'type))
+                                                   (lambda () (teaching-error 'type))
+                                                   type-recs))
+                            (when (check-ctor-args args (method-record-atypes (car methods)) type src level type-recs)
+                              (car methods)))))
+             (mods (method-record-modifiers const))
+             (this (if static? 
+                       class-record
+                       (lookup-this type-recs env))))
+        (when (eq? level 'full)
+          (for-each (lambda (thrown)
+                      (unless (lookup-exn thrown env type-recs level)
+                        (ctor-throws-error (ref-type-class/iface thrown) type src)))
+                    (method-record-throws const)))
+        (when (and (memq 'private mods) (not (eq? class-record this)))
+          (class-access-error 'pri level type src))
+        (when (and (memq 'protected mods) (or (not (is-eq-subclass? this type type-recs)) 
+                                              (not (package-members? c-class (cons (ref-type-class/iface type) 
+                                                                                   (ref-type-path type)) type-recs))))
+          (class-access-error 'pro level type src))
+        (when (and (not (memq 'private mods)) (not (memq 'protected mods)) (not (memq 'public mods))
+                   (not (package-members? c-class (cons (ref-type-class/iface type) (ref-type-path type)) type-recs)))
+          (class-access-error 'pac level type src))
+        ((if (class-alloc? exp) set-class-alloc-ctor-record! set-inner-alloc-ctor-record!)exp const)
+        (make-type/env type (cadr args/env)))))
+  
+  ;check-inner-alloc: exp exp id (list exp) (exp env -> type/env) src type-records (list string) 
+  ;                   env symbol bool -> type/env
+  (define (check-inner-alloc exp obj name args check-e src type-recs c-class env level static?)
+    (let* ((obj-type/env (check-e obj env))
+           (obj-type (type/env-t obj-type/env))
+           (cur-env (type/env-e obj-type/env))
+           (class-rec (send type-recs get-class-record obj-type)))
+      (unless (ref-type? obj-type) (inner-on-non-obj obj-type src))
+      (unless (member (id-string name) 
+                      (map bytes->string/locale (map inner-record-name (class-record-inners class-rec))))
+        (check-inner-error obj-type name src))
+      (set-id-string! name (string-append (ref-type-class/iface obj-type) "." (id-string name)))
+      (check-class-alloc exp (make-name name null (id-src name)) args check-e src type-recs c-class env level static?)))
+  
+  (define (inner-on-non-obj type src)
+    (let ((t (type->ext-name type)))
+      (raise-error t
+                   (format "class invocation cannot be preceeded by non-object value ~a" t)
+                   t src)))
+  
+  (define (check-inner-error type name src)
+    (let ((t (type->ext-name type))
+          (n (id->ext-name name)))
+      (raise-error n
+                   (format "class ~a does not contain an inner class ~a" t n)
+                   t src)))
+
+  ;check-ctor-args: (list type) (list type) type src symbol type-records -> void
+  (define (check-ctor-args args atypes name src level type-recs)
+    (unless (= (length args) (length atypes))
+      (ctor-arg-error 'number args atypes name src))
+    (for-each (lambda (arg atype)
+                (unless (assignment-conversion atype arg type-recs)
+                  (ctor-arg-error 'type (list arg) (cons atype atypes) name src)))
+              args atypes))
+  
+  ;; 15.10
+  ;;check-array-alloc: type-spec (list exp) int src (expr env ->type/env) env 
+  ;                    symbol (list string) type-records -> type/env
+  (define (check-array-alloc elt-type exps dim src check-sub-exp env level c-class type-recs)
+    (send type-recs add-req (make-req 'array null))
+    (let* ((inner-lookup? 
+            (and (name? (type-spec-name elt-type))
+                 (lookup-local-inner (id-string (name-id (type-spec-name elt-type))) env)))
+           (type 
+            (if inner-lookup?
+                (if (> (type-spec-dim elt-type) 0)
+                    (make-array-type
+                     (make-ref-type (inner-rec-unique-name inner-lookup?) null)
+                     (type-spec-dim elt-type))
+                    (make-ref-type (inner-rec-unique-name inner-lookup?) null))
+                (type-spec-to-type elt-type c-class level type-recs))))
+      (when (and (ref-type? type) (not inner-lookup?))
+        (add-required c-class (ref-type-class/iface type) (ref-type-path type) type-recs))
+      (set-type-spec-dim! elt-type (+ (length exps) dim))
+      (let loop ((subs exps) (env env))
+        (cond
+          ((null? subs)
+           (make-type/env (make-array-type type (+ (length exps) dim)) env))
+          (else
+           (let* ((t/env (check-sub-exp (car subs) env))
+                  (t (type/env-t t/env)))
+             (when (and (scheme-val? t) (not (scheme-val-type t)))
+               (set-scheme-val-type! t 'int))
+             (unless (prim-integral-type? t)
+               (array-size-error type t (expr-src (car subs))))
+             (loop (cdr subs) (type/env-e t/env))))))))
+  
+  ;;15.10
+  ;;check-array-alloc-init: type-spec int array-init src (expr env->type/env) env symbol 
+  ;;                        (list string) type-records -> type/env
+  (define (check-array-alloc-init elt-type dim init src check-sub-exp env level c-class type-recs)
+    (send type-recs add-req (make-req 'array null))
+    (let* ((inner-lookup? 
+            (and (name? (type-spec-name elt-type))
+                 (lookup-local-inner (id-string (name-id (type-spec-name elt-type))) env)))
+           (type 
+            (if inner-lookup?
+                (if (> (type-spec-dim elt-type) 0)
+                    (make-array-type
+                     (make-ref-type (inner-rec-unique-name inner-lookup?) null)
+                     (type-spec-dim elt-type))
+                    (make-ref-type (inner-rec-unique-name inner-lookup?) null))
+                (type-spec-to-type elt-type c-class level type-recs)))
+           (a-type/env (check-array-init (array-init-vals init) check-sub-exp env type type-recs))
+           (a-type (type/env-t a-type/env)))
+      (when (and (ref-type? type) (not inner-lookup?))
+        (add-required c-class (ref-type-class/iface type) (ref-type-path type) type-recs))
+      (unless (= (array-type-dim a-type) dim)
+        (array-dim-error type dim (array-type-dim a-type) src))
+      (make-type/env (make-array-type type dim) (type/env-e a-type/env))))
+  
+  ;; 15.25
+  ;check-cond-expr: type/env exp exp (exp env -> type/env) src src symbol type-records -> type/env
+  (define (check-cond-expr test/env then-e else-e check-e src test-src level type-recs)
+    (let* ((test (type/env-t test/env))
+           (then/env (check-e then-e (type/env-e test/env)))
+           (else/env (check-e else-e (type/env-e test/env)))
+           (then (type/env-t then/env))
+           (else-t (type/env-t else/env)))
+      (cond
+        ((and (scheme-val? test) (scheme-val-type test))
+         (unless (eq? 'boolean (scheme-val-type test))
+           (condition-error (scheme-val-type test) test-src)))
+        ((scheme-val? test) (set-scheme-val-type! test 'boolean))
+        (else 
+         (unless (eq? 'boolean test) (condition-error test test-src))))
+      (make-type/env
+       (cond
+         ((and (or (scheme-val? then) (scheme-val? else-t))
+               (or (eq? 'boolean then) (eq? 'boolean else-t)))
+          (cond
+            ((scheme-val? then)
+             (cond
+               ((and (scheme-val-type then) (eq? 'boolean (scheme-val-type then))) 'boolean)
+               (else (set-scheme-val-type! then 'boolean) 'boolean)))
+            ((scheme-val? else-t)
+             (cond
+               ((and (scheme-val-type else-t) (eq? 'boolean (scheme-val-type else-t))) 'boolean)
+               (else (set-scheme-val-type! else-t 'boolean) 'boolean)))))
+         ((and (eq? 'boolean then) (eq? 'boolean else-t)) 'boolean)
+         ((and (prim-numeric-type? then) (prim-numeric-type? else-t))
+          ;; This is not entirely correct, but close enough due to using scheme ints
+          (binary-promotion then else-t))
+         ((and (eq? 'null then) (reference-type? else-t)) else-t)
+         ((and (eq? 'null else-t) (reference-type? then)) then)
+         ((and (reference-type? then) (reference-type? else-t))
+          (if (assignment-conversion then else-t type-recs) 
+              then
+              (if (assignment-conversion else-t then type-recs)
+                  else-t)))
+         (else (condition-mismatch-error then else-t src)))
+       (intersect-var-sets (type/env-e test/env) (type/env-e then/env) (type/env-e else/env)))))
+
+  ;; 15.13
+  ;check-array-access: type/env exp (exp env -> type/env) src -> type/env
+  (define (check-array-access ref/env idx check-e src type-recs)
+    (let* ((ref-type (type/env-t ref/env))
+           (idx/env (check-e idx (type/env-e ref/env)))
+           (idx-type (type/env-t idx/env)))
+      (send type-recs add-req (make-req 'array null))
+      (unless (array-type? ref-type)
+        (illegal-array-access ref-type src))
+      (when (or (not (prim-integral-type? idx-type))
+                (not (eq? 'int (unary-promotion idx-type))))
+        (array-access-error ref-type idx-type src))
+      (make-type/env (if (= 1 (array-type-dim ref-type))
+                         (array-type-type ref-type)
+                         (make-array-type (array-type-type ref-type)
+                                          (sub1 (array-type-dim ref-type))))
+                     (type/env-e idx/env))))
+  
+  ;; 15.14 & 15.15
+  ;;Skips checking of whether expr is variable or value, and whether that variable is final
+  ;;check-pre-post-expr: type/env symbol src -> type/env
+  (define (check-pre-post-expr type/env op src)
+    (let ((type (type/env-t type/env)))
+       (if (prim-numeric-type? type)
+           type/env
+           (unary-error op 'num type src))))
+  
+  ;; 15.15
+  ;check-unary: type/env symbol src -> type/env
+  (define (check-unary expr-type/env op src)
+    (let ((expr-type (type/env-t expr-type/env)))
+      (make-type/env
+       (case op
+         ((+ -)
+          (if (prim-numeric-type? expr-type)
+              (unary-promotion expr-type)
+              (unary-error op 'num expr-type src)))
+         ((~)
+          (if (prim-integral-type? expr-type)
+              (unary-promotion expr-type)
+              (unary-error op 'int expr-type src)))
+         ((!)
+          (if (eq? 'boolean expr-type)
+              'boolean
+              (unary-error op 'bool expr-type src))))
+       (type/env-e expr-type/env))))
+  
+  ;; 15.16
+  ;check-cast: type/env type-spec src symbol (list string) type-records -> type/env
+  (define (check-cast exp-type/env cast-type src level current-class type-recs)
+    (let* ((exp-type (type/env-t exp-type/env))
+           (env (type/env-e exp-type/env))
+           (inner-lookup? 
+            (and (name? (type-spec-name cast-type))
+                 (lookup-local-inner (id-string (name-id (type-spec-name cast-type))) env)))
+           (type 
+            (if inner-lookup?
+                (if (> (type-spec-dim cast-type) 0)
+                    (make-array-type
+                     (make-ref-type (inner-rec-unique-name inner-lookup?) null)
+                     (type-spec-dim cast-type))
+                    (make-ref-type (inner-rec-unique-name inner-lookup?) null))
+                (type-spec-to-type cast-type current-class level type-recs))))
+      (when (and (reference-type? type) (not inner-lookup?))
+        (unless (equal? (car current-class) (ref-type-class/iface type))
+          (send type-recs add-req (make-req (ref-type-class/iface type) (ref-type-path type)))))
+      (make-type/env
+       (cond
+         ((and (reference-type? exp-type) (reference-type? type)) type)
+         ((and (not (reference-type? exp-type)) (not (reference-type? type))) type)
+         ((reference-type? exp-type) (cast-error 'from-prim exp-type type src))
+         (else (cast-error 'from-ref exp-type type src)))
+       (type/env-e exp-type/env))))
+
+  ;; 15.20.2
+  ;check-instanceof type/env type-spec src symbol (list string) type-records -> type/env
+  (define (check-instanceof exp-type/env inst-type src level current-class type-recs)
+    (let* ((exp-type (type/env-t exp-type/env))
+           (env (type/env-e exp-type/env))
+           (inner-lookup? 
+            (and (name? (type-spec-name inst-type))
+                 (lookup-local-inner (id-string (name-id (type-spec-name inst-type))) env)))
+           (type 
+            (if inner-lookup?
+                (if (> (type-spec-dim inst-type) 0)
+                    (make-array-type
+                     (make-ref-type (inner-rec-unique-name inner-lookup?) null)
+                     (type-spec-dim inst-type))
+                    (make-ref-type (inner-rec-unique-name inner-lookup?) null))
+                (type-spec-to-type inst-type current-class level type-recs))))
+      (when (and (ref-type? type) (not inner-lookup?))
+        (unless (equal? (car current-class) (ref-type-class/iface type))
+          (send type-recs add-req (make-req (ref-type-class/iface type) (ref-type-path type)))))
+      (make-type/env 
+       (cond 
+         ((and (ref-type? exp-type) (ref-type? type) 
+               (or (is-eq-subclass? exp-type type type-recs)
+                   (is-eq-subclass? type exp-type type-recs))) 'boolean)
+         ((and (ref-type? exp-type) (ref-type? type))
+          (instanceof-error 'not-related-type type exp-type src))
+         ((ref-type? exp-type)
+          (instanceof-error 'not-class type exp-type src))
+         (else
+          (cond
+            ((memq level '(beginner intermediate)) (instanceof-error 'not-ref type exp-type src))
+            ((and (array-type? exp-type) (array-type? type)
+                  (= (array-type-dim exp-type) (array-type-dim type))
+                  (or (assignment-conversion exp-type type type-recs))) 'boolean)
+            ((and (array-type? exp-type) (array-type? type))
+             (instanceof-error 'not-related-array type exp-type src))
+            ((array-type? exp-type)
+             (instanceof-error 'not-array type exp-type src))
+            (else (instanceof-error 'not-reforarray type exp-type src)))))
+       (type/env-e exp-type/env))))
+  
+  ;; 15.26
+  ;; SKIP - doing the check for compound assignment
+  ;check-assignment: symbol exp exp (exp env -> type/env) (exp env -> type/env) src bool bool string symbol type-records env -> type/env
+  (define (check-assignment op l-exp r-exp check-l check-r src c-tor? static-init? c-class level type-recs env)
+    (when (and (eq? level 'beginner) (not c-tor?)) (illegal-assignment src))
+    (let* ((ltype/env (check-l l-exp env))
+           (rtype/env (check-r r-exp (type/env-e ltype/env)))
+           (ltype (type/env-t ltype/env))
+           (rtype (type/env-t rtype/env)))
+      (when (access? l-exp)
+        (check-final l-exp c-tor? static-init? c-class env))
+      (make-type/env
+       (case op
+         ((=)
+          (if (assignment-conversion ltype rtype type-recs)
+              ltype
+              (assignment-error op ltype rtype src)))
+         ((+= *= /= %= -= <<= >>= >>>= &= ^= or=)
+          (bin-op-type-check op ltype rtype src level type-recs)
+          ltype))
+       (if (and (access? l-exp)
+                (local-access? (access-name l-exp)))
+           (add-set-to-env (id-string (local-access-name (access-name l-exp)))
+                           (type/env-e rtype/env))
+           (type/env-e rtype/env)))))
+
+  ;check-final: expression bool bool string -> void
+  (define (check-final expr ctor? static-init? c-class env)
+    (let ((access (access-name expr))
+          (class (car c-class)))
+      (cond
+        ((local-access? access)
+         (let* ((name (local-access-name access))
+                (properties (var-type-properties (lookup-var-in-env (id-string name) env)))
+                (settable? (properties-settable? properties))
+                (static? (properties-static? properties)))
+           (when (properties-final? properties)
+             (when (not (properties-field? properties)) (assign-final-error 'local name class))
+             (cond
+               ((and ctor? settable? (not static?)) (void))
+               ((and ctor? settable? static?) (assign-final-error 'static-in-ctor name class))
+               ((and ctor? (not settable?)) (assign-final-error 'cannot-set-ctor name class))
+               ((and static-init? settable?) (void))
+               ((and static-init? (not settable?)) (assign-final-error 'cannot-set-static name class))
+               (else (assign-final-error (if static? 'static 'field) name class))))))
+        ((field-access? access)
+         (let* ((name (field-access-field access))
+                (obj (field-access-object access))
+                (v-acc (field-access-access access))
+                (init? (var-access-init? v-acc))
+                (static? (var-access-static? v-acc)))
+           (when (var-access-final? v-acc)
+             (if (and (or (this-expr? obj) (and static-init? (not obj))) 
+                      (equal? (var-access-class v-acc) class))
+                 (cond
+                   ((and ctor? (not init?) (not static?)) (void))
+                   ((and ctor? (not init?) static?) (assign-final-error 'static-in-ctor name class))
+                   ((and ctor? init? static?) (assign-final-error 'static-ctor-already-set name class))
+                   ((and ctor? init? (not static?)) (assign-final-error 'field-already-set name class))
+                   ((and static-init? (not init?)) (void))
+                   ((and static-init? init?) (assign-final-error 'static-already-set name class))
+                   (else (assign-final-error (if static? 'static 'field) name class)))
+                 (assign-final-error (if static? 'static 'field) name class))))))))
+  
+  ;this-expr: expr -> bool
+  (define (this-expr? expr)
+    (and (special-name? expr)
+         (equal? "this" (special-name-name expr))))
+  
+      
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;Expression Errors
+
+  ;;Binop errors
+  ;;bin-op-prim-error: symbol symbol symbol type type src -> void
+  (define (bin-op-prim-error side op expect left right src)
+    (let ((ext-out (get-expected expect))
+          (rt (type->ext-name right))
+          (lt (type->ext-name left))
+          (op (if (eq? op 'oror) (string->symbol "||") op)))
+      (raise-error
+       op
+       (case side
+         ((right) (format "Right hand side of ~a should be of type ~a, but given ~a" op ext-out rt))
+         ((left) (format "Left hand side of ~a should be of type ~a, but given ~a" op ext-out lt))
+         (else (format "~a expects arguments of type ~a, but given ~a and ~a" op ext-out lt rt)))
+       op src)))
+  
+  ;bin-op-beginner-error symbol type type src -> void
+  (define (bin-op-beginner-error op left right src)
+    (let ((rt (type->ext-name right))
+          (lt (type->ext-name left)))
+      (raise-error op
+                   (format "~a only compares integer, character, or boolean values. ~a to ~a is not allowed"
+                           op rt lt)
+                   op src)))
+  
+  ;bin-op-equality-error symbol symbol type type src -> void
+  (define (bin-op-equality-error type op left right src)
+    (let ((rt (type->ext-name right))
+          (lt (type->ext-name left)))
+      (raise-error 
+       op
+       (case type
+         ((both) 
+          (format "~a expects one argument to be assignable to the other, neither ~a nor ~a can be" op lt rt))
+         (else 
+          (format "~a expects its arguments to be equivalent types, given non-equivalent ~a and ~a" 
+                  op lt rt)))
+       op src)))
+
+  ;bin-op-bitwise-error symbol type type src -> void
+  (define (bin-op-bitwise-error op left right src)
+    (let ((lt (type->ext-name left))
+          (rt (type->ext-name right))
+          (prim-list "double, float, long, int, short, byte or char")
+          (op (if (eq? op 'or) (symbol->string "|") op)))
+      (raise-error 
+       op 
+       (cond
+         ((prim-numeric-type? left) 
+          (format "~a expects the right hand side to be a ~a when the left is ~a. Given ~a"
+                  op prim-list lt rt))
+         ((prim-numeric-type? right)
+          (format "~a expects the left hand side to be a ~a when the left is ~a. Given ~a"
+                  op prim-list rt lt))
+         ((eq? left 'boolean)
+          (format "~a expects the right hand side to be a ~a when the left is ~a. Given ~a"
+                  op "boolean" lt rt))
+         ((eq? right 'boolean)
+          (format "~a expects the left hand side to be a ~a when the right is ~a. Given ~a"
+                  op "boolean" rt lt))
+         (else
+          (format "~a expects its arguments to both be either booleans, or ~a. Given ~a and ~a"
+                  op prim-list lt rt)))
+       op src)))
+
+  ;;check-access errors
+  
+  ;variable-not-found-error: symbol id src -> void
+  (define (variable-not-found-error kind var src)
+    (let ((name (id->ext-name var)))
+      (raise-error 
+       name
+       (case kind
+         ((not-found) (format "reference to undefined identifier ~a" name))
+         ((class-name) (format "class named ~a cannot be used as a variable, which is how it is used here" name))
+         ((method-name) 
+          (let ((line1
+                 (format "method named ~a cannot be used as a variable, which is how it is used here." name))
+                (line2 "A call to a method should be followed by () and any arguments to the method"))
+            (format "~a~n~a" line1 line2))))
+       name src)))
+  
+  ;field-lookup-error: symbol symbol type src -> void
+  (define (field-lookup-error kind field exp src)
+    (let ((t (type->ext-name exp)))
+      (raise-error
+       field
+       (case kind
+         ((not-found) (format "field ~a not found for object with type ~a" field t))
+         ((class-name)
+          (format "Class named ~a is being erroneously accessed as a field" field))
+         ((method-name)
+          (let ((line1
+                 (format "Method ~a is being erroneously accessed as a field for class ~a." field t))
+                (line2 "A call to a method chould be followed by () and any arguments to the method"))
+            (format "~a~n~a" line1 line2)))
+         ((array)
+          (format "~a only has a length field, attempted to access ~a" t field))
+         ((primitive)
+          (format "attempted to access field ~a on ~a, this value does not have fields" field t)))
+       field src)))
+
+  ;unusable-var-error: symbol src -> void
+  (define (unusable-var-error name src)
+    (raise-error 
+     name
+     (format "field ~a cannot be used in this class, as two or more parents contain a field with this name" name)
+     name src))
+
+  ;unset-var-error: symbol src -> void
+  (define (unset-var-error name src)
+    (raise-error name
+                 (format "local variable ~a was not set along all paths reaching this point, and cannot be used"
+                         name)
+                 name src))     
+  ;access-before-defined: symbol src -> void
+  (define (access-before-define name src)
+    (raise-error name
+                 (format "field ~a cannot be accessed before its definition" name)
+                 name src))
+  
+  ;not-static-field-access-error symbol symbol src -> void
+  (define (not-static-field-access-error name level src)
+    (raise-error 
+     name
+     (case level
+       ((beginner intermediate) 
+        (format "Field ~a cannot be retrieved from a class, ~a can only be accessed from an instance of the class"
+                name name))
+       ((advanced full)
+        (format "Field ~a accessed as though static; this field is not a static field" name)))
+     name src))
+  
+  ;beginner-field-access-error: symbol src -> void
+  (define (beginner-field-access-error name src)
+    (raise-error
+     name
+     (format "field ~a from the current class accessed as a variable. fields should be accessed with 'this'" name)
+     name src))
+  
+  ;illegal-field-access: symbol symbol symbol string src -> void
+  (define (illegal-field-access kind field level class src)
+    (raise-error
+     field
+     (if (or (eq? kind 'private) (memq level '(beginner intermediate)))
+         (format "field ~a not found for object with type ~a" field class)
+         (case kind
+           ((protected) 
+            (format "field ~a of class ~a can only be accessed by ~a, subclasses of ~a, or fellow package members"
+                    field class class class))
+           ((package) (format "field ~a of class ~a can only be accessed by ~a and fellow package members of ~a" 
+                       field class class class))))
+     field src))
+  
+  ;restricted-field-access: id (list string) src -> void
+  (define (restricted-field-access-err field class src)
+    (let ((n (id->ext-name field)))
+      (raise-error n (format "field ~a from ~a may not be used" n (car class))
+                   n src)))
+  
+  ;;special-name errors
+  ;special-error: src bool -> void
+  (define (special-error src interactions?)
+    (raise-error 'this 
+                 (format "use of 'this' is not allowed in ~a"
+                         (if interactions? "the interactions window" "static code"))
+                 'this src))
+  
+  ;;Call errors
+
+  ;prim-call-error type id src symbol -> void
+  (define (prim-call-error exp name src level)
+    (let ((n (id->ext-name name))
+          (t (type->ext-name exp)))
+      (raise-error
+       n
+       (format "attempted to call method ~a on ~a which does not have methods. ~nOnly values with ~a types have methods"
+               n t
+               (case level 
+                 ((beginner) "class")
+                 ((intermediate) "class or interface")
+                 (else "class, interface, or array")))
+       n src)))
+  
+  ;no-method-error: symbol symbol type id src -> void
+  (define (no-method-error kind sub-kind exp name src)
+    (let ((t (type->ext-name exp))
+          (n (id->ext-name name)))
+      (raise-error 
+       n
+       (case sub-kind
+         ((not-found) (format "~a does not contain a method named ~a"
+                              (case kind
+                                ((class) t)
+                                ((super) "This class's super class")
+                                ((this) "The current class"))
+                              n))
+         ((class-name)
+          (let ((line1 
+                 (format "Class ~a is inappropriately being used as a method." n))
+                (line2
+                 "Parenthesis typically follow the class name when creating an instance, perhaps 'new' was forgotten"))
+          (format "~a~n~a" line1 line2)))
+         ((field-name)
+          (format 
+           "Field ~a is being inappropriately used as a method, parentheses are not used in interacting with a field"
+           n)))                     
+       n src)))
+  
+  ;close-to-keyword-error: symbol id src -> void
+  (define (close-to-keyword-error kind name src)
+    (let ((n (id->ext-name name)))
+      (raise-error n
+                   (case kind
+                     ((method) 
+                      (string-append
+                       (format "this method call uses an unfound method ~a, which is similar to a reserved word~n"
+                               n)
+                       "Perhaps it is miscapitalized or misspelled"))
+                     ((field)
+                       (string-append
+                        (format "this unknown variable, ~a, is similar to a reserved word.~n" n)
+                        "Perhaps it is miscaptialzed or misspelled")))
+                   n src)))
+
+  ;class-as-object-call: level string id src -> void
+  (define (class-as-object-call level class meth src)
+    (let ((n (id->ext-name meth))
+          (c (string->symbol class)))
+      (raise-error n
+                   (case level
+                     ((beginner intermediate) (format "Attempt to use class or interface ~a as an object to call method ~a" c n))
+                     ((advanced) (format "Attempt to use method ~a from class ~a as though it were static" n c)))
+                   c src)))
+  
+  ;beginner-method-access-error: id src -> void
+  (define (beginner-method-access-error name src)
+    (let ((n (id->ext-name name)))
+      (raise-error n
+                   (format "method ~a from the current class must be called on 'this'" n)
+                   n src)))
+
+  
+  ;restricted-method-call id (list string) src -> void
+  (define (restricted-method-call name class src)
+    (let ((n (id->ext-name name)))
+      (raise-error n
+                   (format "method ~a from ~a may not be called" n (car class))
+                   n src)))
+  
+  ;ctor-called-error: type id src -> void
+  (define (ctor-called-error exp name src)
+    (let ((t (if exp (type->ext-name exp) "the current class"))
+          (n (id->ext-name name)))
+      (raise-error n
+                   (format "Constructor ~a from ~a cannot be used as a method" n t)
+                   n src)))
+  
+  ;non-static-called-error: id (list string) src bool -> void
+  (define (non-static-called-error name class src level)
+    (let ((n (id->ext-name name)))
+      (raise-error n
+                   (if (memq level '(advanced full))
+                       (format "Non-static method ~a from ~a cannot be called directly from a static context"
+                               n (car class))
+                       (format "Method ~a from ~a cannot be called here" n (car class)))
+                   n src)))
+  
+  ;interaction-call-error
+  (define (interaction-call-error name src level)
+    (let ((n (id->ext-name name)))
+      (raise-error n
+                   (string-append (format "method ~a cannot be called in the interactions window.~n" n)
+                                  (format "Only ~a methods or methods on objects may be called here" 
+                                          (if (memq level '(beginner intermediate)) "certain library" "static")))
+                   n src)))
+
+  
+  (define (illegal-ctor-call name src level)
+    (let ((n (string->symbol name)))
+      (raise-error n (format "calls to ~a may only occur in ~a"
+                             n
+                             (if (memq level `(full advanced)) "other constructors" "the super constructor"))
+                   n src)))
+
+  ;method-arg-error symbol (list type) (list type) id type src -> void
+  (define (method-arg-error kind args atypes name exp-type src)
+    (let ((n (id->ext-name name))
+          (e (get-call-type exp-type))
+          (givens (map type->ext-name args))
+          (expecteds (map type->ext-name atypes))
+          (awitht "arguments with types"))
+      (raise-error n
+                   (case kind
+                     ((implicit-ctor)
+                      (format 
+                       "This constructor must contain a call to the super class's constructor which expects ~a ~a ~a"
+                       (length expecteds) awitht expecteds))
+                      ((number)
+                       (format "method ~a from ~a expects ~a ~a ~a. Given ~a ~a ~a"
+                               n e (length expecteds) awitht expecteds (length givens) awitht givens))
+                     ((type)
+                      (format "method ~a from ~a expects ~a ~a, but given a ~a instead of ~a for one argument"
+                              n e awitht (map type->ext-name (cdr atypes)) (car givens) (type->ext-name (car atypes)))))
+                   n src)))
+
+  ;teaching-call-error: symbol bool id (list type) type src (list method-record) -> void
+  (define (teaching-call-error kind ctor? name args exp-type src methods)
+    (let* ((method-args (map method-record-atypes (remove-overridden methods)))
+           (non-array-type-list (filter (lambda (arg-list)
+                                          (andmap (lambda (a) (not (array-type? a))) arg-list)) method-args))
+           (predominant-number (get-most-occuring-length non-array-type-list))
+           (type-lists (get-string-of-types (filter (lambda (a) (= (length a) predominant-number)) non-array-type-list))))
+      (let* ((n (id->ext-name name))
+             (e (get-call-type exp-type))
+             (givens (get-string-of-types (list args)))
+             (front (if ctor? "constructor for" (format "method ~a from" n))))
+        (raise-error n
+                     (case kind
+                       ((number)
+                        (format "~a ~a expects ~a arguments with type(s) ~a. Given ~a"
+                                front e predominant-number type-lists givens))
+                       (else
+                        (format "~a ~a expects arguments with type(s) ~a. Given ~a"
+                                front e type-lists givens)))
+                     n src))))
+  
+  ;remove-overridden: (list method-record) -> (list method-record)
+  (define (remove-overridden methods)
+    (letrec ((remove?
+              (lambda (method methods)
+                  (and (not (null? methods))
+                       (or (and
+                            (= (length (method-record-atypes method))
+                               (length (method-record-atypes (car methods))))
+                            (andmap (lambda (x) x) (map type=? 
+                                                        (method-record-atypes method) 
+                                                        (method-record-atypes (car methods)))))
+                           (remove? method (cdr methods))))))
+             (remove
+              (lambda (methods)
+                (cond
+                  ((null? methods) methods)
+                  ((remove? (car methods) (cdr methods))
+                   (remove (cdr methods)))
+                  (else (cons (car methods) (remove (cdr methods))))))))
+      (remove methods)))
+  
+  ;get-most-occuring-lenght: (list (list type)) -> number
+  (define (get-most-occuring-length args)
+    (let* ((lengths (map length args))
+           (max-length (apply max lengths))
+           (vec (make-vector (add1 max-length) 0))
+           (loc 0))
+      (let loop ((l lengths))
+        (unless (null? l)
+          (vector-set! vec (car l) (add1 (vector-ref vec (car l))))
+          (loop (cdr l))))
+      (let loop ((i 0) (max-loc 0) (max 0))
+        (if (= i (vector-length vec))
+            (set! loc max-loc)
+            (if (> (vector-ref vec i) max)
+                (loop (add1 i) i (vector-ref vec i))
+                (loop (add1 i) max-loc max))))
+      loc))
+        
+  ;get-string-of-types: (list (list type)) -> string
+  (define (get-string-of-types types)
+    (let ((out (if (= 1 (length (car types)))
+                   (apply string-append 
+                          (map (lambda (a) (format "~a, or " (type->ext-name (car a)))) types))
+                   (apply string-append
+                          (map (lambda (a) (format "(~a), or "
+                                                   (let ((internal 
+                                                          (apply string-append 
+                                                                 (map (lambda (aI) 
+                                                                        (format "~a, " (type->ext-name aI))) a))))
+                                                     (if (< (string-length internal) 2)
+                                                         internal
+                                                         (substring internal 0 (- (string-length internal) 2))))))
+                               types)))))
+      (substring out 0 (- (string-length out) 5))))                                                         
+  
+  ;call-access-error: symbol symbol id type src -> void
+  (define (call-access-error kind level name exp src)
+    (let ((n (id->ext-name name))
+          (t (get-call-type exp)))
+    (raise-error n
+                 (if (memq level '(beginner abstract))
+                     (format "~a does not contain a method named ~a" t n)
+                     (case kind
+                       ((pro) 
+                        (format "method ~a from ~a may only be called by ~a, a subclass, or package member of ~a" 
+                                n t t t))
+                       ((pri) (format "~a does not contain a method named ~a" t n))
+                       ((pac) (format "method ~a from ~a may only be called by ~a or a package member of ~a" 
+                                      n t t t))))
+                 n src)))
+
+  ;call-arg-error: symbol id (list type) type src -> void
+  (define (call-arg-error kind name args exp src)
+    (let* ((n (id->ext-name name))
+           (t (get-call-type exp))
+           (call-type (if (and (special-name? name)
+                               (string=? "super" (special-name-name name)))
+                          "super constructor for"
+                          (format "method ~a from" n)))
+           (as (map type->ext-name args)))
+      (raise-error n
+                   (case kind
+                     ((number)
+                      (format "~a ~a has no definition with ~a argument~a. Given ~a"
+                              call-type t (length as) (if (> (length as) 1) "s" "") as))
+                     ((no-match)
+                      (format "~a ~a has no definition with compatible types as the given types: ~a"
+                              call-type t as))
+                     ((conflict)
+                      (format "~a ~a has multiple compatible definitions with given arguments: ~a"
+                              call-type t as)))
+                   n src)))
+  
+  ;thrown-error: string id type src -> void
+  (define (thrown-error thrown name exp src)
+    (let ((n (id->ext-name name))
+          (t (get-call-type exp)))
+      (raise-error n
+                   (format "called method ~a from ~a throws exception ~a, which is not caught or listed as thrown"
+                           n t thrown)
+                   n src)))
+      
+  ;beginner-call-error: id src -> void
+  (define (beginner-call-error name src)
+    (let ((n (id->ext-name name)))
+      (raise-error n (format "method ~a cannot be called in ProfessorJ Beginner" n) n src)))
+  
+  ;;Class Alloc errors
+
+  ;class-alloc-error: symbol type src -> void
+  (define (class-alloc-error kind type src)
+    (let ((cl (type->ext-name type)))
+      (raise-error cl
+                   (case kind
+                     ((abstract) (format "class ~a is abstract. Abstract classes may not be instantiated." cl))
+                     ((interface) (format "~a is an interface. interfaces may not be instantiated." cl)))
+                   cl src)))
+
+  ;ctor-arg-error symbol (list type) (list type) type src -> void
+  (define (ctor-arg-error kind args atypes name src)
+    (let ((n (type->ext-name name))
+          (givens (get-string-of-types (list args)))
+          (expecteds (get-string-of-types (list atypes)))
+          (awitht "arguments with types"))
+      (raise-error n
+                   (case kind
+                     ((number)
+                      (format "Constructor for ~a expects ~a ~a ~a. Given ~a ~a ~a"
+                              n (length atypes) awitht expecteds (length args) awitht givens))
+                     ((type)
+                      (format "Constructor for ~a expects ~a ~a, but given a ~a instead of ~a for one argument"
+                              n awitht (get-string-of-types (list (cdr atypes))) (type->ext-name (car args))
+                              (type->ext-name (car atypes)))))
+                   n src)))
+
+  ;ctor-overload-error: symbol type (list type) src -> void
+  (define (ctor-overload-error kind name args src)
+    (let ((n (type->ext-name name))
+          (as (map type->ext-name args)))
+      (raise-error 
+       n
+       (case kind
+         ((number)
+          (format "No constructor for ~a exists with ~a arguments. Given ~a"
+                  n (length as) as))
+         ((no-match)
+          (format "No constructor for ~a exists with compatible types as the given types: ~a"
+                  n as))
+         ((conflict)
+          (format "Multiple constructors for ~a exist with compatible definitions for the given arguments: ~a"
+                  n as)))
+       n src)))
+  
+  ;class-access-error: symbol type src -> void
+  (define (class-access-error kind level name src)
+    (let ((n (type->ext-name name)))
+      (raise-error n
+                   (case kind
+                     ((pro) (format "This constructor for ~a may only be used by ~a and its subclasses~a"
+                                    n n (if (memq level '(beginner intermediate)) "" " and package members")))
+                     ((pri) (format "This constructor for ~a may only be used by ~a"
+                                    n n))
+                     ((pac) (format "This constructor for ~a may~a"
+                                    n (if (memq level '(beginner intermediate))
+                                          " not be used" (format " only be used by ~a and package members" n)))))
+                 n src)))
+
+  ;ctor-throws-error: string type src -> void
+  (define (ctor-throws-error thrown name src)
+    (let ((n (type->ext-name name)))
+      (raise-error n
+                   (format "Constructor for ~a throws exception ~a, which is not caught or listed as thrown"
+                           n thrown)
+                   n src)))
+  
+  ;;Array Alloc error
+  ;array-size-error: type type src -> void
+  (define (array-size-error array dim src)
+    (let ((a (type->ext-name array))
+          (d (type->ext-name dim)))
+      (raise-error a
+                   (format "Allocation of array of ~a requires an integer for the size. Given ~a"
+                           a d)
+                   a src)))
+
+  ;Array Alloc Init error
+  ;array-dim-error: type int int src -> void
+  (define (array-dim-error type dim g-dim src)
+    (let ((t (type->ext-name (make-array-type type dim)))
+          (given (type->ext-name (make-array-type type g-dim))))
+      (raise-error t
+                   (format "Expected an array of type ~a~a, found an array of type ~a~a" t given)
+                   t src)))
+  
+  ;;Conditional Expression errors
+
+  ;condition-error: type src -> void
+  (define (condition-error type src)
+    (let ((t (type->ext-name type)))
+      (raise-error '?
+                   (format "? requires that the first expression have type boolean. Given ~a" t)
+                   '? src)))
+
+  ;condition-mismatch-error: type type src -> void
+  (define (condition-mismatch-error then else src)
+    (raise-error 
+     '?
+     (format 
+      "? requires that the then and else branches have equivalent types: given ~a and ~a which are not equivalent"
+      (type->ext-name then) (type->ext-name else))
+     '? src))
+    
+  ;;Array Access errors
+  ;illegal-array-access: type src -> void
+  (define (illegal-array-access type src)
+    (let ((n (type->ext-name type)))
+      (raise-error 
+       n
+       (format "Expression of type ~a accessed as if it were an array, only arrays may be accessed with [N]" n)
+       n src)))
+  
+  ;array-access-error: type type src -> void
+  (define (array-access-error array idx src)
+    (let ((n (type->ext-name array))
+          (i (type->ext-name idx)))
+      (raise-error n
+                   (format "~a should be indexed with an integer, given ~a" n i)
+                   n src)))
+  
+  ;;Unary error
+  ;unary-error: symbol symbol type src -> void
+  (define (unary-error op expect type src)
+    (raise-error op
+                 (format "~a expects a ~a, given ~a"
+                         op (get-expected expect) (type->ext-name type))
+                 op src))
+  
+  ;;Cast errors
+  ;cast-error: symbol type type src -> void
+  (define (cast-error kind cast exp src)
+    (raise-error 
+     'cast
+     (case kind
+       ((from-prim)
+        (let ((line1 (format "Illegal cast from primitive, ~a, to class or interface ~a."
+                             (type->ext-name exp) (type->ext-name cast)))
+              (line2 "Non-class or interface types may not be cast to class or interface types"))
+          (format "~a~n~a" line1 line2)))
+       ((from-ref)
+        (let ((line1 (format "Illegal cast from class or interface ~a to primitive, ~a."
+                             (type->ext-name exp) (type->ext-name cast)))
+              (line2 "Class or interface types may not be cast to non-class or interface types"))
+          (format "~a~n~a" line1 line2))))
+     'cast src))
+  
+  ;;Instanceof errors
+  ;instanceof-error: symbol type type src -> void
+  (define (instanceof-error kind inst exp src)
+    (let ((i (type->ext-name inst))
+          (e (type->ext-name exp)))
+      (raise-error 
+       'instanceof
+       (case kind
+         ((not-related-type)
+          (let ((line1 "instanceof requires that its expression be related to the given type")
+                (line2 (format "~a is not a subtype of ~a, and ~a is not a subtype of ~a" e i i e)))
+            (format "~a~n~a" line1 line2)))
+         ((not-class)
+          (format 
+           "instanceof requires its expression to be compared to a class or interface: Given ~a which is neither"
+           i))
+         ((not-ref)
+          (format "instanceof requires the expression, compared to ~a, to be a class or interface: Given ~a"
+                  i e))
+         ((not-related-array)
+          (let ((line1 "instanceof requires that its expression be related to the given type")
+                (line2 (format "~a is not a subtype of ~a, and ~a is not a subtype of ~a" e i i e)))
+            (format "~a~n~a" line1 line2)))
+         ((not-array)
+          (format "instancof requires its expression to be an array when compared to ~a. Given ~a" i e))
+         ((not-reforarray)
+          (format "instanceof requires the expression, compared to ~a, to be a class, interface or array: Given ~a" i e)))
+       'instanceof src)))
+  
+  ;;Assignment errors
+  ;illegal-assignment: src -> void
+  (define (illegal-assignment src)
+    (raise-error '= "Assignment is only allowed in the constructor" '= src))
+
+  (define (assignment-error op ltype rtype src)
+    (raise-error op
+                 (format "~a requires that the right hand type be equivalent to or a subtype of ~a: given ~a"
+                         op (type->ext-name ltype) (type->ext-name rtype))
+                 op src))
+  
+  (define (illegal-beginner-assignment)
+    "Assignment statements are only allowed in constructors")
+  (define (assignment-convert-fail op d ltype rtype)
+    (format "~a requires that the right hand type be equivalent to or a subtype of ~a: given ~a" 
+            op ltype rtype))
+
+  ;assign-final-error: symbol id string -> void
+  (define (assign-final-error kind name class)
+    (let* ((n (id->ext-name name))
+           (already-set 
+            (lambda (static?) (format "final~afield ~a has already been set" (if static? " static " " ") n)))
+           (in-ctor
+            (lambda (static?) (format "final~afield ~a may not be set in ~a's constructor" 
+                                      (if static? " static " " ") n class))))
+      (raise-error n
+                   (case kind
+                     ((local) (format "final parameter ~a may not be set" n))
+                     ((static-in-ctor) (in-ctor #t))
+                     ((cannot-set-ctor) (in-ctor #f))
+                     ((cannot-set-static) (format "final field ~a may not be set in ~a's static initialization" n class))
+                     ((static-ctor-already-set) 
+                      (format "~a. Further, it may not be set in ~a's constructor" (already-set #t) class))
+                     ((static-already-set) (already-set #t))
+                     ((field-already-set) (already-set #f))
+                     ((static) (format "final field ~a may only be set in the containing class's static initialization" n))
+                     ((field) (format "final field ~a may only be set in the containing class's constructor" n)))
+                   n (id-src name))))
+
+  
+  ;implicit import error
+  ;class-lookup-error: string src -> void
+  (define (class-lookup-error class src)
+    (raise-error (string->symbol class)
+                 (format "Implicit import of class ~a failed as this class does not exist at the specified location"
+                         class)
+                 (string->symbol class) src))
+  
+  (define check-location (make-parameter #f))
+  
+  (define raise-error (make-error-pass check-location))
+      
+  )
\ No newline at end of file
diff --git a/collects/profj/classpath/COPYING b/collects/profj/classpath/COPYING
new file mode 100644
index 0000000000..eeb586b392
--- /dev/null
+++ b/collects/profj/classpath/COPYING
@@ -0,0 +1,340 @@
+		    GNU GENERAL PUBLIC LICENSE
+		       Version 2, June 1991
+
+ Copyright (C) 1989, 1991 Free Software Foundation, Inc.
+     59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+			    Preamble
+
+  The licenses for most software are designed to take away your
+freedom to share and change it.  By contrast, the GNU General Public
+License is intended to guarantee your freedom to share and change free
+software--to make sure the software is free for all its users.  This
+General Public License applies to most of the Free Software
+Foundation's software and to any other program whose authors commit to
+using it.  (Some other Free Software Foundation software is covered by
+the GNU Library General Public License instead.)  You can apply it to
+your programs, too.
+
+  When we speak of free software, we are referring to freedom, not
+price.  Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+this service if you wish), that you receive source code or can get it
+if you want it, that you can change the software or use pieces of it
+in new free programs; and that you know you can do these things.
+
+  To protect your rights, we need to make restrictions that forbid
+anyone to deny you these rights or to ask you to surrender the rights.
+These restrictions translate to certain responsibilities for you if you
+distribute copies of the software, or if you modify it.
+
+  For example, if you distribute copies of such a program, whether
+gratis or for a fee, you must give the recipients all the rights that
+you have.  You must make sure that they, too, receive or can get the
+source code.  And you must show them these terms so they know their
+rights.
+
+  We protect your rights with two steps: (1) copyright the software, and
+(2) offer you this license which gives you legal permission to copy,
+distribute and/or modify the software.
+
+  Also, for each author's protection and ours, we want to make certain
+that everyone understands that there is no warranty for this free
+software.  If the software is modified by someone else and passed on, we
+want its recipients to know that what they have is not the original, so
+that any problems introduced by others will not reflect on the original
+authors' reputations.
+
+  Finally, any free program is threatened constantly by software
+patents.  We wish to avoid the danger that redistributors of a free
+program will individually obtain patent licenses, in effect making the
+program proprietary.  To prevent this, we have made it clear that any
+patent must be licensed for everyone's free use or not licensed at all.
+
+  The precise terms and conditions for copying, distribution and
+modification follow.
+
+		    GNU GENERAL PUBLIC LICENSE
+   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+  0. This License applies to any program or other work which contains
+a notice placed by the copyright holder saying it may be distributed
+under the terms of this General Public License.  The "Program", below,
+refers to any such program or work, and a "work based on the Program"
+means either the Program or any derivative work under copyright law:
+that is to say, a work containing the Program or a portion of it,
+either verbatim or with modifications and/or translated into another
+language.  (Hereinafter, translation is included without limitation in
+the term "modification".)  Each licensee is addressed as "you".
+
+Activities other than copying, distribution and modification are not
+covered by this License; they are outside its scope.  The act of
+running the Program is not restricted, and the output from the Program
+is covered only if its contents constitute a work based on the
+Program (independent of having been made by running the Program).
+Whether that is true depends on what the Program does.
+
+  1. You may copy and distribute verbatim copies of the Program's
+source code as you receive it, in any medium, provided that you
+conspicuously and appropriately publish on each copy an appropriate
+copyright notice and disclaimer of warranty; keep intact all the
+notices that refer to this License and to the absence of any warranty;
+and give any other recipients of the Program a copy of this License
+along with the Program.
+
+You may charge a fee for the physical act of transferring a copy, and
+you may at your option offer warranty protection in exchange for a fee.
+
+  2. You may modify your copy or copies of the Program or any portion
+of it, thus forming a work based on the Program, and copy and
+distribute such modifications or work under the terms of Section 1
+above, provided that you also meet all of these conditions:
+
+    a) You must cause the modified files to carry prominent notices
+    stating that you changed the files and the date of any change.
+
+    b) You must cause any work that you distribute or publish, that in
+    whole or in part contains or is derived from the Program or any
+    part thereof, to be licensed as a whole at no charge to all third
+    parties under the terms of this License.
+
+    c) If the modified program normally reads commands interactively
+    when run, you must cause it, when started running for such
+    interactive use in the most ordinary way, to print or display an
+    announcement including an appropriate copyright notice and a
+    notice that there is no warranty (or else, saying that you provide
+    a warranty) and that users may redistribute the program under
+    these conditions, and telling the user how to view a copy of this
+    License.  (Exception: if the Program itself is interactive but
+    does not normally print such an announcement, your work based on
+    the Program is not required to print an announcement.)
+
+These requirements apply to the modified work as a whole.  If
+identifiable sections of that work are not derived from the Program,
+and can be reasonably considered independent and separate works in
+themselves, then this License, and its terms, do not apply to those
+sections when you distribute them as separate works.  But when you
+distribute the same sections as part of a whole which is a work based
+on the Program, the distribution of the whole must be on the terms of
+this License, whose permissions for other licensees extend to the
+entire whole, and thus to each and every part regardless of who wrote it.
+
+Thus, it is not the intent of this section to claim rights or contest
+your rights to work written entirely by you; rather, the intent is to
+exercise the right to control the distribution of derivative or
+collective works based on the Program.
+
+In addition, mere aggregation of another work not based on the Program
+with the Program (or with a work based on the Program) on a volume of
+a storage or distribution medium does not bring the other work under
+the scope of this License.
+
+  3. You may copy and distribute the Program (or a work based on it,
+under Section 2) in object code or executable form under the terms of
+Sections 1 and 2 above provided that you also do one of the following:
+
+    a) Accompany it with the complete corresponding machine-readable
+    source code, which must be distributed under the terms of Sections
+    1 and 2 above on a medium customarily used for software interchange; or,
+
+    b) Accompany it with a written offer, valid for at least three
+    years, to give any third party, for a charge no more than your
+    cost of physically performing source distribution, a complete
+    machine-readable copy of the corresponding source code, to be
+    distributed under the terms of Sections 1 and 2 above on a medium
+    customarily used for software interchange; or,
+
+    c) Accompany it with the information you received as to the offer
+    to distribute corresponding source code.  (This alternative is
+    allowed only for noncommercial distribution and only if you
+    received the program in object code or executable form with such
+    an offer, in accord with Subsection b above.)
+
+The source code for a work means the preferred form of the work for
+making modifications to it.  For an executable work, complete source
+code means all the source code for all modules it contains, plus any
+associated interface definition files, plus the scripts used to
+control compilation and installation of the executable.  However, as a
+special exception, the source code distributed need not include
+anything that is normally distributed (in either source or binary
+form) with the major components (compiler, kernel, and so on) of the
+operating system on which the executable runs, unless that component
+itself accompanies the executable.
+
+If distribution of executable or object code is made by offering
+access to copy from a designated place, then offering equivalent
+access to copy the source code from the same place counts as
+distribution of the source code, even though third parties are not
+compelled to copy the source along with the object code.
+
+  4. You may not copy, modify, sublicense, or distribute the Program
+except as expressly provided under this License.  Any attempt
+otherwise to copy, modify, sublicense or distribute the Program is
+void, and will automatically terminate your rights under this License.
+However, parties who have received copies, or rights, from you under
+this License will not have their licenses terminated so long as such
+parties remain in full compliance.
+
+  5. You are not required to accept this License, since you have not
+signed it.  However, nothing else grants you permission to modify or
+distribute the Program or its derivative works.  These actions are
+prohibited by law if you do not accept this License.  Therefore, by
+modifying or distributing the Program (or any work based on the
+Program), you indicate your acceptance of this License to do so, and
+all its terms and conditions for copying, distributing or modifying
+the Program or works based on it.
+
+  6. Each time you redistribute the Program (or any work based on the
+Program), the recipient automatically receives a license from the
+original licensor to copy, distribute or modify the Program subject to
+these terms and conditions.  You may not impose any further
+restrictions on the recipients' exercise of the rights granted herein.
+You are not responsible for enforcing compliance by third parties to
+this License.
+
+  7. If, as a consequence of a court judgment or allegation of patent
+infringement or for any other reason (not limited to patent issues),
+conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License.  If you cannot
+distribute so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you
+may not distribute the Program at all.  For example, if a patent
+license would not permit royalty-free redistribution of the Program by
+all those who receive copies directly or indirectly through you, then
+the only way you could satisfy both it and this License would be to
+refrain entirely from distribution of the Program.
+
+If any portion of this section is held invalid or unenforceable under
+any particular circumstance, the balance of the section is intended to
+apply and the section as a whole is intended to apply in other
+circumstances.
+
+It is not the purpose of this section to induce you to infringe any
+patents or other property right claims or to contest validity of any
+such claims; this section has the sole purpose of protecting the
+integrity of the free software distribution system, which is
+implemented by public license practices.  Many people have made
+generous contributions to the wide range of software distributed
+through that system in reliance on consistent application of that
+system; it is up to the author/donor to decide if he or she is willing
+to distribute software through any other system and a licensee cannot
+impose that choice.
+
+This section is intended to make thoroughly clear what is believed to
+be a consequence of the rest of this License.
+
+  8. If the distribution and/or use of the Program is restricted in
+certain countries either by patents or by copyrighted interfaces, the
+original copyright holder who places the Program under this License
+may add an explicit geographical distribution limitation excluding
+those countries, so that distribution is permitted only in or among
+countries not thus excluded.  In such case, this License incorporates
+the limitation as if written in the body of this License.
+
+  9. The Free Software Foundation may publish revised and/or new versions
+of the General Public License from time to time.  Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+Each version is given a distinguishing version number.  If the Program
+specifies a version number of this License which applies to it and "any
+later version", you have the option of following the terms and conditions
+either of that version or of any later version published by the Free
+Software Foundation.  If the Program does not specify a version number of
+this License, you may choose any version ever published by the Free Software
+Foundation.
+
+  10. If you wish to incorporate parts of the Program into other free
+programs whose distribution conditions are different, write to the author
+to ask for permission.  For software which is copyrighted by the Free
+Software Foundation, write to the Free Software Foundation; we sometimes
+make exceptions for this.  Our decision will be guided by the two goals
+of preserving the free status of all derivatives of our free software and
+of promoting the sharing and reuse of software generally.
+
+			    NO WARRANTY
+
+  11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW.  EXCEPT WHEN
+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK AS
+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU.  SHOULD THE
+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
+REPAIR OR CORRECTION.
+
+  12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGES.
+
+		     END OF TERMS AND CONDITIONS
+
+	    How to Apply These Terms to Your New Programs
+
+  If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these terms.
+
+  To do so, attach the following notices to the program.  It is safest
+to attach them to the start of each source file to most effectively
+convey the exclusion of warranty; and each file should have at least
+the "copyright" line and a pointer to where the full notice is found.
+
+    <one line to give the program's name and a brief idea of what it does.>
+    Copyright (C) 19yy  <name of author>
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License
+    along with this program; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+
+Also add information on how to contact you by electronic and paper mail.
+
+If the program is interactive, make it output a short notice like this
+when it starts in an interactive mode:
+
+    Gnomovision version 69, Copyright (C) 19yy name of author
+    Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+    This is free software, and you are welcome to redistribute it
+    under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the appropriate
+parts of the General Public License.  Of course, the commands you use may
+be called something other than `show w' and `show c'; they could even be
+mouse-clicks or menu items--whatever suits your program.
+
+You should also get your employer (if you work as a programmer) or your
+school, if any, to sign a "copyright disclaimer" for the program, if
+necessary.  Here is a sample; alter the names:
+
+  Yoyodyne, Inc., hereby disclaims all copyright interest in the program
+  `Gnomovision' (which makes passes at compilers) written by James Hacker.
+
+  <signature of Ty Coon>, 1 April 1989
+  Ty Coon, President of Vice
+
+This General Public License does not permit incorporating your program into
+proprietary programs.  If your program is a subroutine library, you may
+consider it more useful to permit linking proprietary applications with the
+library.  If this is what you want to do, use the GNU Library General
+Public License instead of this License.
diff --git a/collects/profj/classpath/LICENSE b/collects/profj/classpath/LICENSE
new file mode 100644
index 0000000000..7d243f10bb
--- /dev/null
+++ b/collects/profj/classpath/LICENSE
@@ -0,0 +1,29 @@
+The software in this package is distributed under the GNU General Public
+License (with "Library Exception" described below).
+
+A copy of GNU General Public License (GPL) is included in this distribution,
+in the file COPYING.  If you do not have the source code, it is available at:
+
+    http://www.gnu.org/software/classpath/
+
+In addition, the files distributed under GPL include the following
+special exception.
+
+    As a special exception, if you link this library with
+    other files to produce an executable, this library does
+    not by itself cause the resulting executable to be covered
+    by the GNU General Public License. This exception does
+    not however invalidate any other reasons why the executable
+    file might be covered by the GNU General Public License. 
+
+As such, this software can be used to run Free as well as proprietary
+applications and applets:  static linking is permitted, so this can
+even be used in embedded configurations.
+
+External libraries included with GNU Classpath may be distributed under
+different licensing terms.  Refer to the documentation for each package
+located in the external directory.
+
+Parts of the native library fdlibm in native/fdlibm are copyright of 
+Sun Microsystems, Inc. or AT&T.
+
diff --git a/collects/profj/compile.ss b/collects/profj/compile.ss
new file mode 100644
index 0000000000..63de7e4d9d
--- /dev/null
+++ b/collects/profj/compile.ss
@@ -0,0 +1,300 @@
+(module compile mzscheme
+  (require "parameters.ss" "ast.ss" "types.ss" "parser.ss" "build-info.ss" "check.ss" "to-scheme.ss" "profj-pref.ss")
+  (require (lib "list.ss")
+           (lib "file.ss")
+           (lib "class.ss"))
+
+  (provide compile-java compile-interactions compile-files compile-ast compile-interactions-ast
+           compilation-unit-code compilation-unit-contains set-compilation-unit-code!
+           read-record write-record
+           set-syntax-location create-type-record
+           )
+  
+  (define (set-syntax-location so) (syntax-location so))
+  
+  (define (create-type-record)
+    (let ((t (make-object type-records)))
+      (set-importer! t find-implicit-import)
+      (classpath (get-classpath))
+      (load-lang t)
+      t))
+  
+  ;kind = 'file | 'port
+  ;level = 'beginner | 'intermediate | 'advanced | 'full
+  
+  ;compile: kind kind level (U #f string) (U #f port) (U #f location) -> (U (list compilation-unit) void)
+  (define (compile-java src dest level name port loc . type-recs)
+    (when (and (eq? src 'file)
+               (not (file-exists? name)))
+      (error 'compile-java "compile-java given file that does not exist: ~a" name))
+    (when (null? (classpath)) (get-classpath))
+    (let ((type-recs (if (null? type-recs)
+                         (make-object type-records)
+                         (car type-recs))))
+      (cond
+        ((and (eq? src 'file) (eq? dest 'file))
+         (let-values  (((path-base file dir?) (split-path (path->complete-path (build-path name)))))
+           (let ((compiled-path (build-path path-base "compiled" (path-replace-suffix file ".zo"))))
+             (unless (and (file-exists? compiled-path)
+                          (> (file-or-directory-modify-seconds compiled-path)
+                             (file-or-directory-modify-seconds (build-path name))))
+               (call-with-input-file name (lambda (port) (compile-to-file port name level)))))))
+        ((eq? dest 'file)
+         (compile-to-file port loc level))
+        ((eq? src 'file)
+         (let-values  (((path-base file dir?) (split-path (path->complete-path (build-path name)))))
+           (let ((compiled-path (build-path path-base "compiled" (path-replace-suffix file ".zo"))))
+             (unless (and (file-exists? compiled-path)
+                          (> (file-or-directory-modify-seconds compiled-path)
+                             (file-or-directory-modify-seconds (build-path name))))
+               (call-with-input-file 
+                   name
+                 (lambda (port) (compile-java-internal port name type-recs #f level)))))))
+        (else
+         (compile-java-internal port loc type-recs #f level)))))
+    
+  ;compile-to-file: port location level -> void
+  ;Should have side-effect of writing to file all files needed for compilation
+  (define (compile-to-file port location level)
+    (let ((type-recs (make-object type-records)))
+      (send type-recs set-compilation-location
+            location 
+            (if (equal? (file-name-from-path location) location)
+                (build-path "compiled")
+                (build-path (substring (path->string location) 0 
+                                       (- (string-length (path->string location))
+                                          (string-length (path->string (file-name-from-path location))))) "compiled")))
+      (for-each (lambda (dependents)
+                  (let ((names (compilation-unit-contains dependents))
+                        (syntaxes (compilation-unit-code dependents))
+                        (locations (compilation-unit-locations dependents)))
+                    (unless (= (length names) (length syntaxes))
+                      ;(printf "Writing a composite file out~n")
+                      ;(printf "~a~n~n" (syntax-object->datum (car syntaxes)))
+                      (call-with-output-file* (build-path (send type-recs get-compilation-location)
+                                                          (file-name-from-path
+                                                           (send type-recs get-composite-location (car names))))
+                                              (lambda (port) (write (compile (car syntaxes)) port)) 'truncate/replace)
+                      (set! syntaxes (cdr syntaxes)))
+                    (unless (= (length names) (length syntaxes) (length locations))
+                      (error 'compile-to-file "Internal error: compilation unit not represented as expected"))
+                    (for-each (lambda (name code location)
+                                ;(printf "~a~n~n" (syntax-object->datum code))
+                                (send type-recs set-location! location)
+                                (let ((directory (send type-recs get-compilation-location)))
+                                  (unless (directory-exists? directory) (make-directory directory))
+                                  (call-with-output-file* (build-path directory (string-append name ".zo"))
+                                                          (lambda (port) (write (compile code) port))
+                                                          'truncate/replace)
+                                  (call-with-output-file* (build-path directory (string-append name ".jinfo"))
+                                                          (lambda (port) (write-record (send type-recs get-class-record 
+                                                                                             (list name)
+                                                                                             #f
+                                                                                             class-record-error)
+                                                                                       port))
+                                                          'truncate/replace)))
+                              names syntaxes locations)))
+                (compile-java-internal port location type-recs #t level))))
+  
+  (define (class-record-error) (error 'compile-to-file "Internal error: class record not found"))
+  
+  ;package: (list string)
+  
+  ;compile-files: (list (list (list path) package)) boolean symbol ->
+  ;               (list (list package (list (list compiliation-unit)) (list class-record)))
+  (define (compile-files files to-file? level)
+    (when (null? (classpath)) (classpath (get-classpath)))
+    (let ((type-recs (make-object type-records))
+          (get-class-names 
+           (lambda (files)
+             (map (lambda (f) (path->string (path-replace-suffix (file-name-from-path f) "")))
+                  files))))
+      (map (lambda (package-files)
+             (let* ((files (car package-files))
+                    (package-name (cadr package-files))
+                    (class-names (get-class-names files)))
+               (list package-name
+                     (filter (lambda (t) t)
+                             (map (lambda (file class)
+                                    (let ((existing-record (send type-recs get-class-record (cons class package-name) #f
+                                                                 (lambda () #f))))
+                                      (and (or (not existing-record) 
+                                               (procedure? existing-record))
+                                           (call-with-input-file file 
+                                             (lambda (port) (compile-java-internal port file type-recs to-file? level))))))
+                                  files class-names))
+                     (map (lambda (class)
+                            (send type-recs get-class-record (cons class package-name) #f (lambda () (error 'internal-error))))
+                          class-names))))
+           files)))
+  
+  (define (compile-ast ast level type-recs)
+    (packages null)
+    (check-list null)
+    (to-file #f)
+    (load-lang type-recs)
+    (build-info ast level type-recs #f)
+    (unless (null? (check-list))
+      (check-defs (car (check-list)) level type-recs))
+    (remove-from-packages ast type-recs)
+    (order-cus (translate-program ast type-recs) type-recs))
+  
+  ;compile-java-internal: port location type-records bool level-> (list compilation-unit)
+  (define (compile-java-internal port location type-recs file? level)
+    (packages null)
+    (check-list null)
+    (to-file file?)
+    (let ((ast (parse port location level)))
+      (remember-main ast)
+      (load-lang type-recs)
+      (set-importer! type-recs find-implicit-import)
+      (build-info ast level type-recs #f)
+      (unless (null? (check-list))
+        (check-defs (car (check-list)) level type-recs))
+      (remove-from-packages ast type-recs)
+      (order-cus (translate-program ast type-recs) type-recs)))
+  
+  ;compile-interactions: port location type-records level -> syntax
+  (define (compile-interactions port location type-recs level)
+    (to-file #f)
+    (let ((ast (parse-interactions port location level)))
+      (if (null? ast)
+          (datum->syntax-object #f '(void) #f)
+          (begin 
+            (build-interactions-info ast level location type-recs)
+            (check-interactions-types ast level location type-recs)
+            (translate-interactions ast location type-recs)))))
+      
+  (define (compile-interactions-ast ast location level type-recs)
+    (to-file #f)
+    (if (null? ast)
+        (datum->syntax-object #f '(void) #f)
+        (begin
+          (build-interactions-info ast level location type-recs)
+          (check-interactions-types ast level location type-recs)
+          (translate-interactions ast location type-recs))))
+  
+  (define-struct elt (prev val next))
+  
+  (define fifo
+    (class* object% ()
+      (define head null)
+      (define tail null)
+      
+      (define/public (empty?)
+        (and (null? head) (null? tail)))
+      
+      (define/public (pop)
+        (let ((old-head head))
+          (set! head (elt-next head))
+          (when (null? head) 
+            (set! tail null))
+          (unless (null? head)
+            (set-elt-prev! head null))
+          (elt-val old-head)))
+      (define/public (push e)
+        (let ((new-elt (make-elt tail e null)))
+          (if (empty?)
+              (begin (set! head new-elt)
+                     (set! tail head))
+              (begin
+                (set-elt-next! tail new-elt)
+                (set! tail new-elt)))))
+      (super-instantiate ())))
+  
+  (define (make-queue) (make-object fifo))
+  (define (empty-queue? q) (send q empty?))
+  (define (add-to-work-queue q elts) (for-each (lambda (e) (send q push e)) elts))
+  (define (queue-head q) (send q pop))
+
+  ;split-cu (list compilation-unit) (list compilation-unit) (list compilation-unit) (lis compilation-unit) type-records 
+  ;          -> (values (list compilation-unit) (list compilation-unit)
+  (define (split-cu cus cus-full with-depends without-depends type-recs)
+    (if (null? cus)
+        (values with-depends without-depends)
+        (if (null? (get-local-depends (compilation-unit-depends (car cus)) cus-full type-recs))
+            (split-cu (cdr cus) cus-full with-depends (cons (car cus) without-depends) type-recs)
+            (split-cu (cdr cus) cus-full (cons (car cus) with-depends) without-depends type-recs))))
+  
+  ;ok-to-add? compilation-unit (list compilation-unit) type-records -> bool
+  (define (ok-to-add? cu cus cus-full type-recs)
+    (andmap (lambda (depends-on)
+              (or (is-in? depends-on cu type-recs)
+                  (dependency-satisfied? depends-on cus type-recs)))
+            (get-local-depends (compilation-unit-depends cu) cus-full type-recs)))
+  
+  ;dependency-satisfied? req (list compilation-unit) type-records -> bool
+  (define (dependency-satisfied? depends-on cus type-recs)
+    (and (not (null? cus))
+         (or (is-in? depends-on (car cus) type-recs)
+             (dependency-satisfied? depends-on (cdr cus) type-recs))))
+  
+  ;get-local-depends: (list req) (list compilation-unit) type-records -> (list req)
+  (define (get-local-depends reqs cus type-recs)
+    (if (null? reqs)
+        null
+        (if (ormap (lambda (cu) (is-in? (car reqs) cu type-recs)) cus)
+            (cons (car reqs) (get-local-depends (cdr reqs) cus type-recs))
+            (get-local-depends (cdr reqs) cus type-recs))))
+  
+  ;is-in? req compilation-unit type-records -> bool
+  (define (is-in? class cu type-recs)
+    (and (member (req-class class) (compilation-unit-contains cu))
+         (equal? (req-path class)
+                 (begin
+                   (send type-recs set-location! (list-ref (compilation-unit-locations cu)
+                                                           (get-position (req-class class) (compilation-unit-contains cu) 0)))
+                   (send type-recs lookup-path (req-class class) (lambda () (error 'internal-error)))))))
+  
+  ;get-position: 'a (list 'a) int -> int
+  (define (get-position name names pos)
+    (if (or (null? (cdr names))
+            (equal? name (car names)))
+        pos
+        (get-position name (cdr names) (add1 pos))))
+  
+  ;order-cus (list compilation-unit) type-records -> (list compilation-unit)
+  (define (order-cus cus type-recs)
+    (let-values (((work-list ordered) (split-cu cus cus null null type-recs)))
+      ;(printf "order-cus: ~a ~a ~a ~n" (length cus) (length work-list) (length ordered)) 
+      (unless (null? work-list)
+        (let ((queue (make-queue)))
+          (for-each (lambda (cu) (send queue push cu)) work-list)
+          (let loop ()
+            ;(printf "looping in order-cus: ~a ~a ~n" (empty-queue? queue) (length ordered))
+            (unless (empty-queue? queue)
+              (let ((cu (send queue pop)))
+                (if (ok-to-add? cu ordered cus type-recs)
+                    (set! ordered (cons cu ordered))
+                    (send queue push cu)))
+              (loop)))))
+      (reverse ordered)))
+  
+  (define (remove-from-packages ast type-recs) 
+    (packages (filter (lambda (def) (not (contained-in? def (package-defs ast))))
+                      (packages))))
+
+  (define (contained-in? def defs)
+    (and (not (null? defs))
+         (or (eq? def (car defs))
+             (contained-in? def (cdr defs)))))
+  
+  (define (contains-main? members)
+    (and (not (null? members))
+         (or (and (method? (car members))
+                  (equal? "main" (id-string (method-name (car members)))))
+             (contains-main? (cdr members)))))
+  
+  (define (remember-main ast)
+    (let ((main-class (filter (lambda (def)
+                                (memq 'public 
+                                      (map modifier-kind (header-modifiers (def-header def)))))
+                              (filter class-def?
+                                      (package-defs ast)))))
+      (if (null? main-class)
+          (main (list #f null))
+          (main (list (contains-main? (def-members (car main-class)))
+                      (id-string (header-id (def-header (car main-class)))))))))
+    
+  )
+
diff --git a/collects/profj/default.jinfo b/collects/profj/default.jinfo
new file mode 100644
index 0000000000..323f2b7f68
--- /dev/null
+++ b/collects/profj/default.jinfo
@@ -0,0 +1,189 @@
+(
+(class ("Object" "java" "lang")
+       (public)
+       ()
+       (("Object" (public) ctor () () ("Object" "java" "lang"))
+	("clone" (protected) ("Object" "java" "lang") () (("CloneNotSupportedException" "java" "lang"))("Object" "java" "lang"))
+        ("equals" (public) boolean (("Object" "java" "lang")) () ("Object" "java" "lang"))
+        ("finalize" (protected) void () () ("Object" "java" "lang"))
+        ("getClass" (public final) ("Class" "java" "lang") () () ("Object" "java" "lang"))
+        ("hashCode" (public) int () () ("Object" "java" "lang"))
+        ("notify" (public final) void () () ("Object" "java" "lang"))
+        ("notifyAll" (public final) void () () ("Object" "java" "lang"))
+        ("toString" (public) ("String" "java" "lang") () () ("Object" "java" "lang"))
+        ("wait" (public final) void () (("InterruptedException" "java" "lang"))("Object" "java" "lang"))
+        ("wait" (public final) void (long) (("InterruptedException" "java" "lang"))("Object" "java" "lang"))
+        ("wait" (public final) void (long int) (("InterruptedException" "java" "lang")) ("Object" "java" "lang")))
+       (("Object" "java" "lang"))
+       ())
+
+(class ("Throwable" "java" "lang")
+       (public)
+       ()
+       (("Throwable" (public) ctor () () ("Throwable" "java" "lang"))
+	("Throwable" (public) ctor (("String" "java" "lang")) () ("Throwable" "java" "lang"))
+	("Throwable" (public) ctor (("String" "java" "lang") ("Throwable" "java" "lang")) () ("Throwable" "java" "lang"))
+	("Throwable" (public) ctor (("Throwable" "java" "lang")) () ("Throwable" "java" "lang"))
+
+	("fillInStackTrace" (public) ("Throwable" "java" "lang") () () ("Throwable" "java" "lang"))
+	("initCause" (public) ("Throwable" "java" "lang") (("Throwable" "java" "lang")) () ("Throwable" "java" "lang"))
+	("getCause" (public) ("Throwable" "java" "lang") () () ("Throwable" "java" "lang"))
+	("getLocalizedMessage" (public) ("String" "java" "lang") () () ("Throwable" "java" "lang"))
+	("getMessage" (public) ("String" "java" "lang") () () ("Throwable" "java" "lang"))
+	("getStackTrace" (public) (1 ("StackTraceElement" "java" "lang")) () () ("Throwable" "java" "lang"))
+	("printStackTrace" (public) void () () ("Throwable" "java" "lang"))
+	("printStackTrace" (public) void (("PrintString" "java" "io")) () ("Throwable" "java" "lang"))
+	("printStackTrace" (public) void (("PrintWriter" "java" "io")) () ("Throwable" "java" "lang"))
+	("setStackTrace" (public) void ((1 ("StackTraceElement" "java" "lang"))) () ("Throwable" "java" "lang"))
+	("toString" (public) ("String" "java" "lang") () () ("Throwable" "java" "lang"))
+
+	("Object" (public) ctor () () ("Object" "java" "lang"))
+	("clone" (protected) ("Object" "java" "lang") () (("CloneNotSupportedException" "java" "lang"))("Object" "java" "lang"))
+        ("equals" (public) boolean (("Object" "java" "lang")) () ("Object" "java" "lang"))
+        ("finalize" (protected) void () () ("Object" "java" "lang"))
+        ("getClass" (public final) ("Class" "java" "lang") () () ("Object" "java" "lang"))
+        ("hashCode" (public) int () () ("Object" "java" "lang"))
+        ("notify" (public final) void () () ("Object" "java" "lang"))
+        ("notifyAll" (public final) void () () ("Object" "java" "lang"))
+        ("toString" (public) ("String" "java" "lang") () () ("Object" "java" "lang"))
+        ("wait" (public final) void () (("InterruptedException" "java" "lang"))("Object" "java" "lang"))
+        ("wait" (public final) void (long) (("InterruptedException" "java" "lang"))("Object" "java" "lang"))
+        ("wait" (public final) void (long int) (("InterruptedException" "java" "lang")) ("Object" "java" "lang")))
+
+       (("Object" "java" "lang"))
+       (("Serializable" "java" "io")))	
+
+(class ("Class" "java" "lang")
+       (public final)
+       ()
+       (("Class" (public) ctor () () ("Class" "java" "lang")))
+       (("Object" "java" "lang"))
+       ())
+
+(class ("String" "java" "lang")
+       (public final)
+       (("CASE_INSENSITIVE_ORDER" (public static final) 
+                                  ("String" "java" "lang")
+                                  ("Comparator" "java" "util")))
+       (("String" (public) ctor () () ("String" "java" "lang"))
+        ("String" (public) ctor (("String" "java" "lang")) () ("String" "java" "lang"))
+        ("String" (public) ctor ((1 char)) () ("String" "java" "lang"))
+        ("String" (public) ctor ((1 char) int int) () ("String" "java" "lang"))
+        ("String" (public) ctor ((1 byte) int int ("String" "java" "lang")) (("UnsupportedEncodingException" "java" "io")) ("String" "java" "lang"))
+        ("String" (public) ctor ((1 byte) ("String" "java" "lang")) (("UnsupportedEncodingException" "java" "io")) ("String" "java" "lang"))
+        ("String" (public) ctor ((1 byte) int int) () ("String" "java" "lang"))
+        ("String" (public) ctor ((1 byte)) () ("String" "java" "lang"))
+        ("String" (public) ctor (("StringBuffer" "java" "lang")) () ("String" "java" "lang"))
+
+        ("length" (public) int () () ("String" "java" "lang"))
+        ("charAt" (public) char (int) () ("String" "java" "lang"))
+        ("getChars" (public) void (int int (1 char) int) () ("String" "java" "lang"))
+        ("getBytes" (public) (1 byte) (("String" "java" "lang")) (("UnsupportedEncodingException" "java" "io")) ("String" "java" "lang"))
+        ("getBytes" (public) (1 byte) () () ("String" "java" "lang"))
+        ("equals" (public) boolean (("Object" "java" "lang")) () ("String" "java" "lang"))
+        ("contentEquals" (public) boolean (("StringBuffer" "java" "lang")) () ("String" "java" "lang"))
+        ("equalsIgnoreCase" (public) boolean (("String" "java" "lang")) () ("String" "java" "lang"))
+        ("compareTo" (public) int (("String" "java" "lang")) () ("String" "java" "lang"))
+        ("compareTo" (public) int (("Object" "java" "lang")) () ("String" "java" "lang"))
+        ("compareToIgnoreCase" (public) int (("String" "java" "lang")) () ("String" "java" "lang"))
+        ("regionMatches" (public) boolean (int ("String" "java" "lang") int int) () ("String" "java" "lang"))
+        ("regionMatches" (public) boolean (boolean int ("String" "java" "lang") int int) () ("String" "java" "lang"))
+        ("startsWith" (public) boolean (("String" "java" "lang") int) () ("String" "java" "lang"))
+        ("startsWith" (public) boolean (("String" "java" "lang")) () ("String" "java" "lang"))
+        ("endsWith" (public) boolean (("String" "java" "lang")) () ("String" "java" "lang"))
+        ("hashCode" (public) int () () ("String" "java" "lang"))
+        ("indexOf" (public) int (int) () ("String" "java" "lang"))
+        ("indexOf" (public) int (int int) () ("String" "java" "lang"))
+        ("lastIndexOf" (public) int (int) () ("String" "java" "lang"))
+        ("lastIndexOf" (public) int (int int) () ("String" "java" "lang"))
+        ("indexOf" (public) int (("String" "java" "lang")) () ("String" "java" "lang"))
+        ("indexOf" (public) int (("String" "java" "lang") int) () ("String" "java" "lang"))
+        ("lastIndexOf" (public) int (("String" "java" "lang")) () ("String" "java" "lang"))
+        ("lastIndexOf" (public) int (("String" "java" "lang") int) () ("String" "java" "lang"))
+        ("substring" (public) ("String" "java" "lang") (int) () ("String" "java" "lang"))
+        ("substring" (public) ("String" "java" "lang") (int int) () ("String" "java" "lang"))
+        ("subSequence" (public) ("CharSequence" "java" "lang") (int int) () ("String" "java" "lang"))
+        ("concat" (public) ("String" "java" "lang") (("String" "java" "lang")) () ("String" "java" "lang"))
+        ("replace" (public) ("String" "java" "lang") (char char) () ("String" "java" "lang"))
+        ("matches" (public) boolean (("String" "java" "lang")) () ("String" "java" "lang"))
+        ("replaceFirst" (public) ("String" "java" "lang") (("String" "java" "lang") ("String" "java" "lang")) () ("String" "java" "lang"))
+        ("replaceAll" (public) ("String" "java" "lang") (("String" "java" "lang")("String" "java" "lang")) () ("String" "java" "lang"))
+        ("split" (public) (1 ("String" "java" "lang")) (("String" "java" "lang") int) () ("String" "java" "lang"))
+        ("split" (public) (1 ("String" "java" "lang")) (("String" "java" "lang")) () ("String" "java" "lang"))
+        ("toLowerCase" (public) ("String" "java" "lang") (("Locale" "java" "util")) () ("String" "java" "lang"))
+        ("toLowerCase" (public) ("String" "java" "lang") () () ("String" "java" "lang"))
+        ("toUpperCase" (public) ("String" "java" "lang") (("Locale" "java" "util")) () ("String" "java" "lang"))
+        ("toUpperCase" (public) ("String" "java" "lang") () () ("String" "java" "lang"))
+        ("trim" (public) ("String" "java" "lang") () () ("String" "java" "lang"))
+        ("toString" (public) ("String" "java" "lang") () () ("String" "java" "lang"))
+        ("toCharArray" (public) (1 char) () () ("String" "java" "lang"))
+        ("valueOf" (public static) ("String" "java" "lang") (("Object" "java" "lang")) () ("String" "java" "lang"))
+        ("valueOf" (public static) ("String" "java" "lang") ((1 char)) () ("String" "java" "lang"))
+        ("valueOf" (public static) ("String" "java" "lang") ((1 char) int int) () ("String" "java" "lang"))
+        ("copyValueOf" (public static) ("String" "java" "lang") ((1 char) int int) () ("String" "java" "lang"))
+        ("copyValueOf" (public static) ("String" "java" "lang") ((1 char)) () ("String" "java" "lang"))
+        ("valueOf" (public static) ("String" "java" "lang") (boolean) () ("String" "java" "lang"))
+        ("valueOf" (public static) ("String" "java" "lang") (char) () ("String" "java" "lang"))
+        ("valueOf" (public static) ("String" "java" "lang") (int) () ("String" "java" "lang"))
+        ("valueOf" (public static) ("String" "java" "lang") (long) () ("String" "java" "lang"))
+        ("valueOf" (public static) ("String" "java" "lang") (float) () ("String" "java" "lang"))
+        ("valueOf" (public static) ("String" "java" "lang") (double) () ("String" "java" "lang"))
+        ("intern" (public) ("String" "java" "lang") () () ("String" "java" "lang"))
+
+	("Object" (public) ctor () () ("Object" "java" "lang"))
+	("clone" (protected) ("Object" "java" "lang") () (("CloneNotSupportedException" "java" "lang"))("Object" "java" "lang"))
+        ("equals" (public) boolean (("Object" "java" "lang")) () ("Object" "java" "lang"))
+        ("finalize" (protected) void () () ("Object" "java" "lang"))
+        ("getClass" (public final) ("Class" "java" "lang") () () ("Object" "java" "lang"))
+        ("hashCode" (public) int () () ("Object" "java" "lang"))
+        ("notify" (public final) void () () ("Object" "java" "lang"))
+        ("notifyAll" (public final) void () () ("Object" "java" "lang"))
+        ("toString" (public) ("String" "java" "lang") () () ("Object" "java" "lang"))
+        ("wait" (public final) void () (("InterruptedException" "java" "lang"))("Object" "java" "lang"))
+        ("wait" (public final) void (long) (("InterruptedException" "java" "lang"))("Object" "java" "lang"))
+        ("wait" (public final) void (long int) (("InterruptedException" "java" "lang")) ("Object" "java" "lang")))
+ 
+       (("Object" "java" "lang"))
+       (("Serializable" "java" "io") ("Comparable" "java" "lang") ("CharSequence" "java" "lang")))
+
+(interface ("Serializable" "java" "io")
+           (public)
+           ()
+           ()
+           ()
+           ())
+
+(interface ("Cloneable" "java" "lang")
+           (public)
+           ()
+           ()
+           ()
+           ())
+
+(interface ("Comparable" "java" "lang")
+           (public)
+           ()
+           (("compareTo" (public) int (("Object" "java" "lang")) () ("Comparable" "java" "lang")))
+           ()
+           ())
+
+(interface ("Runnable" "java" "lang")
+           (public)
+           ()
+           (("run" (public) void () () ("Runnable" "java" "lang")))
+           ()
+           ())
+
+(interface ("CharSequence" "java" "lang")
+           (public)
+           ()
+           (("length" (public) int () () ("CharSequence" "java" "lang"))
+            ("charAt" (public) char (int) () ("CharSequence" "java" "lang"))
+            ("subSequence" (public) ("CharSequence" "java" "lang") (int int) () ("CharSequence" "java" "lang"))
+            ("toString" (public) ("String" "java" "lang") () () ("CharSequence" "java" "lang")))
+           ()
+           ())
+
+)
+
+
diff --git a/collects/profj/doc.txt b/collects/profj/doc.txt
new file mode 100644
index 0000000000..2633b64547
--- /dev/null
+++ b/collects/profj/doc.txt
@@ -0,0 +1,98 @@
+_professorj_
+
+This documentation details available resources, recent additions, and
+constructs which do not currently work in ProfessorJ overall. For
+details of the specific language levels, please see the language level
+specific manuals.
+
+The interactions window accepts variable declaration, statements and
+expressions legal for the language level. If the text is not sending,
+type Alt+Enter.
+
+The definitions window expects class and interface defintions,
+interaction boxes, and test-suite boxes. (i.e. what would be given to
+javac plus two graphical boxes). Descriptions of these boxes can be
+found in the DrScheme manual.
+
+_Libraries available to ProfessorJ:
+
+*NEW* Items are new to either DrScheme 207 or DrScheme 208
+
+  java.lang.Object
+  java.lang.String (see exceptions)
+  java.lang.Throwable
+  java.lang.*Exception
+  *NEW* java.lang.System (only currentTimeMillis, gc, and identityHashCode)
+  *NEW* java.lang.Comparable
+  *NEW* java.lang.Number
+  *NEW* java.lang.Double (see exceptions) 
+  *NEW* java.lang.Float (see exceptions) 
+  *NEW* java.lang.Boolean (see exceptions) 
+  *NEW* java.io.Serializable
+  *NEW* java.util.Random
+
+  *NEW* Teachpacks (PLT/collects/htdch)
+  *NEW* draw.*
+
+  exceptions:
+   String: String(byte[],int,int,String) -- incorrect
+           String(byte[],int,int,int) -- incorrect
+           getBytes() -- partially incorrect
+           replaceAll(String,String) -- not implemented
+           replaceFirst(String,String) -- not implemented
+           matches(String) -- not implemented
+           split(String,int) -- not implemented
+           split(String) -- not implemented
+           trim -- not implemented
+   Double: doubleToLongBits -- not implemented
+           doubleToRawBits -- not implemented
+           longBitsToDouble -- not implemented
+   Float:  floatToIntBits, floatToRawBits, longBitsToFloat -- not implemented
+   Boolean: getBoolean(String) not implemented
+
+_General New Items (New to 207 and 208)
+
+  New to all teaching language levels:
+    import package.name.*;
+    a teachpack directory (PLT/collects/htdch)
+    access to draw.* teachpack
+
+  New to Beginner:
+    super calls reallowed. For example
+      class A { 
+        int x;
+        A(int x) {
+          this.x = x;
+        }
+        int adder() { return x + 1; }
+      }
+      class B extends A {
+        int y;
+        B( int x, int y) {
+          super(x);
+          this.y = y;
+        }
+        int adder() { return y + super.adder(); }
+      }
+    now works
+ 
+    == is restricted to comparing byte, short, int, long, char, and boolean
+    values
+
+    Classes may have initialized fields (i.e. int x = 3;)
+
+_Unfinished constructs:
+  nested classes
+  switch
+  labeled statements (compiles but does not work correctly)
+  reflection
+  unicode
+  synchronized (compiles but is ignored)
+  strictfp (compiles but is ignored)
+
+
+
+
+
+
+
diff --git a/collects/profj/error-messaging.ss b/collects/profj/error-messaging.ss
new file mode 100644
index 0000000000..0eca85ffc3
--- /dev/null
+++ b/collects/profj/error-messaging.ss
@@ -0,0 +1,105 @@
+#cs
+(module error-messaging mzscheme
+  
+  (require "ast.ss")
+  (require "types.ss")
+  
+  (provide make-error-pass get-expected type->ext-name id->ext-name 
+           get-call-type method-name->ext-name path->ext name->path
+           statement->ext-name)
+  
+  ;make-error: 'a string 'a src -> void
+  (define (make-error-pass parm)
+    (lambda (kind message so src)
+      (raise-syntax-error kind message (make-so so src parm))))
+  
+  ;make-so: symbol src (-> location) -> syntax-object
+  (define (make-so id src parm)
+    (datum->syntax-object #f id (build-src-list src parm)))
+  
+  ;build-src-list: src (-> location) -> (U bool (list loc int int int int))
+  (define (build-src-list src parm)
+    (if (not src)
+        src
+        (if (and (= (src-line src) 0)
+                 (= (src-col src) 0)
+                 (= (src-pos src) 0)
+                 (= (src-span src) 0))
+            #f
+            (list (or (src-file src) (parm)) (src-line src) (src-col src) (src-pos src) (src-span src)))))
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;Message helpers
+  
+  ;get-expected: symbol-> string
+  (define (get-expected e)
+    (case e
+      ((bool) 'boolean)
+      ((int) "int, short, byte or char")
+      ((num) "double, float, long, int, short, byte or char")
+      (else "dummy")))
+  
+ ;type->ext-name: type -> symbol
+  (define (type->ext-name t)
+    (string->symbol
+     (cond 
+       ((ref-type? t) (ref-type-class/iface t))
+       ((array-type? t) 
+        (format "~a~a" (type->ext-name (array-type-type t))
+                (let ((dims ""))
+                  (let loop ((d (array-type-dim t)))
+                    (if (= d 0)
+                        dims
+                        (begin (set! dims (string-append dims "[]"))
+                               (loop (sub1 d))))))))
+       (else (format "~a" t)))))
+  
+  ;id->ext-name: id -> symbol
+  (define (id->ext-name id)
+    (string->symbol (if (special-name? id)
+                        (special-name-name id)
+                        (id-string id))))
+  
+  ;get-call-type: type -> string
+  (define (get-call-type t)
+    (cond
+      ((eq? t 'super) "the current super class")
+      ((not t) "this class")
+      (else (type->ext-name t))))
+  
+  ;make-parm-string: (list type) -> string
+  (define (make-parm-string parms)
+    (if (null? parms)
+        ""
+        (let ((parm-str (apply string-append
+                          (map 
+                           (lambda (p) (format "~a " (type->ext-name p))) parms))))
+          (substring parm-str 0 (sub1 (string-length parm-str))))))
+  
+  ;method-name->ext-name: string (list type) -> symbol
+  (define (method-name->ext-name name parms)
+    (string->symbol (format "~a(~a)" name (make-parm-string parms))))
+
+  ;path->ext: (list string) -> string
+  (define (path->ext path)
+    (apply string-append
+           (append (map (lambda (a) (string-append a "."))
+                        (cdr path))
+                   (list (car path)))))
+  
+  ;name->path: name -> (list string)
+  (define (name->path n)
+    (cons (id-string (name-id n)) (map id-string (name-path n))))
+  
+  ;statement->ext-name: statement -> symbol
+  (define (statement->ext-name s)
+    (cond
+      ((ifS? s) 'if)
+      ((return? s) 'return)
+      ((call? s) 
+       (let ((method (call-method-name s)))
+         (string->symbol (if (special-name? method)
+                             (special-name-name method)
+                             (id-string method)))))))
+
+  )
\ No newline at end of file
diff --git a/collects/profj/info.ss b/collects/profj/info.ss
new file mode 100644
index 0000000000..32be57a2b7
--- /dev/null
+++ b/collects/profj/info.ss
@@ -0,0 +1,10 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "ProfessorJ")
+  (define doc.txt "doc.txt")
+  (define tools (list (list "tool.ss")))
+  (define install-collection "installer.ss")
+  (define pre-install-collection "pre-installer.ss")
+  (define compile-subcollections (list (list "profj" "parsers")
+                                       (list "profj" "libs" "java" "lang")
+				       (list "profj" "libs" "java" "io")
+                                       (list "profj" "libs" "java" "util"))))
diff --git a/collects/profj/installer.ss b/collects/profj/installer.ss
new file mode 100644
index 0000000000..e33c2ec4cf
--- /dev/null
+++ b/collects/profj/installer.ss
@@ -0,0 +1,11 @@
+(module installer mzscheme
+  (require (prefix lang: (lib "installer.ss" "profj" "libs" "java" "lang"))
+           (prefix io: (lib "installer.ss" "profj" "libs" "java" "io"))
+           (prefix util: (lib "installer.ss" "profj" "libs" "java" "util")))
+  (provide installer)
+
+  (define (installer plthome)
+    (io:installer plthome)
+    (lang:installer plthome)
+;    (io:installer plthome)
+    (util:installer plthome)))
\ No newline at end of file
diff --git a/collects/profj/libs/java/io/Serializable.jinfo b/collects/profj/libs/java/io/Serializable.jinfo
new file mode 100644
index 0000000000..aca22f9926
--- /dev/null
+++ b/collects/profj/libs/java/io/Serializable.jinfo
@@ -0,0 +1,10 @@
+(interface
+  ("Serializable" "java" "io")
+  (public)
+  #t
+  ()
+  ()
+  ()
+  ()
+  ()
+  "version1")
diff --git a/collects/profj/libs/java/io/Serializable.ss b/collects/profj/libs/java/io/Serializable.ss
new file mode 100644
index 0000000000..2312d4c007
--- /dev/null
+++ b/collects/profj/libs/java/io/Serializable.ss
@@ -0,0 +1,7 @@
+#cs
+(module Serializable mzscheme
+  (require (lib "class.ss"))
+  
+  (provide (all-defined))
+  
+  (define Serializable (interface ())))
\ No newline at end of file
diff --git a/collects/profj/libs/java/io/info.ss b/collects/profj/libs/java/io/info.ss
new file mode 100644
index 0000000000..b178d55fa9
--- /dev/null
+++ b/collects/profj/libs/java/io/info.ss
@@ -0,0 +1,3 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "ProfessorJ: libs java io")
+  #;(define install-collection "installer.ss"))
\ No newline at end of file
diff --git a/collects/profj/libs/java/io/installer.ss b/collects/profj/libs/java/io/installer.ss
new file mode 100644
index 0000000000..3a4588575a
--- /dev/null
+++ b/collects/profj/libs/java/io/installer.ss
@@ -0,0 +1,7 @@
+(module installer mzscheme
+  (provide installer)
+
+  (define (installer plthome)
+    ;replace with calls to compile Java files when they exist at this location
+    (void)
+    ))
\ No newline at end of file
diff --git a/collects/profj/libs/java/lang/ArithmeticException.java b/collects/profj/libs/java/lang/ArithmeticException.java
new file mode 100644
index 0000000000..de79b096ab
--- /dev/null
+++ b/collects/profj/libs/java/lang/ArithmeticException.java
@@ -0,0 +1,77 @@
+/* ArithmeticException.java -- exception thrown to indicate conditions
+   like divide by zero.
+   Copyright (C) 1998, 1999, 2001, 2002 Free Software Foundation, Inc.
+
+This file is part of GNU Classpath.
+
+GNU Classpath is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU Classpath is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Classpath; see the file COPYING.  If not, write to the
+Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+02111-1307 USA.
+
+Linking this library statically or dynamically with other modules is
+making a combined work based on this library.  Thus, the terms and
+conditions of the GNU General Public License cover the whole
+combination.
+
+As a special exception, the copyright holders of this library give you
+permission to link this library with independent modules to produce an
+executable, regardless of the license terms of these independent
+modules, and to copy and distribute the resulting executable under
+terms of your choice, provided that you also meet, for each linked
+independent module, the terms and conditions of the license of that
+module.  An independent module is a module which is not derived from
+or based on this library.  If you modify this library, you may extend
+this exception to your version of the library, but you are not
+obligated to do so.  If you do not wish to do so, delete this
+exception statement from your version. */
+
+
+package java.lang;
+
+/**
+ * Thrown when a math error has occured, such as trying to divide an
+ * integer by zero. For example:<br>
+ * <pre>
+ * int i = 0;
+ * int j = 2 / i;
+ * </pre>
+ *
+ * @author Brian Jones
+ * @author Warren Levy <warrenl@cygnus.com>
+ * @status updated to 1.4
+ */
+public class ArithmeticException extends RuntimeException
+{
+  /**
+   * Compatible with JDK 1.0+.
+   */
+  private static final long serialVersionUID = 2256477558314496007L;
+
+  /**
+   * Create an exception without a message.
+   */
+  public ArithmeticException()
+  {
+  }
+
+  /**
+   * Create an exception with a message.
+   *
+   * @param s the message
+   */
+  public ArithmeticException(String s)
+  {
+    super(s);
+  }
+}
diff --git a/collects/profj/libs/java/lang/ArithmeticException.ss b/collects/profj/libs/java/lang/ArithmeticException.ss
new file mode 100644
index 0000000000..1bb311f43c
--- /dev/null
+++ b/collects/profj/libs/java/lang/ArithmeticException.ss
@@ -0,0 +1,3 @@
+(module |ArithmeticException| mzscheme
+  (require "Object-composite.ss")
+  (provide |ArithmeticException|))
diff --git a/collects/profj/libs/java/lang/ArrayIndexOutOfBoundsException.java b/collects/profj/libs/java/lang/ArrayIndexOutOfBoundsException.java
new file mode 100644
index 0000000000..1a6db8daf0
--- /dev/null
+++ b/collects/profj/libs/java/lang/ArrayIndexOutOfBoundsException.java
@@ -0,0 +1,87 @@
+/* ArrayIndexOutOfBoundsException.java -- exception thrown when accessing
+   an illegal index.
+   Copyright (C) 1998, 1999, 2001, 2002 Free Software Foundation, Inc.
+
+This file is part of GNU Classpath.
+
+GNU Classpath is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU Classpath is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Classpath; see the file COPYING.  If not, write to the
+Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+02111-1307 USA.
+
+Linking this library statically or dynamically with other modules is
+making a combined work based on this library.  Thus, the terms and
+conditions of the GNU General Public License cover the whole
+combination.
+
+As a special exception, the copyright holders of this library give you
+permission to link this library with independent modules to produce an
+executable, regardless of the license terms of these independent
+modules, and to copy and distribute the resulting executable under
+terms of your choice, provided that you also meet, for each linked
+independent module, the terms and conditions of the license of that
+module.  An independent module is a module which is not derived from
+or based on this library.  If you modify this library, you may extend
+this exception to your version of the library, but you are not
+obligated to do so.  If you do not wish to do so, delete this
+exception statement from your version. */
+
+
+package java.lang;
+
+/**
+ * Thrown when attempting to access a position outside the valid range of
+ * an array. For example:<br>
+ * <pre>
+ * int[] i = { 1 };
+ * i[1] = 2;
+ * </pre>
+ *
+ * @author Brian Jones
+ * @author Warren Levy <warrenl@cygnus.com>
+ * @status updated to 1.4
+ */
+public class ArrayIndexOutOfBoundsException extends IndexOutOfBoundsException
+{
+  /**
+   * Compatible with JDK 1.0+.
+   */
+  private static final long serialVersionUID = -5116101128118950844L;
+
+  /**
+   * Create an exception without a message.
+   */
+  public ArrayIndexOutOfBoundsException()
+  {
+  }
+
+  /**
+   * Create an exception with a message.
+   *
+   * @param s the message
+   */
+  public ArrayIndexOutOfBoundsException(String s)
+  {
+    super(s);
+  }
+
+  /**
+   * Create an exception indicating the illegal index.
+   *
+   * @param index the invalid index
+   */
+  public ArrayIndexOutOfBoundsException(int index)
+  {
+    super("Array index out of range: " + index);
+  }
+}
diff --git a/collects/profj/libs/java/lang/ArrayIndexOutOfBoundsException.ss b/collects/profj/libs/java/lang/ArrayIndexOutOfBoundsException.ss
new file mode 100644
index 0000000000..0a33efaef9
--- /dev/null
+++ b/collects/profj/libs/java/lang/ArrayIndexOutOfBoundsException.ss
@@ -0,0 +1,3 @@
+(module |ArrayIndexOutOfBoundsException| mzscheme
+  (require "Object-composite.ss")
+  (provide |ArrayIndexOutOfBoundsException|))
diff --git a/collects/profj/libs/java/lang/ArrayStoreException.java b/collects/profj/libs/java/lang/ArrayStoreException.java
new file mode 100644
index 0000000000..3fa714d2ef
--- /dev/null
+++ b/collects/profj/libs/java/lang/ArrayStoreException.java
@@ -0,0 +1,77 @@
+/* ArrayStoreException.java -- exception thrown to when trying to store an
+   object into an array of a different type.
+   Copyright (C) 1998, 1999, 2001, 2002 Free Software Foundation, Inc.
+
+This file is part of GNU Classpath.
+
+GNU Classpath is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU Classpath is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Classpath; see the file COPYING.  If not, write to the
+Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+02111-1307 USA.
+
+Linking this library statically or dynamically with other modules is
+making a combined work based on this library.  Thus, the terms and
+conditions of the GNU General Public License cover the whole
+combination.
+
+As a special exception, the copyright holders of this library give you
+permission to link this library with independent modules to produce an
+executable, regardless of the license terms of these independent
+modules, and to copy and distribute the resulting executable under
+terms of your choice, provided that you also meet, for each linked
+independent module, the terms and conditions of the license of that
+module.  An independent module is a module which is not derived from
+or based on this library.  If you modify this library, you may extend
+this exception to your version of the library, but you are not
+obligated to do so.  If you do not wish to do so, delete this
+exception statement from your version. */
+
+
+package java.lang;
+
+/**
+ * Thrown when trying to store an object of the wrong runtime type in an
+ * array. For example:<br>
+ * <pre>
+ * Object[] o = new Integer[1];
+ * o[0] = "oops";
+ * </pre>
+ *
+ * @author Brian Jones
+ * @author Warren Levy <warrenl@cygnus.com>
+ * @status updated to 1.4
+ */
+public class ArrayStoreException extends RuntimeException
+{
+  /**
+   * Compatible with JDK 1.0+.
+   */
+  private static final long serialVersionUID = -4522193890499838241L;
+
+  /**
+   * Create an exception without a message.
+   */
+  public ArrayStoreException()
+  {
+  }
+
+  /**
+   * Create an exception with a message.
+   *
+   * @param s the message
+   */
+  public ArrayStoreException(String s)
+  {
+    super(s);
+  }
+}
diff --git a/collects/profj/libs/java/lang/ArrayStoreException.ss b/collects/profj/libs/java/lang/ArrayStoreException.ss
new file mode 100644
index 0000000000..eebe194219
--- /dev/null
+++ b/collects/profj/libs/java/lang/ArrayStoreException.ss
@@ -0,0 +1,3 @@
+(module |ArrayStoreException| mzscheme
+  (require "Object-composite.ss")
+  (provide |ArrayStoreException|))
diff --git a/collects/profj/libs/java/lang/Boolean.java b/collects/profj/libs/java/lang/Boolean.java
new file mode 100644
index 0000000000..07c7d06766
--- /dev/null
+++ b/collects/profj/libs/java/lang/Boolean.java
@@ -0,0 +1,225 @@
+/* Boolean.java -- object wrapper for boolean
+   Copyright (C) 1998, 2001, 2002 Free Software Foundation, Inc.
+
+This file is part of GNU Classpath.
+
+GNU Classpath is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU Classpath is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Classpath; see the file COPYING.  If not, write to the
+Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+02111-1307 USA.
+
+Linking this library statically or dynamically with other modules is
+making a combined work based on this library.  Thus, the terms and
+conditions of the GNU General Public License cover the whole
+combination.
+
+As a special exception, the copyright holders of this library give you
+permission to link this library with independent modules to produce an
+executable, regardless of the license terms of these independent
+modules, and to copy and distribute the resulting executable under
+terms of your choice, provided that you also meet, for each linked
+independent module, the terms and conditions of the license of that
+module.  An independent module is a module which is not derived from
+or based on this library.  If you modify this library, you may extend
+this exception to your version of the library, but you are not
+obligated to do so.  If you do not wish to do so, delete this
+exception statement from your version. */
+
+
+package java.lang;
+
+import java.io.Serializable;
+
+/**
+ * Instances of class <code>Boolean</code> represent primitive
+ * <code>boolean</code> values.
+ *
+ * @author Paul Fisher
+ * @author Eric Blake <ebb9@email.byu.edu>
+ * @since 1.0
+ * @status updated to 1.4
+ */
+public final class Boolean implements Serializable
+{
+  /**
+   * Compatible with JDK 1.0.2+.
+   */
+  private static final long serialVersionUID = -3665804199014368530L;
+
+  /**
+   * This field is a <code>Boolean</code> object representing the
+   * primitive value <code>true</code>. This instance is returned
+   * by the static <code>valueOf()</code> methods if they return
+   * a <code>Boolean</code> representing <code>true</code>.
+   */
+  public static final Boolean TRUE = new Boolean(true);
+
+  /**
+   * This field is a <code>Boolean</code> object representing the
+   * primitive value <code>false</code>. This instance is returned
+   * by the static <code>valueOf()</code> methods if they return
+   * a <code>Boolean</code> representing <code>false</code>.
+   */
+  public static final Boolean FALSE = new Boolean(false);
+
+  /**
+   * The primitive type <code>boolean</code> is represented by this
+   * <code>Class</code> object.
+   *
+   * @since 1.1
+   */
+//  public static final Class TYPE = VMClassLoader.getPrimitiveClass('Z');
+
+  /**
+   * The immutable value of this Boolean.
+   * @serial the wrapped value
+   */
+  private final boolean value;
+
+  /**
+   * Create a <code>Boolean</code> object representing the value of the
+   * argument <code>value</code>. In general the use of the static
+   * method <code>valueof(boolean)</code> is more efficient since it will
+   * not create a new object.
+   *
+   * @param value the primitive value of this <code>Boolean</code>
+   * @see #valueOf(boolean)
+   */
+  public Boolean(boolean value)
+  {
+    this.value = value;
+  }
+
+  /**
+   * Creates a <code>Boolean</code> object representing the primitive
+   * <code>true</code> if and only if <code>s</code> matches
+   * the string "true" ignoring case, otherwise the object will represent
+   * the primitive <code>false</code>. In general the use of the static
+   * method <code>valueof(String)</code> is more efficient since it will
+   * not create a new object.
+   *
+   * @param s the <code>String</code> representation of <code>true</code>
+   *        or false
+   */
+  public Boolean(String s)
+  {
+    value = "true".equalsIgnoreCase(s);
+  }
+
+  /**
+   * Return the primitive <code>boolean</code> value of this
+   * <code>Boolean</code> object.
+   *
+   * @return true or false, depending on the value of this Boolean
+   */
+  public boolean booleanValue()
+  {
+    return value;
+  }
+
+  /**
+   * Returns the Boolean <code>TRUE</code> if the given boolean is
+   * <code>true</code>, otherwise it will return the Boolean
+   * <code>FALSE</code>.
+   *
+   * @param b the boolean to wrap
+   * @return the wrapper object
+   * @see #TRUE
+   * @see #FALSE
+   * @since 1.4
+   */
+  public static Boolean valueOf(boolean b)
+  {
+    return b ? TRUE : FALSE;
+  }
+
+  /**
+   * Returns the Boolean <code>TRUE</code> if and only if the given
+   * String is equal, ignoring case, to the the String "true", otherwise
+   * it will return the Boolean <code>FALSE</code>.
+   *
+   * @param s the string to convert
+   * @return a wrapped boolean from the string
+   */
+  public static Boolean valueOf(String s)
+  {
+    return "true".equalsIgnoreCase(s) ? TRUE : FALSE;
+  }
+
+  /**
+   * Returns "true" if the value of the give boolean is <code>true</code> and
+   * returns "false" if the value of the given boolean is <code>false</code>.
+   *
+   * @param b the boolean to convert
+   * @return the string representation of the boolean
+   * @since 1.4
+   */
+  public static String toString(boolean b)
+  {
+    return b ? "true" : "false";
+  }
+
+  /**
+   * Returns "true" if the value of this object is <code>true</code> and
+   * returns "false" if the value of this object is <code>false</code>.
+   *
+   * @return the string representation of this
+   */
+  public String toString()
+  {
+    return value ? "true" : "false";
+  }
+
+  /**
+   * Returns the integer <code>1231</code> if this object represents
+   * the primitive <code>true</code> and the integer <code>1237</code>
+   * otherwise.
+   *
+   * @return the hash code
+   */
+  public int hashCode()
+  {
+    return value ? 1231 : 1237;
+  }
+
+  /**
+   * If the <code>obj</code> is an instance of <code>Boolean</code> and
+   * has the same primitive value as this object then <code>true</code>
+   * is returned.  In all other cases, including if the <code>obj</code>
+   * is <code>null</code>, <code>false</code> is returned.
+   *
+   * @param obj possibly an instance of any <code>Class</code>
+   * @return true if <code>obj</code> equals this
+   */
+  public boolean equals(Object obj)
+  {
+    return obj instanceof Boolean && value == ((Boolean) obj).value;
+  }
+
+  /**
+   * If the value of the system property <code>name</code> matches
+   * "true" ignoring case then the function returns <code>true</code>.
+   *
+   * @param name the property name to look up
+   * @return true if the property resulted in "true"
+   * @throws SecurityException if accessing the system property is forbidden
+   * @see System#getProperty(String)
+   */
+  public static boolean getBoolean(String name)
+  {
+      throw new RuntimeException("getBoolean has not been implemented yet");
+//    if (name == null || "".equals(name))
+//     return false;
+//    return "true".equalsIgnoreCase(System.getProperty(name));
+  }
+}
diff --git a/collects/profj/libs/java/lang/CharSequence.java b/collects/profj/libs/java/lang/CharSequence.java
new file mode 100644
index 0000000000..9886c1a50b
--- /dev/null
+++ b/collects/profj/libs/java/lang/CharSequence.java
@@ -0,0 +1,8 @@
+package java.lang;
+
+public interface CharSequence {
+  public char charAt(int index);
+  public int length();
+  CharSequence subSequence(int start, int end);
+  String toString();
+}
diff --git a/collects/profj/libs/java/lang/ClassCastException.java b/collects/profj/libs/java/lang/ClassCastException.java
new file mode 100644
index 0000000000..b552b23fbd
--- /dev/null
+++ b/collects/profj/libs/java/lang/ClassCastException.java
@@ -0,0 +1,76 @@
+/* ClassCastException.java -- exception thrown on bad cast
+   Copyright (C) 1998, 1999, 2001, 2002 Free Software Foundation, Inc.
+
+This file is part of GNU Classpath.
+
+GNU Classpath is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU Classpath is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Classpath; see the file COPYING.  If not, write to the
+Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+02111-1307 USA.
+
+Linking this library statically or dynamically with other modules is
+making a combined work based on this library.  Thus, the terms and
+conditions of the GNU General Public License cover the whole
+combination.
+
+As a special exception, the copyright holders of this library give you
+permission to link this library with independent modules to produce an
+executable, regardless of the license terms of these independent
+modules, and to copy and distribute the resulting executable under
+terms of your choice, provided that you also meet, for each linked
+independent module, the terms and conditions of the license of that
+module.  An independent module is a module which is not derived from
+or based on this library.  If you modify this library, you may extend
+this exception to your version of the library, but you are not
+obligated to do so.  If you do not wish to do so, delete this
+exception statement from your version. */
+
+
+package java.lang;
+
+/**
+ * Thrown when an attempt is made to cast an object which is not of the
+ * appropriate runtime type. For example:<br>
+ * <pre>
+ * Object o = new Vector();
+ * String s = (String) o;
+ * </pre>
+ *
+ * @author Brian Jones
+ * @author Warren Levy <warrenl@cygnus.com>
+ * @status updated to 1.4
+ */
+public class ClassCastException extends RuntimeException
+{
+  /**
+   * Compatible with JDK 1.0+.
+   */
+  private static final long serialVersionUID = -9223365651070458532L;
+
+  /**
+   * Create an exception without a message.
+   */
+  public ClassCastException()
+  {
+  }
+
+  /**
+   * Create an exception with a message.
+   *
+   * @param s the message
+   */
+  public ClassCastException(String s)
+  {
+    super(s);
+  }
+}
diff --git a/collects/profj/libs/java/lang/ClassCastException.ss b/collects/profj/libs/java/lang/ClassCastException.ss
new file mode 100644
index 0000000000..374b9a4b92
--- /dev/null
+++ b/collects/profj/libs/java/lang/ClassCastException.ss
@@ -0,0 +1,3 @@
+(module |ClassCastException| mzscheme
+  (require "Object-composite.ss")
+  (provide |ClassCastException|))
diff --git a/collects/profj/libs/java/lang/ClassNotFoundException.java b/collects/profj/libs/java/lang/ClassNotFoundException.java
new file mode 100644
index 0000000000..cb546602e5
--- /dev/null
+++ b/collects/profj/libs/java/lang/ClassNotFoundException.java
@@ -0,0 +1,125 @@
+/* ClassNotFoundException.java -- thrown when class definition cannot be found
+   Copyright (C) 1998, 2002 Free Software Foundation, Inc.
+
+This file is part of GNU Classpath.
+
+GNU Classpath is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU Classpath is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Classpath; see the file COPYING.  If not, write to the
+Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+02111-1307 USA.
+
+Linking this library statically or dynamically with other modules is
+making a combined work based on this library.  Thus, the terms and
+conditions of the GNU General Public License cover the whole
+combination.
+
+As a special exception, the copyright holders of this library give you
+permission to link this library with independent modules to produce an
+executable, regardless of the license terms of these independent
+modules, and to copy and distribute the resulting executable under
+terms of your choice, provided that you also meet, for each linked
+independent module, the terms and conditions of the license of that
+module.  An independent module is a module which is not derived from
+or based on this library.  If you modify this library, you may extend
+this exception to your version of the library, but you are not
+obligated to do so.  If you do not wish to do so, delete this
+exception statement from your version. */
+
+
+package java.lang;
+
+/**
+ * Thrown when a class is requested by reflection, but the class definition
+ * cannot be found. This exception is often chained from another Throwable.
+ *
+ * @author Brian Jones
+ * @author Eric Blake <ebb9@email.byu.edu>
+ * @see Class#forName(String)
+ * @see ClassLoader#findSystemClass(String)
+ * @see ClassLoader#loadClass(String, boolean)
+ * @status updated to 1.4
+ */
+public class ClassNotFoundException extends Exception
+{
+  /**
+   * Compatible with JDK 1.0+.
+   */
+  private static final long serialVersionUID = 9176873029745254542L;
+
+  /**
+   * The cause of this exception (duplicates the one stored in Throwable).
+   *
+   * @serial the exception cause
+   * @since 1.2
+   */
+  private final Throwable ex;
+
+  /**
+   * Create an exception without a message. Note that this initializes the
+   * cause to null.
+   */
+  public ClassNotFoundException()
+  {
+    this(null, null);
+  }
+
+  /**
+   * Create an exception with a message. Note that this initializes the
+   * cause to null.
+   *
+   * @param s the message
+   */
+  public ClassNotFoundException(String s)
+  {
+    this(s, null);
+  }
+
+  /**
+   * Create an exception with a message and chain it to the exception
+   * which occurred while loading the class.
+   *
+   * @param s the message
+   * @param ex the chained exception
+   * @since 1.2
+   */
+  public ClassNotFoundException(String s, Throwable ex)
+  {
+    super(s, ex);
+    this.ex = ex;
+  }
+
+  /**
+   * Returns the exception which occurred while loading the class,
+   * otherwise returns null. This is a legacy method; the preferred choice
+   * now is {@link Throwable#getCause()}.
+   *
+   * @return the cause of this exception
+   * @since 1.2
+   */
+  public Throwable getException()
+  {
+    return ex;
+  }
+
+  /**
+   * Returns the exception which occurred while loading the class,
+   * otherwise returns null.
+   *
+   * @return the cause of this exception
+   * @since 1.4
+   */
+  public Throwable getCause()
+  {
+    return ex;
+  }
+}
diff --git a/collects/profj/libs/java/lang/ClassNotFoundException.ss b/collects/profj/libs/java/lang/ClassNotFoundException.ss
new file mode 100644
index 0000000000..450915c05f
--- /dev/null
+++ b/collects/profj/libs/java/lang/ClassNotFoundException.ss
@@ -0,0 +1,3 @@
+(module |ClassNotFoundException| mzscheme
+  (require "Object-composite.ss")
+  (provide |ClassNotFoundException|))
diff --git a/collects/profj/libs/java/lang/CloneNotSupportedException.java b/collects/profj/libs/java/lang/CloneNotSupportedException.java
new file mode 100644
index 0000000000..e13112ac35
--- /dev/null
+++ b/collects/profj/libs/java/lang/CloneNotSupportedException.java
@@ -0,0 +1,92 @@
+/* CloneNotSupportedException.java -- thrown when an object cannot be cloned
+   Copyright (C) 1998, 1999, 2001, 2002 Free Software Foundation, Inc.
+
+This file is part of GNU Classpath.
+
+GNU Classpath is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU Classpath is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Classpath; see the file COPYING.  If not, write to the
+Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+02111-1307 USA.
+
+Linking this library statically or dynamically with other modules is
+making a combined work based on this library.  Thus, the terms and
+conditions of the GNU General Public License cover the whole
+combination.
+
+As a special exception, the copyright holders of this library give you
+permission to link this library with independent modules to produce an
+executable, regardless of the license terms of these independent
+modules, and to copy and distribute the resulting executable under
+terms of your choice, provided that you also meet, for each linked
+independent module, the terms and conditions of the license of that
+module.  An independent module is a module which is not derived from
+or based on this library.  If you modify this library, you may extend
+this exception to your version of the library, but you are not
+obligated to do so.  If you do not wish to do so, delete this
+exception statement from your version. */
+
+
+package java.lang;
+
+/**
+ * Thrown to indicate an object should not or could not be cloned. This
+ * includes the case when {@link Object#clone()} is called on an object
+ * which does not implement the {@link Cloneable} interface. For example:<br>
+ * <pre>
+ * void m() throws CloneNotSupportedException
+ * {
+ *   clone();
+ * }
+ * </pre>
+ *
+ * <p>Notice that calling <code>clone()</code> on an array will never produce
+ * this exception, as the VM will always succeed in copying the array, or
+ * cause an OutOfMemoryError first. For example:<br>
+ * <pre>
+ * void m(int[] array)
+ * {
+ *   int[] copy = (int[]) array.clone();
+ * }
+ * </pre>
+ *
+ * @author Brian Jones
+ * @author Warren Levy <warrenl@cygnus.com>
+ * @author Eric Blake <ebb9@email.byu.edu>
+ * @see Cloneable
+ * @see Object#clone()
+ * @status updated to 1.4
+ */
+public class CloneNotSupportedException extends Exception
+{
+  /**
+   * Compatible with JDK 1.0+.
+   */
+  private static final long serialVersionUID = 5195511250079656443L;
+
+  /**
+   * Create an exception without a message.
+   */
+  public CloneNotSupportedException()
+  {
+  }
+
+  /**
+   * Create an exception with a message.
+   *
+   * @param s the error message
+   */
+  public CloneNotSupportedException(String s)
+  {
+    super(s);
+  }
+}
diff --git a/collects/profj/libs/java/lang/CloneNotSupportedException.ss b/collects/profj/libs/java/lang/CloneNotSupportedException.ss
new file mode 100644
index 0000000000..46d81e6c46
--- /dev/null
+++ b/collects/profj/libs/java/lang/CloneNotSupportedException.ss
@@ -0,0 +1,3 @@
+(module |CloneNotSupportedException| mzscheme
+  (require "Object-composite.ss")
+  (provide |CloneNotSupportedException|))
diff --git a/collects/profj/libs/java/lang/Comparable.jinfo b/collects/profj/libs/java/lang/Comparable.jinfo
new file mode 100644
index 0000000000..69eb8a1a11
--- /dev/null
+++ b/collects/profj/libs/java/lang/Comparable.jinfo
@@ -0,0 +1,10 @@
+(interface
+  ("Comparable" "java" "lang")
+  (public)
+  #t
+  ()
+  (("compareTo" (public) int (("Object" "java" "lang")) () ("Comparable" "java" "lang")))
+  ()
+  ()
+  ()
+  "version1")
diff --git a/collects/profj/libs/java/lang/Comparable.ss b/collects/profj/libs/java/lang/Comparable.ss
new file mode 100644
index 0000000000..d50cc78cbd
--- /dev/null
+++ b/collects/profj/libs/java/lang/Comparable.ss
@@ -0,0 +1,5 @@
+#cs
+(module Comparable mzscheme
+  (require (lib "class.ss"))
+  (provide (all-defined))
+  (define Comparable (interface () compareTo-java.lang.Object)))
diff --git a/collects/profj/libs/java/lang/Double-native-methods.ss b/collects/profj/libs/java/lang/Double-native-methods.ss
new file mode 100644
index 0000000000..753ad3fb1e
--- /dev/null
+++ b/collects/profj/libs/java/lang/Double-native-methods.ss
@@ -0,0 +1,63 @@
+#cs
+(module Double-native-methods mzscheme
+  
+  (require (lib "class.ss"))
+  (require "Throwable.ss" "String.ss"
+           "NumberFormatException.ss" "NullPointerException.ss" "RuntimeException.ss")
+  
+  (provide (all-defined))
+  
+  (define (Double-parseDouble-java.lang.String-native s)
+    (when (null? s)
+      (raise (create-java-exception NullPointerException
+                                    "parseDouble expected to receive String, received null value"
+                                    (lambda (obj msg)
+                                      (send obj NullPointerException-constructor-java.lang.String msg))
+                                    (current-continuation-marks))))             
+    (let* ((scheme-string (send (send s trim) get-mzscheme-string))
+           (num (string->number scheme-string)))
+      (or num
+          (cond
+            ((equal? scheme-string "+NaN") +nan.0)
+            ((equal? scheme-string "-NaN") -nan.0)
+            ((equal? scheme-string "-Infinity") -inf.0)
+            ((equal? scheme-string "+Infinity") +inf.0)
+            (raise (create-java-exception NumberFormatException
+                                          (format "parseDouble given misformatted string ~a" scheme-string)
+                                          (lambda (obj msg)
+                                            (send obj NumberFormatException-constructor-java.lang.String msg))
+                                          (current-continuation-marks)))))))
+  
+  (define (Double-doubleToLongBits-double-native num) 
+    (raise (create-java-exception RuntimeException
+                                  "doubleToLongBits has not been written"
+                                  (lambda (obj msg)
+                                    (send obj RuntimeException-constructor-java.lang.String msg))
+                                  (current-continuation-marks))))
+    
+  (define (Double-doubleToRawLongBits-double-native num) 
+    (raise (create-java-exception RuntimeException
+                                  "doubleToRawLongBits has not been written"
+                                  (lambda (obj msg)
+                                    (send obj RuntimeException-constructor-java.lang.String msg))
+                                  (current-continuation-marks))))
+  
+  (define (Double-longBitsToDouble-long-native num) 
+    (raise (create-java-exception RuntimeException
+                                  "longBitsToDouble has not been written"
+                                  (lambda (obj msg)
+                                    (send obj RuntimeException-constructor-java.lang.String msg))
+                                  (current-continuation-marks))))
+  
+
+  (define (Double-toString-double-boolean-native num isFloat?)
+    (make-java-string (number->string num)))
+  
+  ;;Privates
+  (define (Double-initIDs-native) (void))
+  (define (Double-getNegInf-native) -inf.0)
+  (define (Double-getPosInf-native) +inf.0)
+  (define (Double-getNaN-native) +nan.0)
+  
+  )
+      
\ No newline at end of file
diff --git a/collects/profj/libs/java/lang/Double.java b/collects/profj/libs/java/lang/Double.java
new file mode 100644
index 0000000000..dcd1d4bafc
--- /dev/null
+++ b/collects/profj/libs/java/lang/Double.java
@@ -0,0 +1,550 @@
+/* Double.java -- object wrapper for double
+   Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003
+   Free Software Foundation, Inc.
+
+This file is part of GNU Classpath.
+
+GNU Classpath is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU Classpath is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Classpath; see the file COPYING.  If not, write to the
+Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+02111-1307 USA.
+
+Linking this library statically or dynamically with other modules is
+making a combined work based on this library.  Thus, the terms and
+conditions of the GNU General Public License cover the whole
+combination.
+
+As a special exception, the copyright holders of this library give you
+permission to link this library with independent modules to produce an
+executable, regardless of the license terms of these independent
+modules, and to copy and distribute the resulting executable under
+terms of your choice, provided that you also meet, for each linked
+independent module, the terms and conditions of the license of that
+module.  An independent module is a module which is not derived from
+or based on this library.  If you modify this library, you may extend
+this exception to your version of the library, but you are not
+obligated to do so.  If you do not wish to do so, delete this
+exception statement from your version. */
+
+package java.lang;
+
+//import gnu.classpath.Configuration;
+
+/**
+ * Instances of class <code>Double</code> represent primitive
+ * <code>double</code> values.
+ *
+ * Additionally, this class provides various helper functions and variables
+ * related to doubles.
+ *
+ * @author Paul Fisher
+ * @author Andrew Haley <aph@cygnus.com>
+ * @author Eric Blake <ebb9@email.byu.edu>
+ * @since 1.0
+ * @status updated to 1.4
+ */
+public final class Double extends Number implements Comparable
+{
+  /**
+   * Compatible with JDK 1.0+.
+   */
+  private static final long serialVersionUID = -9172774392245257468L;
+
+  /**
+   * The maximum positive value a <code>double</code> may represent
+   * is 1.7976931348623157e+308.
+   */
+  public static final double MAX_VALUE = 1.7976931348623157e+308;
+
+  /**
+   * The minimum positive value a <code>double</code> may represent
+   * is 5e-324.
+   */
+  public static final double MIN_VALUE = 5e-324;
+
+  /**
+   * The value of a double representation -1.0/0.0, negative
+   * infinity.
+   */
+  public static final double NEGATIVE_INFINITY =  getNegInf(); //-1.0 / 0.0;
+
+  /**
+   * The value of a double representing 1.0/0.0, positive infinity.
+   */
+  public static final double POSITIVE_INFINITY =  getPosInf(); //1.0 / 0.0;
+
+  /**
+   * All IEEE 754 values of NaN have the same value in Java.
+   */
+  public static final double NaN = getNaN(); //0.0 / 0.0;
+
+  private static native double getNegInf();
+  private static native double getPosInf();
+  private static native double getNaN();
+
+  /**
+   * The primitive type <code>double</code> is represented by this
+   * <code>Class</code> object.
+   * @since 1.1
+   */
+//  public static final Class TYPE = VMClassLoader.getPrimitiveClass('D');
+
+  /**
+   * The immutable value of this Double.
+   *
+   * @serial the wrapped double
+   */
+  private final double value;
+
+  /**
+   * Load native routines necessary for this class.
+   */
+/*  static
+  {
+    if (Configuration.INIT_LOAD_LIBRARY)
+      {
+	System.loadLibrary("javalang");
+	initIDs();
+      }
+  }
+*/
+  /**
+   * Create a <code>Double</code> from the primitive <code>double</code>
+   * specified.
+   *
+   * @param value the <code>double</code> argument
+   */
+  public Double(double value)
+  {
+    this.value = value;
+  }
+
+  /**
+   * Create a <code>Double</code> from the specified <code>String</code>.
+   * This method calls <code>Double.parseDouble()</code>.
+   *
+   * @param s the <code>String</code> to convert
+   * @throws NumberFormatException if <code>s</code> cannot be parsed as a
+   *         <code>double</code>
+   * @throws NullPointerException if <code>s</code> is null
+   * @see #parseDouble(String)
+   */
+  public Double(String s)
+  {
+    value = parseDouble(s);
+  }
+
+  /**
+   * Convert the <code>double</code> to a <code>String</code>.
+   * Floating-point string representation is fairly complex: here is a
+   * rundown of the possible values.  "<code>[-]</code>" indicates that a
+   * negative sign will be printed if the value (or exponent) is negative.
+   * "<code>&lt;number&gt;</code>" means a string of digits ('0' to '9').
+   * "<code>&lt;digit&gt;</code>" means a single digit ('0' to '9').<br>
+   *
+   * <table border=1>
+   * <tr><th>Value of Double</th><th>String Representation</th></tr>
+   * <tr><td>[+-] 0</td> <td><code>[-]0.0</code></td></tr>
+   * <tr><td>Between [+-] 10<sup>-3</sup> and 10<sup>7</sup>, exclusive</td>
+   *     <td><code>[-]number.number</code></td></tr>
+   * <tr><td>Other numeric value</td>
+   *     <td><code>[-]&lt;digit&gt;.&lt;number&gt;
+   *          E[-]&lt;number&gt;</code></td></tr>
+   * <tr><td>[+-] infinity</td> <td><code>[-]Infinity</code></td></tr>
+   * <tr><td>NaN</td> <td><code>NaN</code></td></tr>
+   * </table>
+   *
+   * Yes, negative zero <em>is</em> a possible value.  Note that there is
+   * <em>always</em> a <code>.</code> and at least one digit printed after
+   * it: even if the number is 3, it will be printed as <code>3.0</code>.
+   * After the ".", all digits will be printed except trailing zeros. The
+   * result is rounded to the shortest decimal number which will parse back
+   * to the same double.
+   *
+   * <p>To create other output formats, use {@link java.text.NumberFormat}.
+   *
+   * @XXX specify where we are not in accord with the spec.
+   *
+   * @param d the <code>double</code> to convert
+   * @return the <code>String</code> representing the <code>double</code>
+   */
+  public static String toString(double d)
+  {
+    return toString(d, false);
+  }
+
+  /**
+   * Create a new <code>Double</code> object using the <code>String</code>.
+   *
+   * @param s the <code>String</code> to convert
+   * @return the new <code>Double</code>
+   * @throws NumberFormatException if <code>s</code> cannot be parsed as a
+   *         <code>double</code>
+   * @throws NullPointerException if <code>s</code> is null.
+   * @see #parseDouble(String)
+   */
+  public static Double valueOf(String s)
+  {
+    return new Double(parseDouble(s));
+  }
+
+  /**
+   * Parse the specified <code>String</code> as a <code>double</code>. The
+   * extended BNF grammar is as follows:<br>
+   * <pre>
+   * <em>DecodableString</em>:
+   *      ( [ <code>-</code> | <code>+</code> ] <code>NaN</code> )
+   *    | ( [ <code>-</code> | <code>+</code> ] <code>Infinity</code> )
+   *    | ( [ <code>-</code> | <code>+</code> ] <em>FloatingPoint</em>
+   *              [ <code>f</code> | <code>F</code> | <code>d</code>
+   *                | <code>D</code>] )
+   * <em>FloatingPoint</em>:
+   *      ( { <em>Digit</em> }+ [ <code>.</code> { <em>Digit</em> } ]
+   *              [ <em>Exponent</em> ] )
+   *    | ( <code>.</code> { <em>Digit</em> }+ [ <em>Exponent</em> ] )
+   * <em>Exponent</em>:
+   *      ( ( <code>e</code> | <code>E</code> )
+   *              [ <code>-</code> | <code>+</code> ] { <em>Digit</em> }+ )
+   * <em>Digit</em>: <em><code>'0'</code> through <code>'9'</code></em>
+   * </pre>
+   *
+   * <p>NaN and infinity are special cases, to allow parsing of the output
+   * of toString.  Otherwise, the result is determined by calculating
+   * <em>n * 10<sup>exponent</sup></em> to infinite precision, then rounding
+   * to the nearest double. Remember that many numbers cannot be precisely
+   * represented in floating point. In case of overflow, infinity is used,
+   * and in case of underflow, signed zero is used. Unlike Integer.parseInt,
+   * this does not accept Unicode digits outside the ASCII range.
+   *
+   * <p>If an unexpected character is found in the <code>String</code>, a
+   * <code>NumberFormatException</code> will be thrown.  Leading and trailing
+   * 'whitespace' is ignored via <code>String.trim()</code>, but spaces
+   * internal to the actual number are not allowed.
+   *
+   * <p>To parse numbers according to another format, consider using
+   * {@link java.text.NumberFormat}.
+   *
+   * @XXX specify where/how we are not in accord with the spec.
+   *
+   * @param str the <code>String</code> to convert
+   * @return the <code>double</code> value of <code>s</code>
+   * @throws NumberFormatException if <code>s</code> cannot be parsed as a
+   *         <code>double</code>
+   * @throws NullPointerException if <code>s</code> is null
+   * @see #MIN_VALUE
+   * @see #MAX_VALUE
+   * @see #POSITIVE_INFINITY
+   * @see #NEGATIVE_INFINITY
+   * @since 1.2
+   */
+  public static native double parseDouble(String str);
+
+  /**
+   * Return <code>true</code> if the <code>double</code> has the same
+   * value as <code>NaN</code>, otherwise return <code>false</code>.
+   *
+   * @param v the <code>double</code> to compare
+   * @return whether the argument is <code>NaN</code>.
+   */
+  public static boolean isNaN(double v)
+  {
+    // This works since NaN != NaN is the only reflexive inequality
+    // comparison which returns true.
+    return v != v;
+  }
+
+  /**
+   * Return <code>true</code> if the <code>double</code> has a value
+   * equal to either <code>NEGATIVE_INFINITY</code> or
+   * <code>POSITIVE_INFINITY</code>, otherwise return <code>false</code>.
+   *
+   * @param v the <code>double</code> to compare
+   * @return whether the argument is (-/+) infinity.
+   */
+  public static boolean isInfinite(double v)
+  {
+    return v == POSITIVE_INFINITY || v == NEGATIVE_INFINITY;
+  }
+
+  /**
+   * Return <code>true</code> if the value of this <code>Double</code>
+   * is the same as <code>NaN</code>, otherwise return <code>false</code>.
+   *
+   * @return whether this <code>Double</code> is <code>NaN</code>
+   */
+  public boolean isNaN()
+  {
+    return isNaN(value);
+  }
+
+  /**
+   * Return <code>true</code> if the value of this <code>Double</code>
+   * is the same as <code>NEGATIVE_INFINITY</code> or
+   * <code>POSITIVE_INFINITY</code>, otherwise return <code>false</code>.
+   *
+   * @return whether this <code>Double</code> is (-/+) infinity
+   */
+  public boolean isInfinite()
+  {
+    return isInfinite(value);
+  }
+
+  /**
+   * Convert the <code>double</code> value of this <code>Double</code>
+   * to a <code>String</code>.  This method calls
+   * <code>Double.toString(double)</code> to do its dirty work.
+   *
+   * @return the <code>String</code> representation
+   * @see #toString(double)
+   */
+  public String toString()
+  {
+    return toString(value);
+  }
+
+  /**
+   * Return the value of this <code>Double</code> as a <code>byte</code>.
+   *
+   * @return the byte value
+   * @since 1.1
+   */
+  public byte byteValue()
+  {
+    return (byte) value;
+  }
+
+  /**
+   * Return the value of this <code>Double</code> as a <code>short</code>.
+   *
+   * @return the short value
+   * @since 1.1
+   */
+  public short shortValue()
+  {
+    return (short) value;
+  }
+
+  /**
+   * Return the value of this <code>Double</code> as an <code>int</code>.
+   *
+   * @return the int value
+   */
+  public int intValue()
+  {
+    return (int) value;
+  }
+
+  /**
+   * Return the value of this <code>Double</code> as a <code>long</code>.
+   *
+   * @return the long value
+   */
+  public long longValue()
+  {
+    return (long) value;
+  }
+
+  /**
+   * Return the value of this <code>Double</code> as a <code>float</code>.
+   *
+   * @return the float value
+   */
+  public float floatValue()
+  {
+    return (float) value;
+  }
+
+  /**
+   * Return the value of this <code>Double</code>.
+   *
+   * @return the double value
+   */
+  public double doubleValue()
+  {
+    return value;
+  }
+
+  /**
+   * Return a hashcode representing this Object. <code>Double</code>'s hash
+   * code is calculated by:<br>
+   * <code>long v = Double.doubleToLongBits(doubleValue());<br>
+   *    int hash = (int)(v^(v&gt;&gt;32))</code>.
+   *
+   * @return this Object's hash code
+   * @see #doubleToLongBits(double)
+   */
+  public int hashCode()
+  {
+    long v = doubleToLongBits(value);
+    return (int) (v ^ (v >>> 32));
+  }
+
+  /**
+   * Returns <code>true</code> if <code>obj</code> is an instance of
+   * <code>Double</code> and represents the same double value. Unlike comparing
+   * two doubles with <code>==</code>, this treats two instances of
+   * <code>Double.NaN</code> as equal, but treats <code>0.0</code> and
+   * <code>-0.0</code> as unequal.
+   *
+   * <p>Note that <code>d1.equals(d2)</code> is identical to
+   * <code>doubleToLongBits(d1.doubleValue()) ==
+   *    doubleToLongBits(d2.doubleValue())</code>.
+   *
+   * @param obj the object to compare
+   * @return whether the objects are semantically equal
+   */
+  public boolean equals(Object obj)
+  {
+    if (! (obj instanceof Double))
+      return false;
+
+    double d = ((Double) obj).value;
+
+    // Avoid call to native method. However, some implementations, like gcj,
+    // are better off using floatToIntBits(value) == floatToIntBits(f).
+    // Check common case first, then check NaN and 0.
+    if (value == d)
+      return (value != 0) || (1 / value == 1 / d);
+    return isNaN(value) && isNaN(d);
+  }
+
+  /**
+   * Convert the double to the IEEE 754 floating-point "double format" bit
+   * layout. Bit 63 (the most significant) is the sign bit, bits 62-52
+   * (masked by 0x7ff0000000000000L) represent the exponent, and bits 51-0
+   * (masked by 0x000fffffffffffffL) are the mantissa. This function
+   * collapses all versions of NaN to 0x7ff8000000000000L. The result of this
+   * function can be used as the argument to
+   * <code>Double.longBitsToDouble(long)</code> to obtain the original
+   * <code>double</code> value.
+   *
+   * @param value the <code>double</code> to convert
+   * @return the bits of the <code>double</code>
+   * @see #longBitsToDouble(long)
+   */
+  public static native long doubleToLongBits(double value);
+//  {
+//    return VMDouble.doubleToLongBits(value);
+//  }
+
+  /**
+   * Convert the double to the IEEE 754 floating-point "double format" bit
+   * layout. Bit 63 (the most significant) is the sign bit, bits 62-52
+   * (masked by 0x7ff0000000000000L) represent the exponent, and bits 51-0
+   * (masked by 0x000fffffffffffffL) are the mantissa. This function
+   * leaves NaN alone, rather than collapsing to a canonical value. The
+   * result of this function can be used as the argument to
+   * <code>Double.longBitsToDouble(long)</code> to obtain the original
+   * <code>double</code> value.
+   *
+   * @param value the <code>double</code> to convert
+   * @return the bits of the <code>double</code>
+   * @see #longBitsToDouble(long)
+   */
+  public static native long doubleToRawLongBits(double value);
+  //{
+  //  return VMDouble.doubleToRawLongBits(value);
+  //}
+
+  /**
+   * Convert the argument in IEEE 754 floating-point "double format" bit
+   * layout to the corresponding float. Bit 63 (the most significant) is the
+   * sign bit, bits 62-52 (masked by 0x7ff0000000000000L) represent the
+   * exponent, and bits 51-0 (masked by 0x000fffffffffffffL) are the mantissa.
+   * This function leaves NaN alone, so that you can recover the bit pattern
+   * with <code>Double.doubleToRawLongBits(double)</code>.
+   *
+   * @param bits the bits to convert
+   * @return the <code>double</code> represented by the bits
+   * @see #doubleToLongBits(double)
+   * @see #doubleToRawLongBits(double)
+   */
+  public static native double longBitsToDouble(long bits);
+//  {
+//    return VMDouble.longBitsToDouble(bits);
+//  }
+
+  /**
+   * Compare two Doubles numerically by comparing their <code>double</code>
+   * values. The result is positive if the first is greater, negative if the
+   * second is greater, and 0 if the two are equal. However, this special
+   * cases NaN and signed zero as follows: NaN is considered greater than
+   * all other doubles, including <code>POSITIVE_INFINITY</code>, and positive
+   * zero is considered greater than negative zero.
+   *
+   * @param d the Double to compare
+   * @return the comparison
+   * @since 1.2
+   */
+  public int compareTo(Double d)
+  {
+    return compare(value, d.value);
+  }
+
+  /**
+   * Behaves like <code>compareTo(Double)</code> unless the Object
+   * is not an <code>Double</code>.
+   *
+   * @param o the object to compare
+   * @return the comparison
+   * @throws ClassCastException if the argument is not a <code>Double</code>
+   * @see #compareTo(Double)
+   * @see Comparable
+   * @since 1.2
+   */
+  public int compareTo(Object o)
+  {
+    return compare(value, ((Double) o).value);
+  }
+
+  /**
+   * Behaves like <code>new Double(x).compareTo(new Double(y))</code>; in
+   * other words this compares two doubles, special casing NaN and zero,
+   * without the overhead of objects.
+   *
+   * @param x the first double to compare
+   * @param y the second double to compare
+   * @return the comparison
+   * @since 1.4
+   */
+  public static int compare(double x, double y)
+  {
+    if (isNaN(x))
+      return isNaN(y) ? 0 : 1;
+    if (isNaN(y))
+      return -1;
+    // recall that 0.0 == -0.0, so we convert to infinites and try again
+    if (x == 0 && y == 0)
+      return (int) (1 / x - 1 / y);
+    if (x == y)
+      return 0;
+
+    return x > y ? 1 : -1;
+  }
+
+  /**
+   * Helper method to convert to string.
+   *
+   * @param d the double to convert
+   * @param isFloat true if the conversion is requested by Float (results in
+   *        fewer digits)
+   */
+  // Package visible for use by Float.
+  static native String toString(double d, boolean isFloat);
+
+  /**
+   * Initialize JNI cache.  This method is called only by the
+   * static initializer when using JNI.
+   */
+  private static native void initIDs();
+}
diff --git a/collects/profj/libs/java/lang/Exception.java b/collects/profj/libs/java/lang/Exception.java
new file mode 100644
index 0000000000..edf5de228c
--- /dev/null
+++ b/collects/profj/libs/java/lang/Exception.java
@@ -0,0 +1,104 @@
+/* Exception.java -- generic exception thrown to indicate an exceptional
+   condition has occurred.
+   Copyright (C) 1998, 1999, 2001, 2002 Free Software Foundation, Inc.
+
+This file is part of GNU Classpath.
+
+GNU Classpath is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU Classpath is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Classpath; see the file COPYING.  If not, write to the
+Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+02111-1307 USA.
+
+Linking this library statically or dynamically with other modules is
+making a combined work based on this library.  Thus, the terms and
+conditions of the GNU General Public License cover the whole
+combination.
+
+As a special exception, the copyright holders of this library give you
+permission to link this library with independent modules to produce an
+executable, regardless of the license terms of these independent
+modules, and to copy and distribute the resulting executable under
+terms of your choice, provided that you also meet, for each linked
+independent module, the terms and conditions of the license of that
+module.  An independent module is a module which is not derived from
+or based on this library.  If you modify this library, you may extend
+this exception to your version of the library, but you are not
+obligated to do so.  If you do not wish to do so, delete this
+exception statement from your version. */
+
+
+package java.lang;
+
+/**
+ * The root class of all exceptions worth catching in a program.  This
+ * includes the special category of <code>RuntimeException</code>, which
+ * does not need to be declared in a throws clause.  Exceptions can be used
+ * to represent almost any exceptional behavior, such as programming errors,
+ * mouse movements, keyboard clicking, etc.
+ *
+ * @author Brian Jones
+ * @author Warren Levy <warrenl@cygnus.com>
+ * @author Eric Blake <ebb9@email.byu.edu>
+ * @status updated to 1.4
+ */
+public class Exception extends Throwable
+{
+  /**
+   * Compatible with JDK 1.0+.
+   */
+  private static final long serialVersionUID = -3387516993124229948L;
+
+  /**
+   * Create an exception without a message. The cause remains uninitialized.
+   *
+   * @see #initCause(Throwable)
+   */
+  public Exception()
+  {
+  }
+
+  /**
+   * Create an exception with a message. The cause remains uninitialized.
+   *
+   * @param s the message
+   * @see #initCause(Throwable)
+   */
+  public Exception(String s)
+  {
+    super(s);
+  }
+
+  /**
+   * Create an exception with a message and a cause.
+   *
+   * @param s the message string
+   * @param cause the cause of this error
+   * @since 1.4
+   */
+  public Exception(String s, Throwable cause)
+  {
+    super(s, cause);
+  }
+
+  /**
+   * Create an exception with a given cause, and a message of
+   * <code>cause == null ? null : cause.toString()</code>.
+   *
+   * @param cause the cause of this exception
+   * @since 1.4
+   */
+  public Exception(Throwable cause)
+  {
+    super(cause);
+  }
+}
diff --git a/collects/profj/libs/java/lang/Exception.ss b/collects/profj/libs/java/lang/Exception.ss
new file mode 100644
index 0000000000..9dfce4283d
--- /dev/null
+++ b/collects/profj/libs/java/lang/Exception.ss
@@ -0,0 +1,3 @@
+(module |Exception| mzscheme
+  (require "Object-composite.ss")
+  (provide |Exception|))
diff --git a/collects/profj/libs/java/lang/Float.java b/collects/profj/libs/java/lang/Float.java
new file mode 100644
index 0000000000..8f42b6f914
--- /dev/null
+++ b/collects/profj/libs/java/lang/Float.java
@@ -0,0 +1,530 @@
+/* Float.java -- object wrapper for float
+   Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003
+   Free Software Foundation, Inc.
+
+This file is part of GNU Classpath.
+
+GNU Classpath is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU Classpath is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Classpath; see the file COPYING.  If not, write to the
+Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+02111-1307 USA.
+
+Linking this library statically or dynamically with other modules is
+making a combined work based on this library.  Thus, the terms and
+conditions of the GNU General Public License cover the whole
+combination.
+
+As a special exception, the copyright holders of this library give you
+permission to link this library with independent modules to produce an
+executable, regardless of the license terms of these independent
+modules, and to copy and distribute the resulting executable under
+terms of your choice, provided that you also meet, for each linked
+independent module, the terms and conditions of the license of that
+module.  An independent module is a module which is not derived from
+or based on this library.  If you modify this library, you may extend
+this exception to your version of the library, but you are not
+obligated to do so.  If you do not wish to do so, delete this
+exception statement from your version. */
+
+
+package java.lang;
+
+/**
+ * Instances of class <code>Float</code> represent primitive
+ * <code>float</code> values.
+ *
+ * Additionally, this class provides various helper functions and variables
+ * related to floats.
+ *
+ * @author Paul Fisher
+ * @author Andrew Haley <aph@cygnus.com>
+ * @author Eric Blake <ebb9@email.byu.edu>
+ * @since 1.0
+ * @status updated to 1.4
+ */
+public final class Float extends Number implements Comparable
+{
+  /**
+   * Compatible with JDK 1.0+.
+   */
+  private static final long serialVersionUID = -2671257302660747028L;
+
+  /**
+   * The maximum positive value a <code>double</code> may represent
+   * is 3.4028235e+38f.
+   */
+  public static final float MAX_VALUE = 3.4028235e+38f;
+
+  /**
+   * The minimum positive value a <code>float</code> may represent
+   * is 1.4e-45.
+   */
+  public static final float MIN_VALUE = 1.4e-45f;
+
+  /**
+   * The value of a float representation -1.0/0.0, negative infinity.
+   */
+  public static final float NEGATIVE_INFINITY = (float) Double.NEGATIVE_INFINITY;//-1.0f / 0.0f;
+
+  /**
+   * The value of a float representation 1.0/0.0, positive infinity.
+   */
+  public static final float POSITIVE_INFINITY = (float) Double.POSITIVE_INFINITY;//1.0f / 0.0f;
+
+  /**
+   * All IEEE 754 values of NaN have the same value in Java.
+   */
+  public static final float NaN = (float) Double.NaN;//0.0f / 0.0f;
+
+  /**
+   * The primitive type <code>float</code> is represented by this
+   * <code>Class</code> object.
+   * @since 1.1
+   */
+  //public static final Class TYPE = VMClassLoader.getPrimitiveClass('F');
+
+  /**
+   * The immutable value of this Float.
+   *
+   * @serial the wrapped float
+   */
+  private final float value;
+
+  /**
+   * Create a <code>Float</code> from the primitive <code>float</code>
+   * specified.
+   *
+   * @param value the <code>float</code> argument
+   */
+  public Float(float value)
+  {
+    this.value = value;
+  }
+
+  /**
+   * Create a <code>Float</code> from the primitive <code>double</code>
+   * specified.
+   *
+   * @param value the <code>double</code> argument
+   */
+  public Float(double value)
+  {
+    this.value = (float) value;
+  }
+
+  /**
+   * Create a <code>Float</code> from the specified <code>String</code>.
+   * This method calls <code>Float.parseFloat()</code>.
+   *
+   * @param s the <code>String</code> to convert
+   * @throws NumberFormatException if <code>s</code> cannot be parsed as a
+   *         <code>float</code>
+   * @throws NullPointerException if <code>s</code> is null
+   * @see #parseFloat(String)
+   */
+  public Float(String s)
+  {
+    value = parseFloat(s);
+  }
+
+  /**
+   * Convert the <code>float</code> to a <code>String</code>.
+   * Floating-point string representation is fairly complex: here is a
+   * rundown of the possible values.  "<code>[-]</code>" indicates that a
+   * negative sign will be printed if the value (or exponent) is negative.
+   * "<code>&lt;number&gt;</code>" means a string of digits ('0' to '9').
+   * "<code>&lt;digit&gt;</code>" means a single digit ('0' to '9').<br>
+   *
+   * <table border=1>
+   * <tr><th>Value of Float</th><th>String Representation</th></tr>
+   * <tr><td>[+-] 0</td> <td><code>[-]0.0</code></td></tr>
+   * <tr><td>Between [+-] 10<sup>-3</sup> and 10<sup>7</sup>, exclusive</td>
+   *     <td><code>[-]number.number</code></td></tr>
+   * <tr><td>Other numeric value</td>
+   *     <td><code>[-]&lt;digit&gt;.&lt;number&gt;
+   *          E[-]&lt;number&gt;</code></td></tr>
+   * <tr><td>[+-] infinity</td> <td><code>[-]Infinity</code></td></tr>
+   * <tr><td>NaN</td> <td><code>NaN</code></td></tr>
+   * </table>
+   *
+   * Yes, negative zero <em>is</em> a possible value.  Note that there is
+   * <em>always</em> a <code>.</code> and at least one digit printed after
+   * it: even if the number is 3, it will be printed as <code>3.0</code>.
+   * After the ".", all digits will be printed except trailing zeros. The
+   * result is rounded to the shortest decimal number which will parse back
+   * to the same float.
+   *
+   * <p>To create other output formats, use {@link java.text.NumberFormat}.
+   *
+   * @XXX specify where we are not in accord with the spec.
+   *
+   * @param f the <code>float</code> to convert
+   * @return the <code>String</code> representing the <code>float</code>
+   */
+  public static String toString(float f)
+  {
+    return Double.toString(f, true);
+  }
+
+  /**
+   * Creates a new <code>Float</code> object using the <code>String</code>.
+   *
+   * @param s the <code>String</code> to convert
+   * @return the new <code>Float</code>
+   * @throws NumberFormatException if <code>s</code> cannot be parsed as a
+   *         <code>float</code>
+   * @throws NullPointerException if <code>s</code> is null
+   * @see #parseFloat(String)
+   */
+  public static Float valueOf(String s)
+  {
+    return new Float(parseFloat(s));
+  }
+
+  /**
+   * Parse the specified <code>String</code> as a <code>float</code>. The
+   * extended BNF grammar is as follows:<br>
+   * <pre>
+   * <em>DecodableString</em>:
+   *      ( [ <code>-</code> | <code>+</code> ] <code>NaN</code> )
+   *    | ( [ <code>-</code> | <code>+</code> ] <code>Infinity</code> )
+   *    | ( [ <code>-</code> | <code>+</code> ] <em>FloatingPoint</em>
+   *              [ <code>f</code> | <code>F</code> | <code>d</code>
+   *                | <code>D</code>] )
+   * <em>FloatingPoint</em>:
+   *      ( { <em>Digit</em> }+ [ <code>.</code> { <em>Digit</em> } ]
+   *              [ <em>Exponent</em> ] )
+   *    | ( <code>.</code> { <em>Digit</em> }+ [ <em>Exponent</em> ] )
+   * <em>Exponent</em>:
+   *      ( ( <code>e</code> | <code>E</code> )
+   *              [ <code>-</code> | <code>+</code> ] { <em>Digit</em> }+ )
+   * <em>Digit</em>: <em><code>'0'</code> through <code>'9'</code></em>
+   * </pre>
+   *
+   * <p>NaN and infinity are special cases, to allow parsing of the output
+   * of toString.  Otherwise, the result is determined by calculating
+   * <em>n * 10<sup>exponent</sup></em> to infinite precision, then rounding
+   * to the nearest float. Remember that many numbers cannot be precisely
+   * represented in floating point. In case of overflow, infinity is used,
+   * and in case of underflow, signed zero is used. Unlike Integer.parseInt,
+   * this does not accept Unicode digits outside the ASCII range.
+   *
+   * <p>If an unexpected character is found in the <code>String</code>, a
+   * <code>NumberFormatException</code> will be thrown.  Leading and trailing
+   * 'whitespace' is ignored via <code>String.trim()</code>, but spaces
+   * internal to the actual number are not allowed.
+   *
+   * <p>To parse numbers according to another format, consider using
+   * {@link java.text.NumberFormat}.
+   *
+   * @XXX specify where/how we are not in accord with the spec.
+   *
+   * @param str the <code>String</code> to convert
+   * @return the <code>float</code> value of <code>s</code>
+   * @throws NumberFormatException if <code>s</code> cannot be parsed as a
+   *         <code>float</code>
+   * @throws NullPointerException if <code>s</code> is null
+   * @see #MIN_VALUE
+   * @see #MAX_VALUE
+   * @see #POSITIVE_INFINITY
+   * @see #NEGATIVE_INFINITY
+   * @since 1.2
+   */
+  public static float parseFloat(String str)
+  {
+    // XXX Rounding parseDouble() causes some errors greater than 1 ulp from
+    // the infinitely precise decimal.
+    return (float) Double.parseDouble(str);
+  }
+
+  /**
+   * Return <code>true</code> if the <code>float</code> has the same
+   * value as <code>NaN</code>, otherwise return <code>false</code>.
+   *
+   * @param v the <code>float</code> to compare
+   * @return whether the argument is <code>NaN</code>
+   */
+  public static boolean isNaN(float v)
+  {
+    // This works since NaN != NaN is the only reflexive inequality
+    // comparison which returns true.
+    return v != v;
+  }
+
+  /**
+   * Return <code>true</code> if the <code>float</code> has a value
+   * equal to either <code>NEGATIVE_INFINITY</code> or
+   * <code>POSITIVE_INFINITY</code>, otherwise return <code>false</code>.
+   *
+   * @param v the <code>float</code> to compare
+   * @return whether the argument is (-/+) infinity
+   */
+  public static boolean isInfinite(float v)
+  {
+    return v == POSITIVE_INFINITY || v == NEGATIVE_INFINITY;
+  }
+
+  /**
+   * Return <code>true</code> if the value of this <code>Float</code>
+   * is the same as <code>NaN</code>, otherwise return <code>false</code>.
+   *
+   * @return whether this <code>Float</code> is <code>NaN</code>
+   */
+  public boolean isNaN()
+  {
+    return isNaN(value);
+  }
+
+  /**
+   * Return <code>true</code> if the value of this <code>Float</code>
+   * is the same as <code>NEGATIVE_INFINITY</code> or
+   * <code>POSITIVE_INFINITY</code>, otherwise return <code>false</code>.
+   *
+   * @return whether this <code>Float</code> is (-/+) infinity
+   */
+  public boolean isInfinite()
+  {
+    return isInfinite(value);
+  }
+
+  /**
+   * Convert the <code>float</code> value of this <code>Float</code>
+   * to a <code>String</code>.  This method calls
+   * <code>Float.toString(float)</code> to do its dirty work.
+   *
+   * @return the <code>String</code> representation
+   * @see #toString(float)
+   */
+  public String toString()
+  {
+    return toString(value);
+  }
+
+  /**
+   * Return the value of this <code>Float</code> as a <code>byte</code>.
+   *
+   * @return the byte value
+   * @since 1.1
+   */
+  public byte byteValue()
+  {
+    return (byte) value;
+  }
+
+  /**
+   * Return the value of this <code>Float</code> as a <code>short</code>.
+   *
+   * @return the short value
+   * @since 1.1
+   */
+  public short shortValue()
+  {
+    return (short) value;
+  }
+
+  /**
+   * Return the value of this <code>Integer</code> as an <code>int</code>.
+   *
+   * @return the int value
+   */
+  public int intValue()
+  {
+    return (int) value;
+  }
+
+  /**
+   * Return the value of this <code>Integer</code> as a <code>long</code>.
+   *
+   * @return the long value
+   */
+  public long longValue()
+  {
+    return (long) value;
+  }
+
+  /**
+   * Return the value of this <code>Float</code>.
+   *
+   * @return the float value
+   */
+  public float floatValue()
+  {
+    return value;
+  }
+
+  /**
+   * Return the value of this <code>Float</code> as a <code>double</code>
+   *
+   * @return the double value
+   */
+  public double doubleValue()
+  {
+    return value;
+  }
+
+  /**
+   * Return a hashcode representing this Object. <code>Float</code>'s hash
+   * code is calculated by calling <code>floatToIntBits(floatValue())</code>.
+   *
+   * @return this Object's hash code
+   * @see #floatToIntBits(float)
+   */
+  public int hashCode()
+  {
+    return floatToIntBits(value);
+  }
+
+  /**
+   * Returns <code>true</code> if <code>obj</code> is an instance of
+   * <code>Float</code> and represents the same float value. Unlike comparing
+   * two floats with <code>==</code>, this treats two instances of
+   * <code>Float.NaN</code> as equal, but treats <code>0.0</code> and
+   * <code>-0.0</code> as unequal.
+   *
+   * <p>Note that <code>f1.equals(f2)</code> is identical to
+   * <code>floatToIntBits(f1.floatValue()) ==
+   *    floatToIntBits(f2.floatValue())</code>.
+   *
+   * @param obj the object to compare
+   * @return whether the objects are semantically equal
+   */
+  public boolean equals(Object obj)
+  {
+    if (! (obj instanceof Float))
+      return false;
+
+    float f = ((Float) obj).value;
+
+    // Avoid call to native method. However, some implementations, like gcj,
+    // are better off using floatToIntBits(value) == floatToIntBits(f).
+    // Check common case first, then check NaN and 0.
+    if (value == f)
+      return (value != 0) || (1 / value == 1 / f);
+    return isNaN(value) && isNaN(f);
+  }
+
+  /**
+   * Convert the float to the IEEE 754 floating-point "single format" bit
+   * layout. Bit 31 (the most significant) is the sign bit, bits 30-23
+   * (masked by 0x7f800000) represent the exponent, and bits 22-0
+   * (masked by 0x007fffff) are the mantissa. This function collapses all
+   * versions of NaN to 0x7fc00000. The result of this function can be used
+   * as the argument to <code>Float.intBitsToFloat(int)</code> to obtain the
+   * original <code>float</code> value.
+   *
+   * @param value the <code>float</code> to convert
+   * @return the bits of the <code>float</code>
+   * @see #intBitsToFloat(int)
+   */
+  public static int floatToIntBits(float value)
+  {
+      throw new RuntimeException("floatToIntBits has not been implemented");
+//    return VMFloat.floatToIntBits(value);
+  }
+
+  /**
+   * Convert the float to the IEEE 754 floating-point "single format" bit
+   * layout. Bit 31 (the most significant) is the sign bit, bits 30-23
+   * (masked by 0x7f800000) represent the exponent, and bits 22-0
+   * (masked by 0x007fffff) are the mantissa. This function leaves NaN alone,
+   * rather than collapsing to a canonical value. The result of this function
+   * can be used as the argument to <code>Float.intBitsToFloat(int)</code> to
+   * obtain the original <code>float</code> value.
+   *
+   * @param value the <code>float</code> to convert
+   * @return the bits of the <code>float</code>
+   * @see #intBitsToFloat(int)
+   */
+  public static int floatToRawIntBits(float value)
+  {
+      throw new RuntimeException("floatToRawIntBits has not been implemented");
+//    return VMFloat.floatToRawIntBits(value);
+  }
+
+  /**
+   * Convert the argument in IEEE 754 floating-point "single format" bit
+   * layout to the corresponding float. Bit 31 (the most significant) is the
+   * sign bit, bits 30-23 (masked by 0x7f800000) represent the exponent, and
+   * bits 22-0 (masked by 0x007fffff) are the mantissa. This function leaves
+   * NaN alone, so that you can recover the bit pattern with
+   * <code>Float.floatToRawIntBits(float)</code>.
+   *
+   * @param bits the bits to convert
+   * @return the <code>float</code> represented by the bits
+   * @see #floatToIntBits(float)
+   * @see #floatToRawIntBits(float)
+   */
+  public static float intBitsToFloat(int bits)
+  {
+      throw new RuntimeException("intBitsToFloat has not been implmented");
+//    return VMFloat.intBitsToFloat(bits);
+  }
+
+  /**
+   * Compare two Floats numerically by comparing their <code>float</code>
+   * values. The result is positive if the first is greater, negative if the
+   * second is greater, and 0 if the two are equal. However, this special
+   * cases NaN and signed zero as follows: NaN is considered greater than
+   * all other floats, including <code>POSITIVE_INFINITY</code>, and positive
+   * zero is considered greater than negative zero.
+   *
+   * @param f the Float to compare
+   * @return the comparison
+   * @since 1.2
+   */
+  public int compareTo(Float f)
+  {
+    return compare(value, f.value);
+  }
+
+  /**
+   * Behaves like <code>compareTo(Float)</code> unless the Object
+   * is not an <code>Float</code>.
+   *
+   * @param o the object to compare
+   * @return the comparison
+   * @throws ClassCastException if the argument is not a <code>Float</code>
+   * @see #compareTo(Float)
+   * @see Comparable
+   * @since 1.2
+   */
+  public int compareTo(Object o)
+  {
+    return compare(value, ((Float) o).value);
+  }
+
+  /**
+   * Behaves like <code>new Float(x).compareTo(new Float(y))</code>; in
+   * other words this compares two floats, special casing NaN and zero,
+   * without the overhead of objects.
+   *
+   * @param x the first float to compare
+   * @param y the second float to compare
+   * @return the comparison
+   * @since 1.4
+   */
+  public static int compare(float x, float y)
+  {
+    if (isNaN(x))
+      return isNaN(y) ? 0 : 1;
+    if (isNaN(y))
+      return -1;
+    // recall that 0.0 == -0.0, so we convert to infinities and try again
+    if (x == 0 && y == 0)
+      return (int) (1 / x - 1 / y);
+    if (x == y)
+      return 0;
+
+    return x > y ? 1 : -1;
+  }
+}
diff --git a/collects/profj/libs/java/lang/IllegalAccessException.java b/collects/profj/libs/java/lang/IllegalAccessException.java
new file mode 100644
index 0000000000..f6fc8f67e9
--- /dev/null
+++ b/collects/profj/libs/java/lang/IllegalAccessException.java
@@ -0,0 +1,95 @@
+/* IllegalAccessException.java -- thrown on attempt to reflect on
+   inaccessible data
+   Copyright (C) 1998, 1999, 2001, 2002 Free Software Foundation, Inc.
+
+This file is part of GNU Classpath.
+
+GNU Classpath is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU Classpath is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Classpath; see the file COPYING.  If not, write to the
+Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+02111-1307 USA.
+
+Linking this library statically or dynamically with other modules is
+making a combined work based on this library.  Thus, the terms and
+conditions of the GNU General Public License cover the whole
+combination.
+
+As a special exception, the copyright holders of this library give you
+permission to link this library with independent modules to produce an
+executable, regardless of the license terms of these independent
+modules, and to copy and distribute the resulting executable under
+terms of your choice, provided that you also meet, for each linked
+independent module, the terms and conditions of the license of that
+module.  An independent module is a module which is not derived from
+or based on this library.  If you modify this library, you may extend
+this exception to your version of the library, but you are not
+obligated to do so.  If you do not wish to do so, delete this
+exception statement from your version. */
+
+
+package java.lang;
+
+/**
+ * Thrown whenever a reflective method tries to do something that the
+ * compiler would not allow.  For example, using reflection to set a private
+ * variable that belongs to a class in another package is bad.
+ *
+ * @author Brian Jones
+ * @author Warren Levy <warrenl@cygnus.com>
+ * @see Class#newInstance()
+ * @see Field#set(Object, Object)
+ * @see Field#setBoolean(Object, boolean)
+ * @see Field#setByte(Object, byte)
+ * @see Field#setShort(Object, short)
+ * @see Field#setChar(Object, char)
+ * @see Field#setInt(Object, int)
+ * @see Field#setLong(Object, long)
+ * @see Field#setFloat(Object, float)
+ * @see Field#setDouble(Object, double)
+ * @see Field#get(Object)
+ * @see Field#getBoolean(Object)
+ * @see Field#getByte(Object)
+ * @see Field#getShort(Object)
+ * @see Field#getChar(Object)
+ * @see Field#getInt(Object)
+ * @see Field#getLong(Object)
+ * @see Field#getFloat(Object)
+ * @see Field#getDouble(Object)
+ * @see Method#invoke(Object, Object[])
+ * @see Constructor#newInstance(Object[])
+ * @status updated to 1.4
+ */
+public class IllegalAccessException extends Exception
+{
+  /**
+   * Compatible with JDK 1.0+.
+   */
+  private static final long serialVersionUID = 6616958222490762034L;
+
+  /**
+   * Create an exception without a message.
+   */
+  public IllegalAccessException()
+  {
+  }
+
+  /**
+   * Create an exception with a message.
+   *
+   * @param s the message
+   */
+  public IllegalAccessException(String s)
+  {
+    super(s);
+  }
+}
diff --git a/collects/profj/libs/java/lang/IllegalAccessException.ss b/collects/profj/libs/java/lang/IllegalAccessException.ss
new file mode 100644
index 0000000000..5c7571e39a
--- /dev/null
+++ b/collects/profj/libs/java/lang/IllegalAccessException.ss
@@ -0,0 +1,3 @@
+(module |IllegalAccessException| mzscheme
+  (require "Object-composite.ss")
+  (provide |IllegalAccessException|))
diff --git a/collects/profj/libs/java/lang/IllegalArgumentException.java b/collects/profj/libs/java/lang/IllegalArgumentException.java
new file mode 100644
index 0000000000..deb6735c89
--- /dev/null
+++ b/collects/profj/libs/java/lang/IllegalArgumentException.java
@@ -0,0 +1,75 @@
+/* IllegalArgumentException.java -- thrown when a method is passed an
+   illegal or inappropriate argument
+   Copyright (C) 1998, 1999, 2001, 2002 Free Software Foundation, Inc.
+
+This file is part of GNU Classpath.
+
+GNU Classpath is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU Classpath is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Classpath; see the file COPYING.  If not, write to the
+Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+02111-1307 USA.
+
+Linking this library statically or dynamically with other modules is
+making a combined work based on this library.  Thus, the terms and
+conditions of the GNU General Public License cover the whole
+combination.
+
+As a special exception, the copyright holders of this library give you
+permission to link this library with independent modules to produce an
+executable, regardless of the license terms of these independent
+modules, and to copy and distribute the resulting executable under
+terms of your choice, provided that you also meet, for each linked
+independent module, the terms and conditions of the license of that
+module.  An independent module is a module which is not derived from
+or based on this library.  If you modify this library, you may extend
+this exception to your version of the library, but you are not
+obligated to do so.  If you do not wish to do so, delete this
+exception statement from your version. */
+
+package java.lang;
+
+/**
+ * Thrown when a method is passed an illegal or inappropriate argument. For
+ * example:<br>
+ * <pre>
+ * wait(-1);
+ * </pre>
+ *
+ * @author Brian Jones
+ * @author Warren Levy <warrenl@cygnus.com>
+ * @status updated to 1.4
+ */
+public class IllegalArgumentException extends RuntimeException
+{
+  /**
+   * Compatible with JDK 1.0+.
+   */
+  private static final long serialVersionUID = -5365630128856068164L;
+
+  /**
+   * Create an exception without a message.
+   */
+  public IllegalArgumentException()
+  {
+  }
+
+  /**
+   * Create an exception with a message.
+   *
+   * @param s the message
+   */
+  public IllegalArgumentException(String s)
+  {
+    super(s);
+  }
+}
diff --git a/collects/profj/libs/java/lang/IllegalArgumentException.ss b/collects/profj/libs/java/lang/IllegalArgumentException.ss
new file mode 100644
index 0000000000..01156d1bd9
--- /dev/null
+++ b/collects/profj/libs/java/lang/IllegalArgumentException.ss
@@ -0,0 +1,3 @@
+(module |IllegalArgumentException| mzscheme
+  (require "Object-composite.ss")
+  (provide |IllegalArgumentException|))
diff --git a/collects/profj/libs/java/lang/IllegalMonitorStateException.java b/collects/profj/libs/java/lang/IllegalMonitorStateException.java
new file mode 100644
index 0000000000..08e1ba7a1e
--- /dev/null
+++ b/collects/profj/libs/java/lang/IllegalMonitorStateException.java
@@ -0,0 +1,78 @@
+/* IllegalMonitorStateException.java -- thrown when trying to wait or
+   notify a monitor that is not owned
+   Copyright (C) 1998, 1999, 2001, 2002 Free Software Foundation, Inc.
+
+This file is part of GNU Classpath.
+
+GNU Classpath is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU Classpath is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Classpath; see the file COPYING.  If not, write to the
+Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+02111-1307 USA.
+
+Linking this library statically or dynamically with other modules is
+making a combined work based on this library.  Thus, the terms and
+conditions of the GNU General Public License cover the whole
+combination.
+
+As a special exception, the copyright holders of this library give you
+permission to link this library with independent modules to produce an
+executable, regardless of the license terms of these independent
+modules, and to copy and distribute the resulting executable under
+terms of your choice, provided that you also meet, for each linked
+independent module, the terms and conditions of the license of that
+module.  An independent module is a module which is not derived from
+or based on this library.  If you modify this library, you may extend
+this exception to your version of the library, but you are not
+obligated to do so.  If you do not wish to do so, delete this
+exception statement from your version. */
+
+
+package java.lang;
+
+/**
+ * Thrown when a thread attempts to wait or notify on a monitor that it
+ * does not own (ie. it has not synchronized on the object). For example:<br>
+ * <pre>
+ * void m() {
+ *   notify();
+ * }
+ * </pre>
+ *
+ * @author Brian Jones
+ * @author Warren Levy <warrenl@cygnus.com>
+ * @status updated to 1.4
+ */
+public class IllegalMonitorStateException extends RuntimeException
+{
+  /**
+   * Compatible with JDK 1.0+.
+   */
+  private static final long serialVersionUID = 3713306369498869069L;
+
+  /**
+   * Create an exception without a message.
+   */
+  public IllegalMonitorStateException()
+  {
+  }
+
+  /**
+   * Create an exception with a message.
+   *
+   * @param s the message
+   */
+  public IllegalMonitorStateException(String s)
+  {
+    super(s);
+  }
+}
diff --git a/collects/profj/libs/java/lang/IllegalMonitorStateException.ss b/collects/profj/libs/java/lang/IllegalMonitorStateException.ss
new file mode 100644
index 0000000000..bebea04583
--- /dev/null
+++ b/collects/profj/libs/java/lang/IllegalMonitorStateException.ss
@@ -0,0 +1,3 @@
+(module |IllegalMonitorStateException| mzscheme
+  (require "Object-composite.ss")
+  (provide |IllegalMonitorStateException|))
diff --git a/collects/profj/libs/java/lang/IllegalStateException.java b/collects/profj/libs/java/lang/IllegalStateException.java
new file mode 100644
index 0000000000..16dcf1a80c
--- /dev/null
+++ b/collects/profj/libs/java/lang/IllegalStateException.java
@@ -0,0 +1,80 @@
+/* IllegalStateException.java -- thrown when invoking a method at
+   an illegal or inappropriate time
+   Copyright (C) 1998, 1999, 2001, 2002 Free Software Foundation, Inc.
+
+This file is part of GNU Classpath.
+
+GNU Classpath is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU Classpath is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Classpath; see the file COPYING.  If not, write to the
+Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+02111-1307 USA.
+
+Linking this library statically or dynamically with other modules is
+making a combined work based on this library.  Thus, the terms and
+conditions of the GNU General Public License cover the whole
+combination.
+
+As a special exception, the copyright holders of this library give you
+permission to link this library with independent modules to produce an
+executable, regardless of the license terms of these independent
+modules, and to copy and distribute the resulting executable under
+terms of your choice, provided that you also meet, for each linked
+independent module, the terms and conditions of the license of that
+module.  An independent module is a module which is not derived from
+or based on this library.  If you modify this library, you may extend
+this exception to your version of the library, but you are not
+obligated to do so.  If you do not wish to do so, delete this
+exception statement from your version. */
+
+
+package java.lang;
+
+/**
+ * Thrown when a method is invoked at an illegal or inappropriate time. For
+ * example:<br>
+ * <pre>
+ * void m(Collecion c)
+ * {
+ *   c.iterator().remove();
+ * }
+ * </pre>
+ *
+ * @author Brian Jones
+ * @author Warren Levy <warrenl@cygnus.com>
+ * @since 1.1
+ * @status updated to 1.4
+ */
+public class IllegalStateException extends RuntimeException
+{
+  /**
+   * Compatible with JDK 1.1+.
+   */
+  private static final long serialVersionUID = -1848914673093119416L;
+
+  /**
+   * Create an exception without a message.
+   */
+  public IllegalStateException()
+  {
+  }
+
+  /**
+   * Create an exception with a message.
+   *
+   * @param s the message
+   */
+  public IllegalStateException(String s)
+  {
+    super(s);
+  }
+}
diff --git a/collects/profj/libs/java/lang/IllegalStateException.ss b/collects/profj/libs/java/lang/IllegalStateException.ss
new file mode 100644
index 0000000000..bfa2e66973
--- /dev/null
+++ b/collects/profj/libs/java/lang/IllegalStateException.ss
@@ -0,0 +1,3 @@
+(module |IllegalStateException| mzscheme
+  (require "Object-composite.ss")
+  (provide |IllegalStateException|))
diff --git a/collects/profj/libs/java/lang/IllegalThreadStateException.java b/collects/profj/libs/java/lang/IllegalThreadStateException.java
new file mode 100644
index 0000000000..bcc188e1a6
--- /dev/null
+++ b/collects/profj/libs/java/lang/IllegalThreadStateException.java
@@ -0,0 +1,75 @@
+/* IllegalThreadStateException.java -- thrown when trying to manipulate a
+   Thread when it is not in an appropriate state
+   Copyright (C) 1998, 1999, 2001, 2002 Free Software Foundation, Inc.
+
+This file is part of GNU Classpath.
+
+GNU Classpath is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU Classpath is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Classpath; see the file COPYING.  If not, write to the
+Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+02111-1307 USA.
+
+Linking this library statically or dynamically with other modules is
+making a combined work based on this library.  Thus, the terms and
+conditions of the GNU General Public License cover the whole
+combination.
+
+As a special exception, the copyright holders of this library give you
+permission to link this library with independent modules to produce an
+executable, regardless of the license terms of these independent
+modules, and to copy and distribute the resulting executable under
+terms of your choice, provided that you also meet, for each linked
+independent module, the terms and conditions of the license of that
+module.  An independent module is a module which is not derived from
+or based on this library.  If you modify this library, you may extend
+this exception to your version of the library, but you are not
+obligated to do so.  If you do not wish to do so, delete this
+exception statement from your version. */
+
+
+package java.lang;
+
+/**
+ * Thrown When trying to manipulate a Thread which is in an inappropriate
+ * state. Since the documentation suggests that this can happen with
+ * <code>Thread.suspend</code> or <code>Thread.resume</code>, but these
+ * two methods are deprecated, this exception is likely very rare.
+ *
+ * @author Brian Jones
+ * @author Warren Levy <warrenl@cygnus.com>
+ * @status updated to 1.4
+ */
+public class IllegalThreadStateException extends IllegalArgumentException
+{
+  /**
+   * Compatible with JDK 1.0+.
+   */
+  private static final long serialVersionUID = -7626246362397460174L;
+
+  /**
+   * Create an exception without a message.
+   */
+  public IllegalThreadStateException()
+  {
+  }
+
+  /**
+   * Create an exception with a message.
+   *
+   * @param s the message
+   */
+  public IllegalThreadStateException(String s)
+  {
+    super(s);
+  }
+}
diff --git a/collects/profj/libs/java/lang/IllegalThreadStateException.ss b/collects/profj/libs/java/lang/IllegalThreadStateException.ss
new file mode 100644
index 0000000000..bbe6fd1397
--- /dev/null
+++ b/collects/profj/libs/java/lang/IllegalThreadStateException.ss
@@ -0,0 +1,3 @@
+(module |IllegalThreadStateException| mzscheme
+  (require "Object-composite.ss")
+  (provide |IllegalThreadStateException|))
diff --git a/collects/profj/libs/java/lang/IndexOutOfBoundsException.java b/collects/profj/libs/java/lang/IndexOutOfBoundsException.java
new file mode 100644
index 0000000000..336f87219a
--- /dev/null
+++ b/collects/profj/libs/java/lang/IndexOutOfBoundsException.java
@@ -0,0 +1,75 @@
+/* IndexOutOfBoundsException.java -- thrown for an invalid index
+   Copyright (C) 1998, 1999, 2001, 2002 Free Software Foundation, Inc.
+
+This file is part of GNU Classpath.
+
+GNU Classpath is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU Classpath is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Classpath; see the file COPYING.  If not, write to the
+Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+02111-1307 USA.
+
+Linking this library statically or dynamically with other modules is
+making a combined work based on this library.  Thus, the terms and
+conditions of the GNU General Public License cover the whole
+combination.
+
+As a special exception, the copyright holders of this library give you
+permission to link this library with independent modules to produce an
+executable, regardless of the license terms of these independent
+modules, and to copy and distribute the resulting executable under
+terms of your choice, provided that you also meet, for each linked
+independent module, the terms and conditions of the license of that
+module.  An independent module is a module which is not derived from
+or based on this library.  If you modify this library, you may extend
+this exception to your version of the library, but you are not
+obligated to do so.  If you do not wish to do so, delete this
+exception statement from your version. */
+
+
+package java.lang;
+
+/**
+ * This exception can be thrown to indicate an attempt to access an
+ * index which is out of bounds on objects like String, Array, or Vector.
+ * Usually any negative integer less than or equal to -1 and positive 
+ * integer greater than or equal to the size of the object is an index
+ * which would be out of bounds.
+ *
+ * @author Brian Jones
+ * @author Warren Levy <warrenl@cygnus.com>
+ * @status updated to 1.4
+ */
+public class IndexOutOfBoundsException extends RuntimeException
+{
+  /**
+   * Compatible with JDK 1.0+.
+   */
+  private static final long serialVersionUID = 234122996006267687L;
+
+  /**
+   * Create an exception without a message.
+   */
+  public IndexOutOfBoundsException()
+  {
+  }
+
+  /**
+   * Create an exception with a message.
+   *
+   * @param s the message
+   */
+  public IndexOutOfBoundsException(String s)
+  {
+    super(s);
+  }
+}
diff --git a/collects/profj/libs/java/lang/IndexOutOfBoundsException.ss b/collects/profj/libs/java/lang/IndexOutOfBoundsException.ss
new file mode 100644
index 0000000000..9f63adda94
--- /dev/null
+++ b/collects/profj/libs/java/lang/IndexOutOfBoundsException.ss
@@ -0,0 +1,3 @@
+(module |IndexOutOfBoundsException| mzscheme
+  (require "Object-composite.ss")
+  (provide |IndexOutOfBoundsException|))
diff --git a/collects/profj/libs/java/lang/InstantiationException.java b/collects/profj/libs/java/lang/InstantiationException.java
new file mode 100644
index 0000000000..511481418c
--- /dev/null
+++ b/collects/profj/libs/java/lang/InstantiationException.java
@@ -0,0 +1,74 @@
+/* InstantiationException.java -- thrown when reflection cannot create an
+   instance
+   Copyright (C) 1998, 1999, 2001, 2002 Free Software Foundation, Inc.
+
+This file is part of GNU Classpath.
+
+GNU Classpath is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU Classpath is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Classpath; see the file COPYING.  If not, write to the
+Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+02111-1307 USA.
+
+Linking this library statically or dynamically with other modules is
+making a combined work based on this library.  Thus, the terms and
+conditions of the GNU General Public License cover the whole
+combination.
+
+As a special exception, the copyright holders of this library give you
+permission to link this library with independent modules to produce an
+executable, regardless of the license terms of these independent
+modules, and to copy and distribute the resulting executable under
+terms of your choice, provided that you also meet, for each linked
+independent module, the terms and conditions of the license of that
+module.  An independent module is a module which is not derived from
+or based on this library.  If you modify this library, you may extend
+this exception to your version of the library, but you are not
+obligated to do so.  If you do not wish to do so, delete this
+exception statement from your version. */
+
+
+package java.lang;
+
+/**
+ * Thrown when an attempt is made to use reflection to build a
+ * non-instantiable class (an interface or abstract class).
+ *
+ * @author Brian Jones
+ * @author Warren Levy <warrenl@cygnus.com>
+ * @see Class#newInstance()
+ * @status updated to 1.4
+ */
+public class InstantiationException extends Exception
+{
+  /**
+   * Compatible with JDK 1.0+.
+   */
+  private static final long serialVersionUID = -8441929162975509110L;
+
+  /**
+   * Create an exception without a message.
+   */
+  public InstantiationException()
+  {
+  }
+
+  /**
+   * Create an exception with a message.
+   *
+   * @param s the message
+   */
+  public InstantiationException(String s)
+  {
+    super(s);
+  }
+}
diff --git a/collects/profj/libs/java/lang/InstantiationException.ss b/collects/profj/libs/java/lang/InstantiationException.ss
new file mode 100644
index 0000000000..7a08b897a6
--- /dev/null
+++ b/collects/profj/libs/java/lang/InstantiationException.ss
@@ -0,0 +1,3 @@
+(module |InstantiationException| mzscheme
+  (require "Object-composite.ss")
+  (provide |InstantiationException|))
diff --git a/collects/profj/libs/java/lang/InterruptedException.java b/collects/profj/libs/java/lang/InterruptedException.java
new file mode 100644
index 0000000000..2ee7867f61
--- /dev/null
+++ b/collects/profj/libs/java/lang/InterruptedException.java
@@ -0,0 +1,80 @@
+/* InterruptedException.java -- thrown when a thread is interrupted
+   Copyright (C) 1998, 1999, 2001, 2002 Free Software Foundation, Inc.
+
+This file is part of GNU Classpath.
+
+GNU Classpath is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU Classpath is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Classpath; see the file COPYING.  If not, write to the
+Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+02111-1307 USA.
+
+Linking this library statically or dynamically with other modules is
+making a combined work based on this library.  Thus, the terms and
+conditions of the GNU General Public License cover the whole
+combination.
+
+As a special exception, the copyright holders of this library give you
+permission to link this library with independent modules to produce an
+executable, regardless of the license terms of these independent
+modules, and to copy and distribute the resulting executable under
+terms of your choice, provided that you also meet, for each linked
+independent module, the terms and conditions of the license of that
+module.  An independent module is a module which is not derived from
+or based on this library.  If you modify this library, you may extend
+this exception to your version of the library, but you are not
+obligated to do so.  If you do not wish to do so, delete this
+exception statement from your version. */
+
+
+package java.lang;
+
+/**
+ * Thrown when a thread interrupts another thread which was previously
+ * sleeping, waiting, or paused in some other way.  See the
+ * <code>interrupt</code> method of class <code>Thread</code>.
+ *
+ * @author Brian Jones
+ * @author Warren Levy <warrenl@cygnus.com>
+ * @see Object#wait()
+ * @see Object#wait(long)
+ * @see Object#wait(long, int)
+ * @see Thread#sleep(long)
+ * @see Thread#interrupt()
+ * @see Thread#interrupted()
+ * @status updated to 1.4
+ */
+public class InterruptedException extends Exception
+{
+  /**
+   * Compatible with JDK 1.0+.
+   */
+  private static final long serialVersionUID = 6700697376100628473L;
+
+  /**
+   * Create an exception without a message.
+   */
+  public InterruptedException()
+  {
+  }
+
+  /**
+   * Create an exception with a message.
+   *
+   *
+   * @param s the message
+   */
+  public InterruptedException(String s)
+  {
+    super(s);
+  }
+}
diff --git a/collects/profj/libs/java/lang/InterruptedException.ss b/collects/profj/libs/java/lang/InterruptedException.ss
new file mode 100644
index 0000000000..b0a1c123bd
--- /dev/null
+++ b/collects/profj/libs/java/lang/InterruptedException.ss
@@ -0,0 +1,3 @@
+(module |InterruptedException| mzscheme
+  (require "Object-composite.ss")
+  (provide |InterruptedException|))
diff --git a/collects/profj/libs/java/lang/Math-native-methods.ss b/collects/profj/libs/java/lang/Math-native-methods.ss
new file mode 100644
index 0000000000..572b74cfc7
--- /dev/null
+++ b/collects/profj/libs/java/lang/Math-native-methods.ss
@@ -0,0 +1,58 @@
+#cs
+(module Math-native-methods mzscheme
+  (require (lib "math.ss"))
+
+  (define-syntax (define/provide stx)
+    (syntax-case stx ()
+      [(_ id val)
+       (identifier? #'id)
+       #'(begin
+	   (define id val)
+	   (provide id))]
+      [(_ (id . formals) . rest)
+       #'(begin
+	   (define (id . formals) . rest)
+	   (provide id))]))
+
+  (define/provide (Math-getE-native) e)
+  (define/provide (Math-getPI-native) pi)
+
+  (define/provide (Math-abs-double-native n) (abs n))
+  (define/provide (Math-abs-float-native n) (abs n))
+  (define/provide (Math-abs-int-native n) (abs n))
+  (define/provide (Math-abs-long-native n) (abs n))
+  (define/provide (Math-acos-double-native a) (acos a))
+  (define/provide (Math-asin-double-native a) (asin a))
+  (define/provide (Math-atan-double-native a) (atan a))
+  (define/provide (Math-atan2-double-double-native y x) (atan y x))
+  (define/provide (Math-ceil-double-native a) (ceiling a))
+  (define/provide (Math-cos-double-native a) (cos a))
+  (define/provide (Math-exp-double-native a) (exp a))
+  (define/provide (Math-floor-double-native a) (floor a))
+  (define/provide (Math-IEEEremainder-double-double-native f1 f2)
+    (let ([q (round (/ f1 f2))])
+      (- f1 (* f2 q))))
+  (define/provide (Math-log-double-native a) (log a))
+  (define/provide (Math-max-double-double-native a b) (max a b))
+  (define/provide (Math-max-float-float-native a b) (max a b))
+  (define/provide (Math-max-int-int-native a b) (max a b))
+  (define/provide (Math-max-long-long-native a b) (max a b))
+  (define/provide (Math-min-double-double-native a b) (min a b))
+  (define/provide (Math-min-float-float-native a b) (min a b))
+  (define/provide (Math-min-int-int-native a b) (min a b))
+  (define/provide (Math-min-long-long-native a b) (min a b))
+  (define/provide (Math-pow-double-double-native a b) (expt a b))
+  (define/provide (Math-random-native) (/ (random (sub1 (expt 2 31))) 
+					  (exact->inexact (sub1 (expt 2 31)))))
+  (define/provide (Math-rint-double-native a) (round a))
+  (define/provide (Math-round-double-native a) (inexact->exact (round a)))
+  (define/provide (Math-round-float-native a) (inexact->exact (round a)))
+  (define/provide (Math-sin-double-native a) (sin a))
+  (define/provide (Math-sqrt-double-native a) (sqrt a))
+  (define/provide (Math-tan-double-native a) (tan a))
+  (define/provide (Math-toDegrees-double-native angrad)
+    (* pi (/ angrad 180.0)))
+  (define/provide (Math-toRadians-double-native angdeg)
+    (* 180.0 (/ angdeg pi)))
+
+  )
diff --git a/collects/profj/libs/java/lang/Math.java b/collects/profj/libs/java/lang/Math.java
new file mode 100644
index 0000000000..c669236eca
--- /dev/null
+++ b/collects/profj/libs/java/lang/Math.java
@@ -0,0 +1,45 @@
+
+package java.lang;
+
+public final class Math extends Object {
+  private Math() { super(); }
+
+  private native static double getE();
+  private native static double getPI();
+
+  public static final double E = getE();
+  public static final double PI = getPI();
+
+  public native static double abs(double a);
+  public native static float abs(float a);
+  public native static int abs(int a);
+  public native static long abs(long a);
+  public native static double acos(double a);
+  public native static double asin(double a);
+  public native static double atan(double a);
+  public native static double atan2(double y, double x);
+  public native static double ceil(double a);
+  public native static double cos(double a);
+  public native static double exp(double a);
+  public native static double floor(double a);
+  public native static double IEEEremainder(double f1, double f2);
+  public native static double log(double a);
+  public native static double max(double a, double b);
+  public native static float max(float a, float b);
+  public native static int max(int a, int b);
+  public native static long max(long a, long b);
+  public native static double min(double a, double b);
+  public native static float min(float a, float b);
+  public native static int min(int a, int b);
+  public native static long min(long a, long b);
+  public native static double pow(double a, double b);
+  public native static double random();
+  public native static double rint(double a);
+  public native static long round(double a);
+  public native static int round(float a);
+  public native static double sin(double a);
+  public native static double sqrt(double a);
+  public native static double tan(double a);
+  public native static double toDegrees(double angrad);
+  public native static double toRadians(double angdeg); 
+}
diff --git a/collects/profj/libs/java/lang/NegativeArraySizeException.java b/collects/profj/libs/java/lang/NegativeArraySizeException.java
new file mode 100644
index 0000000000..ee73a97d5a
--- /dev/null
+++ b/collects/profj/libs/java/lang/NegativeArraySizeException.java
@@ -0,0 +1,77 @@
+/* NegativeArraySizeException.java -- thrown on attempt to create array
+   with a negative size
+   Copyright (C) 1998, 1999, 2001, 2002 Free Software Foundation, Inc.
+
+This file is part of GNU Classpath.
+
+GNU Classpath is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU Classpath is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Classpath; see the file COPYING.  If not, write to the
+Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+02111-1307 USA.
+
+Linking this library statically or dynamically with other modules is
+making a combined work based on this library.  Thus, the terms and
+conditions of the GNU General Public License cover the whole
+combination.
+
+As a special exception, the copyright holders of this library give you
+permission to link this library with independent modules to produce an
+executable, regardless of the license terms of these independent
+modules, and to copy and distribute the resulting executable under
+terms of your choice, provided that you also meet, for each linked
+independent module, the terms and conditions of the license of that
+module.  An independent module is a module which is not derived from
+or based on this library.  If you modify this library, you may extend
+this exception to your version of the library, but you are not
+obligated to do so.  If you do not wish to do so, delete this
+exception statement from your version. */
+
+
+package java.lang;
+
+/**
+ * Thrown when an attempt is made to create an array with a negative
+ * size. For example:<br>
+ * <pre>
+ * int i = -1;
+ * int[] array = new int[i];
+ * </pre>
+ *
+ * @author Brian Jones
+ * @author Warren Levy <warrenl@cygnus.com>
+ * @status updated to 1.4
+ */
+public class NegativeArraySizeException extends RuntimeException
+{
+  /**
+   * Compatible with JDK 1.0+.
+   */
+  private static final long serialVersionUID = -8960118058596991861L;
+
+  /**
+   * Create an exception without a message.
+   */
+  public NegativeArraySizeException()
+  {
+  }
+
+  /**
+   * Create an exception with a message.
+   *
+   * @param s the message
+   */
+  public NegativeArraySizeException(String s)
+  {
+    super(s);
+  }
+}
diff --git a/collects/profj/libs/java/lang/NegativeArraySizeException.ss b/collects/profj/libs/java/lang/NegativeArraySizeException.ss
new file mode 100644
index 0000000000..29cedb05df
--- /dev/null
+++ b/collects/profj/libs/java/lang/NegativeArraySizeException.ss
@@ -0,0 +1,3 @@
+(module |NegativeArraySizeException| mzscheme
+  (require "Object-composite.ss")
+  (provide |NegativeArraySizeException|))
diff --git a/collects/profj/libs/java/lang/NoSuchFieldException.java b/collects/profj/libs/java/lang/NoSuchFieldException.java
new file mode 100644
index 0000000000..ee721ebef2
--- /dev/null
+++ b/collects/profj/libs/java/lang/NoSuchFieldException.java
@@ -0,0 +1,73 @@
+/* NoSuchFieldException.java -- thrown when reflecting a non-existant field
+   Copyright (C) 1998, 1999, 2001, 2002 Free Software Foundation, Inc.
+
+This file is part of GNU Classpath.
+
+GNU Classpath is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU Classpath is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Classpath; see the file COPYING.  If not, write to the
+Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+02111-1307 USA.
+
+Linking this library statically or dynamically with other modules is
+making a combined work based on this library.  Thus, the terms and
+conditions of the GNU General Public License cover the whole
+combination.
+
+As a special exception, the copyright holders of this library give you
+permission to link this library with independent modules to produce an
+executable, regardless of the license terms of these independent
+modules, and to copy and distribute the resulting executable under
+terms of your choice, provided that you also meet, for each linked
+independent module, the terms and conditions of the license of that
+module.  An independent module is a module which is not derived from
+or based on this library.  If you modify this library, you may extend
+this exception to your version of the library, but you are not
+obligated to do so.  If you do not wish to do so, delete this
+exception statement from your version. */
+
+
+package java.lang;
+
+/**
+ * Thrown to indicate the class does not have the specified field. This is
+ * caused by a variety of reflection methods, when looking up a field by name.
+ *
+ * @author Brian Jones
+ * @author Warren Levy <warrenl@cygnus.com>
+ * @since 1.1
+ * @status updated to 1.4
+ */
+public class NoSuchFieldException extends Exception
+{
+  /**
+   * Compatible with JDK 1.1+.
+   */
+  private static final long serialVersionUID = -6143714805279938260L;
+
+  /**
+   * Create an exception without a message.
+   */
+  public NoSuchFieldException()
+  {
+  }
+
+  /**
+   * Create an exception with a message.
+   *
+   * @param s the message
+   */
+  public NoSuchFieldException(String s)
+  {
+    super(s);
+  }
+}
diff --git a/collects/profj/libs/java/lang/NoSuchFieldException.ss b/collects/profj/libs/java/lang/NoSuchFieldException.ss
new file mode 100644
index 0000000000..fa56513f75
--- /dev/null
+++ b/collects/profj/libs/java/lang/NoSuchFieldException.ss
@@ -0,0 +1,3 @@
+(module |NoSuchFieldException| mzscheme
+  (require "Object-composite.ss")
+  (provide |NoSuchFieldException|))
diff --git a/collects/profj/libs/java/lang/NoSuchMethodException.java b/collects/profj/libs/java/lang/NoSuchMethodException.java
new file mode 100644
index 0000000000..cba69203f7
--- /dev/null
+++ b/collects/profj/libs/java/lang/NoSuchMethodException.java
@@ -0,0 +1,72 @@
+/* NoSuchMethodException.java -- thrown when reflecting a non-existant method
+   Copyright (C) 1998, 1999, 2001, 2002 Free Software Foundation, Inc.
+
+This file is part of GNU Classpath.
+
+GNU Classpath is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU Classpath is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Classpath; see the file COPYING.  If not, write to the
+Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+02111-1307 USA.
+
+Linking this library statically or dynamically with other modules is
+making a combined work based on this library.  Thus, the terms and
+conditions of the GNU General Public License cover the whole
+combination.
+
+As a special exception, the copyright holders of this library give you
+permission to link this library with independent modules to produce an
+executable, regardless of the license terms of these independent
+modules, and to copy and distribute the resulting executable under
+terms of your choice, provided that you also meet, for each linked
+independent module, the terms and conditions of the license of that
+module.  An independent module is a module which is not derived from
+or based on this library.  If you modify this library, you may extend
+this exception to your version of the library, but you are not
+obligated to do so.  If you do not wish to do so, delete this
+exception statement from your version. */
+
+
+package java.lang;
+
+/**
+ * Thrown to indicate the class does not have the specified method. This is
+ * caused by a variety of reflection methods, when looking up a method by name.
+ *
+ * @author Brian Jones
+ * @author Warren Levy <warrenl@cygnus.com>
+ * @status updated to 1.4
+ */
+public class NoSuchMethodException extends Exception
+{
+  /**
+   * Compatible with JDK 1.0+.
+   */
+  private static final long serialVersionUID = 5034388446362600923L;
+
+  /**
+   * Create an exception without a message.
+   */
+  public NoSuchMethodException()
+  {
+  }
+
+  /**
+   * Create an exception with a message.
+   *
+   * @param s the message
+   */
+  public NoSuchMethodException(String s)
+  {
+    super(s);
+  }
+}
diff --git a/collects/profj/libs/java/lang/NoSuchMethodException.ss b/collects/profj/libs/java/lang/NoSuchMethodException.ss
new file mode 100644
index 0000000000..3f72c10d92
--- /dev/null
+++ b/collects/profj/libs/java/lang/NoSuchMethodException.ss
@@ -0,0 +1,3 @@
+(module |NoSuchMethodException| mzscheme
+  (require "Object-composite.ss")
+  (provide |NoSuchMethodException|))
diff --git a/collects/profj/libs/java/lang/NullPointerException.java b/collects/profj/libs/java/lang/NullPointerException.java
new file mode 100644
index 0000000000..bab2071937
--- /dev/null
+++ b/collects/profj/libs/java/lang/NullPointerException.java
@@ -0,0 +1,82 @@
+/* NullPointerException.java -- thrown when using null instead of an object
+   Copyright (C) 1998, 1999, 2001, 2002 Free Software Foundation, Inc.
+
+This file is part of GNU Classpath.
+
+GNU Classpath is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU Classpath is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Classpath; see the file COPYING.  If not, write to the
+Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+02111-1307 USA.
+
+Linking this library statically or dynamically with other modules is
+making a combined work based on this library.  Thus, the terms and
+conditions of the GNU General Public License cover the whole
+combination.
+
+As a special exception, the copyright holders of this library give you
+permission to link this library with independent modules to produce an
+executable, regardless of the license terms of these independent
+modules, and to copy and distribute the resulting executable under
+terms of your choice, provided that you also meet, for each linked
+independent module, the terms and conditions of the license of that
+module.  An independent module is a module which is not derived from
+or based on this library.  If you modify this library, you may extend
+this exception to your version of the library, but you are not
+obligated to do so.  If you do not wish to do so, delete this
+exception statement from your version. */
+
+
+package java.lang;
+
+/**
+ * Thrown when attempting to use <code>null</code> where an object
+ * is required. The Virtual Machine automatically throws this exception
+ * for the following:<br><ul>
+ * <li>Calling an instance method on a null object</li>
+ * <li>Accessing or modifying a field of a null object</li>
+ * <li>Taking the array length of a null array</li>
+ * <li>Accessing or modifying the slots of a null array</li>
+ * <li>Throwing a null Throwable</li>
+ * <li>Synchronizing on a null object</li>
+ * </ul>
+ * <p>Applications should also throw NullPointerExceptions whenever
+ * <code>null</code> is an inappropriate parameter to a method.
+ *
+ * @author Brian Jones
+ * @author Warren Levy <warrenl@cygnus.com>
+ * @status updated to 1.4
+ */
+public class NullPointerException extends RuntimeException
+{
+  /**
+   * Compatible with JDK 1.0+.
+   */
+  private static final long serialVersionUID = 5162710183389028792L;
+
+  /**
+   * Create an exception without a message.
+   */
+  public NullPointerException()
+  {
+  }
+
+  /**
+   * Create an exception with a message.
+   *
+   * @param s the message
+   */
+  public NullPointerException(String s)
+  {
+    super(s);
+  }
+}
diff --git a/collects/profj/libs/java/lang/NullPointerException.ss b/collects/profj/libs/java/lang/NullPointerException.ss
new file mode 100644
index 0000000000..b6bfcbf020
--- /dev/null
+++ b/collects/profj/libs/java/lang/NullPointerException.ss
@@ -0,0 +1,3 @@
+(module |NullPointerException| mzscheme
+  (require "Object-composite.ss")
+  (provide |NullPointerException|))
diff --git a/collects/profj/libs/java/lang/Number.java b/collects/profj/libs/java/lang/Number.java
new file mode 100644
index 0000000000..54bb1f763e
--- /dev/null
+++ b/collects/profj/libs/java/lang/Number.java
@@ -0,0 +1,131 @@
+/* Number.java =- abstract superclass of numeric objects
+   Copyright (C) 1998, 2001, 2002 Free Software Foundation, Inc.
+
+This file is part of GNU Classpath.
+
+GNU Classpath is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU Classpath is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Classpath; see the file COPYING.  If not, write to the
+Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+02111-1307 USA.
+
+Linking this library statically or dynamically with other modules is
+making a combined work based on this library.  Thus, the terms and
+conditions of the GNU General Public License cover the whole
+combination.
+
+As a special exception, the copyright holders of this library give you
+permission to link this library with independent modules to produce an
+executable, regardless of the license terms of these independent
+modules, and to copy and distribute the resulting executable under
+terms of your choice, provided that you also meet, for each linked
+independent module, the terms and conditions of the license of that
+module.  An independent module is a module which is not derived from
+or based on this library.  If you modify this library, you may extend
+this exception to your version of the library, but you are not
+obligated to do so.  If you do not wish to do so, delete this
+exception statement from your version. */
+
+
+package java.lang;
+
+import java.io.Serializable;
+
+/**
+ * Number is a generic superclass of all the numeric classes, including
+ * the wrapper classes {@link Byte}, {@link Short}, {@link Integer},
+ * {@link Long}, {@link Float}, and {@link Double}.  Also worth mentioning
+ * are the classes in {@link java.math}.
+ *
+ * It provides ways to convert numeric objects to any primitive.
+ *
+ * @author Paul Fisher
+ * @author John Keiser
+ * @author Warren Levy
+ * @author Eric Blake <ebb9@email.byu.edu>
+ * @since 1.0
+ * @status updated to 1.4
+ */
+public abstract class Number implements Serializable
+{
+  /**
+   * Compatible with JDK 1.1+.
+   */
+  private static final long serialVersionUID = -8742448824652078965L;
+
+  /**
+   * Table for calculating digits, used in Character, Long, and Integer.
+   */
+  static final char[] digits = {
+    '0', '1', '2', '3', '4', '5', '6', '7', '8', '9',
+    'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j',
+    'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't',
+    'u', 'v', 'w', 'x', 'y', 'z',
+  };
+
+  /**
+   * The basic constructor (often called implicitly).
+   */
+  public Number()
+  {
+  }
+
+  /**
+   * Return the value of this <code>Number</code> as an <code>int</code>.
+   *
+   * @return the int value
+   */
+  public abstract int intValue();
+
+  /**
+   * Return the value of this <code>Number</code> as a <code>long</code>.
+   *
+   * @return the long value
+   */
+  public abstract long longValue();
+
+  /**
+   * Return the value of this <code>Number</code> as a <code>float</code>.
+   *
+   * @return the float value
+   */
+  public abstract float floatValue();
+
+  /**
+   * Return the value of this <code>Number</code> as a <code>float</code>.
+   *
+   * @return the double value
+   */
+  public abstract double doubleValue();
+
+  /**
+   * Return the value of this <code>Number</code> as a <code>byte</code>.
+   *
+   * @return the byte value
+   * @since 1.1
+   */
+  public byte byteValue()
+  {
+    return (byte) intValue();
+  }
+
+  /**
+   * Return the value of this <code>Number</code> as a <code>short</code>.
+   *
+   * @return the short value
+   * @since 1.1
+   */
+  public short shortValue()
+  {
+    return (short) intValue();
+  }
+}
diff --git a/collects/profj/libs/java/lang/NumberFormatException.java b/collects/profj/libs/java/lang/NumberFormatException.java
new file mode 100644
index 0000000000..d076cc83da
--- /dev/null
+++ b/collects/profj/libs/java/lang/NumberFormatException.java
@@ -0,0 +1,73 @@
+/* NumberFormatException.java -- thrown when parsing a bad string as a number
+   Copyright (C) 1998, 1999, 2001, 2002 Free Software Foundation, Inc.
+
+This file is part of GNU Classpath.
+
+GNU Classpath is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU Classpath is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Classpath; see the file COPYING.  If not, write to the
+Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+02111-1307 USA.
+
+Linking this library statically or dynamically with other modules is
+making a combined work based on this library.  Thus, the terms and
+conditions of the GNU General Public License cover the whole
+combination.
+
+As a special exception, the copyright holders of this library give you
+permission to link this library with independent modules to produce an
+executable, regardless of the license terms of these independent
+modules, and to copy and distribute the resulting executable under
+terms of your choice, provided that you also meet, for each linked
+independent module, the terms and conditions of the license of that
+module.  An independent module is a module which is not derived from
+or based on this library.  If you modify this library, you may extend
+this exception to your version of the library, but you are not
+obligated to do so.  If you do not wish to do so, delete this
+exception statement from your version. */
+
+
+package java.lang;
+
+/**
+ * Can be thrown when attempting to convert a <code>String</code> to
+ * one of the numeric types, but the operation fails because the string
+ * has the wrong format.
+ *
+ * @author Brian Jones
+ * @author Warren Levy <warrenl@cygnus.com>
+ * @status updated to 1.4
+ */
+public class NumberFormatException extends IllegalArgumentException
+{
+  /**
+   * Compatible with JDK 1.0+.
+   */
+  private static final long serialVersionUID = -2848938806368998894L;
+
+  /**
+   * Create an exception without a message.
+   */
+  public NumberFormatException()
+  {
+  }
+
+  /**
+   * Create an exception with a message.
+   *
+   * @param s the message
+   */
+  public NumberFormatException(String s)
+  {
+    super(s);
+  }
+}
diff --git a/collects/profj/libs/java/lang/NumberFormatException.ss b/collects/profj/libs/java/lang/NumberFormatException.ss
new file mode 100644
index 0000000000..35f956bcf9
--- /dev/null
+++ b/collects/profj/libs/java/lang/NumberFormatException.ss
@@ -0,0 +1,3 @@
+(module |NumberFormatException| mzscheme
+  (require "Object-composite.ss")
+  (provide |NumberFormatException|))
diff --git a/collects/profj/libs/java/lang/Object-composite.ss b/collects/profj/libs/java/lang/Object-composite.ss
new file mode 100644
index 0000000000..5a24585a49
--- /dev/null
+++ b/collects/profj/libs/java/lang/Object-composite.ss
@@ -0,0 +1,736 @@
+#cs
+(module Object-composite mzscheme
+  
+  (require (lib "class.ss")
+           (lib "errortrace-lib.ss" "errortrace")
+           (lib "Comparable.ss" "profj" "libs" "java" "lang")
+           (lib "Serializable.ss" "profj" "libs" "java" "io"))
+  (require "compile-lang-syntax.ss")    
+  
+  ;Runtime needed code
+  (define (javaRuntime:convert-to-string data)
+    (cond
+      ((number? data) (make-java-string (number->string data)))
+      ((boolean? data) 
+       (make-java-string (if data "true" "false")))
+      ((char? data) (make-java-string (string data)))
+      ((is-a? data ObjectI) (send data toString))
+      ((is-a? data object%) (make-java-string "SchemeObject"))
+      (else (error 'JavaRuntime:Internal_Error:convert-to-string
+                   (format "Convert to string given unsupported data: ~s" data)))))
+  
+  
+;                                            
+;         ;;         ;                       
+;    ;;;   ;                            ;    
+;   ;   ;  ;                            ;    
+;   ;   ;  ;;;;   ;;;;    ;;;    ;;;   ;;;;; 
+;   ;   ;  ;   ;     ;   ;   ;  ;   ;   ;    
+;   ;   ;  ;   ;     ;   ;;;;;  ;       ;    
+;   ;   ;  ;   ;     ;   ;      ;       ;    
+;   ;   ;  ;   ;     ;   ;   ;  ;   ;   ;   ;
+;    ;;;  ; ;;;      ;    ;;;    ;;;     ;;; 
+;                    ;                       
+;                    ;                       
+;                 ;;;                        
+
+  ;Object.java
+  (provide ObjectI Object-Mix Object)
+  
+  ;Object interface, and a mixin to create objects from.
+  
+  (define ObjectI
+    (interface () Object-constructor clone equals-java.lang.Object finalize getClass
+      hashCode notify notifyAll toString wait wait-long wait-long-int my-name))
+  
+  (define Object-Mix
+    (lambda (parent)
+      (class* parent (ObjectI)
+        
+        (define/public (Object-constructor) (void))
+        
+        ;Needs to do something
+        (define/public clone (lambda () void))
+        
+        (define/public (equals-java.lang.Object obj) (eq? this obj))
+        
+        ;Needs to do something
+        (define/public (finalize) void)
+        
+        (public-final getClass)
+        (define (getClass)
+          (error 'ProfessorJ:getClass 
+                 (format "ProfessorJ does not support getClass calls. ~e" 
+                         (send this toString))))
+        
+        (define/public (hashCode) (eq-hash-code this))
+        
+        ;Needs to do something when Threads more implemented
+        (public-final notify |notifyAll|)
+        (define (notify) void)
+        (define (notifyAll) void)
+        
+        (define/public (my-name) "Object")
+        (define/public (toString)
+          (make-java-string (format "~a@~a" (send this my-name) (send this hashCode))))
+        
+        (public-final wait wait-long wait-long-int)
+        (define wait (lambda () void))
+        (define wait-long (lambda (l) void))
+        (define wait-long-int (lambda (l i) void))
+
+        (define/public (field-names) null)
+        (define/public (field-values) null)
+        
+        (define/public (fields-for-display)
+          (let ((field-name-list (send this field-names))
+                (field-value-list (send this field-values)))
+            (lambda ()
+              (if (null? field-name-list) 
+                  #f
+                  (begin0 (list (car field-name-list) (car field-value-list))
+                          (set! field-name-list (cdr field-name-list))
+                          (set! field-value-list (cdr field-value-list)))))))
+        
+        (super-instantiate ()))))
+  
+  (define Object (Object-Mix object%))
+  
+  
+;                                     
+;                                     
+;   ;;;                               
+;     ;                               
+;    ; ;   ; ;;;  ; ;;;  ;;;;  ;;; ;;;
+;    ; ;    ;      ;         ;  ;   ; 
+;   ;;;;;   ;      ;      ;;;;  ;   ; 
+;   ;   ;   ;      ;     ;   ;   ; ;  
+;   ;   ;   ;      ;     ;   ;   ;;;  
+;  ;;; ;;; ;;;;   ;;;;    ;;; ;   ;   
+;                                 ;   
+;                                 ;   
+;                               ;;    
+
+  ;;array implementation:
+  (provide make-java-array is-java-array? make-runtime-type array->list)
+  
+  (define java-array
+    (class* Object ()
+      
+      (define array null)
+      (define rt #f)
+      (define/public (get-rt) rt)
+      
+      (define/private (check-runtime-type val)
+        (if (<= (runtime-type-dim rt) 1)
+            (if (symbol? (runtime-type-type rt))
+                (case (runtime-type-type rt)
+                  ((byte short int long) (and (number? val) (not (inexact? val))))
+                  ((char) (char? val))
+                  ((float double) (and (number? val) (inexact? val))))
+                (is-a? val (runtime-type-type rt)))
+            (and
+             (is-a? val java-array)
+             (= (sub1 (runtime-type-dim rt))
+                (runtime-type-dim (send val get-rt)))
+             (eq? (runtime-type-type rt) (runtime-type-type (send val get-rt))))))
+      
+      (define/public (check-prim-type type dim)
+        (and (eq? (runtime-type-type rt) type)
+             #;(= dim (runtime-type-dim rt))))
+      (define/public (check-ref-type type dim)
+        (and (eq? (runtime-type-type rt) type)
+             #;(= dim (runtime-type-dim rt))))
+      
+      (define/private (default-val) 
+        (if (and (= 1(runtime-type-dim rt)) (symbol? (runtime-type-type rt)))
+            (case (runtime-type-type rt)
+              ((byte short int long float double) 0)
+              ((char) #\null))
+            null))
+
+      (define/public (length) (vector-length array))
+      
+      (define/private (array-out-of-bounds i)
+        (raise (create-java-exception ArrayIndexOutOfBoundsException
+                                      (format "Array index out of bounds. Range is 0 to ~a, given ~a"
+                                              (sub1 (vector-length array)) i)
+                                      (lambda (obj msg)
+                                        (send obj ArrayIndexOutOfBoundsException-constructor-java.lang.String msg))
+                                      (current-continuation-marks))))
+      
+      (define/public (access index) 
+        (when (or (< index 0) (>= index (length)))
+          (array-out-of-bounds index))
+        (vector-ref array index))
+      
+      (define/public (set index val)
+        (when (or (< index 0) (>= index (length)))
+          (array-out-of-bounds index))
+        (if (check-runtime-type val)
+            (vector-set! array index val)
+            (raise (create-java-exception ArrayStoreException
+                                          "Array given incompatible type"
+                                          (lambda (obj msg) 
+                                            (send obj ArrayStoreException-constructor-java.lang.String msg))
+                                          (current-continuation-marks)))))
+                                        
+      (define/public (make-uninitialized size type)
+        (when (< size 0)
+          (raise (create-java-exception NegativeArraySizeException
+                                        (format "Size for the array must be greater than 0, given ~a" size)
+                                        (lambda (obj msg)
+                                          (send obj NegativeArraySizeException-constructor-java.lang.String msg))
+                                        (current-continuation-marks))))
+        (set! rt type)
+        (set! array (make-vector size (default-val))))
+      
+      (define/public (make-initialized type vals)
+        (set! rt type)
+        (set! array (list->vector vals)))
+      
+      (define/public (make-multi-dimension type size default-val)
+        (set! rt type)
+        (set! array (make-vector size default-val)))
+      
+      (define/public (make-uninit-multi type sizes)
+        (set! rt type)
+        (set! array 
+              (if (null? (cdr sizes))
+                  (make-vector (car sizes) (default-val))
+                  (let ((vec (make-vector (car sizes))))
+                    (let loop ((idx 0))
+                      (unless (>= idx (car sizes))
+                        (vector-set! vec idx (make-java-array (make-runtime-type (runtime-type-type type)
+                                                                                 (sub1 (runtime-type-dim type)))
+                                                              (cdr sizes) null))
+                        (loop (add1 idx))))
+                    vec))))
+      
+      (define/override (my-name) "array")
+      
+      (super-instantiate ())))
+  
+  (define (make-java-array type size vals)
+    (let ((array (make-object java-array)))
+      (cond
+        ((list? size) (send array make-uninit-multi type size))
+        ((null? vals) (send array make-uninitialized size type))
+        ((list? vals) (send array make-initialized type vals))
+        (else (send array make-multi-dimension type size vals)))
+      array))
+  
+  (define (is-java-array? obj) (is-a? obj java-array))
+  
+  (define-struct runtime-type (type dim) (make-inspector))
+  
+  (define (array->list array start stop)
+    (if (= start stop)
+        null
+        (cons (send array access start)
+              (array->list array (add1 start) stop))))
+  
+  
+;                                            
+;                          ;                 
+;    ;;;;   ;                                
+;   ;   ;   ;                                
+;   ;      ;;;;;  ; ;;;  ;;;   ; ;;;    ;;; ;
+;   ;;;     ;      ;       ;    ;;  ;  ;   ; 
+;     ;;;   ;      ;       ;    ;   ;  ;   ; 
+;       ;   ;      ;       ;    ;   ;  ;   ; 
+;   ;   ;   ;   ;  ;       ;    ;   ;  ;   ; 
+;   ;;;;     ;;;  ;;;;   ;;;;; ;;;  ;;  ;;;; 
+;                                          ; 
+;                                          ; 
+;                                       ;;;  
+
+  ;;String.java
+  (provide make-java-string String String-valueOf-java.lang.Object String-valueOf-char1 
+           String-valueOf-char1-int-int String-copyValueOf-char1-int-int String-copyValueOf-char1
+           String-valueOf-boolean String-valueOf-char String-valueOf-int String-valueOf-long 
+           String-valueOf-float String-valueOf-double)
+  
+  (define (make-java-string s)
+    (let ((obj (make-object String)))
+      (send obj make-mzscheme-string s)
+      obj))
+  
+  (define String
+    (class* Object (Comparable Serializable)
+      
+      ;private field containing scheme string
+      (define text "")
+      ;Accessor for scheme string
+      (define/public (get-mzscheme-string) text)
+      
+      ;Constructors
+      (define/public (String-constructor) (send this Object-constructor))      
+
+      (define/public (String-constructor-java.lang.String string)
+        (send this Object-constructor)
+        (set! text (send string get-mzscheme-string)))    
+      
+      (define/public (String-constructor-char1 chars)
+        (send this Object-constructor)
+        (set! text (list->string (array->list chars 0 (send chars length)))))
+    
+      (define/public (String-constructor-char1-int-int chars offset count)
+        (send this Object-constructor)
+        (set! text (list->string (array->list chars offset count))))
+    
+      ;Does not take into account char-set: PROBLEM
+      (define/public (String-constructor-byte1-int-int-java.lang.String ascii offset len char-set)
+        (send this Object-constructor)
+        (set! text (list->string (map integer->char (array->list ascii offset len)))))
+      (define/public (|String-constructor-byte1-java.lang.String| ascii char-set)
+        (send this Object-constructor)
+        (set! text (list->string (map integer->char (array->list ascii 0 (send ascii length))))))
+    
+      ;currently broken until I figure out how to deal appropriately with hi bytes
+      (define/public (String-constructor-byte1-int-int-int ascii hi offset count)
+        (send this Object-constructor))
+      (define/public (String-constructor-byte1-int ascii hi)
+        (send this Object-constructor))
+    
+      (define/public (String-constructor-StringBuffer buffer)
+        (send this Object-constructor)
+        (set! text (substring (send (send buffer toString) get-mzscheme-string)
+                              0 
+                              (send buffer length))))
+    
+      ;Constructor to use when a string is constructed by ""
+      (define/public (make-mzscheme-string str)
+        (send this Object-constructor)
+        (set! text str))
+      
+      (define/override (toString) this)
+    
+      ; -> int
+      (define/public (length) (string-length text))
+      ; int -> char
+      (define/public  (charAt-int index) (string-ref text index))
+    
+      ;-> void
+      (define/public (getChars-int-int-char1-int begin end dest i)
+        (letrec ((build-char-array
+                  (lambda (offset index)
+                    (if (= offset end)
+                        (void)
+                        (begin
+                          (send dest set index (string-ref text offset))
+                          (build-char-array (add1 offset) (add1 index)))))))
+          (build-char-array begin i)))
+    
+      ;Does not mess with charset
+      (define/public (getBytes)
+        (letrec ((array (make-java-array (make-runtime-type 'byte) (length) null))
+                 (build-byte-array
+                  (lambda (index)
+                    (if (= index (length))
+                        array
+                        (begin
+                          (send array set index (char->integer (string-ref text index)))
+                          (build-byte-array (add1 index)))))))
+          (build-byte-array 0)))
+      (define/public (getBytes-java.lang.String charset)
+        (getBytes))
+    
+      (define/public (getBytes-int-int-byte1-int begin end dest i)
+        (letrec ((build-byte-array
+                  (lambda (offset index)
+                    (if (= offset end)
+                        (void)
+                        (begin
+                          (send dest set index (char->integer (string-ref text offset)))
+                          (build-byte-array (add1 offset) (add1 index)))))))
+          (build-byte-array begin i)))
+
+      (define/public (contentEquals-java.lang.StringBuffer buf)
+        (equals-java.lang.Object (send buf toString)))
+    
+      ;Object -> boolean
+      (define/override (equals-java.lang.Object obj)
+        (and (is-a? obj String)
+             (equal? text (send (send obj toString) get-mzscheme-string))))
+      
+      ;Object -> boolean
+      (define/public (equalsIgnoreCase-java.lang.String str)
+        (string-ci=? text (send str get-mzscheme-string)))
+
+      ;find-diff-chars: int int string-> (values int int)
+      (define/private (find-diff-chars i stop-length compare-string)
+        (if (>= i stop-length)
+            (values #f #f)
+            (if (not (equal? (string-ref text i) (string-ref compare-string i)))
+                (values (char->integer (string-ref text i)) (char->integer (string-ref compare-string i)))
+                (find-diff-chars (add1 i) stop-length compare-string))))
+      
+      ;min: int int -> int
+      (define/private (min x y)
+        (cond
+          ((= x y) x)
+          ((< x y) x)
+          (else y)))
+      
+      ;String -> int
+      (define/public (compareTo-java.lang.String str)
+        (let* ((string (send str get-mzscheme-string))
+               (text-l (string-length text))
+               (str-l (string-length string)))
+          (cond
+            ((equals-java.lang.Object str) 0)
+            (else
+             (let-values (((int-text int-str) (find-diff-chars 0 (min text-l str-l) string)))
+               (if int-text
+                   (- int-text int-str)
+                   (- text-l str-l)))))))
+  
+      ;Object -> int: Throws ClassCastException
+      (define/public (compareTo-java.lang.Object obj)
+        (if (is-a? obj String)
+            (compareTo-java.lang.String obj)
+            (raise (create-java-exception ClassCastException
+                                          (format "ClassCastException: Expected argument of class String given ~a"
+                                                  (send (send obj toString) get-mzscheme-string))
+                                          (lambda (obj msg) (send obj ClassCastException-constructor-String msg))
+                                          (current-continuation-marks)))))
+      
+      ;String -> int
+      (define/public (compareToIgnoreCase-java.lang.String str)
+        (letrec ((string (send str get-mzscheme-string))
+                 (find-diff-chars
+                  (lambda (i)
+                    (if (>= i (length text))
+                        (error 'comparetostring "Opps, internal error")
+                        (if (not (char-ci=? (string-ref text i) (string-ref string i)))
+                            (values (char->integer (string-ref text i)) (char->integer (string-ref string i)))
+                            (find-diff-chars (add1 i))))))
+                 (text-l (string-length text))
+                 (str-l (string-length string)))
+          (cond
+            ((equalsIgnoreCase-java.lang.String str) 0)
+            ((string-ci<? text string) 
+             (if (= text-l str-l)
+                 (let-values (((int-text int-str) (find-diff-chars 0)))
+                   (- int-text int-str))
+                 (- text-l str-l)))                               
+            ((string-ci>? text string) 
+             (if (= text-l str-l)
+                 (let-values (((int-text int-str) (find-diff-chars 0)))
+                   (- int-text int-str))
+                 (- text-l str-l))))))
+    
+      ;int String int int -> boolean
+      (define/public (regionMatches-int-java.lang.String-int-int toffset jstr ooffset len)
+        (let ((str (send jstr get-mzscheme-string)))
+          (and (not (negative? toffset))
+               (not (negative? ooffset))
+               (<= (+ toffset len) (string-length text))
+               (<= (+ ooffset len) (string-length str))
+               (string=? (substring text toffset (+ toffset len)) 
+                         (substring str ooffset (+ ooffset len))))))
+    
+      ;.... -> boolean
+      (define/public (regionMatches-boolean-int-java.lang.String-int-int case? toffset jstr ooffset len)
+        (let ((str (send jstr get-mzscheme-string)))
+          (and (not (negative? toffset))
+               (not (negative? ooffset))
+               (<= (+ toffset len) (string-length text))
+               (<= (+ ooffset len) (string-length str))
+               ((if case? string=? string-ci=?) (substring text toffset (+ toffset len)) 
+                (substring str ooffset (+ ooffset len))))))
+    
+      ; .... -> boolean
+      (define/public (startsWith-java.lang.String-int Jprefix offset)
+        (let ((prefix (send Jprefix get-mzscheme-string)))
+          (and (not (negative? offset))
+               (<= (+ offset (string-length prefix)) (string-length text))
+               (string=? prefix (substring text offset (+ offset (string-length prefix)))))))
+    
+      ;..... -> boolean
+      (define/public (startsWith-java.lang.String Jprefix)
+        (let ((prefix (send Jprefix get-mzscheme-string)))
+          (and (<= (string-length prefix) (string-length text))
+               (string=? prefix (substring text 0 (string-length prefix))))))     
+          
+      (define/public (endsWith-java.lang.String Jsuffix)
+        (let ((suffix (send Jsuffix get-mzscheme-string)))
+          (and (<= (string-length suffix) (string-length text))
+               (string=? suffix (substring text (- (string-length text) (string-length suffix)) (string-length text))))))
+    
+      ; -> int
+      (define/override (hashCode)
+        (let ((hash 0))
+          (let loop ([index 0])
+            (unless (>= index (string-length text))
+              (set! hash (+ hash (* (char->integer (string-ref text index)) 
+                                    (expt 31 (- (string-length text) (add1 index))))))
+              (loop (add1 index))))
+          hash))
+    
+    ; character int -> int
+    (define/private (find-char ch pos)
+      (if (>= pos (string-length text))
+          -1
+          (if (char=? ch (string-ref text pos))
+              pos
+              (find-char ch (add1 pos)))))
+      
+      ;character int int -> int
+      (define/private (find-last-char ch pos lpos)
+        (if (>= pos (string-length text))
+            lpos
+            (if (char=? ch (string-ref text pos))
+                (find-last-char ch (add1 pos) pos)
+                (find-last-char ch (add1 pos) lpos))))
+      
+      ; string int -> int
+      (define/private (find-str sch-str str pos)
+        (if (> (+ pos (string-length sch-str)) (string-length text))
+            -1
+            (if (startsWith-java.lang.String-int str pos)
+                pos
+                (find-str sch-str str (add1 pos)))))
+    
+      ; string int int -> int
+      (define/private (find-last-string sch-str str pos lpos)
+        (if (> (+ pos (string-length sch-str)) (string-length text))
+            lpos
+            (if (startsWith-java.lang.String-int str pos)
+                (find-last-string sch-str str (add1 pos) pos)
+                (find-last-string sch-str str (add1 pos) lpos))))
+    
+      (define/public (indexOf-int ch) (find-char (if (number? ch) (integer->char ch) ch) 0))
+      (define/public (indexOf-int-int ch offset) (find-char (if (number? ch) (integer->char ch) ch) offset))
+      (define/public (indexOf-java.lang.String str) (find-str (send str get-mzscheme-string) str 0))    
+      (define/public (indexOf-java.lang.String-int str offset) (find-str (send str get-mzscheme-string) str offset))
+      
+      (define/public (lastIndexOf-int ch) 
+        (find-last-char (if (number? ch) (integer->char ch) ch) 0 -1))
+      (define/public (lastIndexOf-int-int ch offset) 
+        (find-last-char (if (number? ch) (integer->char ch) ch) offset -1))
+      (define/public (lastIndexOf-java.lang.String str) (find-last-string (send str get-mzscheme-string) str 0 -1))
+      (define/public (lastIndexOf-java.lang.String-int str offset) (find-last-string (send str get-mzscheme-string) str offset -1))
+    
+      ;int -> String
+      (define/public (substring-int index) (make-java-string (substring text index (string-length text))))
+    
+      ;... -> String
+      (define/public (substring-int-int begin end) (make-java-string (substring text begin end)))
+    
+      (define/public (subSequence-int-int begin end)
+        (error 'subSequence "Internal Error: subsequence is unimplemented because charSequence is unimplemented"))
+    
+      ;String -> String
+      (define/public (concat-java.lang.String Jstr)
+        (let ((str (send Jstr get-mzscheme-string)))
+          (make-java-string (string-append text str))))
+    
+      ; .. -> String
+      (define/public (replace-char-char old new)
+        (let ((new-text (apply string-append (map string (string->list text)))))
+          (let loop ([index 0])
+            (let ((pos (find-char old index)))
+              (unless (= -1 pos)
+                (string-set! new-text pos new)
+                (loop (add1 index)))))
+          (make-java-string new-text)))
+    
+      ;Does not currently work. Needs to replace regex in text with replace and return new string; PROBLEM
+      (define/public (replaceAll-java.lang.String-java.lang.String regex replace)
+        (error 'replaceAll "Internal error: replaceAll is unimplemented at this time"))
+    
+      (define/public (replaceFirst-java.lang.String-java.lang.String regex replace)
+        (error 'replaceFirst "Internal error: replaceFirst is unimplemented at this time"))
+    
+      (define/public (matches-java.lang.String regex)
+        (error 'matches "Internal error: matches is unimplemented at this time"))
+    
+      (define/public (split-java.lang.String-int regex limit)
+        (error 'split "Internal error: split is unimplemented at this time"))
+      
+      (define/public (split-java.lang.String regex)
+        (error 'split "Internal error: split is unimplemented at this time"))
+    
+      ; -> String
+      (define/public (toLowerCase)
+        (make-java-string (apply string-append (map string (map char-downcase (string->list text))))))
+    
+      ;Does not take Locale into account
+      (define/public (toLowerCase-java.util.Locale locale)
+        (toLowerCase))
+    
+      (define/public (toUpperCase)
+        (make-java-string (apply string-append (map string (map char-upcase (string->list text))))))
+    
+      ;Does not take Locale into account: Problem
+      (define/public (toUpperCase-java.util.Locale locale)
+        (toUpperCase))
+    
+      ;... -> String
+      (define/public (trim)
+        (error 'trim "Internal error: trim is unimplemented at this time."))
+    
+      (define/public (toCharArray) (make-java-array 'char 0 (string->list text)))
+    
+      ;PROBLEM I am not sure what the side effects of this are supposed to be! PROBLEM!
+      (define/public intern  
+        (lambda () this))
+      
+      (define/override (my-name) "String")      
+      (super-instantiate ())))
+  
+  ;valueOf -> String
+  (define (String-valueOf-java.lang.Object obj)
+    (if (null? obj)
+        (make-java-string "null")
+        (send obj |toString|)))
+  (define (String-valueOf-char1 data) 
+    (make-java-string (list->string (array->list data 0 (send data length)))))
+
+  ;Should throw exceptions
+  (define (String-valueOf-char1-int-int data offset len)
+    (make-java-string (list->string (array->list data offset len))))
+
+  (define (String-valueOf-boolean b) (make-java-string (if b "true" "false")))
+  (define (String-valueOf-char c) (make-java-string (string c)))
+  (define (String-valueOf-int i) (make-java-string (number->string i)))
+  (define (String-valueOf-long l) (make-java-string (number->string l)))
+  (define (String-valueOf-float f) (make-java-string (number->string f)))
+  (define (String-valueOf-double d) (make-java-string (number->string d)))
+  
+  ;copyValueOf -> String
+  (define (String-copyValueOf-char1-int-int data offset count)
+    (String-valueOf-char1-int-int data offset count))
+  (define (String-copyValueOf-char1 data) (String-valueOf-char1 data))
+  
+  ;Comparator
+  (define String-CASE_INSENSITIVE_ORDER null)
+  
+  
+;                                                                 
+;         ;;                                 ;;      ;;;          
+;  ;;;;;;; ;                                  ;        ;          
+;  ;  ;  ; ;                                  ;        ;          
+;  ;  ;  ; ; ;;   ; ;;;   ;;;  ;;; ;;; ;;;;   ;;;;     ;     ;;;  
+;     ;    ;;  ;   ;     ;   ;  ;   ;      ;  ;   ;    ;    ;   ; 
+;     ;    ;   ;   ;     ;   ;  ; ; ;   ;;;;  ;   ;    ;    ;;;;; 
+;     ;    ;   ;   ;     ;   ;  ; ; ;  ;   ;  ;   ;    ;    ;     
+;     ;    ;   ;   ;     ;   ;   ; ;   ;   ;  ;   ;    ;    ;   ; 
+;   ;;;;; ;;; ;;; ;;;;    ;;;    ; ;    ;;; ;; ;;;   ;;;;;;  ;;;  
+;                                                                 
+;                                                                 
+;                                                                 
+;Throwable and exceptions
+
+  (provide Throwable (struct java:exception (object))
+           exception-is-a? handle-exception create-java-exception)
+  
+  (define Throwable
+    (class* Object (Serializable)
+      
+      ;private fields
+      ;message: String
+      (define message "")
+      ;stack: continuation-mark-set
+      (define stack null)
+      ;java:exception
+      (define exception null)
+      ;cause: Throwable
+      (define cause null)
+      
+      ;Constructors, set the stack and message
+      (define/public (Throwable-constructor)
+        (set! stack (current-continuation-marks))
+        (send this Object-constructor))
+                
+      (define/public (Throwable-constructor-java.lang.String msg)
+        (set! message msg)
+        (set! stack (current-continuation-marks))
+        (send this Object-constructor))
+      
+      (define/public (Throwable-constructor-java.lang.String-java.lang.Throwable msg cse)
+        (set! message msg)
+        (set! cause cse)
+        (set! stack (current-continuation-marks))
+        (send this Object-constructor))
+      
+      (define/public (Throwable-constructor-java.lang.Throwable cse)
+        (set! message (if (null? cse) null (send cse |toString|)))
+        (set! cause cse)
+        (set! stack (current-continuation-marks))
+        (send this Object-constructor))    
+      
+      (public-final set-exception! get-mzscheme-exception)
+      ;Used to interoperate with mzscheme exceptions: set and get the current exception
+      (define (set-exception! exn)
+        (set! exception exn)
+        (set! stack (exn-continuation-marks exn)))
+      (define (get-mzscheme-exception) exception)
+
+      ;Needs to throw exceptions. Needs to be callable only once per object
+      (define/public (initCause-java.lang.Throwable cse)
+        (set! cause cse)
+        this)
+      
+      ; -> String
+      (define/public (getMessage) message)
+      (define/public (getCause) cause)
+      (define/public (getLocalizedMessage) (send this getMessage))
+      
+      (define/public (setStackTrace-java.lang.StackTraceElement1 elments)
+        (error 'setStackTrace "Internal error: setStackTrace will not be implemented until strack trace element s implemented"))
+      (define/public (getStackTrace)
+        (error 'getStackTrace "Internal error: getStackTrace will not be implemented until StackTraceElement is implemented"))
+      
+       ; -> string
+      (define/override (toString)
+        (if (null? message)
+            (make-java-string (send this my-name))
+            (make-java-string (format "~a: ~a" 
+                                      (send this my-name) 
+                                      (send (send this getMessage) get-mzscheme-string)))))
+      
+      ; -> void
+      (define/public (printStackTrace)
+        (print-error-trace (current-output-port)
+                           (make-exn message stack)))
+
+      ;These functions do not work correctly yet, and won't until printStreams are implemented
+      (define/public printStackTrace-PrintStream (lambda (printStream) void)) 
+      (define/public printStackTrace-PrintWriter (lambda (pW) void))
+      
+      ;This function does nothing at this time
+      (define/public (fillInStackTrace) this)
+      
+      ; -> string
+      (define/override (my-name) "Throwable")
+      
+      (super-instantiate ())))
+  
+  ;(make-java-exception string continuation-mark-set Throwable)
+  ;Where Throwable is an object descending from class Throwable
+  (define-struct (java:exception exn) (object))
+
+  ;exception-is-a?: class -> (exn -> bool)
+  (define (exception-is-a? class)
+    (lambda (exn)
+      (is-a? (java:exception-object exn) class)))
+
+  (define (handle-exception actions)
+    (lambda (exn)
+      (actions (java:exception-object exn))))
+  
+  ;PROBLEM: create java exception misused by String implementation
+  (define (create-java-exception class msg constructor marks)
+    (let* ((exn (make-object class))
+           (str (make-java-string msg))
+           (scheme-exn (make-java:exception msg marks exn)))
+      (constructor exn str)
+      (send exn set-exception! scheme-exn)
+      scheme-exn))
+  
+  (compile-rest-of-lang (list "Object" "Throwable" "String" "Exception" "RuntimeException" "Comparable"))
+  
+  )
\ No newline at end of file
diff --git a/collects/profj/libs/java/lang/Object.jinfo b/collects/profj/libs/java/lang/Object.jinfo
new file mode 100644
index 0000000000..b55c994e50
--- /dev/null
+++ b/collects/profj/libs/java/lang/Object.jinfo
@@ -0,0 +1,21 @@
+(class ("Object" "java" "lang")
+       (public)
+       #t
+       ()
+       (("Object" (public) ctor () () ("Object" "java" "lang"))
+	("clone" (protected) ("Object" "java" "lang") () (("CloneNotSupportedException" "java" "lang"))("Object" "java" "lang"))
+        ("equals" (public) boolean (("Object" "java" "lang")) () ("Object" "java" "lang"))
+        ("finalize" (protected) void () () ("Object" "java" "lang"))
+        ("getClass" (public final) ("Class" "java" "lang") () () ("Object" "java" "lang"))
+        ("hashCode" (public) int () () ("Object" "java" "lang"))
+        ("notify" (public final) void () () ("Object" "java" "lang"))
+        ("notifyAll" (public final) void () () ("Object" "java" "lang"))
+        ("toString" (public) ("String" "java" "lang") () () ("Object" "java" "lang"))
+        ("wait" (public final) void () (("InterruptedException" "java" "lang"))("Object" "java" "lang"))
+        ("wait" (public final) void (long) (("InterruptedException" "java" "lang"))("Object" "java" "lang"))
+        ("wait" (public final) void (long int) (("InterruptedException" "java" "lang")) ("Object" "java" "lang")))
+       ()
+       (("Object" "java" "lang"))
+       ()
+       "version1")
+
diff --git a/collects/profj/libs/java/lang/Object.ss b/collects/profj/libs/java/lang/Object.ss
new file mode 100644
index 0000000000..d60c0776e7
--- /dev/null
+++ b/collects/profj/libs/java/lang/Object.ss
@@ -0,0 +1,4 @@
+#cs
+(module Object mzscheme
+  (require "Object-composite.ss")
+  (provide ObjectI Object-Mix Object))
diff --git a/collects/profj/libs/java/lang/RuntimeException.java b/collects/profj/libs/java/lang/RuntimeException.java
new file mode 100644
index 0000000000..8fc9fb10aa
--- /dev/null
+++ b/collects/profj/libs/java/lang/RuntimeException.java
@@ -0,0 +1,102 @@
+/* RuntimeException.java -- root of all unchecked exceptions
+   Copyright (C) 1998, 1999, 2001, 2002 Free Software Foundation, Inc.
+
+This file is part of GNU Classpath.
+
+GNU Classpath is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU Classpath is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Classpath; see the file COPYING.  If not, write to the
+Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+02111-1307 USA.
+
+Linking this library statically or dynamically with other modules is
+making a combined work based on this library.  Thus, the terms and
+conditions of the GNU General Public License cover the whole
+combination.
+
+As a special exception, the copyright holders of this library give you
+permission to link this library with independent modules to produce an
+executable, regardless of the license terms of these independent
+modules, and to copy and distribute the resulting executable under
+terms of your choice, provided that you also meet, for each linked
+independent module, the terms and conditions of the license of that
+module.  An independent module is a module which is not derived from
+or based on this library.  If you modify this library, you may extend
+this exception to your version of the library, but you are not
+obligated to do so.  If you do not wish to do so, delete this
+exception statement from your version. */
+
+
+package java.lang;
+
+/**
+ * All exceptions which are subclasses of <code>RuntimeException</code>
+ * can be thrown at any time during the execution of a Java virtual machine.
+ * Methods which throw these exceptions are not required to declare them
+ * in their throws clause.
+ *
+ * @author Brian Jones
+ * @author Warren Levy <warrenl@cygnus.com>
+ * @author Eric Blake <ebb9@email.byu.edu>
+ * @status updated to 1.4
+ */
+public class RuntimeException extends Exception
+{
+  /**
+   * Compatible with JDK 1.0+.
+   */
+  private static final long serialVersionUID = -7034897190745766939L;
+
+  /**
+   * Create an exception without a message. The cause remains uninitialized.
+   *
+   * @see #initCause(Throwable)
+   */
+  public RuntimeException()
+  {
+  }
+
+  /**
+   * Create an exception with a message. The cause remains uninitialized.
+   *
+   * @param s the message string
+   * @see #initCause(Throwable)
+   */
+  public RuntimeException(String s)
+  {
+    super(s);
+  }
+
+  /**
+   * Create an exception with a message and a cause.
+   *
+   * @param s the message string
+   * @param cause the cause of this exception
+   * @since 1.4
+   */
+  public RuntimeException(String s, Throwable cause)
+  {
+    super(s, cause);
+  }
+
+  /**
+   * Create an exception with the given cause, and a message of
+   * <code>cause == null ? null : cause.toString()</code>.
+   *
+   * @param cause the cause of this exception
+   * @since 1.4
+   */
+  public RuntimeException(Throwable cause)
+  {
+    super(cause);
+  }
+}
diff --git a/collects/profj/libs/java/lang/RuntimeException.ss b/collects/profj/libs/java/lang/RuntimeException.ss
new file mode 100644
index 0000000000..848281a771
--- /dev/null
+++ b/collects/profj/libs/java/lang/RuntimeException.ss
@@ -0,0 +1,3 @@
+(module |RuntimeException| mzscheme
+  (require "Object-composite.ss")
+  (provide |RuntimeException|))
diff --git a/collects/profj/libs/java/lang/SecurityException.java b/collects/profj/libs/java/lang/SecurityException.java
new file mode 100644
index 0000000000..5fbdb4ae22
--- /dev/null
+++ b/collects/profj/libs/java/lang/SecurityException.java
@@ -0,0 +1,74 @@
+/* SecurityException.java -- thrown to indicate a security violation
+   Copyright (C) 1998, 1999, 2001, 2002 Free Software Foundation, Inc.
+
+This file is part of GNU Classpath.
+
+GNU Classpath is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU Classpath is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Classpath; see the file COPYING.  If not, write to the
+Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+02111-1307 USA.
+
+Linking this library statically or dynamically with other modules is
+making a combined work based on this library.  Thus, the terms and
+conditions of the GNU General Public License cover the whole
+combination.
+
+As a special exception, the copyright holders of this library give you
+permission to link this library with independent modules to produce an
+executable, regardless of the license terms of these independent
+modules, and to copy and distribute the resulting executable under
+terms of your choice, provided that you also meet, for each linked
+independent module, the terms and conditions of the license of that
+module.  An independent module is a module which is not derived from
+or based on this library.  If you modify this library, you may extend
+this exception to your version of the library, but you are not
+obligated to do so.  If you do not wish to do so, delete this
+exception statement from your version. */
+
+
+package java.lang;
+
+/**
+ * The security manager will throw this exception to indicate a security
+ * violation.  This can occur any time an operation is attempted which is
+ * deemed unsafe by the current security policies.
+ *
+ * @author Brian Jones
+ * @author Warren Levy <warrenl@cygnus.com>
+ * @see SecurityManager
+ * @status updated to 1.4
+ */
+public class SecurityException extends RuntimeException
+{
+  /**
+   * Compatible with JDK 1.0+.
+   */
+  private static final long serialVersionUID = 6878364983674394167L;
+
+  /**
+   * Create an exception without a message.
+   */
+  public SecurityException()
+  {
+  }
+
+  /**
+   * Create an exception with a message.
+   *
+   * @param s the message
+   */
+  public SecurityException(String s)
+  {
+    super(s);
+  }
+}
diff --git a/collects/profj/libs/java/lang/SecurityException.ss b/collects/profj/libs/java/lang/SecurityException.ss
new file mode 100644
index 0000000000..e072022ae0
--- /dev/null
+++ b/collects/profj/libs/java/lang/SecurityException.ss
@@ -0,0 +1,3 @@
+(module |SecurityException| mzscheme
+  (require "Object-composite.ss")
+  (provide |SecurityException|))
diff --git a/collects/profj/libs/java/lang/String.jinfo b/collects/profj/libs/java/lang/String.jinfo
new file mode 100644
index 0000000000..9f7e3b8e1b
--- /dev/null
+++ b/collects/profj/libs/java/lang/String.jinfo
@@ -0,0 +1,88 @@
+(class ("String" "java" "lang")
+       (public final)
+       #t     
+       (("CASE_INSENSITIVE_ORDER" (public static final) 
+                                  ("String" "java" "lang")
+                                  ("Comparator" "java" "util")))
+       (("String" (public) ctor () () ("String" "java" "lang"))
+        ("String" (public) ctor (("String" "java" "lang")) () ("String" "java" "lang"))
+        ("String" (public) ctor ((1 char)) () ("String" "java" "lang"))
+        ("String" (public) ctor ((1 char) int int) () ("String" "java" "lang"))
+        ("String" (public) ctor ((1 byte) int int ("String" "java" "lang")) (("UnsupportedEncodingException" "java" "io")) ("String" "java" "lang"))
+        ("String" (public) ctor ((1 byte) ("String" "java" "lang")) (("UnsupportedEncodingException" "java" "io")) ("String" "java" "lang"))
+        ("String" (public) ctor ((1 byte) int int) () ("String" "java" "lang"))
+        ("String" (public) ctor ((1 byte)) () ("String" "java" "lang"))
+        ("String" (public) ctor (("StringBuffer" "java" "lang")) () ("String" "java" "lang"))
+
+        ("length" (public) int () () ("String" "java" "lang"))
+        ("charAt" (public) char (int) () ("String" "java" "lang"))
+        ("getChars" (public) void (int int (1 char) int) () ("String" "java" "lang"))
+        ("getBytes" (public) (1 byte) (("String" "java" "lang")) (("UnsupportedEncodingException" "java" "io")) ("String" "java" "lang"))
+        ("getBytes" (public) (1 byte) () () ("String" "java" "lang"))
+        ("equals" (public) boolean (("Object" "java" "lang")) () ("String" "java" "lang"))
+        ("contentEquals" (public) boolean (("StringBuffer" "java" "lang")) () ("String" "java" "lang"))
+        ("equalsIgnoreCase" (public) boolean (("String" "java" "lang")) () ("String" "java" "lang"))
+        ("compareTo" (public) int (("String" "java" "lang")) () ("String" "java" "lang"))
+        ("compareTo" (public) int (("Object" "java" "lang")) () ("String" "java" "lang"))
+        ("compareToIgnoreCase" (public) int (("String" "java" "lang")) () ("String" "java" "lang"))
+        ("regionMatches" (public) boolean (int ("String" "java" "lang") int int) () ("String" "java" "lang"))
+        ("regionMatches" (public) boolean (boolean int ("String" "java" "lang") int int) () ("String" "java" "lang"))
+        ("startsWith" (public) boolean (("String" "java" "lang") int) () ("String" "java" "lang"))
+        ("startsWith" (public) boolean (("String" "java" "lang")) () ("String" "java" "lang"))
+        ("endsWith" (public) boolean (("String" "java" "lang")) () ("String" "java" "lang"))
+        ("hashCode" (public) int () () ("String" "java" "lang"))
+        ("indexOf" (public) int (int) () ("String" "java" "lang"))
+        ("indexOf" (public) int (int int) () ("String" "java" "lang"))
+        ("lastIndexOf" (public) int (int) () ("String" "java" "lang"))
+        ("lastIndexOf" (public) int (int int) () ("String" "java" "lang"))
+        ("indexOf" (public) int (("String" "java" "lang")) () ("String" "java" "lang"))
+        ("indexOf" (public) int (("String" "java" "lang") int) () ("String" "java" "lang"))
+        ("lastIndexOf" (public) int (("String" "java" "lang")) () ("String" "java" "lang"))
+        ("lastIndexOf" (public) int (("String" "java" "lang") int) () ("String" "java" "lang"))
+        ("substring" (public) ("String" "java" "lang") (int) () ("String" "java" "lang"))
+        ("substring" (public) ("String" "java" "lang") (int int) () ("String" "java" "lang"))
+        ("subSequence" (public) ("CharSequence" "java" "lang") (int int) () ("String" "java" "lang"))
+        ("concat" (public) ("String" "java" "lang") (("String" "java" "lang")) () ("String" "java" "lang"))
+        ("replace" (public) ("String" "java" "lang") (char char) () ("String" "java" "lang"))
+        ("matches" (public) boolean (("String" "java" "lang")) () ("String" "java" "lang"))
+        ("replaceFirst" (public) ("String" "java" "lang") (("String" "java" "lang") ("String" "java" "lang")) () ("String" "java" "lang"))
+        ("replaceAll" (public) ("String" "java" "lang") (("String" "java" "lang")("String" "java" "lang")) () ("String" "java" "lang"))
+        ("split" (public) (1 ("String" "java" "lang")) (("String" "java" "lang") int) () ("String" "java" "lang"))
+        ("split" (public) (1 ("String" "java" "lang")) (("String" "java" "lang")) () ("String" "java" "lang"))
+        ("toLowerCase" (public) ("String" "java" "lang") (("Locale" "java" "util")) () ("String" "java" "lang"))
+        ("toLowerCase" (public) ("String" "java" "lang") () () ("String" "java" "lang"))
+        ("toUpperCase" (public) ("String" "java" "lang") (("Locale" "java" "util")) () ("String" "java" "lang"))
+        ("toUpperCase" (public) ("String" "java" "lang") () () ("String" "java" "lang"))
+        ("trim" (public) ("String" "java" "lang") () () ("String" "java" "lang"))
+        ("toString" (public) ("String" "java" "lang") () () ("String" "java" "lang"))
+        ("toCharArray" (public) (1 char) () () ("String" "java" "lang"))
+        ("valueOf" (public static) ("String" "java" "lang") (("Object" "java" "lang")) () ("String" "java" "lang"))
+        ("valueOf" (public static) ("String" "java" "lang") ((1 char)) () ("String" "java" "lang"))
+        ("valueOf" (public static) ("String" "java" "lang") ((1 char) int int) () ("String" "java" "lang"))
+        ("copyValueOf" (public static) ("String" "java" "lang") ((1 char) int int) () ("String" "java" "lang"))
+        ("copyValueOf" (public static) ("String" "java" "lang") ((1 char)) () ("String" "java" "lang"))
+        ("valueOf" (public static) ("String" "java" "lang") (boolean) () ("String" "java" "lang"))
+        ("valueOf" (public static) ("String" "java" "lang") (char) () ("String" "java" "lang"))
+        ("valueOf" (public static) ("String" "java" "lang") (int) () ("String" "java" "lang"))
+        ("valueOf" (public static) ("String" "java" "lang") (long) () ("String" "java" "lang"))
+        ("valueOf" (public static) ("String" "java" "lang") (float) () ("String" "java" "lang"))
+        ("valueOf" (public static) ("String" "java" "lang") (double) () ("String" "java" "lang"))
+        ("intern" (public) ("String" "java" "lang") () () ("String" "java" "lang"))
+
+	("Object" (public) ctor () () ("Object" "java" "lang"))
+	("clone" (protected) ("Object" "java" "lang") () (("CloneNotSupportedException" "java" "lang"))("Object" "java" "lang"))
+        ("equals" (public) boolean (("Object" "java" "lang")) () ("Object" "java" "lang"))
+        ("finalize" (protected) void () () ("Object" "java" "lang"))
+        ("getClass" (public final) ("Class" "java" "lang") () () ("Object" "java" "lang"))
+        ("hashCode" (public) int () () ("Object" "java" "lang"))
+        ("notify" (public final) void () () ("Object" "java" "lang"))
+        ("notifyAll" (public final) void () () ("Object" "java" "lang"))
+        ("toString" (public) ("String" "java" "lang") () () ("Object" "java" "lang"))
+        ("wait" (public final) void () (("InterruptedException" "java" "lang"))("Object" "java" "lang"))
+        ("wait" (public final) void (long) (("InterruptedException" "java" "lang"))("Object" "java" "lang"))
+        ("wait" (public final) void (long int) (("InterruptedException" "java" "lang")) ("Object" "java" "lang")))
+ 
+       ()
+       (("Object" "java" "lang"))
+       (("Serializable" "java" "io") ("Comparable" "java" "lang") ("CharSequence" "java" "lang"))
+       "version1")
\ No newline at end of file
diff --git a/collects/profj/libs/java/lang/String.ss b/collects/profj/libs/java/lang/String.ss
new file mode 100644
index 0000000000..d4d46b9262
--- /dev/null
+++ b/collects/profj/libs/java/lang/String.ss
@@ -0,0 +1,7 @@
+#cs
+(module String mzscheme
+  (require "Object-composite.ss")
+  (provide make-java-string String String-valueOf-java.lang.Object String-valueOf-char1 
+           String-valueOf-char1-int-int String-copyValueOf-char1-int-int String-copyValueOf-char1
+           String-valueOf-boolean String-valueOf-char String-valueOf-int String-valueOf-long 
+           String-valueOf-float String-valueOf-double))
\ No newline at end of file
diff --git a/collects/profj/libs/java/lang/StringIndexOutOfBoundsException.java b/collects/profj/libs/java/lang/StringIndexOutOfBoundsException.java
new file mode 100644
index 0000000000..9a935ee8c4
--- /dev/null
+++ b/collects/profj/libs/java/lang/StringIndexOutOfBoundsException.java
@@ -0,0 +1,85 @@
+/* StringIndexOutOfBoundsException.java -- thrown to indicate attempt to
+   exceed string bounds
+   Copyright (C) 1998, 1999, 2001, 2002 Free Software Foundation, Inc.
+
+This file is part of GNU Classpath.
+
+GNU Classpath is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU Classpath is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Classpath; see the file COPYING.  If not, write to the
+Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+02111-1307 USA.
+
+Linking this library statically or dynamically with other modules is
+making a combined work based on this library.  Thus, the terms and
+conditions of the GNU General Public License cover the whole
+combination.
+
+As a special exception, the copyright holders of this library give you
+permission to link this library with independent modules to produce an
+executable, regardless of the license terms of these independent
+modules, and to copy and distribute the resulting executable under
+terms of your choice, provided that you also meet, for each linked
+independent module, the terms and conditions of the license of that
+module.  An independent module is a module which is not derived from
+or based on this library.  If you modify this library, you may extend
+this exception to your version of the library, but you are not
+obligated to do so.  If you do not wish to do so, delete this
+exception statement from your version. */
+
+
+package java.lang;
+
+/**
+ * This exception can be thrown to indicate an attempt to access an index
+ * which is out of bounds of a String. Any negative integer, and a positive
+ * integer greater than or equal to the size of the string, is an index
+ * which would be out of bounds.
+ *
+ * @author Brian Jones
+ * @author Warren Levy <warrenl@cygnus.com>
+ * @status updated to 1.4
+ */
+public class StringIndexOutOfBoundsException extends IndexOutOfBoundsException
+{
+  /**
+   * Compatible with JDK 1.0+.
+   */
+  private static final long serialVersionUID = -6762910422159637258L;
+
+  /**
+   * Create an exception without a message.
+   */
+  public StringIndexOutOfBoundsException()
+  {
+  }
+
+  /**
+   * Create an exception with a message.
+   *
+   * @param s the message
+   */
+  public StringIndexOutOfBoundsException(String s)
+  {
+    super(s);
+  }
+
+  /**
+   * Create an exception noting the illegal index.
+   *
+   * @param index the invalid index
+   */
+  public StringIndexOutOfBoundsException(int index)
+  {
+    super("String index out of range: " + index);
+  }
+}
diff --git a/collects/profj/libs/java/lang/StringIndexOutOfBoundsException.ss b/collects/profj/libs/java/lang/StringIndexOutOfBoundsException.ss
new file mode 100644
index 0000000000..9fcf79dcd6
--- /dev/null
+++ b/collects/profj/libs/java/lang/StringIndexOutOfBoundsException.ss
@@ -0,0 +1,3 @@
+(module |StringIndexOutOfBoundsException| mzscheme
+  (require "Object-composite.ss")
+  (provide |StringIndexOutOfBoundsException|))
diff --git a/collects/profj/libs/java/lang/System-native-methods.ss b/collects/profj/libs/java/lang/System-native-methods.ss
new file mode 100644
index 0000000000..136c413314
--- /dev/null
+++ b/collects/profj/libs/java/lang/System-native-methods.ss
@@ -0,0 +1,12 @@
+#cs
+(module System-native-methods mzscheme
+  
+  (provide (all-defined))
+  
+  (define (System-currentTimeMillis-native) (inexact->exact (floor (current-inexact-milliseconds))))
+  
+  (define (System-gc-native) (collect-garbage))
+  
+  (define (System-identityHashCode-java.lang.Object-native o) (eq-hash-code o))
+  
+  )
\ No newline at end of file
diff --git a/collects/profj/libs/java/lang/System.java b/collects/profj/libs/java/lang/System.java
new file mode 100644
index 0000000000..df6288f15e
--- /dev/null
+++ b/collects/profj/libs/java/lang/System.java
@@ -0,0 +1,11 @@
+package java.lang;
+
+public final class System {
+
+  public static native long currentTimeMillis();
+
+  public static native void gc();
+
+  public static native int identityHashCode( Object x);
+ 
+}
\ No newline at end of file
diff --git a/collects/profj/libs/java/lang/Throwable.jinfo b/collects/profj/libs/java/lang/Throwable.jinfo
new file mode 100644
index 0000000000..7540682bc6
--- /dev/null
+++ b/collects/profj/libs/java/lang/Throwable.jinfo
@@ -0,0 +1,38 @@
+(class ("Throwable" "java" "lang")
+       (public)
+       #t     
+       ()
+       (("Throwable" (public) ctor () () ("Throwable" "java" "lang"))
+	("Throwable" (public) ctor (("String" "java" "lang")) () ("Throwable" "java" "lang"))
+	("Throwable" (public) ctor (("String" "java" "lang") ("Throwable" "java" "lang")) () ("Throwable" "java" "lang"))
+	("Throwable" (public) ctor (("Throwable" "java" "lang")) () ("Throwable" "java" "lang"))
+
+	("fillInStackTrace" (public) ("Throwable" "java" "lang") () () ("Throwable" "java" "lang"))
+	("initCause" (public) ("Throwable" "java" "lang") (("Throwable" "java" "lang")) () ("Throwable" "java" "lang"))
+	("getCause" (public) ("Throwable" "java" "lang") () () ("Throwable" "java" "lang"))
+	("getLocalizedMessage" (public) ("String" "java" "lang") () () ("Throwable" "java" "lang"))
+	("getMessage" (public) ("String" "java" "lang") () () ("Throwable" "java" "lang"))
+	("getStackTrace" (public) (1 ("StackTraceElement" "java" "lang")) () () ("Throwable" "java" "lang"))
+	("printStackTrace" (public) void () () ("Throwable" "java" "lang"))
+	("printStackTrace" (public) void (("PrintString" "java" "io")) () ("Throwable" "java" "lang"))
+	("printStackTrace" (public) void (("PrintWriter" "java" "io")) () ("Throwable" "java" "lang"))
+	("setStackTrace" (public) void ((1 ("StackTraceElement" "java" "lang"))) () ("Throwable" "java" "lang"))
+	("toString" (public) ("String" "java" "lang") () () ("Throwable" "java" "lang"))
+
+	("Object" (public) ctor () () ("Object" "java" "lang"))
+	("clone" (protected) ("Object" "java" "lang") () (("CloneNotSupportedException" "java" "lang"))("Object" "java" "lang"))
+        ("equals" (public) boolean (("Object" "java" "lang")) () ("Object" "java" "lang"))
+        ("finalize" (protected) void () () ("Object" "java" "lang"))
+        ("getClass" (public final) ("Class" "java" "lang") () () ("Object" "java" "lang"))
+        ("hashCode" (public) int () () ("Object" "java" "lang"))
+        ("notify" (public final) void () () ("Object" "java" "lang"))
+        ("notifyAll" (public final) void () () ("Object" "java" "lang"))
+        ("toString" (public) ("String" "java" "lang") () () ("Object" "java" "lang"))
+        ("wait" (public final) void () (("InterruptedException" "java" "lang"))("Object" "java" "lang"))
+        ("wait" (public final) void (long) (("InterruptedException" "java" "lang"))("Object" "java" "lang"))
+        ("wait" (public final) void (long int) (("InterruptedException" "java" "lang")) ("Object" "java" "lang")))
+
+       ()
+       (("Object" "java" "lang"))
+       (("Serializable" "java" "io"))
+       "version1")
diff --git a/collects/profj/libs/java/lang/Throwable.ss b/collects/profj/libs/java/lang/Throwable.ss
new file mode 100644
index 0000000000..da1f1a5faf
--- /dev/null
+++ b/collects/profj/libs/java/lang/Throwable.ss
@@ -0,0 +1,5 @@
+#cs
+(module Throwable mzscheme
+  (require "Object-composite.ss")
+  (provide Throwable (struct java:exception (object))
+           exception-is-a? handle-exception create-java-exception))
\ No newline at end of file
diff --git a/collects/profj/libs/java/lang/UnsupportedOperationException.java b/collects/profj/libs/java/lang/UnsupportedOperationException.java
new file mode 100644
index 0000000000..6c00bef434
--- /dev/null
+++ b/collects/profj/libs/java/lang/UnsupportedOperationException.java
@@ -0,0 +1,73 @@
+/* UnsupportedOperationException.java -- thrown when an operation is not
+   supported
+   Copyright (C) 1998, 1999, 2001, 2002 Free Software Foundation, Inc.
+
+This file is part of GNU Classpath.
+
+GNU Classpath is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU Classpath is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Classpath; see the file COPYING.  If not, write to the
+Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+02111-1307 USA.
+
+Linking this library statically or dynamically with other modules is
+making a combined work based on this library.  Thus, the terms and
+conditions of the GNU General Public License cover the whole
+combination.
+
+As a special exception, the copyright holders of this library give you
+permission to link this library with independent modules to produce an
+executable, regardless of the license terms of these independent
+modules, and to copy and distribute the resulting executable under
+terms of your choice, provided that you also meet, for each linked
+independent module, the terms and conditions of the license of that
+module.  An independent module is a module which is not derived from
+or based on this library.  If you modify this library, you may extend
+this exception to your version of the library, but you are not
+obligated to do so.  If you do not wish to do so, delete this
+exception statement from your version. */
+
+
+package java.lang;
+
+/**
+ * This exception is thrown by an object when an operation is
+ * requested of it that it does not support.
+ *
+ * @author Warren Levy <warrenl@cygnus.com>
+ * @since 1.2
+ * @status updated to 1.4
+ */
+public class UnsupportedOperationException extends RuntimeException
+{
+  /**
+   * Compatible with JDK 1.2+.
+   */
+  private static final long serialVersionUID = -1242599979055084673L;
+
+  /**
+   * Create an exception without a message.
+   */
+  public UnsupportedOperationException()
+  {
+  }
+
+  /**
+   * Create an exception with a message.
+   *
+   * @param s the message
+   */
+  public UnsupportedOperationException(String s)
+  {
+    super(s);
+  }
+}
diff --git a/collects/profj/libs/java/lang/UnsupportedOperationException.ss b/collects/profj/libs/java/lang/UnsupportedOperationException.ss
new file mode 100644
index 0000000000..b79ccb2d6c
--- /dev/null
+++ b/collects/profj/libs/java/lang/UnsupportedOperationException.ss
@@ -0,0 +1,3 @@
+(module |UnsupportedOperationException| mzscheme
+  (require "Object-composite.ss")
+  (provide |UnsupportedOperationException|))
diff --git a/collects/profj/libs/java/lang/array.ss b/collects/profj/libs/java/lang/array.ss
new file mode 100644
index 0000000000..1409c4d9d3
--- /dev/null
+++ b/collects/profj/libs/java/lang/array.ss
@@ -0,0 +1,4 @@
+#cs
+(module array mzscheme
+  (require "Object-composite.ss")
+  (provide make-java-array is-java-array? make-runtime-type array->list))
diff --git a/collects/profj/libs/java/lang/compile-lang-syntax.ss b/collects/profj/libs/java/lang/compile-lang-syntax.ss
new file mode 100644
index 0000000000..5881ee93ed
--- /dev/null
+++ b/collects/profj/libs/java/lang/compile-lang-syntax.ss
@@ -0,0 +1,10 @@
+(module compile-lang-syntax mzscheme
+  (require-for-syntax "compile-lang.ss")
+  
+  (provide compile-rest-of-lang)
+  
+  (define-syntax (compile-rest-of-lang stx)
+    (syntax-case stx ()
+      [(_ names) (compile-exceptions (syntax names))]))
+
+  )
\ No newline at end of file
diff --git a/collects/profj/libs/java/lang/compile-lang.ss b/collects/profj/libs/java/lang/compile-lang.ss
new file mode 100644
index 0000000000..7c1d06af4d
--- /dev/null
+++ b/collects/profj/libs/java/lang/compile-lang.ss
@@ -0,0 +1,150 @@
+#cs
+(module compile-lang mzscheme
+  (require (lib "compile.ss" "profj")
+           (lib "list.ss")
+           (lib "file.ss")
+           (lib "pretty.ss"))
+ 
+  (provide compile-exceptions make-compilation-path)
+  
+  (define (get-path paths)
+    (if (null? paths) ""
+        (if (directory-exists? (build-path (car paths) "profj"))
+            (car paths)
+            (get-path (cdr paths)))))
+  
+  ;move-file-in: string string -> void
+  (define (move-file-in path file)
+    (let ((comp-path (build-path path "compiled" file))
+          (o-path (build-path path file)))
+      (cond
+        ((not (file-exists? comp-path)) (copy-file o-path comp-path))
+        ((< (file-or-directory-modify-seconds comp-path) (file-or-directory-modify-seconds o-path))
+         (delete-file comp-path)
+         (copy-file o-path comp-path))
+        (else (void)))))
+  
+  (let ((path (build-path (get-path (current-library-collection-paths)) "profj" "libs" "java" "lang")))
+    (with-handlers
+        ((exn:fail:filesystem? 
+          (lambda (exn)
+            (fprintf (current-error-port) 
+                     "Warning: ProfessorJ needs to be able to modify files in ~a in order to run correctly"
+                     (build-path path)))))
+
+      (unless (directory-exists? (build-path path "compiled"))
+        (make-directory (build-path path "compiled")))
+      (move-file-in path "Object.jinfo")
+      (move-file-in path "String.jinfo")
+      (move-file-in path "Throwable.jinfo")
+      (move-file-in path "Comparable.jinfo")
+      (for-each (lambda (file)
+                  (let ((fp (build-path path "compiled" file)))
+                    (when (file-exists? fp)
+                      (when (< (file-or-directory-modify-seconds fp) 
+                               (file-or-directory-modify-seconds (build-path path "compiled" "Object.jinfo")))
+                        (delete-file (build-path path "compiled" file))))))
+                (filter (lambda (file)
+                          (and
+                           (equal? "jinfo" (filename-extension file))
+                           (not (equal? file "Object.jinfo"))
+                           (not (equal? file "String.jinfo"))
+                           (not (equal? file "Throwable.jinfo"))
+                           (not (equal? file "Comparable.jinfo"))))
+                        (directory-list (build-path path "compiled"))))
+      ))
+  
+  ;flatten : list -> list
+  (define (flatten l)
+    (cond
+      ((null? l) null)
+      ((null? (car l)) (flatten (cdr l)))
+      ((pair? (car l)) (cons (car (car l))
+                             (flatten (cons (cdr (car l)) (cdr l)))))
+      (else (cons (car l) (flatten (cdr l))))))
+  
+  (define (make-compilation-path file-name)
+    (let* ((path (explode-path (normalize-path file-name)))
+           (rev-path (reverse path))
+           (file (car rev-path)))
+      (build-path (apply build-path (reverse (cdr rev-path)))
+                  "compiled" (path-replace-suffix file ".jinfo"))))
+  
+  (define (write-out-jinfos files jinfos)
+    (for-each (lambda (file-name jinfo)
+                (call-with-output-file (make-compilation-path file-name)
+                  (lambda (port) (write-record jinfo port))))
+              files jinfos))
+  
+  (define (clear-jinfos files)
+    (for-each (lambda (file-name)
+                (when (file-exists? (make-compilation-path file-name))
+                  (delete-file (make-compilation-path file-name))))
+              files))
+  
+  ;write-out-files : (list string) (list syntax) -> void
+  ;Writes out module stubes to file: assumes package lang for now
+  (define (write-out-files names bodies)
+    (for-each (lambda (name mod) 
+                (unless (file-exists? (string-append name ".ss"))
+                  (call-with-output-file (string-append name ".ss")
+                    (lambda (port) (pretty-print (syntax-object->datum mod) port))
+                    'truncate/replace)))
+              names
+              (map (lambda (name provide)
+                     (datum->syntax-object #f
+                                           `(module ,(string->symbol name) mzscheme
+                                              (require "Object-composite.ss")
+                                              ,provide)
+                                           #f))
+                   names (map get-provides bodies))))
+ 
+  (define (compile-exceptions so)
+    (set-syntax-location so)
+    (let* ((files (filter (lambda (f) (regexp-match "Exception[.]java$" (path->string f)))
+                          (directory-list (build-path (collection-path "profj") "libs" "java" "lang")))))
+      (let ((cur-dir (current-directory)))
+        (current-directory (build-path (collection-path "profj") "libs" "java" "lang"))
+        (clear-jinfos files)
+        (let* ((compiled (cdr (car (compile-files (list (list files (list "java" "lang"))) #f 'full))))
+               (compiled-exceptions (flatten (car compiled)))
+               (compiled-pieces (map (lambda (cu) (reassemble-pieces (car (compilation-unit-code cu))))
+                                     compiled-exceptions)))
+          (write-out-files (map car compiled-pieces) (map caddr compiled-pieces))
+          (write-out-jinfos files (car (cdr compiled)))
+          (current-directory cur-dir)
+          (datum->syntax-object so 
+                                `(begin ,@(filter (lambda (x) x)
+                                                  (map (lambda (r) (get-keepable-reqs r (syntax-object->datum so)))
+                                                       (apply append (map cadr compiled-pieces))))
+                                        ,@(map caddr compiled-pieces))
+                                #f)))))
+  
+  (define (reassemble-pieces stx)
+    (syntax-case stx ()
+      ((module name mzscheme
+         (require class runtime real ...)
+         begin) (list (symbol->string (syntax-object->datum (syntax name)))
+                      (syntax->list #'(real ...)) 
+                      (syntax begin)))))
+  
+  (define (get-keepable-reqs req names)
+    (syntax-case req (lib file)
+      ((lib name "profj" "libs" "java" "lang")
+       (and (not (member-name (syntax-object->datum (syntax name)) (cdr names))) req))
+      ((file name)
+       (and (not (member-name (syntax-object->datum (syntax name)) (cdr names))) req))
+      (name #f)))
+  
+  (define (member-name name names)
+    (cond
+      ((null? names) #f)
+      ((regexp-match (car names) name) #t)
+      (else (member-name name (cdr names)))))
+      
+  (define (get-provides body)
+    (syntax-case body ()
+      ((begin provide impl ...) (syntax provide))))
+           
+   
+  )
\ No newline at end of file
diff --git a/collects/profj/libs/java/lang/info.ss b/collects/profj/libs/java/lang/info.ss
new file mode 100644
index 0000000000..3063f26d50
--- /dev/null
+++ b/collects/profj/libs/java/lang/info.ss
@@ -0,0 +1,3 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "ProfessorJ: libs java lang")
+  #;(define install-collection "installer.ss"))
diff --git a/collects/profj/libs/java/lang/installer.ss b/collects/profj/libs/java/lang/installer.ss
new file mode 100644
index 0000000000..b4fbf5491c
--- /dev/null
+++ b/collects/profj/libs/java/lang/installer.ss
@@ -0,0 +1,24 @@
+(module installer mzscheme
+  (require (lib "compile.ss" "profj"))
+  (provide installer)
+
+  (define (installer plthome)
+    (let ([java.lang (build-path
+		      (collection-path "profj" "libs" "java" "lang"))])
+      (let ([javac
+	     (lambda (file)
+	       (parameterize ([current-load-relative-directory
+			       java.lang])
+		 (compile-java 'file
+			       'file
+			       'full
+			       (build-path java.lang file)
+			       #f
+			       #f)))])
+	(javac "Math.java")
+        (javac "System.java")
+	(javac "Number.java")
+        (javac "Double.java")
+        (javac "Float.java")
+        (javac "Boolean.java")
+        (javac "CharSequence.java")))))
diff --git a/collects/profj/libs/java/runtime.scm b/collects/profj/libs/java/runtime.scm
new file mode 100644
index 0000000000..e619e83cf9
--- /dev/null
+++ b/collects/profj/libs/java/runtime.scm
@@ -0,0 +1,172 @@
+;Java runtime utilities
+;Kathryn Gray 
+;July 2001
+
+;This module provides functions needed at runtime for compiled Java code
+
+#cs
+(module runtime mzscheme
+  
+  (require (lib "class.ss")
+           (lib "Object.ss" "profj" "libs" "java" "lang")
+           (lib "String.ss" "profj" "libs" "java" "lang")
+           (lib "Throwable.ss" "profj" "libs" "java" "lang")
+           (lib "ArithmeticException.ss" "profj" "libs" "java" "lang")
+           (lib "ClassCastException.ss" "profj" "libs" "java" "lang")
+           (lib "NullPointerException.ss" "profj" "libs" "java" "lang"))
+  
+  (provide convert-to-string shift not-equal bitwise mod divide-int 
+           divide-float and or cast-primitive cast-reference instanceof-array nullError)
+  
+  ;convert-to-string: (U string int real bool char Object) -> string
+  (define (convert-to-string data)
+    (cond
+      ((string? data) (make-java-string data))
+      ((number? data) (make-java-string (number->string data)))
+      ((boolean? data) 
+       (make-java-string (if data "true" "false")))
+      ((char? data) (make-java-string (string data)))
+      ((is-a? data ObjectI) (send data toString))
+      ((is-a? data object%) (make-java-string "SchemeObject"))
+      (else (error 'JavaRuntime:Internal_Error:convert-to-string
+                   (format "Convert to string given unsupported data: ~s" data)))))
+  
+  ;Performs arithmetic shifts on the given integers. 
+  ;shift: symbol int int -> int
+  (define (shift op left right)
+    (case op
+      ((<<) (arithmetic-shift left right))
+      ((>>) (arithmetic-shift left (- right)))
+      ((>>>) (+ (arithmetic-shift left (- right)) (arithmetic-shift 2 (bitwise-not right))))))
+ 
+  ;not-equal: num num -> bool
+  (define (not-equal left right) 
+    (if (number? left)
+        (not (= left right))
+        (not (eq? left right))))
+  
+  ;bitwise: symbol (U (int int) (bool bool)) -> int
+  (define (bitwise op left right)
+    (if (number? left)
+        (case op
+          ((&) (bitwise-and left right))
+          ((^) (bitwise-xor left right))
+          ((or) (bitwise-ior left right)))
+        (case op
+          ((&) (and left right))
+          ((^) (and (not (and left right))
+                    (or left right)))
+          ((or) (or left right)))))
+
+  ;divide-int: int int -> int
+  (define (divide-int left right)
+    (when (zero? right)
+      (create-java-exception ArithmeticException
+                             "Illegal division by zero"
+                             (lambda (exn msg)
+                               (send exn ArithmeticException-constructor-java.lang.String msg))
+                             (current-continuation-marks)))
+    (quotient left right))
+  
+  ;divide-float: float float -> float
+  (define (divide-float left right)
+    (when (zero? right)
+      (raise (create-java-exception ArithmeticException
+                                    "Illegal division by zero"
+                                    (lambda (exn msg)
+                                      (send exn ArithmeticException-constructor-java.lang.String msg))
+                                    (current-continuation-marks))))
+    (if (and (exact? left) (exact? right))
+        (exact->inexact (/ left right))
+        (/ left right)))
+     
+  ;modulo: number number -> number
+  (define (mod left right)
+    (when (zero? right)
+      (raise (create-java-exception ArithmeticException
+                                    "Illegal division by zero"
+                                    (lambda (exn msg)
+                                      (send exn ArithmeticException-constructor-java.lang.String msg))
+                                    (current-continuation-marks))))
+    (remainder left right))
+  
+  (define (raise-class-cast msg)
+    (raise (create-java-exception ClassCastException
+                                  msg
+                                  (lambda (exn msg)
+                                    (send exn ClassCastException-constructor-java.lang.String msg))
+                                  (current-continuation-marks))))
+  
+  (define (make-brackets dim)
+    (if (= 0 dim)
+        ""
+        (string-append "[]" (make-brackets (sub1 dim)))))
+  
+  ;cast-primitive: value symbol int -> value
+  (define (cast-primitive val type dim)
+    (printf "case-primitive ~a ~a ~n" val type)
+    (if (> dim 0)
+        (if (send val check-prim-type type dim)
+            val
+            (raise-class-cast 
+             (format "Cast to ~a~a failed for ~a" type (make-brackets dim) (send (convert-to-string val) get-mzscheme-string))))
+        (case type
+          ((boolean)
+           (unless (boolean? val)
+             (raise-class-cast (format "Cast to boolean failed for ~a" 
+                                       (send (convert-to-string val) get-mzscheme-string))))
+           val)
+          ((byte short int long)
+           (cond
+             ((and (number? val) (inexact? val)) (truncate (inexact->exact val)))
+             ((and (number? val) (exact? val) (rational? val)) (truncate val))
+             ((and (number? val) (exact? val)) val)
+             ((char? val) (char->integer val))
+             (else (raise-class-cast (format "Cast to ~a failed for ~a"
+                                             type
+                                             (send (convert-to-string val) get-mzscheme-string))))))
+          ((char)
+           (cond
+             ((char? val) val)
+             ((and (number? val) (exact? val)) (integer->char val))
+             (else (raise-class-cast (format "Cast to character failed for ~a"
+                                             (send (convert-to-string val) get-mzscheme-string))))))
+          ((float double)
+           (cond
+             ((number? val) val)
+             ((char? val) (char->integer val))
+             (else (raise-class-cast (format "Cast to ~a failed for ~a" type
+                                             (send (convert-to-string val) get-mzscheme-string)))))))))
+  
+  ;cast-reference: value class int symbol-> value
+  (define (cast-reference val type dim name)
+    (if (> dim 0)
+        (if (send val check-ref-type type dim)
+            val
+            (raise-class-cast
+             (format "Cast to ~a~a failed for ~a" name (make-brackets dim) (send (convert-to-string val) get-mzscheme-string))))
+        (cond
+          ((and (eq? Object type) (is-a? val ObjectI)) val)
+          ((is-a? val type) val)
+          (else (raise-class-cast (format "Cast to ~a failed for ~a" name (send val my-name)))))))
+  
+  ;instanceof-array: bool val (U class sym) int -> bool
+  (define (instanceof-array prim? val type dim)
+    (if prim?
+        (send val check-prim-type type dim)
+        (send val check-ref-type type dim)))
+  
+  ;nullError: symbol -> void
+  (define (nullError kind)
+    (raise
+     (create-java-exception NullPointerException
+                            (case kind
+                              ((method) 
+                               "This value cannot access a method to call as it is null and therefore has no methods")
+                              ((field) 
+                               "This value cannot retrieve a field as it is null and therefore has no fields"))
+                            (lambda (exn msg)
+                              (send exn NullPointerException-constructor-java.lang.String msg))
+                            (current-continuation-marks))))
+  
+  )
\ No newline at end of file
diff --git a/collects/profj/libs/java/util/Random.java b/collects/profj/libs/java/util/Random.java
new file mode 100644
index 0000000000..6e7d8cf249
--- /dev/null
+++ b/collects/profj/libs/java/util/Random.java
@@ -0,0 +1,429 @@
+/* Random.java -- a pseudo-random number generator
+   Copyright (C) 1998, 1999, 2000, 2001, 2002 Free Software Foundation, Inc.
+
+This file is part of GNU Classpath.
+
+GNU Classpath is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU Classpath is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Classpath; see the file COPYING.  If not, write to the
+Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+02111-1307 USA.
+
+Linking this library statically or dynamically with other modules is
+making a combined work based on this library.  Thus, the terms and
+conditions of the GNU General Public License cover the whole
+combination.
+
+As a special exception, the copyright holders of this library give you
+permission to link this library with independent modules to produce an
+executable, regardless of the license terms of these independent
+modules, and to copy and distribute the resulting executable under
+terms of your choice, provided that you also meet, for each linked
+independent module, the terms and conditions of the license of that
+module.  An independent module is a module which is not derived from
+or based on this library.  If you modify this library, you may extend
+this exception to your version of the library, but you are not
+obligated to do so.  If you do not wish to do so, delete this
+exception statement from your version. */
+
+
+package java.util;
+
+import java.io.Serializable;
+
+/**
+ * This class generates pseudorandom numbers.  It uses the same
+ * algorithm as the original JDK-class, so that your programs behave
+ * exactly the same way, if started with the same seed.
+ *
+ * The algorithm is described in <em>The Art of Computer Programming,
+ * Volume 2</em> by Donald Knuth in Section 3.2.1.  It is a 48-bit seed,
+ * linear congruential formula.
+ *
+ * If two instances of this class are created with the same seed and
+ * the same calls to these classes are made, they behave exactly the
+ * same way.  This should be even true for foreign implementations
+ * (like this), so every port must use the same algorithm as described
+ * here.
+ *
+ * If you want to implement your own pseudorandom algorithm, you
+ * should extend this class and overload the <code>next()</code> and
+ * <code>setSeed(long)</code> method.  In that case the above
+ * paragraph doesn't apply to you.
+ *
+ * This class shouldn't be used for security sensitive purposes (like
+ * generating passwords or encryption keys.  See <code>SecureRandom</code>
+ * in package <code>java.security</code> for this purpose.
+ *
+ * For simple random doubles between 0.0 and 1.0, you may consider using
+ * Math.random instead.
+ *
+ * @see java.security.SecureRandom
+ * @see Math#random()
+ * @author Jochen Hoenicke
+ * @author Eric Blake (ebb9@email.byu.edu)
+ * @status updated to 1.4
+ */
+public class Random implements Serializable
+{
+  /**
+   * True if the next nextGaussian is available.  This is used by
+   * nextGaussian, which generates two gaussian numbers by one call,
+   * and returns the second on the second call.
+   *
+   * @serial whether nextNextGaussian is available
+   * @see #nextGaussian()
+   * @see #nextNextGaussian
+   */
+  private boolean haveNextNextGaussian;
+
+  /**
+   * The next nextGaussian, when available.  This is used by nextGaussian,
+   * which generates two gaussian numbers by one call, and returns the
+   * second on the second call.
+   *
+   * @serial the second gaussian of a pair
+   * @see #nextGaussian()
+   * @see #haveNextNextGaussian
+   */
+  private double nextNextGaussian;
+
+  /**
+   * The seed.  This is the number set by setSeed and which is used
+   * in next.
+   *
+   * @serial the internal state of this generator
+   * @see #next()
+   */
+  private long seed;
+
+  /**
+   * Compatible with JDK 1.0+.
+   */
+  private static final long serialVersionUID = 3905348978240129619L;
+
+  /**
+   * Creates a new pseudorandom number generator.  The seed is initialized
+   * to the current time, as if by
+   * <code>setSeed(System.currentTimeMillis());</code>.
+   *
+   * @see System#currentTimeMillis()
+   */
+  public Random()
+  {
+    this(System.currentTimeMillis());
+  }
+
+  /**
+   * Creates a new pseudorandom number generator, starting with the
+   * specified seed, using <code>setSeed(seed);</code>.
+   *
+   * @param seed the initial seed
+   */
+  public Random(long seed)
+  {
+    setSeed(seed);
+  }
+
+  /**
+   * Sets the seed for this pseudorandom number generator.  As described
+   * above, two instances of the same random class, starting with the
+   * same seed, should produce the same results, if the same methods
+   * are called.  The implementation for java.util.Random is:
+   *
+<pre>public synchronized void setSeed(long seed)
+{
+  this.seed = (seed ^ 0x5DEECE66DL) & ((1L &lt;&lt; 48) - 1);
+  haveNextNextGaussian = false;
+}</pre>
+   *
+   * @param seed the new seed
+   */
+  public synchronized void setSeed(long seed)
+  {
+    this.seed = (seed ^ 0x5DEECE66DL) & ((1L << 48) - 1);
+    haveNextNextGaussian = false;
+  }
+
+  /**
+   * Generates the next pseudorandom number.  This returns
+   * an int value whose <code>bits</code> low order bits are
+   * independent chosen random bits (0 and 1 are equally likely).
+   * The implementation for java.util.Random is:
+   *
+<pre>protected synchronized int next(int bits)
+{
+  seed = (seed * 0x5DEECE66DL + 0xBL) & ((1L &lt;&lt; 48) - 1);
+  return (int) (seed &gt;&gt;&gt; (48 - bits));
+}</pre>
+   *
+   * @param bits the number of random bits to generate, in the range 1..32
+   * @return the next pseudorandom value
+   * @since 1.1
+   */
+  protected synchronized int next(int bits)
+  {
+    seed = (seed * 0x5DEECE66DL + 0xBL) & ((1L << 48) - 1);
+    return (int) (seed >>> (48 - bits));
+  }
+
+  /**
+   * Fills an array of bytes with random numbers.  All possible values
+   * are (approximately) equally likely.
+   * The JDK documentation gives no implementation, but it seems to be:
+   *
+<pre>public void nextBytes(byte[] bytes)
+{
+  for (int i = 0; i &lt; bytes.length; i += 4)
+  {
+    int random = next(32);
+    for (int j = 0; i + j &lt; bytes.length && j &lt; 4; j++)
+    {
+      bytes[i+j] = (byte) (random & 0xff)
+      random &gt;&gt;= 8;
+    }
+  }
+}</pre>
+   *
+   * @param bytes the byte array that should be filled
+   * @throws NullPointerException if bytes is null
+   * @since 1.1
+   */
+  public void nextBytes(byte[] bytes)
+  {
+    int random;
+    // Do a little bit unrolling of the above algorithm.
+    int max = bytes.length & ~0x3;
+    for (int i = 0; i < max; i += 4)
+      {
+        random = next(32);
+        bytes[i] = (byte) random;
+        bytes[i + 1] = (byte) (random >> 8);
+        bytes[i + 2] = (byte) (random >> 16);
+        bytes[i + 3] = (byte) (random >> 24);
+      }
+    if (max < bytes.length)
+      {
+        random = next(32);
+        for (int j = max; j < bytes.length; j++)
+          {
+            bytes[j] = (byte) random;
+            random >>= 8;
+          }
+      }
+  }
+
+  /**
+   * Generates the next pseudorandom number.  This returns
+   * an int value whose 32 bits are independent chosen random bits
+   * (0 and 1 are equally likely).  The implementation for
+   * java.util.Random is:
+   * 
+<pre>public int nextInt()
+{
+  return next(32);
+}</pre>
+   *
+   * @return the next pseudorandom value
+   */
+  public int nextInt()
+  {
+    return next(32);
+  }
+
+  /**
+   * Generates the next pseudorandom number.  This returns
+   * a value between 0(inclusive) and <code>n</code>(exclusive), and
+   * each value has the same likelihodd (1/<code>n</code>).
+   * (0 and 1 are equally likely).  The implementation for
+   * java.util.Random is:
+   * 
+<pre>
+public int nextInt(int n)
+{
+  if (n &lt;= 0)
+    throw new IllegalArgumentException("n must be positive");
+
+  if ((n & -n) == n)  // i.e., n is a power of 2
+    return (int)((n * (long) next(31)) &gt;&gt; 31);
+
+  int bits, val;
+  do
+  {
+    bits = next(31);
+    val = bits % n;
+  }
+  while(bits - val + (n-1) &lt; 0);
+
+  return val;
+}</pre>
+   *   
+   * <p>This algorithm would return every value with exactly the same
+   * probability, if the next()-method would be a perfect random number
+   * generator.
+   *
+   * The loop at the bottom only accepts a value, if the random
+   * number was between 0 and the highest number less then 1<<31,
+   * which is divisible by n.  The probability for this is high for small
+   * n, and the worst case is 1/2 (for n=(1<<30)+1).
+   *
+   * The special treatment for n = power of 2, selects the high bits of
+   * the random number (the loop at the bottom would select the low order
+   * bits).  This is done, because the low order bits of linear congruential
+   * number generators (like the one used in this class) are known to be
+   * ``less random'' than the high order bits.
+   *
+   * @param n the upper bound
+   * @throws IllegalArgumentException if the given upper bound is negative
+   * @return the next pseudorandom value
+   * @since 1.2
+   */
+  public int nextInt(int n)
+  {
+    if (n <= 0)
+      throw new IllegalArgumentException("n must be positive");
+    if ((n & -n) == n) // i.e., n is a power of 2
+      return (int) ((n * (long) next(31)) >> 31);
+    int bits, val;
+    do
+      {
+        bits = next(31);
+        val = bits % n;
+      }
+    while (bits - val + (n - 1) < 0);
+    return val;
+  }
+
+  /**
+   * Generates the next pseudorandom long number.  All bits of this
+   * long are independently chosen and 0 and 1 have equal likelihood.
+   * The implementation for java.util.Random is:
+   *
+<pre>public long nextLong()
+{
+  return ((long) next(32) &lt;&lt; 32) + next(32);
+}</pre>
+   *
+   * @return the next pseudorandom value
+   */
+  public long nextLong()
+  {
+    return ((long) next(32) << 32) + next(32);
+  }
+
+  /**
+   * Generates the next pseudorandom boolean.  True and false have
+   * the same probability.  The implementation is:
+   * 
+<pre>public boolean nextBoolean()
+{
+  return next(1) != 0;
+}</pre>
+   *
+   * @return the next pseudorandom boolean
+   * @since 1.2
+   */
+  public boolean nextBoolean()
+  {
+    return next(1) != 0;
+  }
+
+  /**
+   * Generates the next pseudorandom float uniformly distributed
+   * between 0.0f (inclusive) and 1.0f (exclusive).  The
+   * implementation is as follows.
+   * 
+<pre>public float nextFloat()
+{
+  return next(24) / ((float)(1 &lt;&lt; 24));
+}</pre>
+   *
+   * @return the next pseudorandom float
+   */
+  public float nextFloat()
+  {
+    return next(24) / (float) (1 << 24);
+  }
+
+  /**
+   * Generates the next pseudorandom double uniformly distributed
+   * between 0.0 (inclusive) and 1.0 (exclusive).  The
+   * implementation is as follows.
+   *
+<pre>public double nextDouble()
+{
+  return (((long) next(26) &lt;&lt; 27) + next(27)) / (double)(1L &lt;&lt; 53);
+}</pre>
+   *
+   * @return the next pseudorandom double
+   */
+  public double nextDouble()
+  {
+    return (((long) next(26) << 27) + next(27)) / (double) (1L << 53);
+  }
+
+  /**
+   * Generates the next pseudorandom, Gaussian (normally) distributed
+   * double value, with mean 0.0 and standard deviation 1.0.
+   * The algorithm is as follows.
+   * 
+<pre>public synchronized double nextGaussian()
+{
+  if (haveNextNextGaussian)
+  {
+    haveNextNextGaussian = false;
+    return nextNextGaussian;
+  }
+  else
+  {
+    double v1, v2, s;
+    do
+    {
+      v1 = 2 * nextDouble() - 1; // between -1.0 and 1.0
+      v2 = 2 * nextDouble() - 1; // between -1.0 and 1.0
+      s = v1 * v1 + v2 * v2;
+    }
+    while (s >= 1);
+
+    double norm = Math.sqrt(-2 * Math.log(s) / s);
+    nextNextGaussian = v2 * norm;
+    haveNextNextGaussian = true;
+    return v1 * norm;
+  }
+}</pre>
+   *
+   * <p>This is described in section 3.4.1 of <em>The Art of Computer
+   * Programming, Volume 2</em> by Donald Knuth.
+   *
+   * @return the next pseudorandom Gaussian distributed double
+   */
+  public synchronized double nextGaussian()
+  {
+    if (haveNextNextGaussian)
+      {
+        haveNextNextGaussian = false;
+        return nextNextGaussian;
+      }
+    double v1, v2, s;
+    do
+      {
+        v1 = 2 * nextDouble() - 1; // Between -1.0 and 1.0.
+        v2 = 2 * nextDouble() - 1; // Between -1.0 and 1.0.
+        s = v1 * v1 + v2 * v2;
+      }
+    while (s >= 1);
+    double norm = Math.sqrt(-2 * Math.log(s) / s);
+    nextNextGaussian = v2 * norm;
+    haveNextNextGaussian = true;
+    return v1 * norm;
+  }
+}
diff --git a/collects/profj/libs/java/util/info.ss b/collects/profj/libs/java/util/info.ss
new file mode 100644
index 0000000000..658676620f
--- /dev/null
+++ b/collects/profj/libs/java/util/info.ss
@@ -0,0 +1,3 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "ProfessorJ: libs java util")
+  #;(define install-collection "installer.ss"))
\ No newline at end of file
diff --git a/collects/profj/libs/java/util/installer.ss b/collects/profj/libs/java/util/installer.ss
new file mode 100644
index 0000000000..4ec660e72b
--- /dev/null
+++ b/collects/profj/libs/java/util/installer.ss
@@ -0,0 +1,18 @@
+(module installer mzscheme
+  (require (lib "compile.ss" "profj"))
+  (provide installer)
+
+  (define (installer plthome)
+    (let ([java.util (build-path
+		      (collection-path "profj" "libs" "java" "util"))])
+      (let ([javac
+	     (lambda (file)
+	       (parameterize ([current-load-relative-directory
+			       java.util])
+		 (compile-java 'file
+			       'file
+			       'full
+			       (build-path java.util file)
+			       #f
+			       #f)))])
+	(javac "Random.java")))))
\ No newline at end of file
diff --git a/collects/profj/parameters.ss b/collects/profj/parameters.ss
new file mode 100644
index 0000000000..f21f8ca31e
--- /dev/null
+++ b/collects/profj/parameters.ss
@@ -0,0 +1,40 @@
+(module parameters mzscheme
+  (provide (all-defined))
+  
+  ;Stores the classpath for the current run
+  (define classpath (make-parameter null))
+  
+  ;Stores syntax-oddness for datum->syntax-object
+  (define syntax-location (make-parameter #f))
+  
+  ;Stores asts of other packages
+  (define packages (make-parameter null))
+  
+  ;Stores asts of other classes
+  (define check-list (make-parameter null))
+  
+  ;Stores a symbol representing the class from which main should be called (#f for none)
+  (define main (make-parameter #f))
+  
+  ;Stores a boolean indicating if compilation is directed at a file
+  (define to-file (make-parameter #f))
+  
+  ;Stores an integer offset for interactions offset
+  (define interactions-offset (make-parameter 0))
+  
+  ;Stores if we are the execution window executing
+  (define execution? (make-parameter #f))
+  
+  ;Stores the error function to trigger for parsing
+  (define determine-error (make-parameter (lambda () #t)))
+  
+  ;Stores a function which when called will produce (->token) of lexed tokens
+  (define lex-stream (make-parameter (lambda () null)))
+  
+  ;Stores whether dynamic typing is allowed
+  (define dynamic? (make-parameter #f))
+  
+  ;Stores whether it is permitted to use Scheme functions and other values
+  (define scheme-ok? (make-parameter #f))
+  
+  ) 
diff --git a/collects/profj/parser.ss b/collects/profj/parser.ss
new file mode 100644
index 0000000000..dd00037547
--- /dev/null
+++ b/collects/profj/parser.ss
@@ -0,0 +1,139 @@
+#cs
+(module parser mzscheme
+  (require "parsers/full-parser.ss"
+           "parsers/advanced-parser.ss"
+           "parsers/intermediate-parser.ss"
+           "parsers/beginner-parser.ss"
+           "parsers/general-parsing.ss"
+           "parsers/parse-error.ss"
+           "parsers/lexer.ss"
+           "ast.ss"
+           "parameters.ss")
+  
+  (require (all-except (lib "lex.ss" "parser-tools") input-port)
+           (lib "readerr.ss" "syntax"))
+  (provide parse parse-interactions parse-expression parse-type parse-name lex-stream)
+  
+  ;function to lex in the entire port
+  ;lex-port: port string -> (list position-token)
+  (define (lex-port port filename)
+    (port-count-lines! port)
+    (file-path filename)
+    (letrec ((getter
+              (lambda (acc)
+                (let ((cur-tok (get-token port)))
+                  (if (eq? 'EOF (position-token-token cur-tok))
+                      (cons cur-tok acc)
+                      (getter (cons cur-tok acc)))))))
+      (reverse! (getter null))))
+  ;getter: (list position-token) -> (-> position-token)
+  (define (getter token-list)
+    (lambda ()
+      (begin0 (car token-list)
+              (unless (null? (cdr token-list))
+                (set! token-list (cdr token-list))))))
+
+  ;main parsing function
+  
+  ;parse: port string symbol -> package
+  (define (parse is filename level)
+    (let* ((lexed (lex-port is filename))
+           (my-get (getter lexed)))
+      (lex-stream (lambda () (getter lexed)))
+      (case level
+        ((beginner) 
+         (determine-error find-beginner-error) 
+         (parse-beginner my-get))
+        ((intermediate) 
+         (determine-error find-intermediate-error)
+         (parse-intermediate my-get))
+        ((advanced) 
+         (determine-error find-advanced-error)
+         (parse-advanced my-get))
+        ((full) (parse-full my-get)))))
+  
+  ;parse-interactions: port string symbol -> (U Statement Expression)
+  (define (parse-interactions is loc level)
+    (let* ((lexed (lex-port is loc))
+           (my-get (getter lexed)))
+      (lex-stream (lambda () (getter lexed)))
+      (case level
+        ((beginner) 
+         (determine-error find-beginner-error-interactions)
+         (parse-beginner-interactions my-get))
+        ((intermediate) 
+         (determine-error find-intermediate-error-interactions)
+         (parse-intermediate-interactions my-get))
+        ((advanced) 
+         (determine-error find-advanced-error-interactions)
+         (parse-advanced-interactions my-get))
+        ((full) (parse-full-interactions my-get)))))
+  
+  ;parse-expression: port string symbol -> Expression
+  (define (parse-expression is loc level)
+    (let* ((lexed (lex-port is loc))
+           (my-get (getter lexed)))
+      (lex-stream (lambda () (getter lexed)))
+      (case level
+        ((beginner)
+         (determine-error find-beginner-error-expression)
+         (parse-beginner-expression my-get))
+        ((intermediate)
+         (determine-error find-intermediate-error-expression)
+         (parse-intermediate-expression my-get))
+        ((advanced)
+         (determine-error find-advanced-error-expression)
+         (parse-advanced-expression my-get))
+        ((full) (parse-full-expression my-get)))))
+
+  ;parse-type: port string symbol -> type-spec
+  (define (parse-type is loc level)
+    (let* ((lexed (lex-port is loc))
+           (my-get (getter lexed)))
+      (lex-stream (lambda () (getter lexed)))
+      (case level
+        ((beginner)
+         (determine-error find-beginner-error-type)
+         (parse-beginner-type my-get))
+        ((intermediate)
+         (determine-error find-intermediate-error-type)
+         (parse-intermediate-type my-get))
+        ((advanced)
+         (determine-error find-advanced-error-type)
+         (parse-advanced-type my-get))
+        ((full) (parse-full-type my-get)))))
+  
+  ;parse-name: port string -> id
+  ;Might not return if a parse-error occurs
+  (define (parse-name is loc)
+    (let* ((lexed (lex-port is loc))
+           (get (getter lexed))
+           (parse-error 
+            (lambda (message start stop)
+              (raise-read-error message
+                                loc
+                                (position-line start)
+                                (position-col start)
+                                (position-offset start)
+                                (- (position-offset stop) (position-offset start)))))
+           (first (get))
+           (next (get))
+           (first-tok (position-token-token first))
+           (first-start (position-token-start-pos first))
+           (first-end (position-token-end-pos first))
+           (next-tok (position-token-token next)))
+        (cond
+          ((and (id-token? first-tok) (eof? next-tok))
+           (make-id (token-value first-tok)
+                    (make-src (position-line first-start)
+                              (position-col first-start)
+                              (position-offset first-start)
+                              (- (position-offset first-end) (position-offset first-start))
+                              loc)))
+          ((not (eof? next-tok))
+           (parse-error "Only one name may appear here, found excess content" 
+                        (position-token-start-pos next) (position-token-end-pos next)))
+          (else (parse-error "Only identifiars may be names: not a valid identifier" 
+                             first-start first-end)))))
+  
+  )
diff --git a/collects/profj/parsers/advanced-parser.ss b/collects/profj/parsers/advanced-parser.ss
new file mode 100644
index 0000000000..05b616d620
--- /dev/null
+++ b/collects/profj/parsers/advanced-parser.ss
@@ -0,0 +1,804 @@
+(module advanced-parser mzscheme
+
+  (require "general-parsing.ss"
+           "lexer.ss"
+           "../ast.ss"
+           "../parameters.ss")
+  
+  (require (lib "yacc.ss" "parser-tools")
+           (all-except (lib "lex.ss" "parser-tools") input-port)
+           (lib "readerr.ss" "syntax"))
+  
+  ;(require (lib "build-grammar.ss" "tester"))
+  
+  (define-syntax testing-parser
+    (syntax-rules ()
+      ((_ parse-info ...) (parser parse-info ...))))
+  
+  (provide parse-advanced parse-advanced-interactions parse-advanced-expression parse-advanced-type)
+  ;(provide advanced-grammar)  
+  
+  (define parsers
+    (parser
+     (start CompilationUnit AdvancedInteractions VariableInitializer Type)
+     ;;(debug "parser.output")
+     (tokens java-vals special-toks Keywords Separators EmptyLiterals Operators)
+     ;(terminals val-tokens special-tokens keyword-tokens separator-tokens literal-tokens operator-tokens)
+     (error (lambda (tok-ok name val start-pos end-pos)
+              (if ((determine-error))
+                  (raise-read-error (format "Parse error near <~a:~a>" name val)
+                                    (file-path)
+                                    (position-line start-pos)
+                                    (position-col start-pos)
+                                    (+ (position-offset start-pos) (interactions-offset))
+                                    (- (position-offset end-pos)
+                                       (position-offset start-pos))))))
+
+     (end EOF)
+     (src-pos)
+     
+     (grammar
+      
+      ;; 19.3
+      (Literal
+       [(INTEGER_LIT) (make-literal 'int (build-src 1) $1)]
+       [(LONG_LIT) (make-literal 'long (build-src 1) $1)]
+       [(FLOAT_LIT) (make-literal 'float (build-src 1) $1)]
+       [(DOUBLE_LIT) (make-literal 'double (build-src 1)  $1)]
+       [(TRUE_LIT) (make-literal 'boolean (build-src 1) #t)]
+       [(FALSE_LIT) (make-literal 'boolean (build-src 1) #f)]
+       [(CHAR_LIT) (make-literal 'char (build-src 1) $1)]
+       [(STRING_LIT) (make-literal 'string 
+                                   (make-src (position-line $1-start-pos)
+                                             (position-col $1-start-pos)
+                                             (+ (position-offset $1-start-pos) (interactions-offset))
+                                             (- (position-offset (cadr $1)) (position-offset $1-start-pos))
+                                             (file-path))
+                                   (car $1))]
+       [(NULL_LIT) (make-literal 'null (build-src 1) #f)])
+      
+      ;; 19.4
+      (Type
+       [(PrimitiveType) $1]
+       [(ReferenceType) $1])
+      
+      (PrimitiveType
+       [(NumericType) $1]
+       [(boolean) (make-type-spec 'boolean 0 (build-src 1))])
+      
+      (NumericType
+       [(IntegralType) $1]
+       [(FloatingPointType) $1])
+      
+      (IntegralType
+       [(byte) (make-type-spec 'byte 0 (build-src 1))]
+       [(short) (make-type-spec 'short 0 (build-src 1))]
+       [(int) (make-type-spec 'int 0 (build-src 1))]
+       [(long) (make-type-spec 'long 0 (build-src 1))]
+       [(char) (make-type-spec 'char 0 (build-src 1))])
+      
+      (FloatingPointType
+       [(float) (make-type-spec 'float 0 (build-src 1))]
+       [(double) (make-type-spec 'double 0 (build-src 1))])
+      
+      (ReferenceType
+       [(Name) (make-type-spec $1 0 (build-src 1))]
+       [(ArrayType) $1]
+       )
+            
+      (ClassOrInterfaceType
+       [(Name) $1])
+      
+      (ClassType
+       [(ClassOrInterfaceType) $1])
+      
+      (InterfaceType
+       [(ClassOrInterfaceType) $1])
+      
+      (ArrayType
+       [(PrimitiveType Dims) (make-type-spec (type-spec-name $1) $2 (build-src 2))]
+       [(Name Dims) (make-type-spec $1 $2 (build-src 2))])
+
+      ;;19.5
+      (Name
+       [(IDENTIFIER) (make-name (make-id $1 (build-src 1)) null (build-src 1))]
+       [(Name PERIOD IDENTIFIER)
+	(make-name (make-id $3 (build-src 3 3)) 
+		       (append (name-path $1) (list (name-id $1)))
+		       (build-src 3))])
+      ;; 19.6
+      (CompilationUnit
+       [(PackageDeclaration ImportDeclarations TypeDeclarations) 
+        (make-package $1 (reverse $2) (reverse $3))]
+       [(ImportDeclarations TypeDeclarations) (make-package #f (reverse $1) (reverse $2))]
+       [(PackageDeclaration TypeDeclarations) (make-package $1 null (reverse $2))]
+       [(PackageDeclaration ImportDeclarations) (make-package $1 (reverse $2) null)]
+       [(PackageDeclaration) (make-package $1 null null)]
+       [(ImportDeclarations) (make-package #f (reverse $1) null)]
+       [(TypeDeclarations) (make-package #f null (reverse $1))]
+       [() (make-package #f null null)])
+      
+      (AdvancedInteractions
+       [(Statement) $1]
+       [(FieldDeclaration) $1]
+       [(Expression) $1]
+       [() null])
+      
+      (ImportDeclarations
+       [(ImportDeclaration) (list $1)]
+       [(ImportDeclarations ImportDeclaration) (cons $2 $1)])
+
+      (TypeDeclarations
+       [(TypeDeclaration) (if $1
+                              (list $1)
+                              null)]
+       [(TypeDeclarations TypeDeclaration) (if $2
+                                               (cons $2 $1)
+                                               $1)])
+      
+      (PackageDeclaration
+       [(package Name SEMI_COLON) $2])
+      
+      (ImportDeclaration
+       [(SingleTypeImportDeclaration) $1]
+       [(TypeImportOnDemandDeclaration) $1])
+      
+      (SingleTypeImportDeclaration
+       [(import Name SEMI_COLON) (make-import $2 #f (build-src 1) (build-src 3) (file-path))])
+      
+      (TypeImportOnDemandDeclaration
+       [(import Name PERIOD * SEMI_COLON)
+	(make-import $2 #t (build-src 1) (build-src 5) (file-path))])
+      
+      (TypeDeclaration
+       [(ClassDeclaration) $1]
+       [(InterfaceDeclaration) $1]
+       [(INTERACTIONS_BOX) $1]
+       [(CLASS_BOX) (parse-class-box $1 (build-src 1) 'advanced)]
+       [(TEST_SUITE) $1]
+       [(EXAMPLE) $1]
+       [(SEMI_COLON) #f])
+      
+      ;; 19.7
+      (Modifiers
+       [(Modifier) (list $1)]
+       [(Modifiers Modifier) (cons $2 $1)])
+      
+      (Modifier
+       [(public) (make-modifier 'public (build-src 1))]
+       [(protected) (make-modifier 'protected (build-src 1))]
+       [(private) (make-modifier 'private (build-src 1))]
+       [(static) (make-modifier 'static (build-src 1))]
+       [(abstract) (make-modifier 'abstract (build-src 1))])
+       
+      ;; 19.8.1
+      (ClassDeclaration
+       [(Modifiers class IDENTIFIER Super Interfaces ClassBody)
+	(make-class-def (make-header (make-id $3 (build-src 3 3)) $1 $4 $5 null (build-src 5))
+                            $6
+                            (build-src 2 2)
+                            (build-src 6)
+                            (file-path)
+                            'advanced
+                            null 'top null)]
+       [(class IDENTIFIER Super Interfaces ClassBody)
+	(make-class-def (make-header (make-id $2 (build-src 2 2)) null $3 $4 null (build-src 4))
+                            $5
+                            (build-src 1)
+                            (build-src 5)
+                            (file-path)
+                            'advanced
+                            null 'top null)])
+      
+      (Super
+       [() null]
+       [(extends ClassType) (list $2)])
+      
+      (Interfaces
+       [() null]
+       [(implements InterfaceTypeList) $2])
+      
+      (InterfaceTypeList
+       [(InterfaceType) (list $1)]
+       [(InterfaceTypeList COMMA InterfaceType) (cons $3 $1)])
+      
+      (ClassBody
+       [(O_BRACE ClassBodyDeclarations C_BRACE) (reverse $2)])
+      
+      (ClassBodyDeclarations
+       [() null]
+       [(ClassBodyDeclarations ClassBodyDeclaration)
+        (cond
+          ((not $2) $1)
+          ((list? $2) (append $2 $1))
+          (else (cons $2 $1)))])
+      
+      (ClassBodyDeclaration
+       [(ClassMemberDeclaration) $1]
+       [(StaticInitializer) $1]
+       [(ConstructorDeclaration) $1]
+       [(SEMI_COLON) #f])
+      
+      (ClassMemberDeclaration
+       [(FieldDeclaration) $1]
+       [(MethodDeclaration) $1])
+      
+      ;; 19.8.2
+      (FieldDeclaration
+       [(Modifiers Type VariableDeclarators SEMI_COLON)
+        (map (lambda (d) (build-field-decl $1 $2 d)) (reverse $3))]
+       [(Type VariableDeclarators SEMI_COLON)
+        (map (lambda (d) (build-field-decl null $1 d)) (reverse $2))])
+
+      (VariableDeclarators
+       [(VariableDeclarator) (list $1)]
+       [(VariableDeclarators COMMA VariableDeclarator) (cons $3 $1)])
+      
+      (VariableDeclarator
+       [(VariableDeclaratorId) $1]
+       [(VariableDeclaratorId = VariableInitializer)
+        (make-var-init $1 $3 (build-src 3))])
+
+      (VariableDeclaratorId
+       [(IDENTIFIER)
+	(make-var-decl (make-id $1 (build-src 1)) null (make-type-spec #f 0 (build-src 1)) (build-src 1))]
+       [(IDENTIFIER Dims)
+	(make-var-decl (make-id $1 (build-src 1)) null (make-type-spec #f $2 (build-src 2)) (build-src 2))])
+			
+      (VariableInitializer
+       [(Expression) $1]
+       [(ArrayInitializer) $1])
+
+      ;; 19.8.3
+      (MethodDeclaration
+       [(MethodHeader MethodBody) (make-method (method-modifiers $1)
+                                               (method-type $1)
+                                               (method-type-parms $1)
+                                               (method-name $1)
+                                               (method-parms $1)
+                                               (method-throws $1)
+                                               $2
+                                               #f
+                                               #f
+                                               (build-src 2))])
+
+      (MethodHeader
+       [(Modifiers Type MethodDeclarator) (construct-method-header $1 null $2 $3 null)]
+       [(Modifiers void MethodDeclarator)
+	(construct-method-header $1 
+				 null 
+				 (make-type-spec 'void 0 (build-src 2 2)) 
+				 $3
+				 null)]
+       [(Type MethodDeclarator) (construct-method-header null null $1 $2 null)]
+       [(void MethodDeclarator)
+	(construct-method-header null
+				 null 
+				 (make-type-spec 'void 0 (build-src 2 2))
+				 $2 
+				 null)])
+      
+      (MethodDeclarator
+       [(IDENTIFIER O_PAREN FormalParameterList C_PAREN) (list (make-id $1 (build-src 1)) (reverse $3) 0)]
+       [(IDENTIFIER O_PAREN C_PAREN) (list (make-id $1 (build-src 1)) null 0)]
+       [(IDENTIFIER O_PAREN FormalParameterList C_PAREN Dims) (list (make-id $1 (build-src 1)) (reverse $3) $5)]
+       [(IDENTIFIER O_PAREN C_PAREN Dims) (list (make-id $1 (build-src 1)) null $4)])
+      
+      (FormalParameterList
+       [(FormalParameter) (list $1)]
+       [(FormalParameterList COMMA FormalParameter) (cons $3 $1)])
+      
+      (FormalParameter
+       [(Type VariableDeclaratorId) (build-field-decl null $1 $2)])
+            
+      (MethodBody
+       [(Block) $1]
+       [(SEMI_COLON) #f])
+      
+      ;; 19.8.4
+      
+      (StaticInitializer
+       ;; 1.1
+       [(Block) (make-initialize #f $1 (build-src 1))])
+      
+      ;; 19.8.5
+      
+      (ConstructorDeclaration
+       [(Modifiers ConstructorDeclarator ConstructorBody)
+	(make-method $1 (make-type-spec 'ctor 0 (build-src 3)) null (car $2) 
+                         (cadr $2) null $3 #f #f (build-src 3))]
+       [(ConstructorDeclarator ConstructorBody)
+	(make-method null (make-type-spec 'ctor 0 (build-src 2)) null (car $1)
+                         (cadr $1) null $2 #f #f (build-src 2))])
+      
+      (ConstructorDeclarator
+       [(IDENTIFIER O_PAREN FormalParameterList C_PAREN) (list (make-id $1 (build-src 1)) (reverse $3))]
+       [(IDENTIFIER O_PAREN C_PAREN) (list (make-id $1 (build-src 1)) null)])
+      
+      (ConstructorBody
+       [(O_BRACE ExplicitConstructorInvocation BlockStatements C_BRACE)
+	(make-block (cons $2 (reverse $3)) (build-src 4))]
+       [(O_BRACE ExplicitConstructorInvocation C_BRACE)
+	(make-block (list $2) (build-src 3))]
+       [(O_BRACE BlockStatements C_BRACE)
+	(make-block 
+	 (cons (make-call #f #f #f (make-special-name #f #f "super") null #f)
+	       (reverse $2))
+	 (build-src 3))]
+       [(O_BRACE C_BRACE)
+	(make-block
+	 (list (make-call #f (build-src 1) 
+			      #f (make-special-name #f #f "super") null (build-src 2)))
+	 (build-src 2))])
+      
+      (ExplicitConstructorInvocation
+       [(this O_PAREN ArgumentList C_PAREN SEMI_COLON)
+	(make-call #f (build-src 5) 
+		       #f (make-special-name #f (build-src 1) "this") (reverse $3) #f)]
+       [(this O_PAREN C_PAREN SEMI_COLON)
+	(make-call #f (build-src 4) 
+		       #f (make-special-name #f (build-src 1) "this") null #f)]
+       [(super O_PAREN ArgumentList C_PAREN SEMI_COLON)
+	(make-call #f (build-src 5) 
+		       #f (make-special-name #f (build-src 1) "super") (reverse $3) #f)]
+       [(super O_PAREN C_PAREN SEMI_COLON)
+	(make-call #f (build-src 4) 
+		       #f (make-special-name #f (build-src 1) "super") null #f)])
+      
+      ;; 19.9.1
+      
+      (InterfaceDeclaration
+       [(Modifiers interface IDENTIFIER ExtendsInterfaces InterfaceBody)
+	(make-interface-def (make-header (make-id $3 (build-src 3 3)) $1 $4 null null (build-src 4))
+                                $5
+                                (build-src 2 2)
+                                (build-src 5)
+                                (file-path)
+                                'advanced
+                                null 'top null)]
+       [(Modifiers interface IDENTIFIER InterfaceBody)
+	(make-interface-def (make-header (make-id $3 (build-src 3 3)) $1 null null null (build-src 3))
+                                $4
+                                (build-src 2 2)
+                                (build-src 4)
+                                (file-path)
+                                'advanced
+                                null 'top null)]
+       [(interface IDENTIFIER ExtendsInterfaces InterfaceBody)
+       	(make-interface-def (make-header (make-id $2 (build-src 2 2)) null $3 null null (build-src 3))
+                                $4
+                                (build-src 1)
+                                (build-src 4)
+                                (file-path)
+                                'advanced
+                                null 'top null)]
+       [(interface IDENTIFIER InterfaceBody)
+	(make-interface-def (make-header (make-id $2 (build-src 2 2)) null null null null (build-src 2))
+                                $3
+                                (build-src 1)
+                                (build-src 3)
+                                (file-path)
+                                'advanced
+                                null 'top null)])
+       
+      
+      (ExtendsInterfaces
+       [(extends InterfaceType) (list $2)]
+       [(ExtendsInterfaces COMMA InterfaceType) (cons $3 $1)])
+
+      (InterfaceBody
+       [(O_BRACE InterfaceMemberDeclarations C_BRACE) $2])
+      
+      (InterfaceMemberDeclarations
+       [() null]
+       [(InterfaceMemberDeclarations InterfaceMemberDeclaration) 
+        (cond
+          ((not $2) $1)
+          ((list? $2) (append $2 $1))
+          (else (cons $2 $1)))])
+      
+      (InterfaceMemberDeclaration
+       [(ConstantDeclaration) $1]
+       [(AbstractMethodDeclaration) $1]
+       [(SEMI_COLON) #f])
+      
+      (ConstantDeclaration
+       [(FieldDeclaration) $1])
+      
+      (AbstractMethodDeclaration
+       [(MethodHeader SEMI_COLON) $1])
+      
+      ;; 19.10
+      
+      (ArrayInitializer
+       [(O_BRACE VariableInitializers COMMA C_BRACE) (make-array-init $2 (build-src 3))]
+       [(O_BRACE VariableInitializers C_BRACE) (make-array-init $2 (build-src 3))]
+       [(O_BRACE COMMA C_BRACE) (make-array-init null (build-src 3))]
+       [(O_BRACE C_BRACE) (make-array-init null (build-src 2))])
+      
+      (VariableInitializers
+       [(VariableInitializer) (list $1)]
+       [(VariableInitializers COMMA VariableInitializer) (cons $3 $1)])
+      
+      ;; 19.11
+      
+      (Block
+       [(O_BRACE BlockStatements C_BRACE) (make-block (reverse $2) (build-src 3))]
+       [(O_BRACE C_BRACE) (make-block null (build-src 2))])
+      
+      (BlockStatements
+       [(BlockStatement) (cond
+			  ((list? $1) $1)
+			  (else (list $1)))]
+       [(BlockStatements BlockStatement) (cond
+                                           ((list? $2)
+                                            (append (reverse $2) $1))
+                                           (else
+                                            (cons $2 $1)))])
+      
+      (BlockStatement
+       [(LocalVariableDeclarationStatement) $1]
+       [(Statement) $1])
+      
+      (LocalVariableDeclarationStatement
+       [(LocalVariableDeclaration SEMI_COLON) $1])
+      
+      (LocalVariableDeclaration
+       [(Type VariableDeclarators)
+        (map (lambda (d) (build-field-decl null $1 d)) (reverse $2))])
+      
+      (Statement
+       [(StatementWithoutTrailingSubstatement) $1]
+       [(IfThenStatement) $1]
+       [(IfThenElseStatement) $1]
+       [(WhileStatement) $1]
+       [(ForStatement) $1])
+      
+      (StatementNoShortIf
+       [(StatementWithoutTrailingSubstatement) $1]
+       [(IfThenElseStatementNoShortIf) $1]
+       [(WhileStatementNoShortIf) $1]
+       [(ForStatementNoShortIf) $1])
+      
+      (StatementWithoutTrailingSubstatement
+       [(Block) $1]
+       [(EmptyStatement) $1]
+       [(Assignment SEMI_COLON) $1]
+       [(ExpressionStatement) $1]
+       [(DoStatement) $1]
+       [(BreakStatement) $1]
+       [(ContinueStatement) $1]
+       [(ReturnStatement) $1])
+      
+      (EmptyStatement
+       [(SEMI_COLON) (make-block null (build-src 1))])
+            
+      (ExpressionStatement
+       [(StatementExpression SEMI_COLON) $1])
+      
+      (StatementExpression
+       [(PreIncrementExpression) $1]
+       [(PreDecrementExpression) $1]
+       [(PostIncrementExpression) $1]
+       [(PostDecrementExpression) $1]
+       [(MethodInvocation) $1]
+       [(ClassInstanceCreationExpression) $1])
+      
+      (IfThenStatement
+       [(if O_PAREN Expression C_PAREN Statement) (make-ifS $3 $5 #f (build-src 1) (build-src 5))])
+      
+      (IfThenElseStatement
+       [(if O_PAREN Expression C_PAREN StatementNoShortIf else Statement)
+	(make-ifS $3 $5 $7 (build-src 1) (build-src 7))])
+      
+      (IfThenElseStatementNoShortIf
+       [(if O_PAREN Expression C_PAREN StatementNoShortIf else StatementNoShortIf)
+	(make-ifS $3 $5 $7 (build-src 1) (build-src 7))])
+      
+      (WhileStatement
+       [(while O_PAREN Expression C_PAREN Statement)
+        (make-while $3 $5 (build-src 5))])
+      
+      (WhileStatementNoShortIf
+       [(while O_PAREN Expression C_PAREN StatementNoShortIf)
+	(make-while $3 $5 (build-src 5))])
+      
+      (DoStatement
+       [(do Statement while O_PAREN Expression C_PAREN SEMI_COLON)
+	(make-doS $2 $5 (build-src 7))])
+      
+      (ForStatement
+       [(for O_PAREN ForInit SEMI_COLON Expression SEMI_COLON ForUpdate C_PAREN Statement)
+	(make-for $3 $5 $7 $9 (build-src 9))]
+       [(for O_PAREN ForInit SEMI_COLON SEMI_COLON ForUpdate C_PAREN Statement)
+	(make-for $3 
+                      (make-literal 'boolean (build-src 4 5) #t) 
+		      $6 
+                      $8 
+                      (build-src 8))])
+	
+      
+      (ForStatementNoShortIf
+       [(for O_PAREN ForInit SEMI_COLON Expression SEMI_COLON ForUpdate C_PAREN StatementNoShortIf)
+	(make-for $3 $5 $7 $9 (build-src 9))]
+       [(for O_PAREN ForInit SEMI_COLON SEMI_COLON ForUpdate C_PAREN StatementNoShortIf)
+      	(make-for $3 (make-literal 'boolean #t (build-src 4 5)) 
+		      $6 $8 (build-src 8))])
+      (ForInit
+       [() null]
+       [(StatementExpressionList) (reverse $1)]
+       [(LocalVariableDeclaration) (reverse $1)])
+      
+      (ForUpdate
+       [() null]
+       [(StatementExpressionList) (reverse $1)])
+      
+      (StatementExpressionList
+       [(StatementExpression) (list $1)]
+       [(StatementExpressionList COMMA StatementExpression) (cons $3 $1)])
+      
+      (BreakStatement
+       [(break SEMI_COLON) (make-break #f (build-src 2))])
+      
+      (ContinueStatement
+       [(continue SEMI_COLON) (make-continue #f (build-src 2))])
+       
+      (ReturnStatement
+       [(return Expression SEMI_COLON) (make-return $2 #f (build-src 3))]
+       [(return SEMI_COLON) (make-return #f #f (build-src 2))])
+      
+      ;; 19.12
+      
+      (Primary
+       [(PrimaryNoNewArray) $1]
+       [(ArrayCreationExpression) $1])
+      
+      (PrimaryNoNewArray
+       [(Literal) $1]
+       [(this) (make-special-name #f (build-src 1) "this")]
+       [(O_PAREN Expression C_PAREN) $2]
+       [(ClassInstanceCreationExpression) $1]
+       [(FieldAccess) $1]
+       [(MethodInvocation) $1]
+       [(ArrayAccess) $1])
+       
+      (ClassInstanceCreationExpression
+       [(new ClassOrInterfaceType O_PAREN ArgumentList C_PAREN)
+	(make-class-alloc #f (build-src 5) $2 (reverse $4) #f #f #f)]
+       [(new ClassOrInterfaceType O_PAREN C_PAREN) 
+	(make-class-alloc #f (build-src 4) $2 null #f #f #f)])
+      
+      (ArgumentList
+       [(Expression) (list $1)]
+       [(ArgumentList COMMA Expression) (cons $3 $1)])
+      
+      (ArrayCreationExpression
+       [(new PrimitiveType DimExprs Dims) (make-array-alloc #f (build-src 4) $2 (reverse $3) $4)]
+       [(new PrimitiveType DimExprs) (make-array-alloc #f (build-src 3) $2 (reverse $3) 0)]
+       [(new ClassOrInterfaceType DimExprs Dims)
+        (make-array-alloc #f (build-src 4) (make-type-spec $2 0 (build-src 2 2)) (reverse $3) $4)]
+       [(new ClassOrInterfaceType DimExprs)
+        (make-array-alloc #f (build-src 3) (make-type-spec $2 0 (build-src 2 2)) (reverse $3) 0)]
+       ;; 1.1
+       [(new PrimitiveType Dims ArrayInitializer) 
+        (begin (display $2)
+               (error 'unimplemented-1.1))]
+       ;; 1.1
+       [(new ClassOrInterfaceType Dims ArrayInitializer) (error 'unimplemented-1.1)])
+      
+      (DimExprs
+       [(DimExpr) (list $1)]
+       [(DimExprs DimExpr) (cons $2 $1)])
+
+      (DimExpr
+       [(O_BRACKET Expression C_BRACKET) $2])
+      
+      (Dims
+       [(O_BRACKET C_BRACKET) 1]
+       [(Dims O_BRACKET C_BRACKET) (add1 $1)])
+      
+      (FieldAccess
+       [(Primary PERIOD IDENTIFIER) 
+        (make-access #f (build-src 3) (make-field-access $1 
+                                                                 (make-id $3 (build-src 3 3)) #f))]
+       [(super PERIOD IDENTIFIER) 
+        (make-access #f (build-src 3)
+                         (make-field-access (make-special-name #f (build-src 1)
+                                                                       "super")
+                                                (make-id $3 (build-src 3 3))
+                                                #f))])
+      
+      (MethodInvocation
+       [(Name O_PAREN ArgumentList C_PAREN) (build-name-call $1 (reverse $3) (build-src 4))]
+       [(Name O_PAREN C_PAREN) (build-name-call $1 null (build-src 3))]
+       [(Primary PERIOD IDENTIFIER O_PAREN ArgumentList C_PAREN)
+        (make-call #f (build-src 6) $1 (make-id $3 (build-src 3 3)) (reverse $5) #f)]
+       [(Primary PERIOD IDENTIFIER O_PAREN C_PAREN)
+        (make-call #f (build-src 5) $1 (make-id $3 (build-src 3 3)) null #f)]
+       [(super PERIOD IDENTIFIER O_PAREN ArgumentList C_PAREN)
+        (make-call #f (build-src 6) 
+                       (make-special-name #f (build-src 1) "super") 
+                       (make-id $3 (build-src 3 3)) (reverse $5) #f)]
+       [(super PERIOD IDENTIFIER O_PAREN C_PAREN)
+        (make-call #f (build-src 5) 
+                       (make-special-name #f (build-src 1) "super") 
+                       (make-id $3 (build-src 3 3)) null #f)])
+      
+      (ArrayAccess
+       [(Name O_BRACKET Expression C_BRACKET)
+        (make-array-access #f (build-src 4) (name->access $1) $3)]
+       [(PrimaryNoNewArray O_BRACKET Expression C_BRACKET)
+	(make-array-access #f (build-src 4) $1 $3)])
+      
+      (PostfixExpression
+       [(Primary) $1]
+       [(Name) (name->access $1)]
+       [(PostIncrementExpression) $1]
+       [(PostDecrementExpression) $1])
+      
+      (PostIncrementExpression
+       [(PostfixExpression ++) (make-post-expr #f (build-src 2) $1 '++ (build-src 2 2))])
+      
+      (PostDecrementExpression
+       [(PostfixExpression --) (make-post-expr #f (build-src 2) $1 '-- (build-src 2 2))])
+      
+      (UnaryExpression
+       [(PreIncrementExpression) $1]
+       [(PreDecrementExpression) $1]
+       [(+ UnaryExpression) (make-unary #f (build-src 2) '+ $2 (build-src 1))]
+       [(- UnaryExpression) (make-unary #f (build-src 2) '- $2 (build-src 1))]
+       [(UnaryExpressionNotPlusMinus) $1])
+      
+      (PreIncrementExpression
+       [(++ UnaryExpression) (make-pre-expr #f (build-src 2) '++ $2 (build-src 1))])
+
+      (PreDecrementExpression
+       [(-- UnaryExpression) (make-pre-expr #f (build-src 2) '-- $2 (build-src 1))])
+      
+      (UnaryExpressionNotPlusMinus
+       [(PostfixExpression) $1]
+       [(~ UnaryExpression) (make-unary #f (build-src 2) '~ $2 (build-src 1))]
+       [(! UnaryExpression) (make-unary #f (build-src 2) '! $2 (build-src 1))]
+       [(CastExpression) $1])
+      
+      (CastExpression
+       [(O_PAREN PrimitiveType Dims C_PAREN UnaryExpression)
+	(make-cast #f (build-src 5) 
+		       (make-type-spec (type-spec-name $2)
+                                           $3
+                                           (build-src 2 3))
+		       $5)]
+       [(O_PAREN PrimitiveType C_PAREN UnaryExpression)
+	(make-cast #f (build-src 4) $2 $4)]
+       [(O_PAREN Expression C_PAREN UnaryExpressionNotPlusMinus)
+        (if (access? $2)
+            (make-cast #f (build-src 4) 
+                           (make-type-spec (access->name $2) 0 (build-src 2 2)) $4)
+            (error 'bad-cast))]
+       ;; GJ - Not sure if this is in spec or not.
+       ;;[(O_PAREN Name < ReferenceTypeList1 C_PAREN UnaryExpressionNotPlusMinus) #t]
+       [(O_PAREN Name Dims C_PAREN UnaryExpressionNotPlusMinus)
+	(make-cast #f (build-src 4)
+		       (make-type-spec $2 $3 (build-src 2 3))
+		       $5)])
+
+      (MultiplicativeExpression
+       [(UnaryExpression) $1]
+       [(MultiplicativeExpression * UnaryExpression)
+        (make-bin-op #f (build-src 3) '* $1 $3 (build-src 2 2))]
+       [(MultiplicativeExpression / UnaryExpression)
+	(make-bin-op #f (build-src 3) '/ $1 $3 (build-src 2 2))]
+       [(MultiplicativeExpression % UnaryExpression)
+	(make-bin-op #f (build-src 3) '% $1 $3 (build-src 2 2))])
+      
+      (AdditiveExpression
+       [(MultiplicativeExpression) $1]
+       [(AdditiveExpression + MultiplicativeExpression)
+	(make-bin-op #f (build-src 3) '+ $1 $3 (build-src 2 2))]
+       [(AdditiveExpression - MultiplicativeExpression)
+	(make-bin-op #f (build-src 3) '- $1 $3 (build-src 2 2))])
+      
+      (ShiftExpression
+       [(AdditiveExpression) $1]
+       [(ShiftExpression << AdditiveExpression)
+	(make-bin-op #f (build-src 3) '<< $1 $3 (build-src 2 2))]
+       [(ShiftExpression >> AdditiveExpression)
+	(make-bin-op #f (build-src 3) '>> $1 $3 (build-src 2 2))]	
+       [(ShiftExpression >>> AdditiveExpression)
+	(make-bin-op #f (build-src 3) '>>> $1 $3 (build-src 2 2))])
+      
+
+      (RelationalExpression
+       [(ShiftExpression) $1]
+       ;; GJ - changed to remove shift/reduce conflict
+       [(ShiftExpression < ShiftExpression)
+        (make-bin-op #f (build-src 3) '< $1 $3 (build-src 2 2))]		
+       [(RelationalExpression > ShiftExpression)
+	(make-bin-op #f (build-src 3) '> $1 $3 (build-src 2 2))]	
+       [(RelationalExpression <= ShiftExpression)
+	(make-bin-op #f (build-src 3) '<= $1 $3 (build-src 2 2))]	
+       [(RelationalExpression >= ShiftExpression)
+	(make-bin-op #f (build-src 3) '>= $1 $3 (build-src 2 2))]	
+       [(RelationalExpression instanceof ReferenceType)
+	(make-instanceof #f (build-src 3) $1 $3 (build-src 2 2))])
+      
+
+      (EqualityExpression
+       [(RelationalExpression) $1]
+       [(EqualityExpression == RelationalExpression)
+	(make-bin-op #f (build-src 3) '== $1 $3 (build-src 2 2))]	
+       [(EqualityExpression != RelationalExpression)
+	(make-bin-op #f (build-src 3) '!= $1 $3 (build-src 2 2))])
+      
+      (AndExpression
+       [(EqualityExpression) $1]
+       [(AndExpression & EqualityExpression)
+	(make-bin-op #f (build-src 3) '& $1 $3 (build-src 2 2))])
+	
+      
+      (ExclusiveOrExpression
+       [(AndExpression) $1]
+       [(ExclusiveOrExpression ^ AndExpression)
+	(make-bin-op #f (build-src 3) '^ $1 $3 (build-src 2 2))])
+
+      
+      (InclusiveOrExpression
+       [(ExclusiveOrExpression) $1]
+       [(InclusiveOrExpression PIPE ExclusiveOrExpression)
+	(make-bin-op #f (build-src 3) 'or $1 $3 (build-src 2 2))])
+      
+      (ConditionalAndExpression
+       [(InclusiveOrExpression) $1]
+       [(ConditionalAndExpression && InclusiveOrExpression)
+	(make-bin-op #f (build-src 3) '&& $1 $3 (build-src 2 2))])
+      
+      (ConditionalOrExpression
+       [(ConditionalAndExpression) $1]
+       [(ConditionalOrExpression OR ConditionalAndExpression)
+	(make-bin-op #f (build-src 3) 'oror $1 $3 (build-src 2 2))])
+      
+      (ConditionalExpression
+       [(ConditionalOrExpression) $1]
+       [(ConditionalOrExpression ? Expression : ConditionalExpression)
+	(make-cond-expression #f (build-src 5) $1 $3 $5 (build-src 2 2))])
+      
+      (AssignmentExpression
+       [(ConditionalExpression) $1])
+      
+      (Assignment
+       [(LeftHandSide AssignmentOperator AssignmentExpression)
+	(make-assignment #f (build-src 3) $1 $2 $3 (build-src 2 2))])
+      
+      (LeftHandSide
+       [(Name) (name->access $1)]
+       [(FieldAccess) $1]
+       [(ArrayAccess) $1])
+      
+      (AssignmentOperator
+       [(=) '=]
+       [(*=) '*=]
+       [(/=) '/=]
+       [(%=) '%=]
+       [(+=) '+=]
+       [(-=) '-=]
+       [(<<=) '<<=]
+       [(>>=) '>>=]
+       [(>>>=) '>>>=]
+       [(&=) '&=]
+       [(^=) '^=]
+       [(OREQUAL) 'or=])
+      
+      (Expression
+       [(AssignmentExpression) $1])
+      
+      (ConstantExpression
+       [(Expression) $1]))))
+
+  ;(define advanced-grammar (cadr parsers))
+  ;(set! parsers (car parsers))
+  
+  (define parse-advanced (car parsers))
+  (define parse-advanced-interactions (cadr parsers))
+  (define parse-advanced-expression (caddr parsers))
+  (define parse-advanced-type (cadddr parsers))
+  )
diff --git a/collects/profj/parsers/beginner-parser.ss b/collects/profj/parsers/beginner-parser.ss
new file mode 100644
index 0000000000..b3a51b192b
--- /dev/null
+++ b/collects/profj/parsers/beginner-parser.ss
@@ -0,0 +1,456 @@
+#cs
+(module beginner-parser mzscheme
+  
+  (require "general-parsing.ss"
+           "lexer.ss"
+           "../ast.ss"
+           "../parameters.ss")
+  
+  (require (lib "yacc.ss" "parser-tools")
+           (all-except (lib "lex.ss" "parser-tools") input-port)           
+           (lib "readerr.ss" "syntax")
+           (prefix class: (lib "class.ss")))
+  
+  ;(require (lib "build-grammar.ss" "tester"))
+  
+  #;(define-syntax testing-parser
+    (syntax-rules ()
+      ((_ parse-info ...) (parser parse-info ...))))
+    
+  (provide parse-beginner parse-beginner-interactions parse-beginner-expression parse-beginner-type)
+  ;(provide beginner-grammar)
+  
+  (define parsers
+    (parser
+     (start CompilationUnit BeginnerInteractions Expression Type)
+     (tokens java-vals special-toks Keywords Separators EmptyLiterals Operators)
+     ;(terminals val-tokens special-tokens keyword-tokens separator-tokens literal-tokens operator-tokens)
+     (error (lambda (tok-ok name val start-pos end-pos)
+              (if ((determine-error))
+                  (raise-read-error (format "Parse error near <~a:~a>" name val)
+                                    (file-path)
+                                    (position-line start-pos)
+                                    (position-col start-pos)
+                                    (+ (position-offset start-pos) (interactions-offset))
+                                    (- (position-offset end-pos)
+                                       (position-offset start-pos))))))
+     
+     (end EOF)
+     (src-pos)
+     
+     (grammar
+      
+      ;; 19.3
+      (Literal
+       [(INTEGER_LIT) (make-literal 'int (build-src 1) $1)]
+       [(LONG_LIT) (make-literal 'long (build-src 1) $1)]
+       [(FLOAT_LIT) (make-literal 'float (build-src 1) $1)]
+       [(DOUBLE_LIT) (make-literal 'double (build-src 1)  $1)]
+       [(TRUE_LIT) (make-literal 'boolean (build-src 1) #t)]
+       [(FALSE_LIT) (make-literal 'boolean (build-src 1) #f)]
+       [(CHAR_LIT) (make-literal 'char (build-src 1) $1)]
+       [(STRING_LIT) (make-literal 'string 
+                                   (make-src (position-line $1-start-pos)
+                                             (position-col $1-start-pos)
+                                             (+ (position-offset $1-start-pos) (interactions-offset))
+                                             (- (position-offset (cadr $1)) (position-offset $1-start-pos))
+                                             (file-path))
+                                   (car $1))])
+;       [(NULL_LIT) (make-literal 'null (build-src 1) #f)])
+      
+      ;; 19.4
+      (Type
+       [(PrimitiveType) $1]
+       [(ReferenceType) $1])
+      
+      (PrimitiveType
+       [(NumericType) $1]
+       [(boolean) (make-type-spec 'boolean 0 (build-src 1))])
+      
+      (NumericType
+       [(IntegralType) $1]
+       [(FloatingPointType) $1])
+      
+      (IntegralType
+       [(byte) (make-type-spec 'byte 0 (build-src 1))]
+       [(short) (make-type-spec 'short 0 (build-src 1))]
+       [(int) (make-type-spec 'int 0 (build-src 1))]
+       [(long) (make-type-spec 'long 0 (build-src 1))]
+       [(char) (make-type-spec 'char 0 (build-src 1))])
+      
+      (FloatingPointType
+       [(float) (make-type-spec 'float 0 (build-src 1))]
+       [(double) (make-type-spec 'double 0 (build-src 1))])
+      
+      (ReferenceType
+       [(IDENTIFIER) (make-type-spec 
+                      (make-name (make-id $1 (build-src 1)) null (build-src 1)) 0 (build-src 1))]
+       )
+      
+      (ClassOrInterfaceType
+       [(IDENTIFIER) (make-name (make-id $1 (build-src 1)) null (build-src 1))])
+            
+      (ClassType
+       [(ClassOrInterfaceType) $1])
+      
+      ;;19.5
+      (Name
+       [(IDENTIFIER) (make-name (make-id $1 (build-src 1)) null (build-src 1))]
+       [(Name PERIOD IDENTIFIER)
+	(make-name (make-id $3 (build-src 3 3)) 
+                   (append (name-path $1) (list (name-id $1)))
+                   (build-src 3))])
+      ;; 19.6
+      (CompilationUnit
+       [(ImportDeclarations TypeDeclarations) (make-package #f (reverse $1) (reverse $2))]
+       [(ImportDeclarations) (make-package #f (reverse $1) null)]
+       [(TypeDeclarations) (make-package #f null (reverse $1))]
+       [() (make-package #f null null)])
+      
+      (TypeDeclarations
+       [(TypeDeclaration) (if $1 (list $1) null)]
+       [(TypeDeclarations TypeDeclaration) (if $2 (cons $2 $1) $1)])
+      
+      (TypeDeclaration
+       [(ClassDeclaration) $1]
+       [(INTERACTIONS_BOX) $1]
+       [(EXAMPLE) $1]
+       [(CLASS_BOX) (parse-class-box $1 (build-src 1) 'beginner)]
+       [(TEST_SUITE) $1]
+       [(SEMI_COLON) #f])
+      
+      ;; 19.7
+      (Modifiers
+       [(Modifier) (list $1)])
+;       [(Modifiers Modifier) (cons $2 $1)])
+      
+      (Modifier
+       [(abstract) (make-modifier 'abstract (build-src 1))])
+
+      (ImportDeclarations
+       [(ImportDeclaration) (list $1)]
+       [(ImportDeclarations ImportDeclaration) (cons $2 $1)])
+      
+      (ImportDeclaration
+       [(import Name SEMI_COLON) (make-import $2 #f (build-src 1) (build-src 3) (file-path))]
+       [(import Name PERIOD * SEMI_COLON)
+	(make-import $2 #t (build-src 1) (build-src 5) (file-path))])
+      
+      ;; 19.8.1
+      (ClassDeclaration
+       [(class IDENTIFIER Super ClassBody)
+	(make-class-def (make-header (make-id $2 (build-src 2 2))
+                                     (list (make-modifier 'public #f))
+                                     $3 null null (build-src 3))
+                        $4
+                        (build-src 1)
+                        (build-src 4)
+                        (file-path)
+                        'beginner
+                        null 'top null)]
+       [(abstract class IDENTIFIER Super ClassBody)
+        (make-class-def (make-header (make-id $3 (build-src 3 3))
+                                     (list (make-modifier 'public #f)
+                                           (make-modifier 'abstract #f))
+                                     $4 null null (build-src 4))
+                        $5
+                        (build-src 2 2)
+                        (build-src 5)
+                        (file-path)
+                        'beginner
+                        null 'top null)])
+      
+      (Super
+       [() null]
+       [(extends ClassType) (list $2)])
+      
+      (ClassBody
+       [(O_BRACE ClassBodyDeclarations C_BRACE) (reverse $2)])
+      
+      (ClassBodyDeclarations
+       [() null]
+       [(ClassBodyDeclarations ClassBodyDeclaration)
+        (cond
+          ((not $2) $1)
+          ((list? $2) (append $2 $1))
+          (else (cons $2 $1)))])
+      
+      (ClassBodyDeclaration
+       [(ClassMemberDeclaration) $1]
+       [(ConstructorDeclaration) $1]
+       [(SEMI_COLON) #f])
+      
+      (ClassMemberDeclaration
+       [(FieldDeclaration) $1]
+       [(MethodDeclaration) $1])
+      
+      ;; 19.8.2
+      (FieldDeclaration
+       [(Type VariableDeclaratorId SEMI_COLON)
+        (build-field-decl (list (make-modifier 'public #f)) $1 $2)]
+       [(Type VariableDeclaratorId = Expression SEMI_COLON)
+        (build-field-decl (list (make-modifier 'public #f)) $1
+                          (make-var-init $2 $4 (build-src 2 4)))])
+
+      (InteractFieldDeclaration
+       [(Type VariableDeclaratorId = Expression SEMI_COLON)
+        (build-field-decl (list (make-modifier 'public #f)) $1 
+                          (make-var-init $2 $4 (build-src 2 4)))])
+      
+      (VariableDeclaratorId
+       [(IDENTIFIER)
+	(make-var-decl (make-id $1 (build-src 1)) null (make-type-spec #f 0 (build-src 1)) (build-src 1))])			
+      
+      ;; 19.8.3
+      (MethodDeclaration
+       [(MethodHeader Block) (make-method (method-modifiers $1)
+                                          (method-type $1)
+                                          (method-type-parms $1)
+                                          (method-name $1)
+                                          (method-parms $1)
+                                          (method-throws $1)
+                                          $2
+                                          #t
+                                          #f
+                                          (build-src 2))]
+       [(MethodHeader SEMI_COLON) (make-method (method-modifiers $1)
+                                               (method-type $1)
+                                               (method-type-parms $1)
+                                               (method-name $1)
+                                               (method-parms $1)
+                                               (method-throws $1)
+                                               #f
+                                               #t
+                                               #f
+                                               (build-src 2))])
+      
+      (MethodHeader
+       [(Modifiers Type MethodDeclarator) (construct-method-header (cons (make-modifier 'public #f) $1) null $2 $3 null)]
+       [(Type MethodDeclarator) (construct-method-header (list (make-modifier 'public #f)) null $1 $2 null)])
+
+      
+      (MethodDeclarator
+       [(IDENTIFIER O_PAREN FormalParameterList C_PAREN) (list (make-id $1 (build-src 1)) (reverse $3) 0)]
+       [(IDENTIFIER O_PAREN C_PAREN) (list (make-id $1 (build-src 1)) null 0)])
+      
+      (FormalParameterList
+       [(FormalParameter) (list $1)]
+       [(FormalParameterList COMMA FormalParameter) (cons $3 $1)])
+      
+      (FormalParameter
+       [(Type VariableDeclaratorId) (build-field-decl null $1 $2)])
+      
+      ;; 19.8.5      
+      (ConstructorDeclaration
+       [(ConstructorDeclarator ConstructorBody)
+	(make-method (list (make-modifier 'public #f)) (make-type-spec 'ctor 0 (build-src 2)) null (car $1)
+                     (cadr $1) null $2 #t #f (build-src 2))])
+      
+      (ConstructorDeclarator
+       [(IDENTIFIER O_PAREN FormalParameterList C_PAREN) (list (make-id $1 (build-src 1)) (reverse $3))]
+       [(IDENTIFIER O_PAREN C_PAREN) (list (make-id $1 (build-src 1)) null)])
+      
+      (ConstructorBody
+       [(O_BRACE ExplicitConstructorInvocation BlockStatements C_BRACE)
+	(make-block (cons $2 (reverse $3)) (build-src 4))]
+       [(O_BRACE ExplicitConstructorInvocation C_BRACE)
+	(make-block (list $2) (build-src 3))]
+       [(O_BRACE BlockStatements C_BRACE)
+	(make-block 
+	 (cons (make-call #f (build-src 3) #f (make-special-name #f #f "super") null #f)
+	       (reverse $2))
+	 (build-src 3))]
+       [(O_BRACE C_BRACE) 
+        (make-block (cons (make-call #f (build-src 2) #f (make-special-name #f #f "super") null #f)
+                          null) (build-src 2))])
+ 
+      (ExplicitConstructorInvocation
+       [(super O_PAREN ArgumentList C_PAREN SEMI_COLON)
+	(make-call #f (build-src 5) 
+		       #f (make-special-name #f (build-src 1) "super") (reverse $3) #f)]
+       [(super O_PAREN C_PAREN SEMI_COLON)
+	(make-call #f (build-src 4) 
+		       #f (make-special-name #f (build-src 1) "super") null #f)])
+      
+      ;; 19.11
+      (Block
+       [(O_BRACE Statement C_BRACE) (make-block (list $2) (build-src 3))])
+      
+      (BlockStatements
+       [(Statement) (if (list? $1) $1 (list $1))]
+       [(BlockStatements Statement) (if (list? $2) (append (reverse $2) $1) (cons $2 $1))])
+      
+      (BeginnerInteractions
+       [(Statement) $1]
+       [(Expression) $1]
+       [(InteractFieldDeclaration) $1]
+       [() null])
+      
+      (Statement
+       [(StatementWithoutTrailingSubstatement) $1]
+       [(IfThenElseStatement) $1])
+      
+      (StatementNoShortIf
+       [(StatementWithoutTrailingSubstatement) $1]
+       [(IfThenElseStatementNoShortIf) $1])
+      
+      (StatementWithoutTrailingSubstatement
+       [(Assignment SEMI_COLON) $1]
+       [(ReturnStatement) $1])
+      
+      (IfThenElseStatement
+       [(if O_PAREN Expression C_PAREN StatementNoShortIf else Statement)
+	(make-ifS $3 $5 $7 (build-src 1) (build-src 7))])
+      
+      (IfThenElseStatementNoShortIf
+       [(if O_PAREN Expression C_PAREN StatementNoShortIf else StatementNoShortIf)
+	(make-ifS $3 $5 $7 (build-src 1) (build-src 7))])
+      
+      (ReturnStatement
+       [(return Expression SEMI_COLON) (make-return $2 #t (build-src 3))])
+      
+      ;; 19.12
+      (Primary
+       [(Literal) $1]
+       [(this) (make-special-name #f (build-src 1) "this")]
+       [(O_PAREN Expression C_PAREN) $2]
+       [(ClassInstanceCreationExpression) $1]
+       [(MethodInvocation) $1]
+       [(FieldAccess) $1])
+      
+      (ClassInstanceCreationExpression
+       [(new ClassOrInterfaceType O_PAREN ArgumentList C_PAREN)
+	(make-class-alloc #f (build-src 5) $2 (reverse $4) #f #f #f)]
+       [(new ClassOrInterfaceType O_PAREN C_PAREN) 
+	(make-class-alloc #f (build-src 4) $2 null #f #f #f)])
+      
+      (ArgumentList
+       [(Expression) (list $1)]
+       [(ArgumentList COMMA Expression) (cons $3 $1)])
+      
+      (MethodInvocation
+       [(Name O_PAREN ArgumentList C_PAREN) (build-name-call $1 (reverse $3) (build-src 4))]
+       [(Name O_PAREN C_PAREN) (build-name-call $1 null (build-src 3))]
+       [(Primary PERIOD IDENTIFIER O_PAREN ArgumentList C_PAREN)
+        (make-call #f (build-src 6) $1 (make-id $3 (build-src 3 3)) (reverse $5) #f)]
+       [(Primary PERIOD IDENTIFIER O_PAREN C_PAREN)
+        (make-call #f (build-src 5) $1 (make-id $3 (build-src 3 3)) null #f)]
+       [(super PERIOD IDENTIFIER O_PAREN ArgumentList C_PAREN)
+        (make-call #f (build-src 6) 
+                   (make-special-name #f (build-src 1) "super") 
+                   (make-id $3 (build-src 3 3)) (reverse $5) #f)]
+       [(super PERIOD IDENTIFIER O_PAREN C_PAREN)
+        (make-call #f (build-src 5) 
+                   (make-special-name #f (build-src 1) "super") 
+                   (make-id $3 (build-src 3 3)) null #f)])
+      
+      (FieldAccess
+       [(Primary PERIOD IDENTIFIER) 
+        (make-access #f (build-src 3) (make-field-access $1 
+                                                         (make-id $3 (build-src 3 3)) #f))])
+      
+      (PostfixExpression
+       [(Primary) $1]
+       [(Name) (name->access $1)])
+      
+      (UnaryExpression
+       [(PostfixExpression) $1]
+       [(- UnaryExpression) (make-unary #f (build-src 2) '- $2 (build-src 1))]
+       [(~ UnaryExpression) (make-unary #f (build-src 2) '~ $2 (build-src 1))]
+       [(! UnaryExpression) (make-unary #f (build-src 2) '! $2 (build-src 1))])
+      
+      (MultiplicativeExpression
+       [(UnaryExpression) $1]
+       [(MultiplicativeExpression * UnaryExpression)
+        (make-bin-op #f (build-src 3) '* $1 $3 (build-src 2 2))]
+       [(MultiplicativeExpression / UnaryExpression)
+	(make-bin-op #f (build-src 3) '/ $1 $3 (build-src 2 2))]
+       [(MultiplicativeExpression % UnaryExpression)
+	(make-bin-op #f (build-src 3) '% $1 $3 (build-src 2 2))])
+      
+      (AdditiveExpression
+       [(MultiplicativeExpression) $1]
+       [(AdditiveExpression + MultiplicativeExpression)
+	(make-bin-op #f (build-src 3) '+ $1 $3 (build-src 2 2))]
+       [(AdditiveExpression - MultiplicativeExpression)
+	(make-bin-op #f (build-src 3) '- $1 $3 (build-src 2 2))])
+      
+      (ShiftExpression
+       [(AdditiveExpression) $1]
+       [(ShiftExpression << AdditiveExpression)
+	(make-bin-op #f (build-src 3) '<< $1 $3 (build-src 2 2))]
+       [(ShiftExpression >> AdditiveExpression)
+	(make-bin-op #f (build-src 3) '>> $1 $3 (build-src 2 2))]	
+       [(ShiftExpression >>> AdditiveExpression)
+	(make-bin-op #f (build-src 3) '>>> $1 $3 (build-src 2 2))])
+      
+      
+      (RelationalExpression
+       [(ShiftExpression) $1]
+       [(ShiftExpression < ShiftExpression)
+        (make-bin-op #f (build-src 3) '< $1 $3 (build-src 2 2))]		
+       [(RelationalExpression > ShiftExpression)
+	(make-bin-op #f (build-src 3) '> $1 $3 (build-src 2 2))]	
+       [(RelationalExpression <= ShiftExpression)
+	(make-bin-op #f (build-src 3) '<= $1 $3 (build-src 2 2))]	
+       [(RelationalExpression >= ShiftExpression)
+	(make-bin-op #f (build-src 3) '>= $1 $3 (build-src 2 2))])
+      
+      (EqualityExpression
+       [(RelationalExpression) $1]
+       [(EqualityExpression == RelationalExpression)
+	(make-bin-op #f (build-src 3) '== $1 $3 (build-src 2 2))]	
+       [(EqualityExpression != RelationalExpression)
+	(make-bin-op #f (build-src 3) '!= $1 $3 (build-src 2 2))])
+      
+      (AndExpression
+       [(EqualityExpression) $1]
+       [(AndExpression & EqualityExpression)
+	(make-bin-op #f (build-src 3) '& $1 $3 (build-src 2 2))])
+      
+      
+      (ExclusiveOrExpression
+       [(AndExpression) $1]
+       [(ExclusiveOrExpression ^ AndExpression)
+	(make-bin-op #f (build-src 3) '^ $1 $3 (build-src 2 2))])
+      
+      
+      (InclusiveOrExpression
+       [(ExclusiveOrExpression) $1]
+       [(InclusiveOrExpression PIPE ExclusiveOrExpression)
+	(make-bin-op #f (build-src 3) 'or $1 $3 (build-src 2 2))])
+      
+      (ConditionalAndExpression
+       [(InclusiveOrExpression) $1]
+       [(ConditionalAndExpression && InclusiveOrExpression)
+	(make-bin-op #f (build-src 3) '&& $1 $3 (build-src 2 2))])
+      
+      (ConditionalOrExpression
+       [(ConditionalAndExpression) $1]
+       [(ConditionalOrExpression OR ConditionalAndExpression)
+	(make-bin-op #f (build-src 3) 'oror $1 $3 (build-src 2 2))])
+      
+      (Assignment
+       [(LeftHandSide AssignmentOperator ConditionalOrExpression)
+	(make-assignment #f (build-src 3) $1 $2 $3 (build-src 2 2))])
+      
+      (LeftHandSide
+       [(Name) (name->access $1)]
+       [(FieldAccess) $1])
+            
+      (AssignmentOperator
+       [(=) '=])
+      
+      (Expression
+       [(ConditionalOrExpression) $1])
+      
+      )))
+  
+  ;(define beginner-grammar (cadr parsers))
+  ;(set! parsers (car parsers))
+  
+  (define parse-beginner (car parsers))
+  (define parse-beginner-interactions (cadr parsers))
+  (define parse-beginner-expression (caddr parsers))
+  (define parse-beginner-type (cadddr parsers))
+  )
\ No newline at end of file
diff --git a/collects/profj/parsers/full-parser.ss b/collects/profj/parsers/full-parser.ss
new file mode 100644
index 0000000000..155ef83707
--- /dev/null
+++ b/collects/profj/parsers/full-parser.ss
@@ -0,0 +1,995 @@
+(module full-parser mzscheme
+
+  (require "general-parsing.ss"
+           "lexer.ss"
+           "../ast.ss"
+           "../parameters.ss")
+  
+  (require (lib "yacc.ss" "parser-tools")
+           (all-except (lib "lex.ss" "parser-tools") input-port)
+           (lib "readerr.ss" "syntax"))
+  
+  (provide parse-full parse-full-interactions parse-full-expression parse-full-type)
+    
+  ;; A parser for Java based on the LALR(1) grammar in the Java
+  ;; Language Specification First Edition, extended to support Java 1.1
+  ;; Bugs: Does not handle @deprecated in documentation comments, t.class where
+  ;;       t is an array type
+  
+  (define parsers
+    (parser
+     (start CompilationUnit Interactions VariableInitializer Type)
+     ;;(debug "parser.output")
+     (tokens java-vals special-toks Keywords Separators EmptyLiterals Operators)
+     (error (lambda (tok-ok name val start-pos end-pos)
+              (raise-read-error (format "Parse error near <~a:~a>" name val)
+                                (file-path)
+                                (position-line start-pos)
+                                (position-col start-pos)
+                                (+ (position-offset start-pos) (interactions-offset))
+                                (- (position-offset end-pos)
+                                   (position-offset start-pos)))))
+
+     (end EOF)
+     (src-pos)
+     
+     (grammar
+      
+      ;; 19.3
+      (Literal
+       [(INTEGER_LIT) (make-literal 'int (build-src 1) $1)]
+       [(HEX_LIT) (make-literal 'int (build-src 1) $1)]
+       [(OCT_LIT) (make-literal 'int (build-src 1) $1)]
+       [(LONG_LIT) (make-literal 'long (build-src 1) $1)]
+       [(HEXL_LIT) (make-literal 'long (build-src 1) $1)]
+       [(OCTL_LIT) (make-literal 'long (build-src 1) $1)]
+       [(FLOAT_LIT) (make-literal 'float (build-src 1) $1)]
+       [(DOUBLE_LIT) (make-literal 'double (build-src 1)  $1)]
+       [(TRUE_LIT) (make-literal 'boolean (build-src 1) #t)]
+       [(FALSE_LIT) (make-literal 'boolean (build-src 1) #f)]
+       [(CHAR_LIT) (make-literal 'char (build-src 1) $1)]
+       [(STRING_LIT) (make-literal 'string (make-src (position-line $1-start-pos)
+                                                     (position-col $1-start-pos)
+                                                     (+ (position-offset $1-start-pos) (interactions-offset))
+                                                     (- (position-offset (cadr $1)) (position-offset $1-start-pos))
+                                                     (file-path))
+                                   (car $1))]
+       [(NULL_LIT) (make-literal 'null (build-src 1) #f)])
+      
+      ;; 19.4
+      (Type
+       [(PrimitiveType) $1]
+       [(ReferenceType) $1])
+      
+      (PrimitiveType
+       [(NumericType) $1]
+       [(boolean) (make-type-spec 'boolean 0 (build-src 1))])
+      
+      (NumericType
+       [(IntegralType) $1]
+       [(FloatingPointType) $1])
+      
+      (IntegralType
+       [(byte) (make-type-spec 'byte 0 (build-src 1))]
+       [(short) (make-type-spec 'short 0 (build-src 1))]
+       [(int) (make-type-spec 'int 0 (build-src 1))]
+       [(long) (make-type-spec 'long 0 (build-src 1))]
+       [(char) (make-type-spec 'char 0 (build-src 1))])
+      
+      (FloatingPointType
+       [(float) (make-type-spec 'float 0 (build-src 1))]
+       [(double) (make-type-spec 'double 0 (build-src 1))])
+      
+      (ReferenceType
+       [(Name) (make-type-spec $1 0 (build-src 1))]
+       [(ArrayType) $1]
+       )
+            
+      (ClassOrInterfaceType
+       [(Name) $1])
+      
+      (ClassType
+       [(ClassOrInterfaceType) $1])
+      
+      (InterfaceType
+       [(ClassOrInterfaceType) $1])
+      
+      (ArrayType
+       [(PrimitiveType Dims) (make-type-spec (type-spec-name $1) $2 (build-src 2))]
+       [(Name Dims) (make-type-spec $1 $2 (build-src 2))])
+
+      ;;19.5
+      (Name
+       [(IDENTIFIER) (make-name (make-id $1 (build-src 1)) null (build-src 1))]
+       [(Name PERIOD IDENTIFIER)
+	(make-name (make-id $3 (build-src 3 3)) 
+		       (append (name-path $1) (list (name-id $1)))
+		       (build-src 3))])
+      ;; 19.6
+      (CompilationUnit
+       [(PackageDeclaration ImportDeclarations TypeDeclarations) 
+        (make-package $1 (reverse $2) (reverse $3))]
+       [(ImportDeclarations TypeDeclarations) (make-package #f (reverse $1) (reverse $2))]
+       [(PackageDeclaration TypeDeclarations) (make-package $1 null (reverse $2))]
+       [(PackageDeclaration ImportDeclarations) (make-package $1 (reverse $2) null)]
+       [(PackageDeclaration) (make-package $1 null null)]
+       [(ImportDeclarations) (make-package #f (reverse $1) null)]
+       [(TypeDeclarations) (make-package #f null (reverse $1))]
+       [() (make-package #f null null)])
+
+      (Interactions
+       [(Statement) $1]
+       [(Expression) $1]
+       [(FieldDeclaration) $1]
+       [() null])
+      
+      (ImportDeclarations
+       [(ImportDeclaration) (list $1)]
+       [(ImportDeclarations ImportDeclaration) (cons $2 $1)])
+
+      (TypeDeclarations
+       [(TypeDeclaration) (if $1
+                              (list $1)
+                              null)]
+       [(TypeDeclarations TypeDeclaration) (if $2
+                                               (cons $2 $1)
+                                               $1)])
+      
+      (PackageDeclaration
+       [(package Name SEMI_COLON) $2])
+      
+      (ImportDeclaration
+       [(SingleTypeImportDeclaration) $1]
+       [(TypeImportOnDemandDeclaration) $1])
+      
+      (SingleTypeImportDeclaration
+       [(import Name SEMI_COLON) (make-import $2 #f (build-src 1) (build-src 3) (file-path))])
+      
+      (TypeImportOnDemandDeclaration
+       [(import Name PERIOD * SEMI_COLON)
+	(make-import $2 #t (build-src 1) (build-src 5) (file-path))])
+      
+      (TypeDeclaration
+       [(ClassDeclaration) $1]
+       [(InterfaceDeclaration) $1]
+       [(INTERACTIONS_BOX) $1]
+       [(CLASS_BOX) (parse-class-box $1 (build-src 1) 'full)]
+       [(TEST_SUITE) $1]
+       [(EXAMPLE) $1]
+       [(SEMI_COLON) #f])
+      
+      ;; 19.7
+      (Modifiers
+       [(Modifier) (list $1)]
+       [(Modifiers Modifier) (cons $2 $1)])
+      
+      (Modifier
+       [(public) (make-modifier 'public (build-src 1))]
+       [(protected) (make-modifier 'protected (build-src 1))]
+       [(private) (make-modifier 'private (build-src 1))]
+       [(static) (make-modifier 'static (build-src 1))]
+       [(abstract) (make-modifier 'abstract (build-src 1))]
+       [(final) (make-modifier 'final (build-src 1))]
+       [(strictfp) (make-modifier 'strictfp (build-src 1))]
+       [(native) (make-modifier 'native (build-src 1))]
+       [(synchronized) (make-modifier 'synchronized (build-src 1))]
+       [(transient) (make-modifier 'transient (build-src 1))]
+       [(volatile) (make-modifier 'volatile (build-src 1))])
+      
+      ;; 19.8.1
+      (ClassDeclaration
+       [(Modifiers class IDENTIFIER Super Interfaces ClassBody)
+	(make-class-def (make-header (make-id $3 (build-src 3 3)) $1 $4 $5 null (build-src 5))
+                            $6
+                            (build-src 2 2)
+                            (build-src 6)
+                            (file-path)
+                            'full
+                            null 'top null)]
+       [(class IDENTIFIER Super Interfaces ClassBody)
+	(make-class-def (make-header (make-id $2 (build-src 2 2)) null $3 $4 null (build-src 4))
+                            $5
+                            (build-src 1)
+                            (build-src 5)
+                            (file-path)
+                            'full
+                            null 'top null)])
+      
+      (Super
+       [() null]
+       [(extends ClassType) (list $2)])
+      
+      (Interfaces
+       [() null]
+       [(implements InterfaceTypeList) $2])
+      
+      (InterfaceTypeList
+       [(InterfaceType) (list $1)]
+       [(InterfaceTypeList COMMA InterfaceType) (cons $3 $1)])
+      
+      (ClassBody
+       [(O_BRACE ClassBodyDeclarations C_BRACE) (reverse $2)])
+      
+      (ClassBodyDeclarations
+       [() null]
+       [(ClassBodyDeclarations ClassBodyDeclaration)
+        (cond
+          ((not $2) $1)
+          ((list? $2) (append $2 $1))
+          (else (cons $2 $1)))])
+      
+      (ClassBodyDeclaration
+       [(ClassMemberDeclaration) $1]
+       ;; 1.1
+       [(ClassDeclaration) (begin (set-def-kind! $1 'member) $1)]
+       ;; 1.1
+       [(InterfaceDeclaration) (begin (set-def-kind! $1 'member) $1)]
+       [(StaticInitializer) $1]
+       [(ConstructorDeclaration) $1]
+       [(SEMI_COLON) #f])
+      
+      (ClassMemberDeclaration
+       [(FieldDeclaration) $1]
+       [(MethodDeclaration) $1])
+      
+      ;; 19.8.2
+      (FieldDeclaration
+       [(Modifiers Type VariableDeclarators SEMI_COLON)
+        (map (lambda (d) (build-field-decl $1 $2 d)) (reverse $3))]
+       [(Type VariableDeclarators SEMI_COLON)
+        (map (lambda (d) (build-field-decl null $1 d)) (reverse $2))])
+
+      (VariableDeclarators
+       [(VariableDeclarator) (list $1)]
+       [(VariableDeclarators COMMA VariableDeclarator) (cons $3 $1)])
+      
+      (VariableDeclarator
+       [(VariableDeclaratorId) $1]
+       [(VariableDeclaratorId = VariableInitializer)
+        (make-var-init $1 $3 (build-src 3))])
+
+      (VariableDeclaratorId
+       [(IDENTIFIER)
+	(make-var-decl (make-id $1 (build-src 1)) null (make-type-spec #f 0 (build-src 1)) (build-src 1))]
+       [(IDENTIFIER Dims)
+	(make-var-decl (make-id $1 (build-src 1)) null (make-type-spec #f $2 (build-src 2)) (build-src 2))])
+			
+      (VariableInitializer
+       [(Expression) $1]
+       [(ArrayInitializer) $1])
+
+      ;; 19.8.3
+      (MethodDeclaration
+       [(MethodHeader MethodBody) (make-method (method-modifiers $1)
+                                               (method-type $1)
+                                               (method-type-parms $1)
+                                               (method-name $1)
+                                               (method-parms $1)
+                                               (method-throws $1)
+                                               $2
+                                               #f
+                                               #f
+                                               (build-src 2))])
+
+      (MethodHeader
+       [(Modifiers Type MethodDeclarator Throws) (construct-method-header $1 null $2 $3 $4)]
+       [(Modifiers void MethodDeclarator Throws)
+	(construct-method-header $1 
+				 null 
+				 (make-type-spec 'void 0 (build-src 2 2)) 
+				 $3 
+				 $4)]
+       [(Type MethodDeclarator Throws) (construct-method-header null null $1 $2 $3)]
+       [(void MethodDeclarator Throws)
+	(construct-method-header null
+				 null 
+				 (make-type-spec 'void 0 (build-src 2 2))
+				 $2 
+				 $3)])
+      
+      (MethodDeclarator
+       [(IDENTIFIER O_PAREN FormalParameterList C_PAREN) (list (make-id $1 (build-src 1)) (reverse $3) 0)]
+       [(IDENTIFIER O_PAREN C_PAREN) (list (make-id $1 (build-src 1)) null 0)]
+       [(IDENTIFIER O_PAREN FormalParameterList C_PAREN Dims) (list (make-id $1 (build-src 1)) (reverse $3) $5)]
+       [(IDENTIFIER O_PAREN C_PAREN Dims) (list (make-id $1 (build-src 1)) null $4)])
+      
+      (FormalParameterList
+       [(FormalParameter) (list $1)]
+       [(FormalParameterList COMMA FormalParameter) (cons $3 $1)])
+      
+      (FormalParameter
+       [(Type VariableDeclaratorId) (build-field-decl null $1 $2)]
+       ;; 1.1
+       [(final Type VariableDeclaratorId) (build-field-decl '(final) $2 $3)])
+      
+      (Throws
+       [() null]
+       [(throws ClassTypeList) $2])
+      
+      (ClassTypeList
+       [(ClassType) (list $1)]
+       [(ClassTypeList COMMA ClassType) (cons $3 $1)])
+      
+      (MethodBody
+       [(Block) $1]
+       [(SEMI_COLON) #f])
+      
+      ;; 19.8.4
+      
+      (StaticInitializer
+       [(static Block) (make-initialize #t $2 (build-src 2))]
+       ;; 1.1
+       [(Block) (make-initialize #f $1 (build-src 1))])
+      
+      ;; 19.8.5
+      
+      (ConstructorDeclaration
+       [(Modifiers ConstructorDeclarator Throws ConstructorBody)
+	(make-method $1 (make-type-spec 'ctor 0 (build-src 4)) null (car $2) 
+                         (cadr $2) $3 $4 #f #f (build-src 4))]
+       [(ConstructorDeclarator Throws ConstructorBody)
+	(make-method null (make-type-spec 'ctor 0 (build-src 3)) null (car $1)
+                         (cadr $1) $2 $3 #f #f (build-src 3))])
+      
+      (ConstructorDeclarator
+       [(IDENTIFIER O_PAREN FormalParameterList C_PAREN) (list (make-id $1 (build-src 1)) (reverse $3))]
+       [(IDENTIFIER O_PAREN C_PAREN) (list (make-id $1 (build-src 1)) null)])
+      
+      (ConstructorBody
+       [(O_BRACE ExplicitConstructorInvocation BlockStatements C_BRACE)
+	(make-block (cons $2 (reverse $3)) (build-src 4))]
+       [(O_BRACE ExplicitConstructorInvocation C_BRACE)
+	(make-block (list $2) (build-src 3))]
+       [(O_BRACE BlockStatements C_BRACE)
+	(make-block 
+	 (cons (make-call #f #f #f (make-special-name #f #f "super") null #f)
+	       (reverse $2))
+	 (build-src 3))]
+       [(O_BRACE C_BRACE)
+	(make-block
+	 (list (make-call #f (build-src 1) 
+			      #f (make-special-name #f (build-src 1) "super") null #f))
+	 (build-src 2))])
+      
+      (ExplicitConstructorInvocation
+       [(this O_PAREN ArgumentList C_PAREN SEMI_COLON)
+	(make-call #f (build-src 5) 
+		       #f (make-special-name #f (build-src 1) "this") (reverse $3) #f)]
+       [(this O_PAREN C_PAREN SEMI_COLON)
+	(make-call #f (build-src 4) 
+		       #f (make-special-name #f (build-src 1) "this") null #f)]
+       [(super O_PAREN ArgumentList C_PAREN SEMI_COLON)
+	(make-call #f (build-src 5) 
+		       #f (make-special-name #f (build-src 1) "super") (reverse $3) #f)]
+       [(super O_PAREN C_PAREN SEMI_COLON)
+	(make-call #f (build-src 4) 
+		       #f (make-special-name #f (build-src 1) "super") null #f)])
+      
+      ;; 19.9.1
+      
+      (InterfaceDeclaration
+       [(Modifiers interface IDENTIFIER ExtendsInterfaces InterfaceBody)
+	(make-interface-def (make-header (make-id $3 (build-src 3 3)) $1 $4 null null (build-src 4))
+                                $5
+                                (build-src 2 2)
+                                (build-src 5)
+                                (file-path)
+                                'full
+                                null 'top null)]
+       [(Modifiers interface IDENTIFIER InterfaceBody)
+	(make-interface-def (make-header (make-id $3 (build-src 3 3)) $1 null null null (build-src 3))
+                                $4
+                                (build-src 2 2)
+                                (build-src 4)
+                                (file-path)
+                                'full
+                                null 'top null)]
+       [(interface IDENTIFIER ExtendsInterfaces InterfaceBody)
+       	(make-interface-def (make-header (make-id $2 (build-src 2 2)) null $3 null null (build-src 3))
+                                $4
+                                (build-src 1)
+                                (build-src 4)
+                                (file-path)
+                                'full
+                                null 'top null)]
+       [(interface IDENTIFIER InterfaceBody)
+	(make-interface-def (make-header (make-id $2 (build-src 2 2)) null null null null (build-src 2))
+                                $3
+                                (build-src 1)
+                                (build-src 3)
+                                (file-path)
+                                'full
+                                null 'top null)])
+       
+      
+      (ExtendsInterfaces
+       [(extends InterfaceType) (list $2)]
+       [(ExtendsInterfaces COMMA InterfaceType) (cons $3 $1)])
+
+      (InterfaceBody
+       [(O_BRACE InterfaceMemberDeclarations C_BRACE) $2])
+      
+      (InterfaceMemberDeclarations
+       [() null]
+       
+       [(InterfaceMemberDeclarations InterfaceMemberDeclaration) 
+        (cond
+          ((not $2) $1)
+          ((list? $2) (append $2 $1))
+          (else (cons $2 $1)))])
+      
+      (InterfaceMemberDeclaration
+       [(ConstantDeclaration) $1]
+       ;; 1.1
+       [(ClassDeclaration) $1]
+       ;; 1.1
+       [(InterfaceDeclaration) $1]
+       [(AbstractMethodDeclaration) $1]
+       [(SEMI_COLON) #f])
+      
+      (ConstantDeclaration
+       [(FieldDeclaration) $1])
+      
+      (AbstractMethodDeclaration
+       [(MethodHeader SEMI_COLON) $1])
+      
+      ;; 19.10
+      
+      (ArrayInitializer
+       [(O_BRACE VariableInitializers COMMA C_BRACE) (make-array-init $2 (build-src 3))]
+       [(O_BRACE VariableInitializers C_BRACE) (make-array-init $2 (build-src 3))]
+       [(O_BRACE COMMA C_BRACE) (make-array-init null (build-src 3))]
+       [(O_BRACE C_BRACE) (make-array-init null (build-src 2))])
+      
+      (VariableInitializers
+       [(VariableInitializer) (list $1)]
+       [(VariableInitializers COMMA VariableInitializer) (cons $3 $1)])
+      
+      ;; 19.11
+      
+      (Block
+       [(O_BRACE BlockStatements C_BRACE) (make-block (reverse $2) (build-src 3))]
+       [(O_BRACE C_BRACE) (make-block null (build-src 2))])
+      
+      (BlockStatements
+       [(BlockStatement) (cond
+			  ((list? $1) $1)
+			  (else (list $1)))]
+       [(BlockStatements BlockStatement) (cond
+                                           ((list? $2)
+                                            (append (reverse $2) $1))
+                                           (else
+                                            (cons $2 $1)))])
+      
+      (BlockStatement
+       ;; 1.1
+       [(ClassDeclaration) (begin (set-def-kind! $1 'statement) $1)]
+       [(InterfaceDeclaration) (begin (set-def-kind! $1 'statement) $1)]
+
+       [(LocalVariableDeclarationStatement) $1]
+       [(Statement) $1])
+      
+      (LocalVariableDeclarationStatement
+       [(LocalVariableDeclaration SEMI_COLON) $1]
+       ;; 1.1
+       [(final LocalVariableDeclaration SEMI_COLON)
+        (map (lambda (d)
+               (let* ((decl (cond
+                              ((var-decl? d) d)
+                              (else (var-init-var-decl d))))
+                      (new-decl (make-var-decl (var-decl-name decl)
+                                                   `(final)
+                                                   (var-decl-type decl)
+                                                   (var-decl-src decl))))
+                                 
+                 (cond
+                   ((var-decl? d) new-decl)
+                   (else (make-var-init new-decl
+                                            (var-init-init d)
+                                            (var-init-src d))))))
+             $2)])
+      
+      (LocalVariableDeclaration
+       [(Type VariableDeclarators)
+        (map (lambda (d) (build-field-decl null $1 d)) (reverse $2))])
+      
+      (Statement
+       [(StatementWithoutTrailingSubstatement) $1]
+       [(LabeledStatement) $1]
+       [(IfThenStatement) $1]
+       [(IfThenElseStatement) $1]
+       [(WhileStatement) $1]
+       [(ForStatement) $1])
+      
+      (StatementNoShortIf
+       [(StatementWithoutTrailingSubstatement) $1]
+       [(LabeledStatementNoShortIf) $1]
+       [(IfThenElseStatementNoShortIf) $1]
+       [(WhileStatementNoShortIf) $1]
+       [(ForStatementNoShortIf) $1])
+      
+      (StatementWithoutTrailingSubstatement
+       [(Block) $1]
+       [(EmptyStatement) $1]
+       [(ExpressionStatement) $1]
+       [(SwitchStatement) $1]
+       [(DoStatement) $1]
+       [(BreakStatement) $1]
+       [(ContinueStatement) $1]
+       [(ReturnStatement) $1]
+       [(SynchronizedStatement) $1]
+       [(ThrowStatement) $1]
+       [(TryStatement) $1])
+      
+      (EmptyStatement
+       [(SEMI_COLON) (make-block null (build-src 1))])
+      
+      (LabeledStatement
+       [(IDENTIFIER : Statement) (make-label (make-id $1 (build-src 1)) $3 (build-src 3))])
+      
+      (LabeledStatementNoShortIf
+       [(IDENTIFIER : StatementNoShortIf) (make-label (make-id $1 (build-src 1)) $3 (build-src 3))])
+      
+      (ExpressionStatement
+       [(StatementExpression SEMI_COLON) $1])
+      
+      (StatementExpression
+       [(Assignment) $1]
+       [(PreIncrementExpression) $1]
+       [(PreDecrementExpression) $1]
+       [(PostIncrementExpression) $1]
+       [(PostDecrementExpression) $1]
+       [(MethodInvocation) $1]
+       [(ClassInstanceCreationExpression) $1])
+      
+      (IfThenStatement
+       [(if O_PAREN Expression C_PAREN Statement) (make-ifS $3 $5 #f (build-src 1) (build-src 5))])
+      
+      (IfThenElseStatement
+       [(if O_PAREN Expression C_PAREN StatementNoShortIf else Statement)
+	(make-ifS $3 $5 $7 (build-src 1) (build-src 7))])
+      
+      (IfThenElseStatementNoShortIf
+       [(if O_PAREN Expression C_PAREN StatementNoShortIf else StatementNoShortIf)
+	(make-ifS $3 $5 $7 (build-src 1) (build-src 7))])
+      
+      (SwitchStatement
+       [(switch O_PAREN Expression C_PAREN SwitchBlock)
+	(make-switch $3 $5 (build-src 5))])
+      
+      (SwitchBlock
+       [(O_BRACE SwitchBlockStatementGroups SwitchLabels C_BRACE)
+	(reverse (cons (make-caseS $3 
+                                       (list (make-block null (build-src 4 4)))
+				       (build-src 3 3))
+		       $2))]
+       [(O_BRACE SwitchBlockStatementGroups C_BRACE) (reverse $2)]
+       [(O_BRACE SwitchLabels C_BRACE)
+	(list (make-caseS $2 
+                              (list (make-block null (build-src 2 2)))
+			      (build-src 3)))]
+       [(O_BRACE C_BRACE) null])
+       
+      (SwitchBlockStatementGroups
+       [(SwitchBlockStatementGroup) (list $1)]
+       [(SwitchBlockStatementGroups SwitchBlockStatementGroup) (cons $2 $1)])
+      
+      (SwitchBlockStatementGroup
+       [(SwitchLabels BlockStatements) (make-caseS $1 (reverse $2) (build-src 2))])
+      
+      (SwitchLabels
+       [(SwitchLabel) $1]
+       [(SwitchLabels SwitchLabel) (cons $2 $1)])
+      
+      (SwitchLabel
+       [(case ConstantExpression :) $2]
+       [(default :) 'default])
+      
+      (WhileStatement
+       [(while O_PAREN Expression C_PAREN Statement)
+        (make-while $3 $5 (build-src 5))])
+      
+      (WhileStatementNoShortIf
+       [(while O_PAREN Expression C_PAREN StatementNoShortIf)
+	(make-while $3 $5 (build-src 5))])
+      
+      (DoStatement
+       [(do Statement while O_PAREN Expression C_PAREN SEMI_COLON)
+	(make-doS $2 $5 (build-src 7))])
+      
+      (ForStatement
+       [(for O_PAREN ForInit SEMI_COLON Expression SEMI_COLON ForUpdate C_PAREN Statement)
+	(make-for $3 $5 $7 $9 (build-src 9))]
+       [(for O_PAREN ForInit SEMI_COLON SEMI_COLON ForUpdate C_PAREN Statement)
+	(make-for $3 
+                      (make-literal 'boolean (build-src 4 5) #t) 
+		      $6 
+                      $8 
+                      (build-src 8))])
+	
+      
+      (ForStatementNoShortIf
+       [(for O_PAREN ForInit SEMI_COLON Expression SEMI_COLON ForUpdate C_PAREN StatementNoShortIf)
+	(make-for $3 $5 $7 $9 (build-src 9))]
+       [(for O_PAREN ForInit SEMI_COLON SEMI_COLON ForUpdate C_PAREN StatementNoShortIf)
+      	(make-for $3 (make-literal 'boolean #t (build-src 4 5)) 
+		      $6 $8 (build-src 8))])
+      (ForInit
+       [() null]
+       [(StatementExpressionList) (reverse $1)]
+       [(LocalVariableDeclaration) (reverse $1)])
+      
+      (ForUpdate
+       [() null]
+       [(StatementExpressionList) (reverse $1)])
+      
+      (StatementExpressionList
+       [(StatementExpression) (list $1)]
+       [(StatementExpressionList COMMA StatementExpression) (cons $3 $1)])
+      
+      (BreakStatement
+       [(break IDENTIFIER SEMI_COLON) (make-break (make-id $2 (build-src 2 2)) (build-src 3))]
+       [(break SEMI_COLON) (make-break #f (build-src 2))])
+      
+      (ContinueStatement
+       [(continue IDENTIFIER SEMI_COLON) (make-continue (make-id $2 (build-src 2 2)) (build-src 3))]
+       [(continue SEMI_COLON) (make-continue #f (build-src 2))])
+       
+      (ReturnStatement
+       [(return Expression SEMI_COLON) (make-return $2 #f (build-src 3))]
+       [(return SEMI_COLON) (make-return #f #f (build-src 2))])
+      
+      (ThrowStatement
+       [(throw Expression SEMI_COLON) (make-throw $2 (build-src 1) (build-src 3))])
+      
+      (SynchronizedStatement
+       [(synchronized O_PAREN Expression C_PAREN Block)
+        (make-synchronized $3 $5 (build-src 4))])
+      
+      (TryStatement
+       [(try Block Catches) (make-try $2 (reverse $3) #f (build-src 1) (build-src 3))]
+       [(try Block Catches Finally) (make-try $2 (reverse $3) $4 (build-src 1) (build-src 4))]
+       [(try Block Finally) (make-try $2 null $3 (build-src 1) (build-src 3))])
+      
+      (Catches
+       [(CatchClause) (list $1)]
+       [(Catches CatchClause) (cons $2 $1)])
+      
+      (CatchClause
+       [(catch O_PAREN FormalParameter C_PAREN Block)
+	(make-catch $3 $5 (build-src 5))])
+      
+      (Finally
+       [(finally Block) $2])
+      
+      ;; 19.12
+      
+      (Primary
+       [(PrimaryNoNewArray) $1]
+       [(ArrayCreationExpression) $1])
+      
+      (PrimaryNoNewArray
+       [(Literal) $1]
+       [(this) (make-special-name #f (build-src 1) "this")]
+       [(O_PAREN Expression C_PAREN) $2]
+       [(ClassInstanceCreationExpression) $1]
+       [(FieldAccess) $1]
+       [(MethodInvocation) $1]
+       [(ArrayAccess) $1]
+       ;; 1.1
+       [(PrimitiveType PERIOD class) (unimplemented-1.1 (build-src 1))]
+       ;; 1.1
+       [(Name PERIOD class) (unimplemented-1.1 (build-src 1))]
+       ;; 1.1
+       ;;[(ArrayType PERIOD class)
+       ;; 1.1
+       ;;[(PrimitiveType Dims PERIOD class)
+       ;; 1.1
+       ;;[(Name Dims PERIOD class)
+       ;; 1.1
+       [(void PERIOD class) (unimplemented-1.1 (build-src 1))]
+       ;; 1.1
+       [(Name PERIOD this) (make-specified-this #f (build-src 3) $1 #f)])
+      
+      (ClassInstanceCreationExpression
+       [(new ClassOrInterfaceType O_PAREN ArgumentList C_PAREN)
+	(make-class-alloc #f (build-src 5) $2 (reverse $4) #f #f #f)]
+       [(new ClassOrInterfaceType O_PAREN C_PAREN) 
+	(make-class-alloc #f (build-src 4) $2 null #f #f #f)]
+       ;; 1.1
+       [(new ClassOrInterfaceType O_PAREN ArgumentList C_PAREN ClassBody)
+        (make-anon-class-alloc (build-src 5)
+			       (build-src 2 6)
+			       (build-src 2 6)
+			       $2 $4 $6)]
+       ;; 1.1
+       [(new ClassOrInterfaceType O_PAREN C_PAREN ClassBody)
+        (make-anon-class-alloc (build-src 4)
+			       (build-src 2 4)
+			       (build-src 2 5)
+			       $2 null $5)]
+       ;; 1.1
+       [(Primary PERIOD new IDENTIFIER O_PAREN ArgumentList C_PAREN ClassBody)
+	(unimplemented-1.1 (build-src 1))]
+       ;; 1.1
+       [(Primary PERIOD new IDENTIFIER O_PAREN C_PAREN ClassBody)
+	(unimplemented-1.1 (build-src 1))]
+       ;; 1.1
+       [(Primary PERIOD new IDENTIFIER O_PAREN ArgumentList C_PAREN)
+        (make-inner-alloc #f (build-src 7) $1 (make-id $4 (build-src 4 4)) (reverse $6) #f)]
+;	(unimplemented-1.1 (build-src 1))]
+       ;; 1.1
+       [(Primary PERIOD new IDENTIFIER O_PAREN C_PAREN)
+        (make-inner-alloc #f (build-src 6) $1 (make-id $4 (build-src 4 4)) null #f)]
+;	(unimplemented-1.1 (build-src 1))]
+       ;; 1.1
+       [(Name PERIOD new IDENTIFIER O_PAREN ArgumentList C_PAREN ClassBody)
+	(unimplemented-1.1 (build-src 1))]
+       ;; 1.1
+       [(Name PERIOD new IDENTIFIER O_PAREN C_PAREN ClassBody)
+	(unimplemented-1.1 (build-src 1))]
+       ;; 1.1
+       [(Name PERIOD new IDENTIFIER O_PAREN ArgumentList C_PAREN)
+	(unimplemented-1.1 (build-src 1))]
+       ;; 1.1
+       [(Name PERIOD new IDENTIFIER O_PAREN C_PAREN)
+	(unimplemented-1.1 (build-src 1))])
+      
+      (ArgumentList
+       [(Expression) (list $1)]
+       [(ArgumentList COMMA Expression) (cons $3 $1)])
+      
+      (ArrayCreationExpression
+       [(new PrimitiveType DimExprs Dims) (make-array-alloc #f (build-src 4) $2 (reverse $3) $4)]
+       [(new PrimitiveType DimExprs) (make-array-alloc #f (build-src 3) $2 (reverse $3) 0)]
+       [(new ClassOrInterfaceType DimExprs Dims)
+        (make-array-alloc #f (build-src 4) (make-type-spec $2 0 (build-src 2 2)) (reverse $3) $4)]
+       [(new ClassOrInterfaceType DimExprs)
+        (make-array-alloc #f (build-src 3) (make-type-spec $2 0 (build-src 2 2)) (reverse $3) 0)]
+       ;; 1.1
+       [(new PrimitiveType Dims ArrayInitializer) (make-array-alloc-init #f (build-src 4) $2 $3 $4)]
+       ;; 1.1
+       [(new ClassOrInterfaceType Dims ArrayInitializer) 
+        (make-array-alloc-init #f (build-src 4) (make-type-spec $2 (build-src 2 2)) $3 $4)])
+      
+      (DimExprs
+       [(DimExpr) (list $1)]
+       [(DimExprs DimExpr) (cons $2 $1)])
+
+      (DimExpr
+       [(O_BRACKET Expression C_BRACKET) $2])
+      
+      (Dims
+       [(O_BRACKET C_BRACKET) 1]
+       [(Dims O_BRACKET C_BRACKET) (add1 $1)])
+      
+      (FieldAccess
+       [(Primary PERIOD IDENTIFIER) 
+        (make-access #f (build-src 3) (make-field-access $1 
+                                                         (make-id $3 (build-src 3 3)) #f))]
+       [(super PERIOD IDENTIFIER) 
+        (make-access #f (build-src 3)
+                         (make-field-access (make-special-name #f (build-src 1)
+                                                                       "super")
+                                                (make-id $3 (build-src 3 3))
+                                                #f))]
+       ;; 1.1
+       [(Name PERIOD super PERIOD IDENTIFIER) (unimplemented-1.1 (build-src 1))])
+      
+      (MethodInvocation
+       [(Name O_PAREN ArgumentList C_PAREN) (build-name-call $1 (reverse $3) (build-src 4))]
+       [(Name O_PAREN C_PAREN) (build-name-call $1 null (build-src 3))]
+       [(Primary PERIOD IDENTIFIER O_PAREN ArgumentList C_PAREN)
+        (make-call #f (build-src 6) $1 (make-id $3 (build-src 3 3)) (reverse $5) #f)]
+       [(Primary PERIOD IDENTIFIER O_PAREN C_PAREN)
+        (make-call #f (build-src 5) $1 (make-id $3 (build-src 3 3)) null #f)]
+       [(super PERIOD IDENTIFIER O_PAREN ArgumentList C_PAREN)
+        (make-call #f (build-src 6) 
+                       (make-special-name #f (build-src 1) "super") 
+                       (make-id $3 (build-src 3 3)) (reverse $5) #f)]
+       [(super PERIOD IDENTIFIER O_PAREN C_PAREN)
+        (make-call #f (build-src 5) 
+                       (make-special-name #f (build-src 1) "super") 
+                       (make-id $3 (build-src 3 3)) null #f)]
+       ;; 1.1
+       [(Name PERIOD super PERIOD IDENTIFIER O_PAREN ArgumentList C_PAREN)
+	(unimplemented-1.1 (build-src 1))]
+       ;; 1.1
+       [(Name PERIOD super PERIOD IDENTIFIER O_PAREN C_PAREN) (unimplemented-1.1 (build-src 1))])
+      
+      (ArrayAccess
+       [(Name O_BRACKET Expression C_BRACKET)
+        (make-array-access #f (build-src 4) (name->access $1) $3)]
+       [(PrimaryNoNewArray O_BRACKET Expression C_BRACKET)
+	(make-array-access #f (build-src 4) $1 $3)])
+      
+      (PostfixExpression
+       [(Primary) $1]
+       [(Name) (name->access $1)]
+       [(PostIncrementExpression) $1]
+       [(PostDecrementExpression) $1])
+      
+      (PostIncrementExpression
+       [(PostfixExpression ++) (make-post-expr #f (build-src 2) $1 '++ (build-src 2 2))])
+      
+      (PostDecrementExpression
+       [(PostfixExpression --) (make-post-expr #f (build-src 2) $1 '-- (build-src 2 2))])
+      
+      (UnaryExpression
+       [(PreIncrementExpression) $1]
+       [(PreDecrementExpression) $1]
+       [(+ UnaryExpression) (make-unary #f (build-src 2) '+ $2 (build-src 1))]
+       [(- UnaryExpression) (make-unary #f (build-src 2) '- $2 (build-src 1))]
+       [(UnaryExpressionNotPlusMinus) $1])
+      
+      (PreIncrementExpression
+       [(++ UnaryExpression) (make-pre-expr #f (build-src 2) '++ $2 (build-src 1))])
+
+      (PreDecrementExpression
+       [(-- UnaryExpression) (make-pre-expr #f (build-src 2) '-- $2 (build-src 1))])
+      
+      (UnaryExpressionNotPlusMinus
+       [(PostfixExpression) $1]
+       [(~ UnaryExpression) (make-unary #f (build-src 2) '~ $2 (build-src 1))]
+       [(! UnaryExpression) (make-unary #f (build-src 2) '! $2 (build-src 1))]
+       [(CastExpression) $1])
+      
+      (CastExpression
+       [(O_PAREN PrimitiveType Dims C_PAREN UnaryExpression)
+	(make-cast #f (build-src 5) 
+		       (make-type-spec (type-spec-name $2)
+                                           $3
+                                           (build-src 2 3))
+		       $5)]
+       [(O_PAREN PrimitiveType C_PAREN UnaryExpression)
+	(make-cast #f (build-src 4) $2 $4)]
+       [(O_PAREN Expression C_PAREN UnaryExpressionNotPlusMinus)
+        (if (access? $2)
+            (make-cast #f (build-src 4) 
+                           (make-type-spec (access->name $2) 0 (build-src 2 2)) $4)
+            (error 'bad-cast))]
+       [(O_PAREN Name Dims C_PAREN UnaryExpressionNotPlusMinus)
+	(make-cast #f (build-src 4)
+		       (make-type-spec $2 $3 (build-src 2 3))
+		       $5)])
+
+      (MultiplicativeExpression
+       [(UnaryExpression) $1]
+       [(MultiplicativeExpression * UnaryExpression)
+        (make-bin-op #f (build-src 3) '* $1 $3 (build-src 2 2))]
+       [(MultiplicativeExpression / UnaryExpression)
+	(make-bin-op #f (build-src 3) '/ $1 $3 (build-src 2 2))]
+       [(MultiplicativeExpression % UnaryExpression)
+	(make-bin-op #f (build-src 3) '% $1 $3 (build-src 2 2))])
+      
+      (AdditiveExpression
+       [(MultiplicativeExpression) $1]
+       [(AdditiveExpression + MultiplicativeExpression)
+	(make-bin-op #f (build-src 3) '+ $1 $3 (build-src 2 2))]
+       [(AdditiveExpression - MultiplicativeExpression)
+	(make-bin-op #f (build-src 3) '- $1 $3 (build-src 2 2))])
+      
+      (ShiftExpression
+       [(AdditiveExpression) $1]
+       [(ShiftExpression << AdditiveExpression)
+	(make-bin-op #f (build-src 3) '<< $1 $3 (build-src 2 2))]
+       [(ShiftExpression >> AdditiveExpression)
+	(make-bin-op #f (build-src 3) '>> $1 $3 (build-src 2 2))]	
+       [(ShiftExpression >>> AdditiveExpression)
+	(make-bin-op #f (build-src 3) '>>> $1 $3 (build-src 2 2))])
+      
+
+      (RelationalExpression
+       [(ShiftExpression) $1]
+       ;; GJ - changed to remove shift/reduce conflict
+       [(ShiftExpression < ShiftExpression)
+        (make-bin-op #f (build-src 3) '< $1 $3 (build-src 2 2))]		
+       [(RelationalExpression > ShiftExpression)
+	(make-bin-op #f (build-src 3) '> $1 $3 (build-src 2 2))]	
+       [(RelationalExpression <= ShiftExpression)
+	(make-bin-op #f (build-src 3) '<= $1 $3 (build-src 2 2))]	
+       [(RelationalExpression >= ShiftExpression)
+	(make-bin-op #f (build-src 3) '>= $1 $3 (build-src 2 2))]	
+       [(RelationalExpression instanceof ReferenceType)
+	(make-instanceof #f (build-src 3) $1 $3 (build-src 2 2))])
+      
+
+      (EqualityExpression
+       [(RelationalExpression) $1]
+       [(EqualityExpression == RelationalExpression)
+	(make-bin-op #f (build-src 3) '== $1 $3 (build-src 2 2))]	
+       [(EqualityExpression != RelationalExpression)
+	(make-bin-op #f (build-src 3) '!= $1 $3 (build-src 2 2))])
+      
+      (AndExpression
+       [(EqualityExpression) $1]
+       [(AndExpression & EqualityExpression)
+	(make-bin-op #f (build-src 3) '& $1 $3 (build-src 2 2))])
+	
+      
+      (ExclusiveOrExpression
+       [(AndExpression) $1]
+       [(ExclusiveOrExpression ^ AndExpression)
+	(make-bin-op #f (build-src 3) '^ $1 $3 (build-src 2 2))])
+
+      
+      (InclusiveOrExpression
+       [(ExclusiveOrExpression) $1]
+       [(InclusiveOrExpression PIPE ExclusiveOrExpression)
+	(make-bin-op #f (build-src 3) 'or $1 $3 (build-src 2 2))])
+      
+      (ConditionalAndExpression
+       [(InclusiveOrExpression) $1]
+       [(ConditionalAndExpression && InclusiveOrExpression)
+	(make-bin-op #f (build-src 3) '&& $1 $3 (build-src 2 2))])
+      
+      (ConditionalOrExpression
+       [(ConditionalAndExpression) $1]
+       [(ConditionalOrExpression OR ConditionalAndExpression)
+	(make-bin-op #f (build-src 3) 'oror $1 $3 (build-src 2 2))])
+      
+      (ConditionalExpression
+       [(ConditionalOrExpression) $1]
+       [(ConditionalOrExpression ? Expression : ConditionalExpression)
+	(make-cond-expression #f (build-src 5) $1 $3 $5 (build-src 2 2))])
+      
+      (AssignmentExpression
+       [(ConditionalExpression) $1]
+       [(Assignment) $1])
+      
+      (Assignment
+       [(LeftHandSide AssignmentOperator AssignmentExpression)
+	(make-assignment #f (build-src 3) $1 $2 $3 (build-src 2 2))])
+      
+      (LeftHandSide
+       [(Name) (name->access $1)]
+       [(FieldAccess) $1]
+       [(ArrayAccess) $1])
+      
+      (AssignmentOperator
+       [(=) '=]
+       [(*=) '*=]
+       [(/=) '/=]
+       [(%=) '%=]
+       [(+=) '+=]
+       [(-=) '-=]
+       [(<<=) '<<=]
+       [(>>=) '>>=]
+       [(>>>=) '>>>=]
+       [(&=) '&=]
+       [(^=) '^=]
+       [(OREQUAL) 'or=])
+      
+      (Expression
+       [(AssignmentExpression) $1])
+      
+      (ConstantExpression
+       [(Expression) $1]))))
+  
+  (define (unimplemented-1.1 src)
+    (raise-read-error "Unimplemented 1.1"
+ 		      (file-path)
+ 		      (src-line src)
+ 		      (src-col src)
+ 		      (src-pos src)
+ 		      (src-span src)))
+  
+  ;make-anon-class-alloc: src src src id (list field) statement -> class-alloc
+  (define (make-anon-class-alloc all-src head-src class-src super args body)
+    (let ([anon (symbol->string (gensym 'anonymous$))])
+      (make-class-alloc #f all-src
+			(make-class-def (make-header (make-id anon all-src) null (list super) null null head-src)
+					body
+					class-src
+					class-src
+					(file-path)
+					'full
+					null 'anon null)
+			(reverse args) #t #f #t)))
+  
+  (define parse-full (car parsers))
+  (define parse-full-interactions (cadr parsers))
+  (define parse-full-expression (caddr parsers))
+  (define parse-full-type (cadddr parsers))
+
+  )
diff --git a/collects/profj/parsers/general-parsing.ss b/collects/profj/parsers/general-parsing.ss
new file mode 100644
index 0000000000..59e6dedac0
--- /dev/null
+++ b/collects/profj/parsers/general-parsing.ss
@@ -0,0 +1,300 @@
+#cs
+(module general-parsing mzscheme
+  
+  (require (all-except (lib "lex.ss" "parser-tools") input-port)
+           (lib "string.ss")
+           (prefix class: (lib "class.ss"))
+           (lib "list.ss"))
+  (require "../ast.ss" "../parameters.ss" "lexer.ss")
+  
+  (provide (all-defined))
+
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;Methods used by all generated parsers
+  (define-syntax (build-src stx)
+    (syntax-case stx ()
+      ((_ end)
+       (syntax (build-src 1 end)))
+      ((_ start end)
+       (with-syntax ((start-pos (datum->syntax-object 
+                                 (syntax end)
+                                 (string->symbol 
+                                  (format "$~a-start-pos"
+                                          (syntax-object->datum (syntax start))))))
+                     (end-pos (datum->syntax-object 
+                               (syntax end)
+                               (string->symbol 
+                                (format "$~a-end-pos"
+                                        (syntax-object->datum (syntax end)))))))
+         (syntax
+          (make-src (position-line start-pos)
+                    (position-col start-pos)
+                    (+ (position-offset start-pos) (interactions-offset))
+                    (- (position-offset end-pos)
+                       (position-offset start-pos))
+                    (file-path)
+                    ))))))
+  
+  (define (construct-method-header mods type-parms ret-type declarator throws)
+    (make-method mods 
+                 (make-type-spec (type-spec-name ret-type)
+                                 (+ (type-spec-dim ret-type) (caddr declarator))
+                                 (type-spec-src ret-type))
+                 type-parms
+                 (car declarator)
+                 (cadr declarator)
+                 throws
+                 #f
+                 #f
+                 #f
+                 #f))
+  
+  (define (name->access n)
+    (make-access #f
+                 (name-src n)
+                 (append (name-path n) (list (name-id n)))))
+  
+  (define (access->name a)
+    (make-name (car (reverse (access-name a)))
+               (cdr (access-name a))
+               (expr-src a)))
+  
+  (define (build-name-call name args src-loc)
+    (make-call #f src-loc 
+               (if (null? (name-path name))
+                   #f
+                   (make-access #f 
+                                (name-src name)
+                                (name-path name)))
+               (name-id name)
+               args 
+               #f))
+  
+  (define (build-field-decl mods type decl)
+    (cond
+      ((var-decl? decl)
+       (make-var-decl (var-decl-name decl)
+                      mods
+                      (make-type-spec
+                       (type-spec-name type)
+                       (+ (type-spec-dim type) 
+                          (type-spec-dim (var-decl-type decl)))
+                       (type-spec-src type))
+                      (var-decl-src decl)))
+      ((var-init? decl)
+       (make-var-init
+        (build-field-decl mods type (var-init-var-decl decl))
+        (var-init-init decl)
+        (var-init-src decl)))))
+  
+;  (define (parse-class-box box box-pos level)
+;    (let*-values (((old-input-port) (input-port))
+;                  ((old-file-path) (file-path))
+;                  ((func _ __) (class:send (class-case-box box) read-one-special 0 #f #f #f #f))
+;                  ((parse-port-list) (func 'level)))
+;      (input-port (car parse-port-list))
+;      (begin0
+;        (car (package-defs ((cadr parse-port-list))))
+;        (file-path old-file-path)
+;        (input-port old-input-port))))
+
+  (define (parse-class-box box box-pos level)
+    (let*-values (((old-file-path) (file-path))
+                  ((old-lex-stream) (lex-stream))
+                  ((parse-func _ __) (class:send (class-case-box box) read-one-special 0 #f #f #f #f))
+                  ((class-ast) (parse-func level old-file-path box-pos lex-stream)))
+      (begin0
+        class-ast
+        (lex-stream old-lex-stream)
+        (file-path old-file-path))))
+;  
+;  (lambda (level class-loc box-pos input-spec)
+;    (make-class-def (make-header ....)
+;                    (list methods, fields, ctor)
+;                    #f
+;                    box-pos
+;                    class-loc
+;                    level
+;                    null
+;                    'top))
+;  (anytime before call parse-method
+;           (let ((old-input (input-spec)))
+;             (input-spec (lambda () get-the-port))
+;             (begin0 (parse-method ... )
+;                     (input-spec old-input))))
+           
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;Token Accessors and Queries for error-messaging parsers
+    
+  (define-syntax define-token?
+    (syntax-rules ()
+                  [(_ name check)
+                   (define (name token) (eq? (token-name token) check))]))
+
+  ;get-token-name: token -> symbol
+  (define get-token-name token-name)
+  
+  ;Special
+  (define-token? eof? 'EOF)
+  
+  ;Modifiers
+  (define-token? abstract? 'abstract)
+  (define-token? native? 'native)
+  (define-token? private? 'private)
+  (define-token? protected? 'protected)
+  (define-token? public? 'public)
+  (define-token? static? 'static)
+  (define-token? strictfp? 'strictfp)
+  (define-token? transient? 'transient)
+  (define-token? volatile? 'volatile)
+  (define-token? final? 'final)
+  (define (modifier-token? token)
+    (and (symbol? token) (memq token `(abstract native private protected public static strictfp transient volatile))))
+  
+  ;Literals
+  (define (literal-token? token)
+    (or (empty-literal? token) (full-literal? token)))
+  (define (empty-literal? token)
+    (and (symbol? token) (memq token `(NULL_LIT TRUE_LIT FALSE_LIT))))
+  (define (full-literal? token)
+    (and (token? token) (memq (token-name token) `(STRING_LIT CHAR_LIT INTEGER_LIT LONG_LIT FLOAT_LIT DOUBLE_LIT))))
+  
+  ;Primitive types
+  (define (prim-type? token)
+    (and (symbol? token) (memq token `(boolean byte char double float int long short))))
+  
+  ;Operators
+  (define (bin-operator? token)
+    (memq (get-token-name token) `(PIPE OR > < == <= >= != && + - * / & ^ % << >> >>>)))
+  (define (unary-end? token)
+    (memq (get-token-name token) `(++ --)))
+  (define (if-exp? token)
+    (eq? (get-token-name token) '?))
+  (define (teaching-unary-operator? token)
+    (and (symbol? token) (memq token `(! ~))))
+  (define (unary-operator? token)
+    (and (symbol? token) (memq token `(! ~ ++ --))))
+  (define (teaching-assignment-operator? token)
+    (and (symbol? token) (eq? token '=)))
+  (define (assignment-operator? token)
+    (and (symbol? token) (memq token `(= += -= *= /= &= ^= %= <<= >>= >>>=))))
+  
+  ;Separators
+  (define-token? o-paren? 'O_PAREN)
+  (define-token? c-paren? 'C_PAREN)
+  (define-token? o-brace? 'O_BRACE)
+  (define-token? c-brace? 'C_BRACE)
+  (define-token? o-bracket? 'O_BRACKET)
+  (define-token? c-bracket? 'C_BRACKET)
+  (define-token? star? '*)
+  (define-token? semi-colon? 'SEMI_COLON)
+  (define-token? colon? ':)
+  (define-token? dot? 'PERIOD)
+  (define-token? comma? 'COMMA)
+  
+  (define (separator? tok)
+    (or (open-separator? tok) (close-separator? tok)
+        (memq (get-token-name tok) `(SEMI_COLON PERIOD COMMA))))
+  (define (open-separator? tok)
+    (memq (get-token-name tok) `(O_PAREN O_BRACE O_BRACKET)))
+  (define (close-separator? tok)
+    (memq (get-token-name tok) `(C_PAREN C_BRACE C_BRACKET)))
+  
+  ;top-level keywords
+  (define-token? package-token? 'package)
+  (define-token? import-token? 'import)
+  
+  ;Definition keywords
+  (define-token? class? 'class)
+  (define-token? extends? 'extends)
+  (define-token? implements? 'implements)
+  (define-token? interface? 'interface)
+  
+  ;Method keywords
+  (define-token? const? 'const)
+  (define-token? throws-token? 'throws)
+  (define-token? void-token? 'void)
+  
+  ;Statement keywords
+  (define-token? break-token? 'break)
+  (define-token? case-token? 'case)
+  (define-token? catch-token? 'catch)
+  (define-token? continue-token? 'continue)
+  (define-token? defualt? 'default)
+  (define-token? do-token? 'do)
+  (define-token? else? 'else)
+  (define-token? finally? 'finally)
+  (define-token? for-token? 'for)
+  (define-token? goto? 'goto)
+  (define-token? if-token? 'if)
+  (define-token? return-token? 'return)
+  (define-token? switch-token? 'switch)
+  (define-token? synchronized-token? 'synchronized)
+  (define-token? throw-token? 'throw)
+  (define-token? try-token? 'try)
+  (define-token? while-token? 'while)
+
+  ;Expression tokens
+  (define-token? instanceof-token? 'instanceof)
+  (define-token? new-token? 'new)
+  (define-token? super? 'super)
+  (define-token? this? 'this)
+  (define-token? cond? '?)
+  (define-token? id-token? 'IDENTIFIER)
+  
+  ;keyword? lex-token -> bool
+  (define (keyword? t)
+    (or (memq (get-token-name t) `(? this super new instanceof while try throw synchronized switch return if goto for finally
+                                     else do default continue catch case break void throws const interface implements extends
+                                     class import package))
+        (assignment-operator? t)
+        (prim-type? t)
+        (modifier? t)))
+  
+  ;only looks for incorrect capitalization at this point, intend to add 1-off spelling errors for at least some keywords
+  ;close-to-keyword? token (opt symbol )-> bool
+  (define (close-to-keyword? t . args)
+    (if (id-token? t)
+        (let ((s (string-copy (token-value t))))
+          (string-lowercase! s)
+          (if (null? args)
+              (or (keyword? (string->symbol s))
+                  (member s all-words))
+              (or (eq? (string->symbol s) (car args))
+                  (member s (select-words (car args))))))
+        #f))
+  
+  (define misspelled-list '((import "mport" "iport" "imort" "imprt" "impot" "impor" "improt")
+                            (class "lass" "cass" "clss" "clas" "calss")
+                            (abstract 
+                             "bstract" "astract" "abtract" "absract" "abstact" "abstrct" "abstrat" "abstract" "abstarct" "abstracts")
+                            (extends "xtends" "etends" "exends" "extnds" "exteds" "extens" "extneds" "extend")
+                            (new "nw" "ne" "nwe")
+                            (this "his" "tis" "ths" "thi" "tihs" "thsi")
+                            (if "fi")
+                            (else "lse" "ese" "els" "eles")
+                            (return "eturn" "rturn" "reurn" "retrn" "retun" "retur" "reutrn" "retrun" "returns")
+                            (true "rue" "tue" "tre" "tru" "ture" "treu")
+                            (false "flse" "fase" "fale" "fals" "flase" "fasle")
+                            (interface
+                                "nterface" "iterface" "inerface" "intrface" "inteface" "interace" "interfce" "interfae" "intreface")
+                            (implements 
+                             "mplements" "iplements" "impements" "implments" "impleents" "implemnts" "implemets" "implemens"
+                             "implement")
+                            (void "oid" "vid" "voi" "viod")
+                            (super "uper" "sper" "supr" "supe" "supper")
+                            (public "ublic" "pblic" "pulic" "pubic" "publc" "publi" "pubilc")
+                            (private "rivate" "pivate" "prvate" "priate" "privte" "privae" "privat" "pravite")
+                            (package "ackage" "pckage" "pakage" "pacage" "packge" "packae" "packag")
+                            (protected "rotected" "portected")
+                            (final "inal" "fnal" "fial" "finl" "finale" "fianl")
+                            ))
+
+  (define (select-words key)
+    (safe-car (filter (lambda (x) (eq? (car x) key)) misspelled-list)))
+  (define (safe-car f)
+    (if (null? f) null (car f)))
+  
+  (define all-words (filter string? (apply append misspelled-list)))
+                                
+  )
\ No newline at end of file
diff --git a/collects/profj/parsers/info.ss b/collects/profj/parsers/info.ss
new file mode 100644
index 0000000000..da6aec894b
--- /dev/null
+++ b/collects/profj/parsers/info.ss
@@ -0,0 +1,2 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "ProfessorJ: parsers"))
\ No newline at end of file
diff --git a/collects/profj/parsers/intermediate-parser.ss b/collects/profj/parsers/intermediate-parser.ss
new file mode 100644
index 0000000000..73790b4514
--- /dev/null
+++ b/collects/profj/parsers/intermediate-parser.ss
@@ -0,0 +1,604 @@
+#cs
+(module intermediate-parser mzscheme
+
+  (require "general-parsing.ss"
+           "lexer.ss"
+           "../ast.ss"
+           "../parameters.ss")
+  
+  (require (lib "yacc.ss" "parser-tools")
+           (all-except (lib "lex.ss" "parser-tools") input-port)
+           (lib "readerr.ss" "syntax"))
+  
+  (require-for-syntax "lexer.ss")
+  ;(require (lib "build-grammar.ss" "tester"))
+
+  (define-syntax testing-parser
+    (syntax-rules ()
+      ((_ parse-info ...) (parser parse-info ...))))  
+  
+  (provide parse-intermediate parse-intermediate-interactions 
+           parse-intermediate-expression parse-intermediate-type)
+  ;(provide intermediate-grammar)
+  
+  
+  (define parsers
+    (testing-parser
+     (start CompilationUnit IntermediateInteractions Expression Type)
+     ;;(debug "parser.output")
+     (tokens java-vals special-toks Keywords Separators EmptyLiterals Operators)
+     ;(terminals val-tokens special-tokens keyword-tokens separator-tokens literal-tokens operator-tokens)
+     (error (lambda (tok-ok name val start-pos end-pos)
+              (if ((determine-error))
+                  (raise-read-error (format "Parse error near <~a:~a>" name val)
+                                    (file-path)
+                                    (position-line start-pos)
+                                    (position-col start-pos)
+                                    (+ (position-offset start-pos) (interactions-offset))
+                                    (- (position-offset end-pos)
+                                       (position-offset start-pos))))))
+
+     (end EOF)
+     (src-pos)
+     
+     (grammar
+      
+      ;; 19.3
+      (Literal
+       [(INTEGER_LIT) (make-literal 'int (build-src 1) $1)]
+       [(LONG_LIT) (make-literal 'long (build-src 1) $1)]
+       [(FLOAT_LIT) (make-literal 'float (build-src 1) $1)]
+       [(DOUBLE_LIT) (make-literal 'double (build-src 1)  $1)]
+       [(TRUE_LIT) (make-literal 'boolean (build-src 1) #t)]
+       [(FALSE_LIT) (make-literal 'boolean (build-src 1) #f)]
+       [(CHAR_LIT) (make-literal 'char (build-src 1) $1)]
+       [(STRING_LIT) (make-literal 'string 
+                                    (make-src (position-line $1-start-pos)
+                                              (position-col $1-start-pos)
+                                              (+ (position-offset $1-start-pos) (interactions-offset))
+                                              (- (position-offset (cadr $1)) (position-offset $1-start-pos))
+                                              (file-path))
+                                   (car $1))]
+       [(NULL_LIT) (make-literal 'null (build-src 1) #f)])
+      
+      ;; 19.4
+      (Type
+       [(PrimitiveType) $1]
+       [(ReferenceType) $1])
+      
+      (PrimitiveType
+       [(NumericType) $1]
+       [(boolean) (make-type-spec 'boolean 0 (build-src 1))])
+      
+      (NumericType
+       [(IntegralType) $1]
+       [(FloatingPointType) $1])
+      
+      (IntegralType
+       [(byte) (make-type-spec 'byte 0 (build-src 1))]
+       [(short) (make-type-spec 'short 0 (build-src 1))]
+       [(int) (make-type-spec 'int 0 (build-src 1))]
+       [(long) (make-type-spec 'long 0 (build-src 1))]
+       [(char) (make-type-spec 'char 0 (build-src 1))])
+      
+      (FloatingPointType
+       [(float) (make-type-spec 'float 0 (build-src 1))]
+       [(double) (make-type-spec 'double 0 (build-src 1))])
+      
+      (ReferenceType
+       ;; GJ - To fix the problem mentioned below
+       ;; [(ClassOrInterfaceType) #t]
+       ;; GJ - Some type variables will come out as names, so a post-pass needs
+       ;;      to convert them to type-vars
+       [(Name) (make-type-spec $1 0 (build-src 1))]
+        )
+            
+      (ClassOrInterfaceType
+       [(Name) $1])
+       
+      (ClassType
+       [(ClassOrInterfaceType) $1])
+      
+      (InterfaceType
+       [(ClassOrInterfaceType) $1])
+
+      ;;19.5
+      (Name
+       [(IDENTIFIER) (make-name (make-id $1 (build-src 1)) null (build-src 1))]
+       [(Name PERIOD IDENTIFIER)
+	(make-name (make-id $3 (build-src 3 3)) 
+		       (append (name-path $1) (list (name-id $1)))
+		       (build-src 3))])
+      ;; 19.6
+      (CompilationUnit
+       [(ImportDeclarations TypeDeclarations) (make-package #f (reverse $1) (reverse $2))]
+       [(TypeDeclarations) (make-package #f null (reverse $1))]
+       [(ImportDeclarations) (make-package #f (reverse $1) null)]
+       [() (make-package #f null null)])
+      
+      (ImportDeclarations
+       [(ImportDeclaration) (list $1)]
+       [(ImportDeclarations ImportDeclaration) (cons $2 $1)])
+      
+      (ImportDeclaration
+       [(import Name SEMI_COLON) (make-import $2 #f (build-src 1) (build-src 3) (file-path))]
+       [(import Name PERIOD * SEMI_COLON)
+	(make-import $2 #t (build-src 1) (build-src 5) (file-path))])
+      
+      (IntermediateInteractions
+       [(Statement) $1]
+       [(Expression) $1]
+       [(FieldDeclaration) $1]
+       [() null])
+      
+      (TypeDeclarations
+       [(TypeDeclaration) (if $1 (list $1) null)]
+       [(TypeDeclarations TypeDeclaration) (if $2
+                                               (cons $2 $1)
+                                               $1)])
+      
+      (TypeDeclaration
+       [(ClassDeclaration) $1]
+       [(InterfaceDeclaration) $1]
+       [(INTERACTIONS_BOX) $1]
+       [(CLASS_BOX) (parse-class-box $1 (build-src 1) 'intermediate)]
+       [(EXAMPLE) $1]
+       [(TEST_SUITE) $1]
+       [(SEMI_COLON) #f])
+      
+      ;; 19.7
+      (Modifiers
+       [(Modifier) (list $1)])
+;       [(Modifiers Modifier) (cons $2 $1)])
+      
+      (Modifier
+       [(abstract) (make-modifier 'abstract (build-src 1))])
+      
+      ;; 19.8.1
+      (ClassDeclaration
+       [(Modifiers class IDENTIFIER Super Interfaces ClassBody)
+	(make-class-def (make-header (make-id $3 (build-src 3 3)) $1 $4 $5 null (build-src 5))
+                            $6
+                            (build-src 2 2)
+                            (build-src 6)
+                            (file-path)
+                            'intermediate
+                            null 'top null)]
+       [(class IDENTIFIER Super Interfaces ClassBody)
+	(make-class-def (make-header (make-id $2 (build-src 2 2)) null $3 $4 null (build-src 4))
+                            $5
+                            (build-src 1)
+                            (build-src 5)
+                            (file-path)
+                            'intermediate
+                            null 'top null)])
+      
+      (Super
+       [() null]
+       [(extends ClassType) (list $2)])
+      
+      (Interfaces
+       [() null]
+       [(implements InterfaceTypeList) $2])
+      
+      (InterfaceTypeList
+       [(InterfaceType) (list $1)]
+       [(InterfaceTypeList COMMA InterfaceType) (cons $3 $1)])
+      
+      (ClassBody
+       [(O_BRACE ClassBodyDeclarations C_BRACE) (reverse $2)])
+      
+      (ClassBodyDeclarations
+       [() null]
+       [(ClassBodyDeclarations ClassBodyDeclaration)
+        (cond
+          ((not $2) $1)
+          ((list? $2) (append $2 $1))
+          (else (cons $2 $1)))])
+      
+      (ClassBodyDeclaration
+       [(ClassMemberDeclaration) $1]
+       [(ConstructorDeclaration) $1]
+       [(SEMI_COLON) #f])
+      
+      (ClassMemberDeclaration
+       [(FieldDeclaration) $1]
+       [(MethodDeclaration) $1])
+      
+      ;; 19.8.2
+      (FieldDeclaration
+       [(Type VariableDeclarators SEMI_COLON)
+        (map (lambda (d) (build-field-decl null $1 d)) (reverse $2))])
+
+      (VariableDeclarators
+       [(VariableDeclarator) (list $1)]
+       [(VariableDeclarators COMMA VariableDeclarator) (cons $3 $1)])
+      
+      (VariableDeclarator
+       [(VariableDeclaratorId) $1]
+       [(VariableDeclaratorId = VariableInitializer)
+        (make-var-init $1 $3 (build-src 3))])
+
+      (VariableDeclaratorId
+       [(IDENTIFIER)
+	(make-var-decl (make-id $1 (build-src 1)) 
+                       (list (make-modifier 'public #f))
+                       (make-type-spec #f 0 (build-src 1)) (build-src 1))])
+			
+      (VariableInitializer
+       [(Expression) $1])
+
+      ;; 19.8.3
+      (MethodDeclaration
+       [(MethodHeader MethodBody) (make-method (method-modifiers $1)
+                                               (method-type $1)
+                                               (method-type-parms $1)
+                                               (method-name $1)
+                                               (method-parms $1)
+                                               (method-throws $1)
+                                               $2
+                                               #f
+                                               #f
+                                               (build-src 2))])
+
+      (MethodHeader
+       [(Modifiers Type MethodDeclarator) (construct-method-header (cons (make-modifier 'public #f) $1) null $2 $3 null)]
+       [(Modifiers void MethodDeclarator)
+	(construct-method-header (cons (make-modifier 'public #f) $1)
+				 null 
+				 (make-type-spec 'void 0 (build-src 2 2))
+				 $3
+				 null)]
+       [(Type MethodDeclarator) (construct-method-header (list (make-modifier 'public #f)) null $1 $2 null)]
+       [(void MethodDeclarator)
+	(construct-method-header (list (make-modifier 'public #f))
+				 null 
+				 (make-type-spec 'void 0 (build-src 1 1))
+				 $2
+				 null)])
+
+      
+      (MethodDeclarator
+       [(IDENTIFIER O_PAREN FormalParameterList C_PAREN) (list (make-id $1 (build-src 1)) (reverse $3) 0)]
+       [(IDENTIFIER O_PAREN C_PAREN) (list (make-id $1 (build-src 1)) null 0)])
+      
+      (FormalParameterList
+       [(FormalParameter) (list $1)]
+       [(FormalParameterList COMMA FormalParameter) (cons $3 $1)])
+      
+      (FormalParameter
+       [(Type VariableDeclaratorId) (build-field-decl null $1 $2)])
+      
+      (MethodBody
+       [(Block) $1]
+       [(SEMI_COLON) #f])
+      
+      ;; 19.8.5
+      
+      (ConstructorDeclaration
+       [(ConstructorDeclarator ConstructorBody)
+	(make-method (list (make-modifier 'public #f))         
+                     (make-type-spec 'ctor 0 (build-src 2)) null (car $1)
+                     (cadr $1) null $2 #f #f (build-src 2))])
+      
+      (ConstructorDeclarator
+       [(IDENTIFIER O_PAREN FormalParameterList C_PAREN) (list (make-id $1 (build-src 1)) (reverse $3))]
+       [(IDENTIFIER O_PAREN C_PAREN) (list (make-id $1 (build-src 1)) null)])
+      
+      (ConstructorBody
+       [(O_BRACE ExplicitConstructorInvocation BlockStatements C_BRACE)
+	(make-block (cons $2 (reverse $3)) (build-src 4))]
+       [(O_BRACE ExplicitConstructorInvocation C_BRACE)
+	(make-block (list $2) (build-src 3))]
+       [(O_BRACE BlockStatements C_BRACE)
+	(make-block 
+	 (cons (make-call #f (build-src 3) #f (make-special-name #f #f "super") null #f)
+	       (reverse $2))
+	 (build-src 3))]
+       [(O_BRACE C_BRACE)
+	(make-block
+	 (list (make-call #f (build-src 2) 
+			      #f (make-special-name #f #f "super") null #f))
+	 (build-src 2))])
+      
+      (ExplicitConstructorInvocation
+       [(super O_PAREN ArgumentList C_PAREN SEMI_COLON)
+	(make-call #f (build-src 5) 
+		       #f (make-special-name #f (build-src 1) "super") (reverse $3) #f)]
+       [(super O_PAREN C_PAREN SEMI_COLON)
+	(make-call #f (build-src 4) 
+		       #f (make-special-name #f (build-src 1) "super") null #f)])
+      
+      ;; 19.9.1
+      
+      (InterfaceDeclaration
+       [(interface IDENTIFIER ExtendsInterfaces InterfaceBody)
+       	(make-interface-def (make-header (make-id $2 (build-src 2 2)) (list (make-modifier 'public #f))
+                                         $3 null null (build-src 3))
+                                $4
+                                (build-src 1)
+                                (build-src 4)
+                                (file-path)
+                                'intermedaite
+                                null 'top null)]
+       [(interface IDENTIFIER InterfaceBody)
+	(make-interface-def (make-header (make-id $2 (build-src 2 2))(list (make-modifier 'public #f))
+                                         null null null (build-src 2))
+                                $3
+                                (build-src 1)
+                                (build-src 3)
+                                (file-path)
+                                'intermdediate
+                                null 'top null)])
+      
+      (ExtendsInterfaces
+       [(extends InterfaceType) (list $2)]
+       [(ExtendsInterfaces COMMA InterfaceType) (cons $3 $1)])
+
+      (InterfaceBody
+       [(O_BRACE InterfaceMemberDeclarations C_BRACE) $2])
+      
+      (InterfaceMemberDeclarations
+       [() null]
+       [(InterfaceMemberDeclarations InterfaceMemberDeclaration)
+        (cond
+          ((not $2) $1)
+          ((list? $2) (append $2 $1))
+          (else (cons $2 $1)))])
+      
+      (InterfaceMemberDeclaration
+       [(AbstractMethodDeclaration) $1]
+       [(SEMI_COLON) #f])
+      
+      (AbstractMethodDeclaration
+       [(MethodHeader SEMI_COLON) $1])
+      
+      (VariableInitializers
+       [(VariableInitializer) (list $1)]
+       [(VariableInitializers COMMA VariableInitializer) (cons $3 $1)])
+      
+      ;; 19.11
+      
+      (Block
+       [(O_BRACE BlockStatements C_BRACE) (make-block (reverse $2) (build-src 3))]
+       [(O_BRACE C_BRACE) (make-block null (build-src 2))])
+      
+      (BlockStatements
+       [(BlockStatement) (cond
+			  ((list? $1) $1)
+			  (else (list $1)))]
+       [(BlockStatements BlockStatement) (cond
+                                           ((list? $2)
+                                            (append (reverse $2) $1))
+                                           (else
+                                            (cons $2 $1)))])
+      
+      (BlockStatement
+       [(LocalVariableDeclarationStatement) $1]
+       [(Statement) $1])
+      
+      (LocalVariableDeclarationStatement
+       [(LocalVariableDeclaration SEMI_COLON) $1])
+      
+      (LocalVariableDeclaration
+       [(Type VariableDeclarators)
+        (map (lambda (d) (build-field-decl null $1 d)) (reverse $2))])
+      
+      (Statement
+       [(StatementWithoutTrailingSubstatement) $1]
+       [(IfThenElseStatement) $1])
+      
+      (StatementNoShortIf
+       [(StatementWithoutTrailingSubstatement) $1]
+       [(IfThenElseStatementNoShortIf) $1])
+      
+      (StatementWithoutTrailingSubstatement
+       [(Block) $1]
+       [(EmptyStatement) $1]
+       [(Assignment SEMI_COLON) $1]
+       [(ExpressionStatement) $1]
+       [(ReturnStatement) $1])
+      
+      (EmptyStatement
+       [(SEMI_COLON) (make-block null (build-src 1))])
+      
+      (ExpressionStatement
+       [(StatementExpression SEMI_COLON) $1])
+      
+      (StatementExpression
+       [(MethodInvocation) $1]
+       [(ClassInstanceCreationExpression) $1])
+      
+      (IfThenElseStatement
+       [(if O_PAREN Expression C_PAREN StatementNoShortIf else Statement)
+	(make-ifS $3 $5 $7 (build-src 1) (build-src 7))])
+      
+      (IfThenElseStatementNoShortIf
+       [(if O_PAREN Expression C_PAREN StatementNoShortIf else StatementNoShortIf)
+	(make-ifS $3 $5 $7 (build-src 1) (build-src 7))])
+      
+      (StatementExpressionList
+       [(StatementExpression) (list $1)]
+       [(StatementExpressionList COMMA StatementExpression) (cons $3 $1)])
+      
+      (ReturnStatement
+       [(return Expression SEMI_COLON) (make-return $2 #f (build-src 3))]
+       [(return SEMI_COLON) (make-return #f #f (build-src 2))])
+      
+      ;; 19.12
+      
+      (Primary
+       [(PrimaryNoNewArray) $1])
+      
+      (PrimaryNoNewArray
+       [(Literal) $1]
+       [(this) (make-special-name #f (build-src 1) "this")]
+       [(O_PAREN Expression C_PAREN) $2]
+       [(ClassInstanceCreationExpression) $1]
+       [(FieldAccess) $1]
+       [(MethodInvocation) $1])
+      
+      (ClassInstanceCreationExpression
+       [(new ClassOrInterfaceType O_PAREN ArgumentList C_PAREN)
+	(make-class-alloc #f (build-src 5) $2 (reverse $4) #f #f #f)]
+       [(new ClassOrInterfaceType O_PAREN C_PAREN) 
+	(make-class-alloc #f (build-src 4) $2 null #f #f #f)])
+      
+      (ArgumentList
+       [(Expression) (list $1)]
+       [(ArgumentList COMMA Expression) (cons $3 $1)])
+            
+      (FieldAccess
+       [(Primary PERIOD IDENTIFIER) 
+        (make-access #f (build-src 3) (make-field-access $1 
+                                                         (make-id $3 (build-src 3 3)) #f))]
+       [(super PERIOD IDENTIFIER) 
+        (make-access #f (build-src 3)
+                         (make-field-access (make-special-name #f (build-src 1)
+                                                                       "super")
+                                                (make-id $3 (build-src 3 3))
+                                                #f))])
+      
+      (MethodInvocation
+       [(Name O_PAREN ArgumentList C_PAREN) (build-name-call $1 (reverse $3) (build-src 4))]
+       [(Name O_PAREN C_PAREN) (build-name-call $1 null (build-src 3))]
+       [(Primary PERIOD IDENTIFIER O_PAREN ArgumentList C_PAREN)
+        (make-call #f (build-src 6) $1 (make-id $3 (build-src 3 3)) (reverse $5) #f)]
+       [(Primary PERIOD IDENTIFIER O_PAREN C_PAREN)
+        (make-call #f (build-src 5) $1 (make-id $3 (build-src 3 3)) null #f)]
+       [(super PERIOD IDENTIFIER O_PAREN ArgumentList C_PAREN)
+        (make-call #f (build-src 6) 
+                       (make-special-name #f (build-src 1) "super") 
+                       (make-id $3 (build-src 3 3)) (reverse $5) #f)]
+       [(super PERIOD IDENTIFIER O_PAREN C_PAREN)
+        (make-call #f (build-src 5) 
+                       (make-special-name #f (build-src 1) "super") 
+                       (make-id $3 (build-src 3 3)) null #f)])
+            
+      (PostfixExpression
+       [(Primary) $1]
+       [(Name) (name->access $1)])      
+      
+      (UnaryExpression
+       [(+ UnaryExpression) (make-unary #f (build-src 2) '+ $2 (build-src 1))]
+       [(- UnaryExpression) (make-unary #f (build-src 2) '- $2 (build-src 1))]
+       [(UnaryExpressionNotPlusMinus) $1])
+      
+      
+      (UnaryExpressionNotPlusMinus
+       [(PostfixExpression) $1]
+       [(~ UnaryExpression) (make-unary #f (build-src 2) '~ $2 (build-src 1))]
+       [(! UnaryExpression) (make-unary #f (build-src 2) '! $2 (build-src 1))]
+       [(CastExpression) $1])
+      
+      (CastExpression
+       [(O_PAREN PrimitiveType C_PAREN UnaryExpression)
+	(make-cast #f (build-src 4) $2 $4)]
+       [(O_PAREN Expression C_PAREN UnaryExpressionNotPlusMinus)
+        (if (access? $2)
+            (make-cast #f (build-src 4) 
+                           (make-type-spec (access->name $2) 0 (build-src 2 2)) $4)
+            (error 'bad-cast))])
+
+      (MultiplicativeExpression
+       [(UnaryExpression) $1]
+       [(MultiplicativeExpression * UnaryExpression)
+        (make-bin-op #f (build-src 3) '* $1 $3 (build-src 2 2))]
+       [(MultiplicativeExpression / UnaryExpression)
+	(make-bin-op #f (build-src 3) '/ $1 $3 (build-src 2 2))]
+       [(MultiplicativeExpression % UnaryExpression)
+	(make-bin-op #f (build-src 3) '% $1 $3 (build-src 2 2))])
+      
+      (AdditiveExpression
+       [(MultiplicativeExpression) $1]
+       [(AdditiveExpression + MultiplicativeExpression)
+	(make-bin-op #f (build-src 3) '+ $1 $3 (build-src 2 2))]
+       [(AdditiveExpression - MultiplicativeExpression)
+	(make-bin-op #f (build-src 3) '- $1 $3 (build-src 2 2))])
+      
+      (ShiftExpression
+       [(AdditiveExpression) $1]
+       [(ShiftExpression << AdditiveExpression)
+	(make-bin-op #f (build-src 3) '<< $1 $3 (build-src 2 2))]
+       [(ShiftExpression >> AdditiveExpression)
+	(make-bin-op #f (build-src 3) '>> $1 $3 (build-src 2 2))]	
+       [(ShiftExpression >>> AdditiveExpression)
+	(make-bin-op #f (build-src 3) '>>> $1 $3 (build-src 2 2))])
+      
+
+      (RelationalExpression
+       [(ShiftExpression) $1]
+       ;; GJ - changed to remove shift/reduce conflict
+       [(ShiftExpression < ShiftExpression)
+        (make-bin-op #f (build-src 3) '< $1 $3 (build-src 2 2))]		
+       [(RelationalExpression > ShiftExpression)
+	(make-bin-op #f (build-src 3) '> $1 $3 (build-src 2 2))]	
+       [(RelationalExpression <= ShiftExpression)
+	(make-bin-op #f (build-src 3) '<= $1 $3 (build-src 2 2))]	
+       [(RelationalExpression >= ShiftExpression)
+	(make-bin-op #f (build-src 3) '>= $1 $3 (build-src 2 2))])      
+
+      (EqualityExpression
+       [(RelationalExpression) $1]
+       [(EqualityExpression == RelationalExpression)
+	(make-bin-op #f (build-src 3) '== $1 $3 (build-src 2 2))]	
+       [(EqualityExpression != RelationalExpression)
+	(make-bin-op #f (build-src 3) '!= $1 $3 (build-src 2 2))])
+      
+      (AndExpression
+       [(EqualityExpression) $1]
+       [(AndExpression & EqualityExpression)
+	(make-bin-op #f (build-src 3) '& $1 $3 (build-src 2 2))])
+	      
+      (ExclusiveOrExpression
+       [(AndExpression) $1]
+       [(ExclusiveOrExpression ^ AndExpression)
+	(make-bin-op #f (build-src 3) '^ $1 $3 (build-src 2 2))])
+      
+      (InclusiveOrExpression
+       [(ExclusiveOrExpression) $1]
+       [(InclusiveOrExpression PIPE ExclusiveOrExpression)
+	(make-bin-op #f (build-src 3) 'or $1 $3 (build-src 2 2))])
+      
+      (ConditionalAndExpression
+       [(InclusiveOrExpression) $1]
+       [(ConditionalAndExpression && InclusiveOrExpression)
+	(make-bin-op #f (build-src 3) '&& $1 $3 (build-src 2 2))])
+      
+      (ConditionalOrExpression
+       [(ConditionalAndExpression) $1]
+       [(ConditionalOrExpression OR ConditionalAndExpression)
+	(make-bin-op #f (build-src 3) 'oror $1 $3 (build-src 2 2))])
+      
+      (ConditionalExpression
+       [(ConditionalOrExpression) $1])
+      
+      (AssignmentExpression
+       [(ConditionalExpression) $1])
+      
+      (Assignment
+       [(LeftHandSide AssignmentOperator AssignmentExpression)
+	(make-assignment #f (build-src 3) $1 $2 $3 (build-src 2 2))])
+      
+      (LeftHandSide
+       [(Name) (name->access $1)]
+       [(FieldAccess) $1])
+      
+      (AssignmentOperator
+       [(=) '=])
+      
+      (Expression
+       [(AssignmentExpression) $1])
+      
+      (ConstantExpression
+       [(Expression) $1]))))
+  
+  ;(define intermediate-grammar (cadr parsers))
+  ;(set! parsers (car parsers))
+  
+  (define parse-intermediate (car parsers))
+  (define parse-intermediate-interactions (cadr parsers))
+  (define parse-intermediate-expression (caddr parsers))
+  (define parse-intermediate-type (cadddr parsers))
+  
+  )
diff --git a/collects/profj/parsers/lexer.ss b/collects/profj/parsers/lexer.ss
new file mode 100644
index 0000000000..8e49b84c85
--- /dev/null
+++ b/collects/profj/parsers/lexer.ss
@@ -0,0 +1,419 @@
+#cs
+(module lexer mzscheme
+  
+  ;; Lexical Analysis according to the Java Language Specification First Edition 
+  ;; chapter 3.
+  ;; Lacks all Unicode support
+  
+  
+  (require (lib "lex.ss" "parser-tools")
+           (prefix re: (lib "lex-sre.ss" "parser-tools")))
+  
+  (provide (all-defined))
+  (define-struct test-case (test))
+  (define-struct example-box (contents))
+  (define-struct interact-case (box))
+  (define-struct class-case (box))
+  
+  (define-empty-tokens Operators
+                       (PIPE OR OREQUAL
+                             =	> < !	~	?	:
+                             ==	<=	>=	!=	&&	++	--
+                             +	-	*	/	&	^	%	<< >> >>>
+                             +=	-=	*=	/=	&=	^=	%=	<<=	>>=	>>>=))
+  
+  (define-empty-tokens Separators
+                       (O_PAREN C_PAREN O_BRACE C_BRACE O_BRACKET C_BRACKET SEMI_COLON PERIOD COMMA))
+  
+  (define-empty-tokens EmptyLiterals (NULL_LIT TRUE_LIT FALSE_LIT EOF))
+  
+  (define-empty-tokens Keywords 
+                       (abstract    default    if            private      this
+                                    boolean     do         implements    protected    throw
+                                    break       double     import        public       throws
+                                    byte        else       instanceof    return       transient
+                                    case        extends    int           short        try
+                                    catch       final      interface     static       void
+                                    char        finally    long          strictfp     volatile
+                                    class       float      native        super        while
+                                    const       for        new           switch
+                                    continue    goto       package       synchronized))
+  
+  (define-tokens java-vals
+                 (STRING_LIT CHAR_LIT INTEGER_LIT LONG_LIT FLOAT_LIT DOUBLE_LIT 
+                             IDENTIFIER STRING_ERROR NUMBER_ERROR HEX_LIT OCT_LIT HEXL_LIT OCTL_LIT))
+  
+  (define-tokens special-toks (CLASS_BOX INTERACTIONS_BOX EXAMPLE TEST_SUITE OTHER_SPECIAL))
+  
+  (define (trim-string s f l)
+    (substring s f (- (string-length s) l)))
+  
+  (define-lex-abbrevs
+   ;; 3.4
+   (CR #\015)
+   (LF #\012)
+   (LineTerminator (re:or CR 
+                          LF 
+                          (re:: CR LF)))
+   (InputCharacter (re:~ CR LF))
+   
+   ;; 3.6
+   (FF #\014)
+   (TAB #\011)
+   (WhiteSpace (re:or #\space 
+                      TAB
+                      FF
+                      LineTerminator))
+   
+   ;; 3.7 (Had to transform CommentTail and CommentTailStar into one RE)
+   ;;     (DocumentationComment only appears in version 1 of the spec)
+   (Comment (re:or TraditionalComment 
+                   EndOfLineComment
+                   DocumentationComment))
+   (TraditionalComment (re:: "/*" NotStar CommentTail))
+   (EndOfLineComment (re:: "//" (re:* InputCharacter)))
+   (DocumentationComment (re:: "/**" CommentTailStar))
+   (CommentTail (re:: (re:* (re:: (re:* NotStar) (re:+ "*") NotStarNotSlash))
+                      (re:* NotStar)
+                      (re:+ "*")
+                      "/"))
+   (CommentTailStar (re:: (re:* (re:: (re:* "*") NotStarNotSlash (re:* NotStar) "*"))
+                          (re:* "*")
+                          "/"))
+   (NotStar (re:~ "*"))
+   (NotStarNotSlash (re:~ "*" "/"))
+   
+   (SyntaxComment (re:or TraditionalCommentEOF
+                         EndOfLineComment))
+   (TraditionalCommentEOF (re:: "/*" CommentTailEOF))
+   (CommentTailEOF (re:or (re:: (re:* (re:: (re:* NotStar) (re:+ "*") NotStarNotSlash))
+                                (re:* NotStar)
+                                (re:+ "*")
+                                "/")
+                          (re:: (re:* (re:: (re:* NotStar) (re:+ "*") NotStarNotSlash))
+                                (re:* NotStar)
+                                (re:* "*"))))
+   
+   ;; 3.8 (No need to worry about excluding keywords and such.  They will
+   ;;      appear first in the lexer spec)
+   ;Not UNICODE compliant
+   (Identifier (re:: JavaLetter (re:* JavaLetterOrDigit)))
+   (JavaLetter (re:or (re:/ "AZ" "az") "_" "$"))
+   (JavaLetterOrDigit (re:or JavaLetter (re:/ "09")))
+   
+   ;; 3.9
+   (Keyword (re:or "abstract"    "default"    "if"            "private"      "this"
+                   "boolean"     "do"         "implements"    "protected"    "throw"
+                   "break"       "double"     "import"        "public"       "throws"
+                   "byte"        "else"       "instanceof"    "return"       "transient"
+                   "case"        "extends"    "int"           "short"        "try"
+                   "catch"       "final"      "interface"     "static"       "void"
+                   "char"        "finally"    "long"          "strictfp"     "volatile"
+                   "class"       "float"      "native"        "super"        "while"
+                   "const"       "for"        "new"           "switch"
+                   "continue"    "goto"       "package"       "synchronized"))
+   
+   ;; 3.10.1
+   (Digits (re:+ (re:/ "09")))
+   (DigitsOpt (re:* (re:/ "09")))
+   
+   (IntegerTypeSuffix (char-set "lL"))
+   (DecimalNumeral (re:or #\0
+                          (re:: (re:/ "19") (re:* (re:/ "09")))))
+   (HexDigit (re:/ "09" "af" "Af"))
+   (HexNumeral (re:: #\0 (char-set "xX") (re:+ HexDigit)))
+   (OctalNumeral (re:: #\0 (re:+ (re:/ "07"))))
+   
+   ;; 3.10.2
+   (FloatTypeSuffix (char-set "fF"))
+   (DoubleTypeSuffix (char-set "dD"))
+   
+   (FloatA (re:: Digits #\. DigitsOpt (re:? ExponentPart)))
+   (FloatB (re:: #\. Digits (re:? ExponentPart)))
+   (FloatC (re:: Digits ExponentPart))
+   (FloatD (re:: Digits (re:? ExponentPart)))
+   
+   (ExponentPart (re:: (char-set "eE") (re:? (char-set "+-")) Digits))
+   
+   ;; MORE
+   
+   ;; 3.10.6
+   (EscapeSequence (re:or "\\b" "\\t" "\\n" "\\f" "\\r" "\\\"" "\\'" "\\\\"
+                          (re:: #\\ (re:? (re:/ "03")) (re:/ "07") (re:/ "07"))
+                          (re:: #\\ (re:/ "07"))))
+   
+   ;; 3.12
+   (Operator (re:or "="	">" "<" "!"	"~"	"?"	":"
+                    "=="	"<="	">="	"!="	"&&" "||"	"++"	"--"
+                    "+"	"-"	"*"	"/"	"&" "|"	"^"	"%"	"<<" ">>" ">>>"
+                    "+="	"-="	"*="	"/="	"&="	"|="	"^="	"%="	"<<="	">>="	">>>=")))
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;Comment lexers
+  
+  (define read-line-comment
+    (lexer
+     [(re:~ #\newline) (read-line-comment input-port)]
+     [#\newline end-pos]
+     [(eof) end-pos]
+     [(special) (read-line-comment input-port)]
+     [(special-comment) (read-line-comment input-port)]
+     ))
+  
+  (define read-block-comment
+    (lexer
+     ["*/" end-pos]
+     [(eof) end-pos]
+     [(re:or "*" "/" (complement (re:: any-string (re:or "*" "/") any-string))) (read-block-comment input-port)]
+     [(special) (read-block-comment input-port)]
+     [(special-comment) (read-block-comment input-port)]
+     ))
+  
+  #;(define read-document-comment
+      (lexer
+       ["**/" end-pos]
+       [(eof) end-pos]
+       [(re:or "*" "/" (~ (any-string))) (read-document-comment input-port)]
+       [(special) (read-document-comment input-port)]
+       [(special-comment) (read-document-comment input-port)]
+       [(special-error) (read-document-comment input-port)]))
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;String lexer
+  
+  ;get-string: input-port -> (U STRING_LIT STRING_ERROR tokens)
+  (define (get-string input-port)
+    (letrec ((tokens (get-string-tokens input-port))
+             (last-token (list-ref tokens (sub1 (length tokens))))
+             (tokens->string
+              (lambda (toks)
+                ;Stops before the last element, which does not have a string
+                (if (null? (cdr toks))
+                    ""
+                    (string-append (string (token-value (position-token-token (car toks))))
+                                   (tokens->string (cdr toks)))))))
+      (if (eq? 'STRING_END (token-name (position-token-token last-token)))
+          (token-STRING_LIT (list (tokens->string tokens) (position-token-end-pos last-token)))
+          (token-STRING_ERROR 
+           (list (tokens->string tokens) 
+                 (position-token-end-pos last-token) 
+                 (position-token-token last-token))))))
+  
+  ;get-string-tokens: input-port -> (list position-token)
+  (define (get-string-tokens input-port)
+    (let ((tok (get-str-tok input-port)))
+      (case (token-name (position-token-token tok))
+        ((STRING_EOF STRING_END STRING_NEWLINE) (list tok))
+        (else (cons tok (get-string-tokens input-port))))))
+    
+  (define-tokens str-tok (STRING_CHAR))
+  (define-empty-tokens err (STRING_END STRING_EOF STRING_NEWLINE))
+  
+  (define get-str-tok
+    (lexer-src-pos
+     (#\" (token-STRING_END))
+     (EscapeSequence (token-STRING_CHAR (EscapeSequence->char lexeme)))
+     (InputCharacter (token-STRING_CHAR (string-ref lexeme 0)))
+     ((re:or CR LF) (token-STRING_NEWLINE))
+     (#\032 (token-STRING_EOF))
+     ((eof) (token-STRING_EOF))))
+  
+  ;; 3.10.6
+  (define (EscapeSequence->char es)
+    (cond
+      ((string=? es "\\b") #\010)
+      ((string=? es "\\t") #\011)
+      ((string=? es "\\n") #\012)
+      ((string=? es "\\f") #\014)
+      ((string=? es "\\r") #\015)
+      ((string=? es "\\\"") #\")
+      ((string=? es "\\'") #\')
+      ((string=? es "\\\\") #\\)
+      (else (integer->char (string->number (trim-string es 1 0) 8)))))
+  
+  (define get-token
+    (lexer-src-pos
+     ;; 3.12
+     (Operator (let ((l lexeme))
+                 (cond
+                   ((string=? l "|") (token-PIPE))
+                   ((string=? l "||") (token-OR))
+                   ((string=? l "|=") (token-OREQUAL))
+                   (else (string->symbol l)))))
+     
+     ;; 3.11
+     ("(" (token-O_PAREN))
+     (")" (token-C_PAREN))
+     ("{" (token-O_BRACE))
+     ("}" (token-C_BRACE))
+     ("[" (token-O_BRACKET))
+     ("]" (token-C_BRACKET))
+     (";" (token-SEMI_COLON))
+     ("," (token-COMMA))
+     ("." (token-PERIOD))
+     
+     ;; 3.10.7
+     ("null" (token-NULL_LIT))
+     
+     ;; 3.10.5
+     (#\" (get-string input-port))
+     ;(token-STRING_LIT (list->string (get-string input-port))))
+     
+     ;; 3.10.4
+     ((re:: #\' (re:~ CR LF #\' #\\) #\')
+      (token-CHAR_LIT (string-ref lexeme 1)))
+     ((re:: #\' EscapeSequence #\') 
+      (token-CHAR_LIT (EscapeSequence->char 
+                       (trim-string lexeme 1 1))))
+     
+     ;; 3.10.3
+     ("true" (token-TRUE_LIT))
+     ("false" (token-FALSE_LIT))
+     
+     ;; 3.10.2
+     ((re:or FloatA FloatB FloatC)
+      (token-DOUBLE_LIT (string->number lexeme)))
+     ((re:: (re:or FloatA FloatB FloatC FloatD) FloatTypeSuffix)
+      (token-FLOAT_LIT (string->number (trim-string lexeme 0 1))))
+     ((re:: (re:or FloatA FloatB FloatC FloatD) DoubleTypeSuffix)
+      (token-DOUBLE_LIT (string->number (trim-string lexeme 0 1))))
+     
+     
+     ;; 3.10.1
+     (DecimalNumeral
+      (token-INTEGER_LIT (string->number lexeme 10)))
+     ((re:: DecimalNumeral IntegerTypeSuffix)
+      (token-LONG_LIT (string->number (trim-string lexeme 0 1) 10)))
+     (HexNumeral
+      (token-HEX_LIT (string->number (trim-string lexeme 2 0) 16)))
+     ((re:: HexNumeral IntegerTypeSuffix)
+      (token-HEXL_LIT (string->number (trim-string lexeme 2 1) 16)))
+     (OctalNumeral
+      (token-OCT_LIT (string->number (trim-string lexeme 1 0) 8)))
+     ((re:: OctalNumeral IntegerTypeSuffix)
+      (token-OCTL_LIT (string->number (trim-string lexeme 1 1) 8)))
+     
+     ;; 3.9
+     (Keyword (string->symbol lexeme))
+     
+     ;; 3.8
+     (Identifier (token-IDENTIFIER lexeme))
+     
+     ;; 3.7
+     ("//" (begin (read-line-comment input-port) (return-without-pos (get-token input-port))))
+     ("/*" (begin (read-block-comment input-port) (return-without-pos (get-token input-port))))
+     #;("/**" (begin (read-document-comment input-port) (return-without-pos (get-token input-port))))
+       
+     ((special)
+      (syntax-case lexeme ()
+        ((parse-example-box examples) (token-EXAMPLE (make-example-box (syntax examples))))
+        (_ 
+         (token-OTHER_SPECIAL (list lexeme start-pos end-pos)))))
+     
+      #;(begin(printf "lexing a special")
+            (syntax-case lexeme ()
+              ((test-case equal? exp1 exp2 exp3 exp4)
+               (token-TEST_SUITE (make-test-case (syntax exp1) (syntax exp2) (syntax exp3) (syntax exp4))))
+              (_ (token-OTHER_SPECIAL (list lexeme start-pos end-pos)))))
+      #;(cond
+        ((class-case? lexeme) (token-CLASS_BOX lexeme))
+        ((interact-case? lexeme) (token-INTERACTIONS_BOX lexeme))
+        ((test-case? lexeme) (token-TEST_SUITE lexeme))
+        (else (token-OTHER_SPECIAL (list lexeme start-pos end-pos))))
+       
+     ;; 3.6
+     ((re:+ WhiteSpace) (return-without-pos (get-token input-port)))
+       
+     ;; 3.5
+     (#\032 'EOF)
+     ((eof) 'EOF)
+       
+     ((re:+ (re:/ "09" "az" "AZ")) (token-NUMBER_ERROR lexeme))
+     
+     ))
+  
+  (define (syn-val lex a b c d)
+    (values lex a b (position-offset c) (position-offset d)))
+  
+  (define get-syn-string
+    (lexer
+     ((re:or CR LF #\") (position-offset end-pos))
+     ((eof) (position-offset end-pos))
+     (EscapeSequence (get-syn-string input-port))
+     (InputCharacter (get-syn-string input-port))))
+  
+  (define (colorize-string my-start-pos)
+    (lexer
+     (#\" (syn-val "" 'string #f my-start-pos end-pos))
+     ((re:or CR LF) (syn-val "" 'error #f my-start-pos end-pos))
+     ((eof) (syn-val "" 'error #f my-start-pos end-pos))
+     (EscapeSequence ((colorize-string my-start-pos) input-port))
+     (InputCharacter ((colorize-string my-start-pos) input-port))))
+  
+  (define get-syntax-token
+    (lexer
+     ;; 3.12
+     (Operator
+      (syn-val lexeme 'keyword #f start-pos end-pos))
+     
+     ;; 3.11
+     ((char-set "(){}[]")
+      (syn-val lexeme 'keyword (string->symbol lexeme) start-pos end-pos))
+     ;; 3.11
+     ((char-set ";,.")
+      (syn-val lexeme 'default #f start-pos end-pos))
+     
+     ;; 3.10.7, 3.10.4, 3.10.3, 3.10.1
+     ((re:or "null" "true" "false"
+             ;char-lit
+             (re:: #\' (re:~ CR LF #\' #\\) #\')
+             (re:: #\' EscapeSequence #\') 
+             ;Doubles and Floats
+             FloatA FloatB FloatC
+             (re:: (re:or FloatA FloatB FloatC FloatD) FloatTypeSuffix)
+             (re:: (re:or FloatA FloatB FloatC FloatD) FloatTypeSuffix)
+             ;Decimal numbers
+             DecimalNumeral
+             HexNumeral
+             OctalNumeral
+             (re:: DecimalNumeral IntegerTypeSuffix)
+             (re:: HexNumeral IntegerTypeSuffix)
+             (re:: OctalNumeral IntegerTypeSuffix))
+      (syn-val lexeme 'literal #f start-pos end-pos))
+     
+     ((re:: #\' InputCharacter) (syn-val lexeme 'literal #f start-pos end-pos))
+     ((re:: #\' InputCharacter (re:~ #\')) (syn-val lexeme 'error #f start-pos end-pos))
+     
+     ((re:: #\' EscapeSequence) (syn-val lexeme 'literal #f start-pos end-pos))
+     ((re:: #\' EscapeSequence (re:~ #\')) (syn-val lexeme 'error #f start-pos end-pos))
+     ((re:: #\' #\\) (syn-val lexeme 'error #f start-pos end-pos))
+     
+     ;; 3.10.5
+     (#\" ((colorize-string start-pos) input-port))
+     ;; 3.9
+     (Keyword (syn-val lexeme 'keyword #f start-pos end-pos))
+     
+     ;; 3.8
+     (Identifier (syn-val lexeme 'identifier #f start-pos end-pos))
+     
+     ;; 3.7
+     ("//" (syn-val lexeme 'comment #f start-pos (read-line-comment input-port)))
+     ("/*" (syn-val lexeme 'comment #f start-pos (read-block-comment input-port)))
+     #;("/**" (syn-val lexeme 'comment #f start-pos (read-document-comment input-port)))
+       
+     ;; 3.6
+     ((re:+ WhiteSpace) (syn-val lexeme 'white-space #f start-pos end-pos))
+       
+     ;; 3.5
+     (#\032 (values lexeme 'eof #f start-pos end-pos))
+     ((eof) (values lexeme 'eof #f start-pos end-pos))
+       
+     ((special) (syn-val "" 'error #f start-pos end-pos))
+     ((special-comment) (syn-val "" 'comment #f start-pos end-pos))
+       
+     ((re:+ (re:/ "09" "az" "AZ")) (syn-val lexeme 'error #f start-pos end-pos))
+       
+     (any-char (syn-val lexeme 'error #f start-pos end-pos))
+       
+     ))
+  )
\ No newline at end of file
diff --git a/collects/profj/parsers/parse-error.ss b/collects/profj/parsers/parse-error.ss
new file mode 100644
index 0000000000..474a5276f8
--- /dev/null
+++ b/collects/profj/parsers/parse-error.ss
@@ -0,0 +1,2427 @@
+#cs
+(module parse-error mzscheme
+  
+  (require "lexer.ss" "general-parsing.ss"
+           "../parameters.ss"
+           (lib "etc.ss")
+           (lib "readerr.ss" "syntax")
+           (all-except (lib "lex.ss" "parser-tools") input-port))
+  
+  (provide
+   find-beginner-error find-beginner-error-interactions find-beginner-error-expression find-beginner-error-type           
+   find-intermediate-error find-intermediate-error-interactions find-intermediate-error-expression find-intermediate-error-type
+   find-advanced-error find-advanced-error-interactions find-advanced-error-expression find-advanced-error-type)
+
+  (define level (make-parameter 'beginner))
+  (define (beginner?) (eq? (level) 'beginner))
+  (define (intermediate?) (eq? (level) 'intermediate))
+  (define (advanced?) (eq? (level) 'advanced))
+  
+  ;find-error: symbol -> (-> (U void #t))
+  (define (find-error level-set)
+    (lambda ()
+      (level level-set)
+      (let ((getter ((lex-stream))))
+        (parse-program null (getter) 'start getter))))
+
+  ;find-expression-error: symbol -> (-> (U void #t))
+  (define (find-expression-error level-set)
+    (lambda ()
+      (level level-set)
+      (let ((getter ((lex-stream))))
+        (parse-expression null (getter) 'start getter #f #f))))
+  
+  ;find-type-error: symbol -> (-> (U void #t))
+  (define (find-type-error level-set)
+    (lambda ()
+      (level level-set)
+      (let ((getter ((lex-stream))))
+        (parse-type null (getter) 'start getter))))
+  
+  ;find-beginner-error: -> (U void #t)
+  (define find-beginner-error (find-error 'beginner))
+  
+  (define find-beginner-error-expression (find-expression-error 'beginner))
+
+  (define find-beginner-error-type (find-type-error 'beginner))
+  
+  ;find-beginner-error-interaction: -> (U bool or token)
+  ;Should not return
+  (define (find-beginner-error-interactions)
+    (let* ((getter ((lex-stream)))
+           (first-tok (getter)))
+      (let ((returned-tok 
+             (case (get-token-name (get-tok first-tok))
+               ((EOF) #t)
+               ((if return) (parse-statement null first-tok 'start getter #f #f #f))
+               ;Taken from Intermediate to allow interaction to say int x = 4;
+               ((IDENTIFIER)
+                (let ((next (getter)))
+                  (if (id-token? (get-tok next))
+                      (parse-field first-tok next 'start getter)
+                      (parse-expression first-tok next 'name getter #f #f))))
+               (else
+                (if (prim-type? (get-tok first-tok))
+                    (parse-field first-tok (getter) 'start getter)
+                    (parse-expression null first-tok 'start getter #f #f))))))
+        
+        (if (or (and (pair? returned-tok) (eof? (get-tok returned-tok))) (boolean? returned-tok))
+            returned-tok
+            (if (and (pair? returned-tok) (semi-colon? (get-tok returned-tok)))
+                (parse-error "';' is not allowed here" (get-start returned-tok) (get-end returned-tok))
+                (parse-error (format "Only 1 statement, expression, or definition is allowed, found extra input ~a"
+                                     (format-out (get-tok returned-tok)))
+                             (get-start returned-tok) (get-end returned-tok)))))))
+  
+  ;find-intermediate-error: -> (U void #t)
+  (define find-intermediate-error (find-error 'intermediate))
+
+  ;find-intermediate-error-expression: -> void
+  (define find-intermediate-error-expression (find-expression-error 'intermediate))
+
+  ;find-intermediate-error-type: -> void
+  (define find-intermediate-error-type (find-type-error 'intermediate))
+  
+  ;find-error-interaction: -> (U bool or token)
+  ;Should not return
+  (define (find-intermediate-error-interactions)
+    (let* ((getter ((lex-stream)))
+           (first-tok (getter)))
+      (level 'intermediate)
+      (let ((returned-tok 
+             (case (get-token-name (get-tok first-tok))
+               ((EOF) #t)
+               ((if return O_BRACE) (parse-statement null first-tok 'start getter #t #f #f))
+               ((IDENTIFIER)
+                (let ((next (getter)))
+                  (if (id-token? (get-tok next))
+                      (parse-statement first-tok next 'local getter #t #f #f)
+                      (parse-expression first-tok next 'name getter #t #f))))
+               (else
+                (if (prim-type? (get-tok first-tok))
+                    (parse-statement null first-tok 'start getter #t #f #f)
+                    (parse-expression null first-tok 'start getter #t #f))))))
+        (if (or (and (pair? returned-tok) (eof? (get-tok returned-tok))) (boolean? returned-tok))
+            returned-tok
+            (if (and (pair? returned-tok) (semi-colon? (get-tok returned-tok)))
+                (parse-error "';' is not allowed here" (get-start returned-tok) (get-end returned-tok))
+                (parse-error (format "Only 1 statement or expression is allowed, found extra input ~a" 
+                                     (format-out (get-tok returned-tok)))
+                             (get-start returned-tok) (get-end returned-tok)))))))
+
+  ;find-advanced-error: -> (U void #t)
+  (define (find-advanced-error)
+    (let ((getter ((lex-stream))))
+      (level 'advanced)
+      (parse-package null (getter) 'start getter)))
+
+  ;find-advanced-error-expression: -> void
+  (define find-advanced-error-expression (find-expression-error 'advanced))
+
+  ;find-advanced-error-type: -> void
+  (define find-advanced-error-type (find-type-error 'advanced))
+  
+  ;find-error-interaction: -> (U bool or token)
+  ;Should not return
+  (define (find-advanced-error-interactions)
+    (let* ((getter ((lex-stream)))
+           (first-tok (getter)))
+      (level 'advanced)
+      (let ((returned-tok 
+             (case (get-token-name (get-tok first-tok))
+               ((EOF) #t)
+               ((if return O_BRACE for do while break continue) 
+                (parse-statement null first-tok 'start getter #t #f #f))
+               ((IDENTIFIER)
+                (let ((next (getter)))
+                  (if (id-token? (get-tok next))
+                      (parse-statement first-tok next 'local getter #t #f #f)
+                      (parse-expression first-tok next 'name getter #t #f)))) 
+               (else 
+                (if (prim-type? (get-tok first-tok))
+                    (parse-statement null first-tok 'start getter #t #f #f)
+                    (parse-expression null first-tok 'start getter #t #f))))))
+        (if (or (and (pair? returned-tok) (eof? (get-tok returned-tok))) (boolean? returned-tok))
+            returned-tok
+            (if (and (pair? returned-tok) (semi-colon? (get-tok returned-tok)))
+                (parse-error "';' is not allowed here" (get-start returned-tok) (get-end returned-tok))
+                (parse-error (format "Only 1 statement or expression is allowed, found extra input ~a"
+                                     (format-out (get-tok returned-tok)))
+                             (get-start returned-tok) (get-end returned-tok)))))))
+  
+  ;;-----------------------------------------------------------------------------------------------------------
+  ;;Functions for parsing and reporting errors
+  
+  ;parse-error: string position position
+  (define (parse-error message start stop)
+    (raise-read-error message
+                      (file-path)
+                      (position-line start)
+                      (position-col start)
+                      (+ (position-offset start) (interactions-offset))
+                      (- (position-offset stop)
+                         (position-offset start))))
+
+  ;token = (list lex-token position position)
+  (define get-tok position-token-token)
+  (define get-start position-token-start-pos)
+  (define (get-end token) 
+    (if (or (eq? (get-token-name (get-tok token)) 'STRING_LIT)
+            (eq? (get-token-name (get-tok token)) 'STRING_ERROR))
+        (cadr (token-value (get-tok token)))
+        (position-token-end-pos token)))
+  
+  ;output-format: token bool -> string
+  (define format-out
+    (opt-lambda (tok [full? #t])
+      (cond
+        ((separator? tok) 
+         (case (get-token-name tok)
+           ((O_BRACE) "{")
+           ((C_BRACE) "}")
+           ((O_PAREN) "(")
+           ((C_PAREN) ")")
+           ((O_BRACKET) "[")
+           ((C_BRACKET) "]")
+           ((SEMI_COLON) ";")
+           ((COMMA) ",")
+           ((PERIOD) ".")))
+        ((eq? (get-token-name tok) 'OR) (if full? "operator ||" "||"))
+        ((eq? (get-token-name tok) 'PIPE) (if full? "operator |" "||"))
+        ((keyword? tok) (if full? 
+                            (format "reserved word ~a" (get-token-name tok)) (get-token-name tok)))
+        ((id-token? tok) (if full? (format "identifier ~a" (token-value tok)) (token-value tok)))
+        ((eq? (get-token-name tok) 'STRING_LIT) (if full? (format "string ~a" (car (token-value tok)))
+                                                    (car (token-value tok))))
+        ((eq? (get-token-name tok) 'NULL_LIT) (if full? "null value" "null"))
+        ((eq? (get-token-name tok) 'TRUE_LIT) (if full? "boolean value true" "true"))
+        ((eq? (get-token-name tok) 'FALSE_LIT) (if full? "boolean value false" "false"))
+        ((literal-token? tok) (if full? (format "value ~a" (token-value tok)) (token-value tok)))
+        ((eq? (get-token-name tok) 'STRING_ERROR)
+         (format "malformed string ~a" (car (token-value tok))))
+        ((eq? (get-token-name tok) 'NUMBER_ERROR)
+         (format "malformed number ~a" (token-value tok)))
+        ((eq? (get-token-name tok) 'OTHER_SPECIAL)
+         (parse-error "Found special which is not a legal character in ProfessorJ" 
+                      (cadr (token-value tok)) (caddr (token-value tok))))
+        ((eq? (get-token-name tok) 'TEST_SUITE) (format "Test Suite Test"))
+        ((eq? (get-token-name tok) 'INTERACTIONS_BOX) (format "Java Interactions Box"))
+        ((eq? (get-token-name tok) 'EXAMPLE) (format "Java Example Box"))
+        ((eq? (get-token-name tok) 'CLASS_BOX) (format "Java Class Box"))
+        (else (get-token-name tok)))))
+
+  ;parse-package: token token symbol (-> token) -> void
+  (define (parse-package pre cur-tok state getter)
+;    (printf "parse-package state: ~a pre ~a cur-tok: ~a~n" state pre cur-tok)
+    (let* ((tok (get-tok cur-tok))
+           (tokN (get-token-name tok))
+           (srt (get-start cur-tok))
+           (end (get-end cur-tok))
+           (out (format-out tok))
+           (ps (if (null? pre) null (get-start pre)))
+           (pe (if (null? pre) null (get-end pre))))
+      (case state
+        ((start)
+         (case tokN
+           ((EOF) #t)
+           ((package)
+            (let ((next (getter)))
+              (if (id-token? (get-tok next))
+                  (let ((after-id (getter)))
+                    (cond
+                      ((dot? (get-tok after-id))
+                       (parse-package cur-tok (parse-name (getter) getter #f) 'semi-colon getter))
+                      ((semi-colon? (get-tok after-id))
+                       (parse-program after-id (getter) 'start getter))
+                      (else
+                       (parse-error 
+                        (format "'package' must have a name followed by ';'. ~a ~a is not a legal name" 
+                                (format-out (get-tok next)) (format-out (get-tok after-id))) 
+                        (get-start next) (get-end after-id)))))
+                  (parse-error (format "'package' must have a name followed by ';'. ~a is not allowed" 
+                                       (format-out (get-tok next)))
+                               srt (get-end next)))))
+           ((IDENTIFIER)
+            (if (close-to-keyword? tok 'package)
+                (parse-error 
+                 (format "~a is close to 'package' but is either miscapitalized or mispelled" (token-value tok))
+                 srt end)
+                (parse-package pre cur-tok 'start getter)))
+           (else
+            (parse-program pre cur-tok 'start getter))))
+        ((semi-colon)
+         (case tokN
+           ((EOF) (parse-error "'package' must have a name followed by a ';'" ps pe))
+           ((SEMI_COLON) (parse-program cur-tok (getter) 'start getter))
+           (else (parse-error (format "'package' must have a name followed by a ';'. ~a is not allowed" out) ps end)))))))
+
+  
+  ;parse-program: token token symbol (-> token) -> (U void bool)
+  (define (parse-program pre cur-tok state getter)
+;    (printf "parse-program state: ~a pre: ~a cur-tok:~a~n" state pre cur-tok)
+    (let* ((tok (get-tok cur-tok))
+           (tokN (get-token-name tok))
+           (srt (get-start cur-tok))
+           (end (get-end cur-tok))
+           (out (format-out tok))
+           (ps (if (null? pre) null (get-start pre)))
+           (pe (if (null? pre) null (get-end pre))))
+      (case state
+        ((start)
+         (case tokN
+           ((EOF) #t)
+           ((import) 
+            (let ((next (getter)))
+              (if (id-token? (get-tok next))
+                  (let ((after-id (getter)))
+                    (cond
+                      ((dot? (get-tok after-id))
+                       (parse-program cur-tok (parse-name (getter) getter #t) 'semi-colon getter))
+                      ((semi-colon? (get-tok after-id))
+                       (parse-program after-id (getter) 'start getter))
+                      (else
+                       (parse-error 
+                        (format "'import' must have a name followed by ';'. ~a is not allowed" 
+                                (format-out (get-tok next))) 
+                        srt (get-end after-id)))))
+                  (parse-error (format "'import' must have a name followed by ';'. ~a is not allowed" out)
+                               srt (get-end next)))))
+           ((IDENTIFIER)
+            (if (close-to-keyword? tok 'import)
+                (parse-error 
+                 (format "~a is close to 'import' but is either miscapitalized or mispelled" (token-value tok))
+                 srt end)
+                (parse-definition pre cur-tok 'start getter)))
+           ((INTERACTIONS_BOX TEST_SUITE CLASS_BOX) (parse-definition cur-tok (getter) 'start getter))
+           (else
+            (parse-definition pre cur-tok 'start getter))))
+        ((semi-colon)
+         (case tokN
+           ((EOF) (parse-error "'import' must have a name followed by a ';'" ps pe))
+           ((SEMI_COLON) (parse-program cur-tok (getter) 'start getter))
+           ((*)
+            (let ((after-star (getter)))
+              (cond
+                ((semi-colon? (get-tok after-star)) (parse-program after-star (getter) 'start getter))
+                (else (parse-error (format "'import' must have a name followed by a ';'. ~a is not allowed" 
+                                           (format-out (get-tok after-star))) ps (get-end after-star))))))
+           (else (parse-error (format "'import' must have a name followed by a ';'. ~a is not allowed" out) ps end)))))))
+  
+  ;parse-definition: token token symbol (-> token) -> void
+  (define (parse-definition pre cur-tok state getter)
+;    (printf "parse-definition state ~a pre: ~a cur-tok ~a~n" state pre cur-tok)
+    (let* ((tok (get-tok cur-tok))
+           (tokN (get-token-name tok))
+           (srt (get-start cur-tok))
+           (end (get-end cur-tok))
+           (out (format-out tok))
+           (ps (if (null? pre) null (get-start pre)))
+           (pe (if (null? pre) null (get-end pre))))
+               
+      (case state
+        ((start) 
+         (case tokN
+           ((EOF) #t)
+           ((class) (parse-definition cur-tok (getter) 'class-id getter))
+           ((abstract) 
+            (let* ((next (getter))
+                   (next-tok (get-tok next)))
+              (cond
+                ((class? next-tok) (parse-definition cur-tok next state getter))
+                ((eof? next-tok) (parse-error "abstract should be followed by class definition" srt end))
+                (else 
+                 (if (close-to-keyword? next-tok 'class)
+                     (parse-error (format "expected 'class' after 'abstract,' found ~a which is incorrectly spelled or capitalized"
+                                          (token-value next-tok))
+                                  srt
+                                  (get-end next))
+                     (parse-error (format "abstract must be immediately followed by 'class' not ~a" (format-out next-tok))
+                                  srt
+                                  (get-end next)))))))
+           ((interface) 
+            (if (or (intermediate?) (advanced?))
+                (parse-definition cur-tok (getter) 'interface-id getter)
+                (parse-error (format "Expected class definition, found ~a which may not be written here" out) srt end)))
+           ((public)
+            (if (advanced?)
+                (parse-definition cur-tok (getter) 'start getter)
+                (parse-error "Expected class definition, found 'public' which may not be written here" srt end)))
+           ((INTERACTIONS_BOX TEST_SUITE CLASS_BOX) (parse-definition cur-tok (getter) 'start getter))
+           ((import)
+            (parse-error "Expected class definition, found 'import', which may only appear at the top of a file" srt end))
+           ((package)
+            (if (advanced?)
+                (parse-error "Expected class definition, found 'package' declaration. package must be the first item of a file" srt end)
+                (parse-error "Expected class definition, found 'package' which may not appear here" srt end)))
+           (else 
+            (cond
+              ((close-to-keyword? tok 'class)
+                (parse-error (format "expected 'class', found ~a which is incorrectly spelled or capitalized"
+                                     (token-value tok))
+                             srt end))
+              ((close-to-keyword? tok 'abstract)
+               (parse-error (format "Expected 'abstract class' or 'class', found ~a which is incorrectly spelled or capitalized"
+                                    (token-value tok))
+                            srt end))
+              ((and (or (intermediate?) (advanced?)) (close-to-keyword? tok 'interface))
+               (parse-error (format "Expected 'interface' or 'class', found ~a which is incorrectly spelled or capitalized"
+                                    (token-value tok)) srt end))
+              ((and (advanced?) (close-to-keyword? tok 'public))
+               (parse-error (string-append
+                             (format 
+                              "Expected 'interface' or 'class'. Found ~a, which is close to 'public' which is allowed.~n"
+                              (token-value tok))
+                             "Check capitalization and spelling")
+                            srt end))
+              ((or (if-token? tok) (return-token? tok)
+                   (and (advanced?) (or (for-token? tok) (while-token? tok) (do-token? tok))))
+               (parse-error (format "Expected class definition, found ~a. Statements must be in a method or interactions window" out)
+                            srt end))
+              ((prim-type? tok) 
+               (parse-error (format "Expected class definition, found ~a. Fields and methods must be in a class body" out)
+                            srt end))
+              ((id-token? tok)
+               (parse-error (format "Expected class definition, found ~a. Fields, methods, and expressions may not be written here"
+                                    out) srt end))
+              (else
+               (parse-error (format "Expected class definition, found ~a which may not be written here" out)
+                            srt end))))))
+        ((class-id)
+         (case tokN
+           ((EOF) (parse-error "'class' should be followed by a class name and body" ps pe))
+           ((IDENTIFIER) 
+            (let* ((next (getter))
+                   (next-tok (get-tok next)))
+              (cond
+                ((eof? next-tok) (parse-error (format "expected class body after ~a" (token-value tok)) srt end))
+                ((extends? next-tok) (parse-definition next (getter) 'extends getter))
+                ((and (or (intermediate?) (advanced?)) (implements? next-tok))
+                 (parse-definition next (getter) 'implements getter))
+                ((o-brace? next-tok) (parse-definition cur-tok next 'class-body getter))
+                ((close-to-keyword? next-tok 'extends) 
+                 (parse-error (format "found ~a, which is similar to 'extends'" (token-value next-tok))
+                              (get-start next) (get-end next)))
+                ((and (or (intermediate?) (advanced?)) (close-to-keyword? next-tok 'implements))
+                 (parse-error (format "found ~a, which is similar to 'implements'" (token-value next-tok))
+                              (get-start next) (get-end next)))
+                ((open-separator? next-tok)
+                 (parse-error (format "expected { to begin class body, but found ~a" (format-out next-tok))
+                              (get-start next) (get-end next)))
+                ((c-brace? tok)
+                 (parse-error (format "Class body must be opened with { before being closed, found ~a" out)
+                              (get-start next) (get-end next)))
+                (else
+                 (parse-error 
+                  (format "class name must be followed by 'extends' or ~a a { to start class body, found ~a"
+                          (if (not (beginner?)) "'implements' clause or " "") 
+                          (format-out next-tok)) srt (get-end next))))))
+           (else 
+            (if (keyword? tok) 
+                (parse-error (format "class may not be called ~a as this is a reserved term" tokN) srt end)
+                (parse-error (format "expected a name for this class, given ~a" out) srt end)))))
+        ((interface-id)
+         (case tokN
+           ((EOF) (parse-error "'interface' should be followed by an interface name and body" ps pe))
+           ((IDENTIFIER)
+            (let* ((next (getter))
+                   (next-tok (get-tok next)))
+              (cond
+                ((eof? next-tok) (parse-error (format "Expected interface body after ~a" (token-value tok)) srt end))
+                ((extends? next-tok) (parse-definition cur-tok next 'iface-extends getter))
+                ((o-brace? next-tok) (parse-definition cur-tok next 'iface-body getter))
+                ((close-to-keyword? next-tok 'extends)
+                 (parse-error (format "found ~a, which is similar to 'extends'" (token-value next-tok)) 
+                              (get-start next) (get-end next)))
+                ((open-separator? next-tok)
+                 (parse-error (format "Expected { to begin interface body, but found ~a" (format-out next-tok))
+                              (get-start next) (get-end next)))
+                ((c-brace? next-tok)
+                 (parse-error (format "Interface body must be opened with { before being closed, found ~a"
+                                      (format-out next-tok)) (get-start next) (get-end next)))
+                ((implements? next-tok)
+                 (parse-error "Interfaces may not implement other interfaces" ps (get-end next)))
+                (else
+                 (parse-error (format "Interface name must be follwed by 'extends' or a { to start its body, found ~a"
+                                      (format-out next-tok)) srt (get-end next))))))
+           (else
+            (if (keyword? tok)
+                (parse-error (format "interface may not be called ~a, as this is a reserved term" tokN) srt end)
+                (parse-error (format "Expected a name for this interface, given ~a" out) srt end)))))
+        ((extends) 
+         (cond
+           ((eof? tok) (parse-error "Expected parent class after extends" ps pe))
+           ((id-token? tok)
+            (if (beginner?)
+                (parse-definition cur-tok (getter) 'class-body getter)
+                (let* ((next (getter))
+                       (next-tok (get-tok next)))
+                  (cond
+                    ((implements? next-tok) (parse-definition next (getter) 'implements getter))
+                    ((close-to-keyword? next-tok 'implements)
+                     (parse-error (format "Expected 'implements', found ~a which is close to 'implements'" (token-value next-tok))
+                                  (get-start next) (get-end next)))
+                    (else (parse-definition cur-tok next 'class-body getter))))))
+           ((o-brace? tok) (parse-error "Expected a parent name after extends and before the class body starts" srt end))
+           ((keyword? tok)
+            (parse-error (format "parent may not be named after reserved word ~a" tokN) srt end))
+           (else (parse-error (format "extends must be followed by parent name, found ~a" out) ps end))))
+        ;Intermediate
+        ((implements)
+         (cond
+           ((eof? tok) (parse-error "Expected implemented interface after implements, and class body" ps pe))
+           ((id-token? tok)
+            (let* ((next (getter))
+                   (next-tok (get-tok next)))
+              (cond
+                ((eof? next-tok) (parse-error "Expected more implemented interfaces or class body" srt end))
+                ((comma? next-tok) (parse-definition next (getter) 'implements-list getter))
+                ((o-brace? next-tok) (parse-definition cur-tok next 'class-body getter))
+                ((id-token? next-tok)
+                 (parse-error "Implemented interfaces must be separated by a comma" srt (get-end next)))
+                (else (parse-error (format "Expected more interfaces or the class body, found ~a" (format-out next-tok))
+                                   (get-start next) (get-end next))))))
+           ((keyword? tok)
+            (parse-error (format "Expected an interface name, which may not be reserved word ~a" tokN) srt end))
+           (else (parse-error (format "Expected an interface name, found ~a" out) srt end))))
+        ;Intermediate
+        ((implements-list)
+         (cond
+           ((eof? tok) (parse-error "Expected an interface name and class body" ps pe))
+           ((id-token? tok)
+            (let* ((next (getter))
+                   (next-tok (get-tok next)))
+              (cond
+                ((eof? next-tok) (parse-error "Expected more interfaces or a class body" srt end))
+                ((comma? next-tok) (parse-definition next (getter) 'implements-list getter))
+                ((o-brace? next-tok) (parse-definition cur-tok next 'class-body getter))
+                ((id-token? next-tok) (parse-error "Implemented interfaces must be separated by a comma" srt (get-end next)))
+                (else (parse-error (format "Expected more interfaces or the class body, found ~a" (format-out next-tok))
+                                   (get-start next) (get-end next))))))
+           ((keyword? tok)
+            (parse-error (format "Expected an interface name for implements clause, found reserved term ~a" tokN) srt end))
+           ((o-brace? tok)
+            (parse-error "Expected an additional interface after comma before { to start class body" ps end))
+           (else (parse-error (format "Expected an interface name, found ~a" out) srt end))))
+        ;Intermediate 
+        ((iface-extends)
+         (cond
+           ((eof? tok) (parse-error "Expected interface name to extend after extends, and interface body" ps pe))
+           ((id-token? tok)
+            (let* ((next (getter))
+                   (next-tok (get-tok next)))
+              (cond
+                ((eof? next-tok) (parse-error "Expected more extended interfaces or interface body" srt end))
+                ((comma? next-tok) (parse-definition next (getter) 'iface-extends-list getter))
+                ((o-brace? next-tok) (parse-definition cur-tok next 'iface-body getter))
+                ((implements? next-tok) 
+                 (parse-error "An interface may not implement other interfaces" (get-start next) (get-end next)))
+                ((id-token? next-tok) (parse-error "Extended interfaces must be separated by a comma" srt (get-end next)))
+                (else 
+                 (parse-error (format "Expected more interfaces to extend of interface body, found ~a" (format-out next-tok))
+                              (get-start next) (get-end next))))))
+           ((keyword? tok)
+            (parse-error (format "Expected a name of an interface to extend, found reserved term ~a, which cannot be a name"
+                                 tokN) srt end))
+           (else
+            (parse-error (format "Expected a name of an interface to extend, found ~a" out) srt end))))
+        ;Intermediate
+        ((iface-extends-list)
+         (cond
+           ((eof? tok) (parse-error "Expected interface name to extend after comma, and interface body" ps pe))
+           ((id-token? tok)
+            (let* ((next (getter))
+                   (next-tok (get-tok next)))
+              (cond
+                ((eof? next-tok) (parse-error "Expected more interfaces or an interface body" srt end))
+                ((comma? next-tok) (parse-definition next (getter) 'iface-extends-list getter))
+                ((o-brace? next-tok) (parse-definition cur-tok next 'iface-body getter))
+                ((id-token? next-tok) (parse-error "Extended interfaces must be separated by a comma" srt (get-end next)))
+                (else (parse-error (format "Expected more interfaces or the interface body, found ~a" (format-out next-tok))
+                                   (get-start next) (get-end next))))))
+           ((keyword? tok)
+            (parse-error (format "Expected an interface name for extends clause, found reserved term ~a" tokN) srt end))
+           ((o-brace? tok)
+            (parse-error "Expected an additional interface after comma before { to start interface body" ps end))
+           (else (parse-error (format "Expected an interface name, found ~a" out) srt end)))) 
+        ((class-body)
+         (case tokN
+           ((EOF) (parse-error (format "Expected class body to begin after ~a" (format-out (get-tok pre))) ps pe))
+           ((O_BRACE) (parse-definition cur-tok (parse-members null (getter) 'start getter #f #f) 'class-body-end getter))
+           (else 
+            (cond
+              ((open-separator? tok)
+               (parse-error (format "expected { to begin class body, but found ~a" out) srt end))
+              ((close-separator? tok)
+               (parse-error (format "Class body must be opened with { before being closed, found ~a" out) srt end))
+              (else
+               (parse-error (format "Expected { to start class body, found ~a" out) srt end))))))
+        ((class-body-end)
+         (case tokN
+           ((EOF) (parse-error "Expected a } to close class body" ps pe))
+           ((C_BRACE) 
+            (let ((next (getter)))
+              (if (c-brace? (get-tok next))
+                  (parse-error "Unnecessary }, class body already closed" srt (get-end next))
+                  (parse-definition cur-tok next 'start getter))))
+           (else (parse-error (format "Expected a } to close class body, found ~a" out) ps end))))
+        ((iface-body)
+         (case tokN
+           ((EOF) (parse-error (format "Expected interface body to begin after ~a" (format-out (get-tok pre))) ps pe))
+           ((O_BRACE) (parse-definition cur-tok (parse-iface-body null (getter) 'start getter) 'iface-body-end getter))
+           (else
+            (cond
+              ((open-separator? tok)
+               (parse-error (format "Expected { to begne interface body, but found ~a" out) srt end))
+              ((close-separator? tok)
+               (parse-error (format "Interface body must be opened with { before being closed, found ~a" out) srt end))
+              (else (parse-error (format "Expected { to start interface body, found ~a" out) srt end))))))
+        ((iface-body-end)
+          (case tokN
+            ((EOF) (parse-error "Expected a } to close interface body" ps pe))
+            ((C_BRACE)
+             (let ((next (getter)))
+               (if (c-brace? (get-tok next))
+                   (parse-error "Unnecessary }, interface body is already closed" srt (get-end next))
+                   (parse-definition cur-tok next 'start getter))))
+            (else (parse-error (format "Expected a } to close interface body, found ~a" out) ps end)))))))
+
+  
+  ;parse-type: token token symbol (->token) -> void
+  (define (parse-type pre cur state getter)
+    (let* ((tok (get-tok cur))
+           (kind (get-token-name tok))
+           (out (format-out tok))
+           (srt (get-start cur))
+           (end (get-end cur))
+           (ps (if (null? pre) null (get-start pre)))
+           (pe (if (null? pre) null (get-end pre))))
+      (case state
+        ((start)
+         (cond
+           ((eof? tok) (parse-error "Expected a type, found nothing" srt end))
+           ((prim-type? tok) (parse-type cur (getter) 'end-or-array getter))
+           ((id-token? tok) (parse-type cur (getter) 'qualified-or-array getter))
+           ;I can do better here: expand close-to-keyword to specify close to which type of keyword
+           (else
+            (parse-error (format "Expected a type, found ~a, which is not the valid beginning of a type" out)
+                         srt end))))
+         ((end-or-array)
+          (cond
+            ((dot? tok) (parse-error (format "'.' cannot follow primitive type ~a in a type declaration" 
+                                             (format-out (get-tok pre))) ps end))
+            ((and (advanced?) (o-bracket? tok))
+             (parse-type pre (getter) 'array-close getter))
+            (else 
+             (parse-error 
+              (format "Only one item may appear in a type declaration, ~a is a complete type, ~a maynot appear"
+                      (format-out (get-tok pre)) out) ps end))))
+         ((qualified-or-array)
+          (cond
+            ((dot? tok)
+             (parse-error "This type declaration maynot contain a '.'" ps end))
+            ((and (advanced?) (o-bracket? tok))
+             (parse-type pre (getter) 'array-close getter))
+            (else
+             (parse-error 
+              (format "Only one item may appear in a type declaration, ~a appears to be a complete type, ~a maynot appear"
+                      (format-out (get-tok pre)) out) ps end))))
+         ((array-close)
+          (cond
+            ((c-bracket? tok) 
+             (let ((next (getter)))
+               (cond
+                 ((o-bracket? (get-tok next))
+                  (parse-type next (getter) 'array-close getter))
+                 (else 
+                  (parse-error 
+                   (format "Only one type may appear in a type declaration, ] appears to complete the type, ~a maynot appear"
+                           (format-out (get-tok next)))
+                   ps (get-end next))))))
+            (else
+             (parse-error
+              (format "Expected a ] to close the array type, found ~a, which maynot appear here" out) ps end)))))))
+              
+  ;parse-members: token token symbol (->token) boolean -> token
+  (define (parse-members pre cur state getter abstract-method? just-method?)
+;    (printf "parse-members: state ~a pre ~a current ~a~n" state pre cur)
+    (let* ((tok (get-tok cur))
+           (kind (get-token-name tok))
+           (out (format-out tok))
+           (srt (get-start cur))
+           (end (get-end cur))
+           (ps (if (null? pre) null (get-start pre)))
+           (pe (if (null? pre) null (get-end pre))))
+
+      (case state
+        ((start)
+         (cond
+           ((eof? tok) cur)
+           ((and (c-brace? tok) (not just-method?)) cur)
+           ((and (c-brace? tok) just-method?) (parse-error "Encountered extra }" srt end))
+           ((abstract? tok) (parse-members cur (getter) 'method getter #t just-method?))
+           ((prim-type? tok) (parse-members cur (getter) 'method-or-field getter #f just-method?))
+           ;Intermediate & Advanced
+           ((and (or (intermediate?) (advanced?)) (void-token? tok)) (parse-members cur (getter) 'method-id getter #f just-method?))
+           ((id-token? tok) (parse-members cur (getter) 'member getter #f just-method?))
+           ;Advanced
+           ((and (advanced?)
+                 (or (public? tok) (private? tok) (protected? tok) (static? tok) (final? tok)))
+            (parse-members cur (getter) 'start getter #f just-method?))
+           ;Advanced
+           ((and (advanced?) (o-brace? tok))
+            (if (modifier-token? (get-tok pre))
+                (parse-error (format "Initilization body may not be preceeded with any modifier. Found ~a" 
+                                     (format-out (get-tok pre))) ps end)
+                (parse-members cur (parse-statement pre cur 'start getter #t #f #f) 'start getter #f just-method?)))
+           (else 
+            (parse-error 
+             (format "Only fields, methods and a constructor may be within the class body, found ~a" out) srt end))))
+        ((member)
+         (cond
+           ((eof? tok) (parse-error "Class member may not end here, class body still requires a }" ps pe))
+           ((dot? tok) 
+            (if (beginner?)
+                (parse-error "The name of a type or class may not contain a '.'" ps end)
+                (parse-members cur (parse-name (getter) getter #f) 'method-or-field getter abstract-method? just-method?)))
+           ((id-token? tok) (parse-members pre cur 'method-or-field getter abstract-method? just-method?))
+           ((o-paren? tok) (parse-members cur (getter) 'ctor-parms getter abstract-method? just-method?))
+           ((c-paren? tok) (parse-error "( must precede ) in parameter list" srt end))
+           ((and (advanced?) (o-bracket? tok))
+            (parse-members pre cur 'method-or-field getter abstract-method? just-method?))
+           ((open-separator? tok)
+            (parse-error (format "( must be used to start parameter list, found ~a" out) srt end))
+           ((prim-type? tok)
+            (parse-error 
+             (format "methods and fields may not be named for primitive type ~a, which appears in the name position" kind)
+             srt end))
+           ((keyword? tok)
+            (parse-error 
+             (format "Expected a name for this field or method, ~a is a reserved word and cannot be the name" kind)
+             srt end))
+           (else (parse-error (format "Expected a name for this field or method, found ~a" out) srt end))))
+        ((method-or-field)
+         (case kind
+           ((EOF) (parse-error "Method or field must have a name, class body still requires a }" ps pe))
+           ((IDENTIFIER) 
+            (let* ((next (getter))
+                   (n-tok (get-tok next))
+                   (n-out (format-out n-tok))
+                   (ne (get-end next)))
+              (cond
+                ((eof? n-tok) 
+                 (parse-error "Method or field has not completed, class body still requires a }" srt end))
+                ;Just ended a field
+                ((semi-colon? n-tok) (parse-members next (getter) 'start getter #f just-method?))
+                ;Intermediate and Advanced
+                ((comma? n-tok) 
+                 (if (or (intermediate?) (advanced?))
+                     (parse-members next (getter) 'field-list getter abstract-method? just-method?)
+                     (parse-error (format "Expected an end to field ~a, fields end in ';', ',' is not allowed" (token-value tok))
+                                  srt ne)))
+                ((and #;(or (intermediate?) (advanced?)) (teaching-assignment-operator? n-tok))
+                 (let ((assign-exp (getter)))
+                   (cond
+                     ((eof? (get-tok assign-exp))
+                      (parse-error (format "Expected an expression to bind to ~a, and class body still needs a }" 
+                                           (token-value tok)) srt end))
+                     ((and (advanced?) (o-brace? (get-tok assign-exp)))
+                      (parse-members next (parse-array-init assign-exp (getter) 'start getter) 'field-init-end getter #f just-method?))
+                     (else
+                      (parse-members next (parse-expression null assign-exp 'start getter #f #f) 'field-init-end getter #f just-method?)))))
+                ((o-paren? n-tok) (parse-members next (getter) 'method-parms getter abstract-method? just-method?))
+                ((open-separator? n-tok) 
+                 (parse-error (format "Method parameters must begin with ( found ~a" n-out) srt ne))
+                ((id-token? n-tok)
+                 (if (and (id-token? (get-tok pre))
+                          (close-to-keyword? (get-tok pre) 'abstract))
+                     (parse-error
+                      (string-append 
+                       (format "Incorrectly formed field or method declaration.~n")
+                       (format
+                        "~a is close to 'abstract' but miscapitalized or misspelled, and might make this a method declaration.~n"
+                        (format-out (get-tok pre)))
+                       "Otherwise, "
+                       (if (or (intermediate?) (advanced?))
+                           (format "Fields must be separated by commas, method paramters must be in ()s, ~a not allowed" n-out)
+                           (format "Fields must be separatley declared, method paramters must be in ()s, ~a not allowed" n-out)))
+                      ps ne)
+                     (parse-error
+                      (if (or (intermediate?) (advanced?))
+                          (format "Fields must be separated by commas, method paramters must be in ()s, ~a not allowed" n-out)
+                          (format "Fields must be separatley declared, method paramters must be in ()s, ~a not allowed" n-out))
+                      srt ne)))
+                (else (parse-error 
+                       (format "Expected ';' to end field or abstract method parameter list, found ~a" n-out) srt ne)))))
+           (else 
+            (if (and (advanced?) (o-bracket? tok))
+                (let* ((next (getter))
+                       (next-tok (get-tok next)))
+                  (cond 
+                    ((eof? next-tok) (parse-error "Expected ] to end array type, and class still requires a }" srt end))
+                    ((c-bracket? next-tok) (parse-members next (getter) 'method-or-field getter abstract-method? just-method?))
+                    ((o-bracket? next-tok) 
+                     (parse-error "Array type may not have [[. A closing ] is required before beginning a new []" 
+                                  srt (get-end next)))
+                    (else
+                     (parse-error (format "Array type is of the form type[]. ~a is not allowed" (format-out next-tok)) srt
+                                  (get-end next)))))
+                (parse-error 
+                 (if (keyword? tok)
+                     (format "Expected a name for this field or method, cannot be named reserved word ~a" kind)
+                     (format "Expected a name for this field or method, found ~a" out))
+                 srt end)))))
+        ;Intermediate
+        ((field-list)
+         (case kind
+           ((EOF) (parse-error "Expected an additional field name after comma, class body still requires a }" ps pe))
+           ((IDENTIFIER)
+            (let* ((next (getter))
+                   (n-tok (get-tok next))
+                   (n-out (format-out n-tok))
+                   (ne (get-end next)))
+              (cond
+                ((eof? n-tok) (parse-error "Field has not completed, class body still requires a }" srt end))
+                ((semi-colon? n-tok) (parse-members next (getter) 'start getter #f just-method?))
+                ((comma? n-tok) (parse-members next (getter) 'field-list getter #f just-method?))
+                ((teaching-assignment-operator? n-tok)
+                 (let ((assign-exp (getter)))
+                   (cond
+                     ((eof? (get-tok assign-exp))
+                      (parse-error (format "Expected an expression to bind to ~a, and class body still needs a }" 
+                                           (token-value tok)) srt end))
+                     ((and (advanced?) (o-brace? (get-tok assign-exp)))
+                      (parse-members next (parse-array-init assign-exp (getter) 'start getter) 'field-init-end getter #f just-method?))
+                     (else
+                      (parse-members next (parse-expression null assign-exp 'start getter #f #f) 'field-init-end getter #f just-method?)))))
+                ((id-token? n-tok)
+                 (parse-error (format "Fields must be separated by commas, ~a not allowed" n-out) srt ne))
+                (else (parse-error (format "Expected ; to end field, or more field names, found ~a" n-out) srt ne)))))
+           (else
+            (parse-error
+             (if (keyword? tok)
+                 (format "Expected a name for this field, cannot be named reseved word ~a" kind)
+                 (format "Expected a name for this field, found ~a" out)) srt end))))
+        ;Intermediate
+        ((field-init-end)
+         (case kind
+           ((EOF) (parse-error "Expected a ';' or comma after field, class body still requires a }" ps pe))
+           ((COMMA) (parse-members cur (getter) 'field-list getter #f just-method?))
+           ((SEMI_COLON) (parse-members cur (getter) 'start getter #f just-method?))
+           ((IDENTIFIER) (parse-error (format "Fields must be separated by commas, ~a not allowed" out) srt end))
+           (else 
+            (parse-error 
+             (if (beginner?) 
+                 (format "Expected a ';' to end the field, found ~a" out)
+                 (format "Expected a ; to end field, or more field names, found ~a" out)) srt end))))                
+        ((method)
+         (cond
+           ((eof? tok) (parse-error "Expected method, and class body still requires a }" ps pe))
+           ((or (prim-type? tok) (and (or (intermediate?) (advanced?)) (void-token? tok)))
+            (parse-members cur (getter) 'method-id getter abstract-method? just-method?))
+           ((id-token? tok)
+            (let* ((next (getter))
+                   (next-tok (get-tok next))
+                   (next-kind (get-token-name next-tok))
+                   (next-end (get-end next))
+                   (next-start (get-start next)))
+              (cond
+                ((eof? next-tok) (parse-error "Expected method name, and class body still requires a }" srt end))
+                ((dot? next-tok) 
+                 (if (beginner?)
+                     (parse-error "The name of a type or class may not contain '.'" srt next-end)
+                     (parse-members next (parse-name (getter) getter #f) 'method-id getter abstract-method? just-method?)))
+                ((o-paren? next-tok) 
+                 (parse-error "Declaration is similar to constructor, which cannot be abstract" ps next-end))
+                ((semi-colon? next-tok) 
+                 (parse-error "Declaration is similar to a field, which cannot be abstract" ps next-end))
+                ((id-token? next-tok) (parse-members cur next 'method-id getter abstract-method? just-method?))
+                ((keyword? next-tok) 
+                 (parse-error 
+                  (format "Expected method name, found ~a which is reserved and cannot be a method's name" next-kind)
+                  next-start next-end))
+                (else (parse-error (format "Expected a method name, found ~a" (format-out next-tok)) 
+                                   next-start next-end)))))
+           ((keyword? tok)
+            (parse-error 
+             (format "Expected return type of the method, reserved word ~a is not a type" kind) srt end))
+           (else (parse-error (format "Expected return type of a method, found ~a" out) srt end))))
+        ((method-id)
+         (case kind
+           ((EOF) (parse-error "Expected method name, and class body still requires a }" ps pe))
+           ((IDENTIFIER)
+            (let* ((next (getter))
+                   (next-tok (get-tok next))
+                   (next-out (format-out next-tok))
+                   (next-start (get-start next))
+                   (next-end (get-end next)))
+              (cond
+                ((eof? next-tok) (parse-error "Expected method body, and class body still requires a }" srt end))
+                ((o-paren? next-tok) (parse-members next (getter) 'method-parms getter abstract-method? just-method?))
+                ((c-paren? next-tok) 
+                 (parse-error "Expected a ( to start parameter list but encountered the closing )" next-start next-end))
+                ((semi-colon? next-tok) 
+                 (parse-error "Declaration is similar to a field, which cannot be abstract" ps next-end))
+                ((open-separator? next-tok)
+                 (parse-error (format "Method parameter list is started by (, found ~a" next-out) next-start next-end))
+                (else (parse-error (format "Expected ( for parameter list, found ~a" next-out) next-start next-end)))))
+           (else
+            (if (keyword? tok)
+                (parse-error 
+                 (format "Expected method name, found ~a which is reserved and cannot be a method's name" kind)
+                 srt end)
+                (parse-error (format "Expected method name, found ~a" out) srt end)))))
+        ((ctor-parms)
+         (cond
+           ((eof? tok) (parse-error "Expected constructor parameters, and class body still requires a }" ps pe))
+           ((o-paren? tok) 
+            (parse-error "Constructor parameter list already started, an additional ( is not needed" srt end))
+           ((c-paren? tok)
+            (let* ((next (getter))
+                   (next-tok (get-tok next))
+                   (next-out (format-out next-tok))
+                   (next-start (get-start next))
+                   (next-end (get-end next)))                             
+              (cond
+                ((eof? next-tok) 
+                 (parse-error "Expected constructor body, and class body still requires a }" srt end))
+                ((c-paren? next-tok) 
+                 (parse-error "Constructor parameter list already closed, unneeded )" next-start next-end))
+                ((o-brace? next-tok) 
+                 (parse-members next (parse-ctor-body null (getter) getter) 'ctor-end getter #f just-method?))
+                ((open-separator? next-tok)
+                 (parse-error (format "Constructor body begins with a {, found ~a" next-out) next-start next-end))
+                ((semi-colon? next-tok) 
+                 (parse-error "Expected a constructor body, ; is only allowed for abstract methods" next-start next-end))
+                (else
+                 (parse-error (format "Expected a constructor body, starting with {, found ~a" next-out) next-start next-end)))))
+           ((or (prim-type? tok) (id-token? tok))
+            (let* ((next (getter))
+                   (next-tok (get-tok next))
+                   (next-start (get-start next))
+                   (next-end (get-end next)))
+              (cond
+                ((eof? next-tok) 
+                 (parse-error "Expected rest of parameter list, and class body still requires a }"  srt end))
+                ((comma? next-tok) (parse-error "Variable name must follow type before ," srt next-end))
+                ((c-paren? next-tok) (parse-error "Variable name must follow type before )" srt next-end))
+                ((id-token? next-tok)
+                 (let* ((afterID (getter))
+                        (afterID-tok (get-tok afterID)))
+                   (cond
+                     ((eof? afterID-tok) 
+                      (parse-error "Expected rest of parameter list, and class body requires a }" next-start next-end))
+                     ((c-paren? afterID-tok) (parse-members next afterID 'ctor-parms getter #f just-method?))
+                     ((close-separator? afterID-tok) 
+                      (parse-error (format "Expected a ) to close parameter list, found ~a" (format-out afterID-tok))
+                                   (get-start afterID) (get-end afterID)))
+                     ((comma? afterID-tok)
+                      (let* ((afterC (getter))
+                             (afterC-tok (get-tok afterC)))
+                        (cond
+                          ((eof? afterC-tok) (parse-error "Expected rest of parameter list, and class body requires a }"
+                                                          (get-start afterID) (get-end afterID)))
+                          ((c-paren? afterC-tok)
+                           (parse-error "Comma is unneeded before ) unless another variable is desired" 
+                                        (get-start afterID) (get-end afterC)))
+                          ((comma? afterC-tok)
+                           (parse-error "Parameter list should not have ,, Only one is needed" 
+                                        (get-start afterID) (get-end afterC)))
+                          (else (parse-members afterID afterC 'ctor-parms getter #f just-method?)))))
+                     ((or (prim-type? afterID-tok) (id-token? afterID-tok))
+                      (parse-error (format "~a begins a new parameter. A , is needed in between parameters"
+                                           (if (prim-type? afterID-tok) (get-token-name afterID-tok) (token-value afterID-tok)))
+                                   next-start (get-end afterID)))
+                     (else (parse-error (format "Expected , or ) in parameter list found ~a" (format-out afterID-tok))
+                                        (get-start afterID) (get-end afterID))))))
+                ((keyword? next-tok)
+                 (parse-error (format "Expected variable name after type, found reserved word ~a, which cannot be a name"
+                                      (get-token-name next-tok))
+                              next-start next-end))
+                ((and (advanced?) (o-bracket? next-tok))
+                 (parse-members cur next 'array-type getter #f just-method?))
+                (else (parse-error (format "Expected new parameter name after type, found ~a" (format-out next-tok))
+                                   next-start next-end)))))
+           ((keyword? tok)
+            (parse-error (format "Expected type name, reserved word ~a is not a type" kind) srt end))
+           (else (parse-error (format "Expected a parameter or ), found ~a" out) srt end))))
+        ((array-type)
+         (case kind
+           ((EOF) (parse-error "Expected remainder of constructor parameters" ps pe))
+           ((O_BRACKET) 
+            (let* ((next (getter))
+                   (next-tok (get-tok next)))
+              (cond 
+                ((eof? next-tok) (parse-error "Expected remainder of array type" srt end))
+                ((c-bracket? next-tok) (parse-members next (getter) 'array-type getter #f just-method?))
+                (else
+                 (parse-error (format "Expected ']' to close array type, found ~a which is not allowed" 
+                                      (format-out next-tok))
+                              srt (get-end next))))))
+           ((COMMA) (parse-error "Expected new paramter name after type, found ','" srt end))
+           ((IDENTIFIER) 
+            (let* ((next (getter))
+                   (next-tok (get-tok next)))
+              (cond
+                ((eof? next-tok) (parse-error "Expected ')' to close parameter list, or more parameters" srt end))
+                
+                ((comma? next-tok)
+                 (let* ((afterC (getter))
+                        (afterC-tok (get-tok afterC)))
+                   (cond
+                     ((eof? afterC-tok) (parse-error "Expected rest of parameter list for constructor"
+                                                     (get-start next) (get-end next)))
+                     ((c-paren? afterC-tok)
+                      (parse-error "Comma is unneeded before ) unless another variable is desired" 
+                                   (get-start next) (get-end afterC)))
+                     ((comma? afterC-tok)
+                      (parse-error "Parameter list should not have ,, Only one is needed" 
+                                   (get-start next) (get-end afterC)))
+                     (else (parse-members next afterC 'ctor-parms getter #f just-method?)))))
+                ((c-paren? next-tok) (parse-members cur next 'ctor-parms getter #f just-method?))
+                (else (parse-error (format "Expected ',' or ')' in parameters found ~a which is not allowed" 
+                                           (format-out next-tok))
+                                   srt (get-end next))))))
+           (else
+            (parse-error (format "Expected parameter name after type, found ~a" out) srt end))))
+        ((method-array-type)
+         (case kind
+           ((EOF) (parse-error "Expected remainder of method parameters" ps pe))
+           ((O_BRACKET) 
+            (let* ((next (getter))
+                   (next-tok (get-tok next)))
+              (cond 
+                ((eof? next-tok) (parse-error "Expected remainder of array type" srt end))
+                ((c-bracket? next-tok) (parse-members cur (getter) 'method-array-type getter abstract-method? just-method?))
+                (else
+                 (parse-error (format "Expected ']' to close array type, found ~a which is not allowed" 
+                                      (format-out next-tok))
+                              srt (get-end next))))))
+           ((COMMA) (parse-error "Expected new paramter name after type, found ','" srt end))
+           ((IDENTIFIER) 
+            (let* ((next (getter))
+                   (next-tok (get-tok next)))
+              (cond
+                ((eof? next-tok) (parse-error "Expected ')' to close parameter list, or more parameters" srt end))
+                
+                ((comma? next-tok)
+                 (let* ((afterC (getter))
+                        (afterC-tok (get-tok afterC)))
+                   (cond
+                     ((eof? afterC-tok) (parse-error "Expected rest of parameter list for method"
+                                                     (get-start next) (get-end next)))
+                     ((c-paren? afterC-tok)
+                      (parse-error "Comma is unneeded before ) unless another variable is desired" 
+                                   (get-start next) (get-end afterC)))
+                     ((comma? afterC-tok)
+                      (parse-error "Parameter list should not have ,, Only one is needed" 
+                                   (get-start next) (get-end afterC)))
+                     (else (parse-members next afterC 'method-parms getter abstract-method? just-method?)))))
+                ((c-paren? next-tok) (parse-members cur next 'method-parms getter abstract-method? just-method?))
+                (else (parse-error (format "Expected ',' or ')' in parameters found ~a which is not allowed" 
+                                           (format-out next-tok))
+                                   srt (get-end next))))))
+           (else
+            (parse-error (format "Expected parameter name after type, found ~a" out) srt end))))
+        ((method-parms)
+         (cond
+           ((eof? tok) (parse-error "Expceted method parameters, and class body still requires }" ps pe))
+           ((o-paren? tok) 
+            (parse-error "Method parameter list already started, an additional ( is not needed" srt end))
+           ((c-paren? tok)
+            (let* ((next (getter))
+                   (next-tok (get-tok next))
+                   (next-out (format-out next-tok))
+                   (next-start (get-start next))
+                   (next-end (get-end next)))
+              (cond
+                ((eof? next-tok)
+                 (parse-error "Expected method body, and class body still requires a '}'" srt end))
+                ((c-paren? next-tok) 
+                 (parse-error "Method parameter list already closed, unneeded ')'" next-start next-end))
+                ((o-brace? next-tok)
+                 (if abstract-method?
+                     (parse-error "abstract methods may not have a body. Found '{' when ';' was expected" next-start next-end)
+                     (parse-members next (if (or (intermediate?) (advanced?))
+                                             (parse-method-body null (getter) getter #f #f)
+                                             (parse-statement null (getter) 'start getter #f #f #f))
+                                    'method-end getter abstract-method? just-method?)))                
+                ((open-separator? next-tok)
+                 (if abstract-method?
+                     (parse-error (format "abstract methods should end with ';', found ~a" next-out) next-start next-end) 
+                     (parse-error (format "Method body begins with a '{', found ~a" next-out) next-start next-end)))
+                ((semi-colon? next-tok) (parse-members next (getter) 'start getter #f just-method?))
+                (else
+                 (if abstract-method?
+                     (parse-error (format "Expected a ';' to end abstract method, found ~a" next-out) next-start next-end)
+                     (parse-error (format "Expected a method body, starting with '{', found ~a" next-out) next-start next-end))))))
+           ((or (prim-type? tok) (id-token? tok))
+            (let* ((next (getter))
+                   (next-tok (get-tok next))
+                   (next-start (get-start next))
+                   (next-end (get-end next)))
+              (cond
+                ((eof? next-tok) 
+                 (parse-error "Expected rest of parameter list, and class body still requires a }" srt end))
+                ((comma? next-tok)  (parse-error "Variable name must follow type before ," srt next-end))
+                ((c-paren? next-tok)  (parse-error "Variable name must follow type before )" srt next-end))
+                ((id-token? next-tok)
+                 (let* ((afterID (getter))
+                        (afterID-tok (get-tok afterID)))
+                   (cond
+                     ((eof? afterID-tok) 
+                      (parse-error "Expected rest of parameter list, and class body requires a '}'" next-start next-end))
+                     ((c-paren? afterID-tok) (parse-members next afterID 'method-parms getter abstract-method? just-method?))
+                     ((comma? afterID-tok)
+                      (let* ((afterC (getter))
+                             (afterC-tok (get-tok afterC)))
+                        (cond
+                          ((eof? afterC-tok) (parse-error "Expected rest of parameter list, and class body requires a '}'"
+                                                          (get-start afterID) (get-end afterID)))
+                          ((c-paren? afterC-tok)
+                           (parse-error "Comma is unneeded before ) unless another variable is desired" 
+                                        (get-start afterID) (get-end afterC)))
+                          ((comma? afterC-tok) 
+                           (parse-error "Parameter list should not have ,, Only one is needed" 
+                                        (get-start afterID) (get-end afterC)))
+                          (else (parse-members afterID afterC 'method-parms getter abstract-method? just-method?)))))
+                     ((or (prim-type? afterID-tok) (id-token? afterID-tok))
+                      (parse-error (format "~a begins a new parameter. A , is needed in between parameters"
+                                           (if (prim-type? afterID-tok) (get-token-name afterID-tok) (token-value afterID-tok)))
+                                   next-start (get-end afterID)))
+                     (else (parse-error (format "Expected , or ) in parameter list found ~a" (format-out afterID-tok))
+                                        (get-start afterID) (get-end afterID))))))
+                ((keyword? next-tok)
+                 (parse-error (format "Expected variable name after type, found reserved word ~a, which cannot be a name"
+                                      (get-token-name next-tok))
+                              next-start next-end))
+                ((and (advanced?) (o-bracket? next-tok))
+                 (parse-members cur next 'method-array-type getter abstract-method? just-method?))
+                (else (parse-error (format "Expected new parameter name after type, found ~a" (format-out next-tok))
+                                   next-start next-end)))))
+           ((keyword? tok)
+            (parse-error (format "Expected type name, reserved word ~a is not a type" kind) srt end))
+           (else (parse-error (format "Expected a parameter or ), found ~a" (format-out tok)) srt end))))
+        ((ctor-end)
+         (case kind
+           ((EOF) (parse-error "Expected } to end constructor body, and class body still requires }" ps pe))
+           ((C_BRACE) (parse-members cur (getter) 'start getter #f just-method?))
+           ((if return) 
+            (parse-error (format "Statements are not permitted in the constructor body, found ~a" kind) srt end))
+           (else (parse-error (format "Expected a } to end the constructor, found ~a" out) srt end))))
+        ((method-end)
+         (case kind
+           ((EOF) (parse-error "Expected } to end method body, and class body still requires }" ps pe))
+           ((C_BRACE) (parse-members cur (getter) 'start getter #f just-method?))
+           (else 
+            (parse-error (format "Expected 1 statement, and then } for method body. Found ~a instead of }" out)
+                         srt end)))))))
+  
+  ;parse-array-init token token symbol (-> token) -> token
+  (define (parse-array-init pre cur-tok state getter)
+;    (printf "parse-array-init state ~a pre ~a cur-tok ~a~n" state pre cur-tok)
+    (let* ((tok (get-tok cur-tok))
+           (kind (get-token-name tok))
+           (out (format-out tok))
+           (start (get-start cur-tok))
+           (end (get-end cur-tok))
+           (ps (if (null? pre) null (get-start pre)))
+           (pe (if (null? pre) null (get-end pre))))
+      (case state
+        ((start)
+         (case kind
+           ((EOF) (parse-error "Expected expressions to create array or '}' to end it" ps pe))
+           ((O_BRACE) (parse-array-init pre (parse-array-init cur-tok (getter) 'start getter) 'comma-or-end getter))
+           ((C_BRACE) (getter))
+           ((SEMI_COLON) (parse-error "Expected a '}' to close array before ending field" ps end))
+           (else (parse-array-init pre (parse-expression null cur-tok 'start getter #f #f) 'comma-or-end getter))))
+        ((comma-or-end)
+         (case kind
+           ((EOF) (parse-error "Expected ',' for more expressions of the array or '}' to end it" ps pe))
+           ((C_BRACE) (getter))
+           ((COMMA)
+            (let* ((next (getter))
+                   (next-tok (get-tok next)))
+              (cond
+                ((eof? next-tok) (parse-error "Expected further expressions for array" ps end))
+                ((c-brace? next-tok) (parse-error "Expected further expressions for array after ',', not '}' to end it" ps 
+                                                  (get-end next)))
+                ((o-brace? next-tok)
+                 (parse-array-init pre (parse-array-init next (getter) 'start getter) 'comma-or-end getter))
+                (else
+                 (parse-array-init pre (parse-expression null next 'start getter #f #f) 'comma-or-end getter)))))
+           (else
+            (parse-error (format "Items of the array must be separated by ',' or end with '}' to close the array. Found ~a" out)
+                         ps end)))))))
+
+  ;Beginner
+  ;parse-field: token token symbol (->token) -> token
+  (define (parse-field pre cur-tok state getter)
+    (let* ((tok (get-tok cur-tok))
+           (kind (get-token-name tok))
+           (out (format-out tok))
+           (start (get-start cur-tok))
+           (end (get-end cur-tok))
+           (ps (if (null? pre) null (get-start pre)))
+           (pe (if (null? pre) null (get-end pre))))
+      (case state
+        ((start)
+         (case kind
+           ((EOF) (parse-error "Expected a name for this variable declaration" ps pe))
+           ((IDENTIFIER) (parse-field cur-tok (getter) 'equals getter))
+           ((=) (parse-error "Expected a name for this variable declaration inbetween the type and =" ps end))
+           (else
+            (if (keyword? tok)
+                (parse-error 
+                 (format "Expected a name for this declaration, reserved word ~a may not be the name" kind) start end)
+                (parse-error
+                 (format "Expected a name for this declaration, found ~a" out) start end)))))
+        ((equals)
+         (case kind
+           ((=) 
+            (let ((next (getter)))
+              (if (eof? (get-tok next))
+                  (parse-error "Expected an expression for this declaration" start end)
+                  (parse-field cur-tok (parse-expression cur-tok next 'start getter #f #f) 'end getter))))
+           ((COMMA)
+            (parse-error "Expected an assignment of the given name to a value, found ',' which is not allowed here."
+                         ps end))
+           ((SEMI_COLON)
+            (parse-error "Expected an assignment of the given name to a value, found ';' which is not allowed here."
+                         ps end))
+           (else
+            (parse-error (format "Expected an assignment of the given name to a value, found ~a" out) ps end))))
+        ((end)
+         (case kind
+           ((EOF) (parse-error "Declaration must end with a ';'" ps pe))
+           ((SEMI_COLON) (getter))
+           (else
+            (parse-error (format "Expected an end to this declartion, found ~a" out) start end)))))))
+  ;Intermediate
+  ;parse-iface-body: token token symbol (->token) -> token
+  (define (parse-iface-body pre cur state getter) 
+    (let* ((tok (get-tok cur))
+           (kind (get-token-name tok))
+           (out (format-out tok))
+           (srt (get-start cur))
+           (end (get-end cur))
+           (ps (if (null? pre) null (get-start pre)))
+           (pe (if (null? pre) null (get-end pre))))
+    (case state
+      ((start)          
+       (cond
+         ((or (eof? tok) (c-brace? tok)) cur)
+         ((abstract? tok) (parse-iface-body cur (getter) 'method-type getter))
+         ((prim-type? tok) (parse-iface-body cur (getter) 'method-id getter))
+         ((void-token? tok) (parse-iface-body cur (getter) 'method-id getter))
+         ((id-token? tok) (parse-iface-body cur (getter) 'method-id getter))
+         (else 
+          (parse-error 
+           (format "Only methods may be within the interface body, found ~a" out) srt end))))
+      ((method-type)
+       (cond
+         ((eof? tok) (parse-error "Expected method, and interface body still requires a }" ps pe))
+         ((or (prim-type? tok) (void-token? tok)) (parse-iface-body cur (getter) 'method-id getter))
+         ((id-token? tok) (parse-iface-body cur (getter) 'method-id getter))
+         ((keyword? tok)
+          (parse-error 
+           (format "Expected return type of the method, reserved word ~a is not a type" kind) srt end))
+         (else (parse-error (format "Expected return type of a method, found ~a" out) srt end))))
+      ((method-id)
+       (case kind
+         ((EOF) (parse-error "Expected method name, and interface body still requires a }" ps pe))
+         ((IDENTIFIER)
+          (let* ((next (getter))
+                 (next-tok (get-tok next))
+                 (next-out (format-out next-tok))
+                 (next-start (get-start next))
+                 (next-end (get-end next)))
+            (cond
+              ((eof? next-tok) (parse-error "Expected method parameters, and interface body still requires a }" srt end))
+              ((o-paren? next-tok) (parse-iface-body next (getter) 'parms getter))
+              ((c-paren? next-tok)
+               (parse-error "Expected a ( to start parameter list but encountered the closing )" next-start next-end))
+              ((semi-colon? next-tok) 
+               (parse-error "Declaration is similar to a field, which maynot be in an interface" ps next-end))
+              ((open-separator? next-tok)
+               (parse-error (format "Method parameter list is started by (, found ~a" next-out) next-start next-end))
+              (else (parse-error (format "Expected ( for parameter list, found ~a" next-out) next-start next-end)))))
+         ((PERIOD) 
+          (if (id-token? (get-tok pre)) 
+              (parse-iface-body cur (parse-name (getter) getter #f) 'method-id getter)
+              (parse-error (format "~a cannot be followed by '.'" (format-out pre)) ps end)))
+         ((O_PAREN) (parse-error "Expected a method name before parameter list" ps end))
+         ((SEMI_COLON) (parse-error "Declaration is similar to a field, which maynot be in an interface" ps end))
+         (else
+          (if (keyword? tok)
+              (parse-error 
+               (format "Expected method name, found ~a which is reserved and cannot be a method's name" kind) srt end)
+              (parse-error (format "Expected method name, found ~a" out) srt end)))))
+      ((parms)
+       (cond
+         ((eof? tok) (parse-error "Expceted method parameters, and interface body still requires }" ps pe))
+         ((o-paren? tok) 
+          (parse-error "Method parameter list already started, an additional ( is not needed" srt end))
+         ((c-paren? tok)
+          (let* ((next (getter))
+                 (next-tok (get-tok next))
+                 (next-out (format-out next-tok))
+                 (next-start (get-start next))
+                 (next-end (get-end next)))
+            (cond
+              ((eof? next-tok) (parse-error "Expected a ';', and interface body still requires a }" srt end))
+              ((c-paren? next-tok) 
+               (parse-error "Method parameter list already closed, unneeded )" next-start next-end))
+              ((o-brace? next-tok)
+               (parse-error "Method in interface maynot have a body" next-start next-end))
+              ((semi-colon? next-tok) (parse-iface-body next (getter) 'start getter))
+              (else
+               (parse-error (format "Expected a ';', found ~a" next-out) next-start next-end)))))
+         ((or (prim-type? tok) (id-token? tok))
+          (let* ((next (getter))
+                 (next-tok (get-tok next))
+                 (next-start (get-start next))
+                 (next-end (get-end next)))
+            (cond
+              ((eof? next-tok) 
+               (parse-error "Expected rest of parameter list, and interface body still requires a }" srt end))
+              ((comma? next-tok)  (parse-error "Variable name must follow type before ," srt next-end))
+              ((c-paren? next-tok)  (parse-error "Variable name must follow type before )" srt next-end))
+              ((id-token? next-tok)
+               (let* ((afterID (getter))
+                      (afterID-tok (get-tok afterID))
+                      (afterID-s (get-start afterID)))
+                 (cond
+                   ((eof? afterID-tok) 
+                    (parse-error "Expected rest of parameter list, and interface body requires a }" next-start next-end))
+                   ((c-paren? afterID-tok) (parse-iface-body next afterID 'parms getter))
+                   ((comma? afterID-tok)
+                    (let* ((afterC (getter))
+                           (afterC-tok (get-tok afterC))
+                           (afterC-end (get-end afterC)))
+                      (cond
+                        ((eof? afterC-tok) 
+                         (parse-error "Expected rest of parameter list, and class body requires a }" afterID-s afterC-end))
+                        ((c-paren? afterC-tok)
+                         (parse-error "Comma is unneeded before ) unless another variable is desired" afterID-s afterC-end))
+                        ((comma? afterC-tok) 
+                         (parse-error "Parameter list should not have ',,' Only one is needed" afterID-s afterC-end))
+                        (else (parse-iface-body afterID afterC 'parms getter)))))
+                   ((or (prim-type? afterID-tok) (id-token? afterID-tok))
+                    (parse-error (format "~a begins a new parameter. A , is needed in between parameters"
+                                         (if (prim-type? afterID-tok) (get-token-name afterID-tok) (token-value afterID-tok)))
+                                 next-start (get-end afterID)))
+                   (else (parse-error (format "Expected , or ) in parameter list found ~a" (format-out afterID-tok))
+                                      afterID-s (get-end afterID))))))
+              ((keyword? next-tok)
+               (parse-error (format "Expected variable name after type, found reserved word ~a, which cannot be a name"
+                                    (get-token-name next-tok))
+                            next-start next-end))
+              (else (parse-error (format "Expected new parameter name after type, found ~a" (format-out next-tok))
+                                 next-start next-end)))))
+         ((keyword? tok)
+          (parse-error (format "Expected type name, reserved word ~a is not a type" kind) srt end))
+         (else (parse-error (format "Expected a parameter or ), found ~a" (format-out tok)) srt end)))))))
+  
+  ;parse-type: token (-> token) bool -> token
+  (define (parse-name cur-tok getter star-ok?) 
+    (let* ((tok (get-tok cur-tok))
+           (kind (get-token-name tok))
+           (start (get-start cur-tok))
+           (stop (get-end cur-tok)))
+      (case kind
+        ((IDENTIFIER) 
+         (let ((next-tok (getter)))
+           (if (dot? (get-tok next-tok))
+               (parse-name (getter) getter star-ok?)
+               next-tok)))
+        ((PERIOD) (parse-error "It is not allowed to have two .s, only one is necessary" start stop))
+        ((*)
+         (if star-ok? 
+             cur-tok
+             (parse-error "A name may not contain a *" start stop)))
+        (else 
+         (if (keyword? tok)
+             (parse-error (format "Expected variable after ., found reserved word ~a, which may not be a variable" kind)
+                          start stop)
+             (parse-error (format "Expected variable after . in name, found ~a" (format-out tok)) start stop))))))
+  
+  ;parse-ctor-body: token token (->token) -> token
+  (define (parse-ctor-body pre cur-tok getter)
+    (case (get-token-name (get-tok cur-tok))
+      ((EOF C_BRACE) cur-tok)
+      ((super) 
+       (parse-ctor-call cur-tok (getter) 'start getter))
+      ((this)
+       (cond
+         ((advanced?) (parse-ctor-call cur-tok (getter) 'start getter))
+         ((intermediate?) (parse-method-body pre cur-tok getter #t #f))
+         ((beginner?) (parse-beginner-ctor-body null cur-tok 'start getter))))
+      (else 
+       (if (beginner?)
+           (parse-beginner-ctor-body null cur-tok 'start getter) 
+           (parse-method-body pre cur-tok getter #t #f)))))
+
+  ;parse-ctor-call: token token symbol -> token
+  (define (parse-ctor-call pre cur-tok state getter) 
+    (let* ((tok (get-tok cur-tok))
+           (kind (get-token-name tok))
+           (out (format-out tok))
+           (start (get-start cur-tok))
+           (end (get-end cur-tok))
+           (ps (if (null? pre) null (get-start pre)))
+           (pe (if (null? pre) null (get-end pre))))
+      (case state
+        ((start)
+         (case kind
+           ((O_PAREN) (parse-ctor-call cur-tok (getter) 'ctor-args getter))
+           ((PERIOD) 
+            (let* ((next (getter))
+                   (next-tok (get-tok next))
+                   (ne (get-end next)))
+              (cond
+                ((id-token? next-tok) 
+                 (parse-method-body pre (parse-statement next (getter) 'assign-or-call getter #t #t #f) getter #t #f))
+                ((keyword? next-tok)
+                 (parse-error (format "Expected identifier after '.', found reserved word ~a" (get-token-name next-tok))
+                              start ne))
+                (else
+                 (parse-error (format "Expected identifer after '.', found ~a" (format-out next-tok)) start ne)))))
+           (else (parse-error (format "~a cannot be used here" (get-token-name pre)) ps end))))
+        ((ctor-args)
+         (case kind
+           ((EOF) (parse-error "Expected constructor arguments or )" ps pe))
+           ((C_PAREN)
+            (let ((next (getter)))
+              (if (semi-colon? (get-tok next))
+;                  (getter)
+                  (if (beginner?)
+                      (parse-beginner-ctor-body null (getter) 'start getter)
+                      (parse-method-body next (getter) getter #t #t))
+                  (parse-error (format "Expected a ';' after constructor call, found ~a" (format-out (get-tok next)))
+                               start (get-end next)))))
+           (else 
+            (parse-ctor-call cur-tok (parse-expression pre cur-tok 'start getter #f #f) 'more-args getter))))
+        ((more-args)
+         (case kind
+           ((EOF) (parse-error "Expected constructor arguments or )" ps pe))
+           ((C_PAREN) (parse-ctor-call pre cur-tok 'ctor-args getter))
+           ((COMMA) 
+            (let ((next (getter)))
+              (if (comma? (get-tok next))
+                  (parse-error "Found ',,' Only one comma is needed to separate arguments" start (get-end next))
+                  (parse-ctor-call cur-tok (parse-expression cur-tok next 'start getter #f #f) 'more-args getter))))
+           (else 
+            (if (close-separator? tok)
+                (parse-error (format "Expected ) to close constructor arguments, found ~a" out) start end)
+                (parse-error (format "A ',' is required between constructor arguments, found ~a" out) start end))))))))
+
+  
+  ;Beginner
+  ;parse-beginner-ctor-body: token token symbol (-> token) -> token
+  (define (parse-beginner-ctor-body pre cur-tok state getter)
+    (let* ((tok (get-tok cur-tok))
+           (kind (get-token-name tok))
+           (out (format-out tok))
+           (start (get-start cur-tok))
+           (end (get-end cur-tok))
+           (ps (if (null? pre) null (get-start pre)))
+           (pe (if (null? pre) null (get-end pre))))
+      (case state
+        ((start)
+         (case kind
+           ((C_BRACE EOF) cur-tok)
+           ((super) 
+            (parse-error 
+             (format "~a~n~a"
+                     "Calling the parent's constructor must be the first action of a constructor,"
+                     "and maynot appear here")
+             start end))
+           ((this) 
+            (let* ((next (getter))
+                   (next-tok (get-tok next))
+                   (ns (get-start next))
+                   (ne (get-end next)))
+              (cond
+                ((eof? next-tok) 
+                 (parse-error "Expected rest of field initialization, constructor and class need }" start end))
+                ((dot? next-tok)
+                 (let* ((afterD (getter))
+                        (afterD-tok (get-tok afterD))
+                        (ae (get-end afterD)))
+                   (cond
+                     ((id-token? afterD-tok) (parse-beginner-ctor-body afterD (getter) 'assign-op getter))
+                     ((keyword? afterD-tok) 
+                      (parse-error (format "Expected identifier after '.', found reserved word ~a" (get-token-name afterD-tok))
+                                   ns ae))
+                     (else
+                      (parse-error (format "Expected identifer after '.', found ~a" (format-out afterD-tok)) ns ae)))))
+                (else (parse-error (format "Expected this.Field, found ~a instead of '.'" (format-out next-tok)) ns ne)))))
+           ((IDENTIFIER)
+            (let ((next (getter)))
+              (if (dot? (get-tok next)) 
+                  (parse-beginner-ctor-body next (parse-name (getter) getter #f) 'assign-op getter)
+                  (parse-beginner-ctor-body cur-tok next 'assign-op getter))))
+           (else 
+            (if (keyword? tok)
+                (parse-error (format "Expected name, found reserved word ~a" kind) start end)
+                (parse-error (format "Expected name, found ~a" out) start end)))))
+        ((assign-op)
+         (case kind
+           ((EOF) (parse-error "Expected rest of field initialization (=), constructor and class need }" ps pe))
+           ((=) 
+            (let ((next (getter)))
+              (if (eof? (get-tok next))
+                  (parse-error "Expected an expression after = for field initialization" start end)
+                  (parse-beginner-ctor-body cur-tok (parse-expression null next 'start getter #f #f) 'assign-end getter))))
+           (else (parse-error (format "Expected = to be used in initializing the field, found ~a" out) start end))))
+        ((assign-end)
+         (cond
+           ((eof? tok) (parse-error "Expected a ; to end field intialization, constructor and class need }" ps pe))
+           ((semi-colon? tok) (parse-beginner-ctor-body cur-tok (getter) 'start getter))
+           (else (parse-error (format "Expected a ; to end field initialization, found ~a" out) start end)))))))
+  
+    
+  ;Intermediate
+  ;parse-method-body: token token (->token) bool bool-> token
+  (define (parse-method-body pre cur-tok getter ctor? call-seen?)
+;    (printf "parse-method-body pre ~a cur-tok ~a~n" pre cur-tok)
+    (case (get-token-name (get-tok cur-tok))
+      ((C_BRACE EOF) cur-tok)
+      (else (parse-method-body pre 
+                               (parse-statement pre cur-tok 'start getter #t ctor? call-seen?) 
+                               getter ctor? call-seen?))))
+  
+  ;Intermediate - addition of parameter id-ok?
+  ;parse-statement: token token symbol (->token) bool bool bool-> token
+  (define (parse-statement pre cur-tok state getter id-ok? ctor? super-seen?)
+;    (printf "parse-statement state: ~a pre: ~a cur-tok: ~a~n" state pre cur-tok)
+    (let* ((tok (get-tok cur-tok))
+           (kind (get-token-name tok))
+           (out (format-out tok))
+           (start (get-start cur-tok))
+           (end (get-end cur-tok))
+           (ps (if (null? pre) null (get-start pre)))
+           (pe (if (null? pre) null (get-end pre))))
+      (case state
+        ((start)
+         (case kind
+           ((if) (parse-statement cur-tok (getter) 'if getter id-ok? ctor? super-seen?))
+           ((return)
+            (let ((next (getter)))
+              (cond
+                ((eof? (get-tok next)) 
+                 (parse-error (if (or (advanced?) (intermediate?) )
+                                  "Expected rest of return" 
+                                  "Expected expression for return") 
+                              start end))
+                ((and (or (advanced?) (intermediate?)) (semi-colon? (get-tok next))) (getter))
+                (else (parse-statement cur-tok (parse-expression null next 'start getter #f #f) 
+                                       'return getter id-ok? ctor? super-seen?)))))
+           ((IDENTIFIER)
+            (if (beginner?)
+                (parse-error
+                 (let ((v (token-value tok)))
+                   (cond
+                    ((close-to-keyword? tok 'if) 
+                     (format "Expected 'if', found ~a which is perhaps miscapitalized or spelled" v))
+                    ((close-to-keyword? tok 'return)
+                     (format "Expected 'return', found ~a which is perhaps miscapitalized or spelled" v))
+                    (else
+                     (format "Expected a statement, found ~a. Statements begin with 'if' or 'return'" out)))) 
+                 start end)
+                (let* ((next (getter))
+                       (next-tok (get-tok next)))
+                  (cond
+                    ((dot? next-tok)
+                     (parse-statement next (parse-name (getter) getter #f) 'statement-or-var getter id-ok? ctor? super-seen?))
+                    ((literal-token? next-tok)
+                     (parse-error 
+                      (if (close-to-keyword? tok 'return)
+                          (string-append
+                           (format "~a ~a is not the correct beginning of a statement. ~a is similar to 'return'~n"
+                                   (token-value tok) (format-out next-tok #f) (token-value tok))
+                           "Check spelling and capitalization")
+                          (format "It is an error to have ~a ~a as a statement" out (format-out next-tok #f)))
+                      start (get-end next)))
+                    ((this? next-tok)
+                     (parse-error
+                      (if (close-to-keyword? tok 'return)
+                          (string-append 
+                           (format "'~a this' is not the correct beginning of a statement. ~a is similar to 'return'~n"
+                                   (token-value tok) (token-value tok))
+                           "Check spelling and capitalization")
+                          (format "It is an error to have '~a this' as a statement" out))
+                      start (get-end next)))
+                    (else
+                     (parse-statement cur-tok next 'statement-or-var getter id-ok? ctor? super-seen?))))))
+           (else
+            (when (beginner?)
+              (parse-error (format "Expected a statement, found ~a. Statements begin with 'if' or 'return'" out) start end))
+            ;Intermediate cases
+            (case kind
+              ;From ctor-beginner-body
+              ((this super)
+               (let* ((next (getter))
+                      (next-tok (get-tok next))
+                      (ns (get-start next))
+                      (ne (get-end next)))
+                 (cond
+                   ;Intermediate error change
+                   ((eof? next-tok) (parse-error (format "Expected ~a.name, unexpected end" kind) start end))
+                   ((dot? next-tok)
+                    (let* ((afterD (getter))
+                           (afterD-tok (get-tok afterD))
+                           (ae (get-end afterD)))
+                      (cond
+                        ;Intermediate changed next state
+                        ((id-token? afterD-tok) 
+                         (parse-statement afterD (getter) 'assign-or-call getter id-ok? ctor? super-seen?))
+                        ((keyword? afterD-tok)
+                         (parse-error (format "Expected identifier after '.', found reserved word ~a" (get-token-name afterD-tok))
+                                      ns ae))
+                        (else
+                         (parse-error (format "Expected identifer after '.', found ~a" (format-out afterD-tok)) ns ae)))))
+                   ((o-paren? next-tok)
+                    (cond
+                      ((and ctor? super-seen?)
+                       (parse-error (format "Expected ~a.name, found ~a instead of '.'" kind (format-out next-tok)) ns ne))
+                      (ctor?
+                       (parse-error (string-append (format "~a() calls must be the first item of the constructor body.~n" kind)
+                                                   (format "Or a name was expected to complete ~a.name constructrion." kind))
+                                    start ne))
+                      (else
+                       (parse-error (string-append (format "~a() calls may only appear in the constructor" kind)
+                                                   (format "Or a name was expected to complete ~a.name construction." kind))
+                                    start ne))))
+                   (else (parse-error (format "Expected ~a.name, found ~a instead of '.'" kind (format-out next-tok)) ns ne)))))
+              ;Intermediate
+              ((new) (parse-statement cur-tok (parse-expression cur-tok (getter) 'alloc-start getter #f #f)
+                                      'end-exp getter id-ok? ctor? super-seen?))
+              ;Intermediate
+              ((O_PAREN) 
+               (parse-statement cur-tok 
+                                (parse-expression cur-tok (parse-expression cur-tok (getter) 'start getter #f #f)
+                                                  'c-paren getter #f #f)
+                                'end-exp getter id-ok? ctor? super-seen?))
+              ;Intermediate
+              ((O_BRACE) 
+               (parse-statement cur-tok (parse-method-body cur-tok (getter) getter ctor? super-seen?) 
+                                          'c-brace getter #t ctor? super-seen?))
+              ;Intermediate - changed wholly
+              (else
+               (cond
+                 ((prim-type? tok) (parse-statement cur-tok (getter) 'local getter id-ok? ctor? super-seen?))
+                 ;Advanced
+                 ((and (advanced?) (for-token? tok))
+                  (parse-statement cur-tok (getter) 'for getter id-ok? ctor? super-seen?))
+                 ((and (advanced?) (do-token? tok))
+                  (parse-statement cur-tok (getter) 'do getter id-ok? ctor? super-seen?))
+                 ((and (advanced?) (while-token? tok))
+                  (parse-statement cur-tok (getter) 'while getter id-ok? ctor? super-seen?))
+                 ((and (advanced?) (or (break-token? tok) (continue-token? tok)))
+                  (parse-statement cur-tok (getter) 'break-continue getter id-ok? ctor? super-seen?))
+                 ((keyword? tok)
+                  (parse-error (format "Expected name, found reserved word ~a" kind) start end))
+                 (else 
+                  (parse-error (format "Expected statement, found ~a, which cannot begin a statement" out) start end))))))))
+        ((if)
+         (case kind
+           ((EOF) (parse-error "Expected conditional test for 'if'" ps pe))
+           ((O_PAREN) 
+            (let ((next (getter)))
+              (if (eof? (get-tok next))
+                  (parse-error (format "Expected conditional expression for 'if'") start end)
+                  (parse-statement cur-tok (parse-expression null next 'start getter #f #f) 
+                                   'if-then getter id-ok? ctor? super-seen?))))
+           (else 
+            (parse-error (format "Conditional expression for 'if' must be started with '(', found ~a" out) start end))))
+        ((if-then)
+         (case kind
+           ((EOF) 
+            (if (advanced?)
+                (parse-error "Expected ')' to close conditional for 'if'" ps pe)
+                (parse-error "Expected ')' to close conditional for 'if', and then and else statements for 'if'" ps pe)))
+           ((C_PAREN)
+            (let* ((next (getter))
+                   (next-tok (get-tok next)))
+              (cond
+                ((eof? next-tok) (parse-error "Expected statement for then branch of 'if'" start end))
+                ((c-paren? next-tok) 
+                 (parse-error "Conditional expression already closed, extra ')' found" start (get-end next)))
+                (else (parse-statement cur-tok (parse-statement null next 'start getter #f ctor? super-seen?)
+                                       'if-else getter id-ok? ctor? super-seen?)))))
+           (else 
+            (parse-error 
+             (format "Conditional expression for 'if' must be in parens, did not find ')', found ~a" out) ps end))))
+        ((if-else)
+         (case kind
+           ((EOF) 
+            (if (advanced?) cur-tok (parse-error "Expected 'else' for 'if' statement" ps pe)))
+           ((else) (parse-statement null (getter) 'start getter #f ctor? super-seen?))
+           (else
+            (if (advanced?)
+                cur-tok
+                (parse-error
+                 (if (and (id-token? tok) (close-to-keyword? tok 'else))
+                     (format "Expected 'else' for 'if', found ~a, which might be mispelled or miscapitalized" 
+                             (token-value tok))
+                     (format "Expected 'else' for 'if', found ~a" out))
+                 start end)))))
+        ((return)
+         (case kind
+           ((EOF) (parse-error "Expected ';' to end 'return' statement" ps pe))
+           ((SEMI_COLON) (getter))
+           (else (parse-error (format "Expected ';' to end 'return' statement, found ~a" out) start end))))
+        ;Intermediate & Advanced
+        ((statement-or-var)
+         (case kind
+           ((EOF) (parse-error "Expected remainder of statement" ps pe))
+           ((IDENTIFIER) (parse-statement pre cur-tok 'local getter id-ok? ctor? super-seen?))
+           (else (parse-statement pre cur-tok 'assign-or-call getter id-ok? ctor? super-seen?))))
+        ;Intermediate
+        ((assign-or-call)
+         (case kind
+           ((EOF) (parse-error "Expected remainder of assignment or call" ps pe))
+           ((=)
+            ;From Assignment
+            (let ((next (getter)))
+              (if (eof? (get-tok next))
+                  (parse-error "Expected an expression after '=' for assignment" start end)
+                  (parse-statement cur-tok 
+                                   (parse-expression null next 'start getter #f #f) 'assign-end getter id-ok? ctor? super-seen?))))
+           ((PERIOD) 
+            (let ((next (getter)))
+              (cond
+                ((eof? (get-tok next)) (parse-error "Expected a name after '.'" start end))
+                ((id-token? (get-tok next)) 
+                 (parse-statement next (getter) 'assign-or-call getter id-ok? ctor? super-seen?))
+                (else
+                 (parse-error (format "Expected a name after '.', ~a is not a valid name" (format-out (get-tok next)))
+                              start (get-end next))))))
+           ((O_PAREN) (parse-statement cur-tok (parse-expression pre cur-tok 'method-call-args getter #f #t)
+                                       'end-exp getter id-ok? ctor? super-seen?))
+           (else 
+            (cond
+              ((and (advanced?) (eq? kind 'O_BRACKET))
+               (let* ((next (getter))
+                      (next-tok (get-tok next)))
+                 (if (eof? next-tok) 
+                     (parse-error "Expected an index for array" start end)
+                     (let* ((afterOB (parse-expression cur-tok next 'start getter #f #f))
+                            (afterOB-tok (get-tok afterOB)))
+                       (if (eof? afterOB-tok)
+                           (parse-error "Expected a ']' to end array index" start (get-end afterOB))
+                           (parse-statement afterOB (getter) 'assignment getter id-ok? ctor? super-seen?))))))
+              ((advanced?)
+               (parse-statement pre cur-tok 'unary-check getter id-ok? ctor? super-seen?))
+              (else
+               (parse-error (format "Expected assignment or method call, found ~a, which is not valid for a statement" out)
+                            start end))))))
+        ((assignment)
+         (case kind
+           ((EOF) (parse-error "Expected remainder of assignment" ps pe))
+           ((=)
+            ;From Assignment
+            (let ((next (getter)))
+              (if (eof? (get-tok next))
+                  (parse-error "Expected an expression after '=' for assignment" start end)
+                  (parse-statement cur-tok 
+                                   (parse-expression null next 'start getter #f #f) 'assign-end getter id-ok? ctor? super-seen?))))
+           ((O_BRACKET)
+            (let* ((next (getter))
+                   (next-tok (get-tok next)))
+              (if (eof? next-tok) 
+                  (parse-error "Expected an index for array" start end)
+                  (let* ((afterOB (parse-expression cur-tok next 'start getter #f #f))
+                         (afterOB-tok (get-tok afterOB)))
+                    (if (eof? afterOB-tok)
+                        (parse-error "Expected a ']' to end array index" start (get-end afterOB))
+                        (parse-statement afterOB (getter) 'assignment getter id-ok? ctor? super-seen?))))))
+           (else
+            (parse-error (format "Expected assignment, found ~a, which is not valid for a statement" out)
+                            start end))))
+        ;Intermediate - from Assignment, error messages changed
+        ((assign-end)
+         (cond
+           ((eof? tok) (parse-error "Expected a ';' to end assignment" ps pe))
+           ((semi-colon? tok) (getter))
+           (else (parse-error (format "Expected a ';' to end assignment, found ~a" out) start end))))
+        ((unary-check)
+         (let ((pre-out (token-value (get-tok pre))))
+           (case kind
+             ((EOF) (parse-error "Expected remainder of statement" ps pe))
+             ((++ --) 
+              (let* ((next (getter))
+                     (next-tok (get-tok next)))
+                (cond
+                  ((eof? next-tok) 
+                   (parse-error (format "Expected a ';' to end ~a~a" pre-out kind) ps end))
+                ((semi-colon? next-tok) (getter))
+                (else
+                 (parse-error (format "Expected a ';' to end ~a~a, found ~a" pre-out kind (format-out next-tok))
+                              ps (get-end next))))))
+             (else (parse-error (format "Expected a statement ~a ~a is not the valid start of a statement"
+                                        pre-out out) ps end)))))
+        ;Intermediate
+        ((end-exp)
+         (case kind
+           ((EOF) (parse-error "Expected ';' or rest of statement" ps pe))
+           ((PERIOD)
+            (let ((next (getter)))
+              (cond
+                ((id-token? (get-tok next)) (parse-statement next (getter) 'assign-or-call getter id-ok? ctor? super-seen?))
+                (else 
+                 (parse-error (format "Expected a name after '.', found ~a" (format-out (get-tok next)))
+                              ps (get-end next))))))
+           ((SEMI_COLON) (getter))
+           (else 
+            (parse-error (format "Expected ';' or rest of statement, found ~a" out) ps end))))
+        ;Intermediate
+        ((c-brace)
+         (case kind
+           ((EOF) (parse-error "Expected a '}' to close '{'" ps pe))
+           ((C_BRACE) (getter))
+           (else (parse-error (format "Expected a '}' to close open '{', found ~a" out) start end))))
+        ;Intermediate
+        ((local)
+         (unless id-ok?
+           (parse-error 
+            (if (advanced?)
+                "Found apparent variable declaration directly in an 'if', 'for', 'while', or 'do'. Varaibles declarations must be in blocks"
+                "Found apparent variable declaration directly in an 'if', variable declarations must be in blocks")
+            ps end))
+         (case kind
+           ((EOF) (parse-error "Variable declaration requires a name" start end))
+           ((IDENTIFIER) 
+            (let* ((next (getter))
+                   (n-tok (get-tok next))
+                   (n-out (format-out n-tok))
+                   (ne (get-end next)))
+              (cond
+                ((eof? n-tok) (parse-error "Variable declaration has not completed" start end))
+                ;Just ended a local field
+                ((semi-colon? n-tok) (getter))
+                ((comma? n-tok) (parse-statement next (getter) 'local-list getter #t ctor? super-seen?))
+                ((teaching-assignment-operator? n-tok)
+                 (let ((assign-exp (getter)))
+                   (cond
+                     ((eof? (get-tok assign-exp))
+                      (parse-error (format "Expected an expression to bind to ~a" (token-value tok)) start end))
+                     ((and (advanced?) (o-brace? (get-tok assign-exp)))
+                      (parse-statement next (parse-array-init assign-exp (getter) 'start getter) 'local-init-end getter #t ctor?
+                                       super-seen?))
+                     (else
+                      (parse-statement next (parse-expression null assign-exp 'start getter #f #f) 
+                                       'local-init-end getter #t ctor? super-seen?)))))
+                ((id-token? n-tok)
+                 (parse-error (format "Variables must be separated by commas, ~a not allowed" n-out) start ne))
+                (else (parse-error (format "Expected ';' or more variables, found ~a" n-out) start ne)))))
+           (else 
+            (if (and (advanced?) (o-bracket? tok))
+                (let* ((next (getter))
+                       (n-tok (get-tok next)))
+                  (cond
+                    ((c-bracket? n-tok)
+                     (parse-statement next (getter) 'local getter id-ok? ctor? super-seen?))
+                    ((o-bracket? n-tok)
+                     (parse-error "Array types may not have [[. A closing ] is necessary before opening a new [" start 
+                                  (get-end next)))
+                    (else (parse-error (format "Array types are of form type[]. ~a is not allowed" (format-out n-tok))
+                                       start (get-end next)))))
+                (parse-error 
+                 (if (keyword? tok)
+                     (format "Expected a name for this variable, cannot be named reserved word ~a" kind)
+                     (format "Expected a name for this variable, found ~a" out)) start end)))))
+        ;Intermediate
+        ((local-list)
+         (case kind
+           ((EOF) (parse-error "Expected an additional variable after comma" ps pe))
+           ((IDENTIFIER)
+            (let* ((next (getter))
+                   (n-tok (get-tok next))
+                   (n-out (format-out n-tok))
+                   (ne (get-end next)))
+              (cond
+                ((eof? n-tok) (parse-error "Variable is not complete" start end))
+                ((semi-colon? n-tok) (getter))
+                ((comma? n-tok) (parse-statement next (getter) 'local-list getter id-ok? ctor? super-seen?))
+                ((teaching-assignment-operator? n-tok)
+                 (let ((assign-exp (getter)))
+                   (if (eof? (get-tok assign-exp))
+                       (parse-error (format "Expected an expression to bind to ~a" (token-value tok)) start end)
+                       (parse-statement next (parse-expression null assign-exp 'start getter #f #f) 
+                                        'local-init-end getter id-ok? ctor? super-seen?))))
+                ((id-token? n-tok)
+                 (parse-error (format "Variables must be separated by commas, ~a not allowed" n-out) start ne))
+                (else (parse-error (format "Expected ';' or more variables, found ~a" n-out) start ne)))))
+           (else
+            (parse-error
+             (if (keyword? tok)
+                 (format "Expected a name for this variable, cannot be named reseved word ~a" kind)
+                 (format "Expected a name for this variable, found ~a" out)) start end))))
+        ;Intermediate
+        ((local-init-end)
+         (case kind
+           ((EOF) (parse-error "Expected a ';' or ',' after variable" ps pe))
+           ((COMMA) (parse-statement cur-tok (getter) 'local-list getter id-ok? ctor? super-seen?))
+           ((SEMI_COLON) (getter))
+           ((IDENTIFIER) (parse-error (format "Variables must be separated by commas, ~a not allowed" out) start end))
+           (else (parse-error (format "Expected a ';' to end variable, or more variables, found ~a" out) start end))))
+        ;Advanced
+        ((for) 
+         (case kind
+           ((EOF) (parse-error "Expected a '(' to begin 'for'" ps pe))
+           ((O_PAREN) 
+            (parse-statement cur-tok (parse-for cur-tok (getter) 'start getter ctor? super-seen?)
+                             'start getter #f ctor? super-seen?))
+           (else
+            (parse-error (format "Expected a '(' to begin 'for'. Found ~a which is not allowed" out) start end))))
+        ;Advanced
+        ((do)
+         (case kind
+           ((EOF) (parse-error "Expeceted a statement and condition for 'do'" ps pe))
+           (else (parse-statement pre (parse-statement pre cur-tok 'start getter #f ctor? super-seen?) 
+                                  'do-while getter id-ok? ctor? super-seen?))))
+        ;Advanced
+        ((do-while)
+         (case kind
+           ((EOF) (parse-error "Expected 'while' and condition for 'do'" ps pe))
+           ((while)
+            (let* ((next (getter))
+                   (next-tok (get-tok next)))
+              (cond
+                ((eof? next-tok) 
+                 (parse-error "Expected a condition beginning with '(' for 'while' portion of 'do'" ps end))
+                ((o-paren? next-tok)
+                 (let* ((afterO (getter))
+                        (afterO-tok (get-tok afterO)))
+                   (cond
+                     ((eof? afterO-tok) 
+                      (parse-error "Expected a condition expression after '('" (get-start next) (get-end next)))
+                     ((c-paren? afterO-tok) (getter))
+                     (else
+                      (parse-statement afterO (parse-expression null afterO 'start getter #f #f) 'do-while-close
+                                       getter id-ok? ctor? super-seen?)))))
+                (else
+                 (parse-error 
+                  (format "Expected a condition beginning with '(' for 'while' portion of 'do'. Found ~a" 
+                          (format-out next-tok)) start (get-end next))))))
+           (else
+            (parse-error (format "Expected 'while' for 'do'. Found ~a which is not allowed here" out) start end))))
+        ;Advanced
+        ((do-while-close)
+         (case kind
+           ((EOF) (parse-error "Expected ')' to close condition of 'do'" ps pe))
+           ((C_PAREN) 
+            (let ((next (getter)))
+              (cond
+                ((eof? (get-tok next)) (parse-error "Expected ';' to close 'do'" ps end))
+                ((semi-colon? (get-tok next)) (getter))
+                (else 
+                 (parse-error (format "Expected ';' to end 'do'. Found ~a which is not allowed" (format-out (get-tok next)))
+                                      (get-start next) (get-end next))))))
+           (else
+            (parse-error (format "Expected ')' to close condition of 'do'. Found ~a which is not allowed" out) ps end))))                  
+        ;Advanced
+        ((while) 
+         (case kind
+           ((EOF) (parse-error "Expected a '(' to begin while condition" ps pe))
+           ((O_PAREN)
+            (let* ((next (getter))
+                   (next-tok (get-tok next)))
+              (cond
+                ((eof? next-tok) (parse-error "Expected a ')' or an expression for while condition" ps end))
+                ((c-paren? next-tok)
+                 (parse-statement next (getter) 'start getter #f ctor? super-seen?))
+                (else
+                 (parse-statement cur-tok (parse-expression null next 'start getter #f #f) 
+                                  'while-close getter id-ok? ctor? super-seen?)))))
+           (else (parse-error (format "Expected a '(' to begin while condition, found ~a" out) ps end))))
+        ;Advanced
+        ((while-close)
+         (case kind
+           ((EOF) (parse-error "Expected a ')' to end while condition" ps pe))
+           ((C_PAREN) (parse-statement cur-tok (getter) 'start getter #f ctor? super-seen?))
+           (else (parse-error (format "Expected a ')' to end while condition, found ~a" out) ps end))))
+        ;Advanced
+        ((break-continue)
+         (case kind
+           ((EOF) (parse-error "Expected a ';'" ps pe))
+           ((SEMI_COLON) (getter))
+           (else (parse-error (format "Expected a ';' to end ~a. Found ~a which is not allowed here" 
+                                      (token-name (get-tok pre)) out)
+                              ps end))))
+        )))
+  
+  ;parse-for: token token state (->token) bool bool -> token
+  (define (parse-for pre cur-tok state getter ctor? super-seen?)
+    (let* ((tok (get-tok cur-tok))
+           (kind (get-token-name tok))
+           (out (format-out tok))
+           (start (get-start cur-tok))
+           (end (get-end cur-tok))
+           (ps (if (null? pre) null (get-start pre)))
+           (pe (if (null? pre) null (get-end pre))))
+;      (printf "parse-for: state ~a pre ~a cur-tok ~a~n" state pre cur-tok)
+      (case state
+        ((start)
+         (cond
+           ((prim-type? tok) 
+            (parse-for pre 
+                       (parse-statement cur-tok (getter) 'local getter #t ctor? super-seen?)
+                       'past-inits getter ctor? super-seen?))
+           ((id-token? tok) 
+            (parse-for pre cur-tok 'init-or-expr getter ctor? super-seen?))
+           ((semi-colon? tok)
+            (parse-for cur-tok (getter) 'past-inits getter ctor? super-seen?))
+           (else (parse-for pre 
+                            (parse-expression pre cur-tok 'start getter #f #f)
+                            'statement-expr-first getter ctor? super-seen?))))
+        ((init-or-exp)
+         (case kind
+           ((EOF) (parse-error "Expected remainder of 'for'" ps pe))
+           ((PERIOD) 
+            (parse-for pre (parse-name (getter) getter #f) 'init-or-exp getter ctor? super-seen?))
+           ((IDENTIFIER)
+            (parse-for pre (parse-statement pre cur-tok 'local getter #t ctor? super-seen?) 
+                       'past-inits getter ctor? super-seen?))
+           (else
+            (parse-for pre (parse-expression pre cur-tok 'start getter #f #f) 
+                       'statement-expr-first getter ctor? super-seen?))))
+        ((statement-expr-first)
+         (case kind
+           ((EOF) (parse-error "Expected remainder of 'for'" ps pe))
+           ((COMMA) (parse-for cur-tok (parse-expression cur-tok (getter) 'start getter #f #f) 'statement-expr-first 
+                               getter ctor? super-seen?))
+           ((SEMI_COLON)
+            (parse-for cur-tok (getter) 'past-inits getter ctor? super-seen?))
+           (else
+            (parse-error (format "Expected a ',' or ';' for list of statement expressions in 'for'. Found ~a" out) 
+                         start end))))
+        ((past-inits)
+         (case kind
+           ((EOF) (parse-error "Expected remainder of 'for'" ps pe))
+           ((SEMI_COLON)
+            (parse-for cur-tok (getter) 'past-condition getter ctor? super-seen?))
+           (else
+            (let ((next (getter)))
+              (cond 
+                ((eof? (get-tok next)) (parse-error "Expected the rest of 'for'" start end))
+                ((semi-colon? (get-tok next)) (parse-for cur-tok next 'end-condition getter 
+                                                         ctor? super-seen?))
+                (else (parse-for cur-tok (parse-expression cur-tok next 'start getter #f #f) 
+                                 'end-condition getter ctor? super-seen?)))))))
+        ((end-condition)
+         (case kind
+           ((EOF) (parse-error "Expected a ';' to end the condition portion of 'for', and rest of 'for'." ps pe))
+           ((SEMI_COLON) (parse-for cur-tok (getter) 'past-condition getter ctor? super-seen?))
+           (else
+            (parse-error (format "Expected a ';' to end the condition portion of 'for', found ~a" out) start end))))
+        ((past-condition)
+         (case kind
+           ((EOF) (parse-error "Expected a ')' to end the pre-statement portion of 'for'" ps pe))
+           ((C_PAREN) (getter))
+           (else
+            (parse-for pre (parse-expression pre cur-tok 'start getter #f #f)
+                       'statement-expr-snd getter ctor? super-seen?))))
+        ((statement-expr-snd)
+         (case kind
+           ((EOF) (parse-error "Expected a ')' to end the pre-statement portion of 'for'" ps pe))
+           ((C_PAREN) (getter))
+           ((COMMA)
+            (let ((next (getter)))
+              (if (eof? (get-tok next))
+                  (parse-error "Expected an expression after ','" start end)
+                  (parse-for cur-tok (parse-expression cur-tok next 'start getter #f #f)
+                             'statement-expr-snd getter ctor? super-seen?))))
+           (else (parse-error (format "Expected a ')' or a ','. Found ~a which is not allowed" out) start end))))
+        )))
+                 
+  ;parse-expression: token token state (->token) bool bool -> token
+  (define (parse-expression pre cur-tok state getter statement-ok? stmt-exp?)
+    ;(printf "parse-expression state ~a pre ~a cur-tok ~a statement-ok? ~a stmt-exp? ~a ~n" 
+    ;        state pre cur-tok statement-ok? stmt-exp?)
+    (let* ((tok (get-tok cur-tok))
+           (kind (get-token-name tok))
+           (out (format-out tok))
+           (start (get-start cur-tok))
+           (end (get-end cur-tok))
+           (ps (if (null? pre) null (get-start pre)))
+           (pe (if (null? pre) null (get-end pre))))
+      (case state
+        ((start)
+         (case kind
+           ((EOF) (parse-error "Expected an expression" ps pe))
+           ((~ ! -) (parse-expression cur-tok 
+                                      (parse-expression cur-tok (getter) 'start getter #f #f) 
+                                      'op-or-end getter statement-ok? stmt-exp?))
+           ((+)
+            (if (or (advanced?) (intermediate?))
+                (parse-expression cur-tok (parse-expression cur-tok (getter) 'start getter #f stmt-exp?) 
+                                  'op-or-end getter statement-ok? stmt-exp?)
+                (parse-error "Expected an expression, + cannot begin an expression" start end)))
+           ;Advanced
+           ((++ --)
+            (if (advanced?)
+                (parse-expression cur-tok 
+                                  (parse-expression cur-tok (getter) 'start getter #f #f)
+                                  'dot-op-or-end getter statement-ok? stmt-exp?)
+                (parse-error (format "Expected an expression, ~a is not the valid beginning of an expression" out)
+                             start end)))
+           ((NULL_LIT) 
+            (if (or (advanced?) (intermediate?))
+                (parse-expression cur-tok (getter) 'dot-op-or-end getter statement-ok? stmt-exp?)
+                (parse-error "Expected an expression. null may not be used here" start end)))
+           ((TRUE_LIT FALSE_LIT STRING_LIT CHAR_LIT INTEGER_LIT 
+                      LONG_LIT FLOAT_LIT DOUBLE_LIT this super)
+            (parse-expression cur-tok (getter) 'dot-op-or-end getter statement-ok? stmt-exp?))
+           ((O_PAREN)
+            (if (or (advanced?) (intermediate?))
+                (parse-expression cur-tok (getter) 'cast-or-parened getter statement-ok? stmt-exp?)
+                (parse-expression cur-tok (parse-expression cur-tok (getter) 'start getter #f #f) 
+                                  'c-paren getter statement-ok? stmt-exp?)))
+           ((new) (parse-expression cur-tok (getter) 'alloc-start getter statement-ok? stmt-exp?))
+           ((IDENTIFIER) (parse-expression cur-tok (getter) 'name getter statement-ok? stmt-exp?))
+           ((STRING_ERROR)
+            (if (eq? 'STRING_NEWLINE (get-token-name (caddr (token-value tok))))
+                (parse-error (format "A string must be contained all on one line, and end in '~a'" #\") start end)
+                (parse-error (format "String must end with '~a', which is not found" #\") start end)))
+           (else 
+            (parse-error (format "Expected an expression, ~a is not the valid beginning of an expression" out) start end))))
+        ;Advanced
+        ((op-or-end)
+         (if stmt-exp?
+             (cond
+               ((and (advanced?) (unary-end? tok)) (getter))
+               (else cur-tok))
+             (cond
+               ((bin-operator? tok) (parse-expression cur-tok (getter) 'start getter #f stmt-exp?))
+               ((and (advanced?) (unary-end? tok)) 
+                (parse-expression cur-tok (getter) 'op-or-end getter statement-ok? stmt-exp?))
+               ((and (advanced?) (if-exp? tok))
+                (parse-expression cur-tok (parse-expression cur-tok (getter) 'start getter #f stmt-exp?) 
+                                  'if-exp-colon getter #f stmt-exp?))
+               ((and (advanced?) (o-bracket? tok)) 
+                (parse-expression cur-tok (getter) 'array-acc getter statement-ok? stmt-exp?))
+               ((and (advanced?) (instanceof-token? tok)) 
+                (parse-expression cur-tok (getter) 'instanceof getter #f stmt-exp?))
+               (else cur-tok))))
+        ((dot-op-or-end)
+         (cond
+           ((dot? tok) 
+            (let* ((next (getter))
+                   (next-tok (get-tok next))
+                   (name (get-token-name next-tok))
+                   (ns (get-start next))
+                   (ne (get-end next)))
+              (cond 
+                ((id-token? next-tok)
+                 (let ((afterID (getter)))
+                   (cond
+                     ((o-paren? (get-tok afterID))
+                      (parse-expression next afterID 'method-call-args getter statement-ok? stmt-exp?))
+                     ((teaching-assignment-operator? (get-tok afterID))
+                      (parse-expression next (parse-expression afterID (getter) 'start getter #f #f)
+                                        'assign-end getter statement-ok? stmt-exp?))
+                     (else (parse-expression next afterID 'dot-op-or-end getter statement-ok? stmt-exp?)))))
+                ((keyword? next-tok) 
+                 (parse-error (format "Expected a method name, reserved name ~a may not be a method name" name) ns ne))
+                (else (parse-error (format "Expected a method name, found ~a" (format-out next-tok)) ns ne)))))
+           (stmt-exp? (parse-expression pre cur-tok 'op-or-end getter #f stmt-exp?))
+           ((bin-operator? tok) (parse-expression cur-tok (getter) 'start getter #f stmt-exp?))
+           ;Advanced
+             ((and (advanced?) (unary-end? tok)) (parse-expression cur-tok (getter) 'op-or-end getter statement-ok? stmt-exp?))
+             ((and (advanced?) (if-exp? tok))
+              (parse-expression cur-tok (parse-expression cur-tok (getter) 'start getter #f #f) 'if-exp-colon getter #f stmt-exp?))
+             ((and (advanced?) (o-bracket? tok)) (parse-expression cur-tok (getter) 'array-acc getter statement-ok? stmt-exp?))
+             ((and (advanced?) (instanceof-token? tok)) (parse-expression cur-tok (getter) 'instanceof getter #f stmt-exp?))
+             (else cur-tok)))
+        ;Advanced
+        ((array-acc)
+         (cond
+           ((eof? tok) (parse-error "Expected expression for accessing array" start end))
+           ((c-bracket? tok) 
+            (parse-error "Expected an expression for accessing array, inbetween [ and ]" ps end))
+           (else (parse-expression pre 
+                                   (parse-expression pre cur-tok 'start getter #f #f) 
+                                   'c-bracket getter statement-ok? stmt-exp?))))
+        ;Advanced
+        ((c-bracket)
+         (case kind
+           ((EOF) (parse-error "Expected ] to end array access" ps pe))
+           ((C_BRACKET) 
+            (let ((next (getter)))
+              (if (teaching-assignment-operator? (get-tok next))
+                  (parse-expression next (parse-expression next (getter) 'start getter #f #f) 
+                                    'assign-end getter statement-ok? stmt-exp?)
+                  (parse-expression cur-tok next 'dot-op-or-end getter statement-ok? stmt-exp?))))
+           (else (parse-error (format "Expected ] to end array access. Found ~a" out) ps end))))
+        ;Advanced
+        ((c-bracket-empty-ok)
+         (case kind
+           ((EOF) (parse-error "Expected ] to end array size specification" ps pe))
+           ((C_BRACKET)
+            (let ((next (getter)))
+              (if (o-bracket? (get-tok next))
+                  (let ((afterOB (getter)))
+                    (if (c-bracket? (get-tok afterOB))
+                        (parse-expression next afterOB 'c-bracket-empty getter statement-ok? stmt-exp?)
+                        (parse-expression next (parse-expression next afterOB 'start getter #f stmt-exp?) 
+                                          'c-bracket-empty-ok getter statement-ok? stmt-exp?)))
+                  (parse-expression cur-tok next 'dot-op-or-end getter statement-ok? stmt-exp?))))
+           (else
+            (parse-error (format "Expected ] to end array size specification. Found ~a" out) ps end))))
+        ;Advanced
+        ((c-bracket-empty)
+         (case kind
+           ((EOF) (parse-error "Expected ] to end array specification" ps pe))
+           ((C_BRACKET) 
+            (let ((next (getter)))
+              (if (o-bracket? (get-tok next))
+                  (parse-expression next (getter) 'c-bracket-empty getter statement-ok? stmt-exp?)
+                  (parse-expression cur-tok next 'dot-op-or-end getter statement-ok? stmt-exp?))))
+           (else (parse-error (format "Expected ] to end array specification. Found ~a" out) ps end))))
+        ;Intermediate
+        ((cast-or-parened)
+         (cond
+           ((eof? tok) (parse-error "Expected a name or expression and a )" ps pe))
+           ((prim-type? tok) (parse-expression pre (getter) 'cast getter statement-ok? stmt-exp?))
+           ((id-token? tok) (parse-expression pre (getter) 'cast-or-parened-close getter statement-ok? stmt-exp?))
+           (else (parse-expression pre (parse-expression pre cur-tok 'start getter #f #f) 
+                                   'c-paren getter statement-ok? stmt-exp?))))
+        ;Intermediate
+        ((cast)
+         (cond
+           ((eof? tok) (parse-error "cast must have close paren and additional expression" ps pe))
+           ((c-paren? tok) (parse-expression cur-tok (getter) 'start getter #f stmt-exp?))
+           ((and (advanced?) (o-bracket? tok))
+            (let ((next (getter)))
+              (cond
+                ((eof? (get-tok next)) (parse-error "cast to array must have ]" start end))
+                ((c-bracket? (get-tok next)) (parse-expression next (getter) 'cast getter statement-ok? stmt-exp?))
+                (else (parse-error (format "cast to array must have ]. ~a is not allowed" (format-out (get-tok next)))
+                                   start (get-end next))))))
+           (else (parse-error (format "cast must have close paren, found ~a instead" out) ps end))))
+        ;Intermediate
+        ((cast-or-parened-close)
+         (cond
+           ((eof? tok) (parse-error "Expected a ')'" ps pe))
+           ((c-paren? tok)
+            (let* ((next (getter))
+                   (next-tok (get-tok next)))
+              (case (get-token-name next-tok)
+                ((~ ! - + TRUE_LIT FALSE_LIT STRING_LIT CHAR_LIT INTEGER_LIT 
+                      LONG_LIT FLOAT_LIT DOUBLE_LIT this O_PAREN new IDENTIFIER super)
+                 (parse-expression cur-tok next 'start getter #f stmt-exp?))
+                ((NULL_LIT)
+                 (if (or (advanced?) (intermediate?))
+                     (parse-expression cur-tok next 'start getter #f stmt-exp?)
+                     (parse-expression cur-tok next 'dot-op-or-end getter #f stmt-exp?)))
+                (else (parse-expression cur-tok next 'dot-op-or-end getter #f stmt-exp?)))))
+           ((and (advanced?) (o-bracket? tok))
+            (let* ((next (getter))
+                   (next-tok (get-tok next)))
+              (cond
+                ((eof? (get-tok next)) 
+                 (parse-error "cast to array must have ], array access must have expression" start end))
+                ((c-bracket? (get-tok next)) (parse-expression next (getter) 'cast getter statement-ok? stmt-exp?))
+                (else (parse-expression cur-tok 
+                                        (parse-expression cur-tok next 'array-acc getter #f stmt-exp?)
+                                        'c-paren getter statement-ok? stmt-exp?)))))
+           (else (parse-expression pre (parse-expression pre cur-tok 'name getter #f #f) 'c-paren getter statement-ok? stmt-exp?))))
+;           (else (parse-error (format "Expected a ')', found ~a" out) ps end))))
+        ((c-paren)
+         (cond
+           ((eof? tok) (parse-error "Expected a )" ps pe))
+           ((c-paren? tok) (parse-expression cur-tok (getter) 'dot-op-or-end getter statement-ok? stmt-exp?))
+           (else (parse-error (format "Expression in parens must have an operator or a close paren, found ~a instead" out) ps end))))
+        ;Advanced
+        ((instanceof)
+         (cond
+           ((eof? tok) (parse-error "Expected a type for instanceof" ps pe))
+           ((id-token? tok)
+            (let ((next (getter)))
+              (if (dot? (get-tok next))
+                  (parse-expression next (parse-name (getter) getter #f) 'instanceof-array getter statement-ok? stmt-exp?)
+                  (parse-expression cur-tok next 'op-or-end getter statement-ok? stmt-exp?))))
+           ((prim-type? tok) (parse-expression cur-tok (getter) 'instanceof-array getter statement-ok? stmt-exp?))
+           ((keyword? tok) 
+            (parse-error (format "Expected a type for instanceof comparison, found ~a which is not the name of a type" out) 
+                         start end)) 
+           (else (parse-error (format "Expected a type for instanceof comparison. Found ~a" out) start end))))
+        ;Advanced
+        ((instanceof-array)
+         (case kind
+           ((O_BRACKET) 
+            (let ((next (getter)))
+              (if (c-bracket? (get-tok next))
+                  (parse-expression next (getter) 'instanceof-array getter statement-ok? stmt-exp?)
+                  (parse-error (format "Array types are of the form type[], expected ] found ~a" 
+                                       (format-out (get-tok next)))
+                               start (get-end next)))))
+           (else (parse-expression pre cur-tok 'op-or-end getter statement-ok? stmt-exp?))))
+        ;Advanced
+        ((if-exp-colon)
+         (cond
+           ((eof? tok) (parse-error "Expected a :" ps pe))
+           ((colon? tok) 
+            (parse-expression cur-tok (parse-expression cur-tok (getter) 'start getter #f #f)
+                              'op-or-end getter statement-ok? stmt-exp?))
+           (else (parse-error (format "Expected a : found ~a" out) start end))))
+        ((alloc-start)
+         (cond
+           ((eof? tok) 
+            (parse-error (if (advanced?)
+                             "Expected a class name or primitive type for allocation"
+                             "Expected a class name for allocation") ps pe))
+           ((id-token? tok)
+            (let* ((next (getter))
+                   (next-tok (get-tok next)))
+              (cond
+                ((eof? next-tok) 
+                 (if (advanced?)
+                     (parse-error "Expected constructor arguments for class allocation or size for array" start end)
+                     (parse-error "Expected constructor arguments for class allocation" start end)))
+                ;Advanced
+                ((dot? next-tok)
+                 (cond
+                   ((beginner?)
+                    (parse-error "Expected (argument, ...) for an object creation, '.' may not appear here"
+                                 (get-start next) (get-end next)))
+                   ((advanced?)
+                    (parse-expression cur-tok (parse-name (getter) getter #f) 'alloc-open getter statement-ok? stmt-exp?))
+                   (else
+                    (parse-expression cur-tok (parse-name (getter) getter #f) 'class-args-start getter statement-ok? stmt-exp?))))
+                ((o-paren? next-tok) (parse-expression cur-tok next 'class-args-start getter statement-ok? stmt-exp?))
+                ;Advanced
+                ((and (advanced?) (o-bracket? next-tok))
+                 (parse-expression next (getter) 'array-size getter statement-ok? stmt-exp?))
+                ((c-paren? next-tok)
+                 (parse-error (format "Expected ( to begin constructor arguments for ~a" out) (get-start pre) end))
+                ((open-separator? next-tok) 
+                 (parse-error (format 
+                               (if (advanced?)
+                                   "Expected ( to begin constructor arguments, or [ to begin array size, found ~a"
+                                   "Expected ( to begin constructor arguments, found ~a") (format-out next-tok))
+                              (get-start next) (get-end next)))
+                (else 
+                 ;Advanced
+                 (parse-error
+                  (format (if (advanced?)
+                              "Expected constructor arguments in parens or array size in []s, found ~a"
+                              "Expected constructor arguments in parens, found ~a")
+                          (format-out next-tok)) (get-start pre) (get-end next))))))
+           ;Advanced
+           ((and (advanced?) (prim-type? tok))
+            (let* ((next (getter))
+                   (next-tok (get-tok next)))
+              (cond
+                ((eof? next-tok) (parse-error "Expected a size for the array" start end))
+                ((o-bracket? next-tok)
+                 (parse-expression next (getter) 'array-size getter statement-ok? stmt-exp?))
+                (else (parse-error (format "Expected a [ to begin array size, found ~a" (format-out next-tok))
+                                   start (get-end next))))))
+           ((keyword? tok)
+            ;Advanced
+            (parse-error (format
+                          (if (advanced?)
+                              "Expected a class name or primitive type, reserved word ~a is neither"
+                              "Expected a class name, reserved word ~a is not a class") kind) start end))
+           (else 
+            (parse-error (format (if (advanced?) 
+                                     "Expected a class name or primitive type, found ~a"
+                                     "Expected a class name, found ~a") out) start end))))
+        ;Advanced
+        ((alloc-open)
+         (case kind
+           ((EOF) (parse-error "Expected a ( to begin constructor arguments or [ to specify array size" ps pe))
+           ((O_PAREN) (parse-expression pre cur-tok 'class-args-start getter statement-ok? stmt-exp?))
+           ((O_BRACKET) (parse-expression cur-tok (getter) 'array-size getter statement-ok? stmt-exp?))
+           (else (parse-error (format "Expected a ( to begin constructor arguments or [ to specify size, found ~a" out)
+                              ps end))))
+        ;Advanced
+        ((array-size)
+         (case kind
+           ((EOF) (parse-error "Expected a size for the array" ps pe))
+           ((C_BRACKET) (parse-error "Array allocation must have an expresion for its size. Found ]" ps end))
+           (else 
+            (parse-expression pre (parse-expression pre cur-tok 'start getter #f stmt-exp?) 
+                              'c-bracket-empty-ok getter statement-ok? stmt-exp?))))
+        ((class-args-start)
+         (case kind
+           ((EOF) (parse-error "Expected constructor arguments starting with (" ps pe))
+           ((O_PAREN)
+            (let* ((next (getter))
+                   (next-tok (get-tok next)))
+              (cond
+                ((eof? next-tok) (parse-error "Expected constructor arguments or )" start end))
+                ((c-paren? next-tok) (parse-expression next (getter) 'dot-op-or-end getter statement-ok? stmt-exp?))
+                (else (parse-expression next (parse-expression cur-tok next 'start getter #f #f) 
+                                        'class-args getter statement-ok? stmt-exp?)))))
+           (else (parse-error (format "Expected constructor arguments, starting with (, found ~a" out) start end))))
+        ((class-args)
+         (case kind
+           ((EOF) (parse-error "Expected constructor arguments or )" ps pe))
+           ((C_PAREN) (parse-expression cur-tok (getter) 'dot-op-or-end getter statement-ok? stmt-exp?))
+           ((COMMA)
+            (let ((next (getter)))
+              (if (comma? (get-tok next))
+                  (parse-error "Found ',,' Only one comma is needed to separate arguments" start (get-end next))
+                  (parse-expression cur-tok (parse-expression cur-tok next 'start getter #f stmt-exp?) 
+                                    'class-args getter statement-ok? stmt-exp?))))
+           (else
+            (if (close-separator? tok)
+                (parse-error (format "Expected ) to close constructor arguments, found ~a" out) start end)
+                (parse-error (format "A ',' is required between expressions in a constructor call, found ~a" out) start end)))))
+        ((name)
+         (case kind
+           ((PERIOD) (parse-expression cur-tok (parse-name (getter) getter #f) 'name getter statement-ok? stmt-exp?))
+           ((O_PAREN) (parse-expression pre cur-tok 'method-call-args getter statement-ok? stmt-exp?))
+           ((=) (parse-expression cur-tok (parse-expression cur-tok (getter) 'start getter #f stmt-exp?) 
+                                  'assign-end getter statement-ok? stmt-exp?))
+           (else (parse-expression pre cur-tok 'op-or-end getter statement-ok? stmt-exp?))))
+        ((method-call-args)
+         (case kind
+           ((EOF) (parse-error "Expected method arguments starting with (" ps pe))
+           ((O_PAREN)
+            (let ((next-tok (getter)))
+              (cond
+                ((eof? (get-tok next-tok)) (parse-error "Expected method arguments or )" start end))
+                ((c-paren? (get-tok next-tok)) 
+                 (let ((after-c (getter)))
+                   (if (and statement-ok? (or (advanced?) (intermediate?) (semi-colon? (get-tok after-c))))
+                       (getter)
+                       (parse-expression next-tok after-c 'dot-op-or-end getter statement-ok? stmt-exp?))))
+                (else (parse-expression cur-tok (parse-expression cur-tok next-tok 'start getter #f stmt-exp?)
+                                        'method-args getter statement-ok? stmt-exp?)))))
+           (else (parse-error (format "Expected method arguments in parens, found ~a" out) start end))))
+        ((method-args)
+         (case kind
+           ((EOF) (parse-error "Expected method arguments or )" ps pe))
+           ((C_PAREN) 
+            (let ((after-c (getter)))
+              (if (and statement-ok? (or (advanced?) (intermediate?) (semi-colon? (get-tok after-c))))
+                  (getter)
+                  (parse-expression cur-tok after-c 'dot-op-or-end getter statement-ok? stmt-exp?))))
+           ((COMMA) 
+            (let ((next (getter)))
+              (if (comma? (get-tok next))
+                  (parse-error "Found ',,' Only one comma is needed to separate arguments" start (get-end next))
+                  (parse-expression cur-tok (parse-expression cur-tok next 'start getter #f stmt-exp?) 
+                                    'method-args getter statement-ok? stmt-exp?))))
+           (else 
+            (if (close-separator? tok)
+                (parse-error (format "Expected ) to close method arguments, found ~a" out) start end)
+                (parse-error (format "A ',' is required between expression in a method call, found ~a" out) start end)))))
+        ((assign-end)
+         (cond
+           ((and statement-ok? (semi-colon? tok)) (getter))
+           ((and statement-ok? (eof? tok)) 
+            (parse-error "Assignment must end with a ';'" ps end))
+           (statement-ok?
+            (parse-error (format "Assignment must end with a ';'. Found ~a" out) start end))
+           ((beginner?) (parse-error "Fields may not be set in this position, only expressions are permitted here" ps end))
+           (else (parse-error "Assignment is not permitted in this position. Only expressions are permitted here" ps end)))))))
+  )
+  
+ 
\ No newline at end of file
diff --git a/collects/profj/pre-installer.ss b/collects/profj/pre-installer.ss
new file mode 100644
index 0000000000..c356e9b48d
--- /dev/null
+++ b/collects/profj/pre-installer.ss
@@ -0,0 +1,30 @@
+(module pre-installer mzscheme
+  
+  ;copy-jinfos path (list string) -> void
+  ;Copies the given jinfos into the compiled directory of the given library
+  (define (copy-jinfos path files)
+    (let ((compiled-path (build-path path "compiled")))
+      (unless (directory-exists? compiled-path) (make-directory compiled-path))
+      (for-each (lambda (file)
+                  (let* ((f-path (build-path path file))
+                         (f-cpath (build-path compiled-path file))
+                         (copied? (file-exists? f-cpath)))
+                    (cond
+                      ((and copied? (file-older-than? f-cpath f-path))
+                       (delete-file f-cpath)
+                       (copy-file f-path f-cpath))
+                      ((not copied?) (copy-file f-path f-cpath)))))
+                files)))
+  
+  ;file-older-than? path path -> bool
+  ;Is file-a older than file-b?
+  (define (file-older-than? file-a file-b)
+    (< (file-or-directory-modify-seconds file-a)
+       (file-or-directory-modify-seconds file-b)))
+  
+  (define (pre-installer plthome)
+    (copy-jinfos (collection-path "profj" "libs" "java" "lang") '("Object.jinfo" "String.jinfo" "Throwable.jinfo"
+                                                                                 "Comparable.jinfo"))
+    (copy-jinfos (collection-path "profj" "libs" "java" "io") '("Serializable.jinfo")))
+  (provide pre-installer)
+  )
\ No newline at end of file
diff --git a/collects/profj/profj-pref.ss b/collects/profj/profj-pref.ss
new file mode 100644
index 0000000000..130508bad1
--- /dev/null
+++ b/collects/profj/profj-pref.ss
@@ -0,0 +1,31 @@
+(module profj-pref mzscheme
+  
+  (require (lib "file.ss")
+           (lib "list.ss"))
+  
+  (provide reset-classpath add-to-classpath get-classpath)
+
+  ;get-classpath: -> (list string)
+  (define (get-classpath)
+    (append (cons (build-path 'same)
+                  (get-preference 'projf:classpath (lambda () null)))
+            (map (lambda (p) (build-path p "profj" "libs"))
+                 (current-library-collection-paths))
+            (map (lambda (p) (build-path p "htdch"))
+                 (current-library-collection-paths))))
+  
+  ;reset-classpath: -> void
+  (define (reset-classpath)
+    (put-preferences `(profj:classpath) (list null)))
+  
+  ;add-to-classpath: string -> void
+  (define (add-to-classpath path)
+    (let ((old-classpath (get-preference 'profj:classpath (lambda () null))))
+      (put-preferences `(profj:classpath) (list (cons path old-classpath)))))
+  
+  ;remove-from-classpath: string -> void
+  (define (remove-from-classpath path)
+    (let ((old-classpath (get-preference 'profj:classpath (lambda () null))))
+      (put-preferences `(profj:classpath) (list (remove path old-classpath)))))
+  
+)
\ No newline at end of file
diff --git a/collects/profj/profj-testing.ss b/collects/profj/profj-testing.ss
new file mode 100644
index 0000000000..551a9c121a
--- /dev/null
+++ b/collects/profj/profj-testing.ss
@@ -0,0 +1,242 @@
+#cs
+(module profj-testing mzscheme
+  
+  (require (lib "compile.ss" "profj")
+           (lib "parameters.ss" "profj")
+           (lib "tool.ss" "profj")
+           (lib "class.ss"))
+  
+  (define interaction-errors (make-parameter 0))
+  (define execution-errors (make-parameter 0))
+  (define file-errors (make-parameter 0))
+  (define interaction-msgs (make-parameter null))
+  (define execution-msgs (make-parameter null))
+  (define file-msgs (make-parameter null))
+  (define expected-error-messages (make-parameter null))
+
+  (provide java-values-equal?)
+  (define (java-values-equal? v1 v2)
+    (java-equal? v1 v2 null null))
+  
+  ;java-equal?: 'a 'a (list 'a) (list 'a)-> bool
+  (define (java-equal? v1 v2 visited-v1 visited-v2)
+    (or (eq? v1 v2)
+        (already-seen? v1 v2 visited-v1 visited-v2)
+        (and (number? v1) (number? v2) (= v1 v2))
+        (cond
+          ((and (object? v1) (object? v2))
+           (cond
+             ((equal? "String" (send v1 my-name))
+              (and (equal? "String" (send v2 my-name))
+                   (equal? (send v1 get-mzscheme-string) (send v2 get-mzscheme-string))))
+             ((equal? "array" (send v1 my-name))
+              (and (equal? "array" (send v2 my-name))
+                   (= (send v1 length) (send v2 length))
+                   (let ((v1-vals (array->list v1))
+                         (v2-vals (array->list v2)))
+                   (andmap (lambda (x) x)
+                           (map java-equal? v1-vals v2-vals 
+                                (map (lambda (v) (cons v1 visited-v1)) v1-vals)
+                                (map (lambda (v) (cons v2 visited-v2)) v2-vals))))))
+             (else
+              (and (equal? (send v1 my-name) (send v2 my-name))
+                   (let ((v1-fields (send v1 field-values))
+                         (v2-fields (send v2 field-values)))
+                     (and (= (length v1-fields) (length v2-fields))
+                          (andmap (lambda (x) x) 
+                                  (map java-equal? v1-fields v2-fields 
+                                       (map (lambda (v) (cons v1 visited-v1)) v1-fields)
+                                       (map (lambda (v) (cons v2 visited-v2)) v2-fields)))))))))
+          ((and (not (object? v1)) (not (object? v2))) (equal? v1 v2))
+          (else #f))))
+  
+  ;array->list: java-array -> (list 'a)
+  (define (array->list v)
+    (letrec ((len (send v length))
+             (build-up
+              (lambda (c)
+                (if (= c len)
+                    null
+                    (cons (send v access c)
+                          (build-up (add1 c)))))))
+      (build-up 0)))
+  
+  
+  ;already-seen?: 'a 'a (list 'a) (list 'a)-> bool
+  (define (already-seen? v1 v2 visited-v1 visited-v2)
+    (cond
+      ((and (null? visited-v1) (null? visited-v2)) #f)
+      ((memq v1 visited-v1)
+       (let ((position-v1 (get-position v1 visited-v1 0)))
+         (eq? v2 (list-ref visited-v2 position-v1))))
+      (else #f)))
+  
+  ;get-position: 'a (list 'a) int -> int
+  (define (get-position v1 visited pos)
+    (if (eq? v1 (car visited))
+        pos
+        (get-position v1 (cdr visited) (add1 pos))))
+  
+  ;interact-internal: symbol (list string) (list evalable-value) string type-record -> void
+  (define (interact-internal level interacts vals msg type-recs)
+    (for-each (lambda (ent val)
+                (let ((st (open-input-string ent)))
+                  (with-handlers 
+                      ([exn?
+                        (lambda (exn)
+                          (cond 
+                            ((and (eq? val 'error) (report-expected-error-messages))
+                             (expected-error-messages (cons (cons msg (exn-message exn)) (expected-error-messages))))
+                            ((not (eq? val 'error))
+                             (interaction-errors (add1 (interaction-errors)))
+                             (interaction-msgs (cons
+                                                (format "Test ~a: Exception raised for ~a : ~a"
+                                                        msg ent (exn-message exn)) (interaction-msgs))))))])
+                    (let ((new-val (eval `(begin
+                                            (require (lib "class.ss")
+                                                     (prefix javaRuntime: (lib "runtime.scm" "profj" "libs" "java")))
+                                            ,(compile-interactions st st type-recs level)))))
+                      (unless (java-equal? (eval val) new-val null null)
+                        (interaction-errors (add1 (interaction-errors)))
+                        (interaction-msgs (cons (format "Test ~a: ~a evaluated to ~a instead of ~a"
+                                                        msg ent new-val val) (interaction-msgs))))))))
+              interacts vals))
+       
+  ;interact-test: symbol (list string) (list evalable-value) string |
+  ;             : string stymbol (list string) (list evalable-value) string -> void
+  (define interact-test
+    (case-lambda
+      [(level in val msg)
+       (interact-internal level in val msg (create-type-record))]
+      ((defn level in val msg)
+       (let* ((type-recs (create-type-record))
+              (def-st (open-input-string defn)))
+         (with-handlers
+             ([exn?
+               (lambda (exn)
+                 (interaction-errors (add1 (interaction-errors)))
+                 (interaction-msgs (cons (format "Test ~a: Exception raised in definition : ~a"
+                                                 msg (exn-message exn))
+                                         (interaction-msgs))))])
+           (execution? #t)
+           (eval-modules (compile-java 'port 'port level #f def-st def-st type-recs))
+           (interact-internal level in val msg type-recs))))))
+  
+  ;interact-test-java-expected: string symbol (list string) (list string) string -> void
+  (define (interact-test-java-expected defn level in val msg)
+    (let* ((type-recs (create-type-record))
+           (def-st (open-input-string defn)))
+      (with-handlers
+          ([exn?
+            (lambda (exn)
+              (interaction-errors (add1 (interaction-errors)))
+              (interaction-msgs (cons (format "Test ~a: Exception raised in definition : ~a"
+                                              msg (exn-message exn))
+                                      (interaction-msgs))))])
+        (execution? #t)
+        (eval-modules (compile-java 'port 'port level #f def-st def-st type-recs))
+        (let ((vals (map (lambda (ex-val)
+                           (let ((st (open-input-string ex-val)))
+                             (eval `(begin (require (lib "class.ss")
+                                                    (prefix javaRuntime: (lib "runtime.scm" "profj" "libs" "java")))
+                                           ,(compile-interactions st st type-recs level)))))
+                         val)))
+          (interact-internal level in vals msg type-recs)))))
+  
+  (define (execute-test defn level error? msg)
+    (let ((st (open-input-string defn)))
+      (with-handlers
+          ([exn?
+            (lambda (exn)
+              (cond
+                ((and error? (report-expected-error-messages))
+                 (expected-error-messages (cons (cons msg (exn-message exn)) (expected-error-messages))))
+                ((not error?)
+                 (execution-errors (add1 (execution-errors)))
+                 (execution-msgs (cons
+                                  (format "Test ~a : Exception-raised: ~a" msg (exn-message exn)) (execution-msgs))))))])
+        (eval-modules (compile-java 'port 'port level #f st st)))))
+  
+  ;run-test: symbol string (U string (list string)) (U string (list string)) -> (U (list (list symbol bool string)) (list ...))
+  (define (run-test level defn interact val)
+    (let* ((type-recs (create-type-record))
+           (def-st (open-input-string defn))
+           (check-vals 
+            (lambda (interact val)
+              (with-handlers
+                  ([exn?
+                    (lambda (exn)
+                      (list 'interact #f (exn-message exn)))])
+                (let* ((get-val (lambda (v-st v-pe)
+                                  (eval `(begin (require (lib "class.ss"))
+                                                (require (prefix javaRuntime: (lib "runtime.scm" "profj" "libs" "java")))
+                                                ,(compile-interactions v-st v-st type-recs level)))))
+                       (i-st (open-input-string interact))
+                       (v-st (open-input-string val))
+                       (i-pe (lambda () (open-input-string interact)))
+                       (v-pe (lambda () (open-input-string val)))
+                       (given-val (get-val i-st i-pe))
+                       (exp-val (get-val v-st v-pe)))
+                  (list 'interact (java-equal? given-val exp-val null null) (format-java given-val #t 'field null #f 0)))))))
+      (with-handlers
+          ([exn?
+            (lambda (exn)
+              (list 'defn #f (exn-message exn)))])
+        (execution? #t)
+        (eval-modules (compile-java 'port 'port level #f def-st def-st type-recs))
+        (cond
+          ((and (pair? interact) (pair? val))
+           (map check-vals interact val))
+          ((and (string? interact) (string? val))
+           (check-vals interact val))))))
+                  
+  (define (file-test file level error? msg)
+    (with-handlers
+        ([exn?
+          (lambda (exn) 
+            (unless error?
+              (file-errors (add1 (file-errors)))
+              (file-msgs (cons
+                          (format "Test ~a :Exception-raised: ~a" msg (exn-message exn)) (file-msgs)))))])
+      (eval-modules (compile-java 'file 'port level file #f #f))))
+  
+  (define (eval-modules modules)
+    (for-each eval 
+         (apply append
+                (map compilation-unit-code modules))))
+  
+  ;prepare-for-tests: String -> void
+  (define (prepare-for-tests lang-level)
+    (printf "Running tests for ~a~n" lang-level)
+    (interaction-errors 0)
+    (interaction-msgs null)
+    (execution-errors 0)
+    (execution-msgs null)
+    (file-errors 0)
+    (file-msgs null))
+  
+  (define report-expected-error-messages (make-parameter #f))
+  
+  ;report-test-results: -> void
+  (define (report-test-results)
+    (when (> (interaction-errors) 0)
+      (printf "~a Interaction errors occurred~n" (interaction-errors))
+      (for-each (lambda (m) (printf "~a~n" m)) (interaction-msgs))
+      (newline))
+    (when (> (execution-errors) 0)
+      (printf "~a Execution errors occurred~n" (execution-errors))
+      (for-each (lambda (m) (printf "~a~n" m)) (execution-msgs))
+      (newline))
+    (when (> (file-errors) 0)
+      (printf "~a file errors occurred~n" (file-errors))
+      (for-each (lambda (m) (printf "~a~n" m)) (file-msgs))
+      (newline))
+    (when (report-expected-error-messages)
+      (printf "Received these expected error messages:~n")
+      (for-each (lambda (m) (printf "Error for test ~a : ~a~n" (car m) (cdr m))) (expected-error-messages)))
+    (printf "Tests completed~n"))
+  
+  (provide interact-test execute-test interact-test-java-expected file-test run-test 
+           report-test-results prepare-for-tests report-expected-error-messages)
+  )
+        
\ No newline at end of file
diff --git a/collects/profj/restrictions.ss b/collects/profj/restrictions.ss
new file mode 100644
index 0000000000..dd62176d6f
--- /dev/null
+++ b/collects/profj/restrictions.ss
@@ -0,0 +1,79 @@
+#cs
+(module restrictions mzscheme
+  
+  (provide is-field-restricted? is-method-restricted? forbidden-lang-class? is-import-restricted?)
+  
+  (define disallowed-methods 
+    (list `("clone" ("Object" "java" "lang"))
+          `("finalize" ("Object" "java" "lang"))
+          `("getClass" ("Object" "java" "lang"))
+          `("notify" ("Object" "java" "lang"))
+          `("notifyAll" ("Object" "java" "lang"))
+          `("wait" ("Object" "java" "lang"))
+          
+          ))
+  
+  ;is-method-restricted?: string (list string) -> bool
+  (define (is-method-restricted? method class)
+    (member (list method class) disallowed-methods))
+  
+  (define disallowed-fields
+    (list `("TYPE" ("Boolean" "java" "lang"))
+          `("TYPE" ("Byte" "java" "lang"))
+          `("TYPE" ("Character" "java" "lang"))
+          `("TYPE" ("Double" "java" "lang"))
+          `("TYPE" ("Float" "java" "lang"))
+          `("TYPE" ("Integer" "java" "lang"))
+          `("TYPE" ("Long" "java" "lang"))
+          `("TYPE" ("Short" "java" "lang"))
+          
+          ))
+  
+  ;is-field-restricted: string (list string) -> bool
+  (define (is-field-restricted? field class)
+    (member (list field class) disallowed-fields))
+
+  (define (disallowed-imports level)
+    (let ((teaching-levels (list `("Class" "java" "lang")
+                                 `("ClassLoader" "java" "lang")
+                                 `("Compiler" "java" "lang")
+                                 `("InheritableThreadLocal" "java" "lang")
+                                 `("Package" "java" "lang")
+                                 `("Process" "java" "lang")
+                                 `("Runtime" "java" "lang")
+                                 `("RuntimePermission" "java" "lang")
+                                 `("SecurityManager" "java" "lang")
+                                 `("StackTraceElement" "java" "lang")
+                                 `("Thread" "java" "lang")
+                                 `("ThreadGroup" "java" "lang")
+                                 `("ThreadLocal" "java" "lang")
+                                 `("Throwable" "java" "lang")
+                                 `("Void" "java" "lang")
+                                 `("*" "java" "lang" "reflect")
+                                 `("*" "java" "lang" "ref")
+                                 `("*" "java" "applet")
+                                 
+                                 ))
+          (beginner&intermediate (list `("System" "java" "lang")
+                                        ;`("*" "java" "io")
+                                        ;`("*" "java" "util")
+                                        )))
+      (case level
+        ((beginner) (append beginner&intermediate
+                            teaching-levels))
+        ((intermediate) (append beginner&intermediate
+                                teaching-levels))
+        ((advanced) (append null
+                            teaching-levels))
+        ((full) null))))
+  
+  ;restricted-import? string (list string) symbol -> bool
+  (define (is-import-restricted? class path level)
+    (or (member (cons class path) (disallowed-imports level))
+        (member (cons "*" path) (disallowed-imports level))))
+  
+  ;forbidden-lang-class? string symbol -> bool
+  (define (forbidden-lang-class? class level)
+    (member (list class "java" "lang") (disallowed-imports level)))
+  
+  )
diff --git a/collects/profj/to-scheme.ss b/collects/profj/to-scheme.ss
new file mode 100644
index 0000000000..080080fe10
--- /dev/null
+++ b/collects/profj/to-scheme.ss
@@ -0,0 +1,2210 @@
+(module to-scheme mzscheme
+  (require "ast.ss"
+           "types.ss"
+           "parameters.ss"
+           (lib "class.ss")
+           (lib "list.ss"))
+  
+  (provide translate-program translate-interactions (struct compilation-unit (contains code locations depends)))
+  
+  ;(make-compilation-unit (list string) (list syntax) (list location) (list (list string)))
+  (define-struct compilation-unit (contains code locations depends) (make-inspector))
+  
+  ;File takes java AST as defined by ast.ss and produces
+  ;semantically (hopefully) equivalent scheme code
+  
+  ;NOTE! Abstract classes are treated no differently than any class.
+  
+  ;Parameters for information about each class
+  (define class-name (make-parameter #f))
+  (define loc (make-parameter #f))
+  (define interactions? (make-parameter #f))
+  (define class-override-table (make-parameter null))
+  (define parent-name (make-parameter "Object"))
+  (define module-name (make-parameter ""))
+  (define module-require (make-parameter ""))
+  
+  ;Parameters for inforamtion about the types
+  (define types (make-parameter null))
+  (define current-depth (make-parameter 0))
+  (define current-local-classes (make-parameter null))
+    
+  (define stx-for-original-property (read-syntax #f (open-input-string "original")))
+  (define (stx-for-source) stx-for-original-property)
+  (define (create-syntax oddness sexpression source)
+    (datum->syntax-object (or oddness (syntax-location) (stx-for-source)) sexpression source stx-for-original-property))
+  (define (make-syntax oddness sexpression source)
+    (datum->syntax-object (or oddness (syntax-location) (stx-for-source)) sexpression source))
+  
+  ;-------------------------------------------------------------------------------------------------------------
+  
+  ;Type abbreviation
+  
+  ;The value of this will vary based on information I have at a given time, 
+  ;as well as whether location is from source file or not
+  ;SrcList  => boolean
+  ;         |  (list symbol int)
+  ;         |  (list symbol int int int)
+  
+  
+  ;------------------------------------------------------------------------------------------------------------
+  ;Helper functions
+  ;Functions which are used throughout the transformation
+  
+  ;build-identifier: (U string symbol (list string)) -> symbol
+  (define (build-identifier name)
+    (cond
+      ((symbol? name) name)
+      ((string? name) (string->symbol name))
+      ;PROBLEM might not be best method
+      ((pair? name) (string->symbol (apply string-append (map (lambda (s) (string-append s ".")) name))))
+      (else 
+       (error 'build-identifier (format "Given ~s" name))
+       name)))
+  
+  ;build-static-name: string symbol -> string
+  (define (build-static-name name . args)
+    (format "~a-~a" (if (null? args) (class-name) (car args)) name))
+  
+  ;build-src: src -> SrcList
+  (define (build-src src) 
+    (if (not src)
+        src
+        (if (and (= (src-line src) 0)
+                 (= (src-col src) 0)
+                 (= (src-pos src) 0)
+                 (= (src-span src) 0))
+            #f
+            (list (or (src-file src) (loc)) (src-line src) (src-col src) (src-pos src) (src-span src)))))
+  
+  ;get-defualt-value: type-spec -> syntax
+  (define (get-default-value type)
+    (let ((name (type-spec-name type)))
+      (if (> (type-spec-dim type) 0)
+          (make-syntax #f 'null #f)
+          (cond
+            ((prim-numeric-type? name) (make-syntax #f 0 #f))
+            ((eq? 'char name) (make-syntax #f '#\space #f))
+            ((eq? 'boolean name) (make-syntax #f '#f #f))
+            (else (make-syntax #f 'null #f))))))
+  
+  ;create-get-name: string string? -> symbol
+  (define (create-get-name name . args)
+    (build-identifier (format "~a-~a-get" (if (null? args) (class-name) (car args))  name)))
+  
+  ;create-set-name: string string? -> symbol
+  (define (create-set-name name . args)
+    (build-identifier (format "~a-~a-set!" (if (null? args) (class-name) (car args)) name)))
+  
+  ;Methods to determine member restrictions
+  ;make-mod-test: symbol -> (list -> bool)
+  (define (make-mod-test acc) (lambda (m) (memq acc m)))
+  (define public? (make-mod-test 'public))
+  (define private? (make-mod-test 'private))
+  (define protected? (make-mod-test 'protected))
+  (define static? (make-mod-test 'static))
+  (define abstract? (make-mod-test 'abstract))
+  (define final? (make-mod-test 'final))
+  
+  ;get-class-name: (U name type-spec) -> syntax
+  (define (get-class-name name)
+    (if (type-spec? name)
+        (set! name (type-spec-name name)))
+    (if (null? (name-path name))
+        (translate-id (id-string (name-id name))
+                      (id-src (name-id name)))
+        (create-syntax #f
+                       (build-identifier (get-class-string name))
+                       (build-src (name-src name)))))
+  
+  ;get-class-string: name -> string
+  (define (get-class-string name)
+    (format "~a~a" (apply string-append (map (lambda (s)
+                                               (string-append s "."))
+                                             (map id-string (name-path name))))
+            (id-string (name-id name))))
+  
+  ;build-var-name: string -> string
+  (define (build-var-name id) (format "~a~~f" id))
+  
+  ;build-generic-name: string string -> string
+  (define (build-generic-name class name) (format "~a-~a~~generic" class name))
+  
+  ;build-method-name: string (list type) -> string
+  (define (mangle-method-name id types)
+    (letrec ((parm-name
+              (lambda (t)
+                (format "-~a"
+                        (cond
+                          ((symbol? t) t)
+                          ((ref-type? t) 
+                           (string-append (apply string-append (map (lambda (p) (string-append p "."))
+                                                                    (ref-type-path t)))
+                                          (ref-type-class/iface t)))
+                          ((array-type? t)
+                           (string-append (let ((s (parm-name (array-type-type t))))
+                                            (substring s 1 (string-length s)))
+                                          (format "~a" (array-type-dim t))))
+                          (else (error 'mangle-method-name (format "Internal Error: given unexptected type ~a" t))))))))
+      (format "~a~a" id (apply string-append (map parm-name types)))))
+  
+  ;constructor? string -> bool
+  (define (constructor? name) 
+    (equal? name (class-name)))
+  
+  ;build-constructor-name: string (list type) -> string
+  (define (build-constructor-name class-name args)
+    (mangle-method-name (format "~a-constructor" class-name) args))
+  
+  ;-------------------------------------------------------------------------------------------------------------------------
+  ;Translation
+  
+  ;translate-interactions: ast location type-records -> syntax
+  (define (translate-interactions prog location type-recs)
+    (loc location)
+    (interactions? #t)
+    (types type-recs)
+    (let ((reqs (send type-recs get-class-reqs))
+          (syn (cond 
+                 ((pair? prog)
+                  (send type-recs set-class-reqs null)
+                  (make-syntax #f 
+                               `(begin ,@(map (lambda (f)
+                                                (translate-interactions f location type-recs))
+                                              prog))
+                               #f))
+                 ((field? prog) 
+                  (translate-field `(private)
+                                   (field-type prog)
+                                   (field-name prog)
+                                   (and (var-init? prog) prog)
+                                   (if (var-init? prog)
+                                       (var-init-src prog)
+                                       (var-decl-src prog))
+                                   #f))
+                 ((statement? prog) (translate-statement prog type-recs))
+                 ((expr? prog) (translate-expression prog))
+                 (else 
+                  (error 'translate-interactions "Internal Error: translate-interactions given ~a" prog)))))
+      (if (null? reqs)
+          syn
+          (make-syntax #f
+                       `(begin (require ,@(remove-dup-syntax (translate-interact-require reqs type-recs)))
+                               ,syn)
+                       #f))))
+  
+  ;translate-program: package type-records -> (list compilation-unit) 
+  (define (translate-program program type-recs)
+    (types type-recs)
+    (interactions? #f)
+    (let* ((package-path (if (package-name program)
+                             (append (map id-string (name-path (package-name program)))
+                                     (list (id-string (name-id (package-name program)))))
+                             null))
+           (full-defs (if (null? (packages)) (package-defs program) (append (packages) (package-defs program))))
+           (dependent-defs (find-dependent-defs full-defs type-recs))
+           (modules (map (lambda (defs)
+                           (let*-values (((ordered-defs) (order-defs defs))
+                                         ((translated-defs reqs) (translate-defs ordered-defs type-recs)))
+                             (make-compilation-unit (map (lambda (def) (id-string (def-name def))) ordered-defs)
+                                                    translated-defs
+                                                    (map def-file ordered-defs)
+                                                    reqs)))
+                         dependent-defs)))
+      modules))
+  
+  ;get-package: definition type-records -> (list string)
+  (define (get-package def type-recs)
+    (send type-recs set-location! (def-file def))
+    (send type-recs lookup-path (id-string (def-name def)) (lambda () (error 'internal-error))))
+  
+  ;find-dependent-defs: (list defs) -> (list (list defs))
+  (define (find-dependent-defs defs type-recs)
+    (let* ((for-each-def (lambda (defs thunk) (for-each thunk defs)))
+           (find 
+            (lambda (req)
+              (letrec ((walker 
+                        (lambda (defs)
+                          (and (not (null? defs))
+                               (if (and (equal? (req-path req)
+                                                (get-package (car defs) type-recs))
+                                        (equal? (req-class req)
+                                                (id-string (def-name (car defs)))))
+                                   (car defs)
+                                   (walker (cdr defs)))))))
+                (walker defs))))
+           (get-requires
+            (lambda (def)
+              (filter (lambda (x) x) (map find (def-uses def)))))
+           )
+      (get-strongly-connected-components defs for-each-def get-requires)))
+  
+  ;get-strongly-connected-components: GRAPH (GRAPH (NODE -> void) -> void) (NODE -> (list NODE)) -> (list (list NODE))
+  (define (get-strongly-connected-components graph for-each-node get-connected-nodes)
+    
+    (let ((marks (make-hash-table))
+          (strongly-connecteds null)
+          (cur-cycle-length 0)
+          (current-cycle null))
+      
+      (letrec ((already-in-cycle? (lambda (n) (eq? 'in-cycle (hash-table-get marks n))))
+               
+               (in-current-cycle?
+                (lambda (n) (hash-table-get current-cycle n (lambda () #f))))
+               (current-cycle-memq
+                (lambda (nodes)
+                  (ormap in-current-cycle? nodes)))
+               (add-to-current-cycle
+                (lambda (n) 
+                  (set! cur-cycle-length (add1 cur-cycle-length))
+                  (hash-table-put! current-cycle n #t)))
+               (retrieve-current-cycle
+                (lambda () (hash-table-map current-cycle (lambda (key v) key))))
+               
+               (componentize 
+                (lambda (node successors member?)
+                  (unless (already-in-cycle? node)
+                    ;(printf "componentize ~a ~a ~a~n" node successors member?)
+                    (let ((added? #f)
+                          (cur-length cur-cycle-length))
+                      (when (and (not member?) (current-cycle-memq successors))
+                        (set! added? #t)
+                        (add-to-current-cycle node))
+                      (hash-table-put! marks node 'in-progress)
+                      (for-each 
+                       (lambda (successor)
+                         (unless (or (in-current-cycle? successor)
+                                     (eq? 'in-progress (hash-table-get marks successor)))
+                           (componentize successor (get-connected-nodes successor) #f)))
+                       successors)
+                      ;(printf "finished successors for ~a~n" node)
+                      (if (or added? (= cur-length cur-cycle-length))
+                          (hash-table-put! marks node 'no-info)
+                          (componentize node successors #f)))))))
+        
+        (for-each-node graph (lambda (n) (hash-table-put! marks n 'no-info)))
+        
+        (for-each-node graph
+                       (lambda (node)
+                         (when (eq? (hash-table-get marks node) 'no-info)
+                           (set! current-cycle (make-hash-table))
+                           (add-to-current-cycle node)
+                           (for-each (lambda (node) (componentize node (get-connected-nodes node) #f))
+                                     (get-connected-nodes node))
+                           (set! strongly-connecteds (cons (retrieve-current-cycle) strongly-connecteds))
+                           (hash-table-for-each
+                            current-cycle
+                            (lambda (n v) (hash-table-put! marks n 'in-a-cycle))))))
+        
+        strongly-connecteds)))
+  
+  ;This is the old find-dependent-defs: unreliable and known to have inifite-loop causing bugs
+  ;find-dependent-defs: (list defs) -> (list (list defs))
+  #;(define (find-dependent-defs defs type-recs)
+    (letrec ((not-found
+              (lambda (def msg tbl)
+                (lambda ()
+                  (hash-table-put! tbl def msg) msg)))
+             ;completed: maps def -> symbol
+             (completed (make-hash-table))  
+             ;completed? def -> bool
+             (completed? 
+              (lambda (def)
+                (eq? 'completed (hash-table-get completed def (not-found def 'started completed)))))
+             ;cycles: (list (list defs))
+             (cycles null)  
+             ;path maps def -> symbol
+             (cycle (make-hash-table))
+             ;in-cycle? def -> bool
+             (in-cycle? 
+              (lambda (def)
+                (eq? 'in-cycle (hash-table-get cycle def (not-found def 'not-in-cycle cycle)))))
+             
+             ;find-cycle: def -> void
+             (find-cycle 
+              (lambda (def)
+                ;(printf "find-cycle for def ~a with reqs ~a~n" (id-string (def-name def))
+                ;        (map req-class (def-uses def)))
+                ;(printf "find-cycle required defs found were ~a~n" 
+                ;       (map id-string (map def-name (filter (lambda (x) x) (map find (def-uses def)))))) 
+                (for-each (lambda (reqD)
+                            (cond
+                              ((or (completed? reqD) (in-cycle? reqD)) (void))
+                              ((or (dependence-on-cycle reqD) (exists-path-to-cycle? reqD null))
+                               (hash-table-put! cycle reqD 'in-cycle)
+                               (find-cycle reqD))))
+                          (filter (lambda (x) x) (map find (def-uses def))))))
+             
+             ;exists-path-to-cycle: def (list def)-> bool
+             (exists-path-to-cycle? 
+              (lambda (def explored-list)
+                ;(printf "exists-path-to-cycle? for ~a~n" (id-string (def-name def)))
+                (let ((reqs-in-cycle (filter (lambda (req)
+                                               ;(printf "reqs-in-cycle: looking at ~a~n" (id-string (def-name req)))
+                                               (and (not (completed? req))
+                                                    (or (in-cycle? req)
+                                                        (and (dependence-on-cycle req)
+                                                             (hash-table-put! cycle req 'in-cycle))
+                                                        (and (not (memq req explored-list))
+                                                             (exists-path-to-cycle? req (cons def explored-list))))))
+                                             (filter (lambda (x) x) (map find (def-uses def))))))
+                  ;(printf "exists-path-to-cycle? reqs-in-cycle for ~a is ~a~n" (id-string (def-name def))
+                  ;        (map id-string (map def-name reqs-in-cycle)))
+                  (and (not (null? reqs-in-cycle))
+                       (hash-table-put! cycle def 'in-cycle)))))
+             
+             ;dependence-on-cycle: req -> bool
+             (dependence-on-cycle
+              (lambda (reqD)
+                (ormap (lambda (x) x)
+                       (hash-table-map cycle (lambda (def v) (and (eq? v 'in-cycle)
+                                                                  (dependence? reqD def)))))))
+             
+             ;to Determine if reqD directly depends on def
+             (dependence? 
+              (lambda (reqD def)
+                (member (make-req (id-string (def-name def)) (get-package def type-recs))
+                        (def-uses reqD))))
+             
+             ;find: req -> (U #f def)
+             (find 
+              (lambda (req)
+                (letrec ((walker 
+                          (lambda (defs)
+                            (and (not (null? defs))
+                                 (if (and (equal? (req-path req)
+                                                  (get-package (car defs) type-recs))
+                                          (equal? (req-class req)
+                                                  (id-string (def-name (car defs)))))
+                                     (car defs)
+                                     (walker (cdr defs)))))))
+                  (walker defs)))))
+      
+      (for-each (lambda (def)
+                  (unless (completed? def)
+                    ;(printf "Started on def ~a~n" (id-string (def-name def)))
+                    (set! cycle (make-hash-table))
+                    (hash-table-put! cycle def 'in-cycle)
+                    (find-cycle def)
+                    ;(printf "Completed looking for cycle for def ~a~n" (id-string (def-name def)))
+                    ;(printf "hashtable for def ~a includes ~a~n" (id-string (def-name def))
+                    ;        (hash-table-map cycle (lambda (k v) (cons (id-string (def-name k)) v))))
+                    (let ((cyc (filter (lambda (d)
+                                         (eq? (hash-table-get cycle d) 'in-cycle))
+                                       (hash-table-map cycle (lambda (k v) k)))))
+                      (for-each (lambda (c) (hash-table-put! completed c 'completed))
+                                cyc)
+                      ;(printf "cycle for ~a is ~a~n" (id-string (def-name def)) (map id-string (map def-name cyc)))
+                      ;(printf "completed table after ~a is ~a" (id-string (def-name def))
+                      ;        (hash-table-map completed (lambda (k v) (list (id-string (def-name k)) v))))
+                      (set! cycles (cons cyc cycles)))))
+                defs)
+      cycles))
+  
+  ;order-defs: (list def) -> (list def)
+  (define (order-defs defs)
+    (reverse
+     (let loop ((ordered-defs null)
+                (local-defs defs))
+       (cond
+         ((null? local-defs) ordered-defs)
+         ((add-def? (car local-defs) local-defs ordered-defs)
+          (loop (cons (car local-defs) ordered-defs)
+                (cdr local-defs)))
+         (else
+          (loop ordered-defs (append (cdr local-defs) (list (car local-defs)))))))))
+    
+  ;add-def? def (list def) (list def) -> bool
+  (define (add-def? def local-defs ordered-defs)
+    (andmap (lambda (e)
+              (satisfied-extend? e local-defs ordered-defs))
+            (append (header-extends (def-header def))
+                    (header-implements (def-header def)))))
+  
+  ;satisified-extend? id (list def) (list def) -> bool
+  (define (satisfied-extend? extend local-defs ordered-defs)
+    (or (null? extend)
+        (not (member (id-string (name-id extend)) 
+                     (map id-string (map def-name local-defs))))
+        (member (id-string (name-id extend))
+                (map id-string (map def-name ordered-defs)))))
+  
+  ;make-composite-name: def -> string
+  (define (make-composite-name d)
+    (build-identifier (string-append (id-string (header-id (def-header d))) "-composite")))
+  
+  ;translate-defs: (list def) type-records -> (values (list syntax) (list reqs))
+  (define (translate-defs defs type-recs)
+    (module-name (make-composite-name (car defs)))
+    (module-require (if (to-file) 
+                        (let ((location (build-path (begin (send type-recs set-location! (def-file (car defs)))
+                                                           (send type-recs get-compilation-location) "compiled")
+                                                    (string-append (symbol->string (module-name)) ".zo"))))
+                          (for-each 
+                           (lambda (def)
+                             (send type-recs set-composite-location (id-string (def-name def)) location))
+                           defs)
+                          `(file ,(path->string (build-path (string-append (symbol->string (module-name)) ".zo")))))
+                        (module-name)))
+    (let* ((translated-defs (map (lambda (d)
+                                   (if (class-def? d)
+                                       (translate-class d type-recs 0)
+                                       (translate-interface d type-recs)))
+                                 defs))
+           (group-reqs (apply append (map (lambda (d) 
+                                            (map (lambda (r) (list (def-file d) r)) (def-uses d)))
+                                          defs)))
+           (reqs (filter-reqs group-reqs defs type-recs)))
+      (values (if (> (length translated-defs) 1)
+                  (cons (make-syntax #f `(module ,(module-name) mzscheme
+                                           (require (lib "class.ss")
+                                                    (prefix javaRuntime: (lib "runtime.scm" "profj" "libs" "java"))
+                                                    (prefix c: (lib "contract.ss"))
+                                                    ,@(remove-dup-syntax (translate-require reqs type-recs)))
+                                           ,@(map car translated-defs))
+                                     #f)
+                        (map cadr translated-defs))
+                  (list (make-syntax #f 
+                                     `(module ,(build-identifier (regexp-replace "-composite" 
+                                                                                 (symbol->string (module-name)) 
+                                                                                 ""))
+                                        mzscheme
+                                        (require (lib "class.ss")
+                                                 (prefix javaRuntime: (lib "runtime.scm" "profj" "libs" "java"))
+                                                 (prefix c: (lib "contract.ss"))
+                                                 ,@(remove-dup-syntax
+                                                    (translate-require (map (lambda (r) (list (def-file (car defs)) r))
+                                                                            (def-uses (car defs)))
+                                                                       type-recs)))
+                                        ,(car (car translated-defs)))
+                                     #f)))
+              (filter (lambda (req) (not (member req reqs)))
+                      (map (lambda (r-pair) (cadr r-pair)) group-reqs)))))
+  
+  ;filter-reqs: (list (list location req)) (list def) type-records -> (list req)
+  (define (filter-reqs reqs defs type-recs)
+    (if (null? reqs)
+        null
+        (if (or (reference (car reqs) defs type-recs)
+                (req-member (car reqs) (cdr reqs)))
+            (filter-reqs (cdr reqs) defs type-recs)
+            (cons (car reqs) (filter-reqs (cdr reqs) defs type-recs)))))
+  
+  ;reference: (list req location) (list def) type-records -> bool
+  (define (reference req defs type-recs)
+    (and (not (null? defs))
+         (or (and (equal? (req-path (cadr req)) (get-package (car defs) type-recs))
+                  (equal? (req-class (cadr req)) (id-string (def-name (car defs)))))
+             (reference req (cdr defs) type-recs))))
+  
+  ;req-member: (list location req) (list (list location req)) -> bool
+  (define (req-member req reqs)
+    (and (not (null? reqs))
+         (or (equal? (cadr req) (cadr (car reqs)))
+             (req-member req (cdr reqs)))))
+  
+  ;remove-dup-syntax: (list syntax) -> (list syntax)
+  (define (remove-dup-syntax syn)
+    (letrec ((remove 
+              (lambda (duped syn)
+                (if (null? syn)
+                    null
+                    (if (eq? duped (car syn))
+                        (remove duped (cdr syn))
+                        (cons (car syn) (remove duped (cdr syn)))))))
+             (remove-dups
+              (lambda (syn)
+                (if (null? syn)
+                    null
+                    (if (memq (car syn) (cdr syn))
+                        (cons (car syn) (remove-dups (remove (car syn) (cdr syn))))
+                        (cons (car syn) (remove-dups (cdr syn))))))))
+      (remove-dups syn)))
+  
+  ;translate-interact-require: (list reg) type-record -> (list syntax)
+  (define (translate-interact-require reqs type-recs)
+    (if (null? reqs)
+        null
+        (let ((req (car reqs)))
+          (cons (begin (send type-recs set-location! 'interactions)
+                       (send type-recs get-require-syntax
+                             (send type-recs require-prefix?
+                                   (cons (req-class req) (req-path req))
+                                   (lambda () #f))
+                             (cons (req-class req) (req-path req))
+                             (lambda () #f)))
+                (translate-interact-require (cdr reqs) type-recs)))))
+  
+  ;translate-require: (list req) type-records -> (list syntax)
+  (define (translate-require reqs type-recs)
+    (if (null? reqs)
+        null
+        (let* ((req (cadr (car reqs)))
+               (err (lambda () (error 'translate-require (format "Internal Error: ~a not found" req)))))
+          (cons (begin (send type-recs set-location! (car (car reqs)))
+                       (send type-recs get-require-syntax 
+                             (send type-recs require-prefix? 
+                                   (cons (req-class req) (req-path req)) 
+                                   err)
+                             (cons (req-class req) (req-path req))
+                             err))
+                (translate-require (cdr reqs) type-recs)))))
+  
+  ;translate-implements: (list name) -> (list syntax)
+  (define (translate-implements imp)
+    (map (lambda (i)
+           (let* ((id (name-id i))
+                  (st (id-string id))
+                  (path (name-path i)))
+             (if (null? path)
+                 (translate-id st (id-src id))
+                 (create-syntax #f (build-identifier (append (map id-string path) (list st)))
+                                (build-src (name-src i))))))
+         imp))
+  
+  ;translate-class: class-def type-records -> (list syntax syntax)
+  (define (translate-class class type-recs depth)
+    ;Let's grab onto the enclosing class-specific info incase depth > 0
+    (let ((old-class-name (class-name))
+          (old-parent-name (parent-name))
+          (old-override-table (class-override-table)))
+      (unless (> depth 0) (loc (def-file class)))
+      
+      (let*-values (((header) (def-header class))
+                    ((kind) (def-kind class))
+                    ((closure-args) (def-closure-args class))
+                    ((parent parent-src extends-object?)
+                     (if (null? (header-extends header))
+                         (values "Object" #f #t)
+                         (let-values (((p p-s) (get-parent (header-extends header))))
+                           (values p p-s
+                                   (class-record-object? 
+                                    (send type-recs get-class-record 
+                                          (name->type (car (header-extends header)) #f #f 'full type-recs)))))))
+                    ((class*) (create-syntax #f 'class* (build-src (def-key-src class))))
+                    ((class-members) (separate-members (def-members class)))
+                    ((methods) (separate-methods (members-method class-members) (make-accesses null null null null null null)))
+                    ((fields) (separate-fields (members-field class-members) (make-accesses null null null null null null))))
+        
+        ;set class specific parameters - old ones are safe
+        (class-name (id-string (header-id header)))
+        (parent-name parent)
+        (class-override-table (make-hash-table))
+            
+        (let* ((class (translate-id (class-name) (id-src (header-id header))))
+               (overridden-methods (get-overridden-methods (append (accesses-public methods) 
+                                                                   (accesses-package methods) 
+                                                                   (accesses-protected methods))))
+               (restricted-methods (make-method-names ;(append (accesses-package methods)
+                                    (accesses-protected methods);)
+                                    overridden-methods))
+               (make-gen-name 
+                (lambda (m)
+                  (build-generic-name (class-name)
+                                      ((if (constructor? (id-string (method-name m))) build-constructor-name mangle-method-name)
+                                       (id-string (method-name m))
+                                       (method-record-atypes (method-rec m))))))
+               (providable-generics 
+                (map make-gen-name 
+                     (append (accesses-public methods)
+                             (accesses-package methods)
+                             (accesses-protected methods))))
+               (private-generics (map make-gen-name (accesses-private methods)))
+               (names-for-dynamic (generate-dynamic-names (append (accesses-public methods)
+                                                                  (accesses-package methods)
+                                                                  (accesses-protected methods))
+                                                          overridden-methods))
+               (dynamic-method-defs (generate-dyn-method-defs names-for-dynamic))
+               (static-method-names (make-static-method-names (accesses-static methods) type-recs))
+               (static-field-names (make-static-field-names (accesses-static fields)))
+               (static-field-setters (make-static-field-setters-names 
+                                      (filter (lambda (f) (not (final? 
+                                                                (map modifier-kind (field-modifiers f)))))
+                                              (accesses-static fields))))
+               (field-getters/setters (make-field-accessor-names (append (accesses-public fields)
+                                                                         (accesses-package fields)
+                                                                         (accesses-protected fields))))
+               (provides `(provide ,(build-identifier (class-name))
+                                   ;,@restricted-methods
+                                   ,@(map build-identifier static-method-names)
+                                   ,@(map build-identifier static-field-names)
+                                   ,@static-field-setters
+                                   ,@(map build-identifier providable-generics)
+                                   ,@field-getters/setters)))
+
+          (let ((class-syntax
+                 (create-syntax 
+                  #f
+                  `(begin ,(unless (or (memq 'private (map modifier-kind (header-modifiers header)))
+                                       (eq? 'anonymous kind)
+                                       (eq? 'statement kind))
+                             provides)
+                          ,(create-local-names (append (make-method-names (accesses-private methods) null)
+                                                       restricted-methods))
+                          (define ,class
+                            (,class* ,(if extends-object?
+                                          (translate-id parent parent-src)
+                                          `(Object-Mix ,(translate-id parent parent-src)))
+                                     ,(translate-implements (header-implements header))
+                             
+                             (super-instantiate ())
+                             
+                             ,@(if (> depth 0)
+                                   `((init-field 
+                                      ,@(let loop ((d depth))
+                                          (cond
+                                            ((= d 0) null)
+                                            (else 
+                                             (cons (string->symbol (format "encl-this-~a~~f" d))
+                                                   (loop (sub1 d))))))))
+                                   null)
+                             
+                             ,@(if (null? closure-args)
+                                   null
+                                   `((init-field 
+                                      ,@(let loop ((args 
+                                                    (map id-string closure-args)))
+                                          (cond
+                                            ((null? args) null)
+                                            (else (cons (string->symbol (format "~a~~f" (car args)))
+                                                        (loop (cdr args)))))))))
+                             ,@(map (lambda (f) (translate-field (map modifier-kind (field-modifiers f))
+                                                                 (field-type f)
+                                                                 (field-name f)
+                                                                 (and (var-init? f) f)
+                                                                 (if (var-init? f)
+                                                                     (var-init-src f)
+                                                                     (var-decl-src f))
+                                                                 #f))
+                                    (append (accesses-public fields)
+                                            (accesses-package fields)
+                                            (accesses-protected fields)
+                                            (accesses-private fields)))
+                             ,@(create-private-setters/getters (accesses-private fields))
+                             
+                             ,@(generate-inner-makers (members-inner class-members) 
+                                                      depth type-recs)
+                             
+                             
+                             ,@(map (lambda (m) (translate-method (method-type m)
+                                                                  (map modifier-kind (method-modifiers m))
+                                                                  (method-name m)
+                                                                  (method-parms m)
+                                                                  (method-body m)
+                                                                  (method-all-tail? m)
+                                                                  (method-src m)
+                                                                  (> depth 0)
+                                                                  depth
+                                                                  (method-rec m)
+                                                                  type-recs))
+                                    (append (accesses-public methods)
+                                            (accesses-package methods)
+                                            (accesses-protected methods)
+                                            (accesses-private methods)))
+                             
+                             ,@dynamic-method-defs
+                             
+                             (define/override (my-name) ,(class-name))
+                             
+                             (define/override (field-names)
+                               (append (super field-names)
+                                       (list ,@(map (lambda (n) (id-string (field-name n)))
+                                                    (append (accesses-public fields)
+                                                            (accesses-package fields)
+                                                            (accesses-protected fields)
+                                                            (accesses-private fields))))))
+
+                             (define/override (field-values)
+                               (append (super field-values)
+                                       (list ,@(map (lambda (n) (build-identifier (build-var-name (id-string (field-name n)))))
+                                                    (append (accesses-public fields)
+                                                            (accesses-package fields)
+                                                            (accesses-protected fields)
+                                                            (accesses-private fields))))))
+                             
+                             (define field-accessors ,(build-field-table create-get-name 'get fields))
+                             (define field-setters ,(build-field-table create-set-name 'set fields))
+                             (define private-methods ,(build-method-table (accesses-private methods) private-generics))
+                                                          
+                             ,@(map (lambda (i) (translate-initialize (initialize-static i)
+                                                                      (initialize-block i)
+                                                                      (initialize-src i)
+                                                                      type-recs))
+                                    (members-init class-members))
+                             
+                             ))
+                          
+                          ,@(create-generic-methods (append (accesses-public methods)
+                                                            (accesses-package methods)
+                                                            (accesses-protected methods)
+                                                            (accesses-private methods)))
+                          
+                          ,@(create-field-accessors field-getters/setters
+                                                    (append (accesses-public fields)
+                                                            (accesses-package fields)
+                                                            (accesses-protected fields)))
+                          ,@(map (lambda (def) (translate-class def type-recs (add1 depth)))
+                                 (members-inner class-members))
+                          ,@(create-static-methods (append static-method-names
+                                                           (make-static-method-names 
+                                                            (accesses-private-static methods) 
+                                                            type-recs))
+                                                   (append (accesses-static methods)
+                                                           (accesses-private-static methods))
+                                                   type-recs)
+                          ,@(create-static-fields (append static-field-names
+                                                          (make-static-field-names (accesses-private-static fields)))
+                                                  (append (accesses-static fields)
+                                                          (accesses-private-static fields)))
+                          ,@(create-static-setters static-field-setters
+                                                   (filter (lambda (f) (not (final? 
+                                                                             (map modifier-kind (field-modifiers f)))))
+                                                           (accesses-static fields)))
+                          ,@(map (lambda (i) (translate-initialize (initialize-static i)
+                                                                   (initialize-block i)
+                                                                   (initialize-src i)
+                                                                   type-recs))
+                                 (members-static-init class-members)) 
+                          )
+                  #f)))
+            
+            ;reset the old class-specific info if in inner-class
+            (begin0
+              (if (> depth 0)
+                  class-syntax
+                  (list class-syntax 
+                        (make-syntax 
+                         #f
+                         `(module ,(build-identifier (class-name)) mzscheme (require ,(module-require)) ,provides)
+                         #f)))
+              (when (> depth 0)
+                (class-name old-class-name)
+                (parent-name old-parent-name)
+                (class-override-table old-override-table))))))))
+
+  ;generate-dynamic-names: (list method) (list method)-> (list (list string method))
+  (define (generate-dynamic-names methods overridden-methods)
+    (map (lambda (method)
+           (list (java-name->scheme (id-string (method-name method)))
+                 method))
+         (refine-method-list methods overridden-methods)))
+ 
+  ;refine-method-list: (list method) (list method) -> (list method)
+  (define (refine-method-list methods overridden-methods)
+    (if (null? methods) 
+        methods
+        (let ((overloaded-removed 
+               (filter (lambda (method)
+                         (not (equal? (id-string (method-name (car methods)))
+                                      (id-string (method-name method)))))
+                       (cdr methods))))
+          (cond
+            ((> (length (cdr methods))
+                (length overloaded-removed))
+             (refine-method-list overloaded-removed overridden-methods))
+            ((memq (car methods) overridden-methods)
+             (refine-method-list (cdr methods) overridden-methods))
+            ((eq? 'ctor (method-record-rtype (method-rec (car methods))))
+             (refine-method-list (cdr methods) overridden-methods))
+            (else (cons (car methods) (refine-method-list (cdr methods) overridden-methods)))))))
+    
+  ;generate-dyn-method-defs: (list (list string method)) -> (list syntax)
+  (define (generate-dyn-method-defs methods)
+    (map (lambda (name-method)
+           (let ((args (map (lambda (arg)
+                              (build-identifier (id-string (var-decl-name arg))))
+                            (method-parms (cadr name-method)))))
+             (create-syntax 
+              #f
+              `(define/public (,(build-identifier (car name-method)) ,@args)
+                 (,(build-identifier (mangle-method-name (id-string (method-name (cadr name-method)))
+                                                         (method-record-atypes (method-rec (cadr name-method)))))
+                   ,@args))
+              #f)))
+         (filter (lambda (name-method)
+                   (not (equal? (car name-method) (id-string (method-name (cadr name-method))))))
+                 methods)))
+  
+  ;build-method-table: (list method) (list symbol) -> sexp
+  (define (build-method-table methods generics)
+    `(let ((table (make-hash-table)))
+       (for-each (lambda (method generic)
+                   (hash-table-put! table (string->symbol method) generic))
+                 (list ,@(map (lambda (m)
+                               (mangle-method-name (id-string (method-name m))
+                                                   (method-record-atypes (method-rec m))))
+                             methods))
+                 (list ,@generics))
+       table))
+  
+  ;build-field-table: (string->string) symbol accesses -> sexp
+  (define (build-field-table maker type fields)
+    `(let ((table (make-hash-table)))
+       (for-each (lambda (field field-method)
+                   (hash-table-put! table (string->symbol field) field-method))
+                 ,@(let ((non-private-fields (map (lambda (n) (id-string (field-name n)))
+                                                  (append (accesses-public fields)
+                                                          (accesses-package fields)
+                                                          (accesses-protected fields))))
+                         (private-fields (map (lambda (n) (id-string (field-name n)))
+                                              (accesses-private fields))))
+                     (list `(list ,@(append non-private-fields private-fields))
+                           `(list ,@(append
+                                     (map (lambda (n) (build-identifier (maker n))) non-private-fields)
+                                     (map (if (eq? 'get type)
+                                              (lambda (n) 
+                                                `(lambda (class-obj)
+                                                   (send class-obj ,(build-identifier (maker n)))))
+                                              (lambda (n)
+                                                `(lambda (class-obj new-val)
+                                                   (send class-obj ,(build-identifier (maker n)) new-val))))
+                                          private-fields))))))
+       table))
+
+                      
+  ;generate-inner-makers: (list def) int type-records -> (list syntax)
+  (define (generate-inner-makers defs depth type-recs)
+    (apply append
+           (map (lambda (d) (build-inner-makers d depth type-recs)) 
+                (filter (lambda (d) (not (memq (def-kind d) '(anonymous statement)))) defs))))
+  
+  ;build-inner-makers: def int type-records -> (list syntax)
+  (define (build-inner-makers def depth type-recs)
+    (let* ((class-name (id-string (def-name def)))
+           (ctor-name (string-append "construct-" class-name))
+           (parms (map method-parms (get-ctors (def-members def) type-recs))))
+      (map (build-inner-maker class-name ctor-name depth type-recs) parms)))
+  
+  ;build-inner-maker: string string int type-records -> ((list field) -> syntax)
+  (define (build-inner-maker class-name ctor-name depth type-recs)
+    (lambda (parms)
+      (let ((translated-parms (translate-parms parms))
+            (encls-this (reverse (let loop ((d depth))
+                                   (cond
+                                     ((= d 0) null)
+                                     (else (cons (string->symbol (format "encl-this-~a~~f" d))
+                                                 (loop (sub1 d))))))))
+            (parm-types (map (lambda (p) (type-spec-to-type (field-type p) #f 'full type-recs)) parms)))
+        (make-syntax #f
+                     `(define/public (,(build-identifier (mangle-method-name ctor-name parm-types)) ,@translated-parms)
+                        (let ((temp-obj (make-object ,(build-identifier class-name)
+                                          this ,@encls-this)))
+                          (send temp-obj ,(build-identifier (build-constructor-name class-name parm-types))
+                                ,@translated-parms)
+                          temp-obj))
+                     #f))))
+
+  ;get-ctors: (list member) -> (list method)
+  (define (get-ctors members type-recs)
+    (filter
+     (lambda (member)
+       (and (method? member)
+            (eq? 'ctor (type-spec-to-type (method-type member) #f 'full type-recs))))
+     members))  
+  
+  ;Code to separate different member types for easier access
+  ;(make-accesses (list member) (list member) (list member) ...)
+  (define-struct accesses (private protected static public package private-static))
+  ;(make-members (list method) (list field) (list init) (list init) (list def) (list def))
+  (define-struct members (method field static-init init nested inner))
+  
+  ;update: ('a 'b -> void) 'a ('b -> (list 'a)) 'b) -> 'b 
+  ;Allows a set! to be passed in and applied
+  (define (update set add-on access struct)
+    (set struct (cons add-on (access struct)))
+    struct)
+  
+  ;separate-members: (list member) -> members
+  (define (separate-members members)
+    (letrec ((my-members (make-members null null null null null null))
+             (separate
+              (lambda (m h)
+                (cond
+                  ((null? m) h)
+                  ((method? (car m))
+                   (separate (cdr m) (update set-members-method! (car m) members-method h)))
+                  ((field? (car m))
+                   (separate (cdr m) (update set-members-field! (car m) members-field h)))
+                  ((initialize? (car m))
+                   (separate (cdr m)
+                             (if (initialize-static (car m))
+                                 (update set-members-static-init! (car m) members-static-init h)
+                                 (update set-members-init! (car m) members-init h))))
+                  ((def? (car m))
+                   (separate (cdr m)
+                             (if (or (interface-def? (car m))
+                                     (memq 'static (map modifier-kind (header-modifiers (def-header (car m))))))
+                                 (update set-members-nested! (car m) members-nested h)
+                                 (update set-members-inner! (car m) members-inner h))))
+                  (else (error 'separate "not something expected: ~e" (car m)))))))
+      (separate members my-members)))
+  
+  ;make-access-separator: ('a -> (list symbol)) -> ((list 'a) accesses -> accesses)
+  (define (make-access-separator get-modifiers)
+    (letrec ((separate
+              (lambda (m h)
+                (if (null? m) h
+                    (separate (cdr m)
+                              (let* ((current (car m))
+                                     (modifiers (map modifier-kind (get-modifiers current))))
+                                (cond
+                                  ((private? modifiers)
+                                   (if (static? modifiers)
+                                       (update set-accesses-private-static! current accesses-private-static h) 
+                                       (update set-accesses-private! current accesses-private h)))
+                                  ((static? modifiers) (update set-accesses-static! current accesses-static h))
+                                  ((protected? modifiers) (update set-accesses-protected! current accesses-protected h))
+                                  ((public? modifiers) (update set-accesses-public! current accesses-public h))
+                                  (else (update set-accesses-package! current accesses-package h)))))))))
+      separate))
+  
+  ;separate-methods: (list method) accesses -> accesses
+  (define separate-methods (make-access-separator method-modifiers))  
+  ;separate-fields: (list field) accesses -> accesses
+  (define separate-fields (make-access-separator field-modifiers))
+  
+  ;get-parent: name -> (values string src)
+  (define get-parent
+    (lambda (parent)
+      (when (= (length parent) 1) (set! parent (car parent)))
+      (when (null? parent) (set! parent (make-name (make-id "Object" #f) null #f)))
+      (if (null? (name-path parent))
+          (values (id-string (name-id parent)) (id-src (name-id parent)))
+          (values (string-append (apply string-append (map (lambda (p)
+                                                             (format "~s." p))
+                                                           (map id-string (name-path parent))))
+                                 (id-string (name-id parent)))
+                  (name-src parent)))))
+  
+  ;create-local-names: (list symbol) -> syntax
+  (define (create-local-names names)
+    (make-syntax #f  `(define-local-member-name ,@names) #f))
+  
+  ;translate-parents: (list name) -> (list syntax)
+  (define (translate-parents extends)
+    (map (lambda (n)
+           (if (null? (name-path n))
+               (translate-id (id-string (name-id n))
+                             (id-src (name-id n)))
+               (create-syntax #f (build-identifier (append (map id-string (name-path n))
+                                                           (list (id-string (name-id n)))))
+                              (build-src (name-src n)))))
+         extends))
+  
+  ;translate-interface: interface-def type-records-> (list syntax)
+  (define (translate-interface iface type-recs)
+    (let* ((header (def-header iface))
+           (name (build-identifier (id-string (header-id header))))
+           (syntax-name (translate-id (id-string (header-id header))
+                                      (id-src (header-id header))))
+           (source (build-src (def-src iface)))
+           (interface (create-syntax #f 'interface (build-src (def-key-src iface))))
+           (members (separate-members (def-members iface))))
+      
+      (loc (def-file iface))
+      (class-name (id-string (header-id header)))
+      (send type-recs set-location! (loc))
+      
+      (let* ((static-field-names (map build-identifier (make-static-field-names (members-field members))))
+             (provides `(provide ,name ,@static-field-names)))
+        
+        (list `(begin ,provides
+                      (define ,syntax-name (,interface ,(translate-parents (header-extends header))
+                                            ,@(make-method-names (members-method members) null)))
+                      ,@(create-static-fields static-field-names (members-field members)))
+              (make-syntax #f `(module ,name mzscheme (requires ,(module-name)) ,provides) #f)))))
+
+  ;-----------------------------------------------------------------------------------------------------------------
+  ;Member translation functions
+  
+  ;translate-inner-class: def type-records int -> (U syntax (list syntax syntax))
+
+  
+  ;------------------------------------------------------------
+  ;;Method translation functions
+  
+  ;override?: symbol type-records -> bool
+  (define (override? method-name type-recs)
+    (let* ((internal-error 
+            (lambda () (error 'override "Internal Error class or it's parent not in class record table")))
+           (class-record 
+            (get-record (send type-recs get-class-record 
+                              (make-ref-type (class-name)
+                                             (send type-recs lookup-path (class-name) (lambda () null)))
+                              #f
+                              internal-error) type-recs))
+           (parent-record (send type-recs get-class-record  
+                                (car (class-record-parents class-record)) #f internal-error)))
+      (memq method-name
+            (map (lambda (m) (string->symbol (mangle-method-name (method-record-name m)
+                                                                 (method-record-atypes m))))
+                 (class-record-methods parent-record)))))
+  
+  ;get-overridden-names: (list method) -> (list method)
+  (define (get-overridden-methods methods) 
+    (filter (lambda (m) 
+              (let ((mname (id-string (method-name m))))
+                (and (method-record-override (method-rec m))
+                     (hash-table-put! (class-override-table) 
+                                      (build-identifier 
+                                       ((if (constructor? mname) build-constructor-name mangle-method-name)
+                                        mname
+                                        (method-record-atypes (method-rec m)))) #t))))
+            methods))
+  
+  ;create-generic-methods: (list method) -> (list syntax)
+  (define (create-generic-methods methods)
+    (map (lambda (method)
+           (let* ((m-name (id-string (method-name method)))
+                  (name ((if (eq? 'ctor (method-record-rtype (method-rec method)))
+                             build-constructor-name mangle-method-name)
+                         m-name
+                         (method-record-atypes (method-rec method)))))
+             (make-syntax #f `(define ,(build-identifier (build-generic-name (class-name) name))
+                                (generic ,(build-identifier (class-name)) ,(build-identifier name)))
+                          (build-src (method-src method)))))
+         methods))
+  
+  ;make-method-names: (list methods) (list methods) -> (list symbol)
+  (define (make-method-names methods minus-methods)
+    (if (null? methods)
+        null
+        (if (memq (car methods) minus-methods)
+            (make-method-names (cdr methods) minus-methods)
+            (cons 
+             (build-identifier ((if (constructor? (id-string (method-name (car methods))))
+                                    build-constructor-name
+                                    mangle-method-name)
+                                (id-string (method-name (car methods)))
+                                (method-record-atypes (method-rec (car methods)))))
+             (make-method-names (cdr methods) minus-methods)))))
+  
+  ;translate-method: type-spec (list symbol) id (list parm) statement bool 
+  ;                  src bool int method-record type-records -> syntax
+  (define (translate-method type modifiers id parms block all-tail? src inner? depth rec type-recs)
+    (let* ((final (final? modifiers))
+           (ctor? (eq? 'ctor (method-record-rtype rec)));(constructor? (id-string id)))
+           (method-string ((if ctor? build-constructor-name mangle-method-name)
+                           (id-string id)
+                           (method-record-atypes rec)))
+           (method-name (translate-id method-string (id-src id)))
+           (over? (method-record-override rec))
+           (definition (cond
+                         ((and over? final) 'define/override-final)
+                         (over? 'define/override)
+                         (final 'define/public-final)
+                         (else 'define/public))))
+      (unless (static? modifiers) (current-depth depth))
+      (current-local-classes null)
+      (create-syntax #f
+                     `(,definition ,method-name 
+                        ,(translate-method-body method-string parms block modifiers type 
+                                                all-tail? ctor? inner? depth type-recs))
+                     (build-src src))))
+  
+  ;make-static-method-names: (list method) type-recs -> (list string)
+  (define (make-static-method-names methods type-recs)
+    (map (lambda (m)
+           (build-static-name (mangle-method-name (id-string (method-name m))
+                                                  (method-record-atypes (method-rec m)))))
+         methods))
+  
+  ;create-static-methods: (list string) (list method) type-records -> (list syntax)
+  (define (create-static-methods names methods type-recs)
+    (if (null? names)
+        null
+        (let ((name (car names))
+              (method (car methods)))
+          (cons (create-syntax #f
+                               `(define ,(translate-id name (id-src (method-name method)))
+                                  ,(translate-method-body name
+                                                          (method-parms method)
+                                                          (method-body method)
+                                                          (map modifier-kind (method-modifiers method))
+                                                          (method-type method)
+                                                          (method-all-tail? method)
+                                                          #f
+                                                          #f
+                                                          0
+                                                          type-recs))
+                               (build-src (method-src method)))
+                (create-static-methods (cdr names) (cdr methods) type-recs)))))
+  
+  (define static-method (make-parameter #f))
+  
+  ;translate-method-body: string (list field) statement (list symbol) type-spec bool bool bool int type-record -> syntax
+  (define (translate-method-body method-name parms block modifiers rtype all-tail? ctor? inner? depth type-recs)
+    (let ((parms (translate-parms parms))
+          (void? (eq? (type-spec-name rtype) 'void))
+          (native? (memq 'native modifiers))
+          (static? (memq 'static modifiers))
+          (native-method-name (build-identifier 
+                               (string-append method-name #;(substring method-name 0 (- (string-length method-name) 2))
+                                              "-native"))))
+            
+      (static-method static?)
+      (make-syntax #f
+                   (cond
+                     ((and block void?)
+                      `(lambda ,parms 
+                         (let/ec return-k
+                           ,(translate-statement block type-recs)
+                           (void))))
+                     ((and block (not void?) all-tail?)
+                      `(lambda ,parms
+                         ,(translate-statement block type-recs)))
+                     ((and block (not void?))
+                      `(lambda ,parms
+                         (let/ec return-k
+                           ,(translate-statement block type-recs))))
+                     ((and (not block) (memq 'abstract modifiers))
+                      `(lambda ,parms (void)))
+                     ((and (not block) native? void? (not static?))
+                      `(lambda ,parms
+                         (,native-method-name
+                           this field-accessors field-setters private-methods ,@parms)
+                         (void)))
+                     ((and (not block) native? (not static?))
+                      `(lambda ,parms
+                         (,native-method-name
+                           this field-accessors field-setters private-methods ,@parms)))
+                     ((and (not block) native? void? static?)
+                      `(lambda ,parms
+                         (,native-method-name ,@parms)
+                         (void)))
+                     ((and (not block) native? static?)
+                      `(lambda ,parms
+                         (,native-method-name ,@parms))))
+                   #f)))
+  
+  ;translate-parms: (list field) -> (list syntax)
+  (define (translate-parms parms)
+    (map (lambda (parm)
+           (translate-id (build-var-name (id-string (field-name parm)))
+                         (id-src (field-name parm))))
+         parms))
+
+  ;----------------------------------------------------------------
+  ;Field translation functions
+  
+  ;make-field-accessor-names: (list fields) -> (list symbol)
+  (define (make-field-accessor-names fields)
+    (if (null? fields)
+        null
+        (let ((name (id-string (field-name (car fields)))))
+          (append (cons (create-get-name name)
+                        (if (final? (map modifier-kind (field-modifiers (car fields))))
+                            null
+                            (list (create-set-name name))))
+                  (make-field-accessor-names (cdr fields))))))
+  
+  (define (create-field-accessors names fields)
+    (if (null? fields)
+        null
+        (let* ((field (car fields))
+               (class (build-identifier (class-name)))
+               (quote-name (build-identifier (build-var-name (id-string (field-name field)))))
+               (getter (car names))
+               (final (final? (map modifier-kind (field-modifiers field)))))
+          (append (cons (make-syntax #f `(define ,getter
+                                           (class-field-accessor ,class ,quote-name)) #f)
+                        (if (not final)
+                            (list (make-syntax #f `(define ,(cadr names)
+                                                     (class-field-mutator ,class ,quote-name)) #f))
+                            null))
+                  (create-field-accessors (if final (cdr names) (cddr names)) (cdr fields))))))
+  
+  (define (make-static-field-setters-names fields) 
+    (map (lambda (f) (create-set-name (id-string (field-name f)))) fields))
+  
+  (define (create-static-setters names fields)
+    (if (null? names)
+        null
+        (let ((name (car names))
+              (field (car fields)))
+          (cons (make-syntax #f
+                             `(define (,name my-val)
+                                (set! ,(build-identifier (build-var-name (build-static-name (id-string (field-name field))))) 
+                                      my-val))
+                             #f)
+                (create-static-setters (cdr names) (cdr fields))))))
+  
+  ;create-private-setters/getters fields -> (list syntax)
+  (define (create-private-setters/getters fields)
+    (if (null? fields)
+        null
+        (let* ((field (car fields))
+               (s-name (id-string (field-name field)))
+               (name (build-identifier (build-var-name s-name)))
+               (getter (create-get-name s-name))
+               (setter (create-set-name s-name)))
+          (append (list (make-syntax #f `(define/public (,getter my-val) ,name) (build-src (id-src (field-name field))))
+                        (make-syntax #f `(define/public (,setter m-obj my-val) (set! ,name my-val)) 
+                                     (build-src (id-src (field-name field)))))
+                  (create-private-setters/getters (cdr fields))))))  
+  
+  ;make-static-fiel-names: (list field) -> (list string)
+  (define (make-static-field-names fields)
+    (map (lambda (f) (build-static-name (build-var-name (id-string (field-name f))))) fields))
+
+  ;create-static-fields: (list string) (list field) -> (list syntax)
+  (define (create-static-fields names fields)
+    (if (null? names)
+        null
+        (let ((name (car names))
+              (f (car fields)))
+          (cons (make-syntax #f
+                             `(define ,(translate-id name (id-src (field-name f))) 
+                                ,(translate-field-body (and (var-init? f) f) (field-type f)))
+                             (build-src (if (var-init? f) (var-init-src f) (var-decl-src f))))
+                (create-static-fields (cdr names) (cdr fields))))))
+  
+  ;translate-field: (list symbol) type-spec id (U #f var-init) src bool -> syntax
+  (define (translate-field access type name init? src static?)
+    (let ((value (translate-field-body init? type))
+          (field-name (translate-id (build-var-name (if static? (build-static-name (id-string name)) (id-string name)))
+                                    (id-src name))))
+      (if (or static? (private? access))
+          (make-syntax #f `(define ,field-name ,value) (build-src src))
+          (make-syntax #f `(field (,field-name ,value)) (build-src src)))))
+  
+  ;translate-field-body (U bool var-init) type -> syntax
+  (define (translate-field-body init? type)
+    (if init?
+        (if (array-init? (var-init-init init?))
+            (initialize-array (array-init-vals (var-init-init init?))
+                              type)
+            (translate-expression (var-init-init init?)))
+        (get-default-value type)))
+  
+  ;translate-initialize: bool block src string type-records -> syntax
+  (define (translate-initialize static? body src type-recs)
+    (translate-block (block-stmts body) (block-src body) type-recs))
+  
+  
+  ;-------------------------------------------------------------------------------------------------------------------------
+  ;translate-statement
+  ;translates a Java statement into a Scheme expresion. 
+  ;raises an error if it has no implementation for a statement type
+  
+  ;Converted
+  ;translate-statement: statement string type-records -> syntax
+  (define translate-statement
+    (lambda (statement type-recs)
+      (cond
+        ((ifS? statement)
+         (translate-if (translate-expression (ifS-cond statement))
+                       (translate-statement (ifS-then statement) type-recs)
+                       (if (ifS-else statement)
+                           (translate-statement (ifS-else statement) type-recs)
+                           'void)
+                       (ifS-key-src statement)
+                       (ifS-src statement)))
+        ((throw? statement)
+         (translate-throw (translate-expression (throw-expr statement))
+                          (throw-key-src statement)
+                          (throw-src statement)))
+        ((return? statement) 
+         (translate-return (if (return-expr statement)
+                               (translate-expression (return-expr statement))
+                               (make-syntax #f '(void) #f))
+                           (return-in-tail? statement)
+                           (return-src statement)))
+        ((while? statement)
+         (translate-while (translate-expression (while-cond statement))
+                          (translate-statement (while-loop statement) type-recs)
+                          (while-src statement)))
+        ((doS? statement)
+         (translate-do (translate-statement (doS-loop statement) type-recs)
+                       (translate-expression (doS-cond statement))
+                       (doS-src statement)))
+        ((for? statement)
+         (translate-for (for-init statement)
+                        (translate-expression (for-cond statement))
+                        (map translate-expression (for-incr statement))
+                        (translate-statement (for-loop statement) type-recs)
+                        (for-src statement)
+                        type-recs))
+        ((try? statement)
+         (translate-try (translate-statement (try-body statement) type-recs)
+                        (try-catches statement)
+                        (and (try-finally statement)
+                             (translate-statement (try-finally statement) type-recs)) 
+                        (try-key-src statement)
+                        (try-src statement)
+                        type-recs))
+        ((switch? statement)
+         (translate-switch (translate-expression (switch-expr statement))
+                           (switch-cases statement)
+                           (switch-src statement)
+                           type-recs))
+        ((block? statement)
+         (translate-block (block-stmts statement) (block-src statement) type-recs))        
+        ((def? statement)
+         (current-local-classes (cons statement (current-local-classes)))
+         (create-syntax #f '(void) #f))
+        ((break? statement)
+         (translate-break (break-label statement)  (break-src statement)))
+        ((continue? statement)
+         (translate-continue (continue-label statement) (continue-src statement)))
+        ((label? statement)
+         (translate-label (label-label statement)
+                          (translate-statement (label-stmt statement) type-recs)
+                          (label-src statement)))
+        ((synchronized? statement)
+         (translate-synchronized (translate-expression (synchronized-expr statement))
+                                 (translate-statement (synchronized-stmt statement) type-recs)
+                                 (synchronized-src statement)))        
+        ((statement-expression? statement)
+         (translate-expression statement))
+        (else
+         (error 'translate-statement (format "translate-statement given unsupported: ~s" statement))))))
+  
+  
+  ;Converted
+  ;translate-if: syntax syntax syntax src src -> syntax
+  (define translate-if
+    (lambda (if? then else key src)
+      (create-syntax #f `(,(create-syntax #f `if (build-src key)) ,if? ,then ,else) (build-src src))))
+  
+  ;Converted
+  ;translate-throw: syntax src src -> syntax
+  (define translate-throw
+    (lambda (expr key src)
+      (create-syntax #f `(let* ((obj ,expr)
+                                (exn (make-java:exception 
+                                      (send (send obj |getMessage|) get-mzscheme-string) 
+                                      (current-continuation-marks) obj)))
+                           (send obj set-exception! exn)
+                           (,(create-syntax #f 'raise (build-src key)) exn)) 
+                     (build-src src))))
+  
+  ;return -> call to a continuation 
+  ;Presently a no-op in the interactions window, although this is incorrect for advanced and full
+  ;translate-return: syntax bool src -> syntax
+  (define (translate-return expr in-tail? src)
+    (if (or (interactions?) in-tail?)
+        (make-syntax #f expr #f)
+        (make-syntax #f `(return-k ,expr) (build-src src))))
+  
+  ;translate-while: syntax syntax src -> syntax
+  (define (translate-while cond body src)
+    (make-syntax #f `(let/ec loop-k
+                       (let loop ((dummy #f))
+                         (when ,cond
+                           ,body
+                           (loop #f))))
+                 (build-src src)))
+
+  ;translate-do: syntax syntax src -> syntax
+  (define (translate-do body cond src)
+    (make-syntax #f `(let/ec loop-k
+                       (let loop ((dummy #f))
+                         ,body
+                         (when ,cond (loop #f))))
+                 (build-src src)))
+  
+  ;translate-for: (U (list statement) (list field)) syntax (list syntax) syntax src type-records-> syntax
+  (define (translate-for init cond incr body src type-recs)
+    (let ((loop `(let/ec loop-k
+                   (let loop ((continue? #f))
+                     (when continue? ,@(if (null? incr) '((void)) incr))
+                     (when ,cond 
+                       ,body
+                       ,@incr
+                       (loop #f)))))
+          (source (build-src src)))
+      (if (and (pair? init) (field? (car init)))
+          (make-syntax #f `(letrec (,@(map (lambda (var)
+                                             `(,(translate-id (build-var-name (id-string (field-name var)))
+                                                              (id-src (field-name var)))
+                                                ,(if (var-init? var)
+                                                     (if (array-init? (var-init-init var))
+                                                         (initialize-array (array-init-vals (var-init-init var)) 
+                                                                           (field-type var))
+                                                         (translate-expression (var-init-init var)))
+                                                     (get-default-value (field-type var))))) 
+                                           init))
+                             ,loop) source)
+          (make-syntax #f `(begin
+                             ,@(map (lambda (s) (translate-statement s type-recs)) init)
+                             ,loop)
+                       source))))
+  
+  ;Converted
+  ;initialize-array: (list (U expression array-init)) type-spec-> syntax
+  (define (initialize-array inits type)
+    (cond
+      ((null? inits) 
+       (make-syntax #f `(make-java-array ,(translate-type-spec type) 0 null) #f))
+;       (error 'initialize-array "Given empty list"))
+      ((array-init? (car inits))
+       (make-syntax #f
+                    `(make-java-array ,(translate-type-spec type)
+                                      0
+                                      (reverse (list ,@(map (lambda (a) (initialize-array (array-init-vals a)
+                                                                                          (make-type-spec (type-spec-name type)
+                                                                                                          (sub1 (type-spec-dim type))
+                                                                                                          (type-spec-src type))))
+                                                            inits))))
+                    (build-src (array-init-src (car inits)))))
+      (else
+       (make-syntax #f
+                    `(make-java-array ,(translate-type-spec type)
+                                      0
+                                      (reverse (list ,@(map translate-expression inits))))
+                    (build-src (if (name? (car inits)) (name-src (car inits)) (expr-src (car inits))))))))
+  
+  ;Converted
+  ;translate-try: syntax (list catch) (U syntax boolean) src src type-records-> syntax
+  (define translate-try
+    (lambda (block catches finally key src type-recs)
+      (let* ((handle (create-syntax #f 'with-handlers (build-src key)))
+             (handlers (make-syntax #f `(,handle [ ,@(make-predicates catches type-recs) ]
+                                         ,block)
+                                    (build-src src))))
+        (if finally
+            (make-syntax #f
+                         `(dynamic-wind void
+                                        (lambda () ,handlers)
+                                        (lambda () ,finally))
+                         #f)
+            handlers))))
+  
+  ;Converted
+  ;make-predicates: (list catch) type-records-> (list syntax)
+  (define make-predicates
+    (lambda (catches type-recs)
+      (map (lambda (catch)
+             (let* ((catch-var (catch-cond catch))
+                    (var-src (var-decl-src catch-var))
+                    (class-name (get-class-name (field-type catch-var)))
+                    (isRuntime? (descendent-Runtime? (field-type catch-var) type-recs))
+                    (type 
+                     (if isRuntime?
+                         (make-syntax #f `exn? (build-src var-src))
+                         (make-syntax #f 
+                                      `(javaException:exception-is-a? ,class-name)
+                                      (build-src var-src))))
+                    (parm (translate-id (build-var-name (id-string (field-name catch-var)))
+                                        (id-src (field-name catch-var))))
+                    (block (make-syntax #f
+                                        `(lambda (,parm)
+                                           ,(translate-statement (catch-body catch) type-recs))
+                                        (build-src (catch-src catch)))))
+               (make-syntax #f `(,type                       
+                                 ,(if isRuntime?
+                                      `(lambda (exn)
+                                         (if (javaException:supported-runtime-exception? exn)
+                                             (,block (javaException:exception-to-class exn))
+                                             (raise exn)))
+                                      block))
+                            (build-src (catch-src catch)))))
+           catches)))
+  
+  ;Determines if the given type represents a class that is a descendent of the RuntimeException class
+  ;descendent-Runtime?: type-spec type-records -> bool
+  (define descendent-Runtime?
+    (lambda (type type-recs)
+      (let ((class-record (send type-recs get-class-record (type-spec-to-type type #f 'full type-recs) #f
+                                (lambda () (error 'descendent-Runtime "Internal Error: class record is not in table")))))
+        (member `("java" "lang" "RuntimeException") (class-record-parents class-record)))))
+  
+  ;Converted
+  ;translate-switch: syntax (list CaseStatements) src type-records -> syntax
+  (define translate-switch
+    (lambda (expr cases src type-recs)
+      (make-syntax #f
+                   `(case ,expr
+                      ,@(map (lambda (case) 
+                               (if (eq? (caseS-constant case) 'default)
+                                   (if (null? (caseS-body case))
+                                       `(else (void))
+                                       `(else ,(translate-block (caseS-body case) (caseS-src case) type-recs)))
+                                   `((,(translate-expression (caseS-constant case))
+                                      ,(translate-block (caseS-body case) (caseS-src case) type-recs)))))
+                             cases))
+                   (build-src src))))
+  
+  ;Converted
+  ;translate-block: (list (U Statement (U var-decl var-init))) src type-recs -> syntax
+  (define translate-block
+    (lambda (statements src type-recs)
+      ;(list (U Statement (U var-decl var-init))) -> (list syntax)
+      (letrec ((translate
+                (lambda (statements)
+                  (if (null? statements)
+                      null
+                      (let ((statement (car statements)))
+                        (if (field? statement)
+                            (translate-var (car statements) (cdr statements))
+                            (cons (translate-statement statement type-recs)
+                                  (translate (cdr statements))))))))
+               (translate-var
+                (lambda (var statements)
+                  (let* ((is-var-init? (var-init? var))
+                         (id (translate-id (build-var-name (id-string (field-name var))) (id-src (field-name var)))))
+                    (list (make-syntax #f 
+                                       `(letrec
+                                            ((,id ,(if is-var-init?
+                                                       (if (array-init? (var-init-init var))
+                                                           (initialize-array (array-init-vals (var-init-init var))
+                                                                             (field-type var))
+                                                           (translate-expression (var-init-init var)))
+                                                       (get-default-value (field-type var)))))
+                                          ,@(if (null? statements)
+                                                (list `(void))
+                                                (translate statements)))
+                                       (build-src (if is-var-init?
+                                                      (var-init-src var)
+                                                      (var-decl-src var)))))))))
+        (if (null? statements)
+            (make-syntax #f `void (build-src src))
+            (make-syntax #f `(begin ,@(translate statements)) (build-src src))))))
+  
+  ;translate-break: (U id #f) src -> syntax
+  (define (translate-break id src)
+    (if (not id)
+        (make-syntax #f `(loop-k (void)) (build-src src))
+        (make-syntax #f `(,(translate-id (string-append (id-string id "-k")) (id-src id)) void) (build-src src))))
+  
+  ;Converted
+  ;translate-continue: (U string #f) src -> syntax
+  (define (translate-continue id src)
+    (if (not id)
+        (make-syntax #f `(loop-k (loop #t)) (build-src src))
+        (make-syntax #f `(,(translate-id (string-append (id-string id) "-k") (id-src id)) 
+                           (,(build-identifier (string-append (id-string id) "-continue"))))
+                     (build-src src))))
+  
+  ;translate-label: id syntax src -> syntax
+  ;NOTE: probably does not have correct behavior
+  (define translate-label
+    (lambda (label stmt src)
+      (make-syntax #f
+                   `(let/ec ,(translate-id (string-append (id-string label) "-k") (id-src label))
+                      (letrec ((,(build-identifier (string-append (id-string label) "-continue"))
+                                (lambda () ,stmt)))
+                        (,(build-identifier (string-append (id-string label) "-continue")))))
+                   (build-src src))))
+  
+  ;translate-synchronized: syntax syntax src -> syntax
+  ;PROBLEM! Does nothing
+  (define translate-synchronized
+    (lambda (expr stmt src)
+      (make-syntax #f
+                   `(begin ,expr ,stmt)
+                   (build-src src))))
+
+  ;------------------------------------------------------------------------------------------------------------------
+  ;translate-contract
+  ;translates types into contracts
+
+  ;type->contract: type -> sexp
+  (define (type->contract type)
+    (cond
+      ((symbol? type)
+       (case type
+         ((int short long byte) 'integer?)
+         ((long float) '(c:and/c number? inexact?))
+         ((boolean) 'boolean?)
+         ((char) 'char?)
+         ((string) `(c:is-a?/c ,(if (send (types) require-prefix '("String" "java" "lang") (lambda () #f))
+                                    'java.lang.String 'String)))))
+      ((ref-type? type) 
+       (let ((class-name (cons (ref-type-class/iface type) (ref-type-path type))))
+       `(c:is-a?/c 
+         ,(build-identifier (if (send (types) require-prefix class-name (lambda () #f))
+                                (format "~a~a" (apply string-append (map (lambda (s) (string-append s "."))
+                                                                         (map id-string (ref-type-path type))))
+                                        (ref-type-class/iface type))
+                                (ref-type-class/iface type))))))
+      ((unknown-ref? type)
+       `(c:object-contract ,@(map (lambda (m) 
+                                    `(,(string->symbol (java-name->scheme (method-contract-name m)))
+                                       ,(type->contract m)))
+                                  (unknown-ref-methods type))
+                           ,@(map (lambda (f) `(field ,(string->symbol (java-name->scheme (scheme-val-name f)))
+                                                      ,(type->contract (scheme-val-type f))))
+                                  (unknown-ref-fields type))))
+      ((method-contract? type)
+       `(c:-> ,@(map type->contract (map scheme-val-type (method-contract-args type)))
+              ,(type->contract (scheme-val-type (method-contract-return type)))))
+      ((not type) 'c:any/c)
+      ))
+  
+  ;------------------------------------------------------------------------------------------------------------------------
+  ;translate-expression
+  ;translates a Java expression into a Scheme expression.
+  ;raises an error if it has no implementation for an expression type
+  
+  ;translate-expression: Expression -> syntax
+  (define translate-expression
+    (lambda (expr)
+      (cond
+        ((literal? expr) (translate-literal (expr-types expr)
+                                            (literal-val expr)
+                                            (expr-src expr)))
+        ((bin-op? expr) (translate-bin-op (bin-op-op expr)
+                                          (translate-expression (bin-op-left expr))
+                                          (expr-types (bin-op-left expr))
+                                          (translate-expression (bin-op-right expr))
+                                          (expr-types (bin-op-right expr))
+                                          (bin-op-key-src expr)
+                                          (expr-src expr)
+                                          (expr-types expr)))
+        ((access? expr) (translate-access (access-name expr)
+                                          (expr-types expr)
+                                          (expr-src expr)))
+        ((special-name? expr) (translate-special-name (special-name-name expr)
+                                                      (expr-src expr)))
+        ((specified-this? expr) (translate-specified-this (specified-this-var expr) (expr-src expr)))
+        ((call? expr) (translate-call (call-expr expr)
+                                      (call-method-name expr)
+                                      (map translate-expression (call-args expr))
+                                      (call-method-record expr)
+                                      (expr-src expr)))
+        ((class-alloc? expr) (translate-class-alloc (class-alloc-name expr)
+                                                    (map expr-types (class-alloc-args expr))
+                                                    (map translate-expression (class-alloc-args expr))
+                                                    (expr-src expr)
+                                                    (class-alloc-class-inner? expr)
+                                                    (class-alloc-local-inner? expr)
+                                                    (class-alloc-ctor-record expr)))
+        ((inner-alloc? expr) (translate-inner-alloc (translate-expression (inner-alloc-obj expr))
+                                                    (inner-alloc-name expr)
+                                                    (map translate-expression (inner-alloc-args expr))
+                                                    (expr-src expr)
+                                                    (inner-alloc-ctor-record expr)))
+        ((array-alloc? expr)(translate-array-alloc (array-alloc-name expr)
+                                                   (map translate-expression (array-alloc-size expr))
+                                                   (expr-src expr)))
+        ((array-alloc-init? expr)(translate-array-alloc-init (array-alloc-init-name expr)
+                                                             (array-alloc-init-dim expr)
+                                                             (array-alloc-init-init expr)
+                                                             (expr-src expr)))
+        ((cond-expression? expr) (translate-cond (translate-expression (cond-expression-cond expr))
+                                                 (translate-expression (cond-expression-then expr))
+                                                 (translate-expression (cond-expression-else expr))
+                                                 (expr-src expr)))
+        ((array-access? expr) (translate-array-access (translate-expression (array-access-name expr))
+                                                      (translate-expression (array-access-index expr))
+                                                      (expr-src expr)))
+        ((post-expr? expr) (translate-post-expr (translate-expression (post-expr-expr expr))
+                                                (post-expr-op expr)
+                                                (post-expr-key-src expr)
+                                                (expr-src expr)))
+        ((pre-expr? expr) (translate-pre-expr (pre-expr-op expr)
+                                              (translate-expression (pre-expr-expr expr))
+                                              (pre-expr-key-src expr)
+                                              (expr-src expr)))
+        ((unary? expr) (translate-unary (unary-op expr)
+                                        (translate-expression (unary-expr expr))
+                                        (unary-key-src expr)
+                                        (expr-src expr)))
+        ((cast? expr) (translate-cast (cast-type expr)
+                                      (translate-expression (cast-expr expr))
+                                      (expr-src expr)))
+        ((instanceof? expr) (translate-instanceof (translate-expression (instanceof-expr expr))
+                                                  (instanceof-type expr)
+                                                  (expr-src expr)))
+        ((assignment? expr) (translate-assignment (assignment-left expr)
+                                                  (assignment-op expr)
+                                                  (translate-expression (assignment-right expr))
+                                                  (assignment-right expr)
+                                                  (expr-types expr)
+                                                  (assignment-key-src expr)
+                                                  (expr-src expr)))
+        (else
+         (error 'translate-expression (format "Translate Expression given unrecognized expression ~s" expr))))))
+  
+  ;All of the following functions translate Java Expressions into syntax.
+  ;Straightforward unless otherwise noted
+  
+  ;translate-literal: symbol value src -> syntax
+  (define (translate-literal type value src)
+    (let ((make-string  `(let ((temp-obj (make-object |String|)))
+                         (send temp-obj make-mzscheme-string ,value)
+                         temp-obj)))
+      (create-syntax #f 
+                     (case type
+                       ((char int long float double boolean) value)
+                       ((String string) make-string)
+                       ((null) 'null)
+                       (else
+                        (if (eq? type string-type)
+                            make-string
+                            (error 'translate-literal (format "Translate literal given unknown type: ~s" type)))))
+                   (build-src src))))
+  
+  ;;make-is-test sym -> (type -> bool)
+  (define (make-is-test kind)
+    (lambda (type)
+      (if (scheme-val? type)
+        (eq? (scheme-val-type type) kind)
+        (eq? type kind))))
+  
+  ;;is-string? type -> bool
+  (define is-string? (make-is-test 'string))
+  ;;is-int? type -> bool
+  (define is-int? (make-is-test 'int))
+  ;;is-char? type -> bool
+  (define is-char? (make-is-test 'char))
+  
+  ;Converted
+  ;translate-bin-op: symbol syntax type syntax type src src type-> syntax
+  (define (translate-bin-op op left left-type right right-type key src type)
+    (let* ((source (build-src src))
+           (op-syntax (create-syntax #f op (build-src key)))
+           (left (if (is-char? left-type)
+                     (make-syntax #f `(char->integer ,left) #f)
+                     left))
+           (right (if (is-char? right-type)
+                      (make-syntax #f `(char->integer ,right) #f)
+                      right))
+           (result
+            (case op
+              ;Mathematical operations
+              ;PROBLEM! + and - do not take into account the possibility of overflow
+              ((+)
+               (cond 
+                 ((and (is-string-type? type) (is-string-type? left-type))
+                  (make-syntax #f `(send ,left concat-java.lang.String (javaRuntime:convert-to-string ,right)) source))
+                 ((and (is-string-type? type) (is-string-type? right-type))
+                  (make-syntax #f `(send (javaRuntime:convert-to-string ,left) concat-java.lang.String ,right) source))
+                 ((is-string-type? type)
+                  (make-syntax #f 
+                               `(send (javaRuntime:convert-to-string ,left) concat-java.lang.String 
+                                      (javaRuntime:convert-to-string ,right)) 
+                               source))
+                 (else
+                  (create-syntax #f `(,op-syntax ,left ,right) source))))
+              ((- *) (make-syntax #f `(,op-syntax ,left ,right) source))
+              ((/) (if (is-int? type)
+                       (make-syntax #f `(,(create-syntax #f 'javaRuntime:divide-int (build-src key)) ,left ,right) source)
+                       (make-syntax #f `(,(create-syntax #f 'javaRuntime:divide-float (build-src key)) ,left ,right) source)))
+              ((%) (make-syntax #f `(,(create-syntax #f 'javaRuntime:mod (build-src key)) ,left ,right) source))
+              ;Shift operations
+              ((<< >> >>>) (make-syntax #f `(,(create-syntax #f 'javaRuntime:shift (build-src key)) (quote ,op) ,left ,right) source))
+              ;comparisons
+              ((< > <= >=) (make-syntax #f `(,op-syntax ,left ,right) source))
+              ((==) 
+               (if (and (prim-numeric-type? left-type) (prim-numeric-type? right-type))
+                   (make-syntax #f `(,(create-syntax #f '= (build-src key)) ,left ,right) source)
+                   (make-syntax #f `(,(create-syntax #f 'eq? (build-src key)) ,left ,right) source)))
+              ((!=) (make-syntax #f `(,(create-syntax #f 'javaRuntime:not-equal (build-src key)) ,left ,right) source))
+              ;logicals
+              ((& ^ or) (make-syntax #f `(,(create-syntax #f 'javaRuntime:bitwise (build-src key)) (quote ,op) ,left ,right) source))
+              ;boolean
+              ((&&) (make-syntax #f `(,(create-syntax #f 'javaRuntime:and (build-src key)) ,left ,right) source))
+              ((oror) (make-syntax #f `(,(create-syntax #f 'javaRuntime:or (build-src key)) ,left ,right) source))
+              (else
+               (error 'translate-op (format "Translate op given unknown operation ~s" op))))))
+      (if (scheme-val? type)
+          (make-syntax #f `(contract ,(type->contract (scheme-val-type type)) ,result 'scheme 'java) source)
+          result)))
+
+  ;translate-access: (U field-access local-access) type src -> syntax
+  (define (translate-access name type src)
+    (cond
+      ((local-access? name)
+       (translate-id (build-var-name (id-string (local-access-name name)))
+                     (id-src (local-access-name name))))
+      ((field-access? name)
+       (let* ((field-string (id-string (field-access-field name)))
+              (field-src (id-src (field-access-field name)))
+              (access (field-access-access name))
+              (obj (field-access-object name))
+              (cant-be-null? (never-null? obj))
+              (expr (if obj (translate-expression obj))))
+         (cond
+           ((var-access-static? access)
+            (if (scheme-val? type)
+                (make-syntax #f
+                             `(c:contract ,(type->contract (scheme-val-type type))
+                                          ,(translate-id (build-static-name field-string (var-access-class access)) field-src)
+                                          'scheme 'java)
+                             (build-src field-src))
+                (translate-id (build-var-name (build-static-name field-string (var-access-class access)))
+                              field-src)))
+           ((eq? 'array (var-access-class access))
+            (if cant-be-null?
+                (make-syntax #f `(send ,expr ,(translate-id field-string field-src)) (build-src src))
+                (make-syntax #f
+                             `(if (null? ,expr)
+                                  (javaRuntime:nullError 'field)
+                                  (send ,expr ,(translate-id field-string field-src)))
+                             (build-src src))))
+           ((and (eq? (var-access-access access) 'private) (static-method))
+            (let ((id (create-get-name field-string (var-access-class access))))
+              (if cant-be-null?
+                  (make-syntax #f `(send ,expr ,id ,expr) (build-src src))
+                  (make-syntax #f `(if (null? ,expr)
+                                       (javaRuntime:nullError 'field)
+                                       (send ,expr ,id ,expr))
+                               (build-src src)))))
+           (else
+              (let ((id (create-get-name field-string (var-access-class access))))
+                (if cant-be-null?
+                    (make-syntax #f `(,id ,expr) (build-src src))
+                    (make-syntax #f
+                                 `(if (null? ,expr)
+                                      (javaRuntime:nullError 'field)
+                                      (,id ,expr))
+                                 (build-src src))))))))))
+  
+  ;translate-special-name: string src -> syntax
+  (define (translate-special-name name src)
+    (let ((id (build-identifier name)))
+      (make-syntax #f id (build-src src))))
+  
+  ;translate-specified-this: string src -> syntax
+  (define (translate-specified-this var src)
+    (make-syntax #f (build-identifier (string-append var "~f")) (build-src src)))
+  
+  ;translate-call: (U expression #f) (U special-name id) (list syntax) method-record src-> syntax
+  (define (translate-call expr method-name args method-record src)
+    (let ((cant-be-null? (never-null? expr))
+          (expression (if expr (translate-expression expr) #f))
+          (unique-name (gensym)))
+      (cond
+        ;Constructor case
+        ((special-name? method-name)
+         (let* ((name (if (equal? (special-name-name method-name) "super")
+                          (parent-name)
+                          (class-name)))
+                (c-name (build-identifier (build-constructor-name name
+                                                                  (method-record-atypes method-record))))
+                (generic-c-name (build-identifier (build-generic-name name c-name))))
+           #;(create-syntax #f
+                          (cond
+                            ((equal? (special-name-name method-name) "this")
+                             `(,c-name ,@args))
+                            ((equal? (parent-name) "Object")
+                             `(send ,(if expr expression 'this) ,c-name ,@args))
+                            ((and expr cant-be-null?)
+                             `(send-generic ,expression ,generic-c-name ,@args))
+                            ((not expr)
+                             `(send-generic this ,generic-c-name ,@args))
+                            (else
+                             `(let ((,unique-name ,expression))
+                                (if (null? ,unique-name)
+                                    (javaRuntime:nullError 'method)
+                                    (send-generic ,unique-name ,generic-c-name ,@args)))))
+                          (build-src src))
+           
+           (if cant-be-null?
+               (create-syntax #f `(send ,(if expr expression 'this) ,c-name ,@args) (build-src src))
+               (create-syntax #f 
+                              `(let ((,unique-name ,expression))
+                                 (if (null? ,unique-name)
+                                     (javaRuntime:nullError 'method)
+                                     (send ,unique-name ,c-name ,@args)))
+                              (build-src src)))))
+          
+        ;Normal case
+        ((id? method-name)
+         (let* ((static? (unless (method-contract? method-record)
+                           (memq 'static (method-record-modifiers method-record))))
+                (temp (unless (method-contract? method-record)
+                        (mangle-method-name (method-record-name method-record)
+                                            (method-record-atypes method-record))))
+                (m-name (unless (method-contract? method-record)
+                          (if static?
+                              (build-static-name temp (car (method-record-class method-record)))
+                              temp)))
+                (generic-name (unless (method-contract? method-record)
+                                (build-generic-name (car (method-record-class method-record)) m-name))))
+           (cond 
+             ((special-name? expr)
+              (let* ((over? (overridden? (string->symbol m-name)))
+                     (name (translate-id m-name 
+                                         #;(if (and (equal? (special-name-name expr) "super") over?)
+                                               (format "super.~a" m-name)
+                                               m-name)
+                                           (id-src method-name))))
+                (cond
+                  (static? (create-syntax #f `(,name ,@args) (build-src src)))
+                  (over? (create-syntax #f `(super ,name ,@args) (build-src src)))
+                  (else (create-syntax #f `(send this ,name ,@args) (build-src src))))))
+             ((not expr)
+              (cond
+                ((method-contract? method-record)
+                 (create-syntax #f `((contract ,(type->contract method-record) 
+                                               ,(java-name->scheme (method-contract-name method-record)))
+                                     ,@args) (build-src src)))
+                ((or static? (memq 'private (method-record-modifiers method-record)))
+                 (create-syntax #f `(,(translate-id m-name (id-src method-name)) ,@args) (build-src src)))
+                (else
+                 (create-syntax #f `(send this ,(translate-id m-name (id-src method-name)) ,@args) (build-src src)))))
+             (else
+              (let ((name (translate-id m-name (id-src method-name))))
+                (cond
+                  ((and cant-be-null? (not static?))          
+                   (create-syntax #f `(send ,expression ,name ,@args) (build-src src)))
+                  (static? (create-syntax #f `(,name ,@args) (build-src src)))
+                  (else
+                   (create-syntax #f
+                                  `(let ((,unique-name ,expression))
+                                     (if (null? ,unique-name)
+                                         (javaRuntime:nullError 'method)
+                                         (send ,unique-name ,name ,@args)))
+                                  (build-src src)))))))))
+        
+        (else (error 'translate-call (format "Translate call given ~s as method-name" method-name))))))
+
+  ;Add more checks perhaps to see in other cases if it can be null
+  ;never-null? expression -> bool
+  (define (never-null? expr)
+    (cond
+      ((not expr) #t)
+      ((special-name? expr) #t)
+      ((class-alloc? expr) #t)
+      ((and (access? expr)
+            (local-access? (access-name expr))
+            (regexp-match "encl-this-" (id-string (local-access-name (access-name expr))))) #t)
+      (else #f)))
+  
+  (define (overridden? name)
+    (hash-table-get (class-override-table) name (lambda () #f)))
+  
+  ;translate-class-alloc: (U name id def) (list type) (list syntax) src bool bool method-record-> syntax
+  (define (translate-class-alloc class-type arg-types args src inner? local-inner? ctor-record)
+    (when (id? class-type) (set! class-type (make-name class-type null (id-src class-type))))
+    (let* ((class-string 
+            (if (def? class-type)
+                (get-class-string (make-name (def-name class-type) null #f))
+                (get-class-string class-type)))
+           (class-id (if (def? class-type)
+                         (def-name class-type)
+                         (name-id class-type)))
+           (default-name (translate-id class-string (id-src class-id)))
+           (default-ctor (translate-id (build-constructor-name 
+                                        (cond
+                                          (local-inner?
+                                           (regexp-replace "-[0-9]*" (method-record-name ctor-record) ""))
+                                          ((and (name? class-type) (null? (name-path class-type)))
+                                           class-string)
+                                          (else (id-string (name-id class-type))))
+                                        (method-record-atypes ctor-record))
+                                       (id-src class-id))))
+      (make-syntax
+       #f
+       (cond
+         (local-inner?
+          `(let ((new-o (make-object ,default-name 
+                          ,@(if (static-method)
+                                null
+                                (let loop ((d (current-depth)))
+                                  (cond
+                                    ((= d 0) '(this))
+                                    (else (cons (build-identifier (format "encl-this-~a~~f" d))
+                                                (loop (sub1 d)))))))
+                          ,@(let loop ((args (def-closure-args
+                                               (if (def? class-type)
+                                                   class-type
+                                                   (find-inner class-string (current-local-classes))))))
+                              (cond
+                                ((null? args) null)
+                                (else (cons (translate-id (string-append (id-string (car args)) "~f") #f)
+                                            (loop (cdr args)))))))))
+             (send new-o ,default-ctor ,@args)
+             new-o))
+         (inner?
+          `(send this ,(translate-id (mangle-method-name (string-append "construct-" class-string)
+                                                         (method-record-atypes ctor-record))
+                                     (id-src class-id))
+                 ,@args))
+         (else `(let ((new-o (make-object ,default-name)))
+                  (send new-o ,default-ctor ,@args)
+                  new-o)))
+       (build-src src))))
+  
+  ;find-inner: string (list def) -> def
+  (define (find-inner name classes)
+    (cond
+      ((equal? name (id-string (def-name (car classes))))
+       (car classes))
+      (else (find-inner name (cdr classes)))))
+        
+  
+  ;translate-inner-alloc: syntax id (list syntax) src method-record -> syntax
+  (define (translate-inner-alloc obj class args src ctor-record)
+    (make-syntax #f `(send ,obj ,(translate-id (mangle-method-name (string-append "construct-"
+                                                                                  (get-class-string (make-name class null #f)))
+                                                                   (method-record-atypes ctor-record))
+                                               (id-src class))
+                           ,@args)
+                 (build-src src)))
+  
+  ;translate-array-alloc: type-spec (list syntax) src -> syntax
+  (define (translate-array-alloc type sizes src)
+    (create-array sizes (translate-type-spec type) src))
+  
+  ;create-array: (list syntax) type src -> syntax
+  (define (create-array sizes type src)
+    (cond
+      ((null? sizes)
+       (error 'create-array "Internal Error: create array given a null list"))
+      ((null? (cdr sizes))
+       (make-syntax #f `(make-java-array ,type ,(car sizes) null) (build-src src)))
+      (else
+       (make-syntax #f `(make-java-array ,type (list ,@sizes) null) (build-src src)))))
+
+  ;translate-array-alloc-init: type-spec int array-init src
+  (define (translate-array-alloc-init type dim init src)
+    (initialize-array type (array-init-vals init)))
+    
+  ;translate-type-spec: type-spec -> syntax
+  (define (translate-type-spec type)
+    (make-syntax #f
+                 `(make-runtime-type ,(if (symbol? (type-spec-name type))
+                                          `(quote ,(type-spec-name type))
+                                          (build-identifier 
+                                           (if (null? (name-path (type-spec-name type)))
+                                               (id-string (name-id (type-spec-name type)))
+                                               (append (map id-string (name-path (type-spec-name type)))
+                                                       (list (id-string (name-id (type-spec-name type))))))))
+                                     ,(type-spec-dim type))
+                 (build-src (type-spec-src type))))
+  
+  ;converted
+  ;translate-array-access: syntax syntax src -> syntax
+  (define translate-array-access
+    (lambda (array index src)
+      (make-syntax #f `(send ,array access ,index) 
+                   (build-src src))))
+  
+  ;converted
+  ;translate-cond: syntax syntax syntax src -> syntax
+  (define translate-cond
+    (lambda (if? then else src)
+      (make-syntax #f `(if ,if? ,then ,else) (build-src src))))
+  
+  ;converted
+  ;translate-post-expr: syntax symbol src src -> syntax
+  (define translate-post-expr
+    (lambda (expr op key src)
+      (make-syntax #f `(begin0
+                         ,expr
+                         (set! ,expr ( ,(create-syntax #f (if (eq? op '++) 'add1 'sub1) (build-src key))
+                                       ,expr)))
+                   (build-src src))))
+  
+  ;converted
+  ;translate-pre-expr: symbol syntax src src -> syntax
+  (define translate-pre-expr
+    (lambda (op expr key src)
+      (make-syntax #f
+                   `(begin
+                      (set! ,expr (,(create-syntax #f (if (eq? op '++) 'add1 'sub1) (build-src key))
+                                   ,expr))
+                      ,expr)
+                   (build-src src))))
+  
+  ;converted
+  ;translate-unary: symbol syntax src src -> syntax
+  (define translate-unary
+    (lambda (op expr key src)
+      (make-syntax #f  (case op
+                         ((-) `(,(create-syntax #f '- (build-src key)) ,expr))
+                         ((!) `(,(create-syntax #f 'not (build-src key)) ,expr))
+                         ((~) `(,(create-syntax #f '- (build-src key)) (- ,expr) 1))
+                         ((+) expr))
+                   (build-src src))))
+  
+  ;converted
+  ;translate-cast: type-spec syntax src
+  (define (translate-cast type expr src)
+    (if (symbol? (type-spec-name type))
+        (make-syntax #f `(javaRuntime:cast-primitive ,expr (quote ,(type-spec-name type)) ,(type-spec-dim type))
+                     (build-src src))
+        (make-syntax #f `(javaRuntime:cast-reference ,expr ,(get-class-name type) 
+                                                     ,(type-spec-dim type) 
+                                                     (quote ,(get-class-name type)))
+                     (build-src src))))
+  
+  ;translate-instanceof: syntax type-spec src -> syntax
+  (define (translate-instanceof expr type src)
+    (if (> (type-spec-dim type) 0)
+        (make-syntax #f
+                     (if (symbol? (type-spec-name type))
+                         `(javaRuntime:instanceof-array #t ,expr (quote ,(type-spec-name type)) ,(type-spec-dim type))
+                         `(javaRuntime:instanceof-array #f ,expr ,(get-class-name type) ,(type-spec-dim type)))
+                     (build-src src))
+        (let ((syntax-type (get-class-name type)))
+          (if (or (eq? (syntax-e syntax-type) 'Object) (eq? (syntax-e syntax-type) 'java.lang.Object))
+              (make-syntax #f `(is-a? ,expr ObjectI) (build-src src))
+              (make-syntax #f `(is-a? ,expr ,syntax-type) (build-src src))))))
+  
+  ;translate-assignment: (U access array-access) symbol syntax expression ?? src src -> syntax
+  (define (translate-assignment name op expr assign-to type key src)
+    (let ((expression (lambda (name) (case op
+                                       ((=) expr)
+                                       ((*=) `(* ,name ,expr))
+                                       ((/=) `(/ ,name ,expr))
+                                       ((+=) `(+ ,name ,expr))
+                                       ((-=) `(- ,name ,expr))
+                                       ((>>=) `(javaRuntime:shift '>> ,name ,expr))
+                                       ((<<=) `(javaRuntime:shift '<< ,name ,expr))
+                                       ((>>>=) `(javaRuntime:shift '>>> ,name ,expr))
+                                       ((%= &= ^= or=) 
+                                        (error 'translate-assignment "Only supports =, +=, -=, *=, & /= >>= <<= >>>= at this time"))))))
+      (cond 
+        ((array-access? name)
+         (translate-array-mutation name expression assign-to src))
+        ((access? name)
+         (let* ((access (access-name name))
+                (src-h (build-src src))
+                (set-h 
+                 (lambda (id)
+                   (make-syntax #f `(begin (,(create-syntax #f 'set! (build-src key))
+                                            ,id ,(expression id)) ,id) src-h))))
+           (cond
+             ((local-access? access)
+              (set-h (translate-id (build-var-name (id-string (local-access-name access)))
+                                   (id-src (local-access-name access)))))
+             ((field-access? access)
+              (let* ((field (id-string (field-access-field access)))
+                     (field-src (id-src (field-access-field access)))
+                     (vaccess (field-access-access access))
+                     (obj (field-access-object access))
+                     (expr (if obj (translate-expression obj))))
+                (cond
+                  ((var-access-static? vaccess)
+                   (set-h (build-identifier (build-static-name (build-var-name field)
+                                                               (build-identifier (var-access-class vaccess))))))
+                  ((not obj) (set-h (translate-id (build-var-name field) field-src)))
+                  (else
+                   (let ((setter (create-set-name field (var-access-class vaccess)))
+                         (getter (create-get-name field (var-access-class vaccess)))
+                         (name (gensym 'field-obj))
+                         (new-val (gensym 'val)))
+                     (make-syntax #f
+                                  `(let* ((,name ,expr)
+                                          (,new-val ,(expression `(,getter ,name))))
+                                     (,setter ,name ,new-val)
+                                     ,new-val)
+                                  src-h))))))))))))
+  
+  ;translate-array-mutation: array-access (syntax -> (list symbol syntax syntax)) expression src -> syntax
+  (define (translate-array-mutation array expression expr src)
+    (let ((array-name (translate-expression (array-access-name array)))
+          (array-index (translate-expression (array-access-index array)))
+          (name (gensym 'my-expr))
+          (index (gensym 'my-index))
+          (new-val (gensym 'val)))
+      (make-syntax #f
+                   `(let* ((,name ,array-name)
+                           (,index ,array-index)
+                           (,new-val ,(expression `(send ,name access ,index))))
+                      (send ,name set ,index ,new-val)
+                      ,new-val)
+                   (build-src src))))
+  
+  ;translate-id: string src -> syntax
+  (define translate-id
+    (lambda (id src)
+      (create-syntax #f (build-identifier id) (build-src src))))
+  
+  )
\ No newline at end of file
diff --git a/collects/profj/tool.ss b/collects/profj/tool.ss
new file mode 100644
index 0000000000..e8c68ae950
--- /dev/null
+++ b/collects/profj/tool.ss
@@ -0,0 +1,908 @@
+(module tool mzscheme
+  (require (lib "tool.ss" "drscheme")
+           (lib "mred.ss" "mred") (lib "framework.ss" "framework") (lib "unitsig.ss") 
+           (lib "include-bitmap.ss" "mrlib") (lib "etc.ss")
+           (lib "class.ss")
+	   (lib "string-constant.ss" "string-constants")
+           (lib "Object.ss" "profj" "libs" "java" "lang") (lib "array.ss" "profj" "libs" "java" "lang")
+           (lib "String.ss" "profj" "libs" "java" "lang"))
+  (require "compile.ss" "parameters.ss" "parsers/lexer.ss" "parser.ss" "ast.ss")
+
+  (require-for-syntax "compile.ss")
+  
+  (provide tool@)
+
+  ;Set the default classpath
+  (preferences:set-default 'profj:classpath null (lambda (v) (and (list? v) (andmap string? v))))
+  
+  (define tool@
+    (unit/sig drscheme:tool-exports^
+      (import drscheme:tool^)
+
+      ;Set the Java editing colors
+      (define color-prefs-table
+        `((keyword ,(make-object color% "black") ,(string-constant profj-java-mode-color-keyword))
+          (string ,(make-object color% "forestgreen") ,(string-constant profj-java-mode-color-string))
+          (literal ,(make-object color% "forestgreen") ,(string-constant profj-java-mode-color-literal))
+          (comment ,(make-object color% 194 116 31) ,(string-constant profj-java-mode-color-comment))
+          (error ,(make-object color% "red") ,(string-constant profj-java-mode-color-error))
+          (identifier ,(make-object color% 38 38 128) ,(string-constant profj-java-mode-color-identifier))
+          (default ,(make-object color% "black") ,(string-constant profj-java-mode-color-default))))
+      
+      ;; short-sym->pref-name : symbol -> symbol
+      ;; returns the preference name for the color prefs
+      (define (short-sym->pref-name sym) (string->symbol (short-sym->style-name sym)))
+      
+      ;; short-sym->style-name : symbol->string
+      ;; converts the short name (from the table above) into a name in the editor list
+      ;; (they are added in by `color-prefs:register-color-pref', called below)
+      (define (short-sym->style-name sym) (format "profj:syntax-coloring:scheme:~a" sym))
+      
+      ;; extend-preferences-panel : vertical-panel -> void
+      ;; adds in the configuration for the Java colors to the prefs panel
+      (define (extend-preferences-panel parent)
+        (for-each
+         (lambda (line)
+           (let ([sym (car line)])
+             (color-prefs:build-color-selection-panel 
+              parent
+              (short-sym->pref-name sym)
+              (short-sym->style-name sym)
+              (format "~a" sym))))
+         color-prefs-table))
+      
+      ;Create the Java editing mode
+      (define mode-surrogate
+        (new color:text-mode%
+             (matches (list (list '|{| '|}|)
+                            (list '|(| '|)|)
+                            (list '|[| '|]|)))
+             (get-token get-syntax-token)
+             (token-sym->style short-sym->style-name)))
+            
+      ;repl-submit: text int -> bool
+      ;Determines if the reple should submit or not
+      (define (repl-submit text prompt-position)
+        (let ((is-if? #f)
+              (is-string? #f)
+              (open-parens 0)
+              (open-braces 0)
+              (open-curlies 0))
+          (let loop ((index 1) (char (send text get-character prompt-position)))
+            (unless (eq? char #\nul)
+              (cond 
+                ;beginning of if statement
+                ((and (= index 1) 
+                      (eq? char #\i) 
+                      (eq? (send text get-character (add1 prompt-position)) #\f)
+                      (eq? (send text get-character (+ 2 prompt-position)) #\space))
+                 (set! is-if? #t)
+                 (loop 3 (send text get-character (+ 3 prompt-position))))
+                ((eq? char #\()
+                 (unless is-string? (set! open-parens (add1 open-parens)))
+                 (loop (add1 index) (send text get-character (+ index prompt-position))))
+                ((eq? char #\))
+                 (unless is-string? (set! open-parens (sub1 open-parens)))
+                 (loop (add1 index) (send text get-character (+ index prompt-position))))
+                ((eq? char #\{)
+                 (unless is-string? (set! open-curlies (add1 open-curlies)))
+                 (loop (add1 index) (send text get-character (+ index prompt-position))))
+                ((eq? char #\})
+                 (unless is-string? (set! open-curlies (sub1 open-curlies)))
+                 (loop (add1 index) (send text get-character (+ index prompt-position))))
+                ((eq? char #\[)
+                 (unless is-string? (set! open-braces (add1 open-braces)))
+                 (loop (add1 index) (send text get-character (+ index prompt-position))))
+                ((eq? char #\])
+                 (unless is-string? (set! open-braces (sub1 open-braces)))
+                 (loop (add1 index) (send text get-character (+ index prompt-position))))
+                ;beginning of string
+                ((eq? char #\")
+                 (set! is-string? (not is-string?))
+                 (loop (add1 index) (send text get-character (+ index prompt-position))))
+                (else
+                 (loop (add1 index) (send text get-character (+ index prompt-position)))))))
+          (not (or (not (= open-parens 0))
+                   (not (= open-braces 0))
+                   (not (= open-curlies 0))
+                   is-if?))))
+      
+      ;; matches-language : (union #f (listof string)) -> boolean
+      (define (matches-language l)
+        (and l (pair? l) (pair? (cdr l)) (equal? (cadr l) "ProfessorJ")))
+      
+      (define (phase1) void)
+      ;Add all the ProfessorJ languages into DrScheme
+      (define (phase2) 
+        #;(drscheme:language-configuration:add-language
+         (make-object ((drscheme:language:get-default-mixin) dynamic-lang%)))
+        (drscheme:language-configuration:add-language
+         (make-object ((drscheme:language:get-default-mixin) full-lang%)))
+        (drscheme:language-configuration:add-language
+         (make-object ((drscheme:language:get-default-mixin) advanced-lang%)))
+        (drscheme:language-configuration:add-language
+         (make-object ((drscheme:language:get-default-mixin) intermediate-lang%)))
+        (drscheme:language-configuration:add-language
+         (make-object ((drscheme:language:get-default-mixin) beginner-lang%))))                 
+      
+      ;(make-profj-settings symbol boolean (list string))
+      (define-struct profj-settings (print-style print-full? classpath) (make-inspector))
+      
+      ;ProfJ general language mixin
+      (define (java-lang-mixin level name number one-line dyn?)
+        (when dyn? (dynamic? #t))
+        (class* object% (drscheme:language:language<%>)
+          
+          (define/public (order-manuals x)
+            (let* ((beg-list '(#"profj-beginner" #"tour" #"drscheme" #"help"))
+                   (int-list (cons #"profj-intermediate" beg-list)))
+              (values (case level
+                        ((beginner) beg-list)
+                        ((intermediate) int-list)
+                        ((advanced full) (cons #"profj-advanced" int-list)))
+                      #f)))
+          
+          ;default-settings: -> profj-settings
+          (define/public (default-settings) 
+            (if (memq level `(beginner intermediate advanced))
+                (make-profj-settings 'field #f null)
+                (make-profj-settings 'type #f null)))
+          ;default-settings? any -> bool
+          (define/public (default-settings? s) (equal? s (default-settings)))
+
+          ;marshall-settings: profj-settings -> (list (list symbol) (list bool) (list string))
+          (define/public (marshall-settings s)
+            (list (list (profj-settings-print-style s))
+                  (list (profj-settings-print-full? s))))
+          
+          ;unmarshall-settings: any -> (U profj-settings #f)
+          (define/public (unmarshall-settings s)
+            (if (and (pair? s) (= (length s) 2)
+                     (pair? (car s)) (= (length (car s)) 1)
+                     (pair? (cadr s)) (= (length (cadr s)) 1))
+                (make-profj-settings (caar s) (caadr s) null)
+                #f))
+
+          ;Create the ProfessorJ settings selection panel
+          ;Note: Should add strings to string constants
+          (define/public (config-panel _parent)
+            (letrec ([parent (instantiate vertical-panel% ()
+                               (parent _parent)
+                               (alignment '(center center))
+                               (stretchable-height #f)
+                               (stretchable-width #f))]
+                     
+                     [output-panel (instantiate group-box-panel% ()
+                                     (label "Display Preferences")
+                                     (parent parent)
+                                     (alignment '(left center)))]
+                     [print-full (when (memq level '(advanced full))
+                                   (make-object check-box% "Print entire contents of arrays?" output-panel 
+                                     (lambda (x y) update-pf)))]
+                     [print-style (make-object radio-box%
+                                    "Display style"
+                                    (list "Class" "Class+Fields" );"Graphical")
+                                    output-panel
+                                    (lambda (x y) (update-ps)))]
+                     
+                     [update-pf (lambda () (void))]
+                     [update-ps (lambda () (void))]
+                     
+                     [cp-panel (instantiate group-box-panel% ()
+                                            (parent parent)
+                                            (alignment '(left center))
+                                            (label "Class path"))]
+                     [tp-panel (instantiate horizontal-panel% ()
+                                 (parent cp-panel)
+                                 (alignment '(center center))
+                                 (stretchable-height #f))]
+                     [lb (instantiate list-box% ()
+                                     (parent cp-panel)
+                                     (choices `("a" "b" "c"))
+                                     (label #f)
+                                     (callback (lambda (x y) (update-buttons))))]
+                     [top-button-panel (instantiate horizontal-panel% ()
+                                         (parent cp-panel)
+                                         (alignment '(center center))
+                                         (stretchable-height #f))]
+                     [bottom-button-panel (instantiate horizontal-panel% ()
+                                            (parent cp-panel)
+                                            (alignment '(center center))
+                                            (stretchable-height #f))]
+                     [list-button (make-object button% "Display Current" tp-panel (lambda (x y) (list-callback)))]                     
+                     [add-button (make-object button% "Add" bottom-button-panel (lambda (x y) (add-callback)))]
+                     [remove-button (make-object button% "Remove" bottom-button-panel (lambda (x y) (remove-callback)))]
+                     [raise-button (make-object button% "Raise" top-button-panel (lambda (x y) (raise-callback)))]
+                     [lower-button (make-object button% "Lower" top-button-panel (lambda (x y) (lower-callback)))]
+                     [enable? #f]
+                     
+                     [update-buttons 
+                      (lambda ()
+                        (let ([lb-selection (send lb get-selection)]
+                              [lb-tot (send lb get-number)])
+                          (send remove-button enable (and lb-selection enable?))
+                          (send raise-button enable (and lb-selection enable? (not (= lb-selection 0))))
+                          (send lower-button enable (and lb-selection enable? (not (= lb-selection (- lb-tot 1)))))))]
+                     [add-callback
+                      (lambda ()
+                        (let ([dir (get-directory "Choose the directory to add to class path" 
+                                                  (send parent get-top-level-window))])
+                          (when dir
+                            (send lb append dir #f)
+                            (preferences:set 'profj:classpath (cons dir (preferences:get 'profj:classpath)))
+                            (update-buttons))))]
+                     [list-callback
+                      (lambda ()
+                        (send lb clear)
+                        (let ((cpath (preferences:get 'profj:classpath)))
+                          (let loop ((n 0) (l cpath))
+                            (cond
+                              ((> n (sub1 (length cpath))) (void))
+                              (else (send lb append (car l))
+                                    (send lb set-data n (car l))
+                                    (loop (+ n 1) (cdr l)))))
+                          (unless (null? cpath)
+                            (send lb set-selection 0))
+                          (set! enable? #t)
+                          (update-buttons)))]
+                     [remove-callback
+                      (lambda ()
+                        (let ([to-delete (send lb get-selection)])
+                           (send lb delete to-delete)
+                          (unless (zero? (send lb get-number))
+                            (send lb set-selection (min to-delete (- (send lb get-number) 1))))
+                          (preferences:set 'profj:classpath (get-classpath))
+                          (update-buttons)))]
+                     [lower-callback
+                      (lambda ()
+                        (let* ([sel (send lb get-selection)]
+                               [vec (get-lb-vector)]
+                               [below (vector-ref vec (+ sel 1))])
+                          (vector-set! vec (+ sel 1) (vector-ref vec sel))
+                          (vector-set! vec sel below)
+                          (set-lb-vector vec)
+                          (send lb set-selection (+ sel 1))
+                          (preferences:set 'profj:classpath (get-classpath))
+                          (update-buttons)))]
+                     [raise-callback
+                      (lambda ()
+                        (let* ([sel (send lb get-selection)]
+                               [vec (get-lb-vector)]
+                               [above (vector-ref vec (- sel 1))])
+                          (vector-set! vec (- sel 1) (vector-ref vec sel))
+                          (vector-set! vec sel above)
+                          (set-lb-vector vec)
+                          (send lb set-selection (- sel 1))
+                          (preferences:set 'profj:classpath (get-classpath))
+                          (update-buttons)))]
+                     [get-lb-vector
+                      (lambda ()
+                        (list->vector
+                         (let loop ([n 0])
+                           (cond
+                             [(= n (send lb get-number)) null]
+                             [else (cons (cons (send lb get-string n)
+                                               (send lb get-data n))
+                                         (loop (+ n 1)))]))))]
+                     [set-lb-vector
+                      (lambda (vec)
+                        (send lb clear)
+                        (let loop ([n 0])
+                          (cond
+                            [(= n (vector-length vec)) (void)]
+                            [else (send lb append (car (vector-ref vec n)))
+                                  (send lb set-data n (cdr (vector-ref vec n)))
+                                  (loop (+ n 1))])))]
+                     [get-classpath
+                      (lambda ()
+                        (let loop ([n 0])
+                          (cond
+                            [(= n (send lb get-number)) null]
+                            [else
+                             (let ([data (send lb get-data n)])
+                               (cons (if data
+                                         'default
+                                         (send lb get-string n))
+                                     (loop (+ n 1))))])))]
+                     [install-classpath
+                      (lambda (paths)
+                        (send lb clear)
+                        (for-each (lambda (cp)
+                                    (if (symbol? cp)
+                                        (send lb append "Default" #t)
+                                        (send lb append cp #f)))
+                                  paths))])
+              (send lb set '())
+              (update-buttons)
+              
+              (case-lambda
+                [()
+                 (make-profj-settings (case (send print-style get-selection)
+                                        [(0) 'type]
+                                        [(1) 'field]
+                                        [(2) 'graphical])
+                                      (if (memq level '(advanced full))
+                                          (send print-full get-value)
+                                          #f)
+                                      (get-classpath))]
+                [(settings)
+                 (send print-style set-selection
+                       (case (profj-settings-print-style settings)
+                         ((type default) 0)
+                         ((field) 1)
+                         ((graphical) 2)))
+                 (when (memq level '(advanced full))
+                   (send print-full set-value (profj-settings-print-full? settings)))
+                 (install-classpath (profj-settings-classpath settings))])))
+                     
+          ;;Stores the types that can be used in the interactions window
+          ;;execute-types: type-record 
+          (define execute-types (create-type-record))
+          
+          (define/public (front-end/complete-program port settings teachpack-cache)
+            (set! execute-types (create-type-record))
+            (let ([name (object-name port)])
+              (lambda ()
+                (syntax-as-top
+                 (let ((end? (eof-object? (peek-char-or-special port))))
+                   (if end? 
+                       eof 
+                       (datum->syntax-object #f `(parse-java-full-program ,(parse port name level)) #f)))))))
+          (define/public (front-end/interaction port settings teachpack-cache)
+            (let ([name (object-name port)])
+              (lambda ()
+                (if (eof-object? (peek-char-or-special port))
+                    eof
+		    (syntax-as-top
+                     (datum->syntax-object 
+                      #f
+                      #;`(compile-interactions-helper ,(lambda (ast) (compile-interactions-ast ast name level execute-types))
+                                                    ,(parse-interactions port name level))
+                      `(parse-java-interactions ,(parse-interactions port name level) ,name)
+                      #f))))))
+
+          ;process-extras: (list struct) type-record -> (list syntax)
+          (define/private (process-extras extras type-recs)
+            (cond
+              ((null? extras) null)
+              ((example-box? (car extras)) 
+               (let ((contents (eval (example-box-contents (car extras)))))
+                 (append 
+                  (map (lambda (example)
+                         (let* ((type-editor (car example))
+                                (type (parse-type (open-input-text-editor type-editor) type-editor level))
+                                (name-editor (cadr example))
+                                (name (parse-name (open-input-text-editor name-editor) name-editor))
+                                (val-editor (caddr example))
+                                (val (parse-expression (open-input-text-editor val-editor) val-editor level)))
+                           (compile-interactions-ast
+                            (make-var-init (make-var-decl name null type #f) val #f)
+                            val-editor level type-recs)))
+                       contents)
+                  (process-extras (cdr extras) type-recs))))
+              ((test-case? (car extras))
+               (cons 
+                (let ((new-test-case
+                       (lambda (to-test-stx exp-stx record set-actuals)
+                         (let ([to-test-values (call-with-values (lambda () to-test-stx) list)]
+                               [exp-values (call-with-values (lambda () exp-stx) list)])
+                           (record (and (= (length to-test-values) (length exp-values))
+                                        (andmap (dynamic-require '(lib "profj-testing.ss" "profj") 'java-values-equal?)
+                                                to-test-values exp-values)))
+                           (set-actuals to-test-values)))))
+                  (let-values (((syn t t2) (send (test-case-test (car extras)) read-special #f #f #f #f)))
+                    (syntax-case syn ()
+                      ((test-case equal? exp1 exp2 exp3 exp4) 
+                       (syntax-case (syntax exp1) (begin require)
+                         ((begin (require req ...) exp)
+                          (syntax-case (syntax exp2) (begin require)
+                            ((begin (require req2 ...) new-exp2) 
+                             (datum->syntax-object #f 
+                                                   `(begin ,(syntax (require req ... req2 ...))
+                                                           (,new-test-case ,(syntax exp) ,(syntax new-exp2)
+                                                             ,(syntax exp3) ,(syntax exp4)))
+                                                   #f))
+                            (else 
+                             (datum->syntax-object #f
+                                                   `(begin ,(syntax (require req ...))
+                                                           (,new-test-case ,(syntax exp) ,(syntax exp2)  ,(syntax exp3) ,(syntax exp4)))
+                                                   #f))))                         
+                         (else 
+                          (syntax-case (syntax exp2) (begin require)
+                            ((begin (require req2 ...) new-exp2)
+                             (datum->syntax-object #f
+                                                   `(begin ,(syntax (require req2 ...))
+                                                           (,new-test-case ,(syntax exp1) ,(syntax new-exp2) ,(syntax exp3) ,(syntax exp4)))
+                                                   #f))
+                          (else 
+                           (datum->syntax-object #f `(,new-test-case ,(syntax exp1) ,(syntax exp2) ,(syntax exp3) ,(syntax exp4)) #f))))))
+                      (else syn))))
+                (process-extras (cdr extras) type-recs)))
+              ((interact-case? (car extras))
+               (let ((interact-box (interact-case-box (car extras))))
+                 (send interact-box set-level level)
+                 (send interact-box set-records execute-types)
+                 (send interact-box set-ret-kind #t)
+                 (append 
+                  (with-handlers ((exn? 
+                                   (lambda (e)
+                                     (send execute-types clear-interactions)
+                                     (raise e))))
+                    (let-values (((syn-list t t2) 
+                                  (send interact-box read-special #f #f #f #f))) syn-list))
+                  (process-extras (cdr extras) type-recs))))))
+          
+          ;find-main-module: (list compilation-unit) -> (U syntax #f)
+          (define/private (find-main-module mod-lists)
+            (if (null? mod-lists)
+                #f
+                (let ((names (compilation-unit-contains (car mod-lists)))
+                      (syntaxes (compilation-unit-code (car mod-lists))))
+                  (if (member (cadr (main)) names)
+                      (if (= (length syntaxes) 1)
+                          (list-ref syntaxes 0)
+                          (list-ref syntaxes (find-position names 1)))
+                      (find-main-module (cdr mod-lists))))))
+        
+          ;find-position: (list string) number-> number
+          (define/private (find-position l p)
+            (when (null? l)
+              (error 'find-position "Internal Error: member incorrectly chose an element as a member"))
+            (if (equal? (cadr (main)) (car l))
+                p
+                (find-position (cdr l) (add1 p))))
+          
+          ;order: (list compilation-unit) -> (list syntax)
+          (define/private (order mod-lists)
+            (if (null? mod-lists)
+                null
+                (append (compilation-unit-code (car mod-lists))
+                        (order (cdr mod-lists)))))
+              
+          (define/public (get-comment-character) (values "//" "*"))
+          (define/public (get-style-delta) #f)
+          (define/public (get-language-position) 
+            (cons (string-constant experimental-languages) (list "ProfessorJ" name) ))
+          (define/public (get-language-numbers) (list 1000 10 number))
+          (define/public (get-language-name) (string-append "ProfessorJ: " name))
+          (define/public (get-language-url) #f)
+          (define/public (get-teachpack-names) null)
+
+          (define/private (syntax-as-top s)
+	    (if (syntax? s) (namespace-syntax-introduce s) s))
+          
+          (define/public (on-execute settings run-in-user-thread)
+            (dynamic-require '(lib "Object.ss" "profj" "libs" "java" "lang") #f)
+            (let ([obj-path ((current-module-name-resolver) '(lib "Object.ss" "profj" "libs" "java" "lang") #f #f)]
+                  [class-path ((current-module-name-resolver) '(lib "class.ss") #f #f)]
+                  [tool-path ((current-module-name-resolver) '(lib "tool.ss" "profj") #f #f)]
+                  [n (current-namespace)])
+              (read-case-sensitive #t)
+              (run-in-user-thread
+               (lambda ()
+                 (error-display-handler 
+                  (drscheme:debug:make-debug-error-display-handler (error-display-handler)))
+                 (let ((old-current-eval (drscheme:debug:make-debug-eval-handler (current-eval))))
+                   (current-eval 
+                    (lambda (exp)
+                      (syntax-case exp (parse-java-full-program parse-java-interactions)
+                        ((parse-java-full-program ex)
+                         (let ((exp (old-current-eval (syntax ex))))
+                           (execution? #t)
+                           (let ((name-to-require #f))
+                             (let loop ((mods (order (compile-ast exp level execute-types)))
+                                        (extras (process-extras 
+                                                 (send execute-types get-interactions-boxes) execute-types))
+                                        (require? #f))
+                               (cond
+                                 ((and (not require?) (null? mods) (null? extras)) (void))
+                                 ((and (not require?) (null? mods))
+                                  (old-current-eval (syntax-as-top (car extras)))
+                                  (loop mods (cdr extras) require?))
+                                 (require? 
+                                  (old-current-eval 
+                                   (syntax-as-top (with-syntax ([name name-to-require])
+                                                    (syntax (require name)))))
+                                  (loop mods extras #f))
+                                 (else 
+                                  (let-values (((name syn) (get-module-name (expand (car mods)))))
+                                    (set! name-to-require name)
+                                    (syntax-as-top (old-current-eval syn))
+                                    (loop (cdr mods) extras #t))))))))
+                        ((parse-java-interactions ex loc)
+                         (let ((exp (syntax-object->datum (syntax ex))))
+                           (old-current-eval 
+                            (syntax-as-top (compile-interactions-ast exp (syntax loc) level execute-types)))))
+                        (_ (old-current-eval exp))))))
+                 (with-handlers ([void (lambda (x)  (printf "~a~n" (exn-message x)))])
+                   (namespace-require 'mzscheme)
+                   (namespace-attach-module n obj-path)
+                   (namespace-attach-module n class-path)
+                   (namespace-require obj-path)
+                   #;(namespace-require '(lib "tool.ss" "profj"))
+                   (namespace-require class-path)
+                   (namespace-require '(prefix javaRuntime: (lib "runtime.scm" "profj" "libs" "java")))
+                   (namespace-require '(prefix c: (lib "contract.ss"))))))))
+          
+          (define/public (render-value value settings port); port-write)
+            (let ((print-full? (profj-settings-print-full? settings))
+                  (style (profj-settings-print-style settings)))
+              (if (is-a? value String)
+                  (write-special (send value get-mzscheme-string) port)
+                  (let ((out (format-java value print-full? style null #f 0)))
+                    (if (< 25 (string-length out))
+                        (display (format-java value print-full? style null #t 0) port)
+                        (display out port))))))
+          (define/public (render-value/format value settings port width) 
+            (render-value value settings port)(newline port))
+          
+          (define/public (create-executable fn parent . args)
+	    (message-box "Unsupported"
+			 "Sorry - executables are not supported for Java at this time"
+			 parent))
+	  (define/public (get-one-line-summary) one-line)
+          
+          (super-instantiate ())))
+      
+      ;Create the ProfessorJ languages
+      (define full-lang% (java-lang-mixin 'full "Full" 4 "Like Java 1.0 (some 1.1)" #f))
+      (define advanced-lang% (java-lang-mixin 'advanced "Advanced" 3 "Java-like Advanced teaching language" #f))
+      (define intermediate-lang% 
+        (java-lang-mixin 'intermediate "Intermediate" 2 "Java-like Intermediate teaching language" #f))
+      (define beginner-lang% (java-lang-mixin 'beginner "Beginner" 1 "Java-like Beginner teaching language" #f))
+      (define dynamic-lang% (java-lang-mixin 'full "Java+dynamic" 5 "Java with dynamic typing capabilities" #t))
+      
+      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;
+      ;;  Wire up to DrScheme
+      ;;
+      
+      (drscheme:modes:add-mode (string-constant profj-java-mode) mode-surrogate repl-submit matches-language)
+      (color-prefs:add-to-preferences-panel (string-constant profj-java) extend-preferences-panel)
+      
+      (for-each (lambda (line)
+                  (let ([sym (car line)]
+                        [color (cadr line)])
+                    (color-prefs:register-color-pref (short-sym->pref-name sym)
+                                                     (short-sym->style-name sym)
+                                                     color)))
+                color-prefs-table)
+      
+      ;;Java Boxes
+      (define java-box%
+        (class* decorated-editor-snip% ()
+          (inherit get-admin get-editor)
+          (define/public (get-comment) "// ")
+          (define/public (get-mesg) "Convert to text comment")
+
+          (define/override get-text
+            (opt-lambda (offset num [flattened? #t])
+              (let* ([super-res (super get-text offset num flattened?)]
+                     [replaced (string-append (send this get-comment) 
+                                              (regexp-replace* "\n" super-res 
+                                                               (string-append "\n" (send this get-comment))))])
+                (if (char=? #\newline (string-ref replaced (- (string-length replaced) 1)))
+                    replaced
+		    (string-append replaced "\n")))))
+          (define/override (get-menu)
+            (let ([menu (make-object popup-menu%)])
+              (make-object menu-item% 
+                (send this get-mesg)
+                menu
+                (lambda (x y)
+                  (let ([to-ed (find-containing-editor)])
+                    (when to-ed
+                      (let ([this-pos (find-this-position)])
+                        (when this-pos
+                          (let ([from-ed (get-editor)])
+                            (send to-ed begin-edit-sequence)
+                            (send from-ed begin-edit-sequence)
+                            (copy-contents-with-comment-char-to-position to-ed from-ed (+ this-pos 1))
+                            (send to-ed delete this-pos (+ this-pos 1))
+                            (send to-ed end-edit-sequence)
+                            (send from-ed end-edit-sequence))))))))
+              menu))
+          ;; find-containing-editor : -> (union #f editor)
+          (define/private (find-containing-editor)
+            (let ([admin (get-admin)])
+              (and admin
+                   (send admin get-editor))))
+          
+          ;; find-this-position : -> (union #f number)
+          (define/private (find-this-position)
+            (let ([ed (find-containing-editor)])
+              (and ed
+                   (send ed get-snip-position this))))
+          
+          ;; copy-contents-with-comment-char-to-position : (is-a? text%) number -> void
+          (define/private (copy-contents-with-comment-char-to-position to-ed from-ed pos)
+            (let loop ([snip (find-last-snip from-ed)])
+              (cond
+                [snip 
+                 (when (or (memq 'hard-newline (send snip get-flags))
+                           (memq 'newline (send snip get-flags)))
+                   (send to-ed insert (send this get-comment) pos))
+                 (send to-ed insert (send snip copy) pos)
+                 (loop (send snip previous))]
+                [else 
+                 (send to-ed insert (send this get-comment) pos)])))
+          
+          ;; find-last-snip : editor -> snip
+          ;; returns the last snip in the editor
+          (define/private (find-last-snip ed)
+            (let loop ([snip (send ed find-first-snip)]
+                       [acc (send ed find-first-snip)])
+              (cond
+                [snip (loop (send snip next) snip)]
+                [else acc])))
+          
+          (super-instantiate ())
+          ))
+      
+      ;Comment box
+      ;;Comment icon
+      (define comment-gif (include-bitmap (lib "slash-slash.gif" "icons")))
+      
+      ;;The following code has been taken with small modifications from framework/private/comment-box.ss
+      (define snipclass-java-comment%
+        (class decorated-editor-snipclass%
+          (define/override (make-snip stream-in) (instantiate java-comment-box% ()))
+          (super-instantiate ())))
+      
+      (define snipclass-comment (make-object snipclass-java-comment%))
+      (send snipclass-comment set-version 1)
+      (send snipclass-comment set-classname "java-comment-box%")
+      (send (get-the-snip-class-list) add snipclass-comment)
+      
+      (define java-comment-box%
+        (class* java-box% (readable-snip<%>)
+          (define/override (make-editor) (new text:keymap%))
+          (define/override (make-snip) (make-object java-comment-box%))
+          (define/override (get-corner-bitmap) comment-gif)
+          (define/override (get-position) 'left-top)
+
+          (define/public (read-special source line column position)
+            (make-special-comment 1))
+          
+          (super-instantiate ())
+          (inherit set-snipclass get-editor)
+          (set-snipclass snipclass-comment)))
+          
+      (define (java-comment-box-mixin %)
+        (class %
+          (inherit get-special-menu get-edit-target-object)
+          
+          (super-new)
+          (new menu-item%
+            (label  (string-constant profj-insert-java-comment-box))
+            (parent (get-special-menu))
+            (callback
+             (lambda (menu event)
+               (let ([c-box (new java-comment-box%)]
+                     [text (get-edit-target-object)])
+                 (send text insert c-box)
+                 (send text set-caret-owner c-box 'global)))))))
+      
+      (drscheme:get/extend:extend-unit-frame java-comment-box-mixin)
+      
+      ;;Java interactions box
+      #;(define ji-gif (include-bitmap (lib "java-interactions-box.gif" "icons")))
+      (define ji-gif (include-bitmap (lib "j.gif" "icons")))
+      
+      (define snipclass-java-interactions%
+        (class decorated-editor-snipclass%
+          (define/override (make-snip stream-in) (instantiate java-interactions-box% ()))
+          (super-instantiate ())))
+      
+      (define snipclass-interactions (make-object snipclass-java-interactions%))
+      (send snipclass-interactions set-version 1)
+      (send snipclass-interactions set-classname "java-interactions-box%")
+      (send (get-the-snip-class-list) add snipclass-interactions)
+      
+      (define java-interactions-box%
+        (class* java-box% (readable-snip<%>)
+          (define/override (make-editor) (new ((drscheme:unit:get-program-editor-mixin) color:text%)))
+          (define/override (make-snip) (make-object java-interactions-box%))
+          (define/override (get-corner-bitmap) ji-gif)
+          (define/override (get-mesg) "Convert to comment")
+          (define level 'full)
+          (define type-recs (create-type-record))
+          (define ret-list? #f)
+          (define/public (set-level l) (set! level l))
+          (define/public (set-records tr) (set! type-recs tr))
+          (define/public (set-ret-kind k) (set! ret-list? k)) 
+          (define-struct input-length (start-pos end-pos))
+
+          (define/private (newline? char) (memq char '(#\015 #\012)))
+          
+          (define/public (read-special source line column position)
+            (let* ((ed (get-editor))
+                   (port (open-input-text-editor ed 0 'end (editor-filter #t)))
+                   (inputs-list null))
+              (let outer-loop ((c (read-char-or-special port)) (start 0))
+                (unless (eof-object? c)
+                  (let inner-loop ((put c) (offset start))
+                    (cond
+                      ((eof-object? put)
+                       (set! inputs-list (cons (make-input-length start offset) inputs-list))
+                       (outer-loop (read-char-or-special port) (add1 offset)))
+                      ((newline? put) 
+                       (let ((new-put (read-char-or-special port))) 
+                         (if (or (eof-object? new-put) (newline? new-put))
+                             (begin
+                               (set! inputs-list (cons (make-input-length start (add1 offset)) inputs-list))
+                               (outer-loop (read-char-or-special port) (+ 2 offset)))
+                             (inner-loop new-put (add1 offset)))))
+                      #;((or (eq? put #\015) (eq? put #\012) (eof-object? put))
+                         (set! inputs-list (cons (make-input-length start offset) inputs-list))
+                         (outer-loop (read-char-or-special port) (add1 offset)))
+                      (else (inner-loop (read-char-or-special port) (add1 offset)))))))
+              (let ((syntax-list (map 
+                                  (lambda (input-len)
+                                    (interactions-offset (input-length-start-pos input-len))
+                                    
+                                    (compile-interactions (open-input-text-editor ed 
+                                                                                  (input-length-start-pos input-len)
+                                                                                  (input-length-end-pos input-len)
+                                                                                  (editor-filter #t))
+                                                          ed type-recs level))
+                                  (reverse inputs-list))))
+;                (printf "~a~n~a~n" syntax-list (map remove-requires syntax-list))
+                (if ret-list?
+                    syntax-list
+                    (datum->syntax-object #f `(begin ,@(map remove-requires syntax-list)) #f)))))
+          (define (remove-requires syn)
+            (syntax-case* syn (begin require) (lambda (r1 r2) (eq? (syntax-e r1) (syntax-e r2)))
+              ((begin (require x ...) exp1 exp ...) (syntax (begin exp1 exp ...)))
+              (else syn)))
+          
+          (super-instantiate ())
+          (inherit set-snipclass get-editor)
+          (set-snipclass snipclass-interactions)
+          (send (get-editor) start-colorer
+                short-sym->style-name get-syntax-token 
+                (list (list '|{| '|}|)
+                      (list '|(| '|)|)
+                      (list '|[| '|]|)))
+          ))
+      
+      (define (java-interactions-box-mixin %)
+        (class %
+          (inherit get-special-menu get-edit-target-object)
+          
+          (super-new)
+          (new menu-item%
+               (label (string-constant profj-insert-java-interactions-box))
+               (parent (get-special-menu))
+               (callback
+                (lambda (menu event)
+                  (let ([i-box (new java-interactions-box%)]
+                        [text (get-edit-target-object)])
+                    (send text insert i-box)
+                    (send text set-caret-owner i-box 'global)))))))
+      
+      (drscheme:get/extend:extend-unit-frame java-interactions-box-mixin)
+      
+
+  ))
+  (define (editor-filter delay?)
+    (lambda (s)
+      (let ((name (send (send s get-snipclass) get-classname)))
+        (cond
+          ((equal? "test-case-box%" name) (values (make-test-case s) 1))
+          ((equal? "java-interactions-box%" name) (values (make-interact-case s) 1))
+          ((equal? "java-class-box%" name) (values (make-class-case s) 1))
+          (delay? (values (lambda () (send s read-one-special 0 #f #f #f #f)) 1))
+          (else (values s 1))))))
+    
+  (provide compile-interactions-helper)
+  (define-syntax (compile-interactions-helper syn)
+    (syntax-case syn ()
+      ((_ comp ast)
+        (namespace-syntax-introduce ((syntax-object->datum (syntax comp))
+                                     (syntax-object->datum (syntax ast)))))))
+  
+    
+  (provide format-java)
+  ;formats a java value (number, character or Object) into a string
+  ;format-java: java-value bool symbol (list value) -> string
+  (define (format-java value full-print? style already-printed newline? num-tabs)
+    (cond
+      ((null? value) "null")
+      ((number? value) (format "~a" value))
+      ((char? value) (format "'~a'" value))
+      ((boolean? value) (if value "true" "false"))
+      ((is-java-array? value) 
+       (if full-print?
+           (array->string value (send value length) -1 #t style already-printed newline? num-tabs)
+           (array->string value 3 (- (send value length) 3) #f style already-printed newline? num-tabs)))
+      ((is-a? value String) (format "~s" (send value get-mzscheme-string)))
+      ((is-a? value ObjectI)
+       (case style
+         ((type) (send value my-name))
+         ((field)
+          (let* ((retrieve-fields (send value fields-for-display))
+                 (st (format "~a(" (send value my-name)))
+                 (new-tabs (+ num-tabs 3));(string-length st)))
+                 (fields ""))
+            (let loop ((current (retrieve-fields)))
+              (let ((next (retrieve-fields)))
+                (when current
+                  (set! fields 
+                        (string-append fields 
+                                       (format "~a~a = ~a~a~a" 
+                                               (if newline? (if (equal? fields "") 
+                                                                (format "~n~a" (get-n-spaces new-tabs)); "" 
+                                                                (get-n-spaces new-tabs)) "")
+                                               (car current)
+                                               (if (memq (cadr current) already-printed)
+                                                   (format-java (cadr current) full-print? 'type already-printed #f 0)
+                                                   (format-java (cadr current) full-print? style 
+                                                                (cons value already-printed) newline?
+                                                                (if newline? 
+                                                                    (+ new-tabs (string-length (car current)) 3)
+                                                                    num-tabs)))
+                                               (if next "," "")
+                                               (if newline? (format "~n") " "))))
+                  (loop next))))
+            (string-append st 
+                           (if (> (string-length fields) 1) 
+                               (substring fields 0 (sub1 (string-length fields))) "") ")")))
+         (else (send value my-name))))
+      (else (format "~a" value))))
+  
+  ;array->string: java-value int int bool symbol (list value) -> string
+  (define (array->string value stop restart full-print? style already-printed nl? nt)
+    (letrec ((len (send value length))
+             (make-partial-string
+              (lambda (idx first-test second-test)
+                (cond
+                  ((first-test idx) "")
+                  ((second-test idx)
+                   (string-append (format-java (send value access idx) full-print? style already-printed nl? nt)
+                                  (make-partial-string (add1 idx) first-test second-test)))
+                  (else
+                   (string-append (format-java (send value access idx) full-print? style already-printed nl? nt)
+                                  " "
+                                  (make-partial-string (add1 idx) first-test second-test)))))))
+      (if (or full-print? (< restart stop))
+          (format "[~a]" (make-partial-string 0 (lambda (i) (>= i len)) (lambda (i) (= i (sub1 len)))))
+          (format "[~a~a~a]"                      
+                  (make-partial-string 0 (lambda (i) (or (>= i stop) (>= i len))) (lambda (i) (= i (sub1 stop))))
+                  " ... "
+                  (make-partial-string restart (lambda (i) (>= i len)) (lambda (i) (= i (sub1 len))))))))
+  
+  (define (get-n-spaces n)
+    (cond
+      ((= n 0) "")
+      (else (string-append " " (get-n-spaces (sub1 n))))))
+  
+  (define (get-module-name stx)
+    (syntax-case stx (module #%plain-module-begin)
+      [(module name lang (#%plain-module-begin bodies ...))
+       (values (syntax name)
+               (syntax (module name lang
+                         (#%plain-module-begin bodies ...))))]
+      [else 
+       (raise-syntax-error 'Java 
+                           "Internal Syntax error in getting module name"
+                           stx)]))
+  
+  (define (add-main-call stx)
+    (syntax-case stx (module #%plain-module-begin)
+      [(module name lang (#%plain-module-begin bodies ...))
+       (let ([execute-body (if (car (main))
+                               `(lambda (x) 
+                                  (display "executing main - ")
+                                  (display (,(string->symbol (string-append (cadr (main)) "-main_java.lang.String1")) x)))
+                               'void)])
+         (with-syntax ([main (datum->syntax-object #f execute-body #f)]) 
+           (values (syntax name)
+                   (syntax (module name lang 
+                             (#%plain-module-begin 
+                              (begin bodies ...)
+                              (main "temporary")))))))]
+      [else
+       (raise-syntax-error 'Java
+                           "Internal Syntax error in compiling Java Program"
+                           stx)])))
diff --git a/collects/profj/types.ss b/collects/profj/types.ss
new file mode 100644
index 0000000000..94cab848c7
--- /dev/null
+++ b/collects/profj/types.ss
@@ -0,0 +1,774 @@
+#cs
+(module types mzscheme
+
+  (require (lib "etc.ss")
+           (lib "pretty.ss")
+           (lib "list.ss")
+           (lib "class.ss")
+           "ast.ss")
+  
+  (provide (all-defined-except sort number-assign-conversions remove-dups meth-member?
+                               variable-member? generate-require-spec))
+      
+  ;; symbol-type = 'null | 'string | 'boolean | 'char | 'byte | 'short | 'int
+  ;;             | 'long | 'float | 'double | 'void
+  ;; reference-type = 'null | 'string | (make-ref-type string (list string))
+  ;; array-type = (make-array-type type int)
+  ;; type = symbol-type
+  ;;      | reference-type
+  ;;      | array-type
+  ;;      | scheme-val
+  ;;      | unknown-ref
+
+  (define-struct ref-type (class/iface path) (make-inspector))
+  (define-struct array-type (type dim))
+  
+  (define object-type (make-ref-type "Object" `("java" "lang")))
+  (define string-type (make-ref-type "String" `("java" "lang")))
+  (define throw-type (make-ref-type "Throwable" `("java" "lang")))
+  (define runtime-exn-type (make-ref-type "RuntimeException" `("java" "lang")))
+  (define serializable-type (make-ref-type "Serializable" `("java" "io")))
+  (define comparable-type (make-ref-type "Comparable" `("java" "lang")))
+  (define cloneable-type (make-ref-type "Cloneable" `("java" "lang")))
+  
+;                                                                                                          
+;                                                                                                          
+;                                                   ;                       ;         ;                    
+;                                                   ;                       ;                              
+;  ;;;;;;;                                          ;                       ;                              
+;     ;                                             ;                       ;                              
+;     ;     ;    ;  ; ;;;    ;;;;             ;;;   ; ;;;    ;;;;     ;;;   ;   ;   ;;;     ; ;;;    ;;; ; 
+;     ;      ;   ;  ;;  ;;   ;  ;;           ;   ;  ;;   ;   ;  ;;   ;   ;  ;  ;      ;     ;;   ;  ;;  ;; 
+;     ;      ;  ;   ;    ;  ;    ;          ;       ;    ;  ;    ;  ;       ; ;       ;     ;    ;  ;    ; 
+;     ;      ;  ;   ;    ;  ;;;;;;          ;       ;    ;  ;;;;;;  ;       ;;;       ;     ;    ;  ;    ; 
+;     ;       ; ;   ;    ;  ;               ;       ;    ;  ;       ;       ;  ;      ;     ;    ;  ;    ; 
+;     ;       ;;    ;;  ;;   ;   ;           ;   ;  ;    ;   ;   ;   ;   ;  ;   ;     ;     ;    ;  ;;  ;; 
+;     ;        ;    ; ;;;     ;;;             ;;;   ;    ;    ;;;     ;;;   ;    ;  ;;;;;   ;    ;   ;;; ; 
+;              ;    ;                                                                                    ; 
+;             ;     ;                                                                                ;  ;; 
+;            ;;     ;                                                                                 ;;;  
+;                                                                                                          
+
+  
+  ;; reference-type: 'a -> boolean
+  (define (reference-type? x)
+    (if (and (scheme-val? x) (scheme-val-type x))
+        (reference-type? (scheme-val-type x))
+        (or (scheme-val? x) 
+            (unknown-ref? x)
+            (ref-type? x) 
+            (memq x `(null string)))))
+
+  ;;is-string?: 'a -> boolean
+  (define (is-string-type? s)
+    (if (scheme-val? s)
+        (is-string-type? (scheme-val-type s))
+        (and (reference-type? s)
+             (or (eq? 'string s) (type=? s string-type)))))
+  
+  ;; 4.2
+  ;; prim-integral-type?: 'a -> boolean
+  (define (prim-integral-type? t)
+    (cond
+      ((and (scheme-val? t) (scheme-val-type t)) 
+       (prim-integral-type? (scheme-val-type t)))
+      ((scheme-val? t) #t)
+      (else (memq t `(byte short int long char)))))
+  ;; prim-numeric-type?: 'a -> boolean
+  (define (prim-numeric-type? t)
+    (cond 
+      ((and (scheme-val? t) (scheme-val-type t))
+       (prim-numeric-type? (scheme-val-type t)))
+      ((scheme-val? t) #t)
+      (else (or (prim-integral-type? t) (memq t `(float double))))))
+  
+  ;; type=?: type type -> boolean
+  (define (type=? t1 t2)
+    (cond
+      ((and (symbol? t1) (symbol? t2))
+       (symbol=? t1 t2))
+      ((and (ref-type? t1) (ref-type? t2))
+       (and (string=? (ref-type-class/iface t1) (ref-type-class/iface t2))
+            (= (length (ref-type-path t1)) (length (ref-type-path t2)))
+            (andmap
+             (lambda (x y)
+               (string=? x y))
+             (ref-type-path t1)
+             (ref-type-path t2))))
+      ((and (array-type? t1) (array-type? t2))
+       (and (= (array-type-dim t1) (array-type-dim t2))
+            (type=? (array-type-type t1) (array-type-type t2))))
+      ((or (symbol? t1) (symbol? t2))
+       (or (or (and (eq? t1 'null) (ref-type? t2))
+               (and (eq? t2 'null) (ref-type? t1)))
+           (and (eq? t1 'string) (type=? t2 string-type))
+           (and (eq? t2 'string) (type=? t1 string-type))))
+      (else #f)))                     
+  
+  ;; 5.1.2
+  ;; widening-prim-conversion: symbol-type symbol-type -> boolean
+  (define (widening-prim-conversion to from)
+    (cond
+      ((symbol=? 'short to)
+       (symbol=? 'byte from))
+      ((symbol=? 'int to)
+       (memq from `(byte short char)))
+      ((symbol=? 'long to)
+       (memq from `(byte short char int)))
+      ((symbol=? 'float to)
+       (memq from `(byte short char int long)))
+      ((symbol=? 'double to)
+       (memq from `(byte short char int long float)))))
+  
+  ;; 5.1.4
+  ;; widening-ref-conversion: type type type-records -> boolean
+  (define (widening-ref-conversion to from type-recs)
+    (cond
+      ((and (symbol? from) (symbol=? from 'null))
+       (or (ref-type? to) (symbol=? 'string to) (array-type? to)))
+      ((and (symbol? from) (symbol=? from 'string))
+       (or (type=? to object-type) 
+           (type=? to serializable-type) 
+           (type=? to comparable-type)))
+      ((and (ref-type? from) (ref-type? to))
+       (or (is-subclass? from to type-recs)
+           (implements? from to type-recs)
+           (and (is-interface? from type-recs)
+                (type=? object-type to))))
+      ((array-type? from)
+       (or (type=? object-type to)
+           (type=? cloneable-type to)
+           (type=? serializable-type to)
+           (and (array-type? to) (= (array-type-dim from) (array-type-dim to))
+                (assignment-conversion (array-type-type to) (array-type-type from) type-recs))))
+      (else #f)))
+  
+  ;; 5.2
+  ;; SKIP - possible narrowing conversion for constants
+  ;; assignment-conversion: type type type-records -> boolean
+  (define (assignment-conversion to from type-recs)
+    (cond
+      ((scheme-val? to) 
+       (cond
+         ((scheme-val-type to) => (lambda (t) (assignment-conversion t from type-recs)))
+         (else (set-scheme-val-type! to from) #t)))
+      ((scheme-val? from)
+       (cond
+         ((scheme-val-type from) => (lambda (t) (assignment-conversion to t type-recs)))
+         (else (set-scheme-val-type! from to) #t)))
+      ((type=? to from) #t)
+      ((and (prim-numeric-type? to) (prim-numeric-type? from))
+       (widening-prim-conversion to from))
+      (else
+       (widening-ref-conversion to from type-recs))))
+  
+  ;; type-spec-to-type: type-spec (U #f (list string) symbol type-records -> type
+  (define (type-spec-to-type ts container-class level type-recs)
+    (let* ((ts-name (type-spec-name ts))
+           (t (cond
+                ((memq ts-name `(null string boolean char byte short int long float double void ctor)) ts-name)
+                ((name? ts-name) (name->type ts-name container-class (type-spec-src ts) level type-recs)))))
+      (if (> (type-spec-dim ts) 0)
+          (make-array-type t (type-spec-dim ts))
+          t)))
+
+  ;name->type: name (U (list string) #f) src symbol type-records -> type
+  (define (name->type n container-class src level type-recs)
+    (let ((name (id-string (name-id n)))
+          (path (map id-string (name-path n))))
+      (type-exists? name path container-class src level type-recs)
+      (make-ref-type name (if (null? path) (send type-recs lookup-path name (lambda () null)) path)))) 
+  
+  ;; type-exists: string (list string) (U (list string) #f) src symbol type-records -> (U record procedure)
+  (define (type-exists? name path container-class src level type-recs)
+    (send type-recs get-class-record (cons name path) container-class
+          ((get-importer type-recs) (cons name path) type-recs level src)))
+    
+  ;; is-interface?: (U type (list string) 'string) type-records-> boolean
+  (define (is-interface? t type-recs)
+    (not (class-record-class? 
+          (get-record (send type-recs get-class-record t) type-recs))))
+  
+  ;;Is c1 a subclass of c2?
+  ;; is-subclass?: (U type (list string) 'string) ref-type type-records -> boolean
+  (define (is-subclass? c1 c2 type-recs)
+    (let ((cr (get-record (send type-recs get-class-record c1) type-recs)))
+      (member (cons (ref-type-class/iface c2) (ref-type-path c2))
+              (class-record-parents cr))))
+
+  ;; subclass?: (U type (list string) 'string) ref-type type-records -> boolean
+  (define (implements? c1 c2 type-recs)
+    (let ((cr (get-record (send type-recs get-class-record c1) type-recs)))
+      (member (cons (ref-type-class/iface c2) (ref-type-path c2))
+              (class-record-ifaces cr))))
+
+  ;is-eq-subclass: type type type-records -> boolean
+  (define (is-eq-subclass? class1 class2 type-recs)
+    (or (type=? class1 class2)
+        (and (reference-type? class1)
+             (reference-type? class2)
+             (is-subclass? class1 class2 type-recs))))
+  
+;                                                                                                          
+;                                                                                                          
+;                                                                                                          
+;            ;;;                                                                                 ;         
+;     ;;;;     ;                                    ;;;;;                                        ;         
+;    ;    ;    ;                                    ;    ;;                                      ;         
+;   ;;         ;                                    ;     ;                                      ;         
+;   ;          ;     ;;;;    ;;;;    ;;;;           ;     ;  ;;;;     ;;;    ;;;;    ; ;;;   ;;; ;   ;;;;  
+;   ;          ;         ;  ;    ;  ;    ;          ;    ;;  ;  ;;   ;   ;  ;;  ;;   ;;     ;;  ;;  ;    ; 
+;   ;          ;     ;;;;;  ;;      ;;              ;;;;;;  ;    ;  ;       ;    ;   ;      ;    ;  ;;     
+;   ;          ;    ;;   ;   ;;;;    ;;;;           ;    ;  ;;;;;;  ;       ;    ;   ;      ;    ;   ;;;;  
+;   ;;         ;    ;    ;       ;       ;          ;     ; ;       ;       ;    ;   ;      ;    ;       ; 
+;    ;    ;    ;    ;   ;;  ;    ;  ;    ;          ;     ;  ;   ;   ;   ;  ;;  ;;   ;      ;;  ;;  ;    ; 
+;     ;;;;   ;;;;;   ;;; ;   ;;;;    ;;;;           ;      ;  ;;;     ;;;    ;;;;    ;       ;;; ;   ;;;;  
+;                                                                                                          
+;                                                                                                          
+;                                                                                                          
+    
+  ;; (make-class-record (list string) (list symbol) boolean boolean (list field-record) 
+  ;;                    (list method-records) (list inner-record) (list (list strings)) (list (list strings)))
+  ;; After full processing fields and methods should contain all inherited fields 
+  ;; and methods.  Also parents and ifaces should contain all super-classes/ifaces
+  (define-struct class-record (name modifiers class? object? fields methods inners parents ifaces))
+
+  (define interactions-record (make-class-record (list "interactions") null #f #f null null null null null))
+  
+  ;; (make-field-record string (list symbol) bool (list string) type)
+  (define-struct field-record (name modifiers init? class type) (make-inspector))
+  
+  ;; (make-method-record string (list symbol) type (list type) (list type) (U bool method-record) string)
+  (define-struct method-record (name modifiers rtype atypes throws override class) (make-inspector))
+
+  ;;(make-inner-record string (list symbol) bool)
+  (define-struct inner-record (name modifiers class?) (make-inspector))
+
+  ;;(make-scheme-record string (list string) path (list scheme-val))
+  (define-struct scheme-record (name path dir provides))
+  
+  ;;(make-scheme-val symbol bool bool (U #f type unknown-ref))
+  (define-struct scheme-val (name dynamic? instance? type))
+  
+  ;;(make-unknown-ref (list method-contract) (list scheme-val))
+  (define-struct unknown-ref (methods fields))
+  
+  ;;(make-method-contract symbol (U type #f) (list (U type #f)))
+  (define-struct method-contract (name return args))  
+  
+;                                                                                      
+;                                                                            ;;        
+;    ;                                                                        ;        
+;    ;                                                                        ;        
+;   ;;;;; ;;; ;;;; ;;;    ;;;          ; ;;;   ;;;    ;;;    ;;;   ; ;;;   ;;;;   ;;;  
+;    ;     ;   ;  ;   ;  ;   ;          ;     ;   ;  ;   ;  ;   ;   ;     ;   ;  ;   ; 
+;    ;     ;   ;  ;   ;  ;;;;;  ;;;;;   ;     ;;;;;  ;      ;   ;   ;     ;   ;   ;;;  
+;    ;      ; ;   ;   ;  ;              ;     ;      ;      ;   ;   ;     ;   ;      ; 
+;    ;   ;  ;;;   ;   ;  ;   ;          ;     ;   ;  ;   ;  ;   ;   ;     ;   ;  ;   ; 
+;     ;;;    ;    ;;;;    ;;;          ;;;;    ;;;    ;;;    ;;;   ;;;;    ;;; ;  ;;;  
+;            ;    ;                                                                    
+;            ;    ;                                                                    
+;          ;;    ;;;                                                                   
+                                                                                                                                                  
+  ;Class to store various information per package compilation
+  (define type-records 
+    (class object%
+      
+      (field (importer 
+              (lambda () 
+                (error 'internal-error "type-records importer field was not set"))))
+      
+      ;Stores type information and require syntax per compile or execution
+      (define records (make-hash-table 'equal))
+      (define requires (make-hash-table 'equal))
+      (define package-contents (make-hash-table 'equal))
+      
+      ;Stores per-class information accessed by location
+      (define class-environment (make-hash-table))
+      (define class-require (make-hash-table))
+
+      (define compilation-location (make-hash-table))
+      
+      (define class-reqs null)
+      (define location #f)
+      
+      ;add-class-record: class-record -> void
+      (define/public (add-class-record r)
+        (hash-table-put! records (class-record-name r) r))
+      ;add-to-records: (list string) ( -> 'a) -> void
+      (define/public (add-to-records key thunk)
+        (hash-table-put! records key thunk))
+      
+      ;; get-class-record: (U type (list string) 'string) (U (list string) #f) ( -> 'a) -> 
+      ;;                                            (U class-record scheme-record procedure)
+      (define/public get-class-record
+        (opt-lambda (ctype [container #f] [fail (lambda () null)])
+          (let*-values (((key key-path) (normalize-key ctype))
+                        ((key-inner) (when (cons? container) (string-append (car container) "." key)))
+                        ((outer-record) (when (cons? container) (get-class-record container)))
+                        ((path) (if (null? key-path) (lookup-path key (lambda () null)) key-path))
+                        ((inner-path) (if (null? key-path) (lookup-path key-inner (lambda () null)) key-path))
+                        ((new-search)
+                         (lambda ()
+                           (if (null? path) 
+                               (fail)
+                               (let ((back-path (reverse path)))
+                                 (search-for-record key (car back-path) 
+                                                    (reverse (cdr back-path)) (lambda () #f) fail))))))
+            ;(printf "get-class-record: ~a~n" ctype)
+            ;(hash-table-for-each records (lambda (k v) (printf "~a -> ~a~n" k v)))
+            (cond
+              ((and container 
+                    (not (null? outer-record))
+                    (not (eq? outer-record 'in-progress))
+                    (member key (map inner-record-name (class-record-inners (get-record outer-record this)))))
+               (hash-table-get records (cons key-inner (cdr container)) fail))
+              ((and container (not (null? outer-record)) (eq? outer-record 'in-progress))
+               (let ((res (hash-table-get records (cons key-inner inner-path) (lambda () #f))))
+                 (or res
+                     (hash-table-get records (cons key path) new-search))))
+              (else
+               (hash-table-get records (cons key path) new-search))))))
+
+      ;normalize-key: (U 'strung ref-type (list string)) -> (values string (list string))
+      (define/private (normalize-key ctype)
+        (cond
+          ((eq? ctype 'string) (values "String" `("java" "lang")))
+          ((ref-type? ctype) (values (ref-type-class/iface ctype) (ref-type-path ctype)))
+          ((cons? ctype) (values (car ctype) (cdr ctype)))
+          (else (values ctype null))))
+      
+      ;search-for-record string string (list string) (-> #f) (-> 'a) -> class-record
+      (define/private (search-for-record class-name new-prefix path test-fail fail)
+        (let* ((new-class-name (string-append new-prefix "." class-name))
+               (rec? (hash-table-get records (cons new-class-name path) test-fail))
+               (back-path (reverse path)))
+          (cond
+            (rec? rec?)
+            ((null? path) (fail))
+            (else (search-for-record new-class-name (car back-path) (reverse (cdr back-path)) test-fail fail)))))                  
+      
+      ;add-package-contents: (list string) (list string) -> void
+      (define/public (add-package-contents package classes)
+        (let ((existing-classes (hash-table-get package-contents package (lambda () null))))
+          (if (null? existing-classes)
+              (hash-table-put! package-contents package classes)
+              (hash-table-put! package-contents package (non-dup-append classes existing-classes)))))
+
+      (define/private (non-dup-append cl pa)
+        (cond
+          ((null? cl) pa)
+          ((member (car cl) pa) (non-dup-append (cdr cl) pa))
+          (else (cons (car cl) (non-dup-append (cdr cl) pa)))))
+      
+      ;get-package-contents: (list string) ( -> 'a) -> (list string)
+      (define/public (get-package-contents package fail)
+        (hash-table-get package-contents package fail))
+      
+      ;add-to-env: string (list string) file -> void
+      (define/public (add-to-env class path loc)
+        (hash-table-put! (hash-table-get class-environment loc
+                                         (lambda ()
+                                           (let ((new-t (make-hash-table 'equal)))
+                                             (hash-table-put! class-environment loc new-t)
+                                             new-t)))
+                         class
+                         path))
+      
+      ;Returns the environment of classes for the current location
+      ;get-class-env: -> (list string)
+      (define/public (get-class-env)
+        (hash-table-map (hash-table-get class-environment location) (lambda (key val) key)))
+      
+      (define (env-failure)
+        (error 'class-environment "Internal Error: environment does not have location"))
+      
+      ;lookup-path: string ( -> 'a) -> (U (list string) #f)
+      (define/public (lookup-path class fail)
+        ;(printf "lookup ~a~n" class)
+        ;(hash-table-for-each (hash-table-get class-environment location)
+        ;                    (lambda (k v) (printf "~a -> ~a~n" k v)))
+        (if location
+            (hash-table-get (hash-table-get class-environment 
+                                            location 
+                                            env-failure)
+                            class fail)
+            (fail)))
+      
+      ;add-require-syntax: (list string) (list syntax syntax) -> void
+      (define/public (add-require-syntax name syn)
+        (get-require-syntax #t name (lambda () (hash-table-put! requires (cons #t name) (car syn))))
+        (get-require-syntax #f name (lambda () (hash-table-put! requires (cons #f name) (cadr syn)))))
+      
+      (define (syntax-fail)
+        (error 'syntax "Internal Error: syntax did not have given req"))
+      
+      ;get-require-syntax: bool (list string) . ( -> 'a)  -> syntax
+      (define/public (get-require-syntax prefix? name . fail)
+        (hash-table-get requires (cons prefix? name) (if (null? fail) syntax-fail (car fail))))
+        
+      ;add-class-req: name boolean location -> void
+      (define/public (add-class-req name pre loc)
+        (hash-table-put! (hash-table-get class-require
+                                         loc
+                                         (lambda () (let ((new-t (make-hash-table 'equal)))
+                                                      (hash-table-put! class-require loc new-t)
+                                                      new-t)))
+                         name pre))
+      
+      ;require-fail
+      (define (require-fail)
+        (error 'require-prefix "Internal Error: require does not have location"))
+      
+      ;require-prefix?: (list string) ( -> 'a) -> bool
+      (define/public (require-prefix? name fail)
+        (hash-table-get (hash-table-get class-require location require-fail) name fail))
+      
+      (define/private (member-req req reqs)
+        (and (not (null? reqs))
+             (or (and (equal? (req-class req) (req-class (car reqs)))
+                      (equal? (req-path req) (req-path (car reqs))))
+                 (member-req req (cdr reqs)))))
+
+      (define/public (set-compilation-location loc dir)  (hash-table-put! compilation-location loc dir))
+      (define/public (get-compilation-location)
+        (hash-table-get compilation-location location 
+                        (lambda () (error 'get-compilation-location "Internal error: location not found"))))
+      (define/public (set-composite-location name dir) (hash-table-put! compilation-location name dir))
+      (define/public (get-composite-location name)
+        ;(printf "get-composite-location for ~a~n" name)
+        ;(hash-table-for-each compilation-location
+        ;                     (lambda (k v) (printf "~a -> ~a~n" k v)))
+        (hash-table-get compilation-location name 
+                        (lambda () (error 'get-composite-location "Internal error: name not found"))))
+      
+      (define/public (add-req req)
+        (unless (member-req req class-reqs)
+          (set! class-reqs (cons req class-reqs))))
+      (define/public (get-class-reqs) class-reqs)
+      (define/public (set-class-reqs reqs) (set! class-reqs reqs))
+
+      (define/public (set-location! l) (set! location l))
+      (define/public (get-location) location)
+
+      (define interaction-package null)
+      (define interaction-fields null)
+      (define interaction-boxes null)      
+      (define execution-loc #f)
+      
+      (define/public (set-interactions-package p) (set! interaction-package p))
+      (define/public (get-interactions-package) interaction-package)
+      (define/public (add-interactions-field rec)
+        (set! interaction-fields (cons rec interaction-fields)))
+      (define/public (get-interactions-fields)
+        interaction-fields)
+      (define/public (clear-interactions)
+        (set! interaction-fields null))
+      (define/public (add-interactions-box box)
+        (set! interaction-boxes (cons box interaction-boxes)))
+      (define/public (get-interactions-boxes) (reverse interaction-boxes))
+      (define/public (set-execution-loc! loc) (set! execution-loc loc))
+      
+      (define/public (give-interaction-execution-names)
+        (when execution-loc
+          (hash-table-for-each (hash-table-get class-environment execution-loc)
+                               (lambda (k v) (add-to-env k v 'interactions)))
+          (set! execution-loc #f)))
+      
+      (super-instantiate ())))
+  
+  (define get-importer (class-field-accessor type-records importer))
+  (define set-importer! (class-field-mutator type-records importer))
+
+;                                                          
+
+;                                                          
+;     ;;;;            ;       ;                            
+;    ;    ;           ;       ;                            
+;   ;        ;;;;   ;;;;;;  ;;;;;;   ;;;;    ; ;;    ;;;;  
+;   ;        ;  ;;    ;       ;      ;  ;;   ;;  ;  ;    ; 
+;   ;    ;; ;    ;    ;       ;     ;    ;   ;      ;;     
+;   ;     ; ;;;;;;    ;       ;     ;;;;;;   ;       ;;;;  
+;   ;     ; ;         ;       ;     ;        ;           ; 
+;    ;    ;  ;   ;    ;       ;      ;   ;   ;      ;    ; 
+;     ;;;;    ;;;      ;;;     ;;;    ;;;    ;       ;;;;  
+;                                                          
+;                                                          
+  
+  ;get-record: (U class-record procedure) type-records -> class-record
+  (define (get-record rec type-recs)
+    (cond
+      ((procedure? rec) 
+       (let ((location (send type-recs get-location)))
+         (begin0 (rec) 
+                 (send type-recs set-location! location))))
+      (else rec)))
+  
+  ;; get-field-record: string class-record (-> 'a) -> field-record
+  (define (get-field-record fname c fail)
+    (let ((frec (filter (lambda (f)
+                          (string=? (field-record-name f) fname))
+                        (class-record-fields c))))
+      (cond
+        ((null? frec) (fail))
+        (else (car frec)))))
+
+  ;get-field-records: class-record -> (list field-record)
+  (define (get-field-records c) (class-record-fields c))
+  
+  ;; get-method-records: string class-record -> (list method-record)
+  (define (get-method-records mname c)
+    (filter (lambda (m)
+              (string=? (method-record-name m) mname))
+            (class-record-methods c)))
+
+  ;remove-dups: (list method-record) -> (list method-record)
+  (define (remove-dups methods)
+    (cond
+      ((null? methods) methods)
+      ((meth-member? (car methods) (cdr methods))
+       (remove-dups (cdr methods)))
+      (else (cons (car methods) (remove-dups (cdr methods))))))
+
+  ;meth-member? method-record (list method-record) -> bool
+  (define (meth-member? meth methods)
+    (and (not (null? methods))
+         (or (andmap type=? (method-record-atypes meth) 
+                            (method-record-atypes (car methods)))
+             (meth-member? meth (cdr methods)))))
+
+  ;sort: (list number) -> (list number)
+  (define (sort l)
+    (quicksort l (lambda (i1 i2) (< (car i1) (car i2)))))
+  
+  ;number-assign-conversion: (list type) (list type) type-records -> int
+  (define (number-assign-conversions site-args method-args type-recs)
+    (cond
+      ((null? site-args) 0)
+      ((and (assignment-conversion (car site-args) (car method-args) type-recs)
+            (not (type=? (car site-args) (car method-args))))
+       (add1 (number-assign-conversions (cdr site-args) (cdr method-args) type-recs)))
+      (else (number-assign-conversions (cdr site-args) (cdr method-args) type-recs))))
+  
+  ;; resolve-overloading: (list method-record) (list type) (-> 'a) (-> 'a) (-> 'a) type-records-> method-record
+  (define (resolve-overloading methods arg-types arg-count-fail method-conflict-fail  no-method-fail type-recs)
+    (let* ((a (length arg-types))
+           (m-atypes method-record-atypes)
+           (a-convert? (lambda (t1 t2) (assignment-conversion t1 t2 type-recs)))
+           (methods (remove-dups (filter (lambda (mr) (= a (length (m-atypes mr)))) methods)))
+           (methods-same (filter (lambda (mr) 
+                                   (andmap type=? (m-atypes mr) arg-types))
+                                 methods))
+           (assignable (filter (lambda (mr)
+                                 (andmap a-convert? (m-atypes mr) arg-types))
+                               methods))
+           (assignable-count (sort 
+                              (map (lambda (mr)
+                                     (list (number-assign-conversions arg-types (m-atypes mr) type-recs)
+                                           mr))
+                                   assignable))))
+      (cond
+        ((null? methods) (arg-count-fail))
+        ((= 1 (length methods-same)) (car methods-same))
+        ((> (length methods-same) 1) (method-conflict-fail))
+        ((null? assignable) (no-method-fail))
+        ((= 1 (length assignable)) (car assignable))
+        ((= (car (car assignable-count))
+            (car (cadr assignable-count))) (method-conflict-fail))
+        (else (car assignable)))))
+
+  ;lookup-scheme: scheme-record string ( -> void) -> scheme-val
+  ;lookup-scheme may raise an exception if variable is not defined in mod-ref
+  (define (lookup-scheme mod-ref variable fail)
+    (let ((var (string->symbol (java-name->scheme variable))))
+      (cond
+        ((variable-member? (scheme-record-provides mod-ref) var) => (lambda (x) x))
+        (else
+         (let ((old-namespace (current-namespace)))
+           (current-namespace (make-namespace))
+           (namespace-require (generate-require-spec (scheme-record-name mod-ref)
+                                                     (scheme-record-path mod-ref)))
+           (begin0
+             (begin
+               (namespace-variable-value var #t  (lambda () 
+                                                   (current-namespace old-namespace)
+                                                   (fail)))
+               (let ((val (make-scheme-val var #t #f #f)))
+                 (set-scheme-record-provides! mod-ref (cons val (scheme-record-provides mod-ref)))
+                 val))
+             (current-namespace old-namespace)))))))
+  
+  ;generate-require-spec: string (list string) -> (U string (list symbol string+))
+  (define (generate-require-spec name path)
+    (let ((mod (string-append name ".ss")))
+      (cond
+        ((null? path) mod)
+        ((equal? (car path) "lib")  `(lib ,mod ,@(cdr path)))
+        (else `(file ,(build-path (apply build-path path) mod))))))
+  
+  ;java-name->scheme: string -> string
+  (define (java-name->scheme name)
+    (cond
+      ((regexp-match "[a-zA-Z0-9]*To[A-Z0-9]*" name)
+       (java-name->scheme (regexp-replace "To" name "->")))
+      ((regexp-match "[a-zA-Z0-9]+P$" name)
+       (java-name->scheme (regexp-replace "P$" name "?")))
+      ((regexp-match "[a-zA-Z0-9]+Set$" name)
+       (java-name->scheme (regexp-replace "Set$" name "!")))
+      ((regexp-match "[a-zA-Z0-9]+Obj$" name)
+       (java-name->scheme (regexp-replace "Obj%" name "%")))
+      ((regexp-match "[a-z0-9]+->[A-Z]" name) =>
+       (lambda (substring)
+         (let ((char (car (regexp-match "[A-Z]" (car substring)))))
+           (java-name->scheme (regexp-replace (string-append "->" char) name
+                                              (string-append "->" (string (char-downcase (car (string->list char))))))))))
+      ((regexp-match "[a-z0-9]+[A-Z]" name) =>
+       (lambda (substring)
+         (let ((char (car (string->list (car (regexp-match "[A-Z]" (car substring))))))
+               (remainder (car (regexp-match "[a-z0-9]+" (car substring)))))
+           (java-name->scheme (regexp-replace (car substring) name 
+                                              (string-append remainder "-" (string (char-downcase char))))))))
+      (else name)))
+
+  ;variable-member? (list scheme-val) symbol -> scheme-val
+  (define (variable-member? known-vars lookup)
+    (and (not (null? known-vars))
+         (or (and (eq? (scheme-val-name (car known-vars)) lookup)
+                  (car known-vars))
+             (variable-member? (cdr known-vars) lookup))))
+
+  ;field-contract-lookup string (list scheme-val) -> (U #f scheme-val)
+  (define (field-contract-lookup name fields)
+    (and (not (null? fields))
+         (or (and (equal? (scheme-val-name (car fields)) name) 
+                  (car fields))
+             (field-contract-lookup name (cdr fields)))))
+
+  ;get-method-contracts: string unknown-ref -> (list method-contract)
+  (define (get-method-contracts name ref)
+    (letrec ((methods (unknown-ref-methods ref))
+             (lookup
+              (lambda (ms)
+                (and (not (null? ms))
+                     (or (and (equal? (method-contract-name (car ms)) name)
+                              (car ms))
+                         (lookup name (cdr ms)))))))
+      (cond
+        ((lookup methods) => (lambda (x) x))
+        (else 
+         (let ((mc (make-method-contract name (make-scheme-val 'method-return #t #f #f) #f)))
+           (set-unknown-ref-methods! ref (cons mc (unknown-ref-methods ref)))
+           (list mc))))))
+         
+                  
+;                                          
+;             ;                ;;          
+;                             ;            
+;     ;;;                     ;            
+;       ;                     ;            
+;       ;   ;;;     ; ;;;   ;;;;;    ;;;;  
+;       ;     ;     ;;   ;    ;     ;;  ;; 
+;       ;     ;     ;    ;    ;     ;    ; 
+;       ;     ;     ;    ;    ;     ;    ; 
+;       ;     ;     ;    ;    ;     ;    ; 
+;   ;  ;;     ;     ;    ;    ;     ;;  ;; 
+;    ;;;    ;;;;;   ;    ;    ;      ;;;;  
+;                                          
+
+  
+  (define type-version "version1")
+  (define type-length 10)
+  
+  ;; read-record: path -> (U class-record #f)
+  (define (read-record filename)
+    (letrec ((parse-class/iface
+              (lambda (input)
+                (and (= (length input) type-length)
+                     (equal? type-version (list-ref input 9))
+                     (make-class-record (list-ref input 1)
+                                        (list-ref input 2)
+                                        (symbol=? 'class (car input))
+                                        (list-ref input 3)
+                                        (map parse-field (list-ref input 4))
+                                        (map parse-method (list-ref input 5))
+                                        (map parse-inner (list-ref input 6))
+                                        (list-ref input 7)
+                                        (list-ref input 8)))))
+             (parse-field
+              (lambda (input)
+                (make-field-record (car input)
+                                   (cadr input)
+                                   #f
+                                   (caddr input)
+                                   (parse-type (cadddr input)))))
+             (parse-method
+              (lambda (input)
+                (make-method-record (car input)
+                                    (cadr input)
+                                    (parse-type (caddr input))
+                                    (map parse-type (cadddr input))
+                                    (map parse-type (list-ref input 4))
+                                    #f
+                                    (list-ref input 5))))
+             (parse-inner
+              (lambda (input)
+                (make-inner-record (car input)
+                                   (cadr input)
+                                   (symbol=? 'class (caddr input)))))
+             (parse-type
+              (lambda (input)
+                (cond
+                  ((symbol? input) input)
+                  ((number? (car input)) 
+                   (make-array-type (parse-type (cadr input)) (car input)))
+                  (else
+                   (make-ref-type (car input) (cdr input)))))))
+      (parse-class/iface (call-with-input-file filename read))))
+  
+  ;; write-record: class-record port->
+  (define (write-record rec port)
+    (letrec ((record->list
+              (lambda (r)
+                (list
+                 (if (class-record-class? r)
+                     'class
+                     'interface)
+                 (class-record-name r)
+                 (class-record-modifiers r)
+                 (class-record-object? r)
+                 (map field->list (class-record-fields r))
+                 (map method->list (class-record-methods r))
+                 (map inner->list (class-record-inners r))
+                 (class-record-parents r)
+                 (class-record-ifaces r)
+                 type-version)))
+             (field->list
+              (lambda (f)
+                (list
+                 (field-record-name f)
+                 (field-record-modifiers f)
+                 (field-record-class f)
+                 (type->list (field-record-type f)))))
+             (method->list
+              (lambda (m)
+                (list
+                 (method-record-name m)
+                 (method-record-modifiers m)
+                 (type->list (method-record-rtype m))
+                 (map type->list (method-record-atypes m))
+                 (map type->list (method-record-throws m))
+                 (method-record-class m))))
+             (inner->list
+              (lambda (i)
+                (list (inner-record-name i)
+                      (inner-record-modifiers i)
+                      (if (inner-record-class? i) 'class 'interface))))
+             (type->list
+              (lambda (t)
+                (cond
+                  ((symbol? t) t)
+                  ((ref-type? t) (cons (ref-type-class/iface t) (ref-type-path t)))
+                  ((array-type? t)
+                   (list (array-type-dim t) (type->list (array-type-type t))))))))
+      (pretty-print (record->list rec) port)))
+  )
diff --git a/collects/profjBoxes/info.ss b/collects/profjBoxes/info.ss
new file mode 100644
index 0000000000..25558f9a46
--- /dev/null
+++ b/collects/profjBoxes/info.ss
@@ -0,0 +1,5 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "ProfJ Boxes")
+  (define tools '(("tool.ss")))
+  (define tool-names (list "ProfJ Boxes"))
+  #;(define tool-icons '()))
diff --git a/collects/profjBoxes/private/box-helpers.ss b/collects/profjBoxes/private/box-helpers.ss
new file mode 100644
index 0000000000..fe951fe184
--- /dev/null
+++ b/collects/profjBoxes/private/box-helpers.ss
@@ -0,0 +1,11 @@
+(module box-helpers mzscheme
+  
+  (require (lib "list.ss")
+           (lib "etc.ss"))
+  
+  (provide last)
+  
+  (define (last alist)
+    (with-handlers ([void (lambda (error) false)])
+      (first (last-pair alist))))
+  )
\ No newline at end of file
diff --git a/collects/profjBoxes/private/example-box.ss b/collects/profjBoxes/private/example-box.ss
new file mode 100644
index 0000000000..de854632f4
--- /dev/null
+++ b/collects/profjBoxes/private/example-box.ss
@@ -0,0 +1,241 @@
+(module example-box mzscheme
+  
+  (require
+   (lib "mred.ss" "mred")
+   (lib "class.ss")
+   (lib "etc.ss")
+   (lib "list.ss")
+   (lib "embedded-gui.ss" "embedded-gui")
+   (lib "match.ss")
+   (lib "unitsig.ss")
+   (lib "tool.ss" "drscheme")
+   (lib "framework.ss" "framework")
+   (lib "parser.ss" "profj")
+   (lib "readerr.ss" "syntax")
+   (lib "make-snipclass.ss" "test-suite" "private")
+   (lib "string-constant.ss" "string-constants")
+   "table.ss"
+   "box-helpers.ss")
+  
+  (provide example-box@ example-box^)
+  
+  ;; This is wrong but it's a good enough prototype
+  (define re:java-id (regexp "[A-Za-z_]+"))
+  (define min-field-width 50)
+  
+  (define-signature example-box^ (example-box%))
+  (define example-box@
+    (unit/sig example-box^
+      (import drscheme:tool^)
+      
+      ;; A readable-snip<%> of an examples box to allow GUI contruction of data examples.
+      (define example-box%
+        (class* editor-snip% (readable-snip<%>)
+          (inherit set-snipclass)
+          
+          (init [examples-to-copy #f])
+          
+          #;(any? (union integer? false?) (union integer? false?) (union integer? false?)
+                  . -> .
+                  any?)
+          ;; Called to get the syntax object representing this box
+          (define/public read-special
+            (opt-lambda (source (line false) (column false) (position false))
+              #;(((is-a?/c text%))
+                 (natural-number? (union natural-number? false?))
+                 . opt-> .
+                 id?)
+              ;; Make an id out of the given text
+              ;; STATUS: I'm parsing the ID with a regexp that's probablly not
+              ;; the correct Java variable regexp. Furthermore, I need to parse
+              ;; it differently if it's a class name vs. field name.
+              ;;EDITED BY KATHY:: Commented this out because the result reading the example box
+              ;;is much different than Mike expected it would be
+              #;(define (text->java-id atext)
+                (let ([str (send atext get-text)])
+                  (match (regexp-match-positions re:java-id str 0 false)
+                    [((m-start . m-end))
+                     (datum->syntax-object
+                      false
+                      (string->symbol (substring str m-start m-end))
+                      (list atext
+                            1
+                            m-start
+                            (add1 m-start)
+                            (- m-end m-start)))]
+                    ;; STATUS: Here I need to provide for a better form of
+                    ;; highlighting using the GUI because there won't always
+                    ;; be text in the box to highlight.
+                    [else (raise-read-error
+                           (string-constant profjBoxes-bad-java-id-error)
+                           atext 1 1 1 (send atext last-position))])))
+              ;;EDITED BY KATHY:: Same reason as stated above
+              #;#`(begin #,@(send examples map-children
+                                (lambda (example)
+                                  (with-syntax ([name (text->java-id
+                                                       (send example get-name))]
+                                                [value (parse-expression
+                                                        (open-input-text-editor
+                                                         (send example get-value))
+                                                        (send example get-value)
+                                                        level)])
+                                    #'(define name value)))))
+              #`(parse-example-box (list #,@(send examples map-children
+                                                  (lambda (example)
+                                                    (with-syntax ([type (send example get-type)]
+                                                                  [id (send example get-name)]
+                                                                  [value (send example get-value)])
+                                                      #'(list type id value))))))
+              ))
+          
+          #;(-> void?)
+          ;; Gives this box the cursor focus
+          (define/public (take-caret)
+            (let ([first-box (send (send examples get-first-child) get-type)])
+              (send pb set-caret-owner
+                    (send (send first-box get-admin) get-snip)
+                    'display)))
+          
+          ;;;;;;;;;;
+          ;; Saving and copying
+          
+          #;((is-a?/c editor-stream-out%) . -> . void?)
+          ;; Writes the examples box to file
+          (define/override (write f)
+            (send examples write f))
+          
+          #;((is-a?/c editor-stream-in%) . -> . void?)
+          ;; Reads the examples state in from an editor-stream
+          (define/public (read-from-file f)
+            (send examples read-from-file f))
+          
+          #;(-> (is-a?/c test-case-box%))
+          ;; Makes a copy of this example box.
+          (define/override (copy)
+            (new example-box% (examples-to-copy examples)))
+          
+          ;;;;;;;;;;
+          ;; Layout
+          
+          (field [pb (new aligned-pasteboard%)])
+          (send pb lock-alignment true)
+          (field [main (new vertical-alignment% (parent pb))]
+                 [header (new horizontal-alignment% (parent main))])
+          
+          ;; Since I don't have an icon I'll just center this for now and leave out the image
+          (new horizontal-alignment% (parent header)) ; left spacer
+          #;(new snip-wrapper% (parent header) (snip (make-object image-snip%)))
+          (new embedded-message%
+               (parent header)
+               (label (string-constant profjBoxes-examples-label)))
+          (new horizontal-alignment% (parent header)) ; right spacer
+          
+          (field
+           [examples (new (table example%)
+                          (parent main)
+                          (copy-constructor examples-to-copy))]
+           [button-bar (new horizontal-alignment% (parent main))]
+           [add-button (new embedded-text-button%
+                            (parent button-bar)
+                            (label (string-constant profjBoxes-add-new-example-button))
+                            (callback (lambda (b e) (send examples add-new))))])
+          (super-new (editor pb))
+          (unless examples-to-copy
+            (send examples add-new))
+          (send pb lock-alignment false)
+          (set-snipclass sc)))
+      
+      (define sc (make-snipclass example-box% "example-box%"))
+      
+      ;; An example layed out in a horizontal manner. Allows access to the pieces of an example.
+      (define example%
+        (class* horizontal-alignment% (table-item<%>)
+          (inherit get-parent get-pasteboard next prev)
+          (init (copy-constructor #f))
+          
+          (field
+           [program-editor%
+            (cue-text-mixin
+             (tabbable-text-mixin
+              ((drscheme:unit:get-program-editor-mixin)
+               (editor:keymap-mixin text:basic%))))]
+           [type (new (single-line-text-mixin program-editor%)
+                      (cue-text (string-constant profjBoxes-type))
+                      (behavior '(on-char)))]
+           [name (new (single-line-text-mixin program-editor%)
+                      (cue-text (string-constant profjBoxes-name))
+                      (behavior '(on-char)))]
+           [value (new program-editor%
+                       (cue-text (string-constant profjBoxes-value))
+                       (behavior '(on-char)))])
+          
+          #;(-> (is-a?/c text%))
+          ;; The first text in the item that can be typed into
+          (define/public (get-first-text) (get-type))
+          
+          (define/public (get-type) type)
+          (define/public (get-name) name)
+          (define/public (get-value) value)
+          
+          #;((is-a?/c editor-stream-out%) . -> . void?)
+          ;; Write the example to file
+          (define/public (write f)
+            (send type write-to-file f)
+            (send name write-to-file f)
+            (send value write-to-file f))
+          
+          #;((is-a?/c editor-stream-out%) . -> . void?)
+          ;; Read the state of the example in from file
+          (define/public (read-from-file f)
+            (send type read-from-file f)
+            (send name read-from-file f)
+            (send value read-from-file f))
+          
+          (super-new)
+          
+          (when copy-constructor
+            (send (send copy-constructor get-type) copy-self-to type)
+            (send (send copy-constructor get-name) copy-self-to name)
+            (send (send copy-constructor get-value) copy-self-to value))
+          
+          ;;;;;;;;;;
+          ;; Tabbing
+          
+          (when (is-a? (prev) example%)
+            (set-tabbing (send (prev) get-value) type))
+          (set-tabbing type name value)
+          (if (is-a? (next) example%)
+              (set-tabbing value (send (next) get-type))
+              (send value set-ahead (lambda ()
+                                      (send (get-parent) add-new))))
+          
+          ;;;;;;;;;;
+          ;; Layout
+          
+          (send (get-pasteboard) lock-alignment true)
+          (new snip-wrapper%
+               (parent this)
+               (snip (new editor-snip%
+                          (editor type)
+                          (min-width min-field-width))))
+          (new snip-wrapper%
+               (parent this)
+               (snip (new editor-snip%
+                          (editor name)
+                          (min-width min-field-width))))
+          (new embedded-message% (parent this) (label " = "))
+          (new snip-wrapper%
+               (parent this)
+               (snip (new editor-snip%
+                          (editor value)
+                          (min-width min-field-width))))
+          (new embedded-message% (parent this) (label " ; "))
+          (new horizontal-alignment% (parent this)) ; spacer
+          (new embedded-text-button%
+               (parent this)
+               (label "Del")
+               (callback (lambda (b e) (send (get-parent) delete-child this))))
+          (send (get-pasteboard) lock-alignment false)
+          ))
+      ))
+  )
\ No newline at end of file
diff --git a/collects/profjBoxes/private/interactions-box.ss b/collects/profjBoxes/private/interactions-box.ss
new file mode 100644
index 0000000000..6a0fd46e83
--- /dev/null
+++ b/collects/profjBoxes/private/interactions-box.ss
@@ -0,0 +1,255 @@
+(module interactions-box mzscheme
+  
+  (require
+   (lib "mred.ss" "mred")
+   (lib "class.ss")
+   (lib "etc.ss")
+   (lib "list.ss")
+   (lib "embedded-gui.ss" "embedded-gui")
+   (lib "match.ss")
+   (lib "unitsig.ss")
+   (lib "tool.ss" "drscheme")
+   (lib "framework.ss" "framework")
+   (lib "readerr.ss" "syntax")
+   (lib "parser.ss" "profj")
+   (lib "string-constant.ss" "string-constants")
+   (lib "text-syntax-object.ss" "test-suite" "private")
+   (lib "print-to-text.ss" "test-suite" "private")
+   (lib "make-snipclass.ss" "test-suite" "private")
+   "table.ss")
+  
+  (provide interactions-box@
+           interactions-box^)
+  
+  (define-signature interactions-box^ (interactions-box%))
+  
+  (define interactions-box@
+    (unit/sig interactions-box^
+      (import drscheme:tool^ text->syntax-object^)
+      
+      (define interactions-box%
+        (class* editor-snip% (readable-snip<%>)
+          (inherit set-snipclass)
+          (init [interactions-to-copy #f])
+          
+          #;(any? (union integer? false?) (union integer? false?) (union integer? false?) . -> . any?)
+          ;; Called to get the syntax object representing this box
+          (define/public read-special
+            (opt-lambda (source (line false) (column false) (position false))
+              #;((is-a?/c text%) . -> . syntax-object?)
+              (define (text->syntax-object text)
+                (match (text->syntax-objects text)
+                  [() (raise-read-error
+                       (string-constant profjBoxes-empty-error)
+                       source line #f position 1)]
+                  [(stx) stx]
+                  [(stx next rest-stx ...)
+                   (raise-read-error (string-constant profjBoxes-too-many-expressions-error)
+                                     text
+                                     (syntax-line next)
+                                     (syntax-column next)
+                                     (syntax-position next)
+                                     (syntax-span next))]))
+              ;(lambda (level class-loc box-pos input-spec)
+              (let ([level 'beginner] [class-loc #f] [box-pos #f] [input-spec #f])
+                #`(begin
+                    #,@(send interactions map-children
+                             (lambda (interaction)
+                               (if (is-a? interaction interaction%)
+                                   (with-syntax ([display-output
+                                                  (lambda (value)
+                                                    (send interaction display-output value))])
+                                     #`(display-output
+                                        #,(text->syntax-object (send interaction get-input))
+                                        ;#,(parse-interactions
+                                        ;   (open-input-text-editor (send interaction get-input))
+                                        ;   (send interaction get-input)
+                                        ;   level)
+                                        ))
+                                   #'(void))))))))
+          
+          #;(-> void)
+          ;; tells the test-box to take the caret
+          (define/public (take-caret)
+            (let ([first-box (send (send interactions get-first-child) get-input)])
+              (send pb set-caret-owner
+                    (send (send first-box get-admin) get-snip)
+                    'display)))
+          
+          ;;;;;;;;;;
+          ;; Reading/Writing
+          
+          #;(-> (is-a?/c interactions-box%))
+          ;; Make an interaction box that is a copy of this interaction box
+          (define/override (copy)
+            (new interactions-box% (interactions-to-copy interactions)))
+          
+          #;((is-a?/c editor-stream-out%) . -> . void?)
+          ;; Writes this interactions box to file
+          (define/override (write f)
+            (send interactions write f))
+            
+          #;((is-a?/c editor-stream-in%) . -> . void?)
+          ;; Reads interactions from file
+          (define/public (read-from-file f)
+            (send interactions read-from-file f))
+          
+          ;;;;;;;;;;
+          ;; Layout
+          
+          (field
+           [pb (new aligned-pasteboard%)]
+           [main (new vertical-alignment% (parent pb))]
+           [header (new horizontal-alignment% (parent main))])
+          
+          (new horizontal-alignment% (parent header)) ; left spacer
+          (new snip-wrapper%
+               (snip (make-object string-snip%
+                       (string-constant profjBoxes-interactions-label)))
+               (parent header))
+          (new horizontal-alignment% (parent header)) ; right spacer
+          
+          (field [interactions (new (table interaction%)
+                                    (parent main)
+                                    (copy-constructor interactions-to-copy))])
+          
+          (super-new (editor pb))
+          (unless interactions-to-copy
+            (send interactions add-new))
+          (set-snipclass sc)))
+      
+      (define sc (make-snipclass interactions-box% "interactions-box%"))
+  
+      ;; One interaction laid out horizontally
+      (define interaction%
+        (class* horizontal-alignment% (table-item<%>)
+          (inherit get-parent next)
+          (init [copy-constructor #f])
+          
+          #;(-> (is-a?/c text%))
+          ;; The first text in the item that can be typed into
+          (define/public (get-first-text) (get-input))
+          
+          #;(-> (is-a?/c text%))
+          ;; The input of this interaction
+          (define/public (get-input) input-text)
+          
+          #;(-> void?)
+          ;; Resets the interaction to an inital state
+          (define/public (reset)
+            (send* output-text
+              (lock false)
+              (erase)
+              (lock true))
+            (send output show false))
+          
+          #;(string? . -> . void?)
+          ;; Sets the output to the given value
+          (define/public (display-output val)
+            (let ([blue-text (new style-delta%)])
+              (send blue-text set-delta-foreground "blue")
+              (send* output-text 
+                (lock false)
+                (change-style blue-text 'start 'end #f))
+              ;(print-to-text output-text (list val))
+              (send* output-text
+                (lock true))
+              (send output show true)))
+          
+          #;(-> void?)
+          ;; Insert a new interaction after this interaction
+          (define/public (make-new)
+            (send (get-parent) add-new this)
+            (send (send (next) get-input) set-caret-owner false 'global))
+          
+          #;((is-a?/c editor-stream-out%) . -> . void?)
+          ;; Writes the interaction to file
+          (define/public (write f)
+            (send input-text write-to-file f))
+          
+          #;((is-a?/c editor-stream-in%) . -> . void?)
+          ;; Reads the interaction from file
+          (define/public (read-from-file f)
+            (send input-text read-from-file f))
+          
+          (super-new)
+          
+          (define program-editor%
+            ((drscheme:unit:get-program-editor-mixin)
+             (interaction-text this)))
+          
+          (field [input-text (new program-editor%)]
+                 [output-text (new text%)])
+          
+          (when copy-constructor
+            (send (send copy-constructor get-input) copy-self-to input-text))
+          
+          (field [io (new vertical-alignment% (parent this))]
+                 [input (new horizontal-alignment% (parent io))])
+          (new embedded-message% (label " > ") (parent input))
+          (new snip-wrapper%
+               (snip (new stretchable-editor-snip%
+                          (editor input-text)
+                          (stretchable-height false)
+                          (with-border? false)
+                          (min-width 100)))
+               (parent input))
+          (new embedded-text-button%
+               (parent input)
+               (label "Ctrl + Enter")
+               (callback (lambda (b e) (make-new))))
+          
+          (field [output (new vertical-alignment% (parent io) (show? false))])
+          (new snip-wrapper%
+               (snip (new stretchable-editor-snip%
+                          (editor output-text)
+                          (stretchable-height false)
+                          (with-border? false)))
+               (parent output))
+          ))
+      
+      #;((is-a? interaction%) . -> . (is-a?/c text%))
+      ;; A text that is a program editor and also has keybindings that move around the
+      ;; interactions from the given interaction
+      (define (interaction-text interaction)
+        (class scheme:text%
+          
+          #;((is-a?/c interaction%) . -> . void?)
+          ;; Send the mouse cursor to the given interaction's input field
+          ;; NOTE: This function not considered harmful.
+          (define (goto inter)
+            (when (is-a? inter interaction%)
+              (let ([text (send inter get-input)])
+                (send text set-caret-owner false 'global))))
+      
+          (field [movement-keymap (make-object keymap%)])
+          
+          (send* movement-keymap
+            (add-function "goto-next-interaction"
+                          (lambda (ignored event)
+                            (goto (send interaction next))))
+            (map-function ":c:right" "goto-next-interaction")
+            (add-function "goto-prev-interaction"
+                          (lambda (ignored event)
+                            (goto (send interaction prev))))
+            (map-function ":c:left" "goto-prev-interaction")
+            (add-function "make-new"
+                          (lambda (ignored event)
+                            (send interaction make-new)))
+            (map-function ":c:return" "make-new")
+            (add-function "delete"
+                          (lambda (ignored event)
+                            (let ([next (send interaction next)])
+                              (send (send interaction get-parent) delete-child interaction)
+                              (goto next))))
+            (map-function ":c:delete" "delete"))
+          
+          #;(-> (listof keymap%))
+          ;; the list of keymaps associated with this text
+          (define/override (get-keymaps)
+            (cons movement-keymap (super get-keymaps)))
+          
+          (super-new)
+          ))
+      ))
+  )
\ No newline at end of file
diff --git a/collects/profjBoxes/private/table.ss b/collects/profjBoxes/private/table.ss
new file mode 100644
index 0000000000..857f6fb3e9
--- /dev/null
+++ b/collects/profjBoxes/private/table.ss
@@ -0,0 +1,108 @@
+(module table mzscheme
+  
+  (require
+   (lib "class.ss")
+   (lib "embedded-gui.ss" "embedded-gui")
+   (lib "etc.ss")
+   (lib "contract.ss"))
+  
+  ;; An interface for things that can be items of a table
+  (define table-item<%>
+    (interface ()
+      #;(-> (is-a?/c text%))
+      ;; The first text in the item that can be typed into
+      get-first-text
+      
+      #;((is-a?/c editor-stream-out%) . -> . void?)
+      ;; Writes the interaction to file
+      write
+     
+      #;((is-a?/c editor-stream-in%) . -> . void?)
+      ;; Reads the interaction from file
+      read-from-file))
+  
+  (provide/contract
+   (table ((implementation?/c table-item<%>) . -> . (implementation?/c alignment<%>)))
+   (table-item<%> interface?))
+  
+  ;; A table for holding element that must be accessed end writen to file
+  (define (table table-item-class%)
+    (class vertical-alignment%
+      (inherit get-pasteboard)
+      (inherit-field head tail)
+      (init [copy-constructor #f])
+      
+      ;;;;;;;;;;
+      ;; Accessors
+      
+      #;(-> (is-a?/c example%))
+      ;; The first example in the example field
+      (define/public (get-first-child)
+        (send head next))
+          
+      #;(((is-a?/c example%) . -> . any?) . -> . (listof any?))
+      ;; A list of the results of applying f to each example in the examples field.
+      (define/public (map-children f)
+        (send head map-to-list f))
+          
+      #;(((is-a?/c example%) . -> . void?) . -> . void?)
+      ;; For eaches over the children
+      (define/public (for-each-child f)
+        (send head for-each f))
+      
+      ;;;;;;;;;;
+      ;; Reading/Writing
+      
+      #;((is-a?/c editor-stream-out%) . -> . void?)
+      ;; Write the examples to file
+      (define/public (write f)
+        (let ([num-items (length (map-children void))])
+          (send f put num-items)
+          (for-each-child (lambda (c) (send c write f)))))
+      
+      #;((is-a?/c editor-stream-in%) . -> . void?)
+      ;; Reads the examples field's state in from the stream
+      (define/public (read-from-file f)
+        (send (get-pasteboard) lock-alignment true)
+        ;; Delete all examples
+        (send head for-each (lambda (c) (send c show false)))
+        (send head next tail)
+        (send tail prev head)
+        ;; Read in all the examples to the file.
+        (let* ([num-examples (box 0)])
+          (send f get num-examples)
+          (let loop ([n (unbox num-examples)])
+            (unless (zero? n)
+              (let ([example (new table-item-class% (parent this))])
+                (send example read-from-file f)
+                (loop (sub1 n))))))
+        (send (get-pasteboard) lock-alignment false))
+
+      ;;;;;;;;;;
+      ;; Adding
+      
+      #;(-> (is-a?/c alignment<%>))
+      ;; Adds a new example to the examples field.
+      (define/public add-new
+        (opt-lambda ((after #f))
+          (let ([item (new table-item-class% (parent this) (after after))])
+            (send (send item get-first-text) set-caret-owner false 'global)
+            item)))
+      
+      #;((is-a?/c example%) . -> . (is-a?/c example%))
+      ;; Adds a new example that is a copy of the given example
+      (define (add-new-copy example-to-copy)
+        (new table-item-class%
+             (parent this)
+             (copy-constructor example-to-copy)))
+      
+      ;;;;;;;;;;
+      ;; Constructor
+      
+      (super-new)
+      (when copy-constructor
+        (send (get-pasteboard) lock-alignment true)
+        (send copy-constructor for-each-child add-new-copy)
+        (send (get-pasteboard) lock-alignment false))
+      ))
+  )
\ No newline at end of file
diff --git a/collects/profjBoxes/tool.ss b/collects/profjBoxes/tool.ss
new file mode 100644
index 0000000000..8f9b85f736
--- /dev/null
+++ b/collects/profjBoxes/tool.ss
@@ -0,0 +1,73 @@
+(module tool mzscheme
+  
+  (provide tool@)
+  
+  (require
+   (lib "class.ss")
+   (lib "mred.ss" "mred")
+   (lib "unitsig.ss")
+   (lib "string-constant.ss" "string-constants")
+   (lib "tool.ss" "drscheme")
+   "private/example-box.ss"
+   "private/interactions-box.ss"
+   (lib "text-syntax-object.ss" "test-suite" "private"))
+  
+  (define extentions@
+    (unit/sig drscheme:tool-exports^
+      (import drscheme:tool^ example-box^ interactions-box^)
+      
+      (define (phase1) (void))
+      (define (phase2) (void))
+      
+      (define (frame-mixin %)
+        (class %
+          (inherit get-edit-target-object get-special-menu)
+          
+          ;; this function is copied from the drscheme/private/unit.ss file
+          (define (has-editor-on-demand menu-item)
+            (let ([edit (get-edit-target-object)])
+              (send menu-item enable (and edit (is-a? edit editor<%>)))))
+          
+          (super-new)
+          
+          (new menu-item%
+               (label (string-constant profjBoxes-insert-java-examples))
+               (parent (get-special-menu))
+               (callback
+                (lambda (menu event)
+                  (let ([box (new example-box%)]
+                        [text (get-edit-target-object)])
+                    (when text
+                      (send text begin-edit-sequence)
+                      (send text insert box)
+                      (send box take-caret)
+                      (send text end-edit-sequence)))))
+               (demand-callback has-editor-on-demand))
+          
+          (new menu-item%
+               (label (string-constant profjBoxes-insert-java-interactions))
+               (parent (get-special-menu))
+               (callback
+                (lambda (menu event)
+                  (let ([box (new interactions-box%)]
+                        [text (get-edit-target-object)])
+                    (when text
+                      (send text begin-edit-sequence)
+                      (send text insert box)
+                      (send box take-caret)
+                      (send text end-edit-sequence)))))
+               (demand-callback has-editor-on-demand))
+          ))
+
+      (drscheme:get/extend:extend-unit-frame frame-mixin)))
+  
+  (define tool@
+    (compound-unit/sig
+      (import (TOOL : drscheme:tool^))
+      (link (EXT : drscheme:tool-exports^ (extentions@ TOOL EXAMPLES INTERACTIONS))
+            (EXAMPLES : example-box^ (example-box@ TOOL))
+            (INTERACTIONS : interactions-box^ (interactions-box@ TOOL SYNTAX))
+            (SYNTAX : text->syntax-object^ (text->syntax-object@ TOOL)))
+      (export (var (EXT phase1))
+              (var (EXT phase2)))))
+  )
diff --git a/collects/profjWizard/assoc-list.scm b/collects/profjWizard/assoc-list.scm
new file mode 100644
index 0000000000..14e7638a6d
--- /dev/null
+++ b/collects/profjWizard/assoc-list.scm
@@ -0,0 +1,70 @@
+(module assoc-list mzscheme
+  
+  (require (lib "class.ss"))
+  
+  (provide assoc%)
+  
+  (define assoc%
+    (class object%
+      (super-new)
+      
+      ;; (Listof (Cons X Y))
+      (define fields '())
+      
+      ;; X Y -> Void
+      ;; add (cons x y) to fields 
+      (define/public (add type name)
+        (set! fields (cons (cons type name) fields)))
+      
+      ;; X -> Void
+      (define/public (remove type)
+        (set! fields
+              (let loop ([fields fields])
+                (cond
+                  [(null? fields) (error 'internal "can't happen: not in list")]
+                  [(eq? (caar fields) type) (cdr fields)]
+                  [else (cons (car fields) (loop (cdr fields)))]))))
+      
+      ;; -> (Listof Y)
+      ;; extract all y in the order in which they were entered
+      (define/public (list) (reverse! (map (lambda (f) (cdr f)) fields)))
+      
+      ;; -> Y
+      (define/public (lookup to-edit)        
+        (let loop ([v fields])
+          (cond
+            [(null? v) (error 'internal "can't find field")]
+            [(eq? (caar v) to-edit) (cdar v)]
+            [else (loop (cdr v))])))
+      
+      ;; X Y -> Void
+      (define/public (update to-edit new-v)
+        (set! fields
+              (let loop ([v fields])
+                (cond
+                  [(null? v) (error 'internal "can't find variant")]
+                  [(eq? (caar v) to-edit) (cons (cons (caar v) new-v) (cdr v))]
+                  [else (cons (car v) (loop (cdr v)))]))))))
+      
+      #| Tests:
+      (require (lib "testing.scm" "testing"))
+      
+      (define al (new assoc%))
+      
+      (send al add 0 1)
+      (test== (send al list) (list 1))
+      
+      (send al add 'a 'b)
+      (test== (send al list) (list 1 'b))
+      
+      (send al update 0 33)
+      (test== (send al lookup 0) 33)
+      
+      (send al remove 0)
+      (test== (send al list) (list 'b))
+      
+      (send al remove 'a)
+      (test== (send al list) '())
+      |#
+      
+      )
\ No newline at end of file
diff --git a/collects/profjWizard/aux-class.scm b/collects/profjWizard/aux-class.scm
new file mode 100644
index 0000000000..c21cea7979
--- /dev/null
+++ b/collects/profjWizard/aux-class.scm
@@ -0,0 +1,14 @@
+(module aux-class mzscheme 
+  (require (lib "class.ss"))
+  
+  (provide 
+   (all-from (lib "class.ss")) 
+   define/abstract ; (define/abstract <identifier>) :: <definition> 
+   )
+  
+  (define-syntax define/abstract 
+    (syntax-rules ()
+      [(define/abstract id)
+       (define/public id (lambda x (error 'id "abstract")))]))
+  
+  )
\ No newline at end of file
diff --git a/collects/profjWizard/aux-contract.scm b/collects/profjWizard/aux-contract.scm
new file mode 100644
index 0000000000..472462a1e1
--- /dev/null
+++ b/collects/profjWizard/aux-contract.scm
@@ -0,0 +1,23 @@
+(module aux-contract mzscheme
+  
+  (require-for-syntax (file "aux-syntax.scm"))
+  (require (lib "contract.ss"))
+  
+  (provide 
+   define-as-contract ;; <definition>
+   )
+  
+  ;; (define-as-contract string (id x ...) body ...)
+  ;; introduces Id for export as a contract and 
+  ;; is-id? for local testing as a function
+  (define-syntax (define-as-contract stx)
+    (syntax-case stx ()
+      [(_ message (name . args) . body)
+       (with-syntax ([is-name (prefix-id-suffix "is-" (syntax name) "?")]
+                     [ct-name (cap-id (syntax name))])
+         (syntax
+          (begin 
+            (define (is-name . args) . body)
+            (define ct-name (flat-named-contract message is-name)))))]))
+  
+  )
diff --git a/collects/profjWizard/aux-syntax.scm b/collects/profjWizard/aux-syntax.scm
new file mode 100644
index 0000000000..7f8638cf43
--- /dev/null
+++ b/collects/profjWizard/aux-syntax.scm
@@ -0,0 +1,32 @@
+#cs(module aux-syntax mzscheme 
+     
+     (provide 
+      prefix-id-suffix ; String Identifier String -> Identifier 
+      add?             ; Identifier -> Identifier 
+      cap-id           ; Identifier -> Identifier 
+      )
+     
+     (require (lib "string.ss"))
+     
+     (define (prefix-id-suffix prefix e suffix)
+       (datum->syntax-object
+        e (string->symbol (format "~a~a~a" prefix (syntax-e e) suffix))))
+     
+     ;; to add a ? at the end of an identifier
+     (define (add? e) (prefix-id-suffix "" e "?"))
+     
+     (define (cap-id id-e)
+       (let* ([id-s (symbol->string (syntax-e id-e))]
+              [fst (substring id-s 0 1)]
+              [rst (substring id-s 1 (string-length id-s))])
+         (string-uppercase! fst)
+         (datum->syntax-object id-e (string->symbol (string-append fst rst)))))
+     
+     #| Tests: 
+     (define e (datum->syntax-object #f 'e))
+     (printf "~s~n" (eq? 'set-e! (syntax-e (prefix-id-suffix "set-" e "!"))))
+     (printf "~s~n" (eq? 'e? (syntax-e (add? e))))
+     (printf "~s~n" (eq? 'Hello (syntax-e (cap-id (datum->syntax-object #f 'hello)))))
+     |#
+     
+     )
diff --git a/collects/profjWizard/class.scm b/collects/profjWizard/class.scm
new file mode 100644
index 0000000000..ecc53b0e43
--- /dev/null
+++ b/collects/profjWizard/class.scm
@@ -0,0 +1,593 @@
+#cs(module class mzscheme 
+     (require (lib "etc.ss") 
+              (lib "list.ss")
+              (lib "contract.ss")
+              (file "data-defs.scm"))
+     
+     ;; ------------------------------------------------------------------------
+     (provide/contract
+      [make-class ((Class) (boolean? boolean?) . opt-> . string?)] 
+      ) 
+     
+     #| Usage: 
+          (make-class a-class toString? template?) 
+        create a Java class from the class specification (a-class).
+
+        The first optional boolean parameter specifies whether we want toString 
+        in the class hiearchy. Default: true
+
+        The second optional boolean parameter specifies whether we want 
+        a draft method template in comments. Default: true
+     |#
+     
+     (provide/contract
+      [make-union ((Union) (boolean? boolean?) . opt-> . string?)]
+      )
+     
+     #| Usage: 
+         (make-union a-union toString? template?)
+        create a Java implementation of a datatype specification using an 
+        abstract class and N variants.
+
+        The first optional boolean parameter specifies whether we want toString 
+        in the class hiearchy. Default: true
+
+        The second optional boolean parameter specifies whether we want 
+        a draft method template in comments. Default: true
+     |#
+     
+     ;; ------------------------------------------------------------------------
+     ;; Construct a union as a collection of Java classes 
+     
+     ;; String (Listof VariantClass) -> String 
+     (define make-union
+       (opt-lambda (the-union [toString? #t][template? #t])
+         (let ([type (dt-type the-union)][type-fields (dt-fields the-union)])
+           (string-append
+            (car (purpose-statement (dt-purpose the-union)))
+            (abstractClass type type-fields template?)
+            "\n"
+            (commas
+             (map (lambda (sc)
+                    (make-class
+                     `(,(car sc) ,type ,(cadr sc) ,(variant-purpose sc))
+                     toString? 
+                     template?
+                     type-fields))
+                  (dt-variants the-union))
+             "\n")))))
+
+     ;; String -> String 
+     (define (abstractClass type type-fields template?)
+       (apply string-append 
+              `(,(format abstractF type)
+                 ;; fields
+                 ,@(map (lambda (f) (format declaf (car f) (cadr f))) type-fields)
+                 ;; optional abstract template 
+                 ,@(if (not template?)
+                       (list "")
+                       `( ,cmnt/*
+                          ,warnin
+                          ,purpos                            
+                          ,absteg
+                          ,cmnt*/))
+                 ,endclf)))
+     
+     ;; ------------------------------------------------------------------------
+     ;; Construct individual Java classes 
+     
+     ;; create class definition (as string) from name, super and list of fields
+     (define make-class 
+       (opt-lambda (the-class [toString? #t][template? #t][super-fields '()])
+         (let ([type   (car the-class)]
+               [super  (cadr the-class)]
+               [fields (caddr the-class)]
+               [prps   (class-purpose the-class)])
+           (apply string-append
+                  `(  ,@(purpose-statement prps)
+                      ,(format classf type (extends super))
+                      ;; fields
+                      ,@(map (lambda (f) (format declaf (car f) (cadr f))) fields)
+                      "\n"
+                      ;; constructor
+                      ,(class-constructor type fields super-fields)
+                      ;; optional template draft:
+                      ,@(make-template super fields template?)
+                      ;; optional toString method:
+                      ,@(toString type fields toString?)
+                      ,endclf)))))
+     
+     ;; String -> String
+     (define (extends super) (if (string=? "" super) "" (format extendsf super)))
+     
+     ;; String Fields Fields -> String
+     (define (class-constructor type fields super-fields)
+       (apply string-append
+              `( ,(format constf type (parameters (append super-fields fields)))
+                  #| When we switch to super in beginner, this will need to change.
+                  ;; call to super(super-fields)
+                  ,@(if (null? super-fields) '()
+                        (list (format superf (commas (map cadr super-fields)))))
+                  |#
+                  ;; init for fields 
+                  ,@(map (lambda (f) (format initif (cadr f) (cadr f))) 
+                         ;; When we switch to super in beginner, ... 
+                         (append super-fields fields))
+                  ,endMet)))
+     
+
+     ;; Fields -> String 
+     ;; create a paremeter list from a field specifications
+     (define (parameters fs)
+       (commas  (map (lambda (f) (format paraf (car f) (cadr f))) fs)))
+     
+     ;; String Fields Boolean -> (listof String)
+     (define (make-template super fields template?)
+       (if (not template?)
+           (list "")
+           `("\n"
+             ;; template method
+             ,cmnt/*
+             ,warnin
+             ,contef
+             ,@(map (lambda (f) (format (if (string=? (car f) super)
+                                            temprf
+                                            tempsf)
+                                        (cadr f)))
+                    fields)
+             ,endMet
+             ,cmnt*/)))
+     
+     ;; String Fields -> (cons String (listof String))
+     ;; create a toString method for class type with _fields_
+     (define toString 
+       (opt-lambda (type fields [toString? #t])
+         (if (not toString?)
+             (list "")
+             (list "\n"
+                   (string-append 
+                    toStrf     
+                    (format prefix type)
+                    ; (apply string-append)
+                    (if (null? fields)
+                        " + "
+                        (format
+                         " + ~a + " (commas (map addToString fields) infix)))
+                    postfix
+                    endMet)))))
+     
+     (provide toString)
+     
+     ;; Field -> String
+     ;; create a call to toString, if necessary 
+     (define (addToString f)
+       (let ([t (car f)] [s (cadr f)])
+         (if (member t StringNative) s (format "~a.toString()" s))))
+     
+     
+     ;; String -> (list String)
+     (define (purpose-statement prps)
+       (if (string=? "" prps) '("") (list (format "// ~a~n" prps))))
+
+     ;; identifiers ending in f are format strings, and require ~n for newline
+     
+     ;; Abstract Class 
+     (define abstractF "abstract class ~a {\n")
+     ;; Abstract Template 
+     (define purpos "  // purpose statement \n")
+     (define absteg "  abstract ??? mmm();\n")       
+     ;; Class 
+     (define classf "class ~a ~a{~n") (define extendsf "extends ~a ")
+     ;; Fields
+     (define declaf "  ~a ~a;~n")
+     ;; Constructor
+     (define constf "  ~a(~a) {~n") (define paraf "~a ~a")
+     (define superf "    super(~a);~n")
+     (define initif "    this.~a = ~a;~n")
+     (define endMet "  }\n")
+     (define endclf "}\n")
+     ;; Concrete Template
+     (define warnin "  // ** DRAFT TEMPLATE ** Edit as needed.\n")
+     (define contef "  ??? mmm() {\n")
+     (define tempsf "    ... this.~a ...\n")
+     (define temprf "    ... this.~a.mmm() ...\n")
+     ;; toString
+     (define toStrf "  public String toString() {\n")
+     (define prefix "    return \"new ~a(\"")
+     (define infix " + \",\" + ")
+     (define postfix "\")\";\n")
+     (define StringNative '("int" "boolean" "String" "double")) ;; and others
+     ;; Comments
+     (define cmnt/* "/*\n")
+     (define cmnt*/ "*/\n")
+     
+     ;; ------------------------------------------------------------------------
+     ;; Library 
+     
+     ;; (Listof String) -> String
+     ;; create a comma-separated string from a list of strings 
+     (define (commas l . comma)
+       (let ([comma (if (null? comma) ", " (car comma))])
+         (if (null? l) ""
+             (apply string-append (car l)
+                    (map (lambda (x) (string-append comma x)) (cdr l))))))
+     
+     ;; ------------------------------------------------------------------------
+     ;; TESTS: 
+     
+     (define empty-template 
+       `("/*\n" 
+         ,warnin
+         "  ??? mmm() {\n"
+         "  }\n"
+         "*/\n"
+         "\n"))
+     
+     #| Tests :
+     (require (lib "testing.scm" "testing"))
+     
+     (test== (commas '()) "")
+     (test== (commas '("x" "y") ) "x, y")
+     (test== (commas '("x" "y") " + ") "x + y")
+     
+     (test== (parameters '()) "")
+     (test== (parameters '(("int" "x"))) "int x")
+     (test== (parameters '(("int" "x") ("foo" "y"))) "int x, foo y")
+     (test== (commas '("x" "y") " + ") "x + y")
+     (test== (commas '("x" "y" "z") " + ") "x + y + z")
+     
+     (test== (cadr (toString "foo" '()))
+             (string-append
+              toStrf
+              "    return \"new foo(\" + \")\";\n"
+              endMet))
+     
+     (test== (cadr (toString "Foo" '(("Foo" "x") ("Moo" "y"))))
+             (string-append
+              toStrf
+              "    return \"new Foo(\" + x.toString() + \",\" + y.toString() + \")\";\n"
+              endMet))
+     
+     (test== (cadr (toString "Foo" '(("int" "x"))))
+             (string-append
+              toStrf
+              "    return \"new Foo(\" + x + \")\";\n"
+              endMet))
+     
+     (test== (cadr (toString "Foo" '(("Boolean" "x"))))
+             (string-append
+              toStrf
+              "    return \"new Foo(\" + x.toString() + \")\";\n"
+              endMet))
+     
+     (test== (cadr (toString "Foo" '(("Foo" "x") ("int" "y") ("Z" "z"))))
+             (string-append
+              toStrf
+              "    return \"new Foo(\" + x.toString() + \",\" + y + \",\" + z.toString() + \")\";\n"
+              endMet))
+     
+     (test== (toString "Foo" '(("Foo" "x") ("int" "y") ("Z" "z")) #f)
+             (list ""))
+     
+     (test== (class-constructor "Node" '(("int" "x")) '(("Info" "i") ("ATree" "parent")))
+             (string-append
+                    "  Node(Info i, ATree parent, int x) {\n"
+                    "    this.i = i;\n"
+                    "    this.parent = parent;\n"
+                    "    this.x = x;\n"
+                    "  }\n"
+                    )
+             "class constructor with super fields")
+
+     '(test== (class-constructor "Node" '(("int" "x")) '(("Info" "i") ("ATree" "parent")))
+             (string-append
+                    "  Node(Info i, ATree parent, int x) {\n"
+                    "    super(i, parent);\n"
+                    "    this.x = x;\n"
+                    "  }\n"
+                    )
+             "class constructor with super fields")
+     
+     (test== (make-class (list "foo" "" '()))
+             (apply string-append 
+                    `( "class foo {\n"
+                       "\n"
+                       "  foo() {\n"
+                       "  }\n"
+                       "\n"
+                       ,@empty-template
+                       "  public String toString() {\n"
+                       "    return \"new foo(\" + \")\";\n"
+                       "  }\n"
+                       "}\n")))
+     
+     (test== (make-class (list "moo" "foo" '()))
+             (apply string-append 
+                    `("class moo extends foo {\n"
+                      "\n"
+                      "  moo() {\n"
+                      "  }\n"
+                      "\n"
+                      ,@empty-template
+                      "  public String toString() {\n"
+                      "    return \"new moo(\" + \")\";\n"
+                      "  }\n"
+                      "}\n")))
+     
+     (test== (make-class (list "moo" "foo" '(("int" "x") ("foo" "f"))))
+             (apply string-append
+                    `("class moo extends foo {\n"
+                      "  int x;\n"
+                      "  foo f;\n"
+                      "\n"
+                      "  moo(int x, foo f) {\n"
+                      "    this.x = x;\n"
+                      "    this.f = f;\n"
+                      "  }\n"
+                      "\n"
+                      ,cmnt/*
+                      ,warnin
+                      "  ??? mmm() {\n"
+                      "    ... this.x ...\n"
+                      "    ... this.f.mmm() ...\n"
+                      "  }\n"
+                      ,cmnt*/
+                      "\n"
+                      "  public String toString() {\n"
+                      "    return \"new moo(\" + x + \",\" + f.toString() + \")\";\n"
+                      "  }\n"
+                      "}\n")))
+     
+     (test== (make-class (list "CartPt" "" '(("int" "x") ("int" "y"))))
+             (apply string-append
+                    `("class CartPt {\n"
+                      "  int x;\n"
+                      "  int y;\n"
+                      "\n"
+                      "  CartPt(int x, int y) {\n"
+                      "    this.x = x;\n"
+                      "    this.y = y;\n"
+                      "  }\n"
+                      "\n"
+                      ,cmnt/*
+                      ,warnin
+                      "  ??? mmm() {\n"
+                      "    ... this.x ...\n"
+                      "    ... this.y ...\n"
+                      "  }\n"
+                      ,cmnt*/
+                      "\n"
+                      "  public String toString() {\n"
+                      "    return \"new CartPt(\" + x + \",\" + y + \")\";\n"
+                      "  }\n"
+                      "}\n")))
+     
+     (test== (abstractClass "Foo" '() #f)
+             (string-append 
+              "abstract class Foo {\n"
+              "}\n"))
+     
+     (test== (abstractClass "Foo" '(("int" "x")) #f)
+             (string-append 
+              "abstract class Foo {\n"
+              "  int x;\n"
+              "}\n")
+             "abstract class with fields")
+     
+     (test== (abstractClass "Foo" '() #t)
+             (apply string-append 
+                    `("abstract class Foo {\n"
+                      ,cmnt/*                        
+                      ,warnin
+                      ,purpos
+                      "  abstract ??? mmm();\n"
+                      ,cmnt*/
+                      "}\n")))
+     
+     (test== (abstractClass "Foo" '(("int" "x")) #t)
+             (apply string-append 
+                    `("abstract class Foo {\n"
+                      "  int x;\n"
+                      ,cmnt/*                        
+                      ,warnin
+                      ,purpos
+                      "  abstract ??? mmm();\n"
+                      ,cmnt*/
+                      "}\n"))
+             "abstract class with fields and template")
+     
+     (test== 
+      (make-union
+       (make-dt "AList" '() '(("MT" ()) ("Cons" (("int" "first") ("AList" "rest")))) ""))
+      (apply string-append 
+             `(
+               "abstract class AList {\n"
+               "/*\n"
+               ,warnin
+               "  // purpose statement \n"
+               "  abstract ??? mmm();\n"
+               "*/\n"
+               "}\n"
+               "\n"
+               "class MT extends AList {\n"
+               "\n"
+               "  MT() {\n"
+               "  }\n"
+               "\n"
+               "/*\n"
+               ,warnin
+               "  ??? mmm() {\n"
+               "  }\n"
+               "*/\n"
+               "\n"
+               "  public String toString() {\n"
+               "    return \"new MT(\" + \")\";\n"
+               "  }\n"
+               "}\n"
+               "\n"
+               "class Cons extends AList {\n"
+               "  int first;\n"
+               "  AList rest;\n"
+               "\n"
+               "  Cons(int first, AList rest) {\n"
+               "    this.first = first;\n"
+               "    this.rest = rest;\n"
+               "  }\n"
+               "\n"
+               "/*\n"
+               ,warnin
+               "  ??? mmm() {\n"
+               "    ... this.first ...\n"
+               "    ... this.rest.mmm() ...\n"
+               "  }\n"
+               "*/\n"
+               "\n"
+               "  public String toString() {\n"
+               "    return \"new Cons(\" + first + \",\" + rest.toString() + \")\";\n"
+               "  }\n"
+               "}\n"
+               )
+             )
+      "full make union")
+     
+     (test== 
+      (make-union
+       (make-dt "AList" '() '(("MT" ()) ("Cons" (("int" "first") ("AList" "rest")))) "")
+       #f #f)
+      (apply string-append 
+             `(
+               "abstract class AList {\n"
+               "}\n"
+               "\n"
+               "class MT extends AList {\n"
+               "\n"
+               "  MT() {\n"
+               "  }\n"
+               "}\n"
+               "\n"
+               "class Cons extends AList {\n"
+               "  int first;\n"
+               "  AList rest;\n"
+               "\n"
+               "  Cons(int first, AList rest) {\n"
+               "    this.first = first;\n"
+               "    this.rest = rest;\n"
+               "  }\n"
+               "}\n"
+               )
+             )
+      "partial make union")
+   
+     (test== (make-class (list "foo" "" '() "hello world"))
+             (apply string-append 
+                    `( "// hello world\n"
+                       "class foo {\n"
+                       "\n"
+                       "  foo() {\n"
+                       "  }\n"
+                       "\n"
+                       ,@empty-template
+                       "  public String toString() {\n"
+                       "    return \"new foo(\" + \")\";\n"
+                       "  }\n"
+                       "}\n")))
+
+     (test== 
+      (make-union
+       (make-dt "AList" '() '(("MT" ()) ("Cons" (("int" "first") ("AList" "rest")))) "hello world")
+       #f #f)
+      (apply string-append 
+             `("// hello world\n"
+               "abstract class AList {\n"
+               "}\n"
+               "\n"
+               "class MT extends AList {\n"
+               "\n"
+               "  MT() {\n"
+               "  }\n"
+               "}\n"
+               "\n"
+               "class Cons extends AList {\n"
+               "  int first;\n"
+               "  AList rest;\n"
+               "\n"
+               "  Cons(int first, AList rest) {\n"
+               "    this.first = first;\n"
+               "    this.rest = rest;\n"
+               "  }\n"
+               "}\n"
+               )
+             )
+      "make union with purpose statement")
+     
+     (test== 
+      (make-union
+       (make-dt
+        "AList" '() '(("MT" ()) ("Cons" (("int" "first") ("AList" "rest")) "pair")) "hello world")
+       #f #f)
+      (apply string-append 
+             `("// hello world\n"
+               "abstract class AList {\n"
+               "}\n"
+               "\n"
+               "class MT extends AList {\n"
+               "\n"
+               "  MT() {\n"
+               "  }\n"
+               "}\n"
+               "\n"
+               "// pair\n"
+               "class Cons extends AList {\n"
+               "  int first;\n"
+               "  AList rest;\n"
+               "\n"
+               "  Cons(int first, AList rest) {\n"
+               "    this.first = first;\n"
+               "    this.rest = rest;\n"
+               "  }\n"
+               "}\n"
+               )
+             )
+      "make union with purpose statement for variants")
+     
+     (test== 
+      (make-union
+       (make-dt
+        "AList"
+        '(("Common" "field") ("Common" "field2"))
+        '(("MT" ()) ("Cons" (("int" "first") ("AList" "rest")) "pair"))
+        "hello world")
+       #f #f)
+      (apply string-append 
+             `("// hello world\n"
+               "abstract class AList {\n"
+               "  Common field;\n"
+               "  Common field2;\n"
+               "}\n"
+               "\n"
+               "class MT extends AList {\n"
+               "\n"
+               "  MT(Common field, Common field2) {\n"
+               "    this.field = field;\n"
+               "    this.field2 = field2;\n"
+               "  }\n"
+               "}\n"
+               "\n"
+               "// pair\n"
+               "class Cons extends AList {\n"
+               "  int first;\n"
+               "  AList rest;\n"
+               "\n"
+               "  Cons(Common field, Common field2, int first, AList rest) {\n"
+               "    this.field = field;\n"
+               "    this.field2 = field2;\n"
+               "    this.first = first;\n"
+               "    this.rest = rest;\n"
+               "  }\n"
+               "}\n"
+               )
+             )
+      "make union with common fields")
+     |#
+     )
+   
\ No newline at end of file
diff --git a/collects/profjWizard/data-defs.scm b/collects/profjWizard/data-defs.scm
new file mode 100644
index 0000000000..a021157334
--- /dev/null
+++ b/collects/profjWizard/data-defs.scm
@@ -0,0 +1,131 @@
+#| Data Defs
+
+ Class          = (list Name SuperClass Fields [Comment])
+ ;; the name of the class, the name of the supertype ("" if none), and 
+ ;; the class's fields
+
+ DataType       = (make-union TypeName Fields VariantClasses Comment)
+ ;; the name of the type and its variants
+ 
+ VariantClasses = (Listof VariantClass)
+ VariantClass   = (list Name Fields [Comment])
+
+ Name           = String 
+ TypeName       = String 
+ SuperClass     = String 
+ Fields         = (Listof Field)
+ Field          = (list String String)
+|#
+
+#cs
+(module data-defs mzscheme 
+  
+  (define-struct dt (type fields variants purpose))
+  
+  ;; Examples
+  (define field1 '("int" "x"))
+  (define field2 '("int" "y"))
+  (define field3 '("boolean" "b"))
+  (define fields (list field1 field2 field3))
+  (define vc1    (list "Leaf" (list field1)))
+  (define vc2    (list "Node" '(("ATree" "left") ("ATree" "right"))))
+  (define datat1 (make-dt "ATree" '() (list vc1 vc2) "a tree for ints"))
+  
+  (require (file "aux-contract.scm"))
+  (require (lib "contract.ss"))
+  
+  (provide 
+   Class   ;; flat-contract
+   Union   ;; flat-contract 
+   Variant ;; flat-contract 
+   Fields  ;; flat-contract
+   java-id? ;; Any -> Boolean
+   class-purpose ;; Class -> String
+   variant-purpose ;; Variant -> String
+   )
+  
+  ;; DataType -> String
+  ;; (define (union-purpose dt) (if (null? (cddr dt)) "" (caddr dt)))
+  
+  ;; Class -> String
+  (define (class-purpose c) (if (null? (cdddr c)) "" (cadddr c)))
+  
+  ;; Variant -> String 
+  (define (variant-purpose c) (if (null? (cddr c)) "" (caddr c)))
+  
+  ;; Any -> Boolean
+  ;; the string isn't empty and contains no spaces 
+  ;; I should really import this from Kathy's parser or whatever
+  ;; so I get qualified names and whatever right
+  (define (java-id? s)
+    (and (string? s) (not (string=? "" s)) (not (regexp-match "[ |\t|\n]" s))))
+  
+  (define-as-contract "<Class>" (class c)
+    (and (pair? c) (pair? (cdr c)) (pair? (cddr c)) 
+         (or (null? (cdddr c))
+             (and (pair? (cdddr c))
+                  (null? (cddddr c))
+                  (string? (cadddr c))))
+         ; (list? c) (= (length c) 3)
+         (java-id? (car c))
+         (let ([super (cadr c)])
+           (or (java-id? super) (string=? super "")))
+         (is-fields? (caddr c))))
+  
+  (define-as-contract "<Fields>" (fields l)
+    (and (list? l) (andmap is-field? l)))
+  
+  (define-as-contract "<Field in Class>" (field l)
+    (and (pair? l) (pair? (cdr l)) (null? (cddr l))
+         (java-id? (car l)) (java-id? (cadr l))))
+  
+  (define-as-contract "<Union>" (union l) (dt? l))
+  
+  (define (is-variants? l) (andmap is-variant? l))
+  
+  (define-as-contract "<Variant>" (variant c) 
+    (and (pair? c) (pair? (cdr c)) 
+         (or
+          (null? (cddr c))
+          (and
+           (pair? (cddr c))
+           (null? (cdddr c))
+           (string? (caddr c)))
+          ; (list? c) (= (length c) 2)
+          (java-id? (car c))
+          (is-fields? (cadr c)))))
+  
+  (provide/contract 
+   (struct dt ((type java-id?)
+               (fields (listof is-field?))
+               (variants (listof is-variant?))
+               (purpose string?))))
+  
+  
+  #| Tests:   
+  (require (lib "testing.scm" "testing"))
+  
+  (test== (java-id? "oops no") #f)
+  (test== (java-id? " oops 2") #f)
+  (test== (java-id? " oops2 ") #f)
+  (test== (java-id? "") #f)
+  (test== (java-id? (string #\tab)) #f)
+  (test== (java-id? (string #\newline)) #f)
+  
+  (test== (is-class? '("Foo" "" ())) #t)
+  (test== (is-class? '("Foo" "" () "hello world")) #t)
+  (test== (is-class? '("Foo" "Moo" (("int" "x") ("int" "y")) "hello world")) #t)
+  
+  (test== (is-class? '("Foo" "Moo")) #f "no fields")
+  (test== (is-class? '("Foo" "Moo Oops" ())) #f "space in super name")
+  
+  (test== (class-purpose '("a" "b" ())) "")
+  (test== (class-purpose '("a" "b" () "hello world")) "hello world")
+  
+  (test== (is-variant? (list "B" '())) #t "variant class")
+  (test== (andmap is-variant?  (list (list "B" '()) (list "C" '()))) #t "variants")
+  (test== (java-id? "A") #t)
+  (test== (is-union? (make-dt "A" '() (list (list "B" '()) (list "C" '())) "")) #t)
+  |#
+  
+  )
diff --git a/collects/profjWizard/data-defs0.scm b/collects/profjWizard/data-defs0.scm
new file mode 100644
index 0000000000..71ed155eb4
--- /dev/null
+++ b/collects/profjWizard/data-defs0.scm
@@ -0,0 +1,129 @@
+#| Data Defs
+
+ Class          = (list Name SuperClass Fields [Comment])
+ ;; the name of the class, the name of the supertype ("" if none), and 
+ ;; the class's fields
+
+ DataType       = (list TypeName VariantClasses [Comment])
+ ;; the name of the type and its variants
+ 
+ VariantClasses = (Listof VariantClass)
+ VariantClass   = (list Name Fields [Comment])
+
+ Name           = String 
+ TypeName       = String 
+ SuperClass     = String 
+ Fields         = (Listof Field)
+ Field          = (list String String)
+|#
+
+#cs
+(module data-defs mzscheme 
+  
+  ;; Examples
+  (define field1 '("int" "x"))
+  (define field2 '("int" "y"))
+  (define field3 '("boolean" "b"))
+  (define fields (list field1 field2 field3))
+  (define vc1    (list "Leaf" (list field1)))
+  (define vc2    (list "Node" '(("ATree" "left") ("ATree" "right"))))
+  (define datat1 (list "ATree" (list vc1 vc2) "a tree for ints"))
+  
+  
+  (require (file "aux-contract.scm"))
+  (require (lib "contract.ss"))
+  
+  (provide 
+   Class   ;; flat-contract
+   Union   ;; flat-contract 
+   Variant ;; flat-contract 
+   java-id? ;; Any -> Boolean
+   class-purpose ;; Class -> String
+   union-purpose ;; Union -> String 
+   variant-purpose ;; Variant -> String
+   )
+  
+  ;; DataType -> String
+  (define (union-purpose dt) (if (null? (cddr dt)) "" (caddr dt)))
+  
+  ;; Class -> String
+  (define (class-purpose c) (if (null? (cdddr c)) "" (cadddr c)))
+  
+  ;; Variant -> String 
+  (define (variant-purpose c) (if (null? (cddr c)) "" (caddr c)))
+  
+  ;; Any -> Boolean
+  ;; the string isn't empty and contains no spaces 
+  ;; I should really import this from Kathy's parser or whatever
+  ;; so I get qualified names and whatever right
+  (define (java-id? s)
+    (and (string? s) (not (string=? "" s)) (not (regexp-match "[ |\t|\n]" s))))
+  
+  (define-as-contract "<Class representation>" (class c)
+                      (and (pair? c) (pair? (cdr c)) (pair? (cddr c)) 
+                           (or (null? (cdddr c))
+                               (and (pair? (cdddr c))
+                                    (null? (cddddr c))
+                                    (string? (cadddr c))))
+                           ; (list? c) (= (length c) 3)
+                           (java-id? (car c))
+                           (let ([super (cadr c)])
+                             (or (java-id? super) (string=? super "")))
+                           (is-fields? (caddr c))))
+  
+  (define (is-fields? l)
+    (and (list? l) (andmap is-field? l)))
+  
+  (define (is-field? l)
+    (and (pair? l) (pair? (cdr l)) (null? (cddr l))
+         (java-id? (car l)) (java-id? (cadr l))))
+  
+  (define-as-contract "<Union (datatype) representation>" (union l)
+                      (and (pair? l) (pair? (cdr l))
+                           (or (null? (cddr l))
+                               (and (pair? (cddr l))
+                                    (null? (cdddr l))
+                                    (string? (caddr l))))
+                           (java-id? (car l))
+                           (andmap is-variant? (cadr l))))
+  
+  (define-as-contract "<Variant (in a union)>" (variant c) 
+                      (and (pair? c) (pair? (cdr c)) 
+                           (or
+                            (null? (cddr c))
+                            (and
+                             (pair? (cddr c))
+                             (null? (cdddr c))
+                             (string? (caddr c)))
+                            ; (list? c) (= (length c) 2)
+                            (java-id? (car c))
+                            (is-fields? (cadr c)))))
+
+  
+  
+  #| Tests: 
+     (require (lib "testing.scm" "testing"))
+     
+     (test== (java-id? "oops no") #f)
+     (test== (java-id? " oops 2") #f)
+     (test== (java-id? " oops2 ") #f)
+     (test== (java-id? "") #f)
+     (test== (java-id? (string #\tab)) #f)
+     (test== (java-id? (string #\newline)) #f)
+     
+     (test== (is-class? '("Foo" "" ())) #t)
+     (test== (is-class? '("Foo" "" () "hello world")) #t)
+     (test== (is-class? '("Foo" "Moo" (("int" "x") ("int" "y")) "hello world")) #t)
+     
+     (test== (is-class? '("Foo" "Moo")) #f "no fields")
+     (test== (is-class? '("Foo" "Moo Oops" ())) #f "space in super name")
+     
+     (test== (class-purpose '("a" "b" ())) "")
+     (test== (class-purpose '("a" "b" () "hello world")) "hello world")
+     
+     (test== (is-variant? (list "B" '())) #t "variant class")
+     (test== (andmap is-variant?  (list (list "B" '()) (list "C" '()))) #t "variants")
+     (test== (java-id? "A") #t)
+     (test== (is-union? (list "A" (list (list "B" '()) (list "C" '())))) #t)
+     |#
+  )
diff --git a/collects/profjWizard/design-history b/collects/profjWizard/design-history
new file mode 100644
index 0000000000..a4f4c11437
--- /dev/null
+++ b/collects/profjWizard/design-history
@@ -0,0 +1,16 @@
+view0: 
+ design interfaces by hand 
+ abstract into functions 
+ abstract common pieces via multiple values 
+
+view: 
+ replace the multiple values abstraction with classes
+
+data-def0
+ everything is a list 
+
+data-def 
+ unions (dt) becomes a struct so that I could add common fields 
+
+draw-txt0
+ explorative prototype
diff --git a/collects/profjWizard/draw-txt.ss b/collects/profjWizard/draw-txt.ss
new file mode 100644
index 0000000000..ebfe696add
--- /dev/null
+++ b/collects/profjWizard/draw-txt.ss
@@ -0,0 +1,440 @@
+#cs
+(module draw-txt mzscheme
+  (require (lib "etc.ss")
+           (lib "list.ss")
+           (lib "contract.ss")
+           (file "data-defs.scm"))
+  
+  (provide/contract
+   [dt-draw    (Union . -> . string?)]
+   [class-draw (Class . -> . string?)])
+  
+  ;; ---------------------------------------------------------------------------
+  ;; Deal with a Union of classes 
+  
+  ;; DataType -> String
+  (define (dt-draw dt)
+    (let ([spr (dt-type dt)]
+	  [vts (dt-variants dt)])
+      (if (null? vts)
+	  (class-draw (list spr "" (dt-fields dt)))
+    (let*-values 
+        ([(vts-as-strings recursive?) (variants*-to-strings vts spr)]
+         [(width)
+          (apply + (map (lambda (x) (string-length (car x))) vts-as-strings))]
+         ;; calculate the connection point for the first and last variant
+         ;; then create a line that connects those two points 
+         [(last)            (caar (last-pair vts-as-strings))]
+         [(fst-bar)         (find-bar (caar vts-as-strings))]
+         [(last-bar)        (find-bar last)]
+         [(width-of-last)   (string-length last)] 
+         [(center-of-last)  (+ (- width width-of-last) (find-bar last))])
+      (strings->string-as-lines
+       (add-recursion-connector
+        recursive?
+        (append
+         (abstract-to-string spr (dt-fields dt) width recursive?)
+         (map (lambda (x) (centered x width)) REFINEMENT-ARROW)
+         (list (string-append 
+                (make-string fst-bar #\space)
+                (make-string (- width fst-bar (- width-of-last +1 last-bar)) #\-)
+                (make-string (- width-of-last +1 last-bar) #\space)))
+         (flatten-string-matrix vts-as-strings))))))))
+  
+  ;; String -> Number
+  (define (find-bar s)
+    (let loop ([i (- (string-length s) 1)])
+      (cond [(< i 0) (error 'find-bar "can't happen: ~e" s)]
+            [(char=? (string-ref s i) #\|) i]
+            [else (loop (- i 1))])))
+ 
+  ;; (Listof String) -> (Listof String)
+  ;; add 
+  ;; 
+  ;;  --+ // on second line 
+  ;;    |
+  ;;  --+ // on last line 
+  ;; to los 
+  (define/contract add-recursion-connector 
+    (boolean?
+     (and/c (listof string?) (lambda (los) (>= (length los) 3)))
+     . -> .
+     any)
+    (lambda (r los)
+      (if (not r) los
+      (let* ([fst (car los)]
+             [snd (cadr los)]
+             [lst (car (last-pair los))]
+             [BLK "   "]
+             [CON "--+"]
+             [LIN "  |"])
+        (cons (string-append fst BLK)
+              (cons (string-append snd CON)
+                    (let loop ([l (cddr los)])
+                      (cond
+                        [(null? (cdr l)) (list (string-append lst CON))]
+                        [else (cons (string-append (car l) LIN) 
+                                    (loop (cdr l)))]))))))))
+  
+  (define REFINEMENT-ARROW
+    (list "/ \\"
+          "---"
+          " | "))
+  
+  ;; Class Fields Number Boolean-> (Listof String)
+  ;; create a list of strings that represent the abstract class of a union 
+  ;; center the strings with respect to width, add a "recursion" arrow (needed?)
+  (define/contract abstract-to-string
+    (string? Fields natural-number/c boolean?
+             . ->d . 
+             (lambda (_1 _2 n _3)
+               (lambda (out) (= (string-length (car out)) n))))
+    (lambda (spr fields width recursive)
+      (let* ([class-as-strings (class-to-strings (list spr "" fields))]
+             [width-of-classes  (string-length (car class-as-strings))]
+             [super-line (centered (cadr class-as-strings) width)])
+        (cons
+         (centered (car class-as-strings) width)
+         (cons (if recursive (add-<-- super-line) super-line)
+               (map (lambda (x) (centered x width)) 
+                    (cddr class-as-strings)))))))
+  
+  ;; String -> String 
+  ;; add the containment arrow to an abstract class from the right fringe
+  (define (add-<-- x0) 
+    (list->string
+     (reverse!
+      (let loop ([x (reverse! (string->list x0))])
+        (cond
+          [(char=? (cadr x) #\|) (cons #\< (cdr x))]
+          [else (cons #\- (loop (cdr x)))])))))
+  
+  ;; VariantClasses Super -> (Listof String)
+  ;; for testing and printing only 
+  (define (variants*-draw variants spr)
+    (let-values ([(s b) (variants*-to-strings variants spr)])
+      (flatten-string-matrix s)))
+  
+  ;; VariantClasses Super -> (Listof (Listof String)) Boolean
+  ;; turns a list of Variants into a list of strings, one per line 
+  (define (variants*-to-strings variants spr)
+    (let* ([d (apply max (map (lambda (vc) (length (second vc))) variants))]
+           [recursion #f])
+      (values 
+       (let loop ([v variants][cnnctd #f])
+         (cond
+           [(null? v) (set! recursion cnnctd) '()]
+           [else (let-values ([(s b) (variant-to-strings (car v) spr cnnctd d)])
+                   (cons s (loop (cdr v) (or cnnctd b))))]))
+       ;; ordering: begin
+       recursion)))
+  
+  ;; VariantClass Super Boolean Number -> String 
+  (define (variant-draw class super left-connected depth)
+    (let-values ([(s b) (variant-to-strings class super left-connected depth)])
+      (strings->string-as-lines s)))
+  
+  ;; VariantClass Super Boolean Number ->* String Boolean 
+  ;; turns a variant class into a list of strings, 
+  ;; computes whether the class points to super
+  ;; with hooks for refinement arrows and for recursive containment arrows
+  ;; with depth :: max number of fields in a variant class of the uion 
+  ;; with left-connected :: whether or not a variant to the left is already rec
+  ;; with super :: the name of the datatype
+  (define (variant-to-strings variant super left-connected depth)
+    (let* ([cs
+            (class-to-strings (cons (car variant) (cons super (cdr variant))))]
+           [head (list (car cs) (cadr cs) (caddr cs))]
+           [tail (cdddr cs)]
+           [fields (second variant)]
+           [types (map first fields)]
+           [recursion #f]
+           [CON "-+"]
+           [CN2 " +"]
+           [STG "--"] ;; (= (string-length CON) (string-length BLK))
+           [BLK "  "] ;; (= (string-length CON) (string-length BLK))          
+           [LIN " |"] ;; (= (string-length CON) (string-length LIN))
+           [junk (lambda _ (symbol->string (gensym)))]
+           [width (string-length (car cs))]
+           [mkln (lambda (lft ch str) 
+                   (string-append lft (make-string width ch) str))])
+      (values 
+       (append
+        (list (string-append BLK (centered "|" width) BLK))
+        (map (lambda (line type)
+               (string-append BLK 
+                              line 
+                              (cond
+                                [(string=? type super) (set! recursion #t) CON]
+                                [recursion LIN]
+                                [else BLK])))
+             cs
+             ;; pad types with junk lines for class header and class bottom
+             (append (map junk head) types (list (junk))))
+        (build-list (- depth -1 (length fields))
+                    (lambda _  (mkln BLK #\space (if recursion LIN BLK))))
+        (list
+         (if left-connected
+             (mkln STG #\- (if recursion CON STG))
+             (mkln BLK #\space (if recursion CN2 BLK)))))
+       recursion)))
+  
+  ;; ---------------------------------------------------------------------------
+  ;; Deal with a single class 
+  
+  ;; Class -> String
+  (define (class-draw class) 
+    (strings->string-as-lines (class-to-strings class)))
+  
+  ;; Class -> (cons String (cons String (cons String (Listof String))))
+  ;; turns a class into a list of strings that represents the class 
+  (define (class-to-strings class)
+    (let* ([name    (first class)]
+           [super   (second class)]
+           [fields  (third class)]
+           [types   (map first fields)]
+           [names   (map second fields)]   
+           ;; start drawing 
+           [fields  (create-field-declarations fields)]                         
+           [width   (width-class name fields)] 
+           [separat (make-separator-line width)])
+      `(,separat
+         ,((make-line width) name)
+         ,separat
+         ,@(map (make-line width) fields)
+         ,separat)))
+  
+  ;; (Listof Field) -> (Listof String)
+  ;; create text lines from Fields
+  (define (create-field-declarations fields)
+    (map (lambda (f) (string-append (string-append (first f) " " (second f)))) 
+         fields))
+  
+  ;; Number -> String
+  ;; make a separator line (+----+) of width
+  (define (make-separator-line width)
+    (string-append 
+     LFT+ 
+     (make-string (- width (string-length LFT+) (string-length RGT+)) #\-)
+     RGT+))
+  
+  ;; Number -> (String -> String)
+  ;; make one line in class of width from txt
+  (define (make-line width)
+    (lambda (txt)
+      (string-append 
+       LEFT 
+       txt
+       (make-string
+        (- width (string-length txt) (string-length LEFT) (string-length RIGHT))
+        #\space)
+       RIGHT)))
+  
+  ;; String (Cons String (Listof String)) -> Number
+  ;; compute width of class as the widest field/name 
+  (define (width-class name fields)
+    (+ (string-length LEFT)
+       ;; longest field spec of name/class and fields
+       (apply max (map string-length (cons name fields)))
+       (string-length RIGHT)))
+  
+  ;; ---------------------------------------------------------------------------
+  ;; Library
+  
+  ;; (Listof String) -> String
+  ;; turn the list of strings into a single string, separating lines with newline 
+  (define (strings->string-as-lines s)
+    (apply string-append (map (lambda (x) (string-append x "\n")) s)))
+  
+  
+  ;; (Listof (Listof String)) -> (Listof String)
+  ;; contract: (apply = (map length smatrix))
+  ;; this requires Pretty Big, it could be written in Intermediate 
+  (define (flatten-string-matrix smatrix) 
+    (apply map (lambda l (apply string-append l)) smatrix))
+  
+    
+  ;; String Number -> String
+  ;; place str in the center of an otherwise blank string
+  (define (centered str width)
+    (let* ([len-str (string-length str)]
+           [lft (quotient (- width len-str) 2)]
+           [rgt (- width len-str lft)])
+      (string-append (make-string lft #\space) str (make-string rgt #\space))))
+    
+  ;; ---------------------------------------------------------------------------
+  ;; Constants
+  
+  (define LEFT  "| ")
+  (define LFT+  "+-")
+  (define RIGHT " |")
+  (define RGT+  "-+") ; (= (string-length RIGHT) (string-length RGT+))
+  ; (define HOOK  " |-o") ; (= (string-length RIGHT) (string-length HOOK))
+  
+  
+  #|Tests: 
+  (require (lib "testing.scm" "testing"))
+
+  (test== (centered "|" 2) "| ")
+  (test== (centered "|" 3) " | ")
+
+  "testing classes"
+  (define class1 (list "Class" "Super" '(("int" "capacity") ("hello" "world"))))
+  (define class2 (list "Class" "Super" '()))
+  
+  (define expected-class
+    (list
+     "+--------------+"
+     "| Class        |"
+     "+--------------+"
+     "| int capacity |"
+     "| hello world  |"
+     "+--------------+"))
+  
+  (define expected-class2
+    (list
+     "+-------+"
+     "| Class |"
+     "+-------+"
+     "+-------+"))
+  
+  (test== (class-draw class1) (strings->string-as-lines expected-class))
+  (test== (class-draw class2) (strings->string-as-lines expected-class2))
+  
+  ; (printf "~a~n" (class-draw class1))
+  
+  "testing variants"
+  (define vclass1 (list "Variant1" '()))
+  (define vclass2 (list "Variant2" '(("int" "x") ("boolean" "y") ("Super" "z"))))
+  (define vclass3 (list "Variant3" '(("String" "x") ("Super" "y") ("Super" "z"))))
+  
+  (define expected-variant1
+    (list
+     "       |        "
+     "  +----------+  "
+     "  | Variant1 |  "
+     "  +----------+  "
+     "  +----------+  "
+     "                "
+     "                "
+     "                "
+     "                "
+     "                "))
+  
+  (define expected-variant2
+    (list
+     "        |        "
+     "  +-----------+  "
+     "  | Variant2  |  "
+     "  +-----------+  "
+     "  | int x     |  "
+     "  | boolean y |  "
+     "  | Super z   |-+"
+     "  +-----------+ |"
+     "                |"
+     "                +"))
+  
+  (define expected-variant3
+    (list
+     "       |        "
+     "  +----------+  "
+     "  | Variant3 |  "
+     "  +----------+  "
+     "  | String x |  "
+     "  | Super y  |-+"
+     "  | Super z  |-+"
+     "  +----------+ |"
+     "               |"
+     "---------------+"))
+  
+  (test== (let-values ([(s b) (variant-to-strings vclass1 "Super" #f 3)]) s)
+          expected-variant1)
+  (test== (variant-draw vclass1 "Super" #f 3) 
+          (strings->string-as-lines expected-variant1))
+  (test== (variant-draw vclass2 "Super" #f 3) 
+          (strings->string-as-lines expected-variant2))
+  (test== (variant-draw vclass3 "Super" #t 3) 
+          (strings->string-as-lines expected-variant3))
+  
+  
+  (test== (let-values
+              ([(s b) 
+                (variants*-to-strings (list vclass1 vclass2 vclass3) "Super")])
+            s)
+          (list expected-variant1 expected-variant2 expected-variant3))
+  
+  (test== (variants*-draw (list vclass1 vclass2 vclass3) "Super") 
+          (flatten-string-matrix
+           (list expected-variant1 expected-variant2 expected-variant3)))
+
+  (define aclass-exp ;; 19
+    (list "     +-------+     "
+          "     | Super |<----"
+          "     +-------+     "
+          "     +-------+     "))
+  
+  (test== (abstract-to-string "Super" '() 19 #t)
+          aclass-exp)
+  
+  (test== (dt-draw
+           (make-dt "Class"
+                    '()
+                    '()
+                    ""))
+          (strings->string-as-lines expected-class2))
+  
+  (test== (dt-draw 
+           (make-dt "Super" '() (list vclass1 vclass2 vclass3) ""))
+          (strings->string-as-lines
+           '(
+"                    +-------+                       "
+"                    | Super |<---------------------+"
+"                    +-------+                      |"
+"                    +-------+                      |"
+"                       / \\                         |" ;; note escape 
+"                       ---                         |"
+"                        |                          |"
+"       ----------------------------------          |"
+"       |                |               |          |"
+"  +----------+    +-----------+    +----------+    |"
+"  | Variant1 |    | Variant2  |    | Variant3 |    |"
+"  +----------+    +-----------+    +----------+    |"
+"  +----------+    | int x     |    | String x |    |"
+"                  | boolean y |    | Super y  |-+  |"
+"                  | Super z   |-+  | Super z  |-+  |"
+"                  +-----------+ |  +----------+ |  |"
+"                                |               |  |"
+"                                +---------------+--+"
+             )))
+  
+  (test== (dt-draw
+           (make-dt "Super" 
+                    '(("int" "x"))
+                    '(("VC1" (("int" "x")))
+                      ("VC2" (("boolean" "b") ("int" "y")))
+                      ("VC3" (("String" "s"))))
+                    ""))
+          (strings->string-as-lines
+          '(
+"                  +-------+                   "
+"                  | Super |                   "
+"                  +-------+                   "
+"                  | int x |                   "
+"                  +-------+                   "
+"                     / \\                      "
+"                     ---                      "
+"                      |                       "
+"      --------------------------------        "
+"      |              |               |        "
+"  +-------+    +-----------+    +----------+  "
+"  | VC1   |    | VC2       |    | VC3      |  "
+"  +-------+    +-----------+    +----------+  "
+"  | int x |    | boolean b |    | String s |  "
+"  +-------+    | int y     |    +----------+  "
+"               +-----------+                  "            
+"                                              "
+"                                              "
+            )))
+  
+  |#
+)
diff --git a/collects/profjWizard/draw-txt0.ss b/collects/profjWizard/draw-txt0.ss
new file mode 100644
index 0000000000..c75b2b1c58
--- /dev/null
+++ b/collects/profjWizard/draw-txt0.ss
@@ -0,0 +1,333 @@
+#| Class Representation: 
+   
+   Class = (list String (Listof Field))
+   Field = (list String String)
+
+|#
+(module draw-txt mzscheme
+  (require (lib "etc.ss")
+           (lib "list.ss"))
+  
+  ;; Class (Listof Classes) -> (Listof String)
+  (define (class-union-to-strings utype variants) 
+    (let* ([ac (class-to-strings utype)]
+           [classes (classes-to-strings variants (car utype))]
+           [v  (flatten-string-matrix classes)]
+           [Lv (string-length (first v))]
+           [the-core
+            (append 
+             (center-picture Lv ac)
+             (center-picture Lv REFINEMENT-ARROW)
+             (center-picture Lv (refinement-connectors classes))
+             v)]
+           [foo 0])
+      (map (lambda (x) 
+             (set! foo (+ foo 1))
+             (cond
+               [(> foo 2) (string-append x "|")]
+               [(= foo 1) x]
+               [(= foo 2) (replace-end-with-back-arrow x)]))
+           the-core)))
+  
+  ;; String -> String 
+  ;; add the containment arrow to an abstract class from the right fringe
+  (define (replace-end-with-back-arrow x0)
+    (list->string
+     (reverse!
+      (cons #\+ 
+            (let loop ([x (reverse (string->list x0))])
+              (cond
+                [(char=? (cadr x) #\|) (cons #\< (cdr x))]
+                [else (cons #\- (loop (cdr x)))]))))))
+  
+  ;; (Listof String) -> (Listof String)
+  (define (refinement-connectors class-pictures)
+    (let ([center-char 
+           (lambda (line c l r)
+             (car (center-picture (string-length line) (list c)  l r)))])
+      (list 
+       (string-append
+        (center-char (caar class-pictures) "+" #\space #\-)
+        (let loop ([cp (rest class-pictures)])
+          (cond
+            [(null? (rest cp))
+             (center-char (caar cp) "+" #\- #\space)]
+            [else (string-append (center-char (caar cp) "+" #\- #\-)
+                                 (loop (rest cp)))])))
+       (foldr (lambda (f r) 
+                (string-append (car (center-picture (string-length (car f)) (list "|"))) r))
+              ""
+              class-pictures)
+       )))
+  
+  ;; Number (Listof String) -> (Listof String)
+  (define center-picture 
+    (opt-lambda (Lv ac (l #\space)[r #\space])
+      (let* ([delta (- Lv (string-length (first ac)))]
+             [lft (quotient delta 2)])
+        (map (pad-lines (make-string lft l) (make-string (- delta lft) r)) ac))))
+  
+  (define REFINEMENT-ARROW
+    (list "/ \\"
+          "---"
+          " | "))
+  
+  ;; Class String *-> String
+  (define (classes-draw classes . super) 
+    (strings->string-as-lines (apply classes-to-strings classes super)))
+  
+  ;; Class -> String
+  (define (class-draw class) 
+    (strings->string-as-lines (class-to-strings class)))
+  
+  ;; (Listof Class) String *-> (Listof (Listof String))
+  ;; take a list of classes and produce a single "line" (listof string-lines)
+  (define (classes-to-strings classes0 . super)
+    (let* (;; (Listof (Listof String))
+           [classes (map (lambda (c) (apply class-to-strings c super)) classes0)] 
+           [L (apply max (map length classes))]
+           [FOO "   "]
+           [classes (foldr (lambda (class-los is-self-recursive rest)
+                             (if (null? super)
+                                 (map (pad-lines FOO FOO)
+                                    (if (>= (length class-los) L)
+                                        class-los
+                                        (pad-class-with-blank-lines L class-los)))
+                             (cons
+                              (append 
+                               (map (pad-lines FOO FOO)
+                                    (if (>= (length class-los) L)
+                                        class-los
+                                        (pad-class-with-blank-lines L class-los)))
+                               (list
+                                (case is-self-recursive
+                                  [(long)
+                                   (string-append 
+                                    "--"
+                                    (make-string (string-length (first class-los)) #\-)
+                                    CROSS
+                                    (if (null? rest) "--" ""))]
+                                  [(short)
+                                   (string-append 
+                                    "  "
+                                    (make-string (string-length (first class-los)) #\space)
+                                    CROSS
+                                    (if (null? rest) "--" ""))]
+                                  [(conn)
+                                   (string-append 
+                                    "--"
+                                    (make-string (string-length (first class-los)) #\-)
+                                    NOCROSS
+                                    (if (null? rest) "--" ""))
+                                   ]
+                                  [(none)
+                                   (string-append 
+                                    "  "
+                                    (make-string (string-length (first class-los)) #\space)
+                                    FOO)])))
+                              rest)))
+                           '() 
+                           classes
+                           (let loop ([c classes0][prior #f])
+                             (cond
+                               [(null? c) '()]
+                               [else (let ([self-recursive (apply is-recursive? (car c) super)])
+                                       (cond
+                                         [(and self-recursive prior) (cons 'long (loop (cdr c) #t))]
+                                         [self-recursive (cons 'short (loop (cdr c) #t))]
+                                         [prior (cons 'conn (loop (cdr c) #t))]
+                                         [else (cons 'none (loop (cdr c) #f))]))])))])
+      classes))
+  
+  
+  
+  (define is-recursive? 
+    (case-lambda 
+      [(class) #f]
+      [(class super)
+       (let* ([name    (first class)]
+              [fields  (second class)]
+              [types   (map first fields)])
+         (member super types))]))
+  
+  
+  (define CROSS "-+-")
+  (define NOCROSS "---")
+  
+  ;; Number (Cons String (Listof String)) -> (Listof String)
+  (define (pad-class-with-blank-lines n l)
+    (let ([blanks (make-string (string-length (first l)) #\space)])
+      (append l (build-list (- n (length l)) (lambda (i) blanks)))))
+  
+  ;; Class String *-> (Listof String)
+  ;; the presence of super suggests that we want to draw a line to super 
+  (define (class-to-strings class . super)
+    (let* ([is-super? (if (null? super)
+                          (lambda (x) false) 
+                          (lambda (x) (string=? (car super) x)))]
+           [name    (first class)]
+           [fields  (second class)]
+           [types   (map first fields)]
+           [names   (map second fields)]                  
+           [fields  (create-field-declarations fields)]                         
+           [width   (width-class name fields)] 
+           [separat (make-separator-line width)]
+           [separat-hasa (make-separator-line width #t)]
+           [start-hasa   #f])
+      (cond
+        [(and (cons? super) (ormap is-super? types))
+         `(,separat
+            ,((make-line width) name)
+            ,separat
+            ,@(map (lambda (line type)
+                     (cond
+                       [(is-super? type) (set! start-hasa #t) [(make-line width HOOK) line]]
+                       [start-hasa [(make-line width HASA) line]]
+                       [else ((make-line width) line)]))
+                   fields types)
+            ,separat-hasa)]
+        [else
+         `(,separat
+            ,((make-line width) name)
+            ,separat
+            ,@(map (make-line width) fields)
+            ,separat)])))
+  
+  ;; (Listof Field) -> (Listof String)
+  (define (create-field-declarations fields)
+    (map (lambda (f) (string-append (string-append (first f) " " (second f)))) 
+         fields))
+  
+  ;; String Boolean *-> String
+  (define (make-separator-line width . hasa)
+    (string-append LFT+ (make-string (- width (string-length LFT+) (string-length RGT+)) #\-) 
+                   (if (null? hasa) RGT+ HASA+)))
+  
+  ;; Number String -> String
+  ;; make one line in class of width from txt
+  (define (make-line width . rgt)
+    (lambda (txt)
+      (string-append 
+       LEFT 
+       txt
+       (make-string 
+        (- width (string-length txt) (string-length LEFT) (string-length RIGHT))
+        #\space)
+       (if (null? rgt) RIGHT (car rgt)))))
+  
+  (define LEFT  "  | ")
+  (define LFT+  "  +-")
+  (define RIGHT " |  ")
+  (define HOOK  " |-o") ; (= (string-length RIGHT) (string-length HOOK))
+  (define RGT+  "-+  ") ; (= (string-length RIGHT) (string-length RGT+))
+  (define HASA  " | |") ; (= (string-length RIGHT) (string-length HASA))
+  (define HASA+ "-+ |") ; (= (string-length RIGHT) (string-length RGT+))
+  
+  ;; String (Cons String (Listof String)) -> Number
+  ;; compute width of class as the widest field/name 
+  (define (width-class name fields)
+    (+ (string-length LEFT)
+       ;; longest field spec of name/class and fields
+       (apply max (map string-length (cons name fields)))
+       (string-length RIGHT)))
+  
+  ;; String String -> (String -> String)
+  ;; add lft and rgt to txt 
+  (define (pad-lines lft rgt) (lambda (txt) (string-append lft txt rgt)))
+  
+  ;; (Listof (Listof String)) -> (Listof String)
+  ;; contract: (apply = (map length smatrix))
+  ;; this requires Pretty Big, it could be written in Intermediate 
+  (define (flatten-string-matrix smatrix) 
+    (apply map (lambda l (apply string-append l)) smatrix))
+  
+  ;; (Listof String) -> String
+  ;; turn the list of strings into a single string, separating lines with newline 
+  (define (strings->string-as-lines s)
+    (apply string-append (map (lambda (x) (string-append x "\n")) s)))
+  
+  ;; Basic Tests: 
+  
+  
+  (equal? 
+   (flatten-string-matrix
+    (list (list "a1" "a2" "a3") (list "b1" "b2" "b3") (list "c1" "c2" "c3")))
+   (list "a1b1c1" "a2b2c2" "a3b3c3"))
+  
+  ;; Tests
+  
+  
+  (define aTrain (list"Train"'(("int" "capacity") ("hello" "world"))))
+  (define sTrain (list"Train"'(("int" "capacity"))))
+  
+  (test== (width-class (car aTrain) (create-field-declarations (cadr aTrain)))
+          (+ 12 (string-length LEFT) (string-length RIGHT)))
+  
+  (test== ([make-line (+ 12 (string-length LEFT) (string-length RIGHT))] "int capacity")
+          "  | int capacity |  ")
+  
+  (test== (make-separator-line (+ 12 (string-length LEFT) (string-length RIGHT)))
+          "  +--------------+  ")
+  
+  (define expected-class
+    (list
+     "  +--------------+  \n"
+     "  | Train        |  \n"
+     "  +--------------+  \n"
+     "  | int capacity |  \n"
+     "  | hello world  |  \n"
+     "  +--------------+  \n"))
+  
+  (test== (class-draw aTrain) 
+          (apply string-append expected-class))
+  
+  (test== (classes-to-strings (list sTrain aTrain))
+          '(("     +--------------+      "
+             "     | Train        |      "
+             "     +--------------+      "
+             "     | int capacity |      "
+             "     +--------------+      "
+             "                           ")
+            ("     +--------------+      "
+             "     | Train        |      "
+             "     +--------------+      "
+             "     | int capacity |      "
+             "     | hello world  |      "
+             "     +--------------+      ")))
+  
+  ;; Union: ARiver = Source(Location) | Confluence(Location, ARiver, ARiver)
+  (define ARiver
+    (list "ARiver" '()))
+  (define Source
+    (list "Source" '(("Location" "loc"))))
+  (define Confluence
+    (list "Confluence" '(("Location" "loc") ("ARiver" "left") ("ARiver" "right"))))
+  
+  (test== (strings->string-as-lines
+           (class-union-to-strings ARiver (list Source Confluence)))
+          (strings->string-as-lines
+          '("                    +--------+                      "
+            "                    | ARiver |<---------------------+"
+            "                    +--------+                      |"
+            "                    +--------+                      |"
+            "                       / \\                          |" ;; note escape 
+            "                       ---                          |"
+            "                        |                           |"
+            "           +--------------------------+             |"
+            "           |                          |             |"
+            "   +--------------+           +--------------+      |"
+            "   | Source       |           | Confluence   |      |"
+            "   +--------------+           +--------------+      |"
+            "   | Location loc |           | Location loc |      |"
+            "   +--------------+           | ARiver left  |-o    |"
+            "                              | ARiver right |-o    |"
+            "                              +--------------+ |    |"
+            "                                              -+----|")))
+  
+  (test== (replace-end-with-back-arrow "| ARiver |     ")
+          "| ARiver |<----+"
+          "replace end with back arrow")
+  
+  (printf "~a" (strings->string-as-lines (class-union-to-strings ARiver (list Source Confluence))))
+  
+  )
diff --git a/collects/profjWizard/info.ss b/collects/profjWizard/info.ss
new file mode 100644
index 0000000000..6b8ca7f8df
--- /dev/null
+++ b/collects/profjWizard/info.ss
@@ -0,0 +1,10 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "ProfessorJ Wizard")
+  (define tools (list (list "tool.ss")))
+  (define comment '(define compile-subcollections (list (list "profj" "parsers")
+                                       (list "profj" "libs" "java" "lang")
+				       (list "profj" "libs" "java" "io"))))
+  (define compile-omit-files
+    '("draw-txt0.ss" "macro-class.scm" "view0.scm" "data-defs0.scm"))
+
+  )
diff --git a/collects/profjWizard/macro-class.scm b/collects/profjWizard/macro-class.scm
new file mode 100644
index 0000000000..b145e31549
--- /dev/null
+++ b/collects/profjWizard/macro-class.scm
@@ -0,0 +1,46 @@
+#cs(module macro-class mzscheme
+     (require-for-syntax (file "class.scm") (file "aux-syntax.scm"))
+     
+     (provide 
+      class ;; (class Name Super (Type Name) ...)
+      union ;; (union Type [Class (Type Name) ...] ...)
+      )
+     
+     (define-syntax (class stx)
+       (syntax-case stx ()
+         [(class Name Super (FType FName) ...)
+          (printf
+           (make-class
+            (list (identifier->string (syntax Name))
+                  (identifier->string (syntax Super))
+                  (map (lambda (x) 
+                         (let* ([x (syntax-e x)]
+                                [type (identifier->string (car x))]
+                                [name (identifier->string (cadr x))])
+                           (list type name)))
+                       (syntax->list (syntax ((FType FName) ...)))))))
+          (syntax (void))]))
+     
+     (define-syntax (union stx)
+       (syntax-case stx (withToString withTemplate)
+         [(union Type [Class (FType FName) ...] ... withToString)
+          (syntax 10)]
+         [(union Type [Class (FType FName) ...] ...)
+          (printf
+           (make-union
+            (list (identifier->string (syntax Type))
+                  (map (lambda (x) 
+                         (let* ([x (syntax-e x)]
+                                [class (identifier->string (car x))]
+                                [fields (map (lambda (f)
+                                               (let* ([x (syntax->list f)]
+                                                      [type (identifier->string (car x))]
+                                                      [name (identifier->string (cadr x))])
+                                                 `(,type ,name)))
+                                             (cdr x))])
+                           (cons class fields)))
+                       (syntax->list (syntax ((Class (FType FName) ...) ...)))))))
+          (syntax (void))]))
+     
+     
+     )
diff --git a/collects/profjWizard/todo b/collects/profjWizard/todo
new file mode 100644
index 0000000000..09b87069ae
--- /dev/null
+++ b/collects/profjWizard/todo
@@ -0,0 +1,51 @@
+#|
+The Java Wizard helps programmers create 
+   * classes 
+   * datatypes via classes. 
+   
+The class wizard requests class name, superclass, and field specifications. 
+From these, it generates a class, its constructor, and optionally a partial 
+template for methods and a toString method. 
+
+The union wizard requests a union name and specifications for the variants. 
+From these, it generates an abstract class (for the union name) and one 
+variant class that extends the abstract class per variant specification. 
+Again, it optionally adds templates and toString methods. 
+
+The wizards are added to the Special menu and insert text at the current 
+point. 
+
+At the moment they cannot read back code and help with natural program 
+edits and transformations. 
+
+The two major files are: 
+ wizard.ss, which is the view and provides the user interaction
+ class.scm, which is the model and provides the functions for turning 
+  a spec into a string that represents a class or a union. 
+
+At the moment, class.scm does not use the Java implementation to perform
+basic checks on the information. It just leaves this to the programmer. 
+So, for example, if a programmer says a field has type "moo" and "moo" 
+doesn't exist as a class, then the wizard inserts a buggy program. 
+
+|#
+
+bugs: 
+
+drawing: 
+
+* finish drawing unions, recursion
+
+model 
+
+* figure out how to add toString and template flags to the macro version 
+
+view
+
+both
+
+* allow common fields in abstract classes
+* parameterize over language level? 
+* privacy modifiers
+
+
diff --git a/collects/profjWizard/tool.ss b/collects/profjWizard/tool.ss
new file mode 100644
index 0000000000..dc2ae4935c
--- /dev/null
+++ b/collects/profjWizard/tool.ss
@@ -0,0 +1,69 @@
+#cs
+(module tool mzscheme
+  (require (lib "tool.ss" "drscheme")
+           (lib "mred.ss" "mred")
+           (lib "unitsig.ss") 
+           (lib "etc.ss")
+           (lib "class.ss")
+	   (lib "string-constant.ss" "string-constants")
+           
+           (file "class.scm")
+           (file "view.scm")
+           (file "draw-txt.ss"))
+
+  (provide tool@)
+  
+  ;; Strings
+  (define insert-java-class "Insert Java Class")
+  (define insert-java-union "Insert Java Union")
+  
+  
+  (define tool@
+    (unit/sig drscheme:tool-exports^
+      (import drscheme:tool^)
+
+      (define (phase1) (void))
+      (define (phase2) (void))
+
+      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;
+      ;;  Wire up to DrScheme
+      ;;
+
+      ;; insert a Java Class
+
+      (define (java-class-wizard-mixin %)
+        (class %
+          (inherit get-special-menu get-edit-target-object)
+          
+          (super-new)
+          
+          ;; String (-> X) (X -> String) -> Void
+          (define (make-menu-item% insert-what get-class-info make-what draw-what)
+            (new menu-item%
+                 (label insert-what) (parent (get-special-menu))
+                 (callback 
+                  (lambda (menu event)
+                    (let*-values
+                        ([(editor) (get-edit-target-object)]
+			 [(b class-as-info) (get-class-info)]
+                         [(class-as-strn) (if (boolean? class-as-info) 
+                                              "" 
+                                              (apply make-what class-as-info))]
+                         [(class-as-dia) (if (and class-as-info b)
+                                             (format 
+                                              "/*~n~a~n*/~n~n"
+                                              (draw-what (car class-as-info)))
+                                             "")])
+			(send editor insert class-as-dia)
+			(send editor insert class-as-strn))))))
+
+          (make-menu-item% insert-java-class get-class-info make-class class-draw)
+          (make-menu-item% insert-java-union get-union-info make-union dt-draw)
+	  ))
+      
+      (drscheme:get/extend:extend-unit-frame java-class-wizard-mixin)
+      
+      ))
+  
+  )
diff --git a/collects/profjWizard/view.scm b/collects/profjWizard/view.scm
new file mode 100644
index 0000000000..8bbcdc10da
--- /dev/null
+++ b/collects/profjWizard/view.scm
@@ -0,0 +1,516 @@
+#cs
+(module view mzscheme 
+  
+  (require (lib "mred.ss" "mred")
+           (lib "class.ss")
+           (lib "etc.ss")
+           (lib "list.ss")
+           (lib "string.ss" "srfi" "13")
+           (lib "contract.ss"))
+  
+  (require (file "assoc-list.scm")
+           (file "data-defs.scm")
+           (file "aux-class.scm"))
+  
+  (provide/contract
+   [get-class-info (->* []
+                        [boolean? (union false/c (list/c Class boolean? boolean?))])]
+   [get-union-info (->* []
+		        [boolean? (union false/c (list/c Union boolean? boolean?))])])
+  
+  (define CLASS-WIZARD "The Class Wizard")
+  (define UNION-WIZARD "The Union Wizard")
+  (define VARIANT-WIZD "The Variant Wizard")
+  (define VARIANT      "Variant") 
+  (define INSERT-CLASS "Insert Class")
+  (define INSERT-UNION "Insert Union")
+  (define INSERT-VARNT "Insert Variant")
+  (define ADD-FIELD    "Add Field")
+  (define ADD-VARIANT  "Add Variant")
+  (define ADD-TOSTRING "add toString()")
+  (define ADD-TEMPLATE "add method template")
+  (define ADD-DIAGRAM  "add class diagram")
+  (define PURPOSE-CLASS "// purpose of class: ")
+  (define PURPOSE-UNION  "// purpose of union: ")
+  (define CLASS        "class")
+  (define SUPER        "super")
+  (define EXTENDS      "extends")
+  (define CHECK-NAME-F "check name of ~a")
+  (define CHECK-TYPE-F "check type for ~a")
+  (define CHECK-FIELD-NAME-F "check field name for ~a")
+  (define TYPE "type") 
+  (define NAME "name")
+  (define ABORT "Abort")
+  (define ERROR: "Error: ")
+  (define DELETE "Delete")
+  (define EDIT         "edit")
+  
+  
+  #|
+     present a dialog to create a single class; 
+     if programmer aborts, return #f
+     otherwise, produce a class and two booleans, requesting toString and draft 
+     templates, respectively
+     |#
+  
+  (define (get-class-info)
+    (let ([ci (new class-info% (title CLASS-WIZARD)
+                   (insert-str INSERT-CLASS) (add-str ADD-FIELD))])
+      (send ci call)))
+  
+  (define (get-union-info)
+    (let ([ui (new union-info% (title UNION-WIZARD)
+                   (insert-str INSERT-UNION) (add-str ADD-VARIANT))])
+      (send ui call)))
+  
+  #|
+            *---------------------*
+            | dialog%             |
+            *---------------------*
+               |
+               |
+              / \
+            *---------------------*
+            | class-union-wizard% |
+            *---------------------*
+            | tostring?           |
+            | template?           |
+            | error-message       |
+            | an-error?           |
+            | call                |
+            | A: produce          |
+            | A: make-class-cb    |
+            | A: add-field-cb     |
+            *---------------------*
+              |
+              |
+             / \
+        --------------------------------------------
+        |                                          |
+    *---------------------*                    *---------------------*
+    | class-info%         |                    | union-info%         |
+    *---------------------*                    *---------------------*
+    | field-panel         |--+                 | vart-panel          |--+
+    *---------------------*  |                 *---------------------*  |
+                             |                                          |          
+                             |                                          |          
+                             |                                          |          
+                             |                                          |          
+    *---------------------*  |                 *---------------------*  | 
+    | vertical-panel%     |  |                 | horizontal-panel%   |  |          
+    *---------------------*  |                 *---------------------*  |          
+                      |      |                                   |      |          
+                      |      |                                   |      |          
+                     / \     |                                  / \     |          
+                 *---------------------*                  *---------------------*
+                 | field-panel%        |                  | variant-panel%      |
+                 *---------------------*                  *---------------------*
+                 | add                 |                  | add                 |
+                 | add-on-return       |                  | produce             |
+                 | produce             |                  *---------------------*
+                 *---------------------*                  | acquired:           |
+                 | acquired:           |                  |  get-type           |
+                 |  window (?)         |                  |  error-message      |
+                 |  error-message      |                  |  an-error?          |
+                 *---------------------*                  *---------------------* 
+
+    |#
+  
+  ;; ------------------------------------------------------------------------
+  ;; Set up the frame, including the info-panel where subclasses can 
+  ;; request specific information. The frame includes buttons for aborting
+  ;; the edit process, for packaging up the information in the edit, and for 
+  ;; adding some component (field, variant)
+  
+  ;; String String String -> ClassUnionWizard
+  (define class-union-wizard%
+    (class dialog% (init-field title insert-str add-str (switches? #t))
+      (super-new (label title) (width 500) (height 300)) 
+      
+      (define p (new vertical-pane% (parent this)))
+      
+      (define button-panel (add-horizontal-panel p))
+      
+      (define abort? #t) ;; assume bad things happen
+      (define (quit x e) (send this show #f))
+      (add-button button-panel ABORT quit)
+
+      (define/abstract make-class-cb)
+      (add-button button-panel insert-str 
+                  (lambda (x e) (set! abort? #f) (make-class-cb x e)))
+      
+      (define/abstract add-field-cb)
+      (add-button button-panel add-str (lambda (x e) (add-field-cb x e)))
+      
+      ;; switches for toString methods and template in comments 
+      (define-values (string template diagram)
+        (if switches? 
+            (let ([switch-pane (add-horizontal-panel p)])
+              (values (make-checkbox switch-pane ADD-TOSTRING) 
+                      (make-checkbox switch-pane ADD-TEMPLATE)
+                      (make-checkbox switch-pane ADD-DIAGRAM)))
+            (values #f #f #f)))
+      (define (get-switch x) (and switches? (send x get-value)))
+      (define/public (tostring?) (get-switch string))
+      (define/public (template?) (get-switch template))
+      (define/public (diagram?) (get-switch diagram))
+      
+      ;; --------------------------------------------------------------------
+      ;; info panel
+      (field (info-pane (new vertical-panel% (parent p) (style '(border)))))
+      
+      ;; --------------------------------------------------------------------
+      ;; error panel         
+      
+      (define message-size 100)
+      (define an-error (cons 1 2))
+      (define message
+        (new message% (parent (add-horizontal-panel p)) 
+             (label (make-string message-size #\space))))
+      
+      ;; String -> false
+      (define/public (error-message m)
+        (send message set-label (string-append ERROR: m)) 
+        (raise an-error))
+      ;; Any -> Boolean 
+      (define/public (an-error? x) (eq? an-error x ))
+      
+      ;; TextField (union false String) -> java-id?
+      (define/public (produce-name-from-text name msg)
+        (let ([x (string-trim-both (send name get-value))])
+          (cond
+            [(not msg) x]
+            [(java-id? x) x]
+            [else (error-message (format CHECK-NAME-F msg))])))
+      
+      ;; --------------------------------------------------------------------
+      ;; call in 
+      (define/public (call) 
+        (send this show #t)
+        (values (diagram?) (if abort? #f (produce))))
+      
+      (define/abstract produce)))
+  
+  ;; ------------------------------------------------------------------------
+  ;; String String String [String] [String] -> ClassUnionWizard
+  ;; get information about a class (fields, purpose statement, ...)
+  (define class-info%
+    (class class-union-wizard%
+      (init-field (a-super null) (a-v-class null))
+      (super-new)
+      (inherit-field info-pane)
+      (inherit 
+        tostring? template? diagram? 
+        error-message an-error? produce-name-from-text)
+      
+      ;; --------------------------------------------------------------------
+      ;; filling the info-pane 
+      
+      ;; Information about the class in general: 
+      (define purpose 
+        ;; it is not the kind of textbox that make-text-field creates
+        (new text-field%
+             (parent info-pane) (label PURPOSE-CLASS) (callback void)))
+      
+      (define class-pane (add-horizontal-panel info-pane))
+      ; (define class-privacy (make-modifier-menu class-pane))
+      (define class-name (make-text-field class-pane CLASS))
+      (define (super-cb x e) (send field-panel add-on-return x e))
+      (define super-name (make-text-field class-pane EXTENDS super-cb))
+      
+      ;; Information about the class's fields:
+      (define field-panel
+        (new field-panel%
+             (parent info-pane) (window this) 
+             (error-message (lambda (x) (error-message x)))))
+      
+      (define/override (add-field-cb x e) (send field-panel add))
+      
+      ;; --------------------------------------------------------------------
+      ;; creating the class from the specification 
+      
+      ;; -> (union false (list Class boolean? boolean?))
+      (define/override (produce)           
+        (with-handlers ([(lambda (x) (an-error? x)) (lambda _ #f)]) 
+           (list (list (produce-name-from-text class-name CLASS)
+                       (produce-name-from-text
+                        super-name (if (null? a-super) #f SUPER))
+                       (send field-panel produce)
+                       (send purpose get-value))
+                 (tostring?) 
+                 (template?))))
+      
+      ;; if the class specification is proper, hide dialog
+      (define/override (make-class-cb x e) 
+        (when (produce) (send this show #f)))
+      
+      ;; --------------------------------------------------------------------
+      ;; setting it all up
+      
+      ;; String -> Void
+      ;; set up the super class, uneditable 
+      (define (setup-super a-super)
+        (send super-name set-value a-super)
+        (send (send super-name get-editor) lock #t))
+      
+      ;; init depending on inputs ... 
+      (cond
+        [(and (null? a-super) (null? a-v-class))
+         (send field-panel add)]
+        [(null? a-v-class)
+         (send field-panel add)
+         (setup-super a-super)]
+        [(null? a-super)
+         (error 'internal "can't happen: no super, but class provided")]
+        [else ; 
+         (setup-super a-super)
+         (let ([name (car a-v-class)]
+               [the-fields (cadr a-v-class)])
+           (send class-name set-value name)
+           (for-each (lambda (f) (send field-panel add f)) the-fields)
+           (send purpose set-value (variant-purpose a-v-class)))])
+      
+      ))
+  
+  ;; Panel Window (String -> Void) -> FieldPanel 
+  ;; manage text fields to add fields to the class in a stack like fashion;
+  ;; add one on <return>, allow users to delete one
+  ;; produce the field specs on demand 
+  (define field-panel%
+    (class vertical-panel% 
+      (init-field window error-message)
+      (super-new)
+      
+      ;; (Listof TextField)
+      ;; the list of name TextFields that have been added via (add)
+      ;; a stack in that the bottom field is always at beginning of list
+      ;; if empty, there are no fields
+      (define the-last-field-name '())
+      
+      ;; TextField -> Void
+      ;; push f on the-last-field-name
+      (define (add-field-name f) 
+        (set! the-last-field-name (cons f the-last-field-name)))
+      
+      ;; TextField -> Void
+      ;; remove from "stack"
+      (define (remove-field-name f)
+        (set! the-last-field-name (remove f the-last-field-name)))
+      
+      ;; TextField Event -> Void
+      ;; a callback that on return creates a new "add field" panel when 
+      ;; it's the bottom most text field
+      (define/public (add-on-return x e)
+        (when (eq? (send e get-event-type) 'text-field-enter)
+          (when (or (null? the-last-field-name)
+                    (eq? (car the-last-field-name) x))
+            (add))
+          (send window on-traverse-char (new key-event% (key-code #\tab)))))
+      
+      ;; -> TextField TextField
+      ;; (list String String) -> TextField TextField
+      ;; add a field panel so that a new field for the class can be specified
+      ;; if one argument, it consists of two strings: 
+      ;; one for the type, one for name
+      (define/public add
+        (case-lambda
+          [() 
+           (let* ([fp (add-horizontal-panel this)]
+                  ; [modi (make-modifier-menu fp)]
+                  [type (make-text-field fp TYPE)]
+                  [name (make-text-field
+                         fp NAME (lambda (x e) (add-on-return x e)))]
+                  [get-values 
+                   (lambda () ; (send modi get-string-selection)
+                     (list (send type get-value) (send name get-value)))])
+             (add-field-name name)
+             (send fields add type get-values)
+             (make-delete-button this fp (lambda () 
+                                           (send fields remove type)
+                                           (remove-field-name name)))
+             (values type name))]
+          [(a-field)
+           (let-values ([(type name) (add)])
+             (send type set-value (car a-field))
+             (send name set-value (cadr a-field)))]))
+      
+      ;; --------------------------------------------------------------------
+      ;; managing the fields of the class 
+      
+      (define fields (new assoc%))
+      
+      (define/public (produce)
+        (foldr ;; r gives me the right order
+         (lambda (v r)
+           (let* ([type (string-trim-both (car v))]
+                  [name (string-trim-both (cadr v))])
+             (cond
+               [(and (java-id? type) (java-id? name))
+                (cons (list type name) r)]
+               [(java-id? type) 
+                (error-message (format CHECK-FIELD-NAME-F type))]
+               [(java-id? name)
+                (error-message (format CHECK-TYPE-F name))]
+               [else r])))
+         '()
+         (map (lambda (th) (th)) (send fields list))))))
+  
+  
+  ;; ------------------------------------------------------------------------
+  ;; -> UnionInfo
+  ;; get information about a datatype union 
+  (define union-info%
+    (class class-union-wizard%
+      (super-new)
+      (inherit-field info-pane)
+      (inherit
+        tostring? template? error-message an-error? produce-name-from-text)
+      
+      ;; --------------------------------------------------------------------
+      ;; filling in the info-pane 
+      
+      (define type-pane 
+        (new vertical-panel% (parent info-pane) 
+             (alignment '(center center)) (style '(border))
+             (min-height 50) (stretchable-height #f)))
+      
+      (define purpose 
+        (new text-field% 
+             (parent type-pane) (label PURPOSE-UNION) (callback void)))
+      (define type-text (make-text-field type-pane TYPE))
+      ;; -> String
+      (define (get-type) (produce-name-from-text type-text TYPE))
+      
+      (define vart-panel 
+        (new variant-panel%
+             (parent info-pane)
+             (get-type (lambda () (get-type)))
+             (error-message (lambda (x) (error-message x)))
+             (an-error? (lambda (x) (an-error? x)))))
+      
+      ;; Information about the union's common fields:
+      (add-button info-pane "Add Common Field"
+                  (lambda (x e) (send field-panel add)))
+      (define field-panel
+        (new field-panel%
+             (parent info-pane) (window this) 
+             (error-message (lambda (x) (error-message x)))))
+      (send field-panel add)
+      
+      ;; -> Union 
+      (define/override (produce)
+        (with-handlers ([(lambda (x) (an-error? x)) (lambda _ #f)])
+          (list 
+           (make-dt (get-type)
+                    (send field-panel produce)
+                    (send vart-panel produce)
+                    (send purpose get-value))
+           (tostring?)
+           (template?))))
+      
+      (define/override (make-class-cb x e)
+        (when (produce) (send this show #f)))
+      
+      (define/override (add-field-cb x e)
+        (send vart-panel add))
+      
+      ;; make two variants to boot
+      ;; allow people to add and delete a variant 
+      (send vart-panel add)
+      (send vart-panel add)))
+  
+  ;; (-> String) (String -> Void) (Any -> Boolean) -> VariantPanel
+  ;; manage the variant panels and their content for union
+  (define variant-panel%
+    (class horizontal-panel% 
+      (super-new (alignment '(center center)) (style '(border))
+                 (min-height 150) (stretchable-height #f))
+      (init get-type error-message an-error?)
+      
+      ;; -> Void
+      (define/public (add)
+        (let* ([vp (new vertical-panel% (parent this)(style '(border)))]
+               [ms (new message% (parent vp) (label VARIANT))] 
+               [bt (new button% (parent vp) (label EDIT)   
+                        (callback (create-variant ms)))])
+          (send variants add bt #f)
+          (make-delete-button this vp (lambda () (send variants remove bt)))))
+      
+      ;; Message -> (Button Event -> Void)
+      (define (create-variant ms)
+        (lambda (bt evt)
+          (with-handlers ([an-error? void])
+            (let*-values
+                ([(type) (get-type)] ;; may raise an error message
+                 [(class-in) (send variants lookup bt)]
+                 [(b a-class) (send (new class-info% 
+                                         (title VARIANT-WIZD)
+                                         (insert-str INSERT-VARNT)
+                                         (switches? #f)
+                                         (add-str ADD-FIELD)
+                                         (a-super type)
+                                         (a-v-class (if class-in class-in '())))
+                                    call)])
+              (when a-class
+                (let* ([a-class (car a-class)]
+                       [name    (car a-class)])
+                  ;; no supertype needed: ;; remove (cadr a-class)
+                  ;; comments, if any, are in:  (cadddr a-class)
+                  (send variants update bt 
+                        (list name (caddr a-class) (class-purpose a-class)))
+                  (send ms set-label name)))))))
+      
+      ;; --------------------------------------------------------------------
+      ;; Managing the datatype: (list name fields [comment])
+      (define variants (new assoc%))
+      
+      (define/public (produce)
+        (foldr (lambda (f r) (if f (cons f r) r)) '()
+               (send variants list)))))
+  
+  ;; ------------------------------------------------------------------------
+  ;; Pane -> HorizontalPanel
+  ;; add a fixed-width horizontal panel (50) to p
+  (define (add-horizontal-panel p)
+    (new horizontal-panel% (parent p) (min-height 50) (stretchable-height #f)))
+  
+  ;; String CallBack -> Button
+  (define (add-button bp l cb) ;; to button-panel
+    (new button% (label l) (parent bp) (callback cb)))
+  
+  ;; Panel String -> CheckBox
+  (define (make-checkbox p l)
+    (new check-box% (parent p) (label l) (callback void)))
+  
+  ;; Panel String [Callback] -> TextField
+  (define make-text-field 
+    (opt-lambda (p l (c void))
+      (new text-field% 
+           (parent p) (label l) (callback c)
+           (min-width 50) (stretchable-width #f))))
+  
+  ;; Panel (-> Void) -> Button
+  ;; create a button that deletes the button's immediate container from this
+  (define (make-delete-button this vp delete-from-model)
+    (new button% (parent vp) (label DELETE)
+         (callback (lambda (x e)
+                     (delete-from-model)
+                     (send this change-children 
+                           (lambda (cs)
+                             (filter (lambda (c) (not (eq? vp c))) cs)))))))
+  
+  ;; ------------------------------------------------------------------------
+  #| Run, program, run:  
+ 
+  (require (file "class.scm") (file "draw-txt.ss"))
+  
+  (define-values (b x) (get-class-info))
+  (if (and x b) (printf "/*~n~a~n*/~n" (class-draw (car x))))
+  (if x (printf "~a~n" (apply make-class x)))
+  
+  (define-values (c y) (get-union-info))
+  (if (and y c) (printf "/*~n~a~n*/~n" (dt-draw (car y))))
+  (if y (printf "~a~n" (apply make-union y)))
+
+ |#  
+  )
diff --git a/collects/profjWizard/view0.scm b/collects/profjWizard/view0.scm
new file mode 100644
index 0000000000..381fe16484
--- /dev/null
+++ b/collects/profjWizard/view0.scm
@@ -0,0 +1,402 @@
+#cs(module wizard mzscheme
+     (require (lib "mred.ss" "mred")
+              (lib "class.ss")
+              (lib "etc.ss")
+              (lib "list.ss")
+              (lib "string.ss" "srfi" "13")
+              (lib "contract.ss"))
+     
+     (require (file "assoc-list.scm")
+              (file "data-defs.scm"))
+     
+     (require-for-syntax (file "aux-syntax.scm"))
+     
+     (provide/contract
+      [get-class-info
+       (() (string? Class) . opt-> . (union false? (list/p Class boolean? boolean?)))]
+      [get-union-info
+       (-> (union false? (list/p Union boolean? boolean?)))] 
+      )
+     
+     ;; (define/abstract <identifier>) :: <definition> 
+     ;; introduce x as an abstract call back that raises an error 
+     ;; and set-x as a setter that defines the function finally 
+     ;; (mimic overriding)
+     (define-syntax (define/abstract e)
+       (syntax-case e ()
+         [(_ x)
+          (with-syntax ([set-x (prefix-id-suffix "set-" (syntax x) "")])
+            (syntax 
+             (define-values (x set-x)
+               (let ([real-x (lambda y (error 'x "not initialized yet"))])
+                 (values
+                  (lambda y (apply real-x y))
+                  (lambda (v) (set! real-x v)))))))]))
+     
+     #|
+     present a dialog to create a single class; 
+     if programmer aborts, return #f
+     otherwise, produce a class and two booleans, requesting toString and draft 
+     templates, respectively
+     |#
+     (define get-class-info
+       (opt-lambda ([a-super null][a-v-class null])
+         
+         ;; -----------------------------------------------------------------------
+         ;; Managing the class
+         
+         ;; (union false (list Class Boolean Boolean))
+         ;; should the dialog return a class representation at the end 
+         (define the-class #f)
+         
+         (define fields (new assoc%))
+         
+         ;; (Listof (-> (list String String)) ->  (list Class Boolean Boolean)
+         ;; produce a class from fields
+         (define (produce-class-from-fields fields)
+           (with-handlers ([spec-error? (lambda _ #f)]) 
+             (let* ([class (string-trim-both (send class-name get-value))]
+                    [super (string-trim-both (send super-name get-value))]
+                    [field (map (lambda (th) (th)) (send fields list))]
+                    [field 
+                     (foldr ;; r gives me the right order
+                      (lambda (x r)
+                        (let* ([v x] ; the privacy information isn't collecte
+                               ; [v (cdr x)]  ; cdr means skip privacy attribute
+                               [type (string-trim-both (car v))]
+                               [name (string-trim-both (cadr v))])
+                          (cond
+                            [(and (java-id? type) (java-id? name))
+                             (cons (list type name) r)]
+                            [(java-id? type)
+                             (error-message (format "check field name for ~a" type))]
+                            [(java-id? name)
+                             (error-message (format "check type for ~a" name))]
+                            [else r])))
+                      '()
+                      field)])
+               (if (java-id? class)
+                   (list (list class super field)
+                         (send tostring? get-value)
+                         (send template? get-value))
+                   (error-message "check class name")))))
+         
+         ;; -----------------------------------------------------------------------
+         ;; the layout 
+         
+         (define-values (f p tostring? template? set-make-class set-add-field)
+           (make-top "Class Wizard" "Insert Class" "Add Field"
+                     (lambda (x e) (set! the-class #f) (send f show #f))))
+         
+         ;; -----------------------------------------------------------------------
+         ;; information about the class
+         
+         (define privacy-modifiers '("no modifier" "public" "private" "protected"))
+         
+         ;; Panel -> Choice
+         (define (make-modifier-menu p)
+           (new choice% 
+                (label "") (choices privacy-modifiers) (parent p) (callback void)))
+         
+         
+         ;; TextField Event -> Void
+         ;; a callback that on return creates a new "add field" panel when 
+         ;; it's the bottom most text field 
+         (define/abstract send/create-field)
+         
+         ;; Information about the class in general: 
+         (define info-pane (new vertical-panel% (parent p) (style '(border))))
+         (define purpose 
+           (new text-field% 
+                (parent info-pane) (label "// purpose of class: ") (callback void)))
+         (define class-pane (add-horizontal-panel info-pane))
+         ; (define class-privacy (make-modifier-menu class-pane))
+         (define class-name (make-text-field class-pane "class"))
+         (define super-name (make-text-field class-pane "extends" send/create-field))
+         
+         ;; Information about the class's fields:
+         (define field-panel (new vertical-panel% (parent info-pane)))
+         
+         ;; (list Modifier String String) *-> Void
+         ;; add a field panel so that a new field for the class can be specified
+         ;; if rest arguments, it consists of two strings: 
+         ;; one for the type, one for name
+         (define (add-field-panel . a-field)
+           (let* ([fp (add-horizontal-panel field-panel)]
+                  ; [modi (make-modifier-menu fp)]
+                  [type (make-text-field fp "type:")]
+                  [name (make-text-field fp "name:" send/create-field)]
+                  [get-values (lambda ()
+                                (list ;(send modi get-string-selection)
+                                 (send type get-value)
+                                 (send name get-value)))])
+             (when (pair? a-field)
+               (send type set-value (car a-field))
+               (send name set-value (cadr a-field)))
+             (add-field-name name)
+             (send fields add type get-values)
+             (new button% 
+                  (label "Delete Field") (parent fp)
+                  (callback
+                   (lambda (x e)
+                     (send fields remove type)
+                     (remove-field-name name)
+                     (send field-panel change-children (remove-panel fp)))))))
+         
+         ;; Managing the creation of new "add field" panels
+         
+         ;; (Listof TextField)
+         ;; the list of name TextFields that have been added via (add-field-panel)
+         ;; a stack in that the bottom field is always at beginning of list
+         ;; if empty, there are no fields
+         (define the-last-field-name '())
+         
+         ;; TextField -> Boolean
+         ;; what is the current last 
+         (define (should-create-new-add-field? x) 
+           (or (null? the-last-field-name) (eq? (car the-last-field-name) x)))
+         
+         ;; TextField -> Void
+         ;; push f on the-last-field-name
+         (define (add-field-name f) 
+           (set! the-last-field-name (cons f the-last-field-name)))
+         
+         ;; TextField -> Void
+         ;; remove from "stack"
+         (define (remove-field-name f)
+           (set! the-last-field-name (remove f the-last-field-name)))
+         
+         (define _stupid_effect
+           (set-send/create-field
+            (lambda (x e)
+              (when (eq? (send e get-event-type) 'text-field-enter)
+                (when (should-create-new-add-field? x) (add-field-panel))
+                (send f on-traverse-char (new key-event% (key-code #\tab)))))))
+         
+         ;; -----------------------------------------------------------------------
+         
+         (define-values (error-message spec-error?) (add-error-panel p))
+         
+         ;; -----------------------------------------------------------------------
+         ;; setting it all up
+         
+         ;; String -> Void
+         ;; set up the super class, uneditable 
+         (define (setup-super a-super)
+           (send super-name set-value a-super)
+           (send (send super-name get-editor) lock #t))
+         
+         (cond
+           [(and (null? a-super) (null? a-v-class))
+            (add-field-panel)]
+           [(null? a-v-class)
+            (add-field-panel)
+            (setup-super a-super)]
+           [(null? a-super)
+            (error 'internal "can't happen: no super, but class provided")]
+           [else ; 
+            (setup-super a-super)
+            (let ([name (car a-v-class)]
+                  [fields (cdr a-v-class)])
+              (send class-name set-value name)
+              (for-each (lambda (f) (apply add-field-panel f)) fields))])
+         
+         (set-add-field (lambda (x e) (add-field-panel)))
+         
+         (set-make-class
+          (lambda (x e)
+            (set! the-class (produce-class-from-fields fields))
+            (when the-class (send f show #f))))
+         
+         (send f show #t)
+         
+         the-class
+         ))
+     
+     
+     #| -> (union #f (list Class Boolean Boolean)
+     present a modal dialog to create a union; 
+     if programmer aborts, return #f
+     otherwise, produce a datatype and two booleans, requesting toString and draft 
+     templates, respectively, for the entire datatype
+  |#
+     (define (get-union-info)
+       
+       ;; -------------------------------------------------------------------------
+       ;; Managing the datatype
+       (define the-type #f)
+       
+       (define variants (new assoc%))
+       
+       ;; -------------------------------------------------------------------------
+       ;; GUI Layout
+       
+       (define-values (f p toString? template? set-make-union set-add-var)
+         (make-top "Union Wizard" "Insert Union" "Add Variant" 
+                   (lambda (x e) (set! the-type #f) (send f show #f))))
+       
+       (define type-pane 
+         (new vertical-panel% 
+              (parent p) 
+              (alignment '(center center)) (style '(border))
+              (min-height 50) (stretchable-height #f)))
+       
+       (define purpose 
+         (new text-field% 
+              (parent type-pane) (label "// purpose of union: ") (callback void)))
+       
+       (define type-text (make-text-field type-pane "Type"))
+       
+       (define vart-pane 
+         (new horizontal-panel% 
+              (parent p) (alignment '(center center)) (style '(border))
+              (min-height 150) (stretchable-height #f)))
+       
+       (define-values (error-message spec-error?) (add-error-panel p))
+       
+       ;; -------------------------------------------------------------------------
+       ;; Accessing and Mutating GUIs
+       
+       ;; -> String
+       (define (get-type)
+         (let ([t (string-trim-both (send type-text get-value))])
+           (if (java-id? t) t (error-message "check type name"))))
+       
+       ;; -> Void
+       (define add-variant-panel
+         (make-add-variant-panel vart-pane spec-error? variants get-type))
+       
+       ;; make two variants to boot
+       ;; allow people to add and delete a variant 
+       (add-variant-panel)
+       (add-variant-panel)
+       
+       (set-make-union
+        (lambda (x e)
+          (set! the-type
+                (with-handlers ([spec-error? (lambda _ #f)])
+                  (list 
+                   (list (get-type)
+                         (foldr (lambda (f r) (if f (cons f r) r)) '()
+                                (send variants list)))
+                   (send toString? get-value)
+                   (send template? get-value))))
+          (send f show #f)))
+       
+       (set-add-var (lambda (x e) (add-variant-panel)))
+       
+       (send f show #t)
+       
+       the-type 
+       )
+     
+     
+     ;; Pane (Any -> Boolean) Assoc -> (-> Void)
+     ;; create a function that adds "variant" panels to the get-union-info dialog
+     (define (make-add-variant-panel vart-pane spec-error? variants get-type)
+       (lambda ()
+         (let* ([vp (new vertical-panel% (parent vart-pane)(style '(border)))]
+                [ms (new message% (parent vp) (label "Variant"))]
+                [bt (new button% (parent vp) (label "Edit")   
+                         (callback 
+                          (lambda (bt evt)
+                            (with-handlers ([spec-error? void])
+                              (let* ([type (get-type)]
+                                     [class-in (send variants lookup bt)]
+                                     [a-class (if class-in 
+                                                  (get-class-info type class-in)
+                                                  (get-class-info type))])
+                                (when a-class
+                                  (let* ([a-class (car a-class)]
+                                         [name (car a-class)]
+                                         [fields (caddr a-class)])
+                                    ;; no supertype needed: remove (cadr a-class)
+                                    (send variants update bt (list name fields))
+                                    (send ms set-label name))))))))])
+           (send variants add bt #f)
+           (new button% (parent vp) (label "Delete")
+                (callback 
+                 (lambda (x e)
+                   (send variants remove bt)
+                   (send vart-pane change-children (remove-panel vp))))))))
+     
+     ;; ---------------------------------------------------------------------------
+     
+     ;; String String String CallBack
+     ;; -> 
+     ;; Frame Pane CheckBox CheckBox (Callback -> Void) (Callback -> Void) 
+     ;; set up the top of the frame 
+     (define (make-top title insert add quit-cb)
+       (define f (new dialog% (label title) (width 500) (height 300)))
+       (define p (new vertical-pane% (parent f)))
+       
+       (define button-panel (add-horizontal-panel p))
+       
+       (define quit (add-button button-panel  "Abort" quit-cb))
+       
+       (define/abstract make-class-cb)
+       (define class-button (add-button button-panel insert make-class-cb))
+       
+       (define/abstract add-field-cb)
+       (define add-field-button (add-button button-panel add add-field-cb))
+       
+       (define switch-pane (add-horizontal-panel p))
+       (define toString-check (make-checkbox switch-pane "add toString()"))    
+       (define template-check (make-checkbox switch-pane "add method template"))  
+       
+       (values f p toString-check template-check set-make-class-cb set-add-field-cb))
+     
+     ;; Panel String [Callback] -> TextField
+     (define make-text-field 
+       (opt-lambda (p l (c void))
+         (new text-field% 
+              (parent p) (label l) (callback c)
+              (min-width 50) (stretchable-width #f))))
+     
+     ;; Pane -> HorizontalPanel
+     ;; add a fixed-width horizontal panel (50) to p
+     (define (add-horizontal-panel p)
+       (new horizontal-panel% (parent p) (min-height 50) (stretchable-height #f)))
+     
+     ;; Panel -> (Panels -> Panels)
+     ;; remove vp from cs 
+     (define (remove-panel vp)
+       (lambda (cs) (filter (lambda (c) (not (eq? vp c))) cs)))
+     
+     ;; String CallBack -> Button
+     (define (add-button bp l cb) ;; to button-panel
+       (new button% (label l) (parent bp) (callback cb)))
+     
+     ;; Panel String -> CheckBox
+     (define (make-checkbox p l)
+       (new check-box% (parent p) (label l) (callback void)))
+     
+     ;; Panel -> (String -> Void) (Any -> Boolean) 
+     (define (add-error-panel p)
+       (define message-size 100)
+       (define spec-error (cons 1 2))
+       (define message
+         (new message%
+              (parent (add-horizontal-panel p)) (label (make-string 100 #\space))))
+       ;; String -> false
+       (define (error-message m)
+         (send message set-label (string-append "error: "m))
+         (raise spec-error))
+       ;; Any -> Boolean 
+       (define (spec-error? x) (eq? spec-error x ))
+       (values error-message spec-error?))
+     
+     
+     #| run: emulate the actual wizard
+     (require (file "class.scm"))
+     
+     (provide x y)
+     
+     (define x (get-class-info))
+     (if x (printf "~a~n" (apply make-class x)))
+     
+     (define y (get-union-info))
+     (if y (printf "~a~n" (apply make-union y)))
+     |#
+     
+     )
diff --git a/collects/readline/doc.txt b/collects/readline/doc.txt
new file mode 100644
index 0000000000..12e5c31418
--- /dev/null
+++ b/collects/readline/doc.txt
@@ -0,0 +1,31 @@
+
+The _readline_ collection (not to be confused with MzScheme's
+`read-line' procedure) provides glue for using GNU's readline library
+with the MzScheme read-eval-print-loop.
+
+
+Normal use of readline
+----------------------
+
+The _rep.ss_ library installs a readline-based function for the
+prompt-and-read part of MzScheme's read-eval-print loop.
+
+I put the following in my ~/.mzschemerc so that MzScheme always starts
+with readline support:
+
+ (require (lib "rep.ss" "readline"))
+
+The readline history is stored across invocations in MzScheme's
+preferences file, assuming MzScheme exits normally.
+
+
+Direct bindings for readline hackers
+------------------------------------
+
+The _readline.ss_ library provides two functions:
+
+> (readline prompt-string) - prints the given prompt string and reads
+  an S-expression.
+
+> (add-history s) - adds the given string to the readline history,
+  which is accessible to the user via the up-arrow key
diff --git a/collects/readline/info.ss b/collects/readline/info.ss
new file mode 100644
index 0000000000..3beace3d09
--- /dev/null
+++ b/collects/readline/info.ss
@@ -0,0 +1,7 @@
+
+(module info (lib "infotab.ss" "setup")
+  (define doc.txt "doc.txt")
+  (define name "readline")
+  (define blurb
+    `("The readline collection provides glue for using GNU's readline library"
+      " with the MzScheme read-eval-print-loop.")))
diff --git a/collects/readline/mzrl.ss b/collects/readline/mzrl.ss
new file mode 100644
index 0000000000..d63863b5ab
--- /dev/null
+++ b/collects/readline/mzrl.ss
@@ -0,0 +1,42 @@
+(module mzrl mzscheme
+
+(require (lib "foreign.ss")) (unsafe!)
+(provide readline add-history set-completion-function!)
+
+; libtermcap maybe needed
+(define libtermcap  (with-handlers ([exn:fail? void])
+		      (ffi-lib "libtermcap")))
+(define libreadline (ffi-lib "libreadline"))
+
+(define readline
+  (get-ffi-obj "readline" libreadline (_fun _string -> _string/eof)))
+
+(define add-history
+  (get-ffi-obj "add_history" libreadline (_fun _string -> _void)))
+
+;; Simple completion: use this with a (string -> list-of string) function that
+;; returns the completions for a given string.  (should clean up bytes/string)
+(define (set-completion-function! func)
+  (if func
+    (set-ffi-obj! "rl_completion_entry_function" libreadline
+                  (_fun _string _int -> _pointer)
+                  (completion-function func))
+    (set-ffi-obj! "rl_completion_entry_function" libreadline _pointer #f)))
+(define (completion-function func)
+  (let ([cur '()])
+    (define (complete str state)
+      (if (zero? state)
+        (begin (set! cur (func str)) (complete str 1))
+        (and (pair? cur)
+             (begin0 (malloc (add1 (bytes-length (car cur)))
+                             (car cur) 'eternal)
+               (set! cur (cdr cur))))))
+    complete))
+
+(set-ffi-obj! "rl_readline_name" libreadline _string "mzscheme")
+
+;; make it possible to run Scheme threads while waiting for input
+(set-ffi-obj! "rl_event_hook" libreadline (_fun -> _int)
+              (lambda () (sync/enable-break (current-input-port)) 0))
+
+)
diff --git a/collects/readline/pread.ss b/collects/readline/pread.ss
new file mode 100644
index 0000000000..b35f79ad9a
--- /dev/null
+++ b/collects/readline/pread.ss
@@ -0,0 +1,69 @@
+
+(module pread mzscheme
+  (require "readline.ss"
+	   (lib "file.ss"))
+
+  (define MAX-HISTORY 100)
+  (define leftovers null)
+
+  (define counter 1)
+
+  (define local-history (get-preference 'mzrl-history (lambda () null)))
+
+  (define (do-readline p)
+    (let ([s (readline p)])
+      (when (string? s)
+	(add-history s)
+	(if (= (length local-history) MAX-HISTORY)
+	    (set! local-history (cdr local-history)))
+	(set! local-history (append local-history (list s))))
+      s))
+
+  (define (save-history)
+    (put-preferences '(mzrl-history) (list local-history)))
+
+  (exit-handler (let ([old (exit-handler)])
+		  (lambda (v)
+		    (save-history)
+		    (old v))))
+  
+  (for-each add-history (if (list? local-history) local-history null))
+
+  (define (prompt-read-using-readline get-prompt)
+    (if (pair? leftovers)
+	(begin0
+	 (car leftovers)
+	 (set! leftovers (cdr leftovers)))
+	(let big-loop ()
+	  (let loop ([s (do-readline (get-prompt 0))][next-pos 1][force? #f])
+	    (if (eof-object? s)
+		(begin
+		  (save-history)
+		  s)
+		(with-handlers ([(if force? (lambda (x) #f) exn:fail:read:eof?)
+				 (lambda (exn)
+				   (let ([v (do-readline (get-prompt next-pos))])
+				     (loop (string-append 
+					    s
+					    "\n"
+					    (if (eof-object? v)
+						""
+						v))
+					   (add1 next-pos)
+					   (eof-object? v))))])
+		  (let ([p (open-input-string (string-append s "\n"))])
+		    (port-count-lines! p)
+		    (let ([rs (let loop ()
+				(let ([r (parameterize ([read-accept-reader #t])
+					   (read-syntax (string->path (format "repl-~a" counter)) p))])
+				  (if (eof-object? r)
+				      null
+				      (cons r (loop)))))])
+		      (if (null? rs)
+			  (big-loop)
+			  (begin0
+			   (car rs)
+			   (set! counter (add1 counter))
+			   (set! leftovers (cdr rs))))))))))))
+
+  (provide prompt-read-using-readline))
diff --git a/collects/readline/readline.ss b/collects/readline/readline.ss
new file mode 100644
index 0000000000..25a38a56fe
--- /dev/null
+++ b/collects/readline/readline.ss
@@ -0,0 +1,6 @@
+
+(module readline mzscheme
+  (require "mzrl.ss") ;; should load .so form
+  
+  (provide readline add-history))
+
diff --git a/collects/readline/rep.ss b/collects/readline/rep.ss
new file mode 100644
index 0000000000..ed5cd2393b
--- /dev/null
+++ b/collects/readline/rep.ss
@@ -0,0 +1,13 @@
+
+(module rep mzscheme
+  (require "pread.ss")
+
+  (current-prompt-read 
+   (let ([orig-read (current-prompt-read)]
+	 [orig-input (current-input-port)])
+     (lambda ()
+       (if (eq? (current-input-port) orig-input)
+	   (prompt-read-using-readline (lambda (n) (if (zero? n) "> " "  ")))
+	   (orig-read))))))
+
+
diff --git a/collects/reduction-semantics/doc.txt b/collects/reduction-semantics/doc.txt
new file mode 100644
index 0000000000..61121a1caa
--- /dev/null
+++ b/collects/reduction-semantics/doc.txt
@@ -0,0 +1,909 @@
+_Reduction Semantics_
+_reduction-semantics_
+
+This collection provides three files:
+
+  _reduction-semantics.ss_: the core reduction semantics
+  library
+
+  _gui.ss_: a _visualization tool for reduction sequences_.
+
+  _subst.ss_: a library for _capture avoiding substitution_.
+
+In addition, the examples subcollection contains several
+small languages to demonstrate various different uses of
+this tool:
+
+  _arithmetic.ss_: an arithmetic language with every
+  possible order of evaluation
+
+  _church.ss_: church numerals with call by name
+  normal order evaluation
+
+  _combinators.ss_: fills in the gaps in a proof in
+  Berendrecht that i and j (defined in the file) are
+  a combinator basis
+
+  _future.ss_: an adaptation of Cormac Flanagan's future
+  semantics.
+
+  _ho-contracts.ss_: computes the mechanical portions of a
+  proof in the Contracts for Higher Order Functions paper
+  (ICFP 2002). Contains a sophisticated example use of an
+  alternative pretty printer.
+
+  _macro.ss_: models macro expansion as a reduction semantics.
+
+  _omega.ss_: the call by value lambda calculus with call/cc.
+  Includes omega and two call/cc-based infinite loops, one of
+  which has an ever-expanding term size and one of which has
+  a bounded term size.
+
+  _threads.ss_: shows how non-deterministic choice can be
+  modelled in a reduction semantics. Contains an example use
+  of a simple alternative pretty printer.
+
+  _semaphores.ss_: a simple threaded language with semaphores
+
+
+  iswim.ss : see further below.
+
+======================================================================
+
+The _reduction-semantics.ss_ library defines a pattern
+language, used in various ways:
+
+  pattern = any
+          | number
+          | string
+          | variable
+          | (variable-except <symbol> ...)
+          | hole
+          | (hole <symbol>)
+          | <symbol>
+          | (name <symbol> <pattern>)
+          | (in-hole <pattern> <pattern>)
+          | (in-named-hole <symbol> <symbol> <pattern> <pattern>)
+          | (side-condition <pattern> <guard>)
+          | (cross <symbol>>)
+          | (pattern ...)
+          | <scheme-constant>
+
+The patterns match sexpressions. The _any_ pattern matches
+any sepxression. The _number_ pattern matches any
+number. The _string_ pattern matches any string. Those three
+patterns may also be suffixed with an underscore and another
+identifier, in which case they bind the full name (as if it
+were an implicit `name' pattern) and match the portion
+before the underscore.
+
+The _variable_ pattern matches any symbol. The
+_variable-except_ pattern matches any variable except those
+listed in its argument. This is useful for ensuring that
+keywords in the language are not accidentally captured by
+variables.
+
+The _hole_ pattern matches anything when inside a matching
+in-hole pattern. The (hole <symbol>) variation on that
+pattern is used in conjuction with in-named-hole to support
+languages that require multiple patterns in a hole.
+
+The _<symbol>_ pattern stands for a literal symbol that must
+match exactly, unless it is the name of a non-terminal in a
+relevant language or contains an underscore. 
+
+If it is a non-terminal, it matches any of the right-hand
+sides of that non-terminal.
+
+If the symbol is a non-terminal followed by an underscore,
+for example e_1, it is implicitly the same as a name pattern
+that matches only the non-terminal, (name e_1 e) for the
+example. If the symbol otherwise has an underscore, it is
+an error.
+
+_name_: The pattern:
+
+  (name <symbol> <pattern>)
+
+matches <pattern> and binds using it to the name <symbol>. 
+
+_in-hole_: The (in-hole <pattern> <pattern>) matches the first
+pattern. This match must include exactly one match against the `hole'
+pattern. The `hole' pattern matches any sexpression. Then, the
+sexpression that matched the hole pattern is used to match against the
+second pattern.
+
+_in-named-hole_: The pattern:
+
+   (in-named-hole <symbol> <pattern> <pattern>) 
+
+is similar in spirit to in-hole, except that it supports
+languages with multiple holes in a context. The first
+argument identifies which hole, using the (hole <symbol>)
+pattern that this expression requires and the rest of the
+arguments are just like in-hole. That is, if there are
+multiple holes in a term, each matching a different (hole
+<name>) pattern, this one selects only the holes that are
+named by the first argument to in-named-hole.
+
+_side-condition_: The (side-condition pattern guard) pattern matches
+what the embedded pattern matches, and then the guard expression is
+evaluated. If it returns #f, the pattern fails to match, and if it
+returns anything else, the pattern matches. In addition, any
+occurrences of `name' in the pattern are bound using `term-let'
+(see below) in the guard.
+
+_cross_: The (cross <symbol>) pattern is used for the compatible
+closure functions. If the language contains a non-terminal with the
+same name as <symbol>, the pattern (cross <symbol>) matches the
+context that corresponds to the compatible closure of that
+non-terminal.
+
+The (pattern ...) pattern matches a sexpression list, where
+each pattern matches an element of the list. In addition, if
+a list pattern contains an ellipses that is not treated as a
+literal, instead it matches any number of duplications of the
+pattern that came before the ellipses (including 0). Furthemore,
+each (name <symbol> <pattern>) in the duplicated pattern
+binds a list of matches to <symbol>, instead of a single match.
+(A nested duplicated pattern creates a list of list matches,
+etc.) Ellipses may be placed anywhere inside the row of 
+patterns,  except in the first position or immediately after
+another ellipses.  Multiple ellipses are allowed.
+
+> (language (non-terminal pattern ...) ...)     SYNTAX
+
+This form defines a context-free language. As an example,
+this is the lambda calculus:
+
+  (define lc-lang
+    (language (e (e e ...)
+                 variable
+                 v)
+              (c (v ... c e ...)
+                 hole)
+              (v (lambda (variable ...) e))))
+
+with non-terminals e for the expression language, c for the
+evaluation contexts and v for values.
+
+> compiled-lang? : (any? . -> . boolean?)
+
+Returns #t if its argument was produced by `language', #f
+otherwise.
+
+> (term-let ([tl-pat expr] ...) body)           SYNTAX
+
+Matches each given id pattern to the value yielded by
+evaluating the corresponding expr and binds each variable in
+the id pattern to the appropriate value (described
+below). These bindings are then accessible to the `term'
+syntactic form.
+
+Identifier-patterns are terms in the following grammar:
+
+    tl-pat ::= identifier
+             | (tl-pat-ele ...)
+tl-pat-ele ::= tl-pat
+             | tl-pat ellipses
+
+where ellipses is the literal symbol consisting of three
+dots (and the ... indicates repetition as usual). If tl-pat
+is an identifier, it matches any value and binds it to the
+identifier, for use inside `term'. If it is a list, it
+matches only if the value being matched is a list value and
+only if every subpattern recursively matches the
+corresponding list element. There may be a single ellipsis
+in any list pattern; if one is present, the pattern before
+the ellipses may match multiple adjacent elements in the
+list value (possibly none).
+
+> (term s-expr)                                 SYNTAX
+
+This form is used for construction of new s-expressions in
+the right-hand sides of reductions. It behaves identically
+to quasiquote except that names bound by `term-let' are
+implicitly substituted with the values that those names were
+bound to, expanding ellipses as in-place sublists (in the
+same manner as syntax-case patterns).
+
+For example,
+
+(term-let ([body '(+ x 1)]
+           [(expr ...) '(+ - (values * /))]
+           [((id ...) ...) '((a) (b) (c d))])
+  (term (let-values ([(id ...) expr] ...) body)))
+
+evaluates to
+
+'(let-values ([(a) +] 
+              [(b) -] 
+              [(c d) (values * /)]) 
+   (+ x 1))
+
+It is an error for a term variable to appear in an
+expression with an ellipsis-depth different from the depth
+with which it was bound by `term-let'. It is also an error
+for two `term-let'-bound identifiers bound to lists of
+different lengths to appear together inside an ellipsis.
+
+> (reduction language pattern bodies ...)       SYNTAX
+
+This form defines a reduction. The first position must
+evaluate to a language defined by the `language' form. The
+pattern determines which terms this reductions apply to and
+the last bodies are expressions that must evaluate to a new
+sexpression corresponding to the reduct for this term. The
+bodies are implicitly wrapped in a begin.
+
+As an example, the reduction for the lambda calculus above
+would be written like this:
+
+     (reduction lc-lang
+                (in-hole (name c c)
+                         ((lambda (variable_i ...) e_body)
+                          v_i ...))
+                (plug 
+                 (term c) 
+                 (foldl lc-subst (term e_body) 
+                                 (term (v_i ...)) 
+                                 (term (variable_i ...)))))
+
+The in-hole pattern matches a term against `c', and binds
+what matches the hole to `hole'. Then, it matches what
+matched the hole against ((lambda (variable) e) v).
+
+Because of the name pattern and the subscripted variable names
+we used, c, hole, variable_i, e_body, and v_i
+are bound with `term-let' in the right hand side of the 
+reduction. Then, when the reduction matches, the result is 
+the result of evaluating the last argument to reduction. 
+See `plug' below and lc-subst is defined by using the 
+subst.ss library below.
+
+> (reduction/context language context pattern bodies ...)   SYNTAX
+
+reduction/context is a short-hand form of reduction. It
+automatically adds the `in-hole' pattern and the call to
+`plug'. The equivalent reduction/context to the above
+example is this:
+
+     (reduction/context 
+      lang
+      c
+      ((lambda (variable_i ...) e_body) v_i ...)
+      (lc-subst (term (variable_i ...))
+                (term (v_i ...))
+                (term e_body))))
+
+> red? : (any? . -> . boolean?)
+
+Returns #t if its argument is a reduction (produced by `reduction',
+`reduction/context', etc.), #f otherwise.
+
+> compatible-closure : (red?
+                        compiled-lang?
+                        symbol?
+                        . -> .
+                        red?)
+
+This function accepts a reduction, a language, the name of a
+non-terminal in the language and returns the compatible
+closure of the reduction for the specified non-terminal.
+
+> context-closure : (red?
+                     compiled-lang?
+                     any
+                     . -> .
+                     red?)
+
+This function accepts a reduction, a language, a pattern
+representing a context (ie, that can be used as the first
+argument to `in-hole'; often just a non-terminal) in the
+language and returns the closure of the reduction
+in that context.
+
+> plug : (any? any? . -> . any)
+
+The first argument to this function is an sexpression to
+plug into. The second argument is the sexpression to replace
+in the first argument. It returns the replaced term.
+
+> reduce : ((listof red?) any? . -> . (listof any?))
+
+Reduce accepts a list of reductions, a term, and returns a
+list of terms that the term reduces to.
+
+> language->predicate : (compiled-lang?
+                         symbol?
+                         . -> . 
+                         (any? . -> . boolean?))
+
+Takes a language and a non-terminal name and produces
+a predicate that matches instances of the non-terminal.
+
+> match-pattern : (compiled-pattern 
+                   any/c
+                   . -> .
+                   (union false? (listof mtch?)))
+
+This is mostly used to explore a particular pattern to
+determine what is going wrong. It accepts a compiled pattern
+and a and returns #f if the pattern doesn't match the term,
+and returns a list of mtch structure if the terms do match.
+
+> compile-pattern : (compiled-lang? any? . -> . compiled-pattern)
+
+This is mostly used in conjunction with match-pattern to
+explore particular patterns and terms when debugging. It
+compiles a sexpression pattern to a pattern.
+
+> mtch? : (any/c . -> . boolean?)
+
+Determines if a value is a mtch structure.
+
+> mtch-bindings : (mtch? -> bindings?)
+
+This returns a bindings structure (see below) that
+binds the pattern variables in this match.
+
+> mtch-context : (mtch? . -> . any/c)
+
+Returns the current context being built up for a
+match. Usually, this is the same as the original term being
+matched.
+
+> mtch-hole : (mtch? . -> . (union none? any/c))
+
+Returns the current contents of the hole for this match (if
+there was a decomposition). Usually returns none.
+
+> variable-not-in : (any? symbol? . -> . symbol?)
+
+This helper function accepts an sexpression and a
+variable. It returns a variable not in the sexpression with
+a prefix the same as the second argument.
+
+> make-bindings : ((listof rib?) . -> . bindings?)
+> bindings? : (any? . -> . boolean?)
+> bindings-table : (bindings? . -> . (listof rib?))
+
+Constructor, predicate, and selector functions for the bindings values
+returned by match-pattern.  Each bindings value represents the bindings
+established for a single parse of the term; multiple such parses may be
+possible in some situations.
+
+> make-rib : (symbol? any? . -> . rib?)
+> rib? : (any? . -> . boolean?)
+> rib-name : (rib? . -> . symbol?)
+> rib-exp : (rib? . -> . any?)
+
+Constructor, predicate, and selector functions for the rib values contained
+within a bindings.  Each rib associates a name with an s-expression from
+the language, or a list of such s-expressions, if the (name ...) clause is
+followed by an ellipsis.  Nested ellipses produce nested lists.
+
+======================================================================
+
+The _gui.ss_ library provides three functions:
+
+> (traces language reductions expr [pp])
+
+This function calls traces/multiple with language, reductions
+and (list expr).
+
+> (traces/multiple lang reductions exprs [pp])
+
+This function calls traces/pred with the predicate
+(lambda (x) #t)
+
+> (traces/pred lang reductions exprs pred [pp])
+  lang : language
+  reductions : (listof reduction)
+  exprs : (listof sexp)
+  pred : (sexp -> boolean)
+  pp : (any -> string)
+     | (any port number (is-a?/c text%) -> void)
+
+This function opens a new window and inserts each
+expr. Then, reduces the terms until either
+reduction-steps-cutoff (see below) different terms are
+found, or no more reductions can occur. It inserts each new
+term into the gui. Clicking the `reduce' button reduces
+until reduction-steps-cutoff more terms are found.
+
+The pred function indicates if this term has a particular
+property. If the function returns #t, the term is displayed
+normally. If it returns #f, the term is displayed with a
+red border.
+
+If the pp function can take four arguments, it renders its
+first argument into the port (its second argument) with 
+width at most given by the number (its third argument). The
+final argument is the text where the port is connected -- 
+characters written to the port go to the end of the editor.
+If the pp function cannot take four arguments, it is 
+instead invoked with a single argument, the s-expression to
+render, and it must return a string which the GUI will use
+as a representation of the given expression for display.
+
+The default pp uses mzlib's pretty-print function. See 
+threads.ss in the examples directory for an example use 
+of the one-argument form of this argument and 
+ho-contracts.ss in the examples directory for an example 
+use of its four-argument form.
+
+You can save the contents of the window as a postscript file
+from the menus.
+
+> (reduction-steps-cutoff)
+> (reduction-steps-cutoff number)
+
+A parameter that controls how many steps the `traces' function
+takes before stopping.
+
+> (initial-font-size)
+> (initial-font-size number)
+
+A parameter that controls the initial font size for the terms shown
+in the GUI window.
+
+> (initial-char-width)
+> (initial-char-width number)
+
+A parameter that determines the initial width of the boxes
+where terms are displayed (measured in characters)
+
+> (dark-pen-color color-or-string)
+> (dark-pen-color) => color-or-string
+
+> (dark-brush-color color-or-string)
+> (dark-brush-color) => color-or-string
+
+> (light-pen-color color-or-string)
+> (light-pen-color) => color-or-string
+
+> (light-brush-color color-or-string)
+> (light-brush-color) => color-or-string
+
+These four parameters control the color of the edges in the graph.
+
+======================================================================
+
+The _subst.ss_ library provides these names:
+
+> (subst (match-pattern subst-rhs ...) ...)      SYNTAX
+
+The result of this form is a function that performs capture
+avoiding substition for a particular (sexp-based)
+language. The function accepts three arguments, a variable,
+a term to substitue and a term to substitute into.
+
+Each of the `match-pattern's specify the forms of
+the language and the `subst-rhs's specify what kind of form
+it is.  Each of the match-patterns are in (lib "match.ss"
+"match)'s pattern language and any variable that they bind
+are avaialbe in the <scheme-expression>'s described below.
+
+The language of the subst-rhs follows.
+
+> (variable)
+
+  this means that the rhs for this form is a symbol that
+  should be treated like a variable. Nothing may follow
+  this.
+
+> (constant)
+
+  this means that the rhs for thsi form is a constant that
+  cannot be renamed. Nothing may follow this.
+
+> (all-vars <scheme-expression>)
+
+This form indicates that this pattern in the language binds
+the variables produced by the
+<scheme-expression>. 
+
+Immediately following this in a subst-rhs must be a (build
+...) form and some number of (subterm ...) or (subterms ...)
+forms.
+
+> (build <scheme-expression>)
+
+This form must come right after an (all-vars ...) form and
+before any (subterm ...) or (subterms ...) forms.
+
+This form tells subst how to reconstruct this term. The
+<scheme-expression> must evaluate to a procedure that
+accepts the (possibly renamed) variables from the all-vars
+clause, and one argument for each of the subterms that
+follow this declaration (with subterms flattened into the
+argument list) in the same order that the subterm or
+subterms declarations are listed.
+
+> (subterm <scheme-expression> <scheme-expression>)
+
+The first <scheme-expression> must be a list of variables
+that is a sub-list of the variables in the all-vars
+expression. The second expression must be an sexp
+corresponding to one of the subexpressions of this
+expression (matched by the match-patten for this clause of
+subst).
+
+> (subterms <scheme-expression> <scheme-expression>)
+
+The first <scheme-expression> must be a list of variables
+that is a sub-list of the variables in the all-vars
+expression. The second expression must be an sexp
+corresponding to one of the subexpressions of this
+expression (matched by the match-patten for this clause of
+subst).
+
+Consider this example of a substition procedure for the
+lambda calculus:
+
+  (define lc-subst
+    (subst
+     [`(lambda ,vars ,body)
+      (all-vars vars)
+      (build (lambda (vars body) `(lambda ,vars ,body)))
+      (subterm vars body)]
+     [(? symbol?) (variable)]
+     [(? number?) (constant)]
+     [`(,fun ,@(args ...))
+      (all-vars '())
+      (build (lambda (vars fun . args) `(,fun ,@args)))
+      (subterm '() fun)
+      (subterms '() args)]))
+
+The first clause matches lambda expressions with any number
+of arguments and says that there is one subterm, the body of
+the lambda, and that all of the variables are bound in it.
+
+The second clause matches symbols and indicates that they
+are variables.
+
+The third clause matches numbers and indicates that they are
+constants.
+
+The final clause matches function applications. The
+`all-vars' shows that applications introduce no new
+names. The build procedure reconstructs a new application
+form. The subterm declaration says that the function
+position is a subterm with no variables bound in it. The
+subterms declaration says that all of the arguments are
+subterms and that they do not introduce any new terms.
+
+In this program, lc-subst is bound to a function that does
+the substition. The first argument is the variable to
+substitute for, the second is the term to substitute and the
+final argument is the term to substitute into. For example,
+this call:
+
+  (lc-subst 'q 
+            '(lambda (x) y) 
+            '((lambda (y) (y q)) (lambda (y) y)))
+
+produces this output:
+
+  '((lambda (y@) (y@ (lambda (x) y))) (lambda (y) y))
+
+This library also provides:
+
+> (plt-subst (match-pattern subst-rhs ...) ...)      SYNTAX
+
+This is identical to subst, described above, except that
+the pattern language used is that from (lib "plt-match.ss"), 
+instead of (lib "match.ss").
+
+> subst/proc
+> alpha-rename 
+> free-vars/memoize
+
+Theses functions are the procedure-based interface to
+substitution that subst expands to and uses.
+
+======================================================================
+
+The _iswim.ss_ module in the "examples" sub-collection defines a
+grammar and reductions from "Programming Languages and Lambda Calculi"
+by Felleisen and Flatt.
+
+       Example S-expression forms of ISWIM expressions:
+         Book                     S-expr
+         ----                     ------
+         (lambda x . x)           ("lam" x x)
+         (+ '1` '2`)              ("+" 1 2)
+         ((lambda y y) '7`)       (("lam" y y) 7)
+
+       CK machine:
+         Book                     S-expr
+         ----                     ------
+         <(lambda x . x), mt>     (("lam" x x) : "mt")
+
+       CEK machine:
+         Book                     S-expr
+         ----                     ------
+         <<(lambda x . x),        ((("lam" x x)
+           {<X,<5,{}>>}>,           : ((X (5 : ()))))
+          mt>                      : "mt")
+         
+       The full grammar:
+
+         (language (M (M M)
+                      (o1 M)
+                      (o2 M M)
+                      V)
+                   (V X
+                      ("lam" variable M)
+                      b)
+                   (X variable)
+                   (b number)
+                   (o1 "add1" "sub1" "iszero")
+                   (o2 "+" "-" "*" "^")
+                   (on o1 o2)
+                   
+                   ;; Evaluation contexts:
+                   (E hole
+                      (E M)
+                      (V E)
+                      (o1 E)
+                      (o2 E M)
+                      (o2 V E))
+     
+                   ;; Continuations (CK machine):
+                   (k "mt"
+                      ("fun" V k)
+                      ("arg" M k)
+                      ("narg" (V ... on) (M ...) k))
+     
+                   ;; Environments and closures (CEK):
+                   (env ((X = vcl) ...))
+                   (cl (M : env))
+                   (vcl (V- : env))
+                   
+                   ;; Values that are not variables:
+                   (V- ("lam" variable M)
+                       b)
+     
+                   ;; Continuations with closures (CEK);
+                   (k- "mt"
+                       ("fun" vcl k-)
+                       ("arg" cl k-)
+                       ("narg" (vcl ... on) (cl ...) k-)))
+     
+       The following are provided by "iswim.ss" (case-insensitively):
+
+               Grammar and substitution:
+>                 iswim-grammar : compiled-lang?
+>                 M? : (any? . -> . boolean?)
+>                 V? : (any? . -> . boolean?)
+>                 o1? : (any? . -> . boolean?)
+>                 o2? : (any? . -> . boolean?)
+>                 on? : (any? . -> . boolean?)
+>                 k? : (any? . -> . boolean?)
+>                 env? : (any? . -> . boolean?)
+>                 cl? : (any? . -> . boolean?)
+>                 vcl? : (any? . -> . boolean?)
+>                 k-? : (any? . -> . boolean?)
+>                 iswim-subst : (M? symbol? M? . -> . M?)
+>                 empty-env : env?
+>                 env-extend : (env? symbol? vcl? . -> . env?)
+>                 env-lookup : (env? symbol? . -> . (union false? vcl?))
+               Reductions:
+>                 beta_v : red?
+>                 delta : (listof red?)
+>                 ->v : (listof red?)
+>                 :->v : (listof red?)
+               Abbreviations:
+>                 if0 : (M? M? M? . -> . M?)
+>                 true : M?
+>                 false : M?
+>                 mkpair : M?
+>                 fst : M?
+>                 snd : M?
+>                 Y_v : M?
+>                 sum : M?
+               Helpers:
+>                 delta*1 : (o1? V? . -> . (union false? V?))
+                     delta as a function for unary operations.
+>                 delta*2 : (o2? V? V? . -> . (union false? V?))
+                     delta as a function for binary operations.
+>                 delta*n : (on? (listof V?) . -> . (union false? V?))
+                     delta as a function for any operation.
+
+======================================================================
+
+The _helper.ss_ module provides additional helper functions and syntax.
+
+ ------- Memoization -------
+
+> (define-memoized (f arg ...) expr ...)    SYNTAX
+
+  Like `define' for function defitions, except that the function is
+  "memoized": it automatically remembers each result, and when `eq?'
+  arguments are provided later, the same result is returned
+  immeduately.
+
+> (lambda-memoized (arg ...) expr)          SYNTAX
+
+  Like `lambda' except that the resulting function is "memoized" (see
+  `define-memoized' above).
+
+ ------- Matching -------
+
+> (lang-match-lambda (variable) grammar-expr 
+    [pattern bodies ...] ...)                                SYNTAX
+
+  Combines a pattern-matching dispatch with a `lambda', producing a
+  function that takes a single argument and pattern-matches. Each
+  `pattern' is as for `reduction', and the names that the pattern
+  binds are visible in the `bodies'.
+
+> (lang-match-lambda* (variable ...) main-variable grammar-expr 
+    [pattern bodies ...] ...)                                SYNTAX
+
+  Generalizes `lang-match-lambda' to create a multi-arity procedure.
+  The `main-variable' must be one of the `variables', and it is the
+  variable used for matching.
+
+> lang-match-lambda-memoized                                 SYNTAX
+> lang-match-lambda-memoized*                                SYNTAX
+
+  Memoized versions of the above.
+
+ ------- Backtracking -------
+
+A function that supports backtracking must returns one of the
+following:
+
+  * #f to indicate failure
+  * any other value to indicate simple success
+  * (many-results l) to indicates success with any of the
+    results in the list l
+  * (explore-results ...) or (explore-parallel-results ...),
+    which explores the results of recursive calls to generate
+    one or more result values lazily
+
+Whenever the backtracking function calls itself (or another
+backtracking function in a cooperative set), it should use
+`explore-results' or `explore-parallel-results' instead of
+inspecting the value directly. To get a single result from
+the backtracking function, uses `first-result'.
+
+> many-results : ((listof any) . -> . any)
+
+Aggregates potential results for future exploration.
+
+> (explore-results (id) backtrackable-expr                   SYNTAX
+        body-expr ...)
+
+  Evaluates `backtrackable-expr'. In the simple case, `id' is bound to
+  the result, the the result of the `explore-results' expression is
+  the result of evaluating `body-expr's.
+
+  If `backtrackable-expr' produces multiple alternatives (via
+  `many-results') or if it produces a backtrackable computation, the
+  result is a backtrackable computation. This backtrackable
+  computation proceeds bey generating each successful result from
+  `backtrackable-expr', and then feeding the result to the
+  `body-expr's to refine the results. Naturally, `body-expr' can
+  contain futher uses of `explore-results' or `many-results' which are
+  folded into the backtracking exploration.
+
+> (explore-parallel-results (results-id) backtrackable-list-expr
+     body-expr ...)
+
+  Generalizes `explore-results' where `backtrackable-list-expr'
+  produces a list of backtrackable results, and `body-expr' is called
+  with successful combinations aggregated into `results-id' as a list.
+
+> first-result : (any . -> . any)
+
+  If the argument to `first-result' is a backtrackable computation, it
+  is explored to obtain the first success, and that success is
+  returned. If complete backtracking fails, the result is #f. If the
+  argument to `first-result' is any other value, it is returned
+  immediately.
+
+ ------- Misc -------
+
+> function-reduce* : ((listof red?)
+                      any?
+                      (any? . -> . boolean?)
+                      number?
+                      . -> . (listof any?))
+
+   A poor-man's `gui' for test interaction. The first argument
+   represents a set of reductions that define a function; the second
+   argument is the starting expression; the thrid argument is a
+   predicate to recognize ending expressions; the fourth argument
+   limits the number of steps taken.  The function applies the
+   reductions repeatedly until an ending expression os found, or until
+   the reduction gets stuck. (If the reduction produces multiple
+   results, an exception is raised.) The result is the list of
+   expressions leading to the ending expression.
+
+> unique-names? : ((listof symbol?) . -> . boolean?)
+
+   Checks a list of symbols, returning #t if each symbol appears
+   only once in the list, #f otherwise.
+
+> generate-string : (-> string?)
+
+   Returns a string that is generated by incrementing a counter.
+
+> all-of : (any? (any? . -> . any) . -> . (listof any?))
+
+   Takes an arbirary S-expression as the first argument, and a
+   predicate as the second argument. all-of' then traverses the pairs
+   that make up the S-expression, calling the predicate on every pair
+   and every value within a pair. The result is the list of values for
+   which the predicate returned true. (If the predicate returns true
+   for a pair, the search does not enter the pair.)
+
+> transitive-closure : ((listof pair?) . -> . (listof (listof any?))
+
+   Given the reprsentation of a function as a list of pairs,
+   `transitive-closure' produces the transitive closure as a list of
+   lists. Each nested list begins with a domain item and continues
+   with a list of range items. 
+
+     Example: 
+      (transitive-closure '((a . b) (b . c))) = '((a b c) (b c))
+
+   The input function must be complete (i.e., all range elements
+   should be in the domain).
+
+   Element equality is determined by `eq?' (with the expectation that
+   elements are usually symbols).
+
+======================================================================
+
+The _generator.ss_ module provides a tool for generating instances of
+a grammar non-terminal.
+
+> lang->generator-table : (lang?
+                           (listof number?)
+                           (listof symbol?)
+                           (listof string?)
+                           (listof symbol?)
+                           number?
+                           . -> .
+                           generator-table?)
+
+  Prepares generator information for a particular language,
+  given a set of numbers to use for the `number' keyword, 
+  a set of symbols for `variable' and `variable-except',
+  and a set of string for `string'.
+
+  The fifth argument lists keywords that appear in the grammar but
+  that should be skipped (to limit the generation space). The last
+  argument should be 0, and it is currently ignored.
+
+> for-each-generated : (generator-table?
+                        (any? number? . -> . any)
+                        generator-table?
+                        symbol?
+                        . -> . any)
+
+  The first argument is a procedure to call with a series of generated
+  grammar instances and each term's size. Instances are generatedfrom
+  smallest to largest; the size of an instance is roughly the size of
+  the proof tree that demonstrates grammar membership.
+
+  The second argument is a generator table created with
+  `lang->generator-table'.
+
+  The third argument is a symbol, the name of a non-terminal for which
+  instances should be generated.
+
+> for-each-generated/size :  (generator-table?
+                              (any? number? . -> . any)
+                              generator-table?
+                              symbol?
+                              . -> . any)
+
+  Like `for-each-generated', except minimum and maxiumum sizes are
+  provided, and the order of generation is arbitrary (i.e., some
+  larger instances may be generated before smaller instances).
diff --git a/collects/reduction-semantics/examples/arithmetic.ss b/collects/reduction-semantics/examples/arithmetic.ss
new file mode 100644
index 0000000000..9d617c9579
--- /dev/null
+++ b/collects/reduction-semantics/examples/arithmetic.ss
@@ -0,0 +1,44 @@
+(module arithmetic mzscheme
+  (require "../reduction-semantics.ss"
+           "../gui.ss")
+  
+  (define lang
+    (language 
+     (e (binop e e)
+        (sqrt e)
+        number)
+     (binop +
+            -
+            *
+            /)
+     
+     (e-ctxt (binop e e-ctxt)
+             (binop e-ctxt e)
+             (sqrt e-ctxt)
+             hole)
+     (v number)))
+  
+  (define reductions
+    (list
+     (reduction lang
+                (in-hole e-ctxt_1
+                         (+ number_1 number_2))
+                (plug (term e-ctxt_1) (+ (term number_1) (term number_2))))
+     (reduction/context lang
+                        e-ctxt
+                        (- number_1 number_2)
+                        (- (term number_1) (term number_2)))
+     (reduction/context lang
+                        e-ctxt
+                        (* number_1 number_2)
+                        (* (term number_1) (term number_2)))
+     (reduction/context lang
+                        e-ctxt
+                        (/ number_1 number_2)
+                        (/ (term number_1) (term number_2)))
+     (reduction/context lang
+                        e-ctxt
+                        (sqrt number_1)
+                        (sqrt (term number_1)))))
+     
+  (traces lang reductions '(- (* (sqrt 36) (/ 1 2)) (+ 1 2))))
\ No newline at end of file
diff --git a/collects/reduction-semantics/examples/beginner.ss b/collects/reduction-semantics/examples/beginner.ss
new file mode 100644
index 0000000000..aecfb1db13
--- /dev/null
+++ b/collects/reduction-semantics/examples/beginner.ss
@@ -0,0 +1,961 @@
+#|
+
+This is the semantics of Beginner Scheme, one of the
+languages in DrScheme.
+
+The first test case fails because the beginner spec
+is broken for that program (ie, the model faithfully
+reflects the (broken) spec).
+
+|#
+
+(module beginner mzscheme
+  (require "../reduction-semantics.ss"
+           "../subst.ss"
+           (lib "match.ss"))
+
+  (provide run-tests)
+  
+  #|
+  
+  `lang' below is actually more generous than beginner, but the
+  reductions assume that the programs are all syntactically
+  well-formed programs in beginner scheme (with the additional
+  constraints that all makers are properly applied and function-
+  defined variables are only applied and non-function-defined
+  variables are never applied -- except for the maker check,
+  these will be in a future version of beginner)
+  
+  still missing: many primops and characters
+  
+  are there any primops that take zero arguments?
+  (should that be syntacically disallowed?)
+
+  |#
+  
+  (define lang
+    (language 
+     (p (d/e ...))
+     (d/e (define (x x x ...) e)
+          (define x (lambda (x x ...) e))
+          (define x e)
+          (define-struct x (x ...))
+          e)
+     (e (x e e ...)
+        (prim-op e ...) 
+        (cond (e e) (e e) ...)
+        (cond (e e) ... (else e))
+        (if e e e)
+        (and e e e ...)
+        (or e e e ...)
+        empty
+        x
+        'x
+        number
+        boolean
+        string)
+        
+     (prim-op + / cons first rest empty? struct? symbol=?)
+     
+     (p-ctxt (d/e-v ... d/e-ctxt d/e ...))
+     (d/e-ctxt (define x e-ctxt)
+               e-ctxt)
+     (e-ctxt hole
+             (x v ... e-ctxt e ...)
+             (prim-op v ... e-ctxt e ...)
+             (cond [false e] ... [e-ctxt e] [e e] ...)
+             (cond [false e] ... [e-ctxt e] [e e] ... [else e])
+             (and true ... e-ctxt e ...)
+             (or false ... e-ctxt e ...))
+     
+     (d/e-v (define x (lambda (x x ...) e))
+            (define x v)
+            (define (x x x ...) e)
+            (define-struct x (x ...))
+            v)
+
+     (v (maker v ...)
+        non-struct-value)
+     (non-struct-value number
+                       list-value
+                       boolean
+                       string
+                       'x)
+     (list-value empty
+                 (cons v list-value))
+     (boolean true
+              false)
+     
+     (maker (side-condition variable_1 (maker? (term variable_1))))
+     
+     (x (side-condition
+         (name 
+          x
+          (variable-except define
+                           define-struct
+                           lambda
+                           cond
+                           else
+                           if
+                           and
+                           or
+                           empty
+                           true
+                           false
+                           quote))
+         (not (prim-op? (term x)))))))
+  
+  (define beg-e-subst 
+    (subst
+     [(? number?)
+      (constant)]
+     [(? symbol?)
+      (variable)]
+     ;; slight cheat here -- but since cond, if, and, or, etc
+     ;; aren't allowed to be variables (syntactically), we're okay.
+     [`(,@(e ...))
+      (all-vars '())
+      (build (lambda (vars . e) e))
+      (subterms '() e)]))
+    
+  (define (maker? v)
+    (and (symbol? v)
+         (regexp-match #rx"^make-" (symbol->string v))))
+  
+  (define p? (language->predicate lang 'p))
+  (define prim-op? (language->predicate lang 'prim-op))
+
+  (define-syntax (--> stx)
+    (syntax-case stx ()
+      [(_ lhs rhs)
+       (syntax (reduction/context lang p-ctxt lhs rhs))]))
+
+  (define-syntax (e--> stx)
+    (syntax-case stx ()
+      [(_ lhs rhs)
+       (syntax (reduction lang (in-hole p-ctxt lhs) rhs))]))
+
+  (define reductions
+    (list
+     
+     ((and true ... false e ...) . --> . 'false)
+     ((and true ...) . --> . 'true)
+     ((side-condition (and true ... v_1 e ...)
+                      (and (not (eq? (term v_1) 'true))
+                           (not (eq? (term v_1) 'false))))
+      . e--> .
+      "and: question result is not true or false")
+     ((or false ... true e ...) . --> . 'true)
+     ((or false ...) . --> . 'false)
+     ((side-condition (or false ... v_1 e ...)
+                      (and (not (eq? (term v_1) 'true))
+                           (not (eq? (term v_1) 'false))))
+      . e--> .
+      "or: question result is not true or false")
+     
+     ((if true e_1 e_2) . --> . (term e_1))
+     ((if false e_1 e_2) . --> . (term e_2))
+     ((side-condition (if v_1 e e)
+                      (and (not (eq? (term v_1) 'false))
+                           (not (eq? (term v_1) 'true))))
+      . e--> .
+      "if: question result is not true or false")
+     
+     
+     ((cond (false e) ... (true e_1) (e e) ...) . --> . (term e_1))
+     ((cond (false e) ... (true e_1) (e e) ... (else e)) . --> . (term e_1))
+     ((cond (false e) ... (else e_1)) . --> . (term e_1))
+     ((cond (false e) ...) . e--> . "cond: all question results were false")
+     
+     ((side-condition
+       (cond (false e) ... (v_1 e) (e e) ...)
+       (and (not (eq? (term v_1) 'false))
+            (not (eq? (term v_1) 'true))
+            (not (eq? (term v_1) 'else))))
+      . e--> .
+      "cond: question result is not true or false")
+     
+     ((side-condition
+       (cond (false e) ... (v_1 e) (e e) ... (else e))
+       (and (not (eq? (term v_1) 'false))
+            (not (eq? (term v_1) 'true))
+            (not (eq? (term v_1) 'else))))
+      . e--> .
+      "cond: question result is not true or false")
+     
+
+     ((empty? empty) . --> . 'true)
+     ((side-condition (empty? v_1)
+                      (not (eq? (term v_1) 'empty)))
+      . --> . 
+      'false)
+     ((empty?) . e--> . "empty?: expects one argument")
+     ((empty? v v v ...) . e--> . "empty?: expects one argument")
+ 
+     ((side-condition (cons v v_1)
+                      (and (not (eq? (term v_1) 'empty))
+                           (not (and (pair? (term v_1))
+                                     (eq? (car (term v_1)) 'cons)))))
+      . e--> .
+      "cons: second argument must be of type <list>")
+     
+     ((first (cons v_1 list-value)) . --> . (term v_1))
+     ((first) . e--> . "first: expects one argument")
+     ((first v v v ...) . e--> . "first: expects one argument")
+     ((side-condition (first v_1)
+                      (not (and (pair? (term v_1)) 
+                                (eq? (car (term v_1)) 'cons))))
+      . e--> .
+      "first: expects argument of type <pair>")
+     
+     ((rest (cons v list-value_1)) . --> . (term list-value_1))
+     ((rest v v v ...) . e--> . "rest: expects one argument")
+     ((rest) . e--> . "rest: expects one argument")
+     
+     ((side-condition (rest v_1)
+                      (not (and (pair? (term v_1)) 
+                                (eq? (car (term v_1)) 'cons))))
+      . e--> .
+      "rest: expects argument of type <pair>")
+     
+     ((symbol=? 'x_1 'x_2) . --> . (if (eq? (term x_1) (term x_2)) 'true 'false))
+     ((side-condition (symbol=? v_1 v_2)
+                      (or (not (and (pair? (term v_1))
+                                    (eq? (car (term v_1)) 'quote)))
+                          (not (and (pair? (term v_2))
+                                    (eq? (car (term v_2)) 'quote)))))
+      . e--> .
+      "symbol=?: expects argument of type <symbol>")
+     ((symbol=?)
+      . e--> .
+      "procedure symbol=?: expects 2 arguments")
+     ((symbol=? v v v v ...)
+      . e--> .
+      "procedure symbol=?: expects 2 arguments")
+     
+     ((+ number_1 ...) . --> . (apply + (term (number_1 ...))))
+     ((side-condition (+ v_arg ...)
+                      (ormap (lambda (v_arg) (not (number? v_arg))) (term (v_arg ...))))
+      . e--> .
+      "+: expects type <number>")
+     
+     ((side-condition (/ number_1 number_2 ...)
+                      (andmap (lambda (number_2) (not (zero? number_2))) (term (number_2 ...))))
+      . --> .
+      (apply / (term (number_1 number_2 ...))))
+     ((side-condition (/ number_1 number_2 ...)
+                      (ormap (lambda (number_2) (zero? number_2)) (term (number_2 ...))))
+      . e--> . 
+      "/: division by zero")
+     ((side-condition (/ v_arg ...)
+                      (ormap (lambda (v_arg) (not (number? v_arg))) (term (v_arg ...))))
+      . e--> .
+      "/: expects type <number>")
+     
+     ;; unbound id application
+     (reduction
+      lang
+      (side-condition
+       ((name before d/e-v) ...
+        (in-hole d/e-ctxt (x_f v ...))
+        d/e ...)
+       (and (not (prim-op? (term x_f)))
+            (not (defined? (term x_f) (term (before ...))))))
+      (format "reference to undefined identifier: ~a" (term x_f)))
+     
+     ;; procedure application as lambda
+     (reduction
+      lang
+      ((name before d/e-v) ...
+       (name defn (define x_f (lambda (x_var ...) e_body)))
+       (name middle d/e-v) ...
+       (in-hole d/e-ctxt_1 (x_f v_arg ...))
+       (name after d/e) ...)
+      (term 
+       (before ...
+        defn
+        middle ...
+        (in-hole d/e-ctxt_1
+                 ,(multi-subst (term (x_var ...)) (term (v_arg ...)) (term e_body)))
+        after ...)))
+     
+     ;; define-style procedure application
+     (reduction
+      lang
+      ((name before d/e-v) ...
+       (name defn (define (x_f x_var ...) e_body))
+       (name middle d/e-v) ...
+       (in-hole (name ctxt d/e-ctxt) ((name f x) (name arg v) ...))
+       (name after d/e) ...)
+      (term
+       (before ...
+        defn
+        middle ...
+        (in-hole ctxt
+                 ,(multi-subst (term (x_var ...))
+                               (term (arg ...))
+                               (term e_body)))
+        after ...)))
+     
+     ;; reference to non-procedure define:
+     (reduction
+      lang
+      ((name before d/e-v) ...
+       (name defn (define (name a x) (name val v)))
+       (name middle d/e-v) ...
+       (in-hole (name ctxt d/e-ctxt) (name a x))
+       (name after d/e) ...)
+      (term 
+       (before ...
+        defn
+        middle ...
+        (in-hole ctxt val)
+        after ...)))
+     
+     ;; unbound reference to top-level id in hole:
+     (reduction
+      lang
+      (side-condition
+       ((name before d/e-v) ...
+        (in-hole d/e-ctxt (name a x))
+        d/e ...)
+       (and (not (prim-op? (term a)))
+            (not (defined? (term a) (term (before ...))))))
+      (format "reference to undefined identifier: ~a" (term a)))
+     
+     ;; reference to procedure-bound var in hole:
+     (reduction
+      lang
+      (d/e-v ...
+       (define ((name f x) (name var x) ...) (name body e))
+       d/e-v ...
+       (in-hole d/e-ctxt (name f x))
+       d/e ...)
+      (format "~a is a procedure, so it must be applied to arguments" (term f)))
+     
+     ;; reference to non-procedure-bound-var in application
+     (reduction
+      lang
+      (d/e-v ...
+       (define (name a x) (name val v))
+       d/e-v ...
+       (in-hole d/e-ctxt ((name a x) v ...))
+       d/e ...)
+      (format "procedure application: expected procedure, given: ~a" (term val)))
+     
+     ((struct? ((name maker maker) v ...)) . --> . 'true)
+     ((struct? non-struct-value) . --> . 'false)
+     
+     ;; struct predicate passes
+     (reduction
+      lang
+      (side-condition
+       ((name before d/e-v) ...
+        (define-struct (name struct x) ((name field x) ...))
+        (name middle d/e-v) ...
+        (in-hole (name ctxt d/e-ctxt) ((name predicate x) ((name maker maker) v ...)))
+        (name after d/e) ...)
+       (and (maker-name-match? (term struct) (term maker))
+            (predicate-name-match? (term struct) (term predicate))))
+      (term
+       (before ...
+        (define-struct struct (field ...))
+        middle ...
+        (in-hole ctxt true)
+        after ...)))
+     
+     ;; struct predicate fail to another struct
+     (reduction
+      lang
+      (side-condition
+       ((name before d/e-v) ...
+        (define-struct (name struct x) ((name field x) ...))
+        (name middle d/e-v) ...
+        (in-hole (name ctxt d/e-ctxt) ((name predicate x) ((name maker maker) v ...)))
+        (name after d/e) ...)
+       (and (not (maker-name-match? (term struct) (term maker)))
+            (predicate-name-match? (term struct) (term predicate))))
+      (term 
+       (before ...
+        (define-struct struct (field ...))
+        middle ...
+        (in-hole ctxt false)
+        after ...)))
+     
+     ;; struct predicate fail to another value
+     (reduction
+      lang
+      (side-condition
+       ((name before d/e-v) ...
+        (define-struct (name struct x) ((name field x) ...))
+        (name middle d/e-v) ...
+        (in-hole (name ctxt d/e-ctxt) ((name predicate x) non-struct-value))
+        (name after d/e) ...)
+       (predicate-name-match? (term struct) (term predicate)))
+      (term 
+       (before ...
+        (define-struct struct (field ...))
+        middle ...
+        (in-hole ctxt false)
+        after ...)))
+     
+     ;; misapplied selector 1
+     (reduction
+      lang
+      (side-condition
+       (d/e-v 
+        ...
+        (define-struct (name struct x) ((name field x) ...))
+        d/e-v ...
+        (in-hole d/e-ctxt ((name selector x) ((name maker maker) (name arg v) ...)))
+        d/e ...)
+       (and (not (maker-name-match? (term struct) (term maker)))
+            (selector-name-match? (term struct) (term (field ...)) (term selector))))
+      (format "~a: expects argument of matching struct" (term selector)))
+     
+     ;; misapplied selector 2
+     (reduction
+      lang
+      (side-condition
+       (d/e-v 
+        ...
+        (define-struct (name struct x) ((name field x) ...))
+        d/e-v ...
+        (in-hole d/e-ctxt ((name selector x) non-struct-value))
+        d/e ...)
+       (selector-name-match? (term struct) (term (field ...)) (term selector)))
+      (format "~a: expects argument of matching struct" (term selector)))
+     
+     ;; well-applied selector
+     (reduction
+      lang
+      (side-condition
+       ((name before d/e-v) ...
+        (define-struct (name struct x) ((name field x) ...))
+        (name middle d/e-v) ...
+        (in-hole (name ctxt d/e-ctxt) ((name selector x) ((name maker maker) (name arg v) ...)))
+        (name after d/e) ...)
+       (and (maker-name-match? (term struct) (term maker))
+            (selector-name-match? (term struct) (term (field ...)) (term selector))))
+      (term 
+       (before ...
+        (define-struct struct (field ...))
+        middle ...
+        (in-hole ctxt
+                 ,(list-ref (term (arg ...)) 
+                            (struct-index (term struct) 
+                                          (term (field ...))
+                                          (term selector))))
+        after ...)))))
+
+  (define (defined? f befores)
+    (ormap
+     (lambda (before)
+       (match before
+         [`(define (,a-name ,@(x ...)) ,b)
+          (eq? f a-name)]
+         [`(define ,a-name (lambda ,@(x ...)))
+          (eq? f a-name)]
+         [`(define-struct ,struct-name (,@(fields ...)))
+          (or (ormap (lambda (field)
+                       (eq? f (string->symbol (format "~a-~a" struct-name field))))
+                     fields)
+              (eq? f (string->symbol (format "make-~a" struct-name)))
+              (eq? f (string->symbol (format "~a?" struct-name))))]
+         [else #t]))
+     befores))
+  
+  (define (multi-subst vars args body)
+    (let loop ([args args]
+               [vars vars]
+               [body body])
+      (cond
+        [(and (null? args) (null? vars))
+         body]
+        [(or (null? args) (null? vars))
+         (error 'multi-subst "malformed program")]
+        [else (loop (cdr args) 
+                    (cdr vars)
+                    (beg-e-subst (car vars) (car args) body))])))
+
+  (define (selector-name-match? struct fields selector)
+    (ormap (lambda (field) (string=? (format "~a-~a" struct field) 
+                                     (symbol->string selector)))
+           fields))
+  
+  (define (struct-index struct init-fields selector)
+    (let loop ([i 0]
+               [fields init-fields])
+      (cond
+        [(null? fields) (error 'struct-index "~s ~s ~s" struct init-fields selector)]
+        [else (let ([field (car fields)])
+                (if (string=? (format "~a-~a" struct field) 
+                              (symbol->string selector))
+                    i
+                    (loop (+ i 1)
+                          (cdr fields))))])))
+  
+  (define (maker-name-match? name maker)
+    (let* ([names (symbol->string name)]
+           [makers (symbol->string maker)]
+           [namel (string-length names)]
+           [makerl (string-length makers)])
+      (and (makerl . > . namel)
+           (string=? (substring makers (- makerl namel) makerl)
+                     names))))
+  
+  (define (predicate-name-match? name predicate)
+    (eq? (string->symbol (format "~a?" name)) predicate))
+
+  (define failed-tests 0)
+  (define total-tests 0)
+  
+  (define (test in out)
+    (set! total-tests (+ total-tests 1))
+    (let/ec k
+      (let* ([failed
+              (lambda (msg)
+                (set! failed-tests (+ failed-tests 1))
+                (fprintf (current-error-port) "FAILED: ~a\n" msg)
+                (k (void)))]
+             [got (normalize in failed)])
+        (unless (equal? got out)
+          (fprintf (current-error-port) "FAILED:   ~s\ngot:      ~s\nexpected: ~s\n" in got out)
+          (set! failed-tests (+ failed-tests 1))))))
+  
+  (define (test-all step . steps)
+    (set! total-tests (+ total-tests 1))
+    (let loop ([this step]
+               [rest steps])
+      (let ([nexts (reduce reductions this)])
+        (cond
+          [(null? rest)
+           (unless (null? nexts)
+             (set! failed-tests (+ failed-tests 1))
+             (fprintf (current-error-port) "FAILED: ~s\n  last step: ~s\n  reduced to: ~s\n"
+                      step
+                      this
+                      nexts))]
+          [else
+           (cond
+             [(and (pair? nexts)
+                   (null? (cdr nexts)))
+              (let ([next (car nexts)])
+                (if (equal? next (car rest))
+                    (loop (car rest)
+                          (cdr rest))
+                    (begin
+                      (set! failed-tests (+ failed-tests 1))
+                      (fprintf (current-error-port) 
+                               "FAILED: ~s\n     step: ~s\n expected: ~s\n      got: ~s\n"
+                               step
+                               this
+                               (car rest)
+                               next))))]
+             [else
+              (set! failed-tests (+ failed-tests 1))
+              (fprintf (current-error-port)
+                       "FAILED: ~s\n  step: ~s\n  not single step: ~s\n"
+                       step
+                       this
+                       nexts)])]))))
+    
+  (define show-dots (make-parameter #f))
+  (define (normalize term failed)
+    (let loop ([term term]
+               [n 1000])
+      (unless (p? term)
+        (failed (format "not a p: ~s" term)))
+      (let ([nexts (reduce reductions term)])
+        (when (show-dots)
+          (display #\.)
+          (flush-output))
+        (cond
+          [(= n 0)
+           (when (show-dots)
+             (newline))
+           (error 'normalize "found too many reductions")]
+          [(null? nexts) 
+           (when (show-dots)
+             (newline))
+           term]
+          [(string? (car nexts))
+           (when (show-dots)
+             (newline))
+           (car nexts)]
+          [(null? (cdr nexts)) (loop (car nexts) (- n 1))]
+          [else 
+           (when (show-dots)
+             (newline))
+           (failed (format "found more than one reduction\n ~s\n ->\n~s" term nexts))]))))
+
+  (define (show-test-results)
+    (cond
+      [(= failed-tests 0) 
+       (fprintf (current-error-port) "passed all ~a tests\n" total-tests)]
+      [else
+       (fprintf (current-error-port) "failed ~a out of ~a tests\n" failed-tests total-tests)]))
+  
+  (define-syntax (tests stx)
+    (syntax-case stx ()
+      [(_ args ...)
+       (syntax
+        (begin
+          (set! failed-tests 0)
+          (set! total-tests 0)
+          args ...
+          (show-test-results)))]))
+  
+  (define (run-tests)
+    (tests
+     (test
+      '((define-struct s ())
+        (s? (make-s)))
+      '((define-struct s ())
+        true))
+     
+     (test
+      '((define-struct s (a b))
+        (s-a (make-s 1 3)))
+      '((define-struct s (a b))
+        1))
+     
+     (test
+      '((define-struct s (a b))
+        (s-b (make-s 1 3)))
+      '((define-struct s (a b))
+        3))
+     
+     (test
+      '((define-struct s (a b))
+        (define-struct t (x y))
+        (t-x (make-s 1 2)))
+      "t-x: expects argument of matching struct")
+     
+     (test
+      '((define-struct t (x y))
+        (t-x 12))
+      "t-x: expects argument of matching struct")
+     
+     (test
+      '((define-struct s (a b))
+        (define-struct t (x y))
+        (s? (make-s 1 2)))
+      '((define-struct s (a b))
+        (define-struct t (x y))
+        true))
+     
+     (test
+      '((define-struct s (a b))
+        (define-struct t (x y))
+        (t? (make-s 1 2)))
+      '((define-struct s (a b))
+        (define-struct t (x y))
+        false))
+     
+     (test
+      '((define-struct s (a b))
+        (struct? (make-s 1 2))
+        (struct? 1))
+      '((define-struct s (a b))
+        true
+        false))
+     
+     (test
+      '((define (f x) x)
+        (f 1))
+      '((define (f x) x)
+        1))
+     
+     (test
+      '((define (double l) (+ l l))
+        (double 2))
+      '((define (double l) (+ l l))
+        4))
+     
+     (test
+      '((define f (lambda (x) x))
+        (f 1))
+      '((define f (lambda (x) x))
+        1))
+     
+     (test
+      '((define double (lambda (l) (+ l l)))
+        (double 2))
+      '((define double (lambda (l) (+ l l)))
+        4))
+     
+     (test
+      '((f 1))
+      "reference to undefined identifier: f")
+     
+     (test
+      '((f 1)
+        (define (f x) x))
+      "reference to undefined identifier: f")
+     
+     (test
+      '((make-s 1)
+        (define-struct s (a b)))
+      "reference to undefined identifier: make-s")
+     
+     (test
+      '((+ 1 2 3))
+      '(6))
+     
+     (test
+      '((+ 1 "2" 3))
+      "+: expects type <number>")
+     
+     (test
+      '((/ 1 2 3))
+      '(1/6))
+     
+     (test
+      '((/ 1 2 0 3))
+      "/: division by zero")
+     
+     (test
+      '((/ 1 "2" 3))
+      "/: expects type <number>")
+     
+     (test '((+ 1 (/ (+ 3 5) (+ 2 2)))) '(3))
+
+     (test '((symbol=? 'x 'x)) '(true))
+     (test '((symbol=? 'x 'y)) '(false))
+     (test '((symbol=? 1 'x)) 
+           "symbol=?: expects argument of type <symbol>")
+     (test '((symbol=? 'x 1)) 
+           "symbol=?: expects argument of type <symbol>")
+     
+     (test '((cons 1 empty)) '((cons 1 empty)))
+     (test '((cons 1 2))
+           "cons: second argument must be of type <list>")
+     (test '((+ (first (cons 1 2)) 2))
+           "cons: second argument must be of type <list>")
+     (test '((+ (first (cons 1 empty)) 2))
+           '(3))
+     
+     (test
+      '((first (cons 1 empty)))
+      '(1))
+     
+     (test
+      '((first 1))
+      "first: expects argument of type <pair>")
+     
+     (test
+      '((first 1 2))
+      "first: expects one argument")
+     
+     (test
+      '((first))
+      "first: expects one argument")
+     
+     (test
+      '((rest (cons 1 empty)))
+      '(empty))
+     
+     (test
+      '((rest 1))
+      "rest: expects argument of type <pair>")
+     
+     (test
+      '((rest 1 2))
+      "rest: expects one argument")
+     
+     (test
+      '((rest))
+      "rest: expects one argument")
+     
+     (test
+      '((empty? empty))
+      '(true))
+     
+     (test
+      '((empty? 1))
+      '(false))
+     
+     (test
+      '((empty?))
+      "empty?: expects one argument")
+     
+     (test
+      '((empty? 1 2))
+      "empty?: expects one argument")
+     
+     (test
+      '((cond [true 1]))
+      '(1))
+     
+     (test
+      '((cond [else 1]))
+      '(1))
+     
+     (test-all
+      '((cond [false 1] [else 2]))
+      '(2))
+     
+     (test-all
+      '((cond [false 1] [false 2]))
+      "cond: all question results were false")
+     
+     (test
+      '((cond [1 1]))
+      "cond: question result is not true or false")
+     
+     (test
+      '((cond [(empty? empty) 'infinite] [else 3]))
+      '('infinite))
+     
+     (test-all
+      '((cond [(if false false false) 'x] [(if true true true) 'y] [(if false false false) 'z]))
+      '((cond [false 'x] [(if true true true) 'y] [(if false false false) 'z]))
+      '((cond [false 'x] [true 'y] [(if false false false) 'z]))
+      '('y))
+     
+     (test-all
+      '((cond [(if false false false) 'x] [(if true true true) 'y] [else 'z]))
+      '((cond [false 'x] [(if true true true) 'y] [else 'z]))
+      '((cond [false 'x] [true 'y] [else 'z]))
+      '('y))
+     
+     (test-all
+      '((cond [(if false false false) 'x] [(if false false false) 'y] [else 'z]))
+      '((cond [false 'x] [(if false false false) 'y] [else 'z]))
+      '((cond [false 'x] [false 'y] [else 'z]))
+      '('z))
+     
+     (test-all
+      '((and true true 3))
+      "and: question result is not true or false")
+     
+     (test-all
+      '((and 1 true true))
+      "and: question result is not true or false")
+     
+     (test-all
+      '((and true true true false))
+      '(false))
+     
+     (test-all
+      '((and false true))
+      '(false))
+     
+     (test-all
+      '((or false false 3))
+      "or: question result is not true or false")
+     
+     (test-all
+      '((or 1 false false))
+      "or: question result is not true or false")
+     
+     (test-all
+      '((or false false false true))
+      '(true))
+     
+     (test-all
+      '((or true false))
+      '(true))
+     
+     (test-all
+      '((or (if false false false) (if false false false) (if true true true) (if false false false)))
+      '((or false (if false false false) (if true true true) (if false false false)))
+      '((or false false (if true true true) (if false false false)))
+      '((or false false true (if false false false)))
+      '(true))
+     
+     (test-all
+      '((and (if true true true) (if true true true) (if false false false) (if true true true)))
+      '((and true (if true true true) (if false false false) (if true true true)))
+      '((and true true (if false false false) (if true true true)))
+      '((and true true false (if true true true)))
+      '(false))
+     
+     (test
+      '((if 1 2 3))
+      "if: question result is not true or false")
+     
+     (test
+      '((if true 'x 'y))
+      '('x))
+     
+     (test
+      '((if false 'x 'y))
+      '('y))
+     
+     ; test non-procedure-defs in context:
+     (test
+      `((+ 3 4) (define a 3) (+ 5 6))
+      `(7 (define a 3) 11))
+     
+     ; test reduction of non-procedure-defs:
+     (test 
+      `((define a 13) (define b (+ a 9)) (+ 3 4))
+      `((define a 13) (define b 22) 7))
+     
+     ; test reduction of unbound ids in hole:
+     (test 
+      `(x)
+      "reference to undefined identifier: x")
+     
+     ; test reduction of function-bound id in hole:
+     (test
+      `((define (a x) (+ x 1)) a)
+      "a is a procedure, so it must be applied to arguments")
+     
+     ; test reduction of non-procedure-def in application:
+     (test
+      `((define a 3) (a 9))
+      "procedure application: expected procedure, given: 3")))
+  
+
+  (define (run-big-test)
+    (parameterize ([show-dots #t])
+      (tests
+       (test
+        '((define-struct pr (hd tl))
+          (define (avg l)
+            (cond
+              [(empty? l) 'infinite]
+              [else (/ (sum l) (howmany/acc l 0))]))
+          (define (sum l)
+            (cond
+              [(empty? (pr-tl l)) (pr-hd l)]
+              [else (+ (pr-hd l) (sum (pr-tl l)))]))
+          (define (howmany/acc l acc)
+            (cond
+              [(empty? l) acc]
+              [else (howmany/acc (pr-tl l) (+ acc 1))]))
+          (avg empty)
+          (avg (make-pr 3 (make-pr 4 (make-pr 5 empty)))))
+        '((define-struct pr (hd tl))
+          (define (avg l)
+            (cond
+              [(empty? l) 'infinite]
+              [else (/ (sum l) (howmany/acc l 0))]))
+          (define (sum l)
+            (cond
+              [(empty? (pr-tl l)) (pr-hd l)]
+              [else (+ (pr-hd l) (sum (pr-tl l)))]))
+          (define (howmany/acc l acc)
+            (cond
+              [(empty? l) acc]
+              [else (howmany/acc (pr-tl l) (+ acc 1))]))
+          'infinite
+          4))
+       (test
+        '((define (contains-sym? s l)
+            (cond
+              [(empty? l) false]
+              [true (or (symbol=? s (first l))
+                        (contains-sym? s (rest l)))]))
+          (contains-sym? 'x (cons 'z (cons 'y (cons 'x empty))))
+          (contains-sym? 'a (cons 'p (cons 'q empty))))
+        '((define (contains-sym? s l)
+            (cond
+              [(empty? l) false]
+              [true (or (symbol=? s (first l))
+                        (contains-sym? s (rest l)))]))
+          true
+          false))))))
diff --git a/collects/reduction-semantics/examples/church.ss b/collects/reduction-semantics/examples/church.ss
new file mode 100644
index 0000000000..6da6534036
--- /dev/null
+++ b/collects/reduction-semantics/examples/church.ss
@@ -0,0 +1,63 @@
+(module church mzscheme
+  (require "../reduction-semantics.ss"
+           "../gui.ss"
+           "../subst.ss")
+  
+  (reduction-steps-cutoff 100)
+  
+  (define lang
+    (language (e (lambda (x) e)
+                 (let (x e) e)
+                 (app e e)
+                 (+ e e)
+                 number
+                 x)
+              (e-ctxt (lambda (x) e-ctxt)
+                      a-ctxt)
+              (a-ctxt (let (x a-ctxt) e)
+                      (app a-ctxt e)
+                      (app x a-ctxt)
+                      hole)
+              (v (lambda (x) e)
+                 x)
+              (x variable)))
+  
+  (define reductions
+    (list
+     (reduction/context lang
+                        e-ctxt
+                        (app (lambda (x_1) e_body) e_arg)
+                        (ch-subst (term x_1) (term e_arg) (term e_body)))
+     (reduction/context lang
+                        e-ctxt
+                        (let (x_1 v_1) e_1)
+                        (ch-subst (term x_1) (term v_1) (term e_1)))))
+  
+  (define ch-subst
+    (subst
+     [`(let (,x ,v) ,b)
+      (all-vars (list x))
+      (build (lambda (vars v b) `(let (,(car vars) ,v) ,b)))
+      (subterm '() v)
+      (subterm (list x) b)]
+     [`(app ,f ,x)
+      (all-vars '())
+      (build (lambda (vars f x) `(app ,f ,x)))
+      (subterm '() f)
+      (subterm '() x)]
+     [`(lambda (,x) ,b)
+      (all-vars (list x))
+      (build (lambda (vars body) `(lambda (,(car vars)) ,body)))
+      (subterm (list x) b)]
+     [(? number?) (constant)]
+     [(? symbol?) (variable)]))
+      
+  
+  (traces lang reductions
+       '(let (plus (lambda (m) 
+                     (lambda (n) 
+                       (lambda (s)
+                         (lambda (z)
+                           (app (app m s) (app (app n s) z)))))))
+          (let (two (lambda (s) (lambda (z) (app s (app s z)))))
+            (app (app plus two) two)))))
\ No newline at end of file
diff --git a/collects/reduction-semantics/examples/combinators.ss b/collects/reduction-semantics/examples/combinators.ss
new file mode 100644
index 0000000000..532fec589b
--- /dev/null
+++ b/collects/reduction-semantics/examples/combinators.ss
@@ -0,0 +1,83 @@
+;"one point basis"
+;"formal aspects of computing"
+
+(module combinators mzscheme
+  (require "../reduction-semantics.ss"
+           "../gui.ss")
+  
+  (initial-font-size 12)
+  (reduction-steps-cutoff 100)
+  (initial-char-width 80)
+  
+  (define lang
+    (language 
+     (e (e e)
+        comb
+        abs1
+        abs2
+        abs3)
+     (e-ctxt (e e-ctxt)
+             (e-ctxt e)
+             hole)
+     (comb i
+           j
+           b
+           c
+           c*
+           w)))
+  
+  (define ij-reductions
+    (list
+     (reduction/context lang
+                        e-ctxt
+                        (i e_1)
+                        (term e_1))
+     (reduction/context lang
+                        e-ctxt
+                        ((((j e_a) e_b) e_c) e_d)
+                        (term ((e_a e_b) ((e_a e_d) e_c))))))
+  
+  (define reductions
+    (append
+     ij-reductions
+     (list
+      (reduction/context lang
+                         e-ctxt
+                         (((b e_m) e_n) e_l)
+                         (term (e_m (e_n e_l))))
+      (reduction/context lang
+                         e-ctxt
+                         (((c e_m) e_n) e_l)
+                         (term ((e_m e_l) e_n)))
+      (reduction/context lang
+                         e-ctxt
+                         ((c* e_a) e_b)
+                         (term (e_b e_a)))
+      (reduction/context lang
+                         e-ctxt
+                         ((w e_a) e_b)
+                         (term ((e_a e_b) e_b))))))
+
+  
+  (define c* `((j i) i))
+  (define (make-c c*) `(((j ,c*) (j ,c*)) (j ,c*)))
+  (define (make-b c) `((,c ((j i) ,c)) (j i)))
+  (define (make-w b c c*) `(,c ((,c ((,b ,c) ((,c ((,b j) ,c*)) ,c*))) ,c*)))
+  (define (make-s b c w) `((,b ((,b (,b ,w)) ,c)) (,b ,b)))
+
+  (traces/multiple lang
+                reductions
+                (list 
+                 `((,c* abs1) abs2)
+                 `(((,(make-c 'c*) abs1) abs2) abs3)
+                 `(((,(make-b 'c) abs1) abs2) abs3)
+                 `((,(make-w 'b 'c 'c*) abs1) abs2)
+                 `(((,(make-s 'b 'c 'w) abs1) abs2) abs3)))
+  
+  ;; s in terms of i and j ( > 18,000 reductions and probably still long way to go)
+  '(traces lang ij-reductions
+       (make-s (make-b (make-c c*))
+               (make-c c*)
+               (make-w (make-b (make-c c*))
+                       (make-c c*)
+                       c*))))
diff --git a/collects/reduction-semantics/examples/control.ss b/collects/reduction-semantics/examples/control.ss
new file mode 100644
index 0000000000..3b1fddc258
--- /dev/null
+++ b/collects/reduction-semantics/examples/control.ss
@@ -0,0 +1,81 @@
+(module control mzscheme
+  (require "../reduction-semantics.ss"
+           "../gui.ss"
+           "../subst.ss")
+  
+  (reduction-steps-cutoff 100)
+  
+  (define lang
+    (language (e (e e)
+                 (\# e)
+                 (f e)
+                 variable
+                 (+ e e)
+                 v)
+              (c (v c)
+                 (c e)
+                 (\# c)
+                 (f c)
+                 (+ v c)
+                 (+ c e)
+                 hole)
+              (c# (v c#)
+                  (c# e)
+                  (f c#)
+                  (+ v c#)
+                  (+ c# e)
+                  hole)
+              (v (lambda (variable) e)
+                 number)))
+  
+  (define reductions
+    (list
+     (reduction lang
+                (in-hole c_1 (\# (in-hole c#_1 (f v_1))))
+                (term-let ([x (variable-not-in (term c#) 'x)])
+                  (term
+                   (in-hole c_1
+                            (v_1 (lambda (x) (in-hole c#_1 x)))))))
+     (reduction lang
+                (in-hole c#_1 (f v_1))
+                (term-let ([x (variable-not-in (term c#_1) 'x)])
+                  (term (v_1 (lambda (x) (in-hole c#_1 x))))))
+     (reduction/context lang
+                        c
+                        ((lambda (variable_x) e_body) v_arg)
+                        (lc-subst (term variable_x) (term v_arg) (term e_body)))
+     (reduction/context lang
+                        c
+                        (+ number_1 number_2)
+                        (+ (term number_1) (term number_2)))))
+  
+  (define lc-subst
+    (subst
+     [`(\# ,e)
+      (all-vars '())
+      (build (lambda (vars body) `(\# ,body)))
+      (subterm '() e)]
+     [`(f ,e)
+      (all-vars '())
+      (build (lambda (vars body) `(f ,body)))
+      (subterm '() e)]
+     [`(+ ,e1 ,e2)
+      (all-vars '())
+      (build (lambda (vars e1 e2) `(+ ,e1 ,e2)))
+      (subterm '() e1)
+      (subterm '() e2)]
+     [(? symbol?) (variable)]
+     [(? number?) (constant)]
+     [`(lambda (,x) ,b)
+      (all-vars (list x))
+      (build (lambda (vars body) `(lambda (,(car vars)) ,body)))
+      (subterm (list x) b)]
+     [`(,f ,x)
+      (all-vars '())
+      (build (lambda (vars f x) `(,f ,x)))
+      (subterm '() f)
+      (subterm '() x)]))
+      
+  (traces/multiple lang reductions
+                (list '(+ 1 (+ 2 (f (lambda (d) (d (d 0))))))
+                      '(+ 1 (\# (+ 2 (f (lambda (d) (d (d 0))))))))))
\ No newline at end of file
diff --git a/collects/reduction-semantics/examples/eta.ss b/collects/reduction-semantics/examples/eta.ss
new file mode 100644
index 0000000000..ad62cecc36
--- /dev/null
+++ b/collects/reduction-semantics/examples/eta.ss
@@ -0,0 +1,72 @@
+(module eta mzscheme
+  (require "../reduction-semantics.ss"
+           "../gui.ss"
+           "../subst.ss")
+  
+  (reduction-steps-cutoff 100)
+  
+  (define lang
+    (language (e (e e)
+                 x
+                 (+ e e)
+                 v)
+              (c (v c)
+                 (c e)
+                 (+ v c)
+                 (+ c e)
+                 hole)
+              (v (lambda (x) e)
+                 number)
+              (x (variable-except lambda +))))
+  
+  (define reductions
+    (list
+     (reduction/context lang
+                        c
+                        ((lambda (variable_x) e_body) v_arg)
+                        (lc-subst (term variable_x) (term v_arg) (term e_body)))
+     (reduction/context lang
+                        c
+                        (+ number_1 number_2)
+                        (+ (term number_1) (term number_2)))
+     (reduction/context lang
+                        c
+                        (side-condition (lambda (variable_x) (e_fun variable_x))
+                                        (equal? (term e_fun) (lc-subst (term variable_x) 1234 (term e_fun))))
+                        (term e_fun))
+     
+     (reduction lang
+                (in-hole c (number_n v_arg))
+                (format "procedure application: expected procedure, given: ~a; arguments were: ~a" 
+                        (term number_n)
+                        (term v_arg)))
+     (reduction lang
+                (in-hole c (+ (name non-num (lambda (variable) e)) (name arg2 v)))
+                (format "+: expects type <number> as 1st argument, given: ~s; other arguments were: ~s"
+                        (term non-num) (term arg2)))
+     (reduction lang
+                (in-hole c (+ (name arg1 v) (name non-num (lambda (variable) e))))
+                (format "+: expects type <number> as 2nd argument, given: ~s; other arguments were: ~s"
+                        (term arg1) (term non-num)))))
+  
+  (define lc-subst
+    (subst
+     [(? symbol?) (variable)]
+     [(? number?) (constant)]
+     [`(lambda (,x) ,b)
+      (all-vars (list x))
+      (build (lambda (vars body) `(lambda (,(car vars)) ,body)))
+      (subterm (list x) b)]
+     [`(+ ,n2 ,n1)
+      (all-vars '())
+      (build (lambda (vars n1 n2) `(+ ,n1 ,n1)))
+      (subterm '() n1)
+      (subterm '() n2)]
+     [`(,f ,x)
+      (all-vars '())
+      (build (lambda (vars f x) `(,f ,x)))
+      (subterm '() f)
+      (subterm '() x)]))
+      
+  
+  (traces lang reductions '(+ (lambda (x) ((+ 1 2) x)) 1)))
\ No newline at end of file
diff --git a/collects/reduction-semantics/examples/future.ss b/collects/reduction-semantics/examples/future.ss
new file mode 100644
index 0000000000..e5cd8435c7
--- /dev/null
+++ b/collects/reduction-semantics/examples/future.ss
@@ -0,0 +1,123 @@
+#|
+
+This is an adaptation of Cormac Flanagan's future semantics
+to a scheme where each term only has a single hole, but
+there are multiple decompositions for each term.
+
+|#
+
+(module future mzscheme
+  (require "../reduction-semantics.ss"
+           "../gui.ss"
+           "../subst.ss")
+  
+  (define lang
+    (language
+     (state (flet (variable state) state)
+            m
+            error)
+     (m (let (variable (future m)) m)
+        (let (variable (car v)) m)
+        (let (variable (cdr v)) m)
+        (let (variable (if v m m)) m)
+        (let (variable (apply v v)) m)
+        (let (variable v) m)
+        v)
+     (v number
+        variable
+        (cons v v)
+        (lambda (variable) m))
+     
+     (e-state (flet (variable e-state) state)
+              (flet (variable state) e-state)
+              e)
+     (e hole
+        (let (variable e) m)
+        (let (variable (future e)) m))))
+  
+  (define reductions
+    (list
+     (reduction lang
+                (in-hole (name e e-state)
+                         (let (variable_1 v_val)
+                           m_exp))
+                (plug (term e)
+                      (future-subst (term variable_1) (term v_val) (term m_exp))))
+     (reduction lang
+                (in-hole (name e e-state)
+                         (let (variable_1 (car (cons v_val v)))
+                           m_exp))
+                (plug (term e) (future-subst (term variable_1)
+                                             (term v_val) 
+                                             (term m_exp))))
+     (reduction lang
+                (in-hole (name e e-state)
+                         (let (variable_1 (cdr (cons v v_val)))
+                           m_exp))
+                (plug (term e) (future-subst (term variable_1)
+                                             (term v_val)
+                                             (term m_exp))))
+     (reduction lang
+                (in-hole (name e e-state)
+                         (let (variable_1 (if true m_then m))
+                           m_exp))
+                (plug (term e) (term (let (variable_1 m_then) m_exp))))
+     (reduction lang
+                (in-hole (name e e-state)
+                         (let (variable_1 (if false m m_else))
+                           m_exp))
+                (plug (term e) (term (let (variable_1 m_else) m_exp))))
+     (reduction lang
+                (in-hole (name e e-state)
+                         (let (variable_1 
+                               (apply (lambda (variable_formal) m_body)
+                                      v_actual))
+                           m_exp))
+                (plug 
+                 (term e)
+                 (term (let (variable_1 ,(future-subst (term variable_formal) (term v_actual) (term m_body)))
+                         m_exp))))
+     (reduction lang
+                (in-hole (name e e-state)
+                         (let (variable_x (future m_1)) m_2))
+                (let ([p (variable-not-in (list (term e) (term m_1) (term m_2)) 'p)])
+                  (term (flet (,p m_1) (let (variable_x ,p) m_2)))))
+     (reduction lang
+                (flet (variable_p v_1) state_body)
+                (future-subst (term variable_p) (term v_1) (term state_body)))
+     (reduction lang
+                (flet (variable_2 (flet (variable_1 state_1) state_2))
+                      state_3)
+                (term (flet (variable_1 state_1) (flet (variable_2 state_2) state_3))))))
+  
+  (define future-subst
+    (subst
+     [`(let (,a-var ,rhs-exp) ,body-exp)
+      (all-vars (list a-var))
+      (build (lambda (vars rhs-exp body-exp) `(let (,(car vars) ,rhs-exp) ,body-exp)))
+      (subterm '() rhs-exp)
+      (subterm (list a-var) body-exp)]
+     [`(lambda (,a-var) ,exp)
+      (all-vars (list a-var))
+      (build (lambda (vars body) `(lambda (,(car vars)) ,body)))
+      (subterm (list a-var) exp)]
+     [(? number?) (constant)]
+     [(? symbol?) (variable)]
+     [`(cons ,hd ,tl)
+      (all-vars '())
+      (build (lambda (vars hd tl) `(cons ,hd ,tl)))
+      (subterm '() hd)
+      (subterm '() tl)]))
+  
+  (define (copy-sexp x) (if (pair? x) (cons (copy-sexp (car x)) (copy-sexp (cdr x))) x))
+  
+  '(traces lang reductions '(let (x (future (let (y (cons 1 2))
+                                           (let (z (car y))
+                                             z))))
+                           (let (p (cons 3 4))
+                             (let (q (car p))
+                               (cons x q)))))
+  
+  (traces lang reductions '(let (x (future (let (y 1)
+                                          y)))
+                          x)))
\ No newline at end of file
diff --git a/collects/reduction-semantics/examples/ho-contracts.ss b/collects/reduction-semantics/examples/ho-contracts.ss
new file mode 100644
index 0000000000..ca8df25827
--- /dev/null
+++ b/collects/reduction-semantics/examples/ho-contracts.ss
@@ -0,0 +1,567 @@
+
+(module ho-contracts mzscheme
+  (require "../reduction-semantics.ss"
+           "../gui.ss"
+           "../subst.ss"
+           (lib "mred.ss" "mred")
+           (lib "framework.ss" "framework")
+           (lib "class.ss")
+           (lib "match.ss")
+           (lib "list.ss"))
+  
+  (initial-font-size 7) (reduction-steps-cutoff 10)
+  ;(initial-font-size 36) (reduction-steps-cutoff 1)
+  
+  (define lang
+    (language
+     (p ((d ...) e))
+     (d (valrec x : e = e))
+     (e (lambda (x) e)
+        (e e)
+        (let ((x e) ...) e)
+        x
+        (fix x e)
+        number
+        (aop e e)
+        (rop e e)
+        (cons e e)
+        empty
+        (hd e)
+        (tl e)
+        (mt e)
+        (if e e e)
+        true
+        false
+        string
+        (--> e e)
+        (contract e)
+        (flatp e)
+        (pred e)
+        (dom e)
+        (rng e)
+        (blame e))
+     (x (variable-except valrec lambda let fix aop rop cons empty hd tl mt if true false --> contract flatp pred dom rng blame))
+     
+     (p-ctxt (((valrec x : v = v) ...
+               (valrec x : e-ctxt = e)
+               d ...)
+              e)
+             (((valrec x : v = v) ...
+               (valrec x : v = e-ctxt)
+               d ...)
+              e)
+             (((valrec x : v = v) ...)
+              e-ctxt))
+     (e-ctxt (e-ctxt e)
+             (v e-ctxt)
+             (let ((x v) ... (x e-ctxt) (x e) ...) e)
+             (aop e-ctxt e)
+             (aop v e-ctxt)
+             (rop e-ctxt e)
+             (rop v e-ctxt)
+             (cons e-ctxt e)
+             (cons v e-ctxt)
+             (hd e-ctxt)
+             (tl e-ctxt)
+             (mt e-ctxt)
+             (if e-ctxt e e)
+             (--> v e-ctxt)
+             (--> e-ctxt e)
+             (contract e-ctxt)
+             (flatp e-ctxt)
+             (pred e-ctxt)
+             (dom e-ctxt)
+             (rng e-ctxt)
+             (blame e-ctxt)
+             hole)
+     (v (cons v v)
+        (lambda (x) e)
+        string
+        number
+        true
+        false 
+        (--> v v)
+        (contract v)
+        (ob v (--> v v) x x)
+        compile-v1
+        compile-v2)
+     
+     (aop + - * /)
+     (rop = >=)))
+  
+  (define ho-contracts-subst
+    (subst
+     [`(let ([,a-vars ,rhs-exps] ...) ,body)
+      (all-vars a-vars)
+      (build (lambda (vars body . rhss) 
+               `(let (,@(map (lambda (var rhs) `[,var ,rhs]) vars rhss))
+                  ,body)))
+      (subterm a-vars body)
+      (subterms '() rhs-exps)]
+     [`(lambda (,var) ,body)
+      (all-vars (list var))
+      (build (lambda (vars body) `(lambda (,(car vars)) ,body)))
+      (subterm (list var) body)]
+     [`(fix ,variable ,e)
+      (all-vars (list variable))
+      (build (lambda (vars body) `(fix ,(car vars) ,body)))
+      (subterm (list variable) e)]
+     [(? number?) (constant)]
+     [`(,(and op (? (lambda (x) (memq x '(cons + - = > / -->))))) ,e1 ,e2)
+      (all-vars '())
+      (build (lambda (vars e1 e2) `(,op ,e1 ,e2)))
+      (subterm '() e1)
+      (subterm '() e2)]
+     [`empty (constant)]
+     [`(,(and op (? (lambda (x) (memq x '(hd tl mt contract flat pred dom rng blame))))) ,e1)
+      (all-vars '())
+      (build (lambda (vars e1) `(,op ,e1)))
+      (subterm '() e1)]
+     [`(if ,e1 ,e2 ,e3)
+      (all-vars '())
+      (build (lambda (vars e1 e2 e3) `(if ,e1 ,e2 ,e3)))
+      (subterm '() e1)
+      (subterm '() e2)
+      (subterm '() e3)]
+     [`(,e1 ,e2)
+      (all-vars '())
+      (build (lambda (vars e1 e2) `(,e1 ,e2)))
+      (subterm '() e1)
+      (subterm '() e2)]
+     [`true (constant)]
+     [`false (constant)]
+     [(? string?) (constant)]
+     [(? symbol?) (variable)]))
+  
+  (define reductions
+    (list
+     (reduction lang  
+                (in-hole (name p p-ctxt) (/ number_n number_m)) 
+                (if (= (term number_m) 0)
+                    (term (error /))
+                    (plug (term p) (/ (term number_n) (term number_m)))))
+     (reduction lang  
+                (in-hole (name p p-ctxt) (* number_n number_m))
+                (plug (term p) (* (term number_n) (term number_m))))
+     (reduction lang  
+                (in-hole (name p p-ctxt) (+ number_n number_m))
+                (plug (term p) (+ (term number_n) (term number_m))))
+     (reduction lang  
+                (in-hole (name p p-ctxt) (- number_n number_m))
+                (plug (term p) (- (term number_n) (term number_m))))
+     (reduction lang  
+                (in-hole (name p p-ctxt) (>= number_n number_m))
+                (plug (term p) (if (>= (term number_n) (term number_m)) 'true 'false)))
+     (reduction lang  
+                (in-hole (name p p-ctxt) (= number_n number_m))
+                (plug (term p) (if (= (term number_n) (term number_m)) 'true 'false)))
+     (reduction lang  
+                (in-hole (name p p-ctxt) ((lambda (variable_x) e_body) v_arg))
+                (plug (term p) (ho-contracts-subst (term variable_x) 
+                                                   (term v_arg) 
+                                                   (term e_body))))
+     (reduction lang  
+                (in-hole (name p p-ctxt) 
+                         (let ((variable_i v_i) ...) e_body))
+                (plug (term p) 
+                      (foldl
+                       ho-contracts-subst
+                       (term e_body)
+                       (term (variable_i ...))
+                       (term (v_i ...)))))
+     (reduction lang  
+                (in-hole (name p p-ctxt) (name tot (fix (name x variable) (name body e))))
+                (plug (term p) (ho-contracts-subst (term x) (term tot) (term body))))
+     (reduction lang  
+                ((name defns
+                       ((valrec (name bvar variable) : (name bctc value) = (name brhs value)) ...
+                        (valrec (name var variable) : value = (name rhs value))
+                        (valrec variable : value = value) ...))
+                 (in-hole (name p e-ctxt) (name var variable)))
+                (term (defns ,(plug (term p) (term rhs)))))
+     (reduction lang
+                (in-hole (name p p-ctxt) (if true e_then e))
+                (plug (term p) (term e_then)))
+     (reduction lang  
+                (in-hole (name p p-ctxt) (if false e e_else))
+                (plug (term p) (term e_else)))
+     (reduction lang  
+                (in-hole (name p p-ctxt) (hd (cons v_fst v)))
+                (plug (term p) (term v_fst)))
+     (reduction lang  
+                (in-hole (name p p-ctxt) (hd empty))
+                (term (error hd)))
+     (reduction lang  
+                (in-hole (name p p-ctxt) (tl (cons v v_rst)))
+                (plug (term p) (term v_rst)))
+     (reduction lang  
+                (in-hole (name p p-ctxt) (tl empty))
+                (term (error tl)))
+     (reduction lang  
+                (in-hole (name p p-ctxt) (mt empty))
+                (plug (term p) 'true))
+     (reduction lang  
+                (in-hole (name p p-ctxt) (mt (cons v v)))
+                (plug (term p) 'false))
+     (reduction lang  
+                (in-hole (name p p-ctxt) (flatp (contract v)))
+                (plug (term p) 'true))
+     (reduction lang  
+                (in-hole (name p p-ctxt) (flatp (--> v v)))
+                (plug (term p) 'false))
+     (reduction lang  
+                (in-hole (name p p-ctxt) (pred (contract v_pred)))
+                (plug (term p) (term v_pred)))
+     (reduction lang  
+                (in-hole (name p p-ctxt) (pred (--> v v)))
+                (term (error pred)))
+     (reduction lang  
+                (in-hole (name p p-ctxt) (dom (--> v_dm v)))
+                (plug (term p) (term v_dm)))
+     (reduction lang  
+                (in-hole (name p p-ctxt) (dom (contract v)))
+                (term (error dom)))
+     (reduction lang  
+                (in-hole (name p p-ctxt) (rng (--> v v_rg)))
+                (plug (term p) (term v_rg)))
+     (reduction lang  
+                (in-hole (name p p-ctxt) (rng (contract v)))
+                (term (error rng)))
+     (reduction lang  
+                (in-hole (name p p-ctxt) (blame (name x variable)))
+                (term (error x)))))
+  
+  (define (pp v port w spec)
+    (parameterize ([current-output-port port])
+      (pp-prog v spec)))
+  
+  (define (pp-prog prog spec)
+    (for-each (lambda (x) (pp-defn x spec)) (car prog))
+    (pp-expr (cadr prog) 0 spec)
+    (display "\n"))
+  
+  (define (pp-defn defn spec)
+    (let ([var (second defn)]
+          [ctc (fourth defn)]
+          [exp (sixth defn)])
+      (printf "val rec ")
+      (display var)
+      (display " : ")
+      (pp-expr ctc 0 spec)
+      (display " = ")
+      (pp-expr exp 0 spec)
+      (display "\n")))
+  
+  (define (dp/ct x)
+    (let* ([str (format "~a" x)]
+           [ct (string-length str)])
+      (display str)
+      ct))
+  
+  ;; pp-expr : sexp number (snip -> void) -> (union #f number)
+  ;; returns #f if it started a new line and a
+  ;; number if it didn't. The number indicates
+  ;; how many columns were printed
+  (define (pp-expr x nl-col text)
+    (cond
+      [(equal? x wrapbar)
+       (insert-wrapbar text)]
+      [else
+       (match x
+         [`(lambda (,v) ,e)
+          (insert-lambda text)
+          (insert-variable text v)
+          (dp/ct ". ")
+          (next-line (+ nl-col 2))
+          (pp-expr e (+ nl-col 2) text)
+          #f]
+         [`(let ((,vs ,rhss) ...) ,body)
+          (insert-bold text "let")
+          (dp/ct " ")
+          (insert-variable text (car vs))
+          (dp/ct " = ")
+          (pp-expr (car rhss) (+ nl-col (string-length (format "let "))) text)
+          (for-each (lambda (v rhs)
+                      (next-line (+ nl-col (string-length (format "let "))))
+                      (insert-variable text v)
+                      (dp/ct " = ")
+                      (pp-expr rhs (+ nl-col (string-length (format "let "))) text))
+                    (cdr vs)
+                    (cdr rhss))
+          (next-line (+ nl-col 2))
+          (pp-expr body (+ nl-col 2) text)
+          #f]
+         [`(fix ,v ,e)
+          (insert-bold text "fix")
+          (dp/ct " ")
+          (dp/ct v)
+          (dp/ct ". ")
+          (next-line (+ nl-col 2))
+          (pp-expr e (+ nl-col 2) text)
+          #f]
+         [`(if ,e1 ,e2 ,e3)
+          (insert-bold text "if")
+          (dp/ct " ")
+          (pp-expr e1 (+ nl-col 3) text)
+          (next-line (+ nl-col 2))
+          (insert-bold text "then")
+          (dp/ct " ")
+          (pp-expr e2 (+ nl-col 2 5) text)
+          (next-line (+ nl-col 2))
+          (insert-bold text "else")
+          (dp/ct " ")
+          (pp-expr e3 (+ nl-col 2 5) text)
+          #f]
+         [`(,e1 ,e2)
+          (let* ([fst-res
+                  (cond
+                    [(simple? e1)
+                     (pp-expr e1 nl-col text)]
+                    [else
+                     (comb (dp/ct "(")
+                           (pp-expr e1 (+ nl-col 1) text)
+                           (dp/ct ")"))])]
+                 [break-lines?
+                  (or (not fst-res)
+                      (>= fst-res 10))]
+                 [_ (when break-lines?
+                      (next-line nl-col))]
+                 [snd-res
+                  (cond
+                    [(simple? e2)
+                     (comb
+                      (dp/ct " ")
+                      (pp-expr e2 
+                               (if break-lines?
+                                   (+ nl-col 1)
+                                   (+ fst-res nl-col 1))
+                               text))]
+                    [else
+                     (comb (dp/ct " (")
+                           (pp-expr e2 
+                                    (if break-lines?
+                                        (+ nl-col 2)
+                                        (+ nl-col fst-res 2))
+                                    text)
+                           (dp/ct ")"))])])
+              (comb
+               fst-res
+               snd-res))]
+         [`(,biop ,e1 ,e2)
+          (let* ([fst-res
+                  (cond
+                    [(simple? e1)
+                     (pp-expr e1 nl-col text)]
+                    [else
+                     (comb
+                      (dp/ct "(")
+                      (pp-expr e1 (+ nl-col 1) text)
+                      (dp/ct ")"))])]
+                 [spc1 (if fst-res
+                           (dp/ct " ")
+                           (begin (next-line nl-col)
+                                  #f))]
+                 [middle 
+                  (case biop
+                    [(cons) (dp/ct "::")]
+                    [(-->) 
+                     (insert-symbol text (string (integer->char 174)))
+                     1]
+                    [else (dp/ct biop)])]
+                 [spc2 (if fst-res
+                           (dp/ct " ")
+                           (begin (next-line nl-col)
+                                  #f))]
+                 [snd-res
+                  (cond
+                    [(simple? e2) 
+                     (pp-expr e2 
+                              (if fst-res
+                                  (+ nl-col fst-res spc1 middle spc2)
+                                  nl-col)
+                              text)]
+                    [else
+                     (comb
+                      (dp/ct "(")
+                      (pp-expr e2 
+                               (if fst-res
+                                   (+ nl-col fst-res spc1 middle spc2 1)
+                                   (+ nl-col 1))
+                               text)
+                      (dp/ct ")"))])])
+            (comb fst-res
+                  spc1
+                  middle
+                  spc2
+                  snd-res))]
+         [`compile-v1
+          (insert-compile text "V" "1")]
+         [`compile-v2
+          (insert-compile text "V" "2")]
+         [`compile-e
+          (insert-compile text "e" #f)]
+         [`empty 
+          (dp/ct "[]")]
+         [(? (lambda (x) 
+               (and (symbol? x)
+                    (memq x keywords))))
+          (insert-bold text (symbol->string x))]
+         [(? symbol?)
+          (insert-variable text x)]
+         [else 
+          (dp/ct (format "~s" x))])]))
+  
+  (define keywords '(contract pred dom rng flatp error blame true false))
+
+  (define (insert-lambda text)
+    (insert-symbol text "l "))
+
+  (define (insert-compile text arg subscript)
+    (let ([sd (make-object style-delta% 'change-family 'script)]
+          [b-sd (make-object style-delta% 'change-family 'script)])
+      (send b-sd set-delta 'change-bold)
+      (+ (insert/style text "C" b-sd)
+         (insert/snip text (make-object sub-snip% "e"))
+         (insert/style text "(" sd)
+         (insert/style text arg #f)
+         (if subscript
+             (insert/snip text (make-object sub-snip% subscript))
+             0)
+         (insert/style text ")" sd))))
+
+  (define (insert-wrapbar text)
+    (send text insert (make-object wrap-bar%)
+          (send text last-position)
+          (send text last-position))
+    4)
+  
+  (define (insert-symbol text str)
+    (insert/style text str (make-object style-delta% 'change-family 'symbol)))
+  
+  (define (insert-bold text str)
+    (insert/style text str (make-object style-delta% 'change-bold))
+    (string-length str))
+  
+  (define (insert-variable text sym)
+    (let ([d (make-object style-delta%)]
+          [str (symbol->string sym)])
+      (send d set-delta-foreground "forest green")
+      (insert/style text str d)
+      (string-length str)))
+    
+  (define wrap-bar%
+    (class snip%
+      (inherit get-style)
+      (define/override (get-extent dc x y wb hb db ab lspace rspace)
+        (set-box/f lspace 0)
+        (set-box/f rspace 0)
+        (let-values ([(w h d a) (send dc get-text-extent "wrap"
+                                      (send (get-style) get-font))])
+          (set-box/f wb w)
+          (set-box/f hb h)
+          (set-box/f db d)
+          (set-box/f ab a)))
+      
+      (define/override (draw dc x y left top right bottom dx dy draw-caret?)
+        (let-values ([(w h d a) (send dc get-text-extent "wrap")])
+          (send dc draw-text "wrap" x y)
+          (send dc draw-line x (+ y 1) (+ x w -1) (+ y 1))))
+      
+      (super-instantiate ())))
+
+  (define sub-snip%
+    (class snip%
+      (init-field str)
+      (inherit get-style)
+      (define/override (get-extent dc x y wb hb db ab lspace rspace)
+        (set-box/f lspace 0)
+        (set-box/f rspace 0)
+        (let-values ([(w h d a) (send dc get-text-extent str
+                                      (send (get-style) get-font))])
+          (set-box/f wb w)
+          (set-box/f hb (+ h (floor (/ h 3))))
+          (set-box/f db (- (+ h (floor (/ h 3)))
+                           (- h d)))
+          (set-box/f ab a)))
+      
+      (define/override (draw dc x y left top right bottom dx dy draw-caret?)
+        (let-values ([(w h d a) (send dc get-text-extent str)])
+          (send dc draw-text str x (+ y (floor (/ h 3))))))
+      
+      (super-instantiate ())))
+  
+  (define (set-box/f b v) (when (box? b) (set-box! b v)))
+  
+  ;; insert/snip : text snip -> number
+  ;; returns an approximation to the width of what was inserted
+  (define (insert/snip text snip)
+    (send text insert snip (send text last-position) (send text last-position))
+    1)
+  
+  ;; insert/style : text string style-delta% -> number
+  ;; returns the number of characters in the string
+  ;; (an approximation to the width of what was inserted)
+  (define (insert/style text str sd)
+    (let ([pos (send text last-position)])
+      (send text insert str pos pos)
+      (when sd
+        (send text change-style 
+              sd
+              pos
+              (send text last-position)))
+      (string-length str)))
+  
+  ;; comb : (union #f number) *-> (union #f number)
+  ;; sums up its arguments, unless it gets #f,
+  ;; in which case it returns #f
+  (define (comb . x)
+    (if (memq #f x)
+        #f
+        (apply + x)))
+  
+  ;; simple : any -> bool
+  ;; determines if an expression need parenthesis
+  (define (simple? exp)
+    (or (not (pair? exp))
+        (equal? exp wrapbar)))
+  
+  ;; next-line : number -> void
+  ;; dp/cts a newline and indents to the proper place
+  (define (next-line n)
+    (dp/ct "\n")
+    (let loop ([n n])
+      (unless (zero? n)
+        (dp/ct " ")
+        (loop (- n 1)))))
+  
+  (define wrapbar
+    `(fix
+      wrap
+      (lambda (ct)
+        (lambda (x)
+          (lambda (p)
+            (lambda (n)
+              (if (flatp ct)
+                  (if ((pred ct) x)
+                      x
+                      (blame p))
+                  (let ((d (dom ct))
+                        (r (rng ct)))
+                    (lambda (y)
+                      ((((wrap r)
+                         (x ((((wrap d) y) n) p)))
+                        p)
+                       n))))))))))
+  
+  (define flat-case
+    `(();; defns...
+      ((((,wrapbar (contract compile-v2)) compile-v1) "p") "n")))
+  
+  (define ho-case
+    `(();; defns...
+      ((((,wrapbar (--> compile-v1 compile-v2)) (lambda (x) compile-e)) "p") "n")))
+  
+  
+  (traces lang reductions flat-case pp)
+  (traces lang reductions ho-case pp)
+  )
diff --git a/collects/reduction-semantics/examples/info.ss b/collects/reduction-semantics/examples/info.ss
new file mode 100644
index 0000000000..8e947b6c8e
--- /dev/null
+++ b/collects/reduction-semantics/examples/info.ss
@@ -0,0 +1,2 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Reduction Semantics examples"))
diff --git a/collects/reduction-semantics/examples/iswim.ss b/collects/reduction-semantics/examples/iswim.ss
new file mode 100644
index 0000000000..e47cfc1a09
--- /dev/null
+++ b/collects/reduction-semantics/examples/iswim.ss
@@ -0,0 +1,255 @@
+(module iswim mzscheme
+  (require (lib "reduction-semantics.ss" "reduction-semantics")
+           (lib "subst.ss" "reduction-semantics")
+	   (lib "contract.ss"))
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; Expression grammar:
+  
+  (define iswim-grammar
+    (language (M (M M)
+		 (o1 M)
+		 (o2 M M)
+		 V
+		 ("letcc" X M)
+		 ("cc" M M))
+	      (V X
+		 ("lam" variable M)
+		 b
+		 ("[" M "]"))
+	      (X variable)
+	      (b number)
+	      (o1 "add1" "sub1" "iszero")
+	      (o2 "+" "-" "*" "^")
+	      (on o1 o2)
+	      
+	      ;; Evaluation contexts:
+	      (E hole
+		 (E M)
+		 (V E)
+		 (o1 E)
+		 (o2 E M)
+		 (o2 V E)
+		 ("cc" E M)
+		 ("cc" V E))
+
+	      ;; Continuations (CK machine):
+	      (k "mt"
+		 ("fun" V k)
+		 ("arg" M k)
+		 ("narg" (V ... on) (M ...) k))
+
+	      ;; Environments and closures (CEK):
+	      (env ((X = vcl) ...))
+	      (cl (M : env))
+	      (vcl (V- : env))
+	      
+	      ;; Values that are not variables:
+	      (V- ("lam" variable M)
+		  b)
+
+	      ;; Continuations with closures (CEK):
+	      (k- "mt"
+		  ("fun" vcl k-)
+		  ("arg" cl k-)
+		  ("narg" (vcl ... on) (cl ...) k-))))
+
+  (define M? (language->predicate iswim-grammar 'M))
+  (define V? (language->predicate iswim-grammar 'V))
+  (define o1? (language->predicate iswim-grammar 'o1))
+  (define o2? (language->predicate iswim-grammar 'o2))
+  (define on? (language->predicate iswim-grammar 'on))
+  (define k? (language->predicate iswim-grammar 'k))
+
+  (define env? (language->predicate iswim-grammar 'env))
+  (define cl? (language->predicate iswim-grammar 'cl))
+  (define vcl? (language->predicate iswim-grammar 'vcl))
+  (define k-? (language->predicate iswim-grammar 'k-))
+
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; Substitution:
+  
+  ;; The subst form makes implemention of capture-avoiding
+  ;; easier. We just have to describe how variables bind
+  ;; in our language's forms.
+  
+  (define iswim-subst/backwards
+    (subst
+     [(? symbol?) (variable)]
+     [(? number?) (constant)]
+     [`("lam" ,X ,M)
+      (all-vars (list X))
+      (build (lambda (X-list M) `("lam" ,(car X-list) ,M)))
+      (subterm (list X) M)]
+     [`(,(and o (or "add1" "sub1" "iszero")) ,M1)
+      (all-vars '())
+      (build (lambda (vars M1) `(,o ,M1)))
+      (subterm '() M1)]
+     [`(,(and o (or "+" "-" "*" "^")) ,M1 ,M2)
+      (all-vars '())
+      (build (lambda (vars M1 M2) `(,o ,M1 ,M2)))
+      (subterm '() M1)
+      (subterm '() M2)]
+     [`(,M1 ,M2)
+      (all-vars '())
+      (build (lambda (empty-list M1 M2) `(,M1 ,M2)))
+      (subterm '() M1)
+      (subterm '() M2)]
+     [`("letcc" ,X ,M)
+      (all-vars (list X))
+      (build (lambda (X-list M) `("letcc" ,(car X-list) ,M)))
+      (subterm (list X) M)]
+     [`("cc" ,M1 ,M2)
+      (all-vars '())
+      (build (lambda (vars M1 M2) `("cc" ,M1 ,M2)))
+      (subterm '() M1)
+      (subterm '() M2)]
+     [`("[" ,E "]")
+      (all-vars '())
+      (build (lambda (vars) `("[" ,E "]")))]))
+     
+
+  ;; the argument order for the subst-generated function
+  ;; doesn't match the order in the notes:
+  (define (iswim-subst M Xr Mr)
+    (iswim-subst/backwards Xr Mr M))
+
+  (define empty-env '())
+
+  ;; Environment lookup
+  (define (env-lookup env X)
+    (let ([m (assq X env)])
+      (and m (caddr m))))
+
+  ;; Environment extension
+  (define (env-extend env X vcl)
+    (cons (list X '= vcl) env))
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; Reductions:
+  
+  ;; beta_v reduction
+  (define beta_v
+    (reduction iswim-grammar
+               (("lam" X_1 M_1) V_1)
+               (iswim-subst (term M_1) (term X_1) (term V_1))))
+  
+  
+  (define delta
+    (list
+     (reduction iswim-grammar ("add1" b_1) (add1 (term b_1)))
+     (reduction iswim-grammar ("sub1" b_1) (sub1 (term b_1)))
+     (reduction iswim-grammar ("iszero" b_1)
+                (if (zero? (term b_1)) 
+                    '("lam" x ("lam" y x))
+                    '("lam" x ("lam" y y))))
+     (reduction iswim-grammar ("+" b_1 b_2) (+ (term b_1) (term b_2)))
+     (reduction iswim-grammar ("-" b_1 b_2) (- (term b_1) (term b_2)))
+     (reduction iswim-grammar ("*" b_1 b_2) (* (term b_1) (term b_2)))
+     (reduction iswim-grammar ("^" b_1 b_2) (expt (term b_1) (term b_2)))))
+  
+  ;; ->v
+  (define ->v (map (lambda (red)
+                     (compatible-closure red iswim-grammar 'M))
+                   (cons beta_v delta)))
+  
+  ;; :->v
+  (define :->v (map (lambda (red)
+                      (context-closure red iswim-grammar 'E))
+                    (cons beta_v delta)))
+
+  ;; :->v+letcc
+  (define :->v+letcc (append
+		      :->v
+		      (list
+
+		       ;; letcc rule:
+		       (reduction
+			iswim-grammar
+			(in-hole E_1 ("letcc" X_1 M_1))
+			(plug (term E_1) 
+                              (iswim-subst (term M_1) (term X_1) `("[" 
+                                                                   ,(plug (term E_1) '||) 
+                                                                   "]"))))
+
+		       ;; cc rule:
+		       (reduction
+			iswim-grammar
+			(in-hole E ("cc" ("[" (in-hole E_2 ||) "]") V_1))
+			(plug (term E_2) (term V_1))))))
+			
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; Helpers:
+  
+  (define (delta*n on Vs)
+    (let ([l (reduce delta `(,on ,@Vs))])
+      (if (null? l)
+	  #f
+	  (car l))))
+
+  (define (delta*1 o1 V)
+    (delta*n o1 (list V)))
+
+  (define (delta*2 o2 V1 V2)
+    (delta*n o2 (list V1 V2)))
+
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; Abbreviations:
+  
+  (define (if0 test then else)
+    (let ([X (variable-not-in `(,then ,else) 'X)])
+      `(((("iszero" ,test) ("lam" ,X ,then)) ("lam" ,X ,else)) 77)))
+  
+  (define true '("lam" x ("lam" y x)))
+  (define false '("lam" x ("lam" y y)))
+  (define boolean-not `("lam" x ((x ,false) ,true)))
+  
+  (define mkpair '("lam" x ("lam" y ("lam" s ((s x) y)))))
+  (define fst '("lam" p (p ("lam" x ("lam" y x)))))
+  (define snd '("lam" p (p ("lam" x ("lam" y y)))))
+  
+  (define Y_v '("lam" f ("lam" x
+			 ((("lam" g (f ("lam" x ((g g) x))))
+			   ("lam" g (f ("lam" x ((g g) x)))))
+			  x))))
+  
+  (define mksum `("lam" s
+		  ("lam" x 
+		   ,(if0 'x 0 '("+" x (s ("sub1" x)))))))
+  (define sum `(,Y_v ,mksum))
+
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; Exports:
+  
+  (provide/contract (iswim-grammar compiled-lang?)
+		    (M? (any/c . -> . boolean?))
+		    (V? (any/c . -> . boolean?))
+		    (o1? (any/c . -> . boolean?))
+		    (o2? (any/c . -> . boolean?))
+		    (on? (any/c . -> . boolean?))
+		    (k? (any/c . -> . boolean?))
+		    (env? (any/c . -> . boolean?))
+		    (cl? (any/c . -> . boolean?))
+		    (vcl? (any/c . -> . boolean?))
+		    (iswim-subst (M? symbol? M? . -> . M?))
+		    (env-lookup (env? symbol? . -> . (union false/c vcl?)))
+		    (env-extend (env? symbol? vcl? . -> . env?))
+		    (empty-env env?)
+		    (beta_v red?)
+		    (delta (listof red?))
+		    (delta*1 (o1? V?  . -> . (union false/c V?)))
+		    (delta*2 (o2? V? V? . -> .  (union false/c V?)))
+		    (delta*n (on? (listof V?) . -> .  (union false/c V?)))
+		    (->v (listof red?))
+		    (:->v (listof red?))
+		    (:->v+letcc (listof red?))
+		    (if0 (M? M? M? . -> . M?))
+		    (true M?)
+		    (false M?)
+		    (boolean-not M?)
+		    (mkpair M?)
+		    (fst M?)
+		    (snd M?)
+		    (Y_v M?)
+		    (sum M?)))
diff --git a/collects/reduction-semantics/examples/macro.ss b/collects/reduction-semantics/examples/macro.ss
new file mode 100644
index 0000000000..588c4ebcff
--- /dev/null
+++ b/collects/reduction-semantics/examples/macro.ss
@@ -0,0 +1,47 @@
+(module macro mzscheme
+  (require "../reduction-semantics.ss"
+           "../gui.ss")
+  
+  (define lang
+    (language 
+     (e (lambda (variable) e)
+        (app e e)
+        number
+        variable)
+     (e-ctxt (lambda (variable) e-ctxt)
+             (app e-ctxt any)
+             (app e e-ctxt)
+             hole)))
+  
+  (define macros '(or let if true false id))
+  
+  (define-syntax (--> stx)
+    (syntax-case stx ()
+      [(_ frm to)
+       (syntax (reduction/context lang e-ctxt frm to))]))
+  
+  (define reductions
+    (list
+     (--> (id (name e any))
+          (term e))
+     (--> (side-condition ((name e1 any) (name e2 any))
+                          (not (memq (term e1) macros)))
+          (term (app e1 e2)))
+     (--> (or (name e1 any) (name e2 any))
+          (let ([var (variable-not-in (list (term e1) (term e2)) 'x)])
+            (term (let (,var e1) (if ,var ,var e2)))))
+     (--> (let ((name var variable) (name rhs any)) 
+            (name body any))
+          (term ((lambda (var) body) rhs)))
+     (--> (if (name test any)
+              (name thn any)
+              (name els any))
+          (term ((test thn) els)))
+     (--> (true)
+          (term (lambda (x) (lambda (y) x))))
+     (--> (false)
+          (term (lambda (x) (lambda (y) y))))))
+  
+  (traces lang reductions '((id id) 5))
+  (traces lang reductions '(id 5))
+  (traces lang reductions '(or (false) (true))))
diff --git a/collects/reduction-semantics/examples/omega.ss b/collects/reduction-semantics/examples/omega.ss
new file mode 100644
index 0000000000..ccad3526f3
--- /dev/null
+++ b/collects/reduction-semantics/examples/omega.ss
@@ -0,0 +1,64 @@
+(module omega mzscheme
+  (require "../reduction-semantics.ss"
+           "../gui.ss"
+           "../subst.ss")
+  
+  (reduction-steps-cutoff 10)
+  
+  (define lang
+    (language (e (e e)
+                 (abort e)
+                 x
+                 v)
+              (c (v c)
+                 (c e)
+                 hole)
+              (v call/cc
+                 number
+                 (lambda (x) e))
+              
+              (x (variable-except lambda call/cc abort))
+              ))
+  
+  (define reductions
+    (list
+     (reduction lang
+                (in-hole c_1 (call/cc v_arg))
+                (term-let ([v (variable-not-in (term c_1) 'x)])
+                  (term (in-hole c_1 (v_arg (lambda (v) (abort (in-hole c_1 v))))))))
+     (reduction lang
+                (in-hole c (abort e_1))
+                (term e_1))
+     
+     (reduction/context lang
+                        c
+                        ((lambda (variable_x) e_body) v_arg)
+                        (lc-subst (term variable_x) (term v_arg) (term e_body)))))
+  
+  (define lc-subst
+    (plt-subst
+     ['abort (constant)]
+     ['call/cc (constant)]
+     [(? symbol?) (variable)]
+     [(? number?) (constant)]
+     [`(lambda (,x) ,b)
+      (all-vars (list x))
+      (build (lambda (vars body) `(lambda (,(car vars)) ,body)))
+      (subterm (list x) b)]
+     [`(call/cc ,v)
+      (all-vars '())
+      (build (lambda (vars arg) `(call/cc ,arg)))
+      (subterm '() v)]
+     [`(,f ,x)
+      (all-vars '())
+      (build (lambda (vars f x) `(,f ,x)))
+      (subterm '() f)
+      (subterm '() x)]))
+      
+  
+  ;(traces lang reductions '((lambda (x) (x x)) (lambda (x) (x x))))
+  
+  ;(traces lang reductions '((call/cc call/cc) (call/cc call/cc)))
+  (traces lang reductions '((lambda (x) ((call/cc call/cc) x)) (call/cc call/cc)))
+  
+  )
diff --git a/collects/reduction-semantics/examples/semaphores.ss b/collects/reduction-semantics/examples/semaphores.ss
new file mode 100644
index 0000000000..39ab1ce246
--- /dev/null
+++ b/collects/reduction-semantics/examples/semaphores.ss
@@ -0,0 +1,190 @@
+#|
+  
+semaphores make things much more predictable...
+  
+|#  
+
+(module semaphores mzscheme
+  (require "../reduction-semantics.ss"
+           "../gui.ss")
+  
+  (reduction-steps-cutoff 100)
+  
+  (define lang
+    (language
+     (p ((store (variable v) ...)
+         (semas (variable sema-count) ...)
+         (threads e ...)))
+     (sema-count number
+                 none)
+     (e (set! variable e)
+        (begin e ...)
+        (semaphore variable)
+        (semaphore-wait e)
+        (semaphore-post e)
+        (lambda (variable) e)
+        (e e)
+        variable
+        (list e ...)
+        (cons e e)
+        number
+        (void))
+     (p-ctxt ((store (variable v) ...)
+              (semas (variable sema-count) ...)
+              (threads e ... e-ctxt e ...)))
+     (e-ctxt (e-ctxt e)
+             (v e-ctxt)
+             (cons e-ctxt e)
+             (cons v e-ctxt)
+             (list v ... e-ctxt e ...)
+             (set! variable e-ctxt)
+             (begin e-ctxt e ...)
+             (semaphore-wait e-ctxt)
+             (semaphore-post e-ctxt)
+             hole)
+     (v (semaphore variable)
+        (lambda (variable) e)
+        (list v ...)
+        number
+        (void))))
+  
+  (define reductions
+    (list
+     (reduction lang
+                (in-hole (name c p-ctxt) (begin v e_1 e_2 e_rest ...))
+                (plug 
+                 (term c)
+                 (term (begin e_1 e_2 e_rest ...))))
+     (reduction lang
+                (in-hole (name c p-ctxt) 
+                         (cons v_1 (list v_2s ...)))
+                (plug 
+                 (term c)
+                 (term (list v_1 v_2s ...))))
+     (reduction lang
+                (in-hole (name c p-ctxt) (begin v e_1))
+                (plug (term c) (term e_1)))
+     (reduction lang
+                (in-hole (name c p-ctxt) (begin v_1))
+                (plug (term c) (term v_1)))
+     (reduction lang
+                ((store
+                  (name befores (variable v)) ...
+                  ((name x variable) (name v v))
+                  (name afters (variable v)) ...)
+                 (name semas any)
+                 (threads
+                  (name e-before e) ...
+                  (in-hole (name c e-ctxt) (name x variable))
+                  (name e-after e) ...))
+                (term 
+                 ((store
+                   befores ...
+                   (x v)
+                   afters ...)
+                  semas
+                  (threads
+                   e-before ...
+                   (in-hole c v)
+                   e-after ...))))
+     (reduction lang
+                ((store
+                  (name befores (variable v)) ...
+                  (variable_i v)
+                  (name afters (variable v)) ...)
+                 (name semas any)
+                 (threads
+                  (name e-before e) ...
+                  (in-hole (name c e-ctxt) (set! variable_i v_new))
+                  (name e-after e) ...))
+                (term 
+                 ((store
+                   befores ...
+                   (variable_i v_new)
+                   afters ...)
+                  semas
+                  (threads
+                   e-before ...
+                   (in-hole c (void))
+                   e-after ...))))
+     (reduction lang
+                ((name store any)
+                 (semas
+                  (name befores (variable v)) ...
+                  (variable_sema number_n)
+                  (name afters (variable v)) ...)
+                 (threads
+                  (name e-before e) ...
+                  (in-hole (name c e-ctxt) (semaphore-wait (semaphore variable_sema)))
+                  (name e-after e) ...))
+                (term 
+                 (store
+                  (semas
+                   befores ...
+                   (variable_sema ,(if (= (term number_n) 1)
+                                       (term none)
+                                       (- (term number_n) 1)))
+                   afters ...)
+                   (threads
+                    e-before ...
+                    (in-hole c (void))
+                    e-after ...))))
+     (reduction lang
+                ((name store any)
+                 (semas
+                  (name befores (variable v)) ...
+                  (variable_sema number_n)
+                  (name afters (variable v)) ...)
+                 (threads
+                  (name e-before e) ...
+                  (in-hole (name c e-ctxt) (semaphore-post (semaphore variable_sema)))
+                  (name e-after e) ...))
+                (term 
+                 (store
+                  (semas
+                   befores ...
+                   (variable_sema ,(+ (term number_n) 1))
+                   afters ...)
+                  (threads
+                   e-before ...
+                   (in-hole c (void))
+                   e-after ...))))
+     
+     (reduction lang
+                ((name store any)
+                 (semas
+                  (name befores (variable v)) ...
+                  (variable_sema none)
+                  (name afters (variable v)) ...)
+                 (threads
+                  (name e-before e) ...
+                  (in-hole (name c e-ctxt) (semaphore-post (semaphore variable_sema)))
+                  (name e-after e) ...))
+                (term 
+                 (store
+                  (semas
+                   befores ...
+                   (variable_sema 1)
+                   afters ...)
+                  (threads
+                   e-before ...
+                   (in-hole c (void))
+                   e-after ...))))))
+  
+  (traces lang
+       reductions
+       `((store (y (list)))
+         (semas)
+         (threads (set! y (cons 1 y))
+                  (set! y (cons 2 y)))))
+  
+  (traces lang
+       reductions
+       `((store (y (list)))
+         (semas (x 1))
+         (threads (begin (semaphore-wait (semaphore x)) 
+                         (set! y (cons 1 y)) 
+                         (semaphore-post (semaphore x)))
+                  (begin (semaphore-wait (semaphore x))
+                         (set! y (cons 2 y))
+                         (semaphore-post (semaphore x)))))))
diff --git a/collects/reduction-semantics/examples/subject-reduction.ss b/collects/reduction-semantics/examples/subject-reduction.ss
new file mode 100644
index 0000000000..cf4f30a239
--- /dev/null
+++ b/collects/reduction-semantics/examples/subject-reduction.ss
@@ -0,0 +1,96 @@
+(module subject-reduction mzscheme
+  (require "../reduction-semantics.ss"
+           "../gui.ss"
+           "../subst.ss"
+           (lib "plt-match.ss"))
+  
+  (reduction-steps-cutoff 10)
+  
+  (define lang
+    (language (e (e e)
+                 (abort e)
+                 x
+                 v)
+              (x (variable-except lambda call/cc abort))
+              (c (v c)
+                 (c e)
+                 hole)
+              (v call/cc
+                 number
+                 (lambda (x t) e))
+              (t num
+                 (t -> t))))
+  
+  (define reductions
+    (list
+     (reduction lang
+                (in-hole c_1 (call/cc v_arg))
+                (let ([v (variable-not-in (term c_1) 'x)])
+                  (plug 
+                   (term c_1) 
+                   (term (v_arg (lambda (,v) 
+                                  (abort ,(plug (term c_1) v))))))))
+     (reduction lang
+                (in-hole c (abort e_1))
+                (term e_1))
+     (reduction/context lang
+                        c
+                        ((lambda (x_format t_1) e_body) v_actual)
+                        ;(lc-subst x_format v_actual e_body)
+                        (lc-subst (term x_format) (term e_body) (term v_actual))
+                        )))
+  
+  (define lc-subst
+    (plt-subst
+     [(? symbol?) (variable)]
+     [(? number?) (constant)]
+     [`(lambda (,x ,t) ,b)
+      (all-vars (list x))
+      (build (lambda (vars body) `(lambda (,(car vars) ,t) ,body)))
+      (subterm (list x) b)]
+     [`(call/cc ,v)
+      (all-vars '())
+      (build (lambda (vars arg) `(call/cc ,arg)))
+      (subterm '() v)]
+     [`(,f ,x)
+      (all-vars '())
+      (build (lambda (vars f x) `(,f ,x)))
+      (subterm '() f)
+      (subterm '() x)]))
+      
+  (define (type-check term)
+    (let/ec k
+      (let loop ([term term]
+                 [env '()])
+        (match term
+          [(? symbol?) 
+            (let ([l (assoc term env)])
+              (if l
+                  (cdr l)
+                  (k #f)))]
+          [(? number?) 'num]
+          [`(lambda (,x ,t) ,b)
+            (let ([body (loop b (cons (cons x t) env))])
+              `(,t -> ,body))]
+          [`(,e1 ,e2)
+            (let ([t1 (loop e1 env)]
+                  [t2 (loop e2 env)])
+              (match t1
+                [`(,td -> ,tr)
+                  (if (equal? td t2)
+                      tr
+                      (k #f))]
+                [else (k #f)]))]))))
+      
+  (define (pred term1)
+    (let ([t1 (type-check term1)])
+      (lambda (term2)
+        (and t1
+             (equal? (type-check term2) t1)))))
+  
+  (define (show term)
+    (traces/pred lang reductions (list term) (pred term)))
+  
+  ;(show '((lambda (x num) x) 1))
+  (show '((lambda (x (num -> num)) 1) ((lambda (x (num -> num)) x) (lambda (x num) x))))
+  )
diff --git a/collects/reduction-semantics/examples/threads.ss b/collects/reduction-semantics/examples/threads.ss
new file mode 100644
index 0000000000..d920b4c5ad
--- /dev/null
+++ b/collects/reduction-semantics/examples/threads.ss
@@ -0,0 +1,128 @@
+(module threads mzscheme
+  (require "../reduction-semantics.ss"
+           "../gui.ss"
+           "../subst.ss"
+           (lib "plt-match.ss"))
+  
+  (reduction-steps-cutoff 100)
+  
+  (define threads
+    (language
+     (p ((store (x v) ...) (threads e ...)))
+     (e (set! x e)
+        (let ((x e)) e)
+        (e e)
+        x
+        v
+        (+ e e))
+     (v (lambda (x) e)
+        number)
+     (x variable)
+     (pc ((store (x v) ...) tc))
+     (tc (threads e ... ec e ...))
+     (ec (ec e) (v ec) (set! variable ec) (let ((x ec)) e) (+ ec e) (+ v ec) hole)))
+  
+  (define reductions
+    (list
+     
+     ; sum
+     (reduction threads
+                (in-hole pc_1 (+ number_1 number_2))
+                (plug (term pc_1) 
+                      (+ (term number_1) (term number_2))))
+     
+     ; deref
+     (reduction threads
+                ((store
+                  (name befores (x v)) ...
+                  (x_i v_i)
+                  (name afters (x v)) ...)
+                 (in-hole tc_1 x_i))
+                (term
+                 ((store 
+                   befores ... 
+                   (x_i v_i)
+                   afters ...)
+                  ,(plug (term tc_1) (term v_i)))))
+     ; set!
+     (reduction threads
+                ((store (name befores (variable v)) ...
+                        (x_i v)
+                        (name afters (variable v)) ...)
+                 (in-hole tc_1 (set! x_i v_new)))
+                (term 
+                 ((store 
+                   befores ... 
+                   (x_i v_new)
+                   afters ...)
+                  ,(plug (term tc_1)
+                         (term v_new)))))
+     ; beta
+     (reduction threads
+                (in-hole pc_1 ((lambda (x_1) e_1) v_1))
+                (plug (term pc_1) 
+                      (substitute (term x_1) (term v_1) (term e_1))))
+     
+     ; let
+     (reduction threads
+                ((store (name the-store any) ...)
+                 (in-hole tc_1 (let ((x_1 v_1)) e_1)))
+                (let ((new-x (variable-not-in (term (the-store ...)) (term x_1))))
+                  (term 
+                   ((store the-store ... (,new-x v_1))
+                    ,(plug (term tc_1) 
+                           (substitute (term x_1) new-x (term e_1)))))))))
+  
+  (define substitute
+    (plt-subst
+     [(? symbol?) (variable)]
+     [(? number?) (constant)]
+     [`(lambda (,x) ,b)
+      (all-vars (list x))
+      (build (lambda (vars body) `(lambda (,(car vars)) ,body)))
+      (subterm (list x) b)]
+     [`(set! ,x ,e)
+      (all-vars '())
+      (build (lambda (vars name body) `(set! ,name ,body)))
+      (subterm '() x)
+      (subterm '() e)]
+     [`(let ((,x ,e1)) ,e2)
+      (all-vars (list x))
+      (build (lambda (vars letval body) `(let ((,(car vars) ,letval)) ,body)))
+      (subterm '() e1)
+      (subterm (list x) e2)]
+     [`(+ ,e1 ,e2)
+      (all-vars '())
+      (build (lambda (vars e1 e2) `(+ ,e1 ,e2)))
+      (subterm '() e1)
+      (subterm '() e2)]
+     [`(,f ,x)
+      (all-vars '())
+      (build (lambda (vars f x) `(,f ,x)))
+      (subterm '() f)
+      (subterm '() x)]))
+  
+  (define (run es) (traces threads reductions `((store) (threads ,@es))))
+  (provide run)
+  
+  (define (count x) 
+    (match x
+      [`(set! ,x ,e) (+ 1 (count e))]
+      [(? symbol?) 1]
+      [(? number?) 0]
+      [`(+ ,e1 ,e2) (+ 1 (count e1) (count e2))]))
+  
+  (traces threads reductions
+       '((store (x 1))
+         (threads
+          (set! x (+ x -1))
+          (set! x (+ x 1))))
+       
+      (lambda (exp)
+        (match exp
+          [`((store (x ,x)) (threads ,t1 ,t2))
+           (format "~a ~a ~a" x (count t1) (count t2))])))
+
+  (parameterize ([initial-char-width 12])
+    (traces threads reductions '((store) (threads (+ 1 1) (+ 1 1)))))
+  )
diff --git a/collects/reduction-semantics/examples/types.ss b/collects/reduction-semantics/examples/types.ss
new file mode 100644
index 0000000000..0e4116fc3d
--- /dev/null
+++ b/collects/reduction-semantics/examples/types.ss
@@ -0,0 +1,91 @@
+(module types mzscheme
+  (require (lib "reduction-semantics.ss" "reduction-semantics")
+           (lib "gui.ss" "reduction-semantics")
+           (lib "subst.ss" "reduction-semantics"))
+  
+  (reduction-steps-cutoff 10)
+  
+  (define lang
+    (language (e (e e)
+                 x
+                 number
+                 (lambda (x t) e)
+                 (if e e e)
+                 (= e e)
+		 (-> e e)
+                 num
+                 bool)
+              (c (t c)
+                 (c e)
+                 (-> t c)
+                 (-> c e)
+                 (= t c)
+                 (= c e)
+                 (if c e e)
+                 (if t c e)
+                 (if t t c)
+                 hole)
+	      (x (variable-except lambda -> if =))
+              (t num bool (-> t t))))
+  
+  (define-syntax (r--> stx)
+    (syntax-case stx ()
+      [(_ i r) (syntax (reduction/context lang c i r))]))
+
+  (define-syntax (e--> stx)
+    (syntax-case stx ()
+      [(_ i msg) (syntax (reduction lang (in-hole c i) msg))]))
+	 
+  (define reductions
+    (list
+     (r--> number 
+           'num)
+     
+     (r--> (lambda (x_1 t_1) e_body)
+           (term (-> t_1 ,(lc-subst (term x_1) 
+                                    (term t_1)
+                                    (term e_body)))))
+     
+     (r--> ((-> t_1 t_2) t_1)
+           (term t_2))
+     
+     (e--> (side-condition ((-> t_1 t) t_2)
+                           (not (equal? (term t_1) (term t_2))))
+           (format "app: domain error ~s and ~s" (term t_1) (term t_2)))
+     
+     (e--> (num t_1)
+           (format "app: non function error ~s" (term t_1)))
+     
+     (r--> (if bool t_1 t_1)
+           (term t_1))
+     (e--> (side-condition (if bool t_1 t_2)
+                           (not (equal? (term t_1) (term t_2))))
+           (format "if: then and else clause mismatch ~s and ~s" (term t_1) (term t_2)))
+     (e--> (side-condition (if t_1 t t)
+                           (not (equal? (term t_1) 'bool)))
+           (format "if: test not boolean ~s" (term t_1)))
+     
+     (r--> (= num num) 'bool)
+     (e--> (side-condition (= t_1 t_2)
+                           (or (not (equal? (term t_1) 'num))
+                               (not (equal? (term t_2) 'num))))
+           (format "=: not comparing numbers ~s and ~s" (term t_1) (term t_2)))))
+  
+  (define lc-subst
+    (subst
+     [(? symbol?) (variable)]
+     [(? number?) (constant)]
+     [`(lambda (,x ,t) ,b)
+      (all-vars (list x))
+      (build (lambda (vars body) `(lambda (,(car vars) ,t) ,body)))
+      (subterm (list x) b)]
+     [`(,f ,@(xs ...))
+      (all-vars '())
+      (build (lambda (vars f . xs) `(,f ,@xs)))
+      (subterm '() f)
+      (subterms '() xs)]))
+  
+  ; (define theterm '((lambda (x num) (lambda (y num) (if (= x y) 0 x))) 1))
+  (define theterm '((lambda (x num) (lambda (y num) (if (= x y) 0 (lambda (x num) x)))) 1))
+  (traces lang reductions theterm)
+  )
diff --git a/collects/reduction-semantics/generator.ss b/collects/reduction-semantics/generator.ss
new file mode 100644
index 0000000000..75e436e48b
--- /dev/null
+++ b/collects/reduction-semantics/generator.ss
@@ -0,0 +1,245 @@
+(module generator mzscheme
+  (require "private/matcher.ss")
+
+  (provide lang->generator-table
+           for-each-generated
+           for-each-generated/size)
+  
+  (define (lang->generator-table lang
+				 nums
+				 vars
+				 strs
+				 skip-kws
+				 cache-limit)
+
+    ;; -------------------- Cache implementation --------------------
+    ;; Cache is currently disabled. It's not clear that it's useful.
+    (define (cache-small gen) gen)
+    
+    ;; -------------------- Build table --------------------
+    ;; The `gens' table maps non-terminal symbols to
+    ;; generator functions. A generator function conumes:
+    ;;   * the min acceptable size of a generated element
+    ;;   * the max acceptable size of a generated element
+    ;;   * a sucess continuation proc that accepts
+    ;;        - the generated value
+    ;;        - the value's size
+    ;;        - a generator proc that produces the next value;
+    ;;          this proc expects to be given the same min, max,
+    ;;          and fail continuation proc as before
+    ;;   * a failure continuation thunk
+    ;;
+    (let ([nts (compiled-lang-lang lang)]
+          [nt-map (make-hash-table)])
+      ;; nt-map tells us which symbols are non-terminals; it also 
+      ;; provides conservative min-size and max-size thunks that are
+      ;; refined as table generation proceeds
+      (for-each (lambda (nt) (hash-table-put! nt-map (nt-name nt) 
+                                              (cons (lambda () 1)
+                                                    (lambda () +inf.0))))
+                nts)
+      ;; gens is the main hash table
+      (let ([gens (make-hash-table)]
+            [atomic-alts (lambda (l size)
+                           (values
+                            (lambda (min-size max-size result-k fail-k)
+			      (let loop ([l l][result-k result-k][max-size max-size][fail-k fail-k])
+				(if (<= min-size size max-size)
+                                    (if (null? l)
+                                        (fail-k)
+                                        (result-k (car l)
+						  size
+						  (lambda (s xs result-k fail-k)
+						    (loop (cdr l) result-k xs fail-k))))
+				    (fail-k))))
+                            (lambda () size)
+                            (lambda () size)))]
+            [to-do nts])
+        (letrec ([make-gen/get-size
+                  (lambda (p)
+                    (cond
+                      [(hash-table-get nt-map p (lambda () #f))
+                       => (lambda (get-sizes)
+                            (values
+                             (lambda (min-size max-size result-k fail-k)
+                               ((hash-table-get gens p) min-size max-size result-k fail-k))
+                             (car get-sizes)
+                             (cdr get-sizes)))]
+                      [(eq? 'number p) (atomic-alts nums 1)]
+                      [(eq? 'string p) (atomic-alts strs 1)]
+                      [(eq? 'any p) (atomic-alts (append nums strs vars) 1)]
+                      [(or (eq? 'variable p)
+                           (and (pair? p)
+                                (eq? (car p) 'variable-except)))
+                       (atomic-alts vars 1)]
+                      [(symbol? p) ; not a non-terminal, because we checked above
+		       (if (memq p skip-kws)
+			   (values
+			    (lambda (min-size max-size result-k fail-k)
+			      (fail-k))
+			    (lambda () +inf.0)
+			    (lambda () -1))
+			   (atomic-alts (list p) 0))]
+                      [(null? p) (atomic-alts (list null) 0)]
+                      [(and (pair? p)
+                            (or (not (pair? (cdr p)))
+                                (not (eq? '... (cadr p)))))
+                       (make-pair-gen/get-size p cons)]
+                      [(and (pair? p) (pair? (cdr p)) (eq? '... (cadr p)))
+		       (let-values ([(just-rest just-rest-min-size just-rest-max-size)
+				     (make-gen/get-size (cddr p))]
+				    [(both both-min-size both-max-size)
+				     (make-pair-gen/get-size (cons (kleene+ (car p)) (cddr p)) append)])
+			 (values
+			  (lambda (min-size max-size result-k fail-k)
+			    (let loop ([both both][result-k result-k][max-size max-size][fail-k fail-k])
+			      (both min-size max-size
+				    (lambda (v size next-both)
+				      (result-k v size
+						(lambda (ns xs result-k fail-k)
+						  (loop next-both result-k xs fail-k))))
+				    (lambda ()
+				      (just-rest min-size max-size result-k fail-k)))))
+			  just-rest-min-size
+			  (lambda () +inf.0)))]
+                      [else
+                       (error 'make-gen "unrecognized pattern: ~e" p)]))]
+                 [make-pair-gen/get-size
+                  (lambda (p combiner)
+                    (let*-values ([(first first-min-size first-max-size) 
+                                   (make-gen/get-size (car p))]
+                                  [(rest rest-min-size rest-max-size) 
+                                   (make-gen/get-size (cdr p))]
+                                  [(this-min-size) (let ([v #f])
+						     (lambda ()
+						       (unless v
+							 (set! v (+ (first-min-size)
+								    (rest-min-size))))
+						       v))]
+                                  [(this-max-size) (let ([v #f])
+						     (lambda ()
+						       (unless v
+							 (set! v (+ (first-max-size)
+								    (rest-max-size))))
+						       v))])
+                      (values
+                       (cache-small
+                        (lambda (min-size max-size result-k fail-k)
+			  (if (min-size . > . (this-max-size))
+			      (fail-k)
+			      (let rloop ([rest rest][result-k result-k][max-size max-size][fail-k fail-k][failed-size +inf.0])
+				(if (max-size . < . (this-min-size))
+				    (fail-k)
+				    (rest
+				     (max 0 (- min-size (first-max-size)))
+				     (min (sub1 failed-size) (- max-size (first-min-size)))
+				     (lambda (rest rest-size next-rest)
+				       (if (rest-size . >= . failed-size)
+					   (rloop next-rest result-k max-size fail-k failed-size)
+					   (let floop ([first first]
+						       [result-k result-k]
+						       [max-size max-size]
+						       [fail-k fail-k] 
+						       [first-fail-k (lambda ()
+								       (rloop next-rest result-k max-size fail-k rest-size))])
+					     (first (max 0 (- min-size rest-size))
+						    (- max-size rest-size)
+						    (lambda (first first-size next-first)
+						      (result-k 
+						       (combiner first rest)
+						       (+ first-size rest-size)
+						       (lambda (ns xs result-k fail-k)
+							 (floop next-first result-k xs fail-k
+								(lambda ()
+								  (rloop next-rest result-k xs fail-k failed-size))))))
+						    first-fail-k))))
+				     fail-k))))))
+                       this-min-size
+                       this-max-size)))]
+                 [kleene+ (lambda (p)
+			    (let ([n (gensym)])
+			      (hash-table-put! nt-map n (cons (lambda () 1)
+							      (lambda () +inf.0)))
+			      (set! to-do (cons (make-nt 
+						 n 
+						 (list (make-rhs (cons p '()))
+						       (make-rhs (cons p n))))
+						to-do))
+			      n))])
+          (let to-do-loop ([nts (reverse to-do)])
+            (set! to-do null)
+            (for-each (lambda (nt)
+                        (hash-table-put!
+                         gens
+                         (nt-name nt)
+                         (let* ([gens+sizes
+                                 (map (lambda (rhs)
+                                        (let-values ([(gen get-min-size get-max-size)
+                                                      (make-gen/get-size 
+                                                       (rhs-pattern rhs))])
+					  (cons gen (cons get-min-size get-max-size))))
+                                      (nt-rhs nt))]
+                                [get-min-size
+                                 (let ([get-min-sizes (map cadr gens+sizes)])
+                                   (let ([v #f])
+                                     (lambda ()
+                                       (unless v
+                                         (set! v (add1
+						  (apply min (map (lambda (gs) (gs))
+								  get-min-sizes)))))
+				       v)))]
+                                [get-max-size
+                                 (let ([get-max-sizes (map cddr gens+sizes)])
+                                   (let ([v #f])
+                                     (lambda ()
+                                       (unless v
+                                         (set! v (add1
+						  (apply max (map (lambda (gs) (gs))
+								  get-max-sizes)))))
+                                       v)))])
+                           (hash-table-put! nt-map (nt-name nt)
+                                            (cons get-min-size get-max-size))
+                           (cache-small
+                            (lambda (min-size max-size result-k fail-k)
+			      (if (min-size . > . (get-max-size))
+                                  (fail-k)
+                                  (let loop ([l (map car gens+sizes)][result-k result-k][max-size max-size][fail-k fail-k])
+				    (if (max-size . < . (get-min-size))
+					(fail-k)
+					(if (null? l)
+					    (fail-k)
+					    (let iloop ([alt-next (car l)]
+							[result-k result-k]
+							[max-size max-size]
+							[fail-k fail-k])
+					      (alt-next
+					       (max 0 (sub1 min-size))
+					       (sub1 max-size)
+					       (lambda (alt a-size alt-next)
+						 (result-k
+						  alt
+						  (add1 a-size)
+						  (lambda (ns xs result-k fail-k)
+						    (iloop alt-next result-k xs fail-k))))
+					       (lambda ()
+						 (loop (cdr l) result-k max-size fail-k)))))))))))))
+                      nts)
+            (unless (null? to-do)
+              (to-do-loop to-do))))
+	gens)))
+  
+  (define (for-each-generated/size proc gens min-size max-size nonterm)
+    (let ([gen (hash-table-get gens nonterm)])
+      (let loop ([gen gen])
+        (gen
+         min-size
+         max-size
+         (lambda (val z1 gen-next)
+           (proc val z1)
+           (loop gen-next))
+         void))))
+  
+  (define (for-each-generated proc gens nonterm)
+    (let loop ([i 0])
+      (for-each-generated/size proc gens i i nonterm)
+      (loop (add1 i)))))
diff --git a/collects/reduction-semantics/gui.ss b/collects/reduction-semantics/gui.ss
new file mode 100644
index 0000000000..d53248f68c
--- /dev/null
+++ b/collects/reduction-semantics/gui.ss
@@ -0,0 +1,517 @@
+;; should cache the count of new snips -- dont
+;; use `count-snips'; use something associated with the
+;; equal hash-table
+
+(module gui mzscheme
+  (require (lib "etc.ss")
+           (lib "graph.ss" "mrlib")
+           "reduction-semantics.ss"
+           (lib "mred.ss" "mred")
+           (lib "framework.ss" "framework")
+           (lib "pretty.ss")
+           (lib "class.ss")
+           (lib "contract.ss")
+           (lib "list.ss"))
+
+  (provide/contract
+   [traces (opt-> (compiled-lang?
+                   (listof red?)
+                   any/c)
+                  (procedure?)
+                  any)]
+   [traces/pred (opt-> (compiled-lang?
+                        (listof red?)
+                        (listof any/c)
+                        (any/c . -> . boolean?))
+                       (procedure?)
+                       any)]
+   [traces/multiple (opt-> (compiled-lang?
+                            (listof red?)
+                            (listof any/c))
+                           (procedure?)
+                           any)])
+               
+   
+  (provide reduction-steps-cutoff initial-font-size initial-char-width
+           dark-pen-color light-pen-color dark-brush-color light-brush-color)
+
+  
+  
+  (preferences:set-default 'plt-reducer:show-bottom #t boolean?)
+  
+  (define dark-pen-color (make-parameter "blue"))
+  (define light-pen-color (make-parameter "lightblue"))
+  (define dark-brush-color (make-parameter "lightblue"))
+  (define light-brush-color (make-parameter "white"))
+  
+  ;; after (about) this many steps, stop automatic, initial reductions
+  (define reduction-steps-cutoff (make-parameter 20))
+  
+  
+  
+  (define initial-font-size
+    (make-parameter
+     (send (send (send (editor:get-standard-style-list) 
+                       find-named-style
+                       "Standard")
+                 get-font)
+           get-point-size)))
+  
+  (define initial-char-width (make-parameter 30))
+  
+  ;; the initial spacing between row and columns of the reduction terms
+  (define x-spacing 15)
+  (define y-spacing 15)
+  
+  (define (default-pp v port w spec)
+    (parameterize ([pretty-print-columns w])
+      (pretty-print v port)))
+  
+  (define traces
+    (opt-lambda (lang reductions expr [pp default-pp])
+      (traces/multiple lang reductions (list expr) pp)))
+      
+  (define traces/multiple
+    (opt-lambda (lang reductions exprs [pp default-pp])
+      (traces/pred lang reductions exprs (lambda (x) #t) pp)))
+  
+  (define traces/pred
+    (opt-lambda (lang reductions exprs pred [pp default-pp])
+      (define main-eventspace (current-eventspace))
+      (define graph-pb (make-object graph-pasteboard%))
+      (define f (instantiate red-sem-frame% ()
+                  (label "Reduction Graph")
+                  (graph-pb graph-pb)
+                  (width 600)
+                  (height 400)
+                  (toggle-panel-callback
+                   (lambda ()
+                     (send remove-my-contents-panel
+                           change-children
+                           (lambda (l)
+                             (preferences:set 'plt-reducer:show-bottom (null? l))
+                             (if (null? l)
+                                 (list bottom-panel)
+                                 null)))))))
+      (define ec (make-object editor-canvas% (send f get-area-container) graph-pb))
+      (define remove-my-contents-panel (new vertical-panel%
+                                            (parent (send f get-area-container))
+                                            (stretchable-height #f)))
+      (define bottom-panel (new vertical-panel%
+                                (parent remove-my-contents-panel)
+                                (stretchable-height #f)))
+      (define font-size (instantiate slider% ()
+                          (label "Font Size")
+                          (min-value 1)
+                          (init-value (initial-font-size))
+                          (max-value 127)
+                          (parent bottom-panel)
+                          (callback (lambda (slider evt) (set-font-size (send slider get-value))))))
+      (define lower-panel (instantiate horizontal-panel% ()
+                             (parent bottom-panel)
+                             (stretchable-height #f)))
+      (define reduce-button (make-object button% 
+                              "Reducing..." 
+                              lower-panel
+                              (lambda (x y)
+                                (reduce-button-callback))))
+      (define status-message (instantiate message% ()
+                               (label "")
+                               (parent lower-panel)
+                               (stretchable-width #t)))
+      
+      (define snip-cache (make-hash-table 'equal))
+      
+      ;; call-on-eventspace-main-thread : (-> any) -> any
+      ;; =reduction thread=
+      (define (call-on-eventspace-main-thread thnk)
+        (parameterize ([current-eventspace main-eventspace])
+          (let ([s (make-semaphore 0)]
+                [ans #f])
+            (queue-callback
+             (lambda ()
+               (set! ans (thnk))
+               (semaphore-post s)))
+            (semaphore-wait s)
+            ans)))
+        
+      ;; only changed on the reduction thread
+      ;; frontier : (listof (is-a?/c graph-editor-snip%))
+      (define frontier (map (lambda (expr) (build-snip snip-cache #f expr pred pp)) exprs))
+
+      ;; set-font-size : number -> void
+      ;; =eventspace main thread=
+      (define (set-font-size size)
+        (let* ([scheme-standard (send (editor:get-standard-style-list) find-named-style
+				      "Standard")]
+               [scheme-delta (make-object style-delta%)])
+          (send scheme-standard get-delta scheme-delta)
+          (send scheme-delta set-size-mult 0)
+          (send scheme-delta set-size-add size)
+          (send scheme-standard set-delta scheme-delta)))
+      
+      ;; reduce-frontier : -> void
+      ;; =reduction thread=
+      ;; updates frontier with the new snip after a single reduction
+      (define (reduce-frontier)
+        (let ([col #f])
+          (let loop ([snips frontier]
+                     [new-frontier null]
+                     [y 0])
+            (cond
+              [(null? snips)
+               (set! frontier new-frontier)]
+              [else
+               (let* ([snip (car snips)]
+                      [new-snips 
+                       (filter 
+                        (lambda (x) x)
+                        (map (lambda (sexp) 
+                               (call-on-eventspace-main-thread
+                                (λ ()
+                                  (build-snip snip-cache snip sexp pred pp))))
+                             (reduce reductions (send snip get-expr))))]
+                      [new-y 
+                       (call-on-eventspace-main-thread
+                        (lambda () ; =eventspace main thread=
+                          (send graph-pb begin-edit-sequence)
+                          (unless col  ;; only compute col here, incase user moves snips
+                            (set! col (+ x-spacing (find-rightmost-x graph-pb))))
+                          (begin0
+                            (insert-into col y graph-pb new-snips)
+                            (send graph-pb end-edit-sequence)
+                            (send status-message set-label
+                                  (string-append (term-count (count-snips)) "...")))))])
+                 (loop (cdr snips)
+                       (append new-frontier new-snips)
+                       new-y))]))))
+      
+      ;; count-snips : -> number
+      ;; =eventspace main thread=
+      ;; counts the snips in `pb'. If connections?
+      ;; is #t, also counts the number of connections 
+      ;; and returns the sum of the connections and snips
+      (define (count-snips)
+        (let loop ([n 0]
+                   [snip (send graph-pb find-first-snip)])
+          (cond
+            [snip (loop (+ n 1) (send snip next))]
+            [else n])))
+      
+      ;; reduce-button-callback : -> void
+      ;; =eventspace main thread=
+      (define (reduce-button-callback)
+        (send reduce-button enable #f)
+        (send reduce-button set-label "Reducing...")
+        (thread
+         (lambda ()
+           (do-some-reductions)
+           (queue-callback
+            (lambda () ;; =eventspace main thread=
+              (scroll-to-rightmost-snip)
+              (send reduce-button set-label "Reduce")
+              (cond
+                [(null? frontier)
+                 (send status-message set-label (term-count (count-snips)))]
+                [else
+                 (send status-message set-label 
+                       (string-append (term-count (count-snips))
+                                      "(possibly more to find)"))
+                 (send reduce-button enable #t)]))))))
+      
+      (define (term-count n)
+        (format "found ~a term~a" n (if (equal? n 1) "" "s")))
+      
+      ;; do-some-reductions : -> void
+      ;; =reduction thread=
+      ;; reduces some number of times, 
+      ;; adding at least reduction-steps-cutoff steps
+      ;; before stopping (unless there aren't that many left)
+      (define (do-some-reductions)
+        (let ([initial-size (call-on-eventspace-main-thread count-snips)])
+          (let loop ()
+            (cond
+              [(null? frontier) (void)]
+              [((call-on-eventspace-main-thread count-snips) . >= . (+ initial-size (reduction-steps-cutoff)))
+               (void)]
+              [else
+               (reduce-frontier)
+               (loop)]))))
+      
+      ;; scroll-to-rightmost-snip : -> void
+      ;; =eventspace main thread=
+      (define (scroll-to-rightmost-snip)
+        (let ([rightmost-snip (send graph-pb find-first-snip)])
+          (let loop ([rightmost-snip rightmost-snip]
+                     [rightmost-y (get-right-edge rightmost-snip)]
+                     [snip (send rightmost-snip next)])
+            (cond
+              [(not snip) (make-snip-visible rightmost-snip)]
+              [else
+               (let ([snip-y (get-right-edge snip)])
+                 (if (<= rightmost-y snip-y)
+                     (loop snip snip-y (send snip next))
+                     (loop rightmost-snip rightmost-y (send snip next))))]))))
+
+      ;; make-snip-visisble : snip -> void
+      ;; =eventspace-main-thread=
+      (define (make-snip-visible snip)
+        (let ([bl (box 0)]
+              [bt (box 0)]
+              [br (box 0)]
+              [bb (box 0)])
+          (send graph-pb get-snip-location snip bl bt #f)
+          (send graph-pb get-snip-location snip br bb #t)
+          (send graph-pb scroll-to 
+                snip
+                0
+                0
+                (- (unbox br) (unbox bl))
+                (- (unbox bb) (unbox bt))
+                #t)))
+      
+      ;; get-right-edge : snip -> void
+      ;; =eventspace-main-thread=
+      (define (get-right-edge snip)
+        (let ([br (box 0)])
+          (send graph-pb get-snip-location snip br #f #t)
+          (unbox br)))
+             
+      (send remove-my-contents-panel
+            change-children
+            (lambda (l)
+              (if (preferences:get 'plt-reducer:show-bottom)
+                  (list bottom-panel)
+                  null)))
+      (insert-into init-rightmost-x 0 graph-pb frontier)
+      (set-font-size (initial-font-size))
+      (reduce-button-callback)
+      (send f show #t)))
+  
+  (define red-sem-frame%
+    (class (frame:standard-menus-mixin (frame:basic-mixin frame%))
+      (init-field graph-pb toggle-panel-callback)
+      (define/override (file-menu:create-save?) #f)
+      (define/override (file-menu:between-save-as-and-print file-menu)
+        (make-object menu-item% "Print..."
+          file-menu
+          (lambda (item evt) (send graph-pb print)))
+        (make-object menu-item% "Export as Encapsulted PostScript..."
+          file-menu
+          (lambda (item evt) (send graph-pb print #t #f 'postscript this #f)))
+        (make-object menu-item% "Export as PostScript..."
+          file-menu
+          (lambda (item evt) (send graph-pb print #t #f 'postscript this)))
+        (make-object menu-item% 
+          "Toggle bottom stuff"
+          file-menu
+          (lambda (item evt) (toggle-panel-callback))))
+      (super-instantiate ())))
+  
+  (define (resizing-pasteboard-mixin pb%)
+    (class pb%
+      
+      (define/augment (on-interactive-resize snip)
+        (when (is-a? snip reflowing-snip<%>)
+          (send snip reflow-program))
+        #;(super on-interactive-resize snip))
+      
+      (define/augment (after-interactive-resize snip)
+        (when (is-a? snip reflowing-snip<%>)
+          (send snip reflow-program))
+        #;(super after-interactive-resize snip))
+      
+      (define/override (interactive-adjust-resize snip w h)
+        (super interactive-adjust-resize snip w h)
+        (when (is-a? snip reflowing-snip<%>)
+          (send snip reflow-program)))
+      (super-instantiate ())))
+  
+  (define reflowing-snip<%>
+    (interface ()
+      reflow-program))
+  
+  (define graph-pasteboard% 
+    (resizing-pasteboard-mixin
+     (graph-pasteboard-mixin pasteboard%)))
+  
+  (define graph-editor-snip%
+    (class* (graph-snip-mixin editor-snip%) (reflowing-snip<%>)
+      (init-field expr pp char-width bad?)
+      (define/public (get-expr) expr)
+      
+      (inherit get-editor)
+      (define/public (reflow-program)
+        (let ([ed (get-editor)])
+          (when ed
+            (let ([ed-ad (send ed get-admin)])
+              (when ed-ad
+                (let ([dc (send ed get-dc)]
+                      [wb (box 0)]
+                      [std-style (send (editor:get-standard-style-list) find-named-style "Standard")])
+                  (send ed-ad get-view #f #f wb #f)
+                  (let-values ([(tw _1 _2 _3) (send dc get-text-extent "w"
+                                                    (and std-style
+                                                         (send std-style get-font)))])
+                    (let ([new-width (max 1 (inexact->exact (floor (/ (- (unbox wb) 2) tw))))])
+                      (unless (equal? new-width char-width)
+                        (set! char-width new-width)
+                        (format-expr))))))))))
+      
+      (inherit get-extent)
+      (define/override (draw dc x y left top right bottom dx dy draw-caret)
+        (when bad?
+          (let ([bw (box 0)]
+                [bh (box 0)]
+                [pen (send dc get-pen)]
+                [brush (send dc get-brush)])
+            (get-extent dc x y bw bh #f #f #f #f)
+            (send dc set-pen (send the-pen-list find-or-create-pen bad-color 1 'solid))
+            (send dc set-brush (send the-brush-list find-or-create-brush bad-color 'solid))
+            (send dc draw-rectangle x y (unbox bw) (unbox bh))
+            (send dc set-pen pen)
+            (send dc set-brush brush)))
+        (super draw dc x y left top right bottom dx dy draw-caret))
+      
+      (define/public (format-expr)
+        (let* ([text (get-editor)]
+               [port (make-output-port
+                      'graph-port
+                      always-evt
+                      (lambda (bytes start end buffering? enable-breaks?)
+                        (send text insert (bytes->string/utf-8 (subbytes bytes start end))
+                              (send text last-position)
+                              (send text last-position))
+                        (- end start))
+                      void)])
+          (send text begin-edit-sequence)
+          (send text thaw-colorer)
+          (send text set-styles-sticky #f)
+          (send text erase)
+          (pp expr port char-width text)
+          (when (char=? #\newline (send text get-character (- (send text last-position) 1)))
+            (send text delete (- (send text last-position) 1) (send text last-position)))
+          (send text freeze-colorer)
+          (when bad?
+            (send text change-style bad-style-delta 0 (send text last-position)))
+          (send text end-edit-sequence)))
+
+      (super-instantiate ())))
+  
+  (define program-text%
+    (class scheme:text%
+      (init-field bad?)
+      (define/override (on-paint before? dc left top right bottom dx dy draw-caret)
+        (when (and bad? before?)
+          (let ([pen (send dc get-pen)]
+                [brush (send dc get-brush)])
+            (send dc set-pen (send the-pen-list find-or-create-pen bad-color 1 'solid))
+            (send dc set-brush (send the-brush-list find-or-create-brush bad-color 'solid))
+            (send dc draw-rectangle (+ dx left) (+ dy top) (- right left) (- bottom top))
+            (send dc set-pen pen)
+            (send dc set-brush brush)))
+        (super on-paint before? dc left top right bottom dx dy draw-caret))
+      (super-new)))
+  
+  (define lines-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
+  (define bad-style-delta (make-object style-delta% 'change-italic))
+  (define bad-color "pink")
+      
+  ;; where the first snips are inserted
+  (define init-rightmost-x 25)
+  
+  ;; insert-into : number number pasteboard (listof snip%) -> number
+  ;; inserts the snips into the pasteboard vertically 
+  ;; aligned, starting at (x,y). Returns
+  ;; the y coordinate where another snip might be inserted.
+  (define (insert-into x y pb exprs)
+    (let loop ([exprs exprs]
+               [y y])
+      (cond
+        [(null? exprs) y]
+        [else
+         (let ([es (car exprs)])
+           (send pb insert es x y)
+           (loop (cdr exprs)
+                 (+ y (find-snip-height pb es) y-spacing)))])))
+
+  ;; build-snip : hash-table
+  ;;              (union #f (is-a?/c graph-snip<%>)) 
+  ;;              sexp
+  ;;              sexp -> boolean
+  ;;              (any port number -> void)
+  ;;           -> (union #f (is-a?/c graph-editor-snip%))
+  ;; returns #f if a snip corresponding to the expr has already been created.
+  ;; also adds in the links to the parent snip
+  ;; =eventspace main thread=
+  (define (build-snip cache parent-snip expr pred pp)
+    (let-values ([(snip new?)
+                  (let/ec k
+                    (k
+                     (hash-table-get
+                      cache
+                      expr
+                      (lambda ()
+                        (let ([new-snip (make-snip parent-snip expr pred pp)])
+                          (hash-table-put! cache expr new-snip)
+                          (k new-snip #t))))
+                     #f))])
+      (when parent-snip
+        (add-links parent-snip snip
+                   (send the-pen-list find-or-create-pen (dark-pen-color) 0 'solid)
+                   (send the-pen-list find-or-create-pen (light-pen-color) 0 'solid)
+                   (send the-brush-list find-or-create-brush (dark-brush-color) 'solid)
+                   (send the-brush-list find-or-create-brush (light-brush-color) 'solid)))
+      (and new? snip)))
+  
+  ;; make-snip : (union #f (is-a?/c graph-snip<%>)) 
+  ;;             sexp 
+  ;;             sexp -> boolean
+  ;;             (any port number -> void)
+  ;;          -> (is-a?/c graph-editor-snip%)
+  ;; unconditionally creates a new graph-editor-snip
+  ;; =eventspace main thread=
+  (define (make-snip parent-snip expr pred pp)
+    (let* ([bad? (not (pred expr))]
+           [text (new program-text% (bad? bad?))]
+           [es (instantiate graph-editor-snip% ()
+                 (char-width (initial-char-width))
+                 (editor text)
+                 (pp 
+                  (if (procedure-arity-includes? pp 4)
+                      pp
+                      (lambda (v port w spec) (display (pp v) port))))
+                 (expr expr)
+                 (bad? bad?))])
+      (send text set-autowrap-bitmap #f)
+      (send text freeze-colorer)
+      (send es format-expr)
+      es))
+  
+  ;; find-rightmost-x : pasteboard -> number
+  (define (find-rightmost-x pb) 
+    (let ([first-snip (send pb find-first-snip)])
+      (if first-snip
+          (let loop ([snip first-snip]
+                     [max-x (find-snip-right-edge pb first-snip)])
+            (cond
+              [snip
+               (loop (send snip next)
+                     (max max-x (find-snip-right-edge pb snip)))]
+              [else max-x]))
+          init-rightmost-x)))
+  
+  ;; find-snip-right-edge : editor snip -> number
+  (define (find-snip-right-edge ed snip)
+    (let ([br (box 0)])
+      (send ed get-snip-location snip br #f #t)
+      (unbox br)))
+  
+  ;; find-snip-height : editor snip -> number
+  (define (find-snip-height ed snip)
+    (let ([bt (box 0)]
+          [bb (box 0)])
+      (send ed get-snip-location snip #f bt #f)
+      (send ed get-snip-location snip #f bb #t)
+      (- (unbox bb)
+         (unbox bt)))))
diff --git a/collects/reduction-semantics/helper.ss b/collects/reduction-semantics/helper.ss
new file mode 100644
index 0000000000..e34fc3f1ea
--- /dev/null
+++ b/collects/reduction-semantics/helper.ss
@@ -0,0 +1,206 @@
+(module helper mzscheme
+  (require (lib "contract.ss")
+           "reduction-semantics.ss")
+  
+  (define counter 0)
+  (define (generate-string)
+    (set! counter (add1 counter))
+    (format "s~a" counter))
+  
+  (define (unique-names? l)
+    (let ([ht (make-hash-table)])
+      (andmap (lambda (n)
+                (if (hash-table-get ht n (lambda () #f))
+                    #f
+                    (begin
+                      (hash-table-put! ht n #t)
+                      #t)))
+              l)))
+  
+  (define (all-of P ?)
+    ;; Traverse P as an sexp, and look for class-name uses:
+    (let ([l (let loop ([sexp P])
+               (cond
+                 [(? sexp) (list sexp)]
+                 [(pair? sexp) (append (loop (car sexp)) (loop (cdr sexp)))]
+                 [else null]))]
+          [ht (make-hash-table)])
+      ;; Filter duplicates by hashing:
+      (for-each (lambda (i) (hash-table-put! ht i #t)) l)
+      (hash-table-map ht (lambda (k v) k))))
+  
+  (define-syntaxes (lang-match-lambda* 
+		    lang-match-lambda-memoized*
+		    lang-match-lambda
+		    lang-match-lambda-memoized)
+    (let ([generic
+           (lambda (lam)
+             (lambda (stx)
+               (syntax-case stx ()
+                 [(_ (id ...) main-id grammar [pattern result] ...)
+                  (with-syntax ([red (generate-temporaries #'(pattern ...))]
+                                [lam lam]
+				[ids #'(id ...)])
+                    (syntax/loc
+                     stx
+                     (let ([lang grammar]
+                           [escape (make-parameter void)])
+                       (let ([reds (list (reduction grammar pattern ((escape) (lambda ids result)))
+                                         ...)])
+                         (lam (id ...)
+                              ((let/ec esc
+                                 (parameterize ([escape esc])
+                                   (reduce reds main-id)
+                                   (error 'lang-match-lambda "no pattern matched input: ~e" main-id)))
+                               id ...))))))])))]
+	  [single
+	   (lambda (multi)
+	     (lambda (stx)
+	       (syntax-case stx ()
+		 [(_ (id) grammar [pattern result] ...)
+		  (with-syntax ([multi multi])
+		    #'(multi (id) id grammar [pattern result] ...))])))])
+      (values
+       (generic #'lambda)
+       (generic #'lambda-memoized)
+       (single #'lang-match-lambda*)
+       (single #'lang-match-lambda-memoized*))))
+  
+    (define (transitive-closure orig)
+    ;; Copy initial mapping:
+    (let ([map (map (lambda (p) (list (car p) (cdr p))) orig)])
+      ;; Extend the map list until nothing changes
+      (let loop ()
+        (let ([changed? #f])
+          (for-each (lambda (pair)
+                      (let ([mapping (cdr pair)])
+                        (for-each (lambda (item)
+                                    (let ([trans (ormap (lambda (transitive)
+                                                          (and (not (memq transitive mapping))
+                                                               transitive))
+                                                        (cdr (assq item map)))])
+                                      (when trans
+                                        (append! pair (list trans))
+                                        (set! changed? #t))))
+                                  mapping)))
+                    map)
+          (when changed? (loop))))
+      ;; Done
+      map))
+  
+  (define-syntax (lambda-memoized stx)
+    (syntax-case stx ()
+      [(_ () body1 body ...)
+       (syntax/loc stx (lambda () body1 body ...))]
+      [(_ (arg) body1 body ...)
+       (syntax/loc 
+        stx 
+        (let ([ht (make-hash-table 'weak)])
+          (lambda (arg)
+            (hash-table-get
+             ht
+             arg
+             (lambda ()
+               (let ([v (begin body1 body ...)])
+                 (hash-table-put! ht arg v)
+                 v))))))]
+      [(_ (arg1 arg ...) body1 body ...)
+       (syntax/loc
+        stx
+        (let ([memo (lambda-memoized (arg1) (lambda-memoized (arg ...) body1 body ...))])
+          (lambda (arg1 arg ...)
+            ((memo arg1) arg ...))))]))
+  
+  (define-syntax define-memoized
+    (syntax-rules ()
+      [(_ (f . args) body1 body ...)
+       (define f (lambda-memoized args body1 body ...))]))
+
+
+  ;; function-reduce*
+  (define (function-reduce* reds expr done? max-steps)
+    (cons 
+     expr
+     (if (or (zero? max-steps) (done? expr))
+	 null
+	 (let ([l (reduce reds expr)])
+	   (cond
+	    [(null? l) null]
+	    [(= 1 (length l))
+	     (function-reduce* reds (car l) done? (sub1 max-steps))]
+	    [else
+	     (error 'function-reduce* 
+		    "found ~a possible steps from ~e"
+		    (length l)
+		    expr)])))))
+
+  (define-struct multi-result (choices))
+
+  ;; ----------------------------------------
+  ;; Path exploration:
+  
+  (define-syntax (explore-results stx)
+    (syntax-case stx ()
+      [(_ (id) result-expr body-expr bes ...)
+       #'(let ([try (lambda (id) body-expr bes ...)])
+           (let ([r result-expr])
+             (do-explore r try)))]))
+
+  (define-syntax (explore-parallel-results stx)
+    (syntax-case stx ()
+      [(_ (list-id) result-list-expr body-expr bes ...)
+       #'(let ([try (lambda (list-id) body-expr bes ...)])
+           (let loop ([rs result-list-expr][es null])
+             (if (null? rs)
+                 (try (reverse es))
+                 (do-explore 
+                  (car rs)
+                  (lambda (e)
+                    (loop (cdr rs) (cons e es)))))))]))
+  
+  (define (do-explore r try)
+    (cond
+      [(multi-result? r)
+       (let loop ([l (multi-result-choices r)])
+         (if (null? l)
+             #f
+	     (let ([a ((car l))])
+	       (if (multi-result? a)
+		   (loop (append (multi-result-choices a)
+				 (cdr l)))
+		   (let ([v (try a)])
+		     (if (not v)
+			 (loop (cdr l))
+			 (make-multi-result 
+			  (append (if (multi-result? v)
+				      (multi-result-choices v)
+				      (list (lambda () v)))
+				  (list (lambda () (loop (cdr l))))))))))))]
+      [else (try r)]))
+
+  (define (many-results l)
+    (make-multi-result (map (lambda (v) (lambda () v)) l)))
+  
+  (define (first-result result)
+    (let/ec k
+      (explore-results (x) result
+        (k x))))
+  
+  (provide
+   define-memoized
+   lambda-memoized
+   lang-match-lambda
+   lang-match-lambda-memoized
+   lang-match-lambda*
+   lang-match-lambda-memoized*
+   explore-results
+   explore-parallel-results)
+  (provide/contract
+   (function-reduce* ((listof red?) any/c (any/c . -> . boolean?) number?
+		      . -> . (listof any/c)))
+   (unique-names? ((listof symbol?) . -> . boolean?))
+   (generate-string (-> string?))
+   (all-of (any/c (any/c . -> . any) . -> . (listof any/c)))
+   (transitive-closure ((listof pair?) . -> . (listof (listof any/c))))
+   (many-results ((listof (lambda (x) (not (multi-result? x)))) . -> . any))
+   (first-result (any/c . -> . any))))
diff --git a/collects/reduction-semantics/info.ss b/collects/reduction-semantics/info.ss
new file mode 100644
index 0000000000..8a3833adfd
--- /dev/null
+++ b/collects/reduction-semantics/info.ss
@@ -0,0 +1,4 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "PLT Redex")
+  (define doc.txt "doc.txt"))
+
diff --git a/collects/reduction-semantics/mc.ss b/collects/reduction-semantics/mc.ss
new file mode 100644
index 0000000000..827dd28992
--- /dev/null
+++ b/collects/reduction-semantics/mc.ss
@@ -0,0 +1,376 @@
+
+(module mc mzscheme
+  (require (lib "reduction-semantics.ss" "reduction-semantics")
+	   (lib "generator.ss" "reduction-semantics")
+           (prefix matcher: (lib "matcher.ss" "reduction-semantics" "private"))
+           (lib "list.ss")
+           (lib "class.ss")
+           (lib "mred.ss" "mred"))
+  
+  (provide build-reductions 
+           generation-depth
+           reduction-depth
+           generate-and-test
+           (struct reduction-graph (initial ht)))
+  
+  ;; reduction-graph = (make-graph sexp hash-table[sexp -o> (listof sexp)])
+  (define-struct reduction-graph (initial ht))
+  
+  (define generation-depth (make-parameter 2))
+  (define reduction-depth (make-parameter 10))
+  (define max-queue-size 100)
+  
+  ;; computes all of the terms of size `n' or smaller for each non-terminal
+  ;; in the language
+  ;; [ sizes are limited by number of recusive constructions of each non terminal;
+  ;;   4 is huge for even tiny languages ]
+  (define (generate-and-test lang nt reductions reductions-test)
+    
+    (define frame (make-object frame% "Status"))
+    (define gc-on-bitmap (make-object bitmap% (build-path (collection-path "icons") "recycle.gif")))
+    (define gc-off-bitmap (make-object bitmap% 
+                            (send gc-on-bitmap get-width)
+                            (send gc-on-bitmap get-height)
+                            #t))
+    (define stupid-internal-define-syntax1
+      (let ([bdc (make-object bitmap-dc% gc-off-bitmap)])
+        (send bdc clear)
+        (send bdc set-bitmap #f)))
+    
+    (define-values (reductions-queue-size-message 
+                    total-reductions-message
+                    test-queue-size-message
+                    total-tests-message
+                    memory-allocated-message)
+      (let* ([outer-hp (make-object horizontal-panel% frame)]
+             [outer-vp (make-object vertical-panel% outer-hp)]
+             [hp1 (make-object horizontal-panel% outer-vp)]
+             [hp2 (make-object horizontal-panel% outer-vp)]
+             [hp3 (make-object horizontal-panel% outer-vp)]
+             [hp4 (make-object horizontal-panel% outer-vp)]
+             [hp5 (make-object horizontal-panel% outer-vp)]
+             [l1 (make-object message% "To Reduce: " hp1)]
+             [l2 (make-object message% "Total Expressions: " hp2)]
+             [l3 (make-object message% "To Test: " hp3)]
+             [l4 (make-object message% "Total Tests: " hp4)]
+             [l5 (make-object message% "Megabytes Allocated: " hp5)]
+             [gc-canvas (instantiate canvas% ()
+                          (parent outer-hp)
+                          (stretchable-width #f)
+                          (stretchable-height #f)
+                          (min-width (send gc-on-bitmap get-width))
+                          (min-height (send gc-on-bitmap get-height)))]
+	     [dms-button (instantiate button% ("DMS" outer-hp)
+				      [callback (lambda (b e)
+						  (dump-memory-stats '<struct>))])])
+
+        (register-collecting-blit gc-canvas
+                                  0
+                                  0 
+                                  (send gc-on-bitmap get-width)
+                                  (send gc-on-bitmap get-height)
+                                  gc-on-bitmap
+                                  gc-off-bitmap)
+        (let ([w (max (send l1 get-width)
+                      (send l2 get-width)
+                      (send l3 get-width)
+                      (send l4 get-width)
+                      (send l5 get-width))])
+          (send l1 min-width w)
+          (send l2 min-width w)
+          (send l3 min-width w)
+          (send l4 min-width w)
+          (send l5 min-width w))
+        
+        (values
+         (instantiate message% ()
+           (label "0000000")
+           ;(stretchable-width #t)
+           (parent hp1))
+         (instantiate message% ()
+           (label "0000000")
+           ;(stretchable-width #t)
+           (parent hp2))
+         (instantiate message% ()
+           (label "0000000")
+           ;(stretchable-width #t)
+           (parent hp3))
+         (instantiate message% ()
+           (label "0000000")
+           ;(stretchable-width #t)
+           (parent hp4))
+         (instantiate message% ()
+           (label "0000000")
+           ;(stretchable-width #t)
+           (parent hp5)))))
+   
+    (define go (make-semaphore 0))
+    
+    (define no-more-terms (box 'no-more-terms))
+
+    (define generation-thread
+      (thread
+       (lambda ()
+         (semaphore-wait go)
+         (generate lang nt enqueue-for-reduction-thread)
+         (enqueue-for-reduction-thread no-more-terms))))
+    
+    (define total-reductions 0)
+    (define reduction-queue (new-queue))
+    (define reduction-queue-sema (make-semaphore 1))
+    (define reduction-thread-sema (make-semaphore 0))
+    (define reduction-producer-sema (make-semaphore max-queue-size))
+    (define (enqueue-for-reduction-thread sexp)
+      (semaphore-wait reduction-producer-sema)
+      (semaphore-wait reduction-queue-sema)
+      (enqueue reduction-queue sexp)
+      (set! total-reductions (+ total-reductions 1))
+      (semaphore-post reduction-thread-sema)
+      (semaphore-post reduction-queue-sema))
+    
+    (define reduction-thread
+      (thread
+       (lambda ()
+         (semaphore-wait go)
+         (let loop ()
+           (semaphore-wait reduction-thread-sema)
+           (semaphore-wait reduction-queue-sema)
+           (let ([sexp (dequeue reduction-queue)])
+             (semaphore-post reduction-queue-sema)
+             (semaphore-post reduction-producer-sema)
+             (cond
+               [(eq? sexp no-more-terms)
+                (enqueue-for-test-thread no-more-terms)]
+               [else
+                (enqueue-for-test-thread (build-reductions sexp reductions))
+                (loop)]))))))
+
+    (define total-tests 0)
+    (define test-queue (new-queue))
+    (define test-queue-sema (make-semaphore 1))
+    (define test-thread-sema (make-semaphore 0))
+    (define test-producer-sema (make-semaphore max-queue-size))
+    (define (enqueue-for-test-thread sexp)
+      (semaphore-wait test-producer-sema)
+      (semaphore-wait test-queue-sema)
+      (enqueue test-queue sexp)
+      (set! total-tests (+ total-tests 1))
+      (semaphore-post test-thread-sema)
+      (semaphore-post test-queue-sema))
+    
+    (define test-thread
+      (thread
+       (lambda ()
+         (semaphore-wait go)
+         (let loop ()
+           (semaphore-wait test-thread-sema)
+           (semaphore-wait test-queue-sema)
+           (let ([reds (dequeue test-queue)])
+             (semaphore-post test-queue-sema)
+             (semaphore-post test-producer-sema)
+             (cond
+               [(eq? reds no-more-terms)
+                (semaphore-post done-semaphore)]
+               [else
+                (reductions-test reds)]))
+           (loop)))))
+    
+    (define mem-divisor (* 1024 1024))
+    (define (update-status)
+      (send test-queue-size-message set-label (format "~a" (queue-size test-queue)))
+      (send total-tests-message set-label (format "~a" total-tests))
+      (send reductions-queue-size-message set-label (format "~a" (queue-size reduction-queue)))
+      (send total-reductions-message set-label (format "~a" total-reductions))
+      (send memory-allocated-message set-label (number->string (quotient (current-memory-use) mem-divisor))))
+
+    (define status-thread
+      (thread
+       (lambda ()
+         (semaphore-wait go)
+         (with-handlers ([exn:break? (lambda (x) (semaphore-post status-thread-done))])
+           (let loop ()
+             (update-status)
+             (sleep 2)
+             (loop))))))
+    
+    (define done-semaphore (make-semaphore 0))
+    (define status-thread-done (make-semaphore 0))
+    
+    (send frame show #t)
+    (semaphore-post go)
+    (semaphore-post go)
+    (semaphore-post go)
+    (semaphore-post go)
+    (yield done-semaphore)
+    (break-thread status-thread)
+    (semaphore-wait status-thread-done)
+    (update-status)
+    (make-object message% "Done." frame))
+
+  
+  
+;                                                                                                      
+;                                                                                                      
+;                                                                                                      
+;                    ;                      ;                                                   ;      
+;                    ;                                                                          ;      
+;                    ;                 ;                                                        ;      
+;   ; ;;  ;;;    ;;; ;  ;    ;   ;;;; ;;;;  ;    ;;;;   ; ;;;        ;;; ;  ; ;;  ;;;   ; ;;;   ; ;;;  
+;   ;;   ;   ;  ;   ;;  ;    ;  ;      ;    ;   ;    ;  ;;   ;      ;   ;;  ;;   ;   ;  ;;   ;  ;;   ; 
+;   ;    ;   ;  ;    ;  ;    ;  ;      ;    ;   ;    ;  ;    ;      ;    ;  ;        ;  ;    ;  ;    ; 
+;   ;    ;;;;;  ;    ;  ;    ;  ;      ;    ;   ;    ;  ;    ;      ;    ;  ;     ;;;;  ;    ;  ;    ; 
+;   ;    ;      ;    ;  ;    ;  ;      ;    ;   ;    ;  ;    ;      ;    ;  ;    ;   ;  ;    ;  ;    ; 
+;   ;    ;      ;   ;;  ;   ;;  ;      ;    ;   ;    ;  ;    ;      ;   ;;  ;    ;   ;  ;;   ;  ;    ; 
+;   ;     ;;;;   ;;; ;   ;;; ;   ;;;;   ;;  ;    ;;;;   ;    ;       ;;; ;  ;     ;;;;; ; ;;;   ;    ; 
+;                                                                        ;              ;              
+;                                                                   ;    ;              ;              
+;                                                                    ;;;;               ;              
+
+  
+  ;; build-reductions : sexp (listof reductions) -> reduction-graph 
+  ;; builds the reduction graph for expression according to reductions
+  (define (build-reductions expression reductions)
+    (let* ([ht (make-hash-table 'equal)]
+           [reduce/add
+            (lambda (term)
+              (let ([reduced (reduce reductions term)])
+                (hash-table-put! ht term reduced)
+                (filter (lambda (term)
+                          (not (hash-table-get ht term (lambda () #f))))
+                        reduced)))])
+      (let loop ([frontier (list expression)]
+                 [depth (reduction-depth)])
+        (unless (zero? depth)
+          (let* ([new-terms (apply append (map reduce/add frontier))])
+            (cond
+              [(null? new-terms) (void)]
+              [else
+               (loop new-terms (- depth 1))]))))
+      (make-reduction-graph expression ht)))
+  
+  
+  
+  
+;                                                                     
+;                                                                     
+;                                                                     
+;                                                  ;                  
+;                                                                     
+;                                             ;                       
+;    ;;; ;   ;;;   ; ;;;    ;;;   ; ;;  ;;;  ;;;;  ;    ;;;;   ; ;;;  
+;   ;   ;;  ;   ;  ;;   ;  ;   ;  ;;   ;   ;  ;    ;   ;    ;  ;;   ; 
+;   ;    ;  ;   ;  ;    ;  ;   ;  ;        ;  ;    ;   ;    ;  ;    ; 
+;   ;    ;  ;;;;;  ;    ;  ;;;;;  ;     ;;;;  ;    ;   ;    ;  ;    ; 
+;   ;    ;  ;      ;    ;  ;      ;    ;   ;  ;    ;   ;    ;  ;    ; 
+;   ;   ;;  ;      ;    ;  ;      ;    ;   ;  ;    ;   ;    ;  ;    ; 
+;    ;;; ;   ;;;;  ;    ;   ;;;;  ;     ;;;;;  ;;  ;    ;;;;   ;    ; 
+;        ;                                                            
+;   ;    ;                                                            
+;    ;;;;                                                             
+
+  
+  
+  ;; generate : lang sexp (sexp -> void) -> void
+  ;; generates the terms up to (generation-depth) in size
+  ;; passes each that comes from gdesired-nt to enqueue-for-reduction-thread
+  (define (generate lang desired-nt enqueue-for-reduction-thread)
+    (let ([gens (lang->generator-table lang
+				       '(0 1)
+				       '(x y)
+				       '("a" "b")
+				       null
+				       0)])
+      (let loop ([n 0])
+	(unless (n . > . (generation-depth))
+	  (for-each-generated/size (lambda (sexp size)
+				     (enqueue-for-reduction-thread sexp))
+				   gens 
+				   n n desired-nt)
+	  (loop (add1 n))))))
+  
+
+  ;; find-interesting-nts : (listof nt) sym -> (listof sym)
+  (define (find-interesting-nts clang desired-nt)
+    (let* ([lang (matcher:compiled-lang-lang clang)]
+           [ht (make-hash-table)]
+           [nt-syms (map matcher:nt-name lang)])
+      (let loop ([nt-sym desired-nt])
+        (let ([nt-lst (filter (lambda (x) (eq? (matcher:nt-name x) nt-sym)) lang)])
+          (cond
+            [(null? nt-lst) (void)]
+            [(null? (cdr nt-lst)) 
+             (let ([referenced-nt-syms (get-referenced-nts nt-syms (car nt-lst) lang)])
+               (for-each
+                (lambda (referenced-nt-sym)
+                  (unless (hash-table-get ht referenced-nt-sym (lambda () #f))
+                    (hash-table-put! ht referenced-nt-sym #t)
+                    (loop referenced-nt-sym)))
+                referenced-nt-syms))]
+            [else (error 'mc.ss "found more than one definition of ~s in grammar" nt-sym)])))
+      (hash-table-map ht (lambda (x y) x))))
+  
+  (define (get-referenced-nts nt-syms nt lang)
+    (let loop ([rhss (matcher:nt-rhs nt)]
+               [refd-nts null])
+      (cond
+        [(null? rhss) refd-nts]
+        [else (loop (cdr rhss)
+                    (get-referenced-nts/rhs nt-syms (car rhss) refd-nts))])))
+  
+  (define (get-referenced-nts/rhs nt-syms rhs acc)
+    (let loop ([pat (matcher:rhs-pattern rhs)]
+               [acc acc])
+      (cond
+        [(null? pat) acc]
+        [(pair? pat) (loop (car pat) (loop (cdr pat) acc))]
+        [(symbol? pat) 
+         (if (memq pat nt-syms)
+             (cons pat acc)
+             acc)])))
+              
+        
+        
+  
+;                                        
+;                                        
+;                                        
+;                                        
+;                                        
+;                                        
+;    ;;; ;  ;    ;   ;;;   ;    ;   ;;;  
+;   ;   ;;  ;    ;  ;   ;  ;    ;  ;   ; 
+;   ;    ;  ;    ;  ;   ;  ;    ;  ;   ; 
+;   ;    ;  ;    ;  ;;;;;  ;    ;  ;;;;; 
+;   ;    ;  ;    ;  ;      ;    ;  ;     
+;   ;   ;;  ;   ;;  ;      ;   ;;  ;     
+;    ;;; ;   ;;; ;   ;;;;   ;;; ;   ;;;; 
+;        ;                               
+;        ;                               
+;        ;                               
+
+
+  
+  (define-struct queue (hd tl size))
+  (define (new-queue) (make-queue null null 0))
+  (define (enqueue queue thnk)
+    (set-queue-size! queue (+ (queue-size queue) 1))
+    (let ([new-tail (cons thnk null)])
+      (if (null? (queue-hd queue))
+          (begin
+            (set-queue-hd! queue new-tail)
+            (set-queue-tl! queue new-tail))
+          (begin
+            (set-cdr! (queue-tl queue) new-tail)
+            (set-queue-tl! queue new-tail)))))
+  (define (dequeue queue)
+    (when (null? (queue-hd queue))
+      (error 'dequeue))
+    (set-queue-size! queue (- (queue-size queue) 1))
+    (let* ([qh (queue-hd queue)]
+	   [fst (car qh)])
+      (set-queue-hd! queue (cdr qh))
+      (set-cdr! qh #f)
+      (when (null? (queue-hd queue))
+        (set-queue-tl! queue null))
+      fst))
+  (define (queue-empty? queue) (null? (queue-hd queue))))
diff --git a/collects/reduction-semantics/private/info.ss b/collects/reduction-semantics/private/info.ss
new file mode 100644
index 0000000000..d35132379f
--- /dev/null
+++ b/collects/reduction-semantics/private/info.ss
@@ -0,0 +1,2 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Reduction Semantics private"))
diff --git a/collects/reduction-semantics/private/make-plt.ss b/collects/reduction-semantics/private/make-plt.ss
new file mode 100644
index 0000000000..dfb0232be9
--- /dev/null
+++ b/collects/reduction-semantics/private/make-plt.ss
@@ -0,0 +1,37 @@
+(module make-plt mzscheme
+  (require (lib "file.ss")
+           (lib "pack.ss" "setup")
+           (lib "plthome.ss" "setup"))
+
+  (current-directory plthome)
+
+  (define (display-res f)
+    (lambda (x)
+      (let ([ans (f x)])
+        (when ans
+          (printf "including ~s~n" x))
+        ans)))
+
+  (define bad-dirs '("CVS" ".svn"))
+  (define bad-files '(".DS_Store" "reduction-semantics.plt"))
+
+  (pack (build-path "collects" "reduction-semantics" "reduction-semantics.plt")
+        "Reduction Semantics"
+        (list (build-path "collects" "reduction-semantics"))
+        '(("reduction-semantics"))
+        (display-res
+         (lambda (filename)
+           (let ([exp (reverse (explode-path (normalize-path filename)))])
+             (cond
+               [(member (cadr exp) bad-dirs)
+                #f]
+               [(member (car exp) bad-dirs)
+                #f]
+               [(member (car exp) bad-files)
+                #f]
+               [(regexp-match #rx"~$" (path->string filename))
+                #f]
+               [else
+                (std-filter filename)]))))
+        #t
+        'file-replace))
diff --git a/collects/reduction-semantics/private/matcher-test.ss b/collects/reduction-semantics/private/matcher-test.ss
new file mode 100644
index 0000000000..57c8081a5b
--- /dev/null
+++ b/collects/reduction-semantics/private/matcher-test.ss
@@ -0,0 +1,583 @@
+(module matcher-test mzscheme
+  (require "matcher.ss"
+           (lib "list.ss"))
+  
+  (define (test)
+    (print-struct #t)
+    (test-empty 'any 1 (list (make-mtch (make-bindings null) 1 none)))
+    (test-empty 'any 'true (list (make-mtch (make-bindings null) 'true none)))
+    (test-empty 'any "a" (list (make-mtch (make-bindings null) "a" none)))
+    (test-empty 'any '(a b) (list (make-mtch (make-bindings null) '(a b) none)))
+    (test-empty 1 1 (list (make-mtch (make-bindings null) 1 none)))
+    (test-empty 99999999999999999999999999999999999999999999999
+                99999999999999999999999999999999999999999999999
+                (list (make-mtch (make-bindings null) 
+                                 99999999999999999999999999999999999999999999999
+                                 none)))
+    (test-empty 'x 'x (list (make-mtch (make-bindings null) 'x none)))
+    (test-empty 1 2 #f)
+    (test-empty "a" "b" #f)
+    (test-empty "a" "a" (list (make-mtch (make-bindings null) "a" none)))
+    (test-empty 'number 1 (list (make-mtch (make-bindings null) 1 none)))
+    (test-empty 'number 'x #f)
+    (test-empty 'string "a" (list (make-mtch (make-bindings null) "a" none)))
+    (test-empty 'string 1 #f)
+    (test-empty 'variable 'x (list (make-mtch (make-bindings null) 'x none)))
+    (test-empty 'variable 1 #f)
+    (test-empty '(variable-except x) 1 #f)
+    (test-empty '(variable-except x) 'x #f)
+    (test-empty '(variable-except x) 'y (list (make-mtch (make-bindings null) 'y none)))
+    (test-empty 'hole 1 #f)
+    (test-empty '(hole hole-name) 1 #f)
+    (test-empty '(name x number) 1 (list (make-mtch (make-bindings (list (make-rib 'x 1))) 1 none)))
+    (test-empty 'number_x 1 (list (make-mtch (make-bindings (list (make-rib 'number_x 1))) 1 none)))
+    (test-empty 'string_y "b" (list (make-mtch (make-bindings (list (make-rib 'string_y "b"))) "b" none)))
+    (test-empty 'any_z '(a b) (list (make-mtch (make-bindings (list (make-rib 'any_z '(a b)))) '(a b) none)))
+    
+    (test-ellipses '(a) '(a))
+    (test-ellipses '(a ...) `(,(make-repeat 'a '())))
+    (test-ellipses '((a ...) ...) `(,(make-repeat '(a ...) '())))
+    (test-ellipses '(a ... b c ...) `(,(make-repeat 'a '()) b ,(make-repeat 'c '())))
+    (test-ellipses '((name x a) ...) `(,(make-repeat '(name x a) (list (make-rib 'x '()))))) 
+    (test-ellipses '((name x (a ...)) ...)
+                   `(,(make-repeat '(name x (a ...)) (list (make-rib 'x '())))))
+    (test-ellipses '(((name x a) ...) ...)
+                   `(,(make-repeat '((name x a) ...) (list (make-rib 'x '())))))
+    (test-ellipses '((1 (name x a)) ...)
+                   `(,(make-repeat '(1 (name x a)) (list (make-rib 'x '())))))
+    (test-ellipses '((any (name x a)) ...)
+                   `(,(make-repeat '(any (name x a)) (list (make-rib 'x '())))))
+    (test-ellipses '((number (name x a)) ...)
+                   `(,(make-repeat '(number (name x a)) (list (make-rib 'x '())))))
+    (test-ellipses '((variable (name x a)) ...)
+                   `(,(make-repeat '(variable (name x a)) (list (make-rib 'x '())))))
+    (test-ellipses '(((name x a) (name y b)) ...)
+                   `(,(make-repeat '((name x a) (name y b)) (list (make-rib 'y '()) (make-rib 'x '())))))
+    (test-ellipses '((name x (name y b)) ...)
+                   `(,(make-repeat '(name x (name y b)) (list (make-rib 'y '()) (make-rib 'x '())))))
+    (test-ellipses '((in-hole (name x a) (name y b)) ...)
+                   `(,(make-repeat '(in-hole (name x a) (name y b)) 
+                                   (list (make-rib 'x '()) (make-rib 'y '())))))
+    
+    (test-empty '() '() (list (make-mtch (make-bindings null) '() none)))
+    (test-empty '(a) '(a) (list (make-mtch (make-bindings null) '(a) none)))
+    (test-empty '(a) '(b) #f)
+    (test-empty '(a b) '(a b) (list (make-mtch (make-bindings null) '(a b) none)))
+    (test-empty '(a b) '(a c) #f)
+    (test-empty '() 1 #f)
+    (test-empty '(#f x) '(#f x) (list (make-mtch (make-bindings null) '(#f x) none)))
+    (test-empty '(#f (name y any)) '(#f) #f)
+    (test-empty '(in-hole (z hole) a) '(z a) (list (make-mtch (make-bindings (list)) '(z a) none)))
+    (test-empty '(in-hole (z hole) (in-hole (x hole) a)) 
+                '(z (x a))
+                (list (make-mtch (make-bindings (list)) '(z (x a)) none)))
+    
+    (test-empty '(in-named-hole h1 (z (hole h1)) a) 
+                '(z a)
+                (list (make-mtch (make-bindings (list)) '(z a) none)))
+    
+    (test-empty '(in-named-hole h1 (z (hole h1)) a) '(z a) (list (make-mtch (make-bindings (list)) '(z a) none)))
+    (test-empty '(in-named-hole c (any (hole c)) y)
+                '(x y)
+                (list (make-mtch (make-bindings (list)) '(x y) none)))
+    (test-empty '(in-named-hole a (in-named-hole b (x (hole b)) (hole a)) y)
+                '(x y)
+                (list (make-mtch (make-bindings (list)) '(x y) none)))
+    (test-empty '(in-hole (in-hole (x hole) hole) y)
+                '(x y)
+                (list (make-mtch (make-bindings (list)) '(x y) none)))
+    
+    (test-empty '((name x number) (name x number)) '(1 1) (list (make-mtch (make-bindings (list (make-rib 'x 1))) '(1 1) none)))
+    (test-empty '((name x number) (name x number)) '(1 2) #f)
+    
+    (test-empty '(a ...) '() (list (make-mtch (make-bindings empty) '() none)))
+    (test-empty '(a ...) '(a) (list (make-mtch (make-bindings empty) '(a) none)))
+    (test-empty '(a ...) '(a a) (list (make-mtch (make-bindings empty) '(a a) none)))
+    (test-empty '((name x a) ...) '() (list (make-mtch (make-bindings (list (make-rib 'x '()))) '() none)))
+    (test-empty '((name x a) ...) '(a) (list (make-mtch (make-bindings (list (make-rib 'x '(a)))) '(a) none)))
+    (test-empty '((name x a) ...) '(a a) (list (make-mtch (make-bindings (list (make-rib 'x '(a a)))) '(a a) none)))
+    
+    (test-empty '(b ... a ...) '() (list (make-mtch (make-bindings empty) '() none)))
+    (test-empty '(b ... a ...) '(a) (list (make-mtch (make-bindings empty) '(a) none)))
+    (test-empty '(b ... a ...) '(b) (list (make-mtch (make-bindings empty) '(b) none)))
+    (test-empty '(b ... a ...) '(b a) (list (make-mtch (make-bindings empty) '(b a) none)))
+    (test-empty '(b ... a ...) '(b b a a) (list (make-mtch (make-bindings empty) '(b b a a) none)))
+    (test-empty '(b ... a ...) '(a a) (list (make-mtch (make-bindings empty) '(a a) none)))
+    (test-empty '(b ... a ...) '(b b) (list (make-mtch (make-bindings empty) '(b b) none)))
+    
+    (test-empty '((name y b) ... (name x a) ...) '() 
+                (list (make-mtch (make-bindings (list (make-rib 'x '())
+                                                      (make-rib 'y '())))
+                                 '()
+                                 none)))
+    (test-empty '((name y b) ... (name x a) ...) '(a)
+                (list (make-mtch (make-bindings (list (make-rib 'x '(a))
+                                                      (make-rib 'y '())))
+                                 '(a)
+                                 none)))
+    (test-empty '((name y b) ... (name x a) ...) '(b) 
+                (list (make-mtch (make-bindings (list (make-rib 'x '())
+                                                      (make-rib 'y '(b))))
+                                 '(b)
+                                 none)))
+    (test-empty '((name y b) ... (name x a) ...) '(b b a a) 
+                (list (make-mtch (make-bindings (list (make-rib 'x '(a a))
+                                                      (make-rib 'y '(b b))))
+                                 '(b b a a)
+                                 none)))
+    (test-empty '((name y a) ... (name x a) ...) '(a) 
+                (list (make-mtch (make-bindings (list (make-rib 'x '())
+                                                      (make-rib 'y '(a))))
+                                 '(a)
+                                 none)
+                      (make-mtch (make-bindings (list (make-rib 'x '(a))
+                                                      (make-rib 'y '())))
+                                 '(a)
+                                 none)))
+    (test-empty '((name y a) ... (name x a) ...) '(a a) 
+                (list (make-mtch (make-bindings (list (make-rib 'x '())
+                                                      (make-rib 'y '(a a))))
+                                 '(a a)
+                                 none)
+                      (make-mtch (make-bindings (list (make-rib 'x '(a))
+                                                      (make-rib 'y '(a))))
+                                 '(a a)
+                                 none)
+                      (make-mtch (make-bindings (list (make-rib 'x '(a a))
+                                                      (make-rib 'y '())))
+                                 '(a a)
+                                 none)))
+
+    (test-ab '(bb_y ... aa_x ...) '() 
+             (list (make-mtch (make-bindings (list (make-rib 'aa_x '())
+                                                   (make-rib 'bb_y '())))
+                              '()
+                              none)))
+    (test-ab '(bb_y ... aa_x ...) '(a)
+             (list (make-mtch (make-bindings (list (make-rib 'aa_x '(a))
+                                                   (make-rib 'bb_y '())))
+                              '(a) 
+                              none)))
+    (test-ab '(bb_y ... aa_x ...) '(b) 
+             (list (make-mtch (make-bindings (list (make-rib 'aa_x '())
+                                                   (make-rib 'bb_y '(b))))
+                              '(b)
+                              none)))
+    (test-ab '(bb_y ... aa_x ...) '(b b a a) 
+             (list (make-mtch (make-bindings (list (make-rib 'aa_x '(a a))
+                                                   (make-rib 'bb_y '(b b))))
+                              '(b b a a)
+                              none)))
+    (test-ab '(aa_y ... aa_x ...) '(a) 
+             (list (make-mtch (make-bindings (list (make-rib 'aa_x '())
+                                                   (make-rib 'aa_y '(a))))
+                              '(a)
+                              none)
+                   (make-mtch (make-bindings (list (make-rib 'aa_x '(a))
+                                                   (make-rib 'aa_y '())))
+                              '(a)
+                              none)))
+    (test-ab '(aa_y ... aa_x ...) '(a a) 
+             (list (make-mtch (make-bindings (list (make-rib 'aa_x '())
+                                                   (make-rib 'aa_y '(a a))))
+                              '(a a)
+                              none)
+                   (make-mtch (make-bindings (list (make-rib 'aa_x '(a))
+                                                   (make-rib 'aa_y '(a))))
+                              '(a a)
+                              none)
+                   (make-mtch (make-bindings (list (make-rib 'aa_x '(a a))
+                                                   (make-rib 'aa_y '())))
+                              '(a a)
+                              none)))
+
+    (test-empty '((name x number) ...) '(1 2) (list (make-mtch (make-bindings (list (make-rib 'x '(1 2)))) '(1 2) none)))
+    
+    (test-empty '(a ...) '(b) #f)
+    (test-empty '(a ... b ...) '(c) #f)
+    (test-empty '(a ... b) '(b c) #f)
+    (test-empty '(a ... b) '(a b c) #f)
+    
+    (test-xab 'exp 1 (list (make-mtch (make-bindings null) 1 none)))
+    (test-xab 'exp '(+ 1 2) (list (make-mtch (make-bindings null) '(+ 1 2) none)))
+    (test-xab '(in-hole ctxt any)
+              '1
+              (list (make-mtch (make-bindings (list)) 1 none)))
+    (test-xab '(in-hole ctxt (name x any))
+              '1
+              (list (make-mtch (make-bindings (list (make-rib 'x 1))) 1 none)))
+    (test-xab '(in-hole (name c ctxt) (name x any))
+              '(+ 1 2)
+              (list (make-mtch (make-bindings (list (make-rib 'c hole) (make-rib 'x '(+ 1 2)))) '(+ 1 2) none)
+                    (make-mtch (make-bindings (list (make-rib 'c `(+ ,hole 2)) (make-rib 'x 1))) '(+ 1 2) none)
+                    (make-mtch (make-bindings (list (make-rib 'c `(+ 1 ,hole)) (make-rib 'x 2))) '(+ 1 2) none)))
+    (test-xab '(in-hole (name c ctxt) (name i (+ number number)))
+              '(+ (+ 1 2) (+ 3 4))
+              (list (make-mtch (make-bindings (list (make-rib 'i '(+ 1 2)) (make-rib 'c `(+ ,hole (+ 3 4)))))
+                               '(+ (+ 1 2) (+ 3 4))
+                               none)
+                    (make-mtch (make-bindings (list (make-rib 'i '(+ 3 4)) (make-rib 'c `(+ (+ 1 2) ,hole))))
+                               '(+ (+ 1 2) (+ 3 4))
+                               none)))
+    
+    (test-empty '(in-hole ((z hole)) (name x any))
+                '((z a))
+                (list (make-mtch (make-bindings (list (make-rib 'x 'a))) '((z a)) none)))
+    (test-empty '(in-hole (name c (z ... hole z ...)) any)
+                '(z z)
+                (list 
+                 (make-mtch (make-bindings (list (make-rib 'c `(z ,hole)))) '(z z) none)
+                 (make-mtch (make-bindings (list (make-rib 'c `(,hole z)))) '(z z) none)))
+    (test-empty '(in-hole (name c (z ... hole z ...)) any)
+                '(z z z)
+                (list 
+                 (make-mtch (make-bindings (list (make-rib 'c `(z z ,hole)))) '(z z z) none)
+                 (make-mtch (make-bindings (list (make-rib 'c `(z ,hole z)))) '(z z z) none)
+                 (make-mtch (make-bindings (list (make-rib 'c `(,hole z z)))) '(z z z) none)))
+    
+    (test-empty '(z (in-hole (name c (z hole)) a))
+                '(z (z a))
+                (list 
+                 (make-mtch (make-bindings (list (make-rib 'c `(z ,hole))))
+                            '(z (z a))
+                            none)))
+    
+    (test-empty '(a (in-hole (name c1 (b (in-hole (name c2 (c hole)) d) hole)) e))
+                '(a (b (c d) e))
+                (list 
+                 (make-mtch (make-bindings (list (make-rib 'c2 `(c ,hole))
+                                                 (make-rib 'c1 `(b (c d) ,hole))))
+                            '(a (b (c d) e))
+                            none)))
+
+    (test-empty '(in-hole (in-hole hole hole) a)
+                'a
+                (list (make-mtch (make-bindings (list)) 'a none)))
+    
+    (test-empty '(a (b (in-hole (name c1 (in-hole (name c2 (c hole)) (d hole))) e)))
+                '(a (b (c (d e))))
+                (list 
+                 (make-mtch (make-bindings (list (make-rib 'c1 `(c (d ,hole)))
+                                                 (make-rib 'c2 `(c ,hole))))
+                            '(a (b (c (d e))))
+                            none)))
+    
+    (test-empty `(+ 1 (side-condition any ,(lambda (bindings) #t)))
+                '(+ 1 b)
+                (list (make-mtch (make-bindings '()) '(+ 1 b) none)))
+    (test-empty `(+ 1 (side-condition any ,(lambda (bindings) #f)))
+                '(+ 1 b)
+                #f)
+    
+    (test-empty `(+ 1 (side-condition b ,(lambda (bindings) #t)))
+                '(+ 1 b)
+                (list (make-mtch (make-bindings '()) '(+ 1 b) none)))
+    (test-empty `(+ 1 (side-condition a ,(lambda (bindings) #t)))
+                '(+ 1 b)
+                #f)
+
+    (test-empty `(side-condition (name x any) ,(lambda (bindings) (eq? (lookup-binding bindings 'x) 'a)))
+                'a
+                (list 
+                 (make-mtch (make-bindings (list (make-rib 'x 'a)))
+                            'a
+                            none)))
+
+    (test-empty `(+ 1 (side-condition (name x any) ,(lambda (bindings) (eq? (lookup-binding bindings 'x) 'a))))
+                '(+ 1 a)
+                (list 
+                 (make-mtch (make-bindings (list (make-rib 'x 'a)))
+                            '(+ 1 a)
+                            none)))
+
+    (test-empty `(side-condition (name x any) ,(lambda (bindings) (eq? (lookup-binding bindings 'x) 'a)))
+                'b
+                #f)
+    
+    (test-empty `(+ 1 (side-condition (name x any) ,(lambda (bindings) (eq? (lookup-binding bindings 'x) 'a))))
+                '(+ 1 b)
+                #f)
+    
+    (test-xab 'exp_1
+              '(+ 1 2)
+              (list (make-mtch (make-bindings (list (make-rib 'exp_1 '(+ 1 2)))) '(+ 1 2) none)))
+    (test-xab '(exp_1 exp_2)
+              '((+ 1 2) (+ 3 4))
+              (list (make-mtch (make-bindings (list (make-rib 'exp_1 '(+ 1 2)) (make-rib 'exp_2 '(+ 3 4))))
+                               '((+ 1 2) (+ 3 4))
+                               none)))
+    (test-xab '(exp_1 exp_1)
+              '((+ 1 2) (+ 3 4))
+              #f)
+    (test-xab 'nesting-names
+              'b
+              (list (make-mtch (make-bindings (list)) 'b none)))
+    (test-xab 'nesting-names
+              '(a b)
+              (list (make-mtch (make-bindings (list)) '(a b) none)))
+    (test-xab 'nesting-names
+              '(a (a b))
+              (list (make-mtch (make-bindings (list)) '(a (a b)) none)))
+    (test-xab '((name x a) nesting-names)
+              '(a (a (a b)))
+              (list (make-mtch (make-bindings (list (make-rib 'x 'a))) '(a (a (a b))) none)))
+    (test-xab 'nesting-names
+              '(a (a (a (a b))))
+              (list (make-mtch (make-bindings (list)) '(a (a (a (a b)))) none)))
+    
+    (test-xab 'same-in-nt
+              '(x x)
+              (list (make-mtch (make-bindings (list)) '(x x) none)))
+    (test-xab 'same-in-nt
+              '(x y)
+              #f)
+     
+    #;
+    (test-xab '(in-hole ec-multi (+ number number))
+              '(+ 1 2)
+              (list (make-bindings (list (make-rib 'hole (make-hole-binding '(+ 1 2) '() #f))))))
+    
+    #;
+    (test-xab '(in-hole ec-multi (+ number number))
+              '(+ 1 (+ 5 6))
+              (list (make-bindings (list (make-rib 'hole (make-hole-binding '(+ 5 6) '(cdr cdr car) #f))))))
+    
+    #;
+    (test-xab '(in-hole ec-multi (+ number number))
+              '(+ (+ (+ 1 2) 3) 4)
+              (list (make-bindings (list (make-rib 'hole (make-hole-binding '(+ 1 2) '(cdr car cdr car) #f))))))
+    
+    #;
+    (test-xab '(in-hole ec-multi (+ number number))
+              '(+ (+ 3 (+ 1 2)) 4)
+              (list (make-bindings (list (make-rib 'hole (make-hole-binding '(+ 1 2) '(cdr car cdr cdr car) #f))))))
+    
+    #;
+    (test-xab '(in-hole ec-multi (+ number number))
+              '(+ (+ (+ 1 2) (+ 3 4)) (+ 5 6))
+              (list (make-bindings (list (make-rib 'hole (make-hole-binding '(+ 5 6) '(cdr cdr car) #f))))
+                    (make-bindings (list (make-rib 'hole (make-hole-binding '(+ 1 2) '(cdr car cdr car) #f))))
+                    (make-bindings (list (make-rib 'hole (make-hole-binding '(+ 3 4) '(cdr car cdr cdr car) #f))))))
+    
+    (run-test
+     'compatible-context-language1
+     (build-compatible-context-language
+      (mk-hasheq '((exp . ()) (ctxt . ())))
+      (list (make-nt 'exp
+                     (list (make-rhs '(+ exp exp))
+                           (make-rhs 'number)))
+            (make-nt 'ctxt
+                     (list (make-rhs '(+ ctxt exp))
+                           (make-rhs '(+ exp ctxt))
+                           (make-rhs 'hole)))))
+     (list
+      (make-nt 'exp-exp 
+               (list (make-rhs 'hole) 
+                     (make-rhs `(+ (cross exp-exp) exp)) 
+                     (make-rhs `(+ exp (cross exp-exp)))))
+      (make-nt 'exp-ctxt
+               (list (make-rhs `(+ (cross exp-ctxt) exp))
+                     (make-rhs `(+ ctxt (cross exp-exp)))
+                     (make-rhs `(+ (cross exp-exp) ctxt))
+                     (make-rhs `(+ exp (cross exp-ctxt)))))
+      (make-nt 'ctxt-exp
+               (list (make-rhs `(+ (cross ctxt-exp) exp))
+                     (make-rhs `(+ exp (cross ctxt-exp)))))
+      (make-nt 'ctxt-ctxt
+               (list (make-rhs 'hole)
+                     (make-rhs `(+ (cross ctxt-ctxt) exp))
+                     (make-rhs `(+ ctxt (cross ctxt-exp)))
+                     (make-rhs `(+ (cross ctxt-exp) ctxt))
+                     (make-rhs `(+ exp (cross ctxt-ctxt)))))))
+    
+    (run-test
+     'compatible-context-language2
+     (build-compatible-context-language
+      (mk-hasheq '((m . ()) (v . ())))
+      (list (make-nt 'm (list (make-rhs '(m m)) (make-rhs '(+ m m)) (make-rhs 'v)))
+            (make-nt 'v (list (make-rhs 'number) (make-rhs '(lambda (x) m))))))
+     (list
+      (make-nt 'm-m
+               (list
+                (make-rhs 'hole)
+                (make-rhs (list (list 'cross 'm-m) 'm))
+                (make-rhs (list 'm (list 'cross 'm-m)))
+                (make-rhs (list '+ (list 'cross 'm-m) 'm))
+                (make-rhs (list '+ 'm (list 'cross 'm-m)))
+                (make-rhs (list 'cross 'm-v))))
+      (make-nt 'm-v (list (make-rhs (list 'lambda (list 'x) (list 'cross 'm-m)))))
+      (make-nt 'v-m
+               (list
+                (make-rhs (list (list 'cross 'v-m) 'm))
+                (make-rhs (list 'm (list 'cross 'v-m)))
+                (make-rhs (list '+ (list 'cross 'v-m) 'm))
+                (make-rhs (list '+ 'm (list 'cross 'v-m)))
+                (make-rhs (list 'cross 'v-v))))
+      (make-nt 'v-v (list (make-rhs 'hole) (make-rhs (list 'lambda (list 'x) (list 'cross 'v-m)))))))
+    
+    (run-test
+     'compatible-context-language3
+     (build-compatible-context-language
+      (mk-hasheq '((m . ()) (seven . ())))
+      (list (make-nt 'm (list (make-rhs '(m seven m)) (make-rhs 'number)))
+            (make-nt 'seven (list (make-rhs 7)))))
+     `(,(make-nt
+         'm-m
+         `(,(make-rhs 'hole) ,(make-rhs `((cross m-m) seven m)) ,(make-rhs `(m (cross m-seven) m)) ,(make-rhs `(m seven (cross m-m)))))
+       ,(make-nt 'm-seven `())
+       ,(make-nt
+         'seven-m
+         `(,(make-rhs `((cross seven-m) seven m)) ,(make-rhs `(m (cross seven-seven) m)) ,(make-rhs `(m seven (cross seven-m)))))
+       ,(make-nt 'seven-seven `(,(make-rhs 'hole)))))
+    
+    #;
+    (test-xab '(in-hole (cross exp) (+ number number))
+              '(+ (+ 1 2) 3)
+              (list (make-bindings (list (make-rib 'hole (make-hole-binding (list '+ 1 2) (list 'cdr 'car) #f))))))
+    
+    (unless failure?
+      (fprintf (current-error-port) "All ~a tests passed.\n" test-count)))
+
+  ;; mk-hasheq : (listof (cons sym any)) -> hash-table
+  ;; builds a hash table that has the bindings in assoc-list
+  (define (mk-hasheq assoc-list)
+    (let ([ht (make-hash-table)])
+      (for-each
+       (lambda (a)
+         (hash-table-put! ht (car a) (cdr a)))
+       assoc-list)
+      ht))
+  
+  ;; test-empty : sexp[pattern] sexp[term] answer -> void
+  ;; returns #t if pat matching exp with the empty language produces ans.
+  (define (test-empty pat exp ans)
+    (run-match-test
+     `(match-pattern (compile-pattern (compile-language '()) ',pat) ',exp)
+     (match-pattern 
+      (compile-pattern (compile-language '()) pat)
+      exp)
+     ans))
+  
+  (define xab-lang #f)
+  ;; test-xab : sexp[pattern] sexp[term] answer -> void
+  ;; returns #t if pat matching exp with a simple language produces ans.
+  (define (test-xab pat exp ans)
+    (unless xab-lang
+      (set! xab-lang
+            (compile-language (list (make-nt 'exp
+                                             (list (make-rhs '(+ exp exp))
+                                                   (make-rhs 'number)))
+                                    (make-nt 'ctxt
+                                             (list (make-rhs '(+ ctxt exp))
+                                                   (make-rhs '(+ exp ctxt))
+                                                   (make-rhs 'hole)))
+                                    
+                                    (make-nt 'ec-multi
+                                             (list (make-rhs 'hole)
+                                                   (make-rhs '(in-named-hole xx ec-one ec-multi))))
+                                    (make-nt 'ec-one
+                                             (list (make-rhs '(+ (hole xx) exp))
+                                                   (make-rhs '(+ exp (hole xx)))))
+
+                                    (make-nt 'same-in-nt (list (make-rhs '((name x any) (name x any)))))
+                                    
+                                    (make-nt 'nesting-names
+                                             (list (make-rhs '(a (name x nesting-names)))
+                                                   (make-rhs 'b)))))))
+    (run-match-test
+     `(match-pattern (compile-pattern xab-lang ',pat) ',exp)
+     (match-pattern (compile-pattern xab-lang pat) exp)
+     ans))
+  
+  (define ab-lang #f)
+  ;; test-xab : sexp[pattern] sexp[term] answer -> void
+  ;; returns #t if pat matching exp with a simple language produces ans.
+  (define (test-ab pat exp ans)
+    (unless ab-lang
+      (set! ab-lang
+            (compile-language (list (make-nt 'aa
+                                             (list (make-rhs 'a)))
+                                    (make-nt 'bb
+                                             (list (make-rhs 'b)))))))
+    (run-match-test
+     `(match-pattern (compile-pattern ab-lang ',pat) ',exp)
+     (match-pattern (compile-pattern ab-lang pat) exp)
+     ans))
+  
+  ;; test-ellipses : sexp sexp -> void
+  (define (test-ellipses pat expected)
+    (run-test
+     `(rewrite-ellipses ',pat (lambda (x) (values x #f)))
+     (let-values ([(compiled-pattern has-hole?) (rewrite-ellipses pat (lambda (x) (values x #f)))])
+       (cons compiled-pattern has-hole?))
+     (cons expected #f)))
+  
+  ;; run-test/cmp : sexp any any (any any -> boolean)
+  ;; compares ans with expected. If failure,
+  ;; prints info about the test and sets `failure?' to #t.
+  (define failure? #f)
+  (define test-count 0)
+  (define (run-test/cmp symbolic ans expected cmp?)
+    (set! test-count (+ test-count 1))
+    (cond
+      [(cmp? ans expected)
+       '(printf "passed: ~s\n" symbolic)]
+      [else 
+       (set! failure? #t)
+       (fprintf (current-error-port)
+                "    test: ~s\nexpected: ~e\n     got: ~e\n"
+                symbolic expected ans)]))
+  
+  (define (run-test symbolic ans expected) (run-test/cmp symbolic ans expected equal/bindings?))
+  
+  ;; run-match-test : sexp got expected
+  ;;   expects both ans and expected to be lists or both to be #f and
+  ;;   compares them using a set-like equality if they are lists
+  (define (run-match-test symbolic ans expected)
+    (run-test/cmp
+     symbolic ans expected
+     (λ (xs ys)
+       (cond
+         [(and (not xs) (not ys)) #t]
+         [(and (list? xs)
+               (list? ys))
+          (and (andmap (λ (x) (memf (λ (y) (equal/bindings? x y)) ys)) xs)
+               (andmap (λ (y) (memf (λ (x) (equal/bindings? x y)) xs)) ys))]
+         [else #f]))))
+  
+  ;; equal/bindings? : any any -> boolean
+  ;; compares two sexps (with embedded bindings) for equality.
+  ;; uses an order-insensitive comparison for the bindings
+  (define (equal/bindings? fst snd)
+    (let loop ([fst fst]
+               [snd snd])
+      (cond
+        [(pair? fst)
+         (and (pair? snd) 
+              (loop (car fst) (car snd))
+              (loop (cdr fst) (cdr snd)))]
+        [(and (mtch? fst)
+              (mtch? snd))
+         (and (loop (mtch-bindings fst)
+                    (mtch-bindings snd))
+              (equal? (mtch-context fst)
+                      (mtch-context snd))
+              (equal? (mtch-hole fst)
+                      (mtch-hole snd)))]
+        [(bindings? fst)
+         (and (bindings? snd)
+              (let ([fst-table (bindings-table fst)]
+                    [snd-table (bindings-table snd)])
+                (and (= (length fst-table)
+                        (length snd-table))
+                     (andmap
+                      loop
+                      (quicksort fst-table rib-lt)
+                      (quicksort snd-table rib-lt)))))]
+        [else (equal? fst snd)])))
+  
+  ;; rib-lt : rib rib -> boolean
+  (define (rib-lt r1 r2) (string<=? (format "~s" (rib-name r1))
+                                    (format "~s" (rib-name r2))))
+  
+  (test))
diff --git a/collects/reduction-semantics/private/matcher.ss b/collects/reduction-semantics/private/matcher.ss
new file mode 100644
index 0000000000..b7e1d97bec
--- /dev/null
+++ b/collects/reduction-semantics/private/matcher.ss
@@ -0,0 +1,909 @@
+#|
+
+Note: the patterns described in the doc.txt file are
+slightly different than the patterns processed here.
+The difference is in the form of the side-condition
+expressions. Here they are procedures that accept
+binding structures, instead of expressions. The
+reduction (And other) macros do this transformation
+before the pattern compiler is invoked.
+
+|#
+(module matcher mzscheme
+  (require (lib "list.ss")
+           (lib "match.ss")
+           (lib "etc.ss")
+           (lib "contract.ss"))
+  
+  ;; lang = (listof nt)
+  ;; nt = (make-nt sym (listof rhs))
+  ;; rhs = (make-rhs single-pattern)
+  ;; single-pattern = sexp
+  (define-struct nt (name rhs) (make-inspector))
+  (define-struct rhs (pattern) (make-inspector))
+  
+  ;; var = (make-var sym sexp)
+  ;; patterns are sexps with `var's embedded
+  ;; in them. It means to match the
+  ;; embedded sexp and return that binding
+  
+  ;; bindings = (make-bindings (listof rib))
+  ;; rib = (make-rib sym sexp)
+  ;; if a rib has a pair, the first element of the pair should be treated as a prefix on the identifer
+  (define-values (make-bindings bindings-table bindings?)
+    (let () 
+      (define-struct bindings (table) (make-inspector)) ;; for testing, add inspector
+      (values (lambda (table)
+                (unless (and (list? table)
+                             (andmap rib? table))
+                  (error 'make-bindings "expected <(listof rib)>, got ~e" table))
+                (make-bindings table))
+              bindings-table
+              bindings?)))
+  
+  (define-struct rib (name exp) (make-inspector)) ;; for testing, add inspector
+  
+  ;; repeat = (make-repeat compiled-pattern (listof rib))
+  (define-struct repeat (pat empty-bindings) (make-inspector)) ;; inspector for tests below
+  
+  ;; compiled-pattern : exp (union #f none sym) -> (union #f (listof mtch))
+  ;; mtch = (make-match bindings sexp[context w/none-inside for the hole] (union none sexp[hole]))
+  ;; mtch is short for "match"
+  (define-values (mtch-bindings mtch-context mtch-hole make-mtch mtch?)
+    (let ()
+      (define-struct mtch (bindings context hole) (make-inspector))
+      (values mtch-bindings
+              mtch-context
+              mtch-hole
+              (lambda (a b c)
+                (unless (bindings? a)
+                  (error 'make-mtch "expected bindings for first agument, got ~e" a))
+                (make-mtch a b c))
+              mtch?)))
+  ;; used to mean no context is available; also used as the "name" for an unnamed (ie, normal) hole
+  (define none
+    (let ()
+      (define-struct none ())
+      (make-none)))
+  (define (none? x) (eq? x none))
+  (define hole
+    (let ()
+      (define-struct hole ())
+      (make-hole)))
+  
+  ;; compiled-lang : (make-compiled-lang (listof nt) 
+  ;;                                     hash-table[sym -o> compiled-pattern]
+  ;;                                     hash-table[sym -o> compiled-pattern]
+  ;;                                     hash-table[sym -o> boolean])
+  ;;                                     hash-table[sexp[pattern] -o> (cons compiled-pattern boolean)])
+  ;; hole-info = (union #f none symbol)
+  ;;               #f means we're not in a `in-hole' context
+  ;;               none means we're looking for a normal hole
+  ;;               symbol means we're looking for a named hole named by the symbol
+  (define compiled-pattern (any/c (union false/c none? symbol?) . -> . (union false/c (listof mtch?))))
+  
+  (define-struct compiled-lang (lang ht across-ht has-hole-ht cache))
+  
+  ;; lookup-binding : bindings (union sym (cons sym sym)) [(-> any)] -> any
+  (define lookup-binding 
+    (opt-lambda (bindings
+		 sym
+		 [fail (lambda () (error 'lookup-binding "didn't find ~e in ~e" sym bindings))])
+      (let loop ([ribs (bindings-table bindings)])
+        (cond
+          [(null? ribs) (fail)]
+          [else
+           (let ([rib (car ribs)])
+             (if (equal? (rib-name rib) sym)
+                 (rib-exp rib)
+                 (loop (cdr ribs))))]))))
+  
+  ;; compile-language : lang -> compiled-lang
+  (define (compile-language lang)
+    (let* ([clang-ht (make-hash-table)]
+           [across-ht (make-hash-table)]
+           [has-hole-ht (build-has-hole-ht lang)]
+           [cache (make-hash-table 'equal)]
+           [clang (make-compiled-lang lang clang-ht across-ht has-hole-ht cache)]
+           [do-compilation
+            (lambda (ht lang prefix-cross?)
+              (for-each
+               (lambda (nt)
+                 (for-each
+                  (lambda (rhs)
+                    (let-values ([(compiled-pattern has-hole?) 
+                                  (compile-pattern/cross? clang (rhs-pattern rhs) prefix-cross?)])
+                      (hash-table-put!
+                       ht
+                       (nt-name nt)
+                       (cons compiled-pattern
+                             (hash-table-get ht (nt-name nt))))))
+                  (nt-rhs nt)))
+               lang))])
+      
+      (for-each (lambda (nt)
+                  (hash-table-put! clang-ht (nt-name nt) null))
+                lang)
+      (hash-table-for-each
+       clang-ht
+       (lambda (nt rhs)
+         (when (has-underscore? nt)
+           (error 'compile-language "cannot use underscore in nonterminal name, ~s" nt))))
+      
+      (let ([compatible-context-language
+             (build-compatible-context-language clang-ht lang)])
+        (for-each (lambda (nt)
+                    (hash-table-put! across-ht (nt-name nt) null))
+                  compatible-context-language)
+        (do-compilation clang-ht lang #t)
+        (do-compilation across-ht compatible-context-language #f)
+        clang)))
+  
+  ; build-has-hole-ht : (listof nt) -> hash-table[symbol -o> boolean]
+  ; produces a map of nonterminal -> whether that nonterminal could produce a hole
+  (define (build-has-hole-ht lang)
+    (let ([has-hole-ht (make-hash-table)])
+      (for-each
+       (lambda (nt) (hash-table-put! has-hole-ht (nt-name nt) #t))
+       lang)
+      has-hole-ht))
+  
+  ;; build-compatible-context-language : lang -> lang
+  (define (build-compatible-context-language clang-ht lang)
+    (apply
+     append
+     (map 
+      (lambda (nt1)
+        (map
+         (lambda (nt2)
+           (let ([compat-nt (build-compatible-contexts/nt clang-ht (nt-name nt1) nt2)])
+             (if (eq? (nt-name nt1) (nt-name nt2))
+                 (make-nt (nt-name compat-nt)
+                          (cons
+                           (make-rhs 'hole)
+                           (nt-rhs compat-nt)))
+                 compat-nt)))
+         lang))
+      lang)))
+    
+  ;; build-compatible-contexts : clang-ht prefix nt -> nt
+  ;; constructs the compatible closure evaluation context from nt.
+  (define (build-compatible-contexts/nt clang-ht prefix nt)
+    (make-nt
+     (symbol-append prefix '- (nt-name nt))
+     (apply append
+            (map
+             (lambda (rhs)
+               (let-values ([(maker count) (build-compatible-context-maker clang-ht
+                                                                           (rhs-pattern rhs)
+                                                                           prefix)])
+                 (let loop ([i count])
+                   (cond
+                     [(zero? i) null]
+                     [else (let ([nts (build-across-nts (nt-name nt) count (- i 1))])
+                             (cons (make-rhs (maker (box nts)))
+                                   (loop (- i 1))))]))))
+             (nt-rhs nt)))))
+    
+  (define (symbol-append . args)
+    (string->symbol (apply string-append (map symbol->string args))))
+  
+  ;; build-across-nts : symbol number number -> (listof pattern)
+  (define (build-across-nts nt count i)
+    (let loop ([j count])
+      (cond
+        [(zero? j) null]
+        [else
+         (cons (= i (- j 1)) 
+               (loop (- j 1)))])))
+    
+  ;; build-compatible-context-maker : symbol pattern -> (values ((box (listof pattern)) -> pattern) number)
+  ;; when the result function is applied, it takes each element
+  ;; of the of the boxed list and plugs them into the places where
+  ;; the nt corresponding from this rhs appeared in the original pattern. 
+  ;; The number result is the number of times that the nt appeared in the pattern.
+  (define (build-compatible-context-maker clang-ht pattern prefix)
+    (let ([count 0])
+      (values
+       (let loop ([pattern pattern])
+         (match pattern
+           [`any (lambda (l) 'any)]
+           [`number (lambda (l) 'number)]
+           [`string (lambda (l) 'string)]
+           [`variable (lambda (l) 'variable)] 
+           [`(variable-except ,@(vars ...)) (lambda (l) pattern)]
+           [`hole  (lambda (l) 'hole)]
+           [`(hole ,(? symbol? hole-name)) (lambda (l) `(hole ,hole-name))]
+           [(? string?) (lambda (l) pattern)]
+           [(? symbol?) 
+            (cond
+              [(hash-table-get clang-ht pattern (lambda () #f))
+               (set! count (+ count 1))
+               (lambda (l)
+                 (let ([fst (car (unbox l))])
+                   (set-box! l (cdr (unbox l)))
+                   (if fst
+                       `(cross ,(symbol-append prefix '- pattern))
+                       pattern)))]
+              [else
+               (lambda (l) pattern)])]
+           [`(name ,name ,pat)
+            (let ([patf (loop pat)])
+              (lambda (l)
+                `(name ,name ,(patf l))))]
+           [`(in-hole ,context ,contractum)
+            (let ([match-context (loop context)]
+                  [match-contractum (loop contractum)])
+              (lambda (l)
+                `(in-hole ,(match-context l)
+                          ,(match-contractum l))))]
+           [`(in-named-hole ,hole-name ,context ,contractum)
+            (let ([match-context (loop context)]
+                  [match-contractum (loop contractum)])
+              (lambda (l)
+                `(in-named-hole ,hole-name
+                                ,(match-context l)
+                                ,(match-contractum l))))]
+           [`(side-condition ,pat ,condition)
+            (let ([patf (loop pat)])
+              (lambda (l)
+                `(side-condition ,(patf l) ,condition)))]
+           [(? list?)
+            (let ([fs (map loop pattern)])
+              (lambda (l)
+                (map (lambda (f) (f l)) fs)))]
+           [else 
+            (lambda (l) pattern)]))
+       count)))
+  
+  ;; match-pattern : compiled-pattern exp -> (union #f (listof bindings))
+  (define (match-pattern compiled-pattern exp)
+    (let ([results (compiled-pattern exp #f)])
+      (and results
+           (let ([filtered (filter-multiples results)])
+             (and (not (null? filtered))
+                  filtered)))))
+  
+  ;; filter-multiples : (listof mtch) -> (listof mtch)
+  (define (filter-multiples matches)
+    (let loop ([matches matches]
+               [acc null])
+      (cond
+        [(null? matches) acc]
+        [else
+         (let ([merged (merge-multiples/remove (car matches))])
+           (if merged
+               (loop (cdr matches) (cons merged acc))
+               (loop (cdr matches) acc)))])))
+  
+  ;; merge-multiples/remove : bindings -> (union #f bindings)
+  ;; returns #f if all duplicate bindings don't bind the same thing
+  ;; returns a new bindings 
+  (define (merge-multiples/remove match)
+    (let/ec fail
+      (let ([ht (make-hash-table 'equal)]
+            [ribs (bindings-table (mtch-bindings match))])
+        (for-each
+         (lambda (rib)
+           (let/ec new
+             (let ([name (rib-name rib)]
+                   [exp (rib-exp rib)])
+               (let ([previous-exp
+                      (hash-table-get 
+                       ht 
+                       name
+                       (lambda ()
+                         (hash-table-put! ht name exp)
+                         (new (void))))])
+                 (unless (equal? exp previous-exp)
+                   (fail #f))))))
+         ribs)
+        (make-mtch
+         (make-bindings (hash-table-map ht make-rib))
+         (mtch-context match)
+         (mtch-hole match)))))
+  
+  (define underscore-allowed '(any number string variable))
+
+  ;; compile-pattern : compiled-lang pattern -> compiled-pattern
+  (define compile-pattern
+    (opt-lambda (clang pattern)
+      (let-values ([(pattern has-hole?) (compile-pattern/cross? clang pattern #t)])
+        pattern)))
+  
+  ;; compile-pattern : compiled-lang pattern boolean -> (values compiled-pattern boolean)
+  (define (compile-pattern/cross? clang pattern prefix-cross?)
+    (define clang-ht (compiled-lang-ht clang))
+    (define has-hole-ht (compiled-lang-has-hole-ht clang))
+    (define across-ht (compiled-lang-across-ht clang))
+    (define compiled-pattern-cache (compiled-lang-cache clang))
+    
+    (define (compile-pattern/cache pattern)
+      (let ([compiled-cache (hash-table-get
+                             compiled-pattern-cache
+                             pattern
+                             (lambda ()
+                               (let-values ([(compiled-pattern has-hole?)
+                                             (true-compile-pattern pattern)])
+                                 (let ([val (cons (memoize compiled-pattern has-hole?) has-hole?)])
+                                   (hash-table-put! compiled-pattern-cache pattern val)
+                                   val))))])
+        (values (car compiled-cache) (cdr compiled-cache))))
+  
+    ;; consult-compiled-pattern-cache : sexp[pattern] (-> compiled-pattern) -> compiled-pattern
+    (define (consult-compiled-pattern-cache pattern calc)
+      (hash-table-get 
+       compiled-pattern-cache
+       pattern
+       (lambda ()
+         (let ([res (calc)])
+           (hash-table-put! compiled-pattern-cache pattern res)
+           res))))
+    
+    (define (true-compile-pattern pattern)
+      (match pattern
+        [`any
+          (values
+           (lambda (exp hole-info) (list (make-mtch (make-bindings null) exp none)))
+           #f)]
+        [`number 
+          (values 
+           (lambda (exp hole-info) (and (number? exp) (list (make-mtch (make-bindings null) exp none))))
+           #f)]
+        [`string
+          (values 
+           (lambda (exp hole-info) (and (string? exp) (list (make-mtch (make-bindings null) exp none))))
+           #f)]
+        [`variable 
+          (values
+           (lambda (exp hole-info)
+             (and (symbol? exp) (list (make-mtch (make-bindings null) exp none))))
+           #f)]
+        [`(variable-except ,@(vars ...))
+          (values
+           (lambda (exp hole-info)
+             (and (symbol? exp)
+                  (not (memq exp vars))
+                  (list (make-mtch (make-bindings null) exp none))))
+           #f)]
+        [`hole (values (match-hole none) #t)]
+        [`(hole ,hole-id) (values (match-hole hole-id) #t)]
+        [(? string?) 
+         (values
+          (lambda (exp hole-info)
+            (and (string? exp)
+                 (string=? exp pattern)
+                 (list (make-mtch (make-bindings null) exp none))))
+          #f)]
+        [(? symbol?)
+         (cond
+           [(hash-table-maps? clang-ht pattern)
+            (values
+             (lambda (exp hole-info)
+               (match-nt clang-ht pattern exp hole-info))
+             (hash-table-get has-hole-ht pattern))]
+           [(has-underscore? pattern)
+            (let ([before (split-underscore pattern)])
+              (unless (or (hash-table-maps? clang-ht before)
+                          (memq before underscore-allowed))
+                (error 'compile-pattern "before underscore must be either a non-terminal or a built-in pattern, found ~a in ~s" 
+                       before
+                       pattern))
+              (compile-pattern/cache `(name ,pattern ,before)))]
+           [else
+            (values
+             (lambda (exp hole-info) (and (eq? exp pattern) (list (make-mtch (make-bindings null) exp none))))
+             #f)])]
+        
+        [`(cross ,(? symbol? pre-id))
+          (let ([id (if prefix-cross?
+                        (symbol-append pre-id '- pre-id)
+                        pre-id)])
+            (cond
+              [(hash-table-get across-ht id (lambda () #f))
+               (values
+                (lambda (exp hole-info)
+                  (match-nt across-ht id exp hole-info))
+                #t)]
+              [else
+               (error 'compile-pattern "unknown cross reference ~a" id)]))]
+        
+        [`(name ,name ,pat)
+          (let-values ([(match-pat has-hole?) (compile-pattern/cache pat)])
+            (values
+             (lambda (exp hole-info)
+               (let ([matches (match-pat exp hole-info)])
+                 (and matches 
+                      (map (lambda (match)
+                             (make-mtch
+                              (make-bindings (cons (make-rib name (mtch-context match))
+                                                   (bindings-table (mtch-bindings match))))
+                              (mtch-context match)
+                              (mtch-hole match)))
+                           matches))))
+             has-hole?))]
+        [`(in-hole ,context ,contractum) 
+          (let-values ([(match-context ctxt-has-hole?) (compile-pattern/cache context)]
+                       [(match-contractum contractum-has-hole?) (compile-pattern/cache contractum)])
+            (values
+             (match-in-hole context contractum exp match-context match-contractum none)
+             (or ctxt-has-hole? contractum-has-hole?)))]
+        [`(in-named-hole ,hole-id ,context ,contractum) 
+          (let-values ([(match-context ctxt-has-hole?) (compile-pattern/cache context)]
+                       [(match-contractum contractum-has-hole?) (compile-pattern/cache contractum)])
+            (values
+             (match-in-hole context contractum exp match-context match-contractum hole-id)
+             (or ctxt-has-hole? contractum-has-hole?)))]
+        
+        [`(side-condition ,pat ,condition)
+          (let-values ([(match-pat has-hole?) (compile-pattern/cache pat)])
+            (values
+             (lambda (exp hole-info)
+               (let ([matches (match-pat exp hole-info)])
+                 (and matches
+                      (let ([filtered (filter (λ (m) (condition (mtch-bindings m))) matches)])
+                        (if (null? filtered)
+                            #f
+                            filtered)))))
+             has-hole?))]
+        [(? list?)
+         (let-values ([(rewritten has-hole?) (rewrite-ellipses pattern compile-pattern/cache)])
+           (values
+            (lambda (exp hole-info)
+              (match-list rewritten exp hole-info))
+            has-hole?))]
+        
+        ;; an already comiled pattern
+        [(? procedure?)
+         pattern]
+        
+        [else 
+         (values
+          (lambda (exp hole-info)
+            (and (eqv? pattern exp)
+                 (list (make-mtch (make-bindings null) exp none))))
+          #f)]))
+    
+    (compile-pattern/cache pattern))
+  
+
+  ;; split-underscore : symbol -> symbol
+  ;; returns the text before the underscore in a symbol (as a symbol)
+  ;; raise an error if there is more than one underscore in the input
+  (define (split-underscore sym)
+    (string->symbol
+     (list->string
+      (let loop ([chars (string->list (symbol->string sym))])
+        (cond
+          [(null? chars) (error 'split-underscore "bad")]
+          [else
+           (let ([c (car chars)])
+             (cond
+               [(char=? c #\_)
+                (when (memq #\_ (cdr chars))
+                  (error 'compile-pattern "found a symbol with multiple underscores: ~s" sym))
+                null]
+               [else (cons c (loop (cdr chars)))]))])))))
+  
+  ;; has-underscore? : symbol -> boolean
+  (define (has-underscore? sym)
+    (memq #\_ (string->list (symbol->string sym))))
+  
+  (define (memoize f needs-all-args?)
+    (if needs-all-args?
+        (memoize2 f)
+        (memoize1 f)))
+  
+  ; memoize1 : (x y -> w) -> x y -> w
+  ; memoizes a function of two arguments under the assumption
+  ; that the function is constant w.r.t the second
+  (define (memoize1 f) (memoize/key f (lambda (x y) x) nohole))
+  (define (memoize2 f) (memoize/key f cons w/hole))
+  
+  (define (memoize/key f key-fn statsbox)
+    (let ([ht (make-hash-table 'equal)]
+	  [entries 0])
+      (lambda (x y)
+        (set-cache-stats-hits! statsbox (add1 (cache-stats-hits statsbox)))
+        (let* ([key (key-fn x y)]
+               [compute/cache
+                (lambda ()
+                  (set! entries (+ entries 1))
+                  (set-cache-stats-hits! statsbox (sub1 (cache-stats-hits statsbox)))
+                  (set-cache-stats-misses! statsbox (add1 (cache-stats-misses statsbox)))
+                  (let ([res (f x y)])
+                    (hash-table-put! ht key res)
+                    res))])
+          (unless (< entries 10000)
+            (set! entries 0)
+            (set! ht (make-hash-table 'equal)))
+          (hash-table-get ht key compute/cache)))))
+  
+  (define-struct cache-stats (name misses hits))
+  (define (new-cache-stats name) (make-cache-stats name 0 0))
+
+  (define w/hole (new-cache-stats "hole"))
+  (define nohole (new-cache-stats "no-hole"))
+  
+  (define (print-stats)
+    (let ((stats (list w/hole nohole)))
+      (for-each 
+       (lambda (s) 
+         (when (> (+ (cache-stats-hits s) (cache-stats-misses s)) 0)
+           (printf "~a has ~a hits, ~a misses (~a)\n" 
+                   (cache-stats-name s)
+                   (cache-stats-hits s)
+                   (cache-stats-misses s)
+                   (* 100 (/ (cache-stats-hits s)
+                             (+ (cache-stats-hits s) (cache-stats-misses s)))))))
+       stats)
+      (let ((overall-hits (apply + (map cache-stats-hits stats)))
+            (overall-miss (apply + (map cache-stats-misses stats))))
+        (printf "---\nOverall hits: ~a\n" overall-hits)
+        (printf "\nOverall misses: ~a\n" overall-miss)
+        (when (> (+ overall-hits overall-miss) 0)
+          (printf "\nOverall rate: ~a\n" (* 100 (/ overall-hits (+ overall-hits overall-miss))))))))
+
+  ;; match-hole : (union #f symbol) -> compiled-pattern
+  (define (match-hole hole-id)
+    (lambda (exp hole-info)
+      (and hole-info
+           (eq? hole-id hole-info)
+           (list (make-mtch (make-bindings '())
+                            hole
+                            exp)))))
+  
+  ;; match-in-hole : sexp sexp sexp compiled-pattern compiled-pattern hole-info -> compiled-pattern
+  (define (match-in-hole context contractum exp match-context match-contractum hole-info)
+    (lambda (exp old-hole-info)
+      (let ([mtches (match-context exp hole-info)])
+        (and mtches
+             (let loop ([mtches mtches]
+                        [acc null])
+               (cond
+                 [(null? mtches) acc]
+                 [else 
+                  (let* ([mtch (car mtches)]
+                         [bindings (mtch-bindings mtch)]
+                         [hole-exp (mtch-hole mtch)]
+                         [contractum-mtches (match-contractum hole-exp old-hole-info)])
+                    (if contractum-mtches
+                        (let i-loop ([contractum-mtches contractum-mtches]
+                                     [acc acc])
+                          (cond
+                            [(null? contractum-mtches) (loop (cdr mtches) acc)]
+                            [else (let* ([contractum-mtch (car contractum-mtches)]
+                                         [contractum-bindings (mtch-bindings contractum-mtch)])
+                                    (i-loop
+                                     (cdr contractum-mtches)
+                                     (cons
+                                      (make-mtch (make-bindings
+                                                  (append (bindings-table contractum-bindings)
+                                                          (bindings-table bindings)))
+                                                 (plug (mtch-context mtch) (mtch-context contractum-mtch))
+                                                 (mtch-hole contractum-mtch))
+                                      acc)))]))
+                        (loop (cdr mtches) acc)))]))))))
+  
+  (define (plug exp hole-stuff)
+    (let loop ([exp exp])
+      (cond
+        [(pair? exp) (cons (loop (car exp)) (loop (cdr exp)))]
+        [(eq? exp hole) hole-stuff]
+        [else exp])))
+  
+  ;; match-list : (listof (union repeat compiled-pattern)) sexp hole-info -> (union #f (listof bindings))
+  (define (match-list patterns exp hole-info)
+    (let (;; raw-match : (listof (listof (listof mtch)))
+          [raw-match (match-list/raw patterns exp hole-info)])
+      
+      (and (not (null? raw-match))
+           
+           (let* (;; combined-matches : (listof (listof mtch))
+                  ;; a list of complete possibilities for matches 
+                  ;; (analagous to multiple matches of a single non-terminal)
+                  [combined-matches (map combine-matches raw-match)]
+                  
+                  ;; flattened-matches : (union #f (listof bindings))
+                  [flattened-matches (if (null? combined-matches)
+                                         #f
+                                         (apply append combined-matches))])
+             flattened-matches))))
+  
+  ;; match-list/raw : (listof (union repeat compiled-pattern)) 
+  ;;                  sexp
+  ;;                  hole-info
+  ;;               -> (listof (listof (listof mtch)))
+  ;; the result is the raw accumulation of the matches for each subpattern, as follows:
+  ;;  (listof (listof (listof mtch)))
+  ;;  \       \       \-------------/  a match for one position in the list (failures don't show up)
+  ;;   \       \-------------------/   one element for each position in the pattern list
+  ;;    \-------------------------/    one element for different expansions of the ellipses
+  ;; the failures to match are just removed from the outer list before this function finishes
+  ;; via the `fail' argument to `loop'.
+  (define (match-list/raw patterns exp hole-info)
+    (let/ec k
+      (let loop ([patterns patterns]
+                 [exp exp]
+                 ;; fail : -> alpha
+                 ;; causes one possible expansion of ellipses to fail
+                 ;; initially there is only one possible expansion, so
+                 ;; everything fails.
+                 [fail (lambda () (k null))])
+        (cond
+          [(pair? patterns)
+           (let ([fst-pat (car patterns)])
+             (cond
+               [(repeat? fst-pat)
+                (if (or (null? exp) (pair? exp))
+                    (let ([r-pat (repeat-pat fst-pat)]
+                          [r-mt (make-mtch (make-bindings (repeat-empty-bindings fst-pat))
+                                           '()
+                                           none)])
+                      (apply 
+                       append
+                       (cons (let/ec k
+                               (let ([mt-fail (lambda () (k null))])
+                                 (map (lambda (pat-ele) (cons (list r-mt) pat-ele))
+                                      (loop (cdr patterns) exp mt-fail))))
+                             (let r-loop ([exp exp]
+                                          ;; past-matches is in reverse order
+                                          ;; it gets reversed before put into final list
+                                          [past-matches (list r-mt)])
+                               (cond
+                                 [(pair? exp)
+                                  (let* ([fst (car exp)]
+                                         [m (r-pat fst hole-info)])
+                                    (if m
+                                        (let* ([combined-matches (collapse-single-multiples m past-matches)]
+                                               [reversed (reverse-multiples combined-matches)])
+                                          (cons 
+                                           (let/ec fail-k
+                                             (map (lambda (x) (cons reversed x))
+                                                  (loop (cdr patterns) 
+                                                        (cdr exp)
+                                                        (lambda () (fail-k null)))))
+                                           (r-loop (cdr exp) combined-matches)))
+                                        (list null)))]
+                                 ;; what about dotted pairs?
+                                 [else (list null)])))))
+                    (fail))]
+               [else
+                (cond
+                  [(pair? exp)
+                   (let* ([fst-exp (car exp)]
+                          [match (fst-pat fst-exp hole-info)])
+                     (if match
+                         (let ([exp-match (map (λ (mtch) (make-mtch (mtch-bindings mtch)
+                                                                    (list (mtch-context mtch))
+                                                                    (mtch-hole mtch)))
+                                               match)])
+                           (map (lambda (x) (cons exp-match x))
+                                (loop (cdr patterns) (cdr exp) fail)))
+                         (fail)))]
+                  [else
+                   (fail)])]))]
+          [else
+           (if (null? exp)
+               (list null)
+               (fail))]))))
+  
+  ;; collapse-single-multiples : (listof mtch) (listof mtch[to-lists]) -> (listof mtch[to-lists])
+  (define (collapse-single-multiples bindingss multiple-bindingss)
+    (apply append 
+           (map
+            (lambda (multiple-match)
+              (let ([multiple-bindings (mtch-bindings multiple-match)])
+                (map
+                 (lambda (single-match)
+                   (let ([single-bindings (mtch-bindings single-match)])
+                     (let ([ht (make-hash-table 'equal)])
+                       (for-each
+                        (lambda (multiple-rib)
+                          (hash-table-put! ht (rib-name multiple-rib) (rib-exp multiple-rib)))
+                        (bindings-table multiple-bindings))
+                       (for-each
+                        (lambda (single-rib)
+                          (let* ([key (rib-name single-rib)]
+                                 [rst (hash-table-get ht key (lambda () null))])
+                            (hash-table-put! ht key (cons (rib-exp single-rib) rst))))
+                        (bindings-table single-bindings))
+                       (make-mtch (make-bindings (hash-table-map ht make-rib))
+                                  (cons (mtch-context single-match)
+                                        (mtch-context multiple-match))
+                                  (pick-hole (mtch-hole single-match)
+                                             (mtch-hole multiple-match))))))
+                 bindingss)))
+            multiple-bindingss)))
+    
+  ;; pick-hole : (union none sexp) (union none sexp) -> (union none sexp)
+  (define (pick-hole s1 s2)
+    (cond
+      [(eq? none s1) s2]
+      [(eq? none s2) s1]
+      [(error 'matcher.ss "found two holes in list pattern ~s ~s" s1 s2)]))
+  
+  ;; reverse-multiples : (listof mtch[to-lists]) -> (listof mtch[to-lists])
+  ;; reverses the rhs of each rib in the bindings and reverses the context.
+  (define (reverse-multiples matches)
+    (map (lambda (match)
+           (let ([bindings (mtch-bindings match)])
+             (make-mtch
+              (make-bindings
+               (map (lambda (rib)
+                      (make-rib (rib-name rib)
+                                (reverse (rib-exp rib))))
+                    (bindings-table bindings)))
+              (reverse (mtch-context match))
+              (mtch-hole match))))
+         matches))
+  
+  ;; match-nt : hash-table[from compiled-lang] sym exp hole-info -> (union #f (listof bindings))
+  (define (match-nt clang-ht nt term hole-info)
+    (let ([compiled-rhss (hash-table-get clang-ht nt)])
+      (let loop ([rhss compiled-rhss]
+                 [anss null])
+        (cond
+          [(null? rhss) (if (null? anss) #f (apply append anss))]
+          [else
+           (let ([mth (remove-bindings/filter ((car rhss) term hole-info))])
+             (if mth
+                 (loop (cdr rhss) (cons mth anss))
+                 (loop (cdr rhss) anss)))]))))
+  
+  ;; remove-bindings/filter : (union #f (listof mtch)) -> (union #f (listof mtch))
+  (define (remove-bindings/filter matches)
+    (and matches
+         (let ([filtered (filter-multiples matches)])
+           (and (not (null? filtered))
+                (map (λ (match)
+                       (make-mtch (make-bindings '())
+                                  (mtch-context match)
+                                  (mtch-hole match)))
+                     matches)))))
+  
+  ;; rewrite-ellipses : (listof pattern) 
+  ;;                    (pattern -> (values compiled-pattern boolean))
+  ;;                 -> (values (listof (union repeat compiled-pattern)) boolean)
+  ;; moves the ellipses out of the list and produces repeat structures
+  (define (rewrite-ellipses pattern compile)
+    (let loop ([exp-eles pattern]
+               [fst dummy])
+      (cond
+        [(null? exp-eles)
+         (if (eq? fst dummy)
+             (values empty #f)
+             (let-values ([(compiled has-hole?) (compile fst)])
+               (values (list compiled) has-hole?)))]
+        [else
+         (let ([exp-ele (car exp-eles)])
+           (cond
+             [(eq? '... exp-ele)
+              (when (eq? fst dummy)
+                (error 'match-pattern "bad ellipses placement: ~s" pattern))
+              (let-values ([(compiled has-hole?) (compile fst)]
+                           [(rest rest-has-hole?) (loop (cdr exp-eles) dummy)])
+                (values
+                 (cons (make-repeat compiled (extract-empty-bindings fst)) rest)
+                 (or has-hole? rest-has-hole?)))]
+             [(eq? fst dummy)
+              (loop (cdr exp-eles) exp-ele)]
+             [else
+              (let-values ([(compiled has-hole?) (compile fst)]
+                           [(rest rest-has-hole?) (loop (cdr exp-eles) exp-ele)])
+                (values
+                 (cons compiled rest)
+                 (or has-hole? rest-has-hole?)))]))])))
+  
+  (define dummy (box 0))
+  
+  ;; extract-empty-bindings : pattern -> (listof rib)
+  (define (extract-empty-bindings pattern)
+    (let loop ([pattern pattern]
+               [ribs null])
+      (match pattern
+        [`any ribs]
+        [`number ribs] 
+        [`variable ribs] 
+        [`(variable-except ,@(vars ...)) ribs]
+
+        [`hole (error 'match-pattern "cannot have a hole inside an ellipses")]
+        [(? symbol?) 
+         (cond
+           [(has-underscore? pattern)
+            (let ([before (split-underscore pattern)])
+              (loop `(name ,pattern ,before) ribs))]
+           [else ribs])]
+        [`(name ,name ,pat) (loop pat (cons (make-rib name '()) ribs))]
+        [`(in-hole ,context ,contractum) (loop context (loop contractum ribs))]
+        [`(in-named-hole ,hole-name ,context ,contractum) (loop context (loop contractum ribs))]
+        [`(side-condition ,pat ,test) (loop pat ribs)]
+        [(? list?)
+         (let-values ([(rewritten has-hole?) (rewrite-ellipses pattern (lambda (x) (values x #f)))])
+           (let i-loop ([r-exps rewritten]
+                        [ribs ribs])
+             (cond
+               [(null? r-exps) ribs]
+               [else (let ([r-exp (car r-exps)])
+                       (cond
+                         [(repeat? r-exp) 
+                          (i-loop
+                           (cdr r-exps)
+                           (append (repeat-empty-bindings r-exp) ribs))]
+                         [else
+                          (i-loop 
+                           (cdr r-exps)
+                           (loop (car r-exps) ribs))]))])))]
+        [else ribs])))
+  
+  ;; combine-matches : (listof (listof mtch)) -> (listof mtch)
+  ;; input is the list of bindings corresonding to a piecewise match
+  ;; of a list. produces all of the combinations of complete matches
+  (define (combine-matches matchess)
+    (let loop ([matchess matchess])
+      (cond
+        [(null? matchess) (list (make-mtch (make-bindings null) '() none))]
+        [else (combine-pair (car matchess) (loop (cdr matchess)))])))
+  
+  ;; combine-pair : (listof mtch) (listof mtch) -> (listof mtch)
+  (define (combine-pair fst snd)
+    (let ([mtchs null])
+      (for-each 
+       (lambda (mtch1)
+         (for-each
+          (lambda (mtch2)
+            (set! mtchs (cons (make-mtch 
+                               (make-bindings (append (bindings-table (mtch-bindings mtch1))
+                                                      (bindings-table (mtch-bindings mtch2))))
+                               (append (mtch-context mtch1) (mtch-context mtch2))
+                               (pick-hole (mtch-hole mtch1) 
+                                          (mtch-hole mtch2)))
+                              mtchs)))
+          snd))
+       fst)
+      mtchs))
+
+  (define (hash-table-maps? ht key)
+    (let/ec k
+      (hash-table-get ht key (lambda () (k #f)))
+      #t))
+  
+  
+  (provide/contract
+   (match-pattern (compiled-pattern any/c . -> . (union false/c (listof mtch?))))
+   (compile-pattern (compiled-lang? any/c . -> . compiled-pattern))
+   
+   (make-bindings ((listof rib?) . -> . bindings?))
+   (bindings-table (bindings? . -> . (listof rib?)))
+   (bindings? (any/c . -> . boolean?))
+   
+   (mtch? (any/c . -> . boolean?))
+   (make-mtch (bindings? any/c any/c . -> . mtch?))
+   (mtch-bindings (mtch? . -> . bindings?))
+   (mtch-context (mtch? . -> . any/c))
+   (mtch-hole (mtch? . -> . (union none? any/c)))
+   
+   (make-rib (symbol? any/c . -> . rib?))
+   (rib? (any/c . -> . boolean?))
+   (rib-name (rib? . -> . symbol?))
+   (rib-exp (rib? . -> . any/c)))
+  
+  (provide (struct nt (name rhs))
+           (struct rhs (pattern))
+           (struct compiled-lang (lang ht across-ht has-hole-ht cache))
+           
+           lookup-binding
+           compile-language
+           
+           compiled-pattern
+           
+           plug
+           none? none
+           
+           print-stats
+           make-repeat
+           
+           hole
+           
+           rewrite-ellipses
+           build-compatible-context-language))
\ No newline at end of file
diff --git a/collects/reduction-semantics/private/red-sem-macro-helpers.ss b/collects/reduction-semantics/private/red-sem-macro-helpers.ss
new file mode 100644
index 0000000000..c88c684e31
--- /dev/null
+++ b/collects/reduction-semantics/private/red-sem-macro-helpers.ss
@@ -0,0 +1,31 @@
+(module red-sem-macro-helpers mzscheme
+  
+  (provide extract-names)
+
+  (require (lib "match.ss"))
+  
+  (define (extract-names stx)
+    (let ([dup-names
+           (let loop ([sexp (syntax-object->datum stx)]
+                      [names null])
+             (match sexp
+               [`(name ,(and sym (? symbol?)) ,pat)
+                (loop pat (cons sym names))]
+               [`(in-hole* ,(and sym (? symbol?)) ,pat1 ,pat2)
+                (loop pat1
+                      (loop pat2
+                            (cons sym names)))]
+               [`(in-hole ,pat1 ,pat2)
+                (loop pat1
+                      (loop pat2
+                            (cons 'hole names)))]
+               [(? list?)
+                (let i-loop ([sexp sexp]
+                             [names names])
+                  (cond
+                    [(null? sexp) names]
+                    [else (i-loop (cdr sexp) (loop (car sexp) names))]))]
+               [else names]))]
+          [ht (make-hash-table)])
+      (for-each (lambda (name) (hash-table-put! ht name #f)) dup-names)
+      (hash-table-map ht (lambda (x y) x)))))
diff --git a/collects/reduction-semantics/private/subst-test.ss b/collects/reduction-semantics/private/subst-test.ss
new file mode 100644
index 0000000000..8d2505eae8
--- /dev/null
+++ b/collects/reduction-semantics/private/subst-test.ss
@@ -0,0 +1,120 @@
+(module subst-test mzscheme
+  (require "../subst.ss"
+           (lib "match.ss"))
+  
+  (define (lc-subst1 var val exp) (subst/proc var val exp lc-separate))
+  (define (lc-free-vars exp) (free-vars/memoize (make-hash-table) exp lc-separate))
+  (define (lc-rename old-name new-name exp) (alpha-rename old-name new-name exp lc-separate))
+  
+  (define lc-subst2
+    (subst
+     [`(lambda ,vars ,body)
+      (all-vars vars)
+      (build (lambda (vars body) `(lambda ,vars ,body)))
+      (subterm vars body)]
+     [`(let (,l-var ,exp) ,body)
+      (all-vars (list l-var))
+      (build (lambda (l-vars exp body) `(let (,@l-vars ,exp) ,body)))
+      (subterm '() exp)
+      (subterm (list l-var) body)]
+     [(? symbol?) (variable)]
+     [(? number?) (constant)]
+     [`(,fun ,@(args ...))
+      (all-vars '())
+      (build (lambda (vars fun . args) `(,fun ,@args)))
+      (subterm '() fun)
+      (subterms '() args)]))
+  
+  (define (lc-separate exp constant variable combine sub-piece)
+    (match exp
+      [`(lambda ,vars ,body)
+       (combine (lambda (vars body) `(lambda ,vars ,body))
+                vars
+                (sub-piece vars body))]
+      [`(let (,l-var ,exp) ,body)
+       (combine (lambda (l-vars exp body) `(let (,(car l-vars) ,exp) ,body))
+                (list l-var)
+                (sub-piece '() exp)
+                (sub-piece (list l-var) body))]
+      [(? symbol?) (variable (lambda (x) x) exp)]
+      [(? number?) (constant exp)]
+      [`(,fun ,@(args ...))
+       (apply 
+        combine
+        (lambda (variables fun . args) `(,fun ,@args))
+        '()
+        (append
+         (list (sub-piece '() fun))
+         (map (lambda (x) (sub-piece '() x)) args)))]))
+  
+  (define-syntax (test stx)
+    (syntax-case stx  ()
+      [(_ test-exp expected)
+       (syntax (test test-exp expected equal?))]
+      [(_ test-exp expected same?)
+       (syntax
+        (let ([actual test-exp]
+              [expected-v expected])
+          ;(printf "testing: ~s\n" (syntax-object->datum #'test-exp))
+          (unless (same? actual expected-v)
+            (printf "     test: ~s\n expected: ~s\n      got: ~s\n" 
+                    (syntax-object->datum #'test-exp)
+                    expected-v
+                    actual))))]))
+  
+  (define (set-equal? xs ys)
+    (and (andmap (lambda (x) (memq x ys)) xs)
+         (andmap (lambda (y) (memq y xs)) ys)))
+  
+  (define (lc-tests) 
+    (tests lc-free-vars lc-subst1 lc-rename)
+    (tests #f lc-subst2 #f))
+  
+  (define (tests free-vars subst rename)
+    (when free-vars
+      (test (free-vars 'x) '(x) set-equal?)
+      (test (free-vars '(lambda (x) x)) '() set-equal?)
+      (test (free-vars '(lambda (x) y)) '(y) set-equal?)
+      (test (free-vars '(let (x 1) x)) '() set-equal?)
+      (test (free-vars '(let (x 1) y)) '(y) set-equal?)
+      (test (free-vars '(let (x x) y)) '(y x) set-equal?)
+      (test (free-vars '(let (x 1) (y y))) '(y) set-equal?)
+      (test (free-vars '(lambda (y) (y y))) '() set-equal?))
+    
+    (when rename
+      (test (rename 'x 'y 'x) 'x)
+      (test (rename 'x 'y '(lambda (x) x)) '(lambda (y) y)))
+    
+    (test (subst 'x 1 'x) 1)
+    (test (subst 'x 1 'y) 'y)
+    (test (subst 'x 1 '(lambda (x) x)) '(lambda (x) x))
+    (test (subst 'x 1 '(lambda (y) x)) '(lambda (y) 1))
+    (test (subst 'x 'y '(lambda (y) x)) '(lambda (y@) y))
+    (test (subst 'x 'y '(lambda (y) (x y))) '(lambda (y@) (y y@)))
+    (test (subst 'x 'y '(let (x 1) 1)) '(let (x 1) 1))
+    (test (subst 'x 'y '(let (x 1) x)) '(let (x 1) x))
+    (test (subst 'x 'y '(let (x 1) y)) '(let (x 1) y))
+    (test (subst 'x 'y '(let (y 1) (x y))) '(let (y@ 1) (y y@)))
+    (test (subst 'q '(lambda (x) y) '(lambda (y) y)) '(lambda (y) y))
+    (test (subst 'q '(lambda (x) y) '(let ([y q]) y)) '(let ([y (lambda (x) y)]) y))
+    (test (subst 'p '1 '(let (t 2) ((p t) t)))
+          '(let (t 2) ((1 t) t)))
+    (test (subst 'p '(lambda (s) s) 
+                 '(let (t (lambda (s) s)) ((p t) t)))
+          '(let (t (lambda (s) s)) (((lambda (s) s) t) t)))
+    (test (subst 'p
+                 '(lambda (s) (s s))
+                 '(let (t (lambda (s) s))
+                    p))
+          '(let (t (lambda (s) s))
+             (lambda (s) (s s))))
+    
+    (test (subst 's 
+                 '(lambda (z) (s z))
+                 '(lambda (s) (lambda (z) (s z))))
+          '(lambda (s) (lambda (z) (s z))))
+    
+    (test (subst 's
+                 '(lambda (s) (lambda (z) (s z)))
+                 '(lambda (z) (s z)))
+          '(lambda (z) ((lambda (s) (lambda (z) (s z))) z)))))
diff --git a/collects/reduction-semantics/private/term.ss b/collects/reduction-semantics/private/term.ss
new file mode 100644
index 0000000000..283f46b95c
--- /dev/null
+++ b/collects/reduction-semantics/private/term.ss
@@ -0,0 +1,54 @@
+(module term mzscheme
+  (require "matcher.ss")
+  (provide term term-let)
+  
+  (define-syntax (term orig-stx)
+    (define (rewrite stx)
+      (let loop ([stx stx])
+        (syntax-case stx (unquote unquote-splicing in-hole)
+          [(unquote x)
+           (with-syntax ([x-rewrite (loop (syntax x))])
+             (syntax (unsyntax x-rewrite)))]
+          [(unquote . x)
+           (raise-syntax-error 'term "malformed unquote" orig-stx stx)]
+          [(unquote-splicing x)
+           (with-syntax ([x-rewrite (loop (syntax x))])
+             (syntax (unsyntax-splicing x-rewrite)))]
+          [(unquote-splicing . x)
+           (raise-syntax-error 'term "malformed unquote splicing" orig-stx stx)]
+          [(in-hole id body)
+           (and (identifier? (syntax id))
+                (identifier? (syntax hole)))
+           (syntax (unsyntax (plug (term id) (term body))))]
+          [(in-hole . x)
+           (raise-syntax-error 'term "malformed in-hole" orig-stx stx)]
+          [(x ...)
+           (with-syntax ([(x-rewrite ...) (map loop (syntax->list (syntax (x ...))))])
+             (syntax (x-rewrite ...)))]
+          [_ stx])))
+
+    (syntax-case orig-stx ()
+      [(_ arg)
+       (with-syntax ([rewritten (rewrite (syntax arg))])
+         (syntax (syntax-object->datum (quasisyntax rewritten))))]))
+  
+  (define-syntax (term-let stx)
+    (syntax-case stx ()
+      [(_ ([x rhs] ...) body1 body2 ...)
+       (syntax
+        (with-syntax ([x rhs] ...)
+          (begin body1 body2 ...)))]
+      [(_ x)
+       (raise-syntax-error 'term-let "expected at least one body" stx)]))
+#|  
+  (define (test stx exp)
+    (unless (equal? (eval stx) exp)
+      (error 'test "~s" (syntax-object->datum stx))))
+  
+  (test (quote-syntax (term 1)) 1)
+  (test (quote-syntax (term (1 2))) (list 1 2))
+  (test (quote-syntax (term (1 ,(+ 1 1)))) (list 1 2))
+  (test (quote-syntax (term-let ([x 1]) (term (x x)))) (list 1 1))
+  (test (quote-syntax (term-let ([(x ...) (list 1 2 3)]) (term ((y x) ...)))) '((y 1) (y 2) (y 3)))
+|#
+)
diff --git a/collects/reduction-semantics/reduction-semantics.ss b/collects/reduction-semantics/reduction-semantics.ss
new file mode 100644
index 0000000000..2624011f5d
--- /dev/null
+++ b/collects/reduction-semantics/reduction-semantics.ss
@@ -0,0 +1,275 @@
+#|
+
+incompatible changes to be done:
+
+  - make contexts be bound to just the context to avoid a separate `hole' thingy
+
+|#
+
+(module reduction-semantics mzscheme
+  (require "private/matcher.ss"
+           "private/term.ss"
+           (lib "contract.ss")
+           (lib "etc.ss"))
+  (require-for-syntax (lib "list.ss"))
+
+  (provide reduction
+           reduction/context
+           language
+           plug
+	   compiled-lang?
+           red?
+           term
+           term-let
+           none?)
+  
+  (provide match-pattern
+           compile-pattern
+           make-bindings bindings-table bindings?
+           mtch? mtch-bindings mtch-context  mtch-hole
+           make-rib rib? rib-name rib-exp)
+
+  
+  (provide/contract
+   (language->predicate (compiled-lang? symbol? . -> . (any/c . -> . boolean?)))
+   (reduce ((listof (lambda (x) (red? x))) any/c . -> . (listof any/c)))
+   (variable-not-in (any/c symbol? . -> . symbol?))
+   (compatible-closure ((lambda (x) (red? x))
+                        compiled-lang?
+                        symbol?
+                        . -> .
+                        (lambda (x) (red? x))))
+   (context-closure ((lambda (x) (red? x))
+                     compiled-lang?
+                     any/c
+                     . -> .
+                     (lambda (x) (red? x)))))
+
+  
+  ;; type red = (make-red compiled-pat ((listof (cons sym tst)) -> any)
+  (define-struct red (contractum reduct))
+
+  ;; build-red : language pattern ((listof (cons sym tst)) -> any) -> red
+  (define (build-red lang contractum reduct)
+    (make-red (compile-pattern lang contractum) reduct))
+  
+  (define (compatible-closure red lang nt)
+    (context-closure red lang `(cross ,nt)))
+  
+  (define (context-closure red lang pattern)
+    (let ([new-name (gensym 'context-closure)])
+      (make-red (compile-pattern
+                 lang
+                 `(in-hole (name ,new-name ,pattern)
+                           ,(red-contractum red)))
+                (lambda (bindings)
+                  (let ([context (lookup-binding bindings new-name)]
+                        [res ((red-reduct red) bindings)])
+                    (plug context res))))))
+  
+  (define-syntax-set (reduction/context reduction language)
+    
+    ;; (reduction/context lang ctxt pattern expression ...)
+    (define (reduction/context/proc stx)
+      (syntax-case stx ()
+        [(_ lang-exp ctxt pattern bodies ...)
+         (let-values ([(names names/ellipses) (extract-names (syntax pattern))])
+	   (when (null? (syntax->list (syntax (bodies ...))))
+	     (raise-syntax-error #f "missing result expression" stx))
+           (with-syntax ([(names ...) names]
+                         [(names/ellipses ...) names/ellipses]
+                         [side-condition-rewritten (rewrite-side-conditions (syntax pattern))])
+             (syntax 
+              (build-red lang-exp
+                         `(in-hole (name context ctxt) side-condition-rewritten)
+                         (lambda (bindings)
+                           (term-let ([context (lookup-binding bindings 'context)]
+                                      [names/ellipses (lookup-binding bindings 'names)] ...)
+                                     (plug
+                                      (term context)
+                                      (begin
+                                        (void)
+                                        bodies ...))))))))]))
+    
+    ;; (reduction lang pattern expression ...)
+    (define (reduction/proc stx)
+      (syntax-case stx ()
+        [(_ lang-exp pattern bodies ...)
+         (let-values ([(names names/ellipses) (extract-names (syntax pattern))])
+	   (when (null? (syntax->list (syntax (bodies ...))))
+	     (raise-syntax-error #f "missing result expression" stx))
+           (with-syntax ([(name-ellipses ...) names/ellipses]
+                         [(name ...) names]
+                         [side-condition-rewritten (rewrite-side-conditions (syntax pattern))])
+             (syntax 
+              (build-red lang-exp
+                         `side-condition-rewritten
+                         (lambda (bindings)
+                           (term-let ([name-ellipses (lookup-binding bindings 'name)] ...)
+                             bodies ...))))))]))
+    
+    (define (language/proc stx)
+      (syntax-case stx ()
+        [(_ (name rhs ...) ...)
+         (andmap identifier? (syntax->list (syntax/loc stx (name ...))))
+         (with-syntax ([((r-rhs ...) ...) (map (lambda (rhss) (map rewrite-side-conditions (syntax->list rhss)))
+                                               (syntax->list (syntax ((rhs ...) ...))))])
+           (syntax/loc stx
+             (compile-language (list (make-nt 'name (list (make-rhs `r-rhs) ...)) ...))))]
+        [(_ (name rhs ...) ...)
+         (for-each
+          (lambda (name)
+            (unless (identifier? name)
+              (raise-syntax-error 'language "expected name" stx name)))
+          (syntax->list (syntax (name ...))))]
+        [(_ x ...)
+         (for-each
+          (lambda (x)
+            (syntax-case x ()
+              [(name rhs ...)
+               (void)]
+              [_
+               (raise-syntax-error 'language "malformed non-terminal" stx x)]))
+          (syntax->list (syntax (x ...))))]))
+    
+    (define (rewrite-side-conditions orig-stx)
+      (let loop ([term orig-stx])
+        (syntax-case term (side-condition)
+          [(side-condition pat exp)
+           (let-values ([(names names/ellipses) (extract-names (syntax pat))])
+             (with-syntax ([(name ...) names]
+                           [(name/ellipses ...) names/ellipses])
+               (syntax/loc term
+                 (side-condition
+                  pat
+                  ,(lambda (bindings)
+                     (term-let ([name/ellipses (lookup-binding bindings 'name)] ...)
+                               exp))))))]
+          [(terms ...)
+           (map loop (syntax->list (syntax (terms ...))))]
+          [else term])))
+
+    (define-struct id/depth (id depth))
+    
+    ;; extract-names : syntax -> (values (listof syntax) (listof syntax[x | (x ...) | ((x ...) ...) | ...]))
+    (define (extract-names orig-stx)
+      (let* ([dups
+              (let loop ([stx orig-stx]
+                         [names null]
+                         [depth 0])
+                (syntax-case stx (name in-hole in-named-hole side-condition)
+                  [(name sym pat)
+                   (identifier? (syntax sym))
+                   (loop (syntax pat) 
+                         (cons (make-id/depth (syntax sym) depth) names)
+                         depth)]
+                  [(in-named-hole hlnm sym pat1 pat2)
+                   (identifier? (syntax sym))
+                   (loop (syntax pat1)
+                         (loop (syntax pat2) names depth)
+                         depth)]
+                  [(in-hole pat1 pat2)
+                   (loop (syntax pat1)
+                         (loop (syntax pat2) names depth)
+                         depth)]
+                  [(side-condition pat e)
+                   (loop (syntax pat) names depth)]
+                  [(pat ...)
+                   (let i-loop ([pats (syntax->list (syntax (pat ...)))]
+                                [names names])
+                     (cond
+                       [(null? pats) names]
+                       [else 
+                        (if (or (null? (cdr pats))
+                                (not (identifier? (cadr pats)))
+                                (not (module-identifier=? (quote-syntax ...)
+                                                          (cadr pats))))
+                            (i-loop (cdr pats)
+                                    (loop (car pats) names depth))
+                            (i-loop (cdr pats)
+                                    (loop (car pats) names (+ depth 1))))]))]
+                  [x
+                   (and (identifier? (syntax x))
+                        (has-underscore? (syntax x)))
+                   (cons (make-id/depth (syntax x) depth) names)]
+                  [else names]))]
+             [no-dups (filter-duplicates dups)])
+        (values (map id/depth-id no-dups)
+                (map build-dots no-dups))))
+    
+    ;; build-dots : id/depth -> syntax[x | (x ...) | ((x ...) ...) | ...]
+    (define (build-dots id/depth)
+      (let loop ([depth (id/depth-depth id/depth)])
+        (cond
+          [(zero? depth) (id/depth-id id/depth)]
+          [else (with-syntax ([rest (loop (- depth 1))]
+                              [dots (quote-syntax ...)])
+                  (syntax (rest dots)))])))
+
+    (define (has-underscore? x)
+      (memq #\_ (string->list (symbol->string (syntax-e x)))))
+    
+    (define (filter-duplicates dups)
+      (let loop ([dups dups])
+        (cond
+          [(null? dups) null]
+          [else 
+           (cons
+            (car dups)
+            (filter (lambda (x) 
+                      (let ([same-id? (module-identifier=? (id/depth-id x)
+                                                           (id/depth-id (car dups)))])
+                        (when same-id?
+                          (unless (equal? (id/depth-depth x)
+                                          (id/depth-depth (car dups)))
+                            (error 'reduction "found the same binder, ~s, at different depths, ~a and ~a"
+                                   (syntax-object->datum (id/depth-id x))
+                                   (id/depth-depth x)
+                                   (id/depth-depth (car dups)))))
+                        (not same-id?)))
+                    (loop (cdr dups))))]))))
+  
+  (define (language->predicate lang id)
+    (let ([p (compile-pattern lang id)])
+      (lambda (x)
+	(and (match-pattern p x) #t))))
+    
+  ;; reduce : (listof red) exp -> (listof exp)
+  (define (reduce reductions exp)
+    (let loop ([reductions reductions]
+               [acc null])
+      (cond
+        [(null? reductions) acc]
+        [else (let ([red (car reductions)])
+                (let ([mtchs (match-pattern (red-contractum red) exp)])
+                  (if mtchs
+                      (loop (cdr reductions)
+                            (map/mt
+                             (lambda (mtch) ((red-reduct red) (mtch-bindings mtch)))
+                             mtchs
+                             acc))
+                      (loop (cdr reductions) acc))))])))
+  
+  ;; map/mt : (a -> b) (listof a) (listof b) -> (listof b)
+  ;; map/mt is like map, except it uses the last argument
+  ;; instaed of the empty list
+  (define (map/mt f l mt-l)
+    (let loop ([l l])
+      (cond
+        [(null? l) mt-l]
+        [else (cons (f (car l)) (loop (cdr l)))])))
+    
+  (define re:gen-d (regexp ".*[^0-9]([0-9]+)$"))
+  (define (variable-not-in sexp var)
+    (let ([nums (let loop ([sexp sexp]
+                           [nums null])
+                  (cond
+                    [(pair? sexp) (loop (cdr sexp) (loop (car sexp) nums))]
+                    [(symbol? sexp) (let ([match (regexp-match re:gen-d (symbol->string sexp))])
+                                      (if match
+                                          (cons (string->number (cadr match)) nums)
+                                          nums))]
+                    [else nums]))])
+      (if (null? nums)
+          (string->symbol (format "~a1" var))
+          (string->symbol (format "~a~a" var (+ 1 (apply max nums))))))))
diff --git a/collects/reduction-semantics/subst.ss b/collects/reduction-semantics/subst.ss
new file mode 100644
index 0000000000..5c9db6395a
--- /dev/null
+++ b/collects/reduction-semantics/subst.ss
@@ -0,0 +1,292 @@
+(module subst mzscheme
+  (require (lib "match.ss")
+           (prefix plt: (lib "plt-match.ss"))
+           (lib "list.ss"))
+  
+  (provide plt-subst subst
+           all-vars variable subterm subterms constant build
+           subst/proc alpha-rename free-vars/memoize)
+  
+  (define-syntax (all-vars stx) (raise-syntax-error 'subst "all-vars out of context" stx))
+  (define-syntax (variable stx) (raise-syntax-error 'subst "variable out of context" stx))
+  (define-syntax (subterm stx) (raise-syntax-error 'subst "subterm out of context" stx))
+  (define-syntax (subterms stx) (raise-syntax-error 'subst "subterms out of context" stx))
+  (define-syntax (constant stx) (raise-syntax-error 'subst "constant out of context" stx))
+  (define-syntax (build stx) (raise-syntax-error 'subst "build out of context" stx))
+  
+  (define-syntax (make-subst stx)
+    (syntax-case stx ()
+      [(_ subst match)
+       (syntax
+        (define-syntax (subst stx)
+          (syntax-case stx ()
+            [(_ (pat rhs (... ...)) (... ...))
+             (with-syntax ([term/arg #'term/arg]
+                           [constant/arg #'constant/arg]
+                           [variable/arg #'variable/arg]
+                           [combine/arg #'combine/arg]
+                           [sub-piece/arg #'subpiece/arg])
+               (define (handle-rhs rhs-stx)
+                 (syntax-case rhs-stx (all-vars build subterm subterms variable constant)
+                   [((all-vars all-vars-exp) (build build-exp) sub-pieces (... ...))
+                    (with-syntax ([(sub-pieces (... ...))
+                                   (map (lambda (subterm-stx)
+                                          (syntax-case subterm-stx (subterm subterms)
+                                            [(subterm vars body) (syntax (list (sub-piece/arg vars body)))]
+                                            [(subterms vars terms) 
+                                             (syntax 
+                                              (let ([terms-var terms])
+                                                (unless (list? terms-var)
+                                                  (error 'subst
+                                                         "expected a list of terms for `subterms' subclause, got: ~e"
+                                                         terms-var))
+                                                (map (lambda (x) (sub-piece/arg vars x))
+                                                     terms-var)))]
+                                            [else (raise-syntax-error 
+                                                   'subst 
+                                                   "unknown all-vars subterm"
+                                                   stx
+                                                   subterm-stx)]))
+                                        (syntax->list (syntax (sub-pieces (... ...)))))])
+                      (syntax
+                       (apply combine/arg
+                              build-exp
+                              all-vars-exp
+                              (append sub-pieces (... ...)))))]
+                   [((all-vars) sub-pieces (... ...))
+                    (raise-syntax-error 'subst "expected all-vars must have an argument" stx rhs-stx)]
+                   [((all-vars all-vars-exp) not-build-clause anything (... ...))
+                    (raise-syntax-error 'subst "expected build clause" (syntax not-build-clause))]
+                   [((all-vars all-vars-exp))
+                    (raise-syntax-error 'subst "missing build clause" (syntax (all-vars all-vars-exp)))]
+                   [((constant)) 
+                    (syntax (constant/arg term/arg))]
+                   [((variable))
+                    (syntax (variable/arg (lambda (x) x) term/arg))]
+                   [(unk unk-more (... ...))
+                    (raise-syntax-error 'subst "unknown clause" (syntax unk))]))
+               (with-syntax ([(expanded-rhs (... ...))
+                              (map handle-rhs (syntax->list (syntax ((rhs (... ...)) (... ...)))))])
+                 (syntax
+                  (let ([separate
+                         (lambda (term/arg constant/arg variable/arg combine/arg sub-piece/arg)
+                           (match term/arg
+                             [pat expanded-rhs] (... ...)
+                             [else (error 'subst "no matching clauses for ~s\n" term/arg)]))])
+                    (lambda (var val exp)
+                      (subst/proc var val exp separate))))))])))]))
+  
+  (make-subst subst match)
+  (make-subst plt-subst plt:match)
+  
+  (define (subst/proc var val exp separate)
+    (let* ([free-vars-cache (make-hash-table)]
+           [fv-val (free-vars/memoize free-vars-cache val separate)])
+      (let loop ([exp exp])
+        (let ([fv-exp (free-vars/memoize free-vars-cache exp separate)]
+              [handle-constant
+               (lambda (x) x)]
+              [handle-variable
+               (lambda (rebuild var-name)
+                 (if (eq? var-name var)
+                     val
+                     (rebuild var-name)))]
+              [handle-complex
+               (lambda (maker vars . subpieces)
+                 (cond
+                   [(ormap (lambda (var) (memq var fv-val)) vars)
+                    =>
+                    (lambda (to-be-renamed-l)
+                      (let ([to-be-renamed (car to-be-renamed-l)])
+                        (loop
+                         (alpha-rename
+                          to-be-renamed
+                          (pick-new-name to-be-renamed (cons to-be-renamed fv-val))
+                          exp
+                          separate))))]
+                   [else
+                    (apply maker 
+                           vars
+                           (map (lambda (subpiece)
+                                  (let ([sub-term-binders (subpiece-binders subpiece)]
+                                        [sub-term (subpiece-term subpiece)])
+                                    (if (memq var sub-term-binders)
+                                        sub-term
+                                        (loop sub-term))))
+                                subpieces))]))])
+          (if (memq var fv-exp)
+              (separate
+               exp
+               handle-constant
+               handle-variable
+               handle-complex
+               make-subpiece)
+              exp)))))
+  
+  (define-struct subpiece (binders term) (make-inspector))
+  
+  ;; alpha-rename : symbol symbol term separate -> term
+  ;; renames the occurrences of to-be-renamed that are 
+  ;; bound in the "first level" of exp.
+  (define (alpha-rename to-be-renamed new-name exp separate)
+    (define (first exp)
+      (separate exp
+                first-handle-constant
+                first-handle-variable
+                first-handle-complex
+                first-handle-complex-subpiece))
+    (define (first-handle-constant x) x)
+    (define (first-handle-variable rebuild var) (rebuild var))
+    (define (first-handle-complex maker vars . subpieces)
+      (let ([replaced-vars
+             (map (lambda (x) (if (eq? x to-be-renamed) new-name x))
+                  vars)])
+        (apply maker replaced-vars subpieces)))
+    (define (first-handle-complex-subpiece binders subterm)
+      (if (memq to-be-renamed binders)
+          (beyond-first subterm)
+          subterm))
+    
+    (define (beyond-first exp)
+      (define (handle-constant x) x)
+      (define (handle-variable rebuild var)
+        (if (eq? var to-be-renamed)
+            (rebuild new-name)
+            (rebuild var)))
+      (define (handle-complex maker vars . subpieces)
+        (apply maker vars subpieces))
+      (define (handle-complex-subpiece binders subterm)
+        (if (memq to-be-renamed binders)
+            subterm
+            (beyond-first subterm)))
+      (separate
+       exp
+       handle-constant
+       handle-variable
+       handle-complex
+       handle-complex-subpiece))
+    
+    (first exp))
+  
+  ;; free-vars/memoize : hash-table[sexp -o> (listof symbols)] sexp separate -> (listof symbols)
+  ;; doesn't cache against separate -- if it changes, a new hash-table must be passed in,
+  ;; or the caching will be wrong
+  (define (free-vars/memoize cache exp separate)
+    (hash-table-get
+     cache
+     exp
+     (lambda ()
+       (let ([res (free-vars/compute cache exp separate)])
+         (hash-table-put! cache exp res)
+         res))))
+  
+  ;; free-vars/memoize : hash-table[sexp -o> (listof symbols)] sexp separate -> (listof symbols)
+  (define (free-vars/compute cache exp separate)
+    (let ([handle-constant (lambda (x) '())]
+          [handle-variable (lambda (rebuild var) (list var))]
+          [handle-complex
+           (lambda (maker vars . subpieces)
+             (apply append subpieces))]
+          [handle-complex-subpiece
+           (lambda (binders subterm)
+             (foldl remove-all
+                    (free-vars/memoize cache subterm separate)
+                    binders))])
+      (separate
+       exp
+       handle-constant
+       handle-variable
+       handle-complex
+       handle-complex-subpiece)))
+  
+  (define (remove-all var lst)
+    (let loop ([lst lst]
+               [ans '()])
+      (cond
+        [(null? lst) ans]
+        [else (if (eq? (car lst) var)
+                  (loop (cdr lst) ans)
+                  (loop (cdr lst) (cons (car lst) ans)))])))
+  
+  (define (lc-direct-subst var val exp)
+    (let ([fv-exp (lc-direct-free-vars exp)])
+      (if (memq var fv-exp)
+          (match exp
+            [`(lambda ,vars ,body)
+             (if (memq var vars)
+                 exp
+                 (let* ([fv-val (lc-direct-free-vars val)]
+                        [vars1 (map (lambda (var) (pick-new-name var fv-val)) vars)])
+                   `(lambda ,vars1 ,(lc-direct-subst
+                                     var 
+                                     val
+                                     (lc-direct-subst/l vars 
+                                                        vars1
+                                                        body)))))]
+            [`(let (,l-var ,exp) ,body)
+             (if (eq? l-var var)
+                 `(let (,l-var ,(lc-direct-subst var val exp)) ,body)
+                 (let* ([fv-val (lc-direct-free-vars val)]
+                        [l-var1 (pick-new-name l-var fv-val)])
+                   `(let (,l-var1 ,(lc-direct-subst var val exp))
+                      ,(lc-direct-subst
+                        var 
+                        val
+                        (lc-direct-subst
+                         l-var 
+                         l-var1
+                         body)))))]
+            [(? number?) exp]
+            [(and var1 (? symbol?))
+             (if (eq? var1 var)
+                 val
+                 var1)]
+            [`(,@(args ...))
+             `(,@(map (lambda (arg) (lc-direct-subst var val arg)) args))])
+          exp)))
+  
+  ;; lc-direct-subst/l : (listof symbol) (listof symbol) (listof symbol) sexp -> exp
+  ;; substitutes each of vars with vals in exp
+  ;; [assume vals don't contain any vars]
+  (define (lc-direct-subst/l vars vals exp)
+    (foldr (lambda (var val exp) (lc-direct-subst var val exp))
+           exp
+           vars
+           vals))
+  
+  ;; lc-direct-free-vars : sexp -> (listof symbol)
+  ;; returns the free variables in exp
+  (define (lc-direct-free-vars exp)
+    (let ([ht (make-hash-table)])
+      (let loop ([exp exp]
+                 [binding-vars null])
+        (match exp
+          [(? symbol?) 
+           (unless (memq exp binding-vars)
+             (hash-table-put! ht exp #t))]
+          [(? number?)
+           (void)]
+          [`(lambda ,vars ,body)
+           (loop body (append vars binding-vars))]
+          [`(let (,var ,exp) ,body)
+           (loop exp binding-vars)
+           (loop body (cons var binding-vars))]
+          [`(,@(args ...))
+           (for-each (lambda (arg) (loop arg binding-vars)) args)]))
+      (hash-table-map ht (lambda (x y) x))))
+  
+  ;; pick-new-name : symbol (listof symbol) -> symbol
+  ;; returns a primed version of `var' that does
+  ;; not occur in vars (possibly with no primes)
+  (define (pick-new-name var vars)
+    (if (member var vars)
+        (pick-new-name (prime var) vars)
+        var))
+  
+  ;; prime : symbol -> symbol
+  ;; adds an @ at the end of the symbol
+  (define (prime var)
+    (string->symbol
+     (string-append
+      (symbol->string var)
+      "@"))))
\ No newline at end of file
diff --git a/collects/setup/doc.txt b/collects/setup/doc.txt
new file mode 100644
index 0000000000..e48e3520c5
--- /dev/null
+++ b/collects/setup/doc.txt
@@ -0,0 +1,579 @@
+
+_Setup PLT_ or _setup-plt_: Collection Setup and Unpacking
+==========================================================
+
+The Setup PLT executable (bin/setup-plt for Unix) performs two
+services:
+
+ * Compiling and setting up all collections: When Setup PLT is run
+   without any arguments, it finds all of the current collections (see
+   the MzScheme manual for information on collections) and compiles
+   module libraries in each collection with an "info.ss" library. The
+   "info.ss" can indicate specifically how the collection's modules
+   are compiled (see below). In this mode, Setup PLT also compiles any
+   module that is referenced by a compiled module.
+
+   The --clean (or -c) flag to Setup PLT causes it to delete existing
+   .zo and extension files, thus ensuring a clean build from the
+   source files. The exact set of deleted files can be controlled by
+   "info.ss" libraries; see below for more info.
+
+   The -l flag takes one or more collection names and restricts Setup
+   PLT's action to those collections.
+
+   The --mode <mode> flag causes Setup PLT to use a .zo compiler other
+   than the default, and to put the resulting .zo files in a
+   subdirectory (of the usual place) names <mode>. The compiler is
+   obtained by using <mode> as a collection name, finding a
+   _zo-compile.ss_ module in that collection, and extracting its
+   `zo-compile' export. The `zo-compile' export should be a function
+   like MzScheme's `compile'.
+
+   In addition to compilation, a collection's "info.ss" library can
+   specify executables to be installed in the "plt" directory
+   ("plt/bin" under Unix) or other installation actions.
+
+ * Unpacking _.plt_ files: A .plt file is a platform-independent
+   distribution archive for MzScheme- and MrEd-based software.  When
+   one or more file names are provided as the command line arguments
+   to Setup PLT, the files contained in the .plt archive are unpacked
+   (according to specifications embedded in the .plt file) and only
+   collections specified by the plt file are compiled and setup.
+
+ Compiling and Setting Up Collections
+ ------------------------------------
+
+Setup PLT attempts to compile and set up any collection that:
+
+ * has an _info.ss_ library (see the mzc manual for a description of
+   info.ss);
+ 
+ * has the 'name' field in "info.ss";
+
+ * is either a top-level collection or a sub-collection of a compilable
+   collection.
+
+Collections meeting this criteria are compiled using the
+`compile-collection-zos' procedure described in the "compiler"
+collection (which means that even if a collection has no "info.ss"
+file, its modules will get compiled if they are used by other compiled
+modules). If the -e or --extension flag is specified, then the
+collections are also compiled using the `compile-collection-extension'
+procedure from "compiler" (which does not compile a module merely
+because it is used by another).
+
+Additional "info.ss" fields trigger additional setup actions:
+
+>  mzscheme-launcher-names - a list of executable names to be
+   installed in "plt" (or "plt/bin") to run MzScheme programs
+   implemented by the collection. A parallel list of library names
+   must be provided by `mzscheme-launcher-libraries' or
+   `mzscheme-launcher-flags' (see below). For each name, a launching
+   executable is set up using the launcher collection's
+   `make-mzscheme-launcher'. The arguments are "-mve-" and
+
+      (format "~s" `(require (lib <file> <colls> ...)))
+
+   where lib is the file named by `mzscheme-launcher-libraries'
+   and <colls> ... are the collections (and subcollections)
+   of the info.ss file. In addition,
+
+    (build-aux-from-path
+     (build-path (collection-path <colls> ...) <suffixless-file>))
+
+   is provided for the optional "aux" argument (for icons, etc.),
+   where <suffixless-file> is <file> without its suffix (see
+   launcher/doc.txt).
+
+   If `mzscheme-launcher-flags' is provided, it is used as a list of
+   command-line argument lists to pass to mzscheme instead of the
+   above default, allowing arbitrary command-line arguments.  If
+   `mzscheme-launcher-flags' is specified together with
+   `mzscheme-launcher-libraries', then the flags will override the
+   libraries, but the libraries can still be used to specify a name
+   for `build-aux-from-path' (to find related information like icon
+   files etc).
+
+   If compile-subcollections mentions a subcollection with
+   this field, the executable is also set up for that subcollection.
+
+   If the executable already exists, no action is taken.
+
+>  mzscheme-launcher-libraries - a list of library names in
+   parallel to `mzscheme-launcher-names' (see above).
+
+>  mzscheme-launcher-flags - a list of command-line flag lists, in
+   parallel to `mzscheme-launcher-names' (see above).
+
+>  mred-launcher-names - a list of executable names to be installed in
+   plt (or plt/bin) to run MrEd programs implemented by the
+   collection.  This is treated in parallel to
+   `mred-launcher-libraries' and `mred-launcher-flags' similarly to
+   `mzscheme-launcher-names' above.
+
+>  mred-launcher-libraries - a list of library names in
+   parallel to `mred-launcher-names' (see above).
+
+>  mred-launcher-flags - a list of command-line flag lists, in
+   parallel to `mred-launcher-names' (see above).
+
+>  install-collection - a string or a path for a library module
+   relative to the collection. The module must provide `installer' as
+   a procedure that accepts either one or two arguments. The first
+   argument is a directory path to the PLT installation directory; the
+   second argument, if accecpted, is a path to the collection's own
+   directory. The procedure should perform collection-specific
+   installation work, and it should avoid unnecessary work in the case
+   that it is called multiple times for the same installation.
+
+>  pre-install-collection - like `install-collection', except that the
+   corresponding installer is called *before* normal the .zo build,
+   instead of after.  The provided procedure should be named
+   `pre-installer' in this case so it can share the same file.
+
+>  post-install-collection - like `install-collection'.  It is called
+   right after the `install-collection' procedure is executed.  The
+   only difference between these is that the `--no-install' flag can
+   be used to disable the previous two installers, but not this one.
+   It is therefore expected to do perform operations that are always
+   needed to be done (even after installation that contains
+   pre-compiled files).  The provided procedure should be named
+   `post-installer' in this case so it can share the same file.
+
+>  clean - a list of pathnames to be deleted when the --clean or -c
+   flag is passed to Setup PLT. The pathnames must be relative to the
+   collection.  If any path names a directory, each of the files
+   in the directory are deleted, but none of the subdirectories of the
+   directory are checked. If the path names a file, the file is
+   deleted. The default, if this flag is not specified, is to delete
+   all files in the "compiled" subdirectory, and all of the files in
+   the platform-specific subdirectory of the compiled directory for
+   the current platform.
+
+   Just as compiling .zo files will compile each module used by a
+   compiled module, deleting a module's compiled image will delete the
+   .zo of each module that is used by the module. More specifically,
+   used modules are determined when deleting a ".dep" file, which
+   would have been created to accompany a .zo file when the .zo was
+   built by Setup PLT. If the .dep file indicates another module, that
+   module's .zo is deleted only if it also has an accompanying .dep
+   file. In that case, the .dep file is deleted, and additional used
+   modules are deleted based on the used module's .dep file, etc.
+   Supplying a specific list of collections to Setup PLT disables this
+   dependency-based deletion of compiled files.
+
+ Running Setup PLT from Scheme on a Single .plt file
+ ---------------------------------------------------
+
+The _plt-single-installer.ss_ module provides a function for
+installing a single .plt file:
+
+> (run-single-installer file get-dir-proc)
+     file : path string
+     get-dir-proc: (-> (union string #f))
+
+   Creates a separate thread and namespace, runs the installer in that
+   thread with the new namespace, and returns when the thread
+   completes or dies. It also creates a custodian to manage the
+   created thread, sets the exit handler for the thread to shut down
+   the custodian, and explicitly shuts down the custodian when the
+   created thread terminates or dies.
+
+   The `get-dir-proc' procedure is called if the installer needs a
+   target directory for installation, and a #f result means that the
+   user cancelled the installation. Typically, `get-dir-proc' is
+   `current-directory'.
+
+ Setup PLT as a Unit
+ -------------------
+
+The _setup-unit.ss_ library in the setup collection exports a _setup@_
+signed unit that imports
+
+  setup-option^ - described below
+  compiler^ - from "sig.ss" in the "compiler" collection
+  compiler:option^  - from "sig.ss" in the "compiler" collection
+  launcher-maker^ - from "launcher-sig.ss" in the "launcher" collection
+
+Invoking this unit starts the setup process. The _option-sig.ss_
+library in "setup" defines the
+>      setup-option^
+signature, which is implemented by the _setup:option@_ unit in
+_option-unit.ss_. It imports nothing and exports the following
+parameters that control the setup process:
+
+> verbose - #t => prints message from `make' to stderr [default: #f]
+> make-verbose - #t => verbose `make' [default: #f]
+> compiler-verbose - #t => verbose `compiler' [default: #f]
+> clean - #t => delete .zo and .so/.dll files in the specified
+         collections [default: #f]
+> compile-mode - path => use a .zo compiler other than plain `compile',
+                 and build to (build-path "compiled" (compile-mode))
+                 [default: #f]
+> make-zo - #t => compile .zo files [default #t]
+> make-so - #t => compile .so/.dll files [default: #f]
+> make-launchers - #t => make collection "info.ss"-specified launchers
+                   [default: #t]
+> make-info-domain - #t => update info-domain/compiled/cache.ss for each
+                   collection path [default: #t]
+> call-install - #t => call collection "info.ss"-specified setup code
+                 [default: #t]
+> force-unpack - #t => ignore version and already-installed errors
+                 when upacking a .plt archive [default: #f]
+> pause-on-errors - #t => in the event of an error, prints a summary error
+                 and waits for stdin input before terminating
+                 [default: #f]
+> specific-collections - a list of collections to set up; the empty
+           list means set-up all collections if  the archives
+           list is also empty [default: null]
+> archives - a list of .plt archives to unpack; any collections specified
+            by the archives are set-up in addition to the collections
+            listed in specific-collections  [default: null]
+> current-target-directory-getter - a thunk that returns the target
+            directory for unpacking a relative .plt archive; when
+            unpacking an archive, either this or the procedure
+            in `current-target-plt-directory-getter' will be called
+            [default: current-directory]
+> current-target-plt-directory-getter - a procedure that takes a
+            preferred path, the PLTHOME path, and a list of path choices;
+            it returns a path for a "plt-relative" install; when
+            unpacking an archive, either this or the procedure
+            in `current-target-directory-getter' will be called
+            [default: (lambda (preferred plthome choices) preferred)]
+
+Thus, to unpack a single .plt archive "x.plt", set the `archives'
+parameter to (list "x.plt") and leave `specific-collections' as null.
+
+Beware that the current namespace might intefere with setup
+actions. For example, if setup is supposed to compile a module `(lib
+"foo.ss")' that imports `(lib "bar.ss")', but `(lib "bar.ss")' is
+already loaded in the current namespace, then compilation will use the
+loaded module rather than re-loading it. If `(lib "bar.ss")' has
+changed, re-using the loaded module is unlikely to be the desired
+behavior. Avoid this problem by invoking the setup process in a fresh
+namespace.
+
+Link the options and setup units so that your option-setting code is
+initialized between them, e.g.:
+
+    (compound-unit/sig
+      ...
+      (link ...
+            [OPTIONS : setup-option^ (setup:option@)]
+            [MY-CODE : () (my-init-options@ OPTIONS)]
+            [SETUP : () (setup@ OPTIONS ...)])
+      ...)
+
+
+_Getting info.ss fields_
+========================
+
+The _getinfo.ss_ module defines the following functions:
+
+> (get-info collection-names) -> (union #f (symbol (-> TST) -> TST))
+
+   Accepts a list of strings naming a collection or sub-collection,
+   and calls `get-info/full' with the full path corresponding to the
+   named collection.
+
+> (get-info/full path) -> (union #f (symbol (-> TST) -> TST))
+
+   Accepts a path to a directory. It returns #f if there is no
+   "info.ss" file in the directory. If the "info.ss" file has the
+   wrong shape (i.e., not a module using (lib "infotab.ss" "setup")),
+   or if the "info.ss" file fails to load, then an exception is
+   raised.
+
+   Otherwise, `get-info' returns an info procedure of one or two
+   arguments. The first argument to the info procedure is always a
+   symbolic name, and the result is the value of the name in the
+   "info.ss" file, if the name is defined. The optional second
+   argument to the info procedure is a thunk that is called when the
+   name is not defined, and the result of the info procedure is the
+   result of the thunk in that case. If the name is not defined and no
+   thunk is provided, then an exception is raised.
+
+> (find-relevant-directories list-of-sym [mode]) -> list-of-path
+
+   Returns a list paths identifying installed directories (i.e., collections
+   and installed PLaneT packages) whose "info.ss" file defines one or more
+   of the given symbols. The result is based on a cache that is computed by 
+   Setup PLT and stored in the "info-domain" sub-directory of each collection
+   directory (as determined by the PLT_COLLECTION_PATHS environment variable, 
+   etc.) and the file "cache.ss" in the user addon dir.
+
+   The result is in a cannonical order (sorted lexographically by directory
+   name), and the paths it returns are suitable for providing to
+   get-info/full.
+
+   If mode is specified, it must be either 'preferred (the default) or
+   'all-available. If mode is 'all-available, find-relevant-collections
+   will return all installed directories whose info files contain the
+   specified symbols -- for instance, all installed PLaneT packages will
+   be searched if 'all-available is specified. If mode is 'preferred,
+   then only a subset of "preferred" packages will be searched, and in
+   particular only the directory containing the most recent version of
+   any PLaneT package will be returned.
+
+   No matter what mode is specified, if more than one collection has the
+   same name, find-relevant-directories will only search the one that 
+   occurs first in the PLT_COLLECTION_PATHS environment variable.
+
+_.plt_ Archive Internals
+==========================================================
+
+NOTE: mzc can be used to create .plt files; see the mzc manual for
+details. The internals of .plt archive files should be of little
+interest to most users.
+
+ Unpacking .plt Distribution Archives
+ ------------------------------------
+
+The extension ".plt" is not required for a distribution archive; this
+convention merely helps users identify the purpose of a distribution
+file.
+
+The raw format of a distribution file is described below.  This format
+is uncompressed and sensitive to communication modes (text
+vs. binary), so the distribution format is derived from the raw format
+by first compressing the file using gzip, then encoding the gzipped
+file with the MIME base64 standard (which relies only the characters
+A-Z, a-z, 0-9, +, /, and =; all other characters are ignored when a
+base64-encoded file is decoded).
+
+The raw format is
+
+ * "PLT" are the first three characters.
+
+ * A procedure that takes a symbol and a failure thunk and returns
+   information about archive for recognized symbols and calls the
+   failure thunk for unrecognized symbols. The information symbols
+   are:
+
+     + 'name - a human-readable string describing the archive's
+       contents. This name is used only for printing messages to the
+       user during unpacking.
+
+     + 'unpacker - a symbol indicating the expected unpacking
+       environment. Currently, the only allowed value is 'mzscheme.
+
+     + 'requires - collections required to be installed before
+       unpacking the archive, which associated versions; see the
+       documentation of `pack' for details.
+
+     + 'conflicts - collections required *not* to be installed before
+       unpacking the archive
+
+     + 'plt-relative? - a boolean; if true, then the archive's content
+       should be unpacked relative to the plt add-ons directory.
+
+     + 'plt-home-relative? - a boolean; if true and if `plt-relative?'
+       is true, then the archive's content should be unpacked relative
+       to the plt installation directory.
+
+   The procedure is extracted from the archive using MzScheme's `read'
+   and `eval' procedures (in a fresh namespace).
+
+ * An unsigned unit that drives the unpacking process. The unit accepts two
+   imports: a path string for the plt directory and an `unmztar'
+   procedure. The remainder of the unpacking process consists of invoking
+   this unit. It is expected that the unit will call `unmztar' procedure to
+   unpack directories and files that are defined in the input archive after
+   this unit. The result of invoking the unit must be a list of collection
+   paths (where each collection path is a list of strings); once the
+   archive is unpacked, Setup PLT will compile and setup the specified
+   collections.
+
+   The `unmztar' procedure takes one argument: a filter
+   procedure. The filter procedure is called for each directory and
+   file to be unpacked. It is called with three arguments:
+
+      + 'dir, 'file, 'file-replace - indicates whether the item to be
+        unpacked is a directory, a file, or a file to be replaced;
+
+      + a relative path string - the pathname of the directory or file
+        to be unpacked, relative to the plt directory; and
+
+      + a path string for the plt directory.
+
+   If the filter procedure returns #f for a directory or file, the
+   directory or file is not unpacked. If the filter procedure returns
+   #t and the directory or file for 'dir or 'file already exists, it
+   is not created. (The file for 'file-replace need not exist
+   already.)
+
+   When a directory is unpacked, intermediate directories are created
+   as necessary to create the specified directory. When a file is
+   unpacked, the directory must already exist.
+
+   The unit is extracted from the archive using MzScheme's `read'
+   and `eval' procedures.
+
+Assuming that the unpacking unit calls the `unmztar' procedure, the
+archive should continue with unpackables. Unpackables are extracted
+until the end-of-file is found (as indicated by an `=' in the
+base64-encoded input archive).
+
+An unpackable is one of the following:
+
+ * The symbol 'dir followed by a list. The `build-path' procedure
+   will be applied to the list to obtain a relative path for the
+   directory (and the relative path is combined with the plt directory
+   path to get a complete path).
+
+   The 'dir symbol and list are extracted from the archive using
+   MzScheme's `read' (and the result is *not* `eval'uated).
+
+ * The symbol 'file, a list, a number, an asterisk, and the file
+   data. The list specifies the file's relative path, just as for
+   directories. The number indicates the size of the file to be
+   unpacked in bytes. The asterisk indicates the start of the file
+   data; the next n bytes are written to the file, where n is the
+   specified size of the file.
+
+   The symbol, list, and number are all extracted from the archive
+   using MzScheme's `read' (and the result is *not* `eval'uated).
+   After the number is read, input characters are discarded until
+   an asterisk is found. The file data must follow this asterisk
+   immediately.
+
+ * The symbol 'file-replace is treated like 'file, but if the file
+   exists on disk already, the file in the archive replaces the file
+   on disk.
+
+ Making .plt archives
+ --------------------
+
+mzc supports the creation of simple .plt files (see the mzc manual for
+details) but the setup collection's _pack.ss_ library provides more
+general functions to help make .plt archives:
+
+> (pack-collections dest name collections replace? extra-setup-collections [filter] [at-plt-home?])
+
+  Creates the .plt file specified by the pathname `dest', using the
+  string `name' as the name reported to Setup PLT as the archive's
+  description.
+
+  The archive contains the collections listed in `collections', which
+  should be a list of collection paths; each collection path is, in
+  turn, a list of relative-path strings.
+
+  If `replace?' is #f, then attempting to unpack the archive will
+  report an error when any of the collections exist already, otherwise
+  unpacking the archive will overwrite an existing collection.
+
+  The `extra-setup-collections' argument is a list of collection paths
+  that are not included in the archive, but are set-up when the
+  archive is unpacked.
+
+  The optional `filter' argument is the same as for `pack' (see
+  below).
+
+  The optional `at-plt-home?' argument is the same as for `pack'
+  where `plt-relative?' is true.
+
+> (pack dest name paths collections [filter encode? file-mode unpack-unit plt-relative? requires conflicts at-plt-home?])
+
+  Creates the .plt file specified by the pathname `dest', using the
+  string `name' as the name reported to Setup PLT as the archive's
+  description, and `collections' as the list of collection paths (to
+  be compiled) returned by the unpacking unit. The `paths' argument
+  must be a list of relative paths for directories and files; the
+  contents of these files and directories will be packed into the
+  archive.
+
+  The `filter' procedure is called with the relative path of each
+  candidate for packing. If it returns #f for some path, then that
+  file or directory is omitted from the archive. If it returns 'file
+  or 'file-replace for a file, the file is packed with that mode,
+  rather than the default mode. The default `filter' is `std-filter'
+  (defined below).
+  
+  If `encode?' is #f, then the output archive is in raw form, and
+  still must be gzipped and mime-encoded (in that order). The default
+  value is #t.
+
+  The `file-mode' argument must be 'file or 'file-replace, indicating
+  the default mode for a file in the archive. The default value is
+  'file.
+
+  The `unpack-unit' argument is usually #f. Otherwise, it must be an
+  unsigned unit that performs the work of unpacking; see the above
+  section on .plt internals for more information about the unit. If
+  `unpack-unit' is #f, an appropriate unpacking unit is generated.
+
+  If `plt-relative?', the archive's files and directories are to be
+  unpacked relative to the plt add-ons directory (unless
+  `plt-at-home?' is #t; see below).
+
+  The `requires' argument should have the shape
+      (list (list <coll-path> <version>) ...)
+  where each <coll-path> is a non-empty list of relative-path strings,
+  and each <version> is a (possibly empty) list of exact integers. The
+  indicated collections must be installed at unpacking time, with
+  version sequences that match as much of the version sequence
+  specified in the corresponding <version>. A collection's version is
+  indicated by the `version' field of it's info.ss file.
+
+  The `conflicts' argument should have the shape
+       (list <coll-path> ...)
+  where each <coll-path> is a non-empty list of relative-path
+  strings. The indicated collections must *not* be installed at
+  unpacking time.
+
+  If `at-plt-home?' and `plt-relative?', the archive is to be unpacked
+  relative to the plt installation directory. The default is #f.
+
+> (std-filter p) - returns #t unless `p', after stripping its
+  directory path and converting to a byte string, matches one of the
+  following regular expressions: "^CVS$", "^[.]svn$", "^[.]cvsignore",
+  "^compiled$", "~$", "^#.*#$", "^[.]#", or "[.]plt$".
+
+> (mztar path output filter file-mode) - called by `pack' to write one
+   directory/file `path' to the output port `output' using the filter
+   procedure `filter' (see `pack' for a description of `filter').  The
+   `file-mode' argument specifies the default mode for packing a file,
+   either 'file or 'file-replace.
+
+ Unpacking .plt archives
+ -----------------------
+
+ The _plt-installer.ss_ library in the setup collection defines these
+ procedures:
+
+> (run-installer filename) - run the .plt installer on the .plt file
+  in `filename' and show the output in a window. This is a composition
+  of `with-installer-window' and `run-single-installer' with a
+  `get-dir-proc' that prompts the user for a directory (turning off
+  the busy cursor while the dialog is active).
+
+> (on-installer-run thunk) - sets the on-installer-run thunk to
+  `thunk'. The on-installer-run thunk is run after a .plt file is
+  installed.
+
+> (on-installer-run) - returns the on-installer-run thunk. The
+  on-installer-run thunk is run after a .plt file is installed.
+
+> (with-installer-window do-install cleanup-thunk)
+    do-install : 
+      ((union (instanceof dialog%) (instanceof frame%)) -> void)
+    creates a frame, sets up the current error and output ports, and
+    turns on the busy cursor before calling `do-install' in a separate
+    thread. 
+
+    Returns before the installation process is complete;
+    cleanup-thunk is called on a queued callback to the
+    eventspace active when `with-installer-window' is
+    invoked.
+
+  (run-single-installer file get-dir-proc) - the same as the sole
+   export of _plt-single-installer.ss_; see above for documentation.
+
+      
+ The _plt-installer-unit.ss_ library in the setup collection returns a unit/sig
+ that imports mred^ and exports setup:plt-installer^. The signature
+ setup:plt-installer^ has two names: run-installer and on-installer-run, as
+ above.
+
+ The _plt-installer-sig.ss_ library defines the setup:plt-installer^
+ signature, which has two names: run-installer and on-installer-run.
diff --git a/collects/setup/getinfo.ss b/collects/setup/getinfo.ss
new file mode 100644
index 0000000000..761c964933
--- /dev/null
+++ b/collects/setup/getinfo.ss
@@ -0,0 +1,161 @@
+
+(module getinfo mzscheme
+
+  (require (lib "match.ss")
+           (lib "list.ss")
+           (lib "etc.ss")
+           
+           (lib "contract.ss"))
+
+  (define info? (opt-> (symbol?) ((-> any/c)) any/c))
+  (define path-or-string? (lambda (x) (or (path? x) (string? x))))
+  
+  (provide/contract
+   (get-info ((listof path-or-string?) . -> . (union info? boolean?)))
+   (get-info/full (path? . -> . (union info? boolean?)))
+   (find-relevant-directories (opt-> ((listof symbol?))
+                                     ((lambda (x) (or (eq? x 'preferred)
+                                                      (eq? x 'all-available))))
+                                     (listof path?))))
+
+
+  
+  ;; in addition to infodomain/compiled/cache.ss, getinfo will look in this 
+  ;; file to find mappings. PLaneT uses this to put info about installed
+  ;; planet packages.
+  (define user-infotable (build-path (find-system-path 'addon-dir) "cache.ss"))
+  
+  (define (get-info coll-path)
+    (let* ([coll-path (map (lambda (x) (if (path? x) (path->string x) x)) coll-path)]
+	   [dir (apply collection-path coll-path)])
+      (get-info/full dir)))
+  
+  (define (get-info/full dir)
+    (let ([file (build-path dir "info.ss")])
+      (if (file-exists? file)
+	  (begin
+	    (with-input-from-file file
+	      (lambda ()
+		(let ([r (read)])
+		  (unless (eof-object? (read))
+		    (error "info.ss file has multiple expressions in ~a" dir))
+		  (match r
+		    [('module 'info '(lib "infotab.ss" "setup")
+		       expr ...)
+		     'ok]
+		    [else (error 
+			   'get-info
+			   "info file does not contain a module of the right shape: \"~a\""
+			   file)]))))
+	    (dynamic-require file '#%info-lookup))
+	  #f)))
+
+  ;; item : (list path (listof symbol) nat nat)
+  
+  (define-struct table (insert   ; item * listof item -> listof item
+                        ht       ; hashtable[key -o> item]
+                        paths    ; listof path
+                        ))
+  
+  (define preferred-table 
+    (make-table 
+     (lambda (i l)
+       (cond
+         [(null? l)
+          (list i)]
+         [else 
+          (match-let ([(_ _ my-maj my-min) i]
+                      [(_ _ their-maj their-min) (car l)])
+            (if
+             (or (> my-maj their-maj)
+                 (and (= my-maj their-maj) (>= my-min their-min)))
+               (list i)
+               l))]))
+     #f #f))
+  
+  (define all-available-table (make-table cons #f #f))
+  
+  (define (populate-table! t)
+    ;; Use the colls ht because a collection might be in multiple
+    ;;  collection paths, and we only want one
+    (let ([colls (make-hash-table 'equal)])
+      (for-each (lambda (f)
+                  (when (file-exists? f)
+                    (for-each 
+                     (lambda (i)
+                       (match i
+                         [((? bytes? pathbytes) 
+                           ((? symbol? fields) ...)
+                           key ;; anything is okay here
+                           (? integer? maj)
+                           (? integer? min))
+                          (let ((old-items (hash-table-get 
+                                            colls
+                                            key
+                                            (lambda () '())))
+                                (new-item (list (bytes->path pathbytes) fields maj min)))
+                            (hash-table-put! colls 
+                                             key
+                                             ((table-insert t) new-item old-items)))]
+                         [_
+                          (error 'find-relevant-directories
+                                 "bad info-domain cache entry: ~e in: ~a" 
+                                 i
+                                 f)]))
+                     (let ([l (with-input-from-file f read)])
+                       (unless (list? l)
+                         (error 'find-relevant-directories
+                                "bad info-domain cache file: ~a" 
+                                f))
+                       l))))
+		(reverse (table-paths t)))
+      ;; For each coll, invert the mapping, adding the col name to the list for each sym: 
+      (hash-table-for-each colls
+			   (lambda (key vals)
+                             (for-each
+                              (lambda (val)
+                                (match val
+                                  [(path syms maj min)
+                                   (for-each (lambda (sym)
+                                               (hash-table-put! 
+                                                (table-ht t)
+                                                sym
+                                                (cons path (hash-table-get (table-ht t) sym (lambda () null)))))
+                                             syms)]
+                                  [_ (error 'get-info 
+                                            "Internal error: invalid info-domain value format: ~s" val)]))
+                              vals)))))
+
+  (define find-relevant-directories
+    (opt-lambda (syms [key 'preferred])
+      (define t (cond 
+                  [(eq? key 'preferred) preferred-table]
+                  [(eq? key 'all-available) all-available-table]
+                  [else (error 'find-relevant-directories "Invalid key: ~s" key)]))
+ 
+      (define search-path 
+        (cons user-infotable 
+              (map (lambda (coll) (build-path coll "info-domain" "compiled" "cache.ss"))
+                   (current-library-collection-paths))))
+      
+      (unless (equal? (table-paths t) search-path)
+        (set-table-ht! t (make-hash-table))
+        (set-table-paths! t search-path)
+        (populate-table! t))
+      
+      (let ([unsorted (if (= (length syms) 1)
+                          ;; Simple case: look up in table
+                          (hash-table-get (table-ht t) (car syms) (lambda () null))
+                          ;; Use a hash table, because the same collection might work for multiple syms
+                          (let ([result (make-hash-table 'equal)])
+                            (for-each (lambda (sym)
+                                        (let ([l (hash-table-get (table-ht t) sym (lambda () null))])
+                                          (for-each (lambda (c) (hash-table-put! result c #t))
+                                                    l)))
+                                      syms)
+                            ;; Extract the relevant collections:
+                            (hash-table-map result (lambda (k v) k))))])
+        (quicksort unsorted compare-directories))))
+  
+  (define (compare-directories a b)
+    (bytes<? (path->bytes a) (path->bytes b))))
diff --git a/collects/setup/info.ss b/collects/setup/info.ss
new file mode 100644
index 0000000000..44faf600a5
--- /dev/null
+++ b/collects/setup/info.ss
@@ -0,0 +1,13 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Setup PLT")
+  (define doc.txt "doc.txt")
+
+  (define compile-omit-files
+    (list "setup.ss" "winstall.ss"))
+
+  (define mzscheme-launcher-libraries (list "setup.ss"))
+  (define mzscheme-launcher-names (list "Setup PLT"))
+
+  ;(define mred-launcher-libraries (list "setup.ss"))
+  ;(define mred-launcher-names (list "GSetup PLT"))
+  )
diff --git a/collects/setup/infotab.ss b/collects/setup/infotab.ss
new file mode 100644
index 0000000000..b551c23f5b
--- /dev/null
+++ b/collects/setup/infotab.ss
@@ -0,0 +1,67 @@
+
+;; Defines a language to be used by info.ss files
+
+(module infotab mzscheme
+  (define-syntax info-module-begin
+    (lambda (stx)
+      (syntax-case stx ()
+	[(mod-beg defn ...)
+	 (let ([names (let loop ([defns (syntax->list (syntax (defn ...)))]
+                                 [r '()])
+                        (if (null? defns)
+                          (reverse! r)
+                          (loop (cdr defns)
+                                (syntax-case (car defns) (define)
+                                  [(define var val)
+                                   (cons (syntax var) r)]
+                                  ;; In case it gets expanded:
+                                  [(define-values (var) val)
+                                   (cons (syntax var) r)]
+                                  [(require lib) r] ; ignore these (see below)
+                                  [_else (raise-syntax-error
+                                          'infotab-module
+                                          "not a well-formed definition"
+                                          stx
+                                          (car defns))]))))])
+           (let ([dup (check-duplicate-identifier names)])
+             (when dup
+               (raise-syntax-error
+                'infotab-module
+                "duplicate definition"
+                stx
+                dup)))
+           (with-syntax ([(name ...) names])
+             (syntax
+               (#%plain-module-begin
+                defn ...
+                (define #%info-lookup
+                  (case-lambda
+                   [(n) (#%info-lookup n (lambda () (error 'info.ss "no info for ~a" n)))]
+                   [(n fail)
+                    (unless (and (procedure? fail)
+                                 (procedure-arity-includes? fail 0))
+                      (error
+                       'info.ss
+                       "expected second argument to be a procedure that takes no arguments, got: ~e"
+                       fail))
+                    (case n
+                      [(name) name]
+                      ...
+                      [else (fail)])]))
+		(define (#%info-domain) '(name ...))
+                (provide #%info-lookup #%info-domain)))))])))
+
+  (define-syntax (limited-require stx)
+    (syntax-case stx ()
+      [(_ lib) (member (syntax-object->datum #'lib)
+                       '((lib "string-constant.ss" "string-constants")))
+       (syntax/loc stx (require lib))]))
+
+  (provide (rename info-module-begin #%module-begin)
+	   #%app #%datum #%top
+	   define quote
+	   list cons car cdr quasiquote unquote unquote-splicing
+	   list* append reverse
+	   path->string build-path collection-path
+	   system-library-subpath
+           (rename limited-require require)))
diff --git a/collects/setup/option-sig.ss b/collects/setup/option-sig.ss
new file mode 100644
index 0000000000..2a6b1c78a4
--- /dev/null
+++ b/collects/setup/option-sig.ss
@@ -0,0 +1,24 @@
+
+(module option-sig mzscheme
+  (require (lib "unitsig.ss"))
+  
+  (provide setup-option^)
+
+  (define-signature setup-option^
+    (verbose
+     make-verbose
+     compiler-verbose
+     clean
+     compile-mode
+     make-zo
+     make-so
+     make-info-domain
+     make-launchers
+     call-install
+     pause-on-errors
+     force-unpacks
+     specific-collections
+     specific-planet-dirs
+     archives
+     current-target-directory-getter
+     current-target-plt-directory-getter)))
diff --git a/collects/setup/option-unit.ss b/collects/setup/option-unit.ss
new file mode 100644
index 0000000000..0ecfd49803
--- /dev/null
+++ b/collects/setup/option-unit.ss
@@ -0,0 +1,34 @@
+
+(module option-unit mzscheme
+  (require (lib "unitsig.ss"))
+
+  (require "option-sig.ss")
+
+  (provide setup:option@)
+
+  (define setup:option@
+    (unit/sig setup-option^
+      (import)
+
+      (define verbose (make-parameter #f))
+      (define make-verbose (make-parameter #f))
+      (define compiler-verbose (make-parameter #f))
+      (define clean (make-parameter #f))
+      (define compile-mode (make-parameter #f))
+      (define make-zo (make-parameter #t))
+      (define make-so (make-parameter #f))
+      (define make-launchers (make-parameter #t))
+      (define make-info-domain (make-parameter #t))
+      (define call-install (make-parameter #t))
+      (define pause-on-errors (make-parameter #f))
+      (define force-unpacks (make-parameter #f))
+
+      (define specific-collections (make-parameter null))
+      (define specific-planet-dirs (make-parameter null))
+      
+      (define archives (make-parameter null))
+
+      (define current-target-directory-getter (make-parameter current-directory))
+      (define current-target-plt-directory-getter 
+	(make-parameter 
+	 (lambda (preferred plthome choices) preferred))))))
diff --git a/collects/setup/pack.ss b/collects/setup/pack.ss
new file mode 100644
index 0000000000..d26eb30749
--- /dev/null
+++ b/collects/setup/pack.ss
@@ -0,0 +1,258 @@
+;; Utilities for creating a .plt package
+(module pack mzscheme
+  (require (lib "deflate.ss")
+           (lib "base64.ss" "net")
+           (lib "process.ss")
+	   (lib "list.ss")
+	   (lib "etc.ss")
+	   (lib "port.ss")
+	   (lib "file.ss")
+	   (lib "getinfo.ss" "setup"))
+
+  (provide pack mztar std-filter pack-collections)
+  
+  (define pack
+    (opt-lambda (dest name paths collections
+		      [filter std-filter]
+		      [encode? #t]
+		      [file-mode 'file]
+		      [unpack-unit #f]
+		      [plt-relative? #t]
+		      [requires null]
+		      [conflicts null]
+		      [plt-home-relative? #f])
+      (let*-values ([(file) (open-output-file dest 'truncate/replace)]
+                    [(fileout thd)
+                     (if encode?
+                         (let-values ([(b64-out b64-in) (make-pipe 4096)]
+                                      [(gz-out gz-in) (make-pipe 4096)])
+                           (thread
+                            (lambda ()
+                              (let ([normal (lambda ()
+                                              (gzip-through-ports gz-out b64-in #f 0)
+                                              (close-output-port b64-in))]
+                                    [gzip (find-executable-path "gzip" #f)])
+                                (if gzip
+                                    (let ([p (process* gzip "-c")])
+                                      (if (eq? 'running ((list-ref p 4) 'status))
+                                          (begin
+					    ;; Use gzip process.
+					    ;; Errors to error port:
+                                            (thread 
+                                             (lambda ()
+					       (dynamic-wind
+						void
+						(lambda ()
+						  (copy-port (cadddr p) (current-error-port)))
+						(lambda ()
+						  (close-input-port (cadddr p))))))
+					    ;; Copy input to gzip:
+                                            (thread
+                                             (lambda ()
+					       (dynamic-wind
+						void
+						(lambda ()
+						  (copy-port gz-out (cadr p)))
+						(lambda ()
+						  (close-input-port gz-out)
+						  (close-output-port (cadr p))))))
+					    ;; Copy input to b64:
+                                            (dynamic-wind
+                                             void
+                                             (lambda ()
+					       (copy-port (car p) b64-in))
+                                             (lambda ()
+                                               (close-input-port (car p))
+                                               (close-output-port b64-in))))
+                                          (normal)))
+                                    (normal)))))
+                           (values
+                            gz-in
+                            (thread
+                             (lambda ()
+                               (base64-encode-stream b64-out file)
+                               (close-output-port file)))))
+                         (values file (thread void)))])
+        (fprintf fileout "PLT~n")
+	(write
+         `(lambda (request failure)
+            (case request
+              [(name) ,name]
+              [(unpacker) 'mzscheme]
+	      [(requires) ',requires]
+	      [(conflicts) ',conflicts]
+	      [(plt-relative?) ,plt-relative?]
+	      [(plt-home-relative?) ,(and plt-relative?
+					  plt-home-relative?)]
+	      [else (failure)]))
+         fileout)
+        (newline fileout)
+        (write
+         (or unpack-unit
+             `(unit 
+                (import plthome mzuntar)
+                (export)
+                (mzuntar void)
+                (quote ,collections)))
+         fileout)
+        (newline fileout)
+        (for-each
+         (lambda (path)
+           (mztar path fileout filter file-mode))
+         paths)
+        (close-output-port fileout)
+        (thread-wait thd))))
+
+  (define (element->string x)
+    (if (path? x) (path->string x) x))
+
+  (define (mztar path output filter file-mode)
+    (define (path->list p)
+      (if (eq? p 'same)
+	  null
+	  (let-values ([(base name dir?) (split-path p)])
+	    (if (path? base)
+		(append (path->list base) (list name))
+		(list name)))))
+    (define-values (init-dir init-files)
+      (if (file-exists? path)
+          (let-values ([(base name dir?) (split-path path)])
+            (values (if (eq? base 'relative) 'same base) (list name)))
+          (values (if (string? path) (string->path path) path) #f)))
+    
+    (let loop ([dir init-dir][dpath (path->list init-dir)][files init-files])
+      (printf "MzTarring ~a...~n" 
+	      (path->string
+	       (if files
+		   (build-path dir (car files))
+		   dir)))
+      (fprintf output "~s~n~s~n" 'dir (map element->string dpath))
+      (for-each
+       (lambda (f)
+         (let* ([p (build-path dir f)]
+                [filter-val (filter p)])
+           (when filter-val
+             (if (directory-exists? p)
+                 (loop p (append dpath (list f)) #f)
+                 (let ([len (file-size p)])
+                   ;; (printf "MzTarring ~a~n" p)
+                   (fprintf output "~s~n~s~n~s~n*"
+                            (case filter-val
+                              [(file) 'file]
+                              [(file-replace) 'file-replace]
+                              [else file-mode])
+                            (map element->string (append dpath (list f)))
+                            len)
+                   (call-with-input-file* p
+                     (lambda (p)
+		       (copy-port p output))))))))
+       (or files (directory-list dir)))))
+  
+  (define (std-filter path)
+    (let-values ([(base name dir?) (split-path path)])
+      (let ([name (path->bytes name)])
+	(not (or (regexp-match #rx#"^CVS$" name)
+		 (regexp-match #rx#"^[.]svn$" name)
+		 (regexp-match #rx#"^[.]cvsignore$" name)
+		 (regexp-match #rx#"^compiled$" name)
+		 (regexp-match #rx#"~$" name)
+		 (regexp-match #rx#"^#.*#$" name)
+		 (regexp-match #rx#"[.]plt$" name)
+		 (regexp-match #rx#"^[.]#" name))))))
+
+  (define pack-collections
+    (opt-lambda (output name collections replace? extra-setup-collections [file-filter std-filter] [plt-home-relative? #f])
+      (let-values ([(dir source-files requires conflicts name)
+		    (let ([dirs (map (lambda (cp) (apply collection-path cp)) collections)])
+		      ;; Figure out the base path:
+		      (let* ([base-path #f]
+			     [base-path-setter #f]
+			     [rel-paths 
+			      (map (lambda (dir coll)
+				     (let-values ([(base c-name dir?) (split-path dir)])
+				       (let-values ([(base subdir)
+						     (let loop ([l (cdr coll)][base base])
+						       (let-values ([(base x-name dir?) (split-path base)])
+							 (if (null? l)
+							     (values base x-name)
+							     (let-values ([(base subdir) (loop (cdr l) base)])
+							       (values base (build-path subdir x-name))))))])
+					 (if base-path
+					     (unless (equal? base base-path)
+					       (error
+						'mzc
+						"cannot combine collections that live in different directories: \"~a\" and: \"~a\""
+						base-path-setter
+						dir))
+					     (begin
+					       (set! base-path-setter dir)
+					       (set! base-path base)))
+					 (build-path 'same subdir c-name))))
+				   dirs collections)]
+			     [infos (map (lambda (cp) (get-info cp))
+					 collections)]
+			     [coll-list? (lambda (cl)
+					   (and (list? cl)
+						(andmap (lambda (c) 
+							  (and (list? c)
+							       (andmap string? c)
+							       (andmap relative-path? c)))
+							cl)))]
+			     [get-dep-coll (lambda (which)
+					     (apply append (map (lambda (i src-cp)
+								  (let ([rl (if i
+										(i which (lambda () null))
+										null)])
+								    (unless (coll-list? rl)
+								      (error
+								       'mzc
+								       "bad ~a specification in info.ss for collection ~s"
+								       which
+								       src-cp))
+								    rl))
+								infos collections)))])
+			(values base-path
+				rel-paths
+				(get-dep-coll 'requires)
+				(append
+				 (if replace? null collections)
+				 (get-dep-coll 'conflicts))
+				(or name
+				    ((or (car infos)
+					 (lambda (n f) (caar collections)))
+				     'name
+				     (lambda () (caar collections)))))))])
+	(let ([output (path->complete-path output)])
+	  (parameterize ([current-directory dir])
+	    (pack output name
+		  source-files
+		  (append
+		   extra-setup-collections
+		   (filter get-info collections))
+		  file-filter #t 
+		  (if replace?
+		      'file-replace
+		      'file)
+		  #f
+		  #t ; plt-relative
+		  ;; For each require, get current version
+		  (map (lambda (r)
+			 (let ([i (get-info r)])
+			   (let ([v (and i (i 'version (lambda () #f)))])
+			     (if v
+				 (begin
+				   (unless (and (list? v)
+						(andmap number? v)
+						(andmap exact? v)
+						(andmap integer? v))
+				     (error
+				      'mzc
+				      "bad version specification in info.ss for collection ~s"
+				      r))
+				   (list r v))
+				 (list r null)))))
+		       (cons
+			'("mzscheme")
+			requires))
+		  conflicts
+		  plt-home-relative?)))))))
diff --git a/collects/setup/plt-installer-sig.ss b/collects/setup/plt-installer-sig.ss
new file mode 100644
index 0000000000..2d3d77de32
--- /dev/null
+++ b/collects/setup/plt-installer-sig.ss
@@ -0,0 +1,8 @@
+(module plt-installer-sig mzscheme
+  (require (lib "unitsig.ss"))
+  (provide setup:plt-installer^)
+  (define-signature setup:plt-installer^
+    (run-installer
+     with-installer-window
+     run-single-installer
+     on-installer-run)))
diff --git a/collects/setup/plt-installer-unit.ss b/collects/setup/plt-installer-unit.ss
new file mode 100644
index 0000000000..aa7b229735
--- /dev/null
+++ b/collects/setup/plt-installer-unit.ss
@@ -0,0 +1,131 @@
+
+(module plt-installer-unit mzscheme
+  (require (lib "unitsig.ss")
+           (lib "mred-sig.ss" "mred")
+           (lib "class.ss")
+           (lib "etc.ss")
+           "plt-installer-sig.ss"
+           (prefix single: "plt-single-installer.ss")
+           (lib "string-constant.ss" "string-constants"))
+  
+  (provide plt-installer@)
+  
+  (define plt-installer@
+    (unit/sig setup:plt-installer^
+      (import mred^)
+      
+      (define on-installer-run
+        (make-parameter void))
+      
+      ;; with-installer-window : ((union (instanceof dialog%) (instanceof frame%)) -> void) (-> void) -> void
+      ;; creates a frame and sets up the current error and output ports
+      ;; before calling `do-install'. 
+      ;; runs the installer in a separate thread and returns immediately,
+      ;; before the installation is complete. The cleanup thunk is called when installation completes
+      (define (with-installer-window do-install cleanup-thunk)
+        (let ([orig-eventspace (current-eventspace)]
+              [orig-custodian (current-custodian)]
+              [inst-eventspace (make-eventspace)])
+          (parameterize ([current-eventspace inst-eventspace])
+            (letrec ([dlg (make-object (class dialog% ()
+                                         (define/augment can-close? (lambda () (send done is-enabled?)))
+                                         (define/augment on-close (lambda () (done-callback)))
+                                         (super-make-object
+                                          (string-constant plt-installer-progress-window-title)
+                                          #f 600 300 #f #f '(resize-border))))]
+                     [text (make-object text%)]
+                     [canvas (make-object editor-canvas% dlg text)]
+                     [button-panel (instantiate horizontal-panel% ()
+                                     (parent dlg)
+                                     (stretchable-height #f)
+                                     (alignment '(center center)))]
+                     [kill-button (make-object button%
+				    (string-constant plt-installer-abort-installation)
+				    button-panel
+				    (lambda (b e) (kill)))]
+                     [done (make-object button% (string-constant close) button-panel (lambda (b e) (done-callback)))]
+                     [output (make-output-port
+                              #f
+                              always-evt
+                              (lambda (bytes start end flush? enable-break?)
+                                (parameterize ([current-eventspace inst-eventspace])
+                                  (queue-callback
+                                   (lambda ()
+                                     (let ([str (bytes->string/utf-8 (subbytes bytes start end))])
+                                       (send text lock #f)
+                                       (send text insert
+                                             str
+                                             (send text last-position)
+                                             'same 
+                                             ; Scroll on newlines only:
+                                             (regexp-match #rx"\n" str))
+                                       (send text lock #t)))))
+                                (- end start))
+                              void)]
+                     [kill
+                      (lambda ()
+                        (custodian-shutdown-all installer-cust)
+                        (fprintf output "\n~a\n" (string-constant plt-installer-aborted))
+                        (send done enable #t))]
+                     [completed-successfully? #f]
+                     [done-callback
+                      (lambda ()
+                        (send dlg show #f)
+                        (custodian-shutdown-all installer-cust))]
+                     [installer-cust (make-custodian)])
+              (send done enable #f)
+              ((current-text-keymap-initializer) (send text get-keymap))
+              (send text lock #t)
+              
+              ;; still do this even tho we aren't in the eventspace main thread
+              (thread (lambda () (send dlg show #t)))
+              
+              (parameterize ([current-custodian installer-cust])
+                (parameterize ([current-eventspace (make-eventspace)])
+                  (queue-callback
+                   (lambda ()
+                     
+                     (let ([installer-thread (current-thread)])
+                       (parameterize ([current-custodian orig-custodian])
+                         (thread
+                          (lambda ()
+                            (thread-wait installer-thread)
+                            (send kill-button enable #f)
+                            (unless completed-successfully? 
+                              (parameterize ([current-eventspace orig-eventspace])
+                                (queue-callback
+                                 (lambda ()
+                                   (cleanup-thunk)))))))))
+                    
+                     (parameterize ([current-output-port output]
+                                    [current-error-port output])
+                       (do-install dlg))
+                     (parameterize ([current-eventspace orig-eventspace])
+                       (queue-callback
+                        (lambda ()
+                          (set! completed-successfully? #t)
+                          ((on-installer-run))
+                          (cleanup-thunk))))
+                     
+                     (send done enable #t)))))))))
+      
+      (define run-single-installer single:run-single-installer)
+      
+      (define run-installer 
+        (opt-lambda (file [cleanup-thunk void])
+          (with-installer-window 
+           (lambda (frame)
+             (run-single-installer 
+              file
+              (lambda ()
+                (sleep 0.2) ; kludge to allow f to appear first
+                (end-busy-cursor)
+                ;; do these strings ever appear? (should move to string-constants, if so)
+                (let ([d (get-directory 
+                          "Select the destination for unpacking"
+                          frame)])
+                  (unless d
+                    (printf ">>> Cancelled <<<~n"))
+                  (begin-busy-cursor)
+                  d))))
+           cleanup-thunk))))))
diff --git a/collects/setup/plt-installer.ss b/collects/setup/plt-installer.ss
new file mode 100644
index 0000000000..7be81c804f
--- /dev/null
+++ b/collects/setup/plt-installer.ss
@@ -0,0 +1,10 @@
+(module plt-installer mzscheme
+  (require (lib "unitsig.ss")
+           "plt-installer-sig.ss"
+           "plt-installer-unit.ss"
+           (lib "mred.ss" "mred")
+           (lib "mred-sig.ss" "mred"))
+  
+  (provide-signature-elements setup:plt-installer^)
+  (define-values/invoke-unit/sig setup:plt-installer^ plt-installer@ #f mred^))
+
diff --git a/collects/setup/plt-single-installer.ss b/collects/setup/plt-single-installer.ss
new file mode 100644
index 0000000000..2a25a44fe5
--- /dev/null
+++ b/collects/setup/plt-single-installer.ss
@@ -0,0 +1,92 @@
+(module plt-single-installer mzscheme 
+  (require (lib "unitsig.ss")
+           (lib "etc.ss")
+           
+	   ;; All the rest are to get the imports for setup@:
+	   "option-sig.ss"
+	   "setup-unit.ss"
+	   "option-unit.ss"
+	   (lib "launcher-sig.ss" "launcher")
+	   (lib "launcher-unit.ss" "launcher")
+	   (lib "dynext-sig.ss" "dynext")
+	   (lib "dynext-unit.ss" "dynext")
+	   (lib "sig.ss" "compiler")
+	   (lib "option-unit.ss" "compiler")
+	   (lib "compiler-unit.ss" "compiler"))
+
+  (provide run-single-installer install-planet-package clean-planet-package)
+
+  ;; run-single-installer : string (-> string) -> void
+  ;; runs the instealler on the given package
+  (define (run-single-installer file get-target-dir)
+    (run-single-installer/internal file get-target-dir #f #f))
+  
+  ;; install-planet-package : path path (list string string (listof string) nat nat) -> void
+  ;; unpacks and installs the given planet package into the given path
+  (define (install-planet-package file directory spec)
+    (run-single-installer/internal file (lambda () directory) (cons directory spec) #f))
+  
+  ;; clean-planet-package : path (list string string (listof string) nat nat) -> void
+  ;; cleans the given planet package
+  (define (clean-planet-package directory spec)
+    (run-single-installer/internal #f (lambda () directory) (cons directory spec) #t))
+  
+  ;; run-single-installer : string (-> string) (list path string string nat nat) -> void
+  ;; creates a separate thread, runs the installer in that thread,
+  ;; returns when the thread completes
+  (define (run-single-installer/internal file get-target-dir planet-spec clean?)
+    (let ([cust (make-custodian)])
+      (parameterize ([current-custodian cust]
+                     [current-namespace (make-namespace)]
+                     [exit-handler (lambda (v) (custodian-shutdown-all cust))])
+        (let ([thd
+               (thread
+                (lambda ()
+                  (invoke-unit/sig
+                   (compound-unit/sig
+                     (import)
+                     (link [launcher : launcher^ (launcher@ dcompile dlink)]
+                           [dcompile : dynext:compile^ (dynext:compile@)]
+                           [dlink : dynext:link^ (dynext:link@)]
+                           [dfile : dynext:file^ (dynext:file@)]
+                           [option : compiler:option^ (compiler:option@)]
+                           [compiler : compiler^ (compiler@
+                                                  option
+                                                  dcompile
+                                                  dlink
+                                                  dfile)]
+                           [soption : setup-option^ (setup:option@)]
+                           [set-options : () ((unit/sig ()
+                                                (import setup-option^ compiler^)
+                                                ;; >>>>>>>>>>>>>> <<<<<<<<<<<<<<<
+                                                ;; Here's where we tell setup the archive file!
+                                                (unless clean? 
+                                                  (archives (list file)))
+                                                
+                                                ;; Here's where we make get a directory:
+                                                (current-target-directory-getter
+                                                 get-target-dir)
+                                                
+                                                (when planet-spec
+                                                  (specific-planet-dirs (list planet-spec)))
+                                                
+                                                (when clean?
+                                                  (clean #t)
+                                                  (make-zo #f)
+                                                  (make-so #f)
+                                                  (make-launchers #f)
+                                                  (make-info-domain #t)
+                                                  (call-install #f))
+                                                  
+                                                
+                                                )
+                                              soption
+                                              compiler)]
+                           [setup : () (setup@
+                                        soption
+                                        compiler
+                                        option
+                                        launcher)])
+                     (export)))))])
+          (thread-wait thd)
+          (custodian-shutdown-all cust))))))
diff --git a/collects/setup/plthome.ss b/collects/setup/plthome.ss
new file mode 100644
index 0000000000..64174632bb
--- /dev/null
+++ b/collects/setup/plthome.ss
@@ -0,0 +1,83 @@
+(module plthome mzscheme
+  (provide plthome plthome-ify un-plthome-ify)
+
+  (define plthome
+    (cond
+     [(getenv "PLTHOME") => (lambda (p) (simplify-path (string->path p)))]
+     [else (with-handlers ([void (lambda (e) #f)])
+             ;; use `split-path' to strip off the trailing "/"
+             (let-values ([(base name dir?)
+                           (split-path (simplify-path
+                                        (build-path (collection-path "mzlib")
+                                                    'up 'up)))])
+               (build-path (if (eq? 'relative base) (current-directory) base)
+                           name)))]))
+
+  ;; The plthome-ify and un-plthome-ify functions are used to store
+  ;; paths that are relative to plthome as such in dep files.  This
+  ;; means that if the plt tree is moved .dep files still work.
+  ;; `plthome-ify' uses `plthome' with a hard-wired "/" suffix, so it
+  ;; will not work properly if there is a different separator or if
+  ;; the input path uses a directory that is equivalent to plthome but
+  ;; not equal? to it.  The only processing that is performed is
+  ;; replacing all backslashes with slashes on Windows.  It is
+  ;; generally fine if this still misses some usages, as long as it
+  ;; works when we prepare a distribution tree using a proper PLTHOME
+  ;; env variable.  Otherwise, things will continue to work fine and
+  ;; .dep files will just contain absolute path names.  These
+  ;; functions work on dep elements -- either a pathname or a pair
+  ;; with a pathname in its cdr, the plthome-ified pathname will
+  ;; itself be a pair.
+
+  (define (simplify-bytes-path bytes)
+    (path->bytes (simplify-path (bytes->path bytes))))
+
+  (define simplify-path*
+    (if (eq? 'windows (system-type))
+      (lambda (str)
+        (regexp-replace* #rx#"\\\\" (simplify-bytes-path str) #"/"))
+      simplify-bytes-path))
+
+  (define plthome-bytes
+    (and plthome (path->bytes plthome)))
+  (define plthome/
+    (and plthome
+	 (regexp-replace #rx#"/?$" (simplify-path* (path->bytes plthome)) #"/")))
+  (define plthome/-len
+    (and plthome/ (bytes-length plthome/)))
+
+  (define (maybe-cdr-op fname f)
+    (lambda (x)
+      (cond [(not plthome/) (error fname "no PLTHOME and no mzlib found")]
+            [(and (pair? x) (not (eq? 'plthome (car x))))
+             (cons (car x) (f (cdr x)))]
+            [else (f x)])))
+
+  ;; plthome-ify : path-or-bytes -> datum-containing-bytes-or-path
+  (define (plthome-ify* path)
+    (let* ([path (cond [(bytes? path) path]
+                       [(path?  path) (path->bytes path)]
+                       [else (error 'plthome-ify
+                                    "expecting a byte-string, got ~e" path)])]
+           [path* (simplify-path* path)])
+      (cond [(and path*
+                  (> (bytes-length path*) plthome/-len)
+                  (equal? (subbytes path* 0 plthome/-len) plthome/))
+             (cons 'plthome (subbytes path* plthome/-len))]
+            [(equal? path* plthome-bytes) (cons 'plthome #"")]
+            [else path])))
+
+  ;; un-plthome-ify : datum-containing-bytes-or-path -> path
+  (define (un-plthome-ify* path)
+    (cond [(and (pair? path)
+                (eq? 'plthome (car path))
+                (bytes? (cdr path)))
+           (if (equal? (cdr path) #"")
+             plthome
+             (build-path plthome (bytes->path (cdr path))))]
+          [(bytes? path) (bytes->path path)]
+          [else path]))
+
+  (define plthome-ify    (maybe-cdr-op 'plthome-ify    plthome-ify*))
+  (define un-plthome-ify (maybe-cdr-op 'un-plthome-ify un-plthome-ify*))
+  )
diff --git a/collects/setup/setup-cmdline.ss b/collects/setup/setup-cmdline.ss
new file mode 100644
index 0000000000..37d0a99439
--- /dev/null
+++ b/collects/setup/setup-cmdline.ss
@@ -0,0 +1,77 @@
+
+;; Command-line parsing is in its own module because it has to be used
+;;  both in setup.ss (pre-zo, pre-cm) and setup-go.ss (use zos and cm).
+;; This means that command lines will be parsed twice.
+
+(module setup-cmdline mzscheme
+  (require (lib "cmdline.ss"))
+  
+  (provide parse-cmdline)
+
+  ;; The result of parse-cmdline is three lists:
+  ;;  - An assoc list mapping flag symbols to booleans
+  ;;     (nearly all symbols correspond to parameter names
+  ;;      in setup-go.ss)
+  ;;  - A list of specific collections
+  ;;  - A list of archives
+
+  (define (parse-cmdline argv)
+    (define x-flags null)
+    (define (add-flags l)
+      (set! x-flags (append (reverse l) x-flags)))
+    
+    (define-values (x-specific-collections x-archives)
+      (command-line
+       "setup-plt"
+       argv
+       (once-each
+	[("-c" "--clean") "Delete existing compiled files; implies -nxi"
+	 (add-flags '((clean #t)
+		      (make-zo #f)
+		      (call-install #f)
+		      (make-launchers #f)
+		      (make-info-domain #f)))]
+	[("-n" "--no-zo") "Do not produce .zo files"
+	 (add-flags '((make-zo #f)))]
+	[("-x" "--no-launcher") "Do not produce launcher programs"
+	 (add-flags '((make-launchers #f)))]
+	[("-i" "--no-install") "Do not call collection-specific pre-installers"
+	 (add-flags '((call-install #f)))]
+	[("-d" "--no-info-domain") "Do not produce info-domain caches"
+	 (add-flags '((make-info-domain #f)))]
+	[("-e" "--extension") "Produce native code extensions"
+	 (add-flags '((make-so #t)))]
+	[("-v" "--verbose") "See names of compiled files and info printfs"
+	 (add-flags '((verbose #t)))]
+	[("-m" "--make-verbose") "See make and compiler usual messages"
+	 (add-flags '((make-verbose #t)))]
+	[("-r" "--compile-verbose") "See make and compiler verbose messages"
+	 (add-flags '((make-verbose #t)
+		      (compiler-verbose #t)))]
+	[("--trust-zos") "Trust existing .zos (use only with prepackaged .zos)"
+	 (add-flags '((trust-existing-zos #t)))]
+	[("-p" "--pause") "Pause at the end if there are any errors"
+	 (add-flags '((pause-on-errors #t)))]
+	[("--force") "Treat version mismatches for archives as mere warnings"
+	 (add-flags '((force-unpacks #t)))]
+	[("-a" "--all-users") "Install archives into PLTHOME, not user-specific directory"
+	 (add-flags '((all-users #t)))]
+	[("--mode") mode "Select a compilation mode"
+	 (add-flags `((compile-mode ,mode)))]
+	[("-l") =>
+	 (lambda (flag . collections)
+	   (map list collections))
+	 '("Setup specific <collection>s only" "collection")])
+       (=>
+	(lambda (collections . archives)
+	  (values (if (null? collections)
+		      null
+		      (car collections))
+		  archives))
+	'("archive")
+	(lambda (s)
+	  (display s)
+	  (printf "If no <archive> or -l <collection> is specified, all collections are setup~n")
+	  (exit 0)))))
+
+    (values x-flags x-specific-collections x-archives)))
diff --git a/collects/setup/setup-go.ss b/collects/setup/setup-go.ss
new file mode 100644
index 0000000000..92391dd752
--- /dev/null
+++ b/collects/setup/setup-go.ss
@@ -0,0 +1,79 @@
+
+(module setup-go mzscheme
+  (require "setup-cmdline.ss"
+	   (lib "unitsig.ss")
+
+	    "option-sig.ss"
+	    "setup-unit.ss"
+	    "option-unit.ss"
+	    (lib "cm.ss"))
+
+  (define-values/invoke-unit/sig setup-option^
+    setup:option@)
+
+  (define-values (x-flags x-specific-collections x-archives)
+    (parse-cmdline (current-command-line-arguments)))
+
+  ;; Pseudo-option:
+  (define (all-users on?)
+    (when on?
+      (current-target-plt-directory-getter
+       (lambda (preferred plthome choices) plthome))))
+
+  ;; Converting parse-cmdline results into parameter settings:
+  (define (do-flag name param)
+    (let ([a (assq name x-flags)])
+      (when a
+	(param (cadr a)))))
+  (define-syntax all-flags
+    (syntax-rules ()
+      [(_ f ...) (begin
+		   (do-flag 'f f)
+		   ...)]))
+  (all-flags clean
+	     make-zo
+	     call-install
+	     make-launchers
+	     make-so
+	     verbose
+	     make-verbose
+	     trust-existing-zos
+	     pause-on-errors
+	     force-unpacks
+	     all-users
+	     compile-mode)
+
+  (specific-collections x-specific-collections)
+  (archives x-archives)
+  (specific-planet-dirs '())
+
+  (require (lib "launcher-sig.ss" "launcher")
+	   (lib "launcher-unit.ss" "launcher")
+
+	   (lib "dynext-sig.ss" "dynext")
+	   (lib "dynext-unit.ss" "dynext"))
+
+  (require (lib "sig.ss" "compiler")
+	   (lib "option-unit.ss" "compiler")
+	   (lib "compiler-unit.ss" "compiler"))
+
+  (invoke-unit/sig
+   (compound-unit/sig
+    (import (SOPTION : setup-option^))
+    (link [launcher : launcher^ (launcher@ dcompile dlink)]
+	  [dcompile : dynext:compile^ (dynext:compile@)]
+	  [dlink : dynext:link^ (dynext:link@)]
+	  [dfile : dynext:file^ (dynext:file@)]
+	  [option : compiler:option^ (compiler:option@)]
+	  [compiler : compiler^ (compiler@
+				 option
+				 dcompile
+				 dlink
+				 dfile)]
+	  [setup : () (setup@
+		       SOPTION
+		       compiler
+		       option
+		       launcher)])
+    (export))
+   setup-option^))
diff --git a/collects/setup/setup-unit.ss b/collects/setup/setup-unit.ss
new file mode 100644
index 0000000000..e8aee109a2
--- /dev/null
+++ b/collects/setup/setup-unit.ss
@@ -0,0 +1,797 @@
+ 
+; Expects parameters to be set before invocation.
+; Calls `exit' when done.
+
+(module setup-unit mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "unit.ss")
+	   (lib "file.ss")
+	   (lib "list.ss")
+	   (lib "cm.ss")
+	   (lib "port.ss")
+           (lib "match.ss")
+           (lib "planet-archives.ss" "planet")
+           
+	   "option-sig.ss"
+	   (lib "sig.ss" "compiler")
+	   (lib "launcher-sig.ss" "launcher")
+           
+	   "unpack.ss"
+	   "getinfo.ss"
+	   "plthome.ss")
+  
+  (provide setup@)
+  
+  (define setup@
+    (unit/sig ()
+      (import setup-option^
+	      compiler^
+	      (compiler:option : compiler:option^)
+	      launcher^)
+      
+      (define setup-fprintf
+	(lambda (p s . args)
+	  (apply fprintf p (string-append "setup-plt: " s "~n") args)))
+      
+      (define setup-printf
+	(lambda (s . args)
+	  (apply setup-fprintf (current-output-port) s args)))
+      
+      (setup-printf "Setup version is ~a" (version))
+      (setup-printf "PLT home directory is ~a" (path->string plthome))
+      (setup-printf "Collection paths are ~a" (if (null? (current-library-collection-paths))
+						  "empty!"
+						  ""))
+      (for-each (lambda (p)
+		  (setup-printf "  ~a" (path->string p)))
+		(current-library-collection-paths))
+      
+      (define (warning s x)
+	(setup-printf s
+		      (if (exn? x)
+			  (exn-message x)
+			  x)))
+      
+      (define (call-info info flag mk-default test)
+	(if info
+	    (let ([v (info flag mk-default)])
+	      (test v)
+	      v)
+	    (mk-default)))
+      
+      (define mode-dir
+	(if (compile-mode)
+	    (build-path "compiled" (compile-mode))
+	    (build-path "compiled")))
+      
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;               Archive Unpacking               ;;
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      
+      (define x-specific-collections
+	(apply 
+	 append
+	 (specific-collections)
+	 (map (lambda (x) (unpack 
+			   x 
+			   plthome 
+			   (lambda (s) (setup-printf "~a" s)) 
+			   (current-target-directory-getter)
+			   (force-unpacks)
+			   (current-target-plt-directory-getter)))
+	      (archives))))
+      
+      (define x-specific-planet-dirs (specific-planet-dirs))
+      
+      (define (done)
+	(setup-printf "Done setting up"))
+            
+      (unless (null? (archives))
+	(when (and (null? x-specific-collections) (null? x-specific-planet-dirs))
+	  (done)
+	  (exit 0))) ; done
+      
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;              Find Collections                 ;;
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      
+      (define-struct cc (collection path name info info-path shadowing-policy) (make-inspector))
+      
+      (define (warning-handler v)
+	(lambda (exn) 
+	  (setup-printf 
+	   "Warning: ~a"
+	   (if (exn? exn)
+	       (exn-message exn)
+	       exn))
+	  v))
+      
+      ;; collection->cc : listof path -> cc
+      (define (collection->cc collection-p)
+        (let ([root-dir (ormap (lambda (p)
+                                 (parameterize ([current-library-collection-paths
+                                                 (list p)])
+                                   (and (with-handlers ([exn:fail? (lambda (x) #f)])
+                                          (apply collection-path collection-p))
+                                        p)))
+                               (current-library-collection-paths))])
+          (let* ([info (with-handlers ([exn:fail? (warning-handler #f)])
+                         (get-info collection-p))]
+                 [name (call-info info 'name (lambda () #f)
+                                  (lambda (x)
+                                    (when x
+                                      (unless (string? x)
+                                        (error 
+                                         (format 
+                                          "'name' result from collection ~s is not a string:"
+                                          collection-p)
+                                         x)))))])
+            (and
+             name
+             (make-cc
+              collection-p
+              (apply collection-path collection-p)
+              name
+              info
+              (build-path root-dir "info-domain" "compiled" "cache.ss")
+              ;; by convention, all collections have "version" 1 0. This forces them
+              ;; to conflict with each other.
+              (list (cons 'lib (map path->string collection-p)) 1 0))))))
+      
+      ;; remove-falses : listof (union X #f) -> listof X
+      ;; returns the non-false elements of l in order
+      (define (remove-falses l) (filter (lambda (x) x) l))
+      
+      (define (planet->cc path owner pkg-file extra-path maj min)
+        (unless (path? path)
+            (error 'path->cc "non-path when building package ~a" pkg-file))
+        (let/ec return
+          (let* ([info (with-handlers ([exn:fail? (warning-handler #f)])
+                         (get-info/full path))]
+                 [name (call-info info 'name (lambda () (return #f))
+                                  (lambda (x)
+                                    (when x
+                                      (unless (string? x)
+                                        (error 
+                                         (format 
+                                          "'name' result from directory ~s is not a string:"
+                                          path)
+                                         x)))))])
+            (make-cc
+             #f
+             path
+             name
+             info
+             (build-path (find-system-path 'addon-dir) "cache.ss")
+             (list `(planet ,owner ,pkg-file ,@extra-path) maj min)))))
+      
+      ;; this is an awful hack
+      (define (planet-cc->sub-cc cc subdir)
+        (match-let ([(('planet owner pkg-file extra-path ...) maj min) (cc-shadowing-policy cc)])
+          (planet->cc 
+           (build-path (cc-path cc) subdir)
+           owner
+           pkg-file
+           (append extra-path (list (path->string subdir)))
+           maj
+           min)))
+
+      (define (cannot-compile c)
+	(error 'setup-plt "don't know how to compile collection: ~a" 
+	       (if (= (length c) 1)
+		   (car c)
+		   c)))
+      
+      (define planet-dirs-to-compile 
+        (remove-falses
+         (map (lambda (spec) (apply planet->cc spec))
+              (if (and (null? x-specific-collections) (null? x-specific-planet-dirs))
+                  (get-installed-planet-archives)
+                  x-specific-planet-dirs))))
+      
+      (define collections-to-compile
+	(quicksort
+	 (if (and (null? x-specific-collections) (null? x-specific-planet-dirs))
+	     (let ([ht (make-hash-table 'equal)])
+	       (let loop ([collection-paths (current-library-collection-paths)])
+		 (cond
+                   [(null? collection-paths) 
+                    (hash-table-map ht (lambda (k v) v))]
+                   [else (let* ([cp (car collection-paths)]
+                                [cp-contents
+                                 (if (directory-exists? cp)
+                                     (directory-list cp)
+                                     null)])
+                           (let loop ([collections (filter
+                                                    (lambda (x)
+                                                      (directory-exists?
+                                                       (build-path cp x)))
+                                                    cp-contents)])
+                             (cond
+                               [(null? collections) (void)]
+                               [else (let* ([collection (car collections)])
+                                       (hash-table-get
+                                        ht
+                                        collection
+                                        (lambda ()
+                                          (let ([cc (collection->cc (list collection))])
+                                            (when cc
+                                              (hash-table-put! 
+                                               ht
+                                               collection
+                                               cc))))))
+                                     (loop (cdr collections))])))
+                         (loop (cdr collection-paths))])))
+	     (map
+	      (lambda (c)
+		(or (collection->cc (map string->path c))
+		    (cannot-compile c)))
+	      x-specific-collections))
+	 (lambda (a b) (string-ci<? (cc-name a) (cc-name b)))))
+      
+      ;; Close over sub-collections
+      (set! collections-to-compile
+	    (let loop ([l collections-to-compile])
+	      (if (null? l)
+		  null
+		  (let* ([cc (car l)]
+			 [info (cc-info cc)])
+		    (append
+		     (map
+		      (lambda (subcol)
+			(or
+			 (collection->cc (map string->path subcol))
+			 (cannot-compile subcol)))
+		      (call-info info 'compile-subcollections
+				 ;; Default: subdirs with info.ss files
+				 (lambda ()
+				   (map
+				    (lambda (l) (map path->string l))
+				    (map (lambda (x) (append (cc-collection cc) (list x)))
+					 (filter
+					  (lambda (p)
+                                            (let ((d (build-path (cc-path cc) p)))
+                                              (and (directory-exists? d)
+                                                   (file-exists? (build-path d "info.ss")))))
+                                          (directory-list (cc-path cc))))))
+				 ;; Result checker:
+				 (lambda (x)
+				   (unless (and (list? x)
+						(andmap
+						 (lambda (x)
+						   (and (list? x)
+							(andmap
+							 (lambda (x)
+							   (and (path-string? x)
+								(relative-path? x)))
+							 x)))
+						 x))
+				     (error "result is not a list of relative path string lists:" x)))))
+		     (list cc)
+		     (loop (cdr l)))))))
+
+      (set! planet-dirs-to-compile
+	    (let loop ([l planet-dirs-to-compile])
+	      (if (null? l)
+		  null
+		  (let* ([cc (car l)]
+			 [info (cc-info cc)])
+		    (append
+		     (remove-falses
+                      (map
+                       (lambda (p) (planet-cc->sub-cc cc p))
+                       (call-info info 'compile-subcollections
+                                  (lambda ()
+                                    (filter
+                                     (lambda (p)
+                                       (let ((d (build-path (cc-path cc) p)))
+                                         (and (directory-exists? d)
+                                              (file-exists? (build-path d "info.ss"))))) 
+                                     (directory-list (cc-path cc))))
+                                  ;; Result checker:
+                                  path?)))
+                     (list cc)
+                     (loop (cdr l)))))))
+
+      (define ccs-to-compile (append collections-to-compile planet-dirs-to-compile))
+      
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;                  Helpers                      ;;
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      
+      (define (control-io-apply print-doing f args)
+        (if (make-verbose)
+            (begin
+              (apply f args)
+              #t)
+            (let* ([oop (current-output-port)]
+                   [printed? #f]
+                   [on? #f]
+                   [dir-table (make-hash-table 'equal)]
+                   [line-accum #""]
+                   [op (if (verbose)
+                           (current-output-port)
+                           (open-output-nowhere))] 
+                   [doing-path (lambda (path)
+                                 (unless printed?
+                                   (set! printed? #t)
+                                   (print-doing oop))
+                                 (unless (verbose)
+                                   (let ([path (normal-case-path (path-only path))])
+                                     (unless (hash-table-get dir-table path (lambda () #f))
+                                       (hash-table-put! dir-table path #t)
+                                       (print-doing oop path)))))])
+              (parameterize ([current-output-port op]
+                             [compile-notify-handler doing-path])
+                (apply f args)
+                printed?))))
+      
+      (define errors null)
+      (define (record-error cc desc go)
+	(with-handlers ([exn:fail?
+			 (lambda (x)
+			   (if (exn? x)
+			       (begin
+				 (fprintf (current-error-port) "~a~n" (exn-message x)))
+			       (fprintf (current-error-port) "~s~n" x))
+			   (set! errors (cons (list cc desc x) errors)))])
+	  (go)))
+      (define (show-errors port)
+	(for-each
+	 (lambda (e)
+	   (let ([cc (car e)]
+		 [desc (cadr e)]
+		 [x (caddr e)])
+	     (setup-fprintf port
+			    "Error during ~a for ~a (~a)"
+			    desc (cc-name cc) (path->string (cc-path cc)))
+	     (if (exn? x)
+		 (setup-fprintf port "  ~a" (exn-message x))
+		 (setup-fprintf port "  ~s" x))))
+	 (reverse errors)))
+      
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;                  Clean                        ;;
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      
+      (define (delete-file/record-dependency path dependencies)
+	(when (regexp-match-positions #rx"[.]dep$" (path->bytes path))
+	  (let ([deps (with-handlers ([exn:fail? (lambda (x) null)])
+			(with-input-from-file path read))])
+	    (when (and (pair? deps) (list? deps))
+              (for-each (lambda (s)
+			  (when (path-string? s)
+			    (hash-table-put! dependencies s #t)))
+			(map un-plthome-ify (cdr deps))))))
+	(delete-file path))
+      
+      (define (delete-files-in-directory path printout dependencies)
+	(for-each
+	 (lambda (end-path)
+	   (let ([path (build-path path end-path)])
+	     (cond
+               [(directory-exists? path)
+                (void)]
+               [(file-exists? path)
+                (printout)
+                (delete-file/record-dependency path dependencies)]
+               [else (error 'delete-files-in-directory
+                            "encountered ~a, neither a file nor a directory"
+                            path)])))
+	 (directory-list path)))
+      
+      (define (clean-collection cc dependencies)
+        (record-error 
+         cc
+         "Cleaning"
+         (lambda ()
+           (let* ([info (cc-info cc)]
+                  [default (box 'default)]
+                  [paths (call-info
+                          info
+                          'clean
+                          (lambda ()
+                            (list mode-dir
+                                  (build-path mode-dir "native")
+                                  (build-path mode-dir "native" (system-library-subpath))))
+                          (lambda (x)
+                            (unless (or (eq? x default)
+                                        (and (list? x)
+                                             (andmap path-string? x)))
+                              (error 'setup-plt "expected a list of path strings for 'clean, got: ~s"
+                                     x))))]
+                  [printed? #f]
+                  [print-message
+                   (lambda ()
+                     (unless printed?
+                       (set! printed? #t)
+                       (setup-printf "Deleting files for ~a at ~a" (cc-name cc) (path->string (cc-path cc)))))])
+             (for-each (lambda (path)
+                         (let ([full-path (build-path (cc-path cc) path)])
+                           (when (or (file-exists? full-path) (directory-exists? full-path))
+                             (let loop ([path (find-relative-path (normalize-path (cc-path cc))
+                                                                  (normalize-path full-path))])
+                               (let loop ([path path])
+                                 (let-values ([(base name dir?) (split-path path)])
+                                   (cond
+                                     [(path? base)
+                                      (loop base)]
+                                     [(eq? base 'relative)
+                                      (when (eq? name 'up)
+                                        (error 'clean
+                                               "attempted to clean files in ~s which is not a subdirectory of ~s"
+                                               full-path
+                                               (cc-path cc)))]
+                                     [else
+                                      (error 'clean
+                                             "attempted to clean files in ~s which is not a subdirectory of ~s"
+                                             full-path
+                                             (cc-path cc))]))))
+                             
+                             (cond
+                               [(directory-exists? full-path)
+                                (delete-files-in-directory
+                                 full-path
+                                 print-message
+                                 dependencies)]
+                               [(file-exists? full-path)
+                                (delete-file/record-dependency full-path dependencies)
+                                (print-message)]
+                               [else (void)]))))
+                       paths)))))
+      
+      (when (clean)
+        (let ([dependencies (make-hash-table 'equal)])
+          ;; Main deletion:
+          (for-each (lambda (cc)
+                      (clean-collection cc dependencies))
+                    ccs-to-compile)
+          ;; Unless specific collections were named, also
+          ;;  delete .zos for referenced modules and delete
+          ;;  info-domain cache
+          (when (and (null? x-specific-collections) (null? x-specific-planet-dirs))
+            (setup-printf "Checking dependencies")
+            (let loop ([old-dependencies dependencies])
+              (let ([dependencies (make-hash-table 'equal)]
+                    [did-something? #f])
+                (hash-table-for-each
+                 old-dependencies
+                 (lambda (file _)
+                   (let-values ([(dir name dir?) (split-path file)])
+                     (let ([base-name (path-replace-suffix name #"")])
+                       (let ([zo (build-path dir mode-dir (format "~a.zo" base-name))]
+                             [dep (build-path dir mode-dir (format "~a.dep" base-name))])
+                         (when (and (file-exists? dep)
+                                    (file-exists? zo))
+                           (set! did-something? #t)
+                           (setup-printf "  deleting ~a" zo)
+                           (delete-file/record-dependency zo dependencies)
+                           (delete-file/record-dependency dep dependencies)))))))
+                (when did-something?
+                  (loop dependencies))))
+            (setup-printf "Clearing info-domain caches")
+            (for-each (lambda (p)
+                        (let ([fn (build-path p "info-domain" "compiled" "cache.ss")])
+                          (when (file-exists? fn)
+                            (with-handlers ([exn:fail:filesystem? (warning-handler (void))])
+                              (with-output-to-file fn void 'truncate/replace)))))
+                      (current-library-collection-paths)))))
+      
+      (when (or (make-zo) (make-so))
+        (compiler:option:verbose (compiler-verbose))
+        (compiler:option:compile-subcollections #f))
+      
+      (define (do-install-part part)
+        (when (or (call-install) (eq? part 'post))
+          (for-each
+           (lambda (cc)
+             (let/ec k
+               (record-error
+                cc
+                (case part
+                  [(pre)     "Early Install"]
+                  [(general) "General Install"]
+                  [(post)    "Post Install"])
+                (lambda ()
+                  (let ([fn (call-info
+                             (cc-info cc)
+                             (case part
+                               [(pre)     'pre-install-collection]
+                               [(general) 'install-collection]
+                               [(post)    'post-install-collection])
+                             (lambda () (k #f))
+                             (lambda (v)
+                               (unless (and (path-string? v)
+                                            (relative-path? v))
+                                 (error "result is not a relative path string: " v))
+                               (let ([p (build-path (cc-path cc) v)])
+                                 (unless (file-exists? p)
+                                   (error "installer file does not exist: " p)))))])
+                    (let ([installer
+                           (with-handlers ([exn:fail? (lambda (exn)
+                                                        (error 'setup-plt
+                                                               "error loading installer: ~a"
+                                                               (if (exn? exn) (exn-message exn) exn)))])
+                             (dynamic-require (build-path (cc-path cc) fn)
+                                              (case part
+                                                [(pre)     'pre-installer]
+                                                [(general) 'installer]
+                                                [(post)    'post-installer])))])
+                      (setup-printf "~aInstalling ~a"
+                                    (case part [(pre) "Pre-"] [(post) "Post-"] [else ""])
+                                    (cc-name cc))
+		      (if (procedure-arity-includes? installer 2)
+			  (installer plthome (cc-path cc))
+			  (installer plthome))))))))
+           ccs-to-compile)))
+      
+      (do-install-part 'pre)
+      
+      (define (make-it desc compile-directory)
+        ;; To avoid polluting the compilation with modules that are
+        ;; already loaded, create a fresh namespace before calling
+        ;; this function
+        (for-each (lambda (cc)
+                    (record-error
+                     cc
+                     (format "Compiling ~a" desc)
+                     (lambda ()
+                       (unless (control-io-apply
+                                (case-lambda 
+                                  [(p) 
+                                   ;; Main "doing something" message
+                                   (setup-fprintf p "Compiling ~a used by ~a" 
+                                                  desc (cc-name cc))]
+                                  [(p where)
+                                   ;; Doing something specifically in "where"
+                                   (setup-fprintf p "  in ~a" 
+                                                  (path->string
+                                                   (path->complete-path
+                                                    where
+                                                    (cc-path cc))))])
+                                compile-directory
+                                (list (cc-path cc) (cc-info cc)))
+                         (setup-printf "No more ~a to compile for ~a" 
+                                       desc (cc-name cc)))))
+                    (collect-garbage))
+                  ccs-to-compile))
+      
+      (define orig-namespace (current-namespace))
+      
+      (define (with-specified-mode thunk)
+        (if (not (compile-mode))
+            (thunk)
+            ;; Use the indicated mode
+            (let ([zo-compile (with-handlers ([exn:fail?
+                                               (lambda (exn)
+                                                 (error 'setup-plt
+                                                        "error loading compiler for mode ~s: ~s"
+                                                        (compile-mode)
+                                                        (if (exn? exn)
+                                                            (exn-message exn)
+                                                            exn)))])
+                                (dynamic-require `(lib "zo-compile.ss" ,(compile-mode)) 'zo-compile))]
+                  [orig-kinds (use-compiled-file-paths)]
+                  [orig-compile (current-compile)])
+              (parameterize ([current-namespace (make-namespace)]
+                             [current-compile zo-compile]
+                             [use-compiled-file-paths (list mode-dir)]
+                             [current-compiler-dynamic-require-wrapper
+                              (lambda (thunk)
+                                (parameterize ([current-namespace orig-namespace]
+                                               [use-compiled-file-paths orig-kinds]
+                                               [current-compile orig-compile])
+                                  (thunk)))])
+                (thunk)))))
+      
+      
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;                  Make zo                      ;;
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      
+      (when (make-zo) 
+        (with-specified-mode
+         (lambda ()
+           (make-it ".zos" compile-directory-zos))))
+      (when (make-so) (make-it "extensions" compile-directory-extension))
+      
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;               Info-Domain Cache               ;;
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      
+      (when (make-info-domain)
+        ;; Each ht maps a collection root dir to an
+        ;; info-domain table. Even when `collections-to-compile'
+        ;; is a subset of all collections, we only care about
+        ;; those collections that exist in the same root as
+        ;; the ones in `collections-to-compile'.
+        (let ([ht (make-hash-table 'equal)]
+              [ht-orig (make-hash-table 'equal)])
+          (for-each (lambda (cc)
+                      (let ([domain (with-handlers ([exn:fail? (lambda (x)
+                                                                 (lambda () null))])
+                                      (dynamic-require
+                                       (build-path (cc-path cc) "info.ss")
+                                       '#%info-domain))])
+                        ;; Check whether we have a table for this cc's info-domain cache:
+                        (let ([t (hash-table-get ht 
+                                                 (cc-info-path cc)
+                                                 (lambda ()
+                                                   ;; No table for this root, yet. Build one.
+                                                   (let ([l (let ([p (cc-info-path cc)])
+                                                              (if (file-exists? p)
+                                                                  (with-handlers ([exn:fail? (warning-handler null)])
+                                                                    (with-input-from-file p
+                                                                      read))
+                                                                  null))])
+                                                     ;; Convert list to hash table. Incluse only well-formed
+                                                     ;;  list elements, and only elements whose corresponding
+                                                     ;;  collection exists.
+                                                     (let ([t (make-hash-table 'equal)]
+                                                           [all-ok? #f])
+                                                       (when (list? l)
+                                                         (set! all-ok? #t)
+                                                         (for-each 
+                                                          (lambda (i)
+                                                            (match i
+                                                              [((? (lambda (a) 
+                                                                       (and (bytes? a)
+                                                                            (file-exists? (build-path 
+                                                                                           (bytes->path a)
+                                                                                           "info.ss"))))
+                                                                   a)
+                                                                ((? symbol? b) ...) 
+                                                                c
+                                                                (? integer? d)
+                                                                (? integer? e))
+                                                               (hash-table-put! t a (list b c d e))]
+                                                              [_ 
+                                                               (set! all-ok? #f)]))
+                                                          l))
+                                                       ;; Record the table loaded for this collection root
+                                                       ;; in the all-roots table:
+                                                       (hash-table-put! ht (cc-info-path cc) t)
+                                                       ;; If anything in the "cache.ss" file was bad,
+                                                       ;; then claim that the old table was empty,
+                                                       ;; so that we definitely write the new table.
+                                                       (hash-table-put! ht-orig (cc-info-path cc) 
+                                                                        (and all-ok? (hash-table-copy t)))
+                                                       t))))])
+                          ;; Add this collection's info to the table, replacing
+                          ;; any information already there.
+                          (hash-table-put! t 
+                                           (path->bytes (cc-path cc))
+                                           (cons (domain) (cc-shadowing-policy cc))))))
+                    ccs-to-compile)
+          ;; Write out each collection-root-specific table to a "cache.ss" file:
+          (hash-table-for-each ht
+                               (lambda (info-path ht)
+                                 (unless (equal? ht (hash-table-get ht-orig info-path))
+                                   (let-values ([(base name must-be-dir?) (split-path info-path)])
+                                     (unless (path? base)
+                                       (error 'make-info-domain "Internal error: cc had invalid info-path: ~s" info-path))
+                                     (make-directory* base)
+                                     (let ([p info-path])
+                                       (setup-printf "Updating ~a" p)
+                                       (with-handlers ([exn:fail? (warning-handler (void))])
+                                         (with-output-to-file p
+                                           (lambda ()
+                                             (write (hash-table-map ht cons))
+                                             (newline))
+                                           'truncate/replace)))))))))
+      
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;                  Make Launchers               ;;
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      
+      (when (make-launchers)
+        (let ([name-list
+               (lambda (l)
+                 (unless (and (list? l) (andmap (lambda (x) (and (path-string? x) (relative-path? x))) l))
+                   (error "result is not a list of relative path strings:" l)))]
+              [flags-list
+               (lambda (l)
+                 (unless (and (list? l) (andmap (lambda (fs) (andmap string? fs)) l))
+                   (error "result is not a list of strings:" l)))]
+              [or-f (lambda (f) (lambda (x) (when x (f x))))])
+          (for-each
+           (lambda (cc)
+             (record-error
+              cc
+              "Launcher Setup"
+              (lambda ()
+                (let* ([info (cc-info cc)]
+                       [make-launcher
+                        (lambda (kind
+                                 launcher-names
+                                 launcher-libraries
+                                 launcher-flags
+                                 program-launcher-path
+                                 make-launcher
+                                 up-to-date?)
+                          (let ([mzlns (call-info info launcher-names (lambda () null) name-list)]
+                                [mzlls (call-info info launcher-libraries (lambda () #f) (or-f name-list))]
+                                [mzlfs (call-info info launcher-flags (lambda () #f) (or-f flags-list))])
+                            (cond
+                              [(null? mzlns) (void)]
+                              [(not (or mzlls mzlfs))
+                               (unless (null? mzlns)
+                                 (setup-printf
+                                  "Warning: ~a launcher name list ~s has no matching library/flags lists"
+                                  kind mzlns))]
+                              [(and (or (not mzlls) (= (length mzlns) (length mzlls)))
+                                    (or (not mzlfs) (= (length mzlns) (length mzlfs))))
+                               (for-each
+                                (lambda (mzln mzll mzlf)
+                                  (let ([p (program-launcher-path mzln)]
+                                        [aux (cons `(exe-name . ,mzln)
+                                                   (build-aux-from-path
+                                                    (build-path (cc-path cc)
+                                                                (path-replace-suffix (or mzll mzln) #""))))])
+                                    (unless (up-to-date? p aux)
+                                      (setup-printf "Installing ~a~a launcher ~a"
+                                                    kind (if (eq? (current-launcher-variant) 'normal)
+                                                             ""
+                                                             (current-launcher-variant))
+                                                    (path->string p))
+                                      (make-launcher
+                                       (or mzlf
+                                           (if (and (cc-collection cc)
+                                                    (= 1 (length (cc-collection cc))))
+                                               ;; Common case (simpler parsing for Windows to
+                                               ;; avoid cygwin bug):
+                                               (list "-qmvL-" mzll (path->string (car (cc-collection cc))))
+                                               (list "-qmvt-" (format "~a" (path->string (build-path (cc-path cc) mzll))))))
+                                       p
+                                       aux))))
+                                mzlns
+                                (or mzlls (map (lambda (_) #f) mzlns))
+                                (or mzlfs (map (lambda (_) #f) mzlns)))]
+                              [else
+                               (let ([fault (if (or (not mzlls) (= (length mzlns) (length mzlls))) 'f 'l)])
+                                 (setup-printf
+                                  "Warning: ~a launcher name list ~s doesn't match ~a list; ~s"
+                                  kind mzlns
+                                  (if (eq? 'l fault) "library" "flags")
+                                  (if (eq? fault 'l) mzlls mzlfs)))])))])
+                  (for-each
+                   (lambda (variant)
+                     (parameterize ([current-launcher-variant variant])
+                       (make-launcher
+                        "MrEd"
+                        'mred-launcher-names
+                        'mred-launcher-libraries
+                        'mred-launcher-flags
+                        mred-program-launcher-path
+                        make-mred-launcher
+                        mred-launcher-up-to-date?)))
+                   (available-mred-variants))
+                  (for-each
+                   (lambda (variant)
+                     (parameterize ([current-launcher-variant variant])
+                       (make-launcher
+                        "MzScheme"
+                        'mzscheme-launcher-names
+                        'mzscheme-launcher-libraries
+                        'mzscheme-launcher-flags
+                        mzscheme-program-launcher-path
+                        make-mzscheme-launcher
+                        mzscheme-launcher-up-to-date?)))
+                   (available-mzscheme-variants))))))
+           ccs-to-compile)))
+      
+      (do-install-part 'general)
+      (do-install-part 'post)
+      
+      (done)
+      
+      (unless (null? errors)
+        (setup-printf "")
+        (show-errors (current-error-port))
+        (when (pause-on-errors)
+          (fprintf (current-error-port)
+                   "INSTALLATION FAILED.~nPress Enter to continue...~n")
+          (read-line))
+        (exit 1))
+      
+      (exit 0))))
diff --git a/collects/setup/setup.lch b/collects/setup/setup.lch
new file mode 100644
index 0000000000..632865e4f0
--- /dev/null
+++ b/collects/setup/setup.lch
@@ -0,0 +1,5 @@
+The context of this file doesn't matter.
+It's existence causes the launcher-maker to
+create an "independent launcher", which
+means that it doesn't depend on the exact
+MzScheme/MrEd executable or DLLs.
diff --git a/collects/setup/setup.ss b/collects/setup/setup.ss
new file mode 100644
index 0000000000..86188f6646
--- /dev/null
+++ b/collects/setup/setup.ss
@@ -0,0 +1,104 @@
+
+;; Because Setup PLT is used to rebuild .zos, we may need to turn off
+;; the use of compiled code or install cm before we do anything. This
+;; startup stub parses the command line and either disables .zos or
+;; installs cm for loading Setup PLT.
+
+;; Note that this file is listed in "info.ss" so that it never gets a
+;; .zo file. Do not `require' this module from anywhere, otherwise it
+;; could get a .zo anyway.
+
+(module setup mzscheme
+
+  (when (file-stream-port? (current-output-port))
+    (file-stream-buffer-mode (current-output-port) 'line))
+
+  (define-values (flags specific-collections archives)
+    ;; Load the command-line parser without using .zos, 
+    ;;  and in its own namespace to avoid poluuting the cm-managed
+    ;;  namespace later
+    (parameterize ([use-compiled-file-paths null]
+		   [current-namespace (make-namespace)])
+      ((dynamic-require '(lib "setup-cmdline.ss" "setup") 'parse-cmdline)
+       (current-command-line-arguments))))
+
+  ;; Checks whether a flag is present:
+  (define (on? flag-name not)
+    (let ([a (assq flag-name flags)])
+      (and a (not (cadr a)))))
+
+  (if (or (on? 'clean values)
+	  (on? 'make-zo not))
+      ;; Don't use .zos, in case they're out of date, and don't load
+      ;;  cm:
+      (when (on? 'clean values)
+	(use-compiled-file-paths null))
+  
+      ;; Load the cm instance to be installed while loading Setup PLT.
+      ;; This has to be dynamic, so we get a chance to turn off compiled
+      ;;  file loading, and so it can be in a separate namespace.
+      (let-values ([(mk trust-zos)
+		    ;; Load cm.ss into its own namespace, so that cm compiles
+		    ;;  itself and its required modules in the right order
+		    ;;  (i.e., when some module requires cm or one of its
+		    ;;  required modules)
+		    ;; Since cm.ss pulls in quite a lot of code itself, we
+		    ;;  would like to load using .zo files. But if we discover
+		    ;;  any date mismatch in the loading process, abort and
+		    ;;  try again without .zo files. If .zo files are newer
+		    ;;  than .ss files but a required file is newer than its
+		    ;;  requring file, we won't notice, but that
+		    ;;  shouldn't happen for a reaonsbaly maintained
+		    ;;  tree, and there's always --clean to turn this
+		    ;;  off. If an .so file is used, we give up using
+		    ;;  compiled files.
+		    (let loop ([skip-zo? (null? (use-compiled-file-paths))])
+		      ((let/ec escape
+			 ;; Create a new namespace, and also install load handlers
+			 ;;  to check file dates, if necessary.
+			 (parameterize ([current-namespace (make-namespace)]
+					[use-compiled-file-paths 
+					 (if skip-zo?
+					     null
+					     (use-compiled-file-paths))]
+					[current-load 
+					 (let ([orig-load (current-load)])
+					   (if skip-zo?
+					       orig-load
+					       (lambda (path modname)
+						 (if (regexp-match #rx#"[.]zo$" (path->bytes path))
+						     ;; It's a .zo:
+						     (orig-load path modname)
+						     ;; Not a .zo! Don't use .zo files at all...
+						     (escape (lambda ()
+							       ;; Try again without .zo
+							       (loop #t)))))))]
+					[current-load-extension 
+					 (if skip-zo?
+					     (current-load-extension)
+					     (lambda (path modname)
+					       (escape (lambda ()
+							 ;; Try again without .zo
+							 (loop #t)))))])
+		           ;; Other things could go wrong, such as a version mismatch.
+		           ;; If something goes wrong, of course, give up on .zo files.
+                           (with-handlers ([exn:fail? (lambda (exn)
+							(if skip-zo?
+							    (raise exn)
+							    (escape
+							     (lambda () (loop #t)))))])
+			     ;; Here's the main dynamic load of "cm.ss":
+			     (let ([mk
+				    (dynamic-require '(lib "cm.ss") 
+						     'make-compilation-manager-load/use-compiled-handler)]
+				   [trust-zos
+				    (dynamic-require '(lib "cm.ss") 'trust-existing-zos)])
+			       ;; Return the two extracted functions:
+			       (lambda () (values mk trust-zos))))))))])
+	(when (on? 'trust-existing-zos values)
+	  (trust-zos #t))
+	(current-load/use-compiled (mk))))
+
+  ;; This has to be dynamic, so we get a chance to turn off
+  ;;  .zo use and turn on the compilation manager.
+  (dynamic-require '(lib "setup-go.ss" "setup") #f))
diff --git a/collects/setup/unpack.ss b/collects/setup/unpack.ss
new file mode 100644
index 0000000000..17ea1b8554
--- /dev/null
+++ b/collects/setup/unpack.ss
@@ -0,0 +1,263 @@
+
+(module unpack mzscheme
+
+  (require (lib "etc.ss")
+	   (lib "inflate.ss")
+	   (lib "file.ss")
+	   (lib "unit.ss")
+	   (lib "base64.ss" "net")
+	   (lib "getinfo.ss" "setup"))
+
+  ;; Returns a port and a kill thunk
+  (define (port64gz->port p64gz)
+    ;; Inflate in a thread so the whole input isn't read at once
+    (let-values ([(base64-out base64-in) (make-pipe 4096)]
+		 [(guz-out guz-in) (make-pipe 4096)])
+      (let ([64t
+	     (thread (lambda () 
+		       (dynamic-wind
+			   void
+			   (lambda ()
+			     (base64-decode-stream p64gz base64-in))
+			   (lambda ()
+			     (close-output-port base64-in)))))]
+	    [gzt
+	     (thread (lambda () 
+		       (dynamic-wind 
+			   void
+			   (lambda ()
+			     (gunzip-through-ports base64-out guz-in))
+			   (lambda ()
+			     (close-output-port guz-in)))))])
+	(values guz-out
+		(lambda ()
+		  (kill-thread 64t)
+		  (kill-thread gzt))))))
+
+  (define (pretty-name f)
+    (with-handlers ([void (lambda (x) f)])
+      (let-values ([(base name dir?) (split-path f)])
+	(format "~a in ~a" (path->string name) (if (path? base)
+						   (path->string base)
+						   base)))))
+
+  (define (unmztar p filter plthome print-status)
+    (define bufsize 4096)
+    (define buffer (make-bytes bufsize))
+    (let loop ()
+      (let ([kind (read p)])
+	(unless (eof-object? kind)
+	  (case kind
+	    [(dir) (let ([s (let ([v (read p)])
+			      (if (null? v)
+				  'same
+				  (apply build-path v)))])
+		     (unless (or (eq? s 'same) (relative-path? s))
+		       (error "expected a directory name relative path string, got" s))
+		     (when (or (eq? s 'same) (filter 'dir s plthome))
+		       (let ([d (build-path plthome s)])
+			 (unless (directory-exists? d)
+			   (print-status
+			    (format "  making directory ~a" (pretty-name d)))
+			   (make-directory* d)))))]
+	    [(file file-replace) 
+	     (let ([s (apply build-path (read p))])
+	       (unless (relative-path? s)
+		 (error "expected a file name relative path string, got" s))
+	       (let ([len (read p)])
+		 (unless (and (number? len) (integer? len))
+		   (error "expected a file name size, got" len))
+		 (let* ([write? (filter kind s plthome)]
+			[path (build-path plthome s)])
+		   (let ([out (and write?
+				   (if (file-exists? path)
+				       (if (eq? kind 'file)
+					   #f
+					   (open-output-file path 'truncate))
+				       (open-output-file path)))])
+		     (when (and write? (not out))
+		       (print-status (format "  skipping ~a; already exists" (pretty-name path))))
+		     (when out
+		       (print-status (format "  unpacking ~a" (pretty-name path))))
+		     ;; Find starting *
+		     (let loop ()
+		       (let ([c (read-char p)])
+			 (cond
+			  [(char=? c #\*) (void)] ; found it
+			  [(char-whitespace? c) (loop)]
+			  [(eof-object? c) (void)] ; signal the error below
+			  [else (error 
+				 (format
+				  "unexpected character setting up ~a, looking for *"
+				  path)
+				 c)])))
+		     ;; Copy file data
+                     (let loop ([n len])
+                       (unless (zero? n)
+                         (let ([l (read-bytes! buffer p 0 (min n bufsize))])
+                           (when (eof-object? l)
+                             (error (format
+                                     "unexpected end-of-file while ~a ~a (at ~a of ~a)"
+                                     (if out "unpacking" "skipping")
+                                     path
+                                     (- len n -1) len)))
+                           (when out
+                             (write-bytes buffer out 0 l))
+                           (loop (- n l)))))
+		     (when out
+		       (close-output-port out))))))]
+	    [else (error "unknown file tag" kind)])
+	  (loop)))))
+
+  (define (call-info info flag mk-default test)
+    (if info
+	(let ([v (info flag mk-default)])
+	  (test v)
+	  v)
+	(mk-default)))
+
+  (define unpack 
+    (opt-lambda (archive [plthome (current-directory)] [print-status (lambda (x) (printf "~a~n" x))]
+			 [get-target-directory (lambda () (current-directory))] [force? #f]
+			 [get-target-plt-directory (lambda (preferred plthome options) preferred)])
+      (let*-values ([(p64gz) (open-input-file archive)]
+		    [(p kill) (port64gz->port p64gz)])
+	(dynamic-wind
+	    void
+	    (lambda ()
+	      (unless (and (eq? #\P (read-char p))
+			   (eq? #\L (read-char p))
+			   (eq? #\T (read-char p)))
+		(error "not an unpackable distribution archive"))
+	      (let* ([n (make-namespace)]
+		     [info (let ([orig (current-namespace)])
+			     (parameterize ([current-namespace n])
+			       (namespace-require '(lib "unit.ss"))
+			       (eval (read p))))])
+		(unless (and (procedure? info)
+			     (procedure-arity-includes? info 2))
+		  (error "expected a procedure of arity 2, got" info))
+		(let ([name (call-info info 'name (lambda () #f)
+				       (lambda (n) 
+					 (unless (string? n)
+					   (if n
+					       (error "couldn't find the package name")
+					       (error "expected a string")))))]
+		      [unpacker (call-info info 'unpacker (lambda () #f)
+					   (lambda (n) 
+					     (unless (eq? n 'mzscheme)
+					       (error "unpacker isn't mzscheme:" n))))]
+		      [target-dir (let ([rel? (call-info info 'plt-relative? (lambda () #f) values)]
+					[not-user-rel? (call-info info 'plt-home-relative? (lambda () #f) values)])
+				    (if rel?
+					(if (and not-user-rel? 
+						 ;; Check for void because old unpacker didn't use
+						 ;;  the failure thunk.
+						 (not (void? not-user-rel?)))
+					    (get-target-plt-directory plthome plthome (list plthome))
+					    (let ([addons (build-path (find-system-path 'addon-dir)
+								      (version))])
+					      (get-target-plt-directory
+					       addons
+					       plthome
+					       (list addons plthome))))
+					(get-target-directory)))])
+		  
+		  ;; Stop if no target directory:
+		  (if target-dir
+
+		      ;; Check declared dependencies (none means v103)
+		      (begin
+			(call-info info 'requires (lambda () null)
+				   (lambda (l) 
+				     (define (bad)
+				       (error "`requires' info is corrupt:" l))
+				     (when (void? l)
+				       (if force?
+					   (print-status "warning: archive is for an older version of PLT Scheme")
+					   (error "cannot install; archive is for an older version of PLT Scheme")))
+				     (unless (or (list? l) 
+						 (and force? (void? l)))
+				       (bad))
+				     ;; Check each dependency:
+				     (when (list? l)
+				       (for-each
+					(lambda (d)
+					  (unless (and (list? d) (= 2 (length d)))
+					    (bad))
+					  (let ([coll-path (car d)]
+						[version (cadr d)])
+					    (unless (and (pair? coll-path)
+							 (list? coll-path)
+							 (andmap string? coll-path)
+							 (list? version)
+							 (andmap number? version))
+					      (bad))
+					    (with-handlers ([exn:fail:filesystem?
+							     (lambda (x)
+							       (if force?
+								   (print-status "warning: missing required collection ~s" coll-path)
+								   (error "cannot install; missing required collection" coll-path)))])
+					      (apply collection-path coll-path))
+					    (let ([inst-version 
+						   (with-handlers ([void (lambda (x) 
+									   (if (exn:break? x)
+									       (raise x)
+									       null))])
+						     (let ([info (get-info coll-path)])
+						       (info 'version (lambda () null))))])
+					      (let loop ([v version][iv inst-version])
+						(unless (null? v)
+						  (when (or (null? iv)
+							    (not (= (car v) (car iv))))
+						    (let ([msg (format "version ~a of collection ~s is required, but version ~a is installed"
+								       version coll-path 
+								       (if (null? inst-version)
+									   '<unknown>
+									   inst-version))])
+						      (if force?
+							  (print-status "warning: ~a" msg)
+							  (error (format "cannot install; ~a" msg)))))
+						  (loop (cdr v) (cdr iv)))))))
+					l))))
+
+			;; Check for conflicts:
+			(call-info info 'conflicts (lambda () null)
+				   (lambda (l) 
+				     (define (bad)
+				       (error "`conflicts' info is corrupt:" l))
+				     (unless (or (list? l)
+						 (and force? (void? l)))
+				       (bad))
+				     (when (list? l)
+				       (for-each
+					(lambda (coll-path)
+					  (unless (and (pair? coll-path)
+						       (list? coll-path)
+						       (andmap string? coll-path))
+					    (bad))
+					  (when (with-handlers ([exn:fail? (lambda (x) #f)])
+						  (apply collection-path coll-path))
+					    (error "cannot install; conflict with installed collection"
+						   coll-path)))
+					l))))
+
+			(unless (and name unpacker)
+			  (error "bad name or unpacker"))
+			(print-status
+			 (format "Unpacking ~a from ~a" name archive))
+			(let ([u (eval (read p) n)])
+			  (unless (eval `(unit? ,u) n)
+			    (error "expected a unit, got" u))
+			  (make-directory* target-dir)
+			  (let ([unmztar (lambda (filter)
+					   (unmztar p filter target-dir print-status))])
+			    (eval `(invoke-unit ,u ,target-dir ,unmztar) n))))
+
+		      ;; Cancelled: no collections
+		      null))))
+	    (lambda ()
+	      (kill)
+	      (close-input-port p64gz))))))
+
+  (provide unpack))
diff --git a/collects/setup/winstall.ss b/collects/setup/winstall.ss
new file mode 100644
index 0000000000..92f62003b3
--- /dev/null
+++ b/collects/setup/winstall.ss
@@ -0,0 +1,9 @@
+;; sets directories for Windows installation
+
+(let ([plthome (build-path 
+		(current-load-relative-directory) 
+		'up 'up)])
+  (putenv "PLTHOME" plthome)
+  (current-library-collection-paths 
+   (list (build-path plthome "collects"))))
+
diff --git a/collects/setup/winvers-change.ss b/collects/setup/winvers-change.ss
new file mode 100644
index 0000000000..199f3927c6
--- /dev/null
+++ b/collects/setup/winvers-change.ss
@@ -0,0 +1,106 @@
+;; This thing will crawl over a given tree and/or files (given on the
+;; command-line, defaults to the current directory) , and looks for "xxxxxxx"
+;; things to replace by the version number, which should be done on a Windows
+;; binary tree before packing a distribution.  It will rename files with
+;; "xxxxxxx" in their name by a "NNN_NNN" version number, and will also do this
+;; rewrite in all files.  (Actually looking for a few known string templates,
+;; to be safe.)  Note that this is done *in-place*, so it will not work from a
+;; running MzScheme.exe on Windows -- "winvers.ss" uses a trick of making a
+;; copy of the binary and restarting that copy for the actual change.
+
+(module winvers-change mzscheme
+
+  (define verbose? #t)
+  (define binary-extensions '(#"exe" #"dll" #"lib" #"so" #"def"
+                              ;; #"obj" #"o"
+                              ))
+  (define xxxs #"xxxxxxx")
+  (define xxxs-re
+    (bytes-append #"(?:lib(?:mzsch|mzgc|mred)(?:|3m)|"
+                  #"[Pp][Ll][Tt][Gg][Dd][Ii]_|"
+                  #"[Uu][Nn][Ii][Pp][Ll][Tt]_|"
+                  #"(?:[Ll][Ii][Bb]|[Ss][Ss][Ll])[Ee][Aa][Yy]32)(" xxxs #")"))
+  (define renaming
+    (byte-regexp (bytes-append #"^" xxxs-re #"[.](?:dll|lib)$")))
+  (define substitutions
+    (map (lambda (s) (regexp-replace #rx#"~a" s xxxs-re))
+         ;; pdb not needed, but this way we can expect no
+         ;; `xxxxxxx's when we finish.
+         '(#"~a[.](?:dll|lib|pdb)\0"
+           #"~a_NULL_THUNK_DATA\0"
+           #"__IMPORT_DESCRIPTOR_~a\0"
+           #"__head_~a_lib\0"
+           #"__~a_lib_iname\0")))
+
+  (require (lib "filename-version.ss" "dynext"))
+  (define version-bytes (string->bytes/utf-8 filename-version-part))
+
+  (define bytes-downcase
+    (let* ([a* (char->integer #\A)]
+           [z* (char->integer #\Z)]
+           [d* (- (char->integer #\a) a*)])
+      (define (byte-downcase b) (if (<= a* b z*) (+ b d*) b))
+      (lambda (bstr)
+        (list->bytes (map byte-downcase (bytes->list bstr))))))
+
+  (define (binary-file? filename)
+    (cond
+     [(regexp-match #rx#"[.]([^.]+)$" filename) =>
+      (lambda (m)
+        (member (bytes-downcase (cadr m)) binary-extensions))]
+     [else #f]))
+
+  (define (do-file file)
+    (define (path) (bytes->path file))
+    (when (binary-file? file)
+      (let ([dfile (bytes-downcase file)])
+        (cond [(regexp-match-positions renaming dfile) =>
+               (lambda (m)
+                 (let ([new (bytes-append (subbytes dfile 0 (caadr m))
+                                          version-bytes
+                                          (subbytes dfile (cdadr m)))])
+                   (when verbose?
+                     (printf "Renaming: ~a/~a -> ~a\n"
+                             (current-directory) file new))
+                   (rename-file-or-directory (path) (bytes->path new))
+                   (set! file new)))]
+              [(regexp-match-positions xxxs dfile)
+               (fprintf (current-error-port) "Warning: ~a/~a was not renamed!\n"
+                        (current-directory) file)]))
+      (let-values ([(i o)    (open-input-output-file (path) 'update)]
+                   [(print?) verbose?])
+        (for-each (lambda (subst)
+                    (file-position i 0)
+                    (let loop ([pos 0])
+                      (cond [(regexp-match-positions subst i) =>
+                             (lambda (m)
+                               (when print?
+                                 (printf "Changing: ~a/~a\n"
+                                         (current-directory) file)
+                                 (set! print? #f))
+                               (file-position o (+ pos (caadr m)))
+                               (display version-bytes o)
+                               (flush-output o)
+                               (file-position i (+ pos (cdar m)))
+                               (loop (+ pos (cdar m))))])))
+                  substitutions)
+        (file-position i 0)
+        (when (regexp-match-positions xxxs i)
+          (fprintf (current-error-port) "Warning: ~a/~a still has \"~a\"!\n"
+                   (current-directory) file xxxs))
+        (close-input-port i)
+        (close-output-port o))))
+
+  (let loop ([files (if (zero? (vector-length (current-command-line-arguments)))
+                      '(#".")
+                      (map string->bytes/utf-8
+                           (vector->list (current-command-line-arguments))))])
+    (when (pair? files)
+      (let ([path (bytes->path (car files))])
+        (cond [(file-exists? path) (do-file (car files))]
+              [(directory-exists? path)
+               (parameterize ([current-directory path])
+                 (loop (map path->bytes (directory-list))))]))
+      (loop (cdr files))))
+
+)
diff --git a/collects/setup/winvers.ss b/collects/setup/winvers.ss
new file mode 100644
index 0000000000..152adcb492
--- /dev/null
+++ b/collects/setup/winvers.ss
@@ -0,0 +1,50 @@
+;; This is a wrapper around `winvers-change.ss' to patch binary files with the
+;; current version number.
+(module winvers mzscheme
+  (require (lib "file.ss")
+           "plthome.ss")
+
+  (define (make-copy)
+    (let ([tmpdir (find-system-path 'temp-dir)])
+      (let ([vers (build-path tmpdir "setvers")])
+	(unless (directory-exists? vers)
+	   (make-directory vers))
+        (for-each
+         (lambda (p)
+           (let ([dest (build-path vers p)])
+             (when (file-exists? dest)
+               (delete-file dest))
+             (copy-file (build-path plthome p) dest)))
+         '("mzscheme.exe" "libmzgcxxxxxxx.dll" "libmzschxxxxxxx.dll"))
+        (build-path vers "mzscheme.exe"))))
+
+  (define (patch-files)
+    (parameterize ((current-command-line-arguments
+                    (vector (path->string plthome))))
+      (dynamic-require `(lib "winvers-change.ss" "setup") #f)))
+
+  (let ([argv (current-command-line-arguments)])
+    (cond
+      [(equal? argv #())
+       (let ([exe (make-copy)])
+         (putenv "PLTHOME" (path->string plthome))
+         (printf "re-launching first time...~n")
+         (subprocess
+          (current-output-port) (current-input-port) (current-error-port)
+          exe "-mvqL-" "winvers.ss" "setup" "patch"))]
+      [(equal? argv #("patch"))
+       (sleep 1) ; time for other process to end
+       (patch-files)
+       (printf "re-launching last time...~n")
+       (subprocess
+        (current-output-port) (current-input-port) (current-error-port)
+        (build-path plthome "mzscheme.exe")
+        "-mvqL-" "winvers.ss" "setup" "finish")]
+      [(equal? argv #("finish"))
+       (sleep 1) ; time for other process to end
+       (delete-directory/files
+        (build-path (find-system-path 'temp-dir) "setvers"))
+       (printf "done!~n")]
+      [else
+       (error 'winvers "unknown command line: ~e" argv)])))
+
diff --git a/collects/sgl/doc.txt b/collects/sgl/doc.txt
new file mode 100644
index 0000000000..e7188800f3
--- /dev/null
+++ b/collects/sgl/doc.txt
@@ -0,0 +1,895 @@
+_GL_/_OpenGL_ bindings for PLT Scheme
+
+Sgl provides access to the system's GL library, version 1.5, and GLU library,
+version 1.3.  The GL API and hence the sgl library do not address system level
+concerns, such as the attachment of GL rendering contexts to displays.  The
+sgl library should work with any PLT Scheme extension that provides GL with
+access to the system (such as a binding for glx).  DrScheme and mred
+automatically attach a GL rendering context to each canvas% object on (at
+least) Windows, Linux and OS X systems.  Refer to the gears.ss example
+(${PLTHOME}/collects/sgl/examples/gears.ss) and the with-gl-context method on
+canvas% objects for more information on using the built-in GL rendering
+context support.
+
+Sgl has two layers, gl.ss and sgl.ss.  The gl.ss library provides access to
+the C-language-style GL API, whereas the sgl.ss library provides a more
+Scheme-like interface.  The gl.ss library provides a binding for each #defined
+constant and for most functions in GL 1.5 and GLU 1.3.  The functions perform
+comparable checking to their C-language counterparts; they check the types of
+their arguments, but do not check the length of array arguments.  The sgl.ss
+library provides wrappers around many of the functions in the gl.ss library to
+present a more Scheme-friendly interface, including function names that follow
+Scheme conventions, and checked, symbolic enumeration arguments, and
+array-length checks.
+
+Safety:
+GL programming is inherently unsafe, even when using only the sgl.ss library.
+Although sgl.ss checks the arguments to each function call, violation of
+higher-level assumptions of the system's GL library can cause it to crash,
+bringing the entire Scheme system down.  For example, sending a large number
+of vertices in a single glBegin causes at least some GL implementations to
+crash.
+
+_gl.ss_
+
+Use the gl.ss module by adding (require (lib "gl.ss" "sgl")) to your program.
+The gl.ss module provides a direct interface to the system's GL library
+closely following the conventions of the C-language GL API.  It provides a
+binding for each #defined constant (these start with GL_) and for the
+functions in the GL 1.5 and GLU 1.3 specifications, except for the following.  
+Vertex arrays           (GL 1.5, Section 2.8)
+Buffer objects          (GL 1.5, Section 2.9)
+glGetPointerv           (GL 1.5, Section 6.1.11)
+Buffer object queries   (GL 1.5, Section 6.1.13)
+Polygon tessalation     (GLU 1.3, Section 5)
+gluQuadricCallback      (GLU 1.3, Section 6.2)
+NURBS                   (GLU 1.3, Section 7)
+
+If one of the provided functions is not present on your system (e.g. if your
+system supports GL 1.3), the function will raise a run-time exception when
+invoked.
+
+Types:
+The functions provided by gl.ss perform comparable checking to their
+C-language counterparts; they check the types of their arguments, but do not
+check the length of array arguments.  The following chart details what Scheme
+values can be passed in for each primitive GL type.
+GLtype                          Scheme value
+------------------------------------------------------------------------------
+GLbyte, GLshort, GLint          exact integer in the proper range
+GLubyte, GLushort, GLuint       non-negative exact integer in the proper range
+GLsizei, GLenum, GLbitfield     non-negative exact integer in the proper range
+GLfloat, GLdouble               real number
+GLclampf, GLclampd              real number
+GLboolean                       Any value, interpreted such that
+                                 #f is GL_FALSE and anything else is GL_TRUE
+                                 (This means that you should not usually
+                                 GL_FALSE or GL_TRUE as arguments, since they
+                                 are bound to integers, both will end up being
+                                 converted to GL_TRUE.)
+				    
+GL functions that take vector arguments accept cvector values.  Section 2.4 of
+the PLT Foreign Interface Manual describes the functions for creating and
+manipulating cvectors (make-cvector, cvector, cvector?, cvector-length,
+cvector-type, cvector-ref, cvector-set!, cvector->list, and list->cvector).
+The type of the cvector is checked: for example, glVertex3fv expects a vector
+of GLfloats, and will only accept a cvector containing GLfloats.  The
+gl-vector.ss module provides cvector operations that account for the GL type
+information.  Functions that accept arrays of type void* will accept any
+cvector, you must ensure that you supply the proper kind of vector, as in the
+C-language GL API.
+
+The following functions have interfaces that differ from their C-language
+counterparts.  The function index at the end of this document refers back
+to these notes for each function.
+
+1: glPixelMap
+   glDeleteTextures
+   glDeleteQueries
+These functions do not take a size argument, it is derived from the length of
+the argument vector.
+
+2: glGenTextures
+   glGenQueries
+These functions do not take vector arguments.  Instead, they allocate a vector
+of the requested size and return it.
+
+3: glAreTexturesResident
+This function takes in a single uint vector, textures, and returns 2 values:
+the specified boolean and a boolean vector residences.
+
+4: glGetBooleanv
+   glGetIntegerv
+   glGetFloatv
+   glGetDoublev
+   glGetLight
+   glGetMaterial
+   glGetTexEnv
+   glGetTexGen
+   glGetTexParameter
+   glGetTexLevelParameter
+   glGetPixelMap
+   glGetMap
+   glGetBufferParameter
+   glGetConvolutionParameter
+   glGetHistogramParameter
+   glGetMinmaxParameter
+   glGetQuery
+   glGetQueryObject
+Instead of taking a vector argument, these function take an integer argument
+that specifies the size of the vector which is returned.
+
+5: glGetClipPlane
+This function does not take a vector argument and returns a double vector of
+length 4.
+
+6: glGetString
+   gluCheckExtension
+   gluErrorString
+   gluGetString
+These functions deal with strings instead of ubyte vectors.
+
+7: gluProject
+   gluUnProject
+   gluUnProject4
+Instead of taking pointers to doubles for return values, these function
+directly return double vectors.
+
+8: glSelectBuffer
+   glFeedbackBuffer
+These functions do not take vectors, instead they return a
+selection-buffer-object or feedback-buffer-object.  The gl.ss library provides
+the functions select-buffer->gl-uint-vector and
+feedback-buffer->gl-float-vector to copy the contents of the buffer into a
+vector.  Because the GL library writes to the buffer-object on GL function
+calls after glSelectBuffer or glFeedbackBuffer has returned, if the buffer is
+garbage collected before GL is finished writing to it, the entire Scheme
+system can crash.  The process-selection function in sgl helps interpret the
+results of glSelectBuffer in a Scheme-friendly format.
+
+
+Notational Example:
+(require (lib "gl.ss" "sgl")
+         (lib "gl-vectors.ss" "sgl"))
+(glBegin GL_TRIANGLES)
+(glVertex3i 1 2 3)
+(glVertex4fv (gl-float-vector 1 2 3 4))
+(glEnd)
+
+See alpha.ss in the examples subdirectory of the sgl collection
+(${PLTHOME}/collects/sgl/examples/alpha.ss) for a working example.  Try
+choosing the sk.jpg file in the icons when this example asks you for a file.
+You may have to press "t" a few times if the spinning cube is blank.
+
+
+_gl-vectors.ss_
+
+The gl-vectors module supports GL programming with cvectors.  In this
+document, and in the error messages, a gl-vector is just a cvector, from (lib
+"foreign.ss"), and a gl-<type>-vector is a cvector with an appropriate type.
+Use this module by adding (require (lib "gl-vectors.ss" "sgl")) to your
+program.  I suggest using this module instead of using the cvector function
+directly because these functions are specialized to handling the GL typedefs
+correctly.
+
+The gl-vectors.ss module provides the following functions, which are synonyms
+for the corresponding cvector functions:
+gl-vector->vector
+gl-vector->list
+gl-vector-length
+gl-vector-ref
+gl-vector-set!
+gl-vector?
+
+Furthermore, for each <type> in byte, ubyte, short, ushort, int, uint, float,
+double, boolean gl-vectors.ss provides the following functions:
+gl-<type>-vector?: any -> boolean
+  True when the argument is a gl-<type>-vector
+make-gl-<type>-vector: non-negative-integer -> gl-<type>-vector
+  Makes a gl-<type>-vector of the given length
+gl-<type>-vector: X ... -> gl-<type>-vector
+  Makes a gl-<type>-vector from the given arguments
+vector->gl-<type>-vector: vector -> gl-<type>-vector
+  Converts a Scheme vector into the specified gl-<type>-vector
+list->gl-<type>-vector: vector -> gl-<type>-vector
+  Converts a Scheme list into the specified gl-<type>-vector
+gl-<type>-vector+: gl-vector ... -> gl-type-vector
+  Computes the element-by-element sum of the given gl-vectors and places the
+  result into a gl-<type>-vector
+gl-<type>-vector-: gl-vector ... -> gl-type-vector
+  Computes the element-by-element difference of the given gl-vectors and
+  places the result into a gl-<type>-vector
+gl-<type>-vector*: real-number gl-vector -> gl-type-vector
+  Multiplies each element of the given gl-vector by the given number and
+  places the result into a gl-<type>-vector
+
+Finally, the following functions are also provided.
+gl-vector-norm: gl-vector -> real-number
+  Returns the square root of the sum of the squares of the elements of the
+  given gl-vector 
+
+_sgl.ss_
+
+Use the sgl.ss module by adding (require (lib "sgl.ss" "sgl)) to your program.
+To prefix the function names with "gl-" use the form (require (prefix gl- (lib
+"sgl.ss" "sgl"))) instead.  The sgl.ss module provides a more Scheme-like
+interface to the GL functions in gl.ss.
+
+Functions in sgl.ss take symbols instead of integers for GLenum arguments.
+Each function checks that the given symbol is an acceptable argument and
+raises an exception if it is not.  Given the name of a C-language #define
+constant, determine the corresponding symbolic argument by removing the
+leading "GL_", converting the letters to lower-case and replacing all
+underscores with dashes.  For example, GL_TRIANGLES becomes 'triangles and
+GL_TRIANGLE_STRIP becomes 'triangle-strip.  Additionally, the functions check
+the length of any array arguments to ensure that GL does not attempt to write
+or read after the array.
+
+The functions in sgl.ss use Scheme style names instead of C style names.  To
+convert a C GL name to a Scheme GL name, drop the leading "gl" (use the
+require form to choose whatever prefix you desire, as above), separate
+adjacent words with hyphens, and convert to all lower case.  Functions that
+have several variants to accommodate different numbers and types of arguments
+are collapsed into one or two functions in sgl.ss.  For example, sgl.ss
+provides two vertex functions, vertex and vertex-v.  The vertex function
+accepts 2, 3 or 4 numerical arguments, and the vertex-v function accepts
+gl-vectors of length 2, 3 or 4.  The C language GL interface has 24 vertex
+functions glVertex3i, glVertex4fv, etc.
+
+
+The sgl.ss module is not yet complete and many functions from the gl module do
+not yet have counterparts in the sgl.ss module.  See the list of functions
+below.
+
+Notational Example:
+(require (prefix gl- (lib "sgl.ss" "sgl"))
+         (lib "gl-vectors.ss" "sgl"))
+(gl-begin 'triangles)
+(gl-vertex 1 2 3)
+(gl-vertex-v (gl-float-vector 1 2 3 4))
+(gl-end)
+
+See gears.ss in the examples subdirectory of the sgl collection
+(${PLTHOME}/collects/sgl/examples/gears.ss) for a working example.  Also see
+the checkers game in ${PLTHOME}/collects/games/checkers/checkers.ss.
+
+sgl provides the following utility functions that have no OpenGL counterpart:
+
+process-selection: gl-uint-vector int -> (listof selection-record)
+where a selection-record is defined by this exported struct: 
+(define-struct selection-record (min-z max-z stack)).
+process-selection parses the contents of a gl-vector from the format used by
+glSelectBuffer.  The second argument should be the number of hits as returned
+by glRenderMode.
+
+get-gl-version-number: -> int
+Returns the version number as an integer: 10, 11, 12, 13, 14, 15, or 20.
+
+get-glu-version-number: -> int
+Returns the version number as an integer: 10, 11, 12, or 13.
+
+Function indexes:
+
+
+----------------------------  sgl.ss: ----------------------------
+(struct selection-record (min-z max-z stack))
+accum
+active-texture
+alpha-func
+begin
+begin-query
+blend-color
+blend-equation
+blend-func
+blend-func-separate
+call-list
+check-extension
+clear
+clear-accum
+clear-color
+clear-depth
+clear-index
+clear-stencil
+clip-plane
+color
+color-mask
+color-material
+color-v
+copy-pixels
+cull-face
+cylinder
+delete-lists
+delete-queries
+depth-func
+depth-mask
+depth-range
+disable
+disk
+edge-flag
+enable
+end
+end-list
+end-query
+eval-coord
+eval-coord-v
+eval-mesh
+eval-point
+feedback-buffer->gl-float-vector
+finish
+flush
+front-face
+frustum
+gen-lists
+gen-queries
+get-error
+get-string
+get-gl-version-number
+get-glu-version-number
+hint
+index
+index-mask
+index-v
+init-names
+is-buffer
+is-enabled
+is-list
+is-query
+light
+light-model
+light-model-v
+light-v
+line-stipple
+line-width
+list-base
+load-identity
+load-matrix
+load-name
+load-transpose-matrix
+look-at
+map-grid
+material
+material-v
+matrix-mode
+mult-matrix
+mult-transpose-matrix
+multi-tex-coord
+multi-tex-coord-v
+new-list
+new-quadric
+normal
+normal-v
+ortho
+ortho-2d
+partial-disk
+pass-through
+perspective
+pick-matrix
+pixel-store
+point-parameter
+point-parameter-v
+point-size
+polygon-mode
+polygon-offset
+pop-attrib
+pop-client-attrib
+pop-matrix
+pop-name
+process-selection
+project
+push-matrix
+push-name
+quadric-draw-style
+quadric-normals
+quadric-orientation
+quadric-texture
+raster-pos
+raster-pos-v
+rect
+rect-v
+render-mode
+rotate
+sample-coverage
+scale
+scissor
+secondary-color
+secondary-color-v
+select-buffer->gl-uint-vector
+shade-model
+sphere
+stencil-func
+stencil-mask
+stencil-op
+tex-coord
+tex-coord-v
+tex-gen
+tex-gen-v
+translate
+u-get-string
+un-project
+un-project4
+vertex
+vertex-v
+viewport
+window-pos
+window-pos-v
+
+-----------------------------  gl.ss:  -----------------------------
+glAccum
+glActiveTexture
+glAlphaFunc
+glAreTexturesResident		*3
+glBegin
+glBeginQuery
+glBindTexture
+glBitmap
+glBlendColor
+glBlendEquation
+glBlendFunc
+glBlendFuncSeparate
+glCallList
+glCallLists
+glClear
+glClearAccum
+glClearColor
+glClearDepth
+glClearIndex
+glClearStencil
+glClipPlane
+glColor3b
+glColor3bv
+glColor3d
+glColor3dv
+glColor3f
+glColor3fv
+glColor3i
+glColor3iv
+glColor3s
+glColor3sv
+glColor3ub
+glColor3ubv
+glColor3ui
+glColor3uiv
+glColor3us
+glColor3usv
+glColor4b
+glColor4bv
+glColor4d
+glColor4dv
+glColor4f
+glColor4fv
+glColor4i
+glColor4iv
+glColor4s
+glColor4sv
+glColor4ub
+glColor4ubv
+glColor4ui
+glColor4uiv
+glColor4us
+glColor4usv
+glColorMask
+glColorMaterial
+glColorSubTable
+glColorTable
+glColorTableParameterfv
+glColorTableParameteriv
+glCompressedTexImage1D
+glCompressedTexImage2D
+glCompressedTexImage3D
+glCompressedTexSubImage1D
+glCompressedTexSubImage2D
+glCompressedTexSubImage3D
+glConvolutionFilter1D
+glConvolutionFilter2D
+glConvolutionParameterf
+glConvolutionParameterfv
+glConvolutionParameteri
+glConvolutionParameteriv
+glCopyColorSubTable
+glCopyColorTable
+glCopyConvolutionFilter1D
+glCopyConvolutionFilter2D
+glCopyPixels
+glCopyTexImage1D
+glCopyTexImage2D
+glCopyTexSubImage1D
+glCopyTexSubImage2D
+glCopyTexSubImage3D
+glCullFace
+glDeleteLists
+glDeleteQueries			*1
+glDeleteTextures		*1
+glDepthFunc
+glDepthMask
+glDepthRange
+glDisable
+glDrawBuffer
+glDrawPixels
+glEdgeFlag
+glEdgeFlagv
+glEnable
+glEnd
+glEndList
+glEndQuery
+glEvalCoord1d
+glEvalCoord1dv
+glEvalCoord1f
+glEvalCoord1fv
+glEvalCoord2d
+glEvalCoord2dv
+glEvalCoord2f
+glEvalCoord2fv
+glEvalMesh1
+glEvalMesh2
+glEvalPoint1
+glEvalPoint2
+glFeedbackBuffer		*8
+glFinish
+glFlush
+glFogCoordd
+glFogCoorddv
+glFogCoordf
+glFogCoordfv
+glFogf
+glFogfv
+glFogi
+glFogiv
+glFrontFace
+glFrustum
+glGenLists
+glGenQueries			*2
+glGenTextures			*2
+glGetBooleanv			*4
+glGetBufferParameteriv		*4
+glGetClipPlane			*5
+glGetColorTable
+glGetCompressedTexImage
+glGetConvolutionFilter
+glGetConvolutionParameterfv	*4
+glGetConvolutionParameteriv	*4
+glGetDoublev			*4
+glGetError
+glGetFloatv			*4
+glGetHistogram
+glGetHistogramParameterfv	*4
+glGetHistogramParameteriv	*4
+glGetIntegerv			*4
+glGetLightfv			*5
+glGetLightiv			*5
+glGetMapdv			*4
+glGetMapfv			*4
+glGetMapiv			*4
+glGetMaterialfv			*4
+glGetMaterialiv			*4
+glGetMinmax
+glGetMinmaxParameterfv		*4
+glGetMinmaxParameteriv		*4
+glGetPixelMapfv			*4
+glGetPixelMapuiv		*4
+glGetPixelMapusv		*4
+glGetPolygonStipple
+glGetQueryObjectiv		*4
+glGetQueryObjectuiv		*4
+glGetQueryiv			*4
+glGetSeparableFilter
+glGetString			*6
+glGetTexEnvfv			*4
+glGetTexEnviv			*4
+glGetTexGendv			*4
+glGetTexGenfv			*4
+glGetTexGeniv			*4
+glGetTexImage
+glGetTexLevelParameterfv	*4
+glGetTexLevelParameteriv	*4
+glGetTexParameterfv		*4
+glGetTexParameteriv		*4
+glHint
+glHistogram
+glIndexMask
+glIndexd
+glIndexdv
+glIndexf
+glIndexfv
+glIndexi
+glIndexiv
+glIndexs
+glIndexsv
+glIndexub
+glIndexubv
+glInitNames
+glIsBuffer
+glIsEnabled
+glIsList
+glIsQuery
+glIsTexture
+glLightModelf
+glLightModelfv
+glLightModeli
+glLightModeliv
+glLightf
+glLightfv
+glLighti
+glLightiv
+glLineStipple
+glLineWidth
+glListBase
+glLoadIdentity
+glLoadMatrixd
+glLoadMatrixf
+glLoadName
+glLoadTransposeMatrixd
+glLoadTransposeMatrixf
+glLogicOp
+glMap1d
+glMap1f
+glMap2d
+glMap2f
+glMapGrid1d
+glMapGrid1f
+glMapGrid2d
+glMapGrid2f
+glMaterialf
+glMaterialfv
+glMateriali
+glMaterialiv
+glMatrixMode
+glMinmax
+glMultMatrixd
+glMultMatrixf
+glMultTransposeMatrixd
+glMultTransposeMatrixf
+glMultiTexCoord1d
+glMultiTexCoord1dv
+glMultiTexCoord1f
+glMultiTexCoord1fv
+glMultiTexCoord1i
+glMultiTexCoord1iv
+glMultiTexCoord1s
+glMultiTexCoord1sv
+glMultiTexCoord2d
+glMultiTexCoord2dv
+glMultiTexCoord2f
+glMultiTexCoord2fv
+glMultiTexCoord2i
+glMultiTexCoord2iv
+glMultiTexCoord2s
+glMultiTexCoord2sv
+glMultiTexCoord3d
+glMultiTexCoord3dv
+glMultiTexCoord3f
+glMultiTexCoord3fv
+glMultiTexCoord3i
+glMultiTexCoord3iv
+glMultiTexCoord3s
+glMultiTexCoord3sv
+glMultiTexCoord4d
+glMultiTexCoord4dv
+glMultiTexCoord4f
+glMultiTexCoord4fv
+glMultiTexCoord4i
+glMultiTexCoord4iv
+glMultiTexCoord4s
+glMultiTexCoord4sv
+glNewList
+glNormal3b
+glNormal3bv
+glNormal3d
+glNormal3dv
+glNormal3f
+glNormal3fv
+glNormal3i
+glNormal3iv
+glNormal3s
+glNormal3sv
+glOrtho
+glPassThrough
+glPixelMapfv			*1
+glPixelMapuiv			*1
+glPixelMapusv			*1
+glPixelStoref
+glPixelStorei
+glPixelTransferf
+glPixelTransferi
+glPixelZoom
+glPointParameterf
+glPointParameterfv
+glPointParameteri
+glPointParameteriv
+glPointSize
+glPolygonMode
+glPolygonOffset
+glPolygonStipple
+glPopAttrib
+glPopClientAttrib
+glPopMatrix
+glPopName
+glPushAttrib
+glPushClientAttrib
+glPushMatrix
+glPushName
+glRasterPos2d
+glRasterPos2dv
+glRasterPos2f
+glRasterPos2fv
+glRasterPos2i
+glRasterPos2iv
+glRasterPos2s
+glRasterPos2sv
+glRasterPos3d
+glRasterPos3dv
+glRasterPos3f
+glRasterPos3fv
+glRasterPos3i
+glRasterPos3iv
+glRasterPos3s
+glRasterPos3sv
+glRasterPos4d
+glRasterPos4dv
+glRasterPos4f
+glRasterPos4fv
+glRasterPos4i
+glRasterPos4iv
+glRasterPos4s
+glRasterPos4sv
+glReadBuffer
+glReadPixels
+glRectd
+glRectdv
+glRectf
+glRectfv
+glRecti
+glRectiv
+glRects
+glRectsv
+glRenderMode
+glResetHistogram
+glResetMinmax
+glRotated
+glRotatef
+glSampleCoverage
+glScaled
+glScalef
+glScissor
+glSecondaryColor3b
+glSecondaryColor3bv
+glSecondaryColor3d
+glSecondaryColor3dv
+glSecondaryColor3f
+glSecondaryColor3fv
+glSecondaryColor3i
+glSecondaryColor3iv
+glSecondaryColor3s
+glSecondaryColor3sv
+glSecondaryColor3ub
+glSecondaryColor3ubv
+glSecondaryColor3ui
+glSecondaryColor3uiv
+glSecondaryColor3us
+glSecondaryColor3usv
+glSelectBuffer			*8
+glSeparableFilter2D
+glShadeModel
+glStencilFunc
+glStencilMask
+glStencilOp
+glTexCoord1d
+glTexCoord1dv
+glTexCoord1f
+glTexCoord1fv
+glTexCoord1i
+glTexCoord1iv
+glTexCoord1s
+glTexCoord1sv
+glTexCoord2d
+glTexCoord2dv
+glTexCoord2f
+glTexCoord2fv
+glTexCoord2i
+glTexCoord2iv
+glTexCoord2s
+glTexCoord2sv
+glTexCoord3d
+glTexCoord3dv
+glTexCoord3f
+glTexCoord3fv
+glTexCoord3i
+glTexCoord3iv
+glTexCoord3s
+glTexCoord3sv
+glTexCoord4d
+glTexCoord4dv
+glTexCoord4f
+glTexCoord4fv
+glTexCoord4i
+glTexCoord4iv
+glTexCoord4s
+glTexCoord4sv
+glTexEnvf
+glTexEnvfv
+glTexEnvi
+glTexEnviv
+glTexGend
+glTexGendv
+glTexGenf
+glTexGenfv
+glTexGeni
+glTexGeniv
+glTexImage1D
+glTexImage2D
+glTexImage3D
+glTexParameterf
+glTexParameterfv
+glTexParameteri
+glTexParameteriv
+glTexSubImage1D
+glTexSubImage2D
+glTexSubImage3D
+glTranslated
+glTranslatef
+glVertex2d
+glVertex2dv
+glVertex2f
+glVertex2fv
+glVertex2i
+glVertex2iv
+glVertex2s
+glVertex2sv
+glVertex3d
+glVertex3dv
+glVertex3f
+glVertex3fv
+glVertex3i
+glVertex3iv
+glVertex3s
+glVertex3sv
+glVertex4d
+glVertex4dv
+glVertex4f
+glVertex4fv
+glVertex4i
+glVertex4iv
+glVertex4s
+glVertex4sv
+glViewport
+glWindowPos2d
+glWindowPos2dv
+glWindowPos2f
+glWindowPos2fv
+glWindowPos2i
+glWindowPos2iv
+glWindowPos2s
+glWindowPos2sv
+glWindowPos3d
+glWindowPos3dv
+glWindowPos3f
+glWindowPos3fv
+glWindowPos3i
+glWindowPos3iv
+glWindowPos3s
+glWindowPos3sv
+gluBuild1DMipmapLevels
+gluBuild1DMipmaps
+gluBuild2DMipmapLevels
+gluBuild2DMipmaps
+gluBuild3DMipmapLevels
+gluBuild3DMipmaps
+gluCheckExtension		*6
+gluCylinder
+gluDisk
+gluErrorString			*6
+gluGetString			*6
+gluLookAt
+gluNewQuadric
+gluOrtho2D
+gluPartialDisk
+gluPerspective
+gluPickMatrix
+gluProject			*7
+gluQuadricDrawStyle
+gluQuadricNormals
+gluQuadricOrientation
+gluQuadricTexture
+gluScaleImage
+gluSphere
+gluUnProject			*7
+gluUnProject4			*7
diff --git a/collects/sgl/examples/alpha.ss b/collects/sgl/examples/alpha.ss
new file mode 100644
index 0000000000..907b9792a8
--- /dev/null
+++ b/collects/sgl/examples/alpha.ss
@@ -0,0 +1,153 @@
+;; By Brendan Burns
+(module alpha mzscheme
+  ;; Standard requires
+  (require 
+   (lib "mred.ss" "mred")
+   (lib "gl.ss" "sgl")
+   (lib "gl-vectors.ss" "sgl")
+   "gl-frame.ss")
+  
+  ;; texture
+  ;; This needs to be here and not in gl-init because of some weirdness in the
+  ;; threading on windows causes the window to attempt to be drawn prior to the
+  ; texture being fully loaded.
+  (define *texture* (image->gl-vector (get-file)))
+  
+  ;; Init function
+  (define (my-gl-init)
+    (let ((res *texture*))
+      ;; Same texture, three smoothing styles...
+      (init-textures 3)
+      (unless (gl-load-texture (list-ref res 2) (list-ref res 0) (list-ref res 1)
+                               GL_NEAREST GL_NEAREST 0)
+        (error "Couldn't load texture"))
+      (unless (gl-load-texture (list-ref res 2) (list-ref res 0) (list-ref res 1)
+                               GL_LINEAR GL_LINEAR 1)
+        (error "Couldn't load texture"))
+      (unless (gl-load-texture (list-ref res 2) (list-ref res 0) (list-ref res 1)
+                               GL_LINEAR GL_LINEAR_MIPMAP_NEAREST 2)
+        (error "Couldn't load texture"))
+      
+      ;; Set-up alpha blending 50% transparency
+      (glColor4d 1 1 1 0.5)
+      (glBlendFunc GL_SRC_ALPHA GL_ONE)
+      (glEnable GL_BLEND)
+      
+      ;; Standard Init
+      (glEnable GL_TEXTURE_2D)
+      (glShadeModel GL_SMOOTH)
+      (glClearColor 0.0 0.0 0.0 0.5)
+      (glClearDepth 1)
+      (glEnable GL_DEPTH_TEST)
+      (glDepthFunc GL_LEQUAL)
+      (glHint GL_PERSPECTIVE_CORRECTION_HINT GL_NICEST)
+      
+      ;; default light
+      (glEnable GL_LIGHT0)
+      (glEnable GL_LIGHTING)))
+  
+  ;; Our user interaction variables
+  (define *xrot* 0)
+  (define *yrot* 0)
+  (define *zrot* 0)
+  (define *z* -5)
+  (define *blend* #f)
+  (define *tex* 0)
+  
+  ;; Our main function that does the drawing
+  (define (my-gl-draw)
+    ;; erase the background
+    (glClear (+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT))
+    ;; turn blending on/off
+    (if *blend* (glEnable GL_BLEND) (glDisable GL_BLEND))
+    
+    ;; draw cube.
+    (glLoadIdentity)
+    (glTranslated 0 0 *z*)
+    (glRotated *xrot* 1 0 0)	
+    (glRotated *yrot* 0 1 0)
+    (glRotated *zrot* 0 0 1)
+    (glBindTexture GL_TEXTURE_2D (get-texture *tex*))
+    (glBegin GL_QUADS)
+    ; front
+    (glNormal3d 0 0 1)
+    (glTexCoord2i 0 0)  
+    (glVertex3i -1 -1 1)
+    (glTexCoord2i 1 0)
+    (glVertex3i 1 -1 1)
+    (glTexCoord2i 1 1)
+    (glVertex3i 1 1 1)
+    (glTexCoord2i 0 1)
+    (glVertex3i -1 1 1)
+    ; back
+    (glNormal3d 0 0 -1)
+    (glTexCoord2i 1 0)  
+    (glVertex3i -1 -1 -1)
+    (glTexCoord2i 1 1)
+    (glVertex3i 1 -1 -1)
+    (glTexCoord2i 0 1)
+    (glVertex3i 1 1 -1)
+    (glTexCoord2i 0 0)
+    (glVertex3i -1 1 -1)
+    ; top
+    (glNormal3d 0 1 0)
+    (glTexCoord2i 0 1)  
+    (glVertex3i -1 1 -1)
+    (glTexCoord2i 0 0)
+    (glVertex3i 1 1 -1)
+    (glTexCoord2i 1 0)
+    (glVertex3i 1 1 1)
+    (glTexCoord2i 1 1)
+    (glVertex3i -1 1 1)
+    ; bottom
+    (glNormal3d 0 -1 0)
+    (glTexCoord2i 1 1)  
+    (glVertex3i -1 -1 -1)
+    (glTexCoord2i 0 1)
+    (glVertex3i -1 -1 1)
+    (glTexCoord2i 0 0)
+    (glVertex3i 1 -1 1)
+    (glTexCoord2i 1 0)
+    (glVertex3i 1 -1 -1)
+    ; right
+    (glNormal3d 1 0 0)
+    (glTexCoord2i 1 0)  
+    (glVertex3i 1 -1 -1)
+    (glTexCoord2i 1 1)
+    (glVertex3i 1 -1 1)
+    (glTexCoord2i 0 1)
+    (glVertex3i 1 1 1)
+    (glTexCoord2i 0 0)
+    (glVertex3i 1 1 -1)
+    ;left
+    (glNormal3d -1 0 0)
+    (glTexCoord2i 0 0)  
+    (glVertex3i -1 -1 -1)
+    (glTexCoord2i 1 0)
+    (glVertex3i -1 1 -1)
+    (glTexCoord2i 1 1)
+    (glVertex3i -1 1 1)
+    (glTexCoord2i 0 1)
+    (glVertex3i -1 -1 1)
+    
+    (glEnd)
+    (set! *xrot* (+ *xrot* 0.3))
+    (set! *yrot* (+ *yrot* 0.2))
+    (set! *zrot* (+ *zrot* 0.4))
+    
+    (glFlush))
+  
+  ;; Move forward
+  (add-key-mapping #\i (lambda () (set! *z* (+ *z* 0.3))))
+  ;; Move backward
+  (add-key-mapping #\k (lambda () (set! *z* (- *z* 0.3))))
+  ;; Turn blending on/off
+  (add-key-mapping #\b (lambda () (set! *blend* (not *blend*))))
+  ;; Cycle textures
+  (add-key-mapping #\t (lambda () (set! *tex* (modulo (+ *tex* 1) 3))))
+  
+  ;; Set the init function
+  (set-gl-init-fn my-gl-init)
+  ;; Set the draw function
+  (set-gl-draw-fn my-gl-draw)
+  (gl-run))
diff --git a/collects/sgl/examples/gears.ss b/collects/sgl/examples/gears.ss
new file mode 100644
index 0000000000..c5660d28e9
--- /dev/null
+++ b/collects/sgl/examples/gears.ss
@@ -0,0 +1,366 @@
+;; $Id: gears.ss,v 1.8 2005/01/12 12:49:10 mflatt Exp $
+;;
+;; This is a version of the venerable "gears" demo for PLT Scheme 200 using
+;; Scott Owens' SGL OpenGL bindings.  It was ported from "glxgears.c" 1.3 from
+;; XFree86, which had the following notices:
+;;
+;;     Copyright (C) 1999-2001  Brian Paul   All Rights Reserved.
+;;
+;;     Permission is hereby granted, free of charge, to any person obtaining a
+;;     copy of this software and associated documentation files (the
+;;     "Software"), to deal in the Software without restriction, including
+;;     without limitation the rights to use, copy, modify, merge, publish,
+;;     distribute, sublicense, and/or sell copies of the Software, and to
+;;     permit persons to whom the Software is furnished to do so, subject to
+;;     the following conditions:
+;;
+;;     The above copyright notice and this permission notice shall be included
+;;     in all copies or substantial portions of the Software.
+;;
+;;     XFree86: xc/programs/glxgears/glxgears.c,v 1.3 2001/11/03 17:29:20 dawes
+;;
+;;     This is a port of the infamous "gears" demo to straight GLX (i.e. no
+;;     GLUT).  Port by Brian Paul 23 March 2001.
+;;
+;; To run, evaluate this file in DrScheme in the "module" language level,
+;; or execute "mred -qu gears.ss" from your OS shell.
+;;
+;; Scheme port by Neil W. Van Dyke <neil@neilvandyke.org>, 23 November 2002.
+;; Originally called glxgears.ss.  Minor modifications since.
+;; See "http://www.neilvandyke.org/opengl-plt/" for more information.
+;;
+;; Updated to newer sgl interface by Scott Owens
+
+
+(module gears mzscheme
+(require (lib "mred.ss" "mred")
+         (lib "class.ss")
+         (lib "math.ss")
+         (prefix gl- (lib "sgl.ss" "sgl"))
+         (lib "gl-vectors.ss" "sgl"))
+         
+         
+(define controls? #t)
+
+(define gears-canvas%
+  (class* canvas% ()
+
+    (inherit refresh with-gl-context swap-gl-buffers get-parent)
+
+    (define rotation 0.0)
+
+    (define view-rotx 20.0)
+    (define view-roty 30.0)
+    (define view-rotz 0.0)
+
+    (define gear1 #f)
+    (define gear2 #f)
+    (define gear3 #f)
+
+    (define step? #f)
+
+    (define/public (run)
+      (set! step? #t)
+      (refresh))
+
+    (define/public (move-left)
+      (set! view-roty (+ view-roty 5.0))
+      (refresh))
+
+    (define/public (move-right)
+      (set! view-roty (- view-roty 5.0))
+      (refresh))
+
+    (define/public (move-up)
+      (set! view-rotx (+ view-rotx 5.0))
+      (refresh))
+
+    (define/public (move-down)
+      (set! view-rotx (- view-rotx 5.0))
+      (refresh))
+
+    (define (build-gear inner-radius    ; radius of hole at center
+                        outer-radius    ; radius at center of teeth
+                        width           ; width of gear
+                        teeth           ; number of teeth
+                        tooth-depth)    ; depth of tooth
+      (let* ((r0             inner-radius)
+             (r1             (- outer-radius (/ tooth-depth 2.0)))
+             (r2             (+ outer-radius (/ tooth-depth 2.0)))
+             (da             (/ (* 2.0 pi) teeth 4.0))
+             (da2            (* da 2))
+             (da3            (* da 3))
+             (half-width     (* width 0.5))
+             (neg-half-width (- half-width)))
+
+        ;; TODO: Generalize away some more redundant program text.
+
+        (gl-shade-model 'flat)
+
+        (gl-normal 0.0 0.0 1.0)
+
+	;; Draw front face.
+        (gl-begin 'quad-strip)
+        (do ((i 0 (+ 1 i))) ((> i teeth))
+          (let* ((angle     (/ (* i 2.0 pi) teeth))
+                 (cos-angle (cos angle))
+                 (sin-angle (sin angle)))
+            (gl-vertex (* r0 cos-angle) (* r0 sin-angle) half-width)
+            (gl-vertex (* r1 cos-angle) (* r1 sin-angle) half-width)
+            (when (< i teeth)
+              (gl-vertex (* r0 cos-angle)
+                            (* r0 sin-angle)
+                            (* half-width))
+              (gl-vertex (* r1 (cos (+ angle da3)))
+                            (* r1 (sin (+ angle da3)))
+                            half-width))))
+        (gl-end)
+
+        ;; Draw front sides of teeth.
+        (gl-begin 'quads)
+        (do ((i 0 (+ 1 i))) ((= i teeth))
+          (let ((angle (/ (* i 2.0 pi) teeth)))
+            (gl-vertex (* r1 (cos angle))
+                       (* r1 (sin angle))
+                       half-width)
+            (gl-vertex (* r2 (cos (+ angle da)))
+                       (* r2 (sin (+ angle da)))
+                       half-width)
+            (gl-vertex (* r2 (cos (+ angle da2)))
+                       (* r2 (sin (+ angle da2)))
+                       half-width)
+            (gl-vertex (* r1 (cos (+ angle da3)))
+                       (* r1 (sin (+ angle da3)))
+                       half-width)))
+        (gl-end)
+
+        (gl-normal 0.0 0.0 -1.0)
+
+        ;; Draw back face.
+        (gl-begin 'quad-strip)
+        (do ((i 0 (+ 1 i))) ((> i teeth))
+          (let* ((angle     (/ (* i 2.0 pi) teeth))
+                 (cos-angle (cos angle))
+                 (sin-angle (sin angle)))
+            (gl-vertex (* r1 cos-angle) (* r1 sin-angle) neg-half-width)
+            (gl-vertex (* r0 cos-angle) (* r0 sin-angle) neg-half-width)
+            (when (< i teeth)
+              (gl-vertex (* r1 (cos (+ angle da3)))
+                         (* r1 (sin (+ angle da3)))
+                         neg-half-width)
+              (gl-vertex (* r0 cos-angle)
+                         (* r0 sin-angle)
+                         neg-half-width))))
+        (gl-end)
+
+        ;; Draw back sides of teeth.
+        (gl-begin 'quads)
+        (do ((i 0 (+ 1 i))) ((= i teeth))
+          (let ((angle (/ (* i 2.0 pi) teeth)))
+            (gl-vertex (* r1 (cos (+ angle da3)))
+                       (* r1 (sin (+ angle da3)))
+                       neg-half-width)
+            (gl-vertex (* r2 (cos (+ angle da2)))
+                       (* r2 (sin (+ angle da2)))
+                       neg-half-width)
+            (gl-vertex (* r2 (cos (+ angle da)))
+                       (* r2 (sin (+ angle da)))
+                       neg-half-width)
+            (gl-vertex (* r1 (cos angle))
+                       (* r1 (sin angle))
+                       neg-half-width)))
+        (gl-end)
+
+        ;; Draw outward faces of teeth.
+        (gl-begin 'quad-strip)
+        (do ((i 0 (+ 1 i))) ((= i teeth))
+          (let* ((angle     (/ (* i 2.0 pi) teeth))
+                 (cos-angle (cos angle))
+                 (sin-angle (sin angle)))
+
+            (gl-vertex (* r1 cos-angle) (* r1 sin-angle) half-width)
+            (gl-vertex (* r1 cos-angle) (* r1 sin-angle) neg-half-width)
+
+            (let* ((u   (- (* r2 (cos (+ angle da))) (* r1 cos-angle)))
+                   (v   (- (* r2 (sin (+ angle da))) (* r1 sin-angle)))
+                   (len (sqrt (+ (* u u) (* v v)))))
+              (gl-normal (/ v len) (- (/ u len)) 0.0))
+
+            (gl-vertex (* r2 (cos (+ angle da)))
+                       (* r2 (sin (+ angle da)))
+                       half-width)
+            (gl-vertex (* r2 (cos (+ angle da)))
+                       (* r2 (sin (+ angle da)))
+                       neg-half-width)
+            (gl-normal cos-angle sin-angle 0.0)
+            (gl-vertex (* r2 (cos (+ angle da2)))
+                       (* r2 (sin (+ angle da2)))
+                       half-width)
+            (gl-vertex (* r2 (cos (+ angle da2)))
+                       (* r2 (sin (+ angle da2)))
+                       neg-half-width)
+
+            (let ((u (- (* r1 (cos (+ angle da3)))
+                        (* r2 (cos (+ angle da2)))))
+                  (v (- (* r1 (sin (+ angle da3)))
+                        (* r2 (sin (+ angle da2))))))
+              (gl-normal v (- u) 0.0))
+
+            (gl-vertex (* r1 (cos (+ angle da3)))
+                       (* r1 (sin (+ angle da3)))
+                       half-width)
+            (gl-vertex (* r1 (cos (+ angle da3)))
+                       (* r1 (sin (+ angle da3)))
+                       neg-half-width)
+            (gl-normal cos-angle sin-angle 0.0)))
+
+        (gl-vertex (* r1 (cos 0)) (* r1 (sin 0)) half-width)
+        (gl-vertex (* r1 (cos 0)) (* r1 (sin 0)) neg-half-width)
+        (gl-end)
+
+        (gl-shade-model 'smooth)
+
+        ;; Draw inside radius cylinder.
+        (gl-begin 'quad-strip)
+        (do ((i 0 (+ 1 i))) ((> i teeth))
+          (let* ((angle     (/ (* i 2.0 pi) teeth))
+                 (cos-angle (cos angle))
+                 (sin-angle (sin angle)))
+            (gl-normal (- cos-angle) (- sin-angle) 0.0)
+            (gl-vertex (* r0 cos-angle) (* r0 sin-angle) neg-half-width)
+            (gl-vertex (* r0 cos-angle) (* r0 sin-angle) half-width)))
+        (gl-end)))
+
+    (define/override (on-size width height)
+      (with-gl-context
+       (lambda ()
+
+         (unless gear1
+           (printf "  RENDERER:   ~A\n" (gl-get-string 'renderer))
+           (printf "  VERSION:    ~A\n" (gl-get-string 'version))
+           (printf "  VENDOR:     ~A\n" (gl-get-string 'vendor))
+           (printf "  EXTENSIONS: ~A\n" (gl-get-string 'extensions)))
+
+         (gl-viewport 0 0 width height)
+         (gl-matrix-mode 'projection)
+         (gl-load-identity)
+         (let ((h (/ height width)))
+           (gl-frustum -1.0 1.0 (- h) h 5.0 60.0))
+         (gl-matrix-mode 'modelview)
+         (gl-load-identity)
+         (gl-translate 0.0 0.0 -40.0)
+
+         (gl-light-v 'light0 'position (vector->gl-float-vector
+                                        (vector 5.0 5.0 10.0 0.0)))
+         (gl-enable 'cull-face)
+         (gl-enable 'lighting)
+         (gl-enable 'light0)
+         (gl-enable 'depth-test)
+
+         (unless gear1
+
+           (set! gear1 (gl-gen-lists 1))
+           (gl-new-list gear1 'compile)
+           (gl-material-v 'front
+                           'ambient-and-diffuse
+                           (vector->gl-float-vector (vector 0.8 0.1 0.0 1.0)))
+           (build-gear 1.0 4.0 1.0 20 0.7)
+           (gl-end-list)
+
+           (set! gear2 (gl-gen-lists 1))
+           (gl-new-list gear2 'compile)
+           (gl-material-v 'front
+                           'ambient-and-diffuse
+                           (vector->gl-float-vector (vector 0.0 0.8 0.2 1.0)))
+           (build-gear 0.5 2.0 2.0 10 0.7)
+           (gl-end-list)
+
+           (set! gear3 (gl-gen-lists 1))
+           (gl-new-list gear3 'compile)
+           (gl-material-v 'front
+                           'ambient-and-diffuse
+                           (vector->gl-float-vector (vector 0.2 0.2 1.0 1.0)))
+           (build-gear 1.3 2.0 0.5 10 0.7)
+           (gl-end-list)
+
+           (gl-enable 'normalize))))
+      (refresh))
+
+    (define sec (current-seconds))
+    (define frames 0)
+    
+    (define/override (on-paint)
+      (when gear1
+	(when (>= (- (current-seconds) sec) 5)
+	  (send (get-parent) set-status-text (format "~a fps" (/ (exact->inexact frames) 5)))
+	  (set! sec (current-seconds))
+	  (set! frames 0))
+	(set! frames (add1 frames))
+        
+	(when step?
+	  ;; TODO: Don't increment this infinitely.
+	  (set! rotation (+ 2.0 rotation)))
+	(with-gl-context
+	 (lambda ()
+
+	   (gl-clear-color 0.0 0.0 0.0 0.0)
+	   (gl-clear 'color-buffer-bit 'depth-buffer-bit)
+
+	   (gl-push-matrix)
+	   (gl-rotate view-rotx 1.0 0.0 0.0)
+	   (gl-rotate view-roty 0.0 1.0 0.0)
+	   (gl-rotate view-rotz 0.0 0.0 1.0)
+
+	   (gl-push-matrix)
+	   (gl-translate -3.0 -2.0 0.0)
+	   (gl-rotate rotation 0.0 0.0 1.0)
+	   (gl-call-list gear1)
+	   (gl-pop-matrix)
+
+	   (gl-push-matrix)
+	   (gl-translate 3.1 -2.0 0.0)
+	   (gl-rotate (- (* -2.0 rotation) 9.0) 0.0 0.0 1.0)
+	   (gl-call-list gear2)
+	   (gl-pop-matrix)
+
+	   (gl-push-matrix)
+	   (gl-translate -3.1 4.2 0.0)
+	   (gl-rotate (- (* -2.0 rotation) 25.0) 0.0 0.0 1.0)
+	   (gl-call-list gear3)
+	   (gl-pop-matrix)
+
+	   (gl-pop-matrix)
+
+	   (swap-gl-buffers)
+	   (gl-flush)))
+	(when step?
+	  (set! step? #f)
+	  (queue-callback (lambda x (send this run))))))
+
+    (super-instantiate () (style '(gl no-autoclear)))))
+(define (f)
+  (let* ((f (make-object frame% "gears.ss" #f))
+         (c (instantiate gears-canvas% (f) (min-width 300) (min-height 300))))
+    (send f create-status-line)
+    (when controls?
+      (let ((h (instantiate horizontal-panel% (f)
+                 (alignment '(center center)) (stretchable-height #f))))
+        (instantiate button%
+          ("Start" h (lambda (b e) (send b enable #f) (send c run)))
+          (stretchable-width #t) (stretchable-height #t))
+        (let ((h (instantiate horizontal-panel% (h)
+                   (alignment '(center center)))))
+          (instantiate button% ("Left" h (lambda x (send c move-left)))
+            (stretchable-width #t))
+          (let ((v (instantiate vertical-panel% (h)
+                     (alignment '(center center)) (stretchable-width #f))))
+            (instantiate button% ("Up" v (lambda x (send c move-up)))
+              (stretchable-width #t))
+            (instantiate button% ("Down" v (lambda x (send c move-down)))
+              (stretchable-width #t)))
+          (instantiate button% ("Right" h (lambda x (send c move-right)))
+            (stretchable-width #t)))))
+    (send f show #t)))
+  (f)
+)
+;;eof
diff --git a/collects/sgl/examples/gl-frame.ss b/collects/sgl/examples/gl-frame.ss
new file mode 100644
index 0000000000..eb858706df
--- /dev/null
+++ b/collects/sgl/examples/gl-frame.ss
@@ -0,0 +1,152 @@
+;; By Brendan Burns, with modifications by Scott Owens
+
+(module gl-frame (lib "plt-pretty-big.ss" "lang")
+  (require (lib "gl.ss" "sgl")
+           (lib "gl-vectors.ss" "sgl"))  
+  (provide set-gl-draw-fn
+           set-gl-init-fn
+           init-textures
+           image->gl-vector
+           bitmap->gl-vector
+           gl-load-texture
+           get-texture
+           add-key-mapping
+           clear-key-mappings
+           gl-run)
+  
+  (define gl-draw void)
+  (define gl-init 
+    (lambda ()
+      (glShadeModel GL_SMOOTH)
+      (glClearColor 0.0 0.0 0.0 0.5)
+      (glClearDepth 1)
+      (glEnable GL_DEPTH_TEST)
+      (glDepthFunc GL_LEQUAL)
+      (glHint GL_PERSPECTIVE_CORRECTION_HINT GL_NICEST)))
+  
+  (define (set-gl-draw-fn fn)
+    (set! gl-draw fn))
+  
+  (define (set-gl-init-fn fn)
+    (set! gl-init fn))
+    
+  ;; A function that recorrects for a new aspect ratio when the window is resized
+  (define (gl-resize width height)
+    (glViewport 0 0 width height)
+    
+    (glMatrixMode GL_PROJECTION)
+    (glLoadIdentity)
+    (gluPerspective 45 (/ width height) 0.1 100)
+    
+    (glMatrixMode GL_MODELVIEW)
+    (glLoadIdentity))
+  
+  (define (recursive-handle-key list code)
+    (cond
+      ((empty? list) void)
+      ((equal? (caar list) code) ((car (cdr (car list)))))
+      (else (recursive-handle-key (rest list) code))))
+  
+  (define *key-mappings* '())
+  
+  (define (add-key-mapping key fn)
+    (set! *key-mappings* (cons (list key fn) *key-mappings*)))
+  
+  (define (clear-key-mappings)
+    (set! *key-mappings* '()))
+  
+  (define (gl-handlekey key)
+    (recursive-handle-key *key-mappings* (send key get-key-code)))
+  
+  (define glcanvas%
+    (class canvas%
+      (inherit refresh with-gl-context swap-gl-buffers)
+
+      (define/override (on-paint)
+        (with-gl-context 
+         (lambda ()
+           (gl-draw)
+           (swap-gl-buffers)))
+        (refresh))
+      
+      (define/override (on-size w h)
+        (with-gl-context 
+         (lambda ()
+           (gl-resize w h)))
+        (refresh))
+      
+      (define/override (on-char key)
+        (gl-handlekey key)
+        (refresh))
+      (super-new (style '(no-autoclear)))))
+  
+  (define (gl-run)
+    (let* ((frame (new frame% (label "OpenGL Window") 
+                              (width 640) 
+                              (height 480)))
+           (glcanvas (new glcanvas% (parent frame))))
+      (unless (send (send (send glcanvas get-dc) get-gl-context) ok?)
+        (display "Error: OpenGL context failed to initialize")
+        (newline)
+        (exit))
+      (send frame show #t)
+      (send glcanvas with-gl-context gl-init)))
+  
+  (define *textures* '())
+  
+  (define init-textures
+    (lambda (count)
+      (set! *textures* (glGenTextures count))))
+  
+  (define (bitmap->gl-vector bmp)
+    (let* (
+           (dc (instantiate bitmap-dc% (bmp)))
+           (pixels (* (send bmp get-width) (send bmp get-height)))
+           (vec (make-gl-ubyte-vector (* pixels 3)))
+           (data (make-bytes (* pixels 4)))
+           (i 0)
+           )
+      (send dc get-argb-pixels 0 0 (send bmp get-width) (send bmp get-height) data)
+      (letrec
+          ([loop
+            (lambda ()
+              (if (< i pixels)
+                  (begin
+                    (gl-vector-set! vec (* i  3) 
+                                    (bytes-ref data (+ (* i 4) 1)))
+                    (gl-vector-set! vec (+ (* i 3) 1) 
+                                    (bytes-ref data (+ (* i 4) 2)))
+                    (gl-vector-set! vec (+ (* i 3) 2) 
+                                    (bytes-ref data (+ (* i 4) 3)))
+                    (set! i (+ i 1))
+                    (loop))))])
+        (loop))
+      (send dc set-bitmap #f)
+      (list (send bmp get-width) (send bmp get-height) vec)))
+  
+  (define (image->gl-vector file) (bitmap->gl-vector (make-object bitmap% file 'unknown #f)))
+  
+  (define gl-load-texture
+    (lambda (image-vector width height min-filter mag-filter ix)
+      (glBindTexture GL_TEXTURE_2D (gl-vector-ref *textures* ix))
+      (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER min-filter)
+      (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER mag-filter)
+      (let* ((new-width 128)
+             (new-height 128)
+             (new-img-vec (make-gl-ubyte-vector (* new-width new-height 3))))
+        (gluScaleImage GL_RGB
+                       width height GL_UNSIGNED_BYTE image-vector
+                       new-width new-height GL_UNSIGNED_BYTE new-img-vec)
+        (if (or (= min-filter GL_LINEAR_MIPMAP_NEAREST)
+                (= mag-filter GL_LINEAR_MIPMAP_NEAREST))
+            (gluBuild2DMipmaps GL_TEXTURE_2D 3 new-width new-height GL_RGB GL_UNSIGNED_BYTE new-img-vec)
+            (glTexImage2D GL_TEXTURE_2D 0 3 new-width new-height 0 GL_RGB GL_UNSIGNED_BYTE new-img-vec))))
+    )
+  
+  (define get-texture
+    (lambda (ix)
+      (gl-vector-ref *textures* ix)))
+  )
+
+
+
diff --git a/collects/sgl/gl-types.ss b/collects/sgl/gl-types.ss
new file mode 100644
index 0000000000..d05262a6c9
--- /dev/null
+++ b/collects/sgl/gl-types.ss
@@ -0,0 +1,76 @@
+(module gl-types mzscheme
+  (require (lib "foreign.ss")
+           "gl-info.ss")
+  
+  (provide (all-defined-except get-unsigned-type get-signed-type make-gl-vector-type))
+
+  (define _float*
+    (make-ctype _float 
+                (lambda (n)
+                  (if (exact? n)
+                      (exact->inexact n)
+                      n))
+                #f))
+  
+  (define (get-unsigned-type size)
+    (case size
+      ((1) _uint8)
+      ((2) _uint16)
+      ((4) _uint32)
+      ((8) _uint64)
+      (else (error 'get-unsigned-type (format "no ~a byte unsigned type" size)))))
+
+  (define (get-signed-type size)
+    (case size
+      ((1) _sint8)
+      ((2) _sint16)
+      ((4) _sint32)
+      ((8) _sint64)
+      (else (error 'get-signed-type (format "no ~a byte signed type" size)))))
+
+  (define (make-gl-vector-type t)
+    (make-ctype _cvector
+                (lambda (sval)
+                  (unless (cvector? sval)
+                    (raise-type-error 'Scheme->C "cvector" sval))
+                  (unless (eq? (cvector-type sval) t)
+                    (error 'Scheme->C "wrong kind of cvector"))
+                  sval)
+                #f))
+
+  (define _gl-byte (get-signed-type gl-byte-size))
+  (define _gl-ubyte (get-unsigned-type gl-ubyte-size))
+  (define _gl-short (get-signed-type gl-short-size))
+  (define _gl-ushort (get-unsigned-type gl-ushort-size))
+  (define _gl-int (get-signed-type gl-int-size))
+  (define _gl-uint (get-unsigned-type gl-uint-size))
+  (define _gl-boolean (make-ctype (get-unsigned-type gl-boolean-size)
+                                  (lambda (x)
+                                    (if x 1 0))
+                                  (lambda (x) (not (= x 0)))))
+  (define _gl-sizei (get-unsigned-type gl-sizei-size))
+  (define _gl-enum (get-unsigned-type gl-enum-size))
+  (define _gl-bitfield (get-unsigned-type gl-bitfield-size))
+  (define _gl-float _float*)
+  (define _gl-double _double*)
+  (define _gl-clampf _float*)
+  (define _gl-clampd _double*)
+
+  (define _gl-bytev (make-gl-vector-type _gl-byte))
+  (define _gl-ubytev (make-gl-vector-type _gl-ubyte))
+  (define _gl-shortv (make-gl-vector-type _gl-short))
+  (define _gl-ushortv (make-gl-vector-type _gl-ushort))
+  (define _gl-intv (make-gl-vector-type _gl-int))
+  (define _gl-uintv (make-gl-vector-type _gl-uint))
+  (define _gl-booleanv (make-gl-vector-type _gl-boolean))
+  (define _gl-floatv (make-gl-vector-type _gl-float))
+  (define _gl-doublev (make-gl-vector-type _gl-double))
+  (define _gl-voidv _cvector)
+
+  ;; If GLfloat and GLdouble don't correspond to C's float and double, things
+  ;; won't work.
+  (unless (= gl-float-size (compiler-sizeof '(float)))
+    (error 'gl-float "GLfloat does not correspond to C's float type"))
+  (unless (= gl-double-size (compiler-sizeof '(double)))
+    (error 'gl-double "GLdouble does not correspond to C's double type"))
+  )
\ No newline at end of file
diff --git a/collects/sgl/gl-vectors.ss b/collects/sgl/gl-vectors.ss
new file mode 100644
index 0000000000..69bdf516c8
--- /dev/null
+++ b/collects/sgl/gl-vectors.ss
@@ -0,0 +1,134 @@
+(module gl-vectors mzscheme
+  (require (lib "foreign.ss")
+           "gl-types.ss")
+  
+  (define-syntax gl-vector-binop
+    (syntax-rules ()
+      ((_ op name make-res)
+       (case-lambda
+         ((v)
+          (unless (gl-vector? v)
+            (raise-type-error name "gl-vector" v))
+          (let* ((l (cvector-length v))
+                 (res (make-res l)))
+            (let loop ((i 0))
+              (when (< i l)
+                (cvector-set! res i (op (cvector-ref v i)))
+                (loop (add1 i)))
+              res)))
+         ((v1 v2)
+          (unless (gl-vector? v1)
+           (raise-type-error name "gl-vector" 0 v1 v2))
+          (unless (gl-vector? v2)
+            (raise-type-error name "gl-vector" 1 v1 v2))
+          (unless (= (cvector-length v1) (cvector-length v2))
+            (error name "given gl-vector arguments of unequal lengths: ~a" 
+                   (list (cvector-length v1) (cvector-length v2))))
+          (let* ((l (cvector-length v1))
+                 (t (cvector-type v1))
+                 (res (make-res l)))
+            (let loop ((i 0))
+              (when (< i l)
+                (cvector-set! res i (op (cvector-ref v1 i) (cvector-ref v2 i)))
+                (loop (add1 i))))
+            res))
+         ((v . vs)
+          (let ((all-v (cons v vs)))
+            (unless (andmap gl-vector? all-v)
+              (let loop ((i 0)
+                         (to-check all-v))
+                (unless (null? to-check)
+                  (unless (gl-vector? (car to-check))
+                    (apply raise-type-error (list* name "gl-vector" i all-v)))
+                  (loop (add1 i) (cdr to-check)))))
+            (let ((l (cvector-length v)))
+              (unless (andmap (lambda (x) (= l (cvector-length x))) vs)
+                (error name "given gl-vector arguments of unequal lengths: ~a"
+                       (map cvector-length all-v)))
+              (let ((res (make-res l)))
+                (let loop ((i 0))
+                  (when (< i l)
+                    (cvector-set! res i (apply op (map (lambda (x) (cvector-ref x i))
+                                                      all-v)))
+                    (loop (add1 i))))
+                res))))))))
+                    
+  (define-for-syntax (d->so stx str)
+    (datum->syntax-object stx (string->symbol str)))
+  
+  (define-syntax (define-gl-vector stx)
+    (syntax-case stx ()
+      ((_ type)
+       (let ((t (syntax-object->datum #'type)))
+         (with-syntax (((v? make-v v vector->v list->v v+ v- v*)
+                        (map
+                         (lambda (fmt)
+                           (d->so #'type (format fmt t)))
+                         '("gl-~a-vector?" "make-gl-~a-vector" "gl-~a-vector"
+                           "vector->gl-~a-vector" "list->gl-~a-vector"
+                           "gl-~a-vector+" "gl-~a-vector-" "gl-~a-vector*")))
+                       (gl-type (d->so #'type (format "_gl-~a" t)))
+                       (gl-vtype (d->so #'type (format "_gl-~av" t))))
+           #'(begin
+               (provide v? make-v v vector->v list->v v+ v- v*)
+               (define (v? v)
+                 (and (cvector? v)
+                      (eq? (cvector-type v) gl-type)))
+               (define (make-v len)
+                 (make-cvector gl-type len))
+               (define (v . args)
+                 (apply cvector (cons gl-type args)))
+               (define (vector->v v)
+                 (unless (vector? v)
+                   (raise-type-error 'vector->v "vector" v))
+                 (list->cvector (vector->list v) gl-type))
+               (define (list->v l)
+                 (list->cvector l gl-type))
+               (define v+ (gl-vector-binop + 'v+ make-v))
+               (define v- (gl-vector-binop - 'v- make-v))
+               (define (v* n v)
+                 (unless (real? n)
+                   (raise-type-error 'gl-vector* "real number" 0 n v))
+                 (unless (gl-vector? v)
+                   (raise-type-error 'gl-vector* "gl-vector" 1 n v))
+                 (let* ((l (cvector-length v))
+                        (t (cvector-type v))
+                        (res (make-v l)))
+                   (let loop ((i 0))
+                     (when (< i l)
+                       (cvector-set! res i (* n (cvector-ref v i)))
+                       (loop (add1 i))))
+                   res))))))))
+  
+  (define-syntax define-gl-vectors
+    (syntax-rules ()
+      ((_ type)
+       (define-gl-vector type))
+      ((_ type rest ...)
+       (begin
+         (define-gl-vector type)
+         (define-gl-vectors rest ...)))))
+  
+  (define-gl-vectors byte ubyte short ushort int uint
+                     float double boolean)
+  (provide gl-vector->vector gl-vector->list gl-vector-length gl-vector-ref
+           gl-vector-set! gl-vector? gl-vector-norm)
+  (define (gl-vector->vector v)
+    (list->vector (cvector->list v)))
+  (define gl-vector->list cvector->list)
+  (define gl-vector-length cvector-length)
+  (define gl-vector-ref cvector-ref)
+  (define gl-vector-set! cvector-set!)
+  (define gl-vector? cvector?)
+  (define (gl-vector-norm v)
+    (unless (gl-vector? v)
+      (raise-type-error 'gl-vector-norm "gl-vector" v))
+    (let ((l (gl-vector-length v)))
+      (let loop ((i 0)
+                 (res 0))
+        (cond
+          ((< i l)
+           (loop (add1 i) (+ (expt (gl-vector-ref v i) 2) res)))
+          (else
+           (sqrt res))))))
+)
\ No newline at end of file
diff --git a/collects/sgl/gl.ss b/collects/sgl/gl.ss
new file mode 100644
index 0000000000..59f9227ca1
--- /dev/null
+++ b/collects/sgl/gl.ss
@@ -0,0 +1,1830 @@
+(module gl mzscheme
+  (require (lib "foreign.ss")
+           "gl-types.ss"
+           "gl-vectors.ss")
+  
+  (unsafe!)
+  (define gl-lib (case (system-type)
+		   [(windows) (ffi-lib "opengl32")]
+                   [(macosx) (ffi-lib "/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL")]
+		   [else (ffi-lib "libGL")]))
+  (define glu-lib (case (system-type)
+		   [(windows) (ffi-lib "glu32")]
+                   [(macosx) (ffi-lib "/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGLU")]
+		   [else (ffi-lib "libGLU")]))
+  
+  (define-syntax define-foreign-lib
+    (syntax-rules (->)
+      ((_ lib name type ... ->)
+       (define-foreign-lib lib name type ... -> _void))
+      ((_ lib name type ...)
+       (begin
+         ;(printf "~a~n" 'name)
+         (provide name)
+         (define name
+           (get-ffi-obj 'name lib (_fun type ...)
+                        (lambda ()
+                          (lambda x
+                            (error 'name "unavailable on this system")))))))))
+
+  (define-syntax define-foreign
+    (syntax-rules ()
+      ((_ args ...)
+       (define-foreign-lib gl-lib args ...))))
+      
+  (define-for-syntax (get-type x err)
+    (case (syntax-object->datum x)
+      ((b) #'_gl-byte)
+      ((s) #'_gl-short)
+      ((i) #'_gl-int)
+      ((f) #'_gl-float)
+      ((d) #'_gl-double)
+      ((ub) #'_gl-ubyte)
+      ((us) #'_gl-ushort)
+      ((ui) #'_gl-uint)
+      ((bv) #'_gl-bytev)
+      ((sv) #'_gl-shortv)
+      ((iv) #'_gl-intv)
+      ((fv) #'_gl-floatv)
+      ((dv) #'_gl-doublev)
+      ((ubv) #'_gl-ubytev)
+      ((usv) #'_gl-ushortv)
+      ((uiv) #'_gl-uintv)
+      (else (raise-syntax-error #f "unknown GL type abbreviation" err x))))
+
+  (define-for-syntax (get-vtype x err)
+    (case (syntax-object->datum x)
+      ((bv) #'_gl-byte)
+      ((sv) #'_gl-short)
+      ((iv) #'_gl-int)
+      ((fv) #'_gl-float)
+      ((dv) #'_gl-double)
+      ((ubv) #'_gl-ubyte)
+      ((usv) #'_gl-ushort)
+      ((uiv) #'_gl-uint)
+      (else (raise-syntax-error #f "unknown GL type abbreviation" err x))))
+  
+  (define-for-syntax (type-map type convert)
+    (syntax-case type (: =)
+      ((label : type) #`(label : #,(type-map #'type convert)))
+      ((type = expr) #`(#,(type-map #'type convert) = expr))
+      ((label : type = expr) #`(label : #,(type-map #'type convert) = expr))
+      (_
+       (convert type))))
+                                 
+  (define-syntax (define-foreign-tparm stx)
+    (syntax-case stx (->)
+      ((_ name (suffix ...) type ...)
+       (let* ((name-sym (syntax-object->datum #'name))
+              (build-def
+               (lambda (suffix)
+                 (with-syntax ((new-name
+                                (datum->syntax-object
+                                 #'name
+                                 (string->symbol
+                                  (format "~a~a"
+                                          name-sym 
+                                          (syntax-object->datum suffix)))
+                                 #'name))
+                               ((new-type ...)
+                                (map
+                                 (lambda (type)
+                                   (type-map
+                                    type
+                                    (lambda (type)
+                                      (syntax-case type (T outT)
+                                        (T (get-type suffix stx))
+                                        ((T n)
+                                         #`(_cvector o
+                                                     #,(get-vtype suffix stx)
+                                                     n))
+                                        (_ type)))))
+                                 (syntax->list #'(type ...)))))
+                   #'(define-foreign new-name new-type ...)))))
+         (with-syntax (((defs ...)
+                        (map build-def (syntax->list #'(suffix ...)))))
+           #'(begin defs ...))))))
+  
+  ;; 2.5
+  (define-foreign glGetError -> _gl-enum)
+  
+  ;; 2.6.1
+  (define-foreign glBegin _gl-enum ->)
+  (define-foreign glEnd ->)
+  
+  ;; 2.6.2
+  (define-foreign glEdgeFlag _gl-boolean ->)
+  (define-foreign glEdgeFlagv _gl-booleanv ->)
+
+  ;; 2.7
+  (define-foreign-tparm glVertex2 (s i f d) T T ->)
+  (define-foreign-tparm glVertex3 (s i f d) T T T ->)
+  (define-foreign-tparm glVertex4 (s i f d) T T T T ->)
+  (define-foreign-tparm glVertex2 (sv iv fv dv) T ->)
+  (define-foreign-tparm glVertex3 (sv iv fv dv) T ->)
+  (define-foreign-tparm glVertex4 (sv iv fv dv) T ->)
+  (define-foreign-tparm glTexCoord1 (s i f d) T ->)
+  (define-foreign-tparm glTexCoord2 (s i f d) T T ->)
+  (define-foreign-tparm glTexCoord3 (s i f d) T T T ->)
+  (define-foreign-tparm glTexCoord4 (s i f d) T T T T ->)
+  (define-foreign-tparm glTexCoord1 (sv iv fv dv) T ->)
+  (define-foreign-tparm glTexCoord2 (sv iv fv dv) T ->)
+  (define-foreign-tparm glTexCoord3 (sv iv fv dv) T ->)
+  (define-foreign-tparm glTexCoord4 (sv iv fv dv) T ->)
+  (define-foreign-tparm glMultiTexCoord1 (s i f d) _gl-enum T ->)
+  (define-foreign-tparm glMultiTexCoord2 (s i f d) _gl-enum T T ->)
+  (define-foreign-tparm glMultiTexCoord3 (s i f d) _gl-enum T T T ->)
+  (define-foreign-tparm glMultiTexCoord4 (s i f d) _gl-enum T T T T ->)
+  (define-foreign-tparm glMultiTexCoord1 (sv iv fv dv) _gl-enum T ->)
+  (define-foreign-tparm glMultiTexCoord2 (sv iv fv dv) _gl-enum T ->)
+  (define-foreign-tparm glMultiTexCoord3 (sv iv fv dv) _gl-enum T ->)
+  (define-foreign-tparm glMultiTexCoord4 (sv iv fv dv) _gl-enum T ->)
+  (define-foreign-tparm glNormal3 (b s i f d) T T T ->)
+  (define-foreign-tparm glNormal3 (bv sv iv fv dv) T ->)
+  (define-foreign-tparm glFogCoord (f d) T ->)
+  (define-foreign-tparm glFogCoord (fv dv) T ->)
+  (define-foreign-tparm glColor3 (b s i f d ub us ui) T T T ->)
+  (define-foreign-tparm glColor4 (b s i f d ub us ui) T T T T ->)
+  (define-foreign-tparm glColor3 (bv sv iv fv dv ubv usv uiv) T ->)
+  (define-foreign-tparm glColor4 (bv sv iv fv dv ubv usv uiv) T ->)
+  (define-foreign-tparm glSecondaryColor3 (b s i f d ub us ui) T T T ->)
+  (define-foreign-tparm glSecondaryColor3 (bv sv iv fv dv ubv usv uiv) T ->)
+  (define-foreign-tparm glIndex (s i f d ub) T ->)
+  (define-foreign-tparm glIndex (sv iv fv dv ubv) T ->)
+  
+  ;; 2.8
+  #|
+  (define-foreign glVertexPointer _gl-int _gl-enum _gl-sizei _gl-voidv ->)
+  (define-foreign glNormalPointer _gl-enum _gl-sizei _gl-voidv ->)
+  (define-foreign glColorPointer _gl-int _gl-enum _gl-sizei _gl-voidv ->)
+  (define-foreign glSecondaryColorPointer
+                  _gl-int _gl-enum _gl-sizei _gl-voidv ->)
+  (define-foreign glIndexPointer _gl-enum _gl-sizei _gl-voidv ->)
+  (define-foreign glFogCoordPointer _gl-enum _gl-sizei _gl-voidv ->)
+  (define-foreign glTexCoordPointer _gl-int _gl-enum _gl-sizei _gl-voidv ->)
+  (define-foreign glEdgeFlagPointer _gl-sizei _gl-voidv ->)
+  (define-foreign glEnableClientState _gl-enum ->)
+  (define-foreign glDisableClientState _gl-enum ->)
+  (define-foreign glClientActiveTexture _gl-enum ->)
+  (define-foreign glArrayElement _gl-int ->)
+  (define-foreign glDrawArrays _gl-enum _gl-int _gl-sizei ->)
+  (define-foreign glMultiDrawArrays _gl-enum _gl-intv _gl-sizeiv _gl-sizei ->)
+  (define-foreign glDrawElements _gl-enum _gl-sizei _gl-enum _gl-voidv ->)
+  (define-foreign glMultiDrawElements
+                  _gl-enum _gl-sizeiv _gl-enum _gl-voidvv _gl-sizei ->)
+  (define-foreign glDrawRangeElements
+                  _gl-enum _gl-uint _gl-uint _gl-sizei _gl-enum _gl-voidv ->)
+  (define-foreign glInterleavedArrays _gl-enum _gl-sizei _gl-voidv)
+  |#
+  
+  ;; 2.9
+  #|
+  (define-foreign glBindBuffer _gl-enum _gl-uint ->)
+  (define-foreign glDeleteBuffers _gl-sizei gl_uintv ->)
+  (define-foreign glGenBuffers _gl-sizei gl_uintv ->)
+  (define-foreign glBufferData _gl-enum _gl-sizeiptr _gl_voidv _gl-enum ->)
+  (define-foreign glBufferSubData _gl-enum _gl-intptr _gl-sizeiptr _gl_voidv ->)
+  (define-foreign glMapBuffer _gl-enum _gl-enum -> _gl-voidv)
+  (define-foreign glUnmapBuffer _gl-enum -> _gl-boolean)
+  |#
+  
+  ;; 2.10
+  (define-foreign-tparm glRect (s i f d) T T T T ->)
+  (define-foreign-tparm glRect (sv iv fv dv) T ->)
+  
+  ;; 2.11.1
+  (define-foreign glDepthRange _gl-clampd _gl-clampd ->)
+  (define-foreign glViewport _gl-int _gl-int _gl-sizei _gl-sizei ->)
+
+  ;; 2.11.2
+  (define-foreign glMatrixMode _gl-enum ->)
+  (define-foreign glLoadMatrixf _gl-floatv ->)
+  (define-foreign glLoadMatrixd _gl-doublev ->)
+  (define-foreign glMultMatrixf _gl-floatv ->)
+  (define-foreign glMultMatrixd _gl-doublev ->)
+  (define-foreign glLoadTransposeMatrixf _gl-floatv ->)
+  (define-foreign glLoadTransposeMatrixd _gl-doublev ->)
+  (define-foreign glMultTransposeMatrixf _gl-floatv ->)
+  (define-foreign glMultTransposeMatrixd _gl-doublev ->)
+  (define-foreign glLoadIdentity ->)
+  (define-foreign-tparm glRotate (f d) T T T T ->)
+  (define-foreign-tparm glTranslate (f d) T T T ->)
+  (define-foreign-tparm glScale (f d) T T T ->)
+  (define-foreign glFrustum _gl-double _gl-double _gl-double
+                            _gl-double _gl-double _gl-double ->)
+  (define-foreign glOrtho _gl-double _gl-double _gl-double
+                          _gl-double _gl-double _gl-double ->)
+  (define-foreign glActiveTexture _gl-enum ->)
+  (define-foreign glPushMatrix ->)
+  (define-foreign glPopMatrix ->)
+  
+  ;; 2.11.3
+  (define-foreign glEnable _gl-enum ->)
+  (define-foreign glDisable _gl-enum ->)
+  
+  ;; 2.11.4
+  (define-foreign-tparm glTexGen (i f d) _gl-enum _gl-enum T ->)
+  (define-foreign-tparm glTexGen (iv fv dv) _gl-enum _gl-enum T ->)
+  
+  ;; 2.12
+  (define-foreign glClipPlane _gl-enum _gl-doublev ->)
+  
+  ;; 2.13
+  (define-foreign-tparm glRasterPos2 (s i f d) T T ->)
+  (define-foreign-tparm glRasterPos3 (s i f d) T T T ->)
+  (define-foreign-tparm glRasterPos4 (s i f d) T T T T ->)
+  (define-foreign-tparm glRasterPos2 (sv iv fv dv) T ->)
+  (define-foreign-tparm glRasterPos3 (sv iv fv dv) T ->)
+  (define-foreign-tparm glRasterPos4 (sv iv fv dv) T ->)
+  (define-foreign-tparm glWindowPos2 (s i f d) T T ->)
+  (define-foreign-tparm glWindowPos3 (s i f d) T T T ->)
+  (define-foreign-tparm glWindowPos2 (sv iv fv dv) T ->)
+  (define-foreign-tparm glWindowPos3 (sv iv fv dv) T ->)
+  
+  ;; 2.14.1
+  (define-foreign glFrontFace _gl-enum ->)
+  
+  ;; 2.14.2
+  (define-foreign-tparm glMaterial (i f) _gl-enum _gl-enum T ->)
+  (define-foreign-tparm glMaterial (iv fv) _gl-enum _gl-enum T ->)
+  (define-foreign-tparm glLight (i f) _gl-enum _gl-enum T ->)
+  (define-foreign-tparm glLight (iv fv) _gl-enum _gl-enum T ->)
+  (define-foreign-tparm glLightModel (i f) _gl-enum T ->)
+  (define-foreign-tparm glLightModel (iv fv) _gl-enum T ->)
+  
+  ;; 2.14.3
+  (define-foreign glColorMaterial _gl-enum _gl-enum ->)
+  
+  ;; 2.14.7
+  (define-foreign glShadeModel _gl-enum ->)
+  
+  ;; 3.3
+  (define-foreign glPointSize _gl-float ->)
+  (define-foreign-tparm glPointParameter (i f) _gl-enum _gl-float ->)
+  (define-foreign-tparm glPointParameter (iv fv) _gl-enum _gl-floatv ->)
+  
+  ;; 3.4
+  (define-foreign glLineWidth _gl-float ->)
+  
+  ;; 3.4.2
+  (define-foreign glLineStipple _gl-int _gl-ushort ->)
+  
+  ;; 3.5.1
+  (define-foreign glCullFace _gl-enum ->)
+  
+  ;; 3.5.2
+  (define-foreign glPolygonStipple _gl-ubytev ->)
+  
+  ;; 3.5.4
+  (define-foreign glPolygonMode _gl-enum _gl-enum ->)
+  
+  ;; 3.5.5
+  (define-foreign glPolygonOffset _gl-float _gl-float ->)
+  
+  ;; 3.6.1
+  (define-foreign-tparm glPixelStore (i f) _gl-enum T ->)
+  
+  ;; 3.6.3
+  (define-foreign-tparm glPixelTransfer (i f) _gl-enum T ->)
+  (define-foreign-tparm glPixelMap (uiv usv fv)
+                        _gl-enum (_gl-sizei = (cvector-length l)) (l : T) ->)
+  (define-foreign glColorTable
+                  _gl-enum _gl-enum _gl-sizei _gl-enum _gl-enum _gl-voidv ->)
+  (define-foreign-tparm glColorTableParameter (iv fv) _gl-enum _gl-enum T ->)
+  (define-foreign glCopyColorTable
+                  _gl-enum _gl-enum _gl-int _gl-int _gl-sizei ->)
+  (define-foreign glColorSubTable
+                  _gl-enum _gl-sizei _gl-sizei _gl-enum _gl-enum _gl-voidv ->)
+  (define-foreign glCopyColorSubTable
+                  _gl-enum _gl-sizei _gl-int _gl-int _gl-sizei ->)
+  (define-foreign glConvolutionFilter2D _gl-enum _gl-enum _gl-sizei _gl-sizei
+                                        _gl-enum _gl-enum _gl-voidv ->)
+  (define-foreign-tparm glConvolutionParameter (iv fv) _gl-enum _gl-enum T ->)
+  (define-foreign glConvolutionFilter1D
+                  _gl-enum _gl-enum _gl-sizei _gl-enum _gl-enum _gl-voidv ->)
+  (define-foreign glSeparableFilter2D _gl-enum _gl-enum _gl-sizei _gl-sizei
+                                      _gl-enum _gl-enum _gl-voidv _gl-voidv ->)
+  (define-foreign glCopyConvolutionFilter2D
+                  _gl-enum _gl-enum _gl-int _gl-int _gl-sizei _gl-sizei ->)
+  (define-foreign glCopyConvolutionFilter1D
+                  _gl-enum _gl-enum _gl-int _gl-int _gl-sizei ->)
+  (define-foreign glHistogram _gl-enum _gl-sizei _gl-enum _gl-boolean ->)
+  (define-foreign glMinmax _gl-enum _gl-enum _gl-boolean ->)
+  
+  ;; 3.6.4
+  (define-foreign glDrawPixels
+                  _gl-sizei _gl-sizei _gl-enum _gl-enum _gl-voidv ->)
+  (define-foreign glPixelZoom _gl-float _gl-float ->)
+  
+  ;; 3.6.5
+  (define-foreign-tparm  glConvolutionParameter (i f) _gl-enum _gl-enum T ->)
+
+  ;; 3.7
+  (define-foreign glBitmap _gl-sizei _gl-sizei _gl-float _gl-float _gl-float
+                           _gl-float _gl-ubytev ->)
+
+  ;; 3.8.1
+  (define-foreign glTexImage3D _gl-enum _gl-int _gl-int _gl-sizei _gl-sizei
+                               _gl-sizei _gl-int _gl-enum _gl-enum _gl-voidv ->)
+  (define-foreign glTexImage2D _gl-enum _gl-int _gl-int _gl-sizei _gl-sizei
+                               _gl-int _gl-enum _gl-enum _gl-voidv ->)
+  (define-foreign glTexImage1D _gl-enum _gl-int _gl-int _gl-sizei _gl-int 
+                               _gl-enum _gl-enum _gl-voidv ->)
+
+  ;; 3.8.2
+  (define-foreign glCopyTexImage2D _gl-enum _gl-int _gl-enum _gl-int _gl-int
+                                   _gl-sizei _gl-sizei _gl-int ->)
+  (define-foreign glCopyTexImage1D _gl-enum _gl-int _gl-enum _gl-int _gl-int
+                                   _gl-sizei _gl-int ->)
+  (define-foreign glTexSubImage3D
+                  _gl-enum _gl-int _gl-int _gl-int _gl-int _gl-sizei _gl-sizei 
+                  _gl-sizei _gl-enum _gl-enum _gl-voidv ->)
+  (define-foreign glTexSubImage2D
+                  _gl-enum _gl-int _gl-int _gl-int _gl-sizei _gl-sizei 
+                  _gl-enum _gl-enum _gl-voidv ->)
+  (define-foreign glTexSubImage1D _gl-enum _gl-int _gl-int _gl-sizei 
+                                  _gl-enum _gl-enum _gl-voidv ->)
+  (define-foreign glCopyTexSubImage3D
+                  _gl-enum _gl-int _gl-int _gl-int _gl-int _gl-int _gl-int 
+                  _gl-sizei _gl-sizei ->)
+  (define-foreign glCopyTexSubImage2D
+                  _gl-enum _gl-int _gl-int _gl-int _gl-int _gl-int
+                  _gl-sizei _gl-sizei ->)
+  (define-foreign glCopyTexSubImage1D
+                  _gl-enum _gl-int _gl-int _gl-int _gl-int _gl-sizei ->)
+
+  ;; 3.8.3
+  (define-foreign glCompressedTexImage1D
+                  _gl-enum _gl-int _gl-enum _gl-sizei _gl-int _gl-sizei
+                  _gl-voidv ->)
+  (define-foreign glCompressedTexImage2D
+                  _gl-enum _gl-int _gl-enum _gl-sizei _gl-sizei _gl-int
+                  _gl-sizei _gl-voidv ->)
+  (define-foreign glCompressedTexImage3D
+                  _gl-enum _gl-int _gl-enum _gl-sizei _gl-sizei _gl-sizei
+                  _gl-int _gl-sizei _gl-voidv ->)
+  (define-foreign glCompressedTexSubImage1D
+                  _gl-enum _gl-int _gl-int _gl-sizei _gl-enum _gl-sizei
+                  _gl-voidv ->)
+  (define-foreign glCompressedTexSubImage2D
+                  _gl-enum _gl-int _gl-int _gl-int _gl-sizei _gl-sizei _gl-enum
+                  _gl-sizei _gl-voidv ->)
+  (define-foreign glCompressedTexSubImage3D
+                  _gl-enum _gl-int _gl-int _gl-int _gl-int _gl-sizei _gl-sizei
+                  _gl-sizei _gl-enum _gl-sizei _gl-voidv ->)
+  
+  ;; 3.8.4
+  (define-foreign-tparm glTexParameter (i f) _gl-enum _gl-enum T ->)
+  (define-foreign-tparm glTexParameter (iv fv) _gl-enum _gl-enum T ->)
+  
+  ;; 3.8.12
+  (define-foreign glBindTexture _gl-enum _gl-uint ->)
+  (define-foreign glDeleteTextures
+                  (_gl-sizei = (cvector-length v)) (v : _gl-uintv) ->)
+  (define-foreign glGenTextures
+                  (n : _gl-sizei) (r : (_cvector o _gl-uint n)) -> _void -> r)
+  (define-foreign glAreTexturesResident
+                  (n : _gl-sizei = (cvector-length v)) (v : _gl-uintv)
+                  (r : (_cvector o _gl-boolean n)) -> 
+                  (r2 : _gl-boolean) -> (values r2 r))
+  
+  ;; 3.8.13
+  (define-foreign-tparm glTexEnv (i f) _gl-enum _gl-enum T ->)
+  (define-foreign-tparm glTexEnv (iv fv) _gl-enum _gl-enum T ->)
+  
+  ;; 3.10
+  (define-foreign-tparm glFog (i f) _gl-enum T ->)
+  (define-foreign-tparm glFog (iv fv) _gl-enum T ->)
+
+  ;; 4.1.2
+  (define-foreign glScissor _gl-int _gl-int _gl-sizei _gl-sizei ->)
+  
+  ;; 4.1.3
+  (define-foreign glSampleCoverage _gl-clampf _gl-boolean ->)
+  
+  ;; 4.1.4
+  (define-foreign glAlphaFunc _gl-enum _gl-clampf ->)
+  
+  ;; 4.1.5
+  (define-foreign glStencilFunc _gl-enum _gl-int _gl-uint ->)
+  (define-foreign glStencilOp _gl-enum _gl-enum _gl-enum ->)
+  
+  ;; 4.1.6
+  (define-foreign glDepthFunc _gl-enum ->)
+  
+  ;; 4.1.7
+  (define-foreign glBeginQuery _gl-enum _gl-uint ->)
+  (define-foreign glEndQuery _gl-enum ->)
+  (define-foreign glGenQueries
+                  (n : _gl-sizei) (r : (_cvector o _gl-uint n)) -> _void -> r)
+  (define-foreign glDeleteQueries  (_gl-sizei = (cvector-length v)) (v : _gl-uintv) ->)
+  
+  ;; 4.1.8
+  (define-foreign glBlendEquation _gl-enum ->)
+  (define-foreign glBlendFuncSeparate _gl-enum _gl-enum _gl-enum _gl-enum ->)
+  (define-foreign glBlendFunc _gl-enum _gl-enum ->)
+  (define-foreign glBlendColor _gl-clampf _gl-clampf _gl-clampf _gl-clampf ->)
+  
+  ;; 4.1.10
+  (define-foreign glLogicOp _gl-enum ->)
+  
+  ;; 4.2.1 
+  (define-foreign glDrawBuffer _gl-enum ->)
+  
+  ;; 4.2.2
+  (define-foreign glIndexMask _gl-uint ->)
+  (define-foreign glColorMask
+                  _gl-boolean _gl-boolean _gl-boolean _gl-boolean ->)
+  (define-foreign glDepthMask _gl-boolean ->)
+  (define-foreign glStencilMask _gl-uint ->)
+  
+  ;; 4.2.3
+  (define-foreign glClear _gl-bitfield ->)
+  (define-foreign glClearColor _gl-clampf _gl-clampf _gl-clampf _gl-clampf ->)
+  (define-foreign glClearIndex _gl-float ->)
+  (define-foreign glClearDepth _gl-clampd ->)
+  (define-foreign glClearStencil _gl-int ->)
+  (define-foreign glClearAccum _gl-float _gl-float _gl-float _gl-float ->)
+  
+  ;; 4.2.4
+  (define-foreign glAccum _gl-enum _gl-float ->)
+  
+  ;; 4.3.2
+  (define-foreign glReadPixels _gl-int _gl-int _gl-sizei _gl-sizei
+                               _gl-enum _gl-enum _gl-voidv ->)
+  (define-foreign glReadBuffer _gl-enum ->)
+  
+  ;; 4.3.3
+  (define-foreign glCopyPixels _gl-int _gl-int _gl-sizei _gl-sizei _gl-enum ->)
+  
+  ;; 5.1
+  ;; Map1 and 2 appear to have a bug in the spec where the last argument is not 
+  ;; declared as a pointer
+  (define-foreign-tparm glMap1 (f) _gl-enum T T _gl-int _gl-int _gl-floatv ->)
+  (define-foreign-tparm glMap1 (d) _gl-enum T T _gl-int _gl-int _gl-doublev ->)
+  (define-foreign-tparm glMap2 (f)
+                        _gl-enum T T _gl-int _gl-int T T _gl-int _gl-int
+                        _gl-floatv ->)
+  (define-foreign-tparm glMap2 (d)
+                        _gl-enum T T _gl-int _gl-int T T _gl-int _gl-int
+                        _gl-doublev ->)
+  (define-foreign-tparm glEvalCoord1 (f d) T ->)
+  (define-foreign-tparm glEvalCoord2 (f d) T T ->)
+  (define-foreign-tparm glEvalCoord1 (fv dv) T ->)
+  (define-foreign-tparm glEvalCoord2 (fv dv) T ->)
+  (define-foreign-tparm glMapGrid1 (f d) _gl-int T T ->)
+  (define-foreign-tparm glMapGrid2 (f d) _gl-int T T _gl-int T T ->)
+  (define-foreign glEvalMesh1 _gl-enum _gl-int _gl-int ->)
+  (define-foreign glEvalMesh2 _gl-enum _gl-int _gl-int _gl-int _gl-int ->)
+  (define-foreign glEvalPoint1 _gl-int ->)
+  (define-foreign glEvalPoint2 _gl-int _gl-int ->)
+  
+  ;; 5.2
+  (define-foreign glInitNames ->)
+  (define-foreign glPopName ->)
+  (define-foreign glPushName _gl-uint ->)
+  (define-foreign glLoadName _gl-uint ->)
+  (define-foreign glRenderMode _gl-enum -> _gl-int)
+  (define-struct select-buffer-object (ptr len))
+  (provide select-buffer->gl-uint-vector)
+  (define (select-buffer->gl-uint-vector sbo)
+    (unless (select-buffer-object? sbo)
+      (raise-type-error 'select-buffer->gl-uint-vector "select-buffer-object" sbo))
+    (let* ((l (select-buffer-object-len sbo))
+           (p (select-buffer-object-ptr sbo))
+           (v (make-gl-uint-vector l)))
+      (let loop ((i 0))
+        (when (< i l)
+          (gl-vector-set! v i (ptr-ref p _gl-uint i))
+          (loop (add1 i))))
+      v))
+  
+  (define-foreign glSelectBuffer
+                  (n : _gl-sizei) (mem : _pointer = (malloc n _gl-uint 'raw)) ->
+                  _void ->
+                  (let ((o (make-select-buffer-object mem n)))
+                    (register-finalizer o (lambda (sbo)
+                                            (free (select-buffer-object-ptr sbo))))
+                    o))
+
+                  
+  ;; 5.3
+  (define-struct feedback-buffer-object (ptr len))
+  (provide feedback-buffer->gl-float-vector)
+  (define (feedback-buffer->gl-float-vector fbo)
+    (unless (feedback-buffer-object? fbo)
+      (raise-type-error 'feedback-buffer->gl-uint-vector "feedback-buffer-object" fbo))
+    (let* ((l (feedback-buffer-object-len fbo))
+           (p (feedback-buffer-object-ptr fbo))
+           (v (make-gl-float-vector l)))
+      (let loop ((i 0))
+        (when (< i l)
+          (gl-vector-set! v i (ptr-ref p _gl-float i))
+          (loop (add1 i))))
+      v))
+  (define-foreign glFeedbackBuffer
+                  (n : _gl-sizei) _gl-enum (mem : _pointer = (malloc _gl-float n 'raw)) ->
+                  _void ->
+                  (let ((o (make-feedback-buffer-object mem n)))
+                    (register-finalizer o (lambda (fbo)
+                                            (free (feedback-buffer-object-ptr fbo))))
+                    o))
+  (define-foreign glPassThrough _gl-float ->)
+  
+  ;; 5.4
+  (define-foreign glNewList _gl-uint _gl-enum ->)
+  (define-foreign glEndList ->)
+  (define-foreign glCallList _gl-uint ->)
+  (define-foreign glCallLists _gl-sizei _gl-enum _gl-voidv ->)
+  (define-foreign glListBase _gl-uint ->)
+  (define-foreign glGenLists _gl-sizei -> _gl-uint)
+  (define-foreign glIsList _gl-uint -> _gl-boolean)
+  (define-foreign glDeleteLists _gl-uint _gl-sizei ->)
+  
+  ;; 5.5
+  (define-foreign glFlush ->)
+  (define-foreign glFinish ->)
+
+  ;; 5.6
+  (define-foreign glHint _gl-enum _gl-enum ->)
+
+  ;; 6.1.1
+  (define-foreign glGetBooleanv
+                  _gl-enum (n : _?) (r : (_cvector o _gl-boolean n)) ->
+                  _void -> r)
+  (define-foreign glGetIntegerv
+                  _gl-enum (n : _?) (r : (_cvector o _gl-int n)) -> _void -> r)
+  (define-foreign glGetFloatv
+                  _gl-enum (n : _?) (r : (_cvector o _gl-float n)) ->
+                  _void -> r)
+  (define-foreign glGetDoublev
+                  _gl-enum (n : _?) (r : (_cvector o _gl-double n)) ->
+                  _void -> r)
+  (define-foreign glIsEnabled _gl-enum -> _gl-boolean)
+  
+  ;; 6.1.3
+  (define-foreign glGetClipPlane
+                  _gl-enum (r : (_cvector o _gl-double 4)) -> _void -> r)
+  (define-foreign-tparm glGetLight (iv fv)
+                        _gl-enum _gl-enum (n : _?) (r : (T n)) -> _void -> r)
+  (define-foreign-tparm glGetMaterial (iv fv)
+                        _gl-enum _gl-enum (n : _?) (r : (T n)) -> _void -> r)
+  (define-foreign-tparm glGetTexEnv (iv fv)
+                        _gl-enum _gl-enum (n : _?) (r : (T n)) -> _void -> r)
+  (define-foreign-tparm glGetTexGen (iv fv dv)
+                        _gl-enum _gl-enum (n : _?) (r : (T n)) -> _void -> r)
+  (define-foreign-tparm glGetTexParameter (iv fv)
+                        _gl-enum _gl-enum (n : _?) (r : (T n)) -> _void -> r)
+  (define-foreign-tparm glGetTexLevelParameter (iv fv)
+                        _gl-enum _gl-int _gl-enum (n : _?) (r : (T n)) ->
+                        _void -> r)
+  (define-foreign-tparm glGetPixelMap (uiv usv fv)
+                        _gl-enum (n : _?) (r : (T n)) -> _void -> r)
+  (define-foreign-tparm glGetMap (iv fv dv)
+                        _gl-enum _gl-enum (n : _?) (r : (T n)) -> _void -> r)
+  (define-foreign-tparm glGetBufferParameter (iv)
+                        _gl-enum _gl-enum (n : _?) (r : (T n)) -> _void -> r)
+
+
+  ;; 6.1.4
+  (define-foreign glGetTexImage _gl-enum _gl-int _gl-enum _gl-enum _gl-voidv ->)
+  (define-foreign glGetCompressedTexImage _gl-enum _gl-int _gl-voidv ->)
+  (define-foreign glIsTexture _gl-uint -> _gl-boolean)
+  
+  ;; 6.1.5
+  (define-foreign glGetPolygonStipple _gl-voidv ->)
+  
+  ;; 6.1.7
+  (define-foreign glGetColorTable _gl-enum _gl-enum _gl-enum _gl-voidv ->)
+  
+  ;; 6.1.8
+  (define-foreign glGetConvolutionFilter
+                  _gl-enum _gl-enum _gl-enum _gl-voidv ->)
+  (define-foreign glGetSeparableFilter
+                  _gl-enum _gl-enum _gl-enum _gl-voidv _gl-voidv _gl-voidv ->)
+  (define-foreign-tparm glGetConvolutionParameter (iv fv)
+                        _gl-enum _gl-enum (n : _?) (r : (T n)) -> _void -> r)
+
+  ;; 6.1.9
+  (define-foreign glGetHistogram
+                  _gl-enum _gl-boolean _gl-enum _gl-enum _gl-voidv ->)
+  (define-foreign glResetHistogram _gl-enum ->)
+  (define-foreign-tparm glGetHistogramParameter (iv fv)
+                        _gl-enum _gl-enum (n : _?) (r : (T n)) -> _void -> r)
+
+  ;; 6.1.10
+  (define-foreign glGetMinmax
+                  _gl-enum _gl-boolean _gl-enum _gl-enum _gl-voidv ->)
+  (define-foreign glResetMinmax _gl-enum ->)
+  (define-foreign-tparm glGetMinmaxParameter (iv fv)
+                        _gl-enum _gl-enum (n : _?) (r : (T n)) -> _void -> r)
+
+  ;; 6.1.11
+  #|
+  (define-foreign glGetPointerv _gl-enum _gl-voidvv ->)
+  |#
+  (define-foreign glGetString _gl-enum -> _string)
+
+  ;; 6.1.12
+  (define-foreign glIsQuery _gl-uint -> _gl-boolean)
+  (define-foreign-tparm glGetQuery (iv)
+                        _gl-enum _gl-enum (n : _?) (r : (T n)) -> _void -> r)
+  (define-foreign-tparm glGetQueryObject (iv uiv)
+                        _gl-uint _gl-enum (n : _?) (r : (T n)) -> _void -> r)
+
+  ;; 6.1.13
+  (define-foreign glIsBuffer _gl-uint -> _gl-boolean)
+  #|
+  (define-foreign glGetBufferSubData
+                  _gl-enum _gl-intptr _gl-sizeiptr _gl-voidv ->)
+  (define-foreign glGetBufferPointerv _gl-enum _gl-enum _gl-voidvv ->)
+  |#
+
+  ;; 6.1.14
+  (define-foreign glPushAttrib _gl-bitfield ->)
+  (define-foreign glPushClientAttrib _gl-bitfield ->)
+  (define-foreign glPopAttrib ->)
+  (define-foreign glPopClientAttrib ->)
+
+  
+  (define-syntax define-foreignu
+    (syntax-rules ()
+      ((_ args ...) (define-foreign-lib glu-lib args ...))))
+  
+  ;; 2
+  (define-foreignu gluGetString _gl-enum -> _string)
+  (define-foreignu gluCheckExtension _string _string -> _gl-boolean)
+  
+  ;; 3.1
+  (define-foreignu gluScaleImage _gl-enum _gl-sizei _gl-sizei _gl-enum _gl-voidv
+                                 _gl-sizei _gl-sizei _gl-enum _gl-voidv ->)
+
+  ;; 3.2
+  (define-foreignu gluBuild1DMipmaps
+                   _gl-enum _gl-int _gl-sizei _gl-enum _gl-enum _gl-voidv ->)
+  (define-foreignu gluBuild2DMipmaps
+                   _gl-enum _gl-int _gl-sizei _gl-sizei _gl-enum _gl-enum
+                   _gl-voidv ->)
+  (define-foreignu gluBuild3DMipmaps
+                   _gl-enum _gl-int _gl-sizei _gl-sizei _gl-sizei 
+                   _gl-enum _gl-enum _gl-voidv ->)
+  (define-foreignu gluBuild1DMipmapLevels
+                   _gl-enum _gl-int _gl-sizei _gl-enum _gl-enum 
+                   _gl-int _gl-int _gl-int _gl-voidv ->)
+  (define-foreignu gluBuild2DMipmapLevels
+                   _gl-enum _gl-int _gl-sizei _gl-sizei _gl-enum _gl-enum
+                   _gl-int _gl-int _gl-int _gl-voidv ->)
+  (define-foreignu gluBuild3DMipmapLevels
+                   _gl-enum _gl-int _gl-sizei _gl-sizei _gl-sizei
+                   _gl-enum _gl-enum _gl-int _gl-int _gl-int _gl-voidv ->)
+
+  ;; 4.1
+  (define-foreignu gluOrtho2D _gl-double _gl-double _gl-double _gl-double ->)
+  (define-foreignu gluPerspective
+                   _gl-double _gl-double _gl-double _gl-double ->)
+  (define-foreignu gluLookAt _gl-double _gl-double _gl-double
+                             _gl-double _gl-double _gl-double
+                             _gl-double _gl-double _gl-double ->)
+  (define-foreignu gluPickMatrix _gl-double _gl-double _gl-double _gl-double _gl-intv ->)
+
+  ;; 4.2
+  (define-foreignu gluProject _gl-double _gl-double _gl-double
+                              _gl-doublev _gl-doublev _gl-intv
+                              (r1 : (_ptr o _gl-double))
+                              (r2 : (_ptr o _gl-double))
+                              (r3 : (_ptr o _gl-double)) ->
+                              _void -> (gl-double-vector r1 r2 r3))
+  (define-foreignu gluUnProject _gl-double _gl-double _gl-double
+                                _gl-doublev _gl-doublev _gl-intv
+                                (r1 : (_ptr o _gl-double))
+                                (r2 : (_ptr o _gl-double))
+                                (r3 : (_ptr o _gl-double)) ->
+                                _void -> (gl-double-vector r1 r2 r3))
+  (define-foreignu gluUnProject4 _gl-double _gl-double _gl-double _gl-double
+                                 _gl-doublev _gl-doublev _gl-intv
+                                 _gl-clampd _gl-clampd
+                                 (r1 : (_ptr o _gl-double))
+                                 (r2 : (_ptr o _gl-double))
+                                 (r3 : (_ptr o _gl-double))
+                                 (r4 : (_ptr o _gl-double)) ->
+                                 _void -> (gl-double-vector r1 r2 r3 r4))
+  
+  ;; 5.1
+  #|
+  (define-foreignu gluNewTess -> _glu-tessalator*)
+  (define-foreignu gluDeleteTess _glu-tessalator* ->)
+  |#
+  
+  ;; 5.2
+  #|
+  (define-foreignu gluTessBeginPolygon _glu-tessalator* _gl-voidv ->)
+  (define-foreignu gluTessBeginContour _glu-tessalator* ->)
+  (define-foreignu gluTessVertex _glu-tessalator* _gl-doublev _gl-voidv ->)
+  (define-foreignu gluTessEndContour _glu-tessalator* ->)
+  (define-foreignu gluTessEndPolygon _glu-tessalator* ->)
+  |#
+  
+  ;; 5.3
+  #|
+  (define-foreignu gluTessCallback _glu-tessalator _gl-enum ??? ->)
+  |#
+
+  ;; 5.4
+  #|
+  (define-foreignu gluTessProperty _glu-tessalator* _gl-enum _gl-double ->)
+  (define-foreignu gluGetTessProperty _glu-tessalator* _gl-enum _gl-doublev ->)
+  (define-foreignu gluTessNormal _glu-tessalator* _gl-double _gl-double _gl-double ->)
+  |#
+
+  ;; 5.7
+  #|
+  (define-foreignu gluBeginPolygon _glu-tessalator* ->)
+  (define-foreignu gluNextContour _glu-tessalator* _gl-enum ->)
+  (define-foreignu gluEndPolygon _glu-tessalator* ->)
+  |#
+
+  ;; 6.1
+  (define _glu-quadric
+    (_cpointer 'quadric _pointer
+               #f
+               (lambda (q*)
+                 (register-finalizer q* gluDeleteQuadric)
+                 q*)))
+  
+  (define-foreignu gluNewQuadric -> _glu-quadric)
+
+  ;; Don't use define-foreign, because this shouldn't be provided
+  (define gluDeleteQuadric
+    (with-handlers ((exn:fail:filesystem?
+                     (lambda (ex)
+                       (lambda x
+                         (error 'gluDeleteQuadric
+                                "unavailable on this system")))))
+      (get-ffi-obj 'gluDeleteQuadric glu-lib (_fun _glu-quadric -> _void))))
+
+  ;; 6.2
+  ;;(define-foreignu gluQuadricCallback
+  ;;                 _glu-quadric (_gl-enum = GLU_ERROR) (_fun _gl-enum -> _void) ->)
+
+  ;; 6.3
+  (define-foreignu gluQuadricNormals _glu-quadric _gl-enum ->)
+  (define-foreignu gluQuadricTexture _glu-quadric _gl-boolean ->)
+  (define-foreignu gluQuadricOrientation _glu-quadric _gl-enum ->)
+  (define-foreignu gluQuadricDrawStyle _glu-quadric _gl-enum ->)
+
+  ;; 6.4
+  (define-foreignu gluSphere _glu-quadric _gl-double _gl-int _gl-int ->)
+  (define-foreignu gluCylinder _glu-quadric _gl-double _gl-double _gl-double
+                               _gl-int _gl-int ->)
+  (define-foreignu gluDisk
+                   _glu-quadric _gl-double _gl-double _gl-int _gl-int ->)
+  (define-foreignu gluPartialDisk
+                   _glu-quadric _gl-double _gl-double _gl-int _gl-int
+                   _gl-double _gl-double ->)
+
+  ;; 7.1
+  #|
+  (define-foreignu gluNewNurbsRenderer -> _glu-nurbs*)
+  (define-foreignu gludeleteNurbsRenderer _glu-nurbs* ->)
+  |#
+  
+  ;; 7.2
+  #|
+  (define-foreignu gluNurbsCallback _glu-nurbs* _gl-enum ??? ->)
+  (define-foreignu gluNurbsCallbackData _glu-nurbs* _gl-voidv ->)
+  |#
+
+  ;; 7.3
+  #|
+  (define-foreignu gluBeginCurve _glu-nurbs* ->)
+  (define-foreignu gluNurbsCurve _glu-nurbs* _gl-int _gl-floatv _gl-int _gl-floatv _gl-int _gl-enum ->)
+  (define-foreignu gluEndCurve _glu-nurbs* ->)
+  |#
+
+  ;; 7.4
+  #|
+  (define-foreignu gluBeginSurface _glu-nurbs* ->)
+  (define-foreignu gluNurbsSurface _glu-nurbs* _gl-int _gl-floatv _gl-int _gl-floatv _gl-int
+                                              _gl-int _gl-floatv _gl-int _gl-int _gl-enum ->)
+  (define-foreignu gluEndSurface _glu-nurbs* ->)
+  |#
+
+  ;; 7.5
+  #|
+  (define-foreignu gluBeginTrim _glu-nurbs* ->)
+  (define-foreignu gluPwlCurve _glu-nurbs* _gl-int _gl-floatv _gl-int _gl-enum ->)
+  (define-foreignu gluEndTrim _glu-nurbs* ->)
+  |#
+
+  ;; 7.6
+  #|
+  (define-foreignu gluNurbsProperty _glu-nurbs* _gl-enum _gl-float ->)
+  (define-foreignu gluLoadSamplingMatrix _glu-nurbs* _gl-floatv _gl-floatv _gl-intv ->)
+  (define-foreignu gluGetNurbsProperty _glu-nurbs* _gl-enum _gl-floatv ->)
+  |#
+
+  ;; 8
+  (define-foreignu gluErrorString _gl-enum -> _string)
+
+
+  (define-syntax define-enum
+    (syntax-rules ()
+      ((_ d v)
+       (begin
+         (provide d)
+         (define d v)))
+      ((_ _ d v)
+       (define-enum d v))))
+  
+  ;; Enumeration constants for version 1.0 and 1.1
+  ;; These values are all taken from MESA's gl.h.
+  ;; Although the standard doesn't define these, they seem to be used on all 
+  ;; platforms.
+  (define-enum GL_FALSE #x0)
+  (define-enum GL_TRUE #x1)
+  (define-enum GL_BYTE #x1400)
+  (define-enum GL_UNSIGNED_BYTE #x1401)
+  (define-enum GL_SHORT #x1402)
+  (define-enum GL_UNSIGNED_SHORT #x1403)
+  (define-enum GL_INT #x1404)
+  (define-enum GL_UNSIGNED_INT #x1405)
+  (define-enum GL_FLOAT #x1406)
+  (define-enum GL_DOUBLE #x140A)
+  (define-enum GL_2_BYTES #x1407)
+  (define-enum GL_3_BYTES #x1408)
+  (define-enum GL_4_BYTES #x1409)
+  (define-enum GL_POINTS #x0000)
+  (define-enum GL_LINES #x0001)
+  (define-enum GL_LINE_LOOP #x0002)
+  (define-enum GL_LINE_STRIP #x0003)
+  (define-enum GL_TRIANGLES #x0004)
+  (define-enum GL_TRIANGLE_STRIP #x0005)
+  (define-enum GL_TRIANGLE_FAN #x0006)
+  (define-enum GL_QUADS #x0007)
+  (define-enum GL_QUAD_STRIP #x0008)
+  (define-enum GL_POLYGON #x0009)
+  (define-enum GL_VERTEX_ARRAY #x8074)
+  (define-enum GL_NORMAL_ARRAY #x8075)
+  (define-enum GL_COLOR_ARRAY #x8076)
+  (define-enum GL_INDEX_ARRAY #x8077)
+  (define-enum GL_TEXTURE_COORD_ARRAY #x8078)
+  (define-enum GL_EDGE_FLAG_ARRAY #x8079)
+  (define-enum GL_VERTEX_ARRAY_SIZE #x807A)
+  (define-enum GL_VERTEX_ARRAY_TYPE #x807B)
+  (define-enum GL_VERTEX_ARRAY_STRIDE #x807C)
+  (define-enum GL_NORMAL_ARRAY_TYPE #x807E)
+  (define-enum GL_NORMAL_ARRAY_STRIDE #x807F)
+  (define-enum GL_COLOR_ARRAY_SIZE #x8081)
+  (define-enum GL_COLOR_ARRAY_TYPE #x8082)
+  (define-enum GL_COLOR_ARRAY_STRIDE #x8083)
+  (define-enum GL_INDEX_ARRAY_TYPE #x8085)
+  (define-enum GL_INDEX_ARRAY_STRIDE #x8086)
+  (define-enum GL_TEXTURE_COORD_ARRAY_SIZE #x8088)
+  (define-enum GL_TEXTURE_COORD_ARRAY_TYPE #x8089)
+  (define-enum GL_TEXTURE_COORD_ARRAY_STRIDE #x808A)
+  (define-enum GL_EDGE_FLAG_ARRAY_STRIDE #x808C)
+  (define-enum GL_VERTEX_ARRAY_POINTER #x808E)
+  (define-enum GL_NORMAL_ARRAY_POINTER #x808F)
+  (define-enum GL_COLOR_ARRAY_POINTER #x8090)
+  (define-enum GL_INDEX_ARRAY_POINTER #x8091)
+  (define-enum GL_TEXTURE_COORD_ARRAY_POINTER #x8092)
+  (define-enum GL_EDGE_FLAG_ARRAY_POINTER #x8093)
+  (define-enum GL_V2F #x2A20)
+  (define-enum GL_V3F #x2A21)
+  (define-enum GL_C4UB_V2F #x2A22)
+  (define-enum GL_C4UB_V3F #x2A23)
+  (define-enum GL_C3F_V3F #x2A24)
+  (define-enum GL_N3F_V3F #x2A25)
+  (define-enum GL_C4F_N3F_V3F #x2A26)
+  (define-enum GL_T2F_V3F #x2A27)
+  (define-enum GL_T4F_V4F #x2A28)
+  (define-enum GL_T2F_C4UB_V3F #x2A29)
+  (define-enum GL_T2F_C3F_V3F #x2A2A)
+  (define-enum GL_T2F_N3F_V3F #x2A2B)
+  (define-enum GL_T2F_C4F_N3F_V3F #x2A2C)
+  (define-enum GL_T4F_C4F_N3F_V4F #x2A2D)
+  (define-enum GL_MATRIX_MODE #x0BA0)
+  (define-enum GL_MODELVIEW #x1700)
+  (define-enum GL_PROJECTION #x1701)
+  (define-enum GL_TEXTURE #x1702)
+  (define-enum GL_POINT_SMOOTH #x0B10)
+  (define-enum GL_POINT_SIZE #x0B11)
+  (define-enum GL_POINT_SIZE_GRANULARITY #x0B13)
+  (define-enum GL_POINT_SIZE_RANGE #x0B12)
+  (define-enum GL_LINE_SMOOTH #x0B20)
+  (define-enum GL_LINE_STIPPLE #x0B24)
+  (define-enum GL_LINE_STIPPLE_PATTERN #x0B25)
+  (define-enum GL_LINE_STIPPLE_REPEAT #x0B26)
+  (define-enum GL_LINE_WIDTH #x0B21)
+  (define-enum GL_LINE_WIDTH_GRANULARITY #x0B23)
+  (define-enum GL_LINE_WIDTH_RANGE #x0B22)
+  (define-enum GL_POINT #x1B00)
+  (define-enum GL_LINE #x1B01)
+  (define-enum GL_FILL #x1B02)
+  (define-enum GL_CW #x0900)
+  (define-enum GL_CCW #x0901)
+  (define-enum GL_FRONT #x0404)
+  (define-enum GL_BACK #x0405)
+  (define-enum GL_POLYGON_MODE #x0B40)
+  (define-enum GL_POLYGON_SMOOTH #x0B41)
+  (define-enum GL_POLYGON_STIPPLE #x0B42)
+  (define-enum GL_EDGE_FLAG #x0B43)
+  (define-enum GL_CULL_FACE #x0B44)
+  (define-enum GL_CULL_FACE_MODE #x0B45)
+  (define-enum GL_FRONT_FACE #x0B46)
+  (define-enum GL_POLYGON_OFFSET_FACTOR #x8038)
+  (define-enum GL_POLYGON_OFFSET_UNITS #x2A00)
+  (define-enum GL_POLYGON_OFFSET_POINT #x2A01)
+  (define-enum GL_POLYGON_OFFSET_LINE #x2A02)
+  (define-enum GL_POLYGON_OFFSET_FILL #x8037)
+  (define-enum GL_COMPILE #x1300)
+  (define-enum GL_COMPILE_AND_EXECUTE #x1301)
+  (define-enum GL_LIST_BASE #x0B32)
+  (define-enum GL_LIST_INDEX #x0B33)
+  (define-enum GL_LIST_MODE #x0B30)
+  (define-enum GL_NEVER #x0200)
+  (define-enum GL_LESS #x0201)
+  (define-enum GL_EQUAL #x0202)
+  (define-enum GL_LEQUAL #x0203)
+  (define-enum GL_GREATER #x0204)
+  (define-enum GL_NOTEQUAL #x0205)
+  (define-enum GL_GEQUAL #x0206)
+  (define-enum GL_ALWAYS #x0207)
+  (define-enum GL_DEPTH_TEST #x0B71)
+  (define-enum GL_DEPTH_BITS #x0D56)
+  (define-enum GL_DEPTH_CLEAR_VALUE #x0B73)
+  (define-enum GL_DEPTH_FUNC #x0B74)
+  (define-enum GL_DEPTH_RANGE #x0B70)
+  (define-enum GL_DEPTH_WRITEMASK #x0B72)
+  (define-enum GL_DEPTH_COMPONENT #x1902)
+  (define-enum GL_LIGHTING #x0B50)
+  (define-enum GL_LIGHT0 #x4000)
+  (define-enum GL_LIGHT1 #x4001)
+  (define-enum GL_LIGHT2 #x4002)
+  (define-enum GL_LIGHT3 #x4003)
+  (define-enum GL_LIGHT4 #x4004)
+  (define-enum GL_LIGHT5 #x4005)
+  (define-enum GL_LIGHT6 #x4006)
+  (define-enum GL_LIGHT7 #x4007)
+  (define-enum GL_SPOT_EXPONENT #x1205)
+  (define-enum GL_SPOT_CUTOFF #x1206)
+  (define-enum GL_CONSTANT_ATTENUATION #x1207)
+  (define-enum GL_LINEAR_ATTENUATION #x1208)
+  (define-enum GL_QUADRATIC_ATTENUATION #x1209)
+  (define-enum GL_AMBIENT #x1200)
+  (define-enum GL_DIFFUSE #x1201)
+  (define-enum GL_SPECULAR #x1202)
+  (define-enum GL_SHININESS #x1601)
+  (define-enum GL_EMISSION #x1600)
+  (define-enum GL_POSITION #x1203)
+  (define-enum GL_SPOT_DIRECTION #x1204)
+  (define-enum GL_AMBIENT_AND_DIFFUSE #x1602)
+  (define-enum GL_COLOR_INDEXES #x1603)
+  (define-enum GL_LIGHT_MODEL_TWO_SIDE #x0B52)
+  (define-enum GL_LIGHT_MODEL_LOCAL_VIEWER #x0B51)
+  (define-enum GL_LIGHT_MODEL_AMBIENT #x0B53)
+  (define-enum GL_FRONT_AND_BACK #x0408)
+  (define-enum GL_SHADE_MODEL #x0B54)
+  (define-enum GL_FLAT #x1D00)
+  (define-enum GL_SMOOTH #x1D01)
+  (define-enum GL_COLOR_MATERIAL #x0B57)
+  (define-enum GL_COLOR_MATERIAL_FACE #x0B55)
+  (define-enum GL_COLOR_MATERIAL_PARAMETER #x0B56)
+  (define-enum GL_NORMALIZE #x0BA1)
+  (define-enum GL_CLIP_PLANE0 #x3000)
+  (define-enum GL_CLIP_PLANE1 #x3001)
+  (define-enum GL_CLIP_PLANE2 #x3002)
+  (define-enum GL_CLIP_PLANE3 #x3003)
+  (define-enum GL_CLIP_PLANE4 #x3004)
+  (define-enum GL_CLIP_PLANE5 #x3005)
+  (define-enum GL_ACCUM_RED_BITS #x0D58)
+  (define-enum GL_ACCUM_GREEN_BITS #x0D59)
+  (define-enum GL_ACCUM_BLUE_BITS #x0D5A)
+  (define-enum GL_ACCUM_ALPHA_BITS #x0D5B)
+  (define-enum GL_ACCUM_CLEAR_VALUE #x0B80)
+  (define-enum GL_ACCUM #x0100)
+  (define-enum GL_ADD #x0104)
+  (define-enum GL_LOAD #x0101)
+  (define-enum GL_MULT #x0103)
+  (define-enum GL_RETURN #x0102)
+  (define-enum GL_ALPHA_TEST #x0BC0)
+  (define-enum GL_ALPHA_TEST_REF #x0BC2)
+  (define-enum GL_ALPHA_TEST_FUNC #x0BC1)
+  (define-enum GL_BLEND #x0BE2)
+  (define-enum GL_BLEND_SRC #x0BE1)
+  (define-enum GL_BLEND_DST #x0BE0)
+  (define-enum GL_ZERO #x0)
+  (define-enum GL_ONE #x1)
+  (define-enum GL_SRC_COLOR #x0300)
+  (define-enum GL_ONE_MINUS_SRC_COLOR #x0301)
+  (define-enum GL_SRC_ALPHA #x0302)
+  (define-enum GL_ONE_MINUS_SRC_ALPHA #x0303)
+  (define-enum GL_DST_ALPHA #x0304)
+  (define-enum GL_ONE_MINUS_DST_ALPHA #x0305)
+  (define-enum GL_DST_COLOR #x0306)
+  (define-enum GL_ONE_MINUS_DST_COLOR #x0307)
+  (define-enum GL_SRC_ALPHA_SATURATE #x0308)
+  (define-enum GL_FEEDBACK #x1C01)
+  (define-enum GL_RENDER #x1C00)
+  (define-enum GL_SELECT #x1C02)
+  (define-enum GL_2D #x0600)
+  (define-enum GL_3D #x0601)
+  (define-enum GL_3D_COLOR #x0602)
+  (define-enum GL_3D_COLOR_TEXTURE #x0603)
+  (define-enum GL_4D_COLOR_TEXTURE #x0604)
+  (define-enum GL_POINT_TOKEN #x0701)
+  (define-enum GL_LINE_TOKEN #x0702)
+  (define-enum GL_LINE_RESET_TOKEN #x0707)
+  (define-enum GL_POLYGON_TOKEN #x0703)
+  (define-enum GL_BITMAP_TOKEN #x0704)
+  (define-enum GL_DRAW_PIXEL_TOKEN #x0705)
+  (define-enum GL_COPY_PIXEL_TOKEN #x0706)
+  (define-enum GL_PASS_THROUGH_TOKEN #x0700)
+  (define-enum GL_FEEDBACK_BUFFER_POINTER #x0DF0)
+  (define-enum GL_FEEDBACK_BUFFER_SIZE #x0DF1)
+  (define-enum GL_FEEDBACK_BUFFER_TYPE #x0DF2)
+  (define-enum GL_SELECTION_BUFFER_POINTER #x0DF3)
+  (define-enum GL_SELECTION_BUFFER_SIZE #x0DF4)
+  (define-enum GL_FOG #x0B60)
+  (define-enum GL_FOG_MODE #x0B65)
+  (define-enum GL_FOG_DENSITY #x0B62)
+  (define-enum GL_FOG_COLOR #x0B66)
+  (define-enum GL_FOG_INDEX #x0B61)
+  (define-enum GL_FOG_START #x0B63)
+  (define-enum GL_FOG_END #x0B64)
+  (define-enum GL_LINEAR #x2601)
+  (define-enum GL_EXP #x0800)
+  (define-enum GL_EXP2 #x0801)
+  (define-enum GL_LOGIC_OP #x0BF1)
+  (define-enum GL_INDEX_LOGIC_OP #x0BF1)
+  (define-enum GL_COLOR_LOGIC_OP #x0BF2)
+  (define-enum GL_LOGIC_OP_MODE #x0BF0)
+  (define-enum GL_CLEAR #x1500)
+  (define-enum GL_SET #x150F)
+  (define-enum GL_COPY #x1503)
+  (define-enum GL_COPY_INVERTED #x150C)
+  (define-enum GL_NOOP #x1505)
+  (define-enum GL_INVERT #x150A)
+  (define-enum GL_AND #x1501)
+  (define-enum GL_NAND #x150E)
+  (define-enum GL_OR #x1507)
+  (define-enum GL_NOR #x1508)
+  (define-enum GL_XOR #x1506)
+  (define-enum GL_EQUIV #x1509)
+  (define-enum GL_AND_REVERSE #x1502)
+  (define-enum GL_AND_INVERTED #x1504)
+  (define-enum GL_OR_REVERSE #x150B)
+  (define-enum GL_OR_INVERTED #x150D)
+  (define-enum GL_STENCIL_TEST #x0B90)
+  (define-enum GL_STENCIL_WRITEMASK #x0B98)
+  (define-enum GL_STENCIL_BITS #x0D57)
+  (define-enum GL_STENCIL_FUNC #x0B92)
+  (define-enum GL_STENCIL_VALUE_MASK #x0B93)
+  (define-enum GL_STENCIL_REF #x0B97)
+  (define-enum GL_STENCIL_FAIL #x0B94)
+  (define-enum GL_STENCIL_PASS_DEPTH_PASS #x0B96)
+  (define-enum GL_STENCIL_PASS_DEPTH_FAIL #x0B95)
+  (define-enum GL_STENCIL_CLEAR_VALUE #x0B91)
+  (define-enum GL_STENCIL_INDEX #x1901)
+  (define-enum GL_KEEP #x1E00)
+  (define-enum GL_REPLACE #x1E01)
+  (define-enum GL_INCR #x1E02)
+  (define-enum GL_DECR #x1E03)
+  (define-enum GL_NONE #x0)
+  (define-enum GL_LEFT #x0406)
+  (define-enum GL_RIGHT #x0407)
+  (define-enum GL_FRONT_LEFT #x0400)
+  (define-enum GL_FRONT_RIGHT #x0401)
+  (define-enum GL_BACK_LEFT #x0402)
+  (define-enum GL_BACK_RIGHT #x0403)
+  (define-enum GL_AUX0 #x0409)
+  (define-enum GL_AUX1 #x040A)
+  (define-enum GL_AUX2 #x040B)
+  (define-enum GL_AUX3 #x040C)
+  (define-enum GL_COLOR_INDEX #x1900)
+  (define-enum GL_RED #x1903)
+  (define-enum GL_GREEN #x1904)
+  (define-enum GL_BLUE #x1905)
+  (define-enum GL_ALPHA #x1906)
+  (define-enum GL_LUMINANCE #x1909)
+  (define-enum GL_LUMINANCE_ALPHA #x190A)
+  (define-enum GL_ALPHA_BITS #x0D55)
+  (define-enum GL_RED_BITS #x0D52)
+  (define-enum GL_GREEN_BITS #x0D53)
+  (define-enum GL_BLUE_BITS #x0D54)
+  (define-enum GL_INDEX_BITS #x0D51)
+  (define-enum GL_SUBPIXEL_BITS #x0D50)
+  (define-enum GL_AUX_BUFFERS #x0C00)
+  (define-enum GL_READ_BUFFER #x0C02)
+  (define-enum GL_DRAW_BUFFER #x0C01)
+  (define-enum GL_DOUBLEBUFFER #x0C32)
+  (define-enum GL_STEREO #x0C33)
+  (define-enum GL_BITMAP #x1A00)
+  (define-enum GL_COLOR #x1800)
+  (define-enum GL_DEPTH #x1801)
+  (define-enum GL_STENCIL #x1802)
+  (define-enum GL_DITHER #x0BD0)
+  (define-enum GL_RGB #x1907)
+  (define-enum GL_RGBA #x1908)
+  (define-enum GL_MAX_LIST_NESTING #x0B31)
+  (define-enum GL_MAX_ATTRIB_STACK_DEPTH #x0D35)
+  (define-enum GL_MAX_MODELVIEW_STACK_DEPTH #x0D36)
+  (define-enum GL_MAX_NAME_STACK_DEPTH #x0D37)
+  (define-enum GL_MAX_PROJECTION_STACK_DEPTH #x0D38)
+  (define-enum GL_MAX_TEXTURE_STACK_DEPTH #x0D39)
+  (define-enum GL_MAX_EVAL_ORDER #x0D30)
+  (define-enum GL_MAX_LIGHTS #x0D31)
+  (define-enum GL_MAX_CLIP_PLANES #x0D32)
+  (define-enum GL_MAX_TEXTURE_SIZE #x0D33)
+  (define-enum GL_MAX_PIXEL_MAP_TABLE #x0D34)
+  (define-enum GL_MAX_VIEWPORT_DIMS #x0D3A)
+  (define-enum GL_MAX_CLIENT_ATTRIB_STACK_DEPTH #x0D3B)
+  (define-enum GL_ATTRIB_STACK_DEPTH #x0BB0)
+  (define-enum GL_CLIENT_ATTRIB_STACK_DEPTH #x0BB1)
+  (define-enum GL_COLOR_CLEAR_VALUE #x0C22)
+  (define-enum GL_COLOR_WRITEMASK #x0C23)
+  (define-enum GL_CURRENT_INDEX #x0B01)
+  (define-enum GL_CURRENT_COLOR #x0B00)
+  (define-enum GL_CURRENT_NORMAL #x0B02)
+  (define-enum GL_CURRENT_RASTER_COLOR #x0B04)
+  (define-enum GL_CURRENT_RASTER_DISTANCE #x0B09)
+  (define-enum GL_CURRENT_RASTER_INDEX #x0B05)
+  (define-enum GL_CURRENT_RASTER_POSITION #x0B07)
+  (define-enum GL_CURRENT_RASTER_TEXTURE_COORDS #x0B06)
+  (define-enum GL_CURRENT_RASTER_POSITION_VALID #x0B08)
+  (define-enum GL_CURRENT_TEXTURE_COORDS #x0B03)
+  (define-enum GL_INDEX_CLEAR_VALUE #x0C20)
+  (define-enum GL_INDEX_MODE #x0C30)
+  (define-enum GL_INDEX_WRITEMASK #x0C21)
+  (define-enum GL_MODELVIEW_MATRIX #x0BA6)
+  (define-enum GL_MODELVIEW_STACK_DEPTH #x0BA3)
+  (define-enum GL_NAME_STACK_DEPTH #x0D70)
+  (define-enum GL_PROJECTION_MATRIX #x0BA7)
+  (define-enum GL_PROJECTION_STACK_DEPTH #x0BA4)
+  (define-enum GL_RENDER_MODE #x0C40)
+  (define-enum GL_RGBA_MODE #x0C31)
+  (define-enum GL_TEXTURE_MATRIX #x0BA8)
+  (define-enum GL_TEXTURE_STACK_DEPTH #x0BA5)
+  (define-enum GL_VIEWPORT #x0BA2)
+  (define-enum GL_AUTO_NORMAL #x0D80)
+  (define-enum GL_MAP1_COLOR_4 #x0D90)
+  (define-enum GL_MAP1_GRID_DOMAIN #x0DD0)
+  (define-enum GL_MAP1_GRID_SEGMENTS #x0DD1)
+  (define-enum GL_MAP1_INDEX #x0D91)
+  (define-enum GL_MAP1_NORMAL #x0D92)
+  (define-enum GL_MAP1_TEXTURE_COORD_1 #x0D93)
+  (define-enum GL_MAP1_TEXTURE_COORD_2 #x0D94)
+  (define-enum GL_MAP1_TEXTURE_COORD_3 #x0D95)
+  (define-enum GL_MAP1_TEXTURE_COORD_4 #x0D96)
+  (define-enum GL_MAP1_VERTEX_3 #x0D97)
+  (define-enum GL_MAP1_VERTEX_4 #x0D98)
+  (define-enum GL_MAP2_COLOR_4 #x0DB0)
+  (define-enum GL_MAP2_GRID_DOMAIN #x0DD2)
+  (define-enum GL_MAP2_GRID_SEGMENTS #x0DD3)
+  (define-enum GL_MAP2_INDEX #x0DB1)
+  (define-enum GL_MAP2_NORMAL #x0DB2)
+  (define-enum GL_MAP2_TEXTURE_COORD_1 #x0DB3)
+  (define-enum GL_MAP2_TEXTURE_COORD_2 #x0DB4)
+  (define-enum GL_MAP2_TEXTURE_COORD_3 #x0DB5)
+  (define-enum GL_MAP2_TEXTURE_COORD_4 #x0DB6)
+  (define-enum GL_MAP2_VERTEX_3 #x0DB7)
+  (define-enum GL_MAP2_VERTEX_4 #x0DB8)
+  (define-enum GL_COEFF #x0A00)
+  (define-enum GL_DOMAIN #x0A02)
+  (define-enum GL_ORDER #x0A01)
+  (define-enum GL_FOG_HINT #x0C54)
+  (define-enum GL_LINE_SMOOTH_HINT #x0C52)
+  (define-enum GL_PERSPECTIVE_CORRECTION_HINT #x0C50)
+  (define-enum GL_POINT_SMOOTH_HINT #x0C51)
+  (define-enum GL_POLYGON_SMOOTH_HINT #x0C53)
+  (define-enum GL_DONT_CARE #x1100)
+  (define-enum GL_FASTEST #x1101)
+  (define-enum GL_NICEST #x1102)
+  (define-enum GL_SCISSOR_TEST #x0C11)
+  (define-enum GL_SCISSOR_BOX #x0C10)
+  (define-enum GL_MAP_COLOR #x0D10)
+  (define-enum GL_MAP_STENCIL #x0D11)
+  (define-enum GL_INDEX_SHIFT #x0D12)
+  (define-enum GL_INDEX_OFFSET #x0D13)
+  (define-enum GL_RED_SCALE #x0D14)
+  (define-enum GL_RED_BIAS #x0D15)
+  (define-enum GL_GREEN_SCALE #x0D18)
+  (define-enum GL_GREEN_BIAS #x0D19)
+  (define-enum GL_BLUE_SCALE #x0D1A)
+  (define-enum GL_BLUE_BIAS #x0D1B)
+  (define-enum GL_ALPHA_SCALE #x0D1C)
+  (define-enum GL_ALPHA_BIAS #x0D1D)
+  (define-enum GL_DEPTH_SCALE #x0D1E)
+  (define-enum GL_DEPTH_BIAS #x0D1F)
+  (define-enum GL_PIXEL_MAP_S_TO_S_SIZE #x0CB1)
+  (define-enum GL_PIXEL_MAP_I_TO_I_SIZE #x0CB0)
+  (define-enum GL_PIXEL_MAP_I_TO_R_SIZE #x0CB2)
+  (define-enum GL_PIXEL_MAP_I_TO_G_SIZE #x0CB3)
+  (define-enum GL_PIXEL_MAP_I_TO_B_SIZE #x0CB4)
+  (define-enum GL_PIXEL_MAP_I_TO_A_SIZE #x0CB5)
+  (define-enum GL_PIXEL_MAP_R_TO_R_SIZE #x0CB6)
+  (define-enum GL_PIXEL_MAP_G_TO_G_SIZE #x0CB7)
+  (define-enum GL_PIXEL_MAP_B_TO_B_SIZE #x0CB8)
+  (define-enum GL_PIXEL_MAP_A_TO_A_SIZE #x0CB9)
+  (define-enum GL_PIXEL_MAP_S_TO_S #x0C71)
+  (define-enum GL_PIXEL_MAP_I_TO_I #x0C70)
+  (define-enum GL_PIXEL_MAP_I_TO_R #x0C72)
+  (define-enum GL_PIXEL_MAP_I_TO_G #x0C73)
+  (define-enum GL_PIXEL_MAP_I_TO_B #x0C74)
+  (define-enum GL_PIXEL_MAP_I_TO_A #x0C75)
+  (define-enum GL_PIXEL_MAP_R_TO_R #x0C76)
+  (define-enum GL_PIXEL_MAP_G_TO_G #x0C77)
+  (define-enum GL_PIXEL_MAP_B_TO_B #x0C78)
+  (define-enum GL_PIXEL_MAP_A_TO_A #x0C79)
+  (define-enum GL_PACK_ALIGNMENT #x0D05)
+  (define-enum GL_PACK_LSB_FIRST #x0D01)
+  (define-enum GL_PACK_ROW_LENGTH #x0D02)
+  (define-enum GL_PACK_SKIP_PIXELS #x0D04)
+  (define-enum GL_PACK_SKIP_ROWS #x0D03)
+  (define-enum GL_PACK_SWAP_BYTES #x0D00)
+  (define-enum GL_UNPACK_ALIGNMENT #x0CF5)
+  (define-enum GL_UNPACK_LSB_FIRST #x0CF1)
+  (define-enum GL_UNPACK_ROW_LENGTH #x0CF2)
+  (define-enum GL_UNPACK_SKIP_PIXELS #x0CF4)
+  (define-enum GL_UNPACK_SKIP_ROWS #x0CF3)
+  (define-enum GL_UNPACK_SWAP_BYTES #x0CF0)
+  (define-enum GL_ZOOM_X #x0D16)
+  (define-enum GL_ZOOM_Y #x0D17)
+  (define-enum GL_TEXTURE_ENV #x2300)
+  (define-enum GL_TEXTURE_ENV_MODE #x2200)
+  (define-enum GL_TEXTURE_1D #x0DE0)
+  (define-enum GL_TEXTURE_2D #x0DE1)
+  (define-enum GL_TEXTURE_WRAP_S #x2802)
+  (define-enum GL_TEXTURE_WRAP_T #x2803)
+  (define-enum GL_TEXTURE_MAG_FILTER #x2800)
+  (define-enum GL_TEXTURE_MIN_FILTER #x2801)
+  (define-enum GL_TEXTURE_ENV_COLOR #x2201)
+  (define-enum GL_TEXTURE_GEN_S #x0C60)
+  (define-enum GL_TEXTURE_GEN_T #x0C61)
+  (define-enum GL_TEXTURE_GEN_MODE #x2500)
+  (define-enum GL_TEXTURE_BORDER_COLOR #x1004)
+  (define-enum GL_TEXTURE_WIDTH #x1000)
+  (define-enum GL_TEXTURE_HEIGHT #x1001)
+  (define-enum GL_TEXTURE_BORDER #x1005)
+  (define-enum GL_TEXTURE_COMPONENTS #x1003)
+  (define-enum GL_TEXTURE_RED_SIZE #x805C)
+  (define-enum GL_TEXTURE_GREEN_SIZE #x805D)
+  (define-enum GL_TEXTURE_BLUE_SIZE #x805E)
+  (define-enum GL_TEXTURE_ALPHA_SIZE #x805F)
+  (define-enum GL_TEXTURE_LUMINANCE_SIZE #x8060)
+  (define-enum GL_TEXTURE_INTENSITY_SIZE #x8061)
+  (define-enum GL_NEAREST_MIPMAP_NEAREST #x2700)
+  (define-enum GL_NEAREST_MIPMAP_LINEAR #x2702)
+  (define-enum GL_LINEAR_MIPMAP_NEAREST #x2701)
+  (define-enum GL_LINEAR_MIPMAP_LINEAR #x2703)
+  (define-enum GL_OBJECT_LINEAR #x2401)
+  (define-enum GL_OBJECT_PLANE #x2501)
+  (define-enum GL_EYE_LINEAR #x2400)
+  (define-enum GL_EYE_PLANE #x2502)
+  (define-enum GL_SPHERE_MAP #x2402)
+  (define-enum GL_DECAL #x2101)
+  (define-enum GL_MODULATE #x2100)
+  (define-enum GL_NEAREST #x2600)
+  (define-enum GL_REPEAT #x2901)
+  (define-enum GL_CLAMP #x2900)
+  (define-enum GL_S #x2000)
+  (define-enum GL_T #x2001)
+  (define-enum GL_R #x2002)
+  (define-enum GL_Q #x2003)
+  (define-enum GL_TEXTURE_GEN_R #x0C62)
+  (define-enum GL_TEXTURE_GEN_Q #x0C63)
+  (define-enum GL_VENDOR #x1F00)
+  (define-enum GL_RENDERER #x1F01)
+  (define-enum GL_VERSION #x1F02)
+  (define-enum GL_EXTENSIONS #x1F03)
+  (define-enum GL_NO_ERROR #x0)
+  (define-enum GL_INVALID_VALUE #x0501)
+  (define-enum GL_INVALID_ENUM #x0500)
+  (define-enum GL_INVALID_OPERATION #x0502)
+  (define-enum GL_STACK_OVERFLOW #x0503)
+  (define-enum GL_STACK_UNDERFLOW #x0504)
+  (define-enum GL_OUT_OF_MEMORY #x0505)
+  (define-enum GL_CURRENT_BIT #x00000001)
+  (define-enum GL_POINT_BIT #x00000002)
+  (define-enum GL_LINE_BIT #x00000004)
+  (define-enum GL_POLYGON_BIT #x00000008)
+  (define-enum GL_POLYGON_STIPPLE_BIT #x00000010)
+  (define-enum GL_PIXEL_MODE_BIT #x00000020)
+  (define-enum GL_LIGHTING_BIT #x00000040)
+  (define-enum GL_FOG_BIT #x00000080)
+  (define-enum GL_DEPTH_BUFFER_BIT #x00000100)
+  (define-enum GL_ACCUM_BUFFER_BIT #x00000200)
+  (define-enum GL_STENCIL_BUFFER_BIT #x00000400)
+  (define-enum GL_VIEWPORT_BIT #x00000800)
+  (define-enum GL_TRANSFORM_BIT #x00001000)
+  (define-enum GL_ENABLE_BIT #x00002000)
+  (define-enum GL_COLOR_BUFFER_BIT #x00004000)
+  (define-enum GL_HINT_BIT #x00008000)
+  (define-enum GL_EVAL_BIT #x00010000)
+  (define-enum GL_LIST_BIT #x00020000)
+  (define-enum GL_TEXTURE_BIT #x00040000)
+  (define-enum GL_SCISSOR_BIT #x00080000)
+  (define-enum GL_ALL_ATTRIB_BITS #x000FFFFF)
+  (define-enum GL_PROXY_TEXTURE_1D #x8063)
+  (define-enum GL_PROXY_TEXTURE_2D #x8064)
+  (define-enum GL_TEXTURE_PRIORITY #x8066)
+  (define-enum GL_TEXTURE_RESIDENT #x8067)
+  (define-enum GL_TEXTURE_BINDING_1D #x8068)
+  (define-enum GL_TEXTURE_BINDING_2D #x8069)
+  (define-enum GL_TEXTURE_INTERNAL_FORMAT #x1003)
+  (define-enum GL_ALPHA4 #x803B)
+  (define-enum GL_ALPHA8 #x803C)
+  (define-enum GL_ALPHA12 #x803D)
+  (define-enum GL_ALPHA16 #x803E)
+  (define-enum GL_LUMINANCE4 #x803F)
+  (define-enum GL_LUMINANCE8 #x8040)
+  (define-enum GL_LUMINANCE12 #x8041)
+  (define-enum GL_LUMINANCE16 #x8042)
+  (define-enum GL_LUMINANCE4_ALPHA4 #x8043)
+  (define-enum GL_LUMINANCE6_ALPHA2 #x8044)
+  (define-enum GL_LUMINANCE8_ALPHA8 #x8045)
+  (define-enum GL_LUMINANCE12_ALPHA4 #x8046)
+  (define-enum GL_LUMINANCE12_ALPHA12 #x8047)
+  (define-enum GL_LUMINANCE16_ALPHA16 #x8048)
+  (define-enum GL_INTENSITY #x8049)
+  (define-enum GL_INTENSITY4 #x804A)
+  (define-enum GL_INTENSITY8 #x804B)
+  (define-enum GL_INTENSITY12 #x804C)
+  (define-enum GL_INTENSITY16 #x804D)
+  (define-enum GL_R3_G3_B2 #x2A10)
+  (define-enum GL_RGB4 #x804F)
+  (define-enum GL_RGB5 #x8050)
+  (define-enum GL_RGB8 #x8051)
+  (define-enum GL_RGB10 #x8052)
+  (define-enum GL_RGB12 #x8053)
+  (define-enum GL_RGB16 #x8054)
+  (define-enum GL_RGBA2 #x8055)
+  (define-enum GL_RGBA4 #x8056)
+  (define-enum GL_RGB5_A1 #x8057)
+  (define-enum GL_RGBA8 #x8058)
+  (define-enum GL_RGB10_A2 #x8059)
+  (define-enum GL_RGBA12 #x805A)
+  (define-enum GL_RGBA16 #x805B)
+  (define-enum GL_CLIENT_PIXEL_STORE_BIT #x00000001)
+  (define-enum GL_CLIENT_VERTEX_ARRAY_BIT #x00000002)
+  (define-enum GL_ALL_CLIENT_ATTRIB_BITS #xFFFFFFFF)
+  (define-enum GL_CLIENT_ALL_ATTRIB_BITS #xFFFFFFFF)
+  
+  ;; These values are taken from SGI's glext.h.
+  (define-enum 12 GL_UNSIGNED_BYTE_3_3_2 #x8032)
+  (define-enum 12 GL_UNSIGNED_SHORT_4_4_4_4 #x8033)
+  (define-enum 12 GL_UNSIGNED_SHORT_5_5_5_1 #x8034)
+  (define-enum 12 GL_UNSIGNED_INT_8_8_8_8 #x8035)
+  (define-enum 12 GL_UNSIGNED_INT_10_10_10_2 #x8036)
+  (define-enum 12 GL_RESCALE_NORMAL #x803A)
+  (define-enum 12 GL_TEXTURE_BINDING_3D #x806A)
+  (define-enum 12 GL_PACK_SKIP_IMAGES #x806B)
+  (define-enum 12 GL_PACK_IMAGE_HEIGHT #x806C)
+  (define-enum 12 GL_UNPACK_SKIP_IMAGES #x806D)
+  (define-enum 12 GL_UNPACK_IMAGE_HEIGHT #x806E)
+  (define-enum 12 GL_TEXTURE_3D #x806F)
+  (define-enum 12 GL_PROXY_TEXTURE_3D #x8070)
+  (define-enum 12 GL_TEXTURE_DEPTH #x8071)
+  (define-enum 12 GL_TEXTURE_WRAP_R #x8072)
+  (define-enum 12 GL_MAX_3D_TEXTURE_SIZE #x8073)
+  (define-enum 12 GL_UNSIGNED_BYTE_2_3_3_REV #x8362)
+  (define-enum 12 GL_UNSIGNED_SHORT_5_6_5 #x8363)
+  (define-enum 12 GL_UNSIGNED_SHORT_5_6_5_REV #x8364)
+  (define-enum 12 GL_UNSIGNED_SHORT_4_4_4_4_REV #x8365)
+  (define-enum 12 GL_UNSIGNED_SHORT_1_5_5_5_REV #x8366)
+  (define-enum 12 GL_UNSIGNED_INT_8_8_8_8_REV #x8367)
+  (define-enum 12 GL_UNSIGNED_INT_2_10_10_10_REV #x8368)
+  (define-enum 12 GL_BGR #x80E0)
+  (define-enum 12 GL_BGRA #x80E1)
+  (define-enum 12 GL_MAX_ELEMENTS_VERTICES #x80E8)
+  (define-enum 12 GL_MAX_ELEMENTS_INDICES #x80E9)
+  (define-enum 12 GL_CLAMP_TO_EDGE #x812F)
+  (define-enum 12 GL_TEXTURE_MIN_LOD #x813A)
+  (define-enum 12 GL_TEXTURE_MAX_LOD #x813B)
+  (define-enum 12 GL_TEXTURE_BASE_LEVEL #x813C)
+  (define-enum 12 GL_TEXTURE_MAX_LEVEL #x813D)
+  (define-enum 12 GL_LIGHT_MODEL_COLOR_CONTROL #x81F8)
+  (define-enum 12 GL_SINGLE_COLOR #x81F9)
+  (define-enum 12 GL_SEPARATE_SPECULAR_COLOR #x81FA)
+  (define-enum 12 GL_SMOOTH_POINT_SIZE_RANGE #x0B12)
+  (define-enum 12 GL_SMOOTH_POINT_SIZE_GRANULARITY #x0B13)
+  (define-enum 12 GL_SMOOTH_LINE_WIDTH_RANGE #x0B22)
+  (define-enum 12 GL_SMOOTH_LINE_WIDTH_GRANULARITY #x0B23)
+  (define-enum 12 GL_ALIASED_POINT_SIZE_RANGE #x846D)
+  (define-enum 12 GL_ALIASED_LINE_WIDTH_RANGE #x846E)
+  
+  (define-enum 'img GL_CONSTANT_COLOR #x8001)
+  (define-enum 'img GL_ONE_MINUS_CONSTANT_COLOR #x8002)
+  (define-enum 'img GL_CONSTANT_ALPHA #x8003)
+  (define-enum 'img GL_ONE_MINUS_CONSTANT_ALPHA #x8004)
+  (define-enum 'img GL_BLEND_COLOR #x8005)
+  (define-enum 'img GL_FUNC_ADD #x8006)
+  (define-enum 'img GL_MIN #x8007)
+  (define-enum 'img GL_MAX #x8008)
+  (define-enum 'img GL_BLEND_EQUATION #x8009)
+  (define-enum 'img GL_FUNC_SUBTRACT #x800A)
+  (define-enum 'img GL_FUNC_REVERSE_SUBTRACT #x800B)
+  (define-enum 'img GL_CONVOLUTION_1D #x8010)
+  (define-enum 'img GL_CONVOLUTION_2D #x8011)
+  (define-enum 'img GL_SEPARABLE_2D #x8012)
+  (define-enum 'img GL_CONVOLUTION_BORDER_MODE #x8013)
+  (define-enum 'img GL_CONVOLUTION_FILTER_SCALE #x8014)
+  (define-enum 'img GL_CONVOLUTION_FILTER_BIAS #x8015)
+  (define-enum 'img GL_REDUCE #x8016)
+  (define-enum 'img GL_CONVOLUTION_FORMAT #x8017)
+  (define-enum 'img GL_CONVOLUTION_WIDTH #x8018)
+  (define-enum 'img GL_CONVOLUTION_HEIGHT #x8019)
+  (define-enum 'img GL_MAX_CONVOLUTION_WIDTH #x801A)
+  (define-enum 'img GL_MAX_CONVOLUTION_HEIGHT #x801B)
+  (define-enum 'img GL_POST_CONVOLUTION_RED_SCALE #x801C)
+  (define-enum 'img GL_POST_CONVOLUTION_GREEN_SCALE #x801D)
+  (define-enum 'img GL_POST_CONVOLUTION_BLUE_SCALE #x801E)
+  (define-enum 'img GL_POST_CONVOLUTION_ALPHA_SCALE #x801F)
+  (define-enum 'img GL_POST_CONVOLUTION_RED_BIAS #x8020)
+  (define-enum 'img GL_POST_CONVOLUTION_GREEN_BIAS #x8021)
+  (define-enum 'img GL_POST_CONVOLUTION_BLUE_BIAS #x8022)
+  (define-enum 'img GL_POST_CONVOLUTION_ALPHA_BIAS #x8023)
+  (define-enum 'img GL_HISTOGRAM #x8024)
+  (define-enum 'img GL_PROXY_HISTOGRAM #x8025)
+  (define-enum 'img GL_HISTOGRAM_WIDTH #x8026)
+  (define-enum 'img GL_HISTOGRAM_FORMAT #x8027)
+  (define-enum 'img GL_HISTOGRAM_RED_SIZE #x8028)
+  (define-enum 'img GL_HISTOGRAM_GREEN_SIZE #x8029)
+  (define-enum 'img GL_HISTOGRAM_BLUE_SIZE #x802A)
+  (define-enum 'img GL_HISTOGRAM_ALPHA_SIZE #x802B)
+  (define-enum 'img GL_HISTOGRAM_LUMINANCE_SIZE #x802C)
+  (define-enum 'img GL_HISTOGRAM_SINK #x802D)
+  (define-enum 'img GL_MINMAX #x802E)
+  (define-enum 'img GL_MINMAX_FORMAT #x802F)
+  (define-enum 'img GL_MINMAX_SINK #x8030)
+  (define-enum 'img GL_TABLE_TOO_LARGE #x8031)
+  (define-enum 'img GL_COLOR_MATRIX #x80B1)
+  (define-enum 'img GL_COLOR_MATRIX_STACK_DEPTH #x80B2)
+  (define-enum 'img GL_MAX_COLOR_MATRIX_STACK_DEPTH #x80B3)
+  (define-enum 'img GL_POST_COLOR_MATRIX_RED_SCALE #x80B4)
+  (define-enum 'img GL_POST_COLOR_MATRIX_GREEN_SCALE #x80B5)
+  (define-enum 'img GL_POST_COLOR_MATRIX_BLUE_SCALE #x80B6)
+  (define-enum 'img GL_POST_COLOR_MATRIX_ALPHA_SCALE #x80B7)
+  (define-enum 'img GL_POST_COLOR_MATRIX_RED_BIAS #x80B8)
+  (define-enum 'img GL_POST_COLOR_MATRIX_GREEN_BIAS #x80B9)
+  (define-enum 'img GL_POST_COLOR_MATRIX_BLUE_BIAS #x80BA)
+  (define-enum 'img GL_POST_COLOR_MATRIX_ALPHA_BIAS #x80BB)
+  (define-enum 'img GL_COLOR_TABLE #x80D0)
+  (define-enum 'img GL_POST_CONVOLUTION_COLOR_TABLE #x80D1)
+  (define-enum 'img GL_POST_COLOR_MATRIX_COLOR_TABLE #x80D2)
+  (define-enum 'img GL_PROXY_COLOR_TABLE #x80D3)
+  (define-enum 'img GL_PROXY_POST_CONVOLUTION_COLOR_TABLE #x80D4)
+  (define-enum 'img GL_PROXY_POST_COLOR_MATRIX_COLOR_TABLE #x80D5)
+  (define-enum 'img GL_COLOR_TABLE_SCALE #x80D6)
+  (define-enum 'img GL_COLOR_TABLE_BIAS #x80D7)
+  (define-enum 'img GL_COLOR_TABLE_FORMAT #x80D8)
+  (define-enum 'img GL_COLOR_TABLE_WIDTH #x80D9)
+  (define-enum 'img GL_COLOR_TABLE_RED_SIZE #x80DA)
+  (define-enum 'img GL_COLOR_TABLE_GREEN_SIZE #x80DB)
+  (define-enum 'img GL_COLOR_TABLE_BLUE_SIZE #x80DC)
+  (define-enum 'img GL_COLOR_TABLE_ALPHA_SIZE #x80DD)
+  (define-enum 'img GL_COLOR_TABLE_LUMINANCE_SIZE #x80DE)
+  (define-enum 'img GL_COLOR_TABLE_INTENSITY_SIZE #x80DF)
+  (define-enum 'img GL_CONSTANT_BORDER #x8151)
+  (define-enum 'img GL_REPLICATE_BORDER #x8153)
+  (define-enum 'img GL_CONVOLUTION_BORDER_COLOR #x8154)
+
+  (define-enum 13 GL_TEXTURE0 #x84C0)
+  (define-enum 13 GL_TEXTURE1 #x84C1)
+  (define-enum 13 GL_TEXTURE2 #x84C2)
+  (define-enum 13 GL_TEXTURE3 #x84C3)
+  (define-enum 13 GL_TEXTURE4 #x84C4)
+  (define-enum 13 GL_TEXTURE5 #x84C5)
+  (define-enum 13 GL_TEXTURE6 #x84C6)
+  (define-enum 13 GL_TEXTURE7 #x84C7)
+  (define-enum 13 GL_TEXTURE8 #x84C8)
+  (define-enum 13 GL_TEXTURE9 #x84C9)
+  (define-enum 13 GL_TEXTURE10 #x84CA)
+  (define-enum 13 GL_TEXTURE11 #x84CB)
+  (define-enum 13 GL_TEXTURE12 #x84CC)
+  (define-enum 13 GL_TEXTURE13 #x84CD)
+  (define-enum 13 GL_TEXTURE14 #x84CE)
+  (define-enum 13 GL_TEXTURE15 #x84CF)
+  (define-enum 13 GL_TEXTURE16 #x84D0)
+  (define-enum 13 GL_TEXTURE17 #x84D1)
+  (define-enum 13 GL_TEXTURE18 #x84D2)
+  (define-enum 13 GL_TEXTURE19 #x84D3)
+  (define-enum 13 GL_TEXTURE20 #x84D4)
+  (define-enum 13 GL_TEXTURE21 #x84D5)
+  (define-enum 13 GL_TEXTURE22 #x84D6)
+  (define-enum 13 GL_TEXTURE23 #x84D7)
+  (define-enum 13 GL_TEXTURE24 #x84D8)
+  (define-enum 13 GL_TEXTURE25 #x84D9)
+  (define-enum 13 GL_TEXTURE26 #x84DA)
+  (define-enum 13 GL_TEXTURE27 #x84DB)
+  (define-enum 13 GL_TEXTURE28 #x84DC)
+  (define-enum 13 GL_TEXTURE29 #x84DD)
+  (define-enum 13 GL_TEXTURE30 #x84DE)
+  (define-enum 13 GL_TEXTURE31 #x84DF)
+  (define-enum 13 GL_ACTIVE_TEXTURE #x84E0)
+  (define-enum 13 GL_CLIENT_ACTIVE_TEXTURE #x84E1)
+  (define-enum 13 GL_MAX_TEXTURE_UNITS #x84E2)
+  (define-enum 13 GL_TRANSPOSE_MODELVIEW_MATRIX #x84E3)
+  (define-enum 13 GL_TRANSPOSE_PROJECTION_MATRIX #x84E4)
+  (define-enum 13 GL_TRANSPOSE_TEXTURE_MATRIX #x84E5)
+  (define-enum 13 GL_TRANSPOSE_COLOR_MATRIX #x84E6)
+  (define-enum 13 GL_MULTISAMPLE #x809D)
+  (define-enum 13 GL_SAMPLE_ALPHA_TO_COVERAGE #x809E)
+  (define-enum 13 GL_SAMPLE_ALPHA_TO_ONE #x809F)
+  (define-enum 13 GL_SAMPLE_COVERAGE #x80A0)
+  (define-enum 13 GL_SAMPLE_BUFFERS #x80A8)
+  (define-enum 13 GL_SAMPLES #x80A9)
+  (define-enum 13 GL_SAMPLE_COVERAGE_VALUE #x80AA)
+  (define-enum 13 GL_SAMPLE_COVERAGE_INVERT #x80AB)
+  (define-enum 13 GL_MULTISAMPLE_BIT #x20000000)
+  (define-enum 13 GL_NORMAL_MAP #x8511)
+  (define-enum 13 GL_REFLECTION_MAP #x8512)
+  (define-enum 13 GL_TEXTURE_CUBE_MAP #x8513)
+  (define-enum 13 GL_TEXTURE_BINDING_CUBE_MAP #x8514)
+  (define-enum 13 GL_TEXTURE_CUBE_MAP_POSITIVE_X #x8515)
+  (define-enum 13 GL_TEXTURE_CUBE_MAP_NEGATIVE_X #x8516)
+  (define-enum 13 GL_TEXTURE_CUBE_MAP_POSITIVE_Y #x8517)
+  (define-enum 13 GL_TEXTURE_CUBE_MAP_NEGATIVE_Y #x8518)
+  (define-enum 13 GL_TEXTURE_CUBE_MAP_POSITIVE_Z #x8519)
+  (define-enum 13 GL_TEXTURE_CUBE_MAP_NEGATIVE_Z #x851A)
+  (define-enum 13 GL_PROXY_TEXTURE_CUBE_MAP #x851B)
+  (define-enum 13 GL_MAX_CUBE_MAP_TEXTURE_SIZE #x851C)
+  (define-enum 13 GL_COMPRESSED_ALPHA #x84E9)
+  (define-enum 13 GL_COMPRESSED_LUMINANCE #x84EA)
+  (define-enum 13 GL_COMPRESSED_LUMINANCE_ALPHA #x84EB)
+  (define-enum 13 GL_COMPRESSED_INTENSITY #x84EC)
+  (define-enum 13 GL_COMPRESSED_RGB #x84ED)
+  (define-enum 13 GL_COMPRESSED_RGBA #x84EE)
+  (define-enum 13 GL_TEXTURE_COMPRESSION_HINT #x84EF)
+  (define-enum 13 GL_TEXTURE_COMPRESSED_IMAGE_SIZE #x86A0)
+  (define-enum 13 GL_TEXTURE_COMPRESSED #x86A1)
+  (define-enum 13 GL_NUM_COMPRESSED_TEXTURE_FORMATS #x86A2)
+  (define-enum 13 GL_COMPRESSED_TEXTURE_FORMATS #x86A3)
+  (define-enum 13 GL_CLAMP_TO_BORDER #x812D)
+  (define-enum 13 GL_COMBINE #x8570)
+  (define-enum 13 GL_COMBINE_RGB #x8571)
+  (define-enum 13 GL_COMBINE_ALPHA #x8572)
+  (define-enum 13 GL_SOURCE0_RGB #x8580)
+  (define-enum 13 GL_SOURCE1_RGB #x8581)
+  (define-enum 13 GL_SOURCE2_RGB #x8582)
+  (define-enum 13 GL_SOURCE0_ALPHA #x8588)
+  (define-enum 13 GL_SOURCE1_ALPHA #x8589)
+  (define-enum 13 GL_SOURCE2_ALPHA #x858A)
+  (define-enum 13 GL_OPERAND0_RGB #x8590)
+  (define-enum 13 GL_OPERAND1_RGB #x8591)
+  (define-enum 13 GL_OPERAND2_RGB #x8592)
+  (define-enum 13 GL_OPERAND0_ALPHA #x8598)
+  (define-enum 13 GL_OPERAND1_ALPHA #x8599)
+  (define-enum 13 GL_OPERAND2_ALPHA #x859A)
+  (define-enum 13 GL_RGB_SCALE #x8573)
+  (define-enum 13 GL_ADD_SIGNED #x8574)
+  (define-enum 13 GL_INTERPOLATE #x8575)
+  (define-enum 13 GL_SUBTRACT #x84E7)
+  (define-enum 13 GL_CONSTANT #x8576)
+  (define-enum 13 GL_PRIMARY_COLOR #x8577)
+  (define-enum 13 GL_PREVIOUS #x8578)
+  (define-enum 13 GL_DOT3_RGB #x86AE)
+  (define-enum 13 GL_DOT3_RGBA #x86AF)
+  
+  (define-enum 14 GL_BLEND_DST_RGB #x80C8)
+  (define-enum 14 GL_BLEND_SRC_RGB #x80C9)
+  (define-enum 14 GL_BLEND_DST_ALPHA #x80CA)
+  (define-enum 14 GL_BLEND_SRC_ALPHA #x80CB)
+  (define-enum 14 GL_POINT_SIZE_MIN #x8126)
+  (define-enum 14 GL_POINT_SIZE_MAX #x8127)
+  (define-enum 14 GL_POINT_FADE_THRESHOLD_SIZE #x8128)
+  (define-enum 14 GL_POINT_DISTANCE_ATTENUATION #x8129)
+  (define-enum 14 GL_GENERATE_MIPMAP #x8191)
+  (define-enum 14 GL_GENERATE_MIPMAP_HINT #x8192)
+  (define-enum 14 GL_DEPTH_COMPONENT16 #x81A5)
+  (define-enum 14 GL_DEPTH_COMPONENT24 #x81A6)
+  (define-enum 14 GL_DEPTH_COMPONENT32 #x81A7)
+  (define-enum 14 GL_MIRRORED_REPEAT #x8370)
+  (define-enum 14 GL_FOG_COORDINATE_SOURCE #x8450)
+  (define-enum 14 GL_FOG_COORDINATE #x8451)
+  (define-enum 14 GL_FRAGMENT_DEPTH #x8452)
+  (define-enum 14 GL_CURRENT_FOG_COORDINATE #x8453)
+  (define-enum 14 GL_FOG_COORDINATE_ARRAY_TYPE #x8454)
+  (define-enum 14 GL_FOG_COORDINATE_ARRAY_STRIDE #x8455)
+  (define-enum 14 GL_FOG_COORDINATE_ARRAY_POINTER #x8456)
+  (define-enum 14 GL_FOG_COORDINATE_ARRAY #x8457)
+  (define-enum 14 GL_COLOR_SUM #x8458)
+  (define-enum 14 GL_CURRENT_SECONDARY_COLOR #x8459)
+  (define-enum 14 GL_SECONDARY_COLOR_ARRAY_SIZE #x845A)
+  (define-enum 14 GL_SECONDARY_COLOR_ARRAY_TYPE #x845B)
+  (define-enum 14 GL_SECONDARY_COLOR_ARRAY_STRIDE #x845C)
+  (define-enum 14 GL_SECONDARY_COLOR_ARRAY_POINTER #x845D)
+  (define-enum 14 GL_SECONDARY_COLOR_ARRAY #x845E)
+  (define-enum 14 GL_MAX_TEXTURE_LOD_BIAS #x84FD)
+  (define-enum 14 GL_TEXTURE_FILTER_CONTROL #x8500)
+  (define-enum 14 GL_TEXTURE_LOD_BIAS #x8501)
+  (define-enum 14 GL_INCR_WRAP #x8507)
+  (define-enum 14 GL_DECR_WRAP #x8508)
+  (define-enum 14 GL_TEXTURE_DEPTH_SIZE #x884A)
+  (define-enum 14 GL_DEPTH_TEXTURE_MODE #x884B)
+  (define-enum 14 GL_TEXTURE_COMPARE_MODE #x884C)
+  (define-enum 14 GL_TEXTURE_COMPARE_FUNC #x884D)
+  (define-enum 14 GL_COMPARE_R_TO_TEXTURE #x884E)
+  
+  (define-enum 15 GL_BUFFER_SIZE #x8764)
+  (define-enum 15 GL_BUFFER_USAGE #x8765)
+  (define-enum 15 GL_QUERY_COUNTER_BITS #x8864)
+  (define-enum 15 GL_CURRENT_QUERY #x8865)
+  (define-enum 15 GL_QUERY_RESULT #x8866)
+  (define-enum 15 GL_QUERY_RESULT_AVAILABLE #x8867)
+  (define-enum 15 GL_ARRAY_BUFFER #x8892)
+  (define-enum 15 GL_ELEMENT_ARRAY_BUFFER #x8893)
+  (define-enum 15 GL_ARRAY_BUFFER_BINDING #x8894)
+  (define-enum 15 GL_ELEMENT_ARRAY_BUFFER_BINDING #x8895)
+  (define-enum 15 GL_VERTEX_ARRAY_BUFFER_BINDING #x8896)
+  (define-enum 15 GL_NORMAL_ARRAY_BUFFER_BINDING #x8897)
+  (define-enum 15 GL_COLOR_ARRAY_BUFFER_BINDING #x8898)
+  (define-enum 15 GL_INDEX_ARRAY_BUFFER_BINDING #x8899)
+  (define-enum 15 GL_TEXTURE_COORD_ARRAY_BUFFER_BINDING #x889A)
+  (define-enum 15 GL_EDGE_FLAG_ARRAY_BUFFER_BINDING #x889B)
+  (define-enum 15 GL_SECONDARY_COLOR_ARRAY_BUFFER_BINDING #x889C)
+  (define-enum 15 GL_FOG_COORDINATE_ARRAY_BUFFER_BINDING #x889D)
+  (define-enum 15 GL_WEIGHT_ARRAY_BUFFER_BINDING #x889E)
+  (define-enum 15 GL_VERTEX_ATTRIB_ARRAY_BUFFER_BINDING #x889F)
+  (define-enum 15 GL_READ_ONLY #x88B8)
+  (define-enum 15 GL_WRITE_ONLY #x88B9)
+  (define-enum 15 GL_READ_WRITE #x88BA)
+  (define-enum 15 GL_BUFFER_ACCESS #x88BB)
+  (define-enum 15 GL_BUFFER_MAPPED #x88BC)
+  (define-enum 15 GL_BUFFER_MAP_POINTER #x88BD)
+  (define-enum 15 GL_STREAM_DRAW #x88E0)
+  (define-enum 15 GL_STREAM_READ #x88E1)
+  (define-enum 15 GL_STREAM_COPY #x88E2)
+  (define-enum 15 GL_STATIC_DRAW #x88E4)
+  (define-enum 15 GL_STATIC_READ #x88E5)
+  (define-enum 15 GL_STATIC_COPY #x88E6)
+  (define-enum 15 GL_DYNAMIC_DRAW #x88E8)
+  (define-enum 15 GL_DYNAMIC_READ #x88E9)
+  (define-enum 15 GL_DYNAMIC_COPY #x88EA)
+  (define-enum 15 GL_SAMPLES_PASSED #x8914)
+  (define-enum 15 GL_FOG_COORD_SRC GL_FOG_COORDINATE_SOURCE)
+  (define-enum 15 GL_FOG_COORD GL_FOG_COORDINATE)
+  (define-enum 15 GL_CURRENT_FOG_COORD GL_CURRENT_FOG_COORDINATE)
+  (define-enum 15 GL_FOG_COORD_ARRAY_TYPE GL_FOG_COORDINATE_ARRAY_TYPE)
+  (define-enum 15 GL_FOG_COORD_ARRAY_STRIDE GL_FOG_COORDINATE_ARRAY_STRIDE)
+  (define-enum 15 GL_FOG_COORD_ARRAY_POINTER GL_FOG_COORDINATE_ARRAY_POINTER)
+  (define-enum 15 GL_FOG_COORD_ARRAY GL_FOG_COORDINATE_ARRAY)
+  (define-enum 15 GL_FOG_COORD_ARRAY_BUFFER_BINDING GL_FOG_COORDINATE_ARRAY_BUFFER_BINDING)
+  (define-enum 15 GL_SRC0_RGB GL_SOURCE0_RGB)
+  (define-enum 15 GL_SRC1_RGB GL_SOURCE1_RGB)
+  (define-enum 15 GL_SRC2_RGB GL_SOURCE2_RGB)
+  (define-enum 15 GL_SRC0_ALPHA GL_SOURCE0_ALPHA)
+  (define-enum 15 GL_SRC1_ALPHA GL_SOURCE1_ALPHA)
+  (define-enum 15 GL_SRC2_ALPHA GL_SOURCE2_ALPHA)
+
+  ;; These values are taken from SGI's glu.h.
+  (define-enum GLU_FALSE 0)
+  (define-enum GLU_TRUE 1)
+  (define-enum GLU_VERSION 100800)
+  (define-enum GLU_EXTENSIONS 100801)
+  (define-enum GLU_INVALID_ENUM 100900)
+  (define-enum GLU_INVALID_VALUE 100901)
+  (define-enum GLU_OUT_OF_MEMORY 100902)
+  (define-enum GLU_INVALID_OPERATION 100904)
+  (define-enum GLU_OUTLINE_POLYGON 100240)
+  (define-enum GLU_OUTLINE_PATCH 100241)
+  (define-enum GLU_NURBS_ERROR 100103)
+  (define-enum GLU_ERROR 100103)
+  (define-enum GLU_NURBS_BEGIN 100164)
+  (define-enum GLU_NURBS_BEGIN_EXT 100164)
+  (define-enum GLU_NURBS_VERTEX 100165)
+  (define-enum GLU_NURBS_VERTEX_EXT 100165)
+  (define-enum GLU_NURBS_NORMAL 100166)
+  (define-enum GLU_NURBS_NORMAL_EXT 100166)
+  (define-enum GLU_NURBS_COLOR 100167)
+  (define-enum GLU_NURBS_COLOR_EXT 100167)
+  (define-enum GLU_NURBS_TEXTURE_COORD 100168)
+  (define-enum GLU_NURBS_TEX_COORD_EXT 100168)
+  (define-enum GLU_NURBS_END 100169)
+  (define-enum GLU_NURBS_END_EXT 100169)
+  (define-enum GLU_NURBS_BEGIN_DATA 100170)
+  (define-enum GLU_NURBS_BEGIN_DATA_EXT 100170)
+  (define-enum GLU_NURBS_VERTEX_DATA 100171)
+  (define-enum GLU_NURBS_VERTEX_DATA_EXT 100171)
+  (define-enum GLU_NURBS_NORMAL_DATA 100172)
+  (define-enum GLU_NURBS_NORMAL_DATA_EXT 100172)
+  (define-enum GLU_NURBS_COLOR_DATA 100173)
+  (define-enum GLU_NURBS_COLOR_DATA_EXT 100173)
+  (define-enum GLU_NURBS_TEXTURE_COORD_DATA 100174)
+  (define-enum GLU_NURBS_TEX_COORD_DATA_EXT 100174)
+  (define-enum GLU_NURBS_END_DATA 100175)
+  (define-enum GLU_NURBS_END_DATA_EXT 100175)
+  (define-enum GLU_NURBS_ERROR1 100251)
+  (define-enum GLU_NURBS_ERROR2 100252)
+  (define-enum GLU_NURBS_ERROR3 100253)
+  (define-enum GLU_NURBS_ERROR4 100254)
+  (define-enum GLU_NURBS_ERROR5 100255)
+  (define-enum GLU_NURBS_ERROR6 100256)
+  (define-enum GLU_NURBS_ERROR7 100257)
+  (define-enum GLU_NURBS_ERROR8 100258)
+  (define-enum GLU_NURBS_ERROR9 100259)
+  (define-enum GLU_NURBS_ERROR10 100260)
+  (define-enum GLU_NURBS_ERROR11 100261)
+  (define-enum GLU_NURBS_ERROR12 100262)
+  (define-enum GLU_NURBS_ERROR13 100263)
+  (define-enum GLU_NURBS_ERROR14 100264)
+  (define-enum GLU_NURBS_ERROR15 100265)
+  (define-enum GLU_NURBS_ERROR16 100266)
+  (define-enum GLU_NURBS_ERROR17 100267)
+  (define-enum GLU_NURBS_ERROR18 100268)
+  (define-enum GLU_NURBS_ERROR19 100269)
+  (define-enum GLU_NURBS_ERROR20 100270)
+  (define-enum GLU_NURBS_ERROR21 100271)
+  (define-enum GLU_NURBS_ERROR22 100272)
+  (define-enum GLU_NURBS_ERROR23 100273)
+  (define-enum GLU_NURBS_ERROR24 100274)
+  (define-enum GLU_NURBS_ERROR25 100275)
+  (define-enum GLU_NURBS_ERROR26 100276)
+  (define-enum GLU_NURBS_ERROR27 100277)
+  (define-enum GLU_NURBS_ERROR28 100278)
+  (define-enum GLU_NURBS_ERROR29 100279)
+  (define-enum GLU_NURBS_ERROR30 100280)
+  (define-enum GLU_NURBS_ERROR31 100281)
+  (define-enum GLU_NURBS_ERROR32 100282)
+  (define-enum GLU_NURBS_ERROR33 100283)
+  (define-enum GLU_NURBS_ERROR34 100284)
+  (define-enum GLU_NURBS_ERROR35 100285)
+  (define-enum GLU_NURBS_ERROR36 100286)
+  (define-enum GLU_NURBS_ERROR37 100287)
+  (define-enum GLU_AUTO_LOAD_MATRIX 100200)
+  (define-enum GLU_CULLING 100201)
+  (define-enum GLU_SAMPLING_TOLERANCE 100203)
+  (define-enum GLU_DISPLAY_MODE 100204)
+  (define-enum GLU_PARAMETRIC_TOLERANCE 100202)
+  (define-enum GLU_SAMPLING_METHOD 100205)
+  (define-enum GLU_U_STEP 100206)
+  (define-enum GLU_V_STEP 100207)
+  (define-enum GLU_NURBS_MODE 100160)
+  (define-enum GLU_NURBS_MODE_EXT 100160)
+  (define-enum GLU_NURBS_TESSELLATOR 100161)
+  (define-enum GLU_NURBS_TESSELLATOR_EXT 100161)
+  (define-enum GLU_NURBS_RENDERER 100162)
+  (define-enum GLU_NURBS_RENDERER_EXT 100162)
+  (define-enum GLU_OBJECT_PARAMETRIC_ERROR 100208)
+  (define-enum GLU_OBJECT_PARAMETRIC_ERROR_EXT 100208)
+  (define-enum GLU_OBJECT_PATH_LENGTH 100209)
+  (define-enum GLU_OBJECT_PATH_LENGTH_EXT 100209)
+  (define-enum GLU_PATH_LENGTH 100215)
+  (define-enum GLU_PARAMETRIC_ERROR 100216)
+  (define-enum GLU_DOMAIN_DISTANCE 100217)
+  (define-enum GLU_MAP1_TRIM_2 100210)
+  (define-enum GLU_MAP1_TRIM_3 100211)
+  (define-enum GLU_POINT 100010)
+  (define-enum GLU_LINE 100011)
+  (define-enum GLU_FILL 100012)
+  (define-enum GLU_SILHOUETTE 100013)
+  (define-enum GLU_SMOOTH 100000)
+  (define-enum GLU_FLAT 100001)
+  (define-enum GLU_NONE 100002)
+  (define-enum GLU_OUTSIDE 100020)
+  (define-enum GLU_INSIDE 100021)
+  (define-enum GLU_TESS_BEGIN 100100)
+  (define-enum GLU_BEGIN 100100)
+  (define-enum GLU_TESS_VERTEX 100101)
+  (define-enum GLU_VERTEX 100101)
+  (define-enum GLU_TESS_END 100102)
+  (define-enum GLU_END 100102)
+  (define-enum GLU_TESS_ERROR 100103)
+  (define-enum GLU_TESS_EDGE_FLAG 100104)
+  (define-enum GLU_EDGE_FLAG 100104)
+  (define-enum GLU_TESS_COMBINE 100105)
+  (define-enum GLU_TESS_BEGIN_DATA 100106)
+  (define-enum GLU_TESS_VERTEX_DATA 100107)
+  (define-enum GLU_TESS_END_DATA 100108)
+  (define-enum GLU_TESS_ERROR_DATA 100109)
+  (define-enum GLU_TESS_EDGE_FLAG_DATA 100110)
+  (define-enum GLU_TESS_COMBINE_DATA 100111)
+  (define-enum GLU_CW 100120)
+  (define-enum GLU_CCW 100121)
+  (define-enum GLU_INTERIOR 100122)
+  (define-enum GLU_EXTERIOR 100123)
+  (define-enum GLU_UNKNOWN 100124)
+  (define-enum GLU_TESS_WINDING_RULE 100140)
+  (define-enum GLU_TESS_BOUNDARY_ONLY 100141)
+  (define-enum GLU_TESS_TOLERANCE 100142)
+  (define-enum GLU_TESS_ERROR1 100151)
+  (define-enum GLU_TESS_ERROR2 100152)
+  (define-enum GLU_TESS_ERROR3 100153)
+  (define-enum GLU_TESS_ERROR4 100154)
+  (define-enum GLU_TESS_ERROR5 100155)
+  (define-enum GLU_TESS_ERROR6 100156)
+  (define-enum GLU_TESS_ERROR7 100157)
+  (define-enum GLU_TESS_ERROR8 100158)
+  (define-enum GLU_TESS_MISSING_BEGIN_POLYGON 100151)
+  (define-enum GLU_TESS_MISSING_BEGIN_CONTOUR 100152)
+  (define-enum GLU_TESS_MISSING_END_POLYGON 100153)
+  (define-enum GLU_TESS_MISSING_END_CONTOUR 100154)
+  (define-enum GLU_TESS_COORD_TOO_LARGE 100155)
+  (define-enum GLU_TESS_NEED_COMBINE_CALLBACK 100156)
+  (define-enum GLU_TESS_WINDING_ODD 100130)
+  (define-enum GLU_TESS_WINDING_NONZERO 100131)
+  (define-enum GLU_TESS_WINDING_POSITIVE 100132)
+  (define-enum GLU_TESS_WINDING_NEGATIVE 100133)
+  (define-enum GLU_TESS_WINDING_ABS_GEQ_TWO 100134)
+  (define-enum GLU_TESS_MAX_COORD 1.0e150)
+  )
diff --git a/collects/sgl/info.ss b/collects/sgl/info.ss
new file mode 100644
index 0000000000..bf1dc0b1a4
--- /dev/null
+++ b/collects/sgl/info.ss
@@ -0,0 +1,8 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "sgl")
+  (define doc.txt "doc.txt")
+  (define pre-install-collection "makefile.ss")
+  (define compile-omit-files (list))
+  (define clean (list (build-path "compiled" "native" (system-library-subpath))
+                      "compiled"
+                      )))
diff --git a/collects/sgl/make-gl-info.ss b/collects/sgl/make-gl-info.ss
new file mode 100644
index 0000000000..9d76a5dc35
--- /dev/null
+++ b/collects/sgl/make-gl-info.ss
@@ -0,0 +1,163 @@
+(module make-gl-info mzscheme
+  (require (prefix dynext: (lib "compile.ss" "dynext"))
+           (all-except (lib "file.ss" "dynext") append-c-suffix)
+           (prefix dynext: (lib "link.ss" "dynext"))
+           (lib "file.ss")
+           (lib "13.ss" "srfi"))
+  
+  (provide make-gl-info)
+  
+  (define c-file #<<end-string
+#include <escheme.h>
+#include <GL/gl.h>
+#include <GL/glu.h>
+
+Scheme_Object *scheme_reload(Scheme_Env *env)
+{
+  Scheme_Env *mod_env;
+  
+  mod_env = scheme_primitive_module(scheme_intern_symbol("make-gl-info-helper"), env);
+  scheme_add_global("gl-byte-size",
+		    scheme_make_integer_value(sizeof(GLbyte)),
+		    mod_env);
+  scheme_add_global("gl-ubyte-size",
+		    scheme_make_integer_value(sizeof(GLubyte)),
+		    mod_env);
+  scheme_add_global("gl-short-size",
+		    scheme_make_integer_value(sizeof(GLshort)),
+		    mod_env);
+  scheme_add_global("gl-ushort-size",
+		    scheme_make_integer_value(sizeof(GLushort)),
+		    mod_env);
+  scheme_add_global("gl-int-size",
+		    scheme_make_integer_value(sizeof(GLint)),
+		    mod_env);
+  scheme_add_global("gl-uint-size",
+		    scheme_make_integer_value(sizeof(GLuint)),
+		    mod_env);
+  scheme_add_global("gl-float-size",
+		    scheme_make_integer_value(sizeof(GLfloat)),
+		    mod_env);
+  scheme_add_global("gl-double-size",
+		    scheme_make_integer_value(sizeof(GLdouble)),
+		    mod_env);
+  scheme_add_global("gl-boolean-size",
+		    scheme_make_integer_value(sizeof(GLboolean)),
+		    mod_env);
+  scheme_add_global("gl-sizei-size",
+		    scheme_make_integer_value(sizeof(GLsizei)),
+		    mod_env);
+  scheme_add_global("gl-clampf-size",
+		    scheme_make_integer_value(sizeof(GLclampf)),
+		    mod_env);
+  scheme_add_global("gl-clampd-size",
+		    scheme_make_integer_value(sizeof(GLclampd)),
+		    mod_env);
+  scheme_add_global("gl-enum-size",
+		    scheme_make_integer_value(sizeof(GLenum)),
+		    mod_env);
+  scheme_add_global("gl-bitfield-size",
+		    scheme_make_integer_value(sizeof(GLbitfield)),
+		    mod_env);
+  scheme_finish_primitive_module(mod_env);
+
+  return scheme_void;
+}
+
+Scheme_Object *scheme_initialize(Scheme_Env *env)
+{
+  return scheme_reload(env);
+}
+
+Scheme_Object *scheme_module_name(void)
+{
+  return scheme_intern_symbol("make-gl-info-helper");
+}
+
+end-string
+    )
+
+  (define (delete/continue x)
+    (with-handlers ((exn:fail:filesystem? void))
+      (delete-file x)))
+
+  (define (parse-includes s)
+    (map (lambda (s)
+           (substring s 2 (string-length s)))
+         (string-tokenize s)))
+  
+  (define (get-args which-arg home)
+    (let ((fp (build-path home "lib" "buildinfo")))
+      (cond
+        ((file-exists? fp)
+         (call-with-input-file fp
+           (lambda (i)
+             (let loop ((l (read-line i)))
+               (cond
+                 ((eof-object? l) "")
+                 (else
+                  (let ((m (regexp-match (format "^~a=(.*)$" which-arg) l)))
+                    (if m
+                        (cadr m)
+                        (loop (read-line i))))))))))
+        (else ""))))
+
+  (define (compile-c-to-so file file.c file.so home)
+    (let ((file.o (append-object-suffix file)))
+      (dynext:compile-extension #f 
+                                file.c
+                                file.o
+                                `(,@(parse-includes (get-args "X_CFLAGS" home))
+                                    ,(build-path home "collects" "compiler")))
+      (dynext:link-extension #f (list file.o) file.so)
+      (delete/continue file.o)))
+
+  (define (build-helper compile-directory home)
+    (let ((file (build-path compile-directory "make-gl-info-helper"))
+          (c (build-path compile-directory "make-gl-info-helper.c"))
+          (so (build-path compile-directory
+                          "native"
+                          (system-library-subpath #f) 
+                          "make-gl-info-helper.so")))
+      (make-directory* (build-path compile-directory "native" (system-library-subpath #f)))
+      (with-output-to-file c
+        (lambda () (display c-file))
+        'replace)
+      (compile-c-to-so file c so home)))
+  
+  (define (make-gl-info compile-directory home)
+    (let ((zo (build-path compile-directory "gl-info.zo"))
+          (mod
+           (compile
+            (case (system-type)
+              ((macosx windows)
+               '(module gl-info mzscheme
+                  (provide (all-defined))
+                  (define gl-byte-size 1)
+                  (define gl-ubyte-size 1)
+                  (define gl-short-size 2)
+                  (define gl-ushort-size 2)
+                  (define gl-int-size 4)
+                  (define gl-uint-size 4)
+                  (define gl-boolean-size 1)
+                  (define gl-sizei-size 4)
+                  (define gl-bitfield-size 4)
+                  (define gl-enum-size 4)
+                  (define gl-float-size 4)
+                  (define gl-double-size 8)
+                  (define gl-clampf-size 4)
+                  (define gl-clampd-size 8)))
+             (else
+              (build-helper compile-directory home)
+              `(module gl-info mzscheme
+                 (provide (all-defined))
+                 ,@(map 
+                    (lambda (x)
+                      `(define ,x ,(dynamic-require '(lib "make-gl-info-helper.ss" "sgl") x)))
+                    '(gl-byte-size gl-ubyte-size gl-short-size gl-ushort-size
+                      gl-int-size gl-uint-size gl-boolean-size gl-sizei-size
+                      gl-bitfield-size gl-enum-size gl-float-size gl-double-size
+                      gl-clampf-size gl-clampd-size))))))))
+      (with-output-to-file zo
+        (lambda () (write mod))
+        'replace))))
diff --git a/collects/sgl/makefile.ss b/collects/sgl/makefile.ss
new file mode 100644
index 0000000000..7a4720f735
--- /dev/null
+++ b/collects/sgl/makefile.ss
@@ -0,0 +1,17 @@
+(module makefile mzscheme
+  (require (lib "make.ss" "make")
+           "make-gl-info.ss")
+
+  (provide pre-installer)
+    
+  (define dir (build-path "compiled"))
+  
+  (define (pre-installer home)
+    (parameterize ((current-directory (collection-path "sgl"))
+		   (make-print-reasons #f)
+		   (make-print-checking #f))
+      (make/proc
+       `((,(build-path dir "gl-info.zo")
+           ("make-gl-info.ss" ,(build-path home "include" "schvers.h"))
+           ,(lambda () (make-gl-info dir home)))))))
+  )
diff --git a/collects/sgl/sgl.ss b/collects/sgl/sgl.ss
new file mode 100644
index 0000000000..0a9a08084c
--- /dev/null
+++ b/collects/sgl/sgl.ss
@@ -0,0 +1,1033 @@
+;; sgl -- An OpenGL extension of MzScheme
+;;
+;; Copyright (C) 2003-2005 Scott Owens <sowens@cs.utah.edu>
+;;
+;; This  library is  free  software; you  can  redistribute it  and/or
+;; modify it under the terms  of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 2.1 of
+;; the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful, but
+;; WITHOUT  ANY  WARRANTY;  without   even  the  implied  warranty  of
+;; MERCHANTABILITY or  FITNESS FOR A  PARTICULAR PURPOSE. See  the GNU
+;; Lesser General Public License for more details.
+ 
+(module sgl mzscheme
+  (require (lib "etc.ss")
+           "gl-vectors.ss"
+           "gl.ss")
+  
+  (define-syntax (_provide stx)
+    (syntax-case stx ()
+      ((_ x ...)
+       (begin
+         #;(for-each
+          (lambda (x)
+            (syntax-case x (rename)
+              ((rename _ n)
+               (display (syntax-object->datum #'n)))
+              (_ (display (syntax-object->datum x))))
+            (newline))
+          (syntax->list #'(x ...)))
+         #'(provide x ...)))))
+  
+  (define-syntax-set (multi-arg multi-type-v)
+    
+    (define (iota n)
+      (cond
+        ((= 0 n) null)
+        (else (cons n (iota (sub1 n))))))
+    
+    (define (get-possible-types-v ts)
+      (combine-str
+       (map (lambda (t)
+              (case t
+                ((iv) "gl-int-vector")
+                ((sv) "gl-short-vector")
+                ((bv) "gl-byte-vector")
+                ((uiv) "gl-uint-vector")
+                ((usv) "gl-ushort-vector")
+                ((ubv) "gl-ubyte-vector")
+                ((dv) "gl-double-vector")
+                ((fv) "gl-float-vector")
+                (else (error (format "~a" t)))))
+            ts)))
+
+    (define (combine-str strs)
+      (cond
+        ((null? strs) "")
+        ((null? (cdr strs))
+         (string-append "or " (car strs)))
+        (else
+         (string-append (car strs) ", " (combine-str (cdr strs))))))
+        
+    (define (multi-arg/proc stx)
+      (syntax-case stx ()
+        ((_ name gl-name ((pre-arg-name pre-arg) ...) (num-arg ...))
+         (let ((build-clause
+                (lambda (num-arg)
+                  (with-syntax (((arg ...)
+                                 (generate-temporaries (iota num-arg)))
+                                (gl-name
+                                 (datum->syntax-object
+                                  #'gl-name
+                                  (string->symbol
+                                   (format "~a~ad"
+                                           (syntax-object->datum #'gl-name)
+                                           num-arg))
+                                  #'gl-name
+                                  #'gl-name)))
+                    #`((pre-arg-name ... arg ...)
+                       (cond
+                         ((and (real? arg) ...)
+                          (gl-name pre-arg ... arg ...))
+                         (else (raise-type-error 'name
+                                                 "real numbers"
+                                                 (list arg ...)))))))))
+           (with-syntax (((clauses ...)
+                          (map build-clause
+                               (syntax-object->datum  #'(num-arg ...)))))
+             #`(define name
+                 (case-lambda clauses ...)))))))
+    
+    (define (multi-type-v/proc stx)
+      (syntax-case stx ()
+        ((_ name gl-name ((pre-arg-name pre-arg ) ...)
+            (length ...) (type ...) num? )
+         (with-syntax ((arg (car (generate-temporaries (list #'name)))))
+           (let* ((num? (syntax-object->datum #'num?))
+                  (lengths (syntax-object->datum #'(length ...)))
+                  (build-clause
+                   (lambda (type)
+                     (with-syntax ((pred?
+                                   (case type
+                                     ((dv) #'gl-double-vector?)
+                                     ((fv) #'gl-float-vector?)
+                                     ((iv) #'gl-int-vector?)
+                                     ((sv) #'gl-short-vector?)
+                                     ((bv) #'gl-byte-vector?)
+                                     ((uiv) #'gl-uint-vector?)
+                                     ((usv) #'gl-ushort-vector?)
+                                     ((ubv) #'gl-ubyte-vector?)))
+                                   ((clause ...)
+                                    (map 
+                                     (lambda (length)
+                                       (with-syntax ((name 
+                                                      (datum->syntax-object
+                                                       #'gl-name
+                                                       (string->symbol
+                                                        (format "~a~a~a"
+                                                                (syntax-object->datum #'gl-name)
+                                                                (if num? length "")
+                                                                type))
+                                                       #'gl-name
+                                                       #'gl-name)))
+                                         #`((#,length) (name pre-arg ... arg))))
+                                     lengths)))
+                       #`((pred? arg)
+                          (case (gl-vector-length arg)
+                            clause ...
+                            (else (error
+                                   'name
+                                   "expects vector with length in ~a: given vector has length ~a" 
+                                   '(length ...)
+                                   (gl-vector-length arg))))))))
+                  (types (syntax-object->datum #'(type ...))))
+             (with-syntax (((clause ...) (map build-clause types)))
+               #`(define (name pre-arg-name ... arg)
+                   (cond
+                     clause ...
+                     (else
+                      (raise-type-error 'name 
+                                        #,(get-possible-types-v types)
+                                        arg)))))))))))
+  
+  (define-for-syntax gl-regex2 (regexp "(^GLU\\-)|(^GL\\-)"))
+  (define-for-syntax _-regex (regexp "_"))
+    
+  (define-for-syntax (string-downcase s)
+    (list->string (map char-downcase (string->list s))))
+  
+  (define-for-syntax (translate-cname name)
+    (string->symbol
+     (string-downcase
+      (regexp-replace* gl-regex2
+                       (regexp-replace* _-regex
+                                        (symbol->string name)
+                                        "-")
+                       ""))))
+  
+  (define-syntax (make-enum-table stx)
+    (syntax-case stx ()
+      ((_ name const ...)
+       (with-syntax (((sym ...)
+                      (map translate-cname
+                           (syntax-object->datum #'(const ...)))))
+         (cond
+           ((< (length (syntax->list #'(const ...))) 8)
+            (quasisyntax/loc stx
+              (define name
+                (let ((l `((sym . ,const) ...)))
+                  (lambda (enum-sym name)
+                    (let ((v (assq enum-sym l)))
+                      (unless v
+                        (raise-type-error name
+                                          (format "symbol in ~a" '(sym ...))
+                                          enum-sym))
+                      (cdr v)))))))
+           (else
+            (quasisyntax/loc stx
+              (define name
+                (let ((ht (make-hash-table)))
+                  (for-each (lambda (key value)
+                              (hash-table-put! ht key value))
+                            '(sym ...) (list const ...))
+                  (lambda (enum-sym name)
+                    (let ((v (hash-table-get ht enum-sym (lambda () #f))))
+                      (unless v
+                        (raise-type-error name
+                                          (format "symbol in ~a" '(sym ...))
+                                          enum-sym))
+                      v)))))))))))
+  
+  (define-syntax (make-inv-enum-table stx)
+    (syntax-case stx ()
+      ((_ name const ...)
+       (with-syntax (((sym ...)
+                      (map translate-cname
+                           (syntax-object->datum #'(const ...)))))
+         (quasisyntax/loc stx
+           (define name
+             (let ((l `((,const . sym) ...)))
+               (lambda (enum-val)
+                 (cdr (assq enum-val l))))))))))
+    
+  (define check-length
+    (case-lambda
+      ((name v desired-length sym)
+       (unless (= desired-length (gl-vector-length v))
+         (error name "expects vector of length ~a for ~a: argument vector has length ~a"
+                desired-length sym (gl-vector-length v))))
+      ((name v desired-length)
+       (unless (= desired-length (gl-vector-length v))
+         (error name "expects vector of length: argument vector has length ~a"
+                desired-length (gl-vector-length v))))))
+
+  ;; 2.5
+  (_provide get-error)
+  (make-inv-enum-table get-error-table
+                       GL_NO_ERROR 
+                       GL_INVALID_ENUM
+                       GL_INVALID_VALUE
+                       GL_INVALID_OPERATION
+                       GL_STACK_OVERFLOW
+                       GL_STACK_UNDERFLOW
+                       GL_OUT_OF_MEMORY)
+  (define (get-error)
+    (get-error-table (glGetError)))
+
+  ;; 2.6.1
+  (_provide (rename gl-begin begin) (rename glEnd end))
+  (make-enum-table begin-table
+                   GL_LINES
+                   GL_LINE_LOOP
+                   GL_LINE_STRIP
+                   GL_POINTS
+                   GL_POLYGON
+                   GL_QUADS
+                   GL_QUAD_STRIP
+                   GL_TRIANGLES
+                   GL_TRIANGLE_FAN
+                   GL_TRIANGLE_STRIP)
+  (define (gl-begin enum)
+    (glBegin (begin-table enum 'begin)))
+  
+  ;; 2.6.2
+  (_provide (rename glEdgeFlag edge-flag))
+
+  ;; 2.7
+  (_provide vertex vertex-v
+            tex-coord tex-coord-v
+            multi-tex-coord multi-tex-coord-v
+            (rename glNormal3d normal) normal-v
+            color color-v
+            (rename glSecondaryColor3d secondary-color) secondary-color-v
+            (rename glIndexd index) index-v)
+
+  (multi-arg vertex glVertex () (2 3 4))
+  (multi-type-v vertex-v glVertex () (2 3 4) (dv iv fv sv) #t)
+  (multi-arg tex-coord glTexCoord () (1 2 3 4))
+  (multi-type-v tex-coord-v glTexCoord () (1 2 3 4) (dv iv fv sv) #t)
+  (make-enum-table multi-tex-coord-table
+                   GL_TEXTURE0 GL_TEXTURE1 GL_TEXTURE2 GL_TEXTURE3 GL_TEXTURE4
+                   GL_TEXTURE5 GL_TEXTURE6 GL_TEXTURE7 GL_TEXTURE8 GL_TEXTURE9
+                   GL_TEXTURE10 GL_TEXTURE11 GL_TEXTURE12 GL_TEXTURE13
+                   GL_TEXTURE14 GL_TEXTURE15 GL_TEXTURE16 GL_TEXTURE17
+                   GL_TEXTURE18 GL_TEXTURE19 GL_TEXTURE20 GL_TEXTURE21
+                   GL_TEXTURE22 GL_TEXTURE23 GL_TEXTURE24 GL_TEXTURE25
+                   GL_TEXTURE26 GL_TEXTURE27 GL_TEXTURE28 GL_TEXTURE29
+                   GL_TEXTURE30 GL_TEXTURE31)
+  (multi-arg multi-tex-coord glMultiTexCoord
+             ((e (multi-tex-coord-table e 'multi-tex-coord)))
+             (1 2 3 4))
+  (multi-type-v multi-tex-coord-v glMultiTexCoord
+                ((e (multi-tex-coord-table e 'multi-tex-coord)))
+                (1 2 3 4)
+                (sv iv fv dv)
+                #t)
+  (multi-type-v normal-v glNormal () (3) (dv iv fv sv bv) #t)
+  (multi-arg color glColor () (3 4))
+  (multi-type-v color-v glColor () (3 4) (dv iv uiv fv ubv bv usv sv) #t)
+  (multi-type-v secondary-color-v glSecondaryColor () (3) (bv sv iv fv dv ubv usv uiv) #t)
+  (multi-type-v index-v glIndex () (1) (dv iv fv sv ubv) #f)
+
+  ;; 2.8, 2.9 not implemented
+
+  ;; 2.10
+  (_provide (rename glRectd rect) rect-v)
+  (multi-type-v rect-v glRect () (4) (dv iv fv sv) #f)
+  
+  ;; 2.11.1
+  (_provide (rename glDepthRange depth-range) (rename glViewport viewport))
+  
+  ;; 2.11.2
+  (_provide matrix-mode load-matrix mult-matrix
+            load-transpose-matrix mult-transpose-matrix
+            (rename glLoadIdentity load-identity)
+            (rename glRotated rotate)
+            (rename glTranslated translate)
+            (rename glScaled scale)
+            (rename glFrustum frustum)
+            (rename glOrtho ortho)
+            active-texture
+            (rename glPushMatrix push-matrix)
+            (rename glPopMatrix pop-matrix))
+  
+  (make-enum-table matrix-mode-table
+                   GL_MODELVIEW GL_PROJECTION GL_TEXTURE GL_COLOR)
+  (define (matrix-mode x)
+    (glMatrixMode (matrix-mode-table x 'matrix-mode)))
+  (define-values (glLoadMatrixfv glLoadMatrixdv glMultMatrixfv glMultMatrixdv
+                  glLoadTransposeMatrixfv glLoadTransposeMatrixdv
+                  glMultTransposeMatrixfv glMultTransposeMatrixdv)
+    (values glLoadMatrixf glLoadMatrixd glMultMatrixf glMultMatrixd
+            glLoadTransposeMatrixf glLoadTransposeMatrixd
+            glMultTransposeMatrixf glMultTransposeMatrixd))
+  (multi-type-v load-matrix glLoadMatrix () (16) (fv dv) #f)
+  (multi-type-v mult-matrix glMultMatrix () (16) (fv dv) #f)
+  (multi-type-v load-transpose-matrix glLoadTransposeMatrix () (16) (fv dv) #f)
+  (multi-type-v mult-transpose-matrix glMultTransposeMatrix () (16) (fv dv) #f)
+  
+  (define (active-texture texture)
+    (glActiveTexture (multi-tex-coord-table texture 'active-texture texture)))
+
+  ;; 2.11.3
+  (_provide enable disable)
+  (make-enum-table enable-table
+		   GL_VERTEX_ARRAY GL_NORMAL_ARRAY GL_FOG_COORD_ARRAY
+		   GL_COLOR_ARRAY GL_SECONDARY_COLOR_ARRAY GL_INDEX_ARRAY
+		   GL_TEXTURE_COORD_ARRAY GL_EDGE_FLAG_ARRAY
+                   GL_NORMALIZE GL_RESCALE_NORMAL 
+                   GL_CLIP_PLANE0 GL_CLIP_PLANE1 GL_CLIP_PLANE2 GL_CLIP_PLANE3
+                   GL_CLIP_PLANE4 GL_CLIP_PLANE5
+                   GL_FOG GL_COLOR_SUM
+                   GL_LIGHTING GL_COLOR_MATERIAL
+                   GL_LIGHT0 GL_LIGHT1 GL_LIGHT2 GL_LIGHT3 GL_LIGHT4
+                   GL_LIGHT5 GL_LIGHT6 GL_LIGHT7
+                   GL_POINT_SMOOTH GL_LINE_SMOOTH GL_LINE_STIPPLE GL_CULL_FACE
+                   GL_POLYGON_SMOOTH GL_POLYGON_OFFSET_POINT
+		   GL_POLYGON_OFFSET_LINE GL_POLYGON_OFFSET_FILL
+                   GL_POLYGON_STIPPLE
+		   GL_MULTISAMPLE GL_SAMPLE_ALPHA_TO_COVERAGE
+		   GL_SAMPLE_ALPHA_TO_ONE GL_SAMPLE_COVERAGE
+                   GL_TEXTURE_1D GL_TEXTURE_2D GL_TEXTURE_3D
+		   GL_TEXTURE_CUBE_MAP
+                   GL_TEXTURE_GEN_S GL_TEXTURE_GEN_T
+		   GL_TEXTURE_GEN_R GL_TEXTURE_GEN_Q
+                   GL_SCISSOR_TEST GL_ALPHA_TEST GL_STENCIL_TEST
+                   GL_DEPTH_TEST GL_BLEND GL_DITHER
+                   GL_INDEX_LOGIC_OP GL_LOGIC_OP GL_COLOR_LOGIC_OP
+		   GL_COLOR_TABLE GL_POST_CONVOLUTION_COLOR_TABLE
+		   GL_POST_COLOR_MATRIX_COLOR_TABLE
+		   GL_CONVOLUTION_1D GL_CONVOLUTION_2D GL_SEPARABLE_2D
+		   GL_HISTOGRAM GL_MINMAX
+                   GL_MAP1_VERTEX_3 GL_MAP1_VERTEX_4 GL_MAP1_INDEX
+                   GL_MAP1_COLOR_4 GL_MAP1_NORMAL
+                   GL_MAP1_TEXTURE_COORD_1 GL_MAP1_TEXTURE_COORD_2
+                   GL_MAP1_TEXTURE_COORD_3 GL_MAP1_TEXTURE_COORD_4
+                   GL_MAP2_VERTEX_3 GL_MAP2_VERTEX_4 GL_MAP2_INDEX
+                   GL_MAP2_COLOR_4 GL_MAP2_NORMAL
+                   GL_MAP2_TEXTURE_COORD_1 GL_MAP2_TEXTURE_COORD_2
+                   GL_MAP2_TEXTURE_COORD_3 GL_MAP2_TEXTURE_COORD_4
+                   GL_AUTO_NORMAL)
+  (define (enable x)
+    (glEnable (enable-table x 'enable)))
+  (define (disable x)
+    (glDisable (enable-table x 'disable)))
+
+  ;; 2.11.4
+  (_provide tex-gen tex-gen-v)
+  (make-enum-table tex-gen-coord-table GL_S GL_T GL_R GL_Q)
+  (make-enum-table tex-gen-pname-table
+                   GL_TEXTURE_GEN_MODE GL_OBJECT_PLANE GL_EYE_PLANE)
+  (make-enum-table tex-gen-param-table
+                   GL_OBJECT_LINEAR GL_EYE_LINEAR GL_SPHERE_MAP
+                   GL_REFLECTION_MAP GL_NORMAL_MAP)
+  (define (tex-gen c p n)
+    (let ((cv (tex-gen-coord-table c 'tex-gen))
+          (pv (tex-gen-pname-table p 'tex-gen)))
+      (unless (= pv GL_TEXTURE_GEN_MODE)
+        (error 'tex-gen "does not accept ~a, use tex-gen-v instead" p))
+      (glTexGeni cv pv (tex-gen-param-table n 'tex-gen))))
+  (define (tex-gen-v c p v)
+    (let ((cv (tex-gen-coord-table c 'tex-gen-v))
+          (pv (tex-gen-pname-table p 'tex-gen-v)))
+      (when (= pv GL_TEXTURE_GEN_MODE)
+        (error 'tex-gen-v "does not accept ~a, use tex-gen instead" p))
+      (let ((f (cond
+                 ((gl-int-vector? v) glTexGeniv)
+                 ((gl-float-vector? v) glTexGenfv)
+                 ((gl-double-vector? v) glTexGendv)
+                 (else
+                  (raise-type-error 'tex-gen-v
+                                    "gl-int-vector, gl-float-vector, or gl-double-vector"
+                                    2 c p v)))))
+        (check-length 'tex-gen-v v 4)
+        (f cv pv v))))
+  
+  ;; 2.12
+  (_provide clip-plane)
+  (make-enum-table clip-plane-table
+                   GL_CLIP_PLANE0 GL_CLIP_PLANE1 GL_CLIP_PLANE2
+                   GL_CLIP_PLANE3 GL_CLIP_PLANE4 GL_CLIP_PLANE5)
+  (define (clip-plane p eqn)
+    (let ((v (clip-plane-table p 'clip-plane)))
+      (unless (gl-double-vector? eqn)
+        (raise-type-error 'clip-plane "gl-double-vector" 1 p eqn))
+      (check-length 'clip-plane eqn 4)
+      (glClipPlane v eqn)))
+  
+  ;; 2.13
+  (_provide raster-pos raster-pos-v
+            window-pos window-pos-v)
+  (multi-arg raster-pos glRasterPos () (2 3 4))
+  (multi-type-v raster-pos-v glRasterPos () (2 3 4) (dv iv fv sv) #t)
+  (multi-arg window-pos glWindowPos () (2 3))
+  (multi-type-v window-pos-v glWindowPos () (2 3) (dv iv fv sv) #t)
+ 
+  ;; 2.14.1
+  (_provide front-face)
+  (make-enum-table front-face-table GL_CCW GL_CW)
+  (define (front-face x)
+    (glFrontFace (front-face-table x 'front-face)))
+
+  ;; 2.14.2
+  (_provide material material-v light light-v light-model light-model-v)
+  (make-enum-table face-table GL_FRONT GL_BACK GL_FRONT_AND_BACK)
+  (make-enum-table material-pname-table
+                   GL_AMBIENT GL_DIFFUSE GL_AMBIENT_AND_DIFFUSE 
+                   GL_SPECULAR GL_EMISSION GL_SHININESS GL_COLOR_INDEXES)
+  
+  (define (get-f v iv fv name a1 a2)
+    (cond
+      ((gl-int-vector? v) iv)
+      ((gl-float-vector? v) fv)
+      (else
+       (raise-type-error name
+                         "gl-int-vector or gl-float-vector"
+                         2 a1 a2 v))))
+  (define (do-f n v0 v1 i f name a0 a1)
+    (unless (real? n)
+      (raise-type-error name "real number" 2 a0 a1 n))
+    (cond
+      ((and (exact? n) (integer? n))
+       (i v0 v1 n))
+      (else
+       (f v0 v1 n))))
+  
+  (define (material face pname param)
+    (let ((v0 (face-table face 'material))
+          (v1 (material-pname-table pname 'material)))
+      (unless (= v1 GL_SHININESS)
+        (error 'material "does not accept ~a, use material-v instead" pname))
+      (do-f param v0 v1 glMateriali glMaterialf 'material face pname)))
+    
+  (define (material-v face pname params)
+    (let ((v0 (face-table face 'material-v))
+          (v1 (material-pname-table pname 'material-v))
+          (f (get-f params glMaterialiv glMaterialfv 'material-v face pname)))
+      (cond
+        ((= GL_SHININESS v1)
+         (check-length 'material-v params 1 pname))
+        ((= GL_COLOR_INDEXES v1)
+         (check-length 'material-v params 3 pname))
+        (else
+         (check-length 'material-v params 4 pname)))
+      (f v0 v1 params)))
+  
+  (make-enum-table light-light-table
+                   GL_LIGHT0 GL_LIGHT1 GL_LIGHT2 GL_LIGHT3
+                   GL_LIGHT4 GL_LIGHT5 GL_LIGHT6 GL_LIGHT7)
+  (make-enum-table light-pname-table
+                   GL_AMBIENT GL_DIFFUSE GL_SPECULAR GL_POSITION
+                   GL_SPOT_DIRECTION
+                   GL_SPOT_EXPONENT GL_SPOT_CUTOFF
+                   GL_CONSTANT_ATTENUATION GL_LINEAR_ATTENUATION
+                   GL_QUADRATIC_ATTENUATION)
+  (define (light light pname param)
+    (let ((v0 (light-light-table light 'light))
+          (v1 (light-pname-table pname 'light)))
+      (unless (memv v1 `(,GL_SPOT_EXPONENT ,GL_SPOT_CUTOFF
+                         ,GL_CONSTANT_ATTENUATION ,GL_LINEAR_ATTENUATION
+                         ,GL_QUADRATIC_ATTENUATION))
+        (error 'light "does not accept ~a, use light-v instead" pname))
+      (do-f param v0 v1 glLighti glLightf 'light light pname)))
+            
+  (define (light-v light pname params)
+    (let ((v0 (light-light-table light 'light-v))
+          (v1 (light-pname-table pname 'light-v))
+          (f (get-f params glLightiv glLightfv 'light-v light pname)))
+      (cond
+        ((= GL_SPOT_DIRECTION v1)
+         (check-length 'light-v params 3 pname))
+        ((memv v1 `(,GL_AMBIENT ,GL_DIFFUSE ,GL_SPECULAR ,GL_POSITION))
+         (check-length 'light-v params 4 pname))
+        (else
+         (check-length 'light-v params 1 pname)))
+      (f v0 v1 params)))
+      
+  (make-enum-table light-model-table
+                   GL_LIGHT_MODEL_AMBIENT
+                   GL_LIGHT_MODEL_COLOR_CONTROL
+                   GL_LIGHT_MODEL_LOCAL_VIEWER
+                   GL_LIGHT_MODEL_TWO_SIDE)
+  
+  (define (light-model pname param)
+    (let ((v (light-model-table pname 'light-model)))
+      (when (= GL_LIGHT_MODEL_AMBIENT v)
+        (error 'light-model "does not accept ~a, use light-model-v instead" pname))
+      (unless (real? param)
+        (raise-type-error 'light-model "real number" 1 pname param))
+      (cond
+        ((and (exact? param) (integer? param))
+         (glLightModeli v param))
+        (else
+         (glLightModelf v param)))))
+      
+  (define (light-model-v pname params)
+    (let ((v (light-model-table pname 'light-model-v))
+          (f (cond
+               ((gl-int-vector? params) glLightModeliv)
+               ((gl-float-vector? params) glLightModelfv)
+               (else
+                (raise-type-error 'light-model-v
+                                  "gl-int-vector or gl-float-vector"
+                                  1 pname params)))))
+      (cond
+        ((= GL_LIGHT_MODEL_AMBIENT v)
+         (check-length 'light-model-v params 4 pname))
+        (else 
+         (check-length 'light-model-v params 1 pname)))
+      (f v params)))
+      
+  ;; 2.14.3
+  (_provide color-material)
+  (make-enum-table color-material-mode-table
+                   GL_EMISSION GL_AMBIENT GL_DIFFUSE
+                   GL_SPECULAR GL_AMBIENT_AND_DIFFUSE)
+  (define (color-material x y)
+    (glColorMaterial (face-table x 'color-material)
+                     (color-material-mode-table y 'color-material)))
+  
+  ;; 2.14.7
+  (_provide shade-model)
+  (make-enum-table shade-model-table GL_FLAT GL_SMOOTH)
+  (define (shade-model x)
+    (glShadeModel (shade-model-table x 'shade-model)))
+
+  ;; 3.3 
+  (_provide (rename glPointSize point-size)
+            point-parameter point-parameter-v)
+  (make-enum-table point-parameter-table
+                   GL_POINT_SIZE_MIN GL_POINT_SIZE_MAX
+                   GL_POINT_DISTANCE_ATTENUATION
+                   GL_POINT_FADE_THRESHOLD_SIZE)
+  (define (point-parameter pname param)
+    (let ((v (point-parameter-table pname 'point-parameter)))
+      (when (= GL_POINT_DISTANCE_ATTENUATION v)
+        (error 'point-parameter "does not accept ~a, use point-parameter-v instead" pname))
+      (unless (real? param)
+        (raise-type-error 'point-parameter "real number" 1 pname param))
+      (cond
+        ((and (exact? param) (integer? param))
+         (glPointParameteri v param))
+        (else
+         (glPointParameterf v param)))))
+  (define (point-parameter-v pname params)
+    (let ((v (point-parameter-table pname 'point-parameter))
+          (f (cond
+               ((gl-int-vector? params) glPointParameteriv)
+               ((gl-float-vector? params) glPointParameterfv)
+               (else
+                (raise-type-error 'point-parameter-v
+                                  "gl-int-vector or gl-float-vector"
+                                  1 pname params)))))
+      (cond
+        ((= GL_POINT_DISTANCE_ATTENUATION v)
+         (check-length 'point-parameter-v 3 pname))
+        (else 
+         (check-length 'light-model-v 1 pname)))
+      (f v params)))
+
+  ;; 3.4
+  (_provide (rename glLineWidth line-width))
+  
+  ;; 3.4.2
+  (_provide (rename glLineStipple line-stipple))
+  
+  ;; 3.5.1
+  (_provide cull-face)  
+  (define (cull-face x)
+    (glCullFace (face-table x)))
+
+  ;; 3.5.2
+  ;; polygon-stipple
+
+  ;;3.5.4
+  (_provide polygon-mode)
+  (make-enum-table polygon-mode-mode-table GL_POINT GL_LINE GL_FILL)
+  (define (polygon-mode x y)
+    (glPolygonMode (face-table x 'polygon-mode)
+                   (polygon-mode-mode-table y 'polygon-mode)))
+
+  ;; 3.5.5
+  (_provide (rename glPolygonOffset polygon-offset))
+  
+  ;; 3.6.1
+  (_provide pixel-store)
+  (make-enum-table pixel-store-table 
+                   GL_UNPACK_SWAP_BYTES GL_UNPACK_LSB_FIRST
+                   GL_UNPACK_ROW_LENGTH GL_UNPACK_SKIP_ROWS
+                   GL_UNPACK_SKIP_PIXELS GL_UNPACK_ALIGNMENT
+                   GL_UNPACK_IMAGE_HEIGHT GL_UNPACK_SKIP_IMAGES)
+  (define (pixel-store pname param)
+    (let ((v (pixel-store-table pname 'pixel-store)))
+      (unless (real? param)
+        (raise-type-error 'pixel-store
+                          "real number"
+                          1 pname param))
+      (cond
+        ((and (exact? param) (integer? param))
+         (glPixelStorei v param))
+        (else
+         (glPixelStoref v param)))))
+  
+  ;; 3.6.3, 3.6.4, 3.6.5, 3.7, 3.8, 3.10 not implemented
+  
+  ;; 4.1.2
+  (_provide (rename glScissor scissor))
+  
+  ;; 4.1.3
+  (_provide (rename glSampleCoverage sample-coverage))
+  
+  ;; 4.1.4
+  (_provide alpha-func)
+  (make-enum-table func-table
+                   GL_NEVER GL_ALWAYS GL_LESS GL_LEQUAL GL_EQUAL
+                   GL_GEQUAL GL_GREATER GL_NOTEQUAL)
+  (define (alpha-func func ref)
+    (glAlphaFunc (func-table func 'alpha-func) ref))
+  
+  ;; 4.1.5
+  (_provide stencil-func stencil-op)
+  (define (stencil-func func ref mask)
+    (glStencilFunc (func-table func 'stencil-func) ref mask))
+
+  (make-enum-table stencil-op-table
+                   GL_KEEP GL_ZERO GL_REPLACE GL_INCR GL_DECR GL_INVERT
+                   GL_INCR_WRAP GL_DECR_WRAP)
+  (define (stencil-op sfail dpfail dppass)
+    (glStencilOp (stencil-op-table sfail 'stencil-op)
+                 (stencil-op-table dpfail 'stencil-op)
+                 (stencil-op-table dppass 'stencil-op)))
+                 
+  ;; 4.1.6
+  (_provide depth-func)
+  (define (depth-func func)
+    (glDepthFunc (func-table func 'depth-func)))
+
+  ;; 4.1.7
+  (_provide begin-query end-query
+            (rename glGenQueries gen-queries)
+            (rename glDeleteQueries delete-queries))
+  (make-enum-table query-table GL_SAMPLES_PASSED)
+  (define (begin-query target id)
+    (glBeginQuery (query-table target 'begin-query) id))
+  (define (end-query target)
+    (glEndQuery (query-table target 'end-query)))
+                      
+
+  ;; 4.1.8
+  (_provide blend-equation blend-func blend-func-separate 
+            (rename glBlendColor blend-color))
+
+  (make-enum-table blend-equation-table
+                   GL_FUNC_ADD GL_FUNC_SUBTRACT GL_FUNC_REVERSE_SUBTRACT
+                   GL_MIN GL_MAX)
+  (define (blend-equation func)
+    (glBlendEquation (blend-equation-table func 'blend-equation)))
+  
+  (make-enum-table blend-func-table
+		   GL_ZERO GL_ONE
+                   GL_SRC_COLOR GL_ONE_MINUS_SRC_COLOR
+		   GL_DST_COLOR GL_ONE_MINUS_DST_COLOR
+                   GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA
+                   GL_DST_ALPHA GL_ONE_MINUS_DST_ALPHA
+                   GL_CONSTANT_COLOR GL_ONE_MINUS_CONSTANT_COLOR
+                   GL_CONSTANT_ALPHA GL_ONE_MINUS_CONSTANT_ALPHA
+                   GL_SRC_ALPHA_SATURATE)
+  (define (blend-func src dest)
+    (glBlendFunc (blend-func-table src 'blend-func)
+		 (blend-func-table dest 'blend-func)))
+
+  (define (blend-func-separate src dest src-alpha dst-alpha)
+    (glBlendFuncSeparate (blend-func-table src 'blend-func)
+                         (blend-func-table dest 'blend-func)
+                         (blend-func-table src-alpha 'blend-func)
+                         (blend-func-table dst-alpha 'blend-func)))
+
+  ;; 4.1.10
+  (provide logic-op)
+  (make-enum-table logic-op-table
+                   GL_CLEAR GL_AND GL_AND_REVERSE GL_COPY GL_AND_INVERTED 
+                   GL_NOOP GL_XOR GL_OR GL_NOR GL_EQUIV GL_INVERT GL_OR_REVERSE
+                   GL_COPY_INVERTED GL_OR_INVERTED GL_NAND GL_SET)
+  (define (logic-op op)
+    (glLogicOp logic-op-table op 'logic-op))
+
+  ;; 4.2.1
+  (provide draw-buffer)
+  (make-enum-table draw-buffer-table
+                   GL_NONE GL_FRONT_LEFT GL_FRONT_RIGHT GL_BACK_LEFT
+                   GL_BACK_RIGHT GL_FRONT GL_BACK GL_LEFT GL_RIGHT
+                   GL_FRONT_AND_BACK
+                   GL_AUX0 GL_AUX1 GL_AUX2 GL_AUX3)
+  (define (draw-buffer buf)
+    (glDrawBuffer (draw-buffer-table buf 'draw-buffer)))
+
+  ;; 4.2.2
+  (_provide (rename glIndexMask index-mask)
+            (rename glColorMask color-mask)
+            (rename glDepthMask depth-mask)
+            (rename glStencilMask stencil-mask))
+  
+  ;; 4.2.3
+  (_provide clear
+            (rename glClearColor clear-color)
+            (rename glClearIndex clear-index)
+            (rename glClearDepth clear-depth)
+            (rename glClearStencil clear-stencil)
+            (rename glClearAccum clear-accum))
+  (make-enum-table clear-table
+                   GL_ACCUM_BUFFER_BIT GL_COLOR_BUFFER_BIT
+                   GL_DEPTH_BUFFER_BIT GL_STENCIL_BUFFER_BIT)
+  (define clear
+    (lambda x
+      (glClear (apply bitwise-ior (map (lambda (x)
+                                         (clear-table x 'clear))
+                                       x)))))
+
+  ;; 4.2.4
+  (_provide accum)
+  (make-enum-table accum-table
+                   GL_ACCUM GL_MULT GL_RETURN GL_MULT GL_ADD)
+  (define (accum op value)
+    (glAccum (accum-table op 'accum) value))
+
+  ;; 4.3.2 not implemented
+
+  ;; 4.3.3
+  (_provide copy-pixels)
+  (make-enum-table copy-pixels-table
+                   GL_COLOR GL_STENCIL GL_DEPTH)
+  (define (copy-pixels a b c d e)
+    (glCopyPixels a b c d (copy-pixels-table e 'copy-pixels)))
+
+  ;; 5.1
+  (_provide ;map1 map2
+            eval-coord eval-coord-v map-grid eval-mesh eval-point)
+  (multi-arg eval-coord glEvalCoord () (1 2))
+  (multi-type-v eval-coord-v glEvalCoord () (1 2) (dv fv) #t)
+  (define map-grid
+    (case-lambda
+      ((n a b) (glMapGrid1d n a b))
+      ((m a b n c d) (glMapGrid2d m a b n c d))))
+  (make-enum-table eval-mesh-table GL_POINT GL_LINE)
+  (define eval-mesh
+    (case-lambda
+      ((e a b) (glEvalMesh1 (eval-mesh-table e 'eval-mesh) a b))
+      ((e a b c d) (glEvalMesh2 (eval-mesh-table e 'eval-mesh) a b c d))))
+  (define eval-point
+    (case-lambda 
+      ((x) (glEvalPoint1 x))
+      ((x y) (glEvalPoint2 x y))))
+
+  ;; 5.2
+  (_provide (rename glInitNames init-names)
+            (rename glPopName pop-name)
+            (rename glPushName push-name)
+            (rename glLoadName load-name)
+            render-mode
+            select-buffer->gl-uint-vector)
+  (make-enum-table render-mode-table GL_RENDER GL_SELECT GL_FEEDBACK)
+  (define (render-mode x)
+    (glRenderMode (render-mode-table x 'render-mode)))
+
+  ;; 5.3
+  (_provide feedback-buffer->gl-float-vector
+            (rename glPassThrough pass-through))
+  
+  ;; 5.4
+  (_provide new-list
+            (rename glEndList end-list)
+            (rename glCallList call-list)
+            ;call-lists
+            (rename glListBase list-base)
+            (rename glGenLists gen-lists)
+            (rename glIsList is-list)
+            (rename glDeleteLists delete-lists))
+  (make-enum-table new-list-table GL_COMPILE GL_COMPILE_AND_EXECUTE)
+  (define (new-list n mode)
+    (glNewList n (new-list-table mode 'new-list)))
+
+  ;; 5.5
+  (_provide (rename glFlush flush)
+            (rename glFinish finish))
+  
+  ;; 5.6
+  (_provide hint)
+  (make-enum-table hint-target-table
+                   GL_PERSPECTIVE_CORRECTION_HINT GL_POINT_SMOOTH_HINT
+                   GL_LINE_SMOOTH_HINT GL_POLYGON_SMOOTH_HINT GL_FOG_HINT
+                   GL_GENERATE_MIPMAP_HINT GL_TEXTURE_COMPRESSION_HINT)
+  (make-enum-table hint-hint-table GL_FASTEST GL_NICEST GL_DONT_CARE)
+  (define (hint target hint)
+    (glHint (hint-target-table target 'hint)
+            (hint-hint-table hint 'hint)))
+
+  ;; 6.1.1
+  (_provide ;glGetBooleanv glGetIntegerv glGetFloatv glGetDoublev
+            is-enabled)
+  (define (is-enabled e)
+    (glIsEnabled (enable-table e 'is-enabled)))
+
+  ;; 6.1.3, 6.1.4, 6.1.5, 6.1.7, 6.1.8, 6.1.9, 6.1.10 not implemented
+
+  ;; 6.1.11
+  (_provide ;get-pointer-v
+            get-string)
+  
+  (make-enum-table get-string-table
+                   GL_VENDOR GL_RENDERER GL_VERSION GL_EXTENSIONS)
+  (define (get-string x)
+    (glGetString (get-string-table x 'get-string)))
+
+  ;; 6.1.12
+  (_provide (rename glIsQuery is-query)
+            ;get-query get-query-object
+            )
+  
+  ;; 6.1.13
+  (_provide (rename glIsBuffer is-buffer)
+            ; get-buffer-sub-data get-buffer-pointer-v
+            )
+  
+  ;; 6.1.14
+  (_provide push-attrib push-client-attrib
+            (rename glPopAttrib pop-attrib)
+            (rename glPopClientAttrib pop-client-attrib))
+  (make-enum-table push-attrib-table
+                   GL_ACCUM_BUFFER_BIT GL_COLOR_BUFFER_BIT GL_CURRENT_BIT
+                   GL_DEPTH_BUFFER_BIT GL_ENABLE_BIT GL_EVAL_BIT GL_FOG_BIT GL_HINT_BIT
+                   GL_LIGHTING_BIT GL_LINE_BIT GL_LIST_BIT GL_MULTISAMPLE_BIT
+                   GL_PIXEL_MODE_BIT GL_POINT_BIT GL_POLYGON_BIT GL_POLYGON_STIPPLE_BIT
+                   GL_SCISSOR_BIT GL_STENCIL_BUFFER_BIT GL_TEXTURE_BIT
+                   GL_TRANSFORM_BIT GL_VIEWPORT_BIT GL_ALL_ATTRIB_BITS)
+  (define push-attrib 
+    (lambda x
+      (glPushAttrib (apply bitwise-ior (map (lambda (x)
+                                              (push-attrib-table x 'clear))
+                                            x)))))
+  (make-enum-table push-client-attrib-table
+                   GL_CLIENT_VERTEX_ARRAY_BIT
+                   GL_CLIENT_PIXEL_STORE_BIT
+                   GL_CLIENT_ALL_ATTRIB_BITS)
+  (define push-client-attrib 
+    (lambda x
+      (glPushClientAttrib (apply bitwise-ior
+                                 (map (lambda (x)
+                                        (push-client-attrib-table x 'clear))
+                                      x)))))
+  
+  
+  
+  ;; 2
+  (_provide u-get-string
+            (rename gluCheckExtension check-extension))
+  (make-enum-table u-get-string-table GLU_VERSION GLU_EXTENSIONS)
+  (define (u-get-string x)
+    (gluGetString (u-get-string-table x 'u-get-string)))
+
+  ;; 3 not implemented
+
+  ;; 4.1
+  (_provide (rename gluOrtho2D ortho-2d)
+            (rename gluPerspective perspective)
+            (rename gluLookAt look-at)
+            pick-matrix)
+  (define (pick-matrix a b c d v)
+    (unless (gl-int-vector? v)
+      (raise-type-error 'pick-matrix
+                        "gl-int-vector"
+                        4 a b c d v))
+    (check-length 'pick-matrix v 4)
+    (gluPickMatrix a b c d v))
+           
+  ;; 4.2
+  (_provide project un-project un-project4)
+  (define (project a b c d e f)
+    (unless (gl-double-vector? d)
+      (raise-type-error 'project
+                        "gl-double-vector"
+                        3 a b c d e f))
+    (unless (gl-double-vector? e)
+      (raise-type-error 'project
+                        "gl-double-vector"
+                        4 a b c d e f))
+    (unless (gl-int-vector? f)
+      (raise-type-error 'project
+                        "gl-double-vector"
+                        5 a b c d e f))
+    (check-length 'project d 16)
+    (check-length 'project e 16)
+    (check-length 'project f 4)
+    (gluProject a b c d e f))
+
+  (define (un-project a b c d e f)
+    (unless (gl-double-vector? d)
+      (raise-type-error 'un-project
+                        "gl-double-vector"
+                        3 a b c d e f))
+    (unless (gl-double-vector? e)
+      (raise-type-error 'un-project
+                        "gl-double-vector"
+                        4 a b c d e f))
+    (unless (gl-int-vector? f)
+      (raise-type-error 'un-project
+                        "gl-double-vector"
+                        5 a b c d e f))
+    (check-length 'un-project d 16)
+    (check-length 'un-project e 16)
+    (check-length 'un-project f 4)
+    (gluUnProject a b c d e f))
+
+  (define (un-project4 a b c d e f g h i)
+    (unless (gl-double-vector? e)
+      (raise-type-error 'un-project
+                        "gl-double-vector"
+                        4 a b c d e f g h i))
+    (unless (gl-double-vector? f)
+      (raise-type-error 'un-project
+                        "gl-double-vector"
+                        5 a b c d e f g h i))
+    (unless (gl-int-vector? g)
+      (raise-type-error 'un-project
+                        "gl-double-vector"
+                        6 a b c d e f g h i))
+    (check-length 'un-project4 e 16)
+    (check-length 'un-project4 f 16)
+    (check-length 'un-project4 g 4)
+    (gluUnProject4 a b c d e f g h i))                        
+  
+  ;; 5 not implemented
+  
+  ;; 6.1
+  (_provide (rename gluNewQuadric new-quadric))
+  
+  ;; 6.2 not implemented
+  
+  ;; 6.3
+  (_provide quadric-normals 
+            (rename gluQuadricTexture quadric-texture)
+            quadric-orientation quadric-draw-style)
+  
+  (make-enum-table quadric-normals-table GLU_NONE GLU_FLAT GLU_SMOOTH)
+  (define (quadric-normals q e)
+    (gluQuadricNormals q (quadric-normals-table e 'quadric-normals)))
+    
+  (make-enum-table quadric-orientation-table GLU_INSIDE GLU_OUTSIDE)
+  (define (quadric-orientation q e)
+    (gluQuadricOrientation q (quadric-orientation-table e 'quadric-normals)))
+    
+  (make-enum-table quadric-draw-style-table
+                   GLU_POINT GLU_LINE GLU_SILHOUETTE GLU_FILL)
+  (define (quadric-draw-style q e)
+    (gluQuadricDrawStyle q (quadric-draw-style-table e 'quadric-draw-style)))
+  
+  ;; 6.4
+  (_provide (rename gluCylinder cylinder)
+            (rename gluDisk disk)
+            (rename gluSphere sphere)
+            (rename gluPartialDisk partial-disk))
+  
+  ;; 7 not implemented
+  
+  ;; 8
+  (_provide ;error-string
+            )
+  
+  ;; Utils
+  
+  (_provide process-selection (struct selection-record (min-z max-z stack)))
+  ;; A selection-record is
+  ;; (make-selection-record number number (listof positive-int))
+  (define-struct selection-record (min-z max-z stack))  
+
+  ;; process-selection : gl-uint-vector int -> (listof selection-record)
+  (define (process-selection v hits)
+    (unless (gl-uint-vector? v)
+      (raise-type-error 'process-selection
+                        "gl-uint-vector"
+                        0 v hits))
+    (let ((index 0))
+      (let loop ((hit 0))
+        (cond
+          ((>= hit hits) null)
+          (else
+           (let ((stack-size (gl-vector-ref v index)))
+             (cons (make-selection-record 
+                    (gl-vector-ref v (add1 index))
+                    (gl-vector-ref v (+ index 2))
+                    (begin
+                      (set! index (+ 3 index))
+                      (let loop ((j 0))
+                        (cond
+                          ((< j stack-size)
+                           (cons (gl-vector-ref v index)
+                                 (begin
+                                   (set! index (add1 index))
+                                   (loop (add1 j)))))
+                          (else null)))))
+                   (loop (add1 hit)))))))))
+  
+  (provide get-gl-version-number get-glu-version-number)
+  (define (get-gl-version-number)
+    (let ((x (regexp-match "^([0-9]*)\\.([0-9*])" (get-string 'version))))
+      (string->number (string-append (cadr x) (caddr x)))))
+  (define (get-glu-version-number)
+    (let ((x (regexp-match "^([0-9]*)\\.([0-9*])" (u-get-string 'version))))
+      (string->number (string-append (cadr x) (caddr x)))))
+
+  
+  
+  )
diff --git a/collects/sirmail/doc.txt b/collects/sirmail/doc.txt
new file mode 100644
index 0000000000..ee06dde655
--- /dev/null
+++ b/collects/sirmail/doc.txt
@@ -0,0 +1,128 @@
+
+_SirMail_ is a _IMAP_ mail client. The current version has a number of
+rough edges, but it is quite useful to the authors.
+
+Caveat: All marks (used for deletion and copying) are local to the
+client. SirMail doesn't use the \Deleted IMAP flag until it is ready
+to delete marked messages. Also, it pays no attention to \Deleted
+flags when synchronizing. However, SirMail removes a \Delete flags
+from a mailbox before purging marked messages. This prevents SirMail
+from accidentally removing messages that you didn't mark within
+SirMail (on the local machine).
+
+Terminology: The GUI uses the term "Folder" everywhere instead of
+"Mailbox". The latter term matches the IMAP specification.
+
+------------------------------------------------------------
+
+Configure SirMail options by visiting Edit | Preferences in a
+mail-reading or mail-sending window. If the current (or default)
+options do not allow SirMail to start up, you get just the preferences
+dialog, and you must try running again after setting the preferences.
+
+Reading panel:
+
+  - Username: The username to use when logging into the server.
+
+  - IMAP Server: The IMAP server's host name (incoming mail).
+    Use a ":<portno>" suffix on the host name to connect to
+    port <portno>.
+
+  - Local Directory: The pathname of an existing directory where
+    SirMail should store downloaded messages.  Defaults to
+     (build-path (find-system-path 'home-dir) "SirMail")
+
+  - Folder List Root: Names a mailbox to use as the root in the mailbox
+    folder list window. If this option is not provided, the folder list
+    window is not available.
+    
+  - Auto-File Table File: The file should contain an expression that
+    reads as a value of the shape
+
+      (list-of (list mailbox-name-string 
+                     (list-of (list field-string regexp-string))))
+
+    which specifies where messages should be autofiled based on
+    regular expression matching of various headers in the email. For
+    any email, if it has a header named `field-string' that mathces
+    `regexp-string', it is filed into `mailbox-name-string'.
+
+  - Shown Header Fields: Names header fields to to (in order_ when
+    reading a message.
+
+Sending panel:
+
+  - Mail From: The user's email address.
+
+  - SMTP Server: The SMTP server's host name (outgoing mail).  Use a
+    ":<portno>" suffix on the host name to connect to port
+    <portno>. Supply multiple SMTP hosts by separating the addresses
+    with a comma; the "File" menu of mail-sending frame will let you
+    choose a specific server.
+
+  - Default To Domain: If a destination address that isn't declared as
+    an alias doesn't include a domain name, SirMail automatically
+    appends this as the domain.  (For instance, say you tend to work
+    at cs.brown.edu and tend to send most of your mail to cs.brown.edu
+    users.  However, your SMTP server is an ISP you use from home.  By
+    default, the server will attempt to deliver the (un-aliased)
+    address `foo' to foo@your-isp.com.  Setting the Default To
+    Domain to `cs.brown.edu' will deliver this to foo@cs.brown.edu
+    instead, irrespective of what SMTP server you use.
+
+  - Save Sent Files: Check this if you want a copy of messages you
+    sent to be saved in an archive, the set it to a directory where
+    SirMail should save outgoing messages.
+
+  - Aliases File: SirMail uses this file to resolve shortcut mail
+    addresses when sending mail. The file should contain an expression
+    that reads as a value of the shape
+
+      (list-of (list string (union string (list-of string))))
+
+    specifing a mapping from names to one or more email
+    addresses. These names can be used in the "To", "cc", or "bcc"
+    headers of your email address.
+
+    Aliases are expanded recursively.
+
+  - Self Addresses: Strings naming your email addresses so followups do
+    not go to yourself.
+
+
+Internal options that still need preference-panel support:
+
+  - biff-delay-seconds: (union #f number); when number specifies how long
+    between sirmail waits before polling the mailbox. Only polls when
+    connected.
+
+  - sort-by: (union #f 'date 'subject 'from 'id); specifies the
+    initial storting of opened mailboxes. 
+    'id indicates sorting by order received and #f means no sorting.
+    These should produce the same ordering, but 'id is probably a bit slower.
+
+  - show-urls: (union 'on 'off), defaults to 'on
+    If this is 'on, it hilights urls in the text. Clicking on the
+    urls will open a web browser, pointing it at that url.
+
+-------------------------------------------------------------------
+
+Implementation Note:
+
+The format of a "mailboxes" file is a list of entries, where each
+entry is a list of at least two elements:
+
+ The first element is the local directory for the mailbox's messages.
+
+ The second element is the mailbox name for the IMAP server. 
+
+ The rest are overriding options. For example, there's no easy way to
+ move my Rice mailboxes to Utah, so I just access them from Rice on the
+ rare occasions when I need them. For each of my Rice mailboxes, the
+ "mailboxes" entry contains all the configuration options that apply to
+ Rice. Nothing in SirMail ever writes new options into "mailboxes"; I
+ add them by hand, and SirMail preserves them. 
+
+The overidding-options feature was a quick hack for what I needed, and
+it should be replaced eventually. There's a lot of duplication of
+information in the current format.
diff --git a/collects/sirmail/emoticon/bigsmile.gif b/collects/sirmail/emoticon/bigsmile.gif
new file mode 100644
index 0000000000..be0ff37842
Binary files /dev/null and b/collects/sirmail/emoticon/bigsmile.gif differ
diff --git a/collects/sirmail/emoticon/cry.gif b/collects/sirmail/emoticon/cry.gif
new file mode 100644
index 0000000000..73e6d4dd0a
Binary files /dev/null and b/collects/sirmail/emoticon/cry.gif differ
diff --git a/collects/sirmail/emoticon/happy.gif b/collects/sirmail/emoticon/happy.gif
new file mode 100644
index 0000000000..f42a6c456d
Binary files /dev/null and b/collects/sirmail/emoticon/happy.gif differ
diff --git a/collects/sirmail/emoticon/kiss.gif b/collects/sirmail/emoticon/kiss.gif
new file mode 100644
index 0000000000..dd48636e25
Binary files /dev/null and b/collects/sirmail/emoticon/kiss.gif differ
diff --git a/collects/sirmail/emoticon/sad.gif b/collects/sirmail/emoticon/sad.gif
new file mode 100644
index 0000000000..187d1f3fbe
Binary files /dev/null and b/collects/sirmail/emoticon/sad.gif differ
diff --git a/collects/sirmail/emoticon/tongue.gif b/collects/sirmail/emoticon/tongue.gif
new file mode 100644
index 0000000000..f13f18a25c
Binary files /dev/null and b/collects/sirmail/emoticon/tongue.gif differ
diff --git a/collects/sirmail/emoticon/wink.gif b/collects/sirmail/emoticon/wink.gif
new file mode 100644
index 0000000000..f498912328
Binary files /dev/null and b/collects/sirmail/emoticon/wink.gif differ
diff --git a/collects/sirmail/folder-mask.xbm b/collects/sirmail/folder-mask.xbm
new file mode 100644
index 0000000000..b1c1dc8894
--- /dev/null
+++ b/collects/sirmail/folder-mask.xbm
@@ -0,0 +1,6 @@
+#define mred_width 16
+#define mred_height 16
+static char mred_bits[] = {
+ 0x00,0x00,0x1e,0x00,0x3f,0x00,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
+ 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xfe,0x7f,
+ 0x00,0x00};
diff --git a/collects/sirmail/folder.bmp b/collects/sirmail/folder.bmp
new file mode 100644
index 0000000000..6227e286ec
Binary files /dev/null and b/collects/sirmail/folder.bmp differ
diff --git a/collects/sirmail/folderr.ss b/collects/sirmail/folderr.ss
new file mode 100644
index 0000000000..c276c66ae4
--- /dev/null
+++ b/collects/sirmail/folderr.ss
@@ -0,0 +1,472 @@
+
+(module folderr mzscheme
+  (require (lib "unitsig.ss")
+           (lib "class.ss")
+           (lib "framework.ss" "framework")
+           (lib "mred-sig.ss" "mred"))
+  
+  (require (lib "list.ss")
+           (lib "etc.ss"))
+  
+  (require "sirmails.ss"
+           "pref.ss")
+  
+  (require (lib "imap-sig.ss" "net"))
+  
+  (require (lib "hierlist-sig.ss" "hierlist"))
+
+  (require (lib "openssl.ss" "openssl"))
+  
+  (provide folder@)
+  (define folder@
+    (unit/sig ()
+      (import sirmail:environment^
+              (shutdown-folders-window)
+              sirmail:options^
+              mred^
+              net:imap^
+              hierlist^)
+  
+      (define (show-error x frame)
+	(message-box "Error" 
+		     (if (exn? x)
+			 (exn-message x)
+			 (format "Strange exception: ~s" x))
+		     frame
+		     '(ok stop)))
+        
+      (define mailbox-cache-file (build-path (LOCAL-DIR) "folder-window-mailboxes"))
+      
+      (define (imap-open-connection)
+        (let ([passwd
+               (or (get-PASSWORD)
+                   (let ([p (get-text-from-user "Password" 
+                                                (format "Password for ~a:" (USERNAME))
+                                                frame
+                                                ""
+                                                '(password))])
+                     (unless p (error 'connect "connection cancelled"))
+                     p))])
+          (let-values ([(server port-no)
+                        (parse-server-name (IMAP-SERVER) (if (get-pref 'sirmail:use-ssl?) 993 143))])
+            (begin0
+	      (if (get-pref 'sirmail:use-ssl?)
+		  (let-values ([(in out) (ssl-connect server port-no)])
+		    (imap-connect* in out (USERNAME) passwd mailbox-name))
+		  (parameterize ([imap-port-number port-no])
+		    (imap-connect server (USERNAME) 
+		                  passwd
+                                  mailbox-name)))
+              (unless (get-PASSWORD)
+                (set-PASSWORD passwd))))))
+
+      (define imap-mailbox-name-mixin
+        (lambda (list%)
+          (class list%
+            (field
+             [full-mailbox-name 'unknown-full-mailbox-name]
+             [is-selectable? #f])
+            [define/public set-full-mailbox-name
+              (lambda (fm)
+                (set! full-mailbox-name fm))]
+            [define/public get-full-mailbox-name
+             (lambda ()
+               full-mailbox-name)]
+            [define/public set-selectable
+              (lambda (x) (set! is-selectable? x))]
+            [define/public selectable?
+              (lambda () is-selectable?)]
+            (super-instantiate ()))))
+      
+      (define imap-mailbox-list-mixin
+        (lambda (list%)
+          (class list%
+            (field
+             [mailbox-name 'unknown-mailbox-name])
+            [define/public get-mailbox-name
+              (lambda ()
+                mailbox-name)]
+            [define/public set-mailbox-name
+              (lambda (m)
+                (set! mailbox-name m))]
+            (super-instantiate ()))))
+      
+      ;; mailbox-folder = (make-deep-folder (union #f bytes)
+      ;;                                    (union #f string)
+      ;;                                    bool
+      ;;                                    nested-mailbox-folder)
+      ;; nested-mailbox-folder = 
+      ;; (union (make-flat-folder bytes (union #f string) bool)
+      ;;        (make-deep-folder bytes (union #f string) bool (listof mailbox-folder)))
+      (define-struct folder (name short-name selectable?))
+      (define-struct (deep-folder folder) (children))
+      (define-struct (flat-folder folder) ())
+
+      ;; refresh-mailboxes : -> void
+      (define (refresh-mailboxes)
+        (let ([mailboxes (fetch-mailboxes)])
+          (when mailboxes
+            (write-mailbox-folder mailboxes)
+            (update-gui mailboxes))))
+
+      ;; write-mailbox-folder : mailbox-folder -> void
+      (define (write-mailbox-folder mbf)
+        (let ([raw-datum
+               (let loop ([mbf mbf])
+                 (cond
+                   [(flat-folder? mbf) (list (folder-name mbf)
+                                             (folder-short-name mbf))]
+                   [(deep-folder? mbf)
+                    (list (folder-name mbf)
+                          (folder-short-name mbf)
+                          (folder-selectable? mbf)
+                          (map loop (deep-folder-children mbf)))]
+                   [else (error 'write-mailbox-folder "unknown mailbox folder: ~e"
+                                mbf)]))])
+          (call-with-output-file mailbox-cache-file
+            (lambda (port)
+              (write raw-datum port))
+            'truncate 'text)))
+      
+      ;; read-mailbox-folder : -> mailbox-folder
+      (define (read-mailbox-folder)
+        (let* ([root-box (ROOT-MAILBOX-FOR-LIST)]
+               [default
+                (make-deep-folder (and root-box (string->bytes/utf-8 root-box))
+                                  root-box
+                                  #f ;; arbitrary
+                                  null)])
+          (if (file-exists? mailbox-cache-file)
+              (let/ec k
+                (let ([raw-datum (call-with-input-file mailbox-cache-file read 'text)])
+                  (let loop ([rd raw-datum])
+                    (cond
+                      [(and (= 2 (length rd))
+                            (or (not (car rd)) (bytes? (car rd)))
+                            (or (not (car rd)) (string? (cadr rd))))
+                       (make-flat-folder (car rd) (cadr rd) #t)]
+                      [(and (= 3 (length rd))
+                            (or (not (car rd)) (bytes? (car rd)))
+                            (or (not (car rd)) (string? (cadr rd)))
+                            (list? (caddr rd)))
+                       (make-deep-folder (car rd)
+                                         (cadr rd)
+                                         #f
+                                         (map loop (caddr rd)))]
+                      [(and (= 4 (length rd))
+                            (or (not (car rd)) (bytes? (car rd)))
+                            (or (not (cadr rd)) (string? (cadr rd)))
+                            (boolean? (caddr rd))
+                            (list? (cadddr rd)))
+                       (make-deep-folder (car rd)
+                                         (cadr rd)
+                                         (caddr rd)
+                                         (map loop (cadddr rd)))]
+                      [else (k default)]))))
+              default)))
+
+      
+      ;; fetch-mailboxes : -> (union #f mailbox-folder)
+      ;; gets the current mailbox list from the server
+      (define (fetch-mailboxes)
+        (with-custodian-killing-stop-button
+         "Updating folder list..."
+         (lambda ()
+           (let-values ([(imap msg-count recent-count) (imap-open-connection)]
+                        [(root-box) (ROOT-MAILBOX-FOR-LIST)])
+             (make-deep-folder
+              (and root-box (string->bytes/utf-8 root-box))
+              root-box
+              #f ;; arbitrary
+              (let loop ([mailbox-name (and root-box (string->bytes/utf-8 root-box))])
+                (let ([mailbox-name-length (if mailbox-name
+					       (bytes-length mailbox-name)
+					       0)]
+                      [get-child-mailbox-name (lambda (item) (second item))]
+                      [child-mailboxes (imap-list-child-mailboxes imap mailbox-name)])
+                  (map (lambda (item)
+                         (let* ([child-mailbox-name (get-child-mailbox-name item)]
+                                [child-mailbox-flags (first item)]
+                                [symbols (map imap-flag->symbol child-mailbox-flags)]
+                                [flat-mailbox? (or (member 'noinferiors symbols)
+						   (member 'hasnochildren symbols))]
+                                [selectable? (not (member 'noselect symbols))]
+                                [child-name-length (bytes-length child-mailbox-name)]
+                                [strip-prefix?
+                                 (and (> child-name-length mailbox-name-length)
+				      mailbox-name
+                                      (bytes=?
+                                       (subbytes child-mailbox-name 0 mailbox-name-length)
+                                       mailbox-name))]
+                                [short-name
+                                 (bytes->string/utf-8
+                                  (if strip-prefix?
+                                      (subbytes child-mailbox-name
+                                                ;; strip separator (thus add1)
+                                                (add1 mailbox-name-length)
+                                                child-name-length)
+                                      child-mailbox-name))])
+                           (if flat-mailbox?
+                               (make-flat-folder child-mailbox-name short-name #t)
+                               (make-deep-folder 
+                                child-mailbox-name
+                                short-name
+                                selectable?
+                                (loop child-mailbox-name)))))
+                       (quicksort
+                        child-mailboxes
+                        (lambda (x y)
+                          (string<=? (bytes->string/utf-8 (get-child-mailbox-name x))
+                                     (bytes->string/utf-8 (get-child-mailbox-name y)))))))))))))
+         
+      (define imap-mailbox-mixin
+        (compose 
+         imap-mailbox-list-mixin
+         imap-mailbox-name-mixin))
+      
+      (define imap-top-list% 
+        (class (imap-mailbox-list-mixin hierarchical-list%) 
+          (field
+           [selected-mailbox #f])
+          [define/public get-selected-mailbox
+            (lambda ()
+              selected-mailbox)]
+          (define/override on-select
+            (lambda (i)
+              (send frame set-status-text "")
+              (set! selected-mailbox (and i 
+                                          (send i selectable?)
+                                          (send i get-full-mailbox-name)))
+              (super on-select i)))
+          (define/override on-double-select
+            (lambda (i)
+              (when (and i (send i selectable?))
+                (let ([mail-box (send i get-full-mailbox-name)])
+                  (send frame set-status-text (format "Opening ~a" mail-box))
+                  (setup-mailboxes-file mail-box)
+                  (open-mailbox (bytes->string/utf-8 mail-box))))
+              (super on-double-select i)))
+          (super-instantiate ())))
+      
+      (define (update-gui orig-mbf)
+        (define (add-child hl mbf)
+          (let* ([deep? (deep-folder? mbf)]
+                 [new-item (if deep?
+                               (send hl new-list imap-mailbox-mixin)
+                               (send hl new-item imap-mailbox-name-mixin))]
+                 [text (send new-item get-editor)])
+            (send new-item set-full-mailbox-name (or (folder-name mbf) #""))
+            (send new-item set-selectable (folder-selectable? mbf))
+            (when deep?
+              (send new-item set-mailbox-name (or (folder-name mbf) #"")))
+            (send text insert (or (folder-short-name mbf) ""))
+            new-item))
+        (send (send top-list get-editor) begin-edit-sequence)
+        (for-each (lambda (x) (send top-list delete-item x))
+                  (send top-list get-items))
+	(for-each (lambda (mbf)
+		    (let loop ([hl top-list]
+			       [mbf mbf])
+		      (let ([new-item (add-child hl mbf)])
+			(when (deep-folder? mbf)
+			  (for-each (lambda (child) (loop new-item child))
+				    (deep-folder-children mbf))))))
+		  (cons (make-flat-folder (string->bytes/utf-8 mailbox-name) mailbox-name #t)
+			(deep-folder-children orig-mbf)))
+        (send (send top-list get-editor) end-edit-sequence))
+      
+      (define folders-frame%
+        (class frame:basic%
+          (define/override (on-size w h)
+            (put-pref 'sirmail:folder-window-w w)
+            (put-pref 'sirmail:folder-window-h h))
+          (define/override (on-move x y)
+            (put-pref 'sirmail:folder-window-x x)
+            (put-pref 'sirmail:folder-window-y y))
+          (define/augment (on-close)
+            (inner (void) on-close)
+            (shutdown-folders-window))
+          (define/override (on-message msg)
+            (let ([s (and (list? msg)
+                          (number? (car msg))
+                          (number? (cadr msg))
+                          (let ([gx (car msg)]
+                                [gy (cadr msg)])
+                            (let-values ([(x y) (send top-list screen->client gx gy)])
+                              (let ([lxb (box 0)]
+                                    [lyb (box 0)])
+                                (let loop ([ed (send top-list get-editor)])
+                                  (set-box! lxb x)
+                                  (set-box! lyb y)
+                                  (send ed global-to-local lxb lyb)
+                                  (let* ([on-it-b (box #f)]
+                                         [pos (send ed find-position (unbox lxb) (unbox lyb) #f on-it-b)])
+                                    (and (unbox on-it-b)
+                                         (let ([snip (send ed find-snip pos 'after-or-none)])
+                                           (cond
+                                             [(is-a? snip hierarchical-item-snip%)
+                                              (let ([item (send snip get-item)])
+                                                (send item get-full-mailbox-name))]
+                                             [(is-a? snip hierarchical-list-snip%)
+                                              (let ([ed (send snip get-content-buffer)])
+                                                (or (loop ed)
+                                                    (let ([i (send snip get-item)])
+                                                      (and (send i selectable?)
+                                                           (send i get-full-mailbox-name)))))]
+                                             [else #f])))))))))])
+              (send frame set-status-text (if s 
+                                              (format "Dragging to ~a" s)
+                                              ""))
+              s))
+          (define/public (get-mailbox-name)
+            (send top-list get-selected-mailbox))
+          (super-instantiate ())))
+      
+      (define icon (make-object bitmap% (build-path (collection-path "sirmail")
+                                                    "folder.bmp")))
+      (define icon-mask (make-object bitmap% (build-path (collection-path "sirmail")
+                                                         "folder-mask.xbm")))
+      (define frame (make-object folders-frame% "Folders" #f
+                      (get-pref 'sirmail:folder-window-w)
+                      (get-pref 'sirmail:folder-window-h)
+                      (max 0 (get-pref 'sirmail:folder-window-x))
+                      (max 0 (get-pref 'sirmail:folder-window-y))))
+      (define top-panel (instantiate horizontal-panel% ((send frame get-area-container))
+                          [alignment '(right center)]
+                          [stretchable-height #f]))
+      
+      (define re:setup-mailboxes (regexp "^([^/]*)/(.*)$"))
+      (define (setup-mailboxes-file bytes-mailbox-name)
+        (define mailbox-name (bytes->string/utf-8 bytes-mailbox-name))
+        (define mailboxes-file (build-path (LOCAL-DIR) "mailboxes"))
+        (define mailboxes
+          (with-handlers ([exn:fail? (lambda (x) '(("Inbox" #"inbox")))])
+            (with-input-from-file mailboxes-file
+              read)))
+        
+        (define mailbox-loc (assoc mailbox-name mailboxes))
+        
+        (unless mailbox-loc
+          
+          (let ([fns (let loop ([str mailbox-name])
+                       (cond
+                         [(regexp-match re:setup-mailboxes str)
+                          =>
+                          (lambda (m)
+                            (cons (cadr m)
+                                  (loop (caddr m))))]
+                         [else
+                          (if (string=? str "")
+                              null
+                              (list str))]))])
+            
+            (unless (null? fns)
+              (let ([mailbox-dir
+                     (let loop ([fns (if (string=? (car fns) "")
+                                         (cdr fns)
+                                         fns)]
+                                [local-dir 'same]
+                                [fs-dir (LOCAL-DIR)])
+                       (cond
+                         [(null? fns) local-dir]
+                         [else (let ([new-fs-dir (build-path fs-dir (car fns))])
+                                 (unless (directory-exists? new-fs-dir)
+                                   (make-directory new-fs-dir))
+                                 (loop (cdr fns)
+                                       (build-path local-dir (car fns))
+                                       new-fs-dir))]))])
+                
+                (with-output-to-file (build-path (LOCAL-DIR) "mailboxes")
+                  (lambda () (write
+                              (append mailboxes
+                                      (list (list mailbox-name
+						  (path->bytes mailbox-dir))))))
+                  'truncate))))))
+      
+      
+      (define refresh-mailbox-button
+        (instantiate button% ()
+          (label "Update Folder List")
+          (parent top-panel)
+          (callback (lambda (x y)
+                      (refresh-mailboxes)))))
+      
+      (define stop-thread #f)
+      (define stop-button
+        (instantiate button% ()
+          (label "Stop")
+          (parent top-panel)
+          (callback (lambda (x y)
+                      (when stop-thread
+                        (break-thread stop-thread))))))
+      
+      (send stop-button enable #f)
+      
+      (define (with-custodian-killing-stop-button what thunk)
+        (let ([c (make-custodian)]
+              [result #f])
+          (dynamic-wind
+           (lambda ()
+             (send frame set-status-text what)
+             (send (send frame get-menu-bar) enable #f)
+             (send top-list enable #f)
+             (send refresh-mailbox-button enable #f)
+             (send stop-button enable #t))
+           (lambda ()
+             (parameterize ([current-custodian c])
+               (set! stop-thread (thread (lambda ()
+                                           (with-handlers ([values (lambda (x)
+                                                                     (set! result x))])
+                                             (set! result (thunk))))))
+               (yield stop-thread)))
+           (lambda ()
+             (send frame set-status-text "")
+             (custodian-shutdown-all c)
+             (send (send frame get-menu-bar) enable #t)
+             (send top-list enable #t)
+             (send refresh-mailbox-button enable #t)
+             (send stop-button enable #f)))
+          (if (exn? result)
+              (raise result)
+              result)))
+             
+      
+      (define top-list (make-object imap-top-list% (send frame get-area-container)))
+      
+      (when (and (send icon ok?) (send icon-mask ok?))
+        (send frame set-icon icon icon-mask 'both))
+      
+      (define file-menu (make-object menu% "&File" (send frame get-menu-bar)))
+      (make-object menu-item% "&Add Folder..." file-menu
+        (lambda (i e)
+          (let ([t (get-text-from-user "New Folder" "New folder name:" frame)])
+            (when t
+              (when (with-custodian-killing-stop-button
+                     (format "Creating ~a" t)
+                     (lambda ()
+                       (let-values ([(imap x y) (imap-open-connection)])
+                         (imap-create-mailbox imap t))
+                       #t))
+                (refresh-mailboxes))))))
+      (make-object separator-menu-item% file-menu)
+      (make-object menu-item% "Close" file-menu
+		   (lambda (i e)
+		     (send frame close)))
+      
+      (frame:reorder-menus frame)
+      
+      (send frame show #t)
+      (send frame min-width 350)
+      (send frame min-height 450)
+      (send frame create-status-line)
+      (send top-list set-mailbox-name (ROOT-MAILBOX-FOR-LIST))
+      (update-gui (read-mailbox-folder))
+
+      (initial-exception-handler
+         (lambda (x)
+           (show-error x frame)
+           ((error-escape-handler))))
+      (current-exception-handler
+       (initial-exception-handler))
+      
+      frame)))
diff --git a/collects/sirmail/info.ss b/collects/sirmail/info.ss
new file mode 100644
index 0000000000..6f5901059d
--- /dev/null
+++ b/collects/sirmail/info.ss
@@ -0,0 +1,11 @@
+
+(module info (lib "infotab.ss" "setup")
+  (define doc.txt "doc.txt")
+  (define name "SirMail")
+  (define mred-launcher-libraries (list "sirmail.ss"))
+  (define mred-launcher-names (list "SirMail"))
+  (define compile-omit-files '("recover.ss"))
+  (define requires '(("mred") ("openssl"))))
+
+
+
diff --git a/collects/sirmail/optionr.ss b/collects/sirmail/optionr.ss
new file mode 100644
index 0000000000..15c77d10a0
--- /dev/null
+++ b/collects/sirmail/optionr.ss
@@ -0,0 +1,82 @@
+
+(module optionr mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "string.ss"))
+
+  (require (lib "imap-sig.ss" "net")
+           (lib "mred-sig.ss" "mred")
+	   (lib "framework.ss" "framework"))
+
+  (require "sirmails.ss"
+	   "pref.ss")
+
+  (define shared-password #f)
+
+  ;; The option@ unit gets instanted afresh for every window, but
+  ;; it defers practically all of its work to the "pref.ss" module
+  ;; (which is only instantiated once).
+  
+  (provide option@)
+  (define option@
+    (unit/sig sirmail:options^
+      (import sirmail:environment^
+	      net:imap^
+              mred^)
+
+      (define (parse-server-name s default-port)
+	(let ([m (regexp-match "^([^:]*):([^:]*)$" s)])
+	  (if (and m (string->number (caddr m)))
+	      (values (cadr m) (string->number (caddr m)))
+	      (values s default-port))))
+
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;  Preferences                                            ;;
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+      (define (MAIL-FROM) (get-pref 'sirmail:mail-from))
+      (define (USERNAME) (get-pref 'sirmail:username))
+      (define (DEFAULT-DOMAIN) (get-pref 'sirmail:default-to-domain))
+      (define (IMAP-SERVER) (get-pref 'sirmail:imap-server))
+      (define (LOCAL-DIR) (get-pref 'sirmail:local-directory))
+      (define (SAVE-SENT) (get-pref 'sirmail:sent-directory))
+
+      (define (SMTP-SERVERS) (let ([s (get-pref 'sirmail:smtp-server)])
+			       (regexp-split ", *" s)))
+      (define current-SMTP-SERVER (car (SMTP-SERVERS)))
+      (define (SMTP-SERVER) (let ([l (SMTP-SERVERS)])
+			      (if (member current-SMTP-SERVER l)
+				  current-SMTP-SERVER
+				  (car l))))
+      (define (set-SMTP-SERVER! s) (set! current-SMTP-SERVER s))
+
+
+      (define PASSWORD (get-pref 'sirmail:password))
+      (define (get-PASSWORD) (or PASSWORD shared-password))
+      (define (set-PASSWORD p) (set! shared-password p))
+
+      (define (BIFF-DELAY) (get-pref 'sirmail:biff-delay))
+
+      (define (ALIASES) (let ([f (get-pref 'sirmail:aliases-file)])
+			  (with-handlers ([exn:fail? (lambda (x) null)])
+			    (with-input-from-file f read))))
+
+      (define (SELF-ADDRESSES) (get-pref 'sirmail:self-addresses))
+
+      (define (AUTO-FILE-TABLE) (let ([f (get-pref 'sirmail:auto-file-table-file)])
+				  (and f
+				       (with-handlers ([exn:fail? (lambda (x) null)])
+					 (with-input-from-file f read)))))
+
+      (define (SORT) (get-pref 'sirmail:initial-sort))
+
+      (define (MESSAGE-FIELDS-TO-SHOW) (get-pref 'sirmail:fields-to-show))
+
+      (define (ROOT-MAILBOX-FOR-LIST) (get-pref 'sirmail:root-mailbox-folder))
+      (define (ARCHIVE-MAILBOX) (get-pref 'sirmail:archive-mailbox-folder))
+
+      (define (USE-EXTERNAL-COMPOSER?) (get-pref 'sirmail:use-extenal-composer?))
+
+      (define (WARN-DOWNLOAD-SIZE) (get-pref 'sirmail:warn-download-size))
+      
+      (define (SHOW-URLS) (get-pref 'sirmail:show-urls?)))))
\ No newline at end of file
diff --git a/collects/sirmail/postmark-mask.xbm b/collects/sirmail/postmark-mask.xbm
new file mode 100644
index 0000000000..d80f30577f
--- /dev/null
+++ b/collects/sirmail/postmark-mask.xbm
@@ -0,0 +1,6 @@
+#define mred_width 16
+#define mred_height 16
+static char mred_bits[] = {
+ 0x00,0x00,0x00,0x00,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
+ 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
+ 0xff,0xff};
diff --git a/collects/sirmail/postmark.bmp b/collects/sirmail/postmark.bmp
new file mode 100644
index 0000000000..c7bee59a04
Binary files /dev/null and b/collects/sirmail/postmark.bmp differ
diff --git a/collects/sirmail/pref.ss b/collects/sirmail/pref.ss
new file mode 100644
index 0000000000..2052f76b45
--- /dev/null
+++ b/collects/sirmail/pref.ss
@@ -0,0 +1,540 @@
+(module pref mzscheme
+
+  (require (lib "class.ss")
+	   (lib "framework.ss" "framework")
+	   (lib "mred.ss" "mred")
+	   (lib "list.ss")
+	   (lib "string.ss")
+	   (lib "etc.ss")
+	   (lib "head.ss" "net"))
+
+  ;; IMPORTANT! All preferences operations outside this
+  ;; file should go through the following exports.
+  ;; DO NOT use preferences:... elsewhere.
+  (provide get-pref put-pref save-prefs
+	   show-pref-dialog
+	   add-preferences-menu-items)
+
+  (define (string-or-false? x) (or (not x) (string? x)))
+  (define (ip-string? x) (and (string? x)
+			      (positive? (string-length x))))
+  (define (abs-path-or-false? x) 
+    (or (not x)
+	(and (path? x) (absolute-path? x))))
+
+  (define (un/marshall-path pref)
+    (preferences:set-un/marshall pref
+				 (lambda (x) 
+                                   (if (path? x)
+                                       (path->bytes x)
+                                       x))
+				 (lambda (x) 
+                                   (cond
+                                     [(bytes? x) (bytes->path x) ]
+                                     [(not x) x]
+                                     [else 'badvalue]))))
+  
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;  Preference Definitions                                 ;;
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+  (preferences:set-default 'sirmail:mail-from "SirMail User <sirmail@plt-scheme.org>" string?)
+  (preferences:set-default 'sirmail:username "username" string?)
+  (preferences:set-default 'sirmail:password #f string-or-false?)
+  (preferences:set-default 'sirmail:default-to-domain "plt-scheme.org" ip-string?)
+
+  (preferences:set-default 'sirmail:imap-server "imap.plt-scheme.org" ip-string?)
+  (preferences:set-default 'sirmail:use-ssl? #f boolean?)
+  (preferences:set-default 'sirmail:server-certificate #f abs-path-or-false?)
+  (preferences:set-default 'sirmail:smtp-server "sendmail.plt-scheme.org" ip-string?)
+
+  (preferences:set-default 'sirmail:local-directory 
+			   (build-path (find-system-path 'home-dir)
+				       "SirMail")
+			   (lambda (x)
+			     (and (path? x)
+				  (absolute-path? x))))
+  (un/marshall-path 'sirmail:local-directory)
+  (preferences:set-default 'sirmail:sent-directory 
+			   (build-path (find-system-path 'home-dir)
+				       "SentMail")
+			   (lambda (x)
+			     (or (not x)
+				 (and (path? x)
+				      (absolute-path? x)))))
+  (un/marshall-path 'sirmail:sent-directory)
+  (preferences:set-default 'sirmail:root-mailbox-folder #f string-or-false?)
+
+  (preferences:set-default 'sirmail:archive-mailbox-folder #f string-or-false?)
+  
+  (preferences:set-default 'sirmail:initial-sort 'id
+			   (lambda (x) (memq x '(id date subject from))))
+  (preferences:set-default 'sirmail:biff-delay
+			   60
+			   (lambda (x)
+			     (or (not x)
+				 (and (number? x)
+				      (exact? x)
+				      (integer? x)
+				      (positive? x)))))
+  (preferences:set-default 'sirmail:warn-download-size 32000
+			   (lambda (x) (or (not x) (and (number? x) (real? x)))))
+  (preferences:set-default 'sirmail:external-composer 'xemacs
+			   (lambda (x) (memq x '(xemacs gnu-emacs))))
+  (preferences:set-default 'sirmail:use-extenal-composer? #f boolean?)
+  (preferences:set-default 'sirmail:show-urls? #t boolean?)
+  (preferences:set-default 'sirmail:show-gc-icon #f boolean?)
+  (preferences:set-default 'sirmail:always-happy #f boolean?)
+  (preferences:set-default 'sirmail:wrap-lines #f boolean?)
+  (preferences:set-default 'sirmail:prefer-text #t boolean?)
+
+  (preferences:set-default 'sirmail:aliases-file
+                           (build-path (find-system-path 'home-dir) ".sirmail.aliases")
+			   abs-path-or-false?)
+  (un/marshall-path 'sirmail:aliases-file)
+  (preferences:set-default 'sirmail:auto-file-table-file (build-path (find-system-path 'home-dir) ".sirmail.auto-file")
+			   abs-path-or-false?)
+  (un/marshall-path 'sirmail:auto-file-table-file)
+
+  (preferences:set-default 'sirmail:self-addresses null
+			   (lambda (x) (and (list? x) (andmap string? x))))
+  (preferences:set-default 'sirmail:fields-to-show '("From" "To" "CC" "Subject" "Date" "X-Mailer" "X-Uptime")
+			   (lambda (x) (and (list? x) (andmap string? x))))
+
+
+  (let ([fw 560]
+	[fh 600])
+    (let-values ([(display-width display-height) (get-display-size)])
+      (preferences:set-default 'sirmail:frame-width
+			       (min display-height fh)
+			       (lambda (x) (and (number? x) (<= 0 x 32768))))
+      (preferences:set-default 'sirmail:frame-height 
+			       (min display-width fw)
+			       (lambda (x) (and (number? x) (<= 0 x 32768))))))
+
+  (define (xywh-okay? n)
+    (and (number? n)
+         (<= 0 n 10000)))
+  (preferences:set-default 'sirmail:folder-window-w 200 xywh-okay?)
+  (preferences:set-default 'sirmail:folder-window-h 400 xywh-okay?)
+  (preferences:set-default 'sirmail:folder-window-x 0 xywh-okay?)
+  (preferences:set-default 'sirmail:folder-window-y 0 xywh-okay?)
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;  Preference Manager                                     ;;
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (define prefs-eventspace (make-eventspace))
+
+  (define (in-preferences-eventspace thunk)
+    (let ([val #f]
+	  [s (make-semaphore)])
+      (parameterize ([current-eventspace prefs-eventspace])
+	(queue-callback
+	 (lambda ()
+	   (with-handlers ([void (lambda (x)
+				   ;; Assume all raised values are exns
+				   (set! val x))])
+	     (set! val (thunk)))
+	   (semaphore-post s))))
+      (semaphore-wait s)
+      (if (exn? val)
+	  (raise val)
+	  val)))
+
+  (define (get-pref id)
+    (in-preferences-eventspace (lambda ()
+				 (preferences:get id))))
+
+  (define (put-pref id val)
+    (in-preferences-eventspace (lambda ()
+				 (preferences:set id val))))
+
+  (define (save-prefs)
+    (in-preferences-eventspace preferences:save))
+
+  (define (add-preferences-menu-items edit-menu)
+    (make-object separator-menu-item% edit-menu)
+    (make-object menu-item% "Preferences" edit-menu
+		 (lambda (x y) (in-preferences-eventspace preferences:show-dialog))))
+  
+  (define (show-pref-dialog)
+    (in-preferences-eventspace 
+     (lambda ()
+       (preferences:show-dialog)
+       (yield 'wait))))
+
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;  Preference Dialog                                      ;;
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (define needs-check null)
+
+  
+  (define (set-hilite e on?)
+    (send e change-style 
+	  (send (make-object style-delta%) set-delta-background (if on? "yellow" "white"))
+	  0 (send e last-position)))
+
+  ;; make-text-field : string panel number symbol boolean
+  ;;                   ((union #f string) (union #f top-level-window<%>) string -> boolean)
+  ;;                   (any -> string)
+  ;;                   (string -> any)
+  ;;                   [ (union #f string) ]
+  ;;                -> void
+  ;; sets up a text field for a preference
+  ;; The 3rd-to-last argument checks the validity of the field content.If
+  ;;  a string is provided, then a top-level-window<%> is also provded, and
+  ;;  the checking function should tell the user why the field-value string
+  ;;  is bad if it is bad.
+  ;; the last two arguments convert between the string representation (as shown in the text field)
+  ;; and the preferences's actual Scheme value.
+  (define make-text-field
+    (opt-lambda (label panel width-num pref optional? check-value val->str str->val [post-label #f])
+      (define p0 (and (or optional? post-label)
+		      (instantiate horizontal-panel% (panel) [stretchable-height #f])))
+      (define e (and optional?
+		     (make-object check-box% label p0
+				  (lambda (c e)
+				    (let ([on? (send c get-value)])
+				      (send t enable on?)
+				      (if on?
+					  (t-cb t e)
+					  (begin
+					    ;; remove all need-check registrations, if any:
+					    (let loop ()
+					      (let ([a (assq t needs-check)])
+						(when a
+						  (set! needs-check (remq a needs-check))
+						  (loop))))
+					    (preferences:set pref #f))))))))
+      (define t-cb (lambda (t e)
+		     (let* ([s (send t get-value)])
+		       (if (check-value #f #f s)
+			   (preferences:set pref (str->val s))
+			   (begin
+			     (set! needs-check (cons (list t label check-value) needs-check))
+			     (set-hilite (send t get-editor) #t))))))
+      (define t (make-object text-field% 
+			     (if optional? #f label) 
+			     (or p0 panel)
+			     t-cb
+			     (make-string width-num #\X)))
+      (when post-label
+	(send t stretchable-width #f)
+	(make-object message% post-label p0))
+
+      (send t set-value (let ([v (preferences:get pref)])
+			  (if v
+			      (val->str v)
+			      "")))
+      (when optional?
+	(send e set-value (preferences:get pref)))
+      (when e
+	(send t enable (send e get-value)))
+      (preferences:add-callback pref (lambda (name val)
+				       (set-hilite (send t get-editor) #f)
+				       (when e
+					 (send e set-value val)
+					 (send t enable val))
+				       (when val
+					 (let ([sval (val->str val)])
+					   (unless (equal? sval (send t get-value))
+					     (send t set-value sval))))))
+
+      (or p0 t)))
+
+  (define (check-unsaved-pref?)
+    (and (andmap (lambda (a)
+		   ((caddr a) (cadr a) (send (car a) get-top-level-window) (send (car a) get-value)))
+		 needs-check)
+	 (begin
+	   (set! needs-check null)
+	   #t)))
+	     
+  (define make-file/directory-button
+    (lambda (dir? button-label parent pref enabler)
+      (define p0 (and enabler
+		      (instantiate horizontal-panel% (parent) [stretchable-height #f])))
+      (define e (and enabler
+		     (make-object check-box% enabler p0
+				  (lambda (c e)
+				    (let ([on? (send c get-value)])
+				      (send p enable on?)
+				      (preferences:set
+				       pref
+				       (and on?
+					    (string->path (send field get-value)))))))))
+      (define p (instantiate horizontal-panel% ((or p0 parent))
+			     [stretchable-height #f]))
+      (define (set-it v)
+	(preferences:set pref v))
+      (define field (make-object text-field% button-label p
+				 ;; For now, just counteract edits:
+				 (lambda (t e)
+				   (send field set-value (path->string (preferences:get pref))))
+                      (path->string
+                       (or (preferences:get pref)
+                           (current-directory)))))
+      (when e
+	(send e set-value (preferences:get pref))
+	(send p enable (send e get-value)))
+      (preferences:add-callback pref (lambda (name val)
+				       (when e
+					 (send e set-value val)
+					 (send p enable val))
+				       (when val
+					 (send field set-value (path->string val)))))
+      (make-object button% "Set..." p (lambda (b e)
+					(let ([v ((if dir? get-directory get-file)
+						  (or enabler button-label))])
+					  (when v
+					    (set-it v)))))
+      p0))
+
+  (define make-boolean
+    (opt-lambda (label p pref [extra-action void])
+      (define c
+	(make-object check-box% label p (lambda (c e)
+					  (let ([v (send c get-value)])
+					    (extra-action v)
+					    (preferences:set pref v)))))
+      (send c set-value (preferences:get pref))
+      (preferences:add-callback pref (lambda (name val)
+				       (send c set-value val)))))
+
+  (define (is-host-address? s)
+    (regexp-match "^([-a-zA-Z0-9]+[.])*[-a-zA-Z0-9]+$" s))
+
+  (define (is-host-address+port? s)
+    (or (is-host-address? s)
+	(let ([m (regexp-match "^(.*):([0-9]+)$" s)])
+	  (and m
+	       (<= 1 (string->number (caddr m)) 65535)
+	       (is-host-address? (cadr m))))))
+
+  (define (is-host-address+port-list? s)
+    (let ([l (regexp-split ", *" s)])
+      (andmap is-host-address+port? l)))
+
+  (define (check-address ok? who tl s port-ok? multi?)
+    (or (ok? s)
+	(begin
+	  (when who
+	    (message-box
+	     "Preference Error"
+	     (format (string-append
+		      "The ~a value must be a~a host IP address~a~a~a.\n"
+		      "An IP address is an string containing a combination of "
+		      "period (.), dash (-), A-Z, a-Z, and 0-9. "
+		      "Also the period cannot appear at the very beginning or end.\n"
+		      "~a"
+		      "You provided\n\n  ~a\n\nwhich is not legal.")
+		     who 
+		     (if multi? " comma-separated list of" "")
+		     (if multi? " es" "")
+		     (if (and multi? port-ok?) " each" "")
+		     (if port-ok? " with an optional port number" "")
+		     (if port-ok? 
+			 (string-append
+			  "An optional port number is specified by adding a "
+			  "colon (:) followed by a number between 1 and 65535.\n")
+			 "")
+		     s)
+	     tl
+	     '(ok stop)))
+	  #f)))
+			
+  (define (check-host-address who tl s)
+    (check-address is-host-address? who tl s #f #f))
+  (define (check-host-address/port who tl s)
+    (check-address is-host-address+port? who tl s #t #f))
+  (define (check-host-address/port/multi who tl s)
+    (check-address is-host-address+port-list? who tl s #t #t))
+
+  ;; check-biff-delay : (union #f string) (union #f parent) string -> boolean
+  ;; checks to see if the string in the biff delay field makes
+  ;; sense as an exact integer between 1 and 3600
+  (define (check-biff-delay who tl s)
+    (let ([n (string->number s)])
+      (or (and (number? n)
+	       (integer? n)
+	       (exact? n)
+	       (<= 1 n 3600))
+	  (begin
+	    (when who
+	      (message-box
+	       "Preference Error"
+	       (format (string-append
+			"The biff delay must be an exact integer between 1 and 3600.~n"
+			"You provided:~n"
+			"  ~a")
+		       s)
+	       tl
+	       '(ok stop)))
+	    #f))))
+
+  
+  ;; check-message-size : (union #f string) (union #f parent) string -> boolean
+  ;; checks to see if the string in the download-max-size field makes
+  ;; sense as an exact positive integer
+  (define (check-message-size who tl s)
+    (let ([n (string->number s)])
+      (or (and (number? n)
+	       (integer? n)
+	       (exact? n)
+	       (positive? n))
+	  (begin
+	    (when who
+	      (message-box
+	       "Preference Error"
+	       (format (string-append
+			"The message size must be an exact, positive integer.~n"
+			"You provided:~n"
+			"  ~a")
+		       s)
+	       tl
+	       '(ok stop)))
+	    #f))))
+  
+  (define (check-user-address who tl s)
+    (with-handlers ([exn:fail? 
+		     (lambda (x)
+		       (when who
+			 (message-box
+			  "Preference Error"
+			  (format "The ~a value you provided is not a legal mail address: ~a"
+				  who s)
+			  tl
+			  '(ok stop)))
+		       #f)])
+      (unless (= 1 (length (extract-addresses s 'all)))
+	(error "multiple addresses"))
+      #t))
+
+  (define (check-simple-user-address who tl s)
+    (and (check-user-address who tl s)
+	 (car (extract-addresses s 'address))))
+
+  (define (check-id who tl s) #t)
+      
+  (define (make-text-list label parent pref check-item)
+    (let ([p (make-object group-box-panel% label parent)])
+      (define l (make-object list-box% #f (or (preferences:get pref) null) p
+			     (lambda (l e)
+			       (send delete enable (pair? (send l get-selections))))
+			     '(multiple)))
+      (define hp (instantiate horizontal-panel% (p) 
+			      [stretchable-height #f]
+			      [alignment '(center center)]))
+      (define add (make-object button% "Add" hp (lambda (b e)
+						  (let loop ([init ""])
+						    (let ([v (get-text-from-user (format "Add to ~a" label)
+										 (format "Add to ~a" label)
+										 (send parent get-top-level-window)
+										 init)])
+						      (when v
+							(let ([revised (check-item (format "item for ~a" label)
+										   (send b get-top-level-window) v)])
+							  (if revised
+							      (begin
+								(send l append (if (string? revised) revised v))
+								(set-prefs))
+							      (loop v)))))))))
+      (define delete (make-object button% "Delete" hp (lambda (b e)
+							(let ([d (send l get-selections)])
+							  (for-each (lambda (i)
+								      (send l delete i))
+								    (quicksort d >))
+							  (set-prefs)))))
+      (define (set-prefs)
+	(send delete enable (pair? (send l get-selections)))
+	(preferences:set
+	 pref
+	 (let ([n (send l get-number)])
+	   (let loop ([i 0])
+	     (if (= i n)
+		 null
+		 (cons (send l get-string i)
+		       (loop (add1 i))))))))
+      (send delete enable #f)
+      (preferences:add-callback pref (lambda (name val)
+				       (send l clear)
+				       (for-each (lambda (i)
+						   (send l append i))
+						 val)
+				       (send delete enable (pair? (send l get-selections)))))))
+
+  (define (make-addresses-preferences-panel parent)
+    (let ([p (instantiate vertical-panel% (parent))])
+      
+      (make-text-field "Mail From" p 20 'sirmail:mail-from #f check-user-address (lambda (x) x) (lambda (x) x))
+      (make-text-field "SMTP Server" p 20 'sirmail:smtp-server #f check-host-address/port/multi (lambda (x) x) (lambda (x) x))
+
+      (make-file/directory-button #t #f p
+				  'sirmail:sent-directory
+				  "Save Sent Files")
+
+
+      (make-text-field "Default \"To\" domain" p 20 'sirmail:default-to-domain #f check-host-address (lambda (x) x) (lambda (x) x))
+      (make-file/directory-button #f #f p
+				  'sirmail:aliases-file
+				  "Aliases File")
+
+      (make-text-list "Self Addresses" p 'sirmail:self-addresses check-simple-user-address)
+
+      (make-boolean "Enable compose-with-Emacs" p 'sirmail:use-extenal-composer?)
+
+      p))
+
+  (define (make-mbox-preferences-panel parent)
+    (let ([p (instantiate vertical-panel% (parent)
+               (alignment '(left center)))])
+      
+      (make-text-field "Username" p 10 'sirmail:username #f check-id (lambda (x) x) (lambda (x) x))
+      (let ([sp (instantiate group-box-panel% ("IMAP Server" p)
+			     [alignment '(left center)])]
+	    [cert #f])
+	(make-text-field "Server" sp 20 'sirmail:imap-server #f check-host-address/port (lambda (x) x) (lambda (x) x))
+	(make-boolean "Encrypt connection using SSL" sp 'sirmail:use-ssl?
+		      (lambda (on?) (send cert enable on?)))
+	(set! cert (make-file/directory-button #f #f sp
+					       'sirmail:server-certificate
+					       "Verify SSL with certificates"))
+        (make-text-field "Archive folder" sp 20 'sirmail:archive-mailbox-folder #t void (lambda (x) x) (lambda (x) x))
+	(make-text-field "Folder list root" sp 20 'sirmail:root-mailbox-folder #t void (lambda (x) x) (lambda (x) x))
+
+	(send cert enable (preferences:get 'sirmail:use-ssl?)))
+
+      (make-file/directory-button #t "Local directory" p
+				  'sirmail:local-directory
+				  #f)
+
+      (make-text-field "Check mail every" p 5 'sirmail:biff-delay #t check-biff-delay number->string string->number
+		       "seconds")
+
+      (make-text-field "Verify download of messages larger than" p 10
+		       'sirmail:warn-download-size #t 
+		       check-message-size number->string string->number
+		       "bytes")
+
+      (make-file/directory-button #f #f p
+				  'sirmail:auto-file-table-file
+				  "Auto-file table file")
+      
+      (make-boolean "Show GC icon" p 'sirmail:show-gc-icon)
+      (make-boolean "Always happy to get mail" p 'sirmail:always-happy)
+      
+      (make-text-list "Shown Header Fields" p 'sirmail:fields-to-show void)
+
+      p))
+
+  (in-preferences-eventspace
+   (lambda ()
+     (preferences:add-panel "Reading" make-mbox-preferences-panel)
+     (preferences:add-panel "Sending" make-addresses-preferences-panel)
+     (preferences:add-editor-checkbox-panel)
+     (preferences:add-can-close-dialog-callback check-unsaved-pref?))))
+
diff --git a/collects/sirmail/readr.ss b/collects/sirmail/readr.ss
new file mode 100644
index 0000000000..96f93dca8d
--- /dev/null
+++ b/collects/sirmail/readr.ss
@@ -0,0 +1,3076 @@
+
+;; This module implements the mail-reading window as a unit. The
+;; unit is instantiated once for each window.
+
+;; General notes:
+;;
+;;   * Always use `as-background' when communicating with the
+;;     server. That way, the user can kill the window if necessary.
+;;     use `enable-main-frame' for the first argument to `as-background'.
+;;     The `as-background' function is defined in "utilr.ss".
+;;
+
+(module readr mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "class.ss")
+           (lib "file.ss")
+	   (lib "mred-sig.ss" "mred")
+           (lib "framework.ss" "framework")
+           (lib "process.ss"))
+
+  (require (lib "string.ss")
+           (lib "list.ss")
+	   (lib "thread.ss")
+           "spell.ss")
+
+  (require "sirmails.ss")
+
+  (require "pref.ss")
+
+  (require (lib "imap-sig.ss" "net")
+	   (lib "smtp-sig.ss" "net")
+	   (lib "head-sig.ss" "net")
+	   (lib "base64-sig.ss" "net")
+	   (lib "mime-sig.ss" "net")
+	   (lib "qp-sig.ss" "net")
+           (lib "htmltext.ss" "browser"))
+
+  (require (lib "hierlist-sig.ss" "hierlist"))
+
+  (require (lib "sendurl.ss" "net"))
+
+  (require (lib "mzssl.ss" "openssl"))
+
+  ;; Constant for messages without a title:
+  (define no-subject-string "<No subject>")
+
+  (provide read@)
+  (define read@
+    (unit/sig sirmail:read^
+      (import sirmail:options^
+	      sirmail:environment^
+	      sirmail:utils^
+	      sirmail:send^
+	      mred^
+	      net:imap^
+	      net:smtp^
+	      net:head^
+	      net:base64^
+	      (mime : net:mime^)
+	      net:qp^
+	      hierlist^)
+      
+      ;; This will be set to the frame object
+      (define main-frame #f)
+      
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;  Error Handling                                         ;;
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+      ;; It's possible that SirMail can't even start with
+      ;;  the default preference values. This flag lets us
+      ;;  give the user a chance.
+      (define got-started? #f)
+
+      (define (show-error x)
+	(let ([sp (open-output-string)])
+	  ;; use error display handler in case
+	  ;; errortrace (or something else) is
+	  ;; installed
+	  (parameterize ([current-output-port sp]
+			 [current-error-port sp])
+	    ((error-display-handler)
+	     (if (exn? x)
+		 (exn-message x)
+		 (format "uncaught exn: ~s" x))
+	     x))
+	  (message-box "Error" 
+		       (get-output-string sp)
+		       main-frame
+		       '(ok stop))
+	  (when (not got-started?)
+	    (when (eq? 'yes (confirm-box "Startup Error"
+					 (string-append
+					  "Looks like you didn't even get started. "
+					  "Set preferences (so you're ready to try again)?")
+					 #f
+					 '(app)))
+	      (show-pref-dialog)))))
+
+      (initial-exception-handler
+       (lambda (x)
+	 (show-error x)
+	 ((error-escape-handler))))
+
+      (current-exception-handler
+       (initial-exception-handler))
+
+      ;; Install std bindings global for file dialog, etc.
+      (let ([km (make-object keymap%)])
+	(add-text-keymap-functions km)
+	(keymap:setup-global km)
+	(let ([f (current-text-keymap-initializer)])
+	  (current-text-keymap-initializer
+	   (lambda (k)
+	     (send k chain-to-keymap km #f)
+	     (f k)))))
+
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;  Mailbox List                                           ;;
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+      ;; In case this is the first run...
+      (unless (directory-exists? (LOCAL-DIR))
+	(make-directory (LOCAL-DIR)))
+
+      ;; The "mailboxes" file tells us where to find local copies
+      ;;  of the mailbox content
+      (define mailboxes
+	(with-handlers ([void (lambda (x) '(("Inbox" #"inbox")))])
+	  (with-input-from-file (build-path (LOCAL-DIR) "mailboxes")
+	    read)))
+
+      (unless (assoc mailbox-name mailboxes)
+	(error 'sirmail "No local mapping for mailbox: ~a" mailbox-name))
+      
+      (define (string/bytes->path s)
+	(if (string? s)
+	    (string->path s)
+	    (bytes->path s)))
+
+      ;; find the mailbox for this window:
+      (define mailbox-dir (build-path (LOCAL-DIR) 
+				      (string/bytes->path (cadr (assoc mailbox-name mailboxes)))))
+      
+      (unless (directory-exists? mailbox-dir)
+	(make-directory mailbox-dir))
+      
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;  Message data structure                                 ;;
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      
+      ;; We use a lists so they can be easily read and written
+      
+      ;; type message = (list ... message attributes, see selectors below ...)
+
+      (define uid-validity #f)
+
+      ;; mailbox : (listof message)
+      ;; mailboxes holds the list of messages reflected in the top list
+      ;; in the GUI. When modifying this value (usually indirectly), use
+      ;; `header-chganging-action'. Mutate the variable, but not the list!
+      (define mailbox (let ([l (with-handlers ([void (lambda (x) null)])
+					      (with-input-from-file
+						  (build-path mailbox-dir "mailbox")
+						read))])
+			;; If the file's list start with an integer, that's
+			;;  the uidvalidity value. Otherwise, for backward
+			;;  compatibility, we allow the case that it wasn't
+			;;  recorded.
+			(if (and (pair? l)
+				 (or (not (car l)) (integer? (car l))))
+			    (begin
+			      (set! uid-validity (car l))
+			      (cdr l))
+			    l)))
+
+      (define mailbox-ht #f)
+      (define (rebuild-mailbox-table!)
+	(set! mailbox-ht (make-hash-table 'equal))
+	(for-each (lambda (m) (hash-table-put! mailbox-ht (car m) m))
+		  mailbox))
+      (rebuild-mailbox-table!)
+
+      (define (find-message id)
+	(hash-table-get mailbox-ht id (lambda () #f)))
+      
+      (define message-uid car)
+      (define message-position cadr)
+      (define message-downloaded? caddr)
+      (define message-from cadddr)
+      (define message-subject (lambda (m) (list-ref m 4)))
+      (define message-flags (lambda (m) (list-ref m 5)))
+      (define message-size (lambda (m) (let ([l (list-tail m 6)])
+                                         ;; For backward compatibility:
+					 (if (pair? l)
+					     (car l)
+					     #f))))
+      (define set-message-position! (lambda (m v) (set-car! (cdr m) v)))
+      (define set-message-downloaded?! (lambda (m v) (set-car! (cddr m) v)))
+      (define set-message-flags! (lambda (m v) (set-car! (list-tail m 5) v)))
+
+      (define (message-marked? m) (memq 'marked (message-flags m)))
+      
+      (define (write-mailbox)
+	(status "Saving mailbox information...")
+	(with-output-to-file (build-path mailbox-dir "mailbox")
+	  (lambda ()
+	    (write (cons uid-validity mailbox)))
+	  'truncate))
+      
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;  Connection                                             ;;
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      
+      (define-values (connect disconnect force-disconnect)
+	(let ([connection #f]
+	      [connection-custodian #f]
+	      [message-count 0])
+	  (values
+	   (letrec ([connect
+		     (case-lambda
+                       [() (connect 'reuse)]
+		       [(mode) (connect 'reuse void void)]
+                       [(mode break-bad break-ok)
+			
+			(define (with-disconnect-handler thunk)
+			  (with-handlers ([void (lambda (exn)
+						  (force-disconnect)
+						  (status "")
+						  (raise exn))])
+			    (break-ok)
+			    (begin0
+			     (thunk)
+			     (break-bad))))
+	  
+	  
+                        (if connection
+                            
+                            ;; Already Connected
+                            (cond
+                              [(eq? mode 'reselect)
+			       (let-values ([(count new) (with-disconnect-handler
+							  (lambda ()
+							    (imap-noop connection)))])
+				 (check-validity (or (imap-uidvalidity connection) 0) void)
+				 (values connection (imap-messages connection) (imap-new? connection)))]
+			      [(eq? mode 'check-new)
+                               (let-values ([(count new) (with-disconnect-handler
+							  (lambda ()
+							    (imap-noop connection)))])
+                                 (values connection message-count (imap-new? connection)))]
+			      [else
+                               (values connection message-count (imap-new? connection))])
+                            
+                            ;; New connection
+                            (begin
+			      (let ([pw (or (get-PASSWORD)
+					    (let ([p (get-text-from-user "Password" 
+									 (format "Password for ~a:" (USERNAME))
+									 main-frame
+									 ""
+									 '(password))])
+					      (unless p (error 'connect "connection cancelled"))
+					      p))])
+				(let*-values ([(imap count new) (let-values ([(server port-no)
+									      (parse-server-name (IMAP-SERVER)
+										(if (get-pref 'sirmail:use-ssl?) 993 143))])
+								  (set! connection-custodian (make-custodian))
+								  (parameterize ([current-custodian connection-custodian])
+								    (with-disconnect-handler
+								     (lambda ()
+								       (if (get-pref 'sirmail:use-ssl?)
+									   (let ([c (ssl-make-client-context)])
+									     (let ([cert (get-pref 'sirmail:server-certificate)])
+									       (when cert
+										 (ssl-set-verify! c #t)
+										 (ssl-load-verify-root-certificates! c cert)))
+									     (let-values ([(in out) (ssl-connect server port-no c)])
+									       (imap-connect* in out (USERNAME) pw mailbox-name)))
+									   (parameterize ([imap-port-number port-no])
+									     (imap-connect server (USERNAME) pw mailbox-name)))))))])
+                                  (unless (get-PASSWORD)
+				    (set-PASSWORD pw))
+				  (status "(Connected, ~a messages)" count)
+				  (with-disconnect-handler
+				   (lambda ()
+				     (check-validity (or (imap-uidvalidity imap) 0) 
+						     (lambda () (imap-disconnect imap)))))
+				  (set! connection imap)
+				  (set! message-count count)
+				  (send disconnected-msg show #f)
+				  (values imap count (imap-new? imap))))))])])
+	     connect)
+	   (lambda ()
+	     (when connection
+	       (status "Disconnecting...")
+	       (as-background 
+		enable-main-frame
+		(lambda (break-bad break-ok)
+		  (with-handlers ([void (lambda (exn)
+					  (force-disconnect/status)
+					  (raise exn))])
+		    (break-ok)
+		    (imap-disconnect connection)))
+		close-frame)
+	       (status "")
+	       (set! connection #f)))
+	   (lambda ()
+	     (custodian-shutdown-all connection-custodian)
+	     (set! connection #f)))))
+      
+      (define (force-disconnect/status)
+	(force-disconnect)
+	(send disconnected-msg show #t)
+	(set! initialized? #f)
+	(set! continue? #f)
+	(status ""))
+
+      (define (check-validity v cleanup)
+	(when (and uid-validity
+		   (not (= uid-validity v))
+		   (pair? mailbox))
+	  ;; This is really very unlikely, but we checked
+	  ;; to guard against disaster.
+	  (cleanup)
+	  (error 'connect "UID validity changed, ~a -> ~a! SirMail can't handle it."
+		 uid-validity v))
+	(set! uid-validity v))
+      
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;  Mailbox Actions (indepdent of the GUI)                 ;;
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      
+      (define initialized? #f)
+      (define new-messages? #f)
+      (define current-count 0)
+      (define continue? #f)
+
+      (define (initialized count)
+	(set! initialized? #t)
+	(set! continue? #t)
+	(set! new-messages? #f)
+	(set! current-count count)
+	(hide-new-mail-msg))
+
+      ;; Syncs `mailbox' with the server
+      (define (update-local break-bad break-ok)
+	(status "Updating ~a from ~a..." mailbox-name (IMAP-SERVER))
+	(let-values ([(imap count new?) (connect 'reselect break-bad break-ok)])
+	  (imap-reset-new! imap)
+	  (start-biff)
+	  (status "Getting message ids...")
+	  (let* ([positions (if continue?
+				(let ([p (length mailbox)])
+				  (map (lambda (i) (+ i p))
+				       (enumerate (- count p))))
+				(enumerate count))]
+		 [data (with-handlers ([void (lambda (exn)
+					       (force-disconnect/status)
+					       (raise exn))])
+			 (break-ok)
+			 (begin0
+			  (imap-get-messages imap 
+					     positions
+					     '(uid))
+			  (break-bad)))]
+		 [uids (map car data)]
+		 [curr-uids (map car mailbox)]
+		 [deleted (if continue?
+			      null
+			      (remove* uids curr-uids))]
+		 [position-uids (map cons uids positions)]
+		 [new (if continue?
+			  position-uids
+			  (remove* curr-uids position-uids
+				   (lambda (a b) (equal? a (car b)))))])
+	    (status "~a deleted, ~a locally new" (length deleted) (length new))
+	    
+	    (unless (null? new)
+	      (status "Getting new headers..."))
+	    (let* ([new-data (with-handlers ([void (lambda (exn)
+						     (force-disconnect/status)
+						     (raise exn))])
+			       (break-ok)
+			       (begin0
+				(imap-get-messages imap 
+						   (map cdr new)
+						   '(header size))
+				(break-bad)))]
+		   [new-headers (map car new-data)]
+		   [new-sizes (map cadr new-data)]
+		   [new-uid/size-map (map cons (map car new) new-sizes)])
+	      (if (and (null? deleted) (null? new))
+		  (begin
+		    (initialized count)
+		    (status "No new messages")
+		    #f)
+		  (begin
+		    (unless (null? deleted)
+		      (status "Deleting local messages...")
+		      (for-each
+		       (lambda (uid)
+			 (with-handlers ([void void])
+			   (let ([path (build-path mailbox-dir (format "~a" uid))])
+			     (delete-file path)
+			     (let ([body (string-append path "body")])
+			       (when (file-exists? body)
+				 (delete-file body))))))
+		       deleted))
+		    
+		    (unless (null? new-headers)
+		      (status "Saving new headers...")
+		      (for-each
+		       (lambda (position-uid header)
+			 (with-output-to-file
+			     (build-path mailbox-dir (format "~a" (car position-uid)))
+			   (lambda ()
+			     (display header))
+			   'truncate))
+		       new new-headers))
+		    
+		    (set! mailbox 
+			  (append
+			   (if continue? mailbox null)
+			   (map
+			    (lambda (uid pos)
+			      (let ([old (assoc uid mailbox)])
+				`(,uid ,pos 
+				       ,(if old
+					    (message-downloaded? old)
+					    #f)
+				       ,(if old
+					    (message-from old)
+					    (extract-field "From" (get-header uid)))
+				       ,(if old
+					    (message-subject old)
+					    (extract-field "Subject" (get-header uid)))
+				       ,(if old
+					    (message-flags old)
+					    null)
+				       ,(if old
+					    (message-size old)
+					    (let ([new (assoc uid new-uid/size-map)])
+					      (if new
+						  (cdr new)
+						  0))))))
+			    uids positions)))
+		    (rebuild-mailbox-table!)
+		    (write-mailbox)
+		    (initialized count)
+		    (display-message-count (length mailbox))
+		    (let ([len (length new-headers)])
+		      (status "Got ~a new message~a" 
+			      len
+			      (if (= 1 len) "" "s")))
+		    #t))))))
+      
+      (define (check-for-new break-bad break-ok)
+	(status "Checking ~a at ~a..." mailbox-name (IMAP-SERVER))
+	(let-values ([(imap count new?) (connect 'check-new break-bad break-ok)])
+	  (set! new-messages? new?))
+	(if new-messages?
+	    (begin
+	      (show-new-mail-msg)
+	      (status "New mail")
+	      #t)
+	    (begin
+	      (hide-new-mail-msg)
+	      (status "No new mail")
+	      #f))
+	new-messages?)
+      
+      ;; gets cached header
+      (define (get-header uid)
+	(let ([file (build-path mailbox-dir (format "~a" uid))])
+	  (with-input-from-file file
+	    (lambda ()
+	      (bytes->string/latin-1
+	       (read-bytes (file-size file)))))))
+      
+      ;; gets cached body or downloads from server (and caches)
+      (define (get-body uid break-bad break-ok)
+	(let ([v (find-message uid)]
+	      [file (build-path mailbox-dir (format "~abody" uid))])
+	  (when (not v)
+	    (error 'internal-error "unknown message: ~a" uid))
+	  (unless (message-downloaded? v)
+	    (status "Getting message ~a..." uid)
+	    (let ([size (message-size v)]
+		  [warn-size (WARN-DOWNLOAD-SIZE)])
+	      (when (and size warn-size (> size warn-size))
+		(unless (eq? 'yes
+			     (confirm-box "Large Message"
+					  (format "The message is ~s bytes.~nReally download?" size)
+					  main-frame))
+		  (status "")
+		  (error "download aborted"))))
+	    (let*-values ([(imap count new?) (connect 'reuse break-bad break-ok)])
+	      (let ([body (with-handlers ([void
+					   (lambda (exn)
+					     (force-disconnect/status)
+					     (raise exn))])
+			    (break-ok)
+			    (begin0
+			     (let ([reply (imap-get-messages 
+					   imap 
+					   (list (message-position v))
+					   '(uid body))])
+			       (if (equal? (caar reply) (message-uid v))
+				   (cadar reply)
+				   (error (string-append "server UID does not match local UID; "
+							 "update the message list and try again"))))
+			     (break-bad)))])
+		(status "Saving message ~a..." uid)
+		(with-output-to-file file
+		  (lambda () (write-bytes body))
+		  'truncate)
+                
+		(set-message-downloaded?! v #t)
+		(write-mailbox))))
+	  (begin0
+            (with-input-from-file file
+              (lambda ()
+                (read-bytes (file-size file))))
+            (status ""))))
+      
+      ;; Checks that `mailbox' is synced with the server
+      (define (check-positions imap msgs)
+	(status "Checking message mapping...")
+	(let ([ids (imap-get-messages imap (map message-position msgs) '(uid))])
+	  (unless (equal? (map car ids) (map message-uid msgs))
+	    (error 'position-check "server's position->id mapping doesn't match local copy. server: ~s local: ~s" 
+                   (map car ids) 
+                   (map message-uid msgs)))))
+      
+      (define (remove-delete-flags imap)
+	(status "Removing old delete flags...")
+	(imap-store imap '- (map message-position mailbox) (list (symbol->imap-flag 'deleted))))
+      
+      ;; purge-messages : (listof messages) -> void
+      (define (purge-messages marked bad-break break-ok)
+        (unless (null? marked)
+          (let-values ([(imap count new?) (connect)])
+	    (with-handlers ([void
+			     (lambda (exn)
+			       (force-disconnect/status)
+			       (raise exn))])
+	      (break-ok)
+	      (check-positions imap marked)
+	      (remove-delete-flags imap)
+	      (status "Deleting marked messages...")
+	      (imap-store imap '+ (map message-position marked)
+			  (list (symbol->imap-flag 'deleted)))
+	      (imap-expunge imap)
+	      (unless (equal? (imap-get-expunges imap)
+			      (map message-position marked))
+		(error "expunge notification list doesn't match expunge request"))
+	      (bad-break))
+            (set! mailbox
+                  (filter
+                   (lambda (m) (not (memq m marked)))
+                   mailbox))
+	    (rebuild-mailbox-table!)
+            (let loop ([l mailbox][p 1])
+              (unless (null? l)
+                (set-message-position! (car l) p)
+                (loop (cdr l) (add1 p))))
+            (write-mailbox)
+            (let* ([problems null]
+                   [try-delete
+                    (lambda (f)
+                      (with-handlers ([void 
+                                       (lambda (x)
+                                         (set! problems (cons x problems)))])
+                        (delete-file f)))])
+              (for-each
+               (lambda (m)
+                 (let ([uid (message-uid m)])
+                   (try-delete (build-path mailbox-dir (format "~a" uid)))
+                   (when (message-downloaded? m)
+                     (try-delete (build-path mailbox-dir (format "~abody" uid))))))
+               marked)
+              (unless (null? problems)
+                (message-box "Warning"
+                             (apply
+                              string-append
+                              "There we problems deleting some local files:"
+                              (map
+                               (lambda (x)
+                                 (string-append
+                                  (string #\newline)
+                                  (if (exn? x)
+                                      (exn-message x)
+                                      "<unknown exn>")))
+			       problems))
+                             main-frame))
+              (display-message-count (length mailbox))
+              (status "Messages deleted")))))
+
+      ;; purge-marked : -> void
+      ;; purges the marked mailbox messages.
+      (define (purge-marked bad-break break-ok)
+	(let* ([marked (filter message-marked? mailbox)])
+	  (purge-messages marked bad-break break-ok)))
+      
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;  GUI: Message List Tools                                ;;
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      
+      (define FROM-WIDTH 150)
+      (define SUBJECT-WIDTH 300)
+      (define UID-WIDTH 150)
+
+      ;; update-frame-width : -> void
+      ;; updates the green line's width
+      ;; preferences's value of sirmail:frame-width must be 
+      ;; up to date before calling this function
+      (define (update-frame-width)
+	(let* ([goofy-margin 15]
+	       [calc-w (- (get-pref 'sirmail:frame-width) goofy-margin)])
+	  (set! FROM-WIDTH (quotient calc-w 4))
+          (set! UID-WIDTH (quotient calc-w 5))
+	  (set! SUBJECT-WIDTH (- calc-w FROM-WIDTH UID-WIDTH)))
+	
+        (when (object? sorting-from-snip)
+          (send sorting-from-snip set-min-width FROM-WIDTH)
+          (send sorting-from-snip set-max-width FROM-WIDTH)
+          (send sorting-uid-snip set-min-width UID-WIDTH)
+          (send sorting-uid-snip set-max-width UID-WIDTH)
+          (send sorting-subject-snip set-min-width SUBJECT-WIDTH)
+          (send sorting-subject-snip set-max-width SUBJECT-WIDTH))
+        
+        (when (object? header-list)
+	  (let ([e (send header-list get-editor)])
+	    (send e begin-edit-sequence)
+	    (for-each (lambda (item)
+			(let* ([e (send item get-editor)]
+			       [line-snip
+				(let loop ([s (send e find-first-snip)])
+				  (cond
+                                    [(not s) #f]
+                                    [(is-a? s line-snip%) s]
+                                    [else (loop (send s next))]))])
+			  (send line-snip set-width (+ FROM-WIDTH SUBJECT-WIDTH UID-WIDTH))))
+		      (send header-list get-items))
+	    (send e end-edit-sequence))))
+      
+      (update-frame-width)
+      
+      (define unselected-delta (make-object style-delta% 'change-normal-color))
+      (define selected-delta (make-object style-delta%))
+      (send selected-delta set-delta-foreground "BLUE")
+      
+      (define unread-delta (make-object style-delta% 'change-bold))
+      (define read-delta (make-object style-delta% 'change-weight 'normal))
+      
+      (define marked-delta (make-object style-delta% 'change-italic))
+      (define unmarked-delta (make-object style-delta% 'change-style 'normal))
+      
+      (define red-delta (make-object style-delta%))
+      (send red-delta set-delta-foreground "red")
+      (define green-delta (make-object style-delta%))
+      (send green-delta set-delta-foreground "green")
+
+      ;; url-delta :  style-delta
+      ;; this is used to higlight urls in the editor window
+      (define url-delta (make-object style-delta% 'change-underline #t))
+      (send url-delta set-delta-foreground "blue")
+      
+      (define (apply-style i delta)
+        (let ([e (send i get-editor)])
+          (send e change-style delta 0 (send e last-position))))
+
+      (define (set-standard-style t s e)
+	(send t change-style (send (send t get-style-list) find-named-style "Standard")
+	      s e))
+      
+      (define current-selected #f)
+      
+      (define (set-current-selected i)
+	(unless (eq? current-selected i)
+	  (let ([e (send header-list get-editor)])
+	    (send e begin-edit-sequence)
+	    (when current-selected
+	      (apply-style current-selected unselected-delta))
+	    (set! current-selected i)
+	    (when i
+	      (apply-style i selected-delta)
+              ; In case we downloaded it just now:
+	      (apply-style i read-delta))
+	    (send e end-edit-sequence))))
+      
+      (define vertical-line-snipclass
+	(make-object
+            (class snip-class% ()
+              (define/override (read s)
+                (make-object vertical-line-snip%))
+              (super-instantiate ()))))
+      (send vertical-line-snipclass set-version 1)
+      (send vertical-line-snipclass set-classname "sirmail:vertical-line%")
+      (send (get-the-snip-class-list) add vertical-line-snipclass)
+      (define body-pen (send the-pen-list find-or-create-pen "blue" 0 'solid))
+      (define body-brush (send the-brush-list find-or-create-brush "WHITE" 'solid))
+      (define vertical-line-snip%
+	(class snip%
+          (inherit set-snipclass get-style get-admin)
+          (field
+           [width 15]
+           [height 10])
+          [define/override get-extent
+            (lambda (dc x y w-box h-box descent-box space-box lspace-box rspace-box)
+              (for-each (lambda (box) (when box (set-box! box 0)))
+                        (list w-box h-box lspace-box rspace-box))
+              (let ([old-font (send dc get-font)])
+                (send dc set-font (send (get-style) get-font))
+                (let-values ([(w h descent ascent)
+                              (send dc get-text-extent "yxX")])
+                  (when w-box
+                    (set-box! w-box width))
+                  
+                  ;; add one here because I know the descent for the entire
+                  ;; line is going to be one more than the descent of the font.
+                  (when descent-box
+                    (set-box! descent-box (+ descent 1)))
+                  
+                  (when space-box
+                    (set-box! space-box ascent))
+                  (let ([text (and (get-admin)
+                                   (send (get-admin) get-editor))])
+                    
+                    ;; add 2 here because I know lines are two pixels taller
+                    ;; than the font. How do I know? I just know.
+                    (set! height (+ h 2))
+                    (when h-box
+                      (set-box! h-box (+ h 2)))
+                    
+                    (send dc set-font old-font)))))]
+          [define/override draw
+            (lambda (dc x y left top right bottom dx dy draw-caret)
+              (let ([orig-pen (send dc get-pen)]
+                    [orig-brush (send dc get-brush)])
+                (send dc set-pen body-pen)
+                (send dc set-brush body-brush)
+                
+                (send dc draw-line 
+                      (+ x (quotient width 2))
+                      y
+                      (+ x (quotient width 2))
+                      (+ y (- height 1)))
+                
+                (send dc set-pen orig-pen)
+                (send dc set-brush orig-brush)))]
+          [define/override write
+            (lambda (s)
+              (void))]
+          [define/override copy
+            (lambda ()
+              (let ([s (make-object vertical-line-snip%)])
+                (send s set-style (get-style))
+                s))]
+          (super-instantiate ())
+          (set-snipclass vertical-line-snipclass)))
+      
+      (define common-style-list #f)
+      (define (single-style t)
+	;; Commented out for now:
+	'(if common-style-list
+	     (send t set-style-list common-style-list)
+	     (set! common-style-list (send t get-style-list)))
+	t)
+      
+      (define (make-field w)
+	(let ([m (instantiate editor-snip% ()
+                   (editor (single-style (let ([e (make-object text% 0.0)])
+                                           (send e set-keymap #f)
+                                           (send e set-max-undo-history 0)
+                                           e)))
+                   (with-border? #f)
+                   (top-margin 1)
+                   (top-inset 1)
+                   (bottom-margin 1)
+                   (bottom-inset 1)
+                   (min-width w)
+                   (max-width w))])
+	  (send m set-flags (remove 'handles-events (send m get-flags)))
+	  m))
+      
+      (define first-gap 35)
+      (define second-gap 15)
+      (define line-space 8)
+      (define extra-height 2)
+      (define left-edge-space 2)
+
+      (define line-snip%
+        (class snip%
+          (init-field from subject uid)
+          (define/override (draw dc x y left top bottom right dx dy draw-caret)
+            (let ([w (get-width)])
+              (let-values ([(_1 h _2 _3) (send dc get-text-extent "yX")])
+                
+                (let ([old-clip (send dc get-clipping-region)])
+                  (send dc set-clipping-rect x y (+ FROM-WIDTH (/ first-gap 2) (- line-space)) h)
+                  (send dc draw-text from (+ x left-edge-space) y #t)
+                  (send dc set-clipping-rect 
+                        (+ x FROM-WIDTH (/ first-gap 2) line-space)
+                        y 
+                        (+ SUBJECT-WIDTH (/ second-gap 2) (- line-space))
+                        h)
+                  (send dc draw-text subject (+ x FROM-WIDTH (/ first-gap 2) line-space) y #t)
+                  (send dc set-clipping-region old-clip)
+                  (send dc draw-text
+                        uid 
+                        (+ x FROM-WIDTH first-gap SUBJECT-WIDTH (/ second-gap 2) line-space)
+                        y
+			#t))
+                  
+		(let ([p (send dc get-pen)])
+		  (send dc set-pen body-pen)
+		  (send dc draw-line 
+			(+ x FROM-WIDTH (/ first-gap 2))
+			y
+			(+ x FROM-WIDTH (/ first-gap 2))
+			(+ y h extra-height))
+		  (send dc draw-line 
+			(+ x FROM-WIDTH first-gap SUBJECT-WIDTH (/ second-gap 2))
+			y
+			(+ x FROM-WIDTH first-gap SUBJECT-WIDTH (/ second-gap 2))
+			(+ y h extra-height))
+		  (send dc set-pen p)))))
+
+          (inherit get-style)
+          (define/override (get-extent dc x y wb hb db sb lb rb)
+            (let-values ([(w h d s) (send dc get-text-extent "yX" (send (get-style) get-font))])
+              (set-box/f! hb (+ extra-height h))
+              (set-box/f! wb (get-width))
+	      (set-box/f! db d)
+	      (set-box/f! sb s)
+	      (set-box/f! lb 2)
+	      (set-box/f! rb 0)))
+
+          (inherit get-admin)
+          
+          (field [width 500])
+          (define/public (set-width w) 
+            (let ([admin (get-admin)])
+              (when admin
+                (send admin resized this #t)))
+            (set! width w))
+          (define/private (get-width) width)
+          (super-new)))
+
+      (define (set-box/f! b v) (when (box? b) (set-box! b v)))
+      
+      (define (add-message m)
+        (let* ([i (send header-list new-item)]
+	       [e (send i get-editor)]
+               [one-line
+                (lambda (s)
+		  (regexp-replace* #rx"[ \r\n\t]+" s " "))]
+	       [snip (new line-snip% 
+                          (from
+                           (one-line (or (parse-encoded (message-from m))
+                                         "<unknown>")))
+                          (subject
+                           (one-line (or (parse-encoded (message-subject m))
+                                         no-subject-string)))
+                          (uid (format "~a" (message-uid m))))]
+               [before (send e last-position)])
+          (send e begin-edit-sequence)
+          (send i user-data (message-uid m))
+          (send e set-line-spacing 0)
+          (send snip set-width (+ FROM-WIDTH SUBJECT-WIDTH UID-WIDTH))
+	  (send e insert snip)
+          (unless (message-downloaded? m)
+            (send e change-style unread-delta before (+ before 1)))
+          (when (memq 'marked (message-flags m))
+            (send e change-style marked-delta before (+ before 1)))
+          (send e end-edit-sequence)
+          i))
+
+      (define display-text% (html-text-mixin text:standard-style-list%))
+      
+      ;; Class for the panel that has columns titles and
+      ;; supports clicks to change the sort order
+      (define sorting-list%
+        (class hierarchical-list%
+          (inherit get-editor selectable set-no-sublists)
+          
+          (define/private (find-sorting-key evt)
+            (let loop ([editor (get-editor)])
+              (when editor
+                (let ([xb (box (send evt get-x))]
+                      [yb (box (send evt get-y))])
+                  (send editor global-to-local xb yb)
+                  (let* ([pos (send editor find-position (unbox xb) (unbox yb))]
+                         [snip (send editor find-snip pos 'after-or-none)])
+                    (cond
+                      [(eq? snip sorting-from-snip) 'from]
+                      [(eq? snip sorting-subject-snip) 'subject]
+                      [(eq? snip sorting-uid-snip) 'uid]
+                      [(is-a? snip editor-snip%)
+                       (loop (send snip get-editor))]
+                      [else #f]))))))
+
+	  (define tracking #f)
+	  (define tracking-on? #f)
+          
+          (define/override (on-event evt)
+            (cond
+	      [(send evt button-down?)
+	       (set! tracking (find-sorting-key evt))
+	       (if tracking
+		   (begin
+		     (set! tracking-on? #t)
+		     (reset-sorting-tracking)
+		     (set-sorting-tracking tracking))
+		   (begin
+		     (set! tracking-on? #f)
+		     (reset-sorting-tracking)))]
+              [(and tracking
+		    (send evt button-up?))
+               (let ([sorting-key (find-sorting-key evt)]
+		     [was-tracking tracking])
+		 (set! tracking #f)
+		 (set! tracking-on? #f)
+		 (and (eq? sorting-key was-tracking)
+		      (case sorting-key
+			[(from) (sort-by-sender)]
+			[(subject) (sort-by-subject)]
+			[(uid) (sort-by-order-received)])))
+	       (reset-sorting-tracking)]
+	      [(and tracking
+		    (send evt dragging?))
+	       (let ([sorting-key (find-sorting-key evt)])
+		 (if (eq? sorting-key tracking)
+		     (unless tracking-on?
+		       (set! tracking-on? #t)
+		       (reset-sorting-tracking)
+		       (set-sorting-tracking tracking))
+		     (when tracking-on?
+		       (set! tracking-on? #f)
+		       (reset-sorting-tracking))))]
+	      [tracking
+	       (set! tracking #f)
+	       (set! tracking-on? #f)
+	       (reset-sorting-tracking)]))
+
+          (super-new (style '(hide-hscroll hide-vscroll)))
+	  (set-no-sublists #t)
+	  (selectable #f)))
+           
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;  GUI: Frame, Menus, & Key Bindings                      ;;
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      
+      ;; Message display modes
+      (define show-full-headers? #f)
+      (define quote-in-reply? #t)
+      (define mime-mode? #t)
+      (define no-mime-inline? #f)
+      (define html-mode? #t)
+      (define img-mode? #f)
+      (define prefer-text? (get-pref 'sirmail:prefer-text))
+      
+      (define global-keymap (make-object keymap%))
+      (send global-keymap add-function "new-mailer"
+	    (lambda (w e) (start-new-mailer #f "" "" "" "" "" null)))
+      (send global-keymap add-function "disconnect"
+	    (lambda (w e)
+	      (disconnect)
+	      (force-disconnect/status)))
+      (send global-keymap add-function "get-new-mail"
+	    (lambda (w e) (get-new-mail)))
+      (send global-keymap add-function "archive-current"
+            (lambda (w e) (send header-list archive-current-message)))
+      (send global-keymap add-function "prev-msg"
+	    (lambda (w e) (send header-list select-prev)))
+      (send global-keymap add-function "next-msg"
+	    (lambda (w e) (send header-list select-next)))
+      (send global-keymap add-function "mark-msg"
+	    (lambda (w e) (send header-list mark-message)))
+      (send global-keymap add-function "unmark-msg"
+	    (lambda (w e) (send header-list unmark-message)))
+      (send global-keymap add-function "hit-msg"
+	    (lambda (w e) (send header-list hit)))
+      (send global-keymap add-function "scroll-down"
+	    (lambda (w e) 
+	      (if (send header-list selected-hit?)
+		  (let*-values ([(e) (send message get-editor)]
+				[(x y) (send e editor-location-to-dc-location 0 0)])
+		    (send e move-position 'down #f 'page)
+		    (let*-values ([(x2 y2) (send e editor-location-to-dc-location 0 0)])
+		      (when (= y y2)
+			(let ([current (send header-list get-selected)])
+			  (send header-list select-next)
+			  (unless (eq? current (send header-list get-selected))
+			    (send header-list hit))))))
+		  (send header-list hit))))
+      (send global-keymap add-function "scroll-up"
+	    (lambda (w e) 
+	      (when (send header-list selected-hit?)
+		(let ([e (send message get-editor)])
+		  (send e move-position 'up #f 'page)))))
+      (send global-keymap add-function "rewind-msg"
+	    (lambda (w e) (send header-list rewind-selected)))
+      (send global-keymap add-function "forward-msg"
+	    (lambda (w e) (send header-list forward-selected)))      
+      (send global-keymap add-function "purge"
+	    (lambda (w e) 
+	      (purge-marked/update-headers)))
+      (send global-keymap add-function "gc"
+	    (lambda (w e) (dump-memory-stats) (collect-garbage)))
+      (send global-keymap add-function "show-memory-graph"
+	    (lambda (w e) (show-memory-graph)))
+      
+      (send global-keymap map-function ":m" "new-mailer")
+      (send global-keymap map-function ":g" "get-new-mail")
+      (send global-keymap map-function ":a" "archive-current")
+      (send global-keymap map-function ":i" "disconnect")
+      (send global-keymap map-function ":n" "next-msg")
+      (send global-keymap map-function ":p" "prev-msg")
+      (send global-keymap map-function ":return" "hit-msg")
+      (send global-keymap map-function ":d" "mark-msg")
+      (send global-keymap map-function ":u" "unmark-msg")
+      (send global-keymap map-function ":space" "scroll-down")
+      (send global-keymap map-function ":b" "scroll-up")
+      (send global-keymap map-function "#" "purge")
+      (send global-keymap map-function "!" "gc")
+      (send global-keymap map-function ":z" "show-memory-graph")
+      (send global-keymap map-function ":m:left" "rewind-msg")
+      (send global-keymap map-function ":d:left" "rewind-msg")
+      (send global-keymap map-function ":m:right" "forward-msg")
+      (send global-keymap map-function ":d:right" "forward-msg")
+      
+      (define icon (make-object bitmap% (build-path (collection-path "sirmail")
+						    "postmark.bmp")))
+      (define icon-mask (make-object bitmap% (build-path (collection-path "sirmail")
+							 "postmark-mask.xbm")))
+      (unless (and (send icon ok?)
+		   (send icon-mask ok?))
+	(set! icon #f))
+      
+      (define sm-super-frame%
+        (frame:searchable-mixin
+         (frame:standard-menus-mixin
+          frame:basic%)))
+      
+      (define sm-frame%
+	(class sm-super-frame%
+          (inherit get-menu-bar set-icon)
+
+          (define/override (file-menu:create-new?) #f)
+          (define/override (file-menu:create-open?) #f)
+          (define/override (file-menu:create-open-recent?) #f)
+
+          ;; -------------------- File Menu --------------------
+          
+          (define/override (file-menu:between-save-as-and-print file-menu)
+            (make-object menu-item% "&Get New Mail" file-menu
+              (lambda (i e) (get-new-mail))
+              #\g)
+            (make-object menu-item% "&Download All" file-menu
+              (lambda (i e) (download-all))
+              #\l)
+            (make-object menu-item% "Archive Message" file-menu
+              (lambda (i e)  (send header-list archive-current-message)))
+            (make-object separator-menu-item% file-menu)
+            (make-object menu-item%
+              "&Open Folders List"
+              file-menu
+              (lambda (x1 x2) (open-folders-window)))
+            (make-object separator-menu-item% file-menu)
+            (make-object menu-item% "&New Message" file-menu
+              (lambda (i e) (start-new-mailer #f "" "" "" "" "" null))
+              #\m)
+            (make-object menu-item% "&Resume Message..." file-menu
+              (lambda (i e) 
+                (let ([file (get-file "Select message to resume"
+                                      main-frame)])
+                  (when file
+                    (start-new-mailer file "" "" "" "" "" null)))))
+            (instantiate menu-item% () 
+              (label "Send Queued Messages")
+              (parent file-menu)
+              (demand-callback
+               (lambda (menu-item) 
+                 (send menu-item enable (enqueued-messages?))))
+              (callback
+               (lambda (i e)
+                 (send-queued-messages))))
+            
+            (make-object separator-menu-item% file-menu)
+            (make-object menu-item% "&Save Message As..." file-menu
+              (lambda (i e)
+                (let ([f (put-file "Save message to"
+                                   main-frame)])
+                  (when f
+                    (send (send message get-editor) save-file f 'text))))))
+          
+          (define/override (file-menu:create-print?) #t)
+          (define/override (file-menu:print-callback i e)
+            (send (send message get-editor) print))
+          
+          (define/override (file-menu:between-print-and-close file-menu)
+            (make-object separator-menu-item% file-menu)
+            (make-object menu-item% "D&isconnect" file-menu
+              (lambda (i e) 
+                (disconnect)
+		(force-disconnect/status))
+              #\i))
+          
+          (define/override (file-menu:close-callback i e) (send main-frame on-close))
+          (define/override (file-menu:create-quit?) #f)
+          
+          ;; -------------------- Help Menu --------------------
+          
+          (define/override (help-menu:after-about menu)
+            (make-object menu-item% "&Help" menu
+              (lambda (i e)
+                (let* ([f (instantiate frame% ("Help")
+                            [width 500]
+                            [height 300])]
+                       [e (make-object text%)]
+                       [c (make-object editor-canvas% f e)])
+                  (send e load-file
+                        (build-path (collection-path "sirmail")
+                                    "doc.txt"))
+                  (send f show #t))))
+            (super help-menu:after-about menu))
+          
+          ;; -------------------- Misc. --------------------
+          
+          (inherit get-edit-target-object)
+          (define/override (get-text-to-search) 
+            (send message get-editor))
+          
+          [define/override on-size
+            (lambda (w h)
+              (put-pref 'sirmail:frame-width w)
+              (put-pref 'sirmail:frame-height h)
+              (update-frame-width)
+              (super on-size w h))]
+          [define/augment can-close? (lambda () 
+				       (and (send (get-menu-bar) is-enabled?)
+					    (inner #t can-close?)))]
+          [define/augment on-close (lambda () 
+				     (logout)
+				     (inner (void) on-close))]
+          [define/override on-subwindow-char
+            (lambda (w e)
+              (or (and
+                   (send (send main-frame get-menu-bar) is-enabled?)
+                   (or (send global-keymap handle-key-event w e)
+                       (and (eq? #\tab (send e get-key-code))
+                            (member w (list header-list message))
+                            (send (if (eq? w message)
+                                      header-list
+                                      message)
+                                  focus))))
+                  (super on-subwindow-char w e)))]
+          (super-instantiate ())
+          (when icon
+            (set-icon icon icon-mask 'both))))
+
+      ;; -------------------- Frame Creation --------------------
+      
+      (set! main-frame (make-object sm-frame% mailbox-name #f 
+				    (get-pref 'sirmail:frame-width)
+				    (get-pref 'sirmail:frame-height)))
+      (define mb (send main-frame get-menu-bar))
+
+      ;; -------------------- Message Menu --------------------
+      
+      (define msg-menu (make-object menu% "&Message" mb))
+      
+      (make-object menu-item% "&Reply" msg-menu
+		   (lambda (i e) (do-reply #f quote-in-reply?))
+		   #\R)
+      (make-object menu-item% "&Follow Up" msg-menu
+        (lambda (i e) (do-reply #t quote-in-reply?))
+        #\t)
+      (make-object menu-item% "F&orward" msg-menu
+        (lambda (i e) (do-forward))
+        #\W)
+      (send (make-object checkable-menu-item% "&Quote Original" msg-menu
+              (lambda (item e)
+                (set! quote-in-reply? (send item is-checked?))))
+	    check #t)
+      (make-object separator-menu-item% msg-menu)
+      (make-object menu-item% "&Mark Selected" msg-menu
+		   (lambda (i e)
+		     (send header-list mark-message))
+		   #\D)
+      (make-object menu-item% "&Unmark Selected" msg-menu
+        (lambda (i e)
+          (send header-list unmark-message))
+        #\U)
+      (define (mark-all mark?)
+	(let* ([marked-uids (map message-uid (filter (if mark?
+							 (lambda (x) (not (message-marked? x)))
+							 message-marked?)
+						     mailbox))]
+	       [items (send header-list get-items)]
+	       [selected (send header-list get-selected)])
+	  (for-each
+	   (lambda (i)
+	     (when (member (send i user-data) marked-uids)
+	       (send i select #t)
+	       (if mark?
+		   (send header-list mark-message)
+		   (send header-list unmark-message))))
+	   items)
+	  (if selected
+	      (send selected select #t)
+	      (send (send header-list get-selected) select #f))))
+      
+      (make-object menu-item% "Mark All" msg-menu
+        (lambda (i e) (mark-all #t)))
+      (make-object menu-item% "Unmark All" msg-menu
+        (lambda (i e) (mark-all #f)))
+      
+      (make-object separator-menu-item% msg-menu)
+      (make-object menu-item% "&Delete Marked" msg-menu
+        (lambda (i e)
+          (when (eq? 'yes
+                     (confirm-box
+                      "Delete Marked?"
+                      "Really delete the marked messages?"
+                      main-frame))
+            (purge-marked/update-headers))))
+
+      (make-object (class menu-item%
+                     (inherit enable set-label)
+                     (define/override (on-demand)
+                       (let ([folder (get-active-folder)])
+                         (enable folder)
+                         (when folder
+                           (set-label (format "&Copy Marked to ~a" folder)))))
+                     (super-instantiate ()))
+        "&Copy Marked to Selected Folder" 
+        msg-menu
+        (lambda x
+          (let ([mbox (get-active-folder)])
+            (if mbox
+                (copy-marked-to mbox)
+                (bell)))))
+      
+      (make-object separator-menu-item% msg-menu)
+      (define sort-menu (make-object menu% "&Sort" msg-menu))
+      (let ([m (make-object menu% "Decode" msg-menu)])
+        (letrec ([switch (lambda (item e)
+                           (if (send item is-checked?)
+                               (begin
+                                 ;; Disable others:
+                                 (send raw check (eq? raw item))
+                                 (send mime-lite check (eq? mime-lite item))
+				 (send mime check (eq? mime item))
+                                 (send html check (eq? html item))
+                                 (send img check (eq? img item))
+                                 ;; Update flags
+                                 (set! mime-mode? (or (send mime is-checked?)
+						      (send mime-lite is-checked?)
+                                                      (send html is-checked?)
+                                                      (send img is-checked?)))
+				 (set! no-mime-inline? (or (send mime-lite is-checked?)))
+                                 (set! html-mode? (or (send html is-checked?)
+                                                      (send img is-checked?)))
+                                 (set! img-mode? (send img is-checked?))
+                                 ;; Re-decode
+                                 (redisplay-current))
+                               ;; Turn it back on
+                               (send item check #t)))]
+                 [raw (make-object checkable-menu-item% "&Raw" m switch)]
+                 [mime-lite (make-object checkable-menu-item% "MIME &without Inline" m switch)]
+                 [mime (make-object checkable-menu-item% "&MIME" m switch)]
+                 [html (make-object checkable-menu-item% "MIME and &HTML" m switch)]
+                 [img (make-object checkable-menu-item% "MIME, HTML, and &Images" m switch)])
+          (send (if (and mime-mode? html-mode?)
+                    html
+                    (if mime-mode?
+                        mime
+                        raw))
+                check #t)
+	  (make-object separator-menu-item% m)
+	  (send (make-object checkable-menu-item% "Prefer &Text" m
+			     (lambda (i e)
+			       (put-pref 'sirmail:prefer-text (send i is-checked?))
+			       (set! prefer-text? (send i is-checked?))
+			       (redisplay-current)))
+		check prefer-text?)))
+      (define wrap-lines-item
+	(make-object checkable-menu-item% "&Wrap Lines" msg-menu
+		     (lambda (item e)
+		       (put-pref 'sirmail:wrap-lines (send item is-checked?))
+		       (send (send message get-editor) auto-wrap
+			     (send item is-checked?)))))
+      (make-object checkable-menu-item% "&View Full Header" msg-menu
+        (lambda (i e)
+          (set! show-full-headers? (send i is-checked?))
+	  (redisplay-current)))
+
+      (make-object menu-item% "by Sender" sort-menu (lambda (i e) (sort-by-sender)))
+      (make-object menu-item% "by Subject" sort-menu (lambda (i e) (sort-by-subject)))
+      (make-object menu-item% "by Date" sort-menu (lambda (i e) (sort-by-date)))
+      (make-object menu-item% "by Order Received" sort-menu (lambda (i e) (sort-by-order-received)))
+      
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;  GUI: Message List                                      ;;
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+      (define drag-cursor (make-object cursor% 'hand))      
+      (define plain-cursor (make-object cursor% 'arrow))
+      (define arrow+watch-cursor (make-object cursor% 'arrow+watch))
+      
+      (define header-list%
+	(class hierarchical-list%
+
+          (inherit get-items show-focus set-cursor select)
+          (field [selected #f])
+          
+          (define/public (mark marked?)
+            (when selected
+              (let* ([uid (send selected user-data)]
+                     [m (find-message uid)]
+                     [flags (message-flags m)])
+                (unless (eq? (not marked?) 
+                             (not (memq 'marked flags)))
+                  (set-message-flags! m (if marked?
+                                            (cons 'marked flags)
+                                            (remq 'marked flags)))
+                  (write-mailbox)
+                  (apply-style selected 
+                               (if marked? 
+                                   marked-delta
+                                   unmarked-delta))
+                  (status "~aarked" 
+                          (if marked? "M" "Unm"))))))
+          
+          (define/public (archive-current-message)
+            (when selected
+              (let ([archive-mailbox (ARCHIVE-MAILBOX)])
+                (when archive-mailbox
+                  (let* ([uid (send selected user-data)]
+                         [item (find-message uid)])
+                    (header-changing-action
+                     #f
+                     (lambda ()
+                       (as-background
+                        enable-main-frame
+                        (lambda (bad-break break-ok)
+                          (with-handlers ([void no-status-handler])
+                            (copy-messages-to (list item) archive-mailbox)
+                            (purge-messages (list item) bad-break break-ok)))
+                        close-frame))))))))
+          
+          (define/public (hit)
+            (when selected
+              (on-double-select selected)))
+          
+          (define/public (mark-message)
+            (mark #t))
+          (define/public (unmark-message)
+            (mark #f))
+          (define/public (selected-hit?) (eq? selected current-selected))
+          (define/override (on-select i)
+            (set! selected i))
+
+          ;; -------------------- Message selection --------------------
+          
+	  (define past-selected null)
+	  (define future-selected null)
+
+	  (define/private (push-selected uid)
+	    (unless (and (pair? past-selected)
+			 (equal? uid (car past-selected)))
+	      (set! future-selected (remove uid future-selected))
+	      (set! past-selected (cons uid (remove uid past-selected)))))
+
+	  (define/public (rewind-selected)
+	    (when (pair? past-selected)
+	      (set! future-selected (cons (car past-selected)
+					  future-selected))
+	      (set! past-selected (cdr past-selected)))
+	    (unless (pair? past-selected)
+	      (set! past-selected (reverse future-selected))
+	      (set! future-selected null))
+	    (set! past-selected (select-from-stack past-selected)))
+
+	  (define/public (forward-selected)
+	    (unless (pair? future-selected)
+	      (set! future-selected (reverse past-selected))
+	      (set! past-selected null))
+	    (set! future-selected (select-from-stack future-selected))
+	    (when (pair? future-selected)
+	      (set! past-selected (cons (car future-selected)
+					past-selected))
+	      (set! future-selected (cdr future-selected))))
+
+	  (define (select-from-stack selected)
+	    (if (pair? selected)
+		(let* ([uid (car selected)]
+		       [i (ormap (lambda (i)
+				   (and (equal? uid (send i user-data))
+					i))
+				 (send header-list get-items))])
+		  (if i
+		      (begin
+			(select i)
+			(do-double-select i #f)
+			selected)
+		      (select-from-stack (cdr selected))))
+		null))
+
+          (define/override (on-double-select i)
+	    (do-double-select i #t))
+	  
+	  (define/private (do-double-select i push?)
+            (let ([e (send message get-editor)]
+                  [uid (send i user-data)])
+              (dynamic-wind
+               (lambda ()
+                 (send e lock #f)
+                 (send e begin-edit-sequence))
+               (lambda ()
+                 (send e erase)
+                 (set-current-selected #f)
+                 (let* ([h (get-header uid)]
+			[small-h (get-viewable-headers h)])
+                   (send e insert 
+			 (string-crlf->lf small-h)
+                         0 'same #f)
+		   ;; Do the body (possibly mime)
+		   (let ([body (as-background 
+				enable-main-frame
+				(lambda (break-bad break-ok) 
+				  (get-body uid break-bad break-ok))
+				close-frame)]
+			 [insert (lambda (body delta)
+				   (let ([start (send e last-position)])
+				     (send e set-position start)
+				     (send e insert 
+					   body
+					   start 'same #f)
+				     (let ([end (send e last-position)])
+				       (delta e start end))))])
+		     (when push?
+		       (push-selected uid))
+		     (parse-and-insert-body h body e insert 78 img-mode?)))
+                 (send e set-position 0)
+                 (set-current-selected i))
+               (lambda ()
+                 (send e end-edit-sequence)
+                 (send e lock #t)))))
+
+          ;; -------------------- Message drag'n'drop --------------------
+          
+          (inherit get-editor client->screen)
+          (field (dragging-item #f)
+                 (dragging-title #f)
+                 (last-status #f)
+                 (drag-start-x 0)
+                 (drag-start-y 0))
+          (define/override (on-event evt)
+            (cond
+              [(send evt button-down?)
+               (when dragging-item
+                 (status "")
+                 (send (get-editor) set-cursor plain-cursor)
+                 (set! dragging-item #f))
+               (let ([text (get-editor)])
+                 (when text
+                   (let ([xb (box (send evt get-x))]
+                         [yb (box (send evt get-y))])
+                     (send text global-to-local xb yb)
+                     (let* ([pos (send text find-position (unbox xb) (unbox yb))]
+                            [snip (send text find-snip pos 'after-or-none)]
+                            [item (and (is-a? snip hierarchical-item-snip%)
+                                       (send snip get-item))])
+                       (set! dragging-title "???")
+                       (set! dragging-item item)
+                       (set! drag-start-x (send evt get-x))
+                       (set! drag-start-y (send evt get-y))
+                       (when dragging-item
+                         (let* ([ud (send dragging-item user-data)]
+                                [message (find-message ud)]
+                                [cap-length 50])
+                           (when message
+                             (let ([title (message-subject message)])
+                               (cond
+                                 [(not title) (set! dragging-title no-subject-string)]
+                                 [((string-length title) . <= . cap-length)
+                                  (set! dragging-title title)]
+                                 [else
+                                  (set! dragging-title
+                                        (string-append (substring title 0 (- cap-length 3)) "..."))])))))))))]
+              [(send evt dragging?)
+	       (when dragging-item
+                 (when (or ((abs (- (send evt get-x) drag-start-x)) . > . 5)
+                           ((abs (- (send evt get-y) drag-start-y)) . > . 5))
+                   (send (get-editor) set-cursor drag-cursor))
+		 (let-values ([(gx gy) (client->screen (send evt get-x) (send evt get-y))])
+		   (let ([mailbox-name (send-message-to-window gx gy (list gx gy))])
+		     (if (string? mailbox-name)
+			 (status "Move message \"~a\" to ~a" dragging-title mailbox-name)
+			 (status "")))))]
+              [(send evt button-up?)
+	       (when dragging-item
+                 (send (get-editor) set-cursor plain-cursor)
+		 (let-values ([(gx gy) (client->screen (send evt get-x) (send evt get-y))]
+			      [(ditem) dragging-item])
+		   (set! dragging-item #f)
+		   (let ([mailbox-name (send-message-to-window gx gy (list gx gy))])
+                     (if (bytes? mailbox-name)
+                         (let* ([user-data (send ditem user-data)]
+                                [item (find-message user-data)])
+                           (when item
+			     (header-changing-action
+			      #f
+			      (lambda ()
+				(as-background
+				 enable-main-frame
+				 (lambda (bad-break break-ok)
+				   (with-handlers ([void no-status-handler])
+                                     (void)
+				     (copy-messages-to (list item) mailbox-name)
+                                     (purge-messages (list item) bad-break break-ok)))
+				 close-frame)))))
+                         (status "")))))]
+              [else
+               (when (and dragging-item
+			  (not (and (or (send evt leaving?)
+					(send evt entering?))
+				    (or (send evt get-left-down)
+					(send evt get-middle-down)
+					(send evt get-right-down)))))
+                 (set! dragging-item #f)
+                 (send (get-editor) set-cursor plain-cursor)
+                 (status ""))])
+
+            (super on-event evt))
+
+	  (super-new (style '(no-hscroll)))
+          (show-focus #t)))
+      
+      ;; header-changing-action: bool thunk -> thunk-result
+      ;; Use this function to bracket operations that change
+      ;; `mailbox'. It will use before an after values to update
+      ;; the message list.
+      (define (header-changing-action downloads? go)
+	(let ([old-mailbox mailbox])
+	  (dynamic-wind
+	   void
+	   go
+	   (lambda ()
+	     (let ([items (send header-list get-items)]
+		   [selected (send header-list get-selected)]
+		   [need-del-selection? #f]
+		   [set-selection? #f])
+	       (send (send header-list get-editor) begin-edit-sequence)
+	       (for-each
+		(lambda (i)
+		  (let ([a (find-message (send i user-data))])
+		    (if a
+			(begin ; Message still here
+			  (when (and downloads? (message-downloaded? a))
+				(apply-style i read-delta))
+			  (when need-del-selection?
+				(set! need-del-selection? #f)
+				(send i select #t)))
+			(begin ; Message gone
+			  (when (eq? i selected)
+				(set! need-del-selection? #t))
+			  (when (eq? i current-selected)
+				(let ([e (send message get-editor)])
+				  (send e begin-edit-sequence)
+				  (send e lock #f)
+				  (send e erase)
+				  (send e lock #t)
+				  (send e end-edit-sequence))
+				(set-current-selected #f))
+			  (send header-list delete-item i)))))
+		items)
+	       (for-each
+		(lambda (m)
+		  (unless (assoc (message-uid m) old-mailbox)
+			  (let ([i (add-message m)])
+			    (unless set-selection?
+				    (set! set-selection? #t)
+				    (send i select #t)
+				    (send i scroll-to)))))
+		mailbox)
+	       (send (send header-list get-editor) end-edit-sequence))))))
+      
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;  GUI: Message Operations                                ;;
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+      ;;  Closes connections and  terminates the window
+      (define (logout)
+	(with-handlers ([void
+			 (lambda (x)
+			   (show-error x)
+			   (when (eq? 'yes
+				      (confirm-box
+				       "Error"
+				       "There was an error disconnecting. Exit anyway?"
+				       main-frame))
+			     (exit-sirmail "read-window exception (1)")
+			     (send main-frame show #f)))])
+	  (disconnect)
+	  (when biff (send biff stop))
+	  (exit-sirmail "read-window exception (2)")
+	  (send main-frame show #f)))
+            
+      (define (get-new-mail)
+	(with-handlers ([void
+			 (lambda (x)
+			   (status "")
+			   (if (send disconnected-msg is-shown?)
+			       (raise x)
+			       (begin
+				 (show-error x)
+				 (when (exn:fail:network? x)
+				   (when (eq? 'yes
+					      (confirm-box
+					       "Error"
+					       (format "There was an communication error.~nClose the connection?")
+					       main-frame))
+				     (force-disconnect/status))))))])
+	  (header-changing-action
+	   #f
+	   (lambda ()
+	     (as-background
+	      enable-main-frame
+	      (lambda (break-bad break-ok) 
+		(when (or (not initialized?)
+			  (check-for-new break-bad break-ok))
+		  (update-local break-bad break-ok)))
+	      close-frame)))))
+      
+      (define (purge-marked/update-headers)
+	(header-changing-action 
+	 #f
+	 (lambda ()
+	   (as-background 
+	    enable-main-frame
+	    (lambda (break-bad break-ok) 
+	      (with-handlers ([void no-status-handler])
+		(purge-marked break-bad break-ok)))
+	    close-frame))))
+      
+      (define (copy-marked-to dest-mailbox-name)
+	(let* ([marked (filter message-marked? mailbox)])
+	  (as-background
+	   enable-main-frame
+	   (lambda (break-bad break-ok)
+	     (copy-messages-to marked dest-mailbox-name))
+	   close-frame)))
+      
+      (define (copy-messages-to marked dest-mailbox-name)
+        (unless (null? marked)
+          (let-values ([(imap count new?) (connect)])
+            (check-positions imap marked)
+            (status "Copying messages to ~a..." dest-mailbox-name)
+	    (imap-copy imap (map message-position marked) dest-mailbox-name)
+	    (status "Copied to ~a" dest-mailbox-name))))
+      
+      (define (auto-file)
+	(as-background
+	 enable-main-frame
+	 (lambda (break-bad break-ok)
+	   (break-ok)
+	   (map
+	    (lambda (auto)
+	      (let* ([dest-mailbox-name (car auto)]
+		     [fields (map car (cadr auto))]
+		     [val-rxs (map string->regexp (map cadr (cadr auto)))])
+		(with-handlers ([void no-status-handler])
+		  (break-ok)
+		  (status "Finding ~a messages..." dest-mailbox-name)
+		  (let ([file-msgs 
+			 (filter
+			  (lambda (m)
+			    (and (not (message-marked? m))
+				 (let ([h (get-header (message-uid m))])
+				   (ormap (lambda (field val-rx)
+					    (let ([v (extract-field field h)])
+					      (and v (regexp-match val-rx v))))
+					  fields val-rxs))))
+			  mailbox)])
+		    (unless (null? file-msgs)
+		      (status "Filing to ~a..." dest-mailbox-name)
+		      (break-bad)
+		      (let-values ([(imap count new?) (connect)])
+			(status (format "Filing to ~a..." dest-mailbox-name))
+                        ; Copy messages for filing:
+			(imap-copy imap (map message-position file-msgs) dest-mailbox-name)
+                        ; Mark them (let the user delete)
+			(for-each (lambda (m)
+				    (set-message-flags! m (cons 'marked (message-flags m)))
+				    (let ([i (let ([items (send header-list get-items)]
+						   [uid (message-uid m)])
+					       (ormap (lambda (i) (and (eq? (send i user-data) uid)
+								       i))
+						      items))])
+				      (apply-style i marked-delta)))
+				  file-msgs)
+			(write-mailbox)))))))
+	    (AUTO-FILE-TABLE)))
+	 close-frame)
+	(status "Auto file done"))
+      
+      (define (download-all)
+	(get-new-mail)
+	(header-changing-action
+	 #t
+	 (lambda ()
+	   (as-background
+	    enable-main-frame
+	    (lambda (break-bad break-ok)
+	      (with-handlers ([exn:break?
+			       (lambda (x) "<interrupted>")])
+		(break-ok)
+		(with-handlers ([exn:break? (lambda (x) (void))])
+	           (for-each (lambda (message)
+			       (let ([uid (message-uid message)])
+				 (break-bad)
+				 (get-body uid break-bad break-ok)
+				 (break-ok)))
+			     mailbox))))
+	    close-frame))))
+      
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;  GUI: Rest of Frame                                     ;;
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      
+      (define sizing-panel (make-object panel:vertical-dragable% (send main-frame get-area-container)))
+      (define top-half (make-object vertical-panel% sizing-panel))
+      (define button-panel (new horizontal-panel% 
+                                (parent top-half)
+                                (stretchable-height #f)))
+      (define sorting-list (instantiate sorting-list% ()
+                             (parent top-half)
+                             (stretchable-height #f)
+			     (vertical-inset 1)))
+      (define header-list (make-object header-list% top-half))
+      (send (send header-list get-editor) set-line-spacing 0)
+      (define message (new editor-canvas% 
+			   [parent sizing-panel]
+			   [style '(auto-hscroll)]))
+      (send header-list min-height 20)
+      (send header-list stretchable-height #t)
+      (send header-list set-no-sublists #t)
+      (send main-frame reflow-container)
+      (with-handlers ([void void])
+        (send sizing-panel set-percentages (list 1/3 2/3)))
+      (let ([e (make-object display-text%)])
+	((current-text-keymap-initializer) (send e get-keymap))
+	(send e set-max-undo-history 0)
+	(send message set-editor e)
+	(make-fixed-width message e #f #f)
+	(let ([b (make-object bitmap% (build-path (collection-path "icons") "return.xbm") 'xbm)])
+	  (when (send b ok?)
+	    (send e set-autowrap-bitmap b)))
+	(send e lock #t))
+
+      (when (get-pref 'sirmail:wrap-lines)
+	(send wrap-lines-item check #t)
+	(send (send message get-editor) auto-wrap #t))
+      
+      ;; enable-main-frame - use with `as-background'
+      (define can-poll? #t)      
+      (define (enable-main-frame on? refocus break-proc)
+	(let ([w (send main-frame get-focus-window)])
+	  (set! can-poll? on?)
+	  (send sorting-list enable on?)
+	  (send header-list enable on?)
+	  (send message enable on?)
+	  (let* ([cursor (if on? plain-cursor arrow+watch-cursor)])
+	    (send main-frame set-cursor cursor)
+	    (send (send sorting-list get-editor) set-cursor cursor #t)
+	    (send (send header-list get-editor) set-cursor cursor #t)
+	    (send (send message get-editor) set-cursor (if on? #f cursor) #t))
+	  (send (send main-frame get-menu-bar) enable on?)
+	  (set! cancel-button-todo break-proc)
+	  (send cancel-button enable (not on?))
+	  (when (and on? refocus)
+	    (send refocus focus))
+	  w))
+
+      (define (close-frame)
+	(send main-frame show #f))
+      
+      (define no-status-handler (lambda (x) (status "") (raise x)))
+            
+      (define disable-button-panel (make-object horizontal-panel% button-panel))
+      (define mailbox-message (make-object message% (format "~a: XXXXX" mailbox-name) disable-button-panel))
+      (define (display-message-count n)
+	(send mailbox-message set-label (format "~a: ~a" mailbox-name n)))
+      (display-message-count (length mailbox))
+      (define new-mail-message%
+        (class canvas%
+          (inherit get-dc get-client-size get-parent
+		   horiz-margin vert-margin)
+          (init-field font)
+          (define message "<<unset>>")
+          (define/override (on-paint)
+            (let ([dc (get-dc)])
+              (send dc set-font font)
+              (let-values ([(w h) (get-client-size)]
+                           [(tw th ta td) (send dc get-text-extent message)])
+                (send dc set-pen (send the-pen-list find-or-create-pen (get-panel-background) 1 'transparent))
+                (send dc set-brush (send the-brush-list find-or-create-brush (get-panel-background) 'panel))
+                (send dc draw-rectangle 0 0 w h)
+                (send dc draw-text message
+                      (- (/ w 2) (/ tw 2))
+                      (- (/ h 2) (/ th 2))
+		      #t))))
+          (define/public (set-message n)
+            (set! message 
+                  (cond
+                    [(get-pref 'sirmail:always-happy) "New Mail!"]
+                    [(n . <= . 50) "New Mail!"]
+                    [(n . <= . 200) "New Mail"]
+                    [else "New Mail!@#$%"]))
+            (update-min-width))
+          (inherit min-width)
+          (define/private (update-min-width)
+            (let-values ([(w h d s) (send (get-dc) get-text-extent message font)])
+              (min-width (inexact->exact (ceiling w)))))
+          (super-new (style '(transparent)))
+          (update-min-width)
+          (inherit stretchable-width)
+	  (horiz-margin 2)
+	  (vert-margin 2)
+          (stretchable-width #f)))
+      
+      (define-values (show-new-mail-msg hide-new-mail-msg disconnected-msg enqueued-msg)
+	(let* ([font (make-object font% (send normal-control-font get-point-size) 'system 'normal 'bold)])
+	  (let ([spacer (make-object message% "  " disable-button-panel)]
+                [m (make-object new-mail-message% font disable-button-panel)]
+		[d (new message% [label "Disconnected"] [parent disable-button-panel] [font font])]
+                [e-msg (new message% [label "Mail Enqueued"] [parent disable-button-panel] [font font])])
+	    (send m show #f)
+            (send e-msg show #f)
+	    (values (lambda () 
+                      (send m set-message (length mailbox))
+                      (send m show #t))
+                    (lambda () (send m show #f))
+                    d
+                    e-msg))))
+      
+      (thread
+       (lambda ()
+         (let loop ()
+           (unless (and (object? main-frame)
+                        (send main-frame is-shown?)
+                        (procedure? enqueued-messages?))
+             (sleep 1/2)
+             (loop)))
+         (let loop ()
+           (when (send main-frame is-shown?)
+             (send enqueued-msg show (enqueued-messages?))
+             (sleep 1/2)
+             (loop)))))
+
+      ;; Optional GC icon (lots of work for this little thing!)
+      (when (get-pref 'sirmail:show-gc-icon)
+	(let* ([gif (make-object bitmap% (build-path (collection-path "icons") "recycle.gif"))]
+	       [w (send gif get-width)]
+	       [h (send gif get-height)]
+	       [recycle-bm (make-object bitmap% (quotient w 2) (quotient h 2))]
+	       [dc (make-object bitmap-dc% recycle-bm)])
+	  (send dc set-scale 0.5 0.5)
+	  (send dc draw-bitmap gif 0 0)
+	  (send dc set-bitmap #f)
+	  (let* ([w (send recycle-bm get-width)]
+		 [h (send recycle-bm get-height)]
+		 [canvas (instantiate canvas% (button-panel)
+				      [stretchable-width #f]
+				      [stretchable-height #f]
+				      [style '(border)])]
+		 [empty-bm (make-object bitmap% w h)]
+		 [dc (make-object bitmap-dc% empty-bm)])
+	    (send canvas min-client-width w)
+	    (send canvas min-client-height h)
+	    (send dc clear)
+	    (send dc set-bitmap #f)
+	    (register-collecting-blit canvas 
+				      0 0 w h
+				      recycle-bm empty-bm
+				      0 0 0 0))))
+
+      (define cancel-button
+	(make-object button% "Stop" button-panel
+		     (lambda (b e) (cancel-button-todo))))
+      (define cancel-button-todo void)
+      (send cancel-button enable #f)
+
+      ;; -------------------- Status Line --------------------
+      
+      (define last-status "")
+      (define status-sema (make-semaphore 1))
+      (define (status . args)
+        (semaphore-wait status-sema)
+	(let ([s (apply format args)])
+          (unless (equal? s last-status)
+            (set! last-status s)
+            (update-status-text)))
+        (semaphore-post status-sema))
+      
+      ;; update-status-text : -> void
+      ;; =any thread=
+      (define (update-status-text)
+        (let ([mem-str
+               (if (and vsz rss)
+                   (format "(mz: ~a vsz: ~a rss: ~a vocab: ~a)"
+                           (format-number (quotient (current-memory-use) 1024)) 
+                           vsz 
+                           rss
+                           (word-count))
+                   (format "(mz: ~a vocab: ~a)"
+                           (format-number (quotient (current-memory-use) 1024))
+                           (word-count)))])
+        (send main-frame set-status-text 
+              (if (equal? last-status "")
+                  mem-str
+                  (string-append last-status " " mem-str)))))
+      (thread
+       (lambda ()
+         (let loop ()
+	   (semaphore-wait status-sema)
+           (when (object? main-frame)
+             (update-status-text))
+           (semaphore-post status-sema)
+	   (sleep 5)
+           (loop))))
+      
+      (define vsz #f)
+      (define rss #f)
+      (define (start-vsz/rss-thread)
+        (thread
+         (lambda ()
+           (define (get-numbers)
+             (with-handlers ([exn:fail? (lambda (x) #f)])
+               (let ([re:nums #rx"[^ \t]*[ \t]*[^ \t]*[ \t]*[^ \t]*[ \t]*[^ \t]*[ \t]*([0-9]*)[ \t]*([0-9]*)[ \t]*"])
+                 (let ([m (regexp-match re:nums (get-lines))])
+                   (and m
+                        (map string->number (cdr m)))))))
+           (define command "ps wwaux | grep SirMail | grep -v grep")
+           
+           (define (get-lines)
+             (let ([p (open-output-string)])
+               (parameterize ([current-output-port p]
+                              [current-input-port (open-input-string "")])
+                 (system command))
+               (get-output-string p)))
+           
+           (let loop ()
+             (let ([v (get-numbers)])
+               (when (and v (send main-frame is-shown?))
+                 (set! vsz (format-number (car v)))
+                 (set! rss (format-number (cadr v)))
+                 (sleep 10)
+                 (loop)))))))
+
+      ;; copied from framerok/private/frame.sss -- be sure to propogate fixes....
+      ;; or establish single point of control.
+      (define (format-number n)
+	(if n
+	    (let loop ([n n])
+	      (cond
+	       [(<= n 1000) (number->string n)]
+	       [else
+		(string-append 
+		 (loop (quotient n 1000))
+		 ","
+		 (pad-to-3 (modulo n 1000)))]))
+	    "???"))
+      
+      (define (pad-to-3 n)
+        (cond
+          [(<= n 9) (format "00~a" n)]
+          [(<= n 99) (format "0~a" n)]
+          [else (number->string n)]))
+      
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;  GUI: Sorting                                           ;;
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;      
+
+      (send sorting-list min-height 5)
+      (define sorting-text (send (send sorting-list new-item) get-editor))
+      (define sorting-text-from (make-object text%))
+      (send sorting-text-from insert "From")
+      (define sorting-text-subject (make-object text%))
+      (send sorting-text-subject insert "Subject")
+      (define sorting-text-uid (make-object text%))
+      (send sorting-text-uid insert "UID")
+      (define (add-sorting-es text width)
+        (let ([es (instantiate editor-snip% ()
+                    (with-border? #f)
+                    (editor text)
+                    (top-margin 1)
+                    (top-inset 1)
+                    (bottom-margin 1)
+                    (bottom-inset 1))])
+          (send sorting-text insert es)
+          (send es set-flags (remove 'handles-events (send es get-flags)))
+          es))
+      (send sorting-list set-line-count 1)
+      (define sorting-from-snip (add-sorting-es sorting-text-from FROM-WIDTH))
+      (send sorting-text insert (make-object vertical-line-snip%))
+      (define sorting-subject-snip (add-sorting-es sorting-text-subject SUBJECT-WIDTH))
+      (send sorting-text insert (make-object vertical-line-snip%))
+      (define sorting-uid-snip (add-sorting-es sorting-text-uid UID-WIDTH))
+      
+      (when (AUTO-FILE-TABLE)
+	(make-object separator-menu-item% msg-menu)
+	(make-object menu-item% "Auto File" msg-menu
+          (lambda (i e)
+            (auto-file))))
+      
+      (define (redisplay-current)
+	(when current-selected
+	  (send header-list on-double-select current-selected)))
+      
+      (define (sort-by-date) 
+        (sort-by-fields (list (list "date" date-cmp)))
+        (reset-sorting-text-styles))
+      (define (sort-by-sender) 
+        (sort-by from<?)
+        (reset-sorting-text-styles)
+        (identify-sorted sorting-text-from))
+      (define (sort-by-subject) 
+        (sort-by subject<?)
+        (reset-sorting-text-styles)
+        (identify-sorted sorting-text-subject))
+      (define (sort-by-order-received) 
+        (sort-by-uid)
+        (reset-sorting-text-styles)
+        (identify-sorted sorting-text-uid))
+      
+      (define no-sort-style-delta (make-object style-delta% 'change-normal))
+      (define sort-style-delta (make-object style-delta% 'change-bold))
+      (send sort-style-delta set-delta-foreground "blue")
+      (define tracking-style-delta (make-object style-delta%))
+      (send tracking-style-delta set-delta-background "Gray")
+      (define not-tracking-style-delta (make-object style-delta%))
+      (send not-tracking-style-delta set-delta-background "White")
+      (define (reset-sorting-text-styles)
+        (send sorting-text-from change-style no-sort-style-delta 0 (send sorting-text-from last-position))
+        (send sorting-text-uid change-style no-sort-style-delta 0 (send sorting-text-uid last-position))
+        (send sorting-text-subject change-style no-sort-style-delta 0 (send sorting-text-subject last-position)))
+      (define (identify-sorted text)
+        (send text change-style sort-style-delta 0 (send text last-position)))
+      (define (reset-sorting-tracking)
+        (send sorting-text-from change-style not-tracking-style-delta 0 (send sorting-text-from last-position))
+        (send sorting-text-uid change-style not-tracking-style-delta 0 (send sorting-text-uid last-position))
+        (send sorting-text-subject change-style not-tracking-style-delta 0 (send sorting-text-subject last-position)))
+      (define (set-sorting-tracking which)
+	(let ([text (case which
+		      [(from) sorting-text-from]
+		      [(subject) sorting-text-subject]
+		      [(uid) sorting-text-uid])])
+	  (send text change-style tracking-style-delta 0 (send text last-position))))
+      
+      (reset-sorting-text-styles)
+      (identify-sorted sorting-text-uid)
+      
+      (define re:date
+	(regexp
+	 "([0-9]*)[ 	]+([A-Za-z]+)[ 	]+([0-9]+)[ 	]+([0-9][0-9]):([0-9][0-9]):([0-9][0-9])"))
+      
+      ;; using the tz seems to require a date->seconds -- too expensive.
+      (define (date-cmp aid bid a b)
+	(define (month->number mon)
+	  (string-lowercase! mon)
+	  (case (string->symbol mon)
+	    [(jan) 1]
+	    [(feb) 2]
+	    [(mar) 3]
+	    [(apr) 4]
+	    [(may) 5]
+	    [(jun) 6]
+	    [(jul) 7]
+	    [(aug) 8]
+	    [(sep) 9]
+	    [(oct) 10]
+	    [(nov) 11]
+	    [(dec) 12]))
+        
+	(define (pairwise-cmp l1 l2)
+	  (cond
+            [(and (null? l1) (null? l2)) 'same]
+            [(or (null? l1) (null? l2)) (error 'pairwise-cmp "internal error; date lists mismatched")]
+            [(= (car l1) (car l2)) (pairwise-cmp (cdr l1) (cdr l2))]
+            [else (< (car l1) (car l2))]))
+        
+	(define (get-date a)
+	  (let* ([m (regexp-match re:date a)])
+	    (if m
+		(let* ([datel (cdr m)]
+		       [day (string->number (first datel))]
+		       [month (month->number (second datel))]
+		       [year (string->number (third datel))]
+		       [hours (string->number (fourth datel))]
+		       [minutes (string->number (fifth datel))]
+		       [seconds (string->number (sixth datel))])
+		  (list year month day
+			hours minutes seconds))
+		(list 0 0 0
+		      0 0 0))))
+        
+	(pairwise-cmp
+	 (get-date a)
+	 (get-date b)))
+            
+      (define re:quote "[\"<>]")
+      ;; from<? : message message -> boolean
+      ;; compares messages by from lines, defaults to uid if froms are equal.
+      (define (from<? a b)
+        (string-cmp/default-uid (get-address a)
+                                (get-address b)
+                                a
+                                b))
+      
+      ;; get-address : message -> string
+      (define (get-address msg)
+        (let ([frm (message-from msg)])
+          (if frm
+	      (hash-table-get
+	       address-memo-table
+	       frm
+	       (lambda ()
+		 (let ([res
+			(with-handlers ([exn:fail? (lambda (x) "")])
+			  (regexp-replace* re:quote 
+					   (car (extract-addresses
+						 frm
+						 'address))
+					   ""))])
+		   (hash-table-put! address-memo-table frm res)
+		   res)))
+              "")))
+      
+      (define address-memo-table (make-hash-table 'equal))
+      
+      (define re:re (regexp "^[rR][eE]: *(.*)"))
+      ;; subject<? : message message -> boolean
+      ;; compares messages by subject lines, defaults to uid if subjects are equal.
+      (define (subject<? a b)
+	(let ([simplify (lambda (msg)
+			  (let ([s (message-subject msg)])
+                            (if s
+                                (let ([m (regexp-match re:re s)])
+                                  (if m
+                                      (cadr m)
+                                      s))
+                                "")))])
+          (string-cmp/default-uid (simplify a) (simplify b) a b)))
+      
+      ;; string-cmp : string string message message -> boolean
+      (define (string-cmp/default-uid str-a str-b a b)
+        (if (string-locale-ci=? str-a str-b)
+            (< (message-uid a) (message-uid b))
+            (string-locale-ci<? str-a str-b)))
+      
+      (define (sort-by compare)
+        (as-background
+         enable-main-frame
+         (lambda (break-bad break-ok)
+           (status "Sorting...")
+           (send header-list sort
+                 (lambda (a b)
+                   (let* ([aid (send a user-data)]
+                          [bid (send b user-data)]
+                          [ma (find-message aid)]
+                          [mb (find-message bid)])
+                     (compare ma mb))))
+           (status ""))
+         close-frame))
+      
+      (define (sort-by-uid)
+        (as-background
+         enable-main-frame
+         (lambda (break-bad break-ok)
+           (status "Sorting...")
+           (send header-list sort
+                 (lambda (a b)
+                   (let ([aid (send a user-data)]
+                         [bid (send b user-data)])
+                     (< aid bid))))
+           (status ""))
+         close-frame))
+      
+      (define (sort-by-fields fields)
+	(let* ([ht (make-hash-table)]
+	       [get-header/cached 
+		(lambda (uid first-field)
+		  (hash-table-get
+		   ht
+		   uid
+		   (lambda ()
+		     (let* ([h (get-header uid)]
+			    [p (cons h
+				     (and first-field
+					  (extract-field 
+					   first-field 
+					   h)))])
+		       (hash-table-put! ht uid p)
+		       p))))])
+	  (as-background
+	   enable-main-frame
+	   (lambda (break-bad break-ok)
+	     (status "Sorting...")
+	     (send header-list sort
+		   (lambda (a b)
+		     (let ([aid (send a user-data)]
+			   [bid (send b user-data)])
+		       (let ([ah+f (get-header/cached aid (and (pair? fields)
+							       (caar fields)))]
+			     [bh+f (get-header/cached bid (and (pair? fields)
+							       (caar fields)))])
+			 (let loop ([fields fields][first? #t])
+			   (if (null? fields)
+			       (< aid bid)
+			       (let ([c ((cadar fields)
+					 aid bid
+					 (if first?
+					     (cdr ah+f)
+					     (parse-encoded
+					      (extract-field (caar fields) (car ah+f))))
+					 (if first?
+					     (cdr bh+f)
+					     (parse-encoded
+					      (extract-field (caar fields) (car bh+f)))))])
+				 (if (eq? c 'same)
+				     (loop (cdr fields) #f)
+				     c))))))))
+	     (status ""))
+	   close-frame)))
+
+      (when (SORT)
+	(case (SORT)
+	  [(date) (sort-by-date)]
+	  [(subject) (sort-by-subject)]
+	  [(from) (sort-by-sender)]
+	  [(id) (void)])) ;; which is (sort-by-order-received)
+
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;  GUI: Finish Setup                                      ;;
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+      (send header-list focus)
+      
+      (for-each add-message mailbox)
+      
+      (send main-frame create-status-line)
+      
+      (send main-frame show #t)
+      (when (eq? (system-type) 'macosx)
+        (start-vsz/rss-thread))
+      (set! got-started? #t)
+      
+      (unless (null? mailbox)
+	(let ([last (car (last-pair (send header-list get-items)))])
+	  (send last select #t)
+	  (queue-callback (lambda () (send last scroll-to)))))
+
+      (frame:reorder-menus main-frame)
+      
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;  Queued Message Sends                                   ;;
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      
+      ;; queue-directory : string
+      ;; the directory where queue'd files are stored (created at this point)
+      (define queue-directory 
+        (let ([dir (build-path (find-system-path 'pref-dir) 
+                               (if (eq? 'unix (system-type)) 
+                                   ".sirmail-queue"
+                                   "SirMail Queue"))])
+          (unless (directory-exists? dir)
+            (make-directory* dir))
+          dir))
+      
+      ;; enqueued-messages? : -> bool
+      ;; returns true if there are messages to send
+      (define (enqueued-messages?)
+	(not (= 0 (length (directory-list queue-directory)))))
+
+      ;; send-queued-messsages : -> void
+      ;; sends the files queued in `queue-directory'
+      (define (send-queued-messages)
+        (for-each send-queued-message (directory-list queue-directory)))
+      
+      ;; send-queued-message : string -> void
+      ;; sends the email message in `filename' by opening a window and sending it a message
+      (define (send-queued-message filename)
+        (start-new-window
+	 (lambda ()
+           (let ([full-filename (build-path queue-directory filename)])
+             (send (new-mailer full-filename "" "" "" "" "" null (length mailbox))
+                   send-message)
+             (delete-file full-filename)))))
+            
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;  Message Parsing                                        ;;
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+      (define get-viewable-headers
+	(lambda (h)
+	  ((if mime-mode? parse-encoded values)
+	   (if show-full-headers?
+	       h
+	       (let loop ([l (reverse (MESSAGE-FIELDS-TO-SHOW))]
+			  [small-h empty-header])
+		 (if (null? l)
+		     small-h
+		     (let ([v (extract-field (car l) h)])
+		       (if v
+			   (loop (cdr l) (insert-field
+					  (car l)
+					  v
+					  small-h))
+			   (loop (cdr l) small-h)))))))))
+
+      (define (parse-and-insert-body header body text-obj insert sep-width img-mode?)
+	(define (insert-separator)
+	  (insert (format "\n~a\n" (make-string sep-width #\-))
+		  (lambda (t s e) 
+		    (send t change-style green-delta (add1 s) (sub1 e)))))
+    
+	(if mime-mode?
+	    (let mime-loop ([msg (with-handlers ([exn:fail? (lambda (x)
+							      (mime:make-message
+							       #f
+							       (mime:make-entity
+								'text
+								'plain 
+								'charset
+								'encoding
+								(mime:make-disposition
+								 'error 
+								 'filename 'creation
+								 'modification 'read
+								 'size 'params)
+								'params 'id
+								'description 'other 'fields
+								null 
+								(lambda (o)
+								  (fprintf o "MIME error: ~a"
+									   (if (exn? x)
+									       (exn-message x)
+									       x))))
+							       #f))])
+				   (mime:mime-analyze (bytes-append (string->bytes/latin-1 
+								     header 
+								     (char->integer #\?))
+								    body)))]
+			    [skip-headers? #t])
+	      (let* ([ent (mime:message-entity msg)]
+                     [slurp-stream (lambda (ent o)
+                                     (with-handlers ([exn:fail? (lambda (x)
+								  (fprintf o 
+									   "~n[decode error: ~a]~n"
+									   (if (exn? x)
+									       (exn-message x)
+									       x)))])
+                                       ((mime:entity-body ent) o)))]
+		     [slurp (lambda (ent)
+                              (let ([o (open-output-bytes)])
+                                (slurp-stream ent o)
+                                (get-output-bytes o)))]
+		     [generic (lambda (ent)
+				(let ([fn (or (let ([disp (mime:entity-disposition ent)])
+						(and (not (equal? "" (mime:disposition-filename disp)))
+						     (mime:disposition-filename disp)))
+					      (let ([l (mime:entity-params ent)])
+						(let ([a (assoc "name" l)])
+						  (and a (cdr a)))))]
+				      [sz (mime:disposition-size (mime:entity-disposition ent))]
+				      [content #f])
+				  (let ([to-file
+					 (lambda (fn)
+					   (as-background
+					    enable-main-frame
+					    (lambda (break-bad break-ok)
+					      (break-ok)
+					      (let ([v (slurp ent)])
+						(break-bad)
+						(unless content
+						  (set! content v)))
+					      (break-ok)
+					      (with-output-to-file fn
+						(lambda ()
+						  (write-bytes content))
+						'truncate/replace))
+					    close-frame))])
+				    (insert-separator)
+				    (insert (format "[~a/~a~a~a]" 
+						    (mime:entity-type ent)
+						    (mime:entity-subtype ent)
+						    (if fn
+							(format " \"~a\"" fn)
+							"")
+						    (if sz
+							(format " ~a bytes" sz)
+							""))
+					    (lambda (t s e)
+					      (send t set-clickback s e
+						    (lambda (a b c)
+						      (let ([fn (put-file "Save Attachement As"
+									  main-frame
+									  #f
+									  fn)])
+							(when fn
+							  (to-file fn))))
+						    #f #f)
+					      (send t change-style url-delta s e)))
+				    (when (eq? (system-type) 'macosx)
+                                      (when fn
+                                        (let ([full-fn (normalize-path (build-path "~/Desktop" fn))])
+					  (insert " " set-standard-style)
+                                          (insert "[save & open]"
+                                                  (lambda (t s e)
+                                                    (send t set-clickback s e
+                                                          (lambda (a b c)
+                                                            (to-file full-fn)
+							    (parameterize ([current-input-port (open-input-string "")])
+							      (system* "/usr/bin/open" (path->string full-fn))))
+                                                          #f #f)
+                                                    (send t change-style url-delta s e)))))))
+                                  (insert "\n" set-standard-style)
+				  (lambda ()
+				    (unless content
+				      (set! content (slurp ent)))
+				    content)))])
+		(case (mime:entity-type ent)
+		  [(text) (let ([disp (mime:disposition-type (mime:entity-disposition ent))])
+                            (cond
+                              [(or (eq? disp 'error)
+				   (and (eq? disp 'inline) (not no-mime-inline?)))
+                               (cond
+                                 [(and html-mode?
+                                       (eq? 'html (mime:entity-subtype ent)))
+                                  ;; If no text-obj supplied, make a temporary one for rendering:
+                                  (let ([target (or text-obj (make-object display-text%))])
+                                    (as-background 
+                                     enable-main-frame
+                                     (lambda (break-bad break-ok) 
+                                       (break-ok)
+                                       (with-handlers ([void no-status-handler])
+                                         (status "Rendering HTML...")
+                                         (let-values ([(in out) (make-pipe)])
+                                           (slurp-stream ent out)
+                                           (close-output-port out)
+					   (render-html-to-text in target img-mode? #f))
+                                         (status "")))
+                                     close-frame)
+                                    (unless text-obj
+                                      ;; Copy text in target to `insert':
+                                      (insert (send target get-text) void)))]
+                                 [else
+				  (let-values ([(bytes->string done)
+						(cond
+						 [(and mime-mode?
+						       (string? (mime:entity-charset ent))
+						       (string-ci=? "UTF-8" (mime:entity-charset ent)))
+						  (values bytes->string/utf-8 void)]
+						 [(and mime-mode?
+						       (string? (mime:entity-charset ent))
+						       (bytes-open-converter (generalize-encoding
+									      (mime:entity-charset ent))
+									     "UTF-8"))
+						  => (lambda (c)
+						       (values
+							(lambda (s alt)
+							  (let loop ([l null][start 0])
+							    (let-values ([(r got status) (bytes-convert c s start)])
+							      (case status
+								[(complete)
+								 (bytes->string/utf-8 (apply bytes-append (reverse (cons r l))) alt)]
+								[(aborts)
+								 (loop (list* #"?" r l) (+ start got))]
+								[(error)
+								 (loop (list* #"?" r l) (+ start got 1))]))))
+							(lambda ()
+							  (bytes-close-converter c))))]
+						 [else (values bytes->string/latin-1 void)])])
+				    (dynamic-wind
+					void
+					(lambda ()
+					  (insert (bytes->string (crlf->lf/preserve-last (slurp ent)) #\?)
+						  (lambda (t s e)
+						    (when (SHOW-URLS) (hilite-urls t s e))
+						    ;;(handle-formatting e) ; too slow
+						    (if (eq? disp 'error)
+							(send t change-style red-delta s e)))))
+					done))])]
+                              [else
+                               (generic ent)]))]
+                  [(image) 
+                   (let ([get (generic ent)])
+		     (let ([tmp-file (make-temporary-file "sirmail-mime-image-~a")])
+		       (call-with-output-file tmp-file
+			 (lambda (port)
+			   (write-bytes (get) port))
+			 'truncate)
+		       (unless no-mime-inline?
+			 (let ([bitmap (make-object bitmap% tmp-file)])
+			   (when (send bitmap ok?)
+			     (insert (make-object image-snip% bitmap) void)
+			     (insert "\n" void))
+			   (delete-file tmp-file)))))]
+		  [(message)
+		   (insert-separator)
+		   (unless (or skip-headers?
+			       (null? (mime:message-fields msg)))
+		     (insert (string-crlf->lf
+			      (get-viewable-headers
+			       (let loop ([l (mime:message-fields msg)])
+				 (if (null? l)
+				     crlf
+				     (string-append (car l)
+						    crlf
+						    (loop (cdr l)))))))
+			     void))
+		   (map (lambda (x) (mime-loop x #f)) (mime:entity-parts ent))]
+		  [(multipart)
+		   (cond
+		    [(and (eq? 'alternative (mime:entity-subtype ent))
+			  (= 2 (length (mime:entity-parts ent)))
+			  (andmap (lambda (m)
+				    (eq? 'text (mime:entity-type (mime:message-entity m))))
+				  (mime:entity-parts ent))
+			  (let ([l (map (lambda (m)
+					  (mime:entity-subtype (mime:message-entity m)))
+					(mime:entity-parts ent))])
+			    (and (member l '((plain html)
+					     (html plain)
+					     (plain enriched)
+					     (enriched plain)))
+				 l)))
+		     => (lambda (l)
+			  (let ([pos (if (eq? (car l) 'plain)
+					 (if prefer-text? 0 1)
+					 (if prefer-text? 1 0))])
+			    (mime-loop (list-ref (mime:entity-parts ent) pos) #f)))]
+		    [else
+		     (map (lambda (x) (mime-loop x #f)) (mime:entity-parts ent))])]
+		  [else (generic ent)])))
+	    ;; Non-mime mode:
+	    (insert (bytes->string/latin-1 (crlf->lf body)) void)))
+
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;  Biff                                                   ;;
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      
+      (define biff%
+	(class timer%
+	  (inherit stop)
+          (define/override (notify)
+            (when can-poll?
+              (unless (send disconnected-msg is-shown?)
+                (with-handlers ([void
+                                 (lambda (x)
+                                   (stop)
+                                   (force-disconnect/status)
+                                   (status "Error connecting: ~s"
+                                           (if (exn? x)
+                                               (exn-message x)
+                                               x)))])
+		  (let ([old-new-messages? new-messages?])
+		    (as-background
+		     enable-main-frame
+		     (lambda (break-bad break-ok) 
+		       (check-for-new break-bad break-ok))
+		     close-frame)
+		    (when (and new-messages?
+			       (not (eq? old-new-messages? new-messages?)))
+		      (bell)))))))
+          (super-instantiate ())))
+      
+      (define biff
+	(if (BIFF-DELAY)
+	    (make-object biff%)
+	    #f))
+      
+      (define (start-biff)
+	(when biff
+	  (send biff start (* 1000 (BIFF-DELAY)))))
+      
+      (start-biff)
+      
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;  Mail Sending                                           ;;
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+      ;; Mail-sending window is implemented in sendr.ss. This is
+      ;;  the set-up for opening such a window.
+      
+      (define my-address 
+	(with-handlers ([void (lambda (x) "<bad address>")])
+	  (car (extract-addresses (MAIL-FROM) 'address))))
+      
+      (define my-username-@
+	(let ([m (regexp-match "^([^@]*)@" my-address)])
+	  (if m
+	      (cadr m)
+	      (string-append my-address "@"))))
+      
+      (define (not-me? name-addr-full)
+	(let ([addr (cadr name-addr-full)])
+	  (cond
+            [(string-ci=? addr my-address) #f]
+            [(and (SELF-ADDRESSES) (member addr (SELF-ADDRESSES))) #f]
+            [(and (> (string-length addr) (string-length  my-username-@))
+                  (string-ci=? my-username-@ (substring addr 0 (string-length  my-username-@))))
+             (eq? (message-box
+                   "Identity?"
+                   (format "Are you ~a?" (caddr name-addr-full))
+                   main-frame
+                   '(yes-no))
+                  'no)]
+            [else #t])))
+      
+      (define (do-reply follow-up? quote-msg?)
+	(define selected (send header-list get-selected))
+	(unless selected
+	  (bell))
+	(when selected
+	  (unless (eq? selected current-selected)
+	    (send header-list on-double-select selected))
+	  (unless (eq? selected current-selected)
+	    (bell))
+	  (when (eq? selected current-selected)
+	    (let* ([uid (send selected user-data)]
+		   [h (get-header uid)]
+		   [rendered-body (let ([e (send message get-editor)]
+					[start (string-length 
+						(string-crlf->lf 
+						 (get-viewable-headers h)))])
+				    (send e get-text start 'eof #t #t))])
+	      (start-new-mailer
+	       #f
+	       (parse-encoded
+		(or (extract-field "Reply-To" h) 
+		    (extract-field "From" h)
+		    ""))
+	       (if follow-up?
+		   (let ([to (parse-encoded (extract-field "To" h))]
+			 [cc (parse-encoded (extract-field "CC" h))])
+		     (if (or to cc)
+			 (let ([to (map
+				    caddr
+				    (filter
+				     not-me?
+				     (append
+				      (if to
+					  (extract-addresses to 'all)
+					  null)
+				      (if cc
+					  (extract-addresses cc 'all)
+					  null))))])
+			   (if (null? to)
+			       ""
+			       (assemble-address-field to)))
+			 ""))
+		   "")
+	       (let ([s (parse-encoded (extract-field "Subject" h))])
+		 (cond
+		  [(not s) ""]
+		  [(regexp-match #rx"^[Rr][Ee][(]([0-9]+)[)]:(.*)$" s)
+		   ;; Other mailer is counting replies. We'll count, too.
+		   => (lambda (m)
+			(format "~a(~a):~a"
+				(substring s 0 2)
+				(add1 (string->number (caddr m)))
+				(cadddr m)))]
+		  [(regexp-match "^[Rr][Ee]:" s) s]
+		  [(regexp-match "^[Aa][Nn][Tt][Ww][Oo][Rr][Tt]:" s) s]
+		  [else (string-append "Re: " s)]))
+	       (let ([id (extract-field "Message-Id" h)]
+		     [refs (extract-field "References" h)])
+		 (format "~a~a"
+			 (if id
+			     (format "In-Reply-To: ~a\r\n" id)
+			     "")
+			 (if (or refs id)
+			     (format "References: ~a\r\n"
+				     (cond
+				      [(and refs id)
+				       (format "~a\r\n\t\t~a" refs id)]
+				      [else (or refs id)]))
+			     "")))
+	       (if quote-in-reply?
+                   (let ([date (parse-encoded (extract-field "Date" h))]
+                         [name
+                          (with-handlers ([exn:fail? (lambda (x) #f)])
+                            (let ([from (parse-encoded (extract-field "From" h))])
+                              (car (extract-addresses from 'name))))])
+                     (string-append
+		      (cond
+		       [(and date name)
+			(format "At ~a, ~a wrote:\r" date name)]
+		       [name
+			(format "Quoting ~a:\r" name)]
+		       [else
+			(format "Quoting <unknown>:\r")])
+                      "> "
+                      (regexp-replace #rx"(?:\n> )*$"
+				      (regexp-replace* #rx"\n" rendered-body "\n> ")
+				      "")))
+		   "")
+	       null)))))
+
+      (define (do-forward)
+	(define selected (send header-list get-selected))
+	(unless selected
+	  (bell))
+	(when selected
+	  (let* ([uid (send selected user-data)]
+		 [h (get-header uid)]
+		 [body (get-body uid void void)])
+	    (start-new-mailer
+	     #f "" ""
+	     (let ([s (extract-field "Subject" h)])
+	       (if (and s (not (regexp-match "^[Ff][Ww][Dd]:" s)))
+		   (string-append "Fwd: " s)
+		   (or s "Fwd")))
+	     "" ""
+	     (list
+	      (make-enclosure
+	       "Forwarded Message"
+	       (insert-field
+		"Content-Type" "message/rfc822"
+		(insert-field 
+		 "Content-Transfer-Encoding" "8bit"
+		 (insert-field
+		  "Content-Disposition" "inline"
+		  empty-header)))
+	       (lambda ()
+		 (split-crlf
+		  (bytes-append (string->bytes/latin-1 h (char->integer #\?))
+				body)))))))))
+      
+      (define (start-new-mailer file to cc subject other-headers body enclosures)
+	(start-new-window
+	 (lambda ()
+	   (new-mailer file to cc subject other-headers body enclosures (length mailbox)))))
+      
+      (define (start-new-mailer/send-message file to cc subject other-headers body enclosures)
+	(start-new-window
+	 (lambda ()
+           (send (new-mailer file to cc subject other-headers body enclosures (length mailbox))
+                 send-message))))
+
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;  Misc Formatting                                        ;;
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      
+      ;; handle-formatting : text -> void
+      (define (handle-formatting e)
+        (let loop ([line (send e last-line)])
+          (unless (zero? line)
+            (for-each
+             (lambda (regexp/action)
+               (handle-single-line/formatting
+                (car regexp/action) 
+                (cadr regexp/action)
+                e
+                line))
+             regexps/actions)
+            (loop (- line 1)))))
+      
+      (define (handle-single-line/formatting regexp action e line)
+        (let ([start (send e line-start-position line)]
+              [end (send e line-end-position line)])
+          (let loop ([string (send e get-text start end #f)]
+                     [line-offset 0])
+            (cond
+              [(regexp-match-positions regexp string)
+               =>
+               (lambda (m)
+                 (let ([before (cadr m)]
+                       [during (caddr m)]
+                       [after (cadddr m)])
+                   (action e
+                           (+ line-offset start (car during))
+                           (+ line-offset start (cdr during)))
+                   (loop (substring string (car before) (cdr before))
+                         (+ (car before) line-offset))
+                   (loop (substring string (car after) (cdr after))
+                         (+ (car after) line-offset))))]
+              [else (void)]))))
+
+      ;; emoticon-path (may not exist)
+      (define emoticon-path
+        (build-path (collection-path "sirmail") "emoticon"))
+
+      ;; emoticon : string string -> (listof (list regexp (text number number -> void)))
+      (define (emoticon img . icons)
+        (let ([snip (make-object image-snip% (build-path emoticon-path img))])
+          (map
+           (lambda (icon)
+             (list (regexp (string-append "(.*)(" (quote-regexp-chars icon) ")(.*)"))
+                   (lambda (e start end)
+                     (send e insert (send snip copy) start end))))
+           icons)))
+      
+      (define (quote-regexp-chars str)
+        (apply
+         string
+         (let loop ([chars (string->list str)])
+           (cond
+             [(null? chars) null]
+             [else (let ([char (car chars)])
+                     (if (memq char regexp-special-chars)
+                         (list* #\\ char (loop (cdr chars)))
+                         (cons char (loop (cdr chars)))))]))))
+      
+      (define regexp-special-chars (string->list "()*+?[].^\\|"))
+      
+      ;; all regexps must have three parenthesized sub-expressions
+      ;; the first is unmatched text before the regexp, the second
+      ;; is the matched tetx and the third is unmatched text after the regexp.
+      (define regexps/actions
+        (list*
+         (list (regexp "(.*)( \\*([^\\*]*)\\* )(.*)")
+               (lambda (e start end) (send e change-style bold-style-delta start end)))
+         (list (regexp "(.*) _([^_]*)_ (.*)")
+               (lambda (e start end) (send e change-style italic-style-delta start end)))
+         (if (directory-exists? emoticon-path)
+             (append
+              (emoticon "bigsmile.gif" ":D" ":-D")
+              (emoticon "cry.gif" ":')" ":'-)")
+              (emoticon "happy.gif" ":)" ":-)" ":>" ":->" "<-:" "<:" "(-:" "(:")
+              (emoticon "kiss.gif" "*:" ":*")
+              (emoticon "sad.gif" ":(" ":-(" ":<" ":-<" ">-:" ">:" "):" ")-:")
+              (emoticon "tongue.gif" ":P" ":-P")
+              (emoticon "wink.gif" ";)" ";-)" ";>" ";->"))
+             null)))
+
+    
+      (define bold-style-delta (make-object style-delta% 'change-bold))
+      (define italic-style-delta (make-object style-delta% 'change-italic))
+
+      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;
+      ;; Mailbox memory graph (from messages in this mailbox)
+      ;;
+
+      (define (show-memory-graph)
+        ;; grab the current value of the mailbox
+        (let ([mailbox mailbox]
+              [mbox-eventspace (current-eventspace)])
+          
+          (status "Collecting memory graph record...")
+          ;; ht : [symbol -o> (listof (cons seconds bytes))]
+          (parameterize ([current-eventspace (make-eventspace)])
+            (queue-callback
+             (lambda ()
+               (let ([ht (make-hash-table)])
+                 (let loop ([mailbox mailbox])
+                   (cond
+                     [(empty? mailbox) (void)]
+                     [else 
+                      (let* ([message (car mailbox)]
+                             [uid (message-uid message)]
+                             [header (get-header uid)]
+                             [key 
+                              (string->symbol
+                               (format "~a" (extract-field "X-Mailer" header)))]
+                             [uptime-str (extract-field "X-Uptime" header)])
+                        (when uptime-str
+                          (let ([uptime (parse-uptime uptime-str)])
+                            (when uptime
+                              (hash-table-put! 
+                               ht
+                               key
+                               (cons
+                                uptime
+                                (hash-table-get ht key (lambda () '()))))))))
+                      (loop (cdr mailbox))]))
+                 
+                 (let ([info 
+                        (quicksort 
+                         (hash-table-map ht (lambda (x y) (list (symbol->string x) y)))
+                         (lambda (x y)
+                           (string<=? (car x) (car y))))])
+                   (parameterize ([current-eventspace mbox-eventspace])
+                     (queue-callback
+                      (lambda ()
+                        (status "Showing graph"))))
+                   (make-memory-graph-window info))))))))
+
+      ;; eventspace: graph eventspace
+      (define (parse-uptime str)
+        (let* ([sep-bytes (regexp-match #rx"([0-9,]*) bytes" str)]
+               [bytes (and sep-bytes
+                           (string->number
+                            (regexp-replace* #rx"," (cadr sep-bytes) "")))]
+               [seconds
+                (cond
+                  [(regexp-match day-hour-regexp str)
+                   =>
+                   (combine (* 24 60 60) (* 60 60))]
+                  [(regexp-match hour-minute-regexp str)
+                   =>
+                   (combine (* 60 60) 60)]
+                  [(regexp-match minute-second-regexp str)
+                   =>
+                   (combine 60 1)]
+                  [else #f])])
+          (if (and bytes seconds)
+              (cons seconds bytes)
+              #f)))
+
+      ;; eventspace: graph eventspace
+      (define (combine m1 m2)
+        (lambda (match)
+          (let ([first (cadr match)]
+                [second (caddr match)])
+            (+ (* (string->number first) m1)
+               (* (string->number second) m2)))))
+      
+      ;; info : (listof (list string (listof (cons number number)))) -> void
+      ;; eventspace: new graph eventspace
+      (define (make-memory-graph-window info)
+        (define frame (new frame:basic% 
+                           (label "Memory Histogram")
+                           (width 500)
+                           (height 600)))
+        (define canvas (new canvas%
+                            (paint-callback
+                             (lambda (c dc)
+                               (draw-graph dc text)))
+                            (parent (send frame get-area-container))))
+        (define text (new text%))
+        (define editor-canvas (new editor-canvas% 
+                                   (parent (send frame get-area-container))
+                                   (editor text)
+                                   (stretchable-height #f)
+                                   (line-count 6)))
+        
+        (define colors '("Green"
+                         "DarkOliveGreen"
+                         "ForestGreen"
+                         "MediumTurquoise"
+                         "SteelBlue"
+                         "Teal"
+                         "CadetBlue"
+                         "Indigo"
+                         "Purple"
+                         "Fuchsia"
+                         "Black"
+                         "DarkRed"
+                         "HotPink"
+                         "OrangeRed"
+                         "SaddleBrown"))
+        
+        (define original-colors colors)
+
+        (define (draw-graph dc text)
+          (let ([max-x 0]
+                [max-y 0]
+                [left-scale 0])
+            (for-each
+             (lambda (key-pairs)
+               (for-each
+                (lambda (pair)
+                  (set! max-x (max (car pair) max-x))
+                  (set! max-y (max (cdr pair) max-y)))
+                (cadr key-pairs)))
+             info)
+
+            (let-values ([(cw ch) (send canvas get-client-size)])
+              (let* ([text-height (let-values ([(w h _1 _2) (send dc get-text-extent "9")])
+                                    h)]
+                     [draw-y-label
+                      (lambda (frac)
+                        (let ([str (format "~a" (quotient (* frac max-y) (* 1024 1024)))]
+                              [y (max (* ch (- 1 frac)) text-height)])
+                          (let-values ([(w h _1 _2) (send dc get-text-extent str)])
+                            (set! left-scale (max left-scale w))
+                            (send dc draw-line 0 (+ y (floor (/ h 2))) cw (+ y (floor (/ h 2))))
+                            (send dc draw-text str 0 y))))])
+                (draw-y-label 1)
+                (draw-y-label 3/4)
+                (draw-y-label 1/2)
+                (draw-y-label 1/4)
+                (draw-y-label 0)
+                (send dc draw-line left-scale 0 left-scale ch)))
+              
+            (set! colors original-colors)
+            (for-each
+             (lambda (key-pairs)
+               (let ([key (car key-pairs)]
+                     [pairs (cadr key-pairs)])
+                 (set! colors (cdr colors))
+                 (send dc set-pen (send the-pen-list find-or-create-pen (car colors) 1 'solid))
+                 (send dc set-brush (send the-brush-list find-or-create-brush (car colors) 'solid))
+                 (for-each
+                  (lambda (pair)
+                    (plot-pair dc (car pair) (cdr pair) left-scale max-x max-y))
+                  pairs)))
+             info)))
+        
+        (define (plot-pair dc x y left-scale max-x max-y)
+          (let-values ([(cw ch) (send canvas get-client-size)])
+            (let* ([w (- cw left-scale)]
+                   [h ch]
+                   [dc-x (+ left-scale (* x (/ w max-x)))]
+                   [dc-y (- ch (* y (/ h max-y)))])
+              (send dc draw-rectangle dc-x dc-y 3 3))))
+        
+        (send text begin-edit-sequence)
+        (for-each (lambda (key-pairs)
+                    (let ([key (car key-pairs)]
+                          [pairs (cadr key-pairs)])
+                      (set! colors (cdr colors))
+                      (let ([before (send text last-position)])
+                        (send text insert (format "~a msgs ~a ~a" 
+                                                  (length pairs)
+                                                  key
+                                                  (car colors)))
+                        (let ([after (send text last-position)])
+                          (send text insert "\n")
+                          (let ([sd (make-object style-delta%)])
+                            (send sd set-delta-foreground (car colors))
+                            (send text change-style sd before after))))))
+                  info)
+        (send text end-edit-sequence)
+        
+        (set-cdr! (last-pair colors) colors)
+        (send frame show #t))
+      
+      (define (make-and-regexp first second)
+        (regexp (format "([0-9]+) ~as? and ([0-9]+) ~as?" first second)))
+      (define day-hour-regexp (make-and-regexp "day" "hour"))
+      (define hour-minute-regexp (make-and-regexp "hour" "minute"))
+      (define minute-second-regexp (make-and-regexp "minute" "second"))
+           
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;  Hiliting URLS                                          ;;
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+      ;; hilite-urls : text -> void
+      ;; highligts all of the urls (strings beginning with `http:', `https:' or `ftp:')
+      ;; in the buffer to be able to click on them.
+      (define (hilite-urls e start end)
+        (define (hilite-urls/prefix prefix)
+          (let loop ([pos start])
+            (when (< pos end)
+              (let ([start-pos (send e find-string prefix 'forward pos 'eof #t #f)])
+                (when start-pos
+                  (let ([eou-pos (let loop ([eou-pos start-pos])
+                                   (cond
+                                     [(= eou-pos (send e last-position)) eou-pos]
+                                     [(char-whitespace? (send e get-character eou-pos))
+				      ;; Back up past ., ,, >, ", and ):
+				      (let loop ([eou-pos eou-pos])
+					(if (memq (send e get-character (sub1 eou-pos))
+						  '(#\" #\. #\, #\> #\)))
+					    (loop (sub1 eou-pos))
+					    eou-pos))]
+                                     [else (loop (+ eou-pos 1))]))])
+                    (send e change-style url-delta start-pos eou-pos)
+                    (send e set-clickback start-pos eou-pos 
+                          (lambda (e start-pos eou-pos)
+                            (send-url (send e get-text start-pos eou-pos))))
+                    (loop eou-pos)))))))
+        (hilite-urls/prefix "http:")
+        (hilite-urls/prefix "https:")
+        (hilite-urls/prefix "ftp:")))))
diff --git a/collects/sirmail/recover.ss b/collects/sirmail/recover.ss
new file mode 100644
index 0000000000..bafedae472
--- /dev/null
+++ b/collects/sirmail/recover.ss
@@ -0,0 +1,27 @@
+
+(require (lib "list.ss")
+	 (lib "head.ss" "net"))
+
+(define msgs (quicksort
+	      (filter (lambda (x) (regexp-match "^[0-9]*$" x)) (directory-list))
+	      (lambda (a b) (< (string->number a) (string->number b)))))
+
+(define mailbox
+  (let loop ([msgs msgs][p 1])
+    (if (null? msgs)
+	null
+	(let ([msg (car msgs)]
+	      [rest (loop (cdr msgs) (add1 p))])
+	  (let ([header (with-input-from-file msg
+		     (lambda () (read-string (file-size msg))))])
+	    (cons (list
+		   (string->number msg)
+		   p
+		   (file-exists? (format "~abody" msg))
+		   (extract-field "From" header)
+		   (extract-field "Subject" header)
+		   null
+		   #f)
+		  rest))))))
+
+(with-output-to-file "mailbox" (lambda () (write mailbox) (newline)) 'truncate)
diff --git a/collects/sirmail/sendr.ss b/collects/sirmail/sendr.ss
new file mode 100644
index 0000000000..7e45435629
--- /dev/null
+++ b/collects/sirmail/sendr.ss
@@ -0,0 +1,950 @@
+
+;; This module implements the mail-composing window. The `new-mailer'
+;;  function creates a compose-window instance.
+
+(module sendr mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "class.ss")
+	   (lib "mred-sig.ss" "mred")
+           (lib "framework.ss" "framework"))
+
+  (require (lib "list.ss")
+	   (lib "file.ss")
+	   (lib "string.ss")
+	   (lib "process.ss"))
+
+  (require "sirmails.ss"
+	   "pref.ss"
+           "spell.ss")
+
+  (require (lib "imap-sig.ss" "net")
+	   (lib "smtp-sig.ss" "net")
+	   (lib "head-sig.ss" "net")
+	   (lib "base64-sig.ss" "net")
+	   (lib "qp-sig.ss" "net"))
+
+  (require (lib "hierlist-sig.ss" "hierlist"))
+
+  (provide send@)
+  (define send@
+    (unit/sig sirmail:send^
+      (import (exit-sirmail)
+	      sirmail:utils^
+	      sirmail:options^
+	      sirmail:read^
+	      mred^
+	      net:imap^
+	      net:smtp^
+	      net:head^
+	      net:base64^
+	      net:qp^
+	      hierlist^)
+
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;  Constants                                             ;;
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+      (define (show-error x main-frame)
+	(message-box "Error" 
+		     (if (exn? x)
+			 (exn-message x)
+			 (format "Strange exception: ~s" x))
+		     main-frame
+		     '(ok stop)))
+        
+      (define FRAME-WIDTH 560)
+      (define FRAME-HEIGHT 600)
+      (let-values ([(display-width display-height) (get-display-size)])
+	(set! FRAME-HEIGHT (min display-height FRAME-HEIGHT))
+	(set! FRAME-WIDTH (min display-width FRAME-WIDTH)))
+
+      (define FORWARD-LIST-HEIGHT 50)
+
+      (define return-bitmap
+	(with-handlers ([void (lambda () #f)])
+	  (let ([bm (make-object bitmap% 
+				 (build-path 
+				  (collection-path "icons")
+				  "return.xbm"))])
+	    (and (send bm ok?) bm))))
+
+      (define send-icon (make-object bitmap% (build-path (collection-path "sirmail")
+							 "stamp.bmp")))
+      (define send-icon-mask (make-object bitmap% (build-path (collection-path "sirmail")
+							      "stamp-mask.xbm")))
+      (unless (and (send send-icon ok?)
+		   (send send-icon-mask ok?))
+	(set! send-icon #f))
+
+      (define SEPARATOR (make-string 75 #\=))
+
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;  Address Parsing                                       ;;
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+      ;; Returns a list of <full>-<address> pairs
+      (define (resolve-alias addr)
+	(cond
+	 [(assoc addr (ALIASES))
+	  => (lambda (m)
+	       (let ([resolve
+		      (lambda (n)
+			(let ([l (sm-extract-addresses n)])
+			  (unless (> (length l) 0)
+			    (error 'resolve-alias "alias is not an address: ~a" n))
+			  l))])
+		 (if (list? (cadr m))
+		     (apply append (map resolve (cadr m)))
+		     (resolve (cadr m)))))]
+	 [(DEFAULT-DOMAIN) (let ([addr (format "~a@~a" addr (DEFAULT-DOMAIN))])
+			     (list (cons addr addr)))]
+	 [else (list (cons addr addr))]))
+
+      ;; Returns a list of <full>-<address> pairs
+      (define (sm-extract-addresses s)
+	(let ([addrs (extract-addresses s 'all)])
+	  (apply
+	   append
+	   (map
+	    (lambda (a)
+	      (let ([name (car a)]
+		    [address (cadr a)]
+		    [full (caddr a)])
+		(if (and (string=? address full)
+			 (not (regexp-match "@" full)))
+		    (resolve-alias full)
+		    (list (cons full address)))))
+	    addrs))))
+      
+      (define (remove-fields l h)
+	(if (null? l)
+	    h
+	    (remove-fields (cdr l) (remove-field (car l) h))))
+
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;  Enclosures                                            ;;
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      
+      (define-struct enclosure (name            ; identifies enclosure in the GUI
+				subheader       ; header for enclosure
+				data-thunk))    ; gets enclosure data as bytes (already encoded)
+
+      ;; Create a message with enclosures.
+      ;;  `header' is a message header created with the head.ss library
+      ;;  `body-lines' is a list of strings and byte strings
+      ;;  `enclosures' is a list of `enclosure' structs
+      (define (enclose header body-lines enclosures)
+	(if (null? enclosures)
+	    (values (insert-field
+		     "Content-Type"
+		     "text/plain; charset=UTF-8"
+		     header)
+		    body-lines)
+	    (let* ([enclosure-datas
+                    (map (lambda (e) ((enclosure-data-thunk e))) enclosures)]
+                   [boundary
+                    ;; Generate something that isn't there:
+                    (let loop ()
+                      (let* ([b (format "---~a~a~a-----" (random 10000) (random 10000) (random 10000))]
+                             [m (regexp b)])
+                        (if (or (ormap (lambda (bl)
+					 (regexp-match-positions m bl))
+				       body-lines)
+                                (ormap
+                                 (lambda (enc data)
+                                   (or (regexp-match-positions m (enclosure-subheader enc))
+                                       (ormap (lambda (bl)
+						(regexp-match-positions m bl))
+					      data)))
+                                 enclosures enclosure-datas))
+                            (loop)
+                            b)))])
+	      (let ([mime-header (insert-field
+				  "MIME-Version"
+				  "1.0"
+				  (insert-field
+				   "Content-Type"
+				   (data-lines->data
+				    (list
+				     "multipart/mixed;"
+				     (format "boundary=~s"
+					     boundary)))
+				   empty-header))])
+		(values (append-headers header mime-header)
+			(append
+			 (list
+			  "This is a multi-part message in MIME format."
+			  (format "--~a" boundary))
+			 (header->lines
+			  (insert-field
+			   "Content-Type"
+			   "text/plain; charset=UTF-8"
+			   (insert-field
+			    "Content-Transfer-Encoding"
+			    "7bit"
+			    empty-header)))
+			  body-lines
+			  (apply
+			   append
+			   (map
+			    (lambda (enc data)
+			      (cons
+			       (format "--~a" boundary)
+			       (append
+				(header->lines
+				 (enclosure-subheader enc))
+				data)))
+			    enclosures enclosure-datas))
+			  (list
+			   (format "--~a--" boundary))))))))
+
+      (define (get-enclosure-type-and-encoding filename mailer-frame auto?)
+        (let ([types '("application/postscript"
+                       "text/plain"
+                       "text/html"
+                       "image/jpeg"
+                       "image/gif"
+                       "image/png"
+                       "application/octet-stream")]
+              [encodings '("7bit"
+                           "quoted-printable"
+                           "base64")]
+              [d (instantiate dialog% ("Enclosure" mailer-frame)
+                   [alignment '(left center)])])
+          (make-object message% (string-append 
+                                 "File: "
+				 (let ([filename (path->string filename)])
+				   (let ([l (string-length filename)])
+				     (if (l . < . 58)
+					 filename
+					 (string-append
+					  (substring filename 0 5)
+					  "..."
+					  (substring filename (- l 50) l))))))
+		       d)
+          (let ([type-list (make-object choice% "Type:" types d void)]
+                [encoding-list (make-object choice% "Encoding:" encodings d void)]
+		[inline-check (make-object check-box% "Inline in recipient's view" d void)]
+                [button-panel (instantiate horizontal-pane% (d)
+                                [alignment '(right center)]
+                                [stretchable-height #f])]
+                [ok? auto?])
+            (let-values ([(ok cancel) (gui-utils:ok/cancel-buttons
+                                       button-panel
+                                       (lambda (b e) 
+                                         (set! ok? #t)
+                                         (send d show #f))
+                                       (lambda (b e)
+                                         (send d show #f)))])
+              (let ([default (lambda (t e inline?)
+                               (letrec ([findpos (lambda (l s)
+                                                   (if (string=? (car l) s)
+                                                       0
+                                                       (add1 (findpos (cdr l) s))))])
+				 (send type-list set-selection (findpos types t))
+				 (send encoding-list set-selection (findpos encodings e))
+                                 (send inline-check set-value inline?)))]
+                    [suffix (let ([m (regexp-match #rx"[.](.*)$" (path->string filename))])
+                              (and m (cadr m)))])
+                (case (if suffix (string->symbol (string-locale-downcase suffix)) '???)
+                  [(txt ss scm) (default "text/plain" "quoted-printable" #f)]
+                  [(htm html) (default "text/html" "quoted-printable" #f)]
+                  [(ps) (default "application/postscript" "base64" #f)]
+                  [(jpeg jpg) (default "image/jpeg" "base64" #t)]
+                  [(png) (default "image/png" "base64" #t)]
+                  [(gif) (default "image/gif" "base64" #t)]
+                  [else (default "application/octet-stream" "base64" #f)]))
+	      (unless auto?
+		(send d show #t))
+              (if ok?
+                  (values (list-ref types (send type-list get-selection))
+                          (list-ref encodings (send encoding-list get-selection))
+			  (send inline-check get-value))
+                  (values #f #f #f))))))
+			
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;  Composer Instance                                     ;;
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      
+      ;; new-mailer : ... -> frame[with send-message method]
+      (define (new-mailer file to cc subject other-headers body enclosures message-count)
+        (define f% (class frame:basic%
+                     (inherit get-menu-bar set-icon get-eventspace accept-drop-files)
+                     [define/public (send-message)
+                       (send-msg)]
+                     (define/augment (can-close?)
+                       (and (send (get-menu-bar) is-enabled?)
+                            (or (not (send message-editor is-modified?))
+                                (eq? 'yes
+                                     (confirm-box
+                                      "Warning"
+                                      "The message is not saved or sent. Close anyway?"
+                                      this)))
+                            (inner #t can-close?)))
+                     (define/augment (on-close)
+                       (send message-editor on-close)
+                       (inner (void) on-close)
+                       (exit-sirmail "mailer close"))
+		     (define/override (on-drop-file f)
+		       (add-enclosure-file f #t))
+                     (super-instantiate ())
+		     (accept-drop-files #t)
+                     (when send-icon
+                       (set-icon send-icon send-icon-mask))))
+        (define mailer-frame (make-object f% "Send Mail" #f FRAME-WIDTH FRAME-HEIGHT))
+        
+        (define mb (send mailer-frame get-menu-bar))
+        (define file-menu (make-object menu% "File" mb))
+        (define edit-menu (make-object menu% "Edit" mb))
+        (define composer-menu (and (USE-EXTERNAL-COMPOSER?)
+                                   (make-object menu% "Composer" mb)))
+        (define button-pane (make-object horizontal-pane% (send mailer-frame get-area-container)))
+        (define title-message (make-object message% "Compose message" button-pane)) 
+        (define button-pane-spacer (make-object vertical-pane%  button-pane))
+        (define cancel-button
+          (make-object button% "Stop" button-pane
+            (lambda (b e) (cancel-button-todo))))
+        (define cancel-button-todo void)
+        
+        (define external-composer-button
+          (and (USE-EXTERNAL-COMPOSER?)
+               (make-object
+                   button%
+                 "External Composer"
+                 button-pane
+                 (lambda (button control-event)
+                   (let ([t (make-temporary-file "sirmail~a")])
+                     
+                     (send message-editor save-file t 'text #t)
+                     
+                     ; To get rid of the Standard Output window: Set
+                     ; the current output & error ports to something
+                     ; else. Or use `process' instead.  Warning: be sure
+                     ; to test in error circumstances (eg, when the
+                     ; external program can't be found).
+                     
+                     (system
+                      (case external-composer
+                        [(xemacs)
+                         (string-append "gnuclient +5 " t)]
+                        [(gnu-emacs)
+                         (string-append "emacsclient +5 " t)]))
+                     
+                     (send message-editor load-file t 'guess #t)
+                     
+                     (with-handlers
+                         ([exn:fail:filesystem?
+                           (lambda (exn)
+                             (message-box "Error Deleting Temporary File"
+                                          (string-append
+                                           "Attempted to delete the "
+                                           "temporary file "
+                                           "`" t "'"
+                                           "but couldn't find it.")
+                                          #f
+                                          '(ok)))])
+                       (delete-file t)))))))
+        
+        (define c (new editor-canvas% 
+                       [parent (send mailer-frame get-area-container)]
+                       [style '(auto-hscroll)]))
+        (define message-editor-super%
+          (color:text-mixin 
+           (editor:backup-autosave-mixin
+            text:standard-style-list%)))
+        (define message-editor (make-object (class message-editor-super%
+                                              (inherit reset-region)
+                                              
+                                              (define immutable-start 0)
+                                              (define immutable-end 0)
+                                              
+                                              (define/override (set-modified mod?)
+                                                (send mailer-frame modified mod?)
+                                                (super set-modified mod?))
+                                              (define/public (set-no-change-region start end)
+                                                (set! immutable-start start)
+                                                (set! immutable-end end)
+                                                (reset-region end 'end))
+                                              
+                                              (define/augment (can-insert? start len)
+                                                (and (or (<= start immutable-start)
+                                                         (>= start immutable-end))
+                                                     (inner #t can-insert? start len)))
+                                              (define/augment (after-insert start len)
+                                                (when (<= start immutable-start)
+						  (set! immutable-start (+ immutable-start len))
+						  (set! immutable-end (+ immutable-end len))
+						  (reset-region immutable-end 'end))
+                                                (inner (void) after-insert start len))
+                                              
+                                              (define/augment (can-delete? start len)
+                                                (and (or (<= (+ start len) immutable-start)
+                                                         (>= start immutable-end))
+                                                     (inner #t can-delete? start len)))
+                                              (define/augment (after-delete start len)
+                                                (when (<= start immutable-start)
+						  (set! immutable-start (- immutable-start len))
+						  (set! immutable-end (- immutable-end len))
+						  (reset-region immutable-end 'end))
+                                                (inner (void) after-delete start len))
+                                              
+                                              (super-new))))
+        (define enclosure-list (make-object hierarchical-list% (send mailer-frame get-area-container)))
+        
+        (define plain-cursor (make-object cursor% 'arrow))
+        (define arrow+watch-cursor (make-object cursor% 'arrow+watch))
+        
+        (define (enable on? refocus cancel-proc)
+          (let ([w (send mailer-frame get-focus-window)])
+            (set! cancel-button-todo cancel-proc)
+            (send mb enable on?)
+            (send c enable on?)
+            (send cancel-button enable (not on?))
+            (let* ([cursor (if on? plain-cursor arrow+watch-cursor)])
+              (send mailer-frame set-cursor cursor)
+              (send (send c get-editor) set-cursor (if on? #f cursor) #t))
+            (when (and on? refocus)
+              (send refocus focus))
+            w))
+        
+        (define (send-msg)
+          (define-values (smtp-server-to-use smtp-port-to-use)
+            (parse-server-name (SMTP-SERVER) 25))
+          (send-message
+           (send message-editor get-text)
+           smtp-server-to-use
+           smtp-port-to-use
+           (map (lambda (i) (send i user-data)) 
+                (send enclosure-list get-items))
+           enable
+           (lambda () (send mailer-frame set-status-text "Sending mail..."))
+           (lambda () (send mailer-frame set-status-text "Building enclosures..."))
+           (lambda () (send mailer-frame set-status-text ""))
+           (lambda ()
+             (send mailer-frame on-close)
+             (send mailer-frame show #f))
+           (lambda ()
+             (let loop ()
+               (when (eq? (message-box "Save?" "Save message before killing?" #f '(yes-no caution))
+                          'yes)
+                 (let ([f (put-file)])
+                   (if f
+                       (send message-editor save-file f 'text)
+                       (loop))))))
+           message-count))
+        
+        ;; enq-msg : -> void
+        ;; enqueues a message for a later send
+        (define (enq-msg)
+          (let ([filename (get-fresh-queue-filename)])
+            (send message-editor save-file filename 'text))
+          
+          (when (send mailer-frame can-close?)
+            (send mailer-frame on-close)
+            (send mailer-frame show #f)))
+        
+        ;; get-fresh-queue-filename : -> string
+        (define (get-fresh-queue-filename)
+          (build-path queue-directory 
+                      (format "enq~a" (+ 1 (length (directory-list queue-directory))))))
+
+	(define (add-enclosure-file file auto?)
+	  (let-values ([(type encoding inline?) (get-enclosure-type-and-encoding file mailer-frame auto?)])
+	    (when (and type encoding)
+	      (let ([i (send enclosure-list new-item)]
+		    [enc (make-enclosure
+			  (path->string file)
+			  (let ([fn (clean-filename
+				     (with-handlers ([void (lambda (x) "unknown")])
+				       (let-values ([(base name dir?) (split-path file)])
+					 (path->string name))))])
+			    (insert-field
+			     "Content-Type" 
+			     (data-lines->data
+			      (list
+			       (string-append type ";")
+			       (format "name=~s" fn)))
+			     (insert-field
+			      "Content-Transfer-Encoding" encoding
+			      (insert-field
+			       "Content-Disposition"
+			       (data-lines->data
+				(list
+				 (format "~a; " (if inline? 'inline 'attachment))
+				 (format "filename=~s" fn)))
+			       empty-header))))
+			  (lambda ()
+			    (let ([content (with-input-from-file file
+					     (lambda ()
+					       (read-bytes (file-size file))))])
+			      (case (string->symbol encoding)
+				[(base64) (split-crlf (base64-encode content))]
+				[(quoted-printable) (split-crlf (qp-encode (lf->crlf content)))]
+				[(7bit) (split-lf (crlf->lf content))]))))])
+		(send (send i get-editor) insert (enclosure-name enc))
+		(send i user-data enc)
+		(let ([p (send mailer-frame get-area-container)])
+		  (unless (memq enclosure-list (send p get-children))
+		    (send p add-child enclosure-list)))))))
+        
+        (define external-composer (get-pref 'sirmail:external-composer))
+        
+        (frame:reorder-menus mailer-frame)
+        (send button-pane stretchable-height #f)
+        (send cancel-button enable #f)
+        
+        (send enclosure-list stretchable-height #f)
+        (send enclosure-list min-height FORWARD-LIST-HEIGHT)
+        (when (null? enclosures)
+          (send (send mailer-frame get-area-container) delete-child enclosure-list))
+        (for-each
+         (lambda (enc)
+           (let ([i (send enclosure-list new-item)])
+             (send (send i get-editor) insert (enclosure-name enc))
+             (send i user-data enc)))
+         enclosures)
+        
+        (when (USE-EXTERNAL-COMPOSER?)
+          (letrec ([switch (lambda (item e)
+                             (if (send item is-checked?)
+                                 (begin
+                                   ;; Disable others:
+                                   (send xemacs check (eq? xemacs item))
+                                   (send gnu-emacs check (eq? gnu-emacs item))
+                                   ;; Update flags
+                                   (set! external-composer
+                                         (cond
+                                           [(send xemacs is-checked?)
+                                            'xemacs]
+                                           [(send gnu-emacs is-checked?)
+                                            'gnu-emacs]))
+                                   (put-pref 'sirmail:external-composer external-composer))
+                                 ;; Turn it back on
+                                 (send item check #t)))]
+                   [xemacs (make-object checkable-menu-item% "XEmacs" composer-menu switch)]
+                   [gnu-emacs (make-object checkable-menu-item% "GNU Emacs" composer-menu switch)])
+            (send
+             (case external-composer
+               [(xemacs) xemacs]
+               [(gnu-emacs) gnu-emacs])
+             check #t)))
+        
+        (make-object menu-item% "Save" file-menu 
+          (lambda (i ev) (send message-editor save-file #f 'text)))
+        (make-object menu-item% "Send" file-menu (lambda (i ev) (send-msg)))
+        (make-object menu-item% "Enqueue message" file-menu (lambda (i ev) (enq-msg)))
+        (make-object separator-menu-item% file-menu)
+        (make-object menu-item% "Add Enclosure..." file-menu
+          (lambda (i env)
+            (let ([file (get-file "Get Enclosure" mailer-frame)])
+              (when file
+		(add-enclosure-file file #f)))))
+
+        (make-object separator-menu-item% file-menu)
+        (make-object (class menu% 
+                       (inherit get-items)
+                       (define/override (on-demand)
+                         (for-each (lambda (i) (send i delete)) (get-items))
+                         (let ([server (SMTP-SERVER)]
+                               [servers (SMTP-SERVERS)])
+                           (for-each
+                            (lambda (s)
+                              (let ([i (make-object checkable-menu-item% s this
+                                         (lambda (i e)
+                                           (for-each (lambda (i) (send i check #f)) (get-items))
+                                           (set-SMTP-SERVER! s)
+                                           (send i check #t)))])
+                                (when (string=? s server)
+                                  (send i check #t))))
+                            servers)))
+                       (super-make-object "SMTP Server" file-menu)))
+        (make-object separator-menu-item% file-menu)
+        (make-object menu-item% "Close" file-menu
+          (lambda (i e) 
+            (when (send mailer-frame can-close?)
+              (send mailer-frame on-close)
+              (send mailer-frame show #f)))
+          (if (eq? (system-type) 'windows) #f #\W))
+        (append-editor-operation-menu-items edit-menu #t)
+        ;; Strip menu key bindings
+        (for-each
+         (lambda (i)
+           (when (is-a? i selectable-menu-item<%>)
+             (send i set-shortcut #f)))
+         (send edit-menu get-items))
+        
+        (make-object separator-menu-item% edit-menu)
+        (send (instantiate menu-item% ("Delete Enclosure" edit-menu)
+                [callback (lambda (i e)
+                            (let ([i (send enclosure-list get-selected)])
+                              (send enclosure-list delete-item i)))]
+                [demand-callback (lambda (m)
+                                   (send m enable (send enclosure-list get-selected)))])
+              enable #f)
+        
+        
+        (add-preferences-menu-items edit-menu)
+        
+        (let ([km (send message-editor get-keymap)])
+          (send km add-function "reflow-paragraph"
+                (lambda (e ev) (reflow-paragraph 
+                                e
+                                (add1 (send e find-string SEPARATOR
+                                            'forward 0 'eof #f)))))
+          (send km map-function ":m:q" "reflow-paragraph")
+          (send km map-function ":a:q" "reflow-paragraph")
+          (special-option-key #t)
+          
+          (add-text-keymap-functions km)
+          (keymap:setup-global km)
+          
+          (send km add-function "send-message"
+                (lambda (w e) (send-msg)))
+          (send km map-function ":m:return" "send-message")
+          (send km map-function ":a:return" "send-message"))
+        
+        (make-fixed-width c message-editor #t return-bitmap)
+        (send message-editor set-paste-text-only #t)
+        (send message-editor set-max-undo-history 5000) ;; Many undos!
+        (send c set-editor message-editor)
+        
+        (activate-spelling message-editor)
+        
+        (send message-editor begin-edit-sequence)
+        (if file
+            ;; Resume a composition...
+            (send message-editor load-file file)
+            ;; Build message skeleton
+            (begin
+              (send message-editor insert "To: ")
+              (send message-editor insert (string-crlf->lf to))
+              (send message-editor insert #\newline)
+              (unless (string=? cc "")
+                (send message-editor insert "CC: ")
+                (send message-editor insert (string-crlf->lf cc))
+                (send message-editor insert #\newline))
+              (send message-editor insert "Subject: ")
+              (send message-editor insert (string-crlf->lf subject))
+              (send message-editor insert #\newline)
+              (send message-editor insert (string-crlf->lf other-headers))
+              (send message-editor insert "X-Mailer: SirMail under MrEd ")
+              (send message-editor insert (version))
+              (send message-editor insert " (")
+              (send message-editor insert (path->string (system-library-subpath)))
+              (send message-editor insert ")")
+              (let ([start-no-change (send message-editor last-position)])
+                (send message-editor insert #\newline)
+                (send message-editor insert SEPARATOR)
+                (send message-editor insert #\newline)
+                (send message-editor set-no-change-region 
+                      start-no-change
+                      (send message-editor last-position)))
+              (let ([message-start (send message-editor last-position)])
+                (send message-editor insert body)
+                (if (string=? to "")
+                    (send message-editor set-position (send message-editor paragraph-end-position 0))
+                    (send message-editor set-position message-start)))
+              (send message-editor clear-undos)))
+        
+        (send message-editor set-modified #f)
+        (send message-editor scroll-to-position 0)
+        (send message-editor end-edit-sequence)
+        
+        (send c focus)
+        
+        (send mailer-frame create-status-line)
+        
+        (send mailer-frame show #t)
+        
+        (initial-exception-handler
+         (lambda (x)
+           (show-error x mailer-frame)
+           ((error-escape-handler))))
+        (current-exception-handler
+         (initial-exception-handler))
+        
+        mailer-frame)
+
+      
+      ;; clean-filename : string -> string
+      ;; builds a filename from a name by sripping out bad chars.
+      (define (clean-filename name)
+        (regexp-replace* "[ /:\\\"'`?*%<>$|\u0100-\U10FFFF]" name "_"))
+      
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;  Message Send                                          ;;
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+      (define (send-message message-str
+                            smtp-server
+                            smtp-port
+                            enclosures
+                            enable 
+                            status-message-starting
+                            status-message-enclosures
+                            status-message-clear
+                            status-done
+                            save-before-killing
+                            message-count)
+        (let ([re (regexp (format "~a\n" SEPARATOR))])
+          (let ([m (regexp-match-positions re message-str)])
+            (if m
+                (let ([header (re-encode-fields
+			       '("To" "CC" "BCC" "Subject")
+			       (string-append
+				(string-lf->crlf (substring message-str 0 (caar m)))
+				(build-uptime-field message-count) 
+                                "\r\n"
+				empty-header))]
+                      [body-lines (regexp-split 
+				   #rx"\n" 
+				   (substring message-str (cdar m) (string-length message-str)))])
+		  (validate-header header)
+                  (let* ([to* (sm-extract-addresses (extract-field "To" header))]
+                         [to (map car to*)]
+                         [cc* (sm-extract-addresses (extract-field "CC" header))]
+                         [cc (map car cc*)]
+                         [bcc* (sm-extract-addresses (extract-field "BCC" header))]
+                         [bcc (map car bcc*)]
+                         [from (let ([l (extract-addresses (MAIL-FROM) 'full)])
+                                 (unless (= 1 (length l))
+                                   (error 'send "bad mail-from configuration: ~a" (MAIL-FROM)))
+                                 (car l))]
+                         [simple-from (let ([l (extract-addresses (MAIL-FROM) 'address)])
+                                        (unless (= 1 (length l))
+                                          (error 'send "bad mail-from configuration: ~a" (MAIL-FROM)))
+                                        (car l))]
+                         [subject (extract-field "Subject" header)]
+                         [prop-header (remove-fields '("To" "CC" "BCC" "Subject") header)]
+                         [std-header (standard-message-header from to cc bcc subject)]
+                         [new-header (append-headers std-header prop-header)]
+                         [tos (map cdr (append to* cc* bcc*))])
+                    
+                    (as-background
+                     enable
+                     (lambda (break-bad break-ok)
+                       (if (null? enclosures)
+                           (status-message-starting)
+                           (status-message-enclosures))
+                       (with-handlers ([void (lambda (x)
+                                               (status-message-clear)
+                                               (raise x))])
+                         (break-ok)
+                         (let-values ([(new-header body-lines) (enclose new-header body-lines enclosures)])
+                           (break-bad)
+                           (unless (null? enclosures)
+                             (status-message-starting))
+                           (when (SAVE-SENT)
+                             (let* ([chop (lambda (s)
+                                            (let ([l (string-length s)])
+                                              (clean-filename (substring s 0 (min l 10)))))]
+                                    [to (if (null? tos) "noone" (chop (car tos)))]
+                                    [subj (if subject (chop subject) "nosubj")])
+                               (let loop ([n 1])
+                                 (let ([fn (build-path (SAVE-SENT) (format "~a_~a_~a" to subj n))])
+                                   (if (file-exists? fn)
+                                       (loop (add1 n))
+                                       (with-output-to-file fn
+                                         (lambda ()
+                                           (display (string-crlf->lf header))
+					   (map (lambda (body-line)
+						  (display body-line)
+						  (newline))
+						body-lines))))))))
+                           (break-ok)
+                           (smtp-sending-end-of-message break-bad)
+                           (smtp-send-message smtp-server
+                                              simple-from
+                                              tos
+                                              new-header
+                                              body-lines
+                                              smtp-port))))
+                       save-before-killing))
+                  (status-done))
+                (message-box
+                 "Error"
+                 (format "Lost \"~a\" separator" SEPARATOR))))))
+
+      (define (re-encode-fields l header)
+	(cond
+	 [(null? l) header]
+	 [(extract-field (car l) header)
+	  => (lambda (v)
+	       (re-encode-fields 
+		(cdr l)
+		(replace-field
+		 (car l)
+		 (encode-for-header v)
+		 header)))]
+	 [else (re-encode-fields (cdr l) header)]))
+      
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;  Meta-Q Reflowing                                      ;;
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+      (define reflow-wordbreak-map
+	(make-object editor-wordbreak-map%))
+      (send reflow-wordbreak-map set-map #\- '(line))
+      (define (reflow-paragraph edit start-min)
+	(let ([wbm (send edit get-wordbreak-map)])
+	  (dynamic-wind
+	      (lambda ()
+		(send edit set-wordbreak-map reflow-wordbreak-map)
+		(send edit begin-edit-sequence))
+	      (lambda ()
+		(let ([p (max start-min (send edit get-start-position))]
+		      [min-line (send edit position-paragraph start-min)])
+		  (let loop ([start-l (send edit position-paragraph p)])
+		    (if (or (<= start-l min-line)
+			    (= (send edit paragraph-start-position start-l)
+			       (add1 (send edit paragraph-start-position (sub1 start-l)))))
+			(let loop ([end-l start-l])
+			  (if (or (= end-l (send edit last-paragraph))
+				  (= (send edit paragraph-end-position end-l)
+				     (sub1 (send edit paragraph-end-position (add1 end-l)))))
+			      (let ([orig-start (send edit paragraph-start-position start-l)]
+				    [end (send edit paragraph-end-position end-l)]
+				    [second-line-prefix
+				     (if (= start-l end-l)
+					 ""
+					 (let ([p (send edit paragraph-start-position (add1 start-l))])
+					   (let loop ([pe p])
+					     (case (send edit get-character pe)
+					       [(#\space #\tab #\>) (loop (add1 pe))]
+					       [else (send edit get-text p pe)]))))])
+				(let ([start ; skip spaces on first line (if there's a non-space):
+				       (let ([start-end (send edit paragraph-end-position start-l)])
+					 (let loop ([start orig-start])
+					   (cond
+					    [(= start-end start) orig-start]
+					    [(memq (send edit get-character start) '(#\space #\tab))
+					     (loop (add1 start))]
+					    [else start])))])
+					; Remove all line breaks and double-spaces
+					; spaces
+				  (let loop ([start start]
+					     [end end]
+					     [l (list (string-append (string #\newline)
+								     second-line-prefix)
+						      (string #\newline)
+						      (string #\tab)
+						      (string #\space #\space))])
+				    (let ([p (send edit find-string (car l)
+						   'forward start end)]
+					  [line-break (string-append (string #\newline)
+								     second-line-prefix)]
+					  [slp-len (string-length second-line-prefix)])
+				      (if (or p (pair? (cdr l)))
+					  (if p
+					      (let ([len (string-length (car l))])
+						(send edit insert " " p (+ p len))
+						(loop start (- end len -1) l))
+					      (loop start end (cdr l)))
+					; Insert good line breaks
+					  (let loop ([start start]
+						     [len (- start orig-start)]
+					; First, remove ending space
+						     [end (if (or (= end start)
+								  (not (char=?
+									#\space
+									(send edit get-character 
+									      (sub1 end)))))
+							      end
+							      (begin
+								(send edit delete (sub1 end) end)
+								(sub1 end)))])
+					    (unless (>= start end)
+					      (let ([ebox (box start)])
+						(send edit find-wordbreak #f ebox 'line)
+						(let* ([p (unbox ebox)]
+						       [wlen (- p start)])
+						  (cond
+						   [(or (zero? len) (< (+ len wlen) 72))
+						    (loop p (+ len wlen) end)]
+						   [(char=? #\space (send edit get-character start))
+						    (send edit insert line-break start (add1 start))
+						    (loop (+ p slp-len) (+ wlen -1 slp-len) 
+							  (+ slp-len end))]
+						   [else
+						    (send edit insert line-break start)
+						    (loop (+ p 1 slp-len) (+ wlen slp-len)
+							  (+ end 1 slp-len))]))))))))))
+			      (loop (add1 end-l))))
+			(loop (sub1 start-l))))))
+	      (lambda () 
+		(send edit end-edit-sequence)
+		(send edit set-wordbreak-map wbm)))
+	  #t))))
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;  Uptime                                                ;;
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (define (build-uptime-field msg-count)
+    (string-append "X-Uptime: "
+		   (how-long-ago (- (current-seconds) invoked-time))
+		   ", using "
+		   (how-much-memory)
+		   " bytes"
+                   (if (number? msg-count) (format " (s: ~A)" msg-count) "")))
+
+  (define invoked-time (current-seconds))
+  
+  (define (how-long-ago diff)
+    (let-values ([(seconds minutes hours days) (apply values (how-long-ago-list diff))])
+		(cond
+		 [days
+		  (string-append
+		   (build-ele days "day")
+		   " and "
+		   (build-ele hours "hour"))]
+		 [hours
+		  (string-append
+		   (build-ele hours "hour")
+		   " and "
+		   (build-ele minutes "minute"))]
+		 [minutes
+		  (string-append
+		   (build-ele minutes "minute")
+		   " and "
+		   (build-ele seconds "second"))]
+		 [else
+		  (build-ele seconds "second")])))
+  
+  (define (build-ele count name)
+    (cond
+     [(or (not count) (zero? count))
+      (format "0 ~as" name)]
+     [(= count 1)
+      (format "1 ~a" name)]
+     [else
+      (format "~a ~as" count name)]))
+  
+  (define (how-long-ago-list diff)
+    (let loop ([divs '(60 60 24)]
+               [diff diff])
+      (cond
+       [(null? divs) 
+	(if (zero? diff)
+	    (list #f)
+	    (list diff))]
+       [else (let ([div (car divs)])
+	       (if (<= diff 0)
+		   (cons #f (loop (cdr divs) 0))
+		   (cons (modulo diff div)
+			 (loop (cdr divs)
+			       (quotient diff div)))))])))
+  
+  (define (how-much-memory)
+    (let loop ([n (current-memory-use)])
+      (cond
+       [(< n 1000) (format "~a" n)]
+       [else (format "~a,~a"
+		     (loop (quotient n 1000))
+		     (pad-3 (modulo n 1000)))])))
+
+  (define (pad-3 n)
+    (cond
+     [(< n 10) (format "00~a" n)]
+     [(< n 100) (format "0~a" n)]
+     [else (format "~a" n)])))
diff --git a/collects/sirmail/sirmail.creator b/collects/sirmail/sirmail.creator
new file mode 100644
index 0000000000..4be7d98a20
--- /dev/null
+++ b/collects/sirmail/sirmail.creator
@@ -0,0 +1,2 @@
+SrMl
+(This code is registered with Apple.)
diff --git a/collects/sirmail/sirmail.icns b/collects/sirmail/sirmail.icns
new file mode 100644
index 0000000000..fa680e4a99
Binary files /dev/null and b/collects/sirmail/sirmail.icns differ
diff --git a/collects/sirmail/sirmail.ico b/collects/sirmail/sirmail.ico
new file mode 100644
index 0000000000..ac07b9bd3f
Binary files /dev/null and b/collects/sirmail/sirmail.ico differ
diff --git a/collects/sirmail/sirmail.ss b/collects/sirmail/sirmail.ss
new file mode 100644
index 0000000000..0ebe403a23
--- /dev/null
+++ b/collects/sirmail/sirmail.ss
@@ -0,0 +1,205 @@
+;; SirMail: Simple Imap Reader for Mail
+;;          (with a mail composer, too)
+
+(module sirmail mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "class.ss")
+	   (lib "mred-sig.ss" "mred")
+	   (lib "mred.ss" "mred")
+           (lib "framework.ss" "framework")
+	   (lib "list.ss"))
+  
+  (require "sirmails.ss"
+	   "pref.ss"
+	   "sirmailr.ss")
+
+  (require (lib "imap-sig.ss" "net")
+	   (lib "smtp-sig.ss" "net")
+	   (lib "head-sig.ss" "net")
+	   (lib "base64-sig.ss" "net")
+	   (lib "mime-sig.ss" "net")
+	   (lib "qp-sig.ss" "net")
+	   (lib "imap.ss" "net")
+	   (lib "smtp.ss" "net")
+	   (lib "head.ss" "net")
+	   (lib "base64.ss" "net")
+	   (lib "mime.ss" "net")
+	   (lib "qp.ss" "net"))
+
+  (require (lib "hierlist-sig.ss" "hierlist")
+	   (lib "hierlist.ss" "hierlist"))
+
+  ;; Constants:
+  (define inbox-name "Inbox")
+  (define default-mailbox-options null)
+
+  ;; ------------------------------------------------------------
+  ;; Every window (reader or sender) is in it's own
+  ;; eventspace. Each should terminate by calling `exit'.
+  ;; We install an exit handler so that we only actually
+  ;; exit when the last window is closed.
+
+  (define prim-exit (exit-handler))
+  (define exit-eventspaces null)
+  (define exit-sema (make-semaphore 1))
+  (define (exit-sirmail where)
+    (let ([evtsp (current-eventspace)])
+      ;; Lock is because a separate process might be calling exit
+      ;;  or starting up
+      (semaphore-wait exit-sema)
+      (set! exit-eventspaces (remq evtsp exit-eventspaces))
+      (when (null? exit-eventspaces)
+	(save-prefs)
+	(prim-exit 0))
+      (semaphore-post exit-sema)))
+
+  ;; This function is called to start a new window:
+  (define (start-new-window thunk)
+    (define evtsp (make-eventspace))
+    (parameterize ([current-eventspace evtsp])
+      (semaphore-wait exit-sema)
+      (set! exit-eventspaces (cons evtsp exit-eventspaces))
+      (semaphore-post exit-sema)
+      (queue-callback
+       (lambda ()
+	 (exit-handler (lambda (x) (exit-sirmail "a")))
+	 (let ([eeh (error-escape-handler)])
+	   (error-escape-handler
+	    (lambda () 
+	      (unless (pair? (get-top-level-windows))
+		;; Didn't start up...
+		(exit-sirmail "b"))
+	      (eeh))))
+	 (thunk)
+	 (yield 'wait)
+	 (exit-sirmail "c")))))
+
+  ;; Reader windows -----------------------------------------------------------
+  
+  ;; This function uses `start-new-window' to open a reader window.
+  ;; A reader window is implemented by an instance of the sirmail@ unit.
+  (define open-mailbox
+    (case-lambda
+     [(mailbox-name) (open-mailbox mailbox-name default-mailbox-options)]
+     [(mailbox-name mailbox-options)
+      (start-new-window
+       (lambda ()
+	 (invoke-unit/sig
+	  sirmail@
+	  sirmail:environment^
+	  mred^
+	  net:imap^
+	  net:smtp^
+	  net:head^
+	  net:base64^
+	  net:mime^
+	  net:qp^
+	  hierlist^)))]))
+
+  ;; There's only one Folders window ----------------------------------------
+  
+  (require "optionr.ss"
+	   "folderr.ss")
+
+  (define folders-window #f)
+  (define folders-lock (make-semaphore 1))
+  
+  (define (with-folders-lock t)
+    (dynamic-wind
+     (lambda () (semaphore-wait folders-lock))
+     t
+     (lambda () (semaphore-post folders-lock))))
+  
+  (define (open-folders-window)
+    (with-folders-lock
+     (lambda ()
+       (if folders-window
+           (send folders-window show #t)
+           (let ([shutdown-folders-window
+                  (lambda ()
+                    (with-folders-lock
+                     (lambda ()
+                       (set! folders-window #f)
+                       (exit-sirmail "d"))))]
+                 [mailbox-name inbox-name]
+                 [mailbox-options default-mailbox-options])
+             (start-new-window
+              (lambda ()
+                (set! folders-window
+                      (invoke-unit/sig
+                       (compound-unit/sig
+                         (import [env : sirmail:environment^]
+                                 [s : (shutdown-folders-window)]
+                                 [mred : mred^]
+                                 [imap : net:imap^]
+                                 [hierlist : hierlist^])
+                         (link [options : sirmail:options^
+                                        (option@
+                                         env
+                                         imap
+                                         mred)]
+                               [folder : ()
+                                       (folder@
+                                        env
+                                        s
+                                        options
+                                        mred imap
+                                        hierlist)])
+                         (export))
+                       sirmail:environment^
+                       (shutdown-folders-window)
+                       mred^
+                       net:imap^
+                       hierlist^)))))))))
+     
+  (define (get-active-folder)
+    (with-folders-lock
+     (lambda ()
+       (and folders-window
+            (send folders-window get-mailbox-name)))))
+
+  ;; Set Quit handler to try closing all windows --------------------
+
+  (define asking-for-quit? #f)
+
+  (application-quit-handler
+   (lambda ()
+     (if asking-for-quit?
+	 (let ([l (get-top-level-windows)])
+	   (when (pair? l)
+	     ;; Createa thread because it's probably a dialog...
+	     (thread (lambda () (send (car l) show #t)))))
+	 (dynamic-wind
+	     (lambda () (set! asking-for-quit? #t))
+	     (lambda ()
+	       (when (= 1 (message-box/custom
+			   "Confirm Quit"
+			   "Really quit?"
+			   "Quit" "Cancel" #f
+			   #f '(default=1)
+			   2))
+		 (let ([l (begin
+			    (semaphore-wait exit-sema)
+			    (begin0
+			     exit-eventspaces
+			     (semaphore-post exit-sema)))])
+		   (for-each
+		    (lambda (evtsp)
+		      (parameterize ([current-eventspace evtsp])
+			(queue-callback
+			 (lambda ()
+			   (let ([f (get-top-level-edit-target-window)])
+			     (when (and f (f . is-a? . frame%))
+			       (when (send f can-close?)
+				 (send f on-close)
+				 (send f show #f)))))
+			 #f)))
+		    l))))
+	     (lambda () (set! asking-for-quit? #f))))))
+
+  ;; We start by opening "Inbox" ----------------------------------------
+  
+  (open-mailbox inbox-name)
+
+  ;; Wait for an explicit exit
+  (yield (make-semaphore)))
diff --git a/collects/sirmail/sirmailr.ss b/collects/sirmail/sirmailr.ss
new file mode 100644
index 0000000000..c7ef4e27dd
--- /dev/null
+++ b/collects/sirmail/sirmailr.ss
@@ -0,0 +1,54 @@
+
+(module sirmailr mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "mred-sig.ss" "mred"))
+
+  (require "sirmails.ss")
+
+  (require (lib "imap-sig.ss" "net")
+           (lib "smtp-sig.ss" "net")
+           (lib "head-sig.ss" "net")
+           (lib "base64-sig.ss" "net")
+           (lib "mime-sig.ss" "net")
+           (lib "qp-sig.ss" "net"))
+  
+  (require (lib "hierlist-sig.ss" "hierlist"))
+  
+  (require "utilr.ss"
+           "optionr.ss"
+           "readr.ss"
+           "sendr.ss")
+
+  ;; The sirmail@ unit implements a single reader window. See
+  ;; "sirmail.ss" for its use: 
+  (provide sirmail@)
+  (define sirmail@
+    (compound-unit/sig
+     (import (ENV : sirmail:environment^)
+	     (MRED : mred^)
+	     (IMAP : net:imap^)
+	     (SMTP : net:smtp^)
+	     (HEAD : net:head^)
+	     (BASE64 : net:base64^)
+	     (MIME : net:mime^)
+	     (QP : net:qp^)
+	     (HIER : hierlist^))
+     (link [UTILS : sirmail:utils^
+		  (util@
+		   MRED
+		   BASE64
+		   QP)]
+	   [OPTIONS : sirmail:options^
+		    (option@
+		     ENV
+		     IMAP
+                     MRED)]
+	   [READ : sirmail:read^
+		 (read@
+		  OPTIONS ENV UTILS SEND
+		  MRED IMAP SMTP HEAD BASE64 MIME QP HIER)]
+	   [SEND : sirmail:send^
+		 (send@
+		  (ENV : (exit-sirmail)) UTILS OPTIONS READ
+		  MRED IMAP SMTP HEAD BASE64 QP HIER)])
+     (export))))
diff --git a/collects/sirmail/sirmails.ss b/collects/sirmail/sirmails.ss
new file mode 100644
index 0000000000..81d8b596ea
--- /dev/null
+++ b/collects/sirmail/sirmails.ss
@@ -0,0 +1,83 @@
+
+(module sirmails mzscheme
+  (require (lib "unitsig.ss"))
+  
+  (provide sirmail:environment^)
+  (define-signature sirmail:environment^
+    (mailbox-name 
+     mailbox-options 
+     open-folders-window
+     get-active-folder
+
+     open-mailbox
+     start-new-window
+     exit-sirmail))
+
+  (provide sirmail:utils^)
+  (define-signature sirmail:utils^
+    (crlf
+     split
+     splice
+     split-crlf
+     split-crlf/preserve-last
+     split-lf
+     crlf->lf
+     crlf->lf/preserve-last
+     lf->crlf
+     string-crlf->lf
+     string-lf->crlf
+     header->lines
+     enumerate
+     find
+     string->regexp
+
+     as-background
+
+     make-fixed-width
+
+     confirm-box
+
+     generalize-encoding
+     parse-encoded
+     encode-for-header))
+
+  (provide sirmail:send^)
+  (define-signature sirmail:send^
+    (new-mailer
+     (struct enclosure (name subheader data-thunk))))
+
+  (provide sirmail:options^)
+  (define-signature sirmail:options^
+    (IMAP-SERVER
+     USERNAME
+     get-PASSWORD
+     set-PASSWORD
+
+     LOCAL-DIR
+
+     MAIL-FROM
+     ALIASES
+     DEFAULT-DOMAIN
+     SMTP-SERVER
+     SMTP-SERVERS
+     set-SMTP-SERVER!
+     SAVE-SENT
+
+     ROOT-MAILBOX-FOR-LIST
+     ARCHIVE-MAILBOX
+     
+     MESSAGE-FIELDS-TO-SHOW
+     WARN-DOWNLOAD-SIZE
+     AUTO-FILE-TABLE
+     BIFF-DELAY
+     SELF-ADDRESSES
+     SORT
+     SHOW-URLS
+     
+     USE-EXTERNAL-COMPOSER?
+
+     parse-server-name))
+
+  (provide sirmail:read^)
+  (define-signature sirmail:read^
+    (queue-directory)))
diff --git a/collects/sirmail/spell.ss b/collects/sirmail/spell.ss
new file mode 100644
index 0000000000..c6ecdf678d
--- /dev/null
+++ b/collects/sirmail/spell.ss
@@ -0,0 +1,210 @@
+(module spell mzscheme
+  (require (lib "lex.ss" "parser-tools")
+           (prefix : (lib "lex-sre.ss" "parser-tools"))
+           (lib "class.ss")
+           (lib "string.ss")
+           (lib "list.ss")
+           (lib "framework.ss" "framework")
+           (lib "contract.ss")
+	   (lib "file.ss")
+           (lib "process.ss"))
+  
+  (provide/contract [activate-spelling ((is-a?/c color:text<%>) . -> . void?)]
+                    [word-count (-> number?)])
+  
+  (define-lex-abbrevs
+   (extended-alphabetic (:or alphabetic #\'))
+   (word (:: (:* extended-alphabetic) (:+ alphabetic) (:* extended-alphabetic)))
+   (paren (char-set "()[]{}")))
+                                   
+  (define get-word
+    (lexer 
+     ((:+ whitespace)
+      (values lexeme 'white-space #f (position-offset start-pos) (position-offset end-pos)))
+     (paren
+      (values lexeme 'other (string->symbol lexeme) (position-offset start-pos) (position-offset end-pos)))
+     ((:+ (:~ (:or alphabetic whitespace paren)))
+      (values lexeme 'other #f (position-offset start-pos) (position-offset end-pos)))
+     (word
+      (let ((ok (spelled-correctly? lexeme)))
+        (values lexeme (if ok 'other 'error) #f (position-offset start-pos) (position-offset end-pos))))
+     ((eof)
+      (values lexeme 'eof #f #f #f))))
+  
+  (define (activate-spelling t)
+    (send t start-colorer
+          (lambda (s) (format "framework:syntax-coloring:scheme:~a" s))
+          get-word
+          `((|(| |)|)
+            (|[| |]|)
+            (|{| |}|))))
+
+  (define ask-chan (make-channel))
+  (define word-count-chan (make-channel))
+  
+  ;; spelled-correctly? : string -> boolean
+  (define (spelled-correctly? word)
+    (sync
+     (nack-guard-evt
+      (lambda (failed)
+        (let ([result (make-channel)])
+          (channel-put ask-chan (list result failed word))
+          result)))))
+  
+  (define (word-count) 
+    (let ([c (make-channel)])
+      (channel-put word-count-chan c)
+      (channel-get c)))
+  
+  (thread
+   (lambda ()
+     (let ([bad-dict (make-hash-table 'equal)])
+       (let loop ([computed? #f]
+                  [dict #f])
+         (sync
+          (handle-evt
+           ask-chan
+           (lambda (lst)
+             (let-values ([(answer-chan give-up-chan word) (apply values lst)])
+               (let ([computed-dict (if computed?
+                                        dict
+                                        (fetch-dictionary))])
+                 (sync
+                  (handle-evt
+                   (channel-put-evt answer-chan (check-word computed-dict bad-dict word))
+                   (lambda (done)
+                     (loop #t computed-dict)))
+                  (handle-evt
+                   give-up-chan
+                   (lambda (done)
+                     (loop #t computed-dict))))))))
+          (handle-evt
+           word-count-chan
+           (lambda (ans)
+             (let ([count (if dict (hash-table-count dict) 0)])
+               (thread (lambda () (channel-put ans count))))
+             (loop computed? dict))))))))
+
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;;
+  ;;; The code below all runs in the above thread (only)
+  ;;;
+  
+  (define extra-words '("sirmail" "mred" "drscheme" "mzscheme" "plt"))
+  
+  (define has-ispell? 'dontknow)
+  (define ispell-prog #f)
+  (define ispell-in #f)
+  (define ispell-out #f)
+  (define ispell-err #f)
+  (define (ispell-word word)
+    (when (eq? has-ispell? 'dontknow)
+      (let ([existing (or (find-executable-path (if (eq? (system-type) 'windows)
+						    "ispell.exe"
+						    "ispell")
+						#f)
+			  (ormap (lambda (x) (and (file-exists? x) x))
+				 '("/sw/bin/ispell"
+				   "/usr/bin/ispell"
+				   "/bin/ispell"
+				   "/usr/local/bin/ispell")))])
+        (if (not existing)
+            (set! has-ispell? #f)
+            (begin
+              (set! has-ispell? #t)
+              (set! ispell-prog existing)))))
+    (cond
+      [has-ispell?
+       (unless (and ispell-in ispell-out ispell-err)
+         (let-values ([(out in pid err status) (apply values (process* ispell-prog 
+								       "-a"
+								       "-w"
+								       ;; Tell ispell to treat every character
+								       ;;  as part of a word, because our lexer
+								       ;;  has already separated words.
+								       (let loop ([n 255][l null])
+									 (if (= n 0)
+									     (apply string-append l)
+									     (loop (sub1 n)
+										   (cons
+										    (format "n~a" n)
+										    l))))))])
+           (let ([version-line (read-line out)])
+             (debug "< ~s\n" version-line))
+           
+           (set! ispell-in in)
+           (set! ispell-out out)
+           (set! ispell-err err)))
+       
+       (let ([to-send (format "^~a\n" word)])
+         (debug "> ~s\n" to-send)
+         (display to-send ispell-in)
+	 (flush-output ispell-in))
+
+       (let* ([answer-line (read-line ispell-out 'any)]
+              [_ (debug "< ~s\n" answer-line)]
+              [blank-line (read-line ispell-out 'any)]
+              [_ (debug "< ~s\n" blank-line)])
+         (unless (equal? blank-line "")
+           (fprintf (current-error-port) "expected blank line from ispell, got (word ~s):\n~a\nrestarting ispell\n\n" 
+                    word
+                    blank-line)
+           (close-output-port ispell-in)
+           (close-input-port ispell-out)
+           (close-input-port ispell-err)
+           (set! ispell-in #f)
+           (set! ispell-out #f)
+           (set! ispell-err #f))
+         (not (not (regexp-match #rx"^[\\+\\-\\*]" answer-line))))]
+      [else #f]))
+
+  (define (debug str . args)
+    (when (getenv "PLTISPELL")
+      (apply printf str args)))
+  
+  ;; fetch-dictionary : -> (union #f hash-table)
+  ;; computes a dictionary, if any of the possible-file-names exist
+  ;; for now, just return an empty table. Always use ispell
+  (define (fetch-dictionary) (make-hash-table 'equal))
+  
+  (define (fetch-dictionary/not-used)
+    (let* ([possible-file-names '("/usr/share/dict/words"
+                                  "/usr/share/dict/connectives"
+                                  "/usr/share/dict/propernames"
+                                  "/usr/dict/words")]
+           [good-file-names (filter file-exists? possible-file-names)])
+      (and (not (null? good-file-names))
+	   (let ([d (make-hash-table 'equal)])
+	     (for-each (lambda (word) (hash-table-put! d word #t)) extra-words)
+	     (for-each 
+	      (lambda (good-file-name)
+		(call-with-input-file* good-file-name
+				       (lambda (i)
+					 (let loop ()
+					   (let ((word (read-line i)))
+					     (unless (eof-object? word)
+						     (hash-table-put! d word #t)
+						     (loop)))))))
+	      good-file-names)
+	     d))))
+  
+  ;; check-word : hash-table hash-table string -> boolean
+  (define (check-word dict bad-dict word)
+    (let* ([word-ok (lambda (w) (hash-table-get dict w (lambda () #f)))]
+           [word-bad (lambda (w) (hash-table-get bad-dict w (lambda () #f)))]
+           [subword-ok (lambda (reg)
+                         (let ([m (regexp-match reg word)])
+                           (and m
+                                (word-ok (cadr m)))))])
+      (if dict
+          (cond
+            [(word-ok word) #t]
+            [(word-ok (string-lowercase! (string-copy word))) #t]
+            [(word-bad word) #f]
+            [else
+             (let ([ispell-ok (ispell-word word)])
+               (if ispell-ok 
+                   (hash-table-put! dict word #t)
+                   (hash-table-put! bad-dict word #t))
+                ispell-ok)])
+          #t))))
diff --git a/collects/sirmail/stamp-mask.xbm b/collects/sirmail/stamp-mask.xbm
new file mode 100644
index 0000000000..7830d743da
--- /dev/null
+++ b/collects/sirmail/stamp-mask.xbm
@@ -0,0 +1,6 @@
+#define mred_width 16
+#define mred_height 16
+static char mred_bits[] = {
+ 0x66,0x66,0xff,0xff,0xff,0xff,0xfe,0x7f,0xfe,0x7f,0xff,0xff,0xff,0xff,0xfe,
+ 0x7f,0xfe,0x7f,0xff,0xff,0xff,0xff,0xfe,0x7f,0xfe,0x7f,0xff,0xff,0xff,0xff,
+ 0x66,0x66};
diff --git a/collects/sirmail/stamp.bmp b/collects/sirmail/stamp.bmp
new file mode 100644
index 0000000000..7f69252ea4
Binary files /dev/null and b/collects/sirmail/stamp.bmp differ
diff --git a/collects/sirmail/utilr.ss b/collects/sirmail/utilr.ss
new file mode 100644
index 0000000000..fc1f5c900f
--- /dev/null
+++ b/collects/sirmail/utilr.ss
@@ -0,0 +1,239 @@
+
+(module utilr mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "class.ss")
+	   (lib "mred-sig.ss" "mred")
+	   (lib "qp-sig.ss" "net")
+	   (lib "base64-sig.ss" "net")
+	   (prefix unihead: (lib "unihead.ss" "net"))
+	   (lib "etc.ss")
+	   (lib "string.ss"))
+
+  (require "sirmails.ss")
+
+  (provide util@)
+  (define util@
+    (unit/sig sirmail:utils^
+      (import mred^
+	      net:base64^
+	      net:qp^)
+
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;  Utilities                                              ;;
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+      (define crlf (string #\return #\linefeed))
+
+      (define (split s re)
+	(regexp-split re s))
+
+      (define (drop-last-if-empty orig-l)
+	(let loop ([l orig-l][accum null])
+	  (cond
+	   [(null? l) orig-l]
+	   [(null? (cdr l))
+	    (if (equal? #"" (car l))
+		(reverse accum)
+		orig-l)]
+	   [else (loop (cdr l) (cons (car l) accum))])))
+
+      (define (splice l sep)
+	(if (null? l)
+	    #""
+	    (let ([p (open-output-bytes)])
+	      (let loop ([l l])
+		(write-bytes (car l) p)
+		(unless (null? (cdr l))
+		  (display sep p)
+		  (loop (cdr l))))
+	      (get-output-bytes p))))
+      
+      (define (split-crlf/preserve-last s)
+	(split s #rx#"\r\n"))
+
+      (define (split-crlf s)
+	(drop-last-if-empty (split-crlf/preserve-last s)))
+
+      (define (split-lf s)
+	(drop-last-if-empty (split s #rx#"\n")))
+
+      (define (crlf->lf s)
+	(splice (split-crlf s) #"\n"))
+
+      (define (crlf->lf/preserve-last s)
+	(splice (split-crlf/preserve-last s) #"\n"))
+
+      (define (lf->crlf s)
+	(splice (split-lf s) #"\r\n"))
+
+      (define (string-crlf->lf s)
+	(regexp-replace* #rx"\r\n" s "\n"))
+
+      (define (string-lf->crlf s)
+	(regexp-replace* #rx"\n" s "\r\n"))
+
+      (define (header->lines s)
+	(regexp-split #rx"\r\n" 
+		      ;; We don't want the extra empty line at the end:
+		      (substring s 0 (- (string-length s) 2))))
+
+      (define (enumerate n)
+	(let loop ([n n][a null])
+	  (if (zero? n)
+	      a
+	      (loop (sub1 n) (cons n a)))))
+
+      (define (find i l)
+	(let loop ([l l][pos 0])
+	  (if (null? l)
+	      #f
+	      (if (eq? (car l) i)
+		  pos
+		  (loop (cdr l) (add1 pos))))))
+
+      (define (string->regexp s)
+	(regexp-quote s))
+
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+      (define (break-really-hard? set-d!)
+	(let* ([d (make-object dialog% "Danger")]
+	       [p (make-object vertical-pane% d)]
+	       [bp (make-object horizontal-pane% d)]
+	       [result #f])
+	  (send bp stretchable-width #f)
+	  (send bp stretchable-height #f)
+	  (make-object message% "Breaking now is dangerous." p)
+	  (make-object message% "It requires killing the window." p)
+	  (make-object message% "" p)
+	  (make-object message% "Are you sure you want to kill?" p)
+	  (make-object button% "&Kill" bp (lambda (b e)
+					    (set! result #t)
+					    (send d show #f)))
+	  (make-object button% "Cancel" bp (lambda (b e) (send d show #f)))
+	  (set-d! d)
+	  (send d show #t)
+	  result))
+
+      ;; as-background: (bool window<%> braek-thunk ->)
+      ;;                (break-ok-thunk break-not-ok-thunk -> X) 
+      ;;                (-> Y) -> X
+      ;; Runs a task in the background.
+      ;; The `enable' function is called with #f as the first argument
+      ;;  near the start of the background task. The `break-thunk' can be
+      ;;  called to interrupt the task. The `enable' function might
+      ;;  not get called at all if the task is fast enough.
+      ;; The `go' function performs the task (in a thread created by
+      ;;   as-background); it receives thunks that it can call to
+      ;;   indicate when breaks are "safe". If the user tries to break
+      ;;   at a non-safe point, the user is warned; if the user
+      ;;   proceeds, things are killed and `exit' is called. If
+      ;;   the user breaks at a safe point, a break signal is sent
+      ;;   to the thread for the background task.
+      ;; The `pre-kill' thunk is called before things are killed
+      ;;   for a non-"safe" break.
+      (define (as-background enable go pre-kill)
+	(let* ([v #f]
+	       [exn #f]
+	       [break-ok? #f]
+	       [breaking-dialog #f]
+	       [adjust-break (make-semaphore 1)]
+	       [change-break-ok (lambda (ok?)
+				  (lambda ()
+				    (semaphore-wait adjust-break)
+				    (set! break-ok? ok?)
+				    (let ([waiting? (and ok? breaking-dialog)])
+				      (when waiting?
+					(send breaking-dialog show #f)
+					(set! breaking-dialog #f))
+				      (semaphore-post adjust-break)
+				      (when waiting?
+					(break-thread (current-thread))))))]
+	       [s (make-semaphore 0)]
+	       [t (thread (lambda ()
+			    (with-handlers ([void (lambda (x) 
+						    (set! exn x))])
+			      (set! v (call-with-values 
+					  (lambda () (go (change-break-ok #f)
+							 (change-break-ok #t)))
+					list))
+			      ((change-break-ok #f)))
+			    (when breaking-dialog
+			      (send breaking-dialog show #f))
+			    (semaphore-post s)))])
+	  ;; If the operation is fast enough, no need to disable then yield then enable,
+	  ;; which makes the screen flash and causes events to get dropped. 1/4 second
+	  ;; seems "fast enough".
+	  (unless (sync/timeout 0.25 s)
+	    (let ([v (enable #f #f
+			     (lambda ()
+			       (semaphore-wait adjust-break)
+			       (if break-ok?
+				   (break-thread t)
+				   (let ([v (break-really-hard? (lambda (d) 
+								  (set! breaking-dialog d)
+								  (semaphore-post adjust-break)))])
+				     (semaphore-wait adjust-break)
+				     (set! breaking-dialog #f)
+				     (semaphore-post adjust-break)
+				     (when v
+				       (pre-kill)
+				       (kill-thread t)
+				       (exit))))))])
+	      (yield s)
+	      (enable #t v void)))
+	  (if exn
+	      (raise exn)
+	      (apply values v))))
+
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+      ;; the actual fixed width font is already set by
+      ;; the editor:standard-style-list-mixin
+      (define (make-fixed-width c e wrap? wrap-bm)
+	(let ([s (send (send e get-style-list)
+		       find-named-style "Standard")])
+	  (send e set-tabs null 8 #f)
+	  (let ([font (send s get-font)]
+		[dc (send c get-dc)]
+		[wbox (box 0)]
+		[hbox (box 0)])
+	    (send e get-view-size wbox hbox)
+	    (let-values ([(w h) (send c get-size)]
+			 [(1w 1h d a) (send dc get-text-extent "X" font)])
+	      (let ([80chars (+ (* 1w 80)
+				2 ; +2 for caret
+				(if wrap-bm 
+				    (send wrap-bm get-width) 
+				    0))])
+		(when wrap? 
+		  (when wrap-bm 
+		    (send e set-autowrap-bitmap wrap-bm))
+		  (send e set-max-width 80chars))
+		(send c min-width 
+		      (inexact->exact (round (+ 80chars (- w (unbox wbox)))))))))))
+
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+      (define confirm-box 
+	(opt-lambda (title message [parent #f] [style null])
+	  (if (= 1 (message-box/custom
+		    title
+		    message
+		    "&Yes"
+		    "&No"
+		    #f
+		    parent
+		    (append (if (memq 'app style) null '(caution)) 
+			    '(default=1))
+		    2))
+	      'yes
+	      'no)))
+
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;  Decoding `from' names                                  ;;
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+      (define generalize-encoding unihead:generalize-encoding)
+      (define parse-encoded unihead:decode-for-header)
+      (define encode-for-header unihead:encode-for-header))))
diff --git a/collects/skipper/debug-tool.ss b/collects/skipper/debug-tool.ss
new file mode 100644
index 0000000000..2f5a00fb27
--- /dev/null
+++ b/collects/skipper/debug-tool.ss
@@ -0,0 +1,762 @@
+(module debug-tool mzscheme
+  (require (lib "etc.ss")
+           (lib "list.ss")
+           (lib "string.ss")
+           (prefix srfi: (lib "search.ss" "srfi" "1"))
+           ;(lib "math.ss")
+           (lib "class.ss")
+           (lib "unitsig.ss")
+           ;(lib "contract.ss")
+           (lib "mred.ss" "mred")
+           (prefix drscheme:arrow: (lib "arrow.ss" "drscheme"))
+           (lib "tool.ss" "drscheme")
+           (lib "marks.ss" "skipper")
+           (lib "boundmap.ss" "syntax")
+           (prefix kernel: (lib "kerncase.ss" "syntax"))
+           (lib "bitmap-label.ss" "mrlib")
+           ;(lib "framework.ss" "framework")
+           #;(lib "string-constant.ss" "string-constants"))
+  
+  (provide tool@)
+  
+  (define tool@
+    (unit/sig drscheme:tool-exports^
+      (import drscheme:tool^)
+      
+      (define phase1 void)
+      (define phase2 void)
+      
+      (define (arglist-bindings arglist-stx)
+        (syntax-case arglist-stx ()
+          [var
+           (identifier? arglist-stx)
+           (list arglist-stx)]
+          [(var ...)
+           (syntax->list arglist-stx)]
+          [(var . others)
+           (cons #'var (arglist-bindings #'others))]))
+      
+      (define (annotate-stx stx breakpoints break-wrap record-bound-id)
+        
+        (define (top-level-annotate stx)
+          (kernel:kernel-syntax-case
+           stx #f
+           [(module identifier name (#%plain-module-begin . module-level-exprs))
+            (quasisyntax/loc stx (module identifier name
+                                   (#%plain-module-begin 
+                                    #,@(map module-level-expr-iterator
+                                            (syntax->list #'module-level-exprs)))))]
+           [else-stx
+            (general-top-level-expr-iterator stx)]))
+        
+        (define (module-level-expr-iterator stx)
+          (kernel:kernel-syntax-case
+           stx #f
+           [(provide . provide-specs)
+            stx]
+           [else-stx
+            (general-top-level-expr-iterator stx)]))
+        
+        (define (general-top-level-expr-iterator stx)
+          (kernel:kernel-syntax-case
+           stx #f
+           [(define-values (var ...) expr)
+            #`(define-values (var ...)
+                #,(annotate #`expr (syntax->list #`(var ...)) #t))]
+           [(define-syntaxes (var ...) expr)
+            stx]
+           [(begin . top-level-exprs)
+            (quasisyntax/loc stx (begin #,@(map (lambda (expr)
+                                                  (module-level-expr-iterator expr))
+                                                (syntax->list #'top-level-exprs))))]
+           [(require . require-specs)
+            stx]
+           [(require-for-syntax . require-specs)
+            stx]
+           [else
+            (annotate stx '() #f)]))
+        
+        (define (annotate expr bound-vars is-tail?)
+          
+          (define annotate-break?
+            (let ([pos (syntax-position expr)]
+                  [src (syntax-source expr)])
+              (and src
+                   (is-a? src object%) ; FIX THIS
+                   pos
+                   (hash-table-get breakpoints pos (lambda () #t))
+                   (kernel:kernel-syntax-case
+                    expr #f
+                    [(if test then) #t]
+                    [(if test then else) #t]
+                    [(begin . bodies) #t]
+                    [(begin0 . bodies) #t]
+                    [(let-values . clause) #t]
+                    [(letrec-values . clause) #t]
+                    [(set! var val) #t]
+                    [(with-continuation-mark key mark body) #t]
+                    [(#%app . exprs) #t]
+                    [_ #f])
+                   (begin
+                     (hash-table-put! breakpoints pos #f)
+                     (hash-table-put! breakpoints (+ pos (syntax-span expr) -1) #f)
+                     #t))))
+          
+          (define (let/rec-values-annotator letrec?)
+            (kernel:kernel-syntax-case
+             expr #f
+             [(label (((var ...) rhs) ...) . bodies)
+              (let* ([new-bindings (apply append
+                                          (map syntax->list
+                                               (syntax->list #`((var ...) ...))))]
+                     [new-rhs (if letrec?
+                                  (map (lambda (expr)
+                                         (annotate expr (append new-bindings bound-vars) #f))
+                                       (syntax->list #`(rhs ...)))
+                                  (map (lambda (expr) (annotate expr bound-vars #f))
+                                       (syntax->list #`(rhs ...))))]
+                     [last-body (car (reverse (syntax->list #`bodies)))]
+                     [all-but-last-body (reverse (cdr (reverse (syntax->list #`bodies))))]
+                     [bodies (append (map (lambda (expr)
+                                            (annotate expr
+                                                      (append new-bindings bound-vars) #f))
+                                          all-but-last-body)
+                                     (list (annotate
+                                            last-body
+                                            (append new-bindings bound-vars) is-tail?)))])
+                (with-syntax ([(new-rhs/trans ...) new-rhs])
+                  (quasisyntax/loc expr
+                    (label (((var ...) new-rhs/trans) ...)
+                           #,@bodies))))]))
+          
+          (define (lambda-clause-annotator clause)
+            (kernel:kernel-syntax-case
+             clause #f
+             [(arg-list . bodies)
+              (let* ([new-bound-vars (append (arglist-bindings #`arg-list) bound-vars)]
+                     [new-bodies (let loop ([bodies (syntax->list #`bodies)])
+                                   (if (equal? '() (cdr bodies))
+                                       (list (annotate (car bodies) new-bound-vars #t))
+                                       (cons (annotate (car bodies) new-bound-vars #f)
+                                             (loop (cdr bodies)))))])
+                (quasisyntax/loc clause
+                  (arg-list #,@new-bodies)))]))
+          
+          (define annotated
+            (syntax-recertify
+             (kernel:kernel-syntax-case
+              expr #f
+              [var-stx (identifier? (syntax var-stx))
+                       (let ([binder (and (syntax-original? expr)
+                                          (srfi:member expr bound-vars module-identifier=?))])
+                         (when binder
+                           (let ([f (first binder)])
+                             (record-bound-id f f)
+                             (record-bound-id expr f)))
+                         expr)]
+              
+              [(lambda . clause)
+               (quasisyntax/loc expr 
+                 (lambda #,@(lambda-clause-annotator #`clause)))]
+              
+              [(case-lambda . clauses)
+               (quasisyntax/loc expr
+                 (case-lambda #,@(map lambda-clause-annotator (syntax->list #`clauses))))]
+              
+              [(if test then)
+               (quasisyntax/loc expr (if #,(annotate #`test bound-vars #f)
+                                         #,(annotate #`then bound-vars is-tail?)))]
+              
+              [(if test then else)
+               (quasisyntax/loc expr (if #,(annotate #`test bound-vars #f)
+                                         #,(annotate #`then bound-vars is-tail?)
+                                         #,(annotate #`else bound-vars is-tail?)))]
+              
+              [(begin . bodies)
+               (letrec ([traverse
+                         (lambda (lst)
+                           (if (and (pair? lst) (equal? '() (cdr lst)))
+                               `(,(annotate (car lst) bound-vars is-tail?))
+                               (cons (annotate (car lst) bound-vars #f)
+                                     (traverse (cdr lst)))))])
+                 (quasisyntax/loc expr (begin #,@(traverse (syntax->list #`bodies)))))]
+              
+              [(begin0 . bodies)
+               (quasisyntax/loc expr (begin0 #,@(map (lambda (expr)
+                                                       (annotate expr bound-vars #f))
+                                                     (syntax->list #`bodies))))]
+              
+              [(let-values . clause)
+               (let/rec-values-annotator #f)]
+              
+              [(letrec-values . clause) 
+               (let/rec-values-annotator #t)]
+              
+              [(set! var val)
+               (let ([binder (and (syntax-original? #'var)
+                                  (srfi:member #'var bound-vars module-identifier=?))])
+                 (when binder
+                   (let ([f (first binder)])
+                     (record-bound-id f f)
+                     (record-bound-id expr f)))
+                 (quasisyntax/loc expr (set! var #,(annotate #`val bound-vars #f))))]
+              
+              [(quote _) expr]
+              
+              [(quote-syntax _) expr]
+              
+              [(with-continuation-mark key mark body)
+               (quasisyntax/loc expr (with-continuation-mark key
+                                       #,(annotate #`mark bound-vars #f)
+                                       #,(annotate #`body bound-vars is-tail?)))]
+              
+              [(#%app . exprs)
+               (let ([subexprs (map (lambda (expr) 
+                                      (annotate expr bound-vars #f))
+                                    (syntax->list #`exprs))])
+                 (if is-tail?
+                     (quasisyntax/loc expr #,subexprs)
+                     (wcm-wrap (make-debug-info expr bound-vars bound-vars 'normal #f)
+                               (quasisyntax/loc expr #,subexprs))))]
+              
+              [(#%datum . _) expr]
+              
+              [(#%top . var) expr]
+              
+              [else (error 'expr-syntax-object-iterator "unknown expr: ~a"
+                           (syntax-object->datum expr))])
+             expr
+             (current-code-inspector)
+             #f))
+          
+          (if annotate-break?
+              (break-wrap
+               (make-debug-info expr bound-vars bound-vars 'at-break #f)
+               annotated
+               expr)
+              annotated))
+        
+        (top-level-annotate stx))
+      
+      (define (break-at bp p)
+        (hash-table-get bp p))
+      
+      (define (truncate str n)
+        (substring str 0 (min n (string-length str))))
+      
+      (define (debug-definitions-text-mixin super%)
+        (class super%
+          
+          (inherit dc-location-to-editor-location
+                   editor-location-to-dc-location
+                   invalidate-bitmap-cache
+                   get-canvas)
+          
+          (define parent #f)
+          (define/public (set-parent! p)
+            (set! parent p))
+          (define mouse-over-pos #f)
+          (define bp-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
+          (define bp-brush (send the-brush-list find-or-create-brush "red" 'solid))
+          (define bp-mo-pen (send the-pen-list find-or-create-pen "darkgray" 1 'solid))
+          (define bp-mo-brush (send the-brush-list find-or-create-brush "pink"
+                                    'solid))
+          (define bp-tmp-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
+          (define bp-tmp-brush (send the-brush-list find-or-create-brush "yellow"
+                                    'solid))
+          (define pc-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
+          (define pc-brush (send the-brush-list find-or-create-brush "forestgreen" 'solid))
+          (define pc-err-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
+          (define pc-err-brush (send the-brush-list find-or-create-brush "red" 'solid))
+          (define pc-brk-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
+          (define pc-brk-brush (send the-brush-list find-or-create-brush "gray" 'solid))
+          
+          (super-instantiate ())
+          
+          (define/private (get-pos/text event)
+            (let ([event-x (send event get-x)]
+                  [event-y (send event get-y)]
+                  [on-it? (box #f)])
+              (let loop ([editor this])
+                (let-values ([(x y) (send editor dc-location-to-editor-location
+                                          event-x event-y)])
+                  (cond
+                    [(is-a? editor text%)
+                     (let ([pos (send editor find-position x y #f on-it?)])
+                       (cond
+                         [(not (unbox on-it?)) (values #f #f)]
+                         [else
+                          (let ([snip (send editor find-snip pos 'after-or-none)])
+                            (if (and snip
+                                     (is-a? snip editor-snip%))
+                                (loop (send snip get-editor))
+                                (values pos editor)))]))]
+                    [(is-a? editor pasteboard%)
+                     (let ([snip (send editor find-snip x y)])
+                       (if (and snip
+                                (is-a? snip editor-snip%))
+                           (loop (send snip get-editor))
+                           (values #f #f)))]
+                    [else (values #f #f)])))))
+          
+          (define/private (find-char-box text left-pos right-pos)
+            (let ([xlb (box 0)]
+                  [ylb (box 0)]
+                  [xrb (box 0)]
+                  [yrb (box 0)])
+              (send text position-location left-pos xlb ylb #t)
+              (send text position-location right-pos xrb yrb #f)
+              (let*-values ([(xl-off yl-off) (send text editor-location-to-dc-location
+                                                   (unbox xlb) (unbox ylb))]
+                            [(xl yl) (dc-location-to-editor-location xl-off yl-off)]
+                            [(xr-off yr-off) (send text editor-location-to-dc-location
+                                                   (unbox xrb) (unbox yrb))]
+                            [(xr yr) (dc-location-to-editor-location xr-off yr-off)])
+                (values xl yl xr yr))))
+          
+          (define/override (on-event event)
+            (if (and parent (send parent debug?))
+                (let ([breakpoints (send parent get-breakpoints)])
+                  (cond
+                    [(send event leaving?)
+                     (when mouse-over-pos
+                       (set! mouse-over-pos #f)
+                       (invalidate-bitmap-cache))]
+                    [(or (send event moving?)
+                         (send event entering?))
+                     (let-values ([(pos text) (get-pos/text event)])
+                       (when (and pos text)
+                         (cond
+                           ; mouse on breakable pos and hasn't moved significantly
+                           [(eq? (add1 pos) mouse-over-pos)]
+                           ; mouse on new breakable pos
+                           [(not (eq? (hash-table-get
+                                       breakpoints
+                                       (add1 pos) (lambda () 'invalid)) 'invalid))
+                            (set! mouse-over-pos (add1 pos))
+                            (invalidate-bitmap-cache)]
+                           ; moved off breakable pos
+                           [mouse-over-pos
+                            (set! mouse-over-pos #f)
+                            (invalidate-bitmap-cache)]))
+                       (super on-event event))]
+                    [(send event button-down? 'right)
+                     (let-values ([(pos text) (get-pos/text event)])
+                       (if (and pos text)
+                           (let* ([pos (add1 pos)]
+                                  [break-status (hash-table-get breakpoints pos (lambda () 'invalid))])
+                             (case break-status
+                               [(#t #f)
+                                (let ([menu (make-object popup-menu% #f)])
+                                  (make-object menu-item%
+                                    "Toggle breakpoint"
+                                    menu
+                                    (lambda (item evt)
+                                      (hash-table-put! breakpoints pos (not break-status))
+                                      (invalidate-bitmap-cache)))
+                                  (let ([pc (send parent get-pc)])
+                                    (if (and pc (= pos pc))
+                                        (let ([stat (send parent get-break-status)])
+                                          (when (cons? stat)
+                                            (send (make-object menu-item%
+                                                    (truncate
+                                                     (if (= 2 (length stat))
+                                                         (format "value = ~a" (cadr stat))
+                                                         (format "~a" (cons 'values (rest stat))))
+                                                     200)
+                                                    menu
+                                                    void) enable #f))
+                                          (when (not (eq? stat 'break))
+                                            (make-object menu-item%
+                                              (if (cons? stat)
+                                                  "Change return value..."
+                                                  "Skip expression...")
+                                              menu
+                                              (lambda (item evt)
+                                                (let ([tmp
+                                                       (get-text-from-user "Return value" #f)])
+                                                  (when tmp
+                                                    (send parent set-break-status
+                                                          (list 'exit-break (eval-string tmp)))))))))
+                                        (make-object menu-item%
+                                          "Run up to this location"
+                                          menu
+                                          (lambda (item evt)
+                                            (hash-table-put!
+                                             breakpoints pos
+                                             (lambda () (hash-table-put! breakpoints pos #f) #t))
+                                            (invalidate-bitmap-cache)
+                                            (when (send parent get-stack-frames)
+                                              (send parent resume))))))
+                                  (send (get-canvas) popup-menu menu
+                                        (+ 1 (inexact->exact (floor (send event get-x))))
+                                        (+ 1 (inexact->exact (floor (send event get-y))))))]
+                               [(invalid)
+                                (if parent
+                                    (let* ([frames (send parent get-stack-frames)]
+                                           [pos-vec (send parent get-pos-vec)]
+                                           [id (vector-ref pos-vec pos)]
+                                           #;[_ (printf "frames = ~a~npos-vec = ~a~nid = ~a~n"
+                                                        frames pos-vec id)])
+                                      (unless (and
+                                               id frames
+                                               (let/ec k
+                                                 (let* ([id-sym (syntax-e id)]
+                                                        [binding (lookup-first-binding
+                                                                  (lambda (id2) (module-identifier=? id id2))
+                                                                  frames (lambda () (k #f)))]
+                                                        [val (mark-binding-value
+                                                              binding)]
+                                                        [menu (make-object popup-menu% #f)])
+                                                   (send (make-object menu-item%
+                                                           (truncate
+                                                            (format "~a = ~a" id-sym val)
+                                                            200)
+                                                           menu
+                                                           (lambda (item evt)
+                                                             (printf "~a" val))) enable #f)
+                                                   (make-object menu-item%
+                                                     (format "(set! ~a ...)" id-sym)
+                                                     menu
+                                                     (lambda (item evt)
+                                                       (let ([tmp
+                                                              (get-text-from-user
+                                                               (format "New value for ~a" id-sym) #f #f
+                                                               (format "~a" val))])
+                                                         (when tmp
+                                                           (mark-binding-set! binding (eval-string tmp))))))
+                                                   (send (get-canvas) popup-menu menu
+                                                         (+ 1 (inexact->exact (floor (send event get-x))))
+                                                         (+ 1 (inexact->exact (floor (send event get-y)))))
+                                                   #t)))
+                                        (super on-event event)))
+                                    (super on-event event))]))
+                           (super on-event event)))]
+                    [else (super on-event event)]))
+                (super on-event event)))
+          
+          (define/override (on-paint before dc left top right bottom dx dy draw-caret)
+            (super on-paint before dc left top right bottom dx dy draw-caret)
+            (when (and parent (send parent debug?) (not before))
+              (let ([breakpoints (send parent get-breakpoints)])
+                (hash-table-for-each
+                 breakpoints
+                 (lambda (pos enabled?)
+                   (when (and (>= pos 0) (or enabled? (and mouse-over-pos (= mouse-over-pos pos))))
+                     (let*-values ([(xl yl xr yr) (find-char-box this (sub1 pos) pos)]
+                                   [(diameter) (- xr xl)]
+                                   [(yoff) (/ (- yr yl diameter) 2)])
+                       (let ([op (send dc get-pen)]
+                             [ob (send dc get-brush)])
+                         (case enabled?
+                           [(#t) (send dc set-pen bp-pen)
+                                 (send dc set-brush bp-brush)]
+                           [(#f) (send dc set-pen bp-mo-pen)
+                                 (send dc set-brush bp-mo-brush)]
+                           [else (send dc set-pen bp-tmp-pen)
+                                   (send dc set-brush bp-tmp-brush)])
+                         ;(drscheme:arrow:draw-arrow dc xl yl xr yr dx dy)
+                         (send dc draw-ellipse (+ xl dx) (+ yl dy yoff) diameter diameter)
+                         #;(send dc draw-polygon stop-sign
+                                 (+ xl dx)
+                                 (+ yl dy 2))
+                         (send dc set-pen op)
+                         (send dc set-brush ob))))))
+                (let ([pos (send parent get-pc)])
+                  (when pos
+                    (let*-values ([(xl yl xr yr) (find-char-box this (sub1 pos) pos)]
+                                  [(ym) (/ (+ yl yr) 2)])
+                      (let ([op (send dc get-pen)]
+                            [ob (send dc get-brush)])
+                        (case (send parent get-break-status)
+                          [(error) (send dc set-pen pc-err-pen)
+                                   (send dc set-brush pc-err-brush)]
+                          [(break) (send dc set-pen pc-brk-pen)
+                                   (send dc set-brush pc-brk-brush)]
+                          [else    (send dc set-pen pc-pen)
+                                   (send dc set-brush pc-brush)]))
+                        (drscheme:arrow:draw-arrow dc xl ym xr ym dx dy)))))))))
+      
+      (define (debug-interactions-text-mixin super%)
+        (class super%
+          
+          (inherit run-in-evaluation-thread
+                   display-results)
+          
+          (define parent #f)
+          (define/public (set-parent! p)
+            (set! parent p))
+          
+          (super-instantiate ())
+          
+          ;; make-debug-eval-handler : (sexp -> value) -> sexp -> value
+          ;; adds debugging information to `sexp' and calls `oe'
+          (define/private (make-debug-eval-handler oe break? break)
+            (lambda (orig-exp)
+              (if (or (compiled-expression? (if (syntax? orig-exp)
+                                                (syntax-e orig-exp)
+                                                orig-exp))
+                      (not parent)
+                      (not (syntax-source orig-exp))
+                      (not (eq? (syntax-source orig-exp)
+                                (send parent get-definitions-text))))
+                  (oe orig-exp)
+                  (let loop ([exp (if (syntax? orig-exp)
+                                      orig-exp
+                                      (namespace-syntax-introduce
+                                       (datum->syntax-object #f orig-exp)))])
+                    (let ([top-e (expand-syntax-to-top-form exp)])
+                      (syntax-case top-e (begin)
+                        [(begin expr ...)
+                         ;; Found a `begin', so expand/eval each contained 
+                         ;; expression one at a time 
+                         (let i-loop ([exprs (syntax->list #'(expr ...))]
+                                      [last-one (list (void))])
+                           (cond
+                             [(null? exprs) (apply values last-one)]
+                             [else (i-loop (cdr exprs)
+                                           (call-with-values
+                                            (lambda () (loop (car exprs)))
+                                            list))]))]
+                        [_else
+                         ;; Not `begin', so proceed with normal expand and eval 
+                         (let* ([breakpoints (send parent get-breakpoints)]
+                                [pos-vec (send parent get-pos-vec)]
+                                [annotated
+                                 (annotate-stx
+                                  (expand-syntax top-e)
+                                  breakpoints
+                                  (lambda (debug-info annotated raw)
+                                    (let* ([start (syntax-position raw)]
+                                           [end (+ start (syntax-span raw) -1)])
+                                      #`(let-values ([(value-list) #f])
+                                          (if (#,break? #,start)
+                                              (set! value-list (#,break (current-continuation-marks)
+                                                                  'entry-break #,debug-info)))
+                                          (if (not value-list)
+                                              (call-with-values
+                                               (lambda () #,annotated)
+                                               (case-lambda
+                                                 [(val) (if (#,break? #,end)
+                                                            (apply values
+                                                                   (#,break (current-continuation-marks)
+                                                                      (list 'exit-break val) #,debug-info))
+                                                            val)]
+                                                 [vals (apply values
+                                                              (if (#,break? #,end)
+                                                                  (#,break (current-continuation-marks)
+                                                                     (cons 'exit-break vals) #,debug-info)
+                                                                  vals))]))
+                                              (apply values
+                                                     (if (#,break? #,end)
+                                                         (#,break (current-continuation-marks)
+                                                            (cons 'exit-break value-list) #,debug-info)
+                                                         value-list))))))
+                                  (lambda (bound binding)
+                                    ;(display-results (list bound))
+                                    (let loop ([i 0])
+                                      (when (< i (syntax-span bound))
+                                        (vector-set! pos-vec (+ i (syntax-position bound)) binding)
+                                        (loop (add1 i))))))])
+                           ;(display-results (list orig-exp))
+                           (oe annotated))]))))))
+          
+          (define/override (reset-console)
+            (super reset-console)
+            (when (and parent (send parent debug?))
+              (let ([breakpoints (send parent get-breakpoints)])
+                (run-in-evaluation-thread
+                 (lambda ()
+                   (let ([self (current-thread)]
+                         [oeh (current-exception-handler)]
+                         [err-hndlr (error-display-handler)])
+                     (error-display-handler
+                      (lambda (msg exn)
+                        (err-hndlr msg exn)
+                        (if (eq? self (current-thread))
+                            (send parent suspend oeh
+                                  (continuation-mark-set->list (exn-continuation-marks exn) debug-key)
+                                  'error)))) ; this breaks the buttons because it looks like we can resume
+                     (current-eval
+                      (make-debug-eval-handler
+                       (current-eval)
+                       (lambda (pos)
+                         (or (hash-table-get breakpoints -1)
+                             (let ([bp (hash-table-get breakpoints pos)])
+                               (if (procedure? bp)
+                                   (bp)
+                                   bp))))
+                       (lambda (ccm kind info)
+                         (let* ([debug-marks (continuation-mark-set->list ccm debug-key)])
+                           (send parent suspend oeh (cons info debug-marks) kind)))))
+                     (current-exception-handler
+                      (lambda (exn)
+                        (if (and (exn:break? exn) (send parent suspend-on-break?))
+                            (let ([marks (exn-continuation-marks exn)]
+                                  [cont (exn:break-continuation exn)])
+                              (thread (lambda ()
+                                        (raise
+                                         (make-exn:break
+                                          (string->immutable-string
+                                           (format "~a (suspending)" (exn-message exn)))
+                                          marks
+                                          cont))))
+                              (send parent suspend oeh (continuation-mark-set->list marks debug-key) 'break)
+                              (cont))
+                            (oeh exn))))))))))))
+      
+      (define (debug-unit-frame-mixin super%)
+        (class super%
+          
+          (inherit get-button-panel
+                   get-definitions-text
+                   get-interactions-text
+                   get-menu-bar
+                   break-callback
+                   reset-offer-kill)
+          
+          (super-instantiate ())
+          
+          (define breakpoints (make-hash-table))
+          (hash-table-put! breakpoints -1 #f)
+          (define resume-sem (make-semaphore))
+          (define want-suspend-on-break? #f)
+          (define want-debug? #f)
+          (define/public (debug?)
+            want-debug?)
+          (define stack-frames #f)
+          (define pos-vec (make-vector 1))
+          (define/public (suspend-on-break?)
+            want-suspend-on-break?)
+          (define/public (get-stack-frames)
+            stack-frames)
+          (define/public (get-pos-vec)
+            pos-vec)
+          (define/public (get-breakpoints)
+            breakpoints)
+          (define in-execute? #f)
+          (define/public (running-defs?)
+            in-execute?)
+          (define break-status #f)
+          (define/public (get-break-status)
+            break-status)
+          (define/public (set-break-status stat)
+            (set! break-status stat))
+          (define control-panel #f)
+          (define/public (resume)
+            (semaphore-post resume-sem))
+          
+          (define/public (get-pc)
+            (if (cons? stack-frames)
+                (let* ([src-stx (mark-source (first stack-frames))]
+                       [start (syntax-position src-stx)]
+                       [end (+ start (syntax-span src-stx) -1)])
+                  (if (cons? break-status)
+                      end
+                      start))
+                #f))
+          
+          (define/public suspend
+            (opt-lambda (break-handler frames [status #f])
+              (set! want-suspend-on-break? #f)
+              (hash-table-put! breakpoints -1 #f)
+              ;(fprintf (current-error-port) "break: ~a~n" (map expose-mark frames))
+              ;(printf "status = ~a~n" status)
+              (let ([osf stack-frames]
+                    [obs break-status])
+                (set! stack-frames frames)
+                (set! break-status status)
+                (send (get-definitions-text) scroll-to-position (get-pc))
+                (send (get-definitions-text) invalidate-bitmap-cache)
+                (with-handlers ([exn:break? break-handler])
+                  (semaphore-wait/enable-break resume-sem))
+                (begin0
+                  (if (cons? break-status)
+                      (rest break-status)
+                      #f)
+                  (set! stack-frames osf)
+                  (set! break-status obs)
+                  (send (get-definitions-text) invalidate-bitmap-cache)))))
+          
+          (define (my-execute debug?)
+            (set! want-debug? debug?)
+            (when control-panel
+              (send control-panel show #f)
+              (set! control-panel #f))
+            (when debug?
+              (make-control-panel))
+            (set! breakpoints (make-hash-table))
+            (hash-table-put! breakpoints -1 #t)
+            (set! pos-vec (make-vector (add1 (send (get-definitions-text) last-position)) #f))
+            (set! resume-sem (make-semaphore))
+            (set! want-suspend-on-break? #f)
+            (set! stack-frames #f)
+            (send (get-definitions-text) set-parent! this)
+            (send (get-interactions-text) set-parent! this)
+            (fluid-let ([in-execute? #t])
+              (super execute-callback)))
+          
+          (define/override (execute-callback)
+            (my-execute #f))
+          
+          (define debug-button
+            (make-object button%
+              ((bitmap-label-maker
+                "Debug"
+                (build-path (collection-path "skipper") "icon-small.png")) this)
+              (get-button-panel)
+              (lambda (button evt)
+                (my-execute #t))))
+          
+          (define/augment (on-close)
+            (when control-panel
+              (send control-panel show #f))
+            (inner (void) on-close))
+          
+          (define/augment (enable-evaluation)
+            (send debug-button enable #t)
+            (inner (void) enable-evaluation))
+          
+          (define/augment (disable-evaluation)
+            (send debug-button enable #f)
+            (inner (void) disable-evaluation))
+          
+          (define (make-control-panel)
+            (set! control-panel (make-object frame% "Debugging Controls" this))
+            (let ([container (make-object vertical-panel% control-panel)])
+              (make-object button%
+                "Break"
+                container
+                (lambda (button evt)
+                  (if stack-frames
+                      (bell)
+                      (begin
+                        (set! want-suspend-on-break? #t)
+                        (break-callback)
+                        (reset-offer-kill)))))
+              (make-object button%
+                "Resume";(debugger-bitmap this)
+                container
+                (lambda (button evt)
+                  (if stack-frames
+                      (semaphore-post resume-sem)
+                      (bell))))
+              (make-object button%
+                "Step"
+                container
+                (lambda (btn evt)
+                  (if stack-frames
+                      (begin
+                        (hash-table-put! breakpoints -1 #t)
+                        (semaphore-post resume-sem))
+                      (bell))))
+              (send control-panel show #t)))
+          
+          (send (get-button-panel) change-children
+                (lambda (_)
+                  (cons debug-button
+                        (remq debug-button _))))))
+      
+      (drscheme:get/extend:extend-definitions-text debug-definitions-text-mixin)
+      (drscheme:get/extend:extend-interactions-text debug-interactions-text-mixin)
+      (drscheme:get/extend:extend-unit-frame debug-unit-frame-mixin))))
\ No newline at end of file
diff --git a/collects/skipper/icon-big.png b/collects/skipper/icon-big.png
new file mode 100644
index 0000000000..4f919a1f4a
Binary files /dev/null and b/collects/skipper/icon-big.png differ
diff --git a/collects/skipper/icon-small.png b/collects/skipper/icon-small.png
new file mode 100644
index 0000000000..6d2a92389f
Binary files /dev/null and b/collects/skipper/icon-small.png differ
diff --git a/collects/skipper/info.ss b/collects/skipper/info.ss
new file mode 100644
index 0000000000..7c3f88145e
--- /dev/null
+++ b/collects/skipper/info.ss
@@ -0,0 +1,7 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Skipper")
+  #;(define tools '(("debug-tool.ss")))
+  (define blurb '("Experimental Debugger"))
+  #;(define tool-names '("Skipper"))
+  #;(define tool-icons '(("icon-big.png" "skipper")))
+)
diff --git a/collects/skipper/marks.ss b/collects/skipper/marks.ss
new file mode 100644
index 0000000000..946102c558
--- /dev/null
+++ b/collects/skipper/marks.ss
@@ -0,0 +1,186 @@
+(module marks mzscheme
+
+  (require (lib "list.ss")
+	   (lib "contract.ss")
+           (lib "my-macros.ss" "stepper" "private")
+           (lib "shared.ss" "stepper" "private"))
+
+  (define-struct full-mark-struct (source label bindings values))
+
+  ; CONTRACTS
+  (define mark? (-> ; no args  
+                 full-mark-struct?))
+  (define mark-list? (listof procedure?))
+  
+  (provide/contract 
+   ;[make-debug-info (-> any? binding-set? varref-set? any? boolean? syntax?)] ; (location tail-bound free label lifting? -> mark-stx)
+   [expose-mark (-> mark? (list/c any/c symbol? (listof (list/c identifier? any/c))))]
+   [make-top-level-mark (syntax? . -> . syntax?)]
+   [lookup-all-bindings ((identifier? . -> . boolean?) mark-list? . -> . (listof any/c))]
+   [lookup-first-binding ((identifier? . -> . boolean?) mark-list? ( -> any) . -> . any)]
+   [lookup-binding (mark-list? identifier? . -> . any)])
+  
+  (provide
+   make-debug-info
+   wcm-wrap
+   skipto-mark?
+   skipto-mark
+   strip-skiptos
+   mark-list?
+   mark-source
+   mark-bindings
+   mark-label
+   mark-binding-value
+   mark-binding-binding
+   mark-binding-set!
+   display-mark
+   all-bindings
+   #;lookup-binding-list
+   debug-key
+   extract-mark-list
+   (struct normal-breakpoint-info (mark-list kind))
+   (struct error-breakpoint-info (message))
+   (struct breakpoint-halt ())
+   (struct expression-finished (returned-value-list)))
+  
+  ; BREAKPOINT STRUCTURES
+  
+  (define-struct normal-breakpoint-info (mark-list kind))
+  (define-struct error-breakpoint-info (message))
+  (define-struct breakpoint-halt ())
+  (define-struct expression-finished (returned-value-list))
+  
+  (define-struct skipto-mark-struct ())
+  (define skipto-mark? skipto-mark-struct?)
+  (define skipto-mark (make-skipto-mark-struct))
+  (define (strip-skiptos mark-list)
+    (filter (lx (not (skipto-mark? _))) mark-list))
+  
+    
+  ; debug-key: this key will be used as a key for the continuation marks.
+  (define-struct debug-key-struct ())
+  (define debug-key (make-debug-key-struct))
+  
+  (define (extract-mark-list mark-set)
+    (strip-skiptos (continuation-mark-set->list mark-set debug-key)))
+   
+  
+  ; the 'varargs' creator is used to avoid an extra cons cell in every mark:
+  (define (make-make-full-mark-varargs source label bindings)
+    (lambda values 
+      (make-full-mark-struct source label bindings values)))
+  
+  ; see module top for type
+  (define (make-full-mark location label bindings)
+    (datum->syntax-object #'here `(lambda () (,(make-make-full-mark-varargs location label bindings)
+                                              ,@(map make-mark-binding-stx bindings)))))
+  
+  (define (mark-source mark)
+    (full-mark-struct-source (mark)))
+    
+  ; : identifier -> identifier
+  (define (make-mark-binding-stx id)
+    #`(case-lambda
+        [() #,(syntax-property id 'stepper-dont-check-for-function #t)]
+        [(v) (set! #,(syntax-property id 'stepper-dont-check-for-function #t) v)]))
+  
+  (define (mark-bindings mark)
+    (map list 
+         (full-mark-struct-bindings (mark)) 
+         (full-mark-struct-values (mark))))
+  
+  (define (mark-label mark)
+    (full-mark-struct-label (mark)))
+  
+  (define (mark-binding-value mark-binding)
+    ((cadr mark-binding)))
+  
+  (define (mark-binding-binding mark-binding)
+    (car mark-binding))
+
+  (define (mark-binding-set! mark-binding v)
+    ((cadr mark-binding) v))
+  
+  (define (expose-mark mark)
+    (let ([source (mark-source mark)]
+          [label (mark-label mark)]
+          [bindings (mark-bindings mark)])
+      (list source
+            label
+            (map (lambda (binding)
+                   (list (mark-binding-binding binding)
+                         (mark-binding-value binding)))
+                 bindings))))
+  
+  (define (display-mark mark)
+    (apply
+     string-append
+     (format "source: ~a~n" (syntax-object->datum (mark-source mark)))
+     (format "label: ~a~n" (mark-label mark))
+     (format "bindings:~n")
+     (map (lambda (binding)
+                 (format " ~a : ~a~n" (syntax-e (mark-binding-binding binding))
+                         (mark-binding-value binding)))
+               (mark-bindings mark))))
+  
+  
+  ; possible optimization: rig the mark-maker to guarantee statically that a
+  ; variable can occur at most once in a mark.  
+  
+  (define (binding-matches matcher mark)
+    (filter (lambda (binding-pair) (matcher (mark-binding-binding binding-pair))) (mark-bindings mark)))
+  
+  (define (lookup-all-bindings matcher mark-list)
+    (apply append (map (lambda (m) (binding-matches matcher m)) mark-list)))
+  
+  (define (lookup-first-binding matcher mark-list fail-thunk)
+    (let ([all-bindings (lookup-all-bindings matcher mark-list)])
+      (if (null? all-bindings)
+          (fail-thunk)
+          (car all-bindings))))
+  
+  (define (lookup-binding mark-list id)
+    (mark-binding-value
+     (lookup-first-binding (lambda (id2) (module-identifier=? id id2)) 
+                           mark-list 
+                           (lambda ()
+                             (error 'lookup-binding "variable not found in environment: ~a~n" (if (syntax? id) 
+                                                                                                  (syntax-object->datum id)
+                                                                                                  id))))))
+  
+  (define (all-bindings mark)
+    (map mark-binding-binding (mark-bindings mark)))
+  
+  (define (wcm-wrap debug-info expr)
+    (quasisyntax/loc expr (with-continuation-mark #,debug-key #,debug-info #,expr)))
+
+  
+  ; DEBUG-INFO STRUCTURES
+  
+  ;;;;;;;;;;
+  ;;
+  ;; make-debug-info builds the thunk which will be the mark at runtime.  It contains 
+  ;; a source expression and a set of binding/value pairs.
+  ;; (syntax-object BINDING-SET VARREF-SET any boolean) -> debug-info)
+  ;;
+  ;;;;;;;;;;
+     
+  (define (make-debug-info source tail-bound free-vars label lifting?)
+       (let*-2vals ([kept-vars (binding-set-varref-set-intersect tail-bound free-vars)])
+         (if lifting?
+             (let*-2vals ([let-bindings (filter (lambda (var) 
+                                                  (case (syntax-property var 'stepper-binding-type)
+                                                    ((let-bound macro-bound) #t)
+                                                    ((lambda-bound stepper-temp non-lexical) #f)
+                                                    (else (error 'make-debug-info 
+                                                                 "varref ~a's binding-type info was not recognized: ~a"
+                                                                 (syntax-e var)
+                                                                 (syntax-property var 'stepper-binding-type)))))
+                                                kept-vars)]
+                          [lifter-syms (map get-lifted-var let-bindings)])
+               (make-full-mark source label (append kept-vars lifter-syms)))
+             (make-full-mark source label kept-vars))))
+  
+  
+  (define (make-top-level-mark source-expr)
+    (make-full-mark source-expr 'top-level null)))
diff --git a/collects/slatex/doc.txt b/collects/slatex/doc.txt
new file mode 100644
index 0000000000..28580b7647
--- /dev/null
+++ b/collects/slatex/doc.txt
@@ -0,0 +1,64 @@
+_SLaTeX_
+========
+
+The use SLaTeX as a standalone program, either drag your .tex file onto
+SLaTeX (on the macintosh or windows), or type "slatex file" at the command
+prompt (under windows or X).
+
+Under the macintosh, SLaTeX will attempt to run OzTeX. If you do not have
+OzTeX installed, or use another version of LaTeX, this will fail and you
+can run your own version manually.
+
+To use SLaTeX in a program, require _slatex-wrapper.ss_:
+
+  (require (lib "slatex-wrapper.ss" "slatex"))
+
+The file slatex-wrapper.ss defines three procedures:
+
+> (slatex filename)
+
+This procedure accepts a string naming a file and runs slatex and latex on
+the file. It calls `filename->latex-filename' on `filename'.
+
+> (slatex/no-latex filename)
+
+This procedure slatex's the file named by filename, without calling
+latex. That is, it only processes the .tex file to produce the .Z files.
+It calls filename->latex-filename on `filename'.
+
+> (latex filename)
+
+This procedure `latex's the file named by filename. It calls
+filename->latex-filename on `filename'.
+
+> (filename->latex-filename filename)
+
+This procedure accepts a filename and, if that file exists, it returns
+it. If the filename appended with the suffix `.tex' exists, that filename
+is returned. Otherwise, error is called.
+
+NOTE: in order to run slatex, your TEXINPUTS environment variable
+must contain a reference to the directory in which the most recent
+version of slatex.sty lives.  That file resides by default in 
+plt/collects/slatex.
+
+_PDF-SLaTeX_
+============
+
+In addition to the slatex tools, this collection contains a parallel
+set of PDF-SLaTeX tools, which are identical except that they call
+pdf-latex rather than latex.  In particular, there is now a launcher
+called (PDF-SLaTeX/pdf-slatex), and the file slatex-wrapper.ss now
+defines pdf-slatex and pdf-latex.
+
+> (pdf-slatex filename)
+
+This procedure `slatex's the file named by filename and
+produces PDF output instead of ps output. It calls
+filename->latex-filename on `filename'.
+
+> (pdf-latex filename)
+
+This procedure `latex's the file named by filename and
+produces PDF output instead of ps output. It calls
+filename->latex-filename on `filename'.
diff --git a/collects/slatex/info.ss b/collects/slatex/info.ss
new file mode 100644
index 0000000000..584198938c
--- /dev/null
+++ b/collects/slatex/info.ss
@@ -0,0 +1,24 @@
+
+(module info (lib "infotab.ss" "setup")
+  (define doc.txt "doc.txt")
+  (define name "SLaTeX")
+
+  ;(define tools (list (list "slatex-lang.ss")))
+  ;(define tool-names (list "SLaTeX Language"))
+
+  (define help-desk-message
+    "Mz/Mr: (require (lib \"slatex-wrapper.ss\" \"slatex\"))")
+  (define blurb
+    (list "SLaTeX is a pre-processor for LaTeX that formats Scheme code. "
+	  "For more information, see "
+	  `(tt () "slatxdoc.dvi")
+	  " in the "
+	  `(tt () ,(path->string (build-path (collection-path "slatex") "slatex-code")))
+	  " directory on this machine."))
+
+  (define mzscheme-launcher-names (list "SLaTeX" "PDF SLaTeX"))
+  (define mzscheme-launcher-flags
+    (list (list "-qge" "(require (lib \"slatex-launcher.ss\" \"slatex\"))")
+          (list "-qge" "(require (lib \"pdf-slatex-launcher.ss\" \"slatex\"))")))
+
+  )
diff --git a/collects/slatex/internal-doc.txt b/collects/slatex/internal-doc.txt
new file mode 100644
index 0000000000..ddc775f936
--- /dev/null
+++ b/collects/slatex/internal-doc.txt
@@ -0,0 +1,22 @@
+This collection contains Dorai Sitaram's slatex.  Unlike prior versions of this 
+collection, it contains only the 'translated' --- that is, the mzscheme-specific
+--- version of slatex.  This means that an update to slatex can only be incorporated
+into the PLT collects world by manually running scmxlate and placing the resulting
+file into this collection.
+
+Instructions for updating to a new version of SLaTeX (for the maintainer of this 
+collection):
+
+1) Follow Dorai's instructions for generating the file 'slatex.scm' (currently,
+this involves downloading the 'scmxlate' and 'slatex' packages and loading 
+the scmxlate.scm file while (current-directory) points to the slatex 
+directory.
+
+2) place this file in plt/collects/slatex (this directory).
+3) also copy slatex.sty to plt/collects/slatex.
+
+4) (hopefully temporary?) Modify slatex.scm so that it doesn't refer to
+   slatex::slatex-error at evaluation time.
+
+5) check it in.
+
diff --git a/collects/slatex/pdf-slatex-launcher.ss b/collects/slatex/pdf-slatex-launcher.ss
new file mode 100644
index 0000000000..fc5bba43ac
--- /dev/null
+++ b/collects/slatex/pdf-slatex-launcher.ss
@@ -0,0 +1,18 @@
+
+(module pdf-slatex-launcher mzscheme
+  (require "slatex-wrapper.ss")
+
+  (define argv (current-command-line-arguments))
+  
+  (case (system-type)
+    [(macos)
+     
+     ;; set up drag and drop
+     (error 'slatex "pdf-slatex not supported under Mac OS Classic")]
+    [(windows unix macosx)
+     (when (eq? (vector) argv)
+       (error 'slatex "expected a file on the command line~n"))
+     (parameterize ([error-escape-handler exit])
+       (pdf-slatex (vector-ref argv 0)))
+     (exit)]))
+
diff --git a/collects/slatex/slatex-launcher.ss b/collects/slatex/slatex-launcher.ss
new file mode 100644
index 0000000000..c901719a83
--- /dev/null
+++ b/collects/slatex/slatex-launcher.ss
@@ -0,0 +1,23 @@
+
+(module slatex-launcher mzscheme
+  (require "slatex-wrapper.ss")
+
+  (define argv (current-command-line-arguments))
+  
+  (case (system-type)
+    [(macos)
+     
+     ;; set up drag and drop
+     (current-load slatex)
+     
+     (for-each slatex (vector->list argv))]
+    [(windows unix macosx)
+     (when (eq? (vector) argv)
+       (fprintf (current-error-port) "slatex: expected a file on the command line\n")
+       (exit 1))
+     (let ([result
+            (parameterize ([error-escape-handler exit])
+              (slatex (vector-ref argv 0)))])
+       (if result
+           (exit)
+           (exit 1)))]))
diff --git a/collects/slatex/slatex-wrapper.ss b/collects/slatex/slatex-wrapper.ss
new file mode 100644
index 0000000000..ab96ddbff8
--- /dev/null
+++ b/collects/slatex/slatex-wrapper.ss
@@ -0,0 +1,96 @@
+
+(module slatex-wrapper mzscheme
+  (require (lib "file.ss")
+	   (lib "process.ss")
+	   (lib "sendevent.ss")
+           "slatex.ss")
+
+  (provide slatex latex pdf-slatex pdf-latex slatex/no-latex)
+
+  (define (add-suffix p s)
+    (path->string
+     (bytes->path 
+      (bytes-append 
+       (path->bytes (if (string? p) (string->path p) p)) s))))
+
+  (define (filename->latex-filename input-file)
+    (let ([norm (normalize-path input-file)])
+      (cond
+        [(file-exists? norm) input-file]
+        [(file-exists? (add-suffix norm #".tex"))
+	 (add-suffix input-file #".tex")]
+        [else
+         (error 'filename->latex-filename "~e does not exist" input-file)])))
+
+  ;; latex, pdf-latex : string -> boolean
+  ;; boolean result indicates success
+  (define-values (latex pdf-latex)
+    (letrec ([meta-latex 
+              (lambda (pdf?)
+                (lambda (input-file)
+                  (let ([file (filename->latex-filename input-file)]
+                        [command-name (if pdf? 
+                                          "pdflatex"
+                                          "latex")])
+                    (case (system-type)
+                      [(macos)
+                       (when pdf?
+                         (error 'latex "do not know how to run pdflatex on ~s" (system-type)))
+                       
+                       (system "OTEX")
+                       
+                       ;; boy, wouldn't it be great if the "actv" appleevent worked for OTEX?
+                       ;;(send-event "OTEX" "misc" "acvt")
+                       (let* ([build-oztex-locations
+                               (list
+                                (lambda (x)
+                                  (build-path x
+                                              "Applications"
+                                              "OzTeX"
+                                              "OzTeX"))
+                                (lambda (x)
+                                  (build-path x
+                                              "Applications (Mac OS 9)"
+                                              "OzTeX"
+                                              "OzTeX")))]
+                              [oztex-locations
+                               (apply
+                                append
+                                (map (lambda (f) (map f (filesystem-root-list))) build-oztex-locations))]
+                              [oztex-location (ormap (lambda (x) (if (file-exists? x) x #f)) oztex-locations)])
+                         (when oztex-location
+                           (with-handlers ([void void]) ;; mzscheme cannot handle result
+                             (send-event "MACS" "aevt" "odoc" (vector 'file oztex-location)))))
+                       (send-event "OTEX" "aevt" "odoc" (vector 'file file))
+                       #t]
+                      [(windows unix macosx) ;; is this also okay for beos?
+		       (let ([latex-path (find-executable-path command-name #f)])
+			 (unless latex-path
+			   (error 'latex "could not find latex binary"))
+			 (system* latex-path file))]
+                      [else
+                       (error 'latex "do not know how to run ~s on ~s" command-name (system-type))]))))])
+      (values
+       (meta-latex #f)
+       (meta-latex #t))))
+  
+  (define-values (slatex pdf-slatex)
+    (letrec ([meta-slatex
+              (lambda (latex-fun)
+                (lambda (filename)
+                  (slatex/no-latex filename)
+                  (latex-fun filename)))])
+      (values 
+       (meta-slatex latex)
+       (meta-slatex pdf-latex))))
+
+  (define (slatex/no-latex input-file)
+    (let* ([fixed-file (filename->latex-filename input-file)]
+           [file (normalize-path fixed-file)])
+      (let-values ([(base name dir?) (split-path file)])
+        (parameterize ([current-directory
+                        (if (string? base)
+                            base
+                            (current-directory))])
+          (slatex::process-main-tex-file (path->string name)))))))
+
diff --git a/collects/slatex/slatex.ss b/collects/slatex/slatex.ss
new file mode 100644
index 0000000000..2a6ff929e2
--- /dev/null
+++ b/collects/slatex/slatex.ss
@@ -0,0 +1,2438 @@
+(module slatex mzscheme
+  (provide slatex::process-main-tex-file)
+
+(define-syntax slatex::setf
+  (lambda (so)
+    (datum->syntax-object
+      so
+      (let ((so-d (syntax-object->datum so)))
+        (let ((l (cadr so-d)) (r (caddr so-d)))
+          (if (symbol? l)
+            `(set! ,l ,r)
+            (let ((a (car l)))
+              (if (eq? a 'list-ref)
+                `(set-car! (list-tail ,@(cdr l)) ,r)
+                `(,(cond
+                    ((eq? a 'string-ref) 'string-set!)
+                    ((eq? a 'vector-ref) 'vector-set!)
+                    ((eq? a 'slatex::of) 'slatex::the-setter-for-of)
+                    (else (error "setf ~s ~s is ill-formed~%" l r)))
+                  ,@(cdr l)
+                  ,r)))))))))
+
+
+;Configured for Scheme dialect plt by scmxlate, v 0m,
+;(c) Dorai Sitaram, 
+;http://www.ccs.neu.edu/~dorai/scmxlate/scmxlate.html
+
+(define slatex::*slatex-version* "2.4z2")
+
+(define slatex::*operating-system* (if (getenv "COMSPEC") 'windows 'unix))
+
+(define-syntax slatex::defenum
+  (lambda (so)
+    (datum->syntax-object
+      so
+      (let ((so-d (syntax-object->datum so)))
+        (let loop ((z (cdr so-d)) (i 0) (r '()))
+          (if (null? z)
+            `(begin ,@r)
+            (loop
+             (cdr z)
+             (+ i 1)
+             (cons `(define ,(car z) (integer->char ,i)) r))))))))
+
+(define-syntax slatex::defrecord
+  (lambda (so)
+    (datum->syntax-object
+      so
+      (let ((so-d (syntax-object->datum so)))
+        (let ((name (cadr so-d)) (fields (cddr so-d)))
+          (let loop ((fields fields) (i 0) (r '()))
+            (if (null? fields)
+              `(begin (define ,name (lambda () (make-vector ,i))) ,@r)
+              (loop
+               (cdr fields)
+               (+ i 1)
+               (cons `(define ,(car fields) ,i) r)))))))))
+
+(define-syntax slatex::the-setter-for-of
+  (lambda (so)
+    (datum->syntax-object
+      so
+      (let ((so-d (syntax-object->datum so)))
+        (let ((r (cadr so-d))
+              (i (caddr so-d))
+              (j (cadddr so-d))
+              (z (cddddr so-d)))
+          (cond
+           ((null? z) `(vector-set! ,r ,i ,j))
+           ((and (eq? i '/) (= (length z) 1)) `(string-set! ,r ,j ,(car z)))
+           (else `(slatex::the-setter-for-of (vector-ref ,r ,i) ,j ,@z))))))))
+
+(define-syntax slatex::of
+  (lambda (so)
+    (datum->syntax-object
+      so
+      (let ((so-d (syntax-object->datum so)))
+        (let ((r (cadr so-d)) (i (caddr so-d)) (z (cdddr so-d)))
+          (cond
+           ((null? z) `(vector-ref ,r ,i))
+           ((and (eq? i '/) (= (length z) 1)) `(string-ref ,r ,(car z)))
+           (else `(slatex::of (vector-ref ,r ,i) ,@z))))))))
+
+(define slatex::ormapcdr
+  (lambda (f l)
+    (let loop ((l l)) (if (null? l) #f (or (f l) (loop (cdr l)))))))
+
+(define slatex::list-prefix?
+  (lambda (pfx l)
+    (cond
+     ((null? pfx) #t)
+     ((null? l) #f)
+     ((eqv? (car pfx) (car l)) (slatex::list-prefix? (cdr pfx) (cdr l)))
+     (else #f))))
+
+(define slatex::string-suffix?
+  (lambda (sfx s)
+    (let ((sfx-len (string-length sfx)) (s-len (string-length s)))
+      (if (> sfx-len s-len)
+        #f
+        (let loop ((i (- sfx-len 1)) (j (- s-len 1)))
+          (if (< i 0)
+            #t
+            (and (char=? (string-ref sfx i) (string-ref s j))
+                 (loop (- i 1) (- j 1)))))))))
+
+(define slatex::mapcan
+  (lambda (f l)
+    (let loop ((l l))
+      (if (null? l) '() (append! (f (car l)) (loop (cdr l)))))))
+
+(define slatex::lassoc
+  (lambda (x al eq)
+    (let loop ((al al))
+      (if (null? al)
+        #f
+        (let ((c (car al))) (if (eq (car c) x) c (loop (cdr al))))))))
+
+(define slatex::lmember
+  (lambda (x l eq)
+    (let loop ((l l)) (if (null? l) #f (if (eq (car l) x) l (loop (cdr l)))))))
+
+(define slatex::delete
+  (lambda (x l eq)
+    (let loop ((l l))
+      (cond
+       ((null? l) l)
+       ((eq (car l) x) (loop (cdr l)))
+       (else (set-cdr! l (loop (cdr l))) l)))))
+
+(define slatex::adjoin
+  (lambda (x l eq) (if (slatex::lmember x l eq) l (cons x l))))
+
+(define slatex::delete-if
+  (lambda (p s)
+    (let loop ((s s))
+      (cond
+       ((null? s) s)
+       ((p (car s)) (loop (cdr s)))
+       (else (set-cdr! s (loop (cdr s))) s)))))
+
+(define slatex::string-prefix?
+  (lambda (s1 s2 i)
+    (let loop ((j 0))
+      (if (= j i)
+        #t
+        (and (char=? (string-ref s1 j) (string-ref s2 j)) (loop (+ j 1)))))))
+
+(define slatex::sublist
+  (lambda (l i f)
+    (let loop ((l (list-tail l i)) (k i) (r '()))
+      (cond
+       ((>= k f) (reverse! r))
+       ((null? l) (slatex::slatex-error "sublist: List too small"))
+       (else (loop (cdr l) (+ k 1) (cons (car l) r)))))))
+
+(define slatex::position-char
+  (lambda (c l)
+    (let loop ((l l) (i 0))
+      (cond
+       ((null? l) #f)
+       ((char=? (car l) c) i)
+       (else (loop (cdr l) (+ i 1)))))))
+
+(define slatex::string-position-right
+  (lambda (c s)
+    (let ((n (string-length s)))
+      (let loop ((i (- n 1)))
+        (cond
+         ((< i 0) #f)
+         ((char=? (string-ref s i) c) i)
+         (else (loop (- i 1))))))))
+
+(define slatex::*return* (integer->char 13))
+
+(define slatex::*tab* (integer->char 9))
+
+(define slatex::slatex-error
+  (lambda (where . what)
+    (display "Error: ")
+    (display where)
+    (newline)
+    (for-each (lambda (v) (write v) (newline)) what)
+    (error "slatex-error")))
+
+(define slatex::exit-slatex (lambda () (exit)))
+
+(define slatex::*slatex-case-sensitive?* #t)
+
+(define slatex::keyword-tokens
+  (list
+   "=>"
+   "%"
+   "abort"
+   "and"
+   "begin"
+   "begin0"
+   "case"
+   "case-lambda"
+   "cond"
+   "define"
+   "define!"
+   "define-macro!"
+   "define-syntax"
+   "defmacro"
+   "defrec!"
+   "delay"
+   "do"
+   "else"
+   "extend-syntax"
+   "fluid-let"
+   "if"
+   "lambda"
+   "let"
+   "let*"
+   "letrec"
+   "let-syntax"
+   "letrec-syntax"
+   "or"
+   "quasiquote"
+   "quote"
+   "rec"
+   "record-case"
+   "record-evcase"
+   "recur"
+   "set!"
+   "sigma"
+   "struct"
+   "syntax"
+   "syntax-rules"
+   "trace"
+   "trace-lambda"
+   "trace-let"
+   "trace-recur"
+   "unless"
+   "unquote"
+   "unquote-splicing"
+   "untrace"
+   "when"
+   "with"))
+
+(define slatex::variable-tokens '())
+
+(define slatex::constant-tokens '())
+
+(define slatex::data-tokens '())
+
+(define slatex::special-symbols
+  (reverse
+    (reverse
+      '(("." . ".")
+        ("..." . "{\\dots}")
+        ("-" . "$-$")
+        ("1-" . "\\va{1$-$}")
+        ("-1+" . "\\va{$-$1$+$}")))))
+
+(define slatex::macro-definers
+  '("define-syntax" "syntax-rules" "defmacro" "extend-syntax" "define-macro!"))
+
+(define slatex::case-and-ilk '("case" "record-case"))
+
+(define slatex::tex-analog
+  (lambda (c)
+    (case c
+      ((#\$ #\& #\% #\# #\_) (string #\\ c))
+      ((#\{ #\}) (string #\$ #\\ c #\$))
+      ((#\\) "$\\backslash$")
+      ((#\+) "$+$")
+      ((#\*) "$\\ast$")
+      ((#\=) "$=$")
+      ((#\<) "$\\lt$")
+      ((#\>) "$\\gt$")
+      ((#\^) "\\^{}")
+      ((#\|) "$\\vert$")
+      ((#\~) "\\~{}")
+      ((#\@) "{\\atsign}")
+      ((#\") "{\\tt\\dq}")
+      (else (string c)))))
+
+(define slatex::token=?
+  (lambda (t1 t2)
+    ((if slatex::*slatex-case-sensitive?* string=? string-ci=?) t1 t2)))
+
+(define slatex::*slatex-enabled?* #t)
+
+(define slatex::*slatex-reenabler* "UNDEFINED")
+
+(define slatex::*intext-triggerers* (list "scheme"))
+
+(define slatex::*resultintext-triggerers* (list "schemeresult"))
+
+(define slatex::*display-triggerers* (list "schemedisplay"))
+
+(define slatex::*response-triggerers* (list "schemeresponse"))
+
+(define slatex::*respbox-triggerers* (list "schemeresponsebox"))
+
+(define slatex::*box-triggerers* (list "schemebox"))
+
+(define slatex::*topbox-triggerers* (list "schemetopbox"))
+
+(define slatex::*input-triggerers* (list "schemeinput"))
+
+(define slatex::*region-triggerers* (list "schemeregion"))
+
+(define slatex::*math-triggerers* '())
+
+(define slatex::*slatex-in-protected-region?* #f)
+
+(define slatex::*protected-files* '())
+
+(define slatex::*include-onlys* 'all)
+
+(define slatex::*latex?* #t)
+
+(define slatex::*slatex-separate-includes?* #f)
+
+(define slatex::*tex-calling-directory* "")
+
+(define slatex::*max-line-length* 200)
+
+(slatex::defenum
+  &void-space
+  &plain-space
+  &init-space
+  &init-plain-space
+  &paren-space
+  &bracket-space
+  &quote-space
+  &inner-space)
+
+(slatex::defenum &void-tab &set-tab &move-tab &tabbed-crg-ret &plain-crg-ret)
+
+(slatex::defenum
+  &void-notab
+  &begin-comment
+  &mid-comment
+  &begin-string
+  &mid-string
+  &end-string
+  &begin-math
+  &mid-math
+  &end-math)
+
+(slatex::defrecord
+  slatex::make-raw-line
+  slatex::=rtedge
+  slatex::=char
+  slatex::=space
+  slatex::=tab
+  slatex::=notab)
+
+(define slatex::make-line
+  (lambda ()
+    (let ((l (slatex::make-raw-line)))
+      (slatex::setf (slatex::of l slatex::=rtedge) 0)
+      (slatex::setf
+        (slatex::of l slatex::=char)
+        (make-string slatex::*max-line-length* #\space))
+      (slatex::setf
+        (slatex::of l slatex::=space)
+        (make-string slatex::*max-line-length* &void-space))
+      (slatex::setf
+        (slatex::of l slatex::=tab)
+        (make-string slatex::*max-line-length* &void-tab))
+      (slatex::setf
+        (slatex::of l slatex::=notab)
+        (make-string slatex::*max-line-length* &void-notab))
+      l)))
+
+(define slatex::*line1* (slatex::make-line))
+
+(define slatex::*line2* (slatex::make-line))
+
+(slatex::defrecord
+  slatex::make-case-frame
+  slatex::=in-ctag-tkn
+  slatex::=in-bktd-ctag-exp
+  slatex::=in-case-exp)
+
+(slatex::defrecord
+  slatex::make-bq-frame
+  slatex::=in-comma
+  slatex::=in-bq-tkn
+  slatex::=in-bktd-bq-exp)
+
+(define slatex::*latex-paragraph-mode?* 'fwd1)
+
+(define slatex::*intext?* 'fwd2)
+
+(define slatex::*code-env-spec* "UNDEFINED")
+
+(define slatex::*in* 'fwd3)
+
+(define slatex::*out* 'fwd4)
+
+(define slatex::*in-qtd-tkn* 'fwd5)
+
+(define slatex::*in-bktd-qtd-exp* 'fwd6)
+
+(define slatex::*in-mac-tkn* 'fwd7)
+
+(define slatex::*in-bktd-mac-exp* 'fwd8)
+
+(define slatex::*case-stack* 'fwd9)
+
+(define slatex::*bq-stack* 'fwd10)
+
+(define slatex::display-space
+  (lambda (s p)
+    (cond
+     ((eq? s &plain-space) (display #\space p))
+     ((eq? s &init-plain-space) (display #\space p))
+     ((eq? s &init-space) (display "\\HL " p))
+     ((eq? s &paren-space) (display "\\PRN " p))
+     ((eq? s &bracket-space) (display "\\BKT " p))
+     ((eq? s &quote-space) (display "\\QUO " p))
+     ((eq? s &inner-space) (display "\\ " p)))))
+
+(define slatex::display-tab
+  (lambda (tab p)
+    (cond
+     ((eq? tab &set-tab) (display "\\=" p))
+     ((eq? tab &move-tab) (display "\\>" p)))))
+
+(define slatex::display-notab
+  (lambda (notab p)
+    (cond
+     ((eq? notab &begin-string) (display "\\dt{" p))
+     ((eq? notab &end-string) (display "}" p)))))
+
+(define slatex::prim-data-token?
+  (lambda (token)
+    (or (char=? (string-ref token 0) #\#) (string->number token))))
+
+(define slatex::set-keyword
+  (lambda (x)
+    (if (not (slatex::lmember x slatex::keyword-tokens slatex::token=?))
+      (begin
+        (set! slatex::constant-tokens
+          (slatex::delete x slatex::constant-tokens slatex::token=?))
+        (set! slatex::variable-tokens
+          (slatex::delete x slatex::variable-tokens slatex::token=?))
+        (set! slatex::data-tokens
+          (slatex::delete x slatex::data-tokens slatex::token=?))
+        (set! slatex::keyword-tokens (cons x slatex::keyword-tokens))))))
+
+(define slatex::set-constant
+  (lambda (x)
+    (if (not (slatex::lmember x slatex::constant-tokens slatex::token=?))
+      (begin
+        (set! slatex::keyword-tokens
+          (slatex::delete x slatex::keyword-tokens slatex::token=?))
+        (set! slatex::variable-tokens
+          (slatex::delete x slatex::variable-tokens slatex::token=?))
+        (set! slatex::data-tokens
+          (slatex::delete x slatex::data-tokens slatex::token=?))
+        (set! slatex::constant-tokens (cons x slatex::constant-tokens))))))
+
+(define slatex::set-variable
+  (lambda (x)
+    (if (not (slatex::lmember x slatex::variable-tokens slatex::token=?))
+      (begin
+        (set! slatex::keyword-tokens
+          (slatex::delete x slatex::keyword-tokens slatex::token=?))
+        (set! slatex::constant-tokens
+          (slatex::delete x slatex::constant-tokens slatex::token=?))
+        (set! slatex::data-tokens
+          (slatex::delete x slatex::data-tokens slatex::token=?))
+        (set! slatex::variable-tokens (cons x slatex::variable-tokens))))))
+
+(define slatex::set-data
+  (lambda (x)
+    (if (not (slatex::lmember x slatex::data-tokens slatex::token=?))
+      (begin
+        (set! slatex::keyword-tokens
+          (slatex::delete x slatex::keyword-tokens slatex::token=?))
+        (set! slatex::constant-tokens
+          (slatex::delete x slatex::constant-tokens slatex::token=?))
+        (set! slatex::variable-tokens
+          (slatex::delete x slatex::variable-tokens slatex::token=?))
+        (set! slatex::data-tokens (cons x slatex::data-tokens))))))
+
+(define slatex::set-special-symbol
+  (lambda (x transl)
+    (let ((c (slatex::lassoc x slatex::special-symbols slatex::token=?)))
+      (if c
+        (set-cdr! c transl)
+        (set! slatex::special-symbols
+          (cons (cons x transl) slatex::special-symbols))))))
+
+(define slatex::unset-special-symbol
+  (lambda (x)
+    (set! slatex::special-symbols
+      (slatex::delete-if
+        (lambda (c) (slatex::token=? (car c) x))
+        slatex::special-symbols))))
+
+(define slatex::texify (lambda (s) (list->string (slatex::texify-aux s))))
+
+(define slatex::texify-data
+  (lambda (s)
+    (let loop ((l (slatex::texify-aux s)) (r '()))
+      (if (null? l)
+        (list->string (reverse! r))
+        (let ((c (car l)))
+          (loop
+           (cdr l)
+           (if (char=? c #\-) (append! (list #\$ c #\$) r) (cons c r))))))))
+
+(define slatex::texify-aux
+  (let ((arrow (string->list "-$>$"))
+        (em-dash (string->list "---"))
+        (en-dash (string->list "--"))
+        (arrow2 (string->list "$\\to$"))
+        (em-dash-2 (string->list "${-}{-}{-}$"))
+        (en-dash-2 (string->list "${-}{-}$")))
+    (lambda (s)
+      (let ((texified-sl
+              (slatex::mapcan
+                (lambda (c) (string->list (slatex::tex-analog c)))
+                (string->list s))))
+        (let loop ((d texified-sl))
+          (cond
+           ((null? d) #f)
+           ((slatex::list-prefix? arrow d)
+            (let ((d2 (list-tail d 4)))
+              (set-car! d (car arrow2))
+              (set-cdr! d (append (cdr arrow2) d2))
+              (loop d2)))
+           ((slatex::list-prefix? em-dash d)
+            (let ((d2 (list-tail d 3)))
+              (set-car! d (car em-dash-2))
+              (set-cdr! d (append (cdr em-dash-2) d2))
+              (loop d2)))
+           ((slatex::list-prefix? en-dash d)
+            (let ((d2 (list-tail d 2)))
+              (set-car! d (car en-dash-2))
+              (set-cdr! d (append (cdr en-dash-2) d2))
+              (loop d2)))
+           (else (loop (cdr d)))))
+        texified-sl))))
+
+(define slatex::display-begin-sequence
+  (lambda (out)
+    (if (or slatex::*intext?* (not slatex::*latex?*))
+      (begin
+        (display "\\" out)
+        (display slatex::*code-env-spec* out)
+        (newline out))
+      (begin
+        (display "\\begin{" out)
+        (display slatex::*code-env-spec* out)
+        (display "}%" out)
+        (newline out)))))
+
+(define slatex::display-end-sequence
+  (lambda (out)
+    (cond
+     (slatex::*intext?*
+      (display "\\end" out)
+      (display slatex::*code-env-spec* out)
+      (newline out))
+     (slatex::*latex?*
+      (display "\\end{" out)
+      (display slatex::*code-env-spec* out)
+      (display "}" out)
+      (newline out))
+     (else
+      (display "\\end" out)
+      (display slatex::*code-env-spec* out)
+      (newline out)))))
+
+(define slatex::display-tex-char
+  (lambda (c p) (display (if (char? c) (slatex::tex-analog c) c) p)))
+
+(define slatex::display-token
+  (lambda (s typ p)
+    (cond
+     ((eq? typ 'syntax)
+      (display "\\sy{" p)
+      (display (slatex::texify s) p)
+      (display "}" p))
+     ((eq? typ 'variable)
+      (display "\\va{" p)
+      (display (slatex::texify s) p)
+      (display "}" p))
+     ((eq? typ 'constant)
+      (display "\\cn{" p)
+      (display (slatex::texify s) p)
+      (display "}" p))
+     ((eq? typ 'data)
+      (display "\\dt{" p)
+      (display (slatex::texify-data s) p)
+      (display "}" p))
+     (else
+      (slatex::slatex-error
+        'slatex::display-token
+        "Unknown token type"
+        typ)))))
+
+(define slatex::get-line
+  (let ((curr-notab &void-notab))
+    (lambda (line)
+      (let ((graphic-char-seen? #f))
+        (let loop ((i 0))
+          (let ((c (read-char slatex::*in*)))
+            (cond
+             (graphic-char-seen? (void))
+             ((or (eof-object? c)
+                  (char=? c slatex::*return*)
+                  (char=? c #\newline)
+                  (char=? c #\space)
+                  (char=? c slatex::*tab*))
+              (void))
+             (else (set! graphic-char-seen? #t)))
+            (cond
+             ((eof-object? c)
+              (cond
+               ((eq? curr-notab &mid-string)
+                (if (> i 0)
+                  (slatex::setf
+                    (slatex::of line slatex::=notab / (- i 1))
+                    &end-string)))
+               ((eq? curr-notab &mid-comment) (set! curr-notab &void-notab))
+               ((eq? curr-notab &mid-math)
+                (slatex::slatex-error
+                  'slatex::get-line
+                  "Found eof inside math")))
+              (slatex::setf (slatex::of line slatex::=char / i) #\newline)
+              (slatex::setf (slatex::of line slatex::=space / i) &void-space)
+              (slatex::setf (slatex::of line slatex::=tab / i) &void-tab)
+              (slatex::setf (slatex::of line slatex::=notab / i) &void-notab)
+              (slatex::setf (slatex::of line slatex::=rtedge) i)
+              (if (eq? (slatex::of line slatex::=notab / 0) &mid-string)
+                (slatex::setf
+                  (slatex::of line slatex::=notab / 0)
+                  &begin-string))
+              (if (= i 0) #f #t))
+             ((or (char=? c slatex::*return*) (char=? c #\newline))
+              (if (and (memv
+                        slatex::*operating-system*
+                        '(dos windows os2 os2fat))
+                       (char=? c slatex::*return*))
+                (if (char=? (peek-char slatex::*in*) #\newline)
+                  (read-char slatex::*in*)))
+              (slatex::setf (slatex::of line slatex::=notab / i) &void-notab)
+              (cond
+               ((eq? curr-notab &mid-string)
+                (slatex::setf
+                  (slatex::of line slatex::=notab / i)
+                  &end-string))
+               ((eq? curr-notab &mid-comment) (set! curr-notab &void-notab))
+               ((eq? curr-notab &mid-math)
+                (slatex::slatex-error
+                  'slatex::get-line
+                  "Sorry, you can't split "
+                  "math formulas across lines in Scheme code")))
+              (slatex::setf (slatex::of line slatex::=char / i) #\newline)
+              (slatex::setf (slatex::of line slatex::=space / i) &void-space)
+              (slatex::setf
+                (slatex::of line slatex::=tab / i)
+                (cond
+                 ((eof-object? (peek-char slatex::*in*)) &plain-crg-ret)
+                 (slatex::*intext?* &plain-crg-ret)
+                 (else &tabbed-crg-ret)))
+              (slatex::setf (slatex::of line slatex::=rtedge) i)
+              (if (eq? (slatex::of line slatex::=notab / 0) &mid-string)
+                (slatex::setf
+                  (slatex::of line slatex::=notab / 0)
+                  &begin-string))
+              #t)
+             ((eq? curr-notab &mid-comment)
+              (slatex::setf (slatex::of line slatex::=char / i) c)
+              (slatex::setf
+                (slatex::of line slatex::=space / i)
+                (cond
+                 ((char=? c #\space) &plain-space)
+                 ((char=? c slatex::*tab*) &plain-space)
+                 (else &void-space)))
+              (slatex::setf (slatex::of line slatex::=tab / i) &void-tab)
+              (slatex::setf (slatex::of line slatex::=notab / i) &mid-comment)
+              (loop (+ i 1)))
+             ((char=? c #\\)
+              (slatex::setf (slatex::of line slatex::=char / i) c)
+              (slatex::setf (slatex::of line slatex::=space / i) &void-space)
+              (slatex::setf (slatex::of line slatex::=tab / i) &void-tab)
+              (slatex::setf (slatex::of line slatex::=notab / i) curr-notab)
+              (let ((i+1 (+ i 1)) (c+1 (read-char slatex::*in*)))
+                (if (char=? c+1 slatex::*tab*) (set! c+1 #\space))
+                (slatex::setf (slatex::of line slatex::=char / i+1) c+1)
+                (slatex::setf
+                  (slatex::of line slatex::=space / i+1)
+                  (if (char=? c+1 #\space) &plain-space &void-space))
+                (slatex::setf (slatex::of line slatex::=tab / i+1) &void-tab)
+                (slatex::setf
+                  (slatex::of line slatex::=notab / i+1)
+                  curr-notab)
+                (loop (+ i+1 1))))
+             ((eq? curr-notab &mid-math)
+              (if (char=? c slatex::*tab*) (set! c #\space))
+              (slatex::setf
+                (slatex::of line slatex::=space / i)
+                (if (char=? c #\space) &plain-space &void-space))
+              (slatex::setf (slatex::of line slatex::=tab / i) &void-tab)
+              (cond
+               ((memv c slatex::*math-triggerers*)
+                (slatex::setf (slatex::of line slatex::=char / i) #\$)
+                (slatex::setf (slatex::of line slatex::=notab / i) &end-math)
+                (slatex::setf curr-notab &void-notab))
+               (else
+                (slatex::setf (slatex::of line slatex::=char / i) c)
+                (slatex::setf (slatex::of line slatex::=notab / i) &mid-math)))
+              (loop (+ i 1)))
+             ((eq? curr-notab &mid-string)
+              (if (char=? c slatex::*tab*) (set! c #\space))
+              (slatex::setf (slatex::of line slatex::=char / i) c)
+              (slatex::setf
+                (slatex::of line slatex::=space / i)
+                (if (char=? c #\space) &inner-space &void-space))
+              (slatex::setf (slatex::of line slatex::=tab / i) &void-tab)
+              (slatex::setf
+                (slatex::of line slatex::=notab / i)
+                (cond
+                 ((char=? c #\") (set! curr-notab &void-notab) &end-string)
+                 (else &mid-string)))
+              (loop (+ i 1)))
+             ((char=? c #\space)
+              (slatex::setf (slatex::of line slatex::=char / i) c)
+              (slatex::setf
+                (slatex::of line slatex::=space / i)
+                (cond
+                 (slatex::*intext?* &plain-space)
+                 (graphic-char-seen? &inner-space)
+                 (else &init-space)))
+              (slatex::setf (slatex::of line slatex::=tab / i) &void-tab)
+              (slatex::setf (slatex::of line slatex::=notab / i) &void-notab)
+              (loop (+ i 1)))
+             ((char=? c slatex::*tab*)
+              (let loop1 ((i i) (j 0))
+                (if (< j 8)
+                  (begin
+                    (slatex::setf (slatex::of line slatex::=char / i) #\space)
+                    (slatex::setf
+                      (slatex::of line slatex::=space / i)
+                      (cond
+                       (slatex::*intext?* &plain-space)
+                       (graphic-char-seen? &inner-space)
+                       (else &init-space)))
+                    (slatex::setf (slatex::of line slatex::=tab / i) &void-tab)
+                    (slatex::setf
+                      (slatex::of line slatex::=notab / i)
+                      &void-notab)
+                    (loop1 (+ i 1) (+ j 1)))))
+              (loop (+ i 8)))
+             ((char=? c #\")
+              (slatex::setf (slatex::of line slatex::=char / i) c)
+              (slatex::setf (slatex::of line slatex::=space / i) &void-space)
+              (slatex::setf (slatex::of line slatex::=tab / i) &void-tab)
+              (slatex::setf (slatex::of line slatex::=notab / i) &begin-string)
+              (set! curr-notab &mid-string)
+              (loop (+ i 1)))
+             ((char=? c #\;)
+              (slatex::setf (slatex::of line slatex::=char / i) c)
+              (slatex::setf (slatex::of line slatex::=space / i) &void-space)
+              (slatex::setf (slatex::of line slatex::=tab / i) &void-tab)
+              (slatex::setf
+                (slatex::of line slatex::=notab / i)
+                &begin-comment)
+              (set! curr-notab &mid-comment)
+              (loop (+ i 1)))
+             ((memv c slatex::*math-triggerers*)
+              (slatex::setf (slatex::of line slatex::=char / i) #\$)
+              (slatex::setf (slatex::of line slatex::=space / i) &void-space)
+              (slatex::setf (slatex::of line slatex::=tab / i) &void-tab)
+              (slatex::setf (slatex::of line slatex::=notab / i) &begin-math)
+              (set! curr-notab &mid-math)
+              (loop (+ i 1)))
+             (else
+              (slatex::setf (slatex::of line slatex::=char / i) c)
+              (slatex::setf (slatex::of line slatex::=space / i) &void-space)
+              (slatex::setf (slatex::of line slatex::=tab / i) &void-tab)
+              (slatex::setf (slatex::of line slatex::=notab / i) &void-notab)
+              (loop (+ i 1))))))))))
+
+(define slatex::peephole-adjust
+  (lambda (curr prev)
+    (if (or (slatex::blank-line? curr) (slatex::flush-comment-line? curr))
+      (if (not slatex::*latex-paragraph-mode?*)
+        (begin
+          (set! slatex::*latex-paragraph-mode?* #t)
+          (if (not slatex::*intext?*)
+            (begin
+              (slatex::remove-some-tabs prev 0)
+              (let ((prev-rtedge (slatex::of prev slatex::=rtedge)))
+                (if (eq?
+                     (slatex::of prev slatex::=tab / prev-rtedge)
+                     &tabbed-crg-ret)
+                  (slatex::setf
+                    (slatex::of
+                      prev
+                      slatex::=tab
+                      /
+                      (slatex::of prev slatex::=rtedge))
+                    &plain-crg-ret)))))))
+      (begin
+        (if slatex::*latex-paragraph-mode?*
+          (set! slatex::*latex-paragraph-mode?* #f)
+          (if (not slatex::*intext?*)
+            (let ((remove-tabs-from #f))
+              (let loop ((i 0))
+                (cond
+                 ((char=? (slatex::of curr slatex::=char / i) #\newline)
+                  (set! remove-tabs-from i))
+                 ((char=? (slatex::of prev slatex::=char / i) #\newline)
+                  (set! remove-tabs-from #f))
+                 ((eq? (slatex::of curr slatex::=space / i) &init-space)
+                  (if (eq? (slatex::of prev slatex::=notab / i) &void-notab)
+                    (begin
+                      (cond
+                       ((or (char=? (slatex::of prev slatex::=char / i) #\()
+                            (eq?
+                             (slatex::of prev slatex::=space / i)
+                             &paren-space))
+                        (slatex::setf
+                          (slatex::of curr slatex::=space / i)
+                          &paren-space))
+                       ((or (char=? (slatex::of prev slatex::=char / i) #\[)
+                            (eq?
+                             (slatex::of prev slatex::=space / i)
+                             &bracket-space))
+                        (slatex::setf
+                          (slatex::of curr slatex::=space / i)
+                          &bracket-space))
+                       ((or (memv
+                             (slatex::of prev slatex::=char / i)
+                             '(#\' #\` #\,))
+                            (eq?
+                             (slatex::of prev slatex::=space / i)
+                             &quote-space))
+                        (slatex::setf
+                          (slatex::of curr slatex::=space / i)
+                          &quote-space)))
+                      (if (memq
+                           (slatex::of prev slatex::=tab / i)
+                           (list &set-tab &move-tab))
+                        (slatex::setf
+                          (slatex::of curr slatex::=tab / i)
+                          &move-tab))))
+                  (loop (+ i 1)))
+                 ((= i 0) (set! remove-tabs-from 0))
+                 ((not (eq? (slatex::of prev slatex::=tab / i) &void-tab))
+                  (set! remove-tabs-from (+ i 1))
+                  (if (memq
+                       (slatex::of prev slatex::=tab / i)
+                       (list &set-tab &move-tab))
+                    (slatex::setf
+                      (slatex::of curr slatex::=tab / i)
+                      &move-tab)))
+                 ((memq
+                   (slatex::of prev slatex::=space / i)
+                   (list
+                    &init-space
+                    &init-plain-space
+                    &paren-space
+                    &bracket-space
+                    &quote-space))
+                  (set! remove-tabs-from (+ i 1)))
+                 ((and (char=?
+                         (slatex::of prev slatex::=char / (- i 1))
+                         #\space)
+                       (eq?
+                        (slatex::of prev slatex::=notab / (- i 1))
+                        &void-notab))
+                  (set! remove-tabs-from (+ i 1))
+                  (slatex::setf (slatex::of prev slatex::=tab / i) &set-tab)
+                  (slatex::setf (slatex::of curr slatex::=tab / i) &move-tab))
+                 (else
+                  (set! remove-tabs-from (+ i 1))
+                  (let loop1 ((j (- i 1)))
+                    (cond
+                     ((<= j 0) 'exit-loop1)
+                     ((not (eq? (slatex::of curr slatex::=tab / j) &void-tab))
+                      'exit-loop1)
+                     ((memq
+                       (slatex::of curr slatex::=space / j)
+                       (list &paren-space &bracket-space &quote-space))
+                      (loop1 (- j 1)))
+                     ((or (not
+                           (eq?
+                            (slatex::of prev slatex::=notab / j)
+                            &void-notab))
+                          (char=? (slatex::of prev slatex::=char / j) #\space))
+                      (let ((k (+ j 1)))
+                        (if (not
+                             (memq
+                              (slatex::of prev slatex::=notab / k)
+                              (list
+                               &mid-comment
+                               &mid-math
+                               &end-math
+                               &mid-string
+                               &end-string)))
+                          (begin
+                            (if (eq?
+                                 (slatex::of prev slatex::=tab / k)
+                                 &void-tab)
+                              (slatex::setf
+                                (slatex::of prev slatex::=tab / k)
+                                &set-tab))
+                            (slatex::setf
+                              (slatex::of curr slatex::=tab / k)
+                              &move-tab)))))
+                     (else 'anything-else?))))))
+              (slatex::remove-some-tabs prev remove-tabs-from))))
+        (if (not slatex::*intext?*) (slatex::add-some-tabs curr))
+        (slatex::clean-init-spaces curr)
+        (slatex::clean-inner-spaces curr)))))
+
+(define slatex::add-some-tabs
+  (lambda (line)
+    (let loop ((i 1) (succ-parens? #f))
+      (let ((c (slatex::of line slatex::=char / i)))
+        (cond
+         ((char=? c #\newline) 'exit-loop)
+         ((not (eq? (slatex::of line slatex::=notab / i) &void-notab))
+          (loop (+ i 1) #f))
+         ((char=? c #\[)
+          (if (eq? (slatex::of line slatex::=tab / i) &void-tab)
+            (slatex::setf (slatex::of line slatex::=tab / i) &set-tab))
+          (loop (+ i 1) #f))
+         ((char=? c #\()
+          (if (eq? (slatex::of line slatex::=tab / i) &void-tab)
+            (if (not succ-parens?)
+              (slatex::setf (slatex::of line slatex::=tab / i) &set-tab)))
+          (loop (+ i 1) #t))
+         (else (loop (+ i 1) #f)))))))
+
+(define slatex::remove-some-tabs
+  (lambda (line i)
+    (if i
+      (let loop ((i i))
+        (cond
+         ((char=? (slatex::of line slatex::=char / i) #\newline) 'exit)
+         ((eq? (slatex::of line slatex::=tab / i) &set-tab)
+          (slatex::setf (slatex::of line slatex::=tab / i) &void-tab)
+          (loop (+ i 1)))
+         (else (loop (+ i 1))))))))
+
+(define slatex::clean-init-spaces
+  (lambda (line)
+    (let loop ((i (slatex::of line slatex::=rtedge)))
+      (cond
+       ((< i 0) 'exit-loop)
+       ((eq? (slatex::of line slatex::=tab / i) &move-tab)
+        (let loop1 ((i (- i 1)))
+          (cond
+           ((< i 0) 'exit-loop1)
+           ((memq
+             (slatex::of line slatex::=space / i)
+             (list &init-space &paren-space &bracket-space &quote-space))
+            (slatex::setf
+              (slatex::of line slatex::=space / i)
+              &init-plain-space)
+            (loop1 (- i 1)))
+           (else (loop1 (- i 1))))))
+       (else (loop (- i 1)))))))
+
+(define slatex::clean-inner-spaces
+  (lambda (line)
+    (let loop ((i 0) (succ-inner-spaces? #f))
+      (cond
+       ((char=? (slatex::of line slatex::=char / i) #\newline) 'exit-loop)
+       ((eq? (slatex::of line slatex::=space / i) &inner-space)
+        (if (not succ-inner-spaces?)
+          (slatex::setf (slatex::of line slatex::=space / i) &plain-space))
+        (loop (+ i 1) #t))
+       (else (loop (+ i 1) #f))))))
+
+(define slatex::blank-line?
+  (lambda (line)
+    (let loop ((i 0))
+      (let ((c (slatex::of line slatex::=char / i)))
+        (cond
+         ((char=? c #\space)
+          (if (eq? (slatex::of line slatex::=notab / i) &void-notab)
+            (loop (+ i 1))
+            #f))
+         ((char=? c #\newline)
+          (let loop1 ((j (- i 1)))
+            (if (not (<= j 0))
+              (begin
+                (slatex::setf (slatex::of line slatex::=space / i) &void-space)
+                (loop1 (- j 1)))))
+          #t)
+         (else #f))))))
+
+(define slatex::flush-comment-line?
+  (lambda (line)
+    (and (char=? (slatex::of line slatex::=char / 0) #\;)
+         (eq? (slatex::of line slatex::=notab / 0) &begin-comment)
+         (not (char=? (slatex::of line slatex::=char / 1) #\;)))))
+
+(define slatex::display-tex-line
+  (lambda (line)
+    (cond
+     (else
+      (let loop ((i (if (slatex::flush-comment-line? line) 1 0)))
+        (let ((c (slatex::of line slatex::=char / i)))
+          (if (char=? c #\newline)
+            (if (not (eq? (slatex::of line slatex::=tab / i) &void-tab))
+              (newline slatex::*out*))
+            (begin (write-char c slatex::*out*) (loop (+ i 1))))))))))
+
+(define slatex::display-scm-line
+  (lambda (line)
+    (let loop ((i 0))
+      (let ((c (slatex::of line slatex::=char / i)))
+        (cond
+         ((char=? c #\newline)
+          (let ((notab (slatex::of line slatex::=notab / i))
+                (tab (slatex::of line slatex::=tab / i)))
+            (if (eq? notab &end-string) (display "}" slatex::*out*))
+            (cond
+             ((eq? tab &tabbed-crg-ret)
+              (display "\\\\%" slatex::*out*)
+              (newline slatex::*out*))
+             ((eq? tab &plain-crg-ret) (newline slatex::*out*))
+             ((eq? tab &void-tab)
+              (write-char #\% slatex::*out*)
+              (newline slatex::*out*)))))
+         ((eq? (slatex::of line slatex::=notab / i) &begin-comment)
+          (slatex::display-tab
+            (slatex::of line slatex::=tab / i)
+            slatex::*out*)
+          (write-char c slatex::*out*)
+          (loop (+ i 1)))
+         ((eq? (slatex::of line slatex::=notab / i) &mid-comment)
+          (write-char c slatex::*out*)
+          (loop (+ i 1)))
+         ((eq? (slatex::of line slatex::=notab / i) &begin-string)
+          (slatex::display-tab
+            (slatex::of line slatex::=tab / i)
+            slatex::*out*)
+          (display "\\dt{" slatex::*out*)
+          (if (char=? c #\space)
+            (slatex::display-space
+              (slatex::of line slatex::=space / i)
+              slatex::*out*)
+            (slatex::display-tex-char c slatex::*out*))
+          (loop (+ i 1)))
+         ((eq? (slatex::of line slatex::=notab / i) &mid-string)
+          (if (char=? c #\space)
+            (slatex::display-space
+              (slatex::of line slatex::=space / i)
+              slatex::*out*)
+            (slatex::display-tex-char c slatex::*out*))
+          (loop (+ i 1)))
+         ((eq? (slatex::of line slatex::=notab / i) &end-string)
+          (if (char=? c #\space)
+            (slatex::display-space
+              (slatex::of line slatex::=space / i)
+              slatex::*out*)
+            (slatex::display-tex-char c slatex::*out*))
+          (write-char #\} slatex::*out*)
+          (if slatex::*in-qtd-tkn*
+            (set! slatex::*in-qtd-tkn* #f)
+            (if slatex::*in-mac-tkn* (set! slatex::*in-mac-tkn* #f)))
+          (loop (+ i 1)))
+         ((eq? (slatex::of line slatex::=notab / i) &begin-math)
+          (slatex::display-tab
+            (slatex::of line slatex::=tab / i)
+            slatex::*out*)
+          (write-char c slatex::*out*)
+          (loop (+ i 1)))
+         ((eq? (slatex::of line slatex::=notab / i) &mid-math)
+          (write-char c slatex::*out*)
+          (loop (+ i 1)))
+         ((eq? (slatex::of line slatex::=notab / i) &end-math)
+          (write-char c slatex::*out*)
+          (if slatex::*in-qtd-tkn*
+            (set! slatex::*in-qtd-tkn* #f)
+            (if slatex::*in-mac-tkn* (set! slatex::*in-mac-tkn* #f)))
+          (loop (+ i 1)))
+         ((char=? c #\space)
+          (slatex::display-tab
+            (slatex::of line slatex::=tab / i)
+            slatex::*out*)
+          (slatex::display-space
+            (slatex::of line slatex::=space / i)
+            slatex::*out*)
+          (loop (+ i 1)))
+         ((char=? c #\')
+          (slatex::display-tab
+            (slatex::of line slatex::=tab / i)
+            slatex::*out*)
+          (write-char c slatex::*out*)
+          (if (or slatex::*in-qtd-tkn*
+                  (> slatex::*in-bktd-qtd-exp* 0)
+                  (and (pair? slatex::*bq-stack*)
+                       (not
+                        (slatex::of
+                          (car slatex::*bq-stack*)
+                          slatex::=in-comma))))
+            #f
+            (set! slatex::*in-qtd-tkn* #t))
+          (loop (+ i 1)))
+         ((char=? c #\`)
+          (slatex::display-tab
+            (slatex::of line slatex::=tab / i)
+            slatex::*out*)
+          (write-char c slatex::*out*)
+          (if (or (null? slatex::*bq-stack*)
+                  (slatex::of (car slatex::*bq-stack*) slatex::=in-comma))
+            (set! slatex::*bq-stack*
+              (cons
+               (let ((f (slatex::make-bq-frame)))
+                 (slatex::setf (slatex::of f slatex::=in-comma) #f)
+                 (slatex::setf (slatex::of f slatex::=in-bq-tkn) #t)
+                 (slatex::setf (slatex::of f slatex::=in-bktd-bq-exp) 0)
+                 f)
+               slatex::*bq-stack*)))
+          (loop (+ i 1)))
+         ((char=? c #\,)
+          (slatex::display-tab
+            (slatex::of line slatex::=tab / i)
+            slatex::*out*)
+          (write-char c slatex::*out*)
+          (if (not
+               (or (null? slatex::*bq-stack*)
+                   (slatex::of (car slatex::*bq-stack*) slatex::=in-comma)))
+            (set! slatex::*bq-stack*
+              (cons
+               (let ((f (slatex::make-bq-frame)))
+                 (slatex::setf (slatex::of f slatex::=in-comma) #t)
+                 (slatex::setf (slatex::of f slatex::=in-bq-tkn) #t)
+                 (slatex::setf (slatex::of f slatex::=in-bktd-bq-exp) 0)
+                 f)
+               slatex::*bq-stack*)))
+          (if (char=? (slatex::of line slatex::=char / (+ i 1)) #\@)
+            (begin (slatex::display-tex-char #\@ slatex::*out*) (loop (+ 2 i)))
+            (loop (+ i 1))))
+         ((memv c '(#\( #\[))
+          (slatex::display-tab
+            (slatex::of line slatex::=tab / i)
+            slatex::*out*)
+          (write-char c slatex::*out*)
+          (cond
+           (slatex::*in-qtd-tkn*
+            (set! slatex::*in-qtd-tkn* #f)
+            (set! slatex::*in-bktd-qtd-exp* 1))
+           ((> slatex::*in-bktd-qtd-exp* 0)
+            (set! slatex::*in-bktd-qtd-exp* (+ slatex::*in-bktd-qtd-exp* 1))))
+          (cond
+           (slatex::*in-mac-tkn*
+            (set! slatex::*in-mac-tkn* #f)
+            (set! slatex::*in-bktd-mac-exp* 1))
+           ((> slatex::*in-bktd-mac-exp* 0)
+            (set! slatex::*in-bktd-mac-exp* (+ slatex::*in-bktd-mac-exp* 1))))
+          (if (not (null? slatex::*bq-stack*))
+            (let ((top (car slatex::*bq-stack*)))
+              (cond
+               ((slatex::of top slatex::=in-bq-tkn)
+                (slatex::setf (slatex::of top slatex::=in-bq-tkn) #f)
+                (slatex::setf (slatex::of top slatex::=in-bktd-bq-exp) 1))
+               ((> (slatex::of top slatex::=in-bktd-bq-exp) 0)
+                (slatex::setf
+                  (slatex::of top slatex::=in-bktd-bq-exp)
+                  (+ (slatex::of top slatex::=in-bktd-bq-exp) 1))))))
+          (if (not (null? slatex::*case-stack*))
+            (let ((top (car slatex::*case-stack*)))
+              (cond
+               ((slatex::of top slatex::=in-ctag-tkn)
+                (slatex::setf (slatex::of top slatex::=in-ctag-tkn) #f)
+                (slatex::setf (slatex::of top slatex::=in-bktd-ctag-exp) 1))
+               ((> (slatex::of top slatex::=in-bktd-ctag-exp) 0)
+                (slatex::setf
+                  (slatex::of top slatex::=in-bktd-ctag-exp)
+                  (+ (slatex::of top slatex::=in-bktd-ctag-exp) 1)))
+               ((> (slatex::of top slatex::=in-case-exp) 0)
+                (slatex::setf
+                  (slatex::of top slatex::=in-case-exp)
+                  (+ (slatex::of top slatex::=in-case-exp) 1))
+                (if (= (slatex::of top slatex::=in-case-exp) 2)
+                  (set! slatex::*in-qtd-tkn* #t))))))
+          (loop (+ i 1)))
+         ((memv c '(#\) #\]))
+          (slatex::display-tab
+            (slatex::of line slatex::=tab / i)
+            slatex::*out*)
+          (write-char c slatex::*out*)
+          (if (> slatex::*in-bktd-qtd-exp* 0)
+            (set! slatex::*in-bktd-qtd-exp* (- slatex::*in-bktd-qtd-exp* 1)))
+          (if (> slatex::*in-bktd-mac-exp* 0)
+            (set! slatex::*in-bktd-mac-exp* (- slatex::*in-bktd-mac-exp* 1)))
+          (if (not (null? slatex::*bq-stack*))
+            (let ((top (car slatex::*bq-stack*)))
+              (if (> (slatex::of top slatex::=in-bktd-bq-exp) 0)
+                (begin
+                  (slatex::setf
+                    (slatex::of top slatex::=in-bktd-bq-exp)
+                    (- (slatex::of top slatex::=in-bktd-bq-exp) 1))
+                  (if (= (slatex::of top slatex::=in-bktd-bq-exp) 0)
+                    (set! slatex::*bq-stack* (cdr slatex::*bq-stack*)))))))
+          (let loop ()
+            (if (not (null? slatex::*case-stack*))
+              (let ((top (car slatex::*case-stack*)))
+                (cond
+                 ((> (slatex::of top slatex::=in-bktd-ctag-exp) 0)
+                  (slatex::setf
+                    (slatex::of top slatex::=in-bktd-ctag-exp)
+                    (- (slatex::of top slatex::=in-bktd-ctag-exp) 1))
+                  (if (= (slatex::of top slatex::=in-bktd-ctag-exp) 0)
+                    (slatex::setf (slatex::of top slatex::=in-case-exp) 1)))
+                 ((> (slatex::of top slatex::=in-case-exp) 0)
+                  (slatex::setf
+                    (slatex::of top slatex::=in-case-exp)
+                    (- (slatex::of top slatex::=in-case-exp) 1))
+                  (if (= (slatex::of top slatex::=in-case-exp) 0)
+                    (begin
+                      (set! slatex::*case-stack* (cdr slatex::*case-stack*))
+                      (loop))))))))
+          (loop (+ i 1)))
+         (else
+          (slatex::display-tab
+            (slatex::of line slatex::=tab / i)
+            slatex::*out*)
+          (loop (slatex::do-token line i))))))))
+
+(define slatex::do-all-lines
+  (lambda ()
+    (let loop ((line1 slatex::*line1*) (line2 slatex::*line2*))
+      (let* ((line2-paragraph? slatex::*latex-paragraph-mode?*)
+             (more? (slatex::get-line line1)))
+        (slatex::peephole-adjust line1 line2)
+        ((if line2-paragraph?
+           slatex::display-tex-line
+           slatex::display-scm-line)
+         line2)
+        (if (not (eq? line2-paragraph? slatex::*latex-paragraph-mode?*))
+          ((if slatex::*latex-paragraph-mode?*
+             slatex::display-end-sequence
+             slatex::display-begin-sequence)
+           slatex::*out*))
+        (if more? (loop line2 line1))))))
+
+(define slatex::scheme2tex
+  (lambda (inport outport)
+    (set! slatex::*in* inport)
+    (set! slatex::*out* outport)
+    (set! slatex::*latex-paragraph-mode?* #t)
+    (set! slatex::*in-qtd-tkn* #f)
+    (set! slatex::*in-bktd-qtd-exp* 0)
+    (set! slatex::*in-mac-tkn* #f)
+    (set! slatex::*in-bktd-mac-exp* 0)
+    (set! slatex::*case-stack* '())
+    (set! slatex::*bq-stack* '())
+    (let ((flush-line
+            (lambda (line)
+              (slatex::setf (slatex::of line slatex::=rtedge) 0)
+              (slatex::setf (slatex::of line slatex::=char / 0) #\newline)
+              (slatex::setf (slatex::of line slatex::=space / 0) &void-space)
+              (slatex::setf (slatex::of line slatex::=tab / 0) &void-tab)
+              (slatex::setf
+                (slatex::of line slatex::=notab / 0)
+                &void-notab))))
+      (flush-line slatex::*line1*)
+      (flush-line slatex::*line2*))
+    (slatex::do-all-lines)))
+
+(define slatex::do-token
+  (let ((token-delims
+          (list
+           #\(
+           #\)
+           #\[
+           #\]
+           #\space
+           slatex::*return*
+           #\"
+           #\'
+           #\`
+           #\newline
+           #\,
+           #\;)))
+    (lambda (line i)
+      (let loop ((buf '()) (i i))
+        (let ((c (slatex::of line slatex::=char / i)))
+          (cond
+           ((char=? c #\\)
+            (loop
+             (cons (slatex::of line slatex::=char / (+ i 1)) (cons c buf))
+             (+ i 2)))
+           ((or (memv c token-delims) (memv c slatex::*math-triggerers*))
+            (slatex::output-token (list->string (reverse! buf)))
+            i)
+           ((char? c)
+            (loop (cons (slatex::of line slatex::=char / i) buf) (+ i 1)))
+           (else
+            (slatex::slatex-error
+              'slatex::do-token
+              "token contains non-char?"
+              c))))))))
+
+(define slatex::output-token
+  (lambda (token)
+    (if (not (null? slatex::*case-stack*))
+      (let ((top (car slatex::*case-stack*)))
+        (if (slatex::of top slatex::=in-ctag-tkn)
+          (begin
+            (slatex::setf (slatex::of top slatex::=in-ctag-tkn) #f)
+            (slatex::setf (slatex::of top slatex::=in-case-exp) 1)))))
+    (if (slatex::lassoc token slatex::special-symbols slatex::token=?)
+      (begin
+        (if slatex::*in-qtd-tkn*
+          (set! slatex::*in-qtd-tkn* #f)
+          (if slatex::*in-mac-tkn* (set! slatex::*in-mac-tkn* #f)))
+        (display
+          (cdr (slatex::lassoc token slatex::special-symbols slatex::token=?))
+          slatex::*out*))
+      (slatex::display-token
+        token
+        (cond
+         (slatex::*in-qtd-tkn*
+          (set! slatex::*in-qtd-tkn* #f)
+          (cond
+           ((equal? token "else") 'syntax)
+           ((slatex::lmember token slatex::data-tokens slatex::token=?) 'data)
+           ((slatex::lmember token slatex::constant-tokens slatex::token=?)
+            'constant)
+           ((slatex::lmember token slatex::variable-tokens slatex::token=?)
+            'constant)
+           ((slatex::lmember token slatex::keyword-tokens slatex::token=?)
+            'constant)
+           ((slatex::prim-data-token? token) 'data)
+           (else 'constant)))
+         ((> slatex::*in-bktd-qtd-exp* 0) 'constant)
+         ((and (not (null? slatex::*bq-stack*))
+               (not (slatex::of (car slatex::*bq-stack*) slatex::=in-comma)))
+          'constant)
+         (slatex::*in-mac-tkn*
+          (set! slatex::*in-mac-tkn* #f)
+          (slatex::set-keyword token)
+          'syntax)
+         ((> slatex::*in-bktd-mac-exp* 0) (slatex::set-keyword token) 'syntax)
+         ((slatex::lmember token slatex::data-tokens slatex::token=?) 'data)
+         ((slatex::lmember token slatex::constant-tokens slatex::token=?)
+          'constant)
+         ((slatex::lmember token slatex::variable-tokens slatex::token=?)
+          'variable)
+         ((slatex::lmember token slatex::keyword-tokens slatex::token=?)
+          (cond
+           ((slatex::token=? token "quote") (set! slatex::*in-qtd-tkn* #t))
+           ((slatex::lmember token slatex::macro-definers slatex::token=?)
+            (set! slatex::*in-mac-tkn* #t))
+           ((slatex::lmember token slatex::case-and-ilk slatex::token=?)
+            (set! slatex::*case-stack*
+              (cons
+               (let ((f (slatex::make-case-frame)))
+                 (slatex::setf (slatex::of f slatex::=in-ctag-tkn) #t)
+                 (slatex::setf (slatex::of f slatex::=in-bktd-ctag-exp) 0)
+                 (slatex::setf (slatex::of f slatex::=in-case-exp) 0)
+                 f)
+               slatex::*case-stack*))))
+          'syntax)
+         ((slatex::prim-data-token? token) 'data)
+         (else 'variable))
+        slatex::*out*))
+    (if (and (not (null? slatex::*bq-stack*))
+             (slatex::of (car slatex::*bq-stack*) slatex::=in-bq-tkn))
+      (set! slatex::*bq-stack* (cdr slatex::*bq-stack*)))))
+
+(define slatex::directory-namestring
+  (lambda (f)
+    (let ((p (slatex::string-position-right slatex::*directory-mark* f)))
+      (if p (substring f 0 (+ p 1)) ""))))
+
+(define slatex::basename
+  (lambda (f)
+    (let ((p (slatex::string-position-right slatex::*directory-mark* f)))
+      (if p (set! f (substring f (+ p 1) (string-length f))))
+      (let ((p (slatex::string-position-right #\. f)))
+        (if p (substring f 0 p) f)))))
+
+(define slatex::*texinputs* "")
+
+(define slatex::*texinputs-list* #f)
+
+(define slatex::*path-separator*
+  (cond
+   ((eq? slatex::*operating-system* 'unix) #\:)
+   ((eq? slatex::*operating-system* 'mac-os) (integer->char 0))
+   ((memq slatex::*operating-system* '(windows os2 dos os2fat)) #\;)
+   (else
+    (slatex::slatex-error "Couldn't determine path separator character."))))
+
+(define slatex::*directory-mark*
+  (cond
+   ((eq? slatex::*operating-system* 'unix) #\/)
+   ((eq? slatex::*operating-system* 'mac-os) #\:)
+   ((memq slatex::*operating-system* '(windows os2 dos os2fat)) #\\)
+   (else (slatex::slatex-error "Couldn't determine directory mark."))))
+
+(define slatex::*directory-mark-string*
+  (list->string (list slatex::*directory-mark*)))
+
+(define slatex::*file-hider*
+  (cond
+   ((memq slatex::*operating-system* '(windows os2 unix mac-os)) ".")
+   ((memq slatex::*operating-system* '(dos os2fat)) "x")
+   (else ".")))
+
+(define slatex::path-to-list
+  (lambda (p)
+    (let loop ((p (string->list p)) (r (list "")))
+      (let ((separator-pos (slatex::position-char slatex::*path-separator* p)))
+        (if separator-pos
+          (loop
+           (list-tail p (+ separator-pos 1))
+           (cons (list->string (slatex::sublist p 0 separator-pos)) r))
+          (reverse! (cons (list->string p) r)))))))
+
+(define slatex::find-some-file
+  (lambda (path . files)
+    (let loop ((path path))
+      (if (null? path)
+        #f
+        (let ((dir (car path)))
+          (let loop1 ((files
+                       (if (or (string=? dir "") (string=? dir "."))
+                         files
+                         (map
+                          (lambda (file)
+                            (string-append
+                              dir
+                              slatex::*directory-mark-string*
+                              file))
+                          files))))
+            (if (null? files)
+              (loop (cdr path))
+              (let ((file (car files)))
+                (if (file-exists? file) file (loop1 (cdr files)))))))))))
+
+(define slatex::file-extension
+  (lambda (filename)
+    (let ((i (slatex::string-position-right #\. filename)))
+      (if i (substring filename i (string-length filename)) #f))))
+
+(define slatex::full-texfile-name
+  (lambda (filename)
+    (let ((extn (slatex::file-extension filename)))
+      (if (and extn (or (string=? extn ".sty") (string=? extn ".tex")))
+        (slatex::find-some-file slatex::*texinputs-list* filename)
+        (slatex::find-some-file
+          slatex::*texinputs-list*
+          (string-append filename ".tex")
+          filename)))))
+
+(define slatex::full-styfile-name
+  (lambda (filename)
+    (slatex::find-some-file
+      slatex::*texinputs-list*
+      (string-append filename ".sty"))))
+
+(define slatex::full-clsfile-name
+  (lambda (filename)
+    (slatex::find-some-file
+      slatex::*texinputs-list*
+      (string-append filename ".cls"))))
+
+(define slatex::full-scmfile-name
+  (lambda (filename)
+    (apply
+     slatex::find-some-file
+     slatex::*texinputs-list*
+     filename
+     (map
+      (lambda (extn) (string-append filename extn))
+      '(".scm" ".ss" ".s")))))
+
+(define slatex::subjobname 'fwd)
+
+(define slatex::primary-aux-file-count -1)
+
+(define slatex::new-primary-aux-file
+  (lambda (e)
+    (set! slatex::primary-aux-file-count (+ slatex::primary-aux-file-count 1))
+    (string-append
+      slatex::*tex-calling-directory*
+      slatex::*file-hider*
+      "Z"
+      (number->string slatex::primary-aux-file-count)
+      slatex::subjobname
+      e)))
+
+(define slatex::new-secondary-aux-file
+  (let ((n -1))
+    (lambda (e)
+      (set! n (+ n 1))
+      (string-append
+        slatex::*tex-calling-directory*
+        slatex::*file-hider*
+        "ZZ"
+        (number->string n)
+        slatex::subjobname
+        e))))
+
+(define slatex::new-aux-file
+  (lambda e
+    (let ((e (if (pair? e) (car e) "")))
+      ((if slatex::*slatex-in-protected-region?*
+         slatex::new-secondary-aux-file
+         slatex::new-primary-aux-file)
+       e))))
+
+(define slatex::eat-till-newline
+  (lambda (in)
+    (let loop ()
+      (let ((c (read-char in)))
+        (cond
+         ((eof-object? c) 'done)
+         ((char=? c #\newline) 'done)
+         (else (loop)))))))
+
+(define slatex::read-ctrl-seq
+  (lambda (in)
+    (let ((c (read-char in)))
+      (if (eof-object? c)
+        (slatex::slatex-error "read-ctrl-exp: \\ followed by eof."))
+      (if (char-alphabetic? c)
+        (list->string
+          (reverse!
+            (let loop ((s (list c)))
+              (let ((c (peek-char in)))
+                (cond
+                 ((eof-object? c) s)
+                 ((char-alphabetic? c) (read-char in) (loop (cons c s)))
+                 ((char=? c #\%) (slatex::eat-till-newline in) (loop s))
+                 (else s))))))
+        (string c)))))
+
+(define slatex::eat-tabspace
+  (lambda (in)
+    (let loop ()
+      (let ((c (peek-char in)))
+        (cond
+         ((eof-object? c) 'done)
+         ((or (char=? c #\space) (char=? c slatex::*tab*))
+          (read-char in)
+          (loop))
+         (else 'done))))))
+
+(define slatex::eat-whitespace
+  (lambda (in)
+    (let loop ()
+      (let ((c (peek-char in)))
+        (cond
+         ((eof-object? c) 'done)
+         ((char-whitespace? c) (read-char in) (loop))
+         (else 'done))))))
+
+(define slatex::eat-tex-whitespace
+  (lambda (in)
+    (let loop ()
+      (let ((c (peek-char in)))
+        (cond
+         ((eof-object? c) 'done)
+         ((char-whitespace? c) (read-char in) (loop))
+         ((char=? c #\%) (slatex::eat-till-newline in))
+         (else 'done))))))
+
+(define slatex::chop-off-whitespace
+  (lambda (l)
+    (slatex::ormapcdr (lambda (d) (if (char-whitespace? (car d)) #f d)) l)))
+
+(define slatex::read-grouped-latexexp
+  (lambda (in)
+    (slatex::eat-tex-whitespace in)
+    (let ((c (read-char in)))
+      (if (eof-object? c)
+        (slatex::slatex-error
+          "read-grouped-latexexp: ~\nExpected { but found eof."))
+      (if (not (char=? c #\{))
+        (slatex::slatex-error
+          "read-grouped-latexexp: ~\nExpected { but found ~a."
+          c))
+      (slatex::eat-tex-whitespace in)
+      (list->string
+        (reverse!
+          (slatex::chop-off-whitespace
+            (let loop ((s '()) (nesting 0) (escape? #f))
+              (let ((c (read-char in)))
+                (if (eof-object? c)
+                  (slatex::slatex-error
+                    "read-groupted-latexexp: ~\nFound eof inside {...}."))
+                (cond
+                 (escape? (loop (cons c s) nesting #f))
+                 ((char=? c #\\) (loop (cons c s) nesting #t))
+                 ((char=? c #\%)
+                  (slatex::eat-till-newline in)
+                  (loop s nesting #f))
+                 ((char=? c #\{) (loop (cons c s) (+ nesting 1) #f))
+                 ((char=? c #\})
+                  (if (= nesting 0) s (loop (cons c s) (- nesting 1) #f)))
+                 (else (loop (cons c s) nesting #f)))))))))))
+
+(define slatex::read-filename
+  (let ((filename-delims
+          (list
+           #\{
+           #\}
+           #\[
+           #\]
+           #\(
+           #\)
+           #\#
+           #\%
+           #\\
+           #\,
+           #\space
+           slatex::*return*
+           #\newline
+           slatex::*tab*
+           #\\)))
+    (lambda (in)
+      (slatex::eat-tex-whitespace in)
+      (let ((c (peek-char in)))
+        (if (eof-object? c)
+          (slatex::slatex-error
+            "read-filename: ~\nExpected filename but found eof."))
+        (if (char=? c #\{)
+          (slatex::read-grouped-latexexp in)
+          (list->string
+            (reverse!
+              (let loop ((s '()) (escape? #f))
+                (let ((c (peek-char in)))
+                  (cond
+                   ((eof-object? c)
+                    (if escape?
+                      (slatex::slatex-error
+                        "read-filename: ~\n\\ followed by eof.")
+                      s))
+                   (escape? (read-char in) (loop (cons c s) #f))
+                   ((char=? c #\\) (read-char in) (loop (cons c s) #t))
+                   ((memv c filename-delims) s)
+                   (else (read-char in) (loop (cons c s) #f))))))))))))
+
+(define slatex::read-schemeid
+  (let ((schemeid-delims
+          (list
+           #\{
+           #\}
+           #\[
+           #\]
+           #\(
+           #\)
+           #\space
+           slatex::*return*
+           #\newline
+           slatex::*tab*)))
+    (lambda (in)
+      (slatex::eat-whitespace in)
+      (list->string
+        (reverse!
+          (let loop ((s '()) (escape? #f))
+            (let ((c (peek-char in)))
+              (cond
+               ((eof-object? c) s)
+               (escape? (read-char in) (loop (cons c s) #f))
+               ((char=? c #\\) (read-char in) (loop (cons c s) #t))
+               ((memv c schemeid-delims) s)
+               (else (read-char in) (loop (cons c s) #f))))))))))
+
+(define slatex::read-delimed-commaed-filenames
+  (lambda (in lft-delim rt-delim)
+    (slatex::eat-tex-whitespace in)
+    (let ((c (read-char in)))
+      (if (eof-object? c)
+        (slatex::slatex-error
+          "read-delimed-commaed-filenames: ~\nExpected filename(s) but found eof."))
+      (if (not (char=? c lft-delim))
+        (slatex::slatex-error
+          "read-delimed-commaed-filenames: ~\nLeft delimiter ~a not found."
+          lft-delim))
+      (let loop ((s '()))
+        (slatex::eat-tex-whitespace in)
+        (let ((c (peek-char in)))
+          (if (eof-object? c)
+            (slatex::slatex-error
+              "read-delimed-commaed-filenames: ~\nFound eof inside filename(s)."))
+          (if (char=? c rt-delim)
+            (begin (read-char in) (reverse! s))
+            (let ((s (cons (slatex::read-filename in) s)))
+              (slatex::eat-tex-whitespace in)
+              (let ((c (peek-char in)))
+                (if (eof-object? c)
+                  (slatex::slatex-error
+                    "read-delimed-commaed-filenames: ~\nFound eof inside filename(s)."))
+                (cond
+                 ((char=? c #\,) (read-char in))
+                 ((char=? c rt-delim) (void))
+                 (else
+                  (slatex::slatex-error
+                    "read-delimed-commaed-filenames: ~\nBad filename(s) syntax.")))
+                (loop s)))))))))
+
+(define slatex::read-grouped-commaed-filenames
+  (lambda (in) (slatex::read-delimed-commaed-filenames in #\{ #\})))
+
+(define slatex::read-bktd-commaed-filenames
+  (lambda (in) (slatex::read-delimed-commaed-filenames in #\[ #\])))
+
+(define slatex::read-grouped-schemeids
+  (lambda (in)
+    (slatex::eat-tex-whitespace in)
+    (let ((c (read-char in)))
+      (if (eof-object? c)
+        (slatex::slatex-error
+          "read-grouped-schemeids: ~\nExpected Scheme identifiers but found eof."))
+      (if (not (char=? c #\{))
+        (slatex::slatex-error
+          "read-grouped-schemeids: ~\nExpected { but found ~a."
+          c))
+      (let loop ((s '()))
+        (slatex::eat-whitespace in)
+        (let ((c (peek-char in)))
+          (if (eof-object? c)
+            (slatex::slatex-error
+              "read-grouped-schemeids:\nFound eof inside Scheme identifiers."))
+          (if (char=? c #\})
+            (begin (read-char in) (reverse! s))
+            (loop (cons (slatex::read-schemeid in) s))))))))
+
+(define slatex::eat-delimed-text
+  (lambda (in lft-delim rt-delim)
+    (slatex::eat-tex-whitespace in)
+    (let ((c (peek-char in)))
+      (if (eof-object? c)
+        'exit
+        (if (char=? c lft-delim)
+          (let loop ()
+            (let ((c (read-char in)))
+              (if (eof-object? c)
+                'exit
+                (if (char=? c rt-delim) 'exit (loop))))))))))
+
+(define slatex::eat-bktd-text
+  (lambda (in) (slatex::eat-delimed-text in #\[ #\])))
+
+(define slatex::eat-grouped-text
+  (lambda (in) (slatex::eat-delimed-text in #\{ #\})))
+
+(define slatex::ignore2 (lambda (i ii) 'void))
+
+(define slatex::disable-slatex-temply
+  (lambda (in)
+    (set! slatex::*slatex-enabled?* #f)
+    (set! slatex::*slatex-reenabler* (slatex::read-grouped-latexexp in))))
+
+(define slatex::enable-slatex-again
+  (lambda ()
+    (set! slatex::*slatex-enabled?* #t)
+    (set! slatex::*slatex-reenabler* "UNDEFINED")))
+
+(define slatex::add-to-slatex-db
+  (lambda (in categ)
+    (if (memq categ '(keyword constant variable))
+      (slatex::add-to-slatex-db-basic in categ)
+      (slatex::add-to-slatex-db-special in categ))))
+
+(define slatex::add-to-slatex-db-basic
+  (lambda (in categ)
+    (let ((setter
+            (cond
+             ((eq? categ 'keyword) slatex::set-keyword)
+             ((eq? categ 'constant) slatex::set-constant)
+             ((eq? categ 'variable) slatex::set-variable)
+             (else
+              (slatex::slatex-error
+                "add-to-slatex-db-basic: ~\nUnknown category ~s."
+                categ))))
+          (ids (slatex::read-grouped-schemeids in)))
+      (for-each setter ids))))
+
+(define slatex::add-to-slatex-db-special
+  (lambda (in what)
+    (let ((ids (slatex::read-grouped-schemeids in)))
+      (cond
+       ((eq? what 'unsetspecialsymbol)
+        (for-each slatex::unset-special-symbol ids))
+       ((eq? what 'setspecialsymbol)
+        (if (not (= (length ids) 1))
+          (slatex::slatex-error
+            "add-to-slatex-db-special: ~\n\\setspecialsymbol takes one arg exactly."))
+        (let ((transl (slatex::read-grouped-latexexp in)))
+          (slatex::set-special-symbol (car ids) transl)))
+       (else
+        (slatex::slatex-error
+          "add-to-slatex-db-special: ~\nUnknown command ~s."
+          what))))))
+
+(define slatex::process-slatex-alias
+  (lambda (in what which)
+    (let ((triggerer (slatex::read-grouped-latexexp in)))
+      (case which
+        ((intext)
+         (set! slatex::*intext-triggerers*
+           (what triggerer slatex::*intext-triggerers* string=?)))
+        ((resultintext)
+         (set! slatex::*resultintext-triggerers*
+           (what triggerer slatex::*resultintext-triggerers* string=?)))
+        ((display)
+         (set! slatex::*display-triggerers*
+           (what triggerer slatex::*display-triggerers* string=?)))
+        ((response)
+         (set! slatex::*response-triggerers*
+           (what triggerer slatex::*response-triggerers* string=?)))
+        ((respbox)
+         (set! slatex::*respbox-triggerers*
+           (what triggerer slatex::*respbox-triggerers* string=?)))
+        ((box)
+         (set! slatex::*box-triggerers*
+           (what triggerer slatex::*box-triggerers* string=?)))
+        ((input)
+         (set! slatex::*input-triggerers*
+           (what triggerer slatex::*input-triggerers* string=?)))
+        ((region)
+         (set! slatex::*region-triggerers*
+           (what triggerer slatex::*region-triggerers* string=?)))
+        ((mathescape)
+         (if (not (= (string-length triggerer) 1))
+           (slatex::slatex-error
+             "process-slatex-alias: ~\nMath escape should be character."))
+         (set! slatex::*math-triggerers*
+           (what (string-ref triggerer 0) slatex::*math-triggerers* char=?)))
+        (else
+         (slatex::slatex-error
+           "process-slatex-alias:\nUnknown command ~s."
+           which))))))
+
+(define slatex::decide-latex-or-tex
+  (lambda (latex?)
+    (set! slatex::*latex?* latex?)
+    (let ((pltexchk.jnk "pltexchk.jnk"))
+      (if (file-exists? pltexchk.jnk) (delete-file pltexchk.jnk))
+      (if (not slatex::*latex?*)
+        (call-with-output-file
+          pltexchk.jnk
+          (lambda (outp) (display 'junk outp) (newline outp)))))))
+
+(define slatex::process-include-only
+  (lambda (in)
+    (set! slatex::*include-onlys* '())
+    (for-each
+      (lambda (filename)
+        (let ((filename (slatex::full-texfile-name filename)))
+          (if filename
+            (set! slatex::*include-onlys*
+              (slatex::adjoin filename slatex::*include-onlys* string=?)))))
+      (slatex::read-grouped-commaed-filenames in))))
+
+(define slatex::process-documentstyle
+  (lambda (in)
+    (slatex::eat-tex-whitespace in)
+    (if (char=? (peek-char in) #\[)
+      (for-each
+        (lambda (filename)
+          (fluid-let
+            ((slatex::*slatex-in-protected-region?* #f))
+            (slatex::process-tex-file (string-append filename ".sty"))))
+        (slatex::read-bktd-commaed-filenames in)))))
+
+(define slatex::process-documentclass
+  (lambda (in) (slatex::eat-bktd-text in) (slatex::eat-grouped-text in)))
+
+(define slatex::process-case-info
+  (lambda (in)
+    (let ((bool (slatex::read-grouped-latexexp in)))
+      (set! slatex::*slatex-case-sensitive?*
+        (cond
+         ((string-ci=? bool "true") #t)
+         ((string-ci=? bool "false") #f)
+         (else
+          (slatex::slatex-error
+            "process-case-info: ~\n\\schemecasesensitive's arg should be true or false.")))))))
+
+(define slatex::seen-first-command? #f)
+
+(define slatex::process-main-tex-file
+  (lambda (filename)
+    (display "SLaTeX v. ")
+    (display slatex::*slatex-version*)
+    (newline)
+    (set! slatex::primary-aux-file-count -1)
+    (set! slatex::*slatex-separate-includes?* #f)
+    (if (or (not slatex::*texinputs-list*) (null? slatex::*texinputs-list*))
+      (set! slatex::*texinputs-list*
+        (if slatex::*texinputs*
+          (slatex::path-to-list slatex::*texinputs*)
+          '(""))))
+    (let ((file-hide-file "xZfilhid.tex"))
+      (if (file-exists? file-hide-file) (delete-file file-hide-file))
+      (if (memq slatex::*operating-system* '(dos os2fat))
+        (call-with-output-file
+          file-hide-file
+          (lambda (out) (display "\\def\\filehider{x}" out) (newline out)))))
+    (display "typesetting code")
+    (set! slatex::*tex-calling-directory*
+      (slatex::directory-namestring filename))
+    (set! slatex::subjobname (slatex::basename filename))
+    (set! slatex::seen-first-command? #f)
+    (slatex::process-tex-file filename)
+    (display "done")
+    (newline)))
+
+(define slatex::dump-intext
+  (lambda (in out)
+    (let* ((write-char (if out write-char slatex::ignore2))
+           (delim-char (begin (slatex::eat-whitespace in) (read-char in)))
+           (delim-char (cond ((char=? delim-char #\{) #\}) (else delim-char))))
+      (if (eof-object? delim-char)
+        (slatex::slatex-error
+          "dump-intext: Expected delimiting character ~\nbut found eof."))
+      (let loop ()
+        (let ((c (read-char in)))
+          (if (eof-object? c)
+            (slatex::slatex-error
+              "dump-intext: Found eof inside Scheme code."))
+          (if (char=? c delim-char)
+            'done
+            (begin (write-char c out) (loop))))))))
+
+(define slatex::dump-display
+  (lambda (in out ender)
+    (slatex::eat-tabspace in)
+    (let ((write-char (if out write-char slatex::ignore2))
+          (ender-lh (string-length ender))
+          (c (peek-char in)))
+      (if (eof-object? c)
+        (slatex::slatex-error
+          "dump-display: Found eof inside displayed code."))
+      (if (char=? c #\newline) (read-char in))
+      (let loop ((i 0))
+        (if (= i ender-lh)
+          'done
+          (let ((c (read-char in)))
+            (if (eof-object? c)
+              (slatex::slatex-error
+                "dump-display: Found eof inside displayed code."))
+            (if (char=? c (string-ref ender i))
+              (loop (+ i 1))
+              (let loop2 ((j 0))
+                (if (< j i)
+                  (begin (write-char (string-ref ender j) out) (loop2 (+ j 1)))
+                  (begin (write-char c out) (loop 0)))))))))))
+
+(define slatex::debug? #f)
+
+(define slatex::process-tex-file
+  (lambda (raw-filename)
+    (if slatex::debug?
+      (begin (display "begin ") (display raw-filename) (newline)))
+    (let ((filename (slatex::full-texfile-name raw-filename)))
+      (if (not filename)
+        (begin
+          (display "[")
+          (display raw-filename)
+          (display "]")
+          (flush-output))
+        (call-with-input-file
+          filename
+          (lambda (in)
+            (let ((done? #f))
+              (let loop ()
+                (if done?
+                  'exit-loop
+                  (begin
+                    (let ((c (read-char in)))
+                      (cond
+                       ((eof-object? c) (set! done? #t))
+                       ((char=? c #\%) (slatex::eat-till-newline in))
+                       ((char=? c #\\)
+                        (let ((cs (slatex::read-ctrl-seq in)))
+                          (if (not slatex::seen-first-command?)
+                            (begin
+                              (set! slatex::seen-first-command? #t)
+                              (slatex::decide-latex-or-tex
+                                (or (string=? cs "documentstyle")
+                                    (string=? cs "documentclass")
+                                    (string=? cs "NeedsTeXFormat")))))
+                          (cond
+                           ((not slatex::*slatex-enabled?*)
+                            (if (string=? cs slatex::*slatex-reenabler*)
+                              (slatex::enable-slatex-again)))
+                           ((string=? cs "slatexignorecurrentfile")
+                            (set! done? #t))
+                           ((string=? cs "slatexseparateincludes")
+                            (if slatex::*latex?*
+                              (set! slatex::*slatex-separate-includes?* #t)))
+                           ((string=? cs "slatexdisable")
+                            (slatex::disable-slatex-temply in))
+                           ((string=? cs "begin")
+                            (slatex::eat-tex-whitespace in)
+                            (if (eqv? (peek-char in) #\{)
+                              (let ((cs (slatex::read-grouped-latexexp in)))
+                                (cond
+                                 ((member cs slatex::*display-triggerers*)
+                                  (slatex::trigger-scheme2tex
+                                    'envdisplay
+                                    in
+                                    cs))
+                                 ((member cs slatex::*response-triggerers*)
+                                  (slatex::trigger-scheme2tex
+                                    'envresponse
+                                    in
+                                    cs))
+                                 ((member cs slatex::*respbox-triggerers*)
+                                  (slatex::trigger-scheme2tex
+                                    'envrespbox
+                                    in
+                                    cs))
+                                 ((member cs slatex::*box-triggerers*)
+                                  (slatex::trigger-scheme2tex 'envbox in cs))
+                                 ((member cs slatex::*topbox-triggerers*)
+                                  (slatex::trigger-scheme2tex
+                                    'envtopbox
+                                    in
+                                    cs))
+                                 ((member cs slatex::*region-triggerers*)
+                                  (slatex::trigger-region
+                                    'envregion
+                                    in
+                                    cs))))))
+                           ((member cs slatex::*intext-triggerers*)
+                            (slatex::trigger-scheme2tex 'intext in #f))
+                           ((member cs slatex::*resultintext-triggerers*)
+                            (slatex::trigger-scheme2tex 'resultintext in #f))
+                           ((member cs slatex::*display-triggerers*)
+                            (slatex::trigger-scheme2tex 'plaindisplay in cs))
+                           ((member cs slatex::*response-triggerers*)
+                            (slatex::trigger-scheme2tex 'plainresponse in cs))
+                           ((member cs slatex::*respbox-triggerers*)
+                            (slatex::trigger-scheme2tex 'plainrespbox in cs))
+                           ((member cs slatex::*box-triggerers*)
+                            (slatex::trigger-scheme2tex 'plainbox in cs))
+                           ((member cs slatex::*topbox-triggerers*)
+                            (slatex::trigger-scheme2tex 'plaintopbox in cs))
+                           ((member cs slatex::*region-triggerers*)
+                            (slatex::trigger-region 'plainregion in cs))
+                           ((member cs slatex::*input-triggerers*)
+                            (slatex::process-scheme-file
+                              (slatex::read-filename in)))
+                           ((string=? cs "input")
+                            (let ((f (slatex::read-filename in)))
+                              (if (not (string=? f ""))
+                                (fluid-let
+                                  ((slatex::*slatex-in-protected-region?* #f))
+                                  (slatex::process-tex-file f)))))
+                           ((string=? cs "usepackage")
+                            (fluid-let
+                              ((slatex::*slatex-in-protected-region?* #f))
+                              (slatex::process-tex-file
+                                (string-append
+                                  (slatex::read-filename in)
+                                  ".sty"))))
+                           ((string=? cs "include")
+                            (if slatex::*latex?*
+                              (let ((f
+                                     (slatex::full-texfile-name
+                                       (slatex::read-filename in))))
+                                (if (and f
+                                         (or (eq? slatex::*include-onlys* 'all)
+                                             (member
+                                               f
+                                               slatex::*include-onlys*)))
+                                  (fluid-let
+                                    ((slatex::*slatex-in-protected-region?*
+                                       #f))
+                                    (if slatex::*slatex-separate-includes?*
+                                      (fluid-let
+                                        ((slatex::subjobname
+                                           (slatex::basename f))
+                                         (slatex::primary-aux-file-count -1))
+                                        (slatex::process-tex-file f))
+                                      (slatex::process-tex-file f)))))))
+                           ((string=? cs "includeonly")
+                            (if slatex::*latex?*
+                              (slatex::process-include-only in)))
+                           ((string=? cs "documentstyle")
+                            (if slatex::*latex?*
+                              (slatex::process-documentstyle in)))
+                           ((string=? cs "documentclass")
+                            (if slatex::*latex?*
+                              (slatex::process-documentclass in)))
+                           ((string=? cs "schemecasesensitive")
+                            (slatex::process-case-info in))
+                           ((string=? cs "defschemetoken")
+                            (slatex::process-slatex-alias
+                              in
+                              slatex::adjoin
+                              'intext))
+                           ((string=? cs "undefschemetoken")
+                            (slatex::process-slatex-alias
+                              in
+                              slatex::delete
+                              'intext))
+                           ((string=? cs "defschemeresulttoken")
+                            (slatex::process-slatex-alias
+                              in
+                              slatex::adjoin
+                              'resultintext))
+                           ((string=? cs "undefschemeresulttoken")
+                            (slatex::process-slatex-alias
+                              in
+                              slatex::delete
+                              'resultintext))
+                           ((string=? cs "defschemeresponsetoken")
+                            (slatex::process-slatex-alias
+                              in
+                              slatex::adjoin
+                              'response))
+                           ((string=? cs "undefschemeresponsetoken")
+                            (slatex::process-slatex-alias
+                              in
+                              slatex::delete
+                              'response))
+                           ((string=? cs "defschemeresponseboxtoken")
+                            (slatex::process-slatex-alias
+                              in
+                              slatex::adjoin
+                              'respbox))
+                           ((string=? cs "undefschemeresponseboxtoken")
+                            (slatex::process-slatex-alias
+                              in
+                              slatex::delete
+                              'respbox))
+                           ((string=? cs "defschemedisplaytoken")
+                            (slatex::process-slatex-alias
+                              in
+                              slatex::adjoin
+                              'display))
+                           ((string=? cs "undefschemedisplaytoken")
+                            (slatex::process-slatex-alias
+                              in
+                              slatex::delete
+                              'display))
+                           ((string=? cs "defschemeboxtoken")
+                            (slatex::process-slatex-alias
+                              in
+                              slatex::adjoin
+                              'box))
+                           ((string=? cs "undefschemeboxtoken")
+                            (slatex::process-slatex-alias
+                              in
+                              slatex::delete
+                              'box))
+                           ((string=? cs "defschemetopboxtoken")
+                            (slatex::process-slatex-alias
+                              in
+                              slatex::adjoin
+                              'topbox))
+                           ((string=? cs "undefschemetopboxtoken")
+                            (slatex::process-slatex-alias
+                              in
+                              slatex::delete
+                              'topbox))
+                           ((string=? cs "defschemeinputtoken")
+                            (slatex::process-slatex-alias
+                              in
+                              slatex::adjoin
+                              'input))
+                           ((string=? cs "undefschemeinputtoken")
+                            (slatex::process-slatex-alias
+                              in
+                              slatex::delete
+                              'input))
+                           ((string=? cs "defschemeregiontoken")
+                            (slatex::process-slatex-alias
+                              in
+                              slatex::adjoin
+                              'region))
+                           ((string=? cs "undefschemeregiontoken")
+                            (slatex::process-slatex-alias
+                              in
+                              slatex::delete
+                              'region))
+                           ((string=? cs "defschememathescape")
+                            (slatex::process-slatex-alias
+                              in
+                              slatex::adjoin
+                              'mathescape))
+                           ((string=? cs "undefschememathescape")
+                            (slatex::process-slatex-alias
+                              in
+                              slatex::delete
+                              'mathescape))
+                           ((string=? cs "setkeyword")
+                            (slatex::add-to-slatex-db in 'keyword))
+                           ((string=? cs "setconstant")
+                            (slatex::add-to-slatex-db in 'constant))
+                           ((string=? cs "setvariable")
+                            (slatex::add-to-slatex-db in 'variable))
+                           ((string=? cs "setspecialsymbol")
+                            (slatex::add-to-slatex-db in 'setspecialsymbol))
+                           ((string=? cs "unsetspecialsymbol")
+                            (slatex::add-to-slatex-db
+                              in
+                              'unsetspecialsymbol)))))))
+                    (loop)))))))))
+    (if slatex::debug?
+      (begin (display "end ") (display raw-filename) (newline)))))
+
+(define slatex::process-scheme-file
+  (lambda (raw-filename)
+    (let ((filename (slatex::full-scmfile-name raw-filename)))
+      (if (not filename)
+        (begin
+          (display "process-scheme-file: ")
+          (display raw-filename)
+          (display " doesn't exist")
+          (newline))
+        (let ((aux.tex (slatex::new-aux-file ".tex")))
+          (display ".")
+          (flush-output)
+          (if (file-exists? aux.tex) (delete-file aux.tex))
+          (call-with-input-file
+            filename
+            (lambda (in)
+              (call-with-output-file
+                aux.tex
+                (lambda (out)
+                  (fluid-let
+                    ((slatex::*intext?* #f)
+                     (slatex::*code-env-spec* "ZZZZschemedisplay"))
+                    (slatex::scheme2tex in out))))))
+          (if slatex::*slatex-in-protected-region?*
+            (set! slatex::*protected-files*
+              (cons aux.tex slatex::*protected-files*)))
+          (slatex::process-tex-file filename))))))
+
+(define slatex::trigger-scheme2tex
+  (lambda (typ in env)
+    (let* ((aux (slatex::new-aux-file))
+           (aux.scm (string-append aux ".scm"))
+           (aux.tex (string-append aux ".tex")))
+      (if (file-exists? aux.scm) (delete-file aux.scm))
+      (if (file-exists? aux.tex) (delete-file aux.tex))
+      (display ".")
+      (flush-output)
+      (call-with-output-file
+        aux.scm
+        (lambda (out)
+          (cond
+           ((memq typ '(intext resultintext)) (slatex::dump-intext in out))
+           ((memq typ '(envdisplay envresponse envrespbox envbox envtopbox))
+            (slatex::dump-display in out (string-append "\\end{" env "}")))
+           ((memq
+             typ
+             '(plaindisplay plainresponse plainrespbox plainbox plaintopbox))
+            (slatex::dump-display in out (string-append "\\end" env)))
+           (else
+            (slatex::slatex-error
+              "trigger-scheme2tex: ~\n                          Unknown triggerer ~s."
+              typ)))))
+      (call-with-input-file
+        aux.scm
+        (lambda (in)
+          (call-with-output-file
+            aux.tex
+            (lambda (out)
+              (fluid-let
+                ((slatex::*intext?* (memq typ '(intext resultintext)))
+                 (slatex::*code-env-spec*
+                   (cond
+                    ((eq? typ 'intext) "ZZZZschemecodeintext")
+                    ((eq? typ 'resultintext) "ZZZZschemeresultintext")
+                    ((memq typ '(envdisplay plaindisplay)) "ZZZZschemedisplay")
+                    ((memq typ '(envresponse plainresponse))
+                     "ZZZZschemeresponse")
+                    ((memq typ '(envrespbox plainrespbox))
+                     "ZZZZschemeresponsebox")
+                    ((memq typ '(envbox plainbox)) "ZZZZschemebox")
+                    ((memq typ '(envtopbox plaintopbox)) "ZZZZschemetopbox")
+                    (else
+                     (slatex::slatex-error
+                       "trigger-scheme2tex: ~\n                                   Unknown triggerer ~s."
+                       typ)))))
+                (slatex::scheme2tex in out))))))
+      (if slatex::*slatex-in-protected-region?*
+        (set! slatex::*protected-files*
+          (cons aux.tex slatex::*protected-files*)))
+      (if (memq
+           typ
+           '(envdisplay plaindisplay envbox plainbox envtopbox plaintopbox))
+        (slatex::process-tex-file aux.tex))
+      (delete-file aux.scm))))
+
+(define slatex::trigger-region
+  (lambda (typ in env)
+    (let ((aux.tex (slatex::new-primary-aux-file ".tex"))
+          (aux2.tex (slatex::new-secondary-aux-file ".tex")))
+      (if (file-exists? aux2.tex) (delete-file aux2.tex))
+      (if (file-exists? aux.tex) (delete-file aux.tex))
+      (display ".")
+      (flush-output)
+      (fluid-let
+        ((slatex::*slatex-in-protected-region?* #t)
+         (slatex::*protected-files* '()))
+        (call-with-output-file
+          aux2.tex
+          (lambda (out)
+            (cond
+             ((eq? typ 'envregion)
+              (slatex::dump-display in out (string-append "\\end{" env "}")))
+             ((eq? typ 'plainregion)
+              (slatex::dump-display in out (string-append "\\end" env)))
+             (else
+              (slatex::slatex-error
+                "trigger-region: ~\nUnknown triggerer ~s."
+                typ)))))
+        (slatex::process-tex-file aux2.tex)
+        (set! slatex::*protected-files* (reverse! slatex::*protected-files*))
+        (call-with-input-file
+          aux2.tex
+          (lambda (in)
+            (call-with-output-file
+              aux.tex
+              (lambda (out) (slatex::inline-protected-files in out)))))
+        (delete-file aux2.tex)))))
+
+(define slatex::inline-protected-files
+  (lambda (in out)
+    (let ((done? #f))
+      (let loop ()
+        (if done?
+          'exit-loop
+          (begin
+            (let ((c (read-char in)))
+              (cond
+               ((eof-object? c) (set! done? #t))
+               ((or (char=? c slatex::*return*) (char=? c #\newline))
+                (let ((c2 (peek-char in)))
+                  (if (not (eof-object? c2)) (write-char c out))))
+               ((char=? c #\%)
+                (write-char c out)
+                (newline out)
+                (slatex::eat-till-newline in))
+               ((char=? c #\\)
+                (let ((cs (slatex::read-ctrl-seq in)))
+                  (cond
+                   ((string=? cs "begin")
+                    (let ((cs (slatex::read-grouped-latexexp in)))
+                      (cond
+                       ((member cs slatex::*display-triggerers*)
+                        (slatex::inline-protected 'envdisplay in out cs))
+                       ((member cs slatex::*response-triggerers*)
+                        (slatex::inline-protected 'envresponse in out cs))
+                       ((member cs slatex::*respbox-triggerers*)
+                        (slatex::inline-protected 'envrespbox in out cs))
+                       ((member cs slatex::*box-triggerers*)
+                        (slatex::inline-protected 'envbox in out cs))
+                       ((member cs slatex::*topbox-triggerers*)
+                        (slatex::inline-protected 'envtopbox in out cs))
+                       ((member cs slatex::*region-triggerers*)
+                        (slatex::inline-protected 'envregion in out cs))
+                       (else
+                        (display "\\begin{" out)
+                        (display cs out)
+                        (display "}" out)))))
+                   ((member cs slatex::*intext-triggerers*)
+                    (slatex::inline-protected 'intext in out #f))
+                   ((member cs slatex::*resultintext-triggerers*)
+                    (slatex::inline-protected 'resultintext in out #f))
+                   ((member cs slatex::*display-triggerers*)
+                    (slatex::inline-protected 'plaindisplay in out cs))
+                   ((member cs slatex::*response-triggerers*)
+                    (slatex::inline-protected 'plainresponse in out cs))
+                   ((member cs slatex::*respbox-triggerers*)
+                    (slatex::inline-protected 'plainrespbox in out cs))
+                   ((member cs slatex::*box-triggerers*)
+                    (slatex::inline-protected 'plainbox in out cs))
+                   ((member cs slatex::*topbox-triggerers*)
+                    (slatex::inline-protected 'plaintopbox in out cs))
+                   ((member cs slatex::*region-triggerers*)
+                    (slatex::inline-protected 'plainregion in out cs))
+                   ((member cs slatex::*input-triggerers*)
+                    (slatex::inline-protected 'input in out cs))
+                   (else (display "\\" out) (display cs out)))))
+               (else (write-char c out))))
+            (loop)))))))
+
+(define slatex::inline-protected
+  (lambda (typ in out env)
+    (cond
+     ((eq? typ 'envregion)
+      (display "\\begin{" out)
+      (display env out)
+      (display "}" out)
+      (slatex::dump-display in out (string-append "\\end{" env "}"))
+      (display "\\end{" out)
+      (display env out)
+      (display "}" out))
+     ((eq? typ 'plainregion)
+      (display "\\" out)
+      (display env out)
+      (slatex::dump-display in out (string-append "\\end" env))
+      (display "\\end" out)
+      (display env out))
+     (else
+      (let ((f (car slatex::*protected-files*)))
+        (set! slatex::*protected-files* (cdr slatex::*protected-files*))
+        (call-with-input-file
+          f
+          (lambda (in) (slatex::inline-protected-files in out)))
+        (delete-file f))
+      (cond
+       ((memq typ '(intext resultintext))
+        (display "{}" out)
+        (slatex::dump-intext in #f))
+       ((memq typ '(envrespbox envbox envtopbox))
+        (if (not slatex::*latex?*) (display "{}" out))
+        (slatex::dump-display in #f (string-append "\\end{" env "}")))
+       ((memq typ '(plainrespbox plainbox plaintopbox))
+        (display "{}" out)
+        (slatex::dump-display in #f (string-append "\\end" env)))
+       ((memq typ '(envdisplay envresponse))
+        (slatex::dump-display in #f (string-append "\\end{" env "}")))
+       ((memq typ '(plaindisplay plainresponse))
+        (slatex::dump-display in #f (string-append "\\end" env)))
+       ((eq? typ 'input) (slatex::read-filename in))
+       (else
+        (slatex::slatex-error
+          "inline-protected: ~\nUnknown triggerer ~s."
+          typ)))))))
+
+
+)
+
diff --git a/collects/slatex/slatex.sty b/collects/slatex/slatex.sty
new file mode 100644
index 0000000000..e9be1d3a8a
--- /dev/null
+++ b/collects/slatex/slatex.sty
@@ -0,0 +1,574 @@
+% slatex.sty
+% SLaTeX v. 2.4
+% style file to be used in (La)TeX when using SLaTeX
+% (c) Dorai Sitaram, Rice U., 1991, 1999
+
+\def\slatexversion{2.4z2}
+
+% This file (or a soft link to it) should be in some
+% directory in your TEXINPUTS path (i.e., the one
+% (La)TeX scours for \input or \documentstyle option
+% files).
+
+% Do not attempt to debug this file, since the results
+% are not transparent just to (La)TeX.  The Scheme part
+% of SLaTeX depends on information laid out here -- so
+% (La)TeX-minded debugging of this file will almost
+% inevitably sabotage SLaTeX.
+
+% It's possible you don't find the default style set
+% out here appealing: e.g., you may want to change the
+% positioning of displayed code; change the fonts for
+% keywords, constants, and variables; add new keywords,
+% constants, and variables; use your names instead of
+% the provided \scheme, [\begin|\end]{schemedisplay},
+% [\begin|\end]{schemebox}, (or \[end]schemedisplay,
+% \[end]schemebox for TeX), which might be seem too
+% long or unmnemonic, and many other things.  The clean
+% way to do these things is outlined in the
+% accompanying manual, slatxdoc.tex.  This way is both
+% easier than messing with this .sty file, and safer
+% since you will not unwittingly break SLaTeX.
+
+%%%
+
+% to prevent loading slatex.sty more than once
+
+\ifx\slatexignorecurrentfile\UNDEFINED
+\else\endinput\fi
+
+% use \slatexignorecurrentfile to disable slatex for
+% the current file.  (Unstrangely, the very definition
+% disables slatex for the rest of _this_ file, slatex.sty.)
+
+\def\slatexignorecurrentfile{}
+
+% checking whether we're using LaTeX or TeX?
+
+\newif\ifusinglatex
+\ifx\newenvironment\UNDEFINED\usinglatexfalse\else\usinglatextrue\fi
+
+% make @ a letter for TeX
+\ifusinglatex\relax\else
+\edef\atcatcodebeforeslatex{\the\catcode`\@ }
+\catcode`\@11
+\fi
+
+% identification of TeX/LaTeX style for schemedisplay.
+% Do \defslatexenvstyle{tex} to get TeX environment
+% style in LaTeX
+\def\defslatexenvstyle#1{\gdef\slatexenvstyle{#1}}
+
+\ifusinglatex\defslatexenvstyle{latex}\else\defslatexenvstyle{tex}\fi
+
+% TeX doesn't have sans-serif; use roman instead
+\ifx\sf\UNDEFINED\let\sf\rm\fi
+
+% tabbing from plain TeX
+%
+\newif\ifus@ \newif\if@cr
+\newbox\tabs \newbox\tabsyet \newbox\tabsdone
+%
+\def\cleartabs{\global\setbox\tabsyet\null \setbox\tabs\null}
+\def\settabs{\setbox\tabs\null \futurelet\next\sett@b}
+\let\tabalignaux=\relax % in case this file is being read in twice
+\def\sett@b{\ifx\next\tabalignaux\let\next\relax
+    \def\next{\afterassignment\s@tt@b\let\next}%
+\else\let\next\s@tcols\fi\next}
+\def\s@tt@b{\let\next\relax\us@false\m@ketabbox}
+\def\tabalign{\us@true\m@ketabbox} % non-\outer version of \tabalignaux
+\outer\def\tabalignaux{\tabalign}
+\def\s@tcols#1\columns{\count@#1 \dimen@\hsize
+  \loop\ifnum\count@>\z@ \@nother \repeat}
+\def\@nother{\dimen@ii\dimen@ \divide\dimen@ii\count@
+  \setbox\tabs\hbox{\hbox to\dimen@ii{}\unhbox\tabs}%
+  \advance\dimen@-\dimen@ii \advance\count@\m@ne}
+%
+\def\m@ketabbox{\begingroup
+  \global\setbox\tabsyet\copy\tabs
+  \global\setbox\tabsdone\null
+  \def\CR{\@crtrue\crcr\egroup\egroup
+    \ifus@\unvbox\z@\lastbox\fi\endgroup
+    \setbox\tabs\hbox{\unhbox\tabsyet\unhbox\tabsdone}}%
+  \setbox\z@\vbox\bgroup\@crfalse
+    \ialign\bgroup&\t@bbox##\t@bb@x\crcr}
+%
+\def\t@bbox{\setbox\z@\hbox\bgroup}
+\def\t@bb@x{\if@cr\egroup % now \box\z@ holds the column
+  \else\hss\egroup \global\setbox\tabsyet\hbox{\unhbox\tabsyet
+      \global\setbox\@ne\lastbox}% now \box\@ne holds its size
+    \ifvoid\@ne\global\setbox\@ne\hbox to\wd\z@{}%
+    \else\setbox\z@\hbox to\wd\@ne{\unhbox\z@}\fi
+    \global\setbox\tabsdone\hbox{\box\@ne\unhbox\tabsdone}\fi
+  \box\z@}
+% finished (re)defining TeX's tabbing macros
+
+% above from plain.tex; was disabled in lplain.tex.  Do
+% not modify above unless you really know what you're
+% up to.  Make all changes you want to following code.
+% The new env is preferable to LaTeX's tabbing env
+% since latter accepts only a small number of tabs
+
+% following retrieves something like LaTeX's tabbing
+% env without the above problem (it also creates a box
+% for easy manipulation!)
+
+\def\lat@xtabbing{\begingroup
+\def\={\cleartabs&} \def\>{&}%
+\def\\{\CR\tabalign\lat@xtabbingleftmost}%
+\tabalign\lat@xtabbingleftmost}
+\def\endlat@xtabbing{\CR\endgroup}
+\let\lat@xtabbingleftmost\relax
+
+% stuff for formating Scheme code
+
+\newskip\par@nlen \newskip\brack@tlen \newskip\quot@len
+\newskip\h@lflambda
+
+\newbox\garb@ge
+\def\s@ttowidth#1#2{\setbox\garb@ge\hbox{#2}#1\wd\garb@ge\relax}
+
+\s@ttowidth\par@nlen{$($}       % size of paren
+\s@ttowidth\brack@tlen{$[$}     % size of bracket
+\s@ttowidth\quot@len{'}         % size of quote indentation
+\s@ttowidth\h@lflambda{ii}      % size of half of lambda indentation
+
+\def\PRN{\hskip\par@nlen}       % these are used by SLaTeX's codesetter
+\def\BKT{\hskip\brack@tlen}
+\def\QUO{\hskip\quot@len}
+\def\HL{\hskip\h@lflambda}
+
+\newskip\abovecodeskip \newskip\belowcodeskip
+\newskip\leftcodeskip \newskip\rightcodeskip
+
+% the following default assignments give a flushleft
+% display
+
+\abovecodeskip=\medskipamount \belowcodeskip=\medskipamount
+\leftcodeskip=0pt \rightcodeskip=0pt
+
+% adjust above,below,left,right codeskip's to personal
+% taste
+
+% for centered displays
+%
+% \leftcodeskip=0pt plus 1fil
+% \rightcodeskip=0pt plus 1fil
+%
+% if \rightcodeskip != 0pt, pagebreaks within Scheme
+% blocks in {schemedisplay} are disabled
+
+\let\checkforfollpar1
+\def\noindentifnofollpar{\ifx\checkforfollpar0\let\next\relax
+  \else\ifusinglatex\let\next\@endparenv
+  \else\let\next\noindentifnofollparI\fi\fi\next}
+\def\noindentifnofollparI{\futurelet\next\noindentifnofollparII}
+\def\noindentifnofollparII{\ifx\next\par\else\noindent\ignorespaces\fi}
+
+% the following are the default font assignments for
+% words in code.  Change them to suit personal taste
+
+\def\keywordfont#1{{\bf #1}}
+\def\variablefont#1{{\it #1\/}}
+\def\constantfont#1{{\sf #1}}
+\def\datafont#1{\constantfont{#1}}
+
+\let\schemecodehook\relax
+\let\ZZZZschemecodehook\relax
+
+%program listings that allow page breaks but
+%can't be centered
+
+\def\ZZZZschemedisplay{\edef\thez@skip{\the\z@skip}%
+  \edef\@tempa{\the\rightcodeskip}%
+  \ifx\@tempa\thez@skip\let\next\ZZZZschemeprogram
+  \else\let\next\ZZZZschemeprogramII\fi\next}
+
+\def\endZZZZschemedisplay{\edef\thez@skip{\the\z@skip}%
+  \edef\@tempa{\the\rightcodeskip}%
+  \ifx\@tempa\thez@skip\let\next\endZZZZschemeprogram
+  \else\let\next\endZZZZschemeprogramII\fi\next}
+
+\def\ZZZZschemeprogram{\vskip\abovecodeskip
+  \begingroup
+  \schemecodehook\ZZZZschemecodehook
+  \frenchspacing
+  \let\sy=\keywordfont \let\cn=\constantfont
+  \let\va=\variablefont \let\dt=\datafont
+  \def\lat@xtabbingleftmost{\hskip\leftskip\hskip\leftcodeskip\relax}%
+  \lat@xtabbing}
+
+\def\endZZZZschemeprogram{\endlat@xtabbing
+  \endgroup
+  \vskip\belowcodeskip
+  \noindentifnofollpar}
+
+\def\ZZZZschemeprogramII{\vskip\abovecodeskip
+  \begingroup
+  \noindent
+  %\ZZZZschemecodehook\schemecodehook %\ZZZZschemebox already has it
+  \hskip\leftcodeskip
+  \ZZZZschemebox}
+
+\def\endZZZZschemeprogramII{\endZZZZschemebox
+  \hskip\rightcodeskip
+  \endgroup
+  \vskip\belowcodeskip
+  \noindentifnofollpar}
+
+\def\ZZZZschemeresponse{\ZZZZschemecodehookforresult
+  \ZZZZschemedisplay}
+\let\endZZZZschemeresponse\endZZZZschemedisplay
+
+%
+
+\def\ZZZZschemebox{%
+  \leavevmode\hbox\bgroup\vbox\bgroup
+  \schemecodehook\ZZZZschemecodehook
+  \frenchspacing
+  \let\sy=\keywordfont \let\cn=\constantfont
+  \let\va=\variablefont \let\dt=\datafont
+  \lat@xtabbing}
+\def\endZZZZschemebox{\endlat@xtabbing
+\egroup\egroup\ignorespaces}
+
+% schemetopbox : added by robby/jbc 2000
+
+\def\ZZZZschemetopbox{%
+  \leavevmode\hbox\bgroup\vtop\bgroup
+  \schemecodehook\ZZZZschemecodehook
+  \frenchspacing
+  \let\sy=\keywordfont \let\cn=\constantfont
+  \let\va=\variablefont \let\dt=\datafont
+  \lat@xtabbing}
+\def\endZZZZschemetopbox{\endlat@xtabbing
+\egroup\egroup\ignorespaces}
+
+\def\ZZZZschemeresponsebox{\ZZZZschemecodehookforresult
+  \ZZZZschemebox}
+\let\endZZZZschemeresponsebox\endZZZZschemebox
+
+%in-text
+
+\def\ZZZZschemecodeintext{\begingroup
+  \schemecodehook\ZZZZschemecodehook
+  \frenchspacing
+  \let\sy\keywordfont \let\cn\constantfont
+  \let\va\variablefont \let\dt\datafont}
+
+\def\endZZZZschemecodeintext{\endgroup\ignorespaces}
+
+\def\ZZZZschemeresultintext{\ZZZZschemecodehookforresult
+  \ZZZZschemecodeintext}
+
+\let\endZZZZschemeresultintext\endZZZZschemecodeintext
+
+%
+
+\def\ZZZZschemecodehookforresult{%
+  \gdef\ZZZZschemecodehook{\let\keywordfont\constantfont
+    \let\variablefont\constantfont
+    \global\let\ZZZZschemecodehook\relax}}
+
+% \comm@nt<some-char>...text...<same-char> comments out
+% TeX source analogous to
+% \verb<some-char>...text...<same-char>.  Sp. case:
+% \comm@nt{...text...} == \comm@nt}...text...}
+
+\def\@makeother#1{\catcode`#112\relax}
+
+\def\comm@nt{%
+  \begingroup
+  \let\do\@makeother \dospecials
+  \@comm}
+
+\begingroup\catcode`\<1 \catcode`\>2
+\catcode`\{12 \catcode`\}12
+\long\gdef\@comm#1<%
+  \if#1{\long\def\@tempa ##1}<\endgroup>\else
+	\long\def\@tempa ##1#1<\endgroup>\fi
+  \@tempa>
+\endgroup
+
+% like LaTeX2e's \InputIfFileExists
+
+\ifx\InputIfFileExists\UNDEFINED
+  \def\InputIfFileExists#1#2#3{%
+    \immediate\openin0=#1\relax
+    \ifeof0\relax\immediate\closein0\relax#3%
+    \else\immediate\closein0\relax#2\input#1\relax\fi}%
+\fi
+
+\def\ZZZZinput#1{\input#1 \relax}
+
+% you may replace the above by
+%
+% \def\ZZZZinput#1{\InputIfFileExists{#1}{}{}}
+%
+% if you just want to call (La)TeX on your text
+% ignoring the portions that need to be SLaTeX'ed
+
+%use \subjobname rather than \jobname to generate
+%slatex's temp files --- this allows us to change
+%\subjobname for more control, if necessary.
+
+\let\subjobname\jobname
+
+% counter for generating temp file names
+
+\newcount\sch@mefilenamecount
+\sch@mefilenamecount=-1
+
+% To produce displayed Scheme code:
+% in LaTeX:
+% \begin{schemedisplay}
+%   ... indented program (with sev'l lines) ...
+% \end{schemedisplay}
+%
+% in TeX:
+% \schemedisplay
+%   ... indented program (with sev'l lines) ...
+% \endschemedisplay
+
+\begingroup\catcode`\|=0 \catcode`\[=1 \catcode`\]=2
+\catcode`\{=12 \catcode`\}=12 \catcode`\\=12
+|gdef|defschemedisplaytoken#1[%
+  |long|expandafter|gdef|csname ZZZZcomment#1|endcsname[%
+    |begingroup
+    |let|do|@makeother |dospecials
+    |csname ZZZZcomment|slatexenvstyle II#1|endcsname]%
+  |long|expandafter|gdef|csname ZZZZcommentlatexII#1|endcsname##1\end{#1}[%
+    |endgroup|end[#1]]%
+  |long|expandafter|gdef|csname ZZZZcommenttexII#1|endcsname##1\end#1[%
+    |endgroup|csname end#1|endcsname]%
+  |long|expandafter|gdef|csname #1|endcsname[%
+    |csname ZZZZcomment#1|endcsname]%
+  |long|expandafter|gdef|csname end#1|endcsname[%
+    |global|advance|sch@mefilenamecount by 1
+    |let|checkforfollpar0%
+    |ZZZZinput[|filehider Z|number|sch@mefilenamecount|subjobname.tex]%
+    |let|checkforfollpar1%
+    |noindentifnofollpar]]%
+|endgroup
+
+\def\undefschemedisplaytoken#1{%
+  \expandafter\gdef\csname#1\endcsname{\UNDEFINED}}
+
+% like {schemedisplay}, but displays output from a
+% Scheme evaluation.  I.e., keywords and variables
+% appear in the data font
+
+\let\defschemeresponsetoken\defschemedisplaytoken
+\let\undefschemeresponsetoken\undefschemedisplaytoken
+
+% \scheme|...program fragment...| produces Scheme code
+% in-text.  Sp. case: \scheme{...} == \scheme}...}
+
+\def\defschemetoken#1{%
+  \long\expandafter\def\csname#1\endcsname{%
+    \global\advance\sch@mefilenamecount by 1
+    \ZZZZinput{\filehider Z\number\sch@mefilenamecount\subjobname.tex}%
+    \comm@nt}}
+
+\let\undefschemetoken\undefschemedisplaytoken
+
+% \schemeresult|...program fragment...| produces a
+% Scheme code result in-text: i.e. keyword or variable
+% fonts are replaced by the data font.  Sp. case:
+% \schemeresult{...} == \schemeresult}...}
+
+\let\defschemeresulttoken\defschemetoken
+\let\undefschemeresulttoken\undefschemetoken
+
+% To produce a box of Scheme code:
+% in LaTeX:
+% \begin{schemebox}
+%   ... indented program (with sev'l lines) ...
+%  \end{schemebox}
+%
+% in TeX:
+% \schemebox
+%   ... indented program (with sev'l lines) ...
+% \endschemebox
+
+\begingroup\catcode`\|=0 \catcode`\[=1 \catcode`\]=2
+\catcode`\{=12 \catcode`\}=12 \catcode`\\=12
+|gdef|defschemeboxtoken#1[%
+  |long|expandafter|gdef|csname ZZZZcomment#1|endcsname[%
+    |begingroup
+    |let|do|@makeother |dospecials
+    |csname ZZZZcomment|slatexenvstyle II#1|endcsname]%
+  |long|expandafter|gdef|csname ZZZZcommentlatexII#1|endcsname##1\end{#1}[%
+    |endgroup|end[#1]]%
+  |long|expandafter|gdef|csname ZZZZcommenttexII#1|endcsname##1\end#1[%
+    |endgroup|csname end#1|endcsname]%
+  |long|expandafter|gdef|csname #1|endcsname[%
+    |global|advance|sch@mefilenamecount by 1
+    |ZZZZinput[|filehider Z|number|sch@mefilenamecount|subjobname.tex]%
+    |csname ZZZZcomment#1|endcsname]%
+  |long|expandafter|gdef|csname end#1|endcsname[]]%
+|endgroup
+
+\let\undefschemeboxtoken\undefschemedisplaytoken
+
+% like {schemeresponse}, but in a box
+
+\let\defschemeresponseboxtoken\defschemeboxtoken
+\let\undefschemeresponseboxtoken\undefschemeboxtoken
+
+\let\defschemetopboxtoken\defschemeboxtoken
+\let\undefschemetopboxtoken\undefschemeboxtoken
+
+% for wholesale dumping of all-Scheme files into TeX (converting
+% .scm files to .tex),
+% use
+%   \schemeinput{<filename>}
+% .scm, .ss, .s extensions optional
+
+\def\defschemeinputtoken#1{%
+  \long\expandafter\gdef\csname#1\endcsname##1{%
+    \global\advance\sch@mefilenamecount by 1
+    \ZZZZinput{\filehider Z\number\sch@mefilenamecount\subjobname.tex}}}
+
+\def\undefschemeinputtoken#1{%
+  \expandafter\gdef\csname#1\endcsname{\UNDEFINED}}
+
+% delineating a region that features typeset code
+% not usually needed, except when using \scheme and schemedisplay
+% inside macro-args and macro-definition-bodies
+% in LaTeX:
+% \begin{schemeregion}
+%   ...
+% \end{schemeregion}
+%
+% in TeX:
+% \schemeregion
+% ...
+% \endschemeregion
+
+\let\defschemeregiontoken\defschemeboxtoken
+\let\undefschemeregiontoken\undefschemeboxtoken
+
+% the SLaTeX tokens
+
+\defschemedisplaytoken{schemedisplay}
+\defschemetoken{scheme}
+\defschemeboxtoken{schemebox}
+\defschemetopboxtoken{schemetopbox}
+\defschemeresulttoken{schemeresult}
+\defschemeresponsetoken{schemeresponse}
+\defschemeresponseboxtoken{schemeresponsebox}
+\defschemeinputtoken{schemeinput}
+\defschemeregiontoken{schemeregion}
+
+% introducing new code-tokens to the keyword, variable and constant
+% categories
+
+\def\comm@ntII{%
+  \begingroup
+  \let\do\@makeother \dospecials
+  \@commII}
+
+\begingroup\catcode`\[1 \catcode`\]2
+\catcode`\{12 \catcode`\}12
+\long\gdef\@commII{[%
+  \long\def\@tempa ##1}[\endgroup]\@tempa]%
+\endgroup
+
+\let\setkeyword\comm@ntII
+\let\setvariable\comm@ntII
+\let\setconstant\comm@ntII
+\let\setdata\comm@ntII
+
+% \defschememathescape makes the succeeding grouped character an
+% escape into latex math from within Scheme code;
+% this character can't be }
+
+\let\defschememathescape\comm@ntII
+\let\undefschememathescape\comm@ntII
+
+% telling SLaTeX that a certain Scheme identifier is to
+% be replaced by the specified LaTeX expression.
+% Useful for generating ``mathematical''-looking
+% typeset code even though the corresponding Scheme
+% code is ascii as usual and doesn't violate
+% identifier-naming rules
+
+\def\setspecialsymbol{%
+  \begingroup
+  \let\do\@makeother \dospecials
+  \@commIII}
+
+\begingroup\catcode`\[1 \catcode`\]2
+\catcode`\{12 \catcode`\}12
+\long\gdef\@commIII{[%
+  \long\def\@tempa ##1}[\endgroup\@gobbleI]\@tempa]%
+\endgroup
+
+\def\@gobbleI#1{}
+
+% \unsetspecialsymbol strips Scheme identifier(s) of
+% any ``mathematical'' look lent by the above
+
+\let\unsetspecialsymbol\comm@ntII
+
+% enabling/disabling slatex
+
+\def\slatexdisable#1{\expandafter\gdef\csname#1\endcsname{}}
+
+% \schemecasesensitive takes either true or false as
+% argument
+
+\def\schemecasesensitive#1{}
+
+%for latex only: use \slatexseparateincludes before the
+%occurrence of any Scheme code in your file, if you
+%want the various \include'd files to have their own
+%pool of temporary slatex files.  This lets you juggle
+%your \include's in successive runs of LaTeX without
+%having to worry that the temp. files may interfere.
+%By default, only a single pool of temp files is used.
+%Warning: On DOS, if your \include'd files have fairly
+%similar names, avoid \slatexseparateincludes since the
+%short filenames on DOS will likely confuse the temp
+%file pools of different \include files.
+
+\def\slatexseparateincludes{%
+\gdef\include##1{{\def\subjobname{##1}%
+\sch@mefilenamecount=-1
+\@include##1 }}}
+
+% convenient abbreviations for characters
+
+\begingroup
+\catcode`\|=0
+|catcode`|\=12
+|gdef|ttbackslash{{|tt|catcode`|\=12 \}}
+|endgroup
+\mathchardef\lt="313C
+\mathchardef\gt="313E
+\begingroup
+  \catcode`\@12
+  \global\let\atsign@%
+\endgroup
+\chardef\dq=`\"
+
+% leading character of slatex filenames: . for unix to
+% keep them out of the way
+
+\def\filehider{.}
+
+% since the above doesn't work of dos, slatex on dos
+% will use a different character, and make the
+% redefinition available through the following
+
+\InputIfFileExists{xZfilhid.tex}{}{}
+
+% @ is no longer a letter for TeX
+
+\ifusinglatex\relax\else
+\catcode`\@\atcatcodebeforeslatex
+\fi
+
+\message{*** Check: Are you sure you called SLaTeX
+\slatexversion\space or later? ***}
diff --git a/collects/slibinit/doc.txt b/collects/slibinit/doc.txt
new file mode 100644
index 0000000000..9776ce05d4
--- /dev/null
+++ b/collects/slibinit/doc.txt
@@ -0,0 +1,48 @@
+
+_SLIB_ Initialization File
+--------------------------
+
+The "init.ss" file in the _slibinit_ collection is an SLIB
+initialization file (tested with version 2d2).
+
+To use SLIB in MzScheme:
+
+  (load (build-path (collection-path "slibinit") "init.ss"))
+or
+  (require (lib "load.ss" "slibinit"))     ; loads "init.ss"
+
+That's enough if the SCHEME_LIBRARY_PATH environment variable is
+defined, or if SLIB is installed as an "slib" collection (i.e., in an
+"slib" directory in the same location as the "mzlib" directory).
+
+
+SLIB is not integerated with MzScheme's module system.  Instead, SLIB
+works in the top-level environment, and it provides its own "feature"
+system using the function `require'. Unfortunately, that function name
+conflicts with MzScheme's own `require' form. In an attempt to work
+around this collision, "init.ss" re-defines `require' as syntax:
+
+  require [not in app position]  -> slib:require
+> (require '<something>)         -> (slib:require '<something>)
+  (require <any> ...)            -> (mz:require <any> ...)
+
+where `slib:require' is bound to SLIB's require function, and
+`mz:require' is bound to MzScheme's `require' syntax.
+
+
+SLIB's `implementation-vicinity' points to the PLT installation
+directory. If that directory is not writable by SLIB users, then
+initialize the installation with
+
+ (require (lib "load.ss" "slibinit"))
+ (require 'new-catalog) ; which is an SLIB `require'
+
+
+The initialization file contains one system-dependent setting:
+`most-positive-fixnum' is bound to a value that is precisely correct
+for 32-bit architectures. The precise value for a 64-bit architcture
+is in the file, but commented out. The only problem with using the
+32-bit value for a 64-bit architecture is a decrease in performance.
+
+No other changes should be necessary. Send patches to
+bugs@plt-scheme.org.
diff --git a/collects/slibinit/info.ss b/collects/slibinit/info.ss
new file mode 100644
index 0000000000..6249bda6f8
--- /dev/null
+++ b/collects/slibinit/info.ss
@@ -0,0 +1,6 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "slib init")
+  (define compile-omit-files '("init.ss" "load.ss"))
+  (define doc.txt "doc.txt"))
+
+
diff --git a/collects/slibinit/init.ss b/collects/slibinit/init.ss
new file mode 100644
index 0000000000..3afbdf6366
--- /dev/null
+++ b/collects/slibinit/init.ss
@@ -0,0 +1,395 @@
+; Derived from:                 	-*-scheme-*-
+; "Template.scm" configuration template of *features* for Scheme
+;  Copyright (C) 1991, 1992, 1993 Aubrey Jaffer.
+
+; Compatibility file for MzScheme --
+;   http://www.plt-scheme.org/software/mzscheme/
+; -- and DrScheme --
+;   http://www.plt-scheme.org/software/drscheme/
+; -- produced by Shriram Krishnamurthi <sk@cs.brown.edu>,
+; Mon Feb 10 12:03:53 CST 1997
+
+(require (lib "pretty.ss"))
+(unless (memq (system-type) '(unix beos))
+  (namespace-require '(lib "date.ss")))
+;; See hack at end:
+(require (rename mzscheme mz:require require))
+
+;;; (software-type) should be set to the generic operating system type.
+;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported.
+
+(define (software-type)
+  (case (system-type)
+    [(unix macosx) 'UNIX]
+    [(windows) 'MS-DOS]
+    [(macos) 'MACOS]
+    [else (system-type)]))
+
+;;; (scheme-implementation-type) should return the name of the scheme
+;;; implementation loading this file.
+
+(define (scheme-implementation-type) '|MzScheme|)
+
+;;; (scheme-implementation-home-page) should return a (string) URL
+;;; (Uniform Resource Locator) for this scheme implementation's home
+;;; page; or false if there isn't one.
+
+(define (scheme-implementation-home-page)
+  "http://www.plt-scheme.org/")
+
+;;; (scheme-implementation-version) should return a string describing
+;;; the version the scheme implementation loading this file.
+
+(define scheme-implementation-version version)
+
+;;; (implementation-vicinity) should be defined to be the pathname of
+;;; the directory where any auxillary files to your Scheme
+;;; implementation reside.
+
+(define implementation-vicinity
+  (let ([path
+	 (or (getenv "PLTHOME")
+	     (with-handlers ([void (lambda (x) #f)])
+	       (let ([p (collection-path "mzlib")])
+		 (let*-values ([(base name dir?) (split-path p)]
+			       [(base name dir?) (split-path base)])
+		   (and (string? base) base))))
+	     (case (system-type)
+	       ((unix macosx) "/usr/local/lib/plt")
+	       ((windows) "C:\\Program Files\\PLT")
+	       ((macos) "My Disk:plt:")))])
+    (lambda () path)))
+
+;;; (library-vicinity) should be defined to be the pathname of the
+;;; directory where files of Scheme library functions reside.
+
+(define library-vicinity
+  (let ((library-path
+	 (or
+	  ;; Use this getenv if your implementation supports it.
+	  (getenv "SCHEME_LIBRARY_PATH")
+	  ;; Use this path if your scheme does not support GETENV
+	  (with-handlers ([void
+			   (lambda (x)
+			     (error 'slib-init
+				    "can't find SCHEME_LIBRARY_PATH environment variable or \"slib\" collection"))])
+	    (collection-path "slib")))))
+    (lambda () library-path)))
+
+;;; (home-vicinity) should return the vicinity of the user's HOME
+;;; directory, the directory which typically contains files which
+;;; customize a computer environment for a user.
+
+(define (home-vicinity)
+  (find-system-path 'home-dir))
+
+;;; *FEATURES* should be set to a list of symbols describing features
+;;; of this implementation.  Suggestions for features are:
+
+(define *features*
+      '(
+	source				;can load scheme source files
+					;(slib:load-source "filename")
+	compiled			;can load compiled files
+					;(slib:load-compiled "filename")
+	rev4-report			;conforms to
+;	rev3-report			;conforms to
+;	ieee-p1178			;conforms to
+;	sicp				;runs code from Structure and
+					;Interpretation of Computer
+					;Programs by Abelson and Sussman.
+	rev4-optional-procedures	;LIST-TAIL, STRING->LIST,
+					;LIST->STRING, STRING-COPY,
+					;STRING-FILL!, LIST->VECTOR,
+					;VECTOR->LIST, and VECTOR-FILL!
+;	rev2-procedures			;SUBSTRING-MOVE-LEFT!,
+					;SUBSTRING-MOVE-RIGHT!,
+					;SUBSTRING-FILL!,
+					;STRING-NULL?, APPEND!, 1+,
+					;-1+, <?, <=?, =?, >?, >=?
+	multiarg/and-			;/ and - can take more than 2 args.
+	multiarg-apply			;APPLY can take more than 2 args.
+	rationalize
+	delay				;has DELAY and FORCE
+	with-file			;has WITH-INPUT-FROM-FILE and
+					;WITH-OUTPUT-FROM-FILE
+	string-port			;has CALL-WITH-INPUT-STRING and
+					;CALL-WITH-OUTPUT-STRING
+;	transcript			;TRANSCRIPT-ON and TRANSCRIPT-OFF
+	char-ready?
+	macro				;has R4RS high level macros
+	defmacro			;has Common Lisp DEFMACRO
+	eval				;SLIB:EVAL is single argument eval
+;	record				;has user defined data structures
+	values				;proposed multiple values
+	dynamic-wind			;proposed dynamic-wind
+	ieee-floating-point		;conforms to
+	full-continuation		;can return multiple times
+;	object-hash			;has OBJECT-HASH
+
+;	sort
+;	queue				;queues
+	pretty-print
+;	object->string
+;	format
+;	trace				;has macros: TRACE and UNTRACE
+;	compiler			;has (COMPILER)
+;	ed				;(ED) is editor
+	system				;posix (system <string>)
+	getenv				;posix (getenv <string>)
+	program-arguments		;returns list of strings (argv)
+;	Xwindows			;X support
+;	curses				;screen management package
+;	termcap				;terminal description package
+;	terminfo			;sysV terminal description
+	current-time			;returns time in seconds since 1/1/1970
+	))
+
+(define program-arguments
+  (lambda ()
+    (vector->list (current-command-line-arguments))))
+
+(define current-time
+  ;; Gives time since 1/1/1970 ...
+  ;;   ... GMT for Unix, Windows, and Mac OS X.
+  ;;   ... local time for Mac OS.
+  (if (memq (system-type) '(unix macosx windows))
+      current-seconds
+      (let ([zero (find-seconds 0 0 0 1 1 1970)])
+	(lambda ()
+	  (- (current-seconds) zero)))))
+
+;;; Remainder is modifications of existing code in Template.scm.
+
+;;; (OUTPUT-PORT-WIDTH <port>)
+(define (output-port-width . arg) 79)
+
+;;; (OUTPUT-PORT-HEIGHT <port>)
+(define (output-port-height . arg) 24)
+
+;;; (CURRENT-ERROR-PORT)
+;; Already in MzScheme
+
+;;; (TMPNAM) makes a temporary file name.
+(define tmpnam (let ((cntr 100))
+		 (lambda () (set! cntr (+ 1 cntr))
+			 (string-append "slib_" (number->string cntr)))))
+
+;;; (FILE-EXISTS? <string>)
+;; Already in MzScheme
+
+;;; (DELETE-FILE <string>)
+;; Already in MzScheme
+
+;;; FORCE-OUTPUT flushes any pending output on optional arg output port
+;;; use this definition if your system doesn't have such a procedure.
+(define force-output flush-output)
+
+;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string
+;;; port versions of CALL-WITH-*PUT-FILE.
+
+(define call-with-input-string
+  (lambda (string thunk)
+    (parameterize ((current-input-port (open-input-string string)))
+      (thunk))))
+
+(define call-with-output-string
+  (lambda (receiver)
+    (let ((sp (open-output-string)))
+      (receiver sp)
+      (get-output-string sp))))
+
+;;; "rationalize" adjunct procedures.
+(define (find-ratio x e)
+  (let ((rat (rationalize x e)))
+    (list (numerator rat) (denominator rat))))
+(define (find-ratio-between x y)
+  (find-ratio (/ (+ x y) 2) (/ (- x y) 2)))
+
+;;; CHAR-CODE-LIMIT is one greater than the largest integer which can
+;;; be returned by CHAR->INTEGER.
+(define char-code-limit 256)
+
+;;; MOST-POSITIVE-FIXNUM is used in modular.scm
+(define most-positive-fixnum #x3FFFFFFF) ; 30 bits on 32-bit machines
+; (define most-positive-fixnum #x3FFFFFFFFFFFFFFF) ; 62 bits on 64-bit machines
+
+;;; Return argument
+(define (identity x) x)
+
+;;; If your implementation provides eval SLIB:EVAL is single argument
+;;; eval using the top-level (user) environment.
+(define slib:eval eval)
+
+;;; If your implementation provides R4RS macros:
+;(define macro:eval slib:eval)
+;(define macro:load load)
+
+(define gentemp
+  (let ((*gensym-counter* -1))
+    (lambda ()
+      (set! *gensym-counter* (+ *gensym-counter* 1))
+      (string->symbol
+       (string-append "slib:G" (number->string *gensym-counter*))))))
+
+
+(define *defmacros*
+  (list (cons 'defmacro
+	      (lambda (name parms . body)
+		`(set! *defmacros* (cons (cons ',name (lambda ,parms ,@body))
+					 *defmacros*))))))
+(define (defmacro? m) (and (assq m *defmacros*) #t))
+
+(define (macroexpand-1 e)
+  (if (pair? e)
+      (let ((a (car e)))
+	(cond ((symbol? a) (set! a (assq a *defmacros*))
+	       (if a (apply (cdr a) (cdr e)) e))
+	      (else e)))
+      e))
+
+(define (macroexpand e)
+  (if (pair? e)
+      (let ((a (car e)))
+	(cond ((symbol? a)
+	       (set! a (assq a *defmacros*))
+	       (if a (macroexpand (apply (cdr a) (cdr e))) e))
+	      (else e)))
+      e))
+
+(define base:eval slib:eval)
+(define (defmacro:eval x) (base:eval (defmacro:expand* x)))
+(define (defmacro:expand* x)
+  (slib:require 'defmacroexpand) 
+  (apply defmacro:expand* x '()))
+
+(define (defmacro:load <pathname>)
+  (slib:eval-load <pathname> defmacro:eval))
+
+(define (slib:eval-load <pathname> evl)
+  (if (not (file-exists? <pathname>))
+      (set! <pathname> (string-append <pathname> (scheme-file-suffix))))
+  (call-with-input-file <pathname>
+    (lambda (port)
+      (let ((old-load-pathname *load-pathname*))
+	(set! *load-pathname* <pathname>)
+	(do ((o (read port) (read port)))
+	    ((eof-object? o))
+	  (evl o))
+	(set! *load-pathname* old-load-pathname)))))
+
+;;; define an error procedure for the library
+(define slib:error
+  (lambda args
+    (let ((cep (current-error-port)))
+      (if (provided? 'trace) (print-call-stack cep))
+      (apply error "Error:" args))))
+
+;;; define these as appropriate for your system.
+(define slib:tab (integer->char 9))
+(define slib:form-feed (integer->char 12))
+
+;;; Support for older versions of Scheme.  Not enough code for its own file.
+(define (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l))
+(define t #t)
+(define nil #f)
+
+;;; Define these if your implementation's syntax can support it and if
+;;; they are not already defined.
+
+(define 1+ add1)
+(define -1+ sub1)
+(define 1- -1+)
+
+(define in-vicinity 
+  (lambda args
+    (let loop ([args args])
+      (cond
+       [(null? (cdr args)) (car args)]
+       [(string=? "" (car args)) (loop (cdr args))]
+       [else (let ([v (loop (cdr args))])
+	       (build-path (car args) v))]))))
+
+;;; Define SLIB:EXIT to be the implementation procedure to exit or
+;;; return if exitting not supported.
+(define slib:exit exit)
+
+;;; Here for backward compatability
+(define scheme-file-suffix
+  (let ((suffix (case (software-type)
+		  ((NOSVE) "_scm")
+		  (else ".scm"))))
+    (lambda () suffix)))
+
+;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever
+;;; suffix all the module files in SLIB have.  See feature 'SOURCE.
+
+(define (slib:load-source f) (load (string-append f ".scm")))
+
+;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced
+;;; by compiling "foo.scm" if this implementation can compile files.
+;;; See feature 'COMPILED.
+
+(define (slib:load-compiled f) (load (string-append f ".zo")))
+
+;;; At this point SLIB:LOAD must be able to load SLIB files.
+
+(define slib:load slib:load-source)
+
+(define slib:warn
+  (lambda args
+    (let ((cep (current-error-port)))
+      (if (provided? 'trace) (print-call-stack cep))
+      (display "Warn: " cep)
+      (for-each (lambda (x) (display x cep)) args)
+      (newline cep))))
+
+(slib:load (in-vicinity (library-vicinity) "require"))
+
+;;; Hack `require' to try to work with both SLIB
+;;; and MzScheme:
+
+(define slib:require require)
+(define-syntax (require stx)
+  (syntax-case stx (quote)
+    [_
+     (identifier? stx)
+     #'slib:require]
+    [(_ (quote something))
+     #'(slib:require (quote something))]
+    [(_ req ...)
+     (if (eq? 'top-level (syntax-local-context))
+	 #'(mz:require req ...)
+	 #'(slib:require req ...))]))
+
+;; The rest are from:
+
+;;;"DrScheme.init" Initialization for SLIB for DrScheme	-*-scheme-*-
+;;  Friedrich Dominicus <frido@q-software-solutions.com>
+;;  Newsgroups: comp.lang.scheme
+;;  Date: 02 Oct 2000 09:24:57 +0200
+
+(define (make-exchanger obj)
+  (lambda (rep) (let ((old obj)) (set! obj rep) old)))
+(define (open-file filename modes)
+  (case modes
+    ((r rb) (open-input-file filename))
+    ((w wb) (open-output-file filename))
+    (else (slib:error 'open-file 'mode? modes))))
+(define (port? port) (or (input-port? port) (output-port? port)))
+(define (call-with-open-ports . ports)
+  (define proc (car ports))
+  (cond ((procedure? proc) (set! ports (cdr ports)))
+	(else (set! ports (reverse ports))
+	      (set! proc (car ports))
+	      (set! ports (reverse (cdr ports)))))
+  (let ((ans (apply proc ports)))
+    (for-each close-port ports)
+    ans))
+(define (close-port port)
+  (cond ((input-port? port)
+	 (close-input-port port)
+	 (if (output-port? port) (close-output-port port)))
+	((output-port? port) (close-output-port port))
+	(else (slib:error 'close-port 'port? port))))
+
diff --git a/collects/slibinit/load.ss b/collects/slibinit/load.ss
new file mode 100644
index 0000000000..3505063ec1
--- /dev/null
+++ b/collects/slibinit/load.ss
@@ -0,0 +1,5 @@
+
+(module load mzscheme
+  ;; affects the namespace:
+  (load (build-path (collection-path "slibinit") "init.ss")))
+
diff --git a/collects/slideshow/cmdline.ss b/collects/slideshow/cmdline.ss
new file mode 100644
index 0000000000..a1f6bd5293
--- /dev/null
+++ b/collects/slideshow/cmdline.ss
@@ -0,0 +1,204 @@
+
+(module cmdline mzscheme
+  (require (lib "class.ss")
+           (lib "unitsig.ss")
+	   (lib "file.ss")
+	   (lib "etc.ss")
+	   (lib "contract.ss")
+	   (lib "mred.ss" "mred")
+	   (lib "cmdline.ss")
+	   (lib "mrpict.ss" "texpict")
+	   (lib "utils.ss" "texpict")
+	   (lib "math.ss")
+	   "sig.ss"
+	   (prefix start: "start-param.ss"))
+
+  (provide cmdline@)
+
+  (define-syntax (define-at-end stx)
+    (syntax-case stx ()
+      [(_ sig body ...)
+       (with-syntax ([(id ...) (let ([expr
+				      (local-expand 
+				       #'(signature->symbols sig)
+				       'expression
+				       null)])
+				 (map (lambda (id)
+					(datum->syntax-object
+					 #'sig
+					 (syntax-e id)))
+				      (vector->list
+				       (syntax-e (cadr (syntax->list expr))))))])
+	 #'(define-values (id ...)
+	     (let ()
+	       body ...
+	       (values id ...))))]))
+
+  (define cmdline@
+    (unit/sig cmdline^
+      (import)
+      
+      (define-at-end cmdline^
+	(define-values (screen-w screen-h) (values 1024 768))
+	(define base-font-size 32)
+
+	(define-values (actual-screen-w actual-screen-h) (get-display-size #t))
+	(define-values (use-screen-w use-screen-h) (values actual-screen-w actual-screen-h))
+
+	(define condense? #f)
+	(define printing? #f)
+	(define native-printing? #f)
+	(define commentary? #f)
+	(define show-gauge? #f)
+	(define keep-titlebar? #f)
+	(define show-page-numbers? #t)
+	(define quad-view? #f)
+	(define pixel-scale (if quad-view? 1/2 1))
+	(define print-slide-seconds? #f)
+	(define use-offscreen? #t)
+	(define use-transitions? use-offscreen?)
+	(define talk-duration-minutes #f)
+	(define trust-me? #f)
+	(define no-squash? #t)
+	(define two-frames? #f)
+	(define use-prefetch? #t)
+	(define use-prefetch-in-preview? #f)
+	(define print-target #f)
+	(define smoothing? #t)
+        
+	(define init-page 0)
+	
+	(define file-to-load
+	  (command-line
+	   "slideshow"
+	   (current-command-line-arguments)
+	   [once-each
+	    (("-d" "--preview") "show next-slide preview (useful on a non-mirroring display)" 
+	     (set! two-frames? #t))
+	    (("-p" "--print") "print (always to PostScript, except under Windows and Mac OS)"
+	     (set! printing? #t)
+	     (set! native-printing? #t))
+	    (("-P" "--ps") "print to PostScript"
+	     (set! printing? #t))
+	    (("-o") file "set output file for PostScript printing"
+	     (set! print-target file))
+	    (("-c" "--condense") "condense"
+	     (set! condense? #t))
+	    (("-t" "--start") page "set the starting page"
+	     (let ([n (string->number page)])
+	       (unless (and n 
+			    (integer? n)
+			    (exact? n)
+			    (positive? n))
+		 (error 'slideshow "argument to -t is not a positive exact integer: ~a" page))
+	       (set! init-page (sub1 n))))
+	    (("-q" "--quad") "show four slides at a time"
+	     (set! quad-view? #t)
+	     (set! pixel-scale 1/2))
+	    (("-n" "--no-stretch") "don't stretch the slide window to fit the screen"
+	     (when (> actual-screen-w screen-w)
+	       (set! actual-screen-w screen-w)
+	       (set! actual-screen-h screen-h)))
+	    (("-s" "--size") w h "use a <w> by <h> window"
+	     (let ([nw (string->number w)]
+		   [nh (string->number h)])
+	       (unless (and nw (< 0 nw 10000))
+		 (error 'slideshow "bad width: ~e" w))
+	       (unless (and nw (< 0 nh 10000))
+		 (error 'slideshow "bad height: ~e" h))
+	       (set! actual-screen-w nw)
+	       (set! actual-screen-h nh)))
+	    (("-a" "--squash") "scale to full window, even if not 4:3 aspect"
+	     (set! no-squash? #f))
+	    (("-m" "--no-smoothing") 
+             "disable anti-aliased drawing (usually faster)"
+             (set! smoothing? #f))
+            ;; Disable --minutes, because it's not used
+	    #;
+	    (("-m" "--minutes") min "set talk duration in minutes"
+	     (let ([n (string->number min)])
+	       (unless (and n 
+			    (integer? n)
+			    (exact? n)
+			    (positive? n))
+		 (error 'slideshow "argument to -m is not a positive exact integer: ~a" min))
+	       (set! talk-duration-minutes n)))
+	    (("-i" "--immediate") "no transitions"
+	     (set! use-transitions? #f))
+	    (("--trust") "allow slide program to write files and make network connections"
+	     (set! trust-me? #t))
+	    (("--no-prefetch") "disable next-slide prefetch"
+	     (set! use-prefetch? #f))
+	    (("--preview-prefetch") "use prefetch for next-slide preview"
+	     (set! use-prefetch-in-preview? #t))
+	    (("--keep-titlebar") "give the slide window a title bar and resize border"
+	     (set! keep-titlebar? #t))
+	    (("--comment") "display commentary"
+	     (set! commentary? #t))
+	    (("--time") "time seconds per slide" (set! print-slide-seconds? #t))]
+	   [args slide-module-file
+		 (cond
+		  [(null? slide-module-file) #f]
+		  [(null? (cdr slide-module-file)) (car slide-module-file)]
+		  [else (error 'slideshow
+			       "expects at most one module file, given ~a: ~s"
+			       (length slide-module-file)
+			       slide-module-file)])]))
+
+	(when (or printing? condense?)
+	  (set! use-transitions? #f))
+
+	(when printing?
+	  (set! use-offscreen? #f)
+	  (set! use-prefetch? #f)
+	  (set! keep-titlebar? #t))
+
+	(dc-for-text-size
+	 (if printing?
+	     (let ([p (let ([pss (make-object ps-setup%)])
+			(send pss set-mode 'file)
+			(send pss set-file
+			      (if print-target
+				  print-target
+				  (if file-to-load
+				      (path-replace-suffix (file-name-from-path file-to-load)
+							   (if quad-view?
+							       "-4u.ps"
+							       ".ps"))
+					"untitled.ps")))
+			(send pss set-orientation 'landscape)
+			(parameterize ([current-ps-setup pss])
+			  (if (and native-printing?
+				   (not (memq (system-type) '(unix))))
+			      ;; Make printer-dc%
+			      (begin
+				(when (can-get-page-setup-from-user?)
+				  (let ([v (get-page-setup-from-user)])
+				    (if v
+					(send pss copy-from v)
+					(exit))))
+				(make-object printer-dc% #f))
+			      ;; Make ps-dc%:
+			      (make-object post-script-dc% (not print-target) #f #t #f))))])
+	       ;; Init page, set "screen" size, etc.:
+	       (unless (send p ok?) (exit))
+	       (send p start-doc "Slides")
+	       (send p start-page)
+	       (set!-values (actual-screen-w actual-screen-h) (send p get-size))
+	       p)
+	     
+	     ;; Bitmaps give same size as the screen:
+	     (make-object bitmap-dc% (make-object bitmap% 1 1))))
+
+	(start:trust-me? trust-me?)
+	(start:file-to-load file-to-load)
+
+	(set!-values (use-screen-w use-screen-h)
+		     (if no-squash?
+			 (if (< (/ actual-screen-w screen-w)
+				(/ actual-screen-h screen-h))
+			     (values actual-screen-w
+				     (floor (* (/ actual-screen-w screen-w) screen-h)))
+			     (values (floor (* (/ actual-screen-h screen-h) screen-w))
+				     actual-screen-h))
+			 (values actual-screen-w actual-screen-h)))))))
diff --git a/collects/slideshow/code.ss b/collects/slideshow/code.ss
new file mode 100644
index 0000000000..fb1ff75f5a
--- /dev/null
+++ b/collects/slideshow/code.ss
@@ -0,0 +1,184 @@
+
+(module code "slideshow.ss"
+  (require (lib "code.ss" "texpict")
+	   (lib "unitsig.ss"))
+  (require-for-syntax (lib "list.ss"))
+
+  (define-values/invoke-unit/sig code^
+    code@
+    #f
+    code-params^)
+
+  (define-code code typeset-code)
+
+  (provide code)
+  (provide-signature-elements code^)
+    
+  (provide define-exec-code/scale
+	   define-exec-code)
+  (define-syntax (define-exec-code/scale stx)
+    (define (drop-to-run l)
+      (map (lambda (x)
+             (cond
+	      [(and (pair? (syntax-e x))
+		    (eq? 'local (syntax-e (car (syntax-e x)))))
+	       (let ([l (syntax->list x)])
+		 (list* 'local
+			(drop-to-run (syntax->list (cadr l)))
+			(cddr l)))]
+	      [(and (pair? (syntax-e x))
+		    (eq? 'define (syntax-e (car (syntax-e x)))))
+	       (let ([l (syntax->list x)])
+		 (list* 'define
+			(cadr l)
+			(drop-to-run (cddr l))))]
+	      [else x]))
+           (filter (lambda (x)
+                     (cond
+		      [(eq? '_ (syntax-e x))
+		       #f]
+		      [(eq? '... (syntax-e x))
+		       #f]
+		      [(eq? 'code:blank (syntax-e x))
+		       #f]
+		      [(and (pair? (syntax-e x))
+			    (eq? 'code:comment (syntax-e (car (syntax-e x)))))
+		       #f]
+		      [(and (pair? (syntax-e x))
+			    (eq? 'code:contract (syntax-e (car (syntax-e x)))))
+		       #f]
+		      [(and (pair? (syntax-e x))
+			    (eq? 'unsyntax (syntax-e (car (syntax-e x)))))
+		       #f]
+		      [else #t]))
+                   l)))
+    (define (drop-to-show l)
+      (foldr (lambda (x r)
+               (cond
+		[(and (identifier? x) (eq? '_ (syntax-e x)))
+		 (cdr r)]
+		[(and (pair? (syntax-e x))
+		      (eq? 'local (syntax-e (car (syntax-e x)))))
+		 (cons
+		  (let ([l (syntax->list x)])
+		    (datum->syntax-object 
+		     x
+		     (list* (car l)
+			    (datum->syntax-object
+			     (cadr l)
+			     (drop-to-show (syntax->list (cadr l)))
+			     (cadr l))
+			    (cddr l))
+		     x))
+		  r)]
+		[(and (pair? (syntax-e x))
+		      (eq? 'cond (syntax-e (car (syntax-e x)))))
+		 (cons
+		  (let ([l (syntax->list x)])
+		    (datum->syntax-object 
+		     x
+		     (list* (car l)
+			    (drop-to-show (cdr l)))
+		     x))
+		  r)]
+		[(and (pair? (syntax-e x))
+		      (eq? 'define (syntax-e (car (syntax-e x)))))
+		 (cons (let ([l (syntax->list x)])
+			 (datum->syntax-object 
+			  x
+			  (list* (car l)
+				 (cadr l)
+				 (drop-to-show (cddr l)))
+			  x))
+		       r)]
+		[else (cons x r)]))
+             empty
+             l))
+
+    (define (to-string c)
+      (let* ([s (open-output-string)]
+	     [l (syntax->list c)]
+	     [init-col (or (syntax-column (first l)) 0)]
+	     [col init-col]
+	     [line (or (syntax-line (first l)) 0)])
+	(define (advance c init-line!)
+	  (let ([c (syntax-column c)]
+		[l (syntax-line c)])
+	    (when (and l (l . > . line))
+	      (newline)
+	      (set! line l)
+	      (init-line!))
+	    (when c
+	      (display (make-string (max 0 (- c col)) #\space))
+	      (set! col c))))
+	(parameterize ([current-output-port s]
+		       [read-case-sensitive #t])
+	  (define (loop init-line!)
+	    (lambda (c)
+	      (cond
+	       [(eq? 'code:blank (syntax-e c))
+		(advance c init-line!)]
+	       [(eq? '_ (syntax-e c)) (void)]
+	       [(eq? '... (syntax-e c))
+		(void)]
+	       [(and (pair? (syntax-e c))
+		     (eq? (syntax-e (car (syntax-e c))) 'code:comment))
+		(advance c init-line!)
+		(printf "; ")
+		(display (syntax-e (cadr (syntax->list c))))]
+	       [(and (pair? (syntax-e c))
+		     (eq? (syntax-e (car (syntax-e c))) 'code:contract))
+		(advance c init-line!)
+		(printf "; ")
+		(let* ([l (cdr (syntax->list c))]
+		       [s-col (or (syntax-column (first l)) col)])
+		  (set! col s-col)
+		  (for-each (loop (lambda ()
+				    (set! col s-col)
+				    (printf "; ")))
+			    l))]
+	       [(and (pair? (syntax-e c))
+		     (eq? (syntax-e (car (syntax-e c))) 'quote))
+		(advance c init-line!)
+		(printf "'")
+		(let ([i (cadr (syntax->list c))])
+		  (set! col (or (syntax-column i) col))
+		  ((loop init-line!) i))]
+	       [(pair? (syntax-e c))
+		(advance c init-line!)
+		(printf "(")
+		(set! col (+ col 1))
+		(map (loop init-line!) (syntax->list c))
+		(printf ")")
+		(set! col (+ col 1))]
+	       [else
+		(advance c init-line!)
+		(let ([s (format "~s" (syntax-e c))])
+		  (set! col (+ col (string-length s)))
+		  (display s))])))
+	  (for-each (loop (lambda () (set! col init-col))) l))
+	(get-output-string s)))
+    
+    (syntax-case stx ()
+      [(_ s (showable-name runnable-name string-name) . c)
+       #`(begin
+           (define runnable-name
+             (quote-syntax
+              (begin
+                #,@(drop-to-run (syntax->list #'c)))))
+           (define showable-name
+	     (scale/improve-new-text
+	      (code
+	       #,@(drop-to-show (syntax->list #'c)))
+	      s))
+	   (define string-name
+	     #,(to-string #'c)))]))
+
+  (define-syntax define-exec-code
+    (syntax-rules ()
+      [(_ (a b c) . r)
+       (define-exec-code/scale 1 (a b c) . r)])))
+
+
+
+
diff --git a/collects/slideshow/core.ss b/collects/slideshow/core.ss
new file mode 100644
index 0000000000..288085dfc7
--- /dev/null
+++ b/collects/slideshow/core.ss
@@ -0,0 +1,810 @@
+
+(module core mzscheme
+  (require (lib "class.ss")
+           (lib "unitsig.ss")
+	   (lib "file.ss")
+	   (lib "etc.ss")
+	   (lib "contract.ss")
+	   (lib "mred.ss" "mred")
+	   (lib "mrpict.ss" "texpict")
+	   (lib "utils.ss" "texpict")
+	   (lib "math.ss")
+	   "sig.ss"
+	   "util.ss")
+
+  (provide core@ 
+	   zero-inset)
+
+  ;; We create structs just once, so that all instances of the 
+  ;; core share the types.
+  (define/provide-struct sliderec (drawer        ; dc<%> x y -> void
+				   title         ; string
+				   comment       ; #f or just-a-comment
+				   page          ; int
+				   page-count    ; int
+				   inset         ; sinset
+				   transitions)) ; canvas% bitmap% -> 'went or delay-msecs
+  (define/provide-struct just-a-comment (content)) ; content is list of strings and picts
+  (define/provide-struct sinset (l t r b))
+  (define/provide-struct click-region (left top right bottom thunk show-click?))
+
+  (define zero-inset (make-sinset 0 0 0 0))
+      
+  (define core@
+    (unit/sig core^
+      (import config^ (viewer : viewer^))
+      (rename (local:condense? condense?)
+	      (local:printing? printing?))
+
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;                    Setup                      ;;
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+      (define local:condense? condense?)
+      (define local:printing? printing?)
+
+      (define font-size base-font-size)
+      (define gap-size (* 3/4 font-size))
+      (define line-sep 2)
+      (define title-size (+ font-size 4))
+      (define main-font (if (and (not printing?)
+				 (string=? (get-family-builtin-face 'default) " Sans"))
+			    'default
+			    'swiss))
+      (define current-main-font (make-parameter main-font))
+
+      (when (not (and (= use-screen-w screen-w)
+		      (= use-screen-h screen-h)
+		      (= pixel-scale 1)))
+	(current-expected-text-scale (list (* (/ use-screen-w screen-w) pixel-scale)
+					   (* (/ use-screen-h screen-h) pixel-scale))))
+
+      (define red "red")
+      (define green "forest green")
+      (define blue "blue")
+      (define purple "purple")
+      (define orange "orange")
+
+      (define current-font-size (make-parameter 
+				 font-size
+				 (lambda (x)
+				   (unless (and (number? x)
+						(integer? x)
+						(exact? x)
+						(positive? x))
+				     (raise-type-error 'current-font-size "exact non-negative integer" x))
+				   x)))
+
+      (define current-title-color (make-parameter
+				   green
+				   (lambda (x)
+				     (unless (or (string? x)
+						 (x . is-a? . color%))
+				       (raise-type-error 'current-title-color
+							 "string or color% object"
+							 x))
+				     x)))
+
+      (define (t s) (text s (current-main-font) (current-font-size)))
+      (define (it s) (text s `(italic . ,(current-main-font)) (current-font-size)))
+      (define (bt s) (text s `(bold . ,(current-main-font)) (current-font-size)))
+      (define (bit s) (text s `(bold italic . ,(current-main-font)) (current-font-size)))
+      (define (tt s) (text s '(bold . modern) (current-font-size)))
+      (define (rt s) (text s 'roman (current-font-size)))
+      (define (titlet s) (colorize (text s 
+					 `(bold . ,(current-main-font)) 
+					 title-size)
+				   (current-title-color)))
+
+      (define (with-font f k)
+	(parameterize ([current-main-font f])
+	  (k)))
+
+      (define (tt* . l) (apply vl-append line-sep (map tt l)))
+
+      (define bullet (if (send (dc-for-text-size) glyph-exists? #\u2022)
+			 (t "\u2022")
+			 (baseless
+			  (cc-superimpose (disk (/ gap-size 2)) 
+					  (blank 0 gap-size)))))
+      (define o-bullet (baseless
+			(cc-superimpose (circle (/ gap-size 2)) 
+					(blank 0 gap-size))))
+
+
+      (define margin 20)
+      (define-values (client-w client-h) (values (- screen-w (* margin 2))
+						 (- screen-h (* margin 2))))
+      (define full-page (blank client-w client-h))
+      (define title-h (pict-height (titlet "Hi")))
+      (define (mk-titleless-page)
+	(inset full-page 0 (- 0 title-h (* 2 gap-size)) 0 0))
+      (define titleless-page (mk-titleless-page))
+
+      (define (set-margin! m)
+	(set! margin m)
+	(set! client-w (- screen-w (* 2 margin)))
+	(set! client-h (- screen-h (* 2 margin)))
+	(set! full-page (blank client-w client-h))
+	(set! titleless-page (mk-titleless-page)))
+      (define (get-margin) margin)
+      (define (get-client-w) client-w)
+      (define (get-client-h) client-h)
+      (define (get-full-page) full-page)
+      (define (get-titleless-page) titleless-page)
+
+      (define (set-title-h! h)
+	(set! title-h h)
+	(set! titleless-page (mk-titleless-page)))
+      (define (get-title-h) title-h)
+
+      (define (set-use-background-frame! on?)
+	(viewer:set-use-background-frame! (and on? #t)))
+
+      (define (enable-click-advance! on?)
+	(viewer:enable-click-advance! (and on? #t)))
+
+      (define (set-page-numbers-visible! on?)
+	(viewer:set-page-numbers-visible! (and on? #t)))
+
+      (define current-page-number-font 
+	(make-parameter
+	 (make-object font% 10 'default 'normal 'normal)
+	 (lambda (f)
+	   (unless (f . is-a? . font%)
+	     (raise-type-error 'current-page-number-font "font%" f))
+	   f)))
+      (define current-page-number-color 
+	(make-parameter (make-object color% "black")
+			(lambda (s)
+			  (unless (s . is-a? . color%)
+			    (raise-type-error 'current-page-number-color "color%" s))
+			  s)))
+      
+      (define page-number 1)
+
+      (define (add-slide! pict title comment page-count inset)
+	(viewer:add-talk-slide! 
+	 (make-sliderec (make-pict-drawer pict)
+			title 
+			comment
+			page-number
+			page-count
+			inset
+			null))
+	(set! page-number (+ page-number page-count)))
+
+      (define (skip-slides n)
+	(set! page-number (+ page-number n)))
+
+      (define (evenize-width p)
+	(let ([w (pict-width p)])
+	  ;; Force even size:
+	  (inset p 0 0 (+ (- (ceiling w) w)
+			  (modulo (ceiling w) 2)) 0)))
+
+      (define (apply-slide-inset sinset pict)
+	(inset pict 
+	       (- (sinset-l sinset))
+	       (- (sinset-t sinset))
+	       (- (sinset-r sinset))
+	       (- (sinset-b sinset))))
+
+      (define (do-add-slide! content title comment page-count inset)
+	(add-slide!
+	 (ct-superimpose
+	  (apply-slide-inset inset full-page)
+	  content)
+	 title
+	 comment
+	 page-count
+	 inset))
+
+      (define default-slide-assembler
+	(lambda (s v-sep p)
+	  (apply vc-append v-sep
+		 (if s
+		     (list (evenize-width (titlet s)) p)
+		     (list p)))))
+
+      (define current-slide-assembler
+	(make-parameter default-slide-assembler))
+
+      (define-struct name-only (title))
+
+      (define (one-slide/title/inset do-add-slide! use-assem? process v-sep skipped-pages s inset . x) 
+	(let-values ([(x c)
+		      (let loop ([x x][c #f][r null])
+			(cond
+			 [(null? x) (values (reverse! r) c)]
+			 [(just-a-comment? (car x))
+			  (loop (cdr x) (car x) r)]
+			 [else
+			  (loop (cdr x) c (cons (car x) r))]))])
+	  (let ([content ((if use-assem?
+			      (current-slide-assembler)
+			      default-slide-assembler)
+			  (and (not (name-only? s)) s)
+			  v-sep
+			  (apply vc-append 
+				 gap-size
+				 (map evenize-width (process x))))])
+	    (do-add-slide!
+	     content
+	     (if (name-only? s) (name-only-title s) s)
+	     c
+	     (+ 1 skipped-pages)
+	     inset))))
+
+      (define (slide-error nested string . args)
+	(apply error
+	       (let loop ([nested nested])
+		 (if (null? nested)
+		     'slide*
+		     (string->symbol (format "~a of ~a" (car nested) (loop (cdr nested))))))
+	       string
+	       args))
+
+      (define (do-slide/title/tall/inset do-add-slide! use-assem? skip-ok? process v-sep s inset . x)
+	;; Check slides:
+	(let loop ([l x][nested null])
+	  (or (null? l)
+	      (cond
+	       [(pict? (car l)) (loop (cdr l) nested)]
+	       [(just-a-comment? (car l)) (loop (cdr l) nested)]
+	       [(memq (car l) '(next next!)) (and (or (pair? l) 
+						      (slide-error nested "argument sequence contains 'next at end"))
+						  (loop (cdr l) nested))]
+	       [(memq (car l) '(alts alts~)) (and (or (pair? (cdr l))
+						      (slide-error nested "argument sequence contains '~a at end" (car l)))
+						  (let ([a (cadr l)])
+						    (and (or (list? a)
+							     (slide-error nested "non-list after '~a: ~e" (car l) a))
+							 (andmap (lambda (sl)
+								   (unless (list? sl)
+								     (slide-error nested "non-list in list after '~a: ~e" 
+										  (car l) sl))
+								   (loop sl (cons (car l) nested)))
+								 a)))
+						  (loop (cddr l) nested))]
+	       [(eq? (car l) 'nothing) (loop (cdr l) nested)]
+	       [else #f])
+	      (slide-error nested "argument sequence contains a bad element: ~e" (car l))))
+
+	(let loop ([l x][r null][comment #f][skip-all? #f][skipped 0])
+	  (cond
+	   [(null? l) 
+	    (if skip-all?
+		(add1 skipped)
+		(begin
+		  (apply one-slide/title/inset do-add-slide! use-assem? process v-sep skipped s inset (reverse r))
+		  0))]
+	   [(memq (car l) '(nothing))
+	    (loop (cdr l) r comment skip-all? skipped)]
+	   [(memq (car l) '(next next!))
+	    (let ([skip? (or skip-all? (and condense? skip-ok? (eq? (car l) 'next)))])
+	      (let ([skipped (if skip?
+				 (add1 skipped)
+				 (begin
+				   (apply one-slide/title/inset do-add-slide! use-assem? process v-sep skipped s inset (reverse r))
+				   0))])
+		(loop (cdr l) r comment skip-all? skipped)))]
+	   [(memq (car l) '(alts alts~)) 
+	    (let ([rest (cddr l)])
+	      (let aloop ([al (cadr l)][skipped skipped])
+		(cond
+		 [(null? al) ;; only happens when al starts out null
+		  (loop rest r comment skip-all? skipped)]
+		 [(null? (cdr al))
+		  (loop (append (car al) rest) r comment skip-all? skipped)]
+		 [else
+		  (let ([skip? (or skip-all? (and condense? skip-ok? (eq? (car l) 'alts~)))])
+		    (let ([skipped (loop (car al) r comment skip? skipped)])
+		      (aloop (cdr al) skipped)))])))]
+	   [else (loop (cdr l) (cons (car l) r) comment skip-all? skipped)])))
+
+      (define (make-slide-inset l t r b)
+	(make-sinset l t r b))
+
+      (define (slide/title/tall/inset/gap v-sep s inset . x)
+	(apply do-slide/title/tall/inset do-add-slide! #t #t values v-sep s inset x))
+
+      (define (slide/title/tall/inset s inset . x)
+	(apply slide/title/tall/inset/gap gap-size s inset x))
+
+      (define (slide/name/tall/inset s inset . x)
+	(apply slide/title/tall/inset (make-name-only s) inset x))
+
+      (define (slide/title/tall/gap v-sep s . x)
+	(apply do-slide/title/tall/inset do-add-slide! #t #t values v-sep s zero-inset x))
+
+      (define (slide/title/tall s . x)
+	(apply slide/title/tall/gap gap-size s x))
+
+      (define (slide/name/tall s . x)
+	(apply slide/title/tall (make-name-only s) x))
+
+      (define (slide/title s . x)
+	(apply slide/title/tall/gap (* 2 gap-size) s x))
+
+      (define (slide/name s . x)
+	(apply slide/title (make-name-only s) x))
+
+      (define (slide/title/inset s inset . x)
+	(apply slide/title/tall/inset/gap (* 2 gap-size) s inset x))
+
+      (define (slide/name/inset s inset . x)
+	(apply slide/title/inset (make-name-only s) inset x))
+
+      (define (slide/title/center/inset s inset . x)
+	(let ([max-width 0]
+	      [max-height 0]
+	      [combine (lambda (x)
+			 (apply vc-append gap-size
+				(map
+				 evenize-width
+				 x)))])
+	  ;; Run through all the slides once to measure (don't actually create slides):
+	  (apply do-slide/title/tall/inset
+		 (lambda (content title comment page-count inset)
+		   (set! max-width (max max-width (pict-width content)))
+		   (set! max-height (max max-height (pict-height content))))
+		 #f
+		 #f
+		 (lambda (x) (list (combine x)))
+		 0 #f inset x)
+	  (apply do-slide/title/tall/inset
+		 do-add-slide!
+		 #t
+		 #t
+		 (lambda (x)
+		   (list
+		    (cc-superimpose
+		     (apply-slide-inset inset (if (string? s)
+						  titleless-page 
+						  full-page))
+		     (ct-superimpose
+		      (blank max-width max-height)
+		      (combine x)))))
+		 0 s inset x)))
+
+      (define (slide/name/center/inset s inset . x)
+	(apply slide/title/center/inset (make-name-only s) inset x))
+
+      (define (slide/title/center s . x)
+	(apply slide/title/center/inset s zero-inset x))
+
+      (define (slide/name/center s . x)
+	(apply slide/title/center (make-name-only s) x))
+
+      (define (slide . x) (apply slide/title #f x))
+      (define (slide/inset inset . x) (apply slide/title/inset #f inset x))
+
+      (define (slide/center . x) (apply slide/title/center #f x))
+      (define (slide/center/inset inset . x) (apply slide/title/center/inset #f inset x))
+
+      (define most-recent-slide
+	(case-lambda
+	 [() (most-recent-slide 0)]
+	 [(n) (viewer:most-recent-talk-slide)]))
+
+      (define retract-most-recent-slide
+	(lambda ()
+	  (let ([slide (viewer:most-recent-talk-slide)])
+	    (when slide
+	      (set! page-number (sliderec-page slide))
+	      (viewer:retract-talk-slide!)
+	      slide))))
+      
+      (define re-slide
+	(opt-lambda (s [addition #f])
+	  (unless (sliderec? s)
+	    (raise-type-error 're-slide "slide" s))
+	  (viewer:add-talk-slide!
+	   (make-sliderec
+	    (let ([orig (sliderec-drawer s)]
+		  [extra (if addition
+			     (make-pict-drawer addition)
+			     void)])
+	      (lambda (dc x y)
+		(orig dc x y)
+		(extra dc x y)))
+	    (sliderec-title s)
+	    (sliderec-comment s)
+	    page-number
+	    1
+	    (sliderec-inset s)
+	    null))
+	  (set! page-number (+ page-number 1))))
+
+      (define (start-at-recent-slide)
+	(viewer:set-init-page! (max 0 (- page-number 2))))
+
+      (define (done-making-slides)
+	(viewer:done-making-slides))
+
+      (define (make-outline . l)
+	(define ah (arrowhead gap-size 0))
+	(define current-item (colorize (hc-append (- (/ gap-size 2)) ah ah) blue))
+	(define other-item (rc-superimpose (ghost current-item) (colorize ah "light gray")))
+	(lambda (which)
+	  (slide/name
+	   (format "--~a--"
+		   (let loop ([l l])
+		     (cond
+		      [(null? l) "<unknown>"]
+		      [(eq? (car l) which)
+		       (cadr l)]
+		      [else (loop (cdddr l))])))
+	   (blank (+ title-h gap-size))
+	   (lc-superimpose
+	    (blank (pict-width full-page) 0)
+	    (let loop ([l l])
+	      (cond
+	       [(null? l) (blank)]
+	       [else
+		(let ([current? (or (eq? which (car l)) 
+				    (and (list? (car l))
+					 (memq which (car l))))])
+		  (vc-append
+		   gap-size
+		   (page-para
+		    (hbl-append
+		     (quotient gap-size 2)
+		     (if current?
+			 current-item
+			 other-item)
+		     (let ([p (cadr l)])
+		       (if (pict? p)
+			   p
+			   (bt p)))))
+		   (let ([rest (loop (cdddr l))]
+			 [sub-items (caddr l)])
+		     (if (and current?
+			      sub-items
+			      (not (null? sub-items)))
+			 (vc-append
+			  gap-size
+			  (sub-items which)
+			  rest)
+			 rest))))]))))))
+
+      (define (comment . s) 
+	(make-just-a-comment s))
+
+      ;; ----------------------------------------
+
+      ;; Move separators (that shouldn't be preceded by extra space)
+      ;; at the front of a string to the end of the previous item
+      (define (shift-no-sep l)
+	(let loop ([l 
+		    ;; Flatten l, first:
+		    (let loop ([l l])
+		      (cond
+		       [(null? l) null]
+		       [(pair? (car l)) (append (loop (car l)) (loop (cdr l)))]
+		       [else (cons (car l) (loop (cdr l)))]))]
+		   [a null])
+	  ;; Combine strings:
+	  (cond
+	   [(null? l) (reverse a)]
+	   [(null? a) (loop (cdr l) (list (car l)))]
+	   [(and (string? (car l)) 
+		 (regexp-match #rx"^[-',. :;?!)]" (car l)))
+	    (let ([m (regexp-match #rx"^([^ ]*) (.*)$" (car l))])
+	      (if m
+		  (if (string? (car a))
+		      (loop (cdr l)
+			    (list* (caddr m)
+				   (string-append (car a) (cadr m))
+				   (cdr a)))
+		      (loop (cdr l)
+			    (list* (caddr m)
+				   (hbl-append (car a) (t (cadr m)))
+				   (cdr a))))
+		  (if (string? (car a))
+		      (loop (cdr l)
+			    (cons (string-append (car a) (car l))
+				  (cdr a)))
+		      (loop (cdr l)
+			    (cons (hbl-append (car a) (t (car l)))
+				  (cdr a))))))]
+	   [else (loop (cdr l) (cons (car l) a))])))
+
+      (define (para*/align v-append w . s)
+	(define space (t " "))
+	(let loop ([pre #f][s (shift-no-sep s)][rest null])
+	  (cond
+	   [(null? s)
+	    (if (null? rest)
+		(or pre (blank))
+		(loop pre (car rest) (cdr rest)))]
+	   [(list? s) (loop pre (car s) (append (cdr s) rest))]
+	   [else
+	    (let* ([p (if (string? s) (t s) s)])
+	      (cond
+	       [(< (+ (if pre (pict-width pre) 0)
+		      (if pre (pict-width space) 0)
+		      (pict-width p)) 
+		   w)
+		;; small enough
+		(loop (if pre 
+			  (hbl-append pre space p) 
+			  p)
+		      rest null)]
+	       [(and (string? s) (regexp-match "(.*) (.*)" s))
+		;; can break on string
+		=> (lambda (m)
+		     (loop pre
+			   (cadr m) 
+			   (cons
+			    (caddr m)
+			    rest)))]
+	       [(not pre)
+		(if (null? rest)
+		    p
+		    (v-append
+		     line-sep
+		     p
+		     (loop #f rest null)))]
+	       [else
+		(v-append
+		 line-sep
+		 pre
+		 (loop p rest null))]))])))
+
+      (define (para* w . s)
+	(para*/align vl-append w s))
+
+      (define (para*/r w . s)
+	(para*/align vr-append w s))
+
+      (define (para*/c w . s)
+	(para*/align vc-append w s))
+
+
+      (define (para/align superimpose v-append w . s)
+	(superimpose (para*/align v-append w s)
+		     (blank w 0)))
+
+      (define (para w . s)
+	(para/align lbl-superimpose vl-append w s))
+
+      (define (para/r w . s)
+	(para/align rbl-superimpose vr-append w s))
+
+      (define (para/c w . s)
+	(para/align cbl-superimpose vc-append w s))
+
+
+      (define (page-para*/align v-append . s)
+	(para*/align v-append client-w s))
+
+      (define (page-para* . s)
+	(page-para*/align vl-append s))
+
+      (define (page-para*/r . s)
+	(page-para*/align vr-append s))
+
+      (define (page-para*/c . s)
+	(page-para*/align vc-append s))
+
+
+      (define (page-para/align superimpose v-append . s)
+	(para/align superimpose v-append client-w s))
+
+      (define (page-para . s)
+	(page-para/align lbl-superimpose vl-append s))
+
+      (define (page-para/r . s)
+	(page-para/align rbl-superimpose vr-append s))
+
+      (define (page-para/c . s)
+	(page-para/align cbl-superimpose vc-append s))
+
+      ;; ----------------------------------------
+
+      (define (l-combiner para w l)
+	(apply
+	 vl-append
+	 gap-size
+	 (map (lambda (x) (para w x)) l)))
+
+      ;; ----------------------------------------
+
+      (define (item*/bullet bullet w . s)
+	(htl-append (/ gap-size 2)
+		    bullet 
+		    (para* (- w
+			      (pict-width bullet) 
+			      (/ gap-size 2)) 
+			   s)))
+
+      (define (item* w . s)
+	(apply item*/bullet bullet w s))
+
+      (define (item w . s)
+	(lbl-superimpose (item* w s)
+			 (blank w 0)))
+
+      (define (item/bullet b w . s)
+	(lbl-superimpose (item*/bullet b w s)
+			 (blank w 0)))
+
+      (define (page-item* . s)
+	(item* client-w s))
+
+      (define (page-item . s)
+	(item client-w s))
+
+      (define (page-item*/bullet b . s)
+	(item*/bullet b client-w s))
+
+      (define (page-item/bullet b . s)
+	(item/bullet b client-w s))
+
+      ;; ----------------------------------------
+
+      (define (subitem* w . s)
+	(inset (htl-append (/ gap-size 2)
+			   o-bullet 
+			   (para* (- w
+				     (* 2 gap-size)
+				     (pict-width bullet) 
+				     (/ gap-size 2)) 
+				  s))
+	       (* 2 gap-size) 0 0 0))
+
+      (define (subitem w . s)
+	(lbl-superimpose (subitem* w s)
+			 (blank w 0)))
+
+      (define (page-subitem* . s)
+	(subitem* client-w s))
+
+      (define (page-subitem . s)
+	(subitem client-w s))
+
+      ;; ----------------------------------------
+
+      (define (paras* w . l)
+	(l-combiner para* w l))
+
+      (define (paras w . l)
+	(l-combiner para w l))
+
+      (define (page-paras* . l)
+	(l-combiner (lambda (x y) (page-para* y)) client-w l))
+
+      (define (page-paras . l)
+	(l-combiner (lambda (x y) (page-para y)) client-w l))
+
+      ;; ----------------------------------------
+
+      (define (itemize w . l)
+	(l-combiner item w l))
+
+      (define (itemize* w . l)
+	(l-combiner item* w l))
+
+      (define (page-itemize . l)
+	(l-combiner (lambda (x y) (page-item y)) client-w l))
+
+      (define (page-itemize* . l)
+	(l-combiner (lambda (x y) (page-item* y)) client-w l))
+
+      ;; ----------------------------------------
+
+      (define (size-in-pixels p)
+	(if (not (and (= use-screen-w screen-w)
+		      (= use-screen-h screen-h)))
+	    (scale p 
+		   (/ screen-w use-screen-w)
+		   (/ screen-h use-screen-h))
+	    p))
+
+      ;; ----------------------------------------
+
+      (define clickback
+	(opt-lambda (pict thunk [show-click? #t])
+	  (let ([w (pict-width pict)]
+		[h (pict-height pict)])
+	    (cons-picture*
+	     pict
+	     `((place 
+		0 0
+		,(dc (lambda (dc x y)
+		       (let-values ([(sx sy) (send dc get-scale)]
+				    [(dx dy) (send dc get-origin)])
+			 (viewer:add-click-region!
+			  (make-click-region (+ (* x sx) dx)
+					     (+ (* y sy) dy)
+					     (+ (* (+ x w) sx) dx)
+					     (+ (* (+ y h) sy) dy)
+					     thunk
+					     show-click?))))
+		     w h
+		     (pict-ascent pict)
+		     (pict-descent pict))))))))
+
+      ;; ----------------------------------------
+
+      (define (add-transition! who trans)
+	(let ([slide (viewer:most-recent-talk-slide)])
+	  (when slide
+	    (set-sliderec-transitions! slide 
+				       (append! (sliderec-transitions slide)
+						(list trans))))))
+      
+      (define scroll-bm #f)
+      (define scroll-dc (make-object bitmap-dc%))
+
+      (define scroll-transition
+	(opt-lambda (x y w h dx dy [duration 0.20] [steps 12])
+	  (add-transition! 'scroll-transition
+			   (lambda (offscreen-dc)
+			     (let* ([steps-done 0]
+				    [xs (/ use-screen-w screen-w)]
+				    [ys (/ use-screen-h screen-h)]
+				    [bcw (send (send offscreen-dc get-bitmap) get-width)]
+				    [bch (send (send offscreen-dc get-bitmap) get-height)]
+				    [mx (- margin (/ (- use-screen-w bcw) 2 xs))]
+				    [my (- margin (/ (- use-screen-h bch) 2 ys))]
+				    [x-space (ceiling (* xs (/ (abs dx) steps)))]
+				    [y-space (ceiling (* ys (/ (abs dy) steps)))]
+				    [x-in (if (positive? dx)
+					      x-space
+					      0)]
+				    [y-in (if (positive? dy)
+					      y-space
+					      0)])
+			       (unless (and scroll-bm
+					    (>= (send scroll-bm get-width) 
+						(+ x-space (* xs w)))
+					    (>= (send scroll-bm get-height) 
+						(+ y-space (* ys h))))
+				 (set! scroll-bm (make-bitmap
+						  (inexact->exact (ceiling (+ x-space (* xs w))))
+						  (inexact->exact (ceiling (+ y-space (* ys h))))))
+				 (if (send scroll-bm ok?)
+				     (send scroll-dc set-bitmap scroll-bm)
+				     (set! scroll-bm #f)))
+
+			       (when scroll-bm
+				 (send scroll-dc clear)
+				 (send scroll-dc draw-bitmap-section (send offscreen-dc get-bitmap)
+				       x-in y-in
+				       (* (+ x mx) xs) (* (+ y my) ys)
+				       (* w xs) (* h ys)))
+			       
+			       (lambda (canvas offscreen-dc)
+				 (if (or (not scroll-bm) (= steps-done steps))
+				     'done
+				     (let*-values ([(cw ch) (send canvas get-client-size)])
+				       (let ([xm (- margin (/ (- use-screen-w bcw) 2 xs))]
+					     [ym (- margin (/ (- use-screen-h bch) 2 ys))])
+					 (set! steps-done (add1 steps-done))
+					 (let ([draw
+						(lambda (dc xm ym)
+						  (send dc draw-bitmap-section
+							scroll-bm
+							(- (* (+ x xm (* dx (/ steps-done steps))) xs) x-in)
+							(- (* (+ y ym (* dy (/ steps-done steps))) ys) y-in)
+							0 0 
+							(ceiling (* xs (+ w (/ (abs dx) steps))))
+							(ceiling (* ys (+ h (/ (abs dy) steps))))))])
+					   (draw (send canvas get-dc) xm ym)
+					   (draw offscreen-dc mx my)))
+				       (/ duration steps)))))))))
+
+      (define pause-transition
+	(lambda (time)
+	  (add-transition! 'pause-transition
+			   (lambda (offscreen-dc)
+			     (let ([done? #f])
+			       (lambda (canvas offscreen-dc)
+				 (if done?
+				     'done
+				     (begin
+				       (set! done? #t)
+				       time)))))))))))
diff --git a/collects/slideshow/doc.txt b/collects/slideshow/doc.txt
new file mode 100644
index 0000000000..3a3dfefe9b
--- /dev/null
+++ b/collects/slideshow/doc.txt
@@ -0,0 +1,650 @@
+
+_Slideshow_ Quick Start
+=======================
+
+Stand-alone:
+
+ 1. Double-click the "Slideshow" executable, or run "slideshow"
+    from the command line.
+
+ 2. Click the "Tutorial" button.
+
+On in DrScheme:
+
+ 1. Open "tutorial-show.ss", which is in the "slideshow" collection.
+    
+    The path depends on your PLT install directory:
+       <plt install dir>/collects/slideshow/tutorial-show.ss
+
+ 2. Set DrScheme's language to "(module ...)".
+ 
+    Use the "Choose Language" menu item in the "Language" menu.
+
+ 3. Click DrScheme's "Execute" button.
+
+
+     ---------- !! IMPORTANT SECURITY INFORMATION !! ----------
+
+   Do not run any Slideshow program in DrScheme unless you know the
+   creator of the slide program and/or trust the slide
+   program. Instead, run untrusted programs with the "Slideshow"
+   executable or "slideshow" command-line program.
+
+   A Slideshow program has access to the full PLT Scheme language,
+   which means that it can write to files and establish network
+   connections (possibly sending your private information elsewhere).
+
+   When you use the "Slideshow" executable or "slideshow" command-line
+   program, however, the slide program is prevented from writing to
+   the filesystem or creating network connections.
+
+
+Slideshow Overview
+==================
+
+Slideshow is a library for creating presentation slides. Unlike
+Powerpoint, Slideshow provides no WYSIWYG interface for constructing
+slides. Instead, like SliTeX, a presentation is generated by a
+program.
+
+For constructing slide images, Slideshow builds on the "texpict"
+collection's utilities for constructing images. More specifically,
+all of the functions provided by `(lib "mrpict.ss" "texpict")'
+are available for creating images.
+
+In addition to the "mrpict.ss" functions, Slideshow provides functions
+for constructing paragraphs and bulleted lists, staging parts of a
+slide, managing fonts, viewing the slides, and scaling slides for a
+particular display.
+
+For boring text slides, the functions listed in this document are
+sufficient to construct slides. More interesting slides --- with
+images and diagrams --- require the more general picture-construction
+functions in "texpict".
+
+Slideshow Modules
+=================
+
+The _slideshow.ss_ module acts as a language that includes:
+
+ - the Slideshow function for creating slides (defined here)
+ - all of MzScheme
+ - (lib "mrpict.ss" "texpict")
+ - (lib "utils.ss" "texpict")
+
+The _slide.ss_ module is like "slideshow.ss", but it does not
+re-provide MzScheme. Thus, "slide.ss" is a non-language version of
+"slideshow.ss", and it can be imported with `require' into a module in
+any language.
+
+The _run.ss_ module is the same as "slideshow.ss" for backward
+compatibility.
+
+  [The "slideshow.ss" and "slide.ss" modules also check the MzScheme
+   parameter `current-command-line-arguments' to configure the slide
+   mode.]
+
+The rest of this section repeats much of the information that is in
+"tutorial-show.ss" (see "Quick Start" at the top of this
+documentation).
+
+The main Slideshow function is `slide/title', which adds a slide to
+the presentation with a given title and content. For example, the
+Hello World presentation can be defined by the following module:
+
+ (module hello-world (lib "slideshow.ss" "slideshow")
+   (slide/title
+    "How to Say Hello"
+    (t "Hello World!")))
+ 
+The `t' function creates a pict containing the given text in the
+default font and style.
+
+Executing the above module pops up a slide-presentation window. Type
+Alt-q (or Meta-q) to end the slides. More controls:
+
+   Alt-q, Meta-q, or Cmd-q             :  end slide show
+   Esc                                 :  if confirmed, end show
+   Right arrow, Space, f, n, or click  :  next slide
+   Left arrow, Backspace, Delete, or b :  previous slide
+   g                                   :  last slide
+   1                                   :  first slide
+   Alt-g, Cmd-g, or Meta-g             :  select a slide
+   Alt-p, Cmd-p, or Meta-p             :  show/hide slide number
+   Alt-c, Cmd-c, or Meta-c             :  show/hide commentary
+   Alt-d, Cmd-d, or Meta-d             :  show/hide preview
+   Alt-m, Cmd-m, or Meta-m             :  show/hide mouse cursor
+   Shift with arrow                    :  move window 1 pixel
+   Alt, Meta, or Cmd with arrow        :  move window 10 pixels
+
+In general, each element after the title string for `slide/title' is a
+pict that will be centered on the slide. The picts are stacked
+verically and top-aligned, with `gap-size' separation between each
+pict.
+
+ (module hello-world (lib "slideshow.ss" "slideshow")
+   (slide/title
+    "How to Say Hello"
+    (t "Hello World!")
+    (t "Goodbye Dlrow!")))
+
+The `slide/title/center' form centers the stacked picts vertically
+instead of putting them at the top of the slide:
+
+ (module hello-world (lib "slideshow.ss" "slideshow")
+   (slide/title/center
+    "How to Say Hello"
+    (t "Hello World!")
+    (t "Goodbye Dlrow!")))
+
+Various functions format paragraphs and generate bullted items for
+lists. For example, `item/page' creates a bulleted paragraph that
+spaces the width of the slide:
+
+ (module hello-world (lib "slideshow.ss" "slideshow")
+   (slide/title
+    "How to Say Hello"
+    (page-item "If you want to create an example, you"
+               "can always do something with" (bt "Hello World!"))
+    (page-item "It's a bit silly, but a follow-up example"
+               "could be" (bt "Goodbye Dlrow!"))))
+
+In this example, `bt' is like `t', except that it makes the text bold.
+The `page-item' function accepts a mixture of strings and picts, and
+it formats them as a paragraph.
+
+Staging Slides
+==============
+
+The `slide/title' function creates a slide as a side effect. It can be
+put inside a function to abstract over a slide:
+
+ (module hello-world (lib "slideshow.ss" "slideshow")
+   (define (make-slide-n n)
+     (slide/title
+      "How to Generalize Slides"
+      (page-item "This is slide number" (number->string n))))
+
+   (make-slide-n 1)
+   (make-slide-n 2)
+   (make-slide-n 3))
+
+The `slide/title' function also has built-in support for some common
+multi-slide patterns. Each element argument to `slide/title' after the
+title is usually a pict, but there are a few other possibilities:
+
+  * If an element is 'next, then a slide is generated containing only
+    the preceeding elements, and then the <elems> are re-processed
+    without the 'next. Multiple 'next elements generate multiple slides.
+
+  * If an element is 'alts, then the next element must be a list of
+    element lists. Each list up to the last one is appended to the
+    elements before 'alts and the resulting list of elements is
+    processed. The last lists is appended to the preceeding elements
+    along with the remaining elements (after the list of lists) and the
+    result is re-processed.
+
+  * A 'nothing element is ignored (useful as a result of a branching
+    expression).
+
+  * 'next! is like 'next, except that it is preserved when consensing
+    (see below on the --condense flag).
+
+  * 'alts~ is like 'alts, except that it is *not* preserved when
+    consensing (see below on the --condense flag).
+
+  * A comment produced by `comment' is ignored, except when commentary
+    is displayed.
+
+Here's an example to illustrate how 'next and 'alts work:
+
+ (module multi-step (lib "slideshow.ss" "slideshow")
+  (slide/title
+   "Example"
+   (page-item "First step")
+   'NEXT
+   (page-item "Second step")
+   'NEXT
+   'ALTS
+   (list (list (page-item "Tentative third step")
+               'NEXT
+               (page-item "This isn't working... back up"))
+         (list (page-item "Third step that works")))
+   'NEXT
+   (page-item "Fourth step")))
+
+[The code above is case-insensitive; 'NEXT and 'ALTS are capitalized
+ merely to stand out.]
+
+Display Size and Fonts
+======================
+
+Slideshow is configured for generating slides in 1024x768 pixel
+format. When the current display has a different size as Slideshow is
+started, the Slideshow display still occupies the entire screen, and
+pictures are scaled just before they are displayed. Thus, one picture
+unit reliably corresponds to a "pixel" that occupies 1/1024 x 1/768 of
+the screen.
+
+The `text' form for generating text pictures takes into account any
+expected scaling for the display when measuring text. (All Slideshow
+text functions, such as `t' and `page-para', are built on `text'.) In
+particular, scaling the picture causes a different font size to be
+used for drawing the slide (rather than bitmap-scaling the original
+font), and changing the font size by a factor of K does not
+necessarily scale all text dimensions equally by a factor of K
+(because, for most devices, each character must have integer
+dimensions). Nevertheless, using the `current-expected-text-scale'
+parameter, Slideshow is usually able to produce good results when the
+slide is scaled.
+
+More generally, different font sets on different platforms can change
+the way a slide is rendered. For example, the `tt' font on one
+platform might be slightly wider than on another, causing different
+line breaks, etc. Beware.
+
+Beware also of using bitmaps in slides when the presentation screen
+will not be 1024x768. In that case, consider using `size-in-pixels'
+(with the caveat that the resulting picture will take up different
+amounts of the slide on different displays).
+
+Transition Animations
+=====================
+
+Any number of transition actions can be installed after a slide is
+created and before the next slide is created. The first animation
+applies to the most recently created slide, and during presentation
+time, it starts when the next slide is requested; after all animations
+complete, the next slide appears immediately.
+
+If the presenter requests the next slide before an animation sequence
+completes, Slideshow breaks all animations and continues immediately
+to the next slide. Animations are not execute when jumping to a slide
+or moving backward through the slide set.
+
+Command-line Options
+====================
+
+The _start.ss_ module can be invoked directly, in which case a module
+file name should be provided on the command line to provide the slide
+content. Setup PLT creates a "Slideshow" executable that runs
+"start.ss".
+
+Thus, if the above example is in multi-step.ss, then
+
+   slideshow multi-step.ss
+
+runs the slides.
+
+The "Slideshow" executable accepts a number of command-line flags.
+Use the --help flag to obtain a list of other flags.
+
+Procedure Reference
+===================
+
+> (slide/title title-string element ...) - Creates a titled slide. See
+  the overview for information about `element's. The space between the
+  title and content is twice `gap-size'.
+
+  When this function (or one of its variants) is first called in
+  non-printing mode, then the viewer window is opened. Furthermore,
+  each call to the function (or a variant) `yield's, so that the
+  viewer window can be refreshed, and so the user can step through
+  slides.
+
+> (slide/title/tall title-string element ...) - Like `slide/title',
+  except that the space is inserted between the title and the slide
+  content is only `gap-size'.
+
+> (slide/title/center title-string element ...) - Like `slide/title',
+  except that the slide content is centered vertically under the
+  title. If the content has steps an alternatives, each individual
+  slide's content is center-top aligned with the largest individual
+  slide's bounding box.
+
+> (slide element ...) - Like `slide/title', but without the title.
+
+> (slide/center element ...) - Like `slide/title/center', but without
+  the title.
+
+> (slide/title/inset title-string slide-inset element ...)
+> (slide/title/tall/inset title-string slide-inset element ...)
+> (slide/title/center/inset title-string slide-inset element ...)
+> (slide/inset slide-inset element ...)
+> (slide/center/inset slide-inset element ...)
+  Like `slide/title', etc., except that an inset is supplied. A slide
+  inset is created with `make-slide-inset'.
+
+> (slide/name title-string element ...)
+> (slide/name/tall title-string element ...)
+> (slide/name/center title-string element ...)
+> (slide/name/inset title-string slide-inset element ...)
+> (slide/name/tall/inset title-string slide-inset element ...)
+> (slide/name/center/inset title-string slide-inset element ...)
+  Like `slide/title', etc., except that the title string is used only
+  for naming the slide, as in the Alt-g dialog, and does not appear at
+  the top of the slide. The content area is therefore the same size as
+  `client-page'.
+
+> (make-slide-inset left-inset top-inset right-inset bottom-inset) -
+  Creates a slide inset, which describes a number of pixels to inset
+  a slide on each side. Each inset must be an exact, non-negative
+  integer.
+
+> (t string) - Same as (text string (current-main-font) (current-font-size))
+> (it string) - Same as (text string `(italic . ,(current-main-font)) (current-font-size))
+> (bt string) - Same as (text string `(bold . ,(current-main-font)) (current-font-size))
+> (bit string) - Same as (text string `(bold italic . ,(current-main-font)) (current-font-size))
+> (tt string) - Same as (text string `(bold . modern) (current-font-size))
+> (rt string) - Same as (text string `roman (current-font-size))
+> (titlet string) - Like `t', but using the default slide-title font and color.
+
+> (para width-n ielement ...) - Generates a paragraph picture of width
+  `width-n'. Each ielement is either a string or a pict; strings are
+  split at spaces for word-wrapping to fit the page, and space is
+  added between elements. However, if a string element starts with a
+  punctuation mark (e.g., a comma), no space is added before the
+  element.
+
+> (para* width-n ielement ...) - Like `para, except that the
+  paragraph is only as wide as necessary, which may be less than
+  `width-n'.
+
+> (page-para ielement ...) - Like `para, except that the width
+   is `client-w' (see below).
+
+> (page-para* ielement ...) - Like `para*', except that the width
+   is `client-w' (see below).
+
+> (item width-n ielement ...)
+> (item* width-n ielement ...)
+> (page-item ielement ...)
+> (page-item* ielement ...)
+  Like `para, etc., except that a bullet is placed in front of the
+  paragraph, and the paragraph is indented on the left.
+
+> (item/bullet bullet-pict width-n ielement ...)
+> (item*/bullet bullet-pict width-n ielement ...)
+> (page-item/bullet bullet-pict ielement ...)
+> (page-item*/bullet bullet-pict ielement ...)
+  Like `item', etc., but with a given bullet pict.
+
+> (subitem width-n ielement ...)
+> (subitem* width-n ielement ...)
+> (page-subitem ielement ...)
+> (page-subitem* ielement ...)
+  Like `item', etc., except that a hollow bullet is used, and the
+  width for the `page-' versions is inset from `client-w'.
+
+
+> (para/c width-n ielement ...)
+> (para*/c width-n ielement ...)
+> (page-para/c ielement ...)
+> (page-para*/c ielement ...)
+  Like `para, etc., except that text is centered within the paragraph.
+
+> (para/r width-n ielement ...)
+> (para*/r width-n ielement ...)
+> (page-para/r ielement ...)
+> (page-para*/r ielement ...)
+  Like `para, etc., except that text is right-aligned within the
+  paragraph.
+
+> (clickback pict thunk)
+  Creates a pict that embeds the given one, and is the same size as
+  the given pict, but that when clicked during a presentation calls
+  `thunk'.
+
+> (most-recent-slide) - Returns a slide structure that be supplied to
+  `re-slide' to make a copy of the slide. Transition animations before
+  or after the slide (if any) are not included in the resulting slide.
+
+> (retract-most-recent-slide) - Cancels the most recently created
+  slide, and also returns a slide structure that be supplied to
+  `re-slide' to restore the slide (usually in a later position).
+  Transition animations after the slide (if any) are lost, while
+  transitions before the slide remain in place (but are not part of
+  the returned slide).
+
+> (re-slide slide [pict]) - [Re-]inserts a slide, optionally
+  `lt-superimpose'ing the given additional pict.
+
+> (start-at-recent-slide) - Sets the starting slide for the talk to
+  the most recently created slide. If this function is used multiple
+  times, the last use overrides the realier uses.
+
+> (scroll-transition x y w h dx dy [secs steps-k]) - inserts a scroll
+  animation that shifts the screen rectangle (x, y, x+w, y+h) by `dx'
+  and `dy', taking `secs' time and animating with `steps-k' steps.
+  See also "Transition Animations", above.
+
+> (pause-transition secs) - inserts a delay "animation" with no
+  drawing effect.   See also "Transition Animations", above.
+
+> (comment string-or-pict ...) - Combines strings and picts to be used
+  as a slide element for (usually hidden) commentary. Use the result
+  as an argument to `slide', `slide/title', etc.
+
+> (make-outline { symbol/s string-or-pict subitems } ...)  - Returns a
+  function that takes a symbol and generates an outline slide. Each
+  trio of arguments defines a section for the outline:
+
+   - The symbol/s names the section, either with a single symbol or a
+     list of symbols. When the outline function is called later to
+     make an outline, the given symbol is compared to the section's
+     symbol(s), and the section is marked as current if the symbol
+     matches.
+
+   - The string-or-pict is used as the displayed name of the
+     section.
+
+   - The subitems are displayed when the section is active. It can be
+     #f or null (for historical reasons) if no subitems are to be
+     displayed. Otherwise, it should be a procedure that takes a symbol
+     (the same one passed to the outline maker) and produces a pict.
+
+> (size-in-pixels p) - Scales p so that p is displayed on the screen
+  as (pict-width p) wide and (pict-height p) tall. The result is just
+  p for a 1024x768 display.
+
+
+> font-size - The default font size, 32. This size is in pixels for a
+  1024x768 screen; see also the "Display Size and Fonts" section, above.
+> gap-size - (* 3/4 font-size)
+
+> current-font-size - Parameter for the font size used by `t', etc.,
+  initialized to `font-size'.
+> line-sep - Amount of seperating between paragraph lines.
+> title-size - Font size used for slide titles, derived from `font-size'.
+> main-font - Font specification used for `t' by default
+> current-main-font - Parameter for the font specification
+  used for `t'. Its argument must be a text-style (see
+  texpict for details).
+> current-title-color - Parameter for the color used by titles/`titlet'
+
+> (with-font f thunk) - Calls `thunk' with
+  `current-main-font' set to `f', which must be a
+  text-style (see texpict for details)
+
+> red - a color name like "red", possibiliy selected by the user.
+> green - a color name like "green"
+> blue - ...
+> purple - ...
+> orange - ...
+
+> bullet - a bullet pict
+> o-bullet - a hollow bullet pict
+
+> client-w - (syntax) useable width of the screen
+> client-h - (syntax) useable height of the screen
+> get-client-w - returns useable width of the screen
+> get-client-h - returns useable height of the screen
+
+> full-page - (syntax) an empty pict that is the same size as the
+              client area
+> titleless-page - (syntax) an empty pict that is the same size as
+                   the client ares minus the title area
+> get-full-page - returns full-page
+> get-titleless-page - returns titleless-page
+
+> margin - (syntax) client margin within the full screen, 20
+> get-margin - returns client margin within the full screen, 20
+> set-margin! - sets `margin' and updates `client-w', `client-h',
+                `full-page', and `titleless-page'
+
+> title-h - (syntax) the height of a title string
+> get-title-h - returns the height of a title string
+
+> set-title-h! - sets `title-h' and updates `titleless-page'; this
+  usually makes sense only in combination with a change to
+  `current-format-slide'
+
+> current-slide-assembler - a parameter whose value is a function for
+  assembling slide content into a single pict; the assembling function
+  takes a string-or-false for the title, a separation for the title
+  and pict (if any), and a pict for the slide content (not counting
+  the title); the result is 'lt-superimpose'd with the client area
+  (but the result pict might draw outside the client region to paint
+  the screen margins, too); see also `set-title-h!',
+  `current-page-number-font', `current-page-number-color', and
+  `set-page-numbers-visible!'
+
+> current-page-number-font - font used to draw slide numbers
+> current-page-number-color - color used to draw slide numbers
+> set-page-numbers-visible! - determines whether slide numbers are
+  initially visible
+
+> printing? - #t if the slides are begin durected to PostScript output
+> condense? - #t if slides are being condensed (see overview)
+> (skip-slides n) - increment the slide counter by `n' without adding
+  any slides.
+
+> (done-making-slides)
+  Notifies the slide viewer that no further slides will be registered,
+  which is mainly useful in printing mode. This procedure is called
+  automatically after loading a file when Slideshow is run as a
+  application.
+
+> (set-use-background-frame! on?) - enables or disables the creation
+  of a background frame, which is typically useful only when insets
+  are active. The last enable/disable during slide creation takes
+  effect once and for all.
+
+> (enable-click-advance! on?) - enables or disables slide advance
+  as a result of a mouse click.
+
+------------------------------------------------------------
+_code.ss_
+------------------------------------------------------------
+
+The "code.ss" module provides functions and syntax for typesetting
+Scheme code a la SlaTeX. It instantiates `code@' from `(lib "code.ss"
+"typeset")', providing Slideshow's `current-font-size' and `line-sep'
+to the unit, and re-exporting the unit's exports from the module.
+
+The "code.ss" module also exports a `code' macro generated by
+`define-code' from `(lib "code.ss" "typeset")':
+
+> (code datum ...) - typesets the `datum' sequence to produce a pict;
+                     see `define-code' from "code.s"" in the "texpict"
+                     collection for more information.
+
+See documentation for "code.ss" in the "texpict" collection for more
+information.
+
+
+Finally, "code.ss" exports a `define-code/string/scale' macro:
+
+> (define-exec-code (pict-id runnable-id string-id)
+    datum ...)
+
+The `pict-id' is bound to the result of `(code datum ...)', except
+that if an underscore by itself appears anywhere in a `datum', then
+the underscore and the following expression are not included for
+`code'.
+
+Meanwhile, `runnable-id' is bound to a syntax object that wraps the
+`datum's in a `begin'. In this case, underscores are removed from the
+`datum's, but not the following expression. Thus, an underscore is
+used to comment out an expression from the pict, but have it present
+in the syntax object for evaluation.
+
+The `string-id' is bound to a string reprsentation of the code that is
+in the pict. This string is useful for copying to the clipboard with
+`(send the-clipboard set-clipboard-string string-id 0)'.
+
+
+> (define-exec-code/scale scale-expr (pict-id runnable-id string-id)
+    datum ...)
+
+Like `define-exec-code', but with a scale to use when generating the
+pict.
+
+
+
+------------------------------------------------------------
+_step.ss_
+------------------------------------------------------------
+
+The "step.ss" module provides syntax for breaking a complex slide into
+steps (that are more complex than can be handled with 'next and 'alts
+in a `slide' sequence).
+
+> (with-steps (id ...) expr) - evaluates `expr' once for each `id',
+  skipping an `id' if it ends with "~" and `condense?' from
+  "slideshow.ss" is true
+
+  Within `expr', several keywords are bound:
+
+>   (only? id) - returns #t during the evaluation of `expr' for
+    `id', #f otherwise
+>   (vonly id) - returns the identity function during the evaluation of
+    `expr' for `id', `ghost' otherwise
+>   (only id then-expr)
+>   (only id then-expr else-expr) - returns the result of `then-expr'
+    for step `id', the result of `else-expr' (defaults to `values')
+    otherwise.
+
+>   (before? id) - returns #t before ... for `id'
+>   (vbefore id) - returns the identify function ... `ghost' otherwise
+>   (before id then-expr)
+>   (before id then-expr else-expr) - returns the result of `then-expr'
+    before step `id', ...
+    
+
+>   (after? id) - return #t during and after ... for `id'
+>   (vafter id) - ...
+>   (after id then-expr)
+>   (after id then-expr else-expr) - returns the result of `then-expr'
+    during and after step `id', ...
+
+>   (between? a-id b-id) - returns #t during and after ... for `a-id',
+    but #f after evaluation for `b-id'
+>   (vbetween a-id b-id) - ...
+>   (between a-id b-id then-expr)
+>   (between a-id b-id then-expr else-expr) - returns the result of 
+    `then-expr' during and after step `a-id' and before step `b-id', 
+    ...
+
+>   (between-excl? a-id b-id) - returns #t during and after ... for
+    `a-id', but #f during and after evaluation for `b-id'
+>   (vbetween-excl a-id b-id) - ...
+>   (between-excl a-id b-id then-expr)
+>   (between-excl a-id b-id then-expr else-expr) - returns the result of 
+    `then-expr' after step `a-id' and before step `b-id', ...
+
+> (with-steps~ (id ...) expr) - like `with-steps', but when
+  `condense?' from "slideshow.ss" is true, then `expr' is evaluated
+  only for the last `id' (independent of whether its name ends in "~")
+
+
+------------------------------------------------------------
+_slides-to-picts.ss_
+------------------------------------------------------------
+
+> (get-slides-as-picts path width height condense?) - executes the
+  Slideshow program indicated by `path' in a fresh namespace, and
+  returns a list of picts for the slides. Each pict have the given
+  `width' and `height', and `condense?' determines whether the program
+  is executed in condense mode.
+
diff --git a/collects/slideshow/examples/big-explosion.jpg b/collects/slideshow/examples/big-explosion.jpg
new file mode 100644
index 0000000000..fe74961360
Binary files /dev/null and b/collects/slideshow/examples/big-explosion.jpg differ
diff --git a/collects/slideshow/examples/interlocking-components.scm b/collects/slideshow/examples/interlocking-components.scm
new file mode 100644
index 0000000000..0a9d149e5d
--- /dev/null
+++ b/collects/slideshow/examples/interlocking-components.scm
@@ -0,0 +1,336 @@
+
+(module interlocking-components (lib "run.ss" "slideshow")
+  (require (lib "class.ss")
+           (lib "mred.ss" "mred"))
+  
+  (define-struct posn (x y) (make-inspector))
+  
+  (define between-space 20)
+
+  (define main-piece-width 200)
+  (define main-piece-height 200)
+  (define right-piece-width 200)
+  (define right-piece-height 200)
+  (define below-piece-width (+ right-piece-width between-space main-piece-width))
+  (define below-piece-height 200)
+  (define below-interpose-piece-width below-piece-width)
+  (define below-interpose-piece-height 50)
+
+  (define main-piece-dark-color "crimson")
+  (define main-piece-light-color "pink")
+  (define right-piece-dark-color "medium blue")
+  (define right-piece-light-color "sky blue")
+  (define below-piece-dark-color "forest green")
+  (define below-piece-light-color "pale green")
+  (define below-interpose-piece-dark-color "purple")
+  (define below-interpose-piece-light-color "plum")
+  
+  (define square-tooth-offset 50)
+  (define square-tooth-height 60)
+  (define square-tooth-width 50)
+  (define square-tooth-accept-space 15)
+  
+  (define pointy-tooth-offset 50)
+  (define pointy-tooth-width 100)
+  (define pointy-tooth-height 50)
+  (define pointy-tooth-accept-space 5)
+
+  (define hex-tooth-offset 50)
+  (define hex-tooth-width 100)
+  (define hex-tooth-height 50)
+  (define hex-tooth-accept-space 10)
+  (define hex-tooth-inset 20)
+
+  (slide/center
+   (page-para/c
+    "The following slide sequences was extracted"
+    "from a talk on components and contracts"))
+  
+  (define (interlocking-components)
+    (slide (make-orig #t #f ghost ghost ghost ghost ghost
+                      "A day in the life of a component software developer."
+                      "We start with one component (from web or somewhere)"))
+    
+    (slide (make-orig #t #f ident ident ghost ghost ghost
+                      "... and compose it with other software to build a system."))
+    
+    (slide (make-orig #t #f ident ghost ident ghost ghost
+                      "Except, of course, the composed pieces might not fit,"))
+    
+    (slide (make-orig #t #f ident ghost ghost ident ghost
+                      "... so the programmers develop adapters."
+                      "Now the program can be run, but what"
+                      "happens when you run it?"))
+    
+    (slide (make-orig #t #f ghost ghost ghost ghost ident
+                      "KABOOM!"))
+    
+    (slide (make-orig #t #f ident ghost ghost ident ghost
+                      "What happened? Which component failed?"))
+    
+    (slide (make-orig #f #f ident ghost ghost ident ghost
+                      "To figure that out, the programmer shouldn't have"
+                      "to understand the details of all of the"
+                      "component implementations."))
+    
+    (slide (make-orig #f #t ident ghost ghost ident ghost
+                      "Instead the grey area, where the interface"
+                      "contract specs are, should have enough"
+                      "information to figure that out.")))
+  
+  (define (make-orig dark? bkg? right bot-hex bot-pointy bot-combined explosion . text)
+    (let* ([below-pointy (below-pointy-piece dark?)]
+           [components
+            (lt-superimpose
+             (at 0
+                 0
+                 (main-piece dark?))
+             (at (+ main-piece-width between-space)
+                 0 
+                 (right (right-piece dark?)))
+             (at 0 
+                 (+ main-piece-height between-space)
+                 (bot-hex (below-hex-piece dark?)))
+             (at 0 
+                 (+ main-piece-height between-space)
+                 (bot-pointy (below-pointy-piece dark?)))
+             (at 0
+                 (+ main-piece-height between-space) 
+                 (bot-combined (below-interpose-piece dark?)))
+             (at 0
+                 (+ main-piece-height between-space below-interpose-piece-height between-space) 
+                 (bot-combined
+                  below-pointy)))]
+           [combined
+            (cc-superimpose
+             (if bkg?
+                 (overlay-background 
+                  "light gray"
+                  (overlay-striped-background
+                   "dark gray"
+                   10 
+                   components))
+                 components)
+             (explosion big-explosion-pict))])
+      (vc-append
+       40
+       combined
+       (apply page-para text))))
+
+                                   
+  (define big-explosion-pict (bitmap "big-explosion.jpg"))
+
+  (define (at x y pict) (hc-append (blank x 0) (vc-append (blank 0 y) pict)))
+  
+  (define (main-piece dark?)
+    (polygon
+     (if dark? main-piece-dark-color main-piece-light-color)
+     (make-posn 0 0)
+     (make-posn main-piece-width 0)
+     (offset-posns main-piece-width square-tooth-offset (square-tooth #t))
+     (make-posn main-piece-width main-piece-height)
+     (offset-posns pointy-tooth-offset main-piece-height (reverse (hex-tooth #t)))
+     (make-posn 0 main-piece-height)
+     (make-posn 0 0)))
+  
+  (define (below-pointy-piece dark?)
+    (polygon
+     (if dark? below-piece-dark-color below-piece-light-color)
+     (make-posn 0 0)
+     (offset-posns pointy-tooth-offset 0 (pointy-tooth #f))
+     (make-posn below-piece-width 0)
+     (make-posn below-piece-width below-piece-height)
+     (make-posn 0 below-piece-height)
+     (make-posn 0 0)))
+  
+  (define (below-hex-piece dark?)
+    (polygon
+     (if dark? below-piece-dark-color below-piece-light-color)
+     (make-posn 0 0)
+     (offset-posns hex-tooth-offset 0 (hex-tooth #f))
+     (make-posn below-piece-width 0)
+     (make-posn below-piece-width below-piece-height)
+     (make-posn 0 below-piece-height)
+     (make-posn 0 0)))
+  
+  (define (below-interpose-piece dark?)
+    (polygon
+     (if dark? below-interpose-piece-dark-color below-interpose-piece-light-color)
+     (make-posn 0 0)
+     (offset-posns pointy-tooth-offset 0 (hex-tooth #f))
+     (make-posn below-interpose-piece-width 0)
+     (make-posn below-interpose-piece-width below-interpose-piece-height)
+     (offset-posns hex-tooth-offset below-interpose-piece-height (reverse (pointy-tooth #t)))
+     (make-posn 0 below-interpose-piece-height)
+     (make-posn 0 0)))
+  
+  (define (right-piece dark?)
+    (polygon
+     (if dark? right-piece-dark-color right-piece-light-color)
+     (make-posn 0 0)
+     (offset-posns 0 square-tooth-offset (square-tooth #f))
+     (make-posn 0 right-piece-height)
+     (make-posn right-piece-width right-piece-height)
+     (make-posn right-piece-width 0)
+     (make-posn 0 0)))
+  
+  (define (polygon color . points)
+    (let ([flat-points (flatten points)])
+      (when (null? flat-points)
+        (error 'polygon "expected at least one point"))
+      (dc
+       (lambda (dc x y)
+         (let ([old-brush (send dc get-brush)])
+           (send dc set-brush (send the-brush-list find-or-create-brush color 'solid))
+           (send dc draw-polygon 
+                 (map (lambda (p) (make-object point% (posn-x p) (posn-y p))) flat-points)
+                 x 
+                 y)
+           (send dc set-brush old-brush)))
+       (get-width flat-points)
+       (get-height flat-points)
+       0
+       0)))
+  
+  (define (get-width points) (apply max (map posn-x points)))
+  (define (get-height points) (apply max (map posn-y points)))
+       
+  (define (square-tooth accept?) 
+    (list (make-posn 0
+                     (if accept?
+                         (- square-tooth-accept-space)
+                         0))
+          (make-posn (- square-tooth-width)
+                     (if accept?
+                         (- square-tooth-accept-space)
+                         0))
+          (make-posn (- square-tooth-width)
+                     (if accept?
+                         (+ square-tooth-height square-tooth-accept-space)
+                         square-tooth-height))
+          (make-posn 0 
+                     (if accept?
+                         (+ square-tooth-height square-tooth-accept-space)
+                         square-tooth-height))))
+  
+  (define (hex-tooth accept?)
+    (list (make-posn (if accept?
+                         (- hex-tooth-accept-space)
+                         0) 
+                     0)
+          (make-posn (if accept? 
+                         (- hex-tooth-inset hex-tooth-accept-space)
+                         hex-tooth-inset)
+                     (- hex-tooth-height))
+          (make-posn (if accept? 
+                         (+ (- hex-tooth-width hex-tooth-inset) hex-tooth-accept-space)
+                         (- hex-tooth-width hex-tooth-inset))
+                     (- hex-tooth-height))
+          (make-posn (if accept?
+                         (+ hex-tooth-width hex-tooth-accept-space)
+                         hex-tooth-width) 
+                     0)))
+  
+  (define (pointy-tooth accept?)
+    (list
+     (make-posn (if accept? (- pointy-tooth-accept-space) 0)
+                0)
+     (make-posn (/ pointy-tooth-width 2)
+                (if accept? 
+                    (- (+ pointy-tooth-height pointy-tooth-accept-space))
+                    (- pointy-tooth-height)))
+     (make-posn (if accept?
+                    (+ pointy-tooth-accept-space pointy-tooth-width)
+                    pointy-tooth-width)
+                0)))
+  
+  (define (offset-posns x y posns)
+    (map (lambda (pt) (make-posn (+ x (posn-x pt)) (+ y (posn-y pt)))) posns))
+  
+  (define (flatten orig-sexp)
+    (let loop ([sexp orig-sexp]
+               [acc null])
+      (cond
+        [(null? sexp) acc]
+        [(pair? sexp)
+         (loop (car sexp) (loop (cdr sexp) acc))]
+        [else (cons sexp acc)])))
+  
+  (define (overlay-striped-background color diameter pict)
+    (let* ([w (pict-width pict)]
+           [h (pict-height pict)]
+           [pt1 (make-object point% 0 0)]
+           [pt2 (make-object point% 0 0)]
+           [pt3 (make-object point% 0 0)]
+           [poly (list pt1 pt2 pt3)]
+           [bkg
+            (dc
+             (lambda (dc dx dy)
+               (let ([old-pen (send dc get-pen)]
+                     [old-brush (send dc get-brush)]
+                     [pen (send the-pen-list find-or-create-pen color 1 'solid)]
+                     [brush (send the-brush-list find-or-create-brush color 'solid)])
+                 (unless pen
+                   (error "unknown color: ~s" color))
+                 (send dc set-pen pen)
+                 (send dc set-brush brush)
+                 (let loop ([x 0]
+                            [t #f])
+                   (when (< x w)
+                     (let loop ([y 0]
+                                [t t])
+                       (when (< y h)
+                         (if t
+                             (begin
+                               (send pt1 set-x (+ x dx))
+                               (send pt1 set-y (+ y dy))
+                               (send pt2 set-x (+ x dx diameter))
+                               (send pt2 set-y (+ y dy))
+                               (send pt3 set-x (+ x dx))
+                               (send pt3 set-y (+ y dy diameter)))
+                             (begin
+                               (send pt1 set-x (+ x dx))
+                               (send pt1 set-y (+ y dy diameter))
+                               (send pt2 set-x (+ x dx diameter))
+                               (send pt2 set-y (+ y dy))
+                               (send pt3 set-x (+ x dx diameter))
+                               (send pt3 set-y (+ y dy diameter))))
+                         (send dc draw-polygon poly)
+                         (loop (+ y diameter)
+                               (not t))))
+                     (loop (+ x diameter)
+                           (not t))))
+                 (send dc set-pen old-pen)
+                 (send dc set-brush old-brush)))
+             w
+             h
+             0
+             0)])
+      (cc-superimpose bkg pict)))
+  
+  (define (overlay-background color pict)
+    (let* ([w (pict-width pict)]
+           [h (pict-height pict)]
+           [bkg
+            (dc
+             (lambda (dc x y)
+               (let ([old-pen (send dc get-pen)]
+                     [old-brush (send dc get-brush)]
+                     [pen (send the-pen-list find-or-create-pen color 1 'solid)]
+                     [brush (send the-brush-list find-or-create-brush color 'solid)])
+                 (unless pen
+                   (error "unknown color: ~s" color))
+                 (send dc set-pen pen)
+                 (send dc set-brush brush)
+                 (send dc draw-rectangle x y w h)
+                 (send dc set-pen old-pen)
+                 (send dc set-brush old-brush)))
+             w
+             h
+             0
+             0)])
+      (cc-superimpose bkg pict)))
+  
+  (define (ident x) x)
+
+  (interlocking-components))
diff --git a/collects/slideshow/info.ss b/collects/slideshow/info.ss
new file mode 100644
index 0000000000..88701a76b1
--- /dev/null
+++ b/collects/slideshow/info.ss
@@ -0,0 +1,12 @@
+
+(module info (lib "infotab.ss" "setup")
+  (define doc.txt "doc.txt")
+  (define name "Slideshow")
+  (define tools (list '("tool.ss")))
+  (define tool-names (list "Slideshow"))
+  (define tool-icons (list (list "slideshow.png" "slideshow")))
+  (define tool-urls (list "http://www.plt-scheme.org/software/slideshow/"))
+  (define mred-launcher-libraries (list "start.ss"))
+  (define mred-launcher-names (list "Slideshow"))
+  (define compile-omit-files
+    (list "tutorial-show.ss" "initial-ones.ss" "pict-snipclass.ss")))
diff --git a/collects/slideshow/initial-ones.ss b/collects/slideshow/initial-ones.ss
new file mode 100644
index 0000000000..fdb4c555d0
--- /dev/null
+++ b/collects/slideshow/initial-ones.ss
@@ -0,0 +1,181 @@
+
+(module initial-ones mzscheme
+  ;; Instead of using the "slideshow.ss" language module,
+  ;;  we can use mzscheme and import "slide.ss"
+  (require (lib "slide.ss" "slideshow")
+	   (lib "code.ss" "slideshow")
+	   (lib "mred.ss" "mred")
+	   (lib "class.ss")
+	   (lib "etc.ss"))
+
+  (provide do-initial-slides)
+
+  (define (do-initial-slides)
+    (begin-with-definitions
+      (slide/name/center
+       "Title Slide"
+       (titlet "Slideshow Tutorial")
+       (blank)
+       (size-in-pixels
+	(bitmap (build-path (collection-path "icons") "PLT-206.png")))
+       (blank)
+       (colorize (it "Press the spacebar to continue") blue)
+       (comment "Welcome to Slideshow"))
+
+      (slide/title/center
+       "About Slideshow"
+       (page-para (bt "Slideshow")
+		  "is a library for creating slide presentations")
+       (page-item "A Slideshow presentation is a PLT Scheme program")
+       (page-item "Instead of a WYSIWYG interface,"
+		  "you get the power of Scheme"))
+      
+      (define (symbol n)
+	(text (string (integer->char n)) 'symbol font-size))
+      (define sym:rightarrow (symbol 174))
+      (define sym:leftarrow (symbol 172))
+
+      (define (meta key)
+	(hbl-append (t "Alt-") 
+		    (if (pict? key) key (tt key))
+		    (t ", Cmd-") 
+		    (if (pict? key) key (tt key))
+		    (t ", or Meta-") 
+		    (if (pict? key) key (tt key))))
+
+      (slide/title
+       "How to Control this Viewer"
+       (scale/improve-new-text
+	(table 3
+	       (apply
+		append
+		(map (lambda (s)
+		       (list (apply page-para* (car s)) (t ":") (t (cadr s))))
+		     `(((,(meta "q")) "end show")
+		       (("Esc") "if confirmed, end show")
+		       ((,sym:rightarrow ", Space," ,(tt "f") "," ,(tt "n") ", or click") "next slide")
+		       ((,sym:leftarrow ", Backspace, Delete, or" ,(tt "b")) "previous slide")
+		       ((,(tt "g")) "last slide")
+		       ((,(tt "1")) "first slide")
+		       ((,(meta "g")) "select a slide")
+		       ((,(meta "p")) "show/hide slide number")
+		       ((,(meta "c")) "show/hide commentary")
+		       ((,(meta "d")) "show/hide preview")
+		       ((,(meta "m")) "show/hide mouse cursor")
+		       ((,(hbl-append (t "Shift-") sym:rightarrow) ", etc.") "move window 1 pixel")
+		       ((,(meta sym:rightarrow) ", etc.") "move window 10 pixels"))))
+	       lbl-superimpose lbl-superimpose
+	       gap-size (/ gap-size 2))
+	0.9)
+       (comment "This window shows comments for each slide. "
+		"The comments are typically fill in the details of what "
+		"the slide presenter says when giving the talk."))
+		
+
+      (define mytalk.scm (tt "mytalk.scm"))
+
+
+      (slide/title
+       "Slideshow Programs"
+       (page-para "A Slideshow program has the form")
+       (scale/improve-new-text
+	(code (module mytalk (lib "slideshow.ss" "slideshow")
+		... #,(it "code to generate slide content") ...))
+	0.9)
+       (page-para "in a file named" mytalk.scm)
+       (colorize (hline (* 3/4 client-w) gap-size) "green")
+       'alts
+       (list (list (page-para "To run a Slideshow program,")
+		   (page-item "Double-click the" (bt "Slideshow") "executable or run" 
+			      (tt "slideshow") "on the command line")
+		   (page-item "Click the" (bt "Open File...") "link and select the"
+			      "Slideshow program file, such as" mytalk.scm))
+	     (list (page-para "Alternately, run a Slideshow program in DrScheme:")
+		   (page-item "Open" mytalk.scm "in DrScheme")
+		   (page-item "Select" (bt "Choose Language") "from the" (bt "Language") "menu")
+		   (page-item "Choose the" (tt "(module ...)") "language")
+		   (page-item "Click" (bt "Execute"))
+		   (colorize (bt "Use DrScheme only if you trust the program") "red"))
+	     (list (page-para (colorize (bt "Important security information:") "red"))
+		   (page-item "A slideshow program has access to the"
+			      (it "full") (it "Scheme") (it "language"))
+		   (page-item "If you don't know the creator of a slide program"
+			      "(or if you don't trust them), run the slides through the"
+			      (bt "Slideshow") "executable or"
+			      (tt "slideshow") "command line")
+		   (colorize
+		    (page-item/bullet
+		     (ghost bullet)
+		     "When run in" (bt "Slideshow") "instead of DrScheme,"
+		     "a slide program cannot write files"
+		     "or make network connections")
+		    "blue"))
+	     (list (page-para "When using a command line, you can specify the program directly:")
+		   (hbl-append (tt "slideshow ") mytalk.scm)
+		   (blank)
+		   (page-para "To print the talk:")
+		   (hbl-append (tt "slideshow --print ") mytalk.scm)
+		   (blank)
+		   (colorize
+		    (page-para/r (it "Run") (tt "slideshow --help") (it "for more options"))
+		    "blue"))))
+
+      (define (sub-para . l)
+	(colorize (apply para (* 3/4 client-w) l) "blue"))
+
+      (slide/title
+       "Slides and Picts"
+       (page-para "The body of a Slideshow program")
+       (page-item/bullet (bt " 1.")
+			 "Makes and combines" (hbl-append (bit "pict") (t "s")))
+       (sub-para "For example,")
+       (code (t "Hello"))
+       (sub-para "creates a pict like this:")
+       (colorize (t "Hello") "black")
+       (page-item/bullet (bt " 2.") "Registers certain picts as slides")
+       (sub-para "For example,")
+       (code (slide (t "Hello")))
+       (sub-para "registers a slide containing only" (colorize (t "Hello") "black")))
+
+      (slide/title/center
+       "Slides versus Picts"
+       (page-para "Technically, the pict concept comes from the"
+		  (tt "\"texpict\"") "collection, and the"
+		  (tt "\"slideshow\"") "collection builds on it")
+       (page-item "The distinction between"
+		  "Slideshow and texpict matters when you"
+		  "use Help Desk to find information")
+       (page-item "For now, we ignore the distinction"))
+
+      (slide/title/center
+       "The Rest of the Tutorial"
+       (page-para "The rest of this tutorial (starting with the next slide) is meant to"
+		  "be viewed while reading the program source")
+       (blank)
+       (page-para "The source is")
+       (let ([s (path->string (build-path (this-expression-source-directory) "tutorial-show.ss"))])
+	 (clickback
+	  (scale/improve-new-text
+	   (let ([p (tt s)])
+	     (colorize
+	      (place-over p 0 (pict-height p)
+			  (linewidth 2 (hline (pict-width p) 2)))
+	      "blue"))
+	   (min 1 (/ (* 0.8 client-w ) (pict-width (tt s)))))
+	  (lambda ()
+	    (let* ([f (new frame% 
+			   [label "tutorial-show.ss"]
+			   [width 600]
+			   [height 400])]
+		   [e (new text%)]
+		   [c (new editor-canvas% 
+			   [parent f]
+			   [editor e])])
+	      (send e load-file s)
+	      (send e change-style 
+		    (make-object style-delta% 'change-family 'modern)
+		    0 'end)
+	      (send f show #t))))))
+      )
+    (void)))
+
diff --git a/collects/slideshow/mask.xbm b/collects/slideshow/mask.xbm
new file mode 100644
index 0000000000..fe839e645c
--- /dev/null
+++ b/collects/slideshow/mask.xbm
@@ -0,0 +1,15 @@
+/* Created with The GIMP */
+#define mask_width 32
+#define mask_height 32
+static unsigned char mask_bits[] = {
+   0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xfe, 0xff, 0xff, 0x7f,
+   0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f,
+   0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f,
+   0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f,
+   0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f,
+   0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f,
+   0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f,
+   0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f,
+   0x00, 0x80, 0x00, 0x00, 0x00, 0xc0, 0x01, 0x00, 0x00, 0xe0, 0x03, 0x00,
+   0x00, 0xb0, 0x06, 0x00, 0x00, 0x98, 0x0c, 0x00, 0x00, 0x8c, 0x18, 0x00,
+   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00 };
diff --git a/collects/slideshow/param.ss b/collects/slideshow/param.ss
new file mode 100644
index 0000000000..37f4a89ae5
--- /dev/null
+++ b/collects/slideshow/param.ss
@@ -0,0 +1,18 @@
+
+(module param mzscheme
+  (require (lib "unitsig.ss")
+	   "sig.ss"
+	   "cmdline.ss"
+	   "viewer.ss")
+
+  (provide current-slideshow-linker)
+
+  (define current-slideshow-linker 
+    (make-parameter 
+     (lambda (core@)
+       (compound-unit/sig
+	(import)
+	(link [CONFIG : cmdline^ (cmdline@)]
+	      [CORE : core^ (core@ (CONFIG : config^) VIEWER)]
+	      [VIEWER : viewer^ (viewer@ CONFIG CORE)])
+	(export (open CORE) (unit (CONFIG : config^) config) (unit VIEWER viewer)))))))
diff --git a/collects/slideshow/pict-snipclass.ss b/collects/slideshow/pict-snipclass.ss
new file mode 100644
index 0000000000..b92a8b8314
--- /dev/null
+++ b/collects/slideshow/pict-snipclass.ss
@@ -0,0 +1,31 @@
+(module pict-snipclass mzscheme
+  (require (lib "class.ss")
+           (lib "mred.ss" "mred"))
+  
+  (provide snip-class)
+  (require "private/pict-box-lib.ss")
+
+  (define pict-snip%
+    (class* editor-snip% (readable-snip<%>)
+      (define/public (read-special file line col pos)
+        (build-lib-pict-stx 
+         (lambda (ids) (syntax (void)))
+         (get-snp/poss this)))
+      (super-new)))
+  
+  (define lib-pict-snipclass%
+    (class snip-class%
+      (define/override (read stream-in)
+        (let* ([snip (new pict-snip%)]
+               [editor (new pasteboard%)]
+               [show-picts? (not (zero? (send stream-in get-exact)))]
+               [up-to-date? (not (zero? (send stream-in get-exact)))])
+          (send snip set-editor editor)
+          (send editor read-from-file stream-in #f)
+          snip))
+      (super-new)))
+  
+  (define snip-class (make-object lib-pict-snipclass%))
+  (send snip-class set-version 2)
+  (send snip-class set-classname (format "~s" '(lib "pict-snipclass.ss" "slideshow")))
+  (send (get-the-snip-class-list) add snip-class))
\ No newline at end of file
diff --git a/collects/slideshow/private/image-snipr.ss b/collects/slideshow/private/image-snipr.ss
new file mode 100644
index 0000000000..862378f257
--- /dev/null
+++ b/collects/slideshow/private/image-snipr.ss
@@ -0,0 +1,47 @@
+(module image-snipr mzscheme
+  (require (lib "mred.ss" "mred")
+           (lib "class.ss"))
+
+  (provide snipclass
+           image-snip/r%)
+  
+  (define image-snip/r%
+    (class image-snip%
+      (init bitmap)
+      (init-field orig-snip)
+      (define/public (get-orig-snip) orig-snip)
+      
+      (inherit get-bitmap)
+      (define/override (copy) (make-object image-snip/r% (get-bitmap) orig-snip))
+      
+      (super-make-object bitmap)
+      
+      (inherit set-snipclass set-bitmap)
+      (set-snipclass snipclass)
+      
+      (define/override (write stream-out)
+        (super write stream-out)
+        (let* ([sc (send orig-snip get-snipclass)]
+               [cn-bytes (string->bytes/utf-8 (send sc get-classname))])
+          (send stream-out put (+ (bytes-length cn-bytes) 1) cn-bytes)
+          (send orig-snip write stream-out)))))
+  
+  (define image-snip/r-snipclass%
+    (class snip-class%
+      (define/override (read stream-in)
+        (let* ([is-sc (send (get-the-snip-class-list) find "wximage")]
+               [bs (send is-sc read stream-in)]
+               [bm (send bs get-bitmap)])
+          (send bs set-bitmap (make-object bitmap% 1 1)) ;; ugh
+          (let* ([name (bytes->string/utf-8 (send stream-in get-bytes))]
+                 [sc (send (get-the-snip-class-list) find name)])
+            (unless sc
+              (error 'ack! "did not find a snipclass ~s, so cannot continue parsing stream" name))
+            (let* ([hidden-snip (send sc read stream-in)])
+              (make-object image-snip/r% bm hidden-snip)))))
+      (super-new)))
+  
+  (define snipclass (new image-snip/r-snipclass%))
+  (send snipclass set-classname (format "~s" '(lib "image-snipr.ss" "slideshow" "private")))
+  (send snipclass set-version 1)
+  (send (get-the-snip-class-list) add snipclass))
diff --git a/collects/slideshow/private/pict-box-lib.ss b/collects/slideshow/private/pict-box-lib.ss
new file mode 100644
index 0000000000..42aa86529d
--- /dev/null
+++ b/collects/slideshow/private/pict-box-lib.ss
@@ -0,0 +1,64 @@
+(module pict-box-lib mzscheme
+  (require (lib "mred.ss" "mred")
+           (lib "class.ss")
+           (lib "mrpict.ss" "texpict")
+           "image-snipr.ss")
+  
+  (provide get-snp/poss
+           build-lib-pict-stx
+           snip-location
+           (struct snp/pos (snp x y))
+           generate-ids)
+  
+  (define-struct snp/pos (snp x y))
+  
+  ;; get-snip/poss : editor-snip -> (listof snp/pos)
+  ;; called on drscheme's thread
+  (define (get-snp/poss es)
+    (let ([pb (send es get-editor)])
+      (let loop ([snip (send pb find-first-snip)])
+        (cond
+          [(not snip) null]
+          [(is-a? snip image-snip/r%)
+           (let ([real-snip (send snip get-orig-snip)])
+             (let-values ([(x y) (snip-location pb snip)])
+               (cons (make-snp/pos real-snip x y)
+                     (loop (send snip next)))))]
+          [(is-a? snip readable-snip<%>)
+           (let-values ([(x y) (snip-location pb snip)])
+             (cons (make-snp/pos snip x y)
+                   (loop (send snip next))))]
+          [else (loop (send snip next))]))))
+  
+  ;; build-lib-pict-stx : syntax (listof snp/pos) -> syntax
+  ;; called on the user's thread
+  (define (build-lib-pict-stx send-back snp/poss)
+    (with-syntax ([(subpicts ...) (map (lambda (snp/pos) (send (snp/pos-snp snp/pos) read-special #f 0 0 0))
+                                       snp/poss)]
+                  [(ids ...) (generate-ids "snip-id" (map snp/pos-snp snp/poss))]
+                  [(x ...) (map snp/pos-x snp/poss)]
+                  [(y ...) (map snp/pos-y snp/poss)])
+      (with-syntax ([send-back (send-back (syntax (ids ...)))])
+        (syntax
+         (let ([ids subpicts] ...)
+           send-back
+           (let ([max-h (max 0 (+ y (pict-height ids)) ...)])
+             (panorama (picture 0 0 `((place ,(- x (/ (pict-height ids) 2))
+                                             ,(- max-h y (/ (pict-height ids) 2))
+                                             ,ids)
+                                      ...)))))))))
+  
+  (define (generate-ids pre lst)
+    (let loop ([i 0]
+               [l lst])
+      (cond
+        [(null? l) null]
+        [else (cons (datum->syntax-object #'here (string->symbol (format "~a~a" pre i)))
+                    (loop (+ i 1)
+                          (cdr l)))])))
+  
+  (define (snip-location pb snip)
+    (let ([x (box 0)]
+          [y (box 0)])
+      (send pb get-snip-location snip x y)
+      (values (unbox x) (unbox y)))))
diff --git a/collects/slideshow/run.ss b/collects/slideshow/run.ss
new file mode 100644
index 0000000000..eea4aabacc
--- /dev/null
+++ b/collects/slideshow/run.ss
@@ -0,0 +1,2 @@
+(module run "slideshow.ss"
+  (provide (all-from "slideshow.ss")))
diff --git a/collects/slideshow/sig.ss b/collects/slideshow/sig.ss
new file mode 100644
index 0000000000..2a63f335a5
--- /dev/null
+++ b/collects/slideshow/sig.ss
@@ -0,0 +1,100 @@
+
+(module sig mzscheme
+  (require (lib "unitsig.ss"))
+
+  (provide config^ viewer^ core^
+	   cmdline^)
+
+  ;; Configuration inputs to the core unit:
+  (define-signature config^
+    (base-font-size             ; normally 32
+     screen-w screen-h          ; logical size, normally 1024x768
+     use-screen-w use-screen-h  ; "pixel" size
+     pixel-scale                ; amount the "pixels" are scaled (e.g., for quad)
+     condense? printing?        ; mode
+     smoothing?))
+     
+  ;; Viewer inputs to the core unit:
+  (define-signature viewer^
+    (;; Registering slides:
+     add-talk-slide!
+     retract-talk-slide!
+     most-recent-talk-slide
+     ;; Pass-through of slide-program requests:
+     set-init-page!
+     set-use-background-frame!
+     enable-click-advance!
+     set-page-numbers-visible!
+     done-making-slides
+     ;; Called when a clickback-containing slide is rendered:
+     add-click-region!))
+
+  ;; The core unit's exports, which are the functions used by a 
+  ;; Slideshow program:
+  (define-signature core^
+    (slide
+     slide/title
+     slide/title/tall
+     slide/center
+     slide/title/center 
+     slide/inset
+     slide/title/inset
+     slide/title/tall/inset
+     slide/center/inset
+     slide/title/center/inset
+     slide/name 
+     slide/name/tall 
+     slide/name/center 
+     slide/name/inset
+     slide/name/tall/inset
+     slide/name/center/inset
+     
+     most-recent-slide retract-most-recent-slide re-slide start-at-recent-slide
+     scroll-transition pause-transition
+     comment make-outline
+     item item* page-item page-item*
+     item/bullet item*/bullet page-item/bullet page-item*/bullet
+     subitem subitem* page-subitem page-subitem*
+     itemize itemize* page-itemize page-itemize*
+     para para* page-para page-para*
+     para/c para/r para*/c para*/r page-para/c page-para/r page-para*/c page-para*/r
+     font-size gap-size current-font-size line-sep title-size 
+     main-font current-main-font with-font current-title-color
+     red green blue purple orange size-in-pixels
+     t it bt bit tt titlet tt* rt
+     bullet o-bullet
+     get-margin set-margin! get-client-w get-client-h
+     get-full-page get-titleless-page
+     skip-slides
+     set-use-background-frame!
+     enable-click-advance!
+     get-title-h set-title-h! current-slide-assembler
+     current-page-number-font current-page-number-color
+     set-page-numbers-visible! done-making-slides
+     clickback 
+     make-slide-inset
+     apply-slide-inset
+     condense?
+     printing?))
+
+  ;; ----------------------------------------
+
+  ;; Extra cmdline inputs to a viewer:
+  (define-signature cmdline^
+    ((open config^)
+     file-to-load ; #f or a path/string
+     init-page
+     use-transitions? 
+     print-slide-seconds?
+     show-page-numbers?
+     commentary?
+     use-offscreen?
+     actual-screen-w actual-screen-h ; actual size (center use- within here)
+     trust-me?
+     quad-view?
+     keep-titlebar?
+     two-frames?
+     use-prefetch?
+     use-prefetch-in-preview?
+     print-target
+     talk-duration-minutes)))
diff --git a/collects/slideshow/slide.ss b/collects/slideshow/slide.ss
new file mode 100644
index 0000000000..0b5b4c2009
--- /dev/null
+++ b/collects/slideshow/slide.ss
@@ -0,0 +1,118 @@
+
+(module slide mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "contract.ss")
+	   (lib "mrpict.ss" "texpict")
+	   (lib "utils.ss" "texpict")
+	   "sig.ss"
+	   "core.ss"
+	   "util.ss"
+	   "param.ss")
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;       Link Config and Viewer with Core        ;;
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  ;; The actual config and viewer untis are determined by a parameter
+  ;;  in "param.ss". This somewhat strange technqiue allows the units
+  ;;  to be changed as this module is loaded in a new namespace; see
+  ;;  "slides-to-picts.ss". Such namespace games are not necessary if
+  ;;  talks are written as units and linked to the core.ss unit.
+
+  (define-values/invoke-unit/sig ((open core^) 
+				  (unit config : config^) 
+				  (unit viewer : viewer^))
+    ((current-slideshow-linker) core@))
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;                Contracts                      ;;
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  ;; Let the contract check always pass for now. We do more specific checking.
+  (define (slide-sequence? l) #t)
+
+  (define slide-contract
+    (() slide-sequence? . ->* . any))
+  (define slide/title-contract
+    ((string?) slide-sequence? . ->* . any))
+  (define slide/inset-contract
+    ((sinset?) slide-sequence? . ->* . any))
+  (define slide/title/inset-contract
+    ((string? sinset?) slide-sequence? . ->* . any))
+
+  (define (side-inset? n) (and (number? n)
+			       (exact? n)
+			       (integer? n)
+			       (n . >= . 0)))
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;                 Exports                       ;;
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  ;; Mostly we re-export core^, but we also add contracts.
+
+  ;; Create macros for `get-margin', etc.
+  (define-accessor margin get-margin)
+  (define-accessor title-h get-title-h)
+  (define-accessor client-w get-client-w)
+  (define-accessor client-h get-client-h)
+  (define-accessor full-page get-full-page)
+  (define-accessor titleless-page get-titleless-page)
+  
+  (provide/contract [slide slide-contract]
+		    [slide/title slide/title-contract]
+		    [slide/title/tall slide/title-contract]
+		    [slide/center slide-contract]
+		    [slide/title/center slide/title-contract]
+		    [slide/inset slide/inset-contract]
+		    [slide/title/inset slide/title/inset-contract]
+		    [slide/title/tall/inset slide/title/inset-contract]
+		    [slide/center/inset slide/inset-contract]
+		    [slide/title/center/inset slide/title/inset-contract]
+		    [slide/name slide/title-contract]
+		    [slide/name/tall slide/title-contract]
+		    [slide/name/center slide/title-contract]
+		    [slide/name/inset slide/title/inset-contract]
+		    [slide/name/tall/inset slide/title/inset-contract]
+		    [slide/name/center/inset slide/title/inset-contract]
+		    [comment (() (listof (union string? pict?)) . ->* . any)])
+  (provide most-recent-slide retract-most-recent-slide re-slide start-at-recent-slide
+	   scroll-transition pause-transition
+	   make-outline
+	   item item* page-item page-item*
+	   item/bullet item*/bullet page-item/bullet page-item*/bullet
+	   subitem subitem* page-subitem page-subitem*
+	   itemize itemize* page-itemize page-itemize*
+	   para para* page-para page-para*
+	   para/c para/r para*/c para*/r page-para/c page-para/r page-para*/c page-para*/r
+	   font-size gap-size current-font-size line-sep title-size 
+	   main-font current-main-font with-font current-title-color
+	   red green blue purple orange size-in-pixels
+	   t it bt bit tt titlet tt* rt
+	   bullet o-bullet
+	   margin get-margin set-margin! 
+	   client-w client-h get-client-w get-client-h
+	   full-page titleless-page get-full-page get-titleless-page
+	   printing? condense?
+	   skip-slides
+	   set-use-background-frame!
+	   enable-click-advance!
+	   title-h get-title-h set-title-h! current-slide-assembler
+	   current-page-number-font current-page-number-color 
+	   set-page-numbers-visible! done-making-slides)
+  (provide/contract [clickback 
+		     ((pict? (lambda (x)
+			       (and (procedure? x)
+				    (procedure-arity-includes? x 0))))
+		      (any/c)
+		      . opt-> .
+		      pict?)]
+		    [make-slide-inset
+		     (side-inset? side-inset? side-inset? side-inset?
+				  . -> .
+				  sinset?)]
+		    [apply-slide-inset
+		     (sinset? pict? . -> . pict?)])
+  ;; Things not at all in the core unit:
+  (provide (all-from (lib "mrpict.ss" "texpict"))
+	   (all-from (lib "utils.ss" "texpict"))))
diff --git a/collects/slideshow/slides-to-picts.ss b/collects/slideshow/slides-to-picts.ss
new file mode 100644
index 0000000000..6273a37ba9
--- /dev/null
+++ b/collects/slideshow/slides-to-picts.ss
@@ -0,0 +1,74 @@
+
+(module slides-to-picts mzscheme
+  (require (lib "mred.ss" "mred")
+	   (lib "class.ss")
+	   (lib "unitsig.ss")
+	   (lib "etc.ss")
+	   "sig.ss"
+	   "param.ss"
+	   "core.ss"
+	   (lib "mrpict.ss" "texpict"))
+
+  (provide get-slides-as-picts)
+
+  (define get-slides-as-picts
+    (opt-lambda (file w h c? [stop-after #f])
+      (let ([ns (make-namespace-with-mred)]
+	    [orig-ns (current-namespace)]
+	    [param ((current-module-name-resolver) '(lib "param.ss" "slideshow") #f #f)]
+	    [core ((current-module-name-resolver) '(lib "core.ss" "slideshow") #f #f)]
+	    [slides null]
+	    [xs (/ w 1024)]
+	    [ys (/ h 768)]
+	    [escape void])
+	(parameterize ([current-namespace ns])
+	  (namespace-attach-module orig-ns param)
+	  (namespace-attach-module orig-ns core))
+	(current-slideshow-linker
+	 (lambda (core@)
+	   (compound-unit/sig
+	    (import)
+	    (link [CONFIG : config^ ((unit/sig config^
+				       (import)
+				       (define base-font-size 32)
+				       (define screen-w 1024)
+				       (define screen-h 768)
+				       (define use-screen-w w)
+				       (define use-screen-h h)
+				       (define pixel-scale 1)
+				       (define condense? c?)
+				       (define printing? #f)
+                                       (define smoothing? #t)))]
+		  [CORE : core^ (core@ CONFIG (VIEWER : viewer^))]
+		  [VIEWER : viewer^ ((unit/sig viewer^
+				       (import)
+				       (define (add-talk-slide! s)
+					 (set! slides (cons s slides))
+					 (when (and stop-after
+						    ((length slides) . >= . stop-after))
+					   (escape (void))))
+				       (define (retract-talk-slide!)
+					 (set! slides (cdr slides)))
+				       (define (most-recent-talk-slide)
+					 (and (pair? slides) (car slides)))
+				       (define display-progress void)
+				       (define set-init-page! void)
+				       (define set-use-background-frame! void)
+				       (define enable-click-advance! void)
+				       (define set-page-numbers-visible! void)
+				       (define add-click-region! void)
+				       (define done-making-slides void)))])
+	    (export (open CORE) (unit CONFIG config) (unit VIEWER viewer)))))
+	(parameterize ([current-namespace ns])
+	  (let/ec k
+	    (set! escape k)
+	    (dynamic-require `(file ,file) #f)))
+	(map (lambda (s)
+	       (let ([drawer (sliderec-drawer s)])
+		 (dc (lambda (dc x y)
+		       (let-values ([(orig-xs orig-ys) (send dc get-scale)])
+			 (send dc set-scale (* orig-xs xs) (* orig-ys ys))
+			 (drawer dc (+ (/ x xs) 20) (+ (/ y ys) 20))
+			 (send dc set-scale orig-xs orig-ys)))
+		     w h 0 0)))
+	     (reverse slides))))))
diff --git a/collects/slideshow/slideshow.bmp b/collects/slideshow/slideshow.bmp
new file mode 100644
index 0000000000..06bbf338f3
Binary files /dev/null and b/collects/slideshow/slideshow.bmp differ
diff --git a/collects/slideshow/slideshow.png b/collects/slideshow/slideshow.png
new file mode 100644
index 0000000000..388e0d5bb1
Binary files /dev/null and b/collects/slideshow/slideshow.png differ
diff --git a/collects/slideshow/slideshow.ss b/collects/slideshow/slideshow.ss
new file mode 100644
index 0000000000..9903553e7c
--- /dev/null
+++ b/collects/slideshow/slideshow.ss
@@ -0,0 +1,6 @@
+
+(module slideshow mzscheme
+  (require (lib "slide.ss" "slideshow"))
+  (provide (all-from (lib "slide.ss" "slideshow"))
+	   (all-from mzscheme)))
+
diff --git a/collects/slideshow/start-param.ss b/collects/slideshow/start-param.ss
new file mode 100644
index 0000000000..3b36b0bc7c
--- /dev/null
+++ b/collects/slideshow/start-param.ss
@@ -0,0 +1,9 @@
+
+(module start-param mzscheme
+  (provide file-to-load
+	   trust-me?)
+
+  (define file-to-load (make-parameter #f))
+  (define trust-me? (make-parameter #t)))
+
+	   
\ No newline at end of file
diff --git a/collects/slideshow/start.creator b/collects/slideshow/start.creator
new file mode 100644
index 0000000000..8dfd6081c3
--- /dev/null
+++ b/collects/slideshow/start.creator
@@ -0,0 +1,2 @@
+PSlS
+(This code is registered with Apple.)
diff --git a/collects/slideshow/start.icns b/collects/slideshow/start.icns
new file mode 100644
index 0000000000..581e34f7bd
Binary files /dev/null and b/collects/slideshow/start.icns differ
diff --git a/collects/slideshow/start.ico b/collects/slideshow/start.ico
new file mode 100644
index 0000000000..5cdbffdb2d
Binary files /dev/null and b/collects/slideshow/start.ico differ
diff --git a/collects/slideshow/start.ss b/collects/slideshow/start.ss
new file mode 100644
index 0000000000..1a144e732d
--- /dev/null
+++ b/collects/slideshow/start.ss
@@ -0,0 +1,72 @@
+
+(module start "slideshow.ss"
+  (require "start-param.ss"
+	   (lib "mred.ss" "mred")
+	   (lib "class.ss"))
+
+  (define (load-content content)
+    (unless (trust-me?)
+      (current-security-guard
+       (make-security-guard (current-security-guard)
+			    (lambda (who what mode)
+			      (when (memq 'write mode)
+				(error 'slideshow
+				       "slide program attempted to write to filesystem: ~e"
+				       what))
+			      (when (memq 'execute mode)
+				(error 'slideshow
+				       "slide program attempted to execute external code: ~e"
+				       what)))
+			    (lambda (who where-name where-port-num mode)
+			      (error 'slideshow
+				     "slide program attempted to make a network connection")))))
+    (dynamic-require (path->complete-path content) #f)
+    (done-making-slides))
+
+  (when (file-to-load)
+    (load-content (string->path (file-to-load))))
+
+  (unless (most-recent-slide)
+    (let ([link (lambda (label thunk)
+		  (clickback (colorize 
+			      (let ([p (t label)])
+				(refocus (vc-append p
+						    (linewidth 2 (hline (pict-width p) 2)))
+					 p))
+			      "blue")
+			     thunk))])
+      (slide/center
+       (hc-append
+	(* 4 gap-size)
+	(titlet "Welcome to Slideshow")
+	(vl-append
+	 gap-size
+	 (page-para* (link "Run Tutorial"
+			   (lambda ()
+			     (retract-most-recent-slide)
+			     (load-content
+			      (build-path (collection-path "slideshow")
+					  "tutorial-show.ss")))))
+	 (page-para* (link "Open File..."
+			   (lambda ()
+			     (let ([file (get-file)])
+			       (when file
+				 (retract-most-recent-slide)
+				 (let-values ([(base name dir?) (split-path file)])
+				   (current-directory base))
+				 (load-content file))))))
+	 (blank)
+	 (page-para* (link "Quit"
+			   (lambda ()
+			     (exit))))))
+       (blank)
+       (blank)
+       (parameterize ([current-main-font `(italic . ,main-font)]
+		      [current-font-size (floor (* #e0.8 (current-font-size)))])
+	 (if (eq? (system-type) 'unix)
+	     (page-para* "To start a talk directly,"
+			 "provide the talk file as a command-line" 
+			 "argument")
+	     (page-para* "To start a talk directly,"
+			 "drag the talk file onto the" (bt "Slideshow")
+			 "application icon")))))))
diff --git a/collects/slideshow/step.ss b/collects/slideshow/step.ss
new file mode 100644
index 0000000000..1ad8d0f0ea
--- /dev/null
+++ b/collects/slideshow/step.ss
@@ -0,0 +1,113 @@
+#cs
+(module step (lib "slideshow.ss" "slideshow")
+  (require (lib "list.ss")
+	   (lib "etc.ss"))
+
+  (provide with-steps with-steps~)
+  
+  (define-syntax (with-steps stx)
+    (syntax-case stx ()
+      [(_ (step-name ...) expr0 expr ...)
+       #'(do-with-steps #f (step-name ...) expr0 expr ...)]))
+
+  (define-syntax (with-steps~ stx)
+    (syntax-case stx ()
+      [(_ (step-name ...) expr0 expr ...)
+       #'(do-with-steps #t (step-name ...) expr0 expr ...)]))
+
+  (define-syntax (define-step stx)
+    (syntax-case stx ()
+      [(_ func id steps (arg ...) 
+	  (((extra-arg ...) (def-arg ...)) ... 
+	   ((all-extra-arg ...) ())) 
+	  body)
+       (syntax/loc stx
+	 (begin
+	   (define func 
+	     (lambda (arg ... all-extra-arg ...)
+	       body))
+	   (define-syntax (id istx)
+	     (syntax-case istx ()
+	       [(_ arg ... extra-arg ...)
+		(syntax/loc istx (_ arg ... extra-arg ... def-arg ...))]
+	       ...
+	       [(_ arg ... all-extra-arg ...)
+		(begin
+		  (unless (ormap (lambda (i)
+				   (and (identifier? #'arg)
+					(module-identifier=? i #'arg)))
+				 (syntax->list (quote-syntax steps)))
+		    (raise-syntax-error
+		     #f
+		     "unknown step name"
+		     istx
+		     #'arg))
+		  ...
+		  (syntax/loc istx (func (quote arg) ... all-extra-arg ...)))]))))]))
+
+  (define-syntax (define-predicate/vproc stx)
+    (syntax-case stx ()
+      [(_ pred pred/p vproc proc steps (arg ...) body)
+       #'(begin
+	   (define-step pred/p pred steps (arg ...) ((() ())) body)
+	   (define-step v proc steps (arg ...) (((f) (values))
+						((f else-f) ()))
+	     (if (pred/p arg ...) 
+		 f
+		 else-f))
+	   (define-step v2 vproc steps (arg ...) ((() ()))
+	     (if (pred/p arg ...) 
+		 (let ([vproc (lambda (x) x)]) vproc)
+		 (let ([vproc (lambda (x) (ghost x))]) vproc))))]))
+       
+  (define-syntax (do-with-steps stx)
+    (syntax-case stx ()
+      [(_ condensing (step-name ...) expr0 expr ...)
+       (let ([capturing (lambda (s)
+			  (datum->syntax-object #'expr0 s))])
+	 (with-syntax ([only? (capturing 'only?)]
+		       [vonly (capturing 'vonly)]
+		       [only (capturing 'only)]
+		       [except? (capturing 'except?)]
+		       [vexcept (capturing 'vexcept)]
+		       [except (capturing 'except)]
+		       [before? (capturing 'before?)]
+		       [vbefore (capturing 'vbefore)]
+		       [before (capturing 'before)]
+		       [after? (capturing 'after?)]
+		       [vafter (capturing 'vafter)]
+		       [after (capturing 'after)]
+		       [between? (capturing 'between?)]
+		       [vbetween (capturing 'vbetween)]
+		       [between (capturing 'between)]
+		       [between-excl? (capturing 'between-excl?)]
+		       [vbetween-excl (capturing 'vbetween-excl)]
+		       [between-excl (capturing 'between-excl)])
+	   #'(let ([steps '(step-name ...)])
+	       (map (lambda (step)
+		      (define-predicate/vproc only? only?/p vonly only (step-name ...)
+			(p)
+			(eq? step p))
+		      (define-predicate/vproc except? except?/p vexcept except (step-name ...)
+			(p)
+			(not (eq? step p)))
+		      (define-predicate/vproc after? after?/p vafter after (step-name ...)
+			(p)
+			(memq step (or (memq p steps) null)))
+		      (define-predicate/vproc before? vbefore?/p vbefore before (step-name ...)
+			(p)
+			(not (after?/p p)))
+		      (define-predicate/vproc between? between?/p vbetween between (step-name ...)
+			(p1 p2)
+			(and (after?/p p1) (or (eq? step p2) (not (after?/p p2)))))
+		      (define-predicate/vproc between-excl? between-excl?/p vbetween-excl between-excl (step-name ...)
+			(p1 p2)
+			(and (after?/p p1) (not (after?/p p2))))
+		      (let () expr0 expr ...))
+		    (if (and condensing condense?)
+			(last-pair steps)
+			(if condense?
+			    (filter (lambda (id)
+				      (not (regexp-match #rx"~$" (symbol->string id))))
+				    steps)
+			    steps))))))])))
diff --git a/collects/slideshow/tool.ss b/collects/slideshow/tool.ss
new file mode 100644
index 0000000000..ef7ee0db07
--- /dev/null
+++ b/collects/slideshow/tool.ss
@@ -0,0 +1,896 @@
+#|
+
+todo:
+
+slideshow language:
+- handle ranges (just the first letter of an identifier), 
+- show/hide menu in the wrong place
+- dock/undock the preview window
+- editing should make the annotations disappear (need to extend the program mixin)
+- move calls to draw-pict over to user's eventspace
+
+pict snip :
+- snipclass for running snips outside of drscheme
+- need to toggle the picts back to scheme code when
+  important things happen (save, execute, etc).
+- should save the true pict size when it gets recorded.
+- show the true size in the GUI
+- when a snip is deleted from inside the pasteboard, remove it from the caches
+- check that when a snip is inserted, things revert (?).
+   maybe something better should happen?
+- test up-to-date? flag
+|#
+
+(module tool mzscheme
+  (require (lib "tool.ss" "drscheme")
+           (lib "mred.ss" "mred")
+           (lib "class.ss")
+           (lib "unitsig.ss")
+           (lib "string-constant.ss" "string-constants")
+           (lib "framework.ss" "framework")
+           (lib "mrpict.ss" "texpict")
+           (lib "pict-value-snip.ss" "texpict")
+           (lib "list.ss")
+           "private/pict-box-lib.ss"
+           "private/image-snipr.ss")
+
+  (provide tool@
+           get-snp/poss
+           build-lib-pict-stx)
+
+  (define orig-inspector (current-inspector))
+
+  (define-syntax syntax/cert 
+    (syntax-rules ()
+      [(_ stx tmpl) (let ([stx stx])
+		      (syntax-recertify
+		       (syntax/loc stx tmpl)
+		       stx
+		       orig-inspector
+		       #f))]))
+
+  (define tool@
+    (unit/sig drscheme:tool-exports^
+      (import drscheme:tool^)
+      
+      (define original-output-port (current-output-port))
+      (define (oprintf . args) (apply fprintf original-output-port args))
+      
+      (define sc-show-slideshow-panel (string-constant slideshow-show-slideshow-panel))
+      (define sc-hide-slideshow-panel (string-constant slideshow-hide-slideshow-panel))
+      (define sc-freeze-picts (string-constant slideshow-freeze-picts))
+      (define sc-thaw-picts (string-constant slideshow-thaw-picts))
+      (define sc-hide-picts (string-constant slideshow-hide-picts))
+      (define sc-show-picts (string-constant slideshow-show-picts))
+      (define sc-cannot-show-picts (string-constant slideshow-cannot-show-picts))
+      (define sc-insert-pict-box (string-constant slideshow-insert-pict-box))
+      
+      
+      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;
+      ;; pict box
+      ;;
+      
+      
+      (define pict-pasteboard%
+        (class pasteboard%
+          (inherit get-admin)
+          
+          (define/augment (after-insert snip before x y)
+            (let ([admin (get-admin)])
+              (when (is-a? admin editor-snip-editor-admin<%>)
+                (send (send admin get-snip) inserted-snip)))
+            (inner (void) after-insert snip before x y))
+          
+          (super-new)))
+      
+      (define pict-snip%
+        (class* decorated-editor-snip% (readable-snip<%>)
+          (inherit get-editor)
+
+          (define show-picts? #f)
+          
+          ;; only for use in the copy method and the read snipclass method
+          (define/public (set-show-picts b) (set! show-picts? b))
+          
+          ;; up-to-date? : boolean
+          ;; indicates if the recent shapes cache is up to date
+          (define up-to-date? #f)
+          
+          ;; only for use in the copy method and the read snipclass method
+          (define/public (set-up-to-date b) (set! up-to-date? b))
+          
+          ;; bitmap-table : hash-table[snip -o> bitmap]
+          ;; maps from the true (Scheme) snip to its current bitmap
+          (define bitmap-table (make-hash-table))
+          
+          ;; only for use in the copy method and the read snipclass method
+          (define/public (set-bitmap-table bt) (set! bitmap-table bt))
+          
+          (define/override (make-editor) (make-object pict-pasteboard%))
+          (define/override (get-corner-bitmap) slideshow-bm)
+          
+          (define/override (copy)
+            (let* ([cp (make-object pict-snip%)]
+                   [ed (send cp get-editor)])
+              (send (get-editor) copy-self-to ed)
+              (let ([bt (make-hash-table)])
+                (hash-table-for-each bitmap-table (lambda (k v) (hash-table-put! bt (send k copy) v)))
+                (send cp set-bitmap-table bt)
+                (send cp set-show-picts show-picts?)
+                (send cp set-up-to-date up-to-date?)
+                cp)))
+          
+          
+          (define/override (get-menu)
+            (let ([menu (instantiate popup-menu% () (title #f))])
+              (cond
+                [show-picts?
+                 (make-object checkable-menu-item%
+                   sc-hide-picts
+                   menu
+                   (lambda (x y)
+                     (hide-picts)))]
+                [up-to-date?
+                 (make-object checkable-menu-item%
+                   sc-show-picts
+                   menu
+                   (lambda (x y)
+                     (show-picts)))]
+                [else
+                 (let ([m (make-object menu-item%
+                            sc-cannot-show-picts
+                            menu
+                            (lambda (x y) void))])
+                   (send m enable #f))])
+              menu))
+          
+          (define/public (update-bitmap-table sub-snips sub-bitmaps)
+            (let ([hidden-table (make-hash-table)])
+              (let loop ([snip (send (get-editor) find-first-snip)])
+                (cond
+                  [snip
+                   (when (is-a? snip image-snip/r%)
+                     (hash-table-put! hidden-table (send snip get-orig-snip) snip))
+                   (loop (send snip next))]
+                  [else (void)]))
+              (for-each (lambda (snip bitmap) 
+                          (hash-table-put! bitmap-table snip bitmap)
+                          (let ([showing (hash-table-get hidden-table snip (lambda () #f))])
+                            (when showing
+                              (send showing set-bitmap bitmap))))
+                        sub-snips
+                        sub-bitmaps)
+              (set! up-to-date? #t)))
+          
+          (define/private (show-picts)
+            (let ([pb (get-editor)])
+              (set! show-picts? #t)
+              (send pb begin-edit-sequence)
+              
+              (set! system-insertion? #t)
+              (hash-table-for-each 
+               bitmap-table
+               (lambda (snip bitmap)
+                 (let ([bm-snip (make-object image-snip/r% bitmap snip)])
+                   (let-values ([(x y) (snip-location pb snip)])
+                     (send snip release-from-owner)
+                     (send pb insert bm-snip x y)))))
+              (set! system-insertion? #f)
+              
+              (send pb end-edit-sequence)))
+          
+          (define/private (hide-picts)
+            (let ([pb (get-editor)])
+              (set! show-picts? #f)
+              
+              (send pb begin-edit-sequence)
+              
+              (let ([all-snips (let loop ([snip (send pb find-first-snip)])
+                                 (cond
+                                   [snip (cons snip (loop (send snip next)))]
+                                   [else null]))])
+                (set! system-insertion? #t)
+                (for-each (lambda (snip)
+                            (when (is-a? snip image-snip/r%)
+                              (let ([real-snip (send snip get-orig-snip)])
+                                (let-values ([(x y) (snip-location pb snip)])
+                                  (send snip release-from-owner)
+                                  (send pb insert real-snip x y)))))
+                          all-snips)
+                (set! system-insertion? #f))
+              
+              (send pb end-edit-sequence)))
+          
+          ;; called on user thread
+          (define/public (read-special file line col pos)
+            (let ([ans-chan (make-channel)])
+              (parameterize ([current-eventspace drs-eventspace])
+                (queue-callback
+                 (lambda ()
+                   (channel-put ans-chan (get-snp/poss this)))))
+              (let ([snp/poss (channel-get ans-chan)])
+                (build-lib-pict-stx 
+                 (lambda (ids)
+                   (with-syntax ([(ids ...) ids]
+                                 [this this]
+                                 [build-bitmap/check build-bitmap/check]
+                                 [drs-eventspace drs-eventspace]
+                                 [(subsnips ...) (map snp/pos-snp snp/poss)]
+                                 [(bitmap-ids ...) (generate-ids "drawer-id" (map snp/pos-snp snp/poss))])
+                     (syntax
+                      (let ([bitmap-ids (build-bitmap/check ids (pict-width ids) (pict-height ids) draw-pict pict?)] ...)
+                        (parameterize ([current-eventspace drs-eventspace])
+                          (queue-callback 
+                           (lambda () ;; drs eventspace
+                             (send this update-bitmap-table 
+                                   (list subsnips ...)
+                                   (list bitmap-ids ...)))))))))
+                 snp/poss))))
+          
+          (define/override (write stream-out)
+            (send stream-out put (if show-picts? 1 0))
+            (send stream-out put (if up-to-date? 1 0))
+            (send (get-editor) write-to-file stream-out))
+          (define/override (make-snip) (new pict-snip%))
+          
+          (define system-insertion? #f)
+          (define/public (inserted-snip)
+            (unless system-insertion?
+              (set! up-to-date? #f)
+              (when show-picts?
+                (hide-picts))))
+          
+          (inherit show-border set-snipclass)
+          (super-new)
+          (show-border #t)
+          (set-snipclass lib-pict-snipclass)))
+      
+      (define lib-pict-snipclass%
+        (class snip-class%
+          (define/override (read stream-in)
+            (let* ([snip (new pict-snip%)]
+                   [editor (send snip get-editor)]
+                   [show-picts? (not (zero? (send stream-in get-exact)))]
+                   [up-to-date? (not (zero? (send stream-in get-exact)))])
+              (send editor read-from-file stream-in #f)
+              (send snip set-up-to-date up-to-date?)
+              (send snip set-show-picts show-picts?)
+              (let ([bt (make-hash-table)])
+                (let loop ([snip (send editor find-first-snip)])
+                  (cond
+                    [(is-a? snip snip%)
+                     (when (is-a? snip image-snip/r%)
+                       (let ([orig (send snip get-orig-snip)]
+                             [bm (send snip get-bitmap)])
+                         (hash-table-put! bt orig bm)))
+                     (loop (send snip next))]
+                    [else (void)]))
+                (send snip set-bitmap-table bt))
+              snip))
+          (super-new)))
+      
+      ;; build-bitmap/check : pict number number (pict dc number number -> void) (any -> boolean) -> bitmap
+      ;; called on user-thread with a pict that the user made
+      (define (build-bitmap/check pict w h draw-pict pict?)
+        (unless (pict? pict) 
+          (error 'pict-snip "expected a pict to be the result of each embedded snip, got ~e"
+                 pict))
+        (let* ([bm (make-object bitmap% 
+                     (inexact->exact (ceiling w))
+                     (inexact->exact (ceiling h)))]
+               [bdc (make-object bitmap-dc% bm)])
+          (send bdc clear)
+          (draw-pict pict bdc 0 0)
+          (send bdc set-bitmap #f)
+          bm))
+      
+      (define (set-box/f b v) (when (box? b) (set-box! b v)))
+      
+      (define slideshow-bm
+        (let ([bm (make-object bitmap% (build-path (collection-path "slideshow") "slideshow.bmp"))])
+          (and (send bm ok?)
+               bm)))
+      
+      (define drs-eventspace (current-eventspace))
+      
+      (define (add-special-menu-item menu frame)
+        (let* ([find-insertion-point ;; -> (union #f editor<%>)
+                ;; returns the editor (if there is one) with the keyboard focus
+                (lambda ()
+                  (let ([editor (send frame get-edit-target-object)])
+                    (and editor
+                         (is-a? editor editor<%>)
+                         (let loop ([editor editor])
+                           (let ([focused (send editor get-focus-snip)])
+                             (if (and focused
+                                      (is-a? focused editor-snip%))
+                                 (loop (send focused get-editor))
+                                 editor))))))]
+               [insert-snip
+                (lambda (make-obj)
+                  (let ([editor (find-insertion-point)])
+                    (when editor
+                      (let ([snip (make-obj)])
+                        (send editor insert snip)
+                        (send editor set-caret-owner snip 'display)))))]
+               [demand-callback ;; : menu-item% -> void
+                ;; enables the menu item when there is an editor available.
+                (lambda (item)
+                  (send item enable (find-insertion-point)))])
+          (instantiate menu:can-restore-menu-item% ()
+            (label sc-insert-pict-box)
+            (parent menu)
+            (demand-callback demand-callback)
+            (callback 
+             (lambda (menu evt)
+               (insert-snip 
+                (lambda () (new pict-snip%))))))))
+      
+      
+      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;
+      ;;  drscheme extensions
+      ;;
+      
+      (define-struct p (pict-drawer width height n))
+      (define new-p
+        (let ([c 0])
+          (lambda (pd w h)
+            (set! c (+ c 1))
+            (make-p pd w h c))))
+      
+      (define show-picts<%>
+        (interface ()
+          slideshow:register-pict))
+      
+      (define show-picts-mixin
+        (mixin (color:text<%> editor<%>) (show-picts<%>)
+          (inherit get-canvas freeze-colorer)
+          
+          ;; all-picts-ht : hash-table[(cons text% number) -op> hash-table[pict -o> p]]
+          ;; the inner hashtables are really treated as sets, using the pict as
+          ;; the equality measure.
+          (define all-picts-ht (make-hash-table 'equal))
+          
+          (define frozen-colorers (make-hash-table))
+          
+          (define mouse-loc #f)
+          (define visible-picts #f)
+          
+          (define/public (slideshow:clear-picts)
+            (set! all-picts-ht (make-hash-table 'equal))
+            (hash-table-for-each
+             frozen-colorers
+             (lambda (k v)
+               (send k thaw-colorer)))
+            (set! frozen-colorers (make-hash-table)))
+          
+          (define/public (slideshow:register-pict text offset range pict pict-drawer width height)
+            (hash-table-get frozen-colorers
+                            text
+                            (lambda ()
+                              (when (is-a? text color:text<%>)
+                                (let ([locked? (send text is-locked?)])
+                                  (send text lock #f)
+                                  (send text freeze-colorer)
+                                  (send text lock locked?))
+                                (hash-table-put! frozen-colorers text #t))))
+            (let ([locked? (send text is-locked?)])
+              (send text lock #f)
+              (send text change-style has-info-style offset (+ offset 1) #f)
+              (send text lock locked?))
+            (let* ([key (cons text offset)]
+                   [picts-ht
+                    (hash-table-get all-picts-ht 
+                                    key
+                                    (lambda ()
+                                      (let ([new-ht (make-hash-table)])
+                                        (hash-table-put! all-picts-ht key new-ht)
+                                        new-ht)))])
+              ;; store the new pict in the hash-table, unless it is already in there,
+              ;; in which case we leave the current one (so we don't get a new number)
+              (hash-table-get
+               picts-ht
+               pict
+               (lambda ()
+                 (hash-table-put!
+                  picts-ht
+                  pict
+                  (new-p pict-drawer width height))))))
+          
+          (define/override (on-event evt)
+            (cond
+              [(send evt leaving?)
+               (update-mouse #f #f)
+               (super on-event evt)]
+              [(or (send evt moving?)
+                   (send evt entering?))
+               (let-values ([(pos text) (get-pos/text evt)])
+                 (update-mouse text pos))
+               (super on-event evt)]
+              [(send evt button-down? 'right)
+               (let-values ([(pos text) (get-pos/text evt)])
+                 (if (and pos text)
+                     (unless (show-menu evt text pos)
+                       (super on-event evt))
+                     (super on-event evt)))]
+              [else
+               (super on-event evt)]))
+          
+          ;; show-menu : ... -> boolean
+          ;; result indicates if a menu was shown
+          (define/private (show-menu evt text pos)
+            (let ([frame (let ([canvas (get-canvas)])
+                           (and canvas
+                                (send canvas get-top-level-window)))])
+              (and frame
+                   (let ([admin (send text get-admin)]
+                         [menu (new popup-menu%)]
+                         [show? #f])
+                     (let* ([frozen-mouse-picts-key (cons text pos)]
+                            [picts-ht (hash-table-get all-picts-ht frozen-mouse-picts-key (lambda () #f))])
+                       (when picts-ht
+                         (let ([picts (get-all-ps-from-ht picts-ht)])
+                           (set! show? #t)
+                           (new menu-item%
+                                (label sc-freeze-picts)
+                                (parent menu)
+                                (callback
+                                 (lambda (x y)
+                                   (send frame slideshow:set-permanent-picts picts)))))))
+                     (when (send frame slideshow:has-permanent-picts?)
+                       (new menu-item%
+                            (label sc-thaw-picts)
+                            (parent menu)
+                            (callback
+                             (lambda (x y)
+                               (send frame slideshow:set-permanent-picts #f))))
+                       (set! show? #t))
+                     (and show?
+                          (begin
+                            (send admin popup-menu 
+                                  menu
+                                  (send evt get-x)
+                                  (send evt get-y))
+                            #t))))))
+            
+          (define/private (update-mouse text pos)
+            (let ([new-mouse-loc (and text pos (cons text pos))])
+              (unless (equal? new-mouse-loc mouse-loc)
+                (set! mouse-loc new-mouse-loc)
+                (let ([frame (let ([canvas (get-canvas)])
+                               (and canvas
+                                    (send canvas get-top-level-window)))])
+                  (when frame
+                    (send frame slideshow:set-visible-picts
+                          (and pos 
+                               text 
+                               (let ([picts-ht
+                                      (hash-table-get all-picts-ht new-mouse-loc (lambda () #f))])
+                                 (and picts-ht
+                                      (get-all-ps-from-ht picts-ht))))))))))
+          
+          (define/private (get-all-ps-from-ht picts-ht)
+            (let ([ps (hash-table-map picts-ht (lambda (k v) v))])
+              (quicksort
+               ps
+               (lambda (x y) (<= (p-n x) (p-n y))))))
+              
+          ;; get-pos/text : event -> (values (union #f text%) (union number #f))
+          ;; returns two #fs to indicate the event doesn't correspond to
+          ;; a position in an editor, or returns the innermost text
+          ;; and position in that text where the event is.
+          (define/private (get-pos/text event)
+            (let ([event-x (send event get-x)]
+                  [event-y (send event get-y)]
+                  [on-it? (box #f)])
+              (let loop ([editor this])
+                (let-values ([(x y) (send editor dc-location-to-editor-location event-x event-y)])
+                  (cond
+                    [(is-a? editor text%)
+                     (let ([pos (send editor find-position x y #f on-it?)])
+                       (cond
+                         [(not (unbox on-it?)) (values #f #f)]
+                         [else
+                          (let ([snip (send editor find-snip pos 'after-or-none)])
+                            (if (and snip
+                                     (is-a? snip editor-snip%))
+                                (loop (send snip get-editor))
+                                (values pos editor)))]))]
+                    [(is-a? editor pasteboard%)
+                     (let ([snip (send editor find-snip x y)])
+                       (if (and snip
+                                (is-a? snip editor-snip%))
+                           (loop (send snip get-editor))
+                           (values #f #f)))]
+                    [else (values #f #f)])))))
+          
+          (super-new)))
+      
+      (define has-info-style (make-object style-delta%))
+      (send has-info-style set-delta-background "black")
+      (send has-info-style set-transparent-text-backing-off #t)
+      (send has-info-style set-delta-foreground "hotpink")
+      
+      (define tab-mixin
+        (mixin (drscheme:rep:context<%> drscheme:unit:tab<%>) ()
+          (inherit get-defs get-ints)
+          (define/augment (clear-annotations)
+            (send (get-defs) slideshow:clear-picts)
+            (send (get-ints) slideshow:clear-picts)
+            (inner (void) clear-annotations))
+          (super-new)))
+      
+      (define unit-frame-mixin
+        (mixin (drscheme:unit:frame<%>) ()
+          (inherit get-show-menu)
+          
+          (define slideshow-parent-panel #f)
+          (define everything-else-panel #f)
+          (define slideshow-panel #f)
+          (define slideshow-canvas #f)
+          (define slideshow-panel-visible? #f)
+          
+          (define permanent-picts #f)
+          (define visible-picts #f)
+          
+          (define/public (slideshow:set-visible-picts picts)
+            (unless (equal? picts visible-picts)
+              (set! visible-picts picts)
+              (when slideshow-panel-visible?
+                (draw-picts (send slideshow-canvas get-dc)))))
+          
+          (define/public (slideshow:set-permanent-picts picts)
+            (set! permanent-picts picts)
+            (if picts
+                (send slideshow-canvas 
+                      init-auto-scrollbars
+                      (inexact->exact (floor (apply max (map p-width picts))))
+                      (inexact->exact (floor (apply + (map p-height picts))))
+                      0
+                      0)
+                (send slideshow-canvas init-auto-scrollbars #f #f 0 0)))
+          (define/public (slideshow:has-permanent-picts?) permanent-picts)
+          
+          (define/override (make-root-area-container cls parent)
+            (set! slideshow-parent-panel (super make-root-area-container slideshow-dragable% parent))
+            (let ([root (make-object cls slideshow-parent-panel)])
+              (set! everything-else-panel root)
+              root))
+          
+          (define/override (update-shown)
+            (super update-shown)
+            (if slideshow-panel-visible?
+                (begin
+                  (unless slideshow-panel (build-slideshow-panel))
+                  (when (is-a? view-menu-item menu-item%)
+                    (send view-menu-item set-label sc-hide-slideshow-panel))
+                  (send slideshow-parent-panel
+                        change-children
+                        (lambda (l)
+                          (list everything-else-panel slideshow-panel))))
+                (begin
+                  (when (is-a? view-menu-item menu-item%)
+                    (send view-menu-item set-label sc-show-slideshow-panel))
+                  (send slideshow-parent-panel
+                        change-children
+                        (lambda (l)
+                          (list everything-else-panel))))))
+          
+          (define/private (build-slideshow-panel)
+            (let ([p (preferences:get 'plt:slideshow:panel-percentage)])
+              ;; must save the value of the pref before creating slideshow-panel
+              ;; so that the callback doesn't clobber it
+              
+              (set! slideshow-panel (new vertical-panel% (parent slideshow-parent-panel)))
+              (set! slideshow-canvas (new canvas%
+                                          (style '(hscroll vscroll))
+                                          (parent slideshow-panel)
+                                          (paint-callback
+                                           (lambda (x dc)
+                                             (draw-picts dc)))))
+              (send slideshow-parent-panel set-percentages (list p (- 1 p)))
+              (preferences:set 'plt:slideshow:panel-percentage p)))
+
+          (define/private (draw-picts dc)
+            (send dc clear)
+            (let ([picts (or permanent-picts visible-picts)])
+              (when picts
+                (let loop ([picts picts]
+                           [y 0])
+                  (cond
+                    [(null? picts) (void)]
+                    [else (let ([pict (car picts)])
+                            ((p-pict-drawer pict) dc 0 y)
+                            (loop (cdr picts)
+                                  (+ y (p-height pict))))])))))
+          
+          (define/override (add-show-menu-items show-menu)
+            (super add-show-menu-items show-menu)
+            (set! view-menu-item
+                  (new menu-item%
+                       (label sc-show-slideshow-panel)
+                       (parent (get-show-menu))
+                       (callback
+                        (lambda (x y)
+                          (set! slideshow-panel-visible? (not slideshow-panel-visible?))
+                          (update-shown))))))
+          
+          (define view-menu-item #f)
+          
+          (super-new)
+          
+          (inherit get-special-menu)
+          (add-special-menu-item (get-special-menu) this)))
+      
+      (define slideshow-dragable%
+        (class panel:horizontal-dragable%
+          (inherit get-percentages)
+          (define/augment (after-percentage-change)
+            (let ([percentages (get-percentages)])
+              (when (= 2 (length percentages))
+                (preferences:set 'plt:slideshow:panel-percentage (car percentages))))
+            (inner (void) after-percentage-change))
+          (super-new)))
+
+      (define has-info-bkg-color (make-object color% "gray"))
+      
+      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;
+      ;; preference defaults
+      ;;
+      
+      ;; size of the drscheme window.
+      (preferences:set-default 'plt:slideshow:panel-percentage 3/4 (lambda (x) (and (number? x) (<= 0 x 1))))
+
+      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;
+      ;;  communication from user thread to drscheme's repl
+      ;;
+            
+      (define system-eventspace (current-eventspace))
+      
+      ;; send-over : any syntax -> void
+      ;; thread: (any) user's thread
+      (define (send-over v stx)
+        (let ([rep (drscheme:rep:current-rep)])
+          (when rep
+            (let ([pict? (dynamic-require '(lib "mrpict.ss" "texpict") 'pict?)])
+              (when (pict? v)
+                (let* ([make-pict-drawer (dynamic-require '(lib "mrpict.ss" "texpict") 'make-pict-drawer)]
+                       [width ((dynamic-require '(lib "mrpict.ss" "texpict") 'pict-width) v)]
+                       [height ((dynamic-require '(lib "mrpict.ss" "texpict") 'pict-height) v)]
+                       [pict-drawer (make-pict-drawer v)])
+                  (parameterize ([current-eventspace system-eventspace])
+                    (queue-callback
+                     (lambda ()
+                       (add-pict-drawer stx v pict-drawer width height))))))))))
+      
+      ;; add-pict-drawer : syntax pict-drawer number number -> void
+      ;; thread: system eventspace
+      (define (add-pict-drawer stx pict pict-drawer width height)
+        (let ([src (syntax-source stx)]
+              [offset (syntax-position stx)]
+              [span (syntax-span stx)])
+          (when (and (is-a? src editor<%>)
+                     (number? offset)
+                     (number? span))
+            (let ([top-most (let loop ([src src])
+                              (let ([admin (send src get-admin)])
+                                (cond
+                                  [(not admin) #f]
+                                  [(is-a? admin editor-snip-editor-admin<%>)
+                                   (let* ([outer-editor-snip (send admin get-snip)]
+                                          [es-admin (send outer-editor-snip get-admin)]
+                                          [outer-editor (send es-admin get-editor)])
+                                     (loop outer-editor))]
+                                  [else src])))])
+              (when (is-a? top-most show-picts<%>)
+                (send top-most slideshow:register-pict src (- offset 1) span pict pict-drawer width height))))))
+      
+      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;
+      ;; slideshow lang
+      ;;
+      
+      (define slideshow-mixin
+        (mixin (drscheme:language:language<%>) ()
+          (define/override (front-end/complete-program input settings teachpack-cache)
+            (let ([st (super front-end/complete-program input settings teachpack-cache)])
+              (lambda ()
+                (let ([sv (st)])
+                  (cond
+                    [(syntax? sv) (rewrite-syntax sv)]
+                    [else sv])))))
+          (define/override (front-end/interaction input settings teachpack-cache)
+            (let ([st (super front-end/interaction input settings teachpack-cache)])
+              (lambda ()
+                (let ([sv (st)])
+                  (cond
+                    [(syntax? sv) (rewrite-syntax sv)]
+                    [else sv])))))
+          (define/override (get-language-name) "Slideshow")
+          (super-new (module '(lib "plt-mred.ss" "lang"))
+                     (language-position (list (string-constant experimental-languages)
+                                              "Slideshow"))
+                     (language-numbers (list 1000 341)))))
+      
+      (define (rewrite-syntax stx)
+        (rewrite-top-level (expand stx)))
+      
+      (define (rewrite-top-level stx)
+        (syntax-case stx (module begin)
+          [(module identifier name (#%plain-module-begin module-level-expr ...))
+           (with-syntax ([(rewritten-module-level-expr ...) (map rewrite-module-level
+                                                                 (syntax->list
+                                                                  (syntax (module-level-expr ...))))])
+             (syntax/cert stx (module identifier name (#%plain-module-begin rewritten-module-level-expr ...))))]
+          [(begin top-level-expr ...)
+           (with-syntax ([(rewritten-top-level-expr ...) 
+                          (map rewrite-top-level (syntax->list (syntax (top-level-expr ...))))])
+             (syntax/cert stx (begin rewritten-top-level-expr ...)))]
+          [general-top-level-expr (rewrite-general-top-level stx)]))
+
+      (define (rewrite-module-level stx)
+        (syntax-case stx (provide begin)
+          [(provide provide-spec ...) stx]
+          [(begin module-level-expr ...)
+           (with-syntax ([(rewritten-module-level-expr ...)
+                          (map rewrite-module-level 
+                               (syntax->list (syntax (module-level-expr  ...))))])
+             (syntax/cert stx (begin rewritten-module-level-expr ...)))]
+          [general-top-level-expr (rewrite-general-top-level stx)]))
+      
+      (define (rewrite-general-top-level stx)
+        (syntax-case stx (define-values define-syntaxes define-values-for-syntax 
+			   require require-for-syntax require-for-template)
+          [(define-values (variable ...) expr)
+           (with-syntax ([rewritten-expr (add-send-over (rewrite-expr (syntax expr)) 
+                                                        (syntax expr) 
+                                                        (length (syntax->list (syntax (variable ...)))))])
+             (syntax/cert stx (define-values (variable ...) rewritten-expr)))]
+          [(define-syntaxes (variable ...) expr) stx]
+          [(define-values-for-syntax (variable ...) expr) stx]
+          [(require require-spec ...) stx]
+          [(require-for-syntax require-spec ...) stx]
+          [(require-for-template require-spec ...) stx]
+          [expr (rewrite-expr stx)]))
+      
+      (define (rewrite-expr stx)
+        (syntax-case stx (lambda case-lambda if begin begin0 let-values letrec-values set! quote quote-syntax 
+				 with-continuation-mark #%app #%datum #%top)
+          [variable
+           (identifier? (syntax variable))
+           (add-send-over/var (syntax variable) stx)]
+          [(lambda formals expr ...)
+           (with-syntax ([(rewritten-expr ...) 
+                          (map rewrite-expr (syntax->list (syntax (expr ...))))])
+	     (syntax/cert stx (lambda formals rewritten-expr ...)))]
+          [(case-lambda (formals expr ...) ...)
+           (with-syntax ([((rewritten-expr ...) ...)
+                          (map (lambda (exprs) (map rewrite-expr (syntax->list exprs)))
+                               (syntax->list (syntax ((expr ...) ...))))])
+             (syntax/cert stx (case-lambda (formals rewritten-expr ...) ...)))]
+          [(if expr1 expr2)
+           (with-syntax ([rewritten-expr1 (add-send-over (rewrite-expr (syntax expr1)) (syntax expr1) 1)]
+                         [rewritten-expr2 (rewrite-expr (syntax expr2))])
+             (syntax/cert stx (if rewritten-expr1 rewritten-expr2)))]
+          [(if expr1 expr2 expr3)
+           (with-syntax ([rewritten-expr1 (add-send-over (rewrite-expr (syntax expr1)) (syntax expr1) 1)]
+                         [rewritten-expr2 (rewrite-expr (syntax expr2))]
+                         [rewritten-expr3 (rewrite-expr (syntax expr3))])
+             (syntax/cert stx (if rewritten-expr1 rewritten-expr2 rewritten-expr3)))]
+          [(begin expr ... last-expr)
+           (with-syntax ([(rewritten-expr ...) (map (lambda (x) (add-send-over (rewrite-expr x) x 1))
+                                                    (syntax->list (syntax (expr ...))))]
+                         [rewritten-last-expr (rewrite-expr (syntax last-expr))])
+             (syntax/cert stx (begin rewritten-expr ... rewritten-last-expr)))]
+          [(begin0 expr ...)
+           (with-syntax ([(rewritten-expr ...) (map (lambda (x) (add-send-over (rewrite-expr x) x 1)) 
+                                                    (syntax->list (syntax (expr ...))))])
+             (syntax/cert stx (begin0 rewritten-expr ...)))]
+          [(let-values (((variable ...) v-expr) ...) expr ...)
+           (with-syntax ([(rewritten-expr ...) (map rewrite-expr (syntax->list (syntax (expr ...))))]
+                         [(rewritten-v-expr ...) (map rewrite-expr (syntax->list (syntax (v-expr ...))))]
+                         [((send-over-vars ...) ...)
+                          (map (lambda (vars)
+                                 (map (lambda (var) (add-send-over/var var var))
+                                      (syntax->list vars)))
+                               (syntax->list (syntax ((variable ...) ...))))])
+             (syntax/cert stx
+			  (let-values (((variable ...) rewritten-v-expr) ...)
+			    (begin (void) (begin (void) send-over-vars ...) ...)
+			    rewritten-expr ...)))]
+          [(letrec-values (((variable ...) v-expr) ...) expr ...)
+           (with-syntax ([(rewritten-expr ...) (map rewrite-expr (syntax->list (syntax (expr ...))))]
+                         [(rewritten-v-expr ...) (map rewrite-expr (syntax->list (syntax (v-expr ...))))]
+                         [((send-over-vars ...) ...)
+                          (map (lambda (vars)
+                                 (map (lambda (var) (add-send-over/var var var))
+                                      (syntax->list vars)))
+                               (syntax->list (syntax ((variable ...) ...))))])
+             (syntax/cert stx
+			  (letrec-values (((variable ...) rewritten-v-expr) ...)
+			    (begin (void) (begin (void) send-over-vars ...) ...)
+			    rewritten-expr ...)))]
+          [(set! variable expr)
+           (with-syntax ([rewritten-expr (add-send-over (rewrite-expr (syntax expr)) (syntax expr) 1)])
+             (syntax/cert stx (set! variable rewritten-expr)))]
+          [(quote datum) stx]
+          [(quote-syntax datum) stx]
+          [(with-continuation-mark expr1 expr2 expr3)
+           (with-syntax ([rewritten-expr1 (add-send-over (rewrite-expr (syntax expr1)) (syntax expr1) 1)]
+                         [rewritten-expr2 (add-send-over (rewrite-expr (syntax expr2)) (syntax expr2) 1)]
+                         [rewritten-expr3 (rewrite-expr (syntax expr3))])
+             (syntax/cert stx (with-continuation-mark rewritten-expr1 rewritten-expr2 rewritten-expr3)))]
+          [(#%app expr ...)
+           (with-syntax ([(rewritten-expr ...) (map (lambda (x) (add-send-over (rewrite-expr x) x 1)) 
+                                                    (syntax->list (syntax (expr ...))))])
+             (syntax/cert stx (#%app rewritten-expr ...)))]
+          [(#%datum . datum) stx]
+          [(#%top . variable) stx]))
+      
+      (define (add-send-over stx loc-stx values-expected)
+        (if (object? (syntax-source loc-stx))
+            (with-syntax ([send-over send-over]
+                          [stx stx]
+                          [loc (datum->syntax-object loc-stx 1 loc-stx)]
+                          [(vars ...) (build-vars values-expected)])
+              (syntax
+               (let-values ([(vars ...) stx])
+                 (send-over vars #'loc) ...
+                 (values vars ...))))
+            stx))
+      (define (add-send-over/var stx loc-stx)
+        (if (object? (syntax-source loc-stx))
+            (with-syntax ([send-over send-over]
+                          [stx stx]
+                          [loc (datum->syntax-object loc-stx 1 loc-stx)])
+              (syntax
+               (begin 
+                 (send-over stx #'loc)
+                 stx)))
+            stx))
+      (define (build-vars n)
+        (cond
+          [(zero? n) #'()]
+          [else (cons (datum->syntax-object #'here (string->symbol (format "x~a" n)))
+                      (build-vars (- n 1)))]))
+
+      
+      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;
+      ;;  wire it up
+      ;;
+      
+      (drscheme:get/extend:extend-interactions-text show-picts-mixin)
+      (drscheme:get/extend:extend-definitions-text show-picts-mixin)
+      (drscheme:get/extend:extend-unit-frame unit-frame-mixin)
+      (drscheme:get/extend:extend-tab tab-mixin)
+      
+      (define (phase1) (void))
+      (define (phase2)
+        (define slideshow-language%
+          (slideshow-mixin
+           ((drscheme:language:get-default-mixin)
+            (drscheme:language:module-based-language->language-mixin
+             (drscheme:language:simple-module-based-language->module-based-language-mixin
+              drscheme:language:simple-module-based-language%)))))
+        
+        (drscheme:language-configuration:add-language
+         (new slideshow-language%)))
+      
+      
+      (drscheme:language:add-snip-value
+       (lambda (x) ((dynamic-require '(lib "mrpict.ss" "texpict") 'pict?) x))
+       (lambda (pict) (new (dynamic-require '(lib "pict-value-snip.ss" "texpict") 'pict-value-snip%) (pict pict))))
+
+        
+      (define lib-pict-snipclass (make-object lib-pict-snipclass%))
+      (send lib-pict-snipclass set-version 2)
+      (send lib-pict-snipclass set-classname (format "~s" '(lib "pict-snipclass.ss" "slideshow")))
+      (send (get-the-snip-class-list) add lib-pict-snipclass)
+
+      )))
+
diff --git a/collects/slideshow/tutorial-show.ss b/collects/slideshow/tutorial-show.ss
new file mode 100644
index 0000000000..cce9916cf4
--- /dev/null
+++ b/collects/slideshow/tutorial-show.ss
@@ -0,0 +1,895 @@
+;; This example slideshow code is meant to be read while
+;;  running the example show.
+
+(module tutorial-show (lib "slideshow.ss" "slideshow")
+  
+  ;; The first few slides are not to be read
+  ;; until you have seen the rest of the tutorial,
+  ;; so we put them in a separate file
+  (require "initial-ones.ss")
+  (do-initial-slides)
+
+  ;; The rest is meant for reading, as you view the slides
+
+  ;; The first slide that's meant to be read
+  (slide
+   (t "Part I: Basic Concepts"))
+
+  ;; The second slide
+  (slide
+   (t "This slide shows how four picts")
+   (t "get vertically appended by the")
+   (tt "slide")
+   (t "function to create and install a slide"))
+  
+  ;; Etc.
+  (slide
+   (t "See how the")
+   (tt "t")
+   (t "function takes a string and")
+   (t "produces a pict with a normal sans-serif font, but")
+   (tt "tt")
+   (t "produces a pict with a fixed-width font?"))
+  
+  (slide
+   (page-para "Breaking up text into lines is painful, so"
+              "the" (tt "page-para")
+              "function takes a mixture of strings and"
+              "picts and puts them into a pagaraph")
+   (page-para "It doesn't matter how strings are broken into"
+              "parts in the code")
+   (page-para "The" (tt "page-para") "function puts space"
+              "between separate strings"
+              ", but not before punctuation" "!"))
+  
+  (slide/center
+   (page-para "The" (tt "slide/center") "function centers"
+              "the slide body vertically")
+   (page-para "All of the" (tt "slide") "functions center"
+              "the body picts horizontally, but" (tt "page-para")
+              "makes a slide-width picture with left-aligned text")
+   (frame (page-para "The" (tt "frame") "function wraps a frame"
+                     "around a pict to create a new pict,"
+                     "so you can easily see this individual pict")))
+  
+  (slide/title
+   "Titles"
+   (page-para "The" (tt "slide/title") "function takes a"
+              "title string before the content picts"))
+  
+  (slide/title/center
+   "Titles and Centering"
+   (page-para "The" (tt "slide/title/center") "function centers the slide body vertically"))
+  
+  (slide/title/center
+   "More Centering"
+   (frame
+    (page-para/c "The" (tt "page-para/c") "function generates"
+                 "a paragraph with centered lines of text"))
+   (frame
+    (page-para* "This line uses the" (tt "page-para*") "function"))
+   (page-para "The" (tt "page-para*") "function creates a paragraph"
+              "that is wrapped to fit the slide, but it allows"
+              "the resulting pict to be more narrow than the slide"))
+
+  (let ([apply-page-para-to-example
+	 (lambda (page-para...)
+	   (page-para...
+	    "And there's" (tt "page-para*/r") ", which is different"
+	    "from" (tt "page-para*") "or" (tt "page-para*/c")
+	    "only if the paragraph takes multiple lines"))])
+    (slide/title
+     "More Alignment"
+     (frame
+      (page-para/r "Of course, there's also" (tt "page-para/r")))
+     (frame (apply-page-para-to-example page-para*/r))
+     (page-para "For comparision, the same text using" (tt "page-para/r") ":")
+     (frame (apply-page-para-to-example page-para/r))
+     (page-para "Unless your font happens to make the" (tt "page-para*/r")
+		"box exactly as wide as this slide, the last box will be slightly"
+		"wider with extra space to the left")))
+  
+  (slide/title
+   "Spacing"
+   (page-para "The" (tt "slide") "functions insert space"
+              "between each body pict")
+   (page-para "The amount of space is" (number->string gap-size)
+              ", which is the value of" (tt "gap-size")))
+  
+  (slide/title
+   "Controlling Space"
+   (vc-append line-sep
+              (page-para "If you want to control the space,"
+                         "simply append the picts yourself to create"
+                         "one body pict")
+              (page-para "The first argument to" (tt "vc-append")
+                         "determines the space between pictures")
+              (page-para "If the first argument is a pict instead of"
+                         "a number, then 0 is used")
+              (page-para "For text in one paragraph, the"
+                         (tt "page-para") "function uses" (tt "line-sep")
+                         ", which is" (number->string line-sep))))
+
+  (slide/title/center
+   "Appending Picts"
+   (vl-append line-sep (frame (t "This is")) (frame (tt "vl-append")))
+   (vc-append line-sep (frame (t "This is")) (frame (tt "vc-append")))
+   (vr-append line-sep (frame (t "This is")) (frame (tt "vr-append"))))
+  
+  (slide/title/center
+   "Horizontal Appending"
+   (hc-append (frame (t "This is")) (frame (vr-append (tt "hc-append")
+                                                      (t "obviously"))))
+   (ht-append (frame (t "This is")) (frame (vr-append (tt "ht-append")
+                                                      (t "obviously"))))
+   (hb-append (frame (t "This is")) (frame (vr-append (tt "hb-append")
+                                                      (t "obviously")))))
+  
+  (slide/title/center
+   "Text Alignment"
+   (hbl-append (frame (scale (tt "hbl-append") 1.5))
+               (frame (t "aligns text baselines")))
+   (page-para "It's especially useful for font mixtures")
+   (hbl-append (frame (scale (tt "htl-append") 1.5))
+               (frame (t "is the same for single lines")))
+   (page-para "The difference between" (tt "htl-append")
+              "and" (tt "hbl-append") "shows up with multiple lines:")
+   (hbl-append (frame (scale (t "bottom lines align") 1.5))
+               (frame (vl-append (t "when using") (tt "hbl-append"))))
+   (htl-append (frame (scale (t "top lines align") 1.5))
+               (frame (vl-append (t "when using") (tt "htl-append")))))
+  
+  (slide/title
+   "Superimposing"
+   (cc-superimpose (t "X") (t "O"))
+   (page-para "The" (tt "cc-superimpose") 
+              "function puts picts on top of each other, centered")
+   (page-para "Each of" (tt "l") "," (tt "r") ", and" (tt "c")
+              "is matched with each of"
+              (tt "t") "," (tt "b") "," (tt "c") "," (tt "bl") ", and" (tt "tl")
+              "in all combinations with" (tt "-superimpose"))
+   (page-para "For example," (tt "cbl-superimpose") ":")
+   (cbl-superimpose (frame (scale (t "one line") 1.5))
+                    (frame
+                     (colorize (vl-append (t "two")
+                                          (t "lines"))
+                               "blue"))))
+  
+  (slide
+   (cc-superimpose 
+    (frame (blank client-w client-h))
+    (vc-append gap-size
+               (t "By definition, the screen is 1024 x 768 units")
+               (t "If you have more or less pixels, the image is scaled")
+               (page-para*
+                "There's a margin, so the \"client\" area is"
+                (number->string client-w) "x" (number->string client-h))
+               (page-para* "The font size is" (number->string font-size)))))
+  
+  (slide/title
+   "Titled Client Area"
+   (rb-superimpose
+    (cc-superimpose
+     (frame titleless-page)
+     (page-para* "If you use a title, then" (tt "titleless-page")
+                 "is the same size as the area left for the body"))
+    (t "It's useful")))
+   
+  (slide/title
+   "More on Paragraphs"
+   (page-para "The" (tt "page-") "in" (tt "page-para")
+              "makes the paragraph take the width of the slide")
+   (para 300 
+         "The" (tt "para") "function requires an explicit size"
+         "for the width of the paragraph, 300 in this case")
+   (para client-w "So" (tt "page-para") "is a shorthand for"
+         (tt "para") "with" (tt "client-w"))
+   (para*/c 500 "Naturally, there is" (tt "para*") ","
+            (tt "para*/c") ", and" (tt "para*/r")))
+  
+  (slide/title/center
+   "Text and Styles"
+   (page-para "Functions exist for" (bt "bold") ","
+              (it "italic") ", and even" (bit "bold-italic") "text")
+   (page-para "The" (tt "text") "function gives you more direct control over the"
+              (text "font" '(italic . modern) font-size) ","
+              (text "size" main-font 24) ", and even"
+              (text "angle" main-font font-size (/ 3.14159 4))))
+  
+  (require (lib "code.ss" "slideshow"))
+  (slide/title/center
+   "Scheme Code"
+   (page-para "For Scheme code, the" (code (lib "code.ss" "slideshow"))
+              "library provides a handy" (code code) "macro for"
+              "typesetting literal code")
+   (page-para "The" (code code) "macro uses source-location information"
+              "to indent code")
+   (code (define (length l)
+           (cond
+             [(null? l) 0]
+             [else (+ 1 (length (cdr l)))]))))
+
+  (slide/title/center
+   "Colors"
+   (page-para "Use the" (colorize (tt "colorize") "blue")
+              "function to color most things, including text")
+   (frame
+    (colorize (page-para "A" (code colorize)
+                         "applies only to sub-picts that do not"
+                         "already have a" (colorize (t "color") "green"))
+              "red")))
+  
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; Part II starts here
+
+  (define outline 
+    (let ([sub-para (lambda l
+		      (apply para (* 3/4 client-w) l))])
+      (make-outline
+       'one "Part I: Basic Concepts" 
+       #f
+       
+       'two "Part II: Practical Slides" 
+       (lambda (tag)
+	 (sub-para "Using" (code make-outline) "and more..."))
+       
+       'three "Part III: Fancy Picts" 
+       (lambda (tag)
+	 (sub-para "Creating interesting graphics"))
+     
+       'four "Part IV: Advanced Slides" 
+       (lambda (tag)
+	 (sub-para "Beyond" (code 'next) "and" (code 'alts)))
+     
+       'background "Part V: Controlling the Background"
+       (lambda (tag)
+	 (sub-para "Changing the overall look of your talk"))
+
+       'printing "Part VI: Printing"
+       (lambda (tag)
+	 (sub-para "Exporting slides as PostScript"))
+
+       'end "Conclusion" 
+       (lambda (tag)
+	 (sub-para "This is the end")))))
+
+  
+  (outline 'two)
+  
+  (slide/title/center
+   "Itemize"
+   (page-item "Bulleted sequences are common in slides")
+   (page-item "The" (code page-item) "function makes a bulleted"
+              "paragraph that is as wide as the slide")
+   (page-item/bullet (colorize (tt "+") "green")
+                     "You can set the bullet, if you like, by using"
+                     (code page-item/bullet))
+   (page-subitem "Naturally, there is also" (code page-subitem)))
+  
+  (slide/title/center
+   "Itemize"
+   (page-para "You could write" (code page-item) "yourself:")
+   (code (define (page-item . l)
+           (htl-append
+            (/ gap-size 2)
+            bullet
+            (apply para 
+                   (- client-w (pict-width bullet) 
+                      (/ gap-size 2))
+                   l))))
+   (page-para "where" (code bullet) "is a constant pict:" bullet))
+  
+  (slide/title/center
+   "Grouping and Space"
+   (page-para "Sometimes you want to group items on a slide")
+   (page-item "A bullet goes with a statement")
+   (page-item "And another does, too")
+   (blank)
+   (page-para "Creating a zero-sized pict with" (code (blank))
+              "effectively doubles the gap, making a space that"
+	      "often looks right"))
+  
+  (slide/title/center
+   "Steps"
+   (page-item "Suppose you want to show only one item at a time")
+   'next
+   (page-item "In addition to body picts, the" (code slide) 
+	      "functions recognize certain staging symbols")
+   (page-item "Use" (code 'next) "in a sequence of" (code slide)
+              "arguments to create multiple slides, one"
+              "containing only the preceding content, and another"
+              "with the remainder")
+   'next
+   (blank)
+   (colorize
+    (page-para* (code 'next) "is not tied to" (code page-item)
+                ", though it's often used with items")
+    "blue"))
+    
+  
+  (slide/title/center
+   "Alternatives"
+   (page-para "Steps can break up a linear slide, but sometimes"
+              "you need to replace one thing with something else")
+   'alts 
+   (list (list 
+          (page-para* "For example, replace this..."))
+         (list
+          (page-para* "... with something else")
+          'next
+          (blank)
+          (page-item "An" (code 'alts) "in a sequence"
+                     "must be followed by a list of lists")
+          (page-item "Each list is a sequence, a different conclusion for the slide's sequence")))
+   (page-item "Anything after the list of lists is folded into the last alternative")
+   'next
+   (blank)
+   (page-para "Of course, you can mix" (code 'alts) "and"
+              (code 'next) "in interesting ways"))
+  
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; Part III starts here
+  (outline 'three)
+
+  (slide/title
+   "Fancy Picts"
+   (page-para "In part I, we saw some basic pict constructors:" 
+	      (code t) "," (code vl-append) ", etc.")
+   (blank)
+   (page-para "The libraries")
+   (vr-append
+    line-sep
+    (code (lib "mrpict.ss" "texpict"))
+    (page-para* "and" (code (lib "utils.ss" "texpict"))))
+   (page-para "provide many more functions for creating picts")
+   (blank)
+   (page-para "Slideshow re-exports all of those functions, so you"
+	      "can just use them"))
+
+  (slide/title
+   "Bitmaps"
+   (page-para "For example, the" (code bitmap) "function loads a bitmap to display")
+   (blank)
+   (bitmap (build-path (collection-path "icons") "plt.gif")))
+
+  (require (lib "symbol.ss" "texpict"))
+  (slide/title/center
+   "Symbols"
+   (page-para "The" (code (lib "symbol.ss" "texpict")) "library"
+	      "provides various symbol constants, such as")
+   (page-para* sym:in (code sym:in))
+   (page-para* sym:rightarrow (code sym:rightarrow))
+   (page-para* sym:infinity (code sym:infinity))
+   (blank)
+   (page-para "Slideshow does not re-export this library, so you"
+	      "must" (code require) "it to use"
+	      (code sym:in) ", etc.")
+   (page-para "Unless otherwise stated in the following slides, however,"
+	      "all definitions are provided by Slideshow"))
+
+  (require (lib "mred.ss" "mred")) ; for message-box
+  (slide/title
+   "Clickbacks"
+   (page-para "The" (code clickback)
+	      "function attaches an arbitrary thunk to a pict"
+	      "for interactive slides")
+   (blank)
+   (clickback (frame (t "Click Me"))
+	      (lambda ()
+		(message-box "Clicked" "Thanks!"))))
+
+  (define (note . l)
+    (colorize (apply page-para/r l) "blue"))
+
+  (slide/title
+   "Tables"
+   (page-para "The" (code table) "function makes rows and columns")
+   (frame
+    (inset
+     (table 3 ; three columns
+	    (list (t "First") (standard-fish (* 2 gap-size) gap-size) (code cons)
+		  (t "Second") (jack-o-lantern (* 4 gap-size)) (code car)
+		  (t "Third") (cloud (* 3 gap-size) gap-size) (code cdr)
+		  (t "Fourth") (file-icon (* 2 gap-size) (* 3 gap-size) #t) (code null?))
+	    (list* lc-superimpose  ; left-align first column
+		   cc-superimpose) ; h-center the rest
+	    cc-superimpose ; v-center all rows
+	    gap-size  ; separate all columns by gap-size
+	    gap-size) ; separate all rows by gap-size
+     gap-size))
+   (note "The above also uses" (code standard-fish) ","
+	 (code jack-o-lantern) "," (code cloud) ", and"
+	 (code file-icon)))
+  
+  (require (lib "math.ss")) ; to get pi
+  (define orientations 
+    (map (lambda (x) (* pi x)) '(0 1/4 1/2 3/4 1 5/4 6/4 7/4)))
+  (define (show-arrows code-arrow t-arrow arrow)
+    (slide/title
+     "Arrows"
+     (page-para "The" code-arrow "function creates an"
+		t-arrow "of a given size and orientation (in radians)")
+     (blank)
+     (page-para "Simple: " (arrow gap-size pi))
+     (blank)
+     (page-para "Fun:")
+     (apply
+      vc-append
+      line-sep
+      (map (lambda (shift)
+	     (colorize
+	      (apply hc-append gap-size (map (lambda (o) 
+					       ;; Here's the other use of arrow
+					       (arrow gap-size (+ o (* shift pi 1/32))))
+					     orientations))
+	      (scale-color (add1 shift) "green")))
+	   '(0 1 2 3 4 5 6 7)))
+     (blank)
+     (note "(That's 64 uses of " code-arrow ")")))
+  (show-arrows (code arrow) (t "arrow") arrow)
+  (show-arrows (code arrowhead) (t "arrowhead") arrowhead)
+
+  (require (lib "face.ss" "texpict"))
+  (slide/title
+   "Faces"
+   (page-para "The" (code (lib "face.ss" "texpict"))
+	      "library makes faces")
+   (blank)
+   (hc-append
+    (* 3 gap-size)
+    (face 'happy "yellow")
+    (face 'badly-embarassed)))
+    
+
+  (require (lib "class.ss")) ; to demonstrate dc
+  (slide/title 
+   "Arbitrary Drawing"
+   (page-para "The" (code dc) "function provides an escape hatch to the underlying"
+              "MrEd toolkit")
+   (page-para "For example," (code (disk 100)) "is the same as")
+   (code
+    (dc (lambda (dc dx dy)
+          (send dc draw-ellipse dx dy 100 100))
+        100 100 0 0))
+   (dc (lambda (dc dx dy)
+         (send dc draw-ellipse dx dy 100 100))
+       100 100 0 0)
+   (disk 100))
+
+  (slide/title
+   "Frames"
+   (page-item "As we've already seen, the" (code frame)
+	      "function wraps a" (frame (t "frame"))
+	      "around a pict")
+   (page-item "The" (code color-frame)
+	      "function wraps a" (color-frame (t "colored frame") "red")
+	      "; compare to" (code frame) "followed by" (code colorize)
+	      "," (colorize (frame (t "like this")) "red"))
+   (blank)
+   (page-item "One way to increase the" (linewidth 3 (frame (t "line thickness")))
+	      "is to use" (code linewidth))
+   (blank)
+   (page-item "It's often useful to" (frame (inset (t "add space") 3))
+	      "around a pict with" (code inset) "before framing it"))
+
+  (define (bound-frame p)
+    (color-frame p "green"))
+
+  (slide/title
+   "Lines and Pict Dimensions"
+   (page-item "The" (code hline) "function creates a horizontal line, given a bounding width and height:")
+   (bound-frame (hline (* 2 gap-size) gap-size))
+   (note "(The" (code hline) "result is framed in green above)")
+   (page-item "Naturally, there's also" (code vline) ":")
+   (bound-frame (vline (* 2 gap-size) gap-size))
+   (blank)
+   (page-item "To" (let ([p (t "underline")])
+		     (vc-append p (hline (pict-width p) 1)))
+	      "a pict, get its width using" (code pict-width)
+	      ", then use" (code hline) "and" (code vc-append))
+   (page-item "If the pict is text, you can restore the"
+	      (let ([p (t "baseline")])
+		(refocus 
+		 (vc-append p (hline (pict-width p) 1))
+		 p))
+	      "using" (code refocus)))
+
+  (slide/title
+   "Placing Picts"
+   (page-item "Another" (let ([p (t "underline strategy")])
+			  (pin-over p 0 (pict-height p) (hline (pict-width p) 1)))
+	      "is to use" (code pin-over) ", which places one pict on"
+	      "top of another to generate a new pict")
+   (page-item "The new pict has the"
+	      (bound-frame
+	       (let ([p (t "original")])
+		 (pin-over p 0 (pict-height p) (hline (pict-width p) 1))))
+	      "pict's bounding box and baselines")
+   (note "(The green frame is the \"bounding box\" of the result)")
+   (blank)
+   (page-item "The" (code pin-over) "function is useful with" (code pt-arrow-line)
+	      "to draw an"
+	      (let ([p (bound-frame (inset (t "outgoing arrow") 2))])
+		(pin-over p (/ (pict-width p) 2)  (/ (pict-height p) 2) 
+			  ;; pt-arrow-line creates a pict where the
+			  ;; "bounding box" corresponds to the non-arrow end
+			  (linewidth 3 (colorize (pt-arrow-line 50 50 gap-size) "orange"))))
+	      "without changing the layout"))
+
+  (define blue-fish (standard-fish (* 3 gap-size) (* 2 gap-size) 'right "blue" "white"))
+  (define plain-file (file-icon (* 2 gap-size) (* 3 gap-size) #t))
+  (define fish-file-scene (bound-frame 
+			   (inset (ht-append (* 4 gap-size) 
+					     blue-fish 
+					     (inset plain-file 0 (* 2 gap-size) 0 0))
+				  gap-size)))
+
+  (slide/title
+   "Finding Picts"
+   (page-para "Typically, an arrow needs to go from one pict to another")
+   (page-para "Functions like" (code rc-find) "locate a point of a pict (such as \"right center\") inside a larger pict")
+   (let-values ([(fdx fdy) (rc-find fish-file-scene blue-fish)]
+		[(adx ady) (lt-find fish-file-scene plain-file)])
+     (pin-over fish-file-scene
+	       fdx fdy
+	       (colorize
+		(pt-arrow-line (- adx fdx) (- ady fdy) gap-size)
+		"orange")))
+   (page-para "There's a" (code -find) "function for every combination of"
+	      (code l) "," (code c) ", and" (code r)
+	      "with" (code t) "," (code c) "," (code b)
+	      "," (code bl) ", and" (code tl)))
+  
+  (slide/title/center
+   "Connecting with Arrows"
+   (page-para "Actually, straight-arrow combinations are so common that"
+	      "Slideshow provides"
+	      (code pin-arrow-line))
+   (pin-arrow-line gap-size fish-file-scene
+		   blue-fish rc-find
+		   plain-file lt-find
+		   1 "orange"))
+  
+  (require (lib "balloon.ss" "texpict"))
+  (slide/title/center
+   "Balloons"
+   (page-para "The" (code (lib "balloon.ss" "texpict"))
+	      "library provides cartoon balloons" sym:emdash
+	      "another reason to use" (code -find) "functions")
+   (let* ([orig fish-file-scene]
+	  [w/fish (pin-balloon (wrap-balloon (t "Fish") 'ne 0 (- gap-size))
+			       orig blue-fish cb-find)]
+	  [w/file (pin-balloon (wrap-balloon (t "File") 'nw (* -2 gap-size) 0)
+			       w/fish
+			       plain-file rc-find)])
+     w/file))
+		  
+  (slide/title
+   "Ghosting"
+   (page-para "The" (code ghost) "function turns a picture invisible")
+   (page-para "For example, the figure on the left and the"
+              "figure on the right are the same size, because the"
+	      "right one uses the" (code ghost) "of the left one")
+   (let ([big-circle (circle 350)]
+         [small-circle (circle 200)])
+     (hc-append
+      30
+      (bound-frame big-circle)
+      (bound-frame
+       (lt-superimpose
+	small-circle
+	(rt-superimpose
+	 small-circle
+	 (lb-superimpose
+	  small-circle
+	  (rb-superimpose
+	   small-circle
+	   (ghost big-circle)))))))))
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; Utilities for running additional examples
+  
+  (define (link s)
+    (let ([p (t s)])
+      (colorize
+       (pin-over p 0 (pict-height p)
+		 (linewidth 2 (hline (pict-width p) 2)))
+       "blue")))
+
+  (define (run-example-talk f)
+    (let ([c (make-custodian)])
+      (parameterize ([current-namespace (make-namespace-with-mred)]
+		     [current-command-line-arguments
+		      (vector (build-path (collection-path "slideshow")
+					  "examples"
+					  f))]
+		     [current-custodian c]
+		     [exit-handler (lambda (v)
+				     (custodian-shutdown-all c))]
+		     [current-directory (build-path (collection-path "slideshow")
+						    "examples")])
+	(parameterize ([current-eventspace (make-eventspace)])
+	  (queue-callback
+	   (lambda () (dynamic-require '(lib "slideshow.ss" "slideshow") #f)))))))
+
+  (require (lib "edit.ss" "mred"))
+  (define (show-example-code f)
+    (new-text-frame (build-path (collection-path "slideshow")
+				"examples"
+				f)))  
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; Part IV
+  (outline 'four)
+  
+  (define (in-picture-slide show-fish show-file show-link)
+    (slide/title
+     "In-Picture Sequences"
+     (page-para "Although" (code 'next) "and" (code 'alts)
+		"can create simple sequences, use procedure"
+		"abstraction and" (code ghost) "to create"
+		"complex sequences inside pict assemblies")
+     (let* ([orig fish-file-scene]
+	    [w/fish (pin-balloon (wrap-balloon (t "Fish") 'ne 0 (- gap-size))
+				 (ghost orig) blue-fish cb-find)]
+	    [w/file (pin-balloon (wrap-balloon (t "File") 'nw (* -2 gap-size) 0)
+				 (ghost w/fish) plain-file rc-find)])
+       (cc-superimpose orig
+		       (show-fish w/fish)
+		       (show-file w/file)))
+     (blank)
+     (blank)
+     (blank)
+     (show-link
+      (page-para/r "Larger example:" 
+		   (clickback (link "run")
+			      (lambda ()
+				(run-example-talk "interlocking-components.scm")))
+		   (clickback (link "code")
+			      (lambda ()
+				(show-example-code "interlocking-components.scm")))))))
+
+  (define (ident x) x)
+  (in-picture-slide ghost ghost ghost)
+  (in-picture-slide ident ghost ghost)
+  (in-picture-slide ident ident ident)
+
+  (define (encloud p)
+    (refocus
+     (cc-superimpose
+      (cloud (* 9/8 (pict-width p))
+	     (* 3/2 (pict-height p))
+	     "light gray")
+      p)
+     p))
+
+  (require (lib "step.ss" "slideshow"))
+  (with-steps
+   (intro basic-stx example-steps with-vonly with-vafter the-rest)
+   (slide/title
+    "Named Steps"
+    (page-para "The" (code (lib "step.ss" "slideshow"))
+	       "library provides a" (code with-steps)
+	       "form to better express complex sequences")
+    (lt-superimpose
+     ((vonly basic-stx)
+      (code (with-steps
+	     (_step-name ...)
+	     _slide-expr)))
+     ((vonly example-steps)
+      (code (with-steps
+	     (intro detail conclusion)
+	     _slide-expr)))
+     ((vafter with-vonly)
+      (code (with-steps
+	     (intro detail conclusion)
+	     code:blank
+	     #,(encloud
+		(cc-superimpose
+		 ((vonly with-vonly)
+		  (code ((vonly intro)
+			 (t "For a start..."))))
+		 ((vafter with-vafter)
+		  (code ((vafter detail)
+			 (t "like this"))))))))))
+    (blank)
+    (lt-superimpose
+     ((vonly basic-stx)
+      (page-para "A" (code with-steps) "form has a sequences of step names"
+		 "followed by an expression to evaluate once for each step"))
+     ((vonly example-steps)
+      (page-para "For example, the above has three steps:"
+		 (code intro) "," (code detail)
+		 ", and" (code conclusion)))
+     ((vonly with-vonly)
+      (vl-append
+       gap-size
+       (page-para "In the body expression, use"
+		  (code ((vonly _step-name) _pict-expr))
+		  "to make" (code _pict-expr)
+		  "visible only during" (code _step-name))
+       (page-para "The expression" (code (vonly _step-name))
+		  "produces either" (code ghost)
+		  "or the identity function")))
+     ((vonly with-vafter)
+      (page-para "Use"
+		 (code ((vafter _step-name) _pict-expr))
+		 "to make" (code _pict-expr)
+		 "visible after" (code _step-name)))
+     ((vonly the-rest)
+      (page-para "There's also" (code vbefore) "," (code vbetween) ", and more")))))
+
+
+  (define smiley (face 'happy))
+  (define desc (page-para "The" (code scroll-transition)
+			  "function scrolls some part of the current slide"
+			  "before shifting to the next slide."))
+  
+  (define (scroll-slide right?)
+    (slide/title
+     "Transition Animations"
+     desc
+     (hc-append
+      (* 3 gap-size)
+      ((if right? ghost values) smiley)
+      ((if right? values ghost) smiley))
+     (blank)
+     ((if right? values ghost) (page-para "The face should have moved from left to right"))))
+  (scroll-slide #f)
+  
+  ;; We really need a better way to do this!
+  (let ([x (/ (- client-w (* 3 gap-size) (* 2 (pict-width smiley))) 2)]
+	[y (+ (pict-height (titlet "Anything")) (* 2 gap-size)
+	      (pict-height desc) gap-size)])
+    (scroll-transition x y
+		       (pict-width smiley) (pict-height smiley)
+		       (+ (pict-width smiley) (* 3 gap-size)) 0
+		       0.5 20))
+  
+  (scroll-slide #t)
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; Background
+
+  ;; A pict to use behind the main content
+  (define fade-bg
+    (let ([w (+ (* 2 margin) client-w)]
+	  [h (+ (* 2 margin) client-h)]
+	  [trans (make-object brush% "white" 'transparent)]
+	  [inside (make-object brush% "white" 'solid)])
+      (inset (dc (lambda (dc x y)
+		   (let ([b (send dc get-brush)]
+			 [p (send dc get-pen)]
+			 [draw-one
+			  (lambda (i)
+			    (send dc draw-rectangle
+				  (+ x i) (+ y i)
+				  (- w (* 2 i)) (- h (* 2 i))))])
+		     (send dc set-brush trans)
+		     (color-series 
+		      dc margin 1
+		      (make-object color% "black")
+		      (make-object color% "white")
+		      draw-one
+		      #t #t)
+		     (send dc set-brush inside)
+		     (draw-one margin)
+		     (send dc set-pen p)
+		     (send dc set-brush b)))
+		 w h 0 0)
+	     (- margin))))
+
+  (define orig-assembler (current-slide-assembler))
+
+  ;; Normally, you'd set the slide assembler at the beginning
+  ;;  of a talk and never change it
+  (current-slide-assembler
+   (lambda (s v-sep c)
+     (lt-superimpose
+      fade-bg
+      (let ([c (colorize c "darkred")])
+	(if s
+	    (vc-append v-sep 
+		       ;; left-aligns the title:
+		       (page-para (titlet s)) 
+		       c)
+	    c)))))
+
+  (outline 'background)
+
+  (slide/title/center
+   "Controlling the Background"
+   (page-para "The" (code current-slide-assembler)
+	      "parameter lets you change the overall look of a slide")
+   (page-para "For this slide and the previous one, the assembler")
+   (page-item "Colorizes the uncolored content as dark red")
+   (page-item "Left-aligns the title")
+   (page-item "Draws a fading box around the slide"))
+
+  (current-slide-assembler orig-assembler)
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; Printing and Condensing
+  (outline 'printing)
+
+  (slide/title/center
+   "Printing"
+   (page-para "To export a set of slides as PostScript, "
+	      "use the" (tt "slideshow") "command-line program:")
+   (tt "slideshow --print myttalk.scm")
+   (blank)
+   (page-para "Slideshow steps through slides while producing PostScript pages")
+   (page-para "The slides will look bad on the screen" sym:emdash "because"
+	      "text is measured for printing instead of screen display"
+	      sym:emdash "but the PostScript will be fine"))
+
+  (slide/title/center
+   "Condensing"
+   (page-para "Often, it makes sense to eliminate" (code 'step)
+	      "staging when printing slides:")
+   (tt "slideshow --print --condense myttalk.scm")
+   (blank)
+   'next
+   (page-para "You can also condense without printing")
+   (tt "slideshow --condense myttalk.scm")
+   'next
+   (blank)
+   (page-para "For example, in condensed form, this slide appears"
+	      "without steps"))
+   
+  (slide/title/center
+   "Steps and Condensing"
+   (page-para "If you condense these slides,"
+              "the previous slide's steps will be skipped")
+   'next!
+   (page-para "Not this slide's steps, because it uses" (code 'next!)))
+  
+  (slide/title/center
+   "Condensing Alternatives"
+   (page-para "Condensing" (it "does not") "merge" (code 'alts) "alternatives")
+   (page-para "But sometimes you want condensing to just use the last alternative")
+   'alts~
+   (list (list (t "um..."))
+         (list (page-para
+                (code 'alts~) "creates alternatives where only the last one"
+                "is used when condensing"))))
+
+  (slide/title/center
+   "Condensing Steps"
+   (page-para "The" (code (lib "step.ss" "slideshow"))
+	      "provides" (code with-steps~)
+	      "where only the last step is included when condensing")
+   (page-para "Also, a" (code with-steps) "step name that"
+	      "ends with" (code ~) "is skipped when condensing"))
+
+  (slide/title/center
+   "Printing and Condensing Your Own Abstractions"
+   (page-para "You can customize your slides using" (code printing?)
+	      "and" (code condensing?))
+   (blank)
+   (page-para "This particular slide is"
+	      (if printing? "printed" "not printed")
+	      "and"
+	      (if condense? "condensed" "not condensed"))
+   (blank)
+   (page-para "When you skip a whole slide, use"
+	      (code skip-slides) "to keep page numbers in sync"))
+  
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; Conclusion starts here
+  (outline 'end)
+
+  (slide/title/center
+   "Your Own Slides"
+   (page-para "A Slideshow presentation is a Scheme program in a module,"
+              "so to make your own:")
+   (scale/improve-new-text ; a macro that improves font selection
+    (code (module mytalk (lib "slideshow.ss" "slideshow")
+	    ... #,(it "your code here") ...))
+    0.9)
+   (blank)
+   (page-para "For further information, search for"
+	      (tt "slideshow") "and" (tt "texpict")
+	      "in Help Desk"))
+  
+  )
diff --git a/collects/slideshow/util.ss b/collects/slideshow/util.ss
new file mode 100644
index 0000000000..3926177ecd
--- /dev/null
+++ b/collects/slideshow/util.ss
@@ -0,0 +1,40 @@
+
+(module util mzscheme
+  (require (lib "mred.ss" "mred")
+	   (lib "class.ss"))
+
+  (provide make-bitmap
+	   define-accessor
+	   define/provide-struct)
+
+  ;; If bitmap creation fails, try an explicit GC.
+  ;; (This loop should be built into MrEd, but it wasn't
+  ;; at the time this code was written.)
+  (define (make-bitmap w h)
+    (let loop ([n 0])
+      (let ([bm (make-object bitmap% w h)])
+	(if (or (= n 4)
+		(send bm ok?))
+	    bm
+	    (begin
+	      (collect-garbage)
+	      (loop (add1 n)))))))
+
+  (define-syntax define-accessor
+    (syntax-rules ()
+      [(_ margin get-margin)
+       (define-syntax margin
+	 (syntax-id-rules ()
+	   [(margin arg) ((get-margin) arg...)]
+	   [margin (get-margin)]))]))
+  
+
+  (define-syntax define/provide-struct
+    (syntax-rules ()
+      [(_ id flds)
+       (begin
+	 (define-struct id flds)
+	 (provide (struct id flds)))])))
+
+
+
diff --git a/collects/slideshow/viewer.ss b/collects/slideshow/viewer.ss
new file mode 100644
index 0000000000..7bf4841f8a
--- /dev/null
+++ b/collects/slideshow/viewer.ss
@@ -0,0 +1,1122 @@
+
+(module viewer mzscheme
+  (require (lib "class.ss")
+           (lib "unit.ss")
+           (lib "unitsig.ss")
+	   (lib "file.ss")
+	   (lib "etc.ss")
+	   (lib "contract.ss")
+	   (lib "mred.ss" "mred")
+	   (lib "mrpict.ss" "texpict")
+	   (lib "utils.ss" "texpict")
+	   (lib "math.ss")
+	   (lib "list.ss")
+	   "sig.ss"
+	   "core.ss"
+	   "util.ss")
+
+  (provide viewer@)
+
+  ;; Needed for browsing
+  (define original-security-guard (current-security-guard))
+      
+  (define viewer@
+    (unit/sig viewer^
+      (import (config : cmdline^) core^)
+      (rename (viewer:set-use-background-frame! set-use-background-frame!)
+	      (viewer:enable-click-advance! enable-click-advance!)
+	      (viewer:set-page-numbers-visible! set-page-numbers-visible!)
+	      (viewer:done-making-slides done-making-slides))
+
+      (define-accessor margin get-margin)
+      (define-accessor client-w get-client-w)
+      (define-accessor client-h get-client-h)
+
+      (define target-page config:init-page)
+      (define current-page (if config:printing? config:init-page 0))
+      (define use-background-frame? #f)
+      (define show-page-numbers? #t)
+      (define click-to-advance? #t)
+      (define blank-cursor-allowed? #t)
+      (define click-regions null)
+      (define talk-slide-list null)
+      (define given-talk-slide-list null)
+      (define talk-slide-reverse-cell-list null)
+      (define given-slide-count 0)
+      (define slide-count 0)
+
+      (define error-on-slide? #f)
+
+      (define empty-slide
+	(make-sliderec (lambda (dc x y) (void))
+		       "<Empty>"
+		       #f
+		       0
+		       1
+		       zero-inset
+		       null))
+
+      (define (talk-list-ref n)
+	(if (n . < . slide-count)
+	    (list-ref talk-slide-list n)
+	    empty-slide))
+
+      (define (given->main!)
+	(if config:quad-view?
+	    (begin
+	      ;; WARNING: This make slide creation O(n^2) for n slides
+	      (set! talk-slide-list (make-quad given-talk-slide-list))
+	      (set! slide-count (length talk-slide-list)))
+	    (begin
+	      (set! talk-slide-list given-talk-slide-list)
+	      (set! slide-count given-slide-count))))
+
+      (define (add-talk-slide! s)
+	(when error-on-slide?
+	  (error "slide window has been closed"))
+	(let ([p (cons s null)])
+	  (if (null? talk-slide-reverse-cell-list)
+	      (set! given-talk-slide-list p)
+	      (set-cdr! (car talk-slide-reverse-cell-list) p))
+	  (set! talk-slide-reverse-cell-list (cons p talk-slide-reverse-cell-list)))
+	(set! given-slide-count (add1 given-slide-count))
+	(given->main!)
+	(if config:printing?
+	    (send progress-display set-label (number->string slide-count))
+	    (begin
+	      (send f slide-changed (sub1 slide-count))
+	      (when (and target-page (= target-page (sub1 slide-count)))
+		(set-init-page! target-page)
+		(set! target-page #f))
+	      (yield))))
+
+      (define (retract-talk-slide!)
+	(unless (null? talk-slide-reverse-cell-list)
+	  (set! talk-slide-reverse-cell-list (cdr talk-slide-reverse-cell-list))
+	  (if (null? talk-slide-reverse-cell-list)
+	      (set! given-talk-slide-list null)
+	      (set-cdr! (car talk-slide-reverse-cell-list) null)))
+	(set! given-slide-count (sub1 given-slide-count))
+	(given->main!)
+	(unless config:printing?
+	  (send f slide-changed slide-count)
+	  (yield)))
+
+      (define (most-recent-talk-slide)
+	(and (pair? talk-slide-reverse-cell-list)
+	     (caar talk-slide-reverse-cell-list)))
+      
+      (define (set-init-page! p)
+	(set! current-page p)
+	(refresh-page))
+      
+      (define (viewer:set-use-background-frame! on?)
+	(set! use-background-frame? (and on? #t)))
+      
+      (define (viewer:enable-click-advance! on?)
+	(set! click-to-advance? (and on? #t)))
+      
+      (define (viewer:set-page-numbers-visible! on?)
+	(set! show-page-numbers? (and on? #t)))
+      (viewer:set-page-numbers-visible! config:show-page-numbers?)
+      
+      (define adjust-cursor (lambda () (send f set-blank-cursor #f)))
+
+      (define (add-click-region! cr)
+	(adjust-cursor)
+	(set! click-regions (cons cr click-regions)))
+
+      (define (make-quad l)
+	(cond
+	 [(null? l) null]
+	 [(< (length l) 4)
+	  (make-quad (append l (vector->list
+				(make-vector
+				 (- 4 (length l))
+				 (make-sliderec void #f #f 
+						(sliderec-page (car (last-pair l)))
+						1 
+						zero-inset 
+						null)))))]
+	 [else (let ([a (car l)]
+		     [b (cadr l)]
+		     [c (caddr l)]
+		     [d (cadddr l)]
+		     [untitled "(untitled)"])
+		 (cons (make-sliderec
+			(lambda (dc x y)
+			  (define-values (orig-sx orig-sy) (send dc get-scale))
+			  (define-values (orig-ox orig-oy) (send dc get-origin))
+			  (define scale (min (/ (- (/ client-h 2) margin) client-h)
+					     (/ (- (/ client-w 2) margin) client-w)))
+			  (define (set-origin x y)
+			    (send dc set-origin (+ orig-ox (* x orig-sx)) (+ orig-oy (* y orig-sy))))
+			  (send dc set-scale (* orig-sx scale) (* orig-sy scale))
+			  (set-origin x y)
+			  ((sliderec-drawer a) dc 0 0)
+			  (set-origin (+ x (/ client-w 2) margin) y)
+			  ((sliderec-drawer b) dc 0 0)
+			  (set-origin x (+ y (/ client-h 2) margin))
+			  ((sliderec-drawer c) dc 0 0)
+			  (set-origin (+ x (/ client-w 2) margin) (+ y (/ client-h 2) margin))
+			  ((sliderec-drawer d) dc 0 0)
+			  (send dc set-scale orig-sx orig-sy)
+			  (set-origin x y)
+			  (send dc draw-line (/ client-w 2) 0 (/ client-w 2) client-h)
+			  (send dc draw-line 0 (/ client-h 2) client-w (/ client-h 2))
+			  (send dc set-origin orig-ox orig-oy))
+			(format "~a | ~a | ~a | ~a"
+				(or (sliderec-title a) untitled)
+				(or (sliderec-title b) untitled)
+				(or (sliderec-title c) untitled)
+				(or (sliderec-title d) untitled))
+			#f
+			(sliderec-page a)
+			(- (+ (sliderec-page d) (sliderec-page-count d)) (sliderec-page a))
+			zero-inset
+			null)
+		       (make-quad (list-tail l 4))))]))
+
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;                   Main GUI                    ;;
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      
+      (define GAUGE-WIDTH 100)
+      (define GAUGE-HEIGHT 4)
+
+      (define talk-start-seconds (current-seconds))
+      (define slide-start-seconds (current-seconds))
+      
+      (define blank-cursor (make-object cursor% 'blank))
+
+      (application-quit-handler (lambda ()
+				  (send f stop-show)))
+
+      (define talk-frame%
+	(class frame% 
+	  (init-field closeable?)
+	  (init-field close-bg?)
+	  (define/augment can-close? (lambda () (and closeable? (inner #t can-close?))))
+	  (define/override on-superwindow-show (lambda (on?)
+						 (unless on?
+						   (when (and close-bg? background-f)
+						     (send background-f show #f)))))
+
+	  (define/override on-subwindow-char
+	    (lambda (w e)
+	      (let ([k (send e get-key-code)])
+		(case k
+		  [(right)
+		   (shift e 1 0 (lambda () (next)))]
+		  [(left)
+		   (shift e -1 0 (lambda () (prev)))]
+		  [(up)
+		   (shift e 0 -1 void)]
+		  [(down)
+		   (shift e 0 1 void)]
+		  [(#\space #\f #\n)
+		   (next)
+		   #t]
+		  [(#\b #\backspace #\rubout)
+		   (prev)
+		   #t]
+		  [(#\g)
+		   (stop-transition)
+		   (if (send e get-meta-down)
+		       (get-page-from-user)
+		       (begin
+			 (set! current-page (max 0 (sub1 slide-count)))
+			 (refresh-page)))
+		   #t]
+		  [(#\1)
+		   (stop-transition)
+		   (set! current-page 0)
+		   (refresh-page)
+		   #t]
+		  [(#\q #\u0153)  ; #\u0153 is for Mac OS
+		   (stop-transition)
+		   (when (or (send e get-meta-down)
+			     (send e get-alt-down))
+		     (stop-show))
+		   #t]
+		  [(escape)
+		   (when (equal? 1 (message-box/custom
+				    "Quit"
+				    "Really quit the slide show?"
+				    "&Quit"
+				    "&Cancel"
+				    #f
+				    this
+				    '(default=1 caution)))
+		     (stop-show))
+		   #t]
+		  [(#\p)
+		   (when (or (send e get-meta-down)
+			     (send e get-alt-down))
+		     (set! show-page-numbers? (not show-page-numbers?))
+		     (stop-transition)
+		     (refresh-page))
+		   #t]
+		  [(#\d)
+		   (when (or (send e get-meta-down)
+			     (send e get-alt-down))
+		     (stop-transition)
+		     (send f-both show (not (send f-both is-shown?)))
+		     (refresh-page))
+		   #t]
+		  [(#\c)
+		   (when (or (send e get-meta-down)
+			     (send e get-alt-down))
+		     (stop-transition)
+		     (send c-frame show (not (send c-frame is-shown?))))
+		   #t]
+		  [(#\m)
+		   (when (or (send e get-meta-down)
+			     (send e get-alt-down))
+		     (set! blank-cursor-allowed? (not blank-cursor-allowed?))
+		     (send f set-blank-cursor blank-cursor-allowed?))]
+		  [else
+		   #f]))))
+
+	  (define/public (stop-show)
+	    (send c-frame show #f)
+	    (send f-both show #f)
+	    (when use-background-frame?
+	      (send f show #f))
+	    (send f show #f)
+	    (when config:print-slide-seconds?
+	      (printf "Total Time: ~a seconds~n"
+		      (- (current-seconds) talk-start-seconds)))
+	    ;; In case slides are still building, tell them to stop. We
+	    ;;  prefer not to `exit' directly if we don't have to.
+	    (set! error-on-slide? #t))
+	  
+	  (define/private (shift e xs ys otherwise)
+	    (cond
+	     [(or (send e get-meta-down)
+		  (send e get-alt-down))
+	      (move-over (* xs 20) (* ys 20))]
+	     [(send e get-shift-down)
+	      (move-over xs ys)]
+	     [else
+	      (otherwise)])
+	    #t)
+	  
+	  (inherit get-x get-y move)
+	  (define/private (move-over dx dy)
+	    (let ([x (get-x)]
+		  [y (get-y)])
+	      (move (+ x dx) (+ y dy))))
+	  
+	  (define/private (prev)
+	    (stop-transition)
+	    (set! current-page (max (sub1 current-page)
+				    0))
+	    (refresh-page))
+	  
+	  (define/public (next)
+	    (if (pair? current-transitions)
+		(stop-transition)
+		(change-slide 1)))
+
+	  (define/public (slide-changed pos)
+	    (when (or (= pos current-page)
+		      (and (or config:use-prefetch?
+			       (send f-both is-shown?))
+			   (= pos (add1 current-page))))
+	      (stop-transition)
+	      (set! prefetched-page #f)
+	      (change-slide 0)
+	      (when (and (= pos 0)
+			 (not config:printing?))
+		(when use-background-frame?
+		  (send f show #f)
+		  (yield)
+		  (send background-f show #t))
+		(send f show #t)
+		(when config:two-frames?
+		  (send f-both show #t)))))
+
+	  (define/private (change-slide n)
+	    (let ([old (talk-list-ref current-page)])
+	      (set! current-page (max 0
+				      (min (+ n current-page)
+					   (sub1 slide-count))))
+	      (when config:print-slide-seconds?
+		(let ([slide-end-seconds (current-seconds)])
+		  (printf "Slide ~a: ~a seconds~n" current-page
+			  (- slide-end-seconds slide-start-seconds))
+		  (set! slide-start-seconds slide-end-seconds)))
+	      ;; Refresh screen, and start transitions from old, if any
+	      (do-transitions (if config:use-transitions?
+				  (sliderec-transitions old)
+				  null)
+			      (send c get-offscreen))))
+
+	  (define blank-cursor? #f)
+	  (define activated? #f)
+
+	  (inherit set-cursor)
+
+	  (define/override (on-activate on?)
+	    (set! activated? on?)
+	    (when blank-cursor?
+	      (set-cursor (if (and blank-cursor? on? blank-cursor-allowed?)
+			      blank-cursor
+			      #f))))
+	  (define/public (set-blank-cursor b?)
+	    (set! blank-cursor? (and b? #t))
+	    (when activated?
+	      (set-cursor (if (and blank-cursor? blank-cursor-allowed?)
+			      blank-cursor
+			      #f))))
+
+	  (super-new)))
+      
+      (define-values (screen-left-inset screen-top-inset)
+	(if config:keep-titlebar?
+	    (values 0 0)
+	    (get-display-left-top-inset)))
+
+      (define background-f
+	(make-object (class frame%
+		       (inherit is-shown?)
+		       (define/override (on-activate on?)
+			 (when (and on? (is-shown?))
+			   (send f show #t)))
+		       (super-new
+			[label "Slideshow Background"]
+			[x (- screen-left-inset)] [y (- screen-top-inset)]
+			[width (inexact->exact (floor config:actual-screen-w))]
+			[height (inexact->exact (floor config:actual-screen-h))]
+			[style '(no-caption no-resize-border hide-menu-bar)]))))
+
+      (send background-f enable #f)
+
+      (define f (new talk-frame%
+		     [closeable? config:keep-titlebar?]
+		     [close-bg? #t]
+		     [label (if config:file-to-load
+				(format "~a: slideshow" (file-name-from-path config:file-to-load))
+				"Slideshow")]
+		     [x (- screen-left-inset)] [y (- screen-top-inset)]
+		     [width (inexact->exact (floor config:actual-screen-w))]
+		     [height (inexact->exact (floor config:actual-screen-h))]
+		     [style (if config:keep-titlebar?
+				null
+				'(no-caption no-resize-border hide-menu-bar))]))
+      
+      (define f-both (new talk-frame%
+			  [closeable? #t]
+			  [close-bg? #f]
+			  [label "Slideshow Preview"]
+			  [x 0] [y 0]
+			  [width (inexact->exact (floor config:actual-screen-w))]
+			  [height (inexact->exact (quotient (floor config:actual-screen-h) 2))]
+			  [style '()]))
+      
+      (define current-sinset zero-inset)
+      (define resizing-frame? #f)
+      (define (reset-display-inset! sinset)
+	(unless (and (= (sinset-l current-sinset) (sinset-l sinset))
+		     (= (sinset-t current-sinset) (sinset-t sinset))
+		     (= (sinset-r current-sinset) (sinset-r sinset))
+		     (= (sinset-b current-sinset) (sinset-b sinset)))
+	  (set! resizing-frame? #t) ; hack --- see yield below
+	  (send f resize 
+		(max 1 (- (inexact->exact (floor config:actual-screen-w)) 
+			  (inexact->exact (floor (* (+ (sinset-l sinset) (sinset-r sinset))
+						    (/ config:actual-screen-w config:screen-w))))))
+		(max 1 (- (inexact->exact (floor config:actual-screen-h)) 
+			  (inexact->exact (floor (* (+ (sinset-t sinset) (sinset-b sinset))
+						    (/ config:actual-screen-h config:screen-h)))))))
+	  (send f move 
+		(inexact->exact (- (floor (* (sinset-l sinset) 
+					     (/ config:actual-screen-w config:screen-w))) 
+				   screen-left-inset))
+		(inexact->exact (- (floor (* (sinset-t sinset) 
+					     (/ config:actual-screen-h config:screen-h))) 
+				   screen-top-inset)))
+	  (set! current-sinset sinset)
+	  ;; FIXME: This yield is here so that the frame
+	  ;;  and its children can learn about their new
+	  ;;  sizes, and so that the generated on-size callback
+	  ;;  can be ignored. Obviously, using yield creates a
+	  ;;  kind of race condition for incoming events from the user.
+	  (yield)
+	  (set! resizing-frame? #f)))
+      
+
+      (define c-frame (new (class talk-frame%
+			     (define/override (on-move x y)
+			       (super on-move x y)
+			       (parameterize ([current-security-guard original-security-guard])
+				 (with-handlers ([void raise]) ; prevents exn handler from grabbing security guard
+				   (put-preferences '(slideshow:commentary-x slideshow:commentary-y)
+						    (list x y)
+						    void))))
+			     (define/override (on-size w h)
+			       (super on-size w h)
+			       (parameterize ([current-security-guard original-security-guard])
+				 (with-handlers ([void raise]) ; prevents exn handler from grabbing security guard
+				   (put-preferences '(slideshow:commentary-width slideshow:commentary-height)
+						    (list w h)
+						    void))))
+			     (super-new))
+			   [closeable? #t]
+			   [close-bg? #f]
+			   [label "Commentary"]
+			   [width (get-preference 'slideshow:commentary-width (lambda () 400))]
+			   [height (get-preference 'slideshow:commentary-height (lambda () 100))]
+			   [x (get-preference 'slideshow:commentary-x (lambda () #f))]
+			   [y (get-preference 'slideshow:commentary-y (lambda () #f))]))
+      (define commentary (make-object text%))
+      (send (new (class editor-canvas% 
+		   (define/override (on-event e)
+		     (super on-event e)
+		     (when (and click-to-advance?
+				(send e button-up?))
+		       (send f next)))
+		   (super-new))
+		 [parent c-frame] 
+		 [editor commentary] 
+		 [style (if (eq? (system-type) 'macosx)
+			    '(auto-hscroll resize-corner)
+			    '(auto-hscroll auto-vscroll))])
+	    set-line-count 3)
+      (send commentary auto-wrap #t)
+      (send c-frame reflow-container)
+      (define SCROLL-STEP-SIZE 20)
+      (define pict-snip%
+	(class snip%
+	  (init-field pict)
+	  (define drawer (make-pict-drawer pict))
+	  (define/override (draw dc x y left top right bottom dx dy draw-caret)
+	    (drawer dc x y))
+	  (define/private (set-box/f b v)
+	    (when b (set-box! b v)))
+	  (define/override (get-extent dc x y wbox hbox descent space lspace rspace)
+	    (set-box/f wbox (pict-width pict))
+	    (set-box/f hbox (pict-height pict))
+	    (set-box/f descent (pict-descent pict))
+	    (set-box/f space 0)
+	    (set-box/f lspace 0)
+	    (set-box/f rspace 0))
+	  (define/override (get-num-scroll-steps)
+	    (inexact->exact (ceiling (/ (pict-height pict) SCROLL-STEP-SIZE))))
+	  (define/override (find-scroll-step y)
+	    (inexact->exact (floor (/ (max 0 y) SCROLL-STEP-SIZE))))
+	  (define/override (get-scroll-step-offset n)
+	    (* n SCROLL-STEP-SIZE))
+	  (super-new)
+	  (inherit set-snipclass)
+	  (set-snipclass pict-snipclass)))
+      (define pict-snipclass (new snip-class%))
+
+      
+      (define start-time #f)
+      
+      (define clear-brush (make-object brush% "WHITE" 'transparent))
+      (define white-brush (make-object brush% "WHITE" 'solid))
+      (define gray-brush (make-object brush% "GRAY" 'solid))
+      (define green-brush (make-object brush% "GREEN" 'solid))
+      (define red-brush (make-object brush% "RED" 'solid))
+      (define black-brush (make-object brush% "BLACK" 'solid))
+      (define black-pen (make-object pen% "BLACK" 1 'solid))
+      (define clear-pen (make-object pen% "BLACK" 1 'transparent))
+      (define red-color (make-object color% "RED"))
+      (define green-color (make-object color% "GREEN"))
+      (define black-color (make-object color% "BLACK"))
+
+      (define (slide-page-string slide)
+	(if (= 1 (sliderec-page-count slide))
+	    (format "~a" (sliderec-page slide))
+	    (format "~a-~a" (sliderec-page slide) (+ (sliderec-page slide)
+						     (sliderec-page-count slide)
+						     -1))))
+      
+      (define (calc-progress)
+	(if (and start-time config:talk-duration-minutes)
+	    (values (min 1 (/ (- (current-seconds) start-time) (* 60 config:talk-duration-minutes)))
+		    (/ current-page (max 1 (sub1 slide-count))))
+	    (values 0 0)))
+      
+      (define (show-time dc w h)
+	(let* ([left (- w GAUGE-WIDTH)]
+	       [top (- h GAUGE-HEIGHT)]
+	       [b (send dc get-brush)]
+	       [p (send dc get-pen)])
+	  (send dc set-pen black-pen)
+	  (send dc set-brush (if start-time gray-brush clear-brush))
+	  (send dc draw-rectangle left top GAUGE-WIDTH GAUGE-HEIGHT)
+	  (when start-time
+	    (let-values ([(duration distance) (calc-progress)])
+	      (send dc set-brush (if (< distance duration)
+				     red-brush
+				     green-brush))
+	      (send dc draw-rectangle left top (floor (* GAUGE-WIDTH distance)) GAUGE-HEIGHT)
+	      (send dc set-brush clear-brush)
+	      (send dc draw-rectangle left top (floor (* GAUGE-WIDTH duration)) GAUGE-HEIGHT)))
+	  (send dc set-pen p)
+	  (send dc set-brush b)))
+      
+      (define c%
+	(class canvas%
+	  (inherit get-dc get-client-size)
+	  
+	  (define clicking #f)
+	  (define clicking-hit? #f)
+	  
+	  (define/override (on-paint)
+	    (let ([dc (get-dc)])
+	      (stop-transition/no-refresh)
+	      (cond
+	       [config:use-offscreen?
+		(let ([bm (send offscreen get-bitmap)])
+		  (send (get-dc) draw-bitmap bm 0 0))]
+	       [else
+		(send dc clear)
+		(paint-slide dc)])))
+	  
+	  (inherit get-top-level-window)
+	  (define/override (on-event e)
+	    (cond
+	     [(send e button-down?)
+	      (let ([c (ormap
+			(lambda (c) (and (click-hits? e c) c))
+			click-regions)])
+		(when c
+		  (if (click-region-show-click? c)
+		      (begin
+			(set! clicking c)
+			(set! clicking-hit? #t)
+			(invert-clicking! #t))
+		      ((click-region-thunk c)))))]
+	     [(and clicking (send e dragging?))
+	      (let ([hit? (click-hits? e clicking)])
+		(unless (eq? hit? clicking-hit?)
+		  (set! clicking-hit? hit?)
+		  (invert-clicking! hit?)))]
+	     [(and clicking (send e button-up?))
+	      (let ([hit? (click-hits? e clicking)]
+		    [c clicking])
+		(unless (eq? hit? clicking-hit?)
+		  (set! clicking-hit? hit?)
+		  (invert-clicking! hit?))
+		(when clicking-hit?
+		  (invert-clicking! #f))
+		(set! clicking #f)
+		(when hit?
+		  ((click-region-thunk c))))]
+	     [(send e button-up?)
+	      (when click-to-advance?
+		(send (get-top-level-window) next))]
+	     [else 
+	      (when (and clicking clicking-hit?)
+		(invert-clicking! #f))
+	      (set! clicking #f)]))
+
+	  
+	  (define/private (click-hits? e c)
+	    (let ([x (send e get-x)]
+		  [y (send e get-y)])
+	      (and (<= (click-region-left c) x (click-region-right c))
+		   (<= (click-region-top c) y (click-region-bottom c)))))
+	  (define/private (invert-clicking! on?)
+	    (let ([dc (get-dc)]
+		  [x (click-region-left clicking)]
+		  [y (click-region-top clicking)]
+		  [w (- (click-region-right clicking) (click-region-left clicking))]
+		  [h (- (click-region-bottom clicking) (click-region-top clicking))])
+	      (if (or on?
+		      (not config:use-offscreen?)
+		      (not offscreen))
+		  (let* ([b (send dc get-brush)]
+			 [p (send dc get-pen)])
+		    (send dc set-pen (send the-pen-list find-or-create-pen "white" 1 'transparent))
+		    (send dc set-brush  (send the-brush-list find-or-create-brush "black" 
+					      (if config:use-offscreen?
+						  'hilite
+						  'xor)))
+		    (send dc draw-rectangle  x y w h)
+		    (send dc set-pen p)
+		    (send dc set-brush b))
+		  (send dc draw-bitmap-section
+			(send offscreen get-bitmap)
+			x y x y
+			w h))))
+	  
+	  (define offscreen #f)
+	  (define/public get-offscreen (lambda () offscreen))
+	  
+	  (define/private (shift-click-region cr dx dy)
+	    (make-click-region (+ dx (click-region-left cr))
+			       (+ dy (click-region-top cr))
+			       (+ dx (click-region-right cr))
+			       (+ dy (click-region-bottom cr))
+			       (click-region-thunk cr)
+			       (click-region-show-click? cr)))
+
+	  (define/private (paint-prefetch dc)
+	    (let-values ([(cw ch) (get-client-size)])
+	      (paint-letterbox dc cw ch config:use-screen-w config:use-screen-h)
+	      (let ([dx (floor (/ (- cw config:use-screen-w) 2))]
+		    [dy (floor (/ (- ch config:use-screen-h) 2))])
+		(send dc draw-bitmap prefetch-bitmap dx dy)
+		(set! click-regions (map (lambda (cr)
+					   (shift-click-region cr dx dy))
+					 prefetched-click-regions))
+		(send f set-blank-cursor (null? click-regions)))))
+	  (define/override (on-size w h)
+	    (unless resizing-frame?
+	      (redraw)))
+
+	  (define/public (redraw)
+	    (reset-display-inset! (sliderec-inset (talk-list-ref current-page)))
+	    (send commentary lock #f)
+	    (send commentary begin-edit-sequence)
+	    (send commentary erase)
+	    (let ([s (talk-list-ref current-page)])
+	      (when (just-a-comment? (sliderec-comment s))
+		(for-each (lambda (v)
+			    (send commentary insert (if (string? v)
+							v
+							(make-object pict-snip% v))))
+			  (just-a-comment-content (sliderec-comment s)))))
+	    (send commentary scroll-to-position 0 #f 'same 'start)
+	    (send commentary end-edit-sequence)
+	    (send commentary lock #t)
+	    (set! click-regions null)
+	    (set! clicking #f)
+	    (stop-transition/no-refresh)
+	    (cond
+	     [config:use-offscreen?
+	      (let-values ([(cw ch) (get-client-size)])
+		(when (and offscreen
+			   (let ([bm (send offscreen get-bitmap)])
+			     (not (and (= cw (send bm get-width))
+				       (= ch (send bm get-height))))))
+		  (send offscreen set-bitmap #f)
+		  (set! offscreen #f))
+		(unless offscreen
+		  (set! offscreen (make-object bitmap-dc% 
+					       (make-bitmap cw ch)))))
+	      (send offscreen clear)
+	      (cond
+	       [(equal? prefetched-page current-page)
+		(paint-prefetch offscreen)]
+	       [else
+		(paint-slide offscreen)])
+	      (let ([bm (send offscreen get-bitmap)])
+		(send (get-dc) draw-bitmap bm 0 0))]
+	     [(equal? prefetched-page current-page)
+	      (paint-prefetch (get-dc))]
+	     [else
+	      (let ([dc (get-dc)])
+		(send dc clear)
+		(paint-slide dc))]))
+	  (super-new [style '(no-autoclear)])))
+
+      (define two-c%
+	(class canvas%
+	  (inherit get-dc)
+
+	  (define/public (paint-prefetched)
+	    (let ([dc (get-dc)])
+	      (let*-values ([(cw ch) (send dc get-size)])
+		(send dc set-scale 
+		      (/ (/ cw 2) (send prefetch-bitmap get-width))
+		      (/ ch (send prefetch-bitmap get-height)))
+		(send dc set-origin (/ cw 2) 0)
+		(send dc draw-bitmap prefetch-bitmap 0 0)
+		(send dc set-origin 0 0)
+		(send dc set-scale 1 1)
+		(send dc draw-line (/ cw 2) 0 (/ cw 2) ch))))
+
+	  (define/override (on-paint)
+	    (let ([dc (get-dc)])
+	      (send dc clear)
+	      (let*-values ([(cw ch) (send dc get-size)])
+		(cond
+		 [(and config:use-prefetch? config:use-prefetch-in-preview?)
+		  (let* ([now-bm (send (send c get-offscreen) get-bitmap)]
+			 [bw (send now-bm get-width)]
+			 [bh (send now-bm get-height)])
+		    (send dc set-scale (/ (/ cw 2) bw) (/ ch bh))
+		    (send dc draw-bitmap now-bm 0 0)
+		    (cond
+		     [(equal? prefetched-page (add1 current-page))
+		      (send dc set-origin (/ cw 2) 0)
+		      (send dc draw-bitmap prefetch-bitmap 0 0)]
+		     [else
+		      (when (< (add1 current-page) slide-count)
+			(let ([b (send dc get-brush)])
+			  (send dc set-brush gray-brush)
+			  (send dc draw-rectangle bw 0 bw bh)
+			  (send dc set-brush b)))])
+		    (send dc set-scale 1 1))]
+		 [else
+		  (paint-slide dc current-page 1/2 1/2 cw (* 2 ch) cw (* 2 ch) #f)
+		  (send dc set-origin (/ cw 2) 0)
+		  (when (< (add1 current-page) slide-count)
+		    (paint-slide dc
+				 (+ current-page 1)
+				 1/2 1/2
+				 cw (* 2 ch) cw (* 2 ch)
+				 #f))])
+		(send dc set-origin 0 0)
+		(send dc draw-line (/ cw 2) 0 (/ cw 2) ch))))
+	  
+	  (inherit get-top-level-window)
+	  (define/override (on-event e)
+	    (cond
+	     [(send e button-up?)
+	      (send (get-top-level-window) next)]))
+	  
+	  (define/public (redraw) (on-paint))
+	  (super-new)))
+
+      (define (paint-letterbox dc cw ch usw ush)
+	(when (or (< usw cw)
+		  (< ush ch))
+	  (let ([b (send dc get-brush)]
+		[p (send dc get-pen)])
+	    (send dc set-brush black-brush)
+	    (send dc set-pen clear-pen)
+	    (when (< usw cw)
+	      (let ([half (/ (- cw usw) 2)])
+		(send dc draw-rectangle 0 0 half ch)
+		(send dc draw-rectangle (- cw half) 0 half ch)))
+	    (when (< ush ch)
+	      (let ([half (/ (- ch ush) 2)])
+		(send dc draw-rectangle 0 0 cw half)
+		(send dc draw-rectangle 0 (- ch half) cw half)))
+	    (send dc set-brush b)
+	    (send dc set-pen p))))
+
+      (define paint-slide
+	(case-lambda
+	 [(dc) (paint-slide dc current-page)]
+	 [(dc page) 
+	  (let-values ([(cw ch) (send dc get-size)])
+	    (paint-slide dc page 1 1 cw ch config:use-screen-w config:use-screen-h #t))]
+	 [(dc page extra-scale-x extra-scale-y cw ch usw ush to-main?)
+	  (let* ([slide (talk-list-ref page)]
+		 [ins (sliderec-inset slide)]
+		 [cw (if to-main?
+			 (+ cw (sinset-l ins) (sinset-r ins))
+			 cw)]
+		 [ch (if to-main?
+			 (+ ch (sinset-t ins) (sinset-b ins))
+			 ch)]
+		 [sx (/ usw config:screen-w)]
+		 [sy (/ ush config:screen-h)]
+		 [mx (/ (- cw usw) 2)]
+		 [my (/ (- ch ush) 2)])
+	    (paint-letterbox dc cw ch usw ush)
+	    
+            (when config:smoothing?
+              (send dc set-smoothing 'aligned))
+            (send dc set-scale (* extra-scale-x sx) (* extra-scale-y sy))
+
+	    ;; Draw the slide
+	    ;;  It's important to set the origin based on
+	    ;;  the floor of my and mx. That way, when we pre-fetch
+	    ;;  into a bitmap, we don't change roundoff in
+	    ;;  the drawing
+	    (let-values ([(ox oy) (send dc get-origin)])
+	      (send dc set-origin 
+		    (+ ox (* extra-scale-x (floor mx))) 
+		    (+ oy (* extra-scale-y (floor my))))
+	      ((sliderec-drawer slide) dc margin margin)
+	      (send dc set-origin ox oy))
+	    
+	    ;; reset the scale
+	    (send dc set-scale 1 1)
+
+	    ;; Slide number
+	    (when (and to-main? show-page-numbers?)
+	      (let ([f (send dc get-font)]
+		    [s (slide-page-string slide)]
+		    [c (send dc get-text-foreground)])
+		(send dc set-font (current-page-number-font))
+		(send dc set-text-foreground (current-page-number-color))
+		(let-values ([(w h d a) (send dc get-text-extent s)])
+		  (send dc draw-text s 
+			(- cw w 5 (* sx (sinset-r ins)) (/ (- cw usw) 2))
+			(- ch h 5 (* sy (sinset-b ins)) (/ (- ch ush) 2))))
+		(send dc set-text-foreground c)
+		(send dc set-font f))))]))
+
+      ;; prefetched-page : (union #f number)
+      (define prefetched-page #f)
+      ;; prefetch-bitmap : (union #f bitmap)
+      (define prefetch-bitmap #f)
+      ;; prefetch-bitmap : (union #f bitmap-dc)
+      (define prefetch-dc #f)
+      ;; prefetch-schedule-cancel-box : (box boolean)
+      (define prefetch-schedule-cancel-box (box #f))
+      ;; prefetched-click-regions : list
+      (define prefetched-click-regions null)
+
+      (define (prefetch-slide n)
+	(set! prefetched-page #f)
+	
+	(unless prefetch-dc
+	  (set! prefetch-dc (new bitmap-dc%)))
+
+	;; try to re-use existing bitmap
+	(unless (and (is-a? prefetch-bitmap bitmap%)
+		     (= config:use-screen-w (send prefetch-bitmap get-width))
+		     (= config:use-screen-h (send prefetch-bitmap get-height)))
+	  (send prefetch-dc set-bitmap #f)
+	  (set! prefetch-bitmap (make-bitmap config:use-screen-w config:use-screen-h))
+	  (when (send prefetch-bitmap ok?)
+	    (send prefetch-dc set-bitmap prefetch-bitmap)))
+
+	(when (send prefetch-dc ok?)
+	  (send prefetch-dc clear)
+	  (let ([old-click-regions click-regions]
+		[old-adjust adjust-cursor])
+	    (set! click-regions null)
+	    (set! adjust-cursor void)
+	    (paint-slide prefetch-dc n)
+	    (set! prefetched-click-regions click-regions)
+	    (set! click-regions old-click-regions)
+	    (set! adjust-cursor old-adjust))
+	  (set! prefetched-page n)
+	  (when (and config:use-prefetch-in-preview?
+		     (send f-both is-shown?))
+	    (send c-both paint-prefetched))))
+
+      (define (schedule-slide-prefetch n delay-msec)
+	(cancel-prefetch)
+	(when (and config:use-prefetch?
+		   (not (equal? n prefetched-page)))
+	  (let ([b (box #t)])
+	    (set! prefetch-schedule-cancel-box b)
+	    (new timer% [interval delay-msec] [just-once? #t]
+		 [notify-callback (lambda ()
+				    (when (unbox b)
+				      (if (pair? current-transitions)
+					  ;; try again to wait for transition to end
+					  (schedule-slide-prefetch n delay-msec)
+					  ;; Build next slide...
+					  (prefetch-slide n))))]))))
+
+
+      (define (cancel-prefetch)
+	(set-box! prefetch-schedule-cancel-box #f))
+
+      (define c (make-object c% f))
+      (define c-both (make-object two-c% f-both))
+      
+      (define refresh-page
+	(opt-lambda ([immediate-prefetch? #f])
+	  (hide-cursor-until-moved)
+	  (send f set-blank-cursor #t)
+	  (when (= current-page 0)
+	    (set! start-time #f)
+	    (unless start-time
+	      (set! start-time (current-seconds))))
+	  (send c redraw)
+	  (when (and c-both (send f-both is-shown?))
+	    (send c-both redraw))
+	  (when (< current-page (- slide-count 1))
+	    (schedule-slide-prefetch (+ current-page 1)
+				     (if immediate-prefetch?
+					 50
+					 500)))))
+
+      (define current-transitions null)
+      (define current-transitions-key #f)
+
+      (define (do-transitions transes offscreen)
+	(let ([key (cons 1 2)])
+	  (set! current-transitions (map (lambda (mk) (mk offscreen)) transes))
+	  (set! current-transitions-key key)
+	  (if (null? transes)
+	      (refresh-page #t)
+	      (let do-trans ()
+		(when (and (eq? current-transitions-key key)
+			   (pair? current-transitions))
+		  (let ([went ((car current-transitions) c offscreen)])
+		    (if (eq? went 'done)
+			(begin
+			  (set! current-transitions (cdr current-transitions))
+			  (if (null? current-transitions)
+			      (refresh-page #t)
+			      (do-trans)))
+			(new timer% 
+			     [just-once? #t]
+			     [interval (inexact->exact (floor (* 1000 went)))]
+			     [notify-callback (lambda ()
+						;; Going through queue-callback
+						;;  avoids blocking events
+						(queue-callback
+						 do-trans
+						 #f))]))))))))
+
+      (define (stop-transition)
+	(cancel-prefetch)
+	(unless (null? current-transitions)
+	  (stop-transition/no-refresh)
+	  (refresh-page)))
+      
+      (define (stop-transition/no-refresh)
+	(set! current-transitions null)
+	(set! current-transitions-key #f))
+      
+      (define (get-page-from-user)
+	(unless (zero? slide-count)
+	  (letrec ([d (make-object dialog% "Goto Page" f 200 250)]
+		   [short-slide-list 
+		    (let loop ([slides talk-slide-list][n 1][last-title #f])
+		      (cond
+		       [(null? slides) null]
+		       [(and last-title
+			     (equal? last-title (or (sliderec-title (car slides))
+						    "(untitled)")))
+			(loop (cdr slides) (+ n 1) last-title)]
+		       [else
+			(let ([title (or (sliderec-title (car slides))
+					 "(untitled)")])
+			  (cons (cons
+				 n
+				 (format "~a. ~a" 
+					 (slide-page-string (car slides))
+					 title))
+				(loop (cdr slides) (add1 n) title)))]))]
+		   [long-slide-list (let loop ([slides talk-slide-list][n 1])
+				      (if (null? slides)
+					  null
+					  (cons (cons
+						 n
+						 (format "~a. ~a" 
+							 (slide-page-string (car slides))
+							 (or (sliderec-title (car slides))
+							     "(untitled)")))
+						(loop (cdr slides) (add1 n)))))]
+		   [slide-list short-slide-list]
+		   [l (make-object list-box% #f (map cdr slide-list)
+				   d (lambda (l e)
+				       (when (eq? (send e get-event-type) 'list-box-dclick)
+					 (ok-action))))]
+		   [p (make-object horizontal-pane% d)]
+		   [ok-action (lambda ()
+				(send d show #f)
+				(let ([i (send l get-selection)])
+				  (when i
+				    (set! current-page (sub1 (car (list-ref slide-list i))))
+				    (refresh-page))))])
+	    (send d center)
+	    (send p stretchable-height #f)
+	    (make-object check-box% "&All Pages" p
+			 (lambda (c e)
+			   (set! slide-list (if (send c get-value)
+						long-slide-list
+						short-slide-list))
+			   (send l set (map cdr slide-list))))
+	    (make-object pane% p)
+	    (make-object button% "Cancel" p (lambda (b e) (send d show #f)))
+	    (make-object button% "Ok" p (lambda (b e) (ok-action)) '(border))
+	    (send l focus)
+	    (send d reflow-container)
+	    (let ([now (let loop ([l slide-list][n 0])
+			 (if (null? l)
+			     (sub1 n)
+			     (if (> (sub1 (caar l)) current-page)
+				 (sub1 n)
+				 (loop (cdr l) (add1 n)))))])
+	      (send l set-selection (max 0 now))
+	      (send l set-first-visible-item (max 0 (- now 3))))
+	    (send d show #t))))
+      
+      (send f reflow-container)
+      (send f-both reflow-container)
+
+      (refresh-page)
+      
+      (let* ([bm (make-object bitmap% (build-path (collection-path "slideshow") "slideshow.png"))]
+	     [mbm (make-object bitmap% (build-path (collection-path "slideshow") "mask.xbm"))])
+	(when (send bm ok?)
+	  (send f set-icon bm (and (send mbm ok?) mbm) 'both)))
+      
+      (when config:commentary?
+	(send c-frame show #t)
+	(message-box "Instructions"
+		     (format "Keybindings:~
+                     ~n  {Meta,Alt}-q - quit~
+                     ~n  Right, Space, f or n - next slide~
+                     ~n  Left, b - prev slide~
+                     ~n  g - last slide~
+                     ~n  1 - first slide~
+                     ~n  {Meta,Alt}-g - select slide~
+                     ~n  p - show/hide slide number~
+                     ~n  {Meta,Alt}-c - show/hide commentary~
+                     ~n  {Meta,Alt,Shift}-{Right,Left,Up,Down} - move window~
+                     ~nAll bindings work in all windows")))
+      
+      (define (do-print)
+	(let ([ps-dc (dc-for-text-size)])
+	  (let loop ([start? #f][l (list-tail talk-slide-list current-page)][n current-page])
+	    (unless (null? l)
+	      (set! current-page n)
+	      (refresh-page)
+	      (when start?
+		(send ps-dc start-page))
+	      (let ([slide (car l)])
+		(let ([xs (/ config:use-screen-w config:screen-w)]
+		      [ys (/ config:use-screen-h config:screen-h)])
+		  (send ps-dc set-scale xs ys)
+		  ((sliderec-drawer slide) ps-dc 
+		   (+ margin (/ (- config:actual-screen-w config:use-screen-w) 2 xs))
+		   (+ margin (/ (- config:actual-screen-h config:use-screen-h) 2 ys))))
+		(when show-page-numbers?
+		  (send ps-dc set-scale 1 1)
+		  (let ([s (slide-page-string slide)])
+		    (let-values ([(w h) (send ps-dc get-size)]
+				 [(sw sh sd sa) (send ps-dc get-text-extent s)]
+				 [(hm vm) (values margin margin)])
+		      (send ps-dc draw-text s (- w hm sw) (- h vm sh))))))
+	      (send ps-dc end-page)
+	      (loop #t (cdr l) (add1 n))))
+	  (parameterize ([current-security-guard original-security-guard])
+	    (send ps-dc end-doc))
+	  (exit)))
+
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;                Progress for Print             ;;
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+      (define-values (progress-window progress-display)
+	(if config:printing?
+	    (parameterize ([current-eventspace (make-eventspace)])
+	      (let* ([f (make-object (class frame% 
+				       (define/augment (on-close) (exit))
+				       (super-instantiate ()))
+				     "Progress")]
+		     [h (instantiate horizontal-panel% (f)
+				     (stretchable-width #f)
+				     (stretchable-height #f))])
+		(make-object message% "Building slide: " h)
+		(let ([d (make-object message% "0000" h)])
+		  (send d set-label "1")
+		  (send f center)
+		  (send f show #t)
+		  (values f d))))
+	    (values #f #f)))
+
+      (define (viewer:done-making-slides)
+	(when config:printing?
+	  (do-print)))
+
+      (let ([eh (current-exception-handler)])
+	(current-exception-handler
+	 (lambda (exn)
+	   (send f show #f)
+	   (when f-both
+	     (send f-both show #f))
+	   (when background-f
+	     (send background-f show #f))
+	   (eh exn)))))))
diff --git a/collects/srfi/.cvsignore b/collects/srfi/.cvsignore
new file mode 100644
index 0000000000..e3ca6473f7
--- /dev/null
+++ b/collects/srfi/.cvsignore
@@ -0,0 +1 @@
+compiled
diff --git a/collects/srfi/1.ss b/collects/srfi/1.ss
new file mode 100644
index 0000000000..4e98e4d862
--- /dev/null
+++ b/collects/srfi/1.ss
@@ -0,0 +1,17 @@
+;; module loader for SRFI-1
+(module |1| mzscheme
+  
+  (require (lib "list.ss" "srfi" "1"))
+  
+  (provide (all-from-except (lib "list.ss" "srfi" "1")
+		       s:append! s:reverse!
+		       s:map s:for-each
+		       s:member
+		       s:assoc)
+	   (rename s:append! append!)
+	   (rename s:reverse! reverse!)
+	   (rename s:map map)
+	   (rename s:for-each for-each)
+	   (rename s:member member)
+	   (rename s:assoc assoc)))
+			    
diff --git a/collects/srfi/1/.cvsignore b/collects/srfi/1/.cvsignore
new file mode 100644
index 0000000000..e3ca6473f7
--- /dev/null
+++ b/collects/srfi/1/.cvsignore
@@ -0,0 +1 @@
+compiled
diff --git a/collects/srfi/1/alist.ss b/collects/srfi/1/alist.ss
new file mode 100644
index 0000000000..8873f3da3b
--- /dev/null
+++ b/collects/srfi/1/alist.ss
@@ -0,0 +1,75 @@
+;;;
+;;; <alist.ss> ---- Association list functions
+;;; Time-stamp: <02/03/01 13:56:33 noel>
+;;;
+;;; Copyright (C) 2002 by Noel Welsh. 
+;;;
+;;; This file is part of SRFI-1.
+
+;;; SRFI-1 is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2.1 of the License, or (at your option) any later version.
+
+;;; SRFI-1 is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with SRFI-1; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307  USA
+
+;;; Author: Noel Welsh <noelwelsh@yahoo.com>
+;;
+;;
+;; Commentary:
+
+;; Based on the reference implementation by Olin Shiver and hence:
+
+;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with
+;; this code as long as you do not remove this copyright notice or
+;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.
+;;     -Olin
+
+(module alist
+  mzscheme
+
+  (require (lib "etc.ss" "mzlib")
+		   (lib "optional.ss" "srfi")
+		   (rename "search.ss" find find)
+		   "filter.ss"
+		   (rename "fold.ss" s:map map))
+
+  (provide (rename my-assoc assoc)
+		   alist-cons
+		   alist-copy
+		   alist-delete
+		   alist-delete!)
+
+  
+  ;; Extended from R4RS to take an optional comparison argument.
+  (define my-assoc
+	(opt-lambda (x lis (maybe-= equal?))
+	  (let ((= maybe-=))
+		(find (lambda (entry) (= x (car entry))) lis))))
+
+  (define (alist-cons key datum alist) (cons (cons key datum) alist))
+
+  (define (alist-copy alist)
+	(s:map (lambda (elt) (cons (car elt) (cdr elt)))
+		   alist))
+
+  (define alist-delete
+	(opt-lambda (key alist (maybe-= equal?))
+	  (let ((= maybe-=))
+		(filter (lambda (elt) (not (= key (car elt)))) alist))))
+
+  (define alist-delete!
+	(opt-lambda (key alist (maybe-= equal?))
+	  (let ((= maybe-=))
+		(filter! (lambda (elt) (not (= key (car elt)))) alist))))
+
+  )
+
+;;; alist.ss ends here
\ No newline at end of file
diff --git a/collects/srfi/1/cons.ss b/collects/srfi/1/cons.ss
new file mode 100644
index 0000000000..a16bc4684c
--- /dev/null
+++ b/collects/srfi/1/cons.ss
@@ -0,0 +1,113 @@
+;;;
+;;; <cons.ss> ---- List constructors
+;;; Time-stamp: <02/02/27 12:19:59 noel>
+;;;
+;;; Copyright (C) 2002 by Noel Welsh. 
+;;;
+;;; This file is part of SRFI-1.
+
+;;; SRFI-1 is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2.1 of the License, or (at your option) any later version.
+
+;;; SRFI-1 is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with SRFI-1; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307  USA
+
+;;; Author: Noel Welsh <noelwelsh@yahoo.com>
+;;
+;;
+;; Commentary:
+
+;; Based on the reference implementation by Olin Shiver and hence:
+
+;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with
+;; this code as long as you do not remove this copyright notice or
+;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.
+;;     -Olin
+
+(module cons
+  mzscheme
+
+  (require (lib "etc.ss" "mzlib")
+		   (lib "optional.ss" "srfi")
+		   "selector.ss")
+
+  (provide xcons 
+		   make-list
+		   list-tabulate
+		   cons*
+		   list-copy
+		   circular-list
+		   iota)
+
+  ;; Occasionally useful as a value to be passed to a fold or other
+  ;; higher-order procedure.
+  (define (xcons d a) (cons a d))
+
+
+  ;; Make a list of length LEN.
+  
+  (define make-list
+	(opt-lambda (len  [elt #f])
+	  (check-arg (lambda (n) (and (integer? n) (>= n 0))) len 'make-list)
+	  (do ((i len (- i 1))
+		   (ans '() (cons elt ans)))
+		  ((<= i 0) ans))))
+  
+
+  ;; Make a list of length LEN. Elt i is (PROC i) for 0 <= i < LEN.
+  
+  (define (list-tabulate len proc)
+	(check-arg (lambda (n) (and (integer? n) (>= n 0))) len 'list-tabulate)
+	(check-arg procedure? proc 'list-tabulate)
+	(do ((i (- len 1) (- i 1))
+		 (ans '() (cons (proc i) ans)))
+		((< i 0) ans)))
+  
+  ;; (cons* a1 a2 ... an) = (cons a1 (cons a2 (cons ... an)))
+  ;; (cons* a1) = a1	(cons* a1 a2 ...) = (cons a1 (cons* a2 ...))
+  ;;
+  ;; (cons first (unfold not-pair? car cdr rest values))
+
+  (define (cons* first . rest)
+	(let recur ((x first) (rest rest))
+	  (if (pair? rest)
+		  (cons x (recur (car rest) (cdr rest)))
+		  x)))
+  
+
+  (define (list-copy lis)				
+	(let recur ((lis lis))			
+	  (if (pair? lis)				
+				(cons (car lis) (recur (cdr lis)))	
+				lis)))					
+  
+  (define (circular-list val1 . vals)
+	(let ((ans (cons val1 vals)))
+	  (set-cdr! (last-pair ans) ans)
+	  ans))
+
+
+  ;; IOTA count [start step]	(start start+step ... start+(count-1)*step)
+  
+  (define iota
+	(opt-lambda (count [start 0] [step 1])
+	  (check-arg integer? count 'iota)
+	  (check-arg number? start 'iota)
+	  (check-arg number? step 'iota)
+	  (let ((last-val (+ start (* (- count 1) step))))
+		(do ((count count (- count 1))
+			 (val last-val (- val step))
+			 (ans '() (cons val ans)))
+			((<= count 0)  ans)))))
+
+  )
+
+;;; cons.ss ends here
\ No newline at end of file
diff --git a/collects/srfi/1/delete.ss b/collects/srfi/1/delete.ss
new file mode 100644
index 0000000000..a826a8f23c
--- /dev/null
+++ b/collects/srfi/1/delete.ss
@@ -0,0 +1,93 @@
+;;;
+;;; <delete.ss> ---- List deletion functions
+;;; Time-stamp: <02/03/01 07:26:12 noel>
+;;;
+;;; Copyright (C) 2002 by Noel Welsh. 
+;;;
+;;; This file is part of SRFI-1.
+
+;;; SRFI-1 is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2.1 of the License, or (at your option) any later version.
+
+;;; SRFI-1 is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with SRFI-1; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307  USA
+
+;;; Author: Noel Welsh <noelwelsh@yahoo.com>
+;;
+;;
+;; Commentary:
+
+
+;; Based on the reference implementation by Olin Shiver and hence:
+
+;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with
+;; this code as long as you do not remove this copyright notice or
+;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.
+;;     -Olin
+
+(module delete
+  mzscheme
+
+  (require (lib "etc.ss" "mzlib")
+		   (lib "optional.ss" "srfi")
+		   "predicate.ss"
+		   "filter.ss")
+
+  (provide delete
+		   delete!
+		   delete-duplicates
+		   delete-duplicates!)
+
+  (define delete
+	(opt-lambda (x lis (maybe-= equal?))
+				(let ((= maybe-=))
+				  (filter (lambda (y) (not (= x y))) lis))))
+
+  (define delete!
+	(opt-lambda (x lis  (maybe-= equal?))
+				(let ((= maybe-=))
+				  (filter! (lambda (y) (not (= x y))) lis))))
+
+  ;; right-duplicate deletion
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; delete-duplicates delete-duplicates!
+  ;;
+  ;; Beware -- these are N^2 algorithms. To efficiently remove duplicates
+  ;; in long lists, sort the list to bring duplicates together, then use a 
+  ;; linear-time algorithm to kill the dups. Or use an algorithm based on
+  ;; element-marking. The former gives you O(n lg n), the latter is linear.
+
+  (define delete-duplicates
+	(opt-lambda (lis (maybe-= equal?))
+				(let ((elt= maybe-=))
+				  (check-arg procedure? elt= 'delete-duplicates)
+				  (let recur ((lis lis))
+					(if (null-list? lis) lis
+						(let* ((x (car lis))
+							   (tail (cdr lis))
+							   (new-tail (recur (delete x tail elt=))))
+						  (if (eq? tail new-tail) lis (cons x new-tail))))))))
+
+  (define delete-duplicates!
+	(opt-lambda (lis (maybe-= equal?))
+				(let ((elt= maybe-=))
+				  (check-arg procedure? elt= 'delete-duplicates!)
+				  (let recur ((lis lis))
+					(if (null-list? lis) lis
+						(let* ((x (car lis))
+							   (tail (cdr lis))
+							   (new-tail (recur (delete! x tail elt=))))
+						  (if (eq? tail new-tail) lis (cons x new-tail))))))))
+
+  )
+
+
+;;; delete.ss ends here
\ No newline at end of file
diff --git a/collects/srfi/1/filter.ss b/collects/srfi/1/filter.ss
new file mode 100644
index 0000000000..89a62e4f67
--- /dev/null
+++ b/collects/srfi/1/filter.ss
@@ -0,0 +1,190 @@
+;;;
+;;; <filter.ss> ---- List filtering and partitioning functions
+;;; Time-stamp: <02/03/01 07:26:43 noel>
+;;;
+;;; Copyright (C) 2002 by Noel Welsh. 
+;;;
+;;; This file is part of SRFI-1.
+
+;;; SRFI-1 is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2.1 of the License, or (at your option) any later version.
+
+;;; SRFI-1 is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with SRFI-1; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307  USA
+
+;;; Author: Noel Welsh <noelwelsh@yahoo.com>
+;;
+;;
+;; Commentary:
+
+;; Based on the reference implementation by Olin Shiver and hence:
+
+;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with
+;; this code as long as you do not remove this copyright notice or
+;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.
+;;     -Olin
+
+(module filter
+  mzscheme
+
+  (require (lib "etc.ss" "mzlib")
+		   (lib "optional.ss" "srfi")
+		   "predicate.ss")
+  (require (lib "receive.ss" "srfi" "8"))
+
+  (provide filter
+		   partition
+		   remove
+		   filter!
+		   partition!
+		   remove!)
+
+
+  ;; filter, remove, partition
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; FILTER, REMOVE, PARTITION and their destructive counterparts do not
+  ;; disorder the elements of their argument.
+
+  ;; This FILTER shares the longest tail of L that has no deleted
+  ;; elements.  If Scheme had multi-continuation calls, they could be
+  ;; made more efficient.
+
+  (define (filter pred lis)			; Sleazing with EQ? makes this
+	(check-arg procedure? pred 'filter)		; one faster.
+	(let recur ((lis lis))		
+	  (if (null-list? lis) lis			; Use NOT-PAIR? to handle dotted lists.
+		  (let ((head (car lis))
+				(tail (cdr lis)))
+			(if (pred head)
+				(let ((new-tail (recur tail)))	; Replicate the RECUR call so
+				  (if (eq? tail new-tail) lis
+					  (cons head new-tail)))
+				(recur tail))))))			; this one can be a tail call.
+
+
+
+
+
+  ;; This implementation of FILTER!
+  ;; - doesn't cons, and uses no stack;
+  ;; - is careful not to do redundant SET-CDR! writes, as writes to memory are 
+  ;;   usually expensive on modern machines, and can be extremely expensive on 
+  ;;   modern Schemes (e.g., ones that have generational GC's).
+  ;; It just zips down contiguous runs of in and out elts in LIS doing the 
+  ;; minimal number of SET-CDR!s to splice the tail of one run of ins to the 
+  ;; beginning of the next.
+  (define (filter! pred lis)
+	(check-arg procedure? pred 'filter!)
+	(let lp ((ans lis))
+	  (cond ((null-list? ans)       ans) ; Scan looking for
+			((not (pred (car ans))) (lp (cdr ans)))	; first cons of result.
+			
+			;; ANS is the eventual answer.
+			;; SCAN-IN: (CDR PREV) = LIS and (CAR PREV) satisfies PRED.
+			;;          Scan over a contiguous segment of the list that
+			;;          satisfies PRED.
+			;; SCAN-OUT: (CAR PREV) satisfies PRED. Scan over a contiguous
+			;;           segment of the list that *doesn't* satisfy PRED.
+			;;           When the segment ends, patch in a link from PREV
+			;;           to the start of the next good segment, and jump to
+			;;           SCAN-IN.
+			(else 
+			 (letrec ((scan-in (lambda (prev lis)
+								 (if (pair? lis)
+									 (if (pred (car lis))
+										 (scan-in lis (cdr lis))
+										 (scan-out prev (cdr lis))))))
+					  (scan-out (lambda (prev lis)
+								  (let lp ((lis lis))
+									(if (pair? lis)
+										(if (pred (car lis))
+											(begin (set-cdr! prev lis)
+												   (scan-in lis (cdr lis)))
+											(lp (cdr lis)))
+										(set-cdr! prev lis))))))
+			   (scan-in ans (cdr ans))
+			   ans)))))
+
+
+
+  ;; Answers share common tail with LIS where possible; 
+  ;; the technique is slightly subtle.
+  (define (partition pred lis)
+	(check-arg procedure? pred 'partition)
+	(let recur ((lis lis))
+	  (if (null-list? lis) (values lis lis)	; Use NOT-PAIR? to handle dotted lists.
+		  (let ((elt (car lis))
+				(tail (cdr lis)))
+			(receive (in out) (recur tail)
+					 (if (pred elt)
+						 (values (if (pair? out) (cons elt in) lis) out)
+						 (values in (if (pair? in) (cons elt out) lis))))))))
+
+
+
+  ;; This implementation of PARTITION!
+  ;; - doesn't cons, and uses no stack;
+  ;; - is careful not to do redundant SET-CDR! writes, as writes to memory are
+  ;;   usually expensive on modern machines, and can be extremely expensive on 
+  ;;   modern Schemes (e.g., ones that have generational GC's).
+  ;; It just zips down contiguous runs of in and out elts in LIS doing the
+  ;; minimal number of SET-CDR!s to splice these runs together into the result 
+  ;; lists.
+  (define (partition! pred lis)
+	(check-arg procedure? pred 'partition!)
+	(if (null-list? lis) (values lis lis)
+		
+		;; This pair of loops zips down contiguous in & out runs of the
+		;; list, splicing the runs together. The invariants are
+		;;   SCAN-IN:  (cdr in-prev)  = LIS.
+		;;   SCAN-OUT: (cdr out-prev) = LIS.
+		(letrec ((scan-in (lambda (in-prev out-prev lis)
+							(let lp ((in-prev in-prev) (lis lis))
+							  (if (pair? lis)
+								  (if (pred (car lis))
+									  (lp lis (cdr lis))
+									  (begin (set-cdr! out-prev lis)
+											 (scan-out in-prev lis (cdr lis))))
+								  (set-cdr! out-prev lis))))) ; Done.
+
+				 (scan-out (lambda (in-prev out-prev lis)
+							 (let lp ((out-prev out-prev) (lis lis))
+							   (if (pair? lis)
+								   (if (pred (car lis))
+									   (begin (set-cdr! in-prev lis)
+											  (scan-in lis out-prev (cdr lis)))
+									   (lp lis (cdr lis)))
+								   (set-cdr! in-prev lis)))))) ; Done.
+
+		  ;; Crank up the scan&splice loops.
+		  (if (pred (car lis))
+			  ;; LIS begins in-list. Search for out-list's first pair.
+			  (let lp ((prev-l lis) (l (cdr lis)))
+				(cond ((not (pair? l)) (values lis l))
+					  ((pred (car l)) (lp l (cdr l)))
+					  (else (scan-out prev-l l (cdr l))
+							(values lis l)))) ; Done.
+
+			  ;; LIS begins out-list. Search for in-list's first pair.
+			  (let lp ((prev-l lis) (l (cdr lis)))
+				(cond ((not (pair? l)) (values l lis))
+					  ((pred (car l))
+					   (scan-in l prev-l (cdr l))
+					   (values l lis))	; Done.
+					  (else (lp l (cdr l)))))))))
+
+
+  ;; Inline us, please.
+  (define (remove  pred l) (filter  (lambda (x) (not (pred x))) l))
+  (define (remove! pred l) (filter! (lambda (x) (not (pred x))) l))
+
+  )  
+;;; filter.ss ends here
\ No newline at end of file
diff --git a/collects/srfi/1/fold.ss b/collects/srfi/1/fold.ss
new file mode 100644
index 0000000000..1fc96d54e4
--- /dev/null
+++ b/collects/srfi/1/fold.ss
@@ -0,0 +1,289 @@
+;;;
+;;; <fold.ss> ---- List folds
+;;; Time-stamp: <02/02/28 12:02:38 noel>
+;;;
+;;; Copyright (C) 2002 by Noel Welsh. 
+;;;
+;;; This file is part of SRFI-1.
+
+;;; SRFI-1 is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2.1 of the License, or (at your option) any later version.
+
+;;; SRFI-1 is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with SRFI-1; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307  USA
+
+;;; Author: Noel Welsh <noelwelsh@yahoo.com>
+;;
+;;
+;; Commentary:
+
+;; Based on the reference implementation by Olin Shiver and hence:
+
+;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with
+;; this code as long as you do not remove this copyright notice or
+;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.
+;;     -Olin
+
+(module fold
+  mzscheme
+
+  (require (lib "optional.ss" "srfi")
+		   "predicate.ss"
+		   "selector.ss"
+		   "util.ss")
+  (require (lib "receive.ss" "srfi" "8"))
+
+  (provide (rename my-map map)
+	   (rename my-for-each for-each)
+	   fold
+	   unfold
+	   pair-fold
+	   reduce
+	   fold-right
+	   unfold-right
+	   pair-fold-right
+	   reduce-right
+	   append-map
+	   append-map!
+	   map!
+	   pair-for-each
+	   filter-map
+	   map-in-order)
+
+  
+  ;; fold/unfold
+  ;;;;;;;;;;;;;;
+  
+  (define (unfold-right p f g seed . maybe-tail)
+	(check-arg procedure? p 'unfold-right)
+	(check-arg procedure? f 'unfold-right)
+	(check-arg procedure? g 'unfold-right)
+	(let lp ((seed seed) (ans maybe-tail))
+	  (if (p seed) ans
+		  (lp (g seed)
+			  (cons (f seed) ans)))))
+  
+  
+  (define (unfold p f g seed . maybe-tail-gen)
+	(check-arg procedure? p 'unfold)
+	(check-arg procedure? f 'unfold)
+	(check-arg procedure? g 'unfold)
+	(if (pair? maybe-tail-gen)
+		
+		(let ((tail-gen (car maybe-tail-gen)))
+		  (if (pair? (cdr maybe-tail-gen))
+			  (apply error "Too many arguments" unfold p f g seed maybe-tail-gen)
+			  
+			  (let recur ((seed seed))
+				(if (p seed) (tail-gen seed)
+					(cons (f seed) (recur (g seed)))))))
+		
+		(let recur ((seed seed))
+		  (if (p seed) '()
+			  (cons (f seed) (recur (g seed)))))))
+  
+  
+  (define (fold kons knil lis1 . lists)
+	(check-arg procedure? kons 'fold)
+	(if (pair? lists)
+		(let lp ((lists (cons lis1 lists)) (ans knil))	; N-ary case
+		  (receive (cars+ans cdrs) (%cars+cdrs+ lists ans)
+				   (if (null? cars+ans) ans ; Done.
+					   (lp cdrs (apply kons cars+ans)))))
+	    
+		(let lp ((lis lis1) (ans knil))			; Fast path
+		  (if (null-list? lis) ans
+			  (lp (cdr lis) (kons (car lis) ans))))))
+  
+  
+  (define (fold-right kons knil lis1 . lists)
+	(check-arg procedure? kons 'fold-right)
+	(if (pair? lists)
+		(let recur ((lists (cons lis1 lists)))		; N-ary case
+		  (let ((cdrs (%cdrs lists)))
+			(if (null? cdrs) knil
+				(apply kons (%cars+ lists (recur cdrs))))))
+		
+		(let recur ((lis lis1))				; Fast path
+		  (if (null-list? lis) knil
+			  (let ((head (car lis)))
+				(kons head (recur (cdr lis))))))))
+  
+  
+  (define (pair-fold-right f zero lis1 . lists)
+	(check-arg procedure? f 'pair-fold-right)
+	(if (pair? lists)
+		(let recur ((lists (cons lis1 lists)))		; N-ary case
+		  (let ((cdrs (%cdrs lists)))
+			(if (null? cdrs) zero
+				(apply f (append! lists (list (recur cdrs)))))))
+		
+		(let recur ((lis lis1))				; Fast path
+		  (if (null-list? lis) zero (f lis (recur (cdr lis)))))))
+  
+  (define (pair-fold f zero lis1 . lists)
+	(check-arg procedure? f 'pair-fold)
+	(if (pair? lists)
+		(let lp ((lists (cons lis1 lists)) (ans zero))	; N-ary case
+		  (let ((tails (%cdrs lists)))
+			(if (null? tails) ans
+				(lp tails (apply f (append! lists (list ans)))))))
+		
+		(let lp ((lis lis1) (ans zero))
+		  (if (null-list? lis) ans
+			  (let ((tail (cdr lis)))		; Grab the cdr now,
+				(lp tail (f lis ans)))))))	; in case F SET-CDR!s LIS.
+  
+  
+  ;; REDUCE and REDUCE-RIGHT only use RIDENTITY in the empty-list case.
+  ;; These cannot meaningfully be n-ary.
+  
+  (define (reduce f ridentity lis)
+	(check-arg procedure? f 'reduce)
+	(if (null-list? lis) ridentity
+		(fold f (car lis) (cdr lis))))
+  
+  (define (reduce-right f ridentity lis)
+	(check-arg procedure? f 'reduce-right)
+	(if (null-list? lis) ridentity
+		(let recur ((head (car lis)) (lis (cdr lis)))
+		  (if (pair? lis)
+			  (f head (recur (car lis) (cdr lis)))
+			  head))))
+  
+  
+  
+  ;; Mappers: append-map append-map! pair-for-each map! filter-map map-in-order
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  
+  (define (append-map f lis1 . lists)
+	(really-append-map append-map  append  f lis1 lists))
+  (define (append-map! f lis1 . lists) 
+	(really-append-map append-map! append! f lis1 lists))
+  
+  (define (really-append-map who appender f lis1 lists)
+	(check-arg procedure? f 'who)
+	(if (pair? lists)
+		(receive (cars cdrs) (%cars+cdrs (cons lis1 lists))
+				 (if (null? cars) '()
+					 (let recur ((cars cars) (cdrs cdrs))
+					   (let ((vals (apply f cars)))
+						 (receive (cars2 cdrs2) (%cars+cdrs cdrs)
+								  (if (null? cars2) vals
+									  (appender vals (recur cars2 cdrs2))))))))
+		
+		;; Fast path
+		(if (null-list? lis1) '()
+			(let recur ((elt (car lis1)) (rest (cdr lis1)))
+			  (let ((vals (f elt)))
+				(if (null-list? rest) vals
+					(appender vals (recur (car rest) (cdr rest)))))))))
+  
+  
+  (define (pair-for-each proc lis1 . lists)
+	(check-arg procedure? proc 'pair-for-each)
+	(if (pair? lists)
+		
+		(let lp ((lists (cons lis1 lists)))
+		  (let ((tails (%cdrs lists)))
+			(if (pair? tails)
+				(begin (apply proc lists)
+					   (lp tails)))))
+		
+		;; Fast path.
+		(let lp ((lis lis1))
+		  (if (not (null-list? lis))
+			  (let ((tail (cdr lis)))	; Grab the cdr now,
+				(proc lis)		; in case PROC SET-CDR!s LIS.
+				(lp tail))))))
+  
+  ;; We stop when LIS1 runs out, not when any list runs out.
+  (define (map! f lis1 . lists)
+	(check-arg procedure? f 'map!)
+	(if (pair? lists)
+		(let lp ((lis1 lis1) (lists lists))
+		  (if (not (null-list? lis1))
+			  (receive (heads tails) (%cars+cdrs/no-test lists)
+					   (set-car! lis1 (apply f (car lis1) heads))
+					   (lp (cdr lis1) tails))))
+		
+		;; Fast path.
+		(pair-for-each (lambda (pair) (set-car! pair (f (car pair)))) lis1))
+	lis1)
+  
+  
+  ;; Map F across L, and save up all the non-false results.
+  (define (filter-map f lis1 . lists)
+	(check-arg procedure? f 'filter-map)
+	(if (pair? lists)
+		(let recur ((lists (cons lis1 lists)))
+		  (receive (cars cdrs) (%cars+cdrs lists)
+				   (if (pair? cars)
+					   (cond ((apply f cars) => (lambda (x) (cons x (recur cdrs))))
+							 (else (recur cdrs))) ; Tail call in this arm.
+					   '())))
+	    
+		;; Fast path.
+		(let recur ((lis lis1))
+		  (if (null-list? lis) lis
+			  (let ((tail (recur (cdr lis))))
+				(cond ((f (car lis)) => (lambda (x) (cons x tail)))
+					  (else tail)))))))
+  
+  
+  ;; Map F across lists, guaranteeing to go left-to-right.
+  ;; NOTE: Some implementations of R5RS MAP are compliant with this spec;
+  ;; in which case this procedure may simply be defined as a synonym for MAP.
+  
+  (define (map-in-order f lis1 . lists)
+	(check-arg procedure? f 'map-in-order)
+	(if (pair? lists)
+		(let recur ((lists (cons lis1 lists)))
+		  (receive (cars cdrs) (%cars+cdrs lists)
+				   (if (pair? cars)
+					   (let ((x (apply f cars)))		; Do head first,
+						 (cons x (recur cdrs)))		; then tail.
+					   '())))
+	    
+		;; Fast path.
+		(let recur ((lis lis1))
+		  (if (null-list? lis) lis
+			  (let ((tail (cdr lis))
+					(x (f (car lis))))		; Do head first,
+				(cons x (recur tail)))))))	; then tail.
+  
+  
+  ;; We extend MAP to handle arguments of unequal length.
+  (define my-map map-in-order)	
+  
+
+;;; Apply F across lists, guaranteeing to go left-to-right.
+;;; NOTE: Some implementations of R5RS MAP are compliant with this spec;
+;;; in which case this procedure may simply be defined as a synonym for FOR-EACH.
+
+  (define (my-for-each f lis1 . lists)
+    (check-arg procedure? f for-each)
+    (if (pair? lists)
+	(let recur ((lists (cons lis1 lists)))
+	  (receive (cars cdrs) (%cars+cdrs lists)
+	    (if (pair? cars)
+		(begin
+		  (apply f cars)	; Do head first,
+		  (recur cdrs)))))	; then tail.
+	    
+	;; Fast path.
+	(let recur ((lis lis1))
+	  (if (not (null-list? lis))
+	      (begin
+		(f (car lis))		; Do head first,
+		(recur (cdr lis)))))))
+  )
+;;; fold.ss ends here
\ No newline at end of file
diff --git a/collects/srfi/1/info.ss b/collects/srfi/1/info.ss
new file mode 100644
index 0000000000..1ae522d588
--- /dev/null
+++ b/collects/srfi/1/info.ss
@@ -0,0 +1,16 @@
+(module info (lib "infotab.ss" "setup")
+
+  (define name "SRFI 1")
+
+  (define compile-omit-files
+    '("alist-test.ss"
+      "all-srfi-1-tests.ss"
+      "cons-test.ss"
+      "delete-test.ss"
+      "filter-test.ss"
+      "fold-test.ss"
+      "lset-test.ss"
+      "misc-test.ss"
+      "predicate-test.ss"
+      "search-test.ss"
+      "selector-test.ss")))
diff --git a/collects/srfi/1/list.ss b/collects/srfi/1/list.ss
new file mode 100644
index 0000000000..17143e3171
--- /dev/null
+++ b/collects/srfi/1/list.ss
@@ -0,0 +1,252 @@
+;;; SRFI-1 list-processing library 			-*- Scheme -*-
+;;; Reference implementation
+;;;
+;;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with
+;;; this code as long as you do not remove this copyright notice or
+;;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.
+;;;     -Olin
+
+;;; This is a library of list- and pair-processing functions. I wrote it after
+;;; carefully considering the functions provided by the libraries found in
+;;; R4RS/R5RS Scheme, MIT Scheme, Gambit, RScheme, MzScheme, slib, Common
+;;; Lisp, Bigloo, guile, T, APL and the SML standard basis. It is a pretty
+;;; rich toolkit, providing a superset of the functionality found in any of
+;;; the various Schemes I considered.
+
+;;; This implementation is intended as a portable reference implementation
+;;; for SRFI-1. See the porting notes below for more information.
+
+;;; Exported:
+;;; xcons tree-copy make-list list-tabulate cons* list-copy 
+;;; proper-list? circular-list? dotted-list? not-pair? null-list? list=
+;;; circular-list length+
+;;; iota
+;;; first second third fourth fifth sixth seventh eighth ninth tenth
+;;; car+cdr
+;;; take       drop       
+;;; take-right drop-right 
+;;; take!      drop-right!
+;;; split-at   split-at!
+;;; last last-pair
+;;; zip unzip1 unzip2 unzip3 unzip4 unzip5
+;;; count
+;;; append! append-reverse append-reverse! concatenate concatenate! 
+;;; unfold       fold       pair-fold       reduce
+;;; unfold-right fold-right pair-fold-right reduce-right
+;;; append-map append-map! map! pair-for-each filter-map map-in-order
+;;; filter  partition  remove
+;;; filter! partition! remove! 
+;;; find find-tail any every list-index
+;;; take-while drop-while take-while!
+;;; span break span! break!
+;;; delete delete!
+;;; alist-cons alist-copy
+;;; delete-duplicates delete-duplicates!
+;;; alist-delete alist-delete!
+;;; reverse! 
+;;; lset<= lset= lset-adjoin  
+;;; lset-union  lset-intersection  lset-difference  lset-xor  lset-diff+intersection
+;;; lset-union! lset-intersection! lset-difference! lset-xor! lset-diff+intersection!
+;;; 
+;;; In principle, the following R4RS list- and pair-processing procedures
+;;; are also part of this package's exports, although they are not defined
+;;; in this file:
+;;;   Primitives: cons pair? null? car cdr set-car! set-cdr!
+;;;   Non-primitives: list length append reverse cadr ... cddddr list-ref
+;;;                   memq memv assq assv
+;;;   (The non-primitives are defined in this file, but commented out.)
+;;;
+;;; These R4RS procedures have extended definitions in SRFI-1 and are defined
+;;; in this file:
+;;;   map for-each member assoc
+;;;
+;;; The remaining two R4RS list-processing procedures are not included: 
+;;;   list-tail (use drop)
+;;;   list? (use proper-list?)
+
+
+;;; A note on recursion and iteration/reversal:
+;;; Many iterative list-processing algorithms naturally compute the elements
+;;; of the answer list in the wrong order (left-to-right or head-to-tail) from
+;;; the order needed to cons them into the proper answer (right-to-left, or
+;;; tail-then-head). One style or idiom of programming these algorithms, then,
+;;; loops, consing up the elements in reverse order, then destructively 
+;;; reverses the list at the end of the loop. I do not do this. The natural
+;;; and efficient way to code these algorithms is recursively. This trades off
+;;; intermediate temporary list structure for intermediate temporary stack
+;;; structure. In a stack-based system, this improves cache locality and
+;;; lightens the load on the GC system. Don't stand on your head to iterate!
+;;; Recurse, where natural. Multiple-value returns make this even more
+;;; convenient, when the recursion/iteration has multiple state values.
+
+;;; Porting:
+;;; This is carefully tuned code; do not modify casually.
+;;;   - It is careful to share storage when possible;
+;;;   - Side-effecting code tries not to perform redundant writes.
+;;; 
+;;; That said, a port of this library to a specific Scheme system might wish
+;;; to tune this code to exploit particulars of the implementation. 
+;;; The single most important compiler-specific optimisation you could make
+;;; to this library would be to add rewrite rules or transforms to:
+;;; - transform applications of n-ary procedures (e.g. LIST=, CONS*, APPEND,
+;;;   LSET-UNION) into multiple applications of a primitive two-argument 
+;;;   variant.
+;;; - transform applications of the mapping functions (MAP, FOR-EACH, FOLD, 
+;;;   ANY, EVERY) into open-coded loops. The killer here is that these 
+;;;   functions are n-ary. Handling the general case is quite inefficient,
+;;;   requiring many intermediate data structures to be allocated and
+;;;   discarded.
+;;; - transform applications of procedures that take optional arguments
+;;;   into calls to variants that do not take optional arguments. This
+;;;   eliminates unnecessary consing and parsing of the rest parameter.
+;;;
+;;; These transforms would provide BIG speedups. In particular, the n-ary
+;;; mapping functions are particularly slow and cons-intensive, and are good
+;;; candidates for tuning. I have coded fast paths for the single-list cases,
+;;; but what you really want to do is exploit the fact that the compiler
+;;; usually knows how many arguments are being passed to a particular
+;;; application of these functions -- they are usually explicitly called, not
+;;; passed around as higher-order values. If you can arrange to have your
+;;; compiler produce custom code or custom linkages based on the number of
+;;; arguments in the call, you can speed these functions up a *lot*. But this
+;;; kind of compiler technology no longer exists in the Scheme world as far as
+;;; I can see.
+;;;
+;;; Note that this code is, of course, dependent upon standard bindings for
+;;; the R5RS procedures -- i.e., it assumes that the variable CAR is bound
+;;; to the procedure that takes the car of a list. If your Scheme 
+;;; implementation allows user code to alter the bindings of these procedures
+;;; in a manner that would be visible to these definitions, then there might
+;;; be trouble. You could consider horrible kludgery along the lines of
+;;;    (define fact 
+;;;      (let ((= =) (- -) (* *))
+;;;        (letrec ((real-fact (lambda (n) 
+;;;                              (if (= n 0) 1 (* n (real-fact (- n 1)))))))
+;;;          real-fact)))
+;;; Or you could consider shifting to a reasonable Scheme system that, say,
+;;; has a module system protecting code from this kind of lossage.
+;;;
+;;; This code does a fair amount of run-time argument checking. If your
+;;; Scheme system has a sophisticated compiler that can eliminate redundant
+;;; error checks, this is no problem. However, if not, these checks incur
+;;; some performance overhead -- and, in a safe Scheme implementation, they
+;;; are in some sense redundant: if we don't check to see that the PROC 
+;;; parameter is a procedure, we'll find out anyway three lines later when
+;;; we try to call the value. It's pretty easy to rip all this argument 
+;;; checking code out if it's inappropriate for your implementation -- just
+;;; nuke every call to CHECK-ARG.
+;;;
+;;; On the other hand, if you *do* have a sophisticated compiler that will
+;;; actually perform soft-typing and eliminate redundant checks (Rice's systems
+;;; being the only possible candidate of which I'm aware), leaving these checks 
+;;; in can *help*, since their presence can be elided in redundant cases,
+;;; and in cases where they are needed, performing the checks early, at
+;;; procedure entry, can "lift" a check out of a loop. 
+;;;
+;;; Finally, I have only checked the properties that can portably be checked
+;;; with R5RS Scheme -- and this is not complete. You may wish to alter
+;;; the CHECK-ARG parameter checks to perform extra, implementation-specific
+;;; checks, such as procedure arity for higher-order values.
+;;;
+;;; The code has only these non-R4RS dependencies:
+;;;   A few calls to an ERROR procedure;
+;;;   Uses of the R5RS multiple-value procedure VALUES and the m-v binding
+;;;     RECEIVE macro (which isn't R5RS, but is a trivial macro).
+;;;   Many calls to a parameter-checking procedure check-arg:
+;;;    (define (check-arg pred val caller)
+;;;      (let lp ((val val))
+;;;        (if (pred val) val (lp (error "Bad argument" val pred caller)))))
+;;;   A few uses of the LET-OPTIONAL and :OPTIONAL macros for parsing
+;;;     optional arguments.
+;;;
+;;; Most of these procedures use the NULL-LIST? test to trigger the
+;;; base case in the inner loop or recursion. The NULL-LIST? function
+;;; is defined to be a careful one -- it raises an error if passed a
+;;; non-nil, non-pair value. The spec allows an implementation to use
+;;; a less-careful implementation that simply defines NULL-LIST? to
+;;; be NOT-PAIR?. This would speed up the inner loops of these procedures
+;;; at the expense of having them silently accept dotted lists.
+
+;;; A note on dotted lists:
+;;; I, personally, take the view that the only consistent view of lists
+;;; in Scheme is the view that *everything* is a list -- values such as
+;;; 3 or "foo" or 'bar are simply empty dotted lists. This is due to the
+;;; fact that Scheme actually has no true list type. It has a pair type,
+;;; and there is an *interpretation* of the trees built using this type
+;;; as lists.
+;;;
+;;; I lobbied to have these list-processing procedures hew to this
+;;; view, and accept any value as a list argument. I was overwhelmingly
+;;; overruled during the SRFI discussion phase. So I am inserting this
+;;; text in the reference lib and the SRFI spec as a sort of "minority
+;;; opinion" dissent.
+;;;
+;;; Many of the procedures in this library can be trivially redefined
+;;; to handle dotted lists, just by changing the NULL-LIST? base-case
+;;; check to NOT-PAIR?, meaning that any non-pair value is taken to be
+;;; an empty list. For most of these procedures, that's all that is
+;;; required.
+;;;
+;;; However, we have to do a little more work for some procedures that
+;;; *produce* lists from other lists.  Were we to extend these procedures to
+;;; accept dotted lists, we would have to define how they terminate the lists
+;;; produced as results when passed a dotted list. I designed a coherent set
+;;; of termination rules for these cases; this was posted to the SRFI-1
+;;; discussion list. I additionally wrote an earlier version of this library
+;;; that implemented that spec. It has been discarded during later phases of
+;;; the definition and implementation of this library.
+;;;
+;;; The argument *against* defining these procedures to work on dotted
+;;; lists is that dotted lists are the rare, odd case, and that by 
+;;; arranging for the procedures to handle them, we lose error checking
+;;; in the cases where a dotted list is passed by accident -- e.g., when
+;;; the programmer swaps a two arguments to a list-processing function,
+;;; one being a scalar and one being a list. For example,
+;;;     (member '(1 3 5 7 9) 7)
+;;; This would quietly return #f if we extended MEMBER to accept dotted
+;;; lists.
+;;;
+;;; The SRFI discussion record contains more discussion on this topic.
+
+;; JBC, 2003-10-20: some of the names provided by list.ss are prefixed
+;; with an s: to avoid colliding with mzscheme.  The wrapper 1.ss 
+;; changes their names back to the non-prefixed form. 
+
+(module list mzscheme
+
+  (require (lib "optional.ss" "srfi"))
+
+  (require "cons.ss"
+	   "selector.ss"
+	   "predicate.ss"
+	   (all-except "misc.ss" append! reverse!)
+	   (rename "misc.ss" s:append! append!)
+	   (rename "misc.ss" s:reverse! reverse!)
+	   (all-except "fold.ss" map for-each)
+	   (rename "fold.ss" s:map map)
+	   (rename "fold.ss" s:for-each for-each)
+	   (all-except "search.ss" member)
+	   (rename "search.ss" s:member member)
+	   "filter.ss"
+	   "delete.ss"
+	   (all-except "alist.ss" assoc)
+	   (rename "alist.ss" s:assoc assoc)
+	   "lset.ss")
+
+
+  (provide 
+   (all-from "cons.ss")
+   (all-from "selector.ss")
+   (all-from "predicate.ss")
+   (all-from "misc.ss")
+   (all-from "fold.ss")
+   (all-from "search.ss")
+   (all-from "filter.ss")
+   (all-from "delete.ss")
+   (all-from "alist.ss")
+   (all-from "lset.ss"))
+
+
+
+;;end of the unit
+)
\ No newline at end of file
diff --git a/collects/srfi/1/lset.ss b/collects/srfi/1/lset.ss
new file mode 100644
index 0000000000..794e74186e
--- /dev/null
+++ b/collects/srfi/1/lset.ss
@@ -0,0 +1,238 @@
+;;;
+;;; <lset.ss> ---- Lists as Sets
+;;; Time-stamp: <03/03/13 16:20:56 noel>
+;;;
+;;; Copyright (C) 2002 by Noel Welsh. 
+;;;
+;;; This file is part of SRFI-1.
+
+;;; SRFI-1 is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2.1 of the License, or (at your option) any later version.
+
+;;; SRFI-1 is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with SRFI-1; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307  USA
+
+;;; Author: Noel Welsh <noelwelsh@yahoo.com>
+;;
+;;
+;; Commentary:
+
+;; Based on the reference implementation by Olin Shiver and hence:
+
+;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with
+;; this code as long as you do not remove this copyright notice or
+;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.
+;;     -Olin
+
+(module lset
+  mzscheme
+
+  (require (lib "optional.ss" "srfi")
+		   (all-except "search.ss" member)
+		   (all-except "fold.ss" map for-each)
+		   (rename "search.ss" s:member member)
+		   "delete.ss"
+		   "predicate.ss"
+		   "filter.ss")
+  (require (lib "receive.ss" "srfi" "8"))
+
+  (provide lset<=
+		   lset=
+		   lset-adjoin
+		   lset-union
+		   lset-union!
+		   lset-intersection
+		   lset-difference
+		   lset-difference!
+		   lset-xor
+		   lset-xor!
+		   lset-diff+intersection
+		   lset-diff+intersection!)
+
+  ;; Lists-as-sets
+  ;;;;;;;;;;;;;;;;;
+
+  ;; This is carefully tuned code; do not modify casually.
+  ;; - It is careful to share storage when possible;
+  ;; - Side-effecting code tries not to perform redundant writes.
+  ;; - It tries to avoid linear-time scans in special cases where constant-time
+  ;;   computations can be performed.
+  ;; - It relies on similar properties from the other list-lib procs it calls.
+  ;;   For example, it uses the fact that the implementations of MEMBER and
+  ;;   FILTER in this source code share longest common tails between args
+  ;;   and results to get structure sharing in the lset procedures.
+  
+  (define (%lset2<= = lis1 lis2) (every (lambda (x) (s:member x lis2 =)) lis1))
+  
+  (define (lset<= = . lists)
+	(check-arg procedure? = 'lset<=)
+	(or (not (pair? lists)) ; 0-ary case
+		(let lp ((s1 (car lists)) (rest (cdr lists)))
+		  (or (not (pair? rest))
+			  (let ((s2 (car rest))  (rest (cdr rest)))
+				(and (or (eq? s2 s1)	; Fast path
+						 (%lset2<= = s1 s2)) ; Real test
+					 (lp s2 rest)))))))
+  
+  (define (lset= = . lists)
+	(check-arg procedure? = 'lset=)
+	(or (not (pair? lists)) ; 0-ary case
+		(let lp ((s1 (car lists)) (rest (cdr lists)))
+		  (or (not (pair? rest))
+			  (let ((s2   (car rest))
+					(rest (cdr rest)))
+				(and (or (eq? s1 s2)	; Fast path
+						 (and (%lset2<= = s1 s2) (%lset2<= = s2 s1))) ; Real test
+					 (lp s2 rest)))))))
+  
+  
+  (define (lset-adjoin = lis . elts)
+	(check-arg procedure? = 'lset-adjoin)
+	(fold (lambda (elt ans) (if (s:member elt ans =) ans (cons elt ans)))
+		  lis elts))
+  
+  
+  (define (lset-union = . lists)
+	(check-arg procedure? = 'lset-union)
+	(reduce (lambda (lis ans)	; Compute ANS + LIS.
+			  (cond ((null? lis) ans)	; Don't copy any lists
+					((null? ans) lis) 	; if we don't have to.
+					((eq? lis ans) ans)
+					(else
+					 (fold (lambda (elt ans) (if (any (lambda (x) (= x elt)) ans)
+												 ans
+												 (cons elt ans)))
+						   ans lis))))
+			'() lists))
+  
+  (define (lset-union! = . lists)
+	(check-arg procedure? = 'lset-union!)
+	(reduce (lambda (lis ans)	; Splice new elts of LIS onto the front of ANS.
+			  (cond ((null? lis) ans)	; Don't copy any lists
+					((null? ans) lis) 	; if we don't have to.
+					((eq? lis ans) ans)
+					(else
+					 (pair-fold (lambda (pair ans)
+								  (let ((elt (car pair)))
+									(if (any (lambda (x) (= x elt)) ans)
+										ans
+										(begin (set-cdr! pair ans) pair))))
+								ans lis))))
+			'() lists))
+  
+  
+  (define (lset-intersection = lis1 . lists)
+	(check-arg procedure? = 'lset-intersection)
+	(let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals.
+	  (cond ((any null-list? lists) '())		; Short cut
+			((null? lists)          lis1)		; Short cut
+			(else (filter (lambda (x)
+							(every (lambda (lis) (s:member x lis =)) lists))
+						  lis1)))))
+  
+  (define (lset-intersection! = lis1 . lists)
+	(check-arg procedure? = 'lset-intersection!)
+	(let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals.
+	  (cond ((any null-list? lists) '())		; Short cut
+			((null? lists)          lis1)		; Short cut
+			(else (filter! (lambda (x)
+							 (every (lambda (lis) (s:member x lis =)) lists))
+						   lis1)))))
+  
+  
+  (define (lset-difference = lis1 . lists)
+	(check-arg procedure? = 'lset-difference)
+	(let ((lists (filter pair? lists)))	; Throw out empty lists.
+	  (cond ((null? lists)     lis1)	; Short cut
+			((memq lis1 lists) '())	; Short cut
+			(else (filter (lambda (x)
+							(every (lambda (lis) (not (s:member x lis =)))
+								   lists))
+						  lis1)))))
+  
+  (define (lset-difference! = lis1 . lists)
+	(check-arg procedure? = 'lset-difference!)
+	(let ((lists (filter pair? lists)))	; Throw out empty lists.
+	  (cond ((null? lists)     lis1)	; Short cut
+			((memq lis1 lists) '())	; Short cut
+			(else (filter! (lambda (x)
+							 (every (lambda (lis) (not (s:member x lis =)))
+									lists))
+						   lis1)))))
+  
+  
+  (define (lset-xor = . lists)
+	(check-arg procedure? = 'lset-xor)
+	(reduce (lambda (b a)			; Compute A xor B:
+			  ;; Note that this code relies on the constant-time
+			  ;; short-cuts provided by LSET-DIFF+INTERSECTION,
+			  ;; LSET-DIFFERENCE & APPEND to provide constant-time short
+			  ;; cuts for the cases A = (), B = (), and A eq? B. It takes
+			  ;; a careful case analysis to see it, but it's carefully
+			  ;; built in.
+			  
+			  ;; Compute a-b and a^b, then compute b-(a^b) and
+			  ;; cons it onto the front of a-b.
+			  (receive (a-b a-int-b)   (lset-diff+intersection = a b)
+					   (cond ((null? a-b)     (lset-difference = b a))
+							 ((null? a-int-b) (append b a))
+							 (else (fold (lambda (xb ans)
+										   (if (s:member xb a-int-b =) ans (cons xb ans)))
+										 a-b
+										 b)))))
+			'() lists))
+  
+  
+  (define (lset-xor! = . lists)
+	(check-arg procedure? = 'lset-xor!)
+	(reduce (lambda (b a)			; Compute A xor B:
+			  ;; Note that this code relies on the constant-time
+			  ;; short-cuts provided by LSET-DIFF+INTERSECTION,
+			  ;; LSET-DIFFERENCE & APPEND to provide constant-time short
+			  ;; cuts for the cases A = (), B = (), and A eq? B. It takes
+			  ;; a careful case analysis to see it, but it's carefully
+			  ;; built in.
+			  
+			  ;; Compute a-b and a^b, then compute b-(a^b) and
+			  ;; cons it onto the front of a-b.
+			  (receive (a-b a-int-b)   (lset-diff+intersection! = a b)
+					   (cond ((null? a-b)     (lset-difference! = b a))
+							 ((null? a-int-b) (append! b a))
+							 (else (pair-fold (lambda (b-pair ans)
+												(if (s:member (car b-pair) a-int-b =) ans
+													(begin (set-cdr! b-pair ans) b-pair)))
+											  a-b
+											  b)))))
+			'() lists))
+  
+  
+  (define (lset-diff+intersection = lis1 . lists)
+	(check-arg procedure? = 'lset-diff+intersection)
+	(cond ((every null-list? lists) (values lis1 '()))	; Short cut
+		  ((memq lis1 lists)        (values '() lis1))	; Short cut
+		  (else (partition (lambda (elt)
+							 (not (any (lambda (lis) (s:member elt lis =))
+									   lists)))
+						   lis1))))
+  
+  (define (lset-diff+intersection! = lis1 . lists)
+	(check-arg procedure? = 'lset-diff+intersection!)
+	(cond ((every null-list? lists) (values lis1 '()))	; Short cut
+		  ((memq lis1 lists)        (values '() lis1))	; Short cut
+		  (else (partition! (lambda (elt)
+							  (not (any (lambda (lis) (s:member elt lis =))
+										lists)))
+							lis1))))
+  
+  
+  )
+
+;;; lset.ss ends here
\ No newline at end of file
diff --git a/collects/srfi/1/misc.ss b/collects/srfi/1/misc.ss
new file mode 100644
index 0000000000..5e42d96557
--- /dev/null
+++ b/collects/srfi/1/misc.ss
@@ -0,0 +1,198 @@
+;;;
+;;; <misc.ss> ---- Miscellaneous list procedures
+;;; Time-stamp: <02/03/01 13:52:22 noel>
+;;;
+;;; Copyright (C) 2002 by Noel Welsh. 
+;;;
+;;; This file is part of SRFI-1.
+
+;;; SRFI-1 is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2.1 of the License, or (at your option) any later version.
+
+;;; SRFI-1 is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with SRFI-1; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307  USA
+
+;;; Author: Noel Welsh <noelwelsh@yahoo.com>
+;;
+;;
+;; Commentary:
+
+;; Based on the reference implementation by Olin Shiver and hence:
+
+;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with
+;; this code as long as you do not remove this copyright notice or
+;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.
+;;     -Olin
+
+(module misc
+  mzscheme
+
+  (require (lib "optional.ss" "srfi")
+		   "predicate.ss"
+		   "selector.ss"
+		   "util.ss"
+		   (rename "fold.ss" reduce-right reduce-right)
+		   (rename "fold.ss" srfi-1:map map))
+  (require (lib "receive.ss" "srfi" "8"))
+
+  (provide length+
+		   concatenate
+		   (rename my-append! append!)
+		   concatenate!
+		   (rename my-reverse! reverse!)
+		   append-reverse
+		   append-reverse!
+		   zip
+		   unzip1
+		   unzip2
+		   unzip3
+		   unzip4
+		   unzip5
+		   count)
+
+
+  ;; count
+  ;;;;;;;;
+  (define (count pred list1 . lists)
+	(check-arg procedure? pred 'count)
+	(if (pair? lists)
+
+		;; N-ary case
+		(let lp ((list1 list1) (lists lists) (i 0))
+		  (if (null-list? list1) i
+			  (receive (as ds) (%cars+cdrs lists)
+					   (if (null? as) i
+						   (lp (cdr list1) ds
+							   (if (apply pred (car list1) as) (+ i 1) i))))))
+
+		;; Fast path
+		(let lp ((lis list1) (i 0))
+		  (if (null-list? lis) i
+			  (lp (cdr lis) (if (pred (car lis)) (+ i 1) i))))))
+
+
+  (define (length+ x)  ; Returns #f if X is circular.
+	(let lp ((x x) (lag x) (len 0))
+	  (if (pair? x)
+		  (let ((x (cdr x))
+				(len (+ len 1)))
+			(if (pair? x)
+				(let ((x   (cdr x))
+					  (lag (cdr lag))
+					  (len (+ len 1)))
+				  (and (not (eq? x lag)) (lp x lag len)))
+				len))
+		  len)))
+
+
+
+  (define (zip list1 . more-lists) (apply srfi-1:map list list1 more-lists))
+
+  ;; Unzippers -- 1 through 5
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (define (unzip1 lis) (map car lis))
+
+  (define (unzip2 lis)
+	(let recur ((lis lis))
+	  (if (null-list? lis) (values lis lis)	; Use NOT-PAIR? to handle
+		  (let ((elt (car lis)))			; dotted lists.
+			(receive (a b) (recur (cdr lis))
+					 (values (cons (car  elt) a)
+							 (cons (cadr elt) b)))))))
+
+  (define (unzip3 lis)
+	(let recur ((lis lis))
+	  (if (null-list? lis) (values lis lis lis)
+		  (let ((elt (car lis)))
+			(receive (a b c) (recur (cdr lis))
+					 (values (cons (car   elt) a)
+							 (cons (cadr  elt) b)
+							 (cons (caddr elt) c)))))))
+
+  (define (unzip4 lis)
+	(let recur ((lis lis))
+	  (if (null-list? lis) (values lis lis lis lis)
+		  (let ((elt (car lis)))
+			(receive (a b c d) (recur (cdr lis))
+					 (values (cons (car    elt) a)
+							 (cons (cadr   elt) b)
+							 (cons (caddr  elt) c)
+							 (cons (cadddr elt) d)))))))
+
+  (define (unzip5 lis)
+	(let recur ((lis lis))
+	  (if (null-list? lis) (values lis lis lis lis lis)
+		  (let ((elt (car lis)))
+			(receive (a b c d e) (recur (cdr lis))
+					 (values (cons (car     elt) a)
+							 (cons (cadr    elt) b)
+							 (cons (caddr   elt) c)
+							 (cons (cadddr  elt) d)
+							 (cons (car (cddddr  elt)) e)))))))
+
+
+  ;; append! append-reverse append-reverse! concatenate concatenate!
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (define (my-append! . lists)
+	;; First, scan through lists looking for a non-empty one.
+	(let lp ((lists lists) (prev '()))
+	  (if (not (pair? lists)) prev
+		  (let ((first (car lists))
+				(rest (cdr lists)))
+			(if (not (pair? first)) (lp rest first)
+;				;; Now, do the splicing.
+				(let lp2 ((tail-cons (last-pair first))
+						  (rest rest))
+				  (if (pair? rest)
+					  (let ((next (car rest))
+							(rest (cdr rest)))
+						(set-cdr! tail-cons next)
+						(lp2 (if (pair? next) (last-pair next) tail-cons)
+							 rest))
+					  first)))))))
+
+
+  ;;(define (append-reverse rev-head tail) (fold cons tail rev-head))
+
+  ;;(define (append-reverse! rev-head tail)
+  ;;  (pair-fold (lambda (pair tail) (set-cdr! pair tail) pair)
+  ;;             tail
+  ;;             rev-head))
+
+  ;; Hand-inline the FOLD and PAIR-FOLD ops for speed.
+
+  (define (append-reverse rev-head tail)
+	(let lp ((rev-head rev-head) (tail tail))
+	  (if (null-list? rev-head) tail
+		  (lp (cdr rev-head) (cons (car rev-head) tail)))))
+
+  (define (append-reverse! rev-head tail)
+	(let lp ((rev-head rev-head) (tail tail))
+	  (if (null-list? rev-head) tail
+		  (let ((next-rev (cdr rev-head)))
+			(set-cdr! rev-head tail)
+			(lp next-rev rev-head)))))
+
+
+  (define (concatenate  lists) (reduce-right append  '() lists))
+  (define (concatenate! lists) (reduce-right my-append! '() lists))
+
+  (define (my-reverse! lis)
+	(let lp ((lis lis) (ans '()))
+	  (if (null-list? lis) ans
+		  (let ((tail (cdr lis)))
+			(set-cdr! lis ans)
+			(lp tail lis)))))
+
+  )
+;;; misc.ss ends here
\ No newline at end of file
diff --git a/collects/srfi/1/predicate.ss b/collects/srfi/1/predicate.ss
new file mode 100644
index 0000000000..9988454492
--- /dev/null
+++ b/collects/srfi/1/predicate.ss
@@ -0,0 +1,126 @@
+;;;
+;;; <predicate.ss> ---- List Predicates
+;;; Time-stamp: <02/02/27 12:57:15 noel>
+;;;
+;;; Copyright (C) 2002 by Noel Welsh. 
+;;;
+;;; This file is part of SRFI-1.
+
+;;; SRFI-1 is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2.1 of the License, or (at your option) any later version.
+
+;;; SRFI-1 is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with SRFI-1; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307  USA
+
+;;; Author: Noel Welsh <noelwelsh@yahoo.com>
+;;
+;;
+;; Commentary:
+
+;; Based on the reference implementation by Olin Shiver and hence:
+
+;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with
+;; this code as long as you do not remove this copyright notice or
+;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.
+;;     -Olin
+
+
+(module predicate
+  mzscheme
+
+  (require (lib "optional.ss" "srfi"))
+
+  (provide pair?
+		   null?
+		   proper-list?
+		   circular-list?
+		   dotted-list?
+		   not-pair?
+		   null-list?
+		   list=)
+
+  ;; <proper-list> ::= ()			; Empty proper list
+  ;;		  |   (cons <x> <proper-list>)	; Proper-list pair
+  ;; Note that this definition rules out circular lists -- and this
+  ;; function is required to detect this case and return false.
+  
+  (define (proper-list? x)
+	(let lp ((x x) (lag x))
+	  (if (pair? x)
+		  (let ((x (cdr x)))
+			(if (pair? x)
+				(let ((x   (cdr x))
+					  (lag (cdr lag)))
+				  (and (not (eq? x lag)) (lp x lag)))
+				(null? x)))
+		  (null? x))))
+  
+  
+  ;; A dotted list is a finite list (possibly of length 0) terminated
+  ;; by a non-nil value. Any non-cons, non-nil value (e.g., "foo" or 5)
+  ;; is a dotted list of length 0.
+  ;;
+  ;; <dotted-list> ::= <non-nil,non-pair>	; Empty dotted list
+  ;;               |   (cons <x> <dotted-list>)	; Proper-list pair
+  
+  (define (dotted-list? x)
+	(let lp ((x x) (lag x))
+	  (if (pair? x)
+		  (let ((x (cdr x)))
+			(if (pair? x)
+				(let ((x   (cdr x))
+					  (lag (cdr lag)))
+				  (and (not (eq? x lag)) (lp x lag)))
+				(not (null? x))))
+		  (not (null? x)))))
+  
+  (define (circular-list? x)
+	(let lp ((x x) (lag x))
+	  (and (pair? x)
+		   (let ((x (cdr x)))
+			 (and (pair? x)
+				  (let ((x   (cdr x))
+						(lag (cdr lag)))
+					(or (eq? x lag) (lp x lag))))))))
+  
+  (define (not-pair? x) (not (pair? x)))	; Inline me.
+  
+  ;; This is a legal definition which is fast and sloppy:
+  ;;     (define null-list? not-pair?)
+  ;; but we'll provide a more careful one:
+  (define (null-list? l)
+	(cond ((pair? l) #f)
+		  ((null? l) #t)
+		  (else (error "null-list?: argument out of domain" l))))
+  
+  
+  (define (list= = . lists)
+	(or (null? lists) ; special case
+		
+		(let lp1 ((list-a (car lists)) (others (cdr lists)))
+		  (or (null? others)
+			  (let ((list-b (car others))
+					(others (cdr others)))
+				(if (eq? list-a list-b)	; EQ? => LIST=
+					(lp1 list-b others)
+					(let lp2 ((list-a list-a) (list-b list-b))
+					  (if (null-list? list-a)
+						  (and (null-list? list-b)
+							   (lp1 list-b others))
+						  (and (not (null-list? list-b))
+							   (= (car list-a) (car list-b))
+							   (lp2 (cdr list-a) (cdr list-b)))))))))))
+  
+  
+  
+  )
+  
+;;; predicate.ss ends here
\ No newline at end of file
diff --git a/collects/srfi/1/search.ss b/collects/srfi/1/search.ss
new file mode 100644
index 0000000000..eb1c9c16d1
--- /dev/null
+++ b/collects/srfi/1/search.ss
@@ -0,0 +1,194 @@
+;;;
+;;; <search.ss> ---- List searching functions
+;;; Time-stamp: <02/02/28 12:11:01 noel>
+;;;
+;;; Copyright (C) 2002 by Noel Welsh. 
+;;;
+;;; This file is part of SRFI-1.
+
+;;; SRFI-1 is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2.1 of the License, or (at your option) any later version.
+
+;;; SRFI-1 is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with SRFI-1; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307  USA
+
+;;; Author: Noel Welsh <noelwelsh@yahoo.com>
+;;
+;;
+;; Commentary:
+
+;; Based on the reference implementation by Olin Shiver and hence:
+
+;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with
+;; this code as long as you do not remove this copyright notice or
+;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.
+;;     -Olin
+
+(module search
+  mzscheme
+
+  (require (lib "etc.ss" "mzlib")
+		   (lib "optional.ss" "srfi")
+		   "predicate.ss"
+		   "util.ss")
+  (require (lib "receive.ss" "srfi" "8"))
+
+  (provide (rename my-member member)
+		   find
+		   find-tail
+		   any
+		   every
+		   list-index
+		   take-while
+		   drop-while
+		   take-while!
+		   span
+		   break
+		   span!
+		   break!)
+
+  ;; Extended from R4RS to take an optional comparison argument.
+  (define my-member
+	(opt-lambda (x lis  (maybe-= equal?))
+	  (let ((= maybe-=))
+		(find-tail (lambda (y) (= x y)) lis))))
+
+  ;; find find-tail take-while drop-while span break any every list-index
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (define (find pred list)
+	(cond ((find-tail pred list) => car)
+		  (else #f)))
+
+  (define (find-tail pred list)
+	(check-arg procedure? pred 'find-tail)
+	(let lp ((list list))
+	  (and (not (null-list? list))
+		   (if (pred (car list)) list
+			   (lp (cdr list))))))
+  
+  (define (take-while pred lis)
+	(check-arg procedure? pred 'take-while)
+	(let recur ((lis lis))
+	  (if (null-list? lis) '()
+		  (let ((x (car lis)))
+			(if (pred x)
+				(cons x (recur (cdr lis)))
+				'())))))
+  
+  (define (drop-while pred lis)
+	(check-arg procedure? pred 'drop-while)
+	(let lp ((lis lis))
+	  (if (null-list? lis) '()
+		  (if (pred (car lis))
+			  (lp (cdr lis))
+			  lis))))
+  
+  (define (take-while! pred lis)
+	(check-arg procedure? pred 'take-while!)
+	(if (or (null-list? lis) (not (pred (car lis)))) '()
+		(begin (let lp ((prev lis) (rest (cdr lis)))
+				 (if (pair? rest)
+					 (let ((x (car rest)))
+					   (if (pred x) (lp rest (cdr rest))
+						   (set-cdr! prev '())))))
+			   lis)))
+  
+  (define (span pred lis)
+	(check-arg procedure? pred 'span)
+	(let recur ((lis lis))
+	  (if (null-list? lis) (values '() '())
+		  (let ((x (car lis)))
+			(if (pred x)
+				(receive (prefix suffix) (recur (cdr lis))
+						 (values (cons x prefix) suffix))
+				(values '() lis))))))
+
+  (define (span! pred lis)
+	(check-arg procedure? pred 'span!)
+	(if (or (null-list? lis) (not (pred (car lis)))) (values '() lis)
+		(let ((suffix (let lp ((prev lis) (rest (cdr lis)))
+						(if (null-list? rest) rest
+							(let ((x (car rest)))
+							  (if (pred x) (lp rest (cdr rest))
+								  (begin (set-cdr! prev '())
+										 rest)))))))
+		  (values lis suffix))))
+  
+  
+  (define (break  pred lis) (span  (lambda (x) (not (pred x))) lis))
+  (define (break! pred lis) (span! (lambda (x) (not (pred x))) lis))
+  
+  (define (any pred lis1 . lists)
+	(check-arg procedure? pred 'any)
+	(if (pair? lists)
+		
+      ;; N-ary case
+		(receive (heads tails) (%cars+cdrs (cons lis1 lists))
+				 (and (pair? heads)
+					  (let lp ((heads heads) (tails tails))
+						(receive (next-heads next-tails) (%cars+cdrs tails)
+								 (if (pair? next-heads)
+									 (or (apply pred heads) (lp next-heads next-tails))
+									 (apply pred heads)))))) ; Last PRED app is tail call.
+		
+		;; Fast path
+		(and (not (null-list? lis1))
+			 (let lp ((head (car lis1)) (tail (cdr lis1)))
+			   (if (null-list? tail)
+				   (pred head)		; Last PRED app is tail call.
+				   (or (pred head) (lp (car tail) (cdr tail))))))))
+
+
+;(define (every pred list)              ; Simple definition.
+;  (let lp ((list list))                ; Doesn't return the last PRED value.
+;    (or (not (pair? list))
+;        (and (pred (car list))
+;             (lp (cdr list))))))
+
+  (define (every pred lis1 . lists)
+	(check-arg procedure? pred 'every)
+	(if (pair? lists)
+		
+		;; N-ary case
+		(receive (heads tails) (%cars+cdrs (cons lis1 lists))
+				 (or (not (pair? heads))
+					 (let lp ((heads heads) (tails tails))
+					   (receive (next-heads next-tails) (%cars+cdrs tails)
+								(if (pair? next-heads)
+									(and (apply pred heads) (lp next-heads next-tails))
+									(apply pred heads)))))) ; Last PRED app is tail call.
+		
+		;; Fast path
+		(or (null-list? lis1)
+			(let lp ((head (car lis1))  (tail (cdr lis1)))
+			  (if (null-list? tail)
+				  (pred head)	; Last PRED app is tail call.
+				  (and (pred head) (lp (car tail) (cdr tail))))))))
+
+  (define (list-index pred lis1 . lists)
+	(check-arg procedure? pred 'list-index)
+	(if (pair? lists)
+		
+		;; N-ary case
+		(let lp ((lists (cons lis1 lists)) (n 0))
+		  (receive (heads tails) (%cars+cdrs lists)
+				   (and (pair? heads)
+						(if (apply pred heads) n
+							(lp tails (+ n 1))))))
+
+      ;; Fast path
+		(let lp ((lis lis1) (n 0))
+		  (and (not (null-list? lis))
+			   (if (pred (car lis)) n (lp (cdr lis) (+ n 1)))))))
+
+  )
+;;; search.ss ends here
\ No newline at end of file
diff --git a/collects/srfi/1/selector.ss b/collects/srfi/1/selector.ss
new file mode 100644
index 0000000000..07fe566219
--- /dev/null
+++ b/collects/srfi/1/selector.ss
@@ -0,0 +1,147 @@
+;;;
+;;; <selector.ss> ---- List selectors
+;;; Time-stamp: <02/02/27 12:49:44 noel>
+;;;
+;;; Copyright (C) 2002 by Noel Welsh. 
+;;;
+;;; This file is part of SRFI-1.
+
+;;; SRFI-1 is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2.1 of the License, or (at your option) any later version.
+
+;;; SRFI-1 is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with SRFI-1; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307  USA
+
+;;; Author: Noel Welsh <noelwelsh@yahoo.com>
+;;
+;;
+;; Commentary:
+
+;; Based on the reference implementation by Olin Shiver and hence:
+
+;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with
+;; this code as long as you do not remove this copyright notice or
+;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.
+;;     -Olin
+
+(module selector
+  mzscheme
+
+  (require (lib "optional.ss" "srfi"))
+  (require (lib "receive.ss" "srfi" "8"))
+
+  (provide
+   first second
+   third fourth
+   fifth sixth
+   seventh eighth
+   ninth tenth
+   car+cdr
+   take drop
+   take-right drop-right
+   take! drop-right!
+   split-at split-at!
+   last
+   last-pair)
+
+  (define first  car)
+  (define second cadr)
+  (define third  caddr)
+  (define fourth cadddr)
+  (define (fifth   x) (car    (cddddr x)))
+  (define (sixth   x) (cadr   (cddddr x)))
+  (define (seventh x) (caddr  (cddddr x)))
+  (define (eighth  x) (cadddr (cddddr x)))
+  (define (ninth   x) (car  (cddddr (cddddr x))))
+  (define (tenth   x) (cadr (cddddr (cddddr x))))
+  
+  (define (car+cdr pair) (values (car pair) (cdr pair)))
+
+  ;; take & drop
+  
+  (define (take lis k)
+	(check-arg integer? k 'take)
+	(let recur ((lis lis) (k k))
+	  (if (zero? k) '()
+		  (cons (car lis)
+				(recur (cdr lis) (- k 1))))))
+  
+  (define (drop lis k)
+	(check-arg integer? k 'drop)
+	(let iter ((lis lis) (k k))
+	  (if (zero? k) lis (iter (cdr lis) (- k 1)))))
+  
+  (define (take! lis k)
+	(check-arg integer? k 'take!)
+	(if (zero? k) '()
+		(begin (set-cdr! (drop lis (- k 1)) '())
+			   lis)))
+  
+  ;; TAKE-RIGHT and DROP-RIGHT work by getting two pointers into the list, 
+  ;; off by K, then chasing down the list until the lead pointer falls off
+  ;; the end.
+  
+  (define (take-right lis k)
+	(check-arg integer? k 'take-right)
+	(let lp ((lag lis)  (lead (drop lis k)))
+	  (if (pair? lead)
+		  (lp (cdr lag) (cdr lead))
+		  lag)))
+  
+  (define (drop-right lis k)
+	(check-arg integer? k 'drop-right)
+	(let recur ((lag lis) (lead (drop lis k)))
+	  (if (pair? lead)
+		  (cons (car lag) (recur (cdr lag) (cdr lead)))
+		  '())))
+  
+  ;; In this function, LEAD is actually K+1 ahead of LAG. This lets
+  ;; us stop LAG one step early, in time to smash its cdr to ().
+  (define (drop-right! lis k)
+	(check-arg integer? k 'drop-right!)
+	(let ((lead (drop lis k)))
+	  (if (pair? lead)
+		  
+		  (let lp ((lag lis)  (lead (cdr lead)))	; Standard case
+			(if (pair? lead)
+				(lp (cdr lag) (cdr lead))
+				(begin (set-cdr! lag '())
+					   lis)))
+		  
+		  '())))	; Special case dropping everything -- no cons to side-effect.
+  
+  (define (split-at x k)
+	(check-arg integer? k 'split-at)
+	(let recur ((lis x) (k k))
+	  (if (zero? k) (values '() lis)
+		  (receive (prefix suffix) (recur (cdr lis) (- k 1))
+				   (values (cons (car lis) prefix) suffix)))))
+  
+  (define (split-at! x k)
+	(check-arg integer? k 'split-at!)
+	(if (zero? k) (values '() x)
+		(let* ((prev (drop x (- k 1)))
+			   (suffix (cdr prev)))
+		  (set-cdr! prev '())
+		  (values x suffix))))
+  
+  
+  (define (last lis) (car (last-pair lis)))
+  
+  (define (last-pair lis)
+	(check-arg pair? lis 'last-pair)
+	(let lp ((lis lis))
+	  (let ((tail (cdr lis)))
+		(if (pair? tail) (lp tail) lis))))
+  
+  
+  )
+;;; selector.ss ends here
\ No newline at end of file
diff --git a/collects/srfi/1/util.ss b/collects/srfi/1/util.ss
new file mode 100644
index 0000000000..e7be2bdbac
--- /dev/null
+++ b/collects/srfi/1/util.ss
@@ -0,0 +1,125 @@
+;;;
+;;; <util.ss> ---- Utility functions
+;;; Time-stamp: <02/02/28 12:05:00 noel>
+;;;
+;;; Copyright (C) 2002 by Noel Welsh. 
+;;;
+;;; This file is part of SRFI-1.
+
+;;; SRFI-1 is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2.1 of the License, or (at your option) any later version.
+
+;;; SRFI-1 is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with SRFI-1; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307  USA
+
+;;; Author: Noel Welsh <noelwelsh@yahoo.com>
+;;
+;;
+;; Commentary:
+
+;; Based on the reference implementation by Olin Shiver and hence:
+
+;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with
+;; this code as long as you do not remove this copyright notice or
+;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.
+;;     -Olin
+
+(module util
+  mzscheme
+
+  (require (lib "optional.ss" "srfi")
+		   "predicate.ss"
+		   "selector.ss")
+  (require (lib "receive.ss" "srfi" "8"))
+
+  (provide %cdrs
+		   %cars+
+		   %cars+cdrs
+		   %cars+cdrs+
+		   %cars+cdrs/no-test)
+
+  ;; Fold/map internal utilities
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; These little internal utilities are used by the general
+  ;; fold & mapper funs for the n-ary cases . It'd be nice if they got inlined.
+  ;; One the other hand, the n-ary cases are painfully inefficient as it is.
+  ;; An aggressive implementation should simply re-write these functions 
+  ;; for raw efficiency; I have written them for as much clarity, portability,
+  ;; and simplicity as can be achieved.
+  ;;
+  ;; I use the dreaded call/cc to do local aborts. A good compiler could
+  ;; handle this with extreme efficiency. An implementation that provides
+  ;; a one-shot, non-persistent continuation grabber could help the compiler
+  ;; out by using that in place of the call/cc's in these routines.
+  ;;
+  ;; These functions have funky definitions that are precisely tuned to
+  ;; the needs of the fold/map procs -- for example, to minimize the number
+  ;; of times the argument lists need to be examined.
+  
+  ;; Return (map cdr lists). 
+  ;; However, if any element of LISTS is empty, just abort and return '().
+  (define (%cdrs lists)
+	(call-with-current-continuation
+	 (lambda (abort)
+	   (let recur ((lists lists))
+		 (if (pair? lists)
+			 (let ((lis (car lists)))
+			   (if (null-list? lis) (abort '())
+				   (cons (cdr lis) (recur (cdr lists)))))
+			 '())))))
+  
+  (define (%cars+ lists last-elt)	; (append! (map car lists) (list last-elt))
+	(let recur ((lists lists))
+	  (if (pair? lists) (cons (caar lists) (recur (cdr lists))) (list last-elt))))
+  
+  ;; LISTS is a (not very long) non-empty list of lists.
+  ;; Return two lists: the cars & the cdrs of the lists.
+  ;; However, if any of the lists is empty, just abort and return [() ()].
+  
+  (define (%cars+cdrs lists)
+	(call-with-current-continuation
+	 (lambda (abort)
+	   (let recur ((lists lists))
+		 (if (pair? lists)
+			 (receive (list other-lists) (car+cdr lists)
+					  (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out
+						  (receive (a d) (car+cdr list)
+								   (receive (cars cdrs) (recur other-lists)
+											(values (cons a cars) (cons d cdrs))))))
+			 (values '() '()))))))
+  
+  ;; Like %CARS+CDRS, but we pass in a final elt tacked onto the end of the
+  ;; cars list. What a hack.
+  (define (%cars+cdrs+ lists cars-final)
+	(call-with-current-continuation
+	 (lambda (abort)
+	   (let recur ((lists lists))
+		 (if (pair? lists)
+			 (receive (list other-lists) (car+cdr lists)
+					  (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out
+						  (receive (a d) (car+cdr list)
+								   (receive (cars cdrs) (recur other-lists)
+											(values (cons a cars) (cons d cdrs))))))
+			 (values (list cars-final) '()))))))
+  
+  ;; Like %CARS+CDRS, but blow up if any list is empty.
+  (define (%cars+cdrs/no-test lists)
+	(let recur ((lists lists))
+	  (if (pair? lists)
+		  (receive (list other-lists) (car+cdr lists)
+				   (receive (a d) (car+cdr list)
+							(receive (cars cdrs) (recur other-lists)
+									 (values (cons a cars) (cons d cdrs)))))
+		  (values '() '()))))
+  
+  )
+
+;;; util.ss ends here
\ No newline at end of file
diff --git a/collects/srfi/11.ss b/collects/srfi/11.ss
new file mode 100644
index 0000000000..d6002a2562
--- /dev/null
+++ b/collects/srfi/11.ss
@@ -0,0 +1,3 @@
+;; Supported by core PLT:
+(module |11| mzscheme
+  (provide let-values let*-values))
\ No newline at end of file
diff --git a/collects/srfi/13.ss b/collects/srfi/13.ss
new file mode 100644
index 0000000000..4bf7e820a8
--- /dev/null
+++ b/collects/srfi/13.ss
@@ -0,0 +1,5 @@
+;; module loader for SRFI-13
+(module |13| mzscheme
+  (require (lib "string.ss" "srfi" "13"))
+  (provide (all-from (lib "string.ss" "srfi" "13"))))
+
diff --git a/collects/srfi/13/.cvsignore b/collects/srfi/13/.cvsignore
new file mode 100644
index 0000000000..e3ca6473f7
--- /dev/null
+++ b/collects/srfi/13/.cvsignore
@@ -0,0 +1 @@
+compiled
diff --git a/collects/srfi/13/string.ss b/collects/srfi/13/string.ss
new file mode 100644
index 0000000000..2f348e3b7b
--- /dev/null
+++ b/collects/srfi/13/string.ss
@@ -0,0 +1,1905 @@
+;;;
+;;; <string.ss> ---- SRFI 13 port to PLT Scheme
+;;; Time-stamp: <2004-02-12 20:31:13 solsona>
+;;;
+;;; Usually, I would add a copyright notice, and the announce that
+;;; this code is under the LGPL licence.  Nevertheless, I only did the
+;;; port to PLT Scheme, and here is the copyright notice, and licence
+;;; from the original source:
+
+;;; Copyright (c) 1988-1994 Massachusetts Institute of Technology.
+;;; Copyright (c) 1998, 1999, 2000 Olin Shivers. All rights reserved.
+;;; Copyright details
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; The prefix/suffix and comparison routines in this code had (extremely
+;;; distant) origins in MIT Scheme's string lib, and was substantially
+;;; reworked by Olin Shivers (shivers@ai.mit.edu) 9/98. As such, it is
+;;; covered by MIT Scheme's open source copyright. See below for details.
+;;; 
+;;; The KMP string-search code was influenced by implementations written
+;;; by Stephen Bevan, Brian Dehneyer and Will Fitzgerald. However, this
+;;; version was written from scratch by myself.
+;;;
+;;; The remainder of this code was written from scratch by myself for scsh.
+;;; The scsh copyright is a BSD-style open source copyright. See below for
+;;; details.
+;;;     -Olin Shivers
+
+;;; MIT Scheme copyright terms
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; This material was developed by the Scheme project at the Massachusetts
+;;; Institute of Technology, Department of Electrical Engineering and
+;;; Computer Science.  Permission to copy and modify this software, to
+;;; redistribute either the original software or a modified version, and
+;;; to use this software for any purpose is granted, subject to the
+;;; following restrictions and understandings.
+;;; 
+;;; 1. Any copy made of this software must include this copyright notice
+;;; in full.
+;;; 
+;;; 2. Users of this software agree to make their best efforts (a) to
+;;; return to the MIT Scheme project any improvements or extensions that
+;;; they make, so that these may be included in future releases; and (b)
+;;; to inform MIT of noteworthy uses of this software.
+;;; 
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with the usual
+;;; standards of acknowledging credit in academic research.
+;;; 
+;;; 4. MIT has made no warrantee or representation that the operation of
+;;; this software will be error-free, and MIT is under no obligation to
+;;; provide any services, by way of maintenance, update, or otherwise.
+;;; 
+;;; 5. In conjunction with products arising from the use of this material,
+;;; there shall be no use of the name of the Massachusetts Institute of
+;;; Technology nor of any adaptation thereof in any advertising,
+;;; promotional, or sales literature without prior written consent from
+;;; MIT in each case.
+
+;;; Scsh copyright terms
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; All rights reserved.
+;;; 
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+;;; 1. Redistributions of source code must retain the above copyright
+;;;    notice, this list of conditions and the following disclaimer.
+;;; 2. Redistributions in binary form must reproduce the above copyright
+;;;    notice, this list of conditions and the following disclaimer in the
+;;;    documentation and/or other materials provided with the distribution.
+;;; 3. The name of the authors may not be used to endorse or promote products
+;;;    derived from this software without specific prior written permission.
+;;; 
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
+;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
+;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
+;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
+;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
+;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Are you still here? Cool, keep reading it gets better:
+
+(module string mzscheme
+  (require (lib "optional.ss" "srfi")
+	   (lib "receive.ss" "srfi" "8")
+	   (lib "char-set.ss" "srfi" "14")
+	   (lib "etc.ss");; for opt-lambda (instead of let-optionals*)
+	   )
+  (provide
+   ;; Provide char-sets:
+   (all-from (lib "char-set.ss" "srfi" "14"))
+   ;; String procedures:
+   string-map string-map!
+   string-fold string-unfold
+   string-fold-right string-unfold-right
+   string-tabulate string-for-each string-for-each-index
+   string-every string-any
+   string-hash string-hash-ci
+   string-compare string-compare-ci
+   string=    string<    string>    string<=    string>=    string<>
+   string-ci= string-ci< string-ci> string-ci<= string-ci>= string-ci<> 
+   string-downcase  string-upcase  string-titlecase  
+   string-downcase! string-upcase! string-titlecase! 
+   string-take string-take-right
+   string-drop string-drop-right
+   string-pad string-pad-right
+   string-trim string-trim-right string-trim-both
+   string-filter string-delete
+   string-index string-index-right 
+   string-skip  string-skip-right
+   string-count
+   string-prefix-length string-prefix-length-ci
+   string-suffix-length string-suffix-length-ci
+   string-prefix? string-prefix-ci?
+   string-suffix? string-suffix-ci?
+   string-contains string-contains-ci
+   substring/shared
+   string-reverse string-reverse! reverse-list->string
+   string-concatenate string-concatenate/shared string-concatenate-reverse
+   string-concatenate-reverse/shared
+   string-append/shared
+   xsubstring string-xcopy!
+   string-null?
+   string-join
+   string-tokenize
+   string-replace
+	 
+   ;; R5RS extended, re-exported:
+   ;; I could do this:
+   ;; (rename extended-string-fill! string-fill!)
+   ;; (rename extended-string->list string->list)
+   ;; and it would work fine in the top level, but you won't be
+   ;; able to (require "string.ss" "srfi") into another module,
+   ;; so I won't.  FIXME: is there any other way?
+   extended-string-fill!
+   extended-string->list
+   ;; R5RS re-exports:
+   ;; string-copy
+   ;; string? make-string string-length string-ref string-set!
+   ;; R5RS re-exports (also defined here but commented-out):
+   ;; string string-append list->string
+
+   ;; Low level routines:
+   make-kmp-restart-vector string-kmp-partial-search kmp-step
+   string-parse-start+end
+   string-parse-final-start+end
+   let-string-start+end
+   check-substring-spec
+   substring-spec-ok?
+   )
+
+
+  ;; Support for START/END substring specs
+  ;; 
+  ;; This macro parses optional start/end arguments from arg lists, defaulting
+  ;; them to 0/(string-length s), and checks them for correctness.
+
+  (define-syntax let-string-start+end
+    (syntax-rules ()
+		  ((let-string-start+end (start end) proc s-exp args-exp body ...)
+		   (receive (start end) (string-parse-final-start+end proc s-exp args-exp)
+			    body ...))
+		  ((let-string-start+end (start end rest) proc s-exp args-exp body ...)
+		   (receive (rest start end) (string-parse-start+end proc s-exp args-exp)
+			    body ...))))
+
+  ;; This one parses out a *pair* of final start/end indices. 
+  ;; Not exported; for internal use.
+  (define-syntax let-string-start+end2
+    (syntax-rules ()
+		  ((l-s-s+e2 (start1 end1 start2 end2) proc s1 s2 args body ...)
+		   (let ((procv proc))	; Make sure PROC is only evaluated once.
+		     (let-string-start+end (start1 end1 rest) procv s1 args
+					   (let-string-start+end (start2 end2) procv s2 rest
+								 body ...))))))
+
+
+  ;; Returns three values: rest start end
+
+  (define (string-parse-start+end proc s args)
+    (if (not (string? s)) (error proc "Non-string value ~a" s))
+    (let ((slen (string-length s)))
+      (if (pair? args)
+
+	  (let ((start (car args))
+		(args (cdr args)))
+	    (if (and (integer? start) (exact? start) (>= start 0))
+		(receive (end args)
+			 (if (pair? args)
+			     (let ((end (car args))
+				   (args (cdr args)))
+			       (if (and (integer? end) (exact? end) (<= end slen))
+				   (values end args)
+				   (error proc "Illegal substring END spec" end s)))
+			     (values slen args))
+			 (if (<= start end) (values args start end)
+			     (error proc "Illegal substring START/END spec" start end s)))
+		(error proc "Illegal substring START spec" start s)))
+
+	  (values '() 0 slen))))
+
+  (define (string-parse-final-start+end proc s args)
+    (receive (rest start end) (string-parse-start+end proc s args)
+	     (if (pair? rest) (error proc "Extra arguments to procedure" rest)
+		 (values start end))))
+
+  (define (substring-spec-ok? s start end)
+    (and (string? s)
+	 (integer? start)
+	 (exact? start)
+	 (integer? end)
+	 (exact? end)
+	 (<= 0 start)
+	 (<= start end)
+	 (<= end (string-length s))))
+
+  (define (check-substring-spec proc s start end)
+    (if (not (substring-spec-ok? s start end))
+	(error "Illegal substring spec." proc s start end)))
+
+
+  ;; Defined by R5RS, so commented out here.
+;(define (string . chars)
+;  (let* ((len (length chars))
+;         (ans (make-string len)))
+;    (do ((i 0 (+ i 1))
+;	 (chars chars (cdr chars)))
+;	((>= i len))
+;      (string-set! ans i (car chars)))
+;    ans))
+;
+;(define (string . chars) (string-unfold null? car cdr chars))
+
+
+  
+  ;; substring/shared S START [END] 
+  ;; string-copy      S [START END]
+  ;; 
+
+  ;; All this goop is just arg parsing & checking surrounding a call to the
+  ;; actual primitive, %SUBSTRING/SHARED.
+
+  (define (substring/shared s start . maybe-end)
+    (check-arg string? s 'substring/shared)
+    (let ((slen (string-length s)))
+      (check-arg (lambda (start) (and (integer? start) (exact? start) (<= 0 start)))
+		 start 'substring/shared)
+      (%substring/shared s start
+			 (:optional maybe-end slen
+				    (lambda (end) (and (integer? end)
+						       (exact? end)
+						       (<= start end)
+						       (<= end slen)))))))
+
+  ;; Split out so that other routines in this library can avoid arg-parsing
+  ;; overhead for END parameter.
+  (define (%substring/shared s start end)
+    (if (and (zero? start) (= end (string-length s))) s
+	(substring s start end)))
+
+  ;; string-copy exists in PLT Scheme, so, we'll use that,
+  ;; hopefully faster implementation.
+  ;; (define (string-copy s . maybe-start+end)
+  ;;   (let-string-start+end (start end) string-copy s maybe-start+end
+  ;; 			   (substring s start end)))
+
+  ;; This library uses the R5RS SUBSTRING, but doesn't export it.
+  ;; Here is a definition, just for completeness.
+  ;; (define (substring s start end)
+  ;;   (check-substring-spec substring s start end)
+  ;;   (let* ((slen (- end start))
+  ;; 	    (ans (make-string slen)))
+  ;;     (do ((i 0 (+ i 1))
+  ;; 	    (j start (+ j 1)))
+  ;; 	   ((>= i slen) ans)
+  ;; 	 (string-set! ans i (string-ref s j)))))
+
+  ;; Basic iterators and other higher-order abstractions
+  ;; (string-map proc s [start end])
+  ;; (string-map! proc s [start end])
+  ;; (string-fold kons knil s [start end])
+  ;; (string-fold-right kons knil s [start end])
+  ;; (string-unfold       p f g seed [base make-final])
+  ;; (string-unfold-right p f g seed [base make-final])
+  ;; (string-for-each       proc s [start end])
+  ;; (string-for-each-index proc s [start end])
+  ;; (string-every char-set/char/pred s [start end])
+  ;; (string-any   char-set/char/pred s [start end])
+  ;; (string-tabulate proc len)
+  ;; 
+  ;; You want compiler support for high-level transforms on fold and unfold ops.
+  ;; You'd at least like a lot of inlining for clients of these procedures.
+  ;; Don't hold your breath.
+
+  (define (string-map proc s . maybe-start+end)
+    (check-arg procedure? proc 'string-map)
+    (let-string-start+end (start end) 'string-map s maybe-start+end
+			  (%string-map proc s start end)))
+
+  (define (%string-map proc s start end) ; Internal utility
+    (let* ((len (- end start))
+	   (ans (make-string len)))
+      (do ((i (- end 1) (- i 1))
+	   (j (- len 1) (- j 1)))
+	  ((< j 0))
+	(string-set! ans j (proc (string-ref s i))))
+      ans))
+
+  (define (string-map! proc s . maybe-start+end)
+    (check-arg procedure? proc 'string-map!)
+    (let-string-start+end (start end) 'string-map! s maybe-start+end
+			  (%string-map! proc s start end)))
+
+  (define (%string-map! proc s start end)
+    (do ((i (- end 1) (- i 1)))
+	((< i start))
+      (string-set! s i (proc (string-ref s i)))))
+
+  (define (string-fold kons knil s . maybe-start+end)
+    (check-arg procedure? kons 'string-fold)
+    (let-string-start+end (start end) 'string-fold s maybe-start+end
+			  (let lp ((v knil) (i start))
+			    (if (< i end) (lp (kons (string-ref s i) v) (+ i 1))
+				v))))
+
+  (define (string-fold-right kons knil s . maybe-start+end)
+    (check-arg procedure? kons 'string-fold-right)
+    (let-string-start+end (start end) 'string-fold-right s maybe-start+end
+			  (let lp ((v knil) (i (- end 1)))
+			    (if (>= i start) (lp (kons (string-ref s i) v) (- i 1))
+				v))))
+
+  ;; (string-unfold p f g seed [base make-final])
+  ;; This is the fundamental constructor for strings. 
+  ;; - G is used to generate a series of "seed" values from the initial seed:
+  ;;     SEED, (G SEED), (G^2 SEED), (G^3 SEED), ...
+  ;; - P tells us when to stop -- when it returns true when applied to one 
+  ;;   of these seed values.
+  ;; - F maps each seed value to the corresponding character 
+  ;;   in the result string. These chars are assembled into the
+  ;;   string in a left-to-right order.
+  ;; - BASE is the optional initial/leftmost portion of the constructed string;
+  ;;   it defaults to the empty string "".
+  ;; - MAKE-FINAL is applied to the terminal seed value (on which P returns
+  ;;   true) to produce the final/rightmost portion of the constructed string.
+  ;;   It defaults to (LAMBDA (X) "").
+  ;; 
+  ;; In other words, the following (simple, inefficient) definition holds:
+  ;; (define (string-unfold p f g seed base make-final)
+  ;;   (string-append base
+  ;;                  (let recur ((seed seed))
+  ;;                    (if (p seed) (make-final seed)
+  ;;                        (string-append (string (f seed))
+  ;;                                       (recur (g seed)))))))
+  ;; 
+  ;; STRING-UNFOLD is a fairly powerful constructor -- you can use it to
+  ;; reverse a string, copy a string, convert a list to a string, read
+  ;; a port into a string, and so forth. Examples:
+  ;; (port->string port) =
+  ;;   (string-unfold (compose eof-object? peek-char)
+  ;;                  read-char values port)
+  ;; 
+  ;; (list->string lis) = (string-unfold null? car cdr lis)
+  ;; 
+  ;; (tabulate-string f size) = (string-unfold (lambda (i) (= i size)) f add1 0)
+
+  ;; A problem with the following simple formulation is that it pushes one
+  ;; stack frame for every char in the result string -- an issue if you are
+  ;; using it to read a 100kchar string. So we don't use it -- but I include
+  ;; it to give a clear, straightforward description of what the function
+  ;; does.
+
+;(define (string-unfold p f g seed base make-final)
+;  (let ((ans (let recur ((seed seed) (i (string-length base)))
+;               (if (p seed)
+;                   (let* ((final (make-final seed))
+;                          (ans (make-string (+ i (string-length final)))))
+;                     (string-copy! ans i final)
+;                     ans)
+;
+;                   (let* ((c (f seed))
+;                          (s (recur (g seed) (+ i 1))))
+;                     (string-set! s i c)
+;                     s)))))
+;    (string-copy! ans 0 base)
+;    ans))
+
+  ;; The strategy is to allocate a series of chunks into which we stash the
+  ;; chars as we generate them. Chunk size goes up in powers of two starting
+  ;; with 40 and levelling out at 4k, i.e.
+  ;;     40 40 80 160 320 640 1280 2560 4096 4096 4096 4096 4096...
+  ;; This should work pretty well for short strings, 1-line (80 char) strings,
+  ;; and longer ones. When done, we allocate an answer string and copy the
+  ;; chars over from the chunk buffers.
+
+  (define string-unfold
+    (opt-lambda (p f g seed (base "") (make-final (lambda (x) "")))
+      (check-arg procedure? p 'string-unfold)
+      (check-arg procedure? f 'string-unfold)
+      (check-arg procedure? g 'string-unfold)
+      (check-arg string? base 'string-unfold)
+      (check-arg procedure? make-final 'string-unfold)
+      (let lp ((chunks '())		; Previously filled chunks
+	       (nchars 0)		; Number of chars in CHUNKS
+	       (chunk (make-string 40)) ; Current chunk into which we write
+	       (chunk-len 40)
+	       (i 0)			; Number of chars written into CHUNK
+	       (seed seed))
+	(let lp2 ((i i) (seed seed))
+	  (if (not (p seed))
+	      (let ((c (f seed))
+		    (seed (g seed)))
+		(if (< i chunk-len)
+		    (begin (string-set! chunk i c)
+			   (lp2 (+ i 1) seed))
+
+		    (let* ((nchars2 (+ chunk-len nchars))
+			   (chunk-len2 (min 4096 nchars2))
+			   (new-chunk (make-string chunk-len2)))
+		      (string-set! new-chunk 0 c)
+		      (lp (cons chunk chunks) (+ nchars chunk-len)
+			  new-chunk chunk-len2 1 seed))))
+
+	      ;; We're done. Make the answer string & install the bits.
+	      (let* ((final (make-final seed))
+		     (flen (string-length final))
+		     (base-len (string-length base))
+		     (j (+ base-len nchars i))
+		     (ans (make-string (+ j flen))))
+		(%string-copy! ans j final 0 flen) ; Install FINAL.
+		(let ((j (- j i)))
+		  (%string-copy! ans j chunk 0 i) ; Install CHUNK[0,I).
+		  (let lp ((j j) (chunks chunks)) ; Install CHUNKS.
+		    (if (pair? chunks)
+			(let* ((chunk  (car chunks))
+			       (chunks (cdr chunks))
+			       (chunk-len (string-length chunk))
+			       (j (- j chunk-len)))
+			  (%string-copy! ans j chunk 0 chunk-len)
+			  (lp j chunks)))))
+		(%string-copy! ans 0 base 0 base-len) ; Install BASE.
+		ans))))))
+
+  (define string-unfold-right
+    (opt-lambda (p f g seed (base "") (make-final (lambda (x) "")))
+      (check-arg string? base 'string-unfold-right)
+      (check-arg procedure? make-final 'string-unfold-right)
+      (let lp ((chunks '())		; Previously filled chunks
+	       (nchars 0)		; Number of chars in CHUNKS
+	       (chunk (make-string 40)) ; Current chunk into which we write
+	       (chunk-len 40)
+	       (i 40)			; Number of chars available in CHUNK
+	       (seed seed))
+	(let lp2 ((i i) (seed seed))	; Fill up CHUNK from right
+	  (if (not (p seed))		; to left.
+	      (let ((c (f seed))
+		    (seed (g seed)))
+		(if (> i 0)
+		    (let ((i (- i 1)))
+		      (string-set! chunk i c)
+		      (lp2 i seed))
+
+		    (let* ((nchars2 (+ chunk-len nchars))
+			   (chunk-len2 (min 4096 nchars2))
+			   (new-chunk (make-string chunk-len2))
+			   (i (- chunk-len2 1)))
+		      (string-set! new-chunk i c)
+		      (lp (cons chunk chunks) (+ nchars chunk-len)
+			  new-chunk chunk-len2 i seed))))
+
+	      ;; We're done. Make the answer string & install the bits.
+	      (let* ((final (make-final seed))
+		     (flen (string-length final))
+		     (base-len (string-length base))
+		     (chunk-used (- chunk-len i))
+		     (j (+ base-len nchars chunk-used))
+		     (ans (make-string (+ j flen))))
+		(%string-copy! ans 0 final 0 flen) ; Install FINAL.
+		(%string-copy! ans flen chunk i chunk-len) ; Install CHUNK[I,).
+		(let lp ((j (+ flen chunk-used)) ; Install CHUNKS.
+			 (chunks chunks))		
+		  (if (pair? chunks)
+		      (let* ((chunk  (car chunks))
+			     (chunks (cdr chunks))
+			     (chunk-len (string-length chunk)))
+			(%string-copy! ans j chunk 0 chunk-len)
+			(lp (+ j chunk-len) chunks))
+		      (%string-copy! ans j base 0 base-len))) ; Install BASE.
+		ans))))))
+
+
+  (define (string-for-each proc s . maybe-start+end)
+    (check-arg procedure? proc 'string-for-each)
+    (let-string-start+end (start end) 'string-for-each s maybe-start+end
+			  (let lp ((i start))
+			    (if (< i end)
+				(begin (proc (string-ref s i)) 
+				       (lp (+ i 1)))))))
+
+  (define (string-for-each-index proc s . maybe-start+end)
+    (check-arg procedure? proc 'string-for-each-index)
+    (let-string-start+end (start end) 'string-for-each-index s maybe-start+end
+			  (let lp ((i start))
+			    (if (< i end) (begin (proc i) (lp (+ i 1)))))))
+
+  (define (string-every criterion s . maybe-start+end)
+    (let-string-start+end (start end) 'string-every s maybe-start+end
+			  (cond ((char? criterion)
+				 (let lp ((i start))
+				   (or (>= i end)
+				       (and (char=? criterion (string-ref s i))
+					    (lp (+ i 1))))))
+
+				((char-set? criterion)
+				 (let lp ((i start))
+				   (or (>= i end)
+				       (and (char-set-contains? criterion (string-ref s i))
+					    (lp (+ i 1))))))
+
+				((procedure? criterion)	; Slightly funky loop so that
+				 (or (= start end) ; final (PRED S[END-1]) call
+				     (let lp ((i start)) ; is a tail call.
+				       (let ((c (string-ref s i))
+					     (i1 (+ i 1)))
+					 (if (= i1 end) (criterion c) ; Tail call.
+					     (and (criterion c) (lp i1)))))))
+
+				(else (error 'string-every "Second param is neither char-set, char, or predicate procedure: ~a" criterion)))))
+
+
+  (define (string-any criterion s . maybe-start+end)
+    (let-string-start+end (start end) 'string-any s maybe-start+end
+			  (cond ((char? criterion)
+				 (let lp ((i start))
+				   (and (< i end)
+					(or (char=? criterion (string-ref s i))
+					    (lp (+ i 1))))))
+
+				((char-set? criterion)
+				 (let lp ((i start))
+				   (and (< i end)
+					(or (char-set-contains? criterion (string-ref s i))
+					    (lp (+ i 1))))))
+
+				((procedure? criterion)	; Slightly funky loop so that
+				 (and (< start end) ; final (PRED S[END-1]) call
+				      (let lp ((i start)) ; is a tail call.
+					(let ((c (string-ref s i))
+					      (i1 (+ i 1)))
+					  (if (= i1 end) (criterion c) ; Tail call
+					      (or (criterion c) (lp i1)))))))
+
+				(else (error "Second param is neither char-set, char, or predicate procedure."
+					     string-any criterion)))))
+
+
+  (define (string-tabulate proc len)
+    (check-arg procedure? proc 'string-tabulate)
+    (check-arg (lambda (val) (and (integer? val) (exact? val) (<= 0 val)))
+	       len 'string-tabulate)
+    (let ((s (make-string len)))
+      (do ((i (- len 1) (- i 1)))
+	  ((< i 0))
+	(string-set! s i (proc i)))
+      s))
+
+
+  
+  ;; string-prefix-length[-ci] s1 s2 [start1 end1 start2 end2]
+  ;; string-suffix-length[-ci] s1 s2 [start1 end1 start2 end2]
+  ;; 
+  ;; Find the length of the common prefix/suffix.
+  ;; It is not required that the two substrings passed be of equal length.
+  ;; This was microcode in MIT Scheme -- a very tightly bummed primitive.
+  ;; %STRING-PREFIX-LENGTH is the core routine of all string-comparisons,
+  ;; so should be as tense as possible.
+
+  (define (%string-prefix-length s1 start1 end1 s2 start2 end2)
+    (let* ((delta (min (- end1 start1) (- end2 start2)))
+	   (end1 (+ start1 delta)))
+
+      (if (and (eq? s1 s2) (= start1 start2)) ; EQ fast path
+	  delta
+
+	  (let lp ((i start1) (j start2)) ; Regular path
+	    (if (or (>= i end1)
+		    (not (char=? (string-ref s1 i)
+				 (string-ref s2 j))))
+		(- i start1)
+		(lp (+ i 1) (+ j 1)))))))
+
+  (define (%string-suffix-length s1 start1 end1 s2 start2 end2)
+    (let* ((delta (min (- end1 start1) (- end2 start2)))
+	   (start1 (- end1 delta)))
+
+      (if (and (eq? s1 s2) (= end1 end2)) ; EQ fast path
+	  delta
+
+	  (let lp ((i (- end1 1)) (j (- end2 1))) ; Regular path
+	    (if (or (< i start1)
+		    (not (char=? (string-ref s1 i)
+				 (string-ref s2 j))))
+		(- (- end1 i) 1)
+		(lp (- i 1) (- j 1)))))))
+
+  (define (%string-prefix-length-ci s1 start1 end1 s2 start2 end2)
+    (let* ((delta (min (- end1 start1) (- end2 start2)))
+	   (end1 (+ start1 delta)))
+
+      (if (and (eq? s1 s2) (= start1 start2)) ; EQ fast path
+	  delta
+
+	  (let lp ((i start1) (j start2)) ; Regular path
+	    (if (or (>= i end1)
+		    (not (char-ci=? (string-ref s1 i)
+				    (string-ref s2 j))))
+		(- i start1)
+		(lp (+ i 1) (+ j 1)))))))
+
+  (define (%string-suffix-length-ci s1 start1 end1 s2 start2 end2)
+    (let* ((delta (min (- end1 start1) (- end2 start2)))
+	   (start1 (- end1 delta)))
+
+      (if (and (eq? s1 s2) (= end1 end2)) ; EQ fast path
+	  delta
+
+	  (let lp ((i (- end1 1)) (j (- end2 1))) ; Regular path
+	    (if (or (< i start1)
+		    (not (char-ci=? (string-ref s1 i)
+				    (string-ref s2 j))))
+		(- (- end1 i) 1)
+		(lp (- i 1) (- j 1)))))))
+
+
+  (define (string-prefix-length s1 s2 . maybe-starts+ends)
+    (let-string-start+end2 (start1 end1 start2 end2) 
+			   'string-prefix-length s1 s2 maybe-starts+ends
+			   (%string-prefix-length s1 start1 end1 s2 start2 end2)))
+
+  (define (string-suffix-length s1 s2 . maybe-starts+ends)
+    (let-string-start+end2 (start1 end1 start2 end2) 
+			   'string-suffix-length s1 s2 maybe-starts+ends
+			   (%string-suffix-length s1 start1 end1 s2 start2 end2)))
+
+  (define (string-prefix-length-ci s1 s2 . maybe-starts+ends)
+    (let-string-start+end2 (start1 end1 start2 end2) 
+			   'string-prefix-length-ci s1 s2 maybe-starts+ends
+			   (%string-prefix-length-ci s1 start1 end1 s2 start2 end2)))
+
+  (define (string-suffix-length-ci s1 s2 . maybe-starts+ends)
+    (let-string-start+end2 (start1 end1 start2 end2) 
+			   'string-suffix-length-ci s1 s2 maybe-starts+ends
+			   (%string-suffix-length-ci s1 start1 end1 s2 start2 end2)))
+
+
+  ;; string-prefix?    s1 s2 [start1 end1 start2 end2]
+  ;; string-suffix?    s1 s2 [start1 end1 start2 end2]
+  ;; string-prefix-ci? s1 s2 [start1 end1 start2 end2]
+  ;; string-suffix-ci? s1 s2 [start1 end1 start2 end2]
+  ;; 
+  ;; These are all simple derivatives of the previous counting funs.
+
+  (define (string-prefix? s1 s2 . maybe-starts+ends)
+    (let-string-start+end2 (start1 end1 start2 end2) 
+			   'string-prefix? s1 s2 maybe-starts+ends
+			   (%string-prefix? s1 start1 end1 s2 start2 end2)))
+
+  (define (string-suffix? s1 s2 . maybe-starts+ends)
+    (let-string-start+end2 (start1 end1 start2 end2) 
+			   'string-suffix? s1 s2 maybe-starts+ends
+			   (%string-suffix? s1 start1 end1 s2 start2 end2)))
+
+  (define (string-prefix-ci? s1 s2 . maybe-starts+ends)
+    (let-string-start+end2 (start1 end1 start2 end2) 
+			   'string-prefix-ci? s1 s2 maybe-starts+ends
+			   (%string-prefix-ci? s1 start1 end1 s2 start2 end2)))
+
+  (define (string-suffix-ci? s1 s2 . maybe-starts+ends)
+    (let-string-start+end2 (start1 end1 start2 end2) 
+			   'string-suffix-ci? s1 s2 maybe-starts+ends
+			   (%string-suffix-ci? s1 start1 end1 s2 start2 end2)))
+
+
+  ;; Here are the internal routines that do the real work.
+
+  (define (%string-prefix? s1 start1 end1 s2 start2 end2)
+    (let ((len1 (- end1 start1)))
+      (and (<= len1 (- end2 start2))	; Quick check
+	   (= (%string-prefix-length s1 start1 end1
+				     s2 start2 end2)
+	      len1))))
+
+  (define (%string-suffix? s1 start1 end1 s2 start2 end2)
+    (let ((len1 (- end1 start1)))
+      (and (<= len1 (- end2 start2))	; Quick check
+	   (= len1 (%string-suffix-length s1 start1 end1
+					  s2 start2 end2)))))
+
+  (define (%string-prefix-ci? s1 start1 end1 s2 start2 end2)
+    (let ((len1 (- end1 start1)))
+      (and (<= len1 (- end2 start2))	; Quick check
+	   (= len1 (%string-prefix-length-ci s1 start1 end1
+					     s2 start2 end2)))))
+
+  (define (%string-suffix-ci? s1 start1 end1 s2 start2 end2)
+    (let ((len1 (- end1 start1)))
+      (and (<= len1 (- end2 start2))	; Quick check
+	   (= len1 (%string-suffix-length-ci s1 start1 end1
+					     s2 start2 end2)))))
+
+  
+  ;; string-compare    s1 s2 proc< proc= proc> [start1 end1 start2 end2]
+  ;; string-compare-ci s1 s2 proc< proc= proc> [start1 end1 start2 end2]
+  ;; 
+  ;; Primitive string-comparison functions.
+  ;; Continuation order is different from MIT Scheme.
+  ;; Continuations are applied to s1's mismatch index;
+  ;; in the case of equality, this is END1.
+
+  (define (%string-compare s1 start1 end1 s2 start2 end2
+			   proc< proc= proc>)
+    (let ((size1 (- end1 start1))
+	  (size2 (- end2 start2)))
+      (let ((match (%string-prefix-length s1 start1 end1 s2 start2 end2)))
+	(if (= match size1)
+	    ((if (= match size2) proc= proc<) end1)
+	    ((if (= match size2)
+		 proc>
+		 (if (char<? (string-ref s1 (+ start1 match))
+			     (string-ref s2 (+ start2 match)))
+		     proc< proc>))
+	     (+ match start1))))))
+
+  (define (%string-compare-ci s1 start1 end1 s2 start2 end2
+			      proc< proc= proc>)
+    (let ((size1 (- end1 start1))
+	  (size2 (- end2 start2)))
+      (let ((match (%string-prefix-length-ci s1 start1 end1 s2 start2 end2)))
+	(if (= match size1)
+	    ((if (= match size2) proc= proc<) end1)
+	    ((if (= match size2) proc>
+		 (if (char-ci<? (string-ref s1 (+ start1 match))
+				(string-ref s2 (+ start2 match)))
+		     proc< proc>))
+	     (+ start1 match))))))
+
+  (define (string-compare s1 s2 proc< proc= proc> . maybe-starts+ends)
+    (check-arg procedure? proc< 'string-compare)
+    (check-arg procedure? proc= 'string-compare)
+    (check-arg procedure? proc> 'string-compare)
+    (let-string-start+end2 (start1 end1 start2 end2) 
+			   'string-compare s1 s2 maybe-starts+ends
+			   (%string-compare s1 start1 end1 s2 start2 end2 proc< proc= proc>)))
+
+  (define (string-compare-ci s1 s2 proc< proc= proc> . maybe-starts+ends)
+    (check-arg procedure? proc< 'string-compare-ci)
+    (check-arg procedure? proc= 'string-compare-ci)
+    (check-arg procedure? proc> 'string-compare-ci)
+    (let-string-start+end2 (start1 end1 start2 end2) 
+			   'string-compare-ci s1 s2 maybe-starts+ends
+			   (%string-compare-ci s1 start1 end1 s2 start2 end2 proc< proc= proc>)))
+
+
+
+  ;; string=          string<>		string-ci=          string-ci<>
+  ;; string<          string>		string-ci<          string-ci>
+  ;; string<=         string>=		string-ci<=         string-ci>=
+  ;; 
+  ;; Simple definitions in terms of the previous comparison funs.
+  ;; I sure hope the %STRING-COMPARE calls get integrated.
+
+  (define (string= s1 s2 . maybe-starts+ends)
+    (let-string-start+end2 (start1 end1 start2 end2) 
+			   'string= s1 s2 maybe-starts+ends
+			   (and (= (- end1 start1) (- end2 start2)) ; Quick filter
+				(or (and (eq? s1 s2) (= start1 start2))	; Fast path
+				    (%string-compare s1 start1 end1 s2 start2 end2 ; Real test
+						     (lambda (i) #f)
+						     values
+						     (lambda (i) #f))))))
+
+  (define (string<> s1 s2 . maybe-starts+ends)
+    (let-string-start+end2 (start1 end1 start2 end2) 
+			   'string<> s1 s2 maybe-starts+ends
+			   (or (not (= (- end1 start1) (- end2 start2))) ; Fast path
+			       (and (not (and (eq? s1 s2) (= start1 start2))) ; Quick filter
+				    (%string-compare s1 start1 end1 s2 start2 end2 ; Real test
+						     values
+						     (lambda (i) #f)
+						     values)))))
+
+  (define (string< s1 s2 . maybe-starts+ends)
+    (let-string-start+end2 (start1 end1 start2 end2) 
+			   'string< s1 s2 maybe-starts+ends
+			   (if (and (eq? s1 s2) (= start1 start2)) ; Fast path
+			       (< end1 end2)
+
+			       (%string-compare s1 start1 end1 s2 start2 end2 ; Real test
+						values
+						(lambda (i) #f)
+						(lambda (i) #f)))))
+
+  (define (string> s1 s2 . maybe-starts+ends)
+    (let-string-start+end2 (start1 end1 start2 end2) 
+			   'string> s1 s2 maybe-starts+ends
+			   (if (and (eq? s1 s2) (= start1 start2)) ; Fast path
+			       (> end1 end2)
+
+			       (%string-compare s1 start1 end1 s2 start2 end2 ; Real test
+						(lambda (i) #f)
+						(lambda (i) #f)
+						values))))
+
+  (define (string<= s1 s2 . maybe-starts+ends)
+    (let-string-start+end2 (start1 end1 start2 end2) 
+			   'string<= s1 s2 maybe-starts+ends
+			   (if (and (eq? s1 s2) (= start1 start2)) ; Fast path
+			       (<= end1 end2)
+
+			       (%string-compare s1 start1 end1 s2 start2 end2 ; Real test
+						values
+						values
+						(lambda (i) #f)))))
+
+  (define (string>= s1 s2 . maybe-starts+ends)
+    (let-string-start+end2 (start1 end1 start2 end2) 
+			   'string>= s1 s2 maybe-starts+ends
+			   (if (and (eq? s1 s2) (= start1 start2)) ; Fast path
+			       (>= end1 end2)
+
+			       (%string-compare s1 start1 end1 s2 start2 end2 ; Real test
+						(lambda (i) #f)
+						values
+						values))))
+
+  (define (string-ci= s1 s2 . maybe-starts+ends)
+    (let-string-start+end2 (start1 end1 start2 end2) 
+			   'string-ci= s1 s2 maybe-starts+ends
+			   (and (= (- end1 start1) (- end2 start2)) ; Quick filter
+				(or (and (eq? s1 s2) (= start1 start2))	; Fast path
+				    (%string-compare-ci s1 start1 end1 s2 start2 end2 ; Real test
+							(lambda (i) #f)
+							values
+							(lambda (i) #f))))))
+
+  (define (string-ci<> s1 s2 . maybe-starts+ends)
+    (let-string-start+end2 (start1 end1 start2 end2) 
+			   'string-ci<> s1 s2 maybe-starts+ends
+			   (or (not (= (- end1 start1) (- end2 start2))) ; Fast path
+			       (and (not (and (eq? s1 s2) (= start1 start2))) ; Quick filter
+				    (%string-compare-ci s1 start1 end1 s2 start2 end2 ; Real test
+							values
+							(lambda (i) #f)
+							values)))))
+
+  (define (string-ci< s1 s2 . maybe-starts+ends)
+    (let-string-start+end2 (start1 end1 start2 end2) 
+			   'string-ci< s1 s2 maybe-starts+ends
+			   (if (and (eq? s1 s2) (= start1 start2)) ; Fast path
+			       (< end1 end2)
+
+			       (%string-compare-ci s1 start1 end1 s2 start2 end2 ; Real test
+						   values
+						   (lambda (i) #f)
+						   (lambda (i) #f)))))
+
+  (define (string-ci> s1 s2 . maybe-starts+ends)
+    (let-string-start+end2 (start1 end1 start2 end2) 
+			   'string-ci> s1 s2 maybe-starts+ends
+			   (if (and (eq? s1 s2) (= start1 start2)) ; Fast path
+			       (> end1 end2)
+
+			       (%string-compare-ci s1 start1 end1 s2 start2 end2 ; Real test
+						   (lambda (i) #f)
+						   (lambda (i) #f)
+						   values))))
+
+  (define (string-ci<= s1 s2 . maybe-starts+ends)
+    (let-string-start+end2 (start1 end1 start2 end2) 
+			   'string-ci<= s1 s2 maybe-starts+ends
+			   (if (and (eq? s1 s2) (= start1 start2)) ; Fast path
+			       (<= end1 end2)
+
+			       (%string-compare-ci s1 start1 end1 s2 start2 end2 ; Real test
+						   values
+						   values
+						   (lambda (i) #f)))))
+
+  (define (string-ci>= s1 s2 . maybe-starts+ends)
+    (let-string-start+end2 (start1 end1 start2 end2) 
+			   'string-ci>= s1 s2 maybe-starts+ends
+			   (if (and (eq? s1 s2) (= start1 start2)) ; Fast path
+			       (>= end1 end2)
+
+			       (%string-compare-ci s1 start1 end1 s2 start2 end2 ; Real test
+						   (lambda (i) #f)
+						   values
+						   values))))
+
+  
+  ;; Hash
+  ;; 
+  ;; Compute (c + 37 c + 37^2 c + ...) modulo BOUND, with sleaze thrown in
+  ;; to keep the intermediate values small. (We do the calculation with just
+  ;; enough bits to represent BOUND, masking off high bits at each step in
+  ;; calculation. If this screws up any important properties of the hash
+  ;; function I'd like to hear about it. -Olin)
+  ;; 
+  ;; If you keep BOUND small enough, the intermediate calculations will 
+  ;; always be fixnums. How small is dependent on the underlying Scheme system; 
+  ;; we use a default BOUND of 2^22 = 4194304, which should hack it in
+  ;; Schemes that give you at least 29 signed bits for fixnums. The core 
+  ;; calculation that you don't want to overflow is, worst case,
+  ;;     (+ 65535 (* 37 (- bound 1)))
+  ;; where 65535 is the max character code. Choose the default BOUND to be the
+  ;; biggest power of two that won't cause this expression to fixnum overflow, 
+  ;; and everything will be copacetic.
+
+  (define (%string-hash s char->int bound start end)
+    (let ((iref (lambda (s i) (char->int (string-ref s i))))
+	  ;; Compute a 111...1 mask that will cover BOUND-1:
+	  (mask (let lp ((i #x10000))	; Let's skip first 16 iterations, eh?
+		  (if (>= i bound) (- i 1) (lp (+ i i))))))
+      (let lp ((i start) (ans 0))
+	(if (>= i end) (modulo ans bound)
+	    (lp (+ i 1) (bitwise-and mask (+ (* 37 ans) (iref s i))))))))
+
+  (define string-hash
+    (opt-lambda (s (bound 4194304) (rest '()))
+      (check-arg (lambda (x)
+		   (and (integer? x)
+			(exact? x)
+			(<= 0 x)))
+		 bound 'string-hash)
+      (let ((bound (if (zero? bound) 4194304 bound))) ; 0 means default.
+	(let-string-start+end (start end) 'string-hash s rest
+			      (%string-hash s char->integer bound start end)))))
+
+  (define string-hash-ci
+    (opt-lambda (s (bound 4194304) (rest '()))
+      (check-arg (lambda (x)
+		   (and (integer? x)
+			(exact? x)
+			(<= 0 x)))
+		 bound 'string-hash-ci)
+      (let ((bound (if (zero? bound) 4194304 bound))) ; 0 means default.
+	(let-string-start+end (start end) 'string-hash-ci s rest
+			      (%string-hash s (lambda (c) (char->integer (char-downcase c)))
+					    bound start end)))))
+  
+  ;; Case hacking
+  ;; 
+  ;; string-upcase  s [start end]
+  ;; string-upcase! s [start end]
+  ;; string-downcase  s [start end]
+  ;; string-downcase! s [start end]
+  ;; 
+  ;; string-titlecase  s [start end]
+  ;; string-titlecase! s [start end]
+  ;;   Capitalize every contiguous alpha sequence: capitalise
+  ;;   first char, lowercase rest.
+
+  (define (string-upcase  s . maybe-start+end)
+    (let-string-start+end (start end) 'string-upcase s maybe-start+end
+			  (%string-map char-upcase s start end)))
+
+  (define (string-upcase! s . maybe-start+end)
+    (let-string-start+end (start end) 'string-upcase! s maybe-start+end
+			  (%string-map! char-upcase s start end)))
+
+  (define (string-downcase  s . maybe-start+end)
+    (let-string-start+end (start end) 'string-downcase s maybe-start+end
+			  (%string-map char-downcase s start end)))
+
+  (define (string-downcase! s . maybe-start+end)
+    (let-string-start+end (start end) 'string-downcase! s maybe-start+end
+			  (%string-map! char-downcase s start end)))
+
+  (define (char-cased? c)
+    (not (char=? (char-downcase c) (char-upcase c))))
+
+  (define (%string-titlecase! s start end)
+    (let lp ((i start))
+      (cond ((string-index s char-cased? i end) =>
+	     (lambda (i)
+	       (string-set! s i (char-titlecase (string-ref s i)))
+	       (let ((i1 (+ i 1)))
+		 (cond ((string-skip s char-cased? i1 end) =>
+			(lambda (j)
+			  (string-downcase! s i1 j)
+			  (lp (+ j 1))))
+		       (else (string-downcase! s i1 end)))))))))
+
+  (define (string-titlecase! s . maybe-start+end)
+    (let-string-start+end (start end) 'string-titlecase! s maybe-start+end
+			  (%string-titlecase! s start end)))
+
+  (define (string-titlecase s . maybe-start+end)
+    (let-string-start+end (start end) 'string-titlecase! s maybe-start+end
+			  (let ((ans (substring s start end)))
+			    (%string-titlecase! ans 0 (- end start))
+			    ans)))
+
+  
+  ;; Cutting & pasting strings
+  ;; 
+  ;; string-take string nchars
+  ;; string-drop string nchars
+  ;; 
+  ;; string-take-right string nchars
+  ;; string-drop-right string nchars
+  ;; 
+  ;; string-pad string k [char start end] 
+  ;; string-pad-right string k [char start end] 
+  ;; 
+  ;; string-trim       string [char/char-set/pred start end] 
+  ;; string-trim-right string [char/char-set/pred start end] 
+  ;; string-trim-both  string [char/char-set/pred start end] 
+  ;; 
+  ;; These trimmers invert the char-set meaning from MIT Scheme -- you
+  ;; say what you want to trim.
+
+  (define (string-take s n)
+    (check-arg string? s 'string-take)
+    (check-arg (lambda (val) (and (integer? n) (exact? n)
+				  (<= 0 n (string-length s))))
+	       n 'string-take)
+    (%substring/shared s 0 n))
+
+  (define (string-take-right s n)
+    (check-arg string? s 'string-take-right)
+    (let ((len (string-length s)))
+      (check-arg (lambda (val) (and (integer? n) (exact? n) (<= 0 n len)))
+		 n 'string-take-right)
+      (%substring/shared s (- len n) len)))
+
+  (define (string-drop s n)
+    (check-arg string? s 'string-drop)
+    (let ((len (string-length s)))
+      (check-arg (lambda (val) (and (integer? n) (exact? n) (<= 0 n len)))
+		 n 'string-drop)
+      (%substring/shared s n len)))
+
+  (define (string-drop-right s n)
+    (check-arg string? s 'string-drop-right)
+    (let ((len (string-length s)))
+      (check-arg (lambda (val) (and (integer? n) (exact? n) (<= 0 n len)))
+		 n 'string-drop-right)
+      (%substring/shared s 0 (- len n))))
+
+
+  (define string-trim
+    (opt-lambda (s (criterion char-set:whitespace) (rest '()))
+      (let-string-start+end (start end) 'string-trim s rest
+			    (cond ((string-skip s criterion start end) =>
+				   (lambda (i) (%substring/shared s i end)))
+				  (else "")))))
+
+  (define string-trim-right
+    (opt-lambda (s (criterion char-set:whitespace) (rest '()))
+      (let-string-start+end (start end) 'string-trim-right s rest
+			    (cond ((string-skip-right s criterion start end) =>
+				   (lambda (i) (%substring/shared s 0 (+ 1 i))))
+				  (else "")))))
+
+  (define string-trim-both
+    (opt-lambda (s (criterion char-set:whitespace) (rest '()))
+      (let-string-start+end (start end) 'string-trim-both s rest
+			    (cond ((string-skip s criterion start end) =>
+				   (lambda (i)
+				     (%substring/shared s i (+ 1 (string-skip-right s criterion i end)))))
+				  (else "")))))
+
+  (define string-pad-right
+    (opt-lambda (s n (char #\space) (rest '()))
+      (check-arg char? char 'string-pad-right)
+      (let-string-start+end (start end) 'string-pad-right s rest
+			    (check-arg (lambda (n) (and (integer? n) (exact? n) (<= 0 n)))
+				       n 'string-pad-right)
+			    (let ((len (- end start)))
+			      (if (<= n len)
+				  (%substring/shared s start (+ start n))
+				  (let ((ans (make-string n char)))
+				    (%string-copy! ans 0 s start end)
+				    ans))))))
+
+  (define string-pad
+    (opt-lambda (s n (char #\space) (rest '()))
+      (check-arg char? char 'string-pad)
+      (let-string-start+end (start end) 'string-pad s rest
+			    (check-arg (lambda (n) (and (integer? n) (exact? n) (<= 0 n)))
+				       n 'string-pad)
+			    (let ((len (- end start)))
+			      (if (<= n len)
+				  (%substring/shared s (- end n) end)
+				  (let ((ans (make-string n char)))
+				    (%string-copy! ans (- n len) s start end)
+				    ans))))))
+
+
+  
+  ;; Filtering strings
+  ;; 
+  ;; string-delete char/char-set/pred string [start end]
+  ;; string-filter char/char-set/pred string [start end]
+  ;; 
+  ;; If the criterion is a char or char-set, we scan the string twice with
+  ;;   string-fold -- once to determine the length of the result string, 
+  ;;   and once to do the filtered copy.
+  ;; If the criterion is a predicate, we don't do this double-scan strategy, 
+  ;;   because the predicate might have side-effects or be very expensive to
+  ;;   compute. So we preallocate a temp buffer pessimistically, and only do
+  ;;   one scan over S. This is likely to be faster and more space-efficient
+  ;;   than consing a list.
+
+  (define (string-delete criterion s . maybe-start+end)
+    (let-string-start+end (start end) 'string-delete s maybe-start+end
+			  (if (procedure? criterion)
+			      (let* ((slen (- end start))
+				     (temp (make-string slen))
+				     (ans-len (string-fold (lambda (c i)
+							     (if (criterion c) i
+								 (begin (string-set! temp i c)
+									(+ i 1))))
+							   0 s start end)))
+				(if (= ans-len slen) temp (substring temp 0 ans-len)))
+
+			      (let* ((cset (cond ((char-set? criterion) criterion)
+						 ((char? criterion) (char-set criterion))
+						 (else (error "string-delete criterion not predicate, char or char-set" criterion))))
+				     (len (string-fold (lambda (c i) (if (char-set-contains? cset c)
+									 i
+									 (+ i 1)))
+						       0 s start end))
+				     (ans (make-string len)))
+				(string-fold (lambda (c i) (if (char-set-contains? cset c)
+							       i
+							       (begin (string-set! ans i c)
+								      (+ i 1))))
+					     0 s start end)
+				ans))))
+
+  (define (string-filter criterion s . maybe-start+end)
+    (let-string-start+end (start end) 'string-filter s maybe-start+end
+			  (if (procedure? criterion)
+			      (let* ((slen (- end start))
+				     (temp (make-string slen))
+				     (ans-len (string-fold (lambda (c i)
+							     (if (criterion c)
+								 (begin (string-set! temp i c)
+									(+ i 1))
+								 i))
+							   0 s start end)))
+				(if (= ans-len slen) temp (substring temp 0 ans-len)))
+
+			      (let* ((cset (cond ((char-set? criterion) criterion)
+						 ((char? criterion) (char-set criterion))
+						 (else (error "string-delete criterion not predicate, char or char-set" criterion))))
+
+				     (len (string-fold (lambda (c i) (if (char-set-contains? cset c)
+									 (+ i 1)
+									 i))
+						       0 s start end))
+				     (ans (make-string len)))
+				(string-fold (lambda (c i) (if (char-set-contains? cset c)
+							       (begin (string-set! ans i c)
+								      (+ i 1))
+							       i))
+					     0 s start end)
+				ans))))
+
+  
+  ;; String search
+  ;; 
+  ;; string-index       string char/char-set/pred [start end]
+  ;; string-index-right string char/char-set/pred [start end]
+  ;; string-skip        string char/char-set/pred [start end]
+  ;; string-skip-right  string char/char-set/pred [start end]
+  ;; string-count       string char/char-set/pred [start end]
+  ;;     There's a lot of replicated code here for efficiency.
+  ;;     For example, the char/char-set/pred discrimination has
+  ;;     been lifted above the inner loop of each proc.
+
+  (define (string-index str criterion . maybe-start+end)
+    (let-string-start+end (start end) 'string-index str maybe-start+end
+			  (cond ((char? criterion)
+				 (let lp ((i start))
+				   (and (< i end)
+					(if (char=? criterion (string-ref str i)) i
+					    (lp (+ i 1))))))
+				((char-set? criterion)
+				 (let lp ((i start))
+				   (and (< i end)
+					(if (char-set-contains? criterion (string-ref str i)) i
+					    (lp (+ i 1))))))
+				((procedure? criterion)
+				 (let lp ((i start))
+				   (and (< i end)
+					(if (criterion (string-ref str i)) i
+					    (lp (+ i 1))))))
+				(else (error "Second param is neither char-set, char, or predicate procedure."
+					     string-index criterion)))))
+
+  (define (string-index-right str criterion . maybe-start+end)
+    (let-string-start+end (start end) 'string-index-right str maybe-start+end
+			  (cond ((char? criterion)
+				 (let lp ((i (- end 1)))
+				   (and (>= i 0)
+					(if (char=? criterion (string-ref str i)) i
+					    (lp (- i 1))))))
+				((char-set? criterion)
+				 (let lp ((i (- end 1)))
+				   (and (>= i 0)
+					(if (char-set-contains? criterion (string-ref str i)) i
+					    (lp (- i 1))))))
+				((procedure? criterion)
+				 (let lp ((i (- end 1)))
+				   (and (>= i 0)
+					(if (criterion (string-ref str i)) i
+					    (lp (- i 1))))))
+				(else (error "Second param is neither char-set, char, or predicate procedure."
+					     string-index-right criterion)))))
+
+  (define (string-skip str criterion . maybe-start+end)
+    (let-string-start+end (start end) 'string-skip str maybe-start+end
+			  (cond ((char? criterion)
+				 (let lp ((i start))
+				   (and (< i end)
+					(if (char=? criterion (string-ref str i))
+					    (lp (+ i 1))
+					    i))))
+				((char-set? criterion)
+				 (let lp ((i start))
+				   (and (< i end)
+					(if (char-set-contains? criterion (string-ref str i))
+					    (lp (+ i 1))
+					    i))))
+				((procedure? criterion)
+				 (let lp ((i start))
+				   (and (< i end)
+					(if (criterion (string-ref str i)) (lp (+ i 1))
+					    i))))
+				(else (error "Second param is neither char-set, char, or predicate procedure."
+					     string-skip criterion)))))
+
+  (define (string-skip-right str criterion . maybe-start+end)
+    (let-string-start+end (start end) 'string-skip-right str maybe-start+end
+			  (cond ((char? criterion)
+				 (let lp ((i (- end 1)))
+				   (and (>= i 0)
+					(if (char=? criterion (string-ref str i))
+					    (lp (- i 1))
+					    i))))
+				((char-set? criterion)
+				 (let lp ((i (- end 1)))
+				   (and (>= i 0)
+					(if (char-set-contains? criterion (string-ref str i))
+					    (lp (- i 1))
+					    i))))
+				((procedure? criterion)
+				 (let lp ((i (- end 1)))
+				   (and (>= i 0)
+					(if (criterion (string-ref str i)) (lp (- i 1))
+					    i))))
+				(else (error "CRITERION param is neither char-set or char."
+					     string-skip-right criterion)))))
+
+
+  (define (string-count s criterion . maybe-start+end)
+    (let-string-start+end (start end) 'string-count s maybe-start+end
+			  (cond ((char? criterion)
+				 (do ((i start (+ i 1))
+				      (count 0 (if (char=? criterion (string-ref s i))
+						   (+ count 1)
+						   count)))
+				     ((>= i end) count)))
+
+				((char-set? criterion)
+				 (do ((i start (+ i 1))
+				      (count 0 (if (char-set-contains? criterion (string-ref s i))
+						   (+ count 1)
+						   count)))
+				     ((>= i end) count)))
+
+				((procedure? criterion)
+				 (do ((i start (+ i 1))
+				      (count 0 (if (criterion (string-ref s i)) (+ count 1) count)))
+				     ((>= i end) count)))
+
+				(else (error "CRITERION param is neither char-set or char."
+					     string-count criterion)))))
+
+
+  
+  ;; 
+  ;; string-fill! string char [start end]
+  ;; 
+  ;; string-copy! to tstart from [fstart fend]
+  ;; 	Guaranteed to work, even if s1 eq s2.
+
+  (define (extended-string-fill! s char . maybe-start+end)
+    (check-arg char? char 'extended-string-fill!)
+    (let-string-start+end (start end) 'extended-string-fill! s maybe-start+end
+			  (do ((i (- end 1) (- i 1)))
+			      ((< i start))
+			    (string-set! s i char))))
+
+  ;; Library-internal routine
+  (define (%string-copy! to tstart from fstart fend)
+    (string-copy! to tstart from fstart fend))
+
+  
+  ;; Returns starting-position in STRING or #f if not true.
+  ;; This implementation is slow & simple. It is useful as a "spec" or for
+  ;; comparison testing with fancier implementations.
+  ;; See below for fast KMP version.
+
+;(define (string-contains string substring . maybe-starts+ends)
+;  (let-string-start+end2 (start1 end1 start2 end2) 
+;                         string-contains string substring maybe-starts+ends
+;    (let* ((len (- end2 start2))
+;	   (i-bound (- end1 len)))
+;      (let lp ((i start1))
+;	(and (< i i-bound)
+;	     (if (string= string substring i (+ i len) start2 end2)
+;		 i
+;		 (lp (+ i 1))))))))
+
+
+  ;; Searching for an occurrence of a substring
+  ;; 
+
+  (define (string-contains text pattern . maybe-starts+ends)
+    (let-string-start+end2 (t-start t-end p-start p-end)
+			   'string-contains text pattern maybe-starts+ends
+			   (%kmp-search pattern text char=? p-start p-end t-start t-end)))
+
+  (define (string-contains-ci text pattern . maybe-starts+ends)
+    (let-string-start+end2 (t-start t-end p-start p-end)
+			   'string-contains-ci text pattern maybe-starts+ends
+			   (%kmp-search pattern text char-ci=? p-start p-end t-start t-end)))
+
+
+  ;; Knuth-Morris-Pratt string searching
+  ;; 
+  ;; See
+  ;;     "Fast pattern matching in strings"
+  ;;     SIAM J. Computing 6(2):323-350 1977
+  ;;     D. E. Knuth, J. H. Morris and V. R. Pratt
+  ;; also described in
+  ;;     "Pattern matching in strings"
+  ;;     Alfred V. Aho
+  ;;     Formal Language Theory - Perspectives and Open Problems
+  ;;     Ronald V. Brook (editor)
+  ;; This algorithm is O(m + n) where m and n are the 
+  ;; lengths of the pattern and string respectively
+
+  ;; KMP search source[start,end) for PATTERN. Return starting index of
+  ;; leftmost match or #f.
+
+  (define (%kmp-search pattern text c= p-start p-end t-start t-end)
+    (let ((plen (- p-end p-start))
+	  (rv (make-kmp-restart-vector pattern c= p-start p-end)))
+
+      ;; The search loop. TJ & PJ are redundant state.
+      (let lp ((ti t-start) (pi 0)
+	       (tj (- t-end t-start)) ; (- tlen ti) -- how many chars left.
+	       (pj plen))	 ; (- plen pi) -- how many chars left.
+
+	(if (= pi plen)
+	    (- ti plen)			; Win.
+	    (and (<= pj tj)		; Lose.
+		 (if (c= (string-ref text ti) ; Search.
+			 (string-ref pattern (+ p-start pi)))
+		     (lp (+ 1 ti) (+ 1 pi) (- tj 1) (- pj 1)) ; Advance.
+		   
+		     (let ((pi (vector-ref rv pi))) ; Retreat.
+		       (if (= pi -1)
+			   (lp (+ ti 1) 0  (- tj 1) plen) ; Punt.
+			   (lp ti       pi tj       (- plen pi))))))))))
+
+  ;; (make-kmp-restart-vector pattern [c= start end]) -> integer-vector
+  ;; 
+  ;; Compute the KMP restart vector RV for string PATTERN.  If
+  ;; we have matched chars 0..i-1 of PATTERN against a search string S, and
+  ;; PATTERN[i] doesn't match S[k], then reset i := RV[i], and try again to
+  ;; match S[k].  If RV[i] = -1, then punt S[k] completely, and move on to
+  ;; S[k+1] and PATTERN[0] -- no possible match of PAT[0..i] contains S[k].
+  ;; 
+  ;; In other words, if you have matched the first i chars of PATTERN, but
+  ;; the i+1'th char doesn't match, RV[i] tells you what the next-longest
+  ;; prefix of PATTERN is that you have matched.
+  ;; 
+  ;; - C= (default CHAR=?) is used to compare characters for equality.
+  ;;   Pass in CHAR-CI=? for case-folded string search.
+  ;; 
+  ;; - START & END restrict the pattern to the indicated substring; the
+  ;;   returned vector will be of length END - START. The numbers stored
+  ;;   in the vector will be values in the range [0,END-START) -- that is,
+  ;;   they are valid indices into the restart vector; you have to add START
+  ;;   to them to use them as indices into PATTERN.
+  ;; 
+  ;; I've split this out as a separate function in case other constant-string
+  ;; searchers might want to use it.
+  ;; 
+  ;; E.g.:
+  ;;    a b d  a b x
+  ;; #(-1 0 0 -1 1 2)
+
+(define (make-kmp-restart-vector pattern . maybe-c=+start+end)
+  (let-optionals* maybe-c=+start+end
+                  ((c= char=? (procedure? c=))
+		   ((start end) (lambda (args)
+				  (string-parse-start+end make-kmp-restart-vector
+							  pattern args))))
+    (let* ((rvlen (- end start))
+	   (rv (make-vector rvlen -1)))
+      (if (> rvlen 0)
+	  (let ((rvlen-1 (- rvlen 1))
+		(c0 (string-ref pattern start)))
+
+	    ;; Here's the main loop. We have set rv[0] ... rv[i].
+	    ;; K = I + START -- it is the corresponding index into PATTERN.
+	    (let lp1 ((i 0) (j -1) (k start))	
+	      (if (< i rvlen-1)
+		  ;; lp2 invariant:
+		  ;;   pat[(k-j) .. k-1] matches pat[start .. start+j-1]
+		  ;;   or j = -1.
+		  (let lp2 ((j j))
+		    (cond ((= j -1)
+			   (let ((i1 (+ 1 i)))
+			     (if (not (c= (string-ref pattern (+ k 1)) c0))
+				 (vector-set! rv i1 0))
+			     (lp1 i1 0 (+ k 1))))
+			  ;; pat[(k-j) .. k] matches pat[start..start+j].
+			  ((c= (string-ref pattern k) (string-ref pattern (+ j start)))
+			   (let* ((i1 (+ 1 i))
+				  (j1 (+ 1 j)))
+			     (vector-set! rv i1 j1)
+			     (lp1 i1 j1 (+ k 1))))
+
+			  (else (lp2 (vector-ref rv j)))))))))
+      rv)))
+
+
+  ;; We've matched I chars from PAT. C is the next char from the search string.
+  ;; Return the new I after handling C. 
+  ;; 
+  ;; The pattern is (VECTOR-LENGTH RV) chars long, beginning at index PAT-START
+  ;; in PAT (PAT-START is usually 0). The I chars of the pattern we've matched
+  ;; are 
+  ;;     PAT[PAT-START .. PAT-START + I].
+  ;; 
+  ;; It's *not* an oversight that there is no friendly error checking or
+  ;; defaulting of arguments. This is a low-level, inner-loop procedure
+  ;; that we want integrated/inlined into the point of call.
+
+  (define (kmp-step pat rv c i c= p-start)
+    (let lp ((i i))
+      (if (c= c (string-ref pat (+ i p-start)))	; Match =>
+	  (+ i 1)			;   Done.
+	  (let ((i (vector-ref rv i)))	; Back up in PAT.
+	    (if (= i -1) 0		; Can't back up further.
+		(lp i))))))		; Keep trying for match.
+
+  ;; Zip through S[start,end), looking for a match of PAT. Assume we've
+  ;; already matched the first I chars of PAT when we commence at S[start].
+  ;; - <0:  If we find a match *ending* at index J, return -J.
+  ;; - >=0: If we get to the end of the S[start,end) span without finding
+  ;;   a complete match, return the number of chars from PAT we'd matched
+  ;;   when we ran off the end.
+  ;; 
+  ;; This is useful for searching *across* buffers -- that is, when your
+  ;; input comes in chunks of text. We hand-integrate the KMP-STEP loop
+  ;; for speed.
+
+  (define string-kmp-partial-search
+    (opt-lambda (pat rv s i (c= char=?) (p-start 0) . start+end)
+      (check-arg procedure? c= 'string-kmp-partial-search)
+      (check-arg vector? rv 'string-kmp-partial-search)
+      (check-arg (lambda (x)
+		   (and (integer? x) (exact? x) (<= 0 x))) p-start 'string-kmp-partial-search)
+      
+      (let-values ([(rest s-start s-end) (string-parse-start+end 'string-kmp-partial-search
+								 s start+end)])
+	(let ((patlen (vector-length rv)))
+	  (check-arg (lambda (i) (and (integer? i) (exact? i) (<= 0 i) (< i patlen)))
+		     i 'string-kmp-partial-search)
+
+	  ;; Enough prelude. Here's the actual code.
+	  (let lp ((si s-start)		; An index into S.
+		   (vi i))		; An index into RV.
+	    (cond ((= vi patlen) (- si)) ; Win.
+		  ((= si s-end) vi)	; Ran off the end.
+		  (else			; Match s[si] & loop.
+		   (let ((c (string-ref s si)))
+		     (lp (+ si 1)	
+			 (let lp2 ((vi vi)) ; This is just KMP-STEP.
+			   (if (c= c (string-ref pat (+ vi p-start)))
+			       (+ vi 1)
+			       (let ((vi (vector-ref rv vi)))
+				 (if (= vi -1) 0
+				     (lp2 vi))))))))))))))
+
+  
+  ;; Misc
+  ;; 
+  ;; (string-null? s)
+  ;; (string-reverse  s [start end])
+  ;; (string-reverse! s [start end])
+  ;; (reverse-list->string clist)
+  ;; (extended-string->list s [start end])
+
+  (define (string-null? s) (zero? (string-length s)))
+
+  (define (string-reverse s . maybe-start+end)
+    (let-string-start+end (start end) 'string-reverse s maybe-start+end
+			  (let* ((len (- end start))
+				 (ans (make-string len)))
+			    (do ((i start (+ i 1))
+				 (j (- len 1) (- j 1)))
+				((< j 0))
+			      (string-set! ans j (string-ref s i)))
+			    ans)))
+
+  (define (string-reverse! s . maybe-start+end)
+    (let-string-start+end (start end) 'string-reverse! s maybe-start+end
+			  (do ((i (- end 1) (- i 1))
+			       (j start (+ j 1)))
+			      ((<= i j))
+			    (let ((ci (string-ref s i)))
+			      (string-set! s i (string-ref s j))
+			      (string-set! s j ci)))))
+
+
+  (define (reverse-list->string clist)
+    (let* ((len (length clist))
+	   (s (make-string len)))
+      (do ((i (- len 1) (- i 1))   (clist clist (cdr clist)))
+	  ((not (pair? clist)))
+	(string-set! s i (car clist)))
+      s))
+
+
+  ;; (define (extended-string->list s . maybe-start+end)
+  ;;  (apply string-fold-right cons '() s maybe-start+end))
+
+  (define (extended-string->list s . maybe-start+end)
+    (let-string-start+end (start end) 'extended-string->list s maybe-start+end
+			  (do ((i (- end 1) (- i 1))
+			       (ans '() (cons (string-ref s i) ans)))
+			      ((< i start) ans))))
+
+  ;; Defined by R5RS, so commented out here.
+;(define (list->string lis) (string-unfold null? car cdr lis))
+
+
+  ;; string-concatenate        string-list -> string
+  ;; string-concatenate/shared string-list -> string
+  ;; string-append/shared s ... -> string
+  ;; 
+  ;; STRING-APPEND/SHARED has license to return a string that shares storage
+  ;; with any of its arguments. In particular, if there is only one non-empty
+  ;; string amongst its parameters, it is permitted to return that string as
+  ;; its result. STRING-APPEND, by contrast, always allocates new storage.
+  ;; 
+  ;; STRING-CONCATENATE & STRING-CONCATENATE/SHARED are passed a list of
+  ;; strings, which they concatenate into a result string. STRING-CONCATENATE
+  ;; always allocates a fresh string; STRING-CONCATENATE/SHARED may (or may
+  ;; not) return a result that shares storage with any of its arguments. In
+  ;; particular, if it is applied to a singleton list, it is permitted to
+  ;; return the car of that list as its value.
+
+  (define (string-append/shared . strings) (string-concatenate/shared strings))
+
+  (define (string-concatenate/shared strings)
+    (let lp ((strings strings) (nchars 0) (first #f))
+      (cond ((pair? strings)		; Scan the args, add up total
+	     (let* ((string  (car strings)) ; length, remember 1st 
+		    (tail (cdr strings)) ; non-empty string.
+		    (slen (string-length string)))
+	       (if (zero? slen)
+		   (lp tail nchars first)
+		   (lp tail (+ nchars slen) (or first strings)))))
+
+	    ((zero? nchars) "")
+
+	    ;; Just one non-empty string! Return it.
+	    ((= nchars (string-length (car first))) (car first))
+
+	    (else (let ((ans (make-string nchars)))
+		    (let lp ((strings first) (i 0))
+		      (if (pair? strings)
+			  (let* ((s (car strings))
+				 (slen (string-length s)))
+			    (%string-copy! ans i s 0 slen)
+			    (lp (cdr strings) (+ i slen)))))
+		    ans)))))
+	
+
+; Alas, Scheme 48's APPLY blows up if you have many, many arguments.
+;(define (string-concatenate strings) (apply string-append strings))
+
+  ;; Here it is written out. I avoid using REDUCE to add up string lengths
+  ;; to avoid non-R5RS dependencies.
+  (define (string-concatenate strings)
+    (let* ((total (do ((strings strings (cdr strings))
+		       (i 0 (+ i (string-length (car strings)))))
+		      ((not (pair? strings)) i)))
+	   (ans (make-string total)))
+      (let lp ((i 0) (strings strings))
+	(if (pair? strings)
+	    (let* ((s (car strings))
+		   (slen (string-length s)))
+	      (%string-copy! ans i s 0 slen)
+	      (lp (+ i slen) (cdr strings)))))
+      ans))
+	
+
+  ;; Defined by R5RS, so commented out here.
+;(define (string-append . strings) (string-concatenate strings))
+
+  ;; string-concatenate-reverse        string-list [final-string end] -> string
+  ;; string-concatenate-reverse/shared string-list [final-string end] -> string
+  ;; 
+  ;; Return
+  ;;   (string-concatenate 
+  ;;     (reverse
+  ;;       (cons (substring final-string 0 end) string-list)))
+
+  (define string-concatenate-reverse
+    (opt-lambda (string-list (final "") (end (string-length final)))
+      (check-arg string? final 'string-concatenate-reverse)
+      (check-arg (lambda (x)
+		   (and (integer? x) (exact? x) (<= 0 x (string-length final))))
+		 end 'string-concatenate-reverse)
+      (let ((len (let lp ((sum 0) (lis string-list))
+		   (if (pair? lis)
+		       (lp (+ sum (string-length (car lis))) (cdr lis))
+		       sum))))
+
+	(%finish-string-concatenate-reverse len string-list final end))))
+
+  (define string-concatenate-reverse/shared
+    (opt-lambda (string-list (final "") (end (string-length final)))
+      (check-arg string? final 'string-concatenate-reverse/shared)
+      (check-arg (lambda (x)
+		   (and (integer? x) (exact? x) (<= 0 x (string-length final))))
+		 end 'string-concatenate-reverse/shared)
+      ;; Add up the lengths of all the strings in STRING-LIST; also get a
+      ;; pointer NZLIST into STRING-LIST showing where the first non-zero-length
+      ;; string starts.
+      (let lp ((len 0) (nzlist #f) (lis string-list))
+	(if (pair? lis)
+	    (let ((slen (string-length (car lis))))
+	      (lp (+ len slen)
+		  (if (or nzlist (zero? slen)) nzlist lis)
+		  (cdr lis)))
+
+	    (cond ((zero? len) (substring/shared final 0 end))
+
+		  ;; LEN > 0, so NZLIST is non-empty.
+
+		  ((and (zero? end) (= len (string-length (car nzlist))))
+		   (car nzlist))
+
+		  (else (%finish-string-concatenate-reverse len nzlist final end)))))))
+
+  (define (%finish-string-concatenate-reverse len string-list final end)
+    (let ((ans (make-string (+ end len))))
+      (%string-copy! ans len final 0 end)
+      (let lp ((i len) (lis string-list))
+	(if (pair? lis)
+	    (let* ((s   (car lis))
+		   (lis (cdr lis))
+		   (slen (string-length s))
+		   (i (- i slen)))
+	      (%string-copy! ans i s 0 slen)
+	      (lp i lis))))
+      ans))
+
+
+
+
+  ;; string-replace s1 s2 start1 end1 [start2 end2] -> string
+  ;; 
+  ;; Replace S1[START1,END1) with S2[START2,END2).
+
+  (define (string-replace s1 s2 start1 end1 . maybe-start+end)
+    (check-substring-spec string-replace s1 start1 end1)
+    (let-string-start+end (start2 end2) 'string-replace s2 maybe-start+end
+			  (let* ((slen1 (string-length s1))
+				 (sublen2 (- end2 start2))
+				 (alen (+ (- slen1 (- end1 start1)) sublen2))
+				 (ans (make-string alen)))
+			    (%string-copy! ans 0 s1 0 start1)
+			    (%string-copy! ans start1 s2 start2 end2)
+			    (%string-copy! ans (+ start1 sublen2) s1 end1 slen1)
+			    ans)))
+
+
+  ;; string-tokenize s [token-set start end] -> list
+  ;; 
+  ;; Break S up into a list of token strings, where a token is a maximal
+  ;; non-empty contiguous sequence of chars belonging to TOKEN-SET.
+  ;; (string-tokenize "hello, world") => ("hello," "world")
+
+  (define string-tokenize
+    (opt-lambda (s (token-chars char-set:graphic) . rest)
+      (check-arg char-set? token-chars 'string-tokenize)
+      (let-string-start+end (start end) 'string-tokenize s rest
+			    (let lp ((i end) (ans '()))
+			      (cond ((and (< start i) (string-index-right s token-chars start i)) =>
+				     (lambda (tend-1)
+				       (let ((tend (+ 1 tend-1)))
+					 (cond ((string-skip-right s token-chars start tend-1) =>
+						(lambda (tstart-1)
+						  (lp tstart-1
+						      (cons (substring s (+ 1 tstart-1) tend)
+							    ans))))
+					       (else (cons (substring s start tend) ans))))))
+				    (else ans))))))
+
+  
+  ;; xsubstring s from [to start end] -> string
+  ;; 
+  ;; S is a string; START and END are optional arguments that demarcate
+  ;; a substring of S, defaulting to 0 and the length of S (e.g., the whole
+  ;; string). Replicate this substring up and down index space, in both the
+  ;;  positive and negative directions. For example, if S = "abcdefg", START=3, 
+  ;; and END=6, then we have the conceptual bidirectionally-infinite string
+  ;;     ...  d  e  f  d  e  f  d  e  f  d  e  f  d  e  f  d  e  f  d  e  f ...
+  ;;     ... -9 -8 -7 -6 -5 -4 -3 -2 -1  0  1  2  3  4  5  6  7  8  9 ...
+  ;; XSUBSTRING returns the substring of this string beginning at index FROM,
+  ;; and ending at TO (which defaults to FROM+(END-START)).
+  ;; 
+  ;; You can use XSUBSTRING in many ways:
+  ;; - To rotate a string left:  (xsubstring "abcdef" 2)  => "cdefab"
+  ;; - To rotate a string right: (xsubstring "abcdef" -2) => "efabcd"
+  ;; - To replicate a string:    (xsubstring "abc" 0 7) => "abcabca"
+  ;; 
+  ;; Note that 
+  ;;   - The FROM/TO indices give a half-open range -- the characters from
+  ;;     index FROM up to, but not including index TO.
+  ;;   - The FROM/TO indices are not in terms of the index space for string S.
+  ;;     They are in terms of the replicated index space of the substring
+  ;;     defined by S, START, and END.
+  ;; 
+  ;; It is an error if START=END -- although this is allowed by special
+  ;; dispensation when FROM=TO.
+
+  (define (xsubstring s from . maybe-to+start+end)
+    (check-arg (lambda (val) (and (integer? val) (exact? val)))
+	       from 'xsubstring)
+    (receive (to start end)
+	     (if (pair? maybe-to+start+end)
+		 (let-string-start+end (start end) 'xsubstring s (cdr maybe-to+start+end)
+				       (let ((to (car maybe-to+start+end)))
+					 (check-arg (lambda (val) (and (integer? val)
+								       (exact? val)
+								       (<= from val)))
+						    to 'xsubstring)
+					 (values to start end)))
+		 (let ((slen (string-length (check-arg string? s 'xsubstring))))
+		   (values (+ from slen) 0 slen)))
+	     (let ((slen   (- end start))
+		   (anslen (- to  from)))
+	       (cond ((zero? anslen) "")
+		     ((zero? slen) (error xsubstring "Cannot replicate empty (sub)string ~a ~a ~a ~a ~a" s from to start end))
+
+		     ((= 1 slen)	; Fast path for 1-char replication.
+		      (make-string anslen (string-ref s start)))
+
+		     ;; Selected text falls entirely within one span.
+		     ((= (floor (/ from slen)) (floor (/ to slen)))
+		      (substring s (+ start (modulo from slen))
+				 (+ start (modulo to   slen))))
+
+		     ;; Selected text requires multiple spans.
+		     (else (let ((ans (make-string anslen)))
+			     (%multispan-repcopy! ans 0 s from to start end)
+			     ans))))))
+
+
+  ;; string-xcopy! target tstart s sfrom [sto start end] -> unspecific
+  ;; 
+  ;; Exactly the same as xsubstring, but the extracted text is written
+  ;; into the string TARGET starting at index TSTART.
+  ;; This operation is not defined if (EQ? TARGET S) -- you cannot copy
+  ;; a string on top of itself.
+
+  (define (string-xcopy! target tstart s sfrom . maybe-sto+start+end)
+    (check-arg (lambda (val) (and (integer? val) (exact? val)))
+	       sfrom 'string-xcopy!)
+    (receive (sto start end)
+	     (if (pair? maybe-sto+start+end)
+		 (let-string-start+end (start end) 'string-xcopy! s (cdr maybe-sto+start+end)
+				       (let ((sto (car maybe-sto+start+end)))
+					 (check-arg (lambda (val) (and (integer? val) (exact? val)))
+						    sto 'string-xcopy!)
+					 (values sto start end)))
+		 (let ((slen (string-length s)))
+		   (values (+ sfrom slen) 0 slen)))
+
+	     (let* ((tocopy (- sto sfrom))
+		    (tend (+ tstart tocopy))
+		    (slen (- end start)))
+	       (check-substring-spec string-xcopy! target tstart tend)
+	       (cond ((zero? tocopy))
+		     ((zero? slen) (error 'string-xcopy! "Cannot replicate empty (sub)string: ~a ~a ~a ~a ~a ~a ~a" target tstart s sfrom sto start end))
+
+		     ((= 1 slen)	; Fast path for 1-char replication.
+		      (extended-string-fill! target (string-ref s start) tstart tend))
+
+		     ;; Selected text falls entirely within one span.
+		     ((= (floor (/ sfrom slen)) (floor (/ sto slen)))
+		      (%string-copy! target tstart s 
+				     (+ start (modulo sfrom slen))
+				     (+ start (modulo sto   slen))))
+
+		     ;; Multi-span copy.
+		     (else (%multispan-repcopy! target tstart s sfrom sto start end))))))
+
+  ;; This is the core copying loop for XSUBSTRING and STRING-XCOPY!
+  ;; Internal -- not exported, no careful arg checking.
+  (define (%multispan-repcopy! target tstart s sfrom sto start end)
+    (let* ((slen (- end start))
+	   (i0 (+ start (modulo sfrom slen)))
+	   (total-chars (- sto sfrom)))
+
+      ;; Copy the partial span @ the beginning
+      (%string-copy! target tstart s i0 end)
+	    
+      (let* ((ncopied (- end i0))	; We've copied this many.
+	     (nleft (- total-chars ncopied)) ; # chars left to copy.
+	     (nspans (quotient nleft slen))) ; # whole spans to copy
+	      
+	;; Copy the whole spans in the middle.
+	(do ((i (+ tstart ncopied) (+ i slen)) ; Current target index.
+	     (nspans nspans (- nspans 1))) ; # spans to copy
+	    ((zero? nspans)
+	     ;; Copy the partial-span @ the end & we're done.
+	     (%string-copy! target i s start (+ start (- total-chars (- i tstart)))))
+
+	  (%string-copy! target i s start end))))) ; Copy a whole span.
+
+
+  
+  ;; (string-join string-list [delimiter grammar]) => string
+  ;; 
+  ;; Paste strings together using the delimiter string.
+  ;; 
+  ;; (join-strings '("foo" "bar" "baz") ":") => "foo:bar:baz"
+  ;; 
+  ;; DELIMITER defaults to a single space " "
+  ;; GRAMMAR is one of the symbols {prefix, infix, strict-infix, suffix} 
+  ;; and defaults to 'infix.
+  ;; 
+  ;; I could rewrite this more efficiently -- precompute the length of the
+  ;; answer string, then allocate & fill it in iteratively. Using 
+  ;; STRING-CONCATENATE is less efficient.
+
+  (define string-join
+    (opt-lambda (strings (delim " ") (grammar 'infix))
+      (check-arg string? delim 'string-join)
+      (let ((buildit (lambda (lis final)
+		       (let recur ((lis lis))
+			 (if (pair? lis)
+			     (cons delim (cons (car lis) (recur (cdr lis))))
+			     final)))))
+
+	(cond ((pair? strings)
+	       (string-concatenate
+		(case grammar
+
+		  ((infix strict-infix)
+		   (cons (car strings) (buildit (cdr strings) '())))
+
+		  ((prefix) (buildit strings '()))
+
+		  ((suffix)
+		   (cons (car strings) (buildit (cdr strings) (list delim))))
+
+		  (else (error "Illegal join grammar"
+			       grammar string-join)))))
+
+	      ((not (null? strings))
+	       (error "STRINGS parameter not list." strings string-join))
+
+	      ;; STRINGS is ()
+
+	      ((eq? grammar 'strict-infix)
+	       (error "Empty list cannot be joined with STRICT-INFIX grammar."
+		      string-join))
+
+	      (else "")))))		; Special-cased for infix grammar.
+
+  )
+
+;; string.ss ends here
diff --git a/collects/srfi/14.ss b/collects/srfi/14.ss
new file mode 100644
index 0000000000..6f028aa0fc
--- /dev/null
+++ b/collects/srfi/14.ss
@@ -0,0 +1,4 @@
+;; module loader for SRFI-14
+(module |14| mzscheme
+  (require (lib "char-set.ss" "srfi" "14"))
+  (provide (all-from (lib "char-set.ss" "srfi" "14"))))
diff --git a/collects/srfi/14/.cvsignore b/collects/srfi/14/.cvsignore
new file mode 100644
index 0000000000..e3ca6473f7
--- /dev/null
+++ b/collects/srfi/14/.cvsignore
@@ -0,0 +1 @@
+compiled
diff --git a/collects/srfi/14/char-set.ss b/collects/srfi/14/char-set.ss
new file mode 100644
index 0000000000..62f72d0f4c
--- /dev/null
+++ b/collects/srfi/14/char-set.ss
@@ -0,0 +1,460 @@
+
+;; Since Matthew implemented this module, tests are in
+;;  plt/collects/tests/mzscheme/char-set.ss.
+;; Since Mike Sperber looked carefully at this module,
+;;  the code and tests are a lot better than they would be.
+
+(module char-set mzscheme
+  (require (lib "integer-set.ss")
+	   (all-except (lib "contract.ss") union)
+	   (rename (lib "contract.ss") union/c union))
+
+  ;; Data defn ----------------------------------------
+    
+  (define-struct char-set (set/thunk))
+
+  (define (fold-set op init l)
+    (if (null? l)
+	init
+	(fold-set op (op init (car l)) (cdr l))))
+
+  (define (char-set-set cs)
+    (let ([v (char-set-set/thunk cs)])
+      (if (procedure? v)
+	  (let ([v2 (v)])
+	    (set-char-set-set/thunk! cs v2)
+	    v2)
+	  v)))
+
+  ;; General procedures ----------------------------------------
+  
+  (define char-set=
+    (case-lambda
+     [() #t]
+     [(cs) #t]
+     [(cs1 cs2) (equal? (integer-set-contents (char-set-set cs1))
+			(integer-set-contents (char-set-set cs2)))]
+     [(cs1 . rest) (fold-set (lambda (v cs) (and v (char-set= cs1 cs))) #t rest)]))
+  
+  (define char-set<=
+    (case-lambda
+     [() #t]
+     [(cs) #t]
+     [(cs1 cs2) (subset? (char-set-set cs1) (char-set-set cs2))]
+     [(cs1 . rest) (and (fold-set (lambda (cs1 cs) (and cs1 (char-set<= cs1 cs) cs)) cs1 rest) #t)]))
+  
+  (define char-set-hash
+    (case-lambda
+     [(cs)
+      (abs (equal-hash-code (char-set-set cs)))]
+     [(cs bound)
+      (modulo (char-set-hash cs) bound)]))
+
+  ;; Iterating over character sets ----------------------------------------
+
+  ;; A cursor is (cons num (list-of (cons start-num end-num)))
+  ;;  where the first num indicates how far we are into the
+  ;;; first range of the cdr of the cursor.
+
+  (define (char-set-cursor cs)
+    (cons 0 (integer-set-contents (char-set-set cs))))
+
+  (define (char-set-ref cs c)
+    (integer->char (+ (car c) (caadr c))))
+
+  (define (char-set-cursor-next cs c)
+    (let ([d (- (cdadr c) (caadr c))])
+      (if (= d (car c))
+	  (cons 0 (cddr c))
+	  (cons (add1 (car c)) (cdr c)))))
+
+  (define (end-of-char-set? c)
+    (null? (cdr c)))
+
+  (define (char-set-fold/done kons knil cs done?)
+    (let loop ([v knil][l (integer-set-contents (char-set-set cs))])
+      (if (null? l)
+	  v
+	  (let ([end (cdar l)])
+	    (let iloop ([v v][i (caar l)])
+	      (if (i . > . end)
+		  (loop v (cdr l))
+		  (let ([v (kons (integer->char i) v)])
+		    (if (done? v)
+			v
+			(iloop v (add1 i))))))))))
+
+  (define (char-set-fold kons knil cs)
+    (char-set-fold/done kons knil cs (lambda (x) #f)))
+
+  (define char-set-unfold
+    (case-lambda
+     [(p f g seed) (char-set-unfold p f g seed char-set:empty)]
+     [(p f g seed base-cs)
+      ;; Implementation taken directly from SRFI-14:
+      (let lp ((seed seed) (cs base-cs))
+        (if (p seed) 
+	    cs ; P says we are done.
+            (lp (g seed) ; Loop on (G SEED).
+                (char-set-adjoin! cs (f seed)))))]))
+
+  (define (char-set-unfold! p f g seed base-cs)
+    (char-set-unfold p f g seed base-cs))
+  
+  (define (char-set-for-each proc cs)
+    (char-set-fold (lambda (c v) (proc c)) (void) cs))
+
+  (define (char-set-map proc cs)
+    ;; Note: no order defined on cs traversal, so it doesn't
+    ;;  matter that we build up the list backward
+    (char-set-fold (lambda (c v) (char-set-adjoin v (proc c))) char-set:empty cs))
+
+
+  ;; Creating character sets ----------------------------------------
+
+  (define (char-set-copy cs) 
+    ;; Our char sets are purely functional:
+    cs)
+
+  (define mk-char-set
+    (let ([char-set (lambda more
+		      (list->char-set more char-set:empty))])
+      char-set))
+
+  (define list->char-set 
+    (case-lambda
+     [(l) (list->char-set l char-set:empty)]
+     [(l cs) (fold-set char-set-adjoin cs l)]))
+  (define (list->char-set! l cs)
+    (list->char-set l cs))
+
+  (define string->char-set
+    (case-lambda
+     [(s) (string->char-set s char-set:empty)]
+     [(s cs) (list->char-set (string->list s) cs)]))
+  (define (string->char-set! s cs)
+    (string->char-set s cs))
+
+  (define char-set-filter
+    (case-lambda
+     [(pred cs) (char-set-filter pred cs char-set:empty)]
+     [(pred cs base-cs)
+      (char-set-fold (lambda (c v) (if (pred c)
+				       (char-set-adjoin v c)
+				       v))
+		     base-cs
+		     cs)]))
+  (define (char-set-filter! pred cs base-cs)
+    (char-set-filter pred cs base-cs))
+
+  (define ucs-range->char-set
+    (case-lambda
+     [(lower upper) (ucs-range->char-set lower upper #f char-set:empty)]
+     [(lower upper error?) (ucs-range->char-set lower upper error? char-set:empty)]
+     [(lower upper error? cs)
+      (when (or (lower . < . 0)
+		(upper . > . #x110000)
+		(lower . >= . upper))
+	(raise (make-exn:fail:contract
+		(string->immutable-string
+		 (format "ucs-range->char-set: invalid range: [~a, ~a)" lower upper))
+		(current-continuation-marks))))
+      (char-set-union cs
+		      (cond
+		       [(and (upper . <= . #xE000)
+			     (lower . >= . #xD800))
+			;; Completely in the hole
+			char-set:empty]
+		       [(upper . <= . #xE000)
+			;; Below the hole
+			(make-char-set (make-integer-set (list (cons lower (sub1 (min #xD800 upper))))))]
+		       [(lower . >= . #xD800)
+			;; Above the hole
+			(make-char-set (make-integer-set (list (cons (max #xE000 lower) (sub1 upper)))))]
+		       [else
+			;; Spans the hole:
+			(make-char-set (make-integer-set (list (cons lower #xD7FF)
+							       (cons #xE000 (sub1 upper)))))]))]))
+  (define (ucs-range->char-set! lower upper error? base-cs)
+    (ucs-range->char-set lower upper error? base-cs))
+
+  (define (->char-set x)
+    (cond
+     [(char? x) (let ([v (char->integer x)])
+		  (make-char-set (make-integer-set (list (cons v v)))))]
+     [(string? x) (string->char-set x)]
+     [(char-set? x) x]
+     [else (raise-type-error '->char-set "character, string, or char-set" x)]))
+
+  ;; Querying character sets ----------------------------------------
+
+  (define (char-set-size cs)
+    (let loop ([l (integer-set-contents (char-set-set cs))][c 0])
+      (if (null? l)
+	  c
+	  (loop (cdr l) (+ c 1 (- (cdar l) (caar l)))))))
+
+  (define (char-set-count pred cs)
+    (char-set-fold (lambda (c v)
+		     (+ v (if (pred c) 1 0)))
+		   0
+		   cs))
+
+  (define (char-set->list cs)
+    (char-set-fold cons null cs))
+    
+  (define (char-set->string cs)
+    (list->string (char-set->list cs)))
+
+  (define (char-set-contains? cs char)
+    (member? (char->integer char) (char-set-set cs)))
+  
+  (define (char-set-every pred cs)
+    (char-set-fold/done (lambda (c v)
+			  (and v
+			       (pred c)))
+			#t
+			cs
+			not))
+
+  (define (char-set-any pred cs)
+    (char-set-fold/done (lambda (c v)
+			  (or v
+			      (pred c)))
+			#f
+			cs
+			values))
+  
+  ;; Character-set algebra ----------------------------------------
+
+  (define char-set-adjoin 
+    (case-lambda
+     [(cs char1) 
+      (let ([v (char->integer char1)])
+	(make-char-set (union (char-set-set cs)
+			      (make-integer-set (list (cons v v))))))]
+     [(cs . more)
+      (fold-set char-set-adjoin cs more)]))
+
+  (define char-set-delete 
+    (case-lambda
+     [(cs char1) 
+      (let ([v (char->integer char1)])
+	(make-char-set (difference (char-set-set cs)
+				   (make-integer-set (list (cons v v))))))]
+     [(cs . more)
+      (fold-set char-set-delete cs more)]))
+
+  (define (char-set-complement cs)
+    (make-char-set
+     (union (complement (char-set-set cs) #x0 #xD7FF)
+	    (complement (char-set-set cs) #xE000 #x10FFFF))))
+
+  (define-syntax define-set-op
+    (syntax-rules ()
+      [(_ char-set-op set-op neutral)
+       (define char-set-op 
+	 (case-lambda
+	  [(cs1 cs2)
+	   (make-char-set (set-op (char-set-set cs1) (char-set-set cs2)))]
+	  [() 
+	   neutral]
+	  [(cs1 . more)
+	   (fold-set char-set-op cs1 more)]))]))
+
+  (define-set-op char-set-union union char-set:empty)
+  (define-set-op char-set-intersection intersect char-set:full)
+  (define char-set-difference
+    (case-lambda
+     [(cs1 cs2)
+      (make-char-set (difference (char-set-set cs1) (char-set-set cs2)))]
+     [(cs1 . more)
+      (fold-set char-set-difference cs1 more)]))
+  (define-set-op char-set-xor xor char-set:empty)
+
+  (define char-set-diff+intersection
+    (case-lambda
+     [(cs1 cs2)
+      (let-values ([(cs1^cs2 cs1-cs2 cs2-cs1) (split (char-set-set cs1) (char-set-set cs2))])
+	(values (make-char-set cs1-cs2)
+		(make-char-set cs1^cs2)))]
+     [(cs1 cs2 . more)
+      (let-values ([(d i) (char-set-diff+intersection cs1 cs2)])
+	(values (apply char-set-difference d more)
+		(apply char-set-intersection i more)))]))
+
+  (define char-set-adjoin! char-set-adjoin)
+  (define char-set-delete! char-set-delete)
+  (define char-set-complement! char-set-complement)
+  (define char-set-union! char-set-union)
+  (define char-set-intersection! char-set-intersection)
+  (define char-set-difference! char-set-difference)
+  (define char-set-xor! char-set-xor)
+  (define char-set-diff+intersection! char-set-diff+intersection)
+
+  ;; ----------------------------------------
+
+  ;; MzScheme provides a rough map to unicode:
+  (define unicode (make-known-char-range-list))
+
+  (define (make-standard-set pred?)
+    (make-char-set
+     (lambda ()
+       (make-integer-set
+	(let loop ([l unicode])
+	  (cond
+	   [(null? l) null]
+	   [(caddar l) 
+	    ;; Every char in this range has the same properites
+	    (if (pred? (integer->char (caar l)))
+		(cons (cons (caar l) (cadar l)) (loop (cdr l)))
+		(loop (cdr l)))]
+	   [else
+	    ;; Check char-by-char:
+	    (let ([end (cadar l)])
+	      (let no-loop ([v (caar l)])
+		(cond
+		 [(v . > . end)
+		  ;; None in this range
+		  (loop (cdr l))]
+		 [(pred? (integer->char v))
+		  ;; Found a char in this range
+		  (let yes-loop ([v2 (add1 v)])
+		    (cond
+		     [(v2 . > . end)
+		      ;; Went to end
+		      (cons (cons v (sub1 v2)) (loop (cdr l)))]
+		     [(pred? (integer->char v2))
+		      (yes-loop (add1 v2))]
+		     [else
+		      ;; Found end of sub-range; treat the rest
+		      ;;  of this range as a new range
+		      (cons (cons v (sub1 v2))
+			    (loop (cons (list v2 end #f) (cdr l))))]))]
+		 [else
+		  ;; Still looking for a char in this range
+		  (no-loop (add1 v))])))]))))))
+
+  (define char-set:lower-case
+    (make-standard-set char-lower-case?))
+  (define char-set:upper-case
+    (make-standard-set char-upper-case?))
+  (define char-set:title-case
+    (make-standard-set char-title-case?))
+  (define char-set:letter
+    (make-standard-set char-alphabetic?))
+  (define char-set:digit
+    (make-standard-set char-numeric?))
+  (define char-set:letter+digit
+    (char-set-union char-set:letter char-set:digit))
+  (define char-set:graphic
+    (make-standard-set char-graphic?))
+  (define char-set:whitespace
+    (make-standard-set char-whitespace?))
+  (define char-set:printing
+    (char-set-union char-set:whitespace char-set:graphic))
+  (define char-set:iso-control
+    (make-standard-set char-iso-control?))
+  (define char-set:punctuation
+    (make-standard-set char-punctuation?))
+  (define char-set:symbol
+    (make-standard-set char-symbolic?))
+  (define char-set:blank
+    (make-standard-set char-blank?))
+  (define char-set:ascii
+    (make-char-set (make-integer-set '((0 . 127)))))
+  (define char-set:hex-digit
+    (make-char-set (make-integer-set '((48 . 57) (65 . 70) (97 . 102)))))
+  (define char-set:empty
+    (make-char-set (make-integer-set '())))
+  (define char-set:full
+    (make-char-set (make-integer-set '((#x0 . #xD7FF) (#xE000 . #x10FFFF)))))
+
+  
+
+  ;; Contracts and provides ----------------------------------------
+
+  (define-syntax (char-sets0/c stx)
+    #'(case-> (char-set? char-set? . -> . any)
+	      (() (listof char-set?) . ->* . any)))
+
+  (define-syntax (char-sets/c stx)
+    #'(case-> (char-set? char-set? . -> . any)
+	      ((char-set?) (listof char-set?) . ->* . any)))
+
+  (define-syntax (char-sets+/c stx)
+    #'(case-> (char-set? char-set? . -> . any)
+	      ((char-set? char-set?) (listof char-set?) . ->* . any)))
+
+  (define ei/c (and/c number? integer? exact?))
+
+  (define-syntax (char-set-char/c stx)
+    #'((char-set?) (listof char?) . ->* . (char-set?)))
+
+  (provide
+   char-set?)
+  (provide/contract
+   [char-set= char-sets0/c]
+   [char-set<= char-sets0/c]
+   [char-set-hash ((char-set?) (integer?) . opt-> . integer?)]
+   [char-set-cursor (char-set? . -> . any)]
+   [char-set-ref (char-set? any/c . -> . char?)]
+   [char-set-cursor-next (char-set? any/c . -> . any)]
+   [end-of-char-set? (any/c . -> . boolean?)]
+   [char-set-fold ((char? any/c . -> . any) any/c char-set? . -> . any)]
+   [char-set-unfold (((any/c . -> . any) (any/c . -> . char?) (any/c . -> . any) any/c) (char-set?) . opt-> . char-set?)]
+   [char-set-unfold! ((any/c . -> . any) (any/c . -> . char?) (any/c . -> . any) any/c char-set? . -> . char-set?)]
+   [char-set-for-each ((char? . -> . any) char-set? . -> . any)]
+   [char-set-map ((char? . -> . any) char-set? . -> . char-set?)]
+   [char-set-copy (char-set? . -> . char-set?)]
+   [rename mk-char-set char-set (() (listof char?) . ->* . (char-set?))]
+   [list->char-set (((listof char?)) (char-set?) . opt-> . char-set?)]
+   [list->char-set! ((listof char?) char-set? . -> . char-set?)]
+   [string->char-set ((string?) (char-set?) . opt-> . char-set?)]
+   [string->char-set! (string? char-set? . -> . char-set?)]
+   [char-set-filter (((char? . -> . any) char-set?) (char-set?) . opt-> . char-set?)]
+   [char-set-filter! ((char? . -> . any) char-set? char-set? . -> . char-set?)]
+   [ucs-range->char-set ((ei/c ei/c) (any/c char-set?) . opt-> . char-set?)]
+   [ucs-range->char-set! (ei/c ei/c any/c char-set? . -> . char-set?)]
+   [->char-set ((union/c string? char? char-set?) . -> . char-set?)]
+   [char-set->list (char-set? . -> . any)]
+   [char-set->string (char-set? . -> . any)]
+   [char-set-size (char-set? . -> . any)]
+   [char-set-count ((char? . -> . any) char-set? . -> . any)]
+   [char-set-contains? (char-set? char? . -> . any)]
+   [char-set-every ((char? . -> . any) char-set? . -> . any)]
+   [char-set-any ((char? . -> . any) char-set? . -> . any)]
+   [char-set-adjoin char-set-char/c]
+   [char-set-adjoin! char-set-char/c]
+   [char-set-delete char-set-char/c]
+   [char-set-delete! char-set-char/c]
+   [char-set-complement (char-set? . -> . char-set?)]
+   [char-set-complement! (char-set? . -> . char-set?)]
+   [char-set-union char-sets0/c]
+   [char-set-union! char-sets/c]
+   [char-set-intersection char-sets0/c]
+   [char-set-intersection! char-sets/c]
+   [char-set-difference char-sets/c]
+   [char-set-difference! char-sets+/c]
+   [char-set-xor char-sets0/c]
+   [char-set-xor! char-sets/c]
+   [char-set-diff+intersection char-sets+/c]
+   [char-set-diff+intersection! char-sets+/c])
+  (provide
+   char-set:lower-case
+   char-set:upper-case
+   char-set:title-case
+   char-set:letter
+   char-set:digit
+   char-set:letter+digit
+   char-set:graphic
+   char-set:printing
+   char-set:whitespace
+   char-set:iso-control
+   char-set:punctuation
+   char-set:symbol
+   char-set:hex-digit
+   char-set:blank
+   char-set:ascii
+   char-set:empty
+   char-set:full))
diff --git a/collects/srfi/16.ss b/collects/srfi/16.ss
new file mode 100644
index 0000000000..8f0ce1e88f
--- /dev/null
+++ b/collects/srfi/16.ss
@@ -0,0 +1,3 @@
+;; Supported by core PLT:
+(module |16| mzscheme
+  (provide case-lambda))
\ No newline at end of file
diff --git a/collects/srfi/17.ss b/collects/srfi/17.ss
new file mode 100644
index 0000000000..cb3997c278
--- /dev/null
+++ b/collects/srfi/17.ss
@@ -0,0 +1,6 @@
+;; module loader for SRFI-17
+(module |17| mzscheme
+  (require (all-except (lib "set.ss" "srfi" "17") set!)
+	   (rename (lib "set.ss" "srfi" "17") my-set! set!))
+  (provide (all-from-except (lib "set.ss" "srfi" "17") my-set!)
+	   (rename my-set! set!)))
diff --git a/collects/srfi/17/.cvsignore b/collects/srfi/17/.cvsignore
new file mode 100644
index 0000000000..e3ca6473f7
--- /dev/null
+++ b/collects/srfi/17/.cvsignore
@@ -0,0 +1 @@
+compiled
diff --git a/collects/srfi/17/set.ss b/collects/srfi/17/set.ss
new file mode 100644
index 0000000000..f854c8a077
--- /dev/null
+++ b/collects/srfi/17/set.ss
@@ -0,0 +1,88 @@
+;;;
+;;; <set.ss> ---- SRFI 17 Generalized set!
+;;; Time-stamp: <02/07/22 20:28:59 solsona>
+;;;
+;;; Copyright (C) Per Bothner (1999, 2000). All Rights Reserved.
+;;; See: http://srfi.schemers.org/srfi-17/srfi-17.html
+;;;
+;;; Based on the implementation for Scheme48.
+
+(module set mzscheme
+  (provide (rename my-set! set!)
+	   setter
+	   set-setter!
+	   getter-with-setter)
+
+  (define-syntax my-set!
+    (syntax-rules ()
+		  ((my-set! (?e0 ?e1 ...) ?v)
+		   ((setter ?e0) ?e1 ... ?v))
+		  ((my-set! ?i ?v)
+		   (set! ?i ?v))))
+
+  (define (getter-with-setter get set)
+    (let ((proc (lambda args (apply get args))))
+      (set-setter! proc set)
+      proc))
+
+  (define (setter proc)
+    (let ((probe (assv proc setters)))
+      (if probe
+	  (cdr probe)
+	  (error (object-name proc) "No setter found"))))
+
+  (define (set-setter! proc setter)
+    (let ((probe (assv proc setters)))
+      (if probe
+	  (set-cdr! probe setter)
+	  (set! setters
+		(cons (cons proc setter)
+		      setters)))
+      (void)))
+
+  (define (car-setter proc)
+    (lambda (p v)
+      (set-car! (proc p) v)))
+
+  (define (cdr-setter proc)
+    (lambda (p v)
+      (set-cdr! (proc p) v)))
+
+  (define setters
+    (list (cons setter     set-setter!)
+	  (cons vector-ref vector-set!)
+	  (cons string-ref string-set!)
+	  (cons car        set-car!)
+	  (cons cdr        set-cdr!)
+
+	  (cons caar   (car-setter car))
+	  (cons cdar   (cdr-setter car))
+	  (cons cadr   (car-setter cdr))
+	  (cons cddr   (cdr-setter cdr))
+
+	  (cons caaar  (car-setter caar))
+	  (cons cdaar  (cdr-setter caar))
+	  (cons cadar  (car-setter cdar))
+	  (cons cddar  (cdr-setter cdar))
+	  (cons caadr  (car-setter cadr))
+	  (cons cdadr  (cdr-setter cadr))
+	  (cons caddr  (car-setter cddr))
+	  (cons cdddr  (cdr-setter cddr))
+
+	  (cons caaaar (car-setter caaar))
+	  (cons cdaaar (cdr-setter caaar))
+	  (cons cadaar (car-setter cdaar))
+	  (cons cddaar (cdr-setter cdaar))
+	  (cons caadar (car-setter cadar))
+	  (cons cdadar (cdr-setter cadar))
+	  (cons caddar (car-setter cddar))
+	  (cons cdddar (cdr-setter cddar))
+	  (cons caaadr (car-setter caadr))
+	  (cons cdaadr (cdr-setter caadr))
+	  (cons cadadr (car-setter cdadr))
+	  (cons cddadr (cdr-setter cdadr))
+	  (cons caaddr (car-setter caddr))
+	  (cons cdaddr (cdr-setter caddr))
+	  (cons cadddr (car-setter cdddr))
+	  (cons cddddr (cdr-setter cdddr))))
+  )
\ No newline at end of file
diff --git a/collects/srfi/18.ss b/collects/srfi/18.ss
new file mode 100644
index 0000000000..ab8dffe1d6
--- /dev/null
+++ b/collects/srfi/18.ss
@@ -0,0 +1,4 @@
+;; Supported by core PLT:
+(module |18| mzscheme
+  (provide thread)
+  )
\ No newline at end of file
diff --git a/collects/srfi/19.ss b/collects/srfi/19.ss
new file mode 100644
index 0000000000..4687427e62
--- /dev/null
+++ b/collects/srfi/19.ss
@@ -0,0 +1,23 @@
+;; module loader for SRFI-19
+(module |19| mzscheme
+  (require (lib "time.ss" "srfi" "19"))
+  (provide (all-from-except (lib "time.ss" "srfi" "19")
+                            make-srfi:date srfi:date?
+                            srfi:date-second 
+                            srfi:date-minute 
+                            srfi:date-hour 
+                            srfi:date-day 
+                            srfi:date-month
+                            srfi:date-year 
+                            srfi:date-year-day
+                            srfi:date-week-day)
+           (rename make-srfi:date make-date)
+           (rename srfi:date? date)
+           (rename srfi:date-second date-second)
+           (rename srfi:date-minute date-minute)
+           (rename srfi:date-hour date-hour)
+           (rename srfi:date-day date-day)
+           (rename srfi:date-month date-month)
+           (rename srfi:date-year date-year)
+           (rename srfi:date-year-day date-year-day)
+           (rename srfi:date-week-day date-week-day)))
diff --git a/collects/srfi/19/.cvsignore b/collects/srfi/19/.cvsignore
new file mode 100644
index 0000000000..e3ca6473f7
--- /dev/null
+++ b/collects/srfi/19/.cvsignore
@@ -0,0 +1 @@
+compiled
diff --git a/collects/srfi/19/info.ss b/collects/srfi/19/info.ss
new file mode 100644
index 0000000000..ab07c01a48
--- /dev/null
+++ b/collects/srfi/19/info.ss
@@ -0,0 +1,4 @@
+(module info (lib "infotab.ss" "setup")
+
+  (define name "SRFI 19")
+  (define compile-omit-files `("tests.ss")))
diff --git a/collects/srfi/19/tests.ss b/collects/srfi/19/tests.ss
new file mode 100644
index 0000000000..c175c5850a
--- /dev/null
+++ b/collects/srfi/19/tests.ss
@@ -0,0 +1,223 @@
+(module tests mzscheme
+
+  ;; tests by Will Fitzgerald, augmented by John Clements -- 2004-08-16
+
+  ;; these tests were built using schemeunit 2.0a (IIRC).  Older versions
+  ;; of schemeunit don't support the same syntax for creating assertions.
+  ;; so when you try to run the tests and they fail miserably, that's probably
+  ;; why.
+  
+;;; simple test procedures
+(require (lib "time.ss" "srfi" "19")
+         (lib "test.ss" "schemeunit") ; change to a planet reference
+         (lib "text-ui.ss" "schemeunit") ; change to a planet reference
+         )
+
+(define-simple-assertion (assert-not-exn-helper thunk)
+                         (with-handlers ([not-break-exn? (lambda (exn) #f)])
+                           (thunk)
+                           #t))
+
+(define-syntax assert-not-exn
+  (lambda (stx)
+      (syntax-case stx ()
+        [(_ arg) (syntax/loc stx (assert-not-exn-helper (lambda () arg)))]
+        [else (error 'assert-not-exn "assert-not-exn expects exactly one argument, received: ~v" stx)])))
+
+(define srfi-19-test-suite
+  (make-test-suite
+   "Tests for SRFI 19"
+   
+   (make-test-case
+    "Creating time structures"
+    (assert-not-exn 
+     (list (current-time 'time-tai)
+           (current-time 'time-utc)
+           (current-time 'time-monotonic)
+           (current-time 'time-thread)
+           (current-time 'time-process))))
+   
+   (make-test-case
+    "Testing time resolutions"
+    (assert-not-exn
+     (list (time-resolution 'time-tai)
+           (time-resolution 'time-utc)
+           (time-resolution 'time-monotonic)
+           (time-resolution 'time-thread)
+           (time-resolution 'time-process))))
+   
+   (make-test-case 
+    "Time comparisons (time=?, etc.)"
+    (let ((t1 (make-time 'time-utc 0 1))
+	  (t2 (make-time 'time-utc 0 1))
+	  (t3 (make-time 'time-utc 0 2))
+	  (t11 (make-time 'time-utc 1001 1))
+	  (t12 (make-time 'time-utc 1001 1))
+	  (t13 (make-time 'time-utc 1001 2)))
+      (assert time=? t1 t2)
+      (assert time>? t3 t2)
+      (assert time<? t2 t3)
+      (assert time>=? t1 t2)
+      (assert time>=? t3 t2)
+      (assert time<=? t1 t2)
+      (assert time<=? t2 t3)
+      (assert time=? t11 t12)
+      (assert time>? t13 t12)
+      (assert time<? t12 t13)
+      (assert time>=? t11 t12)
+      (assert time>=? t13 t12)
+      (assert time<=? t11 t12)
+      (assert time<=? t12 t13)))
+   
+   (make-test-case
+    "Time difference"
+    (let ((t1 (make-time 'time-utc 0 3000))
+	  (t2 (make-time 'time-utc 0 1000))
+	  (t3 (make-time 'time-duration 0 2000))
+	  (t4 (make-time 'time-duration 0 -2000)))
+      (assert time=? t3 (time-difference t1 t2))
+      (assert time=? t4 (time-difference t2 t1))))
+   
+   (make-test-case
+    "TAI-UTC Conversions"
+    (begin
+     (test-one-utc-tai-edge 915148800  32 31)
+     (test-one-utc-tai-edge 867715200  31 30)
+     (test-one-utc-tai-edge 820454400  30 29)
+     (test-one-utc-tai-edge 773020800  29 28)
+     (test-one-utc-tai-edge 741484800  28 27)
+     (test-one-utc-tai-edge 709948800  27 26)
+     (test-one-utc-tai-edge 662688000  26 25)
+     (test-one-utc-tai-edge 631152000  25 24)
+     (test-one-utc-tai-edge 567993600  24 23)
+     (test-one-utc-tai-edge 489024000  23 22)
+     (test-one-utc-tai-edge 425865600  22 21)
+     (test-one-utc-tai-edge 394329600  21 20)
+     (test-one-utc-tai-edge 362793600  20 19)
+     (test-one-utc-tai-edge 315532800  19 18)
+     (test-one-utc-tai-edge 283996800  18 17)
+     (test-one-utc-tai-edge 252460800  17 16)
+     (test-one-utc-tai-edge 220924800  16 15)
+     (test-one-utc-tai-edge 189302400  15 14)
+     (test-one-utc-tai-edge 157766400  14 13)
+     (test-one-utc-tai-edge 126230400  13 12)
+     (test-one-utc-tai-edge 94694400   12 11)
+     (test-one-utc-tai-edge 78796800   11 10)
+     (test-one-utc-tai-edge 63072000   10 0)
+     (test-one-utc-tai-edge 0   0 0) ;; at the epoch
+     (test-one-utc-tai-edge 10   0 0) ;; close to it ...
+     (test-one-utc-tai-edge 1045789645 32 32) ;; about now ...
+     ))
+   
+   (make-test-case
+    "TAI-Date Conversions"
+    (begin
+      (assert tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 29)) 0)
+              (make-srfi:date 0 58 59 23 31 12 1998 0))
+      (assert tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 30)) 0)
+              (make-srfi:date 0 59 59 23 31 12 1998 0))
+      (assert tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 31)) 0)
+              (make-srfi:date 0 60 59 23 31 12 1998 0))
+      (assert tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 32)) 0)
+              (make-srfi:date 0 0 0 0 1 1 1999 0))))
+   
+   
+   (make-test-case 
+    "Date-UTC Conversions"
+    (begin
+      (assert time=? (make-time time-utc 0 (- 915148800 2))
+              (date->time-utc (make-srfi:date 0 58 59 23 31 12 1998 0)))
+      (assert time=? (make-time time-utc 0 (- 915148800 1))
+              (date->time-utc (make-srfi:date 0 59 59 23 31 12 1998 0)))
+      ;; yes, I think this is acutally right.
+      (assert time=? (make-time time-utc 0 (- 915148800 0))
+              (date->time-utc (make-srfi:date 0 60 59 23 31 12 1998 0)))
+      (assert time=? (make-time time-utc 0 (- 915148800 0))
+              (date->time-utc (make-srfi:date 0 0 0 0 1 1 1999 0)))
+      (assert time=? (make-time time-utc 0 (+ 915148800 1))
+              (date->time-utc (make-srfi:date 0 1 0 0 1 1 1999 0)))))
+   
+   (make-test-case 
+    "TZ Offset conversions"
+    (let ((ct-utc (make-time time-utc 6320000 1045944859))
+	  (ct-tai (make-time time-tai 6320000 1045944891))
+	  (cd (make-srfi:date 6320000 19 14 15 22 2 2003 -18000)))
+      (assert time=? ct-utc (date->time-utc cd))
+      (assert time=? ct-tai (date->time-tai cd))))
+   
+   (make-test-case
+    "date->string conversions"
+    (begin
+      (assert-equal? "~.Tue.Tuesday.Jun.June.Tue Jun 5 4:03:02-0200 2007.05.06/05/07. 5,2.000001,Jun.03" 
+                     (date->string (make-srfi:date 1000 2 3 4 5 6 2007 -120)
+                                   "~~.~a.~A.~b.~B.~c.~d.~D.~e,~f,~h.~H"))))
+   
+   (make-test-case
+    "date<->julian-day conversion"
+    (begin (assert = 365 (- (date->julian-day (make-srfi:date 0 0 0 0 1 1 2004 0))
+                     (date->julian-day (make-srfi:date 0 0 0 0 1 1 2003 0))))
+           (let ([test-date (make-srfi:date 0 0 0 0 1 1 2003 -7200)])
+             (assert tm:date= test-date (julian-day->date (date->julian-day test-date) -7200)))))
+   
+   (make-test-case
+    "date->modified-julian-day conversion"
+    (begin (assert = 365 (- (date->modified-julian-day (make-srfi:date 0 0 0 0 1 1 2004 0))
+                            (date->modified-julian-day (make-srfi:date 0 0 0 0 1 1 2003 0))))
+           (let ([test-date (make-srfi:date 0 0 0 0 1 1 2003 -7200)])
+             (assert tm:date= test-date (modified-julian-day->date (date->modified-julian-day test-date) -7200)))))
+   ))
+
+
+
+
+(define (test-one-utc-tai-edge utc tai-diff tai-last-diff)
+  (let* (;; right on the edge they should be the same
+	 (utc-basic (make-time 'time-utc 0 utc))
+	 (tai-basic (make-time 'time-tai 0 (+ utc tai-diff)))
+	 (utc->tai-basic (time-utc->time-tai utc-basic))
+	 (tai->utc-basic (time-tai->time-utc tai-basic))
+         
+	 ;; a second before they should be the old diff
+	 (utc-basic-1 (make-time 'time-utc 0 (- utc 1)))
+	 (tai-basic-1 (make-time 'time-tai 0 (- (+ utc tai-last-diff) 1)))
+	 (utc->tai-basic-1 (time-utc->time-tai utc-basic-1))
+	 (tai->utc-basic-1 (time-tai->time-utc tai-basic-1))
+         
+	 ;; a second later they should be the new diff
+	 (utc-basic+1 (make-time 'time-utc 0 (+ utc 1)))
+	 (tai-basic+1 (make-time 'time-tai 0 (+ (+ utc tai-diff) 1)))
+	 (utc->tai-basic+1 (time-utc->time-tai utc-basic+1))
+	 (tai->utc-basic+1 (time-tai->time-utc tai-basic+1))
+         
+	 ;; ok, let's move the clock half a month or so plus half a second
+	 (shy (* 15 24 60 60))
+	 (hs (/ (expt 10 9) 2))
+	 ;; a second later they should be the new diff
+	 (utc-basic+2 (make-time 'time-utc hs (+ utc shy)))
+	 (tai-basic+2 (make-time 'time-tai hs (+ (+ utc tai-diff) shy)))
+	 (utc->tai-basic+2 (time-utc->time-tai utc-basic+2))
+	 (tai->utc-basic+2 (time-tai->time-utc tai-basic+2)))
+    
+    (assert time=? utc-basic tai->utc-basic)
+    (assert time=? tai-basic utc->tai-basic)
+    (assert time=? utc-basic-1 tai->utc-basic-1)
+    (assert time=? tai-basic-1 utc->tai-basic-1)
+    (assert time=? utc-basic+1 tai->utc-basic+1)
+    (assert time=? tai-basic+1 utc->tai-basic+1)
+    (assert time=? utc-basic+2 tai->utc-basic+2)
+    (assert time=? tai-basic+2 utc->tai-basic+2)))
+
+
+(define (tm:date= d1 d2)
+  (and (= (srfi:date-year d1) (srfi:date-year d2))
+       (= (srfi:date-month d1) (srfi:date-month d2))
+       (= (srfi:date-day d1) (srfi:date-day d2))
+       (= (srfi:date-hour d1) (srfi:date-hour d2))
+       (= (srfi:date-second d1) (srfi:date-second d2))
+       (= (date-nanosecond d1) (date-nanosecond d2))
+       (= (date-zone-offset d1) (date-zone-offset d2))))
+
+
+(test/text-ui srfi-19-test-suite)
+
+)
diff --git a/collects/srfi/19/time.ss b/collects/srfi/19/time.ss
new file mode 100644
index 0000000000..cc14738f1f
--- /dev/null
+++ b/collects/srfi/19/time.ss
@@ -0,0 +1,1473 @@
+;;;
+;;; <time.ss> ---- SRFI 19 Time Data Types and Procedures port to PLT Scheme
+;;; Time-stamp: <2004-07-21 12:57:06 solsona>
+;;;
+;;; Usually, I would add a copyright notice, and the announce that
+;;; this code is under the LGPL licence.  Nevertheless, I only did the
+;;; port to PLT Scheme v200, and here is the copyright notice,
+;;; comments, and licence from the original source:
+
+;;; Based on a corrected version by Will F. Feb/2003
+
+;; SRFI-19: Time Data Types and Procedures.
+;; 
+;; Copyright (C) I/NET, Inc. (2000, 2002, 2003). All Rights Reserved. 
+;; Copyright (C) Neodesic Corporation (2000). All Rights Reserved. 
+;; 
+;; This document and translations of it may be copied and furnished to others, 
+;; and derivative works that comment on or otherwise explain it or assist in its 
+;; implementation may be prepared, copied, published and distributed, in whole or 
+;; in part, without restriction of any kind, provided that the above copyright 
+;; notice and this paragraph are included on all such copies and derivative works. 
+;; However, this document itself may not be modified in any way, such as by 
+;; removing the copyright notice or references to the Scheme Request For 
+;; Implementation process or editors, except as needed for the purpose of 
+;; developing SRFIs in which case the procedures for copyrights defined in the SRFI 
+;; process must be followed, or as required to translate it into languages other 
+;; than English. 
+;; 
+;; The limited permissions granted above are perpetual and will not be revoked 
+;; by the authors or their successors or assigns. 
+;; 
+;; This document and the information contained herein is provided on an "AS IS" 
+;; basis and THE AUTHOR AND THE SRFI EDITORS DISCLAIM ALL WARRANTIES, EXPRESS OR 
+;; IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTY THAT THE USE OF THE 
+;; INFORMATION HEREIN WILL NOT INFRINGE ANY RIGHTS OR ANY IMPLIED WARRANTIES OF 
+;; MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. 
+
+;; -- MzScheme implementation
+;;
+;; The only MzScheme specific features of this implementation is
+;; CURRENT-SECONDS, the DEFINE-STRUCT procedure (SRFI 9: Defining Record Types
+;; could be used), and the constants tm:time-at-zero-seconds
+;; and tm:julian-day-at-zero-seconds, which refer to the '0' of CURRENT-SECONDS.
+;; 
+;; SRFI-6, String Ports, and SRFI-8, RECEIVE: Binding Multiple Values, 
+;; are also used. MzScheme has String Ports built-in. The RECIEVE form
+;; is copied below.
+;;
+; srfi-8: receive
+;(require-library "synrule.ss") -- PLT doesn't like DEFINE-SYNTAX. 
+
+;(define-syntax receive
+;  (syntax-rules ()
+;    ((receive formals expression body ...)
+;     (call-with-values (lambda () expression)
+;                       (lambda formals body ...)))))
+
+;; -- Multiple helper procedures. TM:xxx procedures are meant to be
+;; internal.
+
+(module time mzscheme
+  (require (lib "receive.ss" "srfi" "8")
+	   (lib "29.ss" "srfi")
+	   (lib "optional.ss" "srfi"))
+  (provide time-tai time-utc time-monotonic time-thread time-process time-duration time-gc
+	   current-date current-julian-day current-modified-julian-day current-time time-resolution
+           ;; Time object and accessors
+           make-time time? time-type time-nanosecond 
+           time-second set-time-type! set-time-nanosecond! set-time-second!
+           copy-time
+	   ;; Time comparison
+	   time<=? time<? time=? time>=? time>?
+	   ;; Time arithmetic
+	   time-difference time-difference! add-duration add-duration! subtract-duration subtract-duration!
+           ;; Date object and accessors
+	   ;; date structure is provided by core PLT Scheme, we just extended tu support miliseconds:
+           make-srfi:date srfi:date?
+	   date-nanosecond srfi:date-second srfi:date-minute srfi:date-hour srfi:date-day srfi:date-month
+           srfi:date-year date-zone-offset
+	   ;; This are not part of the date structure (as they are in the original PLT Scheme's date)
+	   srfi:date-year-day srfi:date-week-day date-week-number
+
+	   ;; The following procedures work with this modified version.
+	   
+	   ;; Time/Date/Julian Day/Modified Julian Day Converters
+	   date->julian-day date->modified-julian-day date->time-monotonic date->time-tai date->time-utc
+	   julian-day->date julian-day->time-monotonic julian-day->time-tai julian-day->time-utc modified-julian-day->date
+	   modified-julian-day->time-monotonic modified-julian-day->time-tai modified-julian-day->time-utc time-monotonic->date
+	   time-monotonic->julian-day time-monotonic->modified-julian-day time-monotonic->time-tai time-monotonic->time-tai!
+	   time-monotonic->time-utc time-monotonic->time-utc! time-tai->date time-tai->julian-day time-tai->modified-julian-day
+	   time-tai->time-monotonic time-tai->time-monotonic! time-tai->time-utc time-tai->time-utc! time-utc->date
+	   time-utc->julian-day time-utc->modified-julian-day time-utc->time-monotonic time-utc->time-monotonic!
+	   time-utc->time-tai time-utc->time-tai!
+	   ;; Date to String/String to Date Converters
+	   date->string string->date
+	   )
+
+  ;; SRFI-29: Localization initialization:
+  (re-read-locale)
+  (or (load-bundle! (list 'srfi-19
+			  (current-language)
+			  (current-country)
+			  (current-locale-details)))
+      ;; A little bit less specific
+      (load-bundle! (list 'srfi-19
+			  (current-language)
+			  (current-country)))
+      ;; less specific
+      (load-bundle! (list 'srfi-19 (current-language)))
+      ;; the least specific one (this one *do* exists!, it comes with this srfi) don't worry:
+      (load-bundle! (list 'srfi-19)))
+
+  (define localized-message
+    (lambda (message-name)
+      (localized-template 'srfi-19 message-name)))
+  
+  ;; Constants
+  (define time-tai 'time-tai)
+  (define time-utc 'time-utc)
+  (define time-monotonic 'time-monotonic)
+  (define time-thread 'time-thread)
+  (define time-process 'time-process)
+  (define time-duration 'time-duration)
+
+  ;; example of extension (MZScheme specific)
+  (define time-gc 'time-gc)
+
+
+  ;;-- LOCALE dependent constants
+
+  (define tm:locale-number-separator 'separator)
+
+  (define tm:locale-abbr-weekday-vector (vector 'sun 'mon 'tue 'wed 'thu 'fri 'sat))
+  (define tm:locale-long-weekday-vector (vector 'sunday 'monday 'tuesday 'wednesday
+						'thursday 'friday 'saturday))
+  ;; note empty string in 0th place. 
+  (define tm:locale-abbr-month-vector   (vector 'jan 'feb 'mar
+						'apr 'may 'jun 'jul
+						'aug 'sep 'oct 'nov
+						'dec))
+  
+  (define tm:locale-long-month-vector   (vector 'january 'february
+						'march 'april 'may
+						'june 'july 'august
+						'september 'october
+						'november 'december)) 
+
+  (define tm:locale-pm 'pm)
+  (define tm:locale-am 'am)
+
+  ;; See date->string
+  (define tm:locale-date-time-format 'date-time)
+  (define tm:locale-short-date-format 'date)
+  (define tm:locale-time-format 'time)
+  (define tm:iso-8601-date-time-format 'iso8601)
+  ;;-- Miscellaneous Constants.
+  ;;-- only the tm:tai-epoch-in-jd might need changing if
+  ;;   a different epoch is used.
+
+  (define tm:nano (expt 10 9))
+  (define tm:sid  86400)		; seconds in a day
+  (define tm:sihd 43200)		; seconds in a half day
+  (define tm:tai-epoch-in-jd 4881175/2) ; julian day number for 'the epoch'
+
+  ;; A Very simple Error system for the time procedures
+  ;; 
+  (define tm:time-error-types
+    '(invalid-clock-type
+      unsupported-clock-type
+      incompatible-time-types
+      not-duration
+      dates-are-immutable
+      bad-date-format-string
+      bad-date-template-string
+      invalid-month-specification
+      ))
+
+  (define (tm:time-error caller type value)
+    (if (member type tm:time-error-types)
+	(if value
+	    (error caller "TIME-ERROR type ~S: ~S" type value)
+	    (error caller "TIME-ERROR type ~S" type))
+	(error caller "TIME-ERROR unsupported error type ~S" type)))
+
+  ;; A table of leap seconds
+  ;; See ftp://maia.usno.navy.mil/ser7/tai-utc.dat
+  ;; and update as necessary.
+  ;; this procedures reads the file in the abover
+  ;; format and creates the leap second table
+  ;; it also calls the almost standard, but not R5 procedures read-line 
+  ;; & open-input-string
+  ;; ie (set! tm:leap-second-table (tm:read-tai-utc-date "tai-utc.dat"))
+
+  (define (tm:read-tai-utc-data filename)
+    (define (convert-jd jd)
+      (* (- (inexact->exact jd) tm:tai-epoch-in-jd) tm:sid))
+    (define (convert-sec sec)
+      (inexact->exact sec))
+    (let ( (port (open-input-file filename))
+	   (table '()) )
+      (let loop ((line (read-line port)))
+	(if (not (eq? line eof))
+	    (begin
+	      (let* ( (data (read (open-input-string (string-append "(" line ")")))) 
+		      (year (car data))
+		      (jd   (cadddr (cdr data)))
+		      (secs (cadddr (cdddr data))) )
+		(if (>= year 1972)
+		    (set! table (cons (cons (convert-jd jd) (convert-sec secs)) table)))
+		(loop (read-line port))))))
+      table))
+
+  ;; each entry is ( utc seconds since epoch . # seconds to add for tai )
+  ;; note they go higher to lower, and end in 1972.
+  (define tm:leap-second-table
+    '((915148800 . 32)
+      (867715200 . 31)
+      (820454400 . 30)
+      (773020800 . 29)
+      (741484800 . 28)
+      (709948800 . 27)
+      (662688000 . 26)
+      (631152000 . 25)
+      (567993600 . 24)
+      (489024000 . 23)
+      (425865600 . 22)
+      (394329600 . 21)
+      (362793600 . 20)
+      (315532800 . 19)
+      (283996800 . 18)
+      (252460800 . 17)
+      (220924800 . 16)
+      (189302400 . 15)
+      (157766400 . 14)
+      (126230400 . 13)
+      (94694400  . 12)
+      (78796800  . 11)
+      (63072000  . 10)))
+
+  (define (read-leap-second-table filename)
+    (set! tm:leap-second-table (tm:read-tai-utc-data filename))
+    (values))
+
+
+  (define (tm:leap-second-delta utc-seconds)
+    (letrec ( (lsd (lambda (table)
+		     (cond ((>= utc-seconds (caar table))
+			    (cdar table))
+			   (else (lsd (cdr table)))))) )
+      (if (< utc-seconds  (* (- 1972 1970) 365 tm:sid)) 0
+	  (lsd  tm:leap-second-table))))
+
+  ;; going from tai seconds to utc seconds ... 
+  (define (tm:leap-second-neg-delta tai-seconds)
+    (letrec ( (lsd (lambda (table)
+		     (cond ((null? table) 0)
+			   ((<= (cdar table) (- tai-seconds (caar table)))
+			    (cdar table))
+			   (else (lsd (cdr table)))))) )
+      (if (< tai-seconds  (* (- 1972 1970) 365 tm:sid)) 0
+	  (lsd  tm:leap-second-table))))
+  
+  (define-values (tm:time make-time time? tm:time-ref tm:time-set!)
+    (make-struct-type 
+     'tm:time #f 3 0 #f null (make-inspector) #f null))
+  
+  (define (time-type t)       (tm:time-ref t 0))
+  (define (time-nanosecond t) (tm:time-ref t 1))
+  (define (time-second t)     (tm:time-ref t 2))
+  
+  (define (set-time-type! t type)     (tm:time-set! t 0 type))
+  (define (set-time-nanosecond! t ns) (tm:time-set! t 1 ns))
+  (define (set-time-second! t s)      (tm:time-set! t 2 s))
+  
+  (define (copy-time time)
+    (let ((ntime (make-time #f #f #f)))
+      (set-time-type! ntime (time-type time))
+      (set-time-second! ntime (time-second time))
+      (set-time-nanosecond! ntime (time-nanosecond time))
+      ntime))
+
+
+  ;;; specific time getters.
+  ;;; These should be rewritten to be OS specific.
+  ;;
+  ;; -- using GNU gettimeofday() would be useful here -- gets
+  ;;    second + millisecond 
+  ;;    let's pretend we do, using MzScheme's current-seconds & current-milliseconds
+  ;;    this is supposed to return UTC.
+  ;; 
+
+  (define (tm:get-time-of-day)
+    (values (current-seconds)
+	    (abs (remainder (current-milliseconds) 1000))))
+  
+  (define (tm:current-time-utc)
+    (receive (seconds ms) (tm:get-time-of-day)
+	     (make-time  time-utc (* ms 10000) seconds)))
+
+  (define (tm:current-time-tai)
+    (receive (seconds ms) (tm:get-time-of-day)
+	     (make-time time-tai
+			(* ms 10000)
+			(+ seconds (tm:leap-second-delta seconds))
+			)))
+
+  (define (tm:current-time-ms-time time-type proc)
+    (let ((current-ms (proc)))
+      (make-time time-type 
+		 (* (remainder current-ms 1000) 10000)
+		 (quotient current-ms 10000)
+		 )))
+
+  ;; -- we define it to be the same as TAI.
+  ;;    A different implemation of current-time-montonic
+  ;;    will require rewriting all of the time-monotonic converters,
+  ;;    of course.
+
+  (define (tm:current-time-monotonic)
+    (receive (seconds ms) (tm:get-time-of-day)
+	     (make-time time-monotonic
+			(* ms 10000)
+			(+ seconds (tm:leap-second-delta seconds))
+			)))
+
+  (define (tm:current-time-thread)
+    (tm:current-time-ms-time time-process current-process-milliseconds))
+
+  (define (tm:current-time-process)
+    (tm:current-time-ms-time time-process current-process-milliseconds))
+
+  (define (tm:current-time-gc)
+    (tm:current-time-ms-time time-gc current-gc-milliseconds))
+
+  (define (current-time . clock-type)
+    (let ( (clock-type (:optional clock-type time-utc)) )
+      (cond
+       ((eq? clock-type time-tai) (tm:current-time-tai))
+       ((eq? clock-type time-utc) (tm:current-time-utc))
+       ((eq? clock-type time-monotonic) (tm:current-time-monotonic))
+       ((eq? clock-type time-thread) (tm:current-time-thread))
+       ((eq? clock-type time-process) (tm:current-time-process))
+       ((eq? clock-type time-gc) (tm:current-time-gc))
+       (else (tm:time-error 'current-time 'invalid-clock-type clock-type)))))
+
+  
+  ;; -- Time Resolution
+  ;; This is the resolution of the clock in nanoseconds.
+  ;; This will be implementation specific.
+
+  (define (time-resolution . clock-type)
+    (let ((clock-type (:optional clock-type time-utc)))
+      (cond
+       ((eq? clock-type time-tai) 10000)
+       ((eq? clock-type time-utc) 10000)
+       ((eq? clock-type time-monotonic) 10000)
+       ((eq? clock-type time-thread) 10000)
+       ((eq? clock-type time-gc) 10000)
+       (else (tm:time-error 'time-resolution 'invalid-clock-type clock-type)))))
+
+  (define (tm:time-compare-check time1 time2 caller)
+    (if (or (not (and (time? time1) (time? time2)))
+	    (not (eq? (time-type time1) (time-type time2))))
+	(tm:time-error caller 'incompatible-time-types #f)
+	#t))
+
+  (define (time=? time1 time2)
+    (tm:time-compare-check time1 time2 'time=?)
+    (and (= (time-second time1) (time-second time2))
+	 (= (time-nanosecond time1) (time-nanosecond time2))))
+
+  (define (time>? time1 time2)
+    (tm:time-compare-check time1 time2 'time>?)
+    (or (> (time-second time1) (time-second time2))
+	(and (= (time-second time1) (time-second time2))
+	     (> (time-nanosecond time1) (time-nanosecond time2)))))
+
+  (define (time<? time1 time2)
+    (tm:time-compare-check time1 time2 'time<?)
+    (or (< (time-second time1) (time-second time2))
+	(and (= (time-second time1) (time-second time2))
+	     (< (time-nanosecond time1) (time-nanosecond time2)))))
+
+  (define (time>=? time1 time2)
+    (tm:time-compare-check time1 time2 'time>=?)
+    (or (>= (time-second time1) (time-second time2))
+	(and (= (time-second time1) (time-second time2))
+	     (>= (time-nanosecond time1) (time-nanosecond time2)))))
+
+  (define (time<=? time1 time2)
+    (tm:time-compare-check time1 time2 'time<=?)
+    (or (<= (time-second time1) (time-second time2))
+	(and (= (time-second time1) (time-second time2))
+	     (<= (time-nanosecond time1) (time-nanosecond time2)))))
+
+  ;; -- Time arithmetic
+  (define (tm:time->nanoseconds time)
+    (define (sign1 n)
+      (if (negative? n) -1 1))
+    (+ (* (time-second time) tm:nano)
+       (time-nanosecond time)))
+
+  (define (tm:nanoseconds->time time-type nanoseconds)
+    (make-time time-type
+	       (remainder nanoseconds tm:nano)
+	       (quotient nanoseconds tm:nano)))
+
+  (define (tm:nanoseconds->values nanoseconds)
+    (values (abs (remainder nanoseconds tm:nano))
+	    (quotient nanoseconds tm:nano)))
+
+  (define (tm:time-difference time1 time2 time3)
+    (if (or (not (and (time? time1) (time? time2)))
+	    (not (eq? (time-type time1) (time-type time2))))
+	(tm:time-error 'time-difference 'incompatible-time-types #f))
+    (set-time-type! time3 time-duration)
+    (if (time=? time1 time2)
+	(begin
+	  (set-time-second! time3 0)
+	  (set-time-nanosecond! time3 0))
+	(receive 
+	 (nanos secs)
+	 (tm:nanoseconds->values (- (tm:time->nanoseconds time1)
+				    (tm:time->nanoseconds time2)))
+	 (set-time-second! time3 secs)
+	 (set-time-nanosecond! time3 nanos)))
+    time3)
+
+  (define (time-difference time1 time2)
+    (tm:time-difference time1 time2 (make-time #f #f #f)))
+
+  (define (time-difference! time1 time2)
+    (tm:time-difference time1 time2 time1))
+
+  (define (tm:add-duration time1 duration time3)
+    (if (not (and (time? time1) (time? duration)))
+	(tm:time-error 'add-duration 'incompatible-time-types #f))
+    (if (not (eq? (time-type duration) time-duration))
+	(tm:time-error 'add-duration 'not-duration duration)
+	(let ( (sec-plus (+ (time-second time1) (time-second duration)))
+	       (nsec-plus (+ (time-nanosecond time1) (time-nanosecond duration))) )
+	  (let ((r (remainder nsec-plus tm:nano))
+		(q (quotient nsec-plus tm:nano)))
+					; (set-time-type! time3 (time-type time1))
+	    (if (negative? r)
+		(begin
+		  (set-time-second! time3 (+ sec-plus q -1))
+		  (set-time-nanosecond! time3 (+ tm:nano r)))
+		(begin
+		  (set-time-second! time3 (+ sec-plus q))
+		  (set-time-nanosecond! time3 r)))
+	    time3))))
+
+  (define (add-duration time1 duration)
+    (tm:add-duration time1 duration (make-time (time-type time1) #f #f)))
+
+  (define (add-duration! time1 duration)
+    (tm:add-duration time1 duration time1))
+
+  (define (tm:subtract-duration time1 duration time3)
+    (if (not (and (time? time1) (time? duration)))
+	(tm:time-error 'add-duration 'incompatible-time-types #f))
+    (if (not (eq? (time-type duration) time-duration))
+	(tm:time-error 'tm:subtract-duration 'not-duration duration)
+	(let ( (sec-minus  (- (time-second time1) (time-second duration)))
+	       (nsec-minus (- (time-nanosecond time1) (time-nanosecond duration))) )
+	  (let ((r (remainder nsec-minus tm:nano))
+		(q (quotient nsec-minus tm:nano)))
+	    (if (negative? r)
+		(begin
+		  (set-time-second! time3 (- sec-minus q 1))
+		  (set-time-nanosecond! time3 (+ tm:nano r)))
+		(begin
+		  (set-time-second! time3 (- sec-minus q))
+		  (set-time-nanosecond! time3 r)))
+	    time3))))
+
+  (define (subtract-duration time1 duration)
+    (tm:subtract-duration time1 duration (make-time (time-type time1) #f #f)))
+
+  (define (subtract-duration! time1 duration)
+    (tm:subtract-duration time1 duration time1))
+
+
+  ;; -- Converters between types.
+
+  (define (tm:time-tai->time-utc! time-in time-out caller)
+    (if (not (eq? (time-type time-in) time-tai))
+	(tm:time-error caller 'incompatible-time-types time-in))
+    (set-time-type! time-out time-utc)
+    (set-time-nanosecond! time-out (time-nanosecond time-in))
+    (set-time-second!     time-out (- (time-second time-in)
+				      (tm:leap-second-neg-delta 
+				       (time-second time-in))))
+    time-out)
+
+  (define (time-tai->time-utc time-in)
+    (tm:time-tai->time-utc! time-in (make-time #f #f #f) 'time-tai->time-utc))
+
+
+  (define (time-tai->time-utc! time-in)
+    (tm:time-tai->time-utc! time-in time-in 'time-tai->time-utc!))
+
+
+  (define (tm:time-utc->time-tai! time-in time-out caller)
+    (if (not (eq? (time-type time-in) time-utc))
+	(tm:time-error caller 'incompatible-time-types time-in))
+    (set-time-type! time-out time-tai)
+    (set-time-nanosecond! time-out (time-nanosecond time-in))
+    (set-time-second!     time-out (+ (time-second time-in)
+				      (tm:leap-second-delta 
+				       (time-second time-in))))
+    time-out)
+
+
+  (define (time-utc->time-tai time-in)
+    (tm:time-utc->time-tai! time-in (make-time #f #f #f) 'time-utc->time-tai))
+
+  (define (time-utc->time-tai! time-in)
+    (tm:time-utc->time-tai! time-in time-in 'time-utc->time-tai!))
+
+  ;; -- these depend on time-monotonic having the same definition as time-tai!
+  (define (time-monotonic->time-utc time-in)
+    (if (not (eq? (time-type time-in) time-monotonic))
+	(tm:time-error 'time-monotoinc->time-utc 'incompatible-time-types time-in))
+    (let ((ntime (copy-time time-in)))
+      (set-time-type! ntime time-tai)
+      (tm:time-tai->time-utc! ntime ntime 'time-monotonic->time-utc)))
+
+  (define (time-monotonic->time-utc! time-in)
+    (if (not (eq? (time-type time-in) time-monotonic))
+	(tm:time-error 'time-monotonic->time-utc! 'incompatible-time-types time-in))
+    (set-time-type! time-in time-tai)
+    (tm:time-tai->time-utc! time-in time-in 'time-monotonic->time-utc))
+
+  (define (time-monotonic->time-tai time-in)
+    (if (not (eq? (time-type time-in) time-monotonic))
+	(tm:time-error 'time-monotonic->time-tai 'incompatible-time-types time-in))
+    (let ((ntime (copy-time time-in)))
+      (set-time-type! ntime time-tai)
+      ntime))
+
+  (define (time-monotonic->time-tai! time-in)
+    (if (not (eq? (time-type time-in) time-monotonic))
+	(tm:time-error 'time-monotonic->time-tai! 'incompatible-time-types time-in))
+    (set-time-type! time-in time-tai)
+    time-in)
+
+  (define (time-utc->time-monotonic time-in)
+    (if (not (eq? (time-type time-in) time-utc))
+	(tm:time-error 'time-utc->time-monotonic 'incompatible-time-types time-in))
+    (let ((ntime (tm:time-utc->time-tai! time-in (make-time #f #f #f)
+					 'time-utc->time-monotonic)))
+      (set-time-type! ntime time-monotonic)
+      ntime))
+
+
+  (define (time-utc->time-monotonic! time-in)
+    (if (not (eq? (time-type time-in) time-utc))
+	(tm:time-error 'time-utc->time-montonic! 'incompatible-time-types time-in))
+    (let ((ntime (tm:time-utc->time-tai! time-in time-in
+					 'time-utc->time-monotonic!)))
+      (set-time-type! ntime time-monotonic)
+      ntime))
+
+
+  (define (time-tai->time-monotonic time-in)
+    (if (not (eq? (time-type time-in) time-tai))
+	(tm:time-error 'time-tai->time-monotonic 'incompatible-time-types time-in))
+    (let ((ntime (copy-time time-in)))
+      (set-time-type! ntime time-monotonic)
+      ntime))
+
+  (define (time-tai->time-monotonic! time-in)
+    (if (not (eq? (time-type time-in) time-tai))
+	(tm:time-error 'time-tai->time-monotonic!  'incompatible-time-types time-in))
+    (set-time-type! time-in time-monotonic)
+    time-in)
+
+  ;; -- Date Structures
+  (define-values (tm:date make-srfi:date srfi:date? tm:date-ref tm:date-set!)
+    (make-struct-type 
+     'tm:date #f 8 0 #f null (make-inspector) #f null))
+  ;; PLT Scheme date structure has the following:
+  ;;   * second : 0 to 61 (60 and 61 are for unusual leap-seconds)
+  ;;   * minute : 0 to 59
+  ;;   * hour : 0 to 23
+  ;;   * day : 1 to 31
+  ;;   * month : 1 to 12
+  ;;   * year : e.g., 1996
+  ;;   * week-day : 0 (Sunday) to 6 (Saturday)
+  ;;   * year-day : 0 to 365 (364 in non-leap years)
+  ;;   * dst? : #t (daylight savings time) or #f
+  ;;   * time-zone-offset : the number of seconds east of GMT for this time zone (e.g., Pacific Standard Time is -28800), an exact integer 36
+  
+  (define (date-nanosecond d)  (tm:date-ref d 0))
+  (define (srfi:date-second d) (tm:date-ref d 1))
+  (define (srfi:date-minute d) (tm:date-ref d 2))
+  (define (srfi:date-hour d)   (tm:date-ref d 3))
+  (define (srfi:date-day d)    (tm:date-ref d 4))
+  (define (srfi:date-month d)  (tm:date-ref d 5))
+  (define (srfi:date-year d)   (tm:date-ref d 6))
+  (define (date-zone-offset d) (tm:date-ref d 7))
+  
+  (define (tm:set-date-nanosecond! d ns) (tm:date-set! d 0 ns))
+  (define (tm:set-date-second! d s)      (tm:date-set! d 1 s))
+  (define (tm:set-date-minute! d m)      (tm:date-set! d 2 m))
+  (define (tm:set-date-hour! d h)        (tm:date-set! d 3 h))
+  (define (tm:set-date-day! d day)       (tm:date-set! d 4 day))
+  (define (tm:set-date-month! d m)       (tm:date-set! d 5 m))
+  (define (tm:set-date-year! d y)        (tm:date-set! d 6 y))
+  (define (tm:set-date-zone-offset! d i) (tm:date-set! d 7 i))
+  
+  ;; gives the julian day which starts at noon.
+  (define (tm:encode-julian-day-number day month year)
+    (let* ((a (quotient (- 14 month) 12))
+	   (y (- (+ year 4800) a (if (negative? year) -1  0)))
+	   (m (- (+ month (* 12 a)) 3)))
+      (+ day
+	 (quotient (+ (* 153 m) 2) 5)
+	 (* 365 y)
+	 (quotient y 4)
+	 (- (quotient y 100))
+	 (quotient y 400)
+	 -32045)))
+
+  (define (tm:char-pos char str index len)
+    (cond
+     ((>= index len) #f)
+     ((char=? (string-ref str index) char)
+      index)
+     (else
+      (tm:char-pos char str (+ index 1) len))))
+
+  ; return a string representing the decimal expansion of the fractional 
+  ; portion of a number, limited by a specified precision
+  (define (tm:decimal-expansion r precision)
+    (let loop ([num (- r (round r))]
+               [p precision])
+      (if (or (= p 0) (= num 0))
+          ""
+          (let* ([num-times-10 (* 10 num)]
+                 [round-num-times-10 (round num-times-10)]) 
+            (string-append (number->string (inexact->exact round-num-times-10))
+                           (loop (- num-times-10 round-num-times-10) (- p 1)))))))
+
+  ;; gives the seconds/date/month/year
+  (define (tm:decode-julian-day-number jdn)
+    (let* ((days (truncate jdn))
+	   (a (+ days 32044))
+	   (b (quotient (+ (* 4 a) 3) 146097))
+	   (c (- a (quotient (* 146097 b) 4)))
+	   (d (quotient (+ (* 4 c) 3) 1461))
+	   (e (- c (quotient (* 1461 d) 4)))
+	   (m (quotient (+ (* 5 e) 2) 153))
+	   (y (+ (* 100 b) d -4800 (quotient m 10))))
+      (values ; seconds date month year
+       (* (- jdn days) tm:sid)
+       (+ e (- (quotient (+ (* 153 m) 2) 5)) 1)
+       (+ m 3 (* -12 (quotient m 10)))
+       (if (>= 0 y) (- y 1) y))
+      ))
+
+  ;; relies on the fact that we named our time zone accessor
+  ;; differently from MzScheme's....
+  ;; This should be written to be OS specific.
+  (define (tm:local-tz-offset)
+    (date-time-zone-offset (seconds->date (current-seconds))))
+
+  ;; special thing -- ignores nanos
+  (define (tm:time->julian-day-number seconds tz-offset)
+    (+ (/ (+ seconds
+	     tz-offset
+	     tm:sihd)
+	  tm:sid)
+       tm:tai-epoch-in-jd))
+
+  (define (tm:find proc l)
+    (if (null? l)
+	#f
+	(if (proc (car l))
+	    #t
+	    (tm:find proc (cdr l)))))
+
+  (define (tm:tai-before-leap-second? second)
+    (tm:find (lambda (x)
+	       (= second (- (+ (car x) (cdr x)) 1)))
+	     tm:leap-second-table))
+
+  (define (tm:time->date time tz-offset ttype)
+    (if (not (eq? (time-type time) ttype))
+	(tm:time-error 'time->date 'incompatible-time-types  time))
+    (let* ( (offset (:optional tz-offset (tm:local-tz-offset))) )
+      (receive (secs date month year)
+	       (tm:decode-julian-day-number
+		(tm:time->julian-day-number (time-second time) offset))
+	       (let* ( (hours    (quotient secs (* 60 60)))
+		       (rem      (remainder secs (* 60 60)))
+		       (minutes  (quotient rem 60))
+		       (seconds  (remainder rem 60)) )
+		 (make-srfi:date (time-nanosecond time)
+                                 seconds
+                                 minutes
+                                 hours
+                                 date
+                                 month
+                                 year
+                                 offset)))))
+  
+
+
+  (define (time-tai->date time . tz-offset)
+    (if (tm:tai-before-leap-second? (time-second time))
+	;; if it's *right* before the leap, we need to pretend to subtract a second ...
+	(let ((d (tm:time->date (subtract-duration! (time-tai->time-utc time) (make-time time-duration 0 1)) tz-offset time-utc)))
+	  (tm:set-date-second! d 60)
+	  d)
+	(tm:time->date (time-tai->time-utc time) tz-offset time-utc)))
+
+  (define (time-utc->date time . tz-offset)
+    (tm:time->date time tz-offset time-utc))
+
+  ;; again, time-monotonic is the same as time tai
+  (define (time-monotonic->date time . tz-offset)
+    (tm:time->date time tz-offset time-monotonic))
+
+  (define (date->time-utc date)
+    (let ( (nanosecond (date-nanosecond date))
+	   (second (srfi:date-second date))
+	   (minute (srfi:date-minute date))
+	   (hour (srfi:date-hour date))
+	   (day (srfi:date-day date))
+	   (month (srfi:date-month date))
+	   (year (srfi:date-year date))
+	   (offset (date-zone-offset date)) )
+      (let ( (jdays (- (tm:encode-julian-day-number day month year)
+		       tm:tai-epoch-in-jd)) )
+	(make-time 
+	 time-utc
+	 nanosecond
+	 (+ (* (- jdays 1/2) 24 60 60)
+	    (* hour 60 60)
+	    (* minute 60)
+	    second
+	    (- offset))
+	 ))))
+
+  (define (date->time-tai d)
+    (if (= (srfi:date-second d) 60)
+	(subtract-duration! (time-utc->time-tai! (date->time-utc d)) (make-time time-duration 0 1))
+	(time-utc->time-tai! (date->time-utc d))))
+
+  (define (date->time-monotonic date)
+    (time-utc->time-monotonic! (date->time-utc date)))
+
+
+  (define (tm:leap-year? year)
+    (or (= (modulo year 400) 0)
+	(and (= (modulo year 4) 0) (not (= (modulo year 100) 0)))))
+
+  (define (leap-year? date)
+    (tm:leap-year? (srfi:date-year date)))
+  
+  ;; tm:year-day fixed: adding wrong number of days.
+  (define  tm:month-assoc '((0 . 0) (1 . 31)  (2 . 59)   (3 . 90)   (4 . 120) 
+			    (5 . 151) (6 . 181)  (7 . 212)  (8 . 243)
+			    (9 . 273) (10 . 304) (11 . 334)))
+
+  (define (tm:year-day day month year)
+    (let ((days-pr (assoc (- month 1) tm:month-assoc)))
+      (if (not days-pr)
+	  (tm:time-error 'date-year-day 'invalid-month-specification month))
+      (if (and (tm:leap-year? year) (> month 2))
+	  (+ day (cdr days-pr) 1)
+	  (+ day (cdr days-pr)))))
+
+  (define (srfi:date-year-day date)
+    (tm:year-day (srfi:date-day date) (srfi:date-month date) (srfi:date-year date)))
+
+  ;; from calendar faq 
+  (define (tm:week-day day month year)
+    (let* ((a (quotient (- 14 month) 12))
+	   (y (- year a))
+	   (m (+ month (* 12 a) -2)))
+      (modulo (+ day y (quotient y 4) (- (quotient y 100))
+		 (quotient y 400) (quotient (* 31 m) 12))
+	      7)))
+
+  (define (srfi:date-week-day date)
+    (tm:week-day (srfi:date-day date) (srfi:date-month date) (srfi:date-year date)))
+
+  (define (tm:days-before-first-week date day-of-week-starting-week)
+    (let* ( (first-day (make-srfi:date 0 0 0 0
+                                       1
+                                       1
+                                       (srfi:date-year date)
+                                       #f))
+	    (fdweek-day (srfi:date-week-day first-day))  )
+      (modulo (- day-of-week-starting-week fdweek-day)
+	      7)))
+
+  (define (date-week-number date day-of-week-starting-week)
+    (quotient (- (srfi:date-year-day date)
+		 (tm:days-before-first-week  date day-of-week-starting-week))
+	      7))
+
+  (define (current-date . tz-offset) 
+    (time-utc->date (current-time time-utc)
+		    (:optional tz-offset (tm:local-tz-offset))))
+
+  ;; given a 'two digit' number, find the year within 50 years +/-
+  (define (tm:natural-year n)
+    (let* ( (current-year (srfi:date-year (current-date)))
+	    (current-century (* (quotient current-year 100) 100)) )
+      (cond
+       ((>= n 100) n)
+       ((<  n 0) n)
+       ((<=  (- (+ current-century n) current-year) 50)
+	(+ current-century n))
+       (else
+	(+ (- current-century 100) n)))))
+
+  (define (date->julian-day date)
+    (let ( (nanosecond (date-nanosecond date))
+	   (second (srfi:date-second date))
+	   (minute (srfi:date-minute date))
+	   (hour (srfi:date-hour date))
+	   (day (srfi:date-day date))
+	   (month (srfi:date-month date))
+	   (year (srfi:date-year date))
+	   (offset (date-zone-offset date)) )
+      (+ (tm:encode-julian-day-number day month year)
+	 (- 1/2)
+	 (+ (/ (+ (* hour 60 60)
+		  (* minute 60)
+		  second
+		  (/ nanosecond tm:nano)
+                  (- offset))
+	       tm:sid)))))
+
+  (define (date->modified-julian-day date)
+    (- (date->julian-day date)
+       4800001/2))
+
+
+  (define (time-utc->julian-day time)
+    (if (not (eq? (time-type time) time-utc))
+	(tm:time-error 'time->date 'incompatible-time-types  time))
+    (+ (/ (+ (time-second time) (/ (time-nanosecond time) tm:nano))
+	  tm:sid)
+       tm:tai-epoch-in-jd))
+
+  (define (time-utc->modified-julian-day time)
+    (- (time-utc->julian-day time)
+       4800001/2))
+
+  (define (time-tai->julian-day time)
+    (if (not (eq? (time-type time) time-tai))
+	(tm:time-error 'time->date 'incompatible-time-types  time))
+    (+ (/ (+ (- (time-second time) 
+		(tm:leap-second-delta (time-second time)))
+	     (/ (time-nanosecond time) tm:nano))
+	  tm:sid)
+       tm:tai-epoch-in-jd))
+
+  (define (time-tai->modified-julian-day time)
+    (- (time-tai->julian-day time)
+       4800001/2))
+
+  ;; this is the same as time-tai->julian-day
+  (define (time-monotonic->julian-day time)
+    (if (not (eq? (time-type time) time-monotonic))
+	(tm:time-error 'time->date 'incompatible-time-types  time))
+    (+ (/ (+ (- (time-second time) 
+		(tm:leap-second-delta (time-second time)))
+	     (/ (time-nanosecond time) tm:nano))
+	  tm:sid)
+       tm:tai-epoch-in-jd))
+
+
+  (define (time-monotonic->modified-julian-day time)
+    (- (time-monotonic->julian-day time)
+       4800001/2))
+
+
+  (define (julian-day->time-utc jdn)
+    (let ( (nanosecs (* tm:nano tm:sid (- jdn tm:tai-epoch-in-jd))) )
+      (make-time time-utc
+		 (remainder nanosecs tm:nano)
+		 (floor (/ nanosecs tm:nano)))))
+
+  (define (julian-day->time-tai jdn)
+    (time-utc->time-tai! (julian-day->time-utc jdn)))
+
+  (define (julian-day->time-monotonic jdn)
+    (time-utc->time-monotonic! (julian-day->time-utc jdn)))
+
+  (define (julian-day->date jdn . tz-offset)
+    (let ((offset (:optional tz-offset (tm:local-tz-offset))))
+      (time-utc->date (julian-day->time-utc jdn) offset)))
+
+  (define (modified-julian-day->date jdn . tz-offset)
+    (let ((offset (:optional tz-offset (tm:local-tz-offset))))
+      (julian-day->date (+ jdn 4800001/2) offset)))
+
+  (define (modified-julian-day->time-utc jdn)
+    (julian-day->time-utc (+ jdn 4800001/2)))
+
+  (define (modified-julian-day->time-tai jdn)
+    (julian-day->time-tai (+ jdn 4800001/2)))
+
+  (define (modified-julian-day->time-monotonic jdn)
+    (julian-day->time-monotonic (+ jdn 4800001/2)))
+
+  (define (current-julian-day)
+    (time-utc->julian-day (current-time time-utc)))
+
+  (define (current-modified-julian-day)
+    (time-utc->modified-julian-day (current-time time-utc)))
+
+  ;; returns a string rep. of number N, of minimum LENGTH,
+  ;; padded with character PAD-WITH. If PAD-WITH if #f, 
+  ;; no padding is done, and it's as if number->string was used.
+  ;; if string is longer than LENGTH, it's as if number->string was used.
+  (define (tm:padding n pad-with length)
+    (let* ( (str (number->string n))
+	    (str-len (string-length str)) )
+      (if (or (> str-len length)
+	      (not pad-with))
+	  str
+	  (let* ( (new-str (make-string length pad-with))
+		  (new-str-offset (- (string-length new-str)
+				     str-len)) )
+	    (do ((i 0 (+ i 1)))
+		((>= i (string-length str)))
+	      (string-set! new-str (+ new-str-offset i) 
+			   (string-ref str i)))
+	    new-str))))
+
+  (define (tm:last-n-digits i n)
+    (abs (remainder i (expt 10 n))))
+
+  (define (tm:locale-abbr-weekday n) 
+    (localized-message (vector-ref tm:locale-abbr-weekday-vector n)))
+
+  (define (tm:locale-long-weekday n)
+    (localized-message (vector-ref tm:locale-long-weekday-vector n)))
+
+  (define (tm:locale-abbr-month n)
+    (localized-message (vector-ref tm:locale-abbr-month-vector (- n 1))))
+
+  (define (tm:locale-long-month n)
+    (localized-message (vector-ref tm:locale-long-month-vector (- n 1))))
+
+  (define (tm:vector-find needle haystack comparator)
+    (let ((len (vector-length haystack)))
+      (define (tm:vector-find-int index)
+	(cond
+	 ((>= index len) #f)
+	 ((comparator needle (localized-message (vector-ref haystack index))) (+ index 1))
+	 (else (tm:vector-find-int (+ index 1)))))
+      (tm:vector-find-int 0)))
+
+  (define (tm:locale-abbr-weekday->index string)
+    (tm:vector-find string tm:locale-abbr-weekday-vector string=?))
+
+  (define (tm:locale-long-weekday->index string)
+    (tm:vector-find string tm:locale-long-weekday-vector string=?))
+
+  (define (tm:locale-abbr-month->index string)
+    (tm:vector-find string tm:locale-abbr-month-vector string=?))
+
+  (define (tm:locale-long-month->index string)
+    (tm:vector-find string tm:locale-long-month-vector string=?))
+
+
+
+  ;; do nothing. 
+  ;; Your implementation might want to do something...
+  ;; 
+  (define (tm:locale-print-time-zone date port)
+    (values))
+
+  ;; Again, locale specific.
+  (define (tm:locale-am/pm hr)
+    (localized-message
+     (if (> hr 11) tm:locale-pm tm:locale-am)))
+
+  (define (tm:tz-printer offset port)
+    (cond
+     ((= offset 0) (display "Z" port))
+     ((negative? offset) (display "-" port))
+     (else (display "+" port)))
+    (if (not (= offset 0))
+	(let ( (hours   (abs (quotient offset (* 60 60))))
+	       (minutes (abs (quotient (remainder offset (* 60 60)) 60))) )
+	  (display (tm:padding hours #\0 2) port)
+	  (display (tm:padding minutes #\0 2) port))))
+
+  ;; A table of output formatting directives.
+  ;; the first time is the format char.
+  ;; the second is a procedure that takes the date, a padding character
+  ;; (which might be #f), and the output port.
+  ;;
+  (define tm:directives 
+    (list
+     (cons #\~ (lambda (date pad-with port) (display #\~ port)))
+     
+     (cons #\a (lambda (date pad-with port)
+		 (display (tm:locale-abbr-weekday (srfi:date-week-day date))
+			  port)))
+     (cons #\A (lambda (date pad-with port)
+		 (display (tm:locale-long-weekday (srfi:date-week-day date))
+			  port)))
+     (cons #\b (lambda (date pad-with port)
+		 (display (tm:locale-abbr-month (srfi:date-month date))
+			  port)))
+     (cons #\B (lambda (date pad-with port)
+		 (display (tm:locale-long-month (srfi:date-month date))
+			  port)))
+     (cons #\c (lambda (date pad-with port)
+		 (display (date->string date (localized-message tm:locale-date-time-format)) port)))
+     (cons #\d (lambda (date pad-with port)
+		 (display (tm:padding (srfi:date-day date)
+				      #\0 2)
+			  port)))
+     (cons #\D (lambda (date pad-with port)
+		 (display (date->string date "~m/~d/~y") port)))
+     (cons #\e (lambda (date pad-with port)
+		 (display (tm:padding (srfi:date-day date)
+				      #\Space 2)
+			  port)))
+     (cons #\f (lambda (date pad-with port)
+		 (if (> (date-nanosecond date)
+			tm:nano)
+		     (display (tm:padding (+ (srfi:date-second date) 1)
+					  pad-with 2)
+			      port)
+		     (display (tm:padding (srfi:date-second date)
+					  pad-with 2)
+			      port))
+                 (let ([f (tm:decimal-expansion (/ (date-nanosecond date) tm:nano) 6)])
+                   (if (> (string-length f) 0)
+                       (begin
+                         (display (localized-message tm:locale-number-separator) port)
+                         (display f port))))))
+     (cons #\h (lambda (date pad-with port)
+		 (display (date->string date "~b") port)))
+     (cons #\H (lambda (date pad-with port)
+		 (display (tm:padding (srfi:date-hour date)
+				      pad-with 2)
+			  port)))
+     (cons #\I (lambda (date pad-with port)
+		 (let ((hr (srfi:date-hour date)))
+		   (if (> hr 12)
+		       (display (tm:padding (- hr 12)
+					    pad-with 2)
+				port)
+		       (display (tm:padding hr
+					    pad-with 2)
+				port)))))
+     (cons #\j (lambda (date pad-with port)
+		 (display (tm:padding (srfi:date-year-day date)
+				      pad-with 3)
+			  port)))
+     (cons #\k (lambda (date pad-with port)
+		 (display (tm:padding (srfi:date-hour date)
+				      #\0 2)
+			  port)))
+     (cons #\l (lambda (date pad-with port)
+		 (let ((hr (if (> (srfi:date-hour date) 12)
+			       (- (srfi:date-hour date) 12) (srfi:date-hour date))))
+		   (display (tm:padding hr  #\Space 2)
+			    port))))
+     (cons #\m (lambda (date pad-with port)
+		 (display (tm:padding (srfi:date-month date)
+				      pad-with 2)
+			  port)))
+     (cons #\M (lambda (date pad-with port)
+		 (display (tm:padding (srfi:date-minute date)
+				      pad-with 2)
+			  port)))
+     (cons #\n (lambda (date pad-with port)
+		 (newline port)))
+     (cons #\N (lambda (date pad-with port)
+		 (display (tm:padding (date-nanosecond date)
+				      pad-with 7)
+			  port)))
+     (cons #\p (lambda (date pad-with port)
+		 (display (tm:locale-am/pm (srfi:date-hour date)) port)))
+     (cons #\r (lambda (date pad-with port)
+		 (display (date->string date "~I:~M:~S ~p") port)))
+     (cons #\s (lambda (date pad-with port)
+		 (display (time-second (date->time-utc date)) port)))
+     (cons #\S (lambda (date pad-with port)
+		 (if (> (date-nanosecond date)
+			tm:nano)
+		     (display (tm:padding (+ (srfi:date-second date) 1)
+					  pad-with 2)
+			      port)
+		     (display (tm:padding (srfi:date-second date)
+					  pad-with 2)
+			      port))))
+     (cons #\t (lambda (date pad-with port)
+		 (display #\Tab port)))
+     (cons #\T (lambda (date pad-with port)
+		 (display (date->string date "~H:~M:~S") port)))
+     (cons #\U (lambda (date pad-with port)
+		 (if (> (tm:days-before-first-week date 0) 0)
+		     (display (tm:padding (+ (date-week-number date 0) 1)
+					  #\0 2) port)
+		     (display (tm:padding (date-week-number date 0)
+					  #\0 2) port))))
+     (cons #\V (lambda (date pad-with port)
+		 (display (tm:padding (date-week-number date 1)
+				      #\0 2) port)))
+     (cons #\w (lambda (date pad-with port)
+		 (display (srfi:date-week-day date) port)))
+     (cons #\x (lambda (date pad-with port)
+		 (display (date->string date (localized-message tm:locale-short-date-format)) port)))
+     (cons #\X (lambda (date pad-with port)
+		 (display (date->string date (localized-message tm:locale-time-format)) port)))
+     (cons #\W (lambda (date pad-with port)
+		 (if (> (tm:days-before-first-week date 1) 0)
+		     (display (tm:padding (+ (date-week-number date 1) 1)
+					  #\0 2) port)
+		     (display (tm:padding (date-week-number date 1)
+					  #\0 2) port))))
+     (cons #\y (lambda (date pad-with port)
+		 (display (tm:padding (tm:last-n-digits 
+				       (srfi:date-year date) 2)
+				      pad-with
+				      2)
+			  port)))
+     (cons #\Y (lambda (date pad-with port)
+		 (display (srfi:date-year date) port)))
+     (cons #\z (lambda (date pad-with port)
+		 (tm:tz-printer (date-zone-offset date) port)))
+     (cons #\Z (lambda (date pad-with port)
+		 (tm:locale-print-time-zone date port)))
+     (cons #\1 (lambda (date pad-with port)
+		 (display (date->string date "~Y-~m-~d") port)))
+     (cons #\2 (lambda (date pad-with port)
+		 (display (date->string date "~k:~M:~S~z") port)))
+     (cons #\3 (lambda (date pad-with port)
+		 (display (date->string date "~k:~M:~S") port)))
+     (cons #\4 (lambda (date pad-with port)
+		 (display (date->string date "~Y-~m-~dT~k:~M:~S~z") port)))
+     (cons #\5 (lambda (date pad-with port)
+		 (display (date->string date "~Y-~m-~dT~k:~M:~S") port)))
+     ))
+
+
+  (define (tm:get-formatter char)
+    (let ( (associated (assoc char tm:directives)) )
+      (if associated (cdr associated) #f)))
+
+  (define (tm:date-printer date index format-string str-len port)
+    (if (>= index str-len)
+	(values)
+	(let ( (current-char (string-ref format-string index)) )
+	  (if (not (char=? current-char #\~))
+	      (begin
+		(display current-char port)
+		(tm:date-printer date (+ index 1) format-string str-len port))
+	      (if (= (+ index 1) str-len) ; bad format string.
+		  (tm:time-error 'tm:date-printer 'bad-date-format-string 
+				 format-string)
+		  (let ( (pad-char? (string-ref format-string (+ index 1))) )
+		    (cond
+		     ((char=? pad-char? #\-)
+		      (if (= (+ index 2) str-len) ; bad format string.
+			  (tm:time-error 'tm:date-printer 'bad-date-format-string 
+					 format-string)
+			  (let ( (formatter (tm:get-formatter 
+					     (string-ref format-string
+							 (+ index 2)))) )
+			    (if (not formatter)
+				(tm:time-error 'tm:date-printer 'bad-date-format-string 
+					       format-string)
+				(begin
+				  (formatter date #f port)
+				  (tm:date-printer date (+ index 3)
+						   format-string str-len port))))))
+		     
+		     ((char=? pad-char? #\_)
+		      (if (= (+ index 2) str-len) ; bad format string.
+			  (tm:time-error 'tm:date-printer 'bad-date-format-string 
+					 format-string)
+			  (let ( (formatter (tm:get-formatter 
+					     (string-ref format-string
+							 (+ index 2)))) )
+			    (if (not formatter)
+				(tm:time-error 'tm:date-printer 'bad-date-format-string 
+					       format-string)
+				(begin
+				  (formatter date #\Space port)
+				  (tm:date-printer date (+ index 3)
+						   format-string str-len port))))))
+		     (else
+		      (let ( (formatter (tm:get-formatter 
+					 (string-ref format-string
+						     (+ index 1)))) )
+			(if (not formatter)
+			    (tm:time-error 'tm:date-printer 'bad-date-format-string 
+					   format-string)
+			    (begin
+			      (formatter date #\0 port)
+			      (tm:date-printer date (+ index 2)
+					       format-string str-len port))))))))))))
+
+
+  (define (date->string date .  format-string)
+    (let ( (str-port (open-output-string))
+	   (fmt-str (:optional format-string "~c")) )
+      (tm:date-printer date 0 fmt-str (string-length fmt-str) str-port)
+      (get-output-string str-port)))
+  
+  (define (tm:char->int ch)
+    (cond
+     ((char=? ch #\0) 0)
+     ((char=? ch #\1) 1)
+     ((char=? ch #\2) 2)
+     ((char=? ch #\3) 3)
+     ((char=? ch #\4) 4)
+     ((char=? ch #\5) 5)
+     ((char=? ch #\6) 6)
+     ((char=? ch #\7) 7)
+     ((char=? ch #\8) 8)
+     ((char=? ch #\9) 9)
+     (else (tm:time-error 'bad-date-template-string
+			  (list "Non-integer character" ch)))))
+
+  ;; read an integer upto n characters long on port; upto -> #f if any length
+  (define (tm:integer-reader upto port)
+    (define (accum-int port accum nchars)
+      (let ((ch (peek-char port)))
+	(if (or (eof-object? ch)
+		(not (char-numeric? ch))
+		(and upto (>= nchars  upto )))
+	    accum
+	    (accum-int port (+ (* accum 10) (tm:char->int (read-char port))) (+ nchars 1)))))
+    (accum-int port 0 0))
+
+  (define (tm:make-integer-reader upto)
+    (lambda (port)
+      (tm:integer-reader upto port)))
+
+  ;; read *exactly* n characters and convert to integer; could be padded
+  (define (tm:integer-reader-exact n port)
+    (let ( (padding-ok #t) )
+      (define (accum-int port accum nchars)
+	(let ((ch (peek-char port)))
+	  (cond
+	   ((>= nchars n) accum)
+	   ((eof-object? ch) 
+	    (tm:time-error 'string->date 'bad-date-template-string 
+			   "Premature ending to integer read."))
+	   ((char-numeric? ch)
+	    (set! padding-ok #f)
+	    (accum-int port (+ (* accum 10) (tm:char->int (read-char port)))
+		       (+ nchars 1)))
+	   (padding-ok
+	    (read-char port)		; consume padding
+	    (accum-int port accum (+ nchars 1)))
+	   (else			; padding where it shouldn't be
+	    (tm:time-error 'string->date 'bad-date-template-string 
+			   "Non-numeric characters in integer read.")))))
+      (accum-int port 0 0)))
+
+
+  (define (tm:make-integer-exact-reader n)
+    (lambda (port)
+      (tm:integer-reader-exact n port)))
+
+  (define (tm:zone-reader port) 
+    (let ( (offset 0) 
+	   (positive? #f) )
+      (let ( (ch (read-char port)) )
+	(if (eof-object? ch)
+	    (tm:time-error 'string->date 'bad-date-template-string
+			   (list "Invalid time zone +/-" ch)))
+	(if (or (char=? ch #\Z) (char=? ch #\z))
+	    0
+	    (begin
+	      (cond
+	       ((char=? ch #\+) (set! positive? #t))
+	       ((char=? ch #\-) (set! positive? #f))
+	       (else
+		(tm:time-error 'string->date 'bad-date-template-string
+			       (list "Invalid time zone +/-" ch))))
+	      (let ((ch (read-char port)))
+		(if (eof-object? ch)
+		    (tm:time-error 'string->date 'bad-date-template-string (list "Invalid time zone number" ch)))
+		(set! offset (* (tm:char->int ch)
+				10 60 60)))
+	      (let ((ch (read-char port)))
+		(unless (eof-object? ch)
+                    ;; FIXME: non-existing values should be considered Zero instead of an error
+                    ;; (tm:time-error 'string->date 'bad-date-template-string (list "Invalid time zone number" ch)))
+                   (set! offset (+ offset (* (tm:char->int ch) 60 60)))))
+	      (let ((ch (read-char port)))
+		(unless (eof-object? ch)
+                  ;; FIXME: non-existing values should be considered Zero instead of an error
+                  ;; (tm:time-error 'string->date 'bad-date-template-string (list "Invalid time zone number" ch)))
+                  (set! offset (+ offset (* (tm:char->int ch) 10 60)))))
+	      (let ((ch (read-char port)))
+		(unless (eof-object? ch)
+                  ;; FIXME: non-existing values should be considered Zero instead of an error
+                  ;; (tm:time-error 'string->date 'bad-date-template-string (list "Invalid time zone number" ch)))
+		(set! offset (+ offset (* (tm:char->int ch) 60)))))
+              (if positive? offset (- offset)))))))
+  
+  ;; looking at a char, read the char string, run thru indexer, return index
+  (define (tm:locale-reader port indexer)
+    (let ( (string-port (open-output-string)) )
+      (define (read-char-string)
+	(let ((ch (peek-char port)))
+	  (if (char-alphabetic? ch)
+	      (begin (write-char (read-char port) string-port) 
+		     (read-char-string))
+	      (get-output-string string-port))))
+      (let* ( (str (read-char-string)) 
+	      (index (indexer str)) )
+	(if index index (tm:time-error 'string->date
+				       'bad-date-template-string
+				       (list "Invalid string for " indexer))))))
+
+  (define (tm:make-locale-reader indexer)
+    (lambda (port)
+      (tm:locale-reader port indexer)))
+  
+  (define (tm:make-char-id-reader char)
+    (lambda (port)
+      (if (char=? char (read-char port))
+	  char
+	  (tm:time-error 'string->date
+			 'bad-date-template-string
+			 "Invalid character match."))))
+
+  ;; A List of formatted read directives.
+  ;; Each entry is a list.
+  ;; 1. the character directive; 
+  ;; a procedure, which takes a character as input & returns
+  ;; 2. #t as soon as a character on the input port is acceptable
+  ;; for input,
+  ;; 3. a port reader procedure that knows how to read the current port
+  ;; for a value. Its one parameter is the port.
+  ;; 4. a action procedure, that takes the value (from 3.) and some
+  ;; object (here, always the date) and (probably) side-effects it.
+  ;; In some cases (e.g., ~A) the action is to do nothing
+  (define tm:read-directives 
+    (let ( (ireader4 (tm:make-integer-reader 4))
+	  (ireader2 (tm:make-integer-reader 2))
+           (ireader7 (tm:make-integer-reader 7))
+	   (ireaderf (tm:make-integer-reader #f))
+	   (eireader2 (tm:make-integer-exact-reader 2))
+	   (eireader4 (tm:make-integer-exact-reader 4))
+	   (locale-reader-abbr-weekday (tm:make-locale-reader
+					tm:locale-abbr-weekday->index))
+	   (locale-reader-long-weekday (tm:make-locale-reader
+					tm:locale-long-weekday->index))
+	   (locale-reader-abbr-month   (tm:make-locale-reader
+					tm:locale-abbr-month->index))
+	   (locale-reader-long-month   (tm:make-locale-reader
+					tm:locale-long-month->index))
+	   (char-fail (lambda (ch) #t))
+	   (do-nothing (lambda (val object) (values)))
+	   )
+      
+      (list
+       (list #\~ char-fail (tm:make-char-id-reader #\~) do-nothing)
+       (list #\a char-alphabetic? locale-reader-abbr-weekday do-nothing)
+       (list #\A char-alphabetic? locale-reader-long-weekday do-nothing)
+       (list #\b char-alphabetic? locale-reader-abbr-month
+	     (lambda (val object)
+	       (tm:set-date-month! object val)))
+       (list #\B char-alphabetic? locale-reader-long-month
+	     (lambda (val object)
+	       (tm:set-date-month! object val)))
+       (list #\d char-numeric? ireader2 (lambda (val object)
+					  (tm:set-date-day!
+					   object val)))
+       (list #\e char-fail eireader2 (lambda (val object)
+				       (tm:set-date-day! object val)))
+       (list #\h char-alphabetic? locale-reader-abbr-month
+	     (lambda (val object)
+	       (tm:set-date-month! object val)))
+       (list #\H char-numeric? ireader2 (lambda (val object)
+					  (tm:set-date-hour! object val)))
+       (list #\k char-fail eireader2 (lambda (val object)
+				       (tm:set-date-hour! object val)))
+       (list #\m char-numeric? ireader2 (lambda (val object)
+					  (tm:set-date-month! object val)))
+       (list #\M char-numeric? ireader2 (lambda (val object)
+					  (tm:set-date-minute!
+					   object val)))
+       (list #\N char-numeric? ireader7 (lambda (val object)
+                                          (tm:set-date-nanosecond! object val)))
+       (list #\S char-numeric? ireader2 (lambda (val object)
+					  (tm:set-date-second! object val)))
+       (list #\y char-fail eireader2 
+	     (lambda (val object)
+	       (tm:set-date-year! object (tm:natural-year val))))
+       (list #\Y char-numeric? ireader4 (lambda (val object)
+					  (tm:set-date-year! object val)))
+       (list #\z (lambda (c)
+		   (or (char=? c #\Z)
+		       (char=? c #\z)
+		       (char=? c #\+)
+		       (char=? c #\-)))
+	     tm:zone-reader (lambda (val object)
+			      (tm:set-date-zone-offset! object val)))
+       )))
+
+  (define (tm:string->date date index format-string str-len port template-string)
+    (define (skip-until port skipper)
+      (let ((ch (peek-char port)))
+	(if (eof-object? ch)
+	    (tm:time-error 'string->date 'bad-date-format-string template-string)
+	    (if (not (skipper ch))
+		(begin (read-char port) (skip-until port skipper))))))
+    (if (>= index str-len)
+	(begin 
+	  (values))
+	(let ( (current-char (string-ref format-string index)) )
+	  (if (not (char=? current-char #\~))
+	      (let ((port-char (read-char port)))
+		(if (or (eof-object? port-char)
+			(not (char=? current-char port-char)))
+		    (tm:time-error 'string->date 'bad-date-format-string template-string))
+		(tm:string->date date (+ index 1) format-string str-len port template-string))
+	      ;; otherwise, it's an escape, we hope
+	      (if (> (+ index 1) str-len)
+		  (tm:time-error 'string->date 'bad-date-format-string template-string)
+		  (let* ( (format-char (string-ref format-string (+ index 1)))
+			  (format-info (assoc format-char tm:read-directives)) )
+		    (if (not format-info)
+			(tm:time-error 'string->date 'bad-date-format-string template-string)
+			(begin
+			  (let ((skipper (cadr format-info))
+				(reader  (caddr format-info))
+				(actor   (cadddr format-info)))
+			    (skip-until port skipper)
+			    (let ((val (reader port)))
+			      (if (eof-object? val)
+				  (tm:time-error 'string->date 'bad-date-format-string template-string)
+				  (actor val date)))
+			    (tm:string->date date (+ index 2) format-string  str-len port template-string))))))))))
+
+  (define (string->date input-string template-string)
+    (define (tm:date-ok? date)
+      (and (date-nanosecond date)
+	   (srfi:date-second date)
+	   (srfi:date-minute date)
+	   (srfi:date-hour date)
+	   (srfi:date-day date)
+	   (srfi:date-month date)
+	   (srfi:date-year date)
+	   (date-zone-offset date)))
+    (let ( (newdate (make-srfi:date 0 0 0 0 #t #t #t (tm:local-tz-offset))) )
+      (tm:string->date newdate
+		       0
+		       template-string
+		       (string-length template-string)
+		       (open-input-string input-string)
+		       template-string)
+      (if (tm:date-ok? newdate)
+	  newdate
+	  (tm:time-error 'string->date 'bad-date-format-string (list "Incomplete date read. " newdate template-string)))))
+  
+  )
+
diff --git a/collects/srfi/2.ss b/collects/srfi/2.ss
new file mode 100644
index 0000000000..8aa73e67a6
--- /dev/null
+++ b/collects/srfi/2.ss
@@ -0,0 +1,4 @@
+;; module loader for SRFI-2
+(module |2| mzscheme
+  (require (lib "and-let.ss" "srfi" "2"))
+  (provide (all-from (lib "and-let.ss" "srfi" "2"))))
diff --git a/collects/srfi/2/.cvsignore b/collects/srfi/2/.cvsignore
new file mode 100644
index 0000000000..e3ca6473f7
--- /dev/null
+++ b/collects/srfi/2/.cvsignore
@@ -0,0 +1 @@
+compiled
diff --git a/collects/srfi/2/and-let.ss b/collects/srfi/2/and-let.ss
new file mode 100644
index 0000000000..80675bc71d
--- /dev/null
+++ b/collects/srfi/2/and-let.ss
@@ -0,0 +1,204 @@
+;;;
+;;; <land.ss> ---- SRFI 2 port to PLT Scheme: LAND*, a generalized AND.
+;;; Time-stamp: <02/04/30 08:05:27 solsona>
+;;;
+;;; Usually, I would add a copyright notice, and the announce that
+;;; this code is under the LGPL licence.  Nevertheless, I only did the
+;;; port to PLT Scheme, the original comment follows:
+
+; 			Checking of a LAND* special form
+;
+; LAND* is a generalized AND: it evaluates a sequence of forms one after another
+; till the first one that yields #f; the non-#f result of a form can be bound
+; to a fresh variable and used in the subsequent forms.
+;
+; When an ordinary AND is formed of _proper_ boolean expressions:
+;	(AND E1 E2 ...)
+; expression E2, if it gets to be evaluated, knows that E1 has returned non-#f.
+; Moreover, E2 knows exactly what the result of E1 was - #t - so E2 can use
+; this knowledge to its advantage. If E1 however is an _extended_
+; boolean expression, E2 can no longer tell which particular non-#f
+; value E1 has returned. Chances are it took a lot of work to evaluate E1,
+; and the produced result (a number, a vector, a string, etc) may be of
+; value to E2. Alas, the AND form merely checks that the result is not an #f,
+; and throws it away. If E2 needs it, it has to recompute the value again.
+; This proposed LAND* special form lets constituent expressions get
+; hold of the results of already evaluated expressions, without re-doing
+; their work.
+;
+; Syntax:
+; 	LAND* (CLAWS) BODY
+;
+; where CLAWS is a list of expressions or bindings: 
+;	CLAWS ::= '() | (cons CLAW CLAWS)
+; Every element of the CLAWS list, a CLAW, must be one of the following:
+;	(VARIABLE EXPRESSION)
+; or
+;	(EXPRESSION)
+; or
+;	BOUND-VARIABLE
+; These CLAWS are evaluated in the strict left-to-right order. For each
+; CLAW, the EXPRESSION part is evaluated first (or BOUND-VARIABLE is looked up).
+; If the result is #f, LAND* immediately returns #f, thus disregarding the rest
+; of the CLAWS and the BODY. If the EXPRESSION evaluates to not-#f, and
+; the CLAW is of the form
+;	(VARIABLE EXPRESSION)
+; the EXPRESSION's value is bound to a freshly made VARIABLE. The VARIABLE is
+; available for _the rest_ of the CLAWS, and the BODY. As usual, all
+; VARIABLEs must be unique (like in let*).
+;
+; Thus LAND* is a sort of cross-breed between LET* and AND.
+;
+; Denotation semantics:
+;
+; Eval[ (LAND* (CLAW1 ...) BODY), Env] =
+;	EvalClaw[ CLAW1, Env ] andalso 
+;		Eval[ (LAND* ( ...) BODY), ExtClawEnv[ CLAW1, Env]]
+;
+; Eval[ (LAND* (CLAW) ), Env] = EvalClaw[ CLAW, Env ]
+; Eval[ (LAND* () FORM1 ...), Env] = Eval[ (BEGIN FORM1 ...), Env ]
+; Eval[ (LAND* () ), Env] = #t
+;
+; EvalClaw[ BOUND-VARIABLE, Env ] = Eval[ BOUND-VARIABLE, Env ]
+; EvalClaw[ (EXPRESSION), Env ] = Eval[ EXPRESSION, Env ]
+; EvalClaw[ (VARIABLE EXPRESSION), Env ] = Eval[ EXPRESSION, Env ]
+;
+; ExtClawEnv[ BOUND-VARIABLE, Env ] = Env
+; ExtClawEnv[ (EXPRESSION), Env ] = EnvAfterEval[ EXPRESSION, Env ]
+; ExtClawEnv[ (VARIABLE EXPRESSION), Env ] = 
+;	ExtendEnv[ EnvAfterEval[ EXPRESSION, Env ],
+;		   VARIABLE boundto Eval[ EXPRESSION, Env ]]
+;
+;
+; If one has a Scheme interpreter written in Prolog/ML/Haskell, he can
+; implement the above semantics right away. Within Scheme, it is trivial to
+; code LAND* with R4RS "define-syntax". Alas, Gambit does not have this
+; facility. So this implementation uses macros instead.
+;
+; The following LAND* macro will convert a LAND* expression into a "tree" of
+; AND and LET expressions. For example,
+; (LAND* ((my-list (compute-list)) ((not (null? my-list))))
+;	(do-something my-list))
+; is transformed into
+; (and (let ((my-list (compute-list)))
+;	(and my-list  (not (null? my-list)) (begin (do-something my-list)))))
+;
+; I must admit the LAND* macro is written in a pathetic anti-functional style.
+; To my excuse, the macro's goal is a syntactic transformation of source
+; code, that is, performing a re-writing. IMHO, rewriting kind of suggests
+; mutating.
+;
+; Sample applications:
+;
+; The following piece of code (from my treap package) 
+;   (let ((new-root (node:dispatch-on-key root key ...)))
+;      (if new-root (set! root new-root)))
+; could be elegantly re-written as
+;   (land* ((new-root (node:dispatch-on-key root key ...)))
+;		(set! root new-root))
+;
+; A very common application of land* is looking up a value
+; associated with a given key in an assoc list, returning #f in case of a
+; look-up failure:
+;
+;		; Standard implementation
+; (define (look-up key alist)
+;   (let ((found-assoc (assq key alist)))
+;	(and found-assoc (cdr found-assoc))))
+;
+; 		; A more elegant solution
+; (define (look-up key alist)
+;   (cdr (or (assq key alist) '(#f . #f))))
+;
+; 		; An implementation which is just as graceful as the latter
+;		; and just as efficient as the former:
+; (define (look-up key alist)
+;   (land* ((x (assq key alist))) (cdr x)))
+;
+; Generalized cond:
+;
+; (or
+;   (land* (bindings-cond1) body1)
+;   (land* (bindings-cond2) body2)
+;   (begin else-clause))
+;
+; Unlike => (cond's send), LAND* applies beyond cond. LAND* can also be used
+; to generalize cond, as => is limited to sending of only a single value;
+; LAND* allows as many bindings as necessary (which are performed in sequence)
+;
+; (or
+;  (land* ((c (read-char)) ((not (eof-object? c))))
+;	(string-set! some-str i c) (++! i))
+;  (begin (do-process-eof)))
+;
+; Another concept LAND* is reminiscent of is programming with guards:
+; a LAND* form can be considered a sequence of _guarded_ expressions.
+; In a regular program, forms may produce results, bind them to variables
+; and let other forms use these results. LAND* differs in that it checks
+; to make sure that every produced result "makes sense" (that is, not an #f).
+; The first "failure" triggers the guard and aborts the rest of the
+; sequence (which presumably would not make any sense to execute anyway).
+;
+; $Id: and-let.ss,v 1.1 2003/02/25 01:49:25 solsona Exp $
+
+;;; See: http://srfi.schemers.org for more information on SRFIs.
+
+(module and-let mzscheme
+  (provide and-let*)
+
+  ;; Boy, I thought porting Surfies was "easy" :-) The following
+  ;; and-let* macro does not follow the SRFI-2 description, nor the
+  ;; implementation.  I felt like translating Aramaic into Scheme.
+  ;; 
+  ;; This should be very close to what SRFI-2 defines, though. Or so I hope. 
+  
+  (define-syntax (and-let* stx)
+    (syntax-case stx ()
+      
+      ;; FIXME: empty body (returns #t like AND), is this the intended
+      ;; behavior?
+      [(_ ()) (syntax #t)]
+
+      ;; (and-let* ((x y)))
+      [(_ ((id val)))
+       (unless (identifier? (syntax id))
+	       (raise-syntax-error #f "expected an identifier" stx (syntax id)))
+       (syntax val)]
+
+      ;; (and-let* ((x y)) body)
+      [(_ ((id val) more ...) . body)
+       (unless (identifier? (syntax id))
+	 (raise-syntax-error #f "expected an identifier" stx (syntax id)))
+       (syntax (let ((id val))
+		 (if id
+		     (and-let* (more ...) . body)
+		     #f)))]   
+      
+      [(_ ((exp))) (syntax exp)]
+      
+      [(_ ((exp)) . body)
+       (syntax (if exp (begin . body) #f))]
+
+      [(_ (exp)) (syntax exp)]
+
+      [(_ (exp) . body)
+       (syntax (if exp
+		   (begin . body)
+		   #f))]
+
+      [(_ ((exp) more ...) . body)
+       (syntax (if exp
+		   (and-let* (more ...) . body)
+		   #f))]
+
+      [(_ (exp more ...) . body)
+       (syntax (if exp
+      	      (and-let* (more ...) . body)
+      	      #f))]
+      
+      [(_ () . body) (syntax (begin . body))]
+      ))
+
+  )
+
+;;; land.ss ends here
\ No newline at end of file
diff --git a/collects/srfi/23.ss b/collects/srfi/23.ss
new file mode 100644
index 0000000000..e950b14d63
--- /dev/null
+++ b/collects/srfi/23.ss
@@ -0,0 +1,3 @@
+;; Supported by core PLT:
+(module |23| mzscheme
+  (provide error))
\ No newline at end of file
diff --git a/collects/srfi/25.ss b/collects/srfi/25.ss
new file mode 100644
index 0000000000..5ffbd8eaa1
--- /dev/null
+++ b/collects/srfi/25.ss
@@ -0,0 +1,4 @@
+;; module loader for SRFI-25
+(module |25| mzscheme
+  (require (lib "array.ss" "srfi" "25"))
+  (provide (all-from (lib "array.ss" "srfi" "25"))))
diff --git a/collects/srfi/25/.cvsignore b/collects/srfi/25/.cvsignore
new file mode 100644
index 0000000000..e3ca6473f7
--- /dev/null
+++ b/collects/srfi/25/.cvsignore
@@ -0,0 +1 @@
+compiled
diff --git a/collects/srfi/25/arlib.scm b/collects/srfi/25/arlib.scm
new file mode 100644
index 0000000000..cc8153b386
--- /dev/null
+++ b/collects/srfi/25/arlib.scm
@@ -0,0 +1,542 @@
+;; Array library: high level implementation of useful array procedures.
+
+;;; array arlib
+
+;;; 2001 Jussi Piitulainen
+
+;;; This is a high level implementation of some generally useful
+;;; array procedures. In addition to R5RS and SRFI-25, only one
+;;; tool is used, namely array:apply-to-vector and friends. Thus
+;;; this library serves to prove that the primitives really are
+;;; primitives. - A lower level implementation would access some
+;;; implementation details to bypass redundant checking and such.
+
+;;; Note that these procedures are not necessarily designed with
+;;; full care. Think of them as examples of what can be done.
+;;; Important tools are also missing, including scans and reduces
+;;; and many thinks that I have not even heard of yet.
+
+;;; (array-shape arr) (array-length arr dim) (array-size arr)
+;;; (array-equal? arr1 arr2)
+;;; (shape-for-each shp proc [ind])
+;;; (array-for-each-index arr proc [ind])
+;;; (tabulate-array shp proc) (tabulate-array! shp proc ind)
+;;; (array-retabulate! arr shp proc [ind])
+;;; (array-map [shp] proc arr0 arr1 ...)
+;;; (array-map! arr [shp] proc arr0 arr1 ...)
+;;; (array->vector arr) (array->list arr)
+;;; (share-array/prefix arr k ...) (share-row arr k) (share-column arr k)
+;;; (share-array/origin arr k ...) (share-array/origin arr ind)
+;;; (array-append dim arr0 arr1 ...)
+;;; (transpose arr dim ...)
+;;; (share-nths arr dim n)
+
+;;; Naming problem: should all those index-object using procedures
+;;; bang? The main argument, like shape, is not mutated.
+
+;;; (array-shape arr)
+
+(define (array-shape arr)
+  (let ((r (array-rank arr)))
+    (let ((m (make-array (shape 0 r 0 2))))
+      (do ((d 0 (+ d 1)))
+	  ((= d r)
+	   m)
+	(array-set! m d 0 (array-start arr d))
+	(array-set! m d 1 (array-end arr d))))))
+
+;;; (array-length arr dim)
+
+(define (array-length arr dim)
+  (- (array-end arr dim)
+     (array-start arr dim)))
+
+;;; (array-size arr)
+
+(define (array-size arr)
+  (let ((r (array-rank arr)))
+    (do ((k 0 (+ k 1))
+	 (p 1 (* p (array-length arr k))))
+	((= k r) p))))
+
+;;; (array-equal? a b)
+;;; compares elements with equal? so elements better not contain
+;;; arrays.
+
+(define (array-equal? a b)
+  (let ((r (array-rank a)))
+    (and (= r (array-rank b))
+	 (and (do ((k 0 (+ k 1))
+		   (true #t (and true
+				 (= (array-start a k)
+				    (array-start b k))
+				 (= (array-end a k)
+				    (array-end b k)))))
+		  ((= k r) true))
+	      (let ((ks (make-vector r 0)))
+		(let wok ((d 0))
+		  (if (< d r)
+		      (let ((e (array-end a d)))
+			(do ((k (array-start a d) (+ k 1))
+			     (true #t (and true (wok (+ d 1)))))
+			    ((= k e) true)
+			  (vector-set! ks d k)))
+		      (equal? (array-ref a ks)
+			      (array-ref b ks)))))))))
+
+;;; (shape-for-each shp proc [index-object])
+;;; passes each index in shape to proc in row-major orderd, using
+;;; index-object if provided.
+
+(define (shape-for-each shp proc . o)
+  (if (null? o)
+      (array:arlib:shape-for-each/arguments shp proc)
+      (if (vector? (car o))
+	  (array:arlib:shape-for-each/vector shp proc (car o))
+	  (array:arlib:shape-for-each/array shp proc (car o)))))
+
+(define (array:arlib:shape-for-each/arguments shp proc)
+  (let ((r (array-end shp 0)))
+    (let ((vec (make-vector r)))
+      (let do-dim ((d 0))
+	(if (= d r)
+	    (array:apply-to-vector r proc vec)
+	    (let ((e (array-ref shp d 1)))
+	      (do ((k (array-ref shp d 0) (+ k 1)))
+		  ((= k e))
+		(vector-set! vec d k)
+		(do-dim (+ d 1)))))))))
+
+(define (array:arlib:shape-for-each/vector shp proc vec)
+  (let ((r (array-end shp 0)))
+    (let do-dim ((d 0))
+      (if (= d r)
+	  (proc vec)
+	  (let ((e (array-ref shp d 1)))
+	    (do ((k (array-ref shp d 0) (+ k 1)))
+		((= k e))
+	      (vector-set! vec d k)
+	      (do-dim (+ d 1))))))))
+
+(define (array:arlib:shape-for-each/array shp proc arr)
+  ;; arr is not vector
+  (let ((r (array-end shp 0)))
+    (let do-dim ((d 0))
+      (if (= d r)
+	  (proc arr)
+	  (let ((e (array-ref shp d 1)))
+	    (do ((k (array-ref shp d 0) (+ k 1)))
+		((= k e))
+	      (array-set! arr d k)
+	      (do-dim (+ d 1))))))))
+
+;;; (array-for-each-index arr proc [ind])
+;;; is equivalent to
+;;;
+;;;   (shape-for-each-index (array-shape arr) proc [ind])
+;;;
+;;; but is implemented without allocation of the shape, to prove
+;;; that it can be so implemented.
+
+(define (array-for-each-index arr proc . o)
+  (if (null? o)
+      (array:arlib:array-for-each-index/arguments arr proc)
+      (if (vector? (car o))
+	  (array:arlib:array-for-each-index/vector arr proc (car o))
+	  (array:arlib:array-for-each-index/array arr proc (car o)))))
+
+(define (array:arlib:array-for-each-index/arguments arr proc)
+  (let ((r (array-rank arr)))
+    (let ((vec (make-vector r))
+	  (apply (array:applier-to-vector r)))
+      (let do-dim ((d 0))
+	(if (= d r)
+	    (apply proc vec)
+	    (let ((e (array-end arr d)))
+	      (do ((k (array-start arr d) (+ k 1)))
+		  ((= k e))
+		(vector-set! vec d k)
+		(do-dim (+ d 1)))))))))
+
+(define (array:arlib:array-for-each-index/vector arr proc ind)
+  ;; ind is a vector
+  (let ((r (array-rank arr)))
+    (let do-dim ((d 0))
+      (if (= d r)
+	  (proc ind)
+	  (let ((e (array-end arr d)))
+	    (do ((k (array-start arr d) (+ k 1)))
+		((= k e))
+	      (vector-set! ind d k)
+	      (do-dim (+ d 1))))))))
+
+(define (array:arlib:array-for-each-index/array arr proc ind)
+  ;; ind is an array but not a vector
+  (let ((r (array-rank arr)))
+    (let do-dim ((d 0))
+      (if (= d r)
+	  (proc ind)
+	  (let ((e (array-end arr d)))
+	    (do ((k (array-start arr d) (+ k 1)))
+		((= k e))
+	      (array-set! ind d k)
+	      (do-dim (+ d 1))))))))
+
+;;; (tabulate-array shp proc)
+;;; (tabulate-array! shp proc ind)
+;;; returns a newly allocated array of the given shape with initial
+;;; contents at each index whatever proc returns given the indices.
+;;; The latter procedure reuses ind for package of indices.
+
+(define (tabulate-array shp proc)
+  (let ((arr (make-array shp)))
+    (array:arlib:shape-for-each/vector
+     shp
+     (let ((apply (array:applier-to-vector (array-end shp 0))))
+       (lambda (ix) (array-set! arr ix (apply proc ix))))
+     (make-vector (array-end shp 0)))
+    arr))
+
+(define (tabulate-array! shp proc ind)
+  (let ((arr (make-array shp)))
+    (if (vector? ind)
+	(array:arlib:shape-for-each/vector
+	 shp
+	 (lambda (ix) (array-set! arr ix (proc ix)))
+	 ind)
+	(array:arlib:shape-for-each/array
+	 shp
+	 (lambda (ix) (array-set! arr ix (proc ix)))
+	 ind))
+    arr))
+
+;;; (array-retabulate! arr shp proc [index-object])
+;;; sets the elements of arr in shape to the value of proc at that
+;;; index, using index-object if provided.
+
+(define (array-retabulate! arr shp proc . o)
+  (if (null? o)
+      (array:arlib:shape-for-each/vector
+       shp
+       (let ((apply (array:applier-to-vector (array-end shp 0))))
+	 (lambda (ix)
+	   (array-set! arr ix (apply proc ix))))
+       (make-vector (array-end shp 0)))
+      (if (vector? (car o))
+	  (array:arlib:shape-for-each/vector
+	   shp
+	   (lambda (ix)
+	     (array-set! arr ix (proc ix)))
+	   (car o))
+	  (array:arlib:shape-for-each/array
+	   shp
+	   (lambda (ix)
+	     (array-set! arr ix (proc ix)))
+	   (car o)))))
+
+;;; (array-map! array [shape] proc array0 array1...)
+;;; stores to the elements of array (in shape) the values of proc at
+;;; the contents of arrayk at corresponding index.
+
+(define (array-map! arr x y . o)
+  (if (array:array? x)
+      (array:arlib:map! arr x y (apply vector o))
+      (array:arlib:map! arr (array-shape arr) x (apply vector y o))))
+
+(define (array:arlib:map! arr shp proc args)
+  (let ((rank (vector-length args)))
+    (let ((argv (make-vector rank)))
+      (array:arlib:shape-for-each/vector
+       shp
+       (let ((apply (array:applier-to-vector rank)))
+	 (lambda (ix)
+	   (do ((k 0 (+ k 1)))
+	       ((= k rank))
+	     (vector-set! argv k (array-ref (vector-ref args k) ix)))
+	   (array-set! arr ix (apply proc argv))))
+       (make-vector (array-end shp 0))))))
+
+;;; (array-map [shape] proc array0 array1 ...)
+;;; creates a new array with elements initialized to the values of
+;;; proc at contents of arrayk (in shape).
+
+(define (array-map x y . o)
+  (if (array:array? x)
+      (let ((arr (make-array x)))
+	(array:arlib:map! arr x y (apply vector o))
+	arr)
+      (let ((shp (array-shape y)))
+	(let ((arr (make-array shp)))
+	  (array:arlib:map! arr shp x (apply vector y o))
+	  arr))))
+
+;;; SRFI-25 mailing list requested array->vector; they also requested the
+;;; ability to use an array as an index of an element, and array->list is
+;;; an attempt to provide for that.
+
+(define (array->vector arr)
+  (let ((vec (make-vector (array-size arr))))
+    (let ((k 0))
+      (shape-for-each
+       (array-shape arr)
+       (lambda (index)
+	 (vector-set! vec k (array-ref arr index))
+	 (set! k (+ k 1)))
+       (make-vector (array-rank arr)))
+      vec)))
+
+;;; It needs to be said that more efficient implementations are
+;;; possible, even within SRFI-25.
+
+(define (array->list arr)
+  (vector->list (array->vector arr)))
+
+;;; (share-row arr k)
+;;; shares whatever the first index is about.
+;;; The result has one dimension less.
+
+(define (share-row arr k)
+  (share-array
+   arr
+   (let ((bounds (array->list (array-shape arr))))
+     (apply shape (cddr bounds)))
+   (lambda ks
+     (apply values k ks))))
+
+;;; (share-array/prefix arr k ...)
+
+(define (share-array/prefix arr . js)
+  (if (or (null? js)
+	  (integer? (car js)))
+      (share-array
+       arr
+       (let ((bounds (array->list (array-shape arr))))
+	 (apply shape (list-tail bounds (* 2 (length js)))))
+       (lambda ks
+	 (apply values (append js ks))))
+      (apply (lambda (fix)
+	       (share-array/prefix!
+		arr
+		fix
+		(make-vector (- (array-rank arr)
+				(if (vector? fix)
+				    (vector-length fix)
+				    (array-end fix 0))))))
+	     js)))
+
+(define (share-array/prefix! arr fix in . out)
+  (let* ((out (if (pair? out)
+		  ((lambda (out) out) out)
+		  (make-vector (array-rank arr))))
+	 (fix-ref (if (vector? fix) vector-ref array-ref))
+	 (in-ref (if (vector? in) vector-ref array-ref))
+	 (out-set! (if (vector? out) vector-set! array-set!))
+	 (m (if (vector? fix)
+		(vector-length fix)
+		(array-end fix 0)))
+	 (n (if (vector? out)
+		(vector-length out)
+		(array-end out 0))))
+    (do ((k 0 (+ k 1)))
+	((= k m))
+      (out-set! out k (fix-ref fix k)))
+    (share-array/index!
+     arr
+     (let ((bounds (array->list (array-shape arr))))
+       (apply shape (list-tail bounds (if (vector? fix)
+					  (* 2 (vector-length fix))
+					  (* 2 (array-end fix 0))))))
+     (lambda (in)
+       (do ((k m (+ k 1)))
+	   ((= k n))
+	 (out-set! out k (in-ref in (- k m))))
+       out)
+     in)))
+
+;;; (share-column arr k)
+;;; shares whatever the second index is about.
+;;; The result has one dimension less.
+
+(define (share-column arr k)
+  (share-array
+   arr
+   (let ((bounds (array->list (array-shape arr))))
+     (apply shape
+	    (car bounds) (cadr bounds)
+	    (cddddr bounds)))
+   (lambda ks
+     (apply values (car ks) k (cdr ks)))))
+
+;;; (share-array/origin arr k ...)
+;;; (share-array/origin arr index)
+;;; change origin to k ..., with index a vector or zero-based
+;;; one-dimensional array that contains k ...
+;;;
+;;; This is useful for writing array-append. Maybe for something
+;;; else too - who knows.
+
+(define (share-array/origin arr . xs)
+  (let ((new (if (or (null? xs)
+		     (integer? (car xs)))
+		 xs
+		 (apply (lambda (x)
+			  (if (vector? x)
+			      (vector->list x)
+			      (if (array? x)
+				  (array->list x)
+				  (error "share-array/origin: bad thing"))))
+			xs))))
+    (do ((k (array-rank arr) (- k 1))
+	 (old '() (cons (array-start arr (- k 1)) old)))
+	((= k 0)
+	 (let ((ds (map - new old)))
+	   (share-array
+	    arr
+	    (tabulate-array
+	     (shape 0 (array-rank arr) 0 2)
+	     (lambda (r k)
+	       (case k
+		 ((0) (+ (array-start arr r) (list-ref ds r)))
+		 ((1) (+ (array-end arr r) (list-ref ds r))))))
+	    (lambda ks
+	      (apply values (map - ks ds)))))))))
+
+;;; SRFI-25 mailing list requested making shapes their own type. Here's
+;;; an example of how manipulating shapes as arrays can be useful. The
+;;; example also tests that higher level libraries are indeed easy to
+;;; write on top of this SRFI.
+
+;;; (array-append arr1 arr2 dim)
+;;; appends two arrays along a specified dimension. The arrays must
+;;; have equally many dimensions and all other dimensions equally long.
+;;;
+;;; Generalize to more arrays and maybe rewrite with shape-for-each or
+;;; what have you.
+
+(define (array-append dim arr . ars)
+  (let* ((total (do ((m (array-length arr dim)
+			(+ m (array-length (car r) dim)))
+		     (r ars (cdr r)))
+		    ((null? r) m)))
+	 (common (array-shape arr))
+	 (origin (array->vector (share-column common 0)))
+	 (index (make-vector (array-rank arr))))
+    (array-set! common dim 1 (+ (array-start arr dim) total))
+    (let ((result (make-array common)))
+      (array-set! common dim 1 (array-start arr dim))
+      (let wok ((arr arr)
+		(ars ars))
+	(vector-set! origin dim (array-ref common dim 1))
+	(let ((arr1 (share-array/origin arr origin)))
+	  (array-set! common dim 0 (array-start arr1 dim))
+	  (array-set! common dim 1 (array-end arr1 dim))
+	  (shape-for-each
+	   common
+	   (lambda (index)
+	     (array-set! result index (array-ref arr1 index)))
+	   index))
+	(if (pair? ars)
+	    (wok (car ars) (cdr ars))))
+      result)))
+
+;;; Transpose, as permutation of dimensions, is applicable to all
+;;; arrays. The default is reversal.
+
+;;; The implementation uses multiplication by permutation
+;;; matrix but matrix multiplication is not exported.
+
+(define (array:arlib:matrix-times a b)
+  (or (and (= (array-rank a) 2)
+	   (= (array-rank b) 2))
+      (error "times: arrays are not matrices"))
+  (let ((r0 (array-start a 0))  (rn (array-end a 0))
+	(t0 (array-start a 1))  (tn (array-end a 1))
+	(u0 (array-start b 0))  (un (array-end b 0)) 
+	(k0 (array-start b 1))  (kn (array-end b 1)))
+    (or (= (- tn t0) (- un u0))
+	(error "times: matrices are not compatible"))
+    (let ((ab (make-array (shape r0 rn k0 kn))))
+      (do ((r r0 (+ r 1)))
+	  ((= r rn))
+	(do ((k k0 (+ k 1)))
+	    ((= k kn))
+	  (do ((t t0 (+ t 1))
+	       (u u0 (+ u 1))
+	       (s 0 (+ s (* (array-ref a r t)
+			    (array-ref b u k)))))
+	      ((and (= t tn)
+		    (= u un))
+	       (array-set! ab r k s)))))
+      ab)))
+
+; This is a generalized transpose. It can permute the dimensions any which 
+; way. The permutation is provided by a permutation matrix: a square matrix
+; of zeros and ones, with exactly one one in each row and column, or a
+; permutation of the rows of an identity matrix; the size of the matrix
+; must match the number of dimensions of the array.
+;
+; The default permutation is [ 0 1 | 1 0 ] of course, but any permutation
+; array can be specified, and the shape array of the original array is then
+; multiplied with it, and index column vectors of the new array with its
+; inverse, from left, to permute the rows appropriately.
+
+(define (array:arlib:permutation-matrix . ds)
+  (let* ((n (length ds))
+	 (arr (make-array (shape 0 n 0 n) 0)))
+    (do ((k 0 (+ k 1))
+	 (ds ds (cdr ds)))
+	((= k n))
+      (array-set! arr k (car ds) 1))
+    arr))
+
+;;; (transpose arr k ...)
+;;; shares arr with permuted dimensions. Each dimension from 0
+;;; inclusive to rank exclusive must appear once in k ...
+
+(define (transpose a . p0)
+  (let* ((r (array-rank a))
+	 (permutation (apply array:arlib:permutation-matrix
+			     (if (pair? p0)
+				 p0
+				 (do ((ds '() (cons d ds))
+				      (d 0 (+ d 1)))
+				     ((= d r)
+				      ;; reverse dimensions
+				      ds)))))
+	 (inverse-permutation (share-array permutation
+					   (array-shape permutation)
+					   (lambda (r k)
+					     ;; transpose
+					     (values k r)))))
+    (share-array
+     a
+     (array:arlib:matrix-times permutation (array-shape a))
+     (lambda ks0
+       (apply values
+	      (array->list
+	       (array:arlib:matrix-times
+		inverse-permutation
+		(apply array (shape 0 r 0 1) ks0))))))))
+
+;;; (share-array/index! array subshape proc index)
+
+(define (share-array/index! array subshape proc index)
+  (array:share/index! array subshape proc index))
+
+;;; Take every nth slice along dimension d into a shared array. This
+;;; preserves the origin.
+
+(define (share-nths arr d n)
+  (let* ((bounds (array->vector (array-shape arr)))
+	 (b (vector-ref bounds (* 2 d)))
+	 (e (vector-ref bounds (+ (* 2 d) 1))))
+    (vector-set! bounds (+ (* 2 d) 1) (+ b (quotient (+ n (- e b 1)) n)))
+    (share-array
+     arr
+     (apply shape (vector->list bounds))
+     (lambda ks
+       (apply values
+	      (let d/nk ((u 0) (ks ks))
+		(if (= u d)
+		    (cons (+ b (* n (- (car ks) b))) (cdr ks))
+		    (cons (car ks) (d/nk (+ u 1) (cdr ks))))))))))
diff --git a/collects/srfi/25/array.ss b/collects/srfi/25/array.ss
new file mode 100644
index 0000000000..78c179a6a7
--- /dev/null
+++ b/collects/srfi/25/array.ss
@@ -0,0 +1,677 @@
+;; SRFI-25: Array implementation
+;;; 1997 - 2001 Jussi Piitulainen
+
+;;; --- Intro ---
+
+;;; This interface to arrays is based on Alan Bawden's array.scm of
+;;; 1993 (earlier version in the Internet Repository and another
+;;; version in SLIB). This is a complete rewrite, to be consistent
+;;; with the rest of Scheme and to make arrays independent of lists.
+
+;;; Some modifications are due to discussion in srfi-25 mailing list.
+
+;;; (array? obj)
+;;; (make-array shape [obj])             changed arguments
+;;; (shape bound ...)                    new
+;;; (array shape obj ...)                new
+;;; (array-rank array)                   changed name back
+;;; (array-start array dimension)        new
+;;; (array-end array dimension)          new
+;;; (array-ref array k ...)
+;;; (array-ref array index)              new variant
+;;; (array-set! array k ... obj)         changed argument order
+;;; (array-set! array index obj)         new variant
+;;; (share-array array shape proc)       changed arguments
+
+;;; All other variables in this file have names in "array:".
+
+;;; Should there be a way to make arrays with initial values mapped
+;;; from indices? Sure. The current "initial object" is lame.
+;;;
+;;; Removed (array-shape array) from here. There is a new version
+;;; in arlib though.
+
+;;; --- Representation type dependencies ---
+
+;;; The mapping from array indices to the index to the underlying vector
+;;; is whatever array:optimize returns. The file "opt" provides three
+;;; representations:
+;;; 
+;;; mbda) mapping is a procedure that allows an optional argument
+;;; tter) mapping is two procedures that takes exactly the indices
+;;; ctor) mapping is a vector of a constant term and coefficients
+;;;
+;;; Choose one in "opt" to make the optimizer. Then choose the matching
+;;; implementation of array-ref and array-set!.
+;;;
+;;; These should be made macros to inline them. Or have a good compiler
+;;; and plant the package as a module.
+
+;;; 1. Pick an optimizer.
+;;; 2. Pick matching index representation.
+;;; 3. Pick a record implementation; as-procedure is generic; syntax inlines.
+;;; 3. This file is otherwise portable.
+
+;;; --- Portable R5RS (R4RS and multiple values) ---
+
+
+(module array mzscheme
+  (require (lib "9.ss" "srfi");; record-types
+	   )
+  (provide array? make-array shape array array-rank
+	   array-start array-end array-ref array-set! share-array
+	   ;; FIXME: should we export all these?
+	   ;; Array library: high level implementation of useful procedures
+	   array-shape array-length array-size array-equal?
+	   shape-for-each array-for-each-index
+	   tabulate-array array-retabulate! array-map array-map!
+	   array->vector share-array/prefix share-array/origin
+	   array-append transpose share-nths)
+  ;; As defined in as-srfi-9-record.scm in the reference implementation:
+  (define-record-type
+    array:srfi-9-record-type-descriptor
+    (array:make vec ind shp)
+    array:array?
+    (vec array:vector)
+    (ind array:index)
+    (shp array:shape))
+
+  ;; Using SRFI-25 ctor based index representation
+  (require (lib "include.ss"))
+  (include "ix-ctor.scm")
+  (include "op-ctor.scm")
+
+;;; --- Portable R5RS (R4RS and multiple values) ---
+
+;;; (array? obj)
+;;; returns #t if `obj' is an array and #t or #f otherwise.
+
+  (define (array? obj)
+    (array:array? obj))
+
+;;; (make-array shape)
+;;; (make-array shape obj)
+;;; makes array of `shape' with each cell containing `obj' initially.
+
+  (define (make-array shape . rest)
+    (or (array:good-shape? shape)
+	(error "make-array: shape is not a shape"))
+    (apply array:make-array shape rest))
+
+  (define (array:make-array shape . rest)
+    (let ((size (array:size shape)))
+      (array:make
+       (if (pair? rest)
+	   (apply (lambda (o) (make-vector size o)) rest)
+	   (make-vector size))
+       (if (= size 0)
+	   (array:optimize-empty
+	    (vector-ref (array:shape shape) 1))
+	   (array:optimize
+	    (array:make-index shape)
+	    (vector-ref (array:shape shape) 1)))
+       (array:shape->vector shape))))
+
+;;; (shape bound ...)
+;;; makes a shape. Bounds must be an even number of exact, pairwise
+;;; non-decreasing integers. Note that any such array can be a shape.
+
+  (define (shape . bounds)
+    (let ((v (list->vector bounds)))
+      (or (even? (vector-length v))
+	  (error (string-append "shape: uneven number of bounds: "
+				(array:list->string bounds))))
+      (let ((shp (array:make
+		  v
+		  (if (pair? bounds)
+		      (array:shape-index)
+		      (array:empty-shape-index))
+		  (vector 0 (quotient (vector-length v) 2)
+			  0 2))))
+	(or (array:good-shape? shp)
+	    (error (string-append "shape: bounds are not pairwise "
+				  "non-decreasing exact integers: "
+				  (array:list->string bounds))))
+	shp)))
+
+;;; (array shape obj ...)
+;;; is analogous to `vector'.
+
+  (define (array shape . elts)
+    (or (array:good-shape? shape)
+	(error (string-append "array: shape " (array:thing->string shape)
+			      " is not a shape")))
+    (let ((size (array:size shape)))
+      (let ((vector (list->vector elts)))
+	(or (= (vector-length vector) size)
+	    (error (string-append "array: an array of shape "
+				  (array:shape-vector->string
+				   (array:vector shape))
+				  " has "
+				  (number->string size)
+				  " elements but got "
+				  (number->string (vector-length vector))
+				  " values: "
+				  (array:list->string elts))))
+	(array:make
+	 vector
+	 (if (= size 0)
+	     (array:optimize-empty
+	      (vector-ref (array:shape shape) 1))
+	     (array:optimize
+	      (array:make-index shape)
+	      (vector-ref (array:shape shape) 1)))
+	 (array:shape->vector shape)))))
+
+;;; (array-rank array)
+;;; returns the number of dimensions of `array'.
+
+  (define (array-rank array)
+    (quotient (vector-length (array:shape array)) 2))
+
+;;; (array-start array k)
+;;; returns the lower bound index of array along dimension k. This is
+;;; the least valid index along that dimension if the dimension is not
+;;; empty.
+
+  (define (array-start array d)
+    (vector-ref (array:shape array) (+ d d)))
+
+;;; (array-end array k)
+;;; returns the upper bound index of array along dimension k. This is
+;;; not a valid index. If the dimension is empty, this is the same as
+;;; the lower bound along it.
+
+  (define (array-end array d)
+    (vector-ref (array:shape array) (+ d d 1)))
+
+;;; (share-array array shape proc)
+;;; makes an array that shares elements of `array' at shape `shape'.
+;;; The arguments to `proc' are indices of the result.  The values of
+;;; `proc' are indices of `array'.
+
+;;; Todo: in the error message, should recognise the mapping and show it.
+
+  (define (share-array array subshape f)
+    (or (array:good-shape? subshape)
+	(error (string-append "share-array: shape "
+			      (array:thing->string subshape)
+			      " is not a shape")))
+    (let ((subsize (array:size subshape)))
+      (or (array:good-share? subshape subsize f (array:shape array))
+	  (error (string-append "share-array: subshape "
+				(array:shape-vector->string
+				 (array:vector subshape))
+				" does not map into supershape "
+				(array:shape-vector->string
+				 (array:shape array))
+				" under mapping "
+				(array:map->string
+				 f
+				 (vector-ref (array:shape subshape) 1)))))    
+      (let ((g (array:index array)))
+	(array:make
+	 (array:vector array)
+	 (if (= subsize 0)
+	     (array:optimize-empty
+	      (vector-ref (array:shape subshape) 1))
+	     (array:optimize
+	      (lambda ks
+		(call-with-values
+		 (lambda () (apply f ks))
+		 (lambda ks (array:vector-index g ks))))
+	      (vector-ref (array:shape subshape) 1)))
+	 (array:shape->vector subshape)))))
+
+;;; --- Hrmph ---
+
+;;; (array:share/index! ...)
+;;; reuses a user supplied index object when recognising the
+;;; mapping. The mind balks at the very nasty side effect that
+;;; exposes the implementation. So this is not in the spec.
+;;; But letting index objects in at all creates a pressure
+;;; to go the whole hog. Arf.
+
+;;; Use array:optimize-empty for an empty array to get a
+;;; clearly invalid vector index.
+
+;;; Surely it's perverse to use an actor for index here? But
+;;; the possibility is provided for completeness.
+
+  (define (array:share/index! array subshape proc index)
+    (array:make
+     (array:vector array)
+     (if (= (array:size subshape) 0)
+	 (array:optimize-empty
+	  (quotient (vector-length (array:shape array)) 2))
+	 ((if (vector? index)
+	      array:optimize/vector
+	      array:optimize/actor)
+	  (lambda (subindex)
+	    (let ((superindex (proc subindex)))
+	      (if (vector? superindex)
+		  (array:index/vector
+		   (quotient (vector-length (array:shape array)) 2)
+		   (array:index array)
+		   superindex)
+		  (array:index/array
+		   (quotient (vector-length (array:shape array)) 2)
+		   (array:index array)
+		   (array:vector superindex)
+		   (array:index superindex)))))
+	  index))
+     (array:shape->vector subshape)))
+
+  (define (array:optimize/vector f v)
+    (let ((r (vector-length v)))
+      (do ((k 0 (+ k 1)))
+	  ((= k r))
+	(vector-set! v k 0))
+      (let ((n0 (f v))
+	    (cs (make-vector (+ r 1)))
+	    (apply (array:applier-to-vector (+ r 1))))
+	(vector-set! cs 0 n0)
+	(let wok ((k 0))
+	  (if (< k r)
+	      (let ((k1 (+ k 1)))
+		(vector-set! v k 1)
+		(let ((nk (- (f v) n0)))
+		  (vector-set! v k 0)
+		  (vector-set! cs k1 nk)
+		  (wok k1)))))
+	(apply (array:maker r) cs))))
+
+  (define (array:optimize/actor f a)
+    (let ((r (array-end a 0))
+	  (v (array:vector a))
+	  (i (array:index a)))
+      (do ((k 0 (+ k 1)))
+	  ((= k r))
+	(vector-set! v (array:actor-index i k) 0))
+      (let ((n0 (f a))
+	    (cs (make-vector (+ r 1)))
+	    (apply (array:applier-to-vector (+ r 1))))
+	(vector-set! cs 0 n0)
+	(let wok ((k 0))
+	  (if (< k r)
+	      (let ((k1 (+ k 1))
+		    (t (array:actor-index i k)))
+		(vector-set! v t 1)
+		(let ((nk (- (f a) n0)))
+		  (vector-set! v t 0)
+		  (vector-set! cs k1 nk)
+		  (wok k1)))))
+	(apply (array:maker r) cs))))
+
+;;; --- Internals ---
+
+  (define (array:shape->vector shape)
+    (let ((idx (array:index shape))
+	  (shv (array:vector shape))
+	  (rnk (vector-ref (array:shape shape) 1)))
+      (let ((vec (make-vector (* rnk 2))))
+	(do ((k 0 (+ k 1)))
+	    ((= k rnk)
+	     vec)
+	  (vector-set! vec (+ k k)
+		       (vector-ref shv (array:shape-vector-index idx k 0)))
+	  (vector-set! vec (+ k k 1)
+		       (vector-ref shv (array:shape-vector-index idx k 1)))))))
+
+;;; (array:size shape)
+;;; returns the number of elements in arrays of shape `shape'.
+
+  (define (array:size shape)
+    (let ((idx (array:index shape))
+	  (shv (array:vector shape))
+	  (rnk (vector-ref (array:shape shape) 1)))
+      (do   ((k 0 (+ k 1))
+	     (s 1 (* s
+		     (- (vector-ref shv (array:shape-vector-index idx k 1))
+			(vector-ref shv (array:shape-vector-index idx k 0))))))
+	  ((= k rnk) s))))
+
+;;; (array:make-index shape)
+;;; returns an index function for arrays of shape `shape'. This is a
+;;; runtime composition of several variable arity procedures, to be
+;;; passed to array:optimize for recognition as an affine function of
+;;; as many variables as there are dimensions in arrays of this shape.
+
+  (define (array:make-index shape)
+    (let ((idx (array:index shape))
+	  (shv (array:vector shape))
+	  (rnk (vector-ref (array:shape shape) 1)))
+      (do ((f (lambda () 0)
+	      (lambda (k . ks)
+		(+ (* s (- k (vector-ref
+			      shv
+			      (array:shape-vector-index idx (- j 1) 0))))
+		   (apply f ks))))
+	   (s 1 (* s (- (vector-ref
+			 shv
+			 (array:shape-vector-index idx (- j 1) 1))
+			(vector-ref
+			 shv
+			 (array:shape-vector-index idx (- j 1) 0)))))
+	   (j rnk (- j 1)))
+	  ((= j 0)
+	   f))))
+
+
+;;; --- Error checking ---
+
+;;; (array:good-shape? shape)
+;;; returns true if `shape' is an array of the right shape and its
+;;; elements are exact integers that pairwise bound intervals `[lo..hi)´.
+
+  (define (array:good-shape? shape)
+    (and (array:array? shape)
+	 (let ((u (array:shape shape))
+	       (v (array:vector shape))
+	       (x (array:index shape)))
+	   (and (= (vector-length u) 4)
+		(= (vector-ref u 0) 0)
+		(= (vector-ref u 2) 0)
+		(= (vector-ref u 3) 2))
+	   (let ((p (vector-ref u 1)))
+	     (do ((k 0 (+ k 1))
+		  (true #t (let ((lo (vector-ref
+				      v
+				      (array:shape-vector-index x k 0)))
+				 (hi (vector-ref
+				      v
+				      (array:shape-vector-index x k 1))))
+			     (and true
+				  (integer? lo)
+				  (exact? lo)
+				  (integer? hi)
+				  (exact? hi)
+				  (<= lo hi)))))
+		 ((= k p) true))))))
+
+;;; (array:good-share? subv subsize mapping superv)
+;;; returns true if the extreme indices in the subshape vector map
+;;; into the bounds in the supershape vector.
+
+;;; If some interval in `subv' is empty, then `subv' is empty and its
+;;; image under `f' is empty and it is trivially alright.  One must
+;;; not call `f', though.
+
+  (define (array:good-share? subshape subsize f super)
+    (or (zero? subsize)
+	(letrec
+	    ((sub (array:vector subshape))
+	     (dex (array:index subshape))
+	     (ck (lambda (k ks)
+		   (if (zero? k)
+		       (call-with-values
+			(lambda () (apply f ks))
+			(lambda qs (array:good-indices? qs super)))
+		       (and (ck (- k 1)
+				(cons (vector-ref
+				       sub
+				       (array:shape-vector-index
+					dex
+					(- k 1)
+					0))
+				      ks))
+			    (ck (- k 1)
+				(cons (- (vector-ref
+					  sub
+					  (array:shape-vector-index
+					   dex
+					   (- k 1)
+					   1))
+					 1)
+				      ks)))))))
+	  (let ((rnk (vector-ref (array:shape subshape) 1)))
+	    (or (array:unchecked-share-depth? rnk)
+		(ck rnk '()))))))
+
+;;; Check good-share on 10 dimensions at most. The trouble is,
+;;; the cost of this check is exponential in the number of dimensions.
+
+  (define (array:unchecked-share-depth? rank)
+    (if (> rank 10)
+	(begin
+	  (display `(warning: unchecked depth in share:
+			      ,rank subdimensions))
+	  (newline)
+	  #t)
+	#f))
+
+;;; (array:check-indices caller indices shape-vector)
+;;; (array:check-indices.o caller indices shape-vector)
+;;; (array:check-index-vector caller index-vector shape-vector)
+;;; return if the index is in bounds, else signal error.
+;;;
+;;; Shape-vector is the internal representation, with
+;;; b and e for dimension k at 2k and 2k + 1.
+
+  (define (array:check-indices who ks shv)
+    (or (array:good-indices? ks shv)
+	(error (array:not-in who ks shv))))
+
+  (define (array:check-indices.o who ks shv)
+    (or (array:good-indices.o? ks shv)
+	(error (array:not-in who (reverse (cdr (reverse ks))) shv))))
+
+  (define (array:check-index-vector who ks shv)
+    (or (array:good-index-vector? ks shv)
+	(error (array:not-in who (vector->list ks) shv))))
+
+  (define (array:check-index-actor who ks shv)
+    (let ((shape (array:shape ks)))
+      (or (and (= (vector-length shape) 2)
+	       (= (vector-ref shape 0) 0))
+	  (error "not an actor"))
+      (or (array:good-index-actor?
+	   (vector-ref shape 1)
+	   (array:vector ks)
+	   (array:index ks)
+	   shv)
+	  (array:not-in who (do ((k (vector-ref shape 1) (- k 1))
+				 (m '() (cons (vector-ref
+					       (array:vector ks)
+					       (array:actor-index
+						(array:index ks)
+						(- k 1)))
+					      m)))
+				((= k 0) m))
+			shv))))
+
+  (define (array:good-indices? ks shv)
+    (let ((d2 (vector-length shv)))
+      (do ((kp ks (if (pair? kp)
+                      (cdr kp)))
+           (k 0 (+ k 2))
+           (true #t (and true (pair? kp)
+                         (array:good-index? (car kp) shv k))))
+	  ((= k d2)
+	   (and true (null? kp))))))
+
+  (define (array:good-indices.o? ks.o shv)
+    (let ((d2 (vector-length shv)))
+      (do   ((kp ks.o (if (pair? kp)
+			  (cdr kp)))
+	     (k 0 (+ k 2))
+	     (true #t (and true (pair? kp)
+			   (array:good-index? (car kp) shv k))))
+	  ((= k d2)
+	   (and true (pair? kp) (null? (cdr kp)))))))
+
+  (define (array:good-index-vector? ks shv)
+    (let ((r2 (vector-length shv)))
+      (and (= (* 2 (vector-length ks)) r2)
+	   (do ((j 0 (+ j 1))
+		(k 0 (+ k 2))
+		(true #t (and true
+			      (array:good-index? (vector-ref ks j) shv k))))
+	       ((= k r2) true)))))
+
+  (define (array:good-index-actor? r v i shv)
+    (and (= (* 2 r) (vector-length shv))
+	 (do ((j 0 (+ j 1))
+	      (k 0 (+ k 2))
+	      (true #t (and true
+			    (array:good-index? (vector-ref
+						v
+						(array:actor-index i j))
+					       shv
+					       k))))
+	     ((= j r) true))))
+
+;;; (array:good-index? index shape-vector 2d)
+;;; returns true if index is within bounds for dimension 2d/2.
+
+  (define (array:good-index? w shv k)
+    (and (integer? w)
+	 (exact? w)
+	 (<= (vector-ref shv k) w)
+	 (< w (vector-ref shv (+ k 1)))))
+
+  (define (array:not-in who ks shv)
+    (let ((index (array:list->string ks))
+	  (bounds (array:shape-vector->string shv)))
+      (error (string-append who
+			    ": index " index
+			    " not in bounds " bounds))))
+
+  (define (array:list->string ks)
+    (do ((index "" (string-append index (array:thing->string (car ks)) " "))
+	 (ks ks (cdr ks)))
+	((null? ks) index)))
+
+  (define (array:shape-vector->string shv)
+    (do ((bounds "" (string-append bounds
+				   "["
+				   (number->string (vector-ref shv t))
+				   ".."
+				   (number->string (vector-ref shv (+ t 1)))
+				   ")"
+				   " "))
+	 (t 0 (+ t 2)))
+	((= t (vector-length shv)) bounds)))
+
+  (define (array:thing->string thing)
+    (cond
+     ((number? thing) (number->string thing))
+     ((symbol? thing) (string-append "#<symbol>" (symbol->string thing)))
+     ((char? thing) "#<char>")
+     ((string? thing) "#<string>")
+     ((list? thing) (string-append "#" (number->string (length thing))
+				   "<list>"))
+     
+     ((pair? thing) "#<pair>")
+     ((array? thing) "#<array>")
+     ((vector? thing) (string-append "#" (number->string
+					  (vector-length thing))
+				     "<vector>"))
+     ((procedure? thing) "#<procedure>")
+     (else
+      (case thing
+	((()) "()")
+	((#t) "#t")
+	((#f) "#f")
+	(else
+	 "#<whatsit>")))))
+
+;;; And to grok an affine map, vector->vector type. Column k of arr
+;;; will contain coefficients n0 ... nm of 1 k1 ... km for kth value.
+;;; 
+;;; These are for the error message when share fails.
+
+  (define (array:index-ref ind k)
+    (if (vector? ind)
+	(vector-ref ind k)
+	(vector-ref
+	 (array:vector ind)
+	 (array:actor-index (array:index ind) k))))
+
+  (define (array:index-set! ind k o)
+    (if (vector? ind)
+	(vector-set! ind k o)
+	(vector-set!
+	 (array:vector ind)
+	 (array:actor-index (array:index ind) k)
+	 o)))
+
+  (define (array:index-length ind)
+    (if (vector? ind)
+	(vector-length ind)
+	(vector-ref (array:shape ind) 1)))
+
+  (define (array:map->string proc r)
+    (let* ((m (array:grok/arguments proc r))
+	   (s (vector-ref (array:shape m) 3)))
+      (do ((i "" (string-append i c "k" (number->string k)))
+	   (c "" ", ")
+	   (k 1 (+ k 1)))
+	  ((< r k)
+	   (do ((o "" (string-append o c (array:map-column->string m r k)))
+		(c "" ", ")
+		(k 0 (+ k 1)))
+	       ((= k s)
+		(string-append i " => " o)))))))
+
+  (define (array:map-column->string m r k)
+    (let ((v (array:vector m))
+	  (i (array:index m)))
+      (let ((n0 (vector-ref v (array:vector-index i (list 0 k)))))
+	(let wok ((j 1)
+		  (e (if (= n0 0) "" (number->string n0))))
+	  (if (<= j r)
+	      (let ((nj (vector-ref v (array:vector-index i (list j k)))))
+		(if (= nj 0)
+		    (wok (+ j 1) e)
+		    (let* ((nj (if (= nj 1) ""
+				   (if (= nj -1) "-"
+				       (string-append (number->string nj)
+						      " "))))
+			   (njkj (string-append nj "k" (number->string j))))
+		      (if (string=? e "")
+			  (wok (+ j 1) njkj)
+			  (wok (+ j 1) (string-append e " + " njkj))))))
+	      (if (string=? e "") "0" e))))))
+
+  (define (array:grok/arguments proc r)
+    (array:grok/index!
+     (lambda (vec)
+       (call-with-values
+	(lambda ()
+	  (array:apply-to-vector r proc vec))
+	vector))
+     (make-vector r)))
+
+  (define (array:grok/index! proc in)
+    (let ((m (array:index-length in)))
+      (do ((k 0 (+ k 1)))
+	  ((= k m))
+	(array:index-set! in k 0))
+      (let* ((n0 (proc in))
+	     (n (array:index-length n0)))
+	(let ((arr (make-array (shape 0 (+ m 1) 0 n))))	; (*)
+	  (do ((k 0 (+ k 1)))
+	      ((= k n))
+	    (array-set! arr 0 k (array:index-ref n0 k))) ; (**)
+	  (do ((j 0 (+ j 1)))
+	      ((= j m))
+	    (array:index-set! in j 1)
+	    (let ((nj (proc in)))
+	      (array:index-set! in j 0)
+	      (do ((k 0 (+ k 1)))
+		  ((= k n))
+		(array-set! arr (+ j 1) k (- (array:index-ref nj k) ; (**)
+					     (array:index-ref n0 k))))))
+	  arr))))
+  ;; (*)  Should not use `make-array' and `shape' here
+  ;; (**) Should not use `array-set!' here
+  ;; Should use something internal to the library instead: either lower
+  ;; level code (preferable but complex) or alternative names to these same.
+
+  ;; The array library:
+  (include "arlib.scm")
+  
+  )  
+
+  
\ No newline at end of file
diff --git a/collects/srfi/25/ix-ctor.scm b/collects/srfi/25/ix-ctor.scm
new file mode 100644
index 0000000000..b6f99a4f0b
--- /dev/null
+++ b/collects/srfi/25/ix-ctor.scm
@@ -0,0 +1,77 @@
+(define (array-ref a . xs)
+  (or (array:array? a)
+      (error "not an array"))
+  (let ((shape (array:shape a)))
+    (if (null? xs)
+        (array:check-indices "array-ref" xs shape)
+        (let ((x (car xs)))
+          (if (vector? x)
+              (array:check-index-vector "array-ref" x shape)
+              (if (integer? x)
+                  (array:check-indices "array-ref" xs shape)
+                  (if (array:array? x)
+                      (array:check-index-actor "array-ref" x shape)
+                      (error "not an index object"))))))
+    (vector-ref
+     (array:vector a)
+     (if (null? xs)
+         (vector-ref (array:index a) 0)
+         (let ((x (car xs)))
+           (if (vector? x)
+               (array:index/vector
+                (quotient (vector-length shape) 2)
+                (array:index a)
+                x)
+               (if (integer? x)
+                   (array:vector-index (array:index a) xs)
+                   (if (array:array? x)
+                       (array:index/array
+                        (quotient (vector-length shape) 2)
+                        (array:index a)
+                        (array:vector x)
+                        (array:index x))
+                       (error "array-ref: bad index object")))))))))
+
+(define (array-set! a x . xs)
+  (or (array:array? a)
+      (error "array-set!: not an array"))
+  (let ((shape (array:shape a)))
+    (if (null? xs)
+        (array:check-indices "array-set!" '() shape)
+        (if (vector? x)
+            (array:check-index-vector "array-set!" x shape)
+            (if (integer? x)
+                (array:check-indices.o "array-set!" (cons x xs) shape)
+                (if (array:array? x)
+                    (array:check-index-actor "array-set!" x shape)
+                    (error "not an index object")))))
+    (if (null? xs)
+        (vector-set! (array:vector a) (vector-ref (array:index a) 0) x)
+        (if (vector? x)
+            (vector-set! (array:vector a)
+                         (array:index/vector
+                          (quotient (vector-length shape) 2)
+                          (array:index a)
+                          x)
+                         (car xs))
+            (if (integer? x)
+                (let ((v (array:vector a))
+                      (i (array:index a))
+                      (r (quotient (vector-length shape) 2)))
+                  (do ((sum (* (vector-ref i 0) x)
+                            (+ sum (* (vector-ref i k) (car ks))))
+                       (ks xs (cdr ks))
+                       (k 1 (+ k 1)))
+                    ((= k r)
+                     (vector-set! v (+ sum (vector-ref i k)) (car ks)))))
+                (if (array:array? x)
+                    (vector-set! (array:vector a)
+                                 (array:index/array
+                                  (quotient (vector-length shape) 2)
+                                  (array:index a)
+                                  (array:vector x)
+                                  (array:index x))
+                                 (car xs))
+                    (error (string-append
+                            "array-set!: bad index object: "
+                            (array:thing->string x)))))))))
diff --git a/collects/srfi/25/op-ctor.scm b/collects/srfi/25/op-ctor.scm
new file mode 100644
index 0000000000..a78a0afe82
--- /dev/null
+++ b/collects/srfi/25/op-ctor.scm
@@ -0,0 +1,645 @@
+(begin
+  (define array:opt-args '(ctor (4)))
+  (define (array:optimize f r)
+    (case r
+      ((0) (let ((n0 (f))) (array:0 n0)))
+      ((1) (let ((n0 (f 0))) (array:1 n0 (- (f 1) n0))))
+      ((2)
+       (let ((n0 (f 0 0)))
+         (array:2 n0 (- (f 1 0) n0) (- (f 0 1) n0))))
+      ((3)
+       (let ((n0 (f 0 0 0)))
+         (array:3
+           n0
+           (- (f 1 0 0) n0)
+           (- (f 0 1 0) n0)
+           (- (f 0 0 1) n0))))
+      (else
+       (let ((v
+              (do ((k 0 (+ k 1)) (v '() (cons 0 v)))
+                  ((= k r) v))))
+         (let ((n0 (apply f v)))
+           (apply
+            array:n
+            n0
+            (array:coefficients f n0 v v)))))))
+  (define (array:optimize-empty r)
+    (let ((x (make-vector (+ r 1) 0)))
+      (vector-set! x r -1)
+      x))
+  (define (array:coefficients f n0 vs vp)
+    (case vp
+      ((()) '())
+      (else
+       (set-car! vp 1)
+       (let ((n (- (apply f vs) n0)))
+         (set-car! vp 0)
+         (cons n (array:coefficients f n0 vs (cdr vp)))))))
+  (define (array:vector-index x ks)
+    (do ((sum 0 (+ sum (* (vector-ref x k) (car ks))))
+         (ks ks (cdr ks))
+         (k 0 (+ k 1)))
+        ((null? ks) (+ sum (vector-ref x k)))))
+  (define (array:shape-index) '#(2 1 0))
+  (define (array:empty-shape-index) '#(0 0 -1))
+  (define (array:shape-vector-index x r k)
+    (+
+     (* (vector-ref x 0) r)
+     (* (vector-ref x 1) k)
+     (vector-ref x 2)))
+  (define (array:actor-index x k)
+    (+ (* (vector-ref x 0) k) (vector-ref x 1)))
+  (define (array:0 n0) (vector n0))
+  (define (array:1 n0 n1) (vector n1 n0))
+  (define (array:2 n0 n1 n2) (vector n1 n2 n0))
+  (define (array:3 n0 n1 n2 n3) (vector n1 n2 n3 n0))
+  (define (array:n n0 n1 n2 n3 n4 . ns)
+    (apply vector n1 n2 n3 n4 (append ns (list n0))))
+  (define (array:maker r)
+    (case r
+      ((0) array:0)
+      ((1) array:1)
+      ((2) array:2)
+      ((3) array:3)
+      (else array:n)))
+  (define array:indexer/vector
+    (let ((em
+           (vector
+             (lambda (x i) (+ (vector-ref x 0)))
+             (lambda (x i)
+               (+
+                (* (vector-ref x 0) (vector-ref i 0))
+                (vector-ref x 1)))
+             (lambda (x i)
+               (+
+                (* (vector-ref x 0) (vector-ref i 0))
+                (* (vector-ref x 1) (vector-ref i 1))
+                (vector-ref x 2)))
+             (lambda (x i)
+               (+
+                (* (vector-ref x 0) (vector-ref i 0))
+                (* (vector-ref x 1) (vector-ref i 1))
+                (* (vector-ref x 2) (vector-ref i 2))
+                (vector-ref x 3)))
+             (lambda (x i)
+               (+
+                (* (vector-ref x 0) (vector-ref i 0))
+                (* (vector-ref x 1) (vector-ref i 1))
+                (* (vector-ref x 2) (vector-ref i 2))
+                (* (vector-ref x 3) (vector-ref i 3))
+                (vector-ref x 4)))
+             (lambda (x i)
+               (+
+                (* (vector-ref x 0) (vector-ref i 0))
+                (* (vector-ref x 1) (vector-ref i 1))
+                (* (vector-ref x 2) (vector-ref i 2))
+                (* (vector-ref x 3) (vector-ref i 3))
+                (* (vector-ref x 4) (vector-ref i 4))
+                (vector-ref x 5)))
+             (lambda (x i)
+               (+
+                (* (vector-ref x 0) (vector-ref i 0))
+                (* (vector-ref x 1) (vector-ref i 1))
+                (* (vector-ref x 2) (vector-ref i 2))
+                (* (vector-ref x 3) (vector-ref i 3))
+                (* (vector-ref x 4) (vector-ref i 4))
+                (* (vector-ref x 5) (vector-ref i 5))
+                (vector-ref x 6)))
+             (lambda (x i)
+               (+
+                (* (vector-ref x 0) (vector-ref i 0))
+                (* (vector-ref x 1) (vector-ref i 1))
+                (* (vector-ref x 2) (vector-ref i 2))
+                (* (vector-ref x 3) (vector-ref i 3))
+                (* (vector-ref x 4) (vector-ref i 4))
+                (* (vector-ref x 5) (vector-ref i 5))
+                (* (vector-ref x 6) (vector-ref i 6))
+                (vector-ref x 7)))
+             (lambda (x i)
+               (+
+                (* (vector-ref x 0) (vector-ref i 0))
+                (* (vector-ref x 1) (vector-ref i 1))
+                (* (vector-ref x 2) (vector-ref i 2))
+                (* (vector-ref x 3) (vector-ref i 3))
+                (* (vector-ref x 4) (vector-ref i 4))
+                (* (vector-ref x 5) (vector-ref i 5))
+                (* (vector-ref x 6) (vector-ref i 6))
+                (* (vector-ref x 7) (vector-ref i 7))
+                (vector-ref x 8)))
+             (lambda (x i)
+               (+
+                (* (vector-ref x 0) (vector-ref i 0))
+                (* (vector-ref x 1) (vector-ref i 1))
+                (* (vector-ref x 2) (vector-ref i 2))
+                (* (vector-ref x 3) (vector-ref i 3))
+                (* (vector-ref x 4) (vector-ref i 4))
+                (* (vector-ref x 5) (vector-ref i 5))
+                (* (vector-ref x 6) (vector-ref i 6))
+                (* (vector-ref x 7) (vector-ref i 7))
+                (* (vector-ref x 8) (vector-ref i 8))
+                (vector-ref x 9)))))
+          (it
+           (lambda (w)
+             (lambda (x i)
+               (+
+                (* (vector-ref x 0) (vector-ref i 0))
+                (* (vector-ref x 1) (vector-ref i 1))
+                (* (vector-ref x 2) (vector-ref i 2))
+                (* (vector-ref x 3) (vector-ref i 3))
+                (* (vector-ref x 4) (vector-ref i 4))
+                (* (vector-ref x 5) (vector-ref i 5))
+                (* (vector-ref x 6) (vector-ref i 6))
+                (* (vector-ref x 7) (vector-ref i 7))
+                (* (vector-ref x 8) (vector-ref i 8))
+                (* (vector-ref x 9) (vector-ref i 9))
+                (do ((xi
+                      0
+                      (+
+                       (* (vector-ref x u) (vector-ref i u))
+                       xi))
+                     (u (- w 1) (- u 1)))
+                    ((< u 10) xi))
+                (vector-ref x w))))))
+      (lambda (r) (if (< r 10) (vector-ref em r) (it r)))))
+  (define array:indexer/array
+    (let ((em
+           (vector
+             (lambda (x v i) (+ (vector-ref x 0)))
+             (lambda (x v i)
+               (+
+                (*
+                 (vector-ref x 0)
+                 (vector-ref v (array:actor-index i 0)))
+                (vector-ref x 1)))
+             (lambda (x v i)
+               (+
+                (*
+                 (vector-ref x 0)
+                 (vector-ref v (array:actor-index i 0)))
+                (*
+                 (vector-ref x 1)
+                 (vector-ref v (array:actor-index i 1)))
+                (vector-ref x 2)))
+             (lambda (x v i)
+               (+
+                (*
+                 (vector-ref x 0)
+                 (vector-ref v (array:actor-index i 0)))
+                (*
+                 (vector-ref x 1)
+                 (vector-ref v (array:actor-index i 1)))
+                (*
+                 (vector-ref x 2)
+                 (vector-ref v (array:actor-index i 2)))
+                (vector-ref x 3)))
+             (lambda (x v i)
+               (+
+                (*
+                 (vector-ref x 0)
+                 (vector-ref v (array:actor-index i 0)))
+                (*
+                 (vector-ref x 1)
+                 (vector-ref v (array:actor-index i 1)))
+                (*
+                 (vector-ref x 2)
+                 (vector-ref v (array:actor-index i 2)))
+                (*
+                 (vector-ref x 3)
+                 (vector-ref v (array:actor-index i 3)))
+                (vector-ref x 4)))
+             (lambda (x v i)
+               (+
+                (*
+                 (vector-ref x 0)
+                 (vector-ref v (array:actor-index i 0)))
+                (*
+                 (vector-ref x 1)
+                 (vector-ref v (array:actor-index i 1)))
+                (*
+                 (vector-ref x 2)
+                 (vector-ref v (array:actor-index i 2)))
+                (*
+                 (vector-ref x 3)
+                 (vector-ref v (array:actor-index i 3)))
+                (*
+                 (vector-ref x 4)
+                 (vector-ref v (array:actor-index i 4)))
+                (vector-ref x 5)))
+             (lambda (x v i)
+               (+
+                (*
+                 (vector-ref x 0)
+                 (vector-ref v (array:actor-index i 0)))
+                (*
+                 (vector-ref x 1)
+                 (vector-ref v (array:actor-index i 1)))
+                (*
+                 (vector-ref x 2)
+                 (vector-ref v (array:actor-index i 2)))
+                (*
+                 (vector-ref x 3)
+                 (vector-ref v (array:actor-index i 3)))
+                (*
+                 (vector-ref x 4)
+                 (vector-ref v (array:actor-index i 4)))
+                (*
+                 (vector-ref x 5)
+                 (vector-ref v (array:actor-index i 5)))
+                (vector-ref x 6)))
+             (lambda (x v i)
+               (+
+                (*
+                 (vector-ref x 0)
+                 (vector-ref v (array:actor-index i 0)))
+                (*
+                 (vector-ref x 1)
+                 (vector-ref v (array:actor-index i 1)))
+                (*
+                 (vector-ref x 2)
+                 (vector-ref v (array:actor-index i 2)))
+                (*
+                 (vector-ref x 3)
+                 (vector-ref v (array:actor-index i 3)))
+                (*
+                 (vector-ref x 4)
+                 (vector-ref v (array:actor-index i 4)))
+                (*
+                 (vector-ref x 5)
+                 (vector-ref v (array:actor-index i 5)))
+                (*
+                 (vector-ref x 6)
+                 (vector-ref v (array:actor-index i 6)))
+                (vector-ref x 7)))
+             (lambda (x v i)
+               (+
+                (*
+                 (vector-ref x 0)
+                 (vector-ref v (array:actor-index i 0)))
+                (*
+                 (vector-ref x 1)
+                 (vector-ref v (array:actor-index i 1)))
+                (*
+                 (vector-ref x 2)
+                 (vector-ref v (array:actor-index i 2)))
+                (*
+                 (vector-ref x 3)
+                 (vector-ref v (array:actor-index i 3)))
+                (*
+                 (vector-ref x 4)
+                 (vector-ref v (array:actor-index i 4)))
+                (*
+                 (vector-ref x 5)
+                 (vector-ref v (array:actor-index i 5)))
+                (*
+                 (vector-ref x 6)
+                 (vector-ref v (array:actor-index i 6)))
+                (*
+                 (vector-ref x 7)
+                 (vector-ref v (array:actor-index i 7)))
+                (vector-ref x 8)))
+             (lambda (x v i)
+               (+
+                (*
+                 (vector-ref x 0)
+                 (vector-ref v (array:actor-index i 0)))
+                (*
+                 (vector-ref x 1)
+                 (vector-ref v (array:actor-index i 1)))
+                (*
+                 (vector-ref x 2)
+                 (vector-ref v (array:actor-index i 2)))
+                (*
+                 (vector-ref x 3)
+                 (vector-ref v (array:actor-index i 3)))
+                (*
+                 (vector-ref x 4)
+                 (vector-ref v (array:actor-index i 4)))
+                (*
+                 (vector-ref x 5)
+                 (vector-ref v (array:actor-index i 5)))
+                (*
+                 (vector-ref x 6)
+                 (vector-ref v (array:actor-index i 6)))
+                (*
+                 (vector-ref x 7)
+                 (vector-ref v (array:actor-index i 7)))
+                (*
+                 (vector-ref x 8)
+                 (vector-ref v (array:actor-index i 8)))
+                (vector-ref x 9)))))
+          (it
+           (lambda (w)
+             (lambda (x v i)
+               (+
+                (*
+                 (vector-ref x 0)
+                 (vector-ref v (array:actor-index i 0)))
+                (*
+                 (vector-ref x 1)
+                 (vector-ref v (array:actor-index i 1)))
+                (*
+                 (vector-ref x 2)
+                 (vector-ref v (array:actor-index i 2)))
+                (*
+                 (vector-ref x 3)
+                 (vector-ref v (array:actor-index i 3)))
+                (*
+                 (vector-ref x 4)
+                 (vector-ref v (array:actor-index i 4)))
+                (*
+                 (vector-ref x 5)
+                 (vector-ref v (array:actor-index i 5)))
+                (*
+                 (vector-ref x 6)
+                 (vector-ref v (array:actor-index i 6)))
+                (*
+                 (vector-ref x 7)
+                 (vector-ref v (array:actor-index i 7)))
+                (*
+                 (vector-ref x 8)
+                 (vector-ref v (array:actor-index i 8)))
+                (*
+                 (vector-ref x 9)
+                 (vector-ref v (array:actor-index i 9)))
+                (do ((xi
+                      0
+                      (+
+                       (*
+                        (vector-ref x u)
+                        (vector-ref
+                          v
+                          (array:actor-index i u)))
+                       xi))
+                     (u (- w 1) (- u 1)))
+                    ((< u 10) xi))
+                (vector-ref x w))))))
+      (lambda (r) (if (< r 10) (vector-ref em r) (it r)))))
+  (define array:applier-to-vector
+    (let ((em
+           (vector
+             (lambda (p v) (p))
+             (lambda (p v) (p (vector-ref v 0)))
+             (lambda (p v)
+               (p (vector-ref v 0) (vector-ref v 1)))
+             (lambda (p v)
+               (p
+                (vector-ref v 0)
+                (vector-ref v 1)
+                (vector-ref v 2)))
+             (lambda (p v)
+               (p
+                (vector-ref v 0)
+                (vector-ref v 1)
+                (vector-ref v 2)
+                (vector-ref v 3)))
+             (lambda (p v)
+               (p
+                (vector-ref v 0)
+                (vector-ref v 1)
+                (vector-ref v 2)
+                (vector-ref v 3)
+                (vector-ref v 4)))
+             (lambda (p v)
+               (p
+                (vector-ref v 0)
+                (vector-ref v 1)
+                (vector-ref v 2)
+                (vector-ref v 3)
+                (vector-ref v 4)
+                (vector-ref v 5)))
+             (lambda (p v)
+               (p
+                (vector-ref v 0)
+                (vector-ref v 1)
+                (vector-ref v 2)
+                (vector-ref v 3)
+                (vector-ref v 4)
+                (vector-ref v 5)
+                (vector-ref v 6)))
+             (lambda (p v)
+               (p
+                (vector-ref v 0)
+                (vector-ref v 1)
+                (vector-ref v 2)
+                (vector-ref v 3)
+                (vector-ref v 4)
+                (vector-ref v 5)
+                (vector-ref v 6)
+                (vector-ref v 7)))
+             (lambda (p v)
+               (p
+                (vector-ref v 0)
+                (vector-ref v 1)
+                (vector-ref v 2)
+                (vector-ref v 3)
+                (vector-ref v 4)
+                (vector-ref v 5)
+                (vector-ref v 6)
+                (vector-ref v 7)
+                (vector-ref v 8)))))
+          (it
+           (lambda (r)
+             (lambda (p v)
+               (apply
+                p
+                (vector-ref v 0)
+                (vector-ref v 1)
+                (vector-ref v 2)
+                (vector-ref v 3)
+                (vector-ref v 4)
+                (vector-ref v 5)
+                (vector-ref v 6)
+                (vector-ref v 7)
+                (vector-ref v 8)
+                (vector-ref v 9)
+                (do ((k r (- k 1))
+                     (r
+                      '()
+                      (cons (vector-ref v (- k 1)) r)))
+                    ((= k 10) r)))))))
+      (lambda (r) (if (< r 10) (vector-ref em r) (it r)))))
+  (define array:applier-to-actor
+    (let ((em
+           (vector
+             (lambda (p a) (p))
+             (lambda (p a) (p (array-ref a 0)))
+             (lambda (p a)
+               (p (array-ref a 0) (array-ref a 1)))
+             (lambda (p a)
+               (p
+                (array-ref a 0)
+                (array-ref a 1)
+                (array-ref a 2)))
+             (lambda (p a)
+               (p
+                (array-ref a 0)
+                (array-ref a 1)
+                (array-ref a 2)
+                (array-ref a 3)))
+             (lambda (p a)
+               (p
+                (array-ref a 0)
+                (array-ref a 1)
+                (array-ref a 2)
+                (array-ref a 3)
+                (array-ref a 4)))
+             (lambda (p a)
+               (p
+                (array-ref a 0)
+                (array-ref a 1)
+                (array-ref a 2)
+                (array-ref a 3)
+                (array-ref a 4)
+                (array-ref a 5)))
+             (lambda (p a)
+               (p
+                (array-ref a 0)
+                (array-ref a 1)
+                (array-ref a 2)
+                (array-ref a 3)
+                (array-ref a 4)
+                (array-ref a 5)
+                (array-ref a 6)))
+             (lambda (p a)
+               (p
+                (array-ref a 0)
+                (array-ref a 1)
+                (array-ref a 2)
+                (array-ref a 3)
+                (array-ref a 4)
+                (array-ref a 5)
+                (array-ref a 6)
+                (array-ref a 7)))
+             (lambda (p a)
+               (p
+                (array-ref a 0)
+                (array-ref a 1)
+                (array-ref a 2)
+                (array-ref a 3)
+                (array-ref a 4)
+                (array-ref a 5)
+                (array-ref a 6)
+                (array-ref a 7)
+                (array-ref a 8)))))
+          (it
+           (lambda (r)
+             (lambda (p a)
+               (apply
+                a
+                (array-ref a 0)
+                (array-ref a 1)
+                (array-ref a 2)
+                (array-ref a 3)
+                (array-ref a 4)
+                (array-ref a 5)
+                (array-ref a 6)
+                (array-ref a 7)
+                (array-ref a 8)
+                (array-ref a 9)
+                (do ((k r (- k 1))
+                     (r '() (cons (array-ref a (- k 1)) r)))
+                    ((= k 10) r)))))))
+      (lambda (r)
+        "These are high level, hiding implementation at call site."
+        (if (< r 10) (vector-ref em r) (it r)))))
+  (define array:applier-to-backing-vector
+    (let ((em
+           (vector
+             (lambda (p ai av) (p))
+             (lambda (p ai av)
+               (p (vector-ref av (array:actor-index ai 0))))
+             (lambda (p ai av)
+               (p
+                (vector-ref av (array:actor-index ai 0))
+                (vector-ref av (array:actor-index ai 1))))
+             (lambda (p ai av)
+               (p
+                (vector-ref av (array:actor-index ai 0))
+                (vector-ref av (array:actor-index ai 1))
+                (vector-ref av (array:actor-index ai 2))))
+             (lambda (p ai av)
+               (p
+                (vector-ref av (array:actor-index ai 0))
+                (vector-ref av (array:actor-index ai 1))
+                (vector-ref av (array:actor-index ai 2))
+                (vector-ref av (array:actor-index ai 3))))
+             (lambda (p ai av)
+               (p
+                (vector-ref av (array:actor-index ai 0))
+                (vector-ref av (array:actor-index ai 1))
+                (vector-ref av (array:actor-index ai 2))
+                (vector-ref av (array:actor-index ai 3))
+                (vector-ref av (array:actor-index ai 4))))
+             (lambda (p ai av)
+               (p
+                (vector-ref av (array:actor-index ai 0))
+                (vector-ref av (array:actor-index ai 1))
+                (vector-ref av (array:actor-index ai 2))
+                (vector-ref av (array:actor-index ai 3))
+                (vector-ref av (array:actor-index ai 4))
+                (vector-ref av (array:actor-index ai 5))))
+             (lambda (p ai av)
+               (p
+                (vector-ref av (array:actor-index ai 0))
+                (vector-ref av (array:actor-index ai 1))
+                (vector-ref av (array:actor-index ai 2))
+                (vector-ref av (array:actor-index ai 3))
+                (vector-ref av (array:actor-index ai 4))
+                (vector-ref av (array:actor-index ai 5))
+                (vector-ref av (array:actor-index ai 6))))
+             (lambda (p ai av)
+               (p
+                (vector-ref av (array:actor-index ai 0))
+                (vector-ref av (array:actor-index ai 1))
+                (vector-ref av (array:actor-index ai 2))
+                (vector-ref av (array:actor-index ai 3))
+                (vector-ref av (array:actor-index ai 4))
+                (vector-ref av (array:actor-index ai 5))
+                (vector-ref av (array:actor-index ai 6))
+                (vector-ref av (array:actor-index ai 7))))
+             (lambda (p ai av)
+               (p
+                (vector-ref av (array:actor-index ai 0))
+                (vector-ref av (array:actor-index ai 1))
+                (vector-ref av (array:actor-index ai 2))
+                (vector-ref av (array:actor-index ai 3))
+                (vector-ref av (array:actor-index ai 4))
+                (vector-ref av (array:actor-index ai 5))
+                (vector-ref av (array:actor-index ai 6))
+                (vector-ref av (array:actor-index ai 7))
+                (vector-ref av (array:actor-index ai 8))))))
+          (it
+           (lambda (r)
+             (lambda (p ai av)
+               (apply
+                p
+                (vector-ref av (array:actor-index ai 0))
+                (vector-ref av (array:actor-index ai 1))
+                (vector-ref av (array:actor-index ai 2))
+                (vector-ref av (array:actor-index ai 3))
+                (vector-ref av (array:actor-index ai 4))
+                (vector-ref av (array:actor-index ai 5))
+                (vector-ref av (array:actor-index ai 6))
+                (vector-ref av (array:actor-index ai 7))
+                (vector-ref av (array:actor-index ai 8))
+                (vector-ref av (array:actor-index ai 9))
+                (do ((k r (- k 1))
+                     (r
+                      '()
+                      (cons
+                       (vector-ref
+                         av
+                         (array:actor-index ai (- k 1)))
+                       r)))
+                    ((= k 10) r)))))))
+      (lambda (r)
+        "These are low level, exposing implementation at call site."
+        (if (< r 10) (vector-ref em r) (it r)))))
+  (define (array:index/vector r x v)
+    ((array:indexer/vector r) x v))
+  (define (array:index/array r x av ai)
+    ((array:indexer/array r) x av ai))
+  (define (array:apply-to-vector r p v)
+    ((array:applier-to-vector r) p v))
+  (define (array:apply-to-actor r p a)
+    ((array:applier-to-actor r) p a)))
diff --git a/collects/srfi/26.ss b/collects/srfi/26.ss
new file mode 100644
index 0000000000..97d9d7c630
--- /dev/null
+++ b/collects/srfi/26.ss
@@ -0,0 +1,4 @@
+;; module loader for SRFI-26
+(module |26| mzscheme
+  (require (lib "cut.ss" "srfi" "26"))
+  (provide (all-from (lib "cut.ss" "srfi" "26"))))
diff --git a/collects/srfi/26/.cvsignore b/collects/srfi/26/.cvsignore
new file mode 100644
index 0000000000..e3ca6473f7
--- /dev/null
+++ b/collects/srfi/26/.cvsignore
@@ -0,0 +1 @@
+compiled
diff --git a/collects/srfi/26/cut.ss b/collects/srfi/26/cut.ss
new file mode 100644
index 0000000000..1728164377
--- /dev/null
+++ b/collects/srfi/26/cut.ss
@@ -0,0 +1,113 @@
+;;;
+;;; <cut.ss> ---- SRFI 26 port to PLT Scheme: Notation for Specializing Parameters without currying
+;;; Time-stamp: <02/06/20 03:04:59 noel>
+;;;
+;;; Usually, I would add a copyright notice, and the announce that
+;;; this code is under the LGPL licence.  However, I only did the
+;;; port to PLT Scheme, the original comment follows:
+
+; REFERENCE IMPLEMENTATION FOR SRFI-26 "CUT"
+; ==========================================
+;
+; Sebastian.Egner@philips.com, 5-Jun-2002.
+; adapted from the posting by Al Petrofsky <al@petrofsky.org>
+;
+; The code to handle the variable argument case was originally
+; proposed by Michael Sperber and has been adapted to the new
+; syntax of the macro using an explicit rest-slot symbol. The
+; code to evaluate the non-slots for cute has been proposed by
+; Dale Jordan. The code to allow a slot for the procedure position
+; and to process the macro using an internal macro is based on 
+; a suggestion by Al Petrofsky. The code found below is, with
+; exception of this header and some changes in variable names,
+; entirely written by Al Petrofsky.
+;
+; compliance:
+;   Scheme R5RS (including macros).
+;
+; history of this file:
+;   SE,  6-Feb-2002: initial version as 'curry' with ". <>" notation
+;   SE, 14-Feb-2002: revised for <...>
+;   SE, 27-Feb-2002: revised for 'cut'
+;   SE, 03-Jun-2002: revised for proc-slot, cute
+;   SE, 04-Jun-2002: rewritten with internal transformer (no "loop" pattern)
+;   SE, 05-Jun-2002: replace my code by Al's; substituted "constant" etc.
+;     to match the convention in the SRFI-document
+
+; (srfi-26-internal-cut slot-names combination . se)
+;   transformer used internally
+;     slot-names  : the internal names of the slots
+;     combination : procedure being specialized, followed by its arguments
+;     se          : slots-or-exprs, the qualifiers of the macro
+
+; $Id: cut.ss,v 1.1 2003/02/25 01:50:54 solsona Exp $
+
+;;; See: http://srfi.schemers.org for more information on SRFIs.
+
+(module cut mzscheme
+
+  (provide cut cute)
+
+  (define-syntax srfi-26-internal-cut
+	(syntax-rules (<> <...>)
+
+      ;; construct fixed- or variable-arity procedure:
+	  ;;   (begin proc) throws an error if proc is not an <expression>
+	  ((srfi-26-internal-cut (slot-name ...) (proc arg ...))
+	   (lambda (slot-name ...) ((begin proc) arg ...)))
+	  ((srfi-26-internal-cut (slot-name ...) (proc arg ...) <...>)
+	   (lambda (slot-name ... . rest-slot) (apply proc arg ... rest-slot)))
+
+	  ;; process one slot-or-expr
+	  ((srfi-26-internal-cut (slot-name ...)   (position ...)      <>  . se)
+	   (srfi-26-internal-cut (slot-name ... x) (position ... x)        . se))
+	  ((srfi-26-internal-cut (slot-name ...)   (position ...)      nse . se)
+	   (srfi-26-internal-cut (slot-name ...)   (position ... nse)      . se))))
+
+  ; (srfi-26-internal-cute slot-names nse-bindings combination . se)
+  ;   transformer used internally
+  ;     slot-names     : the internal names of the slots
+  ;     nse-bindings   : let-style bindings for the non-slot expressions.
+  ;     combination    : procedure being specialized, followed by its arguments
+  ;     se             : slots-or-exprs, the qualifiers of the macro
+
+  (define-syntax srfi-26-internal-cute
+	(syntax-rules (<> <...>)
+
+      ;; If there are no slot-or-exprs to process, then:
+      ;; construct a fixed-arity procedure,
+      ((srfi-26-internal-cute
+        (slot-name ...) nse-bindings (proc arg ...))
+       (let nse-bindings (lambda (slot-name ...) (proc arg ...))))
+      ;; or a variable-arity procedure
+      ((srfi-26-internal-cute
+		(slot-name ...) nse-bindings (proc arg ...) <...>)
+	   (let nse-bindings (lambda (slot-name ... . x) (apply proc arg ... x))))
+
+	  ;; otherwise, process one slot:
+	  ((srfi-26-internal-cute
+		(slot-name ...)         nse-bindings  (position ...)   <>  . se)
+	   (srfi-26-internal-cute
+		(slot-name ... x)       nse-bindings  (position ... x)     . se))
+	  ;; or one non-slot expression
+	  ((srfi-26-internal-cute
+		slot-names              nse-bindings  (position ...)   nse . se)
+	   (srfi-26-internal-cute
+		slot-names ((x nse) . nse-bindings) (position ... x)       . se))))
+  
+; exported syntax
+
+  (define-syntax cut
+	(syntax-rules ()
+      ((cut . slots-or-exprs)
+	   (srfi-26-internal-cut () () . slots-or-exprs))))
+
+  (define-syntax cute
+	(syntax-rules ()
+      ((cute . slots-or-exprs)
+	   (srfi-26-internal-cute () () () . slots-or-exprs))))
+
+  )
+
+;;; cut.scm ends here
+
diff --git a/collects/srfi/27.ss b/collects/srfi/27.ss
new file mode 100644
index 0000000000..c5797f831c
--- /dev/null
+++ b/collects/srfi/27.ss
@@ -0,0 +1,3 @@
+(module |27| mzscheme
+  (require (lib "random-bits.ss" "srfi" "27"))
+  (provide (all-from (lib "random-bits.ss" "srfi" "27"))))
diff --git a/collects/srfi/27/.cvsignore b/collects/srfi/27/.cvsignore
new file mode 100644
index 0000000000..e3ca6473f7
--- /dev/null
+++ b/collects/srfi/27/.cvsignore
@@ -0,0 +1 @@
+compiled
diff --git a/collects/srfi/27/random-bits-examples.ss b/collects/srfi/27/random-bits-examples.ss
new file mode 100644
index 0000000000..be00b2ff85
--- /dev/null
+++ b/collects/srfi/27/random-bits-examples.ss
@@ -0,0 +1,294 @@
+(module random-bits-examples mzscheme
+  (require (lib "random-bits.ss" "srfi" "27"))
+
+  (define ascii->char integer->char)
+
+; CONFIDENCE TESTS FOR SRFI-27 "Sources of Random Bits"
+; =====================================================
+;
+; Sebastian.Egner@philips.com, 2002.
+;
+; This file contains a small collection of checks for the
+; implementation of SRFI-27. It is not meant to be complete
+; or to test the actual properties of the underlying generator.
+; It is merely meant to run the code and to check some of the
+; assumptions made by specification. There is an interface to
+; G. Marsaglia's DIEHARD battery of tests for random number
+; generators, though.
+;
+; running this file in Scheme 48 0.57 with SRFI-27 installed:
+;
+;   ,open srfi-27 srfi-23 ascii
+;   ,load conftest.scm
+;
+; speed in Scheme 48 0.57 with SRFI-27 opened:
+;
+;   ,time (do ((k 0 (+ k 1))) ((= k 100000)) (random-integer 2))
+;   ; about  30000/s on P3@800MHz for the Scheme-impl.
+;   ; about 160000/s on P3@800MHz for the C/Scheme-impl.
+;
+;   ,time (do ((k 0 (+ k 1))) ((= k 100000)) (random-real))
+;   ; about   3000/s on P3@800MHz for the Scheme-impl.
+;   ; about 180000/s on P3@800MHz for the C/Scheme-impl.
+;
+; speed in PLT 204 with SRFI-27 opened:
+;
+;   (time (do ((k 0 (+ k 1))) ((= k 100000)) (random-integer 2)))
+;   ; about 30000/s on P3@800MHz for the Scheme-impl.
+;
+;   (time (do ((k 0 (+ k 1))) ((= k 100000)) (random-real)))
+;   ; about 50000/s on P3@800MHz for the Scheme-impl.
+;
+; running this file in Gambit 3.0 (interpreter) with SRFI-27 loaded:
+;
+;   (define ascii->char integer->char)
+;   (load "conftest.scm")
+;
+; compiling a simple program in Gambit 3.0 (compiler) using this file:
+;
+;   1. create 'a.scm' with content;
+;     (include "srfi-27-c.scm")
+;     (time (do ((k 0 (+ k 1))) ((= k 1000000)) (random-integer 2)))
+;     (time (do ((k 0 (+ k 1))) ((= k 1000000)) (random-real)))
+;   2. compile Scheme into C (verbose paths for clarity)
+;     GAMBCDIR=$GAMBIT/lib LD_LIBRARY_PATH=$GAMBIT/lib $GAMBIT/gsc/gsc a
+;   3. compile and link C code into an executable
+;     gcc -I$GAMBIT/lib -o a a.c a_.c -lm -lgambc -L$GAMBIT/lib
+;   4. run the executable
+;     GAMBCDIR=$GAMBIT/lib LD_LIBRARY_PATH=$GAMBIT/lib a
+;
+; speed in Gambit 3.0 with SRFI-27 loaded:
+;
+;   (time (do ((k 0 (+ k 1))) ((= k 100000)) (random-integer 2)))
+;   ; about 5000/s on P3@800MHz, interpreted
+;   ; about 200000/s on P3@800MHz, compiled
+;
+;   (time (do ((k 0 (+ k 1))) ((= k 100000)) (random-real)))
+;   ; about 25000/s on P3@800MHz, interpreted
+;   ; about 400000/s on P3@800MHz, compiled
+;
+; history of this file:
+;   SE, 19-Mar-2002: initial version, based on earlier tests
+;   SE, 22-Mar-2002: adapted to new procedure names
+;   SE, 25-Mar-2002: more descriptive output
+;   SE, 04-Apr-2002: some quick timings; check up
+
+
+; (check expr)
+;    evals expr and issues an error if it is not #t.
+
+(define (check expr)
+  (if (not (eq? (eval expr (interaction-environment)) #t))
+      (error "check failed" expr)))
+
+; Basic Tests of the Interface
+; ============================
+
+(define (my-random-integer n)
+  (let ((x (random-integer n)))
+    (if (<= 0 x (- n 1))
+        x
+        (error "(random-integer n) returned illegal value" x))))
+
+(define (my-random-real)
+  (let ((x (random-real)))
+    (if (< 0 x 1)
+        x
+        (error "(random-real) returned illegal value" x))))
+
+(define (check-basics-1)
+
+  ; generate increasingly large numbers
+  (display "; generating large numbers [bits]: ")
+  (do ((k 0 (+ k 1))
+       (n 1 (* n 2)))
+      ((> k 1024))
+    (display k)
+    (display " ")
+    (my-random-integer n))
+  (display "ok")
+  (newline)
+
+  ; generate some reals
+  (display "; generating reals [1000 times]: ")
+  (do ((k 0 (+ k 1))
+       (x (my-random-real) (+ x (my-random-real))))
+      ((= k 1000)
+       x))
+  (display "ok")
+  (newline)
+
+  ; get/set the state
+  (display "; get/set state: ")
+  (let* ((state1 (random-source-state-ref default-random-source))
+         (x1 (my-random-integer (expt 2 32)))
+         (state2 (random-source-state-ref default-random-source))
+         (x2 (my-random-integer (expt 2 32))))
+    (random-source-state-set! default-random-source state1)
+    (let ((y1 (my-random-integer (expt 2 32))))
+      (if (not (= x1 y1))
+          (error "state get/set doesn't work" x1 y1 state1)))
+    (random-source-state-set! default-random-source state2)
+    (let ((y2 (my-random-integer (expt 2 32))))
+      (if (not (= x2 y2))
+          (error "state get/set doesn't work" x2 y2 state2))))
+  (display "ok")
+  (newline)
+
+  ; randomize!
+  (display "; randomize!: ")
+  (let* ((state1 (random-source-state-ref default-random-source))
+         (x1 (my-random-integer (expt 2 32))))
+    (random-source-state-set! default-random-source state1)
+    (random-source-randomize! default-random-source)
+    (let ((y1 (my-random-integer (expt 2 32))))
+      (if (= x1 y1)
+          (error "random-source-randomize! didn't work" x1 state1))))
+  (display "ok")
+  (newline)
+
+  ; pseudo-randomize!
+  (display "; pseudo-randomize!: ")
+  (let* ((state1 (random-source-state-ref default-random-source))
+         (x1 (my-random-integer (expt 2 32))))
+    (random-source-state-set! default-random-source state1)
+    (random-source-pseudo-randomize! default-random-source 0 1)
+    (let ((y1 (my-random-integer (expt 2 32))))
+      (if (= x1 y1)
+          (error "random-source-pseudo-randomize! didn't work" x1 state1)))
+    (random-source-state-set! default-random-source state1)
+    (random-source-pseudo-randomize! default-random-source 1 0)
+    (let ((y1 (my-random-integer (expt 2 32))))
+      (if (= x1 y1)
+          (error "random-source-pseudo-randomize! didn't work" x1 state1))))
+  (display "ok")
+  (newline)
+  (newline))
+
+
+; Testing the MRG32k3a Generator (if implemented)
+; ===============================================
+
+; (check-mrg32k3a)
+;   tests if the underlying generator is the MRG32k3a generator
+;   as implemented in the reference implementation. This function
+;   is useful to check whether the reference implementation computes
+;   the right numbers.
+
+(define (check-mrg32k3a)
+ 
+  ; check if the initial state is A^16 * (1 0 0 1 0 0)
+  (display "; check A^16 * (1 0 0 1 0 0)")
+  (let* ((s (make-random-source))
+         (state1 (random-source-state-ref s))
+	 (rand (random-source-make-reals s)))
+    (random-source-state-set! s '(lecuyer-mrg32k3a 1 0 0 1 0 0))
+    (do ((k 0 (+ k 1)))
+	((= k 16)
+	 (let ((state2 (random-source-state-ref s)))
+	   (if (not (equal? state1 state2))
+	       (error "16-th state after (1 0 0 1 0 0) is wrong"))))
+	(rand)))
+  (display "ok")
+  (newline)
+
+  ; check if pseudo-randomize! advances properly
+  (display "; checking (random-source-pseudo-randomize! s 1 2)")
+  (let ((s (make-random-source)))
+    (random-source-pseudo-randomize! s 1 2)
+    (if (not (equal? (random-source-state-ref s)
+		     '(lecuyer-mrg32k3a 
+		       1250826159 
+		       3004357423 
+		        431373563 
+		       3322526864 
+		        623307378 
+		       2983662421)))
+	(error "pseudo-randomize! gives wrong result")))
+  (display "ok")
+  (newline)
+
+  ; run the check published by Pierre L'Ecuyer:
+  ;   Note that the reference implementation deals slightly different
+  ;   with reals mapping m1-1 into 1-1/(m1+1) and not into 0 as in
+  ;   L'Ecuyer's original proposal. However, for the first 10^7 reals
+  ;   that makes no difference as m1-1 is not generated.
+  (display "; checking (random-source-pseudo-randomize! s 1 2)...")
+  (let* ((x 0.0) 
+	 (s (make-random-source))
+	 (rand (random-source-make-reals s)))
+    (random-source-state-set!
+     s
+     '(lecuyer-mrg32k3a 12345 12345 12345 12345 12345 12345))
+    (do ((k 0 (+ k 1)))
+	((= k 10000000)
+	 (if (not (< (abs (- x 5001090.95)) 0.01))
+	     (error "bad sum over 10^7 reals" x)))
+      (set! x (+ x (rand)))))
+  (display "ok")
+  (newline))
+
+
+; Writing Data to DIEHARD
+; =======================
+
+; (write-diehard filename s bytes-per-call calls)
+;    creates a binary file to which bytes-per-call * calls bytes are
+;    written. The bytes are obtained from the random source s using
+;    the range n = (expt 256 bytes-per-call).
+;       The intention of write-diehard is to give implementors a 
+;    '15 min.'-way of running their favourite random number generator 
+;    through a pretty tough testsuite.
+;
+;    try: For the reference implementation, the call
+;
+;       (write-diehard "outfile" (make-random-source) 4 2867200)
+;
+;    should create a file that looks as follows (od -A x -t x1 outfile):
+;
+;       0000000 92 bb 7e db 1b 14 f6 bb bb 54 a1 55 c2 3e cd ca
+;       0000010 23 01 20 35 06 47 65 b0 52 4c b8 c0 21 48 af 67
+;       0000020 63 a9 8c 78 50 73 29 08 62 d1 22 7f a6 89 96 77
+;       0000030 98 28 65 2d 2d 8b f9 52 41 be 8e 3f c5 84 0f ca
+;       0000040 c0 fa 03 d6 f0 65 9d 3a 9b ab 6f fe d1 aa 5f 92
+;       0000050 0f ea f6 3b 78 b9 fe ad 63 5e 49 f1 9d c9 8e 2f
+;       0000060 53 a9 5d 32 d4 20 51 1d 1c 2e 82 f0 8b 26 40 c0
+;       ...total length is 11468800 bytes.
+;
+;    The message digest is md5sum = 4df554f56cb5ed251bd04b0d50767443.
+;
+;    try: For the reference implementation, the call
+;
+;       (write-diehard "outfile" (make-random-source) 3 3822934)
+;
+;    should create a file that looks as follows (od -A x -t x1 outfile):
+;
+;       000000 bb 7e db 30 a3 49 14 f6 bb d0 f2 d0 54 a1 55 8b
+;       000010 8c 03 3e cd ca a3 88 1d 01 20 35 e8 50 c8 47 65
+;       000020 b0 e7 d9 28 4c b8 c0 f2 82 35 48 af 67 42 3e 8a
+;       000030 a9 8c 78 12 ef b6 73 29 08 ff e9 71 d1 22 7f 52
+;       000040 b8 f0 89 96 77 dc 71 86 28 65 2d c2 82 fc 8b f9
+;       000050 52 d7 23 2a be 8e 3f 61 a8 99 84 0f ca 44 83 65
+;       000060 fa 03 d6 c2 11 c0 65 9d 3a c2 7a dd ab 6f fe 1c
+;       ...total length is 11468802 bytes.
+;
+;    The message digest is md5sum = 750ac219ff40c50bb2d04ff5eff9b24c.
+
+(define (write-diehard filename s bytes-per-call calls)
+  (let ((port (open-output-file filename))
+	(rand (random-source-make-integers s))
+        (n (expt 256 bytes-per-call)))
+    (do ((i 0 (+ i 1))) 
+        ((= i calls) 
+         (close-output-port port))
+      (let ((x (rand n)))
+        (do ((k 0 (+ k 1))) ((= k bytes-per-call))
+          (write-char (ascii->char (modulo x 256)) port)
+          (set! x (quotient x 256)))))))
+         
+; run some tests
+(check-basics-1)
+(display "passed (check-basics-1)")
+(newline)
+
+) ; end module
\ No newline at end of file
diff --git a/collects/srfi/27/random-bits.ss b/collects/srfi/27/random-bits.ss
new file mode 100644
index 0000000000..ff0c473298
--- /dev/null
+++ b/collects/srfi/27/random-bits.ss
@@ -0,0 +1,598 @@
+; MODULE DEFINITION FOR SRFI-27
+; =============================
+; 
+; Sebastian.Egner@philips.com, Mar-2002, in PLT 204
+;
+; This file contains the top-level definition for the 54-bit integer-only
+; implementation of SRFI 27 for the PLT 204 DrScheme system. 
+;
+; 1. The core generator is implemented in 'mrg32k3a-a.scm'.
+; 2. The generic parts of the interface are in 'mrg32k3a.scm'.
+; 3. The non-generic parts (record type, time, error) are here.
+;
+; load the module with
+;   (require (lib "random-bits.ss" "srfi"))
+;
+; history of this file:
+;   SE, 17-May-2003: initial version
+
+(module random-bits mzscheme
+  (require (lib "9.ss" "srfi"))
+  (require (lib "23.ss" "srfi"))
+
+  (provide 
+   random-integer random-real default-random-source
+   make-random-source random-source? random-source-state-ref
+   random-source-state-set! random-source-randomize!
+   random-source-pseudo-randomize!
+   random-source-make-integers random-source-make-reals)
+
+  (define-record-type :random-source
+    (:random-source-make
+     state-ref
+     state-set!
+     randomize!
+     pseudo-randomize!
+     make-integers
+     make-reals)
+     :random-source?
+    (state-ref :random-source-state-ref)
+    (state-set! :random-source-state-set!)
+    (randomize! :random-source-randomize!)
+    (pseudo-randomize! :random-source-pseudo-randomize!)
+    (make-integers :random-source-make-integers)
+    (make-reals :random-source-make-reals))
+  
+  (define :random-source-current-time 
+    current-milliseconds)
+
+; implementation begins here
+
+; 54-BIT INTEGER IMPLEMENTATION OF THE "MRG32K3A"-GENERATOR
+; =========================================================
+;
+; Sebastian.Egner@philips.com, Mar-2002.
+;
+; This file is an implementation of Pierre L'Ecuyer's MRG32k3a
+; pseudo random number generator. Please refer to 'mrg32k3a.scm'
+; for more information.
+;
+; compliance:
+;   Scheme R5RS with integers covering at least {-2^53..2^53-1}.
+;
+; history of this file:
+;   SE, 18-Mar-2002: initial version
+;   SE, 22-Mar-2002: comments adjusted, range added
+;   SE, 25-Mar-2002: pack/unpack just return their argument
+
+; the actual generator
+
+(define (mrg32k3a-random-m1 state)
+  (let ((x11 (vector-ref state 0))
+	(x12 (vector-ref state 1))
+	(x13 (vector-ref state 2))
+	(x21 (vector-ref state 3))
+	(x22 (vector-ref state 4))
+	(x23 (vector-ref state 5)))
+    (let ((x10 (modulo (- (* 1403580 x12) (* 810728 x13)) 4294967087))
+	  (x20 (modulo (- (* 527612 x21) (* 1370589 x23)) 4294944443)))
+      (vector-set! state 0 x10)
+      (vector-set! state 1 x11)
+      (vector-set! state 2 x12)
+      (vector-set! state 3 x20)
+      (vector-set! state 4 x21)
+      (vector-set! state 5 x22)
+      (modulo (- x10 x20) 4294967087))))
+
+; interface to the generic parts of the generator
+
+(define (mrg32k3a-pack-state unpacked-state)
+  unpacked-state)
+
+(define (mrg32k3a-unpack-state state)
+  state)
+
+(define (mrg32k3a-random-range) ; m1
+  4294967087)
+
+(define (mrg32k3a-random-integer state range) ; rejection method
+  (let* ((q (quotient 4294967087 range))
+	 (qn (* q range)))
+    (do ((x (mrg32k3a-random-m1 state) (mrg32k3a-random-m1 state)))
+	((< x qn) (quotient x q)))))
+
+(define (mrg32k3a-random-real state) ; normalization is 1/(m1+1)
+  (* 0.0000000002328306549295728 (+ 1.0 (mrg32k3a-random-m1 state))))
+
+
+; GENERIC PART OF MRG32k3a-GENERATOR FOR SRFI-27
+; ==============================================
+;
+; Sebastian.Egner@philips.com, 2002.
+;
+; This is the generic R5RS-part of the implementation of the MRG32k3a
+; generator to be used in SRFI-27. It is based on a separate implementation
+; of the core generator (presumably in native code) and on code to
+; provide essential functionality not available in R5RS (see below).
+;
+; compliance:
+;   Scheme R5RS with integer covering at least {-2^53..2^53-1}.
+;   In addition,
+;     SRFI-23: error
+;
+; history of this file:
+;   SE, 22-Mar-2002: refactored from earlier versions
+;   SE, 25-Mar-2002: pack/unpack need not allocate
+;   SE, 27-Mar-2002: changed interface to core generator
+;   SE, 10-Apr-2002: updated spec of mrg32k3a-random-integer
+
+; Generator
+; =========
+;
+; Pierre L'Ecuyer's MRG32k3a generator is a Combined Multiple Recursive 
+; Generator. It produces the sequence {(x[1,n] - x[2,n]) mod m1 : n} 
+; defined by the two recursive generators
+;
+;   x[1,n] = (               a12 x[1,n-2] + a13 x[1,n-3]) mod m1,
+;   x[2,n] = (a21 x[2,n-1] +                a23 x[2,n-3]) mod m2,
+;
+; where the constants are
+;   m1       = 4294967087 = 2^32 - 209    modulus of 1st component
+;   m2       = 4294944443 = 2^32 - 22853  modulus of 2nd component
+;   a12      =  1403580                   recursion coefficients
+;   a13      =  -810728
+;   a21      =   527612
+;   a23      = -1370589
+;
+; The generator passes all tests of G. Marsaglia's Diehard testsuite.
+; Its period is (m1^3 - 1)(m2^3 - 1)/2 which is nearly 2^191.
+; L'Ecuyer reports: "This generator is well-behaved in all dimensions
+; up to at least 45: ..." [with respect to the spectral test, SE].
+;
+; The period is maximal for all values of the seed as long as the
+; state of both recursive generators is not entirely zero.
+;
+; As the successor state is a linear combination of previous
+; states, it is possible to advance the generator by more than one
+; iteration by applying a linear transformation. The following
+; publication provides detailed information on how to do that:
+;
+;    [1] P. L'Ecuyer, R. Simard, E. J. Chen, W. D. Kelton:
+;        An Object-Oriented Random-Number Package With Many Long 
+;        Streams and Substreams. 2001.
+;        To appear in Operations Research.
+;
+; Arithmetics
+; ===========
+;
+; The MRG32k3a generator produces values in {0..2^32-209-1}. All 
+; subexpressions of the actual generator fit into {-2^53..2^53-1}. 
+; The code below assumes that Scheme's "integer" covers this range.
+; In addition, it is assumed that floating point literals can be
+; read and there is some arithmetics with inexact numbers.
+;
+; However, for advancing the state of the generator by more than
+; one step at a time, the full range {0..2^32-209-1} is needed.
+
+
+; Required: Backbone Generator
+; ============================
+;
+; At this point in the code, the following procedures are assumed
+; to be defined to execute the core generator:
+;
+;   (mrg32k3a-pack-state unpacked-state) -> packed-state
+;   (mrg32k3a-unpack-state packed-state) -> unpacked-state
+;      pack/unpack a state of the generator. The core generator works
+;      on packed states, passed as an explicit argument, only. This
+;      allows native code implementations to store their state in a
+;      suitable form. Unpacked states are #(x10 x11 x12 x20 x21 x22) 
+;      with integer x_ij. Pack/unpack need not allocate new objects
+;      in case packed and unpacked states are identical.
+;
+;   (mrg32k3a-random-range) -> m-max
+;   (mrg32k3a-random-integer packed-state range) -> x in {0..range-1}
+;      advance the state of the generator and return the next random
+;      range-limited integer. 
+;        Note that the state is not necessarily advanced by just one 
+;      step because we use the rejection method to avoid any problems 
+;      with distribution anomalies.
+;        The range argument must be an exact integer in {1..m-max}.
+;      It can be assumed that range is a fixnum if the Scheme system
+;      has such a number representation.
+;
+;   (mrg32k3a-random-real packed-state) -> x in (0,1)
+;      advance the state of the generator and return the next random
+;      real number between zero and one (both excluded). The type of
+;      the result should be a flonum if possible.
+
+; Required: Record Data Type
+; ==========================
+;
+; At this point in the code, the following procedures are assumed
+; to be defined to create and access a new record data type:
+;
+;   (:random-source-make a0 a1 a2 a3 a4 a5) -> s
+;     constructs a new random source object s consisting of the 
+;     objects a0 .. a5 in this order.
+;
+;   (:random-source? obj) -> bool
+;     tests if a Scheme object is a :random-source.
+;
+;   (:random-source-state-ref         s) -> a0
+;   (:random-source-state-set!        s) -> a1
+;   (:random-source-randomize!        s) -> a2
+;   (:random-source-pseudo-randomize! s) -> a3
+;   (:random-source-make-integers     s) -> a4
+;   (:random-source-make-reals        s) -> a5
+;     retrieve the values in the fields of the object s.
+
+; Required: Current Time as an Integer
+; ====================================
+;
+; At this point in the code, the following procedure is assumed
+; to be defined to obtain a value that is likely to be different
+; for each invokation of the Scheme system:
+;
+;   (:random-source-current-time) -> x
+;     an integer that depends on the system clock. It is desired
+;     that the integer changes as fast as possible.
+
+
+; Accessing the State
+; ===================
+
+(define (mrg32k3a-state-ref packed-state)
+  (cons 'lecuyer-mrg32k3a 
+        (vector->list (mrg32k3a-unpack-state packed-state))))
+
+(define (mrg32k3a-state-set external-state)
+
+  (define (check-value x m)
+    (if (and (integer? x)
+             (exact? x)
+             (<= 0 x (- m 1)))
+        #t
+        (error "illegal value" x)))
+
+  (if (and (list? external-state)
+           (= (length external-state) 7)
+           (eq? (car external-state) 'lecuyer-mrg32k3a))
+      (let ((s (cdr external-state)))
+        (check-value (list-ref s 0) mrg32k3a-m1)
+        (check-value (list-ref s 1) mrg32k3a-m1)
+        (check-value (list-ref s 2) mrg32k3a-m1)
+        (check-value (list-ref s 3) mrg32k3a-m2)
+        (check-value (list-ref s 4) mrg32k3a-m2)
+        (check-value (list-ref s 5) mrg32k3a-m2)
+        (if (or (zero? (+ (list-ref s 0) (list-ref s 1) (list-ref s 2)))
+                (zero? (+ (list-ref s 3) (list-ref s 4) (list-ref s 5))))
+            (error "illegal degenerate state" external-state))
+        (mrg32k3a-pack-state (list->vector s)))
+      (error "malformed state" external-state)))
+
+
+; Pseudo-Randomization
+; ====================
+;
+; Reference [1] above shows how to obtain many long streams and 
+; substream from the backbone generator.
+;
+; The idea is that the generator is a linear operation on the state.
+; Hence, we can express this operation as a 3x3-matrix acting on the
+; three most recent states. Raising the matrix to the k-th power, we
+; obtain the operation to advance the state by k steps at once. The
+; virtual streams and substreams are now simply parts of the entire
+; periodic sequence (which has period around 2^191).
+;
+; For the implementation it is necessary to compute with matrices in
+; the ring (Z/(m1*m1)*Z)^(3x3). By the Chinese-Remainder Theorem, this
+; is isomorphic to ((Z/m1*Z) x (Z/m2*Z))^(3x3). We represent such a pair
+; of matrices 
+;   [ [[x00 x01 x02],
+;      [x10 x11 x12],
+;      [x20 x21 x22]], mod m1
+;     [[y00 y01 y02],
+;      [y10 y11 y12],
+;      [y20 y21 y22]]  mod m2]
+; as a vector of length 18 of the integers as writen above:
+;   #(x00 x01 x02 x10 x11 x12 x20 x21 x22
+;     y00 y01 y02 y10 y11 y12 y20 y21 y22)
+;
+; As the implementation should only use the range {-2^53..2^53-1}, the
+; fundamental operation (x*y) mod m, where x, y, m are nearly 2^32, 
+; is computed by breaking up x and y as x = x1*w + x0 and y = y1*w + y0 
+; where w = 2^16. In this case, all operations fit the range because 
+; w^2 mod m is a small number. If proper multiprecision integers are
+; available this is not necessary, but pseudo-randomize! is an expected
+; to be called only occasionally so we do not provide this implementation.
+
+(define mrg32k3a-m1 4294967087) ; modulus of component 1
+(define mrg32k3a-m2 4294944443) ; modulus of component 2
+
+(define mrg32k3a-initial-state ; 0 3 6 9 12 15 of A^16, see below
+  '#( 1062452522
+      2961816100 
+       342112271 
+      2854655037 
+      3321940838 
+      3542344109))
+
+(define mrg32k3a-generators #f) ; computed when needed
+
+(define (mrg32k3a-pseudo-randomize-state i j)
+
+  (define (product A B) ; A*B in ((Z/m1*Z) x (Z/m2*Z))^(3x3)
+
+    (define w      65536) ; wordsize to split {0..2^32-1}
+    (define w-sqr1 209)   ; w^2 mod m1
+    (define w-sqr2 22853) ; w^2 mod m2
+
+    (define (lc i0 i1 i2 j0 j1 j2 m w-sqr) ; linear combination
+      (let ((a0h (quotient (vector-ref A i0) w))
+            (a0l (modulo   (vector-ref A i0) w))
+            (a1h (quotient (vector-ref A i1) w))
+            (a1l (modulo   (vector-ref A i1) w))
+            (a2h (quotient (vector-ref A i2) w))
+            (a2l (modulo   (vector-ref A i2) w))
+            (b0h (quotient (vector-ref B j0) w))
+            (b0l (modulo   (vector-ref B j0) w))
+            (b1h (quotient (vector-ref B j1) w))
+            (b1l (modulo   (vector-ref B j1) w))
+            (b2h (quotient (vector-ref B j2) w))
+            (b2l (modulo   (vector-ref B j2) w)))
+        (modulo
+         (+ (* (+ (* a0h b0h) 
+                  (* a1h b1h) 
+                  (* a2h b2h)) 
+               w-sqr)
+            (* (+ (* a0h b0l) 
+                  (* a0l b0h)
+                  (* a1h b1l) 
+                  (* a1l b1h)
+                  (* a2h b2l) 
+                  (* a2l b2h))
+               w)
+            (* a0l b0l)
+            (* a1l b1l)
+            (* a2l b2l))
+         m)))
+    
+    (vector
+     (lc  0  1  2   0  3  6  mrg32k3a-m1 w-sqr1) ; (A*B)_00 mod m1
+     (lc  0  1  2   1  4  7  mrg32k3a-m1 w-sqr1) ; (A*B)_01
+     (lc  0  1  2   2  5  8  mrg32k3a-m1 w-sqr1)
+     (lc  3  4  5   0  3  6  mrg32k3a-m1 w-sqr1) ; (A*B)_10
+     (lc  3  4  5   1  4  7  mrg32k3a-m1 w-sqr1)
+     (lc  3  4  5   2  5  8  mrg32k3a-m1 w-sqr1)
+     (lc  6  7  8   0  3  6  mrg32k3a-m1 w-sqr1)
+     (lc  6  7  8   1  4  7  mrg32k3a-m1 w-sqr1)
+     (lc  6  7  8   2  5  8  mrg32k3a-m1 w-sqr1)
+     (lc  9 10 11   9 12 15  mrg32k3a-m2 w-sqr2) ; (A*B)_00 mod m2
+     (lc  9 10 11  10 13 16  mrg32k3a-m2 w-sqr2)
+     (lc  9 10 11  11 14 17  mrg32k3a-m2 w-sqr2)
+     (lc 12 13 14   9 12 15  mrg32k3a-m2 w-sqr2)
+     (lc 12 13 14  10 13 16  mrg32k3a-m2 w-sqr2)
+     (lc 12 13 14  11 14 17  mrg32k3a-m2 w-sqr2)
+     (lc 15 16 17   9 12 15  mrg32k3a-m2 w-sqr2)
+     (lc 15 16 17  10 13 16  mrg32k3a-m2 w-sqr2)
+     (lc 15 16 17  11 14 17  mrg32k3a-m2 w-sqr2)))
+
+  (define (power A e) ; A^e
+    (cond
+     ((zero? e)
+      '#(1 0 0 0 1 0 0 0 1 1 0 0 0 1 0 0 0 1))
+     ((= e 1)
+      A)
+     ((even? e)
+      (power (product A A) (quotient e 2)))
+     (else
+      (product (power A (- e 1)) A))))
+
+  (define (power-power A b) ; A^(2^b)
+    (if (zero? b)
+        A
+        (power-power (product A A) (- b 1))))
+
+  (define A                        ; the MRG32k3a recursion
+    '#(     0 1403580 4294156359
+            1       0          0
+            0       1          0
+       527612       0 4293573854
+            1       0          0
+            0       1          0))
+
+  ; check arguments
+  (if (not (and (integer? i) 
+                (exact? i)
+                (integer? j)
+                (exact? j)))
+      (error "i j must be exact integer" i j))
+
+  ; precompute A^(2^127) and A^(2^76) only once
+
+  (if (not mrg32k3a-generators)
+      (set! mrg32k3a-generators
+            (list (power-power A 127)
+                  (power-power A  76)
+                  (power A 16))))
+
+  ; compute M = A^(16 + i*2^127 + j*2^76)
+  (let ((M (product 
+            (list-ref mrg32k3a-generators 2)
+            (product
+             (power (list-ref mrg32k3a-generators 0)
+                    (modulo i (expt 2 28)))
+             (power (list-ref mrg32k3a-generators 1) 
+                    (modulo j (expt 2 28)))))))
+    (mrg32k3a-pack-state
+     (vector
+      (vector-ref M 0)
+      (vector-ref M 3)
+      (vector-ref M 6)
+      (vector-ref M 9)
+      (vector-ref M 12)
+      (vector-ref M 15)))))
+
+; True Randomization
+; ==================
+;
+; The value obtained from the system time is feed into a very
+; simple pseudo random number generator. This in turn is used
+; to obtain numbers to randomize the state of the MRG32k3a
+; generator, avoiding period degeneration.
+
+(define (mrg32k3a-randomize-state state)
+
+  ; G. Marsaglia's simple 16-bit generator with carry
+  (define m 65536)
+  (define x (modulo (:random-source-current-time) m))
+  (define (random-m)
+    (let ((y (modulo x m)))
+      (set! x (+ (* 30903 y) (quotient x m)))
+      y))
+  (define (random n) ; m < n < m^2
+    (modulo (+ (* (random-m) m) (random-m)) n))
+
+  ; modify the state
+  (let ((m1 mrg32k3a-m1)
+        (m2 mrg32k3a-m2)
+        (s (mrg32k3a-unpack-state state)))
+    (mrg32k3a-pack-state
+     (vector
+      (+ 1 (modulo (+ (vector-ref s 0) (random (- m1 1))) (- m1 1)))
+      (modulo (+ (vector-ref s 1) (random m1)) m1)
+      (modulo (+ (vector-ref s 2) (random m1)) m1)
+      (+ 1 (modulo (+ (vector-ref s 3) (random (- m2 1))) (- m2 1)))
+      (modulo (+ (vector-ref s 4) (random m2)) m2)
+      (modulo (+ (vector-ref s 5) (random m2)) m2)))))
+
+
+; Large Integers
+; ==============
+;
+; To produce large integer random deviates, for n > m-max, we first 
+; construct large random numbers in the range {0..m-max^k-1} for some 
+; k such that m-max^k >= n and then use the rejection method to choose
+; uniformly from the range {0..n-1}.
+
+(define mrg32k3a-m-max
+  (mrg32k3a-random-range))
+
+(define (mrg32k3a-random-power state k) ; n = m-max^k, k >= 1
+  (if (= k 1)
+      (mrg32k3a-random-integer state mrg32k3a-m-max)
+      (+ (* (mrg32k3a-random-power state (- k 1)) mrg32k3a-m-max)
+         (mrg32k3a-random-integer state mrg32k3a-m-max))))
+
+(define (mrg32k3a-random-large state n) ; n > m-max
+  (do ((k 2 (+ k 1))
+       (mk (* mrg32k3a-m-max mrg32k3a-m-max) (* mk mrg32k3a-m-max)))
+      ((>= mk n)
+       (let* ((mk-by-n (quotient mk n))
+              (a (* mk-by-n n)))
+         (do ((x (mrg32k3a-random-power state k)
+                 (mrg32k3a-random-power state k)))
+             ((< x a) (quotient x mk-by-n)))))))
+
+
+; Multiple Precision Reals
+; ========================
+;
+; To produce multiple precision reals we produce a large integer value
+; and convert it into a real value. This value is then normalized.
+; The precision goal is unit <= 1/(m^k + 1), or 1/unit - 1 <= m^k.
+; If you know more about the floating point number types of the
+; Scheme system, this can be improved.
+
+(define (mrg32k3a-random-real-mp state unit)
+  (do ((k 1 (+ k 1))
+       (u (- (/ 1 unit) 1) (/ u mrg32k3a-m1)))
+      ((<= u 1)
+       (/ (exact->inexact (+ (mrg32k3a-random-power state k) 1))
+          (exact->inexact (+ (expt mrg32k3a-m-max k) 1))))))
+
+
+; Provide the Interface as Specified in the SRFI
+; ==============================================
+;
+; An object of type random-source is a record containing the procedures
+; as components. The actual state of the generator is stored in the
+; binding-time environment of make-random-source.
+
+(define (make-random-source)
+  (let ((state (mrg32k3a-pack-state ; make a new copy
+                (list->vector (vector->list mrg32k3a-initial-state)))))
+    (:random-source-make
+     (lambda ()
+       (mrg32k3a-state-ref state))
+     (lambda (new-state)
+       (set! state (mrg32k3a-state-set new-state)))
+     (lambda ()
+       (set! state (mrg32k3a-randomize-state state)))
+     (lambda (i j)
+       (set! state (mrg32k3a-pseudo-randomize-state i j)))
+     (lambda ()
+       (lambda (n)
+         (cond
+          ((not (and (integer? n) (exact? n) (positive? n)))
+           (error "range must be exact positive integer" n))           
+          ((<= n mrg32k3a-m-max)
+           (mrg32k3a-random-integer state n))
+          (else
+           (mrg32k3a-random-large state n)))))
+     (lambda args
+       (cond
+        ((null? args)
+         (lambda () 
+           (mrg32k3a-random-real state)))
+        ((null? (cdr args))
+         (let ((unit (car args)))
+           (cond
+            ((not (and (real? unit) (< 0 unit 1)))
+             (error "unit must be real in (0,1)" unit))
+            ((<= (- (/ 1 unit) 1) mrg32k3a-m1)
+             (lambda () 
+               (mrg32k3a-random-real state)))
+            (else
+             (lambda () 
+               (mrg32k3a-random-real-mp state unit))))))
+        (else
+         (error "illegal arguments" args)))))))
+
+(define random-source? 
+  :random-source?)
+
+(define (random-source-state-ref s)
+  ((:random-source-state-ref s)))
+
+(define (random-source-state-set! s state)
+  ((:random-source-state-set! s) state))
+
+(define (random-source-randomize! s)
+  ((:random-source-randomize! s)))
+
+(define (random-source-pseudo-randomize! s i j)
+  ((:random-source-pseudo-randomize! s) i j))
+
+; ---
+
+(define (random-source-make-integers s)
+  ((:random-source-make-integers s)))
+
+(define (random-source-make-reals s . unit)
+  (apply (:random-source-make-reals s) unit))
+
+; ---
+
+(define default-random-source 
+  (make-random-source))
+
+(define random-integer
+  (random-source-make-integers default-random-source))
+
+(define random-real
+  (random-source-make-reals default-random-source))
+
+
+) ; module ends
diff --git a/collects/srfi/28.ss b/collects/srfi/28.ss
new file mode 100644
index 0000000000..49a4bee8a4
--- /dev/null
+++ b/collects/srfi/28.ss
@@ -0,0 +1,3 @@
+;; Supported by core PLT:
+(module |28| mzscheme
+  (provide format))
\ No newline at end of file
diff --git a/collects/srfi/29.ss b/collects/srfi/29.ss
new file mode 100644
index 0000000000..e9443f42a8
--- /dev/null
+++ b/collects/srfi/29.ss
@@ -0,0 +1,4 @@
+;; module loader for SRFI-29
+(module |29| mzscheme
+  (require (lib "localization.ss" "srfi" "29"))
+  (provide (all-from (lib "localization.ss" "srfi" "29"))))
diff --git a/collects/srfi/29/.cvsignore b/collects/srfi/29/.cvsignore
new file mode 100644
index 0000000000..e3ca6473f7
--- /dev/null
+++ b/collects/srfi/29/.cvsignore
@@ -0,0 +1 @@
+compiled
diff --git a/collects/srfi/29/bundles/es/srfi-19 b/collects/srfi/29/bundles/es/srfi-19
new file mode 100644
index 0000000000..92a556fd2e
--- /dev/null
+++ b/collects/srfi/29/bundles/es/srfi-19
@@ -0,0 +1,29 @@
+;; -*- scheme -*-
+( ;; weekday abbreviations
+ (sun . "dom") (mon . "lun") (tue . "mar") (wed . "mié")
+ (thu . "jue") (fri . "vie") (sat . "sáb")
+
+ ;; long weekdays
+ (sunday . "domingo") (monday . "lunes") (tuesday . "martes")
+ (wednesday . "miércoles") (thursday . "jueves") (friday . "viernes")
+ (saturday . "sábado")
+
+ ;; month abbrevs
+ (jan . "ene") (feb . "feb") (mar . "mar") (apr . "abr")
+ (may . "may") (jun . "jun") (jul . "jul") (aug . "ago")
+ (sep . "sep") (oct . "oct") (nov . "nov") (dec . "dic")
+
+ ;; long month
+ (january . "Enero") (february . "Febrero") (march . "Marzo") (april . "Abril")
+ (may . "Mayo") (june . "Junio") (july . "Julio") (august . "Agosto")
+ (septembre . "Septiembre") (octuber . "Octubre") (november . "Noviembre") (december . "Deciembre")
+
+ (pm . "PM") (am . "AM")
+
+ (date-time . "~a ~d ~b ~H:~M:~S~z ~Y")
+ (date . "~d/~m/~y")
+ (time . "~H:~M:~S")
+ (iso8601 . "~Y-~m-~dT~H:~M:~S~z")
+ (separator . ".")
+ 
+)
\ No newline at end of file
diff --git a/collects/srfi/29/bundles/srfi-19 b/collects/srfi/29/bundles/srfi-19
new file mode 100644
index 0000000000..ac96044702
--- /dev/null
+++ b/collects/srfi/29/bundles/srfi-19
@@ -0,0 +1,30 @@
+;; -*- scheme -*-
+( ;; weekday abbreviations
+ (sun . "Sun") (mon . "Mon") (tue . "Tue") (wed . "Wed")
+ (thu . "Thu") (fri . "Fri") (sat . "Sat")
+
+ ;; long weekdays
+ (sunday . "Sunday") (monday . "Monday") (tuesday . "Tuesday")
+ (wednesday . "Wednesday") (thursday . "Thursday") (friday . "Friday")
+ (saturday . "Saturday")
+
+ ;; month abbrevs
+ (jan . "Jan") (feb . "Feb") (mar . "Mar") (apr . "Apr")
+ (may . "May") (jun . "Jun") (jul . "Jul") (aug . "Aug")
+ (sep . "Sep") (oct . "Oct") (nov . "Nov") (dec . "Dec")
+
+ ;; long month
+ (january . "January") (february . "February") (march . "March") (april . "April")
+ (may . "May") (june . "June") (july . "July") (august . "August")
+ (septembre . "September") (octuber . "Octuber") (november . "November") (december . "December")
+
+ (pm . "PM") (am . "AM")
+
+ (date-time . "~a ~b ~d ~H:~M:~S~z ~Y")
+ (date . "~m/~d/~y")
+ (time . "~H:~M:~S")
+ (iso8601 . "~Y-~m-~dT~H:~M:~S~z")
+ (separator . ".")
+ 
+ 
+ )
\ No newline at end of file
diff --git a/collects/srfi/29/localization.ss b/collects/srfi/29/localization.ss
new file mode 100644
index 0000000000..defb44362d
--- /dev/null
+++ b/collects/srfi/29/localization.ss
@@ -0,0 +1,207 @@
+;;; <localization.ss> SRFI-29: localization port to PLT Scheme -*- Scheme -*-
+;;; Time-stamp: <03/05/08 12:49:08 solsona>
+;;;
+;;; Copyright (C) Scott G. Miller (2002). All Rights Reserved.
+;;;
+;;; This file is part of PLT Scheme.
+
+;;; PLT Scheme is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2.1 of the License, or (at your option) any later version.
+
+;;; PLT Scheme is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with PLT Scheme; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+;;; Author: Scott G. Miller
+;;; Modified for PLT Scheme by: Francisco Solsona <solsona@acm.org>
+
+(module localization mzscheme
+  (require (lib "etc.ss"))
+  (provide current-language current-country current-locale-details
+	   load-bundle! store-bundle! declare-bundle!
+	   localized-template
+	   ;; NOT in SRFI-29, but useful in PLT when using/changing current-locale:
+	   re-read-locale
+	   )
+
+
+  (define get-from-locale
+    (lambda (what)
+      (let ((locale (current-locale)))
+	(if (string=? locale "")
+	    (case what
+	      ((language) 'en) ;; Default language: English
+	      ((country) 'us) ;; Default country: US
+	      (else null))
+	    (let ((len (string-length locale)))
+	      (case what
+		((language)
+		 (if (>= len 2)
+		     (string->symbol (substring locale 0 2))
+		     'en))
+		((country)
+		 (if (>= len 5)
+		     (string->symbol (substring locale 3 5))
+		     'us))
+		(else ;; details
+		 (if (> len 6)
+		     (list (string->symbol (substring locale 6)))
+		     null))))))))
+
+  
+  (define list-of
+    (lambda (pred)
+      (lambda (lst)
+	(call/cc (lambda (exit)
+		   (let loop ((lst lst))
+		     (cond ((null? lst) #t)
+			   (else (or (pred (car lst))
+				     (exit #f))
+				 (loop (cdr lst))))))))))
+
+
+  ;; The association list in which bundles will be stored
+  (define *localization-bundles* '())
+
+  (define current-language
+    (make-parameter (get-from-locale 'language) (lambda (l)
+						  (if (symbol? l) l 'en))))
+
+  (define current-country
+    (make-parameter (get-from-locale 'country) (lambda (l)
+						 (if (symbol? l) l 'us))))
+  
+  (define current-locale-details
+    (make-parameter (get-from-locale 'details) (lambda (lst)
+						 (if ((list-of symbol?) lst)
+						     lst
+						     null))))
+
+  ;; If you change (current-locale), you don't have to set current-*
+  ;; by hand, you can simply call this procedure, and it will update
+  ;; those parameters to the values in the new locale.
+  (define re-read-locale
+    (lambda ()
+      (current-language (get-from-locale 'language))
+      (current-country (get-from-locale 'country))
+      (current-locale-details (get-from-locale 'details))))
+  
+  ;; System bundles are here:
+  (define system-bundles (build-path
+			  (collection-path "srfi") "29" "bundles"))
+
+  ;; bundle-specifier: (listof symbol)
+  ;; i.e. package + locale, (package-name [language] [country] [details ...])
+  (define load-bundle!
+    (opt-lambda (bundle-specifier [alternate-path null])
+      (let* ((filename (case (length bundle-specifier)
+			 ((1) (symbol->string (car bundle-specifier)))
+			 ((2) (build-path (symbol->string (cadr bundle-specifier))
+					  (symbol->string (car bundle-specifier))))
+			 (else (build-path (symbol->string (cadr bundle-specifier))
+					   (symbol->string (caddr bundle-specifier))
+					   (symbol->string (car bundle-specifier))))))
+	     (path (build-path (if (null? alternate-path)
+				   system-bundles
+				   alternate-path)
+			       filename)))
+	(and (file-exists? path)
+	     ;; Found!
+	     (declare-bundle! bundle-specifier
+			      (with-input-from-file path read))))))
+
+  (define extract-assoc-list
+    (lambda (bundle-specifier)
+      (let loop ((bundle *localization-bundles*))
+	(cond ((null? bundle) #f)
+	      ((equal? (caar bundle) bundle-specifier)
+	       (cdar bundle))
+	      (else (extract-assoc-list (cdr bundle)))))))
+  
+  (define store-bundle!
+    (opt-lambda (bundle-specifier [alternate-path null])
+      (let* ((sub-path (if (null? alternate-path) system-bundles alternate-path))
+	     (file (case (length bundle-specifier)
+		     ((1) (symbol->string (car bundle-specifier)))
+		     ((2)
+		      (let* ((dir (build-path sub-path (symbol->string (cadr bundle-specifier))))
+			     (file (build-path dir (symbol->string (car bundle-specifier)))))
+			(unless (directory-exists? dir)
+			  (make-directory dir))
+			file))
+		     (else
+		      (let* ((dir (build-path sub-path (symbol->string (cadr bundle-specifier))))
+			     (dir2 (build-path dir (symbol->string (caddr bundle-specifier))))
+			     (file (build-path dir2 (symbol->string (car bundle-specifier)))))
+			(unless (directory-exists? dir)
+			  (make-directory dir))
+			(unless (directory-exists? dir2)
+			  (make-directory dir2))
+			file))))
+	     (bundle-assoc-list (extract-assoc-list bundle-specifier)))
+
+	(and bundle-assoc-list
+	     ;; Storing bundle!
+	     (if (file-exists? file)
+		 (if (memq 'write (file-or-directory-permissions file))
+		     ;; Replacing the existing bundle
+		     (with-output-to-file file (lambda ()
+						 (write bundle-assoc-list))
+					  'truncate/replace)
+		     #f);; should be an exception?
+		 (if (let-values ([(base filename directory?)  (split-path file)])
+				 (memq 'write (file-or-directory-permissions base)))
+		     ;; First time, this bundle is stored here:
+		     (with-output-to-file file (lambda ()
+						 (write bundle-assoc-list)))
+		     #f))))))
+
+  ;; Declare a bundle of templates with a given bundle specifier
+  (define declare-bundle!
+    (letrec ((remove-old-bundle
+	      (lambda (specifier bundle)
+		(cond ((null? bundle) '())
+		      ((equal? (caar bundle) specifier)
+		       (cdr bundle))
+		      (else (cons (car bundle)
+				  (remove-old-bundle specifier
+						     (cdr bundle))))))))
+      (lambda (bundle-specifier bundle-assoc-list)
+	(set! *localization-bundles*
+	      (cons (cons bundle-specifier bundle-assoc-list)
+		    (remove-old-bundle bundle-specifier
+				       *localization-bundles*))))))
+
+  ;;Retrieve a localized template given its package name and a template name
+  (define localized-template
+    (letrec ((rdc
+	      (lambda (ls)
+		(if (null? (cdr ls))
+		    '()
+		    (cons (car ls) (rdc (cdr ls))))))
+	     (find-bundle
+	      (lambda (specifier template-name)
+		(cond ((assoc specifier *localization-bundles*) =>
+		       (lambda (bundle) bundle))
+		      ((null? specifier) #f)
+		      (else (find-bundle (rdc specifier)
+					 template-name))))))
+      (lambda (package-name template-name)
+	(let loop ((specifier (cons package-name
+				    (list (current-language)
+					  (current-country)))))
+	  (and (not (null? specifier))
+	       (let ((bundle (find-bundle specifier template-name)))
+		 (and bundle
+		      (cond ((assq template-name bundle) => cdr)
+			     ((null? (cdr specifier)) #f)
+			     (else (loop (rdc specifier)))))))))))
+
+  )
\ No newline at end of file
diff --git a/collects/srfi/30.ss b/collects/srfi/30.ss
new file mode 100644
index 0000000000..15438b73e4
--- /dev/null
+++ b/collects/srfi/30.ss
@@ -0,0 +1,2 @@
+;; Supported by core PLT:
+(module |30| mzscheme)
diff --git a/collects/srfi/31.ss b/collects/srfi/31.ss
new file mode 100644
index 0000000000..3700996bd0
--- /dev/null
+++ b/collects/srfi/31.ss
@@ -0,0 +1,4 @@
+;; SRFI 31: A special form rec for recursive evaluation
+(module |31| mzscheme
+  (require (lib "rec.ss" "srfi" "31"))
+  (provide rec))
diff --git a/collects/srfi/31/.cvsignore b/collects/srfi/31/.cvsignore
new file mode 100644
index 0000000000..e3ca6473f7
--- /dev/null
+++ b/collects/srfi/31/.cvsignore
@@ -0,0 +1 @@
+compiled
diff --git a/collects/srfi/31/rec.ss b/collects/srfi/31/rec.ss
new file mode 100644
index 0000000000..96b8c23bf6
--- /dev/null
+++ b/collects/srfi/31/rec.ss
@@ -0,0 +1,16 @@
+;;;
+;;; <string.ss> ---- SRFI 13 port to PLT Scheme
+;;; Time-stamp: <03/04/25 18:59:09 solsona>
+
+;;; Copyright (C) Dr. Mirko Luedde (2002). All Rights Reserved.
+
+(module rec mzscheme
+  (provide rec)
+
+  (define-syntax rec
+  (syntax-rules ()
+    ((rec (NAME . VARIABLES) . BODY)
+     (letrec ( (NAME (lambda VARIABLES . BODY)) ) NAME))
+    ((rec NAME EXPRESSION)
+     (letrec ( (NAME EXPRESSION) ) NAME))))
+  )
\ No newline at end of file
diff --git a/collects/srfi/38.ss b/collects/srfi/38.ss
new file mode 100644
index 0000000000..aa26631d60
--- /dev/null
+++ b/collects/srfi/38.ss
@@ -0,0 +1,4 @@
+;; Supported by core PLT:
+(module |38| mzscheme
+  (provide (rename write write-with-shared-structure)
+           (rename read read-with-shared-structure)))
diff --git a/collects/srfi/39.ss b/collects/srfi/39.ss
new file mode 100644
index 0000000000..bdda23ac57
--- /dev/null
+++ b/collects/srfi/39.ss
@@ -0,0 +1,3 @@
+;; Supported by core PLT:
+(module |39| mzscheme
+  (provide make-parameter parameterize))
\ No newline at end of file
diff --git a/collects/srfi/4.ss b/collects/srfi/4.ss
new file mode 100644
index 0000000000..0aae4bb60f
--- /dev/null
+++ b/collects/srfi/4.ss
@@ -0,0 +1,3 @@
+(module |4| mzscheme
+  (require (lib "foreign.ss"))
+  (provide-srfi-4))
diff --git a/collects/srfi/40.ss b/collects/srfi/40.ss
new file mode 100644
index 0000000000..c7ee0c9c8c
--- /dev/null
+++ b/collects/srfi/40.ss
@@ -0,0 +1,4 @@
+;; module loader for SRFI-40
+(module |40| mzscheme
+  (require (lib "stream.ss" "srfi" "40"))
+  (provide (all-from (lib "stream.ss" "srfi" "40"))))
diff --git a/collects/srfi/40/stream.ss b/collects/srfi/40/stream.ss
new file mode 100644
index 0000000000..1dba8c8a0e
--- /dev/null
+++ b/collects/srfi/40/stream.ss
@@ -0,0 +1,219 @@
+; SRFI 40
+; STREAM -- LIBRARY OF SYNTAX AND FUNCTIONS TO MANIPULATE STREAMS
+; Zhu Chongkai    mrmathematica@yahoo.com
+; 3-Apr-2005
+
+(module stream mzscheme
+  
+  (provide stream-null
+           stream-cons
+           stream?
+           stream-null?
+           stream-pair?
+           stream-car
+           stream-cdr
+           stream-delay
+           (rename my-stream stream)
+           stream-unfoldn
+           stream-map
+           stream-for-each
+           stream-filter)
+  
+  ;;; PROMISES A LA SRFI-45:
+  
+  ;;; A separate implementation is necessary to
+  ;;; have promises that answer #t to stream?
+  ;;; This requires lots of complicated type conversions.
+  
+  (define-struct s:promise (kind content))
+  
+  (define-syntax srfi-40:lazy
+    (syntax-rules ()
+      ((_ exp)
+       (box (make-s:promise 'lazy (lambda () exp))))))
+  
+  (define (srfi-40:eager x)
+    (make-stream (box (make-s:promise 'eager x))))
+  
+  (define-syntax srfi-40:delay
+    (syntax-rules ()
+      ((_ exp)
+       (srfi-40:lazy (srfi-40:eager exp)))))
+  
+  (define (srfi-40:force promise)
+    (let ((content (unbox promise)))
+      (case (s:promise-kind content)
+        ((eager) (s:promise-content content))
+        ((lazy)
+         (let* ((promise* (stream-promise ((s:promise-content content))))
+                (content (unbox promise)))
+           (unless (eq? 'eager (s:promise-kind content))
+             (set-s:promise-kind! content (s:promise-kind (unbox promise*)))
+             (set-s:promise-content! content (s:promise-content (unbox promise*)))
+             (set-box! promise* content))
+           (srfi-40:force promise))))))
+  
+  ;;; A stream is a new data type, disjoint from all other data types, that
+  ;;; contains a promise that, when forced, is either nil (a single object
+  ;;; distinguishable from all other objects) or consists of an object
+  ;;; (the stream element) followed by a stream.  Each stream element is
+  ;;; evaluated exactly once, when it is first retrieved (not when it is
+  ;;; created); once evaluated its value is saved to be returned by
+  ;;; subsequent retrievals without being evaluated again.
+  
+  ;; STREAM? object -- #t if object is a stream, #f otherwise
+  (define-struct stream (promise))
+  
+  ;; STREAM-NULL -- the distinguished nil stream
+  (define stream-null (make-stream (srfi-40:delay '())))
+  
+  ;; STREAM-CONS object stream -- primitive constructor of streams
+  (define-syntax stream-cons
+    (syntax-rules ()
+      ((_ obj strm)
+       (make-stream (srfi-40:delay (cons obj strm))))))
+  
+  ;; STREAM-NULL? object -- #t if object is the null stream, #f otherwise
+  (define (stream-null? obj)
+    (and (stream? obj)
+         (null? (srfi-40:force (stream-promise obj)))))
+  
+  ;; STREAM-PAIR? object -- #t if object is a non-null stream, #f otherwise
+  (define (stream-pair? obj)
+    (and (stream? obj)
+         (not (null? (srfi-40:force (stream-promise obj))))))
+  
+  ;; STREAM-CAR stream -- first element of stream
+  (define (stream-car strm)
+    (unless (stream? strm)
+      (raise-type-error 'stream-car "stream" strm))
+    (let ((pair (srfi-40:force (stream-promise strm))))
+      (if (null? pair)
+          (raise-type-error 'stream-car "stream-pair" strm)
+          (car pair))))
+  
+  ;; STREAM-CDR stream -- remaining elements of stream after first
+  (define (stream-cdr strm)
+    (unless (stream? strm)
+      (raise-type-error 'stream-cdr "stream" strm))
+    (let ((pair (srfi-40:force (stream-promise strm))))
+      (if (null? pair)
+          (raise-type-error 'stream-cdr "stream-pair" strm)
+          (cdr pair))))
+  
+  ;; STREAM-DELAY object -- the essential stream mechanism
+  (define-syntax stream-delay
+    (syntax-rules ()
+      ((_ expr)
+       (make-stream (srfi-40:lazy expr)))))
+  
+  ;; STREAM object ... -- new stream whose elements are object ...
+  (define (my-stream . objs)
+    (let loop ((objs objs))
+      (stream-delay
+       (if (null? objs)
+           stream-null
+           (stream-cons (car objs) (loop (cdr objs)))))))
+  
+  ;; STREAM-UNFOLDN generator seed n -- n streams from (generator seed)
+  (define stream-unfoldn
+    (letrec ((unfold-result-stream
+              (lambda (gen seed)
+                (let loop ((seed seed))
+                  (stream-delay
+                   (call-with-values
+                    (lambda () (gen seed))
+                    (lambda (next . results)
+                      (stream-cons results (loop next))))))))
+             (result-stream->output-stream
+              (lambda (result-stream i)
+                (stream-delay
+                 (let ((result
+                        (list-ref (stream-car result-stream) i)))
+                   (cond ((pair? result)
+                          (stream-cons (car result)
+                                       (result-stream->output-stream
+                                        (stream-cdr result-stream) i)))
+                         ((not result)
+                          (result-stream->output-stream
+                           (stream-cdr result-stream) i))
+                         ((null? result)
+                          stream-null)
+                         (else
+                          (raise-mismatch-error
+                           'stream-unfoldn
+                           "result of the generator should be <pair>/#f/null; given "
+                           result)))))))
+             (result-stream->output-streams
+              (lambda (result-stream n)
+                (let loop ((i n) (outputs '()))
+                  (if (zero? i)
+                      (apply values outputs)
+                      (let ((i (sub1 i)))
+                        (loop i
+                              (cons (result-stream->output-stream result-stream i)
+                                    outputs))))))))
+      (lambda (gen seed n)
+        (unless (procedure-arity-includes? gen 1)
+          (raise-type-error 'stream-unfoldn "procedure of arity 1" gen))
+        (unless (and (integer? n)
+                     (exact? n)
+                     (positive? n))
+          (raise-type-error 'stream-unfoldn "exact, non-negative integer" n))
+        (result-stream->output-streams (unfold-result-stream gen seed) n))))
+  
+  ;; STREAM-MAP func stream ... -- stream produced by applying func element-wise
+  (define (stream-map func strm1 . strms)
+    (unless (procedure? func)
+      (raise-type-error 'stream-map "procedure" func))
+    (unless (stream? strm1)
+      (raise-type-error 'stream-map "stream" strm1))
+    (if (null? strms)
+        (let loop ((strm strm1))
+          (stream-delay
+           (if (stream-null? strm)
+               stream-null
+               (stream-cons (func (stream-car strm))
+                            (loop (stream-cdr strm))))))
+        (if (andmap stream? strms)
+            (let loop ((strms (cons strm1 strms)))
+              (stream-delay
+               (if (ormap stream-null? strms)
+                   stream-null
+                   (stream-cons (apply func (map stream-car strms))
+                                (loop (map stream-cdr strms))))))
+            (raise-type-error 'stream-map "streams" strms))))
+  
+  ;; STREAM-FOR-EACH proc stream ... -- apply proc element-wise for side-effects
+  (define (stream-for-each proc strm1 . strms)
+    (unless (procedure? proc)
+      (raise-type-error 'stream-for-each "procedure" proc))
+    (unless (stream? strm1)
+      (raise-type-error 'stream-for-each "stream" strm1))
+    (if (null? strms)
+        (let loop ((strm strm1))
+          (unless (stream-null? strm)
+            (proc (stream-car strm))
+            (loop (stream-cdr strm))))
+        (if (andmap stream? strms)
+            (let loop ((strms (cons strm1 strms)))
+              (unless (ormap stream-null? strms)
+                (apply proc (map stream-car strms))
+                (loop (map stream-cdr strms))))
+            (raise-type-error 'stream-for-each "streams" strms))))
+  
+  ;; STREAM-FILTER pred? stream -- new stream including only items passing pred?
+  (define (stream-filter pred? strm)
+    (unless (procedure? pred?)
+      (raise-type-error 'stream-filter "procedure" pred?))
+    (unless (stream? strm)
+      (raise-type-error 'stream-filter "stream" strm))
+    (let loop ((s strm))
+      (stream-delay
+       (cond ((stream-null? s)
+              stream-null)
+             ((pred? (stream-car s))
+              (stream-cons (stream-car s)
+                           (loop (stream-cdr s))))
+             (else
+              (loop (stream-cdr s))))))))
diff --git a/collects/srfi/42.ss b/collects/srfi/42.ss
new file mode 100644
index 0000000000..64d73d3a0a
--- /dev/null
+++ b/collects/srfi/42.ss
@@ -0,0 +1,4 @@
+;; module loader for SRFI-42
+(module |42| mzscheme
+  (require (lib "comprehensions.ss" "srfi" "42"))
+  (provide (all-from (lib "comprehensions.ss" "srfi" "42"))))
diff --git a/collects/srfi/42/.cvsignore b/collects/srfi/42/.cvsignore
new file mode 100644
index 0000000000..e3ca6473f7
--- /dev/null
+++ b/collects/srfi/42/.cvsignore
@@ -0,0 +1 @@
+compiled
diff --git a/collects/srfi/42/comprehensions.ss b/collects/srfi/42/comprehensions.ss
new file mode 100644
index 0000000000..87f9e601e9
--- /dev/null
+++ b/collects/srfi/42/comprehensions.ss
@@ -0,0 +1,1003 @@
+; SRFI 42 as a module in PLT -----------------------------------------------
+; Sebastian.Egner@philips.com, 15-May-2003, PLT 204.
+; For running demos: (require (lib "examples.ss" "srfi" "42"))
+; For anything else: http://srfi.schemers.org/srfi-42/
+
+(module |comprehensions| mzscheme
+
+ (require (lib "23.ss" "srfi"))
+
+ (provide 
+    do-ec list-ec append-ec string-ec string-append-ec vector-ec 
+      vector-of-length-ec sum-ec product-ec min-ec max-ec any?-ec 
+      every?-ec first-ec last-ec fold-ec fold3-ec 
+    : :list :string :vector :integers :range :real-range :char-range 
+      :port :dispatched :do :let :parallel :while :until
+    :-dispatch-ref :-dispatch-set! make-initial-:-dispatch 
+    :generator-proc )
+
+; There is a subtle point in defining a macro inside a module 
+; and exporting it to the rest of the world. If the macro has a 
+; literal identifier which is imported from another module (in 
+; our case `not' comes from mzscheme) then this identifier 
+; becomes local to the module and does not match patterns 
+; as expected when the exported macro is used outside.
+;    As a fix, Matthew Flatt suggested to use syntax-case*
+; with equivalence predicate module-or-top-identifier=? as
+; require-for-syntax'ed by (lib "stx.ss" "syntax"). To limit
+; the amount of modification to the SRFI 42 code below, we
+; replace define-syntax by the new define-syntax-globally
+; which constructs the proper code. The new transformer
+; must be used for all exported macros recognizing `not'.
+
+  (require-for-syntax (lib "stx.ss" "syntax"))
+  
+  (define-syntax define-syntax-globally
+    (syntax-rules (syntax-rules)
+      ((define-syntax-globally macro 
+         (syntax-rules (identifier ...)
+           (pattern template) ... ))
+       (define-syntax (macro stx)
+         (syntax-case* stx (identifier ...) module-or-top-identifier=?
+           (pattern (syntax template)) ... )))))
+
+; ec.scm with define-syntax-globally starts here ---------------------------
+
+; <PLAINTEXT>
+; Eager Comprehensions in [outer..inner|expr]-Convention
+; ======================================================
+;
+; sebastian.egner@philips.com, Eindhoven, The Netherlands, Feb-2003.
+; Scheme R5RS (incl. macros), SRFI-23 (error).
+; 
+; Loading the implementation into Scheme48 0.57:
+;   ,open srfi-23
+;   ,load ec.scm
+;
+; Loading the implementation into PLT/DrScheme 202:
+;   ; File > Open ... "ec.scm", click Execute
+;
+; Loading the implementation into SCM 5d7:
+;   (require 'macro) (require 'record) 
+;   (load "ec.scm")
+;
+; Implementation comments:
+;   * All local (not exported) identifiers are named ec-<something>.
+;   * This implementation focuses on portability, performance, 
+;     readability, and simplicity roughly in this order. Design
+;     decisions related to performance are taken for Scheme48.
+;   * Alternative implementations, Comments and Warnings are 
+;     mentioned after the definition with a heading.
+
+
+; ==========================================================================
+; The fundamental comprehension do-ec
+; ==========================================================================
+;
+; All eager comprehensions are reduced into do-ec and
+; all generators are reduced to :do. 
+;
+; We use the following short names for syntactic variables
+;   q    - qualifier
+;   cc   - current continuation, thing to call at the end;
+;          the CPS is (m (cc ...) arg ...) -> (cc ... expr ...)
+;   cmd  - an expression being evaluated for its side-effects
+;   expr - an expression
+;   gen  - a generator of an eager comprehension
+;   ob   - outer binding
+;   oc   - outer command
+;   lb   - loop binding
+;   ne1? - not-end1? (before the payload)
+;   ib   - inner binding
+;   ic   - inner command
+;   ne2? - not-end2? (after the payload)
+;   ls   - loop step
+;   etc  - more arguments of mixed type
+
+
+; (do-ec q ... cmd)
+;   handles nested, if/not/and/or, begin, :let, and calls generator 
+;   macros in CPS to transform them into fully decorated :do.
+;   The code generation for a :do is delegated to do-ec:do.
+
+(define-syntax-globally do-ec
+  (syntax-rules (nested if not and or begin :do let)
+
+    ; explicit nesting -> implicit nesting
+    ((do-ec (nested q ...) etc ...)
+     (do-ec q ... etc ...) )
+
+    ; implicit nesting -> fold do-ec
+    ((do-ec q1 q2 etc1 etc ...)
+     (do-ec q1 (do-ec q2 etc1 etc ...)) )
+
+    ; no qualifiers at all -> evaluate cmd once
+    ((do-ec cmd)
+     (begin cmd (if #f #f)) )
+
+; now (do-ec q cmd) remains
+
+    ; filter -> make conditional
+    ((do-ec (if test) cmd)
+     (if test (do-ec cmd)) )
+    ((do-ec (not test) cmd)
+     (if (not test) (do-ec cmd)) )
+    ((do-ec (and test ...) cmd)
+     (if (and test ...) (do-ec cmd)) )
+    ((do-ec (or test ...) cmd)
+     (if (or test ...) (do-ec cmd)) )
+
+    ; begin -> make a sequence
+    ((do-ec (begin etc ...) cmd)
+     (begin etc ... (do-ec cmd)) )
+
+    ; fully decorated :do-generator -> delegate to do-ec:do
+    ((do-ec (:do olet lbs ne1? ilet ne2? lss) cmd)
+     (do-ec:do cmd (:do olet lbs ne1? ilet ne2? lss)) )
+
+; anything else -> call generator-macro in CPS; reentry at (*)
+
+    ((do-ec (g arg1 arg ...) cmd)
+     (g (do-ec:do cmd) arg1 arg ...) )))
+
+
+; (do-ec:do cmd (:do olet lbs ne1? ilet ne2? lss)
+;   generates code for a single fully decorated :do-generator
+;   with cmd as payload, taking care of special cases.
+
+(define-syntax do-ec:do
+  (syntax-rules (:do let)
+
+    ; reentry point (*) -> generate code
+    ((do-ec:do cmd 
+               (:do (let obs oc ...) 
+                    lbs 
+                    ne1? 
+                    (let ibs ic ...) 
+                    ne2? 
+                    (ls ...) ))
+     (ec-simplify
+       (let obs
+         oc ...
+         (let loop lbs
+           (ec-simplify
+             (if ne1?
+                 (ec-simplify
+                   (let ibs
+                      ic ...
+                      cmd
+                      (ec-simplify
+                        (if ne2?
+                            (loop ls ...) )))))))))) ))
+
+    
+; (ec-simplify <expression>)
+;   generates potentially more efficient code for <expression>.
+;   The macro handles if, (begin <command>*), and (let () <command>*)
+;   and takes care of special cases.
+
+(define-syntax-globally ec-simplify
+  (syntax-rules (if not let begin)
+
+; one- and two-sided if
+
+    ; literal <test>
+    ((ec-simplify (if #t consequent))
+     consequent )
+    ((ec-simplify (if #f consequent))
+     (if #f #f) )
+    ((ec-simplify (if #t consequent alternate))
+     consequent )
+    ((ec-simplify (if #f consequent alternate))
+     alternate )
+
+    ; (not (not <test>))
+    ((ec-simplify (if (not (not test)) consequent))
+     (ec-simplify (if test consequent)) )
+    ((ec-simplify (if (not (not test)) consequent alternate))
+     (ec-simplify (if test consequent alternate)) )
+
+; (let () <command>*) 
+
+    ; empty <binding spec>*
+    ((ec-simplify (let () command ...))
+     (ec-simplify (begin command ...)) )
+
+; begin 
+
+    ; flatten use helper (ec-simplify 1 done to-do)
+    ((ec-simplify (begin command ...))
+     (ec-simplify 1 () (command ...)) )
+    ((ec-simplify 1 done ((begin to-do1 ...) to-do2 ...))
+     (ec-simplify 1 done (to-do1 ... to-do2 ...)) )
+    ((ec-simplify 1 (done ...) (to-do1 to-do ...))
+     (ec-simplify 1 (done ... to-do1) (to-do ...)) )
+
+    ; exit helper
+    ((ec-simplify 1 () ())
+     (if #f #f) )
+    ((ec-simplify 1 (command) ())
+     command )
+    ((ec-simplify 1 (command1 command ...) ())
+     (begin command1 command ...) )
+
+; anything else
+
+    ((ec-simplify expression)
+     expression )))
+
+
+; ==========================================================================
+; The special generators :do, :let, :parallel, :while, and :until
+; ==========================================================================
+
+(define-syntax :do
+  (syntax-rules ()
+
+    ; full decorated -> continue with cc, reentry at (*)
+    ((:do (cc ...) olet lbs ne1? ilet ne2? lss)
+     (cc ... (:do olet lbs ne1? ilet ne2? lss)) )
+
+    ; short form -> fill in default values
+    ((:do cc lbs ne1? lss)
+     (:do cc (let ()) lbs ne1? (let ()) #t lss) )))
+    
+
+(define-syntax :let
+  (syntax-rules (index)
+    ((:let cc var (index i) expression)
+     (:do cc (let ((var expression) (i 0))) () #t (let ()) #f ()) )
+    ((:let cc var expression)
+     (:do cc (let ((var expression))) () #t (let ()) #f ()) )))
+
+
+(define-syntax :parallel
+  (syntax-rules (:do)
+    ((:parallel cc)
+     cc )
+    ((:parallel cc (g arg1 arg ...) gen ...)
+     (g (:parallel-1 cc (gen ...)) arg1 arg ...) )))
+
+; (:parallel-1 cc (to-do ...) result [ next ] )
+;    iterates over to-do by converting the first generator into 
+;    the :do-generator next and merging next into result.
+
+(define-syntax :parallel-1  ; used as 
+  (syntax-rules (:do let)
+
+    ; process next element of to-do, reentry at (**)
+    ((:parallel-1 cc ((g arg1 arg ...) gen ...) result)
+     (g (:parallel-1 cc (gen ...) result) arg1 arg ...) )
+
+    ; reentry point (**) -> merge next into result
+    ((:parallel-1 
+       cc 
+       gens 
+       (:do (let (ob1 ...) oc1 ...) 
+            (lb1 ...) 
+            ne1?1 
+            (let (ib1 ...) ic1 ...) 
+            ne2?1 
+            (ls1 ...) )
+       (:do (let (ob2 ...) oc2 ...) 
+            (lb2 ...) 
+            ne1?2 
+            (let (ib2 ...) ic2 ...) 
+            ne2?2 
+            (ls2 ...) ))
+     (:parallel-1 
+       cc 
+       gens 
+       (:do (let (ob1 ... ob2 ...) oc1 ... oc2 ...) 
+            (lb1 ... lb2 ...) 
+            (and ne1?1 ne1?2) 
+            (let (ib1 ... ib2 ...) ic1 ... ic2 ...) 
+            (and ne2?1 ne2?2) 
+            (ls1 ... ls2 ...) )))
+
+    ; no more gens -> continue with cc, reentry at (*)
+    ((:parallel-1 (cc ...) () result)
+     (cc ... result) )))
+
+
+(define-syntax :while
+  (syntax-rules ()
+    ((:while cc (g arg1 arg ...) test)
+     (g (:while-1 cc test) arg1 arg ...) )))
+
+(define-syntax :while-1
+  (syntax-rules (:do)
+    ((:while-1 cc test (:do olet lbs ne1? ilet ne2? lss))
+     (:do cc olet lbs (and ne1? test) ilet ne2? lss) )))
+
+
+(define-syntax :until
+  (syntax-rules ()
+    ((:until cc (g arg1 arg ...) test)
+     (g (:until-1 cc test) arg1 arg ...) )))
+
+(define-syntax :until-1
+  (syntax-rules (:do)
+    ((:until-1 cc test (:do olet lbs ne1? ilet ne2? lss))
+     (:do cc olet lbs ne1? ilet (and ne2? (not test)) lss) )))
+
+
+; ==========================================================================
+; The typed generators :list :string :vector etc.
+; ==========================================================================
+
+(define-syntax :list
+  (syntax-rules (index)
+    ((:list cc var (index i) arg ...)
+     (:parallel cc (:list var arg ...) (:integers i)) )
+    ((:list cc var arg1 arg2 arg ...)
+     (:list cc var (append arg1 arg2 arg ...)) )
+    ((:list cc var arg)
+     (:do cc
+          (let ())
+          ((t arg))
+          (not (null? t))
+          (let ((var (car t))))
+          #t
+          ((cdr t)) ))))
+
+
+(define-syntax :string
+  (syntax-rules (index)
+    ((:string cc var (index i) arg)
+     (:do cc
+          (let ((str arg) (len 0)) 
+            (set! len (string-length str)))
+          ((i 0))
+          (< i len)
+          (let ((var (string-ref str i))))
+          #t
+          ((+ i 1)) ))
+    ((:string cc var (index i) arg1 arg2 arg ...)
+     (:string cc var (index i) (string-append arg1 arg2 arg ...)) )
+    ((:string cc var arg1 arg ...)
+     (:string cc var (index i) arg1 arg ...) )))
+
+; Alternative: An implementation in the style of :vector can also
+;   be used for :string. However, it is less interesting as the
+;   overhead of string-append is much less than for 'vector-append'.
+
+
+(define-syntax :vector
+  (syntax-rules (index)
+    ((:vector cc var arg)
+     (:vector cc var (index i) arg) )
+    ((:vector cc var (index i) arg)
+     (:do cc
+          (let ((vec arg) (len 0)) 
+            (set! len (vector-length vec)))
+          ((i 0))
+          (< i len)
+          (let ((var (vector-ref vec i))))
+          #t
+          ((+ i 1)) ))
+
+    ((:vector cc var (index i) arg1 arg2 arg ...)
+     (:parallel cc (:vector cc var arg1 arg2 arg ...) (:integers i)) )
+    ((:vector cc var arg1 arg2 arg ...)
+     (:do cc
+          (let ((vec #f)
+                (len 0)
+                (vecs (ec-:vector-filter (list arg1 arg2 arg ...))) ))
+          ((k 0))
+          (if (< k len)
+              #t
+              (if (null? vecs)
+                  #f
+                  (begin (set! vec (car vecs))
+                         (set! vecs (cdr vecs))
+                         (set! len (vector-length vec))
+                         (set! k 0)
+                         #t )))
+          (let ((var (vector-ref vec k))))
+          #t
+          ((+ k 1)) ))))
+
+(define (ec-:vector-filter vecs)
+  (if (null? vecs)
+      '()
+      (if (zero? (vector-length (car vecs)))
+          (ec-:vector-filter (cdr vecs))
+          (cons (car vecs) (ec-:vector-filter (cdr vecs))) )))
+
+; Alternative: A simpler implementation for :vector uses vector->list
+;   append and :list in the multi-argument case. Please refer to the
+;   'design.scm' for more details.
+
+
+(define-syntax :integers
+  (syntax-rules (index)
+    ((:integers cc var (index i))
+     (:do cc ((var 0) (i 0)) #t ((+ var 1) (+ i 1))) )
+    ((:integers cc var)
+     (:do cc ((var 0)) #t ((+ var 1))) )))
+
+
+(define-syntax :range
+  (syntax-rules (index)
+
+    ; handle index variable and add optional args
+    ((:range cc var (index i) arg1 arg ...)
+     (:parallel cc (:range var arg1 arg ...) (:integers i)) )
+    ((:range cc var arg1)
+     (:range cc var 0 arg1 1) )
+    ((:range cc var arg1 arg2)
+     (:range cc var arg1 arg2 1) )
+
+; special cases (partially evaluated by hand from general case)
+
+    ((:range cc var 0 arg2 1)
+     (:do cc
+          (let ((b arg2))
+            (if (not (and (integer? b) (exact? b)))
+                (error 
+                   "arguments of :range are not exact integer "
+                   "(use :real-range?)" 0 b 1 )))
+          ((var 0))
+          (< var b)
+          (let ())
+          #t
+          ((+ var 1)) ))
+
+    ((:range cc var 0 arg2 -1)
+     (:do cc
+          (let ((b arg2))
+            (if (not (and (integer? b) (exact? b)))
+                (error 
+                   "arguments of :range are not exact integer "
+                   "(use :real-range?)" 0 b 1 )))
+          ((var 0))
+          (> var b)
+          (let ())
+          #t
+          ((- var 1)) ))
+
+    ((:range cc var arg1 arg2 1)
+     (:do cc
+          (let ((a arg1) (b arg2))
+            (if (not (and (integer? a) (exact? a)
+                          (integer? b) (exact? b) ))
+                (error 
+                   "arguments of :range are not exact integer "
+                   "(use :real-range?)" a b 1 )) )
+          ((var a))
+          (< var b)
+          (let ())
+          #t
+          ((+ var 1)) ))
+
+    ((:range cc var arg1 arg2 -1)
+     (:do cc
+          (let ((a arg1) (b arg2) (s -1) (stop 0))
+            (if (not (and (integer? a) (exact? a)
+                          (integer? b) (exact? b) ))
+                (error 
+                   "arguments of :range are not exact integer "
+                   "(use :real-range?)" a b -1 )) )
+          ((var a))
+          (> var b)
+          (let ())
+          #t
+          ((- var 1)) ))
+
+; the general case
+
+    ((:range cc var arg1 arg2 arg3)
+     (:do cc
+          (let ((a arg1) (b arg2) (s arg3) (stop 0))
+            (if (not (and (integer? a) (exact? a)
+                          (integer? b) (exact? b)
+                          (integer? s) (exact? s) ))
+                (error 
+                   "arguments of :range are not exact integer "
+                   "(use :real-range?)" a b s ))
+            (if (zero? s)
+                (error "step size must not be zero in :range") )
+            (set! stop (+ a (* (max 0 (ceiling (/ (- b a) s))) s))) )
+          ((var a))
+          (not (= var stop))
+          (let ())
+          #t
+          ((+ var s)) ))))
+
+; Comment: The macro :range inserts some code to make sure the values
+;   are exact integers. This overhead has proven very helpful for 
+;   saving users from themselves.
+
+
+(define-syntax :real-range
+  (syntax-rules (index)
+
+    ; add optional args and index variable
+    ((:real-range cc var arg1)
+     (:real-range cc var (index i) 0 arg1 1) )
+    ((:real-range cc var (index i) arg1)
+     (:real-range cc var (index i) 0 arg1 1) )
+    ((:real-range cc var arg1 arg2)
+     (:real-range cc var (index i) arg1 arg2 1) )
+    ((:real-range cc var (index i) arg1 arg2)
+     (:real-range cc var (index i) arg1 arg2 1) )
+    ((:real-range cc var arg1 arg2 arg3)
+     (:real-range cc var (index i) arg1 arg2 arg3) )
+
+    ; the fully qualified case
+    ((:real-range cc var (index i) arg1 arg2 arg3)
+     (:do cc
+          (let ((a arg1) (b arg2) (s arg3) (istop 0))
+            (if (not (and (real? a) (real? b) (real? s)))
+                (error "arguments of :real-range are not real" a b s) )
+            (if (and (exact? a) (or (not (exact? b)) (not (exact? s))))
+                (set! a (exact->inexact a)) )
+            (set! istop (/ (- b a) s)) )
+          ((i 0))
+          (< i istop)
+          (let ((var (+ a (* s i)))))
+          #t
+          ((+ i 1)) ))))
+
+; Comment: The macro :real-range adapts the exactness of the start
+;   value in case any of the other values is inexact. This is a
+;   precaution to avoid (list-ec (: x 0 3.0) x) => '(0 1.0 2.0).
+
+    
+(define-syntax :char-range
+  (syntax-rules (index)
+    ((:char-range cc var (index i) arg1 arg2)
+     (:parallel cc (:char-range var arg1 arg2) (:integers i)) )
+    ((:char-range cc var arg1 arg2)
+     (:do cc
+          (let ((imax (char->integer arg2))))
+          ((i (char->integer arg1)))
+          (<= i imax)
+          (let ((var (integer->char i))))
+          #t
+          ((+ i 1)) ))))
+
+; Warning: There is no R5RS-way to implement the :char-range generator 
+;   because the integers obtained by char->integer are not necessarily 
+;   consecutive. We simply assume this anyhow for illustration.
+
+
+(define-syntax :port
+  (syntax-rules (index)
+    ((:port cc var (index i) arg1 arg ...)
+     (:parallel cc (:port var arg1 arg ...) (:integers i)) )
+    ((:port cc var arg)
+     (:port cc var arg read) )
+    ((:port cc var arg1 arg2)
+     (:do cc
+          (let ((port arg1) (read-proc arg2)))
+          ((var (read-proc port)))
+          (not (eof-object? var))
+          (let ())
+          #t
+          ((read-proc port)) ))))
+
+
+; ==========================================================================
+; The typed generator :dispatched and utilities for constructing dispatchers
+; ==========================================================================
+
+(define-syntax :dispatched
+  (syntax-rules (index)
+    ((:dispatched cc var (index i) dispatch arg1 arg ...)
+     (:parallel cc 
+                (:integers i)
+                (:dispatched var dispatch arg1 arg ...) ))
+    ((:dispatched cc var dispatch arg1 arg ...)
+     (:do cc
+          (let ((d dispatch) 
+                (args (list arg1 arg ...)) 
+                (g #f) 
+                (empty (list #f)) )
+            (set! g (d args))
+            (if (not (procedure? g))
+                (error "unrecognized arguments in dispatching" 
+                       args 
+                       (d '()) )))
+          ((var (g empty)))
+          (not (eq? var empty))
+          (let ())
+          #t
+          ((g empty)) ))))
+
+; Comment: The unique object empty is created as a newly allocated
+;   non-empty list. It is compared using eq? which distinguishes
+;   the object from any other object, according to R5RS 6.1.
+
+
+(define-syntax :generator-proc
+  (syntax-rules (:do let)
+
+    ; call g with a variable, reentry at (**)
+    ((:generator-proc (g arg ...))
+     (g (:generator-proc var) var arg ...) )
+
+    ; reentry point (**) -> make the code from a single :do
+    ((:generator-proc
+       var 
+       (:do (let obs oc ...) 
+            ((lv li) ...) 
+            ne1? 
+            (let ((i v) ...) ic ...) 
+            ne2? 
+            (ls ...)) )
+     (ec-simplify 
+      (let obs
+          oc ...
+          (let ((lv li) ... (ne2 #t))
+            (ec-simplify
+             (let ((i #f) ...) ; v not yet valid
+               (lambda (empty)
+                 (if (and ne1? ne2)
+                     (ec-simplify
+                      (begin 
+                        (set! i v) ...
+                        ic ...
+                        (let ((value var))
+                          (ec-simplify
+                           (if ne2?
+                               (ec-simplify 
+                                (begin (set! lv ls) ...) )
+                               (set! ne2 #f) ))
+                          value )))
+                     empty ))))))))
+
+    ; silence warnings of some macro expanders
+    ((:generator-proc var)
+     (error "illegal macro call") )))
+
+
+(define (dispatch-union d1 d2)
+  (lambda (args)
+    (let ((g1 (d1 args)) (g2 (d2 args)))
+      (if g1
+          (if g2 
+              (if (null? args)
+                  (append (if (list? g1) g1 (list g1)) 
+                          (if (list? g2) g2 (list g2)) )
+                  (error "dispatching conflict" args (d1 '()) (d2 '())) )
+              g1 )
+          (if g2 g2 #f) ))))
+
+
+; ==========================================================================
+; The dispatching generator :
+; ==========================================================================
+
+(define (make-initial-:-dispatch)
+  (lambda (args)
+    (case (length args)
+      ((0) 'SRFI42)
+      ((1) (let ((a1 (car args)))
+             (cond
+              ((list? a1)
+               (:generator-proc (:list a1)) )
+              ((string? a1)
+               (:generator-proc (:string a1)) )
+              ((vector? a1)
+               (:generator-proc (:vector a1)) )
+              ((and (integer? a1) (exact? a1))
+               (:generator-proc (:range a1)) )
+              ((real? a1)
+               (:generator-proc (:real-range a1)) )
+              ((input-port? a1)
+               (:generator-proc (:port a1)) )
+              (else
+               #f ))))
+      ((2) (let ((a1 (car args)) (a2 (cadr args)))
+             (cond
+              ((and (list? a1) (list? a2))
+               (:generator-proc (:list a1 a2)) )
+              ((and (string? a1) (string? a1))
+               (:generator-proc (:string a1 a2)) )
+              ((and (vector? a1) (vector? a2))
+               (:generator-proc (:vector a1 a2)) )
+              ((and (integer? a1) (exact? a1) (integer? a2) (exact? a2))
+               (:generator-proc (:range a1 a2)) )
+              ((and (real? a1) (real? a2))
+               (:generator-proc (:real-range a1 a2)) )
+              ((and (char? a1) (char? a2))
+               (:generator-proc (:char-range a1 a2)) )
+              ((and (input-port? a1) (procedure? a2))
+               (:generator-proc (:port a1 a2)) )
+              (else
+               #f ))))
+      ((3) (let ((a1 (car args)) (a2 (cadr args)) (a3 (caddr args)))
+             (cond
+              ((and (list? a1) (list? a2) (list? a3))
+               (:generator-proc (:list a1 a2 a3)) )
+              ((and (string? a1) (string? a1) (string? a3))
+               (:generator-proc (:string a1 a2 a3)) )
+              ((and (vector? a1) (vector? a2) (vector? a3))
+               (:generator-proc (:vector a1 a2 a3)) )
+              ((and (integer? a1) (exact? a1) 
+                    (integer? a2) (exact? a2)
+                    (integer? a3) (exact? a3))
+               (:generator-proc (:range a1 a2 a3)) )
+              ((and (real? a1) (real? a2) (real? a3))
+               (:generator-proc (:real-range a1 a2 a3)) )
+              (else
+               #f ))))
+      (else
+       (letrec ((every? 
+                 (lambda (pred args)
+                   (if (null? args)
+                       #t
+                       (and (pred (car args))
+                            (every? pred (cdr args)) )))))
+         (cond
+          ((every? list? args)
+           (:generator-proc (:list (apply append args))) )
+          ((every? string? args)
+           (:generator-proc (:string (apply string-append args))) )
+          ((every? vector? args)
+           (:generator-proc (:list (apply append (map vector->list args)))) )
+          (else
+           #f )))))))
+
+(define :-dispatch
+  (make-initial-:-dispatch) )
+
+(define (:-dispatch-ref)
+  :-dispatch )
+
+(define (:-dispatch-set! dispatch)
+  (if (not (procedure? dispatch))
+      (error "not a procedure" dispatch) )
+  (set! :-dispatch dispatch) )
+
+(define-syntax :
+  (syntax-rules (index)
+    ((: cc var (index i) arg1 arg ...)
+     (:dispatched cc var (index i) :-dispatch arg1 arg ...) )
+    ((: cc var arg1 arg ...)
+     (:dispatched cc var :-dispatch arg1 arg ...) )))
+
+
+; ==========================================================================
+; The utility comprehensions fold-ec, fold3-ec
+; ==========================================================================
+
+(define-syntax fold3-ec
+  (syntax-rules (nested)
+    ((fold3-ec x0 (nested q1 ...) q etc1 etc2 etc3 etc ...)
+     (fold3-ec x0 (nested q1 ... q) etc1 etc2 etc3 etc ...) )
+    ((fold3-ec x0 q1 q2 etc1 etc2 etc3 etc ...)
+     (fold3-ec x0 (nested q1 q2) etc1 etc2 etc3 etc ...) )
+    ((fold3-ec x0 expression f1 f2)
+     (fold3-ec x0 (nested) expression f1 f2) )
+
+    ((fold3-ec x0 qualifier expression f1 f2)
+     (let ((result #f) (empty #t))
+       (do-ec qualifier
+              (let ((value expression)) ; don't duplicate
+                (if empty
+                    (begin (set! result (f1 value))
+                           (set! empty #f) )
+                    (set! result (f2 value result)) )))
+       (if empty x0 result) ))))
+
+
+(define-syntax fold-ec
+  (syntax-rules (nested)
+    ((fold-ec x0 (nested q1 ...) q etc1 etc2 etc ...)
+     (fold-ec x0 (nested q1 ... q) etc1 etc2 etc ...) )
+    ((fold-ec x0 q1 q2 etc1 etc2 etc ...)
+     (fold-ec x0 (nested q1 q2) etc1 etc2 etc ...) )
+    ((fold-ec x0 expression f2)
+     (fold-ec x0 (nested) expression f2) )
+
+    ((fold-ec x0 qualifier expression f2)
+     (let ((result x0))
+       (do-ec qualifier (set! result (f2 expression result)))
+       result ))))
+
+
+; ==========================================================================
+; The comprehensions list-ec string-ec vector-ec etc.
+; ==========================================================================
+
+(define-syntax list-ec
+  (syntax-rules ()
+    ((list-ec etc1 etc ...)
+     (reverse (fold-ec '() etc1 etc ... cons)) )))
+
+; Alternative: Reverse can safely be replaced by reverse! if you have it.
+;
+; Alternative: It is possible to construct the result in the correct order
+;   using set-cdr! to add at the tail. This removes the overhead of copying
+;   at the end, at the cost of more book-keeping.
+
+
+(define-syntax append-ec
+  (syntax-rules ()
+    ((append-ec etc1 etc ...)
+     (apply append (list-ec etc1 etc ...)) )))
+
+(define-syntax string-ec
+  (syntax-rules ()
+    ((string-ec etc1 etc ...)
+     (list->string (list-ec etc1 etc ...)) )))
+
+; Alternative: For very long strings, the intermediate list may be a
+;   problem. A more space-aware implementation collect the characters 
+;   in an intermediate list and when this list becomes too large it is
+;   converted into an intermediate string. At the end, the intermediate
+;   strings are concatenated with string-append.
+
+
+(define-syntax string-append-ec
+  (syntax-rules ()
+    ((string-append-ec etc1 etc ...)
+     (apply string-append (list-ec etc1 etc ...)) )))
+
+(define-syntax vector-ec
+  (syntax-rules ()
+    ((vector-ec etc1 etc ...)
+     (list->vector (list-ec etc1 etc ...)) )))
+
+; Comment: A similar approach as for string-ec can be used for vector-ec.
+;   However, the space overhead for the intermediate list is much lower
+;   than for string-ec and as there is no vector-append, the intermediate
+;   vectors must be copied explicitly.
+
+(define-syntax vector-of-length-ec
+  (syntax-rules (nested)
+    ((vector-of-length-ec k (nested q1 ...) q etc1 etc ...)
+     (vector-of-length-ec k (nested q1 ... q) etc1 etc ...) )
+    ((vector-of-length-ec k q1 q2             etc1 etc ...)
+     (vector-of-length-ec k (nested q1 q2)    etc1 etc ...) )
+    ((vector-of-length-ec k expression)
+     (vector-of-length-ec k (nested) expression) )
+
+    ((vector-of-length-ec k qualifier expression)
+     (let ((len k))
+       (let ((vec (make-vector len))
+             (i 0) )
+         (do-ec qualifier
+                (if (< i len)
+                    (begin (vector-set! vec i expression)
+                           (set! i (+ i 1)) )
+                    (error "vector is too short for the comprehension") ))
+         (if (= i len)
+             vec
+             (error "vector is too long for the comprehension") ))))))
+
+
+(define-syntax sum-ec
+  (syntax-rules ()
+    ((sum-ec etc1 etc ...)
+     (fold-ec (+) etc1 etc ... +) )))
+
+(define-syntax product-ec
+  (syntax-rules ()
+    ((product-ec etc1 etc ...)
+     (fold-ec (*) etc1 etc ... *) )))
+
+(define-syntax min-ec
+  (syntax-rules ()
+    ((min-ec etc1 etc ...)
+     (fold3-ec (min) etc1 etc ... min min) )))
+
+(define-syntax max-ec
+  (syntax-rules ()
+    ((max-ec etc1 etc ...)
+     (fold3-ec (max) etc1 etc ... max max) )))
+
+(define-syntax last-ec
+  (syntax-rules (nested)
+    ((last-ec default (nested q1 ...) q etc1 etc ...)
+     (last-ec default (nested q1 ... q) etc1 etc ...) )
+    ((last-ec default q1 q2             etc1 etc ...)
+     (last-ec default (nested q1 q2)    etc1 etc ...) )
+    ((last-ec default expression)
+     (last-ec default (nested) expression) )
+
+    ((last-ec default qualifier expression)
+     (let ((result default))
+       (do-ec qualifier (set! result expression))
+       result ))))
+
+
+; ==========================================================================
+; The fundamental early-stopping comprehension first-ec
+; ==========================================================================
+
+(define-syntax first-ec
+  (syntax-rules (nested)
+    ((first-ec default (nested q1 ...) q etc1 etc ...)
+     (first-ec default (nested q1 ... q) etc1 etc ...) )
+    ((first-ec default q1 q2             etc1 etc ...)
+     (first-ec default (nested q1 q2)    etc1 etc ...) )
+    ((first-ec default expression)
+     (first-ec default (nested) expression) )
+
+    ((first-ec default qualifier expression)
+     (let ((result default) (stop #f))
+       (ec-guarded-do-ec 
+         stop 
+         (nested qualifier)
+         (begin (set! result expression)
+                (set! stop #t) ))
+       result ))))
+
+; (ec-guarded-do-ec stop (nested q ...) cmd)
+;   constructs (do-ec q ... cmd) where the generators gen in q ... are
+;   replaced by (:until gen stop).
+
+(define-syntax-globally ec-guarded-do-ec
+  (syntax-rules (nested if not and or begin)
+
+    ((ec-guarded-do-ec stop (nested (nested q1 ...) q2 ...) cmd)
+     (ec-guarded-do-ec stop (nested q1 ... q2 ...) cmd) )
+
+    ((ec-guarded-do-ec stop (nested (if test) q ...) cmd)
+     (if test (ec-guarded-do-ec stop (nested q ...) cmd)) )
+    ((ec-guarded-do-ec stop (nested (not test) q ...) cmd)
+     (if (not test) (ec-guarded-do-ec stop (nested q ...) cmd)) )
+    ((ec-guarded-do-ec stop (nested (and test ...) q ...) cmd)
+     (if (and test ...) (ec-guarded-do-ec stop (nested q ...) cmd)) )
+    ((ec-guarded-do-ec stop (nested (or test ...) q ...) cmd)
+     (if (or test ...) (ec-guarded-do-ec stop (nested q ...) cmd)) )
+
+    ((ec-guarded-do-ec stop (nested (begin etc ...) q ...) cmd)
+     (begin etc ... (ec-guarded-do-ec stop (nested q ...) cmd)) )
+
+    ((ec-guarded-do-ec stop (nested gen q ...) cmd)
+     (do-ec 
+       (:until gen stop) 
+       (ec-guarded-do-ec stop (nested q ...) cmd) ))
+
+    ((ec-guarded-do-ec stop (nested) cmd)
+     (do-ec cmd) )))
+
+; Alternative: Instead of modifying the generator with :until, it is
+;   possible to use call-with-current-continuation:
+;
+;   (define-synatx first-ec 
+;     ...same as above...
+;     ((first-ec default qualifier expression)
+;      (call-with-current-continuation 
+;       (lambda (cc)
+;        (do-ec qualifier (cc expression))
+;        default ))) ))
+;
+;   This is much simpler but not necessarily as efficient.
+
+
+; ==========================================================================
+; The early-stopping comprehensions any?-ec every?-ec
+; ==========================================================================
+
+(define-syntax any?-ec
+  (syntax-rules (nested)
+    ((any?-ec (nested q1 ...) q etc1 etc ...)
+     (any?-ec (nested q1 ... q) etc1 etc ...) )
+    ((any?-ec q1 q2             etc1 etc ...)
+     (any?-ec (nested q1 q2)    etc1 etc ...) )
+    ((any?-ec expression)
+     (any?-ec (nested) expression) )
+
+    ((any?-ec qualifier expression)
+     (first-ec #f qualifier (if expression) #t) )))
+
+(define-syntax every?-ec
+  (syntax-rules (nested)
+    ((every?-ec (nested q1 ...) q etc1 etc ...)
+     (every?-ec (nested q1 ... q) etc1 etc ...) )
+    ((every?-ec q1 q2             etc1 etc ...)
+     (every?-ec (nested q1 q2)    etc1 etc ...) )
+    ((every?-ec expression)
+     (every?-ec (nested) expression) )
+
+    ((every?-ec qualifier expression)
+     (first-ec #t qualifier (if (not expression)) #f) )))
+
+; ec.scm with 'define-syntax-globally ends here ----------------------------
+) ; close the module
\ No newline at end of file
diff --git a/collects/srfi/42/examples-42.ss b/collects/srfi/42/examples-42.ss
new file mode 100644
index 0000000000..095e6ed880
--- /dev/null
+++ b/collects/srfi/42/examples-42.ss
@@ -0,0 +1,598 @@
+; Examples for SRFI 42 as a module to PLT 204 ------------------------------
+; Sebastian.Egner@philips.com, 7-July-2003, PLT 204.
+; For running the demos: (require (lib "examples-42.ss" "srfi" "42"))
+; For anything else: http://srfi.schemers.org/srfi-42/
+
+(module |examples-42| mzscheme
+
+  (require (lib "42.ss" "srfi"))
+
+  (define (my-open-output-file filename)
+    (open-output-file filename 'replace 'text) )
+
+  (define (my-call-with-input-file filename thunk)
+    (call-with-input-file filename thunk 'text) )
+
+; examples.scm starts here -------------------------------------------------
+
+; <PLAINTEXT>
+; Examples for Eager Comprehensions in [outer..inner|expr]-Convention
+; ===================================================================
+;
+; sebastian.egner@philips.com, Eindhoven, The Netherlands, Feb-2003.
+; Scheme R5RS (incl. macros), SRFI-23 (error).
+; 
+; Running the examples in Scheme48 (version 0.57):
+;   ,open srfi-23
+;   ,load ec.scm
+;   (define my-open-output-file open-output-file)
+;   (define my-call-with-input-file call-with-input-file)
+;   ,load examples.scm
+;
+; Running the examples in PLT/DrScheme (version 202): 
+;   ; open "ec.scm", click Execute
+;   (define (my-open-output-file filename)
+;     (open-output-file filename 'replace 'text) )
+;   (define (my-call-with-input-file filename thunk)
+;     (call-with-input-file filename thunk 'text) )
+;   (load "examples.scm")
+;
+; Running the examples in PLT/DrScheme (version 204): 
+;   (require (lib "42-examples.ss" "srfi"))
+;
+; Running the examples in SCM (version 5d7):
+;   (require 'macro) (require 'record)
+;   (load "ec.scm")
+;   (define my-open-output-file open-output-file)
+;   (define my-call-with-input-file call-with-input-file)
+;   (load "examples.scm")
+
+
+; Tools for checking results
+; ==========================
+
+(define (my-equal? x y)
+  (cond
+   ((or (boolean? x) 
+        (null? x)
+        (symbol? x) 
+        (char? x) 
+        (input-port? x)
+        (output-port? x) )
+    (eqv? x y) )
+   ((string? x)
+    (and (string? y) (string=? x y)) )
+   ((vector? x)
+    (and (vector? y)
+         (my-equal? (vector->list x) (vector->list y)) ))
+   ((pair? x)
+    (and (pair? y)
+         (my-equal? (car x) (car y))
+         (my-equal? (cdr x) (cdr y)) ))
+   ((real? x)
+    (and (real? y)
+         (eqv? (exact? x) (exact? y))
+         (if (exact? x)
+             (= x y)
+             (< (abs (- x y)) (/ 1 (expt 10 6))) ))) ; will do here
+   (else
+    (error "unrecognized type" x) )))
+
+(define my-check-correct 0)
+(define my-check-wrong   0)
+
+(define-syntax my-check
+  (syntax-rules (=>)
+    ((my-check ec => desired-result)
+     (begin
+       (newline)
+       (write (quote ec))
+       (newline)
+       (let ((actual-result ec))
+         (display "  => ")
+         (write actual-result)
+         (if (my-equal? actual-result desired-result)
+             (begin
+               (display " ; correct")
+               (set! my-check-correct (+ my-check-correct 1)) )
+             (begin
+               (display " ; *** wrong ***, desired result:")
+               (newline)
+               (display "  => ")
+               (write desired-result)
+               (set! my-check-wrong (+ my-check-wrong 1)) ))
+         (newline) )))))
+             
+
+; ==========================================================================
+; do-ec 
+; ==========================================================================
+
+(my-check 
+  (let ((x 0)) (do-ec (set! x (+ x 1))) x) 
+  => 1)
+
+(my-check 
+  (let ((x 0)) (do-ec (:range i 10) (set! x (+ x 1))) x) 
+  => 10)
+
+(my-check 
+  (let ((x 0)) (do-ec (:range n 10) (:range k n) (set! x (+ x 1))) x) 
+  => 45)
+
+
+; ==========================================================================
+; list-ec and basic qualifiers 
+; ==========================================================================
+
+(my-check (list-ec 1) => '(1))
+
+(my-check (list-ec (:range i 4) i) => '(0 1 2 3))
+
+(my-check (list-ec (:range n 3) (:range k (+ n 1)) (list n k)) 
+  => '((0 0) (1 0) (1 1) (2 0) (2 1) (2 2)) )
+
+(my-check 
+  (list-ec (:range n 5) (if (even? n)) (:range k (+ n 1)) (list n k)) 
+  => '((0 0) (2 0) (2 1) (2 2) (4 0) (4 1) (4 2) (4 3) (4 4)) )
+
+
+(my-check 
+  (list-ec (:range n 5) (not (even? n)) (:range k (+ n 1)) (list n k)) 
+  => '((1 0) (1 1) (3 0) (3 1) (3 2) (3 3)) )
+
+(my-check
+  (list-ec (:range n 5) 
+           (and (even? n) (> n 2)) 
+           (:range k (+ n 1)) 
+           (list n k) )
+  => '((4 0) (4 1) (4 2) (4 3) (4 4)) )
+
+(my-check
+  (list-ec (:range n 5) 
+           (or (even? n) (> n 3)) 
+           (:range k (+ n 1)) 
+           (list n k) )
+  => '((0 0) (2 0) (2 1) (2 2) (4 0) (4 1) (4 2) (4 3) (4 4)) )
+
+(my-check
+ (let ((x 0)) (list-ec (:range n 10) (begin (set! x (+ x 1))) n) x)
+ => 10 )
+
+(my-check
+ (list-ec (nested (:range n 3) (:range k n)) k)
+ => '(0 0 1) )
+
+
+; ==========================================================================
+; Other comprehensions
+; ==========================================================================
+
+(my-check (append-ec '(a b)) => '(a b))
+(my-check (append-ec (:range i 0) '(a b)) => '())
+(my-check (append-ec (:range i 1) '(a b)) => '(a b))
+(my-check (append-ec (:range i 2) '(a b)) => '(a b a b))
+
+(my-check (string-ec #\a) => (string #\a))
+(my-check (string-ec (:range i 0) #\a) => "")
+(my-check (string-ec (:range i 1) #\a) => "a")
+(my-check (string-ec (:range i 2) #\a) => "aa")
+
+(my-check (string-append-ec "ab") => "ab")
+(my-check (string-append-ec (:range i 0) "ab") => "")
+(my-check (string-append-ec (:range i 1) "ab") => "ab")
+(my-check (string-append-ec (:range i 2) "ab") => "abab")
+
+(my-check (vector-ec 1) => (vector 1))
+(my-check (vector-ec (:range i 0) i) => (vector))
+(my-check (vector-ec (:range i 1) i) => (vector 0))
+(my-check (vector-ec (:range i 2) i) => (vector 0 1))
+
+(my-check (vector-of-length-ec 1 1) => (vector 1))
+(my-check (vector-of-length-ec 0 (:range i 0) i) => (vector))
+(my-check (vector-of-length-ec 1 (:range i 1) i) => (vector 0))
+(my-check (vector-of-length-ec 2 (:range i 2) i) => (vector 0 1))
+
+(my-check (sum-ec 1) => 1)
+(my-check (sum-ec (:range i 0) i) => 0)
+(my-check (sum-ec (:range i 1) i) => 0)
+(my-check (sum-ec (:range i 2) i) => 1)
+(my-check (sum-ec (:range i 3) i) => 3)
+
+(my-check (product-ec 1) => 1)
+(my-check (product-ec (:range i 1 0) i) => 1)
+(my-check (product-ec (:range i 1 1) i) => 1)
+(my-check (product-ec (:range i 1 2) i) => 1)
+(my-check (product-ec (:range i 1 3) i) => 2)
+(my-check (product-ec (:range i 1 4) i) => 6)
+
+(my-check (min-ec 1) => 1)
+(my-check (min-ec (:range i 1) i) => 0)
+(my-check (min-ec (:range i 2) i) => 0)
+
+(my-check (max-ec 1) => 1)
+(my-check (max-ec (:range i 1) i) => 0)
+(my-check (max-ec (:range i 2) i) => 1)
+
+(my-check (first-ec #f 1) => 1)
+(my-check (first-ec #f (:range i 0) i) => #f)
+(my-check (first-ec #f (:range i 1) i) => 0)
+(my-check (first-ec #f (:range i 2) i) => 0)
+
+(my-check 
+  (let ((last-i -1))
+    (first-ec #f (:range i 10) (begin (set! last-i i)) i)
+    last-i )
+  => 0 )
+
+(my-check (last-ec #f 1) => 1)
+(my-check (last-ec #f (:range i 0) i) => #f)
+(my-check (last-ec #f (:range i 1) i) => 0)
+(my-check (last-ec #f (:range i 2) i) => 1)
+
+(my-check (any?-ec #f) => #f)
+(my-check (any?-ec #t) => #t)
+(my-check (any?-ec (:range i 2 2) (even? i)) => #f)
+(my-check (any?-ec (:range i 2 3) (even? i)) => #t)
+
+(my-check (every?-ec #f) => #f)
+(my-check (every?-ec #t) => #t)
+(my-check (every?-ec (:range i 2 2) (even? i)) => #t)
+(my-check (every?-ec (:range i 2 3) (even? i)) => #t)
+(my-check (every?-ec (:range i 2 4) (even? i)) => #f)
+
+(my-check 
+ (let ((sum-sqr (lambda (x result) (+ result (* x x)))))
+   (fold-ec 0 (:range i 10) i sum-sqr) )
+ => 285 )
+
+(my-check 
+ (let ((minus-1 (lambda (x) (- x 1)))
+       (sum-sqr (lambda (x result) (+ result (* x x)))))
+   (fold3-ec (error "wrong") (:range i 10) i minus-1 sum-sqr) )
+ => 284 )
+
+(my-check 
+ (fold3-ec 'infinity (:range i 0) i min min)
+ => 'infinity )
+
+
+; ==========================================================================
+; Typed generators
+; ==========================================================================
+
+(my-check (list-ec (:list x '()) x) => '())
+(my-check (list-ec (:list x '(1)) x) => '(1))
+(my-check (list-ec (:list x '(1 2 3)) x) => '(1 2 3))
+(my-check (list-ec (:list x '(1) '(2)) x) => '(1 2))
+(my-check (list-ec (:list x '(1) '(2) '(3)) x) => '(1 2 3))
+
+(my-check (list-ec (:string c "") c) => '())
+(my-check (list-ec (:string c "1") c) => '(#\1))
+(my-check (list-ec (:string c "123") c) => '(#\1 #\2 #\3))
+(my-check (list-ec (:string c "1" "2") c) => '(#\1 #\2))
+(my-check (list-ec (:string c "1" "2" "3") c) => '(#\1 #\2 #\3))
+
+(my-check (list-ec (:vector x (vector)) x) => '())
+(my-check (list-ec (:vector x (vector 1)) x) => '(1))
+(my-check (list-ec (:vector x (vector 1 2 3)) x) => '(1 2 3))
+(my-check (list-ec (:vector x (vector 1) (vector 2)) x) => '(1 2))
+(my-check 
+ (list-ec (:vector x (vector 1) (vector 2) (vector 3)) x)
+ => '(1 2 3))
+
+(my-check (list-ec (:range x -2) x) => '())
+(my-check (list-ec (:range x -1) x) => '())
+(my-check (list-ec (:range x  0) x) => '())
+(my-check (list-ec (:range x  1) x) => '(0))
+(my-check (list-ec (:range x  2) x) => '(0 1))
+
+(my-check (list-ec (:range x  0  3) x) => '(0 1 2))
+(my-check (list-ec (:range x  1  3) x) => '(1 2))
+(my-check (list-ec (:range x -2 -1) x) => '(-2))
+(my-check (list-ec (:range x -2 -2) x) => '())
+
+(my-check (list-ec (:range x 1 5  2) x) => '(1 3))
+(my-check (list-ec (:range x 1 6  2) x) => '(1 3 5))
+(my-check (list-ec (:range x 5 1 -2) x) => '(5 3))
+(my-check (list-ec (:range x 6 1 -2) x) => '(6 4 2))
+
+(my-check (list-ec (:real-range x 0.0 3.0)     x) => '(0. 1. 2.))
+(my-check (list-ec (:real-range x 0   3.0)     x) => '(0. 1. 2.))
+(my-check (list-ec (:real-range x 0   3   1.0) x) => '(0. 1. 2.))
+
+(my-check 
+ (string-ec (:char-range c #\a #\z) c) 
+ => "abcdefghijklmnopqrstuvwxyz" )
+
+(my-check 
+ (begin
+   (let ((f (my-open-output-file "tmp1")))
+     (do-ec (:range n 10) (begin (write n f) (newline f)))
+     (close-output-port f))
+   (my-call-with-input-file "tmp1"
+    (lambda (port) (list-ec (:port x port read) x)) ))
+ => (list-ec (:range n 10) n) )
+
+(my-check 
+ (begin
+   (let ((f (my-open-output-file "tmp1")))
+     (do-ec (:range n 10) (begin (write n f) (newline f)))
+     (close-output-port f))
+   (my-call-with-input-file "tmp1"                 
+     (lambda (port) (list-ec (:port x port) x)) ))
+ => (list-ec (:range n 10) n) )
+
+
+; ==========================================================================
+; The special generators :do :let :parallel :while :until
+; ==========================================================================
+
+(my-check (list-ec (:do ((i 0)) (< i 4) ((+ i 1))) i) => '(0 1 2 3))
+
+(my-check 
+ (list-ec 
+  (:do (let ((x 'x)))
+       ((i 0)) 
+       (< i 4) 
+       (let ((j (- 10 i))))
+       #t
+       ((+ i 1)) )
+  j )
+ => '(10 9 8 7) )
+
+(my-check (list-ec (:let x 1) x) => '(1))
+(my-check (list-ec (:let x 1) (:let y (+ x 1)) y) => '(2))
+(my-check (list-ec (:let x 1) (:let x (+ x 1)) x) => '(2))
+
+(my-check 
+ (list-ec (:parallel (:range i 1 10) (:list x '(a b c))) (list i x))
+ => '((1 a) (2 b) (3 c)) )
+
+(my-check 
+ (list-ec (:while (:range i 1 10) (< i 5)) i)
+ => '(1 2 3 4) )
+
+(my-check 
+ (list-ec (:until (:range i 1 10) (>= i 5)) i)
+ => '(1 2 3 4 5) )
+
+
+; ==========================================================================
+; The dispatching generator
+; ==========================================================================
+
+(my-check (list-ec (: c '(a b)) c) => '(a b))
+(my-check (list-ec (: c '(a b) '(c d)) c) => '(a b c d))
+
+(my-check (list-ec (: c "ab") c) => '(#\a #\b))
+(my-check (list-ec (: c "ab" "cd") c) => '(#\a #\b #\c #\d))
+
+(my-check (list-ec (: c (vector 'a 'b)) c) => '(a b))
+(my-check (list-ec (: c (vector 'a 'b) (vector 'c)) c) => '(a b c))
+
+(my-check (list-ec (: i 0) i) => '())
+(my-check (list-ec (: i 1) i) => '(0))
+(my-check (list-ec (: i 10) i) => '(0 1 2 3 4 5 6 7 8 9))
+(my-check (list-ec (: i 1 2) i) => '(1))
+(my-check (list-ec (: i 1 2 3) i) => '(1))
+(my-check (list-ec (: i 1 9 3) i) => '(1 4 7))
+
+(my-check (list-ec (: i 0.0 1.0 0.2) i) => '(0. 0.2 0.4 0.6 0.8))
+
+(my-check (list-ec (: c #\a #\c) c) => '(#\a #\b #\c))
+
+(my-check 
+ (begin
+   (let ((f (my-open-output-file "tmp1")))
+     (do-ec (:range n 10) (begin (write n f) (newline f)))
+     (close-output-port f))
+   (my-call-with-input-file "tmp1"                 
+     (lambda (port) (list-ec (: x port read) x)) ))
+ => (list-ec (:range n 10) n) )
+    
+(my-check 
+ (begin
+   (let ((f (my-open-output-file "tmp1")))
+     (do-ec (:range n 10) (begin (write n f) (newline f)))
+     (close-output-port f))
+   (my-call-with-input-file "tmp1"                 
+     (lambda (port) (list-ec (: x port) x)) ))
+ => (list-ec (:range n 10) n) )
+
+
+; ==========================================================================
+; With index variable
+; ==========================================================================
+
+(my-check (list-ec (:list c (index i) '(a b)) (list c i)) => '((a 0) (b 1)))
+(my-check (list-ec (:string c (index i) "a") (list c i)) => '((#\a 0)))
+(my-check (list-ec (:vector c (index i) (vector 'a)) (list c i)) => '((a 0)))
+
+(my-check 
+ (list-ec (:range i (index j) 0 -3 -1) (list i j)) 
+ => '((0 0) (-1 1) (-2 2)) )
+
+(my-check 
+ (list-ec (:real-range i (index j) 0 1 0.2) (list i j)) 
+ => '((0. 0) (0.2 1) (0.4 2) (0.6 3) (0.8 4)) )
+
+(my-check 
+ (list-ec (:char-range c (index i) #\a #\c) (list c i)) 
+ => '((#\a 0) (#\b 1) (#\c 2)) )
+
+(my-check 
+ (list-ec (: x (index i) '(a b c d)) (list x i))
+ => '((a 0) (b 1) (c 2) (d 3)) )
+
+(my-check 
+ (begin
+   (let ((f (my-open-output-file "tmp1")))
+     (do-ec (:range n 10) (begin (write n f) (newline f)))
+     (close-output-port f))
+   (my-call-with-input-file "tmp1"
+     (lambda (port) (list-ec (: x (index i) port) (list x i))) ))
+ => '((0 0) (1 1) (2 2) (3 3) (4 4) (5 5) (6 6) (7 7) (8 8) (9 9)) )
+
+
+; ==========================================================================
+; The examples from the SRFI document
+; ==========================================================================
+
+; from Abstract
+
+(my-check (list-ec (: i 5) (* i i)) => '(0 1 4 9 16))
+
+(my-check 
+  (list-ec (: n 1 4) (: i n) (list n i)) 
+  => '((1 0) (2 0) (2 1) (3 0) (3 1) (3 2)) )
+
+; from Generators
+
+(my-check 
+  (list-ec (: x (index i) "abc") (list x i)) 
+  => '((#\a 0) (#\b 1) (#\c 2)) )
+
+(my-check
+  (list-ec (:string c (index i) "a" "b") (cons c i))
+  => '((#\a . 0) (#\b . 1)) )
+
+
+; ==========================================================================
+; Little Shop of Horrors
+; ==========================================================================
+
+(my-check (list-ec (:range x 5) (:range x x) x) => '(0 0 1 0 1 2 0 1 2 3))
+
+(my-check (list-ec (:list x '(2 "23" (4))) (: y x) y) => '(0 1 #\2 #\3 4))
+
+(my-check 
+ (list-ec (:parallel (:integers x) 
+                     (:do ((i 10)) (< x i) ((- i 1))))
+          (list x i))
+ => '((0 10) (1 9) (2 8) (3 7) (4 6)) )
+
+
+; ==========================================================================
+; Less artificial examples
+; ==========================================================================
+
+(define (factorial n) ; n * (n-1) * .. * 1 for n >= 0
+  (product-ec (:range k 2 (+ n 1)) k) )
+
+(my-check (factorial  0) => 1)
+(my-check (factorial  1) => 1)
+(my-check (factorial  3) => 6)
+(my-check (factorial  5) => 120)
+
+
+(define (eratosthenes n) ; primes in {2..n-1} for n >= 1
+  (let ((p? (make-string n #\1)))
+    (do-ec (:range k 2 n)
+           (if (char=? (string-ref p? k) #\1))
+           (:range i (* 2 k) n k)
+           (string-set! p? i #\0) )
+    (list-ec (:range k 2 n) (if (char=? (string-ref p? k) #\1)) k) ))
+
+(my-check 
+ (eratosthenes 50)
+ => '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47) )
+
+(my-check
+ (length (eratosthenes 100000))
+ => 9592 ) ; we expect 10^5/ln(10^5)
+
+
+(define (pythagoras n) ; a, b, c s.t. 1 <= a <= b <= c <= n, a^2 + b^2 = c^2
+  (list-ec 
+   (:let sqr-n (* n n))
+   (:range a 1 (+ n 1))
+; (begin (display a) (display " "))
+   (:let sqr-a (* a a))
+   (:range b a (+ n 1)) 
+   (:let sqr-c (+ sqr-a (* b b)))
+   (if (<= sqr-c sqr-n))
+   (:range c b (+ n 1))
+   (if (= (* c c) sqr-c))
+   (list a b c) ))
+           
+(my-check
+ (pythagoras 15)
+ => '((3 4 5) (5 12 13) (6 8 10) (9 12 15)) )
+
+(my-check
+ (length (pythagoras 200))
+ => 127 )
+
+
+(define (qsort xs) ; stable
+  (if (null? xs)
+      '()
+      (let ((pivot (car xs)) (xrest (cdr xs)))
+        (append
+         (qsort (list-ec (:list x xrest) (if (<  x pivot)) x))
+         (list pivot)
+         (qsort (list-ec (:list x xrest) (if (>= x pivot)) x)) ))))
+
+(my-check 
+ (qsort '(1 5 4 2 4 5 3 2 1 3))
+ => '(1 1 2 2 3 3 4 4 5 5) )
+
+
+(define (pi-BBP m) ; approx. of pi within 16^-m (Bailey-Borwein-Plouffe)
+  (sum-ec 
+    (:range n 0 (+ m 1))
+    (:let n8 (* 8 n))
+    (* (- (/ 4 (+ n8 1))
+          (+ (/ 2 (+ n8 4))
+             (/ 1 (+ n8 5))
+             (/ 1 (+ n8 6))))
+       (/ 1 (expt 16 n)) )))
+
+(my-check
+ (pi-BBP 5)
+ => (/ 40413742330349316707 12864093722915635200) )
+
+
+(define (my-read-line port) ; next line (incl. #\newline) of port
+  (let ((line
+         (string-ec 
+          (:until (:port c port read-char)
+                  (char=? c #\newline) )
+          c )))
+    (if (string=? line "")
+        (read-char port) ; eof-object
+        line )))
+
+(define (my-read-lines filename) ; list of all lines
+  (my-call-with-input-file 
+   filename
+   (lambda (port)
+     (list-ec (:port line port my-read-line) line) )))
+
+(my-check
+ (begin
+   (let ((f (my-open-output-file "tmp1")))
+     (do-ec (:range n 10) (begin (write n f) (newline f)))
+     (close-output-port f))
+   (my-read-lines "tmp1") )
+ => (list-ec (:char-range c #\0 #\9) (string c #\newline)) )
+
+
+; ==========================================================================
+; Summary
+; ==========================================================================
+
+(begin
+  (newline)
+  (newline)
+  (display "correct examples : ")
+  (display my-check-correct)
+  (newline)
+  (display "wrong examples   : ")
+  (display my-check-wrong)
+  (newline)
+  (newline) )
+
+; examples.scm ends here ---------------------------------------------------
+) ; end module
diff --git a/collects/srfi/43.ss b/collects/srfi/43.ss
new file mode 100644
index 0000000000..82e545e82f
--- /dev/null
+++ b/collects/srfi/43.ss
@@ -0,0 +1,8 @@
+;; module loader for SRFI-43
+(module |43| mzscheme
+  (require (lib "vector-lib.ss" "srfi" "43"))
+  (provide (all-from-except (lib "vector-lib.ss" "srfi" "43")
+                            s:vector-fill!
+                            s:vector->list)
+           (rename s:vector-fill! vector-fill!)
+           (rename s:vector->list vector->list)))
diff --git a/collects/srfi/43/constructors.ss b/collects/srfi/43/constructors.ss
new file mode 100644
index 0000000000..52f4a68556
--- /dev/null
+++ b/collects/srfi/43/constructors.ss
@@ -0,0 +1,218 @@
+;;;
+;;; <constructors.ss> ---- Vector constructors
+;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai>
+;;;
+;;; Copyright (C) 2005 by Zhu Chongkai. 
+;;;
+;;; This file is part of SRFI-43.
+
+;;; SRFI-43 is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2.1 of the License, or (at your option) any later version.
+
+;;; SRFI-43 is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with SRFI-43; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307  USA
+
+;;; Author: Zhu Chongkai <mrmathematica@yahoo.com>
+;;
+;;
+;; Commentary:
+
+;; Based on the reference implementation by Taylor Campbell and hence:
+
+;;; Copyright (C) 2003, 2004 Taylor Campbell.
+;;; All rights reserved.
+;;;
+;;; You may do as you please with this code, as long as you refrain
+;;; from removing this copyright notice or holding me liable in _any_
+;;; circumstances for _any_ damages that may be caused by it; and you
+;;; may quote sections from it as you please, as long as you credit me.
+
+
+(module constructors mzscheme
+  
+  (require (lib "receive.ss" "srfi" "8")
+           "util.ss"
+           (lib "etc.ss" "mzlib"))
+  
+  (provide vector-unfold
+           vector-unfold-right
+           vector-copy
+           vector-reverse-copy
+           vector-append
+           vector-concatenate)
+  
+  ;;; (VECTOR-UNFOLD <f> <length> <initial-seed> ...) -> vector
+  ;;;     (F <index> <seed> ...) -> [elt seed' ...]
+  ;;;   The fundamental vector constructor.  Creates a vector whose
+  ;;;   length is LENGTH and iterates across each index K between 0 and
+  ;;;   LENGTH, applying F at each iteration to the current index and the
+  ;;;   current seeds to receive N+1 values: first, the element to put in
+  ;;;   the Kth slot and then N new seeds for the next iteration.
+  (define vector-unfold
+    (letrec ((tabulate!                   ; Special zero-seed case.
+              (lambda (f vec i len)
+                (cond ((< i len)
+                       (vector-set! vec i (f i))
+                       (tabulate! f vec (add1 i) len)))))
+             (unfold1!                    ; Fast path for one seed.
+              (lambda (f vec i len seed)
+                (if (< i len)
+                    (receive (elt new-seed)
+                             (f i seed)
+                             (vector-set! vec i elt)
+                             (unfold1! f vec (add1 i) len new-seed)))))
+             (unfold2+!                   ; Slower variant for N seeds.
+              (lambda (f vec i len seeds)
+                (if (< i len)
+                    (receive (elt . new-seeds)
+                             (apply f i seeds)
+                             (vector-set! vec i elt)
+                             (unfold2+! f vec (add1 i) len new-seeds))))))
+      (lambda (f len . initial-seeds)
+        (unless (procedure? f)
+          (apply raise-type-error
+                 'vector-unfold "procedure" 0
+                 f len initial-seeds))
+        (unless (nonneg-int? len)
+          (apply raise-type-error
+                 'vector-unfold "non-negative exact integer" 1
+                 f len initial-seeds))
+        (let ((vec (make-vector len)))
+          (cond ((null? initial-seeds)
+                 (tabulate! f vec 0 len))
+                ((null? (cdr initial-seeds))
+                 (unfold1! f vec 0 len (car initial-seeds)))
+                (else
+                 (unfold2+! f vec 0 len initial-seeds)))
+          vec))))
+  
+  ;;; (VECTOR-UNFOLD-RIGHT <f> <length> <initial-seed> ...) -> vector
+  ;;;     (F <seed> ...) -> [seed' ...]
+  ;;;   Like VECTOR-UNFOLD, but it generates elements from LENGTH to 0
+  ;;;   (still exclusive with  LENGTH and inclusive with 0), not 0 to
+  ;;;   LENGTH as with VECTOR-UNFOLD.
+  (define vector-unfold-right
+    (letrec ((tabulate!
+              (lambda (f vec i)
+                (cond ((>= i 0)
+                       (vector-set! vec i (f i))
+                       (tabulate! f vec (sub1 i))))))
+             (unfold2+!
+              (lambda (f vec i seeds)
+                (if (>= i 0)
+                    (receive (elt . new-seeds)
+                             (apply f i seeds)
+                             (vector-set! vec i elt)
+                             (unfold2+! f vec (sub1 i) new-seeds))))))
+      (lambda (f len . initial-seeds)
+        (unless (procedure? f)
+          (apply raise-type-error
+                 'vector-unfold-right "procedure" 0
+                 f len initial-seeds))
+        (unless (nonneg-int? len)
+          (apply raise-type-error
+                 'vector-unfold-right "non-negative exact integer" 1
+                 f len initial-seeds))
+        (let ((vec (make-vector len))
+              (i (sub1 len)))
+          (cond ((null? initial-seeds)
+                 (tabulate! f vec i))
+                ((null? (cdr initial-seeds))
+                 (unfold1!  f vec i (car initial-seeds)))
+                (else
+                 (unfold2+! f vec i initial-seeds)))
+          vec))))
+  
+  ;;; (VECTOR-COPY <vector> [<start> <end> <fill>]) -> vector
+  ;;;   Create a newly allocated vector containing the elements from the
+  ;;;   range [START,END) in VECTOR.  START defaults to 0; END defaults
+  ;;;   to the length of VECTOR.  END may be greater than the length of
+  ;;;   VECTOR, in which case the vector is enlarged; if FILL is passed,
+  ;;;   the new locations from which there is no respective element in
+  ;;;   VECTOR are filled with FILL.
+  (define (vector-copy vec . arg)
+    (unless (vector? vec)
+      (raise-type-error 'vector-copy "vector" vec))
+    (apply
+     (opt-lambda (vec (start 0) (end (vector-length vec)) . fill)
+       (check-start vec start 'vector-copy)
+       (unless (nonneg-int? end)
+         (raise-type-error 'vector-copy "non-negative exact integer" end))
+       (unless (<= start end)
+         (raise
+          (make-exn:fail:contract
+           (string->immutable-string
+            (format "~a: indices (~a, ~a) out of range for vector: ~a"
+                    'vector-copy start end vec))
+           (current-continuation-marks))))
+       (let ((new-vector
+              (apply make-vector (cons (- end start) fill))))
+         (%vector-copy! new-vector 0
+                        vec        start
+                        (min end (vector-length vec)))
+         new-vector))
+     vec arg))
+  
+  ;;; (VECTOR-REVERSE-COPY <vector> [<start> <end>]) -> vector
+  ;;;   Create a newly allocated vector whose elements are the reversed
+  ;;;   sequence of elements between START and END in VECTOR.  START's
+  ;;;   default is 0; END's default is the length of VECTOR.
+  (define (vector-reverse-copy vec . arg)
+    (unless (vector? vec)
+      (raise-type-error 'vector-reverse-copy "vector" vec))
+    (apply
+     (opt-lambda (vec (start 0) (end (vector-length vec)))
+       (check-indices vec start end 'vector-reverse-copy)
+       (let ((new (make-vector (- end start))))
+         (%vector-reverse-copy! new 0 vec start end)
+         new))
+     vec arg))
+  
+  ;;; (VECTOR-APPEND <vector> ...) -> vector
+  ;;;   Append VECTOR ... into a newly allocated vector and return that
+  ;;;   new vector.
+  (define (vector-append . vectors)
+    (check-list-of-vecs vectors 'vector-append)
+    (vector-concatenate:aux vectors))
+  
+  ;;; (VECTOR-CONCATENATE <vector-list>) -> vector
+  ;;;   Concatenate the vectors in VECTOR-LIST.  This is equivalent to
+  ;;;     (apply vector-append VECTOR-LIST)
+  ;;; Actually, they're both implemented in terms of an internal routine.
+  (define (vector-concatenate vector-list)
+    (unless (and (list? vector-list)
+                 (andmap vector? vector-list))
+      (raise-type-error 'vector-concatenate "list of vectors" vector-list))
+    (vector-concatenate:aux vector-list))
+  
+  ;;; Auxiliary for VECTOR-APPEND and VECTOR-CONCATENATE
+  (define vector-concatenate:aux
+    (letrec ((compute-length
+              (lambda (vectors len)
+                (if (null? vectors)
+                    len
+                    (let ((vec (car vectors)))
+                      (compute-length (cdr vectors)
+                                      (+ (vector-length vec) len))))))
+             (concatenate!
+              (lambda (vectors target to)
+                (if (null? vectors)
+                    target
+                    (let* ((vec1 (car vectors))
+                           (len (vector-length vec1)))
+                      (%vector-copy! target to vec1 0 len)
+                      (concatenate! (cdr vectors) target
+                                    (+ to len)))))))
+      (lambda (vectors)
+        (let ((new-vector
+               (make-vector (compute-length vectors 0))))
+          (concatenate! vectors new-vector 0)
+          new-vector)))))
diff --git a/collects/srfi/43/conversion.ss b/collects/srfi/43/conversion.ss
new file mode 100644
index 0000000000..0a020c8271
--- /dev/null
+++ b/collects/srfi/43/conversion.ss
@@ -0,0 +1,101 @@
+;;;
+;;; <conversion.ss> ---- Vector conversion
+;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai>
+;;;
+;;; Copyright (C) 2005 by Zhu Chongkai. 
+;;;
+;;; This file is part of SRFI-43.
+
+;;; SRFI-43 is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2.1 of the License, or (at your option) any later version.
+
+;;; SRFI-43 is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with SRFI-43; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307  USA
+
+;;; Author: Zhu Chongkai <mrmathematica@yahoo.com>
+;;
+;;
+;; Commentary:
+
+;; Based on the reference implementation by Taylor Campbell and hence:
+
+;;; Copyright (C) 2003, 2004 Taylor Campbell.
+;;; All rights reserved.
+;;;
+;;; You may do as you please with this code, as long as you refrain
+;;; from removing this copyright notice or holding me liable in _any_
+;;; circumstances for _any_ damages that may be caused by it; and you
+;;; may quote sections from it as you please, as long as you credit me.
+
+(module conversion mzscheme
+  
+  (require "util.ss"
+           (lib "etc.ss"))
+  
+  (provide (rename my-vector->list vector->list)
+           reverse-vector->list
+           reverse-list->vector)
+  
+  ;;; (VECTOR->LIST <vector> [<start> <end>]) -> list
+  ;;;   [R5RS+] Produce a list containing the elements in the locations
+  ;;;   between START, whose default is 0, and END, whose default is the
+  ;;;   length of VECTOR, from VECTOR.
+  (define (my-vector->list vec . maybe-start+end)
+    (unless (vector? vec)
+      (apply raise-type-error
+             'vector->list "vector" 0
+             vec maybe-start+end))
+    (if (null? maybe-start+end)
+        (vector->list vec)           ;+++
+        (apply (opt-lambda (vec (start 0) (end (vector-length vec)))
+                 (check-indices vec start end 'vector->list)
+                 ;(unfold (lambda (i)        ; No SRFI 1.
+                 ;          (< i start))
+                 ;        (lambda (i) (vector-ref vec i))
+                 ;        (lambda (i) (sub1 i))
+                 ;        (sub1 end))
+                 (do ((i (sub1 end) (sub1 i))
+                      (result '() (cons (vector-ref vec i) result)))
+                   ((< i start) result)))
+               vec maybe-start+end)))
+  
+  ;;; (REVERSE-VECTOR->LIST <vector> [<start> <end>]) -> list
+  ;;;   Produce a list containing the elements in the locations between
+  ;;;   START, whose default is 0, and END, whose default is the length
+  ;;;   of VECTOR, from VECTOR, in reverse order.
+  (define (reverse-vector->list vec . maybe-start+end)
+    (unless (vector? vec)
+      (apply raise-type-error
+             'reverse-vector->list "vector" 0
+             vec maybe-start+end))
+    (apply (opt-lambda (vec (start 0) (end (vector-length vec)))
+             (check-indices vec start end 'reverse-vector->list)
+             ;(unfold (lambda (i) (= i end))     ; No SRFI 1.
+             ;        (lambda (i) (vector-ref vec i))
+             ;        (lambda (i) (add1 i))
+             ;        start)
+             (do ((i start (add1 i))
+                  (result '() (cons (vector-ref vec i) result)))
+               ((= i end) result)))
+           vec maybe-start+end))
+  
+  ;;; (REVERSE-LIST->VECTOR <list> -> vector
+  ;;;   Produce a vector containing the elements in LIST in reverse order.
+  (define (reverse-list->vector lst)
+    (unless (list? lst)
+      (raise-type-error 'reverse-list->vector "proper list" lst))
+    (let* ((len (length lst))
+           (vec (make-vector len)))
+      (unfold1! (lambda (index l) (values (car l) (cdr l)))
+                vec
+                (sub1 len)
+                lst)
+      vec)))
diff --git a/collects/srfi/43/iteration.ss b/collects/srfi/43/iteration.ss
new file mode 100644
index 0000000000..1f475bf3cc
--- /dev/null
+++ b/collects/srfi/43/iteration.ss
@@ -0,0 +1,278 @@
+;;;
+;;; <iteration.ss> ---- Vector iteration
+;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai>
+;;;
+;;; Copyright (C) 2005 by Zhu Chongkai. 
+;;;
+;;; This file is part of SRFI-43.
+
+;;; SRFI-43 is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2.1 of the License, or (at your option) any later version.
+
+;;; SRFI-43 is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with SRFI-43; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307  USA
+
+;;; Author: Zhu Chongkai <mrmathematica@yahoo.com>
+;;
+;;
+;; Commentary:
+
+;; Based on the reference implementation by Taylor Campbell and hence:
+
+;;; Copyright (C) 2003, 2004 Taylor Campbell.
+;;; All rights reserved.
+;;;
+;;; You may do as you please with this code, as long as you refrain
+;;; from removing this copyright notice or holding me liable in _any_
+;;; circumstances for _any_ damages that may be caused by it; and you
+;;; may quote sections from it as you please, as long as you credit me.
+
+(module iteration mzscheme
+  
+  (require "util.ss")
+  
+  (provide vector-fold
+           vector-fold-right
+           vector-map
+           vector-map!
+           vector-for-each
+           vector-count)
+  
+  ;;; (VECTOR-FOLD <kons> <initial-knil> <vector> ...) -> knil
+  ;;;     (KONS <knil> <elt> ...) -> knil' ; N vectors -> N+1 args
+  ;;;   The fundamental vector iterator.  KONS is iterated over each
+  ;;;   index in all of the vectors in parallel, stopping at the end of
+  ;;;   the shortest; KONS is applied to an argument list of (list I
+  ;;;   STATE (vector-ref VEC I) ...), where STATE is the current state
+  ;;;   value -- the state value begins with KNIL and becomes whatever
+  ;;;   KONS returned at the respective iteration --, and I is the
+  ;;;   current index in the iteration.  The iteration is strictly left-
+  ;;;   to-right.
+  ;;;     (vector-fold KONS KNIL (vector E_1 E_2 ... E_N))
+  ;;;       <=>
+  ;;;     (KONS (... (KONS (KONS KNIL E_1) E_2) ... E_N-1) E_N)
+  (define (vector-fold kons knil vec . vectors)
+    (unless (procedure? kons)
+      (apply raise-type-error
+             'vector-fold "procedure" 0
+             kons knil vec vectors))
+    (unless (vector? vec)
+      (apply raise-type-error
+             'vector-fold "vector" 2
+             kons knil vec vectors))
+    (if (null? vectors)
+        (%vector-fold1 kons knil (vector-length vec) vec)
+        (begin (check-list-of-vecs vectors 'vector-fold 3
+                                   (list* kons knil vec vectors))
+               (%vector-fold2+ kons knil
+                               (%smallest-length vectors
+                                                 (vector-length vec))
+                               (cons vec vectors)))))
+  
+  (define %vector-fold1
+    (letrec ((loop (lambda (kons knil len vec i)
+                     (if (= i len)
+                         knil
+                         (loop kons
+                               (kons i knil (vector-ref vec i))
+                               len vec (add1 i))))))
+      (lambda (kons knil len vec)
+        (loop kons knil len vec 0))))
+  (define %vector-fold2+
+    (letrec ((loop (lambda (kons knil len vectors i)
+                     (if (= i len)
+                         knil
+                         (loop kons
+                               (apply kons i knil
+                                      (vectors-ref vectors i))
+                               len vectors (add1 i))))))
+      (lambda (kons knil len vectors)
+        (loop kons knil len vectors 0))))
+  
+  ;;; (VECTOR-COUNT <predicate?> <vector> ...)
+  ;;;       -> exact, nonnegative integer
+  ;;;     (PREDICATE? <index> <value> ...) ; N vectors -> N+1 args
+  ;;;   PREDICATE? is applied element-wise to the elements of VECTOR ...,
+  ;;;   and a count is tallied of the number of elements for which a
+  ;;;   true value is produced by PREDICATE?.  This count is returned.
+  (define (vector-count pred? vec . vectors)
+    (unless (procedure? pred?)
+      (apply raise-type-error
+             'vector-count "procedure" 0
+             pred? vec vectors))
+    (if (null? vectors)
+        (%vector-fold1 (lambda (index count elt)
+                         (if (pred? index elt)
+                             (add1 count)
+                             count))
+                       0
+                       (vector-length vec)
+                       vec)
+        (begin (check-list-of-vecs vectors 'vector-count 2
+                                   (list* pred? vec vectors))
+               (%vector-fold2+ (lambda (index count . elts)
+                                 (if (apply pred? index elts)
+                                     (add1 count)
+                                     count))
+                               0
+                               (%smallest-length vectors
+                                                 (vector-length vec))
+                               (cons vec vectors)))))
+  
+  ;;; (VECTOR-FOLD-RIGHT <kons> <initial-knil> <vector> ...) -> knil
+  ;;;     (KONS <knil> <elt> ...) -> knil' ; N vectors => N+1 args
+  ;;;   The fundamental vector recursor.  Iterates in parallel across
+  ;;;   VECTOR ... right to left, applying KONS to the elements and the
+  ;;;   current state value; the state value becomes what KONS returns
+  ;;;   at each next iteration.  KNIL is the initial state value.
+  ;;;     (vector-fold-right KONS KNIL (vector E_1 E_2 ... E_N))
+  ;;;       <=>
+  ;;;     (KONS (... (KONS (KONS KNIL E_N) E_N-1) ... E_2) E_1)
+  ;;;
+  ;;; Not implemented in terms of a more primitive operations that might
+  ;;; called %VECTOR-FOLD-RIGHT due to the fact that it wouldn't be very
+  ;;; useful elsewhere.
+  (define vector-fold-right
+    (letrec ((loop1 (lambda (kons knil vec i)
+                      (if (zero? i)
+                          knil
+                          (let ((j (sub1 i)))
+                            (loop1 kons
+                                   (kons j knil (vector-ref vec j))
+                                   vec
+                                   j)))))
+             (loop2+ (lambda (kons knil vectors i)
+                       (if (zero? i)
+                           knil
+                           (let ((j (sub1 i)))
+                             (loop2+ kons
+                                     (apply kons j knil
+                                            (vectors-ref vectors j))
+                                     vectors
+                                     j))))))
+      (lambda (kons knil vec . vectors)
+        (unless (procedure? kons)
+          (apply raise-type-error
+                 'vector-fold-right "procedure" 0
+                 kons knil vec vectors))
+        (unless (vector? vec)
+          (apply raise-type-error
+                 'vector-fold-right "vector" 2
+                 kons knil vec vectors))
+        (if (null? vectors)
+            (loop1 kons knil vec (vector-length vec))
+            (begin (check-list-of-vecs vectors 'vector-fold-right 3
+                                       (list* kons knil vec vectors))
+                   (loop2+ kons knil (cons vec vectors)
+                           (%smallest-length vectors
+                                             (vector-length vec))))))))
+  
+  ;;; (VECTOR-MAP <f> <vector> ...) -> vector
+  ;;;     (F <elt> ...) -> value ; N vectors -> N args
+  ;;;   Constructs a new vector of the shortest length of the vector
+  ;;;   arguments.  Each element at index I of the new vector is mapped
+  ;;;   from the old vectors by (F I (vector-ref VECTOR I) ...).  The
+  ;;;   dynamic order of application of F is unspecified.
+  (define (vector-map f vec . vectors)
+    (unless (procedure? f)
+      (apply raise-type-error
+             'vector-map "procedure" 0
+             f vec vectors))
+    (unless (vector? vec)
+      (apply raise-type-error
+             'vector-map "vector" 1
+             f vec vectors))
+    (if (null? vectors)
+        (let ((len (vector-length vec)))
+          (%vector-map1! f (make-vector len) vec len))
+        (begin (check-list-of-vecs vectors 'vector-map 2
+                                   (list* f vec vectors))
+               (let ((len (%smallest-length vectors
+                                            (vector-length vec))))
+                 (%vector-map2+! f (make-vector len)
+                                 (cons vec vectors) len)))))
+  
+  ;;; (%VECTOR-MAP1! <f> <target> <length> <vector>)
+  ;;;     (F <index> <elt>) -> elt'
+  (define (%vector-map1! f target vec i)
+    (if (zero? i)
+        target
+        (let ((j (sub1 i)))
+          (vector-set! target j
+                       (f j (vector-ref vec j)))
+          (%vector-map1! f target vec j))))
+  (define (%vector-map2+! f target vectors i)
+    (if (zero? i)
+        target
+        (let ((j (sub1 i)))
+          (vector-set! target j
+                       (apply f j (vectors-ref vectors j)))
+          (%vector-map2+! f target vectors j))))
+  
+  ;;; (VECTOR-MAP! <f> <vector> ...) -> vector
+  ;;;     (F <elt> ...) -> element' ; N vectors -> N args
+  ;;;   Similar to VECTOR-MAP, but rather than mapping the new elements
+  ;;;   into a new vector, the new mapped elements are destructively
+  ;;;   inserted into the first vector.  Again, the dynamic order of
+  ;;;   application of F is unspecified, so it is dangerous for F to
+  ;;;   manipulate the first VECTOR.
+  (define (vector-map! f vec . vectors)
+    (unless (procedure? f)
+      (apply raise-type-error
+             'vector-map! "procedure" 0
+             f vec vectors))
+    (unless (vector? vec)
+      (apply raise-type-error
+             'vector-map! "vector" 1
+             f vec vectors))
+    (if (null? vectors)
+        (%vector-map1! f vec vec (vector-length vec))
+        (begin (check-list-of-vecs vectors 'vector-map! 2
+                                   (list* f vec vectors))
+               (%vector-map2+! f vec (cons vec vectors)
+                               (%smallest-length vectors
+                                                 (vector-length vec))))))
+  
+  ;;; (VECTOR-FOR-EACH <f> <vector> ...) -> void
+  ;;;     (F <elt> ...) ; N vectors -> N args
+  ;;;   Simple vector iterator: applies F to each index in the range [0,
+  ;;;   LENGTH), where LENGTH is the length of the smallest vector
+  ;;;   argument passed, and the respective element at that index.  In
+  ;;;   contrast with VECTOR-MAP, F is reliably applied to each
+  ;;;   subsequent elements, starting at index 0 from left to right, in
+  ;;;   the vectors.
+  (define vector-for-each
+    (letrec ((for-each1
+              (lambda (f vec i len)
+                (when (< i len)
+                  (f i (vector-ref vec i))
+                  (for-each1 f vec (add1 i) len))))
+             (for-each2+
+              (lambda (f vecs i len)
+                (when (< i len)
+                  (apply f i (vectors-ref vecs i))
+                  (for-each2+ f vecs (add1 i) len)))))
+      (lambda (f vec . vectors)
+        (unless (procedure? f)
+          (apply raise-type-error
+                 'vector-for-each "procedure" 0
+                 f vec vectors))
+        (unless (vector? vec)
+          (apply raise-type-error
+                 'vector-for-each "vector" 1
+                 f vec vectors))
+        (if (null? vectors)
+            (for-each1 f vec 0 (vector-length vec))
+            (begin (check-list-of-vecs vectors 'vector-for-each 2
+                                       (list* f vec vectors))
+                   (for-each2+ f (cons vec vectors) 0
+                               (%smallest-length vectors
+                                                 (vector-length vec)))))))))
diff --git a/collects/srfi/43/mutators.ss b/collects/srfi/43/mutators.ss
new file mode 100644
index 0000000000..a9957c27f6
--- /dev/null
+++ b/collects/srfi/43/mutators.ss
@@ -0,0 +1,171 @@
+;;;
+;;; <mutators.ss> ---- Vector mutators
+;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai>
+;;;
+;;; Copyright (C) 2005 by Zhu Chongkai. 
+;;;
+;;; This file is part of SRFI-43.
+
+;;; SRFI-43 is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2.1 of the License, or (at your option) any later version.
+
+;;; SRFI-43 is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with SRFI-43; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307  USA
+
+;;; Author: Zhu Chongkai <mrmathematica@yahoo.com>
+;;
+;;
+;; Commentary:
+
+;; Based on the reference implementation by Taylor Campbell and hence:
+
+;;; Copyright (C) 2003, 2004 Taylor Campbell.
+;;; All rights reserved.
+;;;
+;;; You may do as you please with this code, as long as you refrain
+;;; from removing this copyright notice or holding me liable in _any_
+;;; circumstances for _any_ damages that may be caused by it; and you
+;;; may quote sections from it as you please, as long as you credit me.
+
+(module mutators mzscheme
+  
+  (require "util.ss"
+           (lib "etc.ss"))
+  
+  (provide vector-swap!
+           (rename my-vector-fill! vector-fill!)
+           vector-reverse!
+           vector-copy!
+           vector-reverse-copy!)
+  
+  ;;; (VECTOR-SWAP! <vector> <index1> <index2>) -> void
+  ;;;   Swap the values in the locations at INDEX1 and INDEX2.
+  (define (vector-swap! vec i j)
+    (unless (vector? vec)
+      (raise-type-error 'vector-swap! "vector" 0
+                        vec i j))
+    (check-index vec i 'vector-swap!)
+    (check-index vec j 'vector-swap!)
+    (%vector-swap! vec i j))
+  
+  (define (%vector-swap! vec i j)
+    (let ((x (vector-ref vec i)))
+      (vector-set! vec i (vector-ref vec j))
+      (vector-set! vec j x)))
+  
+  ;;; (VECTOR-FILL! <vector> <value> [<start> <end>]) -> <vector>
+  ;;;   [R5RS+] Fill the locations in VECTOR between START, whose default
+  ;;;   is 0, and END, whose default is the length of VECTOR, with VALUE.
+  ;;;
+  ;;; This one can probably be made really fast natively.
+  (define (my-vector-fill! vec value . maybe-start+end)
+    (cond ((null? maybe-start+end)
+           (vector-fill! vec value))     ;+++
+          ((not (vector? vec))
+           (apply raise-type-error
+                  'vector-fill! "vector" 0
+                  vec value maybe-start+end))
+          (else
+           (apply (opt-lambda (vec value (start 0) (end (vector-length vec)))
+                    (check-indices vec start end 'vector-fill!)
+                    (do ((i start (add1 i)))
+                      ((= i end))
+                      (vector-set! vec i value))
+                    vec)
+                  vec value maybe-start+end))))
+  
+  (define %vector-reverse!
+    (letrec ((loop (lambda (vec i j)
+                     (when (< i j)
+                       (%vector-swap! vec i j)
+                       (loop vec (add1 i) (sub1 j))))))
+      (lambda (vec start end)
+        (loop vec start (sub1 end)))))
+  
+  ;;; (VECTOR-REVERSE! <vector> [<start> <end>]) -> void
+  ;;;   Destructively reverse the contents of the sequence of locations
+  ;;;   in VECTOR between START, whose default is 0, and END, whose
+  ;;;   default is the length of VECTOR.
+  (define (vector-reverse! vec . maybe-start+end)
+    (unless (vector? vec)
+      (apply raise-type-error
+             'vector-reverse! "vector" 0
+             vec maybe-start+end))
+    (apply (opt-lambda (vec (start 0) (end (vector-length vec)))
+             (check-indices vec start end 'vector-reverse!)
+             (%vector-reverse! vec start end))
+           vec maybe-start+end))
+  
+  ;;; (VECTOR-COPY! <target> <tstart> <source> [<sstart> <send>])
+  ;;;       -> unspecified
+  ;;;   Copy the values in the locations in [SSTART,SEND) from SOURCE to
+  ;;;   to TARGET, starting at TSTART in TARGET.
+  (define (vector-copy! target tstart source . maybe-sstart+send)
+    (unless (vector? target)
+      (apply raise-type-error
+             'vector-copy! "vector" 0
+             target tstart source maybe-sstart+send))
+    (check-start target tstart 'vector-copy!)
+    (unless (vector? source)
+      (apply raise-type-error
+             'vector-copy! "vector" 2
+             target tstart source maybe-sstart+send))
+    (apply (opt-lambda (target
+                        tstart
+                        source
+                        (sstart 0)
+                        (send (vector-length source)))
+             (check-indices source sstart send 'vector-copy!)
+             (if (< (- (vector-length target) tstart)
+                    (- send sstart))
+                 (error 'vector-copy!
+                        "target vector not long enough to copy"))
+             (%vector-copy! target tstart source sstart send))
+           target tstart source maybe-sstart+send))
+  
+  ;;; (VECTOR-REVERSE-COPY! <target> <tstart> <source> [<sstart> <send>])
+  (define (vector-reverse-copy! target tstart source . maybe-sstart+send)
+    (unless (vector? target)
+      (apply raise-type-error
+             'vector-reverse-copy! "vector" 0
+             target tstart source maybe-sstart+send))
+    (check-start target tstart 'vector-reverse-copy!)
+    (unless (vector? source)
+      (apply raise-type-error
+             'vector-reverse-copy! "vector" 2
+             target tstart source maybe-sstart+send))
+    (apply (opt-lambda (target
+                        tstart
+                        source
+                        (sstart 0)
+                        (send (vector-length source)))
+             (check-indices source sstart send 'vector-reverse-copy!)
+             (cond ((< (- (vector-length target) tstart)
+                       (- send sstart))
+                    (error 'vector-reverse-copy!
+                           "target vector not long enough to copy"))
+                   ((and (eq? target source)
+                         (= sstart tstart))
+                    (%vector-reverse! target tstart send))
+                   ((and (eq? target source)
+                         (or (between? sstart tstart send)
+                             (between? tstart sstart
+                                       (+ tstart (- send sstart)))))
+                    ;an error in the reference implement here
+                    (error 'vector-reverse-copy!
+                           "Vector range for self-copying overlaps"))
+                   (else
+                    (%vector-reverse-copy! target tstart
+                                           source sstart send))))
+           target tstart source maybe-sstart+send))
+  (define (between? x y z)
+    (and (<  x y)
+         (<= y z))))
\ No newline at end of file
diff --git a/collects/srfi/43/predicates.ss b/collects/srfi/43/predicates.ss
new file mode 100644
index 0000000000..d703cae72c
--- /dev/null
+++ b/collects/srfi/43/predicates.ss
@@ -0,0 +1,103 @@
+;;;
+;;; <predicates.ss> ---- Vector predicates
+;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai>
+;;;
+;;; Copyright (C) 2005 by Zhu Chongkai. 
+;;;
+;;; This file is part of SRFI-43.
+
+;;; SRFI-43 is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2.1 of the License, or (at your option) any later version.
+
+;;; SRFI-43 is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with SRFI-43; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307  USA
+
+;;; Author: Zhu Chongkai <mrmathematica@yahoo.com>
+;;
+;;
+;; Commentary:
+
+;; Based on the reference implementation by Taylor Campbell and hence:
+
+;;; Copyright (C) 2003, 2004 Taylor Campbell.
+;;; All rights reserved.
+;;;
+;;; You may do as you please with this code, as long as you refrain
+;;; from removing this copyright notice or holding me liable in _any_
+;;; circumstances for _any_ damages that may be caused by it; and you
+;;; may quote sections from it as you please, as long as you credit me.
+
+(module predicates mzscheme
+  
+  (require "util.ss")
+  
+  (provide vector-empty?
+           vector=)
+  
+  ;;; (VECTOR-EMPTY? <vector>) -> boolean
+  ;;;   Return #T if VECTOR has zero elements in it, i.e. VECTOR's length
+  ;;;   is 0, and #F if not.
+  (define (vector-empty? vec)
+    (unless (vector? vec)
+      (raise-type-error 'vector-empty? "vector" vec))
+    (zero? (vector-length vec)))
+  
+  ;;; (VECTOR= <elt=?> <vector> ...) -> boolean
+  ;;;     (ELT=? <value> <value>) -> boolean
+  ;;;   Determine vector equality generalized across element comparators.
+  ;;;   Vectors A and B are equal iff their lengths are the same and for
+  ;;;   each respective elements E_a and E_b (element=? E_a E_b) returns
+  ;;;   a true value.  ELT=? is always applied to two arguments.  Element
+  ;;;   comparison must be consistent wtih EQ?; that is, if (eq? E_a E_b)
+  ;;;   results in a true value, then (ELEMENT=? E_a E_b) must result in a
+  ;;;   true value.  This may be exploited to avoid multiple unnecessary
+  ;;;   element comparisons.  (This implementation does, but does not deal
+  ;;;   with the situation that ELEMENT=? is EQ? to avoid more unnecessary
+  ;;;   comparisons, but I believe this optimization is probably fairly
+  ;;;   insignificant.)
+  ;;;   
+  ;;;   If the number of vector arguments is zero or one, then #T is
+  ;;;   automatically returned.  If there are N vector arguments,
+  ;;;   VECTOR_1 VECTOR_2 ... VECTOR_N, then VECTOR_1 & VECTOR_2 are
+  ;;;   compared; if they are equal, the vectors VECTOR_2 ... VECTOR_N
+  ;;;   are compared.  The precise order in which ELT=? is applied is not
+  ;;;   specified.
+  (define (vector= elt=? . vectors)
+    (unless (procedure-arity-includes? elt=? 2)
+      (apply raise-type-error
+             'vector= "procedure of arity 2" 0
+             elt=? vectors))
+    (cond ((null? vectors)
+           #t)
+          ((null? (cdr vectors))
+           (unless (vector? (car vectors))
+             (apply raise-type-error
+                    'vector= "vector" 1
+                    elt=? vectors))
+           #t)
+          (else
+           (check-list-of-vecs vectors 'vector=
+                               1 (cons elt=? vectors))
+           (let loop ((vecs vectors))
+             (let ((vec1 (car vecs))
+                   (vec2+ (cdr vecs)))
+               (or (null? vec2+)
+                   (and (binary-vector= elt=? vec1 (car vec2+))
+                        (loop vec2+))))))))
+  (define (binary-vector= elt=? vector-a vector-b)
+    (or (eq? vector-a vector-b)           ;+++
+        (let ((length-a (vector-length vector-a)))
+          (and (= length-a (vector-length vector-b))
+               (let loop ((i 0))
+                 (or (= i length-a)
+                     (and (elt=? (vector-ref vector-a i)
+                                 (vector-ref vector-b i))
+                          (loop (add1 i))))))))))
\ No newline at end of file
diff --git a/collects/srfi/43/searching.ss b/collects/srfi/43/searching.ss
new file mode 100644
index 0000000000..702c4b07ca
--- /dev/null
+++ b/collects/srfi/43/searching.ss
@@ -0,0 +1,298 @@
+;;;
+;;; <searching.ss> ---- Vector searching
+;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai>
+;;;
+;;; Copyright (C) 2005 by Zhu Chongkai. 
+;;;
+;;; This file is part of SRFI-43.
+
+;;; SRFI-43 is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2.1 of the License, or (at your option) any later version.
+
+;;; SRFI-43 is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with SRFI-43; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307  USA
+
+;;; Author: Zhu Chongkai <mrmathematica@yahoo.com>
+;;
+;;
+;; Commentary:
+
+;; Based on the reference implementation by Taylor Campbell and hence:
+
+;;; Copyright (C) 2003, 2004 Taylor Campbell.
+;;; All rights reserved.
+;;;
+;;; You may do as you please with this code, as long as you refrain
+;;; from removing this copyright notice or holding me liable in _any_
+;;; circumstances for _any_ damages that may be caused by it; and you
+;;; may quote sections from it as you please, as long as you credit me.
+
+(module searching mzscheme
+  
+  (require "util.ss")
+  
+  (provide vector-index
+           vector-index-right
+           vector-skip
+           vector-skip-right
+           vector-binary-search
+           vector-any
+           vector-every)
+  
+  ;; All the functions (except vector-binary-search) here can be 
+  ;; abstracted, but for performance I didn't do so.
+  
+  ;;; (VECTOR-INDEX <predicate?> <vector> ...)
+  ;;;       -> exact, nonnegative integer or #F
+  ;;;     (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args
+  ;;;   Search left-to-right across VECTOR ... in parallel, returning the
+  ;;;   index of the first set of values VALUE ... such that (PREDICATE?
+  ;;;   VALUE ...) returns a true value; if no such set of elements is
+  ;;;   reached, return #F.
+  (define vector-index
+    (letrec ((loop1  (lambda (pred? vec len i)
+                       (cond ((= i len) #f)
+                             ((pred? (vector-ref vec i)) i)
+                             (else (loop1 pred? vec len (add1 i))))))
+             (loop2+ (lambda (pred? vectors len i)
+                       (cond ((= i len) #f)
+                             ((apply pred? (vectors-ref vectors i)) i)
+                             (else (loop2+ pred? vectors len (add1 i)))))))
+      (lambda (pred? vec . vectors)
+        (unless (procedure? pred?)
+          (apply raise-type-error
+                 'vector-index "procedure" 0
+                 pred? vec vectors))
+        (unless (vector? vec)
+          (apply raise-type-error
+                 'vector-index "vector" 1
+                 pred? vec vectors))
+        (if (null? vectors)
+            (loop1 pred? vec (vector-length vec) 0)
+            (begin (check-list-of-vecs vectors 'vector-index 2
+                                       (list* pred? vec vectors))
+                   (loop2+ pred? (cons vec vectors)
+                           (%smallest-length vectors
+                                             (vector-length vec))
+                           0))))))
+  
+  ;;; (VECTOR-SKIP <predicate?> <vector> ...)
+  ;;;       -> exact, nonnegative integer or #F
+  ;;;     (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args
+  ;;;   (vector-index (lambda elts (not (apply PREDICATE? elts)))
+  ;;;                 VECTOR ...)
+  ;;;   Like VECTOR-INDEX, but find the index of the first set of values
+  ;;;   that do _not_ satisfy PREDICATE?.
+  (define vector-skip
+    (letrec ((loop1  (lambda (pred? vec len i)
+                       (cond ((= i len) #f)
+                             ((pred? (vector-ref vec i))
+                              (loop1 pred? vec len (add1 i)))
+                             (else i))))
+             (loop2+ (lambda (pred? vectors len i)
+                       (cond ((= i len) #f)
+                             ((apply pred? (vectors-ref vectors i))
+                              (loop2+ pred? vectors len (add1 i)))
+                             (else i)))))
+      (lambda (pred? vec . vectors)
+        (unless (procedure? pred?)
+          (apply raise-type-error
+                 'vector-skip "procedure" 0
+                 pred? vec vectors))
+        (unless (vector? vec)
+          (apply raise-type-error
+                 'vector-skip "vector" 1
+                 pred? vec vectors))
+        (if (null? vectors)
+            (loop1 pred? vec (vector-length vec) 0)
+            (begin (check-list-of-vecs vectors 'vector-skip 2
+                                       (list* pred? vec vectors))
+                   (loop2+ pred? (cons vec vectors)
+                           (%smallest-length vectors
+                                             (vector-length vec))
+                           0))))))
+  
+  ;;; (VECTOR-INDEX-RIGHT <predicate?> <vector> ...)
+  ;;;       -> exact, nonnegative integer or #F
+  ;;;     (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args
+  ;;;   Right-to-left variant of VECTOR-INDEX.
+  (define vector-index-right
+    (letrec ((loop1  (lambda (pred? vec i)
+                       (if (zero? i)
+                           #f
+                           (let ((i (sub1 i)))
+                             (if (pred? (vector-ref vec i))
+                                 i
+                                 (loop1 pred? vec i))))))
+             (loop2+ (lambda (pred? vectors i)
+                       (if (zero? i)
+                           #f
+                           (let ((i (sub1 i)))
+                             (if (apply pred? (vectors-ref vectors i))
+                                 i
+                                 (loop2+ pred? vectors i)))))))
+      (lambda (pred? vec . vectors)
+        (unless (procedure? pred?)
+          (apply raise-type-error
+                 'vector-index-right "procedure" 0
+                 pred? vec vectors))
+        (unless (vector? vec)
+          (apply raise-type-error
+                 'vector-index-right "vector" 1
+                 pred? vec vectors))
+        (if (null? vectors)
+            (loop1 pred? vec (vector-length vec))
+            (begin (check-list-of-vecs vectors 'vector-index-right 2
+                                       (list* pred? vec vectors))
+                   (loop2+ pred? (cons vec vectors)
+                           (%smallest-length vectors
+                                             (vector-length vec))))))))
+  
+  ;;; (VECTOR-SKIP-RIGHT <predicate?> <vector> ...)
+  ;;;       -> exact, nonnegative integer or #F
+  ;;;     (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args
+  ;;;   Right-to-left variant of VECTOR-SKIP.
+  (define vector-skip-right
+    (letrec ((loop1  (lambda (pred? vec i)
+                       (if (zero? i)
+                           #f
+                           (let ((i (sub1 i)))
+                             (if (pred? (vector-ref vec i))
+                                 (loop1 pred? vec i)
+                                 i)))))
+             (loop2+ (lambda (pred? vectors i)
+                       (if (zero? i)
+                           #f
+                           (let ((i (sub1 i)))
+                             (if (apply pred? (vectors-ref vectors i))
+                                 (loop2+ pred? vectors i)
+                                 i))))))
+      (lambda (pred? vec . vectors)
+        (unless (procedure? pred?)
+          (apply raise-type-error
+                 'vector-skip-right "procedure" 0
+                 pred? vec vectors))
+        (unless (vector? vec)
+          (apply raise-type-error
+                 'vector-skip-right "vector" 1
+                 pred? vec vectors))
+        (if (null? vectors)
+            (loop1 pred? vec (vector-length vec))
+            (begin (check-list-of-vecs vectors 'vector-skip-right 2
+                                       (list* pred? vec vectors))
+                   (loop2+ pred? (cons vec vectors)
+                           (%smallest-length vectors
+                                             (vector-length vec))))))))
+  
+  ;;; (VECTOR-BINARY-SEARCH <vector> <value> <cmp>)
+  ;;;       -> exact, nonnegative integer or #F
+  ;;;     (CMP <value1> <value2>) -> integer
+  ;;;       positive -> VALUE1 > VALUE2
+  ;;;       zero     -> VALUE1 = VALUE2
+  ;;;       negative -> VALUE1 < VALUE2
+  ;;;   Perform a binary search through VECTOR for VALUE, comparing each
+  ;;;   element to VALUE with CMP.
+  (define (vector-binary-search vec value cmp)
+    (unless (vector? vec)
+      (raise-type-error 'vector-binary-search "vector" 0
+                        vec value cmp))
+    (unless (procedure-arity-includes? cmp 2)
+      (raise-type-error 'vector-binary-search "procedure of arity 2" 2
+                        vec value cmp))
+    (let loop ((start 0)
+               (end (vector-length vec))
+               (j -1))
+      (let ((i (quotient (+ start end) 2)))
+        (if (= i j)
+            #f
+            (let ((comparison (cmp (vector-ref vec i) value)))
+              (unless (integer? comparison)
+                (raise-type-error 'vector-binary-search
+                                  "procedure that returns an integer"
+                                  2
+                                  vec value cmp))
+              (cond ((zero?     comparison) i)
+                    ((positive? comparison) (loop start i i))
+                    (else                   (loop i end i))))))))
+  
+  ;;; (VECTOR-ANY <pred?> <vector> ...) -> value
+  ;;;   Apply PRED? to each parallel element in each VECTOR ...; if PRED?
+  ;;;   should ever return a true value, immediately stop and return that
+  ;;;   value; otherwise, when the shortest vector runs out, return #F.
+  ;;;   The iteration and order of application of PRED? across elements
+  ;;;   is of the vectors is strictly left-to-right.
+  (define vector-any
+    (letrec ((loop1 (lambda (pred? vec i len)
+                      (and (not (= i len))
+                           (or (pred? (vector-ref vec i))
+                               (loop1 pred? vec (add1 i) len)))))
+             (loop2+ (lambda (pred? vectors i len)
+                       (and (not (= i len))
+                            (or (apply pred? (vectors-ref vectors i))
+                                (loop2+ pred? vectors (add1 i) len))))))
+      (lambda (pred? vec . vectors)
+        (unless (procedure? pred?)
+          (apply raise-type-error
+                 'vector-any "procedure" 0
+                 pred? vec vectors))
+        (unless (vector? vec)
+          (apply raise-type-error
+                 'vector-any "vector" 1
+                 pred? vec vectors))
+        (if (null? vectors)
+            (loop1 pred? vec 0 (vector-length vec))
+            (begin (check-list-of-vecs vectors 'vector-any 2
+                                       (list* pred? vec vectors))
+                   (loop2+ pred? (cons vec vectors)
+                           0 (%smallest-length vectors
+                                               (vector-length vec))))))))
+  
+  ;;; (VECTOR-EVERY <pred?> <vector> ...) -> value
+  ;;;   Apply PRED? to each parallel value in each VECTOR ...; if PRED?
+  ;;;   should ever return #F, immediately stop and return #F; otherwise,
+  ;;;   if PRED? should return a true value for each element, stopping at
+  ;;;   the end of the shortest vector, return the last value that PRED?
+  ;;;   returned.  In the case that there is an empty vector, return #T.
+  ;;;   The iteration and order of application of PRED? across elements
+  ;;;   is of the vectors is strictly left-to-right.
+  (define vector-every
+    (letrec ((loop1 (lambda (pred? vec i len)
+                      (or (> i len)
+                          (if (= i len)
+                              (pred? (vector-ref vec i))
+                              (and (pred? (vector-ref vec i))
+                                   (loop1 pred? vec (add1 i) len))))))
+             (loop2+ (lambda (pred? vectors i len)
+                       (or (> i len)
+                           (if (= i len)
+                               (apply pred? (vectors-ref vectors i))
+                               (and (apply pred? (vectors-ref vectors i))
+                                    (loop2+ pred? vectors (add1 i) len)))))))
+      (lambda (pred? vec . vectors)
+        (unless (procedure? pred?)
+          (apply raise-type-error
+                 'vector-every "procedure" 0
+                 pred? vec vectors))
+        (unless (vector? vec)
+          (apply raise-type-error
+                 'vector-every "vector" 1
+                 pred? vec vectors))
+        (if (null? vectors)
+            (loop1 pred? vec 0 (sub1 (vector-length vec)))
+            (begin (check-list-of-vecs vectors 'vector-every 2
+                                       (list* pred? vec vectors))
+                   (loop2+ pred?
+                           (cons vec vectors)
+                           0
+                           (sub1
+                            (%smallest-length vectors
+                                              (vector-length vec))))))))))
+
diff --git a/collects/srfi/43/util.ss b/collects/srfi/43/util.ss
new file mode 100644
index 0000000000..7d083b451b
--- /dev/null
+++ b/collects/srfi/43/util.ss
@@ -0,0 +1,162 @@
+;;;
+;;; <util.ss> ---- Utility functions
+;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai>
+;;;
+;;; Copyright (C) 2005 by Zhu Chongkai. 
+;;;
+;;; This file is part of SRFI-43.
+
+;;; SRFI-43 is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2.1 of the License, or (at your option) any later version.
+
+;;; SRFI-43 is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with SRFI-43; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307  USA
+
+;;; Author: Zhu Chongkai <mrmathematica@yahoo.com>
+;;
+;;
+;; Commentary:
+
+;; Based on the reference implementation by Taylor Campbell and hence:
+
+;;; Copyright (C) 2003, 2004 Taylor Campbell.
+;;; All rights reserved.
+;;;
+;;; You may do as you please with this code, as long as you refrain
+;;; from removing this copyright notice or holding me liable in _any_
+;;; circumstances for _any_ damages that may be caused by it; and you
+;;; may quote sections from it as you please, as long as you credit me.
+
+(module util mzscheme
+  
+  (require (lib "etc.ss" "mzlib")
+           (lib "receive.ss" "srfi" "8"))
+  
+  (provide (all-defined))
+  
+  ;;; (CHECK-INDEX <vector> <index> <callee>) -> 
+  ;;;   Ensure that INDEX is a valid index into VECTOR; if not, signal an
+  ;;;   error stating that it is not and that this happened in a call to
+  ;;;   CALLEE.  (Note that this does NOT check that VECTOR is indeed a
+  ;;;   vector.)
+  (define (check-index vec index callee)
+    (unless (nonneg-int? index)
+      (raise-type-error callee "non-negative exact integer" index))
+    (unless (and (<= 0 index)
+                 (< index (vector-length vec)))
+      (raise
+       (make-exn:fail:contract
+        (string->immutable-string
+         (format "~a: index ~a out of range for vector: ~a"
+                 callee index vec))
+        (current-continuation-marks)))))
+  
+  
+  ;;; (CHECK-START <vector> <index> <callee>) -> 
+  ;;;   Ensure that INDEX is a valid bound of VECTOR; if not, signal an
+  ;;;   error stating that it is not and that this happened in a call to
+  ;;;   CALLEE.  (Note that this does NOT check that VECTOR is indeed a
+  ;;;   vector.)
+  (define (check-start vec index callee)
+    (unless (nonneg-int? index)
+      (raise-type-error callee "non-negative exact integer" index))
+    (unless (<= 0 index (vector-length vec))
+      (raise
+       (make-exn:fail:contract
+        (string->immutable-string
+         (format "~a: index ~a out of range for vector: ~a"
+                 callee index vec))
+        (current-continuation-marks)))))
+  
+  ;;; (CHECK-INDICES <vector> <start> <end> <caller>) -> 
+  ;;;   Ensure that START and END are valid bounds of a range within
+  ;;;   VECTOR; if not, signal an error stating that they are not
+  ;;;   while calling CALLEE. 
+  (define (check-indices vec start end callee)
+    (unless (nonneg-int? start)
+      (raise-type-error callee "non-negative exact integer" start))
+    (unless (nonneg-int? end)
+      (raise-type-error callee "non-negative exact integer" end))
+    (unless (<= 0 start end (vector-length vec))
+      (raise
+       (make-exn:fail:contract
+        (string->immutable-string
+         (format "~a: indices (~a, ~a) out of range for vector: ~a"
+                 callee start end vec))
+        (current-continuation-marks)))))
+  
+  (define (nonneg-int? x)
+    (and (integer? x)
+         (exact? x)
+         (not (negative? x))))
+  
+  ;;; (%VECTOR-COPY! <target> <tstart> <source> <sstart> <send>)
+  ;;;   Copy elements at locations SSTART to SEND from SOURCE to TARGET,
+  ;;;   starting at TSTART in TARGET.
+  (define (%vector-copy! target tstart source sstart send)
+    (let loop ((i sstart)
+               (j tstart))
+      (cond ((< i send)
+             (vector-set! target j
+                          (vector-ref source i))
+             (loop (add1 i) (add1 j))))))
+  
+  ;;; (%VECTOR-REVERSE-COPY! <target> <tstart> <source> <sstart> <send>)
+  ;;;   Copy elements from SSTART to SEND from SOURCE to TARGET, in the
+  ;;;   reverse order.
+  (define %vector-reverse-copy!
+    (letrec ((loop (lambda (target source sstart i j)
+                     (cond ((>= i sstart)
+                            (vector-set! target j (vector-ref source i))
+                            (loop target source sstart
+                                  (sub1 i)
+                                  (add1 j)))))))
+      (lambda (target tstart source sstart send)
+        (loop target source sstart
+              (sub1 send)
+              tstart))))
+  
+  ;; type-check : check whether list-of-vecs is list of VECTORs
+  (define check-list-of-vecs
+    (opt-lambda (list-of-vecs caller (n 0) (all-args list-of-vecs))
+      (let loop ((l list-of-vecs)
+                 (i 0))
+        (unless (null? l)
+          (if (vector? (car l))
+              (loop (cdr l) (add1 i))
+              (apply raise-type-error
+                     caller "vector"
+                     (+ n i)
+                     all-args))))))
+  
+  ;;; (%SMALLEST-LENGTH <vector-list> <default-length>)
+  ;;;       -> exact, nonnegative integer
+  ;;;   Compute the smallest length of VECTOR-LIST.  DEFAULT-LENGTH is
+  ;;;   the length that is returned if VECTOR-LIST is empty.  Common use
+  ;;;   of this is in n-ary vector routines:
+  ;;;     (define (f vec . vectors)
+  (define (%smallest-length vector-list length)
+    (if (null? vector-list)
+        length
+        (%smallest-length (cdr vector-list)
+                          (min length
+                               (vector-length (car vector-list))))))
+  
+  (define (vectors-ref vectors i)
+    (map (lambda (v) (vector-ref v i)) vectors))
+  
+  ;;; from vector-unfold-right
+  (define (unfold1! f vec i seed)
+    (if (>= i 0)
+        (receive (elt new-seed)
+                 (f i seed)
+                 (vector-set! vec i elt)
+                 (unfold1! f vec (sub1 i) new-seed)))))
\ No newline at end of file
diff --git a/collects/srfi/43/vector-lib.ss b/collects/srfi/43/vector-lib.ss
new file mode 100644
index 0000000000..09dd42e43a
--- /dev/null
+++ b/collects/srfi/43/vector-lib.ss
@@ -0,0 +1,43 @@
+;;;
+;;; <util.ss> ---- Utility functions
+;;; Time-stamp: <05/03/07 18:21:41 Zhu Chongkai>
+;;;
+;;; Copyright (C) 2005 by Zhu Chongkai. 
+;;;
+;;; This file is part of SRFI-43.
+
+;;; SRFI-43 is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2.1 of the License, or (at your option) any later version.
+
+;;; SRFI-43 is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with SRFI-43; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307  USA
+
+;;; Author: Zhu Chongkai <mrmathematica@yahoo.com>
+;;
+
+(module vector-lib mzscheme
+
+  (require "constructors.ss"
+	   "predicates.ss"
+	   "iteration.ss"
+           "searching.ss"
+	   (all-except "mutators.ss" vector-fill!)
+	   (rename "mutators.ss" s:vector-fill! vector-fill!)
+           (all-except "conversion.ss" vector->list)
+           (rename "conversion.ss" s:vector->list vector->list))
+
+  (provide 
+   (all-from "constructors.ss")
+   (all-from "predicates.ss")
+   (all-from "iteration.ss")
+   (all-from "searching.ss")
+   (all-from "mutators.ss")
+   (all-from "conversion.ss")))
diff --git a/collects/srfi/45.ss b/collects/srfi/45.ss
new file mode 100644
index 0000000000..b02b990840
--- /dev/null
+++ b/collects/srfi/45.ss
@@ -0,0 +1,10 @@
+;; module loader for SRFI-45
+(module |45| mzscheme
+  (require (lib "lazy.ss" "srfi" "45"))
+  (provide (all-from-except (lib "lazy.ss" "srfi" "45")
+                            s:delay
+                            s:force
+                            srfi-45-promise?)
+           (rename s:delay delay)
+           (rename s:force force)
+           (rename srfi-45-promise? promise?)))
diff --git a/collects/srfi/45/.cvsignore b/collects/srfi/45/.cvsignore
new file mode 100644
index 0000000000..e3ca6473f7
--- /dev/null
+++ b/collects/srfi/45/.cvsignore
@@ -0,0 +1 @@
+compiled
diff --git a/collects/srfi/45/lazy.ss b/collects/srfi/45/lazy.ss
new file mode 100644
index 0000000000..2e6bb45cd3
--- /dev/null
+++ b/collects/srfi/45/lazy.ss
@@ -0,0 +1,38 @@
+; SRFI 45
+; Zhu Chongkai   mrmathematica@yahoo.com
+; 25-May-2005
+(module lazy mzscheme
+  
+  (provide lazy
+           eager
+           s:delay
+           s:force
+           srfi-45-promise?)
+  
+  (define-struct srfi-45-promise (content))
+  
+  (define-syntax lazy
+    (syntax-rules ()
+      ((_ exp)
+       (make-srfi-45-promise (cons #f (lambda () exp))))))
+  
+  (define (eager x)
+    (make-srfi-45-promise (cons #t x)))
+  
+  (define-syntax s:delay
+    (syntax-rules ()
+      ((_ exp) (lazy (eager exp)))))
+  
+  (define (s:force promise)
+    (if (srfi-45-promise? promise)
+        (let ((content (srfi-45-promise-content promise)))
+          (if (car content)
+              (cdr content)
+              (let* ((promise* ((cdr content)))
+                     (content (srfi-45-promise-content promise)))
+                (unless (car content)
+                  (set-car! content (car (srfi-45-promise-content promise*)))
+                  (set-cdr! content (cdr (srfi-45-promise-content promise*)))
+                  (set-srfi-45-promise-content! promise* content))
+                (s:force promise))))
+        (raise-type-error 'force "srfi-45-promise" promise))))
diff --git a/collects/srfi/5.ss b/collects/srfi/5.ss
new file mode 100644
index 0000000000..eb0bd18e3f
--- /dev/null
+++ b/collects/srfi/5.ss
@@ -0,0 +1,4 @@
+;; module loader for SRFI-5
+(module |5| mzscheme
+  (require (rename (lib "let.ss" "srfi" "5") my-let let))
+  (provide (rename my-let let)))
diff --git a/collects/srfi/5/.cvsignore b/collects/srfi/5/.cvsignore
new file mode 100644
index 0000000000..e3ca6473f7
--- /dev/null
+++ b/collects/srfi/5/.cvsignore
@@ -0,0 +1 @@
+compiled
diff --git a/collects/srfi/5/let.ss b/collects/srfi/5/let.ss
new file mode 100644
index 0000000000..bb4cd31aeb
--- /dev/null
+++ b/collects/srfi/5/let.ss
@@ -0,0 +1,86 @@
+;;;
+;;; <let.ss> ---- SRFI 5 A compatible let form with signatures and rest arguments
+;;; Time-stamp: <03/04/08 09:56:06 solsona>
+;;;
+;;; Usually, I would add a copyright notice, and the announce that
+;;; this code is under the LGPL licence.  Nevertheless, I only did the
+;;; port to PLT Scheme v200, and here is the copyright notice,
+;;; comments, and licence from the original source:
+;;;
+;;; Copyright (C) Andy Gaynor (1999-2003)
+;;;
+;;; The version of my-let here was cleaned up by: Paul Schlie <schlie@attbi.com>.
+
+(module let mzscheme
+  (provide (rename my-let let))
+
+  (define-syntax my-let
+    (syntax-rules ()
+      ;; standard
+      ((my-let () body ...)
+       (let () body ...))
+      ((my-let ((var val) ...) body ...)
+       (let ((var val) ...) body ...))
+
+      ;; rest style
+      ((my-let ((var val) . bindings) body ...)
+       (let-loop #f bindings (var) (val) (body ...)))
+      
+      ;; signature style
+      ((my-let (name bindings ...) body ...)
+       (let-loop name (bindings ...) () () (body ...)))
+      
+      ;; standard named style
+      ((my-let name (bindings ...) body ...)
+       (let-loop name (bindings ...) () () (body ...)))
+
+      ))
+
+  ;; A loop to walk down the list of bindings.
+
+  (define-syntax let-loop
+    (syntax-rules ()
+
+     ; No more bindings - make a LETREC.
+     ((let-loop name () (vars ...) (vals ...) body)
+      ((letrec ((name (lambda (vars ...) . body)))
+         name)
+       vals ...))
+     
+     ; Rest binding, no name
+     ((let-loop #f (rest-var rest-val ...) (var ...) (val ...) body)
+      (let ((var val) ... (rest-var (list rest-val ...))) . body))
+     
+     ; Process a (var val) pair.
+     ((let-loop name ((var val) more ...) (vars ...)     (vals ...)     body)
+      (let-loop name (more ...)           (vars ... var) (vals ... val) body))
+     
+     ; End with a rest variable - make a LETREC.
+     ((let-loop name (rest-var rest-vals ...) (vars ...) (vals ...) body)
+      ((letrec ((name (lambda (vars ... . rest-var) . body)))
+        name)
+       vals ... rest-vals ...))))
+
+; Four loops - normal and `signature-style', each with and without a rest
+; binding.
+;
+;(let fibonacci ((n 10) (i 0) (f0 0) (f1 1))
+;  (if (= i n)
+;      f0
+;      (fibonacci n (+ i 1) f1 (+ f0 f1))))
+;
+;(let (fibonacci (n 10) (i 0) (f0 0) (f1 1))
+;  (if (= i n)
+;      f0
+;      (fibonacci n (+ i 1) f1 (+ f0 f1))))
+;
+;(let fibonacci ((n 10) (i 0) . (f 0 1))
+;  (if (= i n)
+;      (car f)
+;      (fibonacci n (+ i 1) (cadr f) (+ (car f) (cadr f)))))
+;
+;(let (fibonacci (n 10) (i 0) . (f 0 1))
+;  (if (= i n)
+;      (car f)
+;      (fibonacci n (+ i 1) (cadr f) (+ (car f) (cadr f)))))
+  )
\ No newline at end of file
diff --git a/collects/srfi/6.ss b/collects/srfi/6.ss
new file mode 100644
index 0000000000..9a8cc27311
--- /dev/null
+++ b/collects/srfi/6.ss
@@ -0,0 +1,3 @@
+;; Supported by core PLT:
+(module |6| mzscheme
+  (provide get-output-string open-input-string open-output-string))
diff --git a/collects/srfi/7.ss b/collects/srfi/7.ss
new file mode 100644
index 0000000000..9a3e2fdb5d
--- /dev/null
+++ b/collects/srfi/7.ss
@@ -0,0 +1,4 @@
+;; module loader for SRFI-7
+(module |7| mzscheme
+  (require (lib "program.ss" "srfi" "7"))
+  (provide (all-from (lib "program.ss" "srfi" "7"))))
diff --git a/collects/srfi/7/.cvsignore b/collects/srfi/7/.cvsignore
new file mode 100644
index 0000000000..e3ca6473f7
--- /dev/null
+++ b/collects/srfi/7/.cvsignore
@@ -0,0 +1 @@
+compiled
diff --git a/collects/srfi/7/program.ss b/collects/srfi/7/program.ss
new file mode 100644
index 0000000000..451a92f0f9
--- /dev/null
+++ b/collects/srfi/7/program.ss
@@ -0,0 +1,129 @@
+;;;
+;;; <program.ss> ---- SRFI-7 program
+;;; based on MJ Ray's code for SRFI 0
+
+(module program mzscheme
+  (require-for-syntax (lib "stx.ss" "syntax")
+		      (lib "features.ss" "srfi"))
+  (require (lib "include.ss"))
+  (provide program)
+  
+  (define-syntax require-feature
+    (lambda (x)
+      (syntax-case x ()
+	((_ id)
+	 (with-syntax ((require-spec
+			(datum->syntax-object
+			 (syntax id)
+			 (feature->require-clause
+			  (syntax-object->datum (syntax id))))))
+	   (syntax
+	    (require require-spec)))))))
+  
+  (define-syntax program
+    (lambda (x)
+      (syntax-case* x (requires files code feature-cond and or not else)
+		    module-or-top-identifier=?
+	((_)
+	 (syntax (begin (void))))
+	((_
+	  (requires feature-id ...)
+	  more ...)
+	 (syntax
+	  (begin 
+	    (require-feature feature-id) ...
+	    (program more ...))))
+	((_
+	  (files filename ...)
+	  more ...)
+	 (with-syntax ((_x x))
+	   (syntax
+	    (begin
+	      (include-at/relative-to _x filename filename) ...
+	      (program
+	       more ...)))))
+	((_
+	  (code stuff ...)
+	  more ...)
+	 (syntax
+	  (begin
+	    stuff ...
+	    (program more ...))))
+	((_
+	  (feature-cond)
+	  more ...)
+	 (syntax
+	  (program
+	   more ...)))
+	((_
+	  (feature-cond (else stuff ...))
+	  more ...)
+	 (syntax
+	  (program
+	   stuff ...
+	   more ...)))
+
+	((_
+	  (feature-cond ((and) stuff ...)
+			rest ...)
+	  more ...)
+	 (syntax
+	  (program
+	   stuff ...
+	   more ...)))
+
+	((_
+	  (feature-cond ((and requirement1 requirement ...) stuff ...)
+			rest ...)
+	  more ...)
+	 (syntax
+	  (program
+	   (feature-cond (requirement1
+			  (feature-cond ((and requirement ...) stuff ...)))
+			 rest ...)
+	   more ...)))
+      
+	((_
+	  (feature-cond ((or) stuff ...)
+			rest ...)
+	  more ...)
+	 (syntax
+	  (program
+	   (feature-cond rest ...)
+	   more ...)))
+	((_
+	  (feature-cond ((or requirement1 requirement ...) stuff ...)
+			rest ...)
+	  more ...)
+	 (syntax
+	  (program
+	   (feature-cond (requirement1 stuff ...)
+			 ((or requirement ...) stuff ...)
+			 rest ...)
+	   more ...)))
+
+	((_
+	  (feature-cond ((not requirement) stuff ...)
+			rest ...)
+	  more ...)
+	 (syntax
+	  (program
+	   (feature-cond (requirement
+			  (feature-cond rest ...))
+			 (else
+			  stuff ...)))))
+	((_
+	  (feature-cond (requirement stuff ...)
+			rest ...)
+	  more ...)
+	 (if (feature-present? (syntax-object->datum (syntax requirement)))
+	     (syntax
+	      (program
+	       stuff ...
+	       more ...))
+	     (syntax
+	      (program
+	       (feature-cond rest ...)
+	       more ...))))))))
+
+;;; program.ss ends here
diff --git a/collects/srfi/8.ss b/collects/srfi/8.ss
new file mode 100644
index 0000000000..1840e78022
--- /dev/null
+++ b/collects/srfi/8.ss
@@ -0,0 +1,4 @@
+;; module loader for SRFI-8
+(module |8| mzscheme
+  (require (lib "receive.ss" "srfi" "8"))
+  (provide (all-from (lib "receive.ss" "srfi" "8"))))
diff --git a/collects/srfi/8/.cvsignore b/collects/srfi/8/.cvsignore
new file mode 100644
index 0000000000..e3ca6473f7
--- /dev/null
+++ b/collects/srfi/8/.cvsignore
@@ -0,0 +1 @@
+compiled
diff --git a/collects/srfi/8/receive.ss b/collects/srfi/8/receive.ss
new file mode 100644
index 0000000000..c32766476c
--- /dev/null
+++ b/collects/srfi/8/receive.ss
@@ -0,0 +1,22 @@
+;;;
+;;; <receive.ss> ---- SRFI 8 Binding to Multiple Values port to PLT Scheme
+;;; Time-stamp: <02/05/10 12:22:37 solsona>
+;;;
+;;; Usually, I would add a copyright notice, and the announce that
+;;; this code is under the LGPL licence.  Nevertheless, I only did the
+;;; port to PLT Scheme v200 (it was written for the 103), and here is
+;;; the copyright notice, comments, and licence from the original
+;;; source:
+;;;
+;;; oh well, there is no such comment.
+
+(module receive mzscheme
+  (provide receive)
+
+  ;; (receive vars producer . body)
+  (define-syntax receive
+    (syntax-rules ()
+		  ((receive ?vars ?producer . ?body)
+		   (call-with-values (lambda () ?producer)
+				     (lambda ?vars . ?body)))))
+  )
\ No newline at end of file
diff --git a/collects/srfi/9.ss b/collects/srfi/9.ss
new file mode 100644
index 0000000000..a956092f08
--- /dev/null
+++ b/collects/srfi/9.ss
@@ -0,0 +1,4 @@
+;; module loader for SRFI-9
+(module |9| mzscheme
+  (require (lib "record.ss" "srfi" "9"))
+  (provide (all-from (lib "record.ss" "srfi" "9"))))
diff --git a/collects/srfi/9/.cvsignore b/collects/srfi/9/.cvsignore
new file mode 100644
index 0000000000..e3ca6473f7
--- /dev/null
+++ b/collects/srfi/9/.cvsignore
@@ -0,0 +1 @@
+compiled
diff --git a/collects/srfi/9/record.ss b/collects/srfi/9/record.ss
new file mode 100644
index 0000000000..39bafd42cb
--- /dev/null
+++ b/collects/srfi/9/record.ss
@@ -0,0 +1,104 @@
+;; SRFI 9 for PLT Scheme 200
+;; Mike Sperber, 12/14/2001
+
+(module record mzscheme
+	
+  (provide define-record-type)
+	
+  (define-syntax define-record-type
+	  
+    (let ()
+      (define (filter-map proc l)
+	(if (null? l)
+	    '()
+	    (let ((result (proc (car l))))
+	      (if result
+		  (cons result (filter-map proc (cdr l)))
+		  (filter-map proc (cdr l))))))
+	    
+	    
+      (define (syntax-member? thing stuff)
+	(cond
+	 ((null? stuff) #f)
+	 ((free-identifier=? thing (car stuff)) #t)
+	 (else (syntax-member? thing (cdr stuff)))))
+	    
+      (lambda (x)
+	(syntax-case x ()
+	  ((_ type
+	      (constructor constructor-tag ...)
+	      predicate
+	      (field-tag accessor more ...) ...)
+			    
+			    
+	   (with-syntax
+	       ((number-of-fields (length (syntax->list
+					   (syntax (field-tag ...)))))
+		((modifier ...)
+		 (filter-map (lambda (descriptor)
+			       (syntax-case descriptor ()
+				 ((field-tag accessor) #f)
+				 ((field-tag accessor modifier)
+				  (syntax modifier))))
+			     (syntax->list
+			      (syntax ((field-tag accessor more ...) ...)))))
+		((constructor-arg ...)
+		 (map (lambda (field-tag)
+			(if (syntax-member? field-tag
+					    (syntax->list
+					     (syntax (constructor-tag ...))))
+			    field-tag
+			    (syntax (void))))
+		      (syntax->list
+		       (syntax (field-tag ...)))))
+		(generic-access (syntax generic-access))
+		(generic-mutate (syntax generic-mutate)))
+	     (with-syntax
+		 (((accessor-proc ...)
+		   (let loop ((i 0)
+			      (fields (syntax->list (syntax (field-tag ...)))))
+		     (if (null? fields)
+			 '()
+			 (cons (with-syntax
+				   ((i i))
+				 (syntax
+				  (lambda (s)
+				    (generic-access s i)))) 
+			       (loop (+ 1 i)
+				     (cdr fields))))))
+		  ((modifier-proc ...)
+		   (let loop ((i 0)
+			      (descriptors
+			       (syntax->list
+				(syntax ((field-tag accessor more ...) ...)))))
+		     (if (null? descriptors)
+			 '()
+			 (syntax-case (car descriptors) ()
+			   ((field-tag accessor)
+			    (loop (+ 1 i)
+				  (cdr descriptors)))
+			   ((field-tag accessor modifier)
+			    (cons (with-syntax
+				      ((i i))
+				    (syntax
+				     (lambda (s v)
+				       (generic-mutate s i v))))
+				  (loop (+ 1 i)
+					(cdr descriptors)))))))))
+	       (syntax
+		(define-values (constructor
+				predicate
+				accessor ...
+				modifier ...)
+		  (let-values (((type-descriptor
+				 full-constructor
+				 predicate
+				 generic-access
+				 generic-mutate)
+				(make-struct-type 'type #f number-of-fields 0)))
+					     
+		    (values (lambda (constructor-tag ...)
+			      (full-constructor constructor-arg ...))
+			    predicate
+			    accessor-proc ...
+			    modifier-proc ...))))))))))))
\ No newline at end of file
diff --git a/collects/srfi/doc.txt b/collects/srfi/doc.txt
new file mode 100644
index 0000000000..3b47528912
--- /dev/null
+++ b/collects/srfi/doc.txt
@@ -0,0 +1,152 @@
+PLT Scheme support for _SRFIs_ (`surfies')
+==========================================
+
+This is an implementation of (some) SRFIs to the PLT Scheme system.
+It is intended for PLT Scheme v200+.
+
+If you need more information on SRFI, please visit:
+
+		       http://srfi.schemers.org/
+
+Loading
+-------
+
+To load a SRFI with name conflicts (currently SRFI's 1, 19, 43 and 45)
+in a module, please see the note below.
+
+To load a SRFI, use the following form:
+
+		    (require (lib "N.ss" "srfi"))
+
+if you know the number of the SRFI you want to load.  This is the
+prefered method, or this one:
+
+		 (require (lib "NAME.ss" "srfi" "N"))
+
+if you know the `informative name' of the SRFI.
+
+N, is a number corresponding to the sub-collection that holds a
+particular SRFI, and NAME is a more descriptive name we assigned to
+the main file in which the SRFI is defined.  For instance, to load
+SRFI-13 you have to do either one of:
+
+		    (require (lib "13.ss" "srfi"))
+
+or,
+
+	       (require (lib "string.ss" "srfi" "13"))
+
+NOTE on SRFIs with name conflicts
+---------------------------------
+
+Certain SRFIs (currently SRFIs 1, 19, 43 and 45) provide names which
+conflict with names provided by the 'mzscheme' language.  Attempting
+to require one of these SRFIs in a module written in the 'mzscheme'
+language will result in an error.
+
+To address this problem, the PLT implementations of these SRFIs
+provide a different module which renames the problematic exports to
+avoid these conflicts.  For SRFI 1, this library is called list.ss,
+and should be required like this:
+
+		 (require (lib "list.ss" "srfi" "1"))
+
+which supplies the collading names with a prefix of 's:'
+(e.g. "s:map", "s:reverse!") and is therefore suitable for requires in
+a module.
+
+For SRFI 19, this library is called time.ss, and should be required
+like this:
+
+		(require (lib "time.ss" "srfi" "19"))
+
+which supplies the collading names with a prefix of 'srfi:'
+(e.g. "srfi:date?", "srfi:date-second") and is therefore suitable for
+requires in a module.
+
+Supported SRFIs
+---------------
+
+Here is a table that has an SRFI, file name, and the sub-collection
+number of the already ported SRFIs:
+
+  SRFI               File name               Sub-collection
+ ========           ===========             ================
+
+ SRFI-1             list.ss	                   1
+ SRFI-2             and-let.ss                     2
+ SRFI-4(*1)         4.ss
+ SRFI-5             let.ss                         5
+ SRFI-6(+)          6.ss
+ SRFI-7             program.ss                     7
+ SRFI-8             receive.ss                     8
+ SRFI-9             record.ss                      9
+ SRFI-11(+)         11.ss
+ SRFI-13            string.ss                     13
+ SRFI-14            char-set.ss                   14
+ SRFI-16(+)         16.ss
+ SRFI-17            set.ss                        17
+ SRFI-18(++)        18.ss
+ SRFI-19(*2)        time.ss                       19
+ SRFI-23(+)         23.ss
+ SRFI-25            array.ss                      25
+ SRFI-26            cut.ss                        26
+ SRFI-27            random-bits.ss                27
+ SRFI-28(+)         28.ss
+ SRFI-29            localization.ss               29
+ SRFI-30(+)         30.ss
+ SRFI-31            rec.ss                        31
+ SRFI-34            exception.ss                  34
+ SRFI-38(+)         38.ss
+ SRFI-39(+)         39.ss
+ SRFI-40            stream.ss                     40
+ SRFI-42	    comprehensions.ss             42
+ SRFI-43            vector-lib.ss                 43
+ SRFI-45(*3)        lazy.ss                       45
+
+Notes:
+,--------------------
+| +  Supported by the core of PLT Scheme
+`--------------------
+
+,--------------------
+| ++ Partially supported by the core of PLT Scheme
+`--------------------
+
+,--------------------
+| *1 The functionality is all part of mzscheme available via
+| (lib "foreign.ss"), the only missing part is the i/o syntax.
+`--------------------
+
+,--------------------
+| *2 The time module does not export its time structure (you have to
+| use the time-* procedures.)  It renames all the date-* accesors to
+| tm:date-* so that you won't get errors when including this code in
+| other modules.  Care most be taken NOT to confuse the internal date
+| structure with the PLT Scheme one, they are not the same, and all
+| procedures from this library expect the former.
+`--------------------
+
+,--------------------
+| *3 This port also provide |promise?| / |srfi-45-promise?|.
+`--------------------
+
+
+That's it for now.  If you have ported other SRFIs, and want them
+added to this library, please let us know:
+
+ + the main PLT Scheme discussion list:
+
+   PLT Scheme <plt-scheme@fast.cs.utah.edu>
+
+ + the Schematics-people @ sourceforge.net.  We are NOT members of the
+PLT group, the Schematics project is devoted to create code for PLT
+Scheme ONLY, though.  This SRFI port effort will try to be developed,
+tested, and debugged @ sourceforge, and periodically inserted to PLT
+Scheme.  Please, do join us!:
+
+   http://schematics.sourceforge.net
+
+(we don't have separate mailing lists @ sourceforge.  We have a couple
+of forums there, though.  Of course, you can send us mail directly,
+or... well, we read the PLT Scheme mailing list.)
diff --git a/collects/srfi/features.ss b/collects/srfi/features.ss
new file mode 100644
index 0000000000..a811261d67
--- /dev/null
+++ b/collects/srfi/features.ss
@@ -0,0 +1,30 @@
+(module features mzscheme
+  (provide feature-present?
+	   feature->require-clause)
+
+  (define *feature-alist*
+    '())
+
+  (define (srfi-id? id)
+    (let ((string-id (symbol->string id)))
+      (and (> (string-length string-id) 5)
+	   (string=? "srfi-"
+		     (substring string-id 0 5)))))
+
+  (define (srfi-id->filename srfi-id)
+    (let ((string-id (symbol->string srfi-id)))
+      (string-append (substring string-id 5 (string-length string-id))
+		     ".ss")))
+
+  (define (srfi-id-present? srfi-id)
+    (file-exists? (build-path (collection-path "srfi")
+			      (srfi-id->filename srfi-id))))
+
+  (define (feature-present? id)
+    (or (and (srfi-id? id) (srfi-id-present? id))
+	(and (assq id *feature-alist*) #t)))
+
+  (define (feature->require-clause id)
+    (if (and (srfi-id? id) (srfi-id-present? id))
+	(cons 'lib (list (srfi-id->filename id) "srfi"))
+	(cdr (assq id *feature-alist*)))))
diff --git a/collects/srfi/info.ss b/collects/srfi/info.ss
new file mode 100644
index 0000000000..bb5540c105
--- /dev/null
+++ b/collects/srfi/info.ss
@@ -0,0 +1,40 @@
+;;;
+;;; <info.ss> ---- info file for SRFI collection
+
+;;; Time-stamp: <03/03/27 19:29:44 solsona>
+;;;
+;;; Copyright (C) 2002 by Noel Welsh. 
+;;;
+;;; This file is part of SRFI.
+
+;;; SRFI is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2.1 of the License, or (at your option) any later version.
+
+;;; SRFI is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with SRFI; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307  USA
+
+;;; Author: Noel Welsh <noelwelsh@yahoo.com>
+;;
+;;
+;; Commentary:
+;;
+;; This file tell mzc how to compile the srfi collection.  As
+;; compilation takes place when installing a .plt it is essential that
+;; this file is updated whenever a new release is made.
+
+(module info (lib "infotab.ss" "setup")
+  (define name "srfi")
+  (define doc.txt "doc.txt")
+
+  (define blurb '("SRFI collects together ports to PLT Scheme of the Scheme Request for Implementation libraries.  For further details about the SRFI process see " (a ((href "http://srfi.schemers.org/")) "http://srfi.schemers.org/")))
+  )
+
+;;; info.ss ends here
diff --git a/collects/srfi/optional.ss b/collects/srfi/optional.ss
new file mode 100644
index 0000000000..7d6e018c16
--- /dev/null
+++ b/collects/srfi/optional.ss
@@ -0,0 +1,162 @@
+;;;
+;;; <optional.ss> ---- Let-optionals macros
+;;; Time-stamp: <02/07/15 09:25:27 solsona>
+;;;
+;;; Usually, I would add a copyright notice, and the announce that
+;;; this code is under the LGPL licence.  This code is been copied
+;;; from Scheme48, and Scsh, and thus I will append here their
+;;; Copyright notice:
+;;;
+;;; Copyright (c) 1993-1999 Richard Kelsey and Jonathan Rees
+;;; Copyright (c) 1994-1999 by Olin Shivers and Brian D. Carlstrom.
+;;; All rights reserved.
+;;; 
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+;;; 1. Redistributions of source code must retain the above copyright
+;;;    notice, this list of conditions and the following disclaimer.
+;;; 2. Redistributions in binary form must reproduce the above copyright
+;;;    notice, this list of conditions and the following disclaimer in the
+;;;    documentation and/or other materials provided with the distribution.
+;;; 3. The name of the authors may not be used to endorse or promote products
+;;;    derived from this software without specific prior written permission.
+;;; 
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
+;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
+;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
+;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
+;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
+;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+;;;
+;;; Author: Francisco Solsona <solsona@acm.org>
+;;
+;;
+;; Commentary:
+;;
+;; this is a port of commonly refered (in SRFI mostly) macros, and
+;; utilities, to the PLT Scheme system.  I'm not sure if I should use
+;; the word "port", because I hardly touched Olin Shivers' superiour
+;; macros. :-)
+;;
+
+(module optional mzscheme
+	(provide :optional
+		 let-optionals*
+		 check-arg
+		 )
+
+	;; (function (check-arg predicate value caller))
+	;;
+	;;
+	;; Checks parameter values.
+	(define check-arg
+	  (lambda (pred val caller)
+	    (if (not (pred val))
+		(error caller "given ~s" val)
+		val)))
+
+
+	
+	;; (:optional rest-arg default-exp [test-pred])
+	;;
+	;; This form is for evaluating optional arguments and their defaults
+	;; in simple procedures that take a *single* optional argument. It is
+	;; a macro so that the default will not be computed unless it is needed.
+	;; 
+	;; REST-ARG is a rest list from a lambda -- e.g., R in
+	;;     (lambda (a b . r) ...)
+	;; - If REST-ARG has 0 elements, evaluate DEFAULT-EXP and return that.
+	;; - If REST-ARG has 1 element, return that element.
+	;; - If REST-ARG has >1 element, error.
+	;;
+	;; If there is an TEST-PRED form, it is a predicate that is used to test
+	;; a non-default value. If the predicate returns false, an error is raised.
+	(define-syntax (:optional stx)
+	  (syntax-case stx ()
+		       [(_ rest default-exp)
+			(syntax
+			 (let ((maybe-arg rest))
+			   (if (pair? maybe-arg)
+			       (if (null? (cdr maybe-arg)) (car maybe-arg)
+				   (error "too many optional arguments:" maybe-arg))
+			       default-exp)))]
+		       [(_ rest default-exp arg-test)
+			(syntax
+			 (let ((maybe-arg rest))
+			   (if (pair? maybe-arg)
+			       (if (null? (cdr maybe-arg))
+				   (let ((val (car maybe-arg)))
+				     (if (arg-test val) val
+					 (error "optional argument failed test:" val)))
+				   (error "too many optional arguments:" maybe-arg))
+			       default-exp)))]))
+
+
+	;; NOTE: This is the `less-efficient version of LET-OPTIONALS*'.
+	;;       Once I understand the more efficient one, as for to
+	;;       adapt it to PLT Scheme, I will.  Sorry, Olin Shivers,
+	;;       wrote a far to complex thing for me to grasp. :-{
+
+	;; 	(LET-OPTIONALS* arg-list (opt-clause1 ... opt-clauseN [rest])
+	;;       body ...)
+	;; where
+	;;     <opt-clause> ::= (var default [arg-check supplied?])
+	;;                  |   ((var1 ... varN) external-arg-parser)
+	;;
+	;; LET-OPTIONALS* has LET* scope -- each arg clause sees the bindings of
+	;; the previous clauses. LET-OPTIONALS has LET scope -- each arg clause
+	;; sees the outer scope (an ARG-CHECK expression sees the outer scope
+	;; *plus* the variable being bound by that clause, by necessity).
+	(define-syntax let-optionals*
+	  (syntax-rules ()
+			((let-optionals* arg (opt-clause ...) body ...)
+			 (let ((rest arg))
+			   (%let-optionals* rest (opt-clause ...) body ...)))))
+
+	
+	(define-syntax %let-optionals*
+	  (syntax-rules ()
+			((%let-optionals* arg (((var ...) xparser) opt-clause ...) body ...)
+			 (call-with-values (lambda () (xparser arg))
+					   (lambda (rest var ...)
+					     (%let-optionals* rest (opt-clause ...) body ...))))
+			
+			((%let-optionals* arg ((var default) opt-clause ...) body ...)
+			 (call-with-values (lambda () (if (null? arg) (values default '())
+							  (values (car arg) (cdr arg))))
+					   (lambda (var rest)
+					     (%let-optionals* rest (opt-clause ...) body ...))))
+
+			((%let-optionals* arg ((var default test) opt-clause ...) body ...)
+			 (call-with-values (lambda ()
+					     (if (null? arg) (values default '())
+						 (let ((var (car arg)))
+						   (if test (values var (cdr arg))
+						       (error "arg failed LET-OPT test" var)))))
+					   (lambda (var rest)
+					     (%let-optionals* rest (opt-clause ...) body ...))))
+
+			((%let-optionals* arg ((var default test supplied?) opt-clause ...) body ...)
+			 (call-with-values (lambda ()
+					     (if (null? arg) (values default #f '())
+						 (let ((var (car arg)))
+						   (if test (values var #t (cdr arg))
+						       (error "arg failed LET-OPT test" var)))))
+					   (lambda (var supplied? rest)
+					     (%let-optionals* rest (opt-clause ...) body ...))))
+
+			((%let-optionals* arg (rest) body ...)
+			 (let ((rest arg)) body ...))
+
+			((%let-optionals* arg () body ...)
+			 (if (null? arg) (begin body ...)
+			     (error "Too many arguments in let-opt" arg)))))
+
+	)
+;; optional.ss ends here
\ No newline at end of file
diff --git a/collects/srpersist/doc.txt b/collects/srpersist/doc.txt
new file mode 100644
index 0000000000..b3c9c96592
--- /dev/null
+++ b/collects/srpersist/doc.txt
@@ -0,0 +1,2612 @@
+ _SrPersist_
+ ===========
+
+ _ODBC_
+ ======
+
+ SrPersist is an ODBC library for MzScheme and DrScheme.
+ Any database management system with an ODBC driver should 
+ be usable with SrPersist.
+
+ SrPersist provides a one-to-one mapping of ODBC procedures to 
+ Scheme procedures, with some additional utility procedures in Scheme.
+ Procedures from ODBC versions 1.0 through 3.51 are supported.   
+ Where ODBC expects symbolic constants created through C #define's,
+ SrPersist uses Scheme constants, which are checked for validity.
+ In many cases, redundant arguments are eliminated.  In many cases,
+ the SrPersist version of an ODBC procedure returns a handle, allowing 
+ procedures to be composed.
+
+ ODBC procedure names are mapped to Scheme names straightforwardly.
+ The initial "SQL" in the name is removed, the characters 
+ are made all lowercase, and hyphens are inserted before the location
+ of formerly uppercase letters, other than the first following "SQL".  
+ For example, the hypothetical ODBC name SQLProcedureName would be 
+ mapped to the Scheme name procedure-name.  The exceptions are SQLError
+ and SQLExecute, which are mapped to sql-error and sql-execute, to 
+ avoid confusion with MzScheme procedures.
+
+ The documentation here may be sufficient to get started with
+ SrPersist, but you will certainly want to consult an ODBC reference for 
+ more information.  The file tutorial.txt in the SrPersist collection 
+ provides some simple examples of how to use SrPersist.
+
+ SrPersist is not
+ ----------------
+
+ SrPersist makes the ODBC API available in Scheme, but does not
+ support any abstractions beyond it.  Some useful error-checking is 
+ performed that is not done when using the C version of the API.
+ Serious run-time errors are still possible, such as when a too-small 
+ buffer is bound to a column.  
+
+ Francisco Solsona has built a higher-level layer, SchemeQL,
+ currently in beta, that uses SrPersist as a substrate.
+ A SchemeQL programmer avoids the low-level details 
+ of ODBC.  You can download SchemeQL from 
+ http://schematics.sourceforge.net/schemeql.html.
+
+ Loading
+ -------
+
+ To load SrPersist, use
+
+   (require (lib "srpersist.ss" "srpersist"))
+
+ For Windows, if you get errors when loading, your Windows installation 
+ may be missing certain ODBC libraries.  Look for ODBC Data Sources 
+ in Windows Control Panel.  If that application is missing, download 
+ and install the Microsoft Data Access Components from 
+ http://www.microsoft.com/data/.  The download is about 6.5 Mb.
+
+ Overview of ODBC
+ ----------------
+
+ ODBC is a standard for allowing application programs to retrieve from 
+ and send data to relational databases.  The application program 
+ communicates with a Driver Manager using ODBC procedures.  Database
+ queries use SQL (Structured Query Language).  The Driver Manager 
+ communicates with databases using drivers specific to them.  Therefore, 
+ ODBC is a "middleware" standard.  
+
+ How to use this documentation
+ -----------------------------
+
+ Because ODBC is very complex, this documentation cannot hope to
+ cover all its aspects.  Instead, this documentation describes 
+ a Scheme interface to ODBC.  Each ODBC API procedure has a Scheme
+ counterpart.  In this documentation, we describe the parameters
+ and return values for each procedure, as well as give some indication
+ of the purpose of the procedure.  To use ODBC effectively, you will
+ need access to an ODBC reference, such as that provided with the
+ Microsoft ODBC SDK.
+
+ Overview of ODBC procedures
+ ---------------------------
+
+ In the documentation below, we group SrPersist ODBC procedures 
+ by topics.  The topics are Exceptions, Handles, Connections, Environments,
+ Statements and Parameters, Descriptors, Cursors, Columns and Data
+ Retrieval, Metadata, and Errors and Diagnostics.  SrPersist also has 
+ its own utility procedures, listed under the heading Utilities below.
+
+ For each procedure, we indicate the ODBC version in which it was 
+ introduced.  Therefore, some SrPersist procedures may not be available 
+ to your program.  
+
+ Exceptions
+ ----------
+
+ Any SrPersist ODBC procedure may raise an exception.  
+ SrPersist exceptions correspond to the ODBC SQLRESULT codes, 
+ as follows:
+
+  exn-invalid-handle    SQL_INVALID_HANDLE
+  exn-error             SQL_ERROR
+  exn-still-executing   SQL_STILL_EXECUTING
+  exn-need-data         SQL_NEED_DATA
+  exn-with-info         SQL_SUCCESS_WITH_INFO
+  exn-no-data           SQL_NO_DATA_FOUND (before ODBC 3.0)
+  exn-no-data           SQL_NO_DATA (ODBC 3.0 or greater)
+
+ Each of these exceptions is an ordinary Scheme structure
+ derived from `struct:exn'.  Only `exn-need-data` and `exn-with-info' 
+ contain an extra field, `val' in both cases.  The names of the 
+ exception indicate the nature of the problem that has occurred.  
+ Each of these exceptions, other than `exn-with-info', indicate an error.
+ The exception `exn-error' is a catchall, indicating an unspecified error.
+ The exception `exn-with-info' does not indicate an error, rather it 
+ indicates that additional information is available about the procedure 
+ that generated the exception.  The `val' field of `exn-need-data` or 
+ `exn-with-info' instances contains the value returned by the procedure 
+ that generated the exception.  In the case of `exn-need-data', depending
+ on the ODBC procedure, the contained value may not be meaningful.
+
+ `with-handlers' can be used to handle SrPersist exceptions:
+
+   (with-handlers ([(lambda (exn)
+                      (exn-with-info? exn))
+                    (lambda (exn) 
+                      (printf "Got exn-with-info exception~n")
+                      (printf "Value: ~a~n" (exn-with-info-val exn)))])
+     ...)		      
+
+ Applications can call sql-error, get-diag-rec, or get-diag-field
+ to obtain additional information about an exception that
+ has occurred (see the heading "Diagnostics", below).  No additional 
+ information is available when the exception is `exn-invalid-handle'.
+
+ If you attempt to use an ODBC procedure which is not available 
+ in the ODBC version specified when compiling SrPersist, you
+ will get an exn-not-implemented exception.
+
+ Besides these SrPersist-particular exceptions, other kinds of errors 
+ may raise exceptions.  For example, passing a value of the
+ wrong type to a SrPersist procedure will raise an exception.
+
+ Version information
+ -------------------
+
+ SrPersist offers version information to programs:
+
+> (srp-version)
+
+ Returns a string indicating the version of SrPersist.
+
+> (compiled-odbc-version)
+
+ Returns a string indicating the version of ODBC that was 
+ specified when SrPersist was compiled.  This version 
+ is not necessarily the same as odbc-version, the version
+ specified when loading SrPersist.
+
+ Handles
+ -------
+
+ ODBC and SrPersist support four kinds of handles.  
+ In ODBC itself, all handles are represented as integers,
+ making it possible for handle types to be confused.  
+ In SrPersist, each handle type has a distinct Scheme 
+ type.  An "environment handle" has type `sql-henv'; a
+ "connection handle" has type `sql-hdbc'; a "statement handle" has 
+ type `sql-hstmt'; a "descriptor handle" has type `sql-hdesc'.
+
+ Further, descriptor handles have an attribute which divides 
+ them into subtypes, though this does not show up in their
+ Scheme type.  Ordinarily, a descriptor handle is either an 
+ Application Parameter Descriptor (attribute APD), an Application 
+ Row Descriptor (ARD), an Implementation Parameter Descriptor (IPD), 
+ or an Implementation Row Descriptor (IRD).  Most descriptor 
+ handles are created by an ODBC driver.  When a descriptor 
+ handle is explicitly allocated, it receives the attribute
+ EXPLICIT, rather than one of the four attribute values just 
+ mentioned.
+  
+ There are several procedures to allocate fresh handles.
+
+> (alloc-env)
+
+ ODBC 1.0, deprecated in favor of `alloc-handle'.
+
+ Returns a fresh environment handle. 
+
+> (alloc-connect henv) 
+
+ ODBC 1.0, deprecated in favor of `alloc-handle'.
+
+ Returns a fresh connection handle, given `henv', an
+ environment handle.
+
+> (alloc-stmt hdbc) 
+
+ ODBC 1.0, deprecated in favor of `alloc-handle'.
+
+ Returns a fresh statement handle, given `hdbc', a 
+ connection handle
+
+> (alloc-handle htype [handle])
+
+ ODBC 3.0.
+
+ Returns a fresh handle whose type depends on `htype',
+ a Scheme symbol.  If `htype' is 'sql-handle-env, 
+ then `handle' must be omitted, and a fresh `environment
+ handle' is returned.  If `htype' is 'sql-handle-dbc, 
+ then `handle' must be an environment handle, and a fresh 
+ `connection handle' is returned.  If `htype' is 'sql-handle-stmt, 
+ then `handle' must be a connection handle, and a fresh 
+ `statement handle' is returned.  If `htype' is 'sql-handle-desc, 
+ then `handle' must be a connection handle, and a fresh 
+ `descriptor handle' with attribute EXPLICIT is returned.  
+ Any other value of `htype' causes an error.
+
+ Before using `alloc-handle' to create a connection handle, you may 
+ need to call `set-env-attr' with 'sql-attr-odbc-version and 
+'sql-ov-odbc3 as arguments.
+
+> (free-connect hdbc)
+
+ ODBC 1.0, deprecated in favor of free-handle.
+
+ Frees a connection handle `hdbc', whose value is returned by the 
+ procedure.
+
+> (free-env henv)
+
+ ODBC 1.0, deprecated in favor of free-handle.
+
+ Frees an environment handle `henv', whose value is returned by the
+ procedure.
+
+> (free-handle handle)
+
+ ODBC 3.0.
+
+ Frees `handle', which may be an environment, connection, statment,
+ or descriptor handle.  Returns the value of `handle'.
+
+> (free-stmt hstmt option)
+
+ ODBC 1.0.
+
+ Frees or releases resources for the statement handle `hstmt'.
+ The `option' argument may be any of the following symbols, with
+ the indicated effects:
+
+  'sql-close        closes the statement cursors, discards pending results  
+                    (does not actually free `hstmt')
+  'sql-drop         deprecated, effectively (free-handle hstmt) 
+  'sql-unbind       releases all column buffers for the statement
+  'sql-reset-parms  releases all parameter buffers for the statement
+
+ free-stmt returns the value of `hstmt'.
+
+ Environments
+ ------------
+
+> (data-sources henv direction)
+
+ OCBC 1.0.
+
+ For the environment handle `henv', returns a pair of strings
+ indicating a data source name and its description.  The
+ symbol `direction' is either 'sql-fetch-first, 'sql-fetch-next,
+ 'sql-fetch-first-user, or 'sql-fetch-first-system.  User data
+ sources are visible only to a particular user, while system
+ data sources are visible to all users.
+
+> (drivers henv fetch)
+
+ ODBC 2.0.
+
+ For the environment handle `henv', returns a two-element list
+ of strings describing an available driver.  The first string 
+ identifies the driver and the second string describes attributes
+ of the driver.  `fetch' is either 'sql-fetch-first or 
+ 'sql-fetch-next.  By using repeated calls to drivers with 
+ 'sql-fetch-next, a program can obtain information about all
+ available drivers.  Providing 'sql-fetch-next on the first 
+ call to drivers has the same effect as 'sql-fetch-first.
+
+ Please consult an ODBC reference for an information about the 
+ keyword/value pairs that appear in the attributes string.   
+
+> (get-env-attr henv attr)
+
+ ODBC 3.0.
+
+ Given an environment handle `henv', returns the value of the
+ attribute `attr'.  The possible values for `attr' and the
+ resulting return values are:
+
+  attr                           returns
+  ----                           -------
+  'sql-attr-connection-pooling   'sql-cp-off, or                
+                                 'sql-cp-one-per-driver, or
+                                 'sql-cp-one-per-henv
+
+  'sql-attr-cp-match             'sql-cp-strict-match, or 
+                                 'sql-cp-relaxed-match
+
+  'sql-attr-odbc-version         'sql-ov-odbc3, or
+                                 'sql-ov-odbc2
+
+  'sql-attr-output-nts           boolean
+
+ Please see an ODBC reference for more information about the 
+ significance of these attributes.
+
+> (set-env-attr henv attr val)
+
+ ODBC 3.0.
+
+ Given an environment handle `henv', sets the value of its associated 
+ attribute `attr' to the value `val'.  See `get-env-attr' for the
+ available attributes and their valid values.  Returns the value of 
+ `henv'.
+
+ Connections
+ -----------
+
+ Before an ODBC database may be used, a `connection' between 
+ the ODBC driver and database management system needs to be
+ established.  Here are the procedures for establishing and 
+ managing connections.
+
+> (connect hdbc dbms name password) 
+
+ ODBC 1.0.
+
+ Establishes a connection, given a connection handle `hdbc', and 
+ strings for a database server `dbms', a `name' and `password'.
+ Returns the value of `hdbc'.
+
+> (browse-connect hdbc connect-string)
+
+ ODBC 1.0.
+
+ Connects to a data source, given a connection handle `hdbc'
+ and connection string `connect-string'.  The connection string
+ consists of keyword and value pairs.  See `driver-connect'
+ for the format of such pairs.  The first time `browse-connect' 
+ is called, the connection string must contain either the
+ DSN or DRIVER keywords.  `browse-connect' returns a connection string 
+ with a sequence of keywords and value pairs.  Those pairs not
+ preceded by an asterisk are mandatory in the next call to
+ browse-connect.  If the supplied connection string does not 
+ contain all needed attributes to make a connection, a `exn-need-data'
+ exception is raised, which contains a connection string indicating 
+ which attributes are missing. 
+ 
+> (driver-connect hdbc connect-string prompt)
+
+ ODBC 1.0.
+
+ Connects to an ODBC driver, given a connection handle `hdbc',
+ the string `connect-string', and the symbol `prompt'.
+ The connect-string is a possibly-empty sequence of 
+ keyword, attribute pairs:
+
+   keyword=attribute;... 
+
+ where `keyword' is any of 
+
+   DSN       data source
+   UID       user id
+   PWD       password
+   FILEDSN   name of a .dsn file containing a connection string
+   DRIVER    driver description
+   SAVEFILE  a .dsn file for saving the connection attributes
+
+ or a driver-specific keyword.  DSN and DRIVER are mutually-exclusive.  
+ DRIVER is ODBC 2.0, while FILEDSN and SAVEFILE are ODBC 3.0.
+ For DRIVER only, the attribute may be surrounded by 
+ curly braces {}, useful if the attribute contains a semicolon.
+ `prompt' is one of the symbols 
+
+   'sql-driver-prompt              prompt for required information
+   'sql-driver-complete            prompt if DSN not in connect-string
+   'sql-driver-complete-required   prompt if DSN not in connect-string
+   'sql-driver-noprompt            do not prompt for information
+ 
+ driver-connect returns a connection string indicating all the
+ keywords and values that were passed to the data source.
+
+> (disconnect hdbc)
+
+ ODBC 1.0.
+
+ Closes the data source connection associated with the connection 
+ handle `hdbc'.  Frees any statement and descriptor handles associated 
+ with the connection handle.  Returns the value of `hdbc'.
+
+> (get-info hdbc infotype [handle])
+
+ ODBC 1.0.
+
+ Returns information about the data source associated with the 
+ connection handle `hdbc'.  The type of the return value depends
+ on the symbol `infotype', which indicates the information requested.
+ The optional argument `handle' is either a statement handle
+ or a descript handle, and may be used only with certain 
+ values of `infotype', as described below.
+
+ The significance of the values returned by get-info is beyond the
+ scope of this documentation.  Please consult an ODBC reference 
+ for further information.
+
+ The permissible values of `infotype' vary by ODBC version.
+ Valid values of `infotype' and their return types are:
+
+ infotype                            returns
+ --------                            -------
+
+ [ODBC 1.0 or greater]
+ 'sql-accessible-procedures          boolean
+ 'sql-accessible-tables              boolean
+ 'sql-active-connections             unsigned integer
+ 'sql-active-statements              unsigned integer
+ 'sql-alter-table                    a list with elements chosen from    
+                                      '(sql-at-add-column-collation
+                                        sql-at-add-column-default
+                                        sql-at-add-column-single
+                                        sql-at-add-constraint
+                                        sql-at-add-table-constraint
+                                        sql-at-constraint-name-definition
+                                        sql-at-drop-column-cascade
+                                        sql-at-drop-column-default
+                                        sql-at-drop-column-restrict
+                                        sql-at-drop-table-constraint-cascade
+                                        sql-at-drop-table-constraint-restrict
+                                        sql-at-set-column-default
+                                        sql-at-constraint-initially-deferred
+                                        sql-at-constraint-initially-immediate
+                                        sql-at-constraint-deferrable
+                                        sql-at-constraint-non-deferrable)
+ 'sql-correlation-name               'sql-cn-none, or 
+                                     'sql-cn-different, or 
+                                     'sql-cn-any
+ 'sql-convert-functions              a list with elements chosen from
+                                      '(sql-fn-cvt-cast sql-fn-cvt-convert)
+ 'sql-column-alias                   boolean 
+ 'sql-concat-null-behavior           'sql-cb-null or
+                                     sql-cb-non-null
+ 'sql-convert-bigint                 a list with elements chosen from
+                                      '(sql-cvt-bigint
+                                        sql-cvt-binary
+                                        sql-cvt-bit
+                                        sql-cvt-char
+                                        sql-cvt-date
+                                        sql-cvt-decimal
+                                        sql-cvt-double
+                                        sql-cvt-float
+                                        sql-cvt-integer
+                                        sql-cvt-interval-year-month
+                                        sql-cvt-interval-day-time
+                                        sql-cvt-longvarbinary
+                                        sql-cvt-longvarchar
+                                        sql-cvt-numeric
+                                        sql-cvt-real
+                                        sql-cvt-smallint
+                                        sql-cvt-time
+                                        sql-cvt-timestamp
+                                        sql-cvt-tinyint
+                                        sql-cvt-varbinary
+                                        sql-cvt-varchar)
+ 'sql-convert-binary                 same as for 'sql-convert-bigint
+ 'sql-convert-bit                    same as for 'sql-convert-bigint
+ 'sql-convert-char                   same as for 'sql-convert-bigint
+ 'sql-convert-date                   same as for 'sql-convert-bigint 
+ 'sql-convert-decimal                same as for 'sql-convert-bigint
+ 'sql-convert-double                 same as for 'sql-convert-bigint
+ 'sql-convert-float                  same as for 'sql-convert-bigint
+ 'sql-convert-integer                same as for 'sql-convert-bigint
+ 'sql-convert-longvarbinary          same as for 'sql-convert-bigint
+ 'sql-convert-longvarchar            same as for 'sql-convert-bigint
+ 'sql-convert-real                   same as for 'sql-convert-bigint  
+ 'sql-convert-numeric                same as for 'sql-convert-bigint
+ 'sql-convert-smallint               same as for 'sql-convert-bigint
+ 'sql-convert-time                   same as for 'sql-convert-bigint 
+ 'sql-convert-timestamp              same as for 'sql-convert-bigint
+ 'sql-convert-tinyint                same as for 'sql-convert-bigint
+ 'sql-convert-varbinary              same as for 'sql-convert-bigint
+ 'sql-convert-varchar                same as for 'sql-convert-bigint
+ 'sql-cursor-commit-behavior         'sql-cb-delete, or
+                                     'sql-cb-close, or
+                                     'sql-cb-preserve
+ 'sql-cursor-rollback-behavior       same as for 'sql-cursor-commit-behavior
+ 'sql-data-source-name               string
+ 'sql-data-source-read-only          boolean
+ 'sql-database-name                  string
+ 'sql-dbms-name                      string
+ 'sql-dbms-ver                       string 
+ 'sql-default-txn-isolation          'sql-txn-read-uncommitted, or 
+                                     'sql-txn-read-committed, or
+                                     'sql-txn-repeatable-read, or
+                                     'sql-txn-serializable
+ 'sql-driver-hdbc                    connection handle
+ 'sql-driver-henv                    environment handle
+ 'sql-driver-hlib                    unsigned integer
+ 'sql-driver-hstmt                   statement handle; `handle' argument
+                                      also a statement handle
+ 'sql-driver-name                    string  
+ 'sql-driver-odbc-ver                string 
+ 'sql-driver-ver                     string
+ 'sql-expressions-in-orderby         boolean
+ 'sql-fetch-direction                a list with elements chosen from  
+                                      '(sql-fd-fetch-next
+                                        sql-fd-fetch-first
+                                        sql-fd-fetch-last
+                                        sql-fd-fetch-prior
+                                        sql-fd-fetch-absolute
+                                        sql-fd-fetch-relative
+                                        sql-fd-fetch-bookmark)
+ 'sql-file-usage                     'sql-file-not-supported, or 
+                                     'sql-file-table, or
+                                     'sql-file-qualifier, or
+                                     'sql-file-catalog (ODBC 3.0 or greater)
+ 'sql-getdata-extensions             a list with elements chosen from  
+                                      '(sql-gd-any-column
+                                        sql-gd-any-order
+                                        sql-gd-block
+                                        sql-gd-bound)
+ 'sql-group-by                       'sql-gb-collate (ODBC 3.0 or greater), or 
+                                     'sql-gb-not-supported, or
+                                     'sql-gb-group-by-equals-select, or
+                                     'sql-gb-group-by-contains-select, or
+                                     'sql-gb-no-relation
+ 'sql-identifier-case                'sql-ic-upper, or
+                                     'sql-ic-lower, or 
+                                     'sql-ic-sensitive, or
+                                     'sql-ic-mixed
+ 'sql-identifier-quote-char          string 
+ 'sql-keywords                       string
+ 'sql-like-escape-clause             boolean
+ 'sql-lock-types                     a list with elements chosen from  
+                                      '(sql-lck-no-change
+                                        sql-lck-exclusive
+                                        sql-lck-unlock)
+ 'sql-max-binary-literal-len         unsigned integer
+ 'sql-max-char-literal-len           unsigned integer
+ 'sql-max-column-name-len            unsigned integer
+ 'sql-max-columns-in-group-by        unsigned integer
+ 'sql-max-columns-in-index           unsigned integer
+ 'sql-max-columns-in-order-by        unsigned integer
+ 'sql-max-columns-in-select          unsigned integer
+ 'sql-max-columns-in-table           unsigned integer
+ 'sql-max-cursor-name-len            unsigned integer
+ 'sql-max-index-size                 unsigned integer
+ 'sql-max-owner-name-len             unsigned integer
+ 'sql-max-procedure-name-len         unsigned integer
+ 'sql-max-qualifier-name-len         unsigned integer
+ 'sql-max-row-size                   unsigned integer 
+ 'sql-max-row-size-includes-long     boolean
+ 'sql-max-statement-len              unsigned integer 
+ 'sql-max-table-name-len             unsigned integer
+ 'sql-max-tables-in-select           unsigned integer
+ 'sql-max-user-name-len              unsigned integer 
+ 'sql-mult-result-sets               boolean
+ 'sql-multiple-active-txn            boolean
+ 'sql-need-long-data-len             boolean
+ 'sql-non-nullable-columns           'sql-nnc-null or 
+                                     'sql-nnc-non-null
+ 'sql-null-collation                 'sql-nc-end, or 
+                                     'sql-nc-high, or 
+                                     'sql-nc-low, or 
+                                     'sql-nc-start
+ 'sql-numeric-functions              a list with elements chosen from
+                                      '(sql-fn-num-abs
+                                        sql-fn-num-acos
+                                        sql-fn-num-asin
+                                        sql-fn-num-atan
+                                        sql-fn-num-atan2
+                                        sql-fn-num-ceiling
+                                        sql-fn-num-cos
+                                        sql-fn-num-cot
+                                        sql-fn-num-degrees
+                                        sql-fn-num-exp
+                                        sql-fn-num-floor
+                                        sql-fn-num-log
+                                        sql-fn-num-log10
+                                        sql-fn-num-mod
+                                        sql-fn-num-pi
+                                        sql-fn-num-power
+                                        sql-fn-num-radians
+                                        sql-fn-num-rand
+					sql-fn-num-round
+                                        sql-fn-num-sign
+                                        sql-fn-num-sin
+                                        sql-fn-num-sqrt
+                                        sql-fn-num-tan
+                                        sql-fn-num-truncate)
+ 'sql-odbc-api-conformance           'sql-oac-none, or
+                                     'sql-oac-level1, or
+                                     'sql-oac-level2
+ 'sql-odbc-sql-conformance           'sql-osc-minimum, or
+                                     'sql-osc-core, or
+                                     'sql-osc-extended
+ 'sql-odbc-sql-opt-ief               boolean
+ 'sql-odbc-ver                       string     
+ 'sql-order-by-columns-in-select     boolean
+ 'sql-outer-joins                    boolean
+ 'sql-owner-term                     string
+ 'sql-owner-usage                    a list with elements chosen from
+                                      '(sql-ou-dml-statements
+                                        sql-ou-procedure-invocation
+                                        sql-ou-table-definition
+                                        sql-ou-index-definition
+                                        sql-ou-privilege-definition)
+ 'sql-pos-operations                 a list with elements chosen from  
+                                      '(sql-pos-position
+                                        sql-pos-refresh
+                                        sql-pos-update
+                                        sql-pos-delete
+                                        sql-pos-add)
+ 'sql-positioned-statements          a list with elements chosen from 
+                                      '(sql-ps-positioned-delete
+                                        sql-ps-positioned-update
+                                        sql-ps-select-for-update)
+ 'sql-procedure-term                 string
+ 'sql-procedures                     boolean
+ 'sql-qualifier-location             'sql-ql-start or 'sql-ql-end
+ 'sql-qualifier-name-separator       string
+ 'sql-qualifier-term                 string
+ 'sql-qualifier-usage                a list with elements chosen from  
+                                      '(sql-qu-dml-statements
+                                        sql-qu-procedure-invocation
+                                        sql-qu-table-definition
+                                        sql-qu-index-definition
+                                        sql-qu-privilege-definition)
+ 'sql-quoted-identifier-case         'sql-ic-upper, or 
+                                     'sql-ic-lower, or 
+                                     'sql-ic-sensitive, or
+                                     'sql-ic-mixed
+ 'sql-row-updates                    boolean 
+ 'sql-scroll-concurrency             a list with elements chosen from 
+                                      '(sql-scco-read-only 
+                                        sql-scco-lock
+                                        sql-scco-opt-rowver
+                                        sql-scco-opt-values)
+ 'sql-scroll-options                 a list with elements chosen from    
+                                      '(sql-so-forward-only
+                                        sql-so-static
+                                        sql-so-keyset-driven
+                                        sql-so-dynamic
+                                        sql-so-mixed)
+ 'sql-search-pattern-escape          string 
+ 'sql-server-name                    string
+ 'sql-special-characters             string
+ 'sql-static-sensitivity             a list with elements chosen from 
+                                      '(sql-ss-additions
+                                        sql-ss-deletions
+                                        sql-ss-updates)
+ 'sql-string-functions               a list with elements chosen from
+                                      '(sql-fn-str-ascii
+                                        sql-fn-str-bit-length
+                                        sql-fn-str-char
+                                        sql-fn-str-char-length
+                                        sql-fn-str-character-length
+                                        sql-fn-str-concat
+                                        sql-fn-str-difference
+                                        sql-fn-str-insert
+                                        sql-fn-str-lcase
+                                        sql-fn-str-left
+                                        sql-fn-str-length
+                                        sql-fn-str-locate
+                                        sql-fn-str-ltrim
+                                        sql-fn-str-octet-length
+                                        sql-fn-str-position
+                                        sql-fn-str-repeat
+                                        sql-fn-str-replace
+                                        sql-fn-str-right
+                                        sql-fn-str-rtrim
+                                        sql-fn-str-soundex
+                                        sql-fn-str-space
+                                        sql-fn-str-substring
+                                        sql-fn-str-ucase)
+ 'sql-subqueries                     a list with elements chosen from    
+                                      '(sql-sq-correlated-subqueries
+                                        sql-sq-comparison
+                                        sql-sq-exists
+                                        sql-sq-in
+                                        sql-sq-quantified)
+ 'sql-system-functions               a list with elements chosen from
+                                      '(sql-fn-sys-dbname
+                                        sql-fn-sys-ifnull
+                                        sql-fn-sys-username)
+ 'sql-table-term                     string
+ 'sql-timedate-add-intervals         a list with elements chosen from
+                                      '(sql-fn-tsi-frac-second
+                                        sql-fn-tsi-second
+                                        sql-fn-tsi-minute
+                                        sql-fn-tsi-hour
+                                        sql-fn-tsi-day
+                                        sql-fn-tsi-week
+                                        sql-fn-tsi-month
+                                        sql-fn-tsi-quarter
+                                        sql-fn-tsi-year)
+ 'sql-timedate-diff-intervals        a list with elements chosen from
+                                      '(sql-fn-tsi-frac-second
+                                        sql-fn-tsi-second
+                                        sql-fn-tsi-minute
+                                        sql-fn-tsi-hour
+                                        sql-fn-tsi-day
+                                        sql-fn-tsi-week
+                                        sql-fn-tsi-month
+                                        sql-fn-tsi-quarter
+                                        sql-fn-tsi-year)
+ 'sql-timedate-functions             a list with elements chosen from
+                                      '(sql-fn-td-current-date
+                                        sql-fn-td-current-time
+                                        sql-fn-td-current-timestamp
+                                        sql-fn-td-curdate
+                                        sql-fn-td-curtime
+                                        sql-fn-td-dayname
+                                        sql-fn-td-dayofmonth
+                                        sql-fn-td-dayofweek
+                                        sql-fn-td-dayofyear
+                                        sql-fn-td-extract
+                                        sql-fn-td-hour
+                                        sql-fn-td-minute
+                                        sql-fn-td-month
+                                        sql-fn-td-monthname
+                                        sql-fn-td-now
+                                        sql-fn-td-quarter
+                                        sql-fn-td-second
+                                        sql-fn-td-timestampadd
+                                        sql-fn-td-timestampdiff
+                                        sql-fn-td-week
+                                        sql-fn-td-year)
+ 'sql-txn-capable                    'sql-tc-none, or 
+                                     'sql-tc-dml, or
+                                     'sql-tc-ddl-commit, or
+                                     'sql-tc-ddl-ignore, or
+                                     'sql-tc-all
+ 'sql-txn-isolation-option           same as for 'sql-default-txn-isolation
+ 'sql-union                          a list with elements chosen from    
+                                      '(sql-u-union sql-u-union-all)
+ 'sql-user-name                      string 
+
+ [ODBC 2.0 or greater]:
+ 'sql-bookmark-persistence         a list with elements chosen from 
+                                    '(sql-bp-close sql-bp-delete
+			              sql-bp-drop sql-bp-transaction
+			              sql-bp-update sql-bp-other-hstmt)
+
+ [ODBC 2.01 or greater]:           
+ 'sql-oj-capabilities              a list with elements chosen from
+                                    '(sql-oj-left
+                                      sql-oj-right
+                                      sql-oj-full
+                                      sql-oj-nested
+                                      sql-oj-not-ordered
+                                      sql-oj-inner
+                                      sql-oj-all-comparison-ops)
+
+ [ODBC 3.0 or greater]:
+ 'sql-active-environments          unsigned integer
+ 'sql-aggregate-functions          a list with elements chosen from 
+				    '(sql-af-all
+                                      sql-af-avg
+                                      sql-af-count
+                                      sql-af-distinct
+                                      sql-af-max
+                                      sql-af-min
+                                      sql-af-sum)
+ 'sql-alter-domain                   a list with elements chosen from 
+                                      '(sql-ad-add-domain-constraint
+                                        sql-ad-add-domain-default
+                                        sql-ad-constraint-name-definition
+                                        sql-ad-drop-domain-constraint
+                                        sql-ad-drop-domain-default
+                                        sql-ad-add-constraint-deferrable
+                                        sql-ad-add-constraint-non-deferrable
+                                        sql-ad-add-constraint-inititally-deferred
+                                        sql-ad-add-constraint-initially-immediate)
+ 'sql-async-mode                   'sql-am-connection, or
+	                            'sql-am-statement, or
+                                    'sql-am-none  
+ 'sql-batch-row-count              a list with elements chosen from 
+				    '(sql-brc-rolled-up
+				      sql-brc-procedures
+				      sql-brc-explicit)
+ 'sql-batch-support                 a list with elements chosen from
+				     '(sql-bs-select-explicit
+                                       sql-bs-row-count-explicit
+                                       sql-bs-select-proc
+                                       sql-bs-row-count-proc)
+ 'sql-catalog-location             'sql-cl-start or 'sql-cl-end
+ 'sql-catalog-name                 boolean   
+ 'sql-catalog-name-separator       string
+ 'sql-catalog-term                 string
+ 'sql-catalog-usage                a list with elements chosen from 
+                                    '(sql-cu-dml-statements
+                                      sql-cu-procedure-invocation
+                                      sql-cu-table-definition
+                                      sql-cu-index-definition
+                                      sql-cu-privilege-definition)
+ 'sql-collation-seq                string
+ 'sql-convert-interval-year-month  same as for 'sql-convert-bigint
+ 'sql-convert-interval-day-time    same as for 'sql-convert-bigint
+ 'sql-convert-interval-year-month  same as for 'sql-convert-bigint
+ 'sql-create-assertion             a list with elements chosen from  
+                                    '(sql-ca-create-assertion
+                                      sql-ca-constraint-initially-deferred
+                                      sql-ca-constraint-initially-immediate
+                                      sql-ca-constraint-deferrable
+                                      sql-ca-constraint-non-deferrable)
+ 'sql-create-character-set         a list with elements chosen from  
+                                    '(sql-ccs-create-character-set
+                                      sql-ccs-collate-clause
+                                      sql-ccs-limited-collation)
+ 'sql-create-collation             a list with elements chosen from  
+                                    '(sql-ccol-create-collation)
+ 'sql-create-domain                a list with elements chosen from  
+                                    '(sql-cdo-create-domain
+                                      sql-cdo-constraint-name-definition
+                                      sql-cdo-default
+                                      sql-cdo-constraint
+                                      sql-cdo-collation
+                                      sql-cdo-constraint-initially-deferred
+                                      sql-cdo-constraint-initially-immediate
+                                      sql-cdo-constraint-deferrable
+                                      sql-cdo-constraint-non-deferrable)
+ 'sql-create-schema                a list with elements chosen from  
+                                    '(sql-cs-create-schema
+                                      sql-cs-authorization
+                                      sql-cs-default-character-set)
+ 'sql-create-table                 a list with elements chosen from  
+                                    '(sql-ct-create-table
+                                      sql-ct-table-constraint
+                                      sql-ct-constraint-name-definition
+                                      sql-ct-commit-preserve
+                                      sql-ct-commit-delete
+                                      sql-ct-global-temporary
+                                      sql-ct-local-temporary
+                                      sql-ct-column-constraint
+                                      sql-ct-column-default
+                                      sql-ct-column-collation
+                                      sql-ct-constraint-initially-deferred
+                                      sql-ct-constraint-initially-immediate
+                                      sql-ct-constraint-deferrable
+                                      sql-ct-constraint-non-deferrable)
+ 'sql-create-translation           a list with elements chosen from  
+                                    '(sql-ctr-create-translation)
+ 'sql-create-view                  a list with elements chosen from  
+                                    '(sql-cv-create-view
+                                      sql-cv-check-option
+                                      sql-cv-cascaded
+                                      sql-cv-local)
+ 'sql-datetime-literals            a list with elements chosen from
+                                    '(sql-dl-sql92-date
+                                      sql-dl-sql92-time
+                                      sql-dl-sql92-timestamp
+                                      sql-dl-sql92-interval-year
+                                      sql-dl-sql92-interval-month
+                                      sql-dl-sql92-interval-day
+                                      sql-dl-sql92-interval-hour
+                                      sql-dl-sql92-interval-minute
+                                      sql-dl-sql92-interval-second
+                                      sql-dl-sql92-interval-year-to-month
+                                      sql-dl-sql92-interval-day-to-hour
+                                      sql-dl-sql92-interval-day-to-minute
+                                      sql-dl-sql92-interval-day-to-second
+                                      sql-dl-sql92-interval-hour-to-minute
+                                      sql-dl-sql92-interval-hour-to-second
+                                      sql-dl-sql92-interval-minute-to-second)
+ 'sql-ddl-index                      'sql-di-create-index or 
+                                     'sql-di-drop-index
+ 'sql-describe-parameter           boolean
+ 'sql-dm-ver                       string
+ 'sql-driver-hdesc                 descriptor handle; `handle' argument
+                                     also a descriptor handle 
+ 'sql-drop-assertion               a list with elements chosen from  
+                                    '(sql-da-drop-assertion)
+ 'sql-drop-character-set           a list with elements chosen from  
+                                    '(sql-dcs-drop-character-set)
+ 'sql-drop-collation               a list with elements chosen from  
+                                    '(sql-dc-drop-collation)
+ 'sql-drop-domain                  a list with elements chosen from  
+                                    '(sql-dd-drop-domain
+                                      sql-dd-cascade
+                                      sql-dd-restrict)
+ 'sql-drop-schema                  a list with elements chosen from  
+                                    '(sql-ds-drop-schema
+                                      sql-ds-cascade
+                                      sql-ds-restrict)
+ 'sql-drop-table                   a list with elements chosen from 
+				    '(sql-dt-drop-table
+                                      sql-dt-cascade
+                                      sql-dt-restrict)
+ 'sql-drop-translation             a list with elements chosen from  
+                                    '(sql-dtr-drop-translation)
+ 'sql-drop-view                    a list with elements chosen from  
+	                            '(sql-dv-drop-view
+                                      sql-dv-cascade
+                                      sql-dv-restrict)
+ 'sql-cursor-sensitivity           'sql-insensitive, or 
+                                   'sql-unspecified, or 
+                                   'sql-sensitive
+ 'sql-dynamic-cursor-attributes1   a list with elements chosen from
+				     '(sql-ca1-next sql-ca1-absolute
+                                       sql-ca1-relative sql-ca1-bookmark
+                                       sql-ca1-lock-exclusive 
+                                       sql-ca1-lock-no-change
+                                       sql-ca1-lock-unlock sql-ca1-pos-position
+                                       sql-ca1-pos-update sql-ca1-pos-delete
+                                       sql-ca1-pos-refresh 
+                                       sql-ca1-positioned-update
+                                       sql-ca1-positioned-delete
+                                       sql-ca1-select-for-update
+                                       sql-ca1-bulk-add
+                                       sql-ca1-bulk-update-by-bookmark
+                                       sql-ca1-bulk-delete-by-bookmark
+                                       sql-ca1-bulk-fetch-by-bookmark)
+ 'sql-dynamic-cursor-attributes2   a list with elements chosen from 
+				     '(sql_ca2_read_only_concurrency
+				       sql_ca2_lock_concurrency
+	                               sql_ca2_opt_rowver_concurrency
+                                       sql_ca2_opt_values_concurrency
+                                       sql_ca2_sensitivity_additions
+                                       sql_ca2_sensitivity_deletions
+                                       sql_ca2_sensitivity_updates
+                                       sql_ca2_max_rows_select
+                                       sql_ca2_max_rows_insert
+                                       sql_ca2_max_rows_delete
+                                       sql_ca2_max_rows_update
+                                       sql_ca2_max_rows_catalog
+                                       sql_ca2_max_rows_affects_all
+                                       sql_ca2_crc_exact
+                                       sql_ca2_crc_approximate
+                                       sql_ca2_simulate_non_unique
+                                       sql_ca2_simulate_try_unique
+                                       sql_ca2_simulate_unique)
+ 'sql-forward-only-cursor-attributes1 
+                                   same as for 'sql-keyset-cursor-attributes1  
+ 'sql-forward-only-cursor-attributes2 
+                                   same as for 'sql-keyset-cursor-attributes2  
+ 'sql-index-keywords                 a list with elements chosen from  
+                                      '(sql-ik-asc sql-ik-desc)
+ 'sql-info-schema-views            a list with elements chosen from      
+				    '(sql-isv-assertions 
+                                      sql-isv-character-sets
+				      sql-isv-check-constraints 
+                                      sql-isv-collations
+				      sql-isv-column-domain-usage
+                                      sql-isv-column-privileges 
+                                      sql-isv-columns
+                                      sql-isv-constraint-column-usage
+                                      sql-isv-constraint-table-usage
+                                      sql-isv-domain-constraints
+                                      sql-isv-domains 
+                                      sql-isv-key-column-usage
+				      sql-isv-referential-constraints
+				      sql-isv-schemata 
+                                      sql-isv-sql-languages
+				      sql-isv-table-constraints 
+				      sql-isv-table-privileges
+                                      sql-isv-tables sql-isv-translations
+				      sql-isv-usage-privileges 
+                                      sql-isv-view-column-usage
+                                      sql-isv-view-table-usage)
+ 'sql-insert-statement             a list with elements chosen from  
+				    '(sql-is-insert-literals
+                                      sql-is-insert-searched
+                                      sql-is-select-into)
+ 'sql-integrity                    boolean
+ 'sql-keyset-cursor-attributes1    same as for 'sql-dynamic-cursor-attributes1
+ 'sql-keyset-cursor-attributes2    same as for 'sql-dynamic-cursor-attributes2
+ 'sql-max-async-concurrent-statements unsigned integer
+ 'sql-max-catalog-name-len         unsigned integer
+ 'sql-max-concurrent-activities    unsigned integer
+ 'sql-max-driver-connections       unsigned integer
+ 'sql-max-identifier-len           unsigned integer  
+ 'sql-max-schema-name-len          unsigned integer
+ 'sql-odbc-interface-conformance   'sql-oic-core, or
+                                   'sql-oic-level1, or
+                                   'sql-oic-level2 
+ 'sql-param-array-row-counts       'sql-parc-batch or 'sql-parc-no-batch
+ 'sql-param-array-selects          'sql-pas-batch, or 'sql-pas-no-batch, or
+                                   'sql-pas-no-select
+ 'sql-schema-term                  string
+ 'sql-schema-usage                 a list with elements chosen from  
+                                    '(sql-su-dml-statements
+                                      sql-su-procedure-invocation
+                                      sql-su-table-definition
+                                      sql-su-index-definition
+                                      sql-su-privilege-definition)
+ 'sql-sql-conformance              'sql-sc-sql92-entry, or 
+                                   'sql-sc-fips127-2-transitional, or
+                                   'sql-sc-sql92-full, or
+                                   'sql-sc-sql92-intermediate, or
+ 'sql-sql92-datetime-functions     a list with elements chosen from  
+                                    '(sql-sdf-current-date
+                                      sql-sdf-current-time
+                                      sql-sdf-current-timestamp)
+ 'sql-sql92-foreign-key-delete-rule
+                                   a list with elements chosen from  
+                                    '(sql-sfkd-cascade
+                                      sql-sfkd-no-action
+                                      sql-sfkd-set-default
+                                      sql-sfkd-set-null)
+ 'sql-sql92-foreign-key-update-rule
+                                   a list with elements chosen from  
+                                    '(sql-sfku-cascade
+                                      sql-sfku-no-action
+                                      sql-sfku-set-default
+                                      sql-sfku-set-null)
+ 'sql-sql92-grant                  a list with elements chosen from  
+                                    '(sql-sg-delete-table
+                                      sql-sg-insert-column
+                                      sql-sg-insert-table
+                                      sql-sg-references-table
+                                      sql-sg-references-column
+                                      sql-sg-select-table
+                                      sql-sg-update-column
+                                      sql-sg-update-table
+                                      sql-sg-usage-on-domain
+                                      sql-sg-usage-on-character-set
+                                      sql-sg-usage-on-collation
+                                      sql-sg-usage-on-translation
+                                      sql-sg-with-grant-option)
+ 'sql-sql92-numeric-value-functions
+                                   a list with elements chosen from  
+                                      '(sql-snvf-bit-length
+                                        sql-snvf-char-length
+                                        sql-snvf-character-length
+                                        sql-snvf-extract
+                                        sql-snvf-octet-length
+                                        sql-snvf-position)
+ 'sql-sql92-predicates             a list with elements chosen from  
+                                    '(sql-sp-between
+                                      sql-sp-comparison
+                                      sql-sp-exists
+                                      sql-sp-in
+                                      sql-sp-isnotnull
+                                      sql-sp-isnull
+                                      sql-sp-like
+                                      sql-sp-match-full
+                                      sql-sp-match-partial
+                                      sql-sp-match-unique-full
+                                      sql-sp-match-unique-partial
+                                      sql-sp-overlaps
+                                      sql-sp-quantified-comparison
+                                      sql-sp-unique)
+ 'sql-sql92-relational-join-operations 
+                                   a list with elements chosen from  
+                                    '(sql-srjo-corresponding-clause
+                                      sql-srjo-cross-join
+                                      sql-srjo-except-join
+                                      sql-srjo-full-outer-join
+                                      sql-srjo-inner-join
+                                      sql-srjo-intersect-join
+                                      sql-srjo-left-outer-join
+                                      sql-srjo-natural-join
+                                      sql-srjo-right-outer-join
+                                      sql-srjo-union-join)
+ 'sql-sql92-revoke                 a list with elements chosen from  
+                                    '(sql-sr-cascade
+                                      sql-sr-delete-table
+                                      sql-sr-grant-option-for
+                                      sql-sr-insert-column
+                                      sql-sr-insert-table
+                                      sql-sr-references-column
+                                      sql-sr-references-table
+                                      sql-sr-restrict
+                                      sql-sr-select-table
+                                      sql-sr-update-column
+                                      sql-sr-update-table
+                                      sql-sr-usage-on-domain
+                                      sql-sr-usage-on-character-set
+                                      sql-sr-usage-on-collation
+                                      sql-sr-usage-on-translation)
+ 'sql-sql92-row-value-constructor  a list with elements chosen from  
+                                    '(sql-srvc-value-expression
+                                      sql-srvc-null
+                                      sql-srvc-default
+                                      sql-srvc-row-subquery)
+ 'sql-sql92-string-functions       a list with elements chosen from  
+                                    '(sql-ssf-convert
+                                      sql-ssf-lower
+                                      sql-ssf-upper
+                                      sql-ssf-substring
+                                      sql-ssf-translate
+                                      sql-ssf-trim-both
+                                      sql-ssf-trim-leading
+                                      sql-ssf-trim-trailing)
+ 'sql-sql92-value-expressions      a list with elements chosen from  
+                                    '(sql-sve-case
+                                      sql-sve-cast
+                                      sql-sve-coalesce
+                                      sql-sve-nullif)
+ 'sql-standard-cli-conformance     a list with elements chosen from 
+                                    '(sql-scc-xopen-cli-version1 
+                                      sql-scc-iso92-cli)
+ 'sql-static-cursor-attributes1    same as for 'sql-dynamic-cursor-attributes1  
+ 'sql-static-cursor-attributes2    same as for 'sql-dynamic-cursor-attributes2
+ 'sql-xopen-cli-year               string
+
+> (get-functions hdbc fn)
+
+ ODBC 1.0.
+
+ For the driver that supports the connection indicated by the connection
+ handle `hdbc', get-functions indicates whether the function or set 
+ of functions denoted by the symbol `fn' is supported by the driver.
+
+ For ODBC 2.0 or later, `fn' may be 'sql-api-all-functions.  
+ In that case, get-functions returns a list of two-element lists in which 
+ the first element is a symbol indicating a function name, and
+ the second element is #t if the driver supports the function,
+ otherwise #f.  The function names in the list are those below indicated 
+ as ODBC 2.0 or earlier.
+
+ For ODBC 3.0 or greater, `fn' may be 'sql-api-odbc3-all-functions.  
+ In that case, get-functions returns a list of two-element lists in which 
+ the first element is a symbol indicating a function name, and
+ the second element is #t if the driver supports the function,
+ otherwise #f.  The function names in the list include those from ODBC 3.0, 
+ and those from ODBC 2.0 and earlier.
+
+ `fn' may also be one of the symbols in the following list of functions.
+ In this case, get-functions returns #t if the function is supported,
+ #f otherwise.
+  
+ [ODBC 2.0 and earlier]
+ 'sql-api-sqlbindcol
+ 'sql-api-sqlcancel
+ 'sql-api-sqlconnect
+ 'sql-api-sqlgetfunctions
+ 'sql-api-sqlgetinfo
+ 'sql-api-sqldatasources
+ 'sql-api-sqldescribecol
+ 'sql-api-sqlgettypeinfo
+ 'sql-api-sqldisconnect
+ 'sql-api-sqlnumresultcols
+ 'sql-api-sqldrivers
+ 'sql-api-sqlparamdata
+ 'sql-api-sqlprepare
+ 'sql-api-sqlexecdirect
+ 'sql-api-sqlputdata
+ 'sql-api-sqlexecute
+ 'sql-api-sqlrowcount
+ 'sql-api-sqlfetch
+ 'sql-api-sqlsetcursorname
+ 'sql-api-sqlfreestmt
+ 'sql-api-sqlgetcursorname
+ 'sql-api-sqlgetdata
+ 'sql-api-sqlcolumns
+ 'sql-api-sqlstatistics
+ 'sql-api-sqlspecialcolumns
+ 'sql-api-sqltables
+ 'sql-api-sqlbindparameter
+ 'sql-api-sqlnativesql
+ 'sql-api-sqlbrowseconnect
+ 'sql-api-sqlnumparams
+ 'sql-api-sqlprimarykeys
+ 'sql-api-sqlcolumnprivileges
+ 'sql-api-sqlprocedurecolumns
+ 'sql-api-sqldescribeparam
+ 'sql-api-sqlprocedures
+ 'sql-api-sqldriverconnect
+ 'sql-api-sqlsetpos
+ 'sql-api-sqlforeignkeys
+ 'sql-api-sqltableprivileges
+ 'sql-api-sqlmoreresults
+
+ [ODBC 3.0]
+ 'sql-api-sqlallochandle
+ 'sql-api-sqlgetdescfield
+ 'sql-api-sqlgetdescrec
+ 'sql-api-sqlgetdiagfield
+ 'sql-api-sqlclosecursor
+ 'sql-api-sqlgetdiagrec
+ 'sql-api-sqlcolattribute
+ 'sql-api-sqlgetenvattr
+ 'sql-api-sqlcopydesc
+ 'sql-api-sqlgetstmtattr
+ 'sql-api-sqlendtran
+ 'sql-api-sqlsetconnectattr
+ 'sql-api-sqlfetchscroll
+ 'sql-api-sqlfreehandle
+ 'sql-api-sqlgetconnectattr
+ 'sql-api-sqlsetdescfield
+ 'sql-api-sqlsetdescrec
+ 'sql-api-sqlsetenvattr
+ 'sql-api-sqlsetstmtattr
+ 'sql-api-sqlbulkoperations
+
+> (get-connect-attr hdbc attr)
+
+ ODBC 3.0. 
+
+ For the connection handle `hdbc', returns the value of an attribute 
+ given by the symbol `attr'.  The permissible values of `attr' and
+ the corresponding ranges of return values are:
+
+  'sql-attr-access-mode        'sql-mode-read-only, 'sql-mode-read-write
+  'sql-attr-async-enable       'sql-async-enable-off, 'sql-async-enable-on
+  'sql-attr-autocommit         'sql-autocommit-off, 'sql-autocommit-on
+  'sql-attr-auto-ipd           boolean
+  'sql-attr-connection-dead    'sql-cd-true, 'sql-cd-false
+  'sql-attr-connection-timeout exact integer
+  'sql-attr-current-catalog    string
+  'sql-attr-login-timeout      exact integer
+  'sql-attr-metadata-id        boolean
+  'sql-attr-odbc-cursors       'sql-cur-use-if-needed, 
+                               'sql-cur-use-odbc, 
+                               'sql-cur-use-driver
+  'sql-attr-packet-size        exact integer
+  'sql-attr-quiet-mode         exact integer
+  'sql-attr-trace              exact integer  
+  'sql-attr-tracefile          string 
+  'sql-attr-translate-lib      string
+  'sql-attr-translate-option   exact intger
+  'sql-attr-txn-isolation      'sql-txn-read-uncommitted, 
+                               'sql-txn-read-committed, 
+                               'sql-txn-repeatable-read, 
+			       'sql-txn-serializable
+
+ See an ODBC reference for the significance of these connection attributes.
+ Driver-specific attributes are not supported.
+
+> (get-connect-option hdbc option) 
+
+ ODBC 1.0, deprecated in favor of get-connect-attr. 
+
+ For a connection handle `hdbc', returns the value of the 
+ connection option specified by the symbol `option'.  
+ The permisible values of `option' are 
+
+  'sql-access-mode 
+  'sql-autocommit 
+  'sql-login-timeout
+  'sql-opt-trace    
+  'sql-opt-tracefile
+  'sql-translate-dll
+  'sql-translate-option
+  'sql-txn-isolation
+  'sql-current-qualifier
+  'sql-odbc-cursors
+  'sql-quiet-mode 
+  'sql-packet-size
+
+ The return values are as for `get-connect-attr' for the corresponding
+ attributes.  In that procedure, the corresponding attributes have `-attr-' 
+ in their symbols.
+
+> (set-connect-attr hdbc attr val)
+
+ ODBC 3.0.
+
+ For a connection handle `hdbc', sets the attribute indicated by the 
+ symbol `attr' to be `val'.  The type of `val' depends on `attr', 
+ as follows:
+
+  'sql-attr-access-mode        'sql-mode-read-only, 'sql-mode-read-write
+  'sql-attr-async-enable       'sql-async-enable-off, 'sql-async-enable-on
+  'sql-attr-autocommit         'sql-autocommit-off, 'sql-autocommit-on
+  'sql-attr-connection-timeout exact integer
+  'sql-attr-current-catalog    string
+  'sql-attr-login-timeout      exact integer
+  'sql-attr-metadata-id        boolean
+  'sql-attr-odbc-cursors       'sql-cur-use-if-needed, 
+                               'sql-cur-use-odbc, 
+                               'sql-cur-use-driver
+  'sql-attr-packet-size        exact integer
+  'sql-attr-quiet-mode         exact integer
+  'sql-attr-trace              exact integer  
+  'sql-attr-tracefile          string 
+  'sql-attr-translate-lib      string
+  'sql-attr-translate-option   exact intger
+  'sql-attr-txn-isolation      'sql-txn-read-uncommitted, 
+                               'sql-txn-read-committed, 
+                               'sql-txn-repeatable-read, 
+			       'sql-txn-serializable
+
+ Returns the value of `hdbc'.
+
+ Note that some connection attributes listed in the documentation
+ for `get-connect-attr' are not settable.  The type boolean 
+ above indicates that any Scheme value other than #f is
+ interpreted as true.
+
+ See an ODBC reference for the significance of these connection attributes.
+ Driver-specific attributes are not supported.
+
+> (set-connect-option hdbc option val) 
+
+ ODBC 1.0, deprecated in favor of set-connect-attr. 
+
+ For a connection handle `hdbc', sets the option indicated by the 
+ symbol `option' to be `val'.  The type of `val' depends on `attr'.
+ The permisible values of `option' are: 
+
+  'sql-access-mode 
+  'sql-autocommit 
+  'sql-login-timeout
+  'sql-opt-trace    
+  'sql-opt-tracefile
+  'sql-translate-dll
+  'sql-translate-option
+  'sql-txn-isolation
+  'sql-current-qualifier
+  'sql-odbc-cursors
+  'sql-quiet-mode 
+  'sql-packet-size
+
+ The type of `val' depends on `option', in the same way as corresponding
+ attributes in `set-connect-attr'.  The corresponding attributes in that
+ procedure have `-attr-' in their symbols.
+
+
+ Statements and Parameters
+ -------------------------
+
+> (prepare hstmt sql)
+
+ ODBC 1.0.
+
+ Compiles the SQL statement given by the string `sql' for the 
+ statement handle `hstmt'.  Returns the value of `hstmt'.  Once 
+ an SQL statement has been compiled for a statement handle, 
+ `sql-execute' can be called as many times as desired using that handle.
+ 
+> (sql-execute hstmt)
+
+ ODBC 1.0.
+
+ Executes the SQL statement associated with the statement handle 
+ `hstmt'.  The SQL statement must have been compiled using
+ `sql-prepare'.  When a statement executes, its parameters,
+ indicated by ?'s in the SQL text, are replaced by the values
+ bound to those parameters.  See `bind-parameter' and `bind-param'.
+ The value of `hstmt' is returned.
+
+> (exec-direct hstmt sql)
+
+ ODBC 1.0.
+
+ Compiles and executes the SQL statement `sql', a string, and 
+ associates that statement with the statement handle `hstmt'.  
+ When a statement executes, its parameters, indicated by ?'s in 
+ the SQL text, are replaced by the values bound to those parameters. 
+ See `bind-parameter' and `bind-param'.  The value of `hstmt' is
+ returned.
+
+> (native-sql hdbc sql)
+
+ ODBC 1.0.
+
+ Given a connection handle `hdbc' and an SQL statement `sql', returns 
+ a string indicating the SQL that would be passed to the
+ data source associated with the handle.
+
+> (param-data hstmt)
+
+ ODBC 1.0.
+
+ Returns the sql-buffer that is bound to the statement handle 
+ `hstmt'.  If no such buffer exists, an error occurs.
+
+> (put-data hstmt buff)
+
+ ODBC 1.0.
+
+ Given the statement handle `hstmt' and an sql-buffer `buff',
+ sends the buffer data to either 1) the parameter associated
+ with the statement, or 2) the column associated with the
+ statement, for use with bulk-operations or set-pos.  Returns the
+ value of `hstmt'.
+
+> (cancel hstmt)
+
+ ODBC 1.0.
+
+ Terminates processing of the statement given by the statement handle
+ `hstmt'.  Returns the value of `hstmt'.
+
+> (end-tran handle action)
+
+ ODBC 3.0.
+
+ Requests a commit or rollback for all transactions associated with 
+ `handle', which may be either an environment handle or a 
+ connection handle.  `action' is one of the symbols 
+ 'sql-commit or 'sql-rollback.  Returns the value of `handle'.
+
+> (transact henv hdbc action)
+
+ ODBC 1.0, deprecated in favor of end-tran.
+
+ Requests a commit or rollback for all transactions associated with 
+ either the environment handle `henv' or the connection handle `hdbc'. 
+ `action' is one of the symbols 'sql-commit or 'sql-rollback.
+ If `hdbc' is the symbol 'sql-null-hdbc, the action is performed
+ for the environment handle; otherwise, it is performed for the
+ connection handle.  Returns void.
+
+> (num-params hstmt)
+
+ ODBC 1.0.
+
+ Returns the number of parameters (placeholders indicated by a ?)
+ in the SQL associated with the statement handle `hstmt'.
+ The `prepare' procedure must be called before calling this 
+ procedure.
+
+> (bind-parameter hstmt num param-type sql-type col-size buff ind [digits])
+
+ ODBC 2.0.
+
+ Associates the sql-buffer `buff' with the parameter (a placeholder 
+ indicated by ? in an SQL statement) denoted by the statement 
+ handle `hstmt' and positive integer `num'.  The param-type is
+ one of the symbols 'sql-param-input, 'sql-param-output, or
+ 'sql-param-input-output.  `sql-type' is an SQL data type.
+ `col-size' is the number of bytes to be sent from the buffer 
+ to the parameter, or, if `sql-data-type' is any of 'sql-decimal,
+ 'sql-numeric, 'sql-float, 'sql-real, or 'sql-double, the number of
+ digits of precision used.  `ind' is an sql-indicator. The optional 
+ argument `digits' indicates the number of digits to the right of the 
+ decimal point, and is used if `sql-data-type' is 'sql-decimal, 
+ 'sql-numeric, 'sql-time, 'sql-timestamp, 'sql-type-time, 
+ 'sql-type-timestamp, 'sql-interval-second,  'sql-interval-day-to-second,  
+ 'sql-interval-hour-to-second, or 'sql-interval-minute-to-second.
+ Returns the value of `hstmt'.
+
+ The `prepare' procedure must be called before calling `bind-parameter'.
+
+> (param-options hstmt numrows)
+
+ ODBC 1.0, deprecated in favor of set-stmt-attr.
+
+ For the statement handle `hstmt', indicates to the ODBC driver the 
+ number of rows associated with each parameter.  `numrows' is 
+ an exact positive integer.  Returns the current row number.
+
+> (describe-param hstmt pos)
+
+ ODBC 1.0.
+
+ For the statement handle `hstmt', returns information about the
+ parameter at position `pos', a positive exact integer.  The
+ returned information is a list consisting of
+
+	- a symbol indicating an SQL data type, 
+	- an exact integer that denotes, depending on the data type, 
+           either the number of bytes expected by a data source for 
+	   the parameter, or the precision associated with the data type
+	- an exact integer denoting the number of trailing decimal digits 
+           expected in the column or expression associated with the parameter
+	- a symbol indicating the parameter may be associated with
+	   NULLs, either 'sql-no-nulls, 'sql-nullable, or
+           'sql-nullable-unknown.
+
+> (bind-param hstmt num sql-type col-size buff ind [digits])
+
+ ODBC 3.0, deprecated in favor of bind-parameter.
+
+ Associates the sql-buffer `buff' with the parameter (a placeholder 
+ indicated by ? in an SQL statement) denoted by the statement 
+ handle `hstmt' and positive integer `num'. The arguments are as 
+ for the same-named arguments of procedure `bind-parameter'; some arguments
+ are omitted for `bind-param'.  Note that `bind-param' always 
+ assumes an input parameter, unlike `bind-parameter', which takes 
+ an argument to indicate the parameter type.  Returns the value 
+ of `hstmt'.
+
+> (set-param hstmt num sql-type buff ind)
+
+ ODBC 1.0, deprecated in favor of bind-parameter.
+
+ Associates the sql-buffer `buff' with the parameter (a placeholder 
+ indicated by ? in an SQL statement) denoted by the statement 
+ handle `hstmt' and positive integer `num'.  `sql-type' is an SQL 
+ data type.  `ind' is an sql-indicator.  Returns the value of 
+ `hstmt'. 
+
+> (get-stmt-attr hstmt attr)
+
+ ODBC 3.0.
+
+ For the statement handle `hstmt', returns the value of its 
+ associated attribute `attr'.  The statement handle attributes 
+ and their possible values are:
+
+   attr                               returns      
+   ----                               ------- 
+   'sql-attr-app-param-desc           an APD descriptor handle
+   'sql-attr-app-row-desc             an ARD descriptor handle
+   'sql-attr-async-enable             'sql-async-enable-off, or
+                                      'sql-async-enable-on
+   'sql-attr-concurrency              'sql-concur-read-only, or
+                                      'sql-concur-lock, or
+                                      'sql-concur-rowver, or
+                                      'sql-concur-values
+   'sql-attr-cursor-scrollable        'sql-nonscrollable, or
+                                      'sql-scrollable
+   'sql-attr-cursor-sensitivity       'sql-insensitive, or
+                                      'sql-sensitive, or
+                                      'sql-unspecified
+   'sql-attr-cursor-type              'sql-cursor-forward-only, or
+                                      'sql-cursor-static, or
+                                      'sql-cursor-keyset-driven, or
+                                      'sql-cursor-dynamic
+   'sql-attr-enable-auto-ipd          boolean
+   'sql-attr-fetch-bookmark-ptr       unsigned integer
+   'sql-attr-imp-param-desc           an IPD descriptor handle
+   'sql-attr-imp-row-desc             an IRD descriptor handle
+   'sql-attr-keyset-size              unsigned integer
+   'sql-attr-max-length               unsigned integer
+   'sql-attr-max-rows                 unsigned integer
+   'sql-attr-metadata-id              boolean
+   'sql-attr-noscan                   'sql-noscan-off, or
+                                      'sql-noscan-on
+   'sql-attr-param-bind-offset-ptr    sql-boxed-uint 
+   'sql-attr-param-bind-type          'sql-param-bind-by-column, or
+                                      unsigned integer
+   'sql-attr-param-operation-ptr      sql-op-parms (see read-op-parms, below)
+   'sql-attr-param-status-ptr         row-status (see below)
+   'sql-attr-params-processed-ptr     sql-boxed-uint
+   'sql-attr-paramset-size            unsigned integer
+   'sql-attr-query-timeout            unsigned integer  
+   'sql-attr-retrieve-data            'sql-rd-on, or
+                                      'sql-rd-off
+   'sql-attr-row-array-size           unsigned integer
+   'sql-attr-row-bind-offset-ptr      sql-boxed-uint 
+   'sql-attr-row-bind-type            'sql-bind-by-column, or
+                                      unsigned integer
+   'sql-attr-row-number               unsigned integer
+   'sql-attr-row-operation-ptr        op-parms (see read-op-parms, below)
+   'sql-attr-row-status-ptr           row-status (see read-row-status, below)
+   'sql-attr-rows-fetched-ptr         sql-boxed-uint
+   'sql-attr-simulate-cursor          'sql-sc-non-unique, or
+                                      'sql-sc-try-unique, or
+                                      'sql-sc-unique
+   'sql-attr-use-bookmarks            'sql-ub-off, or
+                                      'sql-ub-variable, or
+                                      'sql-ub-on 
+
+ See an ODBC reference for information about the significance of
+ these attributes.  The type `sql-boxed-uint' is a Scheme representation
+ of a pointer value.  See `make-boxed-uint' and `read-boxed-uint', below.
+ An instance of the type `sql-op-parms' is a value that encapsulates an 
+ array whose elements are either 'sql-param-proceed or
+ 'sql-param-ignore.  See `read-op-parms', below.  An instance
+ of the type `sql-row-status' encapsulates an array, one element for 
+ each parameter in the statement, each with one of the values:
+
+     'sql-param-success 
+     'sql-param-success-with-info
+     'sql-param-error
+     'sql-param-unused
+     'sql-param-diag-unavilable
+
+> (get-stmt-option hstmt option)
+
+ ODBC 1.0, deprecated in favor of get-stmt-attr.
+
+ For the statement handle `hstmt', returns the value of its 
+ associated `option'.  The statement handle options 
+ and their return values are:
+
+   option                             returns      
+   ------                             ------- 
+   'sql-async-enable                  'sql-async-enable-off, or
+                                      'sql-async-enable-on
+   'sql-bind-type                     'sql-param-bind-by-column, or
+                                      unsigned integer
+   'sql-concurrency                   'sql-concur-read-only, or
+                                      'sql-concur-lock, or
+                                      'sql-concur-rowver, or
+                                      'sql-concur-values
+   'sql-cursor-type                   'sql-cursor-forward-only, or
+                                      'sql-cursor-static, or
+                                      'sql-cursor-keyset-driven, or
+                                      'sql-cursor-dynamic
+   'sql-keyset-size                   unsigned integer
+   'sql-max-length                    unsigned integer
+   'sql-max-rows                      unsigned integer
+   'sql-noscan                        'sql-noscan-off, or
+                                      'sql-noscan-on
+   'sql-query-timeout                 unsigned integer  
+   'sql-retrieve-data                 'sql-rd-on, or
+                                      'sql-rd-off
+   'sql-rowset-size                   unsigned integer
+   'sql-simulate-cursor               'sql-sc-non-unique, or
+                                      'sql-sc-try-unique, or
+                                      'sql-sc-unique
+   'sql-use-bookmarks                 'sql-ub-off, or
+                                      'sql-ub-variable, or
+                                      'sql-ub-on 
+
+ See an ODBC reference for the significance of these options.
+
+> (set-stmt-attr hstmt attr val)
+  
+ ODBC 3.0.
+
+ For the statement handle `hstmt', sets its associated attribute `attr'
+ to the value `val'.  See `get-stmt-attr' for attributes and 
+ their possible values.  Returns the value of `hstmt'. 
+
+> (set-stmt-option hstmt attr val)
+  
+ ODBC 1.0, deprecated in favor of set-stmt-attr.
+
+ For the statement handle `hstmt', sets its associated `option'
+ to the value `val'.  See `get-stmt-option' for options and 
+ their possible values.  Returns the value of `hstmt'.
+
+ Descriptors
+ -----------
+
+> (copy-desc hdesc-src hdesc-target)
+
+ ODBC 3.0.
+
+ Copies information from descriptor handle `hdesc-src' to
+ descriptor handle `hdesc-target'.  Returns the value of 
+ `hdesc-src'.
+
+> (get-desc-rec hdesc recnum)
+
+ ODBC 3.0.
+
+ Given a descriptor handle `hdesc' and record number 
+ `recnum', a positive exact integer, returns a list 
+ of values pertaining to the descriptor record.  The first
+ element of that list is a string, the name of the parameter or column 
+ associated with the descriptor record; the second element
+ is a symbol indicating a concise SQL data type (see SQL data
+ types, below); the third element is a symbol that indicates an 
+ interval subtype for the types 'sql-datetime or 'sql-interval, 
+ otherwise 'no-subtype; the fourth element is an exact integer 
+ indicating the byte length of the parameter or column; the fifth 
+ element is an exact integer indicating the number of digits of 
+ precision for the parameter or column (only relevant for numeric data 
+ types); the sixth element is an exact integer indicating the number of
+ digits to the right of the decimal point used for data in the
+ column or parameter; while the seventh element is one of 
+ 'sql-no-nulls, 'sql-nullable, or 'sql-nullable-unknown, indicating
+ whether the parameter or column may have NULL values.
+
+> (set-desc-rec hdesc recnum type subtype length precision scale buff len ind)
+
+ ODBC 3.0.
+
+ For the descriptor record denoted by the descriptor handle `hdesc' and
+ positive exact integer `recnum', sets its associated information.
+ `type' is a symbol indicating a concise SQL or C data type (see SQL data
+ types, below); `subtype' is a symbol indicating a subtype for the types 
+ 'sql-datetime or 'sql-interval, or it may be 'no-subtype; 
+ `len' is an sql-length (see make-length and read-length, below), which 
+ should be initialized to the desired length of the column or parameter 
+ associated with the descriptor record; `ind' is an sql-indicator
+ (see Indicators, below).  Returns the value of `hdesc'.
+
+> (get-desc-field hdesc recnum field)
+
+ ODBC 3.0.
+
+ For the descriptor handle `hdesc', returns the value of a field
+ in the descriptor record with index `recnum', an integer. `field' is a 
+ symbol indicating the field within that record.
+
+ Valid values of `field' and their return types are listed below.
+ Please consult an ODBC reference for the significance of these
+ fields.
+
+ field                                    returns
+ -----                                    -------
+ 'sql-desc-alloc-type                     integer
+ 'sql-desc-array-size                     unsigned integer
+ 'sql-desc-array-status-ptr               array status indicator
+ 'sql-desc-bind-offset-ptr                binding offset
+ 'sql-desc-bind-type                      integer
+ 'sql-desc-count                          integer
+ 'sql-desc-rows-processed-ptr             rows-processed
+ 'sql-desc-auto-unique-value              integer
+ 'sql-desc-base-column-name               string 
+ 'sql-desc-case-sensitive                 boolean
+ 'sql-desc-concise-type                   SQL data type 
+ 'sql-desc-base-table-name                string
+ 'sql-desc-catalog-name                   string
+ 'sql-desc-data-ptr                       sql-buffer 
+ 'sql-desc-datetime-interval-code         'sql-code-date, or 
+                                          'sql-code-time, or
+                                          'sql-code-timestamp, or
+                                          'sql-code-day, or
+                                          'sql-code-day-to-hour, or
+                                          'sql-code-day-to-minute, or
+                                          'sql-code-day-to-second, or
+                                          'sql-code-hour, or
+                                          'sql-code-hour-to-minute, or
+                                          'sql-code-hour-to-second, or 
+                                          'sql-code-minute, or
+                                          'sql-code-minute-to-second, or
+                                          'sql-code-month, or
+                                          'sql-code-second, or
+                                          'sql-code-year, or
+                                          'sql-code-year-to-month
+ 'sql-desc-datetime-interval-precision    integer
+ 'sql-desc-display-size                   integer 
+ 'sql-desc-fixed-prec-scale               boolean
+ 'sql-desc-indicator-ptr                  sql-indicator
+ 'sql-desc-label                          string
+ 'sql-desc-length                         unsigned length
+ 'sql-desc-literal-prefix                 string
+ 'sql-desc-literal-suffix                 string
+ 'sql-desc-local-type-name                string
+ 'sql-desc-name                           string
+ 'sql-desc-nullable                       'sql-nullable, or 
+                                          'sql-no-nulls, or 
+                                          'sql-nullable-unknown
+ 'sql-desc-num-prec-radix                 integer
+ 'sql-desc-octet-length                   integer
+ 'sql-desc-octet-length-ptr               octet-length
+ 'sql-desc-parameter-type                 'sql-param-input, or 
+                                          'sql-param-output, or 
+                                          'sql-param-input-output
+ 'sql-desc-precision                      integer
+ 'sql-desc-rowver                         boolean
+ 'sql-desc-scale                          integer
+ 'sql-desc-schema-name                    string
+ 'sql-desc-searchable                     for ODBC 3.0 or greater:
+                                          'sql-pred-char, or 
+                                          'sql-pred-basic, or 
+                                          'sql-pred-none, or 
+					  'sql-pred-searchable 
+                                          for earlier versions:
+                                          'sql-all-except-like, or
+                                          'sql-like-only, or 
+					  'sql-searchable, or 
+                                          'sql-unsearchable
+ 'sql-desc-table-name                     string
+ 'sql-desc-type                           SQL data type (except intervals)
+ 'sql-desc-type-name                      string
+ 'sql-desc-unnamed                        'sql-named or 'sql-unnamed
+ 'sql-desc-unsigned                       boolean
+ 'sql-desc-updatable                      'sql-attr-readonly, or
+                                          'sql-attr-write, or
+                                          'sql-attr-readwrite-unknown
+
+> (set-desc-field hdesc recnum field val)
+  
+ ODBC 3.0.
+
+ For the descriptor handle `hdesc', sets the field indicated 
+ by the symbol `field' in the record with index `recnum', an integer, 
+ to the value `val'.  See get-desc-field for valid values of 
+ `field' and corresponding types for `val'.  Returns the value of 
+ `hdesc'.
+
+ Cursors
+ -------
+
+> (get-cursor-name hstmt)
+
+  ODBC 1.0.
+
+  Returns a string naming the cursor associated with the statement 
+  handle `hstmt'.
+
+> (set-cursor-name hstmt name)
+
+  ODBC 1.0.
+
+  Assigns the string `name' as the name of the cursor associated with 
+  the statement handle `hstmt'.  Returns the value of `hstmt'.
+
+> (close-cursor hstmt)
+
+  ODBC 3.0.
+
+  Closes the cursor associated with the statement handle `hstmt',
+  discarding any pending results.  Returns the value of `hstmt'.
+
+ Columns and data retrieval
+ -------------------------------
+
+ Data in a relational database is organized into tables consisting
+ of rows and columns.  A column corresponds to a field in the
+ database.  A row is an individual data record. 
+
+> (num-result-cols hstmt)
+
+ ODBC 1.0.
+
+ Returns the number of data columns in the data set associated with
+ the statement handle `hstmt'.
+
+> (describe-col hstmt colnum)
+
+ ODBC 1.0.
+
+ Given the statement handle `hstmt' and the exact integer `colnum', 
+ indicating a column number, returns a list of information describing
+ a column in a data set.  The first element in the list is a 
+ string giving the name of the column; the second element is a 
+ symbol indicating its SQL data type (see SQL data types, below);
+ the third element is the maximum byte length of data for the 
+ column; the fourth element is either the number of digits to the right
+ of the decimal point, for relevant data types (see SQL data types), 
+ otherwise 0; the fifth element is a symbol indicating whether the column 
+ accepts NULL entries, either 'sql-no-nulls, 'sql-nullable, or
+ 'sql-nullable-unknown.
+
+> (col-attribute hstmt colnum attr)
+
+ ODBC 3.0.
+
+ Given the statement handle `hstmt', an exact integer `colnum', 
+ indicating a column number, and the symbol `attr', indicating a
+ column attribute, returns the value of the column attribute.
+ Columns are numbered starting at 1.  The attributes and their 
+ associated types are
+
+   attr                             returns
+   ----                             -------
+   'sql-desc-count                  integer
+   'sql-desc-auto-unique-value      boolean
+   'sql-desc-base-column-name       string
+   'sql-desc-base-table-name        string
+   'sql-desc-case-sensitive         boolean
+   'sql-desc-catalog-name           string
+   'sql-desc-concise-type           SQL data type 
+   'sql-desc-data-ptr               sql-buffer
+   'sql-desc-display-size           integer
+   'sql-desc-fixed-prec-scale       boolean
+   'sql-desc-label                  string
+   'sql-desc-length                 integer
+   'sql-desc-literal-prefix         string
+   'sql-desc-literal-suffix         string
+   'sql-desc-local-type-name        string
+   'sql-desc-name                   string
+   'sql-desc-nullable               'sql-nullable, or
+                                    'sql-no-nulls, or
+                                    'sql-nullable-unknown 
+   'sql-desc-num-prec-radix         integer
+   'sql-desc-octet-length           integer
+   'sql-desc-precision              integer
+   'sql-desc-scale                  integer 
+   'sql-desc-schema-name            string
+   'sql-desc-searchable             ODBC 3.0 or greater:
+                                    'sql-pred-char, or
+                                    'sql-pred-basic, or
+                                    'sql-pred-none, or
+                                    'sql-pred-searchable
+	                            earlier versions of ODBC:
+                                    'sql-like-only, or
+                                    'sql-all-except-like, or
+                                    'sql-searchable, or 
+                                    'sql-unsearchable
+   'sql-desc-table-name             string
+   'sql-desc-type                   concise SQL data type 
+   'sql-desc-type-name              string
+   'sql-desc-unnamed                'sql-named, or
+                                    'sql-unnamed  
+   'sql-desc-unsigned               boolean 
+   'sql-desc-updatable              'sql-attr-readonly, or
+                                    'sql-attr-write, or
+                                    'sql-attr-readwrite-unknown
+
+> (col-attributes hstmt colnum attr)
+
+ ODBC 1.0, deprecated in favor of col-attribute.
+
+ Given the statement handle `hstmt', an exact integer `colnum', 
+ indicating a column number, and the symbol `attr', indicating a
+ column attribute, returns the value of the column attribute.
+ Columns are numbered starting at 1.  The attributes and their 
+ associated types are
+
+   attr                             returns
+   ----                             -------
+   'sql-column-count                integer
+   'sql-column-name                 string
+   'sql-column-type                 SQL data type 
+   'sql-column-length               integer 
+   'sql-column-precision            integer
+   'sql-column-scale                integer
+   'sql-column-display-size         integer
+   'sql-column-nullable             'sql-no-nulls, or
+                                    'sql-nullable
+   'sql-column-unsigned             boolean
+   'sql-column-money                boolean
+   'sql-column-updatable            'sql-attr-readonly, or
+                                    'sql-attr-write, or
+                                    'sql-attr-readwrite-unknown 
+   'sql-column-auto-increment       boolean
+   'sql-column-case-sensitive       boolean
+   'sql-column-searchable           'sql-searchable, or
+                                    'sql-like-only, or
+                                    'sql-all-except-like, or
+                                    'sql-unsearchable   
+   'sql-column-type-name            string 
+   'sql-column-table-name           string
+   'sql-column-owner-name           string
+   'sql-column-qualifier-name       string 
+   'sql-column-label                string
+
+> (bind-col hstmt colnum buff ind)
+
+ ODBC 1.0.
+
+ Associates the sql-buffer `buff' and sql-indicator `ind' 
+ with a column of data denoted by the statement handle `hstmt'
+ and column numer `colnum', an integer.  Returns the value 
+ of `hstmt'.  
+ 
+> (fetch hstmt)
+
+ ODBC 1.0.
+
+ Retrieves data in the current row of the data set for 
+ the statement handle `hstmt' into the sql-buffers
+ bound to the data set's columns, and sets the columns' 
+ associated sql-indicator's.  Returns the value of `hstmt'.
+ For columns without bound sql-buffers, `get-data' can be used 
+ to retrieve data following a `fetch'.  
+
+> (get-data hstmt colnum buff ind)
+
+ Retrieves data in the current row of the data set for 
+ the column denoted by the statement handle `hstmt' 
+ and column number `colnum', an integer, into the sql-buffer 
+ `buff' and sets the sql-indicator `ind'.  Returns the value of 
+ `hstmt'. `get-data' allows column data to be retrieved without 
+ binding columns to buffers.
+
+> (fetch-scroll hstmt orient [rownum])
+
+ ODBC 3.0.
+
+ Fetches multiple rows of data in a data set associated with
+ the statement handle `hstmt'.  `orient' indicates which rows
+ to fetch, and may be one of the symbols 
+
+   'sql-fetch-first              first rowset 
+   'sql-fetch-next               next rowset
+   'sql-fetch-prior              previous rowset
+   'sql-fetch-last               last rowset 
+   'sql-fetch-absolute   *       rowset starting at `rownum'
+   'sql-fetch-relative   *       rowset relative to current,
+                                  using `rownum' (may be negative)
+   'sql-fetch-bookmark   *       rowset relative to 
+                                  'sql-attr-fetch-bookmark-ptr
+                                  statement attribute
+
+ The `rownum' parameter must be supplied when `orient' is one
+ of those marked with `*' above.  fetch-scroll returns the value of 
+ `hstmt'.  The size of rowsets is specified by the 
+ 'sql-attr-row-array-size statement attribute (see 
+ `get-stmt-attr' and `set-stmt-attr').  See an ODBC reference for more 
+ information on using rowsets.
+
+> (set-scroll-options hstmt concurrency keyset size)
+
+ ODBC 1.0, deprecated in favor of get-info and set-stmt-attr.
+
+ Sets cursor scrolling options for the statement handle 
+ `hstmt'.  `concurrency' is one of
+
+   'sql-concur-read-only      updates and deletes not permitted
+   'sql-concur-lock           updates and deletes permitted
+   'sql-concur-rowver         compares row versions for concurrency 
+                                control
+   'sql-concur-values         compares values for concurrency control
+
+ `keyset' is one of
+
+   'sql-scroll-forward-only   only forward scrolling
+   'sql-scroll-static         no scrolling
+   'sql-scroll-keyset-driven  cursor uses keys for scrolling
+   'sql-scroll-dynamic        use `size' parameter for keyset size
+
+ `size', a nonnegative exact integer, gives the size of 
+ rowsets when using `extended-fetch'.  Returns the value of `hstmt'.
+
+> (extended-fetch hstmt orientation [rownum])
+
+ ODBC 1.0, deprecated in favor of fetch-scroll.
+
+ Retrieves a rowset from a result data set for the statement handle
+ `hstmt' and returns a row-status value (see Row Status, below).
+ `orientation' indicates which rowset is to be retrieved, one of
+
+   'sql-fetch-first      first rowset in the data set
+   'sql-fetch-next       next rowset in the data set
+   'sql-fetch-prior      prior rowset in the data set
+   'sql-fetch-last       last rowset in the data set
+   'sql-fetch-absolute * fetches the rowset starting at the row
+                           given by `rownum'
+   'sql-fetch-relative * fetches the rowset `rownum' rows from
+                           the start row of the current rowset
+   'sql-fetch-bookmark * fetches the rowset, interpreting 
+                           `rownum' as a bookmark
+
+ The `rownum' argument is an integer, which may be negative.  
+ It must be provided if `orientation' is one of those marked
+ with `*' above.
+
+> (more-results hstmt)
+
+ ODBC 1.0.
+
+ Retrieves the next data set for the statement handle `hstmt', whose
+ value is returned by the procedure.  `more-results', which moves between 
+ data sets, is distinguished from procedures such as `fetch', which return 
+ results within data sets.  
+
+> (set-pos hstmt rownum operation lock)
+
+ ODBC 1.0.
+
+ Sets a cursor position for the statement handle `hstmt'
+ and updates the data source.  `rownum', a nonnegative exact 
+ integer, specifies the ordinal position of the row within the 
+ current rowset where `operation' is to occur.  A value of 0 
+ indicates that the operation is to occur on every row in the
+ rowset.
+ 
+`operation' is one of 
+
+   'sql-position   positions the cursor at the indicated row
+   'sql-refresh    refreshes data in buffers associated with
+                     the rowset indicated by `rownum'
+   'sql-add        a new row is added to the data source (but see below)
+   'sql-update     data in buffers is used to update the rowset
+   'sql-delete     deletes the indicated row from the data source
+
+ `set-pos' with 'sql-add is deprecated in favor of `bulk-operations' 
+ with 'sql-add.
+ 
+ `lock' indicates the lock status for the row or rows after the
+ operation is performed, one of
+
+   'sql-lock-no-change   use lock status before operation performed
+   'sql-lock-exclusive   no other application or connection can
+                           access
+   'sql-lock-unlock      no lock restrictions on access 
+
+ set-pos returns the value of `hstmt'.
+
+> (bulk-operations hstmt operation)
+
+ ODBC 3.0.
+
+ Performs bulk inserts and bulk bookmark operations on the data source
+ associated with the statement handle `hstmt'. `operation' may
+ be one of
+
+   'sql-add                  adds new rows
+   'sql-update-by-bookmark   updates rows identified by a bookmark
+   'sql-delete-by-bookmark   deletes rows identified by a bookmark
+   'sql-fetch-by-bookmark    retrieves rows identified by a bookmark
+
+ Returns the value of `hstmt'. 
+
+ The details of using bulk-operations are beyond the scope of this
+ documentation.  Consult an ODBC reference for more information.
+
+> (row-count hstmt)
+
+ ODBC 1.0.
+
+ For the data source associated with the statement handle `hstmt', 
+ returns the number of rows affected by the most recent INSERT, 
+ UPDATE, or DELETE operation.
+
+ Metadata
+ --------
+
+> (column-privileges hstmt catalog schema table column)
+
+ ODBC 1.0.
+
+ Creates a result data set describing column privileges in the current 
+ data source.  There are at least eight columns in the resulting data set; a
+ driver may add columns.  The contents of those columns are beyond the scope 
+ of this documentation; consult an ODBC reference for details.
+ 
+ `hstmt' is a statement handle, and its value is returned by the 
+ procedure.  `catalog', `schema', `table', and `column' are strings.  
+ `column' may contain an underscore "_" indicating a single-character 
+ wildcard, or a percent sign "%", which matches zero or more characters.
+
+> (columns hstmt catalog schema table column)
+
+ ODBC 1.0. 
+
+ Creates a result data set describing columns in the current data source.
+ There are at least eighteen columns in the resulting data set; a
+ driver may add columns.  The contents of those columns are beyond the scope 
+ of this documentation; consult an ODBC reference for details.
+ 
+ `hstmt' is a statement handle, whose value is returned by the procedure. 
+ `catalog', `schema', `table', and `column' are strings.  `table' and 
+ `column' may contain an underscore "_" indicating a single-character 
+ wildcard, or a percent sign "%", which matches zero or more characters.
+
+> (foreign-keys hstmt catalog schema table fk-catalog fk-schema fk-table)
+
+ ODBC 1.0.
+
+ Creates a result data set containing foreign key information for the
+ specified table. There are fourteen ODBC-defined columns in the resulting 
+ data set; a driver may add columns. The contents of those columns are beyond 
+ the scope of this documentation; consult an ODBC reference for details.
+ 
+ `hstmt' is a statement handle; its value is returned by the procedure.
+ `catalog', `schema', `table', `fk-catalog', `fk-schema', and `fk-table' 
+ are all strings.  `catalog', `schema', and `table' specify a table 
+ containing a primary key, while  `fk-catalog', `fk-schema', and `fk-table' 
+ specify a table containing a foreign key.
+
+> (get-type-info hstmt type)
+
+ ODBC 1.0.
+
+ Given a statement handle `hstmt' and a symbol `type' indicating an 
+ SQL data type (see SQL data types, below), creates a result data set 
+ describing support for that data type in the current data source.
+ Returns the value of `hstmt'.  There are at least nineteen columns in 
+ the resulting data set; a driver may add columns.  The contents of 
+ those columns are beyond the scope of this documentation; consult an
+ ODBC reference for details.
+
+> (primary-keys hstmt catalog schema table)
+
+ ODBC 1.0.
+
+ Creates a result data set containing the column names that make up the 
+ primary  key for a table.  There are up to six ODBC-defined columns in 
+ the resulting data set; a driver may add columns.  The contents of those 
+ columns are beyond the scope of this documentation; consult an ODBC 
+ reference for details.
+ 
+ `hstmt' is a statement handle; its value is returned by the procedure.  
+ `catalog', `schema', and `table' are strings.
+
+> (procedure-columns hstmt catalog schema name column)
+
+ ODBC 1.0.
+
+ Creates a result data set containing the input and output parameters and
+ columns associated with registered procedures in the current data source.
+ There are nineteen ODBC-defined columns in the resulting data set; a 
+ driver may add columns.  The contents of those columns are beyond the 
+ scope of this documentation; consult an ODBC reference for details.
+
+ `hstmt' is a statement handle; its value is returned by the procedure.  
+ `catalog', `schema', `name', and `column' are strings.  `name' indicates 
+ a procedure name, while `column' is a column name.  `schema', `name', and 
+ `column' may contain an underscore "_" indicating a single-character 
+ wildcard, or a percent sign "%", which matches zero or more characters.
+
+> (procedures hstmt catalog schema name)
+
+ ODBC 1.0.
+
+ Creates a result data set containing the registered procedure names in the
+ current data source.  There are eight ODBC-defined columns in the 
+ resulting data set; a driver may add columns.  The contents of those 
+ columns are beyond the scope of this documentation; consult an ODBC 
+ reference for details.
+ 
+ `hstmt' is a statement handle; its value is returned by the procedure.  
+ `catalog', `schema', and `name' are strings.  `name' indicates a procedure 
+ name.  Both `schema' and `name' may contain an underscore "_" indicating 
+ a single-character wildcard, or a percent sign "%", which matches zero or 
+ more characters.
+
+> (table-privileges hstmt catalog schema table)
+
+ ODBC 1.0.
+
+ Creates a result data set describing tables in the system catalog.
+ Such a data set consists of at least seven string columns, consisting of
+ a catalog name, a schema name, a table name, the grantor of
+ table privileges, the grantee, the name of the privilege, and
+ a string indicating whether the grantee may transfer the privilege.  
+ Valid privilege names are "SELECT", "INSERT", "UPDATE", and "DELETE". 
+ The seventh column is either "YES", "NO", or a NULL.  Drivers may
+ add additional columns.
+
+ `hstmt' is a statement handle; its value is returned by the procedure.
+
+ `catalog', `schema', and `table' are strings to be matched when
+ searching the system catalog.  An underscore "_" indicates a 
+ single-character wildcard; a percent sign "%" matches zero or more
+ characters.
+
+> (tables hstmt catalog schema table table-type)
+
+ ODBC 1.0.
+
+ Creates a result data set giving information about the tables 
+ in the database system catalog.  Such a data set may be 
+ processed as ordinary data.  The result data set has at least five 
+ string columns, consisting of the catalog name, schema name, table
+ name, table type, and descriptive remarks.  Drivers may add additional
+ columns.  
+
+ `hstmt' is a statement handle, and its value is returned by the
+ procedure.
+
+ `catalog', `schema', `table', and `table-type' are strings 
+ to be matched when searching the system catalog.  `catalog' and
+ `schema' may be empty strings for unnamed catalogs and schemas.
+ In `catalog', `schema', and `table', an underscore "_" may be used 
+ as a single-character wildcard, while a percent sign "%" may be 
+ used to match zero or more arbitrary characters.
+
+ The following remarks apply only to ODBC 3.0 or greater:
+
+ `catalog' may also be the symbol 'sql-all-catalogs.  In that case, 
+ if `schema' and `table' are empty strings, the result data set consists 
+ of valid catalog names (the other columns are NULL's).
+
+ `schema' may also be the symbol 'sql-all-schemas.  In that case, if 
+ `catalog' and `table' are empty strings, the result data set
+ consists of valid schema names (the other columns are NULL's).
+
+ `table-type' may also be the symbol 'sql-all-table-types.  In that case,
+ if `catalog', `schema, and `table' are empty strings, the result data set
+ consists of valid table type names (the other columns are NULL's).
+
+ End of ODBC 3.0-or-greater-specific remarks.
+
+ Other factors may affect the result data set.  Please consult an
+ ODBC reference for more details.
+
+> (special-columns hstmt rowid catalog schema table scope nullable)
+
+ ODBC 1.0.
+
+ Creates a result data set describing primary key information in a 
+ given table.  There may be up to eight ODBC-defined columns in the 
+ resulting data set; a driver may add columns.  The contents of those 
+ columns are beyond the scope of this documentation; consult an ODBC 
+ reference for details.
+ 
+ `hstmt' is a statement handle, and its value is returned by the
+ procedure. `rowid' is either 'sql-best-rowid, indicating that the
+ result data set contains a column or columns that uniquely identify 
+ a row in a table; or 'sql-rowver, indicating that the result data set 
+ contains those columns that are automatically updated when a row value 
+ is updated by a transaction.  `catalog', `schema', and `table' are 
+ strings.  `scope' is either 'sql-scope-currow, indicating that the primary 
+ key sought is for the current row, or 'sql-scope-transaction, indicating 
+ that the primary key applies to the current transaction. `nullable' is 
+ either 'sql-no-nulls, which excludes columns in the result data set that 
+ may contain NULL, or 'sql-nullable, which allows such columns.
+
+> (statistics hstmt catalog schema table index-type accuracy)
+
+ ODBC 1.0.
+
+ Creates a result data set describing statistics about a table and its
+ indexes.  There are thirteen ODBC-defined columns in the resulting data 
+ set; a driver may add columns.  The contents of those columns are beyond 
+ the scope of this documentation; consult an ODBC reference for details.
+ 
+ `hstmt' is a statement handle, and its value is returned by the
+ procedure.  `catalog', `schema', and `table'  are strings. 
+ `index-type' is either 'sql-index-unique, indicating that only unique 
+ indexes are to be considered, or 'sql-index-all, indicating that all 
+ indexes are to be considered.  `accuracy' is either 'sql-quick, indicating 
+ that readily-available but perhaps stale data may be used when generating 
+ the data set, or 'sql-ensure, indicating that only up-to-date data is used.
+
+ Errors and Diagnostics
+ ----------------------
+
+> (get-diag-field handle recnum field) 
+
+ ODBC 3.0.
+
+ Returns the value of an individual field of a diagnostic header 
+ record or status record.  The type of the value depends on the field.
+
+ `handle' may be an environment handle, connection handle, statement 
+ handle, or descriptor handle.  `recnum' is a positive integer indicating 
+ which record contains the field.  `field' is a symbol, as listed below.
+
+ Please consult an ODBC reference for information on the significance 
+ of individual fields.  The valid values for `field' and their corresponding 
+ return types are:
+
+ field                                  returns
+ -----                                  -------
+ 'sql-diag-dynamic-function             string
+ 'sql-diag-connection-name              string
+ 'sql-diag-class-origin                 string
+ 'sql-diag-message-text                 string
+ 'sql-diag-server-name                  string
+ 'sql-diag-sqlstate                     string 
+ 'sql-diag-subclass-origin              string  
+ 'sql-diag-cursor-row-count             integer 
+ 'sql-diag-dynamic-function-code        integer
+ 'sql-diag-number                       integer
+ 'sql-diag-row-count                    integer
+ 'sql-diag-column-number                'sql-no-column-number, or 
+                                        'sql-column-number-unknown, or
+                                        integer 
+ 'sql-diag-native                       integer
+ 'sql-diag-row-number                   'sql-no-row-number, or 
+                                        'sql-row-number-unknown, or
+                                        integer 
+ 'sql-diag-returncode                   'sql-success, or 
+                                        'sql-no-data, or
+                                        'sql-invalid-handle, or
+                                        'sql-error, or
+                                        'sql-need-data, or
+                                        'sql-success-with-info
+
+> (get-diag-rec handle recnum) 
+ 
+ ODBC 3.0.
+
+ Returns a three-element list that describes the last ODBC error, 
+ as indicated by the exn-error, exn-with-info, or exn-no-data
+ exceptions.
+
+ The first element of the list is a five-character string indicating
+ an SQL state.  The second element of the list is an integer 
+ indicating an error code specific to the data source.  The third 
+ element is a string describing the error.  See an ODBC reference 
+ for more information on SQL states.
+
+ `handle' may be an environment handle, connection handle, statement 
+ handle, or descriptor handle.  `recnum' is a positive integer 
+ indicating a status record index.
+ 
+> (sql-error henv hdbc hstmt)
+
+ ODBC 1.0, deprecated in favor of get-diag-rec.
+
+ Returns a three-element list that describes the last ODBC error, 
+ as indicated by the exn-error, exn-with-info, or exn-no-data
+ exceptions.
+
+ The first element of the list is a five-character string indicating
+ an SQL state.  The second element of the list is an integer 
+ indicating an error code specific to the data source.  The third 
+ element is a string describing the error.  See an ODBC reference 
+ for more information on SQL states.
+
+ `henv' is an environment handle. `hdbc' is ordinarily a connection 
+ handle, and `hstmt' is ordinarily a statement handle.  For information 
+ about `henv', pass the symbol 'sql-null-hdbc for `hdbc' and the
+ symbol 'sql-null-hstmt for `hstmt'.  For information about `hdbc',
+ when it is a connection handle, pass 'sql-null-hstmt for `hstmt'.
+
+ Utilities
+ ---------
+
+> (make-indicator [n])  
+
+ Creates an sql-indicator.  `n' is a positive exact integer, which
+ defaults to 1.  A larger `n' may be used to create an sql-indicator 
+ representing an array of ODBC indicators.
+
+> (free-indicator! sql-indicator)
+
+ Allows the Scheme garbage collector to reclaim the memory used by 
+ the indicator `sql-indicator'.  If the indicator is subsequently 
+ accessed by the ODBC driver, unpredictable effects may occur.
+
+> (read-indicator sql-indicator [index])
+
+ Given an sql-indicator, returns its stored value or values.  
+ The optional parameter `index' is an index into the array of ODBC indicators 
+ represented by `sql-indicator'. If `index' is omitted, all the values 
+ associated with the sql-indicator are returned in a list.  The 
+ possible values are 'sql-no-total, 'sql-null-data, 'sql-nts, 
+ 'sql-column-ignore, 'sql-data-at-exec, a pair consisting of 
+ 'sql-len-data-at-exec and an integer, or an integer.
+ 
+ Please consult an ODBC reference for the significance of these 
+ values.
+
+> (set-indicator! sql-indicator val [n])
+
+ Stores a value in an sql-indicator.  The optional parameter `n' is 
+ an index into the array of ODBC indicators represented by `sql-indicator'.
+ The default value of `n' is 0.  The possible values of `val' are 
+ 'sql-no-total, 'sql-null-data, 'sql-nts, 'sql-column-ignore, 
+ 'sql-data-at-exec, a pair consisting of 'sql-len-data-at-exec and 
+ an integer, or an integer.
+ 
+ Please consult an ODBC reference for the significance of these 
+ values.
+
+> (make-length)
+
+ Creates an sql-length. 
+
+> (free-length! sql-length)
+
+ Allows the Scheme garbage collector to reclaim the memory used by 
+ the length `sql-length'.  If the length is subsequently accessed by 
+ the ODBC driver, unpredictable effects may occur.
+
+> (read-length an-sql-length)
+
+ Given an sql-length, returns its stored value, which is
+ an integer.
+
+> (make-buffer c-type [num-elts]) 
+
+ Creates an sql-buffer.  The `c-type' parameter is either
+  - a symbol denoting a C data type (see "C data types", below), or
+  - a pair consisting of 'sql-c-char or 'sql-c-wchar, and a 
+      positive exact integer indicating a string width
+ The optional parameter `num-elts' is a positive exact integer 
+ indicating the number of buffer elements (default = 1).  If `ctype' is 
+ 'sql-c-char or 'sql-c-wchar (not in a pair), the string width 
+ defaults to 1.
+
+ It is the responsibility of the programmer to make sure that 
+ buffers bound to columns have the correct type and adequate 
+ size for the column.  If a column has the incorrect type or 
+ is too small, unpredictable effects may occur.
+
+> (free-buffer! sql-buffer)
+
+ Allows the Scheme garbage collector to reclaim the memory used by 
+ the buffer `sql-buffer'.  If the buffer is subsequently accessed by 
+ the ODBC driver, unpredictable effects may occur.
+
+> (read-buffer sql-buffer [index]) 
+
+ Returns the contents of an sql-buffer.  `index' is a zero-based index
+ into the buffer.  If `index' is omitted, the entire buffer contents 
+ are returned, in a form appropriate to the type of data contained
+ in the buffer.  For most C data types, the buffer is read as a 
+ list; for buffers containing 'sql-c-binary, 'sql-c-varbookmark, 
+ and 'sql-c-bit elements, the buffer is read as a string.  If `index' 
+ is given, an individual element of the buffer is returned.   In the 
+ case of 'sql-c-wchar, an error occurs if the segment of the buffer 
+ to be read contains a character not representable as an ordinary 
+ character.  
+
+ SrPersist provides no guarantees that a buffer contains valid data.
+
+> (write-buffer! sql-buffer val [n]) 
+
+ Updates the contents of an sql-buffer.  The type of `val' 
+ depends on the C type used to create the buffer. The `n' parameter
+ is a nonnegative exact integer used to indicate an offset in the
+ buffer; the default is 0.
+
+> (make-row-status [num-rows])
+
+ Creates a new row status value.  The optional `num-rows' parameter
+ indicates how many rows the row-status-value represents.  The default
+ is 1.
+
+> (read-row-status sql-row-status [index])
+
+ Given a row status value, returns a symbol or list of symbols from 
+ '(sql-row-deleted sql-row-error sql-row-success sql-row-updated).
+ If the optional argument `index', a nonnegative exact integer, is
+ omitted, a list is returned.  If provided, `index' is interpreted 
+ as a zero-based index into an array of row status values, and a 
+ single symbol is returned.
+
+> (free-row-status! sql-row-status)
+
+ Allows the Scheme garbage collector to reclaim the memory used by 
+ the row status `sql-row-status'.  If the row status is subsequently 
+ accessed by the ODBC driver, unpredictable effects may occur.
+
+> (read-op-parms an-sql-op-parms)
+
+ Available when compiled for ODBC 3.0 or greater.
+ 
+ Given an sql-op-parms value, returns a list, each element of which 
+ is either 'sql-param-proceed or 'sql-param-ignore.
+
+> (make-boxed-uint unum)
+
+ Given an exact nonnegative number, returns an sql-boxed-uint.
+
+> (read-boxed-uint an-sql-boxed-uint)
+
+ Given an sql-boxed-uint, returns an unsigned integer value.
+
+> (free-boxed-uint an-sql-boxed-uint)
+
+ Allows the Scheme garbage collector to reclaim the memory used by 
+ an sql-boxed-uint.
+
+ SQL data types
+ --------------
+
+ Data stored in data sources have SQL data types.  In contrast, 
+ data in sql-buffer's have C data types.
+
+ The significance of most of these types should be clear.  Consult
+ an ODBC reference for more details.
+
+ 'sql-char
+ 'sql-varchar
+ 'sql-longvarchar
+ 'sql-wchar
+ 'sql-wvarchar
+ 'sql-wlongvarchar
+ 'sql-date
+ 'sql-time
+ 'sql-timestamp
+ 'sql-decimal
+ 'sql-numeric
+ 'sql-smallint
+ 'sql-integer
+ 'sql-real
+ 'sql-float
+ 'sql-double
+ 'sql-bit
+ 'sql-tinyint
+ 'sql-bigint
+ 'sql-binary
+ 'sql-varbinary
+ 'sql-longvarbinary
+ 'sql-interval-year
+ 'sql-interval-year-to-month
+ 'sql-interval-hour
+ 'sql-interval-minute
+ 'sql-interval-day-to-hour
+ 'sql-interval-day-to-minute
+ 'sql-interval-day-to-second
+ 'sql-interval-hour-to-minute
+ 'sql-interval-hour-to-second
+ 'sql-interval-minute-to-second
+
+ [ODBC 3.0 and greater]
+ 'sql-type-date
+ 'sql-type-time
+ 'sql-type-timestamp
+
+ [ODBC 3.5 and greater]
+ 'sql-guid
+
+ C data types
+ ------------
+
+ Data in sql-buffer's have C data types.  In contrast, data stored in 
+ data sources have SQL data types.
+
+ The significance of most of these types should be clear.  Consult
+ an ODBC reference for more details.
+
+ 'sql-c-char
+ 'sql-c-wchar
+ 'sql-c-long
+ 'sql-c-short
+ 'sql-c-float
+ 'sql-c-double
+ 'sql-c-date
+ 'sql-c-time
+ 'sql-c-timestamp
+ 'sql-c-binary
+ 'sql-c-bit
+ 'sql-c-tinyint
+ 'sql-c-slong
+ 'sql-c-sshort
+ 'sql-c-stinyint
+ 'sql-c-ulong
+ 'sql-c-ushort
+ 'sql-c-utinyint
+ 'sql-c-bookmark
+
+ [ODBC 3.0 or greater]
+ 'sql-c-numeric
+ 'sql-c-type-timestamp
+ 'sql-c-type-date
+ 'sql-c-type-time
+ 'sql-c-interval-year
+ 'sql-c-interval-month
+ 'sql-c-interval-day
+ 'sql-c-interval-hour
+ 'sql-c-interval-minute
+ 'sql-c-interval-second
+ 'sql-c-interval-year-to-month
+ 'sql-c-interval-day-to-hour
+ 'sql-c-interval-day-to-minute
+ 'sql-c-interval-day-to-second
+ 'sql-c-interval-hour-to-minute
+ 'sql-c-interval-hour-to-second
+ 'sql-c-interval-minute-to-second
+ 'sql-c-sbigint
+ 'sql-c-ubigint
+ 'sql-c-varbookmark
+
+  [ODBC 3.5 or greater]
+ 'sql-c-guid
+
+
+
diff --git a/collects/srpersist/info.ss b/collects/srpersist/info.ss
new file mode 100644
index 0000000000..c4c338a2f6
--- /dev/null
+++ b/collects/srpersist/info.ss
@@ -0,0 +1,18 @@
+;; info.ss for srpersist collection
+
+;; no .zo compilation necessary, since all the
+;; real code is in C++
+
+(module info (lib "infotab.ss" "setup")
+  (define name "SrPersist")
+  (define doc.txt "doc.txt")
+  (define help-desk-message
+     "Mz/Mr: (require (lib \"srpersist.ss\" \"srpersist\"))")
+  (define compile-omit-files
+    '("info.ss"
+      "srpersist.ss"))
+  (define blurb
+    (list
+      "SrPersist is an extension for using ODBC databases from Scheme."))
+  (define release-version "299")
+  (define release-iteration "0"))
diff --git a/collects/srpersist/private/sigs.ss b/collects/srpersist/private/sigs.ss
new file mode 100644
index 0000000000..535f9e3c1e
--- /dev/null
+++ b/collects/srpersist/private/sigs.ss
@@ -0,0 +1,362 @@
+;; sigs.ss for srpersist collection
+
+(module sigs mzscheme
+
+  (require (lib "unitsig.ss"))
+
+  (provide srpersist:odbc^)
+
+  (define-signature srpersist:odbc-1.0^
+
+   ; version info
+
+    (srp-version
+     compiled-odbc-version
+
+   ; utility
+
+     make-length
+     free-length!
+     read-length
+     make-boxed-uint	
+     read-boxed-uint	
+     free-boxed-uint!
+     make-indicator
+     free-indicator!
+     read-indicator
+     set-indicator!
+     make-row-status
+     read-row-status
+     free-row-status!
+     make-buffer
+     free-buffer!
+     read-buffer
+     write-buffer!
+
+     ; ODBC procedures 
+
+     alloc-connect
+     alloc-env
+     alloc-stmt
+     bind-col
+     cancel
+     columns
+     connect
+     data-sources
+     describe-col
+     disconnect
+     sql-error
+     exec-direct
+     sql-execute
+     fetch
+     free-connect
+     free-env
+     free-stmt
+     get-connect-option
+     get-cursor-name
+     get-data
+     get-functions
+     get-info
+     get-stmt-option
+     get-type-info
+     num-result-cols
+     param-data
+     prepare
+     put-data
+     row-count
+     set-connect-option
+     set-cursor-name
+     set-param
+     set-stmt-option
+     special-columns
+     statistics
+     tables
+     transact
+     driver-connect
+     browse-connect
+     col-attributes
+     column-privileges
+     describe-param
+     extended-fetch
+     foreign-keys
+     more-results
+     native-sql
+     num-params
+     param-options
+     primary-keys
+     procedure-columns
+     procedures
+     set-pos
+     table-privileges
+     set-scroll-options
+
+     ; implementation of ODBC macro
+
+     len-binary-attr
+
+     ; structures
+
+     struct:sql-date
+     make-sql-date
+     sql-date?
+     sql-date-year
+     set-sql-date-year!
+     sql-date-month
+     set-sql-date-month!
+     sql-date-day
+     set-sql-date-day!
+     struct:sql-time
+     make-sql-time
+     sql-time?
+     sql-time-hour
+     set-sql-time-hour!
+     sql-time-minute
+     set-sql-time-minute!
+     sql-time-second
+     set-sql-time-second!
+     struct:sql-timestamp
+     make-sql-timestamp
+     sql-timestamp?
+     sql-timestamp-year
+     set-sql-timestamp-year!
+     sql-timestamp-month
+     set-sql-timestamp-month!
+     sql-timestamp-day
+     set-sql-timestamp-day!
+     sql-timestamp-hour
+     set-sql-timestamp-hour!
+     sql-timestamp-minute
+     set-sql-timestamp-minute!
+     sql-timestamp-second
+     set-sql-timestamp-second!
+     sql-timestamp-fraction
+     set-sql-timestamp-fraction!
+     
+     ; exceptions
+
+     struct:exn-not-implemented
+     make-exn-not-implemented
+     exn-not-implemented?
+     struct:exn-with-info
+     make-exn-with-info
+     exn-with-info?
+     exn-with-info-val
+     set-exn-with-info-val!
+     struct:exn-invalid-handle
+     make-exn-invalid-handle
+     exn-invalid-handle?
+     struct:exn-error
+     make-exn-error
+     exn-error?
+     struct:exn-need-data
+     make-exn-need-data
+     exn-need-data?
+     exn-need-data-val
+     set-exn-need-data-val!
+     struct:exn-still-executing
+     make-exn-still-executing
+     exn-still-executing?
+     struct:exn-no-data
+     make-exn-no-data
+     exn-no-data?))
+  
+  (define-signature srpersist:odbc-2.0^
+
+    ;; ODBC procedures
+
+    ((open srpersist:odbc-1.0^)
+     bind-parameter
+     drivers))
+
+
+  (define-signature srpersist:odbc-3.0^
+
+    ((open srpersist:odbc-2.0^)
+
+     ;; utility 
+
+     read-op-parms
+
+     ;; ODBC procedures
+
+     alloc-handle
+     bind-param
+     bulk-operations
+     close-cursor
+     col-attribute
+     copy-desc
+     end-tran
+     fetch-scroll
+     free-handle
+     get-connect-attr
+     get-desc-field
+     get-desc-rec
+     get-diag-field
+     get-diag-rec
+     get-env-attr
+     get-stmt-attr
+     set-connect-attr
+     set-desc-field
+     set-desc-rec
+     set-env-attr
+     set-stmt-attr
+     
+     ;; structures
+
+     struct:sql-numeric
+     make-sql-numeric
+     sql-numeric?
+     sql-numeric-precision
+     set-sql-numeric-precision!
+     sql-numeric-scale
+     set-sql-numeric-scale!
+     sql-numeric-sign
+     set-sql-numeric-sign!
+     sql-numeric-val
+     set-sql-numeric-val!
+     struct:sql-year-interval
+     make-sql-year-interval
+     sql-year-interval?
+     sql-year-interval-sign
+     set-sql-year-interval-sign!
+     sql-year-interval-year
+     set-sql-year-interval-year!
+     struct:sql-month-interval
+     make-sql-month-interval
+     sql-month-interval?
+     sql-month-interval-sign
+     set-sql-month-interval-sign!
+     sql-month-interval-month
+     set-sql-month-interval-month!
+     struct:sql-day-interval
+     make-sql-day-interval
+     sql-day-interval?
+     sql-day-interval-sign
+     set-sql-day-interval-sign!
+     sql-day-interval-day
+     set-sql-day-interval-day!
+     struct:sql-hour-interval
+     make-sql-hour-interval
+     sql-hour-interval?
+     sql-hour-interval-sign
+     set-sql-hour-interval-sign!
+     sql-hour-interval-hour
+     set-sql-hour-interval-hour!
+     struct:sql-minute-interval
+     make-sql-minute-interval
+     sql-minute-interval?
+     sql-minute-interval-sign
+     set-sql-minute-interval-sign!
+     sql-minute-interval-minute
+     set-sql-minute-interval-minute!
+     struct:sql-second-interval
+     make-sql-second-interval
+     sql-second-interval?
+     sql-second-interval-sign
+     set-sql-second-interval-sign!
+     sql-second-interval-second
+     set-sql-second-interval-second!
+     struct:sql-year-to-month-interval
+     make-sql-year-to-month-interval
+     sql-year-to-month-interval?
+     sql-year-to-month-interval-sign
+     set-sql-year-to-month-interval-sign!
+     sql-year-to-month-interval-year
+     set-sql-year-to-month-interval-year!
+     sql-year-to-month-interval-month
+     set-sql-year-to-month-interval-month!
+     struct:sql-day-to-hour-interval
+     make-sql-day-to-hour-interval
+     sql-day-to-hour-interval?
+     sql-day-to-hour-interval-sign
+     set-sql-day-to-hour-interval-sign!
+     sql-day-to-hour-interval-day
+     set-sql-day-to-hour-interval-day!
+     sql-day-to-hour-interval-hour
+     set-sql-day-to-hour-interval-hour!
+     struct:sql-day-to-minute-interval
+     make-sql-day-to-minute-interval
+     sql-day-to-minute-interval?
+     sql-day-to-minute-interval-sign
+     set-sql-day-to-minute-interval-sign!
+     sql-day-to-minute-interval-day
+     set-sql-day-to-minute-interval-day!
+     sql-day-to-minute-interval-hour
+     set-sql-day-to-minute-interval-hour!
+     sql-day-to-minute-interval-minute
+     set-sql-day-to-minute-interval-minute!
+     struct:sql-day-to-second-interval
+     make-sql-day-to-second-interval
+     sql-day-to-second-interval?
+     sql-day-to-second-interval-sign
+     set-sql-day-to-second-interval-sign!
+     sql-day-to-second-interval-day
+     set-sql-day-to-second-interval-day!
+     sql-day-to-second-interval-hour
+     set-sql-day-to-second-interval-hour!
+     sql-day-to-second-interval-minute
+     set-sql-day-to-second-interval-minute!
+     sql-day-to-second-interval-second
+     set-sql-day-to-second-interval-second!
+     struct:sql-hour-to-minute-interval
+     make-sql-hour-to-minute-interval
+     sql-hour-to-minute-interval?
+     sql-hour-to-minute-interval-sign
+     set-sql-hour-to-minute-interval-sign!
+     sql-hour-to-minute-interval-hour
+     set-sql-hour-to-minute-interval-hour!
+     sql-hour-to-minute-interval-minute
+     set-sql-hour-to-minute-interval-minute!
+     struct:sql-hour-to-second-interval
+     make-sql-hour-to-second-interval
+     sql-hour-to-second-interval?
+     sql-hour-to-second-interval-sign
+     set-sql-hour-to-second-interval-sign!
+     sql-hour-to-second-interval-hour
+     set-sql-hour-to-second-interval-hour!
+     sql-hour-to-second-interval-minute
+     set-sql-hour-to-second-interval-minute!
+     sql-hour-to-second-interval-second
+     set-sql-hour-to-second-interval-second!
+     struct:sql-minute-to-second-interval
+     make-sql-minute-to-second-interval
+     sql-minute-to-second-interval?
+     sql-minute-to-second-interval-sign
+     set-sql-minute-to-second-interval-sign!
+     sql-minute-to-second-interval-minute
+     set-sql-minute-to-second-interval-minute!
+     sql-minute-to-second-interval-second
+     set-sql-minute-to-second-interval-second!))
+  
+  (define-signature srpersist:odbc-3.5^
+    
+    ((open srpersist:odbc-3.0^)
+     
+     struct:sql-guid
+     make-sql-guid
+     sql-guid?
+     sql-guid-data1
+     set-sql-guid-data1!
+     sql-guid-data2
+     set-sql-guid-data2!
+     sql-guid-data3
+     set-sql-guid-data3!
+     sql-guid-data4
+     set-sql-guid-data4!))
+
+  (define-signature srpersist:odbc^
+    
+    ((open srpersist:odbc-3.5^))))
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/collects/srpersist/srpersist.ss b/collects/srpersist/srpersist.ss
new file mode 100644
index 0000000000..c565509b9a
--- /dev/null
+++ b/collects/srpersist/srpersist.ss
@@ -0,0 +1,9 @@
+(module srpersist mzscheme
+  (require (lib "unitsig.ss"))
+  (require (lib "sigs.ss" "srpersist" "private"))
+  (require (lib "srpmain.ss" "srpersist" "private"))
+  (provide-signature-elements srpersist:odbc^))
+
+
+
+   	
diff --git a/collects/srpersist/tutorial.txt b/collects/srpersist/tutorial.txt
new file mode 100644
index 0000000000..92ebfc6786
--- /dev/null
+++ b/collects/srpersist/tutorial.txt
@@ -0,0 +1,189 @@
+SrPersist Tutorial
+==================
+
+If you look at the doc.txt file in the SrPersist collection,
+you soon realize that the ODBC standard is quite complex.
+It is not necessary to master the standard before using it.
+Performing simple data retrievals and insertions is not very 
+difficult.  This tutorial provides some simple examples that
+you can start with when writing your own code.
+
+This tutorial does not address issues of compiling and 
+installing SrPersist.  See the README file in the
+SrPersist source directory for such information.
+
+See the section "Loading" in doc.txt to learn how to load
+SrPersist into MzScheme or DrScheme.  From Help Desk,
+search for "SrPersist" and scroll down to that section.
+
+Allocating handles
+------------------
+
+Before you can connect to a database, you need to allocate
+an environment handle, and a connection handle:
+
+    (define henv (alloc-env))
+    (define hdbc (alloc-connect henv))
+
+We bind these identifiers to the handle values, so that
+we can refer to the handles at later points in the program.
+
+Getting a connection
+--------------------
+
+SrPersist provides three procedures to connect to a database,
+two of which we mention here.
+
+When getting started, you can use
+
+    (driver-connect hdbc "" 'sql-driver-prompt) 
+
+where `hdbc' is the connection handle just allocated.
+This procedure displays a dialog box, or series of them.
+From the dialog boxes, you should be able to choose 
+the database system and a particular database to
+connect to.  This procedure returns a string, which
+you can use in place of the empty string the next
+time you need to call this procedure.  The string 
+contains information about the database system and
+database you chose through the dialogs.  Using that 
+returned string, this procedure will not show a 
+dialog box.
+
+Alternatively, you can use
+
+    (connect hdbc dbms name password) 	   	       
+
+where again `hdbc' is the connection handle you've
+allocated.  `dbms', `name', and `password' are strings
+indicating a database system (a "data source" in ODBC 
+parlance), a login name, and login password.  Unlike
+driver-connect, you have to know the name of the
+database system, which may not be obvious.  To find out
+this information, you can call
+
+    (data-sources henv 'sql-fetch-first)
+
+to get a data source name and its description.  Calling
+data-sources with 'sql-fetch-next gets the next data source;
+you can continue making such calls until you've enumerated
+all possible data sources.
+
+Making a statement
+------------------
+
+Once your program is connected to a database system,
+you'll want to submit queries in the form of SQL. 
+Be patient, for it takes several steps to submit such 
+a query.
+
+First you'll need to allocate a statement handle
+using the existing connection handle: 
+
+    (define hstmt (alloc-stmt hdbc))
+
+We'll see that we can reuse this statement handle
+for several SQL queries.
+
+When you connected to the database system, you 
+chose some particular database.  The database system 
+may contain several databases.  SQL has the USE statement 
+to choose among them.  In SrPersist, we write:
+
+    (prepare hstmt "USE test_db")
+    (sql-execute hstmt)
+
+Note that some database systems, such as Microsoft Access, 
+do not allow you to switch databases in this way.  You can 
+think of prepare as performing a compilation step; sql-execute 
+runs the resulting code.
+
+Now suppose the database test_db contains a table 
+"people" that has columns for name, a string, and 
+age, an integer. 
+
+We can make a query to get the desired data from the 
+database.
+
+    (prepare hstmt "SELECT name,age FROM people")
+    (sql-execute hstmt)
+
+Conceptually, the statement above creates a new table,
+consisting of rows of data.  We need some location
+in our program to store the data.  ODBC uses buffers 
+for data storage.  SrPersist associates an ODBC C type 
+with each buffer.
+
+Assume that the name column consists of strings 
+no longer than 50 characters.  We create a 
+buffer to hold results:
+
+    (define name-buffer (make-buffer '(sql-c-char 50)))
+
+For the age column:
+
+    (define age-buffer (make-buffer 'sql-c-slong))
+
+There are ways to find out the types associated with columns,
+but unfortunately, it's a complicated business.  There are
+actually distinct types (SQL types) for the columns themselves, 
+and separate C types for buffers that receive their data.
+But 'sql-c-char is probably what you want for string buffers,
+and 'sql-c-slong for integer buffers.
+
+We'll need another kind of buffer, an "indicator":
+
+    (define name-indicator (make-indicator))
+    (define age-indicator (make-indicator))
+
+These indicators do not hold data, just status information.
+We can safely ignore their role for the remainder of this
+tutorial.
+
+Next, we wish to associate the buffers we've created with 
+the database columns:
+
+    (bind-col hstmt 1 name-buffer name-indicator)
+    (bind-col hstmt 2 age-buffer age-indicator)
+
+Columns are numbered from 1.  Although the people table
+may have had the name and age at any position, our 
+query above created the name column as column 1,
+and the age column as column 2.
+
+Now we can retrieve the data and print it out:
+
+    (with-handlers 
+     ([(lambda (exn) (exn-no-data? exn)) 
+       (lambda (exn) (printf "** End of data **~n"))])
+     (let loop ()
+       (fetch hstmt)
+       (printf "Name: ~a  Age: ~a~n" 
+	       (read-buffer name-buffer)
+	       (read-buffer age-buffer))
+       (loop)))
+
+The code loops through each row and prints the 
+values stored in the buffers.  When all the 
+data has been read, the call to fetch raises 
+the exn-no-data exception.
+
+Suppose we want to insert a new record into the table people.
+Assume that the table consists of the columns name, address,
+and age.  To perform the insertion, we simply write the 
+appropriate SQL, and run it:
+
+    (prepare hstmt 
+             (string-append "INSERT INTO people SET "
+                            "name=\"Joe Bloggs\","
+                            "address=\"123 Main Street\","
+                            "age=42")) 
+    (sql-execute hstmt)			    
+
+If you now perform the SELECT query above, and run the 
+given loop over the results, you should see the effect 
+of the insertion.
+
+While there's much more in the ODBC standard, this example
+code should give you the flavor of how it works.
+
diff --git a/collects/ssax/SSAX-code.scm b/collects/ssax/SSAX-code.scm
new file mode 100644
index 0000000000..15fca01a86
--- /dev/null
+++ b/collects/ssax/SSAX-code.scm
@@ -0,0 +1,47 @@
+(define-syntax run-test (syntax-rules (define) ((run-test "scan-exp" (define vars body)) (define vars (run-test "scan-exp" body))) ((run-test "scan-exp" ?body) (letrec-syntax ((scan-exp (syntax-rules (quote quasiquote !) ((scan-exp (quote ()) (k-head ! . args)) (k-head (quote ()) . args)) ((scan-exp (quote (hd . tl)) k) (scan-lit-lst (hd . tl) (do-wrap ! quasiquote k))) ((scan-exp (quasiquote (hd . tl)) k) (scan-lit-lst (hd . tl) (do-wrap ! quasiquote k))) ((scan-exp (quote x) (k-head ! . args)) (k-head (if (string? (quote x)) (string->symbol (quote x)) (quote x)) . args)) ((scan-exp (hd . tl) k) (scan-exp hd (do-tl ! scan-exp tl k))) ((scan-exp x (k-head ! . args)) (k-head x . args)))) (do-tl (syntax-rules (!) ((do-tl processed-hd fn () (k-head ! . args)) (k-head (processed-hd) . args)) ((do-tl processed-hd fn old-tl k) (fn old-tl (do-cons ! processed-hd k))))) (do-cons (syntax-rules (!) ((do-cons processed-tl processed-hd (k-head ! . args)) (k-head (processed-hd . processed-tl) . args)))) (do-wrap (syntax-rules (!) ((do-wrap val fn (k-head ! . args)) (k-head (fn val) . args)))) (do-finish (syntax-rules () ((do-finish new-body) new-body))) (scan-lit-lst (syntax-rules (quote unquote unquote-splicing !) ((scan-lit-lst (quote ()) (k-head ! . args)) (k-head (quote ()) . args)) ((scan-lit-lst (quote (hd . tl)) k) (do-tl quote scan-lit-lst ((hd . tl)) k)) ((scan-lit-lst (unquote x) k) (scan-exp x (do-wrap ! unquote k))) ((scan-lit-lst (unquote-splicing x) k) (scan-exp x (do-wrap ! unquote-splicing k))) ((scan-lit-lst (quote x) (k-head ! . args)) (k-head (unquote (if (string? (quote x)) (string->symbol (quote x)) (quote x))) . args)) ((scan-lit-lst (hd . tl) k) (scan-lit-lst hd (do-tl ! scan-lit-lst tl k))) ((scan-lit-lst x (k-head ! . args)) (k-head x . args))))) (scan-exp ?body (do-finish !)))) ((run-test body ...) (begin (run-test "scan-exp" body) ...))))
+(define (make-xml-token kind head) (cons kind head))
+(define xml-token? pair?)
+(define-syntax xml-token-kind (syntax-rules () ((xml-token-kind token) (car token))))
+(define-syntax xml-token-head (syntax-rules () ((xml-token-head token) (cdr token))))
+(define (string-whitespace? str) (let ((len (string-length str))) (cond ((zero? len) #t) ((= 1 len) (char-whitespace? (string-ref str 0))) ((= 2 len) (and (char-whitespace? (string-ref str 0)) (char-whitespace? (string-ref str 1)))) (else (let loop ((i 0)) (or (>= i len) (and (char-whitespace? (string-ref str i)) (loop (inc i)))))))))
+(define (assq-values val alist) (let loop ((alist alist) (scanned (quote ()))) (cond ((null? alist) (values #f scanned)) ((equal? val (caar alist)) (values (car alist) (append scanned (cdr alist)))) (else (loop (cdr alist) (cons (car alist) scanned))))))
+(define (fold-right kons knil lis1) (let recur ((lis lis1)) (if (null? lis) knil (let ((head (car lis))) (kons head (recur (cdr lis)))))))
+(define (fold kons knil lis1) (let lp ((lis lis1) (ans knil)) (if (null? lis) ans (lp (cdr lis) (kons (car lis) ans)))))
+(define ssax:S-chars (map ascii->char (quote (32 10 9 13))))
+(define (ssax:skip-S port) (skip-while ssax:S-chars port))
+(define (ssax:ncname-starting-char? a-char) (and (char? a-char) (or (char-alphabetic? a-char) (char=? #\_ a-char))))
+(define (ssax:read-NCName port) (let ((first-char (peek-char port))) (or (ssax:ncname-starting-char? first-char) (parser-error port "XMLNS [4] for '" first-char "'"))) (string->symbol (next-token-of (lambda (c) (cond ((eof-object? c) #f) ((char-alphabetic? c) c) ((string-index "0123456789.-_" c) c) (else #f))) port)))
+(define (ssax:read-QName port) (let ((prefix-or-localpart (ssax:read-NCName port))) (case (peek-char port) ((#\:) (read-char port) (cons prefix-or-localpart (ssax:read-NCName port))) (else prefix-or-localpart))))
+(define ssax:Prefix-XML (string->symbol "xml"))
+(define name-compare (letrec ((symbol-compare (lambda (symb1 symb2) (cond ((eq? symb1 symb2) (quote =)) ((string<? (symbol->string symb1) (symbol->string symb2)) (quote <)) (else (quote >)))))) (lambda (name1 name2) (cond ((symbol? name1) (if (symbol? name2) (symbol-compare name1 name2) (quote <))) ((symbol? name2) (quote >)) ((eq? name2 ssax:largest-unres-name) (quote <)) ((eq? name1 ssax:largest-unres-name) (quote >)) ((eq? (car name1) (car name2)) (symbol-compare (cdr name1) (cdr name2))) (else (symbol-compare (car name1) (car name2)))))))
+(define ssax:largest-unres-name (cons (string->symbol "#LARGEST-SYMBOL") (string->symbol "#LARGEST-SYMBOL")))
+(define ssax:read-markup-token (let () (define (skip-comment port) (assert-curr-char (quote (#\-)) "XML [15], second dash" port) (if (not (find-string-from-port? "-->" port)) (parser-error port "XML [15], no -->")) (make-xml-token (quote COMMENT) #f)) (define (read-cdata port) (assert (string=? "CDATA[" (read-string 6 port))) (make-xml-token (quote CDSECT) #f)) (lambda (port) (assert-curr-char (quote (#\<)) "start of the token" port) (case (peek-char port) ((#\/) (read-char port) (begin0 (make-xml-token (quote END) (ssax:read-QName port)) (ssax:skip-S port) (assert-curr-char (quote (#\>)) "XML [42]" port))) ((#\?) (read-char port) (make-xml-token (quote PI) (ssax:read-NCName port))) ((#\!) (case (peek-next-char port) ((#\-) (read-char port) (skip-comment port)) ((#\[) (read-char port) (read-cdata port)) (else (make-xml-token (quote DECL) (ssax:read-NCName port))))) (else (make-xml-token (quote START) (ssax:read-QName port)))))))
+(define (ssax:skip-pi port) (if (not (find-string-from-port? "?>" port)) (parser-error port "Failed to find ?> terminating the PI")))
+(define (ssax:read-pi-body-as-string port) (ssax:skip-S port) (string-concatenate/shared (let loop () (let ((pi-fragment (next-token (quote ()) (quote (#\?)) "reading PI content" port))) (if (eqv? #\> (peek-next-char port)) (begin (read-char port) (cons pi-fragment (quote ()))) (cons* pi-fragment "?" (loop)))))))
+(define (ssax:skip-internal-dtd port) (if (not (find-string-from-port? "]>" port)) (parser-error port "Failed to find ]> terminating the internal DTD subset")))
+(define ssax:read-cdata-body (let ((cdata-delimiters (list char-return #\newline #\] #\&))) (lambda (port str-handler seed) (let loop ((seed seed)) (let ((fragment (next-token (quote ()) cdata-delimiters "reading CDATA" port))) (case (read-char port) ((#\newline) (loop (str-handler fragment nl seed))) ((#\]) (if (not (eqv? (peek-char port) #\])) (loop (str-handler fragment "]" seed)) (let check-after-second-braket ((seed (if (string-null? fragment) seed (str-handler fragment "" seed)))) (case (peek-next-char port) ((#\>) (read-char port) seed) ((#\]) (check-after-second-braket (str-handler "]" "" seed))) (else (loop (str-handler "]]" "" seed))))))) ((#\&) (let ((ent-ref (next-token-of (lambda (c) (and (not (eof-object? c)) (char-alphabetic? c) c)) port))) (cond ((and (string=? "gt" ent-ref) (eqv? (peek-char port) #\;)) (read-char port) (loop (str-handler fragment ">" seed))) (else (loop (str-handler ent-ref "" (str-handler fragment "&" seed))))))) (else (if (eqv? (peek-char port) #\newline) (read-char port)) (loop (str-handler fragment nl seed)))))))))
+(define (ssax:read-char-ref port) (let* ((base (cond ((eqv? (peek-char port) #\x) (read-char port) 16) (else 10))) (name (next-token (quote ()) (quote (#\;)) "XML [66]" port)) (char-code (string->number name base))) (read-char port) (if (integer? char-code) (ucscode->char char-code) (parser-error port "[wf-Legalchar] broken for '" name "'"))))
+(define ssax:predefined-parsed-entities (quasiquote (((unquote (string->symbol "amp")) . "&") ((unquote (string->symbol "lt")) . "<") ((unquote (string->symbol "gt")) . ">") ((unquote (string->symbol "apos")) . "'") ((unquote (string->symbol "quot")) . "\""))))
+(define (ssax:handle-parsed-entity port name entities content-handler str-handler seed) (cond ((assq name entities) => (lambda (decl-entity) (let ((ent-body (cdr decl-entity)) (new-entities (cons (cons name #f) entities))) (cond ((string? ent-body) (call-with-input-string ent-body (lambda (port) (content-handler port new-entities seed)))) ((procedure? ent-body) (let ((port (ent-body))) (begin0 (content-handler port new-entities seed) (close-input-port port)))) (else (parser-error port "[norecursion] broken for " name)))))) ((assq name ssax:predefined-parsed-entities) => (lambda (decl-entity) (str-handler (cdr decl-entity) "" seed))) (else (parser-error port "[wf-entdeclared] broken for " name))))
+(define (make-empty-attlist) (quote ()))
+(define (attlist-add attlist name-value) (if (null? attlist) (cons name-value attlist) (case (name-compare (car name-value) (caar attlist)) ((=) #f) ((<) (cons name-value attlist)) (else (cons (car attlist) (attlist-add (cdr attlist) name-value))))))
+(define attlist-null? null?)
+(define (attlist-remove-top attlist) (values (car attlist) (cdr attlist)))
+(define (attlist->alist attlist) attlist)
+(define attlist-fold fold)
+(define ssax:read-attributes (let ((value-delimeters (append ssax:S-chars (quote (#\< #\&))))) (define (read-attrib-value delimiter port entities prev-fragments) (let* ((new-fragments (cons (next-token (quote ()) (cons delimiter value-delimeters) "XML [10]" port) prev-fragments)) (cterm (read-char port))) (cond ((or (eof-object? cterm) (eqv? cterm delimiter)) new-fragments) ((eqv? cterm char-return) (if (eqv? (peek-char port) #\newline) (read-char port)) (read-attrib-value delimiter port entities (cons " " new-fragments))) ((memv cterm ssax:S-chars) (read-attrib-value delimiter port entities (cons " " new-fragments))) ((eqv? cterm #\&) (cond ((eqv? (peek-char port) #\#) (read-char port) (read-attrib-value delimiter port entities (cons (string (ssax:read-char-ref port)) new-fragments))) (else (read-attrib-value delimiter port entities (read-named-entity port entities new-fragments))))) (else (parser-error port "[CleanAttrVals] broken"))))) (define (read-named-entity port entities fragments) (let ((name (ssax:read-NCName port))) (assert-curr-char (quote (#\;)) "XML [68]" port) (ssax:handle-parsed-entity port name entities (lambda (port entities fragments) (read-attrib-value (quote *eof*) port entities fragments)) (lambda (str1 str2 fragments) (if (equal? "" str2) (cons str1 fragments) (cons* str2 str1 fragments))) fragments))) (lambda (port entities) (let loop ((attr-list (make-empty-attlist))) (if (not (ssax:ncname-starting-char? (ssax:skip-S port))) attr-list (let ((name (ssax:read-QName port))) (ssax:skip-S port) (assert-curr-char (quote (#\=)) "XML [25]" port) (ssax:skip-S port) (let ((delimiter (assert-curr-char (quote (#\' #\")) "XML [10]" port))) (loop (or (attlist-add attr-list (cons name (string-concatenate-reverse/shared (read-attrib-value delimiter port entities (quote ()))))) (parser-error port "[uniqattspec] broken for " name))))))))))
+(define (ssax:resolve-name port unres-name namespaces apply-default-ns?) (cond ((pair? unres-name) (cons (cond ((assq (car unres-name) namespaces) => cadr) ((eq? (car unres-name) ssax:Prefix-XML) ssax:Prefix-XML) (else (parser-error port "[nsc-NSDeclared] broken; prefix " (car unres-name)))) (cdr unres-name))) (apply-default-ns? (let ((default-ns (assq (quote *DEFAULT*) namespaces))) (if (and default-ns (cadr default-ns)) (cons (cadr default-ns) unres-name) unres-name))) (else unres-name)))
+(define (ssax:uri-string->symbol uri-str) (string->symbol uri-str))
+(define ssax:complete-start-tag (let ((xmlns (string->symbol "xmlns")) (largest-dummy-decl-attr (list ssax:largest-unres-name #f #f #f))) (define (validate-attrs port attlist decl-attrs) (define (add-default-decl decl-attr result) (let*-values (((attr-name content-type use-type default-value) (apply values decl-attr))) (and (eq? use-type (quote REQUIRED)) (parser-error port "[RequiredAttr] broken for" attr-name)) (if default-value (cons (cons attr-name default-value) result) result))) (let loop ((attlist attlist) (decl-attrs decl-attrs) (result (quote ()))) (if (attlist-null? attlist) (attlist-fold add-default-decl result decl-attrs) (let*-values (((attr attr-others) (attlist-remove-top attlist)) ((decl-attr other-decls) (if (attlist-null? decl-attrs) (values largest-dummy-decl-attr decl-attrs) (attlist-remove-top decl-attrs)))) (case (name-compare (car attr) (car decl-attr)) ((<) (if (or (eq? xmlns (car attr)) (and (pair? (car attr)) (eq? xmlns (caar attr)))) (loop attr-others decl-attrs (cons attr result)) (parser-error port "[ValueType] broken for " attr))) ((>) (loop attlist other-decls (add-default-decl decl-attr result))) (else (let*-values (((attr-name content-type use-type default-value) (apply values decl-attr))) (cond ((eq? use-type (quote FIXED)) (or (equal? (cdr attr) default-value) (parser-error port "[FixedAttr] broken for " attr-name))) ((eq? content-type (quote CDATA)) #t) ((pair? content-type) (or (member (cdr attr) content-type) (parser-error port "[enum] broken for " attr-name "=" (cdr attr)))) (else (ssax:warn port "declared content type " content-type " not verified yet"))) (loop attr-others other-decls (cons attr result))))))))) (define (add-ns port prefix uri-str namespaces) (and (equal? "" uri-str) (parser-error port "[dt-NSName] broken for " prefix)) (let ((uri-symbol (ssax:uri-string->symbol uri-str))) (let loop ((nss namespaces)) (cond ((null? nss) (cons (cons* prefix uri-symbol uri-symbol) namespaces)) ((eq? uri-symbol (cddar nss)) (cons (cons* prefix (cadar nss) uri-symbol) namespaces)) (else (loop (cdr nss))))))) (define (adjust-namespace-decl port attrs namespaces) (let loop ((attrs attrs) (proper-attrs (quote ())) (namespaces namespaces)) (cond ((null? attrs) (values proper-attrs namespaces)) ((eq? xmlns (caar attrs)) (loop (cdr attrs) proper-attrs (if (equal? "" (cdar attrs)) (cons (cons* (quote *DEFAULT*) #f #f) namespaces) (add-ns port (quote *DEFAULT*) (cdar attrs) namespaces)))) ((and (pair? (caar attrs)) (eq? xmlns (caaar attrs))) (loop (cdr attrs) proper-attrs (add-ns port (cdaar attrs) (cdar attrs) namespaces))) (else (loop (cdr attrs) (cons (car attrs) proper-attrs) namespaces))))) (lambda (tag-head port elems entities namespaces) (let*-values (((attlist) (ssax:read-attributes port entities)) ((empty-el-tag?) (begin (ssax:skip-S port) (and (eqv? #\/ (assert-curr-char (quote (#\> #\/)) "XML [40], XML [44], no '>'" port)) (assert-curr-char (quote (#\>)) "XML [44], no '>'" port)))) ((elem-content decl-attrs) (if elems (cond ((assoc tag-head elems) => (lambda (decl-elem) (values (if empty-el-tag? (quote EMPTY-TAG) (cadr decl-elem)) (caddr decl-elem)))) (else (parser-error port "[elementvalid] broken, no decl for " tag-head))) (values (if empty-el-tag? (quote EMPTY-TAG) (quote ANY)) #f))) ((merged-attrs) (if decl-attrs (validate-attrs port attlist decl-attrs) (attlist->alist attlist))) ((proper-attrs namespaces) (adjust-namespace-decl port merged-attrs namespaces))) (values (ssax:resolve-name port tag-head namespaces #t) (fold-right (lambda (name-value attlist) (or (attlist-add attlist (cons (ssax:resolve-name port (car name-value) namespaces #f) (cdr name-value))) (parser-error port "[uniqattspec] after NS expansion broken for " name-value))) (make-empty-attlist) proper-attrs) namespaces elem-content)))))
+(define (ssax:read-external-id port) (let ((discriminator (ssax:read-NCName port))) (assert-curr-char ssax:S-chars "space after SYSTEM or PUBLIC" port) (ssax:skip-S port) (let ((delimiter (assert-curr-char (quote (#\' #\")) "XML [11], XML [12]" port))) (cond ((eq? discriminator (string->symbol "SYSTEM")) (begin0 (next-token (quote ()) (list delimiter) "XML [11]" port) (read-char port))) ((eq? discriminator (string->symbol "PUBLIC")) (skip-until (list delimiter) port) (assert-curr-char ssax:S-chars "space after PubidLiteral" port) (ssax:skip-S port) (let* ((delimiter (assert-curr-char (quote (#\' #\")) "XML [11]" port)) (systemid (next-token (quote ()) (list delimiter) "XML [11]" port))) (read-char port) systemid)) (else (parser-error port "XML [75], " discriminator " rather than SYSTEM or PUBLIC"))))))
+(define (ssax:scan-Misc port) (let loop ((c (ssax:skip-S port))) (cond ((eof-object? c) c) ((not (char=? c #\<)) (parser-error port "XML [22], char '" c "' unexpected")) (else (let ((token (ssax:read-markup-token port))) (case (xml-token-kind token) ((COMMENT) (loop (ssax:skip-S port))) ((PI DECL START) token) (else (parser-error port "XML [22], unexpected token of kind " (xml-token-kind token)))))))))
+(define ssax:read-char-data (let ((terminators-usual (list #\< #\& char-return)) (terminators-usual-eof (list #\< (quote *eof*) #\& char-return)) (handle-fragment (lambda (fragment str-handler seed) (if (string-null? fragment) seed (str-handler fragment "" seed))))) (lambda (port expect-eof? str-handler seed) (if (eqv? #\< (peek-char port)) (let ((token (ssax:read-markup-token port))) (case (xml-token-kind token) ((START END) (values seed token)) ((CDSECT) (let ((seed (ssax:read-cdata-body port str-handler seed))) (ssax:read-char-data port expect-eof? str-handler seed))) ((COMMENT) (ssax:read-char-data port expect-eof? str-handler seed)) (else (values seed token)))) (let ((char-data-terminators (if expect-eof? terminators-usual-eof terminators-usual))) (let loop ((seed seed)) (let* ((fragment (next-token (quote ()) char-data-terminators "reading char data" port)) (term-char (peek-char port))) (if (eof-object? term-char) (values (handle-fragment fragment str-handler seed) term-char) (case term-char ((#\<) (let ((token (ssax:read-markup-token port))) (case (xml-token-kind token) ((CDSECT) (loop (ssax:read-cdata-body port str-handler (handle-fragment fragment str-handler seed)))) ((COMMENT) (loop (handle-fragment fragment str-handler seed))) (else (values (handle-fragment fragment str-handler seed) token))))) ((#\&) (case (peek-next-char port) ((#\#) (read-char port) (loop (str-handler fragment (string (ssax:read-char-ref port)) seed))) (else (let ((name (ssax:read-NCName port))) (assert-curr-char (quote (#\;)) "XML [68]" port) (values (handle-fragment fragment str-handler seed) (make-xml-token (quote ENTITY-REF) name)))))) (else (if (eqv? (peek-next-char port) #\newline) (read-char port)) (loop (str-handler fragment (string #\newline) seed))))))))))))
+(define (ssax:assert-token token kind gi error-cont) (or (and (xml-token? token) (eq? kind (xml-token-kind token)) (equal? gi (xml-token-head token))) (error-cont token kind gi)))
+(define-syntax ssax:make-pi-parser (syntax-rules () ((ssax:make-pi-parser orig-handlers) (letrec-syntax ((loop (syntax-rules (*DEFAULT*) ((loop () #f accum port target seed) (make-case ((else (ssax:warn port "Skipping PI: " target nl) (ssax:skip-pi port) seed) . accum) () target)) ((loop () default accum port target seed) (make-case ((else (default port target seed)) . accum) () target)) ((loop ((*DEFAULT* . default) . handlers) old-def accum port target seed) (loop handlers default accum port target seed)) ((loop ((tag . handler) . handlers) default accum port target seed) (loop handlers default (((tag) (handler port target seed)) . accum) port target seed)))) (make-case (syntax-rules () ((make-case () clauses target) (case target . clauses)) ((make-case (clause . clauses) accum target) (make-case clauses (clause . accum) target))))) (lambda (port target seed) (loop orig-handlers #f () port target seed))))))
+(define-syntax ssax:make-elem-parser (syntax-rules () ((ssax:make-elem-parser my-new-level-seed my-finish-element my-char-data-handler my-pi-handlers) (lambda (start-tag-head port elems entities namespaces preserve-ws? seed) (define xml-space-gi (cons ssax:Prefix-XML (string->symbol "space"))) (let handle-start-tag ((start-tag-head start-tag-head) (port port) (entities entities) (namespaces namespaces) (preserve-ws? preserve-ws?) (parent-seed seed)) (let*-values (((elem-gi attributes namespaces expected-content) (ssax:complete-start-tag start-tag-head port elems entities namespaces)) ((seed) (my-new-level-seed elem-gi attributes namespaces expected-content parent-seed))) (case expected-content ((EMPTY-TAG) (my-finish-element elem-gi attributes namespaces parent-seed seed)) ((EMPTY) (ssax:assert-token (and (eqv? #\< (ssax:skip-S port)) (ssax:read-markup-token port)) (quote END) start-tag-head (lambda (token exp-kind exp-head) (parser-error port "[elementvalid] broken for " token " while expecting " exp-kind exp-head))) (my-finish-element elem-gi attributes namespaces parent-seed seed)) (else (let ((preserve-ws? (cond ((assoc xml-space-gi attributes) => (lambda (name-value) (equal? "preserve" (cdr name-value)))) (else preserve-ws?)))) (let loop ((port port) (entities entities) (expect-eof? #f) (seed seed)) (let*-values (((seed term-token) (ssax:read-char-data port expect-eof? my-char-data-handler seed))) (if (eof-object? term-token) seed (case (xml-token-kind term-token) ((END) (ssax:assert-token term-token (quote END) start-tag-head (lambda (token exp-kind exp-head) (parser-error port "[GIMatch] broken for " term-token " while expecting " exp-kind exp-head))) (my-finish-element elem-gi attributes namespaces parent-seed seed)) ((PI) (let ((seed ((ssax:make-pi-parser my-pi-handlers) port (xml-token-head term-token) seed))) (loop port entities expect-eof? seed))) ((ENTITY-REF) (let ((seed (ssax:handle-parsed-entity port (xml-token-head term-token) entities (lambda (port entities seed) (loop port entities #t seed)) my-char-data-handler seed))) (loop port entities expect-eof? seed))) ((START) (if (eq? expected-content (quote PCDATA)) (parser-error port "[elementvalid] broken for " elem-gi " with char content only; unexpected token " term-token)) (let ((seed (handle-start-tag (xml-token-head term-token) port entities namespaces preserve-ws? seed))) (loop port entities expect-eof? seed))) (else (parser-error port "XML [43] broken for " term-token)))))))))))))))
+(define-syntax ssax:make-parser/positional-args (syntax-rules () ((ssax:make-parser/positional-args *handler-DOCTYPE *handler-UNDECL-ROOT *handler-DECL-ROOT *handler-NEW-LEVEL-SEED *handler-FINISH-ELEMENT *handler-CHAR-DATA-HANDLER *handler-PI) (lambda (port seed) (define (handle-decl port token-head seed) (or (eq? (string->symbol "DOCTYPE") token-head) (parser-error port "XML [22], expected DOCTYPE declaration, found " token-head)) (assert-curr-char ssax:S-chars "XML [28], space after DOCTYPE" port) (ssax:skip-S port) (let*-values (((docname) (ssax:read-QName port)) ((systemid) (and (ssax:ncname-starting-char? (ssax:skip-S port)) (ssax:read-external-id port))) ((internal-subset?) (begin (ssax:skip-S port) (eqv? #\[ (assert-curr-char (quote (#\> #\[)) "XML [28], end-of-DOCTYPE" port)))) ((elems entities namespaces seed) (*handler-DOCTYPE port docname systemid internal-subset? seed))) (scan-for-significant-prolog-token-2 port elems entities namespaces seed))) (define (scan-for-significant-prolog-token-1 port seed) (let ((token (ssax:scan-Misc port))) (if (eof-object? token) (parser-error port "XML [22], unexpected EOF") (case (xml-token-kind token) ((PI) (let ((seed ((ssax:make-pi-parser *handler-PI) port (xml-token-head token) seed))) (scan-for-significant-prolog-token-1 port seed))) ((DECL) (handle-decl port (xml-token-head token) seed)) ((START) (let*-values (((elems entities namespaces seed) (*handler-UNDECL-ROOT (xml-token-head token) seed))) (element-parser (xml-token-head token) port elems entities namespaces #f seed))) (else (parser-error port "XML [22], unexpected markup " token)))))) (define (scan-for-significant-prolog-token-2 port elems entities namespaces seed) (let ((token (ssax:scan-Misc port))) (if (eof-object? token) (parser-error port "XML [22], unexpected EOF") (case (xml-token-kind token) ((PI) (let ((seed ((ssax:make-pi-parser *handler-PI) port (xml-token-head token) seed))) (scan-for-significant-prolog-token-2 port elems entities namespaces seed))) ((START) (element-parser (xml-token-head token) port elems entities namespaces #f (*handler-DECL-ROOT (xml-token-head token) seed))) (else (parser-error port "XML [22], unexpected markup " token)))))) (define element-parser (ssax:make-elem-parser *handler-NEW-LEVEL-SEED *handler-FINISH-ELEMENT *handler-CHAR-DATA-HANDLER *handler-PI)) (scan-for-significant-prolog-token-1 port seed)))))
+(define-syntax ssax:define-labeled-arg-macro (syntax-rules () ((ssax:define-labeled-arg-macro labeled-arg-macro-name (positional-macro-name (arg-name . arg-def) ...)) (define-syntax labeled-arg-macro-name (syntax-rules () ((labeled-arg-macro-name . kw-val-pairs) (letrec-syntax ((find (syntax-rules (arg-name ...) ((find k-args (arg-name . default) arg-name val . others) (next val . k-args)) ... ((find k-args key arg-no-match-name val . others) (find k-args key . others)) ((find k-args (arg-name default)) (next default . k-args)) ...)) (next (syntax-rules () ((next val vals key . keys) (find ((val . vals) . keys) key . kw-val-pairs)) ((next val vals) (rev-apply (val) vals)))) (rev-apply (syntax-rules () ((rev-apply form (x . xs)) (rev-apply (x . form) xs)) ((rev-apply form ()) form)))) (next positional-macro-name () (arg-name . arg-def) ...))))))))
+(ssax:define-labeled-arg-macro ssax:make-parser (ssax:make-parser/positional-args (DOCTYPE (lambda (port docname systemid internal-subset? seed) (when internal-subset? (ssax:warn port "Internal DTD subset is not currently handled ") (ssax:skip-internal-dtd port)) (ssax:warn port "DOCTYPE DECL " docname " " systemid " found and skipped") (values #f (quote ()) (quote ()) seed))) (UNDECL-ROOT (lambda (elem-gi seed) (values #f (quote ()) (quote ()) seed))) (DECL-ROOT (lambda (elem-gi seed) seed)) (NEW-LEVEL-SEED) (FINISH-ELEMENT) (CHAR-DATA-HANDLER) (PI ())))
+(define (ssax:reverse-collect-str fragments) (cond ((null? fragments) (quote ())) ((null? (cdr fragments)) fragments) (else (let loop ((fragments fragments) (result (quote ())) (strs (quote ()))) (cond ((null? fragments) (if (null? strs) result (cons (string-concatenate/shared strs) result))) ((string? (car fragments)) (loop (cdr fragments) result (cons (car fragments) strs))) (else (loop (cdr fragments) (cons (car fragments) (if (null? strs) result (cons (string-concatenate/shared strs) result))) (quote ()))))))))
+(define (ssax:reverse-collect-str-drop-ws fragments) (cond ((null? fragments) (quote ())) ((null? (cdr fragments)) (if (and (string? (car fragments)) (string-whitespace? (car fragments))) (quote ()) fragments)) (else (let loop ((fragments fragments) (result (quote ())) (strs (quote ())) (all-whitespace? #t)) (cond ((null? fragments) (if all-whitespace? result (cons (string-concatenate/shared strs) result))) ((string? (car fragments)) (loop (cdr fragments) result (cons (car fragments) strs) (and all-whitespace? (string-whitespace? (car fragments))))) (else (loop (cdr fragments) (cons (car fragments) (if all-whitespace? result (cons (string-concatenate/shared strs) result))) (quote ()) #t)))))))
+(define (ssax:xml->sxml port namespace-prefix-assig) (letrec ((namespaces (map (lambda (el) (cons* #f (car el) (ssax:uri-string->symbol (cdr el)))) namespace-prefix-assig)) (RES-NAME->SXML (lambda (res-name) (string->symbol (string-append (symbol->string (car res-name)) ":" (symbol->string (cdr res-name))))))) (let ((result (reverse ((ssax:make-parser NEW-LEVEL-SEED (lambda (elem-gi attributes namespaces expected-content seed) (quote ())) FINISH-ELEMENT (lambda (elem-gi attributes namespaces parent-seed seed) (let ((seed (ssax:reverse-collect-str-drop-ws seed)) (attrs (attlist-fold (lambda (attr accum) (cons (list (if (symbol? (car attr)) (car attr) (RES-NAME->SXML (car attr))) (cdr attr)) accum)) (quote ()) attributes))) (cons (cons (if (symbol? elem-gi) elem-gi (RES-NAME->SXML elem-gi)) (if (null? attrs) seed (cons (cons (quote @) attrs) seed))) parent-seed))) CHAR-DATA-HANDLER (lambda (string1 string2 seed) (if (string-null? string2) (cons string1 seed) (cons* string2 string1 seed))) DOCTYPE (lambda (port docname systemid internal-subset? seed) (when internal-subset? (ssax:warn port "Internal DTD subset is not currently handled ") (ssax:skip-internal-dtd port)) (ssax:warn port "DOCTYPE DECL " docname " " systemid " found and skipped") (values #f (quote ()) namespaces seed)) UNDECL-ROOT (lambda (elem-gi seed) (values #f (quote ()) namespaces seed)) PI ((*DEFAULT* lambda (port pi-tag seed) (cons (list (quote *PI*) pi-tag (ssax:read-pi-body-as-string port)) seed)))) port (quote ()))))) (cons (quote *TOP*) (if (null? namespace-prefix-assig) result (cons (list (quote @) (cons (quote *NAMESPACES*) (map (lambda (ns) (list (car ns) (cdr ns))) namespace-prefix-assig))) result))))))
diff --git a/collects/ssax/SXML-to-HTML-ext.scm b/collects/ssax/SXML-to-HTML-ext.scm
new file mode 100644
index 0000000000..accb53c81b
--- /dev/null
+++ b/collects/ssax/SXML-to-HTML-ext.scm
@@ -0,0 +1,420 @@
+;	   HTML Authoring in SXML for my personal Web pages
+;
+; The present file defines several functions and higher-order
+; SXML "tags" that are used to compose HTML pages on my web site.
+; In LaTeX terms, this file is similar to article.cls.
+;
+; See http://pobox.com/~oleg/ftp/Scheme/xml.html#XML-authoring
+; for more examples and explanation.
+;
+; IMPORT
+; Approporiate Prelude: myenv.scm or myenv-bigloo.scm
+; srfi-13-local.scm or the appropriate native implementation of SRFI-13
+; util.scm
+; SXML-tree-trans.scm
+; SXML-to-HTML.scm
+; OS:file-length, unless it is included into the core system
+;   (see myenv-bigloo.scm for example)
+;
+; $Id: SXML-to-HTML-ext.scm,v 1.2 2004/11/09 14:11:39 sperber Exp $
+
+; skip the lst trough the first significant element
+; return the tail of lst such that (car result) is significant
+; Insignificant elems are '(), #f, and lists made of them
+; If all of the list is insignificant, return #f
+(define (signif-tail lst)
+  (define (signif? obj)
+    (and (not (null? obj)) obj
+	 (if (pair? obj)
+	     (or (signif? (car obj))
+		 (signif? (cdr obj)))
+	     obj)))
+  (and (signif? lst)
+       (assert (pair? lst))
+       (if (signif? (car lst)) lst
+	   (signif-tail (cdr lst)))))
+
+; Procedure make-header HEAD-PARMS
+; Create the 'head' SXML/HTML tag. HEAD-PARMS is an assoc list of
+; (h-key h-value), where h-value is a typically string;
+; h-key is a symbol:
+; title, description, AuthorAddress, keywords,
+; Date-Revision-yyyymmdd, Date-Creation-yyyymmdd,
+; long-title
+; One of the h-key can be Links.
+; In that case, h-value is a list of
+;	(l-key l-href (attr value) ...)
+; where l-key is one of the following:
+;	start, contents, prev, next, top, home
+
+(define (make-header head-parms)
+  `(head
+    (title ,(lookup-def 'title head-parms))
+    ,(map
+      (lambda (key)
+	(let ((val (lookup-def key head-parms warn: #f)))
+	  (and val
+	       `(meta (@ (name ,(symbol->string key)) (content ,val))))))
+      '(description AuthorAddress keywords
+	Date-Revision-yyyymmdd Date-Creation-yyyymmdd))
+    ,(let ((links (lookup-def 'Links head-parms '())))
+      (and (pair? links)
+	   (map
+	    (lambda (link-key)
+	      (let ((val (lookup-def link-key links #f)))
+		(and val
+		  (let ((val (if (not (pair? val)) (list val) val)))
+		     `(link (@ (rel ,(symbol->string link-key))
+			       (href ,(car val))
+			       ,@(cdr val)))))))
+	    '(start contents prev next)))))
+)
+
+; Create a navigational bar. The argument head-parms is the same
+; as the one passed to make-header. We're only concerned with the
+; h-value Links
+(define (make-navbar head-parms)
+  (let ((links (lookup-def 'Links head-parms '()))
+	(nav-labels '((prev . "previous")
+		      (next . "next")
+		      (contents . "contents")
+		      (top . "top"))))
+    (and (pair? links)
+      `(div (@ (align "center") (class "navbar"))
+	 ,(let loop ((nav-labels nav-labels) (first? #t))
+	    (if (null? nav-labels) '()
+		(let ((val (lookup-def (caar nav-labels) links warn: #f)))
+		  (if (not val)
+		      (loop (cdr nav-labels) first?)
+		      (cons
+		       (list " " (if first? #f '(n_)) " "
+			     `(a (@ (href ,val)) ,(cdar nav-labels)))
+		       (loop (cdr nav-labels) #f))))))
+	 (hr)))
+))
+			      
+
+; Create a footer. The argument head-parms is the same
+; as passed to make-header.
+(define (make-footer head-parms)
+  `((br)
+    (div (hr))
+    (h3 "Last updated "
+	,(let* ((date-revised
+		  (lookup-def 'Date-Revision-yyyymmdd head-parms))
+		(year (string->integer date-revised 0 4))
+		(month (string->integer date-revised 4 6))
+		(day   (string->integer date-revised 6 8))
+		(month-name
+		 (vector-ref
+		  '#("January" "February" "March" "April" "May" "June"
+		    "July"   "August" "September" "October" "November"
+		    "December")
+		  (dec month))))
+	   (list month-name " " day ", " year)))
+    ,(let ((links (lookup-def 'Links head-parms '())))
+       (and (pair? links)
+	    (let ((home (lookup-def 'home links warn: #f)))
+	      (and home
+		   `(p "This site's top page is "
+		       (a (@ (href ,home)) (strong ,home)))))))
+    (div 
+      (address "oleg-at-pobox.com or oleg-at-acm.org or oleg-at-computer.org"
+       (br)
+       "Your comments, problem reports, questions are very welcome!"))
+    (p (font (@ (size "-2")) "Converted from SXML by SXML->HTML"))
+    ,(let ((rcs-id (lookup-def 'rcs-id head-parms #f)))
+       (and rcs-id `(h4 ,rcs-id)))
+    ))
+
+; Bindings for the post-order function, which traverses the SXML tree
+; and converts it to a tree of fragments
+
+; The universal transformation from SXML to HTML. The following rules
+; work for every HTML, present and future
+(define universal-conversion-rules
+  `((@
+      ((*default*       ; local override for attributes
+        . ,(lambda (attr-key . value) (enattr attr-key value))))
+      . ,(lambda (trigger . value) (cons '@ value)))
+    (*default* . ,(lambda (tag . elems) (entag tag elems)))
+    (*text* . ,(lambda (trigger str) 
+		 (if (string? str) (string->goodHTML str) str)))
+    (n_		; a non-breaking space
+     . ,(lambda (tag . elems)
+	  (cons "&nbsp;" elems)))))
+
+; A variation of universal-conversion-rules which keeps '<', '>', '&'
+; and similar characters intact. The universal-protected-rules are
+; useful when the tree of fragments has to be traversed one more time.
+(define universal-protected-rules
+  `((@
+      ((*default*       ; local override for attributes
+        . ,(lambda (attr-key . value) (enattr attr-key value))))
+      . ,(lambda (trigger . value) (cons '@ value)))
+    (*default* . ,(lambda (tag . elems) (entag tag elems)))
+    (*text* . ,(lambda (trigger str) 
+		 str))
+    (n_		; a non-breaking space
+     . ,(lambda (tag . elems)
+	  (cons "&nbsp;" elems)))))
+
+; The following rules define the identity transformation
+(define alist-conv-rules
+  `((*default* . ,(lambda (tag . elems) (cons tag elems)))
+    (*text* . ,(lambda (trigger str) str))))
+
+
+; Find the 'Header' node within the 'Content' SXML expression.
+; Currently this query is executed via a transformation, with
+; rules that drop out everything but the 'Header' node.
+; We use the _breadth-first_ traversal of the Content tree.
+(define (find-Header Content)
+  (letrec 
+    ((search-rules
+	 `((*default*
+	    *preorder*
+	    . ,(lambda (tag . elems)
+		 (let loop ((elems elems) (worklist '()))
+		   (cond
+		    ((null? elems) 
+		     (if (null? worklist) '()
+			 (pre-post-order worklist search-rules)))
+		    ((not (pair? (car elems))) (loop (cdr elems) worklist))
+		    ((eq? 'Header (caar elems)) (car elems)) ; found
+		    (else (loop (cdr elems) (cons (car elems) worklist)))))))
+	   )))
+    (lookup-def 'Header
+		(list (pre-post-order Content search-rules))
+		)))
+
+
+; Transformation rules that define a number of higher-order tags,
+; which give "style" to all my pages.
+; Some of these rules require a pre-post-order iterator
+; See xml.scm or any other of my web page master files for an example
+; of using these stylesheet rules
+
+(define (generic-web-rules Content additional-rules)
+  (append
+   additional-rules
+   universal-conversion-rules
+   `((html:begin 
+      . ,(lambda (tag . elems)
+	   (list
+	     "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\""
+	     nl 
+	     "\"http://www.w3.org/TR/html4/loose.dtd\">" nl
+	     "<html>" nl
+	     elems
+	     "</html>" nl)))
+
+     (Header
+      *preorder*
+      . ,(lambda (tag . headers)
+	   (post-order (make-header headers) universal-conversion-rules)
+	   ))
+
+     (body
+      . ,(lambda (tag . elems)
+	   (list "<body bgcolor=\"#FFFFFF\">" nl elems "</body>")))
+
+     (navbar			; Find the Header in the Content
+      . ,(lambda (tag)		; and create the navigation bar
+	   (let ((header-parms (find-Header Content)))
+	     (post-order (make-navbar header-parms)
+			 universal-conversion-rules))))
+     
+     (footer			; Find the Header in the Content
+      . ,(lambda (tag)		; and create the footer of the page
+	   (let ((header-parms (find-Header Content)))
+	     (post-order (make-footer header-parms)
+			 universal-conversion-rules))))
+     
+     (page-title		; Find the Header in the Content
+      . ,(lambda (tag)		; and create the page title rule
+	   (let ((header-parms (find-Header Content)))
+	     (list "<h1 align=center>" 
+		   (lookup-def 'long-title header-parms) "</h1>" nl))))
+
+
+     (Section	; (Section level "content ...")
+      . ,(lambda (tag level head-word . elems)
+	   (list "<br>&nbsp;<a name=\"" head-word "\">&nbsp;</a>" nl
+		 "<h" level ">"  head-word elems "</h" level ">" nl)))
+
+     (TOC	; Re-scan the Content for "Section" tags and generate
+      . ,(lambda (tag)	; the Hierarchical Table of contents
+	   (let ((sections
+		  (post-order Content
+		    `((Section	; (Section level "content ...")
+		       ((*text* . ,(lambda (tag str) str)))
+		       . ,(lambda (tag level head-word . elems)
+			    (vector level
+				    (list "<li><a href=\"#" head-word
+					  "\">" head-word elems "</a>" nl))))
+		      (*default*
+		       . ,(lambda (attr-key . elems) elems))
+		      (*text* . ,(lambda (trigger str) '()))))))
+	     ;(cerr sections)
+	     (list "<div>"
+	      (let loop ((curr-level 1) (sections sections))
+	       (cond
+		((null? sections)
+		 (let fill ((curr-level curr-level))
+		   (if (> curr-level 1)
+		       (cons "</ol>" (fill (dec curr-level)))
+		       '())))
+		((null? (car sections)) (loop curr-level (cdr sections)))
+		((pair? (car sections)) (loop curr-level
+					      (append (car sections)
+						      (cdr sections))))
+		((vector? (car sections))
+		 (let ((new-level (vector-ref (car sections) 0)))
+		   (cond
+		    ((= new-level curr-level)
+		     (cons (vector-ref (car sections) 1)
+			   (loop curr-level (cdr sections))))
+		    ((= (inc new-level) curr-level)
+		     (cons "</ol>"
+			   (cons (vector-ref (car sections) 1)
+				 (loop new-level (cdr sections)))))
+		    ((= new-level (inc curr-level))
+		     (cons nl (cons "<ol>"
+			   (cons (vector-ref (car sections) 1)
+				 (loop new-level (cdr sections))))))
+		    (else 
+		     (error "inconsistent levels: " curr-level new-level)))))
+		(else "wrong item: " sections)))
+	      nl "</div>" nl))))
+
+     (bibitem *macro*
+       . ,(lambda (tag label key . text)
+	   `(p (a (@ (name ,key)) "[" ,label "]") " " ,text)))
+
+     (cite		; ought to locate the label and use the label!
+      . ,(lambda (tag key)
+	   (list "[<a href=\"#" key "\">" key "</a>]")))
+
+
+     (trace		; A debugging aid
+      . ,(lambda (tag . content)
+	   (cerr tag content nl)
+	   '()))
+
+     (URL  *macro*
+      . ,(lambda (tag url)
+	   `((br) "<" (a (@ (href ,url)) ,url) ">")))
+
+
+     (verbatim	; set off pieces of code: one or several lines
+      . ,(lambda (tag . lines)
+	   (list "<pre>"
+		 (map (lambda (line) (list "     " line nl))
+		      lines)
+		 "</pre>")))
+		; (note . text-strings)
+		; A note (remark), similar to a footnote
+     (note
+      . ,(lambda (tag . text-strings)
+	   (list " <font size=\"-1\">[" text-strings "]</font>" nl)))
+
+		; A reference to a file
+     (fileref
+      . ,(lambda (tag pathname . descr-text)
+	   (list "<a href=\"" pathname "\">"
+		 (car (reverse (string-split pathname '(#\/))))
+		 "</a> [" 
+		 (let ((file-size (OS:file-length pathname)))
+		   (if (not (positive? file-size))
+		       (error "File not found: " pathname))
+		   (cond
+		    ((< file-size 1024) "&lt;1K")
+		    (else (list (quotient (+ file-size 1023) 1024) "K"))))
+		 "]<br>"
+		 descr-text)))
+
+		; A reference to a plain-text file (article)
+     (textref
+       . ,(lambda (tag pathname title . descr)
+	    (let ((file-size (OS:file-length pathname)))
+	      (if (not (positive? file-size))
+		  (error "File not found: " pathname))
+	      (list "<a href=\"" pathname "\">" title
+		    "</a> <font size=\"-1\">[plain text file]</font><br>" nl
+		    descr))))
+
+		; A reference to an anchor in the present file
+		; (local-ref target . title)
+		; If title is given, generate a regular
+		;	<a href="#target">title</a>
+		; Otherwise, transform the content so that a
+		; construct that may generate an anchor 'target' (such
+		; as Section or Description-unit) is re-written to the
+		; title SXML. All other constructs re-write to
+		; nothing.
+     (local-ref
+      *macro*
+      . ,(lambda (tag target . title)
+	   (let
+	       ((title
+		 (if (pair? title) title	; it is given explicitly
+		     (pre-post-order Content
+		       `((*text* . ,(lambda (trigger str) '()))
+			 (*default*
+			  . ,(lambda (tag . elems)
+			       (let ((first-sign (signif-tail elems)))
+				 (if first-sign
+				     (let ((second-sign
+					    (signif-tail (cdr first-sign))))
+				       (assert (not second-sign))
+				       (car first-sign))
+				     '()))))
+			 (Description-unit
+			  *preorder*
+			  . ,(lambda (tag key title . elems)
+			       (if (equal? key target)
+				   (list title)
+				   '()))))))))
+	     (assert (pair? title))
+	     (cerr "title: " title nl)
+	     `(a (@ (href #\# ,target)) ,title))))
+
+		; Unit of a description for a piece of code
+		; (Description-unit key title . elems)
+		; where elems is one of the following:
+		; headline, body, platforms, version
+     (Description-unit
+      ((headline
+	. ,(lambda (tag . elems)
+	     (list "<dt>" elems "</dt>" nl)))
+       (body
+	. ,(lambda (tag . elems)
+	     (list "<dd>" elems "</dd>" nl)))
+       (platforms
+	. ,(lambda (tag . elems)
+	     (list "<dt><strong>Platforms</strong><dt><dd>"
+		   elems "</dd>" nl)))
+       (version
+	. ,(lambda (tag . elems)
+	     (list "<dt><strong>Version</strong><dt><dd>"
+		   "The current version is " elems ".</dd>" nl)))
+       (references
+	. ,(lambda (tag . elems)
+	     (list "<dt><strong>References</strong><dt><dd>"
+		   elems "</dd>" nl)))
+       (requires
+	. ,(lambda (tag . elems)
+	     (list "<dt><strong>Requires</strong><dt><dd>"
+		   elems "</dd>" nl)))
+       )
+      . ,(lambda (tag key title . elems)
+	   (post-order
+	    `((a (@ (name ,key)) (n_))
+	      (h2 ,title)
+	      (dl (insert-elems))
+	      )
+	    `(,@universal-protected-rules
+	      (insert-elems
+	       . ,(lambda (tag) elems))))))
+)))
diff --git a/collects/ssax/SXML-to-HTML.scm b/collects/ssax/SXML-to-HTML.scm
new file mode 100644
index 0000000000..e1a240d843
--- /dev/null
+++ b/collects/ssax/SXML-to-HTML.scm
@@ -0,0 +1,106 @@
+;			HTML Authoring in SXML
+;
+; The present file defines and demonstrates a function SXML->HTML, the
+; most generic transformation of SXML into the corresponding HTML
+; document. The SXML tree is traversed post-order and converted into
+; another tree, which, written in a depth-first fashion, results in a
+; HTML document. The function SXML->HTML can generate an arbitrary
+; HTML markup, for any existing or yet to be introduced HTML
+; tag. Furthermore, the function supports one higher-level tag,
+; 'html:begin'. As the source code below indicates, SXML->HTML can be
+; trivially extended to support other higher-level tags.
+;
+; The proper HTML markup is being created by a set of node
+; handlers. An iterator 'post-order' executes these functions while it
+; traverses an SXML tree.
+;
+; Each node handler takes a tag (the head of an SXML node) and the
+; list of children nodes, if any. A handler returns a fragment or a
+; list of HTML fragments -- which become arguments to a handler of a
+; parent SXML node.  A function SRV:send-reply takes the resulting
+; tree of fragments and writes out the fragments in a depth-first
+; order. The output is an HTML document that corresponds to the
+; original SXML tree.
+;
+; This pretty-printing operation  makes it possible to author and
+; compose HTML documents in their SXML form. SXML is more concise and
+; expressive than a raw markup language. SXML representing regular
+; Scheme code can be entered in any Scheme-sensitive editor. SXML as a
+; data structure -- a list -- can likewise be composed as a literal or
+; quasi-literal expression. Furthermore, SXML can be produced by regular
+; Scheme functions, which may make authoring more succinct, advanced,
+; and less tedious, as the code below illustrates.
+;
+; IMPORT
+; A prelude appropriate for your Scheme system
+;	(myenv-bigloo.scm, myenv-mit.scm, etc.)
+; util.scm for make-char-quotator
+; SXML-tree-trans.scm for post-order
+;
+; EXPORT
+; SXML->HTML enattr entag string->goodHTML
+;
+; All these files are available in the same directory as this file.
+; See vSXML-to-HTML.scm for the validation code, which also
+; serves as usage examples.
+;
+; See http://pobox.com/~oleg/ftp/Scheme/xml.html#XML-authoring
+; for more examples and explanation.
+;
+; $Id: SXML-to-HTML.scm,v 1.2 2004/11/09 14:11:40 sperber Exp $
+
+
+; The following procedure is the most generic transformation of SXML
+; into the corresponding HTML document. The SXML tree is traversed
+; post-oder (depth-first) and transformed into another tree, which,
+; written in a depth-first fashion, results in an HTML document.
+ 
+(define (SXML->HTML tree)
+ (SRV:send-reply
+   (pre-post-order tree
+                ; Universal transformation rules. Work for every HTML,
+                ; present and future
+    `((@
+      ((*default*       ; local override for attributes
+        . ,(lambda (attr-key . value) (enattr attr-key value))))
+      . ,(lambda (trigger . value) (cons '@ value)))
+     (*default* . ,(lambda (tag . elems) (entag tag elems)))
+     (*text* . ,(lambda (trigger str) 
+		  (if (string? str) (string->goodHTML str) str)))
+ 
+                ; Handle a nontraditional but convenient top-level element:
+                ; (html:begin title <html-body>) element
+     (html:begin . ,(lambda (tag title . elems)
+        (list "Content-type: text/html"         ; HTTP headers
+              nl nl                            ; two nl end the headers
+              "<HTML><HEAD><TITLE>" title "</TITLE></HEAD>"
+	      elems
+              "</HTML>"))))
+ 
+     )))
+
+; The following two functions create the HTML markup for tags and attributes.
+; They are being used in the node handlers for the post-order function, see
+; above.
+
+(define (entag tag elems)
+  (if (and (pair? elems) (pair? (car elems)) (eq? '@ (caar elems)))
+    (list #\newline #\< tag (cdar elems) #\>
+      (and (pair? (cdr elems))
+	(list (cdr elems) "</" tag #\>)))
+    (list #\newline #\< tag #\> (and (pair? elems) (list elems "</" tag #\>))
+      )))
+ 
+(define (enattr attr-key value)
+  (if (null? value) (list #\space attr-key)
+    (list #\space attr-key "=\"" value #\")))
+
+
+; Given a string, check to make sure it does not contain characters
+; such as '<' or '&' that require encoding. Return either the original
+; string, or a list of string fragments with special characters
+; replaced by appropriate character entities.
+
+(define string->goodHTML
+  (make-char-quotator
+   '((#\< . "&lt;") (#\> . "&gt;") (#\& . "&amp;") (#\" . "&quot;"))))
diff --git a/collects/ssax/SXML-tree-trans.scm b/collects/ssax/SXML-tree-trans.scm
new file mode 100644
index 0000000000..e55bb95767
--- /dev/null
+++ b/collects/ssax/SXML-tree-trans.scm
@@ -0,0 +1,249 @@
+;		XML/HTML processing in Scheme
+;		SXML expression tree transformers
+;
+; IMPORT
+; A prelude appropriate for your Scheme system
+;	(myenv-bigloo.scm, myenv-mit.scm, etc.)
+;
+; EXPORT
+; (provide SRV:send-reply
+;	   post-order pre-post-order replace-range)
+;
+; See vSXML-tree-trans.scm for the validation code, which also
+; serves as usage examples.
+;
+; $Id: SXML-tree-trans.scm,v 1.2 2004/11/09 14:11:40 sperber Exp $
+
+
+; Output the 'fragments'
+; The fragments are a list of strings, characters,
+; numbers, thunks, #f, #t -- and other fragments.
+; The function traverses the tree depth-first, writes out
+; strings and characters, executes thunks, and ignores
+; #f and '().
+; The function returns #t if anything was written at all;
+; otherwise the result is #f
+; If #t occurs among the fragments, it is not written out
+; but causes the result of SRV:send-reply to be #t
+
+(define (SRV:send-reply . fragments)
+  (let loop ((fragments fragments) (result #f))
+    (cond
+      ((null? fragments) result)
+      ((not (car fragments)) (loop (cdr fragments) result))
+      ((null? (car fragments)) (loop (cdr fragments) result))
+      ((eq? #t (car fragments)) (loop (cdr fragments) #t))
+      ((pair? (car fragments))
+        (loop (cdr fragments) (loop (car fragments) result)))
+      ((procedure? (car fragments))
+        ((car fragments))
+        (loop (cdr fragments) #t))
+      (else
+        (display (car fragments))
+        (loop (cdr fragments) #t)))))
+
+
+
+;------------------------------------------------------------------------
+;	          Traversal of an SXML tree or a grove:
+;			a <Node> or a <Nodelist>
+;
+; A <Node> and a <Nodelist> are mutually-recursive datatypes that
+; underlie the SXML tree:
+;	<Node> ::= (name . <Nodelist>) | "text string"
+; An (ordered) set of nodes is just a list of the constituent nodes:
+; 	<Nodelist> ::= (<Node> ...)
+; Nodelists, and Nodes other than text strings are both lists. A
+; <Nodelist> however is either an empty list, or a list whose head is
+; not a symbol (an atom in general). A symbol at the head of a node is
+; either an XML name (in which case it's a tag of an XML element), or
+; an administrative name such as '@'.
+; See SXPath.scm and SSAX.scm for more information on SXML.
+
+
+; Pre-Post-order traversal of a tree and creation of a new tree:
+;	pre-post-order:: <tree> x <bindings> -> <new-tree>
+; where
+; <bindings> ::= (<binding> ...)
+; <binding> ::= (<trigger-symbol> *preorder* . <handler>) |
+;               (<trigger-symbol> *macro* . <handler>) |
+;		(<trigger-symbol> <new-bindings> . <handler>) |
+;		(<trigger-symbol> . <handler>)
+; <trigger-symbol> ::= XMLname | *text* | *default*
+; <handler> :: <trigger-symbol> x [<tree>] -> <new-tree>
+;
+; The pre-post-order function visits the nodes and nodelists
+; pre-post-order (depth-first).  For each <Node> of the form (name
+; <Node> ...) it looks up an association with the given 'name' among
+; its <bindings>. If failed, pre-post-order tries to locate a
+; *default* binding. It's an error if the latter attempt fails as
+; well.  Having found a binding, the pre-post-order function first
+; checks to see if the binding is of the form
+;	(<trigger-symbol> *preorder* . <handler>)
+; If it is, the handler is 'applied' to the current node. Otherwise,
+; the pre-post-order function first calls itself recursively for each
+; child of the current node, with <new-bindings> prepended to the
+; <bindings> in effect. The result of these calls is passed to the
+; <handler> (along with the head of the current <Node>). To be more
+; precise, the handler is _applied_ to the head of the current node
+; and its processed children. The result of the handler, which should
+; also be a <tree>, replaces the current <Node>. If the current <Node>
+; is a text string or other atom, a special binding with a symbol
+; *text* is looked up.
+;
+; A binding can also be of a form
+;	(<trigger-symbol> *macro* . <handler>)
+; This is equivalent to *preorder* described above. However, the result
+; is re-processed again, with the current stylesheet.
+
+(define (pre-post-order tree bindings)
+  (let* ((default-binding (assq '*default* bindings))
+	 (text-binding (or (assq '*text* bindings) default-binding))
+	 (text-handler			; Cache default and text bindings
+	   (and text-binding
+	     (if (procedure? (cdr text-binding))
+	         (cdr text-binding) (cddr text-binding)))))
+    (let loop ((tree tree))
+      (cond
+	((null? tree) '())
+	((not (pair? tree))
+	  (let ((trigger '*text*))
+	    (if text-handler (text-handler trigger tree)
+	      (error "Unknown binding for " trigger " and no default"))))
+	((not (symbol? (car tree))) (map loop tree)) ; tree is a nodelist
+	(else				; tree is an SXML node
+	  (let* ((trigger (car tree))
+		 (binding (or (assq trigger bindings) default-binding)))
+	    (cond
+	      ((not binding) 
+		(error "Unknown binding for " trigger " and no default"))
+	      ((not (pair? (cdr binding)))  ; must be a procedure: handler
+		(apply (cdr binding) trigger (map loop (cdr tree))))
+	      ((eq? '*preorder* (cadr binding))
+		(apply (cddr binding) tree))
+	      ((eq? '*macro* (cadr binding))
+		(loop (apply (cddr binding) tree)))
+	      (else			    ; (cadr binding) is a local binding
+		(apply (cddr binding) trigger 
+		  (pre-post-order (cdr tree) (append (cadr binding) bindings)))
+		))))))))
+
+; post-order is a strict subset of pre-post-order without *preorder*
+; (let alone *macro*) traversals. 
+; Now pre-post-order is actually faster than the old post-order.
+; The function post-order is deprecated and is aliased below for
+; backward compatibility.
+(define post-order pre-post-order)
+
+;------------------------------------------------------------------------
+;			Extended tree fold
+; tree = atom | (node-name tree ...)
+;
+; foldts fdown fup fhere seed (Leaf str) = fhere seed str
+; foldts fdown fup fhere seed (Nd kids) =
+;         fup seed $ foldl (foldts fdown fup fhere) (fdown seed) kids
+
+; procedure fhere: seed -> atom -> seed
+; procedure fdown: seed -> node -> seed
+; procedure fup: parent-seed -> last-kid-seed -> node -> seed
+; foldts returns the final seed
+
+(define (foldts fdown fup fhere seed tree)
+  (cond
+   ((null? tree) seed)
+   ((not (pair? tree))		; An atom
+    (fhere seed tree))
+   (else
+    (let loop ((kid-seed (fdown seed tree)) (kids (cdr tree)))
+      (if (null? kids)
+	  (fup seed kid-seed tree)
+	  (loop (foldts fdown fup fhere kid-seed (car kids))
+		(cdr kids)))))))
+
+;------------------------------------------------------------------------
+; Traverse a forest depth-first and cut/replace ranges of nodes.
+;
+; The nodes that define a range don't have to have the same immediate
+; parent, don't have to be on the same level, and the end node of a
+; range doesn't even have to exist. A replace-range procedure removes
+; nodes from the beginning node of the range up to (but not including)
+; the end node of the range.  In addition, the beginning node of the
+; range can be replaced by a node or a list of nodes. The range of
+; nodes is cut while depth-first traversing the forest. If all
+; branches of the node are cut a node is cut as well.  The procedure
+; can cut several non-overlapping ranges from a forest.
+
+;	replace-range:: BEG-PRED x END-PRED x FOREST -> FOREST
+; where
+;	type FOREST = (NODE ...)
+;	type NODE = Atom | (Name . FOREST) | FOREST
+;
+; The range of nodes is specified by two predicates, beg-pred and end-pred.
+;	beg-pred:: NODE -> #f | FOREST
+;	end-pred:: NODE -> #f | FOREST
+; The beg-pred predicate decides on the beginning of the range. The node
+; for which the predicate yields non-#f marks the beginning of the range
+; The non-#f value of the predicate replaces the node. The value can be a
+; list of nodes. The replace-range procedure then traverses the tree and skips
+; all the nodes, until the end-pred yields non-#f. The value of the end-pred
+; replaces the end-range node. The new end node and its brothers will be
+; re-scanned.
+; The predicates are evaluated pre-order. We do not descend into a node that
+; is marked as the beginning of the range.
+
+(define (replace-range beg-pred end-pred forest)
+
+  ; loop forest keep? new-forest
+  ; forest is the forest to traverse
+  ; new-forest accumulates the nodes we will keep, in the reverse
+  ; order
+  ; If keep? is #t, keep the curr node if atomic. If the node is not atomic,
+  ; traverse its children and keep those that are not in the skip range.
+  ; If keep? is #f, skip the current node if atomic. Otherwise,
+  ; traverse its children. If all children are skipped, skip the node
+  ; as well.
+
+  (define (loop forest keep? new-forest)
+    (if (null? forest) (values (reverse new-forest) keep?)
+	(let ((node (car forest)))
+	  (if keep?
+	      (cond			; accumulate mode
+	       ((beg-pred node) =>	; see if the node starts the skip range
+		(lambda (repl-branches)	; if so, skip/replace the node
+		  (loop (cdr forest) #f 
+			(append (reverse repl-branches) new-forest))))
+	       ((not (pair? node))	; it's an atom, keep it
+		(loop (cdr forest) keep? (cons node new-forest)))
+	       (else
+		(let*-values
+		 (((node?) (symbol? (car node))) ; or is it a nodelist?
+		  ((new-kids keep?)		 ; traverse its children
+		   (loop (if node? (cdr node) node) #t '())))
+		 (loop (cdr forest) keep?
+		       (cons 
+			(if node? (cons (car node) new-kids) new-kids)
+			new-forest)))))
+	      ; skip mode
+	      (cond
+	       ((end-pred node) =>	; end the skip range
+		(lambda (repl-branches)	; repl-branches will be re-scanned
+		  (loop (append repl-branches (cdr forest)) #t
+			new-forest)))
+	       ((not (pair? node))	; it's an atom, skip it
+		(loop (cdr forest) keep? new-forest))
+	       (else
+		(let*-values
+		 (((node?) (symbol? (car node)))  ; or is it a nodelist?
+		  ((new-kids keep?)		  ; traverse its children
+		   (loop (if node? (cdr node) node) #f '())))
+		 (loop (cdr forest) keep?
+		       (if (or keep? (pair? new-kids))
+			   (cons
+			    (if node? (cons (car node) new-kids) new-kids)
+			    new-forest)
+			   new-forest)		; if all kids are skipped
+		       ))))))))			; skip the node too
+  
+  (let*-values (((new-forest keep?) (loop forest #t '())))
+     new-forest))
+
diff --git a/collects/ssax/SXPath-old.scm b/collects/ssax/SXPath-old.scm
new file mode 100644
index 0000000000..7a15e7922c
--- /dev/null
+++ b/collects/ssax/SXPath-old.scm
@@ -0,0 +1,1216 @@
+;			XML processing in Scheme
+;		     SXPath -- SXML Query Language
+;
+; SXPath is a query language for SXML, an instance of XML Information
+; set (Infoset) in the form of s-expressions. See SSAX.scm for the
+; definition of SXML and more details. SXPath is also a translation into
+; Scheme of an XML Path Language, XPath:
+;	http://www.w3.org/TR/xpath
+; XPath and SXPath describe means of selecting a set of Infoset's items
+; or their properties.
+;
+; To facilitate queries, XPath maps the XML Infoset into an explicit
+; tree, and introduces important notions of a location path and a
+; current, context node. A location path denotes a selection of a set of
+; nodes relative to a context node. Any XPath tree has a distinguished,
+; root node -- which serves as the context node for absolute location
+; paths. Location path is recursively defined as a location step joined
+; with a location path. A location step is a simple query of the
+; database relative to a context node. A step may include expressions
+; that further filter the selected set. Each node in the resulting set
+; is used as a context node for the adjoining location path. The result
+; of the step is a union of the sets returned by the latter location
+; paths.
+;
+; The SXML representation of the XML Infoset (see SSAX.scm) is rather
+; suitable for querying as it is. Bowing to the XPath specification,
+; we will refer to SXML information items as 'Nodes':
+; 	<Node> ::= <Element> | <attributes-coll> | <attrib>
+; 		   | "text string" | <PI>
+; This production can also be described as
+;	<Node> ::= (name . <Nodeset>) | "text string"
+; An (ordered) set of nodes is just a list of the constituent nodes:
+; 	<Nodeset> ::= (<Node> ...)
+; Nodesets, and Nodes other than text strings are both lists. A
+; <Nodeset> however is either an empty list, or a list whose head is not
+; a symbol.  A symbol at the head of a node is either an XML name (in
+; which case it's a tag of an XML element), or an administrative name
+; such as '@'.  This uniform list representation makes processing rather
+; simple and elegant, while avoiding confusion. The multi-branch tree
+; structure formed by the mutually-recursive datatypes <Node> and
+; <Nodeset> lends itself well to processing by functional languages.
+;
+; A location path is in fact a composite query over an XPath tree or
+; its branch. A singe step is a combination of a projection, selection
+; or a transitive closure. Multiple steps are combined via join and
+; union operations. This insight allows us to _elegantly_ implement
+; XPath as a sequence of projection and filtering primitives --
+; converters -- joined by _combinators_. Each converter takes a node
+; and returns a nodeset which is the result of the corresponding query
+; relative to that node. A converter can also be called on a set of
+; nodes. In that case it returns a union of the corresponding queries over
+; each node in the set. The union is easily implemented as a list
+; append operation as all nodes in a SXML tree are considered
+; distinct, by XPath conventions. We also preserve the order of the
+; members in the union. Query combinators are high-order functions:
+; they take converter(s) (which is a Node|Nodeset -> Nodeset function)
+; and compose or otherwise combine them. We will be concerned with
+; only relative location paths [XPath]: an absolute location path is a
+; relative path applied to the root node.
+;
+; Similarly to XPath, SXPath defines full and abbreviated notations
+; for location paths. In both cases, the abbreviated notation can be
+; mechanically expanded into the full form by simple rewriting
+; rules. In case of SXPath the corresponding rules are given as
+; comments to a sxpath function, below. The regression test suite at
+; the end of this file shows a representative sample of SXPaths in
+; both notations, juxtaposed with the corresponding XPath
+; expressions. Most of the samples are borrowed literally from the
+; XPath specification, while the others are adjusted for our running
+; example, tree1.
+;
+; To do:
+; Rename filter to node-filter or ns-filter
+; Use ;=== for chapters, ;--- for sections, and ;^^^ for end sections
+;
+; $Id: SXPath-old.scm,v 1.2 2004/11/09 14:11:40 sperber Exp $
+
+
+	; See http://pobox.com/~oleg/ftp/Scheme/myenv.scm
+	; See http://pobox.com/~oleg/ftp/Scheme/myenv-scm.scm
+	; See http://pobox.com/~oleg/ftp/Scheme/myenv-bigloo.scm
+;(module SXPath
+;  (include "myenv-bigloo.scm"))		; For use with Bigloo 2.2b
+;(load "myenv-scm.scm")		; For use with SCM v5d2
+;(include "myenv.scm")		; For use with Gambit-C 3.0
+
+
+
+(define (nodeset? x)
+  (or (and (pair? x) (not (symbol? (car x)))) (null? x)))
+
+;-------------------------
+; Basic converters and applicators
+; A converter is a function
+;	type Converter = Node|Nodeset -> Nodeset
+; A converter can also play a role of a predicate: in that case, if a
+; converter, applied to a node or a nodeset, yields a non-empty
+; nodeset, the converter-predicate is deemed satisfied. Throughout
+; this file a nil nodeset is equivalent to #f in denoting a failure.
+
+; The following function implements a 'Node test' as defined in
+; Sec. 2.3 of XPath document. A node test is one of the components of a
+; location step. It is also a converter-predicate in SXPath.
+;
+; The function node-typeof? takes a type criterion and returns a function,
+; which, when applied to a node, will tell if the node satisfies
+; the test.
+;	node-typeof? :: Crit -> Node -> Boolean
+;
+; The criterion 'crit' is a symbol, one of the following:
+;	id		- tests if the Node has the right name (id)
+;	@		- tests if the Node is an <attributes-coll>
+;	*		- tests if the Node is an <Element>
+;	*text*		- tests if the Node is a text node
+;	*PI*		- tests if the Node is a PI node
+;	*any*		- #t for any type of Node
+
+(define (node-typeof? crit)
+  (lambda (node)
+    (case crit
+      ((*) (and (pair? node) (not (memq (car node) '(@ *PI*)))))
+      ((*any*) #t)
+      ((*text*) (string? node))
+      (else
+       (and (pair? node) (eq? crit (car node))))
+)))
+
+
+; Curried equivalence converter-predicates
+(define (node-eq? other)
+  (lambda (node)
+    (eq? other node)))
+
+(define (node-equal? other)
+  (lambda (node)
+    (equal? other node)))
+
+; node-pos:: N -> Nodeset -> Nodeset, or
+; node-pos:: N -> Converter
+; Select the N'th element of a Nodeset and return as a singular Nodeset;
+; Return an empty nodeset if the Nth element does not exist.
+; ((node-pos 1) Nodeset) selects the node at the head of the Nodeset,
+; if exists; ((node-pos 2) Nodeset) selects the Node after that, if
+; exists.
+; N can also be a negative number: in that case the node is picked from
+; the tail of the list.
+; ((node-pos -1) Nodeset) selects the last node of a non-empty nodeset;
+; ((node-pos -2) Nodeset) selects the last but one node, if exists.
+
+(define (node-pos n)
+  (lambda (nodeset)
+    (cond
+     ((not (nodeset? nodeset)) '())
+     ((null? nodeset) nodeset)
+     ((eqv? n 1) (list (car nodeset)))
+     ((negative? n) ((node-pos (+ n 1 (length nodeset))) nodeset))
+     (else
+      (assert (positive? n))
+      ((node-pos (dec n)) (cdr nodeset))))))
+
+; filter:: Converter -> Converter
+; A filter applicator, which introduces a filtering context. The argument
+; converter is considered a predicate, with either #f or nil result meaning
+; failure.
+(define (filter pred?)
+  (lambda (lst)	; a nodeset or a node (will be converted to a singleton nset)
+    (let loop ((lst (if (nodeset? lst) lst (list lst))) (res '()))
+      (if (null? lst)
+	  (reverse res)
+	  (let ((pred-result (pred? (car lst))))
+	    (loop (cdr lst)
+		  (if (and pred-result (not (null? pred-result)))
+		      (cons (car lst) res)
+		      res)))))))
+
+; take-until:: Converter -> Converter, or
+; take-until:: Pred -> Node|Nodeset -> Nodeset
+; Given a converter-predicate and a nodeset, apply the predicate to
+; each element of the nodeset, until the predicate yields anything but #f or
+; nil. Return the elements of the input nodeset that have been processed
+; till that moment (that is, which fail the predicate).
+; take-until is a variation of the filter above: take-until passes
+; elements of an ordered input set till (but not including) the first
+; element that satisfies the predicate.
+; The nodeset returned by ((take-until (not pred)) nset) is a subset -- 
+; to be more precise, a prefix -- of the nodeset returned by
+; ((filter pred) nset)
+
+(define (take-until pred?)
+  (lambda (lst)	; a nodeset or a node (will be converted to a singleton nset)
+    (let loop ((lst (if (nodeset? lst) lst (list lst))))
+      (if (null? lst) lst
+	  (let ((pred-result (pred? (car lst))))
+	    (if (and pred-result (not (null? pred-result)))
+		'()
+		(cons (car lst) (loop (cdr lst)))))
+	  ))))
+
+
+; take-after:: Converter -> Converter, or
+; take-after:: Pred -> Node|Nodeset -> Nodeset
+; Given a converter-predicate and a nodeset, apply the predicate to
+; each element of the nodeset, until the predicate yields anything but #f or
+; nil. Return the elements of the input nodeset that have not been processed:
+; that is, return the elements of the input nodeset that follow the first
+; element that satisfied the predicate.
+; take-after along with take-until partition an input nodeset into three
+; parts: the first element that satisfies a predicate, all preceding
+; elements and all following elements.
+
+(define (take-after pred?)
+  (lambda (lst)	; a nodeset or a node (will be converted to a singleton nset)
+    (let loop ((lst (if (nodeset? lst) lst (list lst))))
+      (if (null? lst) lst
+	  (let ((pred-result (pred? (car lst))))
+	    (if (and pred-result (not (null? pred-result)))
+		(cdr lst)
+		(loop (cdr lst))))
+	  ))))
+
+; Apply proc to each element of lst and return the list of results.
+; if proc returns a nodeset, splice it into the result
+;
+; From another point of view, map-union is a function Converter->Converter,
+; which places an argument-converter in a joining context.
+
+(define (map-union proc lst)
+  (if (null? lst) lst
+      (let ((proc-res (proc (car lst))))
+	((if (nodeset? proc-res) append cons)
+	 proc-res (map-union proc (cdr lst))))))
+
+; node-reverse :: Converter, or
+; node-reverse:: Node|Nodeset -> Nodeset
+; Reverses the order of nodes in the nodeset
+; This basic converter is needed to implement a reverse document order
+; (see the XPath Recommendation).
+(define node-reverse 
+  (lambda (node-or-nodeset)
+    (if (not (nodeset? node-or-nodeset)) (list node-or-nodeset)
+	(reverse node-or-nodeset))))
+
+; node-trace:: String -> Converter
+; (node-trace title) is an identity converter. In addition it prints out
+; a node or nodeset it is applied to, prefixed with the 'title'.
+; This converter is very useful for debugging.
+
+(define (node-trace title)
+  (lambda (node-or-nodeset)
+    (cout nl "-->")
+    (display title)
+    (display " :")
+    (pretty-print node-or-nodeset)
+    node-or-nodeset))
+
+
+;-------------------------
+; Converter combinators
+;
+; Combinators are higher-order functions that transmogrify a converter
+; or glue a sequence of converters into a single, non-trivial
+; converter. The goal is to arrive at converters that correspond to
+; XPath location paths.
+;
+; From a different point of view, a combinator is a fixed, named
+; _pattern_ of applying converters. Given below is a complete set of
+; such patterns that together implement XPath location path
+; specification. As it turns out, all these combinators can be built
+; from a small number of basic blocks: regular functional composition,
+; map-union and filter applicators, and the nodeset union.
+
+
+
+; select-kids:: Pred -> Node -> Nodeset
+; Given a Node, return an (ordered) subset its children that satisfy
+; the Pred (a converter, actually)
+; select-kids:: Pred -> Nodeset -> Nodeset
+; The same as above, but select among children of all the nodes in
+; the Nodeset
+;
+; More succinctly, the signature of this function is
+; select-kids:: Converter -> Converter
+
+(define (select-kids test-pred?)
+  (lambda (node)		; node or node-set
+    (cond 
+     ((null? node) node)
+     ((not (pair? node)) '())   ; No children
+     ((symbol? (car node))
+      ((filter test-pred?) (cdr node)))	; it's a single node
+     (else (map-union (select-kids test-pred?) node)))))
+
+
+; node-self:: Pred -> Node -> Nodeset, or
+; node-self:: Converter -> Converter
+; Similar to select-kids but apply to the Node itself rather
+; than to its children. The resulting Nodeset will contain either one
+; component, or will be empty (if the Node failed the Pred).
+(define node-self filter)
+
+
+; node-join:: [LocPath] -> Node|Nodeset -> Nodeset, or
+; node-join:: [Converter] -> Converter
+; join the sequence of location steps or paths as described
+; in the title comments above.
+(define (node-join . selectors)
+  (lambda (nodeset)		; Nodeset or node
+    (let loop ((nodeset nodeset) (selectors selectors))
+      (if (null? selectors) nodeset
+	  (loop 
+	   (if (nodeset? nodeset)
+	       (map-union (car selectors) nodeset)
+	       ((car selectors) nodeset))
+	   (cdr selectors))))))
+
+
+; node-reduce:: [LocPath] -> Node|Nodeset -> Nodeset, or
+; node-reduce:: [Converter] -> Converter
+; A regular functional composition of converters.
+; From a different point of view,
+;    ((apply node-reduce converters) nodeset)
+; is equivalent to
+;    (foldl apply nodeset converters)
+; i.e., folding, or reducing, a list of converters with the nodeset
+; as a seed.
+(define (node-reduce . converters)
+  (lambda (nodeset)		; Nodeset or node
+    (let loop ((nodeset nodeset) (converters converters))
+      (if (null? converters) nodeset
+	  (loop ((car converters) nodeset) (cdr converters))))))
+
+
+; node-or:: [Converter] -> Converter
+; This combinator applies all converters to a given node and
+; produces the union of their results.
+; This combinator corresponds to a union, '|' operation for XPath
+; location paths.
+; (define (node-or . converters)
+;   (lambda (node-or-nodeset)
+;     (if (null? converters) node-or-nodeset
+; 	(append 
+; 	 ((car converters) node-or-nodeset)
+; 	 ((apply node-or (cdr converters)) node-or-nodeset)))))
+; More optimal implementation follows
+(define (node-or . converters)
+  (lambda (node-or-nodeset)
+    (let loop ((result '()) (converters converters))
+      (if (null? converters) result
+	  (loop (append result (or ((car converters) node-or-nodeset) '()))
+		(cdr converters))))))
+
+
+; node-closure:: Converter -> Converter
+; Select all _descendants_ of a node that satisfy a converter-predicate.
+; This combinator is similar to select-kids but applies to
+; grand... children as well.
+; This combinator implements the "descendant::" XPath axis
+; Conceptually, this combinator can be expressed as
+; (define (node-closure f)
+;      (node-or
+;        (select-kids f)
+;	 (node-reduce (select-kids (node-typeof? '*)) (node-closure f))))
+; This definition, as written, looks somewhat like a fixpoint, and it
+; will run forever. It is obvious however that sooner or later
+; (select-kids (node-typeof? '*)) will return an empty nodeset. At
+; this point further iterations will no longer affect the result and
+; can be stopped.
+
+(define (node-closure test-pred?)	    
+  (lambda (node)		; Nodeset or node
+    (let loop ((parent node) (result '()))
+      (if (null? parent) result
+	  (loop ((select-kids (node-typeof? '*)) parent)
+		(append result
+			((select-kids test-pred?) parent)))
+	  ))))
+
+; node-parent:: RootNode -> Converter
+; (node-parent rootnode) yields a converter that returns a parent of a
+; node it is applied to. If applied to a nodeset, it returns the list
+; of parents of nodes in the nodeset. The rootnode does not have
+; to be the root node of the whole SXML tree -- it may be a root node
+; of a branch of interest.
+; Given the notation of Philip Wadler's paper on semantics of XSLT,
+;  parent(x) = { y | y=subnode*(root), x=subnode(y) }
+; Therefore, node-parent is not the fundamental converter: it can be
+; expressed through the existing ones.  Yet node-parent is a rather
+; convenient converter. It corresponds to a parent:: axis of SXPath.
+; Note that the parent:: axis can be used with an attribute node as well!
+
+(define (node-parent rootnode)
+  (lambda (node)		; Nodeset or node
+    (if (nodeset? node) (map-union (node-parent rootnode) node)
+	(let ((pred
+	       (node-or
+		(node-reduce
+		 (node-self (node-typeof? '*))
+		 (select-kids (node-eq? node)))
+		(node-join
+		 (select-kids (node-typeof? '@))
+		 (select-kids (node-eq? node))))))
+	  ((node-or
+	    (node-self pred)
+	    (node-closure pred))
+	   rootnode)))))
+
+;-------------------------
+; Evaluate an abbreviated SXPath
+;	sxpath:: AbbrPath -> Converter, or
+;	sxpath:: AbbrPath -> Node|Nodeset -> Nodeset
+; AbbrPath is a list. It is translated to the full SXPath according
+; to the following rewriting rules
+; (sxpath '()) -> (node-join)
+; (sxpath '(path-component ...)) ->
+;		(node-join (sxpath1 path-component) (sxpath '(...)))
+; (sxpath1 '//) -> (node-or 
+;		     (node-self (node-typeof? '*any*))
+;		      (node-closure (node-typeof? '*any*)))
+; (sxpath1 '(equal? x)) -> (select-kids (node-equal? x))
+; (sxpath1 '(eq? x))    -> (select-kids (node-eq? x))
+; (sxpath1 ?symbol)     -> (select-kids (node-typeof? ?symbol)
+; (sxpath1 procedure)   -> procedure
+; (sxpath1 '(?symbol ...)) -> (sxpath1 '((?symbol) ...))
+; (sxpath1 '(path reducer ...)) ->
+;		(node-reduce (sxpath path) (sxpathr reducer) ...)
+; (sxpathr number)      -> (node-pos number)
+; (sxpathr path-filter) -> (filter (sxpath path-filter))
+
+(define (sxpath path)
+  (lambda (nodeset)
+    (let loop ((nodeset nodeset) (path path))
+    (cond
+     ((null? path) nodeset)
+     ((nodeset? nodeset)
+      (map-union (sxpath path) nodeset))
+     ((procedure? (car path))
+      (loop ((car path) nodeset) (cdr path)))
+     ((eq? '// (car path))
+      (loop
+       ((if (nodeset? nodeset) append cons) nodeset
+	((node-closure (node-typeof? '*any*)) nodeset))
+       (cdr path)))
+     ((symbol? (car path))
+      (loop ((select-kids (node-typeof? (car path))) nodeset)
+	    (cdr path)))
+     ((and (pair? (car path)) (eq? 'equal? (caar path)))
+      (loop ((select-kids (apply node-equal? (cdar path))) nodeset)
+	    (cdr path)))
+     ((and (pair? (car path)) (eq? 'eq? (caar path)))
+      (loop ((select-kids (apply node-eq? (cdar path))) nodeset)
+	    (cdr path)))
+     ((pair? (car path))
+      (let reducer ((nodeset 
+		     (if (symbol? (caar path))
+			 ((select-kids (node-typeof? (caar path))) nodeset)
+			 (loop nodeset (caar path))))
+		    (reducing-path (cdar path)))
+	(cond
+	 ((null? reducing-path) (loop nodeset (cdr path)))
+	 ((number? (car reducing-path))
+	  (reducer ((node-pos (car reducing-path)) nodeset)
+		   (cdr reducing-path)))
+	 (else
+	  (reducer ((filter (sxpath (car reducing-path))) nodeset)
+		   (cdr reducing-path))))))
+     (else
+      (error "Invalid path step: " (car path)))
+))))
+
+;------------------------------------------------------------------------
+; Sample XPath/SXPath expressions: regression test suite for the
+; implementation above.
+
+; A running example
+
+(define tree1 
+  '(html
+    (head (title "Slides"))
+    (body
+     (p (@ (align "center"))
+	(table (@ (style "font-size: x-large"))
+	       (tr
+		(td (@ (align "right")) "Talks ")
+		(td (@ (align "center")) " = ")
+		(td " slides + transition"))
+	       (tr (td)
+		   (td (@ (align "center")) " = ")
+		   (td " data + control"))
+	       (tr (td)
+		   (td (@ (align "center")) " = ")
+		   (td " programs"))))
+     (ul
+      (li (a (@ (href "slides/slide0001.gif")) "Introduction"))
+      (li (a (@ (href "slides/slide0010.gif")) "Summary")))
+     )))
+
+
+; Example from a posting "Re: DrScheme and XML", 
+; Shriram Krishnamurthi, comp.lang.scheme, Nov. 26. 1999.
+; http://www.deja.com/getdoc.xp?AN=553507805
+(define tree3
+  '(poem (@ (title "The Lovesong of J. Alfred Prufrock")
+	    (poet "T. S. Eliot"))
+	 (stanza
+	  (line "Let us go then, you and I,")
+	  (line "When the evening is spread out against the sky")
+	  (line "Like a patient etherized upon a table:"))
+	 (stanza
+	  (line "In the room the women come and go")
+	  (line "Talking of Michaelangelo."))))
+
+; Validation Test harness
+
+(define-syntax run-test
+ (syntax-rules (define)
+   ((run-test "scan-exp" (define vars body))
+    (define vars (run-test "scan-exp" body)))
+   ((run-test "scan-exp" ?body)
+    (letrec-syntax
+      ((scan-exp			; (scan-exp body k)
+	 (syntax-rules (quote quasiquote !)
+	   ((scan-exp '() (k-head ! . args))
+	     (k-head '() . args))
+	   ((scan-exp (quote (hd . tl)) k)
+	     (scan-lit-lst (hd . tl) (do-wrap ! quasiquote k)))
+	   ((scan-exp (quasiquote (hd . tl)) k)
+	     (scan-lit-lst (hd . tl) (do-wrap ! quasiquote k)))
+	   ((scan-exp (quote x) (k-head ! . args))
+	     (k-head 
+	       (if (string? (quote x)) (string->symbol (quote x)) (quote x))
+	       . args))
+	   ((scan-exp (hd . tl) k)
+	     (scan-exp hd (do-tl ! scan-exp tl k)))
+	   ((scan-exp x (k-head ! . args))
+	     (k-head x . args))))
+	(do-tl
+	  (syntax-rules (!)
+	    ((do-tl processed-hd fn () (k-head ! . args))
+	      (k-head (processed-hd) . args))
+	    ((do-tl processed-hd fn old-tl k)
+	      (fn old-tl (do-cons ! processed-hd k)))))
+	(do-cons
+	  (syntax-rules (!)
+	    ((do-cons processed-tl processed-hd (k-head ! . args))
+	      (k-head (processed-hd . processed-tl) . args))))
+	(do-wrap
+	  (syntax-rules (!)
+	    ((do-wrap val fn (k-head ! . args))
+	      (k-head (fn val) . args))))
+	(do-finish
+	  (syntax-rules ()
+	    ((do-finish new-body) new-body)))
+
+	(scan-lit-lst			; scan literal list
+	  (syntax-rules (quote unquote unquote-splicing !)
+	   ((scan-lit-lst '() (k-head ! . args))
+	     (k-head '() . args))
+	   ((scan-lit-lst (quote (hd . tl)) k)
+	     (do-tl quote scan-lit-lst ((hd . tl)) k))
+	   ((scan-lit-lst (unquote x) k)
+	     (scan-exp x (do-wrap ! unquote k)))
+	   ((scan-lit-lst (unquote-splicing x) k)
+	     (scan-exp x (do-wrap ! unquote-splicing k)))
+	   ((scan-lit-lst (quote x) (k-head ! . args))
+	     (k-head 
+	       ,(if (string? (quote x)) (string->symbol (quote x)) (quote x))
+	       . args))
+	    ((scan-lit-lst (hd . tl) k)
+	      (scan-lit-lst hd (do-tl ! scan-lit-lst tl k)))
+	    ((scan-lit-lst x (k-head ! . args))
+	      (k-head x . args))))
+	)
+      (scan-exp ?body (do-finish !))))
+  ((run-test body ...)
+   (begin
+     (run-test "scan-exp" body) ...))
+))
+
+; Overwrite the above macro to switch the tests off
+; (define-macro (run-test selector node expected-result) #f)
+
+; Location path, full form: child::para 
+; Location path, abbreviated form: para
+; selects the para element children of the context node
+
+(let ((tree
+       '(elem (@) (para (@) "para") (br (@)) "cdata" (para (@) "second par"))
+       )
+      (expected '((para (@) "para") (para (@) "second par")))
+      )
+  (run-test (select-kids (node-typeof? 'para)) tree expected)
+  (run-test (sxpath '(para)) tree expected)
+)
+
+; Location path, full form: child::* 
+; Location path, abbreviated form: *
+; selects all element children of the context node
+
+(let ((tree
+       '(elem (@) (para (@) "para") (br (@)) "cdata" (para "second par"))
+       )
+      (expected
+       '((para (@) "para") (br (@)) (para "second par")))
+      )
+  (run-test (select-kids (node-typeof? '*)) tree expected)
+  (run-test (sxpath '(*)) tree expected)
+)
+
+
+
+; Location path, full form: child::text() 
+; Location path, abbreviated form: text()
+; selects all text node children of the context node
+(let ((tree
+       '(elem (@) (para (@) "para") (br (@)) "cdata" (para "second par"))
+       )
+      (expected
+       '("cdata"))
+      )
+  (run-test (select-kids (node-typeof? '*text*)) tree expected)
+  (run-test (sxpath '(*text*)) tree expected)
+)
+
+
+; Location path, full form: child::node() 
+; Location path, abbreviated form: node()
+; selects all the children of the context node, whatever their node type
+(let* ((tree
+       '(elem (@) (para (@) "para") (br (@)) "cdata" (para "second par"))
+       )
+      (expected (cdr tree))
+      )
+  (run-test (select-kids (node-typeof? '*any*)) tree expected)
+  (run-test (sxpath '(*any*)) tree expected)
+)
+
+; Location path, full form: child::*/child::para 
+; Location path, abbreviated form: */para
+; selects all para grandchildren of the context node
+
+(let ((tree
+       '(elem (@) (para (@) "para") (br (@)) "cdata" (para "second par")
+	(div (@ (name "aa")) (para "third para")))
+       )
+      (expected
+       '((para "third para")))
+      )
+  (run-test
+   (node-join (select-kids (node-typeof? '*))
+	      (select-kids (node-typeof? 'para)))
+   tree expected)
+  (run-test (sxpath '(* para)) tree expected)
+)
+
+
+; Location path, full form: attribute::name 
+; Location path, abbreviated form: @name
+; selects the 'name' attribute of the context node
+
+(let ((tree
+       '(elem (@ (name "elem") (id "idz")) 
+	(para (@) "para") (br (@)) "cdata" (para (@) "second par")
+	(div (@ (name "aa")) (para (@) "third para")))
+       )
+      (expected
+       '((name "elem")))
+      )
+  (run-test
+   (node-join (select-kids (node-typeof? '@))
+	      (select-kids (node-typeof? 'name)))
+   tree expected)
+  (run-test (sxpath '(@ name)) tree expected)
+)
+
+; Location path, full form:  attribute::* 
+; Location path, abbreviated form: @*
+; selects all the attributes of the context node
+(let ((tree
+       '(elem (@ (name "elem") (id "idz")) 
+	(para (@) "para") (br (@)) "cdata" (para "second par")
+	(div (@ (name "aa")) (para (@) "third para")))
+       )
+      (expected
+       '((name "elem") (id "idz")))
+      )
+  (run-test
+   (node-join (select-kids (node-typeof? '@))
+	      (select-kids (node-typeof? '*)))
+   tree expected)
+  (run-test (sxpath '(@ *)) tree expected)
+)
+
+
+; Location path, full form: descendant::para 
+; Location path, abbreviated form: .//para
+; selects the para element descendants of the context node
+
+(let ((tree
+       '(elem (@ (name "elem") (id "idz")) 
+	(para (@) "para") (br (@)) "cdata" (para "second par")
+	(div (@ (name "aa")) (para (@) "third para")))
+       )
+      (expected
+       '((para (@) "para") (para "second par") (para (@) "third para")))
+      )
+  (run-test
+   (node-closure (node-typeof? 'para))
+   tree expected)
+  (run-test (sxpath '(// para)) tree expected)
+)
+
+; Location path, full form: self::para 
+; Location path, abbreviated form: _none_
+; selects the context node if it is a para element; otherwise selects nothing
+
+(let ((tree
+       '(elem (@ (name "elem") (id "idz")) 
+	(para (@) "para") (br (@)) "cdata" (para "second par")
+	(div (@ (name "aa")) (para (@) "third para")))
+       )
+      )
+  (run-test (node-self (node-typeof? 'para)) tree '())
+  (run-test (node-self (node-typeof? 'elem)) tree (list tree))
+)
+
+; Location path, full form: descendant-or-self::node()
+; Location path, abbreviated form: //
+; selects the context node, all the children (including attribute nodes)
+; of the context node, and all the children of all the (element)
+; descendants of the context node.
+; This is _almost_ a powerset of the context node.
+(let* ((tree
+       '(para (@ (name "elem") (id "idz")) 
+	(para (@) "para") (br (@)) "cdata" (para "second par")
+	(div (@ (name "aa")) (para (@) "third para")))
+       )
+      (expected
+       (cons tree
+	(append (cdr tree)
+       '((@) "para" (@) "second par"
+	 (@ (name "aa")) (para (@) "third para")
+	 (@) "third para"))))
+      )
+  (run-test
+   (node-or
+    (node-self (node-typeof? '*any*))
+    (node-closure (node-typeof? '*any*)))
+   tree expected)
+  (run-test (sxpath '(//)) tree expected)
+)
+
+; Location path, full form: ancestor::div 
+; Location path, abbreviated form: _none_
+; selects all div ancestors of the context node
+; This Location expression is equivalent to the following:
+;	/descendant-or-self::div[descendant::node() = curr_node]
+; This shows that the ancestor:: axis is actually redundant. Still,
+; it can be emulated as the following SXPath expression demonstrates.
+
+; The insight behind "ancestor::div" -- selecting all "div" ancestors
+; of the current node -- is
+;  S[ancestor::div] context_node =
+;    { y | y=subnode*(root), context_node=subnode(subnode*(y)),
+;          isElement(y), name(y) = "div" }
+; We observe that
+;    { y | y=subnode*(root), pred(y) }
+; can be expressed in SXPath as 
+;    ((node-or (node-self pred) (node-closure pred)) root-node)
+; The composite predicate 'isElement(y) & name(y) = "div"' corresponds to 
+; (node-self (node-typeof? 'div)) in SXPath. Finally, filter
+; context_node=subnode(subnode*(y)) is tantamount to
+; (node-closure (node-eq? context-node)), whereas node-reduce denotes the
+; the composition of converters-predicates in the filtering context.
+
+(let*
+    ((root
+	 '(div (@ (name "elem") (id "idz")) 
+		(para (@) "para") (br (@)) "cdata" (para (@) "second par")
+		(div (@ (name "aa")) (para (@) "third para"))))
+     (context-node	; /descendant::any()[child::text() == "third para"]
+      (car
+       ((node-closure 
+	 (select-kids
+	  (node-equal? "third para")))
+       root)))
+    (pred
+     (node-reduce (node-self (node-typeof? 'div))
+		  (node-closure (node-eq? context-node))
+		  ))
+     )
+  (run-test
+   (node-or
+     (node-self pred)
+     (node-closure pred))
+   root 
+   (cons root
+	 '((div (@ (name "aa")) (para (@) "third para")))))
+)
+
+
+
+; Location path, full form: child::div/descendant::para 
+; Location path, abbreviated form: div//para
+; selects the para element descendants of the div element
+; children of the context node
+
+(let ((tree
+       '(elem (@ (name "elem") (id "idz")) 
+	(para (@) "para") (br (@)) "cdata" (para "second par")
+	(div (@ (name "aa")) (para (@) "third para")
+	     (div (para "fourth para"))))
+       )
+      (expected
+       '((para (@) "third para") (para "fourth para")))
+      )
+  (run-test
+   (node-join 
+    (select-kids (node-typeof? 'div))
+    (node-closure (node-typeof? 'para)))
+   tree expected)
+  (run-test (sxpath '(div // para)) tree expected)
+)
+
+
+; Location path, full form: /descendant::olist/child::item 
+; Location path, abbreviated form: //olist/item
+; selects all the item elements that have an olist parent (which is not root)
+; and that are in the same document as the context node
+; See the following test.
+
+; Location path, full form: /descendant::td/attribute::align 
+; Location path, abbreviated form: //td/@align
+; Selects 'align' attributes of all 'td' elements in tree1
+(let ((tree tree1)
+      (expected
+       '((align "right") (align "center") (align "center") (align "center"))
+      ))
+  (run-test
+   (node-join 
+    (node-closure (node-typeof? 'td))
+    (select-kids (node-typeof? '@))
+    (select-kids (node-typeof? 'align)))
+   tree expected)
+  (run-test (sxpath '(// td @ align)) tree expected)
+)
+
+
+; Location path, full form: /descendant::td[attribute::align] 
+; Location path, abbreviated form: //td[@align]
+; Selects all td elements that have an attribute 'align' in tree1
+(let ((tree tree1)
+      (expected
+       '((td (@ (align "right")) "Talks ") (td (@ (align "center")) " = ")
+	 (td (@ (align "center")) " = ") (td (@ (align "center")) " = "))
+       ))
+  (run-test
+   (node-reduce 
+    (node-closure (node-typeof? 'td))
+    (filter
+     (node-join
+      (select-kids (node-typeof? '@))
+      (select-kids (node-typeof? 'align)))))
+   tree expected)
+  (run-test (sxpath `(// td ,(node-self (sxpath '(@ align)))))  tree expected)
+  (run-test (sxpath '(// (td (@ align)))) tree expected)
+  (run-test (sxpath '(// ((td) (@ align)))) tree expected)
+  ; note! (sxpath ...) is a converter. Therefore, it can be used
+  ; as any other converter, for example, in the full-form SXPath.
+  ; Thus we can mix the full and abbreviated form SXPath's freely.
+  (run-test
+   (node-reduce 
+    (node-closure (node-typeof? 'td))
+    (filter
+     (sxpath '(@ align))))
+   tree expected)
+)
+
+
+; Location path, full form: /descendant::td[attribute::align = "right"] 
+; Location path, abbreviated form: //td[@align = "right"]
+; Selects all td elements that have an attribute align = "right" in tree1
+(let ((tree tree1)
+      (expected
+       '((td (@ (align "right")) "Talks "))
+       ))
+  (run-test
+   (node-reduce 
+    (node-closure (node-typeof? 'td))
+    (filter
+     (node-join
+      (select-kids (node-typeof? '@))
+      (select-kids (node-equal? '(align "right"))))))
+   tree expected)
+  (run-test (sxpath '(// (td (@ (equal? (align "right")))))) tree expected)
+)
+
+; Location path, full form: child::para[position()=1] 
+; Location path, abbreviated form: para[1]
+; selects the first para child of the context node
+(let ((tree
+       '(elem (@ (name "elem") (id "idz")) 
+	(para (@) "para") (br (@)) "cdata" (para "second par")
+	(div (@ (name "aa")) (para (@) "third para")))
+       )
+      (expected
+       '((para (@) "para"))
+      ))
+  (run-test
+   (node-reduce
+    (select-kids (node-typeof? 'para))
+    (node-pos 1))
+   tree expected)
+  (run-test (sxpath '((para 1))) tree expected)
+)
+
+; Location path, full form: child::para[position()=last()] 
+; Location path, abbreviated form: para[last()]
+; selects the last para child of the context node
+(let ((tree
+       '(elem (@ (name "elem") (id "idz")) 
+	(para (@) "para") (br (@)) "cdata" (para "second par")
+	(div (@ (name "aa")) (para (@) "third para")))
+       )
+      (expected
+       '((para "second par"))
+      ))
+  (run-test
+   (node-reduce
+    (select-kids (node-typeof? 'para))
+    (node-pos -1))
+   tree expected)
+  (run-test (sxpath '((para -1))) tree expected)
+)
+
+; Illustrating the following Note of Sec 2.5 of XPath:
+; "NOTE: The location path //para[1] does not mean the same as the
+; location path /descendant::para[1]. The latter selects the first
+; descendant para element; the former selects all descendant para
+; elements that are the first para children of their parents."
+
+(let ((tree
+       '(elem (@ (name "elem") (id "idz")) 
+	(para (@) "para") (br (@)) "cdata" (para "second par")
+	(div (@ (name "aa")) (para (@) "third para")))
+       )
+      )
+  (run-test
+   (node-reduce	; /descendant::para[1] in SXPath
+    (node-closure (node-typeof? 'para))
+    (node-pos 1))
+   tree '((para (@) "para")))
+  (run-test (sxpath '(// (para 1))) tree
+	    '((para (@) "para") (para (@) "third para")))
+)
+
+; Location path, full form: parent::node()
+; Location path, abbreviated form: ..
+; selects the parent of the context node. The context node may be
+; an attribute node!
+; For the last test:
+; Location path, full form: parent::*/attribute::name
+; Location path, abbreviated form: ../@name
+; Selects the name attribute of the parent of the context node
+
+(let* ((tree
+	'(elem (@ (name "elem") (id "idz")) 
+	       (para (@) "para") (br (@)) "cdata" (para "second par")
+	       (div (@ (name "aa")) (para (@) "third para")))
+	)
+       (para1		; the first para node
+	(car ((sxpath '(para)) tree)))
+       (para3		; the third para node
+	(car ((sxpath '(div para)) tree)))
+       (div		; div node
+	(car ((sxpath '(// div)) tree)))
+       )
+  (run-test
+   (node-parent tree)
+   para1 (list tree))
+  (run-test
+   (node-parent tree)
+   para3 (list div))
+  (run-test		; checking the parent of an attribute node
+   (node-parent tree)
+   ((sxpath '(@ name)) div) (list div))
+  (run-test
+   (node-join
+    (node-parent tree)
+    (select-kids (node-typeof? '@))
+    (select-kids (node-typeof? 'name)))
+   para3 '((name "aa")))
+  (run-test
+   (sxpath `(,(node-parent tree) @ name))
+   para3 '((name "aa")))
+)
+
+; Location path, full form: following-sibling::chapter[position()=1]
+; Location path, abbreviated form: none
+; selects the next chapter sibling of the context node
+; The path is equivalent to
+;  let cnode = context-node
+;    in
+;	parent::* / child::chapter [take-after node_eq(self::*,cnode)] 
+;		[position()=1]
+(let* ((tree
+       '(document
+	 (preface "preface")
+	 (chapter (@ (id "one")) "Chap 1 text")
+	 (chapter (@ (id "two")) "Chap 2 text")
+	 (chapter (@ (id "three")) "Chap 3 text")
+	 (chapter (@ (id "four")) "Chap 4 text")
+	 (epilogue "Epilogue text")
+	 (appendix (@ (id "A")) "App A text")
+	 (References "References"))
+       )
+       (a-node	; to be used as a context node
+	(car ((sxpath '(// (chapter (@ (equal? (id "two")))))) tree)))
+       (expected
+       '((chapter (@ (id "three")) "Chap 3 text")))
+      )
+  (run-test
+   (node-reduce
+    (node-join
+     (node-parent tree)
+     (select-kids (node-typeof? 'chapter)))
+    (take-after (node-eq? a-node))
+    (node-pos 1)
+    )
+   a-node expected)
+)
+
+; preceding-sibling::chapter[position()=1]
+; selects the previous chapter sibling of the context node
+; The path is equivalent to
+;  let cnode = context-node
+;    in
+;	parent::* / child::chapter [take-until node_eq(self::*,cnode)] 
+;		[position()=-1]
+(let* ((tree
+       '(document
+	 (preface "preface")
+	 (chapter (@ (id "one")) "Chap 1 text")
+	 (chapter (@ (id "two")) "Chap 2 text")
+	 (chapter (@ (id "three")) "Chap 3 text")
+	 (chapter (@ (id "four")) "Chap 4 text")
+	 (epilogue "Epilogue text")
+	 (appendix (@ (id "A")) "App A text")
+	 (References "References"))
+       )
+       (a-node	; to be used as a context node
+	(car ((sxpath '(// (chapter (@ (equal? (id "three")))))) tree)))
+       (expected
+       '((chapter (@ (id "two")) "Chap 2 text")))
+      )
+  (run-test
+   (node-reduce
+    (node-join
+     (node-parent tree)
+     (select-kids (node-typeof? 'chapter)))
+    (take-until (node-eq? a-node))
+    (node-pos -1)
+    )
+   a-node expected)
+)
+
+
+; /descendant::figure[position()=42]
+; selects the forty-second figure element in the document
+; See the next example, which is more general.
+
+; Location path, full form:
+;    child::table/child::tr[position()=2]/child::td[position()=3] 
+; Location path, abbreviated form: table/tr[2]/td[3]
+; selects the third td of the second tr of the table
+(let ((tree ((node-closure (node-typeof? 'p)) tree1))
+      (expected
+       '((td " data + control"))
+       ))
+  (run-test
+   (node-join
+    (select-kids (node-typeof? 'table))
+    (node-reduce (select-kids (node-typeof? 'tr))
+		 (node-pos 2))
+    (node-reduce (select-kids (node-typeof? 'td))
+		 (node-pos 3)))
+   tree expected)
+  (run-test (sxpath '(table (tr 2) (td 3))) tree expected)
+)
+
+
+; Location path, full form:
+;		child::para[attribute::type='warning'][position()=5] 
+; Location path, abbreviated form: para[@type='warning'][5]
+; selects the fifth para child of the context node that has a type
+; attribute with value warning
+(let ((tree
+       '(chapter
+	 (para "para1")
+	 (para (@ (type "warning")) "para 2")
+	 (para (@ (type "warning")) "para 3")
+	 (para (@ (type "warning")) "para 4")
+	 (para (@ (type "warning")) "para 5")
+	 (para (@ (type "warning")) "para 6"))
+       )
+      (expected
+       '((para (@ (type "warning")) "para 6"))
+      ))
+  (run-test
+   (node-reduce
+    (select-kids (node-typeof? 'para))
+    (filter
+     (node-join
+      (select-kids (node-typeof? '@))
+      (select-kids (node-equal? '(type "warning")))))
+    (node-pos 5))
+   tree expected)
+  (run-test (sxpath '( (((para (@ (equal? (type "warning"))))) 5 )  ))
+	    tree expected)
+  (run-test (sxpath '( (para (@ (equal? (type "warning"))) 5 )  ))
+	    tree expected)
+)
+
+
+; Location path, full form:
+;		child::para[position()=5][attribute::type='warning'] 
+; Location path, abbreviated form: para[5][@type='warning']
+; selects the fifth para child of the context node if that child has a 'type'
+; attribute with value warning
+(let ((tree
+       '(chapter
+	 (para "para1")
+	 (para (@ (type "warning")) "para 2")
+	 (para (@ (type "warning")) "para 3")
+	 (para (@ (type "warning")) "para 4")
+	 (para (@ (type "warning")) "para 5")
+	 (para (@ (type "warning")) "para 6"))
+       )
+      (expected
+       '((para (@ (type "warning")) "para 5"))
+      ))
+  (run-test
+   (node-reduce
+    (select-kids (node-typeof? 'para))
+    (node-pos 5)
+    (filter
+     (node-join
+      (select-kids (node-typeof? '@))
+      (select-kids (node-equal? '(type "warning"))))))
+   tree expected)
+  (run-test (sxpath '( (( (para 5))  (@ (equal? (type "warning"))))))
+	    tree expected)
+  (run-test (sxpath '( (para 5 (@ (equal? (type "warning")))) ))
+	    tree expected)
+)
+
+; Location path, full form:
+;		child::*[self::chapter or self::appendix]
+; Location path, semi-abbreviated form: *[self::chapter or self::appendix]
+; selects the chapter and appendix children of the context node
+(let ((tree
+       '(document
+	 (preface "preface")
+	 (chapter (@ (id "one")) "Chap 1 text")
+	 (chapter (@ (id "two")) "Chap 2 text")
+	 (chapter (@ (id "three")) "Chap 3 text")
+	 (epilogue "Epilogue text")
+	 (appendix (@ (id "A")) "App A text")
+	 (References "References"))
+       )
+      (expected
+       '((chapter (@ (id "one")) "Chap 1 text")
+	 (chapter (@ (id "two")) "Chap 2 text")
+	 (chapter (@ (id "three")) "Chap 3 text")
+	 (appendix (@ (id "A")) "App A text"))
+      ))
+  (run-test
+   (node-join
+    (select-kids (node-typeof? '*))
+    (filter
+     (node-or
+      (node-self (node-typeof? 'chapter))
+      (node-self (node-typeof? 'appendix)))))
+   tree expected)
+  (run-test (sxpath `(* ,(node-or (node-self (node-typeof? 'chapter))
+				  (node-self (node-typeof? 'appendix)))))
+	    tree expected)
+)
+
+
+; Location path, full form: child::chapter[child::title='Introduction'] 
+; Location path, abbreviated form: chapter[title = 'Introduction']
+; selects the chapter children of the context node that have one or more
+; title children with string-value equal to Introduction
+; See a similar example: //td[@align = "right"] above.
+
+; Location path, full form: child::chapter[child::title] 
+; Location path, abbreviated form: chapter[title]
+; selects the chapter children of the context node that have one or
+; more title children
+; See a similar example //td[@align] above.
+
+(cerr nl "Example with tree3: extracting the first lines of every stanza" nl)
+(let ((tree tree3)
+      (expected
+       '("Let us go then, you and I," "In the room the women come and go")
+      ))
+  (run-test
+   (node-join
+    (node-closure (node-typeof? 'stanza))
+    (node-reduce 
+     (select-kids (node-typeof? 'line)) (node-pos 1))
+    (select-kids (node-typeof? '*text*)))
+   tree expected)
+  (run-test (sxpath '(// stanza (line 1) *text*)) tree expected)
+)
+
diff --git a/collects/ssax/ascii.ss b/collects/ssax/ascii.ss
new file mode 100644
index 0000000000..07ae3449bf
--- /dev/null
+++ b/collects/ssax/ascii.ss
@@ -0,0 +1,13 @@
+(module ascii mzscheme
+
+  (provide ascii->char
+	   char->ascii
+	   ascii-limit
+	   ascii-whitespaces)
+
+  (define ascii->char integer->char)
+  (define char->ascii char->integer)
+  (define ascii-limit 256)
+  (define ascii-whitespaces '(32 9 10 11 12 13)))
+
+
diff --git a/collects/ssax/assertions.ss b/collects/ssax/assertions.ss
new file mode 100644
index 0000000000..466e249c5b
--- /dev/null
+++ b/collects/ssax/assertions.ss
@@ -0,0 +1,38 @@
+(module assertions mzscheme
+
+  (provide assert assure)
+;
+; syntax: assert ?expr ?expr ... [report: ?r-exp ?r-exp ...]
+;
+; If (and ?expr ?expr ...) evaluates to anything but #f, the result
+; is the value of that expression.
+; If (and ?expr ?expr ...) evaluates to #f, an error is reported.
+; The error message will show the failed expressions, as well
+; as the values of selected variables (or expressions, in general).
+; The user may explicitly specify the expressions whose
+; values are to be printed upon assertion failure -- as ?r-exp that
+; follow the identifier 'report:'
+; Typically, ?r-exp is either a variable or a string constant.
+; If the user specified no ?r-exp, the values of variables that are
+; referenced in ?expr will be printed upon the assertion failure.
+
+  (define-syntax assert
+    (syntax-rules (report:)
+      ((assert "doit" (expr ...) (r-exp ...))
+       (cond
+	((and expr ...) => (lambda (x) x))
+	(else
+	 (error 'error "assertion failure: ~a" (list '(and expr ...) r-exp ...)))))
+      ((assert "collect" (expr ...))
+       (assert "doit" (expr ...) ()))
+      ((assert "collect" (expr ...) report: r-exp ...)
+       (assert "doit" (expr ...) (r-exp ...)))
+      ((assert "collect" (expr ...) expr1 stuff ...)
+       (assert "collect" (expr ... expr1) stuff ...))
+      ((assert stuff ...)
+       (assert "collect" () stuff ...))))
+
+  (define-syntax assure
+    (syntax-rules ()
+      ((assure exp error-msg)
+       (assert exp report: error-msg)))))
\ No newline at end of file
diff --git a/collects/ssax/catch-errors.ss b/collects/ssax/catch-errors.ss
new file mode 100644
index 0000000000..2ba7a1a9d1
--- /dev/null
+++ b/collects/ssax/catch-errors.ss
@@ -0,0 +1,15 @@
+(module catch-errors mzscheme
+
+  (provide failed?)
+
+  (define-syntax failed?
+    (syntax-rules ()
+      ((failed? stmts ...)
+       (thunk-failed? (lambda () stmts ...)))))
+  (define (thunk-failed? thunk)
+    (call-with-current-continuation
+     (lambda (return)
+       (with-handlers
+	   (((lambda (x) #t) (lambda (exn) #t)))
+	 (thunk)
+	 #f)))))
diff --git a/collects/ssax/char-encodings.ss b/collects/ssax/char-encodings.ss
new file mode 100644
index 0000000000..a3ac6d03b1
--- /dev/null
+++ b/collects/ssax/char-encodings.ss
@@ -0,0 +1,11 @@
+(module char-encodings mzscheme
+
+  (require "ascii.ss")
+
+  (provide ucscode->char
+	   char-return char-tab char-newline)
+
+  (define ucscode->char ascii->char)
+  (define char-return (ascii->char 13))
+  (define char-tab (ascii->char 9))
+  (define char-newline (ascii->char 10)))
diff --git a/collects/ssax/coutputs.ss b/collects/ssax/coutputs.ss
new file mode 100644
index 0000000000..962c232a5f
--- /dev/null
+++ b/collects/ssax/coutputs.ss
@@ -0,0 +1,5 @@
+(module coutputs mzscheme
+  (provide cout cerr nl)
+  
+  (require (lib "include.ss"))
+  (include "output.scm"))
diff --git a/collects/ssax/crementing.ss b/collects/ssax/crementing.ss
new file mode 100644
index 0000000000..eb83d21f0d
--- /dev/null
+++ b/collects/ssax/crementing.ss
@@ -0,0 +1,6 @@
+(module crementing mzscheme
+
+  (provide dec inc)
+  
+  (define (inc n) (+ n 1))
+  (define (dec n) (- n 1)))
diff --git a/collects/ssax/define-opt.scm b/collects/ssax/define-opt.scm
new file mode 100644
index 0000000000..987c080537
--- /dev/null
+++ b/collects/ssax/define-opt.scm
@@ -0,0 +1,38 @@
+(define-syntax define-opt
+  (syntax-rules (optional)
+    ((define-opt (name . bindings) . bodies)
+      (define-opt "seek-optional" bindings () ((name . bindings) . bodies)))
+
+    ((define-opt "seek-optional" ((optional . _opt-bindings))
+       (reqd ...) ((name . _bindings) . _bodies))
+      (define (name reqd ... . _rest)
+	(letrec-syntax
+	  ((handle-opts
+	     (syntax-rules ()
+	       ((_ rest bodies (var init))
+		 (let ((var (if (null? rest) init
+			      (if (null? (cdr rest)) (car rest)
+				(error "extra rest" rest)))))
+		   . bodies))
+	       ((_ rest bodies var) (handle-opts rest bodies (var #f)))
+	       ((_ rest bodies (var init) . other-vars)
+		 (let ((var (if (null? rest) init (car rest)))
+		       (new-rest (if (null? rest) '() (cdr rest))))
+		   (handle-opts new-rest bodies . other-vars)))
+	       ((_ rest bodies var . other-vars)
+		 (handle-opts rest bodies (var #f) . other-vars))
+	       ((_ rest bodies)		; no optional args, unlikely
+		 (let ((_ (or (null? rest) (error "extra rest" rest))))
+		   . bodies)))))
+	  (handle-opts _rest _bodies . _opt-bindings))))
+
+    ((define-opt "seek-optional" (x . rest) (reqd ...) form)
+      (define-opt "seek-optional" rest (reqd ... x) form))
+
+    ((define-opt "seek-optional" not-a-pair reqd form)
+      (define . form))			; No optional found, regular define
+
+    ((define-opt name body)		; Just the definition for 'name',
+      (define name body))		; for compatibilibility with define
+))
+
diff --git a/collects/ssax/define-opt.ss b/collects/ssax/define-opt.ss
new file mode 100644
index 0000000000..78552839e8
--- /dev/null
+++ b/collects/ssax/define-opt.ss
@@ -0,0 +1,5 @@
+(module define-opt mzscheme
+  (provide define-opt)
+
+  (require (lib "include.ss"))
+  (include "define-opt.scm"))
diff --git a/collects/ssax/doc.txt b/collects/ssax/doc.txt
new file mode 100644
index 0000000000..2b88505b21
--- /dev/null
+++ b/collects/ssax/doc.txt
@@ -0,0 +1,696 @@
+_SSAX_/_SXML_ Library
+=====================
+
+These is Oleg Kiselyov's SSAX/SXML library.  For more documentation
+and papers, refer to
+
+http://ssax.sourceforge.net/
+
+SSAX
+
+================================================================
+_ssax.ss_
+================================================================
+
+To load the module, do
+(require (lib "ssax.ss" "ssax"))
+
+Besides the standard SSAX procedures described below, this defines:
+
+> ssax:warn-parameter - Parameter for the procedure to display
+  warnings.  It must accept a port, a warning message, and any number
+  of additional arguments.
+
+> make-xml-token KIND HEAD
+This creates an XML token.
+
+> xml-token? THING
+
+> xml-token-kind XML-TOKEN
+
+> xml-token-head XML-TOKEN
+
+> ssax:read-markup-token PORT
+This procedure starts parsing of a markup token. The current position
+in the stream must be #\<. This procedure scans enough of the input stream
+to figure out what kind of a markup token it is seeing. The procedure returns
+an xml-token structure describing the token. Note, generally reading
+of the current markup is not finished! In particular, no attributes of
+the start-tag token are scanned.
+
+Here's a detailed break out of the return values and the position in the PORT
+when that particular value is returned:
+PI-token:	only PI-target is read.
+		To finish the Processing Instruction and disregard it,
+		call ssax:skip-pi. ssax:read-attributes may be useful
+		as well (for PIs whose content is attribute-value
+		pairs)
+END-token:	The end tag is read completely; the current position
+		is right after the terminating #\> character.	
+COMMENT		is read and skipped completely. The current position
+		is right after "-->" that terminates the comment.
+CDSECT		The current position is right after "<!CDATA["
+		Use ssax:read-cdata-body to read the rest.
+DECL		We have read the keyword (the one that follows "<!")
+		identifying this declaration markup. The current
+		position is after the keyword (usually a
+		whitespace character)
+
+START-token	We have read the keyword (GI) of this start tag.
+		No attributes are scanned yet. We don't know if this
+		tag has an empty content either.
+		Use ssax:complete-start-tag to finish parsing of
+		the token.
+
+
+> ssax:read-pi-body-as-string PORT
+The current position is right after reading the PITarget. We read the
+body of PI and return is as a string. The port will point to the
+character right after '?>' combination that terminates PI.
+[16] PI ::= '<?' PITarget (S (Char* - (Char* '?>' Char*)))? '?>'
+
+
+> ssax:skip-internal-dtd PORT
+The current pos in the port is inside an internal DTD subset
+(e.g., after reading #\[ that begins an internal DTD subset)
+Skip until the "]>" combination that terminates this DTD
+
+> ssax:read-cdata-body PORT STR-HANDLER SEED
+
+This procedure must be called after we have read a string "<![CDATA["
+that begins a CDATA section. The current position must be the first
+position of the CDATA body. This function reads _lines_ of the CDATA
+body and passes them to a STR-HANDLER, a character data consumer.
+
+The str-handler is a STR-HANDLER, a procedure STRING1 STRING2 SEED.
+The first STRING1 argument to STR-HANDLER never contains a newline.
+The second STRING2 argument often will. On the first invocation of
+the STR-HANDLER, the seed is the one passed to ssax:read-cdata-body
+as the third argument. The result of this first invocation will be
+passed as the seed argument to the second invocation of the line
+consumer, and so on. The result of the last invocation of the
+STR-HANDLER is returned by the ssax:read-cdata-body.  Note a
+similarity to the fundamental 'fold' iterator.
+
+Within a CDATA section all characters are taken at their face value,
+with only three exceptions:
+CR, LF, and CRLF are treated as line delimiters, and passed
+as a single #\newline to the STR-HANDLER
+"]]>" combination is the end of the CDATA section.
+&gt; is treated as an embedded #\> character
+Note, &lt; and &amp; are not specially recognized (and are not expanded)!
+
+
+> ssax:read-char-ref PORT
+
+[66]  CharRef ::=  '&#' [0-9]+ ';' 
+                 | '&#x' [0-9a-fA-F]+ ';'
+
+This procedure must be called after we we have read "&#" 
+that introduces a char reference.
+The procedure reads this reference and returns the corresponding char
+The current position in PORT will be after ";" that terminates
+the char reference
+Faults detected:
+WFC: XML-Spec.html#wf-Legalchar
+
+According to Section "4.1 Character and Entity References"
+of the XML Recommendation:
+ "[Definition: A character reference refers to a specific character
+  in the ISO/IEC 10646 character set, for example one not directly
+  accessible from available input devices.]"
+Therefore, we use a ucscode->char function to convert a character
+code into the character -- *regardless* of the current character
+encoding of the input stream.
+
+
+> ssax:handle-parsed-entity PORT NAME ENTITIES 
+	CONTENT-HANDLER STR-HANDLER SEED
+
+Expand and handle a parsed-entity reference
+port - a PORT
+name - the name of the parsed entity to expand, a symbol
+entities - see ENTITIES
+content-handler -- procedure PORT ENTITIES SEED
+that is supposed to return a SEED
+str-handler - a STR-HANDLER. It is called if the entity in question
+turns out to be a pre-declared entity
+
+The result is the one returned by CONTENT-HANDLER or STR-HANDLER
+Faults detected:
+WFC: XML-Spec.html#wf-entdeclared
+WFC: XML-Spec.html#norecursion
+
+
+> make-empty-attlist
+The ATTLIST Abstract Data Type
+Currently is implemented as an assoc list sorted in the ascending
+order of NAMES.
+
+
+> attlist-add ATTLIST NAME-VALUE-PAIR
+Add a name-value pair to the existing attlist preserving the order
+Return the new list, in the sorted ascending order.
+Return #f if a pair with the same name already exists in the attlist
+
+
+> attlist-null? ATTLIST
+
+> attlist-remove-top ATTLIST
+Given an non-null attlist, return a pair of values: the top and the rest
+
+> attliast->alist
+
+> attlist-fold
+
+> ssax:read-attributes PORT ENTITIES
+
+This procedure reads and parses a production Attribute*
+[41] Attribute ::= Name Eq AttValue
+[10] AttValue ::=  '"' ([^<&"] | Reference)* '"' 
+                | "'" ([^<&'] | Reference)* "'"
+[25] Eq ::= S? '=' S?
+
+
+The procedure returns an ATTLIST, of Name (as UNRES-NAME), Value (as string)
+pairs. The current character on the PORT is a non-whitespace character
+that is not an ncname-starting character.
+
+Note the following rules to keep in mind when reading an 'AttValue'
+"Before the value of an attribute is passed to the application
+or checked for validity, the XML processor must normalize it as follows: 
+- a character reference is processed by appending the referenced
+  character to the attribute value 
+- an entity reference is processed by recursively processing the
+  replacement text of the entity [see ENTITIES]
+  [named entities amp lt gt quot apos are assumed pre-declared]
+- a whitespace character (#x20, #xD, #xA, #x9) is processed by appending #x20
+  to the normalized value, except that only a single #x20 is appended for a
+  "#xD#xA" sequence that is part of an external parsed entity or the
+  literal entity value of an internal parsed entity 
+- other characters are processed by appending them to the normalized value "
+
+
+Faults detected:
+WFC: XML-Spec.html#CleanAttrVals
+WFC: XML-Spec.html#uniqattspec
+
+
+> ssax:uri-string->symbol URI-STR
+Convert a URI-STR to an appropriate symbol
+
+> ssax:complete-start-tag TAG PORT ELEMS ENTITIES NAMESPACES
+
+This procedure is to complete parsing of a start-tag markup. The
+procedure must be called after the start tag token has been
+read. TAG is an UNRES-NAME. ELEMS is an instance of xml-decl::elems;
+it can be #f to tell the function to do _no_ validation of elements
+and their attributes.
+
+This procedure returns several values:
+ ELEM-GI: a RES-NAME.
+ ATTRIBUTES: element's attributes, an ATTLIST of (RES-NAME . STRING)
+pairs. The list does NOT include xmlns attributes.
+ NAMESPACES: the input list of namespaces amended with namespace
+(re-)declarations contained within the start-tag under parsing
+ ELEM-CONTENT-MODEL
+
+On exit, the current position in PORT will be the first character after
+#\> that terminates the start-tag markup.
+
+Faults detected:
+VC: XML-Spec.html#enum 
+VC: XML-Spec.html#RequiredAttr
+VC: XML-Spec.html#FixedAttr
+VC: XML-Spec.html#ValueType
+WFC: XML-Spec.html#uniqattspec (after namespaces prefixes are resolved)
+VC: XML-Spec.html#elementvalid 
+WFC: REC-xml-names/#dt-NSName
+
+Note, although XML Recommendation does not explicitly say it,
+xmlns and xmlns: attributes don't have to be declared (although they
+can be declared, to specify their default value)
+
+Procedure:  ssax:complete-start-tag tag-head port elems entities namespaces
+
+> ssax:read-external-id PORT
+
+This procedure parses an ExternalID production:
+[75] ExternalID ::= 'SYSTEM' S SystemLiteral
+	| 'PUBLIC' S PubidLiteral S SystemLiteral
+[11] SystemLiteral ::= ('"' [^"]* '"') | ("'" [^']* "'") 
+[12] PubidLiteral ::=  '"' PubidChar* '"' | "'" (PubidChar - "'")* "'"
+[13] PubidChar ::=  #x20 | #xD | #xA | [a-zA-Z0-9]
+                        | [-'()+,./:=?;!*#@$_%]
+
+This procedure is supposed to be called when an ExternalID is expected;
+that is, the current character must be either #\S or #\P that start
+correspondingly a SYSTEM or PUBLIC token. This procedure returns the
+SystemLiteral as a string. A PubidLiteral is disregarded if present.
+
+> ssax:read-char-data PORT EXPECT-EOF? STR-HANDLER SEED
+
+This procedure is to read the character content of an XML document
+or an XML element.
+[43] content ::= 
+(element | CharData | Reference | CDSect | PI
+	| Comment)*
+To be more precise, the procedure reads CharData, expands CDSect
+and character entities, and skips comments. The procedure stops
+at a named reference, EOF, at the beginning of a PI or a start/end tag.
+
+port
+a PORT to read
+expect-eof?
+a boolean indicating if EOF is normal, i.e., the character
+data may be terminated by the EOF. EOF is normal
+while processing a parsed entity.
+str-handler
+a STR-HANDLER
+seed
+an argument passed to the first invocation of STR-HANDLER.
+
+The procedure returns two results: SEED and TOKEN.
+The SEED is the result of the last invocation of STR-HANDLER, or the
+original seed if STR-HANDLER was never called.
+
+TOKEN can be either an eof-object (this can happen only if
+expect-eof? was #t), or:
+    - an xml-token describing a START tag or an END-tag;
+For a start token, the caller has to finish reading it.
+    - an xml-token describing the beginning of a PI. It's up to an
+application to read or skip through the rest of this PI;
+    - an xml-token describing a named entity reference.
+
+CDATA sections and character references are expanded inline and
+never returned. Comments are silently disregarded.
+
+As the XML Recommendation requires, all whitespace in character data
+must be preserved. However, a CR character (#xD) must be disregarded
+if it appears before a LF character (#xA), or replaced by a #xA character
+otherwise. See Secs. 2.10 and 2.11 of the XML Recommendation. See also
+the canonical XML Recommendation.
+
+
+> ssax:assert-token TOKEN KIND GI
+Make sure that TOKEN is of anticipated KIND and has anticipated GI
+Note GI argument may actually be a pair of two symbols, Namespace
+URI or the prefix, and of the localname.
+If the assertion fails, error-cont is evaluated by passing it
+three arguments: token kind gi. The result of error-cont is returned.
+
+> ssax:make-pi-parser my-pi-handlers
+Create a parser to parse and process one Processing Element (PI).
+
+my-pi-handlers
+An assoc list of pairs (PI-TAG . PI-HANDLER)
+where PI-TAG is an NCName symbol, the PI target, and
+PI-HANDLER is a procedure PORT PI-TAG SEED
+where PORT points to the first symbol after the PI target.
+The handler should read the rest of the PI up to and including
+the combination '?>' that terminates the PI. The handler should
+return a new seed.
+One of the PI-TAGs may be the symbol *DEFAULT*. The corresponding
+handler will handle PIs that no other handler will. If the
+*DEFAULT* PI-TAG is not specified, ssax:make-pi-parser will assume
+the default handler that skips the body of the PI
+
+The output of the ssax:make-pi-parser is a procedure
+PORT PI-TAG SEED
+that will parse the current PI according to the user-specified handlers.
+
+The previous version of ssax:make-pi-parser was a low-level macro:
+(define-macro ssax:make-pi-parser
+  (lambda (my-pi-handlers)
+  `(lambda (port target seed)
+    (case target
+	; Generate the body of the case statement
+      ,@(let loop ((pi-handlers my-pi-handlers) (default #f))
+	 (cond
+	  ((null? pi-handlers)
+	   (if default `((else (,default port target seed)))
+	       '((else
+		  (ssax:warn port "Skipping PI: " target nl)
+		  (ssax:skip-pi port)
+		  seed))))
+	  ((eq? '*DEFAULT* (caar pi-handlers))
+	   (loop (cdr pi-handlers) (cdar pi-handlers)))
+	  (else
+	   (cons
+	    `((,(caar pi-handlers)) (,(cdar pi-handlers) port target seed))
+	    (loop (cdr pi-handlers) default)))))))))
+
+
+> ssax:make-elem-parser my-new-level-seed my-finish-element
+			my-char-data-handler my-pi-handlers
+
+Create a parser to parse and process one element, including its
+character content or children elements. The parser is typically
+applied to the root element of a document.
+
+my-new-level-seed
+procedure ELEM-GI ATTRIBUTES NAMESPACES EXPECTED-CONTENT SEED
+	where ELEM-GI is a RES-NAME of the element
+	about to be processed.
+This procedure is to generate the seed to be passed
+to handlers that process the content of the element.
+This is the function identified as 'fdown' in the denotational
+semantics of the XML parser given in the title comments to this
+file.
+
+my-finish-element
+procedure ELEM-GI ATTRIBUTES NAMESPACES PARENT-SEED SEED
+This procedure is called when parsing of ELEM-GI is finished.
+The SEED is the result from the last content parser (or
+from my-new-level-seed if the element has the empty content).
+PARENT-SEED is the same seed as was passed to my-new-level-seed.
+The procedure is to generate a seed that will be the result
+of the element parser.
+This is the function identified as 'fup' in the denotational
+semantics of the XML parser given in the title comments to this
+file.
+
+my-char-data-handler
+A STR-HANDLER
+
+my-pi-handlers
+See ssax:make-pi-handler above
+
+
+The generated parser is a
+procedure START-TAG-HEAD PORT ELEMS ENTITIES
+NAMESPACES PRESERVE-WS? SEED
+The procedure must be called after the start tag token has been
+read. START-TAG-HEAD is an UNRES-NAME from the start-element tag.
+ELEMS is an instance of xml-decl::elems.
+See ssax:complete-start-tag::preserve-ws?
+
+Faults detected:
+VC: XML-Spec.html#elementvalid 
+WFC: XML-Spec.html#GIMatch
+
+
+
+> ssax:make-parser user-handler-tag user-handler-proc ...
+
+Create an XML parser, an instance of the XML parsing framework.
+This will be a SAX, a DOM, or a specialized parser depending
+on the supplied user-handlers.
+
+user-handler-tag is a symbol that identifies a procedural expression
+that follows the tag. Given below are tags and signatures of the
+corresponding procedures. Not all tags have to be specified. If some
+are omitted, reasonable defaults will apply.
+
+
+tag: DOCTYPE
+handler-procedure: PORT DOCNAME SYSTEMID INTERNAL-SUBSET? SEED
+If internal-subset? is #t, the current position in the port
+is right after we have read #\[ that begins the internal DTD subset.
+We must finish reading of this subset before we return
+(or must call skip-internal-subset if we aren't interested in reading it).
+The port at exit must be at the first symbol after the whole
+DOCTYPE declaration.
+The handler-procedure must generate four values:
+ELEMS ENTITIES NAMESPACES SEED
+See xml-decl::elems for ELEMS. It may be #f to switch off the validation.
+NAMESPACES will typically contain USER-PREFIXes for selected URI-SYMBs.
+The default handler-procedure skips the internal subset,
+if any, and returns (values #f '() '() seed)
+
+tag: UNDECL-ROOT
+handler-procedure: ELEM-GI SEED
+where ELEM-GI is an UNRES-NAME of the root element. This procedure
+is called when an XML document under parsing contains _no_ DOCTYPE
+declaration.
+The handler-procedure, as a DOCTYPE handler procedure above,
+must generate four values:
+ELEMS ENTITIES NAMESPACES SEED
+The default handler-procedure returns (values #f '() '() seed)
+
+tag: DECL-ROOT
+handler-procedure: ELEM-GI SEED
+where ELEM-GI is an UNRES-NAME of the root element. This procedure
+is called when an XML document under parsing does contains the DOCTYPE
+declaration.
+The handler-procedure must generate a new SEED (and verify
+that the name of the root element matches the doctype, if the handler
+so wishes). 
+The default handler-procedure is the identity function.
+
+tag: NEW-LEVEL-SEED
+handler-procedure: see ssax:make-elem-parser, my-new-level-seed
+
+tag: FINISH-ELEMENT
+handler-procedure: see ssax:make-elem-parser, my-finish-element
+
+tag: CHAR-DATA-HANDLER
+handler-procedure: see ssax:make-elem-parser, my-char-data-handler
+
+tag: PI
+handler-procedure: see ssax:make-pi-parser
+The default value is '()
+
+> ssax:reverse-collect-str LIST-OF-FRAGS -> LIST-OF-FRAGS
+given the list of fragments (some of which are text strings)
+reverse the list and concatenate adjacent text strings.
+We can prove from the general case below that if LIST-OF-FRAGS
+has zero or one element, the result of the procedure is equal?
+to its argument. This fact justifies the shortcut evaluation below.
+
+> ssax:xml->sxml PORT NAMESPACE-PREFIX-ASSIG
+
+This is an instance of a SSAX parser above that returns an SXML
+representation of the XML document to be read from PORT.
+NAMESPACE-PREFIX-ASSIG is a list of (USER-PREFIX . URI-STRING)
+that assigns USER-PREFIXes to certain namespaces identified by
+particular URI-STRINGs. It may be an empty list.
+The procedure returns an SXML tree. The port points out to the
+first character after the root element.
+
+
+
+
+================================================================
+_input-parse.ss_
+================================================================
+
+To load the module, do
+(require (lib "input-parse.ss" "ssax"))
+
+This defines
+
+> (define-struct (exn:ssax exn) (port stuff))
+
+for parser errors raised by SSAX via RAISE.  PORT contains the port on
+which the error happens, STUFF is a list of additional, but random
+information.
+
+Note that this also exports a procedure called read-string, which
+conflicts with the procedure of the same name in the mzscheme
+language.  The ssax collection comes with a module called
+restricted-mzscheme that is identical to mzscheme, except that it
+omits read-string.
+
+> parser-error PORT MESSAGE SPECIALISING-MSG*
+Many procedures of this package call parser-error to report a parsing
+error.  The first argument is a port, which typically points to the
+offending character or its neighborhood. Most of the Scheme systems
+let the user query a PORT for the current position. MESSAGE is the
+description of the error. Other arguments supply more details about
+the problem.
+
+================================================================
+_sxml-tree-trans.ss_
+================================================================
+
+To load the module, do
+(require (lib "sxml-tree-trans.ss" "ssax"))
+
+> SRV:send-reply FRAGMENT ...
+
+Output the 'fragments'
+The fragments are a list of strings, characters,
+numbers, thunks, #f, #t -- and other fragments.
+The function traverses the tree depth-first, writes out
+strings and characters, executes thunks, and ignores
+#f and '().
+The function returns #t if anything was written at all;
+otherwise the result is #f
+If #t occurs among the fragments, it is not written out
+but causes the result of SRV:send-reply to be #t
+
+
+> pre-post-order TREE BINDINGS
+
+          Traversal of an SXML tree or a grove:
+		a <Node> or a <Nodelist>
+
+A <Node> and a <Nodelist> are mutually-recursive datatypes that
+underlie the SXML tree:
+<Node> ::= (name . <Nodelist>) | "text string"
+An (ordered) set of nodes is just a list of the constituent nodes:
+	<Nodelist> ::= (<Node> ...)
+Nodelists, and Nodes other than text strings are both lists. A
+<Nodelist> however is either an empty list, or a list whose head is
+not a symbol (an atom in general). A symbol at the head of a node is
+either an XML name (in which case it's a tag of an XML element), or
+an administrative name such as '@'.
+See SXPath.scm and SSAX.scm for more information on SXML.
+
+
+Pre-Post-order traversal of a tree and creation of a new tree:
+pre-post-order:: <tree> x <bindings> -> <new-tree>
+where
+<bindings> ::= (<binding> ...)
+<binding> ::= (<trigger-symbol> *preorder* . <handler>) |
+              (<trigger-symbol> *macro* . <handler>) |
+	(<trigger-symbol> <new-bindings> . <handler>) |
+	(<trigger-symbol> . <handler>)
+<trigger-symbol> ::= XMLname | *text* | *default*
+<handler> :: <trigger-symbol> x [<tree>] -> <new-tree>
+
+The pre-post-order function visits the nodes and nodelists
+pre-post-order (depth-first).  For each <Node> of the form (name
+<Node> ...) it looks up an association with the given 'name' among
+its <bindings>. If failed, pre-post-order tries to locate a
+*default* binding. It's an error if the latter attempt fails as
+well.  Having found a binding, the pre-post-order function first
+checks to see if the binding is of the form
+(<trigger-symbol> *preorder* . <handler>)
+If it is, the handler is 'applied' to the current node. Otherwise,
+the pre-post-order function first calls itself recursively for each
+child of the current node, with <new-bindings> prepended to the
+<bindings> in effect. The result of these calls is passed to the
+<handler> (along with the head of the current <Node>). To be more
+precise, the handler is _applied_ to the head of the current node
+and its processed children. The result of the handler, which should
+also be a <tree>, replaces the current <Node>. If the current <Node>
+is a text string or other atom, a special binding with a symbol
+*text* is looked up.
+
+A binding can also be of a form
+(<trigger-symbol> *macro* . <handler>)
+This is equivalent to *preorder* described above. However, the result
+is re-processed again, with the current stylesheet.
+
+
+> post-order TREE BINDINGS
+post-order is a strict subset of pre-post-order without *preorder*
+(let alone *macro*) traversals. 
+Now pre-post-order is actually faster than the old post-order.
+The function post-order is deprecated and is aliased below for
+backward compatibility.
+
+> replace-range:: BEG-PRED x END-PRED x FOREST -> FOREST
+Traverse a forest depth-first and cut/replace ranges of nodes.
+
+The nodes that define a range don't have to have the same immediate
+parent, don't have to be on the same level, and the end node of a
+range doesn't even have to exist. A replace-range procedure removes
+nodes from the beginning node of the range up to (but not including)
+the end node of the range.  In addition, the beginning node of the
+range can be replaced by a node or a list of nodes. The range of
+nodes is cut while depth-first traversing the forest. If all
+branches of the node are cut a node is cut as well.  The procedure
+can cut several non-overlapping ranges from a forest.
+
+replace-range:: BEG-PRED x END-PRED x FOREST -> FOREST
+where
+type FOREST = (NODE ...)
+type NODE = Atom | (Name . FOREST) | FOREST
+
+The range of nodes is specified by two predicates, beg-pred and end-pred.
+beg-pred:: NODE -> #f | FOREST
+end-pred:: NODE -> #f | FOREST
+The beg-pred predicate decides on the beginning of the range. The node
+for which the predicate yields non-#f marks the beginning of the range
+The non-#f value of the predicate replaces the node. The value can be a
+list of nodes. The replace-range procedure then traverses the tree and skips
+all the nodes, until the end-pred yields non-#f. The value of the end-pred
+replaces the end-range node. The new end node and its brothers will be
+re-scanned.
+The predicates are evaluated pre-order. We do not descend into a node that
+is marked as the beginning of the range.
+
+
+
+
+================================================================
+_sxml-to-html.ss_
+================================================================
+
+To load the module, do
+(require (lib "sxml-to-html.ss" "ssax"))
+
+> SXML->HTML TREE
+
+The following procedure is the most generic transformation of SXML
+into the corresponding HTML document. The SXML tree is traversed
+post-oder (depth-first) and transformed into another tree, which,
+written in a depth-first fashion, results in an HTML document.
+
+> entag TAG ELEMS
+Create the HTML markup for tags.
+This is used in the node handlers for the post-order function, see
+above.
+
+
+> enattr ATTR-KEY VALUE
+Create the HTML markup for attributes.
+This and entag are being used in the node handlers for the post-order function, see
+above.
+
+> string->goodHTML STRING
+Given a string, check to make sure it does not contain characters
+such as '<' or '&' that require encoding. Return either the original
+string, or a list of string fragments with special characters
+replaced by appropriate character entities.
+
+
+
+
+================================================================
+_sxml-to-html-ext.ss_
+================================================================
+
+To load the module, do
+(require (lib "sxml-to-html-ext.ss" "ssax"))
+
+> make-header HEAD-PARMS
+Create the 'head' SXML/HTML tag. HEAD-PARMS is an assoc list of
+(h-key h-value), where h-value is a typically string;
+h-key is a symbol:
+title, description, AuthorAddress, keywords,
+Date-Revision-yyyymmdd, Date-Creation-yyyymmdd,
+long-title
+One of the h-key can be Links.
+In that case, h-value is a list of
+(l-key l-href (attr value) ...)
+where l-key is one of the following:
+start, contents, prev, next, top, home
+
+
+> make-navbar: HEAD-PARMS
+Create a navigational bar. The argument head-parms is the same
+as the one passed to make-header. We're only concerned with the
+h-value Links
+
+> make-footer HEAD-PARMS
+Create a footer. The argument head-parms is the same
+as passed to make-header.
+
+> universal-conversion-rules
+Bindings for the post-order function, which traverses the SXML tree
+and converts it to a tree of fragments
+
+The universal transformation from SXML to HTML. The following rules
+work for every HTML, present and future
+
+> universal-protected-rules
+A variation of universal-conversion-rules which keeps '<', '>', '&'
+and similar characters intact. The universal-protected-rules are
+useful when the tree of fragments has to be traversed one more time.
+
+> alist-conv-rules
+The following rules define the identity transformation
diff --git a/collects/ssax/find-strings.ss b/collects/ssax/find-strings.ss
new file mode 100644
index 0000000000..f53001ef21
--- /dev/null
+++ b/collects/ssax/find-strings.ss
@@ -0,0 +1,8 @@
+(module find-strings mzscheme
+
+  (provide find-string-from-port?)
+
+  (require "crementing.ss")
+
+  (require (lib "include.ss"))
+  (include "look-for-str.scm"))
diff --git a/collects/ssax/info.ss b/collects/ssax/info.ss
new file mode 100644
index 0000000000..b2ae3d5427
--- /dev/null
+++ b/collects/ssax/info.ss
@@ -0,0 +1,24 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "SSAX/SXML")
+  (define doc.txt "doc.txt")
+
+  (define help-desk-message "Mz/Mr: (require (lib \"ssax.ss\" \"ssax\"))")
+
+  (define blurb
+    `("The SSAX/SXML collection provides functions for reading, writing, and manipulating XML documents."))
+
+  (define compile-omit-files
+    '("SSAX-code.scm"
+      "SXML-to-HTML-ext.scm"
+      "SXML-to-HTML.scm"
+      "SXML-tree-trans.scm"
+      "SXPath-old.scm"
+      "define-opt.scm"
+      "input-parse.scm"
+      "look-for-str.scm"
+      "output.scm"
+      "ppretty-prints.scm"
+      "util.scm"
+      "lookup-def.scm")))
+
+ 
diff --git a/collects/ssax/input-parse.scm b/collects/ssax/input-parse.scm
new file mode 100644
index 0000000000..ca045f4647
--- /dev/null
+++ b/collects/ssax/input-parse.scm
@@ -0,0 +1,326 @@
+;****************************************************************************
+;			Simple Parsing of input
+;
+; The following simple functions surprisingly often suffice to parse
+; an input stream. They either skip, or build and return tokens,
+; according to inclusion or delimiting semantics. The list of
+; characters to expect, include, or to break at may vary from one
+; invocation of a function to another. This allows the functions to
+; easily parse even context-sensitive languages.
+;
+; EOF is generally frowned on, and thrown up upon if encountered.
+; Exceptions are mentioned specifically. The list of expected characters 
+; (characters to skip until, or break-characters) may include an EOF
+; "character", which is to be coded as symbol *eof*
+;
+; The input stream to parse is specified as a PORT, which is usually
+; the last (and optional) argument. It defaults to the current input
+; port if omitted.
+;
+; IMPORT
+; This package relies on a function parser-error, which must be defined
+; by a user of the package. The function has the following signature:
+;	parser-error PORT MESSAGE SPECIALISING-MSG*
+; Many procedures of this package call parser-error to report a parsing
+; error.  The first argument is a port, which typically points to the
+; offending character or its neighborhood. Most of the Scheme systems
+; let the user query a PORT for the current position. MESSAGE is the
+; description of the error. Other arguments supply more details about
+; the problem.
+; myenv.scm, myenv-bigloo.scm or a similar prelude is assumed.
+; From SRFI-13, string-concatenate-reverse
+; If a particular implementation lacks SRFI-13 support, please
+; include the file srfi-13-local.scm
+;
+; $Id: input-parse.scm,v 1.2 2004/11/09 14:11:40 sperber Exp $
+
+;------------------------------------------------------------------------
+
+; -- procedure+: peek-next-char [PORT]
+; 	advances to the next character in the PORT and peeks at it.
+; 	This function is useful when parsing LR(1)-type languages
+; 	(one-char-read-ahead).
+;	The optional argument PORT defaults to the current input port.
+
+(define-opt (peek-next-char (optional (port (current-input-port))))
+  (read-char port) 
+  (peek-char port)) 
+
+
+;------------------------------------------------------------------------
+
+; -- procedure+: assert-curr-char CHAR-LIST STRING [PORT]
+;	Reads a character from the PORT and looks it up
+;	in the CHAR-LIST of expected characters
+;	If the read character was found among expected, it is returned
+;	Otherwise, the procedure writes a nasty message using STRING
+;	as a comment, and quits.
+;	The optional argument PORT defaults to the current input port.
+;
+(define-opt (assert-curr-char expected-chars comment
+			      (optional (port (current-input-port))))
+  (let ((c (read-char port)))
+    (if (memv c expected-chars) c
+    (parser-error port "Wrong character " c
+    	   " (0x" (if (eof-object? c) "*eof*"
+    	   	    (number->string (char->integer c) 16)) ") "
+    	   comment ". " expected-chars " expected"))))
+    	   
+
+; -- procedure+: skip-until CHAR-LIST [PORT]
+;	Reads and skips characters from the PORT until one of the break
+;	characters is encountered. This break character is returned.
+;	The break characters are specified as the CHAR-LIST. This list
+;	may include EOF, which is to be coded as a symbol *eof*
+;
+; -- procedure+: skip-until NUMBER [PORT]
+;	Skips the specified NUMBER of characters from the PORT and returns #f
+;
+;	The optional argument PORT defaults to the current input port.
+
+
+(define-opt (skip-until arg (optional (port (current-input-port))) )
+  (cond
+   ((number? arg)		; skip 'arg' characters
+      (do ((i arg (dec i)))
+      	  ((not (positive? i)) #f)
+      	  (if (eof-object? (read-char port))
+      	    (parser-error port "Unexpected EOF while skipping "
+			 arg " characters"))))
+   (else			; skip until break-chars (=arg)
+     (let loop ((c (read-char port)))
+       (cond
+         ((memv c arg) c)
+         ((eof-object? c)
+           (if (memq '*eof* arg) c
+             (parser-error port "Unexpected EOF while skipping until " arg)))
+         (else (loop (read-char port))))))))
+
+
+; -- procedure+: skip-while CHAR-LIST [PORT]
+;	Reads characters from the PORT and disregards them,
+;	as long as they are mentioned in the CHAR-LIST.
+;	The first character (which may be EOF) peeked from the stream
+;	that is NOT a member of the CHAR-LIST is returned. This character
+;	is left on the stream.
+;	The optional argument PORT defaults to the current input port.
+
+(define-opt (skip-while skip-chars (optional (port (current-input-port))) )
+  (do ((c (peek-char port) (peek-char port)))
+      ((not (memv c skip-chars)) c)
+      (read-char port)))
+ 
+; whitespace const
+
+;------------------------------------------------------------------------
+;				Stream tokenizers
+
+
+; -- procedure+: 
+;    next-token PREFIX-CHAR-LIST BREAK-CHAR-LIST [COMMENT-STRING] [PORT]
+;	skips any number of the prefix characters (members of the
+;	PREFIX-CHAR-LIST), if any, and reads the sequence of characters
+;	up to (but not including) a break character, one of the
+;	BREAK-CHAR-LIST.
+;	The string of characters thus read is returned.
+;	The break character is left on the input stream
+;	The list of break characters may include EOF, which is to be coded as
+;	a symbol *eof*. Otherwise, EOF is fatal, generating an error message
+;	including a specified COMMENT-STRING (if any)
+;
+;	The optional argument PORT defaults to the current input port.
+;
+; Note: since we can't tell offhand how large the token being read is
+; going to be, we make a guess, pre-allocate a string, and grow it by
+; quanta if necessary. The quantum is always the length of the string
+; before it was extended the last time. Thus the algorithm does
+; a Fibonacci-type extension, which has been proven optimal.
+; Note, explicit port specification in read-char, peek-char helps.
+
+; Procedure: input-parse:init-buffer
+; returns an initial buffer for next-token* procedures.
+; The input-parse:init-buffer may allocate a new buffer per each invocation:
+;	(define (input-parse:init-buffer) (make-string 32))
+; Size 32 turns out to be fairly good, on average.
+; That policy is good only when a Scheme system is multi-threaded with
+; preemptive scheduling, or when a Scheme system supports shared substrings.
+; In all the other cases, it's better for input-parse:init-buffer to
+; return the same static buffer. next-token* functions return a copy
+; (a substring) of accumulated data, so the same buffer can be reused.
+; We shouldn't worry about an incoming token being too large:
+; next-token will use another chunk automatically. Still, 
+; the best size for the static buffer is to allow most of the tokens to fit in.
+; Using a static buffer _dramatically_ reduces the amount of produced garbage
+; (e.g., during XML parsing).
+
+(define input-parse:init-buffer
+  (let ((buffer (make-string 512)))
+    (lambda () buffer)))
+  
+
+		; See a better version below
+(define-opt (next-token-old prefix-skipped-chars break-chars
+			(optional (comment "") (port (current-input-port))) )
+  (let* ((buffer (input-parse:init-buffer))
+	 (curr-buf-len (string-length buffer))
+	 (quantum curr-buf-len))
+    (let loop ((i 0) (c (skip-while prefix-skipped-chars port)))
+      (cond
+        ((memv c break-chars) (substring buffer 0 i))
+    	((eof-object? c)
+    	  (if (memq '*eof* break-chars)
+    	    (substring buffer 0 i)		; was EOF expected?
+    	    (parser-error port "EOF while reading a token " comment)))
+    	(else
+    	  (if (>= i curr-buf-len)	; make space for i-th char in buffer
+    	    (begin			; -> grow the buffer by the quantum
+    	      (set! buffer (string-append buffer (make-string quantum)))
+    	      (set! quantum curr-buf-len)
+    	      (set! curr-buf-len (string-length buffer))))
+    	  (string-set! buffer i c)
+    	  (read-char port)			; move to the next char
+    	  (loop (inc i) (peek-char port))
+    	  )))))
+
+
+; A better version of next-token, which accumulates the characters
+; in chunks, and later on reverse-concatenates them, using
+; SRFI-13 if available.
+; The overhead of copying characters is only 100% (or even smaller: bulk
+; string copying might be well-optimised), compared to the (hypothetical)
+; circumstance if we had known the size of the token beforehand.
+; For small tokens, the code performs just as above. For large
+; tokens, we expect an improvement. Note, the code also has no
+; assignments. 
+; See next-token-comp.scm
+
+(define-opt (next-token prefix-skipped-chars break-chars
+		  (optional (comment "") (port (current-input-port))) )
+  (let outer ((buffer (input-parse:init-buffer)) (filled-buffer-l '())
+	      (c (skip-while prefix-skipped-chars port)))
+    (let ((curr-buf-len (string-length buffer)))
+      (let loop ((i 0) (c c))
+	(cond
+	  ((memv c break-chars)
+	    (if (null? filled-buffer-l) (substring buffer 0 i)
+	      (string-concatenate-reverse filled-buffer-l buffer i)))
+	  ((eof-object? c)
+	    (if (memq '*eof* break-chars)	; was EOF expected?
+	      (if (null? filled-buffer-l) (substring buffer 0 i)
+		(string-concatenate-reverse filled-buffer-l buffer i))
+	      (parser-error port "EOF while reading a token " comment)))
+	  ((>= i curr-buf-len)
+	    (outer (make-string curr-buf-len)
+	      (cons buffer filled-buffer-l) c))
+	  (else
+	    (string-set! buffer i c)
+	    (read-char port)			; move to the next char
+	    (loop (inc i) (peek-char port))))))))
+
+; -- procedure+: next-token-of INC-CHARSET [PORT]
+;	Reads characters from the PORT that belong to the list of characters
+;	INC-CHARSET. The reading stops at the first character which is not
+;	a member of the set. This character is left on the stream.
+;	All the read characters are returned in a string.
+;
+; -- procedure+: next-token-of PRED [PORT]
+;	Reads characters from the PORT for which PRED (a procedure of one
+;	argument) returns non-#f. The reading stops at the first character
+;	for which PRED returns #f. That character is left on the stream.
+;	All the results of evaluating of PRED up to #f are returned in a
+;	string.
+;
+;	PRED is a procedure that takes one argument (a character
+;	or the EOF object) and returns a character or #f. The returned
+;	character does not have to be the same as the input argument
+;	to the PRED. For example,
+;	(next-token-of (lambda (c)
+;			  (cond ((eof-object? c) #f)
+;				((char-alphabetic? c) (char-downcase c))
+;				(else #f))))
+;	will try to read an alphabetic token from the current
+;	input port, and return it in lower case.
+; 
+;	The optional argument PORT defaults to the current input port.
+;
+; This procedure is similar to next-token but only it implements
+; an inclusion rather than delimiting semantics.
+
+(define-opt (next-token-of incl-list/pred
+			   (optional (port (current-input-port))) )
+  (let* ((buffer (input-parse:init-buffer))
+	 (curr-buf-len (string-length buffer)))
+  (if (procedure? incl-list/pred)
+    (let outer ((buffer buffer) (filled-buffer-l '()))
+      (let loop ((i 0))
+	(if (>= i curr-buf-len)		; make sure we have space
+	  (outer (make-string curr-buf-len) (cons buffer filled-buffer-l))
+	  (let ((c (incl-list/pred (peek-char port))))
+	    (if c
+	      (begin
+		(string-set! buffer i c)
+		(read-char port)			; move to the next char
+		(loop (inc i)))
+	      ; incl-list/pred decided it had had enough
+	      (if (null? filled-buffer-l) (substring buffer 0 i)
+		(string-concatenate-reverse filled-buffer-l buffer i)))))))
+
+    ; incl-list/pred is a list of allowed characters
+    (let outer ((buffer buffer) (filled-buffer-l '()))
+      (let loop ((i 0))
+	(if (>= i curr-buf-len)		; make sure we have space
+	  (outer (make-string curr-buf-len) (cons buffer filled-buffer-l))
+	  (let ((c (peek-char port)))
+	    (cond
+	      ((not (memv c incl-list/pred))
+		(if (null? filled-buffer-l) (substring buffer 0 i)
+		  (string-concatenate-reverse filled-buffer-l buffer i)))
+	      (else
+		(string-set! buffer i c)
+		(read-char port)			; move to the next char
+		(loop (inc i))))))))
+    )))
+
+
+; -- procedure+: read-text-line [PORT]
+;	Reads one line of text from the PORT, and returns it as a string.
+;	A line is a (possibly empty) sequence of characters terminated
+;	by CR, CRLF or LF (or even the end of file).
+;	The terminating character (or CRLF combination) is removed from
+;	the input stream. The terminating character(s) is not a part
+;	of the return string either.
+;	If EOF is encountered before any character is read, the return
+;	value is EOF.
+; 
+;	The optional argument PORT defaults to the current input port.
+
+(define *read-line-breaks* (list char-newline char-return '*eof*))
+
+(define-opt (read-text-line (optional (port (current-input-port))) )
+  (if (eof-object? (peek-char port)) (peek-char port)
+    (let* ((line
+             (next-token '() *read-line-breaks*
+			 "reading a line" port))
+           (c (read-char port)))	; must be either \n or \r or EOF
+       (and (eqv? c char-return) (eqv? (peek-char port) #\newline)
+         (read-char port))			; skip \n that follows \r
+       line)))
+
+
+; -- procedure+: read-string N [PORT]
+;	Reads N characters from the PORT, and  returns them in a string.
+;	If EOF is encountered before N characters are read, a shorter string
+;	will be returned.
+;	If N is not positive, an empty string will be returned.
+;	The optional argument PORT defaults to the current input port.
+
+(define-opt (read-string n (optional (port (current-input-port))) )
+  (if (not (positive? n)) ""
+    (let ((buffer (make-string n)))
+      (let loop ((i 0) (c (read-char port)))
+        (if (eof-object? c) (substring buffer 0 i)
+          (let ((i1 (inc i)))
+            (string-set! buffer i c)
+            (if (= i1 n) buffer
+              (loop i1 (read-char port)))))))))
+
diff --git a/collects/ssax/input-parse.ss b/collects/ssax/input-parse.ss
new file mode 100644
index 0000000000..10354a960f
--- /dev/null
+++ b/collects/ssax/input-parse.ss
@@ -0,0 +1,36 @@
+(module input-parse "restricted-mzscheme.ss"
+
+  (provide peek-next-char
+	   assert-curr-char
+	   skip-until skip-while
+	   next-token next-token-of
+	   read-text-line
+	   read-string
+	   parser-error
+	   exn:ssax?
+	   exn:ssax-port)
+
+  (require (rename (lib "13.ss" "srfi")
+		   string-concatenate-reverse string-concatenate-reverse))
+
+  (require "define-opt.ss")
+  (require "ascii.ss")
+  (require "char-encodings.ss")
+  (require "crementing.ss")
+
+  (define-struct (exn:ssax exn) (port))
+
+  (define (format-list list)
+    (apply string-append (map format-x list)))
+  
+  (define (format-x thing)
+    (format "~a" thing))
+
+  (define (parser-error port message . rest)
+    (raise (make-exn:ssax (string->immutable-string
+			   (format-list (cons message rest)))
+			  (current-continuation-marks)
+			  port)))
+
+  (require (lib "include.ss"))
+  (include "input-parse.scm"))
\ No newline at end of file
diff --git a/collects/ssax/look-for-str.scm b/collects/ssax/look-for-str.scm
new file mode 100644
index 0000000000..74d833f14c
--- /dev/null
+++ b/collects/ssax/look-for-str.scm
@@ -0,0 +1,100 @@
+; -- Function: find-string-from-port? STR IN-PORT MAX-NO-CHARS
+;    Looks for a string STR within the first MAX-NO-CHARS chars of the
+;    input port IN-PORT
+;    MAX-NO-CHARS may be omitted: in that case, the search span would be
+;    limited only by the end of the input stream.
+;    When the STR is found, the function returns the number of
+;    characters it has read from the port, and the port is set
+;    to read the first char after that (that is, after the STR)
+;    The function returns #f when the string wasn't found
+; Note the function reads the port *STRICTLY* sequentially, and does not
+; perform any buffering. So the function can be used even if the port is open
+; on a pipe or other communication channel.
+;
+; Probably can be classified as misc-io.
+;
+; Notes on the algorithm.
+; A special care should be taken in a situation when one had achieved a partial
+; match with (a head of) STR, and then some unexpected character appeared in
+; the stream. It'll be rash to discard all already read characters. Consider
+; an example of string "acab" and the stream "bacacab...", specifically when
+;    a  c  a _b_
+; b  a  c  a  c  a  b ...
+; that is, when 'aca' had matched, but then 'c' showed up in the stream
+; while we were looking for 'b'. In that case, discarding all already read
+; characters and starting the matching process from scratch, that is,
+; from 'c a b ...', would miss a certain match.
+; Note, we don't actually need to keep already read characters, or at least
+; strlen(str) characters in some kind of buffer. If there has been no match,
+; we can safely discard read characters. If there was some partial match,
+; we already know the characters before, they are in the STR itself, so
+; we don't need a special buffer for that.
+
+;;; "MISCIO" Search for string from port.
+; Written 1995 by Oleg Kiselyov (oleg@ponder.csci.unt.edu)
+; Modified 1996 by A. Jaffer (jaffer@ai.mit.edu)
+;
+; This code is in the public domain.
+
+(define (MISCIO:find-string-from-port? str <input-port> . max-no-char)
+  (set! max-no-char (if (null? max-no-char) #f (car max-no-char)))
+  (letrec
+      ((no-chars-read 0)
+       (my-peek-char			; Return a peeked char or #f
+	(lambda () (and (or (not max-no-char) (< no-chars-read max-no-char))
+			(let ((c (peek-char <input-port>)))
+			  (if (eof-object? c) #f c)))))
+       (next-char (lambda () (read-char <input-port>)
+			  (set! no-chars-read  (inc no-chars-read))))
+       (match-1st-char			; of the string str
+	(lambda ()
+	  (let ((c (my-peek-char)))
+	    (if (not c) #f
+		(begin (next-char)
+		       (if (char=? c (string-ref str 0))
+			   (match-other-chars 1)
+			   (match-1st-char)))))))
+       ;; There has been a partial match, up to the point pos-to-match
+       ;; (for example, str[0] has been found in the stream)
+       ;; Now look to see if str[pos-to-match] for would be found, too
+       (match-other-chars
+	(lambda (pos-to-match)
+	  (if (>= pos-to-match (string-length str))
+	      no-chars-read		; the entire string has matched
+	      (let ((c (my-peek-char)))
+		(and c
+		     (if (not (char=? c (string-ref str pos-to-match)))
+			 (backtrack 1 pos-to-match)
+			 (begin (next-char)
+				(match-other-chars (inc pos-to-match)))))))))
+
+       ;; There had been a partial match, but then a wrong char showed up.
+       ;; Before discarding previously read (and matched) characters, we check
+       ;; to see if there was some smaller partial match. Note, characters read
+       ;; so far (which matter) are those of str[0..matched-substr-len - 1]
+       ;; In other words, we will check to see if there is such i>0 that
+       ;; substr(str,0,j) = substr(str,i,matched-substr-len)
+       ;; where j=matched-substr-len - i
+       (backtrack
+	(lambda (i matched-substr-len)
+	  (let ((j (- matched-substr-len i)))
+	    (if (<= j 0)
+	      (match-1st-char)	; backed off completely to the begining of str
+	      (let loop ((k 0))
+	        (if (>= k j)
+	           (match-other-chars j) ; there was indeed a shorter match
+	           (if (char=? (string-ref str k)
+	           	       (string-ref str (+ i k)))
+	             (loop (inc k))
+	             (backtrack (inc i) matched-substr-len))))))))
+       )
+    (match-1st-char)))
+
+(define find-string-from-port? MISCIO:find-string-from-port?)
+
+
+;-----------------------------------------------------------------------------
+;   This is a test driver for miscio:find-string-from-port?, to make sure it
+;			really works as intended
+
+; moved to vinput-parse.scm
diff --git a/collects/ssax/lookup-def.scm b/collects/ssax/lookup-def.scm
new file mode 100644
index 0000000000..29fa44afc7
--- /dev/null
+++ b/collects/ssax/lookup-def.scm
@@ -0,0 +1,67 @@
+; Look up a value associated with a symbolic key in alist 
+; ((key value) ...) or ((key . value) ...)
+; and return the associated value.
+; If the association has the form
+;   (key . value) where value is not a pair --> return value
+;   (key   value)                           --> return value
+;   (key value1 value2 value3 ...) -> return (value1 value2 value3 ...)
+; that is, the procedure tries to do the right thing for
+; both kinds of associative lists. 
+;
+; The form `lookup-def' is a special form rather than a regular
+; procedure. Its first two arguments are evaluated exactly once. The
+; default-value argument, if given, is evaluated only if the desired key
+; is not found. I have not seen any need to pass `lookup-def' as an
+; argument to other functions. If the latter is desired, it is not
+; difficult to accomplish by explicitly wrapping `lookup-def' into a
+; lambda form.
+;
+; We use a pseudo-keyword argument warn: as a modifier.
+; This is not really a keyword argument (although it may be,
+; if the Scheme system turns out DSSSL-compatible)
+; 
+; (lookup-def key alist)  -- lookup the key in the alist and return the
+;                        associated value. Raise an error if the key is not
+;                        found.
+; (lookup-def key alist default-exp)
+;                     -- lookup the key in the alist and return the associated
+;                        value. If the the key is not found, evaluate
+;                        the default-exp and return its result.
+; (lookup-def key alist warn: default-exp)
+;                     -- the same as above. In addition, write a warning
+;                        (using cerr above) if the key is not found.
+
+(define-syntax lookup-def 
+  (syntax-rules (warn:)
+    ((lookup-def key alist)
+      (let ((nkey key) (nalist alist)) ; evaluate them only once
+	(let ((res (assq nkey nalist)))
+	  (if res
+	    (let ((res (cdr res)))
+	     (cond
+	       ((not (pair? res)) res)
+	       ((null? (cdr res)) (car res))
+	       (else res)))
+	    (error "Failed to find " nkey " in " nalist)))))
+    ((lookup-def key alist default-exp)
+      (let ((res (assq key alist)))
+	(if res
+	  (let ((res (cdr res)))
+	    (cond
+	      ((not (pair? res)) res)
+	      ((null? (cdr res)) (car res))
+	      (else res)))
+	  default-exp)))
+    ((lookup-def key alist warn: default-exp)
+      (let ((nkey key) (nalist alist)) ; evaluate them only once
+	(let ((res (assq nkey nalist)))
+	  (if res
+	    (let ((res (cdr res)))
+	     (cond
+	       ((not (pair? res)) res)
+	       ((null? (cdr res)) (car res))
+	       (else res)))
+	    (begin
+	      (cerr "Failed to find " nkey " in " nalist #\newline)
+	      default-exp)))))
+    ))
diff --git a/collects/ssax/lookup-def.ss b/collects/ssax/lookup-def.ss
new file mode 100644
index 0000000000..f12be298e2
--- /dev/null
+++ b/collects/ssax/lookup-def.ss
@@ -0,0 +1,10 @@
+(module lookup-def mzscheme
+  (provide lookup-def)
+
+  (require (lib "23.ss" "srfi")) ; ERROR
+  (require "coutputs.ss")
+
+  (require (lib "include.ss"))
+  (include "lookup-def.scm"))
+
+    
\ No newline at end of file
diff --git a/collects/ssax/oleg-string-ports.ss b/collects/ssax/oleg-string-ports.ss
new file mode 100644
index 0000000000..06eacd9278
--- /dev/null
+++ b/collects/ssax/oleg-string-ports.ss
@@ -0,0 +1,18 @@
+(module oleg-string-ports mzscheme
+
+  (provide with-output-to-string
+	   call-with-input-string
+	   with-input-from-string)
+
+  (begin
+    (define (with-output-to-string thunk)
+      (let ((port (open-output-string)))
+	(parameterize ((current-output-port port))
+	    (thunk)
+	    (get-output-string port))))
+    (define (call-with-input-string string proc)
+      (proc (open-input-string string)))
+    (define (with-input-from-string string thunk)
+      (parameterize ((current-input-port (open-input-string string)))
+	(thunk)))))
+
diff --git a/collects/ssax/oleg-utils.ss b/collects/ssax/oleg-utils.ss
new file mode 100644
index 0000000000..dbf2e8da0c
--- /dev/null
+++ b/collects/ssax/oleg-utils.ss
@@ -0,0 +1,22 @@
+(module oleg-utils mzscheme
+
+  (provide any?
+	   list-intersperse list-intersperse!
+	   list-tail-diff
+	   string-rindex
+	   substring?
+	   string->integer
+	   string-split
+	   make-char-quotator)
+  
+  (require (rename (lib "13.ss" "srfi") string-index-right string-index-right)
+	   (rename (lib "13.ss" "srfi") string-contains string-contains)
+	   (rename (lib "13.ss" "srfi") string-null? string-null?))
+  (require (lib "23.ss" "srfi"))
+  (require "crementing.ss")
+
+  (require (lib "include.ss"))
+  (include "util.scm"))
+
+
+	   
\ No newline at end of file
diff --git a/collects/ssax/output.scm b/collects/ssax/output.scm
new file mode 100644
index 0000000000..6bffba3a72
--- /dev/null
+++ b/collects/ssax/output.scm
@@ -0,0 +1,18 @@
+; like cout << arguments << args
+; where argument can be any Scheme object. If it's a procedure
+; (without args) it's executed rather than printed (like newline)
+
+(define (cout . args)
+  (for-each (lambda (x)
+              (if (procedure? x) (x) (display x)))
+            args))
+
+(define (cerr . args)
+  (for-each (lambda (x)
+              (if (procedure? x)
+		  (x (current-error-port))
+		  (display x (current-error-port))))
+            args))
+
+;(##define-macro (nl) '(newline))
+(define nl (string #\newline))
diff --git a/collects/ssax/ppretty-prints.scm b/collects/ssax/ppretty-prints.scm
new file mode 100644
index 0000000000..3cab08fa03
--- /dev/null
+++ b/collects/ssax/ppretty-prints.scm
@@ -0,0 +1,31 @@
+; Pretty-printer for various Scheme systems
+;
+; It implements the structure ppretty-prints for Scheme systems
+; other than Scheme48 and PLT Scheme.
+; Also implement display-circle
+;
+; $Id: ppretty-prints.scm,v 1.1 2004/10/02 07:50:50 eli Exp $
+
+; If the pretty-printer is available, use it. Otherwise, use 'display'
+; If display-circle is available or a regular pretty-printer can handle
+; circular lists, use them. Otherwise, refuse to display circular data
+; structures
+
+(cond-expand
+  (bigloo
+    #f)					; pp and display-circle are natively
+					; available
+  ((or scm gambit)
+    					; pp is natively available
+    (define (display-circle x)          ; display-circle is not
+      (display "Cannot safely display circular datastructures. Use SRFI-38")
+      (newline)))
+  ((or petite-chez)
+    (define pp pretty-print)
+    (define display-circle pp))
+  (else
+    (define pp display)		         ; Fall-back to display
+    (define (display-circle x)
+      (display "Cannot safely display circular datastructures. Use SRFI-38")
+      (newline))))
+
diff --git a/collects/ssax/ppretty-prints.ss b/collects/ssax/ppretty-prints.ss
new file mode 100644
index 0000000000..bede97b2ad
--- /dev/null
+++ b/collects/ssax/ppretty-prints.ss
@@ -0,0 +1,6 @@
+(module ppretty-prints mzscheme
+
+  (provide pp)
+
+  (require (lib "pretty.ss"))
+  (define pp pretty-print))
diff --git a/collects/ssax/restricted-mzscheme.ss b/collects/ssax/restricted-mzscheme.ss
new file mode 100644
index 0000000000..f31b2c6cbc
--- /dev/null
+++ b/collects/ssax/restricted-mzscheme.ss
@@ -0,0 +1,3 @@
+(module restricted-mzscheme mzscheme
+  (provide (all-from-except mzscheme
+			    read-string)))
diff --git a/collects/ssax/ssax.ss b/collects/ssax/ssax.ss
new file mode 100644
index 0000000000..0cf4d1d964
--- /dev/null
+++ b/collects/ssax/ssax.ss
@@ -0,0 +1,61 @@
+(module ssax "restricted-mzscheme.ss"
+  
+  (provide xml-token?
+	   xml-token-kind xml-token-head
+	   make-empty-attlist attlist-add
+	   attlist-null?
+	   attlist-remove-top
+	   attlist->alist attlist-fold
+	   ssax:uri-string->symbol
+	   ssax:skip-internal-dtd
+	   ssax:read-pi-body-as-string
+	   ssax:reverse-collect-str-drop-ws
+	   ssax:read-markup-token
+	   ssax:read-cdata-body
+	   ssax:read-char-ref
+	   ssax:read-attributes
+	   ssax:complete-start-tag
+	   ssax:read-external-id
+	   ssax:read-char-data
+	   ssax:make-parser ssax:make-pi-parser ssax:make-elem-parser
+	   ssax:xml->sxml
+	   ssax:warn-parameter)
+
+  (require (rename (lib "1.ss" "srfi") cons* cons*))
+  (require (rename (lib "13.ss" "srfi") string-null? string-null?)
+	   (rename (lib "13.ss" "srfi") string-index string-index)
+	   (rename (lib "13.ss" "srfi")
+		   string-concatenate/shared string-concatenate/shared)
+	   (rename (lib "13.ss" "srfi")
+		   string-concatenate-reverse/shared string-concatenate-reverse/shared))
+
+  (require "crementing.ss")
+  (require "input-parse.ss")
+  (require "char-encodings.ss")
+  (require "ascii.ss")
+  (require "ppretty-prints.ss")
+  (require "oleg-utils.ss")
+  (require "find-strings.ss")
+  (require "assertions.ss")
+  (require "coutputs.ss")
+  (require "catch-errors.ss")
+  (require "oleg-string-ports.ss")
+
+  (define (SSAX:warn-standard port msg . other-msg)
+    (apply cerr (cons (string-append (string #\newline) "Warning: ")
+		      (cons msg
+			    other-msg))))
+
+  
+  (define ssax:warn-parameter (make-parameter SSAX:warn-standard))
+
+  (define (ssax:warn port msg . other-msg)
+    (apply (ssax:warn-parameter) port msg other-msg))
+
+  (require (lib "include.ss"))
+  (include "SSAX-code.scm"))
+
+
+  
+
+
diff --git a/collects/ssax/sxml-to-html-ext.ss b/collects/ssax/sxml-to-html-ext.ss
new file mode 100644
index 0000000000..5aaed71c54
--- /dev/null
+++ b/collects/ssax/sxml-to-html-ext.ss
@@ -0,0 +1,25 @@
+(module sxml-to-html-ext mzscheme
+
+  (provide make-header
+	   make-navbar
+	   make-footer
+	   universal-conversion-rules
+	   universal-protected-rules
+	   alist-conv-rules)
+
+  (require (lib "23.ss" "srfi"))
+  (require "oleg-utils.ss")
+  (require "coutputs.ss")
+  (require "assertions.ss")
+  (require "crementing.ss")
+  (require "lookup-def.ss")
+  (require "sxml-to-html.ss")
+  (require "sxml-tree-trans.ss")
+
+  (define OS:file-length file-size)
+
+  (require (lib "include.ss"))
+  (include "SXML-to-HTML-ext.scm"))
+
+
+  
\ No newline at end of file
diff --git a/collects/ssax/sxml-to-html.ss b/collects/ssax/sxml-to-html.ss
new file mode 100644
index 0000000000..2558c5c3ac
--- /dev/null
+++ b/collects/ssax/sxml-to-html.ss
@@ -0,0 +1,14 @@
+(module sxml-to-html mzscheme
+
+  (provide SXML->HTML
+	   enattr
+	   entag
+	   string->goodHTML)
+  
+  (require "coutputs.ss")
+  (require "assertions.ss")
+  (require "oleg-utils.ss")
+  (require "sxml-tree-trans.ss")
+
+  (require (lib "include.ss"))
+  (include "SXML-to-HTML.scm"))
diff --git a/collects/ssax/sxml-tree-trans.ss b/collects/ssax/sxml-tree-trans.ss
new file mode 100644
index 0000000000..c0e9ed5288
--- /dev/null
+++ b/collects/ssax/sxml-tree-trans.ss
@@ -0,0 +1,10 @@
+(module sxml-tree-trans mzscheme
+
+  (provide SRV:send-reply
+	   post-order pre-post-order replace-range)
+
+  (require "assertions.ss")
+  (require (lib "23.ss" "srfi"))
+
+  (require (lib "include.ss"))
+  (include "SXML-tree-trans.scm"))
diff --git a/collects/ssax/sxpath.ss b/collects/ssax/sxpath.ss
new file mode 100644
index 0000000000..8d0c63e4ba
--- /dev/null
+++ b/collects/ssax/sxpath.ss
@@ -0,0 +1,18 @@
+(module sxpath mzscheme
+
+  (provide nodeset?
+	   node-typeof?
+	   map-union
+	   sxpath)
+
+  (require (lib "pretty.ss"))
+  (require (lib "23.ss" "srfi")) ; ERROR
+  (require "crementing.ss")
+  (require "assertions.ss")
+  (require "coutputs.ss")
+
+  (require (lib "include.ss"))
+  (include "SXPath-old.scm"))
+
+
+  
\ No newline at end of file
diff --git a/collects/ssax/util.scm b/collects/ssax/util.scm
new file mode 100644
index 0000000000..db7fa0dbcb
--- /dev/null
+++ b/collects/ssax/util.scm
@@ -0,0 +1,292 @@
+;****************************************************************************
+;			My Scheme misc utility functions
+;		(mainly dealing with string and list manipulations)
+;
+; myenv.scm, myenv-bigloo.scm or similar prelude is assumed.
+; From SRFI-13, import many functions
+; If a particular implementation lacks SRFI-13 support, please
+; include the file srfi-13-local.scm
+;
+; $Id: util.scm,v 1.2 2004/11/09 14:11:40 sperber Exp $
+
+;------------------------------------------------------------------------
+;                               Iterator ANY?
+;
+; -- procedure+: any? PRED COLLECTION
+;       Searches for the first element in the collection satisfying a
+;       given predicate
+;       That is, the procedure applies PRED to every element of the
+;       COLLECTION in turn.
+;       The first element for which PRED returns non-#f stops the iteration;
+;       the value of the predicate is returned.
+;       If none of the elements of the COLLECTION satisfy the predicate,
+;       the return value from the procedure is #f
+;       COLLECTION can be a list, a vector, a string, or an input port.
+; See vmyenv.scm for validation tests.
+
+(define (any? <pred?> coll)
+  (cond
+    ((list? coll)
+      (let loop ((curr-l coll))
+        (if (null? curr-l) #f
+          (or (<pred?> (car curr-l)) (loop (cdr curr-l))))))
+          
+    ((vector? coll)
+      (let ((len (vector-length coll)))
+       (let loop ((i 0))
+        (if (>= i len) #f
+          (or (<pred?> (vector-ref coll i)) (loop (inc i)))))))
+
+    ((string? coll)
+      (let ((len (string-length coll)))
+       (let loop ((i 0))
+        (if (>= i len) #f
+          (or (<pred?> (string-ref coll i)) (loop (inc i)))))))
+
+    ((input-port? coll)
+      (let loop ((c (read-char coll)))
+        (if (eof-object? c) #f
+          (or (<pred?> c) (loop (read-char coll))))))
+
+    (else (error "any? on an invalid collection"))))
+
+
+;------------------------------------------------------------------------
+;		Some list manipulation functions
+
+; -- procedure+: list-intersperse SRC-L ELEM
+; inserts ELEM between elements of the SRC-L, returning a freshly allocated
+; list (cells, that is)
+      
+(define (list-intersperse src-l elem)
+  (if (null? src-l) src-l
+    (let loop ((l (cdr src-l)) (dest (cons (car src-l) '())))
+      (if (null? l) (reverse dest)
+        (loop (cdr l) (cons (car l) (cons elem dest)))))))
+
+
+; -- procedure+: list-intersperse! SRC-L ELEM
+; inserts ELEM between elements of the SRC-L inplace
+      
+(define (list-intersperse! src-l elem)
+  (if (null? src-l) src-l
+    (let loop ((l src-l))
+      (let ((next-l (cdr l)))
+        (if (null? next-l) src-l
+          (begin
+            (set-cdr! l (cons elem next-l))
+            (loop next-l)))))))
+
+
+	; List-tail-difference: given two lists, list1 and list2 where
+	; list2 is presumably a tail of list1, return 
+	; a (freshly allocated) list which is a difference between list1 
+	; and list2. If list2 is *not* a tail of list1, the entire list1
+	; is returned.
+(define (list-tail-diff list1 list2)
+  (let loop ((l1-curr list1) (difference '()))
+    (cond
+      ((eq? l1-curr list2) (reverse difference))
+      ((null? l1-curr) (reverse difference))
+      (else (loop (cdr l1-curr) (cons (car l1-curr) difference))))))
+
+
+;------------------------------------------------------------------------
+;			String utilities
+; See SRFI-13 or srfi-13-local.scm
+
+
+; Return the index of the last occurence of a-char in str, or #f
+; See SRFI-13
+(define string-rindex string-index-right)
+
+; -- procedure+: substring? PATTERN STRING
+;     Searches STRING to see if it contains the substring PATTERN.
+;     Returns the index of the first substring of STRING that is equal
+;     to PATTERN; or `#f' if STRING does not contain PATTERN.
+;
+;          (substring? "rat" "pirate")             =>  2
+;          (substring? "rat" "outrage")            =>  #f
+;          (substring? "" any-string)              =>  0
+(define (substring? pattern str) (string-contains str pattern))
+
+
+; -- procedure+: string->integer STR START END
+;
+; Makes sure a substring of the STR from START (inclusive) till END
+; (exclusive) is a representation of a non-negative integer in decimal
+; notation. If so, this integer is returned. Otherwise -- when the
+; substring contains non-decimal characters, or when the range from
+; START till END is not within STR, the result is #f.
+;
+; This procedure is a simplification of the standard string->number.
+; The latter is far more generic: for example, it will try to read
+; strings like "1/2" "1S2" "1.34" and even "1/0" (the latter causing
+; a zero-divide error). Note that to string->number,  "1S2" is a valid
+; representation of an _inexact_ integer (100 to be precise).
+; Oftentimes we want to be more restrictive about what we consider a
+; number; we want merely to read an integral label.
+
+(define (string->integer str start end)
+  (and (< -1 start end (inc (string-length str)))
+    (let loop ((pos start) (accum 0))
+      (cond
+        ((>= pos end) accum)
+        ((char-numeric? (string-ref str pos))
+          (loop (inc pos) (+ (char->integer (string-ref str pos)) 
+              (- (char->integer #\0)) (* 10 accum))))
+        (else #f)))))
+
+
+; 
+; -- procedure+: string-split STRING
+; -- procedure+: string-split STRING '()
+; -- procedure+: string-split STRING '() MAXSPLIT
+;
+; Returns a list of whitespace delimited words in STRING.
+; If STRING is empty or contains only whitespace, then the empty list
+; is returned. Leading and trailing whitespaces are trimmed.
+; If MAXSPLIT is specified and positive, the resulting list will
+; contain at most MAXSPLIT elements, the last of which is the string
+; remaining after (MAXSPLIT - 1) splits. If MAXSPLIT is specified and
+; non-positive, the empty list is returned. "In time critical
+; applications it behooves you not to split into more fields than you
+; really need."
+;
+; -- procedure+: string-split STRING CHARSET
+; -- procedure+: string-split STRING CHARSET MAXSPLIT
+;
+; Returns a list of words delimited by the characters in CHARSET in
+; STRING. CHARSET is a list of characters that are treated as delimiters.
+; Leading or trailing delimeters are NOT trimmed. That is, the resulting
+; list will have as many initial empty string elements as there are
+; leading delimiters in STRING.
+;
+; If MAXSPLIT is specified and positive, the resulting list will
+; contain at most MAXSPLIT elements, the last of which is the string
+; remaining after (MAXSPLIT - 1) splits. If MAXSPLIT is specified and
+; non-positive, the empty list is returned. "In time critical
+; applications it behooves you not to split into more fields than you
+; really need."
+;
+; This is based on the split function in Python/Perl
+;
+; (string-split " abc d e f  ") ==> ("abc" "d" "e" "f")
+; (string-split " abc d e f  " '() 1) ==> ("abc d e f  ")
+; (string-split " abc d e f  " '() 0) ==> ()
+; (string-split ":abc:d:e::f:" '(#\:)) ==> ("" "abc" "d" "e" "" "f" "")
+; (string-split ":" '(#\:)) ==> ("" "")
+; (string-split "root:x:0:0:Lord" '(#\:) 2) ==> ("root" "x:0:0:Lord")
+; (string-split "/usr/local/bin:/usr/bin:/usr/ucb/bin" '(#\:))
+; ==> ("/usr/local/bin" "/usr/bin" "/usr/ucb/bin")
+; (string-split "/usr/local/bin" '(#\/)) ==> ("" "usr" "local" "bin")
+
+(define (string-split str . rest)
+		; maxsplit is a positive number
+  (define (split-by-whitespace str maxsplit)
+    (define (skip-ws i yet-to-split-count)
+      (cond
+        ((>= i (string-length str)) '())
+        ((char-whitespace? (string-ref str i))
+          (skip-ws (inc i) yet-to-split-count))
+        (else (scan-beg-word (inc i) i yet-to-split-count))))
+    (define (scan-beg-word i from yet-to-split-count)
+      (cond
+        ((zero? yet-to-split-count)
+          (cons (substring str from (string-length str)) '()))
+        (else (scan-word i from yet-to-split-count))))
+    (define (scan-word i from yet-to-split-count)
+      (cond
+        ((>= i (string-length str))
+          (cons (substring str from i) '()))
+        ((char-whitespace? (string-ref str i))
+          (cons (substring str from i) 
+            (skip-ws (inc i) (- yet-to-split-count 1))))
+        (else (scan-word (inc i) from yet-to-split-count))))
+    (skip-ws 0 (- maxsplit 1)))
+
+		; maxsplit is a positive number
+		; str is not empty
+  (define (split-by-charset str delimeters maxsplit)
+    (define (scan-beg-word from yet-to-split-count)
+      (cond
+        ((>= from (string-length str)) '(""))
+        ((zero? yet-to-split-count)
+          (cons (substring str from (string-length str)) '()))
+        (else (scan-word from from yet-to-split-count))))
+    (define (scan-word i from yet-to-split-count)
+      (cond
+        ((>= i (string-length str))
+          (cons (substring str from i) '()))
+        ((memq (string-ref str i) delimeters)
+          (cons (substring str from i) 
+            (scan-beg-word (inc i) (- yet-to-split-count 1))))
+        (else (scan-word (inc i) from yet-to-split-count))))
+    (scan-beg-word 0 (- maxsplit 1)))
+
+			; resolver of overloading...
+			; if omitted, maxsplit defaults to
+			; (inc (string-length str))
+  (if (string-null? str) '()
+    (if (null? rest) 
+      (split-by-whitespace str (inc (string-length str)))
+      (let ((charset (car rest))
+          (maxsplit
+            (if (pair? (cdr rest)) (cadr rest) (inc (string-length str)))))
+        (cond 
+          ((not (positive? maxsplit)) '())
+          ((null? charset) (split-by-whitespace str maxsplit))
+          (else (split-by-charset str charset maxsplit))))))
+)
+
+
+; make-char-quotator QUOT-RULES
+;
+; Given QUOT-RULES, an assoc list of (char . string) pairs, return
+; a quotation procedure. The returned quotation procedure takes a string
+; and returns either a string or a list of strings. The quotation procedure
+; check to see if its argument string contains any instance of a character
+; that needs to be encoded (quoted). If the argument string is "clean",
+; it is returned unchanged. Otherwise, the quotation procedure will
+; return a list of string fragments. The input straing will be broken
+; at the places where the special characters occur. The special character
+; will be replaced by the corresponding encoding strings.
+;
+; For example, to make a procedure that quotes special HTML characters,
+; do
+;	(make-char-quotator
+;	    '((#\< . "&lt;") (#\> . "&gt;") (#\& . "&amp;") (#\" . "&quot;")))
+
+(define (make-char-quotator char-encoding)
+  (let ((bad-chars (map car char-encoding)))
+
+    ; Check to see if str contains one of the characters in charset,
+    ; from the position i onward. If so, return that character's index.
+    ; otherwise, return #f
+    (define (index-cset str i charset)
+      (let loop ((i i))
+	(and (< i (string-length str))
+	     (if (memv (string-ref str i) charset) i
+		 (loop (inc i))))))
+
+    ; The body of the function
+    (lambda (str)
+      (let ((bad-pos (index-cset str 0 bad-chars)))
+	(if (not bad-pos) str	; str had all good chars
+	    (let loop ((from 0) (to bad-pos))
+	      (cond
+	       ((>= from (string-length str)) '())
+	       ((not to)
+		(cons (substring str from (string-length str)) '()))
+	       (else
+		(let ((quoted-char
+		       (cdr (assv (string-ref str to) char-encoding)))
+		      (new-to 
+		       (index-cset str (inc to) bad-chars)))
+		  (if (< from to)
+		      (cons
+		       (substring str from to)
+		       (cons quoted-char (loop (inc to) new-to)))
+		      (cons quoted-char (loop (inc to) new-to))))))))))
+))
+
diff --git a/collects/stepper/break.ss b/collects/stepper/break.ss
new file mode 100644
index 0000000000..1f39d6c8fc
--- /dev/null
+++ b/collects/stepper/break.ss
@@ -0,0 +1,25 @@
+(module break mzscheme
+
+  (require (lib "contract.ss"))
+  
+  (provide current-breakpoint-handler)
+  
+  (define (default-current-breakpoint-handler)
+    (error 'default-current-breakpoint-handler
+           "The current-breakpoint-handler parameter has not yet been set in this thread."))
+  
+  (define current-breakpoint-handler
+    (make-parameter default-current-breakpoint-handler
+                    (lambda (new-handler)
+                      (if (and (procedure? new-handler)
+                               (procedure-arity-includes? new-handler 0))
+                          new-handler
+                          (error 'current-breakpoint-handler "Bad value for current-breakpoint-handler: ~e" new-handler)))))
+  
+  
+  (provide/contract [break (-> any)])
+  
+  (define (break)
+    ((current-breakpoint-handler))))
+  
+  
\ No newline at end of file
diff --git a/collects/stepper/debugger-doc.txt b/collects/stepper/debugger-doc.txt
new file mode 100644
index 0000000000..d09afc817a
--- /dev/null
+++ b/collects/stepper/debugger-doc.txt
@@ -0,0 +1,104 @@
+---
+
+Preliminary _Debugger_ Documentation
+
+The debugger is structured as an interaction between the program
+being debugged and a debugger UI.  The program is annotated to
+produce a stream of debugger "events" (as defined below) and to
+periodically block on a debugger semaphore.  The debugger currently
+uses the stepper's annotation; changes to the annotation will
+be the focus of the next stage of the debugger.
+
+A simple debugger UI is provided as part of the debugger, but
+users who want to use the debugger will probably also want
+to supply their own UI.  For this reason, we describe the interface
+to the UI first, and then the working of the current skeleton 
+UI.
+
+Debugger Events:
+
+A debugger-event is either:
+> (make-breakpoint-halt), or
+    : (-> debugger-event?)
+> (make-normal-breakpoint-info mark-list kind returned-value-list)
+    : (-> (listof mark?) symbol? (listof any?) 
+          debugger-event?)
+> (make-error-breakpoint-info message)
+    : (-> string? 
+          debugger-event?)
+> (make-expression-finished returned-value-list)
+    : (-> (listof any?)
+          debugger-event?)
+
+> (make-full-mark location label bindings)
+    : (-> syntax? symbol? (listof identifier?)
+          syntax?)
+
+NOTE: there is a mistake here, in the sense that the thing made by
+'make-full-mark' is not actually a mark.  It's a piece of syntax
+that represents a lambda expression which when evaluated turns 
+into a mark.  A mark is an opaque data type.  Its contents can
+be extracted with the expose-mark function:
+
+expose-mark : (-> mark?
+                  (list/p syntax? 
+                          symbol? 
+                          (listof (list/p identifier? any?))))
+
+
+Debugger UI (view-controller) signatures:
+
+  (define-signature debugger-model^
+    (go-semaphore
+     user-custodian
+     set-breakpoint
+     restart-program))
+  
+  (define-signature debugger-vc^
+    (receive-result
+     debugger-output-port))
+
+A debugger UI is a unit which imports signature debugger-model^
+(name-change suggestions welcomed) and exports signature
+debugger-vc^ (ditto).  
+
+> go-semaphore: when the user's program halts at a breakpoint,
+it will block on this semaphore.  Therefore, the UI can
+post to this semaphore to allow computation to proceed.
+
+> user-custodian: the user-custodian governs the user's program.
+Therefore, the UI can shut down this custodian to halt debugging.
+
+> (set-breakpoint location [name]): (location -> number)
+set-breakpoint specifies a location at which to set a breakpoint.
+For the moment, this breakpoint will be active only after restarting
+the user's program.  A location has the following contract:
+(list/p number? ; line number
+	(union string? false?) ; filename
+	(union number? false?) ; position  
+
+> (receive-result event) : (event -> void) The user's program 
+calls this procedure whenever a debugger event occurs.  Note that 
+a  (make-breakpoint-halt) event will occur whenever the user's 
+program blocks at a breakpoint.
+
+> debugger-output-port : output from the user's program goes 
+to this port. 
+
+
+Existing mini-UI:
+
+The debugger starts a graphical read-eval-print loop, with the 
+following bindings:
+
+> go-semaphore: passed through from the debugger
+
+> (events): returns a list of all events that have occurred during 
+the execution of the program.
+
+> user-custodian: passed through from the debugger.
+
+In addition, the mini-UI prints a message to the grepl whenever
+an event occurs (which is cheerfully accepted as input the next
+time the user presses return...).
+
diff --git a/collects/stepper/debugger-sig.ss b/collects/stepper/debugger-sig.ss
new file mode 100644
index 0000000000..0d085cd651
--- /dev/null
+++ b/collects/stepper/debugger-sig.ss
@@ -0,0 +1,13 @@
+(module debugger-sig mzscheme
+  (require (lib "unitsig.ss"))
+  
+  (provide debugger-model^
+           debugger-vc^)
+  
+  (define-signature debugger-model^
+    (go-semaphore
+     user-custodian
+     go))
+  
+  (define-signature debugger-vc^
+    (receive-result)))
diff --git a/collects/stepper/debugger-tool.ss b/collects/stepper/debugger-tool.ss
new file mode 100644
index 0000000000..8d49213360
--- /dev/null
+++ b/collects/stepper/debugger-tool.ss
@@ -0,0 +1,161 @@
+(module debugger-tool mzscheme
+  (require (lib "contract.ss")
+           (lib "tool.ss" "drscheme")
+           (lib "mred.ss" "mred")  
+           (prefix frame: (lib "framework.ss" "framework"))
+           (lib "unitsig.ss")
+           (lib "class.ss")
+           (lib "list.ss")
+           (lib "bitmap-label.ss" "mrlib")
+           "debugger-sig.ss"
+           "private/debugger-vc.ss"
+           "private/debugger-model.ss"
+	   "private/my-macros.ss")
+    
+  (provide tool@)
+  
+  (define tool@
+    (unit/sig drscheme:tool-exports^
+      (import drscheme:tool^)
+
+      (define (phase1) (void))
+      (define (phase2) (void))
+      
+      (define debugger-initial-width 500)
+      (define debugger-initial-height 500)
+      
+      (define debugger-bitmap
+        (bitmap-label-maker
+         "Debug"
+         (build-path (collection-path "icons") "foot.png")))
+
+      (define debugger-unit-frame<%>
+        (interface ()
+          on-debugger-close))
+      
+      (define (debugger-unit-frame-mixin super%)
+        (class* super% (debugger-unit-frame<%>)
+          
+          (inherit get-button-panel get-interactions-text get-definitions-text get-menu-bar)
+          (rename [super-on-close on-close])
+          
+          (define debugger-exists #f)
+          (define/public (on-debugger-close)
+            (set! debugger-exists #f))
+          
+          (define breakpoints null)
+          
+          (super-instantiate ())
+          
+          ; DEBUGGER MENU
+          
+          (define debugger-menu (instantiate menu% () (label "Debugger") (parent (get-menu-bar))))
+          
+          (instantiate menu-item% () (label "Add Breakpoint") (parent debugger-menu) 
+            (callback (lambda (dc-item dc-event)
+                        (set! breakpoints (append breakpoints
+                                                  (list (send (get-definitions-text) get-start-position)))))))
+          
+          (define (position->line-n-offset pos)
+            (let* ([line (send (get-definitions-text) position-line pos)]
+                   [offset (- pos (send (get-definitions-text) line-start-position line))])
+              (values line offset)))
+          
+          (instantiate menu-item% () (label "List Breakpoints") (parent debugger-menu)
+            (callback (lambda (dc-item dc-event)
+                        (message-box "Current Breakpoints"
+                                   (format "Current breakpoint positions: ~a\n" (apply string-append
+                                                                                       (map (lambda (pos)
+                                                                                              (let-values ([(line offset) (position->line-n-offset pos)])
+                                                                                                (format "<~v:~v> (position ~v)\n" line offset pos)))
+                                                                                            breakpoints)))
+                                   this
+                                   '(ok)))))
+          
+          (instantiate menu-item% () (label "Clear All Breakpoints") (parent debugger-menu)
+            (callback (lambda (dc-item dc-event)
+                        (set! breakpoints null))))
+          
+          (define program-expander
+            (contract
+             (-> (-> void?) ; init
+                 (-> (union eof-object? syntax? (cons/p string? any/c)) (-> void?) void?) ; iter
+                 void?)
+             (lambda (init iter)
+               (let* ([lang-settings 
+                       (frame:preferences:get
+                        (drscheme:language-configuration:get-settings-preferences-symbol))]
+                      [lang (drscheme:language-configuration:language-settings-language lang-settings)]
+                      [settings (drscheme:language-configuration:language-settings-settings lang-settings)])
+                 (drscheme:eval:expand-program
+                  (drscheme:language:make-text/pos (get-definitions-text) 
+                                                   0
+                                                   (send (get-definitions-text)
+                                                         last-position)) 
+                  lang-settings
+                  #f
+                  (lambda ()
+                    (init)
+                    (error-value->string-handler
+                     (lambda (val len)
+                       (let ([sp (open-output-string)])
+                         (send lang render-value val settings sp)
+                         (let ([str (get-output-string sp)])
+                           (if ((string-length str) . <= . len)
+                               str
+                               (string-append (substring str 0 (max 0 (- len 3))) "..."))))))
+                    (drscheme:teachpack:install-teachpacks 
+                     (frame:preferences:get 'drscheme:teachpacks))) ; this belongs in model, but I'd need a unit rewrite
+                  void ; kill
+                  iter)))
+             'program-expander
+             'caller))
+          
+          (define debugger-button 
+            (make-object button%
+              (debugger-bitmap this)
+              (get-button-panel)
+              (lambda (button evt)
+                (if debugger-exists
+                    (message-box/custom "Debugger Exists"
+                                        "There is already a debugger window open for this program."
+                                        "OK"
+                                        #f
+                                        #f
+                                        #f
+                                        '(default=1))
+                    (begin
+                      (set! debugger-exists #t)
+                      (start-debugger program-expander this))))))
+          
+          (define breakpoint-origin (get-definitions-text))
+          
+          (define (start-debugger program-expander drs-window)
+            (define-values/invoke-unit/sig (go)
+             (compound-unit/sig 
+               (import [EXPANDER : (program-expander)]
+                       [BREAKPOINTS : (breakpoints breakpoint-origin)]
+                       [DRS-WINDOW : (drs-window)])
+               (link [MODEL : debugger-model^ (debugger-model@ VIEW-CONTROLLER EXPANDER BREAKPOINTS)] 
+                     [VIEW-CONTROLLER : debugger-vc^ (debugger-vc@ MODEL DRS-WINDOW)])
+               (export (var (MODEL go))))
+              #f
+              (program-expander)
+              (breakpoints breakpoint-origin)
+              (drs-window))
+            (go))
+          
+          (rename [super-enable-evaluation enable-evaluation])
+          (define/override (enable-evaluation)
+            (send debugger-button enable #t)
+            (super-enable-evaluation))
+          
+          (rename [super-disable-evaluation disable-evaluation])
+          (define/override (disable-evaluation)
+            (send debugger-button enable #f)
+            (super-disable-evaluation))
+          
+          (send (get-button-panel) change-children
+                (lx (cons debugger-button (remq debugger-button _))))))
+      
+      (drscheme:get/extend:extend-unit-frame debugger-unit-frame-mixin))))
diff --git a/collects/stepper/doc.txt b/collects/stepper/doc.txt
new file mode 100644
index 0000000000..edb838e424
--- /dev/null
+++ b/collects/stepper/doc.txt
@@ -0,0 +1,62 @@
+What is the _Stepper_?
+
+DrScheme includes an "algebraic stepper," a tool which proceeds
+through the evaluation of a set of definitions and expressions,
+one step at a time. This evaluation shows the user how DrScheme
+evaluates expressions and definitions, and can help in debugging
+programs.  Currently, the Stepper is available in the "Beginning
+Student" and "Intermediate Student" language levels.
+
+How do I use the Stepper?
+
+The Stepper operates on the contents of the frontmost DrScheme
+window.  A click on the "Step" button brings up the stepper
+window.  The stepper window has four panes, arranged as follows:
+
+------------------
+|    finished    |
+------------------
+|before ->  after|
+------------------
+|     coming     |
+------------------
+
+
+The first, "finished," box shows definitions and expressions
+whose evaluation is complete. This box is changed only when
+another completed evaluation's result is added to it.
+
+The second, "before," box, shows the current expression.  The
+region highlighted in green is known as the "redex".  You may
+pronounce this word in any way you want.  It is short for
+"reducible expression," and it is the expression which is the
+next to be simplified.
+
+The third, "after," box shows the result of the reduction.  The
+region highlighted in purple is the new expression which is
+substituted for the green one as a result of the reduction.
+
+Finally, the fourth box, labeled "coming" above, shows new
+expressions introduced by prior reductions which have yet to be
+reduced. As an example, a "local" expression may result in many
+new definitions which require reduction.  The definitions which
+have not yet been evaluated appear in the "coming" box.
+
+There are three buttons at the top of the stepper window.  The
+"Home" button returns to the initial state of the evaluation: that
+is, no expressions have yet been evaluated.  The "Previous"
+button returns to the prior step of the evaluation.  The "Next"
+step shows the next step in the evaluation.
+
+For more information on how DrScheme selects a "redex" and how
+the expressions are reduced, please see <A>The Beginner Language
+Semantics</A> which formally specify the set of rules governing
+the language's evaluation.
+
+Please note that the stepper only steps through the expressions
+in the definitions window, and does not allow the user to enter
+additional expressions.  So, for instance, a definitions buffer
+which contains only procedure definitions will not result in
+any reductions.
+
+
diff --git a/collects/stepper/info.ss b/collects/stepper/info.ss
new file mode 100644
index 0000000000..68db9016ea
--- /dev/null
+++ b/collects/stepper/info.ss
@@ -0,0 +1,17 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Stepper")
+  (define doc.txt "doc.txt")
+  
+  (define tools '(("stepper+xml-tool.ss")
+                  #;("debugger-tool.ss")
+                  ))
+  
+  (define tool-names (list "The Stepper" 
+			   #;"The Debugger"
+			   ))
+  
+  (define tool-icons (list '("foot-up.png" "icons") 
+			   #;'("foot-up.png" "icons")
+			   ))
+  (define compile-omit-files `("private/test-annotate.ss" "debugger-tool.ss"))
+)
diff --git a/collects/stepper/internal-docs.txt b/collects/stepper/internal-docs.txt
new file mode 100644
index 0000000000..8022e8dc08
--- /dev/null
+++ b/collects/stepper/internal-docs.txt
@@ -0,0 +1,242 @@
+This file summarizes certain aspects of the operation of the stepper.
+
+The Stepper's use of syntax-property:
+
+In order to make macro-unwinding possible, the stepper adds
+syntax-properties to elaborated code which then informs the
+reconstruction process about how certain macros were originally
+formed.  
+
+In fact, the truth is slightly more complicated, because there are
+two rounds of macro-expansion for a program written in a teaching
+language.  First, the program is expanded according to the 
+macro definitions contained in the "lang" collection.  Then, the
+code is expanded according to the macro definitions built into
+mzscheme.  So, for instance, a beginner 'cond' expands into a
+mzscheme 'cond' which expands into a nested series of 'if's.  
+
+Correspondingly, the stepper's addition of syntax properties is broken
+into two parts; those added for the beginner macros, and those added
+for the mzscheme macros.  However, since it is harder to alter the
+macro expansion which occurs in mzscheme, the latter set are added not
+during the actual macro expansion in mzscheme but as part of a pass
+over the code that occurs in the annotater between expansion and the
+main annotation.  This procedure is called 'top-level-rewrite'.
+
+Therefore, the stepper's syntax-property additions occur in two
+textual locations: collects/lang/private/teach.ss, and
+collects/stepper/private/annotate.ss (with a few stray ones 
+in collects/lang/private/teachhelp.ss).
+
+Also, in order to be visible to the reconstructor, these properties
+must be explicitly transferred from the annotated source code syntax
+to the reconstructed syntax. This is accomplished by the 'attach-info'
+procedure in reconstruct.ss.  Note that in the process, these properties
+are given names that have "user-" prepended to them.  This now seems 
+like a strange decision.
+
+Finally, the astute reader may wonder why I need to add things like
+'comes-from-or, since the expression that results from the expansion
+of 'or' has a corresponding 'or' element in its 'origin field.  The
+reason is that this element appears only on the outermost expression
+in the expansion, and during runtime reconstruction, this outermost
+expression may be gone.
+
+Here are the syntax properties added, the values they may be
+associated with, their meanings, whether they're transferred
+by attach-info, and where they're used:
+
+stepper-skip-completely :
+ [ #t ] : this code should not be annotated at all.  In general, this
+ means it therefore be invisible to the reconstructor. (Not
+ transferred.) Actually, the code is wrapped with a dummy mark,
+ just to make sure that other marks get properly obliterated.
+
+ Note that skipping an expression can turn a sensible expression into
+ a nonsensical one.  This is where the 'expressions are lists of 
+ subexpressions' abstraction and the 'expressions are one of A...Z'
+ abstraction part ways. 
+
+ Uses:
+ - applied to the check of the test-variable in the expansion of the
+   'or' macro. 
+ - applied to the expansion of the primitives defined with 
+   'define-primitive'.
+ - applied to the 'make-generative-lambda' inserted by teach.ss
+ 
+stepper-hint : 
+ this is the most generally applied syntax property.  In general, it
+ informs the reconstructor what macro this source expression came
+ from. 
+
+ See notes below about 'being careful with stepper-hint'.
+
+(Transferred.)
+
+ [ 'comes-from-cond ] : similarly, this expression came from a use
+ of 'cond'. This tag is applied to all the if's, but not to the else
+ clause.
+
+ [ 'comes-from-let* ] : expression was expanded from let*
+ [ 'comes-from-local ] : expression was expanded from local
+
+ [ 'from-xml-box ] : expression was expanded from an xml box
+ [ 'from-scheme-box ] : expression was expanded from a scheme box
+                        (inside an xml box)
+ [ 'from-splice-box ] : expression was expanded from a scheme splice
+		        box (inside an xml box)
+ [ 'comes-from-recur ] : expression was expanded from a 'recur'
+
+stepper-define-type: 
+ this is attached to the right-hand sides of defines to indicate what
+ kind of define they came from. 
+
+ [ 'shortened-proc-define ] : this lambda arose from the expansion
+    of (define (id arg ...) body).  N.B.: anything tagged with this 
+    property must also have a 'stepper-proc-define-name
+    property.
+
+ [ 'lambda-define ] : this lambda arose from the expansion of 
+    (define id (lambda (
+
+
+
+  (Transferred.)
+
+ Question 1: why the right-hand side?  Why not on the define itself?
+ A: because for certain kinds of define (namely those in a local),
+    the define itself evaporates into an internal define which is then
+    expanded in a mzscheme-native expansion into a letrec.
+
+ Question 2: won't the right-hand side change, losing the mark?  
+ A: yes it will, but not for definitions of lambdas.  Since there
+    are three cases we need to distinguish, and two of them are
+    definitions of lambdas, we can distinguish the third case
+    by its lack of a stepper-define-type mark.
+
+ Question 3: what if, through reduction, a different expression
+  than the original one shows up ... which _does_ have one of the
+  two stepper-define-type marks?
+ A: to prevent this, there's another syntax-property, 
+    'stepper-proc-define-name, which indicates the identifier to which
+    this procedure was originally bound.  In the absence of set!,
+    this solves the problem.
+
+stepper-xml-hint : indicates whether this expression came from an 
+xml-box.  The protocol is as follows:
+
+ [ 'from-xml-box ] : attached to the outer application that wraps
+   the result of expanding an xml-box
+
+ [ 'from-scheme-box ] : attached to the (begin ...) that wraps
+   the result of expanding a scheme-box
+
+ [ 'from-splice-box ] : attached to the (qq-append ...) that wraps
+   the result of expanding a splice-box
+
+  (Transferred.)
+
+stepper-xml-value-hint : like the stepper-xml-hint, used to indicate
+   values that are the result of evaluating xml boxes.  The reason
+   this cannot be the same as the stepper-xml-hint property is that
+   the stepper-xml-hint property is one of the "attached" ones which
+   follows the source syntax around.  This means that instances of this
+   property used to signal values that are the result of xml-box
+   evaluation get stomped by the stepper-xml-hint values attached to the
+   source.
+
+ [ 'from-xml-box ] : this value is the result of evaluating an xml 
+   box.
+
+stepper-proc-define-name : stores the name to which a procedure
+   defined with the (define (fn arg ...) body) was bound.
+
+  (Transferred.)
+
+stepper-orig-name: attached to an uninterned symbol used by
+   the expansion of define so that the stepper can compare the
+   name attached to a lambda to the name of a definition.
+
+  (Not transferred.)
+
+stepper-prim-name: 
+ this is attached to the expansion of primitives introduced with the
+ 'define-primitive' form. Its value indicates what name to give to
+ the source term at reconstruction time. 
+
+stepper-binding-type : 
+ this is actually unrelated to macro expansion. It differentiates
+ between the various kinds of lexical bindings. (Not transferred.)
+
+ [ 'macro-bound ] : this variable's binding was inserted by a macro
+ [ 'let-bound ] : this variable's binding was in a let/*/rec
+ [ 'lambda-bound ] : this variable's binding was in a lambda
+
+stepper-and/or-clauses-consumed : 
+ indicates the number of clauses to the left of the one associated
+ with a given 'if' in the expansion of an 'and' or 'or'.
+ This allows the stepper to reconstruct a partially evaluated
+ 'and' or 'or' with the right number of 'true's or 'false's 
+ in front.
+ (Transferred.)
+
+stepper-skipto : 
+ this instructs the annotater to look inside the current expression
+ along a given path for the expression to be annotated.  In
+ particular, the value bound to stepper-skipto must be a list whose
+ elements are car, cdr, or syntax-e. (Not transferred)
+
+Some uses:
+ - applied to the 'check-undefined' check added on local-bound variables.
+ - applied to the spurious 'let' that's wrapped around a local.
+
+Where it's used: the stepper-skipto label is used by the 2nd-pass
+macro-labeler and the annotater.  Both are in annotate.ss.  In addition
+to skipping inward, a stepper hint 
+
+stepper-else : 
+ [ #t ] : Initially applied to the 'true' that the cond macro
+  replaces a beginner's 'else' with, it is later transferred
+  to the 'if' wrapping that 'true'.  This is because there is no
+  place to annotated the cond that is passed to mzscheme's
+  expander which will result in an annotation on the 'if.'
+  Note that it cannot be applied simply to the 'true' itself,
+  because then, when you reduce to the then, the mark on the
+  test (that is, the (#%datum . true)) is gone.
+  (Transferred.)
+
+stepper-define-struct-hint :
+  this expression came from a define-struct. The value associated with
+  this label is the syntax-object representing the define-struct itself.
+
+stepper-test-suite-hint :
+  this expression was the expression being tested in a test-suite-tool
+  test.  this hint indicates to the annotater that the expression should
+  be annotated, even though it's not in one of the expected top-level
+  shapes.
+
+STEPPER-HINT COLLISIONS
+
+ The major concern with the stepper-hint is that two of them may
+ collide.  My claim that this never happens is founded on the following
+ reasoning, KNOWN NOT TO BE RIGOROUS.
+
+ 0) Tags are attached only to expressions that are produced fresh as
+ the result of a macro expansion. (For instance, the 'if' that is
+ the result of the expansion of 'and'.)
+
+ 1) except in the circumstances listed below, the expressions with tags 
+ attached to them are not themselves macro invocations.
+
+ Q.E.D.
+
+ exceptions:
+ 
+1) the beginner cond expands into the mzscheme cond, which is 
+then annotated by the top-level-rewrite. In this case, the expansion
+of the beginner cond does not add any stepper-hint properties, so no
+collision can occur.
+
+2) the intermediate let* expands into the beginner let; both add a 
+stepper-hint.  To resolve this, the expansion of let allows an existing
+stepper-hint to stand.
diff --git a/collects/stepper/private/annotate.ss b/collects/stepper/private/annotate.ss
new file mode 100644
index 0000000000..b7c6f04378
--- /dev/null
+++ b/collects/stepper/private/annotate.ss
@@ -0,0 +1,896 @@
+(module annotate mzscheme
+  (require (prefix kernel: (lib "kerncase.ss" "syntax"))
+           (lib "contract.ss")
+	   (lib "list.ss")
+           (lib "etc.ss")
+           (lib "match.ss")
+           "marks.ss"
+           "shared.ss"
+           "my-macros.ss"
+           "xml-box.ss"
+           (prefix beginner-defined: "beginner-defined.ss"))
+
+  
+  ; CONTRACTS
+
+  
+  ; PROVIDE
+  (provide/contract
+   [annotate
+    (-> syntax?                         ; syntax to annotate
+        (opt->* ((union continuation-mark-set? false/c) 
+                 break-kind?)
+                (list?)
+                (any/c))                 ; procedure for runtime break
+        boolean?                        ; track-inferred-name?
+        syntax?)]                       ; results
+   #;[top-level-rewrite (-> syntax? syntax?)])
+
+;  ;;                                              ;;;;                          ;
+; ;  ;                                     ;       ;                         ;
+; ;     ;   ;  ; ;;;   ; ;;;    ;;;   ; ;;;;;;     ;     ;   ;  ; ;;    ;;; ;;;; ;   ;;;   ; ;;    ;;;
+; ;     ;   ;  ;;   ;  ;;   ;  ;   ;  ;;   ;       ;     ;   ;  ;;  ;  ;     ;   ;  ;   ;  ;;  ;  ;
+;  ;;   ;   ;  ;    ;  ;    ;  ;   ;  ;    ;       ;;;;  ;   ;  ;   ;  ;     ;   ;  ;   ;  ;   ;  ;
+;    ;  ;   ;  ;    ;  ;    ;  ;   ;  ;    ;       ;     ;   ;  ;   ;  ;     ;   ;  ;   ;  ;   ;   ;;
+;    ;  ;   ;  ;    ;  ;    ;  ;   ;  ;    ;       ;     ;   ;  ;   ;  ;     ;   ;  ;   ;  ;   ;     ;
+; ;  ;  ;  ;;  ;;   ;  ;;   ;  ;   ;  ;    ;       ;     ;  ;;  ;   ;  ;     ;   ;  ;   ;  ;   ;     ;
+;  ;;    ;; ;  ; ;;;   ; ;;;    ;;;   ;     ;;     ;      ;; ;  ;   ;   ;;;   ;; ;   ;;;   ;   ;  ;;;
+;              ;       ;
+;              ;       ;                                                                               
+; 
+  ; wrap-struct-form
+
+;  (define (wrap-struct-form names annotated)
+;    (let* ([arg-temps (build-list (length names) get-arg-var)]
+;           [struct-proc-names (cdr names)]
+;           [closure-records (map (lambda (proc-name) (make-closure-record
+;                                                      proc-name 
+;                                                      (lambda () #f)
+;                                                      (eq? proc-name (car struct-proc-names))
+;                                                      #f))
+;                                 struct-proc-names)]
+;           [proc-arg-temp-syms (cdr arg-temp-syms)]
+;           [setters (map (lambda (arg-temp-sym closure-record)
+;                           `(,closure-table-put! ,arg-temp-sym ,closure-record))
+;                         proc-arg-temp-syms
+;                         closure-records)]
+;           [full-body (append setters (list `(values ,@arg-temp-syms)))])
+;      `(#%let-values ((,arg-temp-syms ,annotated)) ,@full-body)))
+
+  
+  ;;;;;;;;;;
+  ;;
+  ;; collapse-let-values: for the purposes of the annotater, it's easier to simply collapse let's and
+  ;;  let*'s into one big let*.  The lexical-binding information attached to each variable reference
+  ;;  guarantees that this won't affect correctness
+  ;;
+  ;;;;;;;;;;
+
+  ;; uh... apparently this isn't used.  2005-01-15, JBC
+  
+  #;(define (collapse-let-values stx)
+    (syntax-case stx (let-values let*-values)
+      [(_ (outer-binding ...) (let-values (inner-binding ...) . bodies))
+       (collapse-let-values (syntax/loc stx (let*-values (outer-binding ... inner-binding ...) . bodies)))]
+      [else stx]))
+
+  ; test exprs:
+  ;  (andmap (lambda (arg-list)
+  ;            (let* ([stx (car arg-list)]
+  ;                   [elaborated (cadr arg-list)]
+  ;                   [eval-result (caddr arg-list)]
+  ;                   [collapsed (collapse-let-values (expand stx))])
+  ;              (printf "~a~n~a~n~a~n~a~n" (syntax-object->datum collapsed)
+  ;                      elaborated
+  ;                      (eval collapsed)
+  ;                      eval-result)
+  ;              (and (equal? (syntax-object->datum collapsed) elaborated)
+  ;                   (equal? (eval collapsed) eval-result))))
+  ;          (list (list #'(let ([a 3] [b 9]) (+ a b)) '(let-values ([(a) (#%datum . 3)] [(b) (#%datum . 9)]) (#%app (#%top . +) a b)) 12)
+  ;                (list #'(let* ([a 9] [b a] [c b]) c) '(let*-values ([(a) (#%datum . 9)] [(b) a] [(c) b]) c) 9)
+  ;                (list #'(let ([a 3] [b 9]) (let ([b 14]) b)) '(let*-values ([(a) (#%datum . 3)] [(b) (#%datum . 9)] [(b) (#%datum . 14)]) b) 14)))
+;
+;  ;                         ;                      ;                                ;            
+;  ;                         ;                      ;                                   ;         
+; ;;;;  ;;;   ; ;;;          ;   ;;;  ;   ;   ;;;   ;      ; ;;  ;;;  ;   ;   ; ; ;; ; ;;;;  ;;;  
+;  ;   ;   ;  ;;   ;         ;  ;   ; ;   ;  ;   ;  ;      ;;   ;   ; ;   ;   ; ;;   ;  ;   ;   ; 
+;  ;   ;   ;  ;    ;         ;  ;   ;  ; ;   ;   ;  ;      ;    ;   ;  ; ; ; ;  ;    ;  ;   ;   ; 
+;  ;   ;   ;  ;    ;  ;;;;;  ;  ;;;;;  ; ;   ;;;;;  ;      ;    ;;;;;  ; ; ; ;  ;    ;  ;   ;;;;; 
+;  ;   ;   ;  ;    ;         ;  ;      ; ;   ;      ;      ;    ;      ; ; ; ;  ;    ;  ;   ;     
+;  ;   ;   ;  ;;   ;         ;  ;      ;;    ;      ;      ;    ;      ; ; ; ;  ;    ;  ;   ;     
+;   ;;  ;;;   ; ;;;          ;   ;;;;   ;     ;;;;  ;      ;     ;;;;   ;   ;   ;    ;   ;;  ;;;; 
+;             ;                                                                                   
+;             ;                                                                                   
+;                                                                                                 
+
+  
+  ; top-level-rewrite : (SYNTAX-OBJECT -> SYNTAX-OBJECT)
+  
+  ; top-level-rewrite performs several tasks; it labels variables with their types (let-bound, lambda-bound, or non-lexical),
+  ; it flags if's which could come from cond's, it labels the begins in conds with 'stepper-skip annotations
+  
+  ; label-var-types returns a syntax object which is identical to the original except that the variable references are labeled
+  ; with the syntax-property 'stepper-binding-type, which is set to either let-bound, lambda-bound, or non-lexical.
+  
+  (define (top-level-rewrite stx)
+    (let loop ([stx stx]
+               [let-bound-bindings null]
+               [cond-test (lx #f)])
+      (if (or (syntax-property stx 'stepper-skip-completely)
+              (syntax-property stx 'stepper-define-struct-hint))
+          stx
+          (let* ([recur-regular 
+                  (lambda (stx)
+                    (loop stx let-bound-bindings (lx #f)))]
+                 [recur-with-bindings
+                  (lambda (exp vars)
+                    (loop exp (append vars let-bound-bindings) (lx #f)))]
+                 [recur-in-cond
+                  (lambda (stx new-cond-test)
+                    (loop stx let-bound-bindings new-cond-test))]
+                 [do-let/rec
+                  (lambda (stx rec?)
+                    (with-syntax ([(label ((vars rhs) ...) . bodies) stx])
+                      (let* ([vars-list (apply append (map syntax->list (syntax->list (syntax (vars ...)))))]
+                             [labelled-vars-list (map (lambda (var-list) (map (lambda (exp) (recur-with-bindings exp vars-list))
+                                                                              (syntax->list var-list)))
+                                                      (syntax->list (syntax (vars ...))))]
+                             [rhs-list (if rec?
+                                           (map (lambda (exp) (recur-with-bindings exp vars-list)) (syntax->list #'(rhs ...)))
+                                           (map recur-regular (syntax->list #'(rhs ...))))]
+                             [new-bodies (map (lambda (exp) (recur-with-bindings exp vars-list)) (syntax->list #'bodies))]
+                             [new-bindings (map list labelled-vars-list rhs-list)])
+                        (datum->syntax-object stx `(,#'label ,new-bindings ,@new-bodies) stx stx))))]
+
+                 ; evaluated at runtime, using 3D code:
+                 [put-into-xml-table (lambda (val)
+                                     (hash-table-put! finished-xml-box-table val #t)
+                                     val)]
+                 
+                 
+                 [rewritten
+                  (kernel:kernel-syntax-case stx #f
+                    
+                    ; cond :
+                    [(if test (begin then) else-stx)
+                     (let ([origin (syntax-property stx 'origin)]
+                           [rebuild-if
+                            (lambda (new-cond-test)
+                              (let* ([new-then (recur-regular (syntax then))]
+                                     [rebuilt (syntax-property
+                                               (rebuild-stx `(if ,(recur-regular (syntax test))
+                                                                 ,new-then
+                                                                 ,(recur-in-cond (syntax else-stx) new-cond-test))
+                                                            stx)
+                                               'stepper-hint
+                                               'comes-from-cond)])
+                                ; move the stepper-else mark to the if, if it's present:
+                                (if (syntax-property (syntax test) 'stepper-else)
+                                    (syntax-property rebuilt 'stepper-else #t)
+                                    rebuilt)))])
+                       (cond [(cond-test stx) ; continuing an existing 'cond'
+                              (rebuild-if cond-test)]
+                             [(and origin (pair? origin) (eq? (syntax-e (car origin)) 'cond)) ; starting a new 'cond'
+                              (rebuild-if (lambda (test-stx) 
+                                            (and (eq? (syntax-source stx) (syntax-source test-stx))
+                                                 (eq? (syntax-position stx) (syntax-position test-stx)))))]
+                             [else ; not from a 'cond' at all.
+                              (rebuild-stx `(if ,@(map recur-regular (list (syntax test) (syntax (begin then)) (syntax else-stx)))) stx)]))]
+                    [(begin body) ; else clauses of conds; ALWAYS AN ERROR CALL
+                     (cond-test stx)
+                     (syntax-property stx 'stepper-skip-completely #t)]
+                    
+                    ; wrapper on a local.  This is necessary because teach.ss expands local into a trivial let wrapping a bunch of
+                    ;  internal defines, and therefore the letrec-values on which I want to hang the 'stepper-hint doesn't yet
+                    ;  exist.  So we patch it up after expansion.  And we discard the outer 'let' at the same time.
+                    [(let-values () expansion-of-local)
+                     (eq? (syntax-property stx 'stepper-hint) 'comes-from-local)
+                     (syntax-case #`expansion-of-local (letrec-values)
+                       [(letrec-values (bogus-clause clause ...) . bodies)
+                        (recur-regular
+                         (syntax-property #`(letrec-values (clause ...) . bodies) 'stepper-hint 'comes-from-local))]
+                       [else (error 'top-level-rewrite "expected a letrec-values inside a local, given: ~e" 
+                                    (syntax-object->datum #`expansion-of-local))])]
+                    
+                    ; let/letrec :
+                    [(let-values x ...) (do-let/rec stx #f)]
+                    [(letrec-values x ...) (do-let/rec stx #t)]
+                    [var
+                     (identifier? (syntax var))
+                     (syntax-property 
+                      (syntax var) 
+                      'stepper-binding-type
+                      (if (eq? (identifier-binding (syntax var)) 'lexical)
+                          (cond [(ormap (lx (bound-identifier=? _ (syntax var))) let-bound-bindings)
+                                 'let-bound]
+                                [else
+                                 'lambda-bound])
+                          'non-lexical))]
+                    
+                    [else
+                     (let ([content (syntax-e stx)])
+                       (if (pair? content)
+                           (rebuild-stx (syntax-pair-map content recur-regular) stx)
+                           stx))])])
+            
+            (if (eq? (syntax-property stx 'stepper-xml-hint) 'from-xml-box)
+                (syntax-property #`(#,put-into-xml-table #,rewritten) 
+                                 'stepper-skipto
+                                 (list syntax-e cdr car))
+                (syntax-recertify rewritten stx (current-code-inspector) #f))))))
+  
+                                                 
+   ;                                               
+  ; ;                         ;          ;         
+  ; ;    ; ;;   ; ;;    ;;;  ;;;;  ;;;  ;;;;  ;;;  
+  ; ;    ;;  ;  ;;  ;  ;   ;  ;   ;   ;  ;   ;   ; 
+ ;   ;   ;   ;  ;   ;  ;   ;  ;       ;  ;   ;   ; 
+ ;;;;;   ;   ;  ;   ;  ;   ;  ;    ;;;;  ;   ;;;;; 
+ ;   ;   ;   ;  ;   ;  ;   ;  ;   ;   ;  ;   ;     
+;     ;  ;   ;  ;   ;  ;   ;  ;   ;   ;  ;   ;     
+;     ;  ;   ;  ;   ;   ;;;    ;;  ;;;;;  ;;  ;;;; 
+                                                   
+                                                   
+                                                   
+  
+;  oh-say-can-you-see,by-the-dawn's-early-light,what-so-proudly-we-hailed,at-the-twilight's-last-gle
+;  a m i n g . W h o s e b r o a d s t r i                                                         p
+;  pe s a n d b r i g h t s t a r s , t hrough-the-perilous-night,o'er-the-ramparts-we-watched,were-
+;  s o g a l l a n t l y s t r e a m i n g                                                         .
+;  an d t h e r o c k e t ' s r e d g l are,the-bombs-bursting-in-air,gave-proof-through-the-night,,
+;  t h a t o u r f l a g w a s s t i l l t                                                         h
+;  er e . O h s a y , d o e s t h a t s tar-spangled-banner-yet-wave,o'er-the-land-of-the-free,and-t
+;  h e h o m e o f t h e b r a v e ? . . .                                                         .
+;  .. . . . . . . . . . . . . . . . . . ............................................................
+;  . . . . . . . . . . . . . . . . . . . .                                                         .
+;  .................................................................................................
+;  .                                                                                               .
+;  .................................................................................................
+;  .                                                                                               .
+;  .................................................................................................
+;  .                                                                                               .
+;  .................................................................................................
+;  .                                                                                               .
+;  .................................................................................................
+;  .                                                                                               .
+;  .................................................................................................
+;  .                                                                                               .
+;  .................................................................................................
+;  .                                                                                               .
+;  .................................................................................................
+;
+  
+  
+  ; annotate takes 
+  ; a) a list of syntax expressions
+  ; b) a break routine to be called at breakpoints, and
+  ; c) a boolean indicating whether to store inferred names.
+  ;
+  
+  (define (annotate expr break track-inferred-names?)
+
+    (define binding-indexer
+      (let ([binding-index 0])
+        (lambda ()
+          (let ([temp binding-index])
+            (set! binding-index (+ binding-index 1))
+            temp))))
+    
+    (define (normal-break)
+      (break (current-continuation-marks) 'normal-break))
+    
+    (define (result-exp-break)
+      (break (current-continuation-marks) 'result-exp-break))
+    
+    (define (result-value-break vals-list)
+      (break (current-continuation-marks) 'result-value-break vals-list))
+    
+    (define (expr-finished-break vals-list)
+      (break (current-continuation-marks) 'expr-finished-break vals-list))
+    
+    (define (double-break)
+      (break (current-continuation-marks) 'double-break))
+    
+    (define (late-let-break . interlaced-info)
+      (break (current-continuation-marks) 'late-let-break interlaced-info))
+    
+    ; here are the possible configurations of wcm's, pre-breaks, and breaks (not including late-let & double-breaks):
+    
+    ; (for full-on stepper)
+    ; wcm, result-break, normal-break
+    ; wcm, normal-break
+    
+    ; wcm-pre-break-wrap : call wcm-wrap with a pre-break on the expr
+    (define (wcm-pre-break-wrap debug-info expr)
+      (wcm-wrap debug-info #`(begin (#,result-exp-break) #,expr)))
+    
+    (define (break-wrap expr)
+      #`(begin (#,normal-break) #,expr))
+    
+    (define (double-break-wrap expr)
+      #`(begin (#,double-break) #,expr))
+    
+    (define (late-let-break-wrap var-names lifted-gensyms expr)
+      (let* ([interlaced (apply append (map list var-names lifted-gensyms))])
+        #`(begin (#,late-let-break #,@interlaced) #,expr)))
+    
+    (define (return-value-wrap expr)
+      #`(call-with-values
+         (lambda () #,expr)
+         (lambda args
+           (#,result-value-break args)
+           (apply values args))))
+    
+    (define (expr-finished-break-wrap expr)
+      #`(call-with-values
+         (lambda () #,expr)
+         (lambda args (#,expr-finished-break args) (apply values args))))
+    
+    (define (make-define-struct-break expr)
+      (lambda ()
+        (break #f 'define-struct-break (list expr))))
+        
+    (define (top-level-annotate/inner expr source-expr defined-name)
+      (let*-2vals ([(annotated dont-care)
+                    (annotate/inner expr 'all #f defined-name)]
+                   [top-level-wrapped #`(with-continuation-mark #,debug-key 
+                                                                #,(make-top-level-mark source-expr)
+                                                                #,(expr-finished-break-wrap annotated))])
+        top-level-wrapped))
+    
+    
+    
+    ; annotate/inner takes 
+    ; a) an expression to annotate
+    ; b) a list of all bindings which this expression is tail w.r.t. 
+    ;    or 'all to indicate that this expression is tail w.r.t. _all_ bindings.
+    ; d) a boolean indicating whether this expression will be the r.h.s. of a reduction
+    ;    (and therefore should be broken before)
+    ; g) information about the binding name of the given expression.  This is used 
+    ;    to associate a name with a closure mark (though this may now be redundant)
+    
+    ; it returns (as a 2vals)
+    ; a) an annotated s-expression
+    ; b) a list of varrefs for the variables which occur free in the expression
+    ;
+    ;(syntax-object BINDING-SET bool bool (union #f symbol (list binding symbol)) -> 
+    ;          sexp (list-of z:varref))
+    
+    
+    
+    
+    
+                                                         ;  ;                           
+                                ;          ;             ;                              
+     ;;;   ; ;;   ; ;;    ;;;  ;;;;  ;;;  ;;;;  ;;;     ;   ;  ; ;;   ; ;;    ;;;   ; ;;
+    ;   ;  ;;  ;  ;;  ;  ;   ;  ;   ;   ;  ;   ;   ;    ;   ;  ;;  ;  ;;  ;  ;   ;  ;;  
+        ;  ;   ;  ;   ;  ;   ;  ;       ;  ;   ;   ;    ;   ;  ;   ;  ;   ;  ;   ;  ;   
+     ;;;;  ;   ;  ;   ;  ;   ;  ;    ;;;;  ;   ;;;;;   ;    ;  ;   ;  ;   ;  ;;;;;  ;   
+    ;   ;  ;   ;  ;   ;  ;   ;  ;   ;   ;  ;   ;       ;    ;  ;   ;  ;   ;  ;      ;   
+    ;   ;  ;   ;  ;   ;  ;   ;  ;   ;   ;  ;   ;       ;    ;  ;   ;  ;   ;  ;      ;   
+     ;;;;; ;   ;  ;   ;   ;;;    ;;  ;;;;;  ;;  ;;;;   ;    ;  ;   ;  ;   ;   ;;;;  ;   
+                                                      ;                                 
+                                                      ;                                 
+    
+    (define annotate/inner
+      ;(-> syntax? binding-set? boolean? (union false/c syntax? (list/p syntax? syntax?)) (vector/p syntax? binding-set?))
+      (lambda (expr tail-bound pre-break? procedure-name-info)
+        
+        (cond [(syntax-property expr 'stepper-skipto)                
+               (let* ([free-vars-captured #f] ; this will be set!'ed
+                      ;[dont-care (printf "expr: ~a\nskipto: ~a\n" expr (syntax-property expr 'stepper-skipto))]
+                      ; WARNING! I depend on the order of evaluation in application arguments here:
+                      [annotated (skipto-annotate
+                                  (syntax-property expr 'stepper-skipto) 
+                                  expr 
+                                  (lambda (subterm)
+                                    (let*-2vals ([(stx free-vars) (annotate/inner subterm tail-bound pre-break? procedure-name-info)])
+                                      (set! free-vars-captured free-vars)
+                                      stx)))])
+                 (2vals (wcm-wrap
+                         skipto-mark
+                         annotated)
+                        free-vars-captured))]
+
+              [(syntax-property expr 'stepper-skip-completely)
+               (2vals (wcm-wrap 13 expr) null)]
+
+              [else
+               (let* ([tail-recur (lambda (expr) (annotate/inner expr tail-bound #t procedure-name-info))]
+                      [non-tail-recur (lambda (expr) (annotate/inner expr null #f #f))]
+                      [result-recur (lambda (expr) (annotate/inner expr null #f procedure-name-info))]
+                      [set!-rhs-recur (lambda (expr name) (annotate/inner expr null #f name))]
+                      [let-rhs-recur (lambda (expr binding-names dyn-index-syms)
+                                       (let* ([proc-name-info 
+                                               (if (not (null? binding-names))
+                                                   (list (car binding-names) (car dyn-index-syms))
+                                                   #f)])
+                                         (annotate/inner expr null #f proc-name-info)))]
+                      [lambda-body-recur (lambda (expr) (annotate/inner expr 'all #t #f))]
+                      ; note: no pre-break for the body of a let; it's handled by the break for the
+                      ; let itself.
+                      [let-body-recur (lambda (bindings)
+                                        (lambda (expr) 
+                                          (annotate/inner expr (binding-set-union (list tail-bound bindings)) #f procedure-name-info)))]
+                      [make-debug-info-normal (lambda (free-bindings)
+                                                (make-debug-info expr tail-bound free-bindings 'none #t))]
+                      [make-debug-info-app (lambda (tail-bound free-bindings label)
+                                             (make-debug-info expr tail-bound free-bindings label #t))]
+                      [make-debug-info-let (lambda (free-bindings binding-list let-counter)
+                                             (make-debug-info expr 
+                                                              (binding-set-union (list tail-bound 
+                                                                                       binding-list
+                                                                                       (list let-counter)))
+                                                              (varref-set-union (list free-bindings 
+                                                                                      binding-list
+                                                                                      (list let-counter))) ; NB using bindings as varrefs
+                                                              'let-body
+                                                              #t))]
+                      [outer-wcm-wrap (if pre-break?
+                                          wcm-pre-break-wrap
+                                          wcm-wrap)]
+                      [wcm-break-wrap (lambda (debug-info expr)
+                                        (outer-wcm-wrap debug-info (break-wrap expr)))]
+                      
+                      [normal-bundle
+                       (lambda (free-vars annotated)
+                         (2vals (outer-wcm-wrap (make-debug-info-normal free-vars)
+                                                annotated)
+                                free-vars))]
+                      
+                      [lambda-clause-abstraction
+                       (lambda (clause)
+                         (with-syntax ([(args-stx . bodies) clause])
+                           (let*-2vals ([(annotated-body free-varrefs)
+                                         ; wrap bodies in explicit begin if more than 1 user-introduced (non-skipped) bodies
+                                         ; NB: CAN'T HAPPEN in beginner up through int/lambda
+                                         (if (> (length (filter (lambda (clause)
+                                                                  (not (syntax-property clause 'stepper-skip-completely)))
+                                                                (syntax->list (syntax bodies)))) 1)
+                                             (lambda-body-recur (syntax (begin . bodies)))
+                                             (let*-2vals ([(annotated-bodies free-var-sets)
+                                                           (2vals-map lambda-body-recur (syntax->list #`bodies))])
+                                               (2vals #`(begin . #,annotated-bodies) (varref-set-union free-var-sets))))]
+                                        [new-free-varrefs (varref-set-remove-bindings free-varrefs
+                                                                                      (arglist-flatten #'args-stx))])
+                             (2vals (datum->syntax-object #'here `(,#'args-stx ,annotated-body) #'clause) new-free-varrefs))))]
+                      
+                      [outer-lambda-abstraction
+                       (lambda (annotated-lambda free-varrefs)
+                         (let*-2vals
+                             ([closure-info (make-debug-info-app 'all free-varrefs 'none)]
+                              [closure-name (if track-inferred-names?
+                                                (cond [(syntax? procedure-name-info) procedure-name-info]
+                                                      [(pair? procedure-name-info) (car procedure-name-info)]
+                                                      [else #f])
+                                                #f)]
+                              [closure-storing-proc
+                               (opt-lambda (closure debug-info [lifted-index #f])
+                                 (closure-table-put! closure (make-closure-record 
+                                                              closure-name
+                                                              debug-info
+                                                              #f
+                                                              lifted-index))
+                                 closure)]
+                              [inferred-name-lambda
+                               (if closure-name
+                                   (syntax-property annotated-lambda 'inferred-name (syntax-e closure-name))
+                                   annotated-lambda)]
+                              [captured
+                               (cond [(pair? procedure-name-info)
+                                      #`(#,closure-storing-proc #,inferred-name-lambda #,closure-info 
+                                          #,(cadr procedure-name-info))]
+                                     [else
+                                      #`(#,closure-storing-proc #,inferred-name-lambda #,closure-info)])])
+                           
+                           (normal-bundle free-varrefs captured)))]
+                      
+                      ; The let transformation is complicated.
+                      ; here's a sample transformation (not including 'break's):
+                      ;(let-values ([(a b c) e1] [(d e) e2]) e3)
+                      ;
+                      ;turns into
+                      ;
+                      ;(let ([counter (<dynamic-counter-call>)])
+                      ;(let-values ([(a b c d e lifter-a-1 lifter-b-2 lifter-c-3 lifter-d-4 lifter-e-5 let-counter)
+                      ;              (values *unevaluated* *unevaluated* *unevaluated* *unevaluated* *unevaluated*
+                      ;                      counter counter counter counter counter 0)])
+                      ;  (with-continuation-mark 
+                      ;   key huge-value
+                      ;   (begin
+                      ;     (set!-values (a b c) e1)
+                      ;     (set! let-counter 1)
+                      ;     (set!-values (d e) e2)
+                      ;     (set! let-counter 2)
+                      ;     e3))))
+                      ;
+                      ; note that this elaboration looks exactly like the one for letrec, and that's
+                      ; okay, becuase expand guarantees that reordering them will not cause capture.
+                      ; this is because a bound variable answers is considered bound by a binding only when
+                      ; the pair answers true to bound-identifier=?, which is determined during (the first)
+                      ; expand.
+                      
+                      ; another irritating point: the mark and the break that must go immediately 
+                      ; around the body.  Irritating because they will be instantly replaced by
+                      ; the mark and the break produced by the annotated body itself. However, 
+                      ; they're necessary, because the body may not contain free references to 
+                      ; all of the variables defined in the let, and thus their values are not 
+                      ; known otherwise.  
+                      ; whoops! hold the phone.  I think I can get away with a break before, and
+                      ; a mark after, so only one of each.  groovy, eh?
+                      
+                      [let-abstraction
+                       (lambda (stx output-identifier make-init-list)
+                         (with-syntax ([(_ ([(var ...) val] ...) . bodies) stx])
+                           (let*-2vals
+                               ([binding-sets (map syntax->list (syntax->list #'((var ...) ...)))]
+                                [binding-list (apply append binding-sets)]
+                                [vals (syntax->list #'(val ...))]
+                                [lifted-var-sets (map (lx (map get-lifted-var _)) binding-sets)]
+                                [lifted-vars (apply append lifted-var-sets)]
+                                [(annotated-vals free-varref-sets-vals)
+                                 (2vals-map let-rhs-recur vals binding-sets lifted-var-sets)]
+                                [(annotated-body free-varrefs-body)
+                                 ((let-body-recur binding-list) 
+                                  (if (= (length (syntax->list (syntax bodies))) 1)
+                                      (car (syntax->list (syntax bodies)))
+                                      (syntax (begin . bodies))))]
+                                [free-varrefs (varref-set-remove-bindings 
+                                               (varref-set-union (cons free-varrefs-body
+                                                                       free-varref-sets-vals)) 
+                                               binding-list)])
+                             
+                             
+                             (let* ([counter-id #`lifting-counter]
+                                    [unevaluated-list (make-init-list binding-list)]
+                                    [outer-initialization
+                                     #`([(#,@lifted-vars #,@binding-list #,let-counter)
+                                         (values #,@(append (map (lambda (dc_binding) counter-id)
+                                                                 binding-list)
+                                                            unevaluated-list
+                                                            (list 0)))])]
+                                    [counter-clauses (build-list 
+                                                      (length binding-sets)
+                                                      (lambda (num)
+                                                        #`(set! #,let-counter #,(+ num 1))))]
+                                    [set!-clauses
+                                     (map (lambda (binding-set val)
+                                            #`(set!-values #,binding-set #,val))
+                                          binding-sets
+                                          annotated-vals)] 
+                                    ; time to work from the inside out again
+                                    ; without renaming, this would all be much much simpler.
+                                    [wrapped-begin (outer-wcm-wrap (make-debug-info-let free-varrefs
+                                                                                        binding-list
+                                                                                        let-counter) 
+                                                                   (double-break-wrap
+                                                                    #`(begin #,@(apply append (zip set!-clauses counter-clauses)) 
+                                                                             #,(late-let-break-wrap binding-list
+                                                                                                    lifted-vars
+                                                                                                    annotated-body))))])
+                               (2vals (quasisyntax/loc 
+                                       expr 
+                                       (let ([#,counter-id (#,binding-indexer)])
+                                         (#,output-identifier #,outer-initialization #,wrapped-begin))) 
+                                      free-varrefs)))))]
+                      
+                      ; if-abstraction: (-> syntax? syntax? (union false/c syntax?) (values syntax? varref-set?))
+                      [if-abstraction
+                       (lambda (test then else) 
+                         (let*-2vals
+                             ([(annotated-test free-varrefs-test) 
+                               (non-tail-recur test)]
+                              [(annotated-then free-varrefs-then) 
+                               (tail-recur then)]
+                              [(annotated-else free-varrefs-else)
+                               (if else
+                                   (tail-recur else)
+                                   (2vals #f null))]
+                              [free-varrefs (varref-set-union (list free-varrefs-test 
+                                                                    free-varrefs-then 
+                                                                    free-varrefs-else))]
+                              [annotated-if 
+                               #`(begin (set! #,if-temp #,annotated-test) 
+                                        (#,normal-break)
+                                        #,(if else
+                                              (quasisyntax/loc expr (if #,if-temp #,annotated-then #,annotated-else))
+                                              (quasisyntax/loc expr (if #,if-temp #,annotated-then))))]
+                              [wrapped (outer-wcm-wrap (make-debug-info-app (binding-set-union (list tail-bound (list if-temp)))
+                                                                            (varref-set-union (list free-varrefs (list if-temp)))
+                                                                            'none)
+                                                       annotated-if)])
+                           (2vals
+                            (with-syntax ([test-var if-temp]
+                                          [wrapped-stx wrapped]
+                                          [unevaluated-stx *unevaluated*])
+                              (syntax/loc expr (let ([test-var unevaluated-stx]) wrapped-stx)))
+                            free-varrefs)))]
+                      
+                      [varref-abstraction
+                       (lambda (var)
+                         (let*-2vals ([free-varrefs (list var)]
+                                      [varref-break-wrap
+                                       (lambda ()
+                                         (wcm-break-wrap (make-debug-info-normal free-varrefs)
+                                                         (return-value-wrap var)))]
+                                      [varref-no-break-wrap
+                                       (lambda ()
+                                         (outer-wcm-wrap (make-debug-info-normal free-varrefs) var))]
+                                      [top-level-varref-break-wrap
+                                       (lambda ()
+                                         (if (memq (syntax-e var) beginner-defined:must-reduce)
+                                             (varref-break-wrap)
+                                             (varref-no-break-wrap)))])
+                           (2vals 
+                            (case (syntax-property var 'stepper-binding-type)
+                              ((lambda-bound macro-bound)   (varref-no-break-wrap))
+                              ((let-bound)                  (varref-break-wrap))
+                              ((non-lexical) ;; is it from this module or not?
+                               (match (identifier-binding var)                                 
+                                 (#f (top-level-varref-break-wrap))
+                                 [`(,path-index-or-symbol ,dc1 ,dc2 ,dc3 ,dc4)
+                                   (if (module-path-index? path-index-or-symbol)
+                                       (let-values ([(module-path dc5) (module-path-index-split path-index-or-symbol)])
+                                         (if module-path 
+                                             ;; not a module-local variable:
+                                             (top-level-varref-break-wrap)
+                                             ;; a module-local-variable:
+                                             (varref-break-wrap)))
+                                       (top-level-varref-break-wrap))]
+                                 [else (error 'annotate "unexpected value for identifier-binding: ~v" identifier-binding)])))
+                            free-varrefs)))]
+                      
+                      [recertifier
+                       (lambda (vals)
+                         (let*-2vals ([(new-expr bindings) vals])
+                           (2vals (syntax-recertify new-expr expr (current-code-inspector) #f)
+                                  bindings)))]
+                      
+                      )
+                 ; find the source expression and associate it with the parsed expression
+                 ;             (when (and red-exprs foot-wrap?)
+                 ;               (set-expr-read! expr (find-read-expr expr)))
+
+                 
+                 (recertifier
+                  (kernel:kernel-syntax-case expr #f
+
+                  [(lambda . clause)
+                    (let*-2vals ([(annotated-clause free-varrefs)
+                                  (lambda-clause-abstraction (syntax clause))]
+                                 [annotated-lambda
+                                  (with-syntax ([annotated-clause annotated-clause])
+                                    (syntax/loc expr (lambda . annotated-clause)))])
+                      (outer-lambda-abstraction annotated-lambda free-varrefs))]
+                   
+                   [(case-lambda . clauses)
+                    (let*-2vals ([(annotated-cases free-varrefs-cases)
+                                  (2vals-map lambda-clause-abstraction (syntax->list (syntax clauses)))]
+                                 [annotated-case-lambda (with-syntax ([annotated-cases annotated-cases])
+                                                          (syntax/loc expr (case-lambda . annotated-cases)))]
+                                 [free-varrefs (varref-set-union free-varrefs-cases)])
+                      (outer-lambda-abstraction annotated-case-lambda free-varrefs))]
+                   
+                   
+                   
+                   [(if test then else) (if-abstraction (syntax test) (syntax then) (syntax else))]
+                   [(if test then) (if-abstraction (syntax test) (syntax then) #f)]
+                   
+                   [(begin . bodies-stx)
+                    (if (null? (syntax->list (syntax bodies-stx)))
+                        (normal-bundle null expr)
+                        (let*-2vals 
+                            ([reversed-bodies (reverse (syntax->list (syntax bodies-stx)))]
+                             [last-body (car reversed-bodies)]
+                             [all-but-last (reverse (cdr reversed-bodies))]
+                             [(annotated-a free-varrefs-a)
+                              (2vals-map non-tail-recur all-but-last)]
+                             [(annotated-final free-varrefs-final)
+                              (tail-recur last-body)])
+                          (normal-bundle (varref-set-union (cons free-varrefs-final free-varrefs-a))
+                                         (quasisyntax/loc expr (begin #,@annotated-a #,annotated-final)))))]
+                   
+                   [(begin0 . bodies-stx)
+                    (let*-2vals
+                        ([bodies (syntax->list (syntax bodies-stx))]
+                         [(annotated-first free-varrefs-first)
+                          (result-recur (car bodies))]
+                         [(annotated-bodies free-varref-sets)
+                          (2vals-map non-tail-recur (cdr bodies))])
+                      (normal-bundle (varref-set-union (cons free-varrefs-first free-varref-sets))
+                                     (quasisyntax/loc expr (begin0 #,annotated-first #,@annotated-bodies))))]
+                   
+                   [(let-values . _)
+                    (let-abstraction expr 
+                                     #`let-values
+                                     (lambda (bindings)
+                                       (map (lambda (_) *unevaluated*) bindings)))]
+                   
+                   [(letrec-values . _)
+                    (let-abstraction expr 
+                                     #`letrec-values
+                                     (lambda (bindings) (map (lambda (b) #`#,b) bindings)))]
+                   
+                   [(set! var val)
+                    (let*-2vals
+                        ([(annotated-val val-free-varrefs)
+                          (set!-rhs-recur (syntax val) (syntax-case (syntax var) (#%top)
+                                                         [(#%top . real-var) (syntax-e (syntax real-var))]
+                                                         [else (syntax var)]))])
+                      (normal-bundle (varref-set-union (list (list (syntax var)) val-free-varrefs))
+                                     (quasisyntax/loc expr (set! #,(syntax var) #,annotated-val))))]
+                   
+                   
+                   [(quote _)
+                    (normal-bundle null expr)]
+                   
+                   [(quote-syntax _)
+                    (normal-bundle null expr)]
+                   
+                   [(with-continuation-mark key mark body)
+                    ;(let*-2vals ([(annotated-key free-varrefs-key)
+                    ;              (non-tail-recur (syntax key))]
+                    ;             [(annotated-mark free-varrefs-mark)
+                    ;              (non-tail-recur (syntax mark))]
+                    ;             [(annotated-body dc_free-varrefs-body)
+                    ;              (result-recur (syntax body))])
+                    (error 'annotate/inner "this region of code is still under construction")
+                    
+                    ;                                       [annotated #`(let-values ([key-temp #,*unevaluated*]
+                    ;                                             [mark-temp #,*unevaluated*]
+                    ;)
+                    ]
+                   
+                   ;                                  [foot-wrap? 
+                   ;                                   (wcm-wrap debug-info annotated)])
+                   ;                           free-bindings))]
+                   
+                   ; the app form's elaboration looks like this, where M0 etc. stand for expressions, and t0 etc
+                   ; are temp identifiers that do not occur in the program:
+                   ; (M0 ...)
+                   ;
+                   ; goes to
+                   ;
+                   ;(let ([t0 *unevaluated*]
+                   ;      ...)
+                   ;  (with-continuation-mark
+                   ;   debug-key
+                   ;   huge-value
+                   ;   (set! t0 M0)
+                   ;   ...
+                   ;   (with-continuation-mark
+                   ;    debug-key
+                   ;    much-smaller-value
+                   ;    (t0 ...))))
+                   ; 
+                   ; 'break's are not illustrated.  An optimization is possible when all expressions M0 ... are
+                   ; varrefs.  In particular (where v0 ... are varrefs):
+                   ; (v0 ...)
+                   ;
+                   ; goes to
+                   ; 
+                   ; (with-continuation-mark
+                   ;  debug-key
+                   ;  debug-value
+                   ;  (v0 ...))
+                   ;
+                   ; in other words, no real elaboration occurs. Note that this doesn't work as-is for the
+                   ; stepper, because there's nowhere to hang the breakpoint; you want to see the break
+                   ; occur after all vars have been evaluated.  I suppose you could do (wcm ... (begin v0 ... (v0 ...)))
+                   ; where the second set are not annotated ... but stepper runtime is not at a premium.
+                   
+                   [(#%app . terms)
+                    (let*-2vals
+                        ([(annotated-terms free-varrefs-terms)
+                          (2vals-map non-tail-recur (syntax->list (syntax terms)))]
+                         [free-varrefs (varref-set-union free-varrefs-terms)])
+                      (2vals
+                       (let* ([arg-temps (build-list (length annotated-terms) get-arg-var)]
+                              [tagged-arg-temps (map (lambda (var) (syntax-property var 'stepper-binding-type 'stepper-temp))
+                                                     arg-temps)]
+                              [let-clauses #`((#,tagged-arg-temps 
+                                               (values #,@(map (lambda (_) *unevaluated*) tagged-arg-temps))))]
+                              [set!-list (map (lambda (arg-symbol annotated-sub-expr)
+                                                #`(set! #,arg-symbol #,annotated-sub-expr))
+                                              tagged-arg-temps annotated-terms)]
+                              [new-tail-bound (binding-set-union (list tail-bound tagged-arg-temps))]
+                              [app-debug-info (make-debug-info-app new-tail-bound tagged-arg-temps 'called)]
+                              [app-term (quasisyntax/loc expr #,tagged-arg-temps)]
+                              [debug-info (make-debug-info-app new-tail-bound
+                                                               (varref-set-union (list free-varrefs tagged-arg-temps)) ; NB using bindings as vars
+                                                               'not-yet-called)]
+                              [let-body (outer-wcm-wrap debug-info #`(begin #,@set!-list
+                                                                            #,(break-wrap
+                                                                               (wcm-wrap
+                                                                                app-debug-info
+                                                                                #`(if (#,in-closure-table #,(car tagged-arg-temps))
+                                                                                      #,app-term
+                                                                                      #,(return-value-wrap app-term))))))])
+                         #`(let-values #,let-clauses #,let-body))
+                       ;)
+                       free-varrefs))]   
+                   
+                   [(#%datum . _)
+                    (normal-bundle null expr)]
+                   
+                   [(#%top . var-stx)
+                    (varref-abstraction #`var-stx)]
+                   
+                   [var-stx
+                    (identifier? #`var-stx)
+                    (varref-abstraction #`var-stx)]
+                   
+                   [else 
+                    (error 'annotate "unexpected syntax for expression: ~v" (syntax-object->datum expr))])))])))
+    
+    
+    ;; annotate/top-level : syntax-> syntax
+    ;; expansion of teaching level language programs produces two kinds of 
+    ;; expressions: modules containing all of the code in the def'ns window, and
+    ;; require statements that invoke those modules.  In the first case, we must annotate
+    ;; the expressions inside the top-level module, and in the second, we should just
+    ;; leave it alone.
+    
+    (define/contract annotate/top-level
+      (syntax? . -> . syntax?)
+      (lambda (expr)
+        (syntax-case expr (module #%plain-module-begin let-values dynamic-wind lambda)
+          [(m1 n1 l1
+             (pm1 . bodies))
+           #`(m1 n1 l1 (pm1 #,@(map annotate/module-top-level (syntax->list #`bodies))))]
+          ; the 'require' form is used for the test harness
+          [(require module-name)
+           expr]
+          ; the 'dynamic-require' form is used by the actual expander 
+          [(let-values ([(done-already?) . rest1])
+                (#%app dynamic-wind
+                 void
+                 (lambda () . rest2)
+                 (lambda () . rest3)))
+           expr]
+          [else (error `annotate/top-level "unexpected top-level expression: ~a\n" (syntax-object->datum expr))])))
+    
+    (define/contract annotate/module-top-level
+      (syntax? . -> . syntax?)
+      (lambda (expr)
+        (cond [(syntax-property expr 'stepper-skip-completely) expr]
+              [(syntax-property expr 'stepper-define-struct-hint)
+               #`(begin #,expr
+                        (#,(make-define-struct-break (syntax-property expr 'stepper-define-struct-hint))))]
+              [(syntax-property expr 'stepper-skipto)
+               (skipto-annotate (syntax-property expr 'stepper-skipto) expr annotate/module-top-level)] 
+              [else 
+               (syntax-case expr (#%app call-with-values define-values define-syntaxes require require-for-syntax provide begin lambda)
+                 [(define-values (new-vars ...) e)
+                  (let* ([name-list (syntax->list #`(new-vars ...))]
+                         [defined-name (if (and (pair? name-list) (null? (cdr name-list)))
+                                           (car name-list)
+                                           #f)])
+                    #`(define-values (new-vars ...)
+                        #,(top-level-annotate/inner (top-level-rewrite #`e) expr defined-name)))]
+                 [(define-syntaxes (new-vars ...) e)
+                  expr]
+                 [(require specs ...)
+                  expr]
+                 [(require-for-syntax specs ...)
+                  expr]
+                 [(provide specs ...)
+                  expr]
+                 [(begin .  bodies)
+                  #`(begin #,@(map annotate/module-top-level (syntax->list #`bodies)))]
+                 [(#%app call-with-values (lambda () body) print-values)
+                  #`(#%app call-with-values (lambda () #,(top-level-annotate/inner (top-level-rewrite #`body) expr #f)) print-values)]
+                 [any
+                  (syntax-property expr 'stepper-test-suite-hint)
+                  (top-level-annotate/inner (top-level-rewrite expr) expr #f)]
+                 [else
+                  (top-level-annotate/inner (top-level-rewrite expr) expr #f)
+                  ;; the following check can't be permitted in the presence of things like test-suite cases
+                  ;; which produce arbitrary expressions at the top level.
+                  #;(error `annotate/module-top-level "unexpected module-top-level expression to annotate: ~a\n" (syntax-object->datum expr))])])))
+    
+    ; body of local
+    #;(printf "input: ~a\n" expr)
+    (let* ([annotated-expr (annotate/top-level expr)])
+      #;(printf "annotated: \n~a\n" (syntax-object->datum annotated-expr))
+      annotated-expr)))
diff --git a/collects/stepper/private/beginner-defined.ss b/collects/stepper/private/beginner-defined.ss
new file mode 100644
index 0000000000..8fe4b701af
--- /dev/null
+++ b/collects/stepper/private/beginner-defined.ss
@@ -0,0 +1,5 @@
+(module beginner-defined mzscheme
+  (provide must-reduce)
+  
+  (define must-reduce
+    `(e pi)))
\ No newline at end of file
diff --git a/collects/stepper/private/debugger-annotate.ss b/collects/stepper/private/debugger-annotate.ss
new file mode 100644
index 0000000000..1d2c661fd7
--- /dev/null
+++ b/collects/stepper/private/debugger-annotate.ss
@@ -0,0 +1,181 @@
+(module debugger-annotate mzscheme
+  
+  (require (prefix kernel: (lib "kerncase.ss" "syntax"))
+           "shared.ss"
+           "marks.ss"
+           (lib "contract.ss"))
+  
+  (define count 0)
+  
+  (provide annotate)
+  
+  (define (arglist-bindings arglist-stx)
+    (syntax-case arglist-stx ()
+      [var
+       (identifier? arglist-stx)
+       (list arglist-stx)]
+      [(var ...)
+       (syntax->list arglist-stx)]
+      [(var . others)
+       (cons #'var (arglist-bindings #'others))]))
+  
+  (define (annotate stx breakpoints breakpoint-origin break)
+    
+    (define (top-level-annotate stx)
+      (kernel:kernel-syntax-case stx #f
+        [(module identifier name (#%plain-module-begin . module-level-exprs))
+         (quasisyntax/loc stx (module identifier name
+                                (#%plain-module-begin 
+                                 #,@(map module-level-expr-iterator
+                                         (syntax->list #'module-level-exprs)))))]
+        [else-stx
+         (general-top-level-expr-iterator stx)]))
+    
+    (define (module-level-expr-iterator stx)
+      (kernel:kernel-syntax-case stx #f
+        [(provide . provide-specs)
+         stx]
+        [else-stx
+         (general-top-level-expr-iterator stx)]))
+    
+    (define (general-top-level-expr-iterator stx)
+      (kernel:kernel-syntax-case stx #f
+        [(define-values (var ...) expr)
+         #`(define-values (var ...)
+             #,(annotate #`expr (syntax->list #`(var ...)) #t))]
+        [(define-syntaxes (var ...) expr)
+         stx]
+        [(begin . top-level-exprs)
+         (quasisyntax/loc stx (begin #,@(map (lambda (expr)
+                                               (module-level-expr-iterator expr))
+                                             (syntax->list #'top-level-exprs))))]
+        [(require . require-specs)
+         stx]
+        [(require-for-syntax . require-specs)
+         stx]
+        [else
+         (annotate stx '() #f)]))
+    
+    (define (annotate expr bound-vars is-tail?)
+      
+      (define (let/rec-values-annotator letrec?)
+        (kernel:kernel-syntax-case expr #f
+          [(label (((var ...) rhs) ...) . bodies)
+           (let* ([new-bindings (apply append (map syntax->list (syntax->list #`((var ...) ...))))]
+                  [new-rhs (if letrec?
+                               (map (lambda (expr) (annotate expr (append new-bindings bound-vars) #f))
+                                    (syntax->list #`(rhs ...)))
+                               (map (lambda (expr) (annotate expr bound-vars #f))
+                                    (syntax->list #`(rhs ...))))]
+                  [last-body (car (reverse (syntax->list #`bodies)))]
+                  [all-but-last-body (reverse (cdr (reverse (syntax->list #`bodies))))]
+                  [bodies (append (map (lambda (expr) (annotate expr (append new-bindings bound-vars) #f))
+                                       all-but-last-body)
+                                  (list (annotate last-body (append new-bindings bound-vars) is-tail?)))])
+             (with-syntax ([(new-rhs/trans ...) new-rhs])
+               (quasisyntax/loc expr
+                                (label (((var ...) new-rhs/trans) ...)
+                                       #,@bodies))))]))
+      
+      (define (lambda-clause-annotator clause)
+        (kernel:kernel-syntax-case clause #f
+          [(arg-list . bodies)
+           (let* ([new-bound-vars (append (arglist-bindings #`arg-list) bound-vars)]
+                  [new-bodies (let loop ([bodies (syntax->list #`bodies)])
+                                (if (equal? '() (cdr bodies))
+                                    (list (annotate (car bodies) new-bound-vars #t))
+                                    (cons (annotate (car bodies) new-bound-vars #f)
+                                          (loop (cdr bodies)))))])
+             (quasisyntax/loc clause
+                              (arg-list #,@new-bodies)))]))
+      
+      (define (break-wrap debug-info annotated)
+        #`(begin
+            (#,break (current-continuation-marks) 'debugger-break #,debug-info)
+            #,annotated))
+      
+      (define annotated
+        (kernel:kernel-syntax-case expr #f
+          [var-stx (identifier? (syntax var-stx)) expr]
+        
+	  [(lambda . clause)
+	   (quasisyntax/loc expr 
+			    (lambda #,@(lambda-clause-annotator #`clause)))]
+	  
+	  [(case-lambda . clauses)
+	   (quasisyntax/loc expr
+			    (case-lambda #,@(map lambda-clause-annotator (syntax->list #`clauses))))]
+	  
+	  [(if test then)
+	   (quasisyntax/loc expr (if #,(annotate #`test bound-vars #f)
+				     #,(annotate #`then bound-vars is-tail?)))]
+	  
+	  [(if test then else)
+	   (quasisyntax/loc expr (if #,(annotate #`test bound-vars #f)
+				     #,(annotate #`then bound-vars is-tail?)
+				     #,(annotate #`else bound-vars is-tail?)))]
+        
+	  [(begin . bodies)
+	   (letrec ([traverse
+		     (lambda (lst)
+		       (if (and (pair? lst) (equal? '() (cdr lst)))
+			   `(,(annotate (car lst) bound-vars is-tail?))
+			   (cons (annotate (car lst) bound-vars #f)
+				 (traverse (cdr lst)))))])
+	     (quasisyntax/loc expr (begin #,@(traverse (syntax->list #`bodies)))))]
+	  
+	  [(begin0 . bodies)
+	   (quasisyntax/loc expr (begin0 #,@(map (lambda (expr)
+						   (annotate expr bound-vars #f))
+						 (syntax->list #`bodies))))]
+	  
+	  [(let-values . clause)
+	   (let/rec-values-annotator #f)]
+	  
+	  [(letrec-values . clause) 
+	   (let/rec-values-annotator #t)]
+	  
+	  [(set! var val) 
+	   (quasisyntax/loc expr (set! var #,(annotate #`val bound-vars #f)))]
+	  
+	  [(quote _) expr]
+	  
+	  [(quote-syntax _) expr]
+	  
+	  ;; FIXME: we have to think harder about this
+	  [(with-continuation-mark key mark body)
+	   (quasisyntax/loc expr (with-continuation-mark key
+							 #,(annotate #`mark bound-vars #f)
+							 #,(annotate #`body bound-vars is-tail?)))]
+	  
+	  [(#%app . exprs)
+	   (let ([subexprs (map (lambda (expr) 
+				  (annotate expr bound-vars #f))
+				(syntax->list #`exprs))])
+	     (if is-tail?
+		 (quasisyntax/loc expr #,subexprs)
+		 (wcm-wrap (make-debug-info expr bound-vars bound-vars 'normal #f)
+			   (quasisyntax/loc expr #,subexprs))))]
+        
+        [(#%datum . _) expr]
+        
+        [(#%top . var) expr]
+        
+        [else (error 'expr-syntax-object-iterator "unknown expr: ~a"
+                     (syntax-object->datum expr))]))
+
+      (set! count (+ count 1))
+      (if (= (modulo count 100) 0)
+          (fprintf (current-error-port) "syntax-source: ~v\nsyntax-position: ~v\n" (syntax-source expr) (syntax-position expr)))
+      
+      
+      (if (and (eq? (syntax-source expr) breakpoint-origin)
+               (memq (- (syntax-position expr) 1) ; syntax positions start at one.
+                     breakpoints))
+          (break-wrap (make-debug-info expr bound-vars bound-vars 'at-break #f)
+                             annotated)
+          annotated))
+    
+    (top-level-annotate stx)))
+
+                
\ No newline at end of file
diff --git a/collects/stepper/private/debugger-bindings.ss b/collects/stepper/private/debugger-bindings.ss
new file mode 100644
index 0000000000..6d1bf00a73
--- /dev/null
+++ b/collects/stepper/private/debugger-bindings.ss
@@ -0,0 +1,125 @@
+; this module is a cheap hack; it interacts with the debugger 
+; REPL by getting & setting values in the top-level environment
+
+(module debugger-bindings mzscheme
+  (require (lib "contract.ss")
+           "marks.ss"
+           (lib "etc.ss")
+           (lib "list.ss")
+           (prefix kernel: (lib "kerncase.ss" "syntax")))
+  
+  (provide/contract [set-event-num! (-> number? void?)] 
+                    [bt (-> void?)] 
+                    [set-frame-num! (-> number? void?)]
+                    [src (-> void?)]
+                    [binding (-> symbol? any)])
+
+  (provide install-debugger-bindings)
+
+  (define (install-debugger-bindings)
+    ; yuck!  dependence on the list of names provided by the module
+    (namespace-set-variable-value! 'e set-event-num!)
+    (namespace-set-variable-value! 'bt bt)
+    (namespace-set-variable-value! 'f set-frame-num!)
+    (namespace-set-variable-value! 'src src)
+    (namespace-set-variable-value! 'v binding)
+    (namespace-set-variable-value! 'c continue)
+    (namespace-set-variable-value! 'bound bound)
+    (namespace-set-variable-value! 'help help))
+  
+  (define (help)
+    (printf "Help Summary:\n")
+    (call-with-input-file (build-path (collection-path "stepper" "private") "debugger-summary.txt")
+      (lambda (port)
+	(let loop ([line (read-line port)])
+	  (unless (eof-object? line)
+          (printf "~a\n" line)
+          (loop (read-line port)))))))
+
+  (define (continue)
+    (semaphore-post (namespace-variable-value 'go-semaphore)))
+  
+  (define (events)
+    ((namespace-variable-value 'events)))
+  
+  (define (current-event-num)
+    (namespace-variable-value 'current-event-num))
+
+  (define (current-event)
+    (list-ref (events) (current-event-num)))
+  
+  ; this retrieves the mark list from the most recent event with normal breakpoint info
+  ; unless an event with breakpoint info has been specified, in which case it returns that
+  (define (current-mark-list)
+    (if (normal-breakpoint-info? (current-event))
+        (normal-breakpoint-info-mark-list (current-event))
+        (let loop ((l  (reverse (events))))
+          (cond
+            ((null? l) (error 'current-mark-list "no events with mark lists: ~v" (events)))
+            ((normal-breakpoint-info? (car l)) (normal-breakpoint-info-mark-list (car l)))
+            (else (loop (cdr l)))))))
+
+  (define (current-frame-num)
+    (namespace-variable-value 'current-frame-num))
+  
+  (define (current-frame)
+    (list-ref (current-mark-list) (current-frame-num)))
+  
+  (define (check-range num bottom top)
+    (when (or (< num bottom) (> num top))
+      (error 'check-range "argument ~v out of range [~v ... ~v]" num bottom top)))
+  
+  ; pretty-print code (represented as sexp)
+  ; stolen from MrFlow
+  (define (simplify t)
+    (kernel:kernel-syntax-case t #f
+      [(#%app . rest) (map simplify (syntax->list #`rest))]
+      [(#%datum . d) #`d]
+      [(#%top . v) #`v]
+      [(a ...) (map simplify (syntax->list #`(a ...)))]
+      [x #`x]))
+  
+  (define (unexpand t)
+    (if (pair? t)
+        (let ([kw (car t)])
+          (if (list? t)
+              (cond
+                [(eq? kw '#%app) (map unexpand (cdr t))]
+                [else (map unexpand t)])
+              (cond
+                [(eq? kw '#%datum) (cdr t)]
+                [(eq? kw '#%top) (cdr t)]
+                [else t])))
+        t))
+  
+  (define (set-event-num! num)
+    (check-range num 0 (- (length (events)) 1))
+    (namespace-set-variable-value! 'current-event-num num)
+    (namespace-set-variable-value! 'current-frame-num 0))
+  
+  (define (set-frame-num! num)
+    (check-range num 0 (- (length (current-mark-list)) 1))
+    (namespace-set-variable-value! 'current-frame-num num))
+  
+  (define (bt)
+    (for-each 
+     (lambda (mark num)
+       (printf "~v: ~v\n" num (unexpand (syntax-object->datum (mark-source mark)))))
+     (current-mark-list)
+     (build-list (length (current-mark-list)) (lambda (x) x))))
+
+  (define (src)
+    (let ([source (mark-source (list-ref (current-mark-list) (current-frame-num)))])
+      ((namespace-variable-value 'highlight-source-position) (syntax-position source))
+      (printf "~v\n" source)))
+
+  (define (binding sym)
+    (map (lambda (binding) (list (mark-binding-binding binding) (mark-binding-value binding)))
+    (lookup-all-bindings (lambda (id) (eq? (syntax-e id) sym)) (do-n-times cdr (current-frame-num) (current-mark-list)))))
+
+  (define (bound)
+    (map (lambda (binding) (list (syntax-e binding) binding))
+         (all-bindings (car (do-n-times cdr (current-frame-num) (current-mark-list))))))
+  
+  (define (do-n-times fn n arg)
+    (foldl (lambda (x arg) (fn arg)) arg (build-list n (lambda (x) x)))))
\ No newline at end of file
diff --git a/collects/stepper/private/debugger-model.ss b/collects/stepper/private/debugger-model.ss
new file mode 100644
index 0000000000..8799ecebd5
--- /dev/null
+++ b/collects/stepper/private/debugger-model.ss
@@ -0,0 +1,79 @@
+(module debugger-model mzscheme
+  (require (lib "unitsig.ss")
+           (lib "contract.ss")
+           (lib "etc.ss")
+           (lib "mred.ss" "mred")
+           (lib "debugger-sig.ss" "stepper")
+           "my-macros.ss"
+           "debugger-annotate.ss"
+           "shared.ss"
+           "marks.ss"
+           "debugger-vc.ss"
+           "debugger-bindings.ss")
+ 
+  
+  (define program-expander-contract
+    (-> (-> void?) ; init
+        (-> (union eof-object? syntax? (cons/c string? any/c)) (-> void?) void?) ; iter
+        void?))
+   
+  (provide debugger-model@)
+
+  ;(provide/contract [go (-> program-expander-contract ; program-expander
+  ;                          void?)])
+  
+  (define (send-to-eventspace eventspace thunk)
+    (parameterize ([current-eventspace eventspace])
+      (queue-callback thunk)))
+
+  (define debugger-debugger-error-port (current-error-port))
+
+  (define debugger-model@   
+    (unit/sig debugger-model^
+      (import debugger-vc^
+              (program-expander)
+              (breakpoints breakpoint-origin))
+      
+      (define go-semaphore (make-semaphore))
+      (define user-custodian (make-custodian))
+      
+      (define queue-eventspace (make-eventspace))
+      
+      (define (queue-result result)
+        (send-to-eventspace 
+         queue-eventspace
+         (lambda ()
+           (receive-result result))))
+      
+      (define basic-eval (current-eval))
+      
+      (define (break mark-set kind final-mark)
+        (let ([mark-list (continuation-mark-set->list mark-set debug-key)])
+          (queue-result (make-normal-breakpoint-info (cons final-mark mark-list) kind))
+          (queue-result (make-breakpoint-halt))
+          (semaphore-wait go-semaphore)))
+      
+      
+      (define (step-through-expression expanded expand-next-expression)
+        (let* ([annotated (annotate expanded breakpoints breakpoint-origin break)])
+          ; (fprintf (current-error-port) "annotated: ~v\n" (syntax-object->datum annotated))
+          (let ([expression-result
+                 (parameterize ([current-eval basic-eval])
+                   (eval annotated))])
+            (queue-result (make-expression-finished (list expression-result)))
+            (queue-result (make-breakpoint-halt))
+            (semaphore-wait go-semaphore)
+            (expand-next-expression))))
+      
+      (define (err-display-handler message exn)
+        (queue-result (make-error-breakpoint-info message)))
+      
+      (define (go)
+        (parameterize ([current-custodian user-custodian])
+          (program-expander
+           (lambda ()
+             (error-display-handler err-display-handler)) ; init
+           (lambda (expanded continue-thunk) ; iter
+             (unless (eof-object? expanded)
+               (step-through-expression expanded continue-thunk)))))))))
+
diff --git a/collects/stepper/private/debugger-summary.txt b/collects/stepper/private/debugger-summary.txt
new file mode 100644
index 0000000000..1d76fd5600
--- /dev/null
+++ b/collects/stepper/private/debugger-summary.txt
@@ -0,0 +1,16 @@
+
+(c) : continue execution (more accurately, post to the continue semaphore)
+(events) : show all debugging events
+(e #) : pick which event to examine
+
+... the following are all implicitly parameterized
+    by the chosen event:
+
+  (bt) : summarize the continuation
+  (f #) : examine the #th frame of the continuation
+
+  ... the following are all implicitly parameterized
+      by the chosen frame
+    (bound) : all bound vars
+    (v <x>) : value of a named variable
+    (src) : the source code 
\ No newline at end of file
diff --git a/collects/stepper/private/debugger-vc.ss b/collects/stepper/private/debugger-vc.ss
new file mode 100644
index 0000000000..169f7aabe8
--- /dev/null
+++ b/collects/stepper/private/debugger-vc.ss
@@ -0,0 +1,104 @@
+(module debugger-vc mzscheme
+  (require (lib "unitsig.ss")
+           (lib "debugger-sig.ss" "stepper")
+           (lib "mred.ss" "mred")
+           (lib "class.ss")
+           (lib "framework.ss" "framework")
+           "marks.ss"
+           "debugger-bindings.ss")
+  
+  (provide debugger-vc@)
+  
+  (define debugger-vc@ 
+    (unit/sig debugger-vc^
+      (import debugger-model^
+              (drs-window))
+      
+      (define debugger-eventspace 
+        (parameterize ([current-custodian user-custodian])
+          (make-eventspace)))
+      
+      (define (receive-result result)
+        (set! event-list (append event-list (list result)))
+        (parameterize ([current-eventspace debugger-eventspace])
+          (queue-callback
+           (lambda ()
+             (namespace-set-variable-value! 'current-event-num (- (length event-list) 1))
+             (namespace-set-variable-value! 'current-frame-num 0))))
+        (send-output-to-debugger-window (format-event result) debugger-output))
+      
+      (define (format-event debugger-event)
+        (cond [(normal-breakpoint-info? debugger-event) 
+               (when (null? (normal-breakpoint-info-mark-list debugger-event))
+                 (error 'format-event "mark list was empty")) ; should never happen; at-brpt mark should always be there
+               (format "normal breakpoint\nsource:~v\n" (mark-source (car (normal-breakpoint-info-mark-list debugger-event))))]
+              [(error-breakpoint-info? debugger-event)
+               (format "error breakpoint\nmessage: ~v\n" (error-breakpoint-info-message debugger-event))]
+              [(breakpoint-halt? debugger-event)
+               (format "breakpoint halt\n")]
+              [(expression-finished? debugger-event)
+               (format "expression finished\nresults: ~v\n" (expression-finished-returned-value-list debugger-event))]))
+      
+      
+      (define event-list null)
+      
+      (define (events) event-list)
+      
+      (thread 
+       (lambda () 
+         (graphical-read-eval-print-loop debugger-eventspace #t)))
+      
+      (define (highlight-source-position posn)
+        (send (send drs-window get-definitions-text)
+              set-position
+              posn
+              (+ 1 posn)))
+      
+      (define debugger-output (make-output-window drs-window user-custodian))
+      
+      ; set up debugger eventspace
+      
+      (parameterize ([current-eventspace debugger-eventspace])
+        (queue-callback 
+         (lambda ()
+           (namespace-set-variable-value! 'go-semaphore go-semaphore)
+           (namespace-set-variable-value! 'events events)
+           (namespace-set-variable-value! 'user-custodian user-custodian)
+           (namespace-set-variable-value! 'highlight-source-position highlight-source-position)
+           (install-debugger-bindings))))))
+  
+  ;; Info functions:
+  
+  ;; Debugger Output Window:
+  
+  (define output-frame%
+    (class frame:basic% ()
+      
+      (init-field drs-window)
+      (init-field user-custodian)
+      
+      (define/override (on-close)
+        (send drs-window on-debugger-close)
+        (custodian-shutdown-all user-custodian))
+      
+      (super-instantiate ())))
+  
+  ; make-output-window : (-> text:basic%)
+  (define (make-output-window drs-window cust)
+    (let* ([frame (instantiate output-frame% () 
+                    (label "Debugger Output")
+                    (width 400)
+                    (height 400)
+                    (drs-window drs-window)
+                    (user-custodian cust))]
+           [canvas (instantiate canvas:basic% () (parent (send frame get-area-container)))]
+           [text (instantiate text:basic% ())])
+      (send canvas set-editor text)
+      (send frame show #t)
+      text))
+  
+  ; send-output-to-debugger-window : (string text:basic% -> void)
+  (define (send-output-to-debugger-window str text)
+    (send text insert str (send text last-position))))      
+      
+    
\ No newline at end of file
diff --git a/collects/stepper/private/display-exp-interface.ss b/collects/stepper/private/display-exp-interface.ss
new file mode 100644
index 0000000000..d5bf4470c6
--- /dev/null
+++ b/collects/stepper/private/display-exp-interface.ss
@@ -0,0 +1,34 @@
+(module display-exp-interface mzscheme
+  
+  (require (lib "mred.ss" "mred")
+           (lib "class.ss")
+           (lib "contract.ss")
+           "my-macros.ss"
+           "highlight-placeholder.ss")
+  
+  (provide exp-without-holes?
+           exp-with-holes?)
+  
+  ; an exp-with-holes is either:
+  ; - a pair of exp-with-holes's,
+  ; - null,
+  ; - a symbol, or
+  ; - the highlight-placeholder
+  
+  (define exp-without-holes-base-case? (union symbol? number? string? null? (lambda (v) (is-a? v snip%))))
+  
+  (define exp-without-holes?
+    (union  exp-without-holes-base-case?
+           (and/c pair? (cons/c (lx ((flat-contract-predicate exp-without-holes?) _))
+                                (lx ((flat-contract-predicate exp-without-holes?) _))))))
+  
+  (define exp-with-holes-base-case? 
+    (union exp-without-holes-base-case?
+          (lx (eq? _ highlight-placeholder))))
+  
+  (define exp-with-holes?
+    (union exp-with-holes-base-case?
+          (and/c pair? (cons/c (lx ((flat-contract-predicate exp-with-holes?) _)) 
+                               (lx ((flat-contract-predicate exp-with-holes?) _))))))
+  
+)
\ No newline at end of file
diff --git a/collects/stepper/private/highlight-placeholder.ss b/collects/stepper/private/highlight-placeholder.ss
new file mode 100644
index 0000000000..711932a52c
--- /dev/null
+++ b/collects/stepper/private/highlight-placeholder.ss
@@ -0,0 +1,13 @@
+(module highlight-placeholder mzscheme
+  
+  (provide highlight-placeholder highlight-placeholder-stx)
+  
+  ; highlight-placeholder : symbol
+  ; highlight-placeholder-stx : syntax
+  
+  ; we rely upon the fact that the highlight-placeholder-stx is a syntax-object, so that
+  ; syntax objects containing the highlight-placeholder-stx still fit the data definition
+  ; for syntax objects 
+  
+  (define highlight-placeholder (gensym "highlight-placeholder"))
+  (define highlight-placeholder-stx #`#,highlight-placeholder))
diff --git a/collects/stepper/private/info.ss b/collects/stepper/private/info.ss
new file mode 100644
index 0000000000..c983a90aa4
--- /dev/null
+++ b/collects/stepper/private/info.ss
@@ -0,0 +1,3 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Stepper private"))
+  
diff --git a/collects/stepper/private/lifting.ss b/collects/stepper/private/lifting.ss
new file mode 100644
index 0000000000..2b0d8042ed
--- /dev/null
+++ b/collects/stepper/private/lifting.ss
@@ -0,0 +1,304 @@
+(module lifting mzscheme
+  (require (lib "etc.ss")
+           (lib "contract.ss")
+           (prefix kernel: (lib "kerncase.ss" "syntax"))
+           (lib "match.ss")
+           "testing-shared.ss"
+           "shared.ss"
+           "my-macros.ss")
+
+  (define-struct context-record (stx index kind))
+  
+  ; context-records are used to represent syntax context frames. That is,
+  ; a list of context records represents a path through a syntax tree
+  ; (to the highlight).
+
+  (define-struct try-record (index try-fn expr))
+  
+  ; try-records are 
+  (provide/contract [lift (syntax? ; syntax to perform lifiting in
+                           boolean? ; lift-at-highlight?
+                           . -> .
+                           (listof syntax?))]) ; result
+                          
+  
+  (define (lift stx lift-in-highlight?)
+    (let*-2vals ([(context-records highlight) (find-highlight stx)])
+      (lift-local-defs context-records highlight lift-in-highlight?)))
+  
+  ; [find-highlight (-> syntax? (listof context-record?))]
+
+  (define (find-highlight stx)
+    (let/ec success-escape
+      (local
+          ((define (make-try-all-subexprs stx kind context-so-far)
+             (lambda (index-mangler list-of-subtries)
+               (let loop ([index 0] [remaining list-of-subtries])
+                 (unless (null? remaining)
+                   (let* ([try (car remaining)]
+                          [corrected-index (index-mangler index)])
+                   ((car try) (cadr try) (cons (make-context-record stx corrected-index kind) context-so-far))
+                   (loop (+ index 1) (cdr remaining)))))))
+           
+           (define try->offset-try
+             (lambda (try)
+               (lambda (offset subtries)
+                 (try (lambda (index) (list (+ offset index))) subtries))))
+           
+           (define (top-level-expr-iterator stx context-so-far)
+             (let ([try (try->offset-try (make-try-all-subexprs stx 'top-level context-so-far))])
+               (kernel:kernel-syntax-case stx #f
+                 [(module identifier name (#%plain-module-begin . module-level-exprs))
+                  (try 3 (map (lambda (expr) `(,module-level-expr-iterator ,expr))
+                              (syntax->list #'module-level-exprs)))]
+                 [else-stx
+                  (general-top-level-expr-iterator stx context-so-far)])))
+           
+           (define (module-level-expr-iterator stx context-so-far)
+             (kernel:kernel-syntax-case stx #f
+               [(provide . provide-specs)
+                (void)]
+               [else-stx
+                (general-top-level-expr-iterator stx context-so-far)]))
+           
+           (define (general-top-level-expr-iterator stx context-so-far)
+             (let ([try (try->offset-try (make-try-all-subexprs stx 'general-top-level context-so-far))])
+               (kernel:kernel-syntax-case stx #f
+                 [(define-values (var ...) expr)
+                  (try 2 `((,expr-iterator ,#'expr)))]
+                 [(define-syntaxes (var ...) expr)
+                  (try 2 `((,expr-iterator ,#'expr)))]
+                 [(begin . top-level-exprs)
+                  (try 1 (map (lambda (expr) `(,top-level-expr-iterator ,expr))
+                              (syntax->list #'exprs)))]
+                 [(require . require-specs)
+                  (void)]
+                 [(require-for-syntax . require-specs)
+                  (void)]
+                 [else
+                  (expr-iterator stx context-so-far)])))
+           
+           (define (expr-iterator stx context-so-far)
+             (when (syntax-property stx 'stepper-highlight)
+               (success-escape (2vals context-so-far stx)))
+             (let* ([try (make-try-all-subexprs stx 'expr context-so-far)]
+                    [try-exprs (lambda (index-mangler exprs) (try index-mangler (map (lambda (expr) (list expr-iterator expr)) 
+                                                                                     (syntax->list exprs))))]
+                    [try-exprs-offset (try->offset-try try-exprs)] 
+                    [let-values-abstraction
+                     (lambda (stx)
+                       (kernel:kernel-syntax-case stx #f
+                         [(kwd (((variable ...) rhs) ...) . bodies)
+                          (begin
+                            (try-exprs (lambda (index) (list 1 index 1)) #'(rhs ...))
+                            (try-exprs-offset 2 #'bodies))]
+                         [else
+                          (error 'expr-syntax-object-iterator 
+                                 "unexpected let(rec) expression: ~a"
+                                 (syntax-object->datum stx))]))]) 
+               (kernel:kernel-syntax-case stx #f
+                 [var-stx
+                  (identifier? (syntax var-stx))
+                  (void)]
+                 [(lambda vars . bodies)
+                  (try-exprs-offset 2 #'bodies)]
+                 [(case-lambda (vars . bodies) ...)
+                  (let loop ([count 1] [clauses (syntax->list #'(bodies ...))])
+                    (unless (null? clauses)
+                      (try-exprs (lambda (index) (list count (+ index 1))) (cdar clauses))
+                      (loop (+ count 1) (cdr clauses))))]
+                 [(if test then)
+                  (try-exprs-offset 1 #'(test then))]
+                 [(if test then else)
+                  (try-exprs-offset 1 #'(test then else))]
+                 [(begin . bodies)
+                  (try-exprs-offset 1 #'bodies)]
+                 [(begin0 . bodies)
+                  (try-exprs-offset 1 #'bodies)]
+                 [(let-values . _)
+                  (let-values-abstraction stx)]
+                 [(letrec-values . _)
+                  (let-values-abstraction stx)]
+                 [(set! var val)
+                  (try-exprs-offset 2 #'(val))]
+                 [(quote _)
+                  (void)]
+                 [(quote-syntax _)
+                  (void)]
+                 [(with-continuation-mark key mark body)
+                  (try-exprs-offset 1 #'(key mark body))]
+                 [(#%app . exprs)
+                  (try-exprs-offset 1 #'exprs)]
+                 [(#%datum . _)
+                  (void)]
+                 [(#%top . var)
+                  (void)]
+                 [else
+                  (error 'expr-iterator "unknown expr: ~a" 
+                         (syntax-object->datum stx))]))))
+        
+        (begin (top-level-expr-iterator stx null)
+               (error 'find-highlight "couldn't find highlight-placeholder in expression: ~v" (syntax-object->datum stx))))))
+
+  ; TESTING:
+  
+  (define-syntax (test-begin stx)
+    (syntax-case stx ()
+      [(_ expr ...)
+       ;#'(begin expr ...) ; testing version
+       #'(void) ; non-testing version
+       ]))
+  
+  (define (datum-ize-context-record cr)
+     (list (syntax-object->datum (context-record-stx cr))
+                          (context-record-index cr)
+                          (context-record-kind cr)))
+  
+  (test-begin (require (lib "mz-testing.ss" "tests" "utils")))
+  
+  (test-begin (section 'stepper-lifting))
+
+  (test-begin
+   ; TEST OF FIND-HIGHLIGHT
+   
+   
+   (define test-datum (expand (car (build-stx-with-highlight
+                                    `((define (f x) (letrec ([a (lambda (x) (b (- x 1)))]
+                                                             [b (lambda (x) ((hilite a) x))])
+                                                      (a x))))))))
+
+   (define expected (list (list `(#%app a x) '(1) 'expr)
+                          (list `(lambda (x) (#%app a x)) '(2) 'expr)
+                          (list `(letrec-values ([(a) (lambda (x) (#%app b (#%app (#%top . -) x (#%datum . 1))))] [(b) (lambda (x) (#%app a x))]) (#%app a x)) '(1 1 1) 'expr)
+                          (list `(lambda (x) (letrec-values ([(a) (lambda (x) (#%app b (#%app (#%top . -) x (#%datum . 1))))] [(b) (lambda (x) (#%app a x))]) (#%app a x))) '(2) 'expr)                 
+                          (list `(define-values (f) (lambda (x) (letrec-values ([(a) (lambda (x) (#%app b (#%app (#%top . -) x (#%datum . 1))))] [(b) (lambda (x) (#%app a x))]) (#%app a x)))) '(2)
+                                               'general-top-level)))
+   
+   (let*-2vals ([(context-records highlight) (find-highlight test-datum)])
+     (test expected map datum-ize-context-record context-records))
+   
+   
+   (test null (lambda () 
+                (let*-2vals ([(context-records dc) 
+                              (find-highlight (car (build-stx-with-highlight `((hilite foo)))))])
+                  context-records))))
+  
+  ; substitute-in-syntax takes a syntax expression (which must be a proper syntax list) and a path
+  ; (represented by a list of numbers) and a syntax-expression to insert.  If the path is null, the
+  ; 'to-insert' expression is returned.  Otherwise, the nth element of the syntax-list is replaced
+  ; by the recursive call with the nth element, the rest of the path, and the to-insert, where n is
+  ; the first number in the list.
+
+  (define (substitute-in-syntax src path to-insert)
+    (if (null? path)
+        to-insert
+        (let* ([opened (syntax->list src)]
+               [n (car path)])
+          (when (>= n (length opened))
+            (error 'substitute-in-syntax "given an n (~v) which is larger than the length of the source sytax ~v" n (syntax-object->datum src)))
+          (datum->syntax-object
+           src
+           (let loop ([n n] [left opened])
+            (if (= n 0) 
+                (cons (substitute-in-syntax (car left) (cdr path) to-insert)
+                      (cdr left))
+                (cons (car left) 
+                      (loop (- n 1) (cdr left)))))
+           src
+           src))))
+  
+  (define (n-times n fn arg)
+    (if (= n 0)
+        arg
+        (fn (n-times (- n 1) fn arg))))
+  
+  (test-begin
+   
+   (local
+       ((define expected '(let-values ([(a) (lambda (x) 'bar)]) (a)))
+        (define actual (syntax-object->datum (substitute-in-syntax #'(let-values ([(a) (lambda (x) 'foo)]) (a)) '(1 0 1 2 1) #'bar))))
+     (printf "equal? ~v\n" (equal? expected actual))))
+  
+  
+  ; lift-local-defs takes a list of contexts and an instruction and works its way out, reconstructing the expression.
+  ; the main action of lift-local-defs is on let-values and letrec-values, where (after performing the substitution)
+  ; the binding clauses are lifted into top-level defs.
+  ; [lift-local-defs (->* ((listof context-record?) syntax?)
+  ;                       ((listof syntax?) (listof syntax?)))]
+  
+  (define (lift-local-defs ctx-list highlighted lift-in-highlighted?)
+    (let-values ([(highlighted-defs highlighted-body) (if lift-in-highlighted?
+                                                          (lift-helper highlighted #f null)
+                                                          (values null highlighted))])
+      (let loop ([ctx-list ctx-list]
+                 [so-far-defs (map (lambda (x) (syntax-property x 'stepper-highlight #t)) 
+                                   highlighted-defs)]
+                 [body (syntax-property highlighted-body 'stepper-highlight #t)])
+        (if (null? ctx-list)
+            (append so-far-defs (list body))
+            (let*-values ([(ctx) (car ctx-list)]
+                          [(index) (context-record-index ctx)]
+                          [(next-defs next-body) 
+                           (lift-helper (substitute-in-syntax (context-record-stx ctx) index body)
+                                        index
+                                        so-far-defs)])
+              (loop (cdr ctx-list) next-defs next-body))))))
+  
+  ; lift-helper takes a syntax object and a split path and a list of syntax objects and breaks it up
+  ; iff its a let/rec, wrapping those before the split and those after the split around the list of syntax
+  ; objects
+  ;  (->* (syntax? (union false? (listof number?)) (listof syntax?)) ((listof syntax?) syntax?))
+  (define (lift-helper stx path so-far-defs)
+    (let* ([lift
+            (lambda ()
+              (kernel:kernel-syntax-case stx #f
+                [(tag ([(var ...) rhs] ...) body ...)
+                 (let* ([defns (syntax->list #'((define-values (var ...) rhs) ...))]
+                        [bodies-list (syntax->list #'(body ...))]
+                        [body (if (= (length bodies-list) 1) ; as far as I can tell, this source info is comprehensively lost.
+                                  (car bodies-list)
+                                  #'(values body ...))])
+                   (cond [(or (not path) (and (= (length path) 1)
+                                              (> (car path) 1)))
+                          (values (append defns so-far-defs) body)]
+                         [(match path [`(1 ,n 1) n]) =>
+                          (lambda (n)
+                            (values (append (sublist 0 n defns) so-far-defs (sublist n (length defns) defns))
+                                    body))]))]
+                [else (error 'lift-helper "let or letrec does not have expected shape: ~v\n" (syntax-object->datum stx))]))])
+    (kernel:kernel-syntax-case stx #f
+      [(let-values . dc)
+       (not (eq? (syntax-property stx 'user-stepper-hint) 'comes-from-or))
+       (lift)]
+      [(letrec-values . dc)
+       (lift)]
+      [else (values so-far-defs stx)])))
+  
+  (test-begin
+   (local 
+       ((define actual-stxs
+          (lift-local-defs
+            (list (make-context-record #'(dc 14) '(0) 'expr)
+                  (make-context-record #'(letrec-values ([(a) 3] [(b) dc] [(c) 5]) (+ 3 4)) '(1 1 1) 'expr)
+                  (make-context-record #'(f dc) '(1) 'expr))
+            #'(let-values ([(a) 4] [(b) 9] [(c) 12]) (p q))
+            #t))
+        
+        (define actual-sexps (map syntax-object->hilite-datum actual-stxs))
+        
+        (define expected-sexps
+          (list '(define-values (a) 3)
+                `(hilite (define-values (a) 4))
+                `(hilite (define-values (b) 9))
+                `(hilite (define-values (c) 12))
+                `(define-values (b) ((hilite (p q)) 14))
+                '(define-values (c) 5)
+                '(f (+ 3 4)))))
+     
+     (test expected-sexps (lambda () actual-sexps))
+     ;(printf "shared: ~v\n" (sexp-shared actual expected))
+     )
+   
+   (report-errs)
+   ))
+ 
diff --git a/collects/stepper/private/marks.ss b/collects/stepper/private/marks.ss
new file mode 100644
index 0000000000..aa77b8dcd8
--- /dev/null
+++ b/collects/stepper/private/marks.ss
@@ -0,0 +1,180 @@
+(module marks mzscheme
+
+  (require (lib "list.ss")
+	   (lib "contract.ss")
+           "my-macros.ss"
+           "shared.ss")
+
+  (define-struct full-mark-struct (source label bindings values))
+
+  ; CONTRACTS
+  (define mark? (-> ; no args  
+                 full-mark-struct?))
+  (define mark-list? (listof procedure?))
+  
+  (provide/contract 
+   ;[make-debug-info (-> any/c binding-set? varref-set? any/c boolean? syntax?)] ; (location tail-bound free label lifting? -> mark-stx)
+   [expose-mark (-> mark? (list/c any/c symbol? (listof (list/c identifier? any/c))))]
+   [make-top-level-mark (syntax? . -> . syntax?)]
+   [lookup-all-bindings ((identifier? . -> . boolean?) mark-list? . -> . (listof any/c))]
+   [lookup-first-binding ((identifier? . -> . boolean?) mark-list? ( -> any) . -> . any/c)]
+   [lookup-binding (mark-list? identifier? . -> . any)])
+  
+  (provide
+   make-debug-info
+   wcm-wrap
+   skipto-mark?
+   skipto-mark
+   strip-skiptos
+   mark-list?
+   mark-source
+   mark-bindings
+   mark-label
+   mark-binding-value
+   mark-binding-binding
+   display-mark
+   all-bindings
+   #;lookup-binding-list
+   debug-key
+   extract-mark-list
+   (struct normal-breakpoint-info (mark-list kind))
+   (struct error-breakpoint-info (message))
+   (struct breakpoint-halt ())
+   (struct expression-finished (returned-value-list)))
+  
+  ; BREAKPOINT STRUCTURES
+  
+  (define-struct normal-breakpoint-info (mark-list kind))
+  (define-struct error-breakpoint-info (message))
+  (define-struct breakpoint-halt ())
+  (define-struct expression-finished (returned-value-list))
+  
+  (define-struct skipto-mark-struct ())
+  (define skipto-mark? skipto-mark-struct?)
+  (define skipto-mark (make-skipto-mark-struct))
+  (define (strip-skiptos mark-list)
+    (filter (lx (not (skipto-mark? _))) mark-list))
+  
+    
+  ; debug-key: this key will be used as a key for the continuation marks.
+  (define-struct debug-key-struct ())
+  (define debug-key (make-debug-key-struct))
+  
+  (define (extract-mark-list mark-set)
+    (strip-skiptos (continuation-mark-set->list mark-set debug-key)))
+   
+  
+  ; the 'varargs' creator is used to avoid an extra cons cell in every mark:
+  (define (make-make-full-mark-varargs source label bindings)
+    (lambda values 
+      (make-full-mark-struct source label bindings values)))
+  
+  ; see module top for type
+  (define (make-full-mark location label bindings)
+    (datum->syntax-object #'here `(lambda () (,(make-make-full-mark-varargs location label bindings)
+                                              ,@(map make-mark-binding-stx bindings)))))
+  
+  (define (mark-source mark)
+    (full-mark-struct-source (mark)))
+    
+  ; : identifier -> identifier
+  (define (make-mark-binding-stx id)
+    #`(lambda () #,(syntax-property id 'stepper-dont-check-for-function #t)))
+  
+  (define (mark-bindings mark)
+    (map list 
+         (full-mark-struct-bindings (mark)) 
+         (full-mark-struct-values (mark))))
+  
+  (define (mark-label mark)
+    (full-mark-struct-label (mark)))
+  
+  (define (mark-binding-value mark-binding)
+    ((cadr mark-binding)))
+  
+  (define (mark-binding-binding mark-binding)
+    (car mark-binding))
+
+  (define (expose-mark mark)
+    (let ([source (mark-source mark)]
+          [label (mark-label mark)]
+          [bindings (mark-bindings mark)])
+      (list source
+            label
+            (map (lambda (binding)
+                   (list (mark-binding-binding binding)
+                         (mark-binding-value binding)))
+                 bindings))))
+  
+  (define (display-mark mark)
+    (apply
+     string-append
+     (format "source: ~a~n" (syntax-object->datum (mark-source mark)))
+     (format "label: ~a~n" (mark-label mark))
+     (format "bindings:~n")
+     (map (lambda (binding)
+                 (format " ~a : ~a~n" (syntax-e (mark-binding-binding binding))
+                         (mark-binding-value binding)))
+               (mark-bindings mark))))
+  
+  
+  ; possible optimization: rig the mark-maker to guarantee statically that a
+  ; variable can occur at most once in a mark.  
+  
+  (define (binding-matches matcher mark)
+    (filter (lambda (binding-pair) (matcher (mark-binding-binding binding-pair))) (mark-bindings mark)))
+  
+  (define (lookup-all-bindings matcher mark-list)
+    (apply append (map (lambda (m) (binding-matches matcher m)) mark-list)))
+  
+  (define (lookup-first-binding matcher mark-list fail-thunk)
+    (let ([all-bindings (lookup-all-bindings matcher mark-list)])
+      (if (null? all-bindings)
+          (fail-thunk)
+          (car all-bindings))))
+  
+  (define (lookup-binding mark-list id)
+    (mark-binding-value
+     (lookup-first-binding (lambda (id2) (module-identifier=? id id2)) 
+                           mark-list 
+                           (lambda ()
+                             (error 'lookup-binding "variable not found in environment: ~a~n" (if (syntax? id) 
+                                                                                                  (syntax-object->datum id)
+                                                                                                  id))))))
+  
+  (define (all-bindings mark)
+    (map mark-binding-binding (mark-bindings mark)))
+  
+  (define (wcm-wrap debug-info expr)
+    #`(with-continuation-mark #,debug-key #,debug-info #,expr))
+
+  
+  ; DEBUG-INFO STRUCTURES
+  
+  ;;;;;;;;;;
+  ;;
+  ;; make-debug-info builds the thunk which will be the mark at runtime.  It contains 
+  ;; a source expression and a set of binding/value pairs.
+  ;; (syntax-object BINDING-SET VARREF-SET any boolean) -> debug-info)
+  ;;
+  ;;;;;;;;;;
+     
+  (define (make-debug-info source tail-bound free-vars label lifting?)
+       (let*-2vals ([kept-vars (binding-set-varref-set-intersect tail-bound free-vars)])
+         (if lifting?
+             (let*-2vals ([let-bindings (filter (lambda (var) 
+                                                  (case (syntax-property var 'stepper-binding-type)
+                                                    ((let-bound macro-bound) #t)
+                                                    ((lambda-bound stepper-temp non-lexical) #f)
+                                                    (else (error 'make-debug-info 
+                                                                 "varref ~a's binding-type info was not recognized: ~a"
+                                                                 (syntax-e var)
+                                                                 (syntax-property var 'stepper-binding-type)))))
+                                                kept-vars)]
+                          [lifter-syms (map get-lifted-var let-bindings)])
+               (make-full-mark source label (append kept-vars lifter-syms)))
+             (make-full-mark source label kept-vars))))
+  
+  
+  (define (make-top-level-mark source-expr)
+    (make-full-mark source-expr 'top-level null)))
diff --git a/collects/stepper/private/model-settings.ss b/collects/stepper/private/model-settings.ss
new file mode 100644
index 0000000000..26db64a527
--- /dev/null
+++ b/collects/stepper/private/model-settings.ss
@@ -0,0 +1,103 @@
+(module model-settings mzscheme
+  (require (lib "contract.ss")
+           (lib "pconvert.ss"))
+  
+  ; there are two separate reasons to use units here, but it's just too painful.
+  ; reason 1) the drscheme:language procedures are linked at runtime into the
+  ; stepper-tool unit, and we need to get them down here somehow.  Making the
+  ; render-settings a unit would solve this.
+  ; reason 2) the render-settings should be recomputed once for each stepper 
+  ; invocation.  invoke-unit is a nice way of doing this without dropping back
+  ; to linking-by-position, which is what happens with a simple closure 
+  ; implementatian.
+  
+  ; HOWEVER, like I said, it's just too painful. Once this is a unit, then 
+  ; everything else wants to be a unit too. For instance, to make sure that 
+  ; the reconstructor gets the right invocation of the unit, it needs to be a 
+  ; unit as well.  Pretty soon, everything is units.
+
+  (define-struct render-settings (true-false-printed? constructor-style-printing? abbreviate-cons-as-list? render-to-sexp lifting?))
+  
+  (provide/contract [check-global-defined (-> symbol? boolean?)]
+                    [global-lookup (-> any/c any)]
+
+                    [struct render-settings 
+                            ([true-false-printed? boolean?]
+                             [constructor-style-printing? boolean?]
+                             [abbreviate-cons-as-list? boolean?]
+                             [render-to-sexp (any/c . -> . any)]
+                             [lifting? boolean?])]
+                    
+                    
+                    [get-render-settings ((any/c . -> . string?) ; render-to-string
+                                          (any/c . -> . any) ; render-to-sexp
+                                          boolean? ; lifting?
+                                          . -> .
+                                          render-settings?)]
+                    
+                    ;; the 'fake' render-settings structures are used for testing, so that the test suite
+                    ;; can be run without access to a drscheme frame.
+                    [fake-beginner-render-settings render-settings?]
+                    [fake-beginner-wla-render-settings render-settings?]
+                    [fake-intermediate-render-settings render-settings?]
+                    [fake-intermediate/lambda-render-settings render-settings?]
+                    [fake-mz-render-settings render-settings?])
+  
+  (define (make-fake-render-to-sexp true/false constructor-style abbreviate)
+    (lambda (val)
+      (parameterize ([booleans-as-true/false true/false]
+                     [constructor-style-printing constructor-style]
+                     [abbreviate-cons-as-list abbreviate])
+        ;; duplication of hack inserted by matthew flatt for 201 release:
+        (or (and (procedure? val)
+                 (object-name val))
+            (print-convert val)))))
+    
+  ; FIXME : #f totally unacceptable as 'render-to-string'
+  (define fake-beginner-render-settings
+    (make-render-settings #t #t #f (make-fake-render-to-sexp #t #t #f) #t))
+  
+  (define fake-beginner-wla-render-settings
+    (make-render-settings #t #t #t (make-fake-render-to-sexp #t #t #t) #t))
+  
+  (define fake-intermediate-render-settings
+    fake-beginner-wla-render-settings)
+  
+  (define fake-intermediate/lambda-render-settings
+    fake-beginner-wla-render-settings)
+  
+  (define fake-mz-render-settings
+    (make-render-settings (booleans-as-true/false) 
+                          (constructor-style-printing) 
+                          (abbreviate-cons-as-list) 
+                          print-convert
+                          #f))
+  
+  (define-struct test-struct () (make-inspector))
+  
+  ;; get-render-settings : infer aspects of the current language's print conversion by explicitly testing 
+  ;;  assorted test expressions
+  (define (get-render-settings render-to-string render-to-sexp lifting?)
+    (let* ([true-false-printed? (string=? (render-to-string #t) "true")]
+           [constructor-style-printing? (string=? (render-to-string (make-test-struct)) "(make-test-struct)")]
+           [rendered-list (render-to-string '(3))]
+           [rendered-list-substring (substring rendered-list 
+                                               0 
+                                               (min 5 (string-length rendered-list)))]
+           [abbreviate-cons-as-list? (and constructor-style-printing?
+                                              (string=? rendered-list-substring "(list"))])
+      (make-render-settings
+       true-false-printed?
+       constructor-style-printing?
+       abbreviate-cons-as-list?
+       render-to-sexp
+       lifting?)))
+  
+  (define (check-global-defined identifier)
+    (with-handlers
+        ([exn:fail:contract:variable? (lambda args #f)])
+      (global-lookup identifier)
+      #t))
+  
+  (define (global-lookup identifier)
+    (namespace-variable-value identifier)))
\ No newline at end of file
diff --git a/collects/stepper/private/model.ss b/collects/stepper/private/model.ss
new file mode 100644
index 0000000000..7d0068104f
--- /dev/null
+++ b/collects/stepper/private/model.ss
@@ -0,0 +1,221 @@
+;step collector state machine (not yet implemented):
+;     
+; datatype held-type = NO-HELD-STEP | SKIPPED-STEP | HELD(args)
+;
+; states: global state of held
+; global: held : held-type
+; edge-names: first, skipped-first, second, skipped-second, double, late-let 
+;
+;transitions (& actions):
+;
+; held = NO-HELD-STEP : 
+;  first(x) : held := HELD(x)
+;  skipped-first : held := SKIPPED-STEP
+;  second(x) : trigger(NO-HELD-STEP, x), held := NO-HELD-STEP ; this happens when evaluating unannotated code
+;  skipped-second : held := NO-HELD-STEP ; I believe this can also arise in unannotated code
+;  double(x) : double-trigger(x), held := NO-HELD-STEP
+;  late-let(x) : late-let-trigger(x), held := NO-HELD-STEP
+;
+; held = SOME(SKIPPED-STEP) :
+;  first(x) : ERROR
+;  skipped-first : ERROR
+;  second(x) : held := NO-HELD-STEP ; this happens e.g. for evaluation of top-level var bound to a procedure
+;  skipped-second : held := NO-HELD-STEP
+;  double(x) : ERROR
+;  late-let(x) : ERROR
+;
+; held = SOME(HELD(args))
+;  first(x) : ERROR
+;  skipped-first : ERROR
+;  second(x) : trigger(HELD(args),x), held = NO-HELD-STEP
+;  skipped-second : held = NO-HELD-STEP
+;  double(x) : ERROR
+;  late-let(x) : ERROR
+
+
+(module model mzscheme
+  (require (lib "contract.ss")
+           (lib "etc.ss")
+           (lib "list.ss")
+           "my-macros.ss"
+           (prefix a: "annotate.ss")
+           (prefix r: "reconstruct.ss")
+           "shared.ss"
+           "marks.ss"
+           "testing-shared.ss"
+           "model-settings.ss")
+ 
+
+  (define program-expander-contract
+    ((-> void?) ; init
+     ((union eof-object? syntax? (cons/c string? any/c)) (-> void?) . -> . void?) ; iter
+     . -> .
+     void?))
+    
+
+  (provide/contract [go (program-expander-contract       ; program-expander
+                         (step-result? . -> . void?)     ; receive-result
+                         (union render-settings? false/c) ; render-settings
+                         boolean?                        ; track-inferred-names?
+                         . -> .
+                         void?)])
+  
+  ; go starts a stepper instance
+  ; see provide stmt for contract 
+  (define (go program-expander receive-result render-settings track-inferred-names?)
+    
+    (local
+        
+        ((define finished-exprs null)
+         
+         (define held-expr-list no-sexp)
+         (define held-step-was-app? #f)
+         
+         (define basic-eval (current-eval))
+         
+         ; redivide takes a list of sexps and divides them into the 'before', 'during', and 'after' lists,
+         ; where the before and after sets are maximal-length lists where none of the s-expressions contain
+         ; a highlight-placeholder
+         ; (->* ((listof syntax)) (list/c syntax syntax syntax))
+         (define (redivide exprs)
+           (letrec ([contains-highlight
+                     (lambda (expr)
+                       (or (syntax-property expr 'stepper-highlight)
+                           (syntax-case expr ()
+                             [(a . rest) (or (contains-highlight #`a) (contains-highlight #`rest))]
+                             [else #f])))])
+             (let* ([list-length (length exprs)]
+                    [split-point-a (- list-length (length (or (memf contains-highlight exprs) null)))]
+                    [split-point-b (length (or (memf contains-highlight (reverse exprs)) null))])
+               (if (<= split-point-b split-point-a)
+                   (error 'redivide-exprs "s-expressions did not contain the highlight-placeholder: ~v" (map syntax-object->hilite-datum exprs))
+                   (values (sublist 0 split-point-a exprs) ; before
+                           (sublist split-point-a split-point-b exprs) ; during
+                           (sublist split-point-b list-length exprs)))))) ; after
+
+         
+;         (redivide `(3 4 (+ (define ,highlight-placeholder) 13) 5 6))
+;         (values `(3 4) `((+ (define ,highlight-placeholder) 13)) `(5 6))
+;         
+;         (redivide `(,highlight-placeholder 5 6))
+;         (values `() `(,highlight-placeholder) `(5 6))
+;         
+;         (redivide `(4 5 ,highlight-placeholder ,highlight-placeholder))
+;         (values `(4 5) `(,highlight-placeholder ,highlight-placeholder) `())
+;         
+;         (printf "will be errors:~n")
+;         (equal? (redivide `(1 2 3 4))
+;                 error-value)
+;         
+;         (redivide `(1 2 ,highlight-placeholder 3 ,highlight-placeholder 4 5))
+;         (values `(1 2) `(,highlight-placeholder 3 ,highlight-placeholder) `(4 5))
+         
+         
+         (define break 
+           (opt-lambda (mark-set break-kind [returned-value-list null])
+             
+             (let* ([mark-list (and mark-set (extract-mark-list mark-set))])
+
+               (define (double-redivide finished-exprs new-exprs-before new-exprs-after)
+                 (let*-values ([(before current after) (redivide new-exprs-before)]
+                               [(before-2 current-2 after-2) (redivide new-exprs-after)])
+                   (unless (equal? (map syntax-object->hilite-datum before) 
+                                   (map syntax-object->hilite-datum before-2))
+                     (error 'double-redivide "reconstructed before defs are not equal."))
+                   (unless (equal? (map syntax-object->hilite-datum after) 
+                                   (map syntax-object->hilite-datum after-2))
+                     (error 'double-redivide "reconstructed after defs are not equal."))
+                   (values (append finished-exprs before) current current-2 after)))
+               
+               (define (reconstruct-helper)
+                 (r:reconstruct-current mark-list break-kind returned-value-list render-settings))
+               
+               (if (r:skip-step? break-kind mark-list render-settings)
+                   (when (eq? break-kind 'normal-break)
+                     (set! held-expr-list skipped-step))
+                   (case break-kind
+                     [(normal-break)
+                      (begin
+                        (set! held-expr-list (reconstruct-helper))
+                        (set! held-step-was-app? (r:step-was-app? mark-list)))]
+                     
+                     [(result-exp-break result-value-break)
+                      (if (eq? held-expr-list skipped-step)
+                          (set! held-expr-list no-sexp)
+                          (let* ([reconstructed (reconstruct-helper)]
+                                 [result
+                                  (if (not (eq? held-expr-list no-sexp))
+                                      (let*-values 
+                                          ([(step-kind) (if (and held-step-was-app?
+                                                                 (eq? break-kind 'result-exp-break))
+                                                            'user-application
+                                                            'normal)]
+                                           [(new-finished current-pre current-post after) 
+                                            (double-redivide finished-exprs held-expr-list reconstructed)])
+                                        (make-before-after-result new-finished current-pre current-post after step-kind))
+                                      
+                                      (let*-values
+                                          ([(before current after) (redivide reconstructed)])
+                                        (make-before-after-result (append finished-exprs before) (list 
+                                                                                                  (syntax-property #`(... ...)
+                                                                                                                   'stepper-highlight
+                                                                                                                   #t))
+                                                                  current after 'normal)))])
+                            (set! held-expr-list no-sexp)
+                            (receive-result result)))]
+                     [(double-break)
+                      ; a double-break occurs at the beginning of a let's evaluation.
+                      (let* ([reconstruct-quadruple (reconstruct-helper)])
+                        (when (not (eq? held-expr-list no-sexp))
+                          (error 'break-reconstruction
+                                 "held-expr-list not empty when a double-break occurred"))
+                        (let*-values 
+                            ([(new-finished current-pre current-post after) 
+                              (double-redivide finished-exprs 
+                                               (list-ref reconstruct-quadruple 0) 
+                                               (list-ref reconstruct-quadruple 1))])
+                          (receive-result (make-before-after-result new-finished
+                                                                    current-pre
+                                                                    current-post
+                                                                    after
+                                                                    'normal))))]
+                     [(late-let-break)
+                      (let ([new-finished (r:reconstruct-current mark-list break-kind returned-value-list render-settings)])
+                        (set! finished-exprs (append finished-exprs new-finished)))]
+                     
+                     [(expr-finished-break)
+                      (let ([reconstructed (r:reconstruct-completed mark-list returned-value-list render-settings)])
+                        (set! finished-exprs (append finished-exprs (list reconstructed))))]
+                     
+                     [(define-struct-break)
+                      (set! finished-exprs (append finished-exprs
+                                                   (list (car returned-value-list))))]
+                     
+                     [else (error 'break "unknown label on break")])))))
+         
+         (define (step-through-expression expanded expand-next-expression)
+           (let* ([annotated (a:annotate expanded break track-inferred-names?)])
+             (eval-syntax annotated)
+             (expand-next-expression)))
+         
+         (define (err-display-handler message exn)
+           (if (not (eq? held-expr-list no-sexp))
+                 (let*-values ([(before current after) (redivide held-expr-list)])
+                   (set! held-expr-list no-sexp)
+                   (receive-result (make-before-error-result (append finished-exprs before) 
+                                                             current message after)))
+               (receive-result (make-error-result finished-exprs message)))))
+      
+      (program-expander
+       (lambda () 
+         ; swap these to allow errors to escape (e.g., when debugging)
+         (error-display-handler err-display-handler)
+         ;(void)
+         )
+       (lambda (expanded continue-thunk) ; iter
+         (if (eof-object? expanded)
+             (begin
+               (receive-result (make-finished-result finished-exprs))
+               (receive-result (make-finished-stepping)))
+             (step-through-expression expanded continue-thunk)))))))
+
diff --git a/collects/stepper/private/mred-extensions.ss b/collects/stepper/private/mred-extensions.ss
new file mode 100644
index 0000000000..a613295f10
--- /dev/null
+++ b/collects/stepper/private/mred-extensions.ss
@@ -0,0 +1,630 @@
+(module mred-extensions mzscheme
+  (require (lib "class.ss")
+           (lib "mred.ss" "mred")
+           (prefix f: (lib "framework.ss" "framework"))
+           (lib "pretty.ss")
+           "highlight-placeholder.ss"
+           "testing-shared.ss"
+	   (lib "string-constant.ss" "string-constants"))
+
+  (provide
+   stepper-canvas%
+   stepper-text%
+   snip?
+   separator-snip% ;; these last two aren't required, but are useful 
+   vertical-separator-snip% ;; for debugging purposes
+   stepper-warning%
+   finished-text
+   stepper-text-test)
+   
+  (define test-dc (make-object bitmap-dc% (make-object bitmap% 1 1)))
+  (define reduct-highlight-color (make-object color% 255 255 255))
+  (define redex-highlight-color (make-object color% 255 255 255))
+  (send test-dc try-color (make-object color% 212 159 245) reduct-highlight-color)
+  (send test-dc try-color (make-object color% 193 251 181) redex-highlight-color)
+  
+  (define error-delta (make-object style-delta% 'change-style 'italic))
+  (send error-delta set-delta-foreground "RED")
+  
+  (define snip-delta (make-object style-delta% 'change-alignment 'top))
+  
+
+;;;;;; copied from /plt/collects/drscheme/snip.ss :
+  
+  (define separator-snipclass
+    (make-object
+        (class snip-class% ()
+          (override read)
+          
+          (define (read s)
+            (let ([size-box (box 0)])
+              (send s get size-box)
+              (make-object separator-snip%)))
+          
+          (super-instantiate ()))))
+  
+  (send* separator-snipclass
+    (set-version 1)
+    (set-classname "drscheme:separator-snip%"))
+  
+  (send (get-the-snip-class-list) add separator-snipclass)
+  
+  ;; the two numbers 1 and 2 which appear here are to line up this snip
+  ;; with the embedded snips around it in the drscheme rep.
+  ;; I have no idea where the extra pixels are going.
+  (define separator-snip%
+    (class snip% ()
+      (inherit get-style set-snipclass set-flags get-flags get-admin)
+      (public reset-width)
+      (override write copy get-extent draw)
+      
+      (define width 800)
+
+      (define (reset-width)
+        (let* ([admin (get-admin)]
+               [reporting-media (send admin get-editor)]
+               [reporting-admin (send reporting-media get-admin)]
+               [widthb (box 0)])
+          (send reporting-admin get-view #f #f widthb #f)
+          (set! width (- (unbox widthb) 2))
+          (send admin resized this #t)))
+      
+      (define (write s)
+        (send s put (char->integer #\r)))
+      
+      (define (copy)
+        (let ([s (make-object separator-snip%)])
+          (send s set-style (get-style))
+          s))
+      
+      (define height 1)
+      (define white-around 2)
+      
+      (define (get-extent dc x y w-box h-box descent-box space-box lspace-box rspace-box)
+        (for-each (lambda (box) (unless (not box) (set-box! box 0)))
+                  (list descent-box space-box lspace-box rspace-box))
+        (unless (not w-box)
+          (set-box! w-box width))
+        (unless (not h-box)
+          (set-box! h-box (+ (* 2 white-around) height))))
+      
+      (define body-pen 
+        (send the-pen-list find-or-create-pen
+              "BLUE" 0 'solid))
+      (define body-brush 
+        (send the-brush-list find-or-create-brush
+              "BLUE" 'solid))
+      
+      (define (draw dc x y left top right bottom dx dy draw-caret)
+            (let ([orig-pen (send dc get-pen)]
+                  [orig-brush (send dc get-brush)])
+              (send dc set-pen body-pen)
+              (send dc set-brush body-brush)
+              
+              (send dc draw-rectangle (+ x 1)
+                    (+ white-around y) width height)
+              
+              (send dc set-pen orig-pen)
+              (send dc set-brush orig-brush)))
+      
+      (super-instantiate ())
+      (set-flags (cons 'hard-newline (get-flags)))
+      (set-snipclass separator-snipclass)))
+
+  ;;;; end of copied region
+
+  ;;;; duplicated for vertical-snip
+  
+  (define red-arrow-bitmap
+    (make-object bitmap% (build-path (collection-path "icons") "red-arrow.bmp") 'bmp))
+
+  (unless (send red-arrow-bitmap ok?)
+    (error 'red-arrow-bitmap "unable to load red-arrow bitmap"))
+  
+  (define vertical-separator-snipclass
+    (make-object
+     (class snip-class% ()
+       (override read)
+       
+       (define (read s)
+         (let ([size-box (box 0)])
+           (send s get size-box)
+           (make-object vertical-separator-snip% 100)))
+       
+       (super-instantiate ()))))
+  
+  (send* separator-snipclass
+    (set-version 1)
+    (set-classname "drscheme:vertical-separator-snip%"))
+  
+  (send (get-the-snip-class-list) add vertical-separator-snipclass)
+  
+  ;; the two numbers 1 and 2 which appear here are to line up this snip
+  ;; with the embedded snips around it in the drscheme rep.
+  ;; I have no idea where the extra pixels are going.
+  (define vertical-separator-snip%
+    (class snip% ()
+      (inherit get-style set-snipclass set-flags get-flags get-admin)
+      (public set-height!)
+      (override write copy get-extent draw)
+      
+      (init-field height)
+      
+
+      (define bitmap-width 15.0)
+      (define left-white 0.0)
+      (define right-white 3.0)
+      (define bitmap-height 10.0)
+      
+      (define (set-height! x) 
+        (set! height (max x bitmap-height)))
+      
+      (define (write s) 
+        (send s put (char->integer #\r)))        ; this can't be right...?
+      
+      (define (copy)
+        (let ([s (make-object vertical-separator-snip% height)])
+          (send s set-style (get-style))
+          s))
+      
+      (define (get-extent dc x y w-box h-box descent-box space-box lspace-box rspace-box)
+        (for-each (lambda (box) (unless (not box) (set-box! box 0)))
+                  (list descent-box space-box lspace-box rspace-box))
+        (unless (not w-box)
+          (set-box! w-box (+ left-white right-white bitmap-width)))
+        (unless (not h-box)
+          (set-box! h-box height)))
+      
+      (define (draw dc x y left top right bottom dx dy draw-caret)
+        (let ([y-offset (round (/ (- height bitmap-height) 2))]
+              [x-offset left-white])
+          (send dc draw-bitmap red-arrow-bitmap (+ x x-offset) (+ y y-offset))))
+      
+      (super-instantiate ())
+      (set-snipclass vertical-separator-snipclass)))
+  
+  
+  ;;;; end of vertical snip-stuff
+  
+  (define stepper-editor-snip%
+    (class editor-snip% ()
+      (inherit get-editor set-min-width set-max-width)
+      (public*
+        [set-new-width
+         (lambda (width canvas)
+           (set-min-width width)
+           (set-max-width width)
+           (let ([editor (get-editor)])
+             (when editor
+               (send editor reset-pretty-print-width width canvas))))])
+      (super-instantiate (#f #f 0 0 0 0 0 0 0 0))))
+                                                                                                              
+                                                                  ;                                    ;;    ;
+       ;                                                          ;              ;                 ;  ;  ;  ; 
+  ;;; ;;;;  ;;;   ; ;;;   ; ;;;    ;;;   ; ;;         ;;;  ;   ;  ; ;;;         ;;;;  ;;;  ;    ; ;;;;;  ; ;  
+ ;     ;   ;   ;  ;;   ;  ;;   ;  ;   ;  ;;          ;     ;   ;  ;;   ;         ;   ;   ;  ;  ;   ;   ;; ;   
+ ;     ;   ;   ;  ;    ;  ;    ;  ;   ;  ;           ;     ;   ;  ;    ;         ;   ;   ;   ;;    ;     ;    
+  ;;   ;   ;;;;;  ;    ;  ;    ;  ;;;;;  ;    ;;;;;   ;;   ;   ;  ;    ;  ;;;;;  ;   ;;;;;   ;;    ;     ; ;; 
+    ;  ;   ;      ;    ;  ;    ;  ;      ;              ;  ;   ;  ;    ;         ;   ;       ;;    ;    ; ;  ;
+    ;  ;   ;      ;;   ;  ;;   ;  ;      ;              ;  ;  ;;  ;;   ;         ;   ;      ;  ;   ;   ;  ;  ;
+ ;;;    ;;  ;;;;  ; ;;;   ; ;;;    ;;;;  ;           ;;;    ;; ;  ; ;;;           ;;  ;;;; ;    ;   ;;;    ;; 
+                  ;       ;                                                                                   
+                  ;       ;                                                                                   
+  
+  ; the stepper-sub-text% class is used to hold an individual list of sexps, with one or more highlights.
+  ; there are four of them in the stepper window.
+  
+  (define stepper-sub-text%
+    (class f:text:standard-style-list% ()
+      
+      (init-field exps highlight-color)
+
+      (inherit insert get-style-list set-style-list change-style highlight-range last-position lock erase
+               begin-edit-sequence end-edit-sequence get-start-position select-all clear)
+      
+      (public* [reset-pretty-print-width
+                (lambda (inner-width canvas)
+                  (begin-edit-sequence)
+                  (let* ([style (send (get-style-list) find-named-style "Standard")]
+                         [char-width (send style get-text-width (send canvas get-dc))]
+                         [width (floor (/ (- inner-width 18) char-width))])
+                    (reformat-sexp width)
+                    (end-edit-sequence)))])
+      
+      (define highlight-table (make-hash-table 'weak))
+      
+      (define stripped-exps
+        (map (lambda (exp) (strip-to-sexp exp highlight-table)) exps))
+      
+      (define pretty-printed-width #f)
+      (define clear-highlight-thunks null)
+      (define/private (reset-style)
+        (change-style (send (get-style-list) find-named-style "Standard")))
+      (define/private (set-last-style)
+        (change-style (send (get-style-list) find-named-style "Standard")
+		      (sub1 (last-position))
+		      (last-position)))
+               
+      (define/private (reformat-sexp width)
+        (when (not (eq? pretty-printed-width width))
+          (set! pretty-printed-width width)
+          (format-whole-step)))
+               
+      (define highlight-begin #f)
+               
+      (inherit get-dc)
+      
+      (define/private (format-sexp sexp)
+        (define text-port (open-output-text-editor this))
+
+        (parameterize ([pretty-print-columns pretty-printed-width]
+                       
+                       ; the pretty-print-size-hook decides whether this object should be printed by the new pretty-print-hook
+                       [pretty-print-size-hook
+                        (lambda (value display? port)
+                          (let ([looked-up (hash-table-get highlight-table value (lambda () #f))])
+                            (cond
+                              [(is-a? value snip%) 
+			       ;; Calculate the effective width of the snip, so that
+			       ;;  too-long lines (as a result of large snips) are broken
+			       ;;  correctly. When the snip is actusally inserted, its width
+			       ;;  will be determined by `(send snip get-count)', but the number
+			       ;;  returned here triggers line breaking in the pretty printer.
+			       (let ([dc (get-dc)]
+                                     [wbox (box 0)])
+                                 (send value get-extent dc 0 0 wbox #f #f #f #f #f)
+                                 (let-values ([(xw dc dc2 dc3) (send dc get-text-extent "x")])
+                                   (max 1 (inexact->exact (ceiling (/ (unbox wbox) xw))))))]
+                              [(and looked-up (not (eq? looked-up 'non-confusable)))
+                               (string-length (format "~s" (car looked-up)))]
+                              [else #f])))]
+                       
+                       [pretty-print-print-hook
+                        ; this print-hook is called for confusable highlights and for images.
+                        (lambda (value display? port)
+                          (let ([to-display (cond 
+					     [(hash-table-get highlight-table value (lambda () #f)) => car]
+					     [else value])])
+                            (cond 
+			     [(is-a? to-display snip%) 
+			      (write-special (send to-display copy) port) (set-last-style)]
+			     [else 
+			      (write-string (format "~s" to-display) port)])))]
+                       [pretty-print-print-line
+                        (lambda (number port old-length dest-columns)
+                          (when (and number (not (eq? number 0)))
+                            (newline port))
+                          0)]
+                       [pretty-print-pre-print-hook
+                        (lambda (value p)
+                          (when (hash-table-get highlight-table value (lambda () #f))
+                            (set! highlight-begin (get-start-position))))]
+                       [pretty-print-post-print-hook
+                        (lambda (value p)
+                          (when (hash-table-get highlight-table value (lambda () #f))
+                            (let ([highlight-end (get-start-position)])
+                              (unless highlight-begin
+                                (error 'format-whole-step "no highlight-begin to match highlight-end"))
+                              (set! clear-highlight-thunks
+                                    (cons (highlight-range highlight-begin highlight-end highlight-color #f #f)
+                                          clear-highlight-thunks))
+                              (set! highlight-begin #f))))]
+                       ;; mflatt: MAJOR HACK - this setting needs to come from the language
+                       ;;  somehow
+                       [read-case-sensitive #t])
+          (pretty-print sexp text-port)))
+             
+      (define/public (format-whole-step)
+        (lock #f)
+        (begin-edit-sequence)
+        (for-each (lambda (fun) (fun)) clear-highlight-thunks)
+        (set! clear-highlight-thunks null)
+        (select-all)
+        (clear)
+        (reset-style)
+        (let loop ([remaining stripped-exps] [first #t])
+          (unless (null? remaining)
+            (unless first (insert #\newline))
+            (format-sexp (car remaining))
+            (loop (cdr remaining) #f)))
+        (end-edit-sequence)
+        (lock #t))
+      
+      (super-instantiate ())))
+  
+                                                   
+                                                                  ;                                                                        ;;    ;
+       ;                                                          ;                                                  ;                 ;  ;  ;  ; 
+  ;;; ;;;;  ;;;   ; ;;;   ; ;;;    ;;;   ; ;;         ;;;  ;   ;  ; ;;;           ;;;   ; ;; ; ;;  ;;;   ; ;;       ;;;;  ;;;  ;    ; ;;;;;  ; ;  
+ ;     ;   ;   ;  ;;   ;  ;;   ;  ;   ;  ;;          ;     ;   ;  ;;   ;         ;   ;  ;;   ;;   ;   ;  ;;          ;   ;   ;  ;  ;   ;   ;; ;   
+ ;     ;   ;   ;  ;    ;  ;    ;  ;   ;  ;           ;     ;   ;  ;    ;         ;   ;  ;    ;    ;   ;  ;           ;   ;   ;   ;;    ;     ;    
+  ;;   ;   ;;;;;  ;    ;  ;    ;  ;;;;;  ;    ;;;;;   ;;   ;   ;  ;    ;  ;;;;;  ;;;;;  ;    ;    ;   ;  ;    ;;;;;  ;   ;;;;;   ;;    ;     ; ;; 
+    ;  ;   ;      ;    ;  ;    ;  ;      ;              ;  ;   ;  ;    ;         ;      ;    ;    ;   ;  ;           ;   ;       ;;    ;    ; ;  ;
+    ;  ;   ;      ;;   ;  ;;   ;  ;      ;              ;  ;  ;;  ;;   ;         ;      ;    ;    ;   ;  ;           ;   ;      ;  ;   ;   ;  ;  ;
+ ;;;    ;;  ;;;;  ; ;;;   ; ;;;    ;;;;  ;           ;;;    ;; ;  ; ;;;           ;;;;  ;    ;     ;;;   ;            ;;  ;;;; ;    ;   ;;;    ;; 
+                  ;       ;                                                                                                                       
+                  ;       ;                                                                                                                       
+  
+  ; the stepper-sub-error-text%, like stepper-sub-text%, fits in one of the four stepper "text" spots.
+  ; it is used for error messages.
+  
+  (define stepper-sub-error-text%
+    (class f:text:standard-style-list% ()
+  
+      (init-field error-msg)
+      
+      (inherit get-style-list last-position set-style-list insert change-style auto-wrap
+               set-max-width)
+      
+      (public* [reset-pretty-print-width 
+                (lambda (inner-width canvas)
+                  (set-max-width inner-width))])
+      
+      (super-instantiate ())
+      (let ([before-error-msg (last-position)])
+        (change-style (send (get-style-list) find-named-style "Standard"))
+        (auto-wrap #t)
+        (insert error-msg)
+        (change-style error-delta before-error-msg (last-position)))))
+                                                                                                   
+                                                                                            ;;    ;
+       ;                                                                                   ;  ;  ; 
+  ;;; ;;;;  ;;;   ; ;;;   ; ;;;    ;;;   ; ;;         ;;;   ;;;   ; ;;  ;   ;   ;;;    ;;; ;  ; ;  
+ ;     ;   ;   ;  ;;   ;  ;;   ;  ;   ;  ;;          ;     ;   ;  ;;  ; ;   ;  ;   ;  ;     ;; ;   
+ ;     ;   ;   ;  ;    ;  ;    ;  ;   ;  ;           ;         ;  ;   ;  ; ;       ;  ;       ;    
+  ;;   ;   ;;;;;  ;    ;  ;    ;  ;;;;;  ;    ;;;;;  ;      ;;;;  ;   ;  ; ;    ;;;;   ;;     ; ;; 
+    ;  ;   ;      ;    ;  ;    ;  ;      ;           ;     ;   ;  ;   ;  ; ;   ;   ;     ;   ; ;  ;
+    ;  ;   ;      ;;   ;  ;;   ;  ;      ;           ;     ;   ;  ;   ;  ;;    ;   ;     ;  ;  ;  ;
+ ;;;    ;;  ;;;;  ; ;;;   ; ;;;    ;;;;  ;            ;;;   ;;;;; ;   ;   ;     ;;;;; ;;;  ;    ;; 
+                  ;       ;                                                                        
+                  ;       ;                                                                        
+                                                                                                   
+  (define stepper-canvas%
+    (class editor-canvas% ()
+      (inherit get-editor)
+      (override*
+        [on-size
+         (lambda (width height)
+           (super on-size width height)
+           (let ([editor (get-editor)])
+             (when editor
+               (send editor reset-width this))))])
+ 
+      (super-instantiate ())))
+                                                                                  
+                                                                           ;;    ;
+       ;                                             ;                 ;  ;  ;  ; 
+  ;;; ;;;;  ;;;   ; ;;;   ; ;;;    ;;;   ; ;;       ;;;;  ;;;  ;    ; ;;;;;  ; ;  
+ ;     ;   ;   ;  ;;   ;  ;;   ;  ;   ;  ;;          ;   ;   ;  ;  ;   ;   ;; ;   
+ ;     ;   ;   ;  ;    ;  ;    ;  ;   ;  ;           ;   ;   ;   ;;    ;     ;    
+  ;;   ;   ;;;;;  ;    ;  ;    ;  ;;;;;  ;    ;;;;;  ;   ;;;;;   ;;    ;     ; ;; 
+    ;  ;   ;      ;    ;  ;    ;  ;      ;           ;   ;       ;;    ;    ; ;  ;
+    ;  ;   ;      ;;   ;  ;;   ;  ;      ;           ;   ;      ;  ;   ;   ;  ;  ;
+ ;;;    ;;  ;;;;  ; ;;;   ; ;;;    ;;;;  ;            ;;  ;;;; ;    ;   ;;;    ;; 
+                  ;       ;                                                       
+                  ;       ;                                                       
+    
+  ; the stepper-text% is the principal inhabitant of the stepper window. It keeps
+  ; track of all of the sexps & error messages in a given step, reformatting as necessary.
+  
+  ; constructor : ((listof sexp) (listof sexp) (listof sexp) (union string #f) (listof sexp) -> )
+  
+  (define stepper-text%
+    (class f:text:standard-style-list% ()
+      
+      (init-field finished-exprs exps post-exps error-msg after-exprs)
+
+      (inherit find-snip insert change-style highlight-range last-position lock erase auto-wrap
+               begin-edit-sequence end-edit-sequence get-start-position get-style-list set-style-list
+               get-admin get-snip-location get-dc needs-update hide-caret)
+      (public* [reset-width 
+                (lambda (canvas)
+                  (lock #f)
+                  (begin-edit-sequence)
+                  (let* ([width-box (box 0)]
+                         [canvas-width (begin (send (get-admin) get-view #f #f width-box #f) (unbox width-box))]
+                         [dc (send canvas get-dc)])
+                    (unless (and old-width (= canvas-width old-width))
+                      (set! old-width canvas-width)
+                      (let* ([minus-cursor-margin (- canvas-width 2)]
+                             [vert-separator-width-box (box 0)]
+                             [_ (send vert-separator get-extent dc 0 0 vert-separator-width-box
+                                      #f #f #f #f #f)]
+                             [vert-separator-width (unbox vert-separator-width-box)]
+                             [minus-center-bar (- minus-cursor-margin vert-separator-width)]
+                             [l-r-box-widths (floor (/ minus-center-bar 2))])
+                        (send top-defs-snip set-new-width minus-cursor-margin canvas)
+                        (send before-snip set-new-width l-r-box-widths canvas)
+                        (send after-snip set-new-width l-r-box-widths canvas)
+                        (send bottom-defs-snip set-new-width minus-cursor-margin canvas)
+                        (coordinate-snip-sizes)
+                        (send horiz-separator-1 reset-width)
+                        (send horiz-separator-2 reset-width)))
+                    (end-edit-sequence)
+                    (lock #t)))])
+
+      (define old-width #f)
+      (define top-defs-snip (make-object stepper-editor-snip%))
+      (define horiz-separator-1 (make-object separator-snip%))
+      (define before-snip (make-object stepper-editor-snip%))
+      (define vert-separator (make-object vertical-separator-snip% 10))
+      (define after-snip (make-object stepper-editor-snip%))
+      (define horiz-separator-2 (make-object separator-snip%))
+      (define bottom-defs-snip (make-object stepper-editor-snip%))
+      (define/private (release-snip-sizes)
+        (for-each (lambda (snip)
+                    (send snip set-min-height 0.0)
+                    (send snip set-max-height 0.0)
+                    (send snip set-max-height 'none))
+                  (list before-snip after-snip)))
+      (define/private (coordinate-snip-sizes)
+        (let* ([get-snip-height
+                (lambda (snip)
+                  (let* ([top-box (box 0)]
+                         [bottom-box (box 0)])
+                    (get-snip-location snip #f top-box #f)
+                    (get-snip-location snip #f bottom-box #t)
+                    (- (unbox bottom-box) (unbox top-box))))]
+               [max-height (apply max (map get-snip-height (list before-snip after-snip)))])
+          (send vert-separator set-height! (- max-height 4))
+          (let ([w-box (box 0)]
+                [h-box (box 0)])
+            (send vert-separator get-extent #f 0 0 w-box h-box #f #f #f #f)
+            (send (send vert-separator get-admin) resized vert-separator #t))))
+      
+      
+
+      (super-instantiate ())
+      (hide-caret #t)
+      (let ([before-position (last-position)])
+        (for-each (lambda (x) (insert x)) (list top-defs-snip (string #\newline) horiz-separator-1
+                               before-snip vert-separator 
+                               after-snip (string #\newline) 
+                               horiz-separator-2 bottom-defs-snip))
+        (change-style snip-delta before-position (last-position)))
+      (send top-defs-snip set-editor 
+            (make-object stepper-sub-text% finished-exprs #f))
+      (send before-snip set-editor
+            (make-object stepper-sub-text% exps redex-highlight-color))
+      (if (eq? error-msg #f)
+          (send after-snip set-editor
+                (make-object stepper-sub-text% post-exps reduct-highlight-color))
+          (send after-snip set-editor
+                (make-object stepper-sub-error-text% error-msg)))
+      (send bottom-defs-snip set-editor
+            (make-object stepper-sub-text% after-exprs #f))
+      (lock #t)))
+  
+  (define finished-text
+    (instantiate (class text% ()
+                   (define/public (reset-width arg)
+                     (void))
+                   
+                   (super-instantiate ())
+                   
+                   (inherit insert lock)
+                   (insert "All of the definitions have been successfully evaluated.")
+                   (lock #t)) 
+      ()))
+  
+  
+  (define (snip? val)
+    (is-a? val snip%))
+  
+  (define warning-color "yellow")
+  (define warning-font (send the-font-list find-or-create-font 18 'decorative 'normal 'bold #f))
+  
+  (define stepper-warning%
+    (class canvas%
+      
+      (init-field warning-str)
+       
+      (inherit get-dc get-client-size)
+      (define/override (on-paint)
+        (let ([dc (get-dc)])
+          (send dc set-font warning-font) 
+          (let-values ([(cw ch) (get-client-size)]
+                       [(tw th dont-care dont-care2) (send dc get-text-extent warning-str)])
+            (send dc set-pen (send the-pen-list find-or-create-pen warning-color 1 'solid))
+            (send dc set-brush (send the-brush-list find-or-create-brush warning-color 'solid))
+            (send dc draw-rectangle 0 0 cw ch)
+            (send dc draw-text 
+                  warning-str
+                  (- (/ cw 2) (/ tw 2))
+                  (- (/ ch 2) (/ th 2))))))
+      
+      (super-instantiate ())
+      (inherit min-width min-height stretchable-height)
+      (let-values ([(tw th dc dc2) (send (get-dc) get-text-extent warning-str warning-font)])
+        (min-width (+ 2 (inexact->exact (ceiling tw))))
+        (min-height (+ 2 (inexact->exact (ceiling th)))))
+      
+      (stretchable-height #f)))
+
+  
+  ;                                                                                          
+  ;                                                                                          
+  ;                                                                                          
+  ;                    ;                                                                     
+  ;                                                                                          
+  ;          ;                             ;                                                 
+  ;    ;;;  ;;;;  ; ;  ;   ; ;;           ;;;;   ;;;             ;;;    ;;;  ;     ;  ; ;;   
+  ;   ;      ;    ;;   ;   ;;  ;           ;    ;   ;           ;      ;   ;  ;   ;   ;;  ;  
+  ;   ;;     ;    ;    ;   ;    ;          ;   ;     ;          ;;    ;    ;   ; ;    ;    ; 
+  ;    ;;    ;    ;    ;   ;    ;  ;;;;;;  ;   ;     ;  ;;;;;;   ;;   ;;;;;;    ;     ;    ; 
+  ;      ;   ;    ;    ;   ;    ;          ;   ;     ;             ;  ;        ; ;    ;    ; 
+  ;      ;   ;    ;    ;   ;;  ;           ;    ;   ;              ;   ;      ;   ;   ;;  ;  
+  ;   ;;;     ;;  ;    ;   ; ;;             ;;   ;;;            ;;;     ;;;; ;     ;  ; ;;   
+  ;                        ;                                                          ;      
+  ;                        ;                                                          ;      
+  ;                        ;                                                          ;      
+  
+  
+  ; strip-to-sexp transforms a syntax-object to an s-expression.  The reason we can't
+  ; just use syntax-object->datum for this is that certain syntax-objects must be
+  ; represented by a gensym'ed pointer into a table.
+                           
+  (define (strip-to-sexp stx highlight-table)
+    (define (strip-regular stx)
+      (let* ([it (if (and (syntax? stx)
+                          (eq? (syntax-property stx 'stepper-hint) 'from-xml))
+                     (strip-xml stx)
+                     stx)]
+             [it
+              (cond [(pair? it)
+                     (cons (strip-regular (car it))
+                           (strip-regular (cdr it)))]
+                    [(syntax? it)
+                     (strip-regular (syntax-e it))]
+                    [else it])]
+             [it
+              (if (and (syntax? stx)
+                       (syntax-property stx 'stepper-highlight))
+                  (if (pair? it) 
+                      (begin
+                        (hash-table-put! highlight-table it 'non-confusable)
+                        it)
+                      (let ([new-sym (gensym "-placeholder")])
+                        (hash-table-put! highlight-table new-sym (list it))
+                        new-sym))
+                  it)])
+        it))
+    
+    ; strip-xml attempts to undo the expansion of quasiquote.  
+    (define (strip-xml stx)
+      ; we'll work on this later.
+      "<xml box here>"
+      ;(instantiate xml-snip% () [eliminate-whitespace-in-tags? #t])
+      )
+    
+    (strip-regular stx))
+                                                                     
+
+  
+  (define (stepper-text-test . args)
+    (let* ([new-frame (make-object frame% "test-frame")]
+           [new-text (apply make-object stepper-text% args)]
+           [new-canvas (make-object stepper-canvas% new-frame new-text)])
+      (send new-canvas min-width 800)
+      (send new-canvas min-height 200)
+      (send new-frame show #t)
+      (send new-text reset-width new-canvas)
+      new-canvas))
+  
+  
+;  (define a
+;    (stepper-text-test (build-stx-with-highlight `((define x 3) 14 15 #f 1))
+;                       (build-stx-with-highlight `((* 13 (hilite (* 15 16)))))
+;                       (build-stx-with-highlight `((hilite (+ 3 4)) (define y 4) 13 14 (+  (hilite 13) (hilite #f)) 13 
+;                                                   298 1 1 (+ (x 398 (hilite (+ x 398))) (hilite (x 398 (+ x 398)))) (hilite #f)))
+;                       #f
+;                       (build-stx-with-highlight `((define y (+ 13 14)) 80))))
+  
+  
+  
+;  (stepper-text-test `() `(uninteresting but long series of lines) `() "This is an error message" `((define x 3 4 5)))
+  
+; (stepper-text-test  `() `() `() "This is another error message" `(poomp))
+
+  )
+
diff --git a/collects/stepper/private/my-macros.ss b/collects/stepper/private/my-macros.ss
new file mode 100644
index 0000000000..2277da0a9f
--- /dev/null
+++ b/collects/stepper/private/my-macros.ss
@@ -0,0 +1,103 @@
+(module my-macros mzscheme
+
+  (require-for-syntax (lib "list.ss"))
+                       
+  ;;;;;;;;;;
+  ;;
+  ;;  paul graham's [ _ ] macro
+  ;;
+  ;;;;;;;;;;
+  
+  (provide lx)
+  
+  (define-syntax (lx stx)
+    (syntax-case stx ()
+      [(lx term)
+       (with-syntax ([binder (datum->syntax-object (syntax term) `_)])
+         (syntax (lambda (binder) term)))]))
+  
+  
+  
+  ;;;;;;;;;;
+  ;;
+  ;;  ccond implementation
+  ;; 
+  ;;;;;;;;;;
+  
+(provide ccond)
+  
+  (define-syntax (ccond stx)
+    (syntax-case stx ()
+      [(_ (question answer) ...)
+       (syntax
+	(cond
+          (question answer) ...
+          (else (error 'ccond "fell off end of cond expression"))))]))
+  
+              
+  
+  ;;;;;;;;;;
+  ;;
+  ;;  2vals implementation
+  ;; 
+  ;;;;;;;;;;
+  
+  (provide 2vals let*-2vals 2vals-first 2vals-second 2vals-map)
+  
+  (define 2vals vector)
+  
+  (define-syntax (let*-2vals stx)
+    (syntax-case stx (let*-2vals)
+      [(let*-2vals () . bodies)
+       (syntax/loc stx (begin . bodies))]
+      [(let*-2vals ([(id-a id-b) rhs] binding ...) . bodies)  ; 2 values in a vector
+       (syntax/loc stx (let* ([_a rhs] [id-a (vector-ref _a 0)] [id-b (vector-ref _a 1)])
+                         (let*-2vals (binding ...) . bodies)))]
+      [(let*-2vals ([id-a rhs] binding ...) . bodies)         ; just 1 value
+       (syntax/loc stx (let* ([id-a rhs]) 
+                         (let*-2vals (binding ...) . bodies)))]))
+  
+  (define-syntax (2vals-first stx)
+    (syntax-case stx (2vals-first)
+      [(2vals-first a)
+       (syntax (vector-ref a 0))]))
+  
+  (define-syntax (2vals-second stx)
+    (syntax-case stx (2vals-second)
+      [(2vals-second a)
+       (syntax (vector-ref a 1))]))
+
+ ; 2vals-map : (('a -> (2vals 'b 'c)) ('a list)) -> (2vals ('b list) ('c list))
+  ;  dual-map is like map, only for a procedure that returns (values a b), and its
+  ;  result is (values a-list b-list)... the contract specifies this more clearly.
+  
+  (define (2vals-map f . lsts)
+    (if (null? (car lsts))
+        (2vals null null)
+        (let*-2vals ([(a b) (apply f (map car lsts))]
+                     [(a-rest b-rest) (apply 2vals-map f (map cdr lsts))])
+          (2vals (cons a a-rest) (cons b b-rest))))))
+
+; test cases
+; (require my-macros)
+;
+;(= (2vals-first (2vals 3 4)) 3)
+;(= (2vals-second (2vals 3 4)) 4)
+;
+;(= 
+; (let*-2vals
+;     ([a (2vals 3 4)]
+;      [(b c) a])
+;   a
+;   c)
+; 4)
+;
+;(make-contract-checker my-type (lambda (x) (= x 3)))
+;
+;(contract-check-my-type? 3 'second-arg)
+;;(contract-check-my-type? 14 'first-arg)
+;
+;((checked-lambda (x (y my-type) (z my-type))
+;    (+ x y z))
+; 3 3 5)
+;
diff --git a/collects/stepper/private/reconstruct.ss b/collects/stepper/private/reconstruct.ss
new file mode 100644
index 0000000000..d015117871
--- /dev/null
+++ b/collects/stepper/private/reconstruct.ss
@@ -0,0 +1,969 @@
+; general assertions about reconstruction:
+; a varref can only occur at the top of a mark-list
+; a varref at the top of the mark-list must either be a top-level-variable
+;  or have a value in some mark somewhere (or both).
+
+(module reconstruct mzscheme
+  (require (prefix kernel: (lib "kerncase.ss" "syntax"))
+           (lib "list.ss")
+           (lib "etc.ss")
+	   (lib "contract.ss")
+           "marks.ss"
+           "model-settings.ss"
+           "shared.ss"
+           "my-macros.ss"
+           "lifting.ss")
+
+  (provide/contract 
+   [reconstruct-completed (-> mark-list? (listof any/c) render-settings? 
+                              syntax?)]
+   [reconstruct-current (-> mark-list? symbol? (listof any/c) render-settings?
+                            (union (listof syntax?)
+                                   (list/c (listof syntax?) (listof syntax?))))]
+   [final-mark-list? (-> mark-list? boolean?)]
+   [skip-step? (-> break-kind? (union mark-list? false/c) render-settings? boolean?)]
+   [step-was-app? (-> mark-list? boolean?)])
+  
+  (define nothing-so-far (gensym "nothing-so-far-"))
+
+  ; the let-glump is a structure that contains the reconstruct-time data about
+  ; a let-binding; that is, the names on the left-hand-side, the expression on
+  ; the right-hand side, and the values computed.
+  
+  (define-struct let-glump (name-set exp val-set))
+
+  ; split-list : ('a -> boolean) (listof 'a) -> (2vals (listof 'a) (listof 'a))
+  ; split-list splits a list into two lists at the first element s.t. (fn element) => true).
+  ; that is, split-list yields the lists A and B such that (append A B) gives the original
+  ; list, and (fn element) => false for all elements in A, and B is either empty or
+  ; (fn (car B)) => true
+  
+ (define (split-list fn lst)
+    (let loop ([remaining lst] [so-far null]) 
+      (cond [(null? remaining)
+             (2vals (reverse so-far) null)]
+            [else
+             (if (fn (car remaining))
+                 (2vals (reverse so-far) remaining)
+                 (loop (cdr remaining) (cons (car remaining) so-far)))])))
+  
+  ; test cases
+  ; (test (2vals '(93 4 2) '(0 2 1)) split-list (lambda (x) (= x 0)) '(93 4 2 0 2 1))
+  ; (test (2vals '(3 4 5) '()) split-list (lambda (x) (= x 0)) '(3 4 5))
+        
+  ; n-split-list : num ('a list) -> ('a list) ('a list)
+  ; n-split-list splits a given list A into two lists B and C, such that B contains the
+  ; first n elements of A, and C contains the rest.
+
+  (define (n-split-list num lst)
+    (when (> num (length lst))
+      (error 'n-split-list "can't split list ~a after ~ath element; not long enough" lst num))
+    (let loop ([count num] [remaining lst] [so-far null])
+      (if (= count 0)
+          (2vals (reverse so-far) remaining)
+          (loop (- count 1) (cdr remaining) (cons (car remaining) so-far)))))
+  
+  ; test cases
+  ; (test (2vals '(a b c) '(d e f)) n-split-list 3 '(a b c d e f))
+  
+  
+  (define (mark-as-highlight stx)
+    (syntax-property stx 'stepper-highlight #t))
+                                                     ;               
+                                                     ;               
+ ; ;;  ;;;    ;;;   ;;;   ; ;;         ;   ;   ;;;   ;  ;   ;   ;;;  
+ ;;   ;   ;  ;     ;   ;  ;;  ;        ;   ;  ;   ;  ;  ;   ;  ;   ; 
+ ;    ;   ;  ;     ;   ;  ;   ;         ; ;       ;  ;  ;   ;  ;   ; 
+ ;    ;;;;;  ;     ;   ;  ;   ;  ;;;;;  ; ;    ;;;;  ;  ;   ;  ;;;;; 
+ ;    ;      ;     ;   ;  ;   ;         ; ;   ;   ;  ;  ;   ;  ;     
+ ;    ;      ;     ;   ;  ;   ;         ;;    ;   ;  ;  ;  ;;  ;     
+ ;     ;;;;   ;;;   ;;;   ;   ;          ;     ;;;;; ;   ;; ;   ;;;; 
+                                                                     
+                                                                     
+  ; recon-value print-converts a value.  If the value is a closure, recon-value
+  ; prints the name attached to the procedure, unless we're on the right-hand-side
+  ; of a let, or unless there _is_ no name.
+  
+  (define recon-value
+    (opt-lambda (val render-settings [assigned-name #f])
+      (if (hash-table-get finished-xml-box-table val (lambda () #f))
+          (syntax-property #`(#%datum . #,val) 'stepper-xml-value-hint 'from-xml-box)
+          (let ([closure-record (closure-table-lookup val (lambda () #f))])     
+            (if closure-record
+                (let* ([mark (closure-record-mark closure-record)]
+                       [base-name (closure-record-name closure-record)])
+                  (if base-name
+                      (let* ([lifted-index (closure-record-lifted-index closure-record)]
+                             [name (if lifted-index
+                                       (construct-lifted-name base-name lifted-index)
+                                       base-name)])
+                        (if (and assigned-name (free-identifier=? base-name assigned-name))
+                            (recon-source-expr (mark-source mark) (list mark) null null render-settings)
+                            #`#,name))
+                      (recon-source-expr (mark-source mark) (list mark) null null render-settings)))
+                (let* ([rendered ((render-settings-render-to-sexp render-settings) val)])
+                  (if (symbol? rendered)
+                      #`#,rendered
+                      #`(#%datum . #,rendered))))))))
+    
+  (define (final-mark-list? mark-list)
+    (and (not (null? mark-list)) (eq? (mark-label (car mark-list)) 'final)))
+
+
+       ;      ;                                                                     ;;;
+       ;                                                          ;                    ;
+  ;;;  ;   ;  ;  ; ;;;         ;    ; ;    ; ;    ;          ;;; ;;;;  ;;;   ; ;;;     ;
+ ;     ;  ;   ;  ;;   ;         ;  ;   ;  ;   ;  ;          ;     ;   ;   ;  ;;   ;    ;
+ ;     ; ;    ;  ;    ;          ;;     ;;     ;;           ;     ;   ;   ;  ;    ;   ;
+  ;;   ;;     ;  ;    ;  ;;;;;   ;;     ;;     ;;    ;;;;;   ;;   ;   ;;;;;  ;    ;  ;
+    ;  ; ;    ;  ;    ;          ;;     ;;     ;;              ;  ;   ;      ;    ;  ;
+    ;  ;  ;   ;  ;;   ;         ;  ;   ;  ;   ;  ;             ;  ;   ;      ;;   ;
+ ;;;   ;   ;  ;  ; ;;;         ;    ; ;    ; ;    ;         ;;;    ;;  ;;;;  ; ;;;   ;
+                 ;                                                           ;
+                 ;                                                           ;
+
+  (define (skip-step? break-kind mark-list render-settings)
+    (case break-kind
+      [(result-value-break)
+       #f]
+      [(result-exp-break)
+       ;; skip if clauses that are the result of and/or reductions
+       (let ([and/or-clauses-consumed (syntax-property (mark-source (car mark-list)) 'stepper-and/or-clauses-consumed)])
+         (and and/or-clauses-consumed
+              (> and/or-clauses-consumed 0)))]
+      [(normal-break)
+       (skip-redex-step? mark-list render-settings)]
+      [(double-break)
+       (not (render-settings-lifting? render-settings))]
+      [(expr-finished-break define-struct-break late-let-break) #f]))
+  
+  (define (skip-redex-step? mark-list render-settings)
+    
+    (define (varref-skip-step? varref)
+      (with-handlers ([exn:fail:contract:variable? (lambda (dc-exn) #f)])
+        (let ([val (lookup-binding mark-list varref)])
+          (equal? (syntax-object->interned-datum (recon-value val render-settings))
+                  (syntax-object->interned-datum (case (syntax-property varref 'stepper-binding-type)
+                                                   ([let-bound]
+                                                    (binding-lifted-name mark-list varref))
+                                                   ([non-lexical]
+                                                    varref)
+                                                   (else
+                                                    (error 'varref-skip-step? "unexpected value for stepper-binding-type: ~e for variable: ~e\n"
+                                                           (syntax-property varref 'stepper-binding-type)
+                                                           varref))))))))
+    
+    (and (pair? mark-list)
+         (let ([expr (mark-source (car mark-list))])
+           (or (kernel:kernel-syntax-case expr #f
+                  [id
+                   (identifier? expr)
+                   (case (syntax-property expr 'stepper-binding-type)
+                       [(lambda-bound) #t]  ; don't halt for lambda-bound vars
+                       [(let-bound)
+                        (varref-skip-step? expr)]
+                       [(non-lexical)
+                        (varref-skip-step? expr)])]
+                  [(#%top . id-stx)
+                   (varref-skip-step? #`id-stx)]
+                  [(#%app . terms)
+                   ; don't halt for proper applications of constructors
+                   (let ([fun-val (lookup-binding mark-list (get-arg-var 0))])
+                     (and (procedure? fun-val)
+                          (procedure-arity-includes? 
+                           fun-val
+                           (length (cdr (syntax->list (syntax terms)))))
+                          (or (and (render-settings-constructor-style-printing? render-settings)
+                                   (if (render-settings-abbreviate-cons-as-list? render-settings)
+                                       (eq? fun-val (find-special-value 'list '(3)))    
+                                       (and (eq? fun-val (find-special-value 'cons '(3 empty)))
+                                            (second-arg-is-list? mark-list))))
+                              ;(model-settings:special-function? 'vector fun-val)
+                              (and (eq? fun-val void)
+                                   (eq? (cdr (syntax->list (syntax terms))) null))
+                              (struct-constructor-procedure? fun-val))))]
+                 [else #f])))))
+  
+  (define (find-special-value name valid-args)
+    (let ([expanded (kernel:kernel-syntax-case (expand (cons name valid-args)) #f
+                      [(#%app fn . rest)
+                       #`fn]
+                      [else (error 'find-special-name "couldn't find expanded name for ~a" name)])])
+      (eval expanded)))
+  
+  (define (second-arg-is-list? mark-list)
+    (let ([arg-val (lookup-binding mark-list (get-arg-var 2))])
+      (list? arg-val)))
+    
+;   ; static-binding-indexer (z:parsed -> integer)
+;  
+;  (define static-binding-indexer
+;    (let* ([name-number-table (make-hash-table)]
+;           [binding-number-table (make-hash-table-weak)])
+;      (lambda (binding)
+;        (cond [(hash-table-get binding-number-table binding (lambda () #f)) =>
+;               (lambda (x) x)]
+;              [else (let* ([orig-name (z:binding-orig-name binding)]
+;                           [old-index (hash-table-get name-number-table orig-name (lambda () -1))]
+;                           [new-index (+ old-index 1)])
+;                      (hash-table-put! name-number-table orig-name new-index)
+;                      (hash-table-put! binding-number-table binding new-index)
+;                      new-index)]))))
+  
+  ; construct-lifted-name 
+  ; (-> syntax? (union num? false/c) symbol?)
+  
+  (define/contract construct-lifted-name
+    (-> syntax? number? syntax?)
+    (lambda (binding dynamic-index)
+      #`#,(string->symbol
+           (string-append (symbol->string (syntax-e binding)) "_" 
+                          (number->string dynamic-index)))))
+  
+  ; binding-lifted-name
+  
+  (define/contract binding-lifted-name
+    (-> mark-list? syntax? syntax?)
+    (lambda (mark-list binding)
+      (construct-lifted-name binding (lookup-binding mark-list (get-lifted-var binding)))))
+
+  
+  (define (step-was-app? mark-list)
+    (and (not (null? mark-list))
+         (syntax-case (mark-source (car mark-list)) (#%app)
+           [(#%app . rest)
+            #t]
+           [else
+            #f])))
+  
+                                                                ;              ;  ;               
+                                                                               ;                  
+ ; ;;; ;;    ;;;    ;;;  ; ;;  ;;;       ;   ;  ; ;;  ;   ;   ; ;  ; ;;    ;;; ;  ;  ; ;;    ;; ; 
+ ;;  ;;  ;  ;   ;  ;     ;;   ;   ;      ;   ;  ;;  ; ;   ;   ; ;  ;;  ;  ;   ;;  ;  ;;  ;  ;  ;; 
+ ;   ;   ;      ;  ;     ;    ;   ;      ;   ;  ;   ;  ; ; ; ;  ;  ;   ;  ;    ;  ;  ;   ;  ;   ; 
+ ;   ;   ;   ;;;;  ;     ;    ;   ;      ;   ;  ;   ;  ; ; ; ;  ;  ;   ;  ;    ;  ;  ;   ;  ;   ; 
+ ;   ;   ;  ;   ;  ;     ;    ;   ;      ;   ;  ;   ;  ; ; ; ;  ;  ;   ;  ;    ;  ;  ;   ;  ;   ; 
+ ;   ;   ;  ;   ;  ;     ;    ;   ;      ;  ;;  ;   ;  ; ; ; ;  ;  ;   ;  ;   ;;  ;  ;   ;  ;  ;; 
+ ;   ;   ;   ;;;;;  ;;;  ;     ;;;        ;; ;  ;   ;   ;   ;   ;  ;   ;   ;;; ;  ;  ;   ;   ;; ; 
+                                                                                                ; 
+  
+  ; unwind takes a syntax object with a single highlight, 
+  ; and returns a list of syntax objects
+  
+  (define (unwind stx lift-at-highlight?)
+    (macro-unwind (lift stx lift-at-highlight?)))
+  
+  ; unwind-no-highlight is really just macro-unwind, but with the 'right' interface that
+  ; makes it more obvious what it does.
+  ; [unwind-no-highlight (-> syntax? (listof syntax?))]
+  
+  (define (unwind-no-highlight stx)
+    (macro-unwind (list stx)))
+  
+  ; unwind-only-highlight : syntax? -> (listof syntax?)
+  (define (unwind-only-highlight stx)
+    (unwind stx #t))
+  
+  (define (first-of-one x) 
+    (unless (= (length x) 1)
+      (error 'first-of-one "expected a list of length one in: ~v" x))
+    (car x))
+  
+  (define (improper-member elt improper-list)
+    (cond [(pair? improper-list)
+           (or (eq? elt (car improper-list))
+               (improper-member elt (cdr improper-list)))]
+          [else
+           (eq? elt improper-list)]))
+  
+  (define-syntax (noisy-and stx)
+    (syntax-case stx ()
+      [(_) #`#t]
+      [(_ a b ...)
+       (with-syntax ([inner (syntax/loc stx (noisy-and b ...))]
+                     [error (syntax/loc #`a (error 'noisy-and "and clause failed"))])
+       (syntax/loc stx (if a inner error)))]
+      [else
+       (error 'noisy-and "bad syntax for noisy-and")]))
+  
+  ;(->* (syntax? (listof syntax?)) 
+  ;     (syntax? (listof syntax?)))
+  
+  (define (macro-unwind stxs)
+    (local
+        ((define (recur-on-pieces stx)
+           (if (pair? (syntax-e stx))
+                (datum->syntax-object stx (syntax-pair-map (syntax-e stx) inner) stx stx)
+                stx))
+         
+         (define (inner stx)
+           (define (fall-through)
+             (kernel:kernel-syntax-case stx #f
+                      [id
+                       (identifier? stx)
+                       (or (syntax-property stx 'stepper-lifted-name)
+                           stx)]
+                      [(define-values dc ...)
+                       (unwind-define stx)]
+                      [(#%app exp ...)
+                       (recur-on-pieces #'(exp ...))]
+                      [(#%datum . datum)
+                       #'datum]
+                      [(let-values . rest)
+                       (unwind-mz-let stx)]
+                      [(letrec-values . rest)
+                       (unwind-mz-let stx)]
+                      [else
+                       (recur-on-pieces stx)]))
+           
+           (transfer-info 
+            (if (syntax-property stx 'user-stepper-hint)
+                (case (syntax-property stx 'user-stepper-hint)
+                  
+                  
+                  [(comes-from-cond) (unwind-cond stx 
+                                                  (syntax-property stx 'user-source)
+                                                  (syntax-property stx 'user-position))]
+                  
+                  [(comes-from-and) (unwind-and/or stx
+                                                   (syntax-property stx 'user-source)
+                                                   (syntax-property stx 'user-position)
+                                                   'and)]
+                  
+                  [(comes-from-or) (unwind-and/or stx
+                                                  (syntax-property stx 'user-source)
+                                                  (syntax-property stx 'user-position)
+                                                  'or)]
+                  
+                  [(comes-from-local)
+                   (unwind-local stx)]
+                  
+                  [(comes-from-recur)
+                   (unwind-recur stx)]
+                  
+                  (else (fall-through)))
+                (fall-through))
+            stx))
+         
+         (define (transfer-highlight from to)
+           (if (syntax-property from 'stepper-highlight)
+               (syntax-property to 'stepper-highlight #t)
+               to))
+         
+         (define (unwind-recur stx)
+           (with-syntax ([(app-keywd letrec-term argval ...) stx]) ; if you use #%app, it gets captured here
+             (with-syntax ([(new-argval ...) (map inner (syntax->list #`(argval ...)))])
+               (let ([unwound (inner #`letrec-term)])
+                 (syntax-case unwound (letrec lambda)
+                   [(letrec ([loop-name (lambda (argname ...) . bodies)]) loop-name-2)
+                    (unless (module-identifier=? #`loop-name #`loop-name-2)
+                      (error "unexpected syntax for 'recur': ~v" stx))
+                    (transfer-highlight unwound #`(recur loop-name ([argname new-argval] ...) . bodies))]
+                   [else #`(#,unwound new-argval ...)])))))
+         
+         (define (unwind-define stx)
+           (kernel:kernel-syntax-case stx #f
+             [(define-values (name . others) body)
+              (unless (null? (syntax-e #'others))
+                (error 'reconstruct "reconstruct fails on multiple-values define: ~v\n" (syntax-object->datum stx)))
+              (let* ([printed-name (or (syntax-property #`name 'stepper-lifted-name)
+                                        (syntax-property #'name 'stepper-orig-name)
+                                        #'name)]
+                     [unwound-body (inner #'body)]
+                     [define-type (syntax-property unwound-body 'user-stepper-define-type)]) ; see notes in internal-docs.txt
+                (if define-type
+                    (kernel:kernel-syntax-case unwound-body #f
+                      [(lambda arglist lam-body ...)
+                       (case define-type
+                         [(shortened-proc-define)
+                          (let ([proc-define-name (syntax-property unwound-body 'user-stepper-proc-define-name)])
+                            (if (or (module-identifier=? proc-define-name #'name)
+                                    (and (syntax-property #'name 'stepper-orig-name)
+                                         (module-identifier=? proc-define-name (syntax-property #'name 'stepper-orig-name))))
+                                #`(define (#,printed-name . arglist) lam-body ...)
+                                #`(define #,printed-name #,unwound-body)))]
+                         [(lambda-define)
+                          #`(define #,printed-name #,unwound-body)]
+                         [else (error 'unwind-define "unknown value for syntax property 'user-stepper-define-type: ~e" define-type)])]
+                      [else (error 'unwind-define "expr with stepper-define-type is not a lambda: ~e" (syntax-object->datum unwound-body))])
+                    #`(define #,printed-name #,unwound-body)))]
+             [else (error 'unwind-define "expression is not a define-values: ~e" (syntax-object->datum stx))]))
+         
+         (define (unwind-mz-let stx)
+           (with-syntax ([(label ([(var) rhs] ...) . bodies) stx])
+             (with-syntax ([(rhs2 ...) (map inner (syntax->list #'(rhs ...)))]
+                           [new-label (if (improper-member 'comes-from-let* (syntax-property stx 'user-stepper-hint))
+                                          #`let*
+                                          (case (syntax-e #'label)
+                                            [(let-values) #'let]
+                                            [(letrec-values) #'letrec]))]
+                           [new-bodies (map inner (syntax->list #'bodies))])
+               (syntax-case #`new-bodies (let*)           ; is this let and the nested one part of a let*?
+                 [((let* bindings inner-body ...))
+                  (and 
+                   (improper-member 'comes-from-let* (syntax-property stx 'user-stepper-hint))
+                   (eq? (syntax-property stx 'user-stepper-source)
+                        (syntax-property (car (syntax->list #`new-bodies)) 'user-stepper-source))
+                   (eq? (syntax-property stx 'user-stepper-position)
+                        (syntax-property (car (syntax->list #`new-bodies)) 'user-stepper-position)))
+                  #`(let* #,(append (syntax->list #`([var rhs2] ...)) (syntax->list #`bindings)) inner-body ...)]
+                 [else
+                  #`(new-label ([var rhs2] ...) . new-bodies)]))))
+         
+         (define (unwind-local stx)
+           (kernel:kernel-syntax-case stx #f
+             [(letrec-values ([vars exp] ...) body) ; at least through intermediate, define-values may not occur in local.
+              (with-syntax ([defns (map inner (syntax->list #`((define-values vars exp) ...)))])
+                  #`(local defns #,(inner #'body)))]
+             [else (error 'unwind-local "expected a letrec-values, given: ~e" (syntax-object->datum stx))]))
+         
+         ;(define (unwind-quasiquote-the-cons-application stx)
+         ;  (syntax-case (recur-on-pieces stx) ()
+         ;    [(#%app the-cons . rest)
+         ;     (syntax (cons . rest))]
+         ;    [else
+         ;     (error 'reconstruct "unexpected result for unwinding the-cons application")]))
+         
+         (define (unwind-cond-clause stx test-stx result-stx)
+           (with-syntax ([new-test (if (syntax-property stx 'user-stepper-else)
+                                       #`else
+                                       (inner test-stx))]
+                         [result (inner result-stx)])
+             #`(new-test result)))
+         
+         (define (unwind-cond stx user-source user-position)
+           (with-syntax ([clauses
+                          (let loop ([stx stx])
+                            (if (and (eq? user-source (syntax-property stx 'user-source))
+                                     (eq? user-position (syntax-property stx 'user-position)))
+                                (syntax-case stx (if begin #%app)
+                                  [(if test result) ; the else clause disappears when it's a language-inserted else clause
+                                   (list (unwind-cond-clause stx #`test #`result))]
+                                  [(if test result else-clause)
+                                   (cons (unwind-cond-clause stx #`test #`result)
+                                         (loop (syntax else-clause)))]
+                                  [(begin . rest) ; else clause appears momentarily in 'before,' even though it's a 'skip-completely'
+                                   null]
+                                  [else-stx
+                                   (error 'unwind-cond "expected an if, got: ~e" (syntax-object->datum (syntax else-stx)))])
+                                (error 'unwind-cond "expected a cond clause expansion, got: ~e" (syntax-object->datum stx))))])
+             (syntax (cond . clauses))))
+         
+         (define (unwind-and/or stx user-source user-position label)
+           (let ([clause-padder (case label
+                                  [(and) #`true]
+                                  [(or) #`false])])
+             (with-syntax ([clauses
+                            (append (build-list (syntax-property stx 'user-stepper-and/or-clauses-consumed) (lambda (dc) clause-padder))
+                                    (let loop ([stx stx])
+                                      (if (and (eq? user-source (syntax-property stx 'user-source))
+                                               (eq? user-position (syntax-property stx 'user-position)))
+                                          (syntax-case stx (if let-values #%datum)
+                                            [(if part-1 part-2 part-3)
+                                             (cons (inner (syntax part-1))
+                                                   (case label
+                                                     ((and)
+                                                      (loop (syntax part-2)))
+                                                     ((or)
+                                                      (loop (syntax part-3)))
+                                                     (else
+                                                      (error 'unwind-and/or "unknown label ~a" label))))]
+                                            [else (error 'unwind-and/or "syntax: ~a does not match and/or patterns" (syntax-object->datum stx))])
+                                          null)))])
+               #`(#,label . clauses)))))
+      
+      (map inner stxs)))
+  
+  
+                                                                       
+                                                                                                               
+ ; ;;  ;;;    ;;;   ;;;   ; ;;           ;;;   ;;;   ;   ;  ; ;;  ;;;   ;;;           ;;;  ;    ;  ; ;;;   ; ;;
+ ;;   ;   ;  ;     ;   ;  ;;  ;         ;     ;   ;  ;   ;  ;;   ;     ;   ;         ;   ;  ;  ;   ;;   ;  ;;  
+ ;    ;   ;  ;     ;   ;  ;   ;         ;     ;   ;  ;   ;  ;    ;     ;   ;         ;   ;   ;;    ;    ;  ;   
+ ;    ;;;;;  ;     ;   ;  ;   ;  ;;;;;   ;;   ;   ;  ;   ;  ;    ;     ;;;;;  ;;;;;  ;;;;;   ;;    ;    ;  ;   
+ ;    ;      ;     ;   ;  ;   ;            ;  ;   ;  ;   ;  ;    ;     ;             ;       ;;    ;    ;  ;   
+ ;    ;      ;     ;   ;  ;   ;            ;  ;   ;  ;  ;;  ;    ;     ;             ;      ;  ;   ;;   ;  ;   
+ ;     ;;;;   ;;;   ;;;   ;   ;         ;;;    ;;;    ;; ;  ;     ;;;   ;;;;          ;;;; ;    ;  ; ;;;   ;   
+                                                                                                   ;           
+                                                                                                   ;           
+                                                                                                               
+
+  ; recon-source-expr 
+  
+  ; recon-source-expr produces the reconstructed version of a given source epxression, using the binding
+  ; information contained in the binding-list.  This happens during reconstruction whenever we come upon
+  ; expressions that we haven't yet evaluated. 
+  
+  ; NB: the variable 'dont-lookup' contains a list of variables whose bindings occur INSIDE the expression
+  ; being evaluated, and hence do NOT yet have values.
+  
+  ; the 'use-lifted-names' vars are those bound by a let which does have lifted names.  it is used in
+  ; rendering the lifting of a let or local to show the 'after' step, which should show the lifted names.
+
+  (define/contract recon-source-expr 
+     (-> syntax? mark-list? binding-set? binding-set? render-settings? syntax?)
+     (lambda (expr mark-list dont-lookup use-lifted-names render-settings)
+      (if (syntax-property expr 'stepper-skipto)
+          (skipto-reconstruct
+           (syntax-property expr 'stepper-skipto)
+           expr
+           (lambda (stx)
+             (recon-source-expr stx mark-list dont-lookup use-lifted-names render-settings)))
+          (if (syntax-property expr 'stepper-prim-name)
+              (syntax-property expr 'stepper-prim-name)
+              (let* ([recur (lambda (expr) (recon-source-expr expr mark-list dont-lookup use-lifted-names render-settings))]
+                     [let-recur (lambda (expr bindings)
+                                  (recon-source-expr expr mark-list (append bindings dont-lookup) use-lifted-names render-settings))]
+                     
+                     [recon-basic
+                      (lambda ()
+                        (with-syntax ([(label . bodies) expr])
+                          #`(label #,@(map recur (filter-skipped (syntax->list (syntax bodies)))))))]
+                     [recon-let/rec
+                      (lambda (rec?)
+                        (with-syntax ([(label  ((vars val) ...) body) expr])
+                          (let* ([bindings (map syntax->list (syntax->list (syntax (vars ...))))]
+                                 [binding-list (apply append bindings)]
+                                 [recur-fn (if rec? 
+                                               (lambda (expr) (let-recur expr binding-list))
+                                               recur)]
+                                 [right-sides (map recur-fn (syntax->list (syntax (val ...))))]
+                                 [recon-body (let-recur (syntax body) binding-list)])
+                            (with-syntax ([(recon-val ...) right-sides]
+                                          [recon-body recon-body]
+                                          [(new-vars ...) (map (lx (map (lx (if (ormap (lambda (binding)
+                                                                                         (bound-identifier=? binding _))
+                                                                                       use-lifted-names)
+                                                                                (syntax-property _
+                                                                                             'stepper-lifted-name
+                                                                                             (binding-lifted-name mark-list _))
+                                                                                _))
+                                                                        _))
+                                                               bindings)])
+                              (syntax (label ((new-vars recon-val) ...) recon-body))))))]
+                     [recon-lambda-clause
+                      (lambda (clause)
+                        (with-syntax ([(args . bodies-stx) clause])
+                          (let* ([arglist (arglist-flatten #'args)]
+                                 [bodies (map (lambda (body) (let-recur body arglist))
+                                              (filter-skipped (syntax->list (syntax bodies-stx))))])
+                            (cons (syntax args) bodies))))]
+                     [recon (kernel:kernel-syntax-case expr #f
+                              
+                              ; lambda
+                              [(lambda . clause-stx)
+                               (let* ([clause (recon-lambda-clause (syntax clause-stx))])
+                                 #`(lambda #,@clause))]
+                              
+                              ; case-lambda
+                              [(case-lambda . clauses-stx)
+                               (let* ([clauses (map recon-lambda-clause (syntax->list (syntax clauses-stx)))])
+                                 #`(case-lambda #,@clauses))]
+                              
+                              ; if, begin, begin0
+                              [(if test then else) (recon-basic)]
+                              [(if test then) (recon-basic)]
+                              [(begin . bodies) (recon-basic)]
+                              [(begin0 . bodies) (recon-basic)]
+                              
+                              ; let-values, letrec-values
+                              [(let-values . rest) (recon-let/rec #f)]
+                              [(letrec-values . rest) (recon-let/rec #t)]
+                              
+                              ; set! : set! doesn't fit into this scheme. It would be a mistake to allow it to proceed.
+                              
+                              ; quote 
+                              [(quote body) (recon-value (syntax-e (syntax body)) render-settings)]
+                              
+                              ; quote-syntax : like set!, the current stepper cannot handle quote-syntax
+                              
+                              ; with-continuation-mark
+                              [(with-continuation-mark . rest) (recon-basic)]
+                              
+                              ; application
+                              [(#%app . terms) (recon-basic)]
+                              
+                              ; #%datum
+                              [(#%datum . datum) 
+                               #`#,(recon-value (syntax-e #'datum) render-settings)]
+                              
+                              ; varref                        
+                              [var-stx
+                               (identifier? expr)
+                               (let* ([var (syntax var-stx)])
+                                 (cond [(eq? (identifier-binding var) 'lexical)
+                                        ; has this varref's binding not been evaluated yet?
+                                        ; (and this varref isn't in the list of must-lookups?)
+                                        (if (and (ormap (lambda (binding)
+                                                     (bound-identifier=? binding var))
+                                                   dont-lookup)
+                                                 (not (ormap (lambda (binding)
+                                                               (bound-identifier=? binding var))
+                                                             use-lifted-names)))
+                                            var
+
+                                            
+                                            (case (syntax-property var 'stepper-binding-type)
+                                              ((lambda-bound) 
+                                               (recon-value (lookup-binding mark-list var) render-settings))
+                                              ((macro-bound)
+                                               ; for the moment, let-bound vars occur only in and/or :
+                                               (recon-value (lookup-binding mark-list var) render-settings))
+                                              ((top-level) var)
+                                              ((let-bound)
+                                               (syntax-property var
+                                                                'stepper-lifted-name
+                                                                (binding-lifted-name mark-list var)))
+                                              ((stepper-temp)
+                                               (error 'recon-source-expr "stepper-temp showed up in source?!?"))
+                                              (else
+                                               (error 'recon-source-expr "unknown 'stepper-binding-type property: ~a" 
+                                                      (syntax-property var 'stepper-binding-type)))))]
+                                       [else ; top-level-varref
+                                        (fixup-name
+                                         var)]))]
+                              [(#%top . var)
+                               (syntax var)]
+                              
+                              [else
+                               (error 'recon-source "no matching clause for syntax: ~a" expr)])])
+                (attach-info recon expr))))))
+  
+  
+  ;; filter-skipped : (listof syntax?) -> (listof syntax?)
+  ;; filter out any elements of the list with 'stepper-skip-completely set, except those with stepper-prim-name set. (HACK).
+  (define (filter-skipped los)
+    (filter (lambda (stx)
+              (or (syntax-property stx 'stepper-prim-name)
+                  (not (syntax-property stx 'stepper-skip-completely))))
+            los))
+ 
+  
+  ;; mflatt: MAJOR HACK - work around the prefix on
+  ;;         beginner name definitions
+  (define (fixup-name s)
+    (let ([m (regexp-match re:beginner: (symbol->string (syntax-e s)))])
+      (if m
+	  (datum->syntax-object s (string->symbol (cadr m)) s s)
+	  s)))
+  (define re:beginner: (regexp "^beginner:(.*)$"))
+                                                                                                        ;                         ; 
+                                       ;                     ;                                          ;         ;               ; 
+ ; ;;  ;;;    ;;;   ;;;   ; ;;    ;;; ;;;; ; ;; ;   ;   ;;; ;;;;         ;;;   ;;;   ; ;;; ;;   ; ;;;   ;   ;;;  ;;;;  ;;;    ;;; ; 
+ ;;   ;   ;  ;     ;   ;  ;;  ;  ;     ;   ;;   ;   ;  ;     ;          ;     ;   ;  ;;  ;;  ;  ;;   ;  ;  ;   ;  ;   ;   ;  ;   ;; 
+ ;    ;   ;  ;     ;   ;  ;   ;  ;     ;   ;    ;   ;  ;     ;          ;     ;   ;  ;   ;   ;  ;    ;  ;  ;   ;  ;   ;   ;  ;    ; 
+ ;    ;;;;;  ;     ;   ;  ;   ;   ;;   ;   ;    ;   ;  ;     ;   ;;;;;  ;     ;   ;  ;   ;   ;  ;    ;  ;  ;;;;;  ;   ;;;;;  ;    ; 
+ ;    ;      ;     ;   ;  ;   ;     ;  ;   ;    ;   ;  ;     ;          ;     ;   ;  ;   ;   ;  ;    ;  ;  ;      ;   ;      ;    ; 
+ ;    ;      ;     ;   ;  ;   ;     ;  ;   ;    ;  ;;  ;     ;          ;     ;   ;  ;   ;   ;  ;;   ;  ;  ;      ;   ;      ;   ;; 
+ ;     ;;;;   ;;;   ;;;   ;   ;  ;;;    ;; ;     ;; ;   ;;;   ;;         ;;;   ;;;   ;   ;   ;  ; ;;;   ;   ;;;;   ;;  ;;;;   ;;; ; 
+                                                                                                ;                                   
+                                                                                                ;                                   
+                                                                                                                                    
+
+  ; reconstruct-completed : reconstructs a completed expression or definition.  
+  
+  (define (reconstruct-completed mark-list vals render-settings)
+    (unless (and (pair? mark-list) (null? (cdr mark-list)) (eq? (mark-label (car mark-list)) 'top-level))
+      (error `reconstruct-completed "expected mark-list of length one with mark having label 'top-level, got: ~a" mark-list))
+    (let skipto-loop ([expr (mark-source (car mark-list))])
+      (cond 
+        [(syntax-property expr 'stepper-skipto) =>
+         (lambda (skipto)
+           (skipto-reconstruct skipto expr
+                               skipto-loop))]
+        [(syntax-property expr 'stepper-define-struct-hint)
+         (error 'reconstruct-completed "define-structs should not be passed to reconstruct-completed")]
+        [else
+         (first-of-one (unwind-no-highlight
+                        (kernel:kernel-syntax-case expr #f
+                          [(define-values vars-stx body)
+                           (let* ([vars (syntax->list #'vars-stx)]
+                                  [recon-vals (map (lambda (val var) 
+                                                     (recon-value val render-settings (or (syntax-property var 'stepper-lifted-name) var))) 
+                                                   vals
+                                                   vars)])
+                             (if (= (length recon-vals) 1)
+                                 (attach-info #`(define-values vars-stx #,(car recon-vals)) expr)
+                                 (attach-info #'(define-values vars-stx (values #,@recon-vals)) expr)))]
+                          [else
+                           (let* ([recon-vals (map (lambda (val)
+                                                     (recon-value val render-settings))
+                                                   vals)])
+                             (if (= (length recon-vals) 1)
+                                 (attach-info (car recon-vals) expr)
+                                 (attach-info #`(values #,@recon-vals) expr)))])))])))
+  
+  ; : (-> syntax? syntax? syntax?)
+  (define (reconstruct-top-level source reconstructed)
+    (cond 
+      [(syntax-property source 'stepper-skipto) =>
+       (lambda (skipto)
+         (skipto-reconstruct skipto source
+                             (lambda (expr)
+                               (reconstruct-top-level expr reconstructed))))]
+      [else
+       (kernel:kernel-syntax-case source #f
+          [(define-values vars-stx body)
+           (attach-info #`(define-values vars-stx #,reconstructed)
+                        source)]
+          [else
+           reconstructed])]))
+  
+                                                                                                                
+                                                                                                                
+                                                                                                                
+                                       ;                     ;                                               ;  
+ ; ;;  ;;;    ;;;   ;;;   ; ;;    ;;; ;;;; ; ;; ;   ;   ;;; ;;;;         ;;;  ;   ;  ; ;; ; ;;  ;;;   ; ;;  ;;;;
+ ;;   ;   ;  ;     ;   ;  ;;  ;  ;     ;   ;;   ;   ;  ;     ;          ;     ;   ;  ;;   ;;   ;   ;  ;;  ;  ;  
+ ;    ;   ;  ;     ;   ;  ;   ;  ;     ;   ;    ;   ;  ;     ;          ;     ;   ;  ;    ;    ;   ;  ;   ;  ;  
+ ;    ;;;;;  ;     ;   ;  ;   ;   ;;   ;   ;    ;   ;  ;     ;   ;;;;;  ;     ;   ;  ;    ;    ;;;;;  ;   ;  ;  
+ ;    ;      ;     ;   ;  ;   ;     ;  ;   ;    ;   ;  ;     ;          ;     ;   ;  ;    ;    ;      ;   ;  ;  
+ ;    ;      ;     ;   ;  ;   ;     ;  ;   ;    ;  ;;  ;     ;          ;     ;  ;;  ;    ;    ;      ;   ;  ;  
+ ;     ;;;;   ;;;   ;;;   ;   ;  ;;;    ;; ;     ;; ;   ;;;   ;;         ;;;   ;; ;  ;    ;     ;;;;  ;   ;   ;;
+                                                                                                                
+                                                                                                                
+                                                                                                                
+  
+  ; reconstruct-current : takes a list of marks, the kind of break, and
+  ; any values that may have been returned at the break point. It produces a list of sexps
+  ; (the result of reconstruction) --- which may contain holes, indicated by the 
+  ; highlight-placeholder --- and a list of sexps which go in the holes
+  
+  (define (reconstruct-current mark-list break-kind returned-value-list render-settings)
+    (local
+        (
+         
+         ; ;;  ;;;    ;;;   ;;;   ; ;;          ;  ; ;;   ; ;;    ;;;   ; ;;
+         ;;   ;   ;  ;     ;   ;  ;;  ;         ;  ;;  ;  ;;  ;  ;   ;  ;;  
+         ;    ;   ;  ;     ;   ;  ;   ;         ;  ;   ;  ;   ;  ;   ;  ;   
+         ;    ;;;;;  ;     ;   ;  ;   ;  ;;;;;  ;  ;   ;  ;   ;  ;;;;;  ;   
+         ;    ;      ;     ;   ;  ;   ;         ;  ;   ;  ;   ;  ;      ;   
+         ;    ;      ;     ;   ;  ;   ;         ;  ;   ;  ;   ;  ;      ;   
+         ;     ;;;;   ;;;   ;;;   ;   ;         ;  ;   ;  ;   ;   ;;;;  ;   
+         
+         
+         (define (recon-inner mark-list so-far)
+           (let* ([recon-source-current-marks 
+                   (lambda (expr)
+                     (recon-source-expr expr mark-list null null render-settings))]
+                  [top-mark (car mark-list)]
+                  [expr (mark-source top-mark)]
+                  
+                  [recon-let
+                   (lambda ()
+                     (with-syntax ([(label ((vars rhs) ...) . bodies) expr])
+                       (let*-2vals ([binding-sets (map syntax->list (syntax->list #'(vars ...)))]
+                                    [binding-list (apply append binding-sets)]
+                                    [glumps 
+                                     (map (lambda (binding-set rhs)
+                                            (make-let-glump
+                                             (map (lambda (binding)
+                                                    (syntax-property binding
+                                                                     'stepper-lifted-name
+                                                                     (binding-lifted-name mark-list binding)))
+                                                 binding-set)
+                                             rhs
+                                             (map (lambda (arg-binding) 
+                                                     (lookup-binding mark-list arg-binding))
+                                                  binding-set)))
+                                          binding-sets
+                                          (syntax->list #`(rhs ...)))]
+                                    [num-defns-done (lookup-binding mark-list let-counter)]
+                                    [(done-glumps not-done-glumps)
+                                     (n-split-list num-defns-done glumps)]
+                                    [recon-lifted 
+                                     (lambda (names expr)
+                                       #`(#,names #,expr))]
+                                    [before-bindings
+                                     (map
+                                      (lambda (glump)
+                                        (let* ([name-set (let-glump-name-set glump)]
+                                               [rhs-val-set (map (lambda (val)
+                                                                   (if (> (length name-set) 0)
+                                                                       (recon-value val render-settings (car name-set))
+                                                                       (recon-value val render-settings))) 
+                                                                 (let-glump-val-set glump))])
+                                          (if (= (length rhs-val-set) 1)
+                                              #`(#,name-set #,@rhs-val-set)
+                                              #`(#,name-set (values #,rhs-val-set)))))
+                                      done-glumps)]
+                                    [reconstruct-remaining-def
+                                     (lambda (glump)
+                                       (let ([rhs-source (let-glump-exp glump)]
+                                             [rhs-name-set (let-glump-name-set glump)])
+                                         (recon-lifted rhs-name-set
+                                                       (recon-source-current-marks rhs-source))))]
+                                    [after-bindings
+                                     (if (pair? not-done-glumps)
+                                         (if (eq? so-far nothing-so-far)
+                                             (map reconstruct-remaining-def not-done-glumps)
+                                             (cons (recon-lifted (let-glump-name-set (car not-done-glumps)) so-far)
+                                                   (map reconstruct-remaining-def (cdr not-done-glumps))))
+                                         null)]
+                                    [recon-bindings (append before-bindings after-bindings)]
+                                    [rectified-bodies (map (lambda (body) (recon-source-expr body mark-list binding-list binding-list render-settings))
+                                                           (syntax->list (syntax bodies)))])
+                         (attach-info #`(label #,recon-bindings #,@rectified-bodies) expr))))])
+             (kernel:kernel-syntax-case expr #f 
+               ; variable references
+               [id
+                (identifier? (syntax id))
+                (if (eq? so-far nothing-so-far)
+                    (recon-source-current-marks expr)
+                    (error 'recon-inner "variable reference given as context: ~a" expr))]
+               
+               [(#%top . id)
+                (if (eq? so-far nothing-so-far)
+                    (recon-source-current-marks expr)
+                    (error 'recon-inner "variable reference given as context: ~a" expr))]
+               
+               ; applications
+               [(#%app . terms)
+                (attach-info
+                 (let* ([sub-exprs (syntax->list (syntax terms))]
+                        [arg-temps (build-list (length sub-exprs) get-arg-var)]
+                        [arg-vals (map (lambda (arg-temp) 
+                                         (lookup-binding mark-list arg-temp))
+                                       arg-temps)])
+                   (case (mark-label (car mark-list))
+                     ((not-yet-called)
+                      (let*-2vals ([(evaluated unevaluated) (split-list (lambda (x) (eq? (cadr x) *unevaluated*))
+                                                                        (zip sub-exprs arg-vals))]
+                                   [rectified-evaluated (map (lx (recon-value _ render-settings)) (map cadr evaluated))])
+                        (if (null? unevaluated)
+                            #`(#%app . #,rectified-evaluated)
+                            #`(#%app 
+                               #,@rectified-evaluated
+                               #,so-far 
+                               #,@(map recon-source-current-marks (cdr (map car unevaluated)))))))
+                     ((called)
+                      (if (eq? so-far nothing-so-far)
+                          (datum->syntax-object #'here `(,#'#%app ...)) ; in unannotated code
+                          (datum->syntax-object #'here `(,#'#%app ... ,so-far ...))))
+                     (else
+                      (error "bad label in application mark in expr: ~a" expr))))
+                 expr)]
+               
+               ; define-struct 
+               ;               
+               ;               [(z:struct-form? expr)
+               ;                 (if (comes-from-define-struct? expr)
+               ;                     so-far
+               ;                     (let ([super-expr (z:struct-form-super expr)]
+               ;                           [raw-type (utils:read->raw (z:struct-form-type expr))]
+               ;                           [raw-fields (map utils:read->raw (z:struct-form-fields expr))])
+               ;                       (if super-expr
+               ;                           `(struct (,raw-type ,so-far)
+               ;                                    ,raw-fields)
+               ;                           `(struct ,raw-type ,raw-fields))))]
+               
+               ; if
+               [(if test then else)
+                (attach-info
+                 (let ([test-exp (if (eq? so-far nothing-so-far)
+                                     (recon-value (lookup-binding mark-list if-temp) render-settings)
+                                     so-far)])
+                   #`(if #,test-exp 
+                         #,(recon-source-current-marks (syntax then))
+                         #,(recon-source-current-marks (syntax else))))
+                 expr)]
+               
+               ; one-armed if
+               
+               [(if test then)
+                (attach-info
+                 (let ([test-exp (if (eq? so-far nothing-so-far)
+                                     (recon-value (lookup-binding mark-list if-temp) render-settings)
+                                     so-far)])
+                   #`(if #,test-exp 
+                         #,(recon-source-current-marks (syntax then))))
+                 expr)]
+               
+               ; quote : there is no break on a quote.
+               
+               ; begin : may not occur directly, but will occur in the expansion of cond, now that I'm no longer
+               ; masking that out with stepper-skipto. Furthermore, exactly one expression can occur inside it.
+               
+               [(begin clause)
+                (attach-info
+                 (if (eq? so-far nothing-so-far)
+                     #`(begin #,(recon-source-current-marks (syntax clause)))
+                     (error 
+                      'recon-inner
+                      "stepper:reconstruct: one-clause begin appeared as context: ~a" (syntax-object->datum expr)))
+                 expr)]
+               
+               ; begin0 : may not occur directly except in advanced
+               
+               ; let-values
+               
+               [(let-values . rest) (recon-let)]
+               
+               [(letrec-values . rest) (recon-let)]
+               
+               ; define-values : define's don't get marks, so they can't occur here
+               
+               ; lambda : there is no break on a lambda
+               
+               [else
+                (error
+                 'recon-inner
+                 "stepper:reconstruct: unknown object to reconstruct: ~a" (syntax-object->datum expr))])))
+         
+         ; the main recursive reconstruction loop is in recon:
+         ; recon : (syntax-object mark-list boolean -> syntax-object)
+         
+         (define (recon so-far mark-list first)
+           (cond [(null? mark-list) ; now taken to indicate a callback:
+                  so-far
+                  ;(error `recon "expcted a top-level mark at the end of the mark list.")
+                  ]
+                 [else
+                  (case (mark-label (car mark-list)) 
+                    [(top-level)
+                     (if (null? (cdr mark-list))
+                         (reconstruct-top-level (mark-source (car mark-list)) so-far)
+                         (error 'recon "top-level-define mark found at non-end of mark list"))]
+                    [else
+                     (let ([reconstructed (recon-inner mark-list so-far)])
+                       (recon
+                        (if first
+                            (mark-as-highlight reconstructed)
+                            reconstructed)
+                        (cdr mark-list)
+                        #f))])]))
+
+         ; uncomment to see all breaks coming in:
+         ; (define _ (printf "break-kind: ~a\ninnermost source: ~a\n" break-kind
+         ;           (and (pair? mark-list)
+         ;                (syntax-object->datum (mark-source (car mark-list))))))
+         
+         (define answer
+           (case break-kind
+             ((result-value-break result-exp-break)
+              (let* ([innermost (if (null? returned-value-list) ; is it an expr -> expr reduction?
+                                    (recon-source-expr (mark-source (car mark-list)) mark-list null null render-settings)
+                                    (recon-value (car returned-value-list) render-settings))])
+                (unwind (recon (mark-as-highlight innermost) (cdr mark-list) #f) #f)))
+             ((normal-break)
+              (unwind (recon nothing-so-far mark-list #t) #f))
+             ((double-break)
+              (let* ([source-expr (mark-source (car mark-list))]
+                     [innermost-before (mark-as-highlight (recon-source-expr source-expr mark-list null null render-settings))]
+                     [newly-lifted-bindings (syntax-case source-expr (letrec-values)
+                                              [(letrec-values ([vars . rest] ...) . bodies)
+                                               (apply append (map syntax->list (syntax->list #`(vars ...))))]
+                                              [(let-values ([vars . rest] ...) . bodies)
+                                               (apply append (map syntax->list (syntax->list #`(vars ...))))]
+                                              [else (error 'reconstruct "expected a let-values as source for a double-break, got: ~e"
+                                                           (syntax-object->datum source-expr))])]
+                     [innermost-after (mark-as-highlight (recon-source-expr (mark-source (car mark-list)) mark-list null newly-lifted-bindings render-settings))])
+                (list (unwind (recon innermost-before (cdr mark-list) #f) #f)
+                      (unwind (recon innermost-after (cdr mark-list) #f) #t))))
+             ((late-let-break)
+              (let* ([one-level-recon (unwind-only-highlight (mark-as-highlight (recon-inner mark-list nothing-so-far)))])
+                (sublist 0 (- (length one-level-recon) 1) one-level-recon)))
+             (else
+              (error 'reconstruct-current-def "unknown break kind: " break-kind)))))
+      
+      answer)))
diff --git a/collects/stepper/private/shared.ss b/collects/stepper/private/shared.ss
new file mode 100644
index 0000000000..e9fe2b9a89
--- /dev/null
+++ b/collects/stepper/private/shared.ss
@@ -0,0 +1,676 @@
+(module shared mzscheme
+  
+  (require "my-macros.ss"
+	   (lib "contract.ss")
+           (lib "list.ss")
+           (lib "etc.ss"))
+
+  ; CONTRACTS
+  
+  (define varref-set? (listof identifier?))
+  (define binding-set? (union varref-set? (symbols 'all)))
+  (define (arglist? v)
+    (or (null? v)
+        (identifier? v)
+        (and (pair? v)
+             ((flat-contract-predicate (cons/c identifier? arglist?)) v))        
+        (and (syntax? v) (null? (syntax-e v)))
+        (and (syntax? v) 
+             ((flat-contract-predicate (cons/c identifier? arglist?)) (syntax-e v)))))
+  
+  (provide/contract
+   ;[varref-set-remove-bindings (-> varref-set? varref-set? varref-set?)]
+   ;[binding-set-varref-set-intersect (-> binding-set? varref-set? binding-set?)]
+   ;[binding-set-union (-> (listof binding-set?) binding-set?)]
+   ;[varref-set-union (-> (listof varref-set?) varref-set?)]
+   [skipto-annotate (-> (listof procedure?) syntax? (-> syntax? syntax?) syntax?)]
+   [skipto-reconstruct (-> (listof procedure?) syntax? (-> syntax? any/c) any/c)]
+   [in-closure-table (-> any/c boolean?)]
+   [sublist (-> number? number? list? list?)]
+   [attach-info (-> syntax? syntax? syntax?)]
+   [transfer-info (-> syntax? syntax? syntax?)]
+   [arglist->ilist (-> arglist? any)]
+   [arglist-flatten (-> arglist? (listof identifier?))])
+  
+  (provide
+   binding-set-union
+   binding-set-pair-union
+   varref-set-union
+   varref-set-pair-union
+   varref-set-remove-bindings
+   binding-set-varref-set-intersect
+   step-result?
+   (struct before-after-result (finished-exprs exp post-exp after-exprs kind))
+   (struct before-error-result (finished-exprs exp err-msg after-exprs))
+   (struct error-result (finished-exprs err-msg))
+   (struct finished-result (finished-exprs))
+   (struct finished-stepping ())
+   list-take
+   list-partition
+   (struct closure-record (name mark constructor? lifted-index))
+   *unevaluated* 
+   no-sexp
+   skipped-step
+   struct-flag
+   multiple-highlight
+   flatten-take
+   closure-table-put!
+   closure-table-lookup
+   get-lifted-var
+   get-arg-var
+   zip
+   let-counter
+   syntax-pair-map
+   make-queue ; -> queue
+   queue-push ; queue val -> 
+   queue-pop ; queue -> val
+   queue-length ; queue -> num
+   rebuild-stx ; datum syntax-object -> syntax-object
+   break-kind? ; predicate
+   varref-set? ; predicate
+   binding-set? ; predicate
+   ; get-binding-name
+   ; bogus-binding?
+   if-temp
+   ; get-lifted-gensym
+   ; expr-read
+   ; set-expr-read!
+   values-map
+   a...b ; a list of numbers from a to b
+   reset-profiling-table ; profiling info
+   get-set-pair-union-stats ; profiling info
+   re-intern-identifier
+   finished-xml-box-table)
+  
+  ; A step-result is either:
+  ; (make-before-after-result finished-exprs exp redex reduct)
+  ; or (make-before-error-result finished-exprs exp redex err-msg)
+  ; or (make-error-result finished-exprs err-msg)
+  ; or (make-finished-result finished-exprs)
+  
+  (define-struct before-after-result (finished-exprs exp post-exp after-exprs kind) (make-inspector))
+  (define-struct before-error-result (finished-exprs exp err-msg after-exprs) (make-inspector))
+  (define-struct error-result (finished-exprs err-msg) (make-inspector))
+  (define-struct finished-result (finished-exprs) (make-inspector))
+  (define-struct finished-stepping () (make-inspector))
+  
+  (define step-result? (union before-after-result? before-error-result? error-result? finished-result? finished-stepping?))
+  
+  ; the closure record is placed in the closure table
+
+  (define-struct closure-record (name mark constructor? lifted-index))
+
+  ; bogus-binding is used so that we can create legal bindings for temporary variables
+  
+  (define (create-bogus-binding name)
+    (let* ([gensymed-name (gensym name)]
+           [binding (datum->syntax-object #'here gensymed-name)])
+      binding))
+  
+  ; make-binding-source creates a pool of bindings, indexed by arbitrary keys. These bindings
+  ; not eq? to any other bindings[*], but a client can always get the same binding by
+  ; invoking the resulting procedure with the same key (numbers work well). make-binding-source
+  ; also takes a string which will be part of the printed representation of the binding's
+  ; name; this makes debugging easier.
+  ; [*] actually, this is not true if you don't use a one-to-one function as the binding-maker
+  ; make-gensym-source : (string -> (key -> binding))
+  
+  (define (make-binding-source id-string binding-maker key-displayer)
+    (let ([assoc-table (make-hash-table 'weak)])
+      (lambda (key)
+        (let ([maybe-fetch (hash-table-get assoc-table key (lambda () #f))])
+          (or maybe-fetch
+              (begin
+                (let* ([new-binding (binding-maker 
+                                     (string-append id-string (key-displayer key) "-"))])
+                  (hash-table-put! assoc-table key new-binding)
+                  new-binding)))))))
+  
+  
+  ; get-arg-var maintains a list of bindings associated with the non-negative
+  ; integers.  These symbols are used in the elaboration of applications; the nth
+  ; in the application is evaluated and stored in a variable whose name is the nth
+  ; gensym supplied by get-arg-var.
+  
+  (define get-arg-var
+    (make-binding-source "arg" create-bogus-binding number->string))
+  
+  ; test cases: (returns #t on success)
+;  (printf "test of get-arg-binding: ~a\n"
+;          (let* ([arg3 (get-arg-var 3)]
+;                 [arg2 (get-arg-var 2)]
+;                 [arg1 (get-arg-var 1)]
+;                 [arg2p (get-arg-var 2)])
+;            (and (not (eq? arg3 arg2))
+;                 (not (eq? arg3 arg1))
+;                 (not (eq? arg3 arg2p))
+;                 (not (eq? arg2 arg1))
+;                 (eq? arg2 arg2p)
+;                 (not (eq? arg1 arg2p)))))
+
+  
+  ; get-lifted-var maintains the mapping between let-bindings and the syntax object
+  ; which is used to capture its index at runtime.
+  ; unfortunately, it can't use "make-binding-source" because you need to compare the items 
+  ; with module-variable=?, which means that hash tables won't work.
+  
+  ; my weak-assoc lists are lists of two-element lists, where the first one is in a weak box.
+  ; furthermore, the whole thing is in a box, to allow it to be banged when needed.
+  
+  (define (weak-assoc-add boxed-lst key value)
+       (set-box! boxed-lst (cons (list (make-weak-box key) value) (unbox boxed-lst))))
+  
+  (define (weak-assoc-search boxed-lst key eq-fun)
+    (let* ([lst (unbox boxed-lst)]
+           [found-val #f]
+           [stripped (let loop ([remaining lst])
+                       (if (null? remaining)
+                           null
+                           (let* ([first (car remaining)]
+                                  [first-key (weak-box-value (car first))])
+                             (if first-key
+                                 (if (eq-fun key first-key)
+                                     (begin 
+                                       (set! found-val (cadr first))
+                                       remaining)
+                                     (cons first
+                                           (loop (cdr remaining))))
+                                 (loop (cdr remaining))))))])
+      (set-box! boxed-lst stripped)
+      found-val))
+  
+  ; test cases:
+  ;  (define wa (box null))
+  ;  (define-struct test ())
+  ;  (weak-assoc-add wa 3 4)
+  ;  (weak-assoc-add wa 9 10)
+  ;  (= (weak-assoc-search wa 3 =) 4)
+  ;  (= (weak-assoc-search wa 9 =) 10)
+  ;  (= (weak-assoc-search wa 3 =) 4)
+  ;  (= (length (unbox wa)) 2)
+  ;  (define my-struct (make-test))
+  ;  (weak-assoc-add wa my-struct 14)
+  ;  (= (length (unbox wa)) 3)
+  ;  (= (weak-assoc-search wa my-struct eq?) 14)
+  ;  (set! my-struct #f)
+  ;  (collect-garbage)
+  ;  (= (length (unbox wa)) 3)
+  ;  (= (weak-assoc-search wa 3 =) 4)
+  ;  (= (length (unbox wa)) 2)
+  
+  (define lifted-index 0)
+  (define (next-lifted-symbol str)
+    (let ([index lifted-index]) 
+      (set! lifted-index (+ lifted-index 1))
+      (datum->syntax-object #'here (string->symbol (string-append str (number->string index))))))
+ 
+  (define get-lifted-var
+   (let ([assoc-table (box null)])
+      (lambda (stx)
+        (let ([maybe-fetch (weak-assoc-search assoc-table stx module-identifier=?)])
+          (or maybe-fetch
+              (begin
+                (let* ([new-binding (next-lifted-symbol
+                                     (string-append "lifter-" (format "~a" (syntax-object->datum stx)) "-"))])
+                  (weak-assoc-add assoc-table stx new-binding)
+                  new-binding)))))))
+  
+  (define if-temp (syntax-property (datum->syntax-object #'here 'if-temp) 'stepper-binding-type 'stepper-temp))
+
+  ; gensyms needed by many modules:
+
+  ; no-sexp is used to indicate no sexpression for display.
+  ; e.g., on an error message, there's no sexp.
+  (define no-sexp (gensym "no-sexp-"))
+  
+  ; skipped-step is used to indicate that the "before" step was skipped.
+  (define skipped-step (gensym "skipped-step-"))
+
+  ; multiple-highlight is used to indicate multiple highlighted expressions
+  (define multiple-highlight (gensym "multiple-highlight-"))
+  
+  ; *unevaluated* is the value assigned to temps before they are evaluated. It's not a symbol so
+  ; it won't need quoting in the source.  Bit of a hack, I know.
+  (define-struct *unevaluated-struct* ())
+  (define *unevaluated* (make-*unevaluated-struct*))
+ 
+  ; struct-flag : uninterned symbol
+  (define struct-flag (gensym "struct-flag-"))
+  
+  ; list-partition takes a list and a number, and returns a 2vals containing 2 lists; the first one contains the
+  ; first n elements of the list, and the second contains the remainder.  If n is greater than
+  ; the length of the list, the exn:application:mismatch exception is raised.
+  
+  (define (list-partition lst n)
+    (if (= n 0)
+        (2vals null lst)
+        (if (null? lst)
+            (list-ref lst 0) ; cheap way to generate exception
+            (let*-2vals ([(first rest) (list-partition (cdr lst) (- n 1))])
+              (2vals (cons (car lst) first) rest)))))
+  
+;  (define expr-read read-getter)
+;  (define set-expr-read! read-setter)
+  
+  (define (list-take n a-list)
+    (if (= n 0)
+        null
+        (cons (car a-list) (list-take (- n 1) (cdr a-list)))))
+  
+  (define (flatten-take n a-list)
+    (apply append (list-take n a-list)))
+  
+  (define-values (closure-table-put! closure-table-lookup in-closure-table)
+    (let ([closure-table (make-hash-table 'weak)])
+      (values
+       (lambda (key value)
+	 (hash-table-put! closure-table key value)
+	 key)                                  ; this return allows a run-time-optimization
+       (lambda args ; key or key & failure-thunk
+         (apply hash-table-get closure-table args))
+       (lambda (key)
+         (let/ec k
+           (hash-table-get closure-table key (lambda () (k #f)))
+           #t)))))
+  
+  ;(begin (closure-table-put! 'foo 'bar)
+  ;       (and (eq? (in-closure-table 'blatz) #f)
+  ;            (eq? (in-closure-table 'foo) #t)))
+ 
+  
+  ;; arglist : for our puposes, an ilist is defined like this:
+  ;; arglist : (union identifier? null? (cons identifier? arglist?) (syntax (cons identifier? arglist?))
+  ;; ... where an ilist val can be anything _except_ a pair or null
+
+  ;; arglist->ilist : turns an (possibly improper) arglist into a (possibly improper) list of syntax objects
+
+  (define (arglist->ilist arglist)
+    (let loop ([ilist arglist])
+      (cond [(identifier? ilist)
+             ilist]
+            [(pair? ilist)
+             (cons (car ilist)
+                   (loop (cdr ilist)))]
+            [(and (syntax? ilist) (pair? (syntax-e ilist)))
+             (loop (syntax-e ilist))]
+            [(null? ilist) null])))
+  
+  ; arglist-flatten : produces a list containing the elements of the ilist
+
+  (define (arglist-flatten arglist)
+    (let loop ([ilist arglist])
+      (cond [(identifier? ilist)
+             (cons ilist null)]
+            [(or (null? ilist) (and (syntax? ilist) (null? (syntax-e ilist))))
+             null]
+            [(pair? ilist)
+             (cons (car ilist) (loop (cdr ilist)))]
+            [(and (syntax? ilist)
+                  (pair? (syntax-e ilist)))
+             (loop (syntax-e ilist))])))
+  
+  ; zip : (listof 'a) (listof 'b) (listof 'c) ... -> (listof (list 'a 'b 'c ...))
+  ; zip reshuffles lists of items into a list of item-lists.  Look at the contract, okay?
+  
+  (define zip
+    (lambda args
+      (apply map list args)))
+  
+  (define let-counter (syntax-property #'let-counter 'stepper-binding-type 'stepper-temp))
+  
+ 
+  ; syntax-pair-map (using the def'ns of the MzScheme docs):
+  
+  (define (syntax-pair-map pair fn)
+    (cons (fn (car pair))
+          (cond [(syntax? (cdr pair))
+                 (fn (cdr pair))]
+                [(pair? (cdr pair))
+                 (syntax-pair-map (cdr pair) fn)]
+                [(null? (cdr pair))
+                 null])))
+  
+  (define (make-queue)
+    (box null))
+  
+  (define (queue-push queue new)
+    (set-box! queue (append (unbox queue) (list new))))
+
+  (define (queue-pop queue)
+    (if (null? (unbox queue))
+        (error 'queue-pop "no elements in queue")
+        (let ([first (car (unbox queue))])
+          (set-box! queue (cdr (unbox queue)))
+          first)))
+  
+  (define (queue-length queue)
+    (length (unbox queue)))
+  
+  (define (rebuild-stx new old)
+    (syntax-recertify (datum->syntax-object old new old old)
+                      old
+                      (current-code-inspector)
+                      #f))
+  
+  (define break-kind?
+    (symbols 'normal-break 'result-exp-break 'result-value-break 'double-break 'late-let-break 'expr-finished-break 'define-struct-break))
+
+  ; functional update package
+
+  (define (swap-args 2-arg-fun)
+    (lambda (x y)
+      (2-arg-fun y x)))
+  
+  (define second-arg (lambda (dc y) y))
+  
+  (define up-mappings
+    `((rebuild ((,car ,(lambda (stx new) (cons new (cdr stx))))
+                (,cdr ,(lambda (stx new) (cons (car stx) new)))
+                (,syntax-e ,(swap-args rebuild-stx))))
+      (discard ((,car ,second-arg)
+                (,cdr ,second-arg)
+                (,syntax-e ,second-arg)))))
+  
+  (define (update fn-list val fn traversal)
+    (if (null? fn-list)
+        (fn val)
+        (let* ([down (car fn-list)]
+               [up (cadr (assq down (cadr (assq traversal up-mappings))))])
+          (up val (update (cdr fn-list) (down val) fn traversal)))))
+ 
+  (define (skipto-annotate fn-list stx annotater)
+    (update fn-list stx annotater 'rebuild))
+
+    ; test cases
+;  (equal? (syntax-object->datum (skipto-annotate (list syntax-e car syntax-e cdr cdr car) #'((a b c) (d e f) (g h i)) (lambda (dc) #'foo)))
+;          '((a b foo) (d e f) (g h i)))
+
+  
+  (define (skipto-reconstruct fn-list stx reconstructer)
+    (update fn-list stx reconstructer 'discard))
+  
+  
+  ; BINDING-/VARREF-SET FUNCTIONS
+  
+  ; note: a BINDING-SET which is not 'all may be used as a VARREF-SET.
+  ; this is because they both consist of syntax objects, and a binding
+  ; answers true to bound-identifier=? with itself, just like a varref
+  ; in the scope of that binding would.
+  
+  ; binding-set-union: (listof BINDING-SET) -> BINDING-SET
+  ; varref-set-union: (listof VARREF-SET) -> VARREF-SET
+  
+  (define profiling-table (make-hash-table 'equal))
+  (define (reset-profiling-table)
+    (set! profiling-table (make-hash-table 'equal)))
+  
+  
+  (define (get-set-pair-union-stats) (hash-table-map profiling-table (lambda (k v) (list k (unbox v)))))
+  
+  
+  ; test cases :
+  ; (profiling-table-incr 1 2)
+  ; (profiling-table-incr 2 3)
+  ; (profiling-table-incr 2 1)
+  ; (profiling-table-incr 1 2)
+  ; (profiling-table-incr 2 1)
+  ;
+  ; (equal? (get-set-pair-union-stats)
+  ;         `(((2 . 3) 1) ((2 . 1) 2) ((1 . 2) 2)))
+    
+  ; until this remove* goes into list.ss?
+  
+  (define (set-pair-union a-set b-set comparator)
+    (cond [(null? b-set) a-set]
+          [(null? a-set) b-set]
+          [else (append (remove* a-set b-set comparator) a-set)]))
+  
+  (define (varref-set-pair-union a-set b-set)
+    (set-pair-union a-set b-set free-identifier=?))
+  
+  (define (binding-set-pair-union a-set b-set)
+    (cond [(eq? a-set 'all) 'all]
+          [(eq? b-set 'all) 'all]
+          [else (set-pair-union a-set b-set eq?)]))
+  
+  (define (pair-union->many-union fn)
+    (lambda (args)
+      (foldl fn null args)))
+  
+  (define binding-set-union
+    (pair-union->many-union binding-set-pair-union))
+  
+  (define varref-set-union
+    (pair-union->many-union varref-set-pair-union))
+      
+
+  ; binding-set-varref-set-intersect : BINDING-SET VARREF-SET -> BINDING-SET
+  ; return the subset of varrefs that appear in the bindings
+  
+  (define (binding-set-varref-set-intersect bindings varrefs)
+    (cond [(eq? bindings 'all) varrefs]
+          [else (filter (lambda (varref)
+                          (ormap (lambda (binding)
+                                   (bound-identifier=? binding varref))
+                                 bindings))
+                        varrefs)]))
+  
+  ; varref-set-remove-bindings : VARREF-SET (BINDING-SET - 'all) -> VARREF-SET
+  ; remove bindings from varrefs
+  
+  (define (varref-set-remove-bindings varrefs bindings)
+    (cond [(eq? bindings 'all)
+           (error 'varref-set-remove-bindings "binding-set 'all passed as second argument, first argument was: ~s" varrefs)]
+          [else (remove* bindings varrefs bound-identifier=?)]))
+  
+  ; sublist returns the list beginning with element <begin> and ending just before element <end>.
+  ; (-> number? number? list? list?)
+  (define (sublist begin end lst) 
+    (if (= end 0) 
+        null
+        (if (= begin 0)
+            (cons (car lst)
+                  (sublist 0 (- end 1) (cdr lst)))
+            (sublist (- begin 1) (- end 1) (cdr lst)))))
+  
+  
+  ; attach-info : SYNTAX-OBJECT SYNTAX-OBJECT -> SYNTAX-OBJECT
+  ; attach-info attaches to a generated piece of syntax the origin & source information of another.
+  ; we do this so that macro unwinding can tell what reconstructed syntax came from what original syntax
+  (define (attach-info stx expr)
+    (let* ([it (syntax-property stx 'user-origin (syntax-property expr 'origin))]
+           [it (syntax-property it 'user-stepper-hint (syntax-property expr 'stepper-hint))]
+           [it (syntax-property it 'user-stepper-else (syntax-property expr 'stepper-else))]
+           [it (syntax-property it 'user-stepper-define-type (syntax-property expr 'stepper-define-type))]
+           [it (syntax-property it 'user-stepper-proc-define-name (syntax-property expr 'stepper-proc-define-name))]
+           [it (syntax-property it 'user-stepper-and/or-clauses-consumed (syntax-property expr 'stepper-and/or-clauses-consumed))]
+           [it (syntax-property it 'stepper-xml-hint (syntax-property expr 'stepper-xml-hint))]
+           [it (syntax-property it 'user-source (syntax-source expr))]
+           [it (syntax-property it 'user-position (syntax-position expr))])
+      it))
+  
+  (define (transfer-info stx expr)
+    (let* ([it (syntax-property stx 'user-origin (syntax-property expr 'user-origin))]
+           [it (syntax-property it 'user-stepper-hint (syntax-property stx 'user-stepper-hint))]
+           [it (syntax-property it 'user-stepper-else (syntax-property expr 'user-stepper-else))]
+           [it (syntax-property it 'user-stepper-define-type (syntax-property expr 'user-stepper-define-type))]
+           [it (syntax-property it 'user-stepper-proc-define-name (syntax-property expr 'user-stepper-proc-define-name))]
+           [it (syntax-property it 'user-stepper-and/or-clauses-consumed (syntax-property expr 'user-stepper-and/or-clauses-consumed))]
+           [it (syntax-property it 'stepper-xml-hint (syntax-property expr 'stepper-xml-hint))]
+           [it (syntax-property it 'user-source (syntax-property expr 'user-source))]
+           [it (syntax-property it 'user-position (syntax-property expr 'user-position))]
+           [it (syntax-property it 'stepper-highlight (or (syntax-property expr 'stepper-highlight)
+                                                          (syntax-property it 'stepper-highlight)))])
+      it))
+  
+  (define (values-map fn . lsts)
+  (apply values (apply map list
+                       (apply map (lambda args (call-with-values (lambda () (apply fn args)) list))
+                              lsts))))
+  
+  ; produces the list of numbers from a to b (inclusive)
+  (define (a...b a b)
+    (if (= a b)
+        (list a)
+        (cons a (a...b (+ a 1) b))))
+  
+  ;; re-intern-identifier : (identifier? -> identifier?)
+  ;; re-intern-identifier : some identifiers are uninterned, which breaks
+  ;; test cases.  re-intern-identifier takes an identifier to a string
+  ;; and back again to make in into an interned identifier.
+  (define (re-intern-identifier identifier)
+    #`#,(string->symbol (symbol->string (syntax-e identifier))))
+  
+  
+  (provide/contract [syntax-object->hilite-datum ((syntax?) ; input
+                                                  (boolean?) ; ignore-highlight?
+                                                  . opt-> .
+                                                  any/c)]) ; sexp with explicit tags
+  
+  ;; syntax-object->hilite-datum : takes a syntax object with zero or more
+  ;; subexpressions tagged with the 'stepper-highlight', 'stepper-xml-hint', and 'stepper-xml-value-hint' syntax-properties
+  ;; and turns it into a datum, where expressions with the named
+  ;; properties result in (hilite <datum>), (xml-box <datum>), (scheme-box <datum>) and (splice-box <datum>) rather than <datum>. It also
+  ;; re-interns all identifiers.  In cases where a given expression has more than one of these, they appear in the order
+  ;; listed.  That is, an expression with both highlight and xml-box annotations will result it (hilite (xml-box <datum>))
+  ;; 
+  ;; this procedure is useful in checking the output of the stepper.
+  
+  (define syntax-object->hilite-datum
+    (opt-lambda (stx [ignore-highlight? #f])
+      (let ([datum (syntax-case stx ()
+                     [(a . rest) (cons (syntax-object->hilite-datum #`a) (syntax-object->hilite-datum #`rest))]
+                     [id
+                      (identifier? stx)
+                      (string->symbol (symbol->string (syntax-e stx)))]
+                     [else (if (syntax? stx)
+                               (syntax-object->datum stx)
+                               stx)])])
+        (let* ([it (case (syntax-property stx 'stepper-xml-hint)
+                     [(from-xml-box) `(xml-box ,datum)]
+                     [(from-scheme-box) `(scheme-box ,datum)]
+                     [(from-splice-box) `(splice-box ,datum)]
+                     [else datum])]
+               [it (case (syntax-property stx 'stepper-xml-value-hint)
+                     [(from-xml-box) `(xml-box-value ,it)]
+                     [else it])]
+               [it (if (and (not ignore-highlight?)
+                            (syntax-property stx 'stepper-highlight))
+                       `(hilite ,it)
+                       it)])
+          it))))
+  
+  ;; finished-xml-box-table : this table tracks values that are the result
+  ;; of evaluating xml boxes.  These values should be rendered as xml boxes,
+  ;; and not as simple lists.
+  
+  (define finished-xml-box-table (make-hash-table 'weak))
+  
+  (provide/contract [syntax-object->interned-datum (syntax? ; input
+                                                    . -> .
+                                                    any)]) ; sexp 
+  
+  ;; syntax-object->interned-datum : like syntax-object->datum, except
+  ;; that it re-interns all identifiers.  Useful in checking whether
+  ;; two sexps will have the same printed representation.
+  
+  (define (syntax-object->interned-datum stx)
+    (syntax-case stx ()
+      [(a . rest) (cons (syntax-object->interned-datum #`a) (syntax-object->interned-datum #`rest))]
+      [id
+       (identifier? stx)
+       (string->symbol (symbol->string (syntax-e stx)))]
+      [else (if (syntax? stx)
+                (syntax-object->datum stx)
+                stx)]))
+  
+  
+  ;; the xml-snip-creation@ unit accepts the xml-snip% and scheme-snip% classes and provides
+  ;; functions which map a "spec" to an xml-snip.
+  ;; An xml-spec is (listof xml-spec-elt)
+  ;; An xml-spec-elt is either
+  ;;  - a string,
+  ;;  - (cons/c 'scheme-box scheme-spec), or
+  ;;  - (cons/c 'splice-box scheme-spec)
+  ;;
+  ;; A scheme-spec is (listof scheme-spec-elt)
+  ;; A scheme-spec-elt is either
+  ;;  - a string, or
+  ;;  - (cons ... oh crud.
+  #;(define xml-snip-creation@
+    (unit/sig (create-xml-snip create-scheme-snip create-splice-snip)
+      (import (xml-snip% scheme-snip%))
+      
+      (define (construct-xml-box spec)
+        (let* ([new-xml-box (instantiate xml-snip% () 
+                              [eliminate-whitespace-in-empty-tags? #t])] ;  need to check what the languages themselves do here
+               [xml-editor (send new-xml-box get-editor)])
+          (for-each
+           (match-lambda
+            [`(scheme-box ,@(schemeboxspec ...)) (send new-xml-box insert (construct-scheme-box #f schemeboxspec))]
+            [`(splice-box ,@(spliceboxspec ...)) (send new-xml-box insert (construct-scheme-box #f spliceboxspec))]
+            [(? string? text) (send xml-editor insert text)])
+           spec)
+          new-xml-box))
+      
+      (define (construct-scheme-box splice? spec)
+        (let* ([new-scheme-box (instantiate scheme-snip% () [splice? splice?])]
+               [scheme-editor (send new-scheme-box get-editor)])
+          (for-each 
+           (match-lambda
+            [`(xml-box ,@(xmlspec ...)) (send scheme-editor insert (construct-xml-box xmlspec))]
+            [(? string? text) (send scheme-editor insert text)])
+           spec)))))
+
+  )
+  
+; test cases
+;(require shared)
+;(load "/Users/clements/plt/tests/mzscheme/testing.ss")
+;
+;(define (a sym) 
+;  (syntax-object->datum (get-lifted-var sym)))
+;(define cd-stx 
+;  (datum->syntax-object #f 'cd))
+;(test 'lifter-ab-0  a (datum->syntax-object #f 'ab))
+;(test 'lifter-cd-1 a cd-stx)
+;(test 'lifter-ef-2 a (datum->syntax-object #f 'ef))
+;(test 'lifter-cd-1 a cd-stx)
+;
+;(test '(a b c) map syntax-e (arglist->ilist #'(a b c)))
+;(test '(a b c) map syntax-e (arglist->ilist #'(a . (b c))))
+;(test 'a syntax-e (arglist->ilist #'a))
+;(let ([result (arglist->ilist #' (a b . c))])
+;  (test 'a syntax-e (car result))
+;  (test 'b syntax-e (cadr result))
+;  (test 'c syntax-e (cddr result)))
+;(test '(a b c) map syntax-e (arglist-flatten #'(a b c)))
+;(test '(a b c) map syntax-e (arglist-flatten #'(a . (b c))))
+;(test '(a b c) map syntax-e (arglist-flatten #'(a b . c)))
+;(test '(a) map syntax-e (arglist-flatten #'a))
+;
+;(define (add1 x) (+ x 1))
+;(test '(3 4 5) ilist-map add1 '(2 3 4))
+;(test '(3 4 . 5) ilist-map add1 '(2 3 . 4))
+;
+;(test '(2 3 4) ilist-flatten '(2 3 4))
+;(test '(2 3 4) ilist-flatten '(2 3 . 4))
+;
+;(define new-queue (make-queue))
+;(test (void) queue-push new-queue 1)
+;(test (void) queue-push new-queue 2)
+;(test 1 queue-pop new-queue)
+;(test (void) queue-push new-queue 3)
+;(test 2 queue-pop new-queue)
+;(test 3 queue-pop new-queue)
+;(err/rt-test (queue-pop new-queue) exn:user?)
+
+;(equal?
+; (call-with-values (lambda ()
+;                     (values-map (lambda (a b) (values (+ a b) (- a b)))
+;                                 `(1 2 3 4 5)
+;                                 `(9 8 7 6 5)))
+;                   (lambda (sums diffs)
+;                     (list sums diffs)))
+; `((10 10 10 10 10)
+;   (-8 -6 -4 -2 0)))
diff --git a/collects/stepper/private/testing-shared.ss b/collects/stepper/private/testing-shared.ss
new file mode 100644
index 0000000000..a31bb10682
--- /dev/null
+++ b/collects/stepper/private/testing-shared.ss
@@ -0,0 +1,62 @@
+(module testing-shared mzscheme
+  (require (lib "contract.ss")
+           "shared.ss"
+           (lib "kerncase.ss" "syntax")
+           (lib "file.ss"))
+  
+  (provide/contract [build-stx-with-highlight ((union (listof any/c) string?) ; input with one or more '(hilite ...) tags
+                                               . -> .
+                                               (listof syntax?))]) ; result
+  
+  (define (build-stx-with-highlight input)
+    (let ([temp-file (make-temporary-file)])
+      (call-with-output-file temp-file
+        (lambda (port)
+          (if (string? input)
+              (display input port)
+              (map (lambda (sexp) (write sexp port) (display #\space port)) input)))
+        'truncate)
+      (begin0
+        (let ([file-port (open-input-file temp-file)])
+          (let read-loop ([stx (read-syntax temp-file file-port)])
+            (if (eof-object? stx)
+                null
+                (cons
+                 (let stx-loop ([stx stx])
+                   (syntax-case stx (hilite)
+                     [(hilite x)
+                      (syntax-property (stx-loop #`x) 'stepper-highlight #t)]
+                     [(a . rest) (datum->syntax-object stx (cons (stx-loop #`a) (stx-loop #`rest)) stx stx)]
+                     [else stx]))
+                 (read-loop (read-syntax temp-file file-port))))))
+        (delete-file temp-file))))
+  
+;  (require (lib "mz-testing.ss" "tests" "utils")
+;           (lib "sexp-diff.ss" "tests" "utils"))
+; (test `((define a 13) 14 15 #f 1)
+;       map
+;       syntax-object->datum
+;       (build-stx-with-highlight `((define a 13)  14 15 #f 1)))
+  
+;      (let ([test-run (build-stx-with-highlight `((+ (hilite x) (hilite (+ (hilite 13) (a b))))))])
+;        (test #t (lambda () (and (pair? test-run) (null? (cdr test-run)))))
+;        (let ([test-stx (car test-run)])
+;          (test `(+ x (+ 13 (a b)))
+;                syntax-object->datum test-stx)
+;          (test #f syntax-property test-stx 'stepper-highlight)
+;          (test #t syntax-property (car (syntax-e (cdr (syntax-e test-stx)))) 'stepper-highlight)
+;          (test #t syntax-property (syntax-case test-stx ()
+;                                     [(+ x target)
+;                                      #`target])
+;                'stepper-highlight)
+;          (test #t syntax-property (syntax-case test-stx (#%app)
+;                                     [(+ x (a target d))
+;                                      #`target])
+;                'stepper-highlight)))
+;  
+;
+;  
+;   (let ([test-sexp `(+ (hilite x) (hilite (+ (hilite 13) (a b))))])
+;     (test #t equal? test-sexp (syntax-object->hilite-datum (car (build-stx-with-highlight (list test-sexp))))))
+  
+  )
diff --git a/collects/stepper/private/xml-box.ss b/collects/stepper/private/xml-box.ss
new file mode 100644
index 0000000000..04a63384ad
--- /dev/null
+++ b/collects/stepper/private/xml-box.ss
@@ -0,0 +1,68 @@
+(module xml-box mzscheme
+  (require (lib "contract.ss")
+           "shared.ss"
+           (prefix kernel: (lib "kerncase.ss" "syntax")))
+  
+  (provide/contract [rewrite-xml-box (syntax?                  ; stx to rewrite
+                                      (syntax? . -> . syntax?) ; rewriter for non-xml-box subcomponents
+                                      . -> . 
+                                      syntax?)])               ; rewritten
+  
+  
+  (define (rewrite-xml-box stx rewrite-other)
+      
+    (define (recur stx)
+      (rewrite-xml-box stx rewrite-other))
+    
+    (define (rewrite-xml-error)
+      (error 'rewrite-xml-box "unexpected syntax in expansion of xml box: ~e" stx))
+
+    (case (syntax-property stx 'stepper-hint) 
+      [(from-scheme-box from-splice-box) (rewrite-other stx)]
+      [(from-xml-box #f)
+       (syntax-property
+        (kernel:kernel-syntax-case stx #f
+          [var-stx (identifier? (syntax var-stx)) (rewrite-xml-error)]
+          
+          [(lambda . clause) (rewrite-xml-error)]
+          
+          [(case-lambda . clauses) (rewrite-xml-error)]
+          
+          [(if test then) (rewrite-xml-error)]
+          
+          [(if test then else) (rewrite-xml-error)]
+          
+          [(begin . bodies) (rewrite-xml-error)]
+          
+          [(begin0 . bodies) (rewrite-xml-error)]
+          
+          [(let-values . clause) (rewrite-xml-error)]
+          
+          [(letrec-values . clause) (rewrite-xml-error)]
+          
+          [(set! var val) (rewrite-xml-error)]
+          
+          [(quote _) stx]
+          
+          [(quote-syntax _) (rewrite-xml-error)]
+          
+          [(with-continuation-mark key mark body) (rewrite-xml-error)]
+          
+          [(#%app . exprs)
+           (rebuild-stx (map recur (syntax->list #`exprs)) stx)]
+          
+          [(#%datum . _) stx]
+          
+          [(#%top . var) (rewrite-xml-error)]
+          
+          [else (error 'syntax-object-iterator "unknown expr: ~a" stx)])
+        'stepper-hint
+        'from-xml-box)]
+      
+      [else
+       (error 'rewrite-xml-box "unexpected stepper-hint \"~v\" on syntax from xml box: ~e" 
+              (syntax-property stx 'stepper-hint)
+              stx)])))
+
+
+
diff --git a/collects/stepper/private/xml-snip-helpers.ss b/collects/stepper/private/xml-snip-helpers.ss
new file mode 100644
index 0000000000..2eba732123
--- /dev/null
+++ b/collects/stepper/private/xml-snip-helpers.ss
@@ -0,0 +1,166 @@
+
+(module xml-snip-helpers mzscheme
+  (require (lib "xml.ss" "xml")
+           (lib "readerr.ss" "syntax")
+           (lib "mred.ss" "mred")
+           (lib "class.ss")
+           (lib "list.ss"))
+  
+  (provide xml-read-special
+           xml-snip<%>
+           scheme-read-special
+           scheme-snip<%>)
+  
+  (define (scheme-read-special snip file line col pos)
+    (let ([text (send snip get-editor)]
+          [splice? (send snip get-splice?)])
+      (when (= 0 (send text last-position))
+        (let-values ([(txt line col pos) (find-position-in-outer snip)])
+          (raise-read-error 
+           (if splice?
+               "read: bad syntax: empty scheme splice box"
+               "read: bad syntax: empty scheme box")
+           txt line col pos 1)))
+      (let ([stx (read-syntax
+                  text
+                  (open-input-text-editor text 0 (send text last-position)))])
+        (when (eof-object? stx)
+          (raise-read-error
+           (if splice?
+               "read: bad syntax: empty scheme splice box"
+               "read: bad syntax: empty scheme box")
+           text 1 1 1 (send text last-position)))
+	stx)))
+  
+  (define (xml-read-special eliminate-whitespace-in-empty-tags? snip file line col pos)
+    (let ([editor (send snip get-editor)]
+          [old-locked #f])
+      (when (= 0 (send editor last-position))
+        (let-values ([(txt line col pos) (find-position-in-outer snip)])
+          (raise-read-error "read: bad syntax: empty xml box"
+                            txt line col pos 1)))
+      (dynamic-wind
+       (lambda () 
+         (set! old-locked (send editor is-locked?))
+         (send editor lock #t))
+       (lambda ()
+         (let* ([port (open-input-text-editor editor 0 'end (xml-snip-filter editor))]
+                [xml (read-xml port)]
+                [xexpr (xml->xexpr (document-element xml))]
+                [clean-xexpr (if eliminate-whitespace-in-empty-tags?
+                                 (eliminate-whitespace-in-empty-tags xexpr)
+                                 xexpr)]
+                [expd-xexpr (expand-embedded clean-xexpr)]
+                [qq-body (datum->syntax-object #'here expd-xexpr (list editor #f #f #f #f))])
+           (with-syntax ([qq-body qq-body])
+             (syntax-property (syntax (quasiquote qq-body))
+                              'stepper-xml-hint
+                              'from-xml-box))))
+       (lambda () (send editor lock old-locked)))))
+  
+  (define ((xml-snip-filter text) s)
+    (cond
+      [(is-a? s scheme-snip<%>)
+       (let* ([position (send text get-snip-position s)]
+              [line (send text position-paragraph position)]
+              [col (- position (send text paragraph-start-position line))])
+         (make-wrapped s text line col position))]
+      [else s]))
+  
+  (define scheme-snip<%>
+    (interface ()
+      get-splice?))
+  
+  (define xml-snip<%>
+    (interface ()))
+  
+  ;; eliminate-whitespace-in-empty-tags : xexpr -> xexpr
+  (define (eliminate-whitespace-in-empty-tags xexpr)
+    (cond
+      [(and (pair? xexpr)
+            (symbol? (car xexpr)))
+       (list* (car xexpr)
+              (cadr xexpr)
+              (map eliminate-whitespace-in-empty-tags
+                   (eliminate-whitespace-in-list (cddr xexpr))))]
+      [else xexpr]))
+  
+  ;; wrapped = (make-wraped sexp text number number number)
+  (define-struct wrapped (snip text line col pos))
+  
+  ;; expand-embedded : xexpr -> xexpr
+  ;; constructs a new xexpr that has the embedded snips expanded 
+  ;; and wrapped with unquotes
+  ;; CRUCIAL INVARIANT: an expression must not receive both 'from-xml-box and 'from-scheme/splice-box tags.
+  (define (expand-embedded _xexpr)
+    (let loop ([xexpr _xexpr])
+      (cond
+        [(pair? xexpr)
+         (cons (loop (car xexpr))
+               (loop (cdr xexpr)))]
+        [(wrapped? xexpr)
+         (let* ([snip (wrapped-snip xexpr)]
+                [text (wrapped-text xexpr)]
+                [pos (wrapped-pos xexpr)]
+                [line (wrapped-line xexpr)]
+                [col (wrapped-col xexpr)]
+                [raw-stxs (list (send snip read-special text line col pos))])
+           (with-syntax ([(stxs ...) raw-stxs])
+             (if (and (is-a? snip scheme-snip<%>)
+                      (send snip get-splice?))
+                 (with-syntax ([err (syntax/loc 
+                                     (car (last-pair raw-stxs))
+                                     (error 'scheme-splice-box "expected a list, found: ~e" lst))])
+                   #`,@#,(syntax-property #`(let ([lst (begin stxs ...)])
+                                              (if (list? lst)
+                                                  lst
+                                                  err))
+                                          'stepper-xml-hint
+                                          'from-splice-box))
+                 #`,#,(syntax-property #`(begin stxs ...) 
+                                       'stepper-xml-hint
+                                       'from-scheme-box))))]
+        [else xexpr])))
+  
+  ;; eliminate-whitespace-in-list (listof xexpr) -> (listof xexpr)
+  ;; if each string in xexprs is a whitespace string, remove all strings
+  ;; otherwise, return input.
+  (define (eliminate-whitespace-in-list xexprs)
+    (cond
+      [(andmap (lambda (x) (or (not (string? x))
+                               (string-whitespace? x)))
+               xexprs)
+       (filter (lambda (x) (not (string? x))) xexprs)]
+      [else xexprs]))
+  
+  ;; string-whitespace? : string -> boolean
+  ;; return #t if the input string consists entirely of whitespace
+  (define (string-whitespace? str)
+    (let loop ([i (string-length str)])
+      (cond
+        [(zero? i) #t]
+        [(char-whitespace? (string-ref str (- i 1)))
+         (loop (- i 1))]
+        [else #f])))
+  
+  
+  ;; transformable? : snip -> boolean
+  ;; deteremines if a snip can be expanded here
+  (define (transformable? snip)
+    (or (is-a? snip xml-snip<%>)
+        (is-a? snip scheme-snip<%>)))
+  
+  ;; find-in-position-in-outer : 
+  ;;    editor-snip -> (values (union #f text%) (union #f number) (union #f number) (union #f number))
+  (define (find-position-in-outer editor-snip)
+    (let/ec k
+      (let ([fail (lambda () (k #f #f #f #f))])
+        (let ([admin (send editor-snip get-admin)])
+          (unless admin (fail))
+          (let ([outer-editor (send admin get-editor)])
+            (unless (is-a? outer-editor text%) (fail))
+            (let ([pos (send outer-editor get-snip-position editor-snip)])
+              (unless pos (fail))
+              (let* ([line (send outer-editor position-paragraph pos)]
+                     [line-start (send outer-editor paragraph-start-position line)])
+                (values outer-editor (+ line 1) (+ (- pos line-start) 1) (+ pos 1))))))))))
\ No newline at end of file
diff --git a/collects/stepper/stepper+xml-tool.ss b/collects/stepper/stepper+xml-tool.ss
new file mode 100644
index 0000000000..0af55b5513
--- /dev/null
+++ b/collects/stepper/stepper+xml-tool.ss
@@ -0,0 +1,19 @@
+(module stepper+xml-tool mzscheme
+  (require (lib "unitsig.ss")
+           (lib "tool.ss" "drscheme")
+           "stepper-tool.ss"
+           "xml-tool.ss")
+
+  (provide tool@)
+  
+  ;; the xml and stepper tools are combined, so that the stepper can create XML snips.
+  ;; note that both of these tools provide 'void' for phase1 and phase2 (which together
+  ;; make up the tool-exports^), so we can provide either one of these for the compound
+  ;; unit.  Doesn't matter.
+  
+  (define tool@
+    (compound-unit/sig
+      (import (TOOL-IMPORTS : drscheme:tool^))
+      (link (XML-TOOL : (xml-snip% scheme-snip%) (xml-tool@ TOOL-IMPORTS))
+            (STEPPER-TOOL :  drscheme:tool-exports^ (stepper-tool@ TOOL-IMPORTS XML-TOOL)))
+      (export (open STEPPER-TOOL)))))
\ No newline at end of file
diff --git a/collects/stepper/stepper-tool.ss b/collects/stepper/stepper-tool.ss
new file mode 100644
index 0000000000..0d25b0966e
--- /dev/null
+++ b/collects/stepper/stepper-tool.ss
@@ -0,0 +1,569 @@
+(module stepper-tool mzscheme
+  (require (lib "contract.ss")
+           (lib "tool.ss" "drscheme")
+           (lib "mred.ss" "mred")  
+           (prefix frame: (lib "framework.ss" "framework"))
+           (lib "unitsig.ss")
+           (lib "class.ss")
+           (lib "etc.ss")
+           (lib "list.ss")
+           (prefix model: "private/model.ss")
+	   "private/my-macros.ss"
+           (prefix x: "private/mred-extensions.ss")
+           "private/shared.ss"
+           "private/model-settings.ss"
+           (lib "pconvert.ss")
+           (lib "string-constant.ss" "string-constants")
+           (lib "async-channel.ss")
+           (lib "bitmap-label.ss" "mrlib"))
+
+  ;; mflatt: MINOR HACK - work around temporary
+  ;;         print-convert problems
+  (define (stepper-print-convert v)
+    (or (and (procedure? v)
+	     (object-name v))
+	(print-convert v)))
+    
+
+  ; hidden invariant: this list should be a sublist of the language-level dialog (i.e., same order):
+  (define stepper-works-for
+    (list (string-constant beginning-student)
+          (string-constant beginning-student/abbrev)
+          (string-constant intermediate-student)
+          (string-constant intermediate-student/lambda)))
+  
+  (provide stepper-tool@)
+  
+  (define stepper-tool@
+    (unit/sig drscheme:tool-exports^
+      (import drscheme:tool^
+              (xml-snip% scheme-snip%))
+      
+      ; tool magic here:
+      (define (phase1) (void))
+      (define (phase2) (void))
+      
+      (define stepper-initial-width 500)
+      (define stepper-initial-height 500)
+      
+      (define drscheme-eventspace (current-eventspace))
+      
+      (define stepper-frame%
+        (class (drscheme:frame:basics-mixin (frame:frame:standard-menus-mixin frame:frame:basic%))
+          
+          (init-field drscheme-frame)
+          
+          ;; PRINTING-PROC 
+          
+          (public set-printing-proc)
+          
+          (define (set-printing-proc proc)
+            (set! printing-proc proc))
+          
+          (define (printing-proc item evt)
+            (message-box "error?" "shouldn't be called"))
+          
+          (define/private (file-menu:print a b) (printing-proc a b))
+          
+          ;; MENUS
+          
+          (define/override (edit-menu:between-find-and-preferences edit-menu) (void))
+          (define/override (edit-menu:between-select-all-and-find edit-menu) (void))
+          (define/override (file-menu:between-save-as-and-print file-menu) (void))
+          
+          ;; CUSTODIANS
+          
+          (define custodian #f)
+          (define/public (set-custodian! cust)
+            (set! custodian cust))
+          (define/augment (on-close)
+            (when custodian
+              (custodian-shutdown-all custodian))
+            (send drscheme-frame on-stepper-close)
+            (inner (void) on-close))
+          
+          ;; WARNING BOXES:
+          
+          (define program-changed-warning-str (string-constant stepper-program-has-changed))
+          (define window-closed-warning-str (string-constant stepper-program-window-closed))
+          
+          (define warning-message-visible-already #f)
+          (define/private (add-warning-message warning-str)
+            (let ([warning-msg (instantiate x:stepper-warning% () 
+                                 (warning-str warning-str)
+                                 (parent (get-area-container)))])
+              (send (get-area-container)
+                    change-children
+                    (if warning-message-visible-already
+                        (lambda (l) 
+                          (list (car l)
+                                warning-msg
+                                (caddr l)))
+                        (lambda (l)
+                          (list (car l)
+                                warning-msg
+                                (cadr l)))))
+              (set! warning-message-visible-already #t)))
+          
+          (inherit get-area-container)
+          (define program-change-already-warned? #f)
+          (define/public (original-program-changed)
+            (unless program-change-already-warned?
+              (set! program-change-already-warned? #t)
+              (add-warning-message program-changed-warning-str)))
+          
+          (define/public (original-program-gone)
+            (add-warning-message window-closed-warning-str))
+          
+          
+          (super-instantiate ("Stepper" #f stepper-initial-width stepper-initial-height))))
+      
+      
+      ;; view-controller-go: called when the stepper starts; starts the stepper's view&controller
+      ;; drscheme-frame : the drscheme frame which is starting the stepper
+      ;; program-expander : see "model.ss" for the contract on a program-expander
+      ;;  -> returns the new frame%
+      (define (view-controller-go drscheme-frame program-expander)
+        
+       
+        (define language-settings 
+          (send (send drscheme-frame get-definitions-text) get-next-settings))
+        (define language
+          (drscheme:language-configuration:language-settings-language language-settings))
+        (define language-level-name
+          (car (last-pair (send language get-language-position))))
+        (define simple-settings
+          (drscheme:language-configuration:language-settings-settings language-settings))
+        
+        ;; VALUE CONVERSION CODE:
+        
+        ;; render-to-string : TST -> string
+        (define (render-to-string val)
+          (let ([string-port (open-output-string)])
+            (send language
+                  render-value
+                  val
+                  simple-settings
+                  string-port)
+            (get-output-string string-port)))
+        
+        ;; make-print-convert-hook: simple-settings -> (TST (TST -> TST) (TST -> TST) -> TST)
+        ;; this code copied from various locations in language.ss and rep.ss
+        (define (make-print-convert-hook simple-settings)
+          (lambda (expr basic-convert sub-convert)
+            (cond
+              [(is-a? expr snip%) 
+               (send expr copy)]
+              #;[((drscheme:rep:use-number-snip) expr)
+               (let ([number-snip-type (drscheme:language:simple-settings-fraction-style simple-settings)])
+                 (cond
+                   [(eq? number-snip-type 'repeating-decimal)
+                    (drscheme:number-snip:make-repeating-decimal-snip expr #f)]
+                   [(eq? number-snip-type 'repeating-decimal-e)
+                    (drscheme:number-snip:make-repeating-decimal-snip expr #t)]
+                   [(eq? number-snip-type 'mixed-fraction)
+                    (drscheme:number-snip:make-fraction-snip expr #f)]
+                   [(eq? number-snip-type 'mixed-fraction-e)
+                    (drscheme:number-snip:make-fraction-snip expr #t)]
+                   [else
+                    (error 'which-number-snip
+                           "expected either 'repeating-decimal, 'repeating-decimal-e, 'mixed-fraction, or 'mixed-fraction-e got : ~e"
+                           number-snip-type)]))]
+              [else (basic-convert expr)])))
+        
+        ;; render-to-sexp : TST -> sexp
+        (define (render-to-sexp val)
+          (parameterize ([current-print-convert-hook (make-print-convert-hook simple-settings)])
+            (set-print-settings
+             language
+             simple-settings
+             (lambda () 
+               (simple-module-based-language-convert-value val simple-settings)))))
+        
+        ; channel for incoming views
+        (define view-channel (make-async-channel))
+        
+        ; the semaphore associated with the view at the end of the view-history
+        ; note that because these are fresh semaphores for every step, posting to a semaphore
+        ; multiple times is no problem.
+        (define release-for-next-step #f)
+        
+        ; the list of available views
+        (define view-history null)
+        
+        ; the view in the stepper window
+        (define view 0)
+        
+        ; whether the stepper is waiting for a new view to become available
+        ; (initially true)
+        ; possible values: #f, 'waiting-for-any-step, 'waiting-for-application
+        (define stepper-is-waiting? 'waiting-for-any-step)
+        
+        ; hand-off-and-block : (-> text%? boolean? void?)
+        ; hand-off-and-block generates a new semaphore, hands off a thunk to drscheme's eventspace,
+        ; and blocks on the new semaphore.  The thunk adds the text% to the waiting queue, and checks
+        ; to see if the stepper is waiting for a new step.  If so, takes that new text% out of the 
+        ; queue and puts it on the list of available ones.  If the stepper is waiting for a new step,
+        ; it checks to see whether this is of the kind that the stepper wants.  If so, display it.
+        ; otherwise, release the stepped program to continue execution.
+        
+        (define (hand-off-and-block step-text step-kind)
+          (let ([new-semaphore (make-semaphore)])
+            (parameterize ([current-eventspace drscheme-eventspace])
+              (queue-callback
+               (lambda ()
+                 (async-channel-put view-channel (list step-text new-semaphore step-kind))
+                 (when stepper-is-waiting?
+                   (let ([try-get (async-channel-try-get view-channel)])
+                     (unless try-get
+                       (error 'check-for-stepper-waiting "queue is empty, even though a step was just added."))
+                     (add-view-triple try-get)
+                     (if (right-kind-of-step? (caddr try-get))
+                         ; got the desired step; show the user:
+                         (begin 
+                           (set! stepper-is-waiting? #f)
+                           (update-view/existing (- (length view-history) 1)))
+                         ; nope, keep running:
+                         (begin
+                           (en/dis-able-buttons)
+                           (semaphore-post new-semaphore)))))))
+              (semaphore-wait new-semaphore))))
+        
+        ; right-kind-of-step? : (boolean? . -> . boolean?)
+        ; is this step the kind of step that the gui is waiting for?
+        (define (right-kind-of-step? step-kind)
+          (case stepper-is-waiting?
+            [(waiting-for-any-step) #t]
+            [(waiting-for-application) (or (eq? step-kind 'user-application)
+                                           (eq? step-kind 'finished-stepping))]
+            [(#f) (error 'right-kind-of-step "this code should be unreachable with stepper-is-waiting? set to #f")]
+            [else (error 'right-kind-of-step "unknown value for stepper-is-waiting?: ~a" stepper-is-waiting?)]))
+        
+        ;; add-view-triple : set the release-semaphore to be the new one, add the view to the list.
+        (define (add-view-triple view-triple)
+          (set! release-for-next-step (cadr view-triple))
+          (set! view-history (append view-history (list (list (car view-triple) (caddr view-triple))))))
+        
+        ;; find-later-application-step : search through the history, starting at 'n', for an application step.
+        (define (find-later-application-step n)
+          (let ([history-length (length view-history)])
+            (let loop ([step (+ n 1)])
+              (cond [(>= step history-length) #f]
+                    [(application-step? (list-ref view-history step)) step]
+                    [else (loop (+ step 1))]))))
+        
+        ;; is this an application step?
+        (define (application-step? history-entry)
+          (case (cadr history-entry)
+            [(user-application finished stepping) #t]
+            [else #f]))
+        
+        ; build gui object:
+        
+        ;; home : the action of the 'home' button
+        (define (home)
+          (when stepper-is-waiting?
+            (set! stepper-is-waiting? #f))
+          (update-view/existing 0))
+        
+        ;; next : the action of the 'next' button
+        (define (next)
+          (let ([new-view (+ view 1)])
+            (if (< new-view (length view-history))
+                (update-view/existing new-view)
+                (begin
+                  (semaphore-post release-for-next-step) ; each step has its own semaphore, so releasing one twice is no problem.
+                  (when stepper-is-waiting?
+                    (error 'try-to-get-view "try-to-get-view should not be reachable when already waiting for new step"))
+                  (let ([try-get (async-channel-try-get view-channel)])
+                    (if try-get
+                        (begin 
+                          (add-view-triple try-get)
+                          (update-view/existing new-view))
+                        (begin
+                          (set! stepper-is-waiting? 'waiting-for-any-step)
+                          (en/dis-able-buttons))))))))
+        
+        ;; next-application : the action of the 'next-application' button
+        ;; NB: while this function looks a lot like (next), the abstractions of the two that I came up with
+        ;; were hard to read. So I left them separate -- JBC
+        (define (next-application)
+          (let ([next-application-step (find-later-application-step view)])
+            (if next-application-step
+                (update-view/existing next-application-step)
+                (begin
+                  (semaphore-post release-for-next-step) ; each step has its own semaphore, so releasing one twice is no problem.
+                  (when stepper-is-waiting?
+                    (error 'try-to-get-view "try-to-get-view should not be reachable when already waiting for new step"))
+                  (let ([try-get (async-channel-try-get view-channel)])
+                    (if try-get
+                        (begin
+                          (add-view-triple try-get)
+                          (if (application-step? (list-ref view-history (+ view 1)))
+                              (update-view/existing (+ view 1))
+                              (begin
+                                (set! stepper-is-waiting? 'waiting-for-application)
+                                (en/dis-able-buttons))))
+                        (begin
+                          (set! stepper-is-waiting? 'waiting-for-application)
+                          (en/dis-able-buttons))))))))
+                
+        ;; previous : the action of the 'previous' button 
+        (define (previous)
+          (when stepper-is-waiting?
+            (set! stepper-is-waiting? #f))
+          (when (= view 0)
+            (error 'previous-application "previous-step button should not be enabled in view zero."))
+          (update-view/existing (- view 1)))
+        
+        ;; previous-application : the action of the 'previous-application' button
+        (define (previous-application)
+          (when stepper-is-waiting?
+            (set! stepper-is-waiting? #f))
+          (when (= view 0)
+            (error 'previous-application "previous-application button should not be enabled in view zero."))
+          (let loop ([new-view (- view 1)])
+            (cond [(= new-view 0)
+                   (update-view/existing new-view)]
+                  [(application-step? (list-ref view-history new-view))
+                   (update-view/existing new-view)]
+                  [else
+                   (loop (- new-view 1))])))
+        
+        ;; GUI ELEMENTS:
+        (define s-frame (make-object stepper-frame% drscheme-frame))
+        (define button-panel (make-object horizontal-panel% (send s-frame get-area-container)))
+        (define home-button (make-object button% (string-constant stepper-home) button-panel
+                              (lambda (_1 _2) (home))))
+        (define previous-application-button (make-object button% (string-constant stepper-previous-application) button-panel
+                                              (lambda (dc-1 dc-2) (previous-application))))
+        (define previous-button (make-object button% (string-constant stepper-previous) button-panel
+                                  (lambda (_1 _2) (previous))))
+        (define next-button (make-object button% (string-constant stepper-next) button-panel 
+                              (lambda (_1 _2) (next))))
+        (define next-application-button (make-object button% (string-constant stepper-next-application) button-panel
+                                          (lambda (dc-1 dc-2) (next-application))))
+        (define canvas (make-object x:stepper-canvas% (send s-frame get-area-container)))
+
+        ;; update-view/existing : set an existing step as the one shown in the frame
+        (define (update-view/existing new-view)
+          (set! view new-view)                  
+          (let ([e (car (list-ref view-history view))])
+            (send e begin-edit-sequence)
+            (send canvas set-editor e)
+            (send e reset-width canvas)
+            (send e set-position (send e last-position))
+            (send e end-edit-sequence))
+          (en/dis-able-buttons))
+        
+        ;; en/dis-able-buttons : set enable & disable the stepper buttons, based on view-controller state
+        (define (en/dis-able-buttons)
+          (let* ([can-go-back? (> view 0)])
+            (send previous-button enable can-go-back?)
+            (send previous-application-button enable can-go-back?)
+            (send home-button enable can-go-back?)
+            (send next-button enable (not (and (>= view (- (length view-history) 1)) stepper-is-waiting?)))
+            (send next-application-button enable (or (find-later-application-step view) (not stepper-is-waiting?)))))
+        
+        (define (print-current-view item evt)
+          (send (send canvas get-editor) print))
+        
+        ; receive-result takes a result from the model and renders it on-screen. Runs on the user thread.
+        ; : (step-result -> void)
+        (define (receive-result result)
+          (let ([step-text
+                 (cond [(before-after-result? result) 
+                        (instantiate x:stepper-text% () 
+                          [finished-exprs (before-after-result-finished-exprs result)]
+                          [exps (before-after-result-exp result)]
+                          [post-exps (before-after-result-post-exp result)]
+                          [error-msg #f]
+                          [after-exprs (before-after-result-after-exprs result)])]
+                       [(before-error-result? result)
+                        (instantiate x:stepper-text% ()
+                          [finished-exprs (before-error-result-finished-exprs result)]
+                          [exps (before-error-result-exp result)]
+                          [post-exps null]
+                          [error-msg (before-error-result-err-msg result)]
+                          [after-exprs (before-error-result-after-exprs result)])]
+                       [(error-result? result)
+                        (instantiate x:stepper-text% ()
+                          [finished-exprs (error-result-finished-exprs result)]
+                          [exps null]
+                          [post-exps null]
+                          [error-msg (error-result-err-msg result)]
+                          [after-exprs null])]
+                       [(finished-result? result)
+                        (instantiate x:stepper-text% ()
+                          [finished-exprs (finished-result-finished-exprs result)]
+                          [exps null]
+                          [post-exps null]
+                          [error-msg #f]
+                          [after-exprs null])]
+                       [(finished-stepping? result)
+                        x:finished-text])]
+                [step-kind (or (and (before-after-result? result)
+                                    (before-after-result-kind result))
+                               (and (finished-stepping? result)
+                                    'finished-stepping))])
+            (hand-off-and-block step-text step-kind)))
+        
+        ; need to capture the custodian as the thread starts up:
+        (define (program-expander-prime init iter)
+          (program-expander (lambda args
+                              (send s-frame set-custodian! (current-custodian))
+                              (apply init args))
+                            iter))
+        
+        ;; CONFIGURE GUI ELEMENTS
+        (send s-frame set-printing-proc print-current-view)
+        (send button-panel stretchable-width #f)
+        (send button-panel stretchable-height #f)
+        (send canvas stretchable-height #t)
+        (en/dis-able-buttons)
+        (send (send s-frame edit-menu:get-undo-item) enable #f)
+        (send (send s-frame edit-menu:get-redo-item) enable #f)
+        
+        ; START THE MODEL
+        (model:go program-expander-prime receive-result (get-render-settings render-to-string render-to-sexp #t)
+                  (not (string=? language-level-name (string-constant intermediate-student/lambda))))
+        (send s-frame show #t)
+        
+        s-frame)
+  
+      ;; stepper-bitmap : the image used for the stepper button
+      (define stepper-bitmap
+        (bitmap-label-maker
+         (string-constant stepper-button-label)
+         (build-path (collection-path "icons") "foot.png")))
+
+      ;; stepper-unit-frame<%> : the interface that the extended drscheme frame fulfils
+      (define stepper-unit-frame<%>
+        (interface ()
+          get-stepper-frame
+          on-stepper-close))
+      
+      ;; stepper-unit-frame-mixin : the mixin that is applied to the drscheme frame to interact with a possible stepper window
+      (define (stepper-unit-frame-mixin super%)
+        (class* super% (stepper-unit-frame<%>)
+          
+          (inherit get-button-panel get-interactions-text get-definitions-text)
+          
+          (define stepper-frame #f)
+          (define/public (on-stepper-close)
+            (set! stepper-frame #f))
+          (define/public (get-stepper-frame) stepper-frame)
+          
+          (super-instantiate ())
+          
+          ;; program-expander : produces expanded expressions from the definitions window one at a time and calls 'iter' on each one
+          (define (program-expander init iter)
+            (let* ([lang-settings 
+                       (send (get-definitions-text) get-next-settings)]
+                      [lang (drscheme:language-configuration:language-settings-language lang-settings)]
+                      [settings (drscheme:language-configuration:language-settings-settings lang-settings)])
+                 (drscheme:eval:expand-program
+                  (drscheme:language:make-text/pos (get-definitions-text) 
+                                                   0
+                                                   (send (get-definitions-text)
+                                                         last-position)) 
+                  lang-settings
+                  #f
+                  (lambda ()
+                    (init)
+                    (error-value->string-handler
+                     (lambda (val len)
+                       (let ([sp (open-output-string)])
+                         (send lang render-value val settings sp)
+                         (let ([str (get-output-string sp)])
+                           (if ((string-length str) . <= . len)
+                               str
+                               (string-append (substring str 0 (max 0 (- len 3))) "...")))))))
+                  void ; kill
+                  iter)))
+          
+          ;; STEPPER BUTTON
+          
+          (define/public (get-stepper-button) stepper-button)
+          (define stepper-button 
+            (make-object button%
+              (stepper-bitmap this)
+              (get-button-panel)
+              (lambda (button evt)
+                (if stepper-frame
+                    (send stepper-frame show #t)
+                    (let* ([settings (send (get-definitions-text) get-next-settings)]
+                           [language (drscheme:language-configuration:language-settings-language settings)]
+                           [language-level (car (last-pair (send language get-language-position)))])
+                      (if (member language-level stepper-works-for)
+                          (set! stepper-frame (view-controller-go this program-expander))
+                          (message-box (string-constant stepper-name)
+				       (format (string-constant stepper-language-level-message)
+					       language-level
+					       (car stepper-works-for)
+					       (car (reverse stepper-works-for))))))))))
+          
+          
+          (define/augment (enable-evaluation)
+            (send stepper-button enable #t)
+            (inner (void) enable-evaluation))
+          
+          (define/augment (disable-evaluation)
+            (send stepper-button enable #f)
+            (inner (void) disable-evaluation))
+          
+          (define/augment (on-close)
+            (when stepper-frame
+              (send stepper-frame original-program-gone))
+            (inner (void) on-close))
+          
+          ; add the stepper button to the button panel:
+          (send (get-button-panel) change-children
+                (lx (cons stepper-button (remq stepper-button _))))))
+      
+      ;; stepper-definitions-text-mixin : a mixin for the definitions text that alerts thet stepper when the definitions
+      ;;  text is altered or destroyed
+      (define (stepper-definitions-text-mixin %)
+        (class %
+          
+          (inherit get-top-level-window)
+          (define/private (notify-stepper-frame-of-change)
+            (let ([win (get-top-level-window)])
+              (when (is-a? win stepper-unit-frame<%>) ;; should only be #f when win is #f.
+                (let ([stepper-window (send win get-stepper-frame)])
+                  (when stepper-window
+                    (send stepper-window original-program-changed))))))
+          
+          (define/augment (on-insert x y)
+            (notify-stepper-frame-of-change)
+            (inner (void) on-insert x y))
+          
+          (define/augment (on-delete x y)
+            (notify-stepper-frame-of-change)
+            (inner (void) on-delete x y))
+          
+          (super-instantiate ())))
+      
+      ;; COPIED FROM drscheme/private/language.ss
+      ;; simple-module-based-language-convert-value : TST settings -> TST
+      (define (simple-module-based-language-convert-value value simple-settings)
+	(case (drscheme:language:simple-settings-printing-style simple-settings)
+	  [(write) value]
+	  [(constructor)
+	   (parameterize ([constructor-style-printing #t]
+			  [show-sharing (drscheme:language:simple-settings-show-sharing simple-settings)])
+			 (stepper-print-convert value))]
+	  [(quasiquote)
+	   (parameterize ([constructor-style-printing #f]
+			  [show-sharing (drscheme:language:simple-settings-show-sharing simple-settings)])
+			 (stepper-print-convert value))]))
+      
+      ;; set-print-settings ; settings ( -> TST) -> TST
+      (define (set-print-settings language simple-settings thunk)
+        (unless (method-in-interface? 'set-printing-parameters (object-interface language))
+          (error 'stepper-tool "language object does not contain set-printing-parameters method"))
+        (send language set-printing-parameters simple-settings thunk))
+      
+      ;; apply the mixins dynamically to the drscheme unit frame and definitions text:
+      (drscheme:get/extend:extend-unit-frame stepper-unit-frame-mixin)
+      (drscheme:get/extend:extend-definitions-text stepper-definitions-text-mixin))))
diff --git a/collects/stepper/xml-tool.ss b/collects/stepper/xml-tool.ss
new file mode 100644
index 0000000000..0f89565f8e
--- /dev/null
+++ b/collects/stepper/xml-tool.ss
@@ -0,0 +1,421 @@
+
+(module xml-tool mzscheme
+  (require "private/xml-snip-helpers.ss"
+           (lib "unitsig.ss")
+           (lib "class.ss")
+           (lib "mred.ss" "mred")
+           (lib "framework.ss" "framework")
+           (lib "tool.ss" "drscheme")
+           (lib "xml.ss" "xml")
+           (lib "string-constant.ss" "string-constants"))
+  
+  (provide xml-tool@)
+  
+  (define orig (current-output-port))
+  (define xml-tool@
+    (unit/sig (xml-snip% scheme-snip%)
+      (import drscheme:tool^)
+      
+      (define (phase1) (void))
+      (define (phase2) (void))
+      
+      (preferences:set-default 'drscheme:xml-eliminate-whitespace #t boolean?)
+      
+      (define xml-box-color "forest green")
+      (define scheme-splice-box-color "blue")
+      (define scheme-box-color "purple")
+      
+      ;; get-bm : string -> (union (is-a?/c bitmap%) false?)
+      (define (get-bm name)
+        (let ([bm (make-object bitmap% (build-path (collection-path "icons") name))])
+          (unless (send bm ok?)
+            (error 'xml-box "bitmap ~a failed to load" name))
+          bm))
+      
+      (define scheme-box-bm (get-bm "scheme-box.jpg"))
+      (define scheme-splice-box-bm (get-bm "scheme-splice-box.jpg"))
+      (define xml-box-bm (get-bm "xml-box.jpg"))
+      (define xml-box-open-bm (get-bm "xml-box-open.jpg"))
+      
+      (define xml-snip%
+        (class* decorated-editor-snip% (readable-snip<%> xml-snip<%>)
+          (inherit get-editor)
+          
+          (init-field eliminate-whitespace-in-empty-tags?)
+          
+          (define/override (make-editor) (make-object (get-xml-text%)))
+          (define/override (get-corner-bitmap) 
+            (if eliminate-whitespace-in-empty-tags?
+                xml-box-bm
+                xml-box-open-bm))
+          
+          (define/override (get-menu)
+            (let* ([menu (instantiate popup-menu% ()
+                           (title (string-constant xml-tool-xml-box)))]
+                   [leave-alone-item
+                    (make-object checkable-menu-item%
+                      (string-constant xml-tool-leave-whitespace-alone)
+                      menu
+                      (lambda (x y)
+                        (set-eliminate-whitespace-in-empty-tags? #f)))]
+                   [eliminate-item
+                    (make-object checkable-menu-item%
+                      (string-constant xml-tool-eliminate-whitespace-in-empty-tags)
+                      menu
+                      (lambda (x y)
+                        (set-eliminate-whitespace-in-empty-tags? #t)))])
+              (send leave-alone-item check (not eliminate-whitespace-in-empty-tags?))
+              (send eliminate-item check eliminate-whitespace-in-empty-tags?)
+              menu))
+          
+          (inherit get-admin reset-min-sizes)
+          (define/private (set-eliminate-whitespace-in-empty-tags? new)
+            (unless (eq? eliminate-whitespace-in-empty-tags? new)
+              (set! eliminate-whitespace-in-empty-tags? new)
+              (preferences:set 'drscheme:xml-eliminate-whitespace new)
+              (reset-min-sizes)
+              (let ([admin (get-admin)])
+                (when admin
+                  (send admin resized this #t)))))
+          
+          (define/public (read-special file line col pos)
+            (xml-read-special eliminate-whitespace-in-empty-tags?
+			      this
+			      file
+			      line
+			      col
+			      pos))
+          
+          (define/override (write stream-out)
+            (send stream-out put (if eliminate-whitespace-in-empty-tags?
+                                     0
+                                     1))
+            (send (get-editor) write-to-file stream-out 0 'eof))
+          (define/override (make-snip)
+            (instantiate xml-snip% ()
+              [eliminate-whitespace-in-empty-tags? eliminate-whitespace-in-empty-tags?]))
+          
+          (define/override (get-color) xml-box-color)
+          
+          (inherit show-border set-snipclass)
+          (super-instantiate ())
+          (show-border #t)
+          (set-snipclass lib-xml-snipclass)))
+      
+      (define xml-snipclass%
+        (class decorated-editor-snipclass%
+          (define/override (make-snip stream-in)
+            (instantiate xml-snip% ()
+              [eliminate-whitespace-in-empty-tags?
+               (preferences:get 'drscheme:xml-eliminate-whitespace)]))
+          (super-instantiate ())))
+      
+      ;; this snipclass is for old, saved files (no snip has it set)
+      (define xml-snipclass (make-object xml-snipclass%))
+      (send xml-snipclass set-version 1)
+      (send xml-snipclass set-classname "drscheme:xml-snip")
+      (send (get-the-snip-class-list) add xml-snipclass)
+      
+      ;; this snipclass overrides the actual one in (lib "xml-snipclass.ss" "xml")
+      ;; as a full-fledged snipclass, for use in DrScheme.
+      
+      (define lib-xml-snipclass%
+        (class snip-class%
+          (define/override (read stream-in)
+            (let* ([eliminate-whitespace-in-empty-tags? (zero? (send stream-in get-exact))]
+                   [snip (instantiate xml-snip% ()
+                           [eliminate-whitespace-in-empty-tags? eliminate-whitespace-in-empty-tags?])])
+              (send (send snip get-editor) read-from-file stream-in #f)
+              snip))
+          (super-instantiate ())))
+      
+      (define lib-xml-snipclass (make-object lib-xml-snipclass%))
+      (send lib-xml-snipclass set-version 1)
+      (send lib-xml-snipclass set-classname (format "~s" '(lib "xml-snipclass.ss" "xml")))
+      (send (get-the-snip-class-list) add lib-xml-snipclass)
+      
+      (define scheme-snip%
+        (class* decorated-editor-snip% (scheme-snip<%> readable-snip<%>)
+          (init-field splice?)
+          (define/public (get-splice?) splice?)
+          
+          (define/override (get-corner-bitmap) 
+            (if splice? 
+                scheme-splice-box-bm
+                scheme-box-bm))
+          
+          (define/override (get-menu)
+            (let ([menu (instantiate popup-menu% ()
+                          (title (if splice?
+                                     (string-constant xml-tool-scheme-splice-box)
+                                     (string-constant xml-tool-scheme-box))))])
+              (instantiate menu-item% ()
+                (label
+                 (if splice?
+                     (string-constant xml-tool-switch-to-scheme)
+                     (string-constant xml-tool-switch-to-scheme-splice)))
+                (parent menu)
+                (callback (lambda (x y) (toggle-splice))))
+              menu))
+          
+          (inherit get-admin reset-min-sizes)
+          (define/private (toggle-splice)
+            (let ([admin (get-admin)])
+              (set! splice? (not splice?))
+              (reset-min-sizes)
+              (when admin
+                (send admin resized this #t))))
+          
+          (inherit get-editor)
+          
+          (define/public (read-special file line col pos)
+            (scheme-read-special this file line col pos))
+          
+          (define/override (make-editor) (new (get-scheme-box-text%)))
+          
+          (define/override (make-snip) 
+            (instantiate scheme-snip% () (splice? splice?)))
+          
+          (define/override (write stream-out)
+            (send stream-out put (if splice? 0 1))
+            (super write stream-out))
+          
+          (inherit show-border set-snipclass)
+          (define/override (get-color)
+            (if splice?
+                scheme-splice-box-color
+                scheme-box-color))
+          
+          (super-instantiate ())
+          (show-border #t)
+          (set-snipclass lib-scheme-snipclass)))
+
+      (define scheme-box-text% #f)
+      (define (get-scheme-box-text%)
+        (unless scheme-box-text%
+          (set! scheme-box-text%
+                (class ((drscheme:unit:get-program-editor-mixin)
+                        (add-file-keymap-mixin
+                         scheme:text%))
+                  (inherit copy-self-to)
+                  (define/override (copy-self)
+                    (let ([t (new scheme-box-text%)])
+                      (copy-self-to t)
+                      t))
+                  (super-new))))
+        scheme-box-text%)
+        
+      (define (add-file-keymap-mixin %)
+        (class %
+          (define/override (get-keymaps)
+            (cons (keymap:get-file) (super get-keymaps)))
+          (super-instantiate ())))
+      
+      (define scheme-snipclass%
+        (class decorated-editor-snipclass%
+          (define/override (make-snip stream-in)
+            (let* ([splice? (zero? (send stream-in get-exact))])
+              (instantiate scheme-snip% () (splice? splice?))))
+          (super-instantiate ())))
+      
+      ;; this snipclass is for old, saved files (no snip has it set)
+      (define scheme-snipclass (make-object scheme-snipclass%))
+      (send scheme-snipclass set-version 2)
+      (send scheme-snipclass set-classname "drscheme:scheme-snip")
+      (send (get-the-snip-class-list) add scheme-snipclass)
+      
+      ;; this snipclass overrides the one in (lib "scheme-snipclass.ss" "xml")
+      ;; as a full-fledged snipclass, for use in DrScheme.
+      (define lib-scheme-snipclass (make-object scheme-snipclass%))
+      (send lib-scheme-snipclass set-version 1)
+      (send lib-scheme-snipclass set-classname (format "~s" '(lib "scheme-snipclass.ss" "xml")))
+      (send (get-the-snip-class-list) add lib-scheme-snipclass)
+      
+      (define plain-text%
+        (class text:keymap% 
+          (init-field [delta (make-object style-delta%)])
+          (inherit change-style copy-self-to)
+          (inherit begin-edit-sequence end-edit-sequence)
+          (define/override (copy-self)
+            (let ([t (make-object plain-text% delta)])
+              (copy-self-to t)
+              t))
+          (define/augment (on-insert x y)
+            (begin-edit-sequence)
+            (inner (void) on-insert x y))
+          (define/augment (after-insert x y)
+            (change-style delta x (+ x y))
+            (end-edit-sequence)
+            (inner (void) after-insert x y))
+          
+          (define/override (get-keymaps)
+            (cons (keymap:get-file) (super get-keymaps)))
+          
+          (inherit set-styles-sticky)
+          (super-instantiate ())
+          (set-styles-sticky #f)))
+      
+      (define xml-keymap (make-object keymap%))
+      (send xml-keymap add-function 
+            "matching-xml" 
+            (lambda (x e) 
+              (when (is-a? x text%)
+                (matching-xml x))))
+      (send xml-keymap map-function ">" "matching-xml")
+      
+      ;; The editor standard style list's Standard size changes
+      ;; according to the font size preference. So,
+      ;; we create an XML style based on that stule
+      ;; for the XML boxes, so they change size too.
+      (let* ([style-list (editor:get-standard-style-list)]
+             [style (send style-list find-named-style "XML")]) 
+        (unless style
+          (let ([xml-delta (make-object style-delta% 'change-family 'default)])
+            (send style-list new-named-style "XML" 
+                  (send style-list find-or-create-style 
+                        (send style-list find-named-style "Standard")
+                        xml-delta)))))
+
+      (define xml-text-mixin
+        (mixin (editor:keymap<%> editor:standard-style-list<%> (class->interface text%)) ()
+          (define/override (get-keymaps)
+            (cons xml-keymap (super get-keymaps)))
+          
+          (inherit begin-edit-sequence end-edit-sequence
+                   change-style get-style-list)
+          (define/augment (on-insert start rng)
+            (begin-edit-sequence)
+            (inner (void) on-insert start rng))
+          (define/augment (after-insert start rng)
+            (inner (void) after-insert start rng)
+            (change-style (send (get-style-list) find-named-style "XML")
+                          start 
+                          (+ start rng))
+            (end-edit-sequence))
+          
+          (super-instantiate ())
+          
+          (inherit set-style-list)
+          ))
+      
+      (define get-xml-text%
+	(let ([xml-text% #f])
+	  (lambda ()
+	    (unless xml-text%
+	      (set! xml-text% (class ((drscheme:unit:get-program-editor-mixin)
+                                      (xml-text-mixin
+                                       plain-text%))
+                                (inherit copy-self-to)
+                                (define/override (copy-self)
+                                  (let ([t (new xml-text%)])
+                                    (copy-self-to t)
+                                    t))
+                                (super-new))))
+            xml-text%)))
+
+      ;; matching-xml : (is-a?/c text) -> void
+      ;; inserts > and if there is an XML tag just
+      ;; before the caret, inserts the corresponding
+      ;; close XML tag after the caret.
+      (define (matching-xml text)
+        (send text begin-edit-sequence)
+        (send text insert ">")
+        (let* ([start (send text get-start-position)]
+               [tagname (find-tag text start)])
+          (when tagname
+            (send text insert "</")
+            (send text insert tagname)
+            (send text insert ">")
+            (send text set-position start)))
+        (send text end-edit-sequence))
+      
+      ;; find-tag : (is-a?/c text%) number? -> (union false? string?)
+      ;; finds the name of the XML tag just before `start' in `text'.
+      ;; returns the tag name, with no trailing space of > or anything like that.
+      (define (find-tag text start)
+        ;; loop iterates backwards, searching for #\<
+        ;; when it finds it, it gets the string starting
+        ;; there, forwards to last-space (if there was a space)
+        ;; or start-1.
+        ;; If there is a #\/ or a #\> just after the #\<, return #f
+        ;; (in that case, they are typing a close tag or closing an empty tag)
+        ;; this technique gleaned from the spec at:
+        ;;  http://www.w3.org/TR/2000/REC-xml-20001006
+        (let loop ([pos (- start 2)]
+                   [last-space #f])
+          (cond
+            [(< pos 0) #f]
+            [else
+             (let ([char (send text get-character pos)])
+               (case char
+                 [(#\>) #f]
+                 [(#\<) 
+                  (if (or (char=? (send text get-character (+ pos 1)) #\/)
+                          (char=? (send text get-character (+ pos 1)) #\>))
+                      #f
+                      (send text get-text (+ pos 1) (or last-space (- start 1))))]
+                 [(#\space #\return #\newline #\tab)
+                  (loop (- pos 1) pos)]
+                 [else (loop (- pos 1) last-space)]))])))
+      
+      (define (xml-box-frame-extension super%)
+        (class super%
+          (inherit get-editor get-special-menu get-edit-target-object)
+          
+          (super-instantiate ())
+          
+          (let* ([menu (get-special-menu)]
+                 [find-insertion-point ;; -> (union #f editor<%>)
+                  ;; returns the editor (if there is one) with the keyboard focus
+                  (lambda ()
+                    (let ([editor (get-edit-target-object)])
+                      (and editor
+                           (is-a? editor editor<%>)
+                           (let loop ([editor editor])
+                             (let ([focused (send editor get-focus-snip)])
+                               (if (and focused
+                                        (is-a? focused editor-snip%))
+                                   (loop (send focused get-editor))
+                                   editor))))))]
+                 [insert-snip
+                  (lambda (make-obj)
+                    (let ([editor (find-insertion-point)])
+                      (when editor
+                        (let ([snip (make-obj)])
+                          (send editor insert snip)
+                          (send editor set-caret-owner snip 'display)))))]
+                 [demand-callback ;; : menu-item% -> void
+                  ;; enables the menu item when there is an editor available.
+                  (lambda (item)
+                    (send item enable (find-insertion-point)))])
+            (instantiate menu:can-restore-menu-item% ()
+              (label (string-constant xml-tool-insert-xml-box))
+              (parent menu)
+              (demand-callback demand-callback)
+              (callback
+               (lambda (menu evt)
+                 (insert-snip
+                  (lambda () 
+                    (instantiate xml-snip% ()
+                      [eliminate-whitespace-in-empty-tags?
+                       (preferences:get 'drscheme:xml-eliminate-whitespace)]))))))
+            (instantiate menu:can-restore-menu-item% ()
+              (label (string-constant xml-tool-insert-scheme-box))
+              (parent menu)
+              (demand-callback demand-callback)
+              (callback 
+               (lambda (menu evt)
+                 (insert-snip 
+                  (lambda () (instantiate scheme-snip% () (splice? #f)))))))
+            (instantiate menu:can-restore-menu-item% ()
+              (label (string-constant xml-tool-insert-scheme-splice-box))
+              (parent menu)
+              (demand-callback demand-callback)
+              (callback
+               (lambda (menu evt)
+                 (insert-snip
+                  (lambda () (instantiate scheme-snip% () (splice? #t))))))))
+          
+          (frame:reorder-menus this)))
+      
+      (drscheme:get/extend:extend-unit-frame xml-box-frame-extension))))
diff --git a/collects/string-constants/danish-string-constants.ss b/collects/string-constants/danish-string-constants.ss
new file mode 100644
index 0000000000..68606d62ff
--- /dev/null
+++ b/collects/string-constants/danish-string-constants.ss
@@ -0,0 +1,1102 @@
+(module danish-string-constants "string-constant-lang.ss"
+ ;;; when translating this constant, substitue name of actual langauge for `English'
+ (is-this-your-native-language "Foretrækker du dansk?")
+
+ (are-you-sure-you-want-to-switch-languages
+  "Dette ændrer sproget i den grafiske brugerflade. Er du sikker?")
+
+ (interact-with-drscheme-in-language "Arbejd med DrScheme på Dansk")
+
+ ;; these two should probably be the same in all languages except English.
+ ;; they are the button labels (under macos and windows, respectively)
+ ;; that go the with the string above.
+ (accept-and-quit "Accepter og afslut")
+ (accept-and-exit "Accepter og afslut")
+
+ ;;; general purpose (DrScheme is hereby a word in every language, by decree of Robby :)
+ (plt "PLT")
+ (drscheme "DrScheme")
+ (ok "Ok")
+ (cancel "Fortryd")
+ (untitled "Uden navn")
+ (untitled-n "Uden navn ~a")
+ (warning "Advarsel")
+ (error "Fejl")
+ (close "Luk") ;; as in, close an open window
+ (stop "Stop")
+ (&stop "&Stop") ;; for use in button and menu item labels, with short cut.
+ (are-you-sure-delete? "Er du sikker på, du vil slette ~a?") ;; ~a is a filename or directory name
+ (ignore "Ignorer")
+ (revert "Gendan")
+
+ ;; label for a generic check box, often supported on dialogs
+ ;; that ask a binary choice of the user. If checked, the
+ ;; dialog isn't going to be shown again.
+ (dont-ask-again "Spørg ikke igen (brugt altid nuværende valg)")
+
+ ;;; important urls
+ (web-materials "Relaterede websites") ;; menu item title
+ (tool-web-sites "Tool Web Sites")   ;; menu item title
+ (drscheme-homepage "DrScheme")
+ (plt-homepage "PLT")
+ (how-to-use-scheme "How to Use Scheme") ;; title of a book.
+ (teachscheme!-homepage "TeachScheme!") ;; probably this should be a `word' in all languages
+
+ ;;; bug report form
+ (cancel-bug-report? "Fortryd afsendelse af fejlrapport?")
+ (are-you-sure-cancel-bug-report?
+  "Er du sikker, du ikke vil afsende denne fejlrapport?")
+ (bug-report-form "Fejlrapportering")
+ (bug-report-field-name "Navn")
+ (bug-report-field-email "E-mail")
+ (bug-report-field-summary "Resumé")
+ (bug-report-field-severity "Alvorlighedsgrad")
+ (bug-report-field-class "Klasse")
+ (bug-report-field-priority "Prioritet")
+ (bug-report-field-description "Beskrivelse")
+ (bug-report-field-reproduce1 "Skridt for at")
+ (bug-report-field-reproduce2 "reproducere fejlen")
+ (bug-report-field-environment "Omgivelse")
+ (bug-report-field-tools "Værktøjer")
+ (bug-report-field-docs-installed "Installeret dokumentation")
+ (bug-report-field-language "Sprog")
+ (bug-report-field-teachpacks "Undervisningspakker")
+ (bug-report-field-collections "Samlinger (Collections)")
+ (bug-report-field-human-language "Modersmål")
+ (bug-report-field-version "Version")
+ (bug-report-synthesized-information "Indsamlet information")  ;; dialog title
+ (bug-report-show-synthesized-info "Vis indsamlet information")
+ (bug-report-submit "Send")
+ (sending-bug-report "Afsender fejlrapport")
+ (error-sending-bug-report "Fejl under afsendelse af fejlrapport")
+ (error-sending-bug-report-expln "Der opstod en fejl ved afsendelse af fejlrapporten. Hvis din internetforbindelse ellers er velfungerende, besøg venligst:\n\n    http://bugs.plt-scheme.org/\n\nog send fejlrapporten ved hjælp af vores online fejlrapporteringsside. Vi er kede af besværet.\n\nFejlmeddelelsen er:\n~a")
+ (bug-report-sent "Fejlrapporten er afsendt")
+ (bug-report-sent-detail "Tak for fejlrapporten. Du bør modtage en bekræftigelse via e-email indenfor den næste halve time. Hvis du ikke får en bekræftigelse, så send en e-mail til scheme@plt-scheme.org.")
+ (illegal-bug-report "Ugyldig fejlrapport")
+ (pls-fill-in-field "Udfyld venligst feltet \"~a\" ")
+ (malformed-email-address "Ugyldig e-mail-adresse")
+ (pls-fill-in-either-description-or-reproduce "Udfyld venligst enten beskrivelsesfeltet eller feltet til reproduktion af fejlen.")
+
+ ;;; check syntax
+ (check-syntax "Syntakstjek")
+ (cs-italic "Kursiv")
+ (cs-bold "Fed")
+ (cs-underline "Understreget")
+ (cs-change-color "Skift farve")
+ (cs-tack/untack-arrow "Pile til/fra")
+ (cs-jump-to-next-bound-occurrence "Hop til næste bundne forekomst")
+ (cs-jump-to-binding "Hop til den bindende forekomst")
+ (cs-jump-to-definition "Hop til definition")
+; (cs-jump "Hop")
+ (cs-error-message "Fejlmeddelelse")
+ (cs-open-file "Ã…bn ~a")
+ (cs-rename-var "Omdøb ~a")
+ (cs-rename-id "Omdøb navn")
+ (cs-rename-var-to "Omdøb ~a til:")
+ (cs-name-duplication-error "Det nye navn, du har valgt, ~s, er i konflikt med et allerede eksisterende navn i dette virkefelt.")
+ (cs-status-init "Syntakstjek: Initialiserer omgivelser for brugerkode")
+ (cs-status-coloring-program "Syntakstjek: farver udtryk")
+ (cs-status-eval-compile-time "Syntakstjek: evaluering på oversættelsestid")
+ (cs-status-expanding-expression "Syntakstjek: Udvider (expanding) udtryk")
+ ;(cs-status-teachpacks "Syntakstjek: installerer undervisningspakke")
+ (cs-mouse-over-variable-import "variabel ~s importeret fra ~s")
+ (cs-mouse-over-syntax-import "syntaks ~s importeret fra ~s")
+
+ (cs-lexical-variable "leksikalsk varaibel")
+ (cs-lexical-syntax "leksikalsl syntaks")
+ (cs-imported-variable "importeret variabel")
+ (cs-imported-syntax "importeret syntaks")
+
+ ;;; info bar at botttom of drscheme frame
+ (collect-button-label "GC")
+ (read-only "Skrivebeskyttet")
+ (read/write "Læs/Skriv")
+ (auto-extend-selection "Auto-udvid")
+ (overwrite "Overskriv")
+ (running "kører")
+ (not-running "kører ikke")
+
+ ;;; misc
+ (welcome-to-something "Velkommen til ~a")
+
+ ; this appears in the drscheme about box.
+ (welcome-to-drscheme-version/language "Velkommen til DrScheme, version ~a, ~a")
+
+ ; these appear on subsequent lines in the `Help|Welcome to DrScheme' dialog.
+ (welcome-to-drscheme "Velkommen til DrScheme")
+ (version/language "version ~a, ~a")
+
+ (goto-line "GÃ¥ til linje")
+ (goto-line-invalid-number
+  "~a er ikke et gyldigt linjenummer. Det skal være et heltal mellem 1 og ~a")
+ (goto-position "GÃ¥ til position")
+ (no-full-name-since-not-saved
+  "Filen har ikke et fuldt navn, for den er endnu ikke gemt.")
+ (cannot-open-because-dne "Kan ikke åbne ~a, for den findes ikke")
+ (interactions-out-of-sync
+  "ADVARSEL: Interaktionsvinduet er ude af trit med definitionsvinduet. Klik på Kør.")
+ (file-is-not-saved "Filen \"~a\" er endnu ikke gemt.")
+ (save "Gem")
+ (please-choose-either "Vælg venligst enten \"~a\" eller \"~a\"")
+ (close-anyway "Luk alligevel")
+ (clear-anyway "Rens Anyway")
+
+ ;; menu item title
+ (log-definitions-and-interactions "Log definitioner og interaktioner...")
+ (stop-logging "Stop logføring")
+ (please-choose-a-log-directory "Vælg en mappe til loggen")
+ (logging-to "Log til: ")
+ (erase-log-directory-contents "Slet indholdet af log-mappen: ~a?")
+ (error-erasing-log-directory "Fejl under sletning ad log-mappens indhold.\n\n~a\n")
+
+ ;; modes
+ (mode-submenu-label "Tilstande")
+ (scheme-mode "Scheme-tilstand")
+ (text-mode "Tekst-tilstand")
+
+ (scheme-mode-color-symbol "Symbol")
+ (scheme-mode-color-keyword "Nøgleord")
+ (scheme-mode-color-comment "Kommentar")
+ (scheme-mode-color-string "Strenf")
+ (scheme-mode-color-constant "Konstant")
+ (scheme-mode-color-parenthesis "Parentes")
+ (scheme-mode-color-error "Fejl")
+ (scheme-mode-color-other "Andet")
+
+ (url "URL")
+ (url: "URL:")
+ (open-url... "Ã…bn URL...")
+ (open-url "Ã…bn URL")
+ (browse... "Gennemse...")
+ (bad-url "Ugyldig URL")
+ (bad-url:this "Ugyldig URL: ~a")
+
+ ;; Help Desk
+ (help "Hjælp")
+ (help-desk "Hjælpebord")
+ (plt:hd:search-results "Søgeresultater")
+ (plt:hd:search "Søg")
+ (plt:hd:search-for "Søg efter")
+ (plt:hd:lucky "Heldig!")
+ (plt:hd:feeling-lucky "Jeg føler mig heldig")
+ (plt:hd:stop "Stop")   
+ (plt:hd:options "Indstillinger") 
+ (plt:hd:configure "Konfigurer")
+ (plt:hd:home "Hjælpebordets start") 
+ (plt:hd:show-manuals "Vis manualer") 
+ (plt:hd:send-bug-report "Send fejlrapport")
+ (plt:hd:query-bug-reports "Søg efter fejlrapporter")
+ ; next 3 are popup menu choices in help desk search frame
+ (plt:hd:search-for-keyword "Nøgleord")
+ (plt:hd:search-for-keyword-or-index "Nøgleord eller indekseret opslag")
+ (plt:hd:search-for-keyword-or-index-or-text "Nøgleord, indekseret opslag eller tekst")
+ (plt:hd:exact-match "præcis match")
+ (plt:hd:containing-match "indeholdende match")
+ (plt:hd:regexp-match "regulært udtryk")
+ (plt:hd:find-docs-for "Find dokumentation om:")
+ (plt:hd:nothing-found-for-search-key "Intet fundet om \"~a\".")
+ (plt:hd:searching "Søger...")
+ (plt:hd:search-stopped "[Søgning stoppet.]")
+ (plt:hd:search-stopped-too-many-matches "[Søgning afbrudt: for mange resultater")
+ (plt:hd:nothing-found-for "Intet fundet om ~a")
+ (plt:hd:error-finding-docs "Kunne ikke finde dokumentation.\n\n~a")
+ (plt:hd:and "og")
+ (plt:hd:refresh "opdater")
+ (plt:hd:refresh-all-manuals "opdater alle manualer")
+ (plt:hd:manual-installed-date "(~a installeret)")
+ ; Help Desk configuration
+ (plt:hd:configuration "PLT Hjælpebordskonfiguration")
+ (plt:hd:no-frames "Ingen rammer (frames)")
+ (plt:hd:use-frames "Brug rammer (frames)")
+ (plt:hd:use-html-frames "Brug HTML-rammer")
+ (plt:hd:search-pane-options "Indstillinger for søgepanel")
+ (plt:hd:height "Højde")
+ (plt:hd:bg-color "Baggrundsfarve")
+ (plt:hd:pixels "pixels")
+ (plt:hd:text-color "Tekstfarve")
+ (plt:hd:link-color "Linkfarve")
+ (plt:hd:text-sample "Søgepanelet har denne farve")
+ (plt:hd:link-sample "Links i søgepanelet har denne farve")
+ (plt:hd:save-changes "Gem ændringer")
+ (plt:hd:reset "Reset")
+ (plt:hd:defaults "Standardindstillinger")
+ (plt:hd:javascript-note
+    "De valg du gør vil blive vist her, hvis du har JavaScript sat til, og en ny moderne standard-følgende browser.")
+ ;; refreshing manuals
+ (plt:hd:refresh-downloading "Henter ~a")
+ (plt:hd:refresh-installing "Installerer ~a")
+ (plt:hd:refresh-clearing-indicies "Renser forgemte indekser")
+ (plt:hd:refresh-progress "PLT-manualhentningsfremskridt")
+;; should not mention `SVN' (plt:hd:refresh-done "Færdig med at opdatere SVN-manualer")
+ (plt:hd:refresh-installation-log "Installationslog")
+ (plt:hd:refresh-stopped "Opdatering af PLT-manualer stoppet")
+ (plt:hd:refreshing-manuals "Genhenter manualer")
+ (plt:hd:refresh-downloading... "Henter ~a...")
+ (plt:hd:refresh-deleting... "Sletter gammel version af ~a...")
+ (plt:hd:refresh-installing... "Installerer ny version af ~a...")
+ (plt:hd:refreshing-manuals-finished "Færdig.")
+ (plt:hd:about-help-desk "Om hjælpebord")
+ (plt:hd:help-desk-about-string
+  "Hjælpebord er en fuldstændig kilde af information om PLT-software, inklusive DrScheme, MzScheme og MrEd.\n\nVersion ~a\nCopyright (c) 1995-2003 PLT")
+ (plt:hd:help-on-help "Hjælp om hjælp")
+ (plt:hd:help-on-help-details "For hjælp om Hjælpebord, følg linket `How to use Help Desk'-linket på hjælpebordets startside.")
+  (reload "Opdater") ;; refresh the page in a web browser
+  (plt:hd:ask-about-separate-browser
+   "Du har valgt et link til indhold på internettet. Vil du se det i Hjælpebordsbrwoseren eller i et separat browserprogram?")
+  (plt:hd:homebrew-browser "Hjælpebordsbrowser") ;; choice for the above string (in a button)
+  (plt:hd:separate-browser "Separat browser") ;; other choice for the above string (also in a button)
+  (plt:hd:external-link-in-help "Eksterne URL'er i hjælp")
+  (plt:hd:use-homebrew-browser "Brug hjælpebordsbrowseren til eksterne URL'er")
+  (plt:hd:new-help-desk "Nyt hjælpebord")
+  (plt:hd:teaching-manuals "Elev-dokumentation")
+  (plt:hd:professional-manuals "Professionel dokumentation")
+  (plt:hd:all-manuals "Al dokumentation")
+
+  ;; in the Help Desk language dialog, title on the right.
+  (plt:hd:manual-search-ordering "Søgeorden")
+
+ ; help desk htty proxy
+ (http-proxy "HTTP-proxy")
+ (proxy-direct-connection "Direkte forbindelse")
+ (proxy-use-proxy "Benyt proxyen:")
+ (proxy-host "Host")
+ (proxy-port "Port")
+ (proxy-bad-host "Ugyldig proxyvært")
+
+ ;; browser
+ (rewind-in-browser-history "Tilbage")
+ (forward-in-browser-history "Fremad")
+ (home "Hjem")
+ (browser "Browser")
+ (external-browser-choice-title "Ekstern browser") ; title for radio-button set
+ (browser-command-line-label "Kommandolinje:") ; label for radio button that is followed by text boxes
+ (choose-browser "Vælg en browser")
+ (no-browser "Spørg senere") ; English changed from "None" to "Ask Later"
+ (use-internal-browser-for-help "Læs hjælpen i den interne PLT webbrowser") ; radio-button label
+ (use-external-browser-for-help "Læs hjælpen med en ekstern webbrowser") ; radio-button label
+ (browser-cmdline-expl-line-1 "(Kommandolinjen konstrueret ved at sætte den forudgående tekst, URL'en,") ; explanatory text for dialog, line 1
+ (browser-cmdline-expl-line-2 "og den efterfølgende tekst sammen uden brug af mellemrum mellem dem.)") ; ... line 2. (Anyone need more lines?)
+ (cannot-display-url "Kan ikke vise URL ~s: ~a")
+ (install? "Installér?")  ;; if a .plt file is found (title of dialog)
+ (you-have-selected-an-installable-package "Du har valgt en pakke, som kan installeres.")
+ (do-you-want-to-install-it? "Vil du installere den?")
+ (paren-file-size "(Filen fylder ~a bytes)")
+ (download-and-install "Download og installér") ;; button label
+ (download "Download") ;; button label
+ (save-downloaded-file/size "Gem den downloadede fil (~a bytes) som ") ;; label for get-file dialog
+ (save-downloaded-file "Gem den downloadede file som")  ;; label for get-file dialog
+ (downloading "Downloader") ;; dialog title
+ (downloading-file... "Downloader fil...")
+ (package-was-installed "Pakken blev installeret.")
+ (download-was-saved "Den downloadede fil blev gemt.")
+ (getting-page "Henter side") ;; dialog title
+
+ (install-plt-file-menu-item... "Installer .plt-fil...")
+ (install-plt-file-dialog-title "Installer .plt-fil")
+ (install-plt-web-tab "Web")
+ (install-plt-file-tab "Fil")
+ (install-plt-filename "Filnavn:")
+ (install-plt-url "URL:")
+
+ ;; install plt file when opened in drscheme strings
+ (install-plt-file "Installer ~a eller åbn for at redigere?")
+ (install-plt-file/yes "Installer")
+ (install-plt-file/no "Rediger")
+
+ (plt-installer-progress-window-title "Installeringsfremgang")
+ (plt-installer-abort-installation "Afbryd installation") ;; button label
+ (plt-installer-aborted "Afbrudt.") ;; msg that appears in the installation window when installation is aborted
+
+
+ ;;; about box
+ (about-drscheme-frame-title "Om DrScheme")
+ (take-a-tour "Tag en rundvisning!")
+ (release-notes "Udgivelsesbemærkninger")
+ (parenthetical-last-version "(tidligere version ~a)")
+ (parenthetical-last-language "(tidligere language ~a)")
+ (parenthetical-last-version/language "(tidligere version ~a, modersmål ~a)")
+
+
+ ;;; save file in particular format prompting.
+ (save-as-plain-text "Gem denne fil som tekt?")
+ (save-in-drs-format "Gem denne fil i det DrScheme-specifikke ikke-tekst format?")
+ (yes "Ja")
+ (no "Nej")
+
+ ;;; preferences
+ (preferences "Indstillinger")
+ (saving-preferences "Gemmer indstillinger")
+ (error-unmarshalling "Error unmarshalling ~a preference")
+ (error-saving-preferences "Fejl under lagring af indstillinger: ~a")
+ (error-reading-preferences "Fejl ved indlæsning af indstillinger")
+ (expected-list-of-length2 "forventede en liste af længde 2")
+ (scheme-prefs-panel-label "Scheme")
+ (warnings-prefs-panel-label "Advarsler")
+ (editor-prefs-panel-label "Redigering")
+ (general-prefs-panel-label "Generelt")
+ (highlight-parens "Farv mellem samhørende parenteser")
+ (fixup-parens "Korriger parenteser, dvs. lav automatisk ) om til ] ")
+ (flash-paren-match "Blink ved samhørende parenteser")
+ (auto-save-files "Auto-save filer")
+ (backup-files "Backup filer")
+ (map-delete-to-backspace "Bind delete til backspace")
+ (verify-exit "Spørg ved nedlukning")
+ (ask-before-changing-format "Spørg før ændring af lagringsformat")
+ (wrap-words-in-editor-buffers "Ombryd ord i redigeringsbufferne")
+ (show-status-line "Vis statuslinjen")
+ (count-columns-from-one "Tæl søjlenumger fra en.")
+ (display-line-numbers "Vis linjenumre i bufferen; ikke tegn-offsets")
+ (enable-keybindings-in-menus "Slå tastaturgenveje i menuer til")
+ (automatically-to-ps "Udskriv automatisk til postscriptfil")
+ (use-mdi "Brug MDI vinduer") ;;; ms windows only -- use that window in a window thingy
+ (separate-dialog-for-searching "Brug separat dialog til søgning")
+ (reuse-existing-frames "Genbrug gamle vinduer, når nye filer åbnes")
+ (default-fonts "Standardskrifttyper")
+ (paren-match-color "Parentesfremhævningsfarve") ; in prefs dialog
+ (choose-color "Vælg farve") ; in prefs dialog
+ (online-coloring-active "Interaktiv syntaksfarvelægning")
+ (open-files-in-tabs "Ã…bn filer i separate faneblade (ikke separate vinduer)")
+
+ ; title of the color choosing dialog
+ (choose-paren-highlight-color "Vælg farve til parentesfremhævning")
+
+ ; should have entire alphabet
+ (font-example-string "Høj bly gom vandt fræk sexquiz på wc.")
+
+ (change-font-button-label "Skift")
+ (fonts "Fonte")
+
+ ; filled with type of font, eg modern, swiss, etc.
+ (choose-a-new-font "Vælg en ny \"~a\" font")
+
+ (font-size-slider-label "Størrelse")
+ (restart-to-see-font-changes "Genstart for at se fontændringer")
+
+ (font-prefs-panel-title "Font")
+ (font-name "Fontnavn")
+ (font-size "Fontstørrelse")
+ (set-font "Anvend font...")
+ (font-smoothing-label  "Skriftypeudglatning")
+ (font-smoothing-none "Ingen")
+ (font-smoothing-some "Nogen")
+ (font-smoothing-all "Fuld")
+ (font-smoothing-default "Brug systemindstillinger")
+ (select-font-name "Vælg skrifttypenavn")
+ (example-text "Eksempeltekst:")
+ (only-warn-once "Advar kun én gang, når kørsler og interaktioner er ude af trit")
+
+ ; warning message when lockfile is around
+ (waiting-for-pref-lock "Venter på indstillingernes låsefil...")
+ (pref-lock-not-gone
+  "Indstillingernes låsefil:\n\n   ~a\n\nforhindrer indstillingerne i at blive gemt. Sørg for, at du ikke kører PLT-programmer og slet denne fil.")
+ (still-locked-exit-anyway? "Indstillingerne blev ikke gemt rigtigt. Afslut alligevel?")
+
+ ;;; indenting preferences panel
+ (indenting-prefs-panel-label "Indrykning")
+
+ ; filled with define, lambda, or begin
+ (enter-new-keyword "Indtast et nyt ~a-lignende nøgleord:")
+ (x-keyword "~a nøgleord")
+ (x-like-keywords "~a-lignende nøgleord")
+
+ (expected-a-symbol "forventede et symbol, fandt: ~a")
+ (already-used-keyword "\"~a\" er allerede et nøgleord med speciel indrykning")
+ (add-keyword "Tilføj")
+ (remove-keyword "Fjern")
+
+ ;;; find/replace
+ (find-and-replace "Søg og erstat")
+ (find "Søg")
+ (replace "Erstat")
+ (dock "Minimer")
+ (undock "Gendan")
+ (use-separate-dialog-for-searching "Brug separat dialog til søgning")
+ (replace&find-again "Erstat og Søg igen") ;;; need double & to get a single &
+ (replace-to-end "Erstat til slutning")
+ (forward "Frem")
+ (backward "Tilbage")
+ (hide "Skjul")
+
+ ;;; multi-file-search
+ (mfs-multi-file-search-menu-item "Søg i filer...")
+ (mfs-string-match/graphics "Streng match (klarer filer med grafik)")
+ (mfs-regexp-match/no-graphics "Regulært udtryk (kun rå tekstfiler)")
+ (mfs-searching... "Søger...")
+ (mfs-configure-search "Søgeindstillinger") ;; dialog title
+ (mfs-files-section "Filer")   ;; section in config dialog
+ (mfs-search-section "Søg") ;; section in config dialog
+ (mfs-dir "Mappe")
+ (mfs-recur-over-subdirectories "Rekursivt i undermapper")
+ (mfs-regexp-filename-filter "Regexp filnavnsfilter")
+ (mfs-search-string "Søgestreng")
+ (mfs-drscheme-multi-file-search "DrScheme - Søgning i flere filer") ;; results window and error message title
+ (mfs-not-a-dir "\"~a\" er ikke en mappe")
+ (mfs-open-file "Ã…bn fil")
+ (mfs-stop-search "Stop søgning")
+ (mfs-case-sensitive-label "Forskel på store og små bogstaver")
+ (mfs-no-matches-found "Intet passende fundet.")
+ (mfs-search-interrupted "Søgning afbrudt.")
+
+ ;;; reverting a file
+ (error-reverting "DrScheme - Fejl ved gendanning")
+ (could-not-read "kunne ikke læse \"~a\"")
+ (are-you-sure-revert
+  "Er du sikker på, at du vil gendanne denne fil? En gendannen kan ikke fortrydes.")
+ (are-you-sure-revert-title "Gendan?")
+
+ ;;; saving a file
+ ; ~a is filled with the filename
+ (error-saving "Fejl under lagring") ;; title of error message dialog
+ (error-saving-file/name "Der var en fejl ved lagring af ~a.")
+ (error-loading "Indlæsefejl")
+ (error-loading-file/name "Fejl ved læsning af ~a.")
+ (unknown-filename "<< ukendt >>")
+
+ ;;; finder dialog
+ (must-specify-a-filename "Du skal angive et filnavn")
+ (file-does-not-exist "Filen \"~a\" findes ikke.")
+ (ask-because-file-exists "Filen \"~a\" findes allerede. Erstat den?")
+ (dne-or-cycle "Filen \"~a\" indeholder en ikke-eksisterende mappe eller en cykel.")
+ (get-file "Hent fil")
+ (put-file "Gem fil")
+ (full-pathname "Fuldt navn med sti")
+ (show-dot-files "Vis filer og mapper, som begynder med punktum.")
+ (up-directory-button-label "Op")
+ (add-button-label "Tilføj") ;;; for multi-file selection
+ (add-all-button-label "Tilføj alle") ;;; for multi-file selection
+ (remove-button-label "Fjern") ;;; for multi-file selection
+ (file-wrong-form "Det filnavn har ikke den rigtige form.")
+ (select-files "Vælg filer")
+ (select-file "Vælg en fil")
+ (dir-dne "Den mappe findes ikke.")
+ (file-dne "Den fil findes ikke.")
+ (empty-filename "Filnavnet skal indeholde et tegn.")
+ (that-is-dir-name "Det er et mappenavn.")
+
+ ;;; raw menu names -- these must match the
+ ;;; versions below, once the &s have been stripped.
+ ;;; if they don't, DrScheme's menus will appear
+ ;;; in the wrong order.
+ (file-menu "Filer")
+ (edit-menu "Rediger")
+ (help-menu "Hjælp")
+ (windows-menu "Vinduer")
+
+ ;;; menus
+ ;;; - in menu labels, the & indicates a alt-key based shortcut.
+ ;;; - sometimes, things are stuck in the middle of
+ ;;; menu item labels. For instance, in the case of
+ ;;; the "Save As" menu, you might see: "Save Definitions As".
+ ;;; be careful of spacing, follow the English, if possible.
+ ;;; - the ellipses in the `after' strings indicates that
+ ;;; more information is required from the user before completing
+ ;;; the command.
+
+ (file-menu-label "&Filer")
+
+ (new-info  "Opret en ny fil")
+ (new-menu-item "&Ny")
+ (new-...-menu-item "&Ny...")
+
+ (open-info "Ã…bn en fil fra disk")
+ (open-menu-item "&Ã…bn...")
+ (open-here-menu-item "&Ã…bn her...")
+
+ (open-recent-info "En liste af filer brugt for nylig")
+ (open-recent-menu-item "Ã…bn gammel")
+
+ (revert-info "Gendan diskkopien af denne fil")
+ (revert-menu-item "Gendan")
+
+ (save-info "Gem filen på disk")
+ (save-menu-item "&Gem")
+
+ (save-as-info "Gemmer filen med et nyt filnavn")
+ (save-as-menu-item "Gem &Som...")
+
+ (print-info "Udskriv filen på printer")
+ (print-menu-item "&Print...")
+
+ (close-info "Luk denne fil")
+ (close-menu-item "&Luk")
+
+ (quit-info "Luk alle vinduer")
+ (quit-menu-item-windows "E&xit")  ; TODO
+ (quit-menu-item-others "&Quit")
+
+ (edit-menu-label "&Rediger")
+
+ (undo-info "Fortryd sidste handling")
+ (undo-menu-item "&Fortryd")
+
+ (redo-info "Fortryd det seneste fortryd")
+ (redo-menu-item "&Omgør")
+
+ (cut-info "Flyt det sidst valgte til klippebordet til senere indsættelse")
+ (cut-menu-item "K&lip")
+
+ (copy-info "Kopier det sidst valgte til klippebordet til senere indsættelse")
+ (copy-menu-item "&Kopier")
+
+ (paste-info "Erstat det valgte med det senest kopierede eller klippede")
+ (paste-menu-item "&Indsæt")
+
+ (clear-info "Slet de valgte elementer uden at påvirke klippebordet eller indsætning")
+ (clear-menu-item-others "Rens")
+ (clear-menu-item-windows "&Rens")
+
+ (select-all-info "Marker alt")
+ (select-all-menu-item "Marker &alt")
+
+ (find-info "Søg efter streng")
+ (find-menu-item "Søg...")
+
+ (find-again-info "Søg efter samme streng som før")
+ (find-again-menu-item "Søg igen")
+
+ (replace-and-find-again-info "Erstat den nuværende tekst og gentag søgningen")
+ (replace-and-find-again-menu-item "Erstat og søg igen")
+
+ (preferences-info "Rediger dine indstillinger")
+ (preferences-menu-item "Indstillinger...")
+
+ (keybindings-info "Vis de gældende, aktive tastebindinger")
+ (keybindings-menu-item "Tastebindinger")
+ (keybindings-frame-title "Tastebindinger")
+ (keybindings-sort-by-name "Sortér efter Navn")
+ (keybindings-sort-by-key "Sortér efter Tast")
+
+ (insert-text-box-item "Indsæt tekstkasse")
+ (insert-pb-box-item   "Indsæt pasteboard-kasse")
+ (insert-image-item    "Indsæt billede...")
+ (insert-comment-box-menu-item-label "Indsæt kommentarkasse")
+ (insert-lambda "Indsæt &Lambda")
+ (insert-delta "Indsæt &Delta (define)")
+
+ (wrap-text-item       "Ombryd tekst")
+
+ (windows-menu-label "&Vinduer")
+ (bring-frame-to-front "Skift til andet vindue")       ;;; title of dialog
+ (bring-frame-to-front... "Skift til andet vindue...") ;;; corresponding title of menu item
+ (next-window "Næste vindue")
+ (previous-window "Forrige vindue")
+ (most-recent-window "Sidst besøgte vindue")
+
+ (view-menu-label "&Vis")
+ (show-overview "Vis programkontur")
+ (hide-overview "Skjul programkontur")
+ (show-module-browser "Vis moduloversigt")
+ (hide-module-browser "Skjul moduloversigt")
+
+ (help-menu-label "&Hjælp")
+ (about-info "Akkrediteringer og detaljer om dette program")
+ (about-menu-item "Om...")
+ (help-menu-check-for-updates "Undersøg, om der er opdateringer...")
+
+ ;; open here's new menu item
+ (create-new-window-or-clear-current
+  "Vil du have et nyt vindue, eller rense det gamle?")
+ (clear-current "Rens nuværende")
+ (new-window "Nyt vindue")
+
+ ;;; exiting and quitting are you sure dialog
+ ;;; (exit is used on windows, quit on macos. go figure)
+ (exit "Afslut")
+ (quit "Afslut")
+ ;;; in are-you-sure-format, either exit or quit is filled in (from above)
+ ;;; based on the platform drscheme is running on.
+ (are-you-sure-exit "Er du sikker, du vil afslutte?")
+ (are-you-sure-quit "Er du sikker, du vil afslutte?")
+
+ ;;; autosaving
+ (error-autosaving "Fejl under autosaving \"~a\".")
+ (autosaving-turned-off "Autosaving er slået fra \nindtil filen filen gemmes.")
+ (recover-autosave-files-frame-title "Gendan backupfiler")
+ (autosave-details "Detaljer")
+ (autosave-recover "Gendan")
+ (autosave-unknown-filename "<<ukendt>>")
+
+  ;; these are labels in a dialog that drscheme displays
+  ;; if you have leftover autosave files. to see the dialog,
+  ;; start up drscheme and modify (but don't save) a file
+  ;; (also, do this with an unsaved file). Wait for the autosave
+  ;; files to appear (typically 5 minutes). Kill DrScheme
+  ;; and restart it. You'll see the dialog
+  (autosave-autosave-label: "Autosave-fil:")
+  (autosave-original-label: "Original fil:")
+  (autosave-autosave-label "Autosave-fil")
+  (autosave-original-label "Original fil")
+  (autosave-compare-files "Sammenlign autosavede filer")
+
+  (autosave-show-autosave "Autosave-fil") ;; title of a window showing the autosave file
+
+  (autosave-explanation "DrScheme fandt autosavede filer, som måske indeholde ugemt arbejde.")
+
+  (autosave-recovered! "Gendannet!") ;; status of an autosave file
+  (autosave-deleted "Slettet")       ;; status of an autosave file
+
+  (autosave-error-deleting "Fejl under sletning ~a\n\n~a") ;; first is a filename, second is an error message from mz.
+  (autosave-delete-button "Slet")
+  (autosave-delete-title "Slet")  ;; title of a dialog asking for deletion confirmation
+  (autosave-done "Færdig")
+  
+  ;; appears in the file dialog
+  (autosave-restore-to-where? "Vælg et sted til at gemme autosave-filen.")
+
+
+ ;;; file modified warning
+ (file-has-been-modified
+  "Der er rettet i filen, siden den sidst blev gemt. Overskriv ændringerne?")
+ (overwrite-file-button-label "Overskriv")
+
+ (definitions-modified
+  "Definitionsteksten er blevet ændret i filsystemet; gem venligst eller brug 'vend tilbage' for at bruge den gamle version")
+ (drscheme-internal-error "Intern fejl i DrScheme")
+
+ ;;; tools
+ (invalid-tool-spec "Værkstøjsspecifikationen i collection ~a's info.ss filen er ugyldig. Forventede enten en streng eller en ikke-tom liste af strenge, fik: ~e")
+ (error-loading-tool-title "DrScheme - Fejl under hentning af værktøj ~s; ~s")
+ (error-invoking-tool-title "Fejl ved kørsel af værktøj ~s;~s")
+ (tool-tool-names-same-length "forventede `tool-names' og `tools' var to lister af samme længde i info.ss for ~s, fik ~e og ~e")
+ (tool-tool-icons-same-length  "forventede `tool-icons' og `tools' var to lister af samme længde i info.ss  for ~s, fik ~e and ~e")
+ (tool-tool-urls-same-length
+  "forventede `tool-urls' og `tools' var lister af samme længde  i info.ss-filen for ~s, fik ~e og ~e")
+ (error-getting-info-tool  "fejl ved hentning af info.ss file for ~s")
+ (tool-error-phase1 "Fejl i fase 1 for værktøjet ~s; ~s")
+ (tool-error-phase2 "Fejl i fase 2 for værktøjet ~s; ~s")
+
+
+ ;;; define popup menu
+ (end-of-buffer-define "<< slutning af buffer >>")
+ (sort-by-name "Sorter efter navn")
+ (sort-by-position "Sorter efter rækkefølge i programteksten")
+ (no-definitions-found "<< ingen definitioner fundet >>")
+ (jump-to-defn "Hop til definitionen af ~a")
+
+ (recent-items-sort-by-age "Sorter efter Alder")
+ (recent-items-sort-by-name "Sorter efter Navn")
+
+
+ ;;; view menu
+ (hide-definitions-menu-item-label "Skjul &Definitioner")
+ (show-definitions-menu-item-label "Vis &Definitioner")
+ (definitions-menu-item-help-string "Vis/Skjul definitionsvinduet")
+ (show-interactions-menu-item-label "Vis &Interaktioner")
+ (hide-interactions-menu-item-label "Skjul &Interaktioner")
+ (interactions-menu-item-help-string "Vis/Skjul interaktionsvinduet")
+ (show-toolbar "Vis &værktøjslinjen")
+ (hide-toolbar "Skjul &værktøjslinjen")
+
+ ;;; file menu
+ (save-definitions-as "Gem definitioner som...")
+ (save-definitions "Gem definitioner")
+ (print-definitions "Udskriv definitioner...")
+ (about-drscheme "Om DrScheme")
+ (save-other "Gem andet")
+ (save-definitions-as-text "Gem definitioner som tekst...")
+ (save-interactions "Gem interaktioner")
+ (save-interactions-as "Gem interaktioner som...")
+ (save-interactions-as-text "Gem interaktioner som tekst...")
+ (print-interactions "Udskriv interaktioner...")
+ (new-tab "Nyt faneblad")
+ (close-tab "Luk faneblad")
+
+ ;;; edit-menu
+ (split-menu-item-label "&Split")
+ (collapse-menu-item-label "K&ollaps")
+
+ ;;; language menu
+ (language-menu-name "&Sprog")
+
+ ;;; scheme-menu
+ (scheme-menu-name "S&cheme")
+ (execute-menu-item-label "Kør")
+ (execute-menu-item-help-string "Genstart programmet i definitionsvinduet")
+ (break-menu-item-label "Afbryd")
+ (break-menu-item-help-string "Afbryd den nuværende evaluering")
+ (kill-menu-item-label "Slå ihjel")
+ (kill-menu-item-help-string "Slå den nuværende evaluering ihjel")
+ (clear-error-highlight-menu-item-label "Fjern fejlfarvelægningen")
+ (clear-error-highlight-item-help-string "Fjerne den pinke farvelægning af fejlene")
+ (reindent-menu-item-label "&Indryk igen")
+ (reindent-all-menu-item-label "Indryk &alt igen")
+ (semicolon-comment-out-menu-item-label "&Udkommenter med semikolonner")
+ (box-comment-out-menu-item-label "&Udkommenter med en kasse")
+ (uncomment-menu-item-label "&Afkommenter")
+
+ (convert-to-semicolon-comment "Konverter til en semikolon-kommentar")
+
+
+ ;;; executables
+ (create-executable-menu-item-label "Lav binær kørselfil...")
+ (create-executable-title "Lav binær kørselsfil")
+ (must-save-before-executable "Du skal gemme dit program, før du laver en binær fil")
+ (save-an-executable "Gem en selvstændig kørselsfil (binary)")
+ (save-a-mred-launcher "Gem en MrEd-starter")
+ (save-a-mzscheme-launcher "Gem en MzScheme-starter")
+ (save-a-mred-stand-alone-executable "Gem en selvstændig MrEd-kørselsfil")
+ (save-a-mzscheme-stand-alone-executable "Gen en selvstændig MzScheme kørselsfil")
+ (definitions-not-saved "Definitionsvinduet har ikke været gemt. Den binære kørselsfil vil bruge den senest gemte version af definitionsvinduet. Fortsæt?")
+ (inline-saved-program-in-executable?  "Indlejr det gemte program i en binær kørselsfil? Hvis ja, så kan du kopiere kørselsfilen til en anden ~a computer, men kørselsfilen vil være ret stor. Hvis ikke, kan du ikke kopiere det gemte program til en anden computer, men den vil være meget mindre. I tilgift, hvis ikke, vil kørselsfilen bruge den seneste version af programmet.")
+ (use-mred-binary?
+  "Brug mred til denne kørselsfil?\n\nHvis ja, så kan dit program bruge biblioteket (lib \"mred.ss\" \"mred\"). Hvis nej, så vil DrScheme bruge mzscheme til kørselsfilen and du kan ikke bruge mred-biblioteket.\n\nHvis du er i tvivl, så vælg ja.")
+ (inline-saved-program-in-executable/windows/path
+   "ADVARSEL! Den frembragte kørselsfil afhænger af tre DLL'er: libmred.dll, libmzsch.gll og libgc.dll, som findes i \n\n~a\n\nKørselsfilen finder DLL'erne enten i kørselsfilens mappe eller gennem miljøvariablen PATH.\n\nDa du installerede DrScheme, tilføjede installationsprogrammet mappen med DLL'erne til brugerens PATH. Vær opmærksom på konfigurationsændringer efter installationen.\n\nHvis du flytter kørselsfilen til en anden maskine, skal du også kopiere DLL'erne til den anden maskine --- enten til samme mappe som kørselsfilen, eller til en mappe i den anden maskines PATH.")
+ (launcher "Starter")
+ (stand-alone "Selvstænding")
+ (executable-type "Type")
+ (executable-base "Efternavn")
+ (filename "Filnavn: ")
+ (create "Lav")
+ (please-choose-an-executable-filename "Vælg et filnavn til kørselsfilen.")
+ (windows-executables-must-end-with-exe
+  "Filnavnet\n\n  ~a\n\ner ikke gyldigt.. Under Windows skal kørselsfiler have efternavnet .exe.")
+ (macosx-executables-must-end-with-app
+  "Filnavnet\n\n  ~a\n\ner ikke gyldigt. Under  MacOS X skal kørselsfiler have efternavnet .app.")
+ (warning-directory-will-be-replaced
+  "ADVARSEL: mappen:\n\n  ~a\n\nvil blive slettet. Fortsæt?")
+ 
+ (create-servlet "Lav en Servlet...")
+
+ ; the ~a is a language such as "module" or "algol60"
+ (create-servlet-unsupported-language
+  "Lav Servlet virker ikke med sproget ~a .")
+
+ ;;; buttons
+ (execute-button-label "Kør")
+ (save-button-label "Gem")
+ (break-button-label "Afbryd")
+
+ ;;; search help desk popup menu
+ (search-help-desk-for "Søg på hjælpebordet efter \"~a\"")
+ (exact-lucky-search-help-desk-for "Præcis, heldig søgning på hjælpebordet efter \"~a\"")
+
+ ;; collapse and expand popup menu items
+ (collapse-sexp "Kollaps s-udtryk")
+ (expand-sexp "Ekspander s-udtryk")
+
+ ;;; fraction dialog
+ (enter-fraction "Indtast brøk")
+ (whole-part "Hele del")
+ (numerator "Tæller")
+ (denominator "Nævner")
+ (invalid-number "Ugyldigt tal: skal være en være et eksakt, reelt, ikke-helt tal.")
+ (insert-fraction-menu-item-label "Indsæt brøk...")
+
+ ;; number snip popup menu
+ (show-decimal-expansion "Vis som decimaltal")
+ (show-fraction-view "Vis som brøk")
+ (show-mixed-fraction-view "Vis som blandet tal")
+ (show-improper-fraction-view "Vis som uægte brøk")
+ (show-more-decimal-places "Vis flere decimaler")
+
+ ;;; TeachPack messages
+ (select-a-teachpack "Vælg undervisningspakke")
+ (clear-teachpack "Fjern undervisningspakken ~a")
+ (teachpack-error-label "DrScheme - Undervisningspakkefejl")
+ (teachpack-dne/cant-read "Undervisningspakkefilen ~a findes ikke, eller er ikke læselig.")
+ (teachpack-didnt-load "Undervisningspakkefilen ~a blev ikke hentet rigtigt.")
+ (teachpack-error-invoke "Undervisningspakkefilen ~a gav en fejl ved kørsel af undervisningspakke...")
+ (add-teachpack-menu-item-label "Tilføj Undervisningspakke")
+ (clear-all-teachpacks-menu-item-label "Fjern alle undervisningspakker")
+ (drscheme-teachpack-message-title "DrScheme Undervisningspakke")
+ (already-added-teachpack "Undervisningspakken ~a er allerede tilføjet")
+
+ ;;; Language dialog
+ (introduction-to-language-dialog
+  "Vælg venligst et sprog. Elever i de fleste begynderkurser bør vælge det foreslåede sprog.")
+ (language-dialog-title "Vælg sprog")
+ (case-sensitive-label "Forskel på store og små bogstaver")
+ (output-style-label "Output-stil")
+ (constructor-printing-style "Konstruktør")
+ (quasiquote-printing-style "Kvasicitering")
+ (write-printing-style "write")
+ (print-printing-style "current-print")
+ (sharing-printing-label "Vis deling i værdier")
+ (use-pretty-printer-label "Indsæt linjeskift i printede værdier")
+ (input-syntax "Input-syntaks")
+ (dynamic-properties "Dynamiske egenskaber")
+ (output-syntax "Output-syntaks")
+ (no-debugging-or-profiling "Ingen debugning eller profilering")
+ (debugging "Debugging")
+ (debugging-and-profiling "Debugning og profilering")
+ (test-coverage "Syntaktisk dækning af testsuiten")
+ (whole/fractional-exact-numbers-label "Skriv tal som brøker")
+ (booleans-as-true/false-label "Skriv sandhedsværdier som true og false")
+ (show-details-button-label "Vis detaljer")
+ (hide-details-button-label "Skjul detaljer")
+ (choose-language-menu-item-label "Vælg sprog...")
+ (revert-to-language-defaults "Vend tilbage til standardsproget")
+ (language-docs-button-label "Sprogdokumentation")
+ (fraction-style "Brøkvisning")
+ (use-mixed-fractions "Uægte brøker")
+ (use-repeating-decimals "Periodeiske decimalbrøker")
+ (decimal-notation-for-rationals "Brug decimaltalsnotation for brøker")
+ (please-select-a-language "Vælg venligst et sprog")
+
+
+ ;;; languages
+ (beginning-student "Begynder")
+ (beginning-one-line-summary "define, cond, strukturer, konstanter og primitiver")
+ (beginning-student/abbrev "Begynder med listeforkortelser")
+ (beginning/abbrev-one-line-summary "Begynder, men udskrivning anvender listenotation i REPL")
+ (intermediate-student "Øvet")
+ (intermediate-one-line-summary "Begynder med leksikalske virkefelter")
+ (intermediate-student/lambda "Øvet med lambda")
+ (intermediate/lambda-one-line-summary "Øvet med funktioner af højere orden")
+ (advanced-student "Avanceret")
+ (advanced-one-line-summary "Øvet med lambda og mutation")
+ (full-language "Fuldstændig") ;; also in the HtDP languages section
+ (how-to-design-programs "How to Design Programs") ;; should agree with MIT Press on this one...
+ (r5rs-like-languages "R5RS-lignende")
+ (pretty-big-scheme "Temmelig omfattende Scheme (inklusiv MrEd og Avanceret)")
+ (pretty-big-scheme-one-line-summary "Grafisk, med mange standardbiblioteker")
+ (r5rs-lang-name "Standard (R5RS)")
+ (r5rs-one-line-summary "R5RS, uden dikkedarer")
+ (expander "Ekspanderen")
+ (expander-one-line-summary "Ekspandere, snarere end evaluerer udtryk")
+ (professional-languages "Professionelle sprog")
+ (teaching-languages "Undervisningssprog")
+ (experimental-languages "Eksperimentale sprog")
+
+ (module-language-one-line-summary "Sprog med modul som eneste konstruktion")
+
+
+ ;;; debug language
+ (unknown-debug-frame "[ukendt]")
+ (backtrace-window-title "Tilbagesporing - DrScheme")
+ (files-interactions "~a's interaktioner") ;; filled with a filename
+ (current-interactions "interaktioner")
+ (current-definitions "definitioner")
+; (stack-frame-in-current-interactions "interaktioner")
+; (stack-frame-in-current-definitions "definitioner")
+ (mzscheme-w/debug "Tekstuel (MzScheme, inkluderer R5RS)")
+ (mzscheme-one-line-summary "PLT Scheme uden GUI ")
+ (mred-w/debug "Grafisk (MrEd, inkluderer MzScheme)")
+ (mred-one-line-summary "PLT Scheme med GUI")
+
+ ;; profiling
+ (profiling-low-color "Lav")
+ (profiling-high-color "Høj")
+ (profiling-choose-low-color "Vælg en farve til lav")
+ (profiling-choose-high-color "Vælg en farve til høj")
+ (profiling "Profilering")
+ (profiling-example-text "(define (foo) (foo))")
+ (profiling-color-config "Farveområde for profilering")
+ (profiling-scale "Farveskala for profilering")
+ (profiling-sqrt "Kvadratrod")
+ (profiling-linear "Lineær")
+ (profiling-square "Kvadratisk")
+ (profiling-number "Antal funktionskald")
+ (profiling-time "Kumuleret tid")
+ (profiling-clear "Rens profil")
+ (profiling-update "Opdater profil")
+ (profiling-col-percent-time "% tid")
+ (profiling-col-function "Funktion")
+ (profiling-col-name "Navn")
+ (profiling-col-time-in-msec "millisekunder")
+ (profiling-col-calls "Kald")
+ (profiling-show-profile "Vis profil")
+ (profiling-hide-profile "Skjul profil")
+ (profiling-unknown-src "<< ukendt >>")
+ (profiling-no-information-available "Der er ingen profileringsinformation tilgængelig. Er du sikker på, at profilering er sat til i dit sprog, og at du har kørt dit program?")
+ (profiling-clear? "Ændringer i definitionsvinduet gør profileringsinformationen ugyldig. Fortsæt?")
+
+ ;; test coverage
+ (test-coverage-clear? "Ændringer i definitionsvinduet ugyldiggør testdækningsinformationen. Fortsæt?")
+ (test-coverage-clear-and-do-not-ask-again "Ja og spørg ikke igen")
+ (test-coverage-ask? "Spørg om at rense dækningen af testen")
+
+ ;;; repl stuff
+ (evaluation-terminated "Evaluering termineret")
+ (evaluation-terminated-explanation
+  "Evalueringstråden kører ikke længere, så der kan ikke foretages yderligere evaluering inden næste kørsel.")
+ (last-stack-frame "vis sidste stakramme")
+ (last-stack-frames "vis de ~a sidste stakrammer")
+ (next-stack-frames "vis de næste ~a stakrammer")
+
+ ;;; welcoming message in repl
+ (language "Sprog")
+ (custom "speciel")
+ (teachpack "Undervisningspakke")
+ (welcome-to "Velkommen til")
+ (version "version")
+
+ ;;; kill evaluation dialog
+ (kill-evaluation? "Vil du slå evalueringen ihjel?")
+ (just-break "Bare afbryd")
+ (kill "Ihjel")
+ (kill? "Ihjel?")
+
+ ;;; version checker
+ (vc-wizard-check-note 
+"Den version, du er ved at installere, er måske ikke den seneste.\n Hvis du vil kan DrScheme tjekke det for dig.")
+ (vc-wizard-check-button "Tjek om der findes en opdatering")
+ (vc-update-check "Opdateringstjek")
+ (vc-please-wait "Vent venligst")
+ (vc-connecting-version-server "Skaber forbindelse til PLT's versionsserver")
+ (vc-network-timeout "Netværkstimeout")
+ (vc-cannot-connect  "Kan ikke skabe forbindelse til PLT's versionsserver")
+ (vc-network-failure "Netværksfejl")
+ (vc-old-binaries "De instalerede binaries for DrScheme (eller MzScheme) er ikke up-to-date")
+ (vc-binary-information-format "Installeret binær version: ~a (iteration ~a)")
+ (vc-details-format "~a~nDetaljer:~n~a")
+ (vc-details-text "Detaljer:~n")
+ (vc-error-format "Fejl: ~a") 
+ (vc-current-format "~a v.~a (iteration ~a) er up-to-date")
+ (vc-update-format "~a v.~a (iteration ~a) behøver opdatering til v.~a (iteration ~a)")
+ (vc-binary-name "Binær")
+ (vc-updates-available "Opdateringer kan hentes hos")
+ (vc-latest-binary-information-format "Sidste offentliggjorte version: ~a (iteration ~a)")
+ (vc-update-dialog-title "PLT opdateringsstatus")
+ (vc-need-update-string "En eller flere installerede PLT software-pakker behøver opdatering")
+ (vc-no-update-string "Alle installerede softwarepakker fra PLT er allerede opdaterede")
+
+ ;; special menu
+ (special-menu "Speciel")
+
+ ;; large semi colon letters
+ (insert-large-letters... "Indsæt store bogstaver...")
+ (large-semicolon-letters "Store semikolon-bogstaver")
+ (text-to-insert "Tekst til indsættelse")
+
+ (module-browser-filename-format "Fuldt filnavn: ~a (~a linjer)")
+ (module-browser-root-filename "Rod-filnavn: ~a")
+ (module-browser-font-size-gauge-label "Skriftstørrelse")
+ (module-browser-progress-label "Fremgang for moduloverblik")
+ (module-browser-adding-file "Tilføjer fil: ~a...")
+ (module-browser-laying-out-graph-label "Beregner udseende for grafen")
+ (module-browser-open-file-format "Ã…bn ~a")
+ (module-browser "Moduloversigt") ;; frame title
+ (module-browser... "Moduloversigt...") ;; menu item title
+ (module-browser-error-expanding "Fejl under ekspansion af programmet:\n\n~a")
+ (module-browser-show-lib-paths "Vis filer læst via (lib ..) stier")
+ (module-browser-progress "Moduloversigt: ~a") ;; prefix in the status line
+ (module-browser-compiling-defns "Moduloversigt: oversætter definitioner")
+ (module-browser-show-lib-paths/short "Følg lib requires") ;; check box label in show module browser pane in drscheme window.
+ (module-browser-refresh "Opdater") ;; button label in show module browser pane in drscheme window.
+ (module-browser-only-in-plt-and-module-langs
+  "Moduloversigten er kun tilgængelig for programmer i PLT-sprogene og i modul-sproget (og kun for de programmer, som benytter moduler).")
+
+ (happy-birthday-matthias "Tillykke med fødselsdagen, Matthias!")
+ (happy-birthday-matthew  "Tillykke med fødselsdagen, Matthew!")
+ (happy-birthday-shriram  "Tillykke med fødselsdagen, Shriram!")
+
+ (mrflow-using-default-language-title "Sprog, som bruges når andet ikke er valgt")
+ (mrflow-using-default-language "Det sprog, som anvendes nu, har ikke en typetabel defineret for dets primitiver. R5RS Scheme bruges i stedet.")
+ (mrflow-button-title "Analyser")
+ ;(mrflow-unknown-style-delta-error-title "Unknown Box Style Delta")
+ ;(mrflow-unknown-style-delta-error "Unknown box style delta: ~a")
+ (mrflow-coloring-error-title "Ukendt farve")
+ (mrflow-coloring-error "Der er ikke defineret en stil for farven: ~a")
+ (mrflow-popup-menu-show-type "Vis type")
+ (mrflow-popup-menu-hide-type "Skjul type")
+ (mrflow-popup-menu-show-errors "Vis fejl")
+ (mrflow-popup-menu-hide-errors "Skjul fejl")
+
+ ;(mrflow-read-exception-title "Læseundtagelse (Read Exception)")
+ ;(mrflow-read-exception "Læseundtagelse (Read exception): ~a")
+ ;(mrflow-syntax-exception-title "Syntaksundtagelse")
+ ;(mrflow-syntax-exception "Syntaksundtagelse: ~a")
+ ;(mrflow-unknown-exception-title "Ukendt undtagelse")
+ ;(mrflow-unknwon-exception "Ukendt undtagelse: ~a")
+ ;(mrflow-language-primitives-error-title "Fejl i sprogprimitiver")
+ ;(mrflow-language-primitives-error "Forkert filnavn for tabellen med typer for sprogets primitiver: ~a")
+
+ (snips-and-arrows-popup-menu-tack-all-arrows "Vis alle pile")
+ (snips-and-arrows-popup-menu-untack-all-arrows "Skjul alle pile")
+ (snips-and-arrows-user-action-disallowed-title "Brugerændringer er i øjeblikket ikke tilladt")
+ (snips-and-arrows-user-action-disallowed "Brugerændringer er ikke tilladt i editorer, som indeholder snips (f.eks. pile) indsat fra et tool. Skjul alle snips for at få lov til at ændre editorens indhold.")
+ ;(snips-and-arrows-changing-terms-warning-title "Changing terms will be undoable")
+ ;(snips-and-arrows-changing-terms-warning "Changing terms in an editor containing snips cannot be undone.  You can either cancel this action, remove the snips, and try the change again, or you can continue with the change, in which case the change will not be undoable (all others changes made before and afterward will still be undoable though).")
+ (snips-and-arrows-hide-all-snips-in-editor "Skjul alle snips i editoren")
+  
+ (xml-tool-menu "XML")
+ (xml-tool-insert-xml-box "Indsæt XML-kasse")
+ (xml-tool-insert-scheme-box "Indsæt Scheme-kasse")
+ (xml-tool-insert-scheme-splice-box "Indsæt Scheme-splejningskasse (Splice Box)")
+ (xml-tool-xml-box "XML-Kasse")
+ (xml-tool-scheme-box "Scheme-Kasse")
+ (xml-tool-scheme-splice-box "Scheme-splejsningskasse Scheme Splice Box")
+ (xml-tool-switch-to-scheme "Skift til Scheme-kasse")
+ (xml-tool-switch-to-scheme-splice "Skift til Scheme-splejsningskasse")
+ (xml-tool-eliminate-whitespace-in-empty-tags "Fjern blanktegn i tomme tags")
+ (xml-tool-leave-whitespace-alone "Bevar blanktegn")
+
+ (show-recent-items-window-menu-item "Vis de senest åbnede filer i et separat vindue")
+ (show-recent-items-window-label "Senest åbnede filer")
+ (number-of-open-recent-items "Antal nye ting")
+ (switch-anyway "Skift fil alligevel")
+
+ (stepper-program-has-changed "ADVARSEL: Programmer er ændret.")
+ (stepper-program-window-closed "ADVARSEL: Programvinduet er væk.")
+
+ (wizard-next "Næste")
+ (wizard-back "Tilbage")
+ (wizard-finish "Færdig")
+
+
+ ;; warnings about closing a drscheme frame when the program
+ ;; might still be doing something interesting
+ (program-is-still-running "Programmet i definitionsvinduet kører stadig. Luk alligevel?")
+  (program-has-open-windows "Programmet i definitionsvinduet har åbne vinduer. Luk dette vindue alligevel?")
+
+  ;; ml-command-line-arguments is for the command line arguments
+  ;; label in the module language details in the language dialog.
+  (ml-command-line-arguments "Kommandolinje argumenter som en vektor af strenge i read-syntaks.")
+ 
+  ;; ml-cp names are all for the module language collection path
+  ;; configuration. See the details portion of the language dialog
+  ;; for the module language (at the bottom).
+  (ml-cp-default-collection-path "<<standard collection-sti>>")
+
+  ;; in std get-directory 
+  (ml-cp-choose-a-collection-path "Vælg en collection-sti")
+
+  ;; err msg when adding default twice
+  (ml-cp-default-already-present
+   "Standard collection-stien er allerede med")
+  
+  ;; title of this section of the dialog (possibly the word
+  ;; `Collection' should not be translated)
+  (ml-cp-collection-paths "Collection-stier")
+
+  ;; button labels
+  (ml-cp-add "Tilføj")
+  (ml-cp-add-default "Tilføj standardindstilling")
+  (ml-cp-remove "Fjern")
+  (ml-cp-raise "Op")
+  (ml-cp-lower "Ned")
+
+  ;; Profj
+  (profj-java "Java")
+  (profj-java-mode "Java-tilstands")
+  (profj-java-mode-color-keyword "nøgleord")
+  (profj-java-mode-color-string "streng")
+  (profj-java-mode-color-literal "bogstavelighed")
+  (profj-java-mode-color-comment "kommentar")
+  (profj-java-mode-color-error "fejl")
+  (profj-java-mode-color-identifier "navn")
+  (profj-java-mode-color-default "andet")
+  
+  ;; The Test Suite Tool
+  ;; Errors
+  (test-case-empty-error "Tom test")
+  (test-case-too-many-expressions-error "For mange udtryk i en test")
+  (test-case-not-at-top-level "Test-boks ikke på top-niveaue")
+  ;; Dr. Scheme window menu items
+  (test-case-insert "Indsæt test")
+  (test-case-disable-all "Slå alle tests fra")
+  (test-case-enable-all "Slå alle tests til")
+  ;; NOTE: The following three string constants are labels of the test-case fields. The width
+  ;;       of the field is determined by the length of the longest of the following three words.
+  ;;       if the words are too long the test case will take up too much horizontal room and
+  ;;       not look very good.
+  ;; This string is the label of the expression that is being tested in a test case.
+  ;(test-case-to-test "Skal testes")
+  ;; This string is the label of the expression that is the expected value of the to-test expression.
+  ;(test-case-expected "Forventet")
+  ;; This string is the label of the actual result of the to test expression.
+  (test-case-actual "Faktisk")
+
+ )
diff --git a/collects/string-constants/doc.txt b/collects/string-constants/doc.txt
new file mode 100644
index 0000000000..e506fdcf76
--- /dev/null
+++ b/collects/string-constants/doc.txt
@@ -0,0 +1,78 @@
+_String Constants_
+
+This library provides the facility for multiple langauges in
+DrScheme's GUI. These are the exported syntactic forms and
+procedures from
+
+   (lib "string-constant.ss" "string-constants")
+
+are
+        
+> (string-constant name) : string
+ 
+   This form returns the string constant named `name'.
+   
+> (string-constants name) : (listof string)
+
+  This form returns a list of string constants, one for each
+  language that DrScheme's GUI supports.
+  
+> (this-language) : symbol
+
+  This form returns the name of the current language
+  
+> (all-languages) : (listof symbol)
+
+  This form returns a list of symbols (in the same order as
+  those returned from string-constants) naming each
+  language.
+
+> (set-language-pref lang) : void
+
+  Sets the language for the next run of DrScheme to
+  lang, which must be a symbol returned from `all-languages'.
+  Does not affect the running DrScheme.
+  
+============================================================
+
+To add string-constants to DrScheme, see the files:
+
+  _english-string-constants.ss_
+  _french-string-constants.ss_
+  _spanish-string-constants.ss_
+  _german-string-constants.ss_
+  _danish-string-constants.ss_
+  _italian-string-constants.ss_
+  
+Each file has the same format. They are each modules
+in the "string-constant-lang.ss" language. The body of each
+module is a finite mapping table that gives the mapping
+from the symbolic name of a string constant to its
+translation in the appropriate language.
+
+The english-string-constants.ss is considered the master
+file -- string constants will be set there and translated
+into each of the other langauge files.  In addition, the
+english-string-constants.ss file should contain hints about
+the context of the strings whose symbol name might not be
+clear.
+
+============================================================
+
+_PLTSTRINGCONSTANTS_ environment variable
+_STRINGCONSTANTS_ environment variable
+
+If either of these environment variables are set, DrScheme
+shows you, during startup, which string constants are not
+yet defined for each langauge. 
+
+You can also specify which languages you are interested
+in. If either environment variable is bound to a symbol (as
+interpreted by `read') you see only the corresponding
+language's messages. If either one is bound to a list of
+symbol (again, as interpreted by `read') you see the
+messages for all the languages in the list. If either is
+bound to anything else, you see all of the languages.
+
+The PLTSTRINGCONSTANTS environment variable takes precedence
+of the STRINGCONSTANTS environment variaable.
diff --git a/collects/string-constants/dutch-string-constants.ss b/collects/string-constants/dutch-string-constants.ss
new file mode 100644
index 0000000000..54c3a48c3f
--- /dev/null
+++ b/collects/string-constants/dutch-string-constants.ss
@@ -0,0 +1,830 @@
+(module dutch-string-constants "string-constant-lang.ss"
+
+;;; -- Where are Undo, Redo, Select all, and friends from the right-click popup menu?
+
+ ;;; when translating this constant, substitute name of actual langauge for `English'
+ (is-this-your-native-language "Is uw moedertaal Nederlands?")
+
+ (are-you-sure-you-want-to-switch-languages
+  "Wisselen van taal vergt een herstart van DrScheme.  Weet u zeker dat u dit wilt?")
+
+ (interact-with-drscheme-in-language "Werk in het Nederlands met DrScheme")
+
+ ;; these two should probably be the same in all languages except English.
+ ;; they are the button labels (under macos and windows, respectively)
+ ;; that go the with the string above.
+ (accept-and-quit "OK, sluit DrScheme maar af")
+ (accept-and-exit "OK, sluit DrScheme maar af")
+ 
+ ;;; general purpose (DrScheme is hereby a word in every language, by decree of Robby :)
+ (plt "PLT")
+ (drscheme "DrScheme")
+ (ok "OK")
+ (cancel "Annuleren")
+ (untitled "Naamloos")
+ (untitled-n "Naamloos ~a")
+ (warning "Waarschuwing")
+ (error "Fout")
+ (close "Sluiten") ;; as in, close an open window
+ (stop "Stop")   
+ (&stop "&Stop") ;; for use in button and menu item labels, with short cut.
+
+ ;;; important urls
+ (web-materials "Verwante Web Sites") ;; menu item title
+ (drscheme-homepage "DrScheme")
+ (plt-homepage "PLT")
+ (how-to-use-scheme "How to Use Scheme") ;; title of a book.
+ (teachscheme!-homepage "TeachScheme!") ;; probably this should be a `word' in all languages
+
+ ;;; bug report form
+ (cancel-bug-report? "Melden defect afbreken?")
+ (are-you-sure-cancel-bug-report?
+  "Weet u zeker dat u deze defectmelding NIET wilt sturen?")
+ (bug-report-form "Defectmeldingsformulier")
+ (bug-report-field-name "Naam")
+ (bug-report-field-email "Email")
+ (bug-report-field-summary "Samenvatting")
+ (bug-report-field-severity "Ernst")
+ (bug-report-field-class "Aard")
+ (bug-report-field-priority "Belang")
+ (bug-report-field-description "Omschrijving")
+ (bug-report-field-reproduce1 "Hoe te")
+ (bug-report-field-reproduce2 "veroorzaken")
+ (bug-report-field-environment "Omgeving")
+ (bug-report-field-tools "Tools") ; <**> -- Where is this used?
+ (bug-report-field-docs-installed "Geïnstalleerde documentatie") ; if allowed, add \n
+ (bug-report-field-language "Programmeertaal")
+ (bug-report-field-teachpacks "Lespakketten")
+ (bug-report-field-collections "Collecties")
+ (bug-report-field-human-language "Spreektaal")
+ (bug-report-field-version "Versie")
+ (bug-report-synthesized-information "Systeeminformatie")  ;; dialog title
+ (bug-report-show-synthesized-info "Toon systeeminformatie")
+ (bug-report-submit "Stuur")
+ (sending-bug-report "Bezig de defectmelding te versturen")
+ (error-sending-bug-report "Fout bij het versturen van de defectmelding")
+ (error-sending-bug-report-expln "Het versturen van de defectmelding mislukte.  Mocht uw internetverbinding verder goed werken, ga dan naar:\n\n    http://bugs.plt-scheme.org/\n\nen verstuur de melding via het webformulier.  Sorry voor het ongemak.\n\nDe foutmelding is:\n~a")
+ (bug-report-sent "defectmelding verzonden")
+ (bug-report-sent-detail "Dank u voor de melding.  Als u niet binnen 30 minuten een bevestigingsmail ontvangt, mail dan naar scheme@plt-scheme.org.")
+ (illegal-bug-report "Ongeldige defectmelding")
+ (pls-fill-in-field "Gelieve het \"~a\"-veld in te vullen")
+ (malformed-email-address "Onmogelijk emailadres")
+ (pls-fill-in-either-description-or-reproduce "Gelieve hetzij het omschrijvings-, hetzij het \"hoe te veroorzaken\"-veld in te vullen.")
+
+ ;;; check syntax
+ (check-syntax "Controleer Syntaxis")
+ (cs-italic "Cursief")
+ (cs-bold "Vet")
+ (cs-underline "Onderstreept")
+ (cs-change-color "Andere kleur")
+ (cs-tack/untack-arrow "Pijlen vast/los")
+ (cs-jump "Spring") ; <**> -- "Jump" - where used?
+ (cs-error-message "Foutmelding")
+ (cs-open-file "Open ~a")
+ (cs-rename-var "Hernoem ~a")
+ (cs-rename-id "Hernoem Identifier") ;<**>
+ (cs-rename-var-to "Hernoem ~a tot:")
+ (cs-name-duplication-error "De nieuwgekozen naam ~s komt al voor in dit bereik")
+ 
+ ;;; info bar at botttom of drscheme frame
+ (collect-button-label "GC")
+ (read-only "Alleen lezen")
+ (read/write "Lezen/Schrijven")
+ (auto-extend-selection "Auto-extend") ; <**> -- when does this appear?
+ (overwrite "Vervang")
+ (running "Bezig")
+ (not-running "Klaar")
+ 
+ ;;; misc
+ (welcome-to-something "Welkom bij ~a")
+ 
+ ; this appears in the drscheme about box.
+ (welcome-to-drscheme-version/language "Welkom bij DrScheme, versie ~a, ~a")
+
+ ; these appear on subsequent lines in the `Help|Welcome to DrScheme' dialog.
+ (welcome-to-drscheme "Welkom bij DrScheme")
+ (version/language "versie ~a, ~a")
+
+ (goto-line "Ga naar regel")
+ (goto-line-invalid-number
+  "~a is geen geheel getal tussen 1 en ~a, dus geen geldig regelnummer")
+ (goto-position "Naar positie")
+ (no-full-name-since-not-saved "Dit bestand is nog nooit opgeslagen, en heeft dus nog geen naam.")
+ (cannot-open-because-dne "~a bestaat niet, en kan dus niet geopend worden.")
+ (interactions-out-of-sync
+  "WAARSCHUWING: Interactie- en definitievenster komen niet overeen.  Druk op Doen!.")
+ (file-is-not-saved "Het bestand \"~a\" is niet opgeslagen.")
+ (save "Opslaan")
+ (please-choose-either "Gelieve te kiezen tussen \"~a\" en \"~a\"")
+ (close-anyway "Toch sluiten")
+ (clear-anyway "Toch wissen") ; <**> -- check with actual usage
+
+ (url "URL")
+ (url: "URL:")
+ (open-url... "Open URL...")
+ (open-url "Open URL")
+ (browse... "Surf...") ; -- Translated as browsing on the Internet
+ (bad-url "Bad URL") ; <**>
+ (bad-url:this "Bad URL: ~a") ;<**>
+ 
+ ;; Help Desk
+ (search-results "Zoekresultaten")
+ (help-desk "Hulpbron")
+ (help-desk-n "Hulpbron ~a")
+ (about-help-desk "Omtrent de Hulpbron")
+ (help-desk-about-string
+  "De Hulpbron bevat complete informatie omtrent PLT programmatuur, waaronder DrScheme, MzScheme, en MrEd.\n\nVersie ~a\nAuteursrecht (c) 1995-2001 PLT")
+ (help-on-help "Hulp voor hulp")
+ (help-on-help-details "Voor hulp bij het gebruik van de Hulpbron, klik de link `Help Desk' op de startpagina van de Hulpbron. (Om op die startpagina te komen, klik op de Startknop bovenaan het hulpbronvenster.)")
+ (find-docs-for "Zoektekst:") ; <**> - This whole part needs redoing.  The "search" button is at the wrong place for natural Dutch..
+ (search "Zoek")
+ ; next 3 are popup menu choices at bottom of help desk window
+ (search-for-keyword "een trefwoord")
+ (search-for-keyword-or-index "een trefwoord of ingang") ; <**>
+ (search-for-keyword-or-index-or-text "als trefwoord, Index Entry of tekst") ; <**>
+ (exact-match "precies")
+ (containing-match "die dit bevat")
+ (regexp-match "regexp match")
+ (feeling-lucky "Het eerste het beste") ; -- Where does this occur?
+ (nothing-found-for-search-key "Niets gevonden voor \"~a\".")
+ (searching "Searching...")
+ (search-stopped "(Zoeken gestopt.)")
+ (search-stopped-too-many-matches "(Zoeken gestopt - te veel treffers.)")
+ (reload "Herlaad")
+ (help "Help")
+ (searching... "Zoeken...")
+ (nothing-found-for-empty-search "Gezocht naar niets -- niets gevonden")
+ (nothing-found-for "Geen treffers voor ~a")
+ (and "en")
+ (error-finding-docs "Kan documentatie niet vinden.\n\n~a")
+ (manual-installed-date "(geïnstalleerd op ~a)") ; -- assuming ~a is a date.
+
+ ;; refreshing manuals
+ (refreshing-manuals "Handleidingen opnieuw ophalen")
+ (refresh-downloading... "~a ophalen...")
+ (refresh-deleting... "Oude versie van ~a verwijderen...")
+ (refresh-installing... "Nieuwe versie van ~a installeren...")
+
+ ;; help desk htty proxy
+ (http-proxy "HTTP Proxy")
+ (proxy-direct-connection "Directe vebinding")
+ (proxy-use-proxy "Gebruik proxy:")
+ (proxy-host "Host")
+ (proxy-port "Port")
+ (proxy-bad-host "Verkeerde Proxy Host")
+
+ ;; browser
+ (rewind-in-browser-history "Terug")
+ (forward-in-browser-history "Vooruit")
+ (home "Start")
+ (browser "Browser")
+ (choose-browser "Kies een surfer") ; -- translated as Internet browser
+ (no-browser "Geen")
+ (cannot-display-url "Kan URL ~s niet tonen: ~a")
+ (install? "Installeren?")  ;; if a .plt file is found (title of dialog)
+ (you-have-selected-an-installable-package "U hebt een installeerbaar pakket gekozen.")
+ (do-you-want-to-install-it? "Wilt u het installeren?")
+ (paren-file-size "(Het bestand bevat ~a bytes)")
+ (download-and-install "Haal op && Installeer") ;; button label
+ (download "Haal op") ;; button label
+ (save-downloaded-file/size "Opgehaald bestand (~a bytes) opslaan als") ;; label for get-file dialog
+ (save-downloaded-file "Opgehaald bestand opslaan als")  ;; label for get-file dialog
+ (downloading "Ophalen") ;; dialog title
+ (downloading-file... "Bestand aan het ophalen...")
+ (package-was-installed "Het pakket is geïnstalleerd.")
+ (download-was-saved "Het opgehaalde bestand is opgeslagen.")
+ (getting-page "Getting Page") ;; dialog title
+
+ (install-plt-file-menu-item... "Installeer .plt-bestand...")
+ (install-plt-file-dialog-title "Installeer .plt-bestand")
+ (install-plt-web-tab "Web")
+ (install-plt-file-tab "Bestand")
+ (install-plt-filename "Bestandsnaam:")
+ (install-plt-url "URL:")
+ 
+ ;; install plt file when opened in drscheme strings
+ (install-plt-file "~a installeren of openen ter bewerking?")
+ (install-plt-file/yes "Installeer")
+ (install-plt-file/no "Bewerk")
+ 
+ ;;; about box
+ (about-drscheme-frame-title "Omtrent DrScheme")
+ (take-a-tour "Rondleiding!")
+ (release-notes "Versienotities")
+ (parenthetical-last-version "(vorige versie ~a)")
+ (parenthetical-last-language "(vorige taal ~a)")
+ (parenthetical-last-version/language "(vorige versie ~a, taal ~a)")
+ 
+ 
+ ;;; save file in particular format prompting.
+ (save-as-plain-text "Bestand opslaan als platte tekst?")
+ (save-in-drs-format "Bestand opslaan in DrScheme (niet tekst) -vorm?")
+ (yes "Ja")
+ (no "Nee") ; -- I personally prefer 'Neen', but it seems most younger people don't..
+ 
+ ;;; preferences
+ (preferences "Voorkeuren")
+ (saving-preferences "Voorkeuren opslaan")
+ (error-unmarshalling "Error unmarshalling ~a preference") ; <**> -- What does that mean?
+ (error-saving-preferences "Fout bij opslaan voorkeuren: ~a")
+ (error-reading-preferences "Fout bij lezen voorkeuren")
+ (expected-list-of-length2 "verwachtte een lijst van 2 lang")
+ (scheme-prefs-panel-label "Scheme")
+ (warnings-prefs-panel-label "Waarschuwingen")
+ (editor-prefs-panel-label "Bewerken")
+ (highlight-parens "Oplichten tussen bijeenhorende haken") ; -- ugly Dutch - should say something completely different, such as "highlight substructure"
+ (fixup-parens "Haken corrigeren")
+ (flash-paren-match "Knipper bijbehorende haak")
+ (auto-save-files "Bestanden automatisch opslaan")
+ (backup-files "Reservebestanden")
+ (map-delete-to-backspace "Delete naar links") ; -- to be changed if RtoL languages are supported
+ (verify-exit "Bevestiging bij afsluiten")
+ (ask-before-changing-format "Bevestiging bij opslaan in ander formaat")
+ (wrap-words-in-editor-buffers "Wrap words in editor buffers")
+ (show-status-line "Toon statusregel")
+ (count-from-one "Regels en kolommen tellen vanaf 1") 
+ (display-line-numbers "Toon regelnummers (geen letternummers) in buffer") ; -- 'buffer' is not wrong, but unclear
+ (enable-keybindings-in-menus "Gebruik sneltoetsen in menus")
+ (automatically-to-ps "Automatically print to postscript file")
+ (use-mdi "Vensters in vensters") ;;; ms windows only -- use that window in a window thingy
+ (separate-dialog-for-searching "Use separate dialog for searching")
+ (reuse-existing-frames "Reuse existing frames when opening new files")
+ (default-fonts "Verstek-lettertypen")
+ 
+ ; should have entire alphabet
+ (font-example-string "The quick brown fox jumps over lazy dogs.") 
+
+ (change-font-button-label "Veranderen") ; or: 'aanpassen' (= adapt)
+ (fonts "Lettertypen") ; -- Where is this used?  If context is clear, then just 'typen' is more natural.
+
+ ; filled with type of font, eg modern, swiss, etc.
+ (choose-a-new-font "Gelieve een nieuw \"~a\" type te kiezen")
+
+ (font-size-slider-label "Grootte")
+ (restart-to-see-font-changes "Herstart om veranderingen te zien")
+
+ (font-prefs-panel-title "Lettertypen")
+ (font-name "Naam")
+ (font-size "Grootte")
+ (set-font "Lettertype instellen...")
+ (select-font-name "Kies naam")
+ (example-text "Voorbeeldtekst:")
+ (only-warn-once "Slechts eenmaal waarschuwen als interacties niet met definitievenster overeenkomen") ; <**> -- The original English seems wrong here.  I translated "interactions" / "definitions" rather than "executions".
+ 
+ ; warning message when lockfile is around
+ (waiting-for-pref-lock "Waiting for the preferences lockfile...") ; <**>
+ (pref-lock-not-gone
+  "The preferences lockfile:\n\n   ~a\n\nprevents the preferences from being saved. Ensure that no PLT software is running and delete this file.")
+ (still-locked-exit-anyway? "Opslaan voorkeuren mislukt. Toch afsluiten?")
+ 
+ ;;; indenting preferences panel
+ (indenting-prefs-panel-label "Indenteren")
+
+ ; filled with define, lambda, or begin
+ (enter-new-keyword "Nieuw ~a-achtig trefwoord")
+ (x-keyword "~a trefwoord") ; -- Funny in English too, isn't it?  "Begin Keyword"
+ (x-like-keywords "~a-achtige trefwoorden")
+
+ (expected-a-symbol "verwachtte een symbool, kreeg: ~a")
+ (already-used-keyword "Het trefwoord \"~a\" heeft al een speciale indentatie")
+ (add-keyword "Toevoegen")
+ (remove-keyword "Verwijderen")
+ 
+ ;;; find/replace
+ (find-and-replace "Zoek en vervang")
+ (find "Zoek")
+ (replace "Vervang")
+ (dock "Aanhaken")
+ (undock "Zweven")
+ (use-separate-dialog-for-searching "Gebruik een apart zoekvenster")
+ (replace&find-again "Vervang && Zoek opnieuw") ;;; need double & to get a single &
+ (replace-to-end "Vervang tot einde")
+ (forward "Voorwaarts")
+ (backward "Terug")
+ (hide "Sluiten")
+ 
+ ;;; multi-file-search
+ (mfs-multi-file-search-menu-item "Zoek in bestanden...")
+ (mfs-string-match/graphics "String match (handles files with graphics)") ; <**>
+ (mfs-regexp-match/no-graphics "Regular Expression (alleen platte tekstbestanden)")
+ (mfs-searching... "Zoekt...")
+ (mfs-configure-search "Zoekinstellingen") ;; dialog title
+ (mfs-files-section "Bestanden")   ;; section in config dialog
+ (mfs-search-section "Zoek") ;; section in config dialog
+ (mfs-dir "Dir")
+ (mfs-recur-over-subdirectories "Recursief in mappen")
+ (mfs-regexp-filename-filter "Regexp filename filter")
+ (mfs-search-string "Zoektekst")
+ (mfs-drscheme-multi-file-search "DrScheme - Multi File Search") ;; results window and error message title
+ (mfs-not-a-dir "\"~a\" is geen map")
+ (mfs-open-file "Bestand openen")
+ (mfs-stop-search "Stop met zoeken")
+ (mfs-case-sensitive-label "Case sensitive") ; <**>
+ (mfs-no-matches-found "Geen treffers.")
+ (mfs-search-interrupted "Zoeken afgebroken.")
+ 
+ ;;; reverting a file
+ (error-reverting "DrScheme - Fout bij herladen")
+ (could-not-read "kan \"~a\" niet lezen")
+ (are-you-sure-revert "Herladen kan niet ongedaan gemaakt worden.  Toch doen?")
+ (are-you-sure-revert-title
+  "Herladen?")
+ 
+ ;;; saving a file
+ ; ~a is filled with the filename
+ (error-saving "Fout bij opslaan") ;; title of error message dialog
+ (error-saving-file/name "Er trad een fout op bij het opslaan van ~a.")
+
+ ;;; finder dialog
+ (must-specify-a-filename "You must specify a file name")
+ (file-does-not-exist "Bestand \"~a\" bestaat niet.")
+ (ask-because-file-exists "Bestand \"~a\" bestaat al. Vervangen?")
+ (dne-or-cycle "Bestand \"~a\" bevat een nietbestaande map, of een cykel.") ; -- weird English.  How can a file contain a directory?
+ (get-file "Get file") ; <**>
+ (put-file "Put file")
+ (full-pathname "Volledige padnaam")
+ (show-dot-files "Toon ook bestanden en mappen waarvan de naam met een punt begint.")
+ (up-directory-button-label "Één map omhoog")
+ (add-button-label "Toevoegen") ;;; for multi-file selection
+ (add-all-button-label "Alles toevoegen") ;;; for multi-file selection
+ (remove-button-label "Verwijderen") ;;; for multi-file selection
+ (file-wrong-form "Bestandsnaam heeft niet de juiste vorm.")
+ (select-files "Kies bestanden")
+ (select-file "Kies bestand")
+ (dir-dne "Map bestaat niet.")
+ (file-dne "Bestand bestaat niet.")
+ (empty-filename "Bestandsnaam moet minstens één letter bevatten.")
+ (that-is-dir-name "Dat is de naam van een map.")
+ 
+ ;;; raw menu names -- these must match the 
+ ;;; versions below, once the &s have been stripped.
+ ;;; if they don't, DrScheme's menus will appear
+ ;;; in the wrong order.
+ (file-menu "Bestand")
+ (edit-menu "Bewerken")
+ (help-menu "Hulp")
+ (windows-menu "Vensters")
+ 
+ ;;; menus
+ ;;; - in menu labels, the & indicates a alt-key based shortcut.
+ ;;; - sometimes, things are stuck in the middle of 
+ ;;; menu item labels. For instance, in the case of
+ ;;; the "Save As" menu, you might see: "Save Definitions As". 
+ ;;; be careful of spacing, follow the English, if possible.
+ ;;; - the ellipses in the `after' strings indicates that
+ ;;; more information is required from the user before completing
+ ;;; the command.
+
+ (file-menu-label "&Bestand")
+
+ (new-info  "Open nieuw bestand")
+ (new-menu-item "&Nieuw")
+ (new-...-menu-item "&Nieuw...")
+
+ (open-info "Open bestand van schijf")
+ (open-menu-item "&Open...")
+ (open-here-menu-item "&Open Hier...")
+
+ (open-recent-info "Onlangs geopende bestanden")
+ (open-recent-menu-item "Open opnieuw")
+ 
+ (revert-info "Negeer de gemaakte wijzigingen, en herlaad het bestand")
+ (revert-menu-item "&Herlaad")
+
+ (save-info "Sla dit bestand op een schijf op")
+ (save-menu-item "O&pslaan")
+
+ (save-as-info "Vraag om een naam en sla dit bestand onder die naam op")
+ (save-as-menu-item "Ops&laan als...")
+
+ (print-info "Stuur dit bestand naar een printer")
+ (print-menu-item "Af&drukken...")
+
+ (close-info "Sluit dit bestand")
+ (close-menu-item "&Sluiten")
+
+ (quit-info "Sluit alle vensters")
+ (quit-menu-item-windows "&Afsluiten")
+ (quit-menu-item-others "&Afsluiten")
+ 
+ (edit-menu-label "Be&werken")
+ 
+ (undo-info "Maak de laatste actie ongedaan")
+ (undo-menu-item "&Ongedaan maken")
+
+ (redo-info "Voer de als laatste ongedaangemaakte actie alsnog uit")
+ (redo-menu-item "Opnieuw &uitvoeren") ;<**> - does the & have the correct position?
+
+ (cut-info "Verplaats de selectie naar het klembord")
+ (cut-menu-item "K&nippen")
+
+ (copy-info "Kopieer de selectie naar het klembord")
+ (copy-menu-item "&Kopiëren")
+
+ (paste-info "Kopieer de inhoud van het klembord naar de plaats van de cursor")
+ (paste-menu-item "&Plakken")
+
+ (clear-info "Gooi de selectie weg")
+ (clear-menu-item-others "Wissen")
+ (clear-menu-item-windows "&Wissen")
+
+ (select-all-info "Selecteer het gehele document")
+ (select-all-menu-item "Selecteer a&lles")
+ 
+ (find-info "Zoek tekst in het document")
+ (find-menu-item "Zoek...")
+
+ (find-again-info "Zoek verder naar dezelfde tekst")
+ (find-again-menu-item "Zoek nogmaals")
+ 
+ (replace-and-find-again-info "Vervang de huidige selectie, en zoek verder")
+ (replace-and-find-again-menu-item "Vervang && Zoek nogmaals")
+
+ (preferences-info "Stel uw voorkeuren in")
+ (preferences-menu-item "Voorkeuren...")
+
+ (keybindings-info "Toon de huidige toetsbetekenissen")
+ (keybindings-menu-item "Toetsbetekenissen")
+ (keybindings-frame-title "Toetsbetekenissen")
+ (keybindings-sort-by-name "Op betekenis")
+ (keybindings-sort-by-key "Op toets")
+
+ (insert-text-box-item "Tekst")
+ (insert-pb-box-item "Pasteboard Box") ;<**>
+ (insert-image-item "Plaatje...")
+ (insert-comment-box-menu-item-label "Commentaarblok")
+ (wrap-text-item "Wrap Text") ; <**>
+ (wrap-text-item "Wrap Text")
+
+
+ (windows-menu-label "&Vensters")
+ (bring-frame-to-front "Kies venster")       ;;; title of dialog
+ (bring-frame-to-front... "Kies venster...") ;;; corresponding title of menu item
+ (next-window "Volgend venster")
+ (previous-window "Vorig venster")
+
+ (view-menu-label "&Tonen")
+ (show-overview "Overzicht") 
+ (hide-overview "Geen Overzicht")
+
+ (help-menu-label "&Hulp")
+ (about-info "Credits and details for this application") ; <**>
+ (about-menu-item "Info...")
+ (help-menu-check-for-updates "Recentere versies...")
+ 
+ ;;; help-desk-specific menus
+ (new-help-desk "Nieuwe Hulpbron")
+
+ ;; open here's new menu item
+ (create-new-window-or-clear-current
+  "Wilt u een nieuw venster openen, of het huidige wissen?")
+ (clear-current "Wis huidig")
+ (new-window "Open nieuw")
+
+ ;;; exiting and quitting ``are you sure'' dialog
+ ;;; (exit is used on windows, quit on macos, in English. Other
+ ;;; languages probably use the same word on both platforms.
+ (exit "Afsluiten")
+ (quit "Afsluiten")
+ (are-you-sure-exit "Weet u zeker dat u wilt afsluiten?")
+ (are-you-sure-quit "Weet u zeker dat u wilt afsluiten?")
+ 
+ ;;; autosaving
+ (error-autosaving "Fout bij automatisch opslaan van \"~a\".")
+ (autosaving-turned-off "Automatisch opslaan uitgezet tot\nhet bestand handmatig is opgeslagen.")
+ 
+ ;;; file modified warning
+ (file-has-been-modified
+  "Sinds de laatste opslag is dit bestand gewijzigd.  Veranderingen overschrijven?")
+ (overwrite-file-button-label "Overschrijven")
+ 
+ (definitions-modified
+  "Het bestand met de definities is gewijzigd.  Gelieve op te slaan of te herladen.")
+ (drscheme-internal-error "Interne Fout van DrScheme")
+ 
+ ;;; tools <**>
+ (invalid-tool-spec "The tool specification in collection ~a's info.ss file is invalid. Expected either a string or a non-empty list of strings, got: ~e")
+ (error-loading-tool-title "DrScheme - Error loading tool ~s; ~s")
+ (error-invoking-tool-title "Error invoking tool ~s;~s")
+ (tool-tool-names-same-length
+  "expected `tool-names' and `tools' to be lists of the same length, in info.ss file for ~s, got ~e and ~e")
+ (tool-tool-icons-same-length
+  "expected `tool-icons' and `tools' to be lists of the same length, in info.ss file for ~s, got ~e and ~e")
+ (error-getting-info-tool
+  "error loading info.ss file for ~s")
+ (tool-error-phase1 "Error in phase 1 for tool ~s; ~s")
+ (tool-error-phase2 "Error in phase 2 for tool ~s; ~s")
+
+
+ ;;; define popup menu
+ (end-of-buffer-define "<< buffereinde >>")
+ (sort-by-name "Sorteer op naam")
+ (sort-by-position "Sorteer op positie in bestand")
+ (no-definitions-found "<< geen definities gevonden >>")
+ (jump-to-defn "Spring naar definitie van ~a")
+
+ (recent-items-sort-by-age "Sorteer op leeftijd")
+ (recent-items-sort-by-name "Sorteer op naam")
+ 
+ ;;; show menu
+ (hide-definitions-menu-item-label "Geen &Definities")
+ (show-definitions-menu-item-label "&Definities")
+ (definitions-menu-item-help-string "Toon het definitievenster al dan niet")
+ (show-interactions-menu-item-label "&Interacties")
+ (hide-interactions-menu-item-label "Geen &Interacties niet")
+ (interactions-menu-item-help-string "Toon het interactievenster al dan niet")
+ 
+ ;;; file menu
+ (save-definitions-as "Definities ops&laan als...")
+ (save-definitions "Definities opslaan")
+ (print-definitions "Definitions af&drukken...")
+ (about-drscheme "Omtrent DrScheme")
+ (save-other "Anderszins opslaan")
+ (save-definitions-as-text "Definities opslaan als tekst...")
+ (save-interactions "Interacties opslaan")
+ (save-interactions-as "Interacties opslaan als...")
+ (save-interactions-as-text "Interacties opslaan als tekst...")
+ (print-interactions "Interacties afdrukken...")
+ 
+ ;;; edit-menu
+ (split-menu-item-label "&Splits")
+ (collapse-menu-item-label "V&oeg samen")
+ 
+ ;;; language menu
+ (language-menu-name "&Taal")
+ 
+ ;;; scheme-menu
+ (scheme-menu-name "S&cheme")
+ (execute-menu-item-label "Doen!")
+ (execute-menu-item-help-string "Voer het programma in het definitievenster uit")
+ (break-menu-item-label "Onderbreken")
+ (break-menu-item-help-string "Onderbreek de huidige berekening")
+ (kill-menu-item-label "Beëindigen")
+ (kill-menu-item-help-string "Beëindig de huidige berekening")
+ (clear-error-highlight-menu-item-label "Verwijder foutkleur")
+ (clear-error-highlight-item-help-string "Verwijdert de roze kleur die de fout aangeeft")
+ (reindent-menu-item-label "He&rindenteer")
+ (reindent-all-menu-item-label "Herindenteer &Alles")
+ (comment-out-menu-item-label "&Commentarieer weg")
+ (uncomment-menu-item-label "&Verwijder commentaartekens") ; -- Sorry, couldn't keep the &U..
+ 
+ ;;; executables
+ (create-executable-menu-item-label "Maak Exe...")
+ (create-executable-title "Maak Exe")
+ (must-save-before-executable "You must save your program before creating an executable.")
+ (save-an-executable "Sla Exe op")
+ (definitions-not-saved "The definitions window has not been saved. The executable will use the latest saved version of the definitions window. Continue?")
+ (inline-saved-program-in-executable?
+  "Inline the saved program in the executable? If yes, you can copy the executable to another ~a computer but the executable will be quite large. If not, you cannot copy the executable to another computer, but it will be much smaller. Additionally, if not, the executable will load the latest version of the program.")
+ (use-mred-binary?
+  "Use the mred binary for this executable?\n\nIf yes, your program can use the (lib \"mred.ss\" \"mred\") library. If no, DrScheme will use mzscheme as the binary for this executable and you cannot use that library.\n\nIf unsure, choose yes.")
+ (inline-saved-program-in-executable/windows/path
+   "WARNING! The generated executable relies on three DLLs: libmred.dll, libmzsch.gll, and libgc.dll, which are located at\n\n~a\n\nThe executable finds the DLLs either in the executable's directory or through the PATH enviornment variable.\n\nWhen you installed DrScheme, the installer adjusted the user's PATH to include the directory where the DLLs were installed. Beware of configuration or user changes since installation.\n\nIf you move the executable to another machine, you must also copy the DLLs to the other machine --- either to the same directory as the executable, or to a directory in the other machine's PATH.") ; -- error in English: enviornment
+ (launcher "Launcher")
+ (stand-alone "Stand-alone")
+ (executable-type "Type")
+ (executable-base "Base")
+ (filename "Bestandsnaam: ")
+ (create "Maak")
+ (please-choose-an-executable-filename "Kies een bestandsnaam voor het programma.")
+ 
+ (create-servlet "Maak Servlet...")
+  
+ ;;; buttons
+ (execute-button-label "Doen!") 
+ (save-button-label "Opslaan")
+ (break-button-label "Onderbreken")
+ 
+ ;;; search help desk popup menu
+ (search-help-desk-for "Zoek hulp omtrent \"~a\"")
+ (exact-lucky-search-help-desk-for "Geef hulp omtremt \"~a\"")
+
+ ;; collapse and expand popup menu items
+ (collapse-sexp "Sexpressie samenvouwen")
+ (expand-sexp "Sexpressie ontvouwen")
+ 
+ ;;; fraction dialog
+ (enter-fraction "Geef breuk")
+ (whole-part "Gehelen")
+ (numerator "Teller")
+ (denominator "Noemer")
+ (invalid-number "Onjuist getal: moet exact, reëel, en niet geheel zijn.")
+ (insert-fraction-menu-item-label "Breuk...")
+
+ ;; number snip popup menu
+ (show-decimal-expansion "Toon als decimaal getal")
+ (show-fraction-view "Toon als breuk")
+ (show-more-decimal-places "Toon meer decimalen")
+ 
+ ;;; Teachpack messages
+ (select-a-teachpack "Kies een lespakket")
+ (clear-teachpack "Verwijder lespakket ~a")
+ (teachpack-error-label "DrScheme - fout in lespakket") ; -- translated as "error in Teachpack".
+ (teachpack-dne/cant-read "Lespakket ~a bestaat niet of is onleesbaar.")
+ (teachpack-didnt-load "Lespakket ~a niet correct geladen.")
+ (teachpack-error-invoke "Lespakket ~a veroorzaakte bij aanroep een fout.")
+ (add-teachpack-menu-item-label "Lespakket toevoegen...")
+ (clear-all-teachpacks-menu-item-label "Alle lespakketten verwijderen")
+ (teachpack-not-only-one-import "Lespakket unit/sig in ~a moet precies één 'import' hebben.") ; <**> -- ??
+ (drscheme-teachpack-message-title "DrScheme-lespakket")
+ (already-added-teachpack "Lespakket ~a al aanwezig")
+ 
+ ;;; Language dialog
+ (introduction-to-language-dialog
+  "Kies een taal.  De verstekwaarde is normaliter de juiste voor beginnende cursisten.")
+ (language-dialog-title "Taal instellen")
+ (case-sensitive-label "Verschil tussen hoofd- en kleine letters") ; -- ugly
+ (output-style-label "Uitvoerstijl")
+ (constructor-printing-style "Constructor")
+ (quasiquote-printing-style "Quasiquote")
+ (write-printing-style "write")
+ (sharing-printing-label "Geef weerkerende delen in uitvoer aan")
+ (use-pretty-printer-label "Toon uitvoer netjes over meer regels") ; -- maybe rather: 'show indented'?
+ (input-syntax "Invoersyntaxis")
+ (dynamic-properties "Dynamische eigenschappen")
+ (output-syntax "Uitvoersyntaxis")
+ (no-debugging-or-profiling "Geen ontwikkelhulp")
+ (debugging "Alleen foutvinden")
+ (debugging-and-profiling "Foutvinden en klokken")
+ (whole/fractional-exact-numbers-label "Rationale getallen als breuken") ; -- 'rational numbers as fractions'
+ (booleans-as-true/false-label "Schrijf true/false in plaats van #T/#F")
+ (show-details-button-label "Toon details")
+ (hide-details-button-label "Toon details niet")
+ (choose-language-menu-item-label "Kies taal...")
+ (revert-to-language-defaults "Herstel verstekwaarden")
+ (language-docs-button-label "Taaldocumenten")
+ (fraction-style "Breukweergave")
+ (use-mixed-fractions "Gemengde breuken")
+ (use-repeating-decimals "Repeterende breuken")
+ (decimal-notation-for-rationals "Schrijf breuken decimaal")
+ (please-select-a-language "Kies een taal")
+
+ 
+ ;;; languages
+ (beginning-student "Beginner")
+ (beginning-one-line-summary "define, cond, structs, constanten, en primitieven")
+ (beginning-student/abbrev "Beginner, met lijstnotatie")
+ (beginning/abbrev-one-line-summary "Beginner, maar lijsten worden met lijstnotatie afgedrukt")
+ (intermediate-student "Middenmoot")
+ (intermediate-one-line-summary "Beginner, plus lexikaal bereik")
+ (intermediate-student/lambda "Middenmoot, plus lambda")
+ (intermediate/lambda-one-line-summary "Middenmoot, plus hogere-ordefuncties")
+ (advanced-student "Gevorderde")
+ (advanced-one-line-summary "Middenmoot, plus lambda en mutatie")
+ (full-language "Compleet") ;; also in the HtDP languages section
+ (how-to-design-programs "How to Design Programs") ;; should agree with MIT Press on this one...
+ (r5rs-like-languages "R5RS-achtig")
+ (pretty-big-scheme "Vrij groot (bevat MrEd en Gevorderde)")
+ (pretty-big-scheme-one-line-summary "Inclusief syntaxis and functies van de HtDP-talen")
+ (r5rs-lang-name "Standaard (R5RS)")
+ (r5rs-one-line-summary "R5RS, kaal")
+ (unknown-debug-frame "[onbekend]")
+ 
+ (module-language-one-line-summary "Execute creates a REPL in the context of the module, including the module's declared language")
+  
+ ;;; debug language
+ (backtrace-window-title "Spoor - DrScheme")
+ (files-interactions "~a's interacties") ;; filled with a filename
+ (current-interactions "interacties")
+ (current-definitions "definities")
+ (mzscheme-w/debug "Enkel tekst (MzScheme, omvat R5RS)")
+ (mzscheme-one-line-summary "PLTs onderliggende Scheme")
+ (mred-w/debug "Grafisch (MrEd, bevat MzScheme)")
+ (mred-one-line-summary "MzScheme met een grafische schil")
+
+ ;; profiling
+ (profiling-low-color "Laag")
+ (profiling-high-color "Hoog")
+ (profiling-choose-low-color "Kies een onderkleur")
+ (profiling-choose-high-color "Kies een bovenkleur")
+ (profiling "Klokken")
+ (profiling-example-text "(define (jippie) (jippie))")
+ (profiling-color-config "Kleurbereik")
+ (profiling-scale "Kleurschaling")
+ (profiling-sqrt "Vierkantswortel")
+ (profiling-linear "Lineair")
+ (profiling-square "Kwadratisch")
+ (profiling-number "Aantal aanroepen")
+ (profiling-time "Totaaltijd")
+ (profiling-clear "Wis klokgegevens")
+ (profiling-update "Werk klokgegevens bij")
+ (profiling-col-percent-time "% Tijd")
+ (profiling-col-function "Functie")
+ (profiling-col-name "Naam")
+ (profiling-col-time-in-msec "Msec")
+ (profiling-col-calls "Aanroepen")
+ (profiling-show-profile "Klokgegevens")
+ (profiling-hide-profile "Geen Klokgegevens")
+ (profiling-unknown-src "<< onbekend >>")
+ (profiling-no-information-available "Er zijn geen klokgegevens.  Deze zijn enkel beschikbaar als klokken in uw taal aanstaat, en u uw programma al gedraaid hebt.")
+
+ (profiling-clear? "Veranderingen in het definitievenster maken de klokgegevens ongeldig.  Toch doorgaan?")
+ 
+ ;;; repl stuff
+ (evaluation-terminated "Berekening gestopt")
+ (evaluation-terminated-explanation
+  "De rekenthread loopt niet meer, dus tot de volgende uitvoering kan geen berekening plaatsvinden.")
+ (last-stack-frame "toon top van de stapel")
+ (last-stack-frames "toon top ~a van de stapel")
+ (next-stack-frames "toon volgende ~a van de stapel")
+ 
+ ;;; welcoming message in repl
+ (language "Taal")
+ (custom "aangepast")
+ (teachpack "Lespakket")
+ (welcome-to "Welkom bij")
+ (version "versie")
+ 
+ ;;; kill evaluation dialog
+ (kill-evaluation? "Wilt u de berekeing beëindigen?")
+ (just-break "Enkel onderbreken")
+ (kill "Beëindigen")
+ (kill? "Beëindigen?")
+
+ ;;; version checker
+ (vc-update-check "Versie bijwerken")
+ (vc-please-wait "Even wachten a.u.b.")
+ (vc-connecting-version-server "Legt verbinding met PLT versieleverancier")
+ (vc-network-timeout "Netwerk plat") 
+ (vc-cannot-connect  "Geen verbinding met PLT versieleverancier")
+ (vc-network-failure "Networkprobleem")
+ (vc-old-binaries "Binaire code voor DrScheme (of MzScheme) is verouderd")
+ (vc-binary-information-format "Binaire code heeft versie: ~a (stap ~a)")
+ (vc-details-format "~a~nDetails:~n~a")
+ (vc-details-text "Details:~n")
+ (vc-error-format "Fout: ~a") 
+ (vc-current-format "~a v.~a (stap ~a) is bij")
+ (vc-update-format "~a v.~a (stap ~a) moet bijgewerkt worden tot v.~a (stap ~a)")
+ (vc-binary-name "Binair") ; <**> - translated as adjective.  Actual use not checked.
+ (vc-updates-available "Nieuwere versies verkrijgbaar te")
+ (vc-latest-binary-information-format "Jongste vrijgegeven versie: ~a (stap ~a)")
+ (vc-update-dialog-title "Status PLT-versie")
+ (vc-need-update-string "Sommige PLT-programmatuur is verouderd")
+ (vc-no-update-string "Alle geïnstalleerde PLT-programmatuur is bij")
+
+ ;; special menu
+ (special-menu "Invoegen")
+ 
+ ;; large semi colon letters
+ (insert-large-letters... "Krantenkop")
+ (large-semicolon-letters "Puntkommaletters")
+ (text-to-insert "Invoegtekst")
+
+ (module-browser-filename-format "Complete bestandsnaam: ~a (~a lines)")
+ (module-browser-root-filename "Root Filename: ~a")
+ (module-browser-font-size-gauge-label "Lettergrootte")
+ (module-browser-progress-label "Module overview progress")
+ (module-browser-adding-file "Toevoegen bestand: ~a...")
+ (module-browser-laying-out-graph-label "Opmaken graaf")
+ (module-browser-open-file-format "Open ~a")
+ (module-browser "Modulekiezer") ;; frame title
+ (module-browser... "Vind module...") ;; menu item title
+ (module-browser-error-expanding "Error expanding the program:\n\n~a")
+
+ (happy-birthday-matthias "Lang zal Matthias leven!")
+
+ (mrflow-using-default-language-title "Verstektaal gebruikt")
+ (mrflow-using-default-language "Er bestaat geen typetabel voor de primitieven van uw huidige taal.  Gelieve R5RS te gebruiken.")
+ (mrflow-button-title "Analyseer")
+ ;(mrflow-unknown-style-delta-error-title "Unknown Box Style Delta")
+ ;(mrflow-unknown-style-delta-error "Unknown box style delta: ~a")
+ (mrflow-coloring-error-title "Onbekende kleur")
+ (mrflow-coloring-error "Geen stijl opgegeven voor kleur: ~a")
+ (mrflow-popup-menu-show-type "Toon type")
+ (mrflow-popup-menu-hide-type "Toon type niet")
+ (mrflow-popup-menu-show-errors "Toon fouten")
+ (mrflow-popup-menu-hide-errors "Toon fouten niet")
+ (mrflow-popup-menu-tack-all-arrows "Alle pijlen vast")
+ (mrflow-popup-menu-untack-all-arrows "Alle pijlen los")
+ ;(mrflow-read-exception-title "Read Exception")
+ ;(mrflow-read-exception "Read exception: ~a")
+ ;(mrflow-syntax-exception-title "Syntax Exception")
+ ;(mrflow-syntax-exception "Syntax exception: ~a")
+ ;(mrflow-unknown-exception-title "Unknown Exception")
+ ;(mrflow-unknown-exception "Unknown exception: ~a")
+ ;(mrflow-language-primitives-error-title "Fout in basisfuncties")
+ ;(mrflow-language-primitives-error "Onjuiste bestandsnaam voor typentabel basisfuncties: ~a")
+
+ (xml-tool-menu "XML")
+ (xml-tool-insert-xml-box "XMLblok")
+ (xml-tool-insert-scheme-box "Schemeblok")
+ (xml-tool-insert-scheme-splice-box "Scheme Splice Box")
+ (xml-tool-xml-box "XML Box")
+ (xml-tool-scheme-box "Scheme Box")
+ (xml-tool-scheme-splice-box "Scheme Splice Box")
+ (xml-tool-switch-to-scheme "Switch to Scheme box")
+ (xml-tool-switch-to-scheme-splice "Switch to Scheme splice box")
+ (xml-tool-eliminate-whitespace-in-empty-tags
+  "Verwijder wit in lege tags") ; <**> - don't know the official Dutch for 'tag' here..
+ (xml-tool-leave-whitespace-alone "Laat wit staan")
+ 
+ (show-recent-items-window-menu-item "Toon onlangs geopende bestanden in een apart venster")
+ (show-recent-items-window-label "Onlangs geopende bestanden")
+ (number-of-open-recent-items "Aantal recente items")
+ (switch-anyway "Toch van bestand wisselen")
+
+ (stepper-program-has-changed "WAARSCHUWING: Programma is veranderd.")
+ (stepper-program-window-closed "WAARSCHUWING: Programmavenster is weg.")
+ )
+
+
diff --git a/collects/string-constants/english-string-constants.ss b/collects/string-constants/english-string-constants.ss
new file mode 100644
index 0000000000..5adde991e6
--- /dev/null
+++ b/collects/string-constants/english-string-constants.ss
@@ -0,0 +1,1284 @@
+#|
+
+When modifying the string constants files,
+please adhere to these guidelines:
+
+- All the entries in english-string-constants.ss have the same format
+  (name string).  If the purpose of an entry you are adding to the
+  file is not clear from just the name and string, put a comment next
+  to the entry explaining what the string is going to be used for and
+  in what context.
+  That's especially true for strings that contain things like "~a".
+  Systematically describe what the "~a" is going to be replaced with.
+  When we have to translate strings like "deleting ~a", we translators
+  need to know what "~a" is going to be (in particular, in some
+  languages like French, we need to know whether the "~a" is going to
+  be a masculine or feminine word, or whether it's going to be
+  singular or plural, etc).
+
+- When adding a bunch of new entries, put together in a section the
+  entries that logically belong together.  Give a title to your
+  section, so we have an idea of what the strings are for.  Don't mix
+  in the same section strings that have nothing to do with each other,
+  that's only going to confuse us.  Do not start a new section if
+  there's already one that deals with the same thing.  Dumping all the
+  new entries in random order at the end of the file is not a good way
+  to have your new entries translated in a timely manner...
+
+- Before adding strings for your new pet tool, check whether you can't
+  re-use strings that already exist.  There's no need for yet another
+  "Ok" string...
+
+- If you modify an existing string in english-string-constants.ss, go
+  through all the *-string-constants.ss files for the other languages,
+  comment out the old version of the modified string in each of these
+  files, and put a short comment there telling us the English string
+  has changed and needs to be re-translated.  Do not erase the old
+  version, it might help us translate the new one.  Do not move it
+  either.  Just comment it out and add the short comment.  After the
+  next cvs update DrScheme will automatically tell us translators that
+  a new string needs to be translated, we will find your comment in
+  the file, and know what to do.
+	Some evil evil people might think that, since DrScheme automatically
+  informs us of new strings to be translated, an easier thing to do
+  when modifying an existing string would be to simply rename it at
+  the same time.  This works, except that if you do that, we
+  translators will get two warnings from DrScheme:
+		language english had but french does not:
+		(new-name "New String")
+		language french had but english does not:
+		(old-name "Old String")
+  then we translators will be left to wonder whether the two things
+  are related or not, and whether we can safely base our translation
+  of "New String" on the translation of "Old String" (since the two
+  strings are likely to be close in meaning).  Worse, we might not
+  even realize the two strings are related and translate "New String"
+  from scratch, just to realize later that it's only a variation of
+  "Old String".  I can tell you that nothing pisses off a translator
+  more than having to translate pretty much the same string twice
+  just because *you* were too lazy to inform us that it was just a
+  slight modification to an existing string rather than an entirely
+  new one.  Conclusion: do not change the name of a string unless you
+  have some really good reason to do so.
+
+- Please think hard before choosing a string and make sure it means
+  what you want it to mean.  That way you won't have to change it
+  later, and we won't have to retranslate it.
+
+- Please think hard before choosing the name for a string.  Use
+  meaningful names.  "error" or "ok" are not meaningful names.  Prefix
+  all related names with a common prefix (the name of your tool or
+  module).  String names are not the right place to save on typing.
+
+- If, for some reason, you really have to change the name of a string
+  (like, because the original name you gave it really sucked...),
+  change the name of the string in *ALL* the *-string-constants.ss
+  files.  That's a modification you can do without the help of a
+  translator, so do it yourself.  It's not the job of the translators
+  to clean up your naming mess for you.  Besides, you are the one who
+  knows what you changed, so leaving the translators having to guess
+  what you did is Not Nice(tm).
+
+- If, for some reason, you need to remove a string (i.e. you changed
+  your code and don't need the string anymore), remove the string in
+  *ALL* the *-string-constants.ss files.  Again, you don't need the
+  help of a translator to do that.  If you're not sure whether you
+  might need the string in the future or not, just comment it out in
+  *ALL* the files.
+
+|#
+
+(module english-string-constants "string-constant-lang.ss"
+ ;;; when translating this constant, substitute name of actual langauge for `English'
+ (is-this-your-native-language "Is English Your Native Language?")
+
+ (are-you-sure-you-want-to-switch-languages
+  "This will change the language of the GUI, which requires you to restart DrScheme. Are you sure?")
+
+ (interact-with-drscheme-in-language "Interact with DrScheme in English")
+
+ ;; these two should probably be the same in all languages excepet English.
+ ;; they are the button labels (under macos and windows, respectively)
+ ;; that go the with the string above.
+ (accept-and-quit "Accept and Quit")
+ (accept-and-exit "Accept and Exit")
+ 
+ ;;; general purpose (DrScheme is hereby a word in every language, by decree of Robby :)
+ (plt "PLT")
+ (drscheme "DrScheme")
+ (ok "OK")
+ (cancel "Cancel")
+ (abort "Abort")
+ (untitled "Untitled")
+ (untitled-n "Untitled ~a")
+ (warning "Warning")
+ (error "Error")
+ (close "Close") ;; as in, close an open window. must match close-menu-item
+                 ;; in the sense that, when the &s have been stripped from
+                 ;; close-menu-item, it must be the same string as this.
+ (stop "Stop")   
+ (&stop "&Stop") ;; for use in button and menu item labels, with short cut.
+ (are-you-sure-delete? "Are you sure you want to delete ~a?") ;; ~a is a filename or directory name
+ (ignore "Ignore")
+ (revert "Revert")
+
+ ;; label for a generic check box, often supported on dialogs
+ ;; that ask a binary choice of the user. If checked, the
+ ;; dialog isn't going to be shown again.
+ (dont-ask-again "Do not ask again (always use current choice)")
+
+ ;;; important urls
+ (web-materials "Related Web Sites") ;; menu item title
+ (tool-web-sites "Tool Web Sites")   ;; menu item title
+ (drscheme-homepage "DrScheme")
+ (plt-homepage "PLT")
+ (how-to-use-scheme "How to Use Scheme") ;; title of a book.
+ (teachscheme!-homepage "TeachScheme!") ;; probably this should be a `word' in all languages
+
+ ;;; bug report form
+ (cancel-bug-report? "Cancel Bug Report?")
+ (are-you-sure-cancel-bug-report?
+  "Are you sure that you want to cancel sending this bug report?")
+ (bug-report-form "Bug Report Form")
+ (bug-report-field-name "Name")
+ (bug-report-field-email "Email")
+ (bug-report-field-summary "Summary")
+ (bug-report-field-severity "Severity")
+ (bug-report-field-class "Class")
+ (bug-report-field-priority "Priority")
+ (bug-report-field-description "Description")
+ (bug-report-field-reproduce1 "Steps to")
+ (bug-report-field-reproduce2 "Reproduce")
+ (bug-report-field-environment "Environment")
+ (bug-report-field-tools "Tools")
+ (bug-report-field-docs-installed "Docs Installed")
+ (bug-report-field-language "Language")
+ (bug-report-field-teachpacks "Teachpacks")
+ (bug-report-field-collections "Collections")
+ (bug-report-field-human-language "Human Language")
+ (bug-report-field-version "Version")
+ (bug-report-synthesized-information "Synthesized Information")  ;; dialog title
+ (bug-report-show-synthesized-info "Show Synthesized Info")
+ (bug-report-submit "Submit")
+ (bug-report-submit-menu-item "Submit Bug Report") ;; in Help Menu (drs & help desk)
+ (sending-bug-report "Sending Bug Report")
+ (error-sending-bug-report "Error Sending Bug Report")
+ (error-sending-bug-report-expln "An error occurred when sending this bug report. If your internet connection is otherwise working fine, please visit:\n\n    http://bugs.plt-scheme.org/\n\nand submit the bug via our online web-form. Sorry for the difficulties.\n\nThe error message is:\n~a")
+ (bug-report-sent "Bug Report Sent")
+ (bug-report-sent-detail "Thanks for the report. You should receive a confirmation email in the next 30 minutes. If you do not, send email to scheme@plt-scheme.org.")
+ (illegal-bug-report "Illegal Bug Report")
+ (pls-fill-in-field "Please fill in the \"~a\" field")
+ (malformed-email-address "Malformed email address")
+ (pls-fill-in-either-description-or-reproduce "Please fill in either the Description field or the Steps to Reproduce field.")
+
+ ;;; check syntax
+ (check-syntax "Check Syntax")
+ (cs-italic "Italic")
+ (cs-bold "Bold")
+ (cs-underline "Underline")
+ (cs-change-color "Change Color")
+ (cs-tack/untack-arrow "Tack/Untack Arrow(s)")
+ (cs-jump-to-next-bound-occurrence "Jump to Next Bound Occurrence")
+ (cs-jump-to-binding "Jump to Binding Occurrence")
+ (cs-jump-to-definition "Jump to Definition")
+ (cs-error-message "Error Message")
+ (cs-open-file "Open ~a")
+ (cs-rename-var "Rename ~a")
+ (cs-rename-id "Rename Identifier")
+ (cs-rename-var-to "Rename ~a to:")
+ (cs-name-duplication-error "The new name you have chosen, ~s, conflicts with an already established name in this scope.")
+ (cs-rename-anyway "Rename Anyway")
+ (cs-status-init "Check Syntax: Initializing environment for user code")
+ (cs-status-coloring-program "Check Syntax: coloring expression")
+ (cs-status-eval-compile-time "Check Syntax: eval compile time")
+ (cs-status-expanding-expression "Check Syntax: expanding expression")
+ (cs-mouse-over-import "binding ~s imported from ~s")
+
+ (cs-lexical-variable "lexical variable")
+ (cs-lexical-syntax "lexical syntax")
+ (cs-imported-variable "imported variable")
+ (cs-imported-syntax "imported syntax")
+
+ ;;; info bar at botttom of drscheme frame
+ (collect-button-label "GC")
+ (read-only "Read only")
+ (read/write "Read/Write")
+ (auto-extend-selection "Auto-extend")
+ (overwrite "Overwrite")
+ (running "running")
+ (not-running "not running")
+ 
+ ;;; misc
+ (welcome-to-something "Welcome to ~a")
+ 
+ ; this appears in the drscheme about box.
+ (welcome-to-drscheme-version/language "Welcome to DrScheme, version ~a, ~a")
+
+ ; these appear on subsequent lines in the `Help|Welcome to DrScheme' dialog.
+ (welcome-to-drscheme "Welcome to DrScheme")
+ (version/language "version ~a, ~a")
+
+ (goto-line "Goto line")
+ (goto-line-invalid-number
+  "~a is not a valid line number. It must be an integer between 1 and ~a")
+ (goto-position "Goto Position")
+ (no-full-name-since-not-saved
+  "The file does not have a full name because it has not yet been saved.")
+ (cannot-open-because-dne "Cannot open ~a because it does not exist.")
+ (interactions-out-of-sync
+  "WARNING: Interactions window is out of sync with the definitions window. Click Run.")
+ (file-is-not-saved "The file \"~a\" is not saved.")
+ (save "Save")
+ (please-choose-either "Please choose either \"~a\" or \"~a\"")
+ (close-anyway "Close Anyway")
+ (clear-anyway "Clear Anyway")
+
+ ;; menu item title
+ (log-definitions-and-interactions "Log Definitions and Interactions...")
+ (stop-logging "Stop Logging")
+ (please-choose-a-log-directory "Please choose a log directory")
+ (logging-to "Logging to: ")
+ (erase-log-directory-contents "Erase contents of log directory: ~a?")
+ (error-erasing-log-directory "Error erasing log directory contents.\n\n~a\n")
+
+ ;; modes
+ (mode-submenu-label "Modes")
+ (scheme-mode "Scheme mode")
+ (text-mode "Text mode")
+
+ (scheme-mode-color-symbol "Symbol")
+ (scheme-mode-color-keyword "Keyword")
+ (scheme-mode-color-comment "Comment")
+ (scheme-mode-color-string "String")
+ (scheme-mode-color-constant "Constant")
+ (scheme-mode-color-parenthesis "Parenthesis")
+ (scheme-mode-color-error "Error")
+ (scheme-mode-color-other "Other")
+ ;; the ~a is filled in with one of the above (scheme-mode-*)
+ (syntax-coloring-choose-color "Choose a color for ~a")
+ (preferences-colors "Colors") ;; used in the preferences dialog
+ 
+ (url "URL")
+ (url: "URL:")
+ (open-url... "Open URL...")
+ (open-url "Open URL")
+ (browse... "Browse...")
+ (bad-url "Bad URL")
+ (bad-url:this "Bad URL: ~a")
+ 
+ ;; Help Desk
+ (help "Help")
+ (help-desk "Help Desk")
+ (plt:hd:search-results "Search results")
+ (plt:hd:search "Search")
+ (plt:hd:search-for "Search for")
+ (plt:hd:lucky "Lucky!")
+ (plt:hd:feeling-lucky "Feeling Lucky")
+ (plt:hd:stop "Stop")   
+ (plt:hd:options "Options") 
+ (plt:hd:configure "Configure")
+ (plt:hd:home "Help Desk home") 
+ (plt:hd:show-manuals "Show manuals") 
+ (plt:hd:send-bug-report "Send bug report")
+ (plt:hd:query-bug-reports "Query bug reports")
+ ; next 3 are popup menu choices in help desk search frame
+ (plt:hd:search-for-keyword "Keyword entry")
+ (plt:hd:search-for-keyword-or-index "Keyword or index entry")
+ (plt:hd:search-for-keyword-or-index-or-text "Keyword, index entry, or text")
+ (plt:hd:exact-match "Exact match")
+ (plt:hd:containing-match "Containing match")
+ (plt:hd:regexp-match "Regexp match")
+ (plt:hd:find-docs-for "Find docs for:")
+ (plt:hd:nothing-found-for-search-key "Nothing found for \"~a\".")
+ (plt:hd:searching "Searching...")
+ (plt:hd:search-stopped "[Search stopped.]")
+ (plt:hd:search-stopped-too-many-matches "[Search aborted: too many matches]")
+ (plt:hd:nothing-found-for "Nothing found for ~a")
+ (plt:hd:error-finding-docs "Could not find documentation.\n\n~a")
+ (plt:hd:and "and")
+ (plt:hd:refresh "refresh")
+ (plt:hd:refresh-all-manuals "refresh all manuals")
+ (plt:hd:manual-installed-date "(installed ~a)")
+ ; Help Desk configuration
+ (plt:hd:configuration "PLT Help Desk configuration")
+ (plt:hd:no-frames "No Frames")
+ (plt:hd:use-frames "Use Frames")
+ (plt:hd:use-html-frames "Use HTML frames")
+ (plt:hd:search-pane-options "Search pane options")
+ (plt:hd:height "Height")
+ (plt:hd:bg-color "Background color")
+ (plt:hd:pixels "pixels")
+ (plt:hd:text-color "Text color")
+ (plt:hd:link-color "Link color")
+ (plt:hd:text-sample "Search pane text appears in this color")
+ (plt:hd:link-sample "Search pane links appear in this color")
+ (plt:hd:save-changes "Save changes")
+ (plt:hd:reset "Reset")
+ (plt:hd:defaults "Defaults")
+ (plt:hd:javascript-note
+    "The selections you make will be shown here if you have Javascript enabled and a recent, standards-compliant browser.")
+ ;; refreshing manuals
+ (plt:hd:refresh-downloading "Downloading ~a")
+ (plt:hd:refresh-installing "Installing ~a")
+ (plt:hd:refresh-progress "PLT manual download progress")
+ (plt:hd:refresh-done "Done refreshing manuals")
+ (plt:hd:refresh-installation-log "Installation log")
+ (plt:hd:refresh-stopped "PLT manuals refresh stopped")
+ (plt:hd:refreshing-manuals "Re-downloading Manuals")
+ (plt:hd:refresh-downloading... "Downloading ~a...")
+ (plt:hd:refresh-deleting... "Deleting old version of ~a...")
+ (plt:hd:refresh-installing... "Installing new version of ~a...")
+ (plt:hd:refresh-clearing-indicies "Clearing cached indices")
+ (plt:hd:refreshing-manuals-finished "Finished.")
+ (plt:hd:about-help-desk "About Help Desk")
+ (plt:hd:help-desk-about-string
+  "Help Desk is a complete source of information about PLT software, including DrScheme, MzScheme, and MrEd.\n\nVersion ~a\nCopyright (c) 1995-2003 PLT")
+ (plt:hd:help-on-help "Help on Help")
+ (plt:hd:help-on-help-details "For help on using Help Desk, follow the `How to use Help Desk' link on Help Desk's home page. (To get to the home page if you're not already there, click the `Home' button at the top of the Help Desk window.)")
+  (reload "Reload") ;; refresh the page in a web browser
+  (plt:hd:ask-about-separate-browser
+   "You have selected a link to content from the world-wide web. Would you like to view it in the Help Desk browser, or would you like to use a separate browser program to view it?")
+  (plt:hd:homebrew-browser "Help Desk Browser") ;; choice for the above string (in a button)
+  (plt:hd:separate-browser "Separate Browser") ;; other choice for the above string (also in a button)
+  (plt:hd:external-link-in-help "External URLs in Help")
+  (plt:hd:use-homebrew-browser "Use Help Desk browser for external URLs")
+  (plt:hd:new-help-desk "New Help Desk")
+  (plt:hd:teaching-manuals "Student manuals")
+  (plt:hd:professional-manuals "Professional manuals")
+  (plt:hd:all-manuals "All manuals")
+
+  ;; in the Help Desk language dialog, title on the right.
+  (plt:hd:manual-search-ordering "Manual Search Order")
+
+
+ ;; Help desk htty proxy
+ (http-proxy "HTTP Proxy")
+ (proxy-direct-connection "Direct connection")
+ (proxy-use-proxy "Use proxy:")
+ (proxy-host "Host")
+ (proxy-port "Port")
+ (proxy-bad-host "Bad Proxy Host")
+
+ ;; browser
+ (rewind-in-browser-history "Rewind")
+ (forward-in-browser-history "Forward")
+ (home "Home")
+ (browser "Browser")
+ (external-browser-choice-title "External Browser") ; title for radio-button set
+ (browser-command-line-label "Command Line:") ; label for radio button that is followed by text boxes
+ (choose-browser "Choose a Browser")
+ (no-browser "Ask Later")
+ (use-internal-browser-for-help "Read help with internal PLT browser") ; radio-button label
+ (use-external-browser-for-help "Read help with external web browser") ; radio-button label
+ (browser-cmdline-expl-line-1 "(Command line formed by concatenating pre-text, URL,") ; explanatory text for dialog, line 1
+ (browser-cmdline-expl-line-2 "and post-text, with no extra spaces between them.)") ; ... line 2. (Anyone need more lines?)
+ (cannot-display-url "Cannot display URL ~s: ~a")
+ (install? "Install?")  ;; if a .plt file is found (title of dialog)
+ (you-have-selected-an-installable-package "You have selected an installable package.")
+ (do-you-want-to-install-it? "Do you want to install it?")
+ (paren-file-size "(The file is ~a bytes)")
+ (download-and-install "Download && Install") ;; button label
+ (download "Download") ;; button label
+ (save-downloaded-file/size "Save downloaded file (~a bytes) as") ;; label for get-file dialog
+ (save-downloaded-file "Save downloaded file as")  ;; label for get-file dialog
+ (downloading "Downloading") ;; dialog title
+ (downloading-file... "Downloading file...")
+ (package-was-installed "The package was installed.")
+ (download-was-saved "The downloaded file was saved.")
+ (getting-page "Getting Page") ;; dialog title
+
+ (install-plt-file-menu-item... "Install .plt File...")
+ (install-plt-file-dialog-title "Install .plt File")
+ (install-plt-web-tab "Web")
+ (install-plt-file-tab "File")
+ (install-plt-filename "Filename:")
+ (install-plt-url "URL:")
+ 
+ ;; install plt file when opened in drscheme strings
+ (install-plt-file "Install ~a or open for editing?")
+ (install-plt-file/yes "Install")
+ (install-plt-file/no "Edit")
+
+ (plt-installer-progress-window-title "Installer Progress") ;; frame title
+ (plt-installer-abort-installation "Abort Installation") ;; button label
+ (plt-installer-aborted "Aborted.") ;; msg that appears in the installation window when installation is aborted
+
+ ;;; about box
+ (about-drscheme-frame-title "About DrScheme")
+ (take-a-tour "Take a Tour!")
+ (release-notes "Release Notes")
+ (parenthetical-last-version "(previous version ~a)")
+ (parenthetical-last-language "(previous language ~a)")
+ (parenthetical-last-version/language "(previous version ~a, language ~a)")
+ 
+ 
+ ;;; save file in particular format prompting.
+ (save-as-plain-text "Save this file as plain text?")
+ (save-in-drs-format "Save this file in drscheme-specific non-text format?")
+ (yes "Yes")
+ (no "No")
+ 
+ ;;; preferences
+ (preferences "Preferences")
+ (saving-preferences "Saving Prefs")
+ (error-unmarshalling "Error unmarshalling ~a preference")
+ (error-saving-preferences "Error saving preferences: ~a")
+ (error-reading-preferences "Error reading preferences")
+ (expected-list-of-length2 "expected a list of length 2")
+ (scheme-prefs-panel-label "Scheme")
+ (warnings-prefs-panel-label "Warnings")
+ (editor-prefs-panel-label "Editing")
+ (general-prefs-panel-label "General")
+ (highlight-parens "Highlight between matching parens")
+ (fixup-parens "Correct parens")
+ (flash-paren-match "Flash paren match")
+ (auto-save-files "Auto-save files")
+ (backup-files "Backup files")
+ (map-delete-to-backspace "Map delete to backspace")
+ (verify-exit "Verify exit")
+ (ask-before-changing-format "Ask before changing save format")
+ (wrap-words-in-editor-buffers "Wrap words in editor buffers")
+ (show-status-line "Show status-line")
+ (count-columns-from-one "Count column numbers from one")
+ (display-line-numbers "Display line numbers in buffer; not character offsets")
+ (enable-keybindings-in-menus "Enable keybindings in menus")
+ (automatically-to-ps "Automatically print to postscript file")
+ (option-as-meta "Treat option key as meta") ;; macos/macos x only
+ (use-mdi "Use MDI Windows") ;;; ms windows only -- use that window in a window thingy
+ (separate-dialog-for-searching "Use separate dialog for searching")
+ (reuse-existing-frames "Reuse existing frames when opening new files")
+ (default-fonts "Default Fonts")
+ (paren-match-color "Parenthesis highlight color") ; in prefs dialog
+ (choose-color "Choose Color") ; in prefs dialog
+ (online-coloring-active "Color syntax interactively")
+ (open-files-in-tabs "Open files in separate tabs (not separate windows)")
+ (show-interactions-on-execute "Automatically open interactions window when running a program")
+ (limit-interactions-size "Limit interactions size")
+ (background-color "Background color")
+ (default-text-color "Default text") ;; used for configuring colors, but doesn't need the word "color"
+ (choose-a-background-color "Please choose a background color")
+
+ ; title of the color choosing dialog
+ (choose-paren-highlight-color "Choose Parenthesis Highlight Color")
+
+ ; should have entire alphabet
+ (font-example-string "The quick brown fox jumped over the lazy dogs.") 
+
+ (change-font-button-label "Change")
+ (fonts "Fonts")
+
+ ; filled with type of font, eg modern, swiss, etc.
+ (choose-a-new-font "Please choose a new \"~a\" font")
+
+ (font-size-slider-label "Size")
+ (restart-to-see-font-changes "Restart to see font changes")
+
+ (font-prefs-panel-title "Font")
+ (font-name "Font Name")
+ (font-size "Font Size")
+ (set-font "Set Font...")
+ (font-smoothing-label  "Font smoothing")
+ (font-smoothing-none "None")
+ (font-smoothing-some "Some")
+ (font-smoothing-all "All")
+ (font-smoothing-default "Use system-wide default")
+ (select-font-name "Select Font Name")
+ (example-text "Example Text:")
+ (only-warn-once "Only warn once when definitions and interactions are not synchronized")
+ 
+ ; warning message when lockfile is around
+ (waiting-for-pref-lock "Waiting for the preferences lockfile...")
+ (pref-lock-not-gone
+  "The preferences lockfile:\n\n   ~a\n\nprevents the preferences from being saved. Ensure that no PLT software is running and delete this file.")
+ (still-locked-exit-anyway? "The preferences were not saved sucessfully. Exit anyway?")
+ 
+ ;;; indenting preferences panel
+ (indenting-prefs-panel-label "Indenting")
+ (indenting-prefs-extra-regexp "Extra regexp")
+
+ ; filled with define, lambda, or begin
+ (enter-new-keyword "Enter new ~a-like keyword:")
+ (x-keyword "~a Keyword")
+ (x-like-keywords "~a-like Keywords")
+
+ (expected-a-symbol "expected a symbol, found: ~a")
+ (already-used-keyword "\"~a\" is already a specially indented keyword")
+ (add-keyword "Add")
+ (remove-keyword "Remove")
+ 
+ ;;; find/replace
+ (find-and-replace "Find and Replace")
+ (find "Find")
+ (replace "Replace")
+ (dock "Dock")
+ (undock "Undock")
+ (use-separate-dialog-for-searching "Use separate dialog for searching")
+ (replace&find-again "Replace && Find Again") ;;; need double & to get a single &
+ (replace-to-end "Replace to End")
+ (forward "Forward")
+ (backward "Backward")
+ (hide "Hide")
+ 
+ ;;; multi-file-search
+ (mfs-multi-file-search-menu-item "Search in Files...")
+ (mfs-string-match/graphics "String match (handles files with graphics)")
+ (mfs-regexp-match/no-graphics "Regular Expression (only raw text files)")
+ (mfs-searching... "Searching...")
+ (mfs-configure-search "Configure Search") ;; dialog title
+ (mfs-files-section "Files")   ;; section in config dialog
+ (mfs-search-section "Search") ;; section in config dialog
+ (mfs-dir "Dir")
+ (mfs-recur-over-subdirectories "Recur over subdirectories")
+ (mfs-regexp-filename-filter "Regexp filename filter")
+ (mfs-search-string "Search string")
+ (mfs-drscheme-multi-file-search "DrScheme - Multi File Search") ;; results window and error message title
+ (mfs-not-a-dir "\"~a\" is not a directory")
+ (mfs-open-file "Open File")
+ (mfs-stop-search "Stop Search")
+ (mfs-case-sensitive-label "Case sensitive")
+ (mfs-no-matches-found "No matches found.")
+ (mfs-search-interrupted "Search aborted.")
+ 
+ ;;; reverting a file
+ (error-reverting "DrScheme - Error Reverting")
+ (could-not-read "could not read \"~a\"")
+ (are-you-sure-revert
+  "Are you sure that you want to revert this file? This change cannot be undone.")
+ (are-you-sure-revert-title
+  "Revert?")
+ 
+ ;;; saving a file
+ ; ~a is filled with the filename
+ (error-saving "Error Saving") ;; title of error message dialog
+ (error-saving-file/name "There was an error saving ~a.")
+ (error-loading "Error Loading")
+ (error-loading-file/name "There was an error loading ~a.")
+ (unknown-filename "<< unknown >>")
+
+ ;;; finder dialog
+ (must-specify-a-filename "You must specify a file name")
+ (file-does-not-exist "The file \"~a\" does not exist.")
+ (ask-because-file-exists "The file \"~a\" already exists. Replace it?")
+ (dne-or-cycle "The file \"~a\" contains a nonexistent directory or a cycle.")
+ (get-file "Get file")
+ (put-file "Put file")
+ (full-pathname "Full pathname")
+ (show-dot-files "Show files and directories that begin with a dot.")
+ (up-directory-button-label "Up directory")
+ (add-button-label "Add") ;;; for multi-file selection
+ (add-all-button-label "Add all") ;;; for multi-file selection
+ (remove-button-label "Remove") ;;; for multi-file selection
+ (file-wrong-form "That filename does not have the right form.")
+ (select-files "Select files")
+ (select-file "Select a file")
+ (dir-dne "That directory does not exist.")
+ (file-dne "That file does not exist.")
+ (empty-filename "The filename must have some letters in it.")
+ (that-is-dir-name "That is a directory name.")
+ 
+ ;;; raw menu names -- these must match the 
+ ;;; versions below, once the &s have been stripped.
+ ;;; if they don't, DrScheme's menus will appear
+ ;;; in the wrong order.
+ (file-menu "File")
+ (edit-menu "Edit")
+ (help-menu "Help")
+ (windows-menu "Windows")
+ 
+ ;;; menus
+ ;;; - in menu labels, the & indicates a alt-key based shortcut.
+ ;;; - sometimes, things are stuck in the middle of 
+ ;;; menu item labels. For instance, in the case of
+ ;;; the "Save As" menu, you might see: "Save Definitions As". 
+ ;;; be careful of spacing, follow the English, if possible.
+ ;;; - the ellipses in the `after' strings indicates that
+ ;;; more information is required from the user before completing
+ ;;; the command.
+
+ (file-menu-label "&File")
+
+ (new-info  "Open a new file")
+ (new-menu-item "&New")
+ (new-...-menu-item "&New...")
+
+ (open-info "Open a file from disk")
+ (open-menu-item "&Open...")
+ (open-here-menu-item "&Open Here...")
+
+ (open-recent-info "A list of the recently opened files")
+ (open-recent-menu-item "Open Recent")
+ 
+ (revert-info "Revert this file to the copy on disk")
+ (revert-menu-item "&Revert")
+
+ (save-info "Save this file to disk")
+ (save-menu-item "&Save")
+
+ (save-as-info "Prompt for a filename and save this file to disk")
+ (save-as-menu-item "Save &As...")
+
+ (print-info "Send this file to a printer")
+ (print-menu-item "&Print...")
+
+ (close-info "Close this file")
+ (close-menu-item "&Close")
+
+ (quit-info "Close all windows")
+ (quit-menu-item-windows "E&xit")
+ (quit-menu-item-others "&Quit")
+ 
+ (edit-menu-label "&Edit")
+ 
+ (undo-info "Undo the most recent action")
+ (undo-menu-item "&Undo")
+
+ (redo-info "Undo the most recent undo")
+ (redo-menu-item "&Redo")
+
+ (cut-info "Move the selected items to the clipboard for later pasting")
+ (cut-menu-item "Cu&t")
+
+ (copy-info "Copy the selected items to the clipboard for later pasting")
+ (copy-menu-item "&Copy")
+
+ (paste-info "Paste the most recently copied or cut items, in place of the selected items")
+ (paste-menu-item "&Paste")
+
+ (clear-info "Erase the selected items without affecting the clipboard or pasting")
+ (clear-menu-item-others "Clear")
+ (clear-menu-item-windows "&Delete")
+
+ (select-all-info "Select the entire document")
+ (select-all-menu-item "Select A&ll")
+ 
+ (find-info "Search for a string")
+ (find-menu-item "Find...")
+
+ (find-again-info "Search for the same string as before")
+ (find-again-menu-item "Find Again")
+ 
+ (replace-and-find-again-info "Replace the current text and search for the same string as before")
+ (replace-and-find-again-menu-item "Replace && Find Again")
+
+ (preferences-info "Configure your preferences")
+ (preferences-menu-item "Preferences...")
+
+ (keybindings-info "Show the currently active keybindings")
+ (keybindings-menu-item "Keybindings")
+ (keybindings-show-active "Show Active Keybindings")
+ (keybindings-frame-title "Keybindings")
+ (keybindings-sort-by-name "Sort by Name")
+ (keybindings-sort-by-key "Sort by Key")
+ (keybindings-add-user-defined-keybindings "Add User-defined Keybindings...")
+ (keybindings-menu-remove "Remove ~a")
+ (keybindings-choose-user-defined-file "Please choose a file containing keybindings.")
+
+ (user-defined-keybinding-error "Error running keybinding ~a\n\n~a")
+ (user-defined-keybinding-malformed-file "The file ~a does not contain a module written in the (lib \"keybinding-lang.ss\" \"framework\") language.")  
+  
+ ;; menu items in the "special" menu
+ (insert-text-box-item "Insert Text Box")
+ (insert-pb-box-item "Insert Pasteboard Box")
+ (insert-image-item "Insert Image...")
+ (insert-comment-box-menu-item-label "Insert Comment Box")
+ (insert-lambda "Insert λ")
+ (insert-delta "Insert &Delta (define)")
+
+ (wrap-text-item "Wrap Text")
+
+ (windows-menu-label "&Windows")
+ (bring-frame-to-front "Bring Frame to Front")       ;;; title of dialog
+ (bring-frame-to-front... "Bring Frame to Front...") ;;; corresponding title of menu item
+ (next-window "Next Window")
+ (previous-window "Previous Window")
+ (most-recent-window "Most Recent Window")
+
+ (view-menu-label "&View")
+ (show-overview "Show Program Contour") 
+ (hide-overview "Hide Program Contour")
+ (show-module-browser "Show Module Browser")
+ (hide-module-browser "Hide Module Browser")
+
+ (help-menu-label "&Help")
+ (about-info "Credits and details for this application")
+ (about-menu-item "About...")
+ (help-menu-check-for-updates "Check for Updates...")
+ 
+ ;; open here's new menu item
+ (create-new-window-or-clear-current
+  "Would you like to create a new window, or clear out the current one?")
+ (clear-current "Clear Current")
+ (new-window "New Window")
+
+ ;;; exiting and quitting ``are you sure'' dialog
+ ;;; exit is used on windows, quit on macos, in English. Other
+ ;;; languages probably use the same word on both platforms.
+ (exit "Exit")
+ (quit "Quit")
+ (are-you-sure-exit "Are you sure you want to exit?")
+ (are-you-sure-quit "Are you sure you want to quit?")
+ 
+ ;;; autosaving
+ (error-autosaving "Error autosaving \"~a\".") ;; ~a will be a filename
+ (autosaving-turned-off "Autosaving is turned off\nuntil the file is saved.")
+ (recover-autosave-files-frame-title "Recover Autosaved Files")
+ (autosave-details "Details")
+ (autosave-recover "Recover")
+ (autosave-unknown-filename "<<unknown>>")
+  
+  ;; these are labels in a dialog that drscheme displays
+  ;; if you have leftover autosave files. to see the dialog,
+  ;; start up drscheme and modify (but don't save) a file
+  ;; (also, do this with an unsaved file). Wait for the autosave
+  ;; files to appear (typically 5 minutes). Kill DrScheme
+  ;; and restart it. You'll see the dialog
+  (autosave-autosave-label: "Autosave file:")
+  (autosave-original-label: "Original file:")
+  (autosave-autosave-label "Autosave file")
+  (autosave-original-label "Original file")
+  (autosave-compare-files "Compare autosave files")
+
+  (autosave-show-autosave "Autosave file") ;; title of a window showing the autosave file
+
+  (autosave-explanation "DrScheme found autosave files, which may contain your unsaved work.")
+
+  (autosave-recovered! "Recovered!") ;; status of an autosave file
+  (autosave-deleted "Deleted")       ;; status of an autosave file
+
+  (autosave-error-deleting "Error deleting ~a\n\n~a") ;; first is a filename, second is an error message from mz.
+  (autosave-delete-button "Delete")
+  (autosave-delete-title "Delete")  ;; title of a dialog asking for deletion confirmation
+  (autosave-done "Done")
+  
+  ;; appears in the file dialog
+  (autosave-restore-to-where? "Choose a place to save the autosave file.")
+  
+  
+ ;;; file modified warning
+ (file-has-been-modified
+  "The file has been modified since it was last saved. Overwrite the modifications?")
+ (overwrite-file-button-label "Overwrite")
+ 
+ (definitions-modified 
+  "The definitions text has been modified in the file-system; please save or revert the definitions text.")
+ (drscheme-internal-error "DrScheme Internal Error")
+ 
+ ;;; tools
+ (invalid-tool-spec "The tool specification in collection ~a's info.ss file is invalid. Expected either a string or a non-empty list of strings, got: ~e")
+ (error-loading-tool-title "DrScheme - Error loading tool ~s; ~s")
+ (error-invoking-tool-title "Error invoking tool ~s;~s")
+ (tool-tool-names-same-length
+  "expected `tool-names' and `tools' to be lists of the same length, in info.ss file for ~s, got ~e and ~e")
+ (tool-tool-icons-same-length
+  "expected `tool-icons' and `tools' to be lists of the same length, in info.ss file for ~s, got ~e and ~e")
+ (tool-tool-urls-same-length
+  "expected `tool-urls' and `tools' to be lists of the same length, in info.ss file for ~s, got ~e and ~e")
+ (error-getting-info-tool
+  "error loading info.ss file for ~s")
+ (tool-error-phase1 "Error in phase 1 for tool ~s; ~s")
+ (tool-error-phase2 "Error in phase 2 for tool ~s; ~s")
+
+
+ ;;; define popup menu
+ (end-of-buffer-define "<< end of buffer >>")
+ (sort-by-name "Sort by name")
+ (sort-by-position "Sort by position in file")
+ (no-definitions-found "<< no definitions found >>")
+ (jump-to-defn "Jump to definition of ~a")
+
+ (recent-items-sort-by-age "Sort by Age")
+ (recent-items-sort-by-name "Sort by Name")
+ 
+ ;;; view menu
+ (hide-definitions-menu-item-label "Hide &Definitions")
+ (show-definitions-menu-item-label "Show &Definitions")
+ (definitions-menu-item-help-string "Show/Hide the definitions window")
+ (show-interactions-menu-item-label "Show &Interactions")
+ (hide-interactions-menu-item-label "Hide &Interactions")
+ (interactions-menu-item-help-string "Show/Hide the interactions window")
+ (show-toolbar "Show &Toolbar")
+ (hide-toolbar "Hide &Toolbar")
+
+ ;;; file menu
+ (save-definitions-as "Save Definitions &As...")
+ (save-definitions "Save Definitions")
+ (print-definitions "Print Definitions...")
+ (about-drscheme "About DrScheme")
+ (save-other "Save Other")
+ (save-definitions-as-text "Save Definitions As Text...")
+ (save-interactions "Save Interactions")
+ (save-interactions-as "Save Interactions As...")
+ (save-interactions-as-text "Save Interactions As Text...")
+ (print-interactions "Print Interactions...")
+ (new-tab "New Tab")
+ (close-tab "Close Tab") ;; must not have any &s in it.
+ 
+ ;;; edit-menu
+ (split-menu-item-label "&Split")
+ (collapse-menu-item-label "C&ollapse")
+ 
+ ;;; language menu
+ (language-menu-name "&Language")
+ 
+ ;;; scheme-menu
+ (scheme-menu-name "S&cheme")
+ (execute-menu-item-label "Run")
+ (execute-menu-item-help-string "Restart the program in the definitions window")
+ (break-menu-item-label "Stop")
+ (break-menu-item-help-string "Break the current evaluation")
+ (kill-menu-item-label "Kill")
+ (kill-menu-item-help-string "Kill the current evaluation")
+ (clear-error-highlight-menu-item-label "Clear Error Highlight")
+ (clear-error-highlight-item-help-string "Removes the pink error highlighting")
+ (reindent-menu-item-label "&Reindent")
+ (reindent-all-menu-item-label "Reindent &All")
+ (semicolon-comment-out-menu-item-label "&Comment Out with Semicolons")
+ (box-comment-out-menu-item-label "&Comment Out with a Box")
+ (uncomment-menu-item-label "&Uncomment")
+
+ (convert-to-semicolon-comment "Convert to Semicolon Comment")
+ 
+ ;;; executables
+ (create-executable-menu-item-label "Create Executable...")
+ (create-executable-title "Create Executable")
+ (must-save-before-executable "You must save your program before creating an executable.")
+ (save-an-executable "Save an Executable")
+ (save-a-mred-launcher "Save a MrEd Launcher")
+ (save-a-mzscheme-launcher "Save a MzScheme Launcher")
+ (save-a-mred-stand-alone-executable "Save a MrEd Stand-alone Executable")
+ (save-a-mzscheme-stand-alone-executable "Save a MzScheme Stand-alone Executable")
+
+ (definitions-not-saved "The definitions window has not been saved. The executable will use the latest saved version of the definitions window. Continue?")
+ (inline-saved-program-in-executable?
+  "Inline the saved program in the executable? If yes, you can copy the executable to another ~a computer but the executable will be quite large. If not, you cannot copy the executable to another computer, but it will be much smaller. Additionally, if not, the executable will load the latest version of the program.")
+ (use-mred-binary?
+  "Use the mred binary for this executable?\n\nIf yes, your program can use the (lib \"mred.ss\" \"mred\") library. If no, DrScheme will use mzscheme as the binary for this executable and you cannot use that library.\n\nIf unsure, choose yes.")
+ (inline-saved-program-in-executable/windows/path
+   "WARNING! The generated executable relies on three DLLs: libmred.dll, libmzsch.gll, and libgc.dll, which are located at\n\n~a\n\nThe executable finds the DLLs either in the executable's directory or through the PATH enviornment variable.\n\nWhen you installed DrScheme, the installer adjusted the user's PATH to include the directory where the DLLs were installed. Beware of configuration or user changes since installation.\n\nIf you move the executable to another machine, you must also copy the DLLs to the other machine --- either to the same directory as the executable, or to a directory in the other machine's PATH.")
+ (launcher "Launcher")
+ (stand-alone "Stand-alone")
+ (executable-type "Type")
+ (executable-base "Base")
+ (filename "Filename: ")
+ (create "Create")
+ (please-choose-an-executable-filename "Please choose a filename to save the executable.")
+ (windows-executables-must-end-with-exe
+  "The filename\n\n  ~a\n\nis illegal. Under Windows, executables must end with .exe.")
+ (macosx-executables-must-end-with-app
+  "The filename\n\n  ~a\n\nis illegal. Under MacOS X, executables must end with .app.")
+ (warning-directory-will-be-replaced
+  "WARNING: the directory:\n\n  ~a\n\nwill be replaced. Proceed?")
+ 
+ (create-servlet "Create Servlet...")
+
+ ; the ~a is a language such as "module" or "algol60"
+ (create-servlet-unsupported-language
+  "Create Servlet does not work with the ~a language.")
+  
+ ;;; buttons
+ (execute-button-label "Run") 
+ (save-button-label "Save")
+ (break-button-label "Stop")
+ 
+ ;;; search help desk popup menu
+ (search-help-desk-for "Search in Help Desk for \"~a\"")
+ (exact-lucky-search-help-desk-for "Exact lucky search in Help Desk for \"~a\"")
+
+ ;; collapse and expand popup menu items
+ (collapse-sexp "Collapse sexpression")
+ (expand-sexp "Expand sexpression")
+ 
+ ;;; fraction dialog
+ (enter-fraction "Enter Fraction")
+ (whole-part "Whole Part")
+ (numerator "Numerator")
+ (denominator "Denominator")
+ (invalid-number "Invalid number: must be an exact, real, non-integral number.")
+ (insert-fraction-menu-item-label "Insert Fraction...")
+
+ ;; number snip popup menu
+ (show-decimal-expansion "View decimal expansion")
+ (show-fraction-view "View as fraction")
+ (show-mixed-fraction-view "View as mixed fraction")
+ (show-improper-fraction-view "View as improper fraction")
+ (show-more-decimal-places "Show more decimal places")
+ 
+ ;;; Teachpack messages
+ (select-a-teachpack "Select a Teachpack")
+ (clear-teachpack "Clear ~a Teachpack")
+ (teachpack-error-label "DrScheme - Teachpack error")
+ (teachpack-dne/cant-read "The teachpack file ~a does not exist or is not readable.")
+ (teachpack-didnt-load "The teachpack file ~a did not load properly.")
+ (teachpack-error-invoke "The teachpack file ~a raised an error when invoked.")
+ (add-teachpack-menu-item-label "Add Teachpack...")
+ (clear-all-teachpacks-menu-item-label "Clear All Teachpacks")
+ (drscheme-teachpack-message-title "DrScheme Teachpack")
+ (already-added-teachpack "Already added ~a teachpack")
+ 
+ ;;; Language dialog
+ (introduction-to-language-dialog
+  "Please select a language. Students in most introductory courses should use the default language.")
+ (language-dialog-title "Choose Language")
+ (case-sensitive-label "Case sensitive")
+ (output-style-label "Output Style")
+ (constructor-printing-style "Constructor")
+ (quasiquote-printing-style "Quasiquote")
+ (write-printing-style "write")
+ (print-printing-style "current-print")
+ (sharing-printing-label "Show sharing in values")
+ (use-pretty-printer-label "Insert newlines in printed values")
+ (input-syntax "Input Syntax")
+ (dynamic-properties "Dynamic Properties")
+ (output-syntax "Output Syntax")
+ (no-debugging-or-profiling "No debugging or profiling")
+ (debugging "Debugging")
+ (debugging-and-profiling "Debugging and profiling")
+ (test-coverage "Syntactic test suite coverage")
+ (whole/fractional-exact-numbers-label "Print numbers as fractions")
+ (booleans-as-true/false-label "Print booleans using true and false")
+ (show-details-button-label "Show Details")
+ (hide-details-button-label "Hide Details")
+ (choose-language-menu-item-label "Choose Language...")
+ (revert-to-language-defaults "Revert to Language Defaults")
+ (language-docs-button-label "Language Docs")
+ (fraction-style "Fraction Style")
+ (use-mixed-fractions "Mixed fractions")
+ (use-repeating-decimals "Repeating decimals")
+ (decimal-notation-for-rationals "Use decimal notation for rationals")
+ (please-select-a-language "Please select a language")
+
+ 
+ ;;; languages
+ (beginning-student "Beginning Student")
+ (beginning-one-line-summary "define, cond, structs, constants, and primitives")
+ (beginning-student/abbrev "Beginning Student with List Abbreviations")
+ (beginning/abbrev-one-line-summary "Beginner, with list style printing in the REPL")
+ (intermediate-student "Intermediate Student")
+ (intermediate-one-line-summary "Beginner plus lexical scope")
+ (intermediate-student/lambda "Intermediate Student with lambda")
+ (intermediate/lambda-one-line-summary "Intermediate plus higher-order functions")
+ (advanced-student "Advanced Student")
+ (advanced-one-line-summary "Intermediate plus lambda and mutation")
+ (full-language "Full") ;; also in the HtDP languages section
+ (how-to-design-programs "How to Design Programs") ;; should agree with MIT Press on this one...
+ (r5rs-like-languages "R5RS-like")
+ (pretty-big-scheme "Pretty Big (includes MrEd and Advanced)")
+ (pretty-big-scheme-one-line-summary "Adds syntax and functions from the HtDP languages")
+ (r5rs-lang-name "Standard (R5RS)")
+ (r5rs-one-line-summary "R5RS, with no frills")
+ (expander "Expander")
+ (expander-one-line-summary "Expands, rather than evaluates, expressions")
+ (professional-languages "Professional Languages")
+ (teaching-languages "Teaching Languages")
+ (experimental-languages "Experimental Languages")
+ 
+ (module-language-one-line-summary "Run creates a REPL in the context of the module, including the module's declared language")
+  
+
+ ;;; debug language
+ (unknown-debug-frame "[unknown]")
+ (backtrace-window-title "Backtrace - DrScheme")
+ (files-interactions "~a's interactions") ;; filled with a filename
+ (current-interactions "interactions")
+ (current-definitions "definitions")
+ (mzscheme-w/debug "Textual (MzScheme, includes R5RS)")
+ (mzscheme-one-line-summary "PLT's implementation Scheme")
+ (mred-w/debug "Graphical (MrEd, includes MzScheme)")
+ (mred-one-line-summary "Adds GUI support to MzScheme")
+
+ ;; profiling
+ (profiling-low-color "Low")
+ (profiling-high-color "High")
+ (profiling-choose-low-color "Please select a low color")
+ (profiling-choose-high-color "Please select a high color")
+ (profiling "Profiling")
+ (profiling-example-text "(define (whee) (whee))")
+ (profiling-color-config "Profiling Color Range") 
+ (profiling-scale "Profiling Color Scale")
+ (profiling-sqrt "Square root")
+ (profiling-linear "Linear")
+ (profiling-square "Square")
+ (profiling-number "Number of Calls")
+ (profiling-time "Cumulative Time")
+ (profiling-update "Update Profile")
+ (profiling-col-percent-time "% Time")
+ (profiling-col-function "Function")
+ (profiling-col-name "Name")
+ (profiling-col-time-in-msec "Msec")
+ (profiling-col-calls "Calls")
+ (profiling-show-profile "Show Profile")
+ (profiling-hide-profile "Hide Profile")
+ (profiling-unknown-src "<< unknown >>")
+ (profiling-no-information-available "There is no profiling information available. Please be sure that profiling is enabled in your language and you have run your program.")
+ (profiling-clear? "Changing the definitions window invalidates the profiling information. Continue?")
+ 
+ ;; test coverage
+ (test-coverage-clear? "Changing the definitions window invalidates the test coverage information. Continue?")
+ (test-coverage-clear-and-do-not-ask-again "Yes, and don't ask again")
+ (test-coverage-ask? "Ask about clearing test coverage")
+  
+ ;; tracing
+ (tracing-enable-tracing "Enable tracing")
+ (tracing-show-tracing-window "Show Tracing")
+ (tracing-hide-tracing-window "Hide Tracing")
+ (tracing-tracing-nothing-to-show "No tracing results are available. Be sure your language supports tracing and it is enabled.")
+
+ ;;; repl stuff
+ (evaluation-terminated "Evaluation Terminated")
+ (evaluation-terminated-explanation
+  "The evaluation thread is no longer running, so no evaluation can take place until the next execution.")
+ (last-stack-frame "show the last stack frame")
+ (last-stack-frames "show the last ~a stack frames")
+ (next-stack-frames "show the next ~a stack frames")
+ 
+ ;;; welcoming message in repl
+ (language "Language")
+ (custom "custom")
+ (teachpack "Teachpack")
+ (welcome-to "Welcome to")
+ (version "version")
+ 
+ ;;; kill evaluation dialog
+ (kill-evaluation? "Do you want to kill the evaluation?")
+ (just-break "Just Break")
+ (kill "Kill")
+ (kill? "Kill?")
+
+ ;;; version checker
+ ;; the next two are used in the initial wizard dialog.
+ ;; Note that vc-wizard-check-prompt can (should) have newlines so
+ ;; it will not make the dialog too wide.
+ (vc-wizard-check-note "The version you are about to install may not be the latest\n one. If you would like, DrScheme can check for you.")
+ (vc-wizard-check-button "Check for Updates")
+ (vc-update-check "Update check")
+ (vc-please-wait "Please wait")
+ (vc-connecting-version-server "Connecting to PLT version server")
+ (vc-network-timeout "Network timeout") 
+ (vc-cannot-connect  "Can't connect to PLT version server")
+ (vc-network-failure "Network failure")
+ (vc-old-binaries "Installed binaries for DrScheme (or MzScheme) are not up-to-date")
+ (vc-binary-information-format "Installed binary version: ~a (iteration ~a)")
+ (vc-details-format "~a~nDetails:~n~a")
+ (vc-details-text "Details:~n")
+ (vc-error-format "Error: ~a") 
+ (vc-current-format "~a v.~a (iteration ~a) is up-to-date")
+ (vc-update-format "~a v.~a (iteration ~a) needs updating to v.~a (iteration ~a)")
+ (vc-binary-name "Binary")
+ (vc-updates-available "Updates are available at")
+ (vc-latest-binary-information-format "Latest released version: ~a (iteration ~a)")
+ (vc-update-dialog-title "PLT update status")
+ (vc-need-update-string "One or more installed PLT software packages needs updating")
+ (vc-no-update-string "All installed PLT software packages are up-to-date")
+
+ ;; special menu
+ (special-menu "S&pecial")
+ 
+ ;; large semi colon letters
+ (insert-large-letters... "Insert Large Letters...")
+ (large-semicolon-letters "Large Semicolon Letters")
+ (text-to-insert "Text to insert")
+
+ (module-browser-filename-format "Full Filename: ~a (~a lines)")
+ (module-browser-root-filename "Root Filename: ~a")
+ (module-browser-font-size-gauge-label "Font Size")
+ (module-browser-progress-label "Module overview progress")
+ (module-browser-adding-file "Adding file: ~a...")
+ (module-browser-laying-out-graph-label "Laying out graph")
+ (module-browser-open-file-format "Open ~a")
+ (module-browser "Module Browser") ;; frame title
+ (module-browser... "Module Browser...") ;; menu item title
+ (module-browser-error-expanding "Error expanding the program:\n\n~a")
+ (module-browser-show-lib-paths "Show files loaded by (lib ..) paths")
+ (module-browser-progress "Module Browser: ~a") ;; prefix in the status line
+ (module-browser-compiling-defns "Module Browser: compiling definitions")
+ (module-browser-show-lib-paths/short "Follow lib requires") ;; check box label in show module browser pane in drscheme window.
+ (module-browser-refresh "Refresh") ;; button label in show module browser pane in drscheme window.
+ (module-browser-only-in-plt-and-module-langs
+  "The module browser is only available for programs in the PLT languages and in the module language (and only for programs that have modules in them).")
+ (module-browser-name-length "Name length")
+ (module-browser-name-short "Short")
+ (module-browser-name-medium "Medium")
+ (module-browser-name-long "Long")
+ (module-browser-open-all "Open all files shown here")
+
+ (happy-birthday-matthias "Happy Birthday, Matthias!")
+ (happy-birthday-matthew "Happy Birthday, Matthew!")
+ (happy-birthday-shriram "Happy Birthday, Shriram!")
+
+ (mrflow-using-default-language-title "Default Language Used")
+ (mrflow-using-default-language "The language currently used does not have a type table defined for its primitives. Using R5RS Scheme instead.")
+ (mrflow-button-title "Analyze")
+ ;(mrflow-unknown-style-delta-error-title "Unknown Box Style Delta")
+ ;(mrflow-unknown-style-delta-error "Unknown box style delta: ~a")
+ (mrflow-coloring-error-title "Unknown Color")
+ (mrflow-coloring-error "No style defined for color: ~a")
+ (mrflow-popup-menu-show-type "Show Type")
+ (mrflow-popup-menu-hide-type "Hide Type")
+ (mrflow-popup-menu-show-errors "Show Errors")
+ (mrflow-popup-menu-hide-errors "Hide Errors")
+ ;(mrflow-read-exception-title "Read Exception")
+ ;(mrflow-read-exception "Read exception: ~a")
+ ;(mrflow-syntax-exception-title "Syntax Exception")
+ ;(mrflow-syntax-exception "Syntax exception: ~a")
+ ;(mrflow-unknown-exception-title "Unknown Exception")
+ ;(mrflow-unknown-exception "Unknown exception: ~a")
+ ;(mrflow-language-primitives-error-title "Language Primitives Error")
+ ;(mrflow-language-primitives-error "Wrong filename for language primitives types table: ~a")
+  
+ (snips-and-arrows-popup-menu-tack-all-arrows "Tack All Arrows")
+ (snips-and-arrows-popup-menu-untack-all-arrows "Untack All Arrows")
+ (snips-and-arrows-user-action-disallowed-title "User Changes Currently Disallowed")
+ (snips-and-arrows-user-action-disallowed "User changes are disallowed in editors that contain tool-inserted snips.  Hide all snips before modifying the content of the editor.")
+ ;(snips-and-arrows-changing-terms-warning-title "Changing terms will be undoable")
+ ;(snips-and-arrows-changing-terms-warning "Changing terms in an editor containing snips cannot be undone.  You can either cancel this action, remove the snips, and try the change again, or you can continue with the change, in which case the change will not be undoable (all others changes made before and afterward will still be undoable though).")
+ (snips-and-arrows-hide-all-snips-in-editor "Hide all snips in editor")
+
+ (xml-tool-menu "XML")
+ (xml-tool-insert-xml-box "Insert XML Box")
+ (xml-tool-insert-scheme-box "Insert Scheme Box")
+ (xml-tool-insert-scheme-splice-box "Insert Scheme Splice Box")
+ (xml-tool-xml-box "XML Box")
+ (xml-tool-scheme-box "Scheme Box")
+ (xml-tool-scheme-splice-box "Scheme Splice Box")
+ (xml-tool-switch-to-scheme "Switch to Scheme box")
+ (xml-tool-switch-to-scheme-splice "Switch to Scheme splice box")
+ (xml-tool-eliminate-whitespace-in-empty-tags
+  "Eliminiate whitespace in empty tags")
+ (xml-tool-leave-whitespace-alone
+  "Leave whitespace alone")
+ 
+ (show-recent-items-window-menu-item "Show Recently Opened Files in Separate Window")
+ (show-recent-items-window-label "Recently Opened Files")
+ (number-of-open-recent-items "Number of recent items")
+ (switch-anyway "Switch File Anyway")
+
+ (stepper-program-has-changed "WARNING: The program has changed.")
+ (stepper-program-window-closed "WARNING: The program window is gone.")
+
+ (stepper-home "Home")
+ (stepper-name "Stepper")
+ (stepper-language-level-message
+  "The language level is set to \"~a\". Currently, the stepper works only for the \"~a\" through the \"~a\" language levels.")
+ (stepper-button-label "Step")
+ (stepper-previous-application "|< Application")
+ (stepper-previous "< Step")
+ (stepper-next "Step >")
+ (stepper-next-application "Application >|")
+ 
+
+ (wizard-next "Next")
+ (wizard-back "Back")
+ (wizard-finish "Finish")
+
+ ;; warnings about closing a drscheme frame when the program
+ ;; might still be doing something interesting
+ (program-is-still-running "The program in the definitions window is still running. Close anyway?")
+  (program-has-open-windows "The program in the definitions window has open windows. Close this window anyway?")
+ 
+  ;; ml-command-line-arguments is for the command line arguments
+  ;; label in the module language details in the language dialog.
+  (ml-command-line-arguments "Command-line arguments as a vector of strings, in read syntax")
+
+  ;; ml-cp names are all for the module language collection path
+  ;; configuration. See the details portion of the language dialog
+  ;; for the module language (at the bottom).
+  (ml-cp-default-collection-path "<<default collection paths>>")
+
+  ;; in std get-directory 
+  (ml-cp-choose-a-collection-path "Please choose a collection path")
+
+  ;; err msg when adding default twice
+  (ml-cp-default-already-present
+   "Default collection paths are already present")
+  
+  ;; title of this section of the dialog (possibly the word
+  ;; `Collection' should not be translated)
+  (ml-cp-collection-paths "Collection Paths")
+
+  ;; button labels
+  (ml-cp-add "Add")
+  (ml-cp-add-default "Add Default")
+  (ml-cp-remove "Remove")
+  (ml-cp-raise "Raise")
+  (ml-cp-lower "Lower")
+
+  ;; Profj
+  (profj-java "Java")
+  (profj-java-mode "Java mode")
+  (profj-java-mode-color-keyword "keyword")
+  (profj-java-mode-color-string "string")
+  (profj-java-mode-color-literal "literal")
+  (profj-java-mode-color-comment "comment")
+  (profj-java-mode-color-error "error")
+  (profj-java-mode-color-identifier "identifier")
+  (profj-java-mode-color-default "default")
+
+  (profj-insert-java-comment-box "Insert Java Comment Box")
+  (profj-insert-java-interactions-box "Insert Java Interactions Box")
+
+  ;; The Test Suite Tool
+  ;; Errors
+  (test-case-empty-error "Empty test case")
+  (test-case-too-many-expressions-error "Too many expressions in a test case.")
+  (test-case-not-at-top-level "Test case box not at top level")
+  ;; Dr. Scheme window menu items
+  (test-case-insert "Insert Test Case")
+  (test-case-disable-all "Disable all Test Cases")
+  (test-case-enable-all "Enable all Test Cases")
+  
+  ;; NOTE: The following string constants are labels of the test-case fields. The width
+  ;;       of the field is determined by the length of the longest of the following three words.
+  ;;       if the words are too long the test case will take up too much horizontal room and
+  ;;       not look very good.
+  ;; This string is the label of the expression that is being tested in a test case.
+  (test-case-to-test "Test")
+  ;; This string is the label of the expression that is the expected value of the to-test expression.
+  (test-case-expected "Should be")
+  ;; This string is the label of the actual result of the to test expression.
+  (test-case-actual "Actual")
+  (test-case-predicate "Predicate")
+  (test-case-should-raise "Should Raise")
+  ;; The label of a field of the test-case that describes the expected error message of a test case
+  (test-case-error-message "Error Message")
+
+  (test-case-menu-title "Test Case")
+  (test-case-switch-to-error-box "Switch to Error Test Box")
+  (test-case-switch-to-nonerror-box "Switch to Nonerror Test box")
+  (test-case-collapse "Collapse Test Case")
+  (test-case-show-actual "Show Actual Value")
+  (test-case-enable "Enable Test Case")
+  (test-case-show-predicate "Show Predicate")
+  (test-case-show-error-message "Show Error Message")
+  (test-case-convert-to-text "Convert to text")
+  
+  ;; Profj Boxes
+  (profjBoxes-empty-error "Empty interaction")
+  (profjBoxes-too-many-expressions-error "Too many expressions in a box")
+  (profjBoxes-interactions-label "Interactions")
+  (profjBoxes-bad-java-id-error "Malformed Java ID")
+  (profjBoxes-examples-label "Examples")
+  (profjBoxes-add-new-example-button "Add new example")
+  (profjBoxes-type "Type")
+  ;; The Java identifier of an example of data
+  (profjBoxes-name "Name")
+  (profjBoxes-value "Value")
+  (profjBoxes-insert-java-examples "Insert Java Examples")
+  (profjBoxes-insert-java-interactions "Insert Java Interactions")
+
+  ;; Slideshow
+  (slideshow-show-slideshow-panel "Show Slideshow Panel")
+  (slideshow-hide-slideshow-panel "Hide Slideshow Panel")
+  (slideshow-freeze-picts "Freeze These Picts")
+  (slideshow-thaw-picts "Show Picts Under Mouse")
+  (slideshow-hide-picts "Show Nested Boxes")
+  (slideshow-show-picts "Show Picts")
+  (slideshow-cannot-show-picts "Cannot show picts; run program to cache sizes first")
+  (slideshow-insert-pict-box "Insert Pict Box") 
+
+  ;; GUI Tool
+  (gui-tool-heading "GUI Tool")
+  (gui-tool-before-clicking-message "Before clicking a tool icon, use \"Insert GUI\" from the \"Special\" menu to insert a root GUI item, or select an already inserted GUI.")
+  (gui-tool-show-gui-toolbar "Show GUI Toolbar")
+  (gui-tool-hide-gui-toolbar "Hide GUI Toolbar")
+  (gui-tool-insert-gui "Insert GUI")
+  )
diff --git a/collects/string-constants/french-string-constants.ss b/collects/string-constants/french-string-constants.ss
new file mode 100644
index 0000000000..c3293fde53
--- /dev/null
+++ b/collects/string-constants/french-string-constants.ss
@@ -0,0 +1,1285 @@
+
+; do not remove all these blank lines, I use them to make sure a translation 
+; in this file appears on the same line as in english-string-constants.ss
+
+; "aâàbcçdeéêèëfghiîïjklmnoôpqrstuûùüvwxyz"
+
+; Note: http://www.linux-france.org/prj/jargonf/ peut etre utile... Les dictionnaires online
+; anglais->francais sont tres pauvres en ce qui concerne le jargon technique, et l'academie
+; francaise (http://www-rocq.inria.fr/qui/Philippe.Deschamp/RETIF/) a quelques longueures de
+; retard. http://www.can.ibm.com/francais/dico/ peut aider aussi...
+; http://www.dicofr.com/ permet les recherches a partir du mot anglais.
+; http://www.francophonie.hachette-livre.fr/ est un dico standard de base
+; http://zeus.inalf.fr/academie9.htm est le dico de l'academie (A-M pour l'instant seulement)
+; http://www.google.com/language_tools?hl=en peut servir...
+; http://www.lexilogos.com/francais_langue_dictionnaires.htm a beaucoup de liens
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+(module french-string-constants "string-constant-lang.ss"
+  ;;; when translating this constant, substitue name of actual langauge for `English'
+  (is-this-your-native-language "Le Français est-il votre langue maternelle ?")
+  
+  (are-you-sure-you-want-to-switch-languages
+   "Ceci va changer le langage utilisé par l'interface graphique, ce qui va nécessiter un redémarrage de DrScheme. Etes-vous certain de vouloir continuer ?")
+  
+  (interact-with-drscheme-in-language "Interagir avec DrScheme en Français")
+  
+  ;; these two should probably be the same in all languages excepet English.
+  ;; they are the button labels (under macos and windows, respectively)
+  ;; that go the with the string above.
+  (accept-and-quit "Accepter et Quitter")
+  (accept-and-exit "Accepter et Quitter")
+  
+  ;;; general purpose (DrScheme is hereby a word in every language, by decree of Robby :)
+  (plt "PLT")
+  (drscheme "DrScheme")
+  (ok "OK")
+  (cancel "Annuler")
+  (abort "Abandonner")
+  (untitled "Sans Nom")
+  (untitled-n "Sans Nom ~a")
+  (warning "Avertissement")
+  (error "Erreur")
+  (close "Fermer") ;; as in, close an open window. must match close-menu-item
+                   ;; in the sense that, when the &s have been stripped from
+                   ;; close-menu-item, it must be the same string as this.
+  (stop "Stop")
+  (&stop "&Stop") ;; for use in button and menu item labels, with short cut.
+  (are-you-sure-delete? "Etes-vous certain de vouloir effacer ~a ?") ;; ~a is a filename
+  (ignore "Ignorer")
+  (revert "Retourner") ; revenir?
+  
+  ;; label for a generic check box, often supported on dialogs
+  ;; that ask a binary choice of the user. If checked, the
+  ;; dialog isn't going to be shown again.
+  (dont-ask-again "Ne jamais redemander (utilisera toujours votre présent choix)")
+  
+  ;;; important urls
+  (web-materials "Sites web apparentés") ;; menu item title
+  (tool-web-sites "Sites web d'outils")   ;; menu item title
+  (drscheme-homepage "DrScheme")
+  (plt-homepage "PLT")
+  (how-to-use-scheme "How to Use Scheme") ;; title of a book.
+  (teachscheme!-homepage "TeachScheme!") ;; probably this should be a `word' in all languages
+  
+  ;;; bug report form
+  (cancel-bug-report? "Annuler la soumission du rapport de bogue ?")
+  (are-you-sure-cancel-bug-report?
+   "Etes-vous certain de vouloir annuler la soumission de ce rapport de bogue ?")
+  (bug-report-form "Formulaire de soumission de bogue")
+  (bug-report-field-name "Nom")
+  (bug-report-field-email "Email")
+  (bug-report-field-summary "Résumé du problème")
+  (bug-report-field-severity "Sévérité")
+  (bug-report-field-class "Classe")
+  (bug-report-field-priority "Priorité")
+  (bug-report-field-description "Description")
+  (bug-report-field-reproduce1 "Etapes à suivre pour")
+  (bug-report-field-reproduce2 "reproduire le bogue")
+  (bug-report-field-environment "Environnement")
+  (bug-report-field-tools "Outils")
+  (bug-report-field-docs-installed "Documentations installées")
+  (bug-report-field-language "Langage")
+  (bug-report-field-teachpacks "Teachpacks")
+  (bug-report-field-collections "Collections")
+  (bug-report-field-human-language "Langage humain")
+  (bug-report-field-version "Version")
+  (bug-report-synthesized-information "Information Synthétisée")  ;; dialog title
+  (bug-report-show-synthesized-info "Montrer l'information synthétisée")
+  (bug-report-submit "Soumettre")
+  (bug-report-submit-menu-item "Soumettre un rapport de bogue") ;; in Help Menu (drs & help desk)
+  (sending-bug-report "Soumission du rapport de bogue en cours...")
+  (error-sending-bug-report "Erreur durant la soumission du rapport de bogue.")
+  (error-sending-bug-report-expln "Une erreur s'est produite pendant la soumission de votre rapport de bogue. Si votre connexion Internet fonctionne correctement, veuillez visiter :\n\n    http://bugs.plt-scheme.org/\n\net soumettre votre bogue en utilisant notre formulaire web en ligne. Je suis vraiment profondément désolé pour toutes vos difficultés.\n\nLe message d'erreur est :\n~a")
+  (bug-report-sent "Le bogue a été correctement soumis.")
+  (bug-report-sent-detail "Merci pour votre soumission. Vous devriez recevoir une confirmation de votre soumission par email d'ici 30 minutes. Si vous ne recevez pas cette confirmation, veuillez envoyer un email à scheme@plt-scheme.org.")
+  (illegal-bug-report "Formulaire de soumission de bogue incomplet.")
+  (pls-fill-in-field "Merci de compléter le champ \"~a\".")
+  (malformed-email-address "Adresse email malformée.")
+  (pls-fill-in-either-description-or-reproduce "Veuillez remplir soit le champ \"Description\", soit le champ \"Etapes à suivre pour reproduire le bogue\".")
+  
+  ;;; check syntax
+  (check-syntax "Vérifier") ; "Syntaxe" ; "Vérificateur de syntaxe" est long...
+  (cs-italic "Italique")
+  (cs-bold "Gras")
+  (cs-underline "Souligné")
+  (cs-change-color "Changer la couleur")
+  (cs-tack/untack-arrow "Coller/décoller les flèches")
+  (cs-jump-to-next-bound-occurrence "Aller à l'occurence suivante")
+  (cs-jump-to-binding "Aller à l'occurence liant celle-ci")
+  (cs-jump-to-definition "Aller à la définition")
+  (cs-error-message "Message d'erreur")
+  (cs-open-file "Ouvrir ~a")
+  (cs-rename-var "Renommer ~a")
+  (cs-rename-id "Renommer l'identificateur")
+  (cs-rename-var-to "Renommer ~a en :")
+  (cs-name-duplication-error "Le nouveau nom que vous avez choisi, ~s, est en conflit avec un autre nom préexistant dans le même contexte.")
+  (cs-rename-anyway "Renommer quand même")
+  (cs-status-init "Vérificateur de syntaxe : initialisation de l'environnement pour le code de l'utilisateur")
+  (cs-status-coloring-program "Vérificateur de syntaxe : coloriage d'une expression")
+  (cs-status-eval-compile-time "Vérificateur de syntaxe : évaluation pour l'expansion") ; peut mieux faire?
+  (cs-status-expanding-expression "Vérificateur de syntaxe : expansion d'une expression")
+  (cs-mouse-over-import "l'identificateur ~s est importé de ~s")
+  
+  (cs-lexical-variable "variable lexicale")
+  (cs-lexical-syntax "syntaxe lexicale")
+  (cs-imported-variable "variable importée")
+  (cs-imported-syntax "syntaxe importée")
+
+  ;;; info bar at botttom of drscheme frame
+  (collect-button-label "Ramassage") ; de miettes
+  (read-only "Lecture seulement")
+  (read/write "Lecture/écriture")
+  (auto-extend-selection "Autosélection") ; "Sélection auto-étendable" ?
+  (overwrite "Correction") ; vs Insertion ? surimpression ?
+  (running "en cours")
+  (not-running "en attente") ; "en attente" ; pause ?
+  
+  ;;; misc
+  (welcome-to-something "Bienvenue dans ~a.")
+  
+  ; this appears in the drscheme about box.
+  (welcome-to-drscheme-version/language "Bienvenue dans DrScheme, version ~a, ~a.")
+  
+  ; these appear on subsequent lines in the `Help|Welcome to DrScheme' dialog.
+  (welcome-to-drscheme "Bienvenue dans DrScheme")
+  (version/language "version ~a, ~a.")
+  
+  (goto-line "Aller à la ligne")
+  (goto-line-invalid-number
+   "~a n'est pas un numéro de ligne valide. Ce doit être un entier entre 1 et ~a.")
+  (goto-position "Aller à la position")
+  (no-full-name-since-not-saved
+   "Le fichier n'a pas encore de nom complet car il n'a pas encore été sauvegardé.")
+  (cannot-open-because-dne "Impossible d'ouvrir ~a car le fichier n'existe pas.")
+  (interactions-out-of-sync
+   "ATTENTION : la fenêtre d'interaction et la fenêtre de définition ne sont pas synchronisées. Cliquez sur Exécuter.")
+  (file-is-not-saved "Le fichier \"~a\" n'a pas été sauvegardé.")
+  (save "Sauvegarder")
+  (please-choose-either "Choisissez \"~a\" ou \"~a\".")
+  (close-anyway "Fermer quand même")
+  (clear-anyway "Effacer quand même")
+  
+  ;; menu item title
+  (log-definitions-and-interactions "Enregistrer les définitions et interactions...")
+  (stop-logging "Stopper l'enregistrement")
+  (please-choose-a-log-directory "Sélectionnez un répertoire d'enregistrement")
+  (logging-to "Enregistrer dans : ")
+  (erase-log-directory-contents "Effacer le contenu du répertoire d'enregistrement : ~a ?")
+  (error-erasing-log-directory "Erreur durant l'effacement du contenu du répertoire d'enregistrement.\n\n~a\n")
+  
+  ;; modes
+  (mode-submenu-label "Modes")
+  (scheme-mode "Mode scheme")
+  (text-mode "Mode texte")
+ 
+  (scheme-mode-color-symbol "les symboles")
+  (scheme-mode-color-keyword "les mots réservés")
+  (scheme-mode-color-comment "les commentaires")
+  (scheme-mode-color-string "les chaînes de caractères")
+  (scheme-mode-color-constant "les constantes")
+  (scheme-mode-color-parenthesis "les parenthèses")
+  (scheme-mode-color-error "les erreurs")
+  (scheme-mode-color-other "le reste")
+ ;; the ~a is filled in with one of the above (scheme-mode-*)
+  (syntax-coloring-choose-color "Choisissez une couleur pour ~a")
+  (preferences-colors "Couleurs") ;; used in the preferences dialog
+ 
+  (url "URL")
+  (url: "URL :")
+  (open-url... "Ouvrir l'URL...")
+  (open-url "Ouvrir l'URL")
+  (browse... "Naviguer...")
+  (bad-url "URL incorrect")
+  (bad-url:this "URL incorrect : ~a")
+  
+  ;; Help Desk
+  (help "Aide")
+  (help-desk "Aide")
+  (plt:hd:search-results "Résultats de la recherche")
+  (plt:hd:search "Chercher")
+  (plt:hd:search-for "Chercher")
+  (plt:hd:lucky "Chanceux !")
+  (plt:hd:feeling-lucky "D'humeur chanceuse")
+  (plt:hd:stop "Stop")
+  (plt:hd:options "Options")
+  (plt:hd:configure "Configurer")
+  (plt:hd:home "Page d'accueil de l'Aide")
+  (plt:hd:show-manuals "Liste des manuels")
+  (plt:hd:send-bug-report "Signaler un bogue") ; Envoyer un rapport de bogue
+  (plt:hd:query-bug-reports "Bogues connus")
+  ; next 3 are popup menu choices at bottom of help desk window
+  (plt:hd:search-for-keyword "par mot clef")
+  (plt:hd:search-for-keyword-or-index "par mot clef ou entrée dans l'index")
+  (plt:hd:search-for-keyword-or-index-or-text "par mot clef, entrée dans l'index ou dans le texte")
+  (plt:hd:exact-match "mot exact")
+  (plt:hd:containing-match "contenant le mot")
+  (plt:hd:regexp-match "expression régulière")
+  (plt:hd:find-docs-for "Chercher dans les docs :")
+  (plt:hd:nothing-found-for-search-key "Rien n'a été trouvé pour \"~a\".")
+  (plt:hd:searching "Recherche en cours...")
+  (plt:hd:search-stopped "(Recherche stoppée.)")
+  (plt:hd:search-stopped-too-many-matches "(Recherche stoppée - trop d'entrées ont été trouvées.)")
+  (plt:hd:nothing-found-for "Rien n'a été trouvé pour ~a.")
+  (plt:hd:error-finding-docs "Documentation introuvable.\n\n~a")
+  (plt:hd:and "et")
+  (plt:hd:refresh "rafraîchir")
+  (plt:hd:refresh-all-manuals "rafraîchir tous les manuels")
+  (plt:hd:manual-installed-date "(installé le ~a)")
+  ; Help Desk configuration
+  (plt:hd:configuration "Configuration de l'Aide")
+  (plt:hd:no-frames "Pas de cadres")
+  (plt:hd:use-frames "Utiliser des cadres")
+  (plt:hd:use-html-frames "Utiliser des cadres HTML")
+  (plt:hd:search-pane-options "Options pour le cadre de recherche")
+  (plt:hd:height "Hauteur")
+  (plt:hd:bg-color "Couleur de fond")
+  (plt:hd:pixels "pixels")
+  (plt:hd:text-color "Couleur du texte")
+  (plt:hd:link-color "Couleur des liens")
+  (plt:hd:text-sample "Le texte dans le cadre de recherche apparaît dans cette couleur")
+  (plt:hd:link-sample "Les liens dans le cadre de recherche apparaîssent dans cette couleur")
+  (plt:hd:save-changes "Sauvegarder les modifications")
+  (plt:hd:reset "Réinitialisation des options")
+  (plt:hd:defaults "Valeurs par défaut")
+  (plt:hd:javascript-note
+   "Les choix que vous faites sont montrés ici si vous avez Javascript et un navigateur récent")
+  ;; refreshing manuals
+  (plt:hd:refresh-downloading "Téléchargement de ~a")
+  (plt:hd:refresh-installing "Installation de la nouvelle version de ~a")
+  (plt:hd:refresh-progress "Progrès du téléchargement des manuels")
+;; should not mention `SVN' (plt:hd:refresh-done "Fin du téléchargement des manuels par SVN")
+  (plt:hd:refresh-installation-log "Journal de l'installation")
+  (plt:hd:refresh-stopped "Téléchargement des manuels stoppé")
+  (plt:hd:refreshing-manuals "Retéléchargement des manuels")
+  (plt:hd:refresh-downloading... "Téléchargement de ~a...")
+  (plt:hd:refresh-deleting... "Effacement de l'ancienne version de ~a...")
+  (plt:hd:refresh-installing... "Installation de la nouvelle version de ~a...")
+  (plt:hd:refresh-clearing-indicies "Effacement des indices cachés")
+  (plt:hd:refreshing-manuals-finished "Terminé.")
+  (plt:hd:about-help-desk "A propos de l'Aide")
+  (plt:hd:help-desk-about-string
+   "L'Aide est une source complète d'information à propos des logiciels du PLT, y compris DrScheme, MzScheme et MrEd.\n\nVersion ~a\nCopyright (c) 1995-2003 PLT.")
+  (plt:hd:help-on-help "Aide de l'Aide")
+  (plt:hd:help-on-help-details "Pour obtenir de l'aide sur comment utiliser l'Aide, suivez le lien `How to use Help Desk' à partir de la page principale de l'Aide (pour trouver la page principale, si vous n'y êtes pas déjà, cliquez sur le boutton `Home' qui apparaît en haut de la fenêtre de l'Aide).")
+  (reload "Rafraîchir")
+  (plt:hd:ask-about-separate-browser
+   "Vous avez sélectionné un lien vers une page sur le world-wide web. Voulez-vous voir cette page en utilisant le navigateur de l'Aide ou voulez-vous utiliser un navigateur séparé ?")
+  (plt:hd:homebrew-browser "Navigateur de l'Aide") ;; choice for the above string (in a button)
+  (plt:hd:separate-browser "Navigateur séparé") ;; other choice for the above string (also in a button)
+  (plt:hd:external-link-in-help "URLs externes dans l'Aide")
+  (plt:hd:use-homebrew-browser "Utiliser le navigateur de l'Aide pour les URLs externes")
+  (plt:hd:new-help-desk "&Nouvelle Aide")
+  (plt:hd:teaching-manuals "Manuels pour étudiants")
+  (plt:hd:professional-manuals "Manuels pour professionnels")
+  (plt:hd:all-manuals "Tous les manuels")
+
+  ;; in the Help Desk language dialog, title on the right.
+  (plt:hd:manual-search-ordering "Ordre de recherche dans les manuels")
+
+  
+  ; help desk htty proxy
+  (http-proxy "Proxy HTTP")
+  (proxy-direct-connection "Connexion directe")
+  (proxy-use-proxy "Utiliser le proxy :")
+  (proxy-host "Machine")
+  (proxy-port "Port")
+  (proxy-bad-host "Mauvaise machine proxy")
+  
+  ;; browser
+  (rewind-in-browser-history "Retourner")
+  (forward-in-browser-history "Avancer")
+  (home "Maison")
+  (browser "Navigateur")
+  (choose-browser "Choisissez un navigateur")
+  (external-browser-choice-title "Navigateur externe") ; title for radio-button set
+  (browser-command-line-label "Ligne de commande :") ; label for radio button that is followed by text boxes
+  (no-browser "Demander plus tard")
+  (use-internal-browser-for-help "Lire l'Aide à l'aide du navigateur PLT interne") ; radio-button label
+  (use-external-browser-for-help "Lire l'Aide à l'aide d'un navigateur externe") ; radio-button label
+  (browser-cmdline-expl-line-1 "(La ligne de commande est la concaténation du préfixe, de l'URL,") ; explanatory text for dialog, line 1
+  (browser-cmdline-expl-line-2 "et du suffixe, sans espace additionel entre eux.)") ; ... line 2. (Anyone need more lines?)
+  (cannot-display-url "Impossible de montrer l'URL ~s : ~a")
+  (install? "Installer ?")  ;; if a .plt file is found (title of dialog)
+  (you-have-selected-an-installable-package "Vous avez sélectionné un logiciel qui peut être installé.") ; package => paquetage, pas tres clair...
+  (do-you-want-to-install-it? "Voulez-vous l'installer ?")
+  (paren-file-size "(Le fichier fait ~a octets)")
+  (download-and-install "Télécharger && Installer") ;; button label
+  (download "Télécharger") ;; button label
+  (save-downloaded-file/size "Sauvegarder le fichier téléchargé (~a octets) sous le nom") ;; label for get-file dialog
+  (save-downloaded-file "Sauvegarder le fichier téléchargé sous le nom")  ;; label for get-file dialog
+  (downloading "Téléchargement") ;; dialog title
+  (downloading-file... "Téléchargement du fichier en cours...")
+  (package-was-installed "Le logiciel à été installé.")
+  (download-was-saved "Le fichier téléchargé à été sauvegardé.")
+  (getting-page "Page en cours de réception") ;; dialog title
+  
+  (install-plt-file-menu-item... "Installer un fichier .plt...")
+  (install-plt-file-dialog-title "Installer un fichier .plt")
+  (install-plt-web-tab "Web")
+  (install-plt-file-tab "Fichier")
+  (install-plt-filename "Nom de fichier :")
+  (install-plt-url "URL :")
+  
+  ;; install plt file when opened in drscheme strings
+  (install-plt-file "Installer ~a ou l'ouvrir pour édition ?")
+  (install-plt-file/yes "Installation")
+  (install-plt-file/no "Edition")
+  
+  (plt-installer-progress-window-title "Progresssion de l'installation") ;; frame title
+  (plt-installer-abort-installation "Abandonner l'installation") ;; button label
+  (plt-installer-aborted "Installation abandonnée.") ;; msg that appears in the installation window when installation is aborted
+  
+  ;;; about box
+  (about-drscheme-frame-title "A propos de DrScheme")
+  (take-a-tour "Faire un tour !")
+  (release-notes "Notes pour la révision")
+  (parenthetical-last-version "(version précédente ~a)")
+  (parenthetical-last-language "(langage précédent ~a)")
+  (parenthetical-last-version/language "(version précédente ~a, langage précédent ~a)")
+  
+  
+  ;;; save file in particular format prompting.
+  (save-as-plain-text "Sauvegarder ce fichier au format texte ?")
+  (save-in-drs-format "Sauvegarder ce fichier au format DrScheme (non-texte) ?")
+  (yes "Oui")
+  (no "Non")
+  
+  ;;; preferences
+  (preferences "Préférences")
+  (saving-preferences "Sauvegarde des préférences")
+  (error-unmarshalling "Erreur durant la dessérialisation de la préférence ~a.")
+  (error-saving-preferences "Erreur durant la sauvegarde des préférences : ~a.")
+  (error-reading-preferences "Erreur durant la lecture des préférences.")
+  (expected-list-of-length2 "espérait une liste de longueur 2.")
+  (scheme-prefs-panel-label "Scheme")
+  (warnings-prefs-panel-label "Avertissements")
+  (editor-prefs-panel-label "Edition")
+  (general-prefs-panel-label "Général")
+  (highlight-parens "Surligner les paires de parenthèses.")
+  (fixup-parens "Corriger les parenthèses.")
+  (flash-paren-match "Montrer la parenthèse correspondante.")
+  (auto-save-files "Sauvegarde automatique des fichiers.")
+  (backup-files "Fichiers de sauvegarde.")
+  (map-delete-to-backspace "La touche Delete génére Backspace.")
+  (verify-exit "Confirmation pour quitter.")
+  (ask-before-changing-format "Confirmation avant de changer le format de sauvegarde.")
+  (wrap-words-in-editor-buffers "Continuer une longue ligne sur la ligne suivante, dans les éditeurs.")
+  (show-status-line "Montrer la barre de status.")
+  (count-columns-from-one "Compter les lignes et colonnes à partir de un.")
+  (display-line-numbers "Montrer le numéro de ligne et de colonne, pas la distance depuis le début d'éditeur.")
+  (enable-keybindings-in-menus "Raccourcis clavier dans les menus.")
+  (automatically-to-ps "Imprimer automatiquement dans un fichier postscript.")
+  (option-as-meta "Utiliser la touche option comme touche meta") ;; macos/macos x only
+  (use-mdi "Utiliser les fenêtres MDI.") ;;; ms windows only -- use that window in a window thingy
+  (separate-dialog-for-searching "Utiliser un dialogue séparé pour les recherches.")
+  (reuse-existing-frames "Réutiliser les fenêtres existantes lors de l'ouverture de nouveaux fichiers")
+  (default-fonts "Polices par défaut")
+  (paren-match-color "Couleur de surlignage des parenthèses") ; in prefs dialog
+  (choose-color "Sélectionnez une couleur") ; in prefs dialog
+  (online-coloring-active "Colorier la syntaxe interactivement")
+  (open-files-in-tabs "Ouvrir les fichiers dans de nouveaux onglets (pas dans de nouvelles fenêtres)")
+  (show-interactions-on-execute "Automatiquement montrer la fenêtre d'interaction lors de l'exécution d'un programme")
+  (limit-interactions-size "Limiter la taille de la fenêtre d'interaction")
+  (background-color "Couleur d'arrière-plan")
+  (default-text-color "Couleur du texte") ;; used for configuring colors, but doesn't need the word "color"
+  (choose-a-background-color "Sélectionnez une couleur d'avant-plan")
+  
+  ; title of the color choosing dialog
+  (choose-paren-highlight-color "Sélectionnez une couleur pour surligner les parenthèses")
+  
+  ; should have entire alphabet
+  (font-example-string "aâàbcçdeéêèëfghiîïjklmnoôpqrstuûùüvwxyz")
+  
+  (change-font-button-label "Changer")
+  (fonts "Polices")
+  
+  ; filled with type of font, eg modern, swiss, etc.
+  (choose-a-new-font "Sélectionnez une nouvelle police \"~a\".")
+  
+  (font-size-slider-label "Taille")
+  (restart-to-see-font-changes "Redémarrez pour voir le changement de polices.")
+  
+  (font-prefs-panel-title "Police")
+  (font-name "Nom de la police")
+  (font-size "Taille de la police")
+  (set-font "Appliquer la police...")
+  (font-smoothing-label  "Lissage de polices")
+  (font-smoothing-none "Aucune")
+  (font-smoothing-some "Certaines")
+  (font-smoothing-all "Toutes")
+  (font-smoothing-default "Utiliser la configuration par défaut du système")
+  (select-font-name "Sélectionnez une police")
+  (example-text "Example de texte :")
+  (only-warn-once "Prévenir une fois seulement quand exécutions et interactions n'ont pas été synchronisées.")
+  
+  ; warning message when lockfile is around
+  (waiting-for-pref-lock "Attente sur le fichier de verrouillage des préférences...")
+  (pref-lock-not-gone
+   "Les préférences sont verrouillées par le fichier :\n\n   ~a\n\nqui empêche les préférences d'être sauvegardées. Assurez-vous qu'aucun logiciel PLT n'est en cours d'exécution et effacer le fichier.")
+  (still-locked-exit-anyway? "Les préférences n'ont pu être sauvegardées correctement. Quitter quand même ?")
+  
+  ;;; indenting preferences panel
+  (indenting-prefs-panel-label "Indentation")
+  (indenting-prefs-extra-regexp "Regexp extra") ; Expression régulière supplémentaire est trop long
+  
+  ; filled with define, lambda, or begin
+  (enter-new-keyword "Entrez un nouveau mot clef ressemblant à ~a :")
+  (x-keyword "Mot clef ~a")
+  (x-like-keywords "Mots clefs ressemblant à ~a")
+  
+  (expected-a-symbol "espérait un symbole, trouvé : ~a")
+  (already-used-keyword "\"~a\" est déjà un mot clef avec une indentation spéciale.")
+  (add-keyword "Ajouter")
+  (remove-keyword "Enlever")
+  
+  ;;; find/replace
+  (find-and-replace "Chercher et remplacer")
+  (find "Chercher")
+  (replace "Remplacer")
+  (dock "Attacher")
+  (undock "Séparer")
+  (use-separate-dialog-for-searching "Utiliser un menu séparé pour chercher.")
+  (replace&find-again "Remplacer && chercher à nouveau") ;;; need double & to get a single &
+  (replace-to-end "Remplacer jusqu'à la fin")
+  (forward "En avant")
+  (backward "En arrière")
+  (hide "Cacher")
+  
+  ;;; multi-file-search
+  (mfs-multi-file-search-menu-item "Rechercher dans les fichiers...")
+  (mfs-string-match/graphics "une chaîne de caractères (y compris dans les fichiers avec graphiques)")
+  (mfs-regexp-match/no-graphics "une expression régulière (fichiers textuels seulement)")
+  (mfs-searching... "Recherche en cours...")
+  (mfs-configure-search "Configurer la recherche") ;; dialog title
+  (mfs-files-section "Fichiers")   ;; section in config dialog
+  (mfs-search-section "Rechercher") ;; section in config dialog
+  (mfs-dir "Répertoire")
+  (mfs-recur-over-subdirectories "Récursion dans les sous-répertoires")
+  (mfs-regexp-filename-filter "Expression régulière pour filtrer les noms de fichiers")
+  (mfs-search-string "Chercher la chaîne de caractères")
+  (mfs-drscheme-multi-file-search "DrScheme - Recherche dans des fichiers multiples") ;; results window and error message title
+  (mfs-not-a-dir "\"~a\" n'est pas un répertoire")
+  (mfs-open-file "Ouvrir le fichier")
+  (mfs-stop-search "Stopper la recherche")
+  (mfs-case-sensitive-label "Différentier les lettres majuscules des minuscules")
+  (mfs-no-matches-found "Rien n'a été trouvé.")
+  (mfs-search-interrupted "Recherche avortée.")
+  
+  ;;;reverting a file
+  (error-reverting "DrScheme - Erreur durant le retour à l'original.")
+  (could-not-read "impossible de lire \"~a\".")
+  (are-you-sure-revert
+   "Etes-vous certain de vouloir retourner à la version de ce fichier qui est sur le disque dur ? Ce changement ne pourra pas être défait.")
+  (are-you-sure-revert-title
+   "Retourner ?")
+  
+  ;;; saving a file
+  ; ~a is filled with the filename
+  (error-saving "Erreur durant la sauvegarde") ;; title of error message dialog
+  (error-saving-file/name "Une erreur s'est produite durant la sauvegarde de ~a.")
+  (error-loading "Erreur durant le chargement")
+  (error-loading-file/name "Une erreur s'est produite durant le chargement de ~a.")
+  (unknown-filename "<< inconnu >>")
+  
+  ;;; finder dialog
+  (must-specify-a-filename "Vous devez spécifier un nom de fichier.")
+  (file-does-not-exist "Le fichier \"~a\" n'existe pas.")
+  (ask-because-file-exists "Le fichier \"~a\" existe déjà. Voulez-vous le remplacer ?")
+  (dne-or-cycle "Le fichier \"~a\" contient un répertoire non-existant, ou une boucle.")
+  (get-file "Obtenir fichier")
+  (put-file "Donner fichier")
+  (full-pathname "Chemin de fichier complet")
+  (show-dot-files "Montrer les fichiers et répertoires dont le nom commence par un point.")
+  (up-directory-button-label "Répertoire parent")
+  (add-button-label "Ajouter") ;;; for multi-file selection
+  (add-all-button-label "Ajouter tous") ;;; for multi-file selection
+  (remove-button-label "Enlever") ;;; for multi-file selection
+  (file-wrong-form "Le format de ce nom de fichier est incorrect.")
+  (select-files "Sélectionnez des fichiers")
+  (select-file "Sélectionnez un fichier")
+  (dir-dne "Ce répertoire n'existe pas.")
+  (file-dne "Ce fichier n'existe pas.")
+  (empty-filename "Le nom de fichier doit contenir au moins quelques lettres.")
+  (that-is-dir-name "Ceci est un nom de répertoire.")
+  
+  ;;; raw menu names -- these must match the 
+  ;;; versions below, once the &s have been stripped.
+  ;;; if they don't, DrScheme's menus will appear
+  ;;; in the wrong order.
+  (file-menu "Fichier")
+  (edit-menu "Editer")
+  (help-menu "Aide")
+  (windows-menu "Fenêtres")
+  
+  ;;; menus
+  ;;; - in menu labels, the & indicates a alt-key based shortcut.
+  ;;; - sometimes, things are stuck in the middle of 
+  ;;; menu item labels. For instance, in the case of
+  ;;; the "Save As" menu, you might see: "Save Definitions As". 
+  ;;; be careful of spacing, follow the English, if possible.
+  ;;; - the ellipses in the `after' strings indicates that
+  ;;; more information is required from the user before completing
+  ;;; the command.
+  
+  (file-menu-label "Fichier")
+
+  (new-info  "Ouvrir un nouveau fichier.")
+  (new-menu-item "&Nouvelle fenêtre")
+  (new-...-menu-item "&Nouvelle...")
+  
+  (open-info "Ouvrir un fichier à partir du disque dur.")
+  (open-menu-item "&Ouvrir")
+  (open-here-menu-item "&Ouvrir ici...")
+  
+  (open-recent-info "Une liste des fichiers ouverts récemment.")
+  (open-recent-menu-item "Ouvrir récent")
+  
+  (revert-info "Retour à la version originale de ce fichier sur le disque dur.")
+  (revert-menu-item "&Retour version disque")
+  
+  (save-info "Sauvegarder ce fichier sur le disque dur.")
+  (save-menu-item "&Sauvegarder")
+  
+  (save-as-info "Demander un nom de fichier et sauver ce fichier sur le disque dur.")
+  (save-as-menu-item "Sauvegarder à")
+  
+  (print-info "Envoyer ce fichier à une imprimante.")
+  (print-menu-item "&Imprimer...")
+  
+  (close-info "Fermer ce fichier.")
+  (close-menu-item "&Fermer")
+  
+  (quit-info "Fermer toutes les fenêtres.")
+  (quit-menu-item-windows "&Quitter")
+  (quit-menu-item-others "&Quitter")
+  
+  (edit-menu-label "&Editer")
+  
+  (undo-info "Défaire l'action la plus récente.")
+  (undo-menu-item "&Défaire")
+  
+  (redo-info "Refaire l'action qui vient d'être défaite.")
+  (redo-menu-item "&Refaire")
+  
+  (cut-info "Déplacer dans le porte-bloc les éléments sélectionés, pour collage ultérieur.")
+  (cut-menu-item "&Couper")
+  
+  (copy-info "Copier dans le porte-bloc les éléments sélectionés, pour collage ultérieur.")
+  (copy-menu-item "Co&pier")
+  
+  (paste-info "Coller à la place des éléments sélectionnés les éléments qui ont été copiés ou coupés le plus récemment.")
+  (paste-menu-item "C&oller")
+  
+  (clear-info "Effacer les éléments sélectionnés sans modifier le porte-bloc ou le collage.")
+  (clear-menu-item-others "Effacer")
+  (clear-menu-item-windows "&Effacer")
+  
+  (select-all-info "Sélectionner tout le document.")
+  (select-all-menu-item "&Sélectionner tout")
+  
+  (find-info "Rechercher une chaîne de caractères.")
+  (find-menu-item "Rechercher...")
+  
+  (find-again-info "Recherche à nouveau la même chaîne de caractères.")
+  (find-again-menu-item "Rechercher à nouveau")
+  
+  (replace-and-find-again-info "Remplacer le texte sélectionné et rechercher à nouveau le même texte.")
+  (replace-and-find-again-menu-item "Remplacer && rechercher à nouveau")
+  
+  (preferences-info "Configurer vos préférences.")
+  (preferences-menu-item "Préférences...")
+  
+  (keybindings-info "Montrer les raccourcis clavier actuellement actifs.")
+  (keybindings-menu-item "Raccourcis clavier")
+  (keybindings-show-active "Montrer les raccourcis clavier actifs")
+  (keybindings-frame-title "Raccourcis clavier")
+  (keybindings-sort-by-name "Trier par nom")
+  (keybindings-sort-by-key "Trier par raccourci")
+  (keybindings-add-user-defined-keybindings "Ajouter des raccourcis clavier...")
+  (keybindings-menu-remove "Enlever ~a")
+  (keybindings-choose-user-defined-file "Sélectionnez un fichier contenant des raccourcis clavier.")
+  
+  (user-defined-keybinding-error "Erreur durant l'exécution du raccourci clavier ~a\n\n~a")
+  (user-defined-keybinding-malformed-file "Le fichier ~a ne contient pas un module écrit dans le langage (lib \"keybinding-lang.ss\" \"framework\").")  
+  
+  ;; menu items in the "special" menu
+  (insert-text-box-item "Insérer une boite texte")
+  (insert-pb-box-item "Insérer une boite à dessin")
+  (insert-image-item "Insérer une image...")
+  (insert-comment-box-menu-item-label "Insérer une boite à commentaires")
+  (insert-lambda "Insérer un &Lambda")
+  (insert-delta "Insérer un &Delta (define)")
+  
+  (wrap-text-item "Replier le texte")
+  
+  (windows-menu-label "Fe&nêtres")
+  (bring-frame-to-front "Amener une fenêtre au premier plan")       ;;; title of dialog
+  (bring-frame-to-front... "Amener une fenêtre au premier plan...") ;;; corresponding title of menu item
+  (next-window "Fenêtre suivante")
+  (previous-window "Fenêtre précédente")
+  (most-recent-window "Fenêtre la plus récente")
+  
+  (view-menu-label "&Montrer")
+  (show-overview "Montrer le contour")
+  (hide-overview "Cacher le contour")
+  (show-module-browser "Montrer le navigateur de modules")
+  (hide-module-browser "Cacher le navigateur de modules")
+  
+  (help-menu-label "&Aide")
+  (about-info "Auteurs et détails concernant ce logiciel.")
+  (about-menu-item "A propos de ...")
+  (help-menu-check-for-updates "Regarder les mises à jour...")
+  
+  ;; open here's new menu item
+  (create-new-window-or-clear-current
+   "Voulez-vous créer une nouvelle fenêtre ou effacer celle-ci ?")
+  (clear-current "Effacer celle-ci")
+  (new-window "Nouvelle fenêtre")
+  
+  ;;; exiting and quitting ``are you sure'' dialog
+  ;;; exit is used on windows, quit on macos, in English. Other
+  ;;; languages probably use the same word on both platforms.
+  (exit "Quitter")
+  (quit "Quitter")
+  (are-you-sure-exit "Etes-vous certain de vouloir quitter ?")
+  (are-you-sure-quit "Etes-vous certain de vouloir quitter ?")
+  
+  ;;; autosaving
+  (error-autosaving "Erreur durant l'auto-sauvegarde de \"~a\".")
+  (autosaving-turned-off "L'auto-sauvegarde est suspendue\njusqu'à ce que le fichier soit sauvegardé.")
+  (recover-autosave-files-frame-title "Recouvrer des fichiers auto-sauvegardés")
+  (autosave-details "Détails")
+  (autosave-recover "Recouvrer")
+  (autosave-unknown-filename "<<inconnu>>")
+  
+  ;; these are labels in a dialog that drscheme displays
+  ;; if you have leftover autosave files. to see the dialog,
+  ;; start up drscheme and modify (but don't save) a file
+  ;; (also, do this with an unsaved file). Wait for the autosave
+  ;; files to appear (typically 5 minutes). Kill DrScheme
+  ;; and restart it. You'll see the dialog
+  (autosave-autosave-label: "Fichier auto-sauvegardé :")
+  (autosave-original-label: "Fichier original :")
+  (autosave-autosave-label "Fichier auto-sauvegardé")
+  (autosave-original-label "Fichier original")
+  (autosave-compare-files "Comparer les fichiers auto-sauvegardés")
+  
+  (autosave-show-autosave "Auto-sauvegarder un fichier") ;; title of a window showing the autosave file
+  
+  (autosave-explanation "DrScheme a trouvé des fichiers auto-sauvegardés, qui peuvent contenir votre travail non-sauvegardé.")
+  
+  (autosave-recovered! "Recouvré !") ;; status of an autosave file
+  (autosave-deleted "Effacé")       ;; status of an autosave file
+  
+  (autosave-error-deleting "Erreur durant l'effacement de ~a\n\n~a") ;; first is a filename, second is an error message from mz.
+  (autosave-delete-button "Effacer")
+  (autosave-delete-title "Effacer")  ;; title of a dialog asking for deletion confirmation
+  (autosave-done "Continuer")
+  
+  ;; appears in the file dialog
+  (autosave-restore-to-where? "Sélectionnez un répertoire où sauvegarder le fichier auto-sauvegardé.")
+  
+  
+  ;;; file modified warning
+  (file-has-been-modified
+   "Ce fichier a été modifié depuis sa dernière sauvegarde. Voulez-vous écraser les modifications ?")
+  (overwrite-file-button-label "Ecraser")
+  
+  (definitions-modified 
+   "Le texte de la fenêtre de définition a été modifié directement sur le disque dur. Sauvegardez ou retournez à la version sur le disque.")
+  (drscheme-internal-error "Erreur interne de DrScheme.")
+  
+  ;;; tools
+  (invalid-tool-spec "La spécification d'outil qui se trouve dans le fichier info.ss de la collection ~a est invalide. Espérait soit une chaîne de caractères, soit une liste de chaînes de caractères, trouvé : ~e")
+  (error-loading-tool-title "DrScheme - Erreur durant le chargement de l'outil ~s; ~s")
+  (error-invoking-tool-title "Erreur durant l'invocation de l'outil ~s;~s")
+  (tool-tool-names-same-length
+   "`tool-names' et `tools' ne sont pas des listes de la même longueur, dans le fichier info.ss pour ~s. Trouvé ~e et ~e")
+  (tool-tool-icons-same-length
+   "`tool-icons' et `tools' ne sont pas des listes de la même longueur, dans le fichier info.ss pour ~s. Trouvé ~e et ~e")
+  (tool-tool-urls-same-length
+   "`tool-urls' et `tools' ne sont pas des listes de la même longueur, dans le fichier info.ss pour ~s. Trouvé ~e et ~e")
+  (error-getting-info-tool
+   "erreur durant le chargement du fichier info.ss pour ~s")
+  (tool-error-phase1 "Erreur durant la phase 1 pour l'outil ~s; ~s")
+  (tool-error-phase2 "Erreur durant la phase 2 oour l'outil ~s; ~s")
+  
+  
+  ;;; define popup menu
+  (end-of-buffer-define "<< fin du tampon >>")
+  (sort-by-name "Trier par nom")
+  (sort-by-position "Trier par position dans le fichier")
+  (no-definitions-found "<< aucune définition trouvée >>")
+  (jump-to-defn "Aller à la définition de ~a")
+  
+  (recent-items-sort-by-age "Trier par age")
+  (recent-items-sort-by-name "Trier par nom")
+  
+  ;;; view menu
+  (hide-definitions-menu-item-label "Cacher les &définitions")
+  (show-definitions-menu-item-label "Montrer les &définitions")
+  (definitions-menu-item-help-string "Cacher/montrer la fenêtre de définition")
+  (show-interactions-menu-item-label "Montrer les &interactions")
+  (hide-interactions-menu-item-label "Cacher les &interactions")
+  (interactions-menu-item-help-string "Montrer/cacher la fenêtre d'interaction")
+  (show-toolbar "Montrer la barre d'ou&tils")
+  (hide-toolbar "Cacher la barre d'ou&tils")
+  
+  ;;; file menu
+  (save-definitions-as "Sauvegarder les définitions...")
+  (save-definitions "&Sauvegarder les définitions")
+  (print-definitions "&Imprimer les définitions...")
+  (about-drscheme "A propos de DrScheme")
+  (save-other "Sauvegarder autre")
+  (save-definitions-as-text "Sauvegarder les définitions au format texte...")
+  (save-interactions "Sauvegarder les interactions")
+  (save-interactions-as "Sauvegarder les interactions...")
+  (save-interactions-as-text "Sauvegarder les interactions au format texte...")
+  (print-interactions "Imprimer les interactions...")
+  (new-tab "Nouvel onglet")
+  (close-tab "Fermer l'onglet")
+
+  ;;; edit-menu
+  (split-menu-item-label "Di&viser")
+  (collapse-menu-item-label "&Rassembler")
+  
+  ;;; language menu
+  (language-menu-name "&Langage")
+  
+  ;;; scheme-menu
+  (scheme-menu-name "&Scheme")
+  (execute-menu-item-label "Exécuter")
+  (execute-menu-item-help-string "Réexécuter le program de la fenêtre de définition.")
+  (break-menu-item-label "Stopper")
+  (break-menu-item-help-string "Stopper l'exécution.")
+  (kill-menu-item-label "Tuer")
+  (kill-menu-item-help-string "Tuer l'exécution.")
+  (clear-error-highlight-menu-item-label "Effacer le surlignage d'erreur")
+  (clear-error-highlight-item-help-string "Efface le surlignage rose après une erreur")
+  (reindent-menu-item-label "&Réindenter")
+  (reindent-all-menu-item-label "Réindenter &tout")
+  (semicolon-comment-out-menu-item-label "&Commenter à l'aide de points-virgules")
+  (box-comment-out-menu-item-label "&Commenter à l'aide d'une boite")
+  (uncomment-menu-item-label "&Décommenter")
+  
+  (convert-to-semicolon-comment "Convertir en un commentaire avec points-virgules")
+  
+  ;;; executables
+  (create-executable-menu-item-label "Créer un exécutable...")
+  (create-executable-title "Créer un exécutable")
+  (must-save-before-executable "Vous devez sauvegarder votre programme avant de créer un exécutable.")
+  (save-an-executable "Sauvegarder un exécutable")
+  (save-a-mred-launcher "Sauvegarder un lanceur de type MrEd")
+  (save-a-mzscheme-launcher "Sauvegarder un lanceur de type MzScheme")
+  (save-a-mred-stand-alone-executable "Sauvegarder un exécutable autonome de type MrEd")
+  (save-a-mzscheme-stand-alone-executable "Sauvegarder un exécutable autonome de type MzScheme")
+  
+  (definitions-not-saved "La fenêtre de définition n'a pas été sauvegardée. L'exécutable va utiliser la dernière version sauvegardée de la fenêtre de définition. Continuer ?")
+  (inline-saved-program-in-executable?
+   "Insérer dans l'exécutable le programme sauvegardé ? Si oui, vous pourrez copier l'exécutable sur un autre ordinateur ~a, mais l'exécutable sera probablement gros. Si vous choisissez non, vous ne pourrez pas copier l'exécutable sur un autre ordinateur, mais il sera bien plus petit. De plus, si vous choisissez non, l'exécutable utilisera toujours la version la plus récente du programme.")
+  (use-mred-binary?
+   "Utiliser le binaire de mred pour cet exécutable ?\n\nSi oui, votre program peut utiliser la bibliothèque (lib \"mred.ss\" \"mred\"). Si non, DrScheme va choisir mzscheme comme binaire pour cet exécutable.\n\nASi vous n'êtes pas sûr, choisissez oui.")
+  (inline-saved-program-in-executable/windows/path
+   "ATTENTION ! L'exécutable généré a besoin de trois DLLs : libmred.dll, libmzsch.gll et libgc.dll, qui sont localisées dans\n\n~a\n\nL'exécutable trouve les DLLs soit dans le répertoire ou se trouve l'exécutable soit en utilisant la variable d'environnement PATH.\n\nQuand vous avez installé DrScheme, l'installateur a modifié le PATH de l'utilisateur pour y inclure le répertoire dans lequel les DLLs se trouvent. Méfiez-vous des changements de configuration ou des changements faits par l'utilisateur depuis l'installation.\n\nSi vous déplacez l'exécutable sur une autre machine, vous devez également copier les DLLS sur l'autre machine, soit dans le même répertoire que l'exécutable, soit dans un répertoire qui figure dans le PATH sur l'autre machine.")
+  (launcher "Lanceur")
+  (stand-alone "Autonome")
+  (executable-type "Type")
+  (executable-base "Base")
+  (filename "Nom de fichier : ")
+  (create "Créer")
+  (please-choose-an-executable-filename "Veuillez sélectionner un nom de fichier pour sauvegarder l'exécutable.")
+  (windows-executables-must-end-with-exe
+   "Le nom de fichier\n\n  ~a\n\nest illégal. Sous Windows, le nom d'un exécutable doit se terminer par .exe.")
+  (macosx-executables-must-end-with-app
+   "Le nom de fichier\n\n  ~a\n\nest illégal. Sous MacOS X, le nom d'un exécutable doit se terminer par .app.")
+  (warning-directory-will-be-replaced
+   "ATTENTION : le répertoire :\n\n  ~a\n\nva être remplacé. Voulez-vous continuer ?")
+  
+  (create-servlet "Créer un servlet...") ;servlet = greffon, extension serveur?
+  
+  ; the ~a is a language such as "module" or "algol60"
+  (create-servlet-unsupported-language
+   "La création de servlets n'est pas possible avec le langage ~a.")
+  
+  ;;; buttons
+  (execute-button-label "Exécuter")
+  (save-button-label "Sauvegarder")
+  (break-button-label "Stopper")
+  
+  ;;; search help desk popup menu
+  (search-help-desk-for "Rechercher \"~a\" dans l'Aide.")
+  (exact-lucky-search-help-desk-for "Faire une recherche \"J'ai de la chance\" dans l'Aide pour le texte exact \"~a\".")
+  
+  ;; collapse and expand popup menu items
+  (collapse-sexp "Rétrécir une sexpression")
+  (expand-sexp "Elargir une sexpression")
+  
+  ;;; fraction dialog
+  (enter-fraction "Entrer une fraction")
+  (whole-part "Partie entière")
+  (numerator "Numérateur")
+  (denominator "Dénominateur")
+  (invalid-number "Nombre invalide : doit être un nombre réel exact non-entier.")
+  (insert-fraction-menu-item-label "Insérer une fraction...")
+  
+  ;; number snip popup menu
+  (show-decimal-expansion "Montrer l'expansion décimale")
+  (show-fraction-view "Montrer sous forme de fraction")
+  (show-mixed-fraction-view "Montrer sous forme partie-entière plus fraction")
+  (show-improper-fraction-view "Montrer sous forme de fraction")
+  (show-more-decimal-places "Montrer plus de décimales")
+  
+  ;;; Teachpack messages
+  (select-a-teachpack "Sélectionner un teachpack")
+  (clear-teachpack "Enlever le teachpack ~a")
+  (teachpack-error-label "DrScheme - erreur avec un teachpack.")
+  (teachpack-dne/cant-read "Le fichier teachpack ~a n'existe pas ou n'est pas lisible.")
+  (teachpack-didnt-load "Le fichier teachpack ~a n'a pas été correctement chargé.")
+  (teachpack-error-invoke "Le fichier teachpack ~a a produit une erreur au moment de son invocation.")
+  (add-teachpack-menu-item-label "Ajouter un teachpack...")
+  (clear-all-teachpacks-menu-item-label "Enlever tous les teachpacks")
+  (drscheme-teachpack-message-title "DrScheme teachpack")
+  (already-added-teachpack "Le teachpack ~a a déjà été ajouté.")
+  
+  ;;; Language dialog
+  (introduction-to-language-dialog
+   "Veuillez sélectionner un langage. Un étudiant dans un cours d'introduction préférera le langage par défaut.")
+  (language-dialog-title "Configurer le langage")
+  (case-sensitive-label "Différentier les lettres majuscules des minuscules.")
+  (output-style-label "Style d'impression des résultats")
+  (constructor-printing-style "Constructeur")
+  (quasiquote-printing-style "Quasiquote")
+  (write-printing-style "write")
+  (print-printing-style "current-print")
+  (sharing-printing-label "Montrer le partage entre valeurs.")
+  (use-pretty-printer-label "Insérer des retours-chariots lors de l'impression des résultats.")
+  (input-syntax "Syntaxe d'entrée")
+  (dynamic-properties "Propriétés dynamiques")
+  (output-syntax "Syntaxe de sortie")
+  (no-debugging-or-profiling "Pas de débogage ou profilage") ; Profilage. Eurk...
+  (debugging "Débogage")
+  (debugging-and-profiling "Débogage et profilage")
+  (test-coverage "Couverture syntaxique de vos tests")
+  (whole/fractional-exact-numbers-label "Imprimer les nombres sous forme de fractions.")
+  (booleans-as-true/false-label "Imprimer les booléens sous forme true et false.")
+  (show-details-button-label "Montrer les détails")
+  (hide-details-button-label "Cacher les détails")
+  (choose-language-menu-item-label "Sélectionner le langage...")
+  (revert-to-language-defaults "Retourner aux valeurs par défaut pour le langage.")
+  (language-docs-button-label "Docs langages")
+  (fraction-style "Style de fractions")
+  (use-mixed-fractions "Fractions mêlées")
+  (use-repeating-decimals "Décimales répétitives")
+  (decimal-notation-for-rationals "Utiliser la notation décimale pour les nombres rationnels")
+  (please-select-a-language "Veuillez sélectionner un langage")
+  
+  
+  ;;; languages
+  (beginning-student "Etudiant niveau débutant")
+  (beginning-one-line-summary "define, cond, structs, constantes, et primitives")
+  (beginning-student/abbrev "Etudiant niveau débutant avec abréviations pour les listes")
+  (beginning/abbrev-one-line-summary "Débutant, avec impression des résultats dans le REPL sous forme de listes")
+  (intermediate-student "Etudiant niveau intermédiaire")
+  (intermediate-one-line-summary "Débutant plus portée lexicale")
+  (intermediate-student/lambda "Etudiant niveau intermédiaire, plus lambda")
+  (intermediate/lambda-one-line-summary "Intermédiaire plus fonctions d'ordre supérieur")
+  (advanced-student "Etudiant niveau avancé")
+  (advanced-one-line-summary "Intermédiaire plus lambda et mutation")
+  (full-language "Complet") ;; also in the HtDP languages section
+  (how-to-design-programs "How to Design Programs") ;; should agree with MIT Press on this one...
+  (r5rs-like-languages "R5RS et langages semblabes")
+  (pretty-big-scheme "Assez gros Scheme")
+  (pretty-big-scheme-one-line-summary "Graphique, plus de nombreuses bibliothèques standards")
+  (r5rs-lang-name "Standard (R5RS)")
+  (r5rs-one-line-summary "R5RS, de base")
+  (expander "Expanseur") ; compression, compresseur, compresser => expansion, expanseur, expanser (expandeur, expander fait trop franglais et expandion n'existe pas)
+  (expander-one-line-summary "Expanse les expressions au lieu de les évaluer")
+  (professional-languages "Langages professionnels")
+  (teaching-languages "Langages d'enseignement")
+  (experimental-languages "Langages expérimentaux")
+  
+  (module-language-one-line-summary "Langage avec module comme seule forme")
+  
+  
+  ;;; debug language
+  (unknown-debug-frame "[inconnu]")
+  (backtrace-window-title "Trace - DrScheme")
+  (files-interactions "les interactions de ~a") ;; filled with a filename
+  (current-interactions "interactions")
+  (current-definitions "définitions")
+  (mzscheme-w/debug "Textuel (MzScheme)")
+  (mzscheme-one-line-summary "PLT Scheme sans la bibliothèque graphique")
+  (mred-w/debug "Graphique (MrEd)")
+  (mred-one-line-summary "PLT Scheme plus la bibliothèque graphique")
+  
+  ;; profiling
+  (profiling-low-color "Bas")
+  (profiling-high-color "Elevé")
+  (profiling-choose-low-color "Sélectionnez une couleur pour Bas")
+  (profiling-choose-high-color "Sélectionnez une couleur pour Elevé")
+  (profiling "Profilage")
+  (profiling-example-text "(define (whee) (whee))")
+  (profiling-color-config "Gamme de couleurs pour le profil")
+  (profiling-scale "Echelle de couleurs pour le profil")
+  (profiling-sqrt "Racine Carrée")
+  (profiling-linear "Linéaire")
+  (profiling-square "Quadratique")
+  (profiling-number "Numbre d'appels de fonctions")
+  (profiling-time "Temps cumulatif")
+  (profiling-clear "Effacer le profil")
+  (profiling-update "Mettre à jour le profil")
+  (profiling-col-percent-time "% Temps")
+  (profiling-col-function "Fonction")
+  (profiling-col-name "Nom")
+  (profiling-col-time-in-msec "ms")
+  (profiling-col-calls "Appels de fonctions")
+  (profiling-show-profile "Montrer le profil")
+  (profiling-hide-profile "Cacher le profil")
+  (profiling-unknown-src "<< inconnu >>")
+  (profiling-no-information-available "Pas d'information de profilage disponible. Assurez vous que l'option de profilage ait été spécifiée pour ce langage et que vous ayez exécuté le programme.")
+  (profiling-clear? "Modifier le contenu de la fenêtre de définition invalide le profil. Voulez-vous continuer ?")
+  
+  ;; test coverage
+  (test-coverage-clear? "Modifier le contenu de la fenêtre de définition invalide l'information de couverture de vos tests. Voulez-vous continuer ?")
+  (test-coverage-clear-and-do-not-ask-again "Oui, et ne me demandez pas à nouveau")
+  (test-coverage-ask? "Demander à propos de l'invalidation de l'information de couverture des tests ?")
+  
+  ;; tracing
+  (tracing-enable-tracing "Traçage")
+  (tracing-show-tracing-window "Montrer le traçage")
+  (tracing-hide-tracing-window "Cacher le traçage")
+  (tracing-tracing-nothing-to-show "Aucun résultat de traçage n'est disponible. Assurez-vous que votre language supporte le traçage et que le traçage est en place")
+
+  ;;; repl stuff
+  (evaluation-terminated "Evaluation terminée.")
+  (evaluation-terminated-explanation
+   "Le thread d'évaluation n'est plus en exécution, toute évaluation est donc impossible jusqu'à la prochaine exécution.")
+  (last-stack-frame "Montrer le dernier appel de fonction sur la pile.")
+  (last-stack-frames "Montrer les derniers ~a appels de fonction sur la pile.")
+  (next-stack-frames "Montrer les ~a appels de fonction suivants sur la pile.")
+  
+  ;;; welcoming message in repl
+  (language "Langage")
+  (custom "personnalisé")
+  (teachpack "Teachpack")
+  (welcome-to "Bienvenue dans")
+  (version "version")
+  
+  ;;; kill evaluation dialog
+  (kill-evaluation? "Voulez-vous tuer l'évaluation ?")
+  (just-break "Simplement stopper")
+  (kill "Tuer")
+  (kill? "Tuer ?")
+  
+  ;;; version checker
+  ;; the next two are used in the initial wizard dialog.
+  ;; Note that vc-wizard-check-prompt can (should) have newlines so
+  ;; it will not make the dialog too wide.
+  (vc-wizard-check-note "La version des logiciels que vous êtes en train d'installer n'est peut-être pas la dernière.~nSi vous le voulez DrScheme peut regarder pour une version plus récente.")
+  (vc-wizard-check-button "Regarder !")
+  (vc-update-check "Vérification des mises à jour")
+  (vc-please-wait "Veuillez patienter")
+  (vc-connecting-version-server "Connexion au server de version de PLT en cours")
+  (vc-network-timeout "Expiration du compte-à-rebours lors de la connexion réseau")
+  (vc-cannot-connect "Impossible de se connecter au serveur de version de PLT")
+  (vc-network-failure "Erreur réseau")
+  (vc-old-binaries "Les fichiers binaires installés pour DrScheme (ou MzScheme) ne sont pas à jour")
+  (vc-binary-information-format "Version binaire installée : ~a (itération ~a)")
+  (vc-details-format "~a~nDétails :~n~a")
+  (vc-details-text "Détails :~n")
+  (vc-error-format "Erreur : ~a")
+  (vc-current-format "~a v.~a (itération ~a) est à jour")
+  (vc-update-format "~a v.~a (itération ~a) doit être remplacé par v.~a (itération ~a)")
+  (vc-binary-name "Binaire")
+  (vc-updates-available "Les mises à jour sont disponibles à")
+  (vc-latest-binary-information-format "Version la plus récente : ~a (itération ~a)")
+  (vc-update-dialog-title "Etat des mises à jour")
+  (vc-need-update-string "Un ou plusieurs des logiciels PLT installés doivent être mis à jour")
+  (vc-no-update-string "Tous les logiciels PLT installés sont à jour")
+  
+  ;; special menu
+  (special-menu "Spécial")
+  
+  ;; large semi colon letters
+  (insert-large-letters... "Insérer de grandes lettres...")
+  (large-semicolon-letters "Grandes lettres en points-virgules")
+  (text-to-insert "Texte à insérer")
+  
+  (module-browser-filename-format "Nom de fichier complet : ~a (~a lignes)")
+  (module-browser-root-filename "Nom de fichier de la racine : ~a")
+  (module-browser-font-size-gauge-label "Taille de la police")
+  (module-browser-progress-label "Avancement du navigateur de modules")
+  (module-browser-adding-file "Ajout du fichier : ~a...")
+  (module-browser-laying-out-graph-label "Tracer le graph")
+  (module-browser-open-file-format "Ouvrir ~a")
+  (module-browser "Navigateur de modules") ;; frame title
+  (module-browser... "Navigateur de modules...") ;; menu item title
+  (module-browser-error-expanding "Erreur durant l'expansion du programme :\n\n~a")
+  (module-browser-show-lib-paths "Montrer les fichiers chargés à l'aide de chemins de fichiers du type (lib ..)")
+  (module-browser-progress "Navigateur de modules : ~a") ;; prefix in the status line
+  (module-browser-compiling-defns "Navigateur de modules : compilation des définitions")
+  (module-browser-show-lib-paths/short "(require (lib ...))") ;; check box label in show module browser pane in drscheme window.
+  (module-browser-refresh "Rafraîchir") ;; button label in show module browser pane in drscheme window.
+  (module-browser-only-in-plt-and-module-langs
+   "Le navigateur de modules n'est disponible que pour les programmes écrits dans l'un des langages PLT ou dans le langage \"module\", et seulement pour les programmes qui contiennent des modules.")
+  (module-browser-name-length "Noms")
+  (module-browser-name-short "courts")
+  (module-browser-name-medium "moyens")
+  (module-browser-name-long "longs")
+  (module-browser-open-all "Ouvrir tous les fichiers montrés ici")
+  
+  (happy-birthday-matthias "Joyeux anniversaire, Matthias !")
+  (happy-birthday-matthew "Joyeux anniversaire, Matthew !")
+  (happy-birthday-shriram "Joyeux anniversaire, Shriram !")
+  
+  (mrflow-using-default-language-title "Langage par défaut utilisé")
+  (mrflow-using-default-language "Le langage actuellement utilisé n'a pas de table de types défini pour ses primitives. R5RS Scheme est utilisé à la place.")
+  (mrflow-button-title "Analyzer")
+  ;(mrflow-unknown-style-delta-error-title "Delta de Style de boîte inconnu")
+  ;(mrflow-unknown-style-delta-error "Delta de style de boîte inconnu : ~a")
+  (mrflow-coloring-error-title "Couleur inconnue")
+  (mrflow-coloring-error "Pas de style défini pour la couleur : ~a")
+  (mrflow-popup-menu-show-type "Montrer le type")
+  (mrflow-popup-menu-hide-type "Cacher le type")
+  (mrflow-popup-menu-show-errors "Montrer les erreurs")
+  (mrflow-popup-menu-hide-errors "Cacher les erreurs")
+  ;(mrflow-read-exception-title "Exception lecture")
+  ;(mrflow-read-exception "Exception durant la lecture : ~a")
+  ;(mrflow-syntax-exception-title "Exception syntaxique")
+  ;(mrflow-syntax-exception "Exception syntaxique : ~a")
+  ;(mrflow-unknown-exception-title "Exception inconnue")
+  ;(mrflow-unknown-exception "Exception inconnue : ~a")
+  ;(mrflow-language-primitives-error-title "Erreur pour les primitives du langage")
+  ;(mrflow-language-primitives-error "Mauvais nom de fichier pour la table des types des primitives du langage : ~a")
+  
+  (snips-and-arrows-popup-menu-tack-all-arrows "Coller toutes les flèches")
+  (snips-and-arrows-popup-menu-untack-all-arrows "Décoller toutes les flèches")
+  (snips-and-arrows-user-action-disallowed-title "Changements actuellement interdits")
+  (snips-and-arrows-user-action-disallowed "Les changements sont interdits dans les éditeurs qui contiennent des boîtes inserées par un outil.  Cachez toutes les boîtes avant de modifier le contenu de l'éditeur.")
+  ;(snips-and-arrows-changing-terms-warning-title "Changer les termes ne pourra être défait")
+  ;(snips-and-arrows-changing-terms-warning "Changer des termes dans un éditeur n'est pas une action qui peut être défaite. Vous pouvez soit annuler cette action, cacher les boîtes, et réessayer le changement, soit vous pouvez continuer le changement, auquel cas le changement ne pourra pas être défait (tous les autres changements effectués avant ou après pourront cependant toujours être défaits).")
+  (snips-and-arrows-hide-all-snips-in-editor "Cacher les boîtes de cet éditeur")
+  
+  (xml-tool-menu "XML")
+  (xml-tool-insert-xml-box "Insérer une boîte XML")
+  (xml-tool-insert-scheme-box "Insérer une boîte Scheme")
+  (xml-tool-insert-scheme-splice-box "Insérer une boîte Scheme à raccord")
+  (xml-tool-xml-box "Boîte XML")
+  (xml-tool-scheme-box "Boîte Scheme")
+  (xml-tool-scheme-splice-box "Boîte Scheme à raccord")
+  (xml-tool-switch-to-scheme "Changer pour une boîte Scheme")
+  (xml-tool-switch-to-scheme-splice "Changer pour une boîte Scheme à raccord")
+  (xml-tool-eliminate-whitespace-in-empty-tags
+   "Eliminer les espaces dans les délimiteurs vides")
+  (xml-tool-leave-whitespace-alone
+   "Laisser les espaces tel quel")
+  
+  (show-recent-items-window-menu-item "Montrer les fichiers récemment ouverts dans une fenêtre séparée")
+  (show-recent-items-window-label "Fichiers récemment ouverts")
+  (number-of-open-recent-items "Nombre de fichiers récents")
+  (switch-anyway "Changer de fichier quand même")
+  
+  (stepper-program-has-changed "Avertissement : le programme a été modifié.")
+  (stepper-program-window-closed "Avertissement : la fenêtre du programme a disparu.")
+  
+  (stepper-home "Début") ; Accueil?
+  (stepper-name "Stepper")
+  (stepper-language-level-message
+   "Le langage actuellement utilisé est \"~a\". Le Stepper ne fonctionne pour l'instant que pour les langages de \"~a\" à \"~a\"")
+  (stepper-button-label "Pas")
+  (stepper-previous-application "|< Application")
+  (stepper-previous "< Pas")
+  (stepper-next "Pas >")
+  (stepper-next-application "Application >|")
+  
+  
+  (wizard-next "Suivant")
+  (wizard-back "Précédent")
+  (wizard-finish "Fin")
+  
+  ;; warnings about closing a drscheme frame when the program
+  ;; might still be doing something interesting
+  (program-is-still-running "Le programme dans la fenêtre de définition est toujours en cours d'exécution. Fermer la fenêtre quand même ?")
+  (program-has-open-windows "Le programme dans la fenêtre de définition a d'autres fenêtres ouvertes. Fermer la fenêtre quand même ?")
+  
+  ;; ml-command-line-arguments is for the command line arguments
+  ;; label in the module language details in the language dialog.
+  (ml-command-line-arguments "Arguments de ligne de commande, sous forme d'un vecteur de chaînes de caractères (syntaxe de read)")
+
+  ;; ml-cp names are all for the module language collection path
+  ;; configuration. See the details portion of the language dialog
+  ;; for the module language (at the bottom).
+  (ml-cp-default-collection-path "<<chemins de répertoires pour les collections par défaut>>")
+  
+  ;; in std get-directory 
+  (ml-cp-choose-a-collection-path "Choisissez un chemin de répertoire pour une collection")
+  
+  ;; err msg when adding default twice
+  (ml-cp-default-already-present
+   "Les chemins de répertoires pour les collections par défaut sont déjà présents")
+  
+  ;; title of this section of the dialog (possibly the word
+  ;; `Collection' should not be translated)
+  (ml-cp-collection-paths "Chemins de répertoires pour les collections")
+  
+  ;; button labels
+  (ml-cp-add "Ajouter")
+  (ml-cp-add-default "Ajouter les chemins par défaut")
+  (ml-cp-remove "Enlever")
+  (ml-cp-raise "Monter")
+  (ml-cp-lower "Descendre")
+
+  ;; Profj
+  (profj-java "Java")
+  (profj-java-mode "mode Java")
+  (profj-java-mode-color-keyword "mot réservé")
+  (profj-java-mode-color-string "chaîne de caractères")
+  (profj-java-mode-color-literal "valeur litérale")
+  (profj-java-mode-color-comment "commentaire")
+  (profj-java-mode-color-error "erreur")
+  (profj-java-mode-color-identifier "identificateur") ; l'académie française ne reconnaît pas ce mot
+  (profj-java-mode-color-default "valeur par défaut")
+
+  (profj-insert-java-comment-box "Insérer une boite à commentaires Java")
+  (profj-insert-java-interactions-box "Insérer une boite à interactions Java")
+  
+  ;; The Test Suite Tool
+  ;; Errors
+  (test-case-empty-error "Test vide")
+  (test-case-too-many-expressions-error "Expressions trop nombreuses dans un test.")
+  (test-case-not-at-top-level "Test n'est pas à la racine") ; au premier niveau?
+  ;; Dr. Scheme window menu items
+  (test-case-insert "Insérer un test")
+  (test-case-disable-all "Invalider tous les tests")
+  (test-case-enable-all "Revalider tous les tests")
+  
+  ;; NOTE: The following three string constants are labels of the test-case fields. The width
+  ;;       of the field is determined by the length of the longest of the following three words.
+  ;;       if the words are too long the test case will take up too much horizontal room and
+  ;;       not look very good.
+  ;; This string is the label of the expression that is being tested in a test case.
+  (test-case-to-test "À tester")
+  ;; This string is the label of the expression that is the expected value of the to-test expression.
+  (test-case-expected "Attendu")
+  ;; This string is the label of the actual result of the to test expression.
+  (test-case-actual "Reçu")
+  (test-case-predicate "Prédicat")
+  (test-case-should-raise "Doit lever l'exception")
+  ;; The label of a field of the test-case that describes the expected error message of a test case
+  (test-case-error-message "Message d'erreur")
+
+  (test-case-menu-title "Test")
+  (test-case-switch-to-error-box "Changer pour une boîte de test d'erreur")
+  (test-case-switch-to-nonerror-box "Changer pour une boîte de test sans erreur")
+  (test-case-collapse "Escamoter le test")
+  (test-case-show-actual "Montrer la valeur")
+  (test-case-enable "Revalider le test")
+  (test-case-show-predicate "Montrer le predicat")
+  (test-case-show-error-message "Montrer le message d'erreur")
+  (test-case-convert-to-text "Convertir en texte")
+  
+  ;; Profj Boxes
+  (profjBoxes-empty-error "Interaction vide")
+  (profjBoxes-too-many-expressions-error "Expressions trop nombreuses dans un test")
+  (profjBoxes-interactions-label "Interactions")
+  (profjBoxes-bad-java-id-error "Identificateur Java malformé") ; l'académie française ne reconnaît pas ce mot
+  (profjBoxes-examples-label "Examples")
+  (profjBoxes-add-new-example-button "Ajouter un nouvel example")
+  (profjBoxes-type "Type")
+  ;; The Java identifier of an example of data
+  (profjBoxes-name "Nom")
+  (profjBoxes-value "Valeur")
+  (profjBoxes-insert-java-examples "Insérer des examples Java")
+  (profjBoxes-insert-java-interactions "Insérer des interactions Java")
+
+  ;; Slideshow
+  (slideshow-show-slideshow-panel "Montrer la sous-fenêtre Slideshow")
+  (slideshow-hide-slideshow-panel "Cacher la sous-fenêtre Slideshow")
+  (slideshow-freeze-picts "Geler ces images")
+  (slideshow-thaw-picts "Montrer les images sous la souris")
+  (slideshow-hide-picts "Montrer les boîtes nichées")
+  (slideshow-show-picts "Montrer les images")
+  (slideshow-cannot-show-picts "Il est impossible de montrer les images; exécutez d'abord le programme pour calculer les dimensions")
+  (slideshow-insert-pict-box "Insérer une boîte à image") ; vu a la tele!
+
+  ;; GUI Tool
+  (gui-tool-heading "Outil GUI") ; IGU is seldom used, "interface graphique" is too long
+  (gui-tool-before-clicking-message "Avant d'utiliser cet outil vous devez d'abord soit employer \"Insérer une GUI\" dans le menu \"Spécial\" pour insérer une GUI à la racine,soit sélectionner une GUI existante")
+  (gui-tool-show-gui-toolbar "Montrer la barre d'outils GUI")
+  (gui-tool-hide-gui-toolbar "Cacher la barre d'outils GUI")
+  (gui-tool-insert-gui "Insérer une GUI")  
+  ); "aâàbcçdeéêèëfghiîïjklmnoôpqrstuûùüvwxyz"
diff --git a/collects/string-constants/german-string-constants.ss b/collects/string-constants/german-string-constants.ss
new file mode 100644
index 0000000000..8b8fe66e3b
--- /dev/null
+++ b/collects/string-constants/german-string-constants.ss
@@ -0,0 +1,1181 @@
+(module german-string-constants "string-constant-lang.ss"
+
+ (is-this-your-native-language
+  "Ist Deutsch Ihre Muttersprache?")
+
+ (are-you-sure-you-want-to-switch-languages
+  "Dies wird die Sprache der DrScheme-Benutzeroberfläche ändern und erfordert einen Neustart von DrScheme.  Sind Sie sicher?")
+
+ (interact-with-drscheme-in-language "Deutsche Benutzeroberfläche für DrScheme")
+
+ (accept-and-quit "In Ordnung - Beenden")
+ (accept-and-exit "In Ordnung - Beenden")
+ ;;; general purpose (DrScheme is hereby a word in every language, by decree of Robby :)
+ (plt "PLT")
+ (drscheme "DrScheme")
+ (ok "OK")
+ (cancel "Absagen")
+ (abort "Abbrechen")
+ (untitled "Namenlos")
+ (untitled-n "Namenlos ~a")
+ (warning "Warnung")
+ (error "Fehler")
+ (close "Schließen") ;; as in, close an open window
+ (stop "Stop")
+ (&stop "&Stop") ;; for use in button and menu item labels, with short cut.
+ (are-you-sure-delete? "Sind Sie sicher, dass Sie ~a löschen wollen?") ;; ~a is a filename or directory name
+ (ignore "Ignorieren")
+ (revert "Änderungen rückgängig machen")
+
+ (dont-ask-again "Nicht wieder nachfragen (immer so wie jetzt)")
+
+ (web-materials "Verwandte Web-Seiten")
+ (tool-web-sites "Web-Seiten mit Tools")
+ (drscheme-homepage "DrScheme")
+ (plt-homepage "PLT")
+ (how-to-use-scheme "How to Use Scheme")
+ (teachscheme!-homepage "TeachScheme!")
+
+ ;;; bug report form
+ (cancel-bug-report? "Bug-Report verwerfen?")
+ (are-you-sure-cancel-bug-report?
+  "Sind Sie sicher, dass Sie diesen Bug-Report verwerfen wollen?")
+ (bug-report-form "Formular für Bug-Report")
+ (bug-report-field-name "Name")
+ (bug-report-field-email "Email")
+ (bug-report-field-summary "Zusammenfassung")
+ (bug-report-field-severity "Wie schlimm?")
+ (bug-report-field-class "Art")
+ (bug-report-field-priority "Priorität")
+ (bug-report-field-description "Beschreibung")
+ (bug-report-field-reproduce1 "Schritte, um das Problem zu")
+ (bug-report-field-reproduce2 "reproduzieren")
+ (bug-report-field-environment "Umgebung")
+ (bug-report-field-tools "Tools")
+ (bug-report-field-docs-installed "Installierte Dokumentation")
+ (bug-report-field-language "Sprachebene")
+ (bug-report-field-teachpacks "Teachpacks")
+ (bug-report-field-collections "Kollektionen")
+ (bug-report-field-human-language "Interaktionssprache")	;
+ (bug-report-field-version "Version")
+ (bug-report-synthesized-information "Generierte Information")  ;; dialog title
+ (bug-report-show-synthesized-info "Generierte Informationen anzeigen")	; (an)zeigen
+ (bug-report-submit "Abschicken")	
+ (bug-report-submit-menu-item "Bug-Report abschicken") ;; in Help Menu (drs & help desk)
+ (sending-bug-report "Bug-Report abschicken")
+ (error-sending-bug-report "Versendung des Bug-Reports fehlgeschlagen")
+ (error-sending-bug-report-expln "Ein Fehler ist beim Versenden des Bug-Reports aufgetreten. Falls Ihre Internet-Verbindung eigentlich funktioniert, besuchen Sie bitte:\n\n    http://bugs.plt-scheme.org/ \n\nund teilen Sie uns den Bug mit unserem Online-Formular mit. Wir bitten um Ihr Verständnis.\n\nDie Fehlermeldung lautet:\n~a")
+ (bug-report-sent "Bug-Report erfolgreich verschickt")
+ (bug-report-sent-detail "Wir danken für Ihren Bug-Report. Sie sollten innerhalb der nächsten 30 Minuten eine Bestätigung per Email bekommen. Falls nicht, schicken Sie eine Email an folgende Adresse: scheme@plt-scheme.org.")
+ (illegal-bug-report "Ungültiger Bug-Report")
+ (pls-fill-in-field "Bitte auch das \"~a\" Feld ausfüllen")
+ (malformed-email-address "Ungültige Email-Adresse")
+ (pls-fill-in-either-description-or-reproduce "Bitte füllen Sie entweder das Feld \"Beschreibung\" oder das Feld \"Schritte, um das Problem zu reproduzieren\" aus.")
+
+ ;;; check syntax
+ (check-syntax "Syntaxprüfung")
+ (cs-italic "Kursiv")
+ (cs-bold "Fett")
+ (cs-underline "Unterstrichen")
+ (cs-change-color "Farbe ändern")
+ (cs-tack/untack-arrow "Pfeil befestigen/lösen")
+ (cs-jump-to-next-bound-occurrence "Zum nächsten gebundenen Vorkommen springen")
+ (cs-jump-to-binding "Zu bindendem Vorkommen springen")
+ (cs-jump-to-definition "Zu Definition springen")
+ (cs-error-message "Fehlermeldung")
+ (cs-open-file "~a öffnen")
+ (cs-rename-var "~a umbenennen")
+ (cs-rename-id "Bezeichner umbenennen")
+ (cs-rename-var-to "~a umbenennen nach:")
+ (cs-name-duplication-error "Der neugewählte Name, ~s, ist hier schon gebunden.")
+ (cs-rename-anyway "Trotzdem umbenennen")
+ (cs-status-init "Syntaxprüfung: Umgebung für den User-Code initialisieren")
+ (cs-status-coloring-program "Syntaxprüfung: Ausdruck einfärben")
+ (cs-status-eval-compile-time "Syntaxprüfung: Compile-Time-Code ausführen")
+ (cs-status-expanding-expression "Syntaxprüfung: Ausdruck expandieren")
+ (cs-mouse-over-import "Bindung ~s importiert aus ~s")
+
+ (cs-lexical-variable "lexikalische Variable")
+ (cs-lexical-syntax "lexikalische Syntax")
+ (cs-imported-variable "importierte Variable")
+ (cs-imported-syntax "importierte Syntax")
+
+ ;;; info bar at botttom of drscheme frame
+ (collect-button-label "GC")
+ (read-only "Schreibgeschützt")
+ (read/write "Lesen/Schreiben")
+ (auto-extend-selection "Automatisch erweitern")
+ (overwrite "Ãœberschreiben")
+ (running "Programm läuft")
+ (not-running "Programm inaktiv")
+ 
+ ;;; misc
+ (welcome-to-something "Willkommen bei ~a")
+ 
+ ; this appears in the drscheme about box.
+ (welcome-to-drscheme-version/language "Willkommen bei DrScheme! (Version ~a, ~a)")
+
+ ; these appear on subsequent lines in the `Help|Welcome to DrScheme' dialog.
+ (welcome-to-drscheme "Willkommen bei DrScheme")
+ (version/language "Version ~a, ~a")
+
+ (goto-line "Springe zu Zeile")
+ (goto-line-invalid-number
+  "~a ist keine gültige Zeilennummer. Es muss eine ganze Zahl zwischen 1 und ~a sein.")
+ (goto-position "Springe zu Position")
+ (no-full-name-since-not-saved
+  "Die Datei hat noch keinen Namen, weil sie noch nicht abgespeichert wurde.")
+ (cannot-open-because-dne "Die Datei ~a kann nicht geöffnet werden, weil sie nicht existiert.")
+ (interactions-out-of-sync
+  "WARNUNG: Das Interaktionsfenster ist nicht mehr mit dem Definitionsfensters synchron. Bitte 'Ausführen' anklicken.")
+ (file-is-not-saved "Die Datei \"~a\" ist nicht gespeichert.")
+ (save "Speichern")
+ (please-choose-either "Bitte entweder \"~a\" oder \"~a\" wählen")
+ (close-anyway "Trotzdem schließen")
+ (clear-anyway "Trotzdem löschen")
+
+ (log-definitions-and-interactions "Definitionen and Interaktionen protokollieren...")
+ (stop-logging "Protokoll stoppen")
+ (please-choose-a-log-directory "Bitte wählen Sie ein Verzeichnis f?r das Protokoll")
+ (logging-to "Protokoll: ")
+ (erase-log-directory-contents "Inhalt von Protokoll-Verzeichnisses ~a löschen?")
+ (error-erasing-log-directory "Fehler beim Löschen des Protokoll-Verzeichnisses.\n\n~a\n")
+
+ ;; modes
+ (mode-submenu-label "Modi")
+ (scheme-mode "Scheme-Modus")
+ (text-mode "Text-Modus")
+
+ (scheme-mode-color-symbol "Symbol")
+ (scheme-mode-color-keyword "Schlüsselwort")
+ (scheme-mode-color-comment "Kommentar")
+ (scheme-mode-color-string "Zeichenkette")
+ (scheme-mode-color-constant "Literal")
+ (scheme-mode-color-parenthesis "Klammer")
+ (scheme-mode-color-error "Fehler")
+ (scheme-mode-color-other "Sonstiges")
+ (syntax-coloring-choose-color "Wählen Sie eine Farbe für ~a")
+ (preferences-colors "Farben")
+
+ (url "URL")
+ (url: "URL:")
+ (open-url... "URL öffnen...")
+ (open-url "URL öffnen")
+ (browse... "Brausen...")
+ (bad-url "Ungültige URL")
+ (bad-url:this "Ungültige URL: ~a")
+ 
+ ;; Help Desk
+ (help "Hilfe")
+ (help-desk "Hilfezentrum")
+ (plt:hd:search-results "Suchergebnisse")
+ (plt:hd:search "Suchen")
+ (plt:hd:search-for "Suchen nach")
+ (plt:hd:lucky "Glück gehabt!")
+ (plt:hd:feeling-lucky "Auf gut Glück")
+ (plt:hd:stop "Stop")   
+ (plt:hd:options "Optionen") 
+ (plt:hd:configure "Konfiguration")
+ (plt:hd:home "Hilfezentrum-Homepage") 
+ (plt:hd:show-manuals "Handbücher anzeigen") 
+ (plt:hd:send-bug-report "Bug-Report")
+ (plt:hd:query-bug-reports "Bug-Reports abfragen")
+ ; next 3 are popup menu choices in help desk search frame
+ (plt:hd:search-for-keyword "Stichworteintrag")
+ (plt:hd:search-for-keyword-or-index "Stichwort- oder Index-Eintrag")
+ (plt:hd:search-for-keyword-or-index-or-text "Stichwort- oder Index-Eintrag, oder Text")
+ (plt:hd:exact-match "Exakte Treffer")
+ (plt:hd:containing-match "Teilwort")
+ (plt:hd:regexp-match "über regulären Ausdruck")
+ (plt:hd:find-docs-for "Finde Dokumentation zu:")
+ (plt:hd:nothing-found-for-search-key "Nichts zu \"~a\" gefunden.")
+ (plt:hd:searching "Suche...")
+ (plt:hd:search-stopped "[Suche gestopt.]")
+ (plt:hd:search-stopped-too-many-matches "[Suche abgebrochen: zu viele Treffer]")
+ (plt:hd:nothing-found-for "Nichts zu ~a gefunden")
+ (plt:hd:error-finding-docs "Konnte die Dokumentation nicht finden.\n\n~a")
+ (plt:hd:and "und")
+ (plt:hd:refresh "aktualisieren")
+ (plt:hd:refresh-all-manuals "alle Handbücher aktualisieren")
+ (plt:hd:manual-installed-date "(installiert ~a)")
+ ; Help Desk configuration
+ (plt:hd:configuration "Konfiguration PLT-Hilfezentrum")
+ (plt:hd:no-frames "Ohne Frames")
+ (plt:hd:use-frames "Mit Frames")
+ (plt:hd:use-html-frames "Mit HTML-frames")
+ (plt:hd:search-pane-options "Optionen Such-Panel")
+ (plt:hd:height "Höhe")
+ (plt:hd:bg-color "Hintergrundfarbe")
+ (plt:hd:pixels "Pixel")
+ (plt:hd:text-color "Farbe Text")
+ (plt:hd:link-color "Farbe Links")
+ (plt:hd:text-sample "Text im Such-Panel erscheint in dieser Farbe")
+ (plt:hd:link-sample "Links im Such-Panel erscheinen in dieser Farbe")
+ (plt:hd:save-changes "Änderungen sichern")
+ (plt:hd:reset "Zurücksetzen")
+ (plt:hd:defaults "Werkseinstellungen")
+ (plt:hd:javascript-note
+    "Ihre Selektionen werden hier erscheinen, falls Sie Javascript eingeschaltet haben und einen aktuellen standardkompatiblen Brauser benutzen.")
+ ;; refreshing manuals
+ (plt:hd:refresh-downloading "~a herunterladen")
+ (plt:hd:refresh-installing "~a installieren")
+ (plt:hd:refresh-progress "Fortschritt beim Herunterladen von PLT-Handbuch")
+;; should not mention `SVN' (plt:hd:refresh-done "Aktualisierung der Handbücher aus SVN abgeschlossen")
+ (plt:hd:refresh-installation-log "Installations-Protokoll")
+ (plt:hd:refresh-stopped "PLT-Handbuch-Aktualisierung gestoppt")
+ (plt:hd:refreshing-manuals "Handbücher aktualisieren")
+ (plt:hd:refresh-downloading... "~a herunterladen...")
+ (plt:hd:refresh-deleting... "Alte Version von ~a löschen...")
+ (plt:hd:refresh-installing... "Neue Version von ~a installieren...")
+ (plt:hd:refresh-clearing-indicies "Gecachte Indizes löschen")
+ (plt:hd:refreshing-manuals-finished "Fertig.")
+ (plt:hd:about-help-desk "Ãœber das Hilfezentrum")
+ (plt:hd:help-desk-about-string
+  "Das Hilfezentrum ist die primäre Quelle für Information über die PLT-Software,insbesondere DrScheme, MzScheme und MrEd.\n\nVersion ~a\nCopyright (c) 1995-2003 PLT")
+ (plt:hd:help-on-help "Hilfe zur Hilfe")
+ (plt:hd:help-on-help-details "Hilfe zum Hilfezentrum finden Sie auf der Hilfezentrum-Hompage unter 'Help Desk'. (Um auf diese Homepage zu gelangen, drücken Sie den 'Home'-Knopf oben im Hilfezentrum.)")
+  (reload "Aktualisieren") ;; refresh the page in a web browser
+  (plt:hd:ask-about-separate-browser
+   "Sie haben einen Link selektiert, der ins Web zeigt. Wollen Sie die Seite im Hilfe-Brauser oder im externen Brauser anzeigen?")
+  (plt:hd:homebrew-browser "Hilfe-Brauser") ;; choice for the above string (in a button)
+  (plt:hd:separate-browser "Externer Brauser") ;; other choice for the above string (also in a button)
+  (plt:hd:external-link-in-help "Externe URLs im Hilfe-Brauser")
+  (plt:hd:use-homebrew-browser "Den Hilfe-Brauser für externe URLs benutzen")
+  (plt:hd:new-help-desk "Neues Hilfezentrum")
+  (plt:hd:teaching-manuals "Handbücher für Lehrende und Lernende")
+  (plt:hd:professional-manuals "Handbücher für Anwender")
+  (plt:hd:all-manuals "Alle Handbücher")
+
+  ;; in the Help Desk language dialog, title on the right.
+  (plt:hd:manual-search-ordering "Suchreihenfolge Handbuch")
+
+
+ ;; Help desk htty proxy
+ (http-proxy "HTTP-Proxy")
+ (proxy-direct-connection "Direkte Verbindung")
+ (proxy-use-proxy "Proxy benutzen:")
+ (proxy-host "Name")
+ (proxy-port "Port")
+ (proxy-bad-host "Unzulässiger Proxy")
+
+ ;; browser
+ (rewind-in-browser-history "Zurück")
+ (forward-in-browser-history "Vor")
+ (home "Home")
+ (browser "Brauser")
+ (external-browser-choice-title "Externer Brauser")
+ (browser-command-line-label "Kommandzeile:")
+ (choose-browser "Brauser auswählen")
+ (no-browser "Später")
+ (use-internal-browser-for-help "Hilfe mit internem PLT-Brauser lesen")
+ (use-external-browser-for-help "Hilfe mit externam Brauser lesen")
+ (browser-cmdline-expl-line-1 "(Kommandozeile konstruiert durch Aneinanderhängen von Vor-Text, URL,")
+ (browser-cmdline-expl-line-2 " und Nach-Text, ohne zusätzliche Leerzeichen dazwischen.")
+ (cannot-display-url "Kann URL ~s nicht anzeigen: ~a")
+ (install? "Installieren?")  ;; if a .plt file is found (title of dialog)
+ (you-have-selected-an-installable-package "Sie haben eine installierbares Paket angewählt.")
+ (do-you-want-to-install-it? "Wollen Sie es installieren?")
+ (paren-file-size "(Die Datei hat ~a Bytes)")
+ (download-and-install "Herunterladen && installieren") ;; button label
+ (download "Herunterladen") ;; button label
+ (save-downloaded-file/size "Datei (~a Bytes) speichern als") ;; label for get-file dialog
+ (save-downloaded-file "Datei speichern als")  ;; label for get-file dialog
+ (downloading "Herunterladen") ;; dialog title
+ (downloading-file... "Datei herunterladen...")
+ (package-was-installed "Das Paket wurde erfolgreich installiert.")
+ (download-was-saved "Die Datei wurde erfolgreich gespeichert.")
+ (getting-page "Seite laden") ;; dialog title
+
+ (install-plt-file-menu-item... ".plt-Datei installieren...")
+ (install-plt-file-dialog-title ".plt-Datei installieren")
+ (install-plt-web-tab "Web")
+ (install-plt-file-tab "Datei")
+ (install-plt-filename "Dateiname:")
+ (install-plt-url "URL:")
+  
+ (install-plt-file "~a installieren oder editieren?")
+ (install-plt-file/yes "Installieren")
+ (install-plt-file/no "Editieren")
+ 
+ (plt-installer-progress-window-title "Fortschritt Installation")
+ (plt-installer-abort-installation "Installation abbrechen")
+ (plt-installer-aborted "Abgebrochen.")
+  
+ ;;; about box
+ (about-drscheme-frame-title "Ãœber DrScheme")
+ (take-a-tour "Nehmen Sie die Führung!")
+ (release-notes "Release-Notes")
+ (parenthetical-last-version "(vorige Version ~a)")
+ (parenthetical-last-language "(vorige Sprache ~a)")
+ (parenthetical-last-version/language "(vorige Version ~a, Sprache ~a)")
+ 
+ 
+ ;;; save file in particular format prompting.
+ (save-as-plain-text "Diese Datei als Text speichern?")
+ (save-in-drs-format "Diese Datei im DrScheme-Format (kein Text) speichern?")
+ (yes "Ja")
+ (no "Nein")
+ 
+ ;;; preferences
+ (preferences "Einstellungen")
+ (saving-preferences "Einstellungen werden gesichert")
+ (error-unmarshalling "Fehler beim Lesen der Einstellung für ~a")
+ (error-saving-preferences "Fehler beim Speichern der Einstellungen für ~a")
+ (error-reading-preferences "Fehler beim Lesen der Einstellungen")
+ (expected-list-of-length2 "Eine Liste mit zwei Elementen erwartet")
+ (scheme-prefs-panel-label "Scheme")
+ (warnings-prefs-panel-label "Warnmeldungen")
+ (editor-prefs-panel-label "Editieren")
+ (general-prefs-panel-label "Allgemein")
+ (highlight-parens "Geklammerten Text hervorheben")
+ (fixup-parens "Klammern korrigieren")
+ (flash-paren-match "Passende Klammer anblinken")
+ (auto-save-files "Dateien automatisch abspeichern")
+ (backup-files "Backup-Dateien")
+ (map-delete-to-backspace "Entf löscht rückwärts")
+ (verify-exit "Bei Verlassen nachfragen")
+ (ask-before-changing-format "For Formatänderung beim Speichern nachfragen")
+ (wrap-words-in-editor-buffers "Worte in Editor-Puffern umbrechen")
+ (show-status-line "Status-Zeile anzeigen")
+ (count-columns-from-one "Spaltennummern fangen mit 1 an")
+ (display-line-numbers "Zeilennummern in Puffern anzeigen, keine Puffer-Indizes")
+ (enable-keybindings-in-menus "Tastenbelegung für Menüs")
+ (automatically-to-ps "Automatisch in PostScript-Datei drucken")
+ (option-as-meta "Option-Taste als Mera behandeln") ;; macos/macos x only
+ (use-mdi "MDI-Fenster verwenden") ;;; ms windows only -- use that window in a window thingy
+ (separate-dialog-for-searching "Für Textsuche separaten Dialog verwenden")
+ (reuse-existing-frames "Existierende Fenster für neu geöffnete Dateien wiederverwenden")
+ (default-fonts "Standard-Fonts")
+ (paren-match-color "Farbe für Klammern-Hervorhebung") ; in prefs dialog
+ (choose-color "Farbe auswählen") ; in prefs dialog
+ (online-coloring-active "Syntax interaktiv einfärben")
+ (open-files-in-tabs "Dateien in separaten Tabs öffnen (nicht separaten Fenstern)")
+ (show-interactions-on-execute "Interaktionen beim Programmstart automatisch öffnen")
+ (limit-interactions-size "Umfang der Interaktionen einschränken")
+ (background-color "Hintergrundfarbe")
+ (default-text-color "Standard für Text") ;; used for configuring colors, but doesn't need the word "color"
+ (choose-a-background-color "Hintergrundfarbe auswählen")
+
+ ; title of the color choosing dialog
+ (choose-paren-highlight-color "Farbe für Klammerhervorhebung wählen")
+
+ ; should have entire alphabet
+ (font-example-string "Zwölf Boxkämpfer jagen Victor quer über den großen Sylter Deich.") 
+
+ (change-font-button-label "Ändern")
+ (fonts "Schriften")
+
+ ; filled with type of font, eg modern, swiss, etc.
+ (choose-a-new-font "Neuen Font für \"~a\" wählen")
+
+ (font-size-slider-label "Größe")
+ (restart-to-see-font-changes "Neu starten, damit die Schriftänderung wirksam wird")
+
+ (font-prefs-panel-title "Schriftart")
+ (font-name "Name Schriftart")
+ (font-size "Größe Schriftart")
+ (set-font "Schriftart setzen...")
+ (font-smoothing-label  "Weiche Kanten bei Schrift")
+ (font-smoothing-none "Nicht")
+ (font-smoothing-some "Bißchen")
+ (font-smoothing-all "Total")
+ (font-smoothing-default "System-Einstellung verwenden")
+ (select-font-name "Schriftart-Name auswählen")
+ (example-text "Beispieltext:")
+ (only-warn-once "Nur einmal warnen, wenn Definitionen und Interaktionen nicht synchron sind")
+ 
+ ; warning message when lockfile is around
+ (waiting-for-pref-lock "Auf Lock-Datei für Einstellungen warten...")
+ (pref-lock-not-gone
+  "Die Lock-Datei für die Einstellungen:\n\n   ~a\n\nverhindert, dass die Einstellungen abgespeichert werden können. Bitte stellen Sie sicher, dass keine andere PLT-Software läuft und löschen Sie dann diese Datei.")
+ (still-locked-exit-anyway? "Die Einstellungen wurden nicht korrekt gespeichert.  Trotzdem beenden?")
+ 
+ ;;; indenting preferences panel
+ (indenting-prefs-panel-label "Einrücken")
+ (indenting-prefs-extra-regexp "Zusätzlicher Regexp")
+
+ ; filled with define, lambda, or begin
+ (enter-new-keyword "Bitte ein Schlüsselwort wie ~a eingeben:")
+ (x-keyword "~a-Schlüsselwort")
+ (x-like-keywords "Schlüsselwort wie ~a")
+
+ (expected-a-symbol "Symbol erwartet, stattdessen bekommen: ~a")
+ (already-used-keyword "\"~a\" ist bereits ein Schlüsselwort mit Spezial-Einrückung")
+ (add-keyword "Hinzufügen")
+ (remove-keyword "Entfernen")
+ 
+ ;;; find/replace
+ (find-and-replace "Suchen und Ersetzen")
+ (find "Suchen")
+ (replace "Ersetzen")
+ (dock "Andocken")
+ (undock "Ablegen")
+ (use-separate-dialog-for-searching "Separaten Dialog für Suchen verwenden")
+ (replace&find-again "Nochmals Suchen && Ersetzen") ;;; need double & to get a single &
+ (replace-to-end "Ersetzen bis zum Ende")
+ (forward "Vorwärts")
+ (backward "Rückwärts")
+ (hide "Ausblenden")
+ 
+ ;;; multi-file-search
+ (mfs-multi-file-search-menu-item "In Dateien suchen...")
+ (mfs-string-match/graphics "per Text (auch in Dateien mit Grafik)")
+ (mfs-regexp-match/no-graphics "per regulärem Ausdruck (nur reine Textdateien)")
+ (mfs-searching... "Suche...")
+ (mfs-configure-search "Einstellungen Suche") ;; dialog title
+ (mfs-files-section "Dateien")   ;; section in config dialog
+ (mfs-search-section "Suche") ;; section in config dialog
+ (mfs-dir "Verzeichnis")
+ (mfs-recur-over-subdirectories "In Unterverzeichnisse abtauchen")
+ (mfs-regexp-filename-filter "Regulärer Ausdruck Dateinamen-Filter")
+ (mfs-search-string "Zeichenkette suchen")
+ (mfs-drscheme-multi-file-search "DrScheme - Suche in mehreren Dateien") ;; results window and error message title
+ (mfs-not-a-dir "\"~a\" ist kein Verzeichnis")
+ (mfs-open-file "Datei öffnen")
+ (mfs-stop-search "Suche stoppen")
+ (mfs-case-sensitive-label "Groß-/Kleinschreibung beachten")
+ (mfs-no-matches-found "Keine Treffer gefunden.")
+ (mfs-search-interrupted "Suche abgebrochen.")
+ 
+ ;;; reverting a file
+ (error-reverting "DrScheme - Fehler beim Wiederherstellen")
+ (could-not-read "Konnte \"~a\" nicht lesen")
+ (are-you-sure-revert
+  "Sind Sie sicher, dass Sie diese Datei wiederherstellen wollen? Diese Operation kann nicht rückgängig gemacht werden.")
+ (are-you-sure-revert-title
+  "Wiederherstellen?")
+ 
+ ;;; saving a file
+ ; ~a is filled with the filename
+ (error-saving "Fehler beim Speichern") ;; title of error message dialog
+ (error-saving-file/name "Fehler beim Speichern von ~a")
+ (error-loading "Fehler beim Laden")
+ (error-loading-file/name "Fehler beim Laden von ~a.")
+ (unknown-filename "<< unbekannt >>")
+
+ ;;; finder dialog
+ (must-specify-a-filename "Sie müssen einen Dateinamen angeben")
+ (file-does-not-exist "Die Datei \"~a\" existiert nicht.")
+ (ask-because-file-exists "Die Datei \"~a\" existiert schon. Ersetzen?")
+ (dne-or-cycle "Der Dateiname \"~a\" enthält ein nicht existentes Verzeichnis oder einen Zyklus.")
+ (get-file "Datei lesen")
+ (put-file "Datei schreiben")
+ (full-pathname "Gesamter Dateiname")
+ (show-dot-files "Dateien und Verzeichnisse anzeigen, die mit einem Punkt anfangen.")
+ (up-directory-button-label "Verzeichnis nach oben")
+ (add-button-label "Hinzufügen") ;;; for multi-file selection
+ (add-all-button-label "Alle hinzufügen") ;;; for multi-file selection
+ (remove-button-label "Entfernen") ;;; for multi-file selection
+ (file-wrong-form "Der Dateiname hat nicht die richtige Form.")
+ (select-files "Dateien auswählen")
+ (select-file "Datei auswählen")
+ (dir-dne "Das Verzeichnis existiert nicht.")
+ (file-dne "Die Datei existiert nicht.")
+ (empty-filename "Der Dateiname muss Buchstaben enthalten.")
+ (that-is-dir-name "Dieser Name gehört zu einem Verzeichnis.")
+ 
+ ;;; raw menu names -- these must match the 
+ ;;; versions below, once the &s have been stripped.
+ ;;; if they don't, DrScheme's menus will appear
+ ;;; in the wrong order.
+ (file-menu "Datei")
+ (edit-menu "Bearbeiten")
+ (help-menu "Hilfe")
+ (windows-menu "Fenster")
+ 
+ ;;; menus
+ ;;; - in menu labels, the & indicates a alt-key based shortcut.
+ ;;; - sometimes, things are stuck in the middle of 
+ ;;; menu item labels. For instance, in the case of
+ ;;; the "Save As" menu, you might see: "Save Definitions As". 
+ ;;; be careful of spacing, follow the English, if possible.
+ ;;; - the ellipses in the `after' strings indicates that
+ ;;; more information is required from the user before completing
+ ;;; the command.
+
+ (file-menu-label "&Datei")
+
+ (new-info  "Neue Datei öffnen")
+ (new-menu-item "&Neu")
+ (new-...-menu-item "&Neu...")
+
+ (open-info "Datei öffnen")
+ (open-menu-item "&Öffnen...")
+ (open-here-menu-item "Hier &öffnen...")
+
+ (open-recent-info "Liste kürzlich bearbeiteter Dateien")
+ (open-recent-menu-item "Öffne noch einmal")
+ 
+ (revert-info "Stelle diese Datei wieder her wie zuletzt gespeichert")
+ (revert-menu-item "&Wiederherstellen")
+
+ (save-info "Diese Datei auf der Platte speichern")
+ (save-menu-item "&Speichern")
+
+ (save-as-info "Dateinamen abfragen und dann Datei auf der Platte speichern")
+ (save-as-menu-item "Speichern &unter...")
+
+ (print-info "Diese Datei zum Drucker schicken")
+ (print-menu-item "&Drucken...")
+
+ (close-info "Diese Datei schließen")
+ (close-menu-item "&Schließen")
+
+ (quit-info "Alle Fenster schließen")
+ (quit-menu-item-windows "Be&enden")
+ (quit-menu-item-others "&Beenden")
+ 
+ (edit-menu-label "&Bearbeiten")
+ 
+ (undo-info "Letzte Aktion rückgängig machen")
+ (undo-menu-item "&Rückgängig")
+
+ (redo-info "Letzte Rückgängig-Operation rückgängig machen")
+ (redo-menu-item "&Nochmal")
+
+ (cut-info "Verschiebe die Selektion ins Clipboard, um sie später wieder einfügen zu können")
+ (cut-menu-item "&Ausschneiden")
+
+ (copy-info "Kopiere die Selektion ins Clipboard, um sie später wieder einfügen zu könne")
+ (copy-menu-item "&Kopieren")
+
+ (paste-info "Ersetze die aktuelle Selektion durch die zuletzt kopierte oder ausgeschnittene Selektion")
+ (paste-menu-item "&Einfügen")
+
+ (clear-info "Lösche die Selektion, ohne das Clipboard dabei zu ändern oder etwas einzufügen")
+ (clear-menu-item-others "Löschen")
+ (clear-menu-item-windows "&Löschen")
+
+ (select-all-info "Selektiere das gesamte Dokument")
+ (select-all-menu-item "&Alles selektieren")
+ 
+ (find-info "Suche eine Zeichenkette")
+ (find-menu-item "Suche...")
+
+ (find-again-info "Suche die gleiche Zeichenkette nochmal")
+ (find-again-menu-item "Suche nochmal")
+ 
+ (replace-and-find-again-info "Ersetze den aktuellen Text und suche dann das gleiche nochmal")
+ (replace-and-find-again-menu-item "Ersetzen && nochmal suchen")
+
+ (preferences-info "Konfiguriere die Einstellungen")
+ (preferences-menu-item "Einstellungen...")
+
+ (keybindings-info "Aktuelle Tastaturbelegung anzeigen")
+ (keybindings-menu-item "Tastaturbelegung")
+ (keybindings-show-active "Aktive Tastenbelegungen anzeigen")
+ (keybindings-frame-title "Tastaturbelegung")
+ (keybindings-sort-by-name "Nach Name sortieren")
+ (keybindings-sort-by-key "Nach Taste sortieren")
+ (keybindings-add-user-defined-keybindings "Benutzerdefinierte Tastenbelegungen hinzufügen...")
+ (keybindings-menu-remove "~a entfernen")
+ (keybindings-choose-user-defined-file "Bitte eine Datei mit den Tastenbelegungen auswählen.")
+
+ (user-defined-keybinding-error "Fehler beim Ausführen der Tastenbelegung ~a\n\n~a")
+ (user-defined-keybinding-malformed-file "Die Datei ~a enthält kein Modul, das in der Sprache (lib \"keybinding-lang.ss\" \"framework\") geschrieben ist.")  
+
+ ;; menu items in the "special" menu
+ (insert-text-box-item "Text-Kasten einfügen")
+ (insert-pb-box-item "Pinwand-Kasten einfügen")
+ (insert-image-item "Bild einfügen...")
+ (insert-comment-box-menu-item-label "Kommentarkasten einfügen")
+ (insert-lambda "&Lambda einfügen")
+ (insert-delta "&Delta (define) einfügen")
+
+ (wrap-text-item "Text umbrechen")
+
+ (windows-menu-label "&Fenster")
+ (bring-frame-to-front "Fenster nach vorn")       ;;; title of dialog
+ (bring-frame-to-front... "Fenster nach vorn...") ;;; corresponding title of menu item
+ (next-window "Nächstes Fenster")
+ (previous-window "Voriges Fenster")
+ (most-recent-window "Letztes Fenster")
+
+ (view-menu-label "&Anzeigen")
+ (show-overview "Programm-Umriss einblenden") 
+ (hide-overview "Programm-Umriss ausblenden")
+ (show-module-browser "Modul-Brauser einblenden")
+ (hide-module-browser "Modul-Brauser ausblenden")
+
+ (help-menu-label "&Hilfe")
+ (about-info "Mehr über dieses Programm und seine Entstehung")
+ (about-menu-item "Ãœber...")
+ (help-menu-check-for-updates "Nach Updates schauen...")
+ 
+ ;; open here's new menu item
+ (create-new-window-or-clear-current
+  "Würden Sie gern ein neues Fenster aufmachen oder dieses hier löschen und wiederverwenden?")
+ (clear-current "Dieses löschen")
+ (new-window "Neues Fenster")
+
+ ;;; exiting and quitting ``are you sure'' dialog
+ ;;; exit is used on windows, quit on macos, in English. Other
+ ;;; languages probably use the same word on both platforms.
+ (exit "Beenden")
+ (quit "Beenden")
+ (are-you-sure-exit "Sind Sie sicher, dass Sie das Programm beenden wollen?")
+ (are-you-sure-quit "Sind Sie sicher, dass Sie das Programm beenden wollen?")
+ 
+ ;;; autosaving
+ (error-autosaving "Fehler beim automatischen Speichern von \"~a\".") ;; ~a will be a filename
+ (autosaving-turned-off "Automatisches Speichern abgeschaltet\nbis die Datei wieder gespeichert wird.")
+ (recover-autosave-files-frame-title "Automatisch gespeicherte Dateien zurückholen")
+ (autosave-details "Details")
+ (autosave-recover "Zurückholen")
+ (autosave-unknown-filename "<<unbekannt>>")
+  
+  ;; these are labels in a dialog that drscheme displays
+  ;; if you have leftover autosave files. to see the dialog,
+  ;; start up drscheme and modify (but don't save) a file
+  ;; (also, do this with an unsaved file). Wait for the autosave
+  ;; files to appear (typically 5 minutes). Kill DrScheme
+  ;; and restart it. You'll see the dialog
+  (autosave-autosave-label: "Automatisch gespeicherte Datei:")
+  (autosave-original-label: "Ursprüngliche Datei:")
+  (autosave-autosave-label "Automatisch gespeicherte Datei")
+  (autosave-original-label "Ursprüngliche Datei")
+  (autosave-compare-files "Automatisch gespeicherte Dateien vergleichen")
+
+  (autosave-show-autosave "Automatisch gespeicherte Datei") ;; title of a window showing the autosave file
+
+  (autosave-explanation "DrScheme hat automatisch gespeicherte Dateien gefunden, die nicht regulär gespeicherten Inhalt enthalten könnten.")
+
+  (autosave-recovered! "Zurückgeholt!") ;; status of an autosave file
+  (autosave-deleted "Gelöscht")       ;; status of an autosave file
+
+  (autosave-error-deleting "Fehler beim Löschen von ~a\n\n~a") ;; first is a filename, second is an error message from mz.
+  (autosave-delete-button "Löschen")
+  (autosave-delete-title "Löschen")  ;; title of a dialog asking for deletion confirmation
+  (autosave-done "Fertig")
+  
+  ;; appears in the file dialog
+  (autosave-restore-to-where? "Bestimmen Sie, wo die automatisch gespeicherte Datei hin zurückgeholt werden soll")
+  
+  
+ ;;; file modified warning
+ (file-has-been-modified
+  "Die Datei wurde verändert, seit sie das letzte Mal gespeichert wurde. Änderungen überschreiben?")
+ (overwrite-file-button-label "Ãœberschreiben")
+ 
+ (definitions-modified 
+  "Die Definitionen wurden auf der Platte geändert; bitte speichern sie die Definitionen oder holen Sie diese von der Platte zurück.")
+ (drscheme-internal-error "Interner Fehler in DrScheme")
+ 
+ ;;; tools
+ (invalid-tool-spec "Die Tool-Spezifikation in der Datei info.ss der Kollektion ~a enthält Fehler. Da sollte eine Zeichenkette oder eine Liste von Zeichenketten stehen, tatsächlich steht dort aber: ~e")
+ (error-loading-tool-title "DrScheme - Fehler beim Laden von ~s; ~s")
+ (error-invoking-tool-title "Fehler beim Starten von Tool ~s;~s")
+ (tool-tool-names-same-length
+  "`tool-names' und `tools' in info.ss für ~s müssen Listen der gleichen Länge sein, tatsächlich stehen dort ~e und ~e")
+ (tool-tool-icons-same-length
+  "`tool-icons' und `tools' in info.ss für ~s müssen Listen der gleichen Länge sein, tatsächlich stehen dort ~e und ~e")
+ (tool-tool-urls-same-length
+  "`tool-urls' und `tools' in info.ss für ~s müssen Listen der gleichen Länge sein, tatsächlich stehen dort ~e und ~e")
+ (error-getting-info-tool
+  "Fehler beim Laden von info.ss file für ~s")
+ (tool-error-phase1 "Fehler in Phase 1 von Tool ~s; ~s")
+ (tool-error-phase2 "Fehler in Phase 2 von Tool ~s; ~s")
+
+
+ ;;; define popup menu
+ (end-of-buffer-define "<< Text-Ende >>")
+ (sort-by-name "Nach Namen Sortieren")
+ (sort-by-position "Nach Position in der Datei sortieren")
+ (no-definitions-found "<< keine Definitionen gefunden>>")
+ (jump-to-defn "Zur Definition von ~a springen")
+
+ (recent-items-sort-by-age "Nach Alter sortieren")
+ (recent-items-sort-by-name "Nach Name sortieren")
+ 
+ ;;; view menu
+ (hide-definitions-menu-item-label "&Definitionen ausblenden")
+ (show-definitions-menu-item-label "&Definitionen einblenden")
+ (definitions-menu-item-help-string "Definitionsfenster ein-/ausblenden")
+ (show-interactions-menu-item-label "&Interaktionen einblenden")
+ (hide-interactions-menu-item-label "&Interaktionen ausblenden")
+ (interactions-menu-item-help-string "Interaktionsfenster ein-/ausblenden")
+ (show-toolbar "&Toolbar einblenden")
+ (hide-toolbar "&Toolbar ausblenden")
+
+ ;;; file menu
+ (save-definitions-as "Definitionen speichern unter...")
+ (save-definitions "Definitionen speichern")
+ (print-definitions "Definition drucken...")
+ (about-drscheme "Ãœber DrScheme")
+ (save-other "Speichern unter")
+ (save-definitions-as-text "Definitionen als Text speichern...")
+ (save-interactions "Interaktionen speichern")
+ (save-interactions-as "Interaktionen speichern unter...")
+ (save-interactions-as-text "Interaktionen als Text speichern...")
+ (print-interactions "Interaktionen drucken...")
+ (new-tab "Neuer Tab")
+ (close-tab "Tab schließen")
+ 
+ ;;; edit-menu
+ (split-menu-item-label "&Splitten")
+ (collapse-menu-item-label "Einfalten")
+ 
+ ;;; language menu
+ (language-menu-name "&Sprache")
+ 
+ ;;; scheme-menu
+ (scheme-menu-name "S&cheme")
+ (execute-menu-item-label "Start")
+ (execute-menu-item-help-string "Das Programm im Definitionsfenster neu starten")
+ (break-menu-item-label "Stop")
+ (break-menu-item-help-string "Momentane Auswertung unterbrechen")
+ (kill-menu-item-label "Abbrechen")
+ (kill-menu-item-help-string "Momentante Auswertung abbrechen")
+ (clear-error-highlight-menu-item-label "Fehlermarkierung entfernen")
+ (clear-error-highlight-item-help-string "Entfernt die rosa Fehlermarkierung")
+ (reindent-menu-item-label "&Einrücken")
+ (reindent-all-menu-item-label "&Alles einrücken")
+ (semicolon-comment-out-menu-item-label "Mit Semikolon auskommentieren")
+ (box-comment-out-menu-item-label "Mit Kommentar-Kasten auskommentieren")
+ (uncomment-menu-item-label "Einkommentieren")
+
+ (convert-to-semicolon-comment "In Semikolon-Kommentar umwandeln")
+ 
+ ;;; executables
+ (create-executable-menu-item-label "Programmdatei generieren...")
+ (create-executable-title "Programmdatei generieren")
+ (must-save-before-executable "Sie müssen vor der Generierung einer Programmdatei speichern.")
+ (save-an-executable "Programmdatei speichern")
+ (save-a-mred-launcher "MrEd-Launcher speichern")
+ (save-a-mzscheme-launcher "MzScheme-Launcher speichern")
+ (save-a-mred-stand-alone-executable "MrEd-Stand-Alone-Programmdatei speichern")
+ (save-a-mzscheme-stand-alone-executable "MzScheme-Stand-Alone-Programmdatei speichern")
+
+ (definitions-not-saved "Die Definitionen sind nicht gespeichert. Die Programmdatei wird von der letzten gespeicherten Version gezogen. Weitermachen?")
+ (inline-saved-program-in-executable?
+  "Scheme-Code in das Programm einbinden? Dann könnten Sie die Programmdatei zu einem anderen ~a-Computer transferieren, aber die Programmdatei wird dann ziemlich groß. Falls nicht, können Sie die Programmdatei nicht transferieren, aber sie wird deutlich kleiner. Außerdem wird die Programmdatei dann die jeweils neueste Version des Scheme-Codes benutzen.")
+ (use-mred-binary?
+  "MrEd für diese Programmdatei verwenden?\n\nFalls ja, kann das Programm die Bibliothek (lib \"mred.ss\" \"mred\") verwenden. Falls nein, wird DrScheme MzScheme verwenden - dann kann das Programm die Bibliothek nicht verwenden.n\nFalls Sie nicht sicher sind, wählen Sie \"ja\".")
+ (inline-saved-program-in-executable/windows/path
+   "WARNUNG! Die generierte Programmdatei benötigt drei DLLs: libmred.dll, libmzsch.gll und libgc.dll, die sich in folgendem Verzeichnis befinden:\n\n~a\n\nDie Programmdatei findet DLLs entweder im selben Verzeichnis wie die Programmdatei selbst oder durch die Umgebungsvariable PATH.\n\nAls Sie DrScheme installierten, hat der Installer PATH derart verwändert, dass das DLL-Verzeichnis dabei ist. Diese Einstellung könnte seitdem geändert worden sein.\n\nFalls Sie die Programmdatei auf eine andere Maschine tranferieren, müssen Sie die DLLs ebenfalls transferieren - entweder in das gleiche Verzeichnis wie die Programmdatei oder in ein Verzeichnis im PATH der anderen Maschine.")
+ (launcher "Launcher")
+ (stand-alone "Stand-alone")
+ (executable-type "Typ")
+ (executable-base "Hauptteil")
+ (filename "Dateiname: ")
+ (create "Erzeugen")
+ (please-choose-an-executable-filename "Bitte Dateinamen für Programm auswählen")
+ (windows-executables-must-end-with-exe
+  "Der Dateiname\n\n  ~a\n\nist unzulässig. Unter Windows müssen Programmdateien mit .exe enden.")
+ (macosx-executables-must-end-with-app
+  "Der Dateiname\n\n  ~a\n\nist unzulässig. Unter Mac OS X müssen Namen für Programme mit .app enden.")
+ (warning-directory-will-be-replaced
+  "WARNUNG: das Verzeichnis:\n\n  ~a\n\nwird überschrieben werden. Weitermachen?")
+ 
+ (create-servlet "Servlet erzeugen...")
+
+ ; the ~a is a language such as "module" or "algol60"
+ (create-servlet-unsupported-language
+  "Servlet lassen sich nicht aus einem Programm in der Sprache \"~a\" erzeugen.")
+  
+ ;;; buttons
+ (execute-button-label "Start") 
+ (save-button-label "Speichern")
+ (break-button-label "Stop")
+ 
+ ;;; search help desk popup menu
+ (search-help-desk-for "Suche im Hilfezentrum nach \"~a\"")
+ (exact-lucky-search-help-desk-for "Exakte Suche im Hilfezentrum auf gut Glück nach \"~a\"")
+
+ ;; collapse and expand popup menu items
+ (collapse-sexp "S-Expression einfalten")
+ (expand-sexp "S-Expression wieder ausfalten")
+ 
+ ;;; fraction dialog
+ (enter-fraction "Bruch eingeben")
+ (whole-part "Ganzzahliger Anteil")
+ (numerator "Zähler")
+ (denominator "Nenner")
+ (invalid-number "Unzulässige Zahl: muss exakt, reell und nicht ganz sein.")
+ (insert-fraction-menu-item-label "Bruch einfügen...")
+
+ ;; number snip popup menu
+ (show-decimal-expansion "Als Dezimalexpansion anzeigen")
+ (show-fraction-view "Als Bruch anzeigen")
+ (show-mixed-fraction-view "Als gemischten Bruch anzeigen")
+ (show-improper-fraction-view "Als ungemischten Bruch anzeigenn")
+ (show-more-decimal-places "Mehr Dezimalziffern anzeigen")
+ 
+ ;;; Teachpack messages
+ (select-a-teachpack "Teachpack auswählen")
+ (clear-teachpack "Teachpack ~a herauswerfen")
+ (teachpack-error-label "DrScheme - Teachpack-Fehler")
+ (teachpack-dne/cant-read "Die Teachpack-Datei ~a existiert nicht oder ist nicht lesbar.")
+ (teachpack-didnt-load "Die Teachpack-Datei ~a konnte nicht korrekt geladen werden.")
+ (teachpack-error-invoke "Die Teachpack-Datei ~a hat beim Start ein Problem signalisiert.")
+ (add-teachpack-menu-item-label "Teachpack hinzufügen...")
+ (clear-all-teachpacks-menu-item-label "Alle Teachpacks herauswerfen")
+ (drscheme-teachpack-message-title "DrScheme-Teachpack")
+ (already-added-teachpack "Teachpack ~a ist schon dabei")
+ 
+ ;;; Language dialog
+ (introduction-to-language-dialog
+  "Bitte eine Sprache auswählen. Für den Anfängerkurs ist wahrscheinlich die voreingestellte Sprache die richtige.")
+ (language-dialog-title "Sprache auswählen")
+ (case-sensitive-label "Groß-/Kleinschreibung unterscheiden")
+ (output-style-label "Ausgabenotation")
+ (constructor-printing-style "Konstruktor")
+ (quasiquote-printing-style "Quasiquote")
+ (write-printing-style "write")
+ (print-printing-style "current-print")
+ (sharing-printing-label "Zeige Sharing an")
+ (use-pretty-printer-label "Zeilenumbrüche in Ausdruck einfügen")
+ (input-syntax "Eingabesyntax")
+ (dynamic-properties "Laufzeit")
+ (output-syntax "Ausgabesyntax")
+ (no-debugging-or-profiling "Kein Debugging oder Profiling")
+ (debugging "Debugging")
+ (debugging-and-profiling "Debugging und Profiling")
+ (test-coverage "Syntaktische Test-Suiten-Abdeckung")
+ (whole/fractional-exact-numbers-label "Zahlen als Brüche ausdrucken")
+ (booleans-as-true/false-label "Booleans als \"true\" und \"false\" ausdrucken")
+ (show-details-button-label "Details einblenden")
+ (hide-details-button-label "Details ausblenden")
+ (choose-language-menu-item-label "Sprache auswählen...")
+ (revert-to-language-defaults "Standard-Spracheinstellungen wiederherstellen")
+ (language-docs-button-label "Dokumentation für Sprache")
+ (fraction-style "Bruch-Ausgabe")
+ (use-mixed-fractions "gemischte Brüche")
+ (use-repeating-decimals "Dezimalausgabe mit Perioden")
+ (decimal-notation-for-rationals "Dezimalnotation für Brüche")
+ (please-select-a-language "Bitte Sprache auswählen")
+
+ 
+ ;;; languages
+ (beginning-student "Anfänger")
+ (beginning-one-line-summary "define, cond, Strukturen, Konstanten und Primitiva")
+ (beginning-student/abbrev "Anfänger mit Listen-Abkürzungen")
+ (beginning/abbrev-one-line-summary "Anfänger, wobei Listen mit \"list\" in der REPL ausgedruckt werden")
+ (intermediate-student "Zwischenstufe")
+ (intermediate-one-line-summary "Anfänger plus lexikalische Bindung")
+ (intermediate-student/lambda "Zwischenstufe mit lambda")
+ (intermediate/lambda-one-line-summary "Zwischenstufe plus Prozeduren höherer Ordnung")
+ (advanced-student "Fortgeschritten")
+ (advanced-one-line-summary "Zwischenstufe plus lambda und Mutation")
+ (full-language "Alles") ;; also in the HtDP languages section
+ (how-to-design-programs "How to Design Programs") ;; should agree with MIT Press on this one...
+ (r5rs-like-languages "R5RS-verwandet")
+ (pretty-big-scheme "Kombo (enthält MrEd and Fortgeschritten)")
+ (pretty-big-scheme-one-line-summary "Macht Syntax and Prozeduren der HtDP-Sprachen verfügbar")
+ (r5rs-lang-name "Standard (R5RS)")
+ (r5rs-one-line-summary "R5RS, ohne alles andere")
+ (expander "Expander")
+ (expander-one-line-summary "Expandiert Ausdrücke, statt sie auszuwerten")
+ (professional-languages "Sprachen für Entwickler")
+ (teaching-languages "Lehrsprachen")
+ (experimental-languages "Experimentelle Sprachen")
+ 
+ (module-language-one-line-summary "Start erzeugt eine REPL im Kontext des Moduls inklusive der deklarierten Sprache des Moduls.")
+  
+
+ ;;; debug language
+ (unknown-debug-frame "[unbekannt]")
+ (backtrace-window-title "Backtrace - DrScheme")
+ (files-interactions "Interaktionen von ~a") ;; filled with a filename
+ (current-interactions "Interaktionen")
+ (current-definitions "Definitionen")
+ (mzscheme-w/debug "Text (MzScheme, mit R5RS)")
+ (mzscheme-one-line-summary "Die PLT-Version von Scheme")
+ (mred-w/debug "Grafisch (MrEd, mit MzScheme)")
+ (mred-one-line-summary "MzScheme + GUI-Bibliothek")
+
+ ;; profiling
+ (profiling-low-color "Wenig")
+ (profiling-high-color "Viel")
+ (profiling-choose-low-color "Bitte Farbe für \"wenig\" auswählen")
+ (profiling-choose-high-color "Bitte Farbe für \"viel\" auswählen")
+ (profiling "Profiling")
+ (profiling-example-text "(define (whee) (whee))")
+ (profiling-color-config "Farbbereich für Profiling") 
+ (profiling-scale "Farbskala für Profiling")
+ (profiling-sqrt "Wurzel")
+ (profiling-linear "Linear")
+ (profiling-square "Quadrat")
+ (profiling-number "Aufrufanzahl")
+ (profiling-time "Gesamtzeit")
+ (profiling-clear "Profile löschen")
+ (profiling-update "Profile atkualisieren")
+ (profiling-col-percent-time "% Zeit")
+ (profiling-col-function "Prozedur")
+ (profiling-col-name "Name")
+ (profiling-col-time-in-msec "ms")
+ (profiling-col-calls "Aufrufe")
+ (profiling-show-profile "Profile einblenden")
+ (profiling-hide-profile "Profile ausblenden")
+ (profiling-unknown-src "<< unbekannt >>")
+ (profiling-no-information-available "Es ist keine Profiling-Information verfügbar. Bitte stellen Sie sicher, dass Profiling eingeschaltet und Ihr Programm gelaufen ist.")
+ (profiling-clear? "Änderungen im Definitionsfenster machen die Profiling-Informationen ungültig. Weitermachen?")
+ 
+ ;; test coverage
+ (test-coverage-clear? "Änderungen im Definitionsfenster machen die Information über Testabdeckung ungültig. Weitermachen?")
+ (test-coverage-clear-and-do-not-ask-again "Ja, und nicht nicht wieder fragen")
+ (test-coverage-ask? "Frage nach dem Löschen der Testabdeckungs-Information")
+  
+ ;; tracing
+ (tracing-enable-tracing "Tracing einschalten")
+ (tracing-show-tracing-window "Tracing einblenden")
+ (tracing-hide-tracing-window "Tracing ausblenden")
+ (tracing-tracing-nothing-to-show "Es liegen keine Tracing-Resultate vor. Stellen Sie sicher, dass die eingestellte Sprache Tracing unterstützt und dass Tracing eingeschaltet ist.")
+
+ ;;; repl stuff
+ (evaluation-terminated "Auswertung abgebrochen")
+ (evaluation-terminated-explanation
+  "Der Auswertungs-Thread läuft nicht mehr; es findet also keine Auswertung bis zum nächsten Programmlauf statt.")
+ (last-stack-frame "letzten Stack-Frame zeigen")
+ (last-stack-frames "die letzten ~a Stack-Frames zeigen")
+ (next-stack-frames "die nächsten ~a Stack-Frames zeigen")
+ 
+ ;;; welcoming message in repl
+ (language "Sprache")
+ (custom "angepasst")
+ (teachpack "Teachpack")
+ (welcome-to "Willkommen bei")
+ (version "Version")
+ 
+ ;;; kill evaluation dialog
+ (kill-evaluation? "Auswertung abbrechen?")
+ (just-break "Nur unterbrechen")
+ (kill "Abbrechen")
+ (kill? "Abbrechen?")
+
+ ;;; version checker
+ ;; the next two are used in the initial wizard dialog.
+ ;; Note that vc-wizard-check-prompt can (should) have newlines so
+ ;; it will not make the dialog too wide.
+ (vc-wizard-check-note "Die Version, die Sie gerade installieren wollen, könnte veraltet\n sein. Wenn Sie wollen, kann DrScheme nachsehen.")
+ (vc-wizard-check-button "Nach Updates schauen")
+ (vc-update-check "Update-Prüfung")
+ (vc-please-wait "Bitte warten")
+ (vc-connecting-version-server "Mit PLT-Versions-Server verbinden")
+ (vc-network-timeout "Netzwerk-Timeout") 
+ (vc-cannot-connect  "Verbindungsversuch zum PLT-Versions-Server fehlgeschlagen")
+ (vc-network-failure "Netzwerkproblem")
+ (vc-old-binaries "Die installierten Programmdateien für DrScheme (oder MzScheme) sind veraltet")
+ (vc-binary-information-format "Version installierte Programmdatei: ~a (Iteration ~a)")
+ (vc-details-format "~a~nDetails:~n~a")
+ (vc-details-text "Details:~n")
+ (vc-error-format "Fehler: ~a") 
+ (vc-current-format "~a v.~a (Iteration ~a) ist auf dem aktuellen Stand")
+ (vc-update-format "~a v.~a (Iteration ~a) sollte aktualisiert werden auf v.~a (Iteration ~a)")
+ (vc-binary-name "Programmdatei")
+ (vc-updates-available "Updates sind verfügbar auf")
+ (vc-latest-binary-information-format "Neuestes Release ist Version ~a (Iteration ~a)")
+ (vc-update-dialog-title "PLT-Update-Status")
+ (vc-need-update-string "Ein oder mehrere installierte PLT-Software-Pakete sind veraltet")
+ (vc-no-update-string "Alle installierten PLT-Software-Pakte sind auf dem neuesten Stand")
+
+ ;; special menu
+ (special-menu "S&pezial")
+ 
+ ;; large semi colon letters
+ (insert-large-letters... "Große Buchstaben einfügen...")
+ (large-semicolon-letters "Große Buchstaben aus Semikolons")
+ (text-to-insert "Einzufügender Text")
+
+ (module-browser-filename-format "Vollständiger Dateiname: ~a (~a Zeilen)")
+ (module-browser-root-filename "Basis-Dateiname: ~a")
+ (module-browser-font-size-gauge-label "Schriftgröße")
+ (module-browser-progress-label "Fortschritt Modul-Ãœbersicht")
+ (module-browser-adding-file "Datei ~a hinzufügen...")
+ (module-browser-laying-out-graph-label "Graph-Layout")
+ (module-browser-open-file-format "~a öffnen")
+ (module-browser "Modul-Brauser") ;; frame title
+ (module-browser... "Modul-Brauser...") ;; menu item title
+ (module-browser-error-expanding "Fehler beim Expandieren des Programms:\n\n~a")
+ (module-browser-show-lib-paths "Dateien anzeigen, die über (lib ..)-Pfade eingebunden wurden")
+ (module-browser-progress "Modul-Brauser: ~a") ;; prefix in the status line
+ (module-browser-compiling-defns "Modul-Brauser: Definition compilieren")
+ (module-browser-show-lib-paths/short "\"lib\"-requires folgen") ;; check box label in show module browser pane in drscheme window.
+ (module-browser-refresh "Aktualisieren") ;; button label in show module browser pane in drscheme window.
+ (module-browser-only-in-plt-and-module-langs
+  "Der Modul-Brauser ist nur für Programme in den PLT-Sprachen und in der Modul-Sprache verfügbar (und nur für Programme mit Modulen).")
+ (module-browser-name-length "Länge der Namen")
+ (module-browser-name-short "Kurz")
+ (module-browser-name-medium "Mittel")
+ (module-browser-name-long "Lang")
+ (module-browser-open-all "Alle hier angezeigten Datein öffnen")
+
+ (happy-birthday-matthias "Happy Birthday, Matthias!")
+ (happy-birthday-matthew "Happy Birthday, Matthew!")
+ (happy-birthday-shriram "Happy Birthday, Shriram!")
+
+ (mrflow-using-default-language-title "Standard-Sprache verwendet")
+ (mrflow-using-default-language "Die momentan verwendete Sprache hat keine Typ-Tabelle für ihre Primitiva.  Verwende stattdessen R5RS-Scheme.")
+ (mrflow-button-title "Analyse")
+ ;(mrflow-unknown-style-delta-error-title "Unknown Box Style Delta")
+ ;(mrflow-unknown-style-delta-error "Unknown box style delta: ~a")
+ (mrflow-coloring-error-title "Farbe für \"unbekannt\"")
+ (mrflow-coloring-error "Kein Style für Farbe ~a verwendet")
+ (mrflow-popup-menu-show-type "Typ einblenden")
+ (mrflow-popup-menu-hide-type "Typ ausblenden")
+ (mrflow-popup-menu-show-errors "Fehler einblenden")
+ (mrflow-popup-menu-hide-errors "Fehler ausblenden")
+ ;(mrflow-read-exception-title "Read Exception")
+ ;(mrflow-read-exception "Read exception: ~a")
+ ;(mrflow-syntax-exception-title "Syntax Exception")
+ ;(mrflow-syntax-exception "Syntax exception: ~a")
+ ;(mrflow-unknown-exception-title "Unknown Exception")
+ ;(mrflow-unknown-exception "Unknown exception: ~a")
+ ;(mrflow-language-primitives-error-title "Language Primitives Error")
+ ;(mrflow-language-primitives-error "Wrong filename for language primitives types table: ~a")
+  
+ (snips-and-arrows-popup-menu-tack-all-arrows "Alle Pfeile befestigen")
+ (snips-and-arrows-popup-menu-untack-all-arrows "Alle Pfeile lösen")
+ (snips-and-arrows-user-action-disallowed-title "Änderungen durch den Benutzer momentan nicht möglich")
+ (snips-and-arrows-user-action-disallowed "In Editoren, die von Tools erzeugte Snips enthalten, sind Änderungen durch den Benutzer nicht möglich. Blenden Sie alle Snips aus, bevor Sie den Inhalt des Editors ändern.")
+ ;(snips-and-arrows-changing-terms-warning-title "Changing terms will be undoable")
+ ;(snips-and-arrows-changing-terms-warning "Changing terms in an editor containing snips cannot be undone.  You can either cancel this action, remove the snips, and try the change again, or you can continue with the change, in which case the change will not be undoable (all others changes made before and afterward will still be undoable though).")
+ (snips-and-arrows-hide-all-snips-in-editor "Alle Snips im Editor ausblenden")
+
+ (xml-tool-menu "XML")
+ (xml-tool-insert-xml-box "XML-Kasten einfügen")
+ (xml-tool-insert-scheme-box "Scheme-Kasten einfügen")
+ (xml-tool-insert-scheme-splice-box "Scheme-Spleiß-Kasten einfügen")
+ (xml-tool-xml-box "XML-Kasten")
+ (xml-tool-scheme-box "Scheme-Kasten")
+ (xml-tool-scheme-splice-box "Scheme-Spleiß-Kasten")
+ (xml-tool-switch-to-scheme "In Scheme-Kasten verwandeln")
+ (xml-tool-switch-to-scheme-splice "In Scheme-Spleiß-Kasten verwandeln")
+ (xml-tool-eliminate-whitespace-in-empty-tags
+  "Überflüssigen Whitespace in leeren Tags entfernen")
+ (xml-tool-leave-whitespace-alone
+  "Whitespace unverändert lassen")
+ 
+ (show-recent-items-window-menu-item "Kürzlich geöffnete Dateien in separatem Fenster anzeigen")
+ (show-recent-items-window-label "Kürzlich geöffnete Dateien")
+ (number-of-open-recent-items "Anzahl kürzlich geöffneter Dateien")
+ (switch-anyway "Datei trotzdem wechseln")
+
+ (stepper-program-has-changed "WARNUNG: Das Programm wurde geändert.")
+ (stepper-program-window-closed "WARNUNG: Das Programm-Fenster ist nicht mehr da.")
+
+ (stepper-home "Anfang")
+ (stepper-name "Stepper")
+ (stepper-language-level-message
+  "Die aktuelle Sprachebene ist \"~a\". Der Stepper funktioniert bisher nur für die Ebenen\"~a\" bis \"~a\".")
+ (stepper-button-label "Stepper")
+ (stepper-previous-application "|< Applikation")
+ (stepper-previous "< Schritt")
+ (stepper-next "Schritt >")
+ (stepper-next-application "Applikation >|")
+ 
+ (wizard-next "Weiter")
+ (wizard-back "Zurück")
+ (wizard-finish "Fertigstellen")
+
+ ;; warnings about closing a drscheme frame when the program
+ ;; might still be doing something interesting
+ (program-is-still-running "Das Programm im Definitionsfenster läuft noch.  Trotzdem schließen?")
+  (program-has-open-windows "Das Programm im Definitionsfenster hat noch offene Fenster.  Trotzdem dieses Fenster schließen?")
+ 
+  ;; ml-command-line-arguments is for the command line arguments
+  ;; label in the module language details in the language dialog.
+  (ml-command-line-arguments "Kommandozeilen-Argumente als Vektoren von Zeichenketten, in Read-Syntax")
+
+  ;; ml-cp names are all for the module language collection path
+  ;; configuration. See the details portion of the language dialog
+  ;; for the module language (at the bottom).
+  (ml-cp-default-collection-path "<<Standard-Pfade für Kollektionen>>")
+
+  ;; in std get-directory 
+  (ml-cp-choose-a-collection-path "Bitte Pfad für Kollektion auswählen")
+
+  ;; err msg when adding default twice
+  (ml-cp-default-already-present
+   "Standard-Pfade für Kollektionen schon vorhanden")
+  
+  ;; title of this section of the dialog (possibly the word
+  ;; `Collection' should not be translated)
+  (ml-cp-collection-paths "Pfade für Kollektionen")
+
+  ;; button labels
+  (ml-cp-add "Hinzufügen")
+  (ml-cp-add-default "Standard hinzufügen")
+  (ml-cp-remove "Entfernen")
+  (ml-cp-raise "Höher")
+  (ml-cp-lower "Tiefer")
+
+  ;; Profj
+  (profj-java "Java")
+  (profj-java-mode "Java-Modus")
+  (profj-java-mode-color-keyword "Schlüsselwort")
+  (profj-java-mode-color-string "Zeichenkette")
+  (profj-java-mode-color-literal "Literal")
+  (profj-java-mode-color-comment "Kommentar")
+  (profj-java-mode-color-error "Fehler")
+  (profj-java-mode-color-identifier "Bezeichner")
+  (profj-java-mode-color-default "sonstiges")
+  
+  (profj-insert-java-comment-box "Java-Kommentarkasten einfügen")
+  (profj-insert-java-interactions-box "Java-Interaktions-Kasten einfügen")
+
+  ;; The Test Suite Tool
+  ;; Errors
+  (test-case-empty-error "Leerer Testfall")
+  (test-case-too-many-expressions-error "Zu viele Ausdrücke in einem Testfall")
+  (test-case-not-at-top-level "Testfall-Kasten nicht ganz am Top-Level")
+  ;; Dr. Scheme window menu items
+  (test-case-insert "Testfall einfügen")
+  (test-case-disable-all "Alle Testfälle deaktivieren")
+  (test-case-enable-all "Alle Testfälle aktivieren")
+  ;; NOTE: The following three string constants are labels of the test-case fields. The width
+  ;;       of the field is determined by the length of the longest of the following three words.
+  ;;       if the words are too long the test case will take up too much horizontal room and
+  ;;       not look very good.
+  ;; This string is the label of the expression that is being tested in a test case.
+  (test-case-to-test "Test")
+  ;; This string is the label of the expression that is the expected value of the to-test expression.
+  (test-case-expected "Sollte sein")
+  ;; This string is the label of the actual result of the to test expression.
+  (test-case-actual "Tatsächlich")
+  (test-case-predicate "Prädikate")
+  (test-case-should-raise "Sollte verursachen")
+  ;; The label of a field of the test-case that describes the expected error message of a test case
+  (test-case-error-message "Fehlermeldung")
+
+  (test-case-menu-title "Testfall")
+  (test-case-switch-to-error-box "Zu Fehler-Testbox machen")
+  (test-case-switch-to-nonerror-box "Zu Nicht-Fehler-Testbox machen")
+  (test-case-collapse "Testfall einfalten")
+  (test-case-show-actual "Tatsächlichen Wert zeigen")
+  (test-case-enable "Testfall aktivieren")
+  (test-case-show-predicate "Prädikat anzeigen")
+  (test-case-show-error-message "Fehlermeldung anzeigen")
+  (test-case-convert-to-text "In Text umwandeln")
+
+  ;; Profj Boxes
+  (profjBoxes-empty-error "Leere Interaktion")
+  (profjBoxes-too-many-expressions-error "Zu viele Ausdrücke in einem Kasten")
+  (profjBoxes-interactions-label "Interaktionen")
+  (profjBoxes-bad-java-id-error "Nicht-wohlgeformte Java-ID")
+  (profjBoxes-examples-label "Beispiele")
+  (profjBoxes-add-new-example-button "Neues Beispiel hinzufügen")
+  (profjBoxes-type "Typ")
+  ;; The Java identifier of an example of data
+  (profjBoxes-name "Name")
+  (profjBoxes-value "Wert")
+  (profjBoxes-insert-java-examples "Java-Beispiele einfügen")
+  (profjBoxes-insert-java-interactions "Java-Interactionen einfügen")
+
+  ;; Slideshow
+  (slideshow-show-slideshow-panel "Slideshow-Panel zeigen")
+  (slideshow-hide-slideshow-panel "Slideshow Panel")
+  (slideshow-freeze-picts "Diese Picts einfrieren")
+  (slideshow-thaw-picts "Picts unter der Maus zeigen")
+  (slideshow-hide-picts "Geschachtelte Kästen anzeigen")
+  (slideshow-show-picts "Picts anzeigen")
+  (slideshow-cannot-show-picts "Kann die Picts nicht anzeigen; Sie müssen erst das Programm zum Cachen der Größen laufen lassen")
+  (slideshow-insert-pict-box "Pict-Kasten einfügen") 
+
+  ;; GUI Tool
+  (gui-tool-heading "GUI-Werkzeug")
+  (gui-tool-before-clicking-message "Befor Sie auf ein Tool-Icon klicken, benutzen Sie \"GUI einfügen\" vom \"Spezial\"-Menü, um ein Wurzel-GUI-Element einzufügen, oder selektieren Sie eine schon vorher eingefügte GUI.")
+  (gui-tool-show-gui-toolbar "GUI-Toolbar einblenden")
+  (gui-tool-hide-gui-toolbar "GUI-Toolbar ausblenden")
+  (gui-tool-insert-gui "GUI einfügen")
+  )
diff --git a/collects/string-constants/info.ss b/collects/string-constants/info.ss
new file mode 100644
index 0000000000..0cb59daa69
--- /dev/null
+++ b/collects/string-constants/info.ss
@@ -0,0 +1,3 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "String constants")
+  (define doc.txt "doc.txt"))
diff --git a/collects/string-constants/italian-string-constants.ss b/collects/string-constants/italian-string-constants.ss
new file mode 100644
index 0000000000..e52e4cfce2
--- /dev/null
+++ b/collects/string-constants/italian-string-constants.ss
@@ -0,0 +1,9 @@
+
+(module italian-string-constants "string-constant-lang.ss"
+ (is-this-your-native-language "Is Italian Your Native Language?")
+
+ (are-you-sure-you-want-to-switch-languages
+  "This will change the language of the GUI, which requires you to restart DrScheme. Are you sure?")
+
+ (interact-with-drscheme-in-language "Interact with DrScheme in Italian")
+  )
diff --git a/collects/string-constants/japanese-string-constants.ss b/collects/string-constants/japanese-string-constants.ss
new file mode 100644
index 0000000000..1997ec11ba
--- /dev/null
+++ b/collects/string-constants/japanese-string-constants.ss
@@ -0,0 +1,1285 @@
+#|
+
+When modifying the string constants files,
+please adhere to these guidelines:
+
+- All the entries in english-string-constants.ss have the same format
+  (name string).  If the purpose of an entry you are adding to the
+  file is not clear from just the name and string, put a comment next
+  to the entry explaining what the string is going to be used for and
+  in what context.
+  That's especially true for strings that contain things like "~a".
+  Systematically describe what the "~a" is going to be replaced with.
+  When we have to translate strings like "deleting ~a", we translators
+  need to know what "~a" is going to be (in particular, in some
+  languages like French, we need to know whether the "~a" is going to
+  be a masculine or feminine word, or whether it's going to be
+  singular or plural, etc).
+
+- When adding a bunch of new entries, put together in a section the
+  entries that logically belong together.  Give a title to your
+  section, so we have an idea of what the strings are for.  Don't mix
+  in the same section strings that have nothing to do with each other,
+  that's only going to confuse us.  Do not start a new section if
+  there's already one that deals with the same thing.  Dumping all the
+  new entries in random order at the end of the file is not a good way
+  to have your new entries translated in a timely manner...
+
+- Before adding strings for your new pet tool, check whether you can't
+  re-use strings that already exist.  There's no need for yet another
+  "Ok" string...
+
+- If you modify an existing string in english-string-constants.ss, go
+  through all the *-string-constants.ss files for the other languages,
+  comment out the old version of the modified string in each of these
+  files, and put a short comment there telling us the English string
+  has changed and needs to be re-translated.  Do not erase the old
+  version, it might help us translate the new one.  Do not move it
+  either.  Just comment it out and add the short comment.  After the
+  next cvs update DrScheme will automatically tell us translators that
+  a new string needs to be translated, we will find your comment in
+  the file, and know what to do.
+	Some evil evil people might think that, since DrScheme automatically
+  informs us of new strings to be translated, an easier thing to do
+  when modifying an existing string would be to simply rename it at
+  the same time.  This works, except that if you do that, we
+  translators will get two warnings from DrScheme:
+		language english had but french does not:
+		(new-name "New String")
+		language french had but english does not:
+		(old-name "Old String")
+  then we translators will be left to wonder whether the two things
+  are related or not, and whether we can safely base our translation
+  of "New String" on the translation of "Old String" (since the two
+  strings are likely to be close in meaning).  Worse, we might not
+  even realize the two strings are related and translate "New String"
+  from scratch, just to realize later that it's only a variation of
+  "Old String".  I can tell you that nothing pisses off a translator
+  more than having to translate pretty much the same string twice
+  just because *you* were too lazy to inform us that it was just a
+  slight modification to an existing string rather than an entirely
+  new one.  Conclusion: do not change the name of a string unless you
+  have some really good reason to do so.
+
+- Please think hard before choosing a string and make sure it means
+  what you want it to mean.  That way you won't have to change it
+  later, and we won't have to retranslate it.
+
+- Please think hard before choosing the name for a string.  Use
+  meaningful names.  "error" or "ok" are not meaningful names.  Prefix
+  all related names with a common prefix (the name of your tool or
+  module).  String names are not the right place to save on typing.
+
+- If, for some reason, you really have to change the name of a string
+  (like, because the original name you gave it really sucked...),
+  change the name of the string in *ALL* the *-string-constants.ss
+  files.  That's a modification you can do without the help of a
+  translator, so do it yourself.  It's not the job of the translators
+  to clean up your naming mess for you.  Besides, you are the one who
+  knows what you changed, so leaving the translators having to guess
+  what you did is Not Nice(tm).
+
+- If, for some reason, you need to remove a string (i.e. you changed
+  your code and don't need the string anymore), remove the string in
+  *ALL* the *-string-constants.ss files.  Again, you don't need the
+  help of a translator to do that.  If you're not sure whether you
+  might need the string in the future or not, just comment it out in
+  *ALL* the files.
+
+|#
+
+(module japanese-string-constants "string-constant-lang.ss"
+ ;;; when translating this constant, substitute name of actual langauge for `English'
+ (is-this-your-native-language "Is Japanese Your Native Language?")
+
+ (are-you-sure-you-want-to-switch-languages
+  "This will change the language of the GUI, which requires you to restart DrScheme. Are you sure?")
+
+ (interact-with-drscheme-in-language "Interact with DrScheme in Japanese")
+
+ ;; these two should probably be the same in all languages excepet English.
+ ;; they are the button labels (under macos and windows, respectively)
+ ;; that go the with the string above.
+ (accept-and-quit "Accept and Quit")
+ (accept-and-exit "Accept and Exit")
+ 
+ ;;; general purpose (DrScheme is hereby a word in every language, by decree of Robby :)
+ (plt "PLT")
+ (drscheme "DrScheme")
+ (ok "OK")
+ (cancel "キャンセル")
+ (abort "中止")
+ (untitled "Untitled")
+ (untitled-n "Untitled ~a")
+ (warning "警告")
+ (error "エラー")
+ (close "閉�る") ;; as in, close an open window. must match close-menu-item
+                 ;; in the sense that, when the &s have been stripped from
+                 ;; close-menu-item, it must be the same string as this.
+ (stop "�止")   
+ (&stop "�止(&S)") ;; for use in button and menu item labels, with short cut.
+ (are-you-sure-delete? "~a を削除��よ������？") ;; ~a is a filename or directory name
+ (ignore "無視")
+ (revert "復元")
+
+ ;; label for a generic check box, often supported on dialogs
+ ;; that ask a binary choice of the user. If checked, the
+ ;; dialog isn't going to be shown again.
+ (dont-ask-again "今後��メッセージを表示��� (�在��択�使�れ��)")
+
+ ;;; important urls
+ (web-materials "関連�るウェブサイト") ;; menu item title
+ (tool-web-sites "ツール�ウェブサイト")   ;; menu item title
+ (drscheme-homepage "DrScheme")
+ (plt-homepage "PLT")
+ (how-to-use-scheme "How to Use Scheme") ;; title of a book.
+ (teachscheme!-homepage "TeachScheme!") ;; probably this should be a `word' in all languages
+
+ ;;; bug report form
+ (cancel-bug-report? "�グ報告を中止����？")
+ (are-you-sure-cancel-bug-report?
+  "���グ報告を�信����中止��よ������？")
+ (bug-report-form "�グ報告フォーム")
+ (bug-report-field-name "��")
+ (bug-report-field-email "メールアドレス")
+ (bug-report-field-summary "概�")
+ (bug-report-field-severity "深刻度")
+ (bug-report-field-class "分類")
+ (bug-report-field-priority "優先度")
+ (bug-report-field-description "説明")
+ (bug-report-field-reproduce1 "���手順")
+ (bug-report-field-reproduce2 "")
+ (bug-report-field-environment "環境")
+ (bug-report-field-tools "ツール")
+ (bug-report-field-docs-installed "インストール�れ��る文書")
+ (bug-report-field-language "言語")
+ (bug-report-field-teachpacks "ティー�パック")
+ (bug-report-field-collections "コレクション")
+ (bug-report-field-human-language "自然言語")
+ (bug-report-field-version "�ージョン")
+ (bug-report-synthesized-information "詳細情報")  ;; dialog title
+ (bug-report-show-synthesized-info "詳細情報�表示")
+ (bug-report-submit "�信")
+ (bug-report-submit-menu-item "�グ報告��信") ;; in Help Menu (drs & help desk)
+ (sending-bug-report "�グ報告を�信中��")
+ (error-sending-bug-report "�グ報告��信エラー")
+ (error-sending-bug-report-expln "�グ報告��信中�エラー�発生����。も��インター�ット接続�正常��る�ら�\n\n    http://bugs.plt-scheme.org/\n\nを開���オンライン�ウェブフォーム�ら�グ報告を行������。�手間を���申�訳�り��ん。\n\nエラーメッセージ:\n~a")
+ (bug-report-sent "�グ報告を�信����")
+ (bug-report-sent-detail "�グ報告を行������有難�������。30分以内�確��メール������られ��。も��られ�����場���scheme@plt-scheme.org ��連絡����。")
+ (illegal-bug-report "�グ報告�正��入力�れ����ん")
+ (pls-fill-in-field "フィールド \"~a\" を入力������。")
+ (malformed-email-address "メールアドレス�形��正���り��ん。")
+ (pls-fill-in-either-description-or-reproduce " \"説明\" ��� \"���手順\" ���れ�一方�入力������。")
+
+ ;;; check syntax
+ (check-syntax "構文�検証")
+ (cs-italic "斜体")
+ (cs-bold "太字")
+ (cs-underline "下線")
+ (cs-change-color "カラー�変更")
+ (cs-tack/untack-arrow "矢��連�/�連�")
+ (cs-jump-to-next-bound-occurrence "Jump to Next Bound Occurrence")
+ (cs-jump-to-binding "Jump to Binding Occurrence")
+ (cs-jump-to-definition "Jump to Definition")
+ (cs-error-message "エラーメッセージ")
+ (cs-open-file "~a を開�")
+ (cs-rename-var "~a ���を変更")
+ (cs-rename-id "Rename Identifier")
+ (cs-rename-var-to "Rename ~a to:")
+ (cs-name-duplication-error "The new name you have chosen, ~s, conflicts with an already established name in this scope.")
+ (cs-rename-anyway "Rename Anyway")
+ (cs-status-init "Check Syntax: Initializing environment for user code")
+ (cs-status-coloring-program "Check Syntax: coloring expression")
+ (cs-status-eval-compile-time "Check Syntax: eval compile time")
+ (cs-status-expanding-expression "Check Syntax: expanding expression")
+ (cs-mouse-over-import "binding ~s imported from ~s")
+
+ (cs-lexical-variable "レキシカル変数")
+ (cs-lexical-syntax "レキシカル構文")
+ (cs-imported-variable "イン�ート変数")
+ (cs-imported-syntax "イン�ート構文")
+
+ ;;; info bar at botttom of drscheme frame
+ (collect-button-label "GC")
+ (read-only "読��り専用")
+ (read/write "読�書��能")
+ (auto-extend-selection "自動拡張")
+ (overwrite "上書�")
+ (running "実行中")
+ (not-running "�止中")
+ 
+ ;;; misc
+ (welcome-to-something "~a �よ����")
+ 
+ ; this appears in the drscheme about box.
+ (welcome-to-drscheme-version/language "Welcome to DrScheme, version ~a, ~a")
+
+ ; these appear on subsequent lines in the `Help|Welcome to DrScheme' dialog.
+ (welcome-to-drscheme "Welcome to DrScheme")
+ (version/language "version ~a, ~a")
+
+ (goto-line "行番�を指定��移動")
+ (goto-line-invalid-number
+  "~a �無効�行番���。行番�� 1 �ら ~a ���整数�指定������。")
+ (goto-position "�置を指定��移動")
+ (no-full-name-since-not-saved
+  "��ファイル����存�れ�������完全���を������ん。")
+ (cannot-open-because-dne "~a �存在�����開��������ん。")
+ (interactions-out-of-sync
+  "警告: 対話ウィンドウ�定義ウィンドウ��期�����ん。実行ボタンを押������。")
+ (file-is-not-saved "ファイル \"~a\" ��存�れ����ん。")
+ (save "�存")
+ (please-choose-either "\"~a\" ��� \"~a\" ���れ�を�択������。")
+ (close-anyway "����閉�る")
+ (clear-anyway "����消去�る")
+
+ ;; menu item title
+ (log-definitions-and-interactions "定義�対話を記録�る...")
+ (stop-logging "記録��止")
+ (please-choose-a-log-directory "記録先�ディレクトリを�択������")
+ (logging-to "記録先: ")
+ (erase-log-directory-contents "記録先�ディレクトリ ~a �内容を消去����？")
+ (error-erasing-log-directory "記録先�ディレクトリ�内容を消去����ん���。\n\n~a\n")
+
+ ;; modes
+ (mode-submenu-label "モード")
+ (scheme-mode "Scheme モード")
+ (text-mode "Text モード")
+
+ (scheme-mode-color-symbol "シンボル")
+ (scheme-mode-color-keyword "キーワード")
+ (scheme-mode-color-comment "コメント")
+ (scheme-mode-color-string "文字列")
+ (scheme-mode-color-constant "定数")
+ (scheme-mode-color-parenthesis "括弧")
+ (scheme-mode-color-error "エラー")
+ (scheme-mode-color-other "��他")
+ ;; the ~a is filled in with one of the above (scheme-mode-*)
+ (syntax-coloring-choose-color "Choose a color for ~a")
+ (preferences-colors "Colors") ;; used in the preferences dialog
+ 
+ (url "URL")
+ (url: "URL:")
+ (open-url... "URL を開�...")
+ (open-url "URL を開�")
+ (browse... "�択...")
+ (bad-url "�正� URL")
+ (bad-url:this "�正� URL: ~a")
+ 
+ ;; Help Desk
+ (help "ヘルプ")
+ (help-desk "ヘルプデスク")
+ (plt:hd:search-results "検索�果")
+ (plt:hd:search "検索")
+ (plt:hd:search-for "検索語")
+ (plt:hd:lucky "Lucky!")
+ (plt:hd:feeling-lucky "Feeling Lucky")
+ (plt:hd:stop "�止")   
+ (plt:hd:options "オプション") 
+ (plt:hd:configure "設定")
+ (plt:hd:home "ヘルプデスク�ホーム") 
+ (plt:hd:show-manuals "マニュアル�表示") 
+ (plt:hd:send-bug-report "�グ報告��信")
+ (plt:hd:query-bug-reports "�グ報告�検索")
+ ; next 3 are popup menu choices in help desk search frame
+ (plt:hd:search-for-keyword "キーワード�")
+ (plt:hd:search-for-keyword-or-index "キーワード�索引�")
+ (plt:hd:search-for-keyword-or-index-or-text "キーワード,索引,テキスト�")
+ (plt:hd:exact-match "正確�一致")
+ (plt:hd:containing-match "�ん��る")
+ (plt:hd:regexp-match "正�表��マッ�")
+ (plt:hd:find-docs-for "検索:")
+ (plt:hd:nothing-found-for-search-key "情報��り��ん \"~a\".")
+ (plt:hd:searching "検索中...")
+ (plt:hd:search-stopped "[検索を�止����]")
+ (plt:hd:search-stopped-too-many-matches "[検索を中止����: ヒット件数�多����]")
+ (plt:hd:nothing-found-for "情報��り��ん ~a")
+ (plt:hd:error-finding-docs "ドキュメント�見��り��ん\n\n~a")
+ (plt:hd:and "and")
+ (plt:hd:refresh "refresh")
+ (plt:hd:refresh-all-manuals "refresh all manuals")
+ (plt:hd:manual-installed-date "(installed ~a)")
+ ; Help Desk configuration
+ (plt:hd:configuration "PLT Help Desk configuration")
+ (plt:hd:no-frames "No Frames")
+ (plt:hd:use-frames "Use Frames")
+ (plt:hd:use-html-frames "Use HTML frames")
+ (plt:hd:search-pane-options "Search pane options")
+ (plt:hd:height "Height")
+ (plt:hd:bg-color "Background color")
+ (plt:hd:pixels "pixels")
+ (plt:hd:text-color "Text color")
+ (plt:hd:link-color "Link color")
+ (plt:hd:text-sample "Search pane text appears in this color")
+ (plt:hd:link-sample "Search pane links appear in this color")
+ (plt:hd:save-changes "Save changes")
+ (plt:hd:reset "Reset")
+ (plt:hd:defaults "Defaults")
+ (plt:hd:javascript-note
+    "The selections you make will be shown here if you have Javascript enabled and a recent, standards-compliant browser.")
+ ;; refreshing manuals
+ (plt:hd:refresh-downloading "Downloading ~a")
+ (plt:hd:refresh-installing "Installing ~a")
+ (plt:hd:refresh-progress "PLT manual download progress")
+ (plt:hd:refresh-done "Done refreshing manuals")
+ (plt:hd:refresh-installation-log "Installation log")
+ (plt:hd:refresh-stopped "PLT manuals refresh stopped")
+ (plt:hd:refreshing-manuals "Re-downloading Manuals")
+ (plt:hd:refresh-downloading... "Downloading ~a...")
+ (plt:hd:refresh-deleting... "Deleting old version of ~a...")
+ (plt:hd:refresh-installing... "Installing new version of ~a...")
+ (plt:hd:refresh-clearing-indicies "Clearing cached indices")
+ (plt:hd:refreshing-manuals-finished "Finished.")
+ (plt:hd:about-help-desk "ヘルプデスク����")
+ (plt:hd:help-desk-about-string
+  "Help Desk is a complete source of information about PLT software, including DrScheme, MzScheme, and MrEd.\n\nVersion ~a\nCopyright (c) 1995-2003 PLT")
+ (plt:hd:help-on-help "Help on Help")
+ (plt:hd:help-on-help-details "For help on using Help Desk, follow the `How to use Help Desk' link on Help Desk's home page. (To get to the home page if you're not already there, click the `Home' button at the top of the Help Desk window.)")
+  (reload "Reload") ;; refresh the page in a web browser
+  (plt:hd:ask-about-separate-browser
+   "You have selected a link to content from the world-wide web. Would you like to view it in the Help Desk browser, or would you like to use a separate browser program to view it?")
+  (plt:hd:homebrew-browser "Help Desk Browser") ;; choice for the above string (in a button)
+  (plt:hd:separate-browser "Separate Browser") ;; other choice for the above string (also in a button)
+  (plt:hd:external-link-in-help "External URLs in Help")
+  (plt:hd:use-homebrew-browser "Use Help Desk browser for external URLs")
+  (plt:hd:new-help-desk "New Help Desk")
+  (plt:hd:teaching-manuals "Student manuals")
+  (plt:hd:professional-manuals "Professional manuals")
+  (plt:hd:all-manuals "All manuals")
+
+  ;; in the Help Desk language dialog, title on the right.
+  (plt:hd:manual-search-ordering "Manual Search Order")
+
+
+ ;; Help desk htty proxy
+ (http-proxy "HTTP プロキシ")
+ (proxy-direct-connection "直接接続")
+ (proxy-use-proxy "プロキシを使�:")
+ (proxy-host "ホスト")
+ (proxy-port "�ート")
+ (proxy-bad-host "Bad Proxy Host")
+
+ ;; browser
+ (rewind-in-browser-history "戻る")
+ (forward-in-browser-history "進む")
+ (home "ホーム")
+ (browser "ブラウザ")
+ (external-browser-choice-title "外部ブラウザ") ; title for radio-button set
+ (browser-command-line-label "コマンドライン:") ; label for radio button that is followed by text boxes
+ (choose-browser "Choose a Browser")
+ (no-browser "Ask Later")
+ (use-internal-browser-for-help "Read help with internal PLT browser") ; radio-button label
+ (use-external-browser-for-help "Read help with external web browser") ; radio-button label
+ (browser-cmdline-expl-line-1 "(Command line formed by concatenating pre-text, URL,") ; explanatory text for dialog, line 1
+ (browser-cmdline-expl-line-2 "and post-text, with no extra spaces between them.)") ; ... line 2. (Anyone need more lines?)
+ (cannot-display-url "Cannot display URL ~s: ~a")
+ (install? "Install?")  ;; if a .plt file is found (title of dialog)
+ (you-have-selected-an-installable-package "You have selected an installable package.")
+ (do-you-want-to-install-it? "Do you want to install it?")
+ (paren-file-size "(The file is ~a bytes)")
+ (download-and-install "Download && Install") ;; button label
+ (download "Download") ;; button label
+ (save-downloaded-file/size "Save downloaded file (~a bytes) as") ;; label for get-file dialog
+ (save-downloaded-file "Save downloaded file as")  ;; label for get-file dialog
+ (downloading "Downloading") ;; dialog title
+ (downloading-file... "Downloading file...")
+ (package-was-installed "The package was installed.")
+ (download-was-saved "The downloaded file was saved.")
+ (getting-page "Getting Page") ;; dialog title
+
+ (install-plt-file-menu-item... ".plt ファイル�インストール...")
+ (install-plt-file-dialog-title ".plt ファイル�インストール")
+ (install-plt-web-tab "ウェブ")
+ (install-plt-file-tab "ファイル")
+ (install-plt-filename "ファイル�:")
+ (install-plt-url "URL:")
+ 
+ ;; install plt file when opened in drscheme strings
+ (install-plt-file "~a をインストール����？�れ�も編集用�開����？")
+ (install-plt-file/yes "インストール")
+ (install-plt-file/no "編集")
+
+ (plt-installer-progress-window-title "インストール�進行状�") ;; frame title
+ (plt-installer-abort-installation "インストールを中止") ;; button label
+ (plt-installer-aborted "中止����") ;; msg that appears in the installation window when installation is aborted
+
+ ;;; about box
+ (about-drscheme-frame-title "DrScheme ����")
+ (take-a-tour "ツアー�紹介�")
+ (release-notes "リリースノート")
+ (parenthetical-last-version "(previous version ~a)")
+ (parenthetical-last-language "(previous language ~a)")
+ (parenthetical-last-version/language "(previous version ~a, language ~a)")
+ 
+ 
+ ;;; save file in particular format prompting.
+ (save-as-plain-text "��ファイルをプレーンテキスト��存����？")
+ (save-in-drs-format "��ファイルを DrScheme 専用��イナリ形���存����？")
+ (yes "��")
+ (no "���")
+ 
+ ;;; preferences
+ (preferences "環境設定")
+ (saving-preferences "�存�設定")
+ (error-unmarshalling "Error unmarshalling ~a preference")
+ (error-saving-preferences "Error saving preferences: ~a")
+ (error-reading-preferences "Error reading preferences")
+ (expected-list-of-length2 "expected a list of length 2")
+ (scheme-prefs-panel-label "Scheme")
+ (warnings-prefs-panel-label "警告")
+ (editor-prefs-panel-label "編集")
+ (general-prefs-panel-label "一般")
+ (highlight-parens "対応�る括弧�間を強調表示�る")
+ (fixup-parens "括弧を自動修正�る")
+ (flash-paren-match "対応�る括弧をフラッシュ�る")
+ (auto-save-files "ファイルを自動�存�る")
+ (backup-files "ファイルを�ックアップ�る")
+ (map-delete-to-backspace "Delete キーを Backspace キー���処��る")
+ (verify-exit "DrScheme 終了時�確�を�る")
+ (ask-before-changing-format "�存形�を変更�る��確�を�る")
+ (wrap-words-in-editor-buffers "エディタ�テキストを折り返��表示�る")
+ (show-status-line "ステータス行を表示�る")
+ (count-columns-from-one "�番�を 1 �ら数�る")
+ (display-line-numbers "Display line numbers in buffer; not character offsets")
+ (enable-keybindings-in-menus "メニュー�キー�インドを有効��る")
+ (automatically-to-ps "自動的� PostScript ファイル��刷�る")
+ (option-as-meta "Option キーを Meta キー���処��る") ;; macos/macos x only
+ (use-mdi "MDI ウィンドウを使用�る") ;;; ms windows only -- use that window in a window thingy
+ (separate-dialog-for-searching "Use separate dialog for searching")
+ (reuse-existing-frames "Reuse existing frames when opening new files")
+ (default-fonts "Default Fonts")
+ (paren-match-color "Parenthesis highlight color") ; in prefs dialog
+ (choose-color "Choose Color") ; in prefs dialog
+ (online-coloring-active "Color syntax interactively")
+ (open-files-in-tabs "Open files in separate tabs (not separate windows)")
+ (show-interactions-on-execute "Automatically open interactions window when running a program")
+ (limit-interactions-size "Limit interactions size")
+ (background-color "Background color")
+ (default-text-color "Default text") ;; used for configuring colors, but doesn't need the word "color"
+ (choose-a-background-color "Please choose a background color")
+
+ ; title of the color choosing dialog
+ (choose-paren-highlight-color "Choose Parenthesis Highlight Color")
+
+ ; should have entire alphabet
+ (font-example-string "The quick brown fox jumped over the lazy dogs.") 
+
+ (change-font-button-label "Change")
+ (fonts "Fonts")
+
+ ; filled with type of font, eg modern, swiss, etc.
+ (choose-a-new-font "Please choose a new \"~a\" font")
+
+ (font-size-slider-label "サイズ")
+ (restart-to-see-font-changes "フォント�変更��起動後�有効��り��")
+
+ (font-prefs-panel-title "フォント")
+ (font-name "フォント�")
+ (font-size "フォントサイズ")
+ (set-font "Set Font...")
+ (font-smoothing-label  "ﾌｫ�ﾄ�ｽﾑｰｼﾞ�ｸﾞ")
+ (font-smoothing-none "��")
+ (font-smoothing-some "�る程度")
+ (font-smoothing-all "���")
+ (font-smoothing-default "システム�既定値を使�")
+ (select-font-name "フォント���択")
+ (example-text "サンプル テキスト:")
+ (only-warn-once "定義�対話��期�����場��一度��警告�る。")
+ 
+ ; warning message when lockfile is around
+ (waiting-for-pref-lock "環境設定�ロックファイルを待�����...")
+ (pref-lock-not-gone
+  "The preferences lockfile:\n\n   ~a\n\nprevents the preferences from being saved. Ensure that no PLT software is running and delete this file.")
+ (still-locked-exit-anyway? "環境設定��存����ん���。�り���終了����？")
+ 
+ ;;; indenting preferences panel
+ (indenting-prefs-panel-label "インデント")
+ (indenting-prefs-extra-regexp "Extra regexp")
+
+ ; filled with define, lambda, or begin
+ (enter-new-keyword "Enter new ~a-like keyword:")
+ (x-keyword "~a Keyword")
+ (x-like-keywords "~a-like Keywords")
+
+ (expected-a-symbol "expected a symbol, found: ~a")
+ (already-used-keyword "\"~a\" is already a specially indented keyword")
+ (add-keyword "追加")
+ (remove-keyword "削除")
+ 
+ ;;; find/replace
+ (find-and-replace "検索�置�")
+ (find "検索")
+ (replace "置�")
+ (dock "��")
+ (undock "分離")
+ (use-separate-dialog-for-searching "Use separate dialog for searching")
+ (replace&find-again "Replace && Find Again") ;;; need double & to get a single &
+ (replace-to-end "Replace to End")
+ (forward "�方")
+ (backward "後方")
+ (hide "Hide")
+ 
+ ;;; multi-file-search
+ (mfs-multi-file-search-menu-item "Search in Files...")
+ (mfs-string-match/graphics "String match (handles files with graphics)")
+ (mfs-regexp-match/no-graphics "Regular Expression (only raw text files)")
+ (mfs-searching... "Searching...")
+ (mfs-configure-search "Configure Search") ;; dialog title
+ (mfs-files-section "Files")   ;; section in config dialog
+ (mfs-search-section "Search") ;; section in config dialog
+ (mfs-dir "Dir")
+ (mfs-recur-over-subdirectories "Recur over subdirectories")
+ (mfs-regexp-filename-filter "Regexp filename filter")
+ (mfs-search-string "Search string")
+ (mfs-drscheme-multi-file-search "DrScheme - Multi File Search") ;; results window and error message title
+ (mfs-not-a-dir "\"~a\" is not a directory")
+ (mfs-open-file "Open File")
+ (mfs-stop-search "Stop Search")
+ (mfs-case-sensitive-label "Case sensitive")
+ (mfs-no-matches-found "No matches found.")
+ (mfs-search-interrupted "Search aborted.")
+ 
+ ;;; reverting a file
+ (error-reverting "DrScheme - Error Reverting")
+ (could-not-read "could not read \"~a\"")
+ (are-you-sure-revert
+  "Are you sure that you want to revert this file? This change cannot be undone.")
+ (are-you-sure-revert-title
+  "Revert?")
+ 
+ ;;; saving a file
+ ; ~a is filled with the filename
+ (error-saving "�存�失敗") ;; title of error message dialog
+ (error-saving-file/name "~a を�存中�エラー�発生����")
+ (error-loading "ロード�失敗")
+ (error-loading-file/name "~a をロード中�エラー�発生����")
+ (unknown-filename "<< unknown >>")
+
+ ;;; finder dialog
+ (must-specify-a-filename "You must specify a file name")
+ (file-does-not-exist "The file \"~a\" does not exist.")
+ (ask-because-file-exists "The file \"~a\" already exists. Replace it?")
+ (dne-or-cycle "The file \"~a\" contains a nonexistent directory or a cycle.")
+ (get-file "Get file")
+ (put-file "Put file")
+ (full-pathname "Full pathname")
+ (show-dot-files "Show files and directories that begin with a dot.")
+ (up-directory-button-label "Up directory")
+ (add-button-label "Add") ;;; for multi-file selection
+ (add-all-button-label "Add all") ;;; for multi-file selection
+ (remove-button-label "Remove") ;;; for multi-file selection
+ (file-wrong-form "That filename does not have the right form.")
+ (select-files "ファイル��択")
+ (select-file "ファイル��択")
+ (dir-dne "��ディレクトリ�存在���ん。")
+ (file-dne "��ファイル�存在���ん。")
+ (empty-filename "The filename must have some letters in it.")
+ (that-is-dir-name "�れ�ディレクトリ���。")
+ 
+ ;;; raw menu names -- these must match the 
+ ;;; versions below, once the &s have been stripped.
+ ;;; if they don't, DrScheme's menus will appear
+ ;;; in the wrong order.
+ (file-menu "ファイル(F)")
+ (edit-menu "編集(E)")
+ (help-menu "ヘルプ(H)")
+ (windows-menu "ウィンドウ(W)")
+ 
+ ;;; menus
+ ;;; - in menu labels, the & indicates a alt-key based shortcut.
+ ;;; - sometimes, things are stuck in the middle of 
+ ;;; menu item labels. For instance, in the case of
+ ;;; the "Save As" menu, you might see: "Save Definitions As". 
+ ;;; be careful of spacing, follow the English, if possible.
+ ;;; - the ellipses in the `after' strings indicates that
+ ;;; more information is required from the user before completing
+ ;;; the command.
+
+(file-menu-label "ファイル(&F)")
+
+ (new-info  "新�ファイルを開���")
+ (new-menu-item "新�作�(&N)")
+ (new-...-menu-item "新�作�(&N)...")
+
+ (open-info "ディスク�らファイルを開���")
+ (open-menu-item "開�(&O)...")
+ (open-here-menu-item "���開�(&O)...")
+
+ (open-recent-info "最近開��ファイル�一覧を表示���")
+ (open-recent-menu-item "最近開��ファイル")
+ 
+ (revert-info "��ファイルをディスク上�ファイル�戻���")
+ (revert-menu-item "復元(&R)")
+
+ (save-info "��ファイルをディスク��存���")
+ (save-menu-item "�存(&S)")
+
+ (save-as-info "��ファイル�ファイル�を指定��ディスク��存���")
+ (save-as-menu-item "��を付���存(&A)...")
+
+ (print-info "��ファイルをプリンタ��刷���")
+ (print-menu-item "�刷(&P)...")
+
+ (close-info "��ファイルを閉���")
+ (close-menu-item "閉�る(&C)")
+
+ (quit-info "����ウィンドウを閉���")
+ (quit-menu-item-windows "終了(&X)")
+ (quit-menu-item-others "&Quit")
+ 
+ (edit-menu-label "編集(&E)")
+ 
+ (undo-info "直��動作を元�戻���")
+ (undo-menu-item "元�戻�(&U)")
+
+ (redo-info "元�戻��直��動作を�実行���")
+ (redo-menu-item "やり直�(&R)")
+
+ (cut-info "�択項目を切り�りクリップボード�コピー���")
+ (cut-menu-item "切り�り(&U)")
+
+ (copy-info "�択項目をクリップボード�コピー���")
+ (copy-menu-item "コピー(&C)")
+
+ (paste-info "�在��択項目��直��コピー���切り�られ�項目を貼り付���")
+ (paste-menu-item "貼り付�(&P)")
+
+ (clear-info "�択項目を削除���")
+ (clear-menu-item-others "削除")
+ (clear-menu-item-windows "削除(&D)")
+
+ (select-all-info "文書全体を�択���")
+ (select-all-menu-item "����択(&L)")
+ 
+ (find-info "文字列を検索���")
+ (find-menu-item "検索...")
+
+ (find-again-info "直��検索文字列���文字列を検索���")
+ (find-again-menu-item "�検索")
+ 
+ (replace-and-find-again-info "�在�テキストを置���直��検索文字列���文字列を検索���")
+ (replace-and-find-again-menu-item "置���検索")
+
+ (preferences-info "環境設定を行���")
+ (preferences-menu-item "環境設定...")
+
+ (keybindings-info "�在有効�キー�インドを表示���")
+ (keybindings-menu-item "キー�インド")
+ (keybindings-show-active "�在有効�キー�インドを表示")
+ (keybindings-frame-title "キー�インド")
+ (keybindings-sort-by-name "���並�替�")
+ (keybindings-sort-by-key "キー�並�替�")
+ (keybindings-add-user-defined-keybindings "ユーザー定義�キー�インドを追加...")
+ (keybindings-menu-remove "~a を削除")
+ (keybindings-choose-user-defined-file "キー�インドを記述��ファイルを�択������")
+
+ (user-defined-keybinding-error "キー�インド ~a\n\n~a を実行中�エラー�発生����")
+ (user-defined-keybinding-malformed-file "ファイル ~a ���言語 (lib \"keybinding-lang.ss\" \"framework\") �書�れ�モジュール���れ����ん。")  
+  
+ ;; menu items in the "special" menu
+ (insert-text-box-item "テキストボックスを挿入")
+ (insert-pb-box-item "ペーストボード ボックスを挿入")
+ (insert-image-item "画�を挿入...")
+ (insert-comment-box-menu-item-label "コメント ボックスを挿入")
+ (insert-lambda "ラムダ(λ)を挿入")
+ (insert-delta "デルタ(定義)を挿入(&D)")
+
+ (wrap-text-item "テキストを折り返�")
+
+ (windows-menu-label "ウィンドウ(&W)")
+ (bring-frame-to-front "フレームを���移動")       ;;; title of dialog
+ (bring-frame-to-front... "フレームを���移動...") ;;; corresponding title of menu item
+ (next-window "次�ウィンドウ")
+ (previous-window "��ウィンドウ")
+ (most-recent-window "最近使用��ウィンドウ")
+
+ (view-menu-label "表示(&V)")
+ (show-overview "プログラム�外観を表示") 
+ (hide-overview "プログラム�外観を�表示")
+ (show-module-browser "モジュール ブラウザを表示")
+ (hide-module-browser "モジュール ブラウザを�表示")
+
+ (help-menu-label "ヘルプ(&H)")
+ (about-info "��アプリケーション�著作権�詳細情報を表示���")
+ (about-menu-item "�ージョン情報...")
+ (help-menu-check-for-updates "アップデート�確�...")
+ 
+ ;; open here's new menu item
+ (create-new-window-or-clear-current
+  "新�ウィンドウを作�����？�れ�も��在�ウィンドウを消去����？")
+ (clear-current "�在�ウィンドウを消去")
+ (new-window "新�ウィンドウを作�")
+
+ ;;; exiting and quitting ``are you sure'' dialog
+ ;;; exit is used on windows, quit on macos, in English. Other
+ ;;; languages probably use the same word on both platforms.
+ (exit "終了")
+ (quit "終了")
+ (are-you-sure-exit "終了��よ������？")
+ (are-you-sure-quit "終了��よ������？")
+ 
+ ;;; autosaving
+ (error-autosaving "\"~a\" を自動�存中�エラー�発生����。") ;; ~a will be a filename
+ (autosaving-turned-off "��ファイル��存�れる���\n自動�存�無効��り��。")
+ (recover-autosave-files-frame-title "自動�存ファイル�復元")
+ (autosave-details "詳細")
+ (autosave-recover "復元")
+ (autosave-unknown-filename "<<unknown>>")
+  
+  ;; these are labels in a dialog that drscheme displays
+  ;; if you have leftover autosave files. to see the dialog,
+  ;; start up drscheme and modify (but don't save) a file
+  ;; (also, do this with an unsaved file). Wait for the autosave
+  ;; files to appear (typically 5 minutes). Kill DrScheme
+  ;; and restart it. You'll see the dialog
+  (autosave-autosave-label: "自動�存ファイル:")
+  (autosave-original-label: "元�ファイル:")
+  (autosave-autosave-label "自動�存ファイル")
+  (autosave-original-label "元�ファイル")
+  (autosave-compare-files "自動�存ファイル�比較")
+
+  (autosave-show-autosave "自動�存ファイル") ;; title of a window showing the autosave file
+
+  (autosave-explanation "DrScheme �自動�存ファイルを検出����。自動�存ファイル���未�存�作業�果���れ��る�能性��り��。")
+
+  (autosave-recovered! "復元�����") ;; status of an autosave file
+  (autosave-deleted "削除����")       ;; status of an autosave file
+
+  (autosave-error-deleting "~a\nを削除中�エラー�発生����。\n~a") ;; first is a filename, second is an error message from mz.
+  (autosave-delete-button "削除")
+  (autosave-delete-title "削除")  ;; title of a dialog asking for deletion confirmation
+  (autosave-done "Done")
+  
+  ;; appears in the file dialog
+  (autosave-restore-to-where? "自動�存ファイルを�存�る場所を�択������。")
+  
+  
+ ;;; file modified warning
+ (file-has-been-modified
+  "��ファイル���回�存�れ�後�変更�れ����。変更を上書�����？")
+ (overwrite-file-button-label "上書�")
+ 
+ (definitions-modified 
+  "The definitions text has been modified in the file-system; please save or revert the definitions text.")
+ (drscheme-internal-error "DrScheme 内部エラー")
+ 
+ ;;; tools
+ (invalid-tool-spec "The tool specification in collection ~a's info.ss file is invalid. Expected either a string or a non-empty list of strings, got: ~e")
+ (error-loading-tool-title "DrScheme - Error loading tool ~s; ~s")
+ (error-invoking-tool-title "Error invoking tool ~s;~s")
+ (tool-tool-names-same-length
+  "expected `tool-names' and `tools' to be lists of the same length, in info.ss file for ~s, got ~e and ~e")
+ (tool-tool-icons-same-length
+  "expected `tool-icons' and `tools' to be lists of the same length, in info.ss file for ~s, got ~e and ~e")
+ (tool-tool-urls-same-length
+  "expected `tool-urls' and `tools' to be lists of the same length, in info.ss file for ~s, got ~e and ~e")
+ (error-getting-info-tool
+  "error loading info.ss file for ~s")
+ (tool-error-phase1 "Error in phase 1 for tool ~s; ~s")
+ (tool-error-phase2 "Error in phase 2 for tool ~s; ~s")
+
+
+ ;;; define popup menu
+ (end-of-buffer-define "<< �ッファ終端 >>")
+ (sort-by-name "���並�替�")
+ (sort-by-position "ファイル内��置�並�替�")
+ (no-definitions-found "<< 定義��り��ん >>")
+ (jump-to-defn "~a �定義�移動")
+
+ (recent-items-sort-by-age "日時�並�替�")
+ (recent-items-sort-by-name "���並�替�")
+ 
+ ;;; view menu
+ (hide-definitions-menu-item-label "定義を�表示(&D)")
+ (show-definitions-menu-item-label "定義を表示(&D)")
+ (definitions-menu-item-help-string "定義ウィンドウを表示/�表示���")
+ (show-interactions-menu-item-label "対話を表示(&I)")
+ (hide-interactions-menu-item-label "対話を�表示(&I)")
+ (interactions-menu-item-help-string "対話ウィンドウを表示/�表示���")
+ (show-toolbar "ツール�ーを表示(&T)")
+ (hide-toolbar "ツール�ーを�表示(&T)")
+
+ ;;; file menu
+ (save-definitions-as "定義���を付���存(&A)...")
+ (save-definitions "定義��存")
+ (print-definitions "定義を�刷...")
+ (about-drscheme "DrScheme����")
+ (save-other "��他��存")
+ (save-definitions-as-text "定義をテキスト��存...")
+ (save-interactions "対話��存")
+ (save-interactions-as "対話���を付���存...")
+ (save-interactions-as-text "対話をテキスト��存...")
+ (print-interactions "対話を�刷...")
+ (new-tab "新�タブ")
+ (close-tab "タブを閉�る") ;; must not have any &s in it.
+ 
+ ;;; edit-menu
+ (split-menu-item-label "分割(&S)")
+ (collapse-menu-item-label "分割解除(&O)")
+ 
+ ;;; language menu
+ (language-menu-name "言語(&L)")
+ 
+ ;;; scheme-menu
+ (scheme-menu-name "S&cheme")
+ (execute-menu-item-label "実行")
+ (execute-menu-item-help-string "定義ウィンドウ�プログラムを�開始���")
+ (break-menu-item-label "�止")
+ (break-menu-item-help-string "�在�評価を�止���")
+ (kill-menu-item-label "強制終了")
+ (kill-menu-item-help-string "�在�評価を強制終了���")
+ (clear-error-highlight-menu-item-label "エラー強調表示を消去")
+ (clear-error-highlight-item-help-string "ピンク色�エラー強調表示を消去���")
+ (reindent-menu-item-label "�インデント(&R)")
+ (reindent-all-menu-item-label "���を�インデント(&A)")
+ (semicolon-comment-out-menu-item-label "セミコロン�コメントアウト(&C)")
+ (box-comment-out-menu-item-label "ボックス�コメントアウト(&C)")
+ (uncomment-menu-item-label "コメント解除(&U)")
+
+ (convert-to-semicolon-comment "セミコロン コメント�変�")
+ 
+ ;;; executables
+ (create-executable-menu-item-label "実行ファイル�作�...")
+ (create-executable-title "実行ファイル�作�")
+ (must-save-before-executable "実行ファイルを作��る���プログラムを�存������。")
+ (save-an-executable "実行ファイル��存")
+ (save-a-mred-launcher "MrEd ラン�ャ��存")
+ (save-a-mzscheme-launcher "MzScheme ラン�ャ��存")
+ (save-a-mred-stand-alone-executable "MrEd スタンドアロン実行ファイル��存")
+ (save-a-mzscheme-stand-alone-executable "MzScheme スタンドアロン実行ファイル��存")
+
+ (definitions-not-saved "定義ウィンドウ��存�れ����ん。実行ファイル��定義ウィンドウ�最新��存�使�れ��。よ������？")
+ (inline-saved-program-in-executable?
+  "Inline the saved program in the executable? If yes, you can copy the executable to another ~a computer but the executable will be quite large. If not, you cannot copy the executable to another computer, but it will be much smaller. Additionally, if not, the executable will load the latest version of the program.")
+ (use-mred-binary?
+  "Use the mred binary for this executable?\n\nIf yes, your program can use the (lib \"mred.ss\" \"mred\") library. If no, DrScheme will use mzscheme as the binary for this executable and you cannot use that library.\n\nIf unsure, choose yes.")
+ (inline-saved-program-in-executable/windows/path
+   "WARNING! The generated executable relies on three DLLs: libmred.dll, libmzsch.gll, and libgc.dll, which are located at\n\n~a\n\nThe executable finds the DLLs either in the executable's directory or through the PATH enviornment variable.\n\nWhen you installed DrScheme, the installer adjusted the user's PATH to include the directory where the DLLs were installed. Beware of configuration or user changes since installation.\n\nIf you move the executable to another machine, you must also copy the DLLs to the other machine --- either to the same directory as the executable, or to a directory in the other machine's PATH.")
+ (launcher "ラン�ャ")
+ (stand-alone "スタンドアロン")
+ (executable-type "Type")
+ (executable-base "Base")
+ (filename "ファイル�: ")
+ (create "作�")
+ (please-choose-an-executable-filename "Please choose a filename to save the executable.")
+ (windows-executables-must-end-with-exe
+  "The filename\n\n  ~a\n\nis illegal. Under Windows, executables must end with .exe.")
+ (macosx-executables-must-end-with-app
+  "The filename\n\n  ~a\n\nis illegal. Under MacOS X, executables must end with .app.")
+ (warning-directory-will-be-replaced
+  "WARNING: the directory:\n\n  ~a\n\nwill be replaced. Proceed?")
+ 
+ (create-servlet "サーブレット�作�...")
+
+ ; the ~a is a language such as "module" or "algol60"
+ (create-servlet-unsupported-language
+  "言語 ~a ��サーブレット�作������ん。")
+  
+ ;;; buttons
+ (execute-button-label "実行") 
+ (save-button-label "�存")
+ (break-button-label "�止")
+ 
+ ;;; search help desk popup menu
+ (search-help-desk-for "Search in Help Desk for \"~a\"")
+ (exact-lucky-search-help-desk-for "Exact lucky search in Help Desk for \"~a\"")
+
+ ;; collapse and expand popup menu items
+ (collapse-sexp "S-�を縮�")
+ (expand-sexp "S-�を展開")
+ 
+ ;;; fraction dialog
+ (enter-fraction "Enter Fraction")
+ (whole-part "Whole Part")
+ (numerator "Numerator")
+ (denominator "Denominator")
+ (invalid-number "Invalid number: must be an exact, real, non-integral number.")
+ (insert-fraction-menu-item-label "Insert Fraction...")
+
+ ;; number snip popup menu
+ (show-decimal-expansion "View decimal expansion")
+ (show-fraction-view "View as fraction")
+ (show-mixed-fraction-view "View as mixed fraction")
+ (show-improper-fraction-view "View as improper fraction")
+ (show-more-decimal-places "Show more decimal places")
+ 
+ ;;; Teachpack messages
+ (select-a-teachpack "ティー�パックを�択")
+ (clear-teachpack "Clear ~a Teachpack")
+ (teachpack-error-label "DrScheme - Teachpack error")
+ (teachpack-dne/cant-read "The teachpack file ~a does not exist or is not readable.")
+ (teachpack-didnt-load "The teachpack file ~a did not load properly.")
+ (teachpack-error-invoke "The teachpack file ~a raised an error when invoked.")
+ (add-teachpack-menu-item-label "Add Teachpack...")
+ (clear-all-teachpacks-menu-item-label "Clear All Teachpacks")
+ (drscheme-teachpack-message-title "DrScheme Teachpack")
+ (already-added-teachpack "Already added ~a teachpack")
+ 
+ ;;; Language dialog
+ (introduction-to-language-dialog
+  "Please select a language. Students in most introductory courses should use the default language.")
+ (language-dialog-title "Choose Language")
+ (case-sensitive-label "Case sensitive")
+ (output-style-label "Output Style")
+ (constructor-printing-style "Constructor")
+ (quasiquote-printing-style "Quasiquote")
+ (write-printing-style "write")
+ (print-printing-style "current-print")
+ (sharing-printing-label "Show sharing in values")
+ (use-pretty-printer-label "Insert newlines in printed values")
+ (input-syntax "Input Syntax")
+ (dynamic-properties "Dynamic Properties")
+ (output-syntax "Output Syntax")
+ (no-debugging-or-profiling "No debugging or profiling")
+ (debugging "Debugging")
+ (debugging-and-profiling "Debugging and profiling")
+ (test-coverage "Syntactic test suite coverage")
+ (whole/fractional-exact-numbers-label "Print numbers as fractions")
+ (booleans-as-true/false-label "Print booleans using true and false")
+ (show-details-button-label "詳細を表示")
+ (hide-details-button-label "詳細を�表示")
+ (choose-language-menu-item-label "言語��択...")
+ (revert-to-language-defaults "Revert to Language Defaults")
+ (language-docs-button-label "Language Docs")
+ (fraction-style "Fraction Style")
+ (use-mixed-fractions "Mixed fractions")
+ (use-repeating-decimals "Repeating decimals")
+ (decimal-notation-for-rationals "Use decimal notation for rationals")
+ (please-select-a-language "Please select a language")
+
+ 
+ ;;; languages
+ (beginning-student "Beginning Student")
+ (beginning-one-line-summary "define, cond, structs, constants, and primitives")
+ (beginning-student/abbrev "Beginning Student with List Abbreviations")
+ (beginning/abbrev-one-line-summary "Beginner, with list style printing in the REPL")
+ (intermediate-student "Intermediate Student")
+ (intermediate-one-line-summary "Beginner plus lexical scope")
+ (intermediate-student/lambda "Intermediate Student with lambda")
+ (intermediate/lambda-one-line-summary "Intermediate plus higher-order functions")
+ (advanced-student "Advanced Student")
+ (advanced-one-line-summary "Intermediate plus lambda and mutation")
+ (full-language "Full") ;; also in the HtDP languages section
+ (how-to-design-programs "How to Design Programs") ;; should agree with MIT Press on this one...
+ (r5rs-like-languages "R5RS-like")
+ (pretty-big-scheme "Pretty Big (includes MrEd and Advanced)")
+ (pretty-big-scheme-one-line-summary "Adds syntax and functions from the HtDP languages")
+ (r5rs-lang-name "Standard (R5RS)")
+ (r5rs-one-line-summary "R5RS, with no frills")
+ (expander "Expander")
+ (expander-one-line-summary "Expands, rather than evaluates, expressions")
+ (professional-languages "Professional Languages")
+ (teaching-languages "Teaching Languages")
+ (experimental-languages "Experimental Languages")
+ 
+ (module-language-one-line-summary "Run creates a REPL in the context of the module, including the module's declared language")
+  
+
+ ;;; debug language
+ (unknown-debug-frame "[unknown]")
+ (backtrace-window-title "Backtrace - DrScheme")
+ (files-interactions "~a's interactions") ;; filled with a filename
+ (current-interactions "interactions")
+ (current-definitions "definitions")
+ (mzscheme-w/debug "Textual (MzScheme, includes R5RS)")
+ (mzscheme-one-line-summary "PLT's implementation Scheme")
+ (mred-w/debug "Graphical (MrEd, includes MzScheme)")
+ (mred-one-line-summary "Adds GUI support to MzScheme")
+
+ ;; profiling
+ (profiling-low-color "低�")
+ (profiling-high-color "高�")
+ (profiling-choose-low-color "低�Please select a low color")
+ (profiling-choose-high-color "Please select a high color")
+ (profiling "プロファイル")
+ (profiling-example-text "(define (whee) (whee))")
+ (profiling-color-config "プロファイル�カラー範囲") 
+ (profiling-scale "プロファイル�カラー尺度")
+ (profiling-sqrt "平方根")
+ (profiling-linear "ç·šåž‹")
+ (profiling-square "二乗")
+ (profiling-number "呼�出��回数")
+ (profiling-time "累�時間")
+ (profiling-clear "プロファイル�消去")
+ (profiling-update "プロファイル�更新")
+ (profiling-col-percent-time "% Time")
+ (profiling-col-function "関数")
+ (profiling-col-name "��")
+ (profiling-col-time-in-msec "ミリ秒")
+ (profiling-col-calls "Calls")
+ (profiling-show-profile "プロファイルを表示")
+ (profiling-hide-profile "プロファイルを�表示")
+ (profiling-unknown-src "<< unknown >>")
+ (profiling-no-information-available "プロファイル情報��り��ん。�使��言語�プロファイリングを有効���プロファイル対象�プログラムを実行������。")
+ (profiling-clear? "定義ウィンドウを書���る��プロファイル情報�無効��り��。よ������？")
+ 
+ ;; test coverage
+ (test-coverage-clear? "定義ウィンドウを書���る��テスト カ�レージ情報�無効��り��。よ������？")
+ (test-coverage-clear-and-do-not-ask-again "Yes, and don't ask again")
+ (test-coverage-ask? "Ask about clearing test coverage")
+  
+ ;; tracing
+ (tracing-enable-tracing "トレースを有効��る")
+ (tracing-show-tracing-window "トレースを表示")
+ (tracing-hide-tracing-window "トレースを�表示")
+ (tracing-tracing-nothing-to-show "トーレス�果��り��ん。�使��言語�トレース�サ�ート�れ��る��を確���トレースを有効�������。")
+
+ ;;; repl stuff
+ (evaluation-terminated "評価�終了����。")
+ (evaluation-terminated-explanation
+  "評価スレッド�も�実行�れ����ん���次�実行�る���評価�行�れ��ん。")
+ (last-stack-frame "最後�スタックフレームを表示�る")
+ (last-stack-frames "最後�  ~a スタックフレームを表示�る")
+ (next-stack-frames "次� ~a スタックフレームを表示�る")
+ 
+ ;;; welcoming message in repl
+ (language "言語")
+ (custom "カスタム")
+ (teachpack "ティー�パック")
+ (welcome-to "よ���")
+ (version "�ージョン")
+ 
+ ;;; kill evaluation dialog
+ (kill-evaluation? "評価を強制終了����？")
+ (just-break "Just Break")
+ (kill "強制終了")
+ (kill? "強制終了？")
+
+ ;;; version checker
+ ;; the next two are used in the initial wizard dialog.
+ ;; Note that vc-wizard-check-prompt can (should) have newlines so
+ ;; it will not make the dialog too wide.
+ (vc-wizard-check-note "The version you are about to install may not be the latest\n one. If you would like, DrScheme can check for you.")
+ (vc-wizard-check-button "Check for Updates")
+ (vc-update-check "Update check")
+ (vc-please-wait "Please wait")
+ (vc-connecting-version-server "Connecting to PLT version server")
+ (vc-network-timeout "Network timeout") 
+ (vc-cannot-connect  "Can't connect to PLT version server")
+ (vc-network-failure "Network failure")
+ (vc-old-binaries "Installed binaries for DrScheme (or MzScheme) are not up-to-date")
+ (vc-binary-information-format "Installed binary version: ~a (iteration ~a)")
+ (vc-details-format "~a~nDetails:~n~a")
+ (vc-details-text "Details:~n")
+ (vc-error-format "Error: ~a") 
+ (vc-current-format "~a v.~a (iteration ~a) is up-to-date")
+ (vc-update-format "~a v.~a (iteration ~a) needs updating to v.~a (iteration ~a)")
+ (vc-binary-name "Binary")
+ (vc-updates-available "Updates are available at")
+ (vc-latest-binary-information-format "Latest released version: ~a (iteration ~a)")
+ (vc-update-dialog-title "PLT update status")
+ (vc-need-update-string "One or more installed PLT software packages needs updating")
+ (vc-no-update-string "All installed PLT software packages are up-to-date")
+
+ ;; special menu
+ (special-menu "特殊(&P)")
+ 
+ ;; large semi colon letters
+ (insert-large-letters... "大��文字を挿入...")
+ (large-semicolon-letters "大��セミコロン")
+ (text-to-insert "挿入�る文字列")
+
+ (module-browser-filename-format "完全�ファイル�: ~a (~a 行)")
+ (module-browser-root-filename "ルート ファイル�: ~a")
+ (module-browser-font-size-gauge-label "フォント サイズ")
+ (module-browser-progress-label "Module overview progress")
+ (module-browser-adding-file "ファイルを追加�����: ~a...")
+ (module-browser-laying-out-graph-label "グラフを�置�����")
+ (module-browser-open-file-format "開� ~a")
+ (module-browser "モジュール ブラウザ") ;; frame title
+ (module-browser... "モジュール ブラウザ...") ;; menu item title
+ (module-browser-error-expanding "Error expanding the program:\n\n~a")
+ (module-browser-show-lib-paths "Show files loaded by (lib ..) paths")
+ (module-browser-progress "Module Browser: ~a") ;; prefix in the status line
+ (module-browser-compiling-defns "Module Browser: compiling definitions")
+ (module-browser-show-lib-paths/short "Follow lib requires") ;; check box label in show module browser pane in drscheme window.
+ (module-browser-refresh "Refresh") ;; button label in show module browser pane in drscheme window.
+ (module-browser-only-in-plt-and-module-langs
+  "The module browser is only available for programs in the PLT languages and in the module language (and only for programs that have modules in them).")
+ (module-browser-name-length "���長�")
+ (module-browser-name-short "短�")
+ (module-browser-name-medium "普通")
+ (module-browser-name-long "長�")
+ (module-browser-open-all "���表示�れ��る����ファイルを開�")
+
+ (happy-birthday-matthias "�誕生日�����, Matthias!")
+ (happy-birthday-matthew "�誕生日�����, Matthew!")
+ (happy-birthday-shriram "�誕生日�����, Shriram!")
+
+ (mrflow-using-default-language-title "既定�使用�る言語")
+ (mrflow-using-default-language "�在使用���る言語�����プリミティブ用�型テーブル��り��ん。代替��� R5RS Scheme を使���。")
+ (mrflow-button-title "解�")
+ ;(mrflow-unknown-style-delta-error-title "Unknown Box Style Delta")
+ ;(mrflow-unknown-style-delta-error "Unknown box style delta: ~a")
+ (mrflow-coloring-error-title "未知�カラー")
+ (mrflow-coloring-error "No style defined for color: ~a")
+ (mrflow-popup-menu-show-type "Show Type")
+ (mrflow-popup-menu-hide-type "Hide Type")
+ (mrflow-popup-menu-show-errors "表示エラー")
+ (mrflow-popup-menu-hide-errors "�表示エラー")
+ ;(mrflow-read-exception-title "Read Exception")
+ ;(mrflow-read-exception "Read exception: ~a")
+ ;(mrflow-syntax-exception-title "Syntax Exception")
+ ;(mrflow-syntax-exception "Syntax exception: ~a")
+ ;(mrflow-unknown-exception-title "Unknown Exception")
+ ;(mrflow-unknown-exception "Unknown exception: ~a")
+ ;(mrflow-language-primitives-error-title "Language Primitives Error")
+ ;(mrflow-language-primitives-error "Wrong filename for language primitives types table: ~a")
+  
+ (snips-and-arrows-popup-menu-tack-all-arrows "Tack All Arrows")
+ (snips-and-arrows-popup-menu-untack-all-arrows "Untack All Arrows")
+ (snips-and-arrows-user-action-disallowed-title "User Changes Currently Disallowed")
+ (snips-and-arrows-user-action-disallowed "User changes are disallowed in editors that contain tool-inserted snips.  Hide all snips before modifying the content of the editor.")
+ ;(snips-and-arrows-changing-terms-warning-title "Changing terms will be undoable")
+ ;(snips-and-arrows-changing-terms-warning "Changing terms in an editor containing snips cannot be undone.  You can either cancel this action, remove the snips, and try the change again, or you can continue with the change, in which case the change will not be undoable (all others changes made before and afterward will still be undoable though).")
+ (snips-and-arrows-hide-all-snips-in-editor "Hide all snips in editor")
+
+ (xml-tool-menu "XML")
+ (xml-tool-insert-xml-box "XML ボックスを挿入")
+ (xml-tool-insert-scheme-box "Scheme ボックスを挿入")
+ (xml-tool-insert-scheme-splice-box "Scheme Splice ボックスを挿入")
+ (xml-tool-xml-box "XML ボックス")
+ (xml-tool-scheme-box "Scheme ボックス")
+ (xml-tool-scheme-splice-box "Scheme Splice ボックス")
+ (xml-tool-switch-to-scheme "Scheme ボックス�切り替�")
+ (xml-tool-switch-to-scheme-splice "Scheme Splice ボックス�切り替�")
+ (xml-tool-eliminate-whitespace-in-empty-tags
+  "空タグ内�空白を削除")
+ (xml-tool-leave-whitespace-alone
+  "空白を残�")
+ 
+ (show-recent-items-window-menu-item "最近開��ファイルを別ウィンドウ�表示�る")
+ (show-recent-items-window-label "最近開��ファイル")
+ (number-of-open-recent-items "Number of recent items")
+ (switch-anyway "Switch File Anyway")
+
+ (stepper-program-has-changed "警告: プログラム�変更�れ���。")
+ (stepper-program-window-closed "警告: プログラム ウィンドウ�閉����。")
+
+ (stepper-home "Home")
+ (stepper-name "Stepper")
+ (stepper-language-level-message
+  "The language level is set to \"~a\". Currently, the stepper works only for the \"~a\" through the \"~a\" language levels.")
+ (stepper-button-label "Step")
+ (stepper-previous-application "|< Application")
+ (stepper-previous "< Step")
+ (stepper-next "Step >")
+ (stepper-next-application "Application >|")
+ 
+
+ (wizard-next "次�")
+ (wizard-back "戻る")
+ (wizard-finish "完了")
+
+ ;; warnings about closing a drscheme frame when the program
+ ;; might still be doing something interesting
+ (program-is-still-running "定義ウィンドウ内�プログラム�実行中��。強制的�閉����？")
+  (program-has-open-windows "定義ウィンドウ内�プログラム�ウィンドウを開�����。��ウィンドウを強制的�閉����？")
+ 
+  ;; ml-command-line-arguments is for the command line arguments
+  ;; label in the module language details in the language dialog.
+  (ml-command-line-arguments "Command-line arguments as a vector of strings, in read syntax")
+
+  ;; ml-cp names are all for the module language collection path
+  ;; configuration. See the details portion of the language dialog
+  ;; for the module language (at the bottom).
+  (ml-cp-default-collection-path "<<default collection paths>>")
+
+  ;; in std get-directory 
+  (ml-cp-choose-a-collection-path "Please choose a collection path")
+
+  ;; err msg when adding default twice
+  (ml-cp-default-already-present
+   "Default collection paths are already present")
+  
+  ;; title of this section of the dialog (possibly the word
+  ;; `Collection' should not be translated)
+  (ml-cp-collection-paths "Collection Paths")
+
+  ;; button labels
+  (ml-cp-add "Add")
+  (ml-cp-add-default "Add Default")
+  (ml-cp-remove "Remove")
+  (ml-cp-raise "Raise")
+  (ml-cp-lower "Lower")
+
+  ;; Profj
+  (profj-java "Java")
+  (profj-java-mode "Java モード")
+  (profj-java-mode-color-keyword "キーワード")
+  (profj-java-mode-color-string "文字列")
+  (profj-java-mode-color-literal "リテラル")
+  (profj-java-mode-color-comment "コメント")
+  (profj-java-mode-color-error "エラー")
+  (profj-java-mode-color-identifier "識別�")
+  (profj-java-mode-color-default "デフォルト")
+
+  (profj-insert-java-comment-box "Java コメント ボックスを挿入")
+  (profj-insert-java-interactions-box "Java 対話ボックスを挿入")
+
+  ;; The Test Suite Tool
+  ;; Errors
+  (test-case-empty-error "Empty test case")
+  (test-case-too-many-expressions-error "Too many expressions in a test case.")
+  (test-case-not-at-top-level "Test case box not at top level")
+  ;; Dr. Scheme window menu items
+  (test-case-insert "Insert Test Case")
+  (test-case-disable-all "Disable all Test Cases")
+  (test-case-enable-all "Enable all Test Cases")
+  
+  ;; NOTE: The following string constants are labels of the test-case fields. The width
+  ;;       of the field is determined by the length of the longest of the following three words.
+  ;;       if the words are too long the test case will take up too much horizontal room and
+  ;;       not look very good.
+  ;; This string is the label of the expression that is being tested in a test case.
+  (test-case-to-test "Test")
+  ;; This string is the label of the expression that is the expected value of the to-test expression.
+  (test-case-expected "Should be")
+  ;; This string is the label of the actual result of the to test expression.
+  (test-case-actual "Actual")
+  (test-case-predicate "Predicate")
+  (test-case-should-raise "Should Raise")
+  ;; The label of a field of the test-case that describes the expected error message of a test case
+  (test-case-error-message "Error Message")
+
+  (test-case-menu-title "Test Case")
+  (test-case-switch-to-error-box "Switch to Error Test Box")
+  (test-case-switch-to-nonerror-box "Switch to Nonerror Test box")
+  (test-case-collapse "Collapse Test Case")
+  (test-case-show-actual "Show Actual Value")
+  (test-case-enable "Enable Test Case")
+  (test-case-show-predicate "Show Predicate")
+  (test-case-show-error-message "Show Error Message")
+  (test-case-convert-to-text "Convert to text")
+  
+  ;; Profj Boxes
+  (profjBoxes-empty-error "Empty interaction")
+  (profjBoxes-too-many-expressions-error "Too many expressions in a box")
+  (profjBoxes-interactions-label "Interactions")
+  (profjBoxes-bad-java-id-error "Malformed Java ID")
+  (profjBoxes-examples-label "Examples")
+  (profjBoxes-add-new-example-button "Add new example")
+  (profjBoxes-type "Type")
+  ;; The Java identifier of an example of data
+  (profjBoxes-name "Name")
+  (profjBoxes-value "Value")
+  (profjBoxes-insert-java-examples "Insert Java Examples")
+  (profjBoxes-insert-java-interactions "Insert Java Interactions")
+
+  ;; Slideshow
+  (slideshow-show-slideshow-panel "Show Slideshow Panel")
+  (slideshow-hide-slideshow-panel "Hide Slideshow Panel")
+  (slideshow-freeze-picts "Freeze These Picts")
+  (slideshow-thaw-picts "Show Picts Under Mouse")
+  (slideshow-hide-picts "Show Nested Boxes")
+  (slideshow-show-picts "Show Picts")
+  (slideshow-cannot-show-picts "Cannot show picts; run program to cache sizes first")
+  (slideshow-insert-pict-box "Insert Pict Box") 
+
+  ;; GUI Tool
+  (gui-tool-heading "GUI Tool")
+  (gui-tool-before-clicking-message "Before clicking a tool icon, use \"Insert GUI\" from the \"Special\" menu to insert a root GUI item, or select an already inserted GUI.")
+  (gui-tool-show-gui-toolbar "Show GUI Toolbar")
+  (gui-tool-hide-gui-toolbar "Hide GUI Toolbar")
+  (gui-tool-insert-gui "Insert GUI")
+  )
diff --git a/collects/string-constants/private/only-once.ss b/collects/string-constants/private/only-once.ss
new file mode 100644
index 0000000000..c742b146e0
--- /dev/null
+++ b/collects/string-constants/private/only-once.ss
@@ -0,0 +1,13 @@
+(module only-once mzscheme
+  (provide maybe-print-message)
+  
+  (define already-printed? #f)
+  
+  (define (maybe-print-message msg)
+    (unless already-printed?
+      (set! already-printed? #t)
+      ;; the output port may no longer be there, in which case
+      ;; we just give up on printing
+      (with-handlers ([exn:fail? (lambda (x) (void))])
+        (fprintf (current-error-port) "~a" msg)))))
+
diff --git a/collects/string-constants/simplified-chinese-string-constants.ss b/collects/string-constants/simplified-chinese-string-constants.ss
new file mode 100644
index 0000000000..734e42c192
--- /dev/null
+++ b/collects/string-constants/simplified-chinese-string-constants.ss
@@ -0,0 +1,9 @@
+(module simplified-chinese-string-constants "string-constant-lang.ss"
+ (is-this-your-native-language "Is Chinese (in Simplified Characters) Your Native Language?")
+ (interact-with-drscheme-in-language "Interact with DrScheme in Simplified Chinese")
+ (welcome-to-something "Welcome to ~a")
+ (welcome-to "Welcome to")
+ (welcome-to-drscheme-version/language "Welcome to DrScheme, version ~a, ~a")
+
+ ; these appear on subsequent lines in the `Help|Welcome to DrScheme' dialog.
+ (welcome-to-drscheme "Welcome to DrScheme"))
diff --git a/collects/string-constants/spanish-string-constants.ss b/collects/string-constants/spanish-string-constants.ss
new file mode 100644
index 0000000000..456c6b2983
--- /dev/null
+++ b/collects/string-constants/spanish-string-constants.ss
@@ -0,0 +1,1151 @@
+(module spanish-string-constants "string-constant-lang.ss"
+
+ ;;; when translating this constant, substitue name of actual langauge for `English'
+ (is-this-your-native-language
+  "¿Es español tu idioma materno?")
+
+ (interact-with-drscheme-in-language "Interactúa con DrScheme en Español")
+
+ (are-you-sure-you-want-to-switch-languages
+  "Esto cambiará el idioma de la interfaz, lo que requiere que reinicies DrScheme. ¿Estas seguro(a)?")
+ 
+
+ (accept-and-quit "Aceptar y salir")
+ (accept-and-exit "Aceptar y salir")
+
+ ;;; general purpose (DrScheme is hereby a word in every language, by decree of Robby :)
+ (plt "PLT")
+ (drscheme "DrScheme")
+ (ok "OK")
+ (cancel "Cancelar")
+ (abort "Abortar")
+ (untitled "Sin título")
+ (untitled-n "Sin título ~a")
+ (warning "Advertencia")
+ (error "Error")
+ (close "Cerrar") ;; as in, close an open window
+ (stop "Detener")
+ (&stop "&Detener")
+ (are-you-sure-delete? "¿Seguro(a) quieres borrar ~a?") ;; ~a is a filename or directory name
+ (ignore "Ignorar")
+ (revert "Revertir")
+
+ ;; label for a generic check box, often supported on dialogs
+ ;; that ask a binary choice of the user. If checked, the
+ ;; dialog isn't going to be shown again.
+ (dont-ask-again "No volver a preguntar (usar la selección actual siempre)")
+ 
+ ;; important urls
+ (web-materials "Sitios de Web Relacionados")
+ (tool-web-sites "Sitios de Web de Herramientas")   ;; menu item title
+ (drscheme-homepage "DrScheme")
+ (plt-homepage "PLT")
+ (how-to-use-scheme "Cómo Usar Scheme")
+ (teachscheme!-homepage "TeachScheme!")
+ 
+ ;;; bug report form
+ (cancel-bug-report? "¿Cancelar el reporte de problemas?")
+ (are-you-sure-cancel-bug-report?
+  "¿Estas seguro que quieres cancelar el envío de éste reporte de problemas?")
+ (bug-report-form "Forma para reportar problemas")
+ (bug-report-field-name "Nombre")
+ (bug-report-field-email "Correo Electrónico")
+ (bug-report-field-summary "Resumen")
+ (bug-report-field-severity "Gravedad")
+ (bug-report-field-class "Clase")
+ (bug-report-field-priority "Propiedad")
+ (bug-report-field-description "Descripción")
+ (bug-report-field-reproduce1 "Pasos para")
+ (bug-report-field-reproduce2 "Reproducir")
+ (bug-report-field-environment "Ambiente")
+ (bug-report-field-tools "Herramientas")
+ (bug-report-field-docs-installed "Documentos instalados")
+ (bug-report-field-language "Lenguaje")
+ (bug-report-field-teachpacks "Paquetes de enseñanza")
+ (bug-report-field-collections "Colecciones")
+ (bug-report-field-human-language "Idioma")
+ (bug-report-field-version "Versión")
+ (bug-report-synthesized-information "Información sintetizada")  ;; dialog title
+ (bug-report-show-synthesized-info "Muestra información resumida")
+ (bug-report-submit "Enviar")
+ (bug-report-submit-menu-item "Enviar reporte de problemas") ;; in Help Menu (drs & help desk)
+ (sending-bug-report "Enviando reporte de problemas")
+ (error-sending-bug-report "Error al enviar el reporte de problemas")
+ (error-sending-bug-report-expln "Un error ocurrió mientras enviaba éste reporte de problemas.  Si tu conexión a Internet está funcionando bien, por favor visita:\n\n    http://bugs.plt-scheme.org/\n\ny envía el reporte de problemas por medio de la forma de web en esea página de WEB. Sentimos mucho las molestias que esto te ocasiona.\n\nEl mensaje de error es:\n~a")
+ (bug-report-sent "Reporte de problemas enviado")
+ (bug-report-sent-detail "Gracias por el reporte. Recibirás una confirmación por correo electrónico en los siguientes 30 minutos. Si dicho mensaje no llega, envía un mensaje a scheme@plt-scheme.org.")
+ (illegal-bug-report "Reporte de problemas ilegal")
+ (pls-fill-in-field "Por favor requisita el campo \"~a\"")
+ (malformed-email-address "Dirección de correo electrónico inválida")
+ (pls-fill-in-either-description-or-reproduce "Por favor requisita el campo de Descripción o el de Pasos para Reproducir.")
+
+ ;;; check syntax
+ (check-syntax "Revisa la sintáxis")
+ (cs-italic "Itálica")
+ (cs-bold "Negrita")
+ (cs-underline "Subrayado")
+ (cs-change-color "Cambiar color")
+ (cs-tack/untack-arrow "Anclar/Liberar flecha")
+ (cs-jump-to-next-bound-occurrence "Saltar a la Siguiente Ocurrencia Ligada")
+ (cs-jump-to-binding "Saltar a Ocurrencia Ligada")
+ (cs-jump-to-definition "Saltar a la Definición")
+ (cs-error-message "Mensaje de error")
+ (cs-open-file "Abrir ~a")
+ (cs-rename-var "Renombrar ~a")
+ (cs-rename-id "Renombrar identificador")
+ (cs-rename-var-to "Renombrar ~a a:")
+ (cs-name-duplication-error "El nuevo nombre que has seleccionado, ~s, colisiona con otro nombre en este ambiente.")
+ (cs-rename-anyway "Renombrar de cualquier modo")
+ (cs-status-init "Checar sintaxis: Iniciando el ambiente para el código de usuario")
+ (cs-status-coloring-program "Checar sintaxis: coloreando la expresión")
+ (cs-status-eval-compile-time "Checar sintaxis: tiempo de evaluación y compilación")
+ (cs-status-expanding-expression "Checar sintaxis: expandiendo la expresión")
+ (cs-mouse-over-import "Asociación ~s importada desde ~s")
+ 
+ (cs-lexical-variable "variable léxica")
+ (cs-lexical-syntax "sintaxis léxica")
+ (cs-imported-variable "variable importada")
+ (cs-imported-syntax "sintaxis importada")
+ 
+ 
+ ;;; info bar at botttom of drscheme frame
+ (collect-button-label "Recolectar")
+ (read-only "Sólo lectura")
+ (read/write "Lectura/Escritura")
+ (auto-extend-selection "Selección Auto-Extendida")
+ (overwrite "Sobreescribir")
+ (running "ejecutando")
+ (not-running "suspendido") 
+ 
+ ;;; misc
+ (welcome-to-something "Bienvenido a ~a")
+ 
+ ; this appears in the drscheme about box.
+ (welcome-to-drscheme-version/language "Bienvenido a DrScheme, versión ~a, ~a")
+
+ ; these appear on subsequent lines in the `Help|Welcome to DrScheme' dialog.
+ (welcome-to-drscheme "Bienvenido a DrScheme")
+ (version/language "versión ~a, ~a")
+
+ (goto-line "Ir a la línea")
+ (goto-line-invalid-number
+  "~a no es un número de línea válido. Debe ser un entero entre 1 y ~a")
+ (goto-position "Ir a la posición")
+ (no-full-name-since-not-saved
+  "El archivo no tienen un nombre completo porque no ha sido salvado aún.")
+ (cannot-open-because-dne "~a no puede ser abierto, porque no existe.")
+ (interactions-out-of-sync
+  "ADVERTENCIA: La ventana de interacción está fuera de sincronía con la ventana de definición.  Presione el botón Ejecutar.")
+ (file-is-not-saved "El archivo \"~a\" no ha sido salvado.")
+ (save "Salvar")
+ (please-choose-either "Por favor seleccione una de \"~a\" o \"~a\"")
+ (close-anyway "Cerrar y descartar cambios")
+ (clear-anyway "Limpiar")
+
+ ;; menu item title
+ (log-definitions-and-interactions "Guardar bitácora de Definiciones e Interacciones...")
+ (stop-logging "Terminar bitácora")
+ (please-choose-a-log-directory "Por favor seleccione un directorio para almacenar bitácora")
+ (logging-to "Guardando bitácora en: ")
+ (erase-log-directory-contents "¿Borrar el contenido del directorio de bitácoras: ~a?")
+ (error-erasing-log-directory "Error al borrar el contenido del directorio de bitácoras.\n\n~a\n")
+
+  ;; modes
+ (mode-submenu-label "Modos")
+ (scheme-mode "Modo Scheme")
+ (text-mode "Modo Texto")
+
+ (scheme-mode-color-symbol "Símbolo")
+ (scheme-mode-color-keyword "Llave")
+ (scheme-mode-color-comment "Comentario")
+ (scheme-mode-color-string "Cadena")
+ (scheme-mode-color-constant "Constante")
+ (scheme-mode-color-parenthesis "Paréntesis")
+ (scheme-mode-color-error "Error")
+ (scheme-mode-color-other "Otro")
+  ;; the ~a is filled in with one of the above (scheme-mode-*)
+ (syntax-coloring-choose-color "Escoge un color para: ~a")
+ (preferences-colors "Colores") ;; used in the preferences dialog
+
+ (url "URL")
+ (url: "URL:")
+ (open-url... "Abre URL...")
+ (open-url "Abre URL")
+ (browse... "Navega...")
+ (bad-url "URL Inválido")
+ (bad-url:this "URL Inválido: ~a")
+ 
+ ;; Help Desk
+ (help "Ayuda")
+ (help-desk "Módulo de Ayuda")
+ (plt:hd:search-results "Buscar resultados")
+ (plt:hd:search "Buscar")
+ (plt:hd:search-for "Busca")
+ (plt:hd:lucky "¡Afortunado!")
+ (plt:hd:feeling-lucky "Me siento afortunado")
+ (plt:hd:stop "Detener")    
+ (plt:hd:options "Opciones")
+ (plt:hd:configure "Configurar")
+ (plt:hd:home "Hogar del Módulo de Ayuda")
+ (plt:hd:show-manuals "Mostrar manuales")
+ (plt:hd:send-bug-report "Enviar reporte de problemas")
+ (plt:hd:query-bug-reports "Buscar en los reporetes de problemas")
+ ; next 3 are popup menu choices at bottom of help desk window
+ (plt:hd:search-for-keyword "por Palabra clave")
+ (plt:hd:search-for-keyword-or-index "por palabra clave o entrada en el índice")
+ (plt:hd:search-for-keyword-or-index-or-text "por palabra clave, entrada en el índice o texto")
+ (plt:hd:exact-match "patrón exacto") ;; exact match??
+ (plt:hd:containing-match "subcadena") ;; containing match ??
+ (plt:hd:regexp-match "expresión regular") ;; match regexp
+ (plt:hd:find-docs-for "Encuentra documentación sobre:")
+ (plt:hd:nothing-found-for-search-key "No se encontró nada con \"~a\".")
+ (plt:hd:searching "Buscando...")
+ (plt:hd:search-stopped "(Búsqueda detenida.)")
+ (plt:hd:search-stopped-too-many-matches "(Búsqueda detenida - demasiados patrones casan.)")
+ (plt:hd:nothing-found-for "Nada casa con ~a")
+ (plt:hd:error-finding-docs "No pude encontrar la documentación.\n\n~a")
+ (plt:hd:and "y")
+ (plt:hd:refresh "refrescar")
+ (plt:hd:refresh-all-manuals "refrescar todos los manuales")
+ (plt:hd:manual-installed-date "(~a instalado)")
+ ;; Help Desk configuration
+ (plt:hd:configuration "Configuración del Módulo de Ayuda PLT")
+ (plt:hd:no-frames "Sin ventanas (frames)")
+ (plt:hd:use-frames "Usar ventanas (frames)")
+ (plt:hd:use-html-frames "Usar ventanas de HTML")
+ (plt:hd:search-pane-options "Buscar opciones de pantalla")
+ (plt:hd:height "Altura")
+ (plt:hd:bg-color "Color del fondo")
+ (plt:hd:pixels "pixeles")
+ (plt:hd:text-color "Color del texto")
+ (plt:hd:link-color "Color de ligas")
+ (plt:hd:text-sample "El texto en las búsquedas aparece en este color")
+ (plt:hd:link-sample "Las ligas son mostradas en este color")
+ (plt:hd:save-changes "Salvar cambios")
+ (plt:hd:reset "Reajuste")
+ (plt:hd:defaults "Valores por omisión")
+ (plt:hd:javascript-note
+  "La selección que hagas aparecerá aquí si haz habilitado javascript y tienes un navegador estándar reciente.")
+ ;; refreshing manuals
+ (plt:hd:refresh-downloading "Bajando ~a")
+ (plt:hd:refresh-installing "Instalando ~a")
+ (plt:hd:refresh-progress "Progreso de la descarga del manual del PLT")
+;; should not mention `SVN' (plt:hd:refresh-done "Refresco de los manuales via SVN terminado")
+ (plt:hd:refresh-installation-log "Bitácora de instalación")
+ (plt:hd:refresh-stopped "Refresco de manuales del PLT detenido")
+ (plt:hd:refresh-clearing-indicies "Eliminando índices guardados")
+ (plt:hd:refresh-deleting... "Borrando la versión vieja de ~a...")
+ (plt:hd:refresh-downloading... "Bajando ~a...")
+ (plt:hd:refresh-installing... "Instalando nueva versión de ~a...")
+ (plt:hd:refresh-clearing-indicies "Eliminando indices almacenados")
+ (plt:hd:refreshing-manuals "Bajando (nuevamente) los Manuales")
+ (plt:hd:refreshing-manuals-finished "Terminado.")
+ (plt:hd:about-help-desk "Acerca del Módulo de Ayuda")
+ (plt:hd:help-desk-about-string
+  "El Módulo de Ayuda es una fuente complete de información acerca del software del grupo PLT, incluyendo DrScheme, MzScheme y MrEd.\n\nVersión ~a\nCopyright (c) 1995-2003 PLT")
+ (plt:hd:help-on-help "Ayuda para la ayuda")
+ (plt:hd:help-on-help-details "Para ayuda sobre el uso del Módulo de Ayuda, sigue la liga `Cómo usar el Módulo de Ayuda' desde el página principal del Módulo de Ayuda.  (Para llegar a la página principal si no estás ahí ya, presiona el botón marcado `Hogar' en la parte superior de la ventana del Módulo de Ayuda.")
+ (plt:hd:ask-about-separate-browser
+  "Ha seleccionado una liga que apunta a contenido en el Web.  ¿Le gustaría visitarlo en el navegador del Módulo de Ayuda o le gustaría usar un navegador separado para ver dicho contenido?")
+ (plt:hd:homebrew-browser "Navegador del Módulo de Ayuda") ;; choice for the above string (in a button)
+ (plt:hd:separate-browser "Navegador separado") ;; other choice for the above string (also in a button)
+ (plt:hd:external-link-in-help "URLs externos en Ayuda")
+ (plt:hd:use-homebrew-browser "Usar el Navegador del Módulo de Ayuda para URL externos")
+ (plt:hd:new-help-desk "Nuevo Módulo de Ayuda")
+ (plt:hd:teaching-manuals "Manuales para estudiantes")
+ (plt:hd:professional-manuals "Manuales para profesionales")
+ (plt:hd:all-manuals "Todos los manuales")
+
+ ;; in the Help Desk language dialog, title on the right.
+ (plt:hd:manual-search-ordering "Orden de búsqueda en manuales")
+ 
+ (reload "Volver a cargar") ;; Reload
+
+
+ ;; help desk http proxy
+ (http-proxy "Proxy de HTTP")
+ (proxy-direct-connection "Coneción Directa")
+ (proxy-use-proxy "Utilizar proxy:")
+ (proxy-host "Host")
+ (proxy-port "Port")
+ (proxy-bad-host "El Host Proxy está mal especificado")
+
+    ;;browser
+ (rewind-in-browser-history "Revertir")
+ (forward-in-browser-history "Adelante")
+ (home "Hogar")
+ (browser "Navegador")
+ (external-browser-choice-title "Navegador externo") ; title for radio-button set
+ (browser-command-line-label "Línea de comandos:") ; label for radio button that is followed by text boxes
+ (choose-browser "Escoge un navegador")
+ (no-browser "Preguntar más tarde")
+ (use-internal-browser-for-help "Leer ayuda con el navegador interno de PLT") ; radio-button label
+ (use-external-browser-for-help "Leer ayuda con un navegador externo") ; radio-button label
+ (browser-cmdline-expl-line-1 "(línea de comando formada concatenando pre-text, URL,") ; explanatory text for dialog, line 1
+ (browser-cmdline-expl-line-2 "y post-text, sin espacios extra entre ellos.)") ; ... line 2. (Anyone need more lines?)
+ (cannot-display-url "No puedeo desplegar el URL ~s: ~a")
+ (install? "¿Instalar?")  ;; if a .plt file is found (title of dialog)
+ (you-have-selected-an-installable-package "Ha seleccionado un paquete instalable.")
+ (do-you-want-to-install-it? "¿Desea intalarlo?")
+ (paren-file-size "(El archivo mide ~a bytes)")
+ (download-and-install "Descargar && Instalar")
+ (download "Descargar")
+ (save-downloaded-file "Salvar el archivo descargado como")
+ (save-downloaded-file/size "Salvar el archivo descargado (~a bytes) como")
+ (downloading "Descargar")
+ (downloading-file... "Descargando archivo...")
+ (package-was-installed "El paquete fué instalado.")
+ (download-was-saved "Se ha salvado el archivo descargado.")
+ (getting-page "Obteniendo Página")
+
+ (install-plt-file-menu-item... "Instalar archivo .plt ...")
+ (install-plt-file-dialog-title "Instalar archivo .plt")
+ (install-plt-web-tab "Web")
+ (install-plt-file-tab "Archivo")
+ (install-plt-filename "Nombre de Archivo:")
+ (install-plt-url "URL:")
+ 
+ ;; install plt file when opened in drscheme strings
+ (install-plt-file "¿Deseas instalar ~a, o quieres abrirlo para edición?")
+ (install-plt-file/yes "Instalar")
+ (install-plt-file/no "Editar")
+ 
+ (plt-installer-progress-window-title "Progreso del instalador")
+ (plt-installer-abort-installation "Abortar instalación") ;; button label
+ (plt-installer-aborted "Abortado.") ;; msg that appears in the installation window when installation is aborted
+
+ ;;; about box
+ (about-drscheme-frame-title "Acerca de DrScheme")
+ (take-a-tour "¡Haz un recorrido!")
+ (release-notes "Notas sobre ésta versión")
+ (parenthetical-last-version "(versión anterior ~a)")
+ (parenthetical-last-language "(lenguaje anterior ~a)")
+ (parenthetical-last-version/language "(versión anterior ~a, lenguaje ~a)")
+ 
+ ;;; save file in particular format prompting.
+ (save-as-plain-text "¿Salvar este archivo como texto plano?")
+ (save-in-drs-format "¿Salvar este archivo en el formato, no texto, particular de DrScheme?")
+ (yes "Si")
+ (no "No")
+ 
+ ;;; preferences
+ (preferences "Preferencias")
+ (saving-preferences "Salvar preferencias")
+ (error-unmarshalling "Error mientras desempacaba la preferencia ~a")
+ (error-saving-preferences "Error al salvar preferencias: ~a")
+ (error-reading-preferences "Error al leer preferencias")
+ (expected-list-of-length2 "esperaba un lista de longitud 2")
+ (scheme-prefs-panel-label "Scheme")
+ (warnings-prefs-panel-label "Advertencias")
+ (editor-prefs-panel-label "Editando")
+ (general-prefs-panel-label "General") 
+ (highlight-parens "Resaltar entre parejas de paréntesis")
+ (fixup-parens "Corrige paréntesis")
+ (flash-paren-match "Señala el paréntesis que casa")
+ (auto-save-files "Auto-salva archivos")
+ (backup-files "Archivos de respaldo")
+ (map-delete-to-backspace "Cambia suprimir por backspace")
+ (verify-exit "Confirmar salida")
+ (ask-before-changing-format "Preguntar antes de cambiar el formato de salida")
+ (wrap-words-in-editor-buffers "Ajustar al border palabras en el editor")
+ (show-status-line "Mostrar línea de estado")
+ (count-columns-from-one "Cuenta números de columna a partir de uno") 
+ (display-line-numbers "Muestra números de línea en el contenedor; sin desplazamiento de caracteres")
+ (enable-keybindings-in-menus "Habilita enlaces de teclas en los menús")
+ (automatically-to-ps "Imprime automáticamente a un archivo en postscript")
+ (option-as-meta "Tratar cualquier tecla como meta") ;; macos/macos x only
+ (use-mdi "Utiliza Ventanas MDI") ;;; ms windows only -- use that window in a window thingy
+ (separate-dialog-for-searching "Use el diálogo adecuado para buscar")
+ (reuse-existing-frames "Reutilizar marcos existentes cuando se abre un nuevo archivo")
+ (default-fonts "Fuentes por omisión")
+ (paren-match-color "Color de resaltado de paréntesis") ; in prefs dialog
+ (choose-color "Selección de Color") ; in prefs dialog
+ (online-coloring-active "Colorea sintaxis interactivamente")
+ (open-files-in-tabs "Abrir archivos en distintas pestañas (no distintas ventanas)")
+ (show-interactions-on-execute "Abrir ventana de interacciones cuando se ejecuta un programa")
+ (limit-interactions-size "Limita el tamaño de las interacciones")
+ (background-color "Color de fondo")
+ (default-text-color "Texto por omisión") ;; used for configuring colors, but doesn't need the word "color"
+ (choose-a-background-color "Por favor selecciona un color de fondo")
+
+  ; title of the color choosing dialog
+ (choose-paren-highlight-color "Selecciona un color para resaltar paréntesis")
+
+ ; should have entire alphabet
+ (font-example-string "abcdefghijklmnñopqrstuvxyz¡!¿?«».")  ;; FIXME: shoulde this have special characters?
+
+ (change-font-button-label "Cambiar")
+ (fonts "Fuentes")
+
+					; filled with type of font, eg modern, swiss, etc.
+ (choose-a-new-font "Por favor selecciona una nueva fuente \"~a\"")
+
+ (font-size-slider-label "Tamaño")
+ (restart-to-see-font-changes "Re-inicia para ver los cambios de las fuentes")
+
+ (font-prefs-panel-title "Fuente")
+ (font-name "Nombre de fuente")
+ (font-size "Tamaño de fuente")
+ (set-font "Ver Fuente...")
+ (font-smoothing-label  "Suavisar Fuente")
+ (font-smoothing-none "Nada")
+ (font-smoothing-some "Algo")
+ (font-smoothing-all "Todo")
+ (font-smoothing-default "Utiliza el valor por omisión del sistema")
+ (select-font-name "Selecciona un nombre de Fuente")
+ (example-text "Texto de ejemplo:")
+ (only-warn-once "Sólo advierte una vez cuando las ejecución e interacciones no están sincronizadas")
+ 
+ ; warning message when lockfile is around
+ (waiting-for-pref-lock "Esperando el archivo candado de las preferencias...")
+ (pref-lock-not-gone
+  "El archivo candado de las preferencias:\n\n   ~a\n\nevita que éstas sean salvadas. Asegúrate que ningún otro software de PLT esté corriendo y borra este archivo.")
+ (still-locked-exit-anyway? "Las preferencias no fueron salvadas exitosamente. ¿Salir de cualquier forma?")
+
+ ;;; indenting preferences panel
+ (indenting-prefs-panel-label "Sangrar")  ;; To indent is "Sangrado de márgenes"
+ (indenting-prefs-extra-regexp "Expresiones regulares extra")
+ 
+ ; filled with define, lambda, or begin
+ (enter-new-keyword "Teclea una nueva palabra clave parecida a ~a:")
+ (x-keyword "Palabra clave ~a")
+ (x-like-keywords "Palabra clave parecida a ~a")
+
+ (expected-a-symbol "esperaba un símbolo, encontré: ~a")
+ (already-used-keyword "la palabra clave \"~a\" ya tenía un sangrado especial asignado")
+ (add-keyword "Añade")
+ (remove-keyword "Borra")
+ 
+ ;;; find/replace
+ (find-and-replace "Buscar y reemplazar")
+ (find "Buscar")
+ (replace "Reemplazar")
+ (dock "Atracar")
+ (undock "Des-atracar")
+ (use-separate-dialog-for-searching "Use el diálogo adecuado para buscar")
+ (replace&find-again "Reemplazar && Vuelve a buscar") ;;; need double & to get a single &
+ (replace-to-end "Reemplazar hasta el final")
+ (forward "Hacia adelante")
+ (backward "Hacia atrás")
+ (hide "Esconder")
+
+ ;; multi-file-search
+ (mfs-multi-file-search-menu-item "Buscar en archivos...")
+ (mfs-string-match/graphics "Búsqueda de Cadenas (maneja archivos con gráficas)")
+ (mfs-regexp-match/no-graphics "Expresión Regular (sólo archivos de texto plano)")
+ (mfs-searching... "Buscando...")
+ (mfs-configure-search "Configuración de Búsqueda")
+ (mfs-files-section "Archivos")
+ (mfs-search-section "Buscar")
+ (mfs-dir "Dir")
+ (mfs-recur-over-subdirectories "Recurrir sobre subdirectorios")
+ (mfs-regexp-filename-filter "Filtro de nombres de archivo con expresiones regulares")
+ (mfs-search-string "Buscar cadena")
+ (mfs-drscheme-multi-file-search "DrScheme - Búsqueda Multi Archivo")
+ (mfs-not-a-dir "\"~a\" no es un directorio")
+ (mfs-open-file "Abrir Archivo")
+ (mfs-stop-search "Detener Búsqueda")
+ (mfs-case-sensitive-label "Sensible al Tamaño")
+ (mfs-no-matches-found "Nada casó con la búsqueda.")
+ (mfs-search-interrupted "Búsqueda abortada.")
+ 
+ ;;;reverting a file
+ (error-reverting "DrScheme - Error al Revertir")
+ (could-not-read "no pude leer \"~a\"")
+ (are-you-sure-revert "¿Estas seguro que deseas revertir este archivo? Este cambio no puede deshacerse.")
+ (are-you-sure-revert-title "¿Revertir?")
+
+ ;; saving a file
+ ;; ~a is filled with the filename
+ (error-saving "Error al Salvar")
+ (error-saving-file/name "Hubo un error mientras salvaba ~a.")
+ (error-loading "Error al cargar")
+ (error-loading-file/name "Hubo un error mientras cargaba ~a.")
+ (unknown-filename "<< desconocido >>")
+
+ ;;; finder dialog
+ (must-specify-a-filename "Debes especificar un nombre de archivo")
+ (file-does-not-exist "El archivo \"~a\" no existe.")
+ (ask-because-file-exists "El archivo \"~a\" ya existía. ¿Deseas reemplazarlo?")
+ (dne-or-cycle "El archivo \"~a\" contiene un directorio inexistente o un ciclo.")
+ (get-file "Obtener archivo")
+ (put-file "Poner archivo")
+ (full-pathname "Ruta completa")
+ (show-dot-files "Muestra archivos y directorio que comiencen con un punto.")
+ (up-directory-button-label "Arriba")
+ (add-button-label "Añadir") ;;; for multi-file selection
+ (add-all-button-label "Añadir todos") ;;; for multi-file selection
+ (remove-button-label "Eliminar") ;;; for multi-file selection
+ (file-wrong-form "Ese archivo no tiene el formato correcto.")
+ (select-files "Selecciona archivos")
+ (select-file "Selecciona un archivo")
+ (dir-dne "El directorio no existe.")
+ (file-dne "El archivo no existe.")
+ (empty-filename "El nombre del archivo debe contener al menos algunas letras.")
+ (that-is-dir-name "Eso es un nombre de directorio.")
+ 
+ ;;; raw menu names -- these must match the 
+ ;;; versions below, once the &s have been stripped.
+ ;;; if they don't, DrScheme's menus will appear
+ ;;; in the wrong order.
+ (file-menu "Archivo")
+ (edit-menu "Edición")
+ (help-menu "Ayuda")
+ (windows-menu "Ventana")
+
+ ;;; menus
+ ;;; - in menu labels, the & indicates a alt-key based shortcut.
+ ;;; - sometimes, things are stuck in the middle of 
+ ;;; menu item labels. For instance, in the case of
+ ;;; the "Save As" menu, you might see: "Save Definitions As". 
+ ;;; be careful of spacing, follow the English, if possible.
+ ;;; - the ellipses in the `after' strings indicates that
+ ;;; more information is required from the user before completing
+ ;;; the command.
+
+ (file-menu-label "&Archivo")
+
+ (new-info  "Abre un nuevo archivo")
+ (new-menu-item "&Nuevo")
+ (new-...-menu-item "&Nuevo...")
+ 
+ (open-info "Abre un nuevo archivo del disco")
+ (open-menu-item "&Abrir...")
+ (open-here-menu-item "&Abrir aquí...")
+ (open-recent-info "Una lista de archivos abiertos recientemente")
+ (open-recent-menu-item "Abrir reciente")
+
+ (revert-info "Revertir este archivo a la copia en disco")
+ (revert-menu-item "&Revertir")
+
+ (save-info "Salva este archivo a disco")
+ (save-menu-item "&Guardar")
+
+ (save-as-info "Te pide un nombre para salvar este archivo a disco")
+ (save-as-menu-item "Guardar &como ...")
+
+ (print-info "Envía este archivo a una impresora")
+ (print-menu-item "&Imprimir...")
+
+ (close-info "Cierra este archivo")
+ (close-menu-item "&Cerrar")
+
+ (quit-info "Cierra todas las ventanas")
+ (quit-menu-item-windows "&Salir")
+ (quit-menu-item-others "&Salir") ;; FIXME: salir is exit, so quit is ???
+ 
+ (edit-menu-label "&Edición")
+ 
+ (undo-info "Deshace la acción más reciente")
+ (undo-menu-item "&Deshacer")
+
+ (redo-info "Deshace el más reciente deshacer")
+ (redo-menu-item "&Rehacer")
+
+ (cut-info "Mueve los elementos seleccionados al porta-papeles para pegarlos más tarde")
+ (cut-menu-item "Cor&tar")
+
+ (copy-info "Copia los elementos seleccionados al porta-papeles para pegarlos más tarde")
+ (copy-menu-item "&Copiar")
+
+ (paste-info "Pega los elementos copiados o cortados más recientemente en lugar de los objetos seleccionados")
+ (paste-menu-item "&Pegar")
+
+ (clear-info "Borra los elementos seleccionados sin afectar el porta-papeles o el pegado")
+ (clear-menu-item-others "Limpiar")
+ (clear-menu-item-windows "Borr&ar")
+
+ (select-all-info "Selecciona el documento completo")
+ (select-all-menu-item "&Selecciona todo")
+ 
+ (find-info "Busca una cadena")
+ (find-menu-item "&Buscar...")
+
+ (find-again-info "Busca la misma cadena que antes")
+ (find-again-menu-item "Volver a buscar")
+ 
+ (replace-and-find-again-info "Reemplaza el texto actual y busca por la misma cadena que antes")
+ (replace-and-find-again-menu-item "Reemplaza && buscar otra vez")
+
+ (preferences-info "Configura tus preferencias")
+ (preferences-menu-item "Personalizar...")
+
+ (keybindings-info "Muestra los enlaces de tecla activos")
+ (keybindings-menu-item "Enlaces de teclas")
+ (keybindings-show-active "Mostrar enlaces de tecla activos")
+ (keybindings-frame-title "Enlaces de teclas")
+ (keybindings-sort-by-name "Ordena por Nombre")
+ (keybindings-sort-by-key "Ordena por Llave")
+ (keybindings-add-user-defined-keybindings "Añade enlaces de tecla definidos por el usuario...")
+ (keybindings-menu-remove "Eliminar ~a")
+ (keybindings-choose-user-defined-file "Por favor seleccione un archivo con enlaces de teclas.")
+
+ (user-defined-keybinding-error "Error al ejecutar el enlace de teclas ~a\n\n~a")
+ (user-defined-keybinding-malformed-file "El archivo ~a no contiene un módulo escrito usando el lenguaje (lib \"keybinding-lang.ss\" \"framework\").")  
+
+ (insert-text-box-item "Inserta caja de texto")
+ (insert-pb-box-item "Inserta caja de porta-papeles")
+ (insert-image-item "Inserta imagen...")
+ (insert-comment-box-menu-item-label "Insertar Caja de comentario")
+ (insert-lambda "Inserta &Lambda")
+ (insert-delta "Inserta &Delta (define)")
+ 
+ (wrap-text-item "Ajustar texto al borde")
+
+ (windows-menu-label "&Ventana")
+ (bring-frame-to-front "Traer ventana al frente")
+ (bring-frame-to-front... "Traer ventana al frente...")
+ (next-window "Ventana siguiente")
+ (previous-window "Ventana anterior")
+ (most-recent-window "Ventana más reciente")
+ 
+ (view-menu-label "&Muestra")
+ (show-overview "Mostrar Panorama")
+ (hide-overview "Esconder Panorama")
+ (show-module-browser "Mostrar Navegador de Módulos")
+ (hide-module-browser "Esconder Navegador de Módulos")
+
+ (help-menu-label "&Ayuda")
+ (about-info "Créditos y detalles de esta apliación")
+ (about-menu-item "Acerca ...")
+ (help-menu-check-for-updates "Buscando Actualizaciones...")
+
+  ;;; help-desk-specific menus
+ ;; open here's new menu item
+ (create-new-window-or-clear-current
+  "¿Deseas una nueva ventana o limpiar la ventana actual?")
+ (clear-current "Limpiar actual")
+ (new-window "Nueva ventana")
+
+ ;;; exiting and quitting are you sure dialog
+ ;;; (exit is used on windows, quit on macos. go figure)
+ (exit "Salir")
+ (quit "Abandonar") ;; FIXME: Quit
+ ;;; in are-you-sure-format, either exit or quit is filled in (from above)
+ ;;; based on the platform drscheme is running on.
+ (are-you-sure-exit "¿Estas seguro(a) que deseas salir?")
+ (are-you-sure-quit "¿Estas seguro(a) que deseas abandonar?") ;; FIXME: Quit
+ 
+ ;;; autosaving
+ (error-autosaving "Error al auto-salvar \"~a\".")
+ (autosaving-turned-off "Auto-salvar está desactivado hasta\n que el archivo sea salvado.")
+ (recover-autosave-files-frame-title "Recuperar archivos auto-salvados")
+ (autosave-details "Detalles")
+ (autosave-recover "Recuperar")
+ (autosave-unknown-filename "<<desconocido>>")
+
+ ;; these are labels in a dialog that drscheme displays
+ ;; if you have leftover autosave files. to see the dialog,
+ ;; start up drscheme and modify (but don't save) a file
+ ;; (also, do this with an unsaved file). Wait for the autosave
+ ;; files to appear (typically 5 minutes). Kill DrScheme
+ ;; and restart it. You'll see the dialog
+ (autosave-autosave-label: "Archivo auto-salvado:")
+ (autosave-original-label: "Archivo original:")
+ (autosave-autosave-label "Archivo auto-salvado")
+ (autosave-original-label "Archivo original")
+ (autosave-compare-files "Compara archivos auto-salvados")
+
+ (autosave-show-autosave "Auto-salvar archivo") ;; title of a window showing the autosave file
+
+ (autosave-explanation "DrScheme encontró archivos auto-salvados que pueden contener tu trabajo no salvado.")
+
+ (autosave-recovered! "¡Recuperado!") ;; status of an autosave file
+ (autosave-deleted "Borrado")       ;; status of an autosave file
+
+ (autosave-error-deleting "Error al borrar ~a\n\n~a") ;; first is a filename, second is an error message from mz.
+ (autosave-delete-button "Borrar")
+ (autosave-delete-title "Borrar")  ;; title of a dialog asking for deletion confirmation
+ (autosave-done "Listo")
+ 
+ ;; appears in the file dialog
+ (autosave-restore-to-where? "Escoge un lugar para guardar el archivo auto-salvado.")
+ 
+ ;;; file modified warning
+ (file-has-been-modified
+  "El archivo ha sido modificado desde la última vez que fue salvado. ¿Sobreescribo las modificaciones?")
+ (overwrite-file-button-label "Sobreescribir")
+ 
+ (definitions-modified 
+  "El texto de las definiciones ha sido modificado en el sistema de archivos; por favor salve o regrese el texto de las definiciones.")
+ (drscheme-internal-error "Error interno de DrScheme")
+ 
+ ;;; tools
+ (invalid-tool-spec "La especificación de la herramienta, especificada en el archivo info.ss de la colección ~a, es inválida.  Esperaba una cadena o una lista no vacía de cadenas y recibí: ~e")
+ (error-loading-tool-title "DrScheme - Error al cargar la herramienta ~s; ~s")
+ (error-invoking-tool-title "Error al invocar la herramienta ~s;~s")
+ (tool-tool-names-same-length
+  "esperaba que `tool-names' y `tools', en el archivo info.ss de ~s, fueran listas de la misma longitud, pero obtuve ~e y ~e")
+ (tool-tool-icons-same-length
+  "esperaba que `tool-icons' y  `tools', en el archivo info.ss de ~s, fueran listas de la misma longitud, pero obtuve ~e y ~e")
+ (tool-tool-urls-same-length
+  "esperaba que `tool-urls' y `tools' fueran listas del mismo tamaño en info.ss de ~s, pero obtuve ~e y ~e")
+ (error-getting-info-tool "error al cargar el archivo info.ss de ~s")
+ (tool-error-phase1 "Error en la fase 1 de la herramienta ~s; ~s")
+ (tool-error-phase2 "Error en la fase 2 de la herramienta ~s; ~s")
+
+ ;;; define popup menu
+ (end-of-buffer-define "<< fin de contenedor (buffer) >>") ;; FIXME: buffer --> almacenador intermediario ?
+ (sort-by-name "Ordena por nombre")
+ (sort-by-position "Ordena por posición en el archivo")
+ (no-definitions-found "<< no se encontraron definiciones >>")
+ (jump-to-defn "Saltar a la definición de ~a")
+
+ (recent-items-sort-by-age "Ordena por Edad")
+ (recent-items-sort-by-name "Ordena por Nombre")
+ 
+  ;;; show menu
+ (hide-definitions-menu-item-label "Esconder &Definiciones")
+ (show-definitions-menu-item-label "Mostrar &Definiciones")
+ (definitions-menu-item-help-string "Mostrar/Esconder la ventana de definiciones")
+ (show-interactions-menu-item-label "Mostrar &Interacciones")
+ (hide-interactions-menu-item-label "Esconder &Interacciones")
+ (interactions-menu-item-help-string "Mostrar/Esconder la ventana de Interacciones")
+ (show-toolbar "Mostrar &Barra de herramientas")
+ (hide-toolbar "Esconder &Barra de Herramientas")
+
+ ;;; file menu
+ (save-definitions-as "Salvar Definiciones como...")
+ (save-definitions "Salvar Definiciones")
+ (print-definitions "Imprimir Definiciones...")
+ (about-drscheme "Acerca DrScheme")
+ (save-other "Salvar otros")
+ (save-definitions-as-text "Salvar Definiciones como Texto...")
+ (save-interactions "Salvar Interacciones")
+ (save-interactions-as "Salvar Interacciones como...")
+ (save-interactions-as-text "Salvar Interacciones como Texto...")
+ (print-interactions "Imprimir Interacciones...")
+ (new-tab "Nueva pestaña")
+ (close-tab "Cerrar pestaña") ;; must not have any &s in it.
+
+ ;;; edit-menu
+ (split-menu-item-label "&Dividir")
+ (collapse-menu-item-label "C&olapsar")
+ 
+ ;;; language menu
+ (language-menu-name "&Lenguaje")
+ 
+ ;;; scheme-menu
+ (scheme-menu-name "S&cheme")
+ (execute-menu-item-label "Ejecutar")
+ (execute-menu-item-help-string "Reinicia el programa en la ventana de definiciones")
+ (break-menu-item-label "Interrumpir")
+ (break-menu-item-help-string "Interrumpe la evaluación actual")
+ (kill-menu-item-label "Terminar")
+ (kill-menu-item-help-string "Terminar la evaluación actual")
+ (clear-error-highlight-menu-item-label "Eliminar resaltado de error")
+ (clear-error-highlight-item-help-string "Elimina el resaltado rosa de errores")
+ (reindent-menu-item-label "&Re-sangrar")
+ (reindent-all-menu-item-label "Re-sangrar &todo")
+ (semicolon-comment-out-menu-item-label "&Comentar con punto y coma")
+ (box-comment-out-menu-item-label "&Comentar con una Caja")
+ (uncomment-menu-item-label "&Des-comentar")
+
+ (convert-to-semicolon-comment "Convertir a comentario con punto y coma")
+ 
+ ;;; executables
+ (create-executable-menu-item-label "Crear ejecutable...")
+ (create-executable-title "Crear Ejecutable")
+ (must-save-before-executable "Debes salvar tu programa antes de hacer un ejecutable.")
+ (save-an-executable "Salvar un Ejecutable")
+ (save-a-mred-launcher "Salvar un lanzador de MrEd")
+ (save-a-mzscheme-launcher "Salvar un lanzador de MzScheme")
+ (save-a-mred-stand-alone-executable "Salvar un ejecutable autocontenido de MrEd")
+ (save-a-mzscheme-stand-alone-executable "Salvar un ejecutable autocontenido de MzScheme")
+
+ (definitions-not-saved "La ventana de definiciones no ha sido salvada. El ejecutable usará la última versión salvada de la ventana de definiciones. ¿Desea continuar?")
+ (inline-saved-program-in-executable?
+  "¿Deseas que ponga \"en línea\" (auto-contenido) el programa salvado en el ejecutable? Si sí, puedes copiar el ejecutable ~a a otra computadora, pero el ejecutable será muy grande.  Si no, no podrás copiar el ejecutable a otra computadora pero será más pequeño.  Adicionalmente, si escojes no, el ejecutable siempre cargará la última versión del programa.")
+ (use-mred-binary? "¿Utilizar el binario mred para este ejecutable?\n\nSi sí, tu programa puede usar la biblioteca  (lib \"mred.ss\" \"mred\").  Si no, DrScheme usará mzscheme como binario para este ejecutable y no podrás usar la biblioteca mencionada.\n\nSi no está seguro(a) escoga Sí") 
+ (inline-saved-program-in-executable/windows/path
+  "ADVERTENCIA: El ejecutable generado requiere tres DLLs: libmred.dll, libmzsch.dll, y libmzgc.dll, que están localizadas en\n\n~a\n\nEl ejecutable encuentra las DLLs ya sea en el directorio de ejecutables o a través de la variable de ambiente PATH.\n\nCuando instalaste DrScheme, el instalador ajustó la variable PATH para que incluyera el directorio donde las DLLs fueron instaladas.  Toma en cuenta los cambios de usuario y configuración desde la instalación.\n\nSi mueves el ejecutable a otra máquina, también debes copiar las DLLs a la otra máquina --- ya sea al mismo direcotorio que el ejecutable o a un directorio en el PATH de la otra máquina.")
+ (launcher "Lanzador")
+ (stand-alone "Auto-contenido")
+ (executable-type "Tipo")
+ (executable-base "Base")
+ (filename "Nombre de archivo: ")
+ (create "Crear")
+ (please-choose-an-executable-filename "Por favor selecciona un nombre de archivo para salvar el ejecutable.")
+ (windows-executables-must-end-with-exe
+  "El nombre de archivo \n\n  ~a\n\nes ilegal.  En Windows, los ejecutables deben tener terminación .exe.")
+ (macosx-executables-must-end-with-app
+  "El nombre de archivo\n\n  ~a\n\nes ilegal.  En MacOS X, los ejecutables deben tener terminación .app.")
+ (warning-directory-will-be-replaced
+  "ADVERTENCIA: el directorio:\n\n  ~a\n\nserá reemplazado.  ¿Continuar?")
+ 
+ (create-servlet "Crear Servlet...")
+ 
+ ;; the ~a is a language such as "module" or "algol60"
+ (create-servlet-unsupported-language
+  "Crear Servlet no funciona con el lenguaje ~a.")
+
+ ;;; buttons
+ (execute-button-label "Ejecutar") 
+ (save-button-label "Salvar")
+ (break-button-label "Interrumpir")
+ 
+ ;;; search help desk popup menu
+ (search-help-desk-for "Busca en el Módulo de Ayuda \"~a\"")
+ (exact-lucky-search-help-desk-for "Búsqueda precisa y con suerte en el Módulo de Ayuda \"~a\"") ;; FIXME:  Exact lucky search in Help Desk for
+ 
+ ;; collapse and expand popup menus
+ (collapse-sexp "Colapsar expresión-s")
+ (expand-sexp "Expandir expresión-s")
+
+ ;;; fraction dialog
+ (enter-fraction "Introducir Fracción")
+ (whole-part "Parte entera")
+ (numerator "Numerador")
+ (denominator "Denominador")
+ (invalid-number "Número inválido: debe ser un número real exacto, no entero.")
+ (insert-fraction-menu-item-label "Insertar Fracción...")
+ 
+ ;; number snip popup menu
+ (show-decimal-expansion "Ver expansión decimal")
+ (show-fraction-view "Ver como fracción")
+ (show-mixed-fraction-view "Ver como una fracción mixta")   
+ (show-improper-fraction-view "Ver como fracción impropia")
+ (show-more-decimal-places "Muestra más posiciones decimales")
+ 
+ ;;; TeachPack messages
+ (select-a-teachpack "Selecciona un Paquete de Enseñanza")
+ (clear-teachpack "Limpia el Paquete de Enseñanza ~a")
+ (teachpack-error-label "DrScheme - Paquete de Enseñanza error")
+ (teachpack-dne/cant-read "El archivo del Paquete de Enseñanza ~a no existe o no puede ser leído.")
+ (teachpack-didnt-load "El archivo del Paquete de Enseñanza ~a no se cargó apropiadamente.")
+ (teachpack-error-invoke "El archivo del Paquete de Enseñanza ~a lanzó un error durante su invocación.")
+ (add-teachpack-menu-item-label "Añadir un Paquete de Enseñanza...")
+ (clear-all-teachpacks-menu-item-label "Limpia Todos los Paquetes de Enseñanza")
+ (drscheme-teachpack-message-title "DrScheme Paquete de Enseñanza")
+ (already-added-teachpack "El paquete de enseñanza ~a ya estaba cargado")
+ 
+ ;;; Language dialog
+ (introduction-to-language-dialog
+  "Por favor selecciona un lenguaje.  La mayoría de los estudiantes de cursos introductorios deberían usar el lenguaje por omisión.")
+ (language-dialog-title "Configurar Lenguaje")
+ (case-sensitive-label "Sensible a mayúsculas") ;; FIXME: Case sensitive
+ (output-style-label "Estilo de salida")
+ (constructor-printing-style "Constructor")
+ (quasiquote-printing-style "Quasiquote")
+ (print-printing-style "current-print")
+ (write-printing-style "write")
+ (sharing-printing-label "Show sharing in values")
+ (use-pretty-printer-label "Insertar caracteres de nueva línea en valores impresos")
+ (input-syntax "Sintáxis de Entrada")
+ (dynamic-properties "Propiedades dinámicas")
+ (output-syntax "Sintáxis de Salida")
+ (no-debugging-or-profiling "No depurando o delineando")
+ (debugging "Depurando")
+ (debugging-and-profiling "Depurando y delineando")
+ (test-coverage "Paquete de prueba de cobertura sintáctica") ;; FIXME: Syntactic test suite coverage
+ (whole/fractional-exact-numbers-label "Imprimir números como fracciones")
+ (booleans-as-true/false-label "Imprimir valores booleanos usando true y false")
+ (show-details-button-label "Mostrar Detalles")
+ (hide-details-button-label "Esconder Detalles")
+ (choose-language-menu-item-label "Escoger Lenguaje...")
+ (revert-to-language-defaults "Revertir a los Valores por Omisión del Lenguaje")
+ (language-docs-button-label "Documentación de Lenguajes")
+ (fraction-style "Estilo de Fracciones")
+ (use-mixed-fractions "Fracciones mixtas")
+ (use-repeating-decimals "Decimales repetidos")
+ (decimal-notation-for-rationals "Usar notación decimal para racionales")
+ (please-select-a-language "Por favor selecciona un lenguaje")
+ 
+ ;;; languages
+ (beginning-student "Estudiante Principiante")
+ (beginning-one-line-summary "define, cond, structs, constantes, y primitivas") 
+ (beginning-student/abbrev "Estudiante Principiante con Abreviaturas de Listas")
+ (beginning/abbrev-one-line-summary "Principiante con estilo de impresión de listas en el REPL") 
+ (intermediate-student "Estudiante Intermedio")
+ (intermediate-one-line-summary "Estudiante Principiante más alcance léxico")
+ (intermediate-student/lambda "Estudiante Intermedio con lambda")
+ (intermediate/lambda-one-line-summary "Estudiante Intermedio más funciones de alto-nivel")
+ (advanced-student "Estudiante Avanzado")
+ (advanced-one-line-summary "Estudiante Intermedio más lambda y mutación") 
+ (full-language "Completo")
+ (how-to-design-programs "How to Design Programs") ;; should agree with MIT Press on this one...
+ (r5rs-like-languages "Similar a R5RS")
+ (expander "Expander")
+ (expander-one-line-summary "Expande, en lugar de evaluar, expresiones")
+ (professional-languages "Languajes Profesionales")
+ (teaching-languages "Languajes de Enseñanza")
+ (experimental-languages "Languajes Experimentales") 
+ (pretty-big-scheme "Muy Grande (incluye MrEd y Avanzado)")
+ (pretty-big-scheme-one-line-summary "Añade syntaxis y funciones de los lenguajes HtDP")
+ (r5rs-lang-name "R5RS estándar")
+ (r5rs-one-line-summary "R5RS, sin ornamentos")
+ (unknown-debug-frame "[desconocido]")
+ 
+ (module-language-one-line-summary "Ejecutar crea un REPL en el contexto del módulo, incluyendo el lenguaje declarado para el módulo")
+
+ ;;; debug language
+ (backtrace-window-title "Backtrace - DrScheme")
+ (files-interactions "Interacciones de ~a") ;; filled with a filename
+ (current-interactions "interacciones")
+ (current-definitions "definiciones")
+ (mzscheme-w/debug "Texto (MzScheme, incluye R5RS)")
+ (mzscheme-one-line-summary "Implementación de Scheme del PLT") 
+ (mred-w/debug "Gráfico (MrEd, incluye MzScheme)")
+ (mred-one-line-summary "Añade soporte para IGU a MzScheme")
+
+ ;; profiling
+ (profiling-low-color "Tenue")
+ (profiling-high-color "Fuerte")
+ (profiling-choose-low-color "Por favor selecciona un color tenue")
+ (profiling-choose-high-color "Por favor selecciona un color fuerte")
+ (profiling "Delineando")
+ (profiling-example-text "(define (whee) (whee))")
+ (profiling-color-config "Delineando Rango de Color")
+ (profiling-scale "Delineando Escala de Color")
+ (profiling-sqrt "Raíz cuadrada")
+ (profiling-linear "Lineal")
+ (profiling-square "Cuadrado")
+ (profiling-number "Número de llamadas")
+ (profiling-time "Tiempo acumulado")
+ (profiling-clear "Limpiar delineado")
+ (profiling-update "Actualiza Delineado")
+ (profiling-col-percent-time "% Tiempo")
+ (profiling-col-function "Función")
+ (profiling-col-name "Nombre")
+ (profiling-col-time-in-msec "Msec")
+ (profiling-col-calls "Llamadas")
+ (profiling-show-profile "Muestra Delineado")
+ (profiling-hide-profile "Esconder Profile")
+ (profiling-unknown-src "<< desconocido >>")
+ (profiling-no-information-available "No hay información de delineado disponible. Por favor, asegúrate que la opción de delineado está activada para el lenguaje y de haber ejecutado su programa.")
+ (profiling-clear? "Cambiar la ventana de definiciones invalida la información de delineado. ¿Continuar?")
+ 
+ ;; test coverage
+ (test-coverage-clear? "El cambiar la ventana de definiciones invalida la información de pruebas de cobertura. ¿Continuar?")
+ (test-coverage-clear-and-do-not-ask-again "Sí y no me preguntes más")
+ (test-coverage-ask? "¿Preguntar acerca de las pruebas de  cobertura?")
+
+ ;; tracing
+ (tracing-enable-tracing "Habilitar trazado")
+ (tracing-show-tracing-window "Mostrar trazado")
+ (tracing-hide-tracing-window "Esconder trazado")
+ (tracing-tracing-nothing-to-show "No hay resultados de trazado disponibles.  Asegúrese que su lenguaje soporte trazado y que esté habilitado.")
+
+ 
+ ;;; repl stuff
+ (evaluation-terminated "Evaluación Terminada")
+ (evaluation-terminated-explanation
+  "El hilo de control de la evaluación ya no se está ejecutando, por lo que no se puede efectuar ninguna evaluación hasta la siguiente ejecución.")
+ (last-stack-frame "Mostrar el último marco (frame) en el stack")
+ (last-stack-frames "Mostrar los últimos ~a marcos (frames)")
+ (next-stack-frames "Mostrar los siguientes ~a marcos (frames) en el stack")
+ 
+ ;;; welcoming message in repl
+ (language "Lenguaje")
+ (custom "custom")
+ (teachpack "Paquete de Enseñanza")
+ (welcome-to "Bienvenido a")
+ (version "versión")
+ 
+ ;;; kill evaluation dialog
+ (kill-evaluation? "¿Quieres terminar la evaluación?")
+ (just-break "Interrupción Simple")
+ (kill "Terminar")
+ (kill? "¿Terminar?")
+ 
+ ;; version checker
+ ;; vc-check-prompt is gone, I'm leaving this comment to make it easier to generate
+ ;; vc-wizard-check-note which is similar, only it is used as part of the initial
+ ;; wizard dialog.  Note that vc-wizard-check-prompt can (should) have newlines so
+ ;; it will not make the dialog too wide.
+ (vc-wizard-check-note "La versión que está a punto de instalar puede no ser\nla más reciente.  Si lo desea, DrScheme puede verificar por Usted.")
+ (vc-wizard-check-button "¡Buscar ahora!") 
+ (vc-update-check "Revisar Actualización")
+ (vc-please-wait "Por favor espere")
+ (vc-connecting-version-server "Conectando al servidor de versión PLT")
+ (vc-network-timeout "La conexión de red ha expirado")
+ (vc-cannot-connect "No puedo conectarme al servidor de versión PLT")
+ (vc-network-failure "Falla de Red")
+ (vc-old-binaries "Los binarios instalados para DrScheme (o MzScheme) no están actualizados")
+ (vc-binary-information-format "Versión binaria instalada: ~a (iteración ~a)")
+ (vc-details-format "~a~nDetalles:~n~a")
+ (vc-details-text "Detalles:~n")
+ (vc-error-format "Error: ~a")
+ (vc-current-format "~a v.~a (iteración ~a) está actualizada")
+ (vc-update-format "~a v.~a (iteración ~a) requiere ser actualizado a v.~a (iteración ~a)")
+ (vc-binary-name "Binario")
+ (vc-updates-available "Las actualizaciones están disponibles en")
+ (vc-latest-binary-information-format "Última versión liberada: ~a (iteración ~a)")
+ (vc-update-dialog-title "PLT estatus de actualización")
+ (vc-need-update-string "Uno o más de los paquetes de software PLT necesitan ser actualizados")
+ (vc-no-update-string "Todo el software PLT instalado está al día")
+
+ ;; special menu
+ (special-menu "Especial")
+
+ ;; large semi colon letters
+ (insert-large-letters... "Insertar Letras Grandes...")
+ (large-semicolon-letters "Letas Dos Puntos Grandes")
+ (text-to-insert "Texto a insertar")
+
+ (module-browser-filename-format "Nombre de archivo completo: ~a (~a líneas)")
+ (module-browser-root-filename "Raíz del archivo: ~a")
+ (module-browser-font-size-gauge-label "Tamaño de fuente")
+ (module-browser-progress-label "Módulo de resumen de progreso")
+ (module-browser-adding-file "Añadiendo archivo: ~a...")
+ (module-browser-laying-out-graph-label "Depositando gráfica")
+ (module-browser-open-file-format "Abriendo ~a")
+ (module-browser "Navegador de Módulos")
+ (module-browser... "Navegador de Módulos...")
+ (module-browser-error-expanding "Error al expandir el programa:\n\n~a")
+ (module-browser-show-lib-paths "Muestra archivos cargados por rutas (lib ..)")
+ (module-browser-progress "Navegador de Módulos: ~a") ;; prefix in the status line
+ (module-browser-compiling-defns "Navegador de Módulos: compilando las definiciones")
+ (module-browser-show-lib-paths/short "Seguir los requires de bibliotecas (lib)") ;; check box label in show module browser pane in drscheme window.
+ (module-browser-refresh "Refrescar") ;; button label in show module browser pane in drscheme window.
+ (module-browser-only-in-plt-and-module-langs
+  "El navegador de módulos está disponible para programas en los lenguajes PLT y en el lenguaje con módulos (y únicamente para programas que incluyan módulos).")
+ (module-browser-name-length "Longitud de nombre")
+ (module-browser-name-short "Corto")
+ (module-browser-name-medium "Medio")
+ (module-browser-name-long "Largo")
+ (module-browser-open-all "Abrir todos los archivos mostrados")
+
+ ;; Birthdays section
+ (happy-birthday-matthias "¡Feliz cumpleaños Matthias!")
+ (happy-birthday-matthew "¡Feliz cumpleaños Matthew!")
+ (happy-birthday-shriram "¡Feliz cumpleaños Shriram!")
+ 
+ (mrflow-using-default-language-title "Lenguaje por omisión usado")
+ (mrflow-using-default-language "El lenguaje usado actualmente no tiene un tipo tabla definido para sus primitivas.  Usaré R5RS Scheme en su lugar.")
+ (mrflow-button-title "Analizar")
+ (mrflow-coloring-error "Estilo no definido para el color: ~a")
+ (mrflow-coloring-error-title "Color desconocido")
+;(mrflow-language-primitives-error "Nombre de archivo incorrecto para la tabla de tipos primitivos del lenguaje: ~a")
+;(mrflow-language-primitives-error-title "Error de Primitivas del Lenguaje")
+ (mrflow-popup-menu-hide-errors "Esconder Errores")
+ (mrflow-popup-menu-hide-type "Esconder Tipo")
+ (mrflow-popup-menu-show-errors "Mostrar Errores")
+ (mrflow-popup-menu-show-type "Mostrar Tipo")
+;(mrflow-read-exception "Leer excepción: ~a")
+;(mrflow-read-exception-title "Leer Excepción")
+;(mrflow-syntax-exception "Excepción de sintaxis: ~a")
+;(mrflow-syntax-exception-title "Excepción de Sintaxis")
+;(mrflow-unknown-exception-title "Excepción Desconocida")
+;(mrflow-unknown-exception "Excepción Desconocida: ~a")
+ 
+ (snips-and-arrows-popup-menu-tack-all-arrows "Ligar todas las Flechas")
+ (snips-and-arrows-popup-menu-untack-all-arrows "Desligar todas las Flechas")
+ (snips-and-arrows-user-action-disallowed-title "Cambios del usuario no permitidos actualmente")
+ (snips-and-arrows-user-action-disallowed "Cambios del usuario no son permitidos en editores que contienen partes insertadas por herramientas.  Esconde todas las partes antes de modificar el contenido del editor.")
+ (snips-and-arrows-hide-all-snips-in-editor "Esconder todas las partes en el editor")
+
+ (xml-tool-menu "XML")
+ (xml-tool-insert-scheme-box "Insertar Caja de Scheme")
+ (xml-tool-insert-scheme-splice-box "Insertar Caja de Unión de Scheme")
+ (xml-tool-insert-xml-box "Insertar Caja de XML")
+ (xml-tool-xml-box "Caja de XML")
+ (xml-tool-scheme-box "Caja de Scheme")
+ (xml-tool-scheme-splice-box "Caja de Unión de Scheme")
+ (xml-tool-switch-to-scheme "Cambiar a caja de  Scheme")
+ (xml-tool-switch-to-scheme-splice "Cambiar a caja de unión de Scheme")
+ (xml-tool-eliminate-whitespace-in-empty-tags "Eliminar blancos en etiquetas vacías")
+ (xml-tool-leave-whitespace-alone "Dejar blancos por la paz")
+
+ (show-recent-items-window-label "Archivos abiertos recientemente")
+ (show-recent-items-window-menu-item "Muestra Archivos Abiertos recientemente en otra ventana")
+ (number-of-open-recent-items "Número de elementos recientes")
+ (switch-anyway "Cambia de archivo de cualquier forma")
+
+ (stepper-program-has-changed "ADVERTENCIA: El programa ha cambiado.")
+ (stepper-program-window-closed "ADVERTENCIA: La ventana del programa ha desaparecido.")
+
+ (wizard-next "Siguiente")
+ (wizard-back "Atrás")
+ (wizard-finish "Finalizar")
+ 
+ ;; warnings about closing a drscheme frame when the program
+ ;; might still be doing something interesting
+ (program-is-still-running "El programa en la ventana de definiciones sigue corriendo.  ¿Cerrar de cualquier forma?")
+ (program-has-open-windows "El programa en la ventana de definiciones abrió otras ventanas.  ¿Cerrar esta ventana de cualquier forma?")
+
+ ;; ml-command-line-arguments is for the command line arguments
+ ;; label in the module language details in the language dialog.
+ (ml-command-line-arguments "Argumentos en la línea de comandos como un vector de cadenas, en leer sintaxis")
+ 
+ ;; ml-cp names are all for the module language collection path
+ ;; configuration. See the details portion of the language dialog
+ ;; for the module language (at the bottom).
+ (ml-cp-default-collection-path "<<rutas de colección por omisión>>")
+
+ ;; in std get-directory 
+ (ml-cp-choose-a-collection-path "Por favor selecciona una ruta de colecciones")
+
+ ;; err msg when adding default twice
+ (ml-cp-default-already-present "La ruta de colecciones por omisión ya está presente")
+ 
+ ;; title of this section of the dialog (possibly the word
+ ;; `Collection' should not be translated)
+ (ml-cp-collection-paths "Rutas de colecciones")
+
+ ;; button labels
+ (ml-cp-add "Añadir")
+ (ml-cp-add-default "Añadir por omisión")
+ (ml-cp-remove "Eliminar")
+ (ml-cp-raise "Elevar")
+ (ml-cp-lower "Bajar")
+
+ ;; Profj
+ (profj-java "Java")
+ (profj-java-mode "Modo Java")
+ (profj-java-mode-color-keyword "llave")
+ (profj-java-mode-color-string "cadena")
+ (profj-java-mode-color-literal "literal")
+ (profj-java-mode-color-comment "comentario")
+ (profj-java-mode-color-error "error")
+ (profj-java-mode-color-identifier "identificador")
+ (profj-java-mode-color-default "por omisión")
+ 
+ ;; The Test Suite Tool
+ ;; Errors
+ (test-case-empty-error "Caso de prueba vacío")
+ (test-case-too-many-expressions-error "Demasiadas expresiones en el caso de prueba.")
+ (test-case-not-at-top-level "Caja para caso de prueba no en nivel superior")
+ ;; Dr. Scheme window menu items
+ (test-case-insert "Insertar Caso de Prueba")
+ (test-case-disable-all "Deshabilitar todos los Casos de Prueba")
+ (test-case-enable-all "Habilitar todos los Casos de Prueba")
+ ;; NOTE: The following three string constants are labels of the test-case fields. The width
+ ;;       of the field is determined by the length of the longest of the following three words.
+ ;;       if the words are too long the test case will take up too much horizontal room and
+ ;;       not look very good.
+ ;; This string is the label of the expression that is being tested in a test case.
+ (test-case-to-test "Por probar")
+ ;; This string is the label of the expression that is the expected value of the to-test expression.
+ (test-case-expected "Esperado")
+ ;; This string is the label of the actual result of the to test expression.
+ (test-case-actual "Obtenido")
+ (test-case-predicate "Predicado")
+ (test-case-should-raise "Debe provocar") ;; should raise?
+ ;; The label of a field of the test-case that describes the expected error message of a test case
+ (test-case-error-message "Mensaje de Error")
+
+ (test-case-menu-title "Caso de prueba")
+ (test-case-switch-to-error-box "Cambiar a caja de prueba de error")
+ (test-case-switch-to-nonerror-box "Cambiar a caja de prueba sin-error")
+ (test-case-collapse "Colapsar el caso de prueba")
+ (test-case-show-actual "Mostrar valor actual")
+ (test-case-enable "Activar caso de prueba")
+ (test-case-show-predicate "Mostrar predicado")
+ (test-case-show-error-message "Mostrar mensaje de error")
+ (test-case-convert-to-text "Convertir a texto")
+
+  ;; Profj Boxes
+ (profjBoxes-empty-error "Interacción vacía")
+ (profjBoxes-too-many-expressions-error "Demasiadas expresiones en una caja")
+ (profjBoxes-interactions-label "Interacciones")
+ (profjBoxes-bad-java-id-error "Java ID mal formado")
+ (profjBoxes-examples-label "Ejemplos")
+ (profjBoxes-add-new-example-button "Añadir nuevo ejemplo")
+ (profjBoxes-type "Tipo")
+ ;; The Java identifier of an example of data
+ (profjBoxes-name "Nombre")
+ (profjBoxes-value "Valor")
+
+ 
+ )
diff --git a/collects/string-constants/string-constant-lang.ss b/collects/string-constants/string-constant-lang.ss
new file mode 100644
index 0000000000..59a740a781
--- /dev/null
+++ b/collects/string-constants/string-constant-lang.ss
@@ -0,0 +1,25 @@
+(module string-constant-lang mzscheme
+  (provide (rename -#%module-begin #%module-begin)
+           #%datum)
+  
+  (define-syntax (-#%module-begin stx)
+    (syntax-case stx ()
+      [(_ (name str) ...)
+       (and (andmap symbol? (syntax-object->datum (syntax (name ...))))
+            (andmap string? (syntax-object->datum (syntax (str ...)))))
+       (with-syntax ([string-constants (datum->syntax-object stx 'string-constants)])
+         (syntax
+          (#%plain-module-begin
+           (provide string-constants)
+           (define string-constants
+             '((name str) ...)))))]
+      [(_ prs ...)
+       (for-each
+        (lambda (pr-stx)
+          (let ([pr (syntax-object->datum pr-stx)])
+            (unless (and (list? pr) 
+                         (= 2 (length pr))
+                         (symbol? (car pr))
+                         (string? (cadr pr)))
+              (raise-syntax-error 'string-constant-lang "bad string constant" stx pr-stx))))
+        (syntax->list (syntax (prs ...))))])))
\ No newline at end of file
diff --git a/collects/string-constants/string-constant.ss b/collects/string-constants/string-constant.ss
new file mode 100644
index 0000000000..59611f0773
--- /dev/null
+++ b/collects/string-constants/string-constant.ss
@@ -0,0 +1,214 @@
+
+(module string-constant mzscheme
+  (require-for-syntax (lib "etc.ss")
+		      (lib "list.ss")
+                      (prefix english: "english-string-constants.ss")
+                      (prefix spanish: "spanish-string-constants.ss")
+                      (prefix german: "german-string-constants.ss")
+                      (prefix french: "french-string-constants.ss")
+                      (prefix dutch: "dutch-string-constants.ss")
+                      (prefix danish: "danish-string-constants.ss")
+		      (prefix italian: "italian-string-constants.ss")
+		      (prefix japanese: "japanese-string-constants.ss")
+                      (prefix traditional-chinese: "traditional-chinese-string-constants.ss")
+                      (prefix simplified-chinese: "simplified-chinese-string-constants.ss"))
+  
+  (require (lib "file.ss")
+           (lib "etc.ss")
+           "private/only-once.ss")
+
+  (provide string-constant string-constants this-language all-languages set-language-pref)
+  
+  ;; set-language-pref : symbol -> void
+  (define (set-language-pref language)
+    (put-preferences (list 'plt:human-language) (list language)))
+  
+  ;; language : symbol
+  (define language (get-preference 'plt:human-language (lambda () 'english)))
+    
+  (define-syntax-set (string-constant string-constants this-language all-languages)
+    ;; type sc = (make-sc symbol (listof (list symbol string)) (union #f hash-table[symbol -o> #t]))
+    (define-struct sc (language-name constants ht))
+    
+    (define available-string-constant-sets
+      (list 
+       (make-sc 'english english:string-constants #f)
+       (make-sc 'spanish spanish:string-constants #f)
+       (make-sc 'french french:string-constants #f)
+       (make-sc 'german german:string-constants #f)
+       (make-sc 'dutch dutch:string-constants #f)
+       (make-sc 'danish danish:string-constants #f)
+       (make-sc 'italian italian:string-constants #f)
+       (make-sc 'japanese japanese:string-constants #f)
+       (make-sc 'traditional-chinese traditional-chinese:string-constants #f)
+       (make-sc 'simplified-chinese simplified-chinese:string-constants #f)))
+    
+    (define first-string-constant-set (car available-string-constant-sets))
+    
+    ;; env-var-set? : symbol -> boolean
+    ;; returns #t if the user has requested this langage info.
+    ;; If the environment variable is set to something that
+    ;; isn't well-formed according to `read' you get all output
+    ;; If the environment variable is set to a symbol (according to read)
+    ;; you get that language. If it is set to a list of symbols
+    ;; (again, according to read) you get those langauges.
+    ;; if it is set to anything else, you get all langauges.
+    (define (env-var-set? lang)
+      (cond
+        [(symbol? specific) (eq? lang specific)]
+        [(list? specific) (memq lang specific)]
+        [else #t]))
+    
+    (define env-var-set 
+      (or (getenv "PLTSTRINGCONSTANTS")
+          (getenv "STRINGCONSTANTS")))
+    
+    (define specific
+      (and env-var-set
+           (with-handlers ([exn:fail:read? (lambda (x) #t)])
+             (read (open-input-string env-var-set)))))
+    
+    (define the-warning-message #f)
+    (define (get-warning-message)
+      (unless the-warning-message
+        (set! the-warning-message
+	      (let* (;; type no-warning-cache-key = (cons symbol symbol)
+		     ;; warning-table : (listof (list no-warning-cache-key (listof (list sym string))))
+                     [warning-table null]
+		     [extract-ht
+                      (lambda (sc)
+                        (unless (sc-ht sc)
+                          (let ([ht (make-hash-table)])
+                            (for-each (lambda (ent) (hash-table-put! ht (car ent) #t))
+                                      (sc-constants sc))
+                            (set-sc-ht! sc ht)))
+                        (sc-ht sc))]
+                     [check-one-way
+		      (lambda (sc1 sc2)
+			(let ([assoc1 (sc-constants sc1)]
+			      [assoc2 (sc-constants sc2)]
+                              [ht2 (extract-ht sc2)])
+			  (for-each
+			   (lambda (pair1)
+			     (let* ([constant1 (car pair1)]
+				    [value1 (cadr pair1)]
+				    [pair2 (hash-table-get ht2 constant1 (lambda () #f))])
+			       (unless pair2
+				 (let ([no-warning-cache-key (cons (sc-language-name sc1) (sc-language-name sc2))])
+				   (when (or (env-var-set? (sc-language-name sc1))
+					     (env-var-set? (sc-language-name sc2)))
+				     (cond
+                                       [(memf (lambda (x) (equal? (car x) no-warning-cache-key)) warning-table)
+                                        =>
+                                        (lambda (x)
+                                          (let ([ent (car x)])
+                                            (set-car! (cdr ent) (cons (list constant1 value1) (cadr ent)))))]
+                                       [else
+                                        (set! warning-table (cons (list no-warning-cache-key
+                                                                        (list (list constant1 value1)))
+                                                                  warning-table))]))))))
+			   assoc1)))])
+                
+                (for-each (lambda (x) 
+                            (check-one-way x first-string-constant-set)
+                            (check-one-way first-string-constant-set x))
+                          (cdr available-string-constant-sets))
+		
+		(let ([sp (open-output-string)])
+		  (for-each
+		   (lambda (bad)
+		     (let* ([lang-pair (car bad)]
+			    [constants (cadr bad)]
+			    [lang1-name (car lang-pair)]
+			    [lang2-name (cdr lang-pair)])
+		       (fprintf sp "WARNING: language ~a had but ~a does not:\n"
+				lang1-name
+				lang2-name)
+		       (for-each
+			(lambda (x) (fprintf sp "   ~s\n" x))
+			(quicksort
+			 constants
+			 (lambda (x y) (string<=? (symbol->string (car x)) (symbol->string (car y))))))
+		       (newline sp)))
+		   warning-table)
+		  (get-output-string sp)))))
+      the-warning-message)
+    
+    (define (string-constant/proc stx)
+      (syntax-case stx ()
+        [(_ name)
+         (let ([assoc-table (sc-constants first-string-constant-set)]
+               [datum (syntax-object->datum (syntax name))])
+           (unless (symbol? datum)
+             (raise-syntax-error #f
+                                 (format "expected name, got: ~s" datum)
+                                 stx))
+           (let ([default-val (assq datum assoc-table)])
+             (unless default-val
+               (raise-syntax-error 
+                #f
+                (format "~a is not a known string constant" datum) 
+                stx))
+             (with-syntax ([(constants ...) (map (lambda (x)
+                                                   (let ([val (assq datum (sc-constants x))])
+                                                     (if val
+                                                         (cadr val)
+                                                         (cadr default-val))))
+                                                 available-string-constant-sets)]
+                           [(languages ...) (map sc-language-name available-string-constant-sets)]
+                           [first-constant (cadr (assq datum (sc-constants first-string-constant-set)))])
+               (with-syntax ([conditional-for-string
+                              (syntax/loc stx
+                                (cond
+                                  [(eq? language 'languages) constants] ...
+                                  [else first-constant]))])
+                 (if env-var-set
+		     (with-syntax ([warning-message (get-warning-message)])
+		       (syntax/loc stx
+			 (begin
+			   (maybe-print-message warning-message)
+			   conditional-for-string)))
+                     (syntax/loc stx conditional-for-string))))))]))
+    
+    (define (string-constants/proc stx)
+      (syntax-case stx ()
+        [(_ name)
+         (let ([assoc-table (sc-constants first-string-constant-set)]
+               [datum (syntax-object->datum (syntax name))])
+           (unless (symbol? datum)
+             (raise-syntax-error #f
+                                 (format "expected name, got: ~s" datum)
+                                 stx))
+           (let ([default-val (assq datum assoc-table)])
+             (unless default-val
+               (raise-syntax-error 
+                #f
+                (format "~a is not a known string constant" datum)
+                stx))
+             (with-syntax ([(constants ...) (map (lambda (x) 
+                                                   (let ([val (assq datum (sc-constants x))])
+                                                     (if val
+                                                         (cadr val)
+                                                         (cadr default-val))))
+                                                 available-string-constant-sets)])
+               (syntax (list constants ...)))))]))
+    
+    (define (this-language/proc stx)
+      (syntax-case stx ()
+        [(_)
+         (syntax language)]))
+    
+    (define (all-languages/proc stx)
+      (syntax-case stx ()
+        [(_) 
+         (with-syntax ([(languages ...) (map sc-language-name available-string-constant-sets)])
+           (syntax (list 'languages ...)))]))))
+#|
+(require string-constant)
+(string-constant is-this-your-native-language)
+(string-constants is-this-your-native-language)
+(all-languages)
+(this-language)
+(expand #'(string-constant is-this-your-native-language))
+(expand #'(string-constants is-this-your-native-language))
+|#
diff --git a/collects/string-constants/traditional-chinese-string-constants.ss b/collects/string-constants/traditional-chinese-string-constants.ss
new file mode 100644
index 0000000000..0917d28c6d
--- /dev/null
+++ b/collects/string-constants/traditional-chinese-string-constants.ss
@@ -0,0 +1,46 @@
+#|
+
+Got the codes below by sending a utf-8 encoded email to myself, via Mail.
+
+--Apple-Mail-1--910733453
+Content-Transfer-Encoding: quoted-printable
+Content-Type: text/plain;
+	charset=UTF-8;
+	format=flowed
+
+
+On Feb 7, 2004, at 12:46 PM, Robby Findler wrote:
+
+> =E6=AD=A1=E8=BF=8E=E4=BD=BF=E7=94=A8 DrScheme
+>
+> Robby=
+
+--Apple-Mail-1--910733453
+Content-Transfer-Encoding: quoted-printable
+Content-Type: text/enriched;
+	charset=UTF-8
+
+
+
+On Feb 7, 2004, at 12:46 PM, Robby Findler wrote:
+
+
+<excerpt><fontfamily><param>Apple LiGothic</param>=E6=AD=A1=E8=BF=8E=E4=BD=
+=BF=E7=94=A8 DrScheme
+
+
+Robby</fontfamily></excerpt>=
+
+--Apple-Mail-1--910733453--
+
+ |#
+
+(module traditional-chinese-string-constants "string-constant-lang.ss"
+ (is-this-your-native-language "Is Chinese (in Traditional Characters) Your Native Language?")
+ (interact-with-drscheme-in-language "Interact with DrScheme in Traditional Chinese")
+ (welcome-to-drscheme-version/language "\u6b61\u8fce\u4f7f\u7528 DrScheme, version ~a, ~a")
+ (welcome-to-drscheme "\u6b61\u8fce\u4f7f\u7528 DrScheme")
+ (welcome-to "\u6b61\u8fce\u4f7f\u7528")
+ (wizard-next "\u4e0b\u4e00\u6b65")
+ (wizard-back "\u4e0a\u4e00\u6b65"))
+
diff --git a/collects/swindle/base.ss b/collects/swindle/base.ss
new file mode 100644
index 0000000000..4567eb568d
--- /dev/null
+++ b/collects/swindle/base.ss
@@ -0,0 +1,545 @@
+;;; Written by Eli Barzilay: Maze is Life!  (eli@barzilay.org)
+
+;;> The `base' module defines some basic low-level syntactic extensions to
+;;> MzScheme.  It can be used by itself to get these extensions.
+
+(module base mzscheme
+
+(provide (all-from-except mzscheme
+          #%module-begin #%top #%app define let let* letrec lambda))
+
+;;>> (#%module-begin ...)
+;;>   `base' is a language module -- it redefines `#%module-begin' to load
+;;>   itself for syntax definitions.
+(provide (rename module-begin~ #%module-begin))
+(define-syntax (module-begin~ stx)
+  (let ([e (if (syntax? stx) (syntax-e stx) stx)])
+    (if (pair? e)
+      (datum->syntax-object
+       (quote-syntax here)
+       (list* (quote-syntax #%plain-module-begin)
+              (datum->syntax-object stx
+                                    (list (quote-syntax require-for-syntax)
+                                          '(lib "base.ss" "swindle")))
+              (cdr e))
+       stx)
+      (raise-syntax-error #f "bad syntax" stx)))
+  ;; This doesn't work anymore (from 203.4)
+  ;; (syntax-rules ()
+  ;;   [(_ . body) (#%plain-module-begin
+  ;;                (require-for-syntax (lib "base.ss" "swindle")) . body)])
+  )
+
+;;>> (#%top . id)
+;;>   This special syntax is redefined to make keywords (symbols whose names
+;;>   begin with a ":") evaluate to themselves.  Note that this does not
+;;>   interfere with using such symbols for local bindings.
+(provide (rename top~ #%top))
+(define-syntax (top~ stx)
+  (syntax-case stx ()
+    [(_ . x)
+     (let ([x (syntax-object->datum #'x)])
+       (and (symbol? x) (not (eq? x '||))
+            (eq? #\: (string-ref (symbol->string x) 0))))
+     (syntax/loc stx (#%datum . x))]
+    [(_ . x) (syntax/loc stx (#%top . x))]))
+
+;;>> (#%app ...)
+;;>   Redefined so it is possible to apply using dot notation: `(foo x . y)'
+;;>   is the same as `(apply foo x y)'.  This is possible only when the last
+;;>   (dotted) element is an identifier.
+(provide (rename app~ #%app))
+(define-syntax (app~ stx)
+  (syntax-case stx ()
+    [(_ x ...) (syntax/loc stx (#%app x ...))]
+    [(_ . x)
+     (let loop ([s (syntax-e #'x)] [r '()])
+       (cond [(list? s) (syntax/loc stx (#%app . x))]
+             [(pair? s) (loop (cdr s) (cons (car s) r))]
+             [else (let ([e (and (syntax? s) (syntax-e s))])
+                     (if (or (null? e) (pair? e))
+                       (loop e r)
+                       (quasisyntax/loc stx
+                         (#%app apply . #,(reverse! (cons s r))))))]))]))
+
+;;>> (define id-or-list ...)
+;;>   The standard `define' form is modified so instead of an identifier
+;;>   name for a function, a list can be used -- resulting in a curried
+;;>   function.
+;;>     => (define (((plus x) y) z) (+ x y z))
+;;>     => plus
+;;>     #<procedure:plus>
+;;>     => (plus 5)
+;;>     #<procedure:plus:1>
+;;>     => ((plus 5) 6)
+;;>     #<procedure:plus:2>
+;;>     => (((plus 5) 6) 7)
+;;>     18
+;;>   Note the names of intermediate functions.
+;;>
+;;>   In addition, the following form can be used to define multiple values:
+;;>     => (define (values a b) (values 1 2))
+(provide (rename define~ define))
+(define-syntax (define~ stx)
+  ;; simple version
+  ;; (syntax-case stx ()
+  ;;   [(_ (name arg ...) body ...)
+  ;;    #`(define~ name (lambda~ (arg ...) body ...))]
+  ;;   [(_ name body ...) #'(define name body ...)])
+  ;; this version makes created closures have meaningful names
+  ;; also -- if the syntax is top-level, then translate all defines into a
+  ;;   define with (void) followed by a set! -- this is for the problem of
+  ;;   defining something that is provided by some module, and re-binding a
+  ;;   syntax
+  (syntax-case stx (values)
+    [(_ name expr) (identifier? #'name)
+     (if (eq? 'top-level (syntax-local-context))
+       #'(begin (define-values (name) (void)) (set! name expr))
+       #'(define-values (name) expr))]
+    [(_ (values name ...) expr)
+     (if (eq? 'top-level (syntax-local-context))
+       #'(begin (define name (void)) ...
+                (set!-values (name ...) expr))
+       #'(define-values (name ...) expr))]
+    [(_ names body0 body ...) (pair? (syntax-e #'names))
+     (let loop ([s #'names] [args '()])
+       (syntax-case s ()
+         [(name . arg) (loop #'name (cons #'arg args))]
+         [name
+          (let ([sym (syntax-object->datum #'name)])
+            (let loop ([i    (sub1 (length args))]
+                       [as   (reverse (cdr args))]
+                       [body #'(begin body0 body ...)])
+              (if (zero? i)
+                (if (eq? 'top-level (syntax-local-context))
+                  (quasisyntax/loc stx
+                    (begin (define name (void))
+                           (set! name (lambda~ #,(car args) #,body))))
+                  (quasisyntax/loc stx
+                    (define name (lambda~ #,(car args) #,body))))
+                (loop (sub1 i) (cdr as)
+                      (syntax-property
+                       (quasisyntax/loc stx (lambda~ #,(car as) #,body))
+                       'inferred-name
+                       (string->symbol (format "~a:~a" sym i)))))))]))]))
+
+;;>> (let ([id-or-list ...] ...) ...)
+;;>> (let* ([id-or-list ...] ...) ...)
+;;>> (letrec ([id-or-list ...] ...) ...)
+;;>   All standard forms of `let' are redefined so they can generate
+;;>   functions using the same shortcut that `define' allows.  This includes
+;;>   the above extension to the standard `define'.  For example:
+;;>     => (let ([((f x) y) (+ x y)]) ((f 1) 2))
+;;>     3
+;;>   It also includes the `values' keyword in a similar way to `define'.
+;;>   For example:
+;;>     => (let ([(values i o) (make-pipe)]) i)
+;;>     #<pipe-input-port>
+(provide (rename let~ let) (rename let*~ let*) (rename letrec~ letrec))
+(define-syntaxes (let~ let*~ letrec~)
+  (let* ([process
+          (lambda (stx var0 val0 . flat?)
+            (syntax-case var0 (values)
+              [(values var ...) (null? flat?) #`((var ...) . #,val0)]
+              [_ (let loop ([var var0] [args '()])
+                   (if (identifier? var)
+                     (if (null? args)
+                       (let ([val (syntax->list val0)])
+                         (if (and (pair? val) (null? (cdr val)))
+                           (list (if (null? flat?) (list var) var) (car val))
+                           (raise-syntax-error
+                            #f "bad binding" stx #`(#,var0 #,@val0))))
+                       (let ([sym (syntax-e var)])
+                         (let loop ([i   (sub1 (length args))]
+                                    [as  (reverse args)]
+                                    [val val0])
+                           (if (< i 0)
+                             (list (if (null? flat?) (list var) var)
+                                   (car (syntax->list val)))
+                             (loop (sub1 i) (cdr as)
+                                   (let ([val #`((lambda~ #,(car as) #,@val))])
+                                     (if (zero? i)
+                                       val
+                                       (syntax-property
+                                        val 'inferred-name
+                                        (if (zero? i)
+                                          sym
+                                          (string->symbol
+                                           (format "~a:~a" sym i)))))))))))
+                (syntax-case var ()
+                  [(var . args1) (loop #'var (cons #'args1 args))])))]))]
+         [mk-bindings
+          (lambda (stx bindings . flat?)
+            (syntax-case bindings ()
+              [((var val more ...) ...)
+               (datum->syntax-object
+                #'bindings
+                (map (lambda (x y) (apply process stx x y flat?))
+                     (syntax->list #'(var ...))
+                     (syntax->list #'((val more ...) ...)))
+                #'bindings)]))]
+         [mk-let
+          (lambda (tag . lbl)
+            (lambda (stx)
+              (syntax-case stx ()
+                [(_ label bindings body0 body ...)
+                 (and (identifier? #'label) (pair? lbl))
+                 (quasisyntax/loc stx
+                   (#,(car lbl) label #,(mk-bindings stx #'bindings #t)
+                    body0 body ...))]
+                [(_ bindings body0 body ...)
+                 (quasisyntax/loc stx
+                   (#,tag #,(mk-bindings stx #'bindings) body0 body ...))])))])
+    (values (mk-let #'let-values #'let)
+            (mk-let #'let*-values)
+            (mk-let #'letrec-values))))
+
+;;>> (lambda formals body ...)
+;;>   The standard `lambda' is extended with Lisp-like &-keywords in its
+;;>   argument list.  This extension is available using the above short
+;;>   syntax.  There is one important difference between these keywords and
+;;>   Lisp: some &-keywords are used to access arguments that follow the
+;;>   keyword part of the arguments.  This makes it possible to write
+;;>   procedures that can be invoked as follows:
+;;>     (f <required-args> <optional-args> <keyword-args> <additional-args>)
+;;>   (Note: do not use more keywords after the <additional-args>!)
+;;>
+;;>   Available &-keywords are:
+(provide (rename lambda~ lambda))
+(define-syntax (lambda~ stx)
+  (define (process-optional-arg o)
+    (syntax-case o ()
+      [(var default) (identifier? #'var) (list #'var #'default)]
+      [(var) (identifier? #'var) (list #'var #'#f)]
+      [var (identifier? #'var) (list #'var #'#f)]
+      [var (raise-syntax-error #f "not a valid &optional spec" stx #'var)]))
+  (define (process-keyword-arg k)
+    (define (key var)
+      (datum->syntax-object
+       k
+       (string->symbol
+        (string-append ":" (symbol->string (syntax-object->datum var))))
+       k k))
+    (syntax-case k ()
+      [(var key default) (identifier? #'var) (list #'var #'key #'default)]
+      [(var default) (identifier? #'var) (list #'var (key #'var) #'default)]
+      [(var) (identifier? #'var) (list #'var (key #'var) #'#f)]
+      [var (identifier? #'var) (list #'var (key #'var) #'#f)]
+      [var (raise-syntax-error #f "not a valid &key spec" stx #'var)]))
+  (syntax-case stx ()
+    [(_ formals expr0 expr ...)
+     (let ([vars       '()]
+           [opts       '()]
+           [keys       '()]
+           [rest       #f]  ; keys and all (no optionals)
+           [rest-keys  #f]  ; like the above, minus specified keys
+           [body       #f]  ; stuff that follows all keywords
+           [all-keys   #f]  ; all keys, excluding body
+           [other-keys #f]) ; unprocessed keys, excluding body
+       ;; relations:
+       ;;   rest = (append all-keys body)
+       ;;   rest-keys = (append other-keys body)
+       (let loop ([state #f] [args #'formals])
+         (syntax-case args ()
+           [() #f]
+           [(v . xs)
+            (let* ([v #'v]
+                   [k (if (symbol? v) v (and (identifier? v) (syntax-e v)))]
+                   [x (and k (symbol->string k))])
+              (cond
+               ;; check &-keywords according to their name, so something like
+               ;;  (let ([&rest 1]) (lambda (&rest r) ...))
+               ;; works as expected
+               [(and x (> (string-length x) 0) (eq? #\& (string-ref x 0)))
+                (case k
+;;>   * &optional, &opt, &opts: denote an optional argument, possibly with a
+;;>     default value (if the variable is specified as `(var val)').
+;;>       => ((lambda (x &optional y [z 3]) (list x y z)) 1)
+;;>       (1 #f 3)
+;;>       => ((lambda (x &optional y [z 3]) (list x y z)) 1 2 #f)
+;;>       (1 2 #f)
+                  [(&optional &opt &opts)
+                   (if state
+                     (raise-syntax-error
+                      #f "misplaced &optional argument" stx #'formals)
+                     (loop 'o #'xs))]
+;;>   * &keys, &key: a keyword argument -- the variable should be specified
+;;>     as `x' or `(x)' to be initialized by an `:x' keyword, `(x v)' to
+;;>     specify a default value `v', and `(x k v)' to further specify an
+;;>     arbitrary keyword `k'.
+;;>       => ((lambda (&key x [y 2] [z :zz 3]) (list x y z)) :x 'x :zz 'z)
+;;>       (x 2 z)
+;;>     Note that keyword values take precedence on the left, and that
+;;>     keywords are not verified:
+;;>       => ((lambda (&key y) y) :y 1 :z 3 :y 2)
+;;>       1
+                  [(&key &keys)
+                   (if (memq state '(#f o r!))
+                     (loop 'k #'xs)
+                     (raise-syntax-error
+                      #f "misplaced &keys argument" stx #'formals))]
+;;>   * &rest: a `rest' argument which behaves exactly like the Scheme dot
+;;>     formal parameter (actually a synonym for it: can't use both).  Note
+;;>     that in case of optional arguments, the rest variable holds any
+;;>     arguments that were not used for defaults, but using keys doesn't
+;;>     change its value.  For example:
+;;>       => ((lambda (x &rest r) r) 1 2 3)
+;;>       (2 3)
+;;>       => ((lambda (x &optional y &rest r) r) 1)
+;;>       ()
+;;>       => ((lambda (x &optional y &rest r) r) 1 2 3)
+;;>       (3)
+;;>       => ((lambda (x &optional y . r) r) 1 2 3)
+;;>       (3)
+;;>       => ((lambda (x &key y &rest r) (list y r)) 1 :y 2 3 4)
+;;>       (2 (:y 2 3 4))
+;;>       => ((lambda (x &key y &rest r) (list y r)) 1 :y 2 3 4 5)
+;;>       (2 (:y 2 3 4 5))
+;;>     Note that the last two examples indicate that there is no error if
+;;>     the given argument list is not balanced.
+                  [(&rest)
+                   (if (pair? (syntax-e #'xs))
+                     (loop 'r #'xs)
+                     (raise-syntax-error
+                      #f "no name for &rest argument" stx #'formals))]
+;;>   * &rest-keys: similar to `&rest', but all specified keys are removed
+;;>     with their values.
+;;>       => ((lambda (x &key y &rest r) r) 1 :x 2 :y 3)
+;;>       (:x 2 :y 3)
+;;>       => ((lambda (x &key y &rest-keys r) r) 1 :x 2 :y 3)
+;;>       (:x 2)
+                  [(&rest-keys)
+                   (if (pair? (syntax-e #'xs))
+                     (loop 'rk #'xs)
+                     (raise-syntax-error
+                      #f "no name for &rest-keys argument" stx #'formals))]
+;;>   * &body: similar to `&rest-keys', but all key/values are removed one
+;;>     by one until a non-key is encountered.  (Warning: this is *not* the
+;;>     same as in Common Lisp!)
+;;>       => ((lambda (x &key y &body r) r) 1 :x 2 :y 3)
+;;>       ()
+;;>       => ((lambda (x &key y &body r) r) 1 :x 2 :y 3 5 6)
+;;>       (5 6)
+                  [(&body &rest-all-keys) ; &rest-all-keys for compatibility
+                   (if (pair? (syntax-e #'xs))
+                     (loop 'b #'xs)
+                     (raise-syntax-error
+                      #f "no name for &body argument"
+                      stx #'formals))]
+;;>   * &all-keys: the list of all keys+vals, without a trailing body.
+;;>       => ((lambda (&keys x y &all-keys r) r) :x 1 :z 2 3 4)
+;;>       (:x 1 :z 2)
+                  [(&all-keys)
+                   (if (pair? (syntax-e #'xs))
+                     (loop 'ak #'xs)
+                     (raise-syntax-error
+                      #f "no name for &all-keys argument"
+                      stx #'formals))]
+;;>   * &other-keys: the list of unprocessed keys+vals, without a trailing
+;;>     body.
+;;>       => ((lambda (&keys x y &other-keys r) r) :x 1 :z 2 3 4)
+;;>       (:z 2)
+                  [(&other-keys)
+                   (if (pair? (syntax-e #'xs))
+                     (loop 'ok #'xs)
+                     (raise-syntax-error
+                      #f "no name for &other-keys argument"
+                      stx #'formals))]
+;;>
+;;>   Finally, here is an example where all &rest-like arguments are
+;;>   different:
+;;>     => ((lambda (&keys x y
+;;>                  &rest r
+;;>                  &rest-keys rk
+;;>                  &body b
+;;>                  &all-keys ak
+;;>                  &other-keys ok)
+;;>           (list r rk b ak ok))
+;;>         :z 1 :x 2 2 3 4)
+;;>     ((:z 1 :x 2 2 3 4) (:z 1 2 3 4) (2 3 4) (:z 1 :x 2) (:z 1))
+;;>   Note that the following invariants hold:
+;;>   * rest = (append all-keys body)
+;;>   * rest-keys = (append other-keys body)
+                  [else (raise-syntax-error
+                         #f "unknown lambda &-keyword" stx v)])]
+               [(not (or x (memq state '(o k))))
+                (raise-syntax-error #f "not an identifier" stx v)]
+               [else
+                (let ([test (lambda (var name)
+                              (if var
+                                (raise-syntax-error
+                                 #f (format "too many &~a arguments" name)
+                                 stx #'formals)
+                                (set! state 'r!)))])
+                  (case state
+                    [(#f) (set! vars (cons v vars))]
+                    [(o)  (set! opts (cons v opts))]
+                    [(k)  (set! keys (cons v keys))]
+                    [(r!) (raise-syntax-error
+                           #f "second identifier after a &rest or similar"
+                           stx v)]
+                    [(r)  (test rest       'rest      ) (set! rest v)]
+                    [(rk) (test rest-keys  'rest-keys ) (set! rest-keys v)]
+                    [(b)  (test body       'body      ) (set! body v)]
+                    [(ak) (test all-keys   'all-keys  ) (set! all-keys v)]
+                    [(ok) (test other-keys 'other-keys) (set! other-keys v)]
+                    [else (raise-syntax-error #f "bad lambda formals" stx v)])
+                  (loop state #'xs))]))]
+           [v (loop state #'(&rest v))]))
+       (set! vars (reverse! vars))
+       (set! opts (map process-optional-arg (reverse! opts)))
+       (set! keys (map process-keyword-arg  (reverse! keys)))
+       (when (and (or rest-keys body all-keys other-keys) (not rest))
+         (set! rest #'rest))
+       (cond
+        ;; non-trivial case -- full processing
+        [(or (pair? opts) (pair? keys) rest-keys body all-keys other-keys)
+         (unless rest (set! rest #'rest))
+         ;; other-keys is computed from all-keys
+         (when (and other-keys (not all-keys)) (set! all-keys #'all-keys))
+         (quasisyntax/loc stx
+           (lambda (#,@vars . #,rest)
+             (let*-values
+                 (#,@(map (lambda (o)
+                            #`[(#,(car o))
+                               (if (pair? #,rest)
+                                 (begin0 (car #,rest)
+                                   (set! #,rest (cdr #,rest)))
+                                 #,(cadr o))])
+                          opts)
+                  #,@(map (lambda (k)
+                            #`[(#,(car k))
+                               (getarg #,rest #,(cadr k)
+                                       (lambda () #,(caddr k)))])
+                          keys)
+                  #,@(if rest-keys
+                       #`([(#,rest-keys)
+                           (filter-out-keys '#,(map cadr keys) #,rest)])
+                       #'())
+                  #,@(cond
+                      ;; At most one scan for body, all-keys, other-keys.  This
+                      ;; could be much shorter by always using keys/args, but a
+                      ;; function call is not a place to spend time on.
+                      [(and body all-keys)
+                       #`([(#,all-keys #,body)
+                           ;; inlined keys/args
+                           (let loop ([args #,rest] [keys '()])
+                             (cond [(or (null? args)
+                                        (null? (cdr args))
+                                        (not (keyword? (car args))))
+                                    (values (reverse! keys) args)]
+                                   [else (loop (cddr args)
+                                               (list* (cadr args) (car args)
+                                                      keys))]))])]
+                      [body
+                       #`([(#,body)
+                           (let loop ([args #,rest])
+                             (if (or (null? args)
+                                     (null? (cdr args))
+                                     (not (keyword? (car args))))
+                               args
+                               (loop (cddr args))))])]
+                      [all-keys
+                       #`([(#,all-keys)
+                           ;; inlined keys/args, not returning args
+                           (let loop ([args #,rest] [keys '()])
+                             (cond [(or (null? args)
+                                        (null? (cdr args))
+                                        (not (keyword? (car args))))
+                                    (reverse! keys)]
+                                   [else (loop (cddr args)
+                                               (list* (cadr args) (car args)
+                                                      keys))]))])]
+                      [else #'()])
+                  #,@(if other-keys
+                       #`([(#,other-keys) ; use all-keys (see above)
+                           (filter-out-keys '#,(map cadr keys) #,all-keys)])
+                       #'()))
+               expr0 expr ...)))]
+        ;; common cases: no optional, keyword, or otherfancy stuff
+        [(null? vars)
+         (quasisyntax/loc stx
+           (lambda #,(or rest #'()) expr0 expr ...))]
+        [else
+         (quasisyntax/loc stx
+           (lambda (#,@vars . #,(or rest #'())) expr0 expr ...))]))]))
+
+;; Utilities for the above (note: no errors for odd length)
+(provide keyword? syntax-keyword?
+         getarg syntax-getarg getargs keys/args filter-out-keys)
+;;>> (keyword? x)
+;;>   A predicate for keyword symbols (symbols that begin with a ":").
+(define (keyword? x)
+  (and (symbol? x) (not (eq? x '||))
+       (eq? (string-ref (symbol->string x) 0) #\:)))
+;;>> (syntax-keyword? x)
+;;>   Similar to `keyword?' but also works for an identifier (a syntax
+;;>   object) that contains a keyword.
+(define (syntax-keyword? x)
+  (keyword? (if (syntax? x) (syntax-e x) x)))
+;;>> (getarg args keyword [not-found])
+;;>   Searches the given list of arguments for a value matched with the
+;;>   given keyword.  Similar to CL's `getf', except no error checking is
+;;>   done for an unbalanced list.  In case no value is found, the optional
+;;>   default value can be used -- this can be either a thunk, a promise, or
+;;>   any other value that will be used as is.  For a repeated keyword the
+;;>   leftmost occurrence is used.
+(define (getarg args keyword . not-found)
+  (let loop ([args args])
+    (cond [(or (null? args) (null? (cdr args)))
+           (and (pair? not-found)
+                (let ([x (car not-found)])
+                  (cond [(procedure? x) (x)]
+                        [(promise? x) (force x)]
+                        [else x])))]
+          [(eq? (car args) keyword) (cadr args)]
+          [else (loop (cddr args))])))
+;;>> (syntax-getarg syntax-args keyword [not-found])
+;;>   Similar to `getarg' above, but the input is a syntax object of a
+;;>   keyword-value list.
+(define (syntax-getarg syntax-args keyword . not-found)
+  (when (syntax? keyword) (set! keyword (syntax-e keyword)))
+  (let loop ([args syntax-args])
+    (syntax-case args ()
+      [(key arg . more)
+       (if (eq? (syntax-e #'key) keyword) #'arg (loop #'more))]
+      [_ (and (pair? not-found)
+              (let ([x (car not-found)])
+                (cond [(procedure? x) (x)]
+                      [(promise? x) (force x)]
+                      [else x])))])))
+;;>> (getargs initargs keyword)
+;;>   The same as `getarg' but return the list of all key values matched --
+;;>   no need for a default value.  The result is in the same order as in
+;;>   the input.
+(define (getargs initargs keyword)
+  (define (scan tail)
+    (cond [(null? tail) '()]
+          [(null? (cdr tail)) (error 'getargs "keyword list not balanced.")]
+          [(eq? (car tail) keyword) (cons (cadr tail) (scan (cddr tail)))]
+          [else (scan (cddr tail))]))
+  (scan initargs))
+;;>> (keys/args args)
+;;>   The given argument list is scanned and split at the point where there
+;;>   are no more keyword-values, and the two parts are returned as two
+;;>   values.
+;;>     => (keys/args '(:a 1 :b 2 3 4 5))
+;;>     (:a 1 :b 2)
+;;>     (3 4 5)
+(define (keys/args args)
+  (let loop ([args args] [keys '()])
+    (cond [(or (null? args) (null? (cdr args)) (not (keyword? (car args))))
+           (values (reverse! keys) args)]
+          [else (loop (cddr args) (list* (cadr args) (car args) keys))])))
+;;>> (filter-out-keys outs args)
+;;>   The keywords specified in the outs argument, with their matching
+;;>   values are filtered out of the second arguments.
+(define (filter-out-keys outs args)
+  (let loop ([as args] [r '()])
+    (cond [(null? as) (reverse! r)]
+          [(null? (cdr as)) (reverse! (cons (car as) r))]
+          [else
+           (loop (cddr as)
+                 (if (memq (car as) outs) r (list* (cadr as) (car as) r)))])))
+
+)
diff --git a/collects/swindle/clos.ss b/collects/swindle/clos.ss
new file mode 100644
index 0000000000..8db9023b0f
--- /dev/null
+++ b/collects/swindle/clos.ss
@@ -0,0 +1,767 @@
+;;; Written by Eli Barzilay: Maze is Life!  (eli@barzilay.org)
+
+;;> This module contains only syntax definitions, which makes Swindle closer
+;;> to CLOS -- making the object system much more convenient to use.
+
+(module clos (lib "turbo.ss" "swindle")
+
+(require (lib "tiny-clos.ss" "swindle"))
+(provide (all-from (lib "tiny-clos.ss" "swindle")))
+
+;;; ---------------------------------------------------------------------------
+;;; General helpers
+
+(defsyntax (args-arity stx)
+  (syntax-case stx ()
+    [(_ args)
+     (let loop ([args #'args] [n 0])
+       (syntax-case args ()
+         [(a . more)
+          (or (not (identifier? #'a))
+              ;; stop at &-keyword
+              (let ([sym (syntax-e #'a)])
+                (or (eq? sym '||)
+                    (not (eq? #\& (string-ref (symbol->string sym) 0))))))
+          (loop #'more (add1 n))]
+         [() (datum->syntax-object stx n stx)]
+         [_  (quasisyntax/loc stx (make-arity-at-least #,n))]))]))
+
+;;; ---------------------------------------------------------------------------
+;;; Generic macros
+
+;;>>... Generic macros
+
+;;>> (generic)
+;;> | (generic name initargs ...)
+;;> | (generic name (arg ...) initargs ...)
+;;>   Create a generic function object (an instance of the
+;;>   `*default-generic-class*' parameter).  The first form uses the default
+;;>   name given by the syntactical context, the second one gets an explicit
+;;>   name and the third also gets a list of arguments which is used to
+;;>   count the required number of arguments.  If there is no argument list
+;;>   to count, the first method that gets added will set this number.  The
+;;>   two last forms allow initargs to be passed to the <generic> instance
+;;>   creation, for example, to specify a `:combination' argument.  (The
+;;>   first form does not allow keywords, since a keyword would be taken as
+;;>   the name.)
+(defsyntax* (generic stx)
+  (syntax-case stx ()
+    [(_)
+     #`(make (*default-generic-class*) :name '#,(syntax-local-name))]
+    [(_ name) (identifier? #'name)
+     #'(make (*default-generic-class*) :name 'name)]
+    [(_ name initarg initargs ...)
+     (and (identifier? #'name) (syntax-keyword? #'initarg))
+     #'(make (*default-generic-class*) initarg initargs ... :name 'name)]
+    [(_ name args) (identifier? #'name)
+     #`(make (*default-generic-class*)
+             :name 'name :arity (args-arity args))]
+    [(_ name args initarg initargs ...)
+     (and (identifier? #'name) (syntax-keyword? #'initarg))
+     #`(make (*default-generic-class*)
+             initarg initargs ... :name 'name :arity (args-arity args))]))
+
+;;>> (defgeneric name (arg ...) initargs ...)
+;;> | (defgeneric (name arg ...) initargs ...)
+;;> | (defgeneric name initargs ...)
+;;>   This form defines a generic function using the `generic' syntax given
+;;>   above.  The last form doesn't specify a number of arguments.  Some
+;;>   extra `initargs' can be specified too but they are needed mainly for a
+;;>   `:combination' argument.
+(defsyntax* (defgeneric stx)
+  (let* ([ctx (syntax-local-context)]
+         [ctx (cond [(pair? ctx) (car ctx)]
+                    [(eq? ctx 'top-level) ctx]
+                    [else #f])]
+         [mark (lambda (name)
+                 ((syntax-local-value #'generic-contexts-defined?) name ctx))])
+    (syntax-case stx ()
+      [(_ name args initargs ...) (identifier? #'name)
+       (begin (mark #'name) #'(define name (generic name args initargs ...)))]
+      [(_ (name . args) initargs ...) (identifier? #'name)
+       (begin (mark #'name) #'(define name (generic name args initargs ...)))]
+      [(_ name initargs ...) (identifier? #'name)
+       (begin (mark #'name) #'(define name (generic name initargs ...)))])))
+
+;; returns #t if an identifier id in context ctx is already defined as a genric
+;; (used by defmethod to detect when it should expand to an add-method)
+(define-syntax generic-contexts-defined?
+  (let ([table (make-hash-table 'weak)])
+    (lambda (id ctx)
+      ;; ctx is either the first element of (syntax-local-context) or
+      ;; 'top-level.  Note that top-level identifiers in different modules
+      ;; should not be `module-identifier=?' (eg, `eval' takes care of this).
+      (let ([cs (hash-table-get table ctx (lambda () '()))])
+        (or (ormap (lambda (c) (module-identifier=? id c)) cs) ; defined
+            (begin (hash-table-put! table ctx (cons id cs)) ; undefined
+                   #f))))))
+
+;;; ---------------------------------------------------------------------------
+;;; Method macros
+
+;;>>... Method macros
+
+;;>> (call-next-method [args ...]) [*local*]
+;;>> (next-method?) [*local*]
+;;>   These are bindings which are available only in method bodies.
+;;>   `call-next-method' will invoke the next method in a generic invocation
+;;>   sequence if any.  If arguments are given to `call-next-method', it
+;;>   will change the arguments for the next method -- but this is done when
+;;>   the methods are already filtered and sorted, so the new arguments
+;;>   should always be consistent with the old types.  If there are no
+;;>   methods left, or when calling a method directly, or when a before or
+;;>   after method is used, the `no-next-method' generic will be used --
+;;>   normally resulting in an error.  `next-method?' returns `#t' if there
+;;>   is another method ready to be called.
+
+(defsyntax (make-method-specs/initargs stx)
+  (syntax-case stx ()
+    [(_ name args0 body . more)
+     (let loop ([args #'args0] [specializers '()] [arguments '()])
+       (syntax-case args (=)
+         [([arg = val] . rest)
+          (loop #'rest
+                (cons #'(singleton val) specializers) (cons #'arg arguments))]
+         [([arg type] . rest)
+          (loop #'rest (cons #'type specializers) (cons #'arg arguments))]
+         [([arg] . rest)
+          (loop #'rest (cons #'<top> specializers) (cons #'arg arguments))]
+         [(arg . rest)
+          (and (identifier? #'arg)
+               ;; stop at &-keyword
+               (let ([sym (syntax-e #'arg)])
+                 (or (eq? sym '||)
+                     (not (eq? #\& (string-ref (symbol->string sym) 0))))))
+          (loop #'rest (cons #'<top> specializers) (cons #'arg arguments))]
+         [_ ; both null and rest argument
+          (let* ([specializers (reverse! specializers)]
+                 [arguments    (reverse! arguments)]
+                 [name-e       (syntax-e #'name)]
+                 [cnm (datum->syntax-object
+                       #'args0 'call-next-method #'args0)])
+            (unless (null? (syntax-e args))
+              (set! arguments
+                    (if (null? arguments) args (append! arguments args))))
+            (let ([makeit
+                   (quasisyntax/loc stx
+                     (make (*default-method-class*)
+                           :specializers (list #,@specializers)
+                           :name '#,(if name-e #'name (syntax-local-name))
+                           :procedure
+                           (lambda (#,cnm . #,arguments)
+                             ;; See "Trick" in tiny-clos.ss
+                             ;; -- use a syntax to not do this unless needed
+                             (letsyntax
+                                 ([#,(datum->syntax-object
+                                      #'args0 'next-method? #'args0)
+                                   (lambda (stx)
+                                     (syntax-case stx ()
+                                       [(__) #'(not (eq? '*no-next-method*
+                                                         (object-name #,cnm)))]
+                                       [(__ . xs)
+                                        #'((named-lambda next-method? () 1)
+                                           . xs)]
+                                       [__
+                                        #'(named-lambda next-method? ()
+                                            (not
+                                             (eq? '*no-next-method*
+                                                  (object-name #,cnm))))]))])
+                               . body))
+                           . more))])
+              (if name-e
+                (quasisyntax/loc stx (letrec ([name #,makeit]) name))
+                makeit)))]))]))
+
+;;>> (method (arg ...) body ...)
+;;>> (named-method name (arg ...) body ...)
+;;>> (qualified-method qualifier (arg ...) body ...)
+;;>   These forms are all similar variants to create a method object (and
+;;>   instance of the `*default-method-class*' parameter).  A method looks
+;;>   very similar to a lambda expression, except that the an argument can
+;;>   be a of the form `[arg spec]' where `spec' is a specializer -- either
+;;>   a class or a singleton specifier (the square brackets are equivalent
+;;>   to round parens, just make the code more readable).  Also, an argument
+;;>   can have the form of `[arg = val]' which is shorthand for specifying
+;;>   `[arg (singleton val)]'.  In case of a simple argument, <top> is
+;;>   always used as a specializer, but this processing stops as soon as a
+;;>   &-keyword is encountered.  The `named-method' form is used to provide
+;;>   an explicit name (which can be used to call itself recursively) , and
+;;>   `qualified-method' is used to provide an explicit qualifier (which
+;;>   should be one of the standard qualifiers (:primary, :around, :before,
+;;>   or :after) when using the standard <method> and <generic> classes).
+;;>
+;;>   The resulting method can be added to a generic and these specializers
+;;>   will be used when filtering applicable methods, or it can be used by
+;;>   itself and the specializers will be used to check the arguments.  This
+;;>   makes it easy to use `method' instead of `lambda' to get some type
+;;>   information, but note that the result is going to run slower since the
+;;>   type check only takes time but cannot be used by MzScheme to optimize
+;;>   the code.
+;;>
+;;>   Note that the specializer argument are evaluated normally, which means
+;;>   that anything can be used, even something like:
+;;>     (let ([x (list <string> <integer>)])
+;;>       (method ([x (2nd x)] [y = (+ 2 3)]) (+ x y)))
+(defsubst* (method args body0 body ...)
+  (make-method-specs/initargs #f args (body0 body ...)))
+(defsubst* (named-method name args body0 body ...)
+  (make-method-specs/initargs name args (body0 body ...)))
+(defsubst* (qualified-method qualifier args body0 body ...)
+  (make-method-specs/initargs #f args (body0 body ...) :qualifier qualifier))
+
+;;>> (-defmethod-create-generics- [#t/#f])
+;;>   This is a syntax parameter (see above) holding a boolean.  When this
+;;>   is set to `#t' (the default), then the `defmethod' form below will try
+;;>   to detect when the first definition happens and automatic add a
+;;>   `defgeneric' form to define the object as a generic.  A safer but less
+;;>   convenient approach would be to set this to `#f' and always do an
+;;>   explicit `defgeneric'.
+(define-syntax-parameter* -defmethod-create-generics- #t)
+
+(defsyntax (method-def-adder stx)
+  (syntax-case stx ()
+    [(_ qualifier name args body ...) (identifier? #'name)
+     ;; always make it with no name so add-method will add it
+     (with-syntax ([method-make (syntax/loc stx
+                                  (qualified-method qualifier args body ...))])
+       (let ([ctx (syntax-local-context)])
+         (cond
+          [(or ; if:
+            ;; not enabled
+            (not (syntax-e ((syntax-local-value
+                             #'-defmethod-create-generics-))))
+            ;; expression position -- same as using add-method
+            (eq? 'expression ctx)
+            ;; defined symbol or second module binding
+            (identifier-binding #'name)
+            ;; already defined in this local context or top-level
+            (let ([ctx (cond [(pair? ctx) (car ctx)]
+                             [(eq? ctx 'top-level) ctx]
+                             [else #f])])
+              (and ctx ((syntax-local-value #'generic-contexts-defined?)
+                        #'name ctx))))
+           ;; then use add-method
+           ;; (printf ">>> ~s: add\n" (syntax-e #'name))
+           (syntax/loc stx (add-method name method-make))]
+          ;; this might still be useful sometimes...
+          ;; [(eq? 'top-level ctx)
+          ;;  ;; if top-level then use a trick: try to use an
+          ;;  (syntax/loc stx
+          ;;    (define name ; trick: try using exising generic
+          ;;      (let ([g (or (no-errors name) (generic name))])
+          ;;        (add-method g method-make)
+          ;;        g)))]
+          [else
+           ;; first module or function binding
+           ;; (printf ">>> ~s: def\n" (syntax-e #'name))
+           (syntax/loc stx (define name
+                             (let ([g (generic name)])
+                               (add-method g method-make)
+                               g)))])))]))
+
+;;>> (defmethod name [qualifier] (arg ...) body ...)
+;;> | (defmethod [qualifier] (name arg ...) body ...)
+;;>   This form is used to define a method object using `method' and its
+;;>   variants above.  A qualifier (a :keyword) can be specified anywhere
+;;>   before the argument list, and the name can be either specified before
+;;>   the arguments (Lisp style) or with the arguments (Scheme style).
+;;>   Depending on `-defmethod-create-generics-' (see above), this form
+;;>   might add a `defgeneric' form to define the given `name' as a generic
+;;>   object, and then add the created method.  The created method is
+;;>   attached to the generic in any case, which makes the name of this form
+;;>   a little misleading since it is not always defining a variable value.
+;;>   In a local definition context, this should do the right thing as long
+;;>   as `defmethod' or `defgeneric' is used to define the method (but note
+;;>   that using a local generic function, is very inefficient) -- for
+;;>   example, both of these work (defining a local generic):
+;;>     (define (f)
+;;>       (defgeneric foo)
+;;>       (defmethod (foo [x <c1>]) 1)
+;;>       (defmethod (foo [x <c2>]) 2)
+;;>       3)
+;;>     (define (f)
+;;>       (defmethod (foo [x <c1>]) 1)
+;;>       (defmethod (foo [x <c2>]) 2)
+;;>       3)
+;;>   but this fails because the first `defmethod' doesn't know that it is
+;;>   already defined:
+;;>     (define (f)
+;;>       (define foo (generic foo))
+;;>       (defmethod (foo [x c1]) 1)
+;;>       (defmethod (foo [x c1]) 2)
+;;>       3)
+;;>   second "but" -- this:
+;;>     (define (f)
+;;>       (define foo (generic foo))
+;;>       blah
+;;>       (defmethod (foo [x <c1>]) 1)
+;;>       (defmethod (foo [x <c2>]) 2)
+;;>       3)
+;;>   works because a `defmethod' in an expression context is always the
+;;>   same as `add-method'.
+(defsyntax* (defmethod stx)
+  (define (n+a? stx)
+    (let ([na (syntax-e stx)]) (and (pair? na) (identifier? (car na)))))
+  (syntax-case stx ()
+    [(_ name qualifier args body0 body ...)
+     (and (identifier? #'name) (syntax-keyword? #'qualifier))
+     (syntax/loc stx
+       (method-def-adder qualifier name args body0 body ...))]
+    [(_ qualifier name args body0 body ...)
+     (and (identifier? #'name) (syntax-keyword? #'qualifier))
+     (syntax/loc stx
+       (method-def-adder qualifier name args body0 body ...))]
+    [(_ qualifier name+args body0 body ...)
+     (and (n+a? #'name+args) (syntax-keyword? #'qualifier))
+     ;; simple pattern matching with (name . args) and using args won't work
+     ;; since the destructing loses the arguments context and call-next-method
+     ;; won't be accessible in the body.
+     (with-syntax ([name (car (syntax-e #'name+args))]
+                   [args (datum->syntax-object ; hack binding context!
+                          #'name+args
+                          (cdr (syntax-e #'name+args))
+                          #'name+args)])
+       (syntax/loc stx
+         (method-def-adder qualifier name args body0 body ...)))]
+    [(_ name+args body0 body ...) (n+a? #'name+args)
+     ;; same as above
+     (with-syntax ([name (car (syntax-e #'name+args))]
+                   [args (datum->syntax-object ; hack binding context!
+                          #'name+args
+                          (cdr (syntax-e #'name+args))
+                          #'name+args)])
+       (syntax/loc stx
+         (method-def-adder #f name args body0 body ...)))]
+    [(_ name args body0 body ...) (identifier? #'name)
+     (syntax/loc stx (method-def-adder #f name args body0 body ...))]))
+
+;;>> (beforemethod ...)
+;;>> (aftermethod ...)
+;;>> (aroundmethod ...)
+;;>> (defbeforemethod ...)
+;;>> (defaftermethod ...)
+;;>> (defaroundmethod ...)
+;;>   These forms are shorthands that will generate a qualified method using
+;;>   one of the standard qualifiers.
+(defsubst* (beforemethod . more) (qualified-method :before . more))
+(defsubst* (aftermethod  . more) (qualified-method :after  . more))
+(defsubst* (aroundmethod . more) (qualified-method :around . more))
+(defsubst* (defbeforemethod . more) (defmethod :before . more))
+(defsubst* (defaftermethod  . more) (defmethod :after  . more))
+(defsubst* (defaroundmethod . more) (defmethod :around . more))
+
+;;; ---------------------------------------------------------------------------
+;;; Class macros
+
+;;>>... Class macros
+
+(defsyntax (make-class-form stx)
+  (define (slots/initargs s/a)
+    (define (syntax-null? x)
+      (or (null? x)
+          (and (syntax? x)
+               (null? (syntax-e x)))))
+
+    (define (syntax-car x)
+      (cond ((pair? x) (car x))
+            ((syntax? x) (car (syntax-e x)))
+            (else (error "Syntax car"))))
+
+    (define (syntax-cdr x)
+      (cond ((pair? x) (cdr x))
+            ((syntax? x) (cdr (syntax-e x)))
+            (else (error "Syntax cdr"))))
+
+    (define (syntax-cadr x) (syntax-car (syntax-cdr x)))
+    (define (syntax-cddr x) (syntax-cdr (syntax-cdr x)))
+
+    (let loop ([xs s/a]
+               [r '()]
+               ;; use #F so we can tell the difference between
+               ;; unsupplied and specifically false.
+               [default-initargs #f])
+      (syntax-case xs (:default-initargs)
+        [() (values (datum->syntax-object #'s/a (reverse! r) #'s/a)
+                    #'()
+                    (datum->syntax-object #'s/a default-initargs #'s/a))]
+        [((name . args) . more) (identifier? #'name)
+         (loop #'more (cons #'(list 'name . args) r) default-initargs)]
+        [(:default-initargs val . more)
+         (loop #'more r
+               (do ((tail (syntax val) (syntax-cddr tail))
+                    (result '() (cons #`(list '#,(syntax-car tail)
+                                              '#,(syntax-cadr tail)
+                                              (lambda ()
+                                                #,(syntax-cadr tail)))
+                                      result)))
+                   ((syntax-null? tail)
+                    #`(list #,@(reverse! result)))))]
+        [(key val . more) (syntax-keyword? #'key)
+         (values (datum->syntax-object #'s/a (reverse! r) #'s/a)
+                 #'(key val . more)
+                 (datum->syntax-object #'s/a default-initargs #'s/a))]
+        [(name . more) (identifier? #'name)
+         (loop #'more (cons #'(list 'name) r) default-initargs)])))
+  (syntax-case stx ()
+    [(_ metaclass cname supers . s/a)
+     (let*-values ([(slots initargs default-initargs) (slots/initargs #'s/a)]
+                   [(meta) (syntax-getarg initargs :metaclass #'metaclass)])
+       (with-syntax ([(arg ...) #`(#,@initargs
+                                   :direct-default-initargs #,default-initargs
+                                   :direct-supers (list . supers)
+                                   :direct-slots (list #,@slots)
+                                   :name '#,(if (syntax-e #'cname)
+                                              #'cname (syntax-local-name)))])
+         (if (identifier? #'cname)
+           #`(rec-make (cname #,meta arg ...))
+           #`(make #,meta arg ...))))]))
+
+;;>> (class [name] (super ...) slot ... class-initarg ...)
+;;>   Create a class object (an instance of the `*default-class-class*'
+;;>   parameter).  An explicit name can optionally be specified explicitly.
+;;>   The list of superclasses are evaluated normally, so they can be any
+;;>   expression (as with the `method' forms).  Each slot can be either a
+;;>   symbol, which will be used as the slot name, or a list that begins
+;;>   with a symbol and continues with a keyword-argument option list.
+;;>   Finally, more initargs for the class generation can be provided.  See
+;;>   the `defclass' forms below for an explanation on the available slot
+;;>   option and class initargs.  If a name is given, then `rec-make' is
+;;>   used, see that for a description.
+(defsyntax* (class stx)
+  (syntax-case stx ()
+    [(_ name supers slot ...) (identifier? #'name)
+     #'(make-class-form (*default-class-class*) name supers slot ...)]
+    [(_ supers slot ...)
+     #'(make-class-form (*default-class-class*) #f supers slot ...)]))
+
+;;>> (entityclass [name] (super) slot ... class-initarg ...)
+;;>   Same as the `class' form, but creates an entity class object (an
+;;>   instance of the `*default-entityclass-class*' parameter).
+(defsyntax* (entityclass stx)
+  (syntax-case stx ()
+    [(_ name supers slot ...) (identifier? #'name)
+     #'(make-class-form (*default-entityclass-class*) name supers slot ...)]
+    [(_ supers slot ...)
+     #'(make-class-form (*default-entityclass-class*) #f supers slot ...)]))
+
+;;>> (-defclass-auto-initargs- [#f/initargs])
+;;>   This is a syntax parameter (see above) holding either `#f' or an
+;;>   initargs list .  If it is not `#f', `defclass' below will add its
+;;>   contents to the end of the given initargs (so user supplied arguments
+;;>   can override them).  The default is `#f'.
+(define-syntax-parameter* -defclass-auto-initargs- #f)
+
+;;>> (-defclass-autoaccessors-naming- [naming-keyword])
+;;>   This syntax parameter holds a keyword symbol that is used in the
+;;>   `defclass' for the `:autoaccessors' if it is specified as `#t' or if
+;;>   it used due to `:auto'.  See the description of the `:autoaccessors'
+;;>   option below for possible values.  The default is `:class-slot'.
+(define-syntax-parameter* -defclass-autoaccessors-naming- :class-slot)
+
+;;>> (-defclass-accessor-mode- [mode-keyword])
+;;>   This syntax parameter holds a keyword symbol that is used in the
+;;>   `defclass' for the way accessors, readers, and writers are generated.
+;;>   It can be `:defmethod' for using `defmethod', `:defgeneric' for using
+;;>   `defgeneric' and then `add-method', `:add-method' for using
+;;>   `add-method', `:method' for defining an independent method, or
+;;>   `:procedure' for defining a simple Scheme procedure.  The default is
+;;>   `:defmethod.  This default is usually fine, but a situation where this
+;;>   is important is if the syntax parameter `-defmethod-create-generics-'
+;;>   is set to `#f' so a `defmethod' requires a prior `defgeneric' so a
+;;>   defclass will not work unless the generic functions are defined in
+;;>   advance.
+(define-syntax-parameter* -defclass-accessor-mode- :defmethod)
+
+;;>> (defclass name (super ...) slot ... class-initarg ...)
+;;>   This form uses the `class' form above to define a new class.  See the
+;;>   `class' form for the syntax.  Note that slot-options that are not
+;;>   compile-time ones (method names) are accumulated according to the
+;;>   class precedence list.
+;;>
+;;>   Available slot options are:
+;;>   * :initarg keyword
+;;>     Use `keyword' in `make' to provide a value for this slot.
+;;>   * :initializer func
+;;>     Use the given function to initialize the slot -- either a thunk or a
+;;>     function that will be applied on the initargs given to `make'.
+;;>   * :initvalue value
+;;>     Use `value' as the default for this slot.
+;;>   * :reader name
+;;>     Define `name' (an unquoted symbol) as a reader method for this slot.
+;;>   * :writer name
+;;>     Define `name' (an unquoted symbol) as a writer method for this slot.
+;;>   * :accessor name
+;;>     Define `name' (an unquoted symbol) as an accessor method for this
+;;>     slot -- this means that two methods are defined: `name' and
+;;>     `set-name!'.
+;;>   * :type type
+;;>     Restrict this slot value to objects of the given `type'.
+;;>   * :lock { #t | #f | value }
+;;>     If specified and non-`#f', then this slot is locked.  `#t' locks it
+;;>     permanently, but a diffrent value works as a key: they allow setting
+;;>     the slot by using cons of the key and the value to set.
+;;>   * :allocation { :class | :instance }
+;;>     Specify that this slot is a normal one (`:instance', the default),
+;;>     or allocated per class (`:class').
+;;>   The specific way of creating helper methods (for readers, writers, and
+;;>   accessors) is determined by `-defclass-accessor-mode-' (see above).
+;;>
+;;>   Available class options (in addition to normal ones that initialize
+;;>   the class slots like `:name', `:direct-default-initargs', `:direct-slots', `:direct-supers') are:
+;;>   * :metaclass class
+;;>     create a class object which is an instance of the `class'
+;;>     meta-class (this means that an instance of the given meta-class
+;;>     should be used for creating the new class).
+;;>   * :autoinitargs { #t | #f }
+;;>     if set to `#t', make the class definition automatically generate
+;;>     initarg keywords from the slot names.
+;;>   * :autoaccessors { #f | #t | :class-slot | :slot }
+;;>     if set to non-`#f', generate accessor methods automatically --
+;;>     either using the classname "-" slotname convention (`:class-slot')
+;;>     or just the slotname (`:slot').  If it is `#t' (or turned on by
+;;>     `:auto') then the default naming style is taken from the
+;;>     `-defclass-autoaccessors-naming-' syntax parameter.  Note that for
+;;>     this, and other external object definitions (`:automaker' and
+;;>     `:autopred'), the class name is stripped of a surrounding "<>"s if
+;;>     any.
+;;>   * :automaker { #f | #t }
+;;>     automatically creates a `maker' function using the "make-" classname
+;;>     naming convention.  The maker function is applied on arguments and
+;;>     keyword-values -- if there are n slots, then arguments after the
+;;>     first n are passed to `make' to create the instance, then the first
+;;>     n are `slot-set!'ed into the n slots.  This means that it can get
+;;>     any number of arguments, and usually there is no point in additional
+;;>     keyword values (since if they initialize slots, their values will
+;;>     get overridden anyway).  It also means that the order of the
+;;>     arguments depend on the *complete* list of the class's slots (as
+;;>     given by `class-slots'), so use caution when doing multiple
+;;>     inheritance (actually, in that case it is probably better to avoid
+;;>     these makers anyway).
+;;>   * :autopred { #f | #t }
+;;>     automatically create a predicate function using the `classname "?"'
+;;>     naming convention.
+;;>   * :default-slot-options { #f | '(keyword ...) }
+;;>     if specified as a quoted list, then slot descriptions are modified
+;;>     so the first arguments are taken as values to the specified
+;;>     keywords.  For example, if it is `'(:type :initvalue)' then a slot
+;;>     description can have a single argument for `:type' after the slot
+;;>     name, a second argument for `:initvalue', and the rest can be more
+;;>     standard keyword-values.  This is best set with
+;;>     `-defclass-auto-initargs-'
+;;>   * :auto { #f | #t }
+;;>     if specified as `#t', then all automatic behavior available above is
+;;>     turned on.
+;; The following option is added in extra.ss
+;;>   * :printer { #f | #t | procedure }
+;;>     if given, install a printer function.  `#t' means install the
+;;>     `print-object-with-slots' function from "clos.ss", otherwise, it is
+;;>     expected to be a function that gets an object, an escape boolean
+;;>     flag an an optional port (i.e, 2 or more arguments), and prints the
+;;>     object on the class using the escape flag to select `display'-style
+;;>     (`#f') or `write'-style (#t).
+;;>
+;;>   Note that the class object is made by `class' with a name, so it is
+;;>   possible to use the class itself as the value of `:type' properties
+;;>   for a recursive class.
+;;>
+;;>   Whenever the classname is used, it is taken from the defined name,
+;;>   without a surrounding "<>"s if any.  Note that some of these options
+;;>   are processed at compile time (all method names and auto-generation of
+;;>   methods).
+(defsyntax (make-defclass-form stx)
+  (syntax-case stx ()
+    [(_ class-maker name supers . slots0)
+     (let loop ([slots1 #'slots0] [slots2 '()])
+       (syntax-case slots1 ()
+         [(slot more ...) (not (syntax-keyword? #'slot))
+          (loop #'(more ...) (cons #'slot slots2))]
+         [(initarg ...) ; if slots1 is not null then it contains class keywords
+          (let* ([autoargs (let ([as ((syntax-local-value
+                                       #'-defclass-auto-initargs-))])
+                             (and (syntax? as) (syntax-e as) as))]
+                 [initargs (if autoargs
+                             #`(initarg ... #,@autoargs) #'(initarg ...))]
+                 [defmethods '()]
+                 [sgetarg (lambda (arg . def)
+                            (let ([a (apply syntax-getarg initargs arg def)])
+                              (if (syntax? a) (syntax-object->datum a) a)))]
+                 [all-auto (sgetarg :auto)]
+                 [autoaccessors (sgetarg :autoaccessors (and all-auto #t))]
+                 [automaker (or (sgetarg :automaker) all-auto)]
+                 [autopred (or (sgetarg :autopred) all-auto)]
+                 [accessor-mode (syntax-e ((syntax-local-value
+                                            #'-defclass-accessor-mode-)))]
+                 [default-slot-options (sgetarg :default-slot-options)]
+                 [string-name
+                  (regexp-replace
+                   #rx"^<(.*)>$" (symbol->string (syntax-e #'name)) "\\1")])
+            (define (get-defaccessor-form a-name typed-args untyped-args body)
+              (case accessor-mode
+                [(:defmethod)
+                 #`(defmethod (#,a-name #,@typed-args) #,body)]
+                [(:defgeneric)
+                 #`(begin (defgeneric (#,a-name #,@untyped-args))
+                          (add-method #,a-name (method #,typed-args #,body)))]
+                [(:add-method)
+                 #`(add-method #,a-name (method #,typed-args #,body))]
+                [(:method) #`(define #,a-name (method #,typed-args #,body))]
+                [(:procedure) #`(define (#,a-name #,@untyped-args) #,body)]
+                [else (error
+                       'defclass
+                       "bad value in -defclass-accessor-mode-: ~e"
+                       accessor-mode)]))
+            (define (addreader reader sname)
+              (push! (get-defaccessor-form
+                      reader #'((x name)) #'(x) #`(slot-ref x '#,sname))
+                     defmethods))
+            (define (addwriter writer sname type)
+              (push! (get-defaccessor-form
+                      writer #`((x name) #,(if type #`(n #,type) #'n)) #'(x n)
+                      #`(slot-set! x '#,sname n))
+                     defmethods))
+            (define (do-slot slot)
+              (define-values (sname args)
+                (syntax-case slot ()
+                  [(sname args ...)
+                   (values
+                    #'sname
+                    (cond
+                     [(not default-slot-options) #'(args ...)]
+                     [(and (list? default-slot-options)
+                           (= 2 (length default-slot-options))
+                           (memq (car default-slot-options)
+                                 '(quote quasiquote)))
+                      (let loop ([d  (cadr default-slot-options)]
+                                 [as #'(args ...)]
+                                 [r  '()])
+                        (syntax-case as ()
+                          [(v rest ...) (pair? d)
+                           (loop (cdr d)
+                                 #'(rest ...)
+                                 (list* #'v (car d) r))]
+                          [_ (datum->syntax-object #'(args ...)
+                                                   (append (reverse! r) as)
+                                                   #'(args ...))]))]
+                     [else (raise-syntax-error
+                            #f "bad form for :default-slot-options"
+                            stx initargs)]))]
+                  [sname (values #'sname #'())]))
+              (let ([reader (syntax-getarg args :reader)]
+                    [writer (syntax-getarg args :writer)]
+                    [accessor
+                     (syntax-getarg
+                      args :accessor
+                      (and autoaccessors
+                           (thunk
+                             (if (eq? autoaccessors :slot)
+                               sname
+                               (datum->syntax-object
+                                sname
+                                (string->symbol
+                                 (concat string-name "-"
+                                         (symbol->string (syntax-e sname))))
+                                sname)))))]
+                    [type (syntax-getarg args :type)])
+                (when reader (addreader reader sname))
+                (when writer (addwriter writer sname type))
+                (when accessor
+                  (addreader accessor sname)
+                  (addwriter
+                   (datum->syntax-object
+                    accessor
+                    (string->symbol
+                     (concat "set-" (symbol->string (syntax-e accessor)) "!"))
+                    accessor)
+                   sname type))
+                (let loop ([as args] [res (list sname)])
+                  (syntax-case as ()
+                    [(keyword value more ...)
+                     (loop #'(more ...)
+                           (list* (if (memq (syntax-e #'keyword)
+                                            '(:reader :writer :accessor))
+                                    #''value #'value)
+                                  #'keyword res))]
+                    [() (datum->syntax-object as (reverse! res) as)]))))
+            (when (eq? autoaccessors #t)
+              (set! autoaccessors
+                    (syntax-e ((syntax-local-value
+                                #'-defclass-autoaccessors-naming-)))))
+            (unless (memq autoaccessors '(#t #f :slot :class-slot))
+              (raise-syntax-error
+               #f (concat "`:autoaccessors' expecting either a "
+                          "`:slot' or `:class-slot' as value.")
+               stx initargs))
+            (let ([slots (map do-slot (reverse! slots2))])
+              #`(begin
+                  (define name
+                    (class-maker name supers
+                                 . #,(datum->syntax-object
+                                      #'slots0
+                                      ;; note: append with a non-list 2nd arg
+                                      (append
+                                       slots (if all-auto
+                                               #`(:autoinitargs #t #,@initargs)
+                                               initargs))
+                                      #'slots0)))
+                  #,@(datum->syntax-object
+                      #'stx (reverse! defmethods) #'stx)
+                  #,@(if automaker
+                       (with-syntax
+                           ([maker (datum->syntax-object
+                                    #'name
+                                    (string->symbol
+                                     (concat "make-" string-name))
+                                    #'name)])
+                         #'((define maker
+                              (let ([slots (class-slots name)])
+                                (lambda args
+                                  (let loop ([as args] [ss slots] [r '()])
+                                    (if (or (null? as) (null? ss))
+                                      (let ([new (make name . as)])
+                                        (for-each (lambda (x)
+                                                    (slot-set! new . x))
+                                                  r)
+                                        new)
+                                      (loop (cdr as) (cdr ss)
+                                            (cons (list (caar ss) (car as))
+                                                  r)))))))))
+                       '())
+                  #,@(if autopred
+                       (with-syntax
+                           ([pred? (datum->syntax-object
+                                    #'name
+                                    (string->symbol (concat string-name "?"))
+                                    #'name)])
+                         #'((define (pred? x) (instance-of? x name))))
+                       '()))))]))]))
+
+(defsubst* (defclass name supers slot ...)
+  (make-defclass-form class name supers slot ...))
+
+;;>> (defentityclass name (super ...) slot ... class-initarg ...)
+;;>   The same as `defclass', but for entity classes.
+(defsubst* (defentityclass name supers slot ...)
+  (make-defclass-form entityclass name supers slot ...))
+
+;;; ---------------------------------------------------------------------------
+;;; Forms with a provide version
+
+;;>>...
+;;> *** Auto provide forms
+
+;;>> (defgeneric* ...)
+;;>> (defclass* ...)
+;;>> (defentityclass* ...)
+;;>   These forms are defined as the original version, except that the
+;;>   defined variable is automatically provided (made using
+;;>   `make-provide-syntax' above).  Note that there is no version for
+;;>   `defmethod' since it should not be used where a single definition
+;;>   place is needed -- and it wouldn't make sense to have multiple
+;;>   `provide' forms for every `defmethod*' occurrence.  Note that
+;;>   `defclass*' provides only the class identifier and not any
+;;>   automatically generated ones (accessors etc).
+(provide defgeneric*)     (make-provide-syntax defgeneric     defgeneric*)
+(provide defclass*)       (make-provide-syntax defclass       defclass*)
+(provide defentityclass*) (make-provide-syntax defentityclass defentityclass*)
+
+)
diff --git a/collects/swindle/custom.ss b/collects/swindle/custom.ss
new file mode 100644
index 0000000000..fa8ed4b950
--- /dev/null
+++ b/collects/swindle/custom.ss
@@ -0,0 +1,79 @@
+;;; CustomSwindle
+;;;   Name:       CustomSwindle
+;;;   DialogName: Customized Swindle
+;;;   OneLine:    Sample Customized Swindle
+;;;   URL:        http://www.barzilay.org/Swindle/
+
+;;; This file demonstrates how a customized Swindle-based language can be
+;;; created.  Most of these things could be done with the GUI language
+;;; customizing, but (a) it will make it very verbose, (b) most syntax settings
+;;; are things that beginners should not know about, (c) it will not allow
+;;; things like the redefinition of `lambda' which is done below.  To make a
+;;; customization file, it should be some *.ss file in this directory, that
+;;; begins in the same way as above commented prefix: beginning with the magic
+;;; string, and then specifying some parameters for this language.  Specifying
+;;; the language's name as it appears at the top of the interactions menu
+;;; (defaults to the file name minus the ".ss"), the name as it appears in the
+;;; language selection dialog box (defaults to the Name), the one-line
+;;; description (appears at the bottom of the language dialog), and a URL to
+;;; jump to when the name in the interactions is clicked.  Remember that since
+;;; the language can be pretty different than Swindle, then appropriate
+;;; documentation should be added too.
+;;;
+;;; This is a good place to add common functionality and customizations, but
+;;; not things that can be made into a module -- a teachpack is better for
+;;; those.
+
+(module custom (lib "swindle.ss" "swindle")
+  ;; provide all swindle, minus `lambda' which is overriden to `method'
+  (provide (all-from-except (lib "swindle.ss" "swindle") lambda))
+  (provide (rename lambda~ lambda))
+  (defsubst lambda~ method)
+  ;; some default customizations
+  (*make-safely* #t)
+  ;; set some syntax parameters -- must use eval!
+  (eval #'(begin
+            ;; simple defclass forms:
+            (-defclass-auto-initargs-
+             (;; auto acccessors, constructors, and predicates
+              :auto #t
+              ;; first two things after a slot name are type and initvalue
+              :default-slot-options '(:type :initvalue)
+              ;; printed representation of objects shows slot contents
+              :printer print-object-with-slots))
+            ;; set the accessor names made by the above
+            (-defclass-autoaccessors-naming- :class-slot)
+            ;; always use an explicit generic
+            (-defmethod-create-generics- #f)
+            ;; use defgeneric + add-method for accessors (since defmethod now
+            ;; wouldn't create the generic)
+            (-defclass-accessor-mode- :defgeneric))))
+
+;;; To make thins even better, it is best to change preferences so Swindle
+;;; syntax get indented correctly.  For this, create the default preference
+;;; file "plt/collects/defaults/plt-prefs.ss", and in it you can put any
+;;; specific preferences you want as the defaults for people who run the system
+;;; for the first time (see the "Preference Files" section in the Help Desk).
+;;; The two relevant settings are -- make Swindle the default language:
+;;;   (drscheme:205-settings
+;;;     (("Swindle" "Full Swindle")
+;;;      #6(#f current-print mixed-fraction-e #f #t debug)))
+;;; And to make indentation handle Swindle forms correctly, locate the tab
+;;; specifications line and add the swindle forms indentation:
+;;;   (framework:tabify
+;;;    (... stuff which is already there ...
+;;;     (define* define) (define-syntax* define) (defsyntax define)
+;;;     (defsyntax* define) (letsyntax lambda) (defsubst define)
+;;;     (defsubst* define) (letsubst lambda) (defmacro define)
+;;;     (defmacro* define) (letmacro lambda) (named-lambda lambda)
+;;;     (thunk lambda) (while lambda) (until lambda) (dotimes lambda)
+;;;     (dolist lambda) (no-errors lambda) (regexp-case lambda)
+;;;     (generic lambda) (defgeneric define) (method lambda)
+;;;     (named-method lambda) (qualified-method lambda) (defmethod define)
+;;;     (beforemethod lambda) (aftermethod lambda) (aroundmethod lambda)
+;;;     (defbeforemethod define) (defaftermethod define)
+;;;     (defaroundmethod define) (class lambda) (entityclass lambda)
+;;;     (defclass define) (defentityclass define) (defgeneric* define)
+;;;     (defclass* define) (defentityclass* define) (with-slots lambda)
+;;;     (with-accessors lambda) (matcher lambda) (match lambda)
+;;;     (defmatcher define) (defmatcher0 define)))
diff --git a/collects/swindle/extra.ss b/collects/swindle/extra.ss
new file mode 100644
index 0000000000..ea9dcd8524
--- /dev/null
+++ b/collects/swindle/extra.ss
@@ -0,0 +1,939 @@
+(module extra (lib "turbo.ss" "swindle")
+
+;;> This module defines some additional useful functionality which requires
+;;> Swindle.
+
+(require (lib "clos.ss" "swindle"))
+
+;;; ---------------------------------------------------------------------------
+;;; A convenient `defstruct'
+
+;; This makes it possible to create MzScheme structs using Swindle's `main' and
+;; keyword arguments.
+
+(define struct-to-slot-names (make-hash-table))
+
+(hash-table-put! struct-to-slot-names <struct> '())
+
+(add-method initialize (method ([s <struct>] initargs) ???))
+
+(define (struct-type->class* stype maker slots)
+  (let* ([this (struct-type->class stype)]
+         [superslots (let ([s (class-direct-supers this)])
+                       (and (pair? s) (null? (cdr s))
+                            (hash-table-get
+                             struct-to-slot-names (car s) (thunk #f))))])
+    (when superslots
+      (when (some (lambda (x) (memq x superslots)) slots)
+        (error 'defstruct "cannot redefine slot names"))
+      (let ([allslots (append superslots slots)])
+        (hash-table-put! struct-to-slot-names this slots)
+        (add-method allocate-instance
+          (let ([???s (build-list (length allslots) (lambda _ ???))])
+            (method ([class = this]) (maker . ???s))))
+        (add-method initialize
+          (let ([none "-"]
+                [keys (build-list
+                       (length slots)
+                       (lambda (n) (list (symbol-append ': (nth slots n)) n)))]
+                [setter! (4th (call-with-values
+                                  (thunk (struct-type-info stype)) list))])
+            (method ([obj this] initargs)
+              (for-each (lambda (k)
+                          (let ([v (getarg initargs (1st k) none)])
+                            (unless (eq? none v)
+                              (setter! obj (2nd k) v))))
+                        keys)
+              (call-next-method))))))
+    this))
+
+;;>> (defstruct <struct-name> ([super]) slot ...)
+;;>   This is just a Swindle-style syntax for one of
+;;>     (define-struct struct-name (slot ...) (make-inspector))
+;;>     (define-struct (struct-name super) (slot ...) (make-inspector))
+;;>   with an additional binding of <struct-name> to the Swindle class that
+;;>   is computed by `struct-type->class'.  The `(make-inspector)' is needed
+;;>   to make this a struct that we can access information on.  Note that in
+;;>   method specifiers, the `struct:foo' which is defined by
+;;>   `define-struct' can be used just like `<foo>'.  What all this means is
+;;>   that you can use MzScheme structs if you just want Swindle's generic
+;;>   functions, but use built in structs that are more efficient since they
+;;>   are part of the implementation.  For example:
+;;>
+;;>     => (defstruct <foo> () x y)
+;;>     => <foo>
+;;>     #<primitive-class:foo>
+;;>     => (defmethod (bar [x <foo>]) (foo-x x))
+;;>     => (bar (make-foo 1 2))
+;;>     1
+;;>     => (defmethod (bar [x struct:foo]) (foo-x x))
+;;>     => (bar (make-foo 3 4))
+;;>     3
+;;>     => (generic-methods bar)
+;;>     (#<method:bar:foo>)
+;;>     => (defstruct <foo2> (foo) z)
+;;>     => (bar (make-foo2 10 11 12))
+;;>     10
+;;>
+;;>   To make things even easier, the super-struct can be written using a
+;;>   "<...>" syntax which will be stripped, and appropriate methods are
+;;>   added to `allocate-instance' and `initialize' so structs can be built
+;;>   using keywords:
+;;>
+;;>     => (defstruct <foo3> (<foo>) z)
+;;>     => (foo-x (make <foo3> :z 3 :y 2 :x 1))
+;;>     1
+;;>     => (foo3-z (make <foo3> :z 3 :y 2 :x 2))
+;;>     3
+;;>
+;;>   The `<struct-name>' identifier *must* be of this form -- enclosed in
+;;>   "<>"s.  This restriction is due to the fact that defining an MzScheme
+;;>   struct `foo', makes `foo' bound as a syntax object to something that
+;;>   cannot be used in any other way.
+(defsyntax* (defstruct stx)
+  (define <>-re #rx"^<(.*)>$")
+  (define (<>-id? id)
+    (and (identifier? id) (regexp-match <>-re (symbol->string (syntax-e id)))))
+  (define (doit name super slots)
+    (let* ([str (regexp-replace <>-re (symbol->string (syntax-e name)) "\\1")]
+           [name-sans-<> (datum->syntax-object name (string->symbol str) name)]
+           [struct:name (datum->syntax-object
+                         name (string->symbol (concat "struct:" str)) name)]
+           [make-struct (datum->syntax-object
+                         name (string->symbol (concat "make-" str)) name)]
+           [super (and super (datum->syntax-object
+                              super (string->symbol
+                                     (regexp-replace
+                                      <>-re (symbol->string (syntax-e super))
+                                      "\\1"))
+                              super))])
+      (quasisyntax/loc stx
+        (begin
+          (define-struct #,(if super #`(#,name-sans-<> #,super) name-sans-<>)
+            #,slots (make-inspector))
+          (define #,name
+            (struct-type->class* #,struct:name #,make-struct '#,slots))))))
+  (syntax-case stx ()
+    [(_ name (s) slot ...) (<>-id? #'name) (doit #'name #'s #'(slot ...))]
+    [(_ name ( ) slot ...) (<>-id? #'name) (doit #'name #f  #'(slot ...))]
+    [(_ name more ...) (not (<>-id? #'name))
+     (raise-syntax-error #f "requires a name that looks like \"<...>\""
+                         stx #'name)]))
+
+;;; ---------------------------------------------------------------------------
+;;; Convenient macros
+
+(defsyntax process-with-slots
+  (syntax-rules ()
+    [(_ obj () (bind ...) body ...)
+     (letsubst (bind ...) body ...)]
+    [(_ obj ((id slot) slots ...) (bind ...) body ...)
+     (process-with-slots
+      obj (slots ...) (bind ... (id (slot-ref obj slot))) body ...)]
+    [(_ obj (id slots ...) (bind ...) body ...)
+     (process-with-slots
+      obj (slots ...) (bind ... (id (slot-ref obj 'id))) body ...)]))
+
+;;>> (with-slots obj (slot ...) body ...)
+;;>   Evaluate the body in an environment where each `slot' is defined as a
+;;>   symbol-macro that accesses the corresponding slot value of `obj'.
+;;>   Each `slot' is either an identifier `id' which makes it stand for
+;;>   `(slot-ref obj 'id)', or `(id slot)' which makes `id' stand for
+;;>   `(slot-ref obj 'slot)'.
+(defsubst* (with-slots obj (slot ...) body0 body ...)
+  (process-with-slots obj (slot ...) () body0 body ...))
+
+(defsyntax process-with-accessors
+  (syntax-rules ()
+    [(_ obj () (bind ...) body ...)
+     (letsubst (bind ...) body ...)]
+    [(_ obj ((id acc) accs ...) (bind ...) body ...)
+     (process-with-accessors
+      obj (accs ...) (bind ... (id (acc obj))) body ...)]
+    [(_ obj (id accs ...) (bind ...) body ...)
+     (process-with-accessors
+      obj (accs ...) (bind ... (id (id obj))) body ...)]))
+
+;;>> (with-accessors obj (accessor ...) body ...)
+;;>   Evaluate the body in an environment where each `accessor' is defined
+;;>   as a symbol-macro that accesses `obj'.  Each `accessor' is either an
+;;>   identifier `id' which makes it stand for `(id obj)', or
+;;>   `(id accessor)' which makes `id' stand for `(accessor obj);.
+(defsubst* (with-accessors obj (acc ...) body0 body ...)
+  (process-with-accessors obj (acc ...) () body0 body ...))
+
+;;; ---------------------------------------------------------------------------
+;;; An "as" conversion operator.
+
+;;>> (as class obj)
+;;>   Converts `obj' to an instance of `class'.  This is a convenient
+;;>   generic wrapper around Scheme conversion functions (functions that
+;;>   look like `foo->bar'), but can be used for other classes too.
+(defgeneric* as (class object))
+
+(defmethod (as [c <class>] [x <top>])
+  (if (instance-of? x c)
+    x
+    (error 'as "can't convert ~e -> ~e; given: ~e." (class-of x) c x)))
+
+;;>> (add-as-method from-class to-class op ...)
+;;>   Adds a method to `as' that will use the function `op' to convert
+;;>   instances of `from-class' to instances of `to-class'.  More operators
+;;>   can be used which will make this use their composition.  This is used
+;;>   to initialize `as' with the standard Scheme conversion functions.
+(define* (add-as-method from to . op)
+  (let ([op (apply compose op)])
+    (add-method as (method ([c = to] [x from]) (op x)))))
+
+;; Add Scheme primitives.
+(add-as-method <symbol>   <string>  symbol->string)
+(add-as-method <string>   <symbol>  string->symbol)
+(add-as-method <exact>    <inexact> exact->inexact)
+(add-as-method <inexact>  <exact>   inexact->exact)
+(add-as-method <number>   <string>  number->string)
+(add-as-method <string>   <number>  string->number)
+(add-as-method <char>     <string>  string)
+(add-as-method <char>     <integer> char->integer)
+(add-as-method <integer>  <char>    integer->char)
+(add-as-method <string>   <list>    string->list)
+(add-as-method <list>     <string>  list->string)
+(add-as-method <vector>   <list>    vector->list)
+(add-as-method <list>     <vector>  list->vector)
+(add-as-method <number>   <integer> inexact->exact round)
+(add-as-method <rational> <integer> inexact->exact round)
+(add-as-method <struct>   <vector>  struct->vector)
+(add-as-method <string>   <regexp>  regexp)
+(add-as-method <regexp>   <string>  object-name)
+;; Some weird combinations
+(add-as-method <symbol>   <number>  string->number symbol->string)
+(add-as-method <number>   <symbol>  string->symbol number->string)
+(add-as-method <struct>   <list>    vector->list struct->vector)
+
+;;; ---------------------------------------------------------------------------
+;;; Recursive equality.
+
+;;>> (equals? x y)
+;;>   A generic that compares `x' and `y'.  It has an around method that
+;;>   will stop and return `#t' if the two arguments are `equal?'.  It is
+;;>   intended for user-defined comparison between any instances.
+(defgeneric* equals? (x y))
+
+(defaroundmethod (equals? [x <top>] [y <top>])
+  ;; check this first in all cases
+  (or (equal? x y) (call-next-method)))
+
+(defmethod (equals? [x <top>] [y <top>])
+  ;; the default is false - the around method returns #t if they're equal?
+  #f)
+
+;;>> (add-equals?-method class pred?)
+;;>   Adds a method to `equals?' that will use the given `pred?' predicate
+;;>   to compare instances of `class'.
+(define* (add-equals?-method class pred?)
+  (add-method equals? (method ([x class] [y class]) (pred? x y))))
+
+;;>> (class+slots-equals? x y)
+;;>   This is a predicate function (not a generic function) that will
+;;>   succeed if `x' and `y' are instances of the same class, and all of
+;;>   their corresponding slots are `equals?'.  This is useful as a quick
+;;>   default for comparing simple classes (but be careful and avoid
+;;>   circularity problems).
+(define* (class+slots-equals? x y)
+  (let ([xc (class-of x)] [yc (class-of y)])
+    (and (eq? xc yc)
+         (every (lambda (s)
+                  (equals? (slot-ref x (car s)) (slot-ref y (car s))))
+                (class-slots xc)))))
+
+;;>> (make-equals?-compare-class+slots class)
+;;>   Make `class' use `class+slots-equals?' for comparison with `equals?'.
+(define* (make-equals?-compare-class+slots class)
+  (add-equals?-method class class+slots-equals?))
+
+;;; ---------------------------------------------------------------------------
+;;; Generic addition for multiple types.
+
+;;>> (add x ...)
+;;>   A generic addition operation, initialized for some Scheme types
+;;>   (numbers (+), lists (append), strings (string-append), symbols
+;;>   (symbol-append), procedures (compose), and vectors).  It dispatches
+;;>   only on the first argument.
+(defgeneric* add (x . more))
+
+;;>> (add-add-method class op)
+;;>   Add a method to `add' that will use `op' to add objects of class
+;;>   `class'.
+(define* (add-add-method c op)
+  ;; dispatch on first argument
+  (add-method add (method ([x c] . more) (apply op x more))))
+
+(add-add-method <number>    +)
+(add-add-method <list>      append)
+(add-add-method <string>    string-append)
+(add-add-method <symbol>    symbol-append)
+(add-add-method <procedure> compose)
+
+(defmethod (add [v <vector>] . more)
+  ;; long but better than vectors->lists->append->vectors
+  (let* ([len (apply + (map vector-length (cons v more)))]
+         [vec (make-vector len)])
+    (let loop ([i 0] [v v] [vs more])
+      (dotimes [j (vector-length v)]
+        (set! (vector-ref vec (+ i j)) (vector-ref v j)))
+      (unless (null? vs) (loop (+ i (vector-length v)) (car vs) (cdr vs))))
+    vec))
+
+;;; ---------------------------------------------------------------------------
+;;; Generic len for multiple types.
+
+;;>> (len x)
+;;>   A generic length operation, initialized for some Scheme types (lists
+;;>   (length), strings (string-length), vectors (vector-length)).
+(defgeneric* len (x))
+
+;;>> (add-len-method class op)
+;;>   Add a method to `len' that will use `op' to measure objects length for
+;;>   instances of `class'.
+(define* (add-len-method c op)
+  (add-method len (method ([x c]) (op x))))
+
+(add-len-method <list>   length)
+(add-len-method <string> string-length)
+(add-len-method <vector> vector-length)
+
+;;; ---------------------------------------------------------------------------
+;;; Generic ref for multiple types.
+
+;;>> (ref x indexes...)
+;;>   A generic reference operation, initialized for some Scheme types and
+;;>   instances.  Methods are predefined for lists, vectors, strings,
+;;>   objects, hash-tables, boxes, promises, parameters, and namespaces.
+(defgeneric* ref (x . indexes))
+
+;;>> (add-ref-method class op)
+;;>   Add a method to `ref' that will use `op' to reference objects of class
+;;>   `class'.
+(define* (add-ref-method c op)
+  (add-method ref (method ([x c] . indexes) (op x . indexes))))
+
+(add-ref-method <list>       list-ref)
+(add-ref-method <vector>     vector-ref)
+(add-ref-method <string>     string-ref)
+(add-ref-method <object>     slot-ref)
+(add-ref-method <hash-table> hash-table-get)
+(add-ref-method <box>        unbox)
+(add-ref-method <promise>    force)
+(defmethod (ref [p <parameter>] . _) (p))
+(defmethod (ref [n <namespace>] . args)
+  (parameterize ([current-namespace n])
+    (apply namespace-variable-value args)))
+
+;;; ---------------------------------------------------------------------------
+;;; Generic set-ref! for multiple types.
+
+;;>> (put! x v indexes)
+;;>   A generic setter operation, initialized for some Scheme types and
+;;>   instances.  The new value comes first so it is possible to add methods
+;;>   to specialize on it.  Methods are predefined for lists, vectors,
+;;>   strings, objects, hash-tables, boxes, parameters, and namespaces.
+(defgeneric* put! (x v . indexes))
+
+;;>> (add-put!-method class op)
+;;>   Add a method to `put!' that will use `op' to change objects of class
+;;>   `class'.
+(define* (add-put!-method c op)
+  (add-method put! (method ([x c] v . indexes) (op x v . indexes))))
+
+;;>> (set-ref! x indexes... v)
+;;>   This syntax will just translate to `(put! x v indexes...)'.  It makes
+;;>   it possible to make `(set! (ref ...) ...)' work with `put!'.
+(defsyntax* (set-ref! stx)
+  (syntax-case stx ()
+    [(_ x i ...)
+     (let* ([ris  (reverse (syntax->list #'(i ...)))]
+            [idxs (reverse! (cdr ris))]
+            [val  (car ris)])
+       (quasisyntax/loc stx
+         (put! x #,val #,@(datum->syntax-object #'(i ...) idxs #'(i ...)))))]))
+
+(define (put!-arg typename args)
+  (if (or (null? args) (pair? (cdr args)))
+   (if (null? args)
+     (error 'put! "got no index for a ~a argument" typename)
+     (error 'put! "got more than one index for a ~a argument ~e"
+            typename args))
+   (car args)))
+
+(defmethod (put! [l <list>] x . i_)
+  (list-set! l (put!-arg '<list> i_) x))
+(defmethod (put! [v <vector>] x . i_)
+  (vector-set! v (put!-arg '<vector> i_) x))
+(defmethod (put! [s <string>] [c <char>] . i_)
+  (string-set! s (put!-arg '<string> i_) c))
+(defmethod (put! [o <object>] x . s_)
+  (slot-set! o (put!-arg '<object> s_) x))
+(defmethod (put! [h <hash-table>] x . k_)
+  (if (null? k_)
+    (error 'put! "got no index for a <hash-table> argument")
+    (hash-table-put! h (car k_) x)))
+(add-put!-method <box> set-unbox!)
+(defmethod (put! [p <parameter>] x . _)
+  (if (null? _)
+    (p x)
+    (error 'put! "got extraneous indexes for a <parameter> argument")))
+(defmethod (put! [n <namespace>] x . v_)
+  (if (null? v_)
+    (error 'put! "got no index for a <namespace> argument")
+    (parameterize ([current-namespace n])
+      (apply namespace-set-variable-value! (car v_) x
+             (if (null? (cdr v_)) '() (list (cadr v_)))))))
+
+;;; ---------------------------------------------------------------------------
+;;>>... Generic-based printing mechanism
+
+;;>> *print-level*
+;;>> *print-length*
+;;>   These parameters control how many levels deep a nested data object
+;;>   will print, and how many elements are printed at each level.  `#f'
+;;>   means no limit.  The effect is similar to the corresponding globals in
+;;>   Lisp.  Only affects printing of container objects (like lists, vectors
+;;>   and structures).
+(define* *print-level*  (make-parameter 6))
+(define* *print-length* (make-parameter 20))
+
+(define orig-write-handler   (port-write-handler   (current-error-port)))
+(define orig-display-handler (port-display-handler (current-error-port)))
+
+;;>> (print-object obj esc? port)
+;;>   Prints `obj' on `port' using the above parameters -- the effect of
+;;>   `esc?' being true is to use a `write'-like printout rather than a
+;;>   `display'-like printout when it is false.  Primitive Scheme values are
+;;>   printed normally, Swindle objects are printed using the un-`read'-able
+;;>   "#<...>" sequence unless a method that handles them is defined.  For
+;;>   this printout, objects with a `name' slot are printed using that name
+;;>   (and their class's name).
+;;>
+;;>   Warning: this is the method used for user-interaction output, errors
+;;>   etc.  Make sure you only define reliable methods for it.
+(defgeneric* print-object (object esc? port))
+
+(defmethod (print-object o esc? port)
+  (orig-display-handler "#" port)
+  (orig-display-handler (class-name (class-of o)) port))
+
+(defmethod (print-object [o <builtin>] esc? port)
+  ((if esc? orig-write-handler orig-display-handler) o port))
+
+(define printer:too-deep "#?#")
+(define printer:too-long "...")
+
+(defmethod (print-object [o <improper-list>] esc? port)
+  (cond
+   [(null? o) (orig-display-handler "()" port)]
+   [(and (pair? (cdr o)) (null? (cddr o))
+         (memq (car o) '(quote quasiquote unquote unquote-splicing
+                               syntax quasisyntax unsyntax unsyntax-splicing)))
+    (orig-display-handler (case (car o)
+                            [(quote)             "'"]
+                            [(quasiquote)        "`"]
+                            [(unquote)           ","]
+                            [(unquote-splicing)  ",@"]
+                            [(syntax)            "#'"]
+                            [(quasisyntax)       "#`"]
+                            [(unsyntax)          "#,"]
+                            [(unsyntax-splicing) "#,@"])
+                          port)
+    (print-object (cadr o) esc? port)]
+   [(eq? (*print-level*) 0)
+    (orig-display-handler printer:too-deep port)]
+   [else
+    (orig-display-handler "(" port)
+    (if (eq? (*print-length*) 0)
+      (orig-display-handler printer:too-long port)
+      (parameterize ([*print-level* (sub1 (or (*print-level*) 0))])
+        (print-object (car o) esc? port)
+        (do ([o (cdr o) (if (pair? o) (cdr o) '())]
+             [n (sub1 (or (*print-length*) 0)) (sub1 n)])
+            [(or (null? o)
+                 (and (zero? n)
+                      (begin (orig-display-handler " " port)
+                             (orig-display-handler printer:too-long port)
+                             #t)))]
+          (if (pair? o)
+            (begin (orig-display-handler " " port)
+                   (print-object (car o) esc? port))
+            (begin (orig-display-handler " . " port)
+                   (print-object o esc? port))))))
+    (orig-display-handler ")" port)]))
+
+(defmethod (print-object [o <vector>] esc? port)
+  (cond [(eq? (*print-level*) 0)
+         (orig-display-handler printer:too-deep port)]
+        [(zero? (vector-length o)) (orig-display-handler "#()" port)]
+        [else (orig-display-handler "#(" port)
+              (if (eq? (*print-length*) 0)
+                (orig-display-handler printer:too-long port)
+                (parameterize ([*print-level* (sub1 (or (*print-level*) 0))])
+                  (print-object (vector-ref o 0) esc? port)
+                  (let ([len (if (*print-length*)
+                               (min (vector-length o) (*print-length*))
+                               (vector-length o))])
+                    (do ([i 1 (add1 i)]) [(>= i len)]
+                      (orig-display-handler " " port)
+                      (print-object (vector-ref o i) esc? port))
+                    (when (< len (vector-length o))
+                      (orig-display-handler " " port)
+                      (orig-display-handler printer:too-long port)))))
+              (orig-display-handler ")" port)]))
+
+;;>> (name-sans-<> name)
+;;>   Given a string or symbol for name, return a string where the outermost
+;;>   set of angle brackets have been stripped if they are present.  This is
+;;>   handy if you are writing your own print-object methods.
+(define <>-re #rx"^<(.*)>$")
+(define* (name-sans-<> name)
+  (cond [(string? name) (regexp-replace <>-re name "\\1")]
+        [(symbol? name) (regexp-replace <>-re (symbol->string name) "\\1")]
+        [(eq? ??? name) "???"]
+        [else name]))
+
+;; Take care of all <object>s with a `name' slot
+(defmethod (print-object (o <object>) esc? port)
+  (let* ([c  (class-of o)]
+         [cc (class-of c)]
+         [(name x) (name-sans-<> (slot-ref x 'name))])
+    (if (and (assq 'name (class-slots c)) (assq 'name (class-slots cc)))
+      (begin (orig-display-handler "#<" port)
+             (orig-display-handler (name c) port)
+             (orig-display-handler ":" port)
+             (orig-display-handler (name o) port)
+             (orig-display-handler ">" port))
+      (call-next-method))))
+
+;;>> (print-object-with-slots obj esc? port)
+;;>   This is a printer function that can be used for classes where the
+;;>   desired output shows slot values.  Note that it is a simple function,
+;;>   which should be embedded in a method that is to be added to
+;;>   `print-object'.
+(define* (print-object-with-slots o esc? port)
+  (if (eq? (*print-level*) 0)
+    (orig-display-handler printer:too-deep port)
+    (let ([class (class-of o)])
+      (orig-display-handler "#<" port)
+      (orig-display-handler (name-sans-<> (class-name class)) port)
+      (orig-display-handler ":" port)
+      (parameterize ([*print-level* (sub1 (or (*print-level*) 0))])
+        (do ([s (class-slots class) (cdr s)]
+             [n (or (*print-length*) -1) (sub1 n)])
+            [(or (null? s)
+                 (and (zero? n)
+                      (begin (orig-display-handler " " port)
+                             (orig-display-handler printer:too-long port))))]
+          (let ([val (slot-ref o (caar s))])
+            (if (eq? ??? val)
+              (set! n (add1 n))
+              (begin (orig-display-handler " " port)
+                     (orig-display-handler (caar s) port)
+                     (orig-display-handler "=" port)
+                     (print-object val esc? port))))))
+      (orig-display-handler ">" port))))
+
+;; Add a hook to make <class> so it will initialize a printer if given
+(defmethod :after (initialize [c <class>] initargs)
+  (let ([printer (or (getarg initargs :printer)
+                     (and (getarg initargs :auto) #t))])
+    (when printer
+      (when (eq? #t printer) (set! printer print-object-with-slots))
+      (add-method print-object
+                  (method ([x c] esc? port) (printer x esc? port))))))
+
+;;>> (display-object obj [port])
+;;>> (write-object obj [port])
+;;>   Used to display and write an object using `print-object'.  Used as the
+;;>   corresponding output handler functions.
+(define* (display-object obj &optional [port (current-output-port)])
+  (print-object obj #f port))
+(define* (write-object obj &optional [port (current-output-port)])
+  (print-object obj #t port))
+;;>> (object->string obj [esc? = #t])
+;;>   Convert the given `obj' to a string using its printed form.
+(define* (object->string obj &optional [esc? #t])
+  (with-output-to-string
+    (thunk (print-object obj esc? (current-output-port)))))
+
+;; Hack these to echo
+(*echo-display-handler* display-object)
+(*echo-write-handler* write-object)
+
+;;>> (install-swindle-printer)
+;;>   In MzScheme, output is configurable on a per-port basis.  Use this
+;;>   function to install Swindle's `display-object' and `write-object' on
+;;>   the current output and error ports whenever they are changed
+;;>   (`swindle' does that on startup).  This makes it possible to see
+;;>   Swindle values in errors, when using `printf' etc.
+(define* (install-swindle-printer)
+  (global-port-print-handler write-object)
+  (port-display-handler (current-output-port) display-object)
+  (port-display-handler (current-error-port)  display-object)
+  (port-write-handler   (current-output-port) write-object)
+  (port-write-handler   (current-error-port)  write-object))
+
+;;; ---------------------------------------------------------------------------
+;;>>... Simple matching
+
+;;>> match-failure
+;;>   The result for a matcher function application that failed.  You can
+;;>   return this value from a matcher function in a <matcher> so the next
+;;>   matching one will get invoked.
+(define* match-failure "failure")
+
+;;>> (matching? matcher value)
+;;>   The `matcher' argument is a value of any type, which is matched
+;;>   against the given `value'.  For most values matching means being equal
+;;>   (using `equals?')  to, but there are some exceptions: class objects
+;;>   are tested with `instance-of?', functions are used as predicates,
+;;>   literals are used with equals?, pairs are compared recursively and
+;;>   regexps are used with regexp-match.
+(define* (matching? matcher value)
+  (cond [(class? matcher)    (instance-of? value matcher)]
+        [(function? matcher) (matcher value)]
+        [(pair? matcher)     (and (pair? value)
+                                  (matching? (car matcher) (car value))
+                                  (matching? (cdr matcher) (cdr value)))]
+        ;; handle regexps - the code below relies on returning this result
+        [(regexp? matcher)   (and (string? value)
+                                  (regexp-match matcher value))]
+        [else (equals? matcher value)]))
+
+;;>> (let/match pattern value body ...)
+;;>   Match the `value' against the given `pattern', and evaluate the body
+;;>   on a success.  It is an error for the match to fail.  Variables that
+;;>   get bound in the matching process can be used in the body.
+;;>
+;;>   The pattern specification has a complex syntax as follows:
+;;>   - simple values (not symbols) are compared with `matching?' above;
+;;>   - :x                 keywords are also used as literal values;
+;;>   - *                  is a wildcard that always succeeds;
+;;>   - ???                matches the `???' value;
+;;>   - (lambda ...)       use the resulting closure value (for predicates);
+;;>   - (quote ...)        use the contents as a simple value;
+;;>   - (quasiquote ...)   same;
+;;>   - (V := P)           assign the variable V to the value matched by P;
+;;>   - V                  for a variable name V that was not part of the
+;;>                        pattern so far, this matches anything and binds V
+;;>                        to the value -- the same as (V := *);
+;;>   - (! E)              evaluate E, use the result as a literal value;
+;;>   - (!! E)             evaluate E, continue matching only if it is true;
+;;>   - (V when E)         same as (and V (!! E));
+;;>   - (and P ...)        combine the matchers with and, can bind any
+;;>                        variables in all parts;
+;;>   - (or P ...)         combine the matchers with or, bound variables are
+;;>                        only from the successful form;
+;;>   - (if A B C)         same as (or (and A B) C);
+;;>   - (F => P)           continue matching P with (F x) (where is x is the
+;;>                        current matched object);
+;;>   - (V :: P ...)       same as (and (! V) P...), useful for class forms
+;;>                        like (<class> :: (foo => f) ...);
+;;>   - (make <class> ...) if the value is an instance of <class>, then
+;;>                        continue by the `...' part which is a list of
+;;>                        slot names and patterns -- a slot name is either
+;;>                        :foo or 'foo, and the pattern will be matched
+;;>                        against the contents of that slot in the original
+;;>                        <class> instance;
+;;>   - ???                matches the unspecified value (`???' in tiny-clos)
+;;>   - (regexp R)         convert R to a regexp and use that to match
+;;>                        strings;
+;;>   - (regexp R P ...)   like the above, but continue matching the result
+;;>                        with `(P ...)' so it can bind variables to the
+;;>                        result (something like `(regexp "a(x?)b" x y)'
+;;>                        will bind `x' to the `regexp-match' result, and
+;;>                        `y' to a match of the sub-regexp part);
+;;>   - (...)              other lists - match the elements of a list
+;;>                        recursively (can use a dot suffix for a "rest"
+;;>                        arguments).
+;;>
+;;> Note that variable names match anything and bind the name to the result,
+;;> except when the name was already seen -- where the previously bound
+;;> value is used, allowing patterns where some parts should match the same
+;;> value.  (A name was `seen' if it was previously used in the pattern
+;;> except on different branches of an `or' pattern.)
+(defsyntax (make-matcher-form stx)
+  (define (re r)
+    ;; Note: this inserts the _literal_ regexp in the code if it is a string.
+    (cond [(regexp? (syntax-e r)) r]
+          [(string? (syntax-e r)) (regexp (syntax-e r))]
+          [else #`(regexp #,r)]))
+  (define (loop x pattern vs body)
+    ;; body always a delayed function that expects bindings
+    (syntax-case pattern (* ??? := ! !! when and or if => ::
+                            make regexp quote quasiquote lambda)
+      [* ; wildcard
+       (body vs)]
+      [??? ; matches ???
+       #`(if (matching? ??? #,x) #,(body vs) match-failure)]
+      [(v := p) ; assign the variable V to the value matched by P
+       #`(let ([v #,x]) #,(loop #'v #'p (cons #'v vs) body))]
+      [v ; (V := *) if V is a symbol that was not already used
+       (and (identifier? #'v) (not (syntax-keyword? #'v))
+            (not (ormap (lambda (u) (bound-identifier=? #'v u)) vs)))
+       (loop x #'(v := *) vs body)]
+      [(! e) ; evaluate E and use it as a simple value
+       #`(if (matching? e x) #,(body vs) match-failure)]
+      [(!! e) ; evaluate E and succeed only if it is true
+       #`(if e #,(body vs) match-failure)]
+      [(p when e) ; => (and P (!! E))
+       #`(_ x (and p (!! e)) #,(body vs))]
+      ;; and/or
+      [(and) (body vs)]
+      [(or)  #'match-failure]
+      [(and p) (loop x #'p vs body)]
+      [(or  p) (loop x #'p vs body)]
+      [(and p1 p2 ...) (loop x #'p1 vs
+                             (lambda (vs) (loop x #'(and p2 ...) vs body)))]
+      [(or  p1 p2 ...) #`(let ([tmp #,(loop x #'p1 vs body)])
+                           (if (eq? tmp match-failure)
+                             #,(loop x #'(or p2 ...) vs body)
+                             tmp))]
+      [(if a b c) ; => (or (and A B) C)
+       (loop x #'(or (and a b) c) vs body)]
+      [(f => p) ; continue matching P with (F x)
+       #`(let ([v (f #,x)]) #,(loop #'v #'p vs body))]
+      [(v :: . p) ; => (and (! V) P ...), eg (<foo> :: (foo => f) ...)
+       (loop x #'(and (! v) . p) vs body)]
+      [(make class initarg+vals ...)
+       ;; (make <class> :slotname p ...) - match on slots of the given class
+       #`(let ([obj #,x])
+           (if (instance-of? obj class)
+             #,(let loop1 ([av #'(initarg+vals ...)] [vs vs])
+                 (syntax-case av (quote)
+                   [(key p more ...) (syntax-keyword? #'key)
+                    (let* ([s (symbol->string (syntax-e #'key))]
+                           [s (datum->syntax-object
+                               #'key
+                               (string->symbol
+                                (substring s 1 (string-length s)))
+                               #'key)])
+                      (loop #`(slot-ref obj '#,s) #'p vs
+                            (lambda (vs) (loop1 #'(more ...) vs))))]
+                   [('key p more ...)
+                    (loop #'(slot-ref obj 'key) #'p vs
+                          (lambda (vs) (loop1 #'(more ...) vs)))]
+                   [() (body vs)]))
+             match-failure))]
+      [(regexp r) ; use R as a regexp (matching? handles it)
+       #`(if (matching? #,(re #'r) #,x) #,(body vs) match-failure)]
+      [(regexp r . p) ; => like the above, but match P... on result
+       #`(let ([m (matching? #,(re #'r) #,x)])
+           (if m #,(loop #'m #'p vs body) match-failure))]
+      ;; literal lists
+      ['v #`(if (matching? 'v #,x) #,(body vs) match-failure)]
+      [`v #`(if (matching? `v #,x) #,(body vs) match-failure)]
+      [(lambda as b ...)
+       #`(if (matching? (lambda as b ...) #,x) #,(body vs) match-failure)]
+      [(a . b) ; simple lists
+       #`(if (pair? #,x)
+           (let ([hd (car #,x)] [tl (cdr #,x)])
+             #,(loop #'hd #'a vs (lambda (vs) (loop #'tl #'b vs body))))
+           match-failure)]
+      ;; other literals (null, keywords, non-symbols)
+      [() #`(if (null? #,x) #,(body vs) match-failure)]
+      [v  #`(if (matching? v #,x) #,(body vs) match-failure)]))
+  (syntax-case stx ()
+    [(_ x pattern body) (loop #'x #'pattern '() (lambda (vs) #'body))]))
+(defsubst* (let/match pattern value body ...)
+  (let* ([v value] [r (make-matcher-form v pattern (begin body ...))])
+    (if (eq? r match-failure)
+      (error 'let/match "value did not match pattern: ~e" v)
+      r)))
+
+;;>> (matcher pattern body ...)
+;;>   This creates a matcher function, using the given `pattern' which will
+;;>   be matched with the list of given arguments on usage.  If the given
+;;>   arguments fail to match on an application, an error will be raised.
+(defsubst* (matcher pattern body ...)
+  (lambda args
+    (let ([r (make-matcher-form args pattern (begin body ...))])
+      (if (eq? r match-failure)
+        (error 'matcher "application values did not match pattern: ~e" v)
+        r))))
+
+;; Matching similar to `cond'
+;;>> (match x (pattern expr ...) ...)
+;;>   This is similar to a `cond' statement but each clause starts with a
+;;>   pattern, possibly binding variables for its body.  It also handles
+;;>   `else' as a last clause.
+(defsyntax match-internal
+  (syntax-rules (else)
+    [(_ x) (void)]
+    [(_ x (else body0 body ...)) (begin body0 body ...)]
+    [(_ x (pattern body0 body ...) clause ...)
+     (let ([m (make-matcher-form x pattern (begin body0 body ...))])
+       (if (eq? m match-failure) (match x clause ...) m))]))
+(defsubst* (match x clause ...)
+  (let ([v x]) (match-internal v clause ...)))
+
+;;>> <matcher>
+;;>   A class similar to a generic function, that holds matcher functions
+;;>   such as the ones created by the `matcher' macro.  It has three slots:
+;;>   `name', `default' (either a default value or a function that is
+;;>   applied to the arguments to produce the default value), and `matchers'
+;;>   (a list of matcher functions).
+(defentityclass* <matcher> (<generic>)
+  (name     :initarg :name     :initvalue '-anonymous-)
+  (default  :initarg :default  :initvalue #f)
+  (matchers :initarg :matchers :initvalue '()))
+
+;; Set the entity's proc
+(defmethod (initialize [matcher <matcher>] initargs)
+  (call-next-method)
+  (set-instance-proc!
+   matcher
+   (lambda args
+     (let loop ([matchers (slot-ref matcher 'matchers)])
+       (if (null? matchers)
+         (let ([default (slot-ref matcher 'default)])
+           (if (procedure? default)
+             (default . args)
+             (or default
+                 (error (slot-ref matcher 'name) "no match found."))))
+         (let ([r (apply (car matchers) args)])
+           (if (eq? r match-failure)
+             (loop (cdr matchers))
+             r)))))))
+
+;;; Add a matcher - normally at the end, with add-matcher0 at the beginning
+(define (add-matcher matcher m)
+  (slot-set! matcher 'matchers
+             (append! (slot-ref matcher 'matchers) (list m))))
+(define (add-matcher0 matcher m)
+  (slot-set! matcher 'matchers
+             (cons m (slot-ref matcher 'matchers))))
+
+(defsyntax (defmatcher-internal stx)
+  (syntax-case stx ()
+    [(_ adder name args body ...)
+     (with-syntax ([matcher-make (syntax/loc stx (matcher args body ...))])
+       (if (or
+            ;; not enabled
+            (not (syntax-e
+                  ((syntax-local-value #'-defmethod-create-generics-))))
+            ;; defined symbol or second module binding
+            (identifier-binding #'name)
+            ;; local definition -- don't know which is first => no define
+            (eq? 'lexical (syntax-local-context)))
+         (syntax/loc stx (adder name matcher-make))
+         ;; top-level or first module binding
+         (syntax/loc stx
+           (define name ; trick: try using exising generic
+             (let ([m (or (no-errors name) (make <matcher> :name 'name))])
+               (adder m matcher-make)
+               m)))))]))
+
+;;>> (defmatcher (name pattern) body ...)
+;;>> (defmatcher0 (name pattern) body ...)
+;;>   These macros define a matcher (if not defined yet), create a matcher
+;;>   function and add it to the matcher (either at the end (defmatcher) or
+;;>   at the beginning (defmatcher0)).
+(defsyntax* (defmatcher stx)
+  (syntax-case stx ()
+    [(_ (name . args) body0 body ...) (identifier? #'name)
+     #'(defmatcher-internal add-matcher name args body0 body ...)]
+    [(_ name args body0 body ...) (identifier? #'name)
+     #'(defmatcher-internal add-matcher name args body0 body ...)]))
+(defsyntax* (defmatcher0 stx)
+  (syntax-case stx ()
+    [(_ (name . args) body0 body ...) (identifier? #'name)
+     #'(defmatcher-internal add-matcher0 name args body0 body ...)]
+    [(_ name args body0 body ...) (identifier? #'name)
+     #'(defmatcher-internal add-matcher0 name args body0 body ...)]))
+
+;;; ---------------------------------------------------------------------------
+;;>>... An amb macro
+;;> This is added just because it is too much fun to miss.  To learn about
+;;> `amb', look for it in the Help Desk, in the "Teach Yourself Scheme in
+;;> Fixnum Days" on-line manual.
+
+(define amb-fail (make-parameter #f))
+(define (initialize-amb-fail)
+  (amb-fail (thunk (error 'amb "tree exhausted"))))
+(initialize-amb-fail)
+
+;;>> (amb expr ...)
+;;>   Execute forms in a nondeterministic way: each form is tried in
+;;>   sequence, and if one fails then evaluation continues with the next.
+;;>   `(amb)' fails immediately.
+(defsubst* (amb expr ...)
+  (let ([prev-amb-fail (amb-fail)])
+    (let/cc sk
+      (let/cc fk
+        (amb-fail (thunk (amb-fail prev-amb-fail) (fk 'fail)))
+        (sk expr)) ...
+      (prev-amb-fail))))
+
+;;>> (amb-assert cond)
+;;>   Asserts that `cond' is true, fails otherwise.
+(define* (amb-assert bool) (unless bool ((amb-fail))))
+
+;;>> (amb-collect expr)
+;;>   Evaluate expr, using amb-fail repeatedly until all options are
+;;>   exhausted and returns the list of all results.
+(defsubst* (amb-collect e)
+  (let ([prev-amb-fail (amb-fail)]
+        [results '()])
+    (when (let/cc k
+            (amb-fail (thunk (k #f)))
+            (let ([v e]) (push! v results) (k #t)))
+      ((amb-fail)))
+    (amb-fail prev-amb-fail)
+    (reverse! results)))
+
+;;; ---------------------------------------------------------------------------
+;;>>... Very basic UI - works also in console mode
+;;> The following defines some hacked UI functions that works using MrEd GUI
+;;> if it is available, or the standard error and input ports otherwise.
+;;> The check is done by looking for a GUI global binding.
+
+;;>> *dialog-title*
+;;>   This parameter defines the title used for the hacked UI interface.
+(define* *dialog-title* (make-parameter "Swindle Message"))
+
+;;>> (message fmt-string arg ...)
+;;>   Like `printf' with a prefix title, or using a message dialog box.
+(define* (message str . args)
+  (let ([msg (format str . args)])
+    (if (namespace-defined? 'message-box)
+      ((namespace-variable-value 'message-box) (*dialog-title*) msg)
+      (echo :>e :s- "<<<" (*dialog-title*) ": " msg ">>>")))
+  (void))
+
+(define (first-non-ws-char str idx)
+  (and (< idx (string-length str))
+       (let ([c (string-ref str idx)])
+         (if (memq c '(#\space #\tab #\newline))
+           (first-non-ws-char str (add1 idx))
+           c))))
+
+(define (ui-question str args prompt positive-result msg-style
+                     positive-char negative-char)
+  (let ([msg (apply format str args)])
+    (if (namespace-defined? 'message-box)
+      (eq? ((namespace-variable-value 'message-box)
+            (*dialog-title*) msg #f msg-style)
+           positive-result)
+      (begin (echo :>e :n- :s- (*dialog-title*) ">>> " msg " " prompt " ")
+             (let loop ()
+               (let ([inp (first-non-ws-char (read-line) 0)])
+                 (cond [(char-ci=? inp positive-char) #t]
+                       [(char-ci=? inp negative-char) #f]
+                       [else (loop)])))))))
+
+;;>> (ok/cancel? fmt-string arg ...)
+;;>> (yes/no? fmt-string arg ...)
+;;>   These functions are similar to `message', but they are used to ask an
+;;>   "ok/cancel" or a "yes/no" question.  They return a boolean.
+(define* (ok/cancel? str . args)
+  (ui-question str args "Ok/Cancel" 'ok '(ok-cancel) #\o #\c))
+(define* (yes/no? str . args)
+  (ui-question str args "Yes/No" 'yes '(yes-no) #\y #\n))
+
+)
diff --git a/collects/swindle/html-doc.txt b/collects/swindle/html-doc.txt
new file mode 100644
index 0000000000..afc0fe5da4
--- /dev/null
+++ b/collects/swindle/html-doc.txt
@@ -0,0 +1,1887 @@
+This is a rough manual/tutorial thing for "html.ss".
+
+Contents:
+
+  1. General
+  2. Scheme extensions
+  2.1. Lisp-like self-evaluating keywords
+  2.2. Extended function arguments
+  2.3. Convenient list syntax
+  2.4. General functions and macros
+  3. HTML generation
+  3.1. General value producing
+  3.2. Quoting -- Scheme and HTML output
+  3.3. Global variables
+  3.4. Text processing
+  3.5. Output and formatting tags
+  3.6. Tags, wrappers, and attributes
+  3.7. Predefined tags and wrappers
+  4. Making it work
+  4.1. General Scripting
+  4.2. Script setup for "html.ss"
+  4.3. Creating HTML files
+
+
+========================================================================
+1. General
+
+This is the documentation for "html.ss", a module I wrote to produce
+HTML code using Scheme (specific to MzScheme).  This project was born as
+a quick hack to create my home page files, and grew into a much larger
+system, which was later incorporated into my Scheme Web Server as well.
+Its goals are to produce HTML easily and elegantly, so that even the
+HTML code generated is readable.
+
+You should use this thing if you want to produce a lot of HTML output in
+a uniform way, and have a relatively easy time maintaining it.  However,
+the price which is paid to achieve this goal, is that you should know
+how to program well.  This means that if you want a quick HTML page, or
+if you don't know/want/like programming, then this is probably the wrong
+solution.  One thing to bear in mind is that a project can begin its
+life using this and at some point, it can continue by editing the HTML
+output (and suffer the usual price this implies).  The goal of having
+readable HTML output is not only for having an elegant output, but for
+making such a conversion easy since this output is human-readable.
+
+I'm assuming general knowledge of Scheme, MzScheme and HTML.
+Documentations can be found on the PLT sites (http://www.drscheme.org/),
+
+* The Revised Scheme Report:
+  http://www.cs.rice.edu/CS/PLT/packages/doc/r5rs/index.htm
+
+* MzScheme:
+  http://www.cs.rice.edu/CS/PLT/packages/doc/mzscheme/index.htm
+
+Also, good HTML reference can be found at:
+  http://www.idocs.com/tags/
+
+To use this thing, all you need to do is download and install the PLT
+file at http://www.barzilay.org/Swindle/, and load the module with:
+  (require (lib "html.ss" "swindle"))
+This document is not complete, nor does it attempts to be -- the
+ultimate documentation is, as usually with all open-source projects, the
+code itself.  But there are more convenient ways to write scripts as
+explained below.
+
+If you have any more comments, questions, suggestions or bug reports,
+mail eli@barzilay.org.
+
+
+========================================================================
+2. Scheme extensions
+
+There are several extensions to Scheme that "html.ss" provides and uses.
+Again, this comes on top of MzScheme which has its own extensions on top
+of the Scheme standard.  Note also, that "html.ss" does a
+`(read-case-sensitive #t)', so all Scheme code which uses it is
+case-sensitive.
+
+
+------------------------------------------------------------------------
+2.1. Lisp-like self-evaluating keywords
+
+As in Lisp, symbols that begin with a `:' evaluate to themselves.  This
+is used for keyword function arguments, including functions that
+generate HTML tags, where arbitrary keyword/values can be specified and
+will be used as attributes and values for the HTML tag.
+
+
+------------------------------------------------------------------------
+2.2. Extended function arguments
+
+Function arguments (both for `define' and `lambda' expressions (named
+and anonymous functions)) are extended considerably:
+
+* A function can have nested parens to indicate currying.  This is
+  useful for functions that will swallow some arguments and output a
+  function to be used later.
+   +----------
+   |> (define ((plus x) y) (+ x y))
+   |> (plus 1)
+   |#<procedure:plus:1>
+   |> ((plus 1) 2)
+   |3
+   +----------
+
+* `&optional' indicates optional arguments, as in Lisp.  They can also
+  contain default values:
+   +----------
+   |> (define (foo x &optional y) (list 'x= x 'y= y))
+   |> (foo 1)
+   |(x= 1 y= #f)
+   |> ((lambda (x &optional y) (list 'x= x 'y= y)) 1)
+   |(x= 1 y= #f)
+   |> (foo 1 2)
+   |(x= 1 y= 2)
+   |> (define (foo x &optional (y 3)) (list 'x= x 'y= y))
+   |> (foo 1)
+   |(x= 1 y= 3)
+   |> (foo 1 2)
+   |(x= 1 y= 2)
+   |> (define (foo x &optional (y (* x 2))) (list 'x= x 'y= y))
+   |> (foo 12)
+   |(x= 12 y= 24)
+   +----------
+
+* `&keys' behaves like Lisp's `&key' (for compatibility, `&key' does the
+  same), and is used to define arguments that are assigned by labeled
+  keywords.  Default values and different names are possible too.  Note
+  that no extensive error checking is done (like checking that the
+  keyword list is balanced, or that it uses only keywords), so watch for
+  sneaky bugs.
+   +----------
+   |> (define (foo x &keys y z) (list 'x= x 'y= y 'z= z))
+   |> (foo 1)
+   |(x= 1 y= #f z= #f)
+   |> (foo 1 :z 2)
+   |(x= 1 y= #f z= 2)
+   |> (foo 1 :z 2 :y 1)
+   |(x= 1 y= 1 z= 2)
+   |> (foo 1 :y 1 :y 2 :y 3)
+   |(x= 1 y= 1 z= #f)
+   |> (define (foo x &keys (y 'yyy)) (list 'x= x 'y= y))
+   |> (foo 1)
+   |(x= 1 y= yyy)
+   |> (foo 1 :y 2)
+   |(x= 1 y= 2)
+   |> (define (foo x &keys (y :foo 'yyy)) (list 'x= x 'y= y))
+   |> (foo 1 :foo 2)
+   |(x= 1 y= 2)
+   |> ((lambda (&keys x y) (list x y)) :y 1 :x 2)
+   |(2 1)
+   +----------
+  Keywords are an important feature for this system, since it allows
+  modifying a function so it is more generalized without affecting
+  previous places that use it.
+
+* `&rest' indicates an argument that holds unprocessed values for the
+  function call.  This is mainly for completeness with Lisp's syntax,
+  since it is the same as using Scheme's dot notation.
+   +----------
+   |> (define (foo x &optional y &rest r) (list 'x= x 'y= y 'r= r))
+   |> (foo 1)
+   |(x= 1 y= #f r= ())
+   |> (foo 1 2)
+   |(x= 1 y= 2 r= ())
+   |> (foo 1 2 3)
+   |(x= 1 y= 2 r= (3))
+   |> (foo 1 2 3 4)
+   |(x= 1 y= 2 r= (3 4))
+   +----------
+
+* There are two additional options that are related to `&rest':
+  - `&body' is like `&rest' without all keyword/values;
+  - `&rest-keys' is like `&rest' without all keyword/values for the
+    specified `&keys'.
+   +----------
+   |> ((lambda (&keys x y &rest r &rest-keys r1 &body r2)
+   |     (list x y r r1 r2))
+   |   :x 2 :z 2 3)
+   |(2 #f (:x 2 :z 2 3) (:z 2 3) (3))
+   +----------
+  Note that this is different than Lisp, where `&body' is the same as
+  `&rest'.
+
+
+------------------------------------------------------------------------
+2.3. Convenient list and strings syntax
+
+Since lists are useful as a way to concatenate output elements (see
+below), there is a convenient notation for them -- just use an infix
+`:'.  It can also be used inside quotes and quasiquotes.  Note that it
+cannot touch an identifier because it will get parsed as part of that
+identifier.
+   +----------
+   |> (begin 1 : 2)
+   |(1 2)
+   |> (let ((x 12)) "var foo = "(+ x 1))
+   |13
+   |> (let ((x 12)) "var foo = ":(+ x 1))
+   |("var foo = " 13)
+   |> (let ((x 12)) "var foo = ":x)
+   |:x
+   |> (let ((x 12)) '("var foo = ":(+ x 1):"z"))
+   |(("var foo = " (+ x 1) "z"))
+   |> (let ((x 12)) '("{" "var foo = ":(+ x 1):"z" "}"))
+   |("{" ("var foo = " (+ x 1) "z") "}")
+   +----------
+Notes: I have wrapped examples in a form since if you enter "1 : 2" then
+MzScheme's evaluator will read the input item by item instead of using
+the colon preprocessor.  Also note that the last form returned `:x'
+because the colon was attached to the identifier, making it a keyword
+which is the result of the whole form.
+
+Also, strings as arguments are common, so there is another shortcut
+syntax: if a string has a `_' on both sides, its contents is split on
+newlines and the result substitutes the original.
+   +----------
+   |> (list _""_)
+   |("")
+   |> (list _"eli"_)
+   |("eli")
+   |> (list _"eli
+   |          barzilay"_)
+   |("eli" "barzilay")
+   |> (list _"
+   |          eli
+   |          
+   |          barzilay
+   |          "_)
+   |("eli" "" "barzilay")
+   |> '(big: _"
+   |          eli
+   |          
+   |          barzilay
+   |          "_)
+   |(big: "eli" "" "barzilay")
+   |> (output-html (big: _"
+   |                       eli
+   |                       
+   |                       barzilay
+   |                       "_))
+   |<big>eli  barzilay</big>
+   +----------
+The same notes above apply here too.
+
+------------------------------------------------------------------------
+2.4. General functions and macros
+
+(getarg plist key [default])
+  Given a keyword/value list (a Lisp "plist"), and a key, it returns the
+  value associated with that key (or, if not found, it returns its third
+  argument supplied as a default value, or #f if omitted)
+   +----------
+   |> (getarg '(1 11 2 22 3 33 444) 2)
+   |22
+   |> (getarg '(1 11 2 22 3 33 444) 4)
+   |#f
+   |> (getarg '(1 11 2 22 3 33 444) 4 "FOO")
+   |"FOO"
+   |> (getarg '(1 11 2 22 3 33 444) 4 (delay "FOO"))
+   |"FOO"
+   |> (getarg '(1 11 2 22 3 33 444) 4 (thunk "FOO"))
+   |"FOO"
+   +----------
+  This is not something that should be used frequently, since usually
+  you would use `&keys' to pull out keyword arguments.
+
+(eprintf format-str args...)
+  A function that can be used like MzScheme's `printf', except it
+  outputs stuff on the standard error port, so you can use this for
+  debugging.  This is useful because during HTML generation, standard
+  output is post-processed (and probably going away to a file).
+
+(defmacro (foo ...) ...)
+  Is a macro that generates macro bindings in a simple Lisp-like way.
+  The difference from Lisp is that the argument list contains the
+  identifier as in Scheme functions, unlike Lisp's definitions.
+
+(maptree func tree)
+  Similar to `map', but descends down into lists and pairs.
+
+(mappend func list...)
+  Performs a normal `map' and appends the results.
+
+(mapply func list)
+  Performs a `map' by applying the given function over argument lists in
+  the given list.
+
+(thunk ...)
+  A macro that has some forms in its body like Scheme's `begin', and
+  will generate an argument-less function that evaluates the body when
+  called.  This can be used to defer evaluation, but note that Scheme
+  promises are handled as well (using `delay' and `force').
+
+
+========================================================================
+3. HTML generation
+
+The `output-html' function outputs the HTML code generated by its
+arguments.  To try things out, simply run mzscheme and type
+  (require (lib "html.ss" "swindle"))
+Do all this in Emacs for more convenience.  Another option is to write a
+quick script that will do it, see below for ways to do this.
+
+The main function to try things out is `output-html' which is the one
+used to produce HTML output.  Another function that might be useful in
+some cases is `output'.  This is the internal function that is used to
+output text, except that it doesn't do HTML quoting etc (which the above
+does).
+
+Note that all this is either for internal usage, debugging or
+experimenting.  Other functions should be used to generate HTML files,
+such as `make-html' etc, more later.
+
+
+------------------------------------------------------------------------
+3.1. General value producing
+
+HTML values are almost any Scheme values.
+
+* Simple values will just get printed out.  This includes values that
+  don't fall under one of the categories below.
+   +----------
+   |> (output-html 1)
+   |1
+   |> (output-html 'foo)
+   |foo
+   |> (output-html "foo")
+   |foo
+   |> (output-html 0.10)
+   |0.1
+   |> (output-html (/ 4 3))
+   |4/3
+   +----------
+
+* Lists are iterated over, general pairs get recoursed too.
+   +----------
+   |> (output-html (list 1 'foo "foo" 0.10 (/ 4 3)))
+   |1foofoo0.14/3
+   |> (output-html (list 'foo (list 1 (cons 2 3) 4)))
+   |foo1234
+   |> (let ((f (lambda (x) "{": x :"}"))) (output-html (f 1):" ":(f 2)))
+   |{1} {2}
+   +----------
+  The last example demonstrates usage of both a scheme function, and the
+  list infix notation.  An exception for this are lists that represent
+  HTML tags, which are lists that begin with a symbol that ends with a
+  colon:
+   +----------
+   |> (output-html (list 'foo: :bar 1 "x" '(foo: "y")))
+   |<foo bar="1">x <foo>y</foo></foo>
+   +----------
+  This is explained below.
+
+* Functions are applied on no arguments, which means that only thunks
+  should be used.  One note here -- the function is called with no
+  arguments and then the value it returns is again passed to the output
+  function, so a function can either print stuff, return stuff, or even
+  both.
+   +----------
+   |> (output-html (lambda () 'foo))
+   |foo
+   |> (output-html (lambda () (output 'foo)))
+   |foo
+   |> (output-html (lambda () (output 'foo) 'bar))
+   |foobar
+   |> (output-html (lambda () (output "<") 123))
+   |&lt;123
+   |> (output (lambda () (output "<") 123))
+   |<123
+   +----------
+  Note that the third expression will output "foo" and return a symbol
+  which is then printed as it is the result of the function call.  The
+  last two expressions demonstrates that using `output' is fine within
+  HTML generating code, but when used outside the HTML processing
+  context, the result is normal.
+
+* Promises are forced -- this is not the place to describe promises, but
+  as a quick reminder, (delay ...) is similar to an argument-less
+  function, and `force' will evaluate the body and return its value
+  (caching it for further `force's, which is the difference between a
+  promise and a thunk).
+   +----------
+   |> (let ((x (delay (begin (output "foo!") 'x))))
+   |    (output-html (list x x x)))
+   |foo!xxx
+   +----------
+
+* Parameters output their values.  (Parameters are MzScheme's solution
+  against using global values -- they are procedures that when applied
+  on no arguments return the stored value, and when applied on a value,
+  they set the stored value to it.  They are safer than globals since
+  they work properly even in a multithreaded environment.)
+
+* #f and MzScheme's `void' produces no output, which is useful for
+  conditional expressions.
+   +----------
+   |> (output-html (list 'a (and (< 3 2) 2) 'b))
+   |ab
+   |> (output-html (list 'a (when (< 3 2) 2) 'b))
+   |ab
+   +----------
+
+Allowing general functions is especially useful: it allows you to
+include functions that will generate output by printing things.  This
+can be used to create arbitrary output (but see the "Quoting" section
+below).
+
+When writing code that generate HTML, remember that this is still
+standard Scheme, so while a function like `html:' will process all of
+its arguments, it is different than Scheme's `begin' (you can use lists
+instead).  For example:
+   +----------
+   |> (output-html (html: 1 2 3))
+   |<html>
+   |1
+   |2
+   |3
+   |</html>
+   |> (output-html (html: (lambda () 1 2 3)))
+   |<html>
+   |3
+   |</html>
+   |> (output-html (html: (lambda () (list 1 2 3))))
+   |<html>
+   |123
+   |</html>
+   |> (output-html (html: (lambda () 1 : 2 : 3)))
+   |<html>
+   |123
+   |</html>
+   +----------
+
+
+------------------------------------------------------------------------
+3.2. Quoting -- Scheme and HTML output
+
+One thing to keep in mind, which tends to make things seem a bit
+complicated, is that in Scheme strings, the backslash and double-quote
+characters have special meanings.  A double-quote terminates a string
+and a backslash is used to add the following character literally,
+including backslash itself (note that in future versions of MzScheme,
+more C-like backslash sequences will be included).  So, for example, the
+scheme string "\"\\\"" contains a double-quote, a backslash, and another
+double-quote.  As you can see, when combining Scheme with another system
+that uses backslash as a special character, you get a bunch of fun
+backslashes to play with.  So, just be careful, it's not as complicated
+as it seems to be.
+
+HTML output is done with an output post-processing context, so printing
+special characters produces the correct HTML output.  Backslash can be
+used to include the actual character, and it can be used to include a
+literal backslash characters as well.
+   +----------
+   |> (output-html "<foo> & \"bar\"")
+   |&lt;foo&gt; &amp; &quot;bar&quot;
+   |> (output-html "\\<\\&\\>\\\\")
+   |<&>\
+   +----------
+Character conversions are controlled by the value of the `html-quotes'
+variable.
+
+There are also some special characters that produce some special HTML
+symbol as a result.  Currently, this list has space which generates an
+HTML non-breakable space symbol, `C' (copywrite), `R'(trademark), `-'
+(mdash), `<' and `>' (left and right angle quotes), `1', `2' and `3'
+(superscript 1, 2 and 3), `*' (bullet).  Remember that you can always
+quote the ampersand to insert any other element:
+   +----------
+   |> (output-html "\\ \\C\\R\\T\\*\\&foo;")
+   |&nbsp;&copy;&reg;&trade;&bull;&foo;
+   +----------
+These are stored in the `html-specials' variables.  The default list is
+likely to be augmented and changed.
+
+Finally, there are two special strings that make a context where this
+processing is disabled -- they are a NUL character (ASCII 0) followed by
+a "{" to open the context and a "}" to close it.  In such a context,
+which can be nested, HTML processing is disabled.  The choice of a NUL
+character makes it impossible to have conflicts with input files and
+user strings.  This construct can be made automatically with the
+`::literal?' meta-keyword or the `literal:' function (see below).  In
+(very) rare cases where the context should be controlled, you should use
+the variables `literal-begin' and `literal-end' have these strings as
+their values.
+
+These constructs are used internally to make output of attributes and
+their values, scripts and styles unprocessed.  There are some other
+cases where they can be useful, like outputting raw HTML as part of
+other code or from an external file, avoiding the standard
+post-processing, as in the last line of the example below.
+
+Examples:
+   +----------
+   |> (output-html literal-begin :"<foo>": literal-end)
+   |<foo>
+   |> (output-html literal-begin :"<": literal-begin :"&":
+   |               literal-end :">": literal-end)
+   |<&>
+   |> (output-html literal-begin :"<": literal-begin :"&":
+   |                literal-end :">")
+   |<&>
+   |quote-html: Unmatched open-literal.
+   |> (output-html literal-begin :"x\\&y": literal-end)
+   |x\&y
+   |> (output-html literal-begin :"\\ \\C": literal-end)
+   |\ \C
+   |> (output-html
+   |   literal-begin :(thunk (printf "<b>foo</b>")): literal-end)
+   |<b>foo</b>
+   |> (output-html (meta-content~ 'description "\"<meta>\" example"))
+   |<meta name="description" content=""<meta>" example">
+   |> (output-html (meta-content~ 'description
+   |                              literal-end :"\"<meta>\" example":
+   |                              literal-begin))
+   |<meta name="description" content="&quot;&lt;meta&gt;&quot; example">
+   +----------
+Again, this is just to know what's going on, the `literal:' function and
+`::literal?' keywords are preferable.
+
+As another example, note that in:
+   +----------
+   |> (output-html (b: (thunk (output-html (i: "foo")))))
+   |<b>&lt;i&gt;foo&lt;/i&gt;
+   |</b>
+   |> (output-html (b: (literal: (thunk (output-html (i: "foo"))))))
+   |<b><i>foo</i>
+   |</b>
+   +----------
+The internal thunk outputs raw HTML so `::literal?' should be #t, but it
+is important for that thunk's formatting that `::verbatim?' is left as
+the default #f because it uses the same values.  (The reason for the
+unnecessary newline is that `output-html' always tries to terminate
+output with a newline.)
+
+The post-processing mechanism is general and applies to any output
+generated when HTML is produced.  This simplifies including HTML
+content by just printing stuff on the standard output.  A useful
+function for this is `display-file' which gets a file name and prints
+it.  So, you can use something like
+   +----------
+   |> (output-html (literal: (thunk (display-file "foo"))))
+   |<b>foo</b>
+   +----------
+to display the contents of a file that contains raw HTML.  More on
+`display-file' (and `display-mixed-file') below.
+
+
+------------------------------------------------------------------------
+3.3. Global parameters
+
+The behavior of the HTML generator can be customized by modifying some
+global parameters.  If these values are set, it should be done right
+after loading "html.ss", it is not a wise thing to change these values
+during HTML generation.  A parameter is a procedure that keeps a value:
+to get the value you apply the procedure on no arguments and to change
+its value, you apply it on the new value.  See the MzScheme manual for
+more information on parameters.
+
+*html-target-dir*
+  a string which is the default directory to create HTML files in, or
+  "", for using the current directory.  The default is "".  Can be set
+  to #f: "" will be used in this case.  It always ends with a "/" unless
+  it is "".
+
+*html-suffix*
+  a string which is used as a suffix for HTML files.  The default is
+  ".html".  This string always begins with a ".".
+
+*image-dir*
+  a string which is the name of an images directory (similarly to
+  `*html-target-dir*', it can be set to #f for no directory), used only
+  for the `my-images~', `my-gif~', and `my-jpg~' functions.  The default
+  is "images/".  It always ends with a "/" unless it is "".
+
+*doc-type*
+  a string that is inserted at the top of files generated by
+  `make-html', and is intended for an initial "<!DOCTYPE...>" line.  It
+  can be changed to #f to have no such line.  The default is: "HTML 4.0
+  Transitional", the rest of this string is produced by `make-html'.
+  (See the description of output values above for an explanation on
+  parameters and how to change them.  In short, `(*doc-type*)' returns
+  the value and `(*doc-type* x)' sets it to x.)
+
+*charset-type*
+  a string that is inserted in the header using `http-equiv~' and
+  "Content-Type" and a default "text/html" value for the type.  The
+  default is "ISO-8859-1".
+
+*prefix*
+  stuff that gets inserted by `html~:' into the header section.  Useful
+  for adding things like `meta-content~'.  The default is #f.
+
+*current-html-obj*
+  when working on an HTML object (see below), this parameter will be set
+  to this object.
+
+
+------------------------------------------------------------------------
+3.4. Text processing
+
+Text processing is, obviously, a big thing for this application, and
+there is therefore a lot of related functionality.
+
+(concat str...)
+  Is used to concatenate strings, shorthand for `string-append'.
+
+(mapconcat func list separator)
+  Similar to the Emacs Lisp `mapconcat' function, except that it works
+  with lists: it gets a function, a sequence of objects and a returns a
+  list of the function applied to all objects, with the separator
+  between them.  The fact that it works with lists makes it suitable for
+  HTML output.
+   +----------
+   |> (mapconcat add1 '(1 2 3) 'x)
+   |(2 x 3 x 4)
+   |> (output-html (mapconcat (lambda (x) "[": x :"]") '(1 2 3) " | "))
+   |[1] | [2] | [3]
+   +----------
+
+(string-capital str)
+  Capitalizes the first character in a given string (only the first).
+
+(input->output)
+  Copies (efficiently) the current input port to the current output
+  port.
+
+(with-output-filter filter-func output-thunk)
+  The filter function is a function of no arguments that reads its input
+  and write some accordingly processed output.  The output function is a
+  function of no arguments that produces some output.  Applying
+  filterize on both will run `output-thunk' piping its output into
+  `filter-func' and its results are in turn printed on the standard
+  output.  This is a low level function that is used to implement the
+  HTML post-processing (and some more).
+
+(with-input-filter filter-func input)
+  Similar for `with-output-filter', but for input.
+
+(display-file file)
+  Gets a file name and simply spit its contents on the standard output.
+  If you want to display HTML content using this, you should first wrap
+  it in a thunk so the contents will appear as part of going over the
+  HTML structure rather than when making the function call, and you also
+  need to wrap it with a `literal:' to avoid processing of the HTML
+  text.
+
+(display-mixed-file file ...)
+  Displays the file, filtered through a function that allows mixing raw
+  text and Scheme code.  For example, if the file "x" contains:
+   +----------
+   |<#(define a "foo")#>
+   |<a href="c:\{:a:}.htm"><#a#>&nbsp;?</a>
+   |<#(b:#>FOO<#)#>
+   +----------
+  then you can get:
+   +----------
+   |> (output-html (big: (thunk (display-mixed-file "x"))))
+   |<big>
+   |<a href="c:\{:a:}.htm">foo&nbsp;?</a>
+   |<b>FOO</b>
+   |</big>
+   +----------
+  More arguments are keywords and values:
+  * `:metas'         a list with two strings that are used as the open
+                     and close markers.  (Default: "<#" and "#>").
+  * `:scheme?'       if true, then the default initial mode for parsing
+                     the file is Scheme -- note that in that case you'll
+                     probably view the file as a Scheme file and the
+                     meaning of the open/close will look like it is
+                     reversed, so be careful.  (Default: #f).
+  * `:string-quotes' if specified, either a string that will be inserted
+                     for the Scheme reader for the begin/end of a meta
+                     string, or a pair for different begin/end values.
+  * `:split-lines?'  if true, then generated strings that span several
+                     lines will be split so that each line is a seperate
+                     string in the result (and a a space prefix for
+                     these lines is eliminated).  (Default: #f).
+  If "y" contains:
+   +----------
+   |(define a "foo")
+   |]<a href="c:\[a].htm">[a]&nbsp;?</a>[
+   |(b: ]FOO[)
+   +----------
+  then:
+   +----------
+   |> (output-html
+   |   (big: (thunk (display-mixed-file "y" :metas '("[" "]")
+   |                                        :scheme? #t))))
+   |<big><a href="c:\foo.htm">foo&nbsp;?</a><b>FOO</b></big>
+   +----------
+  Finally, if there is a squence of two such meta-open tags, then a
+  sequence of two closing ones is expected, all on one line with an even
+  number of characters between them.  The two parts of the section
+  between them are used as the new tokens.  If "z" contains:
+   +----------
+   |<#(define a "foo")#>
+   |<#<#[]#>#>
+   |<a href="c:\[a].htm">[a]&nbsp;?</a>
+   |[(b: ]FOO[)]
+   |[[{}]]{a}!
+   |zzz
+   +----------
+  then (note the empty lines):
+   +----------
+   |> (output-html (thunk (display-mixed-file "z")))
+   |
+   |
+   |<a href="c:\foo.htm">foo&nbsp;?</a>
+   |<b>FOO</b>
+   |foo!
+   |zzz
+   +----------
+
+(relativize-path path)
+  Attempt to relativize the given path according to the current path.
+  This is used in case you want to create HTML objects in directories,
+  refer to them according to their normal path and get it relative to
+  the currect object.  For example, in the source for the `a/b' object,
+  a reference to `c/d' will turn to "../d.html".  Search for this name
+  below for more details.
+
+(regexp-replacements replacements)
+  This function gets a single argument which is a list of replacements,
+  each one is a list of a regular expression an a replacement, which is
+  either a fixed string, a string containing "\\N" instances (replaced
+  using MzScheme's `regexp-replace'), or a function (applied on the
+  result of `regexp-match').  The replacements list can hold a single
+  replacement for convenience.  The return value is a function that will
+  execute these replacements on a given input.  The result of applying
+  the function is a string only as long as it is possible -- a
+  replacement can put in non-string values and in this case the result
+  will be a list of recursive calls (which makes it suitable for HTML
+  output).
+   +----------
+   |> (regexp-replacements '(("a" "b")))
+   |#<procedure:replacement>
+   |> ((regexp-replacements '(("a" "b"))) "abcde")
+   |"bbcde"
+   |> ((regexp-replacements '(("[ae]" "\\0\\0"))) "abcde")
+   |"aabcdee"
+   |> ((regexp-replacements '(("[ae]" 12))) "abcde")
+   |("" 12 ("bcd" 12 ""))
+   |> (output-html ((regexp-replacements `(("[ae]" ,b:))) "abcde"))
+   |<b>a</b>bcd<b>e</b>
+   +----------
+  Note that this function is not too optimized, and it is generally a
+  quick hack which is supposed to do the right thing in simple cases.
+  Also, replacement results are not rescanned again (or some of the
+  above examples would loop infinitely).
+
+(do-replacements replacements args...)
+  This is a simple `maptree'ing of the generated replacements function,
+  which makes it useful for general tree structures.  Note that there is
+  it doesn't penetrate promises and thunks, and that it only works on
+  the separate string elements so it can't recognize a regexp that
+  starts at one place and ends at another string, for example, in the
+  following:
+   +----------
+   |> (output-html
+   |   (do-replacements (list "<([^<>]+)>" (lambda (_ x) (u: x)))
+   |     (b: "FOO")))
+   |<b>FOO</b>
+   |> (output-html
+   |   (do-replacements (list "<([^<>]+)>" (lambda (_ x) (u: x)))
+   |     (b: "<FOO>")))
+   |<b><u>FOO</u></b>
+   +----------
+  the "<b>"s and "</b>"s did not change since `tag~:' puts the "<" and
+  the ">" in different elements of a list.  The replacements argument
+  can be a function, expected to be the result of `regexp-replacements'.
+
+(with-replacements replacements body...)
+  Similar to the above, except the the body's output is post-processed
+  using the specified replacements (using `with-output-filter').  This
+  means that it covers any output, including HTML junk.  The output is
+  pulled just before the normal HTML post-processing, so it'll have some
+  "\\("s etc.  The output of `with-replacements' is actually a thunk, so
+  its output is normally preprocessed getting the final HTML output.
+  One more restriction is that it works on a line-by-line basis so no
+  multi-line regexps can be used.
+   +----------
+   |> (output-html (u: (with-replacements `(("[ae]" ,b:)) "abcde")))
+   |<u><b>a</b>bcd<b>e</b></u>
+   |> (output-html (u: (with-replacements
+   |                       `(("\\*([^*]*)\\*" ,(lambda (_ x) (b: x))))
+   |                     "foo *bar* baz")))
+   |<u>foo <b>bar</b> baz</u>
+   +----------
+
+text-replacements
+  A variable holding a standard text replacements: "*...*" for bold,
+  "_..._" underlines, "/.../" italicizes.
+   +----------
+   |> (output-html (with-replacements text-replacements
+   |                                  "*foo* _bar_ _/baz/_"))
+   |<b>foo</b> <u>bar</u> <u><i>baz</i></u>
+   +----------
+
+(regexp-case str clauses...)
+  This is a macro that has a structure which is somewhat like a `case'
+  expression.  Every clause has a test part which is a regexp, a list
+  made of a regexp and some symbols following it or `else'.  If the
+  given string matches the regexp of a clause, the body is evaluated,
+  possibly binding given variable names to `regexp-match's results.  To
+  access the complete result of `regexp-match', either use the `match'
+  identifier that is bound to the whole match (when the form that binds
+  variables is used), or use the `=>' syntax which applies a given
+  function on all match results.
+   +----------
+   |> (regexp-case "foo"
+   |    ["f" 1] [("(b)a(r*)" x y) (list x y)] [else '?])
+   |1
+   |> (regexp-case "barr"
+   |    ["f" 1] [("(b)a(r*)" x y) (list x y)] [else '?])
+   |("b" "rr")
+   |> (regexp-case "bzzt"
+   |    ["f" 1] [("(b)a(r*)" x y) (list x y)] [else '?])
+   |?
+   |> (regexp-case "bzzt" ["f" 1] [("b(z)" x) match])
+   |"bz"
+   |> (regexp-case "zbarrz"
+   |    ["f" 1] ["(b)a(r*)" => (lambda x x)] [else '?])
+   |("barr" "b" "rr")
+   +----------
+
+
+------------------------------------------------------------------------
+3.5. Output and formatting tags
+
+There are various functions that are used to format output.  These
+functions are used by HTML-generating function to format the resulting
+HTML so it is readable.  Despite being on a lower level, there are some
+cases where they can be useful.
+
+(display!: x)
+  displays its argument like Scheme's `display', but it takes care of
+  newline and indentation management.
+
+(newline!:), (space!:)
+  is used to stick newlines or spaces in the HTML code, in a way that
+  respects the current indentation.
+
+(newlines: ...), (spaces: ...)
+  outputs its arguments, separated by `newline!:'s or `space!:'s.
+
+(text: ...)
+  is the same as `newlines:'.
+
+(indent: ...)
+  output its arguments in an indented environment.
+
+(literal: ...)
+  output its arguments in an environment that disables HTML post
+  processing (for example, for including and external file, or code that
+  outputs raw HTML).
+
+(verbatim: ...)
+  output its arguments in an environment that disables indentation etc
+  temporarily (which is needed, for example, for `pre:').
+
+(include-file: ...)
+(include-mixed-file: ...)
+  these are two wrappers for `display-file' and `display-mixed-file',
+  described above.  Note that they don't use any meta keywords, and that
+  `include-mixed-file:' can get normal keywords that are sent to
+  `display-mixed-file'.
+
+
+------------------------------------------------------------------------
+3.6. HTML tags structures, wrappers, and attributes
+
+There are several functions and macros that are used to produce HTML
+tags and tag pairs, and for defining functions that produce them.  These
+functions get keywords and values that are used for attributes and
+values for the tags, and then some HTML content.  Note that if a keyword
+appears more than once, the first value is the one used, but this is not
+a feature that should be used often.  Boolean values for keywords are
+special: #f drops the attribute, and #t will include it by itself.  The
+HTML output has keyword values always surrounded by double quote (also,
+remember that all this is in case-sensitive mode).
+
+*** HTML list structures
+
+First, there are some details to know.  The HTML tag functions create
+list values that represent them, which are then converted to normal text
+when output.  These list values are very simple -- they look just like
+the function application, so they can be constructed using quotations or
+any other way:
+   +----------
+   |> (b: 1 2)
+   |(b: 1 2)
+   |> (output-html (b: 1 2))
+   |<b>1 2</b>
+   |> (output-html '(b: 1 2))
+   |<b>1 2</b>
+   |> (output-html '(b: :x 1 1 2))
+   |<b x="1">1 2</b>
+   +----------
+
+This is can be confusing for inexperienced Scheme programmers, for
+example:
+   +----------
+   |> (define eli "Eli Barzilay")
+   |> (output-html (b: eli))
+   |<b>Eli Barzilay</b>
+   |> (output-html '(b: eli))
+   |<b>eli</b>
+   +----------
+what happened here is that the first `b:' form is a normal function
+application which evaluated `eli' to its value.  The second form had a
+literal quoted string that only has the symbol `eli' in it.  I could
+resolve symbols by looking up their global value, but that wouldn't
+work with local variables, which is the reason why these two
+expression are different:
+   +----------
+   |> (let ((b: i:)) (output-html (b: "foo")))
+   |<i>foo</i>
+   |> (let ((b: i:)) (output-html '(b: "foo")))
+   |<b>foo</b>
+   +----------
+The main thing to remember is that since the output of these tags is
+readable, you can always inspect this value to see what's wrong.  For
+example, here is the above values:
+   +----------
+   |> (b: eli)
+   |(b: "Eli Barzilay")
+   |> '(b: eli)
+   |(b: eli)
+   |> (let ((b: i:)) (b: "foo"))
+   |(i: "foo")
+   |> (let ((b: i:)) '(b: "foo"))
+   |(b: "foo")
+   +----------
+
+For this reason, it is generally better to stick with the normal
+function form rather than generate literal strings.  In the future, I
+might make things better by making them return some non-list
+structure, and doing some processing work, for example, an `itemize:'
+function will return the appropriate `(ul: (li: ...) (li: ...))'
+structure that matches exactly the HTML structure (sans formatting)...
+The reason for this list structure is that I plan to reach the goal of
+a better output for these HTML functions so you could inspect their
+values as well, for example, use them with different packages like the
+XML collection that comes with MzScheme.
+
+Most HTML tags have such equivalent functions, so they can all be either
+applied or stuck in lists manually.  Even symbols that end with a colon
+that were not defined as functions can be used.
+   +----------
+   |> (output-html (x: :x 1 1 2))
+   |reference to undefined identifier: x:
+   |> (output-html '(x: :x 1 1 2))
+   |<x x="1">1 2</x>
+   +----------
+
+There is a table that stores information about tags, including, in some
+cases some processing functions:
+   +----------
+   |> (p: :x 1 1 2)
+   |(p: :x 1 1 2)
+   |> (output-html (p: :x 1 1 2))
+   |<p x="1">
+   |1
+   |2
+   |</p>
+   +----------
+
+Another confusing point about this is that the list structure matters:
+if some `foo:' symbol doesn't appear at the beginning of a list, you
+will not get the expected result -- normally, working with lists
+(e.g., appending) does not modify the output, but if you modify the
+list structure, you can get a mess:
+   +----------
+   |> (output-html (list "foo" (b: "bar")))
+   |foo<b>bar</b>
+   |> (output-html (cons "foo" (b: "bar")))
+   |foob:bar
+   +----------
+The second result turned out wrong, because the `b:' symbol that the
+`b:' function created is no long at the beginning of a list.  As said
+above, remember that you can print these values to see what's wrong:
+   +----------
+   |> (list "foo" (b: "bar"))
+   |("foo" (b: "bar"))
+   |> (cons "foo" (b: "bar"))
+   |("foo" b: "bar")
+   +----------
+The second expression's value shows why the output didn't come out
+right.
+
+There is a safety mechanism that can be used to prevent some of these
+things -- making these HTML lists wrapped in an extra list level,
+which will take care of most of these problem -- the
+`make-safe-forms!' function can be used to turn it on (or off, given
+an explicit #f argument):
+   +----------
+   |> (make-safe-forms!)
+   |> (b: "bar")
+   |((b: "bar"))
+   |> (cons "foo" (b: "bar"))
+   |("foo" (b: "bar"))
+   |> (output-html (cons "foo" (b: "bar")))
+   |foo<b>bar</b>
+   |> (make-safe-forms! #f)
+   |> (output-html (cons "foo" (b: "bar")))
+   |foob:bar
+   +----------
+This is not on by default not only because it is less efficient (the
+difference is negligible), but because it modifies the result structures
+which means that code that must have it on should most likely be fixed
+anyway.  Also, note that it doesn't change the result of manually
+constructed lists (obviously).
+
+*** Naming conventions
+
+There are various identifier naming conventions that are used throughout
+the system -- some are just conventions and some gets special treatment.
+
+* As said above, symbols that begin with a ":" are keyword -- they
+  evaluate to themselves.
+
+* Keywords that begin with a ":" (= symbols that begin with a "::") are
+  `meta-keywords' which are treated differently in HTML structures:
+  normal keywords are used as tag attributes to display, but meta
+  keywords are not displayed -- they are reserved for various tag
+  processing functions, for output formatting and other information.
+  For example:
+   +----------
+   |> (output-html '(foo: :bar 1 2 3))
+   |<foo bar="1">2 3</foo>
+   |> (output-html '(foo: ::bar 1 2 3))
+   |<foo>2 3</foo>
+   |> (output-html '(foo: ::spaces? #f ::bar 1 2 3))
+   |<foo>23</foo>
+   +----------
+  (As usual in Scheme, a "?" is used for booleans.)
+
+* Symbols that end with a ":" are used for HTML tags.  This is also for
+  symbols that are bound to functions that produce HTML tags with the
+  same symbol at its beginning.
+
+* Names that end with a "~" are functions that generate HTML but do not
+  get keyword/value arguments -- usually these create some HTML
+  structure given some fixed arguments (e.g., `mailto~'), or HTML tags
+  that have no end-tag (e.g., `meta-content~').  They are usually bound
+  as the same type of functions (returning a value that looks like the
+  function call), so they can be planted in lists, but only defined ones
+  can be used.
+
+* Names that end with a "~:" get some special argument and then more
+  arguments that are used as usual, e.g., `color~:'.
+
+* Names that end with a "::" (or "~::") are functions that generate
+  functions that generate HTML output.  These are usually internal
+  functions, and not defined as HTML tags (so you can't put these
+  symbols in lists).
+
+* Names that start with a "_" are normally used for global html-object
+  bindings (see `defhtml' below).
+
+* There are other standard Scheme conventions that I will not discuss.
+  Just one thing that I use -- `*foo*' for parameter names, because
+  they're somewhat equivalent to special globals in Common Lisp.
+
+*** Some standard meta attributes
+
+The following is a list of meta attributes that are common to all HTML
+tags (there are others which are used by various functions).  Note that
+some meta keywords are inherited to subforms, and some do not get passed
+along -- in the descriptions, below, the default is that there is no
+inheritance except when specified.
+
+* `::args' -- This is a special meta argument that can have a list value
+  which will be added to the argument list.  It is usually intended for
+  keyword/value pairs, but can be used as a general mechanism (e.g., a
+  substitute for apply).  For example:
+   +----------
+   |> (output-html
+   |   (body: ::args '(:bgcolor "blue" :text "yellow") "foo"))
+   |<body bgcolor="blue" text="yellow">
+   |foo
+   |</body>
+   |> (output-html
+   |   (body: :bgcolor "black" ::args '(:bgcolor "blue" :text "yellow")
+   |     "foo"))
+   |<body bgcolor="black" text="yellow">
+   |foo
+   |</body>
+   |> (output-html ;; <- unreliable
+   |   (body: ::args '(:bgcolor "blue" :text "yellow") :bgcolor "black"
+   |     "foo"))
+   |<body bgcolor="blue" text="yellow">
+   |foo
+   |</body>
+   |> (output-html
+   |   (body: ::args '(:bgcolor "blue" :text "yellow" "bar") "foo"))
+   |<body bgcolor="blue" text="yellow">
+   |bar
+   |foo
+   |</body>
+   +----------
+  Note that the place where these are stuck in is not something to rely
+  on -- I have one version that sticks it in place, and another that
+  puts it between the keywords and the body.  So don't rely on
+  precedence with other keywords, and put normal arguments only if
+  `::args' is the last keyword.
+
+* `::func' -- A function that will be used to process the body.  The
+  relation of this function and the assigned HTML tag string is complex
+  so just don't use this.
+
+* `::empty?' -- If #t, then this construct should not have any body and
+  an error is raised if it gets any.  If it is #f, then when the body is
+  empty you still get both open and close tags.  The default is neither,
+  which makes the output have both tags only if there is some body
+  present.
+
+* `::1st-args' -- This should be a list of keywords.  This construct
+  will pull an appropriate number of elements from the body and use them
+  as values for these keywords, which makes it a mechanism to generate
+  `foo~:' functions.  Mostly for internal usage.
+
+* `::arg-funcs' -- The value of this keyword should be an association
+  list of a keyword and a processing function.  If this keyword appears
+  in an HTML function, the function will be applied on the HTML tag,
+  keyword name (a string) and the given value, and it should return two
+  values for the new name and value.  The default value is the value of
+  the `*arg-funcs*' parameter which defaults to a list that will use
+  `relativize-path' on `:src' and `:href' arguments.  To disable this
+  processing, you can use `::arg-funcs #f', but that will disable all
+  processing so it is better to disable processing only for one
+  attribute, for example: `::arg-funcs (list* :href #f (*arg-funcs*))'.
+  This keyword is inherited, so you can do this at any form to modify
+  evrything in it.
+
+* `::literal?' -- If true, then HTML post-processing is disabled for the
+  body (see above for more details).  Default: #f.  This meta-keyword is
+  not inherited, but it is not needed since the context of the body is
+  all literal.  Also, once it is used, it is impossible to disable it in
+  nested forms by giving a #f value.
+
+* `::verbatim?' -- If true, then spaces and newlines that are used for
+  pretty printing are not used.  Default: #f.
+
+* `::indent?' -- If true, make the body indented.  This meta keyword is
+  inherited, default: #f
+
+* `::newlines?' -- If true, put a `newline!:' between body elements.
+  Note that `:newlines?' can be false, while `::indent?' true, because
+  the contents can have things with newlines in them.  This meta keyword
+  is inherited, default: same as `:indent?'.
+
+* `::spaces?' -- Same for `space!:'s.  This meta keyword is inherited,
+  default: the opposite of `::newlines?'.
+
+*** Form functions and wrappers
+
+(make-form ...)
+  This is the function which is used to create HTML list structures.
+  Usually `list*', but can be modified with `make-safe-forms!'.  See
+  above.
+
+(defform name: [string] ...)
+  This macro defines `name:' (a ":" suffix is required) as an HTML
+  structure generating function that outputs a "name" tag (or a
+  different tag if a string follows `name:').  Such declared forms can
+  be used as functions that will create a list that looks like the
+  function application, so they can be used as symbols in lists too.  It
+  can specify keywords (both normal and meta) to use with this construct
+  -- but when the function is used, these keyword values can be
+  overridden.  If the string is #f, then no tag gets printed, which is
+  useful only for formatting and applying a sub `::func' field (this is
+  how functions like `newlines:' are defined), and if it is a symbol it
+  will use that form for output.  See the source for advanced usages.
+   +----------
+   |> (output-html '(foo: 1 2))
+   |<foo>1 2</foo>
+   |> (defform foo: :bar 1)
+   |> (output-html '(foo: 1 2))
+   |<foo bar="1">1 2</foo>
+   |> (output-html (foo: 1 2))
+   |<foo bar="1">1 2</foo>
+   |> (output-html (foo:))
+   |<foo bar="1">
+   |> (output-html (foo: :bar 2))
+   |<foo bar="2">
+   |> (defform foo :bar 1)
+   |defform: got a name that doesn't end with a colon at: foo in: [...]
+   |> (defform foo: "foooo" :bar 1)
+   |> (output-html (foo:))
+   |<foooo bar="1">
+   |> (output-html (foo: foo:))
+   |<foooo bar="1"><foooo bar="1"></foooo>
+   +----------
+  Note that the resulting tag can be used with no arguments which means
+  that it can be used as is (as shown in the last expression).
+
+(defwrapper name: [string] ...)
+(deftag name: [string] ...)
+  These are versions of `defform' that set the ::empty? value:
+   +----------
+   |> (defwrapper foo: :bar 1)
+   |> (output-html (foo: foo:))
+   |<foo bar="1"><foo bar="1"></foo></foo>
+   |> (deftag foo: :bar 1)
+   |> (output-html (foo: foo:))
+   |output-form: `foo' got a non-empty body: (#<procedure:foo:>).
+   +----------
+
+(form~:    tag ...)
+(wrapper~: tag ...)
+(tag~:     tag ...)
+  These are special HTML functions that can be used to create arbitrary
+  HTML tags, given a first string argument (must be first, and must be a
+  string):
+   +----------
+   |> (output-html (wrapper~: "foo" :bar 1))
+   |<foo bar="1"></foo>
+   |> (output-html (tag~: "foo" :bar 1))
+   |<foo bar="1">
+   |> (output-html (form~: "foo" :bar 1))
+   |<foo bar="1">
+   |> (output-html (form~: "foo" :bar 1 1 2))
+   |<foo bar="1">1 2</foo>
+   |> (output-html (form~: "foo" :bar 1 ::indent? #t 1 2))
+   |<foo bar="1">
+   |  1
+   |  2
+   |</foo>
+   |> (output-html '(form~: "foo" :bar 1 ::spaces? #f 1 2))
+   |<foo bar="1">12</foo>
+   |> (output-html '(form~: #f :bar 1 ::spaces? #f 1 2))
+   |12
+   +----------
+
+(form:->:: foo:), (form~:->~:: foo~:),
+  These are functions that gets a form function as its argument, and
+  returns a different form function, the first returns a wrapper
+  constructor with some default values.  The second works on functions
+  that get a unique first argument.  (This is like currying, except that
+  keywords given to the final result get precedence.)
+   +----------
+   |> (defwrapper foo: :bar 1)
+   |> (defwrapper foo~: 'recform: ::tag 'foo: ::1st-args ::n)
+   |> (define foo:: (form:->:: foo:))
+   |> (define foo~:: (form~:->~:: foo~:))
+   |> (output-html (foo: "zzz"))
+   |<foo bar="1">zzz</foo>
+   |> (output-html (foo~: 3 "zzz"))
+   |<foo bar="1"><foo bar="1"><foo bar="1">zzz</foo></foo></foo>
+   |> (output-html (foo~: 3 :bar 2 "zzz"))
+   |<foo bar="2"><foo bar="2"><foo bar="2">zzz</foo></foo></foo>
+   |> (output-html ((foo:: :x 1) :y 2 "bar"))
+   |<foo y="2" x="1" bar="1">bar</foo>
+   |> (output-html ((foo:: :x 1) :x 2 "bar"))
+   |<foo x="2" bar="1">bar</foo>
+   |> (output-html ((foo~:: 2 :x 1) :x 2 "bar"))
+   |<foo x="2" bar="1"><foo x="2" bar="1">bar</foo></foo>
+   +----------
+
+(recform: foo:)
+  This is a form function that expects `::tag' and `::n' arguments, and
+  will repeat that tag the specified number of times, nesting it in
+  itself or collecting a result list (depending on the `::empty?'
+  property of its tag):
+   +----------
+   |> (output-html (recform: ::n 2 ::tag 'big:))
+   |<big><big></big></big>
+   |> (output-html (recform: ::n 2 ::tag 'big: "A"))
+   |<big><big>A</big></big>
+   |> (output-html (recform: ::n 2 ::tag 'br:))
+   |<br><br>
+   |> (output-html (recform: ::n 2 ::tag 'br: :foo 2))
+   |<br foo="2"><br foo="2">
+   |> (defwrapper foo~: 'recform: ::tag 'foo: ::1st-args ::n)
+   |> (output-html (foo~: 2 "A"))
+   |<foo><foo>A</foo></foo>
+   |> (output-html (foo~: 2))
+   |<foo><foo>
+   +----------
+  This is useful for HTML tags that can be `accumulated', like "<big>",
+  and for defining many wrappers based on a more general one.
+
+
+------------------------------------------------------------------------
+3.7. Predefined tags and wrappers
+
+This is a brief list of functions that generate HTML output.  For more
+details, see the source.
+
+br:, break:, break~:
+  output an HTML line-break ("<br>").  `break~:' can be used to output a
+  sequence of these.
+
+hr: (hline:)
+  outputs a horizontal line ("<hr>").
+
+html:, head:, body:, title:, link:, base:, frameset:, frame:, noframes:,
+iframe:, meta:, p:, b:, i:, u:, em:, strong:, blink:, strike:, tt:,
+cite:, code:, samp:, kbd:, dfn:, var:, abbr:, acronym:, h1:, h2:, h3:,
+h4:, h5:, h6:, sub:, sup:, ins:, del:, nobr:
+  simple HTML wrappers and tags, each with some default formatting
+  attributes (`::newlines?', `::indent?', `::spaces?').
+
+(link-rel~ rel ref)
+(link-rev~ rev ref)
+  shorthand for (link: :rel rel :href ref), and the same for `:rev'.
+
+(meta-content~ name content), (http-equiv~ name content)
+  shorthand for (meta: :name name :content content) and for
+  (meta: :http-equiv name :content content).
+
+big:, big~:, small:, small~:
+  simple and `recform:' versions of these tags.
+
+font:, face~:, size~:, color~:, size-2:, ..., size+4:, black:, white:,
+red:, green:, blue:, cyan:, magenta:, yellow:, purple:
+  an HTML font tag, and shorthands for face, sizes, and colors
+  specifications.
+
+div:, left:, right:, center:, justify:
+  a "div" tag, and shorthands for formatting text using the `:align'
+  attribute.
+
+ltr:, rtl:
+  a "div" shorthand for using an "ltr" or an "rtl" direction using the
+  `:dir' attribute.
+
+span:, class~:
+  a "span" tag, and shorthand for a "span" using a `:class' attribute.
+
+address:, blockquote:, quote:, q:
+  more simple tags (quote: is a `blockquote:' tag).
+
+pre:
+  a "pre" environment (with no automatic indentation).
+
+img:, (image~ fname [alt] ...), (gif~ fname [alt] ...),
+(jpg~ fname [alt] ...), (png~ fname [alt] ...)
+  an "img" tag, shorthand for specifying the `alt:' attribute (with
+  possibly more attributes), and shorthands for omitting common
+  suffixes.
+
+(my-image~ fname [alt]), (my-gif~ fname [alt] ...),
+(my-jpg~ fname [alt] ...), (my-png~ fname alt ...)
+  similar to the above, but automatically prepends `*image-dir*'.
+
+map:, area:, spacer:
+  some more image-related things.
+
+a:, (ref~: ref ...), (name~: label ...)
+  an html "a" wrapper, a reference link ("a" with an "href" attribute),
+  and a named anchor ("a" with a "name" attribute).  The first argument
+  to `ref~:' and `label~:' is the URL and the rest is the keyword/values
+  and body expressions.
+   +----------
+   |> (output-html (html: (name~: "foo" "FOO") "foo..."
+   |                      (ref~: "#foo" "Go to FOO")))
+   |<html>
+   |<a name="foo">FOO</a>
+   |foo...
+   |<a href="#foo">Go to FOO</a>
+   |</html>
+   +----------
+
+http~:, ftp~:, telnet~:, mailto~:
+  shorthands that prepends the corresponding URL element to a `ref~:'
+  call.
+
+(ref~ x), (http~ x), (ftp~ x), (telnet~ x), (mailto~ x)
+  generate links that contain their own text in tt font.
+
+(list~: tag ...)
+  This generates a list of some kind, the given tag is the one used to
+  construct the list.  There are some special keyword arguments that it
+  handles -- a `::br' argument specifies some number of "<br>"s to stick
+  after every item to make a list with more spaces, and a `::subtag'
+  argument can be used to override the default "<li>" tag used for
+  items.  The extra arguments for `list~:' are the items, each is a
+  list that is passed to the item wrapper.  If the item list has a
+  `item>' symbol, then it is split by that symbol to generate the real
+  items (this is controlled by a `::split-by' argument).  Note that
+  `item>' is bound to itself so it can be used unquoted and in manually
+  constructed lists.
+   +----------
+   |> (output-html (list~: "ul" '("item #1") '("item #2")))
+   |<ul>
+   |  <li>item #1</li>
+   |  <li>item #2</li>
+   |</ul>
+   |> (output-html (list~: "ul" ::br 2 '("item #1") '("item #2")))
+   |<ul>
+   |  <li>item #1 <br><br></li>
+   |  <li>item #2 <br><br></li>
+   |</ul>
+   |> (output-html (list~: "ul" ::subtag "foo"
+   |                        '("item #1") '("item #2")))
+   |<ul>
+   |  <foo>item #1</foo>
+   |  <foo>item #2</foo>
+   |</ul>
+   |> (output-html (list~: "ul" :type 'disc
+   |                        '("item" "#1") '(:foo 2 "item" "#2")))
+   |<ul type="disc">
+   |  <li>item #1</li>
+   |  <li foo="2">item #2</li>
+   |</ul>
+   |> (output-html (list~: "ul" :type 'disc
+   |                       item> "item" "#1"
+   |                       item> :foo 2 "item" "#2"))
+   |<ul type="disc">
+   |  <li>item #1</li>
+   |  <li foo="2">item #2</li>
+   |</ul>
+   +----------
+  There is also an option of using a second `::subtag2' argument for
+  things like description lists (below), and it is possible to put a
+  list of tags in `::subtag' and a matching list of separators in
+  `::split-by' (to change the token used to separate items) so a nested
+  list can be generated (for example, for tables).  Finally, a
+  `::subargs' argument can be used to supply default arguments
+  (keywords) to sub items (see `table*:' below for an example).
+
+enumerate:, itemize:, menu:, dir:
+  These functions use the above (through `list~::'), for lists with
+  "ol", "ul", "menu", and "dir" tags.
+
+itemize-bullet:, itemize-circle:, itemize-square:
+  These are versions of `itemize:' that use "disc", "circle", and
+  "square" as the value of the "type" attribute to force a certain
+  marker.
+
+description:
+   These are used for description lists ("dl").  Using them is similar
+   to the above, except that in items a `!>' separates the header part
+   ("dt") from the body part ("dd") (`!>', like `item>' is bound to
+   itself).
+
+table:, th:, tr:, td:
+  "table" and related wrappers.
+
+table*:
+  This is an HTML function that uses the `list~:' function above, with
+  `row>' and `col>' tokens, to create a table:
+   +----------
+   |> (output-html (table*: :width "100%"
+   |                 row> :bgcolor "blue" col> "a" col> "b" "c"
+   |                 row> col> "x" "y"
+   |                 row> "1" "2" "3"))
+   |<table width="100%">
+   |  <tr bgcolor="blue">
+   |    <td>a</td>
+   |    <td>b c</td>
+   |  </tr>
+   |  <tr>
+   |    <td>x y</td>
+   |  </tr>
+   |  <tr>
+   |    <td>1</td>
+   |    <td>2</td>
+   |    <td>3</td>
+   |  </tr>
+   |</table>
+   |> (output-html (table*: ::subargs '(:foo "bar")
+   |                        row> col> "x1" col> "x2" row> "y1" "y2"))
+   |<table>
+   |  <tr foo="bar">
+   |    <td>x1</td>
+   |    <td>x2</td>
+   |  </tr>
+   |  <tr foo="bar">
+   |    <td>y1</td>
+   |    <td>y2</td>
+   |  </tr>
+   |</table>
+   |> (output-html (table*: ::subargs '((:foo1 "bar") (:foo2 "baz"))
+   |                        row> col> "x1" col> "x2" row> "y1" "y2"))
+   |<table>
+   |  <tr foo1="bar">
+   |    <td foo2="baz">x1</td>
+   |    <td foo2="baz">x2</td>
+   |  </tr>
+   |  <tr foo1="bar">
+   |    <td foo2="baz">y1</td>
+   |    <td foo2="baz">y2</td>
+   |  </tr>
+   |</table>
+   +----------
+  Note the last item in all examples, which doesn't have `col>' tokens
+  so each element is made a separate item.  The `table*:' form is much
+  easier to create `quick' tables, but when a program is used to create
+  complex tables, `table:' (with `tr:' and `td:') can be more
+  convenient, since it is not sensitive to the list structure of its
+  arguments.
+
+form:, input:, button:, submit-button:, text-input:, checkbox:,
+radiobox:, password-input:, hidden-input:, select:, option:
+  "form" wrapper and various form element tags, many are just `input:'
+  with some value for `:type' (the last two are actually wrappers
+  expecting a body).
+
+(submit~: val ...)
+  shorthand for `submit-button:' with the first argument being the label
+  or the option value (the "value" attribute).
+
+options:
+  Similar to a list, but generates a `select' element with nested
+  `options'.  Each item should have the value first:
+   +----------
+   |> (output-html (options: item> 1 "item #1" item> 2 "item #2"))
+   |<select>
+   |  <option value="1">item #1</option>
+   |  <option value="2">item #2</option>
+   |</select>
+   +----------
+
+(select-options: ...)
+  shorthand for a `select:' with nested `option:'s -- the arguments are
+  lists holding a value and a label, for example:
+   +----------
+   |> (output-html (select-options: '(1 label1) '(2 label2)))
+   |<select>
+   |  <option value="1">label1</option>
+   |  <option value="2">label2</option>
+   |</select>
+   +----------
+
+(button*: ...)
+  this is the actual HTML "button" wrapper, unlike the above `button:'
+  which is just a shor for (input: :type 'button ...).
+
+(label~: label ...)
+  a "label" wrapper, with a value for the `:for' attribute.
+
+(textarea: ...)
+  a "textarea" form element, the contents has indentation disabled.
+
+legend:, (fieldset: ...)
+  a "legend" wrapper, and a "fieldset" wrapper -- if the `fieldset:'
+  body contains a `!>', then the first part will be sent to `legend:'
+  and the second used as the `fieldset:' body.
+
+(comment: ...)
+  formatted HTML comment (doesn't accept any attributes):
+   +----------
+   |> (output-html (comment: "foo"))
+   |<!-- foo -->
+   |> (output-html (comment: "foo" "bar"))
+   |<!--
+   |  foo
+   |  bar
+   |-->
+   +----------
+
+(script-src~ src), (style-src~ css-file)
+  a "script" tag with its "src" attribute given and an empty body, and a
+  "link" tag used for a css file specification.
+
+script:, style:, noscript:
+  comment-objects (objects that are placed in an HTML comment), and a
+  matching "noscript" wrapper -- the contents is protected from HTML
+  post-processing:
+   +----------
+   |> (output-html (script: "var i = 1;" "window.alert(\"foo\");"))
+   |<script type="text/javascript" language="JavaScript"><!--
+   |  var i = 1;
+   |  window.alert("foo");
+   |// --></script>
+   +----------
+
+applet:, object:, param:, param~:
+  an "applet", and "object" wrappers, a "param" tag, and a function
+  receiving the name and value of the parameter.
+
+embed:, noembed:
+  an "embed" tag and a "noembed" wrapper.
+
+applet-params:, object-params:
+  Uses `list:' for items that each has a name and a value.  Note that
+  this is also useful if you give it arguments that are a two-element
+  list each:
+   +----------
+   |> (output-html (applet-params: item> 'foo 1 item> 'bar 2))
+   |<applet>
+   |  <param name="foo" value="1">
+   |  <param name="bar" value="2">
+   |</applet>
+   |> (output-html (object-params: '(foo 1) '(bar 2)))
+   |<object>
+   |  <param name="foo" value="1">
+   |  <param name="bar" value="2">
+   |</object>
+   +----------
+
+(html~: title head body [args...])
+  This is a convenient HTML wrapper, getting a title, a head argument
+  containing some list of stuff to put in the head section, and a body.
+  It also uses `*prefix*' to add stuff to the header section (#f by
+  default), and `*charset-type*' for adding the right meta-tag.  In
+  addition, extra arguments can be used to override this behavior:
+  `:prefix' and `:charset-type' can be used to override these defaults.
+   +----------
+   |> (*prefix* (meta-content~ 'author (concat "Eli Barzilay")))
+   |> (output-html (html~: "Main Page" (list (script: "var foo = 1"))
+   |                 (body: "blah blah blah")))
+   |<html>
+   |<head>
+   |  <meta name="author" content="Eli Barzilay">
+   |  <meta name="generator" content="Scheme!">
+   |  <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1">
+   |  <title>Main Page</title>
+   |  <script type="text/javascript" language="JavaScript"><!--
+   |    var foo = 1
+   |  // --></script>
+   |</head>
+   |<body>
+   |blah blah blah
+   |</body>
+   |</html>
+   +----------
+  Note that the head argument must be in a list, see `make-safe-forms!'
+  above.
+
+(document: ...)
+  This is a global wrapper, it does some minimal job like outputting the
+  document type (if `*doc-type*' is set) and an optional comment to put
+  at the top and bottom of the result (if a `::comment' keyword is
+  given, or you can specify different ones with `::comment1' and
+  `::comment2').
+
+
+========================================================================
+4. Making it work
+
+Now that woring with all the above should be clear, we reach the point
+of putting it all together in a script.
+
+
+------------------------------------------------------------------------
+4.1. General scripting
+
+The easiest way to run a script in Unix, is to make it executable (using
+"chmod +x foo") and write some `magic' prefix that will allow it to run.
+What I found most convenient is the following prefix:
+   +----------
+   |#!/bin/sh
+   |#|
+   |exec mzscheme -r "$0" "$@"
+   ||#
+   |... scheme code ...
+   +----------
+This will make it a /bin/sh script that will just execute mzscheme with
+the correct command-line arguments: `-r' is for running a script: short
+for `-fmv-' which stands for `-f' for loading an argument, `-m' for
+supressing the banner, `-v' for no interactive read-eval-print loop, and
+`--' to specify that more arguments are passed to the script without
+further processing.  The first "$0" argument is consumed by the `-f' --
+this is the actual script (the double-quotes are to protect file name
+with spaces from exploding to multiple arguments), and "$@" are other
+arguments that are passed to the script because of the `--' (again "$@"
+will send each argument, handeling spaces in them correctly).  When
+MzScheme starts, it ignores the /bin/sh stuff and will happily proceed
+to execute the file.  Stick to this template and be safe.
+
+On Windows, it should be possible to add an executable file type,
+specifying how it should be run.  For example, making it executed by
+  "C:\Program Files\PLT\MzScheme.exe" -r
+should do the trick.  Note that spaces makes life a mess.
+
+
+------------------------------------------------------------------------
+4.2. Script setup for "html.ss"
+
+The MzScheme executable accepts lots of useful flags that can be used to
+automate a lot of work.  We've seen above how `-r' is used to run a
+Scheme script, but HTML generation scripts will usually look roughly
+like this:
+   +----------
+   |#!/bin/sh
+   |#|
+   |exec mzscheme -r "$0" "$@"
+   ||#
+   |(require (lib "html.ss" "swindle"))
+   |...
+   |... HTML-definitions scheme code  ...
+   |...
+   |(html-main argv)
+   +----------
+(See below for `html-main' usage.)
+
+Now, we can further use the following command-line arguments:
+* `-L' to specify a library file and collection names;
+* `-C' to invoke `main' on the given script arguments as a list
+  beginning with the script file name (it implies `-r').
+Using these, we can write this equivalent script:
+   +----------
+   |#!/bin/sh
+   |#|
+   |exec mzscheme -LC "html.ss" "swindle" "$0" "$@"
+   ||#
+   |...
+   |... HTML-definitions scheme code  ...
+   |...
+   |(define (main args) (html-main (cdr args)))
+   +----------
+Note that the "-LC" order specifies that the library and collection
+names come first, then the script name and that `main' is invoked after
+loading the file.
+
+On Windows, the problem is that an extension can be used to specify that
+a file is to be thrown as an argument on some binary with predefined
+additional arguments.  So either use something like the first script
+above, or create yet another extension for HTML scripts.
+
+
+------------------------------------------------------------------------
+4.3. Creating HTML files
+
+Finally, this section describes how to produce HTML files.  This is
+describing the level built on top of all of the above.
+
+`*defined-htmls*' is a variable holding HTML objects.  To define an HTML
+object, use the `(defhtml foo ...)' macro -- it gets a variable name
+that will be bound to the HTML object, and push that object onto
+`*defined-html*'.  The extra arguments are keyword/values, which are
+expected to hold values for at least `:name' which holds the file name
+(sans base directory and suffix, but possibly with sub directories), and
+a `:contents' value that will be used to produce the HTML object.  The
+`:contents' value can be any of the valid value that is shown as usual,
+or a function of a variable number of arguments that will be applied to
+the supplied list of keywords and values so it can inspect values for
+more keywords (e.g., supplied by defaults as described below).  For
+convenience, the `:name' argument can be dropped and the symbol name
+will be used instead (dropping a "_" prefix of and adding "index" in
+case it ends with a "/").  Also the `:contents' argument can be dropped
+and its value should just be the last one -- in this case, its value
+will be protected by a `delay' which makes it easier for it to reference
+later defined values.  `defhtml' uses the `(html-obj!  ...)' macro,
+which is similar to a simple `list', except that it handles the contents
+value as described above, and the result is pushed on the
+`*defined-htmls*' list (the `!' suffix doesn't mean that this is
+especially exiting, just that it modifies a value rather than simply
+returning one).
+   +----------
+   |> (html-obj! :a 1 :b 2 3)
+   |(:a 1 :b 2 :contents #<struct:promise>)
+   |> (defhtml x :a 1 :b 2 3)
+   |> x
+   |(:name "x" :a 1 :b 2 :contents #<struct:promise>)
+   |> (getarg x :contents)
+   |#<struct:promise>
+   |> (force (getarg x :contents))
+   |3
+   |> *defined-htmls*
+   |((:name "x" :a 1 :b 2 :contents #<struct:promise>)
+   | (:a 1 :b 2 :contents #<struct:promise>))
+   +----------
+One note about `:name' -- possible file arguments (e.g., arguments for
+`ref~:'s and `image~', can be relativized in case `:name' contains a
+subdirectory name; to do this, use the `relativize-path' function
+described above.  This means that to get it done properly, the actual
+call should be done at HTML generation time (you can wrap them in a
+`delay' or `thunk').
+
+At this point you probably wonder why the whole keywords-values mess...
+
+Well, one feature that is desired is to have access to information about
+HTML objects from other pieces of code.  For example, code that
+generates a menu that shows links to other pages with some information
+about them, which is included in the appropriate `defhtml' form.  If an
+HTML output object is used, there is no way to pull that information
+out, so HTML objects are just keyword/value lists.  A good setup is to
+have a function that creates the contents function and treats given
+information in some uniform way -- see below for an example.  To pull
+out keyword information from an HTML object, the utility function
+`getarg' described above can be used.  Remember the option of using
+`delay' (a Scheme promise) or a thunk (a function with no arguments)
+above -- putting references to yet-undefined HTML objects is possible in
+such constructs since they get evaluated when all HTML objects are
+defined.
+
+To actually produce HTML files from HTML objects, use the `make-html'
+function -- it should be called with an HTML object and possibly more
+keywords/values.  If keywords are provided, they will be used as default
+values for HTML object keywords (so this can be used for invocation
+specific values, like date).  The `make-htmls' is similar, except it
+expects a list of HTML objects as its first arguments (and again,
+optionally more keywords/values).  Finally, a convenient function is
+`make-defined-htmls' -- when called (with no arguments or
+keywords/values), it will go over all HTML objects in `*defined-htmls*',
+collected by `defhtml' forms, and create their files.  (Actually, it
+will check `*defined-html*' once it is done, since more HTML objects may
+be defined while creating pages.)
+
+The following example is a complete script that will create three HTML
+files in the directory you run it from.  (The evaluation delay trick
+should be used in case the body of the `_main' object references later
+ones.)
+
+   +----------
+   |#!/bin/sh
+   |#|
+   |exec mzscheme -LC "html.ss" "swindle" "$0" "$@"
+   ||#
+   |(define ((my-page: &rest body)
+   |         &keys name (title (string-capital name)) info)
+   |  (html: (title: title)
+   |    (body: (h1: title) hr: body hr: (comment: "menu follows")
+   |      (apply text: (map (lambda (html)
+   |                          (ref~: (concat (getarg html :name)
+   |                                         (*html-suffix*))
+   |                                 "[":(getarg html :info):"]"))
+   |                        (reverse *pages*))))))
+   |(defhtml _main :name "index" :title "Main" :info "My main page"
+   |  (my-page: "Yo!  Welcome to my main page!"))
+   |(defhtml _professional :info "Career stuff"
+   |  (my-page: "As CEO of Foo Corp, I blah blah blah..."))
+   |(defhtml _hobbies :info "Personal hobbies"
+   |  (my-page: "I like to shove dead bugs up my nose."))
+   |(define *pages* *defined-htmls*)
+   |(define (main args) (html-main (cdr args)))
+   +----------
+
+(Remember that `defhtml' can use symbol names that contain `/'s to put
+the results in these subdirectories, but remember that these
+subdirectories should exist.)
+
+This is the standard approach that I prefer -- a single script that
+creates multiple HTML files.  To create a single HTML file at a time,
+different approaches can be used.  The first one, is to have the same
+script, but create only a subset of the defined HTML objects.  For this,
+use the function `html-main' instead of `make-defined-htmls'.  This
+function gets a list as an argument and will make each HTML object on
+the list or search for it by a defined name in case of a string.  It can
+also accept more keyword/values to send to the html creation function.
+If the input list is empty, it simply invokes `make-defined-htmls'.  To
+search an HTML object by a string name, it looks for either a symbol
+bound to an HTML object with the given argument name, or an HTML object
+with a `:name' attribute equal to the given argument, or an HTML object
+whose processed name (the `:name' value with `*html-target-dir*' and
+`*html-suffix*') is equal to the given argument.  All this makes it
+convenient to run on script inputs: with arguments it will genrate only
+the requested pages, and without it will create all defined pages.
+Thing you should know if you use this approach:
+
+* Make sure that the script header has that "$@" so additional command
+  line arguments are passed to MzScheme.  On Windows you should make
+  sure that whatever way you chose to invoke MzScheme programs, should
+  be passing command line arguments to it.
+
+* The variable MzScheme uses to bind command line arguments is `argv',
+  it is bound to a vector of strings but `html-main' will convert a
+  given vector to a list.
+
+* MzScheme has a `-C' flag that will call the `main' function with the
+  list of arguments, beginning with the script file name -- so you can
+  bind `main' to `html-main' and get the above automatically.
+
+* You should be aware of the fact that this approach might not evaluate
+  all HTML bodies, so you should be careful not to rely on an HTML
+  object evaluation to have a visible effect on evaluation of other
+  objects.
+
+Another option is to create separate scripts to create several pages.
+For this, you can either use the above functions (just have a single
+HTML object defined on each script) or resort to lower level functions
+like `output-html'.  Another function that can be used for this purpose
+is `(output-to-html "foo" html-object)' which will place the HTML output
+of the given html-object in "foo.html" (or any other file, depending on
+`*html-target-dir*' and `*html-suffix*'.  If these scripts rely on some
+shared code, you should consult the MzScheme documentation to learn how
+to load files.  Normally, you would just `load' the given shared code,
+but you might want to invoke several scripts in a single execution --
+for extra convenience you could use MzScheme's module mechanism.  For a
+more ambitious project, you can even use MzScheme's `make' library and
+much more.
+
+In addition to all this, remember that the HTML generators can do
+anything at all.  They can even read in external files and incorporate
+them in the output -- remember that everything that is printed on the
+standard output is included in the resulting HTML.  You can use
+`display-mixed-file' as described above, or do anything you want, (and
+remember to use `literal:' where necessary).
+
+
+========================================================================
diff --git a/collects/swindle/html.ss b/collects/swindle/html.ss
new file mode 100644
index 0000000000..f8ac5c3219
--- /dev/null
+++ b/collects/swindle/html.ss
@@ -0,0 +1,1250 @@
+;;; ===========================================================================
+;;; Swindle HTML Generator
+;;; Written by Eli Barzilay: Maze is Life!  (eli@barzilay.org)
+
+(module html (lib "turbo.ss" "swindle")
+
+(provide (all-from (lib "turbo.ss" "swindle")))
+
+;; ============================================================================
+;; Global parameters
+
+(define (make-dir-param name default)
+  (make-parameter default
+    (lambda (dir)
+      (let ([dir (if (path? dir) (path->string dir) dir)])
+        (cond [(or (not dir) (equal? "" dir)) ""]
+              [(not (string? dir))
+               (error name "expecting a directory string")]
+              [(eq? #\/ (string-ref dir (sub1 (string-length dir)))) dir]
+              [else (concat dir "/")])))))
+(define (make-suffix-param name default)
+  (make-parameter default
+    (lambda (sfx)
+      (cond [(or (not (string? sfx)) (equal? sfx ""))
+             (error name "expecting a non-empty string")]
+            [(eq? #\. (string-ref sfx 0)) sfx]
+            [else (concat "." sfx)]))))
+
+(define* *html-target-dir*  (make-dir-param '*html-target-dir* ""))
+(define* *html-suffix*      (make-suffix-param '*html-suffix* ".html"))
+(define* *image-dir*        (make-dir-param '*image-dir* "images/"))
+(define* *doc-type*
+  (make-parameter "HTML 4.0 Transitional"
+    ;;XHTML '("XHTML 1.0 Transitional"
+    ;;   "\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\"")
+    ))
+(define* *charset-type*     (make-parameter "ISO-8859-1"))
+(define* *prefix*           (make-parameter #f))
+(define* *current-html-obj* (make-parameter #f))
+
+;; ============================================================================
+;; Basic stuff - keywords, case, special evaluation
+
+(define (split-newlines-string str)
+  (let ([l (let loop ([str str])
+             (cond
+              [(regexp-match-positions #rx" *\n *" str) =>
+               (lambda (p)
+                 (let ([a (caar p)] [b (cdar p)] [len (string-length str)])
+                   (if (eq? b len)
+                     (list (substring str 0 a))
+                     (cons (substring str 0 a)
+                           (loop (substring str b len))))))]
+              [else (list str)]))])
+    (if (and (pair? l) (equal? (car l) "")) (cdr l) l)))
+
+(define* __infix-:__ list) ; ugly hack to make the ugly hack below work...
+
+;; Turn `x : x' to `(list x x)' and _"..."_ to split strings
+(define special-eval
+  (let ([orig-eval (current-eval)])
+    (lambda (expr)
+      (define (:-args x y r)
+        (let loop ([r r] [a (list y x)])
+          (syntax-case r (:)
+            [(: x . xs) (loop #'xs (cons #'x a))]
+            [xs (values (reverse! a) #'xs)])))
+      (orig-eval
+       (let loop ([expr (datum->syntax-object #f expr)] [q 0])
+         (syntax-case expr (: _)
+           [(_ x _ . r) (string? (syntax-e #'x))
+            (let ([strs (map (lambda (s) (datum->syntax-object #'x s))
+                             (split-newlines-string (syntax-e #'x)))])
+              (loop (quasisyntax/loc expr
+                      (#,@(if (null? strs) (list #'"") strs) . r))
+                    q))]
+           [(qop x) (and (identifier? #'qop)
+                         (memq (syntax-object->datum #'qop)
+                               '(quote quasiquote unquote unquote-splicing)))
+            (let ([x1 (loop #'x (case (syntax-object->datum #'qop)
+                                  [(quote) +inf.0]
+                                  [(quasiquote) (add1 q)]
+                                  [(unquote unquote-splicing) (sub1 q)]))])
+              (if (eq? x1 #'x) expr (quasisyntax/loc expr (qop #,x1))))]
+           [(x : y . r)
+            (let-values ([(xs rest) (:-args #'x #'y #'r)])
+              (loop (if (> q 0)
+                      (quasisyntax/loc expr (#,xs . #,rest))
+                      (quasisyntax/loc expr ((__infix-:__ . #,xs) . #,rest)))
+                    q))]
+           [(x . xs)
+            (let ([x1 (loop #'x q)] [xs1 (loop #'xs q)])
+              (if (and (eq? x1 #'x) (eq? xs1 #'xs))
+                expr
+                (quasisyntax/loc expr (#,x1 . #,xs1))))]
+           [x #'x]))))))
+
+;; Activate it
+(unless (eq? special-eval (current-eval)) (current-eval special-eval))
+;; Make it case-sensitive by default
+(read-case-sensitive #t)
+;; (Note that both the above do not change parsing of this file.)
+
+;; ============================================================================
+;; Utilities
+
+(define* (mapconcat f lst sep)
+  (cond [(null? lst) '()]
+        [(null? (cdr lst)) (list (f (car lst)))]
+        [else (cons (f (car lst))
+                    (apply append! (map (lambda (x) (list sep (f x)))
+                                        (cdr lst))))]))
+
+(define* (string-capital str)
+  (let ([s (string-copy str)])
+    (string-set! s 0 (char-upcase (string-ref s 0)))
+    s))
+
+(define (string-quote s)
+  (let ([s (format "~s" s)])
+    (substring s 1 (sub1 (string-length s)))))
+
+(define* (keyword->string symbol)
+  (and (keyword? symbol)
+       (let ([str (symbol->string symbol)])
+         (and (not (equal? str ":"))
+              (substring str 1 (string-length str))))))
+
+(define* (basename path)
+  (let-values ([(_1 name _2) (split-path path)]) (path->string name)))
+
+(define* (dirname path)
+  (let-values ([(dir _1 _2) (split-path path)])
+    (cond [(path? dir) (regexp-replace #rx"(.)/$" (path->string dir) "\\1")]
+          [(string? dir) (regexp-replace #rx"(.)/$" dir "\\1")]
+          [(eq? dir 'relative) "."]
+          [(not dir) "/"])))
+
+(define* (relativize-path path)
+  (if (and (string? path) ; hack -- non-strings are just ignored
+           (not (regexp-match #rx"^[a-z]+://" path)))
+    (let ([cur-path
+           (cond [(*current-html-obj*) => (lambda (x) (getarg x :name))]
+                 [else #f])])
+      (if (and cur-path (regexp-match #rx"/" cur-path))
+        (let loop ([path path] [cur-path cur-path])
+          (let ([x (regexp-match #rx"^([^/]*/)(.*)" path)])
+            (if (and x (>= (string-length cur-path) (string-length (cadr x)))
+                     (equal? (cadr x)
+                             (substring cur-path 0 (string-length (cadr x)))))
+              (loop (caddr x) (substring cur-path
+                                         (string-length (cadr x))
+                                         (string-length cur-path)))
+              (regexp-replace #rx"(/?)([^/]*)$"
+                              (regexp-replace #rx"[^/]*/" cur-path "../")
+                              (string-append "\\1" path)))))
+        path))
+    path))
+
+;; ============================================================================
+;; I/O stuff
+
+(define* (input->output)
+  ;; new buffer on every call in case of threading
+  (let* ([bufsize 4096] [buffer (make-string bufsize)])
+    (let loop ()
+      (let ([l (read-bytes-avail! buffer)])
+        (unless (eof-object? l)
+          (write-bytes buffer (current-output-port) 0 l)
+          (loop))))))
+
+(define* (with-output-filter filter proc)
+  (let-values ([(i o) (make-pipe)])
+    (define err #f)
+    (define (err! e)
+      (unless (or err (exn:break? e)) (set! err e))
+      (close-input-port i)
+      (if (eq? (current-thread) t1) (kill-thread t2) (break-thread t1)))
+    (define t1 (current-thread))
+    (define t2 (parameterize ([current-input-port i])
+                 (thread (thunk (with-handlers ([void err!])
+                                  (filter) (close-input-port i))))))
+    (parameterize ([current-output-port o])
+      (with-handlers ([void err!])
+        (proc) (close-output-port o) (thread-wait t2)))
+    (when err (raise err))))
+
+(define* (with-input-filter filter proc)
+  (let-values ([(i o) (make-pipe)])
+    (define err #f)
+    (define (err! e)
+      (unless (or err (exn:break? e)) (set! err e))
+      (close-output-port o)
+      (if (eq? (current-thread) t1) (kill-thread t2) (break-thread t1)))
+    (define t1 (current-thread))
+    (define t2 (parameterize ([current-output-port o])
+                 (thread (thunk (with-handlers ([void err!])
+                                  (filter) (close-output-port o))))))
+    (parameterize ([current-input-port i])
+      (with-handlers ([void err!])
+        (proc) (close-input-port i) (thread-wait t2)))
+    (when err (raise err))))
+
+(define (process-metas
+         &keys [metas         '("<#" "#>")]
+               [scheme?       #f]
+               [string-quotes #f]
+               [split-lines?  #f])
+  (define scm? #t)
+  (define meta-begin (car metas))
+  (define meta-end   (cadr metas))
+  (define-values (string-begin string-end)
+    (cond [(list? string-quotes) (apply values string-quotes)]
+          [string-quotes (values string-quotes string-quotes)]
+          [(*in-quote-html?*)
+           (values (concat "\"" (string-quote literal-begin))
+                   (concat (string-quote literal-end) "\""))]
+          [else (values "\"" "\"")]))
+  (define split-indent    #f)
+  (define meta-regexp     #f)
+  (define (make-meta-regexp!)
+    (let ([b (regexp-quote meta-begin)] [e (regexp-quote meta-end)])
+      (set! meta-regexp (regexp (format "(~a|~a)(~a|~a)?" b e b e)))))
+  (define (open)
+    (when scm? (error 'process-metas "unexpected meta-begin token"))
+    (unless split-lines? (display string-end)) (set! scm? #t))
+  (define (close)
+    (unless scm? (error 'process-metas "unexpected meta-end token"))
+    (unless split-lines? (display string-begin))
+    (set! scm? #f)
+    (set! split-indent 'x))
+  (define (disp x)
+    (let ([x (if scm? x (string-quote x))])
+      (if (or (not split-lines?) scm?)
+        (unless (equal? x "") (display x))
+        (let ([p (cond [(regexp-match-positions #rx"[^ ]" x) => caar]
+                       [else #f])])
+          (display string-begin)
+          (when p
+            (if (eq? 'x split-indent)
+              (display (substring x p (string-length x)))
+              (begin (when (or (not split-indent) (< p split-indent))
+                       (set! split-indent p))
+                     (display (substring x split-indent (string-length x))))))
+          (display string-end)))))
+  (make-meta-regexp!)
+  (unless scheme? (close))
+  (let loop ([str (read-line)])
+    (cond
+     [(eof-object? str)]
+     [(regexp-match-positions meta-regexp str) =>
+      (lambda (x)
+        (let ([prefix (substring str 0 (caar x))]
+              [suffix (substring str (cdar x) (string-length str))]
+              [token  (substring str (caadr x) (cdadr x))] ; first ()'s
+              [token2 (and (caddr x)                       ; second ()'s
+                           (substring str (caaddr x) (cdaddr x)))])
+          (when (or scm?
+                    (not split-lines?)
+                    (not (regexp-match #rx"^ *$" prefix)))
+            (disp prefix))
+          (cond
+           [(and (not scm?) token2
+                 (equal? meta-begin token) (equal? meta-begin token2))
+            (let ([y (regexp-match-positions meta-regexp suffix)])
+              (unless (and (caddr y)
+                           (equal? meta-end
+                                   (substring suffix (caadr y) (cdadr y)))
+                           (equal? meta-end
+                                   (substring suffix (caaddr y) (cdaddr y)))
+                           (> (caar y) 0)
+                           (zero? (modulo (caar y) 2))) ; even string
+                (error 'process-metas
+                       "Expected a double closing-sequence in ~s" suffix))
+              ;; split the new metas
+              (set! meta-begin (substring suffix 0 (/ (caar y) 2)))
+              (set! meta-end (substring suffix (/ (caar y) 2) (caar y)))
+              (make-meta-regexp!)
+              ;; loop with the rest of suffix
+              (loop str))]
+           [(equal? token meta-begin) (open)
+            (loop suffix)]
+           [(equal? token meta-end) (close)
+            (loop (if (and split-lines? (regexp-match #rx"^ *$" suffix))
+                    (begin (set! split-indent #f) (read-line))
+                    suffix))]
+           ;; remove one "\" (never happens -- see comment above)
+           [else (error 'process-metas "Internal error")])))]
+     [else (disp str) (newline)
+           (when (eq? 'x split-indent) (set! split-indent #f))
+           (loop (read-line))]))
+  (unless scheme? (open)))
+
+(define* (display-file file)
+  (cond [(not file) (input->output)]
+        [(input-port? file)
+         (parameterize ([current-input-port file]) (input->output))]
+        [else (with-input-from-file file input->output)]))
+
+(define* (display-mixed-file file &rest args)
+  (define (doit)
+    (with-input-filter
+     (if (null? args) process-metas (lambda () (apply process-metas args)))
+     (thunk (parameterize ([*newline?* (*newline?*)] [*space?* (*space?*)])
+              (let loop ([x (read-syntax "mixed-file-input")])
+                (unless (eof-object? x)
+                  (output (eval (namespace-syntax-introduce x)))
+                  (loop (read-syntax "mixed-file-input"))))))))
+  (cond [(not file) (doit)]
+        [(input-port? file)
+         (parameterize ([current-input-port file]) (doit))]
+        [else (with-input-from-file file doit)]))
+
+;; ============================================================================
+;; Text processing
+
+(define* (regexp-replacements replacements)
+  (unless (list? (car replacements)) (set! replacements (list replacements)))
+  (let ([replacements
+         (map (lambda (x)
+                (define re (if (regexp? (car x)) (car x) (regexp (car x))))
+                (cons re
+                      (if (and (string? (cadr x))
+                               (regexp-match #rx"\\\\[0-9]" (cadr x)))
+                        (lambda (str . rest)
+                          (if (string? str)
+                            (regexp-replace re str (cadr x))
+                            str))
+                        (cadr x))))
+              replacements)])
+    (define (replacement str &optional no-r)
+      (let loop ([rs replacements])
+        (cond
+         [(or (null? rs) (not (string? str)) (equal? str "")) str]
+         [(eq? rs no-r) (loop (cdr rs))]
+         [(regexp-match-positions (caar rs) str) =>
+          (lambda (posns)
+            (let* ([r (cdar rs)]
+                   [prfx (replacement (substring str 0 (caar posns)))]
+                   [sffx (replacement
+                          (substring str (cdar posns) (string-length str)))]
+                   [str (cond
+                         [(and (procedure? r)
+                               (procedure-arity-includes? r (length posns)))
+                          (apply
+                           r
+                           (map
+                            (lambda (p)
+                              (cond
+                               [(not p) p]
+                               [(eq? (car p) (cdr p)) ""]
+                               [else
+                                (replacement
+                                 (if (and (eq? (car p) 0)
+                                          (eq? (cdr p) (string-length str)))
+                                   str (substring str (car p) (cdr p)))
+                                 rs)]))
+                            posns))]
+                         [else r])])
+              ((if (and (string? prfx) (string? str) (string? sffx))
+                 concat list)
+               prfx str sffx)))]
+         [else (loop (cdr rs))])))
+    replacement))
+
+(define* (do-replacements replacements x . more)
+  (define replace (if (procedure? replacements)
+                    replacements (regexp-replacements replacements)))
+  (maptree replace (if (null? more) x (cons x more))))
+
+(define* (with-replacements replacements . body)
+  (define replace (if (procedure? replacements)
+                    replacements (regexp-replacements replacements)))
+  (define (filter &optional not-first?)
+    (let ([l (read-line)])
+      (unless (eof-object? l)
+        (when not-first? (newline))
+        (output (replace l))
+        (filter #t))))
+  (list (thunk (parameterize ([*newline?*    'x]
+                              [*space?*      'x]
+                              [*indentation* (*indentation*)]
+                              [*verbatim?*   #f])
+                 (with-output-filter filter (thunk (output body)))))
+        (thunk (*space?* #f) (*newline?* #f))))
+
+(define* text-replacements
+  (map (lambda (x)
+         (list (car x) (lambda (_ txt) (list (cadr x) txt))))
+       `((#rx"\\*([^*]*)\\*" b:) (#rx"_([^_]*)_" u:) (#rx"/([^/]*)/" i:))))
+
+;; ============================================================================
+;; HTML contents generation
+
+(define* *newline?*    (make-parameter 'x))
+(define* *space?*      (make-parameter 'x))
+(define* *indentation* (make-parameter 0))
+(define* *verbatim?*   (make-parameter #f))
+
+(define *tag-table* (make-hash-table))
+
+;; If it gets deeper, then browsers will start crying anyway!
+(define *indentations* (make-vector 200 #f))
+
+(define* (display!: x . xs)
+  (unless (*verbatim?*)
+    (cond
+     [(eq? #t (*newline?*))
+      (newline)
+      (display (or (vector-ref *indentations* (*indentation*))
+                   (let* ([n (* 2 (*indentation*))]
+                          [i (concat (make-string (quotient n 8) #\tab)
+                                     (make-string (remainder n 8) #\space))])
+                     (vector-set! *indentations* (*indentation*) i)
+                     i)))]
+     [(eq? #t (*space?*)) (display " ")])
+    (*space?* #f) (*newline?* #f))
+  (display x)
+  (unless (null? xs) (for-each display xs)))
+
+(define* (newline!:)
+  (unless (or (*verbatim?*) (*newline?*)) (*newline?* #t)))
+
+(define* (space!:)
+  (unless (or (*verbatim?*) (*space?*)) (*space?* #t)))
+
+;; Can't use defform because it will override the bindings
+(hash-table-put! *tag-table* 'newline   newline)
+(hash-table-put! *tag-table* 'newline!: newline!:)
+(hash-table-put! *tag-table* 'space!:   space!:)
+;; the following makes quoted quotes disapper
+(hash-table-put! *tag-table* 'quote     (lambda x x))
+
+(define* *arg-funcs*
+  (let ([rel (lambda (t a v) (values a (relativize-path v)))])
+    (make-parameter `(:href ,rel :src ,rel))))
+
+;; This function is not too elegant since it tries to be very efficient
+(define (output-form x form-info)
+  (define tag  (car form-info))
+  (define info (cdr form-info))
+  (define xs (cdr x)) ; body values
+  (define ks '())     ; keyword symbols
+  (define as '())     ; attribute names
+  (define vs '())     ; attribute values
+  (define ms '())     ; meta keyword/values
+  (define fms '())    ; formatting meta keyword/values
+  ;; meta values marked as unspecified
+  (define ? "?")
+  (define func      ?) ; function to process body
+  (define empty?    ?) ; if no body (& close tag) needed
+  (define 1st-args  ?) ; first argument[s] should be for this keyword[s]
+  (define arg-funcs ?) ; alist of keyword processing arguments
+  (define literal?  ?) ; no quote-html in body (def: #f)
+  (define verbatim? ?) ; no indentation & newline formattings (def: literal?)
+  (define indent?   ?) ; indent body (def: #f)
+  (define newlines? ?) ; newline separators (def: indent?)
+  (define spaces?   ?) ; space separators (def: (not newlines?))
+  (define (kloop xs)
+    (if (and (pair? xs) (pair? (cdr xs)) (symbol? (car xs)))
+      (let* ([k (car xs)] [v (cadr xs)]
+             [a (keyword->string k)])
+        (cond
+         [(memq k ks) (kloop (cddr xs))] ; ignore later key values
+         [(not a) xs]
+         [(eq? #\: (string-ref a 0))
+          (case k
+            [(::args)      (when v (set-cdr! (cdr xs) (append v (cddr xs))))]
+            [(::func)      (when (eq? ? func)      (set! func      v))]
+            [(::empty?)    (when (eq? ? empty?)    (set! empty?    v))]
+            [(::1st-args)  (when (eq? ? 1st-args)  (set! 1st-args  v))]
+            [(::arg-funcs) (when (eq? ? arg-funcs) (set! arg-funcs v)
+                                 (set! fms (list* v k fms)))]
+            [(::literal?)  (when (eq? ? literal?)  (set! literal?  v))]
+            [(::verbatim?) (when (eq? ? verbatim?) (set! verbatim? v))]
+            [(::indent?)   (when (eq? ? indent?)   (set! indent?   v)
+                                 (set! fms (list* v k fms)))]
+            [(::newlines?) (when (eq? ? newlines?) (set! newlines? v)
+                                 (set! fms (list* v k fms)))]
+            [(::spaces?)   (when (eq? ? spaces?)   (set! spaces?   v)
+                                 (set! fms (list* v k fms)))]
+            [else          (set! ms (list* v k ms))])
+          (kloop (cddr xs))]
+         [else
+          (set! ks (cons k ks)) (set! as (cons a as)) (set! vs (cons v vs))
+          (kloop (cddr xs))]))
+      xs))
+  (set! xs (kloop xs))
+  (set! xs (append (kloop info) xs)) ; append if entry has args
+  (let 1st-args-loop ()
+    (when (and 1st-args (not (eq? ? 1st-args)))
+      (let ([as 1st-args])
+        (set! 1st-args ?)
+        (cond [(symbol? as) (set! xs (kloop (cons as xs)))]
+              [(pair? as)
+               (set! xs (let loop ([xs xs] [as as] [l '()])
+                          (cond
+                           [(null? as) (kloop (append! (reverse! l) xs))]
+                           [(null? xs)
+                            (if (pair? (car as))
+                              (loop xs (cdr as)
+                                    (list* (cadar as) (caar as) l))
+                              (error 'output-form
+                                     "`~a' expecting an argument for `~a'."
+                                     tag (car as)))]
+                           [else
+                            (loop (cdr xs) (cdr as)
+                                  (list* (car xs)
+                                         ((if (pair? (car as)) caar car) as)
+                                         l))])))])
+        (1st-args-loop))))
+  (set! ks (reverse! ks))
+  (set! as (reverse! as))
+  (set! vs (reverse! vs))
+  (set! ms (reverse! ms))
+  ;; set default meta values
+  (when (eq? ? empty?)    (set! empty?    '?)) ; unspec => empty if no body
+  (when (eq? ? arg-funcs) (set! arg-funcs (*arg-funcs*)))
+  (when (eq? ? literal?)  (set! literal?  #f))
+  (when (eq? ? verbatim?) (set! verbatim? #f))
+  (when (eq? ? indent?)   (set! indent?   #f))
+  (when (eq? ? newlines?) (set! newlines? indent?))
+  (when (eq? ? spaces?)   (set! spaces?   (not newlines?)))
+  (when (eq? ? func)
+    (set! func (and (or (procedure? tag) (symbol? tag))
+                    (begin0 tag (set! tag #f)))))
+  (when (and (eq? empty? #t) (pair? xs))
+    (error 'output-form "`~a' got a non-empty body: ~s." (or tag func) xs))
+  (when tag
+    (when newlines? (newline!:))
+    (display!: literal-begin "<" tag)
+    (for-each
+     (lambda (a v k)
+       (cond [(and arg-funcs (getarg arg-funcs k)) =>
+              (lambda (f) (when f (set!-values (a v) (f tag a v))))])
+       (when v
+         (if (eq? v #t)
+           (display!: " " a)
+           (begin (display!: " " a "=\"") (output v) (display!: "\"")))))
+     as vs ks)
+    ;;XHTML (display!: (if empty? " />" ">") literal-end)
+    (display!: ">" literal-end))
+  (unless (and (null? xs) empty? (not func))
+    (when tag
+      (if newlines? (newline!:) (begin (*newline?* 'x) (*space?* 'x))))
+    (when literal? (display literal-begin))
+    (let ([body
+           (thunk
+             (if func
+               (output
+                (let loop ([ks ks] [vs vs] [l '()])
+                  (if (null? ks)
+                    (let ([body (append! (reverse! fms) ms (reverse! l) xs)])
+                      (if (procedure? func)
+                        (apply func body)
+                        (cons func body))) ; allows using a symbol as alias
+                    (loop (cdr ks) (cdr vs) (list* (car vs) (car ks) l)))))
+               (for-each
+                (cond
+                 [newlines? (newline!:) (lambda (x) (output x) (newline!:))]
+                 [spaces? (space!:) (lambda (x) (output x) (space!:))]
+                 [else output])
+                xs)))])
+      (cond [func (body)]
+            [(and indent? verbatim?)
+             (parameterize
+                 ([*indentation* (add1 (*indentation*))] [*verbatim?* #t])
+               (body))]
+            [indent?
+             (parameterize ([*indentation* (add1 (*indentation*))]) (body))]
+            [verbatim? (parameterize ([*verbatim?* #t]) (body))]
+            [else (body)]))
+    (when literal? (display literal-end))
+    (when tag
+      (if newlines? (newline!:) (begin (*newline?* 'x) (*space?* 'x)))
+      (display!: literal-begin "</" tag ">" literal-end)
+      (when newlines? (newline!:)))))
+
+(define* (output x)
+  ;; optimized by frequency
+  (cond
+   ;; This can be used instead of the special-eval hack above, but it'll be
+   ;; much more limited.
+   ;; [(eq? x '!) (*space?* #t) (*newline?* #t)]
+   [(string? x) (display!: x)]
+   [(and (pair? x) (symbol? (car x))
+         (hash-table-get
+          *tag-table* (car x)
+          (thunk
+            (let ([s (symbol->string (car x))])
+              ;; maybe do this to all symbols?
+              (and (eq? #\: (string-ref s (sub1 (string-length s))))
+                   (list (substring s 0 (sub1 (string-length s))))))))) =>
+    (lambda (info)
+      (cond [(procedure? info) (output (apply info (cdr x)))]
+            [(eq? 'form~: info)
+             (output-form (cons (car x) (cddr x)) (list (cadr x)))]
+            [else (output-form x info)]))]
+   [(list? x)      (for-each output x)]
+   [(procedure? x) (output (x))] ; it might return stuff to output too
+   [(void? x)      #f]
+   [(promise? x)   (output (force x))]
+   [(pair? x)      (output (car x)) (output (cdr x))]
+   ;; [(parameter? x) (output (x))] ; not needed -- procedure? returns #t
+   [x              (display!: x)]
+   [else           #f]))
+
+;; A form `constructor' -- can be modified to protect form lists so, for
+;; example, appending results won't screw things up...
+(define* make-form list*)
+(define* (make-safe-forms! &optional (safe? #t))
+  (set! make-form (if safe? (lambda args (list (apply list* args))) list*)))
+
+(defsyntax* (defform stx)
+  (syntax-case stx ()
+    [(_ (name . vars) . body+args)
+     (let loop ([b+a #'body+args] [body '()])
+       (cond [(syntax? b+a) (loop (syntax-e b+a) body)]
+             [(or (null? b+a) (keyword? (syntax-e (car b+a))))
+              (quasisyntax/loc stx
+                (defform name (lambda vars #,@(reverse! body)) #,@b+a))]
+             [else (loop (cdr b+a) (cons (car b+a) body))]))]
+    [(_ name . args) (identifier? #'name)
+     (let ([str (symbol->string (syntax-object->datum #'name))])
+       (if (or (equal? str "")
+               (not (memq (string-ref str (sub1 (string-length str)))
+                          '(#\: #\~))))
+         (raise-syntax-error #f "got a name that doesn't end with a colon"
+                             stx #'name)
+         (let* ([str (regexp-replace #rx"^(.*[^~:])[~:]*:$" str "\\1")]
+                [val
+                 (syntax-case #'args ()
+                   [() #`(list #,str)]
+                   [(#f . as) #`(list . args)]
+                   [(str . as) (string? (syntax-e #'str)) #`(list . args)]
+                   [(a . as)
+                    (let ([as? (not (null? (syntax-e #'as)))])
+                      #`(let ([t a])
+                          (cond
+                           [(procedure? t) #,(if as? #'(list t . as) #'t)]
+                           [(and (symbol? t) (not (keyword? t))
+                                 (hash-table-get *tag-table* t (thunk #f)))
+                            => (lambda (t1) #,(if as? #'(list t . as) #'t1))]
+                           [else (list #,str t . as)])))])])
+           #`(begin (let ([v #,val])
+                      (when (pair? v)
+                        (let-values ([(t1 t2) (keys/args (cdr v))])
+                          (unless (null? t2)
+                            (error 'defform "bad info list: ~s." v))))
+                      (hash-table-put! *tag-table* 'name v))
+                    (define name (lambda body (make-form 'name body)))))))]))
+
+(defsubst* (defwrapper name args ...) (defform name args ... ::empty? #f))
+
+(defsubst* (deftag name args ...) (defform name args ... ::empty? #t))
+
+(make-provide-syntax defform    defform*)
+(make-provide-syntax defwrapper defwrapper*)
+(make-provide-syntax deftag     deftag*)
+
+;; stuff for general formatting
+(defwrapper* literal:  #f ::literal?  #t)
+(defwrapper* verbatim: #f ::verbatim? #t)
+(defwrapper* indent:   #f ::indent?   #t)
+(defwrapper* newlines: #f ::newlines? #t)
+(defwrapper* spaces:   #f ::spaces?   #t)
+(defwrapper* text:     #f ::newlines? #t)
+
+;; file utility forms
+(defform* include-file: display-file)
+(defform* include-mixed-file: display-mixed-file)
+
+;; generic wrapper (expecting a string as a first argument)
+(hash-table-put! *tag-table* 'form~: 'form~:)
+(define* (form~: . args) (cons 'form~: args))
+(defform* (wrapper~: x . xs) (list* 'form~: x ::empty? #f xs))
+(defform* (tag~:     x . xs) (list* 'form~: x ::empty? #t xs))
+;; some convenient functions
+(define* (((form:->:: w:) . args1) &all-keys args2 &body body)
+  (apply w: (append args2 args1 body))) ; arg2 precede
+(define* (((form~:->~:: w~:) x . args1) &all-keys args2 &body body)
+  (apply w~: x (append args2 args1 body))) ; arg2 precede
+
+(defform* (recform: &keys (tag ::tag #f) (n ::n 1)
+                    &other-keys keys &body body)
+  (cond
+   [(zero? n) body]
+   [(and (null? body) (symbol? tag)
+         ;; try to see of the tag symbol is ::empty?
+         (cond [(hash-table-get *tag-table* tag (thunk #f)) =>
+                (lambda (x)
+                  (and (pair? x) (eq? #t (getarg (cdr x) ::empty?))))]))
+    (let ([tag (if (symbol? tag) (list* tag keys) (apply tag keys))])
+      (let loop ([n n] [l '()])
+        (if (zero? n) l (loop (sub1 n) (cons tag l)))))]
+   [else (let ([tag (if (symbol? tag) (lambda x (cons tag x)) tag)])
+           (let loop ([n (sub1 n)] [l (apply tag (append keys body))])
+             (if (zero? n)
+               l (loop (sub1 n) (apply tag (append keys (list l)))))))]))
+
+;; ============================================================================
+;; HTML tags
+
+(deftag* br:) (deftag* break: 'br:)
+(deftag* break~: 'recform: ::tag 'br: ::1st-args '((::n 1)))
+(deftag* hr:) (deftag* hline: 'hr:)
+
+(defwrapper* html:     ::newlines? #t
+  ;;XHTML :xmlns "http://www.w3.org/1999/xhtml" :xml:lang "en" :lang "en"
+  )
+(defwrapper* head:     ::indent?   #t)
+(defwrapper* body:     ::newlines? #t)
+(defwrapper* title:)
+(deftag*     link:     ::indent? #t)
+(deftag*     link-rel~ 'link: ::1st-args '(:rel :href))
+(deftag*     link-rev~ 'link: ::1st-args '(:rev :href))
+(deftag*     base:)
+(defwrapper* frameset: ::indent? #t)
+(deftag*     frame:)
+(defwrapper* noframes:)
+(defwrapper* iframe:)
+(deftag*     meta:     ::indent? #f)
+(deftag*     meta-content~ 'meta: ::1st-args '(:name :content))
+(deftag*     http-equiv~   'meta: ::1st-args '(:http-equiv :content))
+
+(defwrapper* p:       ::newlines? #t) (defwrapper* par: 'p:)
+(defwrapper* b:       )
+(defwrapper* i:       )
+(defwrapper* u:       )
+(defwrapper* em:      )
+(defwrapper* strong:  )
+(defwrapper* blink:   )
+(defwrapper* s:       )
+(defwrapper* strike:  )
+(defwrapper* tt:      )
+(defwrapper* cite:    )
+(defwrapper* dfn:     )
+(defwrapper* code:    )
+(defwrapper* samp:    )
+(defwrapper* kbd:     )
+(defwrapper* var:     )
+(defwrapper* abbr:    )
+(defwrapper* acronym: )
+(defwrapper* h1:      )
+(defwrapper* h2:      )
+(defwrapper* h3:      )
+(defwrapper* h4:      )
+(defwrapper* h5:      )
+(defwrapper* h6:      )
+(defwrapper* sub:     )
+(defwrapper* sup:     )
+(defwrapper* ins:     )
+(defwrapper* del:     )
+(defwrapper* nobr:    )
+
+(defwrapper* big:     )
+(defwrapper* big~:    recform: ::tag 'big: ::1st-args ::n)
+(defwrapper* small:   )
+(defwrapper* small~:  recform: ::tag 'small: ::1st-args ::n)
+
+(defwrapper* font:    )
+
+(defwrapper* face~: 'font: ::1st-args :face)
+
+(defwrapper* (size~: s . body)
+  (list* 'font: :size (list (and (number? s) (> s 0) "+") s) body))
+(defwrapper* size+0: 'font: :size "+0")
+(defwrapper* size+1: 'font: :size "+1")
+(defwrapper* size+2: 'font: :size "+2")
+(defwrapper* size+3: 'font: :size "+3")
+(defwrapper* size+4: 'font: :size "+4")
+(defwrapper* size-1: 'font: :size "-1")
+(defwrapper* size-2: 'font: :size "-2")
+
+(defwrapper* color~:  'font: ::1st-args :color)
+(defwrapper* black:   'font: :color "black")
+(defwrapper* white:   'font: :color "white")
+(defwrapper* red:     'font: :color "red")
+(defwrapper* green:   'font: :color "green")
+(defwrapper* blue:    'font: :color "blue")
+(defwrapper* cyan:    'font: :color "cyan")
+(defwrapper* magenta: 'font: :color "magenta")
+(defwrapper* yellow:  'font: :color "yellow")
+(defwrapper* purple:  'font: :color "purple")
+
+(defwrapper* div: ::indent? #t)
+(defwrapper* left:    'div: ::indent? #t :align 'left)
+(defwrapper* right:   'div: ::indent? #t :align 'right)
+(defwrapper* justify: 'div: ::indent? #t :align 'justify)
+(defwrapper* center:  'div: ::indent? #t :align 'center)
+
+(defwrapper* rtl:     'div: ::indent? #t :dir 'rtl)
+(defwrapper* ltr:     'div: ::indent? #t :dir 'ltr)
+
+(defwrapper* span: ::indent? #t)
+(defwrapper* class~: 'span: ::1st-args :class ::newlines? #f ::indent? #t)
+
+(defwrapper* address:    ::indent? #t)
+(defwrapper* blockquote: ::indent? #t)
+(defwrapper* quote:      'blockquote: ::indent? #t)
+(defwrapper* q:)
+(defwrapper* pre:        ::verbatim? #t)
+
+(deftag* img: :alt "")
+(deftag* image~
+  (lambda (&keys [type ::type #f] [my? ::my? #f] src &rest-keys args)
+    (if (string? src)
+      (begin ; use concat for relativize-path
+        (when type (set! src (concat src "." type)))
+        (when my?  (set! src (concat (*image-dir*) src))))
+      (begin
+        (when type (set! src (list src "." type)))
+        (when my?  (set! src (list (*image-dir*) src)))))
+    (apply img: :src src args))
+  ::1st-args '(:src (:alt #f #|XHTML ""|#)))
+(defform* gif~    'image~ ::type "gif")
+(defform* jpg~    'image~ ::type "jpg")
+(defform* png~    'image~ ::type "png")
+(defform* my-image~ 'image~ ::my? #t)
+(defform* my-gif~ 'gif~ ::my? #t)
+(defform* my-jpg~ 'jpg~ ::my? #t)
+(defform* my-png~ 'png~ ::my? #t)
+(defwrapper* map:)
+(deftag*     area:)
+(deftag*     spacer:)
+
+;; Links
+
+(defwrapper* a:)
+(defwrapper* ref~:
+  (lambda (&keys [base ::base #f] href &rest-keys args)
+    (apply a: :href (if base (list base href) href) args))
+  ::1st-args :href)
+(defwrapper* name~:   'a: ::1st-args :name)
+(defwrapper* http~:   'ref~: ::base "http://")
+(defwrapper* ftp~:    'ref~: ::base "ftp://")
+(defwrapper* telnet~: 'ref~: ::base "telnet://")
+(defwrapper* mailto~: 'ref~: ::base "mailto:")
+(defform* (ref~    x) (ref~:    x (tt: x)))
+(defform* (http~   x) (http~:   x (tt: x)))
+(defform* (ftp~    x) (ftp~:    x (tt: x)))
+(defform* (telnet~ x) (telnet~: x (tt: x)))
+(defform* (mailto~ x) (mailto~: x (tt: x)))
+
+;; Lists and tables
+
+(define* !>    '!>)
+(define* item> 'item>)
+(define* row>  'row>)
+(define* col>  'col>)
+
+(defwrapper* li: ::indent? #t ::newlines? #f)
+
+(define (split-by key args)
+  (define (splitter args)
+    (let loop ([args args] [acc '()])
+      (cond
+       [(null? args) (cons (reverse! acc) '())]
+       [(eq? (car args) key) (cons (reverse! acc) (splitter (cdr args)))]
+       [else (loop (cdr args) (cons (car args) acc))])))
+  (splitter args))
+
+(defwrapper* (list~: &keys [tag ::tag #f] [br ::br 0]
+                           [subtag ::subtag '(li:)]
+                           [split ::split-by '(item>)]
+                           [subtag2 ::subtag2 #f]
+                           [subargs ::subargs #f]
+                     &rest-keys args)
+  (define (wrap tag keys body subargs br)
+    (cond [;; kludge: if the body begins with a `foo:' wrap it in a list
+           ;; -- there is no other way to distinguish ("a" "b") and (b: "x")
+           (and (pair? body) (symbol? (car body))
+                (hash-table-get *tag-table* (car body)
+                  (thunk
+                    (let ([s (symbol->string (car body))])
+                      (eq? #\: (string-ref s (sub1 (string-length s))))))))
+           (set! body (list body))]
+          [(not (list? body)) (set! body (list body))])
+    (cond [(or (not (pair? subargs)) (null? (car subargs)))]
+          [(pair? (car subargs)) (set! body (append (car subargs) body))]
+          [else (set! body (append subargs body))])
+    (when (and (pair? br) (number? (car br)))
+      (set! body (append body (list (break~: (car br))))))
+    (cond [(string? tag) (list* 'wrapper~: tag (append keys body))]
+          [(symbol? tag) (cons tag (append keys body))]
+          [(apply tag (append keys body))]))
+  (let loop ([args    args]
+             [splits  (if (list? split)  split  (list split))]
+             [subtags (if (list? subtag) subtag (list subtag))]
+             [tag     tag]
+             [subargs (cons '() subargs)]
+             [br      (and (> br 0) (list #f br))]) ; br only on 2nd level
+    (let-values ([(keys items)
+                  (cond [(not (list? args)) (values '() args)]
+                        [(and (pair? splits) (memq (car splits) args))
+                         (let ([xs (split-by (car splits) args)])
+                           (values (car xs) (cdr xs)))]
+                        [else (keys/args args)])])
+      (cond [(not items) #f] ; filter out false items
+            [(pair? splits)
+             (wrap tag keys
+                   (map (lambda (i)
+                          (loop i (cdr splits) (cdr subtags) (car subtags)
+                                (and (list? subargs) (list? (car subargs))
+                                     (cdr subargs))
+                                (and (pair? br) (cdr br))))
+                        items)
+                   subargs br)]
+            [subtag2
+             (let ([x (split-by !> items)])
+               (cond [(null? (cdr x)) (wrap tag keys items br)]
+                     [(pair? (cddr x))
+                      (error 'list~: "multiple `!>'s in ~s." items)]
+                     [else
+                      (list (wrap tag keys (car x) subargs #f)
+                            (indent:
+                             (let-values ([(k b) (keys/args (cadr x))])
+                               (wrap subtag2 k b
+                                     (and (list? subargs)
+                                          (list? (car subargs))
+                                          (cdr subargs))
+                                     br))))]))]
+            [else (wrap tag keys items subargs br)])))
+  ::indent? #t ::1st-args '::tag)
+
+(define* list~:: (form~:->~:: list~:))
+
+;; use strings as tags to avoid recursion
+(defwrapper* enumerate:  (list~:: "ol"))
+(defwrapper* itemize:    (list~:: "ul"))
+(defwrapper* menu:       (list~:: "menu"))
+(defwrapper* dir:        (list~:: "dir"))
+(defwrapper* itemize-bullet: (list~:: "ul" :type 'disc))
+(defwrapper* itemize-circle: (list~:: "ul" :type 'circle))
+(defwrapper* itemize-square: (list~:: "ul" :type 'square))
+(defwrapper* description:    (list~:: "dl" ::subtag "dt" ::subtag2 "dd"))
+
+(defwrapper* table: ::indent? #t)
+(defwrapper* th:    ::indent? #t)
+(defwrapper* tr:    ::indent? #t)
+(defwrapper* td:    ::indent? #f ::newlines? #f)
+
+;; A version that uses `list:' -- easier for manual tables, but sensitive to
+;; lists, so `table:' might be more useful for some programs.
+(defwrapper* table*:
+  (list~:: "table" ::subtag '(tr: td:) ::split-by '(row> col>))
+  ::indent? #t)
+
+;; Form stuff
+
+(defwrapper* form: ::indent? #t)
+(deftag*     input:)
+(deftag*     button:         'input: :type 'button)
+(deftag*     submit-button:  'input: :type 'submit)
+(deftag*     submit~:        'submit-button: ::1st-args :value)
+(deftag*     text-input:     'input: :type 'text)
+(deftag*     checkbox:       'input: :type 'checkbox)
+(deftag*     radiobox:       'input: :type 'radio)
+(deftag*     password-input: 'input: :type 'password)
+(deftag*     hidden-input:   'input: :type 'hidden)
+(defwrapper* select: ::indent? #t)
+(defwrapper* option: ::indent? #f ::newlines? #f)
+(defwrapper* option~: ::indent? #f ::newlines? #f ::1st-args :value)
+(defwrapper* options: (list~:: "select" ::subtag 'option~:)
+  ::indent? #t)
+(defform* (select-options: &all-keys keys &body options)
+  (apply select: (append keys (map (lambda (o)
+                                     (if (list? o)
+                                       `(option: :value ,@o)
+                                       `(option: :value ,o ,o)))
+                                   options))))
+(defwrapper* button*: "button")
+(defwrapper* label~: ::1st-args :for)
+(defwrapper* textarea: ::verbatim? #t)
+(defwrapper* legend:)
+(defwrapper* (fieldset: . body)
+  (if (memq !> body)
+    (let ([xs (split-by !> body)])
+      (when (pair? (cddr xs))
+        (error 'fieldset: "multiple `!>'s in ~s." body))
+      (apply wrapper~: "fieldset" ::indent? #t
+             (apply legend: (car xs)) (cadr xs)))
+    (apply wrapper~: "fieldset" body)))
+
+;; Comments scripts and styles
+
+(defform* comment:
+  (lambda (&keys [code? ::code? #f] &body lines)
+    (unless (null? lines)
+      (list literal-begin "<!--"
+            (cond [code?               (list (apply indent: lines) "// ")]
+                  [(null? (cdr lines)) (list " " (car lines) " ")]
+                  [else                (apply indent: lines)])
+            "-->" literal-end)))
+  ::newlines? #t)
+
+(defwrapper* script: ::func comment: ::code? #t
+                     :type "text/javascript" :language "JavaScript")
+(defwrapper* script-src~ 'script: ::1st-args :src)
+(defwrapper* noscript: ::indent? #t)
+(defwrapper* style: ::func comment: ::code? #t :type "text/css")
+(defwrapper* style-src~ 'link: ::1st-args :href
+                               :rel "stylesheet" :type "text/css")
+
+(defwrapper* applet: ::indent? #t)
+(defwrapper* object: ::indent? #t)
+(deftag*     param:)
+(deftag*     param~: ::1st-args '(:name :value))
+(defwrapper* applet-params:
+  (list~:: "applet" ::subtag 'param~:) ::indent? #t)
+(defwrapper* object-params:
+  (list~:: "object" ::subtag 'param~:) ::indent? #t)
+
+(deftag*     embed:)
+(defwrapper* noembed: ::indent? #t)
+
+;; ============================================================================
+;; A little higher abstraction level...
+
+(defform* (html~: title head body
+                  &keys [charset-type (*charset-type*)]
+                        [prefix *prefix*])
+  (html: (apply head: prefix
+                (meta-content~ 'generator "Scheme!")
+                (and charset-type
+                     (http-equiv~ "Content-Type"
+                                  (list "text/html; charset=" charset-type)))
+                (and title (title: title))
+                (or head '()))
+         body))
+
+(defform* (document: &keys [comment  ::comment  #f]
+                           [comment1 ::comment1 comment]
+                           [comment2 ::comment2 comment]
+                     &rest-keys body)
+  (text: (cond [(*doc-type*) =>
+                (lambda (t)
+                  (literal: (list "<!DOCTYPE html PUBLIC \"-//W3C//DTD "
+                                  (if (list? t) (car t) t) "//EN\""
+                                  (and (pair? t) (cons " " (cdr t)))
+                                  ">")))])
+         (and comment1 (comment: comment1))
+         body
+         (and comment2 (comment: comment2))))
+
+;; ============================================================================
+;; HTML quotations
+
+;; Quote some characters.
+(define* html-quotes
+  (make-parameter '((#\< "lt") (#\> "gt") (#\" "quot") (#\& "amp"))))
+
+;; Expand some other characters.
+(define* html-specials
+  (make-parameter
+   '((#\space "nbsp") (#\C "copy") (#\R "reg") (#\T "trade") (#\- "mdash")
+     (#\< "laquo") (#\> "raquo") (#\1 "sup1") (#\2 "sup2") (#\3 "sup3")
+     (#\* "bull"))))
+
+(define *in-quote-html?* (make-parameter #f))
+
+(define* literal-begin "\0{")
+(define* literal-end   "\0}")
+
+;; Quote HTML text using the above.
+;;   Things in html-quotes get translated: "<" --> "&lt;"
+;;   Things in html-specials are translated when escaped: "\\ " --> "&nbsp;"
+;;   All other characters after "\" appear literal.
+;;   Meta quotes for literal text are "NUL{" and "NUL)" - they prevent any
+;;     special processing inside (and can be nested).  The idea is that user
+;;     strings and files never contains these, if needed, the literal-begin
+;;     and literal-end should be used from user code.
+(define* (quote-html html-proc)
+  (define cur-html-quotes   (html-quotes))
+  (define cur-html-specials (html-specials))
+  (define (display-char ch specials)
+    (cond [(assq ch specials) =>
+           (lambda (x) (display #\&) (display (cadr x)) (display #\;))]
+          [else (display ch)]))
+  (define (quote-html)
+    (let ([literal 0])
+      (let loop ()
+        (let ([ch (read-char)])
+          (unless (eof-object? ch)
+            (cond [(eq? ch #\nul)
+                   (set! ch (read-char))
+                   (case ch
+                     [(#\{) (set! literal (add1 literal))]
+                     [(#\}) (if (> literal 0)
+                              (set! literal (sub1 literal))
+                              (error 'quote-html "Unexpected literal-end."))]
+                     [else (display ch)])]
+                  [(and (eq? ch #\\) (zero? literal))
+                   (display-char (read-char) cur-html-specials)]
+                  [(> literal 0) (display ch)]
+                  [else (display-char ch cur-html-quotes)])
+            (loop))))
+      (when (> literal 0) (error 'quote-html "Unmatched open-literal."))))
+  (parameterize ([*in-quote-html?* #t])
+    (with-output-filter quote-html html-proc)))
+
+;; ============================================================================
+;; Website creation
+
+(define* *defined-htmls* '())
+(define* (add-defined-html html)
+  (set! *defined-htmls* (cons html *defined-htmls*)))
+
+(defsyntax* (html-obj! stx)
+  (syntax-case stx ()
+    [(_ . body)
+     (let ([body #'body])
+       (let loop ([as body] [ks '()])
+         (syntax-case as (:contents)
+           [(:contents c . r) #f]
+           [(key val . r)
+            (and (identifier? #'key) (syntax-keyword? #'key))
+            (loop #'r (list* #'val #'key ks))]
+           [(b ...)
+            (set! body `(,@(reverse! ks)
+                         ,#':contents ,#'(delay (begin b ...))))]))
+       #`(let ([html (list #,@body)]) (add-defined-html html) html))]))
+
+(defsyntax* (defhtml stx)
+  (syntax-case stx ()
+    [(_ var . body-) (identifier? #'var)
+     (let ([body #'body-])
+       (let loop ([bs body])
+         (syntax-case bs (:name)
+           [(:name n . r) #`(define var (html-obj! . body-))]
+           [(key val . r)
+            (and (identifier? #'key) (syntax-keyword? #'key))
+            (loop #'r)]
+           [_ (let ([name (symbol->string (syntax-e #'var))])
+                (when (eq? (string-ref name 0) #\_)
+                  (set! name (substring name 1 (string-length name))))
+                (when (eq? (string-ref name (sub1 (string-length name))) #\/)
+                  (set! name (string-append name "index")))
+                #`(define var (html-obj! :name #,name . body-)))])))]))
+
+(define (maybe-add-suffix str suffix)
+  (let ([len1 (string-length str)]
+        [len2 (string-length suffix)])
+    (if (and (>= len1 len2)
+             (equal? suffix (substring str (- len1 len2) len1)))
+      str (concat str suffix))))
+
+(define* (html-file-name file-or-html &keys relative?)
+  (let* ([file (if (string? file-or-html)
+                 file-or-html
+                 (getarg file-or-html :name))]
+         [name (maybe-add-suffix (concat (*html-target-dir*) file)
+                                 (*html-suffix*))])
+    (if relative? (relativize-path name) name)))
+
+(define* (html-ref-name file-or-html &keys relative?)
+  (let* ([file (if (string? file-or-html)
+                 file-or-html
+                 (getarg file-or-html :name))]
+         [name (maybe-add-suffix file (*html-suffix*))])
+    (if relative? (relativize-path name) name)))
+
+(define* (output-html html)
+  ;; this is only used as a top-level wrapper for quote-html with output
+  (parameterize ([*newline?* 'x] [*space?* 'x] [*verbatim?* #f])
+    (quote-html (thunk (output html)
+                       (when (boolean? (*newline?*)) (newline))))))
+
+(define* (output-to-html file html)
+  (let ([fname (html-file-name (or file html))]
+        [html  (thunk
+                 ;; Due to strange bug with Sun and NFS
+                 (file-stream-buffer-mode (current-output-port) 'block)
+                 (output-html html))])
+    (if fname
+      (begin (printf "Making ~a\n" fname)
+             (let ([d (dirname fname)])
+               (unless (directory-exists? d)
+                 (make-directory d)))
+             (when (file-exists? fname) (delete-file fname))
+             (with-output-to-file fname html))
+      (begin ; (eprintf "Warning: no filename, using stdout.\n")
+        (html)))))
+
+(define* (make-html page . more-args)
+  (parameterize ([*current-html-obj* page])
+    (apply
+     (lambda (&keys name contents &rest args)
+       (when (promise? contents) (set! contents (force contents)))
+       (output-to-html (if (symbol? name) (symbol->string name) name)
+         (thunk
+           (let ([contents
+                  (cond [(and (procedure? contents)
+                              (arity-at-least? (procedure-arity contents)))
+                         (apply contents args)]
+                        [else contents])])
+             (output
+              (apply document:
+                     ::comment1 '("Generated by Swindle/html "
+                                  "(http://www.barzilay.org/Swindle/)")
+                     ::comment2 "Generated by Swindle/html"
+                     contents))))))
+     (append page more-args))))
+
+(define* (make-htmls pages . more-args)
+  (unless (equal? "" (*html-target-dir*))
+    (unless (directory-exists? (*html-target-dir*))
+      (make-directory (*html-target-dir*)))
+    (unless (directory-exists? (*html-target-dir*))
+      (error 'make-htmls
+             "could not create output directory: ~s." (*html-target-dir*))))
+  (for-each (lambda (page) (apply make-html page more-args)) pages))
+
+(define* (make-defined-htmls . more-args)
+  ;; repeat while making pages create more pages
+  (when (pair? *defined-htmls*)
+    (let ([pages (reverse *defined-htmls*)])
+      (set! *defined-htmls* '())
+      (apply make-htmls pages more-args)
+      (make-defined-htmls))))
+
+(define (find-html-by-string str)
+  (let* ([sym (string->symbol str)]
+         [val (namespace-variable-value sym #f (lambda () #f))])
+    (if (and val (list? val) (getarg val :name))
+      val
+      (let loop ([hs *defined-htmls*])
+        (and (pair? hs) (let ([name (getarg (car hs) :name)])
+                          (if (or (equal? str name)
+                                  (equal? str (html-file-name name))
+                                  (equal? str (html-ref-name name)))
+                            (car hs)
+                            (loop (cdr hs)))))))))
+
+(define* (html-main args . more-args)
+  (let ([args (cond [(list? args) args]
+                    [(vector? args) (vector->list args)]
+                    [else (list args)])])
+    (if (null? args)
+      (apply make-defined-htmls more-args)
+      (for-each (lambda (x)
+                  (cond [(not (string? x)) (apply make-html x more-args)]
+                        [(find-html-by-string x) =>
+                         (lambda (x) (apply make-html x more-args))]
+                        [else (eprintf "Ignoring ~s\n" x)]))
+                args))))
+
+;; ============================================================================
+
+)
diff --git a/collects/swindle/info.ss b/collects/swindle/info.ss
new file mode 100644
index 0000000000..dd8c2e6a12
--- /dev/null
+++ b/collects/swindle/info.ss
@@ -0,0 +1,41 @@
+;;; Written by Eli Barzilay: Maze is Life!  (eli@barzilay.org)
+
+(module info (lib "infotab.ss" "setup")
+  ;;
+  (define name "Swindle")
+  (define blurb
+    '("Swindle extensions for MzScheme -- CLOS and more."))
+  (define help-desk-message
+    "Mz/Mr: (require (lib \"swindle.ss\" \"swindle\"))")
+  ;;
+  ;; Can't use these since the startup parameters are hard-wired
+  (define mzscheme-launcher-names '("swindle"))
+  (define mzscheme-launcher-flags
+    '(("-me"
+       "(namespace-require/copy (quote (lib \"swindle.ss\" \"swindle\")))")))
+  ;;
+  ;; This simple interface is not enough, use tool.ss instead
+  ;; (define drscheme-language-modules
+  ;;   '(("swindle.ss" "swindle")
+  ;;     ("turbo.ss" "swindle")
+  ;;     ("html.ss" "swindle")))
+  ;; (define drscheme-language-positions
+  ;;   '(("Swindle" "Full Swindle")
+  ;;     ("Swindle" "Swindle without CLOS")
+  ;;     ("Swindle" "HTML Swindle")))
+  ;; (define drscheme-language-numbers
+  ;;   '((-900 0) (-900 1) (-900 2)))
+  ;; (define drscheme-language-one-line-summaries
+  ;;   '("Scheme with Full Swindle extensions"
+  ;;     "Scheme with Swindle without the object system"
+  ;;     "Scheme with the HTML and Swindle extensions"))
+  ;; (define drscheme-language-urls
+  ;;   '("http://www.barzilay.org/Swindle/"
+  ;;     "http://www.barzilay.org/Swindle/"
+  ;;     "http://www.barzilay.org/Swindle/"))
+  ;;
+  (define tools      '(("tool.ss")))
+  (define tool-names '("Swindle"))
+  (define tool-icons '(("swindle-icon.png" "swindle")))
+  (define tool-urls  '("http://www.barzilay.org/Swindle/"))
+  )
diff --git a/collects/swindle/misc.ss b/collects/swindle/misc.ss
new file mode 100644
index 0000000000..0bd498c8cd
--- /dev/null
+++ b/collects/swindle/misc.ss
@@ -0,0 +1,2009 @@
+;;; Written by Eli Barzilay: Maze is Life!  (eli@barzilay.org)
+
+;;> A lot of miscellaneous functionality that is needed for Swindle, or
+;;> useful by itself.
+
+(module misc (lib "base.ss" "swindle")
+
+(require (lib "list.ss"))
+(provide (all-from (lib "list.ss")))
+(require (lib "etc.ss"))
+(provide (all-from (lib "etc.ss")))
+(require (all-except (lib "string.ss") regexp-quote))
+(provide (all-from (lib "string.ss")))
+
+;; ----------------------------------------------------------------------------
+;;>>... Convenient syntax definitions
+
+;;>> (define* ...)
+;;>   Just like `define', except that the defined identifier is
+;;>   automatically `provide'd.  Doesn't work for defining values.
+(provide define*)
+(define-syntax (define* stx)
+  (syntax-case stx ()
+    [(_ x . xs)
+     (let ([name (let loop ([x #'x])
+                   (syntax-case x () [(x . xs) (loop #'x)] [_ x]))])
+       #`(begin (provide #,name) (define x . xs)))]))
+;;>> (make-provide-syntax orig-def-syntax provide-def-syntax)
+;;>   Creates `provide-def-syntax' as a syntax that is the same as
+;;>   `orig-def-syntax' together with an automatic `provide' form for the
+;;>   defined symbol, which should be either the first argument or the first
+;;>   identifier in a list (it does not work for recursive nesting).  The
+;;>   convention when this is used is to use a "*" suffix for the second
+;;>   identifier.
+(provide make-provide-syntax)
+(define-syntax make-provide-syntax
+  (syntax-rules ()
+    [(_ form form*)
+     (define-syntax form*
+       (syntax-rules ()
+         [(_ (id . as) . r) (begin (provide id) (form (id . as) . r))]
+         [(_ id . r) (begin (provide id) (form id . r))]))]))
+;;>> (define-syntax* ...)
+;;>   Defined as the auto-provide form of `define-syntax'.
+(provide define-syntax*)
+(make-provide-syntax define-syntax define-syntax*)
+
+;;>> (defsyntax ...)
+;;>> (defsyntax* ...)
+;;>> (letsyntax (local-syntaxes ...) ...)
+;;>   These are just shorthands for `define-syntax', `define-syntax*', and
+;;>   `let-syntax'.  This naming scheme is consistent with other definitions
+;;>   in this module (and the rest of Swindle).
+(define-syntax* defsyntax
+  (syntax-rules () [(_ . args) (define-syntax . args)]))
+(make-provide-syntax defsyntax defsyntax*) (provide defsyntax*)
+(define-syntax* letsyntax
+  (syntax-rules () [(_ . args) (let-syntax . args)]))
+
+;;>> (defsubst name body)
+;;>> (defsubst* name body)
+;;>> (letsubst ([name body] ...) letbody ...)
+;;>   These are convenient ways of defining simple pattern transformer
+;;>   syntaxes (simple meaning they're much like inlined functions).  In
+;;>   each of these forms, the `name' can be either a `(name arg ...)' which
+;;>   will define a simple macro or an identifier which will define a
+;;>   symbol-macro.  For example:
+;;>     => (defsubst (my-if cond then else)
+;;>          (if (and cond (not (eq? 0 cond))) then else))
+;;>     => (my-if 1 (echo 2) (echo 3))
+;;>     2
+;;>     => (my-if 0 (echo 2) (echo 3))
+;;>     3
+;;>     => (define x (list 1 2 3))
+;;>     => (defsubst car-x (car x))
+;;>     => car-x
+;;>     1
+;;>     => (set! car-x 11)
+;;>     => x
+;;>     (11 2 3)
+;;>   Actually, if a `(name arg ...)' is used, then the body can have more
+;;>   pattern/expansions following -- but since this form translates to a
+;;>   usage of `syntax-rules', the `name' identifier should normally be `_'
+;;>   in subsequent patterns.  For example:
+;;>     => (defsubst (my-if cond then else)
+;;>                    (if (and cond (not (eq? 0 cond))) then else)
+;;>                  (_ cond then)
+;;>                    (and cond (not (eq? 0 cond)) then))
+;;>     => (my-if 0 1)
+;;>     #f
+;;>   Finally, note that since these are just patterns that get handled by
+;;>   syntax-rules, all the usual pattern stuff applies, like using `...'.
+
+(defsyntax defsubst-process
+  (syntax-rules ()
+    [(_ name (acc ...)) (define-syntax name (syntax-rules () acc ...))]
+    [(_ name (acc ...) n+a subst . more)
+     (defsubst-process name (acc ... (n+a subst)) . more)]))
+(defsyntax* defsubst
+  (syntax-rules ()
+    [(_ (name . args) subst)
+     (define-syntax name
+       (syntax-rules () [(name . args) subst]))]
+    [(_ (name . args) subst . more)
+     (defsubst-process name () (name . args) subst . more)]
+    [(_ name subst)
+     (define-syntax (name stx)
+       (syntax-case stx () ; syntax-rules won't handle identifier expansion
+         ;; doesn't matter here, but see `letsubst' for an explanation on `___'
+         [(___ . args) (syntax/loc stx (subst . args))]
+         [___          (syntax/loc stx subst)]))]))
+(make-provide-syntax defsubst defsubst*) (provide defsubst*)
+
+;; a let version of the above
+(defsyntax* (letsubst stx)
+  (syntax-case stx ()
+    [(_ ([name body] ...) letbody ...)
+     (quasisyntax/loc stx
+       (let-syntax
+           #,(map
+              (lambda (name body)
+                ;; use `___' in the following, if we use `name', then it would
+                ;; not be possible to make an X subst that expand to something
+                ;; with the previous X, so (let ([x 1]) (letsubst ([x x]) x))
+                ;; will loop forever instead of returning 1.
+                (syntax-case name ()
+                  [(name . args)
+                   (quasisyntax/loc body
+                     (name (syntax-rules () [(___ . args) #,body])))]
+                  [name (identifier? #'name)
+                   (quasisyntax/loc body
+                     (name
+                      (lambda (stx)
+                        (syntax-case stx ()
+                          [(___ . args) (syntax/loc stx (#,body . args))]
+                          [___          (syntax/loc stx #,body)]))))]))
+              (syntax-e #'(name ...)) (syntax-e #'(body ...)))
+         letbody ...))]))
+
+;;>> (defmacro name body)
+;;>> (defmacro* name body)
+;;>> (letmacro ([name body] ...) letbody ...)
+;;>   These are just like MzScheme's define-macro (from mzlib/defmacro) with
+;;>   two major extensions:
+;;>   * If `name' is a simple identifier then a symbol-macro is defined (as
+;;>     with `defsubst' above).
+;;>   * A `letmacro' form for local macros is provided.
+
+(require-for-syntax (lib "dmhelp.ss" "mzlib" "private"))
+(provide defmacro letmacro)
+(define-syntaxes (defmacro letmacro)
+  (let ()
+    (define (syntax-null? x)
+      (or (null? x) (and (syntax? x) (null? (syntax-e x)))))
+    (define (syntax-pair? x)
+      (or (pair? x) (and (syntax? x) (pair? (syntax-e x)))))
+    (define (syntax-car x)   (if (pair? x) (car x) (car (syntax-e x))))
+    (define (syntax-cdr x)   (if (pair? x) (cdr x) (cdr (syntax-e x))))
+    (define (check-args stx name args)
+      (unless (identifier? name)
+        (raise-syntax-error
+         #f "expected an identifier for the macro name" stx name))
+      (let loop ([args args])
+        (cond [(syntax-null? args) 'ok]
+              [(identifier? args) 'ok]
+              [(syntax-pair? args)
+               (unless (identifier? (syntax-car args))
+                 (raise-syntax-error
+                  #f "expected an identifier for a macro argument"
+                  stx (syntax-car args)))
+               (loop (syntax-cdr args))]
+              [else
+               (raise-syntax-error
+                #f "not a valid argument sequence after the macro name"
+                stx)])))
+    (values
+     (lambda (stx) ; defmacro
+       (syntax-case stx ()
+         [(_ (name . args) body0 body ...)
+          (begin
+            (check-args stx #'name #'args)
+            #'(define-syntax name
+                (let ([p (lambda args body0 body ...)])
+                  (lambda (stx)
+                    (let ([l (syntax->list stx)])
+                      (unless (and l (procedure-arity-includes?
+                                      p (sub1 (length l))))
+                        (raise-syntax-error #f "bad form" stx))
+                      (let ([ht (make-hash-table)])
+                        (datum->syntax-object
+                         stx
+                         (dm-subst
+                          ht (apply p (cdr (dm-syntax->datum stx ht))))
+                         stx)))))))]
+         [(_ name body) (identifier? #'name)
+          #'(define-syntax name
+              (lambda (stx)
+                (syntax-case stx ()
+                  [(_ . xs) (quasisyntax/loc stx
+                              (#,(datum->syntax-object stx body stx) . xs))]
+                  [_ (datum->syntax-object stx body stx)])))]))
+     (lambda (stx) ; letmacro
+       (syntax-case stx ()
+         [(_ ([name body] ...) letbody ...)
+          (quasisyntax/loc stx
+            (let-syntax
+                #,(map
+                   (lambda (name body)
+                     (if (identifier? name)
+                       (quasisyntax/loc body
+                         (#,name
+                          (lambda (stx)
+                            (syntax-case stx ()
+                              [(_1 . xs)
+                               (quasisyntax/loc stx
+                                 (#,(datum->syntax-object stx body stx)
+                                  . xs))]
+                              [_1 (datum->syntax-object stx #,body stx)]))))
+                       (syntax-case name ()
+                         [(name . args)
+                          (begin
+                            (check-args stx #'name #'args)
+                            (quasisyntax/loc body
+                              (name
+                               (let ([p (lambda args #,body)])
+                                 (lambda (stx)
+                                   (let ([l (syntax->list stx)])
+                                     (unless
+                                         (and l (procedure-arity-includes?
+                                                 p (sub1 (length l))))
+                                       (raise-syntax-error #f "bad form" stx))
+                                     (let ([ht (make-hash-table)])
+                                       (datum->syntax-object
+                                        stx
+                                        (dm-subst
+                                         ht (apply p (cdr (dm-syntax->datum
+                                                           stx ht))))
+                                        stx))))))))])))
+                   (syntax-e #'(name ...)) (syntax-e #'(body ...)))
+              letbody ...))])))))
+(make-provide-syntax defmacro defmacro*) (provide defmacro*)
+
+;; ----------------------------------------------------------------------------
+;;>>... Controlling syntax
+
+;;>> (define-syntax-parameter name default)
+;;>> (define-syntax-parameter* name default)
+;;>   Creates a `syntax parameter'.  Syntax parameters are things that you
+;;>   can use just like normal parameters, but they are syntax transformers,
+;;>   and the information they store can be used by other syntax
+;;>   transformers.  The purpose of having them around is to parameterize
+;;>   the way syntax transformation is used -- so they should be used as
+;;>   global option changes, not for frequent side effect: they change their
+;;>   value at syntax expansion time.  Note that using it stores the literal
+;;>   syntax that is passed to them -- there is no way to evaluate the given
+;;>   argument, for example, if some parameter expects a boolean -- then
+;;>   `(not #t)' will not work!  The syntax parameter itself is invoked
+;;>   wither with no arguments to retrieve its value, or with an argument to
+;;>   set it.  Retrieving or setting the value in this way is meaningful
+;;>   only in an interactive context since using it in a function just
+;;>   expands to the current value:
+;;>     => (define-syntax-parameter -foo- 1)
+;;>     => (-foo-)
+;;>     1
+;;>     => (define (foo) (-foo-))
+;;>     => (-foo- 2)
+;;>     => (-foo-)
+;;>     2
+;;>     => (foo)
+;;>     1
+(defsyntax* define-syntax-parameter
+  (syntax-rules ()
+    [(_ name default)
+     (define-syntax name
+       (let ([p (make-parameter #'default)])
+         (lambda stx
+           (if (null? stx)
+             (p) ; when the value is used in other transformers
+             (syntax-case (car stx) ()
+               [(_ new) (begin (p #'new) #'(void))]
+               [(_)     (p)])))))]))
+(make-provide-syntax define-syntax-parameter define-syntax-parameter*)
+(provide define-syntax-parameter*)
+
+;; ----------------------------------------------------------------------------
+;;>>... Setters and more list accessors
+
+;;>> (set-caar! place x)
+;;>> (set-cadr! place x)
+;;>> (set-cdar! place x)
+;;>> (set-cddr! place x)
+;;>> (set-caaar! place x)
+;;>> (set-caadr! place x)
+;;>> (set-cadar! place x)
+;;>> (set-caddr! place x)
+;;>> (set-cdaar! place x)
+;;>> (set-cdadr! place x)
+;;>> (set-cddar! place x)
+;;>> (set-cdddr! place x)
+;;>> (set-caaaar! place x)
+;;>> (set-caaadr! place x)
+;;>> (set-caadar! place x)
+;;>> (set-caaddr! place x)
+;;>> (set-cadaar! place x)
+;;>> (set-cadadr! place x)
+;;>> (set-caddar! place x)
+;;>> (set-cadddr! place x)
+;;>> (set-cdaaar! place x)
+;;>> (set-cdaadr! place x)
+;;>> (set-cdadar! place x)
+;;>> (set-cdaddr! place x)
+;;>> (set-cddaar! place x)
+;;>> (set-cddadr! place x)
+;;>> (set-cdddar! place x)
+;;>> (set-cddddr! place x)
+;;>   These are all defined so it is possible to use `setf!' from "setf.ss"
+;;>   with these standard and library-provided functions.
+(define* set-caar!   (lambda (p v) (set-car! (car p) v)))
+(define* set-cadr!   (lambda (p v) (set-car! (cdr p) v)))
+(define* set-cdar!   (lambda (p v) (set-cdr! (car p) v)))
+(define* set-cddr!   (lambda (p v) (set-cdr! (cdr p) v)))
+(define* set-caaar!  (lambda (p v) (set-car! (caar p) v)))
+(define* set-caadr!  (lambda (p v) (set-car! (cadr p) v)))
+(define* set-cadar!  (lambda (p v) (set-car! (cdar p) v)))
+(define* set-caddr!  (lambda (p v) (set-car! (cddr p) v)))
+(define* set-cdaar!  (lambda (p v) (set-cdr! (caar p) v)))
+(define* set-cdadr!  (lambda (p v) (set-cdr! (cadr p) v)))
+(define* set-cddar!  (lambda (p v) (set-cdr! (cdar p) v)))
+(define* set-cdddr!  (lambda (p v) (set-cdr! (cddr p) v)))
+(define* set-caaaar! (lambda (p v) (set-car! (caaar p) v)))
+(define* set-caaadr! (lambda (p v) (set-car! (caadr p) v)))
+(define* set-caadar! (lambda (p v) (set-car! (cadar p) v)))
+(define* set-caaddr! (lambda (p v) (set-car! (caddr p) v)))
+(define* set-cadaar! (lambda (p v) (set-car! (cdaar p) v)))
+(define* set-cadadr! (lambda (p v) (set-car! (cdadr p) v)))
+(define* set-caddar! (lambda (p v) (set-car! (cddar p) v)))
+(define* set-cadddr! (lambda (p v) (set-car! (cdddr p) v)))
+(define* set-cdaaar! (lambda (p v) (set-cdr! (caaar p) v)))
+(define* set-cdaadr! (lambda (p v) (set-cdr! (caadr p) v)))
+(define* set-cdadar! (lambda (p v) (set-cdr! (cadar p) v)))
+(define* set-cdaddr! (lambda (p v) (set-cdr! (caddr p) v)))
+(define* set-cddaar! (lambda (p v) (set-cdr! (cdaar p) v)))
+(define* set-cddadr! (lambda (p v) (set-cdr! (cdadr p) v)))
+(define* set-cdddar! (lambda (p v) (set-cdr! (cddar p) v)))
+(define* set-cddddr! (lambda (p v) (set-cdr! (cdddr p) v)))
+
+;;>> (1st list)
+;;>> (2nd list)
+;;>> (3rd list)
+;;>> (4th list)
+;;>> (5th list)
+;;>> (6th list)
+;;>> (7th list)
+;;>> (8th list)
+;;>   Quick list accessors -- no checking is done, which makes these
+;;>   slightly faster than the bindings provided by mzlib/list.
+(define* 1st car)
+(define* 2nd cadr)
+(define* 3rd caddr)
+(define* 4th cadddr)
+(define* 5th (lambda (x) (car (cddddr x))))
+(define* 6th (lambda (x) (cadr (cddddr x))))
+(define* 7th (lambda (x) (caddr (cddddr x))))
+(define* 8th (lambda (x) (cadddr (cddddr x))))
+
+;;>> (set-1st! list x)
+;;>> (set-2nd! list x)
+;;>> (set-3rd! list x)
+;;>> (set-4th! list x)
+;;>> (set-5th! list x)
+;;>> (set-6th! list x)
+;;>> (set-7th! list x)
+;;>> (set-8th! list x)
+;;>   Setter functions for the above.
+(define* set-1st! set-car!)
+(define* set-2nd! set-cadr!)
+(define* set-3rd! set-caddr!)
+(define* set-4th! set-cadddr!)
+(define* set-5th! (lambda (p v) (set-car! (cddddr p) v)))
+(define* set-6th! (lambda (p v) (set-car! (cdr (cddddr p)) v)))
+(define* set-7th! (lambda (p v) (set-car! (cddr (cddddr p)) v)))
+(define* set-8th! (lambda (p v) (set-car! (cdddr (cddddr p)) v)))
+
+;;>> (head pair)
+;;>> (tail pair)
+;;>> (set-head! pair x)
+;;>> (set-tail! pair x)
+;;>   Synonyms for `first', `rest', `set-first!', `set-rest!'.
+(define* head first)
+(define* tail rest)
+(define* set-head! set-first!)
+(define* set-tail! set-rest!)
+
+;;>> (set-second! list x)
+;;>> (set-third! list x)
+;;>> (set-fourth! list x)
+;;>> (set-fifth! list x)
+;;>> (set-sixth! list x)
+;;>> (set-seventh! list x)
+;;>> (set-eighth! list x)
+;;>   Defined to allow `setf!' with these mzlib/list functions.  Note that
+;;>   there is no error checking (unlike the accessor functions which are
+;;>   provided by mzlib/list).
+(define* set-second!  set-2nd!)
+(define* set-third!   set-3rd!)
+(define* set-fourth!  set-4th!)
+(define* set-fifth!   set-5th!)
+(define* set-sixth!   set-6th!)
+(define* set-seventh! set-7th!)
+(define* set-eighth!  set-8th!)
+
+;;>> (nth list n)
+;;>> (nthcdr list n)
+;;>   Functions for pulling out the nth element and the nth tail of a list.
+;;>   Note the argument order which is unlike the one in CL.
+(define* nth list-ref)
+(define* (nthcdr l n)
+  (if (zero? n) l (nthcdr (cdr l) (- n 1))))
+
+;;>> (list-set! list n x)
+;;>> (set-nth! list n x)
+;;>   A function to set the nth element of a list, also provided as
+;;>   `set-nth!' to allow using `setf!' with `nth'.
+(define* (list-set! lst index new)
+  (set-car! (nthcdr lst index) new))
+(define* set-nth! list-set!)
+
+;;>> (set-list-ref! list n x)
+;;>> (set-vector-ref! vector n x)
+;;>> (set-string-ref! string n x)
+;;>   These are defined as `list-set!', `vector-set!', and `string-set!', so
+;;>   the accessors can be used with `setf!'.
+(define* set-list-ref!   list-set!)
+(define* set-vector-ref! vector-set!)
+(define* set-string-ref! string-set!)
+
+;;>> (last list)
+;;>> (set-last! list x)
+;;>   Accessing a list's last element, and modifying it.
+(define* (last l)
+  (car (last-pair l)))
+(define* (set-last! l x)
+  (set-car! (last-pair l) x))
+
+;;>> (set-unbox! box x)
+;;>   Allow using `setf!' with `unbox'.  Note: this is an alias for
+;;>   `set-box!' which is an inconsistent name with other Scheme `set-foo!'
+;;>   functions -- the result is that you can also do `(setf! (box foo) x)'
+;;>   and bogusly get the same effect.
+(define* set-unbox! set-box!)
+
+;;>> (set-hash-table-get! table key [default] value)
+;;>   This is defined to be able to `setf!' into a `hash-table-get'
+;;>   accessor.  The form that `setf!' assembles always puts the new value
+;;>   last, but it is still useful to have a default thunk which results in
+;;>   an optional argument in an unusual place (and this argument is ignored
+;;>   by this, which is why it is defined as a macro).  For example:
+;;>     => (define t (make-hash-table))
+;;>     => (inc! (hash-table-get t 'foo))
+;;>     hash-table-get: no value found for key: foo
+;;>     => (inc! (hash-table-get t 'foo (thunk 0)))
+;;>     => (hash-table-get t 'foo)
+;;>     1
+(defsubst*
+  (set-hash-table-get! table key value) (hash-table-put! table key value)
+  (_ table key thunk value)             (hash-table-put! table key value))
+
+;; ----------------------------------------------------------------------------
+;;>>... Utilities
+
+;;>> (eprintf fmt-string args ...)
+;;>   Same as `printf' but it uses `current-error-port'.
+(define* (eprintf . args)
+  (apply fprintf (current-error-port) args))
+
+;;>> concat
+;;>   A shorter alias for `string-append'.
+(define* concat string-append)
+
+;;>> (symbol-append sym ...)
+;;>   Self explanatory.
+(define* (symbol-append . symbols)
+  (string->symbol (apply string-append (map symbol->string symbols))))
+
+;;>> (maptree func tree)
+;;>   Applies given function to a tree made of cons cells, and return the
+;;>   results tree with the same shape.
+(define* (maptree f x)
+  (let loop ([x x])
+    (cond [(list? x) (map loop x)]
+          [(pair? x) (cons (loop (car x)) (loop (cdr x)))]
+          [else (f x)])))
+
+;;>> (map! func list ...)
+;;>   Same as `map' -- but destructively modifies the first list to hold the
+;;>   results of applying the function.  Assumes all lists have the same
+;;>   length.
+(define* (map! f l . rest)
+  (if (null? rest)
+    (let loop ([xs l])
+      (if (null? xs) l (begin (set-car! xs (f (car xs))) (loop (cdr xs)))))
+    (let loop ([xs l] [ls rest])
+      (if (null? xs) l (begin (set-car! xs (apply f (car xs) (map car ls)))
+                              (loop (cdr xs) (map cdr ls)))))))
+
+;;>> (maptree! func tree)
+;;>   Same as `maptree' -- but destructively modifies the list to hold the
+;;>   results of applying the function.
+(define* (maptree! f x)
+  (if (pair? x)
+    (begin (let loop ([x x])
+             (defsubst (do-part get set)
+               (let ([y (get x)])
+                 (cond [(pair? y) (loop y)]
+                       [(not (null? y)) (set x (f y))])))
+             (do-part car set-car!)
+             (do-part cdr set-cdr!))
+           x)
+    (f x))) ; can't be destructive here
+
+;;>> (mappend func list ...)
+;;>> (mappend! func list ...)
+;;>   Common idiom for doing a `(map func list ...)' and appending the
+;;>   results.  `mappend!' uses `append!'.
+(define* (mappend f . ls)
+  (apply append (apply map f ls)))
+(define* (mappend! f . ls)
+  (apply append! (apply map f ls)))
+
+;;>> (mapply func list-of-lists)
+;;>   Apply the given `func' on every list in `list-of-lists' and return the
+;;>   results list.
+(define* (mapply f ls)
+  (map (lambda (args) (apply f args)) ls))
+
+;;>> (negate predicate?)
+;;>   Returns a negated predicate function.
+(define* (negate pred?)
+  (lambda x (not (pred? . x))))
+
+;;>> (position-of x list)
+;;>   Finds `x' in `list' and returns its index.
+(define* (position-of x lst)
+  (let loop ([i 0] [l lst])
+    (cond [(null? l) #f]
+          [(eq? x (car l)) i]
+          [else (loop (add1 i) (cdr l))])))
+
+;;>> (find-if predicate? list)
+;;>   Find and return an element of `list' which satisfies `predicate?', or
+;;>   #f if none found.
+(define* (find-if pred? l)
+  (let loop ([l l])
+    (cond [(null? l) #f]
+          [(pred? (car l)) (car l)]
+          [else (loop (cdr l))])))
+
+;;>> (some predicate? list ...)
+;;>> (every predicate? list ...)
+;;>   Similar to MzScheme's `ormap' and `andmap', except that when multiple
+;;>   lists are given, the check stops as soon as the shortest list ends.
+
+(define* (some pred? l . rest)          ; taken from slib/comlist.scm,
+  (cond [(null? rest)                   ; modified to check only up to the
+         (let mapf ([l l])              ; length of the shortest list.
+           (and (not (null? l))
+                (or (pred? (car l)) (mapf (cdr l)))))]
+        [else (let mapf ([l l] [rest rest])
+                (and (not (or (null? l) (memq '() rest)))
+                     (or (apply pred? (car l) (map car rest))
+                         (mapf (cdr l) (map cdr rest)))))]))
+
+(define* (every pred? l . rest)         ; taken from slib/comlist.scm
+  (cond [(null? rest)                   ; modified to check only up to the
+         (let mapf ([l l])              ; length of the shortest list.
+           (or (null? l)
+               (and (pred? (car l)) (mapf (cdr l)))))]
+        [else (let mapf ([l l] [rest rest])
+                (or (null? l) (if (memq '() rest) #t #f)
+                    (and (apply pred? (car l) (map car rest))
+                         (mapf (cdr l) (map cdr rest)))))]))
+
+;;>> (regexp-quote string)
+;;>   The same as `regexp-quote' from mzlib/string, but faster.
+(define* regexp-quote
+  (let ([re (regexp "[][*?+|().\\$^-]")])
+    (lambda (s) (regexp-replace* re s "\\\\&"))))
+
+;;>> (with-output-to-string thunk)
+;;>   Run `thunk' collecting generated output into a string.
+(define* (with-output-to-string thunk)
+  (let ([str (open-output-string)])
+    (parameterize ([current-output-port str]) (thunk))
+    (get-output-string str)))
+
+;;>> (1+ x)
+;;>> (1- x)
+;;>   Synonyms for `add1' and `sub1'.
+(define* 1+ add1)
+(define* 1- sub1)
+
+;; ----------------------------------------------------------------------------
+;;>>... Multi-dimensional hash-tables
+;; Using lists of `eq?' keys, based on MzScheme's hash tables (MzScheme doesn't
+;; have custom hashes).  Use weak hash-tables so no space is redundantly
+;; wasted.
+
+;;>> (make-l-hash-table)
+;;>> (l-hash-table-get table keys [failure-thunk])
+;;>> (l-hash-table-put! table keys value)
+;;>> (set-l-hash-table-get! table key [default] value)
+;;>   These functions are similar to MzScheme's hash-table functions, except
+;;>   that they work with a list of keys (compared with `eq?').  If it was
+;;>   possible to use a custom equality hash-table, then then would use
+;;>   something like
+;;>     (lambda (x y) (and (= (length x) (length y)) (andmap eq? x y))).
+;;>   The implementation uses a hash-table of hash-tables, all of them weak,
+;;>   since it is supposed to be used for memoization.
+;;>
+;;>   `set-l-hash-table-get!' is defined to work with `setf!'.
+
+;; Internal values, used below.
+(define *nothing* (list "*"))
+(define (return-nothing) *nothing*)
+
+(defsubst l-hash-vector-length 10)
+
+(define* (make-l-hash-table)
+  (make-vector (add1 l-hash-vector-length) *nothing*))
+
+(define* (l-hash-table-get table keys . thunk)
+  (let ([len (length keys)])
+    (let loop ([obj (vector-ref table (min len l-hash-vector-length))]
+               [keys (if (< len l-hash-vector-length) keys (cons len keys))])
+      (cond [(eq? obj *nothing*)
+             (if (null? thunk)
+               (error 'l-hash-table-get "no value found.") ((car thunk)))]
+            [(null? keys) obj]
+            [(not (hash-table? obj))
+             (error 'l-hash-table-get "got to a premature value.")]
+            [else (loop (hash-table-get obj (car keys) return-nothing)
+                        (cdr keys))]))))
+
+(define* (l-hash-table-put! table keys value)
+  (let* ([len (length keys)]
+         [obj (vector-ref table (min len l-hash-vector-length))])
+    (when (eq? obj *nothing*)
+      (set! obj (if (zero? len) value (make-hash-table 'weak)))
+      (vector-set! table (min len l-hash-vector-length) obj))
+    (unless (zero? len)
+      (let loop ([obj obj]
+                 [keys (if (< len l-hash-vector-length) keys (cons len keys))])
+        (cond [(not (hash-table? obj))
+               (error 'l-hash-table-put! "got to a premature value.")]
+              [(null? (cdr keys)) (hash-table-put! obj (car keys) value)]
+              [else (let ([value (hash-table-get
+                                  obj (car keys) return-nothing)])
+                      (when (eq? value *nothing*)
+                        (set! value (make-hash-table 'weak))
+                        (hash-table-put! obj (car keys) value))
+                      (loop value (cdr keys)))])))))
+
+(defsubst*
+  (set-l-hash-table-get! table key value) (l-hash-table-put! table key value)
+  (_ table key thunk value)               (l-hash-table-put! table key value))
+
+;; Simple memoization.
+
+;;>> (memoize func)
+;;>   Return a memoized version of `func'.  Note that if `func' is
+;;>   recursive, it should be arranged for it to call the memoized version
+;;>   rather then call itself directly.
+(define* (memoize f)
+  (let ([table (make-l-hash-table)])
+    (lambda args
+      (l-hash-table-get
+       table args
+       (thunk
+         (let ([r (apply f args)]) (l-hash-table-put! table args r) r))))))
+
+;;>> (memoize! func-name)
+;;>   Changes the given function binding to a memoized version.
+(defsubst* (memoize! f) (set! f (memoize f)))
+
+;; ---------------------------------------------------------------------------
+;;>>... Generic iteration and list comprehension
+;; Idea originated in a post on c.l.s by Based on Phil Bewig (July 2002), but
+;; went light years beyond that.
+
+;;>> (collect [dir] (var base expr) clause ...)
+;;>   Sophisticated iteration syntax.  The iteration is specified by the
+;;>   given clauses, where `var' serves as an accumulator variable that
+;;>   collects a value beginning with `base' and continuing with `expr' --
+;;>   similar to a single binding in a `do' form with a variable, an initial
+;;>   value and an update expression.  But there are much more iteration
+;;>   options than a `do' form: this form supports a generic
+;;>   list-comprehension and related constructs.  Forms that use this
+;;>   construct are:
+;;>
+
+;;>> (loop-for clause ...)
+;;>   Use when no value collection is needed, and the default for
+;;>   expressions is to do them instead of using them as a filter.
+;;>   Implemented as:
+;;>     (collect => (acc (void) acc) do clause ...)
+(defsubst* (loop-for clause ...)
+  (collect => (acc (void) acc) do clause ...))
+;;>
+
+;;>> (list-of expr clause ...)
+;;>   Implemented as:
+;;>     (reverse! (collect (acc '() (cons expr acc)) clause ...))
+(defsubst* (list-of expr clause ...)
+  (reverse! (collect (acc '() (cons expr acc)) clause ...)))
+;;>
+
+;;>> (sum-of expr clause ...)
+;;>   Implemented as:
+;;>     (collect (acc 0 (+ expr acc)) clause ...)
+(defsubst* (sum-of expr clause ...)
+  (collect (acc 0 (+ expr acc)) clause ...))
+;;>
+
+;;>> (product-of expr clause ...)
+;;>   Implemented as:
+;;>     (collect (acc 1 (* expr acc)) clause ...)
+(defsubst* (product-of expr clause ...)
+  (collect (acc 1 (* expr acc)) clause ...))
+;;>
+
+;;>> (count-of clause ...)
+;;>   Only count matching cases, implemented as:
+;;>     (sum-of 1 clause ...)
+(defsubst* (count-of clause ...)
+  (sum-of 1 clause ...))
+;;>
+
+;;>   Each clause is either:
+;;>   * (v <- ...):     a binding generator clause;
+;;>   * (v <- ... and v <- ...): parallel generator clauses;
+;;>   * (v is is-expr): bind `v' to the result of `is-expr';
+;;>   * while expr:     a `while' keyword followed by an expression will
+;;>                     abort the whole loop if that expression evaluates to
+;;>                     #f;
+;;>   * until expr:     an `until' keyword followed by an expression will
+;;>                     abort the whole loop if that expression evaluates to
+;;>                     a non-#f value;
+;;>   * when ...:       filter by the following expressions -- if an
+;;>                     expression evaluates to #f, stop processing this
+;;>                     iteration (default for all macros except for
+;;>                     `loop-for');
+;;>   * unless ...:     filter by the negation of the following expressions;
+;;>   * do ...:         execute the following expressions, used for side
+;;>                     effects (default for the `loop-for' macro);
+;;>   * expr:           expression is used according to the current mode set
+;;>                     by a `when', `unless', or `do', keyword that
+;;>                     precedes it.
+;;>   The effect of this form is to iterate each generator variable
+;;>   according to generating `<-' clauses (see below for these) and
+;;>   parallel clauses, and evaluate the `expr' with each combination, which
+;;>   composes a result out of iteration-bound values and an accumulated
+;;>   result.  Generation is done in a nested fashion, where the rightmost
+;;>   generator spin fastest.  Parallel generators (specified with an infix
+;;>   `and') make all iterations happen simultaneously, ending as soon as
+;;>   the first one ends.  An `is' clause is used for binding arbitrary
+;;>   variables, a `do' clause is used to execute code for general
+;;>   side-effects, and other clauses are used to filter results before
+;;>   continuing down the clause list.  Each clause can use variables bound
+;;>   by previous clauses, and the `expr' can use all bound variables as
+;;>   well as the given accumulator variable.
+;;>
+;;>   An optional first token can be used to specify the direction which is
+;;>   used to accumulate the result.  It can be one of these two tokens:
+;;>   `<=': A "backward" collection, the default (similar to `foldl');
+;;>   `=>': A "forward" collection (similar to `foldr').
+;;>   The default "backward" direction works by generating an accumulator
+;;>   carrying loop, as in this code (this code is for demonstration, not
+;;>   what `collect' creates):
+;;>     (let loop ([x foo] [acc '()])
+;;>       (if (done? x) acc (loop (next x) (cons (value x) acc))))
+;;>   which is a common Scheme idiom for such operations.  The problem is
+;;>   that this accumulation happens in reverse -- requiring reversing the
+;;>   final result (which is done by the `list-of' macro).  A "forward"
+;;>   direction does a naive recursive loop:
+;;>     (let loop ([x foo])
+;;>       (if (done? x) '() (cons (value x) (loop (next x)))))
+;;>   collecting values in the correct order, but the problem is that it
+;;>   keeps a computation context which makes memory consumption
+;;>   inefficient.  The default style is usually preferred, since reversing
+;;>   a list is a cheap operation, but it is not possible when infinite
+;;>   lists (streams) are used since it is impossible to reverse them.  In
+;;>   these cases, the "forward" style should be used, but the `expr' must
+;;>   take care not to evaluate the iteration "variable" immediately, using
+;;>   `delay' or a similar mechanism (this "variable" is not bound to a
+;;>   value but substituted with an expression (a symbol macro)).  For
+;;>   example, here's a quick lazy list usage:
+;;>     => (defsubst (lcons x y) (delay (cons x y)))
+;;>     => (define (lcar s) (car (force s)))
+;;>     => (define (lcdr s) (cdr (force s)))
+;;>     => (define x (collect (_ '() (lcons x _)) (x <- 0 ..)))
+;;>     ; loops indefinitely
+;;>     => (define x (collect => (_ '() (lcons x _)) (x <- 0 ..)))
+;;>     => (lcar (lcdr (lcdr x)))
+;;>     2
+;;>   Note that the `loop-for' macro uses a "forward" direction, but this is
+;;>   only because it is slightly faster since it doesn't require an extra
+;;>   binding.
+;;>   [The direction can be changed for a single part by using a "<-!"
+;;>   keyword instead of "<-", but this is an experimental feature since I
+;;>   don't know if it's actually useful for anything.  Do not try to mix
+;;>   this with the `while' and `until' keywords which are implemented
+;;>   differently based on the direction.]
+;;>
+
+(defsyntax* (collect stx)
+  (define (split id stxs)
+    (let loop ([stxs '()] [stxss '()]
+               [l (if (syntax? stxs) (syntax->list stxs) stxs)])
+      (cond [(null? l) (reverse! (cons (reverse! stxs) stxss))]
+            [(and (identifier? (car l)) (module-identifier=? id (car l)))
+             (loop '() (cons (reverse! stxs) stxss) (cdr l))]
+            [else (loop (cons (car l) stxs) stxss (cdr l))])))
+  (define (gen-loop generate add-aux! &optional hacked)
+    (with-syntax ([generate generate]
+                  [(cur step done? value)
+                   (generate-temporaries '(cur step done? value))])
+      (add-aux! #'((cur step done? value) (apply values generate)))
+      (with-syntax ([value #'(if value (value cur) cur)])
+        (with-syntax ([value (if hacked
+                               #`(let ([r value]) (set! #,hacked r) r)
+                               #'value)])
+          #'(cur cur (step cur) (and done? (done? cur)) value)))))
+  (define (gen var args add-aux! hack-var! &optional seq?)
+    (define (hack!) (when (and seq? hack-var!) (hack-var! var)))
+    (define (gen1 arg) (if seq? arg (gen-loop arg add-aux!)))
+    (with-syntax ([v var])
+      (syntax-case args (then until while .. ..<)
+;;>   Generator forms are one of the following ("..", "then", "until",
+;;>   "while" are literal tokens), see below for what values are generated:
+;;>   * (v <- sequence):
+;;>     iterate `v' on values from `sequence';
+        [(arg)            (gen1 #'(collect-iterator arg))]
+;;>   * (v <- 1st [2nd] .. [last]):
+;;>     iterate on an enumerated range, including last element of range;
+        [(a b ..  z)      (gen1 #'(collect-numerator a b  z        ))]
+        [(a b ..   )      (gen1 #'(collect-numerator a b  #f       ))]
+        [(a   ..  z)      (gen1 #'(collect-numerator a #f z        ))]
+        [(a   ..   )      (gen1 #'(collect-numerator a #f #f       ))]
+;;>   * (v <- 1st [2nd] ..< last):
+;;>     iterate on an enumerated range, excluding last element of range;
+        [(a b ..< z)      (gen1 #'(collect-numerator a b  z  '<    ))]
+        [(a   ..< z)      (gen1 #'(collect-numerator a #f z  '<    ))]
+;;>   * (v <- 1st [2nd] .. while last):
+;;>     iterate on an enumerated range, excluding last element of range;
+        [(a b .. while z) (gen1 #'(collect-numerator a b  z  'while))]
+        [(a   .. while z) (gen1 #'(collect-numerator a #f z  'while))]
+;;>   * (v <- 1st [2nd] .. until last):
+;;>     iterate on an enumerated range, excluding last element of range;
+        [(a b .. until z) (gen1 #'(collect-numerator a b  z  'until))]
+        [(a   .. until z) (gen1 #'(collect-numerator a #f z  'until))]
+;;>   * (v <- x then next-e [{while|until} cond-e]):
+;;>     start with the `x' expression, continue with the `next-e' expression
+;;>     (which can use `v'), do this while/until `cond-e' is true if a
+;;>     condition is given;
+        [(arg then next) (hack!)
+         (if seq? ; making seq? => convert to composable funcs
+           #'(list arg (lambda (v) next) #f #f)
+           #'(v arg next #f v))]
+        [(arg then next while cond) (hack!)
+         (if seq?
+           #'(list arg (lambda (v) next) (lambda (v) (not cond)) #f)
+           #'(v arg next (not cond) v))]
+        [(arg then next until cond) (hack!)
+         (if seq?
+           #'(list arg (lambda (v) next) (lambda (v) cond) #f)
+           #'(v arg next cond v))]
+;;>   * (v <- x {while|until} cond-e):
+;;>     repeat using the `x' expression while/until `cond-e' is true;
+        [(arg while cond) (hack!)
+         (if seq?
+           #'(list #f #f #f (lambda (_) (if cond arg collect-final)))
+           #'(v #f #f #f (begin (set! v arg) (if cond v collect-final))))]
+        [(arg until cond) (hack!)
+         (if seq?
+           #'(list #f #f #f (lambda (_) (if cond collect-final arg)))
+           #'(v #f #f #f (begin (set! v arg) (if cond collect-final v))))]
+;;>   * (v <- func arg ...):
+;;>     applies `func' to `arg ...', the result is expected to be some
+;;>     "iterator value" which is used to do the iteration -- iteration
+;;>     values are created by `collect-iterator' and `collect-numerator',
+;;>     see below for their description and return values.
+;;>   * (v <- gen1 <- gen2 <- ...):
+;;>     generator clauses can have multiple parts specified by more `<-'s,
+;;>     all of them will run sequentially;
+        [(f x ...)
+         (let ([argss (split #'<- args)])
+           (if (= 1 (length argss))
+             (gen1 #'(f x ...))
+             (let ([hacked #f])
+               (with-syntax
+                   ([(gen ...)
+                     (map (lambda (as)
+                            (gen var as add-aux!
+                                 (lambda (v) (set! hacked v) (hack-var! v))
+                                 #t))
+                          argss)])
+                 (gen-loop #'(sequential-generators gen ...)
+                           add-aux! hacked)))))])))
+  (define-values (acc base0 expr clauses fwd?)
+    (syntax-case stx (<= =>)
+      [(_ <= (acc base expr) clause ...)
+       (values #'acc #'base #'expr #'(clause ...) #f)]
+      [(_ => (acc base expr) clause ...)
+       (values #'acc #'base #'expr #'(clause ...) #t)]
+      [(_ (acc base expr) clause ...)
+       (values #'acc #'base #'expr #'(clause ...) #f)]))
+  (define need-break? #f)
+  (define loop-body
+    (let c-loop ([base base0] [clauses clauses] [mode 'when] [rev? #f])
+      (syntax-case clauses (<- <-! is do when unless while until)
+        [() (if (if rev? (not fwd?) fwd?)
+              #`(letsubst ([#,acc #,base]) #,expr)
+              expr)]
+        [((var <-! arg ...) rest ...)
+         (c-loop base #'((var <- arg ...) rest ...) mode 'rev!)]
+        [((var <- arg ...) rest ...)
+;;>   * (v1 <- gen1 ... and v2 <- gen2 ...):
+;;>     finally, an infix `and' specifies parallel generators, binding
+;;>     several variables.
+         (let ([rev? (if (eq? 'rev! rev?) #t #f)]
+               [gens (split #'and #'(var <- arg ...))]
+               [loop-id (car (generate-temporaries '(loop)))]
+               [aux '()] [hacked-vars '()])
+           (for-each
+            (lambda (g)
+              (syntax-case g (<-)
+                [(var <- arg ...) (identifier? #'var) #f]
+                [_ (raise-syntax-error
+                    #f "expected a generator clause" stx g)]))
+            gens)
+           (with-syntax ([((var <- arg ...) ...) gens])
+             ;; Hack needed: generator variables are defined later in the loop
+             ;; just before their code, after the place where the expression
+             ;; appear in setup code.  This is usually not a problem since
+             ;; functions are applied the same, but when using expression
+             ;; iteration (`then') in a sequential range which is in
+             ;; simultaneous iteration where real expressions are turned to
+             ;; functions (which are define before variables the might
+             ;; reference).  This could be eliminated, restricting expressions
+             ;; from referencing variables that are bound in parallel, but this
+             ;; is usually the power of using expression (which can be claimed
+             ;; redundant).  The hack is doing this:
+             ;;  (let ([x #f] ...)
+             ;;    ... (let ([x (let ([r value]) (set! x r) r)])))
+             ;; The problem is that the extra junk makes it run twice slower,
+             ;; so do this only for bindings that has the above scenario
+             ;; (parallel of sequential of expression generators).  To test it,
+             ;; do this:
+             ;;  (list-of (list c x y)
+             ;;    (c <- 1 .. 5 and x <- 1 <- 'x then y
+             ;;                 and y <- 1 <- 'y then x))
+             ;; but this always works:
+             ;;  (list-of (list c x y)
+             ;;    (c <- 1 .. 5 and x <- 'x then y and y <- 'y then x))
+             (with-syntax ([((cur fst next done? value) ...)
+                            (map (lambda (v as)
+                                   (gen v as
+                                        (lambda (a) (set! aux (cons a aux)))
+                                        (lambda (v)
+                                          (set! hacked-vars
+                                                (cons v hacked-vars)))))
+                                 (syntax->list #'(var ...))
+                                 (syntax->list #'((arg ...) ...)))]
+                           [loop loop-id]
+                           [(aux ...) (reverse aux)] [acc acc] [base base])
+               (with-syntax
+                   ([body
+                     (let* ([fwd? (if rev? (not fwd?) fwd?)]
+                            [return (if fwd? #'base #'acc)]
+                            [body (if fwd?
+                                    (c-loop #`(#,loop-id next ...)
+                                            #'(rest ...) mode rev?)
+                                    #`(loop next ...
+                                            #,(c-loop #'acc #'(rest ...)
+                                                      mode rev?)))])
+                       #`(let-values (aux ...)
+                           (let loop ([cur fst] ...
+                                      #,@(if fwd? #'() #'((acc base))))
+                             (if (or done? ...)
+                               #,return
+                               #,(let vloop ([vars (syntax->list #'(var ...))]
+                                             [values (syntax->list
+                                                      #'(value ...))])
+                                   (if (null? vars)
+                                     body
+                                     #`(let ([#,(car vars) #,(car values)])
+                                         (if (eq? #,(car vars) collect-final)
+                                           #,return
+                                           #,(vloop (cdr vars)
+                                                    (cdr values))))))))))])
+                 (if (null? hacked-vars)
+                   #'body
+                   (with-syntax ([(var ...) (reverse hacked-vars)])
+                     #'(let ([var #f] ...) body)))))))]
+        [((var is is-expr) rest ...)
+         #`(let ([var is-expr]) #,(c-loop base #'(rest ...) mode rev?))]
+        [(while cond rest ...)
+         #`(if cond
+             #,(c-loop base #'(rest ...) mode rev?)
+             #,(if (if rev? (not fwd?) fwd?)
+                 base0 (begin (set! need-break? #t) #`(break #,base))))]
+        [(until cond rest ...)
+         #`(if cond
+             #,(if (if rev? (not fwd?) fwd?)
+                 base0 (begin (set! need-break? #t) #`(break #,base)))
+             #,(c-loop base #'(rest ...) mode rev?))]
+        [(do     rest ...) (c-loop base #'(rest ...) 'do     rev?)]
+        [(when   rest ...) (c-loop base #'(rest ...) 'when   rev?)]
+        [(unless rest ...) (c-loop base #'(rest ...) 'unless rev?)]
+        [(expr rest ...)
+         (with-syntax ([cont (c-loop base #'(rest ...) mode rev?)])
+           (case mode
+             [(when)   #`(if expr cont #,base)]
+             [(unless) #`(if expr #,base cont)]
+             [(do)     #`(begin expr cont)]))])))
+  (if need-break?
+    #`(let/ec break #,loop-body) loop-body))
+;;>
+
+(define (sequential-generators gen . rest)
+  (let-values ([(new) #f] [(fst step done? value) (values . gen)])
+    (define (next!)
+      (and (pair? rest)
+           (begin (set! gen   (car rest)) (set! rest  (cdr rest))
+                  (set! fst   (1st gen))  (set! step  (2nd gen))
+                  (set! done? (3rd gen))  (set! value (4th gen))
+                  #t)))
+    (list fst
+          (lambda (x)
+            (let ([r (step (if new (begin0 new (set! new #f)) x))])
+              (if (and done? (done? r)) (if (next!) fst collect-final) r)))
+          (lambda (x)
+            (and (null? rest)
+                 (or (eq? x collect-final) (and done? (done? x)))))
+          (lambda (x)
+            (let ([r (if value (value x) x)])
+              (if (eq? r collect-final)
+                (let* ([n? (next!)] [r (and n? (if value (value fst) fst))])
+                  (set! new fst)
+                  (if (or (not n?) (done? fst)) collect-final r))
+                r))))))
+
+(define (function->iterator f &optional done? include-last?)
+  (define arity
+    (cond [(procedure-arity-includes? f 0) 0]
+          [(procedure-arity-includes? f 1) 1]
+          [else (error 'function->iterator
+                       "don't know how to iterate over function ~e" f)]))
+  (when (and done? include-last?)
+    (set! done?
+          (let ([d? done?])
+            (lambda (x) (when (d? x) (set! f (lambda _ collect-final))) #f))))
+  (when (eq? 1 arity) (set! f (function-iterator f collect-final)))
+  (list (void) void #f
+        (if done?
+          (lambda (_)
+            (let ([x (f)])
+              (if (or (eq? x collect-final) (done? x)) collect-final x)))
+          (lambda (_) (f)))))
+
+;;>   Iteration is possible on one of the following sequence values:
+(define* (collect-iterator seq)
+  (define (out-of-range r) (lambda (x) (<= r x)))
+  (cond
+;;>   * list: iterate over the list's element;
+   [(list? seq) (list seq cdr null? car)]
+;;>   * vector: iterate over the vector's elements;
+   [(vector? seq) (list 0 add1 (out-of-range (vector-length seq))
+                        (lambda (i) (vector-ref seq i)))]
+;;>   * string: iterate over characters in the string;
+   [(string? seq) (list 0 add1 (out-of-range (string-length seq))
+                        (lambda (i) (string-ref seq i)))]
+;;>   * integer n: iterate on values from 0 to n-1;
+   [(integer? seq) (list 0 add1 (out-of-range seq) #f)]
+;;>   * procedure f:
+   [(procedure? seq)
+;;>     - if f accepts zero arguments, begin with (f) and iterate by
+;;>       re-applying (f) over and over, so the only way to end this
+;;>       iteration is by returning `collect-final' (see below);
+;;>     - otherwise, if f accepts one argument, it is taken as a generator
+;;>       function: it is passed a one-argument procedure `yield' which can
+;;>       be used to suspend its execution returning the given value, and it
+;;>       will be continued when more values are required (see
+;;>       `function-iterator' below);
+    (function->iterator seq)]
+;;>   * hash-table: iterate over key-value pairs -- this is done with a
+;;>     generator function:
+;;>       (lambda (yield)
+;;>         (hash-table-for-each seq (lambda (k v) (yield (cons k v)))))
+   [(hash-table? seq)
+    (collect-iterator (lambda (yield)
+                        (hash-table-for-each
+                         seq (lambda (k v) (yield (cons k v))))))]
+;;>   * other values: repeated infinitely.
+   [else (list seq identity #f #f)]))
+;;>   Note that iteration over non-lists is done efficiently, iterating over
+;;>   a vector `v' is better than iterating over `(vector->list v)'.
+;;>
+
+;;>   Enumeration is used whenever a ".." token is used to specify a range.
+;;>   There are different enumeration types based on different input types,
+;;>   and all are modified by the token used:
+;;>   * "..": a normal inclusive range;
+;;>   * "..<": a range that does not include the last element;
+;;>   * ".. while": a range that continues while a predicate is true;
+;;>   * ".. until": a range that continues until a predicate is true.
+;;>   The "..<" token extends to predicates in the expected way: the element
+;;>   that satisfies the predicate is the last one and it is not included in
+;;>   the enumeration -- unlike "..".
+;;>   These are the possible types that can be used with an enumeration:
+(define* (collect-numerator from second to &optional flag)
+  (define (check-type pred? &optional not-to)
+    (and (pred? from) (or (not second) (pred? second))
+         (or not-to (not to) (pred? to))))
+  (define (to->pred)
+    (and to (let ([to (if (and (procedure? to)
+                               (procedure-arity-includes? to 1))
+                        to (lambda (x) (equal? x to)))])
+              (if (eq? 'while flag) (negate to) to))))
+  (when (and (memq flag '(while until))
+             (not (and (procedure? to) (procedure-arity-includes? to 1))))
+    (set! to (lambda (x) (equal? x to))))
+;;>   * num1 [num2] .. [num3]: go from num1 to num3 in num3 in num2-num1
+;;>     steps, if num2 is not given then use +1/-1 steps, if num3 is not
+;;>     given don't stop;
+;;>   * num1 [num2] .. pred: go from num1 by num2-num1 steps (defaults to
+;;>     1), up to the number that satisfies the given predicate;
+  (cond [(check-type number?)
+         (let* ([step
+                 (cond [second (- second from)]
+                       [(and (number? to) (> from to)) -1]
+                       [else 1])]
+                [gt?
+                 (case flag
+                   [(#f) (if (positive? step) > <)]
+                   [(<)  (if (positive? step) >= <=)]
+                   [else (error 'collect-numerator "internal error")])])
+           (list from
+                 (lambda (x) (+ x step))
+                 (if (number? to) (lambda (x) (gt? x to)) #f)
+                 #f))]
+;;>   * char1 [char2] .. [char3/pred]: the same as with numbers, but on
+;;>     character ranges;
+        [(check-type char? #t)
+         (let ([numerator (collect-numerator
+                           (char->integer from)
+                           (and second (char->integer second))
+                           (cond [(char? to) (char->integer to)]
+                                 [(and (procedure? to)
+                                       (procedure-arity-includes? to 1))
+                                  (compose to integer->char)]
+                                 [else to])
+                           flag)])
+           (list (1st numerator) (2nd numerator) (3rd numerator)
+                 integer->char))]
+;;>   * func .. [pred/x]: use `func' the same way as in an iterator above,
+;;>     use `pred' to identify the last element, if `pred' is omitted repeat
+;;>     indefinitely;
+        [(and (procedure? from) (not second))
+         (let ([to (to->pred)])
+           (function->iterator from to (and (not flag) to)))]
+;;>   * fst [next] .. [pred]: start with `fst', continue by repeated
+;;>     applications of the `next' function on it, and use `pred' to
+;;>     identify the last element, if `pred' is omitted repeat indefinitely,
+;;>     if `next' is omitted repeat `fst', and if both `fst' and `next' are
+;;>     numbers or characters then use their difference for stepping.  (Note
+;;>     that to repeat a function value you should use `identity' as for
+;;>     `next' or the function will be used as described above.)
+        [else
+         (cond [(and (number? from) (number? second))
+                (let ([d (- second from)]) (set! second (lambda (x) (+ x d))))]
+               [(not second) (set! second identity)]
+               [(not (and (procedure? second)
+                          (procedure-arity-includes? second 1)))
+                (error 'collect-numerator
+                       "don't know how to enumerate ~e ~e .. ~e"
+                       from second to)])
+         (if (not to)
+           (list from second #f #f)
+           (let ([to (to->pred)])
+             (if (or flag (not to))
+               (list from second to #f)
+               (let ([almost-done? (to from)] [done? #f])
+                 (list from (lambda (x)
+                              (if almost-done?
+                                (set! done? #t)
+                                (let ([next (second x)])
+                                  (when (to next) (set! almost-done? #t))
+                                  next)))
+                       (lambda (_) done?) #f)))))]))
+;;>
+
+;;>   Here is a long list of examples for clarification, all using
+;;>   `list-of', but the generalization should be obvious:
+;;>     => (list-of x [x <- '(1 2 3)])
+;;>     (1 2 3)
+;;>     => (list-of (list x y) [x <- '(1 2 3)] [y <- 1 .. 2])
+;;>     ((1 1) (1 2) (2 1) (2 2) (3 1) (3 2))
+;;>     => (list-of (format "~a~a~a" x y z)
+;;>                 [x <- '(1 2)] [y <- #(a b)] [z <- "xy"])
+;;>     ("1ax" "1ay" "1bx" "1by" "2ax" "2ay" "2bx" "2by")
+;;>     => (list-of (+ x y) [x <- '(1 2 3)] [y <- 20 40 .. 100])
+;;>     (21 41 61 81 101 22 42 62 82 102 23 43 63 83 103)
+;;>     => (list-of (+ x y) [x <- '(1 2 3) and y <- 20 40 .. 100])
+;;>     (21 42 63)
+;;>     => (list-of y [x <- 0 .. and y <- '(a b c d e f g h i)] (even? x))
+;;>     (a c e g i)
+;;>     => (list-of y [x <- 0 .. and y <- '(a b c d e f g h i)]
+;;>          when (even? x) do (echo y))
+;;>     a
+;;>     c
+;;>     e
+;;>     g
+;;>     i
+;;>     (a c e g i)
+;;>     => (list-of (list x y) [x <- 3 and y <- 'x])
+;;>     ((0 x) (1 x) (2 x))
+;;>     => (list-of (list x y) [x <- 3 and y <- 'x ..])
+;;>     ((0 x) (1 x) (2 x))
+;;>     => (list-of (list x y) [x <- #\0 .. and y <- '(a b c d)])
+;;>     ((#\0 a) (#\1 b) (#\2 c) (#\3 d))
+;;>     => (list-of x [x <- '(1 2 3) then (cdr x) until (null? x)])
+;;>     ((1 2 3) (2 3) (3))
+;;>     => (list-of (list x y)
+;;>          [x <- '(1 2 3) then (cdr y) until (null? x) and
+;;>           y <- '(10 20 30) then (cdr x) until (null? y)])
+;;>     (((1 2 3) (10 20 30)) ((20 30) (2 3)) ((3) (30)))
+;;>     => (list-of x [x <- (lambda (yield) 42)])
+;;>     ()
+;;>     => (list-of x [x <- (lambda (yield) (yield 42))])
+;;>     (42)
+;;>     => (list-of x [x <- (lambda (yield) (yield (yield 42)))])
+;;>     (42 42)
+;;>     => (list-of x [x <- (lambda (yield)
+;;>                           (for-each (lambda (x) (echo x) (yield x))
+;;>                                     '(3 2 1 0)))])
+;;>     3
+;;>     2
+;;>     1
+;;>     0
+;;>     (3 2 1 0)
+;;>     => (list-of x [x <- (lambda (yield)
+;;>                           (for-each (lambda (x) (echo x) (yield (/ x)))
+;;>                                     '(3 2 1 0)))])
+;;>     3
+;;>     2
+;;>     1
+;;>     0
+;;>     /: division by zero
+;;>     => (list-of x
+;;>          [c <- 3 and
+;;>           x <- (lambda (yield)
+;;>                  (for-each (lambda (x) (echo x) (yield (/ x)))
+;;>                            '(3 2 1 0)))])
+;;>     3
+;;>     2
+;;>     1
+;;>     (1/3 1/2 1)
+;;>     => (define h (make-hash-table))
+;;>     => (set! (hash-table-get h 'x) 1
+;;>              (hash-table-get h 'y) 2
+;;>              (hash-table-get h 'z) 3)
+;;>     => (list-of x [x <- h])
+;;>     ((y . 2) (z . 3) (x . 1))
+;;>     => (list-of x [x <- 4 <- 4 .. 0 <- '(1 2 3)])
+;;>     (0 1 2 3 4 3 2 1 0 1 2 3)
+;;>     => (list-of (list x y)
+;;>          [x <- 1 .. 3 <- '(a b c) and
+;;>           y <- (lambda (y) (y 'x) (y 'y)) <- "abcd"])
+;;>     ((1 x) (2 y) (3 #\a) (a #\b) (b #\c) (c #\d))
+;;>
+;;>   Note that parallel iteration is useful both for enumerating results,
+;;>   and for walking over a finite prefix of an infinite iteration.
+;;>
+;;>   The following is an extensive list of various ranges:
+;;>     => (list-of x [x <- 0 .. 6])
+;;>     (0 1 2 3 4 5 6)
+;;>     => (list-of x [x <- 0 ..< 6])
+;;>     (0 1 2 3 4 5)
+;;>     => (list-of x [x <- 0 .. -6])
+;;>     (0 -1 -2 -3 -4 -5 -6)
+;;>     => (list-of x [x <- 0 ..< -6])
+;;>     (0 -1 -2 -3 -4 -5)
+;;>     => (list-of x [x <- 0 2 .. 6])
+;;>     (0 2 4 6)
+;;>     => (list-of x [x <- 0 2 ..< 6])
+;;>     (0 2 4)
+;;>     => (list-of x [x <- 0 -2 ..< -6])
+;;>     (0 -2 -4)
+;;>     => (list-of x [x <- #\a .. #\g])
+;;>     (#\a #\b #\c #\d #\e #\f #\g)
+;;>     => (list-of x [x <- #\a ..< #\g])
+;;>     (#\a #\b #\c #\d #\e #\f)
+;;>     => (list-of x [x <- #\a #\c .. #\g])
+;;>     (#\a #\c #\e #\g)
+;;>     => (list-of x [x <- #\a #\c ..< #\g])
+;;>     (#\a #\c #\e)
+;;>     => (list-of x [x <- #\g #\e ..< #\a])
+;;>     (#\g #\e #\c)
+;;>     => (list-of x [x <- 6 5 .. zero?])
+;;>     (6 5 4 3 2 1 0)
+;;>     => (list-of x [x <- 6 5 ..< zero?])
+;;>     (6 5 4 3 2 1)
+;;>     => (list-of x [x <- 6 5 .. until zero?])
+;;>     (6 5 4 3 2 1)
+;;>     => (list-of x [x <- 6 5 .. while positive?])
+;;>     (6 5 4 3 2 1)
+;;>     => (list-of x [x <- '(1 2 3) cdr .. null?])
+;;>     ((1 2 3) (2 3) (3) ())
+;;>     => (list-of x [x <- '(1 2 3) cdr ..< null?])
+;;>     ((1 2 3) (2 3) (3))
+;;>     => (list-of x [x <- '(1 2 3) cdr .. until null?])
+;;>     ((1 2 3) (2 3) (3))
+;;>     => (list-of x [x <- '(1 2 3) cdr .. while pair?])
+;;>     ((1 2 3) (2 3) (3))
+;;>     => (list-of x [x <- #\a #\d .. while char-alphabetic?])
+;;>     (#\a #\d #\g #\j #\m #\p #\s #\v #\y)
+;;>     => (list-of x [x <- #\a #\d .. char-alphabetic?])
+;;>     (#\a)
+;;>     => (list-of x [x <- #\a #\d ..< char-alphabetic?])
+;;>     ()
+;;>     => (list-of x [x <- 0 1 .. positive?])
+;;>     (0 1)
+;;>     => (list-of x [x <- 1 2 .. positive?])
+;;>     (1)
+;;>     => (list-of x [x <- 1 2 ..< positive?])
+;;>     ()
+;;>     => (list-of x [x <- '(a b c) ..< pair?])
+;;>     ()
+;;>     => (list-of x [x <- '(a b c) .. pair?])
+;;>     ((a b c))
+;;>     => (list-of x [x <- '(a b c) cdr .. pair?])
+;;>     ((a b c))
+;;>     => (list-of x [x <- read-line .. eof-object?])
+;;>     ...list of remaining input lines, including #<eof>...
+;;>     => (list-of x [x <- read-line ..< eof-object?])
+;;>     ...list of remaining input lines, excluding #<eof>...
+;;>     => (list-of x [x <- read-line ..< eof])
+;;>     ...the same...
+;;>
+
+;;>> collect-final
+;;>   This value can be used to terminate iterations: when it is returned as
+;;>   the iteration value (not the state), the iteration will terminate
+;;>   without using it.
+(define* collect-final (list "*"))
+
+;;>> (function-iterator f [final-value])
+;;>   `f' is expected to be a function that can accept a single input value.
+;;>   It is applied on a `yield' function that can be used to return a value
+;;>   at any point.  The return value is a function of no argument, which
+;;>   returns on every application values that were passed to `yield'.  When
+;;>   `f' terminates, the final result of the iterated return value depends
+;;>   on the optional argument -- if none was supplied, the actual return
+;;>   value is returned, if a thunk was supplied it is applied for a return
+;;>   value, and if any other value was given it is returned.  After
+;;>   termination, calling the iterated function again results in an error.
+;;>   (The supplied `yield' function returns its supplied value to the
+;;>   calling context when resumed.)
+;;>     => (define (foo yield) (yield 1) (yield 2) (yield 3))
+;;>     => (define bar (function-iterator foo))
+;;>     => (list (bar) (bar) (bar))
+;;>     (1 2 3)
+;;>     => (bar)
+;;>     3
+;;>     => (bar)
+;;>     function-iterator: iterated function #<procedure:foo> exhausted.
+;;>     => (define bar (function-iterator foo 'done))
+;;>     => (list (bar) (bar) (bar) (bar))
+;;>     (1 2 3 done)
+;;>     => (bar)
+;;>     function-iterator: iterated function #<procedure:foo> exhausted.
+;;>     => (define bar (function-iterator foo (thunk (error 'foo "done"))))
+;;>     => (list (bar) (bar) (bar))
+;;>     (1 2 3)
+;;>     => (bar)
+;;>     foo: done
+(define* (function-iterator f . finally)
+  (define ret #f)
+  (define (done)
+    (set! cnt (thunk (error 'function-iterator
+                            "iterated function ~e exhausted." f))))
+  (define cnt
+    (cond [(null? finally) (thunk (let ([r (f yield)]) (done) (ret r)))]
+          [(and (procedure? (car finally))
+                (procedure-arity-includes? (car finally) 0))
+           (thunk (f yield) (done) (ret ((car finally))))]
+          [else (thunk (f yield) (done) (ret (car finally)))]))
+  (define (yield v) (let/cc k (set! cnt (thunk (k v))) (ret v)))
+  (thunk (let/cc ret1 (set! ret ret1) (cnt))))
+
+;;>> (collect-iterator sequence)
+;;>> (collect-numerator from second to [flag])
+;;>   These functions are used to construct iterations.  `collect-iterator'
+;;>   is the function used to create iteration over a sequence object and it
+;;>   is used by `(x <- sequence)' forms of `collect'.  `collect-numerator'
+;;>   create range iterations specified with `(x <- from second to)' forms,
+;;>   where unspecified values are passed as `#f', and the flag argument is
+;;>   a `<', `while', or `until' symbol for ranges specified with "..<",
+;;>   ".. while" and ".. until".  These functions are available for
+;;>   implementing new iteration constructs, for example:
+;;>     => (define (in-values producer)
+;;>          (collect-iterator (call-with-values producer list)))
+;;>     => (list-of x [x <- in-values (thunk (values 1 2 3))])
+;;>     (1 2 3)
+;;>   The return value that specifies an iteration is a list of four items:
+;;>   1. the initial state value;
+;;>   2. a `step' function that gets a state and returns the next one;
+;;>   3. a predicate for the end state (#f for none);
+;;>   4. a function that computes a value from the state variable.
+;;>   But usually the functions are more convenient.
+;;>
+;;>   Finally, remember that you can return `collect-final' as the value to
+;;>   terminate any iteration.
+
+;; ----------------------------------------------------------------------------
+;;>>... Convenient printing
+
+;;>> *echo-display-handler* [h]
+;;>> *echo-write-handler*   [h]
+;;>   Currently, MzScheme's I/O can be customized only on a per port basis.
+;;>   This means that installing the object printing generic later will
+;;>   change only the standard ports, and for new ports a handleres should
+;;>   always be installed.  This means that `echos' will not work with
+;;>   objects since it uses a new port -- so use these parameters to allow
+;;>   to change them later to the Swindle printer.
+(define* *echo-display-handler* (make-parameter display))
+(define* *echo-write-handler* (make-parameter write))
+
+;;>> (echo arg ...)
+;;>   This is a handy printout utility that offers an alternative approach
+;;>   to `printf'-like output (it's a syntax, but it can be used as a
+;;>   regular function too, see below).  When applied, it simply prints its
+;;>   arguments one by one, using certain keywords to control its behavior:
+;;>   * :>e     - output on the current-error-port;
+;;>   * :>o     - output on the current-output-port (default);
+;;>   * :>s     - accumulate output in a string which is the return value
+;;>               (string output sets `:n-' as default (unless
+;;>               pre-specified));
+;;>   * :> p    - output on the given port `p', or a string if `#f';
+;;>   * :>> o   - use `o', a procedure that gets a value and a port, as the
+;;>               output handler (the procedure can take one value and
+;;>               display it on the current output port);
+;;>   * :d      - use `display' output (default);
+;;>   * :w      - use `write' output;
+;;>   * :d1 :w1 - change to a `display' or `write' output just for the next
+;;>               argument;
+;;>   * :s-     - no spaces between arguments;
+;;>   * :s+     - add spaces between arguments (default);
+;;>   * :n-     - do not print a final newline;
+;;>   * :n+     - terminate the output with a newline (default);
+;;>   * :n      - output a newline now;
+;;>   * : or :: - avoid a space at this point;
+;;>   * :\{     - begin a list construct (see below).
+;;>   Keywords that require additional argument are ignored if no argument
+;;>   is given.
+;;>
+;;>   Recursive processing of a list begins with a `:\{' and ends with a
+;;>   `:\}' (which can be simpler if `read-curly-brace-as-paren' is off).
+;;>   Inside a list context, values are inspected and any lists cause
+;;>   iteration for all elements.  In each iteration, all non-list arguments
+;;>   are treated normally, but lists are dissected and a single element is
+;;>   printed in each step, terminating when the shortest list ends (and
+;;>   repeating a last `dotted' element of a list):
+;;>     => (define abc '(a b c))
+;;>     => (echo :\{ "X" abc :\})
+;;>     X a X b X c
+;;>     => (echo :\{ "X" abc '(1 2 3 4) :\})
+;;>     X a 1 X b 2 X c 3
+;;>     => (echo :\{ "X" abc '(1 . 2) :\})
+;;>     X a 1 X b 2 X c 2
+;;>   Inside a list context, the `:^' keyword can be used to stop this
+;;>   iteration if it is the last:
+;;>     => (echo :s- :\{ abc :^ ", " :\})
+;;>     a, b, c
+;;>   Nesting of lists is also simple, following these simple rules, by
+;;>   nesting the `:\{' ... `:\}' construct:
+;;>     => (echo :s- :\{ "<" :\{ '((1 2) (3 4 5) 6 ()) :^ "," :\} ">"
+;;>                      :^ "-" :\})
+;;>     <1,2>-<3,4,5>-<6>-<>
+;;>   Note that this example is similar to the CL `format':
+;;>     (format t "~{<~{~a~^,~}>~^-~}" '((1 2) (3 4 5) 6 ()))
+;;>   except that `echo' treats a dotted element (a non-list in this case)
+;;>   as repeating as needed.
+;;>
+;;>   There are two additional special keywords that are needed only in
+;;>   uncommon situations:
+;;>   * :k-  - turn off keyword processing
+;;>   * :k+  - turn keyword processing on
+;;>   Usually, when `echo' is used, it is processed by a macro that detects
+;;>   all keywords, even if there is a locally bound variable with a keyword
+;;>   name.  This means that keywords are only ones that are syntactically
+;;>   so, not expressions that evaluate to keywords.  The two cases where
+;;>   this matters are -- when `echo' is used for its value (using it as a
+;;>   value, not in a head position) no processing is done so all keywords
+;;>   will just get printed; and when `echo' is used in a context where a
+;;>   variable has a keyword name and you want to use its value (which not a
+;;>   great idea anyway, so there is no way around it).  The first case is
+;;>   probably more common, so the variable `echo:' is bound to a special
+;;>   value that will force treating the next value as a keyword (if it
+;;>   evaluates to one) -- it can also be used to turn keyword processing on
+;;>   (which means that all keyword values will have an effect).  Here is a
+;;>   likely examples where `echo:' should be used:
+;;>     => (define (echo-values vals)
+;;>          (apply echo "The given values are:" echo: :w vals))
+;;>     => (echo-values '("a" "b" "c"))
+;;>     The given values are: "a" "b" "c"
+;;>     => (echo-values '(:a :b :c))
+;;>     The given values are: :a :b :c
+;;>   And here are some tricky examples:
+;;>     => (echo :>s 2)
+;;>     "2"
+;;>     => (define e echo)                 ; `e' is the real `echo' function
+;;>     => (e :>s 2)                       ; no processing done here
+;;>     :>s 2
+;;>     => (e echo: :>s 2)                 ; explicit key
+;;>     "2"
+;;>     => (e echo: :k+ :>s 2)             ; turn on keywords
+;;>     "2"
+;;>     => (let ([:>s 1]) (echo :>s 2))    ; `:>s' was processed by `echo'
+;;>     "2"
+;;>     => (let ([:>s 1]) (e :>s 2))       ; `:>s' was not processed
+;;>     1 2
+;;>     => (let ([:>s 1]) (e echo: :>s 2)) ; `:>s' is not a keyword here!
+;;>     1 2
+;;>     => (let ([:>s 1]) (echo echo: :>s 2)) ; `echo:' not needed
+;;>     "2"
+;;>
+;;>   Finally, it is possible to introduce new keywords to `echo'.  This is
+;;>   done by calling it with the `:set-user' keyword, which expects a
+;;>   keyword to attach a handler to, and the handler itself.  The handler
+;;>   can be a simple value or a keyword that will be used instead:
+;;>     => (echo :set-user :foo "foo")
+;;>     => (echo 1 :foo 2)
+;;>     1 foo 2
+;;>     => (echo :set-user :foo :n)
+;;>     => (echo 1 :foo 2)
+;;>     1
+;;>     2
+;;>   The `:set-user' keyword can appear with other arguments, it has a
+;;>   global effect in any case:
+;;>     => (echo 1 :foo :set-user :foo "FOO" 2 :foo 3
+;;>              :set-user :foo "bar" :foo 4)
+;;>     1
+;;>     2 FOO 3 bar 4
+;;>     => (echo 1 :foo 2)
+;;>     1 bar 2
+;;>   If the handler is a function, then when this keyword is used, the
+;;>   function is applied on arguments pulled from the remaining `echo'
+;;>   arguments that follow (if the function can get any number of
+;;>   arguments, then all remaining arguments are taken).  The function can
+;;>   work in two ways: (1) when it is called, the `current-output-port'
+;;>   will be the one that `echo' currently prints to, so it can just print
+;;>   stuff; (2) if the function returns a list (or a single value which is
+;;>   not `#f' or `void'), then these values will be used instead of the
+;;>   taken arguments.  Some examples:
+;;>     => (echo :set-user :foo (thunk "FOO") 1 :foo 2)
+;;>     1 FOO 2
+;;>     => (echo :set-user :add1 add1 1 :add1 2)
+;;>     1 3
+;;>     => (echo :set-user :+1 (lambda (n) (list n '+1= (add1 n))) :+1 2)
+;;>     2 +1= 3
+;;>     => (echo :set-user :<> (lambda args (append '("<") args '(">")))
+;;>              :<> 1 2 3)
+;;>     < 1 2 3 >
+;;>   Care should be taken when user keywords are supposed to handle other
+;;>   keywords -- the `echo:' tag will usually be among the arguments except
+;;>   when `:k+' was used and an argument value was received.  This exposes
+;;>   the keyword treatment hack and might change in the future.
+;;>
+;;>   To allow user handlers to change settings temporarily, there are
+;;>   `:push' and `:pop' keywords that will save and restore the current
+;;>   state (space and newline flags, output type and port etc).  For
+;;>   example:
+;;>     => (echo :set-user :@
+;;>              (lambda (l)
+;;>                (echo-quote
+;;>                 list :push :s- :\{ "\"" l "\"" :^ ", " :\} :pop)))
+;;>     => (echo 1 :@ '(2 3 4) 5)
+;;>     1 "2", "3", "4" 5
+;;>   The above example shows another helper tool -- the `echo-quote'
+;;>   syntax: `(echo-quote head arg ...)' will transform into `(head ...)',
+;;>   where keyword arguments are prefix with the `echo:' tag.  Without it,
+;;>   things would look much worse.
+;;>
+;;>   In addition to `:set-user' there is an `:unset-user' keyword which
+;;>   cancels a keyword handler.  Note that built-in keywords cannot be
+;;>   overridden or unset.
+
+;;>> (echo-quote head arg ...) [h]
+;;>   This macro will result in `(head arg ...)', where all keywords in the
+;;>   argument list are preceded with the `echo:' tag.  It is a convenient
+;;>   form to use for defining new echo keyword handlers.
+(defsyntax* (echo-quote stx)
+  (define (process args)
+    (syntax-case args ()
+      [() #'()]
+      [(x . more) (with-syntax ([more (process #'more)])
+                    (if (syntax-keyword? #'x)
+                      ;; `datum' protects from using a local binding
+                      #'(echo: (#%datum . x) . more) #'(x . more)))]
+      [x #'x])) ; only in case of (echo ... . x)
+  (syntax-case stx ()
+    [(_ head . args) (quasisyntax/loc stx (head . #,(process #'args)))]))
+
+(provide (rename echo-syntax echo))
+(defsyntax (echo-syntax stx)
+  (syntax-case stx ()
+    [(_ . args) (syntax/loc stx (echo-quote echo . args))]
+    [_ #'echo]))
+
+;; A table for user-defined keywords
+(define echo-user-table (make-hash-table))
+
+;; Make an echo keyword handler for a given procedure.  The handler gets the
+;; current list of arguments and returns the new list of arguments.
+(define (make-echo-handler keyword proc)
+  (let* ([arity (procedure-arity proc)]
+         [at-least (and (arity-at-least? arity)
+                        (arity-at-least-value arity))]
+         [required (or at-least arity)])
+    (unless (integer? required)
+      (error 'echo "handler function for `~e' has bad arity" keyword))
+    (lambda (args)
+      (if (< (length args) required)
+        (error 'echo "user-keyword `~e' didn't get enough arguments" keyword)
+        (let*-values ([(proc-args rest-args)
+                       (if at-least
+                         (values args '())
+                         (let loop ([rest args] [args '()] [n required])
+                           (if (zero? n)
+                             (values (reverse! args) rest)
+                             (loop (cdr rest) (cons (car rest) args)
+                                   (sub1 n)))))]
+                      [(result) (apply proc proc-args)])
+          (cond [(list? result) (append result rest-args)]
+                [(and result (not (void? result)))
+                 (if (keyword? result)
+                   (list* echo: result rest-args) (cons result rest-args))]
+                [else rest-args]))))))
+
+(define (echo . args)
+  (define break: "break:")
+  (define call:  "call:")
+  (let ([printer (*echo-display-handler*)] [out (current-output-port)]
+        [spaces? #t] [newline? 'x] [first? #t] [str? #f] [keys? #f]
+        [states '()])
+    (define (getarg) (begin0 (car args) (set! args (cdr args))))
+    (define (push-state!)
+      (set! states (cons (list printer out spaces? newline? first? str? keys?)
+                         states)))
+    (define (pop-state!)
+      (if (null? states)
+        (error 'echo "tried to restore a state, but none saved")
+        (let ([s (car states)])
+          (set! states (cdr states))
+          (set!-values (printer out spaces? newline? first? str? keys?)
+                       (apply values s)))))
+    (define (set-out! arg)
+      (set! out (or arg (open-output-string)))
+      (set! str? (not arg))
+      (unless (output-port? out)
+        (error 'echo "expected an output-port or #f, given ~e" out)))
+    (define (printer1! hparam)
+      (unless (or (null? args) (eq? echo: (car args)))
+        (let ([p (hparam)])
+          (unless (eq? printer p)
+            (let ([v (getarg)] [op printer])
+              (set! printer p)
+              (set! args (list* v echo: :>> op args)))))))
+    (define (process-list)
+      (define level 1)
+      (define ((do-lists args))
+        ;; this returns a thunk so the whole thing is not expanded in one shot
+        (let loop ([args args] [cars '()] [cdrs '()] [last? '?])
+          (if (null? args)
+            (reverse!
+             (if last? cars (list* (do-lists (reverse! cdrs)) call: cars)))
+            (let* ([1st (car args)] [p? (pair? 1st)])
+              (if (and last? (eq? 1st break:))
+                (reverse! cars)
+                (if (null? 1st)
+                  '()
+                  (loop (cdr args)
+                        (if (eq? 1st break:)
+                          cars (cons (if p? (car 1st) 1st) cars))
+                        (cons (if p? (cdr 1st) 1st) cdrs)
+                        (if p?
+                          (or (eq? last? #t) (null? (cdr 1st)))
+                          last?))))))))
+      (let loop ([l-args '()])
+        (define (pop-key-tags)
+          (when (and (pair? l-args) (eq? echo: (car l-args)))
+            (set! l-args (cdr l-args)) (pop-key-tags)))
+        (when (null? args)
+          (error 'echo "found a `~e' with no matching `~e'" :\{ :\}))
+        (let ([arg (getarg)])
+          (define (next) (loop (cons arg l-args)))
+          (cond
+           [(eq? arg echo:) (set! keys? (or keys? 'just-one)) (next)]
+           [(and keys? (keyword? arg))
+            (unless (eq? keys? #t) (set! keys? #f))
+            (case arg
+              [(:\})
+               (set! level (sub1 level))
+               (if (zero? level)
+                 (begin
+                   (pop-key-tags)
+                   (set! args (append! ((do-lists (reverse! l-args))) args)))
+                 (next))]
+              [(:\{)
+               (set! level (add1 level)) (next)]
+              [(:^)
+               (when (eq? 1 level) (set! arg break:) (pop-key-tags))
+               (next)]
+              [else (next)])]
+           [else (next)]))))
+    (let loop ()
+      (unless (null? args)
+        (let ([arg (getarg)])
+          (cond
+           [(eq? arg call:) (set! args (append! ((getarg)) args))]
+           [(eq? arg echo:) (set! keys? (or keys? 'just-one))]
+           [(and keys? (keyword? arg))
+            (unless (eq? keys? #t) (set! keys? #f))
+            (case arg
+              [(:>e)    (set-out! (current-error-port))]
+              [(:>o)    (set-out! (current-output-port))]
+              [(:>s)    (set-out! #f)]
+              [(:>)     (unless (or (null? args) (eq? echo: (car args)))
+                          (set-out! (getarg)))]
+              [(:>>)    (unless (or (null? args) (eq? echo: (car args)))
+                          (let ([p (getarg)])
+                            (set! printer (if (eq? 1 (procedure-arity p))
+                                            (lambda (x _) (p x)) p))))]
+              [(:d)     (set! printer (*echo-display-handler*))]
+              [(:w)     (set! printer (*echo-write-handler*))]
+              [(:d1)    (printer1! *echo-display-handler*)]
+              [(:w1)    (printer1! *echo-write-handler*)]
+              [(:s-)    (set! spaces? (and spaces? (not first?) 'just-one))]
+              [(:s+)    (set! spaces? #t)]
+              [(:n-)    (set! newline? #f)]
+              [(:n+)    (set! newline? #t)]
+              [(:n)     (newline out) (set! first? #t)]
+              [(:: :)   (set! first? #t)]
+              [(:push)  (push-state!)]
+              [(:pop)   (pop-state!)]
+              [(:\{)    (process-list)]
+              [(:\} :^) (error 'echo "unexpected list keyword `~e'" arg)]
+              [(:k-)    (set! keys? #f)]
+              [(:k+)    (set! keys? #t)]
+              [(:set-user :unset-user)
+               (let loop ([keyword echo:])
+                 (if (null? args)
+                   (error 'echo "expecting a keyword+handler after `~e'" arg)
+                   (let ([x (getarg)])
+                     (cond
+                      [(eq? keyword echo:) (loop x)]
+                      [(not (keyword? keyword))
+                       (error 'echo "got a `~e' with a non-keyword `~e'"
+                              arg keyword)]
+                      [(eq? arg :unset-user)
+                       (hash-table-put! echo-user-table keyword #f)]
+                      [(eq? x echo:) (loop keyword)]
+                      [else (let ([handler (if (procedure? x)
+                                             (make-echo-handler keyword x) x)])
+                              (hash-table-put! echo-user-table keyword handler)
+                              (when (and newline? (not (eq? #t newline))
+                                         (null? args))
+                                (set! newline? #f)))]))))]
+              [else
+               (let ([user (hash-table-get echo-user-table arg (thunk #f))])
+                 (if user
+                   (set! args
+                         (cond [(procedure? user) (user args)]
+                               [(keyword? user) (list* echo: user args)]
+                               [else (cons user args)]))
+                   (error 'echo "unknown keyword: `~e'" arg)))])]
+           [first?  (printer arg out) (set! first? #f)]
+           [spaces? (display " " out) (printer arg out)
+                    (unless (eq? spaces? #t) (set! spaces? #f))]
+           [else (printer arg out)])
+          (loop))))
+    (when (and newline? (or (not str?) (eq? newline? #t))) (newline out))
+    (when str? (get-output-string out))))
+
+;;>> (echos arg ...)
+;;>   Just uses `echo' with `:>s'.
+(provide (rename echos-syntax echos))
+(defsyntax (echos-syntax stx)
+  (syntax-case stx ()
+    [(_ . args) (syntax/loc stx (echo-syntax :>s . args))]
+    [_ #'echos]))
+(define (echos . args)
+  (echo echo: :>s . args))
+
+;;>> echo:
+;;>   See the `echo' description for usage of this value.
+(define* echo: "echo:")
+
+;; ----------------------------------------------------------------------------
+;; Simple macros
+
+;;>> (named-lambda name args body ...)
+;;>   Like `lambda', but the name is bound to itself in the body.
+(defsubst* (named-lambda name args . body)
+  (letrec ([name (lambda args . body)]) name))
+
+;;>> (thunk body ...)
+;;>   Returns a procedure of no arguments that will have the given body.
+(defsubst* (thunk body ...) (lambda () body ...))
+
+;;>> (while condition body ...)
+;;>> (until condition body ...)
+;;>   Simple looping constructs.
+(defsubst* (while cond body ...)
+  (let loop () (when cond (begin body ... (loop)))))
+(defsubst* (until cond body ...)
+  (while (not cond) body ...))
+
+;;>> (dotimes (i n) body ...)
+;;>   Loop `n' times, evaluating the body when `i' is bound to 0,1,...,n-1.
+(defsubst* (dotimes [i n] body0 body ...)
+  (let loop ([i 0])
+    (when (< i n) body0 body ... (loop (add1 i)))))
+
+;;>> (dolist (x list) body ...)
+;;>   Loop with `x' bound to elements of `list'.
+(defsubst* (dolist [x lst] body0 body ...)
+  (for-each (lambda (x) body0 body ...) lst))
+
+;;>> (no-errors body ...)
+;;>   Execute body, catching all errors and returning `#f' if one occurred.
+(defsubst* (no-errors body ...)
+  (with-handlers ([void (lambda (x) #f)]) body ...))
+;;>> (no-errors* body ...)
+;;>   Execute body, catching all errors and returnsthe exception if one
+;;>   occured.
+(defsubst* (no-errors* body ...)
+  (with-handlers ([void identity]) body ...))
+
+;;>> (regexp-case string clause ...)
+;;>   Try to match the given `string' against several regexps.  Each clause
+;;>   has one of the following forms:
+;;>   * (re => function): if `string' matches `re', apply `function' on the
+;;>     result list.
+;;>   * ((re args ...) body ...): if `string' matches `re', bind the tail of
+;;>     results (i.e, excluding the whole match result) to the given
+;;>     arguments and evaluate the body.  The whole match result (the first
+;;>     element of `regexp-match') is bound to `match'.
+;;>   * (re body ...): if `string' matches `re', evaluate the body -- no
+;;>     match results are available.
+;;>   * (else body ...): should be the last clause which is evaluated if all
+;;>     previous cases failed.
+(defsyntax* (regexp-case stx)
+  (define (do-clause c)
+    (syntax-case c (else =>)
+      [(else body ...) c]
+      [(re => func) #'((regexp-match re s) => (lambda (r) (apply func r)))]
+      [((re . args) body ...)
+       #`((regexp-match re s) =>
+          (lambda (r)
+            (apply (lambda (#,(datum->syntax-object c 'match c) . args)
+                     body ...)
+                   r)))]
+      [(re body ...) #'((regexp-match re s) body ...)]))
+  (define (do-clauses c)
+    (cond [(null? c) c]
+          [(pair? c) (cons (do-clause (car c)) (do-clauses (cdr c)))]
+          [(syntax? c) (do-clauses (syntax-e c))]))
+  (syntax-case stx ()
+    [(_ str clause ...)
+     #`(let ([s str]) (cond #,@(do-clauses #'(clause ...))))]))
+
+;; ----------------------------------------------------------------------------
+;; Taken from slib (faster than then quicksort and mergesort in list.ss).
+;; "sort.scm" Defines: sorted?, merge, merge!, sort, sort!
+;; Author : Richard A. O'Keefe (based on Prolog code by D.H.D.Warren)
+
+;;>>... Sorting
+;;> The following section defines functions for sorting.  They are taken
+;;> directly from slib since they are more convenient and faster than the
+;;> functions in mzlib/list.  See the source for more details.
+
+;;>> (sorted? sequence less?)
+;;>   True when `sequence' is a list (x0 x1 ... xm) or a vector #(x0 ... xm)
+;;>   such that its elements are sorted according to `less?':
+;;>     (not (less? (list-ref list i) (list-ref list (- i 1)))).
+(define* (sorted? seq less?)
+  (cond [(null? seq) #t]
+        [(vector? seq)
+         (let ([n (vector-length seq)])
+           (if (<= n 1)
+             #t
+             (do ([i 1 (+ i 1)])
+                 [(or (= i n)
+                      (less? (vector-ref seq i) (vector-ref seq (- i 1))))
+                  (= i n)])))]
+        [else
+         (let loop ([last (car seq)] [next (cdr seq)])
+           (or (null? next)
+               (and (not (less? (car next) last))
+                    (loop (car next) (cdr next)))))]))
+
+;;>> (merge a b less?)
+;;>   Takes two lists `a' and `b' such that both (sorted? a less?) and
+;;>   (sorted? b less?) are true, and returns a new list in which the
+;;>   elements of `a' and `b' have been stably interleaved so that (sorted?
+;;>   (merge a b less?) less?) is true.  Note: this does not accept vectors.
+(define* (merge a b less?)
+  (cond [(null? a) b]
+        [(null? b) a]
+        [else (let loop ([x (car a)] [a (cdr a)] [y (car b)] [b (cdr b)])
+                ;; The loop handles the merging of non-empty lists.  It has
+                ;; been written this way to save testing and car/cdring.
+                (if (less? y x)
+                  (if (null? b)
+                    (cons y (cons x a))
+                    (cons y (loop x a (car b) (cdr b))))
+                  ;; x <= y
+                  (if (null? a)
+                    (cons x (cons y b))
+                    (cons x (loop (car a) (cdr a) y b)))))]))
+
+;;>> (merge! a b less?)
+;;>   Takes two sorted lists `a' and `b' and smashes their cdr fields to
+;;>   form a single sorted list including the elements of both.  Note: this
+;;>   does not accept vectors.
+(define* (merge! a b less?)
+  (define (loop r a b)
+    (if (less? (car b) (car a))
+      (begin (set-cdr! r b)
+             (if (null? (cdr b))
+               (set-cdr! b a)
+               (loop b a (cdr b))))
+      ;; (car a) <= (car b)
+      (begin (set-cdr! r a)
+             (if (null? (cdr a))
+               (set-cdr! a b)
+               (loop a (cdr a) b)))))
+  (cond [(null? a) b]
+        [(null? b) a]
+        [(less? (car b) (car a))
+         (if (null? (cdr b))
+           (set-cdr! b a)
+           (loop b a (cdr b)))
+         b]
+        [else ; (car a) <= (car b)
+         (if (null? (cdr a))
+           (set-cdr! a b)
+           (loop a (cdr a) b))
+         a]))
+
+;;>> (sort! sequence less?)
+;;>   Sorts the list or vector `sequence' destructively.
+;; It uses a version of merge-sort invented, to the best of my knowledge, by
+;; David H. D. Warren, and first used in the DEC-10 Prolog system.
+;; R. A. O'Keefe adapted it to work destructively in Scheme.
+(define* (sort! seq less?)
+  (define (step n)
+    (cond [(> n 2) (let* ([j (quotient n 2)]
+                          [a (step j)]
+                          [k (- n j)]
+                          [b (step k)])
+                     (merge! a b less?))]
+          [(= n 2) (let ([x (car seq)]
+                         [y (cadr seq)]
+                         [p seq])
+                     (set! seq (cddr seq))
+                     (when (less? y x)
+                       (set-car! p y) (set-car! (cdr p) x))
+                     (set-cdr! (cdr p) '())
+                     p)]
+          [(= n 1) (let ([p seq])
+                     (set! seq (cdr seq))
+                     (set-cdr! p '())
+                     p)]
+          [else '()]))
+  (if (vector? seq)
+    (let ([n (vector-length seq)] [vec seq])
+      (set! seq (vector->list seq))
+      (do ([p (step n) (cdr p)] [i 0 (+ i 1)])
+          [(null? p) vec]
+        (vector-set! vec i (car p))))
+    ;; otherwise, assume it is a list
+    (step (length seq))))
+
+;;>> (sort sequence less?)
+;;>   Sorts a vector or list non-destructively.  It does this by sorting a
+;;>   copy of the sequence.
+;; My understanding is that the Standard says that the result of append is
+;; always "newly allocated" except for sharing structure with "the last
+;; argument", so (append x '()) ought to be a standard way of copying a list x.
+(define* (sort seq less?)
+  (if (vector? seq)
+    (list->vector (sort! (vector->list seq) less?))
+    (sort! (append seq '()) less?)))
+
+)
diff --git a/collects/swindle/patterns.ss b/collects/swindle/patterns.ss
new file mode 100644
index 0000000000..81750205c4
--- /dev/null
+++ b/collects/swindle/patterns.ss
@@ -0,0 +1,267 @@
+(module patterns mzscheme
+
+(provide (all-from-except mzscheme
+                          define-values
+                          define
+                          let-values
+                          let*-values
+                          letrec-values
+                          let
+                          let*
+                          letrec
+                          set!
+                          set!-values
+                          lambda))
+
+(provide (rename define-values~ define-values)
+         (rename define~        define)
+         (rename let-values~    let-values)
+         (rename let*-values~   let*-values)
+         (rename letrec-values~ letrec-values)
+         (rename let~           let)
+         (rename let*~          let*)
+         (rename letrec~        letrec)
+         (rename set!~          set!)
+         (rename set!-values~   set!-values)
+         (rename lambda~        lambda))
+(define-syntaxes (define-values~
+                  define~
+                  let-values~
+                  let*-values~
+                  letrec-values~
+                  let~
+                  let*~
+                  letrec~
+                  set!~
+                  set!-values~
+                  lambda~)
+  (let ()
+    (define (id->handlers id)
+      (and (identifier? id)
+           (syntax-local-value
+            (datum->syntax-object id
+                                  (string->symbol
+                                   (string-append "extended-arg-keyword:"
+                                                  (symbol->string
+                                                   (syntax-e id))))
+                                  id)
+            (lambda () #f))))
+    (define (flatten-extended-bindings/values stxs expr)
+      (define temps (generate-temporaries stxs))
+      (define (remove-false-2nd l)
+        (let loop ([l l] [r '()])
+          (if (null? l)
+            (reverse! r)
+            (loop (cdr l) (if (cadar l) (cons (car l) r) r)))))
+      (let loop (;; tail: listof (cons extended-id, assigned-temp)
+                 [tail (map cons (syntax->list stxs) temps)]
+                 ;; r: listof (list extended-ids new-temps convert-expr)
+                 ;;        or (list extended-id same-temp #f)
+                 [r '()]
+                 ;; #f if non-id scanned, otherwise #t or 'first on first pass
+                 [simple? 'first]
+                 ;; vbinds: listof listof listof (vars expr)
+                 [vbinds (list (list (list temps expr)))])
+        (if (null? tail)
+          (let ([r (reverse! r)])
+            (if simple?
+              (if (eq? simple? 'first)
+                (values stxs expr)
+                (values (datum->syntax-object stxs (map car r) stxs)
+                        (let loop ([vbs (reverse vbinds)])
+                          (if (null? vbs)
+                            (if (and (pair? r) (null? (cdr r)))
+                              (quasisyntax/loc stxs #,(cadar r))
+                              (quasisyntax/loc stxs (values #,@(map cadr r))))
+                            (quasisyntax/loc stxs
+                              (let-values #,(remove-false-2nd (car vbs))
+                                #,(loop (cdr vbs))))))))
+              ;; saw non-identifiers, so start another iteration
+              (loop (apply append (map (lambda (x)
+                                         (if (caddr x)
+                                           (map cons (car x) (cadr x))
+                                           (list (cons (car x) (cadr x)))))
+                                       r))
+                    '() #t (cons (map cdr r) vbinds))))
+          (syntax-case (caar tail) ()
+            [var (identifier? #'var)
+             (loop (cdr tail) (cons (list (caar tail) (cdar tail) #f) r)
+                   simple? vbinds)]
+            [(id . xs) (identifier? #'id)
+             (cond
+              [(id->handlers #'id) =>
+               (lambda (handlers)
+                 (let ([bindings (syntax->list ((car handlers) #'xs))]
+                       [new-expr ((cadr handlers) (cdar tail) #'xs)])
+                   (unless (list? bindings)
+                     (error 'extended-binding
+                            "`~s->bindings' returned a non-list value: ~s"
+                            (syntax-e #'id) bindings))
+                   (loop (cdr tail)
+                         (cons (list bindings (generate-temporaries bindings)
+                                     new-expr)
+                               r)
+                         #f vbinds)))]
+              [else (raise-syntax-error
+                     'extended-binding
+                     "got a form which is not an extended binding"
+                     (caar tail) #'id)])]
+            [_ (raise-syntax-error
+                'extended-binding "bad binding" (caar tail))]))))
+    (define (_define-values stx)
+      (syntax-case stx ()
+        [(_ (var ...) expr)
+         (let-values ([(bindings expr)
+                       (flatten-extended-bindings/values #'(var ...) #'expr)])
+           (quasisyntax/loc stx (define-values #,bindings #,expr)))]))
+    (define (_define stx)
+      (syntax-case stx (values)
+        [(_ (values x ...) expr)
+         (syntax/loc stx (define-values~ (x ...) expr))]
+        [(_ (id . xs) expr) (id->handlers #'id)
+         (syntax/loc stx (define-values~ ((id . xs)) expr))]
+        [(_ (id . xs) body0 body ...)
+         (syntax/loc stx (define-values~ (id) (lambda~ xs body0 body ...)))]
+        [(_ x expr)
+         (syntax/loc stx (define-values~ (x) expr))]))
+    (define (make-let-values let-form)
+      (lambda (stx)
+        (syntax-case stx ()
+          [(_ (binding ...) body0 body ...)
+           (quasisyntax/loc stx
+             (#,let-form
+                 #,(map (lambda (binding)
+                          (syntax-case binding ()
+                            [((var ...) expr)
+                             (let-values ([(bindings expr)
+                                           (flatten-extended-bindings/values
+                                            #'(var ...) #'expr)])
+                               (quasisyntax/loc binding
+                                 (#,bindings #,expr)))]))
+                        (syntax->list #'(binding ...)))
+               body0 body ...))])))
+    (define _let-values (make-let-values #'let-values))
+    (define _let*-values (make-let-values #'let*-values))
+    (define _letrec-values (make-let-values #'letrec-values))
+    (define (make-let let-form label?)
+      (lambda (stx)
+        (syntax-case stx ()
+          [(_ label ((var val) ...) body0 body ...)
+           (and label? (identifier? #'label))
+           (quasisyntax/loc stx
+             ((letrec~ ([label (lambda~ (var ...) body0 body ...)]) label)
+              val ...))]
+          [(_ (binding ...) body0 body ...)
+           (quasisyntax/loc stx
+             (#,let-form #,(map (lambda (binding)
+                                  (syntax-case binding (values)
+                                    [((values x ...) expr) #'((x ...) expr)]
+                                    [(x expr)              #'((x)     expr)]))
+                                (syntax->list #'(binding ...)))
+               body0 body ...))])))
+    (define _let    (make-let #'let-values~    #t))
+    (define _let*   (make-let #'let*-values~   #f))
+    (define _letrec (make-let #'letrec-values~ #f))
+    (define (_set! stx)
+      (syntax-case stx (values)
+        [(_ (values x ...) expr) (syntax/loc stx (set!-values~ (x ...) expr))]
+        [(_ x expr)              (syntax/loc stx (set!-values~ (x) expr))]))
+    (define (_set!-values stx)
+      (syntax-case stx ()
+        [(_ (var ...) expr)
+         (let-values ([(bindings expr)
+                       (flatten-extended-bindings/values #'(var ...) #'expr)])
+           (quasisyntax/loc stx
+             (set!-values #,bindings #,expr)))]))
+    (define (_lambda stx)
+      (syntax-case stx ()
+        [(_ vars body0 body ...)
+         (let loop ([vs #'vars] [newvars '()] [specials '()] [restarg '()])
+           (syntax-case vs ()
+             [((id xs ...) . rest) (identifier? #'id)
+              (let ([newvar (car (generate-temporaries #'(id)))])
+                (loop #'rest (cons newvar newvars)
+                      (cons (list #'(id xs ...) newvar) specials)
+                      restarg))]
+             [(id . rest) (identifier? #'id)
+              (loop #'rest (cons #'id newvars) specials restarg)]
+             [id (identifier? #'id)
+              (loop #'() newvars specials #'id)]
+             [() (let ([args (datum->syntax-object
+                              #'vars (append! (reverse! newvars) restarg)
+                              #'vars)])
+                   (if (null? specials)
+                     (quasisyntax/loc stx (lambda #,args body0 body ...))
+                     (quasisyntax/loc stx
+                       (lambda #,args
+                         (let~ #,(reverse! specials)
+                           body0 body ...)))))]))]))
+    (values _define-values
+            _define
+            _let-values
+            _let*-values
+            _letrec-values
+            _let
+            _let*
+            _letrec
+            _set!
+            _set!-values
+            _lambda)))
+
+;; These are used as procedures for the syntax level
+(provide extended-arg-keyword:list extended-arg-keyword:vector)
+(define-syntax extended-arg-keyword:list
+  (list (lambda (vars) vars)
+        (lambda (expr vars)
+          (quasisyntax/loc expr (apply values #,expr)))))
+(define-syntax extended-arg-keyword:vector
+  (list (lambda (vars) vars)
+        (lambda (expr vars)
+          (quasisyntax/loc expr (apply values (vector->list #,expr))))))
+
+;; quote turns implicit lists and vectors to explicit ones
+(provide extended-arg-keyword:quote)
+(define-syntax extended-arg-keyword:quote
+  (list (lambda (vars)
+          (define (do-vars vs)
+            (datum->syntax-object
+             vs (map (lambda (v)
+                       (if (identifier? v) v (quasisyntax/loc v '#,v)))
+                     (syntax->list vs))
+             vs))
+          (do-vars (syntax-case vars ()
+                     [((v ...)) #'(v ...)] [(#(v ...)) #'(v ...)])))
+        (lambda (expr vars)
+          (syntax-case vars ()
+            [((v ...))
+             (quasisyntax/loc expr (apply values #,expr))]
+            [(#(v ...))
+             (quasisyntax/loc expr (apply values (vector->list #,expr)))]))))
+
+;; (define (values a (list (vector b c) (vector d) (list)) e)
+;;         (values 1 (list (vector 2 3) (vector 4) (list)) 5))
+;; (list a b c d e)
+;; (let ([(values a (list (vector b c) (vector d) (list)) e)
+;;        (values 1 (list (vector 2 3) (vector 4) (list)) 5)])
+;;   (list a b c d e))
+;; (let* ([(list x y) (list 1 2)] [(list x y) (list y x)]) (list x y))
+;; (let ([(values a '(#(b c) #(d) ()) e)
+;;        (values 1 '(#(2 3) #(4) ()) 5)])
+;;   (list a b c d e))
+;; (map (lambda ((list x y)) (list y x)) '((1 2) (3 4)))
+;; (let loop ([(list str n) (list "foo" 10)])
+;;   (if (zero? n) str (loop (list (string-append str "!") (sub1 n)))))
+;;
+;; (module foo mzscheme
+;;   (provide (struct point (x y)) extended-arg-keyword:make-point)
+;;   (define-struct point (x y))
+;;   (define-syntax extended-arg-keyword:make-point
+;;     (list (lambda (vars) (syntax-case vars () ((x y) vars)))
+;;           (lambda (expr vars)
+;;             (quasisyntax/loc expr
+;;               (values (point-x #,expr) (point-y #,expr)))))))
+;; (require foo)
+;; (define a (make-point 1 2))
+;; (let ([(make-point x y) a]) (+ x y))
+
+)
diff --git a/collects/swindle/readme.txt b/collects/swindle/readme.txt
new file mode 100644
index 0000000000..fd323a89d5
--- /dev/null
+++ b/collects/swindle/readme.txt
@@ -0,0 +1,160 @@
+====< Swindle >=========================================================
+
+This is the Swindle Reference Manual.
+
+Swindle is a collection of modules that extend PLT Scheme with many
+additional features.  The main feature which started this project is a
+CLOS-like object system based on Tiny-CLOS from Xerox, but there is a
+lot more -- see the feature list below for a rough picture.  Swindle is
+now part of PLT Scheme.
+
+
+====< Feature List >====================================================
+
+The following is a high-level description of major features provided by
+Swindle.  For every feature, the file that provides it is specified, if
+only a subset of the system is needed.
+
+* Some basic syntax extensions, including lambda &-keywords, and
+  improved `define' and `let' forms.  (Available separately using
+  "base.ss".)
+
+* Generic setters with `set!', additional useful mutation forms:
+  `pset!', `shift!', `rotate!', and some simple ones like `inc!', and
+  `push!'.  (Available separately using "setf.ss", where the names
+  `setf!' and `psetf!' are used to avoid changing the Scheme form.)
+
+* Easy macro-defining macros -- simple syntax-rules macros with
+  `defsubst', and a generic `defmacro' utility, all with a local
+  `let...' form, and extended to easily create symbol macros.
+  ("misc.ss")
+
+* A `collect' macro that provides very sophisticated list comprehensions
+  and much more.  ("misc.ss")
+
+* An `echo' mechanism which is an alternative to using format strings,
+  and contains many useful features including a list iteration
+  construct, and is easy to extend.  ("misc.ss")
+
+* A `regexp-case' syntax which is similar to a `case' on strings with
+  easy access to submatches.  ("misc.ss")
+
+* A CLOS-like object system -- based on Tiny CLOS, but with many
+  extensions that bring it much closer to CLOS, and heavily optimized.
+  Some added features include singleton and struct classes, applicable
+  stand-alone methods, method-combination, and some MOP extensions.
+  (Available without syntax bindings in "tiny-clos.ss")
+
+* Good integration with the Scheme implementation: primitive values have
+  corresponding Swindle classes, and struct types can also be used as
+  type specializers.  A Swindle class will be made when needed, and it
+  will reflect the struct hierarchy.  In addition, structs can be
+  defined with a Swindle-line `defstruct' syntax which will also make it
+  possible to create these structs with `make' using keyword arguments.
+  ("tiny-clos.ss" and "extra.ss")
+
+* Many hairy macros that make the object system much more convenient
+  (CLOS has also a lot of macro code).  Some of the macros (especially
+  `defclass') can be customized.  ("clos.ss")
+
+* Useful generic functions, including `print-object' which is used to
+  display all objects.  ("extra.ss")
+
+* A `match' mechanism with a generic-like interface.  ("extra.ss")
+
+* The fun `amb' toy.  ("extra.ss")
+
+* A language that can easily create HTML, where the result is
+  human-editable.  ("html.ss")
+
+* Customizable syntax: easy to add customized languages to DrScheme.
+  ("custom.ss")
+
+
+====< Reference Manual >================================================
+
+Files marked with "module" provide a module by the same name, files
+marked with "language module" modify the language and should be used as
+an initial import for other modules.  Most files (and especially all
+language modules) are useful by themselves, even without using the whole
+Swindle environment.
+
+* base.ss (language module)
+  Basic syntax extensions, mainly Lisp-like lambda argument &-keywords.
+
+* setf.ss (module)
+  Generic setters similar to `setf' in Lisp, and a few more useful
+  macros.
+
+* misc.ss (module)
+  Lots of useful functionality bits, including everything from
+  frequently useful MzScheme standard libraries (`list.ss', `etc.ss',
+  and `string.ss').
+
+* turbo.ss (language module)
+  A module that packages functionality from `base', `setf' (overriding
+  `set!' with `setf!'), and `misc'.
+
+* tiny-clos.ss (module)
+  The core object system, based on Tiny CLOS from Xerox, but heavily
+  modified, optimized and extended.
+
+* clos.ss (module)
+  Convenient macro wrappers for "tiny-clos.ss".
+
+* extra.ss (module)
+  Extra functionality on top of clos.
+
+* swindle.ss (language module)
+  The main Swindle environment module: packages `tiny-clos', `clos', and
+  `extra' on top of `turbo', and some more general definitions.
+
+* info.ss (module)
+  Compilation definitions.
+
+* install.ss (module)
+  This module is used to install the Swindle launcher.
+
+* tool.ss (module)
+  Setup for Swindle in DrScheme -- makes some languages available in
+  DrScheme, including custom Swindle-based languages.
+
+* custom.ss (module)
+  A sample file that demonstrates how to create a Swindle-based
+  customized language -- see the source for instructions.
+
+* html.ss (module)
+  A language for creating HTML.
+
+* html-doc.txt
+  Documentation file for "html.ss".
+
+* doc.txt
+  Descriptions of user-level functions, macros, generic functions and
+  variables, in a format that help-desk can use.  (Not included, an HTML
+  manual is created instead.)
+
+* copying.txt
+  Full copyright text (LGPL).
+
+
+====< Copyright Notice >================================================
+
+Copyright (C) 1998-2005 Eli Barzilay (eli@barzilay.org)
+
+    This library is free software; you can redistribute it and/or modify
+    it under the terms of the GNU Lesser General Public License as
+    published by the Free Software Foundation; either version 2.1 of the
+    License, or (at your option) any later version.
+
+    This library is distributed in the hope that it will be useful, but
+    WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+    Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
+    USA
+
+====< * >===============================================================
diff --git a/collects/swindle/setf.ss b/collects/swindle/setf.ss
new file mode 100644
index 0000000000..6fec1c0c8b
--- /dev/null
+++ b/collects/swindle/setf.ss
@@ -0,0 +1,276 @@
+;;; Written by Eli Barzilay: Maze is Life!  (eli@barzilay.org)
+
+;;> This module provides the forms `setf!', `psetf!', and `setf!-values' for
+;;> generic setters, much like CL's `setf', and `psetf', and a form similar
+;;> to MzScheme's `set!-values'.  Note that when these are later re-exported
+;;> (by `turbo'), they are renamed as `set!', `pset!', and `set!-values'
+;;> (overriding the built-in `set!' and `set!-values').  Also, note that
+;;> this just defines the basic functionality, the `misc' module defines
+;;> many common setters.
+
+(module setf mzscheme
+
+;;>> (setf! place value ...)
+;;>   Expand `(setf! (foo ...) v)' to `(set-foo! ... v)'.  The generated
+;;>   `set-foo!' identifier has the same syntax context as `foo', which
+;;>   means that to use this for some `foo' you need to define `set-foo!'
+;;>   either as a function or a syntax in the same definition context of
+;;>   `foo'.  The nice feature that comes out of this and the syntax system
+;;>   is that examples like the following work as expected:
+;;>     (let ([foo car] [set-foo! set-car!]) (setf! (foo a) 11))
+;;>
+;;>   `place' gets expanded before this processing is done so macros work
+;;>   properly.  If the place is not a form, then this will just use the
+;;>   standard `set!'.
+;;>
+;;>   Another extension of the original `set!' is that it allows changing
+;;>   several places in sequence -- `(setf! x a y b)' will set `x' to `a'
+;;>   and then set `y' to `b'.
+;; Original idea thanks to Eric Kidd who stole it from Dylan
+(provide setf!)
+(define-syntax (setf! stx)
+  (define (expand-place stx)
+    (syntax-case stx ()
+      [(_ var val)
+       (quasisyntax/loc stx
+         (_ #,(local-expand
+               #'var 'expression
+               (append '(#%app #%top #%datum)
+                       (map (lambda (s) (datum->syntax-object #'var s #f))
+                            '(#%app #%top #%datum))))
+            val))]
+      [else stx]))
+  (syntax-case (expand-place stx) ()
+    [(_ (getter args ...) val)
+     (if (identifier? #'getter)
+       (quasisyntax/loc stx
+         (#,(datum->syntax-object
+             #'getter
+             (string->symbol
+              (string-append "set-" (symbol->string (syntax-e #'getter)) "!"))
+             #'getter #'getter)
+          args ... val))
+       (raise-syntax-error #f "not an identifier" stx #'getter))]
+    [(_ var val)
+     (syntax/loc stx (set! var val))]
+    [(_ var val more ...)
+     (let loop ([vas #'(var val more ...)] [r '()])
+       (syntax-case vas ()
+         [(v a more ...)
+          (loop #'(more ...) (cons (syntax/loc stx (_ v a)) r))]
+         [() (quasisyntax/loc stx (begin #,@(reverse! r)))]
+         [_ (raise-syntax-error #f "uneven number of forms" stx)]))]))
+
+;;>> (psetf! place value ...)
+;;>   This is very similar to `setf!' above, except that the change to the
+;;>   places is done *simultaneously*.  For example, `(setf! x y y x)'
+;;>   switches the values of the two variables.
+;; This could have been expressed using `setf!-values', but that would lead to
+;; an unnecessary creation of a values tuple.
+(provide psetf!)
+(define-syntax (psetf! stx)
+  (syntax-case stx ()
+    ;; optimize common case
+    [(_ place val) (syntax/loc stx (setf! place val))]
+    [(_ more ...)
+     (let loop ([vars '()] [vals '()] [more (syntax->list #'(more ...))])
+       (cond
+        [(null? more)
+         (let ([vars (reverse vars)]
+               [vals (reverse vals)]
+               [tmps (generate-temporaries (map (lambda (x) 'x) vars))])
+           (quasisyntax/loc stx
+             (let #,(map (lambda (t v) #`(#,t #,v)) tmps vals)
+               #,@(map (lambda (v t) #`(setf! #,v #,t)) vars tmps))))]
+        [(null? (cdr more))
+         (raise-syntax-error #f "uneven number of forms" stx)]
+        [else (loop (cons (car more) vars) (cons (cadr more) vals)
+                    (cddr more))]))]))
+
+;;>> (setf!-values (place ...) expr)
+;;>   This is a version of `setf!', that works with multiple values.  `expr'
+;;>   is expected to evaluate to the correct number of values, and these are
+;;>   then put into the specified places which can be an place suited to
+;;>   `setf!'.  Note that no duplication of identifiers is checked, if an
+;;>   identifier appears more than once then it will have the last assigned
+;;>   value.
+(provide setf!-values)
+(define-syntax (setf!-values stx)
+  (syntax-case stx ()
+    ;; optimize common case
+    [(_ (place) val) (syntax/loc stx (setf! place val))]
+    [(_ (place ...) values)
+     (with-syntax ([(temp ...) (datum->syntax-object
+                                #'(place ...)
+                                (generate-temporaries #'(place ...))
+                                #'(place ...))])
+       (syntax/loc stx
+         (let-values ([(temp ...) values])
+           (setf! place temp) ...)))]))
+
+;;>> (set-values! places ... values-expr)
+;;>> (set-list! places ... list-expr)
+;;>> (set-vector! places ... vector-expr)
+;;>   These are defined as special forms that use `setf!-values' to set the
+;;>   given places to the appropriate components of the third form.  This
+;;>   allows foing the following:
+;;>     => (define (values a b c) (values 1 2 3))
+;;>     => (setf! (values a b c) (values 11 22 33))
+;;>     => (list a b c)
+;;>     (11 22 33)
+;;>     => (setf! (list a b c) (list 111 222 333))
+;;>     => (list a b c)
+;;>     (111 222 333)
+;;>     => (setf! (list a b c) (list 1111 2222 3333))
+;;>     => (list a b c)
+;;>     (1111 2222 3333)
+;;>   Furthermore, since the individual setting of each place is eventually
+;;>   done with `setf!', then this can be used recursively:
+;;>     => (set! (list a (vector b) (vector c c)) '(2 #(3) #(4 5)))
+;;>     => (list a b c)
+;;>     (2 3 5)
+(provide set-values! set-list! set-vector!)
+(define-syntaxes (set-values! set-list! set-vector!)
+  (let ([make-setter
+         (lambda (convert)
+           (lambda (stx)
+             (syntax-case stx ()
+               [(_ x y ...)
+                (let loop ([args (syntax->list #'(x y ...))] [as '()])
+                  (if (null? (cdr args))
+                    (quasisyntax/loc stx
+                      (setf!-values #,(datum->syntax-object
+                                       #'(x y ...) (reverse! as) #'(x y ...))
+                                    #,(convert (car args))))
+                    (loop (cdr args) (cons (car args) as))))])))])
+    (values
+     ;; set-values!
+     (make-setter (lambda (x) x))
+     ;; set-list!
+     (make-setter (lambda (x) #`(apply values #,x)))
+     ;; set-vector!
+     (make-setter (lambda (x) #`(apply values (vector->list #,x)))))))
+
+(provide shift! rotate! inc! dec! push! pop!)
+(define-syntaxes (shift! rotate! inc! dec! push! pop!)
+  (let* ([protect-indexes
+          (lambda (place body)
+            (syntax-case place ()
+              [(getter . xs)
+               (let ([bindings+expr
+                      (let loop ([xs #'xs]
+                                 [bindings '()]
+                                 [expr (list #'getter)]
+                                 [all-ids? #t])
+                        (syntax-case xs ()
+                          [() (and (not all-ids?)
+                                   (cons (reverse! bindings) (reverse! expr)))]
+                          [(x . xs)
+                           (let ([new (datum->syntax-object
+                                       #'x (gensym) #'x)])
+                             (loop #'xs
+                                   (cons (list new #'x) bindings)
+                                   (cons new expr)
+                                   (and (identifier? #'x) all-ids?)))]
+                          [x (and (not (and all-ids? (identifier? #'x)))
+                                  (let ([new (datum->syntax-object
+                                              #'x (gensym) #'x)])
+                                    (cons (reverse! (cons (list new #'x)
+                                                          bindings))
+                                          (append! (reverse! expr) new))))]))])
+                 (if bindings+expr
+                   #`(let #,(car bindings+expr) #,(body (cdr bindings+expr)))
+                   (body place)))]
+              [_ (body place)]))]
+         [protect-indexes-list
+          (lambda (places body)
+            (let loop ([ps places] [r '()])
+              (if (null? ps)
+                (body (reverse! r))
+                (protect-indexes (car ps) (lambda (p)
+                                            (loop (cdr ps) (cons p r)))))))])
+    (values
+;;>> (shift! place ... newvalue)
+;;>   This is similar to CL's `shiftf' -- it is roughly equivalent to
+;;>     (begin0 place1
+;;>             (psetf! place1 place2
+;;>                     place2 place3
+;;>                     ...
+;;>                     placen newvalue))
+;;>   except that it avoids evaluating index subforms twice, for example:
+;;>     => (let ([foo (lambda (x) (printf ">>> ~s\n" x) x)]
+;;>              [a '(1)] [b '(2)])
+;;>          (list (shift! (car (foo a)) (car (foo b)) 3) a b))
+;;>     >>> (1)
+;;>     >>> (2)
+;;>     (1 (2) (3))
+     ;; --- shift!
+     (lambda (stx)
+       (syntax-case stx ()
+         [(_ x y more ...)
+          (protect-indexes-list (syntax->list #'(x y more ...))
+            (lambda (vars)
+              (let loop ([vs vars] [r '()])
+                (if (null? (cdr vs))
+                  (quasisyntax/loc stx
+                    (let ([v #,(car vars)])
+                      (psetf! #,@(datum->syntax-object
+                                  #'(x y more ...)
+                                  (reverse! r)
+                                  #'(x y more ...)))
+                      v))
+                  (loop (cdr vs) (list* (cadr vs) (car vs) r))))))]))
+;;>> (rotate! place ...)
+;;>   This is similar to CL's `rotatef' -- it is roughly equivalent to
+;;>     (psetf! place1 place2
+;;>             place2 place3
+;;>             ...
+;;>             placen place1)
+;;>   except that it avoids evaluating index subforms twice.
+     ;; --- rotate!
+     (lambda (stx)
+       (syntax-case stx ()
+         [(_ x) #'(void)]
+         [(_ x xs ...)
+          (protect-indexes-list (syntax->list #'(x xs ...))
+            (lambda (vars)
+              (let loop ([vs vars] [r '()])
+                (if (null? (cdr vs))
+                  (quasisyntax/loc stx
+                    (psetf! #,@(datum->syntax-object
+                                #'(x xs ...)
+                                (reverse! (list* (car vars) (car vs) r))
+                                #'(x xs ...))))
+                  (loop (cdr vs) (list* (cadr vs) (car vs) r))))))]))
+;;>> (inc! place [delta])
+;;>> (dec! place [delta])
+;;>> (push! x place)
+;;>> (pop! place)
+;;>   These are some simple usages of `setf!'.  Note that they also avoid
+;;>   evaluating any indexes twice.
+     ;; --- inc!
+     (lambda (stx)
+       (syntax-case stx ()
+         [(_ p) #'(_ p 1)]
+         [(_ p d) (protect-indexes #'p
+                    (lambda (p) #`(setf! #,p (+ #,p d))))]))
+     ;; --- dec!
+     (lambda (stx)
+       (syntax-case stx ()
+         [(_ p) #'(_ p 1)]
+         [(_ p d) (protect-indexes #'p
+                    (lambda (p) #`(setf! #,p (- #,p d))))]))
+     ;; --- push!
+     (lambda (stx)
+       (syntax-case stx ()
+         [(_ x p) (protect-indexes #'p
+                    (lambda (p) #`(setf! #,p (cons x #,p))))]))
+     ;; --- pop!
+     (lambda (stx)
+       (syntax-case stx ()
+         [(_ p) (protect-indexes #'p
+                  (lambda (p)
+                    #`(let ([p1 #,p])
+                        (begin0 (car p1) (setf! #,p (cdr p1))))))])))))
+
+)
diff --git a/collects/swindle/swindle-icon.png b/collects/swindle/swindle-icon.png
new file mode 100644
index 0000000000..75a6c44e6e
Binary files /dev/null and b/collects/swindle/swindle-icon.png differ
diff --git a/collects/swindle/swindle-logo.png b/collects/swindle/swindle-logo.png
new file mode 100644
index 0000000000..d07c20bcaa
Binary files /dev/null and b/collects/swindle/swindle-logo.png differ
diff --git a/collects/swindle/swindle.ss b/collects/swindle/swindle.ss
new file mode 100644
index 0000000000..20377aa3fa
--- /dev/null
+++ b/collects/swindle/swindle.ss
@@ -0,0 +1,19 @@
+;;; Written by Eli Barzilay: Maze is Life!  (eli@barzilay.org)
+
+;;> This module combines all modules to form the Swindle language module.
+;;>
+;;> Note that it does not re-define `#%module-begin', so the language used
+;;> for transformers is still the one defined by `turbo'.
+
+(module swindle (lib "turbo.ss" "swindle")
+  (require (lib "clos.ss" "swindle")
+           (lib "extra.ss" "swindle"))
+  (provide (all-from (lib "turbo.ss" "swindle"))
+           (all-from (lib "clos.ss" "swindle"))
+           (all-from (lib "extra.ss" "swindle")))
+  (current-prompt-read (lambda () (display "=> ") (read)))
+  (install-swindle-printer)
+  ;; This comes out ugly in DrScheme.
+  ;; (printf
+  ;;  "Welcome to Swindle -- Eli Barzilay: Maze is Life! (eli@barzilay.org)\n")
+  )
diff --git a/collects/swindle/tiny-clos.ss b/collects/swindle/tiny-clos.ss
new file mode 100644
index 0000000000..863af90442
--- /dev/null
+++ b/collects/swindle/tiny-clos.ss
@@ -0,0 +1,2362 @@
+;;; Heavily hacked by Eli Barzilay: Maze is Life!  (eli@barzilay.org)
+
+;;> This module is the core object system.  It is a heavily hacked version
+;;> of the original Tiny-CLOS code from Xerox, but it has been fitted to
+;;> MzScheme, optimized and extended.  See the source file for a lot of
+;;> details about how the CLOS magic is created.
+;;>
+;;> [There is one difference between Swindle and Tiny-CLOS: the meta object
+;;> hierarchy is assumed to be using only single inheritance, or if there is
+;;> multiple inheritance then the built in meta objects should come first to
+;;> make the slots allocated in the same place.  This should not be a
+;;> problem in realistic situations.]
+
+;;; Original copyright:
+;;; ***************************************************************************
+;;; Copyright (c) 1992 Xerox Corporation.  All Rights Reserved.
+;;;
+;;; Use, reproduction, and preparation of derivative works are permitted.  Any
+;;; copy of this software or of any derivative work must include the above
+;;; copyright notice of Xerox Corporation, this paragraph and the one after it.
+;;; Any distribution of this software or derivative works must comply with all
+;;; applicable United States export control laws.
+;;; This software is made available AS IS, and XEROX CORPORATION DISCLAIMS ALL
+;;; WARRANTIES, EXPRESS OR IMPLIED, INCLUDING WITHOUT LIMITATION THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE, AND
+;;; NOTWITHSTANDING ANY OTHER PROVISION CONTAINED HEREIN, ANY LIABILITY FOR
+;;; DAMAGES RESULTING FROM THE SOFTWARE OR ITS USE IS EXPRESSLY DISCLAIMED,
+;;; WHETHER ARISING IN CONTRACT, TORT (INCLUDING NEGLIGENCE) OR STRICT
+;;; LIABILITY, EVEN IF XEROX CORPORATION IS ADVISED OF THE POSSIBILITY OF SUCH
+;;; DAMAGES.
+;;; ***************************************************************************
+
+(module tiny-clos (lib "base.ss" "swindle")
+
+;;; A very simple CLOS-like language, embedded in Scheme, with a simple MOP.
+;;; The features of the default base language are:
+;;;   * Classes, with instance slots, but no slot options.
+;;;   * Multiple-inheritance.
+;;;   * Generic functions with multi-methods and class specializers only.
+;;;   * Primary methods and call-next-method; no other method combination.
+;;;   * Uses Scheme's lexical scoping facilities as the class and generic
+;;;     function naming mechanism.  Another way of saying this is that class,
+;;;     generic function and methods are first-class (meta)objects.
+;;;
+;;; While the MOP is simple, it is essentially equal in power to both MOPs in
+;;; AMOP.  This implementation is not at all optimized, but the MOP is designed
+;;; so that it can be optimized.  In fact, this MOP allows better optimization
+;;; of slot access extenstions than those in AMOP.
+;;;
+;;; In addition to calling a generic, the entry points to the default base
+;;; language are:
+;;;
+;;;   (MAKE-CLASS list-of-superclasses list-of-slot-names)
+;;;   (MAKE-GENERIC-FUNCTION)
+;;;   (MAKE-METHOD list-of-specializers procedure)
+;;;   (ADD-METHOD generic method)
+;;;
+;;;   (MAKE class . initargs)
+;;;   (INITIALIZE instance initargs) ; Add methods to this, dont call directly.
+;;;
+;;;   (SLOT-REF    object slot-name)
+;;;   (SLOT-SET!   object slot-name new-value)
+;;;   (SLOT-BOUND? object slot-name)
+;;;
+;;; So, for example, one might do:
+;;;   (define <position> (make-class (list <object>) (list 'x 'y)))
+;;;   (add-method initialize
+;;;     (make-method (list <position>)
+;;;       (lambda (call-next-method pos initargs)
+;;;         (for-each (lambda (initarg-name slot-name)
+;;;                     (slot-set! pos slot-name
+;;;                                (getarg initargs initarg-name 0)))
+;;;                   '(x y)
+;;;                   '(x y)))))
+;;;   (set! p1 (make <position> 'x 1 'y 3))
+;;;
+;;; NOTE!  Do not use EQUAL? to compare objects!  Use EQ? or some hand written
+;;;        procedure.  Objects have a pointer to their class, and classes are
+;;;        circular structures, and...
+;;;
+;;; The introspective part of the MOP looks like the following.  Note that
+;;; these are ordinary procedures, not generics.
+;;;   * CLASS-OF
+;;;     INSTANCE-OF?
+;;;     SUBCLASS?
+;;;   * CLASS-DEFAULT-INITARGS
+;;;     CLASS-DIRECT-DEFAULT-INITARGS
+;;;     CLASS-DIRECT-SUPERS
+;;;     CLASS-DIRECT-SLOTS
+;;;     CLASS-CPL
+;;;     CLASS-SLOTS
+;;;     CLASS-NAME
+;;;   * GENERIC-METHODS
+;;;     GENERIC-ARITY
+;;;     GENERIC-NAME
+;;;     GENERIC-COMBINATION
+;;;   * METHOD-SPECIALIZERS
+;;;     METHOD-PROCEDURE
+;;;     METHOD-NAME
+;;;
+;;; The intercessory protocol looks like (generics in uppercase):
+;;; ELI: All of these are generic functions now!
+;;;   MAKE
+;;;     ALLOCATE-INSTANCE
+;;;     INITIALIZE                   (really a base-level generic)
+;;;   class initialization
+;;;     COMPUTE-CPL
+;;;     COMPUTE-SLOTS
+;;;     COMPUTE-DEFAULT-INITARGS
+;;;     COMPUTE-GETTER-AND-SETTER
+;;;   method initialization
+;;;     COMPUTE-APPLY-METHOD
+;;;   ADD-METHOD                    (Notice this is not a generic!) [eli: yes!]
+;;;     COMPUTE-APPLY-GENERIC
+;;;       COMPUTE-METHODS
+;;;         COMPUTE-METHOD-MORE-SPECIFIC?
+;;;       COMPUTE-APPLY-METHODS
+
+;;; OK, now let's get going.  But, as usual, before we can do anything
+;;; interesting, we have to muck around for a bit first.  First, we need to
+;;; load the support library.  [-- replaced with a module.]
+(require (lib "misc.ss" "swindle"))
+
+;; This is a convenient function for raising exceptions
+(define (raise* exn-maker fmt . args)
+  (let ([sym (and (symbol? fmt)
+                  (begin0 fmt
+                    (when (null? args) (error 'raise* "got too few arguments"))
+                    (set! fmt (car args)) (set! args (cdr args))))]
+        [fmt-num (- (length args) (procedure-arity exn-maker) -2)])
+    (when (< fmt-num 0)
+      (error 'raise* "got too few arguments"))
+    (let loop ([fmt-args '()] [args args] [a fmt-num])
+      (if (zero? a)
+        (raise (exn-maker
+                (string->immutable-string
+                 (if sym
+                   (apply format (concat "~s: " fmt) sym (reverse! fmt-args))
+                   (apply format fmt (reverse! fmt-args))))
+                (current-continuation-marks) . args))
+        (loop (cons (car args) fmt-args) (cdr args) (sub1 a))))))
+
+;; A simple topological sort.
+;; It's in this file so that both TinyClos and Objects can use it.
+;; This is a fairly modified version of code I originally got from Anurag
+;; Mendhekar <anurag@moose.cs.indiana.edu>.
+(define (compute-std-cpl c get-direct-supers)
+  (top-sort (build-transitive-closure get-direct-supers c)
+            (build-constraints get-direct-supers c)
+            (std-tie-breaker get-direct-supers)))
+(define (top-sort elements constraints tie-breaker)
+  (let loop ([elements elements] [constraints constraints] [result '()])
+    (if (null? elements)
+      result
+      (let ([can-go-in-now
+             (filter (lambda (x)
+                       (every (lambda (constraint)
+                                (or (not (eq? (cadr constraint) x))
+                                    (memq (car constraint) result)))
+                              constraints))
+                     elements)])
+        (if (null? can-go-in-now)
+          (error 'top-sort "invalid constraints")
+          (let ([choice (if (null? (cdr can-go-in-now))
+                          (car can-go-in-now)
+                          (tie-breaker result can-go-in-now))])
+            (loop (filter (lambda (x) (not (eq? x choice))) elements)
+                  constraints (append result (list choice)))))))))
+(define (std-tie-breaker get-supers)
+  (lambda (partial-cpl min-elts)
+    (let loop ([pcpl (reverse partial-cpl)])
+      (let* ([current-elt (car pcpl)]
+             [ds-of-ce (get-supers current-elt)]
+             [common (filter (lambda (x) (memq x ds-of-ce)) min-elts)])
+        (if (null? common)
+          (if (null? (cdr pcpl))
+            (error 'std-tie-breaker "nothing valid") (loop (cdr pcpl)))
+          (car common))))))
+(define (build-transitive-closure get-follow-ons x)
+  (let track ([result '()] [pending (list x)])
+    (if (null? pending)
+      result
+      (let ([next (car pending)])
+        (if (memq next result)
+          (track result (cdr pending))
+          (track (cons next result)
+                 (append (get-follow-ons next) (cdr pending))))))))
+(define (build-constraints get-follow-ons x)
+  (let loop ([elements (build-transitive-closure get-follow-ons x)]
+             [this-one '()]
+             [result '()])
+    (if (or (null? this-one) (null? (cdr this-one)))
+      (if (null? elements)
+        result
+        (loop (cdr elements)
+              (cons (car elements) (get-follow-ons (car elements)))
+              result))
+      (loop elements
+            (cdr this-one)
+            (cons (list (car this-one) (cadr this-one)) result)))))
+
+;;; Then, we need to build what, in a more real implementation, would be the
+;;; interface to the memory subsystem: instances and entities.  The former are
+;;; used for instances of instances of <class>; the latter are used for
+;;; instances of instances of <entity-class>.  In this MOP, none of this is
+;;; visible to base- or MOP-level programmers.
+;;; A few things to note, that have influenced the way all this is done:
+;;;   - R4RS doesn't provide a mechanism for specializing the
+;;;     behavior of the printer for certain objects.
+;;;   - Some Scheme implementations bomb when printing circular structures --
+;;;     that is, arrays and/or lists that somehow point back to themselves.
+;;; So, the natural implementation of instances -- vectors whose first field
+;;; point to the class -- is straight on out.  Instead, we use a procedure to
+;;; `encapsulate' that natural representation.
+;;; Having gone that far, it makes things simpler to unify the way normal
+;;; instances and entities are handled, at least in the lower levels of the
+;;; system.  Don't get faked out by this -- the user shouldn't think of normal
+;;; instances as being procedures, they aren't. (At least not in this
+;;; language.)  If you are using this to teach, you probably want to hide the
+;;; implementation of instances and entities from people.
+
+;;>> ???
+;;>   This is MzScheme's `unspecified' value which is used as the default
+;;>   value for unbound slots.  It is provided so you can check if a slot is
+;;>   unbound.
+(define* ??? (letrec ([x x]) x)) ; this is MzScheme's #<undefined> value
+(define unspecified-initializer (lambda args ???))
+(define false-func (lambda args #f))
+
+;; Basic allocation follows, all was in a single let, but this is not needed
+;; with MzScheme's modules.  Also modified to use simple structs for
+;; everything, including entities since PLT has applicable struct objects.
+
+(define-values (struct:instance make-instance instance? inst-ref inst-set!)
+  ;; slots: applicable, class, function, slots-vector
+  (make-struct-type 'swindleobj #f 3 0 #f '() (current-inspector)
+                    (lambda (o . args) (apply (instance-proc o) args))))
+(defsubst (instance-class x) (inst-ref x 0))
+(defsubst (instance-proc  x) (inst-ref x 1))
+(defsubst (instance-slots x) (inst-ref x 2))
+(defsubst (set-instance-class! x c) (inst-set! x 0 c))
+(defsubst (set-instance-proc!  x p) (inst-set! x 1 p))
+(defsubst (set-instance-slots! x s) (inst-set! x 2 s))
+
+(defsubst (%instance-ref o f)    (vector-ref (instance-slots o) f))
+(defsubst (%instance-set! o f n) (vector-set! (instance-slots o) f n))
+
+(define (%allocate-instance class nfields)
+  (make-instance class
+                 (lambda args
+                   (error 'instance
+                          "an instance isn't a procedure -- can't apply it"))
+                 (make-vector nfields ???)))
+
+(define (%allocate-entity class nfields)
+  (letrec ([o (make-instance
+               class
+               (lambda args
+                 (error 'entity
+                        "tried to call an entity before its proc is set"))
+               (make-vector nfields ???))])
+    o))
+
+;; This is used only once as part of bootstrapping the braid.
+(define (set-instance-class-to-self! class)
+  (set-instance-class! class class))
+
+;;>>...
+;;> *** Low level functionality
+;;> (These functions should be used with caution, since they make shooting
+;;> legs in exotic ways extremely easy.)
+
+;;>> (change-class! object new-class initargs ...)
+;;>   This operation changes the class of the given `object' to the given
+;;>   `new-class'.  The way this is done is by creating a fresh instance of
+;;>   `new-class', then copying all slot values from `object' to the new
+;;>   instance for all shared slot names.  Finally, the new instance's set
+;;>   of slots is used for the original object with the new class, so it
+;;>   preserves its identity.
+(define* (change-class! obj new-class . initargs)
+  (let ([new (make new-class . initargs)]
+        [new-slots (%class-slots new-class)])
+    (dolist [slot (%class-slots (class-of obj))]
+      (when (and (not (eq? :class (getarg (cdr slot) :allocation :instance)))
+                 (assq (car slot) new-slots))
+        (slot-set! new (car slot) (slot-ref obj (car slot)))))
+    (set-instance-slots! obj (instance-slots new))
+    (set-instance-class! obj new-class)))
+
+;; This might be cute for some ugly hacks but not needed for now.
+;; Copies the contents of source to target, making it an "alias" object.  This
+;; is no re-provided by clos.ss, but maybe it will in the future...
+;; (define* (copy-object-contents! target source)
+;;   (set-instance-class! target (instance-class source))
+;;   (set-instance-proc!  target (instance-proc  source))
+;;   (set-instance-slots! target (instance-slots source)))
+
+;;>> (set-instance-proc! object proc)
+;;>   This function sets the procedure of an entity object.  It is useful
+;;>   only for making new entity classes.
+(provide set-instance-proc!) ; dangerous!
+
+;; Basic allocation ends here.
+
+;;>>...
+;;> *** Basic functionality
+
+;;>> (instance? x)
+;;>> (object? x)
+;;>   These two are synonyms: a predicate that returns #t for objects that
+;;>   are allocated and managed by Swindle.
+(provide instance?)
+(define* object? instance?)
+
+;;>> (class-of x)
+;;>   Return the class object of `x'.  This will either be a Swindle class
+;;>   for objects, or a built-in class for other Scheme values.
+;;; %allocate-instance, %allocate-entity, %instance-ref, %instance-set! and
+;;; class-of are the normal interface, from the rest of the code, to the
+;;; low-level memory system.  One thing to take note of is that the protocol
+;;; does not allow the user to add low-level instance representations.  I have
+;;; never seen a way to make that work.
+;;; Note that this implementation of class-of assumes the name of a the
+;;; primitive classes that are set up later.
+(define* (class-of x)
+  ;; This is an early version that will be modified when built-in types are
+  ;; introduced later.
+  (if (instance? x) (instance-class x) <top>))
+
+;;; Now we can get down to business.  First, we initialize the braid.
+;;; For Bootstrapping, we define an early version of MAKE.  It will be changed
+;;; to the real version later on.
+(define* (make class . initargs)
+  (cond [(or (eq? class <class>) (eq? class <entity-class>))
+         (let* ([new     (%allocate-instance class
+                                             (length the-slots-of-a-class))]
+                [dinitargs (getarg initargs :direct-default-initargs '())]
+                [dsupers (getarg initargs :direct-supers '())]
+                [dslots  (map list (getarg initargs :direct-slots '()))]
+                [cpl     (let loop ([sups dsupers] [so-far (list new)])
+                           (if (null? sups)
+                             (reverse! so-far)
+                             (loop (append (cdr sups)
+                                           (%class-direct-supers (car sups)))
+                                   (if (memq (car sups) so-far)
+                                     so-far
+                                     (cons (car sups) so-far)))))]
+                [slots
+                 (apply append dslots (map %class-direct-slots (cdr cpl)))]
+                [initargs
+                 (apply append dinitargs (map %class-direct-default-initargs (cdr cpl)))]
+                [nfields 0]
+                [name (or (getarg initargs :name) '-anonymous-)]
+                [field-initializers '()]
+                ;; this is a temporary allocator version, kept as the original
+                ;; one in tiny-clos.  the permanent version below is modified.
+                [allocator
+                 (lambda (init)
+                   (let ([f nfields])
+                     (set! nfields (+ nfields 1))
+                     (set! field-initializers (cons init field-initializers))
+                     (list (lambda (o)   (%instance-ref  o f))
+                           (lambda (o n) (%instance-set! o f n)))))]
+                [getters-n-setters
+                 (map (lambda (s)
+                        (cons (car s) (allocator unspecified-initializer)))
+                      slots)])
+           (%set-class-default-initargs!   new '()) ; no default initargs yet
+           (%set-class-direct-default-initargs! new dinitargs)
+           (%set-class-direct-supers!      new dsupers)
+           (%set-class-direct-slots!       new dslots)
+           (%set-class-cpl!                new cpl)
+           (%set-class-slots!              new slots)
+           (%set-class-nfields!            new nfields)
+           (%set-class-field-initializers! new (reverse! field-initializers))
+           (%set-class-getters-n-setters!  new getters-n-setters)
+           (%set-class-name!               new name)
+           (%set-class-initializers!       new '()) ; no class inits now
+           (%set-class-valid-initargs!     new #f)  ; no initargs now
+           new)]
+        [(eq? class <generic>)
+         (let ([new   (%allocate-entity class (length (%class-slots class)))]
+               [arity (getarg initargs :arity #f)]
+               [name  (or (getarg initargs :name) '-anonymous-)])
+           (%set-generic-methods!     new '())
+           (%set-generic-arity!       new arity)
+           (%set-generic-name!        new name)
+           (%set-generic-combination! new #f)
+           new)]
+        [(eq? class <method>)
+         (let ([new  (%allocate-entity class (length (%class-slots class)))]
+               [name (or (getarg initargs :name) '-anonymous-)])
+           (%set-method-specializers! new (getarg initargs :specializers))
+           (%set-method-procedure!    new (getarg initargs :procedure))
+           (%set-method-qualifier!    new (or (getarg initargs :qualifier)
+                                              :primary))
+           (%set-method-name!         new name)
+           (set-instance-proc!        new (method:compute-apply-method #f new))
+           new)]))
+
+;;; These are the real versions of slot-ref and slot-set!.  Because of the way
+;;; the new slot access protocol works, with no generic call in line, they can
+;;; be defined up front like this.  Cool eh?
+
+;;>> (slot-ref obj slot)
+;;>   Pull out the contents of the slot named `slot' in the given `obj'.
+;;>   Note that slot names are usually symbols, but can be other values as
+;;>   well.
+(define* (slot-ref object slot-name)
+  ((lookup-slot-info (class-of object) slot-name cadr) object))
+(defsubst (%slot-ref object slot-name)
+  ((lookup-slot-info (class-of object) slot-name cadr) object))
+
+;;>> (slot-set! obj slot new)
+;;>   Change the contents of the `slot' slot of `obj' to the given `new'
+;;>   value.
+(define* (slot-set! object slot-name new-value)
+  ((lookup-slot-info (class-of object) slot-name caddr) object new-value))
+(defsubst (%slot-set! object slot-name new-value)
+  ((lookup-slot-info (class-of object) slot-name caddr) object new-value))
+;;>> (set-slot-ref! obj slot new)
+;;>   An alias for `slot-set!', to enable using `setf!' on it.
+(define* set-slot-ref! slot-set!)
+
+;; This is a utility that is used to make locked slots
+(define (make-setter-locked! g+s key error)
+  (let ([setter (cadr g+s)])
+    (set-cadr! g+s
+      (lambda (o n)
+        (cond [(and (pair? n) (eq? key (car n)) (not (eq? key #t)))
+               (setter o (cdr n))]
+              [(eq? ??? ((car g+s) o)) (setter o n)]
+              [else (error)])))))
+
+;;>> (slot-bound? object slot)
+;;>   Checks if the given `slot' is bound in `object'.  See also `???'
+;;>   above.
+(define* (slot-bound? object slot-name)
+  (not (eq? ??? (%slot-ref object slot-name))))
+
+(define (lookup-slot-info class slot-name selector)
+  (selector (or (assq slot-name
+                      ;; no need to ground slot-ref any more! -- see below
+                      ;; (if (eq? class <class>)
+                      ;;   ;;* This grounds out the slot-ref tower
+                      ;;   getters-n-setters-for-class
+                      ;;   (%class-getters-n-setters class))
+                      (%class-getters-n-setters class))
+                (raise* make-exn:fail:contract
+                        "slot-ref: no slot `~e' in ~e" slot-name class))))
+
+;;; These are for optimizations - works only for single inheritance!
+(define (%slot-getter class slot-name)
+  (lookup-slot-info class slot-name cadr))
+(define (%slot-setter class slot-name)
+  (lookup-slot-info class slot-name caddr))
+
+;;>>... Singleton and Struct Specifiers
+
+;;; Singleton class.  A hash-table is used so it is still possible to compare
+;;; classes with eq?.
+(define singleton-classes (make-hash-table 'weak))
+;;>> (singleton x)
+;;>   Returns a singleton specification.  Singletons can be used as type
+;;>   specifications that have only one element in them so you can
+;;>   specialize methods on unique objects.
+;;>
+;;>   This is actually just a list with the symbol `singleton' in its head
+;;>   and the value, but this function uses a hash table to always return
+;;>   the same object for the same value.  For example:
+;;>     => (singleton 1)
+;;>     (singleton 1)
+;;>     => (eq? (singleton 1) (singleton 1))
+;;>     #t
+;;>   but if the input objects are not `eq?', the result isn't either:
+;;>     => (eq? (singleton "1") (singleton "1"))
+;;>     #f
+;;>   Only `eq?' is used to compare objects.
+(define* (singleton x)
+  (or (hash-table-get singleton-classes x false-func)
+      (let ([c (list 'singleton x)])
+        (hash-table-put! singleton-classes x c)
+        c)))
+;;>> (singleton? x)
+;;>   Determines if something is a singleton specification (which is any
+;;>   list with a head containing the symbol `singleton').
+(define* (singleton? x)
+  (and (pair? x) (eq? (car x) 'singleton)))
+(defsubst (%singleton? x)
+  (and (pair? x) (eq? (car x) 'singleton)))
+;;>> (singleton-value x)
+;;>   Pulls out the value of a singleton specification.
+(define* singleton-value cadr)
+
+;;>>...
+;;> Also note that MzScheme struct types are converted to appropriate
+;;> Swindle classes.  This way, it is possible to have Swindle generic
+;;> functions that work with struct type specializers.
+
+;;>> (struct-type->class struct-type)
+;;>   This function is used to convert a struct-type to a corresponding
+;;>   Swindle subclass of `<struct>'.  See the MzScheme manual for details
+;;>   on struct types.
+(define struct-to-class-table (make-hash-table))
+(define* (struct-type->class stype)
+  (hash-table-get
+   struct-to-class-table stype
+   (thunk (let-values ([(name init-field-k auto-field-k accessor mutator
+                         immutable-k-list super skipped?)
+                        (struct-type-info stype)])
+            (let* ([super (cond [super (struct-type->class super)]
+                                [skipped? <opaque-struct>]
+                                [else <struct>])]
+                   [this (parameterize ([*default-object-class* #f])
+                           (make <primitive-class>
+                                 :name name :direct-supers (list super)))])
+              (hash-table-put! struct-to-class-table stype this)
+              this)))))
+
+;;>>...
+;;> *** Common accessors
+
+;;; Given that the early version of MAKE is allowed to call accessors on class
+;;; metaobjects, the definitions for them come here, before the actual class
+;;; definitions, which are coming up right afterwards.
+;;>> (class-default-initargs class)
+;;>> (class-direct-default-initargs class)
+;;>> (class-direct-slots class)
+;;>> (class-direct-supers class)
+;;>> (class-slots class)
+;;>> (class-cpl class)
+;;>> (class-name class)
+;;>> (class-initializers class)
+;;>   Accessors for class objects (look better than using `slot-ref').
+(define* (class-default-initargs c)   (%slot-ref c 'default-initargs))
+(define* (class-direct-default-initargs c)
+                                      (%slot-ref c 'direct-default-initargs))
+(define* (class-direct-slots       c) (%slot-ref c 'direct-slots))
+(define* (class-direct-supers      c) (%slot-ref c 'direct-supers))
+(define* (class-slots              c) (%slot-ref c 'slots))
+(define  (class-nfields            c) (%slot-ref c 'nfields))
+(define  (class-field-initializers c) (%slot-ref c 'field-initializers))
+(define  (class-getters-n-setters  c) (%slot-ref c 'getters-n-setters))
+(define* (class-cpl                c) (%slot-ref c 'cpl))
+(define* (class-name               c) (%slot-ref c 'name))
+(define* (class-initializers       c) (%slot-ref c 'initializers))
+(define  (class-valid-initargs     c) (%slot-ref c 'valid-initargs))
+;;>> (generic-methods generic)
+;;>> (generic-arity generic)
+;;>> (generic-name generic)
+;;>> (generic-combination generic)
+;;>   Accessors for generic function objects.
+(define* (generic-methods          g) (%slot-ref g 'methods))
+(define* (generic-arity            g) (%slot-ref g 'arity))
+(define* (generic-name             g) (%slot-ref g 'name))
+(define* (generic-combination      g) (%slot-ref g 'combination))
+;;>> (method-specializers method)
+;;>> (method-procedure method)
+;;>> (method-qualifier method)
+;;>> (method-name method)
+;;>> (method-arity method)
+;;>   Accessors for method objects.  `method-arity' is not really an
+;;>   accessor, it is deduced from the arity of the procedure (minus one for
+;;>   the `call-next-method' argument).
+(define* (method-specializers      m) (%slot-ref m 'specializers))
+(define* (method-procedure         m) (%slot-ref m 'procedure))
+(define* (method-qualifier         m) (%slot-ref m 'qualifier))
+(define* (method-name              m) (%slot-ref m 'name))
+(define* (method-arity m)
+  (let ([a (procedure-arity (%method-procedure m))])
+    (cond [(integer? a) (sub1 a)]
+          [(arity-at-least? a)
+           (make-arity-at-least (sub1 (arity-at-least-value a)))]
+          [else (error 'method-arity "the procedure in ~e has bad arity ~e"
+                       m a)])))
+
+;;; These versions will be optimized later.
+(define %class-default-initargs   class-default-initargs)
+(define %class-direct-default-initargs class-direct-default-initargs)
+(define %class-direct-slots       class-direct-slots)
+(define %class-direct-supers      class-direct-supers)
+(define %class-slots              class-slots)
+(define %class-nfields            class-nfields)
+(define %class-field-initializers class-field-initializers)
+(define %class-getters-n-setters  class-getters-n-setters)
+(define %class-cpl                class-cpl)
+(define %class-name               class-name)
+(define %class-initializers       class-initializers)
+(define %class-valid-initargs     class-valid-initargs)
+(define %generic-methods          generic-methods)
+(define %generic-arity            generic-arity)
+(define %generic-name             generic-name)
+(define %generic-combination      generic-combination)
+(define %method-specializers      method-specializers)
+(define %method-procedure         method-procedure)
+(define %method-qualifier         method-qualifier)
+(define %method-name              method-name)
+
+(define (%set-class-default-initargs! c x)
+                                         (%slot-set! c 'default-initargs x))
+(define (%set-class-direct-default-initargs! c x)
+                                         (%slot-set! c 'direct-default-initargs x))
+(define (%set-class-direct-slots!   c x) (%slot-set! c 'direct-slots   x))
+(define (%set-class-direct-supers!  c x) (%slot-set! c 'direct-supers  x))
+(define (%set-class-slots!          c x) (%slot-set! c 'slots          x))
+(define (%set-class-nfields!        c x) (%slot-set! c 'nfields        x))
+(define (%set-class-field-initializers! c x)
+                                         (%slot-set! c 'field-initializers x))
+(define (%set-class-getters-n-setters! c x)
+                                         (%slot-set! c 'getters-n-setters x))
+(define (%set-class-cpl!            c x) (%slot-set! c 'cpl            x))
+(define (%set-class-name!           c x) (%slot-set! c 'name           x))
+(define (%set-class-initializers!   c x) (%slot-set! c 'initializers   x))
+(define (%set-class-valid-initargs! c x) (%slot-set! c 'valid-initargs x))
+(define (%set-generic-methods!      g x) (%slot-set! g 'methods        x))
+(define (%set-generic-arity!        g x) (%slot-set! g 'arity          x))
+(define (%set-generic-name!         g x) (%slot-set! g 'name           x))
+(define (%set-generic-combination!  g x) (%slot-set! g 'combination    x))
+(define (%set-method-specializers!  m x) (%slot-set! m 'specializers   x))
+(define (%set-method-procedure!     m x) (%slot-set! m 'procedure      x))
+(define (%set-method-qualifier!     m x) (%slot-set! m 'qualifier      x))
+(define (%set-method-name!          m x) (%slot-set! m 'name           x))
+
+;;; These are used to access the two slots that optimize generic invocations.
+(define (%generic-app-cache            g  ) (%slot-ref  g 'app-cache))
+(define (%generic-singletons-list      g  ) (%slot-ref  g 'singletons-list))
+(define (%set-generic-app-cache!       g x) (%slot-set! g 'app-cache x))
+(define (%set-generic-singletons-list! g x) (%slot-set! g 'singletons-list x))
+
+;;; The next 7 clusters define the 6 initial classes.  It takes 7 to 6 because
+;;; the first and fourth both contribute to <class>.
+
+(define the-slots-of-a-class
+  '(default-initargs
+    direct-default-initargs    ; ((name form thunk) ...)
+    direct-supers              ; (class ...)
+    direct-slots               ; ((name . options) ...)
+    cpl                        ; (class ...)
+    slots                      ; ((name . options) ...)
+    nfields                    ; an integer
+    field-initializers         ; (proc ...)
+    getters-n-setters          ; ((slot-name getter setter) ...)
+    name                       ; a symbol
+    initializers               ; (proc ...)
+    valid-initargs))           ; (initarg ...) or #f
+(define getters-n-setters-for-class ; see lookup-slot-info
+  (map (lambda (s)
+         (let ([f (position-of s the-slots-of-a-class)])
+           (list s
+                 (lambda (o)   (%instance-ref  o f))
+                 (lambda (o n) (%instance-set! o f n)))))
+       the-slots-of-a-class))
+
+;;>>...
+;;> *** Basic classes
+
+;;>> <class>
+;;>   This is the "mother of all classes": every Swindle class is an
+;;>   instance of `<class>'.
+;;>   Slots:
+;;>   * default-initargs: initargs
+;;>   * direct-default-initargs: direct initargs
+;;>   * direct-supers:  direct superclasses
+;;>   * direct-slots:   direct slots, each a list of a name and options
+;;>   * cpl:            class precedence list (classes list this to <top>)
+;;>   * slots:          all slots (like direct slots)
+;;>   * nfields:        number of fields
+;;>   * field-initializers: a list of functions to initialize slots
+;;>   * getters-n-setters:  an alist of slot-names, getters, and setters
+;;>   * name:           class name (usually the defined identifier)
+;;>   * initializers:   procedure list that perform additional initializing
+;;>   See the `clos' documentation for available class and slot keyword
+;;>   arguments and their effect.
+(define* <class> (%allocate-instance #f (length the-slots-of-a-class)))
+(set-instance-class-to-self! <class>)
+
+;; In the original tiny-clos, this block used to just set the getters-n-setters
+;; slot of a class to '() since it wasn't used anyway.  In Swindle the MOP
+;; accessors are all optimized to directly get the vector element because the
+;; meta hierarchy is assumed to be single-inheritance only (allocation of more
+;; slots always come after the built in ones), so what I do here is set the
+;; slot value properly, and since `%class-getters-n-setters' accesses the
+;; vector directly it doesn't go through slot-ref, which means that the
+;; slot-ref definition above is fine. So,
+;;   (%set-class-getters-n-setters! <class> getters-n-setters-for-class)
+;; translates into this:
+((caddr (assq 'getters-n-setters getters-n-setters-for-class))
+ <class> getters-n-setters-for-class)
+;; and now the direct `%class-getters-n-setters' version:
+(set! %class-getters-n-setters
+      ;; and (lookup-slot-info <class> 'getters-n-setters caddr) translates to:
+      (cadr (assq 'getters-n-setters getters-n-setters-for-class)))
+
+;;>> <top>
+;;>   This is the "mother of all values": every value is an instance of
+;;>   `<top>' (including standard Scheme values).
+(define* <top> (make <class> :direct-default-initargs '()
+                             :direct-supers '()
+                             :direct-slots  '()
+                             :name          '<top>))
+
+;;>> <object>
+;;>   This is the "mother of all objects": every Swindle object is an
+;;>   instance of `<object>'.
+(define* <object> (make <class> :direct-default-initargs '()
+                                :direct-supers (list <top>)
+                                :direct-slots  '()
+                                :name          '<object>))
+
+;;; This cluster, together with the first cluster above that defines <class>
+;;; and sets its class, have the effect of:
+;;;   (define <class>
+;;;     (make <class> :direct-default-initargs '()
+;;;                   :direct-supers (list <object>)
+;;;                   :direct-slots  '(direct-supers ...)
+;;;                   :name          '<class>))
+(%set-class-default-initargs!   <class> '())
+(%set-class-direct-default-initargs! <class> '())
+(%set-class-direct-supers!      <class> (list <object>))
+(%set-class-cpl!                <class> (list <class> <object> <top>))
+(%set-class-direct-slots!       <class> (map list the-slots-of-a-class))
+(%set-class-slots!              <class> (map list the-slots-of-a-class))
+(%set-class-nfields!            <class> (length the-slots-of-a-class))
+(%set-class-field-initializers! <class> (map (lambda (s)
+                                               unspecified-initializer)
+                                             the-slots-of-a-class))
+(%set-class-name!               <class> '<class>)
+(%set-class-initializers!       <class> '())
+(%set-class-valid-initargs!     <class> #f)
+
+;;>> <procedure-class>
+;;>   The class of all procedures classes, both standard Scheme procedures
+;;>   classes and entity (Swindle procedure objects) classes.  (Note that
+;;>   this is a class of *classes*).
+(define* <procedure-class>
+  (make <class> :direct-default-initargs '()
+                :direct-supers (list <class>)
+                :direct-slots  '()
+                :name          '<procedure-class>))
+
+;;>> <entity-class>
+;;>   The class of entity classes -- generic functions and methods.  An
+;;>   entity is a procedural Swindle object, something that you can apply as
+;;>   a function but it is still a Swindle object.  Note that this is the
+;;>   class of entity *classes* not of entities themselves.
+(define* <entity-class>
+  (make <class> :direct-default-initargs '()
+                :direct-supers (list <procedure-class>)
+                :direct-slots  '()
+                :name          '<entity-class>))
+
+;;>> <function>
+;;>   The class of all applicable values: methods, generic functions, and
+;;>   standard closures.
+(define* <function>
+  (make <class> :direct-default-initargs '()
+                :direct-supers (list <top>)
+                :direct-slots  '()
+                :name          '<function>))
+
+;;; The two extra slots below (app-cache and singletons-list) are used to
+;;; optimize generic invocations: app-cache holds an 'equal hash-table that
+;;; maps a list of classes to the lambda expression that holds the method call
+;;; (it used to be an l-hash-table, but 'equal is ok since we can't compare
+;;; swindleobj instances recursively -- which is also why tool.ss needs to
+;;; redefine the `render-value/format' method).  The contents of this slot is
+;;; reset whenever a method is added to the generic.  Two problems make things
+;;; a little more complicated.  First, if add-method is used to modify any of
+;;; the generic-invocation-generics then all of these caches should be flushed,
+;;; this is achieved by setting *generic-app-cache-tag* to a new [list] object
+;;; and the value of app-cache is a cons of that value and the actual hash
+;;; table - if we see that the car is not eq? to the current tag, then we flush
+;;; the cache.  Second, singleton values might screw things up, so we hold in
+;;; singletons-list a list that has the same length as all method specializer
+;;; lists, each element contains a hash table with all singleton values that
+;;; appear in that place matched to #t, then when we try to see if we have a
+;;; cached function for a generic application, we scan the argument list
+;;; against this list, and any value that has a singleton with that value at
+;;; some method, is left in place for the app-cache lookup (it is used itself
+;;; rather than its class).  This whole thing is a bit complicated but leads to
+;;; dramatic run-time improvement.
+;;>> <generic>
+;;>   The class of generic functions: objects that contain method objects
+;;>   and calls the appropriate ones when applied.
+;;>   Slots:
+;;>   * methods:     a list of <method> objects
+;;>   * arity:       the generic arity (same for all of its methods)
+;;>   * name:        generic name
+;;>   * combination: a method combination function or #f, see
+;;>                  `make-generic-combination' below for details
+(define* <generic>
+  (make <entity-class> :direct-default-initargs '()
+                       :direct-supers (list <object> <function>)
+                       :direct-slots  '(methods arity name combination
+                                        app-cache singletons-list) ; see above
+                       :name          '<generic>))
+
+;;>> <method>
+;;>   The class of methods: objects that are similar to Scheme closures,
+;;>   except that they have type specifiers attached.  Note that in contrast
+;;>   to Tiny CLOS, methods are applicable objects in Swindle -- they check
+;;>   supplied argument types when applied.
+;;>   Slots:
+;;>   * specializers: a list of class (and singleton) specializers
+;;>   * procedure:    the function (never call directly!)
+;;>   * qualifier:    some qualifier tag, used when applying a generic
+;;>   * name:         method name
+(define* <method>
+  (make <entity-class> :direct-default-initargs '()
+                       :direct-supers (list <object> <function>)
+                       :direct-slots  '(specializers procedure qualifier name)
+                       :name          '<method>))
+;; Do this since compute-apply-method relies on them not changing, as well as a
+;; zillion other places.  A method should be very similar to a lambda.
+(dolist [slot '(specializers procedure qualifier)]
+  (make-setter-locked! (lookup-slot-info <method> slot cdr) #t
+    (lambda ()
+      (raise* make-exn:fail:contract
+              "slot-set!: slot `~e' in <method> is locked" slot))))
+
+;;>>...
+;;> *** Convenience functions
+;;>
+;;> These are some convenience functions -- no new syntax, just function
+;;> wrappers for `make' with some class and some slot values.  See `clos'
+;;> for a more sophisticated (and convenient) approach.
+
+;;; These are the convenient syntax we expose to the base-level user.
+;;>> (make-class direct-supers direct slots)
+;;>   Creates a class object -- an instance of <class>.
+(define* (make-class direct-supers direct-slots)
+  (make <class> :direct-default-initargs '()
+                :direct-supers direct-supers
+                :direct-slots  direct-slots))
+;;>> (make-generic-function [name/arity])
+;;>   Creates a generic function object -- an instance of <generic>.  The
+;;>   argument can specify name and/or arguments number.
+(define* (make-generic-function . name/arity)
+  (cond
+   [(null? name/arity) (make <generic>)]
+   [(null? (cdr name/arity))
+    (let ([n/a (car name/arity)])
+      (if (integer? n/a)
+        (make <generic> :arity n/a) (make <generic> :name n/a)))]
+   [else (make <generic> :name (car name/arity) :arity (cadr name/arity))]))
+;;>> (make-method specializers procedure)
+;;>   Creates a method object -- an instance of <method>, using the given
+;;>   specializer list and procedure.  The procedure should have a first
+;;>   argument which is being used to access a `call-next-method' call.
+(define* (make-method specializers procedure)
+  (make <method> :specializers specializers
+                 :procedure    procedure))
+
+;;>> (no-next-method generic method [args ...])
+;;>> (no-applicable-method generic [args ...])
+;;>   These two generic functions are equivalents to the ones in CL.  The
+;;>   first one is applied on a generic and a method in case there was no
+;;>   next method and `call-next-method' was used.  The second is used when
+;;>   a generic was called but no matching primary methods were found.  The
+;;>   only difference is that in Swindle methods can be applied directly,
+;;>   and if `call-next-method' is used, then `no-next-method' gets `#f' for
+;;>   the generic argument.
+(define* no-next-method       (make-generic-function 'no-next-method))
+(define* no-applicable-method (make-generic-function 'no-applicable-method))
+
+;;; Add possibility of generic-independent method application - this is the
+;;; instance-proc of methods, which is activated when you apply the object (in
+;;; the original, methods could not be applied).  This is defined using this
+;;; name and arguments because it is later used directly by the generic
+;;; function (cannot use the generic in the inital make since methods need to
+;;; be created when the generics are constructed).
+(define (method:compute-apply-method call-next-method method)
+  (let* ([specializers (%method-specializers method)]
+         [*no-next-method* ; see the *no-next-method* trick below
+          (lambda args (no-next-method #f method . args))]
+         [proc     (%method-procedure method)]
+         [arity    (method-arity method)]
+         [exact?   (integer? arity)]
+         [required ((if exact? identity arity-at-least-value) arity)])
+    (when (and exact? (> (length specializers) required))
+      (error 'compute-apply-method
+             "got ~e specializers for ~s - too much for procedure arity ~a"
+             (length specializers) (%method-name method) required))
+    (lambda args
+      (cond [(if exact?
+               (not (= (length args) required)) (< (length args) required))
+             (raise* make-exn:fail:contract:arity
+                     "method ~a: expects ~a~e argument~a, given ~e~a"
+                     (%method-name method)
+                     (if exact? "" "at least ") required
+                     (if (= 1 required) "" "s") (length args)
+                     (if (null? args) "" (format ": ~e" args)))]
+            [(not (every instance-of? args specializers))
+             (let loop ([args args] [specs specializers])
+               (if (instance-of? (car args) (car specs))
+                 (loop (cdr args) (cdr specs))
+                 (raise* make-exn:fail:contract
+                         "method ~a: expects argument of type ~a; given ~e"
+                         (%method-name method) (%class-name (car specs))
+                         (car args))))]
+            [else (proc *no-next-method* . args)]))))
+
+;;>>... Generics in the instance initialization protocol
+;;> The following generic functions are used as part of the protocol of
+;;> instantiating an instance, and some are used specifically to instantiate
+;;> class objects.
+
+;;; The instance structure protocol.
+;;>> (allocate-instance class initargs)
+;;>   This generic function is called to allocate an instance of a class.
+;;>   It is applied on the class object, and is expected to return the new
+;;>   instance object of that class.
+(define* allocate-instance
+  (make-generic-function 'allocate-instance))
+;;>> (initialize instance initargs)
+;;>   This generic is called to initialize an instance.  It is applied on
+;;>   the newly allocated object and the given initargs, and is not expected
+;;>   to return any meaningful value -- only do some side effects on the
+;;>   instance to initialize it.  When overriding this for a some class, it
+;;>   is not a good idea to skip `call-next-method' since it is responsible
+;;>   for initializing slot values.
+(define* initialize
+  (make-generic-function 'initialize))
+;;>> (compute-getter-and-setter class slot allocator)
+;;>   This generic is used to get a getter and setter functions for a given
+;;>   slot.  It is passed the class object, the slot information (a list of
+;;>   a slot name and options), and an allocator function.  The allocator is
+;;>   a function that gets an initializer function and returns an index
+;;>   position for the new slot.  The return value should be a list of two
+;;>   elements -- a getter and a setter functions.
+(define* compute-getter-and-setter
+  (make-generic-function 'compute-getter-and-setter))
+;;; The class initialization protocol.
+;;>> (compute-cpl class)
+;;>   This generic is used to get the class-precedence-list for a class
+;;>   object.  The standard <class> object uses the `compute-std-cpl' (see
+;;>   in the code) which flattens the class ancestors using a topological
+;;>   sort that resolve ambiguities left-to-right.
+(define* compute-cpl
+  (make-generic-function 'compute-cpl))
+;;>> (compute-slots class)
+;;>   This generic is used to compute all slot information for a given
+;;>   class, after its precedence list has been computed.  The standard
+;;>   <class> collects information from all preceding classes.
+(define* compute-slots
+  (make-generic-function 'compute-slots))
+
+;;>> (compute-default-initargs class)
+;;>   This generic is used to compute the default initargs for a given
+;;>   class.
+(define* compute-default-initargs
+  (make-generic-function 'compute-default-initargs))
+
+;;>> (compute-apply-method method)
+;;>   This generic is used to compute the procedure that will get executed
+;;>   when a method is applied directly.
+(define* compute-apply-method
+  (make-generic-function 'compute-apply-method))
+
+;;>>... Generics in the generic invocation protocol
+;;> These generics are used for invocation of generic functions.  See the
+;;> code to see how this circularity is achieved.
+
+;;>> ((compute-apply-generic generic) args ...)
+;;>   This generic is used to compute the object (a closure) that is
+;;>   actually applied to execute the generic call.  The standard version
+;;>   uses `compute-method' and `compute-apply-methods' below, and caches
+;;>   the result.
+(define* compute-apply-generic
+  (make-generic-function 'compute-apply-generic))
+;;>> (compute-methods generic args)
+;;>   Computes the methods that should be applied for this generic
+;;>   invocation with args.  The standard code filters applicable methods
+;;>   and sorts them according to their specificness.  The return value is
+;;>   expected to depend only on the types of the arguments (and values if
+;;>   there are singleton specializers).
+(define* compute-methods
+  (make-generic-function 'compute-methods))
+;;>> ((compute-method-more-specific? generic) mthd1 mthd2 args)
+;;>   Get a generic and return a function that gets two methods and a list
+;;>   of arguments and decide which of the two methods is more specific.
+;;>   This decision should only be based on the argument types, or values
+;;>   only in case of singletons.
+(define* compute-method-more-specific?
+  (make-generic-function 'compute-method-more-specific?))
+;;>> ((compute-apply-methods generic methods) args ...)
+;;>   Gets a generic and returns a function that gets the given arguments
+;;>   for this call.  This function which it returns is the combination of
+;;>   all given methods.  The standard one arranges them by default using
+;;>   the `call-next-method' argument that methods have.  Swindle extends
+;;>   this with qualified methods and applies `before', `after', and
+;;>   `around' methods in a similar way to CLOS: first the `around' methods
+;;>   are applied (and they usually call their `call-next-method' to
+;;>   continue but can return a different value), then all the `before'
+;;>   methods are applied (with no `call-next-method'), then all `primary'
+;;>   methods as usual (remembering the return value), and finally the
+;;>   `after' methods (similar to the `before', but in reverse specificness
+;;>   order).  If the generic has a `combination' slot value, then it is a
+;;>   procedure that is used to combine the primary methods, but the
+;;>   auxiliary ones are still applied in the same way.  This is unlike CLOS
+;;>   where the standard combinations run only `around' methods, and there
+;;>   is generally more control with method combinations, but in Swindle
+;;>   `compute-apply-methods' should be overridden for this.  See
+;;>   `make-generic-combination' for details about method combinations.
+(define* compute-apply-methods
+  (make-generic-function 'compute-apply-methods))
+
+;;; The next thing to do is bootstrap generic functions.
+
+(define generic-invocation-generics
+  (list compute-apply-generic compute-methods
+        compute-method-more-specific? compute-apply-methods))
+
+;;; This is used to signal whenever all method caches are to be reset - so when
+;;; a method is added to generic-invocation-generics, this is set to some value
+;;; which is not eq? to the current one.
+(define *generic-app-cache-tag* #t)
+
+;;>> (add-method generic method)
+;;>   This generic function is called to add a method to a generic function
+;;>   object.  This is an other change from the original Tiny CLOS where it
+;;>   was a normal function.
+(define* (add-method generic method)
+  ;; add singleton specializer value (if any) to the corresponding hash table
+  ;; in singletons-list.
+  (define (add-to-singletons-list specs tables)
+    (unless (null? specs)
+      (when (%singleton? (car specs))
+        (unless (car tables)
+          (set-car! tables (make-hash-table 'weak)))
+        (hash-table-put! (car tables) (singleton-value (car specs)) #t))
+      (add-to-singletons-list (cdr specs) (cdr tables))))
+  (define (n-falses n)
+    (let loop ([n n] [r '()]) (if (zero? n) r (loop (sub1 n) (cons #f r)))))
+  (let ([tables    (%generic-singletons-list generic)]
+        [specs     (%method-specializers method)]
+        [qualifier (%method-qualifier method)])
+    ;; make sure that tables always contain enough hash tables (or #f's)
+    (cond [(eq? tables ???)
+           (set! tables (n-falses (length specs)))
+           (%set-generic-singletons-list! generic tables)]
+          [(< (length tables) (length specs))
+           (set! tables (append!
+                         tables
+                         (n-falses (- (length specs) (length tables)))))
+           (%set-generic-singletons-list! generic tables)])
+    (add-to-singletons-list specs tables)
+    (if (memq generic generic-invocation-generics)
+      ;; reset all caches by changing the value of *generic-app-cache-tag*
+      (set! *generic-app-cache-tag* (list #f))
+      ;; reset this generic app-cache
+      (%set-generic-app-cache! generic ???))
+    (%set-generic-methods!
+     generic
+     (cons method
+           (filter (lambda (m)
+                     (not (and (every eq? (method-specializers m) specs)
+                               (eq? (%method-qualifier m) qualifier))))
+                   (%generic-methods generic))))
+    (set-instance-proc! generic (compute-apply-generic generic))))
+
+;;; Adding a method calls COMPUTE-APPLY-GENERIC, the result of which calls the
+;;; other generics in the generic invocation protocol.  Two, related, problems
+;;; come up.  A chicken and egg problem and a infinite regress problem.
+;;; In order to add our first method to COMPUTE-APPLY-GENERIC, we need
+;;; something sitting there, so it can be called.  The first definition below
+;;; does that.
+;;; Then, the second definition solves both the infinite regress and the not
+;;; having enough of the protocol around to build itself problem the same way:
+;;; it special cases invocation of generics in the invocation protocol.
+
+(set-instance-proc! compute-apply-generic
+  (lambda (generic)
+    ((%method-procedure (car (%generic-methods generic))) '() generic)))
+
+(add-method compute-apply-generic
+  (make-method (list <generic>)
+    (named-lambda method:compute-apply-generic (call-next-method generic)
+      #| The code below is the original, then comes the optimized version below
+      ;; see the definition of the <generic> class above.
+      (lambda args
+        (if (and (memq generic generic-invocation-generics)    ;* Ground case
+                 (memq (car args) generic-invocation-generics))
+          (apply (%method-procedure (last (%generic-methods generic))) #f args)
+          ((compute-apply-methods generic)
+           (compute-methods generic args) . args)))
+      |#
+      ;; This function converts the list of arguments to a list of keys to look
+      ;; for in the cache - use the argument's class except when there is a
+      ;; corresponding singleton with the same value at the same position.
+      (define (get-keys args tables)
+        (let loop ([args args] [tables tables] [ks '()])
+          (if (or (null? tables) (null? args))
+            (reverse! ks)
+            (loop (cdr args) (cdr tables)
+                  (cons (if (and (car tables)
+                                 (hash-table-get
+                                  (car tables) (car args) false-func))
+                          (car args)
+                          (class-of (car args)))
+                        ks)))))
+      ;; This is the main function that brings the correct value from the
+      ;; cache, or generates one and store it if there is no entry, or the
+      ;; cache was reset.  Finally, it is applied to the arguments as usual.
+      ;; NOTE: This code is delicate! Handle with extreme care!
+      (lambda args
+        (let ([app-cache (%generic-app-cache generic)]
+              [arity     (%generic-arity generic)]
+              [keys      (get-keys args (%generic-singletons-list generic))]
+              [ground?   (and ;* Ground case
+                          (memq generic generic-invocation-generics)
+                          (pair? args)
+                          (memq (car args) generic-invocation-generics))])
+          ;; This function creates the cached closure -- the assumption is that
+          ;; `keys' contain a specification that will identify all calls that
+          ;; will have this exact same list.
+          (define (compute-callable)
+            (let ([c (if ground?
+                       (let ([m (%method-procedure
+                                 (last (%generic-methods generic)))])
+                         (lambda args (apply m #f args)))
+                       (compute-apply-methods
+                        generic (compute-methods generic args)))])
+              (hash-table-put! (cdr app-cache) keys c)
+              c))
+          (when (cond [(not arity) #f]
+                      [(integer? arity) (not (= (length args) arity))]
+                      [else (< (length args) (arity-at-least-value arity))])
+            (let ([least (and (arity-at-least? arity)
+                              (arity-at-least-value arity))])
+              (raise* make-exn:fail:contract:arity
+                      "generic ~a: expects ~a~e argument~a, given ~e~a"
+                      (%generic-name generic)
+                      (if least "at least " "") (or least arity)
+                      (if (= 1 (or least arity)) "" "s") (length args)
+                      (if (null? args) "" (format ": ~e" args)))))
+          (when (or (eq? app-cache ???)
+                    (not (eq? (car app-cache) *generic-app-cache-tag*)))
+            (set! app-cache (cons *generic-app-cache-tag*
+                                  (make-hash-table 'weak 'equal)))
+            (%set-generic-app-cache! generic app-cache))
+          ((hash-table-get (cdr app-cache) keys compute-callable)
+           . args))))))
+
+(add-method compute-methods
+  (make-method (list <generic>)
+    (named-lambda method:compute-methods (call-next-method generic args)
+      (let ([more-specific? (compute-method-more-specific? generic)])
+        (sort (filter
+               (lambda (m)
+                 ;; Note that every only goes as far as the shortest list
+                 (every instance-of? args (%method-specializers m)))
+               (%generic-methods generic))
+              (lambda (m1 m2) (more-specific? m1 m2 args)))))))
+
+(add-method compute-method-more-specific?
+  (make-method (list <generic>)
+    (named-lambda method:compute-method-more-specific?
+                  (call-next-method generic)
+      (lambda (m1 m2 args)
+        (let loop ([specls1 (%method-specializers m1)]
+                   [specls2 (%method-specializers m2)]
+                   [args    args])
+          (cond [(and (null? specls1) (null? specls2))
+                 (if (eq? (%method-qualifier m1) (%method-qualifier m2))
+                   (error 'generic
+                          "two methods are equally specific in ~e" generic)
+                   #f)]
+                ;; some methods in this file have less specializers than
+                ;; others, for things like args -- so remove this, leave the
+                ;; args check but treat the missing as if it's <top>
+                ;; ((or (null? specls1) (null? specls2))
+                ;;  (error 'generic
+                ;;         "two methods have different number of ~
+                ;;          specializers in ~e" generic))
+                [(null? args) ; shouldn't happen
+                 (error 'generic
+                        "fewer arguments than specializers for ~e" generic)]
+                [(null? specls1) ; see above -> treat this like <top>
+                 (if (eq? <top> (car specls2))
+                   (loop specls1 (cdr specls2) (cdr args))
+                   #f)]
+                [(null? specls2) ; see above -> treat this like <top>
+                 (if (eq? <top> (car specls1))
+                   (loop (cdr specls1) specls2 (cdr args))
+                   #t)]
+                [else (let ([c1 (car specls1)] [c2 (car specls2)])
+                        (if (eq? c1 c2)
+                          (loop (cdr specls1) (cdr specls2) (cdr args))
+                          (more-specific? c1 c2 (car args))))]))))))
+
+(add-method compute-apply-methods
+  (make-method (list <generic>)
+    (named-lambda method:compute-apply-methods
+                  (call-next-method generic methods)
+      (let ([primaries '()] [arounds '()] [befores '()] [afters '()]
+            [combination (%generic-combination generic)])
+        ;; *** Trick: this (and in <method> above) is the only code that is
+        ;; supposed to ever apply a method procedure.  So, the closure that
+        ;; will invoke `no-next-method' is named `*no-next-method*' so it is
+        ;; identifiable.  The only way to break this would be to call the
+        ;; method-procedure directly on an object with such a name.
+        (define one-step
+          (if combination
+            (combination generic)
+            (lambda (tail args)
+              (lambda newargs
+                ;; tail is never null: (null? (cdr tail)) below, and the fact
+                ;; that this function is applied on the primaries which are
+                ;; never null
+                (let ([args (if (null? newargs) args newargs)])
+                  ((cdar tail)
+                   (if (null? (cdr tail))
+                     (named-lambda *no-next-method* args
+                       (no-next-method generic (caar tail) . args))
+                     (one-step (cdr tail) args))
+                   . args))))))
+        (define ((apply-before/after-method args) method)
+          ((cdr method)
+           (named-lambda *no-next-method* args
+             (no-next-method generic (car method) . args))
+           . args))
+        (define ((call-before-primary-after args) . newargs)
+          ;; could supply newargs below, but change before calling befores
+          (let ([args (if (null? newargs) args newargs)])
+            (for-each (apply-before/after-method args) befores)
+            (begin0 ((one-step primaries args))
+              (for-each (apply-before/after-method args) afters))))
+        (define (one-around-step tail args)
+          (if (null? tail)
+            (call-before-primary-after args)
+            (lambda newargs
+              (let ([args (if (null? newargs) args newargs)])
+                ((cdar tail) (one-around-step (cdr tail) args) . args)))))
+        ;; first sort by qualifier and pull out method-procedures
+        (let loop ([ms methods])
+          (unless (null? ms)
+            (letsubst ([(push! p)
+                        (set! p (cons (cons (car ms)
+                                            (%method-procedure (car ms)))
+                                      p))])
+              (case (%method-qualifier (car ms))
+                [(:primary) (push! primaries)]
+                [(:around)  (push! arounds)]
+                [(:before)  (push! befores)]
+                [(:after)   (push! afters)]
+                ;; ignore other qualifiers
+                ;; [else (error 'compute-apply-methods
+                ;;              "a method ~e has an unexpected qualifier `~e'"
+                ;;              (car methods)
+                ;;              (%method-qualifier (car methods)))]
+                )
+            (loop (cdr ms)))))
+        (set! primaries (reverse! primaries))
+        (set! arounds   (reverse! arounds))
+        (set! befores   (reverse! befores))
+        ;; no reverse! for afters
+        (cond [(null? primaries)
+               (lambda args (no-applicable-method generic . args))]
+              ;; optimize common case of only primaries
+              [(and (null? befores) (null? afters) (null? arounds))
+               ;; args is initialized to () since if it is a generic of no
+               ;; arguments then it will always stay so, otherwise, the first
+               ;; call will have the real arguments anyway
+               (one-step primaries '())]
+              [else (one-around-step arounds '())])))))
+
+;;>> (((make-generic-combination keys...) generic) tail args)
+;;>   This function can be used to construct simple method combinations that
+;;>   can be used with the `combination' slot of generic functions.  The
+;;>   combination itself is a function that gets a generic and returns a
+;;>   function that gets a list of method/procedure pairs (for optimization
+;;>   the method-procedures are pre taken) and the arguments and performs
+;;>   the call -- but this is only interesting if there's any need to
+;;>   implement a method combination directly, otherwise, the
+;;>   `make-generic-combination' interface should allow enough freedom.
+;;>   Note that when a method combination is used, `around', `before', and
+;;>   `after' are called around the primary call as usual, but the primaries
+;;>   are never called with a valid `call-next-method' argument.
+;;>
+;;>   The keyword arguments that can be taken determine the behavior of this
+;;>   combination.  Overall, it is roughly like a customizable version of a
+;;>   fold operation on the method calls.
+;;>   * :init
+;;>     - The initial value for this computation.  Defaults to null.
+;;>   * :combine
+;;>     - A function to be called on a method call result and the old value,
+;;>       and produces a new value.  The default is `cons', which with an
+;;>       initial null value will collect the results into a reversed list.
+;;>   * :process-methods
+;;>     - A function that can be called on the initial list of
+;;>       method/procedure pairs to change it -- for example, it can be
+;;>       reversed to apply the methods from the least specific to the most
+;;>       specific.  No default.
+;;>   * :process-result
+;;>     - A function that can be called on the final resulting value to
+;;>       produce the actual return value.  For example, it can reverse back
+;;>       a list of accumulated values.  No default.
+;;>   * :control
+;;>     - If this parameter is specified, then the `:combine' argument is
+;;>       ignored.  The value given to `:control' should be a function of
+;;>       four arguments:
+;;>       1. a `loop' function that should be called on some new value and
+;;>          some new tail;
+;;>       2. a `val' argument that gets the current accumulated value;
+;;>       3. a `this' thunk that can be called to apply the current method
+;;>          and return its result;
+;;>       4. a `tail' value that holds the rest of the method/procedure list
+;;>          which can be sent to `loop'.
+;;>       It should be clear now, that a `:control' argument can have a lot
+;;>       of control on the computation, it can abort, change arbitrary
+;;>       values and skip calling methods.  Note that if it won't call
+;;>       `loop' with an empty list, then a `:process-result' function will
+;;>       not be used as well.  See the pre-defined combinations in the
+;;>       source code to see examples of using this function.
+(define* (make-generic-combination
+          &key [init '()] [combine cons]
+               process-methods process-result control)
+  (lambda (generic)
+    (lambda (tail dummy-args)
+      (let ([tail (if process-methods (process-methods tail) tail)])
+        (lambda args
+          (let loop ([res init] [tail tail])
+            ;; see *no-next-method* trick above
+            (let ([*no-next-method*
+                   (lambda args (no-next-method generic (caar tail) . args))])
+              (if (null? tail)
+                (if process-result (process-result res) res)
+                (if control
+                  (control loop res
+                           (lambda () ((cdar tail) *no-next-method* . args))
+                           (cdr tail))
+                  (loop (combine ((cdar tail) *no-next-method* . args) res)
+                        (cdr tail)))))))))))
+
+;;>> generic-+-combination
+;;>> generic-list-combination
+;;>> generic-min-combination
+;;>> generic-max-combination
+;;>> generic-append-combination
+;;>> generic-append!-combination
+;;>> generic-begin-combination
+;;>> generic-and-combination
+;;>> generic-or-combination
+;;>   These are all functions that can be used as a `combination' value for
+;;>   a generic function.  They work in the same way as the standard method
+;;>   combinations of CL.  Most of them do the obvious thing based on some
+;;>   function to combine the result.  The `begin' combination simply
+;;>   executes all methods one by one and returns the last value, the `and'
+;;>   and `or' combinations will call them one by one until a false or true
+;;>   result is returned.  The source of these can be used as templates for
+;;>   defining more combinations.
+(define* generic-+-combination
+  (make-generic-combination :init 0 :combine +))
+(define* generic-list-combination
+  (make-generic-combination :process-result reverse!))
+(define* generic-min-combination
+  (make-generic-combination :process-result (lambda (r) (apply min r))))
+(define* generic-max-combination
+  (make-generic-combination :process-result (lambda (r) (apply max r))))
+(define* generic-append-combination
+  (make-generic-combination
+   :process-result (lambda (r) (apply append (reverse! r)))))
+(define* generic-append!-combination
+  (make-generic-combination
+   :process-result (lambda (r) (apply append! (reverse! r)))))
+(define* generic-begin-combination
+  (make-generic-combination :init #f :combine (lambda (x y) x)))
+(define* generic-and-combination
+  (make-generic-combination
+   :init #t :combine (lambda (x y) (and x y))
+   :control (lambda (loop val this tail) (and val (loop (this) tail)))))
+(define* generic-or-combination
+  (make-generic-combination
+   :init #f :combine (lambda (x y) (and x y))
+   :control (lambda (loop val this tail) (or (this) (loop #f tail)))))
+
+;;>>...
+;;> *** More class functionality
+;;> (In the following, a `class' can be a class, a singleton specifier, or a
+;;> struct type.)
+
+;; optimized helper
+(defsubst (%struct->class c)
+  (if (struct-type? c) (struct-type->class c) c))
+
+;;>> (subclass? class1 class2)
+;;>   Is `class1' a subclass of `class2'?
+(define* (subclass? c1 c2)
+  (if (%singleton? c1)
+    (if (%singleton? c2)
+      (eq? (singleton-value c1) (singleton-value c2))
+      (instance-of? (singleton-value c1) (%struct->class c2)))
+    (memq (%struct->class c2) (%class-cpl (%struct->class c1)))))
+
+;;>> (instance-of? x class)
+;;>   Checks if `x' is an instance of `class' (or one of its subclasses).
+(define* (instance-of? x c)
+  ;; efficiency: many cases use <top> (all untyped arguments)
+  (or (eq? c <top>)
+      (if (%singleton? c)
+        ;; efficiency: similar to `subclass?' above
+        (eq? (singleton-value c) x)
+        (memq (%struct->class c) (%class-cpl (%struct->class (class-of x)))))))
+
+;;>> (class? x)
+;;>   Determines whether `x' is a class.
+(define* (class? x) (instance-of? x <class>))
+(defsubst (%class? x) (instance-of? x <class>))
+
+;;>> (specializer? x)
+;;>   Determines whether `x' is a class, a singleton, or a struct-type.
+(define* (specializer? x) (or (class? x) (%singleton? x) (struct-type? x)))
+
+;;>> (more-specific? class1 class2 x)
+;;>   Is `class1' more specific than `class2' for the given value?
+(define* (more-specific? c1 c2 arg)
+  (if (%singleton? c1)
+    (and (eq? (singleton-value c1) arg)
+         (not (and (%singleton? c2) (eq? (singleton-value c1) arg))))
+    (let ([cc1 (memq (%struct->class c1) (%class-cpl (class-of arg)))])
+      (and cc1 (memq (%struct->class c2) (cdr cc1))))))
+
+(add-method initialize
+  (make-method (list <top>)
+    (named-lambda method:initialize (call-next-method object initargs)
+      (error 'initialize "can't initialize an instance of ~e"
+             (class-of object)))))
+
+(add-method initialize
+  (make-method (list <object>)
+    (named-lambda method:initialize (call-next-method object initargs)
+      (let* ([class (class-of object)]
+             [field-initializers (%class-field-initializers class)])
+        (for-each (lambda (init) (init . initargs))
+                  (%class-initializers class))
+        (let loop ([n 0] [inits field-initializers])
+          (when (pair? inits)
+            (%instance-set! object n ((car inits) . initargs))
+            (loop (+ n 1) (cdr inits))))))))
+
+(add-method initialize
+  (make-method (list <class>)
+    (named-lambda method:initialize (call-next-method class initargs)
+      (call-next-method)
+      ;; No checking on this.
+      (%set-class-direct-default-initargs!
+       class
+       (getarg initargs :direct-default-initargs '()))
+      (%set-class-direct-supers!
+       class
+       (let ([default (*default-object-class*)]
+             [supers (getarg initargs :direct-supers)])
+         ;; check valid supers, and always have an object class
+         (cond
+          [(not default) supers] ; check disabled
+          [(or (not supers) (null? supers)) (list (*default-object-class*))]
+          [(not (list? supers)) (error 'class "bad superclasses: ~e" supers)]
+          [else (let ([c (find-if
+                          (lambda (c)
+                            (not (and (%class? c) (subclass? c default))))
+                          supers)])
+                  (if c
+                    (error 'class "cannot inherit from a ~a, ~e"
+                           (if (%class? c) "non-object class" "non-class") c)
+                    supers))])))
+      (%set-class-direct-slots!
+       class
+       (let ([autoinitargs (getarg initargs :autoinitargs)])
+         (map (lambda (s)
+                (if (pair? s)
+                  (if (or (not autoinitargs)
+                          (getarg (cdr s) :initarg)
+                          (not (symbol? (car s))))
+                    s
+                    (list* (car s) :initarg (string->symbol
+                                             (string-append
+                                              ":" (symbol->string (car s))))
+                           (cdr s)))
+                  (list s)))
+              (getarg initargs :direct-slots '()))))
+      (%set-class-cpl!   class (compute-cpl   class))
+      (%set-class-slots! class (compute-slots class))
+      (%set-class-default-initargs! class (compute-default-initargs class))
+      (%set-class-name!  class (or (getarg initargs :name) '-anonymous-))
+      (let* ([nfields 0]
+             [field-initializers '()]
+             ;; allocator: give me an initializer function, get a slot number
+             [allocator (lambda (init)
+                          (let ([f nfields])
+                            (set! nfields (+ nfields 1))
+                            (set! field-initializers
+                                  (cons init field-initializers))
+                            f))]
+             [getters-n-setters (map (lambda (slot)
+                                       (cons (car slot)
+                                             (compute-getter-and-setter
+                                              class slot allocator)))
+                                     (%class-slots class))])
+        (%set-class-nfields! class nfields)
+        (%set-class-field-initializers! class (reverse! field-initializers))
+        (%set-class-getters-n-setters! class getters-n-setters))
+      (%set-class-initializers!
+       class (reverse
+              (mappend
+               (lambda (c)
+                 (if (instance-of? c <class>) (%class-initializers c) '()))
+               (cdr (%class-cpl class)))))
+      (%set-class-valid-initargs! ; for sanity checks
+       class (getarg initargs :valid-initargs
+                     (thunk (mappend (lambda (slot)
+                                       (getargs (cdr slot) :initarg))
+                                     (%class-slots class))))))))
+
+(add-method initialize
+  (make-method (list <generic>)
+    (named-lambda method:initialize (call-next-method generic initargs)
+      (call-next-method)
+      (%set-generic-methods! generic '())
+      (%set-generic-arity!   generic (getarg initargs :arity #f))
+      (%set-generic-name!    generic (or (getarg initargs :name) '-anonymous-))
+      (%set-generic-combination! generic (getarg initargs :combination))
+      (set-instance-proc!    generic
+                             (lambda args
+                               (raise* make-exn:fail:contract
+                                       "~s: no methods added yet"
+                                       (%generic-name generic)))))))
+
+(add-method initialize
+  (make-method (list <method>)
+    (named-lambda method:initialize (call-next-method method initargs)
+      (call-next-method)
+      (%set-method-specializers! method
+                                 (map (lambda (c) (%struct->class c))
+                                      (getarg initargs :specializers)))
+      (%set-method-procedure!    method (getarg initargs :procedure))
+      (%set-method-qualifier!    method (or (getarg initargs :qualifier)
+                                            :primary))
+      (%set-method-name!         method (or (getarg initargs :name)
+                                            '-anonymous-))
+      (set-instance-proc!        method (compute-apply-method method)))))
+
+(add-method allocate-instance
+  (make-method (list <class>)
+    (named-lambda method:allocate-instance (call-next-method class initargs)
+      (%allocate-instance class (length (%class-field-initializers class))))))
+
+(add-method allocate-instance
+  (make-method (list <entity-class>)
+    (named-lambda method:allocate-instance (call-next-method class initargs)
+      (%allocate-entity class (length (%class-field-initializers class))))))
+
+(add-method compute-cpl
+  (make-method (list <class>)
+    (named-lambda method:compute-cpl (call-next-method class)
+      (compute-std-cpl class %class-direct-supers))))
+
+(add-method compute-slots
+  (make-method (list <class>)
+    (named-lambda method:compute-slots (call-next-method class)
+      (let ([all-slots   (map %class-direct-slots (%class-cpl class))]
+            [final-slots #f])
+        (let collect ([to-process (apply append all-slots)]
+                      [result '()])
+          (if (null? to-process)
+            (set! final-slots result)
+            (let* ([name   (caar to-process)]
+                   [others '()]
+                   [remaining-to-process
+                    (filter (lambda (o)
+                              (if (eq? (car o) name)
+                                (begin (set! others (cons (cdr o) others)) #f)
+                                #t))
+                            to-process)])
+              (collect remaining-to-process
+                       (cons (cons name (apply append (reverse! others)))
+                             result)))))
+        ;; Sort the slots by order of appearance in cpl, makes them stay in the
+        ;; same index, allowing optimizations for single-inheritance
+        (let collect ([to-process (apply append (reverse! all-slots))]
+                      [result '()])
+          (cond [(null? to-process) (reverse! result)]
+                [(assq (caar to-process) result)
+                 (collect (cdr to-process) result)]
+                [else (collect (cdr to-process)
+                               (cons (assq (caar to-process) final-slots)
+                                     result))]))))))
+
+(add-method compute-default-initargs
+  (make-method (list <class>)
+    (named-lambda method:compute-slots (call-next-method class)
+      (reverse!
+       ;; Remove the duplicates from the less specific classes
+       (foldl
+        (lambda (initarg initlist)
+          (if (memf (lambda (already-seen)
+                      (eq? (car initarg) (car already-seen)))
+                    initlist)
+              initlist
+              (cons initarg initlist)))
+        '()
+        ;; Collect them into a list (if they aren't #F)
+        (foldr (lambda (initargs all-initargs)
+                 (if initargs
+                     (append initargs all-initargs)
+                     all-initargs))
+               '()
+               ;; Get all the initargs
+               (map %class-direct-default-initargs (%class-cpl class))))))))
+
+(add-method compute-getter-and-setter
+  (make-method (list <class>)
+    (letrec ([nothing "nothing"]
+             [l-getarg
+              ;; apply getarg on a list of names until get a value
+              (lambda (args initargs)
+                ;; give priority to first initargs
+                (if (null? initargs)
+                  nothing
+                  (let ([x (getarg args (car initargs) nothing)])
+                    (if (eq? x nothing) (l-getarg args (cdr initargs)) x))))])
+      (named-lambda method:compute-getter-and-setter
+                    (call-next-method class slot allocator)
+        (let ([initargs    (getargs (cdr slot) :initarg)]
+              [initializer (getarg (cdr slot) :initializer)]
+              [initvalue   (getarg (cdr slot) :initvalue ???)]
+              [type        (getarg (cdr slot) :type #f)]
+              [allocation  (getarg (cdr slot) :allocation :instance)]
+              [lock        (getarg (cdr slot) :lock #f)])
+          (define init
+            (if initializer
+              (if (eq? 0 (procedure-arity initializer))
+                (lambda args (initializer)) initializer)
+              (lambda args initvalue)))
+          (define (init-slot . args)
+            (let ([result (l-getarg args initargs)])
+              (when (eq? result nothing)
+                (set! result (apply init args)))
+              (when (and type (not (eq? result ???))
+                         (not (instance-of? result type)))
+                (error 'class
+                       "bad initial value type for slot ~e in ~e (~e not a ~e)"
+                       (car slot) class result type))
+              result))
+          (when (and type (not (specializer? type)))
+            (error 'class "bad type specifier for ~e: ~e" (car slot) type))
+          (case allocation
+            [(:instance)
+             (let* ([f (allocator init-slot)]
+                    [g+s (list (lambda (o) (%instance-ref o f))
+                               (if (and type (not (eq? <top> type)))
+                                 (lambda (o n)
+                                   (if (instance-of? n type)
+                                     (%instance-set! o f n)
+                                     (raise* make-exn:fail:contract
+                                             "slot-set!: wrong type for slot ~
+                                              ~e in ~e (~e not in ~e)"
+                                             (car slot) class n type)))
+                                 (lambda (o n) (%instance-set! o f n))))])
+               (when lock
+                 (make-setter-locked! g+s lock
+                   (lambda ()
+                     (raise* make-exn:fail:contract
+                             "slot-set!: slot `~e' in ~e is locked"
+                             (car slot) (%class-name class)))))
+               g+s)]
+            [(:class)
+             (unless (null? initargs)
+               (let ([setter #f])
+                 (%set-class-initializers!
+                  class
+                  (cons (lambda args
+                          (let ([result (l-getarg args initargs)])
+                            ;; cache the setter
+                            (unless setter
+                              (set! setter
+                                    (caddr (assq (car slot)
+                                                 (%class-getters-n-setters
+                                                  class)))))
+                            (unless (eq? result nothing)
+                              (setter #f result))))
+                        (%class-initializers class)))))
+             (if (and (assq (car slot) (%class-direct-slots class))
+                      (getarg (cdr (assq (car slot)
+                                         (%class-direct-slots class)))
+                              :allocation #f))
+               ;; the slot was declared as :class here
+               (let* ([cell (init)] ; default value - no arguments
+                      [g+s (list (lambda (o) cell)
+                                 (lambda (o n)
+                                   (if (and type (not (instance-of? n type)))
+                                     (raise*
+                                      make-exn:fail:contract
+                                      "slot-set!: wrong type for shared slot ~
+                                       ~e in ~e (~e not in ~e)"
+                                      (car slot) class n type)
+                                     (set! cell n))))])
+                 (when lock
+                   (make-setter-locked! (car slot) g+s lock
+                     (lambda ()
+                       (raise* make-exn:fail:contract
+                               "slot-set!: slot `~e' in ~e is locked"
+                               (car slot) (%class-name class)))))
+                 g+s)
+               ;; the slot was inherited as :class - fetch its getters/setters
+               (let loop ([cpl (cdr (%class-cpl class))])
+                 (cond [(assq (car slot) (%class-getters-n-setters (car cpl)))
+                        => cdr]
+                       [else (loop (cdr cpl))])))]
+            [else
+             (error 'class
+                    "allocation for ~e must be :class or :instance, got ~e"
+                    (car slot) allocation)]))))))
+
+;;; Use the previous function when populating this generic.
+(add-method compute-apply-method
+  (make-method (list <method>) method:compute-apply-method))
+
+(add-method no-next-method
+  (make-method (list <generic> <method>)
+    (lambda (call-next-method generic method . args)
+      (raise* make-exn:fail:contract
+              (concat "~s: no applicable next method to call"
+                      (case (%method-qualifier method)
+                        [(:before) " in a `before' method"]
+                        [(:before) " in an `after' method"]
+                        [else ""]))
+              (%generic-name generic)))))
+(add-method no-next-method
+  (make-method (list (singleton #f) <method>)
+    (lambda (call-next-method generic method . args)
+      (raise* make-exn:fail:contract
+              "~s: no applicable next method when calling a method directly"
+              (%method-name method)))))
+
+(add-method no-applicable-method
+  (make-method (list <generic>)
+    (lambda (call-next-method generic . args)
+      (raise* make-exn:fail:contract
+              "~s: no applicable primary methods for argument types ~e"
+              (%generic-name generic) (map class-of args)))))
+
+;;; ---------------------------------------------------------------------------
+;;; Customization variables
+
+;;>>... Swindle Customization Parameters
+
+;;>> *default-method-class*
+;;>> *default-generic-class*
+;;>> *default-class-class*
+;;>> *default-entityclass-class*
+;;>   These parameters specify default classes for the many constructor
+;;>   macros in `clos'.
+(define* *default-method-class*      (make-parameter <method>))
+(define* *default-generic-class*     (make-parameter <generic>))
+(define* *default-class-class*       (make-parameter <class>))
+(define* *default-entityclass-class* (make-parameter <entity-class>))
+
+;; an automatic superclass for all classes -- turned off for the builtins below
+;;>> *default-object-class*
+;;>   This parameter contains a value which is automatically made a
+;;>   superclass for all classes.  Defaults to `<object>'.
+(define* *default-object-class* (make-parameter #f))
+
+;;>> *make-safely*
+;;>   Setting this parameter to #t will make Swindle perform sanity checks
+;;>   on given initargs for creating an object.  This will make things
+;;>   easier for debugging, but also slower.  Defaults to `#f'.  Note that
+;;>   the sanity checks are done in `initialize'.
+;; This could be in `make', but `defclass' will call that with no slots to make
+;; the object and then call `initialize' with all arguments to actually create
+;; the class.
+(define* *make-safely* (make-parameter #f))
+
+(define (check-initargs class initargs)
+  ;; sanity check - verify sensible keywords given
+  (let ([valid-initargs (%class-valid-initargs class)])
+    (or (not valid-initargs)
+        (let loop ([args initargs])
+          (cond [(null? args) #t]
+                [(not (and (pair? args) (pair? (cdr args))))
+                 (error 'make "error in initargs for ~e; arg list not balanced"
+                        class)]
+                [(not (symbol? (car args)))
+                 (error 'make "error in initargs for ~e; ~e is not a keyword"
+                        class (car args))]
+                [(not (memq (car args) valid-initargs))
+                 (error 'make "error in initargs for ~e; unknown keyword: ~e"
+                        class (car args))]
+                [else (loop (cddr args))])))))
+
+(define (extend-initargs given-initargs class-initargs)
+  (let ((extended
+         (foldl (lambda (initarg initlist)
+                  (let ((key (car initarg)))
+                    (if (getarg given-initargs key)
+                        initlist
+                        (cons key (cons ((caddr initarg)) initlist)))))
+                '() class-initargs)))
+    (if (null? extended)
+        given-initargs
+        (append given-initargs extended))))
+
+;;; ---------------------------------------------------------------------------
+;;; Make `make' a generic function
+
+;;>>... Creating Instances
+
+;;; Now everything works, both generic functions and classes, so we can turn on
+;;; the real MAKE.
+;;; ELI: This is turned into a generic function - do this carefully - first
+;;; create the generic function and the method instances, then change make.
+
+;;>> (make class initargs ...)
+;;>   Create an instance of `class', which can be any Swindle class (except
+;;>   for some special top-level classes and built-in classes).
+;;>
+;;>   See the `Object Initialization Protocol' below for a description of
+;;>   generic functions that are involved in creating a Swindle object.
+(let ([m (make-method (list <class>)
+           (named-lambda method:make (call-next-method class . given-initargs)
+             (let* ([initargs (extend-initargs given-initargs (class-default-initargs class))]
+                    [instance (allocate-instance class initargs)])
+               (when (*make-safely*) (check-initargs class initargs))
+               (initialize instance initargs)
+               instance)))]
+      [g (make-generic-function 'make)])
+  (add-method g m)
+  (set! make g))
+
+;; The clean concept behind this is due to Joe Marshall.
+
+;;>> (rec-make (name class arg ...) ...)
+;;>   This is similar to:
+;;>
+;;>     (letrec ([name (make class arg ...)] ...)
+;;>       (values name ...))
+;;>
+;;>   except that the names are first bound to allocated instances with no
+;;>   initargs, and then they are initialized with all these bindings.  This
+;;>   is useful for situations where creating some instances needs other
+;;>   instances as values.  One sample usage is the way `defclass' makes the
+;;>   class binding available for slot specifications like `:type'.  Note
+;;>   that this is a special form, which invokes `allocate-instance' and
+;;>   `initialize' directly, so specializing `make' on some input will not
+;;>   change the way `rec-make' works.
+(define (rec-allocate-instance class given-initargs)
+  (allocate-instance class (extend-initargs given-initargs (class-default-initargs class))))
+
+(define (rec-initialize instance given-initargs)
+  (initialize instance (extend-initargs given-initargs (class-default-initargs (class-of instance)))))
+
+(defsubst* (rec-make (name class arg ...) ...)
+  (let ((name (rec-allocate-instance class (list arg ...))) ...)
+    (when (*make-safely*) (check-initargs class (list arg ...)) ...)
+    (rec-initialize name (list arg ...)) ...
+    (values name ...)))
+
+;;; ---------------------------------------------------------------------------
+;;; Make `add-method' a generic function
+
+;;; Use this to compute a name for the method.  specs is a list of classes or
+;;; class-names (in case of unnamed-methods in clos.ss).
+(define (compute-method-name specs generic-name)
+  (define (spec-string spec)
+    (cond [(%singleton? spec) (format "{~e}" (singleton-value spec))]
+          [(%class? spec)     (symbol->string
+                               (%class-name (%struct->class spec)))]
+          [else               "???"]))
+  (string->symbol
+   (apply string-append
+          (symbol->string generic-name) ":"
+          (if (null? specs)
+            '("()")
+            (cons (spec-string (car specs))
+                  (map (lambda (c) (string-append "," (spec-string c)))
+                       (cdr specs)))))))
+
+(let ([old-add-method add-method])
+  (set! add-method (make <generic> :name 'add-method :arity 2))
+  (old-add-method add-method
+    (make-method (list <generic> <method>)
+      (named-lambda method:add-method (call-next-method generic method)
+        (let ([method-arity (method-arity method)]
+              [generic-arity (%generic-arity generic)])
+          (cond
+           [(not generic-arity)
+            (%set-generic-arity! generic method-arity)]
+           ;; note: equal? works on arity-at-least structs
+           [(not (equal? generic-arity method-arity))
+            (error 'add-method
+                   "wrong arity for `~e', expects ~a; given a method with ~a"
+                   (%generic-name generic)
+                   (if (integer? generic-arity)
+                     generic-arity
+                     (format "at-least-~a"
+                             (arity-at-least-value generic-arity)))
+                   (if (integer? method-arity)
+                     method-arity
+                     (format "at-least-~a"
+                             (arity-at-least-value method-arity))))])
+          ;; set a name for the method if none (when attached to a generic)
+          (let ([n (%method-name method)])
+            (unless (and n (not (eq? n '-anonymous-)))
+              (%set-method-name!
+               method
+               (let* ([psym (object-name (%method-procedure method))]
+                      [pstr (and psym (symbol->string psym))])
+                 (if (or (not pstr) (regexp-match #rx":[0-9]*:[0-9]*$" pstr))
+                   (compute-method-name (%method-specializers method)
+                                        (%generic-name generic))
+                   psym)))))
+          (old-add-method generic method))))))
+
+;;; Optimized frequently used accessors:
+;;; This is possible because of the ordering of the slots in compute-slots,
+;;; works only for single-inheritance.  Note that there is no type checking -
+;;; it is unsafe, but makes things around 5-6 times faster!
+(set! %class-default-initargs    (%slot-getter <class>   'default-initargs))
+(set! %class-direct-default-initargs (%slot-getter <class> 'direct-default-initargs))
+(set! %class-direct-slots        (%slot-getter <class>   'direct-slots))
+(set! %class-direct-supers       (%slot-getter <class>   'direct-supers))
+(set! %class-slots               (%slot-getter <class>   'slots))
+(set! %class-nfields             (%slot-getter <class>   'nfields))
+(set! %class-field-initializers  (%slot-getter <class>   'field-initializers))
+(set! %class-getters-n-setters   (%slot-getter <class>   'getters-n-setters))
+(set! %class-cpl                 (%slot-getter <class>   'cpl))
+(set! %class-name                (%slot-getter <class>   'name))
+(set! %class-initializers        (%slot-getter <class>   'initializers))
+(set! %class-valid-initargs      (%slot-getter <class>   'valid-initargs))
+(set! %generic-methods           (%slot-getter <generic> 'methods))
+(set! %generic-arity             (%slot-getter <generic> 'arity))
+(set! %generic-name              (%slot-getter <generic> 'name))
+(set! %generic-combination       (%slot-getter <generic> 'combination))
+(set! %method-specializers       (%slot-getter <method>  'specializers))
+(set! %method-procedure          (%slot-getter <method>  'procedure))
+(set! %method-qualifier          (%slot-getter <method>  'qualifier))
+(set! %method-name               (%slot-getter <method>  'name))
+(set! %set-class-default-initargs! (%slot-setter <class> 'default-initargs))
+(set! %set-class-direct-default-initargs! (%slot-setter <class> 'direct-default-initargs))
+(set! %set-class-direct-slots!   (%slot-setter <class>   'direct-slots))
+(set! %set-class-direct-supers!  (%slot-setter <class>   'direct-supers))
+(set! %set-class-slots!          (%slot-setter <class>   'slots))
+(set! %set-class-nfields!        (%slot-setter <class>   'nfields))
+(set! %set-class-field-initializers!(%slot-setter <class> 'field-initializers))
+(set! %set-class-getters-n-setters! (%slot-setter <class> 'getters-n-setters))
+(set! %set-class-cpl!            (%slot-setter <class>   'cpl))
+(set! %set-class-name!           (%slot-setter <class>   'name))
+(set! %set-class-initializers!   (%slot-setter <class>   'initializers))
+(set! %set-class-valid-initargs! (%slot-setter <class>   'valid-initargs))
+(set! %set-generic-methods!      (%slot-setter <generic> 'methods))
+(set! %set-generic-arity!        (%slot-setter <generic> 'arity))
+(set! %set-generic-name!         (%slot-setter <generic> 'name))
+(set! %set-generic-combination!  (%slot-setter <generic> 'combination))
+(set! %set-method-specializers!  (%slot-setter <method>  'specializers))
+(set! %set-method-procedure!     (%slot-setter <method>  'procedure))
+(set! %set-method-qualifier!     (%slot-setter <method>  'qualifier))
+(set! %set-method-name!          (%slot-setter <method>  'name))
+;; Optimize these internal ones as well.
+(set! %generic-app-cache         (%slot-getter <generic> 'app-cache))
+(set! %generic-singletons-list   (%slot-getter <generic> 'singletons-list))
+(set! %set-generic-app-cache!    (%slot-setter <generic> 'app-cache))
+(set! %set-generic-singletons-list! (%slot-setter <generic> 'singletons-list))
+
+;;; ---------------------------------------------------------------------------
+;;; Built-in classes.
+
+;;>>... Built-in Classes
+
+;;>> <primitive-class>
+;;>   The class of all built-on classes.
+(define* <primitive-class>
+  (make <class> :direct-default-initargs '()
+                :direct-supers (list <class>)
+                :direct-slots  '()
+                :name          '<primitive-class>
+                ;; needed so structs can turn to classes even if *make-safely*
+                :valid-initargs #f))
+;; Normally, can't allocate these.
+(add-method allocate-instance
+  (make-method (list <primitive-class>)
+    (named-lambda method:allocate-instance (call-next-method class initargs)
+      (error 'allocate-instance "can't instantiate a primitive class ~e"
+             class))))
+
+;;>> <builtin>
+;;>   The superclass of all built-in classes.
+(define* <builtin>
+  (make <class> :direct-default-initargs '()
+                :direct-supers (list <top>)
+                :direct-slots  '()
+                :name          '<builtin>))
+(defsubst (defprimclass primclass) (defprimclass primclass <builtin>)
+          (_ primclass supers ...) (define* primclass
+                                     (make <primitive-class>
+                                           :name          'primclass
+                                           :direct-default-initargs '()
+                                           :direct-supers (list supers ...)
+                                           :direct-slots  '())))
+;;>> <sequence>
+;;>> <immutable>
+;;>> <improper-list>
+;;>> <pair>
+;;>> <immutable-pair>
+;;>> <list>
+;;>> <nonempty-list>
+;;>> <immutable-nonempty-list>
+;;>> <null>
+;;>> <vector>
+;;>> <char>
+;;>> <string>
+;;>> <immutable-string>
+;;>> <symbol>
+;;>> <boolean>
+;;>> <number>
+;;>> <exact>
+;;>> <inexact>
+;;>> <complex>
+;;>> <real>
+;;>> <rational>
+;;>> <integer>
+;;>> <exact-complex>
+;;>> <inexact-complex>
+;;>> <exact-real>
+;;>> <inexact-real>
+;;>> <exact-rational>
+;;>> <inexact-rational>
+;;>> <exact-integer>
+;;>> <inexact-integer>
+;;>> <end-of-file>
+;;>> <port>
+;;>> <input-port>
+;;>> <output-port>
+;;>> <stream-port>
+;;>> <input-stream-port>
+;;>> <output-stream-port>
+;;>> <void>
+;;>> <box>
+;;>> <weak-box>
+;;>> <regexp>
+;;>> <parameter>
+;;>> <promise>
+;;>> <exn>
+;;>> <break-exn>
+;;>> <non-break-exn>
+;;>> <semaphore>
+;;>> <hash-table>
+;;>> <subprocess>
+;;>> <thread>
+;;>> <syntax>
+;;>> <identifier-syntax>
+;;>> <namespace>
+;;>> <custodian>
+;;>> <tcp-listener>
+;;>> <security-guard>
+;;>> <will-executor>
+;;>> <struct-type>
+;;>> <inspector>
+;;>> <pseudo-random-generator>
+;;>> <compiled-expression>
+;;>> <unknown-primitive>
+;;>   These classes represent built-in objects.  See the class hierarchy
+;;>   below for a complete description of the relations between these
+;;>   classes.
+;;>> <struct>
+;;>> <opaque-struct>
+;;>   These are also classes for built-in objects, but they are classes for
+;;>   MzScheme structs -- which can be used like Swindle classes since they
+;;>   will get converted to appropriate Swindle subclasses of `<struct>'.
+;;>   `<opaque-struct>' is a class of structs that are hidden -- see the
+;;>   documentation for `struct-info' and the `skipped?' result.  Note that
+;;>   structs can be used as long as they can be inspected -- otherwise, we
+;;>   can't even know that they are structs with `struct?' (this means that
+;;>   <opaque-struct> can only appear in the cpl of a struct class that
+;;>   inherits from a struct which is not under the current inspector).
+(defprimclass <sequence>)
+(defprimclass <immutable>)
+(defprimclass <improper-list> <sequence>)
+(defprimclass <pair> <improper-list>)
+(defprimclass <immutable-pair> <pair> <immutable>)
+(defprimclass <list> <improper-list>)
+(defprimclass <nonempty-list> <pair> <list>)
+(defprimclass <immutable-nonempty-list> <nonempty-list> <immutable>)
+(defprimclass <null> <list>)
+(defprimclass <vector> <sequence>)
+(defprimclass <char>)
+(defprimclass <string> <sequence>)
+(defprimclass <immutable-string> <string> <immutable>)
+(defprimclass <symbol>)
+(defprimclass <boolean>)
+;; Have all possible number combinations in any case
+(defprimclass <number>)
+(defprimclass <exact> <number>)
+(defprimclass <inexact> <number>)
+(defprimclass <complex> <number>)
+(defprimclass <real> <complex>)
+(defprimclass <rational> <real>)
+(defprimclass <integer> <rational>)
+(defprimclass <exact-complex> <complex> <exact>)
+(defprimclass <inexact-complex> <complex> <inexact>)
+(defprimclass <exact-real> <real> <exact-complex>)
+(defprimclass <inexact-real> <real> <inexact-complex>)
+(defprimclass <exact-rational> <rational> <exact-real>)
+(defprimclass <inexact-rational> <rational> <inexact-real>)
+(defprimclass <exact-integer> <integer> <exact-rational>)
+(defprimclass <inexact-integer> <integer> <inexact-rational>)
+(defprimclass <end-of-file>)
+(defprimclass <port>)
+(defprimclass <input-port> <port>)
+(defprimclass <output-port> <port>)
+(defprimclass <stream-port> <port>)
+;; MzScheme stuff
+(defprimclass <input-stream-port> <input-port> <stream-port>)
+(defprimclass <output-stream-port> <output-port> <stream-port>)
+(defprimclass <void>)
+(defprimclass <box>)
+(defprimclass <weak-box> <box>)
+(defprimclass <regexp>)
+(defprimclass <parameter>)
+(defprimclass <promise>)
+(defprimclass <exn>)
+(defprimclass <break-exn> <exn>)
+(defprimclass <non-break-exn> <exn>)
+(defprimclass <semaphore>)
+(defprimclass <hash-table>)
+(defprimclass <subprocess>)
+(defprimclass <thread>)
+(defprimclass <syntax>)
+(defprimclass <identifier-syntax> <syntax>)
+(defprimclass <namespace>)
+(defprimclass <custodian>)
+(defprimclass <tcp-listener>)
+(defprimclass <security-guard>)
+(defprimclass <will-executor>)
+(defprimclass <struct-type>)
+(defprimclass <inspector>)
+(defprimclass <pseudo-random-generator>)
+(defprimclass <compiled-expression>)
+(defprimclass <unknown-primitive>)
+(defprimclass <struct>)
+(defprimclass <opaque-struct> <struct>)
+;;>> <procedure>
+;;>   The class of all Scheme procedures.
+(define* <procedure>
+  (make <procedure-class> :name          '<procedure>
+                          :direct-default-initargs '()
+                          :direct-supers (list <builtin> <function>)
+                          :direct-slots  '()))
+;;>> <primitive-procedure>
+;;>   The class of all primitive MzScheme procedures.
+(define* <primitive-procedure>
+  (make <procedure-class>
+        :name          '<primitive-procedure>
+        :direct-default-initargs '()
+        :direct-supers (list <procedure>)
+        :direct-slots  '()))
+
+(*default-object-class* <object>) ; turn auto-superclass back on
+
+(set! class-of
+      (lambda (x)
+        ;; If all Schemes were IEEE compliant, the order of these wouldn't
+        ;; matter?
+        ;; ELI: changed the order so it fits best the expected results.
+        (cond [(instance?    x) (instance-class x)]
+              [(procedure?   x) (cond [(parameter? x) <parameter>]
+                                      [(primitive? x) <primitive-procedure>]
+                                      [else <procedure>])]
+              [(string?      x) (if (immutable? x)
+                                  <immutable-string> <string>)]
+              [(pair?        x) (if (list? x)
+                                  (if (immutable? x)
+                                    <immutable-nonempty-list> <nonempty-list>)
+                                  (if (immutable? x)
+                                    <immutable-pair> <pair>))]
+              [(null?        x) <null>]
+              [(char?        x) <char>]
+              [(symbol?      x) <symbol>]
+              [(number?      x) (if (exact? x)
+                                  (cond [(integer?  x) <exact-integer>]
+                                        [(rational? x) <exact-rational>]
+                                        [(real?     x) <exact-real>]
+                                        [(complex?  x) <exact-complex>]
+                                        [else <exact>]) ; should not happen
+                                  (cond [(integer?  x) <inexact-integer>]
+                                        [(rational? x) <inexact-rational>]
+                                        [(real?     x) <inexact-real>]
+                                        [(complex?  x) <inexact-complex>]
+                                        [else <inexact>]))] ; should not happen
+              [(boolean?     x) <boolean>]
+              [(vector?      x) <vector>]
+              [(eof-object?  x) <end-of-file>]
+              [(input-port?  x) (if (file-stream-port? x)
+                                  <input-stream-port> <input-port>)]
+              [(output-port? x) (if (file-stream-port? x)
+                                  <output-stream-port> <output-port>)]
+              ;; MzScheme stuff
+              [(struct? x)
+               (let-values ([(type _) (struct-info x)])
+                 (if type (struct-type->class type) <opaque-struct>))]
+              [(void?           x) <void>]
+              [(box?            x) <box>]
+              [(weak-box?       x) <weak-box>]
+              [(regexp?         x) <regexp>]
+              [(promise?        x) <promise>]
+              [(exn?            x) (if (exn:break? x)
+                                     <break-exn> <non-break-exn>)]
+              [(semaphore?      x) <semaphore>]
+              [(hash-table?     x) <hash-table>]
+              [(thread?         x) <thread>]
+              [(subprocess?     x) <subprocess>]
+              [(syntax?         x) (if (identifier? x)
+                                     <identifier-syntax> <syntax>)]
+              [(namespace?      x) <namespace>]
+              [(custodian?      x) <custodian>]
+              [(tcp-listener?   x) <tcp-listener>]
+              [(security-guard? x) <security-guard>]
+              [(will-executor?  x) <will-executor>]
+              [(struct-type?    x) <struct-type>]
+              [(inspector?      x) <inspector>]
+              [(pseudo-random-generator? x) <pseudo-random-generator>]
+              [(compiled-expression? x) <compiled-expression>]
+              [else <unknown-primitive>])))
+
+;;; ---------------------------------------------------------------------------
+;;; Some useful predicates.
+
+;;>> (builtin? x)
+;;>> (function? x)
+;;>> (generic? x)
+;;>> (method? x)
+;;>   Predicates for instances of <builtin>, <function>, <generic>, and
+;;>   <method>.
+(define* (builtin?  x) (instance-of? x <builtin>))
+(define* (function? x) (instance-of? x <function>))
+(define* (generic?  x) (instance-of? x <generic>))
+(define* (method?   x) (instance-of? x <method>))
+
+;;; ---------------------------------------------------------------------------
+;;>>... Class Hierarchy
+;;>
+;;> In the following, every class's class is specified after a colon.  Also,
+;;> some classes appear in more than once place due to multiple-inheritance.
+;;>
+;;>   <top> : <class>
+;;>     <object> : <class>
+;;>       <class> : <class>
+;;>         <procedure-class> : <class>
+;;>           <entity-class> : <class>
+;;>         <primitive-class> : <class>
+;;>       <generic> : <entity-class>
+;;>       <method> : <entity-class>
+;;>     <function> : <class>
+;;>       <generic> : <entity-class>
+;;>       <method> : <entity-class>
+;;>       <procedure> : <procedure-class>
+;;>         <primitive-procedure> : <procedure-class>
+;;>     <builtin> : <class>
+;;>       <sequence> : <primitive-class>
+;;>         <improper-list> : <primitive-class>
+;;>           <pair> : <primitive-class>
+;;>             <immutable-pair> : <primitive-class>
+;;>             <nonempty-list> : <primitive-class>
+;;>               <immutable-nonempty-list> : <primitive-class>
+;;>           <list> : <primitive-class>
+;;>             <nonempty-list> : <primitive-class>
+;;>               <immutable-nonempty-list> : <primitive-class>
+;;>             <null> : <primitive-class>
+;;>         <vector> : <primitive-class>
+;;>         <string> : <primitive-class>
+;;>           <immutable-string> : <primitive-class>
+;;>       <immutable> : <primitive-class>
+;;>         <immutable-nonempty-list> : <primitive-class>
+;;>         <immutable-pair> : <primitive-class>
+;;>         <immutable-string> : <primitive-class>
+;;>       <char> : <primitive-class>
+;;>       <symbol> : <primitive-class>
+;;>       <boolean> : <primitive-class>
+;;>       <number> : <primitive-class>
+;;>         <complex> : <primitive-class>
+;;>           <exact-complex> : <primitive-class>
+;;>           <inexact-complex> : <primitive-class>
+;;>           <real> : <primitive-class>
+;;>             <exact-real> : <primitive-class>
+;;>             <inexact-real> : <primitive-class>
+;;>             <rational> : <primitive-class>
+;;>               <integer> : <primitive-class>
+;;>               <exact-rational> : <primitive-class>
+;;>               <inexact-rational> : <primitive-class>
+;;>                 <exact-integer> : <primitive-class>
+;;>                 <inexact-integer> : <primitive-class>
+;;>         <exact> : <primitive-class>
+;;>           <exact-complex> : <primitive-class>
+;;>             <exact-real> : <primitive-class>
+;;>               <exact-rational> : <primitive-class>
+;;>                 <exact-integer> : <primitive-class>
+;;>         <inexact> : <primitive-class>
+;;>           <inexact-complex> : <primitive-class>
+;;>             <inexact-real> : <primitive-class>
+;;>               <inexact-rational> : <primitive-class>
+;;>                 <inexact-integer> : <primitive-class>
+;;>       <end-of-file> : <primitive-class>
+;;>       <port> : <primitive-class>
+;;>         <input-port> : <primitive-class>
+;;>           <input-stream-port> : <primitive-class>
+;;>         <output-port> : <primitive-class>
+;;>           <output-stream-port> : <primitive-class>
+;;>         <stream-port> : <primitive-class>
+;;>           <input-stream-port> : <primitive-class>
+;;>           <output-stream-port> : <primitive-class>
+;;>       <void> : <primitive-class>
+;;>       <box> : <primitive-class>
+;;>         <weak-box> : <primitive-class>
+;;>       <regexp> : <primitive-class>
+;;>       <parameter> : <primitive-class>
+;;>       <promise> : <primitive-class>
+;;>       <exn> : <primitive-class>
+;;>         <break-exn> : <primitive-class>
+;;>         <non-break-exn> : <primitive-class>
+;;>       <semaphore> : <primitive-class>
+;;>       <hash-table> : <primitive-class>
+;;>       <subprocess> : <primitive-class>
+;;>       <thread> : <primitive-class>
+;;>       <syntax> : <primitive-class>
+;;>         <identifier-syntax> : <primitive-class>
+;;>       <namespace> : <primitive-class>
+;;>       <custodian> : <primitive-class>
+;;>       <tcp-listener> : <primitive-class>
+;;>       <security-guard> : <primitive-class>
+;;>       <will-executor> : <primitive-class>
+;;>       <inspector> : <primitive-class>
+;;>       <pseudo-random-generator> : <primitive-class>
+;;>       <compiled-expression> : <primitive-class>
+;;>       <unknown-primitive> : <primitive-class>
+;;>       <procedure> : <procedure-class>
+;;>         <primitive-procedure> : <procedure-class>
+;;>       <struct> : <primitive-class>
+;;>         <opaque-struct> : <primitive-class>
+;;>         ... struct type classes ...
+
+;;>>... Object Initialization Protocol
+;;> This is the initialization protocol.  All of these are generic
+;;> functions (unlike the original Tiny CLOS).  See the individual
+;;> descriptions above for more details.
+;;>
+;;>   make
+;;>     allocate-instance
+;;>     initialize
+;;>   class initialization only:
+;;>     compute-cpl
+;;>     compute-slots
+;;>     compute-default-initargs
+;;>     compute-getter-and-setter
+;;>   method initialization only:
+;;>     compute-apply-method
+;;>   add-method
+;;>     compute-apply-generic
+;;>       compute-methods
+;;>         compute-method-more-specific?
+;;>       compute-apply-methods
+
+)
diff --git a/collects/swindle/tool.ss b/collects/swindle/tool.ss
new file mode 100644
index 0000000000..da12df8e81
--- /dev/null
+++ b/collects/swindle/tool.ss
@@ -0,0 +1,167 @@
+;;; Written by Eli Barzilay: Maze is Life!  (eli@barzilay.org)
+
+;; This allows adding a Swindle icon on startup.
+(module tool mzscheme
+  (require (lib "unitsig.ss")
+           (lib "tool.ss" "drscheme")
+           (lib "class.ss")
+           (lib "list.ss")
+           (lib "mred.ss" "mred")
+           (lib "sendurl.ss" "net")
+           (lib "string-constant.ss" "string-constants"))
+  (provide tool@)
+  (define tool@
+    (unit/sig drscheme:tool-exports^ (import drscheme:tool^)
+      (define swindle-url "http://www.barzilay.org/Swindle/")
+      ;; Swindle languages
+      (define (swindle-language
+               l-name l-module l-entry-name l-one-line l-sensitive? l-url)
+        (class (drscheme:language:module-based-language->language-mixin
+                (drscheme:language:simple-module-based-language->module-based-language-mixin
+                 (class* object%
+                         (drscheme:language:simple-module-based-language<%>)
+                   (define/public (get-language-numbers) '(-1000 2000 0))
+                   (define/public (get-language-position)
+                     (list (string-constant professional-languages)
+                           "Swindle" l-entry-name))
+                   (define/public (get-module) l-module)
+                   (define/public (get-one-line-summary) l-one-line)
+                   (define/public (get-language-url) l-url)
+                   (define/public (get-reader)
+                     (lambda (src port)
+                       (let ([v (read-syntax src port)])
+                         (if (eof-object? v)
+                           v
+                           (namespace-syntax-introduce v)))))
+                   (super-instantiate ()))))
+          (define/override (use-namespace-require/copy?) #t)
+          (define/override (default-settings)
+            (drscheme:language:make-simple-settings
+             l-sensitive? 'current-print 'mixed-fraction-e #f #t 'debug))
+          (define/override (get-language-name) l-name)
+          (define/override (config-panel parent)
+            (let* ([make-panel
+                    (lambda (msg contents)
+                      (make-object message% msg parent)
+                      (let ([p (instantiate vertical-panel% ()
+                                 (parent parent)
+                                 (style '(border))
+                                 (alignment '(left center)))])
+                        (if (string? contents)
+                          (make-object message% contents p)
+                          (contents p))))]
+                   [title-panel
+                    (instantiate horizontal-panel% ()
+                      (parent parent)
+                      (alignment '(center center)))]
+                   [title-pic
+                    (make-object message%
+                      (make-object bitmap%
+                        (build-path (collection-path "swindle")
+                                    "swindle-logo.png"))
+                      title-panel)]
+                   [title (let ([p (instantiate vertical-panel% ()
+                                     (parent title-panel)
+                                     (alignment '(left center)))])
+                            (make-object message% (format "Swindle") p)
+                            (make-object message% (format "Setup") p)
+                            p)]
+                   [input
+                    (make-panel (string-constant input-syntax)
+                                (if l-sensitive?
+                                  "always case-sensitive"
+                                  (lambda (p)
+                                    (make-object check-box%
+                                      (string-constant case-sensitive-label)
+                                      p void))))]
+                   [debugging
+                    (make-panel
+                     (string-constant dynamic-properties)
+                     (lambda (p)
+                       (instantiate radio-box% ()
+                         (label #f)
+                         (choices
+                          `(,(string-constant no-debugging-or-profiling)
+                            ,(string-constant debugging)
+                            ,(string-constant debugging-and-profiling)))
+                         (parent p)
+                         (callback void))))]
+                   [output
+                    (make-panel (string-constant output-style-label)
+                                "always current-print")])
+              (case-lambda
+               [()
+                (drscheme:language:make-simple-settings
+                 (or l-sensitive? (send input get-value))
+                 'current-print 'mixed-fraction-e #f #t
+                 (case (send debugging get-selection)
+                   [(0) 'none]
+                   [(1) 'debug]
+                   [(2) 'debug/profile]))]
+               [(settings)
+                (unless l-sensitive?
+                  (send input set-value
+                        (drscheme:language:simple-settings-case-sensitive
+                         settings)))
+                (send debugging set-selection
+                      (case (drscheme:language:simple-settings-annotations
+                             settings)
+                        [(none) 0]
+                        [(debug) 1]
+                        [(debug/profile) 2]))])))
+          (define/override (render-value/format value settings port port-write)
+            (parameterize ([current-output-port port]
+                           [current-inspector (make-inspector)])
+              ((current-print) value)))
+          (super-instantiate ())))
+      (define (add-swindle-language
+               name module entry-name one-line sensitive? url)
+        (drscheme:language-configuration:add-language
+         (make-object ((drscheme:language:get-default-mixin)
+                       (swindle-language
+                        name
+                        `(lib ,(string-append module ".ss") "swindle")
+                        entry-name one-line sensitive? url)))))
+      (define phase1 void)
+      (define (phase2)
+        (for-each (lambda (args)
+                    (apply add-swindle-language `(,@args #f)))
+                  '(("Swindle" "swindle" "Full Swindle"
+                     "Full Swindle extensions" #t)
+                    ("Swindle w/o CLOS" "turbo" "Swindle without CLOS"
+                     "Swindle without the object system" #t)
+                    ("Swindle Syntax" "base" "Basic syntax only"
+                     "Basic Swindle syntax: keyword-arguments etc" #t)
+                    ("HTML Swindle" "html" "HTML Swindle"
+                     "Swindle's HTML extension" #t)))
+        (parameterize ([current-directory (collection-path "swindle")])
+          (define (do-customize file)
+            (when (regexp-match #rx"\\.ss$" file)
+              (with-input-from-file file
+                (lambda ()
+                  (let ([l (read-line)])
+                    (when (regexp-match #rx"^;+ *CustomSwindle *$" l)
+                      (let ([file (regexp-replace #rx"\\.ss$" file "")]
+                            [name #f] [dname #f] [one-line #f] [url #f])
+                        (let loop ([l (read-line)])
+                          (cond
+                           [(regexp-match #rx"^;+ *([A-Z][A-Za-z]*): *(.*)$" l)
+                            => (lambda (m)
+                                 (let ([sym (string->symbol (cadr m))]
+                                       [val (caddr m)])
+                                   (case sym
+                                     [(|Name|)       (set! name     val)]
+                                     [(|DialogName|) (set! dname    val)]
+                                     [(|OneLine|)    (set! one-line val)]
+                                     [(|URL|)        (set! url      val)])
+                                   (loop (read-line))))]))
+                        (unless name (set! name file))
+                        (unless dname (set! dname name))
+                        (unless one-line
+                          (set! one-line
+                                (string-append "Customized Swindle: " name)))
+                        (unless url (set! url swindle-url))
+                        (add-swindle-language
+                         name file dname one-line #f url))))))))
+          (for-each do-customize (map path->string (directory-list)))))
+      )))
diff --git a/collects/swindle/turbo.ss b/collects/swindle/turbo.ss
new file mode 100644
index 0000000000..8aa86deae0
--- /dev/null
+++ b/collects/swindle/turbo.ss
@@ -0,0 +1,44 @@
+;;; Written by Eli Barzilay: Maze is Life!  (eli@barzilay.org)
+
+;;> This module combines the `base', `setf', and `misc', modules to create a
+;;> new language module.  Use this module to get most of Swindle's
+;;> functionality which is unrelated to the object system.
+
+(module turbo (lib "base.ss" "swindle")
+  (require (lib "setf.ss" "swindle")
+           (lib "misc.ss" "swindle"))
+  (provide (all-from-except (lib "base.ss" "swindle")
+                            set! set!-values #%module-begin)
+           (rename module-begin~ #%module-begin)
+           (all-from-except (lib "setf.ss" "swindle") setf! psetf!)
+;;>> (set! place value ...)  [*syntax*]
+;;>> (pset! place value ...) [*syntax*]
+;;>> (set!-values (place ...) expr) [*syntax*]
+;;>   This module renames `setf!', `psetf!', and `setf!-values' from the
+;;>   `setf' module as `set!', `pset!' and `set!-values' so the built-in
+;;>   `set!' and `set!-values' syntaxes are overridden.
+           (rename setf! set!) (rename psetf! pset!)
+           (rename setf!-values set!-values)
+           (all-from (lib "misc.ss" "swindle")))
+;;>> #%module-begin
+;;>   `turbo' is a language module -- it redefines `#%module-begin' to load
+;;>   itself for syntax definitions.
+  (defsyntax (module-begin~ stx)
+    (let ([e (if (syntax? stx) (syntax-e stx) stx)])
+      (if (pair? e)
+        (datum->syntax-object
+         (quote-syntax here)
+         (list* (quote-syntax #%plain-module-begin)
+                (datum->syntax-object stx
+                                      (list (quote-syntax require-for-syntax)
+                                            '(lib "turbo.ss" "swindle")))
+                (cdr e))
+         stx)
+        (raise-syntax-error #f "bad syntax" stx)))
+    ;; This doesn't work anymore (from 203.4)
+    ;; (syntax-rules ()
+    ;;   [(_ . body)
+    ;;    (#%plain-module-begin
+    ;;     (require-for-syntax (lib "turbo.ss" "swindle")) . body)])
+    )
+  )
diff --git a/collects/syntax-color/default-lexer.ss b/collects/syntax-color/default-lexer.ss
new file mode 100644
index 0000000000..0921604f2f
--- /dev/null
+++ b/collects/syntax-color/default-lexer.ss
@@ -0,0 +1,27 @@
+(module default-lexer mzscheme
+  (require (lib "lex.ss" "parser-tools")
+           (prefix : (lib "lex-sre.ss" "parser-tools")))
+  
+  (provide default-lexer)
+  
+  (define-lex-abbrevs 
+   (parens (:or #\( #\) #\[ #\] #\{ #\})))
+                     
+  
+  (define default-lexer
+    (lexer
+     ((:+ (:~ parens whitespace))
+      (values lexeme 'no-color #f (position-offset start-pos) (position-offset end-pos)))
+     ((:+ whitespace)
+      (values lexeme 'white-space #f (position-offset start-pos) (position-offset end-pos)))
+     (parens
+      (values lexeme 'no-color (string->symbol lexeme) (position-offset start-pos) (position-offset end-pos)))
+     ((special)
+      (values "" 'no-color #f (position-offset start-pos) (position-offset end-pos)))
+     ((special-comment)
+      (values "" 'comment #f (position-offset start-pos) (position-offset end-pos)))
+     ((eof)
+      (values lexeme 'eof #f #f #f)))))
+     
+             
+             
diff --git a/collects/syntax-color/doc.txt b/collects/syntax-color/doc.txt
new file mode 100644
index 0000000000..c304906241
--- /dev/null
+++ b/collects/syntax-color/doc.txt
@@ -0,0 +1,52 @@
+_syntax-color_
+
+The syntax-color collection provides the underlying data structures
+and some helpful utilities for the color-text% class of the framework
+(collects/framework/private/color.ss).
+
+_token-tree.ss_
+A splay-tree class specifically geared for the task of on-the-fly
+tokenization.
+
+_paren-tree.ss_
+Parenthesis matching code built on top of token-tree.
+
+_scheme-lexer.ss_
+A lexer for Scheme (including all mzscheme extensions) build
+specifically for color-text%.
+
+scheme-lexer returns 5 values:
+
+ - A string containing the matching text.  Block comments and specials
+   currently return an empty string.  This may change in the future to
+   other string or non-string data.
+
+ - A symbol in '(error comment white-space constant string no-color
+   parenthesis other symbol eof)
+
+ - A symbol in '(|(| |)| |[| |]| |{| |}|) or #f
+
+ - A number representing the starting position of the match.
+ 
+ - A number representing the ending position of the match.
+
+_default-lexer.ss_
+A lexer that only identifies the following: ( ) [ ] { }
+also build specifically for color-text%.
+
+default-lexer returns 5 values:
+
+ - A string containing the matching text.  Block specials currently
+   return an empty string.  This may change in the future to other
+   string or non-string data.
+
+ - A symbol in '(comment white-space no-color eof)
+
+ - A symbol in '(|(| |)| |[| |]| |{| |}|) or #f
+
+ - A number representing the starting position of the match.
+ 
+ - A number representing the ending position of the match.
+
+
+
diff --git a/collects/syntax-color/info.ss b/collects/syntax-color/info.ss
new file mode 100644
index 0000000000..519e18ea2d
--- /dev/null
+++ b/collects/syntax-color/info.ss
@@ -0,0 +1,5 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Syntax Color")
+  (define doc.txt "doc.txt"))
+
+
diff --git a/collects/syntax-color/paren-tree.ss b/collects/syntax-color/paren-tree.ss
new file mode 100644
index 0000000000..ea776be3c0
--- /dev/null
+++ b/collects/syntax-color/paren-tree.ss
@@ -0,0 +1,237 @@
+(module paren-tree mzscheme
+  (require (lib "class.ss")
+           "token-tree.ss")
+  
+  (provide paren-tree%)
+  
+  (define paren-tree%
+    (class object%
+
+      ;; matches: (listof (list/p symbol symbol))
+      ;; Symbols for the open-close pairs
+      (init matches)
+
+      (define open-matches-table (make-hash-table))
+      (for-each (lambda (x)
+                  (hash-table-put! open-matches-table (car x) (cadr x)))
+                matches)
+      
+      (define close-matches-table (make-hash-table))
+      (for-each (lambda (x)
+                  (hash-table-put! close-matches-table (cadr x) (car x)))
+                matches)
+      
+      (define/private (is-open? x)
+        (hash-table-get open-matches-table x (lambda () #f)))
+      
+      (define/private (is-close? x)
+        (hash-table-get close-matches-table x (lambda () #f)))
+      
+      (define/private (matches? open close)
+        (equal? (hash-table-get open-matches-table open (lambda () #f))
+                close))
+
+      (define tree (new token-tree%))
+      (define invalid-tree (new token-tree%))
+      
+      (define/private (split tree pos)
+        (send tree search! pos)
+        (let ((token-start (send tree get-root-start-position)))
+          (cond
+            ((send tree is-empty?)
+             (values (new token-tree%) (new token-tree%)))
+            ((= pos token-start)
+             (send tree split-before))
+            (else
+             (let-values (((first next) (send tree split-after)))
+               (let ((first-end (send first get-root-end-position)))
+                 (send first add-to-root-length (- pos first-end))
+                 (insert-first! next (new token-tree%
+                                          (length (- first-end pos))
+                                          (data (cons #f 0))))
+                 (values first next)))))))
+      
+      ;; split-tree: natural-number -> 
+      ;; Everything at and after pos is marked as invalid.
+      ;; pos must not be a position inside of a token.
+      (define/public (split-tree pos)
+        (let-values (((l r) (split tree pos)))
+          (set! tree l)
+          (set! invalid-tree r)))
+      
+      ;; merget-tree: natural-number ->
+      ;; Makes the num-to-keep last positions that have been marked
+      ;; invalid valid again.
+      (define/public (merge-tree num-to-keep)
+        (send invalid-tree search-max!)
+        (let*-values (((bad good) (split invalid-tree (- (send invalid-tree get-root-end-position)
+                                                         num-to-keep)))
+                      ((data) (send good get-root-data)))
+          (when (and data
+                     (not (or (is-open? (car data))
+                              (is-close? (car data)))))
+            (add-token #f (send good get-root-length))
+            (send good remove-root!))
+          (insert-last! tree good)))
+      
+      
+      ;; add-token: symbol * natural-number ->
+      ;; Adds the token to the end of the valid part of the tree.
+      (define/public (add-token type length)
+        (cond
+          ((or (send tree is-empty?) (is-open? type) (is-close? type))
+           ; Big performance increase using the -spec version.
+           ;(insert-last! tree (new token-tree% (length length) (data (cons type length))))
+           (insert-last-spec! tree length (cons type length)))
+          (else
+           (send tree search-max!)
+           (send tree add-to-root-length length))))
+
+      ;; truncate: natural-number ->
+      ;; removes the tokens after pos
+      (define/public (truncate pos)
+        (let-values (((l r) (split tree pos)))
+          (set! tree l)))
+        
+      ;; match-forward: natural-number? -> (union #f natural-number)^3
+      ;; The first return is the starting position of the open-paren
+      ;; The second return is the position of the closing paren.
+      ;; If the third return is #f, then the first two returns
+      ;; represent a real match.
+      ;; If the third return is a number, it is the maximum position
+      ;; in the tree that was searched.
+      ;; If it indicates an error, the first two results give the
+      ;; starting and stoping positions for error highlighting.
+      ;; If all three return #f, then there was no tree to search, or 
+      ;; the position did not immediately preceed an open.
+      (define/public (match-forward pos)
+        (send tree search! pos)
+        (cond
+          ((and (not (send tree is-empty?))
+                (is-open? (car (send tree get-root-data)))
+                (= (send tree get-root-start-position) pos))
+           (let ((end
+                  (let/ec ret
+                    (do-match-forward (node-right (send tree get-root))
+                                      (send tree get-root-end-position)
+                                      (list (car (send tree get-root-data)))
+                                      ret)
+                    #f)))
+             (cond
+               (end
+                (values pos end #f))
+               (else
+                (send tree search-max!)
+                (let ((end (send tree get-root-end-position)))
+                  (send tree search! pos)
+                  (values pos (+ pos (cdr (send tree get-root-data))) end))))))
+          (else
+           (values #f #f #f))))
+      
+      ;; match-backward: natural-number? -> (union #f natural-number)^3
+      ;; The first return is the starting position of the open-paren
+      ;; The second return is the position of the closing paren.
+      ;; If the third return is #f, then the first two returns
+      ;; represent a real match, otherwise it represents an error
+      ;; If it indicates an error, the first two results give the
+      ;; starting and stoping positions for error highlighting.
+      ;; If all three return #f, then there was no tree to search, or 
+      ;; the position did not immediately follow a close.
+      (define/public (match-backward pos)
+        (send tree search! (if (> pos 0) (sub1 pos) pos))
+        (cond
+          ((and (not (send tree is-empty?))
+                (is-close? (car (send tree get-root-data)))
+                (= (+ (cdr (send tree get-root-data))
+                      (send tree get-root-start-position))
+                   pos))
+           (let ((end
+                  (let/ec ret
+                    (do-match-backward (node-left (send tree get-root))
+                                       0
+                                       (list (car (send tree get-root-data)))
+                                       ret)
+                    #f)))
+             (cond
+               (end
+                (values end pos #f))
+               (else
+                (send tree search! pos)
+                (values (- pos (cdr (send tree get-root-data))) pos #t)))))
+          (else
+           (values #f #f #f))))
+      
+      ;; is-open-pos?: natural-number -> (union #f symbol)
+      ;; if the position starts an open, return the corresponding close,
+      ;; otherwise return #f
+      (define/public (is-open-pos? pos)
+        (send tree search! pos)
+        (let ((d (send tree get-root-data)))
+          (and (= (send tree get-root-start-position) pos)
+               d
+               (is-open? (car d)))))
+
+      ;; is-close-pos?: natural-number -> (union #f symbol)
+      ;; if the position starts an close, return the corresponding open,
+      ;; otherwise return #f
+      (define/public (is-close-pos? pos)
+        (send tree search! pos)
+        (let ((d (send tree get-root-data)))
+          (and (= (send tree get-root-start-position) pos)
+               d
+               (is-close? (car d)))))
+      
+      (define/private (do-match-forward node top-offset stack escape)
+        (cond
+          ((not node) stack)
+          (else
+           (let* ((type (car (node-token-data node)))
+                  (left-stack (do-match-forward (node-left node) top-offset stack escape))
+                  (new-stack
+                   (cond
+                     ((is-open? type) (cons type left-stack))
+                     ((and (is-close? type) (matches? (car left-stack) type))
+                      (cdr left-stack))
+                     ((is-close? type) (escape #f))
+                     (else left-stack)))
+                  (start (+ top-offset (node-left-subtree-length node))))
+             (cond
+               ((null? new-stack)
+                (let ((loc (+ start (cdr (node-token-data node)))))
+                  (escape loc)))
+               (else
+                (do-match-forward (node-right node) (+ start (node-token-length node)) new-stack escape)))))))
+      
+      (define/private (do-match-backward node top-offset stack escape)
+        (cond
+          ((not node) stack)
+          (else
+           (let* ((type (car (node-token-data node)))
+                  (right-stack (do-match-backward (node-right node)
+                                                  (+ top-offset (node-left-subtree-length node)
+                                                     (node-token-length node))
+                                                  stack escape))
+                  (new-stack
+                   (cond
+                     ((is-close? type) (cons type right-stack))
+                     ((and (is-open? type) (matches? type (car right-stack)))
+                      (cdr right-stack))
+                     ((is-open? type) (escape #f))
+                     (else right-stack))))
+             (cond
+               ((null? new-stack)
+                (escape (+ top-offset (node-left-subtree-length node))))
+               (else
+                (do-match-backward (node-left node) top-offset new-stack escape)))))))
+      
+      (define/public (test)
+        (let ((v null)
+              (i null))
+          (send tree for-each (lambda (a b c)
+                                (set! v (cons (list a b c) v))))
+          (send invalid-tree for-each (lambda (a b c)
+                                        (set! i (cons (list a b c) i))))
+          (list (reverse v) (reverse i))))
+        
+      (super-instantiate ())
+      )))
diff --git a/collects/syntax-color/scheme-lexer.ss b/collects/syntax-color/scheme-lexer.ss
new file mode 100644
index 0000000000..bf9e736a30
--- /dev/null
+++ b/collects/syntax-color/scheme-lexer.ss
@@ -0,0 +1,311 @@
+(module scheme-lexer mzscheme
+  
+  (require (lib "lex.ss" "parser-tools")
+           (prefix : (lib "lex-sre.ss" "parser-tools")))
+  
+  (provide scheme-lexer)
+   
+  (define-lex-abbrevs
+         
+   ;; For case insensitivity
+   [a (char-set "aA")]
+   [b (char-set "bB")]
+   [c (char-set "cC")]
+   [d (char-set "dD")]
+   [e (char-set "eE")]
+   [f (char-set "fF")]
+   [g (char-set "gG")]
+   [h (char-set "hH")]
+   [i (char-set "iI")]
+   [j (char-set "jJ")]
+   [k (char-set "kK")]
+   [l (char-set "lL")]
+   [m (char-set "mM")]
+   [n (char-set "nN")]
+   [o (char-set "oO")]
+   [p (char-set "pP")]
+   [q (char-set "qQ")]
+   [r (char-set "rR")]
+   [s (char-set "sS")]
+   [t (char-set "tT")]
+   [u (char-set "uU")]
+   [v (char-set "vV")]
+   [w (char-set "wW")]
+   [x (char-set "xX")]
+   [y (char-set "yY")]
+   [z (char-set "zZ")]
+
+   [digit (:/ "0" "9")]
+   [digit2 (:/ "0" "1")]
+   [digit8 (:/ "0" "7")]
+   [digit10 digit]
+   [digit16 (:/ "af" "AF" "09")]
+
+   [scheme-whitespace (:or #\newline #\return #\tab #\space #\vtab #\page)]
+   [line-comment (:: ";" (:* (:~ #\newline)))]
+
+   
+   ;; What about char->integer constraint?
+   [unicode  (:or (:: "u" (:** 1 4 digit16))
+                  (:: "U" (:** 1 6 digit16)))]
+   
+   [character (:or (:: "#\\" any-char)
+                   (:: "#\\" character-name)
+                   (:: "#\\" (:/ "0" "3") digit8 digit8)
+                   (:: "#\\" unicode))]
+   
+   [character-name (:or (:: s p a c e)
+                        (:: n e w l i n e)
+                        (:: n u l) 
+                        (:: n u l l)
+                        (:: b a c k s p a c e)
+                        (:: t a b)
+                        (:: l i n e f e e d)
+                        (:: v t a b)
+                        (:: p a g e)
+                        (:: r e t u r n)
+                        (:: r u b o u t))]
+   
+   [bad-char (:or "#\\"
+                  (:: "#\\" (:>= 2 alphabetic))
+                  (:: "#\\" (:/ "0" "3") digit8))]
+       
+   ;; What about byte string regexp strings
+   [str (:or (:: (:? "#rx") "\"" (:* string-element (:: "\\" unicode)) "\"")
+             byte-str)]
+   [byte-str (:: (:? "#rx") "#\"" (:* string-element) "\"")]
+   [string-element (:or (:~ "\"" "\\")
+                        "\\\""
+                        "\\\\"
+                        "\\a"
+                        "\\b"
+                        "\\t"
+                        "\\n"
+                        "\\v"
+                        "\\f"
+                        "\\r"
+                        "\\e"
+                        "\\'"
+                        (:: "\\" (:** 1 3 digit8))
+                        (:: "\\x" (:** 1 2 digit16))
+                        (:: "\\" #\newline))]
+
+   [bad-str (:: (:? "#rx") (:? "#") "\"" 
+                (:* (:~ "\"" "\\")
+                    (:: "\\" any-char))
+                (:? "\\" "\""))]
+   
+
+   [special-numbers (:or (:: n a n ".0") (:: i n f ".0"))]   
+   [exponent-marker (:or e s f d l)]
+   [sign (char-set "+-")]
+   [exactness (:or "#i" "#e" "#I" "#E")]
+   [radix2 (:or "#b" "#B")]
+   [radix8 (:or "#o" "#O")]
+   [radix10 (:or "#d" "#D")]
+   [radix16 (:or "#x" "#X")]
+   
+   [script (:: "#!" (:* (:~ #\newline) (:: #\\ #\newline)))]
+   
+   [identifier-delims (:or (char-set "\",'`()[]{};") scheme-whitespace)]
+   [identifier-chars (:~ identifier-delims "\\" "|")]
+   [identifier-escapes (:or (:: "\\" any-char)
+                            (:: "|" (:* (:~ "|")) "|"))]
+   [identifier-start (:or identifier-escapes
+                          (:~ identifier-delims "\\" "|" "#")
+                          "#%")]
+   [identifier (:: identifier-start
+                   (:* identifier-escapes identifier-chars))]
+
+   [bad-id-start (:or identifier-escapes
+                      (:~ identifier-delims "\\" "|"))]
+   [bad-id-escapes (:or identifier-escapes
+                        (:: "|" (:* (:~ "|"))))]
+   [bad-id (:or (:: bad-id-start
+                    (:* identifier-escapes identifier-chars)
+                    (:? "\\" bad-id-escapes))
+                "\\"
+                bad-id-escapes)]
+             
+  
+   [reader-command (:or (:: "#" c s) (:: "#" c i))]
+   [sharing (:or (:: "#" (make-uinteger digit10) "=")
+                 (:: "#" (make-uinteger digit10) "#"))])
+  
+  
+  (define-lex-trans make-num
+    (syntax-rules ()
+      ((_ digit radix) (:: (make-prefix radix) (make-complex digit)))))
+  
+  (define-lex-trans make-prefix
+    (syntax-rules ()
+      ((_ radix) (:or (:: radix (:? exactness))
+                      (:: (:? exactness) radix)))))
+  
+  (define-lex-trans make-complex
+    (syntax-rules ()
+      ((_ digit)
+       (:or (make-real digit)
+            (:: (make-real digit) "@" (make-real digit))
+            (:: (make-real digit) "+" (:or special-numbers (make-ureal digit)) i)
+            (:: (make-real digit) "-" (:or special-numbers (make-ureal digit)) i)
+            (:: (make-real digit) "+" i)
+            (:: (make-real digit) "-" i)
+            (:: "+" (:or special-numbers (make-ureal digit)) i)
+            (:: "-" (:or special-numbers (make-ureal digit)) i)
+            (:: "+" i)
+            (:: "-" i)))))
+  
+  (define-lex-trans make-ureal
+    (syntax-rules ()
+      ((_ digit) (:or (make-uinteger digit)
+                      (:: (make-uinteger digit) "/" (make-uinteger digit) (:? (make-suffix digit)))
+                      (make-decimal digit)))))
+
+  (define-lex-trans make-real
+    (syntax-rules ()
+      ((_ digit) (:or (:: (:? sign) (make-ureal digit))
+                      (:: (char-set "+-") special-numbers)))))
+  
+  (define-lex-trans make-uinteger
+    (syntax-rules ()
+      ((_ digit) (:: (:+ digit) (:* "#")))))
+  
+  (define-lex-trans make-decimal
+    (syntax-rules ()
+      ((_ digit)
+       (:or (:: (make-uinteger digit) (make-suffix digit))
+            (:: "." (:+ digit) (:* "#") (make-suffix digit))
+            (:: (:+ digit) "." (:* digit) (:* "#") (make-suffix digit))
+            (:: (:+ digit) (:+ "#") "." (:* "#") (make-suffix digit))))))
+
+  (define-lex-trans make-suffix
+    (syntax-rules ()
+      ((_ digit) (:or "" (:: exponent-marker (:? sign) (:+ digit))))))
+
+  
+  (define (ret lexeme type paren start-pos end-pos)
+    (values lexeme type paren (position-offset start-pos) (position-offset end-pos)))
+
+
+  (define get-next-comment
+    (lexer
+     ["#|" (values 1 end-pos)]
+     ["|#" (values -1 end-pos)]
+     [(:or "#" "|" (:* (:~ "|" "#")))
+      (get-next-comment input-port)]
+     [(eof) (values 'eof end-pos)]
+     [(special)
+      (get-next-comment input-port)]
+     [(special-comment)
+      (get-next-comment input-port)]))
+  
+  (define (read-nested-comment num-opens start-pos input)
+    (let-values (((diff end) (get-next-comment input)))
+      (cond
+        ((eq? 'eof diff) (ret "" 'error #f start-pos end))
+        (else
+         (let ((next-num-opens (+ diff num-opens)))
+           (cond
+             ((= 0 next-num-opens) (ret "" 'comment #f start-pos end))
+             (else (read-nested-comment next-num-opens start-pos input))))))))
+  
+  (define (get-offset i)
+    (let-values (((x y offset) (port-next-location i)))
+      offset))
+  
+  (define (escape-regexp s)
+    (apply string-append 
+           (map (lambda (c)
+                  (if (memq c '(#\( #\) #\* #\+ #\? #\[ #\] #\. #\^ #\\ #\|))
+                      (string #\\ c)
+                      (string c)))
+                (string->list s))))
+  
+  (define (special-read-line i)
+    (let ((next (peek-char-or-special i)))
+      (cond
+        ((or (eq? next #\newline) (not (char? next)))
+         null)
+        (else
+         (read-char i)
+         (cons next (special-read-line i))))))
+          
+  (define (get-here-string start-pos i)
+    (let* ((ender (list->string (special-read-line i)))
+           (next-char (peek-char-or-special i)))
+      (cond
+        ((or (equal? ender "") (not (eq? #\newline next-char)))
+         (values (string-append "#<<" ender) 'error #f start-pos (get-offset i)))
+        (else
+         (read-char i)
+         (let loop ((acc (list (string-append "#<<" ender "\n"))))
+           (let* ((next-line (list->string (special-read-line i)))
+                  (next-char (peek-char-or-special i)))
+             (cond
+               ((not (or (char? next-char) (eof-object? next-char))) ;; a special
+                (values (apply string-append (reverse! (cons next-line acc)))
+                        'error #f start-pos (get-offset i)))
+               ((equal? next-line ender)  ;; end of string
+                (values (apply string-append (reverse! (cons next-line acc)))
+                        'string #f start-pos (get-offset i)))
+               ((eof-object? next-char)
+                (values (apply string-append (reverse! (cons next-line acc)))
+                        'error #f start-pos (get-offset i)))
+               (else
+                (read-char i)
+                (loop (cons (string-append next-line "\n") acc))))))))))
+        
+  (define scheme-lexer
+    (lexer
+     [(:+ scheme-whitespace) (ret lexeme 'white-space #f start-pos end-pos)]
+     [(:or "#t" "#f" "#T" "#F" character
+           (make-num digit2 radix2)
+           (make-num digit8 radix8)
+           (make-num digit10 (:? radix10))
+           (make-num digit16 radix16))
+      (ret lexeme 'constant #f start-pos end-pos)]
+     [str (ret lexeme 'string #f start-pos end-pos)]
+     [(:or "#;" line-comment) 
+      (ret lexeme 'comment #f start-pos end-pos)]
+     ["#|" (read-nested-comment 1 start-pos input-port)]
+     [(:: (:or "" "#hash" "#hasheq" (:: "#" (:* digit10))) "(")
+      (values lexeme 'parenthesis '|(| (position-offset start-pos) (position-offset end-pos))]
+     [(:: (:or "" "#hash" "#hasheq" (:: "#" (:* digit10))) "[")
+      (values lexeme 'parenthesis '|[| (position-offset start-pos) (position-offset end-pos))]
+     [(:: (:or "" "#hash" "#hasheq" (:: "#" (:* digit10))) "{")
+      (values lexeme 'parenthesis '|{| (position-offset start-pos) (position-offset end-pos))]
+     [(:or ")" "]" "}")
+      (values lexeme 'parenthesis (string->symbol lexeme) (position-offset start-pos) (position-offset end-pos))]
+     [(:or "'" "`" "#'" "#`" "#&")
+      (values lexeme 'constant #f (position-offset start-pos) (position-offset end-pos))]
+     [(:or script sharing reader-command "." "," ",@" "#," "#,@")
+      (values lexeme 'other #f (position-offset start-pos) (position-offset end-pos))]
+     [identifier (values lexeme 'symbol #f (position-offset start-pos) (position-offset end-pos))]
+     ["#<<" (get-here-string (position-offset start-pos) input-port)]
+     [(special)
+      (ret "" 'no-color #f start-pos end-pos)]
+     [(special-comment)
+      (ret "" 'comment #f start-pos end-pos)]
+     [(eof) (values lexeme 'eof #f #f #f)]
+     [(:or bad-char bad-str 
+           (:& bad-id
+               (complement (:: (:or (:: "#" (:or f t)) reader-command sharing "#<<" "#\\" "#|" "#;" "#&" script) any-string))))
+      (ret lexeme 'error #f start-pos end-pos)]
+     [any-char (extend-error lexeme start-pos end-pos input-port)]))
+  
+  (define (extend-error lexeme start end in)
+    (if (memq (peek-char-or-special in)
+              `(special #\newline #\return #\tab #\space #\vtab
+                 #\" #\, #\' #\` #\( #\) #\[ #\] #\{ #\} #\;
+                 ,eof))
+        (ret lexeme 'error #f start end)
+        (let-values (((rest end-pos) (get-chunk in)))
+          (ret (string-append lexeme rest) 'error #f start end-pos))))
+  
+  (define get-chunk
+    (lexer
+     ((:+ (:~ identifier-delims)) (values lexeme end-pos))))
+  
+  
+  )
diff --git a/collects/syntax-color/token-tree.ss b/collects/syntax-color/token-tree.ss
new file mode 100644
index 0000000000..827b176f0b
--- /dev/null
+++ b/collects/syntax-color/token-tree.ss
@@ -0,0 +1,372 @@
+(module token-tree mzscheme
+  (require (lib "class.ss"))
+  
+  (provide token-tree% insert-first! insert-last! insert-last-spec!
+           node-token-length node-token-data node-left-subtree-length node-left node-right)
+  
+  ;; A tree is 
+  ;;  - #f
+  ;;  - (make-node NAT 'a NAT tree tree)
+  (define-struct node (token-length token-data left-subtree-length left right))
+  
+  
+  ;; ----- The algorithmic implementation of the splay tree for a buffer ------
+  
+  ;; search-max: tree * tree list -> tree
+  (define (search-max node path)
+    (cond
+      ((not node)
+       (end-search path))
+      (else
+       (search-max (node-right node) (cons node path)))))
+  
+  ;; search-min: tree * tree list -> tree
+  (define (search-min node path)
+    (cond
+      ((not node)
+       (end-search path))
+      (else
+       (search-min (node-left node) (cons node path)))))
+  
+  ;; internal-search: tree * NAT * NAT * tree list -> tree
+  ;; key-position is the position in the buffer we are looking for
+  ;; offset is the offset for the whole subtree of node in the buffer.
+  ;; path is the path back to the root
+  (define (internal-search node key-position offset path)
+    (cond
+      ((not node)
+       (end-search path))
+      (else
+       (let* ((node-start (+ offset (node-left-subtree-length node)))
+              (node-end (+ node-start (node-token-length node))))
+         (cond
+           ((< key-position node-start)
+            (internal-search (node-left node) key-position offset (cons node path)))
+           ((>= key-position node-end)
+            (internal-search (node-right node) key-position node-end (cons node path)))
+           (else
+            (bottom-up-splay node path)))))))
+  
+  ;; end-search: tree list -> tree
+  (define (end-search path)
+    (cond
+      ((null? path) #f)
+      (else (bottom-up-splay (car path) (cdr path)))))
+  
+  ;; update-subtree-length-left-rotate: tree * tree -> 
+  (define (update-subtree-length-left-rotate self parent)
+    (set-node-left-subtree-length! parent 
+                                   (- (node-left-subtree-length parent)
+                                      (node-left-subtree-length self)
+                                      (node-token-length self))))
+  
+  ;; update-subtree-length-right-rotate: tree * tree ->
+  (define (update-subtree-length-right-rotate self parent)
+    (set-node-left-subtree-length! self
+                                   (+ (node-left-subtree-length parent)
+                                      (node-left-subtree-length self)
+                                      (node-token-length parent))))
+  
+  ;; bottom-up-splay: tree * tree list -> tree
+  (define (bottom-up-splay self path)
+    (cond
+      ((null? path) self)               ;; node is root already
+      ((null? (cdr path))               ;; node's parent is root
+       (let ((parent (car path)))
+         (cond
+           ((eq? self (node-left parent))
+            (set-node-left! parent (node-right self))
+            (set-node-right! self parent)
+            (update-subtree-length-left-rotate self parent))
+           (else
+            (set-node-right! parent (node-left self))
+            (set-node-left! self parent)
+            (update-subtree-length-right-rotate self parent))))
+       self)
+      (else
+       (let ((grand (cadr path))
+             (parent (car path)))
+         (cond
+           ((eq? self (node-left parent))
+            (cond
+              ((eq? parent (node-left grand))
+               (set-node-left! grand (node-right parent))
+               (set-node-right! parent grand)
+               (set-node-left! parent (node-right self))
+               (set-node-right! self parent)
+               (update-subtree-length-left-rotate parent grand)
+               (update-subtree-length-left-rotate self parent))
+              (else
+               (set-node-right! grand (node-left self))
+               (set-node-left! self grand)
+               (set-node-left! parent (node-right self))
+               (set-node-right! self parent)
+               (update-subtree-length-left-rotate self parent)
+               (update-subtree-length-right-rotate self grand))))
+           (else
+            (cond
+              ((eq? parent (node-right grand))
+               (set-node-right! grand (node-left parent))
+               (set-node-left! parent grand)
+               (set-node-right! parent (node-left self))
+               (set-node-left! self parent)
+               (update-subtree-length-right-rotate parent grand)
+               (update-subtree-length-right-rotate self parent))
+              (else
+               (set-node-left! grand (node-right self))
+               (set-node-right! self grand)
+               (set-node-right! parent (node-left self))
+               (set-node-left! self parent)
+               (set-node-left-subtree-length! grand
+                                              (- (node-left-subtree-length grand)
+                                                 (node-left-subtree-length parent)
+                                                 (node-token-length parent)
+                                                 (node-left-subtree-length self)
+                                                 (node-token-length self)))
+               (update-subtree-length-right-rotate self parent)))))
+         (if (not (null? (cddr path)))
+             (if (eq? grand (node-left (caddr path)))
+                 (set-node-left! (caddr path) self)
+                 (set-node-right! (caddr path) self)))
+         (bottom-up-splay self (cddr path))))))
+
+  (define (size node acc)
+    (cond
+      ((not node) acc)
+      (else
+       (let ((left-size (size (node-left node) acc)))
+         (size (node-right node) (add1 left-size))))))
+      
+  (define (max-depth node)
+    (cond
+      ((not node) 0)
+      (else
+       (add1 (max (max-depth (node-left node))
+                  (max-depth (node-right node)))))))
+
+  (define (do-to-list node)
+    (cond
+      (node
+       (append (do-to-list (node-left node))
+               (list (vector (node-token-length node) (node-left-subtree-length node) (node-token-data node)))
+               (do-to-list (node-right node))))
+      (else null)))
+  
+
+  (define (do-splay-tree-for-each f node offset)
+    (when node
+      (do-splay-tree-for-each f (node-left node) offset)
+      (let ((node-start (+ offset (node-left-subtree-length node))))
+        (f node-start (node-token-length node) (node-token-data node))
+        (do-splay-tree-for-each f (node-right node) (+ node-start (node-token-length node))))))
+  
+  ;; --------------------- The interface to the splay tree --------------------
+  
+  (define-local-member-name set-root)
+  (define token-tree%
+    (class object%
+      
+      (init (length #f)
+            (data #f))
+
+      ;; root: tree
+      (define root
+        (if length
+            (make-node length data 0 #f #f)
+            #f))
+      
+      ;; reset-tree ->
+      (define/public (reset-tree)
+        (set! root #f))
+  
+      ;; get-root: -> tree
+      (define/public (get-root)
+        root)
+
+      ;; set-root: tree ->
+      ;; set-root is not accessible outside of this module
+      (define/public (set-root t)
+        (set! root t))
+      
+      ;; is-empty?: ->
+      (define/public (is-empty?)
+        (if root #f #t))
+      
+      (define/public (get-root-length)
+        (if root
+            (node-token-length root)
+            0))
+      
+      (define/public (get-root-data)
+        (if root
+            (node-token-data root)
+            #f))
+      
+      (define/public (get-root-start-position)
+        (if root
+            (node-left-subtree-length root)
+            0))
+      
+      (define/public (get-root-end-position)
+        (if root
+            (+ (node-left-subtree-length root)
+               (node-token-length root))
+            0))
+      
+      (define/public (add-to-root-length inc)
+        (unless root
+          (error 'add-to-root-length "Attempted to increase root length of empty token-tree%"))
+        (set-node-token-length! root (+ (node-token-length root) inc)))
+      
+      ;; search!: NAT ->
+      ;; Moves the node at key-position to the root
+      (define/public (search! key-position)
+        (when root
+          (set! root (internal-search root key-position 0 null))))
+      
+      ;; search-max!: ->
+      ;; moves the maximum node to the root
+      (define/public (search-max!)
+        (when root
+          (set! root (search-max root null))))
+      
+      ;; search-min!: ->
+      ;; moves the minimum node to the root
+      (define/public (search-min!)
+        (when root
+          (set! root (search-min root null))))
+      
+      ;; remove-root!: ->
+      ;; Removes the root node
+      (define/public (remove-root!)
+        (when root
+          (let ((new-node (search-max (node-left root) null)))
+            (cond
+              (new-node
+               (set-node-right! new-node (node-right root))
+               (set! root new-node))
+              (else
+               (set! root (node-right root)))))))
+
+      
+      ;; split: -> NAT * NAT * token-tree% * token-tree%
+      ;; splits the tree into 2 trees, setting root to #f
+      ;; Returns the start and end position of the token at pos
+      ;; Returns all tokens before pos and after pos, not
+      ;; including any tokens adjacent to pos.  Thus is s
+      ;; pos is on a token boundary, 2 tokens will be dropped.
+      ;; In this case, the start will be for the first dropped
+      ;; token and the stop will be for the second.
+      (define/public (split pos)
+        (search! pos)
+        (let ((t1 (new token-tree%))
+              (t2 (new token-tree%)))
+          (cond
+            (root
+             (let ((second-start (get-root-start-position))
+                   (second-stop (get-root-end-position)))
+               (send t1 set-root (node-left root))
+               (send t2 set-root (node-right root))
+               (set! root #f)
+               (cond
+                 ((= pos second-start)
+                  (send t1 search-max!)
+                  (let ((first-start (send t1 get-root-start-position)))
+                    (send t1 remove-root!)
+                    (values first-start second-stop t1 t2)))
+                 (else
+                  (values second-start second-stop t1 t2)))))
+            (else (values 0 0 t1 t2)))))
+
+;;      (define/public (split)
+;;        (let ((t1 (new token-tree%))
+;;              (t2 (new token-tree%)))
+;;          (cond
+;;            (root
+;;             (send t1 set-root (node-left root))
+;;             (send t2 set-root (node-right root))
+;;             (begin0
+;;               (values (node-left-subtree-length root)
+;;                       (+ (node-left-subtree-length root) (node-token-length root))
+;;                       t1
+;;                       t2)
+;;               (set! root #f)))
+;;            (else (values 0 0 t1 t2)))))
+      
+      ;; split-after: -> token-tree% * token-tree%
+      ;; splits the tree into 2 trees, setting root to #f
+      ;; returns a tree including root and its left subtree
+      ;; then root's right subtree
+      (define/public (split-after)
+        (let ((t1 (new token-tree%))
+              (t2 (new token-tree%)))
+          (when root
+            (send t1 set-root root)
+            (send t2 set-root (node-right root))
+            (set-node-right! root #f)
+            (set! root #f))
+          (values t1 t2)))
+           
+      ;; split-before: -> token-tree% * token-tree%
+      ;; splits the tree into 2 trees, setting root to #f
+      ;; returns root's left subtree and a tree including root
+      ;; and its right subtree
+      (define/public (split-before)
+        (let ((t1 (new token-tree%))
+              (t2 (new token-tree%)))
+          (when root
+            (send t1 set-root (node-left root))
+            (send t2 set-root root)
+            (set-node-left! root #f)
+            (set-node-left-subtree-length! root 0)
+            (set! root #f))
+          (values t1 t2)))
+      
+      (define/public (to-list)
+        (do-to-list root))
+      
+      (define/public (for-each f)
+        (do-splay-tree-for-each f root 0))
+      
+      (super-instantiate ())))
+
+  ;; insert-first!: token-tree% * token-tree% ->
+  ;; insert tree2 into tree1 as the first thing.
+  ;; Set tree2's root to #f
+  (define (insert-first! tree1 tree2)
+    (send tree2 search-max!)
+    (let ((node1 (send tree1 get-root))
+          (node2 (send tree2 get-root)))
+      (when node2
+        (set-node-right! node2 node1)
+        (send tree1 set-root node2)
+        (send tree2 reset-tree))))
+  
+  ;; insert-last!: token-tree% * token-tree%  ->
+  ;; insert tree2 into tree1 as the last thing.
+  ;; Set tree2's root to #f
+  (define (insert-last! tree1 tree2)
+    (send tree1 search-max!)
+    (let ((node1 (send tree1 get-root))
+          (node2 (send tree2 get-root)))
+      (cond
+        (node1
+         (set-node-right! node1 node2))
+        (else
+         (send tree1 set-root node2)))
+      (send tree2 reset-tree)))
+
+  ;; insert-last-spec!: token-tree% NAT 'a ->
+  ;; Same as (insert-last! tree1 (new token-tree% (length len) (data type)))
+  ;; This optimization is important for the colorer.
+  (define (insert-last-spec! tree1 len type)
+    (send tree1 search-max!)
+    (let ((node1 (send tree1 get-root))
+          (node2 (make-node len type 0 #f #f)))
+      (cond
+        (node1
+         (set-node-right! node1 node2))
+        (else
+         (send tree1 set-root node2)))))
+    
+  )
\ No newline at end of file
diff --git a/collects/syntax/boundmap.ss b/collects/syntax/boundmap.ss
new file mode 100644
index 0000000000..8742d24221
--- /dev/null
+++ b/collects/syntax/boundmap.ss
@@ -0,0 +1,141 @@
+
+(module boundmap mzscheme
+  (require (lib "contract.ss")
+	   (lib "etc.ss"))
+  
+  (define-syntax (make-mapping-code stx)
+    (syntax-case stx ()
+      [(_ identifier->symbol
+          make-identifier-mapping
+          identifier-mapping-ht
+          identifier-mapping?
+          identifier-mapping-get
+          identifier-mapping-put!
+          identifier-mapping-for-each
+          identifier-mapping-map
+          identifier=?)
+       (and (identifier? (syntax identifier-mapping))
+            (identifier? (syntax identifier-mapping-get))
+            (identifier? (syntax identifier-mapping-put!))
+            (identifier? (syntax identifier-mapping-for-each))
+            (identifier? (syntax identifier-mapping-map)))
+       (syntax
+        (begin
+          
+          (define mk-identifier-mapping
+            (let ([make-identifier-mapping
+                   (lambda ()
+                     (make-identifier-mapping
+                      (make-hash-table)))])
+              make-identifier-mapping))
+          
+          (define identifier-mapping-get
+            (opt-lambda (bi id [fail (lambda () 
+                                       (error 'identifier-mapping-get
+                                              "no mapping for ~e"
+                                              id))])
+              (or (ormap (lambda (i)
+                           (and (identifier=? (car i) id)
+                                (cdr i)))
+                         (hash-table-get (identifier-mapping-ht bi)
+                                         (identifier->symbol id) 
+                                         (lambda () null)))
+                  (fail))))
+          
+          (define identifier-mapping-put!
+            (lambda (bi id v)
+              (let ([l (hash-table-get
+                        (identifier-mapping-ht bi)
+                        (identifier->symbol id) 
+                        (lambda () null))])
+                (hash-table-put!
+                 (identifier-mapping-ht bi)
+                 (identifier->symbol id) 
+                 (let loop ([l l])
+                   (cond
+                     [(null? l) (list (cons id v))]
+                     [(identifier=? (caar l) id)
+                      (cons (cons id v) (cdr l))]
+                     [else (cons (car l) (loop (cdr l)))]))))))
+          
+          (define identifier-mapping-for-each
+            (lambda (bi f)
+              (hash-table-for-each (identifier-mapping-ht bi)
+                                   (lambda (k v)
+                                     (for-each (lambda (i)
+                                                 (f (car i) (cdr i)))
+                                               v)))))
+          
+          (define identifier-mapping-map
+            (lambda (bi f)
+              (let* ([first (cons #f null)]
+                     [last first])
+                (identifier-mapping-for-each
+                 bi
+                 (lambda (k v)
+                   (let ([pr (cons (f k v) null)])
+                     (set-cdr! last pr)
+                     (set! last pr))))
+                (cdr first))))
+          
+          (provide (rename mk-identifier-mapping make-identifier-mapping))
+          (provide/contract
+           [identifier-mapping? (any/c . -> . boolean?)]
+           [identifier-mapping-get (opt->*
+                                    (identifier-mapping?
+                                     identifier?)
+                                    ((-> any))
+                                    any)]
+           [identifier-mapping-put! (identifier-mapping?
+                                     identifier?
+                                     any/c
+                                     . -> .
+                                     void?)]
+           [identifier-mapping-for-each (identifier-mapping?
+                                         (identifier? any/c . -> . any)
+                                         . -> .
+                                         void?)]
+           [identifier-mapping-map (identifier-mapping?
+                                    (identifier? any/c . -> . any)
+                                    . -> .
+                                    (listof any/c))])))]))
+  
+  ;; ht : hash-table[symbol(key) -> (listof (cons syntax[identifier] any))]
+  ;; the entries in the hash-table narrow the mapping to 
+  ;; the identifiers that match that key.
+  (define-struct bound-identifier-mapping (ht))
+
+  (define (bound-identifier->symbol id) (syntax-e id))
+  
+  (make-mapping-code
+   bound-identifier->symbol
+   make-bound-identifier-mapping
+   bound-identifier-mapping-ht
+   bound-identifier-mapping?
+   bound-identifier-mapping-get
+   bound-identifier-mapping-put!
+   bound-identifier-mapping-for-each
+   bound-identifier-mapping-map
+   bound-identifier=?)
+
+  ;; ht : hash-table[symbol(key) -> (listof (cons syntax[identifier] any))]
+  ;; the entries in the hash-table narrow the mapping to 
+  ;; the identifiers that match that key.
+  (define-struct module-identifier-mapping (ht))
+
+  (define (module-identifier->symbol id) 
+    (let ([binding (identifier-binding id)])
+      (if (pair? binding)
+          (cadr binding)
+          (syntax-e id))))
+  
+  (make-mapping-code
+   module-identifier->symbol
+   make-module-identifier-mapping
+   module-identifier-mapping-ht
+   module-identifier-mapping?
+   module-identifier-mapping-get
+   module-identifier-mapping-put!
+   module-identifier-mapping-for-each
+   module-identifier-mapping-map
+   module-identifier=?))
diff --git a/collects/syntax/context.ss b/collects/syntax/context.ss
new file mode 100644
index 0000000000..ef79219f23
--- /dev/null
+++ b/collects/syntax/context.ss
@@ -0,0 +1,15 @@
+
+(module context mzscheme 
+  (provide build-expand-context
+	   generate-expand-context)
+
+  (define (build-expand-context v)
+    (let ([c (syntax-local-context)])
+      (if (pair? c)
+	  (cons-immutable v c)
+	  (list-immutable v))))
+
+  (define (generate-expand-context)
+    (build-expand-context (gensym 'internal-define))))
+
+	   
\ No newline at end of file
diff --git a/collects/syntax/define.ss b/collects/syntax/define.ss
new file mode 100644
index 0000000000..abc4a4d08a
--- /dev/null
+++ b/collects/syntax/define.ss
@@ -0,0 +1,109 @@
+
+(module define mzscheme
+  (require (lib "stx.ss" "syntax"))
+
+  (provide normalize-definition)
+
+  ;; This code was shamefully copied from MzScheme's startup.ss!
+
+  (define normalize-definition
+    (case-lambda 
+     [(stx lambda-stx check-context?)
+      (when (and check-context?
+		 (memq (syntax-local-context) '(expression)))
+	(raise-syntax-error 
+	 #f
+	 "not allowed in an expression context"
+	 stx))
+      (syntax-case stx ()
+	[(_ id expr)
+	 (identifier? #'id)
+	 (values #'id #'expr)]
+	[(_ id . rest)
+	 (identifier? #'id)
+	 (raise-syntax-error
+	  #f
+	  (syntax-case stx ()
+	    [(_ id expr ...)
+	     "bad syntax (multiple expressions after identifier)"]
+	    [(_ id)
+	     "bad syntax (zero expressions after identifier)"]
+	    [(_ id . rest)
+	     "bad syntax (illegal use of `.')"])
+	  stx)]
+	[(_ something . rest)
+	 (not (stx-pair? #'something))
+	 (raise-syntax-error
+	  #f
+	  "bad syntax"
+	  stx
+	  #'something)]
+	[(_ proto . body)
+	 (let-values ([(id mk-rhs)
+		       (letrec ([simple-proto
+				 ;; check the args and set up a proc-maker; we return
+				 ;;  a proc maker instead of a final proc to enable
+				 ;;  left-to-right checking of the function protos
+				 (lambda (proto)
+				   (let-values ([(args mk-rhs)
+						 (syntax-case proto ()
+						   [(id arg ...)
+						    (values (syntax->list #'(arg ...))
+							    (lambda (body)
+							      (quasisyntax/loc stx (#,lambda-stx (arg ...)
+												 . #,body))))]
+						   [(id arg ... . rest)
+						    (values (syntax->list #'(arg ... rest))
+							    (lambda (body)
+							      (quasisyntax/loc stx 
+								(#,lambda-stx (arg ... . rest)
+									      . #,body))))])])
+				     (for-each (lambda (a)
+						 (unless (identifier? a)
+						   (raise-syntax-error
+						    #f
+						    "not an identifier for procedure argument"
+						    stx
+						    a)))
+					       args)
+				     (let ([dup (check-duplicate-identifier args)])
+				       (when dup
+					 (raise-syntax-error
+					  #f
+					  "duplicate argument identifier"
+					  stx
+					  dup)))
+				     mk-rhs))]
+				[general-proto
+				 ;; proto is guaranteed to be a stx-pair
+				 (lambda (proto)
+				   (syntax-case proto ()
+				     [(id . rest)
+				      (identifier? #'id)
+				      (values #'id
+					      (simple-proto proto))]
+				     [((something . more) . rest)
+				      (let-values ([(id mk-rhs) (general-proto #'(something . more))])
+					(let ([mk-inner (simple-proto proto)])
+					  (values id
+						  (lambda (body)
+						    (mk-rhs (list (mk-inner body)))))))]
+				     [(other . rest)
+				      (raise-syntax-error
+				       #f
+				       "bad syntax (not an identifier for procedure name, and not a nested procedure form)"
+				       stx
+				       #'other)]))])
+			 (general-proto #'proto))])
+	   (unless (stx-list? #'body)
+	     (raise-syntax-error
+	      #f
+	      "bad syntax (illegal use of `.' for procedure body)"
+	      stx))
+	   (when (stx-null? #'body)
+	     (raise-syntax-error
+	      #f
+	      "bad syntax (no expressions for procedure body)"
+	      stx))
+	   (values id (mk-rhs #'body)))])]
+     [(stx lambda-stx) (normalize-definition stx lambda-stx #t)])))
diff --git a/collects/syntax/doc.txt b/collects/syntax/doc.txt
new file mode 100644
index 0000000000..0b6e302f47
--- /dev/null
+++ b/collects/syntax/doc.txt
@@ -0,0 +1,546 @@
+
+Syntax Utilities
+----------------
+
+The libraries of the "syntax" collection provide utilities for
+manipulating expressions and inspecting modules.
+
+======================================================================
+_stx.ss_: deconstructing syntax objects
+======================================================================
+
+> (stx-null? v) - returns #t if `v' is either the empty list or a
+  syntax object representing the empty list (i.e., `syntax-e' on the
+  syntax object returns the empty list).
+
+> (stx-pair? v) - returns #t if `v' is either a pair or a syntax
+  object representing a pair. See also the definition of "syntax pair"
+  in the MzScheme manual.
+
+> (stx-list? v) - returns #t if `v' is a list, or if it is a sequence
+  of pairs leading to a syntax object such that `syntax->list' (from
+  MzScheme) would produce a list.
+
+> (stx->list stx-list) - produces a list by flatting out a trailing
+  syntax object using `syntax->list'. The `stx-list' argument must be
+  a value for which `stx-list?' would return #t.
+
+> (stx-car v) - takes the car of a "syntax pair". See the definition
+  of "syntax pair" in the MzScheme manual.
+
+> (stx-cdr v) - takes the cdr of a "syntax pair". See the definition
+  of "syntax pair" in the MzScheme manual.
+
+> (module-or-top-identifier=? a-id b-id) - returns #t if `a-id' and
+  `b-id' are module-identifier=?, or if `a-id' and `b-id' have the
+  same name (as extracted by `syntax-e') and `a-id' has no binding
+  other than at the top level.
+
+  This procedure is useful in conjunction with `syntax-case*' to match
+  procedure names that are normally bound by MzScheme. For example,
+  the `include' macro uses this procedure to recognize `build-path';
+  using `module-identifier=?'  would not work well outside of
+  `module', since the top-level `build-path' is a distinct variable
+  from the MzScheme export (though it's bound to the same procedure,
+  initially).
+
+======================================================================
+_kerncase.ss_: matching fully-expanded expressions
+======================================================================
+
+> (kernel-syntax-case stx-expr trans?-expr clause ...) - a syntactic
+  form like `syntax-case*', except that the literals are built-in as
+  the names of the primitive MzScheme forms. (The primitive syntactic
+  forms must have their normal bindings in the context of the
+  `kernel-syntax-case' expression.)
+
+  The `trans?-expr' boolean expression replaces the comparision
+  procedure, and instead selects simply between normal-phase
+  comparisions or transformer-phase comparisions. The `clause's are
+  the same as in `syntax-case*'.
+
+> (kernel-form-identifier-list syntax) - returns a list of identifiers
+  for the names of the primitive MzScheme forms for expressions, with
+  the lexical context of `syntax'. This function is useful for
+  generating a list of stopping points to provide to `local-expand'.
+
+======================================================================
+_toplevel.ss_: helper for moduleless compilation and expansion
+======================================================================
+
+> (expand-top-level-with-compile-time-evals stx) - expands `stx' as
+  a top-level expression, and evaluates its compile-time portion for
+  the benefit of later expansions.
+
+  The expander recognizes top-level `begin' expressions, and
+  interleaves the evaluation and expansion of of the `begin' body, so
+  that compile-time expressions within the `begin' body affect later
+  expansions within the body. (In other words, it ensures that
+  expanding a `begin' is the same as expanding separate top-level
+  expressions.)
+
+  The `stx' argument should have a context already, possibily
+  introduced with `namespacae-inroduce-syntax'.
+
+> (expand-top-level-with-compile-time-evals/flatten stx) - 
+  Just like expand-top-level-with-compile-time-evals,
+  except that it returns a list of syntax objects, none of
+  which have a begin. These syntax objects are the
+  flattened out contents of any begins in `stx'.
+
+> (expand-syntax-top-level-with-compile-time-evals stx)
+  Like `expand-top-level-with-compile-time-evals', but `stx' should
+  have a context already, possibily introduced with
+  `namespacae-inroduce-syntax'.
+
+> (eval-compile-time-part-of-top-level stx) - evaluates
+  expansion-time code in the fully expanded top-level expression
+  represented by `stx (or a part of it, in the case of `begin'
+  expressions). The expansion-time code might affect the compilation
+  of later top-level expressions. For example, if `stx is a
+  `require' expression, then `namespace-require/expansion-time' is
+  used on each require specification in the form. Normally, this
+  function is used only by `expand-top-level-with-compile-time-evals'.
+
+> (eval-compile-time-part-of-top-level/compile stx) - like
+  `eval-compile-time-part-of-top-level', but the result is compiled
+  code.
+
+======================================================================
+_define.ss_: handling all the same function forms as `define'
+======================================================================
+
+> (normalize-definition defn-stx lambda-id-stx [check-context?]) -
+  takes a definition form whose shape is like `define' (though
+  possibly with a different keyword) and returns two values: the
+  defined identifier and the right-hand side expression.
+
+  To generate the right-hand side, this funciton may need to insert
+  uses of `lambda'. The `lambda-id-stx' argument provides a suitable
+  `lambda' identifier.
+
+  If the definition is ill-formed, a syntax error is raised. If
+  `check-context?' is true, then a syntax error is raised if
+  `(syntax-local-context)' indicates that the current context is an
+  expression context. The default value of `check-context?' is #t.
+
+======================================================================
+_struct.ss_: generating the same names as `define-struct'
+======================================================================
+
+> (parse-define-struct stx orig-stx) - parses `stx' as a `define-struct' 
+  form, but uses `orig-stx' to report syntax errors (under the
+  assumption that `orig-stx' is the same as `stx', or that they at
+  least share sub-forms). The result is four values: an identifier for
+  the struct type name, a identifier or #f for the super-name, a list
+  of identifiers for fields, and a syntax object for the inspector
+  expression.
+
+> (build-struct-names name-id field-ids omit-sel? omit-set? [src-stx]) -
+  generates the names bound by `define-struct' given an identifier for
+  the struct type name and a list of identifiers for the field
+  names. The result is a list of identifiers:
+
+      struct:`name-id'
+      make-`name-id'
+      `name-id'?
+      `name-id'-`field'       ; for each `field' in `field-ids'
+      set-`name-id'-`field'!  ; (getter and setter names alternate)
+      ...
+
+  If `omit-sel?' is true, then the selector names are omitted from the
+  result list. If `omit-set?' is true, then the setter names are
+  omitted from the result list.
+
+  The default src-stx is #f; it is used to provide a source location
+  to the generated identifiers.
+
+> (build-struct-generation name-id field-ids omit-sel? omit-set? 
+                          [super-type prop-value-list immutable-k-list]) -
+  takes the same arguments as `build-struct-names' and generates an
+  S-expression for code using `make-struct-type' to generate the
+  structure type and return values for the identifiers created by
+  `build-struct-names'.  The optional `super-type', `prop-value-list',
+  and `immutable-k-list' parameters take s-expression values that are
+  used as the corresponding arguments to `make-struct-type'.
+
+> (build-struct-generation* all-name-ids name-id field-ids omit-sel? omit-set? 
+                            [super-type prop-value-list immutable-k-list]) -
+  like `build-struct-generation', but given the names produced by
+  `build-struct-names', instead of re-generating them.
+
+> (build-struct-expand-info name-id field-ids omit-sel? omit-set?
+                            base-name base-getters base-setters) - 
+  takes the same arguments as `build-struct-names', plus a parent
+  identifier/#t/#f and a list of accessor and mutator identifiers
+  (possibly ending in #f) for a parent type, and generates an
+  S-expression for expansion-time code to be used in the binding for
+  the structure name. A #t for the base-name means no super-type, #f
+  means that the super-type (if any) is unknown, and an identifier
+  indicates the super-type identifier.
+
+> (struct-declaration-info? v) - returns #t if `x' has the shape of
+  expansion-time information for structure type declarations, #f
+  otherwise. See also the syntax chapter of the MzScheme manual.
+
+> (generate-struct-declaration orig-stx name-id super-id-or-false
+                               field-id-list current-context
+			       make-make-struct-type
+			       continue-macro-id continue-data-stx)
+> (generate-delayed-struct-declaration stx make-make-make-struct-type)
+
+  These two procedurs cooperate to implement the core of a
+  `define-struct' expansion that works for embedded definition
+  contexts (where lookup of supertype information may need to be
+  delayed).
+
+  The `generate-struct-declaration' procedure is called by a macro
+  expander to generate the expansion, where the `name-id',
+  `super-id-or-false', and `field-id-list' arguments provide the main
+  parameters. The `current-context' argument is normally the result of
+  `syntax-local-context'. The `orig-stx' argument is used for syntax
+  errors.
+
+  The `make-struct-type' procedure is called to generate the
+  expression to actually create the struct type. Its arguments are
+  `orig-stx', `name-id-stx', `defined-name-stxes', and `super-info'.
+  The first two are as provided originally to
+  `generate-struct-declaration', the third is the set of names
+  generated by `build-struct-names', and the last is super-struct info
+  obtained by resolving `super-id-or-false' when it is not #f, #f
+  otherwise.
+
+  The result should be an expression whose values are the same as the
+  result of `make-struct-type'. Thus, the following is a basic
+  `make-make-struct-type'
+
+      (lambda (orig-stx name-stx defined-name-stxes super-info)
+	#`(make-struct-type '#,name-stx 
+			     #,(and super-info (list-ref super-info 0))
+			     #,(/ (- (length defined-name-stxes) 3) 2)
+			     0 #f))
+
+  but an actual `make-make-struct-type' will likely do more.
+
+  If the lookup of super-struct information must be delayed,
+  `generate-struct-declaration' produces an expression that invokes
+  the macro named by `continue-macro-id'. This macro should have the
+  form
+
+     (define-syntax (continue-macro stx)
+       (generate-delayed-struct-declaration 
+        stx 
+        make-make-make-struct-type))
+
+  where `make-make-make-struct-type' takes the syntax object
+  `continue-stx' and produces a procedure equivalent to the
+  `make-make-struct-type' procedure.
+
+======================================================================
+_name.ss_: extracting inferred names
+======================================================================
+
+> (syntax-local-infer-name stx) - similar to
+>   syntax-local-name
+  except that `stx' is checked for an
+>   'inferred-name
+  property (which overrides any inferred name). If neither
+  `syntax-local-name' not 'inferred-name produce a name, then a name
+  is constructed from the source-location information in `stx', if
+  any. If no name can be constructed, the result is #f.
+
+======================================================================
+_docprovide.ss_: attaching documentation to exports
+======================================================================
+
+> (provide-and-document doc-label-id doc-row ...) - a form that
+  exports names and records documentation information.  
+
+  !! IMPORTANT: For now, the exporting module must be required with a
+     `lib' or `file' form. Releatiuve paths do no work correctly !!
+
+  The `doc-label-id' identifier is used as a key for accessing the
+  documentation through `lookup-documentation'.  The actual
+  documentation is organized into "rows", each with a section title.
+
+  A `row' has one of the following forms
+
+   (section-string (name type-datum doc-string ...) ...)
+
+     Creates a documentation section whose title is `section-string',
+     and provides/documents each `name. The `type-datum' is arbitrary,
+     for use by clients that call `lookup-documentation'. The
+     `doc-string's are also arbitrary documentation information,
+     usually concatenated by clients.
+
+     A `name' is either an identifier or a renaming sequence
+     `(local-name-id extenal-name-id)'.
+
+     Multiple `row's with the same section name will be merged in the
+     documentation output. The final order of sections matches the
+     order of the first mention of each section.
+  
+   (all-from prefix-id module-path doc-label-id)
+   (all-from-except prefix-id module-path doc-label-id id ...)
+
+     where `all-from' and `all-from-except' are keywords. Merges
+     documentation and provisions from the specified module into the
+     current one; the `prefix-id' is used to prefix the imports into
+     the current module (so they can be re-exported). If `id's are
+     provided, the specified `id's are not re-exported and their
+     documentation is not merged.  
+
+> (lookup-documentation module-path-v label-sym) - returns
+  documentation for the specified module and label. The
+  `module-path-v' argument is a quoted module path, like the argument
+  to MzScheme's `dynamic-require'. The `label-sym' identifies a set of
+  documentation using the symbol as a label identifier in
+  `provide-and-document'.
+
+======================================================================
+_moddep.ss_: inspecting modules and module dependencies
+======================================================================
+
+Interpretations of module paths in this library mimic that of the
+default module path resolver in MzScheme (which means that the library
+is limited, but certainly useful as no other module path resolvers
+currently exist).
+
+> (with-module-reading-parameterization thunk) - calls `thunk' with
+  all reader parameters reset to their default values.
+
+> (check-module-form stx expected-module-sym filename-string-or-#f) -
+  inspects `stx' to check whether evaluating it will declare a module
+  named `expected-module-sym' (plus a prefix, if
+  `current-module-name-prefix' is set) --- at least if `module' is
+  bound in the top-level to MzScheme's `module'. The syntax object
+  `stx' can contain a compiled expression.
+
+  If `stx' can declare a module in an appropriate top-level, then the
+  `check-module-form' procedure returns a syntax object that certainly
+  will declare a module (adding explicit context to the leading
+  `module' if necessary) in any top-level. Otherwise, if
+  `filename-string-or-#f' is a string, a suitable exception is raised,
+  and if `filename-string-or-#f' is #f, #f is returned.
+
+  If stx is eof or eof wrapped as a syntax object, then an error is
+  raised or #f is returned.
+
+> (get-module-code path [compiled-subdir compile-proc ext-proc]) -
+  returns a compiled expression for the declaration of the module
+  specified by `module-path-v'. The `module-path-v' argument is a
+  quoted module path, as for MzScheme's `dynamic-require' using the
+  default module path resolver.
+
+  The `compiled-subdir' argument defaults to "compiled"; it specifies
+  the sub-directory to search for a compiled version of the module.
+
+  The `compile-proc' argument defaults to `compile'. This procedure is
+  used to compile module source if an already-compiled version is not
+  available.
+
+  The `ext-proc' argument defaults to #f. If it is not #f, it must be
+  a procedure of two arguments that is used when `path' does not exist
+  and no ".zo" version of `path' can be found, but an extension
+  implementing `path' is found. In that case, the arguments to
+  `ext-proc' are the path for the extension, and a boolean indicating
+  whether the extension is a _loader file (#t) or not (#f).
+
+  If a ".zo" version of `path' is available and newer than var `path'
+  (in one of the directories specified by `compiled-subdir'), then it
+  is used instead of the source. Native-code versions of `path' are
+  ignored --- unless only a native-code version exists (i.e., `path'
+  itself does not exist). If only a native-code version exists, it is
+  supplied to `ext-proc' when `ext-proc' is #f, or an exception is
+  raised (to report that an extension file cannot be used) when
+  `ext-proc' is #f.
+
+> (resolve-module-path module-path-v rel-to-path-string/thunk/#f) -
+  resolves a module path to filename path. The module path is
+  resolved relative to `rel-to-path-string/thunk/#f' if it is a string
+  (a filename path), to the directory result of calling the thunk if
+  it is a thunk, or to the current directory otherwise.
+
+> (resolve-module-path-index module-path-index rel-to-path-string/thunk/#f)
+  - like `resolve-module-path' but the input is a module path index
+  (see the MzScheme manual for details); in this case, the
+  `rel-to-path-string/thunk/#f' base is used where the module path index
+  contains the "self" index.  If `module-path-v' represents the
+  "self" module path index, then an exception is raised unless
+  `rel-to-path-string/thunk/#f' is a path string.
+
+> (collapse-module-path module-path-v rel-to-module-path-v) - returns
+  a "simplified" module path by combining `module-path-v' with
+  `rel-to-module-path', where the latter must have the form '(lib
+  <relative-path> <collection>), '(file <path>), a relative path, or a
+  thunk to generate one of those.
+
+> (collapse-module-path-index module-path-index rel-to-module-path-v)
+  - like `collapse-module-path', but the input is a module path index
+  (see the MzScheme manual for details); in this case, the
+  `rel-to-module-path-v' base is used where the module path index
+  contains the "self" index.
+
+> (show-import-tree module-path-v) - a debugging aid that prints the
+  import hierarchy starting from a given module path.
+
+======================================================================
+_readerr.ss_: signalling parse errors
+======================================================================
+
+> (raise-read-error msg-string source-v line-k col-k pos-k span-k)
+
+  Creates and raises an
+>  exn:read
+  exception, using `msg-string' as the base error message.
+
+  Source-location information is added to the error message using the
+  last five arguments (if the `error-print-source-location' parameter
+  is set to #t). The `source-v' argument is an arbitrary value naming
+  the source location --- usually a file path string. Each of the
+  `line-k', `pos-k' arguments is #f or a positive exact integer
+  representing the location within `source-name' (as much as known),
+  `col-k' is a non-negaytive exact integer for the source column (if
+  known), and `span-k' is #f or a non-negative exact integer for an
+  item range starting from the indicated position.
+
+> (raise-read-eof-error msg-string source-v line-k col-k pos-k span-k)
+
+  Like `raise-read-error', but raises
+>  exn:read:eof
+  insteda of `exn:read'.
+
+======================================================================
+_boundmap.ss_: mapping identifiers based on bound-identifier=? and module-identifier=?
+======================================================================
+
+> (make-bound-identifier-mapping) - produces a hash-table-like value
+   for storing a mapping from syntax identifiers to arbitrary
+   values.
+
+   The mapping uses `bound-identifier=?' to compare mapping keys, but
+   also uses a hash table based on symbol equality to make the mapping
+   efficient in the common case (i.e., where the identifiers print
+   differently).
+
+> (bound-identifier-mapping? v) - #t if v was produced by
+   `make-bound-identifier-mapping', #f otherwise.
+
+> bound-identifier-mapping-get : (bound-identifier-mapping?
+				  identifier?
+				  [(-> any)]
+				  . opt-> . 
+				  any)
+  - Like `hash-table-get' for bound-identifier mappings.
+
+> bound-identifier-mapping-put! : (bound-identifier-mapping?
+				   identifier?
+				   any?
+				   . -> .
+				   void?)
+  - Like `hash-table-put! for bound-identifier mappings.
+
+> bound-identifier-mapping-for-each : (bound-identifier-mapping?
+				       (identifier? any? . -> . any)
+				       . -> .
+				       void?)
+  - Like `hash-table-for-each'
+
+> bound-identifier-mapping-map : (bound-identifier-mapping?
+				  (identifier? any? . -> . any)
+				  . -> .
+				  (listof any?))
+  - Like `hash-table-map'
+
+
+> (make-module-identifier-mapping) - produces a hash-table-like value
+   for storing a mapping from syntax identifiers to arbitrary
+   values.
+
+   The mapping uses `module-identifier=?' to compare mapping
+   keys, but also uses a hash table based on symbol equality
+   to make the mapping efficient in the common case, i.e.,
+   where the identifiers print differently. Note that some
+   identifiers print differently but are module-identifier=?
+   to each other. This case is handled properly by this
+   library.
+
+> (module-identifier-mapping? v) - #t if v was produced by
+   `make-module-identifier-mapping', #f otherwise.
+
+> module-identifier-mapping-get : (opt->
+                                   (module-identifier-mapping?
+                                    identifier?)
+                                   [(-> any)]
+                                   any)
+  - Like `hash-table-get' for module-identifier mappings.
+
+> module-identifier-mapping-put! : (module-identifier-mapping?
+                                    identifier?
+                                    any?
+                                    . -> .
+                                    void?)
+  - Like `hash-table-put! for module-identifier mappings.
+
+> module-identifier-mapping-for-each : (module-identifier-mapping?
+                                        (identifier? any? . -> . any)
+                                        . -> .
+                                        void?)
+  - Like `hash-table-for-each'
+
+> module-identifier-mapping-map : (module-identifier-mapping?
+                                   (identifier? any? . -> . any)
+                                   . -> .
+                                   (listof any?))
+  - Like `hash-table-map'
+
+
+======================================================================
+_zodiac.ss_, _zodiac-unit.ss_, and _zodiac-sig.ss_: compatibility
+  layer for software that used to use Zodiac
+======================================================================
+
+The interface is similar to Zodiac --- enough to be useful for porting
+--- but different in many ways. See "zodiac-sig.ss" for details. New
+software should not use this compatibility layer.
+
+======================================================================
+_path-spec.ss_: resolves `include'-like static path specification
+======================================================================
+
+> (resolve-path-spec path-spec-stx source-stx expr-stx build-path-stx)
+
+Resolves the syntactic path specification `path-spec-stx' as for
+MzLib's `include'. The result is a complete path.
+
+The `source-stx' specifies a syntax object whose source-location
+information determines relative-path resolution.  The `expr-stx' is
+used for reporting syntax errors. The `build-path-stx' is usually
+#'build-path; it provides an identifier to compare to parts of
+`path-spec-stx' to recognize the `build-path' keyword.
+
+======================================================================
+_context.ss_: support for _local-expand_
+======================================================================
+
+> (build-expand-context v) - returns an immutable list suitable for
+  use as a context argument to `local-expand' for an
+  internal-definition context. The `v' argument represents the
+  immediate context for expansion. The context list builds on
+  `(syntax-local-context)' if it is a list.
+
+> (generate-expand-context) - calls `build-expand-context' with a
+  generated symbol.
+
+======================================================================
+_trusted-xforms.ss_: trustworthy recertifying transformers
+======================================================================
+
+This module has no exports. It exists only to require other modules
+that perform syntax transformations, where the other transformations
+must use `syntax-recertify'. An application that wishes to provide a
+less powerful code inspector to a sub-program should generally attach
+"trusted-xforms.ss" to the sub-program's namespace so that things like
+the class system work properly.
+
+
diff --git a/collects/syntax/docprovide.ss b/collects/syntax/docprovide.ss
new file mode 100644
index 0000000000..fbc536f2ec
--- /dev/null
+++ b/collects/syntax/docprovide.ss
@@ -0,0 +1,265 @@
+
+(module docprovide mzscheme
+  (require-for-syntax "private/doctable.ss")
+
+  (define-syntaxes (provide-and-document provide-and-document/wrap)
+    (let ()
+      (define (add-prefix prefix rows)
+	(map (lambda (row)
+	       (cons (car row)
+		     (map
+		      (lambda (x) 
+			(cons prefix x))
+		      (cdr row))))
+	     rows))
+
+      (define (remove-prefixes rows)
+	(map (lambda (row)
+	       (cons (car row)
+		     (map (lambda (proc)
+			    (let ([rest (cdr proc)])
+			      (if (pair? (car rest))
+				  (cons (cadar rest)
+					(cdr rest))
+				  rest)))
+			  (cdr row))))
+	     rows))
+
+      (define (remove-docs rows exceptions)
+	(map (lambda (row)
+	       (cons (car row)
+		     (let loop ([l (cdr row)])
+		       (cond
+			[(null? l) null]
+			[(memq (let ([i (cadar l)])
+				 (if (symbol? i)
+				     i
+				     (cadr i)))
+			       exceptions)
+			 (loop (cdr l))]
+			[else (cons (car l) (loop (cdr l)))]))))
+	     rows))
+
+      (define (go stx label wrap rows)
+	(unless (identifier? label)
+		(raise-syntax-error
+		 'provide-and-document
+		 "label is not an identifier"
+		 stx
+		 label))
+	(when wrap
+	      (unless (identifier? wrap)
+		      (raise-syntax-error
+		       'provide-and-document
+		       "wrap is not an identifier"
+		       stx
+		       wrap)))
+	(let ([rows (map (lambda (row)
+			   ;; Helper:
+			   (define (get-existing tag path label exceptions)
+			     (unless (identifier? tag)
+				     (raise-syntax-error
+				      'provide-and-document
+				      "prefix tag is not an identifier"
+				      stx
+				      tag))
+			     (unless (identifier? label)
+				     (raise-syntax-error
+				      'provide-and-document
+				      "label is not an identifier"
+				      stx
+				      label))
+			     (for-each
+			      (lambda (except)
+				(unless (identifier? except)
+					(raise-syntax-error
+					 'provide-and-document
+					 "exclusion is not an identifier"
+					 stx
+					 except)))
+			      exceptions)
+			     (let ([mod ((current-module-name-resolver) path #f #f)])
+			       ;; Execute syntax part at top-level:
+			       (dynamic-require mod (void))
+			       ;; Extract documentation via top-level:
+			       (let ([docs ((dynamic-require-for-syntax 
+					     '(lib "doctable.ss" "syntax" "private") 
+					     'lookup-documentation)
+					    mod
+					    (syntax-e label))])
+				 (unless docs
+					 (raise-syntax-error
+					  'provide-and-document
+					  "could not find provided documentation"
+					  stx
+					  row))
+				 (remove-docs (add-prefix tag docs)
+					      (map syntax-e exceptions)))))
+			   ;; Parse row:
+			   (syntax-case row ()
+					[(header proc ...)
+					 (string? (syntax-e (syntax header)))
+					 (begin
+					   ;; check form:
+					   (map (lambda (proc)
+						  (syntax-case proc ()
+							       [(name type-sexpr doc-string ...)
+								(and (or (identifier? (syntax name))
+									 (let ([l (syntax->list (syntax name))])
+									   (and l
+										(= (length l) 2)
+										(andmap identifier? l))))
+								     (andmap (lambda (s) (string? (syntax-e s)))
+									     (syntax->list (syntax (doc-string ...)))))
+								'ok]))
+						(syntax->list (syntax (proc ...))))
+					   (add-prefix #f (list (syntax-object->datum row))))]
+					[(all-from tag path label)
+					 (eq? 'all-from (syntax-e (syntax all-from)))
+					 (let ([tag (syntax tag)]
+					       [label (syntax label)]
+					       [path (syntax-object->datum (syntax path))])
+					   (get-existing tag path label null))]
+					[(all-from-except tag path label exception ...)
+					 (eq? 'all-from-except (syntax-e (syntax all-from-except)))
+					 (let ([tag (syntax tag)]
+					       [label (syntax label)]
+					       [path (syntax-object->datum (syntax path))]
+					       [exceptions (syntax->list (syntax (exception ...)))])
+					   (get-existing tag path label exceptions))]))
+			 rows)]
+	      [imports (apply
+			append
+			(map (lambda (row)
+			       (syntax-case row ()
+					    [(header . _)
+					     (string? (syntax-e (syntax header)))
+					     null]
+					    [(all-from/-except tag path label except ...)
+					     (list (with-syntax ([pf (datum->syntax-object
+								      stx
+								      (syntax-e
+								       (syntax (prefix tag path))))])
+						     (syntax (require pf))))]))
+			     rows))])
+	  ;; Collapse rows for a section name:
+	  (let ([rows (let loop ([rows (apply append rows)])
+			(if (null? rows)
+			    null
+			    (let ([rest (loop (cdr rows))])
+			      (let ([a (assoc (caar rows) rest)])
+				(if a
+				    (cons (cons (caar rows)
+						(append (cdar rows)
+							(cdr a)))
+					  (let loop ([l rest])
+					    (cond
+					     [(null? l) null]
+					     [(equal? (caar l) (caar rows))
+					      (cdr l)]
+					     [else (cons (car l) (loop (cdr l)))])))
+				    (cons (car rows) rest))))))])
+	    ;; Extract procs and eliminate duplicates
+	    (let ([procs (let ([ht (make-hash-table)])
+			   (for-each
+			    (lambda (proc-line)
+			      (let-values ([(loc-name ext-name)
+					    (let ([n (cadr proc-line)])
+					      (if (pair? n)
+						  (values (car n) (cadr n))
+						  (values n n)))])
+					  (hash-table-put! ht ext-name (list* (car proc-line)
+									      loc-name
+									      ext-name))))
+			    (apply append (map cdr rows)))
+			   (hash-table-map ht (lambda (key val) val)))])
+	      (let ([names (map (lambda (proc)
+				  (cond
+				   [(car proc)
+				    ;; Source prefixed:
+				    `(rename ,(string->symbol (format "~a~a" 
+								      (syntax-e (car proc))
+								      (cadr proc)))
+					     ,(cadr proc))]
+				   [(eq? (cadr proc) (cddr proc))
+				    ;; Plain
+				    (cadr proc)]
+				   [else
+				    ;; Local renamed:
+				    `(rename ,(cadr proc)
+					     ,(cddr proc))]))
+				procs)]
+		    [wrapped-name
+		     (lambda (name)
+		       (string->symbol (format "~a>>~a" 
+					       (syntax-e wrap)
+					       (if (pair? name)
+						   (cadr name)
+						   name))))])
+		(with-syntax ([procs (if wrap
+					 (map (lambda (name)
+						`(rename 
+						  ,(wrapped-name name)
+						  ,(if (pair? name)
+						       (caddr name)
+						       name)))
+					      names)
+					 names)]
+			      [(wrap ...) (if wrap
+					      (map (lambda (name)
+						     `(,wrap ,(datum->syntax-object
+							       wrap
+							       (wrapped-name name))
+							     ,(datum->syntax-object
+							       wrap
+							       (if (pair? name)
+								   (cadr name)
+								   name))))
+						   names)
+					      null)]
+			      [(import ...) imports]
+			      [src (datum->syntax-object stx 'source)]
+			      [rows (remove-prefixes rows)]
+			      [label label])
+		(syntax/loc stx
+			    (begin
+			      import ...
+			      wrap ...
+			      (provide . procs)
+			      (define-syntaxes ()
+				(begin
+				  (register-documentation (quote-syntax src) 'label 'rows)
+				  (values)))))))))))
+
+      (values
+       (lambda (stx)
+	 (syntax-case stx ()
+		      [(_ label row ...)
+		       (go stx
+			   (syntax label)
+			   #f
+			   (syntax->list (syntax (row ...))))]))
+       (lambda (stx)
+	 (syntax-case stx ()
+		      [(_ label wrap row ...)
+		       (go stx
+			   (syntax label)
+			   (let ([s (syntax wrap)])
+			     (and (syntax-e s) s))
+			   (syntax->list (syntax (row ...))))])))))
+
+
+  (define (lookup-documentation path label)
+    (let ([mod ((current-module-name-resolver) path #f #f)])
+      (dynamic-require mod (void))
+      ((dynamic-require-for-syntax 
+	'(lib "doctable.ss" "syntax" "private")
+	'lookup-documentation)
+       mod
+       label)))
+       
+  (provide provide-and-document
+	   provide-and-document/wrap
+	   lookup-documentation))
+
+			      
\ No newline at end of file
diff --git a/collects/syntax/info.ss b/collects/syntax/info.ss
new file mode 100644
index 0000000000..6bbf105a81
--- /dev/null
+++ b/collects/syntax/info.ss
@@ -0,0 +1,5 @@
+
+(module info (lib "infotab.ss" "setup")
+  (define doc.txt "doc.txt")
+  (define name "Syntax Utilities"))
+
diff --git a/collects/syntax/kerncase.ss b/collects/syntax/kerncase.ss
new file mode 100644
index 0000000000..b71924c3b1
--- /dev/null
+++ b/collects/syntax/kerncase.ss
@@ -0,0 +1,47 @@
+
+(module kerncase mzscheme
+
+  (define-syntax kernel-syntax-case
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ stxv trans? clause ...)
+	 (quasisyntax/loc
+	  stx
+	  (syntax-case* stxv #,(datum->syntax-object
+				stx
+				'(quote 
+				  quote-syntax #%datum #%top
+				  lambda case-lambda
+				  let-values letrec-values
+				  begin begin0 set!
+				  with-continuation-mark
+				  if #%app
+				  define-values define-syntaxes define-values-for-syntax
+				  module #%plain-module-begin require provide 
+				  require-for-syntax require-for-template))
+			(if trans? module-transformer-identifier=? module-identifier=?)
+	    clause ...))])))
+
+  (define (kernel-form-identifier-list stx)
+    (map (lambda (s)
+	   (datum->syntax-object stx s #f))
+	 '(begin
+	    define-values
+	    define-syntaxes
+	    define-values-for-syntax
+	    set!
+	    let-values
+	    let*-values
+	    letrec-values
+	    lambda
+	    case-lambda
+	    if
+	    quote
+	    letrec-syntaxes+values
+	    with-continuation-mark
+	    #%app
+	    #%top
+	    #%datum)))
+  
+  (provide kernel-syntax-case
+	  kernel-form-identifier-list))
diff --git a/collects/syntax/moddep.ss b/collects/syntax/moddep.ss
new file mode 100644
index 0000000000..35825cad38
--- /dev/null
+++ b/collects/syntax/moddep.ss
@@ -0,0 +1,424 @@
+
+(module moddep mzscheme
+  (require (lib "etc.ss")
+           (lib "resolver.ss" "planet"))
+  
+
+  (provide moddep-current-open-input-file)
+  (define moddep-current-open-input-file
+    (make-parameter open-input-file))
+  
+  (provide with-module-reading-parameterization)
+  (define (with-module-reading-parameterization thunk)
+    (parameterize ((read-case-sensitive #t)
+		   (read-square-bracket-as-paren #t)
+		   (read-curly-brace-as-paren #t)
+		   (read-accept-box #t)
+		   (read-accept-compiled #t)
+		   (read-accept-bar-quote #t)
+		   (read-accept-graph #t)
+		   (read-decimal-as-inexact #t)
+		   (read-accept-dot #t)
+		   (read-accept-quasiquote #t)
+		   (read-accept-reader #t)
+		   (current-readtable #f))
+      (thunk)))
+
+  (define (raise-wrong-module-name filename expected-name name)
+    (raise
+     (make-exn:fail
+      (string->immutable-string
+       (format
+	"load-handler: expected a `module' declaration for `~a' in ~s, found: ~a"
+	expected-name filename name))
+      (current-continuation-marks))))
+  
+  (define (check-module-form exp expected-module filename)
+    (cond
+     [(or (eof-object? exp)
+	  (eof-object? (syntax-e exp)))
+      (and filename
+	   (raise
+	    (make-exn:fail
+	     (string->immutable-string
+	      (format
+	       "load-handler: expected a `module' declaration for `~a' in ~s, but found end-of-file"
+	       expected-module filename))
+	     (current-continuation-marks))))]
+     [(compiled-module-expression? (syntax-e exp))
+      (if (eq? (module-compiled-name (syntax-e exp))
+	       expected-module)
+	  ;; It's fine:
+	  exp
+	  ;; Wrong name:
+	  (and filename
+	       (raise-wrong-module-name filename expected-module 
+                                        (module-compiled-name (syntax-e exp)))))]
+     [(and (syntax? exp)
+	   (syntax-case exp ()
+	     [(mod nm . _)
+	      (and (eq? (syntax-e (syntax mod)) 'module)
+		   (identifier? (syntax nm)))]
+	     [_else #f]))
+      ;; It's ok; need to install a specific `module' binding:
+      (with-syntax ([(mod nm . _) exp])
+        (unless (eq? (syntax-e (syntax nm)) expected-module)
+          (raise-wrong-module-name filename expected-module (syntax-e (syntax nm))))
+	(datum->syntax-object exp
+			      (cons (syntax module)
+				    (cdr (syntax-e exp)))
+			      exp
+			      exp))]
+     [else
+      (and filename
+	   (raise
+	    (make-exn:fail
+	     (string->immutable-string
+	      (format
+	       "load-handler: expected a `module' declaration for `~a' in ~s, but found something else"
+	       expected-module filename))
+	     (current-continuation-marks))))]))
+  
+  (define re:suffix #rx#"\\..*$")
+	  
+  (define (resolve s)
+    (if (complete-path? s)
+	s
+	(let ([d (current-load-relative-directory)])
+	  (if d (path->complete-path s d) s))))
+  
+  (define (date>=? a bm)
+    (and a
+	 (let ([am (with-handlers ([exn:fail:filesystem? (lambda (x) #f)])
+		     (file-or-directory-modify-seconds a))])
+	   (or (and (not bm) am) (and am bm (>= am bm))))))
+
+  (define (read-one path src?)
+    (let ([p ((moddep-current-open-input-file) path)])
+      (when src? (port-count-lines! p))
+      (dynamic-wind
+       void
+       (lambda ()
+	 (let ([v (with-module-reading-parameterization
+		   (lambda ()
+		     (read-syntax path p)))])
+	   (when (eof-object? v)
+	     (error 'read-one "empty file; expected a module declaration in: ~a" path))
+	   (let ([name (let-values ([(base name dir?) (split-path path)])
+			 (string->symbol (bytes->string/utf-8
+					  (path->bytes (path-replace-suffix  name #""))
+					  #\?)))])
+	     (check-module-form v name path))
+	   (unless (eof-object? (read p))
+	     (error 
+	      'read-one
+	      "file has more than one expression; expected a module declaration only in: ~a"
+	      path))
+	   (if (and (syntax? v)
+		    (compiled-expression? (syntax-e v)))
+	       (syntax-e v)
+	       v)))
+       (lambda () (close-input-port p)))))
+  
+  (define-struct (exn:get-module-code exn) (path))
+
+  (define get-module-code
+    (opt-lambda (path [sub-path "compiled"] [compiler compile] [extension-handler #f])
+      (unless (path-string? path) 
+	(raise-type-error 'get-module-code "path or string (sans nul)" path))
+      (let*-values ([(path) (resolve path)]
+		    [(base file dir?) (split-path path)]
+		    [(base) (if (eq? base 'relative) 'same base)]
+		    [(mode) (use-compiled-file-paths)])
+	(let* ([get-so (lambda (file)
+			 (build-path base
+				     sub-path
+				     "native"
+				     (system-library-subpath)
+				     (path-replace-suffix
+				      file
+				      (case (system-type)
+					[(windows) #".dll"]
+					[else #".so"]))))]
+	       [zo (build-path base
+			       sub-path
+			       (path-replace-suffix file #".zo"))]
+	       [so (get-so file)]
+	       [_loader-so (get-so (string->path "_loader.ss"))]
+	       [path-d (with-handlers ([exn:fail:filesystem? (lambda (x) #f)])
+			 (file-or-directory-modify-seconds path))]
+	       [with-dir (lambda (t) 
+			   (parameterize ([current-load-relative-directory 
+					   (if (path? base) 
+					       base 
+					       (current-directory))])
+			     (t)))])
+	  (cond
+	   ;; Use .zo, if it's new enough
+	   [(date>=? zo path-d)
+	    (read-one zo #f)]
+	   ;; Otherwise, use source if it exists
+	   [path-d 
+            (with-dir (lambda () (compiler (read-one path #t))))]
+	   ;; No source --- maybe there's an .so?
+	   [(and (not path-d)
+		 (date>=? so path-d))
+	    (if extension-handler
+		(extension-handler so #f)
+		(raise (make-exn:get-module-code 
+			(string->immutable-string
+			 (format "get-module-code: cannot use extension file; ~e" so))
+			(current-continuation-marks)
+			so)))]
+	   ;; Or maybe even a _loader.so?
+	   [(and (not path-d)
+		 (date>=? _loader-so path-d)
+		 (let ([getter (load-extension _loader-so)])
+		   (let-values ([(loader modname) (getter (string->symbol 
+							   (bytes->string/latin-1
+							    (path->bytes
+							     (path-replace-suffix file #"")))))])
+		     loader)))
+	    => (lambda (loader)
+		 (if extension-handler
+		     (extension-handler loader #t)
+		     (raise (make-exn:get-module-code 
+			     (string->immutable-string
+			      (format "get-module-code: cannot use _loader file: ~e"
+				      _loader-so))
+			     (current-continuation-marks)
+			     loader))))]
+	   ;; Report a not-there error
+	   [else
+	    (raise (make-exn:get-module-code 
+		    (string->immutable-string (format "get-module-code: no such file: ~e" path))
+		    (current-continuation-marks)
+		    #f))])))))
+
+  (define re:dir #rx#"(.+?)/+(.*)")
+
+  (define (force-relto relto dir?)
+    (cond
+     [(path-string? relto)
+      (if dir?
+	  (let-values ([(base n d?) (split-path relto)])
+	    (if (eq? base 'relative)
+		(or (current-load-relative-directory)
+		    (current-directory))
+		base))
+	  relto)]
+     [(pair? relto) relto]
+     [(not dir?)
+      (error 'resolve-module-path-index "can't resolve \"self\" with just a relative directory ~e" relto)]
+     [(procedure? relto) (relto)]
+     [else
+      (current-directory)]))
+
+  (define resolve-module-path
+    ;; relto should be a complete path, #f, or procedure that returns a complete path
+    (lambda (s relto)
+      (let ([get-dir (lambda () (force-relto relto #t))])
+	(cond
+	 [(string? s)
+	  ;; Parse Unix-style relative path string
+	  (let loop ([path (get-dir)][s (if (path? s)
+					    (path->bytes s)
+					    (string->bytes/utf-8 s))])
+	    (let ([prefix (regexp-match re:dir s)])
+	      (if prefix
+		  (loop (build-path path 
+				    (let ([p (cadr prefix)])
+				      (cond
+				       [(bytes=? p #".") 'same]
+				       [(bytes=? p #"..") 'up]
+				       [else (bytes->path p)])))
+			(caddr prefix))
+		  (build-path path (bytes->path s)))))]
+	 [(and (or (not (pair? s))
+		   (not (list? s)))
+	       (not (path? s)))
+	  #f]
+	 [(or (path? s)
+	      (eq? (car s) 'file))
+	  (let ([p (if (path? s)
+		       s
+		       (cadr s))])
+	    (path->complete-path p (let ([d (get-dir)])
+				     (if (path-string? d)
+					 d
+					 (or (current-load-relative-directory)
+					     (current-directory))))))]
+	 [(eq? (car s) 'lib)
+	  (let ([cols (let ([len (length s)])
+			(if (= len 2)
+			    (list "mzlib")
+			    (cddr s)))])
+	    (let ([p (apply collection-path cols)])
+	      (build-path p (cadr s))))]
+         [(eq? (car s) 'planet)
+          (let ((module-id
+                 (cond
+                   [(path? relto)
+                    (string->symbol (string-append "," (path->string (path->complete-path relto))))]
+                   [else #f])))
+            (let-values ([(path pkg) (get-planet-module-path/pkg s module-id #f)])
+              path))]
+	 [else #f]))))
+
+  (define (resolve-module-path-index mpi relto)
+    ;; relto must be a complete path
+    (let-values ([(path base) (module-path-index-split mpi)])
+      (if path
+	  (resolve-module-path path (resolve-possible-module-path-index base relto))
+	  (force-relto relto #f))))
+
+  (define (resolve-possible-module-path-index base relto)
+    (cond
+     [(module-path-index? base)
+      (resolve-module-path-index base relto)]
+     [(symbol? base)
+      (let ([s (symbol->string base)])
+	(if (and ((string-length s) . > . 0)
+		 (char=? #\, (string-ref s 0)))
+	    (substring s 1 (string-length s))
+	    relto))]
+     [relto (if (procedure? relto)
+		(relto)
+		relto)]
+     [else #f]))
+
+  (define re:path-only #rx#"^(.*)/[^/]*$")
+
+  (define collapse-module-path
+    ;; relto-mp should be a relative path, '(lib relative-path collection), or '(file path)
+    ;;          of a thunk that produces one of those
+    (lambda (s relto-mp)
+      (let ([combine-relative-elements
+	     (lambda (elements)
+	       (when (procedure? relto-mp)
+		 (set! relto-mp (relto-mp)))
+	       (cond
+		[(path-string? relto-mp)
+		 (bytes->string/locale
+		  (apply
+		   bytes-append
+		   (let ([m (regexp-match re:path-only (if (path? relto-mp)
+							   (path->bytes relto-mp)
+							   (string->bytes/locale relto-mp)))])
+		     (if m
+			 (cadr m)
+			 #"."))
+		   (map (lambda (e)
+			  (cond
+			   [(eq? e 'same) #"/."]
+			   [(eq? e 'up) #"/.."]
+			   [else (bytes-append #"/" (if (path? e)
+							(path->bytes e)
+							e))]))
+			elements)))]
+		[else (let ([path (path->string
+				   (apply build-path
+					  (let-values ([(base n d?) (split-path (cadr relto-mp))])
+					    (if (eq? base 'relative)
+						'same
+						base))
+					  (map (lambda (i)
+						 (cond
+						  [(bytes? i) (bytes->path i)]
+						  [else i]))
+					       elements)))])
+			(if (eq? (car relto-mp) 'lib)
+			    `(lib ,path ,(caddr relto-mp))
+			    `(file ,path)))]))])
+	(cond
+	 [(string? s)
+	  ;; Parse Unix-style relative path string
+	  (let loop ([elements null][s (string->bytes/utf-8 s)])
+	    (let ([prefix (regexp-match re:dir s)])
+	      (if prefix
+		  (loop (cons (let ([p (cadr prefix)])
+				(cond
+				 [(bytes=? p #".") 'same]
+				 [(bytes=? p #"..") 'up]
+				 [else (bytes->path p)]))
+			      elements)
+			(caddr prefix))
+		  (combine-relative-elements 
+		   (reverse (cons s elements))))))]
+	 [(and (or (not (pair? s))
+		   (not (list? s)))
+	       (not (path? s)))
+	  #f]
+	 [(or (path? s)
+	      (eq? (car s) 'file))
+	  (let ([p (if (path? s)
+		       s
+		       (cadr s))])
+	    (if (absolute-path? p)
+		s
+		(let loop ([p p][elements null])
+		  (let-values ([(base name dir?) (split-path p)])
+		    (cond
+		     [(eq? base 'relative)
+		      (combine-relative-elements 
+		       (cons name elements))]
+		     [else (loop base (cons name elements))])))))]
+	 [(eq? (car s) 'lib)
+	  (let ([cols (let ([len (length s)])
+			(if (= len 2)
+			    (list "mzlib")
+			    (cddr s)))])
+	    `(lib ,(path->string
+		    (build-path (if (null? (cdr cols))
+				    'same
+				    (apply build-path 'same (cdr cols)))
+				(cadr s)))
+		  ,(car cols)))]
+	 [else #f]))))
+
+  (define (collapse-module-path-index mpi relto-mp)
+    (let-values ([(path base) (module-path-index-split mpi)])
+      (if path
+	  (collapse-module-path path 
+				(cond
+				 [(symbol? base)
+				  (let ([s (symbol->string base)])
+				    (if (and ((string-length s) . > . 0)
+					     (char=? #\, (string-ref s 0)))
+					`(file ,(substring s 1 (string-length s)))
+					relto-mp))]
+				 [(module-path-index? base)
+				  (collapse-module-path-index base relto-mp)]
+				 [else relto-mp]))
+	  relto-mp)))
+
+  (define (show-import-tree module-path)
+    (let loop ([path (resolve-module-path module-path #f)][indent ""][fs ""])
+      (printf "~a~a~a~n" indent path fs)
+      (let ([code (get-module-code path)])
+	(let-values ([(imports fs-imports ft-imports) (module-compiled-imports code)]
+		     [(mk-loop) (lambda (fs)
+				  (lambda (i)
+				    (unless (symbol? i)
+				      (loop (resolve-module-path-index i path)
+					    (format " ~a" indent)
+					    fs))))])
+	  (for-each (mk-loop "") imports)
+	  (for-each (mk-loop " [for-syntax]") fs-imports)
+	  (for-each (mk-loop " [for-template]") ft-imports)))))
+
+  (provide check-module-form
+
+	   get-module-code
+           exn:get-module-code
+           exn:get-module-code?
+           exn:get-module-code-path
+           make-exn:get-module-code
+           
+	   resolve-module-path
+	   resolve-module-path-index
+
+	   collapse-module-path
+	   collapse-module-path-index
+
+	   show-import-tree))
diff --git a/collects/syntax/name.ss b/collects/syntax/name.ss
new file mode 100644
index 0000000000..3e73450dec
--- /dev/null
+++ b/collects/syntax/name.ss
@@ -0,0 +1,23 @@
+
+(module name mzscheme
+  (provide syntax-local-infer-name)
+  
+  (define (syntax-local-infer-name stx)
+    (or (syntax-property stx 'inferred-name)
+	(let ([n (syntax-local-name)])
+	  (or n
+	      (let ([s (syntax-source stx)])
+		(and s
+		     (let ([s (cond
+			       [(path? s) (path->string s)]
+			       [else s])]
+			   [l (syntax-line stx)]
+			   [c (syntax-column stx)])
+		       (if l
+			   (string->symbol (format "~a:~a:~a" s l c))
+			   (let ([p (syntax-position stx)])
+			     (string->symbol (format "~a::~a" s p))))))))))))
+
+				     
+		
+	  
\ No newline at end of file
diff --git a/collects/syntax/path-spec.ss b/collects/syntax/path-spec.ss
new file mode 100644
index 0000000000..7aba18ffd6
--- /dev/null
+++ b/collects/syntax/path-spec.ss
@@ -0,0 +1,65 @@
+(module path-spec mzscheme
+  (require "stx.ss")
+
+  (provide resolve-path-spec)
+
+  (define (resolve-path-spec fn loc stx build-path-stx)
+    (let ([file
+	   (syntax-case* fn (lib) module-or-top-identifier=?
+	     [_
+	      (string? (syntax-e fn))
+	      (let ([s (syntax-e fn)])
+		(unless (or (relative-path? s)
+			    (absolute-path? s))
+		  (raise-syntax-error
+		   #f
+		   "bad pathname string"
+		   stx
+		   fn))
+		(string->path s))]
+	     [(-build-path elem ...)
+	      (module-or-top-identifier=? #'-build-path build-path-stx)
+	      (let ([l (syntax-object->datum (syntax (elem ...)))])
+		(when (null? l)
+		  (raise-syntax-error
+		   #f
+		   "`build-path' keyword is not followed by at least one string"
+		   stx
+		   fn))
+		(apply build-path l))]
+	     [(lib filename ...)
+	      (let ([l (syntax-object->datum (syntax (filename ...)))])
+		(unless (or (andmap string? l)
+			    (pair? l))
+		  (raise-syntax-error
+		   #f
+		   "`lib' keyword is not followed by a sequence of string datums"
+		   stx
+		   fn))
+		(build-path (if (null? (cdr l))
+				(collection-path "mzlib")
+				(apply collection-path (cdr l)))
+			    (car l)))]
+	     [else
+	      (raise-syntax-error
+	       #f
+	       "not a pathname string, `build-path' form, or `lib' form for file"
+	       stx
+	       fn)])])
+      (if (complete-path? file)
+	  file
+	  (path->complete-path
+	   file
+	   (cond
+	    ;; Src of include expression is a path?
+	    [(and (path? (syntax-source loc))
+		  (complete-path? (syntax-source loc)))
+	     (let-values ([(base name dir?) 
+			   (split-path (syntax-source loc))])
+	       (if dir?
+		   (syntax-source loc)
+		   base))]
+	    ;; Load relative?
+	    [(current-load-relative-directory)]
+	    ;; Current directory
+	    [(current-directory)]))))))
diff --git a/collects/syntax/primitives.ss b/collects/syntax/primitives.ss
new file mode 100644
index 0000000000..0fd95a2931
--- /dev/null
+++ b/collects/syntax/primitives.ss
@@ -0,0 +1,34 @@
+
+(module primitives mzscheme
+  
+  ;; The following primitives either invoke functions, or
+  ;;  install functions that can be used later.
+   (define (procedure-calling-prims)
+     '(apply map for-each andmap ormap make-promise
+	     dynamic-wind thread call-in-nested-thread
+	     make-object call-with-values time-apply
+	     call-with-output-file call-with-input-file
+	     with-output-to-file with-input-from-file
+	     exit-handler current-eval current-exception-handler
+	     current-prompt-read current-load
+	     call-with-escape-continuation call-with-current-continuation
+	     current-print port-display-handler port-write-handler
+	     port-print-handler global-port-print-handler
+	     error-display-handler error-escape-handler
+	     port-read-handler error-value->string-handler
+	     call/ec call/cc hash-table-get
+	     hash-table-map hash-table-for-each make-input-port make-output-port
+	     current-module-name-resolver))
+
+   ;; The following primitives can compute return values by an
+   ;;  internal chained tail call (relevant to mzc)
+   (define (internal-tail-chain-prims)
+     '(call-with-values apply 
+	error
+	call-with-current-continuation
+	hash-table-get
+	write-image-to-file
+	syntax-local-value))
+
+   (provide procedure-calling-prims
+	    internal-tail-chain-prims))
diff --git a/collects/syntax/private/doctable.ss b/collects/syntax/private/doctable.ss
new file mode 100644
index 0000000000..743b422bdf
--- /dev/null
+++ b/collects/syntax/private/doctable.ss
@@ -0,0 +1,27 @@
+
+(module doctable mzscheme
+  (require (lib "moddep.ss" "syntax"))
+
+  (define ht (make-hash-table 'equal))
+
+  (define (register-documentation src-stx label v)
+    (let ([mod (let ([s (syntax-source-module src-stx)])
+		 (if (module-path-index? s)
+		      ((current-module-name-resolver)
+		       (collapse-module-path-index s `(lib "docprovide.ss" "syntax"))
+		       #f #f)
+		     s))])
+      (let ([mht (hash-table-get ht mod
+				 (lambda ()
+				   (let ([mht (make-hash-table)])
+				     (hash-table-put! ht mod mht)
+				     mht)))])
+	(hash-table-put! mht label v))))
+
+  (define (lookup-documentation mod label)
+    (let ([mht (hash-table-get ht mod (lambda () #f))])
+      (and mht
+	   (hash-table-get mht label (lambda () #f)))))
+
+  (provide register-documentation
+	   lookup-documentation))
diff --git a/collects/syntax/readerr.ss b/collects/syntax/readerr.ss
new file mode 100644
index 0000000000..6f47f53fcc
--- /dev/null
+++ b/collects/syntax/readerr.ss
@@ -0,0 +1,53 @@
+(module readerr mzscheme
+  (provide raise-read-error
+	   raise-read-eof-error)
+
+  (define (raise-read-error msg source-name line col pos span)
+    (-raise-read-error make-exn:fail:read msg source-name line col pos span))
+    
+  (define (raise-read-eof-error msg source-name line col pos span)
+    (-raise-read-error make-exn:fail:read:eof msg source-name line col pos span))
+
+  (define (-raise-read-error make-exn:fail:read msg source-name line col pos span)
+    (let ([bad-type
+           (lambda (which what)
+             (raise-type-error 'raise-read-error
+                               what
+                               which
+                               msg source-name line col pos span))]
+          [ordinal? (lambda (x)
+                      (or (not x) 
+                          (and (number? x) (exact? x) (positive? x) (integer? x))))]
+          [ordinal "positive exact integer"]
+	  [cardinal? (lambda (x)
+		       (or (not x)
+			   (and (number? x) (exact? x) (not (negative? x)) (integer? x))))]
+	  [cardinal "non-negative exact integer"])
+    
+      (unless (string? msg)
+        (bad-type 0 "string"))
+      (unless (ordinal? line)
+        (bad-type 2 ordinal))
+      (unless (cardinal? col)
+        (bad-type 3 cardinal))
+      (unless (ordinal? pos)
+        (bad-type 4 ordinal))
+      (unless (cardinal? span)
+        (bad-type 5 cardinal))
+      
+      (raise
+       (make-exn:fail:read
+        (string->immutable-string
+         (format "~a~a"
+                 (cond
+                   [(not (error-print-source-location)) ""]
+                   [(and line col)
+                    (format "~a:~a:~a: " source-name line col)]
+                   [pos
+                    (format "~a::~a: " source-name pos)]
+                   [else
+                    (format "~a: " source-name)])
+                 msg))
+        (current-continuation-marks)
+	(list-immutable (make-srcloc
+			 source-name line col pos span)))))))
diff --git a/collects/syntax/struct.ss b/collects/syntax/struct.ss
new file mode 100644
index 0000000000..97f87ecf42
--- /dev/null
+++ b/collects/syntax/struct.ss
@@ -0,0 +1,357 @@
+
+(module struct mzscheme
+  (require (lib "etc.ss")
+	   "stx.ss")
+  (require-for-template mzscheme)
+  
+  (provide parse-define-struct
+
+	   build-struct-names
+	   build-struct-generation
+	   build-struct-expand-info
+	   struct-declaration-info?
+           
+	   generate-struct-declaration
+	   generate-delayed-struct-declaration)
+
+
+  ;; parse-define-struct stx stx -> (values id id-or-#f list-of-id stx)
+  (define (parse-define-struct stx orig-stx)
+
+    (define (parse-at-id)
+      (syntax-case stx ()
+	[(_ id . rest)
+	 (identifier? #'id)
+	 (parse-at-fields #'id #f #'rest)]
+	[(_ (id super-id) . rest)
+	 (and (identifier? #'id)
+	      (identifier? #'super-id))
+	 (parse-at-fields #'id #'super-id #'rest)]
+	[(_ bad . rest)
+	   (raise-syntax-error
+	    #f
+	    "expected an identifer or parenthesized sequence of two identifiers"
+	    orig-stx
+	    #'bad)]))
+
+    (define (parse-at-fields id sup-id rest)
+	(syntax-case rest ()
+	  [((field ...) . rest)
+	   (let ([fields (syntax->list #'(field ...))])
+	     (for-each (lambda (id)
+			 (unless (identifier? id)
+			   (raise-syntax-error
+			    #f
+			    "expected a field identifier"
+			    orig-stx
+			    id)))
+		       fields)
+	     (parse-at-inspector id sup-id fields #'rest))]
+	  [(bad . rest)
+	   (raise-syntax-error
+	    #f
+	    "expected a parenthesized sequence of field identifiers"
+	    orig-stx
+	    #'bad)]
+	  [_
+	   (raise-syntax-error
+	    #f
+	    (string-append "expected fields after " (if sup-id
+							"struct name and parent name"
+							"struct name"))
+	    orig-stx)]))
+
+      (define (parse-at-inspector id sup-id fields rest)
+	(syntax-case rest ()
+	  [() 
+	   (values id sup-id fields #'(current-inspector))]
+	  [(inspector more . rest)
+	   (not (stx-null? #'rest))
+	   (raise-syntax-error
+	    #f
+	    "unexpected form after inspector"
+	    orig-stx
+	    #'more)]
+	  [(inspector)
+	   (values id sup-id fields #'inspector)]
+	  [(inspector . rest)
+	   (raise-syntax-error
+	    #f
+	    "unexpected form after inspector"
+	    orig-stx
+	    #'rest)]
+	  [_
+	   (raise-syntax-error
+	    #f
+	    "bad syntax"
+	    orig-stx)]))
+	  
+
+      (parse-at-id))
+
+
+  ;; build-struct-names : id (list-of id) bool bool -> (list-of id)
+  (define build-struct-names
+    (opt-lambda (name-stx fields omit-sel? omit-set? [srcloc-stx #f])
+      (let ([name (symbol->string (syntax-e name-stx))]
+	    [fields (map symbol->string (map syntax-e fields))]
+	    [+ string-append])
+	(map (lambda (s)
+	       (datum->syntax-object name-stx (string->symbol s) srcloc-stx))
+	     (append
+	      (list 
+	       (+ "struct:" name)
+	       (+ "make-" name)
+	       (+ name "?"))
+	      (let loop ([l fields])
+		(if (null? l)
+		    null
+		    (append
+		     (if omit-sel?
+			 null
+			 (list (+ name "-" (car l))))
+		     (if omit-set?
+			 null
+			 (list (+ "set-" name "-" (car l) "!")))
+		     (loop (cdr l))))))))))
+
+  (define build-struct-generation
+    (opt-lambda (name-stx fields omit-sel? omit-set? [super-type #f] [prop-value-list null]
+                          [immutable-positions null] [mk-rec-prop-list (lambda (struct: make- ? acc mut) null)])
+      (let ([names (build-struct-names name-stx fields omit-sel? omit-set?)])
+	(build-struct-generation* names name-stx fields omit-sel? omit-set? super-type prop-value-list
+				  immutable-positions mk-rec-prop-list))))
+
+  (define build-struct-generation*
+    (opt-lambda (names name fields omit-sel? omit-set? [super-type #f] [prop-value-list null]
+		       [immutable-positions null] [mk-rec-prop-list (lambda (struct: make- ? acc mut) null)])
+      (let ([num-fields (length fields)]
+	    [acc/mut-makers (let loop ([l fields][n 0])
+			      (if (null? l)
+				  null
+				  (let ([mk-one
+					 (lambda (acc?)
+					   (list
+					    `(,(if acc?
+						   'make-struct-field-accessor
+						   'make-struct-field-mutator)
+					      ,(if acc? 'acc 'mut)
+					      ,n ',(car l))))])
+				    (append
+				     (if omit-sel?
+					 null
+					 (mk-one #t))
+				     (if omit-set?
+					 null
+					 (mk-one #f))
+				     (loop (cdr l) (add1 n))))))]
+	    [extra-props (mk-rec-prop-list 'struct: 'make- '? 'acc 'mut)])
+	`(let-values ([(struct: make- ? acc mut)
+		       (make-struct-type ',name ,super-type ,num-fields 0 #f 
+					 ,prop-value-list (current-inspector)
+					 #f ,immutable-positions)])
+	   (values struct:
+		   make-
+		   ?
+		   ,@acc/mut-makers)))))
+
+  (define build-struct-expand-info
+    (lambda (name-stx fields omit-sel? omit-set? base-name base-getters base-setters)
+      (let* ([names (build-struct-names name-stx fields omit-sel? omit-set?)])
+	(build-struct-expand-info* names name-stx fields omit-sel? omit-set? base-name base-getters base-setters))))
+
+  (define build-struct-expand-info*
+    (lambda (names name-stx fields omit-sel? omit-set? base-name base-getters base-setters)
+      (let* ([flds (cdddr names)]
+	     [every-other (lambda (l)
+			    (let loop ([l l])
+			      (cond
+			       [(null? l) null]
+			       [(null? (cdr l)) (list (car l))]
+			       [else (cons (car l) (loop (cddr l)))])))]
+	     [add-#f (lambda (omit? base)
+		       (if omit?
+			   (if (let loop ([l base])
+				 (cond
+				  [(null? l) #t]
+				  [(not (car l)) #f]
+				  [else (loop (cdr l))]))
+			       (append base '(#f)))
+			   base))]
+	     [qs (lambda (x) (if (eq? x #t)
+				 x
+				 (and x `((syntax-local-certifier) (quote-syntax ,x)))))])
+	`(list-immutable
+	  ,(qs (car names))
+	  ,(qs (cadr names))
+	  ,(qs (caddr names))
+	  (list-immutable 
+	   ,@(reverse (if omit-sel?
+			  null
+			  (map qs (if omit-set? flds (every-other flds)))))
+	   ,@(map qs (add-#f omit-sel? base-getters)))
+	  (list-immutable
+	   ,@(reverse (if omit-set?
+			  null
+			  (map qs (if omit-sel?
+				      flds
+				      (every-other (if (null? flds)
+						       null
+						       (cdr flds)))))))
+	   ,@(map qs (add-#f omit-set? base-setters)))
+	  ,(qs base-name)))))
+
+
+  (define (struct-declaration-info? x)
+    (define (identifier/#f? x)
+      (or (not x) 
+	  (identifier? x)))
+    (define (id/#f-list? id? x)
+      (or (null? x)
+	  (and (pair? x)
+	       (if (null? (cdr x))
+		   (identifier/#f? (car x))
+		   (and (id? (car x))
+			(id/#f-list? id? (cdr x)))))))
+
+    (and (list? x)
+	 (= (length x) 6)
+	 (identifier/#f? (car x))
+	 (identifier/#f? (cadr x))
+	 (identifier/#f? (caddr x))
+	 (id/#f-list? identifier? (list-ref x 3))
+	 (id/#f-list? identifier/#f? (list-ref x 4))
+	 (or (eq? #t (list-ref x 5)) (identifier/#f? (list-ref x 5)))))
+
+
+  ;; ----------------------------------------
+
+  (define struct-info-type-id car)
+  (define struct-info-constructor-id cadr)
+  (define struct-info-predicate-id caddr)
+  (define struct-info-accessor-ids cadddr)
+  (define struct-info-mutator-ids (lambda (x) (list-ref x 4)))
+
+  (define (get-stx-info orig-stx super-id defined-names gen-expr?)
+    ;; Looks up super info, if needed, and builds compile-time info for the
+    ;; new struct; called by all three forms, but does only half the work
+    ;; if `defined-names' is #f.
+    ;; If `expr?' is #t, then generate an expression to build the info,
+    ;; otherwise build the info directly.
+    (let ([qs (if gen-expr? (lambda (x) #`((syntax-local-certifier) (quote-syntax #,x))) values)]
+	  [every-other (lambda (l)
+			 (let loop ([l l][r null])
+			   (cond
+			    [(null? l) r]
+			    [(null? (cdr l)) (cons (car l) r)]
+			    [else (loop (cddr l) (cons (car l) r))])))]
+	  [super-info (and super-id 
+			   (syntax-local-value super-id (lambda () #f)))])
+      (when super-id 
+	;; Did we get valid super-info ?
+	(when (or (not (struct-declaration-info? super-info))
+		  (not (struct-info-type-id super-info)))
+	  (raise-syntax-error
+	   #f
+	   (if (struct-declaration-info? super-info)
+	       "parent struct information does not include a type for subtyping"
+	       (format "parent struct type not defined~a"
+		       (if super-info
+			   (format " (~a does not name struct type information)"
+				   (syntax-e super-id))
+			   "")))
+	   orig-stx
+	   super-id)))
+      ;; Generate the results:
+      (values
+       super-info
+       (if defined-names
+	   (let-values ([(initial-gets initial-sets)
+			 (if super-info
+			     (values (map qs (struct-info-accessor-ids super-info))
+				     (map qs (struct-info-mutator-ids super-info)))
+			     (values null null))]
+			[(fields) (cdddr defined-names)]
+			[(wrap) (if gen-expr? (lambda (x) #`(list-immutable #,@x)) values)])
+	     (wrap
+	      (list-immutable (qs (car defined-names))
+			      (qs (cadr defined-names))
+			      (qs (caddr defined-names))
+			      (wrap
+			       (apply
+				list-immutable
+				(append (map qs (every-other fields)) 
+					initial-gets)))
+			      (wrap
+			       (apply
+				list-immutable
+				(append (map qs (if (null? fields) 
+						    null 
+						    (every-other (cdr fields)))) 
+					initial-sets)))
+			      (if super-id
+				  (qs super-id)
+				  #t))))
+	   #f))))
+
+  (define (make-core make-make-struct-type orig-stx defined-names super-info name field-names)
+    #`(let-values ([(type maker pred access mutate)
+		    #,(make-make-struct-type orig-stx name defined-names super-info)])
+	(values type maker pred
+		#,@(let loop ([field-names field-names][n 0])
+		     (if (null? field-names)
+			 null
+			 (list* #`(make-struct-field-accessor access #,n '#,(car field-names))
+				#`(make-struct-field-mutator mutate #,n '#,(car field-names))
+				(loop (cdr field-names) (add1 n))))))))
+
+  (define (generate-struct-declaration orig-stx
+				       name super-id field-names 
+				       context 
+				       make-make-struct-type
+				       continue-macro-id continue-data)
+    (let ([defined-names (build-struct-names name field-names #f #f name)]
+	  [delay? (and (not (memq context '(module top-level expression)))
+		       super-id)])
+      (let-values ([(super-info stx-info) 
+		    (if delay?
+			(values #f #f)
+			(get-stx-info orig-stx super-id defined-names #t))])
+	(let ([result
+	       #`(begin
+		   (define-values
+		     #,defined-names
+		     #,(if delay?
+			   #`(begin0 ;; the `begin0' guarantees that it's an expression
+			      (#,continue-macro-id #,orig-stx #,name #,super-id 
+						   #,defined-names #,field-names 
+						   #,continue-data))
+			   (make-core make-make-struct-type orig-stx defined-names super-info name field-names)))
+		   (define-syntaxes (#,name)
+		     #,(if delay?
+			   #`(let-values ([(super-info stx-info) 
+					   (get-stx-info (quote-syntax ,orig-stx)
+							 (quote-syntax ,super-id)
+							 (list #,@(map (lambda (x) 
+									 #`(quote-syntax #,x))
+								       defined-names))
+							 #f
+							 values)])
+			       stx-info)
+			   stx-info)))])
+	  (if super-id
+	      (syntax-property result 
+			       'disappeared-use 
+			       (syntax-local-introduce super-id))
+	      result)))))
+
+  (define (generate-delayed-struct-declaration stx make-make-make-struct-type)
+    (syntax-case stx ()
+      [(_ orig-stx name super-id defined-names field-names continue-data)
+       (let-values ([(super-info stx-info) (get-stx-info #'orig-stx #'super-id #f #f)])
+	 (make-core (make-make-make-struct-type #'continue-data)
+		    #'orig-stx
+		    (syntax->list #'defined-names)
+		    super-info
+		    #'name
+		    (syntax->list #'field-names)))])))
diff --git a/collects/syntax/stx.ss b/collects/syntax/stx.ss
new file mode 100644
index 0000000000..818d16372f
--- /dev/null
+++ b/collects/syntax/stx.ss
@@ -0,0 +1,78 @@
+(module stx mzscheme
+
+  ;; These utilities facilitate operations on syntax objects.
+  ;; A syntax object that represents a parenthesized sequence
+  ;; can contain a mixture of cons cells and syntax objects,
+  ;; hence the need for `stx-null?', `stx-car', etc.
+
+  ;; a syntax null?
+  (define (stx-null? p)
+    (or (null? p)
+	(and (syntax? p) 
+	     (null? (syntax-e p)))))
+
+  ;; a syntax pair?
+  (define (stx-pair? p)
+    (or (pair? p)
+	(and (syntax? p)
+	     (pair? (syntax-e p)))))
+
+  ;; a syntax list?
+  (define (stx-list? p)
+    (or (list? p)
+	(if (syntax? p) 
+	    (or (list? (syntax-e p))
+		(let loop ([l (syntax-e p)])
+		  (if (pair? l)
+		      (loop (cdr l))
+		      (stx-list? l))))
+	    (and (pair? p)
+		 (stx-list? (cdr p))))))
+
+  ;; car of a syntax pair
+  (define (stx-car p)
+    (if (pair? p)
+	(car p)
+	(car (syntax-e p))))
+
+  ;; cdr of a syntax pair
+  (define (stx-cdr p)
+    (if (pair? p)
+	(cdr p)
+	(cdr (syntax-e p))))
+
+  ;; Flattens a syntax list into a list
+  (define (stx->list e)
+    (if (syntax? e)
+	(syntax->list e)
+	(let ([flat-end
+	       (let loop ([l e])
+		 (if (null? l) 
+		     #f
+		     (if (pair? l)
+			 (loop (cdr l))
+			 (if (syntax? l) 
+			     (syntax->list l)
+			     #f))))])
+	  (if flat-end
+	      ;; flatten
+	      (let loop ([l e])
+		(if (null? l) 
+		    null
+		    (if (pair? l) 
+			(cons (car l) (loop (cdr l)))
+			(if (syntax? l) 
+			    flat-end))))
+	      e))))
+
+  (define (module-or-top-identifier=? a b)
+    (or (module-identifier=? a b)
+	(and (eq? (syntax-e a) (syntax-e b))
+	     (module-identifier=? a
+				  (datum->syntax-object
+				   #f
+				   (syntax-e b))))))
+
+  (provide stx-null? stx-pair? stx-list?
+	   stx-car stx-cdr stx->list
+	   module-or-top-identifier=?))
diff --git a/collects/syntax/toplevel.ss b/collects/syntax/toplevel.ss
new file mode 100644
index 0000000000..630c8ff6a7
--- /dev/null
+++ b/collects/syntax/toplevel.ss
@@ -0,0 +1,97 @@
+
+(module toplevel mzscheme
+  (require "kerncase.ss")
+  
+  (provide eval-compile-time-part-of-top-level
+	   eval-compile-time-part-of-top-level/compile
+           expand-top-level-with-compile-time-evals
+           expand-syntax-top-level-with-compile-time-evals
+           expand-syntax-top-level-with-compile-time-evals/flatten)
+
+  ;; eval-compile-time-part-of-top-level/compile : syntax -> (listof compiled-expression)
+  (define (eval-compile-time-part-of-top-level/compile expr)
+    (map (lambda (e) (compile-and-eval-compile-time-part e #t))
+         (flatten-out-begins expr)))
+  
+  (define (eval-compile-time-part-of-top-level stx)
+    (for-each (lambda (e) (compile-and-eval-compile-time-part e #f))
+              (flatten-out-begins stx)))
+  
+  (define (expand-top-level-with-compile-time-evals stx)
+    (expand-syntax-top-level-with-compile-time-evals 
+     (namespace-syntax-introduce stx)))
+
+  ;; expand-syntax-top-level-with-compile-time-evals/flatten : syntax -> (listof syntax)
+  (define (expand-syntax-top-level-with-compile-time-evals/flatten stx)
+    (let loop ([stx stx])
+      (let ([e (expand-syntax-to-top-form stx)])
+        (syntax-case e (begin)
+          [(begin expr ...)
+           (apply append (map loop (syntax->list (syntax (expr ...)))))]
+          [else 
+           (let ([e (expand-syntax e)])
+             (compile-and-eval-compile-time-part e #f)
+             (list e))]))))
+  
+  (define (expand-syntax-top-level-with-compile-time-evals stx)
+    (let ([e (expand-syntax-to-top-form stx)])
+      (syntax-case e (begin)
+        [(begin expr ...)
+         (with-syntax ([(expr ...) 
+                        ;;left-to-right part of this map is important:
+                        (map expand-syntax-top-level-with-compile-time-evals
+                             (syntax->list (syntax (expr ...))))]
+                       [(beg . _) e])
+           (datum->syntax-object e (syntax-e (syntax (beg expr ...))) e e))]
+        [else 
+         (let ([e (expand-syntax e)])
+           (compile-and-eval-compile-time-part e #f)
+           e)])))
+  
+  ;; compile-and-eval-compile-time-part : syntax boolean -> (union syntax compiled-expression)
+  ;; compiles the syntax it receives as an argument and evaluates the compile-time part of it.
+  ;; result depends on second argument. If #t, returns compiled expressions
+  ;; if #f, returns void (and doesn't do any extra compilation)
+  ;; pre: there are no top-level begins in stx.
+  (define (compile-and-eval-compile-time-part stx compile?)
+    (let ([eval/compile (lambda (stx) 
+                          (let ([compiled (compile-syntax stx)])
+                            (eval compiled)
+                            (when compile?
+                              compiled)))])
+      (kernel-syntax-case stx #f
+        [(require req ...)
+	 (begin0
+	  (when compile? (compile-syntax stx))
+	  (for-each (lambda (req) (namespace-require/expansion-time (syntax-object->datum req)))
+		    (syntax->list (syntax (req ...)))))]
+        [(module . _)
+         (eval/compile stx)]
+        [(define-syntaxes . _)
+         (eval/compile stx)]
+        [(define-values-for-syntax . _)
+         (eval/compile stx)]
+        [(require-for-syntax . _)
+         (eval/compile stx)]
+        [(define-values (id ...) . _)
+	 (begin0
+	  (when compile? (compile-syntax stx))
+	  (for-each (lambda (id)
+		      (with-syntax ([id id]
+				    [undefined (letrec ([x x]) x)])
+			(eval-syntax (syntax (define-values (id) undefined)))))
+		    (syntax->list (syntax (id ...)))))]
+        [_else 
+         (when compile? (compile-syntax stx))])))
+  
+  ;; flatten-out-begins : syntax -> (listof syntax)
+  ;; flattens out the begins in a top-level expression,
+  ;; into multiple expressions
+  (define (flatten-out-begins expr)
+    (let loop ([expr expr])
+      (let ([expr (expand-syntax-to-top-form expr)])
+	(syntax-case expr (begin)
+	  [(begin expr ...)
+	   (apply append (map loop (syntax->list (syntax (expr ...)))))]
+	  [else 
+	   (list expr)])))))
\ No newline at end of file
diff --git a/collects/syntax/trusted-xforms.ss b/collects/syntax/trusted-xforms.ss
new file mode 100644
index 0000000000..47491004a2
--- /dev/null
+++ b/collects/syntax/trusted-xforms.ss
@@ -0,0 +1,2 @@
+(module trusted-xforms mzscheme
+  (require (lib "class.ss")))
diff --git a/collects/syntax/zodiac-sig.ss b/collects/syntax/zodiac-sig.ss
new file mode 100644
index 0000000000..1b0762e4b2
--- /dev/null
+++ b/collects/syntax/zodiac-sig.ss
@@ -0,0 +1,101 @@
+
+;; Interface for zodiac compatibility layer,
+;;  for programs that used to manipulate the
+;;  output of zodiac elaboration.
+
+(module zodiac-sig mzscheme
+  (require (lib "unitsig.ss"))
+  
+  (provide zodiac^)
+
+  (define-signature  zodiac^
+    (;; Syntax -> zodiac compatibility:
+     syntax->zodiac
+     ;; Zodiac compatibility -> syntax:
+     zodiac->syntax
+
+     structurize-syntax
+     zread-object ; = (compose syntax-e zodiac-stx)
+
+     ;; origin struct:
+     origin-who  ; 'source or 'macro
+     origin-how  ; #f or tree of syntax objects,
+                 ;  as repotred by the 'origin
+                 ;  property of the syntax object.
+     
+     ;; location struct:
+     location-line    ; = syntax line
+     location-column  ; = syntax col
+     location-file    ; = syntax src
+     ;; Note: there is no location-offset, yet
+
+     ;; EOF
+     eof?
+
+     ;; zodiac struct:
+     ;;  zodiac (stx) ; used to be (origin start finish)
+     (struct zodiac (stx))
+     zodiac-origin    ; = identity
+     zodiac-start     ; = identity
+     zodiac-finish    ; = zodiac-start
+
+     ;; reader structs:
+     ;;  zodiac (stx)
+     ;;    zread ; used to have (object)
+     ;; The sub-tree has been cut off; inspect
+     ;;  the stx object, instead.
+     (struct zread ())
+
+     ;; elaborator structs:
+     (struct parsed (back))
+
+     (struct varref (var))
+     (struct top-level-varref (module slot exptime? expdef? position))  ; added module, exptime?, position
+     create-top-level-varref
+     (struct bound-varref (binding))   create-bound-varref
+
+     (struct binding (var orig-name))  create-binding
+
+     make-lexical-varref
+     lexical-varref? create-lexical-varref      ; alias for bound-varref
+     make-lexical-binding
+     lexical-binding?  create-lexical-binding   ; alias for binding
+
+     (struct app (fun args))           create-app
+
+     (struct if-form (test then else))               create-if-form
+     (struct quote-form (expr))                      create-quote-form
+     (struct begin-form (bodies))                    create-begin-form
+     (struct begin0-form (bodies))                   create-begin0-form
+     (struct let-values-form (vars vals body))       create-let-values-form
+     (struct letrec-values-form (vars vals body))    create-letrec-values-form
+     (struct define-values-form (vars val))          create-define-values-form
+     (struct set!-form (var val))                    create-set!-form
+     (struct case-lambda-form (args bodies))         create-case-lambda-form
+     (struct with-continuation-mark-form (key val body)) create-with-continuation-mark-form
+
+     ;; Thess are new:
+     (struct quote-syntax-form (expr))               create-quote-syntax-form
+     (struct define-syntaxes-form (names expr))      create-define-syntaxes-form
+     (struct define-for-syntax-form (names expr))    create-define-for-syntax-form
+     (struct module-form (name requires            ; lstof stx for module paths
+			       for-syntax-requires ; lstof stx for module paths
+			       for-template-requires ; lstof stx for module paths
+			       body                ; begin form
+			       syntax-body         ; begin form
+			       provides  ; lstof (sym | (def-sym . prvd-sym) | (mod-path def-sym . prvd-sym))
+			       syntax-provides  ;  ditto
+			       indirect-provides   ; lstof sym
+			       kernel-reprovide-hint ; #f | #t | exclude-sym
+			       self-path-index))   ; module path index
+     create-module-form
+     (struct require/provide-form ())                create-require/provide-form
+
+     ;; args:
+     (struct arglist (vars))
+     (struct sym-arglist ())
+     (struct list-arglist ())
+     (struct ilist-arglist ())
+
+     make-empty-back-box
+     register-client)))
diff --git a/collects/syntax/zodiac-unit.ss b/collects/syntax/zodiac-unit.ss
new file mode 100644
index 0000000000..bd9264ce5c
--- /dev/null
+++ b/collects/syntax/zodiac-unit.ss
@@ -0,0 +1,732 @@
+;; Zodiac compatibility layer,
+;;  for programs that used to manipulate the
+;;  output of zodiac elaboration.
+
+(module zodiac-unit mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "list.ss"))
+  (require "kerncase.ss")
+
+  (require "zodiac-sig.ss"
+	   "stx.ss")
+
+  (provide zodiac@)
+
+  (define zodiac@
+    (unit/sig zodiac^
+      (import)
+      
+      (define (stx-bound-assq ssym l)
+	(ormap (lambda (p)
+		 (and (bound-identifier=? ssym (car p))
+		      p))
+	       l))
+
+      ;; Back boxes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+      (define-struct secure-box (value))
+
+      (define init-value-list '())
+
+      (define register-initial-value
+	(lambda (index value-thunk)
+	  (set! init-value-list
+		(append init-value-list
+			(list value-thunk)))))
+
+      (define make-initial-value-vector
+	(lambda ()
+	  (let ((v (make-vector current-vector-size uninitialized-flag)))
+	    (let loop ((index 0) (inits init-value-list))
+	      (unless (null? inits)
+		(vector-set! v index ((car inits)))
+		(loop (add1 index) (cdr inits))))
+	    v)))
+
+      (define make-empty-back-box
+	(lambda ()
+	  (make-secure-box (make-initial-value-vector))))
+
+      (define current-vector-size 2)
+      
+      (define next-client-count
+	(let ((count -1))
+	  (lambda ()
+	    (set! count (add1 count))
+	    (when (>= count current-vector-size)
+	      (set! current-vector-size (* 2 current-vector-size)))
+	    count)))
+
+      (define-struct uninitialized-back ())
+      (define uninitialized-flag (make-uninitialized-back))
+      
+      (define getters-setters
+	(lambda (index)
+	  (values
+	   (lambda (back)		; getter
+	     (let ((v (secure-box-value back)))
+	       (with-handlers
+		   ((exn:fail:contract?
+		     (lambda (exception)
+		       (vector-ref (extend-back-vector back) index))))
+		 (let ((value (vector-ref v index)))
+		   (if (uninitialized-back? value)
+		       (let ((correct-value
+			      ((list-ref init-value-list index))))
+			 (vector-set! v index correct-value)
+			 correct-value)
+		       value)))))
+	   (lambda (back value)		; setter
+	     (let ((v (secure-box-value back)))
+	       (with-handlers
+		   ((exn:fail:contract?
+		     (lambda (exception)
+		       (vector-set! (extend-back-vector back) index value))))
+		 (vector-set! v index value)))))))
+  
+      (define register-client
+	(lambda (client-name default-initial-value-thunk)
+	  (let ((index (next-client-count)))
+	    (register-initial-value index default-initial-value-thunk)
+	    (getters-setters index))))
+      
+      (define extend-back-vector
+	(lambda (back-box)
+	  (let ((v (secure-box-value back-box)))
+	    (let ((new-v (make-initial-value-vector)))
+	      (let loop ((n (sub1 (vector-length v))))
+		(when (>= n 0)
+		  (vector-set! new-v n (vector-ref v n))
+		  (loop (sub1 n))))
+	      (set-secure-box-value! back-box new-v)
+	      new-v))))
+      
+      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+      (define (mk-back) (make-empty-back-box))
+
+      (define (get-slot stx table)
+	(let ([l (hash-table-get table (syntax-e stx) (lambda () null))])
+	  (let ([s (ormap (lambda (b)
+			    (and (module-identifier=? stx (car b))
+				 (cdr b)))
+			  l)])
+	    (if s
+		s
+		(let ([s (box #f)])
+		  (hash-table-put! table (syntax-e stx) (cons (cons stx s) l))
+		  s)))))
+
+      (define (let-s->z mk-let rec? stx env loop)
+	(syntax-case stx ()
+	  [(_ ([vars rhs] ...) . body)
+	   (let* ([varses (syntax->list (syntax (vars ...)))]
+		  [rhses (syntax->list (syntax (rhs ...)))]
+		  [z:varses (map (lambda (vars)
+				   (map (lambda (var)
+					  (make-binding
+					   stx
+					   (mk-back)
+					   (gensym (syntax-e var))
+					   (syntax-e var)))
+					(syntax->list vars)))
+				 varses)]
+		  [body-env (append
+			     (apply
+			      append
+			      (map (lambda (z:vars vars)
+				     (map (lambda (z:var var)
+					    (cons
+					     var
+					     z:var))
+					  z:vars
+					  (syntax->list vars)))
+				   z:varses
+				   varses))
+			     env)])
+	     (mk-let
+	      stx
+	      (mk-back)
+	      z:varses
+	      (map (lambda (rhs)
+		     (loop rhs (if rec? body-env env)))
+		   rhses)
+	      (loop (syntax (begin . body)) body-env)))]))
+      
+      (define (args-s->z env args)
+	(let-values ([(maker ids)
+		      (syntax-case args ()
+			[id
+			 (identifier? (syntax id))
+			 (values make-sym-arglist
+				 (list (syntax id)))]
+			[(id ...)
+			 (values make-list-arglist (syntax->list args))]
+			[_else (values make-ilist-arglist
+				       (let loop ([args args])
+					 (syntax-case args ()
+					   [id (identifier? args) (list args)]
+					   [(id . rest)
+					    (cons (syntax id) (loop (syntax rest)))])))])])
+	  (let ([bindings
+		 (map (lambda (id)
+			(make-binding
+			 id
+			 (mk-back)
+			 (gensym (syntax-e id))
+			 (syntax-e id)))
+		      ids)])
+	    (values
+	     (append (map cons ids bindings) env)
+	     (maker bindings)))))
+
+      (define (syntax->zodiac stx)
+	(define slot-table (make-hash-table))
+	(define trans-slot-table (make-hash-table))
+	(define syntax-slot-table (make-hash-table))
+
+	(if (eof-object? stx)
+	    stx
+	    (let loop ([stx stx][env null][trans? #f])
+	      (kernel-syntax-case stx trans?
+		[id
+		 (identifier? stx)
+		 (let ([a (stx-bound-assq stx env)])
+		   (if a
+		       ;; Lexical reference:
+		       (make-bound-varref
+			stx
+			(mk-back)
+			(binding-var (cdr a))
+			(cdr a))
+		       ;; Top-level (or module) reference:
+		       (let ([b (let ([b ((if trans?
+					      identifier-transformer-binding
+					      identifier-binding)
+					  stx)])
+				  ;; If b, is it imported?
+				  (and (pair? b)
+				       (let ([modname (and (pair? b) (car b))])
+					 (and (or (symbol? modname)
+						  (and (module-path-index? modname)
+						       (let-values ([(name base) (module-path-index-split modname)])
+							 (or name base))))
+					      b))))])
+			 (make-top-level-varref
+			  stx
+			  (mk-back)
+			  (if b
+			      (cadr b)
+			      (syntax-e stx))
+			  (let ([modname (and b (car b))])
+			    modname)
+			  (get-slot stx (if trans? trans-slot-table slot-table))
+			  trans?
+			  (and b (list-ref b 4))
+			  (and b
+			       ((if trans?
+				    identifier-transformer-binding-export-position
+				    identifier-binding-export-position)
+				stx))))))]
+
+		[(#%top . id)
+		 ;; Top-level reference:
+		 (make-top-level-varref
+		  stx
+		  (mk-back)
+		  (syntax-e (syntax id))
+		  #f
+		  (get-slot (syntax id) (if trans? trans-slot-table slot-table))
+		  trans?
+		  #f
+		  #f)]
+
+		[(#%datum . val)
+		 (let ([val (syntax val)])
+		   (make-quote-form
+		    stx
+		    (mk-back)
+		    (make-zread
+		     val)))]
+
+		[(define-values names rhs)
+		 (make-define-values-form
+		  stx
+		  (mk-back)
+		  (map (lambda (stx)
+			 (let ([b (identifier-binding stx)])
+			   (make-top-level-varref
+			    stx
+			    (mk-back)
+			    (if (pair? b)
+				(cadr b)
+				(syntax-e stx))
+			    (and (pair? b) (car b))
+			    (get-slot stx slot-table)
+			    #f
+			    #f
+			    #f)))
+		       (syntax->list (syntax names)))
+		  (loop (syntax rhs) null #f))]
+		
+		[(-define names rhs)
+		 (or (module-identifier=? #'-define #'define-syntaxes)
+		     (module-identifier=? #'-define #'define-values-for-syntax))
+		 (let ([for-stx? (module-identifier=? #'-define #'define-values-for-syntax)])
+		   ((if for-stx?
+			make-define-for-syntax-form
+			make-define-syntaxes-form)
+		    stx
+		    (mk-back)
+		    (map (lambda (stx)
+			   (let ([b (identifier-binding stx)])
+			     (make-top-level-varref
+			      stx
+			      (mk-back)
+			      (if (pair? b)
+				  (cadr b)
+				  (syntax-e stx))
+			      (and (pair? b) (car b))
+			      (get-slot stx syntax-slot-table)
+			      #f
+			      for-stx?
+			      #f)))
+			 (syntax->list (syntax names)))
+		    (loop (syntax rhs) null #t)))]
+		
+		[(module name init-require (#%plain-module-begin . body))
+		 (let* ([body (map (lambda (x)
+				     (loop x env trans?))
+				   (syntax->list (syntax body)))]
+			[get-required-modules
+			 (lambda (req)
+			   (let loop ([body body])
+			     (cond
+			      [(null? body) null]
+			      [(and (require/provide-form? (car body))
+				    (module-identifier=? req (stx-car (zodiac-stx (car body)))))
+			       (append
+				(map (lambda (r)
+				       (syntax-case* r (prefix all-except rename)
+					   (lambda (a b) (eq? (syntax-e a)
+							      (syntax-e b)))
+					 [mod
+					  (identifier? r)
+					  r]
+					 [(prefix id mod)
+					  (syntax mod)]
+					 [(rename mod . _)
+					  (syntax mod)]
+					 [(all-except mod . _)
+					  (syntax mod)]
+					 [_else r]))
+				     (stx->list (stx-cdr (zodiac-stx (car body)))))
+				(loop (cdr body)))]
+			      [else (loop (cdr body))])))]
+			[rt-required
+			 (cons (syntax init-require)
+			       (get-required-modules (quote-syntax require)))]
+			[et-required
+			 (cons (syntax init-require)
+			       (get-required-modules (quote-syntax require-for-syntax)))]
+			[tt-required
+			 (cons (syntax init-require)
+			       (get-required-modules (quote-syntax require-for-template)))]
+			[et-body
+			 (filter (lambda (e)
+				   (or (define-syntaxes-form? e)
+				       (define-for-syntax-form? e)))
+				 body)]
+			[rt-body
+			 (filter (lambda (e) (and (not (define-syntaxes-form? e))
+						  (not (define-for-syntax-form? e))
+						  (not (require/provide-form? e))))
+				 body)])
+		   (make-module-form
+		    stx
+		    (mk-back)
+		    (syntax name)
+		    rt-required
+		    et-required
+		    tt-required
+		    (make-begin-form
+		     stx
+		     (mk-back)
+		     rt-body)
+		    (make-begin-form
+		     stx
+		     (mk-back)
+		     et-body)
+		    (syntax-property stx 'module-variable-provides)
+		    (syntax-property stx 'module-syntax-provides)
+		    (syntax-property stx 'module-indirect-provides)
+		    (syntax-property stx 'module-kernel-reprovide-hint)
+		    (syntax-property stx 'module-self-path-index)))]
+		[(require i ...)
+		 (make-require/provide-form
+		  stx
+		  (mk-back))]
+		[(require-for-syntax i ...)
+		 (make-require/provide-form
+		  stx
+		  (mk-back))]
+		[(require-for-template i ...)
+		 (make-require/provide-form
+		  stx
+		  (mk-back))]
+		[(provide i ...)
+		 (make-require/provide-form
+		  stx
+		  (mk-back))]
+
+		[(quote expr)
+		 (make-quote-form
+		  stx
+		  (mk-back)
+		  (make-zread (syntax expr)))]
+
+		[(quote-syntax expr)
+		 (make-quote-syntax-form
+		  stx
+		  (mk-back)
+		  (syntax expr))]
+		
+		[(lambda args . body)
+		 (let-values ([(env args) (args-s->z env (syntax args))])
+		   (make-case-lambda-form
+		    stx
+		    (mk-back)
+		    (list args)
+		    (list (loop (syntax (begin . body)) env trans?))))]
+		[(case-lambda [args . body] ...)
+		 (let-values ([(envs argses)
+			       (let ([es+as
+				      (map
+				       (lambda (args)
+					 (let-values ([(env args) (args-s->z env args)])
+					   (cons env args)))
+				       (syntax->list (syntax (args ...))))])
+				 (values
+				  (map car es+as)
+				  (map cdr es+as)))])
+		   (make-case-lambda-form
+		    stx
+		    (mk-back)
+		    argses
+		    (map (lambda (env body)
+			   (with-syntax ([body body])
+			     (loop (syntax (begin . body)) env trans?)))
+			 envs
+			 (syntax->list (syntax (body ...))))))]
+
+		[(let-values . _)
+		 (let-s->z make-let-values-form #f stx env
+			   (lambda (b env) (loop b env trans?)))]
+		[(letrec-values . _)
+		 (let-s->z make-letrec-values-form #t stx env
+			   (lambda (b env) (loop b env trans?)))]
+		
+		[(set! var rhs)
+		 (make-set!-form
+		  stx
+		  (mk-back)
+		  (loop (syntax var) env trans?)
+		  (loop (syntax rhs) env trans?))]
+		
+		[(begin . exprs)
+		 (make-begin-form
+		  stx
+		  (mk-back)
+		  (map (lambda (x)
+			 (loop x env trans?))
+		       (syntax->list (syntax exprs))))]
+		
+		[(begin0 . exprs)
+		 (make-begin0-form
+		  stx
+		  (mk-back)
+		  (map (lambda (x)
+			 (loop x env trans?))
+		       (syntax->list (syntax exprs))))]
+
+		[(if test then)
+		 (make-if-form
+		  stx
+		  (mk-back)
+		  (loop (syntax test) env trans?)
+		  (loop (syntax then) env trans?)
+		  (loop (syntax (#%app void)) env trans?))]
+
+		[(if test then else)
+		 (make-if-form
+		  stx
+		  (mk-back)
+		  (loop (syntax test) env trans?)
+		  (loop (syntax then) env trans?)
+		  (loop (syntax else) env trans?))]
+
+		[(with-continuation-mark k v body)
+		 (make-with-continuation-mark-form
+		  stx
+		  (mk-back)
+		  (loop (syntax k) env trans?)
+		  (loop (syntax v) env trans?)
+		  (loop (syntax body) env trans?))]
+
+		[(#%app)
+		 (make-quote-form
+		  (syntax/loc stx ())
+		  (mk-back)
+		  (make-zread (quote-syntax ())))]
+		[(#%app func arg ...)
+		 (make-app
+		  stx
+		  (mk-back)
+		  (loop (syntax func) env trans?)
+		  (map
+		   (lambda (arg)
+		     (loop arg env trans?))
+		   (syntax->list (syntax (arg ...)))))]
+		
+		[_else
+		 (error 'syntax->zodiac
+			"unrecognized expression form: ~e"
+			(syntax-object->datum stx))]))))
+
+      
+      (define (zodiac->syntax x)
+	(let loop ([x x])
+	  (cond
+	   [(zread? x)
+	    (zodiac-stx x)]
+
+	   [(top-level-varref? x)
+	    (zodiac-stx x)]
+	   [(bound-varref? x)
+	    ;; An stx object is getting gensymmed here!
+	    (datum->syntax-object #f (binding-var (bound-varref-binding x)) #f)]
+	   
+	   [(app? x)
+	    (with-syntax ([fun (loop (app-fun x))]
+			  [args (map loop (app-args x))])
+	      (syntax (#%app fun . args)))]
+
+	   [(if-form? x)
+	    (with-syntax ([test (loop (if-form-test x))]
+			  [then (loop (if-form-then x))]
+			  [else (loop (if-form-else x))])
+	      (syntax (if test then else)))]
+
+	   [(quote-form? x)
+	    (with-syntax ([v (zodiac-stx (quote-form-expr x))])
+	      (syntax (quote v)))]
+	   [(quote-syntax-form? x)
+	    (with-syntax ([v (quote-syntax-form-expr x)])
+	      (syntax (quote-syntax v)))]
+
+	   [(begin-form? x)
+	    (with-syntax ([body (map loop (begin-form-bodies))])
+	      (syntax (begin . body)))]
+	   [(begin0-form? x)
+	    (with-syntax ([body (map loop (begin-form-bodies))])
+	      (syntax (begin0 . body)))]
+
+	   [(let-values-form? x)
+	    (with-syntax ([(vars ...)
+			   (map (lambda (vars)
+				  (map binding-var vars))
+				(let-values-form-vars x))]
+			  [(val ...)
+			   (map loop (let-values-form-vals x))]
+			  [body (loop (let-values-form-body x))])
+	      (syntax (let-values ([vars val] ...) body)))]
+	   [(letrec-values-form? x)
+	    (with-syntax ([(vars ...)
+			   (map (lambda (vars)
+				  (map binding-var vars))
+				(letrec-values-form-vars x))]
+			  [(val ...)
+			   (map loop (letrec-values-form-vals x))]
+			  [body (loop (letrec-values-form-body x))])
+	      (syntax (letrec-values ([vars val] ...) body)))]
+	   
+	   [(define-values-form? x)
+	    (with-syntax ([vars (map zodiac-stx (define-values-form-vars x))]
+			  [val (loop (define-values-form-val x))])
+	      (syntax (define-values vars val)))]
+	   
+	   [(set!-form? x)
+	    (with-syntax ([var (loop (set!-form-var x))]
+			  [val (loop (set!-form-val x))])
+	      (syntax (set! var val)))]
+	   
+	   [(case-lambda-form? x)
+	    (with-syntax ([(args ...)
+			   (map (lambda (args)
+				  (cond
+				   [(sym-arglist? args)
+				    (datum->syntax-object #f (binding-var (car (arglist-vars args))) #f)]
+				   [(list-arglist? args)
+				    (map (lambda (var)
+					   (datum->syntax-object #f (binding-var var) #f))
+					 (arglist-vars args))]
+				   [(ilist-arglist? args)
+				    (let loop ([vars (arglist-vars args)])
+				      (let ([id (datum->syntax-object #f (binding-var (car vars)) #f)])
+					(if (null? (cdr vars))
+					    id
+					    (cons id (loop (cdr vars))))))]))
+				(case-lambda-form-args x))]
+			  [(body ...)
+			   (map loop (case-lambda-form-bodies x))])
+	      (syntax (case-lambda [args body] ...)))]
+
+	   [(with-continuation-mark-form? x)
+	    (with-syntax ([key (loop (with-continuation-mark-form-key x))]
+			  [val (loop (with-continuation-mark-form-val x))]
+			  [body (loop (with-continuation-mark-form-body x))])
+	      (syntax (with-continuation-mark key val body)))]
+
+	   [else (error 'zodiac->syntax
+			"unknown zodiac record type: ~e"
+			x)])))
+
+      (define (zodiac-origin z) z)
+
+      (define (origin-who z)
+	(if (syntax-original? (zodiac-stx z))
+	    'source
+	    'macro))
+
+      (define (origin-how z)
+	(syntax-property (zodiac-stx z) 'origin))
+      
+      (define (zodiac-start z) z)
+      (define (zodiac-finish z) z)
+
+      (define (location-line z)
+	(and (zodiac-stx z) (syntax-line (zodiac-stx z))))
+      
+      (define (location-column z)
+	(and (zodiac-stx z) (syntax-column (zodiac-stx z))))
+
+      (define (location-file z)
+	(and (zodiac-stx z) (syntax-source (zodiac-stx z))))
+
+      (define (zread-object z)
+	(syntax-e (zodiac-stx z)))
+
+      (define (structurize-syntax sexp)
+	(make-zread (datum->syntax-object #f sexp #f)))
+
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+      (define eof? eof-object?)
+
+      (define-struct zodiac (stx))
+      (define-struct (zread zodiac) ())
+
+      (define-struct (parsed zodiac) (back))
+
+      (define-struct (varref parsed) (var))
+
+      (define-struct (top-level-varref varref) (module slot exptime? expdef? position))
+      (define (create-top-level-varref z var module slot exptime? expdef? position)
+	(make-top-level-varref (zodiac-stx z) (mk-back) var module slot exptime? expdef? position))
+
+      (define-struct (bound-varref varref) (binding))
+      (define (create-bound-varref z var binding)
+	(make-bound-varref (zodiac-stx z) (mk-back) var binding))
+
+      (define lexical-varref? bound-varref?)
+      (define make-lexical-varref make-bound-varref)
+      (define create-lexical-varref create-bound-varref)
+
+      (define-struct (binding parsed) (var orig-name))
+      (define (create-binding z var orig-name)
+	(make-binding (zodiac-stx z) (mk-back) var orig-name))
+
+      (define lexical-binding? binding?)
+      (define make-lexical-binding make-binding)
+      (define create-lexical-binding create-binding)
+
+
+      (define-struct (app parsed) (fun args))
+      (define (create-app z fun args)
+	(make-app (zodiac-stx z) (mk-back) fun args))
+
+      (define-struct (if-form parsed) (test then else))
+      (define (create-if-form z test then else)
+	(make-if-form (zodiac-stx z) (mk-back) test then else))
+
+      (define-struct (quote-form parsed) (expr))
+      (define (create-quote-form z expr)
+	(make-quote-form (zodiac-stx z) (mk-back) expr))
+
+      (define-struct (begin-form parsed) (bodies))
+      (define (create-begin-form z bodies)
+	(make-begin-form (zodiac-stx z) (mk-back) bodies))
+
+      (define-struct (begin0-form parsed) (bodies))
+      (define (create-begin0-form z bodies)
+	(make-begin0-form (zodiac-stx z) (mk-back) bodies))
+
+      (define-struct (let-values-form parsed) (vars vals body))
+      (define (create-let-values-form z vars vals body)
+	(make-let-values-form (zodiac-stx z) (mk-back) vars vals body))
+
+      (define-struct (letrec-values-form parsed) (vars vals body))
+      (define (create-letrec-values-form z vars vals body)
+	(make-letrec-values-form (zodiac-stx z) (mk-back) vars vals body))
+
+      (define-struct (define-values-form parsed) (vars val))
+      (define (create-define-values-form z vars val)
+	(make-define-values-form (zodiac-stx z) (mk-back) vars val))
+
+      (define-struct (set!-form parsed) (var val))
+      (define (create-set!-form z var val)
+	(make-set!-form (zodiac-stx z) (mk-back) var val))
+
+      (define-struct (case-lambda-form parsed) (args bodies))
+      (define (create-case-lambda-form z args bodies)
+	(make-case-lambda-form (zodiac-stx z) (mk-back) args bodies))
+
+      (define-struct (with-continuation-mark-form parsed) (key val body))
+      (define (create-with-continuation-mark-form z key val body)
+	(make-with-continuation-mark-form (zodiac-stx z) (mk-back) key val body))
+
+      (define-struct (quote-syntax-form parsed) (expr))
+      (define (create-quote-syntax-form z expr)
+	(make-quote-syntax-form (zodiac-stx z) (mk-back) expr))
+
+      (define-struct (define-syntaxes-form parsed) (names expr))
+      (define (create-define-syntaxes-form z names expr)
+	(make-define-syntaxes-form (zodiac-stx z) (mk-back) names expr))
+
+      (define-struct (define-for-syntax-form parsed) (names expr))
+      (define (create-define-for-syntax-form z names expr)
+	(make-define-for-syntax-form (zodiac-stx z) (mk-back) names expr))
+
+      (define-struct (module-form parsed) (name requires for-syntax-requires for-template-requires 
+						body syntax-body 
+						provides syntax-provides indirect-provides
+						kernel-reprovide-hint
+						self-path-index))
+      (define (create-module-form z name rt-requires et-requires tt-requires
+				  rt-body et-body
+				  var-provides syntax-provides indirect-provides
+				  kernel-hint self)
+	(make-module-form (zodiac-stx z) (mk-back) 
+			  name rt-requires et-requires tt-requires 
+			  rt-body et-body
+			  var-provides syntax-provides indirect-provides
+			  kernel-hint self))
+
+      (define-struct (require/provide-form parsed) ())
+      (define (create-require/provide-form z)
+	(make-require/provide-form (zodiac-stx z) (mk-back)))
+
+      (define-struct arglist (vars))
+      (define-struct (sym-arglist arglist) ())
+      (define-struct (list-arglist arglist) ())
+      (define-struct (ilist-arglist arglist) ()))))
diff --git a/collects/syntax/zodiac.ss b/collects/syntax/zodiac.ss
new file mode 100644
index 0000000000..f08f4ee3f1
--- /dev/null
+++ b/collects/syntax/zodiac.ss
@@ -0,0 +1,11 @@
+
+(module zodiac mzscheme
+  (require (lib "unitsig.ss"))
+
+  (require "zodiac-sig.ss")
+  (require "zodiac-unit.ss")
+
+  (define-values/invoke-unit/sig zodiac^
+    zodiac@)
+
+  (provide-signature-elements zodiac^))
diff --git a/collects/test-suite/extension.ss b/collects/test-suite/extension.ss
new file mode 100644
index 0000000000..03053b69ea
--- /dev/null
+++ b/collects/test-suite/extension.ss
@@ -0,0 +1,14 @@
+
+(module extension mzscheme
+  (provide add-test-suite-extension
+	   test-suite-extensions)
+
+  (define (add-test-suite-extension button icon callback)
+    (test-suite-extensions (append
+			    (test-suite-extensions)
+			    (list (list button icon callback)))))
+
+  (define test-suite-extensions (make-parameter null)))
+
+
+     
\ No newline at end of file
diff --git a/collects/test-suite/info.ss b/collects/test-suite/info.ss
new file mode 100644
index 0000000000..5eee46188f
--- /dev/null
+++ b/collects/test-suite/info.ss
@@ -0,0 +1,5 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Test Suite")
+  (define tools '(("tool.ss")))
+  (define tool-names (list "The Test Suite Tool"))
+  (define tool-icons (list '("question-mark.png" "test-suite" "private" "icons"))))
diff --git a/collects/test-suite/private/convert-to-string.ss b/collects/test-suite/private/convert-to-string.ss
new file mode 100644
index 0000000000..4350d05553
--- /dev/null
+++ b/collects/test-suite/private/convert-to-string.ss
@@ -0,0 +1,38 @@
+#| This module provides a mixin that gives a snip a method called convert-to-string.
+   This method finds the editor that contains the snip and if it's a text it replaces
+   the snip with a string in that editor.
+|#
+
+(module convert-to-string mzscheme
+  
+  (require
+   (lib "class.ss")
+   (lib "mred.ss" "mred")
+   (lib "framework.ss" "framework")
+   (lib "embedded-gui.ss" "embedded-gui")
+   (lib "contract.ss"))
+  
+  (provide/contract
+   (convert-to-string-mixin mixin-contract)
+   (convert-to-string<%> interface?))
+  
+   (define convert-to-string<%>
+     (interface ()
+       convert-to-string))
+   
+   (define convert-to-string-mixin
+     (mixin ((class->interface snip%)) (convert-to-string<%>)
+       (inherit get-admin get-text)
+       
+       (define/public (convert-to-string str)
+         (let ([to-ed (snip-parent this)])
+           (when (is-a? to-ed text%)
+             (let ([this-pos (send to-ed get-snip-position this)])
+               (when this-pos
+                 (send to-ed begin-edit-sequence)
+                 (send to-ed delete this-pos (add1 this-pos))
+                 (send to-ed insert (string-length str) str this-pos)
+                 (send to-ed end-edit-sequence))))))
+       
+       (super-new)))
+  )
diff --git a/collects/test-suite/private/doc/ChangeLog b/collects/test-suite/private/doc/ChangeLog
new file mode 100644
index 0000000000..d3602c19e6
--- /dev/null
+++ b/collects/test-suite/private/doc/ChangeLog
@@ -0,0 +1,38 @@
+2003/12/18
+  * Fixed the bug where fixed width lables didn't fit in their extents.
+  * Made the test-box take the caret when inserted.
+  * Made error reporting for out of context test-cases highlight the box.
+  * Made tabbing work.
+
+2003/12/16
+  * Made the aligned-pasteboards work
+
+2003/11/17
+  * Made event handling of the pasteboards work differently
+
+2003/11/13
+  * Added tabbing.
+  * Corrected the handling of multiple values in test case boxes.
+  * Made the empty test case error hightlight the full test case. It'd be
+    better to have it highlight just the part of the test case that is empty
+    but this is not possible with the current error highlighting system.
+
+2003/10/??
+  * Changed the test-suite tool to make test-case-boxes.
+
+2003/04/23
+  * Added code highlighting to the "Too many expressions in a test box
+    error message
+
+2003/04/16
+  * Added a ChangeLog
+  * Added a seperator to the language menu
+  * Removed model and window directories from private
+  * Added an open button which opens the program being tested in drscheme. If
+    the file is already open in a drscheme window, it uses the existing one.
+  * Fixed tabbing so that snips that are off screen are scrolled to when
+    they are tabbed to.
+  * Made the save button appear when the program to test box gets modified.
+  * Made the save button not appear when the test-suite is just loaded.
+  * Documented aligned-snip-mixin and click-forwarding-mixin in the doc.txt
+    of the mrlib collection.
diff --git a/collects/test-suite/private/doc/TODO b/collects/test-suite/private/doc/TODO
new file mode 100644
index 0000000000..5c1421c952
--- /dev/null
+++ b/collects/test-suite/private/doc/TODO
@@ -0,0 +1,59 @@
+;;;;;;;;;;
+;; Todo ;;
+;;;;;;;;;;
+
+multiview:
+It'd be cool to allow multiple views of the test suite
+
+errorboxes: future
+Need to have boxes that handle errors.
+
+output:
+need to handle output (side effect) of test calls. Maybe not.
+
+stepper: future
+allow easy addition of break points and stepping of the testcases.
+
+language-pref: future
+Make a language level preference to execute or not execute the test cases.
+Maybe just do it in debug mode? Actually, probablly just have a preference
+to remember wether or not they have enabled or disabled test cases by
+default.
+
+disable: future
+add a button to disable a test case.
+
+error-no-stop:
+when a test cases raises exception don't stop at all even it is not expected
+just make it fail or even flag it as raising an error. This could be a
+preference really.
+
+project:
+want to be able to run a lot of test-suites from the command line. Also sould
+have a digest of number of tests failed or succeed at the end of a run.
+
+scheme-unit:
+integrate with scheme unit
+
+;;;;;;;;;;
+;; Bugs ;;
+;;;;;;;;;;
+
+namespace: robby
+Adding the test-case macro to the top-level require makes test-cases in
+modules not see the macro and fail to execute. Test-cases don't work in
+beginner level because require makes no sence.
+
+mouse-cursor: important
+If you mouse down on a text box and mouse up in another, the cursor
+appears in the second text box.
+
+mouse-off: important, robby
+If you mouse down on a button snip and move the mouse off, the button
+stays depressed.
+
+This may be the same as what you describe below, but when I type this:
+(let loop () (loop)) into a test case window and then type more close
+parens after that, things vibrate in a strange way.
+
+test-suite entry boxes are not locked when the program is executing
diff --git a/collects/test-suite/private/doc/old-todo b/collects/test-suite/private/doc/old-todo
new file mode 100644
index 0000000000..99cc2dc573
--- /dev/null
+++ b/collects/test-suite/private/doc/old-todo
@@ -0,0 +1,160 @@
+######################################################################
+                       Immediate TODO list:
+######################################################################
+  To highlight test-cases that are currently selected, use the same method
+as in test-text. Only color the snip though, not the editor. This will
+fill in the places in the snip that don't have children snips on it.
+--------------
+  To enable and disable the delete snip button use the on-focus or on
+not-focus of the test-cases. do something clever to avoid the blinking of
+the delete button between off-focus and on-focus.
+--------------
+make GUI-monkey test-suite for test-suite
+--------------
+make a better test-suite window using editor-mixin
+  and derive a controller from it, not the way I
+  am currently doing it. (this will give undo/redo)
+--------------
+figure out the problem with resized overloading
+  and a clean way to fix it.
+--------------
+override on-default-event of the pasteboard if it's not needed
+so that all the funny selection and movement doesn't happen.
+-------------------
+On Mon, Nov 18, 2002 at 03:03:49PM -0600, Robert Bruce Findler wrote:
+> Make deletion actually set the focus to another one of the snips, so I
+> can keep deleting.
+-------------------
+> Also, it may look better to remove the outer box entirely and just have
+> lines between the test case items (or even not, if you can figure out
+> the background colors)
+-------------------
+ * There's a problem with handling mouse-button releases. They seem to
+   be handled like clicks. For example, drag a selection in "Expected",
+   but release the mouse in "Call". The selection will move to "Call".
+
+Matthew
+-------------------
+   - after xcuting and receiving checks for all tests, edit an expected value
+     and see whether you get a save button
+------------------
+
+######################################################################
+                          Nonimmediate TODO:
+######################################################################
+disable the open button when there is no program to test in the text box
+-------------------
+make undo/redo work
+-------------------
+have the 'special' menu in the test-suite tool so that
+  one might add xml boxes to test-suites for instance.
+-------------------
+Disable the open button when there is nothing in the program to test box
+-------------------
+Refactor languaged frame unit so that it does not depend on the model but
+instread stores the language and teachpacks in it's own fields and may be
+used by DrScheme as a general mixin to add language support to windows.
+-------------------
+add support for the test definitions boxes.
+-------------------
+One thing I noticed about your tester: it doesn't seem to use Robby's
+string-constants system.  So all the menus and buttons and stuff you
+have will always be in English, which will look weird to people who
+use DrScheme with another language.
+
+Philippe
+-------------------
+Give better error message on bad file loading.(message box?)
+disallow newlines in program to file box
+-------------------
+It'd also be really nice to have a Stepper associated with individual
+test cases -- this is currently a pain with the stepper (I have to
+step through old runs to get to new ones, or putz around with
+commenting code).  With the testing facility you have just the right
+interface to make the stepper highly usable!
+----------------
+Programs aren't associated with the buffer that is open (like the REPL) They
+are associated with the saved file. This is confusing when you change a
+program and expect it's test to behave differently in the test window.
+Currently you must save it. Should there either be an "out of syn" warning
+or a way to read straight from the buffer?
+-----------------
+I think that there is too much whitespace around the boxes, too. It'd           
+be nicer to use color to separate the lines and get back some screen
+"real estate".                                 
+                                          
+Robby                                             
+-----------------
+make the test-suite not halt on a failure?
+-----------------
+   - we need to be able to associate a test suite with more than one
+     definitions window (say we reimplement a module to improve its
+     performance. it should pass the same functionality tests)
+------------------
+Pls add a checkbox so that you can turn off individual tests
+or skip tests that fail. -- Matthias
+------------------
+
+######################################################################
+                              Unknown:
+######################################################################
+I've done a first cut of io in the test suite. It doesn't do everything
+-- here are some TODOs for you:
+
+  - hide last newline (like in value printer)
+  - remove IO boxes when executing
+  - fix the `(lambda () (send this ...)' hack
+
+The last one needs some re-organization, I believe. I'll let you think
+about it.
+
+Also, I noticed that execute doesn't shutdown the old custodian, so
+frames and things created in previous tests are still around in the new
+test. (This also means that there is a memory leak!)
+
+That's already on your list, right?
+
+Robby
+-----------------
+For your TODO list, please. :)
+  
+It would be nice if there was a little turn down triangle in the test
+cases that would collapse the entire case to just the triangle. If
+adjacent test cases were collapsed, they would sit next to each other
+horizontally (ie, leave more vertical room). When executing, if the
+test case passes and it was closed, it stays closed, but if it fails
+and it was closed, it pops open.
+  
+What do you think?
+-----------------
+When I create a new case, the tester installs a huge big question
+mark.  It's cute [so are the cross and check -- these will probably be
+a big hit with kids -- whoever designed them did a great job!], but
+(a) I think they're too large; and (b) I think the ? is misleading.
+Something about ?'s shape, size and location makes me think it must be
+a button.  (Location, especially -- it's exactly where I would expect
+the "Submit" button on a Web form.) I clicked on it a few times, but
+nothing happened.  Then I remembered that there'd been an Execute
+button at the top, clicked on it, and saw the outcome.  In other
+words, I expected ? to play the role of Execute.
+-sk
+-------------------
+The box under Actual surprised me multiple times.  After entering a
+value for Call and for Expected, I was surprised to find tabbing and
+typing do nothing.  The color change just tells me "this is special"
+(eg, where you enter your SSN on a govt form); the box still tells me
+"this is a place you enter text".  Can you remove the box entirely
+from below Actual?  In fact, if Actual and the output never appeared
+until you executed the program, that may be even better.
+-sk
+----------------
+BUG: I wanted to make the second test case buggy (but not lose the
+subsequent ones).  So I clicked on the box around the first one, which
+showed me little highlight points around the box.  I tried to move it,
+but nothing happened.  Then I went to the scroll bar and tried to
+scroll somewhere in that region, but got a MrEd toolbox method error,
+and now the screen won't redraw.  I'll try to reproduce it. ... Okay,
+did so successfully, I'll send in a bug report.  Anyway, it'd be nice
+to reorder cases.  It'd be especially neat the reorder by
+success/failure.
+-------------------
diff --git a/collects/test-suite/private/find-scheme-menu.ss b/collects/test-suite/private/find-scheme-menu.ss
new file mode 100644
index 0000000000..68b4626de6
--- /dev/null
+++ b/collects/test-suite/private/find-scheme-menu.ss
@@ -0,0 +1,38 @@
+;; This code is duplicated from the servelt-builder.ss file
+(module find-scheme-menu mzscheme
+  
+  (provide find-scheme-menu)
+  
+  (require
+   (lib "class.ss")
+   (lib "mred.ss" "mred")
+   (lib "string-constant.ss" "string-constants"))
+  
+  ; : menu% -> (U menu% #f)
+  ; to crawl up and down the menu hierarcy to find the scheme menu
+  ; This attempts to work even if
+  ; a) the menus and menu items are in a different langauge
+  ; b) the menus are in Philippe's language where they are all blank (and hence the same)
+  ; It starts by selecting the menu by position to avoid problem b).
+  ; Just to be paranoid, it looks in other positions, too.
+  ; The scheme menu must have "Create Executable..." in some language as a menu item.
+  (define (find-scheme-menu special-menu)
+    (let* ([bar (send special-menu get-parent)]
+           [menus (send bar get-items)]
+           [ordered-menus (if (< (length menus) 5)
+                              menus
+                              (cons (car (cddddr menus)) menus))])
+      (ormap (lambda (m)
+               (and (string=? (label->plain-label (string-constant scheme-menu-name))
+                              (send m get-plain-label))
+                    (ormap is-create-executable-item? (send m get-items))
+                    m))
+             ordered-menus)))
+  
+  
+  ; menu-item% -> bool
+  (define (is-create-executable-item? item)
+    (and (is-a? item labelled-menu-item<%>)
+         (string=? (string-constant create-executable-menu-item-label)
+                   (send item get-label))))
+  )
\ No newline at end of file
diff --git a/collects/test-suite/private/icons/check-mark.jpeg b/collects/test-suite/private/icons/check-mark.jpeg
new file mode 100644
index 0000000000..83ff6b8464
Binary files /dev/null and b/collects/test-suite/private/icons/check-mark.jpeg differ
diff --git a/collects/test-suite/private/icons/checkbox_enabled_checked.gif b/collects/test-suite/private/icons/checkbox_enabled_checked.gif
new file mode 100644
index 0000000000..bf895b074e
Binary files /dev/null and b/collects/test-suite/private/icons/checkbox_enabled_checked.gif differ
diff --git a/collects/test-suite/private/icons/checkbox_enabled_notchecked.gif b/collects/test-suite/private/icons/checkbox_enabled_notchecked.gif
new file mode 100644
index 0000000000..25870c8462
Binary files /dev/null and b/collects/test-suite/private/icons/checkbox_enabled_notchecked.gif differ
diff --git a/collects/test-suite/private/icons/cross.jpeg b/collects/test-suite/private/icons/cross.jpeg
new file mode 100644
index 0000000000..1124b610f0
Binary files /dev/null and b/collects/test-suite/private/icons/cross.jpeg differ
diff --git a/collects/test-suite/private/icons/empty.jpeg b/collects/test-suite/private/icons/empty.jpeg
new file mode 100644
index 0000000000..5c8047faa9
Binary files /dev/null and b/collects/test-suite/private/icons/empty.jpeg differ
diff --git a/collects/test-suite/private/icons/question-mark.jpeg b/collects/test-suite/private/icons/question-mark.jpeg
new file mode 100644
index 0000000000..4edab4cdac
Binary files /dev/null and b/collects/test-suite/private/icons/question-mark.jpeg differ
diff --git a/collects/test-suite/private/icons/question-mark.png b/collects/test-suite/private/icons/question-mark.png
new file mode 100644
index 0000000000..c08c9d88d3
Binary files /dev/null and b/collects/test-suite/private/icons/question-mark.png differ
diff --git a/collects/test-suite/private/icons/small-check-mark.jpeg b/collects/test-suite/private/icons/small-check-mark.jpeg
new file mode 100644
index 0000000000..cc2e570c73
Binary files /dev/null and b/collects/test-suite/private/icons/small-check-mark.jpeg differ
diff --git a/collects/test-suite/private/icons/small-cross.jpeg b/collects/test-suite/private/icons/small-cross.jpeg
new file mode 100644
index 0000000000..20c729dc22
Binary files /dev/null and b/collects/test-suite/private/icons/small-cross.jpeg differ
diff --git a/collects/test-suite/private/icons/small-empty.gif b/collects/test-suite/private/icons/small-empty.gif
new file mode 100644
index 0000000000..97c9e1f607
Binary files /dev/null and b/collects/test-suite/private/icons/small-empty.gif differ
diff --git a/collects/test-suite/private/icons/small-no.gif b/collects/test-suite/private/icons/small-no.gif
new file mode 100644
index 0000000000..204cbf8a30
Binary files /dev/null and b/collects/test-suite/private/icons/small-no.gif differ
diff --git a/collects/test-suite/private/info.ss b/collects/test-suite/private/info.ss
new file mode 100644
index 0000000000..6e9ce8f1ba
--- /dev/null
+++ b/collects/test-suite/private/info.ss
@@ -0,0 +1,2 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Test Suite private"))
diff --git a/collects/test-suite/private/make-snipclass.ss b/collects/test-suite/private/make-snipclass.ss
new file mode 100644
index 0000000000..1b81372140
--- /dev/null
+++ b/collects/test-suite/private/make-snipclass.ss
@@ -0,0 +1,36 @@
+(module make-snipclass mzscheme
+  
+  (require
+   (lib "etc.ss")
+   (lib "mred.ss" "mred")
+   (lib "class.ss")
+   (lib "contract.ss"))
+  
+  (define read-proc? (class? (is-a?/c editor-stream-in%) . -> . object?))
+  
+  (provide/contract
+   (make-snipclass ((class? string?) (read-proc?) . opt-> . (is-a?/c snip-class%)))
+   (send-read-from-file read-proc?))
+  
+  ;; Creats a snipclass and registers it with the snip class list
+  (define make-snipclass
+    (opt-lambda (class% classname (read-proc send-read-from-file))
+      (let* ([abstract-snip-class%
+              (class snip-class%
+                #;((is-a?/c editor-stream-in%) . -> . (is-a?/c interactions-box%))
+                ;; Produces an interaction box from the given file stream
+                (define/override (read f)
+                  (read-proc class% f))
+                (super-new))]
+             [sc (new abstract-snip-class%)])
+        (send sc set-classname classname)
+        (send sc set-version 2)
+        (send (get-the-snip-class-list) add sc)
+        sc)))
+  
+  ;; Returns an object of class after reading its contents from the given stream
+  (define (send-read-from-file class% f)
+    (let ([object (new class%)])
+      (send object read-from-file f)
+      object))
+  )
\ No newline at end of file
diff --git a/collects/test-suite/private/print-to-text.ss b/collects/test-suite/private/print-to-text.ss
new file mode 100644
index 0000000000..5a4f2f7f45
--- /dev/null
+++ b/collects/test-suite/private/print-to-text.ss
@@ -0,0 +1,62 @@
+(module print-to-text mzscheme
+  
+  (require
+   (lib "list.ss")
+   (lib "etc.ss")
+   (lib "class.ss")
+   (lib "contract.ss")
+   (lib "unitsig.ss")
+   (lib "mred.ss" "mred")
+   (lib "framework.ss" "framework")
+   (lib "tool.ss" "drscheme"))
+  
+  (provide print-to-text^
+	   print-to-text@)
+
+  (define-signature print-to-text^
+    (print-to-text))
+
+  (define print-to-text@
+    (unit/sig print-to-text^
+      (import drscheme:tool^)
+
+      ;; Using the current languages print operations, print the list of values to the text
+      (define (print-to-text atext vals)
+	(unless (empty? vals)
+	  (send* atext
+		 (begin-edit-sequence)
+		 (erase))
+	  (let ([port
+		 (make-output-port
+		  'set-actuals
+		  always-evt
+		  (lambda (s start end block? enable-breaks?)
+		    (send atext insert
+			  (list->string
+			   (map integer->char
+				(bytes->list (subbytes s start end)))))
+		    (- end start))
+		  void
+		  (lambda (v block? enable-breaks?)
+		    (if (v . is-a? . snip%)
+			(send atext insert v)
+			(send atext insert (format "~s" v)))
+		    #t))])
+	    (define (print-one v)
+	      (let* ([language-settings
+		      (preferences:get
+		       (drscheme:language-configuration:get-settings-preferences-symbol))]
+		     [language
+		      (drscheme:language-configuration:language-settings-language
+		       language-settings)]
+		     [settings
+		      (drscheme:language-configuration:language-settings-settings
+		       language-settings)])
+		(send language render-value v settings port)))
+	    (print-one (first vals))
+	    (for-each
+	     (lambda (val)
+	       (newline port)
+	       (print-one val))
+	     (rest vals)))
+	  (send atext end-edit-sequence))))))
diff --git a/collects/test-suite/private/test-case-box.ss b/collects/test-suite/private/test-case-box.ss
new file mode 100644
index 0000000000..9a765f6387
--- /dev/null
+++ b/collects/test-suite/private/test-case-box.ss
@@ -0,0 +1,586 @@
+#| Note: Test cases have a lot of state like the to-test, predicate, etc. I need to find a way
+   to not have to maintain this list of state in many places. It's not as simple as a global
+   list, however, because they need to be instantiation variables, etc.
+|#
+(module test-case-box mzscheme
+  
+  (provide test-case-box^ test-case-box@)
+  
+  (require
+   (lib "class.ss")
+   (lib "list.ss")
+   (lib "mred.ss" "mred")
+   (lib "unitsig.ss")
+   (lib "tool.ss" "drscheme")
+   (lib "etc.ss")
+   (lib "match.ss")
+   (lib "framework.ss" "framework")
+   (lib "readerr.ss" "syntax")
+   (lib "string-constant.ss" "string-constants")
+   (lib "embedded-gui.ss" "embedded-gui")
+   (lib "string-constant.ss" "string-constants")
+   "make-snipclass.ss"
+   "convert-to-string.ss"
+   "text-syntax-object.ss"
+   "print-to-text.ss"
+   "test-case.ss"
+   (rename (lib  "teachprims.ss" "lang" "private") beginner-equal? beginner-equal?))
+  
+  (define-signature test-case-box^ (test-case-box% phase1 phase2))
+  (define test-case-box@
+    (unit/sig test-case-box^
+      (import drscheme:tool^ text->syntax-object^ print-to-text^)
+      
+      (define test-case:program-editor% false)
+      
+      (define (phase1) (void))
+      (define (phase2)
+        (set! test-case:program-editor%
+              (init-text-mixin
+               (tabbable-text-mixin
+                ((drscheme:unit:get-program-editor-mixin)
+                 scheme:text%)))))
+      
+      ;; The test case box that is inserted into the drscheme frame
+      (define test-case-box%
+         (class* (on-show-editor-snip-mixin
+                  (convert-to-string-mixin
+                   (decorated-editor-snip-mixin editor-snip%))) (readable-snip<%>)
+           (inherit get-admin convert-to-string)
+           
+           ;; A text that will uncollapse the test case when it is highlighted for an error
+           (define error-alert-text%
+             (class test-case:program-editor%
+               (define/override highlight-range
+                 (opt-lambda (start end color (bitmap false) (caret-space false) (priority 'low))
+                   (when collapsed? (collapse false))
+                   (super highlight-range start end color bitmap caret-space priority)))
+               (super-new)))
+           
+           (init-field
+            [enabled? true]
+            [actual-show? false]
+            [collapsed? false]
+            [show-right-pane? false]
+            [error-box? false]
+            [to-test (new error-alert-text%)]
+            [expected (new error-alert-text%)]
+            [predicate (new error-alert-text% (text ""))]
+            [should-raise (new error-alert-text% (text ""))]
+            [error-message (new error-alert-text%)])
+           
+           #;(any? (union integer? false?) (union integer? false?) (union integer? false?) . -> . any?)
+           ;; Called by the execution to get a syntax object that represents this box.
+           (define/public read-special
+             (opt-lambda (source (line false) (column false) (position false))
+               #;((is-a?/c text%) . -> . syntax-object?)
+               ;; Creates a single syntax object out of the text or raises read-error
+               (define (text->syntax-object text default-content)
+                 (match (text->syntax-objects text default-content)
+                   [() (raise-read-error (string-constant test-case-empty-error)
+                                         source line false position 1)]
+                   [(stx) stx]
+                   [(stx next rest-stx ...)
+                    (raise-read-error (string-constant test-case-too-many-expressions-error)
+                                      text
+                                      (syntax-line next)
+                                      (syntax-column next)
+                                      (syntax-position next)
+                                      (syntax-span next))]))
+
+               (if enabled?
+                     (with-syntax ([to-test-stx (syntax-property (text->syntax-object to-test #f)
+                                                                 'stepper-test-suite-hint
+                                                                 true)]
+                                   [update-stx (lambda (x) (update x))] ; eta public method
+                                   [set-actuals-stx set-actuals]
+                                   [w printf])
+                       (if error-box?
+                           (with-syntax ([exn-pred-stx (text->syntax-object should-raise #'exn:fail?)]
+                                         [exn-handler-stx
+                                          (if (empty-text? error-message)
+                                              #'(lambda (v) true)
+                                              #`(lambda (v)
+                                                  (equal? (exn-message v)
+                                                          #,(text->syntax-object
+                                                             error-message
+							     #f))))])
+                             (syntax/loc (datum->syntax-object
+                                          false 'ignored (list source line column position 1))
+                               (test-error-case to-test-stx
+                                                exn-pred-stx
+                                                exn-handler-stx
+                                                update-stx
+                                                set-actuals-stx)))
+                           (with-syntax ([exp-stx (text->syntax-object expected #f)]
+                                         [pred-stx (text->syntax-object predicate beginner-equal?)])
+                             (syntax/loc (datum->syntax-object
+                                          false 'ignored (list source line column position 1))
+                               (test-case pred-stx
+                                          to-test-stx
+                                          exp-stx
+                                          update-stx
+                                          set-actuals-stx)))))
+                   (syntax-property #'(define-values () (values))
+                                    'stepper-skip-completely
+                                    true))))
+           
+           #;(boolean? . -> . void?)
+           ;; sets the test case to the proper result bassed on if it was correct
+           (define/public (update pass?)
+             (send result update (if pass? 'pass 'fail)))
+           
+           #;(-> void?)
+           ;; resets the state of the test case
+           (define/public (reset)
+             (send pb lock-alignment true)
+             (send* actual
+               (lock false)
+               (erase)
+               (lock true))
+             (when enabled?
+               (send result update 'unknown))
+             (send pb lock-alignment false))
+           
+           #;(boolean? . -> . void?)
+           ;; enables or disables the test case
+           (define/public (enable enable?)
+             (unless (boolean=? enabled? enable?)
+               (if enable?
+                   (begin (set! enabled? true)
+                          (send result update 'unknown))
+                   (begin (set! enabled? false)
+                          (reset)
+                          (send result update 'disabled)))))
+           
+           #;(-> void)
+           ;; tells the test-box to take the caret
+           (define/public (take-caret)
+             (send pb set-caret-owner
+                   (send (send to-test get-admin) get-snip)
+                   'display))
+           
+           #;(-> string)
+           ;; The textual representation of this test-case
+           ;; STATUS: Begginner language doesn't have with-handlers
+           ;; STATUS: Pretty printing not here yet.
+           (define (get-string)
+             (if error-box?
+                 "Not yet implemented. What to do in beginner?"
+                 (format "(~a ~a ~a)"
+                         (send predicate get-text)
+                         (send to-test get-text)
+                         (send expected get-text))))
+           
+           #;((is-a?/c expand-program%) (listof any?) . -> . void?)
+           ;; set the text in the actual field to the value given
+           ;; STATUS: Ensure the edit-sequence is needed.
+           (define (set-actuals vals)
+             (send (send (get-admin) get-editor) begin-edit-sequence)
+             (send actual lock false)
+             (print-to-text actual vals)
+             (send actual lock true)
+             (send (send (get-admin) get-editor) end-edit-sequence))
+           
+           ;;;;;;;;;;
+           ;; Saving and Copying
+           
+           #;(-> (is-a?/c test-case-box%))
+           ;; Called by drscheme to copy and paste this test-case
+           (define/override (copy)
+             (let ([new-to-test (new error-alert-text%)]
+                   [new-expected (new error-alert-text%)]
+                   [new-predicate (new error-alert-text%)]
+                   [new-should-raise (new error-alert-text%)]
+                   [new-error-message (new error-alert-text%)])
+               (send to-test copy-self-to new-to-test)
+               (send expected copy-self-to new-expected)
+               (send predicate copy-self-to new-predicate)
+               (send should-raise copy-self-to new-should-raise)
+               (send error-message copy-self-to new-error-message)
+               (new test-case-box%
+                    (enabled? enabled?)
+                    (actual-show? actual-show?)
+                    (collapsed? collapsed?)
+                    (show-right-pane? show-right-pane?)
+                    (error-box? error-box?)
+                    (to-test new-to-test)
+                    (expected new-expected)
+                    (predicate predicate)
+                    (should-raise should-raise)
+                    (error-message error-message))))
+           
+           #;((is-a?/c editor-stream-out%) . -> . void?)
+           ;; Writes this test case box to the given file.
+           (define/override (write f)
+             (send to-test write-to-file f)
+             (send expected write-to-file f)
+             (send predicate write-to-file f)
+             (send should-raise write-to-file f)
+             (send error-message write-to-file f)
+             (send f put (if enabled? 1 0))
+             (send f put (if collapsed? 1 0))
+             (send f put (if error-box? 1 0)))
+           
+           
+           #;((is-a?/c editor-stream-in%) . -> . void?)
+           ;; Reads the state of the box in from the given stream
+           (define/public (read-from-file f)
+             (let ([enabled?-box (box 0)]
+                   [collapsed?-box (box 0)]
+                   [error-box?-box (box 0)])
+	       (let ([vers (send tcb-sc reading-version f)])
+		 (case vers
+		   [(1)
+		    ;; Discard comment:
+		    (send (new text%) read-from-file f)
+		    (send* to-test (erase) (read-from-file f))
+		    (send* expected (erase) (read-from-file f))
+		    ;; Nothing else is in the stream in version 1,
+		    ;;  so leave the defaults
+		    ]
+		   [(2)
+		    (send* to-test (erase) (read-from-file f))
+		    (send* expected (erase) (read-from-file f))
+		    (send* predicate (erase) (read-from-file f))
+		    (send* should-raise (erase) (read-from-file f))
+		    (send* error-message (erase) (read-from-file f))
+		    (send f get enabled?-box)
+		    (send f get collapsed?-box)
+		    (send f get error-box?-box)
+		    (enable (= (unbox enabled?-box) 1))
+		    ;; Presently this is poking a bug in the embedded-gui.
+		    ;; I'll leaving it commented til I reduce the bug.
+		    #;(collapse (= (unbox collapsed?-box) 1))
+		    (toggle-error-box (= (unbox error-box?-box) 1))]))))
+           
+           ;;;;;;;;;;
+           ;; Layout
+           
+           #;(-> (is-a?/c bitmap%))
+           ;; The bitmap to use for the top corner of the box.
+           (define/override (get-corner-bitmap)
+             (if error-box?
+                 (make-object bitmap% (icon "scheme-box.jpg"))
+                 (make-object bitmap% (icon "scheme-box.jpg"))))
+           
+           #;(-> (symbols 'top-right 'top-left 'bottom-left 'bottom-right))
+           ;; The location of the corner bitmap
+           (define/override (get-position) 'top-right)
+           
+           #;(-> (union string? (is-a?/c color%)))
+           ;; The color of the border of this box
+           (define/override (get-color) (if error-box? "red" "purple"))
+           
+           #;(-> (is-a?/c popup-menu%))
+           ;; The popup menu used for the top corner of this box
+           (define/override (get-menu)
+             (let ([the-menu (new popup-menu% (title (string-constant test-case-menu-title)))])
+               (define (make-toggle label f init)
+                 (letrec ([item (new checkable-menu-item%
+                                     (parent the-menu)
+                                     (label label)
+                                     (checked init)
+                                     (callback (lambda (m e)
+                                                 (f (send item is-checked?)))))])
+                   item))
+               (new menu-item%
+                    (label (if error-box?
+                               (string-constant test-case-switch-to-nonerror-box)
+                               (string-constant test-case-switch-to-error-box)))
+                    (parent the-menu)
+                    (callback (lambda (m e)
+                                (toggle-error-box (not error-box?)))))
+               (make-toggle
+                (string-constant test-case-collapse)
+                collapse collapsed?)
+               (make-toggle
+                (string-constant test-case-show-actual)
+                show-actual actual-show?)
+               (make-toggle
+                (string-constant test-case-enable)
+                (lambda (b) (enable b)) enabled?) ; eta public method
+               (make-toggle
+                (if error-box?
+                    (string-constant test-case-show-error-message)
+                    (string-constant test-case-show-predicate))
+                show-right-pane show-right-pane?)
+               (new menu-item%
+                    (label (string-constant test-case-convert-to-text))
+                    (parent the-menu)
+                    (callback
+                     (lambda (m e)
+                       (convert-to-string (get-string)))))
+               the-menu))
+           
+           #;(-> void)
+           ;; Hide and show the boxes that differ between error and now and
+           ;; poke the snip-parent to display the new boarder color
+           (define (toggle-error-box bool)
+             (set! error-box? bool)
+             (send pb lock-alignment true)
+             (send should-be-pane show (not error-box?))
+             (send should-raise-pane show error-box?)
+             (send predicate-pane show (not error-box?))
+             (send error-message-pane show error-box?)
+             (send pb lock-alignment false)
+             (if error-box?
+                 (set-tabbing to-test should-raise)
+                 (set-tabbing to-test expected))
+             (>>= (snip-parent this)
+                  (lambda (admin)
+                    (send admin resized this true))))
+           
+           #;(boolean? . -> . void)
+           ;; Shows or hides the actual box
+           (define (show-actual show?)
+             (set! actual-show? show?)
+             (send pb lock-alignment true)
+             (send show-actual-button set-state
+                   (boolean->show-actual-btn-state show?))
+             (send to-test-pane stretchable-height show?)
+             (send actual-pane show show?)
+             (send pb lock-alignment false))
+           
+           #;(boolean? . -> . void)
+           ;; Toggles the test-case between a collapsed minimal state and one with entry boxes.
+           (define (collapse bool)
+             (set! collapsed? bool)
+             (send collapse-button set-state
+                   (boolean->collapse-btn-state bool))
+             (send body show (not bool)))
+           
+           #;(booean? . -> . void)
+           ;; Shows or hides the predicate box
+           (define (show-right-pane show?)
+             (set! show-right-pane? show?)
+             (send right-pane show show-right-pane?))
+           
+           ;;;;;;;;;;
+           ;; Box layout
+           
+           (field
+            [pb (new aligned-pasteboard%)]
+            [main (new horizontal-alignment% (parent pb))])
+           
+           ;;;;;;;;;;
+           ;; The button bar w/ result check mark box
+           
+           (field
+            [button-pane (new vertical-alignment% (parent main))]
+            [result (new result-snip% (status (if enabled? 'unknown 'disabled)))])
+           (snip-wrap button-pane result)
+           (field
+            [collapse-button
+             (new turn-button%
+                  (parent button-pane)
+                  (state (boolean->collapse-btn-state collapsed?))
+                  (turn-off (lambda (b e) (collapse true)))
+                  (turn-on (lambda (b e) (collapse false))))]
+            [show-actual-button
+             (new turn-button%
+                  (parent button-pane)
+                  (state (boolean->show-actual-btn-state actual-show?))
+                  (turn-off (lambda (b e) (show-actual false)))
+                  (turn-on (lambda (b e) (show-actual true))))])
+           
+           ;;;;;;;;;;
+           ;; The text boxes
+           
+           (field
+            [body (new horizontal-alignment% (parent main) (show? (not collapsed?)))]
+            [to-test-pane
+             (new labeled-text-field%
+                  (parent body)
+                  (label (string-constant test-case-to-test))
+                  (text to-test))]
+            
+            [result-pane (new vertical-alignment% (parent body))]
+            [should-be-pane
+             (new labeled-text-field%
+                  (parent result-pane)
+                  (show? (not error-box?))
+                  (label (string-constant test-case-expected))
+                  (text expected))]
+            [should-raise-pane
+             (new labeled-text-field%
+                  (parent result-pane)
+                  (show? error-box?)
+                  (label (string-constant test-case-should-raise))
+                  (text should-raise))]
+            [actual (new actual-text%)]
+            [actual-pane
+             (new labeled-text-field%
+                  (parent result-pane)
+                  (label (string-constant test-case-actual))
+                  (show? actual-show?)
+                  (snip-class (grey-editor-snip-mixin stretchable-editor-snip%))
+                  (text actual))]
+            
+            [right-pane (new vertical-alignment% (parent body) (show? show-right-pane?))]
+            [predicate-pane
+             (new labeled-text-field%
+                  (parent right-pane)
+                  (show? (not error-box?))
+                  (label (string-constant test-case-predicate))
+                  (text predicate))]
+            [error-message-pane
+             (new labeled-text-field%
+                  (parent right-pane)
+                  (show? error-box?)
+                  (label (string-constant test-case-error-message))
+                  (text error-message))])
+           
+           (super-new (editor pb))
+           
+           (set-tabbing to-test expected predicate)
+           (set-tabbing should-raise error-message)
+           
+           ;;;;;;;;;;
+           ;; Snip class
+           
+           (inherit set-snipclass)
+           (set-snipclass tcb-sc)))
+        
+      ;;;;;;;;;;
+      ;; Snip class
+      
+      ;; A snip-class for the test case box
+      (define tcb-sc
+        (make-snipclass
+         test-case-box%
+         "test-case-box%"
+         #;
+	 (lambda (class% f)
+           (let ([enabled?-box (box 0)]
+                 [collapsed?-box (box 0)]
+                 [error-box?-box (box 0)]
+                 [to-test (new test-case:program-editor%)]
+                 [expected (new test-case:program-editor%)]
+                 [predicate (new test-case:program-editor%)]
+                 [should-raise (new test-case:program-editor%)]
+                 [error-message (new test-case:program-editor%)])
+             (send to-test read-from-file f)
+             (send expected read-from-file f)
+             (send predicate read-from-file f)
+             (send should-raise read-from-file f)
+             (send error-message read-from-file f)
+             (send f get enabled?-box)
+             (send f get collapsed?-box)
+             (send f get error-box?-box)
+             (new class%
+                  (enabled? (= (unbox enabled?-box) 1))
+                  (collapsed? (= (unbox collapsed?-box) 1))
+                  (error-box? (= (unbox error-box?-box) 1))
+                  (to-test to-test)
+                  (expected expected)
+                  (predicate predicate)
+                  (should-raise should-raise)
+                  (error-message error-message))))))
+      ))
+  
+  #;((-> void?) (-> void?) (symbols 'up 'down) . -> . snip%)
+  ;; a snip which acts as a toggle button for rolling a window up and down
+  ;; STATUS : Change this to derive embedded-toggle-button%
+  (define turn-button%
+    (class embedded-toggle-button%
+      (super-new
+       (images-off (cons (icon "turn-down.png") (icon "turn-down-click.png")))
+       (images-on (cons (icon "turn-up.png") (icon "turn-up-click.png"))))))
+  
+  ;; a snip which will display a pass/fail result
+  (define result-snip%
+    (class image-snip%
+      (inherit set-bitmap)
+      (init-field [status 'unknown])
+      ;; ((symbols 'pass 'fail 'unknown 'disabled) . -> . void?)
+      ;; updates the image with the icon representing one of three results
+      (define/public (update value)
+	(set-bitmap
+	 (memoize value
+		  (lambda ()
+		    (make-object bitmap%
+				 (test-icon
+				  (case value
+				    [(pass) "small-check-mark.jpeg"]
+				    [(fail) "small-cross.jpeg"]
+				    [(unknown) "small-empty.gif"]
+				    [(disabled) "small-no.gif"])))))))
+      
+      (super-new)
+      (update status)))
+
+  (define memory (make-hash-table 'equal))
+  (define (memoize k thunk)
+    (hash-table-get memory k (lambda ()
+			       (let ([v (thunk)]) 
+				 (hash-table-put! memory k v)
+				 v))))
+  
+  #;(string? . -> . string?)
+  ;; A path to the icon given a file name
+  (define (icon str)
+    (build-path (collection-path "icons") str))
+  
+  #;(string? . -> . string?)
+  ;; A path to the icon in the test-suite given a file name
+  (define (test-icon str)
+    (build-path (collection-path "test-suite") "private" "icons" str))
+  
+  ;; a locked text hightlighted to show that it is inactive
+  (define actual-text%
+    (class (grey-editor-mixin
+            (text:hide-caret/selection-mixin scheme:text%))
+      (inherit hide-caret lock)
+      (super-new)
+      (hide-caret true)
+      (lock true)))
+
+  ;; a text mixin that gives the text an init arg of an initial contents
+  (define init-text-mixin
+    (mixin ((class->interface text%)) ()
+      (inherit insert)
+      (init [text ""])
+      (super-new)
+      (insert text)))
+           
+  #;(boolean? . -> . (symbols 'on 'off))
+  ;; converts a boolean to the value expected by the collapse button
+  (define (boolean->collapse-btn-state bool)
+    (if bool 'on 'off))
+  
+  #;(boolean? . -> . (symbols 'on 'off))
+  ;; converts a boolean to the value expected by the show actual button
+  (define (boolean->show-actual-btn-state bool)
+    (if bool 'off 'on))
+  
+  #;((is-a?/c text%) . -> . boolean?)
+  ;; True if the given text is empty
+  (define (empty-text? t)
+    (let ([str (send t get-text)])
+      (string=? str "")))
+  
+  ;;;;;;;;;;
+  ;; Eaiser syntax for embedded-gui
+  (define (snip-wrap p snip)
+    (new snip-wrapper% (parent p) (snip snip)))
+  
+  ;; Inserts a label and a text field into the given alignment
+  (define labeled-text-field%
+    (class vertical-alignment%
+      (init label text (snip-class stretchable-editor-snip%))
+      (super-new (stretchable-height false))
+      (new embedded-message% (parent this) (label label))
+      (new snip-wrapper%
+           (parent this)
+           (snip (new snip-class
+                      (editor text)
+                      (min-width 80))))))
+  
+  #;((union any? false?) (any? . -> . any?) . -> . (union any? false?))
+  ;; Send the value to the function unless it 'fails' by returning false. Like haskell's bind operator.
+  (define (>>= value function)
+    (cond
+      [value => function]
+      [else false]))
+  )
diff --git a/collects/test-suite/private/test-case.ss b/collects/test-suite/private/test-case.ss
new file mode 100644
index 0000000000..30cec55a0d
--- /dev/null
+++ b/collects/test-suite/private/test-case.ss
@@ -0,0 +1,75 @@
+#|
+This module provides a test-case macro for the test-case-box to expand into.
+The test-case box does not immediatly expand into the body of the macro itself
+because the macro is able to check the (syntax-local-context) of the invocation
+to give better error messages when the test-case is not at the top level.
+|#
+
+(module test-case mzscheme
+  
+  (provide test-case test-error-case)
+  
+  ;; STATUS : Abstract these two syntaxes and use string constant for the error  
+  (define-syntax (test-case stx)
+    (syntax-case stx ()
+      [(_ test to-test-stx exp-stx record set-actuals)
+       (case (syntax-local-context)
+         [(module top-level)
+          (syntax-property
+           #`(define-values ()
+               (let ([to-test-values (call-with-values
+                                      (lambda () #,(syntax-property #`to-test-stx
+                                                                    'stepper-test-suite-hint
+                                                                    #t))
+                                                       list)]
+                     [exp-values (call-with-values (lambda () exp-stx) list)])
+                 (record (and (= (length to-test-values) (length exp-values))
+                              (andmap test to-test-values exp-values)))
+                 (set-actuals to-test-values)
+                 (values)))
+           'stepper-skipto
+           (list ;define-values
+            syntax-e cdr cdr car 
+            ; let-values
+            syntax-e cdr car 
+            ; clauses
+            syntax-e car syntax-e cdr car
+            ; call-with-values
+            syntax-e cdr syntax-e cdr car 
+            ; lambda
+            syntax-e cdr cdr car
+            ))]
+         [else (raise-syntax-error #f
+                                   "test case not at toplevel"
+                                   (syntax/loc stx (test-case to-test-stx exp-stx)))])]))
+  
+  (define-syntax (test-error-case stx)
+    (syntax-case stx ()
+      [(_ to-test-stx exn-pred exn-handler record set-actuals)
+       (case (syntax-local-context)
+         [(module top-level)
+          (syntax-property
+           #'(define-values ()
+               (with-handlers ([exn-pred
+                                (lambda (v)
+                                  (set-actuals (list v))
+                                  (record (exn-handler v))
+                                  (values))]
+                               [void
+                                (lambda (v)
+                                  (set-actuals v)
+                                  (record #f)
+                                  (values))])
+                 to-test-stx
+                 (record #f)
+                 (values)))
+           'stepper-skipto
+           (list ;; define-values
+            syntax-e cdr cdr car
+            ;; with-handlers
+            syntax-e cdr cdr cdr car
+            ))]
+         [else (raise-syntax-error #f
+                                   "test case not at toplevel"
+                                   (syntax/loc stx (test-case to-test-stx exp-stx)))])]))
+  )
diff --git a/collects/test-suite/private/text-syntax-object.ss b/collects/test-suite/private/text-syntax-object.ss
new file mode 100644
index 0000000000..cf33146618
--- /dev/null
+++ b/collects/test-suite/private/text-syntax-object.ss
@@ -0,0 +1,59 @@
+(module text-syntax-object mzscheme
+  
+  (require
+   (lib "unitsig.ss")
+   (lib "class.ss")
+   (lib "list.ss")
+   (lib "tool.ss" "drscheme")
+   (lib "framework.ss" "framework")
+   (lib "mred.ss" "mred"))
+  
+  (provide text->syntax-object@
+           text->syntax-object^)
+
+  (define top-id #'here)
+  
+  (define-signature text->syntax-object^ (text->syntax-objects))
+  
+  (define text->syntax-object@
+    (unit/sig text->syntax-object^
+      (import drscheme:tool^)
+      
+      #;((is-a?/c text%) . -> . (listof syntax-object?))
+      ;; a syntax object representing the text with the color of the given object
+      (define (text->syntax-objects text default-v)
+        (let ([port (open-input-text-editor text)])
+          #;(-> (listof syntax-object?))
+          ;; Reads all the syntax objects for the text%
+          (define (read-all-syntax)
+            (let* ([language-settings
+                    (preferences:get
+                     (drscheme:language-configuration:get-settings-preferences-symbol))]
+                   [language
+                    (drscheme:language-configuration:language-settings-language
+                     language-settings)]
+                   [settings
+                    (drscheme:language-configuration:language-settings-settings
+                     language-settings)])
+              (if (drscheme:language-configuration:language-settings? language-settings)
+                  (let ([thunk (if (and default-v
+					(zero? (send text last-position)))
+				   (let ([got? #f])
+				     (lambda () 
+				       (begin0
+					(if got?
+					    eof
+					    default-v)
+					(set! got? #t))))
+				   (send language front-end/interaction
+					 (open-input-text-editor text)
+					 settings
+					 (drscheme:teachpack:new-teachpack-cache '())))])
+                    (let loop ()
+                      (let ([expr (thunk)])
+                        (cond [(eof-object? expr) empty]
+                              [else (cons expr (loop))]))))
+                  (error 'text->syntax-object "Invalid language settings"))))
+          (read-all-syntax)))
+      ))
+  )
\ No newline at end of file
diff --git a/collects/test-suite/tool.ss b/collects/test-suite/tool.ss
new file mode 100644
index 0000000000..0a9db3a05c
--- /dev/null
+++ b/collects/test-suite/tool.ss
@@ -0,0 +1,179 @@
+(module tool mzscheme
+  
+  (provide tool@)
+  
+  (require
+   (lib "etc.ss")
+   (lib "class.ss")
+   (lib "mred.ss" "mred")
+   (lib "unitsig.ss")
+   (lib "tool.ss" "drscheme")
+   (lib "framework.ss" "framework")
+   (lib "string-constant.ss" "string-constants")
+   (lib "snip-lib.ss" "mrlib" "private" "aligned-pasteboard")
+   "private/test-case-box.ss"
+   "private/find-scheme-menu.ss"
+   "private/text-syntax-object.ss"
+   "private/print-to-text.ss")
+  
+  (define-signature menu-extentions^ ())
+  (define menu-extentions@
+    (unit/sig menu-extentions^;drscheme:tool-exports^
+      (import drscheme:tool^ test-case-box^)
+      
+      ;; This delay is set up because reset-highlighting is called immediately
+      ;; after execution where I don't want the test-cases to be cleared.
+      ;; STATUS: It appears that the problem this flag was created to fix has been
+      ;; fixed and is now delaying unecessarily. I have commented out the place where
+      ;; it is set to true, effectively turning off the feature. I'll remove the code
+      ;; if no bugs creap in after sufficient usage.
+      (define delay? false)
+      
+      ;; This flag ensures that the test case boxes are only reset when the need
+      ;; to be, which is only once after each execution of the program.
+      (define needs-reset? false)
+      
+      ;; Adds the test suite tool menu to the Dr. Scheme frame
+      ;; Updates the needs-reset? when the the program is executed
+      (define test-case-mixin
+        (mixin (drscheme:unit:frame<%> top-level-window<%> (class->interface frame%)) ()
+          (inherit get-definitions-text get-edit-target-object get-menu-bar
+                   get-special-menu)
+          
+          #;(-> void)
+          ;; Called when the program is executed
+          ;; Overriden to rest the test-cases.
+          (define/override (execute-callback)
+            (send (get-definitions-text) for-each-test-case
+                  (lambda (case) (send case reset)))
+            (super execute-callback)
+            ;(set! delay? true)
+            (set! needs-reset? true))
+          
+          #;(boolean . -> . void)
+          ;; Enable or disable all of the test-cases
+          (define (enable enable?)
+            (send (get-definitions-text) for-each-test-case
+                  (lambda (case) (send case enable enable?))))
+          
+          #;((is-a?/c menu-item%) . -> . void)
+          ;; NOTE: This function is COPIED from the drscheme/private/unit.ss file
+          (define (has-editor-on-demand menu-item)
+            (let ([edit (get-edit-target-object)])
+              (send menu-item enable (and edit (is-a? edit editor<%>)))))
+          
+          (super-new)
+          
+          ;; Create the new menu items.
+          (field
+           [test-cases-enabled? true]
+           [insert-menu-item
+            (new menu-item%
+                 (label (string-constant test-case-insert))
+                 (parent (get-special-menu))
+                 (callback
+                  (lambda (menu event)
+                    (let ([test-box (new test-case-box% (enabled? test-cases-enabled?))]
+                          [text (get-edit-target-object)])
+                      (when text
+                        (send text begin-edit-sequence)
+                        (send text insert test-box)
+                        (send test-box take-caret)
+                        (send text end-edit-sequence)))))
+                 (demand-callback has-editor-on-demand))])
+          (let ([parent (find-scheme-menu (get-special-menu))])
+            (and parent
+                 (new menu-item%
+                      (parent parent)
+                      (label (string-constant test-case-disable-all))
+                      (callback
+                       (lambda (menu event)
+                         (set! test-cases-enabled? (not test-cases-enabled?))
+                         (if test-cases-enabled?
+                             (send menu set-label (string-constant test-case-disable-all))
+                             (send menu set-label (string-constant test-case-enable-all)))
+                         (send (get-definitions-text) for-each-test-case
+                               (lambda (tc) (send tc enable test-cases-enabled?))))))))))
+
+      (drscheme:get/extend:extend-unit-frame test-case-mixin)
+      
+      ;; Adds a hook in the reset-highlighting to clear all of the test-case results when
+      ;; the appropriate
+      ;; STATUS: It's better to override reset-highlighting but this after-insert/delete works
+      ;; for now.
+      (define clear-results-mixin
+        (mixin (editor<%>) ()
+          (inherit find-first-snip)
+
+          ;#;(case-> (-> boolean?) (boolean? . -> . void))
+          ;;; Get or set the delay-reset field
+          ;(define/public delay-reset
+          ;  (case-lambda
+          ;    [() delay?]
+          ;    [(v) (set! delay? v)]))
+          
+          #;(-> void)
+          ;; set all of the test-case-boxes in the definitions text to an unevaluated state
+          (define/public (reset-test-case-boxes)
+            (when needs-reset?
+              (set! needs-reset? false)
+              (for-each-test-case (lambda (snip) (send snip reset)))))
+          
+          #;(((is-a?/c test-case-box%) . -> . void) . -> . void)
+          ;; executes the given function on each test-case-box
+          (define/public (for-each-test-case f)
+            (for-each-snip
+               (lambda (snip)
+                 (when (is-a? snip test-case-box%)
+                   (f snip)))
+               (find-first-snip)))
+          
+          (super-new)))
+      
+      (drscheme:get/extend:extend-definitions-text clear-results-mixin)
+
+      ;; Require the test-case macro into every new namespace when a program is run.
+      (define require-macro-mixin
+        (mixin ((class->interface drscheme:rep:text%)) ()
+          (inherit get-user-namespace get-canvas)
+          
+          #;((is-a?/c area<%>) . -> . (is-a?/c frame%))
+          ;; The frame containing the given area
+          (define (find-frame area)
+            (let ([parent (send area get-parent)])
+              (if parent
+                  (find-frame parent)
+                  area)))
+          
+          #;(-> void)
+          ;; Called to indicate that the program annotations should be cleared.
+          ;; Overriden to reset test case boxes
+          (define/override (reset-highlighting)
+            (super reset-highlighting)
+            (let ([text (send (find-frame (get-canvas)) get-definitions-text)])
+              ;(if (send text delay-reset)
+              ;    (send text delay-reset false)
+              ;    (send text reset-test-case-boxes)))) 
+              (send text reset-test-case-boxes)))
+          
+          #;(-> void)
+          ;; Called when the program is execute to reset the rep:text
+          ;; Overriden to require the test case macro into any program that is executed.
+          (define/override (reset-console)
+            (super reset-console)
+            (parameterize ([current-namespace (get-user-namespace)])
+              (namespace-require '(lib "test-case.ss" "test-suite" "private"))))
+          (super-new)))
+      
+      (drscheme:get/extend:extend-interactions-text require-macro-mixin)))
+  
+  (define tool@
+    (compound-unit/sig
+     (import (TOOL : drscheme:tool^))
+     (link (MENU   : menu-extentions^ (menu-extentions@ TOOL CASE))
+           (CASE   : test-case-box^ (test-case-box@ TOOL SYNTAX PRINT))
+           (SYNTAX : text->syntax-object^ (text->syntax-object@ TOOL))
+           (PRINT  : print-to-text^ (print-to-text@ TOOL)))
+     (export (var (CASE phase1))
+             (var (CASE phase2)))))
+  )
diff --git a/collects/tests/addrhack.c b/collects/tests/addrhack.c
new file mode 100644
index 0000000000..99c5c9143c
--- /dev/null
+++ b/collects/tests/addrhack.c
@@ -0,0 +1,57 @@
+/*
+Matthew writes:
+
+This file, when loaded, defines:
+
+  object->address : value -> exact integer in [0,2^32-1]
+  address->object : exact integer in [0,2^32-1] -> value
+
+Obviously, address->object is not safe.
+
+To Compile:
+
+  mzc --cc addrhack.c
+  mzc --ld addrhack.so addrhack.o
+
+*/
+#include "escheme.h"
+
+Scheme_Object *object_to_address(int c, Scheme_Object **a)
+{
+  return scheme_make_integer_value_from_unsigned((unsigned long)a[0]);
+}
+
+Scheme_Object *address_to_object(int c, Scheme_Object **a)
+{
+  unsigned long v;
+
+  if (!scheme_get_unsigned_int_val(a[0], &v))
+    scheme_signal_error("bad address");
+
+  return (Scheme_Object *)v;
+}
+
+Scheme_Object *scheme_reload(Scheme_Env *env)
+{
+  scheme_add_global("object->address", 
+                    scheme_make_prim_w_arity(object_to_address,
+                                             "object->address",
+                                             1, 1),
+                    env);
+  scheme_add_global("address->object",
+                    scheme_make_prim_w_arity(address_to_object, 
+                                             "address->object",
+                                             1, 1),
+                    env);
+
+  return scheme_void;
+}
+
+Scheme_Object *scheme_initialize(Scheme_Env *env)
+{
+  return scheme_reload(env);
+}
+
+Scheme_Object *scheme_module_name() {
+  return scheme_make_string("addrhack");
+}
diff --git a/collects/tests/aligned-pasteboard/debug.ss b/collects/tests/aligned-pasteboard/debug.ss
new file mode 100644
index 0000000000..d13734ea9f
--- /dev/null
+++ b/collects/tests/aligned-pasteboard/debug.ss
@@ -0,0 +1,80 @@
+(module debug mzscheme
+  (require
+   (lib "class.ss"))
+  
+  (provide
+   debug-snip
+   debug-pasteboard
+   debug-canvas)
+  
+  ;;debug-snip: -> (void)
+  ;;get the relevant info about the snip that contains the two others pasteboards
+  (define debug-snip
+    (lambda (snip)
+      (printf "--- aligned-editor-snip% --\n")
+      (let ((l (box 0))
+            (t (box 0))
+            (r (box 0))
+            (b (box 0)))
+        (send snip get-inset l t r b)
+        (printf "get-inset: ~sX~s  ~sX~s\n" (unbox l) (unbox r) (unbox t) (unbox b)))
+      
+      (let ((l (box 0))
+            (t (box 0))
+            (r (box 0))
+            (b (box 0)))
+        (send snip get-margin l t r b)
+        (printf "get-margin: ~sX~s  ~sX~s\n" (unbox l) (unbox r) (unbox t) (unbox b)))
+      
+      (printf "get-max-height: ~s~n" (send snip get-max-height))
+      (printf "get-max-width: ~s~n" (send snip get-max-width))
+      (printf "get-min-height: ~s~n" (send snip get-min-height))
+      (printf "get-min-width: ~s~n" (send snip get-min-width))
+      ;(printf "snip-width: ~s~n" (send pasteboard snip-width snip))
+      ;(printf "snip-height: ~s~n" (send pasteboard snip-height snip))
+      ))
+  
+  ;;debug-pasteboard: -> (void)
+  ;;displays to the repl the sizes i'm interested in
+  (define debug-pasteboard
+    (lambda (pasteboard)
+      (printf "--- aligned-pasteboard% ---\n")
+      (let ((tmp1 (box 0))
+            (tmp2 (box 0)))
+        (send pasteboard get-extent tmp1 tmp2)
+        (printf "get-extent: ~sX~s\n" (unbox tmp1) (unbox tmp2)))
+      (printf "get-max-height: ~s\n" (send pasteboard get-max-height))
+      (let ((tmp (call-with-values (lambda () (send pasteboard get-max-view-size)) cons)))
+        (printf "get-max-view-size: ~sX~s\n" (car tmp) (cdr tmp)))
+      (printf "get-max-width: ~s\n" (send pasteboard get-max-width))
+      (printf "get-min-height: ~s\n" (send pasteboard get-min-height))
+      (printf "get-min-width: ~s\n" (send pasteboard get-min-width))
+      (let ((tmp1 (box 0))
+            (tmp2 (box 0)))
+        (send pasteboard get-view-size tmp1 tmp2)
+        (printf "get-view-size: ~sX~s\n" (unbox tmp1) (unbox tmp2)))
+      ))
+  
+  ;;debug-canvas: -> (void)
+  ;;just some help counting pixels
+  (define debug-canvas
+    (lambda (canvas)
+      (printf "--- aligned-editor-canvas% ---\n")
+      ;;values
+      (let ((tmp (call-with-values (lambda () (send canvas get-client-size)) cons)))
+        (printf "~a: ~sX~s\n" (symbol->string (quote get-client-size)) (car tmp) (cdr tmp)))
+      (let ((tmp (call-with-values (lambda () (send canvas get-graphical-min-size)) cons)))
+        (printf "~a: ~sX~s\n" (symbol->string (quote get-graphical-min-size)) (car tmp) (cdr tmp)))
+      (let ((tmp (call-with-values (lambda () (send canvas get-size)) cons)))
+        (printf "~a: ~sX~s\n" (symbol->string (quote get-size)) (car tmp) (cdr tmp)))
+      ;;1 value
+      (printf "~a: ~s\n" (symbol->string (quote get-height)) (send canvas get-height))
+      (printf "~a: ~s\n" (symbol->string (quote get-width)) (send canvas get-width))
+      (printf "~a: ~s\n" (symbol->string (quote horiz-margin)) (send canvas horiz-margin))
+      (printf "~a: ~s\n" (symbol->string (quote min-client-height)) (send canvas min-client-height))
+      (printf "~a: ~s\n" (symbol->string (quote min-client-width)) (send canvas min-client-width))
+      (printf "~a: ~s\n" (symbol->string (quote min-height)) (send canvas min-height))
+      (printf "~a: ~s\n" (symbol->string (quote min-width)) (send canvas min-width))
+      (printf "~a: ~s\n" (symbol->string (quote vert-margin)) (send canvas vert-margin))
+      ))
+  )
\ No newline at end of file
diff --git a/collects/tests/aligned-pasteboard/example.ss b/collects/tests/aligned-pasteboard/example.ss
new file mode 100644
index 0000000000..d9fe843e5d
--- /dev/null
+++ b/collects/tests/aligned-pasteboard/example.ss
@@ -0,0 +1,87 @@
+(require
+ (lib "class.ss")
+ (lib "mred.ss" "mred")
+ (lib "etc.ss")
+ "../aligned-pasteboard.ss"
+ "../aligned-editor-container.ss")
+
+;                                                          
+;                                                          
+;                                       ;;                 
+;                                        ;                 
+;                                        ;                 
+;    ;;;;; ;;  ;;  ;;;;;;;;;;;;;; ;;;    ;     ;;;;;  ;;;; 
+;   ;    ;  ;;;;      ; ;  ;  ; ;;  ;;   ;    ;    ; ;   ; 
+;   ;;;;;;   ;;    ;;;; ;  ;  ; ;    ;   ;    ;;;;;; ;;;;  
+;   ;        ;;   ;   ; ;  ;  ; ;    ;   ;    ;          ; 
+;   ;;   ;  ;  ;  ;   ; ;  ;  ; ;;  ;;   ;    ;;   ; ;   ; 
+;    ;;;;  ;;  ;;  ;;;;;;; ;; ;;; ;;;  ;;;;;   ;;;;  ;;;;  
+;                               ;                          
+;                              ;;;                         
+;                                                          
+
+(define frame
+  (instantiate frame% ()
+    (label "Frame")
+    (width 400)
+    (height 400)))
+
+(define pasteboard
+  (instantiate horizontal-pasteboard% ()))
+
+(define canvas
+  (instantiate aligned-editor-canvas% ()
+    (parent frame)
+    (editor pasteboard)))
+
+(define vp1
+  (instantiate vertical-pasteboard% ()))
+
+(define ae-snip1
+  (instantiate aligned-editor-snip% ()
+    (editor vp1)))
+
+(define vp2
+  (instantiate vertical-pasteboard% ()))
+
+(define ae-snip2
+  (instantiate aligned-editor-snip% ()
+    (editor vp2)))
+
+(define vp3
+  (instantiate vertical-pasteboard% ()))
+
+(define ae-snip3
+  (instantiate aligned-editor-snip% ()
+    (editor vp3)))
+
+(define vp4
+  (instantiate vertical-pasteboard% ()))
+
+(define ae-snip4
+  (instantiate aligned-editor-snip% ()
+    (editor vp4)))
+
+(define vp5
+  (instantiate vertical-pasteboard% ()))
+
+(define ae-snip5
+  (instantiate aligned-editor-snip% ()
+    (editor vp5)))
+
+(define t-snip1
+  (instantiate editor-snip% ()
+    (editor (instantiate text% ()))))
+
+(define t-snip2
+  (instantiate editor-snip% ()
+    (editor (instantiate text% ()))))
+
+(send pasteboard insert ae-snip1 false)
+(send pasteboard insert ae-snip2 false)
+(send pasteboard insert ae-snip5 false)
+(send vp2 insert ae-snip3 false)
+(send vp2 insert ae-snip4 false)
+(send vp1 insert t-snip1 false)
+(send vp5 insert t-snip2 false)
+(send frame show true)
\ No newline at end of file
diff --git a/collects/tests/aligned-pasteboard/old-bugs/big-min.ss b/collects/tests/aligned-pasteboard/old-bugs/big-min.ss
new file mode 100644
index 0000000000..abd08f35b5
--- /dev/null
+++ b/collects/tests/aligned-pasteboard/old-bugs/big-min.ss
@@ -0,0 +1,25 @@
+(require
+ (lib "class.ss")
+ (lib "mred.ss" "mred")
+ (lib "etc.ss")
+ (lib "aligned-pasteboard.ss" "mrlib"))
+
+(define frame (instantiate frame% () (label "big-min") (width 400) (height 500)))
+(define test-suite (instantiate vertical-pasteboard% ()))
+(instantiate aligned-editor-canvas% () (parent frame) (editor test-suite))
+
+(define top-string false)
+
+(define (new)
+  (let* ([main-pb (instantiate horizontal-pasteboard% ())]
+         [pb (instantiate vertical-pasteboard% ())]
+         [snip (instantiate aligned-editor-snip% () (editor pb))]
+         [string (make-object string-snip% "Testing String Snip")])
+    (set! top-string string)
+    (send main-pb insert snip false)
+    (send main-pb insert string false)
+    (instantiate aligned-editor-snip% () (editor main-pb))))
+
+(send frame show true)
+(define (add) (send test-suite insert (new)))
+(add)
\ No newline at end of file
diff --git a/collects/tests/aligned-pasteboard/old-bugs/missing-min.ss b/collects/tests/aligned-pasteboard/old-bugs/missing-min.ss
new file mode 100644
index 0000000000..aa7fc2cff1
--- /dev/null
+++ b/collects/tests/aligned-pasteboard/old-bugs/missing-min.ss
@@ -0,0 +1,20 @@
+(require
+ (lib "class.ss")
+ (lib "etc.ss")
+ (lib "aligned-pasteboard.ss" "mrlib")
+ (lib "class.ss")
+ (lib "mred.ss" "mred"))
+
+(define f (instantiate frame% () (label "test") (width 400) (height 500)))
+(define pb1 (instantiate vertical-pasteboard% ()))
+(define ec (instantiate aligned-editor-canvas% () (parent f) (editor pb1) (style '(no-hscroll))))
+
+(define pb2 (instantiate vertical-pasteboard% ()))
+(define es2 (instantiate aligned-editor-snip% () (editor pb2)))
+
+(define t (instantiate text% ()))
+(define es3 (instantiate editor-snip% () (editor t)))
+
+(send pb1 insert es2)
+(send pb2 insert es3)
+(send f show true)
\ No newline at end of file
diff --git a/collects/tests/aligned-pasteboard/snip-dumper.ss b/collects/tests/aligned-pasteboard/snip-dumper.ss
new file mode 100644
index 0000000000..8fdd8f68e4
--- /dev/null
+++ b/collects/tests/aligned-pasteboard/snip-dumper.ss
@@ -0,0 +1,70 @@
+(module snip-dumper mzscheme
+  
+  (require
+   (lib "class.ss")
+   (lib "mred.ss" "mred"))
+  
+  (provide
+   dump-children
+   (struct snip-dump (left top right bottom children))
+   dump=?)
+  
+  ;;dump=?: ((union snip-dump? (listof snip-dump?)) . -> . boolean?)
+  (define (dump=? dump1 dump2)
+    (cond
+      [(and (list? dump1) (list? dump2)
+            (eq? (length dump1) (length dump2)))
+       (andmap dump=? dump1 dump2)]
+      [(and (snip-dump? dump1) (snip-dump? dump2))
+       (and
+        (dump=? (snip-dump-left dump1)
+                (snip-dump-left dump2))
+        (dump=? (snip-dump-top dump1)
+                (snip-dump-top dump2))
+        (dump=? (snip-dump-right dump1)
+                (snip-dump-right dump2))
+        (dump=? (snip-dump-bottom dump1)
+                (snip-dump-bottom dump2))
+        (dump=? (snip-dump-children dump1)
+                (snip-dump-children dump2)))]
+      [else (equal? dump1 dump2)]))
+  
+  ;; type snip-dump =
+  ;;   (make-single number number number number (union #f (listof snip-dump)))
+  ;; if children is #f, this indicates that the snip was not an
+  ;; editor-snip. In contrast, if it is null, this indicates that
+  ;; the snip is an editor-snip, but has no children.
+  (define-struct snip-dump (left top right bottom children))
+  
+  ;; dump-pb : snip -> snip-dump
+  (define (dump-snip snip)
+    (let ([outer-pb (send (send snip get-admin) get-editor)]
+          [bl (box 0)]
+          [bt (box 0)]
+          [br (box 0)]
+          [bb (box 0)])
+      (send outer-pb get-snip-location snip bl bt #t)
+      (send outer-pb get-snip-location snip br bb #f)
+      (make-snip-dump
+       (unbox bl)
+       (unbox bt)
+       (unbox br)
+       (unbox bb)
+       (dump-snips snip))))
+  
+  ;; dump-snips : snip -> (union #f (listof snip-dump))
+  (define (dump-snips snip)
+    (cond
+      [(is-a? snip editor-snip%)
+       (dump-children (send snip get-editor))]
+      [else #f]))
+  
+  ;; dump-children : editor<%> -> (listof snip-dump)
+  (define (dump-children editor)
+    (let loop ([snip (send editor find-first-snip)])
+      (cond
+        [snip
+         (cons (dump-snip snip)
+               (loop (send snip next)))]
+        [else null])))
+  )
\ No newline at end of file
diff --git a/collects/tests/aligned-pasteboard/test-alignment.ss b/collects/tests/aligned-pasteboard/test-alignment.ss
new file mode 100644
index 0000000000..21802a60a8
--- /dev/null
+++ b/collects/tests/aligned-pasteboard/test-alignment.ss
@@ -0,0 +1,252 @@
+(require
+ "utils.ss"
+ (lib "etc.ss")
+ (lib "list.ss")
+ (lib "match.ss")
+ (lib "private/aligned-pasteboard/alignment.ss" "mrlib"))
+
+;; los-equal? ((listof rect?) (listof rect?) . -> . boolean?)
+;; tests the equality of the list of structures
+(define (los-equal? a b)
+  (equal?
+   (map rect->list a)
+   (map rect->list b)))
+
+;; rect->list (rect? . -> . vector?)
+;; a vector of the fields in the rect
+(define rect->list
+  (match-lambda
+    [($ rect ($ dim x width stretchable-width?) ($ dim y height stretchable-height?))
+     (list x width stretchable-width? y height stretchable-height?)]))
+
+;; empty pasteboard
+(test
+ los-equal?
+ (align 'vertical 100 100 empty)
+ empty)
+
+;; empty pasteboard
+(test
+ los-equal?
+ (align 'horizontal 100 100 empty)
+ empty)
+
+;; one unstretchable snip
+(test
+ los-equal?
+ (align 'vertical
+        100 100
+        (list (make-rect (make-dim 0 10 false)
+                         (make-dim 0 10 false))))
+ (list (make-rect (make-dim 0 10 false)
+                  (make-dim 0 10 false))))
+
+(test
+ los-equal?
+ (align 'horizontal
+        100 100
+        (list (make-rect (make-dim 0 10 false)
+                         (make-dim 0 10 false))))
+ (list (make-rect (make-dim 0 10 false)
+                  (make-dim 0 10 false))))
+
+;; one stretchable snip
+(test
+ los-equal?
+ (align 'vertical
+        100 100
+        (list (make-rect (make-dim 0 10 true)
+                         (make-dim 0 10 true))))
+ (list (make-rect (make-dim 0 100 true)
+                  (make-dim 0 100 true))))
+
+;; two stretchable snips
+(test
+ los-equal?
+ (align 'vertical
+        10
+        10
+        (list
+         (make-rect (make-dim 0 0 true)
+                    (make-dim 0 0 true))
+         (make-rect (make-dim 0 0 true)
+                    (make-dim 0 0 true))))
+ (list
+  (make-rect (make-dim 0 10 true)
+             (make-dim 0 5 true))
+  (make-rect (make-dim 0 10 true)
+             (make-dim 5 5 true))))
+
+;; three stretchable, one too big
+(test
+ los-equal?
+ (align 'vertical
+        50 100
+        (list (make-rect (make-dim 0 0 true)
+                         (make-dim 0 50 true))
+              (make-rect (make-dim 0 0 true)
+                         (make-dim 0 0 true))
+              (make-rect (make-dim 0 0 true)
+                         (make-dim 0 0 true))))
+ (list (make-rect (make-dim 0 50 true)
+                  (make-dim 0 50 true))
+       (make-rect (make-dim 0 50 true)
+                  (make-dim 50 25 true))
+       (make-rect (make-dim 0 50 true)
+                  (make-dim 75 25 true))))
+
+;; three stetchable, one too big, and an unstetchable
+(test
+ los-equal?
+ (align 'vertical
+        50 100
+        (list (make-rect (make-dim 0 0 true)
+                         (make-dim 0 50 true))
+              (make-rect (make-dim 0 0 true)
+                         (make-dim 0 0 true))
+              (make-rect (make-dim 0 0 true)
+                         (make-dim 0 0 true))
+              (make-rect (make-dim 0 50 false)
+                         (make-dim 0 10 false))))
+ (list (make-rect (make-dim 0 50 true)
+                  (make-dim 0 50 true))
+       (make-rect (make-dim 0 50 true)
+                  (make-dim 50 20 true))
+       (make-rect (make-dim 0 50 true)
+                  (make-dim 70 20 true))
+       (make-rect (make-dim 0 50 false)
+                  (make-dim 90 10 false))))
+
+;; failure from test-suite frame
+;; wrong answer given was (list (make-rect 0 0 335.0 10 #t))
+(test
+ los-equal?
+ (align 'vertical
+        335.0
+        563.0
+        (list
+         (make-rect (make-dim 0 10.0 #t)
+                    (make-dim 0 10.0 #t))))
+ (list (make-rect (make-dim 0 335.0 true)
+                  (make-dim 0 563.0 true))))
+
+;; sort of like the previous failed test but with a nonsizable snip
+(test
+ los-equal?
+ (align 'vertical
+        563.0
+        335.0
+        (list
+         (make-rect (make-dim 0 10.0 #t)
+                    (make-dim 0 10.0 #t))
+         (make-rect (make-dim 0 10.0 false)
+                    (make-dim 0 10.0 false))))
+ (list (make-rect (make-dim 0 563.0 true)
+                  (make-dim 0 325.0 true))
+       (make-rect (make-dim 0 10.0 false)
+                  (make-dim 325.0 10.0 false))))
+
+;; something that requires a little modulo in division
+(test
+ los-equal?
+ (align 'vertical
+        10
+        10
+        (list
+         (make-rect (make-dim 0 0 true)
+                    (make-dim 0 0 true))
+         (make-rect (make-dim 0 0 true)
+                    (make-dim 0 0 true))
+         (make-rect (make-dim 0 0 true)
+                    (make-dim 0 0 true))))
+ (list (make-rect (make-dim 0 10 true)
+                  (make-dim 0 4 true))
+       (make-rect (make-dim 0 10 true)
+                  (make-dim 4 3 true))
+       (make-rect (make-dim 0 10 true)
+                  (make-dim 7 3 true))))
+
+;; 1 snip only stretches in off dimention
+(test
+ los-equal?
+ (align 'vertical
+        100
+        400
+        (list
+         (make-rect (make-dim 0 10 true)
+                    (make-dim 0 30 false))))
+ (list (make-rect (make-dim 0 100 true)
+                  (make-dim 0 30 false))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; The following examples of usage were taken from the test-suite tool and turned into test cases ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(test
+ los-equal?
+ (align 'vertical 563.0 335.0 (list))
+ empty)
+
+(test
+ los-equal?
+ (align 'vertical 563.0 335.0
+        (list (make-rect (make-dim 0 241 #t) (make-dim 0 114 #f))))
+ (list (make-rect (make-dim 0 563.0 #t) (make-dim 0 114 #f))))
+
+(test
+ los-equal?
+ (align 'vertical 551.0 102.0
+        (list (make-rect (make-dim 0 34 #t) (make-dim 0 47 #t))
+              (make-rect (make-dim 0 231 #t) (make-dim 0 57 #t))))
+ (list (make-rect (make-dim 0 551.0 #t) (make-dim 0 47 #t))
+       (make-rect (make-dim 0 551.0 #t) (make-dim 47 57 #t))))
+
+(test
+ los-equal?
+ (align 'vertical 539.0 35.0
+        (list (make-rect (make-dim 0 24 #f) (make-dim 0 13 #f))
+              (make-rect (make-dim 0 11 #f) (make-dim 0 24 #f))))
+ (list (make-rect (make-dim 0 24 #f) (make-dim 0 13 #f))
+       (make-rect (make-dim 0 11 #f) (make-dim 13 24 #f))))
+
+(test
+ los-equal?
+ (align 'horizontal 539.0 45.0
+        (list (make-rect (make-dim 0 65 #t) (make-dim 0 47 #t))
+              (make-rect (make-dim 0 48 #t) (make-dim 0 47 #t))
+              (make-rect (make-dim 0 63 #t) (make-dim 0 47 #t))
+              (make-rect (make-dim 0 45 #f) (make-dim 0 44 #f))))
+ (list
+  (make-rect (make-dim 0 165.0 true) (make-dim 0 45.0 true))
+  (make-rect (make-dim 165.0 165.0 true) (make-dim 0 45.0 true))
+  (make-rect (make-dim 330.0 164.0 true) (make-dim 0 45.0 true))
+  (make-rect (make-dim 494.0 45 false) (make-dim 0 44 false))))
+
+(test
+ los-equal?
+ (align 'vertical 153.0 33.0
+        (list (make-rect (make-dim 0 55 #f) (make-dim 0 13 #f))
+              (make-rect (make-dim 0 11 #f) (make-dim 0 24 #f))))
+ (list
+  (make-rect (make-dim 0 55 false) (make-dim 0 13 false))
+  (make-rect (make-dim 0 11 false) (make-dim 13 24 false))))
+
+(test
+ los-equal?
+ (align 'vertical 153.0 33.0
+        (list (make-rect (make-dim 0 38 #f) (make-dim 0 13 #f))
+              (make-rect (make-dim 0 11 #f) (make-dim 0 24 #f))))
+ (list
+  (make-rect (make-dim 0 38 false) (make-dim 0 13 false))
+  (make-rect (make-dim 0 11 false) (make-dim 13 24 false))))
+
+(test
+ los-equal?
+ (align 'vertical 152.0 33.0
+        (list (make-rect (make-dim 0 26 #f) (make-dim 0 13 #f))
+              (make-rect (make-dim 0 53 #f) (make-dim 0 24 #f))))
+ (list
+  (make-rect (make-dim 0 26 false) (make-dim 0 13 false))
+  (make-rect (make-dim 0 53 false) (make-dim 13 24 false))))
+
+(tests-done)
diff --git a/collects/tests/aligned-pasteboard/test-pasteboard-lib.ss b/collects/tests/aligned-pasteboard/test-pasteboard-lib.ss
new file mode 100644
index 0000000000..d6fd14e834
--- /dev/null
+++ b/collects/tests/aligned-pasteboard/test-pasteboard-lib.ss
@@ -0,0 +1,117 @@
+(require
+ "utils.ss"
+ (lib "etc.ss")
+ (lib "class.ss")
+ (lib "mred.ss" "mred")
+ (lib "private/aligned-pasteboard/pasteboard-lib.ss" "mrlib")
+ (lib "aligned-pasteboard.ss" "mrlib"))
+
+;; pasteboard-root: ((is-a?/c aligned-pasteboard<%>) -> (is-a?/c aligned-pasteboard<%>))
+;; gets the top most aligned pasteboard in the tree of pasteboards and containers
+
+(let*
+    ([pb1 (instantiate vertical-pasteboard% ())]
+     [pb2 (instantiate horizontal-pasteboard% ())]
+     [pb3 (instantiate vertical-pasteboard% ())]
+     [es2 (instantiate aligned-editor-snip% () (editor pb2))]
+     [es3 (instantiate aligned-editor-snip% () (editor pb3))]
+     
+     [frame (instantiate frame% () (label "l") (width 10) (height 10))]
+     [canvas (instantiate aligned-editor-canvas% () (parent frame) (editor pb1))])
+  
+  (send pb1 insert es2)
+  (send pb2 insert es3)
+  
+  (test equal?
+   (pasteboard-root pb3)
+   pb1)
+  
+  (test equal?
+   (pasteboard-root pb2)
+   pb1)
+  
+  (test equal?
+   (pasteboard-root pb1)
+   pb1)
+  )
+
+(let*
+    ([pb1 (instantiate vertical-pasteboard% ())]
+     [pb2 (instantiate horizontal-pasteboard% ())]
+     [pb3 (instantiate vertical-pasteboard% ())]
+     [es1 (instantiate aligned-editor-snip% () (editor pb1))]
+     [es3 (instantiate aligned-editor-snip% () (editor pb3))]
+     
+     [frame (instantiate frame% () (label "l") (width 10) (height 10))]
+     [canvas (instantiate aligned-editor-canvas% () (parent frame) (editor pb2))])
+  
+  (send pb2 insert es1)
+  (send pb2 insert es3)
+  
+  (test equal?
+   (pasteboard-root pb3)
+   pb2)
+  
+  (test equal?
+   (pasteboard-root pb2)
+   pb2)
+  
+  (test equal?
+   (pasteboard-root pb1)
+   pb2)
+  )
+
+;; pasteboard-parent: ((is-a?/c pasteboard%) . -> . (is-a?/c aligned-editor-container<%>))
+;; gets the canvas or snip that the pasteboard is displayed in
+(let*
+    ([pb1 (instantiate vertical-pasteboard% ())]
+     [pb2 (instantiate horizontal-pasteboard% ())]
+     [pb3 (instantiate vertical-pasteboard% ())]
+     [es2 (instantiate aligned-editor-snip% () (editor pb2))]
+     [es3 (instantiate aligned-editor-snip% () (editor pb3))]
+     
+     [frame (instantiate frame% () (label "l") (width 10) (height 10))]
+     [canvas (instantiate aligned-editor-canvas% () (parent frame) (editor pb1))])
+  
+  (send pb1 insert es2)
+  (send pb2 insert es3)
+  
+  (test equal?
+   (pasteboard-parent pb1)
+   canvas)
+  
+  (test equal?
+   (pasteboard-parent pb2)
+   es2)
+  
+  (test equal?
+   (pasteboard-parent pb3)
+   es3)
+  )
+
+(let*
+    ([pb1 (instantiate vertical-pasteboard% ())]
+     [pb2 (instantiate horizontal-pasteboard% ())]
+     [pb3 (instantiate vertical-pasteboard% ())]
+     [es2 (instantiate aligned-editor-snip% () (editor pb2))]
+     [es3 (instantiate aligned-editor-snip% () (editor pb3))]
+     
+     [frame (instantiate frame% () (label "l") (width 10) (height 10))]
+     [canvas (instantiate aligned-editor-canvas% () (parent frame) (editor pb1))])
+  
+  (send pb1 insert es2)
+  (send pb1 insert es3)
+  
+  (test equal?
+   (pasteboard-parent pb1)
+   canvas)
+  
+  (test equal?
+   (pasteboard-parent pb2)
+   es2)
+  
+  (test equal?
+   (pasteboard-parent pb3)
+   es3)
+  )
+(tests-done)
diff --git a/collects/tests/aligned-pasteboard/test-snip-lib.ss b/collects/tests/aligned-pasteboard/test-snip-lib.ss
new file mode 100644
index 0000000000..f8c0f9a074
--- /dev/null
+++ b/collects/tests/aligned-pasteboard/test-snip-lib.ss
@@ -0,0 +1,201 @@
+(require
+ "utils.ss"
+ (lib "etc.ss")
+ (lib "class.ss")
+ (lib "mred.ss" "mred")
+ (lib "private/aligned-pasteboard/snip-lib.ss" "mrlib")
+ (lib "private/aligned-pasteboard/aligned-pasteboard.ss" "mrlib")
+ (lib "private/aligned-pasteboard/aligned-editor-container.ss" "mrlib"))
+
+(printf "running tests for snip-lib.ss~n")
+  
+;;snip-min-width: ((is-a?/c snip%) . -> . number?)
+;;the width of a snip in the given pasteboard
+(let*
+    ([pb1 (instantiate vertical-pasteboard% ())]
+     [es1 (instantiate editor-snip% () (editor pb1))]
+     [pb2 (instantiate vertical-pasteboard% ())]
+     
+     [frame (instantiate frame% () (label "l") (width 10) (height 10))]
+     [canvas (instantiate aligned-editor-canvas% () (parent frame) (editor pb2))])
+  (send frame show true)
+  
+  (send pb2 insert es1)
+  (send es1 resize 20 20)
+  (sleep/yield 1)
+  (test
+   =
+   (snip-min-width es1)
+   20)
+  
+  (send es1 resize 200 90)
+  (sleep/yield 1)
+  (test
+   =
+   (snip-min-width es1)
+   200)
+  
+  (send frame show false)
+  )
+
+;;snip-min-height: ((is-a?/c snip%) . -> . number?)
+;;the height of a snip in the given pasteboard
+(let*
+    ([pb1 (instantiate vertical-pasteboard% ())]
+     [es1 (instantiate editor-snip% () (editor pb1))]
+     [pb2 (instantiate vertical-pasteboard% ())]
+     
+     [frame (instantiate frame% () (label "l") (width 10) (height 10))]
+     [canvas (instantiate aligned-editor-canvas% () (parent frame) (editor pb2))])
+  (send frame show true)
+  
+  (send pb2 insert es1)
+  (send es1 resize 20 20)
+  (sleep/yield 1)
+  (test
+   =
+   (snip-min-height es1)
+   20)
+  
+  (send es1 resize 200 90)
+  (sleep/yield 1)
+  (test
+   =
+   (snip-min-height es1)
+   90)
+  
+  (send frame show false)
+  )
+
+;;snip-parent: ((is-a?/c snip%) . -> . (is-a?/c editor<%>))
+;;the pasteboard that contains the snip
+(let*
+    ([pb1 (instantiate pasteboard% ())]
+     [es1 (instantiate editor-snip% () (editor pb1))]
+     [pb2 (instantiate pasteboard% ())]
+     
+     [frame (instantiate frame% () (label "l") (width 10) (height 10))]
+     [canvas (instantiate editor-canvas% () (parent frame) (editor pb2))])
+  (send frame show true)
+  
+  (send pb2 insert es1)
+  
+  (test
+   equal?
+   (snip-parent es1)
+   pb2)
+  
+  (send frame show false)
+  )
+
+(let*
+    ([pb1 (instantiate horizontal-pasteboard% ())]
+     [pb2 (instantiate horizontal-pasteboard% ())]
+     [pb3 (instantiate horizontal-pasteboard% ())]
+     [pb4 (instantiate horizontal-pasteboard% ())]
+     [pb5 (instantiate horizontal-pasteboard% ())]
+     [es2 (instantiate aligned-editor-snip% () (editor pb2))]
+     [es3 (instantiate aligned-editor-snip% () (editor pb3))]
+     [es4 (instantiate aligned-editor-snip% () (editor pb4))]
+     [es5 (instantiate aligned-editor-snip% () (editor pb5))]
+     
+     [frame (instantiate frame% () (label "l") (width 10) (height 10))]
+     [canvas (instantiate aligned-editor-canvas% () (parent frame) (editor pb1))])
+  (send frame show true)
+  (send pb1 insert es2)
+  (send pb2 insert es3)
+  (send pb3 insert es4)
+  (send pb4 insert es5)
+  
+  (test
+   equal?
+   (snip-parent es2)
+   pb1)
+  
+  (test
+   equal?
+   (snip-parent es3)
+   pb2)
+  
+  (test
+   equal?
+   (snip-parent es4)
+   pb3)
+  
+  (test
+   equal?
+   (snip-parent es5)
+   pb4)
+  
+  (send frame show false)
+  )
+
+;;fold-snip: (lambda (b?) ((any? b? . -> . b?) b? (is-a?/c snip%) . -> . b?))
+;;the application of f on all snips from snip to the end in a foldl foldr mannor
+(let*
+    ([pb1 (instantiate vertical-pasteboard% ())]
+     [es1 (instantiate editor-snip% () (editor (instantiate text% ())))]
+     [es2 (instantiate editor-snip% () (editor (instantiate text% ())))]
+     [es3 (instantiate editor-snip% () (editor (instantiate text% ())))]
+     [es4 (instantiate editor-snip% () (editor (instantiate text% ())))]
+     
+     [frame (instantiate frame% () (label "l") (width 10) (height 10))]
+     [canvas (instantiate aligned-editor-canvas% () (parent frame) (editor pb1))])
+  (send frame show true)
+  
+  (send pb1 insert es1)
+  (send pb1 insert es2)
+  (send pb1 insert es3)
+  (send pb1 insert es4)
+  
+  (send es1 resize 100 100)
+  (send es2 resize 100 100)
+  (send es3 resize 100 100)
+  (send es4 resize 100 100)
+  
+  (test
+   =
+   (fold-snip
+    (lambda (snip total-height)
+      (+ (snip-min-height snip)
+         total-height))
+    0
+    es4)
+   400)
+  
+  (send frame show false)
+  )
+
+  
+;;for-each-snip: (((is-a?/c snip%) . -> . (void)) (is-a/c? snip%) . -> . (void))
+;;applies the function to all the snips
+(let*
+    ([pb1 (instantiate vertical-pasteboard% ())]
+     [es1 (instantiate editor-snip% () (editor (instantiate text% ())))]
+     [es2 (instantiate editor-snip% () (editor (instantiate text% ())))]
+     [es3 (instantiate editor-snip% () (editor (instantiate text% ())))]
+     [es4 (instantiate editor-snip% () (editor (instantiate text% ())))]
+     
+     [frame (instantiate frame% () (label "l") (width 10) (height 10))]
+     [canvas (instantiate aligned-editor-canvas% () (parent frame) (editor pb1))]
+     [count 0])
+  (send frame show true)
+  
+  (send pb1 insert es1)
+  (send pb1 insert es2)
+  (send pb1 insert es3)
+  (send pb1 insert es4)
+  
+  (for-each-snip
+   (lambda (snip)
+     (set! count (add1 count)))
+   es4)
+  
+  (test
+   =
+   count
+   4)
+  
+  (send frame show false)
+  )
+(tests-done)
diff --git a/collects/tests/aligned-pasteboard/test.ss b/collects/tests/aligned-pasteboard/test.ss
new file mode 100644
index 0000000000..621cd3c806
--- /dev/null
+++ b/collects/tests/aligned-pasteboard/test.ss
@@ -0,0 +1,232 @@
+;;note: turns out these tests are window manager specific
+
+(require
+ (lib "class.ss")
+ (lib "mred.ss" "mred")
+ (lib "etc.ss")
+ (lib "list.ss")
+ (lib "aligned-pasteboard.ss" "mrlib")
+ "snip-dumper.ss")
+
+                                                        
+                                                        
+;                                     ;;                 
+;                                      ;                 
+;                                      ;                 
+;  ;;;;; ;;  ;;  ;;;;;;;;;;;;;; ;;;    ;     ;;;;;  ;;;; 
+; ;    ;  ;;;;      ; ;  ;  ; ;;  ;;   ;    ;    ; ;   ; 
+; ;;;;;;   ;;    ;;;; ;  ;  ; ;    ;   ;    ;;;;;; ;;;;  
+; ;        ;;   ;   ; ;  ;  ; ;    ;   ;    ;          ; 
+; ;;   ;  ;  ;  ;   ; ;  ;  ; ;;  ;;   ;    ;;   ; ;   ; 
+;  ;;;;  ;;  ;;  ;;;;;;; ;; ;;; ;;;  ;;;;;   ;;;;  ;;;;  
+;                             ;                          
+;                            ;;;                         
+                                                        
+(printf "running test1.ss~n")
+
+(define frame
+  (instantiate frame% ()
+    (label "Frame")
+    (width 400)
+    (height 400)))
+
+(define pasteboard
+  (instantiate horizontal-pasteboard% ()))
+
+(define canvas
+  (instantiate aligned-editor-canvas% ()
+    (parent frame)
+    (editor pasteboard)))
+
+(define insider
+  (instantiate vertical-pasteboard% ()))
+
+(define insider2
+  (instantiate vertical-pasteboard% ()))
+
+(define insider3
+  (instantiate vertical-pasteboard% ()))
+
+(define insider4
+  (instantiate vertical-pasteboard% ()))
+
+(define insider5
+  (instantiate vertical-pasteboard% ()))
+
+(define insider6
+  (instantiate vertical-pasteboard% ()))
+
+(define insider7
+  (instantiate vertical-pasteboard% ()))
+
+(define pb-snip
+  (instantiate aligned-editor-snip% ()
+    (editor insider)))
+
+(define pb-snip2
+  (instantiate aligned-editor-snip% ()
+    (editor insider2)))
+
+(define pb-snip3
+  (instantiate aligned-editor-snip% ()
+    (editor insider3)))
+
+(define pb-snip4
+  (instantiate aligned-editor-snip% ()
+    (editor insider4)))
+
+(define pb-snip5
+  (instantiate aligned-editor-snip% ()
+    (editor insider5)))
+
+(define pb-snip6
+  (instantiate aligned-editor-snip% ()
+    (editor insider6)))
+
+(define pb-snip7
+  (instantiate aligned-editor-snip% ()
+    (editor insider7)))
+
+(define t-snip
+  (instantiate editor-snip% ()
+    (editor
+     (instantiate text% ()))))
+
+(define i-snip
+  (instantiate image-snip% ()))
+
+(define i-snip2
+  (instantiate image-snip% ()))
+
+(define t-snip2
+  (instantiate editor-snip% ()
+    (editor
+     (instantiate text% ()))))
+(define t-snip3
+  (instantiate editor-snip% ()
+    (editor
+     (instantiate text% ()))))
+
+(send pasteboard begin-edit-sequence)
+(send frame show true)
+(send pasteboard insert pb-snip)
+(send pasteboard insert t-snip)
+(send pasteboard insert i-snip)
+(send pasteboard insert i-snip2)
+(send pasteboard insert pb-snip2)
+(send pasteboard insert t-snip2)
+(send insider insert t-snip3)
+(send insider2 insert pb-snip3)
+(send insider2 insert pb-snip4)
+(send pasteboard insert pb-snip5)
+(send pasteboard insert pb-snip6)
+(send pasteboard insert pb-snip7)
+(send pasteboard end-edit-sequence)
+
+
+
+
+; ;                    ;            
+; ;                    ;            
+;;;;;;;   ;;;;;  ;;;; ;;;;;    ;;;; 
+; ;      ;    ; ;   ;  ;      ;   ; 
+; ;      ;;;;;; ;;;;   ;      ;;;;  
+; ;      ;          ;  ;          ; 
+; ;      ;;   ; ;   ;  ;      ;   ; 
+; ;;;;;   ;;;;  ;;;;   ;;;;;  ;;;;  
+
+
+
+
+(dump=?
+ (dump-children pasteboard)
+ (list
+  (make-snip-dump 57.0 368.0 0.0 0.0 empty)
+  (make-snip-dump 114.0 368.0 57.0 0.0 empty)
+  (make-snip-dump 171.0 368.0 114.0 0.0 empty)
+  (make-snip-dump 182.0 24.0 171.0 0.0 empty)
+  (make-snip-dump
+   249.0
+   368.0
+   182.0
+   0.0
+   (list (make-snip-dump 55.0 178.0 0.0 0.0 empty) (make-snip-dump 55.0 356.0 0.0 178.0 empty)))
+  (make-snip-dump 269.0 20.0 249.0 0.0 false)
+  (make-snip-dump 289.0 20.0 269.0 0.0 false)
+  (make-snip-dump 300.0 24.0 289.0 0.0 empty)
+  (make-snip-dump 368.0 368.0 300.0 0.0 (list (make-snip-dump 11.0 24.0 0.0 0.0 empty))))
+ )
+
+(send frame resize 0 0)
+(sleep/yield 1)
+
+(dump=?
+ (dump-children pasteboard)
+ (list
+  (make-snip-dump 10.0 34.0 0.0 0.0 empty)
+  (make-snip-dump 20.0 34.0 10.0 0.0 empty)
+  (make-snip-dump 30.0 34.0 20.0 0.0 empty)
+  (make-snip-dump 41.0 24.0 30.0 0.0 empty)
+  (make-snip-dump
+   61.0
+   34.0
+   41.0
+   0.0
+   (list (make-snip-dump 10.0 11.0 0.0 0.0 empty) (make-snip-dump 10.0 22.0 0.0 11.0 empty)))
+  (make-snip-dump 81.0 20.0 61.0 0.0 false)
+  (make-snip-dump 101.0 20.0 81.0 0.0 false)
+  (make-snip-dump 112.0 24.0 101.0 0.0 empty)
+  (make-snip-dump 133.0 34.0 112.0 0.0 (list (make-snip-dump 11.0 24.0 0.0 0.0 empty))))
+ )
+
+(send frame resize 800 600)
+(sleep/yield 1)
+
+(dump=?
+ (dump-children pasteboard)
+ (list
+  (make-snip-dump 137.0 568.0 0.0 0.0 empty)
+  (make-snip-dump 274.0 568.0 137.0 0.0 empty)
+  (make-snip-dump 411.0 568.0 274.0 0.0 empty)
+  (make-snip-dump 422.0 24.0 411.0 0.0 empty)
+  (make-snip-dump
+   569.0
+   568.0
+   422.0
+   0.0
+   (list (make-snip-dump 135.0 278.0 0.0 0.0 empty) (make-snip-dump 135.0 556.0 0.0 278.0 empty)))
+  (make-snip-dump 589.0 20.0 569.0 0.0 false)
+  (make-snip-dump 609.0 20.0 589.0 0.0 false)
+  (make-snip-dump 620.0 24.0 609.0 0.0 empty)
+  (make-snip-dump 768.0 568.0 620.0 0.0 (list (make-snip-dump 11.0 24.0 0.0 0.0 empty))))
+ )
+
+(send frame resize 400 400)
+(send pasteboard delete i-snip)
+(send pasteboard delete i-snip2)
+
+(dump=?
+ (dump-children pasteboard)
+ (list
+  (make-snip-dump 65.0 368.0 0.0 0.0 empty)
+  (make-snip-dump 130.0 368.0 65.0 0.0 empty)
+  (make-snip-dump 195.0 368.0 130.0 0.0 empty)
+  (make-snip-dump 206.0 24.0 195.0 0.0 empty)
+  (make-snip-dump
+   281.0
+   368.0
+   206.0
+   0.0
+   (list (make-snip-dump 63.0 178.0 0.0 0.0 empty) (make-snip-dump 63.0 356.0 0.0 178.0 empty)))
+  (make-snip-dump 292.0 24.0 281.0 0.0 empty)
+  (make-snip-dump 368.0 368.0 292.0 0.0 (list (make-snip-dump 11.0 24.0 0.0 0.0 empty))))
+ )
+
+(send pasteboard erase)
+(dump=?
+ (dump-children pasteboard)
+ empty
+ )
+
+(send frame show false)
+(printf "done~n")
\ No newline at end of file
diff --git a/collects/tests/aligned-pasteboard/test2.ss b/collects/tests/aligned-pasteboard/test2.ss
new file mode 100644
index 0000000000..21992a2c87
--- /dev/null
+++ b/collects/tests/aligned-pasteboard/test2.ss
@@ -0,0 +1,190 @@
+;;note: turns out these tests are window manager specific
+
+(require
+ (lib "class.ss")
+ (lib "mred.ss" "mred")
+ (lib "etc.ss")
+ (lib "list.ss")
+ (lib "aligned-pasteboard.ss" "mrlib")
+ "snip-dumper.ss")
+
+;                                                          
+;                                                          
+;                                       ;;                 
+;                                        ;                 
+;                                        ;                 
+;    ;;;;; ;;  ;;  ;;;;;;;;;;;;;; ;;;    ;     ;;;;;  ;;;; 
+;   ;    ;  ;;;;      ; ;  ;  ; ;;  ;;   ;    ;    ; ;   ; 
+;   ;;;;;;   ;;    ;;;; ;  ;  ; ;    ;   ;    ;;;;;; ;;;;  
+;   ;        ;;   ;   ; ;  ;  ; ;    ;   ;    ;          ; 
+;   ;;   ;  ;  ;  ;   ; ;  ;  ; ;;  ;;   ;    ;;   ; ;   ; 
+;    ;;;;  ;;  ;;  ;;;;;;; ;; ;;; ;;;  ;;;;;   ;;;;  ;;;;  
+;                               ;                          
+;                              ;;;                         
+;                                                          
+
+(printf "running test2.ss~n")
+
+(define frame
+  (instantiate frame% ()
+    (label "Frame")
+    (width 400)
+    (height 400)))
+
+(define pasteboard
+  (instantiate horizontal-pasteboard% ()))
+
+(define canvas
+  (instantiate aligned-editor-canvas% ()
+    (parent frame)
+    (editor pasteboard)))
+
+(define vp1
+  (instantiate vertical-pasteboard% ()))
+
+(define ae-snip1
+  (instantiate aligned-editor-snip% ()
+    (editor vp1)))
+
+(define vp2
+  (instantiate vertical-pasteboard% ()))
+
+(define ae-snip2
+  (instantiate aligned-editor-snip% ()
+    (editor vp2)))
+
+(define vp3
+  (instantiate vertical-pasteboard% ()))
+
+(define ae-snip3
+  (instantiate aligned-editor-snip% ()
+    (editor vp3)))
+
+(define vp4
+  (instantiate vertical-pasteboard% ()))
+
+(define ae-snip4
+  (instantiate aligned-editor-snip% ()
+    (editor vp4)))
+
+(define vp5
+  (instantiate vertical-pasteboard% ()))
+
+(define ae-snip5
+  (instantiate aligned-editor-snip% ()
+    (editor vp5)))
+
+(send pasteboard insert ae-snip1)
+(send pasteboard insert ae-snip2)
+(send pasteboard insert ae-snip5)
+(send vp2 insert ae-snip3)
+(send vp2 insert ae-snip4)
+(send frame show true)
+
+;                                     
+;                                     
+;                                     
+;   ;                    ;            
+;   ;                    ;            
+;  ;;;;;    ;;;;;  ;;;; ;;;;;    ;;;; 
+;   ;      ;    ; ;   ;  ;      ;   ; 
+;   ;      ;;;;;; ;;;;   ;      ;;;;  
+;   ;      ;          ;  ;          ; 
+;   ;      ;;   ; ;   ;  ;      ;   ; 
+;   ;;;;;   ;;;;  ;;;;   ;;;;;  ;;;;  
+;                                     
+;                                     
+;                                     
+
+(sleep/yield 1)
+(dump=?
+ (dump-children pasteboard)
+ (list
+  (make-snip-dump 120.0 368.0 0.0 0.0 empty)
+  (make-snip-dump
+   249.0
+   368.0
+   120.0
+   0.0
+   (list (make-snip-dump 117.0 178.0 0.0 0.0 empty) (make-snip-dump 117.0 356.0 0.0 178.0 empty)))
+  (make-snip-dump 368.0 368.0 249.0 0.0 empty))
+ )
+
+(send frame resize 0 0)
+(sleep/yield 1)
+(dump=?
+ (dump-children pasteboard)
+ (list
+  (make-snip-dump 10.0 30.0 0.0 0.0 empty)
+  (make-snip-dump
+   30.0
+   30.0
+   10.0
+   0.0
+   (list (make-snip-dump 10.0 10.0 0.0 0.0 empty) (make-snip-dump 10.0 19.0 0.0 9.0 empty)))
+  (make-snip-dump 40.0 30.0 30.0 0.0 empty))
+ )
+
+(send frame resize 800 600)
+(sleep/yield 1)
+(dump=?
+ (dump-children pasteboard)
+ (list
+  (make-snip-dump 253.0 568.0 0.0 0.0 empty)
+  (make-snip-dump
+   516.0
+   568.0
+   253.0
+   0.0
+   (list (make-snip-dump 251.0 278.0 0.0 0.0 empty) (make-snip-dump 251.0 556.0 0.0 278.0 empty)))
+  (make-snip-dump 768.0 568.0 516.0 0.0 empty))
+ )
+
+(send pasteboard delete ae-snip5)
+(dump=?
+ (dump-children pasteboard)
+ (list
+  (make-snip-dump
+   389.0
+   568.0
+   0.0
+   0.0
+   (list (make-snip-dump 377.0 278.0 0.0 0.0 empty) (make-snip-dump 377.0 556.0 0.0 278.0 empty)))
+  (make-snip-dump 768.0 568.0 389.0 0.0 empty))
+ )
+
+(send pasteboard insert ae-snip5)
+(dump=?
+ (dump-children pasteboard)
+ (list
+  (make-snip-dump 253.0 568.0 0.0 0.0 empty)
+  (make-snip-dump
+   516.0
+   568.0
+   253.0
+   0.0
+   (list (make-snip-dump 251.0 278.0 0.0 0.0 empty) (make-snip-dump 251.0 556.0 0.0 278.0 empty)))
+  (make-snip-dump 768.0 568.0 516.0 0.0 empty))
+ )
+
+(send pasteboard delete ae-snip5)
+(send pasteboard delete ae-snip1)
+(dump=?
+ (dump-children pasteboard)
+ (list
+  (make-snip-dump
+   768.0
+   568.0
+   0.0
+   0.0
+   (list (make-snip-dump 756.0 278.0 0.0 0.0 empty) (make-snip-dump 756.0 556.0 0.0 278.0 empty))))
+ )
+
+(send pasteboard erase)
+(dump=?
+ (dump-children pasteboard)
+ empty
+ )
+
+(send frame show false)
+(printf "done~n")
diff --git a/collects/tests/drscheme/README b/collects/tests/drscheme/README
new file mode 100644
index 0000000000..fd6223358e
--- /dev/null
+++ b/collects/tests/drscheme/README
@@ -0,0 +1,58 @@
+`(#|
+
+This directory contains code for testing DrScheme. To run the tests,
+load run-test.ss. It will return a function that accepts the names of
+tests. Those names must be listed here. If no arguments are passed to
+the function, all tests will be run.
+
+|# stepper-test.ss #|
+
+   runs the stepper on the sample solutions and
+   checks the results.
+   
+|# io.ss #|
+
+   This tests the drscheme's io implementation.
+   
+|# repl-test.ss #|
+
+   This tests various interactions between parameters in the 
+   implementation of drscheme.
+
+|# language-test.ss #|   
+
+   This tests that all of the individual settings in the language dialog 
+   take effect in the repl.
+
+|# module-lang-test.ss #|
+
+   This tests the code involved in implementing the new module language.
+   
+   graphics.ss
+
+   This tests the various graphic elements that can appear
+   in programs.
+
+  launcher.ss
+
+   This tests the launcher feature of drscheme.
+
+  sample-solutions-one-window.ss
+
+   This tests the sample solutions in HtDP,
+   but reuses the same drscheme window.
+   There is a race condition in this test,
+   so it is commented out here, for now.
+   
+|# teachpack.ss #|
+
+   Tests the teachpacks
+
+|# syncheck-test.ss #|
+
+|# test-box-test.ss #|
+
+   Test test boxes.
+   
+
+|#)
diff --git a/collects/tests/drscheme/drscheme-test-util.ss b/collects/tests/drscheme/drscheme-test-util.ss
new file mode 100644
index 0000000000..c297ffa945
--- /dev/null
+++ b/collects/tests/drscheme/drscheme-test-util.ss
@@ -0,0 +1,500 @@
+;;; util.ss
+
+;;; utility functions for DrScheme GUI testing 
+
+;;; Authors: Robby Findler, Paul Steckler
+
+(module drscheme-test-util mzscheme
+  (require (prefix fw: (lib "framework.ss" "framework"))
+           (lib "hierlist.ss" "hierlist")
+           (lib "mred.ss" "mred")
+           (lib "class.ss")
+           (lib "list.ss")
+           (lib "contract.ss")
+           (lib "etc.ss")
+           (lib "gui.ss" "tests" "utils")
+           (lib "contract.ss"))
+  
+  (provide/contract 
+   [use-get/put-dialog ((-> any) path? . -> . void?)])
+  
+  (provide save-drscheme-window-as
+           do-execute
+           test-util-error
+           poll-until
+           wait-for-computation
+           wait-for-drscheme-frame
+           wait-for-new-frame
+           clear-definitions
+           type-in-definitions
+           type-in-interactions
+           type-string
+           wait
+           wait-pending
+           get-sub-panel
+           get-text-pos
+           wait-for-button
+           push-button-and-wait
+           set-language-level!
+           repl-in-edit-sequence?
+           fetch-output
+           has-error?
+           run-one/sync)
+  
+  ;; save-drscheme-window-as : string -> void
+  ;; use the "save as" dialog in drscheme to save the definitions
+  ;; window to a file.
+  (define (save-drscheme-window-as filename)
+    (use-get/put-dialog
+     (lambda ()
+       (fw:test:menu-select "File" "Save Definitions As..."))
+     filename))
+
+  ;; open-dialog is a thunk that should open the dialog
+  ;; filename is a string naming a file that should be typed into the dialog
+  (define (use-get/put-dialog open-dialog filename)
+    (let ([drs (wait-for-drscheme-frame)])
+      (with-handlers ([(lambda (x) #t)
+		       (lambda (x)
+			 (fw:preferences:set 'framework:file-dialogs 'std)
+			 (raise x))])
+	(fw:preferences:set 'framework:file-dialogs 'common)
+	(open-dialog)
+	(let ([dlg (wait-for-new-frame drs)])
+	  (send (find-labelled-window "Full pathname") focus)
+	  (fw:test:keystroke #\a (list (case (system-type)
+					 [(windows) 'control]
+					 [(macosx macos) 'meta]
+					 [(unix) 'meta]
+                                         [else (error 'use-get/put-dialog "unknown platform: ~s\n"
+                                                      (system-type))])))
+	  (for-each fw:test:keystroke (string->list (path->string filename)))
+	  (fw:test:button-push "OK")
+	  (wait-for-new-frame dlg))
+	(fw:preferences:set 'framework:file-dialogs 'std))))
+
+  (define (test-util-error fmt . args)
+    (raise (make-exn (apply fmt args) (current-continuation-marks))))
+  
+  ;; poll-until : (-> alpha) number (-> alpha) -> alpha
+  ;; waits until pred return a true value and returns that.
+  ;; if that doesn't happen by `secs', calls fail and returns that.
+  (define poll-until
+    (opt-lambda (pred [secs 10] [fail (lambda ()
+                                        (error 'poll-until 
+                                               "timeout after ~e secs, ~e never returned a true value"
+                                               secs pred))])
+      (let ([step 1/20])
+	(let loop ([counter secs])
+	  (if (<= counter 0)
+	      (fail)
+	      (let ([result (pred)])
+		(or result
+		    (begin
+		      (sleep step)
+		      (loop (- counter step))))))))))
+  
+  (define (drscheme-frame? frame)
+    (method-in-interface? 'get-execute-button (object-interface frame)))
+  
+  (define wait-for-drscheme-frame
+    (case-lambda
+     [() (wait-for-drscheme-frame #t)]
+     [(print-message?)
+      (let ([wait-for-drscheme-frame-pred
+             (lambda ()
+               (let ([active (get-top-level-focus-window)])
+                 (if (and active
+                          (drscheme-frame? active))
+                     active
+                     #f)))])
+        (or (wait-for-drscheme-frame-pred)
+            (begin
+              (when print-message?
+                (printf "Select DrScheme frame~n"))
+              (poll-until wait-for-drscheme-frame-pred))))]))
+  
+  ;; wait-for-new-frame : frame [(listof eventspace) = null] -> frame
+  ;; returns the newly opened frame, waiting until old-frame
+  ;; is no longer frontmost. Optionally checks other eventspaces
+  ;; waits until the new frame has a focus'd window, too. 
+  (define wait-for-new-frame
+    (case-lambda
+     [(old-frame) (wait-for-new-frame old-frame null)]
+     [(old-frame extra-eventspaces)
+      (wait-for-new-frame old-frame extra-eventspaces 10)]
+     [(old-frame extra-eventspaces timeout)
+      (let ([wait-for-new-frame-pred
+	     (lambda ()
+	       (let ([active (or (get-top-level-focus-window)
+				 (ormap
+				  (lambda (eventspace)
+				    (parameterize ([current-eventspace eventspace])
+				      (get-top-level-focus-window)))
+				  extra-eventspaces))])
+		 (if (and active
+                          (send active get-focus-window)
+			  (not (eq? active old-frame)))
+		     active
+		     #f)))])
+	(poll-until wait-for-new-frame-pred timeout))]))
+
+  ;; wait-for-computation : frame -> void
+  ;; waits until the drscheme frame finishes some computation.
+  ;; uses the state of the execute button to indicate when the
+  ;; computations is finished. That is, waits for the execute
+  ;; button to dim, indicating a computation is running. Then,
+  ;; waits for it to be re-enabled, indicating that the computation
+  ;; is complete.
+  (define (wait-for-computation frame)
+    (verify-drscheme-frame-frontmost 'wait-for-computation frame)
+    (let* ([wait-for-computation-to-start
+	    (lambda ()
+	      (fw:test:reraise-error)
+	      (not (send (send frame get-execute-button) is-enabled?)))]
+           [wait-for-computation-to-finish
+	    (lambda ()
+	      (fw:test:reraise-error)
+	      (send (send frame get-execute-button) is-enabled?))])
+      ;(poll-until wait-for-computation-to-start 60) ;; hm.
+      (poll-until wait-for-computation-to-finish 60)))
+
+  (define do-execute 
+    (case-lambda
+     [(frame)
+      (do-execute frame #t)]
+     [(frame wait-for-finish?)
+      (verify-drscheme-frame-frontmost 'do-execute frame)
+      (let ([button (send frame get-execute-button)])
+	(fw:test:button-push button)
+	(when wait-for-finish?
+	  (wait-for-computation frame)))]))
+  
+  (define (verify-drscheme-frame-frontmost function-name frame)
+    (unless (and (eq? frame (get-top-level-focus-window))
+		 (drscheme-frame? frame))
+      (error function-name "drscheme frame not frontmost: ~e" frame)))
+  
+  (define (clear-definitions frame)
+    (verify-drscheme-frame-frontmost 'clear-definitions frame)
+    (fw:test:new-window (send frame get-definitions-canvas))
+    (let ([window (send frame get-focus-window)])
+      (let-values ([(cw ch) (send window get-client-size)]
+		   [(w h) (send window get-size)])
+	(fw:test:mouse-click 'left
+			     (inexact->exact (+ cw (floor (/ (- w cw) 2))))
+			     (inexact->exact (+ ch (floor (/ (- h ch) 2)))))))
+    (fw:test:menu-select "Edit" "Select All")
+    (fw:test:menu-select "Edit" (if (eq? (system-type) 'macos)
+				    "Clear"
+				    "Delete")))
+    
+  
+  (define (type-in-definitions frame str)
+    (type-in-definitions/interactions (lambda (x) (send x get-definitions-canvas)) frame str))
+  (define (type-in-interactions frame str)
+    (type-in-definitions/interactions (lambda (x) (send x get-interactions-canvas)) frame str))
+
+  (define (type-in-definitions/interactions get-canvas frame str/sexp)
+    (let ([str (if (string? str/sexp)
+		   str/sexp
+		   (let ([port (open-output-string)])
+		     (parameterize ([current-output-port port])
+		       (write str/sexp port))
+		     (get-output-string port)))])
+      (verify-drscheme-frame-frontmost 'type-in-definitions/interactions frame)
+      (let ([canvas (get-canvas frame)])
+	(fw:test:new-window canvas)
+	(send (send canvas get-editor) set-caret-owner #f)
+	(type-string str))))
+  
+  ;; type-string : string -> void
+  ;; to call test:keystroke repeatedly with the characters
+  (define (type-string str)
+    (let ([len (string-length str)])
+      (let loop ([i 0])
+        (unless (>= i len)
+          (let ([c (string-ref str i)])
+            (fw:test:keystroke
+             (if (char=? c #\newline)
+                 #\return
+                 c)))
+          (loop (+ i 1))))))
+  
+  (define wait
+    (case-lambda 
+     [(test desc-string) (wait test desc-string 5)]
+     [(test desc-string time)
+      (let ([int 1/2])
+	(let loop ([sofar 0])
+	  (cond
+	    [(> sofar time) (error 'wait desc-string)]
+	    [(test) (void)]
+	    [else (sleep int)
+		  (loop (+ sofar int))])))]))
+  
+  (define (wait-pending)
+    (wait (lambda () (= 0 (fw:test:number-pending-actions)))
+	  "Pending actions didn't terminate")
+    (fw:test:reraise-error))
+  
+  
+;;; get-sub-panel takes 
+;;;    a list of integers describing the path from a frame to the desired panel
+;;;    the frame
+;;;    based on code by Mark Krentel
+  
+;;;    Examples:
+;;;    (get-sub-panel '() frame) gets the top-panel in frame
+;;;    (get-sub-panel '(2) frame) gets the 2nd child of the top-panel 
+;;;    (get-sub-panel '(2 0) frame) gets the 0th child of the 2nd child of the top-panel 
+  
+  (define (get-sub-panel path frame)
+    (letrec ([loop 
+	      (lambda (path panel)
+		(if (null? path)
+		    (if (is-a? panel panel%)
+			panel
+			(test-util-error "not a panel")) 
+		    (loop
+		     (cdr path)
+		     (list-ref (send panel get-children) (car path)))))])
+      (loop path frame)))
+  
+;;; get-text-pos returns the offset in an text buffer of the beginning
+;;; of the last line
+  
+  (define (get-text-pos text)
+    (let* ([last-pos (send text last-position)]
+	   [last-line (send text position-line last-pos)])
+      (send text line-start-position last-line)))
+  
+  ; poll for enabled button
+  
+  (define (wait-for-button button)
+    (poll-until
+     (let ([wait-for-button-pred
+	    (lambda ()
+	      (send button is-enabled?))])
+       wait-for-button-pred)))
+  
+  (define (push-button-and-wait button)
+    (fw:test:button-push button)
+    (poll-until
+     (let ([button-push-and-wait-pred
+	    (lambda ()
+	      (fw:test:reraise-error)
+	      (= 0 (fw:test:number-pending-actions)))])
+       button-push-and-wait-pred))
+    (wait-for-button button))
+  
+  ;; set-language-level! : (cons (union regexp string) (listof (union regexp string))) boolean -> void
+  ;; set language level in the frontmost DrScheme frame (resets settings to defaults)
+  ;; If `close-dialog?' it #t,
+  (define set-language-level! 
+    (opt-lambda (in-language-spec [close-dialog? #t])
+      (unless (and (pair? in-language-spec)
+                   (list? in-language-spec)
+                   (andmap (lambda (x) (or string? regexp?)) in-language-spec))
+        (error 'set-language-level! "expected a non-empty list of regexps and strings for language, got: ~e" in-language-spec))
+      (let ([drs-frame (get-top-level-focus-window)])
+        (fw:test:menu-select "Language" "Choose Language...")
+        (let* ([language-dialog (wait-for-new-frame drs-frame)]
+               [language-choice (find-labelled-window #f hierarchical-list%)]
+               [b1 (box 0)]
+               [b2 (box 0)]
+               [click-on-snip
+                (lambda (snip)
+                  (let* ([editor (send (send snip get-admin) get-editor)]
+                         [between-threshold (send editor get-between-threshold)])
+                    (send editor get-snip-location snip b1 b2)
+                    (let-values ([(gx gy) (send editor editor-location-to-dc-location
+                                                (unbox b1)
+                                                (unbox b2))])
+                      (let ([x (inexact->exact (+ gx between-threshold 1))]
+                            [y (inexact->exact (+ gy between-threshold 1))])
+                        (fw:test:mouse-click 'left x y)))))])
+          (send language-choice focus)
+          (let loop ([list-item language-choice]
+                     [language-spec in-language-spec])
+            (let* ([name (car language-spec)]
+                   [which (filter (lambda (child)
+                                    (let* ([text (send (send child get-editor) get-text)]
+                                           [matches
+                                            (or (and (regexp? name)
+                                                     (regexp-match name text))
+                                                (and (string? name)
+                                                     (string=? name text)))])
+                                      (and matches
+                                           child)))
+                                  (send list-item get-items))])
+              (when (null? which)
+                (error 'set-language-level! "couldn't find language: ~e, no match at ~e"
+                       in-language-spec name))
+              (unless (= 1 (length which))
+                (error 'set-language-level! "couldn't find language: ~e, double match ~e"
+                       in-language-spec name))
+              (let ([next-item (car which)])
+                (cond
+                  [(null? (rest language-spec))
+                   (when (is-a? next-item hierarchical-list-compound-item<%>)
+                     (error 'set-language-level! "expected no more languages after ~e, but still are, input ~e"
+                            name in-language-spec))
+                   (click-on-snip (send next-item get-clickable-snip))]
+                  [else
+                   (unless (is-a? next-item hierarchical-list-compound-item<%>)
+                     (error 'set-language-level! "expected more languages after ~e, but got to end, input ~e"
+                            name in-language-spec))
+                   (unless (send next-item is-open?)
+                     (click-on-snip (send next-item get-arrow-snip)))
+                   (loop next-item (cdr language-spec))]))))
+          
+          (with-handlers ([exn:fail? (lambda (x) (void))])
+            (fw:test:button-push "Show Details"))
+          
+          (fw:test:button-push "Revert to Language Defaults")
+          
+          (when close-dialog?
+            (fw:test:button-push "OK")
+            (let ([new-frame (wait-for-new-frame language-dialog)])
+              (unless (eq? new-frame drs-frame)
+                (error 'set-language-level! "didn't get drscheme frame back, got: ~s\n" new-frame)))))))) 
+
+  (provide/contract [check-language-level ((union string? regexp?) . -> . void?)])
+  ;; checks that the language in the drscheme window is set to the given one.
+  ;; clears the definitions, clicks execute and checks the interactions window.
+  (define (check-language-level lang-spec)
+    (let* ([drs-frame (get-top-level-focus-window)]
+           [interactions (send drs-frame get-interactions-text)]
+           [definitions-canvas (send drs-frame get-definitions-canvas)])
+      (fw:test:new-window definitions-canvas)
+      (fw:test:menu-select "Edit" "Select All")
+      (fw:test:menu-select "Edit" "Delete")
+      (do-execute drs-frame)
+      (let ([lang-line (send interactions get-text
+                             (send interactions line-start-position 1)
+                             (send interactions line-end-position 1))])
+        (unless (regexp-match lang-spec lang-line)
+          (error 'check-language-level "expected ~s to match ~s"
+                 lang-line lang-spec)))))
+  
+  
+  (define (repl-in-edit-sequence?)
+    (send (send (wait-for-drscheme-frame) get-interactions-text) refresh-delayed?))
+ 
+  ;; has-error? : frame -> (union #f string)
+  ;; returns the error text of an error in the interactions window of the frame or #f if there is none.
+  ;; ensures that frame is front most.
+  (define (has-error? frame)
+    (run-one/sync
+     (lambda ()
+       (verify-drscheme-frame-frontmost 'had-error? frame)
+       (let* ([interactions-text (send frame get-interactions-text)]
+              [last-para (send interactions-text last-paragraph)])
+         (unless (>= last-para 2)
+           (error 'has-error? "expected at least 2 paragraphs in interactions window, found ~a"
+                  (+ last-para 1)))
+         (let ([start (send interactions-text paragraph-start-position 2)]
+               [end (send interactions-text paragraph-end-position
+                          (- (send interactions-text last-paragraph) 1))])
+           (send interactions-text split-snip start)
+           (send interactions-text split-snip end)
+           (let loop ([pos start])
+             (cond
+               [(<= end pos) #f]
+               [else
+                (let ([snip (send interactions-text find-snip pos 'after-or-none)])
+                  (cond
+                    [(not snip) #f]
+                    [else
+                     (let ([color (send (send snip get-style) get-foreground)])
+                       (if (and (= 255 (send color red))
+                                (= 0 (send color blue) (send color green)))
+                           
+                           ;; return the text of the entire line containing the red text
+                           (let ([para (send interactions-text position-paragraph pos)])
+                             (send interactions-text get-text
+                                   (send interactions-text paragraph-start-position para)
+                                   (send interactions-text paragraph-end-position para)))
+                           
+                           (loop (+ pos (send snip get-count)))))]))])))))))
+
+  (define fetch-output
+    (case-lambda
+      [(frame) (fetch-output frame #f #f)]
+      [(frame _start _end)
+       (run-one/sync
+        (lambda ()
+          (verify-drscheme-frame-frontmost 'fetch-output frame)
+          (let-values ([(start end)
+                        (if (and _start _end)
+                            (values _start _end)
+                            (let* ([interactions-text (send frame get-interactions-text)]
+                                   [last-para (send interactions-text last-paragraph)])
+                              (unless (>= last-para 2)
+                                (error 'fetch-output "expected at least 2 paragraphs in interactions window, found ~a"
+                                       (+ last-para 1)))
+                              (values (send interactions-text paragraph-start-position 2)
+                                      (send interactions-text paragraph-end-position
+                                            (- (send interactions-text last-paragraph) 1)))))])
+            (let ([interactions-text (send frame get-interactions-text)])
+              
+              (send interactions-text split-snip start)
+              (send interactions-text split-snip end)
+              (let loop ([snip (send interactions-text find-snip end 'before)]
+                         [strings null])
+                (cond
+                  [(< (send interactions-text get-snip-position snip) start)
+                   (apply string-append strings)]
+                  [else 
+                   (cond
+                     [(is-a? snip string-snip%)
+                      (loop (send snip previous)
+                            (cons (send snip get-text 0 (send snip get-count)) strings))]
+                     [(is-a? snip editor-snip%)
+                      (let ([editor (send snip get-editor)])
+                        (cond
+                          [(is-a? editor pasteboard%)
+                           (loop (send snip previous)
+                                 (cons "<pasteboard>" strings))]
+                          [(is-a? editor text%)
+                           (loop (send snip previous)
+                                 (list* "{embedded \""
+                                        (send editor get-text)
+                                        "\"}"
+                                        strings))]))]
+                     [(is-a? snip image-snip%)
+                      (loop (send snip previous)
+                            (cons (with-handlers ([exn:fail? (lambda (x) "{image}")])
+                                    (format "{~a}" (send snip get-image-name)))
+                                  strings))]
+                     
+                     [;; this test is an approximation of
+                      ;; (is-a? snip drscheme:snip:number-snip%)
+                      (and (method-in-interface? 'get-fraction-view (object-interface snip)))
+                      (loop (send snip previous)
+                            (cons (format "{number ~s ~s ~s}"
+                                          (send snip get-number)
+                                          (send snip get-text 0 (send snip get-count))
+                                          (send snip get-fraction-view))
+                                  strings))]
+                     
+                     [else (error 'find-output "{unknown snip: ~e}~n" snip)])]))))))]))
+  
+  ;; run-one/sync : (-> A) -> A
+  ;; runs the thunk `f' as a test action, and
+  ;; waits for it to complete. Also propogates
+  ;; exceptions.
+  (define (run-one/sync f)
+    (let ([s (make-semaphore 0)]
+          [exn #f]
+          [anss #f])
+      (fw:test:run-one
+       (lambda ()
+         (with-handlers ([exn:fail? (lambda (exn) (set! exn exn))])
+           (call-with-values f (lambda x (set! anss x))))
+         (semaphore-post s)))
+      (semaphore-wait s)
+      (if anss
+          (apply values anss)
+          (raise exn)))))
\ No newline at end of file
diff --git a/collects/tests/drscheme/info.ss b/collects/tests/drscheme/info.ss
new file mode 100644
index 0000000000..dfdb696668
--- /dev/null
+++ b/collects/tests/drscheme/info.ss
@@ -0,0 +1,10 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "DrScheme Test Suite")
+  (define compile-omit-files 
+    '("config-lang-test.ss" "drscheme-jr.ss" "drscheme-test.ss" 
+      "event-efficency.ss" ;"language-test.ss"
+      "launcher.ss" 
+      "line-art.ss" "menu-test.ss" "repl-test-tmp.ss" 
+      "pr-144.ss" "pr-246.ss" "pr-39.ss" "pr-46.ss" "pr-48.ss" 
+      "pr-51.ss" "pr-58.ss" "pr-80.ss" "pr-99.ss"
+      "sig.ss" "sixlib.ss")))
diff --git a/collects/tests/drscheme/io.ss b/collects/tests/drscheme/io.ss
new file mode 100644
index 0000000000..dadddcd7ac
--- /dev/null
+++ b/collects/tests/drscheme/io.ss
@@ -0,0 +1,172 @@
+#|
+
+add this test:
+
+(let ()
+  (display "x")
+  (write-special (make-object string-snip% " in: "))
+  (display "y")
+  (flush-output))
+
+|#
+
+(module io mzscheme
+  (require "drscheme-test-util.ss"
+           (lib "gui.ss" "tests" "utils")
+           (lib "class.ss")
+           (lib "list.ss")
+           (lib "pretty.ss")
+           (lib "mred.ss" "mred")
+           (lib "framework.ss" "framework")
+           (lib "text-string-style-desc.ss" "mrlib")
+           (prefix fw: (lib "framework.ss" "framework")))
+  
+  (provide run-test)
+  
+  (define (output-err-port-checking)
+    (define (check-output expression expected)
+      (begin
+        (clear-definitions drs-frame)
+        (type-in-definitions drs-frame expression)
+        (do-execute drs-frame)
+        (let* ([text (send drs-frame get-interactions-text)]
+               [got (get-string/style-desc text (send text paragraph-start-position 2))])
+          (unless (andmap (λ (exp got)
+                            (and (string=? (car exp) (car got))
+                                 (or (equal? (cadr exp) (cadr got))
+                                     (and (procedure? (cadr exp))
+                                          ((cadr exp) (cadr got))))))
+                          expected 
+                          got)
+            (error 'io.ss "expected ~s, got ~s for ~s" expected got expression)))))
+    
+    (define (output-style x) (equal? (list-ref x 9) '(150 0 150)))
+    (define (error-style x) (equal? (list-ref x 9) '(255 0 0)))
+    
+    (define prompt '("\n> " default-color))
+    
+    (check-output "(display 1)" (list (list "1" output-style) prompt))
+    (check-output "(display 1 (current-output-port))" (list (list "1" output-style) prompt))
+    
+    (check-output "(display 1 (current-error-port))" (list (list "1" error-style) prompt))
+    (check-output "(display 1) (display 1 (current-error-port))" 
+                  (list (list "1" output-style)
+                        (list "1" error-style)
+                        prompt))
+    (check-output "(display 1 (current-error-port)) (display 1)" 
+                  (list (list "1" error-style)
+                        (list "1" output-style)
+                        prompt))
+    (check-output "(display 1) (display 1 (current-error-port)) (display 1)" 
+                  (list (list "1" output-style)
+                        (list "1" error-style)
+                        (list "1" output-style)
+                        prompt))
+    (check-output "(display 1 (current-error-port)) (display 1) (display 1 (current-error-port))"
+                  (list (list "1" error-style)
+                        (list "1" output-style)
+                        (list "1" error-style)
+                        prompt))
+    (check-output "(let ([s (make-semaphore)]) (thread (lambda () (display 1) (semaphore-post s))) (semaphore-wait s))"
+                  (list (list "1" output-style)
+                        prompt))
+    (check-output
+     "(let ([s (make-semaphore)]) (thread (lambda () (display 1 (current-output-port)) (semaphore-post s))) (semaphore-wait s))" 
+     (list (list "1" output-style)
+           prompt))
+    (check-output
+     "(let ([s (make-semaphore)]) (thread (lambda () (display 1 (current-error-port)) (semaphore-post s))) (semaphore-wait s))"
+     (list (list "1" error-style)
+           prompt)))
+  
+  (define (long-io/execute-test)
+    (let ([string-port (open-output-string)])
+      (pretty-print
+       (let f ([n 7] [p null]) (if (= n 0) p (list (f (- n 1) (cons 'l p)) (f (- n 1)  (cons 'r p)))))
+       string-port)
+      (clear-definitions drs-frame)
+      (type-in-definitions
+       drs-frame
+       "(let f ([n 7] [p null]) (if (= n 0) p (list (f (- n 1) (cons 'l p)) (f (- n 1)  (cons 'r p)))))")
+      (do-execute drs-frame)
+      (let ([got-output (fetch-output drs-frame)])
+        (clear-definitions drs-frame)
+        (do-execute drs-frame)
+        (unless (equal? "" (fetch-output drs-frame))
+          (error 'io.ss "failed long io / execute test (extra io)"))
+        (unless (whitespace-string=?
+                 (get-output-string string-port)
+                 got-output)
+          (error 'io.ss "failed long io / execute test (output doesn't match)")))))
+  
+  
+  (define (reading-test)
+    (define (do-input-test program input expected-transcript)
+      (do-execute drs-frame)
+      (type-in-interactions drs-frame program)
+      (let ([before-newline-pos (send interactions-text last-position)])
+        (type-in-interactions drs-frame (string #\newline))
+        (wait (λ ()
+                ;; the focus moves to the input box, so wait for that.
+                (send interactions-text get-focus-snip))
+              "input box didn't appear")
+        
+        (type-string input)
+        (wait-for-computation drs-frame)
+        (let ([got-value
+               (fetch-output drs-frame 
+                             (send interactions-text paragraph-start-position 3) ;; start after test expression
+                             (send interactions-text paragraph-end-position
+                                   (- (send interactions-text last-paragraph) 1)))])
+          (unless (equal? got-value expected-transcript)
+            (printf "FAILED: expected: ~s~n             got: ~s~n         program: ~s~n           input: ~s~n"
+                    expected-transcript got-value program input)))))
+    
+    (clear-definitions drs-frame)
+    (do-input-test "(read-char)" "a\n" "a\n#\\a")
+    (do-input-test "(read-char)" "λ\n" "λ\n#\\λ")
+    (do-input-test "(read-line)" "abcdef\n" "abcdef\n\"abcdef\"") 
+    (do-input-test "(list (read-char) (read-line))" "abcdef\n" "abcdef\n(#\\a \"bcdef\")")
+
+    (do-input-test "(read)" "a\n" "a\na")
+    (do-input-test "(list (read) (read))" "a a\n" "a a\n(a a)")
+    (do-input-test "(list (read-char) (read))" "aa\n" "aa\n(#\\a a)")
+    
+    (do-input-test "(begin (read-char) (sleep 1) (read-char))" "ab\ncd\n" "ab\ncd\n#\\b")
+    (do-input-test "(list (read) (sleep 1) (read) (read))" "a b\nc d\n" "a b\nc d\n(a #<void> b c)")
+    
+    (do-input-test "(begin (display 1) (read))" "2\n" "12\n2\n") ;; why an extra newline?!
+    
+    (do-input-test "(read-line)" "\n" "\n\"\"")
+    (do-input-test "(read-char)" "\n" "\n#\\newline")
+
+    (do-input-test "(list (read) (printf \"1~n\") (read) (printf \"3~n\"))"
+                   "0 2\n"
+                   "0 2\n1\n3\n(0 #<void> 2 #<void>)")
+    
+    (do-input-test "(write (read))"
+                   "()\n"
+                   "()\n()")
+    
+    (do-input-test "(begin (write (read)) (write (read)))"
+                   "(1)\n(2)\n"
+                   "(1)\n(1)(2)\n(2)")
+    
+    (do-input-test 
+     (string-append "(let ([b (read-byte)][bs0 (bytes 0)][bs1 (bytes 1)][bs2 (bytes 2)])"
+                    "(read-bytes-avail!* bs0)"
+                    "(read-bytes-avail!* bs1)"
+                    "(read-bytes-avail!* bs2)"
+                    "(list b bs0 bs1 bs2))\n")
+     "ab\n"
+     "ab\n(97 #\"b\" #\"\\n\" #\"\\2\")"))
+  
+  (define drs-frame (wait-for-drscheme-frame))
+  (define interactions-text (send drs-frame get-interactions-text))
+  (set-language-level! (list "PLT" (regexp "Textual")))
+  
+  (define (run-test)
+    ;(long-io/execute-test)
+    ;(output-err-port-checking)
+    (reading-test)
+    ))
diff --git a/collects/tests/drscheme/language-test.ss b/collects/tests/drscheme/language-test.ss
new file mode 100644
index 0000000000..1b66e8d16d
--- /dev/null
+++ b/collects/tests/drscheme/language-test.ss
@@ -0,0 +1,1211 @@
+#|
+
+Make sure there are tests that cover these parameters:
+
+ (read-case-sensitive #f) 
+ (read-square-bracket-as-paren #f)  -- test: (symbol? '[])
+ (read-curly-brace-as-paren #f)
+ (print-vector-length #f)
+
+the settings above should match r5rs
+
+|#
+
+(module language-test mzscheme
+  (require "drscheme-test-util.ss"
+           (lib "gui.ss" "tests" "utils")
+           (lib "class.ss")
+           (lib "list.ss")
+           (lib "mred.ss" "mred")
+           (lib "framework.ss" "framework")
+           (prefix fw: (lib "framework.ss" "framework")))
+  
+  (provide run-test)
+
+  (define language (make-parameter "<<not a language>>"))
+  
+  ;; set-language : boolean -> void
+  (define (set-language close-dialog?)
+    (set-language-level! (language) close-dialog?))
+
+  
+                            
+                         ;; 
+                          ; 
+                          ; 
+;;; ;   ; ;;;   ;;;    ;;;; 
+ ; ; ;   ;     ;   ;  ;   ; 
+ ; ; ;   ;     ;;;;;  ;   ; 
+ ; ; ;   ;     ;      ;   ; 
+ ; ; ;   ;     ;   ;  ;   ; 
+;; ; ;; ;;;;    ;;;    ;;; ;
+  
+
+  (define (mred)
+    (parameterize ([language (list "PLT" (regexp "Graphical"))])
+      (check-top-of-repl)
+
+      (generic-settings #f)
+      (generic-output #t #t #t)
+      
+      (test-hash-bang)
+      (test-error-after-definition)
+      
+      (prepare-for-test-expression)
+
+      (test-expression "'|.|" "|.|")
+      
+      (test-expression '("(equal? (list " image ") (list " image "))") 
+                       "#f")
+      (test-expression "(define x 1)(define x 2)" "")
+      
+      (test-expression 'xml "(a () (b ()))")
+
+      (test-expression "(define-struct spider (legs))(make-spider 4)" "#<struct:spider>")
+      
+      (test-expression "(sqrt -1)" "0+1i")
+
+      (test-expression "class" (regexp "class: bad syntax in: class"))
+      (test-expression "shared" "{bug09.gif} reference to undefined identifier: shared")
+      
+      (test-expression "(define (. x y) (* x y))" #rx"read: illegal use of \"\\.\"")
+      (test-expression "'(1 . 2)" "(1 . 2)")
+      
+      (test-expression "(define (f define) 1)" "")
+      (test-expression "(define (f car) 1)" "")
+      (test-expression "(define (f empty) 1)" "")
+      
+      (test-expression "call/cc" "#<primitive:call-with-current-continuation>")
+      
+      (test-expression "(error 'a \"~a\" 1)" "{bug09.gif} a: 1")
+      (test-expression "(error \"a\" \"a\")" "{bug09.gif} a \"a\"")
+      
+      (test-expression "(time 1)" 
+                       #rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1")
+            
+      (test-expression "true" "{bug09.gif} reference to undefined identifier: true")
+      (test-expression "mred^" "{bug09.gif} reference to undefined identifier: mred^")
+      (test-expression "(eq? 'a 'A)" "#f")
+      (test-expression "(set! x 1)" "{bug09.gif} set!: cannot set undefined identifier: x")
+      (test-expression "(cond [(= 1 2) 3])" "")
+      (test-expression "(cons 1 2)" "(1 . 2)")
+      (test-expression "'(1)" "(1)")
+      (test-expression "(define shrd (box 1)) (list shrd shrd)"
+                       "(#&1 #&1)")
+      (test-expression 
+       "(local ((define x x)) 1)"
+       #rx"define: not allowed in an expression context")
+      (test-expression "(letrec ([x x]) 1)" "1")
+      (test-expression "(if 1 1 1)" "1")
+      (test-expression "(+ 1)" "1")
+      
+      (test-expression "(let ([f (lambda (x) x)]) f)" "#<procedure:f>")
+      (test-expression ",1" "unquote: not in quasiquote in: (unquote 1)")
+      
+      (test-expression "1.0" "1.0")
+      (test-expression "#i1.0" "1.0")
+      (test-expression "4/3" "{number 4/3 \"1 1/3\" mixed}")
+      (test-expression "1/3" "{number 1/3 \"1/3\" mixed}")
+      (test-expression "-4/3" "{number -4/3 \"-1 1/3\" mixed}")
+      (test-expression "-1/3" "{number -1/3 \"-1/3\" mixed}")
+      (test-expression "3/2" "{number 3/2 \"1 1/2\" mixed}")
+      (test-expression "1/2" "{number 1/2 \"1/2\" mixed}")
+      (test-expression "-1/2" "{number -1/2 \"-1/2\" mixed}")
+      (test-expression "-3/2" "{number -3/2 \"-1 1/2\" mixed}")
+      (test-expression "+1/3i" "0+1/3i")
+      (test-expression "+1/2i" "0+1/2i")
+      (test-expression "779625/32258" "{number 779625/32258 \"24 5433/32258\" mixed}")
+      (test-expression "(exact? 1.5)" "#f")
+      
+      (test-expression "(list 1)" "(1)")
+      (test-expression "(car (list))" "car: expects argument of type <pair>; given ()")
+
+      (test-expression "argv" "#0()")))
+
+
+                                                        
+                            ;;                          
+                             ;                          
+                             ;                          
+;;; ;   ;;;;;   ;;;    ;;;   ; ;;    ;;;  ;;; ;    ;;;  
+ ; ; ;  ;  ;   ;   ;  ;   ;  ;;  ;  ;   ;  ; ; ;  ;   ; 
+ ; ; ;    ;     ;;;   ;      ;   ;  ;;;;;  ; ; ;  ;;;;; 
+ ; ; ;   ;         ;  ;      ;   ;  ;      ; ; ;  ;     
+ ; ; ;  ;   ;  ;   ;  ;   ;  ;   ;  ;   ;  ; ; ;  ;   ; 
+;; ; ;; ;;;;;   ;;;    ;;;  ;;; ;;;  ;;;  ;; ; ;;  ;;;  
+                                                        
+                                                        
+                                                        
+
+  
+  (define (mzscheme)
+    (parameterize ([language (list "PLT" (regexp "Textual"))])
+
+      (check-top-of-repl)
+
+      (generic-settings #f)
+      (generic-output #t #t #t)
+      
+      (test-hash-bang)
+      (test-error-after-definition)
+      
+      (prepare-for-test-expression)
+      
+      (test-expression "'|.|" "|.|")
+      (test-expression '("(equal? (list " image ") (list " image "))") 
+                       "#f")
+      (test-expression "(define x 1)(define x 2)" "")
+      
+      (test-expression "(define-struct spider (legs))(make-spider 4)" "#<struct:spider>")
+      
+      (test-expression "(sqrt -1)" "0+1i")
+
+      (test-expression "class" "{bug09.gif} reference to undefined identifier: class")
+      (test-expression "shared" "{bug09.gif} reference to undefined identifier: shared")
+      
+      (test-expression "(define (. x y) (* x y))" #rx"read: illegal use of \"\\.\"")
+      (test-expression "'(1 . 2)" "(1 . 2)")
+      
+      (test-expression "(define (f define) 1)" "")
+      (test-expression "(define (f car) 1)" "")
+      (test-expression "(define (f empty) 1)" "")
+      
+      (test-expression "call/cc" "#<primitive:call-with-current-continuation>")
+      
+      (test-expression "(error 'a \"~a\" 1)" "{bug09.gif} a: 1")
+      (test-expression "(error \"a\" \"a\")" "{bug09.gif} a \"a\"")
+      
+      (test-expression "(time 1)" 
+                       #rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1")
+      
+      (test-expression "true" "{bug09.gif} reference to undefined identifier: true")
+      (test-expression "mred^" "{bug09.gif} reference to undefined identifier: mred^")
+      (test-expression "(eq? 'a 'A)" "#f")
+      (test-expression "(set! x 1)" "{bug09.gif} set!: cannot set undefined identifier: x")
+      (test-expression "(cond [(= 1 2) 3])" "")
+      (test-expression "(cons 1 2)" "(1 . 2)")
+      (test-expression "'(1)" "(1)")
+      (test-expression "(define shrd (box 1)) (list shrd shrd)"
+                       "(#&1 #&1)")
+      (test-expression 
+       "(local ((define x x)) 1)"
+       #rx"define: not allowed in an expression context")
+      (test-expression "(letrec ([x x]) 1)" "1")
+      (test-expression "(if 1 1 1)" "1")
+      (test-expression "(+ 1)" "1")
+
+      (test-expression "1.0" "1.0")
+      (test-expression "#i1.0" "1.0")
+      (test-expression "4/3" "{number 4/3 \"1 1/3\" mixed}")
+      (test-expression "1/3" "{number 1/3 \"1/3\" mixed}")
+      (test-expression "-4/3" "{number -4/3 \"-1 1/3\" mixed}")
+      (test-expression "-1/3" "{number -1/3 \"-1/3\" mixed}")
+      (test-expression "3/2" "{number 3/2 \"1 1/2\" mixed}")
+      (test-expression "1/2" "{number 1/2 \"1/2\" mixed}")
+      (test-expression "-1/2" "{number -1/2 \"-1/2\" mixed}")
+      (test-expression "-3/2" "{number -3/2 \"-1 1/2\" mixed}")
+      (test-expression "+1/3i" "0+1/3i")
+      (test-expression "+1/2i" "0+1/2i")
+      (test-expression "779625/32258" "{number 779625/32258 \"24 5433/32258\" mixed}")
+      (test-expression "(exact? 1.5)" "#f")
+
+      (test-expression "(let ([f (lambda (x) x)]) f)" "#<procedure:f>")
+      (test-expression ",1" "unquote: not in quasiquote in: (unquote 1)")
+
+      (test-expression "(list 1)" "(1)")
+      (test-expression "(car (list))" "car: expects argument of type <pair>; given ()")
+      
+      (test-expression "argv" "#0()")))
+
+  
+  
+;                           
+;                           
+;                           
+;        ;;;;;;             
+;        ;                  
+;        ;                  
+;   ; ;  ;       ; ;   ;;;  
+;   ;;   ;;;;    ;;   ;     
+;   ;        ;   ;    ;;    
+;   ;         ;  ;     ;;   
+;   ;         ;  ;       ;  
+;   ;    ;   ;   ;       ;  
+;   ;     ;;;    ;    ;;;   
+;                           
+;                           
+;                           
+
+  
+  (define (r5rs)
+    (parameterize ([language (list (regexp "R5RS"))])
+
+      (check-top-of-repl)
+
+      (generic-settings #f)
+      (generic-output #t #t #t)
+      
+      (test-hash-bang)
+      (test-error-after-definition)
+      
+      (prepare-for-test-expression)
+      
+      (test-expression "'|.|" "|.|")
+      (test-expression '("(equal? (list " image ") (list " image "))") 
+                       "#f")
+      (test-expression "(define x 1)(define x 2)" "")
+      
+      (test-expression "(define-struct spider (legs))(make-spider 4)" "#<struct:spider>")
+      
+      (test-expression "(sqrt -1)" "0+1i")
+
+      (test-expression "class" "{bug09.gif} reference to undefined identifier: class")
+      (test-expression "shared" "{bug09.gif} reference to undefined identifier: shared")
+      
+      (test-expression "(define (. x y) (* x y))" #rx"read: illegal use of \"\\.\"")
+      (test-expression "'(1 . 2)" "(1 . 2)")
+      
+      (test-expression "(define (f define) 1)" "")
+      (test-expression "(define (f car) 1)" "")
+      (test-expression "(define (f empty) 1)" "")
+      
+      (test-expression "call/cc" "#<primitive:call-with-current-continuation>")
+      
+      (test-expression "(error 'a \"~a\" 1)" "{bug09.gif} a: 1")
+      (test-expression "(error \"a\" \"a\")" "{bug09.gif} a \"a\"")
+      
+      (test-expression "(time 1)" 
+                       #rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1")
+      
+      (test-expression "true" "{bug09.gif} reference to undefined identifier: true")
+      (test-expression "mred^" "{bug09.gif} reference to undefined identifier: mred^")
+      (test-expression "(eq? 'a 'A)" "#t")
+      (test-expression "(set! x 1)" "{bug09.gif} set!: cannot set undefined identifier: x")
+      (test-expression "(cond [(= 1 2) 3])" "")
+      (test-expression "(cons 1 2)" "(1 . 2)")
+      (test-expression "'(1)" "(1)")
+      (test-expression "(define shrd (box 1)) (list shrd shrd)"
+                       "(#&1 #&1)")
+      (test-expression 
+       "(local ((define x x)) 1)"
+       #rx"define: not allowed in an expression context")
+      (test-expression "(letrec ([x x]) 1)" "1")
+      (test-expression "(if 1 1 1)" "1")
+      (test-expression "(+ 1)" "1")
+
+      (test-expression "1.0" "1.0")
+      (test-expression "#i1.0" "1.0")
+      (test-expression "4/3" "{number 4/3 \"1 1/3\" mixed}")
+      (test-expression "1/3" "{number 1/3 \"1/3\" mixed}")
+      (test-expression "-4/3" "{number -4/3 \"-1 1/3\" mixed}")
+      (test-expression "-1/3" "{number -1/3 \"-1/3\" mixed}")
+      (test-expression "3/2" "{number 3/2 \"1 1/2\" mixed}")
+      (test-expression "1/2" "{number 1/2 \"1/2\" mixed}")
+      (test-expression "-1/2" "{number -1/2 \"-1/2\" mixed}")
+      (test-expression "-3/2" "{number -3/2 \"-1 1/2\" mixed}")
+      (test-expression "+1/3i" "0+1/3i")
+      (test-expression "+1/2i" "0+1/2i")
+      (test-expression "779625/32258" "{number 779625/32258 \"24 5433/32258\" mixed}")
+      (test-expression "(exact? 1.5)" "#f")
+
+      (test-expression "(let ([f (lambda (x) x)]) f)" "#<procedure:f>")
+      (test-expression ",1" "unquote: not in quasiquote in: (unquote 1)")
+
+      (test-expression "(list 1)" "(1)")
+      (test-expression "(car (list))" "car: expects argument of type <pair>; given ()")
+
+      (test-expression "argv" "#0()")))
+                                                        
+;;                      ;                               
+ ;                                                      
+ ;                                                      
+ ;;;;    ;;;    ;;; ; ;;;   ; ;;;  ; ;;;    ;;;   ; ;;; 
+ ;   ;  ;   ;  ;   ;    ;    ;;  ;  ;;  ;  ;   ;   ;    
+ ;   ;  ;;;;;  ;   ;    ;    ;   ;  ;   ;  ;;;;;   ;    
+ ;   ;  ;      ;   ;    ;    ;   ;  ;   ;  ;       ;    
+ ;   ;  ;   ;  ;   ;    ;    ;   ;  ;   ;  ;   ;   ;    
+; ;;;    ;;;    ;;;;  ;;;;; ;;;  ;;;;;  ;;  ;;;   ;;;;  
+                   ;                                    
+                   ;                                    
+                ;;;                                     
+
+  
+  (define (beginner)
+    (parameterize ([language (list "How to Design Programs" "Beginning Student")])
+      (check-top-of-repl)
+
+      (generic-settings #t)
+      (generic-output #f #f #f)
+      (teaching-language-fraction-output)
+      
+      (test-hash-bang)
+      (test-error-after-definition)
+      
+      (prepare-for-test-expression)
+
+      (test-expression "'|.|" "'|.|")
+      (test-expression '("(equal? (list " image ") (list " image "))") 
+                       "true")
+      
+      (test-expression "(define x 1)(define x 2)"
+                       "x: this name was defined previously and cannot be re-defined"
+                       "define: cannot redefine name: x")
+      
+      (test-expression "(define-struct spider (legs))(make-spider 4)" 
+                       "(make-spider 4)"
+                       "define-struct: cannot redefine name: spider")
+      
+      (test-expression "(sqrt -1)" "0+1i")
+
+      (test-expression "class" 
+                       "class: name is not defined, not an argument, and not a primitive name"
+                       "reference to undefined identifier: class")
+      (test-expression "shared"
+                       "shared: name is not defined, not an argument, and not a primitive name"
+                       "reference to undefined identifier: shared")
+
+      (test-expression "(define (. x y) (* x y))" "read: illegal use of \".\"")
+      (test-expression "'(1 . 2)" "read: illegal use of \".\"")
+      
+      (test-expression "call/cc"
+                       "call/cc: name is not defined, not an argument, and not a primitive name"
+                       "reference to undefined identifier: call/cc")
+      
+      (test-expression "(error 'a \"~a\" 1)"
+                       "procedure error: expects 2 arguments, given 3: 'a \"~a\" 1")
+      (test-expression "(error \"a\" \"a\")"
+                       "error: expected a symbol and a string, got \"a\" and \"a\"")
+      
+      (test-expression "(time 1)"
+                       "time: name is not defined, not an argument, and not a primitive name"
+                       "reference to undefined identifier: time")
+      
+      (test-expression "true" "true")
+      (test-expression "mred^" 
+                       "mred^: name is not defined, not an argument, and not a primitive name"
+                       "reference to undefined identifier: mred^")
+      (test-expression "(eq? 'a 'A)" "false")
+      (test-expression "(set! x 1)"
+                       "set!: name is not defined, not an argument, and not a primitive name"
+                       "reference to undefined identifier: set!")
+      (test-expression "(cond [(= 1 2) 3])" "cond: all question results were false")
+      (test-expression "(cons 1 2)" "cons: second argument must be of type <list>, given 1 and 2")
+      (test-expression "'(1)" "quote: expected a name after a ', found something else")
+      (test-expression "(define shrd (list 1)) (list shrd shrd)"
+                       "(cons (cons 1 empty) (cons (cons 1 empty) empty))"
+                       "define: cannot redefine name: shrd")
+      (test-expression "(local ((define x x)) 1)"
+                       "local: name is not defined, not an argument, and not a primitive name"
+                       "function call: expected a defined name or a primitive operation name after an open parenthesis, but found something else")
+      (test-expression "(letrec ([x x]) 1)"
+                       "letrec: name is not defined, not an argument, and not a primitive name"
+                       "function call: expected a defined name or a primitive operation name after an open parenthesis, but found something else")
+      (test-expression "(if 1 1 1)" "if: question result is not true or false: 1")
+      (test-expression "(+ 1)" "procedure +: expects at least 2 arguments, given 1: 1")
+      
+      (test-expression "1.0" "1")
+      (test-expression "#i1.0" "#i1.0")
+      (test-expression "4/3" "{number 4/3 \"1.3\" decimal}")
+      (test-expression "1/3" "{number 1/3 \"0.3\" decimal}")
+      (test-expression "-4/3" "{number -4/3 \"-1.3\" decimal}")
+      (test-expression "-1/3" "{number -1/3 \"-0.3\" decimal}")
+      (test-expression "3/2" "{number 3/2 \"1.5\" decimal}")
+      (test-expression "1/2" "{number 1/2 \"0.5\" decimal}")
+      (test-expression "-1/2" "{number -1/2 \"-0.5\" decimal}")
+      (test-expression "-3/2" "{number -3/2 \"-1.5\" decimal}")
+      (test-expression "+1/3i" "0+1/3i")
+      (test-expression "+1/2i" "0+0.5i")
+      (test-expression "779625/32258" "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}")
+      (test-expression "(exact? 1.5)" "true")
+      
+      (test-expression "(let ([f (lambda (x) x)]) f)"
+                       "let: name is not defined, not an argument, and not a primitive name"
+                       "function call: expected a defined name or a primitive operation name after an open parenthesis, but found something else")
+      (test-expression ",1"
+                       "read: illegal use of comma")
+
+      (test-expression "(list 1)" "(cons 1 empty)")
+      (test-expression "(car (list))" "car: expects argument of type <pair>; given empty")
+
+      (test-expression "argv" 
+                       "argv: name is not defined, not an argument, and not a primitive name"
+                       "reference to undefined identifier: argv")))
+  
+
+                                                               
+;;                         ;       ;;                          
+ ;                        ;         ;                          
+ ;                        ;         ;                          
+ ;;;;    ;;;    ;;; ;    ;   ;;;;   ;;;;   ; ;;;   ;;;  ;;; ;;;
+ ;   ;  ;   ;  ;   ;     ;       ;  ;   ;   ;     ;   ;  ;   ; 
+ ;   ;  ;;;;;  ;   ;    ;     ;;;;  ;   ;   ;     ;;;;;  ;   ; 
+ ;   ;  ;      ;   ;    ;    ;   ;  ;   ;   ;     ;       ; ;  
+ ;   ;  ;   ;  ;   ;   ;     ;   ;  ;   ;   ;     ;   ;   ;;;  
+; ;;;    ;;;    ;;;;   ;      ;;; ;; ;;;   ;;;;    ;;;     ;   
+                   ;  ;                                        
+                   ;                                           
+                ;;;                                            
+
+
+  (define (beginner/abbrev)
+    (parameterize ([language (list "How to Design Programs" 
+                                   "Beginning Student with List Abbreviations")])
+      (check-top-of-repl)
+  
+      (generic-settings #t)
+      (generic-output #t #f #f)
+      (teaching-language-fraction-output)
+      
+      (test-hash-bang)
+      
+      (test-error-after-definition)
+      
+      (prepare-for-test-expression)
+      
+      (test-expression "'|.|" "'|.|")      
+      (test-expression '("(equal? (list " image ") (list " image "))") 
+                       "true")
+      
+      (test-expression "(define x 1)(define x 2)"
+                       "x: this name was defined previously and cannot be re-defined"
+                       "define: cannot redefine name: x")
+      
+      (test-expression "(define-struct spider (legs))(make-spider 4)"
+                       "(make-spider 4)"
+                       "define-struct: cannot redefine name: spider")
+      
+      (test-expression "(sqrt -1)" "0+1i")
+
+      (test-expression "class"
+                       "class: name is not defined, not an argument, and not a primitive name"
+                       "reference to undefined identifier: class")
+      (test-expression "shared"
+                       "shared: name is not defined, not an argument, and not a primitive name"
+                       "reference to undefined identifier: shared")
+
+      (test-expression "(define (. x y) (* x y))" "read: illegal use of \".\"")
+      (test-expression "'(1 . 2)" "read: illegal use of \".\"")
+      
+      (test-expression "call/cc"
+                       "call/cc: name is not defined, not an argument, and not a primitive name"
+                       "reference to undefined identifier: call/cc")
+      
+      (test-expression "(error 'a \"~a\" 1)"
+                       "procedure error: expects 2 arguments, given 3: 'a \"~a\" 1")
+      (test-expression "(error \"a\" \"a\")"
+                       "error: expected a symbol and a string, got \"a\" and \"a\"")
+      
+      (test-expression "(time 1)"
+		         "time: name is not defined, not an argument, and not a primitive name"
+		         "reference to undefined identifier: time")
+      
+      (test-expression "true" "true")
+      (test-expression "mred^" 
+                       "mred^: name is not defined, not an argument, and not a primitive name"
+                       "reference to undefined identifier: mred^")
+      (test-expression "(eq? 'a 'A)" "false")
+      (test-expression "(set! x 1)"
+                       "set!: name is not defined, not an argument, and not a primitive name"
+                       "reference to undefined identifier: set!")
+      (test-expression "(cond [(= 1 2) 3])" "cond: all question results were false")
+      (test-expression "(cons 1 2)" "cons: second argument must be of type <list>, given 1 and 2")
+      (test-expression "'(1)" "(list 1)")
+      (test-expression "(define shrd (list 1)) (list shrd shrd)"
+                       "(list (list 1) (list 1))"
+                       "define: cannot redefine name: shrd")
+      (test-expression "(local ((define x x)) 1)"
+                       "local: name is not defined, not an argument, and not a primitive name"
+                       "function call: expected a defined name or a primitive operation name after an open parenthesis, but found something else")
+      (test-expression "(letrec ([x x]) 1)"
+                       "letrec: name is not defined, not an argument, and not a primitive name"
+                       "function call: expected a defined name or a primitive operation name after an open parenthesis, but found something else")
+      (test-expression "(if 1 1 1)" "if: question result is not true or false: 1")
+      (test-expression "(+ 1)" "procedure +: expects at least 2 arguments, given 1: 1")
+      
+      (test-expression "1.0" "1")
+      (test-expression "#i1.0" "#i1.0")
+      (test-expression "4/3" "{number 4/3 \"1.3\" decimal}")
+      (test-expression "1/3" "{number 1/3 \"0.3\" decimal}")
+      (test-expression "-4/3" "{number -4/3 \"-1.3\" decimal}")
+      (test-expression "-1/3" "{number -1/3 \"-0.3\" decimal}")
+      (test-expression "3/2" "{number 3/2 \"1.5\" decimal}")
+      (test-expression "1/2" "{number 1/2 \"0.5\" decimal}")
+      (test-expression "-1/2" "{number -1/2 \"-0.5\" decimal}")
+      (test-expression "-3/2" "{number -3/2 \"-1.5\" decimal}")
+      (test-expression "+1/3i" "0+1/3i")
+      (test-expression "+1/2i" "0+0.5i")
+      (test-expression "779625/32258" "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}")
+      (test-expression "(exact? 1.5)" "true")
+      
+      (test-expression "(let ([f (lambda (x) x)]) f)" 
+                       "let: name is not defined, not an argument, and not a primitive name"
+                       "function call: expected a defined name or a primitive operation name after an open parenthesis, but found something else")
+      (test-expression ",1"
+                       "unquote: misuse of a comma or `unquote', not under a quasiquoting backquote")
+
+      (test-expression "(list 1)" "(list 1)")
+      (test-expression "(car (list))" "car: expects argument of type <pair>; given empty")
+
+      (test-expression "argv" 
+                       "argv: name is not defined, not an argument, and not a primitive name"
+                       "reference to undefined identifier: argv")))
+
+
+                                                                                    
+   ;                                                 ;;    ;                        
+                ;                                     ;                 ;           
+                ;                                     ;                 ;           
+ ;;;   ; ;;;   ;;;;;   ;;;   ; ;;; ;;; ;    ;;;    ;;;;  ;;;    ;;;;   ;;;;;   ;;;  
+   ;    ;;  ;   ;     ;   ;   ;     ; ; ;  ;   ;  ;   ;    ;        ;   ;     ;   ; 
+   ;    ;   ;   ;     ;;;;;   ;     ; ; ;  ;;;;;  ;   ;    ;     ;;;;   ;     ;;;;; 
+   ;    ;   ;   ;     ;       ;     ; ; ;  ;      ;   ;    ;    ;   ;   ;     ;     
+   ;    ;   ;   ;   ; ;   ;   ;     ; ; ;  ;   ;  ;   ;    ;    ;   ;   ;   ; ;   ; 
+ ;;;;; ;;;  ;;   ;;;   ;;;   ;;;;  ;; ; ;;  ;;;    ;;; ; ;;;;;   ;;; ;   ;;;   ;;;  
+                                                                                    
+                                                                                    
+                                                                                    
+
+
+  (define (intermediate)
+    (parameterize ([language (list "How to Design Programs" "Intermediate Student")])
+      (check-top-of-repl)
+
+      (generic-settings #t)
+      (generic-output #t #f #f)
+      (teaching-language-fraction-output)
+      
+      (test-hash-bang)
+      (test-error-after-definition)
+      
+      (prepare-for-test-expression)
+      
+      (test-expression "'|.|" "'|.|")
+      (test-expression '("(equal? (list " image ") (list " image "))") 
+                       "true")
+      
+      (test-expression "(define x 1)(define x 2)"
+                       "x: this name was defined previously and cannot be re-defined"
+                       "define: cannot redefine name: x")
+      
+      (test-expression "(define-struct spider (legs))(make-spider 4)"
+                       "(make-spider 4)"
+                       "define-struct: cannot redefine name: spider")
+      
+      (test-expression "(sqrt -1)" "0+1i")
+
+      (test-expression "class" 
+                       "class: name is not defined, not an argument, and not a primitive name"
+                       "reference to undefined identifier: class")
+      (test-expression "shared"
+                       "shared: name is not defined, not an argument, and not a primitive name"
+                       "reference to undefined identifier: shared")
+      
+      (test-expression "(define (. x y) (* x y))" "read: illegal use of \".\"")
+      (test-expression "'(1 . 2)" "read: illegal use of \".\"")
+      
+      (test-expression "call/cc"
+                       "call/cc: name is not defined, not an argument, and not a primitive name"
+                       "reference to undefined identifier: call/cc")
+      
+      (test-expression "(error 'a \"~a\" 1)"
+                       "procedure error: expects 2 arguments, given 3: 'a \"~a\" 1")
+      (test-expression "(error \"a\" \"a\")"
+                       "error: expected a symbol and a string, got \"a\" and \"a\"")
+      
+      (test-expression "(time 1)" 
+                       #rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1")
+            
+      (test-expression "true" "true")
+      (test-expression "mred^" 
+                       "mred^: name is not defined, not an argument, and not a primitive name"
+                       "reference to undefined identifier: mred^")
+      (test-expression "(eq? 'a 'A)" "false")
+      (test-expression "(set! x 1)"
+                       "set!: name is not defined, not an argument, and not a primitive name"
+                       "reference to undefined identifier: set!")
+      (test-expression "(cond [(= 1 2) 3])" "cond: all question results were false")
+      (test-expression "(cons 1 2)" "cons: second argument must be of type <list>, given 1 and 2")
+      (test-expression "'(1)" "(list 1)")
+      (test-expression "(define shrd (list 1)) (list shrd shrd)"
+                       "(list (list 1) (list 1))"
+                       "define: cannot redefine name: shrd")
+      (test-expression "(local ((define x x)) 1)" "local variable used before its definition: x")
+      (test-expression "(letrec ([x x]) 1)" "local variable used before its definition: x")
+      (test-expression "(if 1 1 1)" "if: question result is not true or false: 1")
+      (test-expression "(+ 1)" "procedure +: expects at least 2 arguments, given 1: 1")
+      
+      (test-expression "1.0" "1")
+      (test-expression "#i1.0" "#i1.0")
+      (test-expression "4/3" "{number 4/3 \"1.3\" decimal}")
+      (test-expression "1/3" "{number 1/3 \"0.3\" decimal}")
+      (test-expression "-4/3" "{number -4/3 \"-1.3\" decimal}")
+      (test-expression "-1/3" "{number -1/3 \"-0.3\" decimal}")
+      (test-expression "3/2" "{number 3/2 \"1.5\" decimal}")
+      (test-expression "1/2" "{number 1/2 \"0.5\" decimal}")
+      (test-expression "-1/2" "{number -1/2 \"-0.5\" decimal}")
+      (test-expression "-3/2" "{number -3/2 \"-1.5\" decimal}")
+      (test-expression "+1/3i" "0+1/3i")
+      (test-expression "+1/2i" "0+0.5i")
+      (test-expression "779625/32258" "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}")
+      (test-expression "(exact? 1.5)" "true")
+      
+      (test-expression "(let ([f (lambda (x) x)]) f)" "function:f")
+      (test-expression ",1"
+                       "unquote: misuse of a comma or `unquote', not under a quasiquoting backquote")
+
+      (test-expression "(list 1)" "(list 1)")
+      (test-expression "(car (list))" "car: expects argument of type <pair>; given empty")
+      (test-expression "argv" 
+                       "argv: name is not defined, not an argument, and not a primitive name"
+                       "reference to undefined identifier: argv")))
+
+
+                                                                      
+   ;                       ; ;;;                 ;;         ;;        
+                ;         ;    ;                  ;          ;        
+                ;         ;    ;                  ;          ;        
+ ;;;   ; ;;;   ;;;;;     ;     ;    ;;;;  ;;; ;   ;;;;    ;;;;  ;;;;  
+   ;    ;;  ;   ;        ;     ;        ;  ; ; ;  ;   ;  ;   ;      ; 
+   ;    ;   ;   ;       ;      ;     ;;;;  ; ; ;  ;   ;  ;   ;   ;;;; 
+   ;    ;   ;   ;       ;      ;    ;   ;  ; ; ;  ;   ;  ;   ;  ;   ; 
+   ;    ;   ;   ;   ;  ;       ;    ;   ;  ; ; ;  ;   ;  ;   ;  ;   ; 
+ ;;;;; ;;;  ;;   ;;;   ;     ;;;;;;  ;;; ;;; ; ;;; ;;;    ;;; ;  ;;; ;
+                      ;                                               
+                                                                      
+                                                                      
+
+
+  (define (intermediate/lambda)
+    (parameterize ([language (list "How to Design Programs" 
+                                   "Intermediate Student with lambda")])
+      (check-top-of-repl)
+      
+      (generic-settings #t)
+      (generic-output #t #f #f)
+      (teaching-language-fraction-output)
+      
+      (test-hash-bang)
+      (test-error-after-definition)
+      
+      (prepare-for-test-expression)
+      
+      (test-expression "'|.|" "'|.|")
+      (test-expression '("(equal? (list " image ") (list " image "))") 
+                       "true")
+      (test-expression "(define x 1)(define x 2)"
+                       "x: this name was defined previously and cannot be re-defined"
+                       "define: cannot redefine name: x")
+      
+      (test-expression "(define-struct spider (legs))(make-spider 4)"
+                       "(make-spider 4)"
+                       "define-struct: cannot redefine name: spider")
+      
+      (test-expression "(sqrt -1)" "0+1i")
+      
+      (test-expression "class"
+                       "class: name is not defined, not an argument, and not a primitive name"
+                       "reference to undefined identifier: class")
+      (test-expression "shared" 
+                       "shared: name is not defined, not an argument, and not a primitive name"
+                       "reference to undefined identifier: shared")
+      
+      (test-expression "(define (. x y) (* x y))" "read: illegal use of \".\"")
+      (test-expression "'(1 . 2)" "read: illegal use of \".\"")
+      
+      (test-expression "call/cc"
+                       "call/cc: name is not defined, not an argument, and not a primitive name"
+                       "reference to undefined identifier: call/cc")
+      
+      (test-expression "(error 'a \"~a\" 1)"
+                       "procedure error: expects 2 arguments, given 3: 'a \"~a\" 1")
+      (test-expression "(error \"a\" \"a\")"
+                       "error: expected a symbol and a string, got \"a\" and \"a\"")
+      
+      (test-expression "(time 1)" 
+                       #rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1")
+            
+      (test-expression "true" "true")
+      (test-expression "mred^" 
+                       "mred^: name is not defined, not an argument, and not a primitive name"
+                       "reference to undefined identifier: mred^")
+      (test-expression "(eq? 'a 'A)" "false")
+      (test-expression "(set! x 1)"
+                       "set!: name is not defined, not an argument, and not a primitive name"
+                       "reference to undefined identifier: set!")
+      (test-expression "(cond [(= 1 2) 3])" "cond: all question results were false")
+      (test-expression "(cons 1 2)" "cons: second argument must be of type <list>, given 1 and 2")
+      (test-expression "'(1)" "(list 1)")
+      (test-expression "(define shrd (list 1)) (list shrd shrd)"
+                       "(list (list 1) (list 1))"
+                       "define: cannot redefine name: shrd")
+      (test-expression "(local ((define x x)) 1)" "local variable used before its definition: x")
+      (test-expression "(letrec ([x x]) 1)" "local variable used before its definition: x")
+      (test-expression "(if 1 1 1)" "if: question result is not true or false: 1")
+      (test-expression "(+ 1)" "procedure +: expects at least 2 arguments, given 1: 1")
+      
+      (test-expression "1.0" "1")
+      (test-expression "#i1.0" "#i1.0")
+      (test-expression "4/3" "{number 4/3 \"1.3\" decimal}")
+      (test-expression "1/3" "{number 1/3 \"0.3\" decimal}")
+      (test-expression "-4/3" "{number -4/3 \"-1.3\" decimal}")
+      (test-expression "-1/3" "{number -1/3 \"-0.3\" decimal}")
+      (test-expression "3/2" "{number 3/2 \"1.5\" decimal}")
+      (test-expression "1/2" "{number 1/2 \"0.5\" decimal}")
+      (test-expression "-1/2" "{number -1/2 \"-0.5\" decimal}")
+      (test-expression "-3/2" "{number -3/2 \"-1.5\" decimal}")
+      (test-expression "+1/3i" "0+1/3i")
+      (test-expression "+1/2i" "0+0.5i")
+      (test-expression "779625/32258" "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}")
+      (test-expression "(exact? 1.5)" "true")
+      
+      (test-expression "(let ([f (lambda (x) x)]) f)" "(lambda (a1) ...)")
+      (test-expression ",1"
+                       "unquote: misuse of a comma or `unquote', not under a quasiquoting backquote")
+
+      (test-expression "(list 1)" "(list 1)")
+      (test-expression "(car (list))" "car: expects argument of type <pair>; given empty")
+      (test-expression "argv" 
+                       "argv: name is not defined, not an argument, and not a primitive name"
+                       "reference to undefined identifier: argv")))
+  
+
+                                                        
+           ;;                                        ;; 
+            ;                                         ; 
+            ;                                         ; 
+ ;;;;    ;;;; ;;; ;;; ;;;;  ; ;;;    ;;;    ;;;    ;;;; 
+     ;  ;   ;  ;   ;      ;  ;;  ;  ;   ;  ;   ;  ;   ; 
+  ;;;;  ;   ;  ;   ;   ;;;;  ;   ;  ;      ;;;;;  ;   ; 
+ ;   ;  ;   ;   ; ;   ;   ;  ;   ;  ;      ;      ;   ; 
+ ;   ;  ;   ;   ;;;   ;   ;  ;   ;  ;   ;  ;   ;  ;   ; 
+  ;;; ;  ;;; ;   ;     ;;; ;;;;  ;;  ;;;    ;;;    ;;; ;
+                                                        
+                                                        
+                                                        
+
+
+  (define (advanced)
+    (parameterize ([language (list "How to Design Programs" "Advanced Student")])
+      (check-top-of-repl)
+
+      (generic-settings #t)
+      (generic-output #t #t #t)
+      (teaching-language-fraction-output)
+      
+      (test-hash-bang)
+      (test-error-after-definition)
+      
+      (prepare-for-test-expression)
+      
+      (test-expression "'|.|" "'|.|")
+      (test-expression '("(equal? (list " image ") (list " image "))") 
+                       "true")
+      (test-expression "(define x 1)(define x 2)"
+                       "x: this name was defined previously and cannot be re-defined"
+                       "define: cannot redefine name: x")
+      
+      (test-expression "(define-struct spider (legs))(make-spider 4)"
+                       "(make-spider 4)"
+                       "define-struct: cannot redefine name: spider")
+      
+      (test-expression "(sqrt -1)" "0+1i")
+
+      (test-expression "class"
+                       "class: name is not defined, not an argument, and not a primitive name"
+                       "reference to undefined identifier: class")
+
+      (test-expression "shared" "shared: found a use of `shared' that does not follow an open parenthesis")
+      
+      (test-expression "(define (. x y) (* x y))" "read: illegal use of \".\"")
+      (test-expression "'(1 . 2)" "read: illegal use of \".\"")
+      
+      (test-expression "call/cc" 
+                       "call/cc: name is not defined, not an argument, and not a primitive name"
+                       "reference to undefined identifier: call/cc")
+      
+      (test-expression "(error 'a \"~a\" 1)"
+                       "procedure error: expects 2 arguments, given 3: 'a \"~a\" 1")
+      (test-expression "(error \"a\" \"a\")"
+                       "error: expected a symbol and a string, got \"a\" and \"a\"")
+      
+      (test-expression "(time 1)" 
+                       #rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1")
+            
+      (test-expression "true" "true")
+      (test-expression "mred^" 
+                       "mred^: name is not defined, not an argument, and not a primitive name"
+                       "reference to undefined identifier: mred^")
+      (test-expression "(eq? 'a 'A)" "false")
+      (test-expression "(set! x 1)"
+                       "x: name is not defined"
+                       "set!: cannot set undefined identifier: x")
+      (test-expression "(cond [(= 1 2) 3])" "cond: all question results were false")
+      (test-expression "(cons 1 2)" "cons: second argument must be of type <list or cyclic list>, given 1 and 2")
+      (test-expression "'(1)" "(list 1)")
+      (test-expression "(define shrd (list 1)) (list shrd shrd)"
+                       "(shared ((-1- (list 1))) (list -1- -1-))"
+                       "define: cannot redefine name: shrd")
+      (test-expression "(local ((define x x)) 1)" "local variable used before its definition: x")
+      (test-expression "(letrec ([x x]) 1)" "local variable used before its definition: x")
+      (test-expression "(if 1 1 1)" "if: question result is not true or false: 1")
+      (test-expression "(+ 1)" "procedure +: expects at least 2 arguments, given 1: 1")
+
+      (test-expression "1.0" "1")
+      (test-expression "#i1.0" "#i1.0")
+      (test-expression "4/3" "{number 4/3 \"1.3\" decimal}")
+      (test-expression "1/3" "{number 1/3 \"0.3\" decimal}")
+      (test-expression "-4/3" "{number -4/3 \"-1.3\" decimal}")
+      (test-expression "-1/3" "{number -1/3 \"-0.3\" decimal}")
+      (test-expression "3/2" "{number 3/2 \"1.5\" decimal}")
+      (test-expression "1/2" "{number 1/2 \"0.5\" decimal}")
+      (test-expression "-1/2" "{number -1/2 \"-0.5\" decimal}")
+      (test-expression "-3/2" "{number -3/2 \"-1.5\" decimal}")
+      (test-expression "+1/3i" "0+1/3i")
+      (test-expression "+1/2i" "0+0.5i")
+      (test-expression "779625/32258" "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}")
+      (test-expression "(exact? 1.5)" "true")
+      
+      (test-expression "(let ([f (lambda (x) x)]) f)" "(lambda (a1) ...)")
+      (test-expression ",1"
+                       "unquote: misuse of a comma or `unquote', not under a quasiquoting backquote")
+
+      (test-expression "(list 1)" "(list 1)")
+      (test-expression "(car (list))" "car: expects argument of type <pair>; given empty")
+      (test-expression "argv"
+                       "argv: name is not defined, not an argument, and not a primitive name"
+                       "reference to undefined identifier: argv")))
+
+                                                 
+                                                 
+                                            ;    
+                                            ;    
+  ;;;  ;;  ;; ; ;;;  ; ;;;    ;;;   ; ;;;  ;;;;; 
+ ;   ;  ;   ;  ;   ;  ;   ;  ;   ;   ;      ;    
+  ;;;   ;   ;  ;   ;  ;   ;  ;   ;   ;      ;    
+     ;  ;   ;  ;   ;  ;   ;  ;   ;   ;      ;    
+ ;   ;  ;   ;  ;   ;  ;   ;  ;   ;   ;      ;   ;
+  ;;;    ;;; ; ;;;;   ;;;;    ;;;   ;;;;     ;;; 
+               ;      ;                          
+               ;      ;                          
+              ;;;    ;;;                         
+
+
+  (define (prepare-for-test-expression)
+    (let ([drs (wait-for-drscheme-frame)])
+      (clear-definitions drs)
+      (set-language #t)
+      (sleep 1) ;; this shouldn't be neccessary....
+      (do-execute drs)))
+  
+  ;; test-setting : (-> void) string string string -> void
+  ;; opens the language dialog, runs `set-setting'
+  ;; closes the language dialog, executes,
+  ;; makes sure that `expression' produces
+  ;; `result'. `set-setting' is expected to click around
+  ;; in the language dialog.
+  ;; `setting-name' is used in the error message when the test fails.
+  (define (test-setting set-setting setting-name expression result)
+    (set-language #f)
+    (set-setting)
+    (let ([f (get-top-level-focus-window)])
+      (fw:test:button-push "OK")
+      (wait-for-new-frame f))
+    (let* ([drs (get-top-level-focus-window)]
+           [interactions (send drs get-interactions-text)])
+      (clear-definitions drs)
+      (type-in-definitions drs expression)
+      (do-execute drs)
+      (let* ([got (fetch-output drs)])
+        (unless (string=? result got)
+          (printf "FAILED: ~s ~s ~s test~n expected: ~a~n      got: ~a~n"
+                  (language) setting-name expression result got)))))
+  
+  (define (test-hash-bang)
+    (let* ([expression (format "#!~n1")]
+           [result "1"]
+           [drs (get-top-level-focus-window)]
+           [interactions (send drs get-interactions-text)])
+      (clear-definitions drs)
+      (type-in-definitions drs expression)
+      (do-execute drs)
+      (let* ([got (fetch-output drs)])
+        (unless (string=? "1" got)
+          (printf "FAILED: ~s ~a test~n expected: ~a~n     got: ~a~n"
+                  (language) expression result got)))))
+  
+  (define (check-top-of-repl)
+    (let ([drs (wait-for-drscheme-frame)])
+      (set-language #t)
+      (do-execute drs)
+      (let* ([interactions (send drs get-interactions-text)]
+             [short-lang (car (last-pair (language)))]
+             [get-line (lambda (n) (send interactions get-text 
+                                         (send interactions paragraph-start-position n)
+                                         (send interactions paragraph-end-position n)))]
+             [line0-expect (format "Welcome to DrScheme, version ~a." (version:version))]
+             [line1-expect 
+              (if (string? short-lang)
+                  (format "Language: ~a." short-lang)
+                  short-lang)]
+             [line0-got (get-line 0)]
+             [line1-got (get-line 1)])
+        (unless (and (string=? line0-expect line0-got)
+                     (if (string? short-lang)
+                         (string=? line1-expect line1-got)
+                         (regexp-match line1-expect line1-got)))
+          (printf "expected lines: ~n  ~a~n  ~a~ngot lines:~n  ~a~n  ~a~n" 
+                  line0-expect line1-expect
+                  line0-got line1-got)
+          (error 'language-test.ss "failed get top of repl test")))))
+
+  
+  ;; teaching-language-fraction-output
+  ;; tests that the teaching langauges properly handle repeating decimals
+  (define (teaching-language-fraction-output)
+    (test-setting
+     (lambda () (fw:test:set-radio-box! "Fraction Style" "Mixed fractions"))
+     "Fraction Style -- Mixed fractions"
+     "4/3"
+     "{number 4/3 \"1 1/3\" mixed}")
+    (test-setting
+     (lambda () (fw:test:set-radio-box! "Fraction Style" "Repeating decimals"))
+     "Fraction Style -- Repeating decimals"
+     "4/3"
+     "{number 4/3 \"1.3\" decimal}"))
+  
+  ;; plt-language-fraction-output : -> void
+  ;; tests that the PLT languages properly handle repeating decimals
+  (define (plt-language-fraction-output)
+    (test-setting
+     (lambda () (fw:test:set-check-box! "Use decimal notation for rationals" #f))
+     "Use decimal notation for rationals -- #f"
+     "4/3 1/2 -1/3"
+     "{number 4/3 \"1 1/3\" mixed}\n{number 1/2 \"1/2\" mixed}\n{number -1/3 \"- 1/3\" mixed}")
+    (test-setting
+     (lambda () (fw:test:set-check-box! "Use decimal notation for rationals" #t))
+     "Use decimal notation for rationals -- #t"
+     "4/3 1/2 -1/3"
+     "{number 4/3 \"#e1.3\" decimal}\n{number 1/2 \"#e0.5\" decimal}\n{number -1/3 \"#e-0.3\" decimal}"))
+  
+  (define (generic-settings false/true?)
+    (test-setting
+      (lambda () (fw:test:set-check-box! "Case sensitive" #t))
+     "Case sensitive -- #t"
+     "(eq? 'g 'G)" (if false/true? "false" "#f"))
+    (test-setting
+     (lambda () (fw:test:set-check-box! "Case sensitive" #f))
+     "Case sensitive -- #f"
+     "(eq? 'g 'G)" (if false/true? "true" "#t")))
+  
+  (define (generic-output list? quasi-quote? has-sharing?)
+    (let* ([drs (wait-for-drscheme-frame)]
+           [expression (format "(define x (list 2))~n(list x x)")]
+           [set-output-choice
+            (lambda (option show-sharing pretty?)
+              (set-language #f)
+              (fw:test:set-radio-box! "Output Style" option)
+              (when (and has-sharing? show-sharing)
+                (fw:test:set-check-box!
+                 "Show sharing in values"
+                 (if (eq? show-sharing 'on) #t #f)))
+              (fw:test:set-check-box!
+               "Insert newlines in printed values"
+               pretty?)
+              (let ([f (get-top-level-focus-window)])
+                (fw:test:button-push "OK")
+                (wait-for-new-frame f)))]
+           [shorten
+            (lambda (str)
+              (if ((string-length str) . <= . 45)
+                  str
+                  (string-append (substring str 0 45) "...")))]
+           [test
+	    ;; answer must either be a string, or a procedure that accepts both zero and 1
+	    ;; argument. When the procedure accepts 1 arg, the argument is `got' and
+	    ;; the result must be a boolean indicating if the result was satisfactory.
+	    ;; if the procedure receives no arguments, it must return a descriptive string
+	    ;; for the error message
+            (lambda (option show-sharing pretty? answer)
+              (set-output-choice option show-sharing pretty?)
+              (do-execute drs)
+              (let ([got (fetch-output drs)])
+                (unless (if (procedure? answer)
+                            (answer got)
+                            (whitespace-string=? answer got))
+                  (printf "FAILED ~s ~a, sharing ~a pretty? ~a~n            got ~s~n       expected ~s~n"
+                          (language) option show-sharing pretty?
+                          (shorten got)
+                          (if (procedure? answer) (answer) answer)))))])
+      
+      (clear-definitions drs)
+      (type-in-definitions drs expression)
+      
+      (test "write" 'off #t "((2) (2))")
+      (when has-sharing?
+        (test "write" 'on #t "(#0=(2) #0#)"))
+      (when quasi-quote?
+        (test "Quasiquote" 'off #t "`((2) (2))")
+        (when has-sharing?
+          (test "Quasiquote" 'on #t "(shared ((-1- `(2))) `(,-1- ,-1-))")))
+      
+      (test "Constructor" 'off #t
+            (if list?
+                "(list (list 2) (list 2))"
+                "(cons (cons 2 empty) (cons (cons 2 empty) empty))"))
+      (when has-sharing?
+        (test "Constructor" 'on #t
+              (if list?
+                  "(shared ((-1- (list 2))) (list -1- -1-))"
+                  "(shared ((-1- (cons 2 empty))) (cons -1- (cons -1- empty)))")))
+ 
+      ;; setup write / pretty-print difference
+      (clear-definitions drs)
+      (for-each fw:test:keystroke
+                (string->list
+                 "(define (f n)\n(cond [(zero? n) null]\n[else (cons n (f (- n 1)))]))\n(f 200)"))
+      (test "Constructor" #f #f
+            (case-lambda
+             [(x) (not (member #\newline (string->list x)))]
+             [() "no newlines in result"]))
+      (test "Constructor" #f #t
+            (case-lambda
+             [(x) (member #\newline (string->list x))]
+             [() "newlines in result (may need to make the window smaller)"]))
+      (test "write" #f #f
+            (case-lambda
+             [(x) (not (member #\newline (string->list x)))]
+             [() "no newlines in result"]))
+      (test "write" #f #t
+            (case-lambda
+             [(x) (member #\newline (string->list x))]
+             [() "newlines in result (may need to make the window smaller)"]))))
+
+  (define re:out-of-sync
+    (regexp
+     "WARNING: Interactions window is out of sync with the definitions window\\."))
+  
+  (define (test-error-after-definition)
+    (let* ([drs (wait-for-drscheme-frame)]
+           [interactions-text (send drs get-interactions-text)])
+      (clear-definitions drs)
+      (type-in-definitions drs "(define y 0) (define (f x) (/ x y)) (f 2)")
+      (do-execute drs)
+      (let ([last-para (send interactions-text last-paragraph)])
+        (type-in-interactions drs "y\n")
+        (wait-for-computation drs)
+        (let ([got
+               (fetch-output
+                drs
+                (send interactions-text paragraph-start-position (+ last-para 1))
+                (send interactions-text paragraph-end-position
+                      (- (send interactions-text last-paragraph) 1)))])
+          (unless (equal? got "0")
+            (printf "FAILED: test-error-after-definition failed, expected 0, got ~s\n" got))))))
+
+  
+  ;; test-expression : (union string 'xml 'image (listof (union string 'xml 'image)))
+  ;;                   (union string regexp (string -> boolean)) 
+  ;;                -> void
+  ;; types an expression in the definitions window, executes it and tests the output
+  ;; types an expression in the REPL and tests the output from the REPL.
+  (define test-expression
+    (case-lambda 
+      [(expression expected) (test-expression expression expected expected)]
+      [(expression defs-expected repl-expected)
+       (let* ([drs (wait-for-drscheme-frame)]
+              [interactions-text (send drs get-interactions-text)]
+              [definitions-text (send drs get-definitions-text)]
+              [handle-insertion
+               (lambda (item)
+                 (cond
+                   [(eq? item 'image)
+                    (use-get/put-dialog 
+                     (lambda () (fw:test:menu-select "Special" "Insert Image..."))
+                     (simplify-path (build-path (collection-path "icons") "recycle.gif")))]
+                   [(string? item)
+                    (type-in-definitions drs item)]
+                   [(eq? item 'xml)
+                    (fw:test:menu-select "Special" "Insert XML Box")
+                    (for-each fw:test:keystroke (string->list "<a><b>"))]
+                   [else (error 'handle-insertion "unknown thing to insert ~s" item)]))]
+              [check-expectation
+               (lambda (expected got)
+                 (cond
+                   [(string? expected)
+                    (whitespace-string=? expected got)]
+                   [(regexp? expected)
+                    (regexp-match expected got)]
+                   [(procedure? expected)
+                    (expected got)]))]
+              [make-err-msg
+               (lambda (expected)
+                 (cond
+                   [(string? expected)
+                    "FAILED: ~s ~s expected ~s to produce:\n  ~s\ngot:\n  ~s\ninstead~n"]
+                   [(regexp? expected)
+                    "FAILED: ~s ~s expected ~s to match ~s, got ~s instead~n"]
+                   [(procedure? expected)
+                    "FAILED: ~s ~s expected ~s to pass predicate ~s, got ~s~n"]))])
+         (clear-definitions drs)
+         (cond
+	   [(pair? expression) (for-each handle-insertion expression)]
+           [else (handle-insertion expression)])
+         (do-execute drs)
+         
+         (let ([got
+                (fetch-output
+                 drs
+                 (send interactions-text paragraph-start-position 2)
+                 (send interactions-text paragraph-end-position
+                       (- (send interactions-text last-paragraph) 1)))])
+           (when (regexp-match re:out-of-sync got)
+             (error 'text-expression "got out of sync message"))
+           (unless (check-expectation defs-expected got)
+             (printf (make-err-msg defs-expected) 
+                     'definitions (language) expression defs-expected got)))
+         
+         (send definitions-text select-all)
+         (send definitions-text copy)
+         
+         (send interactions-text set-position
+               (send interactions-text last-position)
+               (send interactions-text last-position))
+         
+         (send interactions-text paste)
+         
+         (let ([last-para (send interactions-text last-paragraph)])
+           (type-in-interactions drs (string #\newline))
+           (wait-for-computation drs)
+           (let ([got
+                  (fetch-output
+                   drs
+                   (send interactions-text paragraph-start-position (+ last-para 1))
+                   (send interactions-text paragraph-end-position
+                         (- (send interactions-text last-paragraph) 1)))])
+             (when (regexp-match re:out-of-sync got)
+               (error 'text-expression "got out of sync message"))
+             (unless (check-expectation repl-expected got)
+               (printf (make-err-msg repl-expected) 'interactions (language) expression defs-expected got)))))]))
+  
+  
+  (define-syntax (go stx)
+    (syntax-case stx ()
+      [(_ arg)
+       (identifier? (syntax arg))
+       (syntax (begin (printf ">> starting ~a\n" (syntax-object->datum #'arg))
+                      (arg)
+                      (printf ">> finished ~a\n" (syntax-object->datum #'arg))))]))
+  
+  (define (run-test)
+    ;; clear teachpack
+    (let ([drs (wait-for-drscheme-frame)])
+      (fw:test:menu-select "Language" "Clear All Teachpacks"))
+
+    (go beginner)
+    (go beginner/abbrev)
+    (go intermediate)
+    (go intermediate/lambda)
+    (go advanced)
+    (go r5rs)
+    (go mred)
+    (go mzscheme)))
diff --git a/collects/tests/drscheme/module-lang-test.ss b/collects/tests/drscheme/module-lang-test.ss
new file mode 100644
index 0000000000..fc6297b00c
--- /dev/null
+++ b/collects/tests/drscheme/module-lang-test.ss
@@ -0,0 +1,181 @@
+(module module-lang-test mzscheme
+  (require "drscheme-test-util.ss"
+           (lib "class.ss")
+           (lib "file.ss")
+           (lib "etc.ss")
+           (lib "mred.ss" "mred")
+           (lib "framework.ss" "framework")
+           (prefix fw: (lib "framework.ss" "framework")))
+  
+  (provide run-test)
+  
+  (define-struct test (definitions   ;; string
+                       interactions  ;; (union #f string)
+                       result))      ;; string
+
+  (define this-dir (collection-path "tests" "drscheme"))
+
+  (define tests
+    (list
+     
+     (make-test "" 
+                #f
+                (regexp "module-language: the definitions window must contain a module"))
+     (make-test "1" 
+                #f
+                (regexp "module-language: only module expressions are allowed"))
+     (make-test "(module m mzscheme) 1" 
+                #f 
+                (regexp "module-language: there can only be one expression in the definitions window"))
+     (make-test "(module m mzscheme (provide x) (define x 1))" "x" "1")
+     (make-test "(module m mzscheme (define x 1))" "x" "1")
+     (make-test "(module m mzscheme (define x 1) (define y 1) (provide y))" "x" "1")
+     (make-test "(module m mzscheme (define x 1) (define y 2) (provide y))" "y" "2")
+     (make-test "(module m mzscheme (require (lib \"list.ss\")))" 
+                "foldl" 
+                (regexp "foldl"))
+     
+     (make-test "(module m mzscheme (require (rename (lib \"list.ss\") local-foldl foldl)))" 
+                "local-foldl"
+                (regexp "foldl>"))
+     
+     (make-test "(module m mzscheme (require (all-except (lib \"list.ss\") foldl)))" 
+                "first"
+                (regexp "first>"))
+     (make-test "(module m mzscheme (require (all-except (lib \"list.ss\") foldl)))" 
+                "foldl"
+                ". reference to an identifier before its definition: foldl")
+     
+     (make-test "(module m mzscheme (require (prefix mz: mzscheme)))" "mz:+" #rx"primitive:+")
+     
+     (make-test "(module n mzscheme (provide (all-from-except mzscheme +)))"
+                "+"
+                #rx"primitive:+")
+     
+     (make-test "(module m mzscheme (require (prefix x: (lib \"list.ss\")) (lib \"list.ss\")))" 
+                "foldl"
+                (regexp "foldl>"))
+     (make-test "(module m mzscheme (require (prefix x: (lib \"list.ss\")) (lib \"list.ss\")))" 
+                "x:foldl"
+                (regexp "foldl>"))
+     
+     (make-test (format "~s"
+                        `(module m (file ,(path->string (build-path this-dir "module-lang-test-tmp.ss")))
+                           x))
+                "x"
+                "1")
+     
+     ;; + shouldn't be bound in the REPL because it isn't bound
+     ;; in the module.
+     (make-test (format "~s"
+                        `(module m (file ,(path->string (build-path this-dir "module-lang-test-tmp.ss")))
+                           x))
+                "+"
+                ". reference to an identifier before its definition: +")
+     
+     (make-test (format "~s" '(module m mzscheme (provide lambda)))
+                "(lambda (x) x)"
+                #rx"<procedure")
+     
+     (make-test (format "~s" '(module m mzscheme (define-syntax (m x) (syntax 1)) (provide m)))
+                "(m)"
+                "1")
+     (make-test (format "~s" '(module m mzscheme (define-syntax s (syntax 1)) (provide s)))
+                "s"
+                "s: illegal use of syntax in: s")
+     
+     (make-test (format "~s" '(module m mzscheme (define-syntax (x stx) #'(define a 10)) x x))
+                "a"
+                ". reference to an identifier before its definition: a")
+     (make-test (format "~s" '(module m mzscheme (define-syntax (x stx) #'(define-syntax (a stx) #'10)) x x))
+                "a"
+                ". reference to an identifier before its definition: a")
+     (make-test (format "~s" '(module m mzscheme (define-syntax (x stx) #'(define a 10)) x x (define a 77)))
+                "a"
+                "77")
+     (make-test (format "~s" '(module m mzscheme (define-syntax (x stx) #'(define-syntax (a stx) #'10)) x x (define a 78)))
+                "a"
+                "78")
+     
+     (make-test
+      (format "~s" `(module m mzscheme
+                      (require-for-syntax (file ,(path->string (build-path this-dir "module-lang-test-tmp2.ss"))))
+                      (provide s)
+                      (define-syntax (s stx) e)))
+      (format "~s ~s" '(require m) 's)
+      ". module-lang-test-tmp2.ss:1:70: compile: bad syntax; literal data is not allowed, because no #%datum syntax transformer is bound in: 1")))
+  
+  ;; set up for tests that need external files
+  (call-with-output-file (build-path this-dir "module-lang-test-tmp.ss")
+    (lambda (port)
+      (write `(module module-lang-test-tmp mzscheme
+                (provide (all-from-except mzscheme +)
+                         x)
+                (define x 1))
+             port))
+    'truncate
+    'text)
+  
+  (call-with-output-file (build-path this-dir "module-lang-test-tmp2.ss")
+    (lambda (port)
+      (write `(module module-lang-test-tmp2 mzscheme
+                (provide e)
+                (define e #'1))
+             port))
+    'truncate
+    'text)
+
+  (define drs (wait-for-drscheme-frame))
+  (define interactions-text (send drs get-interactions-text))
+  
+  (define (single-test test)
+    (let/ec k
+      (clear-definitions drs)
+      (type-in-definitions drs (test-definitions test))
+      (do-execute drs)
+        
+      (let ([ints (test-interactions test)])
+        
+        (when ints
+          (let ([after-execute-output
+                 (send interactions-text
+                       get-text
+                       (send interactions-text paragraph-start-position 2)
+                       (send interactions-text paragraph-end-position 2))])
+            (unless (string=? "> " after-execute-output)
+              (printf "FAILED: ~a\n        ~a\n        expected no output after execution, got: ~s\n"
+                      (test-definitions test)
+                      (or (test-interactions test) 'no-interactions)
+                      after-execute-output)
+              (k (void)))
+            (type-in-interactions drs ints)
+            (fw:test:keystroke #\return)
+            (wait-for-computation drs)))
+        
+        (let* ([para-to-check (- (send interactions-text position-paragraph
+                                       (send interactions-text last-position))
+                                 1)]
+               [after-int-start
+                (send interactions-text paragraph-start-position para-to-check)]
+               [after-int-end
+                (send interactions-text paragraph-end-position para-to-check)]
+               [after-int-output (send interactions-text
+                                       get-text
+                                       after-int-start
+                                       after-int-end)]
+               [passed?
+                (cond
+                  [(string? (test-result test))
+                   (string=? after-int-output (test-result test))]
+                  [(regexp? (test-result test))
+                   (regexp-match (test-result test) after-int-output)])])
+          (unless passed?
+            (printf "FAILED: ~a\n        ~a\n  expected: ~a\n       got: ~a\n"
+                    (test-definitions test)
+                    (or (test-interactions test) 'no-interactions)
+                    (test-result test)
+                    after-int-output))))))
+  
+  (define (run-test)
+    (set-language-level! '("(module ...)") #t)
+    (for-each single-test tests)))
diff --git a/collects/tests/drscheme/repl-test.ss b/collects/tests/drscheme/repl-test.ss
new file mode 100644
index 0000000000..bddddda13b
--- /dev/null
+++ b/collects/tests/drscheme/repl-test.ss
@@ -0,0 +1,988 @@
+#|
+
+add this test:
+
+(require (lib "pretty.ss"))
+(pretty-print-print-hook (lambda x (car)))
+(list 1 2 3)
+
+There shouldn't be any error (but add in a bug that triggers one to be sure!)
+
+|#
+(module repl-test mzscheme
+  (require "drscheme-test-util.ss"
+           (lib "class.ss")
+           (lib "file.ss")
+           (lib "mred.ss" "mred")
+           (lib "framework.ss" "framework"))
+  
+  (provide run-test)
+  
+  (define-struct loc (line col offset))
+  ;; loc = (make-loc number number number)
+  ;; numbers in loc structs start at zero.
+  
+  (define-struct test (program
+                       ;; : (union 
+                       ;;    string 
+                       ;;    'fraction-sum
+                       ;;    (listof
+                       ;;      (union string?  // typed in
+                       ;;             'left    // left arrow key
+                       ;;             (list string? string?)))) // menu item select
+                       
+                       execute-answer        ;; : string
+                       load-answer           ;; : (union #f string)
+                       
+                       has-backtrace?        ;; : boolean
+                       ;; indicates if the backtrace icon should appear for this test
+                       ;; only applies to the debug tests
+                       
+                       source-location ;; : (union 'definitions
+                       ;;                          'interactions
+                       ;;                          (cons loc loc))
+                       ;; if cons, the car and cdr are the start and end positions resp.
+                       ;; if 'interactions, no source location and
+                       ;;    the focus must be in the interactions window
+                       ;; if 'definitions, no source location and
+                       ;;     the focus must be in the definitions window
+                       
+                       source-location-in-message  ;; : (union #f 'read 'expand)
+                       ;; 'read indicates that the error message is a read error, so
+                       ;; the source location is the port info, and 'expand indicates
+                       ;; that the error messsage is an expansion time error, so the
+                       ;; the source location is the repl.
+                       ;; #f indicates no source location error message
+                       ;; if this field is not #f, the execute-answer and load-answer fields
+                       ;; are expected to be `format'able strings with one ~a in them.
+                       
+                       docs-icon?                  ;; : boolean 
+                       ;; true if this should have a docs icon in front of the response.
+                       
+                       breaking-test?              ;; : boolean
+                       
+                       ;; setup is called before the test case is run.
+                       setup ;; : -> void
+                       ;; teardown is called after the test case is complete.
+                       teardown ;; : -> void
+                       ))
+  
+  (define test-data
+    (list
+     ;; basic tests
+     (make-test "1"
+                "1"
+                "1"
+                #f
+                'interactions
+		#f
+                #f
+                #f
+                void
+                void)
+     (make-test "\"a\""
+                "\"a\""
+                "\"a\""
+                #f
+                'interactions
+		#f
+                #f
+                #f
+                void
+                void)
+     
+     (make-test "1 2"
+                "1\n2"
+                "2"
+                #f
+                'interactions
+		#f
+                #f
+                #f
+                void
+                void)
+     
+     (make-test "\"a\" \"b\""
+                "\"a\"\n\"b\""
+                "\"b\""
+                #f
+                'interactions
+		#f
+                #f
+                #f
+                void
+                void)
+     
+     (make-test "("
+                "~aread: expected a ')'"
+                "~aread: expected a ')'"
+                #t
+                (cons (make-loc 0 0 0) (make-loc 0 1 1))
+		'read
+                #f
+                #f
+                void
+                void)
+     (make-test "."
+                "~aread: illegal use of \".\""
+                "~aread: illegal use of \".\""
+                #t
+                (cons (make-loc 0 0 0) (make-loc 0 1 1))
+                'read
+                #f
+                #f
+                void
+                void)
+     (make-test "(lambda ())"
+                "~alambda: bad syntax in: (lambda ())"
+                "~alambda: bad syntax in: (lambda ())"
+                #t
+                (cons (make-loc 0 0 0) (make-loc 0 11 11))
+		'expand
+                #t
+                #f
+                void
+                void)
+     (make-test "xx"
+                "reference to undefined identifier: xx"
+                "reference to undefined identifier: xx"
+                #t
+                (cons (make-loc 0 0 0) (make-loc 0 2 2))
+                #f
+                #f
+                #f
+                void
+                void)
+     (make-test "(raise 1)"
+                "uncaught exception: 1"
+                "uncaught exception: 1"
+                #f
+                'interactions
+                #f
+                #f
+                #f
+                void
+                void)
+     (make-test "(raise #f)"
+                "uncaught exception: #f"
+                "uncaught exception: #f"
+                #f
+		'interactions
+                #f
+                #f
+                #f
+                void
+                void)
+     
+     (make-test "(values 1 2)"
+                "1\n2"
+                "1\n2"
+                #f
+		'interactions
+                #f
+                #f
+                #f
+                void
+                void)
+     (make-test "(list 1 2)"
+                "(1 2)"
+                "(1 2)"
+                #f
+		'interactions
+                #f
+                #f
+                #f
+                void
+                void)
+     
+     (make-test "(parameterize ([print-struct #t])(define-struct s (x) (make-inspector))(printf \"~s\\n\" (make-s 1)))"
+                "#(struct:s 1)"
+                "#(struct:s 1)"
+                #f
+                'interactions
+                #f
+                #f
+                #f
+                void
+                void)
+     
+     ;; top-level semantics test
+     (make-test "(define (f) (+ 1 1)) (define + -) (f)"
+                "0"
+                "0"
+                #f
+		'interactions
+                #f
+                #f
+                #f
+                void
+                void)
+
+     (make-test "(begin (define-struct a ()) (define-struct (b a) ()))"
+		""
+		""
+		#f
+		'interactions
+		#f
+		#f
+		#f
+                void
+                void)
+     
+     (make-test "(begin (values) 1)"
+		"1"
+		"1"
+		#f
+		'interactions
+		#f
+		#f
+		#f
+                void
+                void)
+
+     (make-test (string-append
+                 "(module m mzscheme (provide e) (define e #'1))\n"
+                 "(module n mzscheme (require-for-syntax m) (provide s) (define-syntax (s stx) e))\n"
+                 "(require n)\n"
+                 "s")
+                "compile: bad syntax; literal data is not allowed, because no #%datum syntax transformer is bound in: 1"
+                "compile: bad syntax; literal data is not allowed, because no #%datum syntax transformer is bound in: 1"
+                #f
+                (cons (make-loc 1 43 43) (make-loc 1 44 44))
+                #f
+                #f
+                #f
+                void
+                void)
+
+     ;; leading comment test
+     (make-test "#!\n1"
+                "1"
+                "1"
+                #f
+		'interactions
+                #f
+                #f
+                #f
+                void
+                void)
+     #|
+     (make-test (list "#!\n" 
+                      '("Special" "Insert XML Box")
+                      "<a>")
+                "(a ())"
+                "(a ())"
+                #f
+		'interactions
+                #f
+                #f
+                #f
+                void
+                void)
+
+     ;; XML tests
+     (make-test
+      '(("Special" "Insert XML Box")
+        "<a>")
+      "(a ())"
+      "(a ())"
+      #f
+      'interactions
+      #f
+      #f
+      #f
+      void
+      void)
+     
+     (make-test
+      '(("Special" "Insert XML Box")
+        "<a>"
+        ("Special" "Insert Scheme Box")
+        "1")
+      "(a () 1)"
+      "(a () 1)"
+      #f
+      'interactions
+      #f
+      #f
+      #f
+      void
+      void)
+     
+     (make-test
+      '(("Special" "Insert XML Box")
+        "<a>"
+        ("Special" "Insert Scheme Splice Box")
+        "'(1)")
+      "(a () 1)"
+      "(a () 1)"
+      #f
+      'interactions
+      #f
+      #f
+      #f
+      void
+      void)
+     
+     (make-test
+      '(("Special" "Insert XML Box")
+        "<a>"
+        ("Special" "Insert Scheme Splice Box")
+        "1")
+      "scheme-splice-box: expected a list, found: 1"
+      "scheme-splice-box: expected a list, found: 1"
+      #t
+      'definitions
+      #f
+      #f
+      #f
+      void
+      void)
+     |#
+     
+     ;; eval tests
+     (make-test "    (eval '(values 1 2))"
+                "1\n2"
+                "1\n2"
+		#f
+		'interactions
+                #f
+                #f
+                #f
+                void
+                void)
+     (make-test "    (eval '(list 1 2))"
+                "(1 2)"
+                "(1 2)"
+                #f
+		'interactions
+                #f
+                #f
+                #f
+                void
+                void)
+     (make-test "    (eval '(lambda ()))"
+                "lambda: bad syntax in: (lambda ())"
+                "lambda: bad syntax in: (lambda ())"
+                2
+		(cons (make-loc 0 4 4) (make-loc 0 23 23))
+                #f
+                #f
+                #f
+                void
+                void)
+     (make-test "    (eval 'x)"
+                "reference to undefined identifier: x"
+                "reference to undefined identifier: x"
+                2
+		(cons (make-loc 0 4 4) (make-loc 0 13 13))
+                #f
+                #f
+                #f
+                void
+                void)
+     
+     (make-test "(eval (box 1))"
+		"#&1"
+		"#&1"
+                #f
+		'interactions
+		#f
+                #f
+		#f
+                void
+                void)
+     
+     (make-test "(eval '(box 1))"
+		"#&1"
+		"#&1"
+                #f
+		'interactions
+		#f
+                #f
+		#f
+                void
+                void)
+     
+     ; printer setup test
+     (make-test "(car (void))"
+                "car: expects argument of type <pair>; given #<void>"
+                "car: expects argument of type <pair>; given #<void>"
+                2
+		(cons (make-loc 0 0 0) (make-loc 0 12 12))
+                #f
+                #f
+                #f
+                void
+                void)
+     
+     ;; error in the middle
+     (make-test "1 2 ( 3 4"
+                "1\n2\n~aread: expected a ')'"
+                "~aread: expected a ')'"
+		#f
+		(cons (make-loc 0 4 4) (make-loc 0 9 9))
+                'read
+                #f
+                #f
+                void
+                void)
+     (make-test "1 2 . 3 4"
+                "1\n2\n~aread: illegal use of \".\""
+                "~aread: illegal use of \".\""
+		#f
+		(cons (make-loc 0 4 4) (make-loc 0 5 5))
+                'read
+                #f
+                #f
+                void
+                void)
+     (make-test "1 2 (lambda ()) 3 4"
+                "1\n2\n~alambda: bad syntax in: (lambda ())"
+                "~alambda: bad syntax in: (lambda ())"
+		#f
+		(cons (make-loc 0 4 4) (make-loc 0 15 15))
+                'expand
+                #t
+                #f
+                void
+                void)
+     (make-test "1 2 x 3 4"
+                "1\n2\nreference to undefined identifier: x"
+                "reference to undefined identifier: x"
+		#t
+		(cons (make-loc 0 4 4) (make-loc 0 5 5))
+                #f
+                #f
+                #f
+                void
+                void)
+     (make-test "1 2 (raise 1) 3 4"
+                "1\n2\nuncaught exception: 1"
+                "uncaught exception: 1"
+		#f
+		'interactions
+                #f
+                #f
+                #f
+                void
+                void)
+     (make-test "1 2 (raise #f) 3 4"
+                "1\n2\nuncaught exception: #f"
+                "uncaught exception: #f"
+		#f
+		'interactions
+                #f
+                #f
+                #f
+                void
+                void)
+
+     ;; error across separate files
+     (let ([tmp-filename (make-temporary-file "dr-repl-test~a.ss")])
+       (make-test
+        (format "(load ~s) (f (lambda () (+ 1 (car 1))))" (path->string tmp-filename))
+        "car: expects argument of type <pair>; given 1"
+        "car: expects argument of type <pair>; given 1"
+        #t
+        (cons (make-loc -1 -1 (+ (string-length (path->string tmp-filename)) 29))
+              (make-loc -1 -1 (+ (string-length (path->string tmp-filename)) 36)))
+        #f
+        #f
+        #f
+        (lambda ()
+          (call-with-output-file tmp-filename
+            (lambda (port)
+              (write '(define (f t) (+ 1 (t)))
+                     port))
+            'truncate))
+        (lambda ()
+          (delete-file tmp-filename))))
+     
+     ;; new namespace test
+     (make-test "(current-namespace (make-namespace))\nif"
+                "~aif: bad syntax in: if"
+                "~aif: bad syntax in: if"
+                #f
+		(cons (make-loc 1 0 37) (make-loc 1 2 39))
+                'expand
+                #t
+                #f
+                void
+                void)
+     
+     (make-test "(current-namespace (make-namespace 'empty))\nif"
+                "~acompile: bad syntax; reference to top-level identifiers is not allowed, because no #%top syntax transformer is bound in: if"
+                #f
+                #f
+		(cons (make-loc 1 0 44) (make-loc 1 0 46))
+                'expand
+                #t
+                #f
+                void
+                void)
+     
+     ;; macro tests
+     (make-test "(define-syntax (c stx) (syntax-case stx () [(_ p q r) (syntax (+ p q r))]))"
+		""
+		""
+                #f
+		'interactions
+		#f
+                #f
+		#f
+                void
+                void)
+     
+     
+     
+     ;; error escape handler test
+     (make-test
+      "(let ([old (error-escape-handler)])\n(+ (let/ec k\n(dynamic-wind\n(lambda () (error-escape-handler (lambda () (k 5))))\n(lambda () (car))\n(lambda () (error-escape-handler old))))\n10))"
+      "car: expects 1 argument, given 0\n15"
+      "car: expects 1 argument, given 0\n15"
+      #t
+      'definitions
+      #f
+      #f
+      #f
+      void
+      void)
+     
+     ; fraction snip test
+     (make-test 'fraction-sum
+                "{number 5/6 \"5/6\" mixed}"
+                "{number 5/6 \"5/6\" mixed}"
+                #f
+                'interactions
+                #f
+                #f
+                #f
+                void
+                void)
+     
+     ;; should produce a syntax object with a turn-down triangle.
+     (make-test "(write (list (syntax x)))" 
+                "({syntax-snip})"
+                "({syntax-snip})"
+                #f
+                'interactions
+                #f
+                #f
+                #f
+                void
+                void)
+     
+     (make-test
+      ;; the begin/void combo is to make sure that no value printout
+      ;; comes and messes up the source location for the error.
+      "(define s (make-semaphore 0))\n(queue-callback\n(lambda ()\n(dynamic-wind\nvoid\n(lambda () (car))\n(lambda () (semaphore-post s)))))\n(begin (yield s) (void))"
+      "car: expects 1 argument, given 0"
+      "car: expects 1 argument, given 0"
+      2
+      (cons (make-loc 0 99 99) (make-loc 0 104 104))
+      #f
+      #f
+      #f
+      void
+      void)
+     
+     ;; breaking tests
+     (make-test "(semaphore-wait (make-semaphore 0))"
+                "user break"
+                "user break"
+                2
+		(cons (make-loc 0 0 0) (make-loc 0 35 35))
+                #f
+                #f
+                #t
+                void
+                void)
+     
+     (make-test "(let l()(l))"
+                "user break"
+                "user break"
+                2
+		(cons (make-loc 0 8 8) (make-loc 0 11 11))
+                #f
+                #f
+                #t
+                void
+                void)
+     
+     ;; continuation tests
+     (make-test "(define k (call/cc (lambda (x) x)))\n(k 17)\nk"
+		"17" "17"
+                #f
+		'interactions
+		#f
+                #f
+		#f
+                void
+                void)
+     (make-test "(define v (vector (call/cc (lambda (x) x))))\n((vector-ref v 0) 2)\nv"
+		"#1(2)" "#1(2)"
+                #f
+		'interactions
+		#f
+                #f
+                #f
+                void
+                void)
+     (make-test "(define v (vector (eval '(call/cc (lambda (x) x)))))\n((vector-ref v 0) 2)\nv"
+		"#1(2)" "#1(2)"
+                #f
+		'interactions
+		#f
+                #f
+                #f
+                void
+                void)
+     
+     (make-test "(define x 1)\n(begin (set! x (call/cc (lambda (x) x)))\n(x 3))"
+		"procedure application: expected procedure, given: 3; arguments were: 3"
+                "procedure application: expected procedure, given: 3; arguments were: 3"
+                #t
+		(cons (make-loc 3 7 61) (make-loc 3 12 66))
+		#f
+                #f
+                #f
+                void
+                void)
+
+     ;; graphical lambda tests
+     (make-test (list "((" '("Special" "Insert λ") "(x) x) 1)")
+                "1"
+                "1"
+                #f
+                'interactions
+		#f
+                #f
+                #f
+                void
+                void)
+     
+     (make-test (list "(" '("Special" "Insert λ") "())")
+                "~aλ: bad syntax in: (λ ())"
+                "~aλ: bad syntax in: (λ ())"
+                #t
+                (cons (make-loc 0 0 0) (make-loc 0 11 11))
+		'expand
+                #t
+                #f
+                void
+                void)
+     
+     ;; thread tests
+     (make-test "(begin (thread (lambda () x)) (sleep 1/10))"
+                "reference to undefined identifier: x"
+                "reference to undefined identifier: x"
+                #t
+		(cons (make-loc 0 26 26) (make-loc 0 27 27))
+                #f
+                #f
+                #f
+                void
+                void)))
+  
+  (define backtrace-image-string "{bug09.gif}")
+  (define file-image-string "{file.gif}")
+
+  (define (run-test)
+    
+    (define drscheme-frame (wait-for-drscheme-frame))
+    
+    (define interactions-text (send drscheme-frame get-interactions-text))
+    (define interactions-canvas (send drscheme-frame get-interactions-canvas))
+    (define definitions-text (send drscheme-frame get-definitions-text))
+    (define definitions-canvas (send drscheme-frame get-definitions-canvas))
+    (define execute-button (send drscheme-frame get-execute-button))
+    
+    (define (insert-string string)
+      (let loop ([n 0])
+        (unless (= n (string-length string))
+          (let ([c (string-ref string n)])
+            (if (char=? c #\newline)
+                (test:keystroke #\return)
+                (test:keystroke c)))
+          (loop (+ n 1)))))
+    
+    (define wait-for-execute (lambda () (wait-for-button execute-button)))
+    (define get-int-pos (lambda () (get-text-pos interactions-text)))
+    
+    (define tmp-load-short-filename "repl-test-tmp.ss")
+    (define tmp-load-filename
+      (normal-case-path
+       (normalize-path 
+        (build-path (collection-path "tests" "drscheme")
+                    tmp-load-short-filename))))
+    
+    (define short-tmp-load-filename
+      (let-values ([(base name dir?) (split-path tmp-load-filename)])
+        (path->string name)))
+    
+    
+    ;; setup-fraction-sum-interactions : -> void 
+    ;; clears the definitions window, and executes `1/2' to
+    ;; get a fraction snip in the interactions window.
+    ;; Then, copies that and uses it to construct the sum
+    ;; of the 1/2 image and 1/3.
+    (define (setup-fraction-sum-interactions)
+      (clear-definitions drscheme-frame)
+      (type-in-definitions drscheme-frame "1/2")
+      (do-execute drscheme-frame)
+      (let ([s (make-semaphore 0)])
+        (queue-callback
+         (lambda ()
+           (let* ([start (send interactions-text paragraph-start-position 2)]
+                  ;; since the fraction is supposed to be one char wide, we just
+                  ;; select one char, so that, if the regular number prints out,
+                  ;; this test will fail.
+                  [end (+ start 1)])
+             (send interactions-text set-position start end)
+             (semaphore-post s))))
+        (semaphore-wait s))
+      (test:menu-select "Edit" "Copy")
+      (clear-definitions drscheme-frame)
+      (type-in-definitions drscheme-frame "(+ ")
+      (test:menu-select "Edit" "Paste")
+      (type-in-definitions drscheme-frame " 1/3)"))
+    
+    ; given a filename "foo", we perform two operations on the contents 
+    ; of the file "foo.ss".  First, we insert its contents into the REPL
+    ; directly, and second, we use the load command.  We compare the
+    ; the results of these operations against expected results.
+    (define run-single-test
+      (lambda (execute-text-start escape raw?)
+        (lambda (in-vector)
+          (let* ([program (test-program in-vector)]
+                 [execute-answer (test-execute-answer in-vector)]
+                 [source-location (test-source-location in-vector)]
+                 [source-location-in-message (test-source-location-in-message in-vector)]
+                 [setup (test-setup in-vector)]
+                 [teardown (test-teardown in-vector)]
+                 [start-line (and source-location-in-message
+                                  (number->string (+ 1 (loc-line (car source-location)))))]
+                 [start-col (and source-location-in-message
+                                 (number->string (loc-col (car source-location))))]
+                 [formatted-execute-answer
+                  (let* ([w/backtrace
+                          (if (and (test-has-backtrace? in-vector)
+                                   (not raw?))
+                              (string-append backtrace-image-string " ")
+                              "")]
+                         [final
+                          ;; if there is a source-location for the message, put the
+                          ;; icons just before it. Otherwise, but the icons at
+                          ;; the beginning of the entire string.
+                          (if source-location-in-message
+                              (format execute-answer w/backtrace)
+                              (string-append w/backtrace execute-answer))])
+                    final)]
+                 [load-answer (test-load-answer in-vector)]
+                 [formatted-load-answer
+                  (and load-answer
+                       (let* ([w/file-icon
+                               (if raw?
+                                   (if source-location-in-message
+                                       (string-append file-image-string " " load-answer)
+                                       load-answer)
+                                   (if (or (eq? source-location 'definitions)
+                                           (pair? source-location))
+                                       (string-append file-image-string " " load-answer)
+                                       load-answer))]
+                              [w/backtrace
+                               (if raw?
+                                   w/file-icon
+                                   (if (or (eq? source-location 'definitions)
+                                           (pair? source-location))
+                                       (string-append backtrace-image-string " " w/file-icon)
+                                       w/file-icon))])
+                         (if source-location-in-message
+                             (format w/file-icon 
+                                     (format "~a:~a:~a: "
+                                             short-tmp-load-filename
+                                             start-line
+                                             start-col))
+                             w/file-icon)))]
+                 [breaking-test? (test-breaking-test? in-vector)])
+            
+            (setup)
+            
+            (clear-definitions drscheme-frame)
+            ; load contents of test-file into the REPL, recording
+            ; the start and end positions of the text
+            
+            (cond
+              [(string? program)
+               (insert-string program)]
+              [(eq? program 'fraction-sum)
+               (setup-fraction-sum-interactions)]
+              [(list? program)
+               (for-each
+                (lambda (item)
+                  (cond
+                    [(string? item) (insert-string item)]
+                    [(eq? item 'left)
+                     (send definitions-text 
+                           set-position
+                           (- (send definitions-text get-start-position) 1)
+                           (- (send definitions-text get-start-position) 1))]
+                    [(pair? item) (apply test:menu-select item)]))
+                program)])
+            
+            (do-execute drscheme-frame #f)
+            (when breaking-test?
+              (test:button-push (send drscheme-frame get-break-button)))
+            (wait-for-execute)
+            
+            (let* ([execute-text-end (- (get-int-pos) 1)] ;; subtract one to skip last newline
+                   [received-execute
+                    (fetch-output drscheme-frame execute-text-start execute-text-end)])
+              
+              ; check focus and selection for execute test
+              (unless raw?
+                (cond
+                  [(eq? source-location 'definitions)
+                   (unless (send definitions-canvas has-focus?)
+                     (printf "FAILED execute test for ~s\n  expected definitions to have the focus\n"
+                             program))]
+                  [(eq? source-location 'interactions)
+                   (unless (send interactions-canvas has-focus?)
+                     (printf "FAILED execute test for ~s\n  expected interactions to have the focus\n"
+                             program))]
+                  [(send definitions-canvas has-focus?)
+                   (let ([start (car source-location)]
+                         [finish (cdr source-location)])
+                     (let* ([error-ranges (send interactions-text get-error-ranges)]
+                            [error-range (and error-ranges
+                                              (not (null? error-ranges))
+                                              (car error-ranges))])
+                       (unless (and error-range
+                                    (= (+ (srcloc-position error-range) -1) (loc-offset start))
+                                    (= (+ (srcloc-position error-range) -1 (srcloc-span error-range)) (loc-offset finish)))
+                         (printf "FAILED execute test for ~s\n  error-range is ~s\n  expected ~s\n"
+                                 program
+                                 (list (+ (srcloc-position error-range) -1)
+                                       (+ (srcloc-position error-range) -1 (srcloc-span error-range)))
+                                 (list (loc-offset start)
+                                       (loc-offset finish))))))]))
+              
+              ; check text for execute test
+              (unless (string=? received-execute formatted-execute-answer)
+                (printf "FAILED execute test for ~s (~a)\n  expected: ~s\n       got: ~s\n"
+                        program
+                        raw?
+                        formatted-execute-answer received-execute))
+              
+              (test:new-window interactions-canvas)
+              
+              ; save the file so that load is in sync
+              (test:menu-select "File" "Save Definitions")
+              
+              ; make sure that a prompt is available at end of the REPL
+              (unless (and (char=? #\>
+                                   (send interactions-text get-character
+                                         (- (send interactions-text last-position) 2)))
+                           (char=? #\space
+                                   (send interactions-text get-character
+                                         (- (send interactions-text last-position) 1))))
+                (test:keystroke #\return))
+              
+              ; stuff the load command into the REPL 
+              (for-each test:keystroke
+                        (string->list (format "(load ~s)" tmp-load-short-filename)))
+              
+              ; record current text position, then stuff a CR into the REPL
+              (let ([load-text-start (+ 1 (send interactions-text last-position))])
+                
+                (test:keystroke #\return)
+                
+                (when breaking-test?
+                  (test:button-push (send drscheme-frame get-break-button)))
+                (wait-for-execute)
+                
+                (when load-answer
+                  (let* ([load-text-end (- (get-int-pos) 1)] ;; subtract one to eliminate newline
+                         [received-load 
+                          (fetch-output drscheme-frame load-text-start load-text-end)])
+                    
+                    ; check load text 
+                    (unless (string=? received-load formatted-load-answer)
+                      (printf "FAILED load test for ~s\n  expected: ~s\n       got: ~s\n"
+                              program formatted-load-answer received-load)))))
+              
+              (teardown)
+              
+              ; check for edit-sequence
+              (when (repl-in-edit-sequence?)
+                (printf "FAILED: repl in edit-sequence")
+                (escape)))))))
+    
+    (define (run-test-in-language-level raw?)
+      (let ([level (list "PLT" (regexp "Graphical"))])
+        (printf "running ~s (raw? ~a) tests\n" level raw?)
+        (if raw?
+            (begin
+              (set-language-level! level #f)
+              (test:set-radio-box-item! "No debugging or profiling")
+              (let ([f (get-top-level-focus-window)])
+                (test:button-push "OK")
+                (wait-for-new-frame f)))
+            (set-language-level! level))
+        
+        (test:new-window definitions-canvas)
+        (clear-definitions drscheme-frame)
+        (do-execute drscheme-frame)
+        (let/ec escape 
+          (for-each (run-single-test (get-int-pos) escape raw?) test-data))))
+    
+    (define (kill-tests)
+      (clear-definitions drscheme-frame)
+      (do-execute drscheme-frame)
+      
+      (test:menu-select "Scheme" "Kill")
+      
+      (let ([win (wait-for-new-frame drscheme-frame)])
+        (test:button-push "OK")
+        (let ([drs2 (wait-for-new-frame win)])
+          (unless (eq? drs2 drscheme-frame)
+            (error 'kill-test1 "expected original drscheme frame to come back to the front"))))
+      
+      (type-in-definitions drscheme-frame "(kill-thread (current-thread))")
+      (do-execute drscheme-frame #f)
+      (let ([win (wait-for-new-frame drscheme-frame)])
+        (test:button-push "OK")
+        (let ([drs2 (wait-for-new-frame win)])
+          (unless (eq? drs2 drscheme-frame)
+            (error 'kill-test2 "expected original drscheme frame to come back to the front"))))
+      
+      (clear-definitions drscheme-frame)
+      (do-execute drscheme-frame)
+      (type-in-definitions
+       drscheme-frame
+       "(define (f) (queue-callback f) (error 'ouch)) (f)")
+      (do-execute drscheme-frame #f)
+      (sleep 1/2)
+      (test:menu-select "Scheme" "Kill")
+      (let ([win (wait-for-new-frame drscheme-frame null 360)])
+        (test:button-push "OK")
+        (let ([drs2 (wait-for-new-frame win)])
+          (unless (eq? drs2 drscheme-frame)
+            (error
+             'kill-test3
+             "expected original drscheme frame to come back to the front"))))
+      (when (send (send drscheme-frame get-interactions-text) local-edit-sequence?)
+        (error 'kill-test3 "in edit-sequence")))
+    
+    
+    ;; run the tests
+    
+    (when (file-exists? tmp-load-filename)
+      (delete-file tmp-load-filename))
+    (save-drscheme-window-as tmp-load-filename)
+    
+    ;(set-language-level! (list "PLT" "Graphical (MrEd)")) (kill-tests)
+    
+    (run-test-in-language-level #f)
+    (run-test-in-language-level #t)))
diff --git a/collects/tests/drscheme/run-tests.ss b/collects/tests/drscheme/run-tests.ss
new file mode 100644
index 0000000000..0558930cf6
--- /dev/null
+++ b/collects/tests/drscheme/run-tests.ss
@@ -0,0 +1,145 @@
+;; load this file as a tool to run the test suites
+
+(module run-tests mzscheme
+  (require (lib "class.ss")
+           (lib "mred.ss" "mred")
+           (lib "framework.ss" "framework"))
+
+  (provide ask-test-suite)
+  
+  (define test-thread
+    (let ([kill-old void])
+      (lambda (test thunk)
+        (kill-old)
+        (let ([thread-desc (thread
+                            (lambda ()
+                              (printf "t>> ~a started~n" test)
+                              (thunk)
+                              (printf "t>> ~a finished~n" test)))])
+          (set! kill-old
+                (lambda ()
+                  (when (thread-running? thread-desc)
+                    (kill-thread thread-desc)
+                    (printf "t>> killed ~a~n" test))))))))
+      
+  (define all-tests (map symbol->string (load (build-path (collection-path "tests" "drscheme")
+                                                          "README"))))
+  
+  (define (make-repl)
+    (test-thread
+     "REPL"
+     (lambda ()
+       (let ([startup "~/.mzschemerc"])
+         (when (file-exists? startup)
+           (load startup)))
+       (case (system-type)
+         [(windows macos)
+          (graphical-read-eval-print-loop (current-eventspace))]
+         [else
+          (read-eval-print-loop)]))))
+      
+  (define (run-test-suite filename)
+    (test-thread
+     filename
+     (lambda ()
+       ((dynamic-require `(lib ,filename "tests" "drscheme") 'run-test)))))
+      
+  (define current-test-suite-frame #f)
+      
+  (define test-suite-frame%
+    (class frame%
+      (define/override (on-size w h)
+        (preferences:set 'drscheme:test-suite:frame-width w)
+        (preferences:set 'drscheme:test-suite:frame-height h))
+      (define/augment (on-close)
+        (inner (void) on-close)
+        (set! current-test-suite-frame #f))
+      (super-new)))
+
+  (define (ask-test-suite parent)
+    (if current-test-suite-frame
+        (send current-test-suite-frame show #t)
+        (let* ([drscheme-test-dir (collection-path "tests" "drscheme")]
+               [frame (make-object test-suite-frame% 
+                        "Test Suites"
+                        parent
+                        (preferences:get 'drscheme:test-suite:frame-width)
+                        (preferences:get 'drscheme:test-suite:frame-height))]
+               [panel (make-object vertical-panel% frame)]
+               [top-panel (make-object vertical-panel% panel)]
+               [bottom-panel (make-object horizontal-panel% panel)])
+          (send top-panel stretchable-height #f)
+          (make-object button%
+            "REPL" 
+            bottom-panel
+            (lambda (_1 _2)
+              (send frame show #f)
+              (make-repl)))
+          
+          (when drscheme-test-dir
+            (send top-panel stretchable-height #t)
+            (send bottom-panel stretchable-height #f)
+            (letrec ([lb (make-object list-box%
+                           #f
+                           all-tests
+                           top-panel
+                           (lambda (b e)
+                             (when (eq? (send e get-event-type) 'list-box-dclick)
+                               (run-test-suite-callback))))]
+                     [run-test-suite-callback
+                      (lambda ()
+                        (let ([selection (send lb get-selection)])
+                          (when selection
+                            (send frame show #f)
+                            (let ([test (list-ref all-tests selection)])
+                              (preferences:set
+                               'drscheme:test-suite:file-name
+                               test)
+                              (run-test-suite
+                               test)))))])
+              
+	      ;; set values from preferences
+              (let* ([test-suite (preferences:get 'drscheme:test-suite:file-name)]
+                     [num (send lb find-string test-suite)])
+                (when num
+                  (send lb set-string-selection test-suite)
+                  (send lb set-first-visible-item num)
+                  (test:run-interval (preferences:get 'drscheme:test-suite:run-interval))))
+              
+              (send
+               (make-object button%
+                 "Run Test Suite"
+                 bottom-panel
+                 (lambda (_1 _2)
+                   (run-test-suite-callback))
+                 '(border))
+               focus))
+            
+            (let* ([pre-times (list 0 10 50 100 500)]
+                   [times (if (member (test:run-interval) pre-times)
+                              pre-times
+                              (append pre-times (list (test:run-interval))))]
+                   [choice
+                    (make-object choice%
+                      "Run Interval"
+                      (map number->string times)
+                      top-panel
+                      (lambda (choice event)
+                        (let ([time (list-ref times (send choice get-selection))])
+                          (preferences:set 'drscheme:test-suite:run-interval time)
+                          (test:run-interval time))))])
+              (send choice set-selection
+                    (let loop ([l times]
+                               [n 0])
+                      (if (= (car l) (test:run-interval))
+                          n
+                          (loop (cdr l)
+                                (+ n 1)))))))
+          (make-object button%
+            "Cancel" 
+            bottom-panel
+            (lambda (_1 _2)
+              (send frame show #f)))
+          (make-object grow-box-spacer-pane% bottom-panel)
+          (send frame show #t)
+          (set! current-test-suite-frame frame)))))
diff --git a/collects/tests/drscheme/sample-solutions-one-window.ss b/collects/tests/drscheme/sample-solutions-one-window.ss
new file mode 100644
index 0000000000..fc85761949
--- /dev/null
+++ b/collects/tests/drscheme/sample-solutions-one-window.ss
@@ -0,0 +1,252 @@
+
+(module sample-solutions-one-window mzscheme
+  (require "drscheme-test-util.ss"
+           (lib "gui.ss" "tests" "utils")
+           (lib "class.ss")
+           (lib "list.ss")
+           (lib "file.ss")
+           (lib "mred.ss" "mred")
+           (lib "framework.ss" "framework")
+           (prefix fw: (lib "framework.ss" "framework")))
+  
+  (provide run-test)
+  
+  (define (section->language section)
+    (cond
+      [(section . <= . 12) '("How to Design Programs" "Beginning Student")]
+      [(section . <= . 19) '("How to Design Programs" "Intermediate Student")]
+      [(section . <= . 29) '("How to Design Programs" "Intermediate Student with lambda")]
+      [else '("How to Design Programs" "Advanced Student")]))
+
+  (define sample-solutions-teachpack-filename
+    (build-path (collection-path "tests" "drscheme") "sample-solutions-testsuite-tp.scm"))
+  
+  (define sample-solutions-dir
+    (let ([try1
+           (collection-path "solutions")]
+          [try2
+           (build-path (collection-path "mzlib")
+                       'up
+                       'up
+                       'up
+                       "robby"
+                       "collects"
+                       "solutions")])
+      (cond
+        [(directory-exists? try1) try1]
+        [else try2])))
+  
+  (unless (directory-exists? sample-solutions-dir)
+    (error 'sample-solutions.ss "expected directory ~s to exist" sample-solutions-dir))
+  
+  (set! sample-solutions-dir (normalize-path sample-solutions-dir))
+  
+  (define toc (call-with-input-file (build-path sample-solutions-dir "toc.ss") read))
+  (define default-toc-entry '(#f ()))
+  
+  (define labels
+    (let* ([all-info (call-with-input-file (build-path (collection-path "solutions") 
+                                                       'up 'up "proj" "book" "solutions"
+                                                       "labels.scm") read)]
+           [ex-labels (filter (lambda (x) (and (string=? (substring (car x) 0 3) "ex:")
+                                               (> (string-length (car x)) 3)))
+                              all-info)])
+      (map (lambda (x) 
+             (cons (string-append (substring (car x) 3 (string-length (car x))) ".scm")
+                   (cdr x)))
+           ex-labels)))
+  
+  (define (filename->section filename)
+    (let* ([label (car (memf (lambda (x) (string=? (car x) filename)) labels))]
+           [section (car (cadr label))])
+      section))
+         
+  (define sample-solutions
+    (quicksort
+     (filter (lambda (x) (and 
+                          (> (string-length x) 3)
+                          (string=? "scm" (substring x (- (string-length x) 3) (string-length x)))
+                          (memf (lambda (y) (string=? (car y) x)) labels)))
+             (directory-list sample-solutions-dir))
+     (lambda (fx fy)
+       (< (filename->section fx)
+          (filename->section fy)))))
+
+  (define separator-sexp "should be")
+  
+  (define (test-single-file filename)
+    (let* ([toc-entry (let ([lookup (assoc (string->symbol filename) toc)])
+                        (if lookup
+                            (cdr lookup)
+                            default-toc-entry))]
+           [section (filename->section filename)]
+           [language (section->language section)]
+           [errors-ok? (car toc-entry)]
+           [teachpacks (cadr toc-entry)])
+      (let* ([drs-frame (wait-for-drscheme-frame)]
+             [definitions-text (send drs-frame get-definitions-text)]
+             [interactions-text (send drs-frame get-interactions-text)])
+        
+        (run-one/sync
+         (lambda ()
+           ;; update the program (cheat to hack around gc bug -- should really use file|open)
+           ;; (this is also much more efficient, tho)
+           (send definitions-text load-file (build-path sample-solutions-dir filename))))
+        ;; only bother changing the language dialog when necessary.
+        (unless (string=?
+                 (run-one/sync
+                  (lambda ()
+                    (send interactions-text get-text
+                          (send interactions-text paragraph-start-position 1)
+                          (send interactions-text paragraph-end-position 1))))
+                 (format "Language: ~a." (car (last-pair language))))
+          (set-language-level! language))
+        ;; only bother changing the teachpacks when necessary.
+        (let* ([get-full-path
+                (lambda (teachpack)
+                  (cond
+                    [(absolute-path? teachpack)
+                     (normal-case-path 
+                      (normalize-path
+                       teachpack))]
+                    [else
+                     (normal-case-path
+                      (normalize-path
+                       (build-path
+                        (collection-path "mzlib") 'up 'up
+                        "teachpack" "htdp" teachpack)))]))]
+               [teachpack-should-be
+                (apply string-append 
+                       (map (lambda (tp) (format "Teachpack: ~a.~n" (get-full-path tp)))
+                            (cons
+                             sample-solutions-teachpack-filename
+                             teachpacks)))]
+               [teachpack-is
+                (run-one/sync
+                  (lambda ()
+                    (send interactions-text get-text
+                          (send interactions-text paragraph-start-position 2)
+                          (send interactions-text paragraph-start-position 
+                                (+ 2 (length teachpacks) 1)))))] ;; add 1 for the always there teachpack
+               [teachpacks-already-set? (string=? teachpack-should-be teachpack-is)])
+          (unless teachpacks-already-set?
+            (fw:test:menu-select "Language" "Clear All Teachpacks")
+            (use-get/put-dialog
+             (lambda ()
+               (fw:test:menu-select "Language" "Add Teachpack..."))
+             sample-solutions-teachpack-filename)
+            (for-each (lambda (teachpack)
+                        (use-get/put-dialog
+                         (lambda ()
+                           (fw:test:menu-select "Language" "Add Teachpack..."))
+                         (get-full-path teachpack)))
+                      teachpacks)))
+        (do-execute drs-frame)
+        
+        ;; kill the program, but only when it opens windows
+        (let ([open-user-windows?
+               (parameterize ([current-eventspace (send interactions-text get-user-eventspace)])
+                 (not (null? (get-top-level-windows))))])
+          (when #t #;open-user-windows?
+            (printf "killing\n")
+            (let ([cust (send interactions-text get-user-custodian)])
+              (run-one/sync
+               (lambda ()
+                 (custodian-shutdown-all cust))))
+            (let ([wait-for-kill-window
+                   (lambda ()
+                     (let ([f (get-top-level-focus-window)])
+                       (and f (equal? (send f get-label)
+                                      "Evaluation Terminated"))))])
+              (poll-until wait-for-kill-window)
+              (fw:test:button-push "OK")
+              (wait-for-drscheme-frame #f)
+              (printf "killed\n"))))
+        
+        (check-for-red-text filename drs-frame)
+        
+        ;; still check equal pairs when there is a sanctioned error.
+        (cond
+          [(and (not errors-ok?)
+                (has-error? drs-frame))
+           =>
+           (lambda (err-msg)
+             (printf "ERROR: ~a: found error, but should be no errors (section ~a):~n  ~a\n  teachpacks: ~a\n"
+                     filename
+                     section
+                     err-msg
+                     teachpacks))]
+          [else
+           (let* ([output (fetch-output drs-frame)]
+                  [port (open-input-string output)])
+             (let loop ([last #f]
+                        [equal-count 1])
+               (let ([sexp (with-handlers ([(lambda (exn) #t)
+                                            (lambda (exn) exn)])
+                             (read port))])
+                 (unless (eof-object? sexp)
+                   (cond
+                     [(and (not last) (equal? sexp separator-sexp))
+                      (printf "ERROR: ~a: found = as first sexp~n" filename)]
+                     [(and last (equal? separator-sexp sexp))
+                      (let ([after (with-handlers ([(lambda (exn) #t)
+                                                    (lambda (exn) exn)])
+                                     (read port))])
+                        (unless (equal? after last)
+                          (printf "ERROR: ~a: pair #~a mismatched.\n     got ~s\nexpected ~s\nteachpacks: ~a\n"
+                                  filename equal-count 
+                                  (if (exn? last) (exn-message last) last)
+                                  (if (exn? after) (exn-message after) after)
+                                  teachpacks))
+                        (loop after (+ equal-count 1)))]
+                     [else (loop sexp equal-count)])))))]))))
+  
+  (define (check-for-red-text filename drs-frame)
+    (when (run-one/sync
+           (lambda ()
+             (send drs-frame get-test-coverage-info-visible?)))
+      (printf "ERROR: ~a: test coverage shows uncovered code\n"
+              filename)))
+  
+  ;; has-test-coverage-annotations? : text -> (union (list ...) #f)
+  (define (has-test-coverage-annotations? definitions-text)
+    (let loop ([snip (send definitions-text find-first-snip)]
+               [black #f]
+               [red #f])
+      (cond
+        [snip
+         (let* ([style (send snip get-style)]
+                [foreground (send style get-foreground)])
+           (cond
+             [(black? foreground)
+              (if red
+                  (list (get-snip-info definitions-text snip) red)
+                  (loop (send snip next) (get-snip-info definitions-text snip) red))]
+             [(red? foreground)
+              (if black
+                  (list black (get-snip-info definitions-text snip))
+                  (loop (send snip next) black (get-snip-info definitions-text snip)))]
+             [else
+              (loop (send snip next) black red)]))]
+        [else #f])))
+  
+  (define (get-snip-info definitions-text snip)
+    (let* ([pos (send definitions-text get-snip-position snip)]
+           [para (send definitions-text position-paragraph pos)]
+           [para-start (send definitions-text paragraph-start-position para)])
+      (list (+ para 1)
+            (- pos para-start))))
+  
+  (define red-color (make-object color% "firebrick"))
+  (define (red? c)
+    (and (= (send c red) (send red-color red))
+         (= (send c green) (send red-color green))
+         (= (send c blue) (send red-color blue))))
+
+  (define (black? c)
+    (and (zero? (send c red))
+         (zero? (send c green))
+         (zero? (send c blue))))
+    
+  (define (run-test)
+    (for-each test-single-file sample-solutions)))
\ No newline at end of file
diff --git a/collects/tests/drscheme/sample-solutions-testsuite-tp.scm b/collects/tests/drscheme/sample-solutions-testsuite-tp.scm
new file mode 100644
index 0000000000..6a105d6b79
--- /dev/null
+++ b/collects/tests/drscheme/sample-solutions-testsuite-tp.scm
@@ -0,0 +1,38 @@
+(module sample-solutions-testsuite-tp mzscheme
+  (provide require-library)
+  (require (lib "include.ss"))
+  
+  (define-syntax require-library
+    (let ([cache null])
+      (lambda (stx)
+        (syntax-case stx ()
+          [(_ fn-stx lib-stx)
+           (let ([fn (syntax-object->datum (syntax fn-stx))]
+                 [lib (syntax-object->datum (syntax lib-stx))])
+             (unless (equal? lib "solutions")
+               (raise-syntax-error
+                #f
+                "expected `solutions' collection as second argument to require-library"
+                stx))
+             (unless (string? fn)
+               (raise-syntax-error
+                #f
+                "expected string constant as first argument to require-library"
+                stx))
+             (if (member fn cache)
+                 (syntax (void))
+                 (with-syntax ([full-fn 
+                                (bytes->string/utf-8
+                                 (path->bytes
+                                  (build-path 
+                                   (with-handlers ([exn:fail:filesystem?
+                                                    (lambda (x)
+                                                      (current-load-relative-directory))])
+                                     (collection-path "solutions"))
+                                   fn)))]
+                               [orig stx])
+                   (set! cache (cons fn cache))
+                   (syntax
+                    (begin
+                      (include-at/relative-to orig orig full-fn)
+                      (void))))))])))))
diff --git a/collects/tests/drscheme/stepper-test.ss b/collects/tests/drscheme/stepper-test.ss
new file mode 100644
index 0000000000..917b5493b6
--- /dev/null
+++ b/collects/tests/drscheme/stepper-test.ss
@@ -0,0 +1,674 @@
+
+(module stepper-test mzscheme
+  (require (lib "mred.ss" "mred")
+           (lib "class.ss")
+           "drscheme-test-util.ss"
+           (lib "gui.ss" "tests" "utils")
+           (lib "framework.ss" "framework")
+           (lib "pretty.ss"))
+  
+  (provide run-test)
+  
+  (define next-button-label "Step >")
+  (define no-more-steps-message "All of the definitions have been successfully evaluated.")
+  
+  ;; type contents = (listof (union snip string contents))
+  ;; type error = (make-error string)
+  ;; type step = (make-step contents contents (union error contents))
+  (define-struct step (definitions before after) (make-inspector))
+  (define-struct err (message) (make-inspector))
+
+  ;; type program-spec = (union string (make-file string))
+  (define-struct file (name))
+  
+  (define current-program-id (make-parameter 'current-program-id-unset))
+  (define failure-escape (make-parameter 'failure-escape-unset))
+  
+  (define sample-solutions-directory "/home/robby/unison/collects/solutions")
+  
+  (define to-skip-to "average-price.scm")
+  
+  (define (run-test)
+    (run-fully-specified-tests)
+    
+    #|
+    (set-language-level! (list "How to Design Programs" "Beginning Student with List Abbreviations"))
+    (run-string-test "(define (f x) (* x 2))\n(+ 1 (f (+ 1 1)))")
+    (run-string-test "(sqrt 2)")
+    (run-string-test "(car)")
+    
+    (run-sample-solution-tests)
+    |#
+    )
+ 
+  (define (run-fully-specified-tests)
+    (set-language-level! (list "How to Design Programs" "Beginning Student"))
+    (beginner-tests/no-list)
+    (test-transcript '(cons 1 (cons 2 (list 3 4 5)))
+                     '(cons 1 (cons 2 (cons 3 (cons 4 (cons 5 empty))))))
+    
+    (set-language-level! (list "How to Design Programs" "Beginning Student with List Abbreviations"))
+    (beginner-tests/no-list)
+    (test-transcript '(cons 1 (cons 2 (list 3 4 5)))
+                     '(cons 1 (list 2 3 4 5))
+                     '(list 1 2 3 4 5)))
+  
+  (define (beginner-tests/no-list)
+    (test-transcript '(+ 1 2) 3)
+    (test-transcript
+     '(cond [(= 1 1) (cond [(= 1 2) 3] [else 4])])
+     '(cond [true (cond [(= 1 2) 3] [else 4])])
+     '(cond [(= 1 2) 3] [else 4])
+     '(cond [false 3] [else 4])
+     '(cond [else 4])
+     '4)
+    (test-transcript
+     '(if (= 1 1) (if (= 1 2) 4 (if (= 1 1) 5 6)) 7)
+     '(if true (if (= 1 2) 4 (if (= 1 1) 5 6)) 7)
+     '(if (= 1 2) 4 (if (= 1 1) 5 6))
+     '(if false 4 (if (= 1 1) 5 6))
+     '(if (= 1 1) 5 6)
+     '(if true 5 6)
+     '5)
+    (test-transcript
+     '(and (or true false)
+           (or false false true)
+           (and true true)
+           false)
+     '(and true
+           (or false false true)
+           (and true true)
+           false)
+     '(and true
+           true
+           (and true true)
+           false)
+     '(and true
+           true
+           true
+           false)
+     'false)
+
+    (fully-specified-test
+     "(+ #i1.2 1)"
+     (make-step '() '("(+ #i1.2 1)") '("#i2.2"))
+     (make-step '("#i2.2") '() '()))
+    
+    (test-transcript/defns
+     (list '(define (f x) (+ x 1)))
+     '(f 1)
+     '(+ 1 1)
+     '2)
+
+    (test-transcript
+     '(+ 1 (posn-x (make-posn (+ 1 2) (+ 3 4))))
+     '(+ 1 (posn-x (make-posn 3 (+ 3 4))))
+     '(+ 1 (posn-x (make-posn 3 7)))
+     '(+ 1 3)
+     '4)
+    
+    (test-transcript/defns
+     (list '(define-struct s (a b)))
+     '(if (s? (make-s 'a 'b))
+          (s-a (make-s 'c 'd))
+          'ack)
+     '(if true
+          (s-a (make-s 'c 'd))
+          'ack)
+     '(s-a (make-s 'c 'd))
+     ''c)
+
+    (test-transcript/defns
+     (list '(define x 1))
+     '(+ x x)
+     '(+ 1 x)
+     '(+ 1 1)
+     '2)
+    
+    (test-transcript/defns
+     (list '(define-struct con (hd tl))
+           '(define-struct mt ())
+           '(define (sum l)
+              (cond
+                [(mt? l) 0]
+                [(con? l) (+ (con-hd l) (sum (con-tl l)))])))
+     '(sum (make-con 5 (make-con 6 (make-con 7 (make-mt)))))
+     '(cond
+        [(mt? (make-con 5 (make-con 6 (make-con 7 (make-mt))))) 0]
+        [(con? (make-con 5 (make-con 6 (make-con 7 (make-mt))))) 
+         (+ (con-hd (make-con 5 (make-con 6 (make-con 7 (make-mt)))))
+            (sum (con-tl (make-con 5 (make-con 6 (make-con 7 (make-mt)))))))])
+     '(cond
+        [false 0]
+        [(con? (make-con 5 (make-con 6 (make-con 7 (make-mt))))) 
+         (+ (con-hd (make-con 5 (make-con 6 (make-con 7 (make-mt)))))
+            (sum (con-tl (make-con 5 (make-con 6 (make-con 7 (make-mt)))))))])
+     '(cond
+        [(con? (make-con 5 (make-con 6 (make-con 7 (make-mt))))) 
+         (+ (con-hd (make-con 5 (make-con 6 (make-con 7 (make-mt)))))
+            (sum (con-tl (make-con 5 (make-con 6 (make-con 7 (make-mt)))))))])
+     '(cond
+        [true
+         (+ (con-hd (make-con 5 (make-con 6 (make-con 7 (make-mt)))))
+            (sum (con-tl (make-con 5 (make-con 6 (make-con 7 (make-mt)))))))])
+     '(+ (con-hd (make-con 5 (make-con 6 (make-con 7 (make-mt)))))
+         (sum (con-tl (make-con 5 (make-con 6 (make-con 7 (make-mt)))))))
+     '(+ 5
+         (sum (con-tl (make-con 5 (make-con 6 (make-con 7 (make-mt)))))))
+     '(+ 5
+         (sum (make-con 6 (make-con 7 (make-mt)))))
+     '(+ 5
+         (cond
+           [(mt? (make-con 6 (make-con 7 (make-mt)))) 0]
+           [(con? (make-con 6 (make-con 7 (make-mt)))) 
+            (+ (con-hd (make-con 6 (make-con 7 (make-mt))))
+               (sum (con-tl (make-con 6 (make-con 7 (make-mt))))))]))
+     '(+ 5
+         (cond
+           [false 0]
+           [(con? (make-con 6 (make-con 7 (make-mt)))) 
+            (+ (con-hd (make-con 6 (make-con 7 (make-mt))))
+               (sum (con-tl (make-con 6 (make-con 7 (make-mt))))))]))
+     '(+ 5
+         (cond
+           [(con? (make-con 6 (make-con 7 (make-mt)))) 
+            (+ (con-hd (make-con 6 (make-con 7 (make-mt))))
+               (sum (con-tl (make-con 6 (make-con 7 (make-mt))))))]))
+     '(+ 5
+         (cond
+           [true
+            (+ (con-hd (make-con 6 (make-con 7 (make-mt))))
+               (sum (con-tl (make-con 6 (make-con 7 (make-mt))))))]))
+     '(+ 5
+         (+ (con-hd (make-con 6 (make-con 7 (make-mt))))
+            (sum (con-tl (make-con 6 (make-con 7 (make-mt)))))))
+     '(+ 5
+         (+ 6
+            (sum (con-tl (make-con 6 (make-con 7 (make-mt)))))))
+     '(+ 5
+         (+ 6
+            (sum (make-con 7 (make-mt)))))
+     '(+ 5
+         (+ 6
+            (cond
+              [(mt? (make-con 7 (make-mt))) 0]
+              [(con? (make-con 7 (make-mt))) 
+               (+ (con-hd (make-con 7 (make-mt))) 
+                  (sum (con-tl (make-con 7 (make-mt)))))])))
+     '(+ 5
+         (+ 6
+            (cond
+              [false 0]
+              [(con? (make-con 7 (make-mt))) 
+               (+ (con-hd (make-con 7 (make-mt))) 
+                  (sum (con-tl (make-con 7 (make-mt)))))])))
+     '(+ 5
+         (+ 6
+            (cond
+              [(con? (make-con 7 (make-mt))) 
+               (+ (con-hd (make-con 7 (make-mt))) 
+                  (sum (con-tl (make-con 7 (make-mt)))))])))
+     '(+ 5
+         (+ 6
+            (cond
+              [true
+               (+ (con-hd (make-con 7 (make-mt))) 
+                  (sum (con-tl (make-con 7 (make-mt)))))])))
+     '(+ 5
+         (+ 6
+            (+ (con-hd (make-con 7 (make-mt))) 
+               (sum (con-tl (make-con 7 (make-mt)))))))
+     '(+ 5
+         (+ 6
+            (+ 7
+               (sum (con-tl (make-con 7 (make-mt)))))))
+     '(+ 5
+         (+ 6
+            (+ 7
+               (sum (make-mt)))))
+     '(+ 5
+         (+ 6
+            (+ 7
+               (cond
+                [(mt? (make-mt)) 0]
+                [(con? (make-mt)) (+ (con-hd (make-mt)) (sum (con-tl (make-mt))))]))))
+     '(+ 5
+         (+ 6
+            (+ 7
+               (cond
+                [true 0]
+                [(con? (make-mt)) (+ (con-hd (make-mt)) (sum (con-tl (make-mt))))]))))
+     '(+ 5 (+ 6 (+ 7 0)))
+     '(+ 5 (+ 6 7))
+     '(+ 5 13)
+     '18))
+     
+  (define (fully-specified-test init . steps)
+    (let ([actual (step-and-extract-program init)])
+      (unless (equal? actual steps)
+        (printf "FAILED: ~s\nexpected: ~s\n     got: ~s\n" init steps actual))))
+
+  (define (test-transcript/defns defns init . sexp-steps)
+    (let* ([str-defns (apply string-append (map (lambda (x) (string-append (to-string x) "\n")) defns))]
+           [actual-steps (step-and-extract-program (format "~a~a" str-defns (to-string init)))]
+           [failed
+            (lambda (msg . args)
+              (printf "FAILED: ~a\ndefns: ~s\nexpected: ~s\nactual: ~s\n\n" 
+                      (apply format msg args)
+                      defns
+                      (cons init sexp-steps)
+                      actual-steps))])
+      (let loop ([steps actual-steps]
+                 [last init]
+                 [sexps sexp-steps]
+                 [n 0])
+        (cond
+          [(and (null? sexps) 
+                (not (null? steps))
+                (null? (cdr steps)))
+           (let ([step (car steps)])
+             (unless (ws-equal? (stringify (step-definitions step))
+                                (string-append
+                                 str-defns
+                                 "\n"
+                                 (to-string last)))
+               (failed "mismatch at last step ~s and ~s"
+                       (step-definitions step)
+                       last))
+             (unless (and (equal? '() (step-before step))
+                          (equal? '() (step-after step)))
+               (failed "expected empty before and after steps in the last step")))]
+          [(or (null? steps) (null? sexps))
+           (failed "different length")]
+          [else
+           (let ([step (car steps)]
+                 [sexp (car sexps)])
+             (cond
+               [(not (ws-equal? (stringify (step-definitions step)) str-defns))
+                (failed "mismatch at ~a defnitions ~s and ~s" 
+                        n
+                        (stringify (step-definitions step))
+                        str-defns)]
+               [(not (ws-equal? (stringify (step-before step))
+                                (to-string last)))
+                (failed "mismatch at ~a before ~s and ~s"
+                        n
+                        (stringify (step-before step))
+                        last)]
+               [(not (ws-equal? (stringify (step-after step))
+                                (to-string sexp)))
+                (failed "mismatch at ~a after ~s and ~s"
+                        n
+                        (stringify (step-after step))
+                        sexp)]
+               [else
+                (loop (cdr steps)
+                      sexp
+                      (cdr sexps)
+                      (+ n 1))]))]))))
+
+  (define (to-string s)
+    (let ([sp (open-output-string)])
+      (parameterize ([pretty-print-columns 'infinity]
+                     [current-output-port sp])
+        (pretty-print s))
+      (get-output-string sp)))
+  
+  (define (stringify x)
+    (unless (andmap string? x)
+      (error 'stringify "cannot: ~s" x))
+    (apply string-append x))
+  
+  (define (test-transcript init . sexp-steps)
+    (apply test-transcript/defns '() init sexp-steps))
+  
+  (define (ws-equal? s1 s2)
+    (equal? (regexp-replace* "[ \t\n]+"
+                             (string-append " " s1 " ")
+                             " ")
+            (regexp-replace* "[ \t\n]+"
+                             (string-append " " s2 " ")
+                             " ")))
+                       
+  (define (run-sample-solution-tests)
+    (let ([found-it? #f])
+      (for-each
+       (lambda (file) 
+         (when (equal? file to-skip-to)
+           (set! found-it? #t))
+         (when found-it?
+           (run-file-test (build-path sample-solutions-directory file))))
+       (directory-list sample-solutions-directory))))
+  
+  ;; run-file-test : string -> void
+  (define (run-file-test filename)
+    (let/ec k
+      (parameterize ([current-program-id filename]
+                     [failure-escape k])
+        (check-steps
+         (make-file filename)
+         (step-and-extract-program (make-file filename))))))
+  
+  ;; run-string-test : string -> void
+  ;; runs the test in the string.
+  (define (run-string-test prog)
+    (let/ec k
+      (parameterize ([current-program-id prog]
+                     [failure-escape k])
+        (check-steps
+         prog
+         (step-and-extract-program prog)))))
+  
+  ;; simple-failure : (union #f step) string any ... -> beta
+  ;; indicates that this one test failed, but the stepper may still
+  ;; be steppable, so just jumps out of this one test.
+  (define (simple-failure step message . args)
+    (printf "FAILED TEST ~s:\n" (current-program-id))
+    (when step (printf "~s\n" step))
+    (printf "~a\n\n" (apply format message args))
+    ((failure-escape)))
+  
+  ;; check-steps : program-spec (listof step) -> void
+  ;; executes each of the steps in DrScheme and raises
+  ;; an exception if something doesn't match up.
+  (define (check-steps program steps)
+    (let* ([drs-frame (wait-for-drscheme-frame)]
+           [defs-text (send drs-frame get-definitions-text)])
+      (let loop ([last-results #f]
+                 [steps steps])
+        (cond
+          [(null? steps)
+           (clear-definitions drs-frame)
+           (type-in-definitions drs-frame ";; full prog\n")
+           (set-definitions-to-program drs-frame program)
+           (do-execute drs-frame)
+           (let ([prog-results (fetch-output drs-frame)])
+             
+             ;; can only check subset here, since we may have stopped stepping early
+             (check-subset-results #f last-results prog-results))]
+          [else
+           (let ([step (car steps)])
+             (clear-definitions drs-frame)
+             (dynamic-wind
+              (lambda ()
+                (send defs-text begin-edit-sequence))
+              (lambda ()
+                (type-in-definitions drs-frame ";; before\n")
+                (insert-into-definitions drs-frame (step-definitions step))
+                (type-in-definitions drs-frame "\n")
+                (insert-into-definitions drs-frame (step-before step)))
+              (lambda ()
+                (send defs-text end-edit-sequence)))
+             (do-execute drs-frame)
+             (let ([before-results (fetch-output drs-frame)])
+               (when last-results
+                 (check-subset-results step last-results before-results))
+               (clear-definitions drs-frame)
+               (dynamic-wind
+                (lambda ()
+                  (send defs-text begin-edit-sequence))
+                (lambda ()
+                  (type-in-definitions drs-frame ";; after\n")
+                  (insert-into-definitions drs-frame (step-definitions step))
+                  (type-in-definitions drs-frame "\n")
+                  (unless (err? (step-after step))
+                    (insert-into-definitions drs-frame (step-after step))))
+                (lambda ()
+                  (send defs-text end-edit-sequence)))
+               (do-execute drs-frame)
+               (cond
+                 [(err? (step-after step))
+                  (let* ([pre-output (fetch-output drs-frame)]
+                         [add-newline? (and ((string-length pre-output) . >= . 1)
+                                            (not
+                                             (char=?
+                                              (string-ref pre-output 
+                                                          (- (string-length pre-output) 1))
+                                              #\newline)))]
+                         [after-results 
+                          (if add-newline?
+                              (string-append pre-output
+                                             "\n"
+                                             (err-message (step-after step)))
+                              (string-append pre-output
+                                             (err-message (step-after step))))])
+                    (check-same-results step before-results after-results)
+                    (unless (null? (cdr steps))
+                      (simple-failure #f "expected no more steps after an error, found ~s" (cdr steps)))
+                    (loop after-results null))]
+                 [else
+                  (let ([after-results (fetch-output drs-frame)])
+                    (check-same-results step before-results after-results)
+                    (loop after-results (cdr steps)))])))]))))
+
+  ;; insert-info-definitions : frame contents -> void
+  ;; technically, this function should probably type the
+  ;; contents into the definitions window, but that is
+  ;; considerably slower than just inserting it directly....
+  (define (insert-into-definitions drs-frame orig-contents)
+    (let ([defns (send drs-frame get-definitions-text)])
+      (let loop ([contents orig-contents])
+        (for-each
+         (lambda (content)
+           (cond
+             [(string? content)
+              (send defns insert content
+                    (send defns last-position)
+                    (send defns last-position))]
+             [(is-a? content snip%)
+              (send defns insert (send content copy)
+                    (send defns last-position)
+                    (send defns last-position))]
+             [(eq? content 'unknown)
+              (error 'insert-into-definitions "found unknown snip in ~e" orig-contents)]
+             [(list? content) 
+              ;; wrong thing. this flattens embedded editors
+              (loop content)]))
+         contents))))
+  
+  ;; check-subset-results : step string string -> void
+  ;; raises an error if s1 is not the beginning of s2.
+  (define (check-subset-results step s1 s2)
+    (unless (and (<= (string-length s1)
+                     (string-length s2))
+                 (string=? (substring s2 0 (string-length s1))
+                           s1))
+      (simple-failure step "expected\n  ~s\nto be the beginning of\n  ~s" s1 s2)))
+  
+  ;; check-same-results : step string string -> void
+  ;; raises an error if s1 is not s2.
+  (define (check-same-results step s1 s2)
+    (unless (string=? s1 s2)
+      (simple-failure step "expected\n  ~s\nto be the same as\n  ~s" s1 s2)))
+  
+  ;; step-and-extract-program : program-spec -> (listof step)
+  (define (step-and-extract-program program)
+    (let ([drs-frame (wait-for-drscheme-frame)])
+      (clear-definitions drs-frame)
+      (set-definitions-to-program drs-frame program)
+      (let* ([stepper-frame (start-stepper drs-frame)]
+             [steps (get-all-steps stepper-frame)])
+        (test:menu-select "File" "Close")
+        (let ([drs-frame1 (wait-for-new-frame stepper-frame)])
+          (unless (eq? drs-frame1 drs-frame)
+            (error 'step-and-extract "didn't get back to drscheme frame, got: ~e" drs-frame)))
+        steps)))
+
+  ;; set-definitions-to-program : program-spec -> void
+  (define (set-definitions-to-program drs-frame program)
+    (cond
+      [(string? program)
+       (type-in-definitions drs-frame program)]
+      [else
+       (let ([definitions-text (send drs-frame get-definitions-text)])
+         (send definitions-text load-file (file-name program))
+         (send definitions-text set-filename #f))]))
+
+  ;; start-stepper : frame -> frame
+  (define (start-stepper drs-frame)
+    (test:button-push (send drs-frame get-stepper-button))
+    (let ([stepper-frame (wait-for-new-frame drs-frame)])
+      stepper-frame))
+  
+  ;; get-all-steps : frame -> (listof step)
+  (define (get-all-steps stepper-frame)
+    (let* ([stepper-canvas (find-labelled-window #f editor-canvas% stepper-frame)]
+           [stepper-editor (poll-until (lambda () 
+                                         (let ([ed (send stepper-canvas get-editor)])
+                                           (if (and ed
+                                                    (not (send ed refresh-delayed?)))
+                                               ed
+                                               #f))))])
+      (cons (get-step stepper-frame stepper-editor)
+            (get-more-steps stepper-frame))))
+
+  ;; get-more-steps : stepper-frame -> (listof step)
+  ;; repeatedly push the next button to get out all of the steps
+  (define (get-more-steps stepper-frame)
+    (let ([next-button (find-labelled-window next-button-label button% stepper-frame)]
+          [stepper-canvas (find-labelled-window #f editor-canvas% stepper-frame)])
+      
+      ;; wait until we are in a "ready" state.
+      (poll-until (lambda () (send next-button is-enabled?))
+                  2
+                  void)
+      
+      ;; at most 200 steps
+      (let loop ([n 200])
+        (cond
+          [(zero? n) null]
+          [(send next-button is-enabled?)
+           (let* ([before-editor (poll-until (lambda () (send stepper-canvas get-editor)))]
+                  [new-step-available?
+                   ;; if there is a new editor and the next button is enabled,
+                   ;; we take that to mean that a new step has appeared.
+                   (lambda ()
+                     (let ([editor (send stepper-canvas get-editor)])
+                       (and editor
+                            (or (and (not (eq? before-editor editor))
+                                     (not (send editor refresh-delayed?))
+                                     (send next-button is-enabled?))
+                                (editor-has-stepper-done-message editor)))))])
+             (test:button-push next-button)
+             (poll-until new-step-available? 2 void)
+             (if (new-step-available?)
+                 (let ([step (get-step stepper-frame (send stepper-canvas get-editor))])
+                   (if step
+                       (cons step (loop (- n 1)))
+                       (loop (- n 1))))
+                 null))]
+          [else null]))))
+  
+  ;; editor-has-stepper-done-message : editor->boolean
+  (define (editor-has-stepper-done-message editor)
+    (string=? (send editor get-text 0 (send editor last-position))
+              no-more-steps-message))
+  
+  ;; get-step : frame editor -> (union step #f)
+  ;; extracts a step from the stepper window. Only returns #f for
+  ;; the "I'm done stepping" message that sometimes appears at the end.
+  (define (get-step stepper-frame stepper-editor)
+    (let ([canvas (find-labelled-window #f canvas% stepper-frame (lambda () #f))])
+      (when canvas
+        (error 'get-steps "stepper warning present!")))
+    (let* ([extraction (extract-from-editor stepper-editor)]
+           [step (separate-steps extraction)])
+      (unless step
+        (unless (equal? (list no-more-steps-message) extraction)
+          (error 'get-step "couldn't parse stepper window: ~s\n" extraction)))
+      step))
+      
+  ;; snips = (union (cons error snips) (cons snip snips) (cons snips snips) null)
+  ;; extract-from-editor : editor -> snips
+  (define (extract-from-editor editor)
+    (let loop ([snip (send editor find-first-snip)])
+      (cond
+        [(not snip)
+         null]
+        [(is-a? snip editor-snip%)
+         (let ([editor (send snip get-editor)])
+           (cons (cond
+                   [(not editor) '()]
+                   [(contains-error-message? editor)
+                    (let ([ans (extract-from-editor editor)])
+                      (unless (and (list? ans)
+                                   (andmap string? ans))
+                        (error 'extract-from-editor "couldn't parse error message: ~s" ans))
+                      (make-err (apply string-append ans)))]
+                   [else (extract-from-editor editor)])
+                 (loop (send snip next))))]
+        [(is-a? snip string-snip%)
+         (cons (send snip get-text 0 (send snip get-count) #t)
+               (loop (send snip next)))]
+        [(or (is-a? snip image-snip%)
+             (and (is-a? snip snip%)
+                  (method-in-interface? 'get-fraction-view (object-interface snip))))
+         (cons (send snip copy) (loop (send snip next)))]
+        [else (cons 'unknown
+                    (loop (send snip next)))])))
+  
+  ;; contains-error-message? : editor -> boolean
+  ;; returns #t if the editors contents look like an error message
+  (define (contains-error-message? editor)
+    (let ([snip (send editor find-first-snip)])
+      (and snip
+           (error-style? (send snip get-style)))))  
+  
+  ;; error-style? : style -> boolean
+  (define (error-style? style)
+    (let ([color (send style get-foreground)])
+      (and (color-equal? (send the-color-database find-color "red") color)
+           (memq (send style get-style) '(slant italic)))))
+  
+  ;; color-equal? : color color -> boolean
+  (define (color-equal? c1 c2)
+    (and (= (send c1 red) (send c2 red))
+         (= (send c1 green) (send c2 green))
+         (= (send c1 blue) (send c2 blue))))
+
+           
+  ;; separate-steps : snips -> (union step #f)
+  (define (separate-steps snips)
+    (let/ec k
+      (let ([program null]
+            [before null]
+            [after null]
+            [snips snips])
+        
+        (define (hunt-for-list id)
+          (let loop ()
+            (cond
+              [(null? snips) (k #f)]
+              [(eq? 'unknown (car snips)) (k #f)]
+              [(list? (car snips))
+               (begin0 (car snips)
+                       (set! snips (cdr snips)))]
+              [else (set! snips (cdr snips))
+                    (loop)])))
+        (define (hunt-for-list/error id)
+          (let loop ()
+            (cond
+              [(null? snips) (k #f)]
+              [(eq? 'unknown (car snips)) (k #f)]
+              [(or (err? (car snips)) (list? (car snips)))
+               (begin0 (car snips)
+                       (set! snips (cdr snips)))]
+              [else (set! snips (cdr snips))
+                    (loop)])))
+        (define (hunt-for-unknown id)
+          (let loop ()
+            (cond
+              [(null? snips) (k #f)]
+              [(eq? 'unknown (car snips)) (set! snips (cdr snips))]
+              [else (set! snips (cdr snips))
+                    (loop)])))
+        
+        (set! program (hunt-for-list 'program))
+        (hunt-for-unknown 'before)
+        (set! before (hunt-for-list 'before))
+        (hunt-for-unknown 'after)
+        (set! after (hunt-for-list/error 'after))
+        
+        (make-step program
+                   before
+                   after)))))
diff --git a/collects/tests/drscheme/syncheck-test.ss b/collects/tests/drscheme/syncheck-test.ss
new file mode 100644
index 0000000000..e48287d33b
--- /dev/null
+++ b/collects/tests/drscheme/syncheck-test.ss
@@ -0,0 +1,740 @@
+
+(module syncheck-test mzscheme
+  
+  (require "drscheme-test-util.ss"
+           (lib "gui.ss" "tests" "utils")
+           (lib "etc.ss")
+           (lib "class.ss")
+           (lib "list.ss")
+           (lib "file.ss")
+           (lib "mred.ss" "mred")
+           (lib "framework.ss" "framework")
+           (lib "text-string-style-desc.ss" "mrlib"))
+  
+  (provide run-test)
+  
+  ;; type str/ann = (list (union symbol string) symbol)
+  ;; type test = (make-test string
+  ;;                        (listof str/ann)
+  ;;                        (listof (cons (list number number) (listof (list number number)))))
+  (define-struct test (input expected arrows))
+  (define-struct (dir-test test) ())
+  
+  (define build-test
+    (opt-lambda (input expected [arrow-table '()])
+      (make-test input expected arrow-table)))
+  
+  ;; tests : (listof test)
+  (define tests
+    (list 
+     
+     (build-test "12345"
+                '(("12345" constant)))
+     (build-test "'abcdef"
+                '(("'" imported-syntax)
+                  ("abcdef" constant)))
+     (build-test "(define f 1)"
+                '(("("      default-color)
+                  ("define" imported-syntax)
+                  (" "      default-color)
+                  ("f"      lexically-bound-variable)
+                  (" "      default-color)
+                  ("1"      constant)
+                  (")"      default-color)))
+     (build-test "(lambda (x) x)"
+                '(("("      default-color)
+                  ("lambda" imported-syntax)
+                  (" ("     default-color)
+                  ("x"      lexically-bound-variable)
+                  (") "     default-color)
+                  ("x"      lexically-bound-variable)
+                  (")"      default-color))
+                (list '((9 10) (12 13))))
+     (build-test "(lambda x x)"
+                '(("("      default-color)
+                  ("lambda" imported-syntax)
+                  (" "      default-color)
+                  ("x"      lexically-bound-variable)
+                  (" "      default-color)
+                  ("x"      lexically-bound-variable)
+                  (")"      default-color))
+                (list '((8 9) (10 11))))
+     (build-test "(lambda (x . y) x y)"
+                '(("("      default-color)
+                  ("lambda" imported-syntax)
+                  (" ("     default-color)
+                  ("x"      lexically-bound-variable)
+                  (" . "    default-color)
+                  ("y"      lexically-bound-variable)
+                  (") "     default-color)
+                  ("x"      lexically-bound-variable)
+                  (" "      default-color)
+                  ("y"      lexically-bound-variable)
+                  (")"      default-color))
+                (list '((9 10) (16 17))
+                      '((13 14) (18 19))))
+     
+     (build-test "(case-lambda [(x) x])"
+                 '(("("           default-color)
+                   ("case-lambda" imported-syntax)
+                   (" [("         default-color)
+                   ("x"           lexically-bound-variable)
+                   (") "          default-color)
+                   ("x"           lexically-bound-variable)
+                   ("])"          default-color))
+                 (list '((15 16) (18 19))))
+     
+     (build-test "(if 1 2 3)"
+                '(("("  default-color)
+                  ("if" imported-syntax)
+                  (" "  default-color)
+                  ("1"  constant)
+                  (" "  default-color)
+                  ("2"  constant)
+                  (" "  default-color)
+                  ("3"  constant)
+                  (")"  default-color)))
+     (build-test "(if 1 2)"
+                '(("("  default-color)
+                  ("if" imported-syntax)
+                  (" "  default-color)
+                  ("1"  constant)
+                  (" "  default-color)
+                  ("2"  constant)
+                  (")"  default-color)))
+     
+     (build-test "(begin 1 2)"
+                '(("("     default-color)
+                  ("begin" imported-syntax)
+                  (" "     default-color)
+                  ("1"     constant)
+                  (" "     default-color)
+                  ("2"     constant)
+                  (")"     default-color)))
+     (build-test "(begin0 1 2)"
+                '(("("      default-color)
+                  ("begin0" imported-syntax)
+                  (" "      default-color)
+                  ("1"      constant)
+                  (" "      default-color)
+                  ("2"      constant)
+                  (")"      default-color)))
+     (build-test "(let ([x x]) x)"
+                '(("("   default-color)
+                  ("let" imported-syntax)
+                  (" ([" default-color)
+                  ("x"   lexically-bound-variable)
+                  (" "   default-color)
+                  ("x"   error)
+                  ("]) " default-color)
+                  ("x"   lexically-bound-variable)
+                  (")"   default-color))
+                (list '((7 8) (13 14))))
+     (build-test "(letrec ([x x]) x)"
+                '(("("      default-color)
+                  ("letrec" imported-syntax)
+                  (" (["    default-color)
+                  ("x"      lexically-bound-variable)
+                  (" "      default-color)
+                  ("x"      lexically-bound-variable)
+                  ("]) "    default-color)
+                  ("x"      lexically-bound-variable)
+                  (")"      default-color))
+                (list '((10 11) (12 13) (16 17))))
+     (build-test "(#%top . x)"
+                 '(("("     default-color) 
+                   ("#%top" imported-syntax)
+                   (" . "   default-color)
+                   ("x"     error)
+                   (")"    default-color)))
+     (build-test "(set! x 1)"
+                '(("("    default-color)
+                  ("set!" imported-syntax)
+                  (" "    default-color)
+                  ("x"    error)
+                  (" "    default-color)
+                  ("1"    constant)
+                  (")"    default-color)))
+     (build-test "(set! x 1) (define x 2)"
+                 '(("("      default-color)
+                   ("set!"   imported-syntax)
+                   (" "      default-color)
+                   ("x"      lexically-bound-variable)
+                   (" "      default-color)
+                   ("1"      constant)
+                   (") ("    default-color)
+                   ("define" imported-syntax)
+                   (" "      default-color)
+                   ("x"      lexically-bound-variable)
+                   (" 2)"    default-color))
+                 (list '((19 20) (6 7))))
+     (build-test "(let ([x 1]) (set! x 2))"
+                '(("("    default-color)
+                  ("let"   imported-syntax)
+                  (" (["   default-color)
+                  ("x"     lexically-bound-variable)
+                  (" "     default-color)
+                  ("1"     constant)
+                  ("]) ("  default-color)
+                  ("set!"  imported-syntax)
+                  (" "     default-color)
+                  ("x"     lexically-bound-variable)
+                  (" "     default-color)
+                  ("2"     constant)
+                  ("))"    default-color))
+                (list '((7 8) (19 20))))
+     (build-test "object%"
+                '(("object%" lexically-bound-variable)))
+     (build-test "unbound-id"
+                '(("unbound-id" error)))
+     (build-test "(define bd 1) bd"
+                '(("("       default-color)
+                  ("define"  imported-syntax)
+                  (" "       default-color)
+                  ("bd"      lexically-bound-variable)
+                  (" "       default-color)
+                  ("1"       constant)
+                  (") "      default-color)
+                  ("bd"      lexically-bound-variable))
+                (list '((8 10) (14 16))))
+     (build-test "#'abc"
+                '(("#'"  imported-syntax)
+                  ("abc" constant)))
+     (build-test "(with-continuation-mark 1 2 3)"
+                '(("("                      default-color)
+                  ("with-continuation-mark" imported-syntax)
+                  (" "                      default-color)
+                  ("1"                      constant)
+                  (" "                      default-color)
+                  ("2"                      constant)
+                  (" "                      default-color)
+                  ("3"                      constant)
+                  (")"                      default-color)))
+     (build-test "(f x)"
+                '(("(" default-color)
+                  ("f" error)
+                  (" " default-color)
+                  ("x" error)
+                  (")" default-color)))
+     (build-test "(define-syntax (f stx) (syntax 1))"
+                '(("("             default-color)
+                  ("define-syntax" imported-syntax)
+                  (" ("            default-color)
+                  ("f"             lexically-bound-syntax)
+                  (" "             default-color)
+                  ("stx"           lexically-bound-variable)
+                  (") ("           default-color)
+                  ("syntax"        imported-syntax)
+                  (" "             default-color)
+                  ("1"             constant)
+                  ("))"            default-color)))
+     (build-test "(module m mzscheme)"
+                '(("("        default-color)
+                  ("module"   imported-syntax)
+                  (" m "      default-color)
+                  ("mzscheme" error)
+                  (")"        default-color)))
+     (build-test "(require-for-syntax mzscheme)"
+                '(("("                  default-color)
+                  ("require-for-syntax" imported-syntax)
+                  (" "          default-color)
+                  ("mzscheme"   error)
+                  (")"          default-color)))
+     (build-test "(require (lib \"list.ss\"))"
+                '(("("                   default-color)
+                  ("require"             imported-syntax)
+                  (" "                   default-color)
+                  ("(lib \"list.ss\")"   error)
+                  (")"                   default-color)))
+     (build-test "(module m mzscheme (provide x) (define x 1))"
+                '(("("             default-color)
+                  ("module"        imported-syntax)
+                  (" m mzscheme (" default-color)
+                  ("provide"       imported-syntax)
+                  (" "             default-color)
+                  ("x"             lexically-bound-variable)
+                  (") ("           default-color)
+                  ("define"        imported-syntax)
+                  (" "             default-color)
+                  ("x"             lexically-bound-variable)
+                  (" "             default-color)
+                  ("1"             constant)
+                  ("))"            default-color))
+                (list '((10 18) (20 27) (32 38))
+                      '((39 40) (28 29))))
+     
+     (build-test "(module m mzscheme (+ 1 2))"
+                '(("("             default-color)
+                  ("module"        imported-syntax)
+                  (" m mzscheme (" default-color)
+                  ("+"             imported-variable)
+		  (" "             default-color)
+		  ("1"             constant)
+		  (" "             default-color)
+		  ("2"             constant)
+                  ("))"            default-color))
+                (list '((10 18) (20 21))))
+     
+     (build-test "(module m mzscheme (require (lib \"list.ss\")))"
+                '(("("                 default-color)
+                  ("module"            imported-syntax)
+                  (" m mzscheme ("     default-color)
+                  ("require"           imported-syntax)
+                  (" "                 default-color)
+                  ("(lib \"list.ss\")" error)
+                  ("))"                default-color))
+                (list '((10 18) (20 27))))
+     
+     (build-test "(module m mzscheme (require-for-syntax (lib \"list.ss\")) (define-syntax s foldl))"
+                '(("("                     default-color)
+                  ("module"                imported-syntax)
+                  (" m mzscheme ("         default-color)
+                  ("require-for-syntax"    imported-syntax)
+                  (" (lib \"list.ss\")) (" default-color)
+                  ("define-syntax"         imported-syntax)
+                  (" "                     default-color)
+                  ("s"                     lexically-bound-syntax)
+                  (" "                     default-color)
+                  ("foldl"                 imported-variable)
+                  ("))"                    default-color))
+                (list '((10 18) (20 38) (57 70))
+                      '((39 54) (73 78))))
+     
+     (build-test "(module m mzscheme (require-for-syntax (lib \"etc.ss\")) (define-syntax s (rec f 1)))"
+                '(("("                     default-color)
+                  ("module"                imported-syntax)
+                  (" m mzscheme ("         default-color)
+                  ("require-for-syntax"    imported-syntax)
+                  (" (lib \"etc.ss\")) ("  default-color)
+                  ("define-syntax"         imported-syntax)
+                  (" "                     default-color)
+                  ("s"                     lexically-bound-syntax)
+                  (" ("                    default-color)
+                  ("rec"                   imported-syntax)
+                  (" "                     default-color)
+                  ("f"                     lexically-bound-variable)
+                  (" "                     default-color)
+                  ("1"                     constant)
+                  (")))"                   default-color))
+                (list '((10 18) (20 38) (56 69))
+                      '((39 53) (73 76))))
+
+     (build-test "(define-syntax s (lambda (stx) (syntax-case stx () (_ 123))))"
+                '(("("             default-color)
+                  ("define-syntax" imported-syntax)
+                  (" "             default-color)
+                  ("s"             lexically-bound-syntax)
+                  (" ("            default-color)
+                  ("lambda"        imported-syntax)
+                  (" ("            default-color)
+                  ("stx"           lexically-bound-variable)
+                  (") ("           default-color)
+                  ("syntax-case"   imported-syntax)
+                  (" "             default-color)
+                  ("stx"           lexically-bound-variable)
+                  (" () ("         default-color)
+                  ("_"             lexically-bound-syntax)
+                  (" "             default-color)
+                  ("123"           constant)
+                  ("))))"          default-color))
+                (list '((26 29) (44 47))))
+
+     (build-test "(require (lib \"list.ss\")) first"
+                '(("("                    default-color)
+                  ("require"              imported-syntax)
+                  (" (lib \"list.ss\")) " default-color)
+                  ("first"                imported-variable))
+                (list '((9 24) (26 31))))
+     
+     (build-test "(require (lib \"etc.ss\")) (rec f 1)"
+                '(("("                    default-color)
+                  ("require"              imported-syntax)
+                  (" (lib \"etc.ss\")) (" default-color)
+                  ("rec"                  imported-syntax)
+                  (" "                    default-color)
+                  ("f"                    lexically-bound-variable)
+                  (" "                    default-color)
+                  ("1"                    constant)
+                  (")"                    default-color))
+                (list '((9 23) (26 29))))
+     
+     (build-test "(define-struct s ())"
+                '(("("             default-color)
+                  ("define-struct" imported-syntax)
+                  (" "             default-color)
+                  ("s"             lexically-bound-syntax)
+                  (" ())"          default-color)))
+     
+     (build-test "(define-struct s ()) (define-struct (t s) ())"
+                '(("("             default-color)
+                  ("define-struct" imported-syntax)
+                  (" "             default-color)
+                  ("s"             lexically-bound-syntax)
+                  (" ()) ("        default-color)
+                  ("define-struct" imported-syntax)
+                  (" ("            default-color)
+                  ("t"             lexically-bound-syntax)
+                  (" "             default-color)
+                  ("s"             lexically-bound-syntax)
+                  (") ())"         default-color))
+                (list '((15 16) (39 40))))
+     
+     (build-test "(let () (define-struct s (x)) 1)"
+                 '(("("             default-color)
+                   ("let"           imported-syntax)
+                   (" () ("         default-color)
+                   ("define-struct" imported-syntax)
+                   (" "             default-color)
+                   ("s"             lexically-bound-syntax)
+                   (" (x)) "        default-color)
+                   ("1"             constant)
+                   (")"             default-color)))
+     
+     (build-test "(let ([x 12]) (define-struct s (x)) x)"
+                 '(("("             default-color)
+                   ("let"           imported-syntax)
+                   (" (["           default-color)
+                   ("x"             lexically-bound-variable)
+                   (" "             default-color)
+                   ("12"            constant)
+                   ("]) ("          default-color)
+                   ("define-struct" imported-syntax)
+                   (" "             default-color)
+                   ("s"             lexically-bound-syntax)
+                   (" (x)) "        default-color)
+                   ("x"             lexically-bound-variable)
+                   (")"             default-color))
+                 (list '((7 8) (36 37))))
+     
+     (build-test "`(1 ,x 2)"
+                '(("`"        imported-syntax)
+                  ("("        default-color)
+                  ("1"        constant)
+                  (" ,"       default-color)
+                  ("x"        error)
+                  (" "        default-color)
+                  ("2"        constant)
+                  (")"        default-color)))
+
+     (build-test "`(a ,2 b c d)"
+                `(("`"  imported-syntax)
+                  ("("  default-color)
+                  ("a"  constant)
+                  (" ," default-color)
+                  ("2"  constant)
+                  (" "  default-color)
+                  ("b"  constant)
+                  (" "  default-color)
+                  ("c"  constant)
+                  (" "  default-color)
+                  ("d"  constant)
+                  (")"  default-color)))
+     
+     (build-test "#!"
+                '(("#!" default-color)))
+     
+     (build-test "#!\n"
+                '(("#!\n" default-color)))
+     
+     (build-test "#!\n1"
+                '(("#!\n" default-color)
+                  ("1"    constant)))
+     
+     (build-test "#!\n1\n1"
+                '(("#!\n" default-color)
+                  ("1"    constant)
+                  ("\n"   default-color)
+                  ("1"    constant)))
+     
+     (build-test "(module m mzscheme (lambda (x) x) (provide))"
+                '(("("             default-color)
+                  ("module"        imported-syntax)
+                  (" m mzscheme (" default-color)
+                  ("lambda"        imported-syntax)
+                  (" ("            default-color)
+                  ("x"             lexically-bound-variable)
+                  (") "            default-color)
+                  ("x"             lexically-bound-variable)
+                  (") ("           default-color)
+                  ("provide"       imported-syntax)
+                  ("))"            default-color))
+                (list '((10 18) (20 26) (35 42))
+                      '((28 29) (31 32))))
+     
+     (build-test "(module m mzscheme (define-struct s (a)) s-a make-s s? set-s-a!)"
+                '(("("             default-color)
+                  ("module"        imported-syntax)
+                  (" m mzscheme (" default-color)
+                  ("define-struct" imported-syntax)
+                  (" "             default-color)
+                  ("s"             lexically-bound-syntax)
+                  (" (a)) "        default-color)
+                  ("s-a"           lexically-bound-variable)
+                  (" "             default-color)
+                  ("make-s"        lexically-bound-variable)
+                  (" "             default-color)
+                  ("s?"            lexically-bound-variable)
+                  (" "             default-color)
+                  ("set-s-a!"      lexically-bound-variable)
+                  (")"             default-color))
+                (list '((10 18) (20 33))))
+     
+     (build-test "(define tordu3 '(a . #0=(b c d . #0#)))"
+                '(("("        default-color)
+                  ("define"   imported-syntax)
+                  (" "        default-color)
+                  ("tordu3"   lexically-bound-variable)
+                  (" "        default-color)
+                  ("'"        imported-syntax)
+                  ("(a . #0=(b c d . #0#))" constant)
+                  (")"        default-color)))
+
+     (build-test "(let l () l l)"
+                '(("("    default-color)
+                  ("let"  imported-syntax)
+                  (" "    default-color)
+                  ("l"    lexically-bound-variable)
+                  (" () " default-color)
+                  ("l"    lexically-bound-variable)
+                  (" "    default-color)
+                  ("l"    lexically-bound-variable)
+                  (")"    default-color))
+                (list '((5 6) (10 11) (12 13))))
+     (build-test "(class object% this)"
+                '(("("       default-color)
+                  ("class"   imported-syntax)
+                  (" "       default-color)
+                  ("object%" lexically-bound-variable)
+                  (" "       default-color)
+                  ("this"    imported-identifier)
+                  (")"       default-color)))
+     (build-test "(module m mzscheme (require (lib \"list.ss\")) foldl)"
+                '(("("                    default-color)
+                  ("module"               imported-syntax)
+                  (" m mzscheme ("        default-color)
+                  ("require"              imported-syntax)
+                  (" (lib \"list.ss\")) " default-color)
+                  ("foldl"                imported-variable)
+                  (")"                    default-color))
+                (list '((10 18) (20 27))
+                      '((28 43) (45 50))))
+     (build-test "(module m (lib \"htdp-beginner.ss\" \"lang\") empty)"
+                '(("("                                         default-color)
+                  ("module"                                    imported-syntax)
+                  (" m (lib \"htdp-beginner.ss\" \"lang\") "   default-color)
+                  ("empty"                                     imported-variable)
+                  (")"                                         default-color))
+                (list '((10 41) (42 47))))
+     (build-test "(module m mzscheme (require (prefix x: (lib \"list.ss\"))) x:foldl)"
+                '(("("                                default-color)
+                  ("module"                           imported-syntax)
+                  (" m mzscheme ("                    default-color)
+                  ("require"                          imported-syntax)
+                  (" (prefix x: (lib \"list.ss\"))) " default-color)
+                  ("x:foldl"                          imported-variable)
+                  (")"                                default-color))
+                (list '((10 18) (20 27))
+                      '((28 55) (57 64))))
+     
+     (build-test "(module m mzscheme (require (prefix x: (lib \"list.ss\")) (lib \"list.ss\")) x:foldl foldl)"
+                '(("("                                                  default-color)
+                  ("module"                                             imported-syntax)
+                  (" m mzscheme ("                                      default-color)
+                  ("require"                                            imported-syntax)
+                  (" (prefix x: (lib \"list.ss\")) (lib \"list.ss\")) " default-color)
+                  ("x:foldl"                                            imported-variable)
+                  (" "                                                  default-color)
+                  ("foldl"                                              imported-variable)
+                  (")"                                                  default-color))
+                (list '((10 18) (20 27))
+                      '((28 55) (73 80) (81 86))
+                      '((56 71) (73 80) (81 86))))
+                      
+     (build-test "(module m mzscheme (require (lib \"etc.ss\")) (rec f 1))"
+                '(("("                     default-color)
+                  ("module"                imported-syntax)
+                  (" m mzscheme ("         default-color)
+                  ("require"               imported-syntax)
+                  (" (lib \"etc.ss\")) ("  default-color)
+                  ("rec"                   imported-syntax)
+                  (" "                     default-color)
+                  ("f"                     lexically-bound-variable)
+                  (" "                     default-color)
+                  ("1"                     constant)
+                  ("))"                    default-color))
+                (list '((10 18) (20 27))
+                      '((28 42) (45 48))))
+     
+     (build-test "(module m (lib \"htdp-intermediate.ss\" \"lang\") (local ((define x x)) x))"
+                '(("("                                            default-color)
+                  ("module"                                       imported-syntax)
+                  (" m (lib \"htdp-intermediate.ss\" \"lang\") (" default-color)
+                  ("local"                                        imported-syntax)
+                  (" ((define "                                   default-color)
+                  ("x"                                            lexically-bound-variable)
+                  (" "                                            default-color)
+                  ("x"                                            lexically-bound-variable)
+                  (")) "                                          default-color)
+                  ("x"                                            lexically-bound-variable)
+                  ("))"                                           default-color))
+                (list '((10 45) (47 52))
+                      '((62 63) (64 65) (68 69))))
+     
+     (make-dir-test "(module m mzscheme (require \"~a/list.ss\") foldl foldl)"
+                    '(("("             default-color)
+                      ("module"        imported-syntax)
+                      (" m mzscheme (" default-color)
+                      ("require"       imported-syntax)
+                      (" \""           default-color)
+                      (relative-path   default-color)
+                      ("/list.ss\") "  default-color)
+                      ("foldl"         imported-variable)
+                      (" "             default-color)
+                      ("foldl"         imported-variable)
+                      (")"             default-color))
+                    #f)))
+  
+  (define (run-test)
+    (check-language-level #rx"Graphical")
+    (let* ([drs (wait-for-drscheme-frame)]
+           [defs (send drs get-definitions-text)]
+           [filename (make-temporary-file "syncheck-test~a")])
+      (let-values ([(dir _1 _2) (split-path filename)])
+        (send defs save-file filename)
+        (preferences:set 'framework:coloring-active #f)
+        (for-each (run-one-test (normalize-path dir)) tests)
+        (preferences:set 'framework:coloring-active #t)
+        (send defs save-file) ;; clear out autosave
+        (send defs set-filename #f)
+        (delete-file filename))))
+  
+  (define ((run-one-test save-dir) test)
+    (let* ([drs (wait-for-drscheme-frame)]
+           [defs (send drs get-definitions-text)]
+           [input (test-input test)]
+           [expected (test-expected test)]
+           [arrows (test-arrows test)]
+           [relative (find-relative-path save-dir (collection-path "mzlib"))])
+      (clear-definitions drs)
+      (cond
+        [(dir-test? test)
+         (type-in-definitions drs (format input (path->string relative)))]
+        [else (type-in-definitions drs input)])
+      (test:button-push (send drs syncheck:get-button))
+      (wait-for-computation drs)
+      
+      ;; this isn't right -- seems like there is a race condition because
+      ;; wait-for-computation isn't waiting long enough?
+      '(when (send defs in-edit-sequence?)
+         (error 'syncheck-test.ss "still in edit sequence for ~s" input))
+      
+      (when (send drs syncheck:error-report-visible?)
+        (printf "FAILED ~s\n   error report window is visible\n"
+                input))
+      
+      ;; need to check for syntax error here
+      (let ([got (get-annotated-output drs)])
+        (compare-output (cond
+                          [(dir-test? test)
+                           (map (lambda (x)
+                                  (list (if (eq? (car x) 'relative-path)
+                                            (path->string relative)
+                                            (car x))
+                                        (cadr x)))
+                                expected)]
+                          [else
+                           expected])
+                        got
+                        arrows 
+                        (send defs syncheck:get-bindings-table)
+                        input))))
+  
+  (define remappings
+    '((constant default-color)
+      (imported-syntax imported-identifier)
+      (imported-variable imported-identifier)
+      (lexically-bound-syntax lexically-bound-identifier)
+      (lexically-bound-variable lexically-bound-identifier)))
+  
+  (define (collapse-and-rename expected)
+    (let ([renamed
+           (map (lambda (ent)
+                  (let* ([str (car ent)]
+                         [id (cadr ent)]
+                         [matches (assoc id remappings)])
+                    (if matches
+                        (list str (cadr matches))
+                        ent)))
+                expected)])
+      (let loop ([ids renamed])
+        (cond
+          [(null? ids) null]
+          [(null? (cdr ids)) ids]
+          [else (let ([fst (car ids)]
+                      [snd (cadr ids)])
+                  (if (eq? (cadr fst) (cadr snd))
+                      (loop (cons (list (string-append (car fst) (car snd)) (cadr fst))
+                                  (cddr ids)))
+                      (cons fst (loop (cdr ids)))))]))))
+    
+  ;; compare-arrows : (listof (cons (list number number) (listof (list number number))))
+  ;;                  hash-table[(list text number number) -o> (listof (list text number number))]
+  ;;               -> void
+  (define (compare-arrows test-exp expected raw-actual)
+    (when expected
+      (let ()
+        (define already-checked (make-hash-table 'equal))
+        
+        (define actual-ht (make-hash-table 'equal))
+        (define stupid-internal-define-syntax1
+          (hash-table-for-each raw-actual
+                               (lambda (k v)
+                                 (hash-table-put! actual-ht
+                                                  (cdr k) 
+                                                  (quicksort
+                                                   (map cdr v)
+                                                   (lambda (x y) (< (car x) (car y))))))))
+        (define expected-ht (make-hash-table 'equal))
+        (define stupid-internal-define-syntax2
+          (for-each (lambda (binding) (hash-table-put! expected-ht (car binding) (cdr binding)))
+                    expected))
+        ;; binding-in-ht? : hash-table (list number number) (listof (list number number)) -> boolean
+        (define (test-binding expected? ht)
+          (lambda (pr)
+            (let ([frm (car pr)]
+                  [to (cdr pr)])
+              (hash-table-get
+               already-checked
+               frm
+               (lambda ()
+                 (hash-table-put! already-checked frm #t)
+                 (let ([ht-ent (hash-table-get ht frm (lambda () 'nothing-there))])
+                   (unless (equal? ht-ent to)
+                     (printf (if expected? 
+                                 "FAILED arrow test ~s from ~s\n  expected ~s\n    actual ~s\n"
+                                 "FAILED arrow test ~s from ~s\n    actual ~s\n  expected ~s\n")
+                             test-exp
+                             frm
+                             ht-ent
+                             to))))))))
+        
+        (for-each (test-binding #t expected-ht) (hash-table-map actual-ht cons))
+        (for-each (test-binding #f actual-ht) (hash-table-map expected-ht cons)))))
+  
+  (define (compare-output raw-expected got arrows arrows-got input)
+    (let ([expected (collapse-and-rename raw-expected)])
+      (cond
+        [(equal? got expected)
+         (compare-arrows input arrows arrows-got)]
+        [else
+         (printf "FAILED: ~s\n      expected: ~s\n           got: ~s\n"
+                 input expected got)])))
+  
+  ;; get-annotate-output : drscheme-frame -> (listof str/ann)
+  (define (get-annotated-output drs)
+    (let ([chan (make-channel)])
+      (queue-callback
+       (λ ()
+         (channel-put chan (get-string/style-desc (send drs get-definitions-text)))))
+      (channel-get chan))))
+
diff --git a/collects/tests/drscheme/teachpack.ss b/collects/tests/drscheme/teachpack.ss
new file mode 100644
index 0000000000..a47d05a5ed
--- /dev/null
+++ b/collects/tests/drscheme/teachpack.ss
@@ -0,0 +1,224 @@
+
+(module teachpack mzscheme
+  (require "drscheme-test-util.ss"
+           (lib "class.ss")
+           (lib "file.ss")
+           (lib "mred.ss" "mred")
+           (lib "framework.ss" "framework")
+           (prefix fw: (lib "framework.ss" "framework")))
+  
+  (provide run-test)
+  
+  (define drs-frame (wait-for-drscheme-frame))
+  (define interactions-text (send drs-frame get-interactions-text))
+  
+  (define good-teachpack-name "teachpack-tmp~a")
+  
+  (define (test-good-teachpack tp-exps dr-exp expected)
+    (clear-definitions drs-frame)
+    (type-in-definitions drs-frame dr-exp)
+    (fw:test:menu-select "Language" "Clear All Teachpacks")
+    
+    (let ([tp-names
+           (let ([teachpack-path (normal-case-path
+                                  (normalize-path
+                                   (collection-path "tests" "drscheme")))])
+             (let loop ([tp-exps tp-exps]
+                        [n 0])
+               (cond
+                 [(null? tp-exps) null]
+                 [else
+                  (let ([tp-name (build-path teachpack-path 
+                                             (string-append
+                                              (format good-teachpack-name n)
+                                              ".ss"))])
+                    (call-with-output-file tp-name
+                      (lambda (port) (write (car tp-exps) port))
+                      'truncate)
+                    (use-get/put-dialog
+                     (lambda ()
+                       (fw:test:menu-select "Language" "Add Teachpack..."))
+                     tp-name)
+                    (cons tp-name (loop (cdr tp-exps) (+ n 1))))])))])
+      
+      (do-execute drs-frame)
+      
+      (let ([got (fetch-output drs-frame)]
+            [full-expectation 
+             (string-append
+              (apply string-append (map (lambda (x) (format "Teachpack: ~a.~n" x)) tp-names))
+              expected)])
+        (unless (equal? got 
+                        full-expectation)
+          (printf 
+           "FAILED:       tp: ~s~n             exp: ~s~n        expected: ~s~n             got: ~s~n"
+           tp-exps
+           dr-exp
+           full-expectation
+           got)))))
+  
+  ;; there are no more errors when the teachpack is loaded (for now...)
+  (define (test-bad/load-teachpack tp-exp expected-error)
+    (fw:test:menu-select "Language" "Clear All Teachpacks")
+    (let ([tp-name (normal-case-path
+                    (normalize-path
+                     (build-path
+                      (collection-path "tests" "drscheme")
+                      "teachpack-tmp.ss")))])
+      (call-with-output-file tp-name
+        (lambda (port) (display tp-exp port))
+        'truncate)
+      (use-get/put-dialog
+       (lambda ()
+         (fw:test:menu-select "Language" "Add Teachpack..."))
+       tp-name)
+      (let ([dialog
+             (with-handlers ([(lambda (x) #t)
+                              (lambda (x) #f)])
+               (wait-for-new-frame drs-frame))])
+        (cond
+          [dialog
+           (let ([got (send dialog get-message)])
+             (unless (string=? got expected-error)
+               (printf "FAILED:       tp: ~s~n        expected: ~s~n             got: ~s~n"
+                       tp-exp expected-error got))
+             (fw:test:button-push "Ok")
+             (wait-for-new-frame dialog))]
+          [else
+           (printf "FAILED: no error message appeared~n              tp: ~s~n        expected: ~s~n"
+                   tp-exp expected-error)]))))
+  
+  (define (test-bad/execute-teachpack tp-exp expected)
+    (fw:test:menu-select "Language" "Clear All Teachpacks")
+    (let ([tp-name (normal-case-path
+                    (normalize-path
+                     (build-path
+                      (collection-path "tests" "drscheme")
+                      "teachpack-tmp.ss")))])
+      (call-with-output-file tp-name
+        (lambda (port) (display tp-exp port))
+        'truncate)
+      (use-get/put-dialog
+       (lambda ()
+         (fw:test:menu-select "Language" "Add Teachpack..."))
+       tp-name)
+      (do-execute drs-frame #f)
+      (let ([dialog
+             (with-handlers ([exn:fail? (lambda (x) #f)])
+               (let ([wait-for-error-pred
+                      (lambda ()
+                        (let ([active
+                               (or
+                                (get-top-level-focus-window)
+                                (and (send interactions-text get-user-eventspace)
+                                     (parameterize ([current-eventspace
+                                                     (send interactions-text get-user-eventspace)])
+                                       (get-top-level-focus-window))))])
+                          (if (and active (not (eq? active drs-frame)))
+                              active
+                              #f)))])
+                 (poll-until wait-for-error-pred)))])
+        (cond
+          [dialog
+           (let ([got (send dialog get-message)]
+                 [expected-error
+                  (string-append (format "Invalid Teachpack: ~a~n" tp-name)
+                                 expected)])
+             (unless (string=? got expected-error)
+               (printf "FAILED:       tp: ~s~n        expected: ~s~n             got: ~s~n"
+                       tp-exp expected-error got))
+             (fw:test:button-push "Ok")
+             (wait-for-new-frame dialog))]
+          [else
+           (printf "FAILED: no error message appeared~n              tp: ~s~n        expected: ~s~n"
+                   tp-exp error)]))))
+  
+  (define (generic-tests)
+    (test-good-teachpack
+     (list
+      `(module ,(string->symbol (format good-teachpack-name 0)) mzscheme))
+     "1"
+     "1")
+    
+    (test-good-teachpack
+     (list `(module ,(string->symbol (format good-teachpack-name 0)) mzscheme
+              (provide not-a-primitive)
+              (define not-a-primitive 1)))
+     "not-a-primitive"
+     "1")
+    
+    (test-good-teachpack
+     (list `(module ,(string->symbol (format good-teachpack-name 0)) mzscheme
+              (provide not-a-primitive1)
+              (define not-a-primitive1 1))
+           `(module ,(string->symbol (format good-teachpack-name 1)) mzscheme
+              (provide not-a-primitive2)
+              (define not-a-primitive2 2)))
+     "(+ not-a-primitive1 not-a-primitive2)"
+     "3"))
+  
+  (define (good-tests)
+    (set-language-level! `("PLT" ,(regexp "Graphical")))
+    (generic-tests)
+    
+    (set-language-level! '("How to Design Programs" "Beginning Student"))
+    (generic-tests))
+  
+  (define (bad-tests)
+    (set-language-level! '("How to Design Programs" "Beginning Student"))
+    
+    (test-bad/execute-teachpack
+     "undefined-id"
+     "reference to undefined identifier: undefined-id")
+ 
+    (test-bad/execute-teachpack
+     `(module teachpack-tmp mzscheme (car))
+     "car: expects argument of type <pair>; given 1"))
+  
+  (define (get-string-from-file fn)
+    (call-with-input-file fn
+      (lambda (port)
+        (apply string-append
+               (let loop ()
+                 (let ([l (read-line port)])
+                   (if (eof-object? l)
+                       null
+                       (list* l " " (loop)))))))
+      'text))
+  
+  ;; doesn't test graphing.ss teachpack
+  (define (test-built-in-teachpacks)
+    (clear-definitions drs-frame)
+    (type-in-definitions drs-frame "1")
+    (let* ([test-teachpack
+            (lambda (dir)
+              (lambda (teachpack)
+                (when (or (equal? "ss" (filename-extension teachpack))
+                          (equal? "scm" (filename-extension teachpack)))
+                  (unless (equal? "graphing.ss" teachpack)
+                    (printf "  testing ~a~n" (build-path dir teachpack))
+                    (let ([filename (normal-case-path (build-path dir teachpack))])
+                      (fw:test:menu-select "Language" "Clear All Teachpacks")
+                      (use-get/put-dialog
+                       (lambda ()
+                         (fw:test:menu-select "Language" "Add Teachpack..."))
+                       filename)
+                      (do-execute drs-frame)
+                      
+                      (let ([got (fetch-output drs-frame)]
+                            [expected (format "Teachpack: ~a.~n1" filename)])
+                        (unless (equal? got expected)
+                          (printf "FAILED built in teachpack test: ~a~n" filename)
+                          (printf "       got: ~s~n  expected: ~s~n" got expected))))))))]
+           [test-teachpacks
+            (lambda (dir)
+              (for-each (test-teachpack dir) (directory-list dir)))]
+           [teachpack-dir (normalize-path (build-path (collection-path "mzlib") 'up 'up "teachpack"))])
+      (set-language-level! '("How to Design Programs" "Advanced Student"))
+      (test-teachpacks teachpack-dir)
+      (test-teachpacks (build-path teachpack-dir "htdp"))))
+  
+  (define (run-test)
+    ;(good-tests)
+    ;(bad-tests)
+    (test-built-in-teachpacks)))
diff --git a/collects/tests/drscheme/test-box-test.ss b/collects/tests/drscheme/test-box-test.ss
new file mode 100644
index 0000000000..32425ecca7
--- /dev/null
+++ b/collects/tests/drscheme/test-box-test.ss
@@ -0,0 +1,129 @@
+(module test-box-test mzscheme
+  (require "drscheme-test-util.ss"
+           (lib "class.ss")
+           (lib "file.ss")
+           (lib "mred.ss" "mred")
+           (lib "framework.ss" "framework")
+	   (rename (lib  "teachprims.ss" "lang" "private") beginner-equal? beginner-equal?))
+  
+  (provide run-test)
+
+  (define (run-test)
+    
+    (define drscheme-frame (wait-for-drscheme-frame))
+    
+    (define definitions-text (send drscheme-frame get-definitions-text))
+    (define definitions-canvas (send drscheme-frame get-definitions-canvas))
+    (define execute-button (send drscheme-frame get-execute-button))
+    
+    (define (insert-string string)
+      (let loop ([n 0])
+        (unless (= n (string-length string))
+          (let ([c (string-ref string n)])
+            (if (char=? c #\newline)
+                (test:keystroke #\return)
+                (test:keystroke c)))
+          (loop (+ n 1)))))
+    
+    (define wait-for-execute (lambda () (wait-for-button execute-button)))
+
+    (define (get-test-box)
+      (send definitions-text find-snip (send definitions-text last-position) 'before))
+
+    (define (get-test-image fn)
+      (make-object 
+       image-snip%
+       (make-object bitmap% (build-path (collection-path "test-suite" "private" "icons") fn))))
+
+    (define check-img (get-test-image "small-check-mark.jpeg"))
+    (define cross-img (get-test-image "small-cross.jpeg"))
+    (define non-img (get-test-image "small-empty.gif"))
+
+    (define red-square (make-object image-snip%
+				    (let* ([bm (make-object bitmap% 20 20)]
+					   [dc (make-object bitmap-dc% bm)])
+				      (send dc set-brush "red" 'solid)
+				      (send dc set-pen "red" 1 'solid)
+				      (send dc draw-rectangle 0 0 20 20)
+				      (send dc set-bitmap #f)
+				      bm)))
+
+    (define (same-img? a b)
+      (beginner-equal? a b))
+
+    (define (test-box-status s)
+      (let eloop ([e (send s get-editor)])
+	(let sloop ([s (send e find-first-snip)])
+	  (and s
+	       (or
+		(cond
+		 [(s . is-a? . editor-snip%)
+		  (eloop (send s get-editor))]
+		 [(s . is-a? . image-snip%)
+		  (cond
+		   [(same-img? s check-img) 'pass]
+		   [(same-img? s cross-img) 'fail]
+		   [(same-img? s non-img) 'not-run]
+		   [else #f])]
+		 [else #f])
+		(sloop (send s next)))))))
+
+    (define (check-test-box-status v s)
+      (let ([u (test-box-status s)])
+	(if (eq? v u)
+	    (printf "~a - good\n" v)
+	    (printf "FAILED: ~a != ~a\n" u v))))
+	
+
+    (define (try-test preamble expr expect result)
+      (test:new-window definitions-canvas)
+      (send definitions-text erase)
+      
+      (insert-string preamble)
+
+      (test:menu-select "Special" "Insert Test Case")
+      
+      (insert-string expr)
+      (insert-string "\t")
+      (let loop ([expect expect])
+	(cond
+	 [(expect . is-a? . snip%)
+	  (send (send drscheme-frame get-edit-target-object) insert (send expect copy))]
+	 [(list? expect)
+	  (for-each loop expect)]
+	 [else
+	  (insert-string expect)]))
+      
+      (check-test-box-status 'not-run (get-test-box))
+      (do-execute drscheme-frame #t)
+      (check-test-box-status result (get-test-box)))
+
+    (define scheme-languages
+      '(("How to Design Programs" "Beginning Student")
+	("How to Design Programs" "Intermediate Student")
+	("How to Design Programs" "Advanced Student")
+	("PLT" #rx"Textual")
+	("PLT" #rx"Graphical")))
+
+    (for-each (lambda (lang)
+		(set-language-level! lang #t)
+
+		(try-test "" "(+ 1 2)" "3" 'pass)
+		(try-test "" "(+ 1 -2)" "3" 'fail)
+		(try-test "" "(list 1)" "(list 1)" 'pass)
+		(try-test "" "not-defined" "3" 'not-run)
+		(try-test "(define (f x) (+ x 1))" "(f 2)" "3" 'pass)
+		
+		(use-get/put-dialog
+		 (lambda ()
+		   (test:menu-select "Language" "Add Teachpack..."))
+		 (build-path (collection-path "mzlib") 'up 'up "teachpack" "htdp" "image.ss"))
+		(try-test "" "(rectangle 20 20 'solid \"red\")" "3" 'fail)
+		(try-test "" "(rectangle 20 20 'solid \"red\")" red-square 'pass)
+		(try-test "" "(list (rectangle 20 20 'solid \"red\") 17)" `("(list " ,red-square " 17)") 'pass)
+		(test:menu-select "Language" "Clear All Teachpacks")
+		
+		(void))
+	      scheme-languages)
+
+    (void)))
diff --git a/collects/tests/drscheme/tool.ss b/collects/tests/drscheme/tool.ss
new file mode 100644
index 0000000000..d7634ca57c
--- /dev/null
+++ b/collects/tests/drscheme/tool.ss
@@ -0,0 +1,48 @@
+;; load this file as a tool to run the test suites
+
+(module tool mzscheme
+  (require (lib "tool.ss" "drscheme")
+           (lib "list.ss")
+           (lib "unitsig.ss")
+           (lib "class.ss")
+           (lib "mred.ss" "mred")
+           (lib "framework.ss" "framework"))
+  
+  (provide tool@)
+
+  (define tool@
+    (unit/sig drscheme:tool-exports^
+      (import drscheme:tool^)
+            
+      (define (phase1) (void))
+      (define (phase2) (void))
+      
+      (preferences:set-default 'drscheme:test-suite:file-name "repl-tests.ss" string?)
+      (preferences:set-default 'drscheme:test-suite:run-interval 10 number?)
+      
+      (preferences:set-default 'drscheme:test-suite:frame-width #f (lambda (x) (or (not x) (number? x))))
+      (preferences:set-default 'drscheme:test-suite:frame-height 300 (lambda (x) (or (not x) (number? x))))
+      
+      (define (tool-mixin super%)
+        (class super%
+          (inherit get-button-panel)
+          (super-new)
+          (let* ([bitmap (make-object bitmap% 
+                           (if (<= (get-display-depth) 1)
+                               (build-path (collection-path "icons") "bb-sm-bw.bmp")
+                               (build-path (collection-path "icons") "bb-small.bmp"))
+                           'bmp)]
+                 [button (make-object button%
+                           (if (send bitmap ok?) bitmap "Console")
+                           (get-button-panel)
+                           (lambda (button evt) 
+                             (let ([ask-test-suite (dynamic-require '(lib "run-tests.ss" "tests" "drscheme")
+                                                                    'ask-test-suite)])
+                               (ask-test-suite this))))])
+            (send (get-button-panel) change-children
+                  (lambda (l)
+                    (cons button (remq button l)))))))
+      
+      (when (getenv "PLTDRTESTS")
+        (printf "PLTDRTESTS: installing unit frame mixin\n")
+        (drscheme:get/extend:extend-unit-frame tool-mixin)))))
diff --git a/collects/tests/framework/README b/collects/tests/framework/README
new file mode 100644
index 0000000000..085bf42d93
--- /dev/null
+++ b/collects/tests/framework/README
@@ -0,0 +1,102 @@
+`(#|
+		      Framework Test Suite Overview
+
+Each tests will rely on the sucessfully completion of all of the ones
+before it. In addition, all test suites rely on the sucessful
+completion of the engine test suites and the mzscheme test suites.
+
+All of these tests reside in PLTHOME/collects/tests/framework/
+
+There will be a main mzscheme process which will start up a new mred
+as necessary for the test suites. Since some tests actually require
+mred to exit in order to pass, this governor is required. 
+
+To run a test use:
+
+   framework-test <test.ss> ...
+
+where or <test.ss> is the name of one of the tests below.
+Alternatively, pass no command-line arguments to run all of
+the tests. (Under windows, the app will be named "Framework
+Test"; see the mred-launcher-names documentation for how the
+names change on the various platforms)
+
+Some of the tests in this file are not yet present in the
+testing directory. They are planned future expansions of
+this test suite (and have been for some time....)
+
+OS X: you will have to click on the newly started mred
+processes in the doc while the test suite runs or it will
+signal failures when there aren't any.
+
+- load: |# load.ss #|
+
+  | This tests that the advertised ways of loading the framework at
+  | it's components all work.
+
+- exit: |# exit.ss #|
+
+  | This tests that exit:exit really exits and that the exit callbacks
+  | are actually run.
+
+- preferences: |# prefs.ss #|
+
+  | This tests that preferences are saved and restored correctly, both
+  | immediately and across reboots of mred.
+
+
+- individual object tests:
+
+  | These tests are simple object creation and basic operations.
+  | Each test assumes that the others pass; this may yield strange
+  | error messages when one fails.
+
+  - frames: |# frame.ss #|
+  - canvases: |# canvas.ss #|
+  - texts: |# text.ss #|
+  - pasteboards: |# pasteboard.ss #|
+
+- keybindings: |# keys.ss #|
+
+  | This tests the misc (non-scheme) keybindings
+
+- searching: |# search.ss #|
+
+  | This tests the seaching frame.
+
+- info: |# info-frame.ss #|
+
+  | This tests the info frame. (ie that toolbar on the bottom of the
+                                screen)
+
+- group tests: |# group-test.ss #|
+
+  | make sure that mred:the-frame-group records frames correctly.
+  | fake user input expected.
+
+- scheme mode |# scheme.ss #|
+
+  | Make sure that Scheme things work in scheme mode.
+
+- saving tests:
+
+  | These tests will make sure that the usual checks against a user
+  | losing their work are in place.
+
+  - autosaving: |# autosave.ss #|
+  - closing: |# close.ss #|
+  - quitting: |# quit.ss #|
+
+- interactive tests
+
+  | these tests require intervention by people. Clicking and whatnot
+  
+  - panel:single |# panel.ss #|
+
+  - garbage collection: |# mem.ss #|
+
+    | These tests will create objects in various configurations and
+    | make sure that they are garbage collected
+
+	
+|#)
diff --git a/collects/tests/framework/canvas.ss b/collects/tests/framework/canvas.ss
new file mode 100644
index 0000000000..767a292a4f
--- /dev/null
+++ b/collects/tests/framework/canvas.ss
@@ -0,0 +1,28 @@
+(module canvas mzscheme
+  (require "test-suite-utils.ss")
+
+(define (test-creation class name)
+  (test
+   name
+   (lambda (x) (eq? 'passed x))
+   (lambda ()
+     (send-sexp-to-mred
+      `(let* ([f (make-object frame:basic% "test canvas" #f 300 300)]
+	      [c (make-object ,class (send f get-area-container))])
+	 (send c set-editor (make-object text:wide-snip%))
+	 (send f show #t)))
+      (wait-for-frame "test canvas")
+      (send-sexp-to-mred
+       `(send (get-top-level-focus-window) show #f))
+      'passed)))
+
+(test-creation '(canvas:basic-mixin editor-canvas%)
+	       'canvas:basic-mixin-creation)
+(test-creation 'canvas:basic%
+	       'canvas:basic%-creation)
+
+(test-creation '(canvas:wide-snip-mixin canvas:basic%)
+	       'canvas:wide-snip-mixin-creation)
+(test-creation 'canvas:wide-snip%
+	       'canvas:wide-snip%-creation)
+)
diff --git a/collects/tests/framework/debug.ss b/collects/tests/framework/debug.ss
new file mode 100644
index 0000000000..5e92722ee7
--- /dev/null
+++ b/collects/tests/framework/debug.ss
@@ -0,0 +1,50 @@
+(module debug mzscheme
+  (provide debug-printf debug-when)
+
+  (define-syntax debug-when
+    (lambda (stx)
+
+      ;; all of the steps in the tcp connection
+      (define mz-tcp? #f)
+      (define mr-tcp? mz-tcp?)
+      
+      ;; administrative messages about preferences files and
+      ;; command line flags
+      (define admin? #f)
+      
+      ;; tests that passed and those that failed
+      (define schedule? #t)
+      
+      ;; all of the sexpression transactions between mz and mred
+      (define messages? #t)
+
+      (syntax-case stx (mr-tcp mz-tcp admin schedule messages)
+	[(_ mr-tcp rest ...)
+	 (if mr-tcp?
+	     (syntax (begin rest ...))
+	     (syntax (void)))]
+	[(_ mz-tcp rest ...)
+	 (if mz-tcp?
+	     (syntax (begin rest ...))
+	     (syntax (void)))]
+	[(_ admin rest ...)
+	 (if admin?
+	     (syntax (begin rest ...))
+	     (syntax (void)))]
+	[(_ schedule rest ...)
+	 (if schedule?
+	     (syntax (begin rest ...))
+	     (syntax (void)))]
+	[(_ messages rest ...)
+	 (if messages?
+	     (syntax (begin rest ...))
+	     (syntax (void)))]
+	[(_ unk rest ...)
+	 (raise-syntax-error 'debug-when "unknown flag" stx (syntax unk))])))
+
+  (define-syntax debug-printf
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ flag fmt-string rest ...)
+	 (with-syntax ([flag-name (format ">> ~a: " (syntax-object->datum (syntax flag)))])
+	   (syntax (debug-when flag (printf (string-append flag-name fmt-string) rest ...))))]))))
diff --git a/collects/tests/framework/exit.ss b/collects/tests/framework/exit.ss
new file mode 100644
index 0000000000..00e597136f
--- /dev/null
+++ b/collects/tests/framework/exit.ss
@@ -0,0 +1,50 @@
+(module exit mzscheme
+  (require "test-suite-utils.ss")
+
+(test 'exit/no-prompt
+      (lambda (x)
+	(and (eq? x 'passed)
+	     (not (mred-running?))))
+      (lambda ()
+	(with-handlers ([eof-result? (lambda (x) 'passed)])
+	  (send-sexp-to-mred '(begin (exit:exit) (sleep/yield 1)))
+	  'failed)))
+
+(define tmp-file (build-path (find-system-path 'temp-dir) "framework-exit-test-suite"))
+;; need to test "on" callbacks
+(test 'exit-callback-called
+      (lambda (x)
+	(begin0 (and (file-exists? tmp-file) (not (mred-running?)))
+		(when (file-exists? tmp-file) (delete-file tmp-file))))
+
+      (lambda ()
+	(when (file-exists? tmp-file) (delete-file tmp-file))
+	(with-handlers ([eof-result? (lambda (x) 'passed)])
+	  (send-sexp-to-mred
+	   `(begin
+	      (exit:insert-can?-callback (lambda () (call-with-output-file (bytes->path ,(path->bytes tmp-file)) void) #t))
+	      (begin (exit:exit) (sleep/yield 1)))))))
+
+(test 'exit-callback-removed
+      (lambda (x) (and (eq? x 'passed) (not (mred-running?))))
+      (lambda ()
+	(with-handlers ([eof-result? (lambda (x) 'passed)])
+	  (send-sexp-to-mred
+	   `(begin
+	      ((exit:insert-can?-callback (lambda () (error 'called-exit-callback))))
+	      (begin (exit:exit) (sleep/yield 1)))))))
+
+(test 'exit-callback-stops-exit
+      (lambda (x) (eq? x 'passed))
+      (lambda ()
+	(begin0
+	 (send-sexp-to-mred
+	  `(begin
+	     (let ([rm-callback (exit:insert-can?-callback (lambda () #f))])
+	       (exit:exit)
+	       (rm-callback)
+	       'passed)))
+	 (with-handlers ([eof-result? (lambda (x) 'passed)])
+	   (send-sexp-to-mred
+	    `(exit:exit))))))
+)
diff --git a/collects/tests/framework/frame.ss b/collects/tests/framework/frame.ss
new file mode 100644
index 0000000000..13a8b9c130
--- /dev/null
+++ b/collects/tests/framework/frame.ss
@@ -0,0 +1,146 @@
+(module frame mzscheme
+  (require "test-suite-utils.ss")
+  
+  (send-sexp-to-mred '(send (make-object frame:basic%
+                              "dummy to keep from quitting")
+                            show #t))
+  
+  (define (test-creation name class-expression . args)
+    (test
+     name
+     (lambda (x) (eq? 'passed x))
+     (lambda ()
+       (let ([frame-label
+              (send-sexp-to-mred
+               `(let ([f (instantiate ,class-expression () ,@args)])
+                  (send f show #t)
+                  (send f get-label)))])
+         (wait-for-frame frame-label)
+         (queue-sexp-to-mred
+          '(send (get-top-level-focus-window) close))
+         'passed))))
+  
+  (test-creation
+   'basic%-creation
+   'frame:basic%
+   '(label "test"))
+  (test-creation
+   'basic-mixin-creation
+   '(frame:basic-mixin frame%)
+   '(label "test"))
+  
+  (test-creation
+   'info-mixin-creation
+   '(frame:info-mixin frame:basic%)
+   '(label "test"))
+  
+  (test-creation
+   'info%-creation
+   'frame:info%
+   '(label "test"))
+  
+  (test-creation
+   'text-info-mixin-creation
+   '(frame:text-info-mixin frame:info%)
+   '(label "test"))
+  (test-creation
+   'text-info%-creation
+   'frame:text-info%
+   '(label "test"))
+  
+  (test-creation
+   'pasteboard-info-mixin-creation
+   '(frame:pasteboard-info-mixin frame:info%)
+   '(label "test"))
+  
+  (test-creation
+   'pasteboard-info%-creation
+   'frame:pasteboard-info%
+   '(label "test"))
+  
+  (test-creation
+   'standard-menus%-creation
+   'frame:standard-menus%
+   '(label "test"))
+  
+  (test-creation
+   'standard-menus-mixin
+   '(frame:standard-menus-mixin frame:basic%)
+   '(label "test"))
+  
+  (test-creation
+   'text%-creation
+   'frame:text%)
+  (test-creation
+   'text-mixin-creation
+   '(frame:text-mixin frame:editor%))
+  (test-creation
+   'text-mixin-creation
+   '(frame:text-mixin frame:editor%))
+  
+  (test-creation
+   'searchable%-creation
+   'frame:searchable%)
+  (test-creation
+   'searchable-mixin
+   '(frame:searchable-mixin frame:text%))
+  
+  (test-creation
+   'pasteboard-mixin-creation
+   '(frame:pasteboard-mixin frame:editor%))
+  (test-creation
+   'pasteboard-mixin-creation
+   '(frame:pasteboard-mixin (frame:editor-mixin frame:standard-menus%)))
+  (test-creation
+   'pasteboard%-creation
+   'frame:pasteboard%)
+  
+  (define (test-open name class-expression)
+    (let* ([test-file-contents "test"]
+           [tmp-file-name "framework-tmp"]
+           [tmp-file (build-path (collection-path "tests" "framework")
+                                 tmp-file-name)])
+      (test
+       name
+       (lambda (x)
+         (when (file-exists? tmp-file)
+           (delete-file tmp-file))
+         (equal? x test-file-contents))
+       (lambda ()
+         (let ([frame-name 
+                (send-sexp-to-mred
+                 `(let ([frame (new ,class-expression)])
+                    (preferences:set 'framework:file-dialogs 'common)
+                    (send frame show #t)
+                    (send frame get-label)))])
+           (wait-for-frame frame-name)
+           (send-sexp-to-mred
+            `(test:menu-select "File" "Open..."))
+           (wait-for-frame "Get file")
+           (call-with-output-file tmp-file
+             (lambda (port)
+               (display test-file-contents port))
+             'truncate)
+           (send-sexp-to-mred
+            `(begin (send (find-labelled-window "Full pathname") focus)
+                    ,(case (system-type)
+                       [(macos macosx) `(test:keystroke #\a '(meta))]
+                       [(unix) `(test:keystroke #\a '(meta))]
+                       [(windows) `(test:keystroke #\a '(control))]
+                       [else (error 'file-open-dialog "unknown system type: ~a" (system-type))])
+                    (for-each test:keystroke
+                              (string->list ,(path->string tmp-file)))
+                    (test:keystroke #\return)))
+           (wait-for-frame tmp-file-name)
+           (begin0
+             (send-sexp-to-mred
+              `(let* ([w (get-top-level-focus-window)]
+                      [t (send (send w get-editor) get-text)])
+                 (test:close-top-level-window w)
+                 t))
+             (wait-for-frame frame-name)
+             (queue-sexp-to-mred
+              `(send (get-top-level-focus-window) close))))))))
+  
+  (test-open "frame:searchable open" 'frame:searchable%)
+  (test-open "frame:text open" 'frame:text%))
diff --git a/collects/tests/framework/framework-test-engine.icns b/collects/tests/framework/framework-test-engine.icns
new file mode 100644
index 0000000000..4dbb8be9d3
Binary files /dev/null and b/collects/tests/framework/framework-test-engine.icns differ
diff --git a/collects/tests/framework/framework-test-engine.ss b/collects/tests/framework/framework-test-engine.ss
new file mode 100644
index 0000000000..bb922b6c7f
--- /dev/null
+++ b/collects/tests/framework/framework-test-engine.ss
@@ -0,0 +1,73 @@
+
+(module framework-test-engine mzscheme
+  (require (lib "pconvert.ss")
+	   (lib "mred.ss" "mred")
+	   "debug.ss")
+
+  (define errs null)
+  (define sema (make-semaphore 1))
+  (define (protect f)
+    (semaphore-wait sema)
+    (begin0 (f)
+	    (semaphore-post sema)))
+
+  (define (exception->string x)
+    (if (exn? x)
+	(let ([p (open-output-string)])
+	  (parameterize ([current-error-port p])
+	    ((error-display-handler) (exn-message x) x))
+	  (get-output-string p))
+	(format "uncaught exn: ~s" x)))
+
+  (thread
+   (lambda ()
+     (with-handlers ([(lambda (x) #t)
+		      (lambda (x)
+			(printf "test suite thread died: ~a~n"
+				(if (exn? x)
+				    (exn-message x)
+				    (format "~s" x))))])
+       (let ([port (load
+		    (build-path
+		     (collection-path "tests" "framework")
+		     "receive-sexps-port.ss"))])
+	 (debug-printf mr-tcp "about to connect to ~a~n" port)
+	 (let*-values ([(in out) (tcp-connect "127.0.0.1" port)])
+	   (let loop ()
+	     (debug-printf mr-tcp "about to read~n")
+	     (let ([sexp (read in)])
+	       (if (eof-object? sexp)
+		   (begin
+		     (debug-printf mr-tcp "got eof~n")
+		     (close-input-port in)
+		     (close-output-port out)
+		     (exit))
+		   (begin
+		     (debug-printf mr-tcp "got expression to evaluate~n")
+		     (write
+		      (let ([these-errs (protect (lambda () (begin0 errs (set! errs null))))])
+			(if (null? these-errs)
+			    (with-handlers ([(lambda (x) #t)
+					     (lambda (x) (list 'error (exception->string x)))])
+			      (list 'normal (print-convert (eval sexp))))
+			    (list 'last-error
+				  (apply string-append
+					 (map (lambda (x) (string-append (exception->string x) (string #\newline)))
+					      these-errs)))))
+		      out)
+		     (loop))))))))))
+
+  (let ([od (event-dispatch-handler)]
+	[port (current-output-port)])
+    (event-dispatch-handler
+     (lambda (evt)
+       (parameterize ([current-exception-handler
+		       (let ([oe (current-exception-handler)])
+			 (lambda (exn)
+			   (protect
+			    (lambda ()
+			      (set! errs (cons exn errs))))
+			   (oe exn)))])
+	 (od evt)))))
+
+  (yield (make-semaphore 0)))
diff --git a/collects/tests/framework/group-test.ss b/collects/tests/framework/group-test.ss
new file mode 100644
index 0000000000..36fb5dbab3
--- /dev/null
+++ b/collects/tests/framework/group-test.ss
@@ -0,0 +1,157 @@
+(module group-test mzscheme
+  (require "test-suite-utils.ss")
+  
+  (test
+   'exit-on
+   (lambda (x) #t)
+   (lambda ()
+     (send-sexp-to-mred
+      '(begin (send (make-object frame:basic% "first") show #t)
+              (preferences:set 'framework:verify-exit #t)))
+     (wait-for-frame "first")
+     (send-sexp-to-mred
+      `(queue-callback (lambda () (send (get-top-level-focus-window) close))))
+     (wait-for-frame "Warning")
+     (send-sexp-to-mred
+      `(test:button-push "Cancel"))
+     (wait-for-frame "first")
+     'passed))
+  
+  ;; after the first test, we should have one frame that will always
+  ;; be in the group.
+  
+  (test
+   'one-frame-registered
+   (lambda (x) (equal? x (list "test" "first")))
+   (lambda ()
+     (send-sexp-to-mred
+      `(send (make-object frame:basic% "test") show #t))
+     (wait-for-frame "test")
+     (send-sexp-to-mred
+      `(begin0
+         (map (lambda (x) (send x get-label)) (send (group:get-the-frame-group) get-frames))
+         (send (get-top-level-focus-window) close)))))
+  
+  (test
+   'two-frames-registered
+   (lambda (x) (equal? x (list "test2" "test1" "first")))
+   (lambda ()
+     (send-sexp-to-mred
+      '(send (make-object frame:basic% "test1") show #t))
+     (wait-for-frame "test1")
+     (send-sexp-to-mred
+      '(send (make-object frame:basic% "test2") show #t))
+     (wait-for-frame "test2")
+     (send-sexp-to-mred
+      `(begin0
+         (let ([frames (send (group:get-the-frame-group) get-frames)])
+           (for-each (lambda (x) 
+                       (unless (equal? (send x get-label) "first")
+                         (send x close)))
+                     frames)
+           (map (lambda (x) (send x get-label)) frames))))))
+  
+  (test
+   'one-frame-unregistered
+   (lambda (x) (equal? x (list "test1" "first")))
+   (lambda ()
+     (send-sexp-to-mred
+      '(send (make-object frame:basic% "test1") show #t))
+     (wait-for-frame "test1")
+     (send-sexp-to-mred
+      '(send (make-object frame:basic% "test2") show #t))
+     (wait-for-frame "test2")
+     (queue-sexp-to-mred
+      `(send (get-top-level-focus-window) close))
+     (send-sexp-to-mred
+      `(let ([frames (send (group:get-the-frame-group) get-frames)])
+         (for-each (lambda (x) 
+                     (unless (equal? (send x get-label) "first")
+                       (send x close)))
+                   frames)
+         (map (lambda (x) (send x get-label)) frames)))))
+  
+  (test
+   'windows-menu
+   (lambda (x)
+     (equal? x (list "Bring Frame to Front..." "Most Recent Window" 
+                     #f "first" "test")))
+   (lambda ()
+     (send-sexp-to-mred
+      '(let ([frame (make-object frame:basic% "test")])
+         (send frame show #t)))
+     (wait-for-frame "test")
+     (send-sexp-to-mred
+      '(begin0
+         (map
+          (lambda (x) (and (is-a? x labelled-menu-item<%>) (send x get-label)))
+          (send (car (send (send (get-top-level-focus-window) get-menu-bar) get-items)) get-items))
+         (send (get-top-level-focus-window) close)))))
+  
+  (test
+   'windows-menu-unshown
+   (lambda (x)
+     (equal? x (list "Bring Frame to Front..." "Most Recent Window"
+                     #f "first" "test")))
+   (lambda ()
+     (send-sexp-to-mred
+      '(let ([frame1 (make-object frame:basic% "test")]
+             [frame2 (make-object frame:basic% "test-not-shown")])
+         (send frame1 show #t)))
+     (wait-for-frame "test")
+     (send-sexp-to-mred
+      '(begin0
+         (map
+          (lambda (x) (and (is-a? x labelled-menu-item<%>) (send x get-label)))
+          (send (car (send (send (get-top-level-focus-window) get-menu-bar) get-items)) get-items))
+         (send (get-top-level-focus-window) close)))))
+  
+  (test
+   'windows-menu-sorted1
+   (lambda (x)
+     (equal? x (list "Bring Frame to Front..." "Most Recent Window"
+                     #f "aaa" "bbb" "first")))
+   (lambda ()
+     (send-sexp-to-mred
+      '(let ([frame (make-object frame:basic% "aaa")])
+         (send frame show #t)))
+     (wait-for-frame "aaa")
+     (send-sexp-to-mred
+      '(let ([frame (make-object frame:basic% "bbb")])
+         (send frame show #t)))
+     (wait-for-frame "bbb")
+     (send-sexp-to-mred
+      `(let ([frames (send (group:get-the-frame-group) get-frames)])
+         (begin0
+           (map
+            (lambda (x) (and (is-a? x labelled-menu-item<%>) (send x get-label)))
+            (send (car (send (send (car frames) get-menu-bar) get-items)) get-items))
+           (for-each (lambda (x) 
+                       (unless (equal? (send x get-label) "first")
+                         (send x close)))
+                     frames))))))
+  
+  (test
+   'windows-menu-sorted2
+   (lambda (x)
+     (equal? x (list "Bring Frame to Front..." "Most Recent Window"
+                     #f "aaa" "bbb" "first")))
+   (lambda ()
+     (send-sexp-to-mred
+      '(let ([frame (make-object frame:basic% "bbb")])
+         (send frame show #t)))
+     (wait-for-frame "bbb")
+     (send-sexp-to-mred
+      '(let ([frame (make-object frame:basic% "aaa")])
+         (send frame show #t)))
+     (wait-for-frame "aaa")
+     (send-sexp-to-mred
+      `(let ([frames (send (group:get-the-frame-group) get-frames)])
+         (begin0
+           (map
+            (lambda (x) (and (is-a? x labelled-menu-item<%>) (send x get-label)))
+            (send (car (send (send (car frames) get-menu-bar) get-items)) get-items))
+           (for-each (lambda (x) 
+                       (unless (equal? (send x get-label) "first")
+                         (send x close)))
+                     frames)))))))
diff --git a/collects/tests/framework/handler-test.ss b/collects/tests/framework/handler-test.ss
new file mode 100644
index 0000000000..a6e79334ae
--- /dev/null
+++ b/collects/tests/framework/handler-test.ss
@@ -0,0 +1,47 @@
+(module handler-test mzscheme
+  (require "test-suite-utils.ss")
+
+(let* ([filename "framework-group-test.ss"]
+       [tmp-filename (build-path (find-system-path 'temp-dir) filename)])
+
+  (test
+   'file-opened
+   (lambda (x) (equal? (list filename "MrEd REPL") x))
+   (lambda ()
+     (send-sexp-to-mred
+      `(begin (handler:edit-file ,tmp-filename)
+	      (void)))
+     (wait-for-frame filename)
+     (send-sexp-to-mred
+      `(begin0 (map (lambda (x) (send x get-label)) (get-top-level-windows))
+               (send (car (get-top-level-windows)) close)))))
+
+  (test
+   'files-opened-twice
+   (lambda (x) (equal? (list filename "MrEd REPL") x))
+   (lambda ()
+     (send-sexp-to-mred
+      `(begin (handler:edit-file ,tmp-filename)
+	      (void)))
+     (wait-for-frame filename)
+     (send-sexp-to-mred
+      `(begin (handler:edit-file ,tmp-filename)
+	      (void)))
+     (wait-for-frame filename)
+     (send-sexp-to-mred
+      `(begin0 (map (lambda (x) (send x get-label)) (get-top-level-windows))
+               (send (car (get-top-level-windows)) close)))))
+
+  (test
+   'file-opened-in-editor
+   (lambda (x) (equal? filename x))
+   (lambda ()
+     (send-sexp-to-mred
+      `(begin (handler:edit-file ,tmp-filename)
+	      (void)))
+     (wait-for-frame filename)
+     (send-sexp-to-mred
+      `(let ([f (car (get-top-level-windows))])
+	 (send (send f get-editor) get-filename))))))
+
+)
diff --git a/collects/tests/framework/info.ss b/collects/tests/framework/info.ss
new file mode 100644
index 0000000000..d347c146f5
--- /dev/null
+++ b/collects/tests/framework/info.ss
@@ -0,0 +1,7 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Framework Test Suite")
+  (define compile-omit-files '("key-specs.ss" "utils.ss" "receive-sexps-port.ss"))
+  (define mred-launcher-libraries (list "framework-test-engine.ss"))
+  (define mred-launcher-names (list "Framework Test Engine"))
+  (define mzscheme-launcher-libraries (list "main.ss"))
+  (define mzscheme-launcher-names (list "Framework Test")))
diff --git a/collects/tests/framework/key-specs.ss b/collects/tests/framework/key-specs.ss
new file mode 100644
index 0000000000..ab643fd5e5
--- /dev/null
+++ b/collects/tests/framework/key-specs.ss
@@ -0,0 +1,29 @@
+(define-struct key-spec (before after macos unix windows))
+(define-struct buff-spec (string start end))
+
+(define global-specs
+  (list
+   (make-key-spec (make-buff-spec "abc" 1 1)
+		  (make-buff-spec "abc" 2 2)
+		  (list '(#\f control) '(right))
+		  (list '(#\f control) '(right))
+		  (list '(#\f control) '(right)))))
+
+(define scheme-specs
+  (list 
+   (make-key-spec (make-buff-spec "(abc (def))" 4 4)
+		  (make-buff-spec "(abc (def))" 10 10)
+		  (list ;'(#\f alt control)
+			'(right alt))
+		  (list ;'(#\f alt control)
+			'(right alt))
+		  (list ;'(#\f alt control)
+			'(right alt)))
+   (make-key-spec (make-buff-spec "'(abc (def))" 1 1)
+		  (make-buff-spec "'(abc (def))" 12 12)
+		  (list ;'(#\f alt control)
+			'(right alt))
+		  (list ;'(#\f alt control)
+			'(right alt))
+		  (list ;'(#\f alt control)
+			'(right alt)))))
diff --git a/collects/tests/framework/keys.ss b/collects/tests/framework/keys.ss
new file mode 100644
index 0000000000..2b5c818241
--- /dev/null
+++ b/collects/tests/framework/keys.ss
@@ -0,0 +1,129 @@
+(module keys mzscheme
+  (require "test-suite-utils.ss")
+  (require (lib "include.ss"))
+
+(test
+ 'keymap:aug-keymap%/get-table
+ (lambda (x)
+   (equal? '((c:k "abc")) x))
+ (lambda ()
+   (send-sexp-to-mred
+    '(let ([k (make-object keymap:aug-keymap%)])
+       (send k add-function "abc" void)
+       (send k map-function "c:k" "abc")
+       (hash-table-map (send k get-map-function-table) list)))))
+
+(test
+ 'keymap:aug-keymap%/get-table/ht
+ (lambda (x)
+   (equal? x '((c:k "def"))))
+ (lambda ()
+   (send-sexp-to-mred
+    '(let ([k (make-object keymap:aug-keymap%)]
+	   [ht (make-hash-table)])
+       (send k add-function "abc" void)
+       (send k map-function "c:k" "abc")
+       (hash-table-put! ht 'c:k "def")
+       (hash-table-map (send k get-map-function-table/ht ht) list)))))
+
+(test
+ 'keymap:aug-keymap%/get-table/chain1
+ (lambda (x)
+   (equal? x '((c:k "abc-k2"))))
+ (lambda ()
+   (send-sexp-to-mred
+    '(let ([k (make-object keymap:aug-keymap%)]
+	   [k1 (make-object keymap:aug-keymap%)]
+	   [k2 (make-object keymap:aug-keymap%)])
+       (send k1 add-function "abc-k1" void)
+       (send k1 map-function "c:k" "abc-k1")
+       (send k2 add-function "abc-k2" void)
+       (send k2 map-function "c:k" "abc-k2")
+       (send k chain-to-keymap k1 #t)
+       (send k chain-to-keymap k2 #t)
+       (hash-table-map (send k get-map-function-table) list)))))
+
+(test
+ 'keymap:aug-keymap%/get-table/chain/2
+ (lambda (x)
+   (equal? x '((c:k "abc-k"))))
+ (lambda ()
+   (send-sexp-to-mred
+    '(let ([k (make-object keymap:aug-keymap%)]
+	   [k1 (make-object keymap:aug-keymap%)])
+       (send k1 add-function "abc-k1" void)
+       (send k1 map-function "c:k" "abc-k1")
+       (send k add-function "abc-k" void)
+       (send k map-function "c:k" "abc-k")
+       (send k chain-to-keymap k1 #t)
+       (hash-table-map (send k get-map-function-table) list)))))
+
+(define (test-canonicalize name str1 str2)
+  (test
+   (string->symbol (format "keymap:canonicalize-keybinding-string/~a" name))
+   (lambda (x)
+     (string=? x str2))
+   (lambda ()
+     (send-sexp-to-mred
+      `(keymap:canonicalize-keybinding-string ,str2)))))
+
+(test-canonicalize 1 "c:a" "c:a")
+(test-canonicalize 2 "d:a" "d:a")
+(test-canonicalize 3 "m:a" "m:a")
+(test-canonicalize 4 "a:a" "a:a")
+(test-canonicalize 5 "s:a" "s:a")
+(test-canonicalize 6 "c:a" "c:a")
+(test-canonicalize 7 "s:m:d:c:a:a" "a:c:d:m:s:a")
+(test-canonicalize 8 "~s:~m:~d:~c:~a:a" "~a:~c:~d:~m:~s:a")
+(test-canonicalize 9 ":a" "~a:~c:~d:~m:~s:a")
+(test-canonicalize 10 ":d:a" "~a:~c:d:~m:~s:a")
+(test-canonicalize 11 "esc;s:a" "esc;s:a")
+(test-canonicalize 12 "s:a;esc" "s:a;esc")
+
+(include "key-specs.ss")
+
+(send-sexp-to-mred `(send (make-object frame:basic% "dummy to trick frame group") show #t))
+(wait-for-frame "dummy to trick frame group")
+
+(define (test-key key-spec)
+  (let* ([keys ((case (system-type)
+		  [(macos) key-spec-macos]
+		  [(unix) key-spec-unix]
+		  [(windows) key-spec-windows])
+		key-spec)]
+	 [before (key-spec-before key-spec)]
+	 [after (key-spec-after key-spec)]
+	 [process-key
+	  (lambda (key)
+	    (let ([text-expect (buff-spec-string after)]
+		  [start-expect (buff-spec-start after)]
+		  [end-expect (buff-spec-end after)])
+	      (test key
+		    (lambda (x) (equal? x (vector text-expect start-expect end-expect)))
+		    `(let* ([text (send (get-top-level-focus-window) get-editor)])
+		       (send text erase)
+		       (send text insert ,(buff-spec-string before))
+		       (send text set-position ,(buff-spec-start before) ,(buff-spec-end before))
+		       (test:keystroke ',(car key) ',(cdr key))
+		       (vector (send text get-text)
+			       (send text get-start-position)
+			       (send text get-end-position))))))])
+    (for-each process-key keys)))
+
+(define (test-specs frame-name frame-class specs)
+  (send-sexp-to-mred `(send (make-object ,frame-class ,frame-name) show #t))
+  (wait-for-frame frame-name)
+  (for-each test-key specs)
+  (send-sexp-to-mred `(send (get-top-level-focus-window) close)))
+
+(test-specs "global keybingings test" 'frame:text% global-specs)
+(test-specs "scheme mode keybindings test" 
+	    '(class frame:editor% (name)
+	       (override
+		[get-editor%
+		 (lambda ()
+		   (scheme:text-mixin text:basic%))])
+	       (sequence (super-init name)))
+	    scheme-specs)
+
+)
diff --git a/collects/tests/framework/load.ss b/collects/tests/framework/load.ss
new file mode 100644
index 0000000000..56d1dbc543
--- /dev/null
+++ b/collects/tests/framework/load.ss
@@ -0,0 +1,65 @@
+(module load mzscheme
+  (require "test-suite-utils.ss")
+
+  (load-framework-automatically #f)
+
+  (define (test/load file exp)
+    (test
+     (string->symbol file)
+     void?
+     `(let ([mred-name 
+             ((current-module-name-resolver) '(lib "mred.ss" "mred") #f #f)]
+            [orig-namespace (current-namespace)])
+        (parameterize ([current-namespace (make-namespace)])
+          (namespace-attach-module
+           orig-namespace           mred-name)
+          (eval '(require (lib ,file "framework")))
+          (with-handlers ([(lambda (x) #t)
+                           (lambda (x)
+                             (if (exn? x)
+                                 (exn-message x)
+                                 (format "~s" x)))])
+            (eval ',exp)
+            (void))))))
+
+ 
+  (test/load "gui-utils.ss" 'gui-utils:next-untitled-name)
+  (test/load "test.ss" 'test:run-interval)
+  (test/load "splash.ss" 'start-splash)
+  (test/load "framework-sig.ss" '(begin (eval '(require (lib "unitsig.ss")))
+                                        (eval '(define-signature dummy-signature^ framework^))))
+  (test/load "framework-unit.ss" 'framework@)
+  (test/load "framework.ss" '(list test:button-push
+				   gui-utils:next-untitled-name
+				   frame:basic-mixin))
+  
+  ;; ensures that all of the names in the signature are provided
+  ;; by (require (lib "framework.ss" "framework"))
+  (test/load 
+   "framework.ss"
+   ;; these extra evals let me submit multiple, independent top-level
+   ;; expressions in the newly created namespace.
+   '(begin (eval '(require (lib "unitsig.ss")))
+           (eval '(require (lib "framework-sig.ss" "framework")))
+           (eval '(letrec ([prepend-symbol
+                            (lambda (s1)
+                              (lambda (s2)
+                                (string->symbol
+                                 (string-append
+                                  (symbol->string s1)
+                                  ":"
+                                  (symbol->string s2)))))]
+                           ;; exp-sig = (union (vectorof exp-sig)
+                           ;;                  (cons sym exp-sig) 
+                           ;;                  symbol)
+                           [flatten ;; : exp-sig -> (listof symbol)
+                            (lambda (l)
+                              (cond
+                                [(vector? l) 
+                                 (apply append (map flatten (vector->list l)))]
+                                [(pair? l)
+                                 (map (prepend-symbol (car l)) (flatten (cdr l)))]
+                                [(symbol? l) (list l)]
+                                [else (error 'flatten "unk: ~e" l)]))]
+                        [names (flatten (signature->symbols framework^))])
+                    (for-each eval names))))))
diff --git a/collects/tests/framework/main.ss b/collects/tests/framework/main.ss
new file mode 100644
index 0000000000..19a170535a
--- /dev/null
+++ b/collects/tests/framework/main.ss
@@ -0,0 +1,97 @@
+(module main mzscheme 
+  (require (lib "launcher.ss" "launcher")
+	   (lib "cmdline.ss")
+	   (lib "unitsig.ss")
+	   "debug.ss"
+	   "test-suite-utils.ss")
+
+  (define argv (current-command-line-arguments))
+
+  (define preferences-file (find-system-path 'pref-file))
+
+  (define old-preferences-file (let-values ([(base name _2) (split-path preferences-file)])
+				 (build-path base (string-append (path->string name) ".save"))))
+  
+
+  (define all-files
+    (map symbol->string
+	 (load
+	  (build-path
+	   (collection-path "tests" "framework")
+	   "README"))))
+
+  (define all? #f)
+  (define 3m? #f)
+  (define files-to-process null)
+  (define command-line-flags
+    `((once-each
+       [("--3m")
+        ,(lambda (flag) (use-3m #t))
+        ("Run the tests using a 3m mred")]
+       [("-a" "--all")
+	,(lambda (flag)
+	   (set! all? #t))
+	("Run all of the tests")])
+      (multi
+       [("-o" "--only")
+	,(lambda (flag _only-these-tests)
+	   (set-only-these-tests! (cons (string->symbol _only-these-tests)
+					(or (get-only-these-tests) null))))
+	("Only run test named <test-name>" "test-name")])))
+      
+  (parse-command-line "framework-test" argv command-line-flags
+		      (lambda (collected . files)
+			(set! files-to-process (if (or all? (null? files)) all-files files)))
+		      `("Names of the tests; defaults to all tests"))
+
+  (when (file-exists? preferences-file)
+    (debug-printf admin "  saving preferences file ~s to ~s~n" preferences-file old-preferences-file)
+    (if (file-exists? old-preferences-file)
+	(debug-printf admin "  backup preferences file exists, using that one~n")
+	(begin (copy-file preferences-file old-preferences-file)
+	       (debug-printf admin "  saved preferences file~n"))))
+      
+  (with-handlers ([(lambda (x) #f)
+		   (lambda (x) (display (exn-message x)) (newline))])
+    (for-each
+     (lambda (x)
+       (when (member x all-files)
+	 (shutdown-mred)
+         (load-framework-automatically #t)
+	 (let/ec k
+	   (dynamic-wind
+	    (lambda ()
+	      (set-section-name! x)
+	      (set-section-jump! k))
+	    (lambda ()
+	      (with-handlers ([(lambda (x) #t)
+			       (lambda (exn)
+				 (debug-printf schedule "~a~n" (if (exn? exn) (exn-message exn) exn)))])
+
+		(debug-printf schedule "beginning ~a test suite~n" x)
+		(dynamic-require `(lib ,x "tests" "framework") #f)
+		(debug-printf schedule "PASSED ~a test suite~n" x)))
+	    (lambda ()
+	      (reset-section-name!)
+	      (reset-section-jump!))))))
+     files-to-process))
+
+  (debug-printf admin "  restoring preferences file ~s to ~s~n" old-preferences-file preferences-file)
+  (when (file-exists? preferences-file)
+    (unless (file-exists? old-preferences-file)
+      (error 'framework-test "lost preferences file backup!"))
+    (delete-file preferences-file)
+    (copy-file old-preferences-file preferences-file)
+    (delete-file old-preferences-file))
+  (debug-printf admin "  restored preferences file~n")
+
+  (shutdown-listener)
+
+  (cond
+   [(null? failed-tests)
+    (printf "All tests passed.~n")]
+   [else
+    (debug-printf schedule "FAILED tests:~n")
+    (for-each (lambda (failed-test)
+		(debug-printf schedule "  ~a // ~a~n" (car failed-test) (cdr failed-test)))
+	      failed-tests)]))
diff --git a/collects/tests/framework/mem.ss b/collects/tests/framework/mem.ss
new file mode 100644
index 0000000000..0bf6ee7202
--- /dev/null
+++ b/collects/tests/framework/mem.ss
@@ -0,0 +1,173 @@
+(module mem mzscheme
+  (require "test-suite-utils.ss")
+  
+  ; mem-boxes : (list-of (list string (list-of (weak-box TST))))
+  (send-sexp-to-mred '(define mem-boxes null))
+  
+  (define mem-count 10)
+  
+  (define (test-allocate tag open close)
+    (send-sexp-to-mred
+     `(let ([new-boxes
+             (let loop ([n ,mem-count])
+               (cond
+                 [(zero? n) null]
+                 [else
+                  (let* ([o (,open)]
+                         [b (make-weak-box o)])
+                    (,close o)
+                    
+                    ;; break at least that link.
+                    (set! o #f)
+
+                    ;; flush pending events
+                    (let ([s (make-semaphore 0)])
+                      (queue-callback (lambda () (semaphore-post s)) #f)
+                      (yield s))
+                    
+                    (cons b (loop (- n 1))))]))])
+        (sleep/yield 1/10) (collect-garbage)
+        (sleep/yield 1/10) (collect-garbage)
+        (sleep/yield 1/10) (collect-garbage)
+        (set! mem-boxes (cons (list ,tag new-boxes) mem-boxes)))))
+  
+  (define (done)
+    (send-sexp-to-mred
+     `(begin
+        (yield) (collect-garbage)
+        (yield) (collect-garbage)
+        (yield) (collect-garbage)
+        (yield) (collect-garbage)
+        (yield) (collect-garbage)
+        (yield) (collect-garbage)
+        (let* ([f (make-object dialog% "Results" #f 300 500)]
+               [text (make-object text%)]
+               [ec (make-object editor-canvas% f text)]
+               [hp (instantiate horizontal-panel% () 
+                     (parent f)
+                     (stretchable-width #f)
+                     (stretchable-height #f))]
+               [vp (instantiate vertical-panel% ()
+                     (parent hp)
+                     (stretchable-width #f)
+                     (stretchable-height #f))]
+               [gc-canvas (make-object canvas% hp '(border))]
+               [anything? #f])
+          
+          (define (update-gui)
+            (send text erase)
+            (let ([anything? #f])
+              (send text begin-edit-sequence)
+              (for-each
+               (lambda (boxl)
+                 (let* ([tag (car boxl)]
+                        [boxes (cadr boxl)]
+                        [calc-results
+                         (lambda ()
+                           (let loop ([boxes boxes]
+                                      [n 0])
+                             (cond
+                               [(null? boxes) n]
+                               [else (if (weak-box-value (car boxes))
+                                         (loop (cdr boxes) (+ n 1))
+                                         (loop (cdr boxes) n))])))])
+                   (let ([res (calc-results)])
+                     (when (> res 0)
+                       (set! anything? #t)
+                       (send text insert (format "~a: ~a of ~a\n" tag res ,mem-count))))))
+               (reverse mem-boxes))
+              (unless anything?
+                (send text insert "Nothing!\n"))
+              (send text end-edit-sequence)))
+          
+          (update-gui)
+          
+          (let ([onb (icon:get-gc-on-bitmap)]
+                [offb (icon:get-gc-off-bitmap)])
+            (when (and (send onb ok?)
+                       (send offb ok?))
+              (send* gc-canvas
+                (min-client-width (max (send gc-canvas min-width) (send onb get-width)))
+                (min-client-height (max (send gc-canvas min-height) (send onb get-height)))
+                (stretchable-width #f)
+                (stretchable-height #f))
+              (register-collecting-blit gc-canvas 
+                                        0 0
+                                        (send onb get-width)
+                                        (send onb get-height)
+                                        onb offb)))
+          
+          (make-object button% 
+            "Collect" 
+            vp
+            (lambda (x y)
+              (send text erase)
+              (send text insert "Collecting Garbage\n")
+              (collect-garbage)(collect-garbage)(collect-garbage)
+              (collect-garbage)(collect-garbage)(collect-garbage)
+              (collect-garbage)(collect-garbage)(collect-garbage)
+              (update-gui)))
+          (make-object button% "Close" vp (lambda (x y) (send f show #f)))
+          (send f show #t)))))
+  
+  (define (test-frame-allocate %)
+    (let ([name (format "~s" %)])
+      (send-sexp-to-mred '(preferences:set 'framework:exit-when-no-frames #f))
+      (test-allocate name
+                     `(lambda () (let ([f (make-object ,% ,name)])
+                                   (send f show #t)
+                                   (yield) (yield)
+                                   f))
+                     `(lambda (f)
+                        (yield) (yield)
+                        (send f close)
+                        (when (send f is-shown?)
+                          (error 'test-frame-allocate "~a instance didn't close" ',%))
+                        (yield) (yield)))
+      (send-sexp-to-mred '(preferences:set 'framework:exit-when-no-frames #t))))
+  
+  (test-allocate "frame%"
+                 '(lambda () (let ([f (make-object frame% "test frame")])
+                               (send f show #t)
+                               f))
+                 '(lambda (f) (send f show #f)))
+  
+  
+  (define (test-editor-allocate object-name)
+    (test-allocate (symbol->string object-name)
+                   `(lambda () (make-object ,object-name))
+                   '(lambda (e) (send e on-close))))
+  
+  (test-editor-allocate 'text:basic%)
+  (test-editor-allocate 'text:keymap%)
+  (test-editor-allocate 'text:autowrap%)
+  (test-editor-allocate 'text:file%)
+  (test-editor-allocate 'text:clever-file-format%)
+  (test-editor-allocate 'text:backup-autosave%)
+  (test-editor-allocate 'text:searching%)
+  (test-editor-allocate 'text:info%)
+  
+  (test-editor-allocate 'pasteboard:basic%)
+  (test-editor-allocate 'pasteboard:keymap%)
+  (test-editor-allocate 'pasteboard:file%)
+  (test-editor-allocate 'pasteboard:backup-autosave%)
+  (test-editor-allocate 'pasteboard:info%)
+  
+  (test-editor-allocate 'scheme:text%)
+  
+  (test-allocate "text:return%"
+                 '(lambda () (make-object text:return% void))
+                 '(lambda (t) (void)))
+  
+  (test-frame-allocate '(class frame% (inherit show) (define/public (close) (show #f)) (super-new)))
+  (test-frame-allocate 'frame:basic%)
+  (test-frame-allocate 'frame:info%)
+  (test-frame-allocate 'frame:text-info%)
+  (test-frame-allocate 'frame:pasteboard-info%)
+  (test-frame-allocate 'frame:standard-menus%)
+  
+  (test-frame-allocate 'frame:text%)
+  (test-frame-allocate 'frame:searchable%)
+  
+  (test-frame-allocate 'frame:pasteboard%)
+  (done))
diff --git a/collects/tests/framework/panel.ss b/collects/tests/framework/panel.ss
new file mode 100644
index 0000000000..4b3a7b1f7a
--- /dev/null
+++ b/collects/tests/framework/panel.ss
@@ -0,0 +1,135 @@
+(module panel mzscheme
+  (require "test-suite-utils.ss")
+
+(test 
+ 'single-panel
+ (lambda (x) (eq? x 'passed))
+ `(let* ([semaphore (make-semaphore 0)]
+	 [semaphore-frame%
+	  (class frame% 
+	    (define/augment (on-close) (semaphore-post semaphore))
+	    (super-new))]
+	 [f (make-object semaphore-frame% "Single Panel Test")]
+	 [blue-brush (send the-brush-list find-or-create-brush "BLUE" 'solid)]
+	 [green-brush (send the-brush-list find-or-create-brush "FOREST GREEN" 'solid)]
+	 [black-pen (send the-pen-list find-or-create-pen "BLACK" 1 'solid)]
+	 [grid-canvas%
+	  (class canvas% 
+	    (init-field lines)
+	    (init label)
+	    (inherit get-dc get-client-size)
+	    (override on-paint)
+	    (define (on-paint)
+	      (let-values ([(width height) (get-client-size)])
+		(let ([dc (get-dc)]
+		      [single-width (/ width lines)]
+		      [single-height (/ height lines)])
+		  (send dc set-pen black-pen)
+		  (let loop ([i lines])
+		    (cond
+		      [(zero? i) (void)]
+		      [else
+		       (let loop ([j lines])
+			 (cond
+			   [(zero? j) (void)]
+			   [else 
+			    (send dc set-brush
+				  (if (= 0 (modulo (+ i j) 2))
+				      blue-brush green-brush))
+			    (send dc draw-rectangle
+				  (* single-width (- i 1))
+				  (* single-height (- j 1))
+				  single-width
+				  single-height)
+			    (loop (- j 1))]))
+		       (loop (- i 1))])))))
+	    (super-instantiate ())
+
+	    ;; soon to be obsolete, hopefully.
+	    (inherit set-label)
+	    (set-label label)
+
+	    (inherit min-width min-height)
+	    (min-width 50)
+	    (min-height 50))]
+	 [border-panel (make-object horizontal-panel% f '(border))]
+	 [single-panel (make-object panel:single% border-panel)]
+	 [children
+	  (list
+	   (instantiate grid-canvas% () (lines 3) (parent single-panel) (label "Small") (stretchable-width #f) (stretchable-height #f))
+	   (instantiate grid-canvas% () (lines 3) (parent single-panel) (label "Wide") (stretchable-width #f) (stretchable-height #t))
+	   (instantiate grid-canvas% () (lines 3) (parent single-panel) (label "Tall") (stretchable-width #t) (stretchable-height #f))
+	   (instantiate grid-canvas% () (lines 3) (parent single-panel) (label "Wide and Tall") (stretchable-width #t) (stretchable-height #t)))]
+	 [active-child (car children)]
+	 [radios (make-object horizontal-panel% f)]
+	 [make-radio
+	  (lambda (label choices callback)
+	    (let* ([panel (make-object vertical-panel% radios '(border))]
+		   [message (make-object message% label panel)]
+		   [radio (make-object radio-box% #f choices panel (lambda (radio _) (callback radio)))]
+		   [button (make-object button%
+			     "Cycle" panel
+			     (lambda (_1 _2)
+			       (let ([before (send radio get-selection)]
+				     [tot (send radio get-number)])
+				 (let loop ([n tot])
+				   (unless (zero? n)
+				     (send radio set-selection (- tot n))
+				     (callback radio)
+				     (sleep/yield 1)
+				     (loop (- n 1))))
+				 (send radio set-selection before)
+				 (callback radio))))])
+	      radio))]
+	 [radio
+	  (make-radio
+	   "Active Child"
+	   (map (lambda (x) (send x get-label)) children)
+	   (lambda (radio)
+	     (let loop ([n (length children)]
+			[cs children])
+	       (cond
+		 [(null? cs) (void)]
+		 [else (let ([c (car cs)])
+			 (if (string=? (send radio get-item-label (send radio get-selection))
+				       (send c get-label))
+			     (begin (set! active-child c)
+				    (send single-panel active-child active-child))
+			     (loop (- n 1)
+				   (cdr cs))))]))))]
+	 [vertical-alignment 'center]
+	 [horizontal-alignment 'center]
+	 [update-alignment (lambda () 
+			     (send single-panel set-alignment horizontal-alignment vertical-alignment))]
+	 [horiz
+	  (make-radio 
+	   "Horizontal Alignment"
+	   (list "left" "center" "right")
+	   (lambda (radio)
+	     (set! horizontal-alignment (string->symbol (send radio get-item-label (send radio get-selection))))
+	     (update-alignment)))]
+	 [vert
+	  (make-radio
+	   "Vertical Alignment"
+	   (list "top" "center" "bottom")
+	   (lambda (radio)
+	     (set! vertical-alignment (string->symbol (send radio get-item-label (send radio get-selection))))
+	     (update-alignment)))]
+	 [buttons (make-object horizontal-panel% f)]
+	 [result 'failed]
+	 [failed (make-object button% "Failed" buttons (lambda (_1 _2) (semaphore-post semaphore)))]
+	 [passed (make-object button% "Passed" buttons (lambda (_1 _2) 
+							 (set! result 'passed)
+							 (semaphore-post semaphore)))])
+    (send border-panel min-width 100)
+    (send border-panel min-height 100)
+    (send vert set-selection 1)
+    (send horiz set-selection 1)
+    (send buttons stretchable-height #f)
+    (send buttons set-alignment 'right 'center)
+    (send radios stretchable-height #f)
+    (send f show #t)
+    (yield semaphore)
+    (send f show #f)
+    result))
+)
diff --git a/collects/tests/framework/pasteboard.ss b/collects/tests/framework/pasteboard.ss
new file mode 100644
index 0000000000..59a0d3c923
--- /dev/null
+++ b/collects/tests/framework/pasteboard.ss
@@ -0,0 +1,50 @@
+(module pasteboard mzscheme
+  (require "test-suite-utils.ss")
+
+(define (test-creation frame class name)
+  (test
+   name
+   (lambda (x) #t)
+   (lambda ()
+     (let ([frame-label
+	    (send-sexp-to-mred
+	     `(let* ([% (class ,frame
+			  (override get-editor%)
+			  [define (get-editor%)
+			    ,class])]
+		     [f (instantiate % ())])
+		(preferences:set 'framework:exit-when-no-frames #f)
+		(send f show #t)
+		(send f get-label)))])
+       (wait-for-frame frame-label)
+       (queue-sexp-to-mred
+	`(send (get-top-level-focus-window) close))))))
+
+(test-creation 'frame:editor%
+	       '(editor:basic-mixin pasteboard%)
+	       'editor:basic-mixin-creation)
+(test-creation 'frame:editor%
+	       'pasteboard:basic%
+	       'pasteboard:basic-creation)
+
+(test-creation 'frame:editor%
+	       '(editor:file-mixin pasteboard:keymap%)
+	       'editor:file-mixin-creation)
+(test-creation 'frame:editor%
+	       'pasteboard:file%
+	       'pasteboard:file-creation)
+
+(test-creation 'frame:editor%
+	       '(editor:backup-autosave-mixin pasteboard:file%)
+	       'editor:backup-autosave-mixin-creation)
+(test-creation 'frame:editor%
+	       'pasteboard:backup-autosave%
+	       'pasteboard:backup-autosave-creation)
+
+(test-creation 'frame:pasteboard%
+	       '(editor:info-mixin pasteboard:backup-autosave%)
+	       'editor:info-mixin-creation)
+(test-creation 'frame:pasteboard%
+	       'pasteboard:info%
+	       'pasteboard:info-creation)
+)
diff --git a/collects/tests/framework/prefs.ss b/collects/tests/framework/prefs.ss
new file mode 100644
index 0000000000..189f413d06
--- /dev/null
+++ b/collects/tests/framework/prefs.ss
@@ -0,0 +1,115 @@
+(module prefs mzscheme
+  (require "test-suite-utils.ss"
+	   (lib "etc.ss")
+	   (lib "list.ss"))
+  
+  (define ((check-eq? x) y) (eq? x y))
+  (define pref-sym 'plt:not-a-real-preference)
+  (define marshalling-pref-sym 'plt:not-a-real-preference-marshalling)
+  (define default-test-sym 'plt:not-a-real-preference-default-test)
+  
+  (define saved-prefs-file 
+    (let loop ([n 0])
+      (let ([candidate
+             (build-path (this-expression-source-directory)
+                         (format "save-prefs.~a" n))])
+        (if (file-exists? candidate)
+            (loop (+ n 1))
+            candidate)))) 
+  
+  (define prefs-file (find-system-path 'pref-file))
+  
+  (when (file-exists? prefs-file)
+    (copy-file prefs-file saved-prefs-file)
+    (delete-file prefs-file)
+    (printf "saved preferences file from ~s to ~s\n" prefs-file saved-prefs-file))
+  
+  (shutdown-mred)
+  
+  (test
+   'preference-unbound
+   (check-eq? 'passed)
+   `(with-handlers ([exn:unknown-preference?
+                     (lambda (x)
+                       'passed)])
+      (preferences:get ',pref-sym)))
+  (test 'preference-set-default/get
+        (check-eq? 'passed)
+        `(begin (preferences:set-default ',pref-sym 'passed symbol?)
+                (preferences:get ',pref-sym)))
+  (test 'preference-set/get
+        (check-eq? 'new-pref)
+        `(begin (preferences:set ',pref-sym 'new-pref)
+                (preferences:get ',pref-sym)))
+
+  (test 'preference-marshalling
+        (check-eq? 'the-answer)
+        `(begin (preferences:set-default ',marshalling-pref-sym (lambda () 'the-answer) procedure?)
+                (preferences:set-un/marshall ',marshalling-pref-sym
+                                             (lambda (f) (f))
+                                             (lambda (v) (lambda () v)))
+                (begin0 ((preferences:get ',marshalling-pref-sym))
+                        (preferences:set ',marshalling-pref-sym (lambda () 2))
+                        (preferences:save))))
+  (shutdown-mred)
+  (test 'preference-marshalling
+        (check-eq? 2)
+        `(begin (preferences:set-default ',marshalling-pref-sym (lambda () 'the-answer) procedure?)
+                (preferences:set-un/marshall ',marshalling-pref-sym
+                                             (lambda (f) (f))
+                                             (lambda (v) (lambda () v)))
+                ((preferences:get ',marshalling-pref-sym))))
+  
+  (with-handlers ([eof-result? (lambda (x) (void))])
+    (send-sexp-to-mred '(begin (preferences:set 'framework:verify-exit #f)
+                               (exit:exit)
+                               
+                               ;; do this yield here so that exit:exit
+                               ;; actually exits on this interaction.
+                               ;; right now, exit:exit queue's a new event to exit
+                               ;; instead of just exiting immediately.
+                               (yield (make-semaphore 0)))))
+  
+  (test 'preference-get-after-restart
+        (check-eq? 'new-pref)
+        `(begin (preferences:set-default ',pref-sym 'passed symbol?)
+                (preferences:get ',pref-sym)))
+
+  (test 'preference-no-set-default-stage1
+        (check-eq? 'stage1)
+        `(begin (preferences:set-default ',default-test-sym 'default symbol?)
+                (preferences:set ',default-test-sym 'new-value)
+                (preferences:save)
+                'stage1))
+  (shutdown-mred)
+  (test 'preference-no-set-default-stage2
+        (check-eq? 'stage2)
+        `(begin (preferences:save)
+                'stage2))
+  (shutdown-mred)
+  (test 'preference-no-set-default-stage3
+        (check-eq? 'new-value)
+        `(begin (preferences:set-default ',default-test-sym 'default symbol?)
+                (preferences:get ',default-test-sym)))
+  
+  (test 'dialog-appears
+        (lambda (x) (eq? 'passed x))
+        (lambda ()
+          (send-sexp-to-mred '(begin (send (make-object frame:basic% "frame") show #t)
+                                     (preferences:show-dialog)))
+          (wait-for-frame "Preferences")
+          (send-sexp-to-mred '(begin (preferences:hide-dialog)
+                                     (let ([f (get-top-level-focus-window)])
+                                       (if f
+                                           (if (string=? "Preferences" (send f get-label))
+                                               'failed
+                                               'passed)
+                                           'passed))))))
+  
+  (when (file-exists? saved-prefs-file)
+    (printf "restoring preferences file from ~s to ~s\n" saved-prefs-file prefs-file)
+    (when (file-exists? prefs-file)
+      (delete-file prefs-file))
+    (copy-file saved-prefs-file prefs-file)
+    (delete-file saved-prefs-file)))
+
diff --git a/collects/tests/framework/test-suite-utils.ss b/collects/tests/framework/test-suite-utils.ss
new file mode 100644
index 0000000000..dfa343b62f
--- /dev/null
+++ b/collects/tests/framework/test-suite-utils.ss
@@ -0,0 +1,302 @@
+
+(module test-suite-utils mzscheme
+  (require (lib "launcher.ss" "launcher")
+	   (lib "pretty.ss")
+	   (lib "list.ss")
+           (lib "process.ss")
+	   "debug.ss")
+
+  (provide
+   test-name
+   failed-tests
+
+   ;(struct eof-result ())
+   eof-result?
+
+   load-framework-automatically
+   shutdown-listener shutdown-mred mred-running?
+   use-3m
+   send-sexp-to-mred queue-sexp-to-mred
+   test
+   wait-for-frame
+
+   ;; sexp -> void
+   ;; grabs the frontmost window, executes the sexp and waits for a new frontmost window
+   wait-for-new-frame
+
+   wait-for
+
+   reset-section-jump!
+   set-section-jump!
+   reset-section-name!
+   set-section-name!
+   set-only-these-tests!
+   get-only-these-tests)
+  
+  (define use-3m (make-parameter #f))
+
+  (define section-jump void)
+  (define (set-section-jump! _s) (set! section-jump _s))
+  (define (reset-section-jump!) (set! section-jump #f))
+
+  (define section-name "<<setup>>")
+  (define (set-section-name! _s) (set! section-name _s))
+  (define (reset-section-name!) (set! section-name "<<setup>>"))
+
+  (define only-these-tests #f)
+  (define (get-only-these-tests) only-these-tests)
+  (define (set-only-these-tests! _t) (set! only-these-tests _t))
+
+  (define test-name "<<setup>>")
+  (define failed-tests null)
+
+  (define-struct eof-result ())
+
+  (define load-framework-automatically? #t)
+
+  (define initial-port 6012)
+  (define port-filename (build-path
+			 (collection-path "tests" "framework")
+			 "receive-sexps-port.ss"))
+
+  (unless (file-exists? port-filename)
+    (call-with-output-file port-filename
+      (lambda (port)
+	(write initial-port port))))
+
+  (define listener
+    (let loop ()
+      (let ([port (load port-filename)])
+	(with-handlers ([exn:fail?
+			 (lambda (x)
+			   (let ([next (+ port 1)])
+			     (call-with-output-file port-filename
+			       (lambda (p)
+				 (write next p))
+			       'truncate)
+			     (debug-printf mz-tcp "  tcp-listen failed for port ~a, attempting ~a~n"
+					   port
+					   next)
+			     (loop)))])
+	  (debug-printf mz-tcp "listening to ~a~n" port)
+	  (tcp-listen port)))))
+
+  (define in-port #f)
+  (define out-port #f)
+
+  (define (restart-mred)
+    (shutdown-mred)
+    (case (system-type)
+      [(macosx)
+       (thread
+        (lambda ()
+          (system*
+           (path->string
+            (build-path (collection-path "mzlib")
+                        'up
+                        'up
+                        "bin" 
+                        (if (use-3m)
+                            "mred3m"
+                            "mred")))
+           "-mvqt"
+           (path->string 
+            (build-path (collection-path "tests" "framework")
+                        "framework-test-engine.ss")))))]
+      [else (error 'test-suite-utils.ss "don't know how to start mred")])
+    (debug-printf mz-tcp "accepting listener~n")
+    (let-values ([(in out) (tcp-accept listener)])
+      (set! in-port in)
+      (set! out-port out))
+    (when load-framework-automatically?
+      (queue-sexp-to-mred
+       '(begin (eval '(require (lib "framework.ss" "framework")))
+	       (eval '(require (lib "gui.ss" "tests" "utils")))))))
+
+  (define load-framework-automatically
+    (case-lambda
+     [(new-load-framework-automatically?)
+      (unless (eq? (not (not new-load-framework-automatically?))
+		   load-framework-automatically?)
+	(set! load-framework-automatically? (not (not new-load-framework-automatically?)))
+	(shutdown-mred))]
+     [() load-framework-automatically?]))
+
+  (define shutdown-listener
+    (lambda ()
+      (shutdown-mred)
+      (debug-printf mz-tcp "closing listener~n")
+      (tcp-close listener)))
+
+  (define shutdown-mred
+    (lambda ()
+      (when (and in-port
+		 out-port)
+	(with-handlers ([exn:fail? (lambda (x) (void))])
+	  (close-output-port out-port))
+	(with-handlers ([exn:fail? (lambda (x) (void))])
+	  (close-input-port in-port))
+	(set! in-port #f)
+	(set! in-port #f))))
+
+  (define mred-running?
+    (lambda ()
+      (if (char-ready? in-port)
+	  (not (eof-object? (peek-char in-port)))
+	  #t)))
+
+  (define queue-sexp-to-mred
+    (lambda (sexp)
+      (send-sexp-to-mred
+       `(let ([thunk (lambda () ,sexp)]
+	      [sema (make-semaphore 0)])
+	  (queue-callback (lambda ()
+			    (thunk)
+			    (semaphore-post sema)))
+	  (semaphore-wait sema)))))
+
+  (define re:tcp-read-error (regexp "tcp-read:"))
+  (define re:tcp-write-error (regexp "tcp-write:"))
+  (define (tcp-error? exn)
+    (or (regexp-match re:tcp-read-error (exn-message exn))
+	(regexp-match re:tcp-write-error (exn-message exn))))
+
+  (define (send-sexp-to-mred sexp)
+    (let/ec k
+      (let ([show-text 
+	     (lambda (sexp)
+	       
+	       (debug-when messages
+			   (parameterize ([pretty-print-print-line
+					   (let ([prompt "  "]
+						 [old-liner (pretty-print-print-line)])
+					     (lambda (ln port ol cols)
+					       (let ([ov (old-liner ln port ol cols)])
+						 (if ln 
+						     (begin (display prompt port)
+							    (+ (string-length prompt) ov))
+						     ov))))])
+			     (pretty-print sexp)
+			     (newline))))])
+	(unless (and in-port
+		     out-port
+		     (with-handlers ([tcp-error?
+				      (lambda (x) #f)])
+		       (or (not (char-ready? in-port))
+			   (not (eof-object? (peek-char in-port))))))
+	  (restart-mred))
+	(debug-printf messages "  ~a // ~a: sending to mred:~n" section-name test-name)
+	(show-text sexp)
+	(with-handlers ([exn:fail?
+			 (lambda (x)
+			   (cond
+			     ;; this means that mred was closed
+			     ;; so we can restart it and try again.
+			     [(tcp-error? x) 
+			      (restart-mred)
+			      (write sexp out-port)
+			      (newline out-port)]
+			     [else (raise x)]))])
+	  (write sexp out-port)
+	  (newline out-port))
+	(let ([answer
+	       (with-handlers ([exn:fail?
+				(lambda (x)
+				  (if (tcp-error? x);; assume tcp-error means app closed
+				      eof
+				      (list 'cant-read
+					    (string-append
+					     (exn-message x)
+					     "; rest of string: "
+					     (format
+					      "~s"
+					      (apply
+					       string
+					       (let loop ()
+						 (if (char-ready? in-port)
+						     (let ([char (read-char in-port)])
+						       (if (eof-object? char)
+							   null
+							   (cons char (loop))))
+						     null))))))))])
+		 (read in-port))])
+	  (debug-printf messages "  ~a // ~a: received from mred:~n" section-name test-name)
+	  (show-text answer)
+	  (unless (or (eof-object? answer)
+		      (and (list? answer)
+			   (= 2 (length answer))
+			   (memq (car answer)
+				 '(error last-error cant-read normal))))
+	    (error 'send-sexp-to-mred "unpected result from mred: ~s~n" answer))
+	  (if (eof-object? answer)
+	      (raise (make-eof-result))
+	      (case (car answer)
+		[(error)
+		 (error 'send-sexp-to-mred "mred raised \"~a\"" (second answer))]
+		[(last-error)
+		 (error 'send-sexp-to-mred "mred (last time) raised \"~a\"" (second answer))]
+		[(cant-read) (error 'mred/cant-parse (second answer))]
+		[(normal) 
+		 (eval (second answer))]))))))
+
+  (define test
+    (case-lambda
+     [(in-test-name passed? sexp/proc) (test in-test-name passed? sexp/proc 'section)]
+     [(in-test-name passed? sexp/proc jump)
+      (fluid-let ([test-name in-test-name])
+	(when (or (not only-these-tests)
+		  (memq test-name only-these-tests))
+	  (let* ([result
+		  (with-handlers ([exn:fail?
+				   (lambda (x)
+				     (if (exn? x)
+					 (exn-message x)
+					 x))])
+		    (if (procedure? sexp/proc)
+			(sexp/proc)
+			(begin0 (send-sexp-to-mred sexp/proc)
+				(send-sexp-to-mred ''check-for-errors))))]
+		 [failed (with-handlers ([exn:fail?
+					  (lambda (x)
+					    (string-append
+					     "passed? test raised exn: "
+					     (if (exn? x)
+						 (exn-message x)
+						 (format "~s" x))))])
+			   (not (passed? result)))])
+	    (when failed
+	      (debug-printf schedule "FAILED ~a:~n  ~s~n" test-name result)
+	      (set! failed-tests (cons (cons section-name test-name) failed-tests))
+	      (case jump
+		[(section) (section-jump)]
+		[(continue) (void)]
+		[else (jump)])))))]))
+
+  (define (wait-for/wrapper wrapper sexp)
+    (let ([timeout 10]
+	  [pause-time 1/2])
+      (send-sexp-to-mred
+       (wrapper
+	`(let ([test (lambda () ,sexp)])
+	   (let loop ([n ,(/ timeout pause-time)])
+	     (if (zero? n)
+		 (error 'wait-for
+			,(format "after ~a seconds, ~s didn't come true" timeout sexp))
+		 (unless (test)
+		   (sleep ,pause-time)
+		   (loop (- n 1))))))))))
+
+  (define (wait-for sexp) (wait-for/wrapper (lambda (x) x) sexp))
+
+  (define (wait-for-new-frame sexp)
+    (wait-for/wrapper
+     (lambda (w)
+       `(let ([frame (get-top-level-focus-window)])
+	  ,sexp
+	  ,w))
+     `(not (eq? frame (get-top-level-focus-window)))))
+
+  (define (wait-for-frame name)
+    (wait-for `(let ([win (get-top-level-focus-window)])
+		 (and win
+		      (string=? (send win get-label) ,name))))))
diff --git a/collects/tests/framework/text.ss b/collects/tests/framework/text.ss
new file mode 100644
index 0000000000..a4ddc08246
--- /dev/null
+++ b/collects/tests/framework/text.ss
@@ -0,0 +1,73 @@
+(module text mzscheme
+  (require "test-suite-utils.ss")
+  
+  (define dummy-frame-title "dummy to avoid quitting")
+  (send-sexp-to-mred `(send (make-object frame:basic% ,dummy-frame-title) show #t))
+  
+  (define (test-creation frame% class name)
+    (test
+     name
+     (lambda (x) 
+       (equal? x (list dummy-frame-title))) ;; ensure no frames left
+     (lambda ()
+       (let ([label
+              (send-sexp-to-mred
+               `(let ([f (instantiate (class ,frame%
+                                        (override get-editor%)
+                                        [define (get-editor%) ,class]
+                                        (super-instantiate ()))
+                           ())])
+                  (send f show #t)
+                  (send f get-label)))])
+         (wait-for-frame label)
+         (send-sexp-to-mred `(test:keystroke #\a))
+         (wait-for `(string=? "a" (send (send (get-top-level-focus-window) get-editor) get-text)))
+         (send-sexp-to-mred
+          `(begin 
+             ;; remove the `a' to avoid save dialog boxes (and test them, I suppose)
+             (send (send (get-top-level-focus-window) get-editor) undo) 
+
+             (send (send (get-top-level-focus-window) get-editor) lock #t)
+             (send (send (get-top-level-focus-window) get-editor) lock #f)))
+         (queue-sexp-to-mred
+          `(send (get-top-level-focus-window) close))
+         (send-sexp-to-mred `(map (lambda (x) (send x get-label)) (get-top-level-windows)))))))
+  
+  
+  (test-creation 'frame:text%
+                 '(text:basic-mixin (editor:basic-mixin text%))
+                 'text:basic-mixin-creation)
+  (test-creation 'frame:text%
+                 'text:basic%
+                 'text:basic-creation)
+  
+  (test-creation 'frame:text%
+                 '(editor:file-mixin text:keymap%)
+                 'editor:file-mixin-creation)
+  (test-creation 'frame:text%
+                 'text:file%
+                 'text:file-creation)
+  (test-creation 'frame:text%
+                 '(text:clever-file-format-mixin text:file%)
+                 'text:clever-file-format-mixin-creation)
+  (test-creation 'frame:text%
+                 'text:clever-file-format%
+                 'text:clever-file-format-creation)
+  (test-creation 'frame:text%
+                 '(editor:backup-autosave-mixin text:clever-file-format%)
+                 'editor:backup-autosave-mixin-creation)
+  (test-creation 'frame:text%
+                 'text:backup-autosave%
+                 'text:backup-autosave-creation)
+  (test-creation 'frame:text%
+                 '(text:searching-mixin text:backup-autosave%)
+                 'text:searching-mixin-creation)
+  (test-creation 'frame:text%
+                 'text:searching%
+                 'text:searching-creation)
+  (test-creation '(frame:searchable-mixin frame:text%)
+                 '(text:info-mixin (editor:info-mixin text:searching%))
+                 'text:info-mixin-creation)
+  (test-creation '(frame:searchable-mixin frame:text%)
+                 'text:info%
+                 'text:info-creation))
diff --git a/collects/tests/framework/utils.ss b/collects/tests/framework/utils.ss
new file mode 100644
index 0000000000..3776c311ff
--- /dev/null
+++ b/collects/tests/framework/utils.ss
@@ -0,0 +1,13 @@
+(define (wait-for-frame name)
+  (let ([timeout 10]
+	[pause-time 1/2])
+    (send-sexp-to-mred
+     `(let loop ([n ,(/ timeout pause-time)])
+	(if (zero? n)
+	    (error 'wait-for-mred-frame
+		   ,(format "after ~a seconds, frame labelled ~s didn't appear" timeout name))
+	    (let ([win (get-top-level-focus-window)])
+	      (printf "win: ~a label ~a~n" win (and win (string=? (send win get-label) ,name)))
+	      (unless (and win (string=? (send win get-label) ,name))
+		(sleep ,pause-time)
+		(loop (- n 1)))))))))
diff --git a/collects/tests/info.ss b/collects/tests/info.ss
new file mode 100644
index 0000000000..8172248ca5
--- /dev/null
+++ b/collects/tests/info.ss
@@ -0,0 +1,8 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Test Suites")
+  (define doc-subcollections (list "tester"))
+  (define compile-subcollections '(("tests" "drscheme")
+				   ("tests" "framework")
+				   ("tests" "utils")))
+  (define tools (list '("tool.ss" "drscheme")))
+  (define tool-names (list "DrScheme Test Suites")))
diff --git a/collects/tests/mred/README b/collects/tests/mred/README
new file mode 100644
index 0000000000..6ce7f2923d
--- /dev/null
+++ b/collects/tests/mred/README
@@ -0,0 +1,87 @@
+
+The "item.ss" test (use load/cd) creates a frame to select among
+several types of control-testing frames. Click the `Get Instructions'
+button in the top-left for more information.
+
+---------------------------------------------------------------------------
+
+The "draw.ss" test (use load/cd) tests drawing commands. Click the
+"What Should I See?" button for further details.
+
+---------------------------------------------------------------------------
+
+The "mem.ss" test is loaded at startup:
+  mred -r mem.ss
+Creates a lot of frames and instance of other objects, reporting
+memory information along the way. At the end, before the last memory
+dump, objects that are still allocated are displayed like this:
+  (frame (1 . 5))
+This means that the frame allocated by thread #1 at cycle 5
+(counting down from some number) hasn't been garbage-collected.
+If there's a few of these lines (around 10), that's ok.
+A large number of lines (say, 50) indicates a GC problem.
+
+---------------------------------------------------------------------------
+
+[Out of date:]
+The "random.ss" test is a randomized test of the MrEd classes that tests
+MrEd's stability. Load "random.ss", and then run
+  (init)
+This attempts to create instances of classes using random
+intialization arguments. (init) can be run any number of times. 
+(2 is a good number) Then run
+  (call-all-random) 
+This calls every method of every class (skipping some "dangerous" ones
+that modify the file system) with a random instance and with random
+arguments.
+
+To avoid testing much of the wxMedia toolbox, which is likely to be
+platform-independent, (define skip-media? #t) before loading
+"random.ss".
+
+
+==================================================
+Old Stuff
+==================================================
+
+---------------------------------------------------------------------------
+
+The "imred.ss" test is used to check for memory leaks in a loop
+invoking the mred system. Call the `go' procedure with a list
+of symbol flags:
+  'force not included:
+     Use the current eventspaces; expects mred:run-exit-callbacks
+     to terminate everything properly
+  'force included:
+     Use a new eventspace; don't run mred:run-exit-callbacks and
+     call wx:kill-eventspace instead.
+  'console included:
+     Open a MrEd console
+  'thread included:
+     Spawn a sleeping-and-looping thread during each invocation.
+     Also tests semaphore-callback (because it has to)
+  'eventspace included:
+     Create a new sub-eventspace during each invocation with
+     a wx:frame% shown
+
+---------------------------------------------------------------------------
+
+"startup" tests the startup flags of mred. run "run.ss" from that directory.
+
+---------------------------------------------------------------------------
+
+"frame-edit.ss" checks that various frames match with various
+edits. Under construction.
+
+---------------------------------------------------------------------------
+
+"gui.ss" tests:
+ - save prompting (before closing unsaved files) and
+ - autosaving 
+
+evaluate `(load "gui.ss")' in the console to run.
+
+It also overwrites the file "tmp.ss" in the testing directory.
+
+---------------------------------------------------------------------------
+
diff --git a/collects/tests/mred/auto.ss b/collects/tests/mred/auto.ss
new file mode 100644
index 0000000000..c90f3e5988
--- /dev/null
+++ b/collects/tests/mred/auto.ss
@@ -0,0 +1,5 @@
+
+(load-relative "editor.ss")
+(load-relative "paramz.ss")
+(load-relative "dc.ss")
+(load-relative "windowing.ss")
diff --git a/collects/tests/mred/button-steps.txt b/collects/tests/mred/button-steps.txt
new file mode 100644
index 0000000000..e2e233ace2
--- /dev/null
+++ b/collects/tests/mred/button-steps.txt
@@ -0,0 +1,11 @@
+Click the "Hit Me" button. "Callback Ok" should appear in the console.
+
+Click "Check". "All Ok" should appear in the console.
+
+Repeat the above two steps.
+
+Click "Disable Test" and quickly click "Hit Me". The button should
+ become disabled for a second, then become re-enabled, but the
+ click on "Hit Me" should not invoke the callback.
+
+Repeat the first two steps above.
diff --git a/collects/tests/mred/canvas-steps.txt b/collects/tests/mred/canvas-steps.txt
new file mode 100644
index 0000000000..d22562ff9b
--- /dev/null
+++ b/collects/tests/mred/canvas-steps.txt
@@ -0,0 +1,175 @@
+
+Overview
+--------
+
+This canvas test frame is for checking the behvaiour of the
+scrollbars. Canvas scrollbars work in one of two modes:
+  1) Managing: the scrollbar determines the size and offset of
+     the canvas's drawing area.
+  2) Non-managing: the scrollbars are simply placed next to the
+     canvas; the canvas's size and offset are not affected by
+     the scrollbar values.
+In the test frame, the top canvas is initially unmanaged, and the
+bottom is managed.
+
+An HVCanvas has both horizontal and vertical scrollbars, but the
+scrollbars are initially disabled. Clikcing the "Enable Vertical"
+checkbox enables the vertical scroll. A VCanvas has only a vertical
+scrollbar; clicking "ENable Horizontal" in this case has no effect.
+When a canvas is managed by its scrollbars and a scrollbar is missing
+in a particular direction, it should act the same as an unmanaged
+canvas in that direction.
+
+On each canvas, the following are painted at 0,0:
+ * The name of the canvas
+ * Three values per scroll bar, for UNMANAGED canvases:
+    - The current value of the scroll
+    - The maximum value of the scroll
+    - The page step of the scroll
+   These should all be 0 for MANAGED canvases and for
+   disabled directions
+ * Two size measurements:
+    - The client size of the canvas
+    - The drawing area of the canvas
+   These should be the same for UNMANAGED canvases/directions
+ * Two lines showing what each `virtual boundary' of the canvas would
+   be if it is managed and the scrollbar is enabled. (Initially, the
+   bottom canvas's boundaries are probably beyond the visible region.)
+   When the canvas is managed with a vertical scrollbar, the bottom
+   boundary line might not be visible, i.e., it might be clipped - but
+   it must be clipped eactly in that case.
+
+As the scroll is changed for the managed canvas, the information will
+move, because the scrolls automatically adjust the offset of the
+canvas. For the unmanaged canvas, the information is always visible in
+the same place; it is just updated.
+
+The top's scrollbars have a range of 10 and a page step of 3.  The
+bottom's scrollbars have a range of 20 and a page step of 3 (although
+the page step is sometimes ignored for a managed canvas).  In managed
+mode:
+
+ * In the bottom canvas, one vertical scroll step is mapped to 10
+   pixels and one horizontal step to 25 pixels, making the virtual
+   area 200 pixels high and 500 pixels wide.
+
+   When the "Small" checkbox is checked, the range is changed to 2
+   instead of 20, making the virtual size 20 high by 50 wide.
+
+ * In the bottom canvas, one vertical or horizontal scroll step is
+   mapped to 1 pixel, making the virtual area 10x10.
+
+Initially, the top canvas is unmanaged and the bottom is managed.
+Checking the "swap" checkbox makes the top canvas unmanaged and the
+bottom canvas managed.
+
+The steps below assume an HVCanvas. Don't resize the window before
+starting the steps.
+
+HVCanvas Steps
+--------------
+ 
+Enable vertical scroll. The scroll should be at position 1 for both
+ canvases. The bottom canvas should be scrolled up 10 pixels.  The
+ displayed info should change:
+    -------------------------------------------
+    | Unmanaged Scroll                        |
+    | V: p: 1 r: 10 g: 3 H: 0 0 0             |
+    | Client: <m> x <n> Virtual: <m> x <n>    | ; for some <m> and <n>
+    -------------------------------------------
+    | Automanaged Scroll                      | ; <- actually, scrolled up
+    | V: p: 0 r: 0 g: 0 H: 0 0 0              | ; all zero for managed
+    | Client: <m> x <n'> Virtual: <m> x 200   | ; <n'> within 1 of <n>
+    -------------------------------------------
+  (You might not be able to read 200 in the lower right.)
+  Make the window slightly wider. Make sure the <m> gets bigger to
+  reflect the new width of the canvases.
+
+Set the bottom canvas's vertical scroll to 0. The "Automanaged Scroll"
+ should scroll back down into the original location.
+
+Scroll the bottom canvas's vertical scroll to its maximum value (which
+ is less than 10) You may see the bottom border close to the bottom
+ edge of the canvas.
+
+Adjust the top canvas's scroll, and watch the `p' value change each
+ time. The maximum value is 10. Use the `page up/down' areas and make
+ sure the `p' value changes by 3.
+
+Turn off the vertical scroll. The bottom canvas's image should snap
+ back to its original place. All the `V:' values in the top should
+ return to zeros.
+
+Perform the above steps for horizontal scrolling.
+
+Turn on both vertical and horizontal scrolling. You should see the
+ obvious combined effect. In particular, the bottom canvas's text
+ should be scrolled both up and to the left.
+
+Move all scrolls to 1 step beyond the smallest setting.  
+
+Make the frame larger. The top canvas's scrolls should still have 10
+ steps, but the bottom canvas's scrolls will have fewer steps,
+ reflecting the fact that less scrolling is needed to see the same
+ virtual area.
+
+Test the bottom canvas's scrolls to ensure that the maximum values of
+ the scrolls show the edges of the canvas's virtual area.
+
+Make the frame large enough to see the whole bottom canvas's virtual
+  area. The scrollbars should become disabled in both directions.
+
+Make the frame smaller again. The bottom canvas's scrolls should
+ adjust correctly. Make the frame small enough that all scrollbars are
+ active.
+
+Move all scrolls to 1 step beyond the smallest setting.  
+
+Check "swap". Now, the top canvas is managed and the bottom canvas is
+ unmanaged. But the top canvas's area is so small that its scrollbars
+ are always disabled. (It may also be clipped to the tiny 10x10 box.)
+ The bottom canvas's scrollbars should now act the the top ones used
+ to: there are 20 steps in each direction and the `V:' and `H:' values
+ change as the scrolls are moved.
+
+Uncheck "swap". The scrollbars should all go back to the 1 position.
+ The bottom canvas should be scrolled in the usual way.
+
+Check "small". The top canvas should be unaffected. The bottom canvas
+ should scroll back to 0,0, the scrollbars should be disabled, and a
+ 50x20 box should be drawn in the upper left (or the entire canvas is
+ clipped to that box).
+
+Check "swap". The bottom canvas should not be clipped.
+
+Check "swap". The bottom canvas might be clipped again.
+
+Uncheck "small". The bottom canvas should not be clipped.
+
+Check "small" and disable vertical scrolls. The bottom canvas should
+ be clipped horizontally or the boundary drawn at a small offset from
+ the left.
+
+Enable vertical and disable horizontal. The bottom canvas will be
+ narrowly clipped of have a short boundary from the top.
+
+HCanvas Steps
+--------------
+
+A vertical scrollbar should not be visible at all.
+
+Check both "Enable Vertical" and "Enable Horizontal". Verify that the
+ canvases act exactly like an HVCanvas with vertical scrolls disabled.
+
+VCanvas Steps
+--------------
+
+Transpose the approve appropriately
+
+Canvas Steps
+------------
+
+No scrollbars, checking the enabler boxes has no effect.
+
+Click "small" and make sure the bottom canvas is not clipped.
+
diff --git a/collects/tests/mred/checkbox-steps.txt b/collects/tests/mred/checkbox-steps.txt
new file mode 100644
index 0000000000..0ee77b2374
--- /dev/null
+++ b/collects/tests/mred/checkbox-steps.txt
@@ -0,0 +1,21 @@
+Check the "On" checkbox. "Callback Ok" should appear in the console.
+
+Uncheck the "On" checkbox. "Callback Ok" should appear in the console.
+
+Click "Check". "All Ok" should appear in the console.
+
+Repeat the above three steps.
+
+Click "Toggle". The checkbox should become checked.
+
+Click "Toggle". The checkbox should become unchecked.
+
+Check the "On" checkbox. "Callback Ok" should appear in the console.
+
+Click "Toggle". The checkbox should become unchecked.
+
+Repeat the above four steps with "Simulation Toggle" instead of "Toggle".
+ However, with "Simulation Toggle", "Callback Ok" should be printed
+ each time "Simulation Toggle" is hit.
+
+Click "Check". "All Ok" should appear in the console.
diff --git a/collects/tests/mred/choice-list-steps.txt b/collects/tests/mred/choice-list-steps.txt
new file mode 100644
index 0000000000..3d3856b0f5
--- /dev/null
+++ b/collects/tests/mred/choice-list-steps.txt
@@ -0,0 +1,236 @@
+Set Up, Callbacks, Appending
+----------------------------
+
+The choice/list should contain "Alpha" "Beta" and "Gamma" for
+ starters, unless and empty choice/list was created. In a choice,
+ "Alpha" should be initially selected.
+
+If there are no items:
+
+   * Click on the choice box. Make sure that nothing prints to the
+     console as a result. 
+
+   * Click "Append"; "Extra 1" should appear in the list of tiems.
+     For a choice, it should be immediately selected.
+
+   * Click "Append" again. The selection should not change.
+   
+   * Start over with a fresh frame. Click the "Clear" button and
+     nothing should happen.
+
+   * If its an empty list, start over with a fresh frame. Click the
+     "Reset" button and make sure "Alpha" "Beta" and "Gamma" are
+     added.
+
+   * Start over with a fresh frame again; jump down to the `Clearing'
+     section (but don't click "Clear").
+
+For a multi-selection list, jump down to "Multiple Selections".
+
+If there are items, select each once in order (single-click for
+ lists). After each solection, "Changed N" should appear in the
+ console (where N is the position of the item, counting from 0) for a
+ choice item, "Change (N)" for a list box; in either case, the
+ "Changed" line is followed by "Callback Ok". This should be printed
+ even if the selection is technically unchanged. Select the last one a
+ second time to make sure.
+
+For a choice, click to pop-up the menu, but don't select anything. for
+ a list, click in an area without items and in the scroll bar(s). In
+ both cases, the selection should not change and nothing should print
+ in the console.
+
+Click the "Append" button. The seletion should not change, but a new
+ item "Extra 1" should appear.
+
+Click the "Append" button again.
+
+Select the first newly added item.
+
+Click on the "check" button. In the console, "content: " whould be
+ printed along with a list of strings. That list should match the
+ items in the choice/list.
+
+Selections
+----------
+
+Click "Select First". The selection should change to "Alpha", but
+ nothing should appear in the console.
+
+Click "Select Middle".  The selection should change to "Gamma", but
+ nothing should appear in the console.
+
+Click "Select Last".  The selection should change to "Extra 2"", but
+ nothing should appear in the console.
+
+Click "Select Bad -1" and Select Bad X". In both cases, nothing should
+ happen, and nothing should appear in the console.
+
+Repeat the above four steps for the "by name" buttons. (There's
+ nothing equivalent to -1 for the "by name" buttons.)
+
+Repeat the four steps for the "by Simulate" buttons; in addition to
+ having the selections change, the "Changed N" and "Callback Ok"
+ messages should print in the console. For the -1 and X cases, "event
+ selection value mismatch" should print in the console, and the
+ selection should not change.
+
+Click on the "check" button and check the content list.
+
+Clearing
+--------
+
+Choose clear. All items should disappear.
+
+Choose clear again. Nothing should happen.
+
+Click on all parts of the control. The callback should never be
+ invoked.
+
+Click on all the "Select" buttons. For the top buttons and "by
+ Simulate" buttons (but not the "bad" ones), an exception should be
+ reported. Nothing should happend for the "by Name" buttons.
+
+Click on "Check". The empty item list should be reported in the
+ console.
+
+Click on "Append". For a choice, "Extra 3" should be immediately
+ selected. For a list box, nothing should be selected.
+
+Click "Append" again. The selection should not change.
+
+Select the second item, "Extra 4". Note the callback message in
+ the console for item 1.
+
+Click "Check" and see the list in the console: ("Extra 3" "Extra 4")
+
+Append one more, "Extra 5", and try all the selecting buttons again.
+
+Append 5 more items. The last one is very long, but it should look ok:
+ "This is a Really Long Named Item That Would Have Used the Short
+ Name, Yes This is a Really Long Named Item That Would Have Used the
+ Short Name Extra 10"
+
+Select the long-name item.
+
+Click "Check". The long name should be printed ok in the console.
+
+>> No More Tests for Choice Frames <<
+
+Visible Range >> Lists Only <<
+-------------
+
+Scroll to the top and select the first item. Click "Visible
+ Indices". In the console, the top should be 0, and the visible count
+ equal to the number of items that are completely visible in the
+ item. If an item is only partly visible, it should not be counted.
+
+Scroll down exactly one item's height without changing the
+ selection. Click "Visible Incices" again. The top should change to 1
+ but the count should be the same.
+
+On some platforms, you can scroll to partially show the first item.
+ Try it and hit "Visible Indices"; the partially shown item should
+ count as unshown. The visible count should not change.
+
+Make the window taller to show at least one more item. Try "Visible
+ Indices" again and make sure it changed.
+
+Click "Select Last". The list should scroll to the end. Try "Visible
+ Indices" again.
+
+Make the list box taller than all its items. (It may be necssary to
+ delete some items by selecting them and hitting the "Delete" button.)
+ Click "Visible Indices" and make sure that the visible count is still
+ more than the number of items.
+
+Deleting  >> Lists Only <<
+--------
+
+Select an item in the middle of the list.
+
+Hit "Delete". The item should disappear, and nothing shold be
+ selected.
+
+Append a new item.
+
+Select the third item in the list. Hit "Delete Above"; the second item
+ should disappear, and the selection should stick with its item as it
+ moves into 2nd place. Hit "Delete Above" again and the first item
+ should disappear, and the new first item should still be selected.
+ Click "Delete Above" one more time, and nothing should happen.
+
+Append two new items.
+
+Select the third to last item in the list. Test "Delete Below" by
+ clicking it three times, just like to "Delete Above".
+
+Append two new items.
+
+Click "Check" and inspect the item list in the console.
+
+Select the first item. Click the "Reset" button. The list should
+ contain "Alpha" "Beta" and "Gamma" with no selection.
+
+Click "Check" and inspect the item list in the console.
+
+Double-Click  >> Lists Only <<
+------------
+
+Double-click on "Alpha". The console should report the first click
+ in the normal way, and then report "Changed -1" followed by
+ "Double-click", then "Callback Ok".
+
+Double-click on "Gamma". Same as above, except that the initial
+ click is reported for position 2 instead of 0.
+
+Click "Check" and inspect the item list in the console.
+
+>> No More Tests for Single-Selection List Frames <<
+
+Multiple Selections >> Multiple-Selection Lists Only <<
+-------------------
+
+Click on each of the three items and make sure that "Changed"
+ and "Callback Ok" are printed in the console:
+
+  * For regular MultiLists, each click should unhilite the
+    old selection as it hilites the new one
+
+  * For MultiExtendLists, each click should extend the
+    selection.
+
+Click on a selected item to make sure "Changed" is printed again.
+
+Click "Check" and verify the item list *and* the selection list.
+ (Remember that the items are numbered from 0).
+
+Clear the selection except for one item, somehow. (You may need to use
+ the Ctl key)
+
+Use the shift key to select a second item. The console should show
+ "Changed" and "Callback Ok" as usual.
+
+Click "Check" and verify that the selection list now has the right
+ two items.
+
+Shift-click on a selected item. The console should show "Changed"
+ and "Callback Ok" as usual.
+
+Shift-click to select the remaining item. The console should show
+ "Changed" and "Callback Ok" as usual.
+
+Control-click on a selected item. It should become unselected (and the
+ other two selected items should remain so). The console should report
+ "Changed" and "Callback Ok".
+
+Click "Check" and verify the selection list.
+
+Try the "Select N" buttons. They should always extend the selection.
+
+Try the "by Simulate" buttons; they should should act like clicking,
+ either extending the selection or restarting it.
+
+Try dragging (and shift-dragging and ctl-dragging) and make sure the
+ console reports are appropriate.
+
diff --git a/collects/tests/mred/dc.ss b/collects/tests/mred/dc.ss
new file mode 100644
index 0000000000..ec8b1dfb21
--- /dev/null
+++ b/collects/tests/mred/dc.ss
@@ -0,0 +1,140 @@
+
+(load-relative "loadtest.ss")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;                               DC Tests                                     ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define mdc (make-object bitmap-dc%))
+(define bm (make-object bitmap% 10 10))
+(define bm2 (make-object bitmap% 10 10))
+
+(test #t 'is-color? (send bm is-color?))
+
+(define (bad m . args)
+  (with-handlers ([exn:fail:contract?
+		   (lambda (x)
+		     (test '("ok")
+			   `(send <bad-dc> ,m ...)
+			   (regexp-match "ok" (exn-message x))))])
+    (send-generic mdc (make-generic (object-interface mdc) m) . args)
+    (error 'bad-dc "~a shouldn't succeed" `(send <bad-dc> ,m ...))))
+
+(define (test-all mdc try)
+  (try 'clear)
+  (try 'draw-arc 0 0 10 10 0.1 0.2)
+  (try 'draw-bitmap bm2 0 0)
+  (try 'draw-bitmap-section bm2 0 0 0 0 5 5)
+  (try 'draw-ellipse 0 0 10 10)
+  (try 'draw-line 0 0 10 10)
+  (try 'draw-lines (list (make-object point% 0 0) (make-object point% 10 10)))
+  (try 'draw-point 5 5)
+  (try 'draw-polygon (list (make-object point% 0 0) (make-object point% 10 10) (make-object point% 5 10)))
+  (try 'draw-rectangle 0 0 10 10)
+  (try 'draw-rounded-rectangle 0 0 10 10)
+  (try 'draw-spline 0 0 10 10 5 10)
+  (try 'draw-text "Hello" 0 0)
+
+  (try 'start-doc "Ok")
+  (try 'start-page)
+  (try 'end-page)
+  (try 'end-doc)
+
+  (try 'get-background)
+  (try 'get-brush)
+  (try 'get-clipping-region)
+  (try 'get-font)
+  (try 'get-pen)
+  (try 'get-size)
+  (try 'get-text-background)
+  (try 'get-text-foreground)
+  (try 'get-text-mode)
+
+  (try 'set-background (make-object color% "Yellow"))
+  (try 'set-brush (make-object brush% "Yellow" 'solid))
+  (try 'set-clipping-rect 0 0 10 10)
+  (try 'set-clipping-region (make-object region% mdc))
+  (try 'set-font (make-object font% 12 'default 'normal 'normal))
+  (try 'set-origin 0 0)
+  (try 'set-pen (make-object pen% "Yellow" 1 'solid))
+  (try 'set-scale 2 2)
+  (try 'set-text-background (make-object color% "Yellow"))
+  (try 'set-text-foreground (make-object color% "Yellow"))
+  (try 'set-text-mode 'transparent)
+  (try 'try-color (make-object color% "Yellow") (make-object color%)))
+
+(st #f mdc ok?)
+(test-all mdc bad)
+
+(send mdc set-bitmap bm)
+(test-all mdc (lambda (m . args)
+		(send-generic mdc (make-generic (object-interface mdc) m) . args)))
+
+(send mdc set-bitmap #f)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Get-pixel, set-pixel, get-argb-pixels, etc.
+
+;; New DC to reset background, etc:
+(define mdc (make-object bitmap-dc% bm))
+(send mdc clear)
+
+(define col (make-object color%))
+(define bts (make-bytes 40))
+
+(st #f mdc get-pixel 30 4 col)
+(st #t mdc get-pixel 3 4 col)
+(st 255 col red)
+(st 255 col green)
+(st 255 col blue)
+(stv mdc get-argb-pixels 0 0 2 5 bts)
+(test #t 'same-str (equal? (make-bytes 40 255) bts))
+
+(send col set 30 40 50)
+(send mdc try-color col col)
+(send mdc set-pixel 3 4 col)
+
+(stv mdc get-argb-pixels 2 1 2 5 bts)
+(test #t 'same-str (equal? (bytes-append (make-bytes 28 255)
+					 (bytes 255
+						(send col red)
+						(send col green)
+						(send col blue))
+					 (make-bytes 8 255))
+			   bts))
+
+(define col2 (make-object color% 130 140 150))
+(send mdc try-color col2 col2)
+(let loop ([i 0])
+  (unless (= i 10)
+    (bytes-set! bts (+ 0 (* i 4)) 255)
+    (bytes-set! bts (+ 1 (* i 4)) (send col2 red))
+    (bytes-set! bts (+ 2 (* i 4)) (send col2 green))
+    (bytes-set! bts (+ 3 (* i 4)) (send col2 blue))
+    (loop (add1 i))))
+(stv mdc set-argb-pixels 5 5 5 2 bts)
+(let ([col3 (make-object color%)]
+      [white (make-object color% 255 255 255)]
+      [check-col (lambda (what a b)
+		   (test #t `(same red ,what) (= (send a red) (send b red)))
+		   (test #t `(same green ,what) (= (send a green) (send b green)))
+		   (test #t `(same blue ,what) (= (send a blue) (send b blue))))])
+  (let i-loop ([i 0])
+    (unless (= i 10)
+      (let j-loop ([j 0])
+	(if (= j 10)
+	    (i-loop (add1 i))
+	    (begin
+	      (st #t mdc get-pixel i j col3)
+	      (cond
+	       [(and (= i 3) (= j 4))
+		(check-col '(3 4) col col3)]
+	       [(and (<= 5 i 9)
+		     (<= 5 j 6))
+		(check-col `(,i ,j) col2 col3)]
+	       [else
+		(check-col `(,i ,j) white col3)])
+	      (j-loop (add1 j))))))))
+
+
+(report-errs)
diff --git a/collects/tests/mred/draw-info.txt b/collects/tests/mred/draw-info.txt
new file mode 100644
index 0000000000..f03ffc63f8
--- /dev/null
+++ b/collects/tests/mred/draw-info.txt
@@ -0,0 +1,302 @@
+The drawing area should have the following features:
+
+  At the top-left, when the window is opened for the first time, you
+    shoudl see a hollow box with a line sticking out to the bottom
+    left. Repainting the canvas should produce instead a solid box and
+    no line. Repainting with Pixmap or Bitmap should always produce
+    the hollow box and line.
+
+  At the top, "Pen 0 x 0" in a consistent font (i.e., re-painting
+    should not change the font; clicking *2 should make it twice
+    a big, and unclicking should restore it)
+  "Pen 1 x 1" in a possibly different font
+  "Pen 2 x 2" in a bold red font (bold version of 1x1 font) on yellow
+  
+  A line should appear across each of "Pen 0 x 0" and "Pen 1 x 1"
+    (if the line is missing, it was probably erased when the text
+     was repainted, and that is bad)
+  A little bit of a black line should appear before "Pen 2 x 2", but
+    the yellow background should have covered up the rest of the line
+
+  To the right of the Pen text, a black and red pair of splines should
+    form a squashed "S", twice as wide as high. The "S" is formed by
+    two splines.
+
+  Under the splines should be two blue polygons, the top with a square
+    hole (odd-even fill) and the bottom all solid (winding fill). The
+    black lines forming the polygon should be the same in each shape
+    (strictly on borders for the top polygon, drawn over blue in the
+    bottom polygon).
+
+  Toward the right should be three columns of boxes, with a fourth
+    column that starts with a box. All boxes should have a red border.
+    In the first thre columns, the boxes shold contain lines on a
+    background that matches the normal background (i.e., either white
+    or cyan). The lines should be black for the left colum, and green
+    for the second and third columns. In the fourth column, the shapes
+    should be filled with the platform-specific panel background
+    pattern; the third shape should be a semi-circle with no outline
+    on the bottm edge.
+
+  Further right (to the the right of the columns) should appear an
+    X, a cross, and an narrow X tilted NW. Each should be drawn in
+    green (5 pixels wide) with a thin black line centered along each
+    green line.  Scaling the piture should make the green line thicker,
+    but not the black line, and the black line should stay centered.
+
+  Under the columns of boxes, a black box should be filled with an 25%
+    black B&W bitmap, and a red box frame should be draw with a 50%
+    red stipple.
+
+  To the right of those two boxes should appear two little boxes,
+    black pixels on a tan background, the top one 8x8 and the bottom
+    on 6x10.  The black pixels in the top one should form a vertical
+    line right or center with a kind of semi-spring on the left
+    edge. The black pixels in 6x10 should be just a longer semi-spring
+    to the left.
+
+  At the far right should appear six stars, drawn once as lines (left
+    column) and once as a polygon outline (right column). The first row
+    uses 'projecting cap and 'miter join, the second uses 'round and
+    'round, and the last uses 'butt and 'bevel.
+
+  The drawings under "0 x 0" and "1 x 1" should look nearly the same:
+
+    TopLeft: h-line should be left-aligned with box below it, but
+             extend 1 extra pixel. v-line similarly should be
+             top-aligned and 1 pixel longer. The lines should not
+             touch the box - there should be 2 pixels of space.
+
+    Top: Lines for the rotated L's should join in a sharp corner
+
+    Second from Top: like top-left, but lines should touch the box (so
+                     only the vertical overhang is visible)
+
+    Second from top, right: For 0x0, the X should never be more than 1
+                            pixel wide; this is a case where 1x1 may
+                            be different (i.e., it may have areas
+                            two-pixels wide)
+
+    Four shape rows: First (solid brush, solid pen) and second (solid
+             brush, solid pen) columns should be the same shape, with
+             the first hollow and the second filled. Third (solid
+             brush, no pen) column should look like the second column.
+             The fourth column should be the xor of the first and
+             third columns. The precise results are ill-defined for
+             the "2 x 2 Pen" shapes.
+
+    Octagons: two hollow octagons exactly the same shape.
+
+    Dot (after octagons): a single pixel (uses draw-point)
+
+    Another Dot (below the first one): a single pixel (created as a
+       0-length line from draw-line)
+
+    Line: actually two lines, but they should form a single
+             unbroken line
+
+    Arcs: The leftmost should be the top half of an ellipse (it's
+          formed via two arcs); the rightmost should be a filled wedge
+          from 90 degrees to 180 degress. The arcs are part of an
+          ellipse 40 tall and 30 wide (i.e., stretched slightly in the
+          vertical direction from a circle).
+
+  The drawings under 2x2 should be reasonable extensions of the
+  0x0 and 1x1 pictures for a double-wide pen.
+
+  Big octagon: The octagon defines the region for octagon clipping.
+          Also, it's drawn in xor mode, so it should flip black to
+          white wherever the octagon line runs over the shapes of the
+          middle section. The bitmaps of the bottom region are drawn
+          afterwards, and wil therefore hide parts of the octagon
+          line, although the MrEd logo is also drawn in XOR mode so it
+          shouldn't obscure the octagon line.
+
+  Bottom section:
+
+    Images: MrEd logo (b & w), drawn in XOR mode, so the octagin line
+              should be toggled where the black part of the MrEd logo
+              intersects with the line. This changes with the
+              "MrEd XOR" choice control (see below).
+            BB logo (color)
+            Top subrow:
+              Down-left arrow (with a thin horizontal line), black on
+                background
+              Down-left arrow, red on background
+              Down-left arrow, red on background
+            Bottom subrow, on blue field in black-bordered roundrect:
+              Down-left arrow (with a thin horizontal line), black on
+                blue
+              Down-left arrow, red on blue
+              Down-left arrow, red on background (cyan or white)
+            BB logo, same as before
+            Down-left arrow - red on black
+
+    Stippled boxes, in a blue box w/black border, four black-outlined
+      shapes:
+        Sqaure - green down-arrows on blue field
+        Cirle - green down-arrows on background (cyan or white) field
+        Square - bb logo
+        Square - green cross-hatch on blue
+		    
+    Dashed lines: each half green and half black with the background
+       color (white or cyan) between the dots/dashes, two of each:
+           Solid line
+           Dot line
+           Long Dash line
+           Short Dash line
+           Dot Dash line
+
+   Long line: On the screen in unsmoothed or aligned mode, the line 
+       should be 1 pixel wide, except that the last 1/9th should be
+       two pixels wide. In postscript or smooth mode, the line should
+       consist of 9 segments, growing in width from 0.0 to 2.0
+       (inclusive) in 0.25 increments. When the image is scaled by a
+       factor of 2, the first 1/9th on the screen should still be 1
+       pixel, the next 7/9ths should be 2 pixels, and the last 1/9
+       should be 4 pixels wide.
+
+   Red shapes with black outlines (below long line): square, round
+      square, circle, and triangle without a top line; these are drawn
+      as paths.
+
+   Four lines (to right of red shapes): in 'unsmoothed or 'aligned
+      mode, the lines should appear euqally spaced at scale 1, but
+      scale 2 should show the middle lines closer by two pixels; the
+      'smoothed mode should approximate this at scale 1. At scale 2,
+      'unsmoothed and 'aligned should look the same.
+
+   Thick blue-line round rects with red center: the left one has pen
+      size 7, and the right pen size 8. At scale 1, the two should be
+      separated by a blank column of pixels in 'unsmoothed and
+      'smoothed mode, but in 'smoothed mode or at scale 2, they should
+      touch.
+
+    Four suqares with overbar (bottom of drawing): the suqares,
+      which are strteched bitmaps, should touch, and the four squares
+      should have the same span as the overbar line.
+
+The image should look the same regardless of the top radio button
+setting --- Canvas, Pixmap, or Bitmap --- except that the Bitmap
+setting must produce a black-and-white image.  When you go from Pixmap
++ *2 ("*2" is described next) back to Pixmap, there may be junk from
+the *2 drawing left around the right and bottom. That's ok. Same for
+going from Canvas + Cyan ("Cyan" is described later) to Pixmap + Cyan.
+
+Clicking on the "*2" checkbox should double the size of everything,
+including the pen widths, but not the bitmaps. The 0x0 pen should be
+the same width as before (1 pixel).
+
+Clicking on "+10" should shift everything 10 pixels down and across.
+(Even when "*2" is checked, it should be a 10 pixel offset).
+
+Clicking on "Cyan" should change the background to cyan instead of
+white. When Pixmap or Bitmap is used, the background will be set in
+the Pixmap/Bitmap, not the canvas, so a white background should frame
+the cyan area to the right and bottom (if you make the window big
+enough).
+
+Clipping should slip the drawing to a particular shape:
+
+   rectangle - a 10-pixel strip 100 pixels from the left
+ 
+   octagon - the content of the big outlined octagon; some
+     part of the octagone outline is clipped
+
+   circle - a circle inscribed in the octagon's bounding
+     box
+
+   wedge - pi/4 to 3pi/4 of circle
+
+   round rectangle - a rounded rect inscrobed in the the blue box for
+     testing stipples
+
+   unions, intersects, subtracts - hopefully obvious
+
+   polka - purple field with holes showing the normal drawing
+
+   lambda - a region in the shape of a lambda
+
+When the "Clip Pre-Scale" checkbox is not checked, then when a scale
+such as "*2" is selected, the clipping region should scale
+accordingly. "+10" should move the clipping region. (In either the
+"*2" or "+10" case, the content of the clipped region should be the
+same.) When the "Clip Pre-Scale" checkbox is checked, then the
+clipping region should not scale with the rest of the drawing. Be sure
+to try both scaling modes with smoothing both on and off.
+
+The "Clock" button tests a range of wedges. Each wedge has a 1-pixel
+ black background and orange filling. A sequence of wedges is
+ produced.  Imagine the following:
+   The two hands of a clock start at 0 radians (i.e., 3:15). For each
+   step, the minute hand is moved back (counter-clockwise) pi/4
+   radians, while the hour hand moves back pi/8 radians, and
+   everything between the minute hand moving counter-clockwise to the
+   hour hand is filled in. So after drawing the full circle on the 0th
+   step, the wedge includes everything except a small slice on the 1st
+   step. The empty slice grows ever larger while shifting
+   counter-clockwise. By the time the minute hand wraps to 0 radians
+   (at which point the hour hand is a pi radians), the wedge covers
+   only the top half of the clock. It keeps going until the wedge
+   nearly disappears (but instead of disappearing, the whole circle is
+   filled in again). The same pattern is then repeated, but reversing
+   the wedge part and empty part (so the wedge starts small and grows
+   larger this time around).
+ The orange wedge is drawn just before the bitmaps, so they appear on
+ top of the orange wedge, but the wegde paints over other things. If
+ the "Pixmap" box is checked and the "Polka" clipping region is
+ selected, the result is an animtation where you can only see the
+ wedge grow and move through the polka-dot holes in the purple field.
+
+The "Clip Clock" button is similar to "Clock", except that all drawing
+ is clipped to the area to be painted orange. "Clip Clock" clipping
+ overrides any other clipping setting.
+
+Clicking on "PostScript" should produce the image described above in a
+PostScript file.
+
+The "icons" and "stipple" boxes enable those parts of the
+drawing. These checkboxes are provided because PostScript drawing of
+icons and stipples can be slow.
+
+The "MrEd XOR" menu selects a icon:
+
+  - "MrEd XOR" : initial icon, as described above
+
+  - "PLT Middle" : middle area of the PLT logo (used when starting
+    DrScheme), same size as the MrEd icon. Make sure scaling works
+    right (i.e., same section shown and scaled).
+
+ - "PLT ^ MrEd" : "PLT Middle" masked by the MrEd icon.
+
+ - "MrEd ^ PLT" : MrEd icon masked by the "PLT Middle" image (so it's
+   translucent).
+
+ - "MrEd ^ MrEd" : MrEd icon masked by itself... non-black parts
+   should be transparent.
+
+ - "MrEd~" - Upside-down MrEd icon. Besides PLT Middle, this
+   one should blank out whatever is behind it (using cyan in
+   cyan mode)
+
+ - "MrEd ^ MrEd~" - MrEd icons masked by upside-down MrEd icon.
+   Note that the parens should be fully intact.
+
+ - "M^M~ Opaque" - Same as previous; drawn with 'opaque, but that
+   should have no visible effect.
+
+ - "M^M~ Red" - Same as two previous, but drawn red instead of black.
+
+ - "PLT^PLT" - The PLT Middle image, but translucent
+
+----------
+
+Finally, print these instructions by hitting the "Print" button at the
+top of the "What Should I See?" window. The following lines are for
+the printing test; they should wrap aroundneatly on the printed
+page. (Don't add any newlines.) Check to make sure no lines are
+skipped or duplicated across page breaks. Try different page
+orientations.
+
+0         1         2         3         4         5         6         7         8         9         X         O         T         T         F
+012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789
diff --git a/collects/tests/mred/draw.ss b/collects/tests/mred/draw.ss
new file mode 100644
index 0000000000..733c3f6e38
--- /dev/null
+++ b/collects/tests/mred/draw.ss
@@ -0,0 +1,1216 @@
+
+(require (lib "class100.ss"))
+
+(define manual-chinese? #f)
+
+(when manual-chinese?
+  (send the-font-name-directory set-post-script-name 
+	(send the-font-name-directory find-or-create-font-id "MOESung-Regular" 'default)
+	'normal
+	'normal
+	"MOESung-Regular"))
+
+(define sys-path 
+  (lambda (f)
+    (build-path (collection-path "icons") f)))
+
+(define local-path 
+  (let ([d (current-load-relative-directory)])
+    (lambda (f)
+      (build-path d f))))
+
+(define (get-icon)
+  (make-object bitmap% (sys-path "mred.xbm") 'xbm))
+
+(define get-plt
+  (let ([i #f])
+    (lambda ()
+      (unless i
+	(set! i (make-object bitmap% (sys-path "plt.gif"))))
+      i)))
+
+(define get-rotated
+  (let ([i #f])
+    (lambda ()
+      (unless i
+	(set! i (let* ([icon (get-icon)]
+                       [w (send icon get-width)]
+                       [h (send icon get-height)])
+                  (let ([bm (make-object bitmap% w h #t)])
+                    (let ([src (make-object bitmap-dc% icon)]
+                          [dest (make-object bitmap-dc% bm)]
+                          [c (make-object color%)])
+                      (let loop ([i 0])
+                        (unless (= i w)
+                          (let loop ([j 0])
+                            (unless (= j h)
+                              (send src get-pixel i j c)
+                              (send dest set-pixel i (- h j 1) c)
+                              (loop (add1 j))))
+                          (loop (add1 i))))
+                      (send src set-bitmap #f)
+                      (send dest set-bitmap #f)
+                      bm)))))
+      i)))
+
+(define (show-instructions file)
+  (letrec ([f (make-object frame% (path->string file) #f 400 400)]
+	   [print (make-object button% "Print" f
+			       (lambda (b ev)
+				 (send e print)))]
+	   [c (make-object editor-canvas% f)]
+	   [e (make-object text%)])
+    (send e load-file file)
+    (send e lock #t)
+    (send c set-editor e)
+    (send f show #t)))
+
+(define pi (atan 0 -1))
+
+(define star
+  (list (make-object point% 30 0)
+	(make-object point% 48 60)
+	(make-object point% 0 20)
+	(make-object point% 60 20)
+	(make-object point% 12 60)))
+
+(define octagon
+  (list (make-object point% 60 60)
+	(make-object point% 120 60)
+	(make-object point% 180 120)
+	(make-object point% 180 180)
+	(make-object point% 120 240)
+	(make-object point% 60 240)
+	(make-object point% 0 180)
+	(make-object point% 0 120)
+	(make-object point% 60 60)))
+
+(define (get-b&w-light-stipple)
+  (make-object bitmap%
+	       (list->bytes '(#x88 0 #x22 0 #x88 0 #x22 0))
+	       8 8))
+
+(define (get-b&w-half-stipple)
+  (make-object bitmap%
+	       (list->bytes '(#xcc #x33 #xcc #x33 #xcc #x33 #xcc #x33))
+	       8 8))
+
+
+(define lambda-path
+  (let ()
+    (define left-lambda-path
+      (let ([p (new dc-path%)])
+	(send p move-to 148 670)
+
+	;; top corner
+	(send p line-to 156.5 654)
+	
+	;; left edge spline
+	(send p curve-to 197.5 665 225 672 240 653)
+	(send p curve-to 275.06 608.59 282.5 573 291.5 528)
+	(send p curve-to 296.12 504.92 294.11 490.62 288.96 470)
+	(send p curve-to 276.34 419.46 254.18 382.39 228.5 339)
+	(send p curve-to 193.21 279.37 159.68 208.41 120.5 150)
+	
+	(send p line-to 130 142)
+
+	p))
+
+    (define bottom-lambda-path
+      (let ([p (new dc-path%)])
+	(send p move-to 130 142)
+
+	;; bottom left foot
+	(send p line-to 183.5 150)
+	
+	;; bottom middle spline
+	(send p curve-to 203.5 197 225.91 248.79 246 294)
+	(send p curve-to 262 330 273.5 366 291.5 402)
+	(send p curve-to 296.01 411.02 313 456 324 440)
+	(send p curve-to 333.89 425.61 346 400 353 382)
+	(send p curve-to 372.28 332.42 390.57 284.39 409 237)
+	(send p curve-to 423 201 431.5 174 444.5 141)
+	
+	;; bottom right foot
+	(send p line-to 460 134)
+	(send p line-to 524 169)
+
+	p))
+
+    (define right-lambda-path
+      (let ([p (new dc-path%)])
+	(send p move-to 148 670)
+
+	;; right edge spline
+	(send p curve-to 187.21 683.31 228.21 699.77 270 694)
+	(send p curve-to 323.6 686.6 345.23 610.92 359 563)
+	(send p curve-to 373.75 511.68 395.5 470 413 420)
+	(send p curve-to 441.56 338.4 489.5 258 525.5 177)
+
+	(send p line-to 524 169)
+
+	(send p reverse)
+
+	p))
+
+    (let ([p (new dc-path%)])
+      (send p append left-lambda-path)
+      (send p append bottom-lambda-path)
+      (send p append right-lambda-path)
+      
+      (send p translate -5 -86)
+      (send p scale 1 -1)
+      (send p translate 0 630)
+      (send p scale 0.5 0.5)
+      p)))
+
+
+(define fancy-path
+  (let ([p (new dc-path%)]
+	[p2 (new dc-path%)])
+    (send p2 move-to 10 80)
+    (send p2 line-to 80 80)
+    (send p2 line-to 80 10)
+    (send p2 line-to 10 10)
+    (send p2 close)
+    
+    (send p move-to 1 1)
+    (send p line-to 90 1)
+    (send p line-to 90 90)
+    (send p line-to 1 90)
+    (send p close)
+    (send p append p2)
+    (send p arc 50 50 100 120 0 (* pi 1/2) #f)
+
+    p))
+
+(define square-bm
+  (let* ([bm (make-object bitmap% 10 10)]
+	 [dc (make-object bitmap-dc% bm)])
+    (send dc clear)
+    (send dc set-brush "white" 'transparent)
+    (send dc set-pen "black" 1 'solid)
+    (send dc draw-rectangle 0 0 10 10)
+    (send dc set-bitmap #f)
+    bm))
+
+(define DRAW-WIDTH 550)
+(define DRAW-HEIGHT 375)
+
+(let* ([f (make-object frame% "Graphics Test" #f 600 550)]
+       [vp (make-object vertical-panel% f)]
+       [hp0 (make-object horizontal-panel% vp)]
+       [hp (make-object horizontal-panel% vp)]
+       [hp2 hp]
+       [hp2.5 hp0]
+       [hp3 hp]
+       [bb (make-object bitmap% (sys-path "bb.gif") 'gif)]
+       [return (let* ([bm (make-object bitmap% (sys-path "return.xbm") 'xbm)]
+		      [dc (make-object bitmap-dc% bm)])
+		 (send dc draw-line 0 3 20 3)
+		 (send dc set-bitmap #f)
+		 bm)]
+       [clock-start #f]
+       [clock-end #f]
+       [clock-clip? #f]
+       [use-bitmap? #f]
+       [use-bad? #f]
+       [depth-one? #f]
+       [cyan? #f]
+       [smoothing 'unsmoothed]
+       [save-filename #f]
+       [save-file-format #f]
+       [clip 'none])
+  (send hp0 stretchable-height #f)
+  (send hp stretchable-height #f)
+  (send hp2.5 stretchable-height #f)
+  (send hp3 stretchable-height #f)
+  (make-object button% "What Should I See?" hp0
+	       (lambda (b e)
+		 (show-instructions (local-path "draw-info.txt"))))
+  (let ([canvas
+	 (make-object
+	  (class canvas%
+	    (init parent)
+	    (inherit get-dc refresh init-auto-scrollbars)
+	    (define no-bitmaps? #f)
+	    (define no-stipples? #f)
+	    (define pixel-copy? #f)
+	    (define kern? #f)
+	    (define clip-pre-scale? #f)
+	    (define mask-ex-mode 'mred)
+	    (define xscale 1)
+	    (define yscale 1)
+	    (define offset 0)
+	    (public*
+	     [set-bitmaps (lambda (on?) (set! no-bitmaps? (not on?)) (refresh))]
+	     [set-stipples (lambda (on?) (set! no-stipples? (not on?)) (refresh))]
+	     [set-pixel-copy (lambda (on?) (set! pixel-copy? on?) (refresh))]
+	     [set-kern (lambda (on?) (set! kern? on?) (refresh))]
+	     [set-clip-pre-scale (lambda (on?) (set! clip-pre-scale? on?) (refresh))]
+	     [set-mask-ex-mode (lambda (mode) (set! mask-ex-mode mode) (refresh))]
+	     [set-scale (lambda (xs ys) (set! xscale xs) (set! yscale ys) (refresh))]
+	     [set-offset (lambda (o) (set! offset o) (refresh))])
+	    (override*
+	     [on-paint
+	      (case-lambda
+	       [() (on-paint #f)]
+	       [(ps?)
+		(let* ([can-dc (get-dc)]
+		       [pen0s (make-object pen% "BLACK" 0 'solid)]
+		       [pen1s (make-object pen% "BLACK" 1 'solid)]
+		       [pen2s (make-object pen% "BLACK" 2 'solid)]
+		       [pen0t (make-object pen% "BLACK" 0 'transparent)]
+		       [pen1t (make-object pen% "BLACK" 1 'transparent)]
+		       [pen2t (make-object pen% "BLACK" 2 'transparent)]
+		       [pen0x (make-object pen% "BLACK" 0 'xor)]
+		       [pen1x (make-object pen% "BLACK" 1 'xor)]
+		       [pen2x (make-object pen% "BLACK" 2 'xor)]
+		       [brushs (make-object brush% "BLACK" 'solid)]
+		       [brusht (make-object brush% "BLACK" 'transparent)]
+		       [brushb (make-object brush% "BLUE" 'solid)]
+		       [mem-dc (if use-bitmap?
+				   (make-object bitmap-dc%)
+				   #f)]
+		       [bm (if use-bitmap?
+			       (if use-bad?
+				   (make-object bitmap% "no such file")
+				   (make-object bitmap% (* xscale DRAW-WIDTH) (* yscale DRAW-HEIGHT) depth-one?))
+			       #f)]
+		       [draw-series
+			(lambda (dc pens pent penx size x y flevel last?)
+			  (let* ([ofont (send dc get-font)]
+				 [otfg (send dc get-text-foreground)]
+				 [otbg (send dc get-text-background)]
+				 [obm (send dc get-text-mode)])
+			    (if (positive? flevel)
+				(send dc set-font
+				      (make-object font%
+						   10 'decorative
+						   'normal 
+						   (if (> flevel 1)
+						       'bold
+						       'normal)
+						   #t)))
+			    (send dc set-pen pens)
+			    (send dc set-brush brusht)
+			    
+			    ; Text should overlay this line (except for 2x2)
+			    (send dc draw-line 
+				  (+ x 3) (+ y 12)
+				  (+ x 40) (+ y 12))
+
+			    (send dc set-text-background (make-object color% "YELLOW"))
+			    (when (= flevel 2)
+			      (send dc set-text-foreground (make-object color% "RED"))
+			      (send dc set-text-mode 'solid))
+
+			    (send dc draw-text (string-append size " P\uE9n") ; \uE9 is e with '
+				  (+ x 5) (+ y 8))
+			    (send dc set-font ofont)
+			    
+			    (when (= flevel 2)
+			      (send dc set-text-foreground otfg)
+			      (send dc set-text-mode obm))
+			    (send dc set-text-background otbg)
+			    
+			    (send dc draw-line
+				  (+ x 5) (+ y 27) (+ x 10) (+ 27 y))
+			    (send dc draw-rectangle
+				  (+ x 5) (+ y 30) 5 5)
+			    (send dc draw-line
+				  (+ x 12) (+ y 30) (+ x 12) (+ y 35))
+			    
+			    (send dc draw-line
+				  (+ x 5) (+ y 40) (+ x 10) (+ 40 y))
+			    (send dc draw-rectangle
+				  (+ x 5) (+ y 41) 5 5)
+			    (send dc draw-line
+				  (+ x 10) (+ y 41) (+ x 10) (+ 46 y))
+			    
+			    (send dc draw-line
+				  (+ x 15) (+ y 25) (+ x 20) (+ 25 y))
+			    (send dc draw-line
+				  (+ x 20) (+ y 30) (+ x 20) (+ 25 y))
+			    
+			    (send dc draw-line
+				  (+ x 30) (+ y 25) (+ x 25) (+ 25 y))
+			    (send dc draw-line
+				  (+ x 25) (+ y 30) (+ x 25) (+ 25 y))
+			    
+			    (send dc draw-line
+				  (+ x 35) (+ y 30) (+ x 40) (+ 30 y))
+			    (send dc draw-line
+				  (+ x 40) (+ y 25) (+ x 40) (+ 30 y))
+			    
+			    (send dc draw-line
+				  (+ x 50) (+ y 30) (+ x 45) (+ 30 y))
+			    (send dc draw-line
+				  (+ x 45) (+ y 25) (+ x 45) (+ 30 y))
+
+			    ; Check line thickness with "X"
+			    (send dc draw-line
+				  (+ x 20) (+ y 45) (+ x 40) (+ 39 y))
+			    (send dc draw-line
+				  (+ x 20) (+ y 39) (+ x 40) (+ 45 y))
+			    
+			    (send dc draw-rectangle
+				  (+ x 5) (+ y 50) 10 10)
+			    (send dc draw-rounded-rectangle
+				  (+ x 5) (+ y 65) 10 10 3)
+			    (send dc draw-ellipse
+				  (+ x 5) (+ y 80) 10 10)
+			    
+			    (send dc set-brush brushs)
+			    (send dc draw-rectangle
+				  (+ x 17) (+ y 50) 10 10)
+			    (send dc draw-rounded-rectangle
+				  (+ x 17) (+ y 65) 10 10 3)
+			    (send dc draw-ellipse
+				  (+ x 17) (+ y 80) 10 10)
+			    
+			    (send dc set-pen pent)
+			    (send dc draw-rectangle
+				  (+ x 29) (+ y 50) 10 10)
+			    (send dc draw-rounded-rectangle
+				  (+ x 29) (+ y 65) 10 10 3)
+			    (send dc draw-ellipse
+				  (+ x 29) (+ y 80) 10 10)
+			    
+			    (send dc set-pen penx)
+			    (send dc draw-rectangle
+				  (+ x 41) (+ y 50) 10 10)
+			    (send dc draw-rounded-rectangle
+				  (+ x 41) (+ y 65) 10 10 3)
+			    (send dc draw-ellipse
+				  (+ x 41) (+ y 80) 10 10)
+			    
+			    (send dc set-pen pens)
+			    (send dc draw-rectangle
+				  (+ x 17) (+ y 95) 10 10)
+			    ; (send dc set-logical-function 'clear)
+			    (send dc draw-rectangle
+				  (+ x 18) (+ y 96) 8 8)
+			    ; (send dc set-logical-function 'copy)
+			    
+			    (send dc draw-rectangle
+				  (+ x 29) (+ y 95) 10 10)
+			    ; (send dc set-logical-function 'clear)
+			    (send dc set-pen pent)
+			    (send dc draw-rectangle
+				  (+ x 30) (+ y 96) 8 8)
+
+			    (send dc set-pen pens)
+			    (send dc draw-rectangle
+				  (+ x 5) (+ y 95) 10 10)
+			    ; (send dc set-logical-function 'xor)
+			    (send dc draw-rectangle
+				  (+ x 5) (+ y 95) 10 10)
+			    ; (send dc set-logical-function 'copy)
+			    
+			    (send dc draw-line
+				  (+ x 5) (+ y 110) (+ x 8) (+ y 110))
+			    (send dc draw-line
+				  (+ x 8) (+ y 110) (+ x 11) (+ y 113))
+			    (send dc draw-line
+				  (+ x 11) (+ y 113) (+ x 11) (+ y 116))
+			    (send dc draw-line
+				  (+ x 11) (+ y 116) (+ x 8) (+ y 119))
+			    (send dc draw-line
+				  (+ x 8) (+ y 119) (+ x 5) (+ y 119))
+			    (send dc draw-line
+				  (+ x 5) (+ y 119) (+ x 2) (+ y 116))
+			    (send dc draw-line
+				  (+ x 2) (+ y 116) (+ x 2) (+ y 113))
+			    (send dc draw-line
+				  (+ x 2) (+ y 113) (+ x 5) (+ y 110))
+			    
+			    (send dc draw-lines
+				  (list
+				   (make-object point% 5 95)
+				   (make-object point% 8 95)
+				   (make-object point% 11 98)
+				   (make-object point% 11 101)
+				   (make-object point% 8 104)
+				   (make-object point% 5 104)
+				   (make-object point% 2 101)
+				   (make-object point% 2 98)
+				   (make-object point% 5 95))
+				  (+ x 12) (+ y 15))
+
+			    (send dc draw-point (+ x 35) (+ y 115))
+			    (send dc draw-line (+ x 35) (+ y 120) (+ x 35) (+ y 120))
+			    
+			    (send dc draw-line
+				  (+ x 5) (+ y 125) (+ x 10) (+ y 125))
+			    (send dc draw-line
+				  (+ x 11) (+ y 125) (+ x 16) (+ y 125))
+
+			    (send dc set-brush brusht)
+			    (send dc draw-arc 
+				  (+ x 5) (+ y 135)
+				  30 40
+				  0 (/ pi 2))
+			    (send dc draw-arc 
+				  (+ x 5) (+ y 135)
+				  30 40
+				  (/ pi 2) pi)
+			    (send dc set-brush brushs)
+			    (send dc draw-arc 
+				  (+ x 45) (+ y 135)
+				  30 40
+				  (/ pi 2) pi)
+			    (send dc set-brush brusht)      
+
+			    
+			    (when last?
+			      (let ([p (send dc get-pen)])
+				(send dc set-pen (make-object pen% "BLACK" 1 'xor))
+				(send dc draw-polygon octagon)
+				(send dc set-pen p))
+
+			      (when clock-start
+				(let ([b (send dc get-brush)])
+				  (send dc set-brush (make-object brush% "ORANGE" 'solid))
+				  (send dc draw-arc 0. 60. 180. 180. clock-start clock-end)
+				  (send dc set-brush b))))
+
+			    (when last?
+			      (let ([op (send dc get-pen)])
+
+				; Splines
+				(define (draw-ess dx dy)
+				  (send dc draw-spline 
+					(+ dx 200) (+ dy 10)
+					(+ dx 218) (+ dy 12)
+					(+ dx 220) (+ dy 20))
+				  (send dc draw-spline 
+					(+ dx 220) (+ dy 20)
+					(+ dx 222) (+ dy 28)
+					(+ dx 240) (+ dy 30)))
+				(send dc set-pen pen0s)
+				(draw-ess 0 0)
+				(send dc set-pen (make-object pen% "RED" 0 'solid))
+				(draw-ess -2 2)
+			      
+				; Polygons: odd-even vs. winding
+				(let ([polygon
+				       (list (make-object point% 12 0)
+					     (make-object point% 40 0)
+					     (make-object point% 40 28)
+					     (make-object point% 0 28)
+					     (make-object point% 0 12)
+					     (make-object point% 28 12)
+					     (make-object point% 28 40)
+					     (make-object point% 12 40)
+					     (make-object point% 12 0))]
+				      [ob (send dc get-brush)]
+				      [op (send dc get-pen)])
+				  (send dc set-pen pen1s)
+				  (send dc set-brush (make-object brush% "BLUE" 'solid))
+				  (send dc draw-polygon polygon 200 40 'odd-even)
+				  (send dc draw-polygon polygon 200 90 'winding)
+				  (send dc set-pen op)
+				  (send dc set-brush ob))
+
+
+				; Brush patterns:
+				(let ([pat-list (list 'bdiagonal-hatch
+						      'crossdiag-hatch
+						      'fdiagonal-hatch
+						      'cross-hatch
+						      'horizontal-hatch
+						      'vertical-hatch)]
+				      [b (make-object brush% "BLACK" 'solid)]
+				      [ob (send dc get-brush)]
+				      [obg (send dc get-background)]
+				      [blue (make-object color% "BLUE")])
+				  (let loop ([x 245][y 10][l pat-list])
+				    (unless (null? l)
+				      (send b set-color "BLACK")
+				      (send b set-style (car l))
+				      (send dc set-brush b)
+				      (send dc draw-rectangle x y 20 20)
+				      (send dc set-brush ob)
+				      (send b set-color "GREEN")
+				      (send dc set-brush b)
+				      (send dc draw-rectangle (+ x 25) y 20 20)
+				      (send dc set-background blue)
+				      (send dc draw-rectangle (+ x 50) y 20 20)
+				      (send dc set-background obg)
+				      (send dc set-brush ob)
+				      (loop x (+ y 25) (cdr l))))
+
+				  (send b set-style 'panel)
+				  (send b set-color (get-panel-background))
+				  (send dc set-brush b)
+				  (send dc draw-rectangle 320 10 20 20)
+				  (send dc draw-ellipse 320 35 20 20)
+				  (send dc draw-arc 320 60 20 20 0 3.14)
+				  (send dc draw-rounded-rectangle 320 85 20 20 2)
+
+				  (send dc set-brush ob))
+				
+				(send dc set-pen op))
+
+			      ; Thick-line centering:
+			      (let ([thick (make-object pen% "GREEN" 5 'solid)])
+				(define (draw-lines)
+				  (send dc draw-line 360 10 400 50)
+				  (send dc draw-line 360 50 400 10)
+				  (send dc draw-line 360 80 400 80)
+				  (send dc draw-line 380 60 380 100)
+				  (send dc draw-line 360 120 400 140)
+				  (send dc draw-line 370 110 390 150))
+				(let ([op (send dc get-pen)])
+				  (send dc set-pen thick)
+				  (draw-lines)
+				  (send dc set-pen pen0s)
+				  (draw-lines)
+				  (send dc set-pen op)))
+				
+			      ; B&W 8x8 stipple:
+			      (unless no-bitmaps?
+				(let ([bml (get-b&w-light-stipple)]
+				      [bmh (get-b&w-half-stipple)]
+				      [orig-b (send dc get-brush)]
+				      [orig-pen (send dc get-pen)])
+				  (send dc set-brush brusht)
+				  (send dc set-pen pen1s)
+				  (send dc draw-rectangle 244 164 18 18)
+				  (send dc draw-bitmap bml 245 165)
+				  (send dc draw-bitmap bml 245 173)
+				  (send dc draw-bitmap bml 253 165)
+				  (send dc draw-bitmap bml 253 173)
+
+				  (let ([p (make-object pen% "RED" 1 'solid)])
+				    (send p set-stipple bmh)
+				    (send dc set-pen p)
+				    (send dc draw-rectangle 270 164 18 18))
+
+				  (send dc set-brush orig-b)
+				  (send dc set-pen orig-pen))))
+			    
+			    (unless no-bitmaps?
+			      (let ([obg (send dc get-background)]
+				    [tan (make-object color% "TAN")])
+				(send dc set-background tan)
+				(let* ([bits #"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789/+"]
+				       [bm (make-object bitmap% bits 64 8)])
+				  (send dc draw-bitmap bm 306 164 'opaque))
+				(let* ([bits #"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz01234567"]
+				       [bm (make-object bitmap% bits 48 10)])
+				  (send dc draw-bitmap bm 306 184 'opaque))
+				(send dc set-background obg)))
+
+			    (when last?
+			      ; Test get-text-extent
+			      (let ([save-pen (send dc get-pen)]
+				    [save-fnt (send dc get-font)])
+				(send dc set-pen (make-object pen% "YELLOW" 1 'solid))
+				(let loop ([fam '(default default modern modern decorative roman)]
+					   [stl '(normal  slant   slant  italic normal     normal)]
+					   [wgt '(normal  bold    normal normal bold       normal)]
+					   [sze '(12      12      12     12     12         32)]
+					   [x 244]
+					   [y 210]
+					   [chinese? #t])
+				  (unless (null? fam)
+				    (let ([fnt (make-object font% (car sze) (car fam) (car stl) (car wgt))]
+					  [s "AvgflfiMh"])
+				      (send dc set-font fnt)
+				      (send dc draw-text s x y kern?)
+				      (send dc set-font save-fnt)
+				      (let-values ([(w h d a) (send dc get-text-extent s fnt kern?)])
+					(send dc draw-rectangle x y w h)
+					(send dc draw-line x (+ y (- h d)) (+ x w) (+ y (- h d)))
+					(when chinese?
+					  (let ([s "\u7238"]
+						[x (+ x (* 1.5 w))]
+						[cfnt (if (and (dc . is-a? . post-script-dc%)
+							       manual-chinese?)
+							  (make-object font% 12 "MOESung-Regular" 'default)
+							  fnt)])
+					    (send dc set-font cfnt)
+					    (send dc draw-text s x y kern?)
+					    (send dc set-font fnt)
+					    (let-values ([(w h d a) (send dc get-text-extent s cfnt kern?)])
+					      (send dc draw-rectangle x y w h)
+					      (send dc draw-line x (+ y (- h d)) (+ x w) (+ y (- h d)))
+					      ;; Mathematical "A" (beyond UCS-2)
+					      (let ([s "\U1D670"]
+						    [x (+ x (* 1.5 w))])
+						(send dc set-font fnt)
+						(send dc draw-text s x y kern?)
+						(send dc set-font fnt)
+						(let-values ([(w h d a) (send dc get-text-extent s cfnt kern?)])
+						  (send dc draw-rectangle x y w h)
+						  (send dc draw-line x (+ y (- h d)) (+ x w) (+ y (- h d))))))))
+					(loop (cdr fam) (cdr stl) (cdr wgt) (cdr sze) x (+ y h) #f)))))
+				(send dc set-pen save-pen)))
+
+			    ; Bitmap copying:
+			    (when (and (not no-bitmaps?) last?)
+			      (let ([x 5] [y 165])
+				(let ([mred-icon (get-icon)])
+				  (case mask-ex-mode
+				    [(plt plt-mask plt^plt mred^plt)
+				     (let* ([plt (get-plt)]
+					    [tmp-bm (make-object bitmap% 
+								 (send mred-icon get-width)
+								 (send mred-icon get-height)
+								 #f)]
+					    [tmp-dc (make-object bitmap-dc% tmp-bm)])
+				       (send tmp-dc draw-bitmap plt
+					     (/ (- (send mred-icon get-width)
+						   (send plt get-width))
+						2)
+					     (/ (- (send mred-icon get-height)
+						   (send plt get-height))
+						2))
+				       (if (eq? mask-ex-mode 'mred^plt)
+					   (send dc draw-bitmap mred-icon x y
+						 'solid
+						 (send the-color-database find-color "BLACK")
+						 tmp-bm)
+					   (send dc draw-bitmap tmp-bm x y 'solid 
+						 (send the-color-database find-color "BLACK")
+						 (cond
+						  [(eq? mask-ex-mode 'plt-mask) mred-icon]
+						  [(eq? mask-ex-mode 'plt^plt) tmp-bm]
+						  [else #f]))))]
+                                    [(mred^mred)
+                                     (send dc draw-bitmap mred-icon x y
+                                           'solid
+                                           (send the-color-database find-color "BLACK")
+                                           mred-icon)]
+                                    [(mred~)
+                                     (send dc draw-bitmap (get-rotated) x y 'opaque)]
+                                    [(mred^mred~ opaque-mred^mred~ red-mred^mred~)
+                                     (send dc draw-bitmap mred-icon x y 
+                                           (if (eq? mask-ex-mode 'opaque-mred^mred~)
+                                               'opaque
+                                               'solid)
+                                           (send the-color-database find-color 
+                                                 (if (eq? mask-ex-mode 'red-mred^mred~)
+                                                     "RED"
+                                                     "BLACK"))
+                                           (get-rotated))]
+                                    [else
+                                     ;; simple draw
+                                     (send dc draw-bitmap mred-icon x y 'xor)]))
+				(set! x (+ x (send (get-icon) get-width)))
+				(let ([black (send the-color-database find-color "BLACK")]
+				      [red (send the-color-database find-color "RED")]
+				      [do-one
+				       (lambda (bm mode color)
+					 (if (send bm ok?)
+					     (begin
+					       (let ([h (send bm get-height)]
+						     [w (send bm get-width)])
+						 (send dc set-pen (make-object pen% "YELLOW" 1 'solid))
+						 (send dc draw-line 3 3 40 40)
+						 (send dc draw-bitmap-section
+						       bm x y 
+						       0 0 w h
+						       mode color)
+						 (set! x (+ x w 10))))
+					     (printf "bad bitmap~n")))])
+				  ;; BB icon
+				  (do-one bb 'solid black)
+				  (let ([start x])
+				    ;; First three return icons:
+				    (do-one return 'solid black)
+				    (do-one return 'solid red)
+				    (do-one return 'opaque red)
+				    ;; Next three, on a bluew background
+				    (let ([end x]
+					  [b (send dc get-brush)])
+				      (send dc set-brush (make-object brush% "BLUE" 'solid))
+				      (send dc draw-rounded-rectangle (- start 5) (+ y 15) (- end start) 15 -0.2)
+				      (send dc set-brush b)
+				      (set! x start)
+				      (set! y (+ y 18))
+				      (do-one return 'solid black)
+				      (do-one return 'solid red)
+				      (do-one return 'opaque red)
+				      (set! y (- y 18))))
+				  ;; Another BB icon, make sure color has no effect
+				  (do-one bb 'solid red)
+				  ;; Another return, blacnk on red
+				  (let ([bg (send dc get-background)])
+				    (send dc set-background (send the-color-database find-color "BLACK"))
+				    (do-one return 'opaque red)
+				    (send dc set-background bg))
+				  ;; Return by drawing into color, copying color to monochrome, then
+				  ;;  monochrome back oonto canvas:
+				  (let* ([w (send return get-width)]
+					 [h (send return get-height)]
+					 [color (make-object bitmap% w h)]
+					 [mono (make-object bitmap% w h #t)]
+					 [cdc (make-object bitmap-dc% color)]
+					 [mdc (make-object bitmap-dc% mono)])
+				    (send cdc clear)
+				    (send cdc draw-bitmap return 0 0)
+				    (send mdc clear)
+				    (send mdc draw-bitmap color 0 0)
+				    (send dc draw-bitmap mono
+					  (- x w 10) (+ y 18)))
+				  (send dc set-pen pens))))
+
+			    (when (and (not no-stipples?) last?)
+			      ; Blue box as background:
+			      (send dc set-brush brushb)
+			      (send dc draw-rectangle 80 200 125 40)
+			      (when (send return ok?)
+				(let ([b (make-object brush% "GREEN" 'solid)])
+				  (send b set-stipple return)
+				  (send dc set-brush b)
+				  ; First stipple (transparent background)
+				  (send dc draw-rectangle 85 205 30 30)
+				  (send dc set-brush brushs)
+				  (send b set-style 'opaque)
+				  (send dc set-brush b)
+				  ; Second stipple (opaque)
+				  (send dc draw-ellipse 120 205 30 30)
+				  (send dc set-brush brushs)
+				  (send b set-stipple bb)
+				  (send dc set-brush b)
+				  ; Third stipple (BB logo)
+				  (send dc draw-rectangle 155 205 20 30)
+				  (send dc set-brush brushs)
+				  (send b set-stipple #f)
+				  (send b set-style 'cross-hatch)
+				  (send dc set-brush b)
+				  ; Green cross hatch (white BG) on blue field
+				  (send dc draw-rectangle 180 205 20 20)
+				  (send dc set-brush brushs))))
+			    
+			    (when (and pixel-copy? last? (not (or ps? (eq? dc can-dc))))
+			      (let* ([x 100]
+				     [y 170]
+				     [x2 245] [y2 188]
+				     [w 40] [h 20]
+				     [c (make-object color%)]
+				     [bm (make-object bitmap% w h depth-one?)]
+				     [mdc (make-object bitmap-dc%)])
+				(send mdc set-bitmap bm)
+				(let iloop ([i 0])
+				  (unless (= i w)
+				    (let jloop ([j 0])
+				      (if (= j h)
+					  (iloop (add1 i))
+					  (begin
+					    (send dc get-pixel (+ i x) (+ j y) c)
+					    (send mdc set-pixel i j c)
+					    (jloop (add1 j)))))))
+				(send dc draw-bitmap bm x2 y2)
+				(let ([p (send dc get-pen)]
+				      [b (send dc get-brush)])
+				  (send dc set-pen (make-object pen% "BLACK" 0 'xor-dot))
+				  (send dc set-brush brusht)
+				  (send dc draw-rectangle x y w h)
+				  (send dc set-pen p)
+				  (send dc set-brush b))))
+			    
+			    (let ([styles (list 'solid
+						'dot
+						'long-dash
+						'short-dash
+						'dot-dash)]
+				  [obg (send dc get-background)]
+				  [red (make-object color% "RED")])
+			      (let loop ([s styles][y 250])
+				(unless (null? s)
+				  (let ([p (make-object pen% "GREEN" flevel (car s))])
+				    (send dc set-pen p)
+				    (send dc draw-line (+ x 5) y (+ x 30) y)
+				    (send dc set-background red)
+				    (send dc draw-line (+ x 5) (+ 4 y) (+ x 30) (+ y 4))
+				    (send dc set-background obg)
+				    (send pens set-style (car s))
+				    (send dc set-pen pens)
+				    (send dc draw-line (+ x 30) y (+ x 55) y)
+				    (send dc set-background red)
+				    (send dc draw-line (+ x 30) (+ y 4) (+ x 55) (+ y 4))
+				    (send dc set-background obg)
+				    (send dc set-pen pent)
+				    (send pens set-style 'solid)
+				    (loop (cdr s) (+ y 8))))))
+
+			    (when (= flevel 2)
+			      (let ([lens '(0 0.25 0.5 0.75 1.0 1.25 1.5 1.75 2.0)])
+				(let loop ([l lens][x 10])
+				  (unless (null? l)
+				    (let ([p (make-object pen% "BLACK" (car l) 'solid)])
+				      (send dc set-pen p)
+				      (send dc draw-line x 300 (+ x 19) 300)
+				      (send dc set-pen pent)
+				      (loop (cdr l) (+ x 20)))))))
+
+			    (when last?
+			      (let ()
+				(define (pen cap join)
+				  (let ([p (make-object pen% "blue" 4 'solid)])
+				    (send p set-cap cap)
+				    (send p set-join join)
+				    (send dc set-pen p)))
+				(send dc set-brush (make-object brush% "white" 'transparent))
+				(pen 'projecting 'miter)
+				(send dc draw-lines star 410 10)
+				(send dc draw-polygon star 480 10)
+				(pen 'round 'round)
+				(send dc draw-lines star 410 80)
+				(send dc draw-polygon star 480 80)
+				(pen 'butt 'bevel)
+				(send dc draw-lines star 410 150)
+				(send dc draw-polygon star 480 150))
+
+			      (send dc set-pen (make-object pen% "green" 3 'solid))
+			      (send dc set-brush (make-object brush% "yellow" 'solid))
+			      (send dc draw-path (let ([p (new dc-path%)])
+						   (send p append fancy-path)
+						   (send p scale 0.5 0.5)
+						   (send p translate 410 230)
+						   p))
+			      (send dc set-pen (make-object pen% "black" 0 'solid))
+			      (send dc set-brush (make-object brush% "red" 'solid))
+			      (send dc draw-path (let ([p (new dc-path%)])
+						   (send p append lambda-path)
+						   (send p scale 0.3 0.3)
+						   p)
+				    465 230)
+
+			      (send dc draw-path (let ([p (new dc-path%)])
+						   (send p rectangle 10 310 20 20)
+						   (send p rounded-rectangle 40 310 20 20 5)
+						   (send p ellipse 70 310 20 20)
+						   (send p move-to 100 310)
+						   (send p lines (list (make-object point% 0 0)
+								       (make-object point% 0 20)
+								       (make-object point% 20 10))
+							 100 310)
+						   p))
+
+			      (send dc draw-line 130 310 150 310)
+			      (send dc draw-line 130 312.5 150 312.5)
+			      (send dc draw-line 130 314.3 150 314.3)
+			      (send dc draw-line 130 316.7 150 316.7)
+
+			      (let-values ([(xs ys) (send dc get-scale)])
+				(send dc set-scale (* xs 1.25) (* ys 1.25))
+				(let ([x (/ 10 1.25)]
+				      [y (/ 340 1.25)])
+				  (send dc draw-bitmap square-bm x y)
+				  (send dc draw-bitmap square-bm (+ x 10) y)
+				  (send dc draw-bitmap square-bm (+ x 20) y)
+				  (send dc draw-bitmap square-bm (+ x 30) y))
+				(send dc set-scale xs ys)
+				(send dc set-pen "black" 0 'solid)
+				(send dc draw-line 10 337 59 337))
+
+			      (let ([p (send dc get-pen)])
+				(send dc set-pen "blue" 8 'solid)
+				(send dc draw-rectangle 160 310 20 20)
+				(send dc set-pen "blue" 7 'solid)
+				(send dc draw-rectangle 187 310 20 20)
+				(send dc set-pen p)))
+			      
+			    (when (and last? (not (or ps? (eq? dc can-dc)))
+				       (send mem-dc get-bitmap))
+			      (send can-dc draw-bitmap (send mem-dc get-bitmap) 0 0 'opaque)))
+			  
+			  'done)])
+
+		  (send (get-dc) set-scale 1 1)
+		  (send (get-dc) set-origin 0 0)
+
+		  (let ([dc (if ps?
+				(let ([dc (if (eq? ps? 'print)
+					      (make-object printer-dc%)
+					      (make-object post-script-dc%))])
+				  (and (send dc ok?) dc))
+				(if (and use-bitmap?)
+				    (begin
+				      (send mem-dc set-bitmap bm)
+				      mem-dc)
+				    (get-dc)))])
+		    (when dc
+		      (send dc start-doc "Draw Test")
+		      (send dc start-page)
+
+		      (if clip-pre-scale?
+			  (begin
+			    (send dc set-scale 1 1)
+			    (send dc set-origin 0 0))
+			  (begin
+			    (send dc set-scale xscale yscale)
+			    (send dc set-origin offset offset)))
+		      (send dc set-smoothing smoothing)
+		      
+		      (send dc set-background
+			    (if cyan?
+				(send the-color-database find-color "CYAN")
+				(send the-color-database find-color "WHITE")))
+
+		      ;(send dc set-clipping-region #f)
+		      (send dc clear)
+
+		      (if clock-clip?
+			  (let ([r (make-object  region% dc)])
+			    (send r set-arc 0. 60. 180. 180. clock-start clock-end)
+			       (send dc set-clipping-region r))
+			  (let ([mk-poly (lambda (mode)
+					   (let ([r (make-object region% dc)])
+					     (send r set-polygon octagon 0 0 mode) r))]
+				[mk-circle (lambda ()
+					     (let ([r (make-object region% dc)])
+					       (send r set-ellipse 0. 60. 180. 180.) r))]
+				[mk-rect (lambda ()
+					   (let ([r (make-object region% dc)])
+					     (send r set-rectangle 100 -25 10 400) r))])
+			    (case clip
+			      [(none) (void)]
+			      [(rect) (send dc set-clipping-rect 100 -25 10 400)]
+			      [(rect2) (send dc set-clipping-rect 50 -25 10 400)]
+			      [(poly) (send dc set-clipping-region (mk-poly 'odd-even))]
+			      [(circle) (send dc set-clipping-region (mk-circle))]
+			      [(wedge) (let ([r (make-object region% dc)])
+					 (send r set-arc 0. 60. 180. 180. (* 1/4 pi) (* 3/4 pi))
+					 (send dc set-clipping-region r))]
+			      [(lam) (let ([r (make-object region% dc)])
+				       (send r set-path lambda-path)
+				       (send dc set-clipping-region r))]
+			      [(rect+poly) (let ([r (mk-poly 'winding)])
+					     (send r union (mk-rect))
+						(send dc set-clipping-region r))]
+			      [(rect+circle) (let ([r (mk-circle)])
+					       (send r union (mk-rect))
+					       (send dc set-clipping-region r))]
+			      [(poly-rect) (let ([r (mk-poly 'odd-even)])
+					     (send r subtract (mk-rect))
+					     (send dc set-clipping-region r))]
+			      [(poly&rect) (let ([r (mk-poly 'odd-even)])
+					     (send r intersect (mk-rect))
+						(send dc set-clipping-region r))]
+			      [(poly^rect) (let ([r (mk-poly 'odd-even)])
+					     (send r xor (mk-rect))
+					     (send dc set-clipping-region r))]
+			      [(roundrect) (let ([r (make-object region% dc)])
+					     (send r set-rounded-rectangle 80 200 125 40 -0.25)
+					     (send dc set-clipping-region r))]
+			      [(empty) (let ([r (make-object region% dc)])
+					 (send dc set-clipping-region r))]
+			      [(polka) 
+			       (let ([c (send dc get-background)])
+				 (send dc set-background (send the-color-database find-color "PURPLE"))
+				 (send dc clear)
+				 (send dc set-background c))
+			       (let ([r (make-object region% dc)]
+				     [w 30]
+				     [s 10])
+				 (let xloop ([x 0])
+				   (if (> x 300)
+				       (send dc set-clipping-region r)
+				       (let yloop ([y 0])
+					 (if (> y 500)
+					     (xloop (+ x w s))
+					     (let ([r2 (make-object region% dc)])
+					       (send r2 set-ellipse x y w w)
+					       (send r union r2)
+					       (yloop (+ y w s))))))))
+			       (send dc clear)])))
+
+		      (when clip-pre-scale?
+			(send dc set-scale xscale yscale)
+			(send dc set-origin offset offset)
+
+			(let ([r (send dc get-clipping-region)])
+			  (send dc set-clipping-rect 0 0 20 20)
+			  (if r
+			      (let ([r2 (make-object region% dc)])
+				(send r2 set-rectangle 0 0 0 0)
+				(send r xor r2)
+				(send r2 xor r)
+				(send dc set-clipping-region r2))
+			      (send dc set-clipping-region #f))))
+		      
+		      ;; check default pen/brush:
+		      (send dc draw-rectangle 0 0 5 5)
+		      (send dc draw-line 0 0 20 6)
+
+		      (send dc set-font (make-object font% 10 'default))
+
+		      (draw-series dc pen0s pen0t pen0x "0 x 0" 5 0 0 #f)
+		      
+		      (draw-series dc pen1s pen1t pen1x "1 x 1" 70 0 1 #f)
+		      
+		      (draw-series dc pen2s pen2t pen2x "2 x 2" 135 0 2 #t)
+
+		      (unless clock-clip?
+			(let ([r (send dc get-clipping-region)])
+			  (if (eq? clip 'none)
+			      (when r
+				(error 'draw-test "shouldn't have been a clipping region"))
+			      (let*-values ([(x y w h) (send r get-bounding-box)]
+					    [(l) (list x y w h)]
+					    [(=~) (lambda (x y)
+						    (<= (- x 2) y (+ x 2)))])
+				(unless (andmap =~ l
+						(let ([l
+						       (case clip
+							 [(rect) '(100. -25. 10. 400.)]
+							 [(rect2) '(50. -25. 10. 400.)]
+							 [(poly circle poly-rect) '(0. 60. 180. 180.)]
+							 [(wedge) '(26. 60. 128. 90.)]
+							 [(lam) '(58. 10. 202. 281.)]
+							 [(rect+poly rect+circle poly^rect) '(0. -25. 180. 400.)]
+							 [(poly&rect) '(100. 60. 10. 180.)]
+							 [(roundrect) '(80. 200. 125. 40.)]
+							 [(polka) '(0. 0. 310. 510.)]
+							 [(empty) '(0. 0. 0. 0.)])])
+						  (if clip-pre-scale?
+						      (list (- (/ (car l) xscale) offset)
+							    (- (/ (cadr l) yscale) offset)
+							    (- (/ (caddr l) xscale) offset)
+							    (- (/ (cadddr l) yscale) offset))
+						      l)))
+				  (error 'draw-test "clipping region changed badly: ~a" l))))))
+
+		      (let-values ([(w h) (send dc get-size)])
+			(unless (cond
+				 [ps? #t]
+				 [use-bad? #t]
+				 [use-bitmap? (and (= w (* xscale DRAW-WIDTH)) (= h (* yscale DRAW-HEIGHT)))]
+				 [else (and (= w (* 2 DRAW-WIDTH)) (= h (* 2 DRAW-HEIGHT)))])
+			  (error 'x "wrong size reported by get-size: ~a ~a" w h)))
+
+		      (send dc set-clipping-region #f)
+
+		      (send dc end-page)
+		      (send dc end-doc)))
+		  
+		  (when save-filename
+		    (send bm save-file save-filename save-file-format)
+		    (set! save-filename #f))
+
+		  'done)])])
+	    (super-new [parent parent][style '(hscroll vscroll)])
+	    (init-auto-scrollbars (* 2 DRAW-WIDTH) (* 2 DRAW-HEIGHT) 0 0))
+	  vp)])
+    (make-object radio-box% #f '("Canvas" "Pixmap" "Bitmap" "Bad") hp0
+		 (lambda (self event)
+		   (set! use-bitmap? (< 0 (send self get-selection)))
+		   (set! depth-one? (< 1 (send self get-selection)))
+		   (set! use-bad? (< 2 (send self get-selection)))
+		   (send canvas refresh))
+		 '(horizontal))
+    (make-object button% "PS" hp
+		 (lambda (self event)
+		   (send canvas on-paint #t)))
+    (make-object button% "Print" hp
+		 (lambda (self event)
+		   (send canvas on-paint 'print)))
+    (make-object choice% #f '("1" "*2" "/2" "1,*2" "*2,1") hp
+		 (lambda (self event)
+		   (send canvas set-scale 
+			 (list-ref '(1 2 1/2 1 2) (send self get-selection))
+			 (list-ref '(1 2 1/2 2 1) (send self get-selection)))))
+    (make-object check-box% "+10" hp
+		 (lambda (self event)
+		   (send canvas set-offset (if (send self get-value) 10 0))))
+    (make-object check-box% "Cyan" hp
+		 (lambda (self event)
+		   (set! cyan? (send self get-value))
+		   (send canvas refresh)))
+    (send (make-object check-box% "Icons" hp2
+		       (lambda (self event)
+			 (send canvas set-bitmaps (send self get-value))))
+	  set-value #t)
+    (send (make-object check-box% "Stipples" hp2
+		       (lambda (self event)
+			 (send canvas set-stipples (send self get-value))))
+	  set-value #t)
+    (make-object check-box% "Pixset" hp2
+		 (lambda (self event)
+		   (send canvas set-pixel-copy (send self get-value))))
+    (make-object choice% #f '("Unsmoothed" "Smoothed" "Aligned") hp2.5
+		 (lambda (self event)
+		   (set! smoothing (list-ref '(unsmoothed smoothed aligned)
+					     (send self get-selection)))
+		   (send canvas refresh)))
+    (make-object button% "Clock" hp2.5 (lambda (b e) (clock #f)))
+    (make-object choice% #f
+		 '("MrEd XOR" "PLT Middle" "PLT ^ MrEd" "MrEd ^ PLT" "MrEd ^ MrEd" 
+		   "MrEd~" "MrEd ^ MrEd~" "M^M~ Opaque" "M^M~ Red"
+		   "PLT^PLT")
+		 hp2.5
+		 (lambda (self event)
+		   (send canvas set-mask-ex-mode 
+			 (list-ref '(mred plt plt-mask mred^plt mred^mred 
+					  mred~ mred^mred~ opaque-mred^mred~ red-mred^mred~
+					  plt^plt)
+				   (send self get-selection)))))
+    (make-object check-box% "Kern" hp2.5
+		 (lambda (self event)
+		   (send canvas set-kern (send self get-value))))
+    (make-object button% "Save" hp0
+		 (lambda (b e)
+		   (unless use-bitmap?
+		     (error 'save-file "only available for pixmap/bitmap mode"))
+		   (let ([f (put-file)])
+		     (when f
+		       (let ([format
+			      (cond 
+			       [(regexp-match "[.]xbm$" f) 'xbm]
+			       [(regexp-match "[.]xpm$" f) 'xpm]
+			       [(regexp-match "[.]jpe?g$" f) 'jpeg]
+			       [(regexp-match "[.]png$" f) 'png]
+			       [else (error 'save-file "unknown suffix: ~e" f)])])
+			 (set! save-filename f)
+			 (set! save-file-format format)
+			 (send canvas refresh))))))
+    (make-object choice% "Clip" 
+		 '("None" "Rectangle" "Rectangle2" "Octagon" 
+		   "Circle" "Wedge" "Round Rectangle" "Lambda"
+		   "Rectangle + Octagon" "Rectangle + Circle" 
+		   "Octagon - Rectangle" "Rectangle & Octagon" "Rectangle ^ Octagon" "Polka"
+		   "Empty")
+		 hp3
+		 (lambda (self event)
+		   (set! clip (list-ref
+		               '(none rect rect2 poly circle wedge roundrect lam 
+				      rect+poly rect+circle poly-rect poly&rect poly^rect 
+				      polka empty)
+		               (send self get-selection)))
+		   (send canvas refresh)))
+    (make-object check-box% "Clip Pre-Scale" hp3
+		 (lambda (self event)
+		   (send canvas set-clip-pre-scale (send self get-value))))
+    (let ([clock (lambda (clip?)
+		   (thread (lambda ()
+			     (set! clock-clip? clip?)
+			     (let loop ([c 0][swapped? #f][start 0.][end 0.])
+			       (if (= c 32)
+				   (if swapped?
+				       (void)
+				       (loop 0 #t 0. 0.))
+				   (begin
+				     (set! clock-start (if swapped? end start))
+				     (set! clock-end (if swapped? start end))
+				     (send canvas on-paint)
+				     (sleep 0.25)
+				     (loop (add1 c) swapped? (+ start (/ pi 8)) (+ end (/ pi 16))))))
+			     (set! clock-clip? #f)
+			     (set! clock-start #f)
+			     (set! clock-end #f)
+			     (send canvas refresh))))])
+      (make-object button% "Clip Clock" hp3 (lambda (b e) (clock #t)))))
+
+  (send f show #t))
+
+; Canvas, Pixmaps, and Bitmaps:
+;  get-pixel
+;  begin-set-pixel
+;  end-set-pixel
+;  set-pixel
diff --git a/collects/tests/mred/editor.ss b/collects/tests/mred/editor.ss
new file mode 100644
index 0000000000..3c62a80bc3
--- /dev/null
+++ b/collects/tests/mred/editor.ss
@@ -0,0 +1,292 @@
+
+(load-relative "loadtest.ss")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;                            Editor Tests                                    ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;;;;; Undo tests
+
+(define e (make-object text%))
+
+(stv e insert "Hello")
+(st #t e is-modified?)
+(stv e undo)
+(st #f e is-modified?)
+(stv e redo)
+(st #t e is-modified?)
+(stv e set-modified #f)
+(st #f e is-modified?)
+(stv e undo)
+(st #t e is-modified?)
+(stv e redo)
+(st #f e is-modified?)
+(stv e undo)
+(st #t e is-modified?)
+(stv e redo)
+(st #f e is-modified?)
+(stv e undo)
+(stv e set-modified #f)
+(st #f e is-modified?)
+(stv e redo)
+(st #t e is-modified?)
+(st "Hello" e get-text)
+(define undone? #f)
+(stv e add-undo (letrec ([f (lambda ()
+			      (set! undone? #t)
+			      (send e add-undo f) ; reinstall self!
+			      #f)])
+		  f))
+(stv e undo)
+(st "Hello" e get-text)
+(test #t 'undone? undone?)
+(stv e undo)
+(st "" e get-text)
+(set! undone? #f)
+(stv e redo)
+(st "Hello" e get-text)
+(test #f 'undone? undone?)
+(stv e redo)
+(st "Hello" e get-text)
+(test #t 'undone? undone?)
+(set! undone? #f)
+(stv e redo)
+(st "Hello" e get-text)
+(test #f 'undone? undone?)
+(stv e insert "x")
+(st "Hellox" e get-text)
+(stv e add-undo (lambda ()
+		  (set! undone? #t)
+		  #t)) ; do next one, too
+(stv e undo)
+(test #t 'undone? undone?)
+(st "Hello" e get-text)
+
+;; Editor ports
+
+(let ([e (make-object text%)]
+      [res-mode? #f])
+  (stv e insert "hello")
+  (let ([p (open-input-text-editor e)])
+    (test 'hello 'read (read p))
+    (test eof 'read (read p)))
+  (stv e insert " there")
+  (let ([p (open-input-text-editor e)])
+    (test 'hello 'read (read p))
+    (test 'there 'read (read p))
+    (test eof 'read (read p)))
+  (stv e insert (make-object
+		 (class* snip% 
+		   (readable-snip<%>)
+		   (define/public (read-special src line col pos)
+		     (if res-mode?
+			 'res
+			 (error 'ack)))
+		   (super-new))))
+  (let ([p (open-input-text-editor e)])
+    (port-count-lines! p)
+    (test '(1 0 1) 'pos (call-with-values (lambda () (port-next-location p)) list))
+    (test 'hello 'read (read p))
+    (test '(1 5 6) 'pos (call-with-values (lambda () (port-next-location p)) list))
+    (test 'there 'read (read p))
+    (test '(1 11 12) 'pos (call-with-values (lambda () (port-next-location p)) list))
+    (test 'got-ack 'read (with-handlers ([exn:fail? (lambda (x)
+						      'got-ack)])
+			   (read p)))
+    (test '(1 12 13) 'pos (call-with-values (lambda () (port-next-location p)) list))
+    (test eof 'read (read p)))
+  (set! res-mode? #t)
+  (let ([p (open-input-text-editor e)])
+    (port-count-lines! p)
+    (test 'hello 'read (read p))
+    (test 'there 'read (read p))
+    (test 'res 'read (read p))
+    (test '(1 12 13) 'pos (call-with-values (lambda () (port-next-location p)) list))
+    (test eof 'read (read p)))
+  (stv e insert (make-object image-snip% (build-path
+					  (collection-path "icons") 
+					  "plt.gif")))
+  (let ([p (open-input-text-editor e)])
+    (test 'hello 'read (read p))
+    (test 'there 'read (read p))
+    (test 'res 'read (read p))
+    (test #t 'read (is-a? (read p) image-snip%))))
+
+(let ()
+  (define x (new text%))
+  (define s (make-object image-snip% "no-such-image.jpg" 
+			 'unknown #f #f))
+  (define t (make-object image-snip% "no-such-image.jpg" 
+			 'unknown #f #f))
+  (send x insert s 0 'same #t)
+  (send x insert t 1 'same #t)
+  (send x insert "1" 2 'same #t)
+  
+  (let ([i (open-input-text-editor x 0 'end (lambda (x) (eq? x s)))])
+    (test #t 'peek-s (peek-byte-or-special i 0))
+    (test #t 'read-s (read-byte-or-special i))
+    (test #f 'peek-t (peek-byte-or-special i 0))
+    (test 49 'read-1 (peek-byte-or-special i 1))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;                            Snips and Streams                               ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (mk-number-snip-class% term?)
+  (class snip-class%
+    (define/override (read f)
+      (let* ([number-str (if term?
+			     (send f get-bytes)
+			     (send f get-unterminated-bytes))]
+             [number (string->number (bytes->string/utf-8 number-str))]
+             [decimal-prefix (bytes->string/utf-8 (if term?
+						      (send f get-bytes)
+						      (send f get-unterminated-bytes)))]
+             [snip
+              (instantiate number-snip% ()
+                [number number]
+                [decimal-prefix decimal-prefix])])
+        snip))
+    (super-instantiate ())))
+
+(define snip-class (make-object (mk-number-snip-class% #t)))
+(send snip-class set-classname (format "~s" `(lib "number-snip.ss" "drscheme" "private")))
+(send (get-the-snip-class-list) add snip-class)
+
+(define snip-class2 (make-object (mk-number-snip-class% #f)))
+(send snip-class2 set-classname (format "~s" `(lib "number-snip-two.ss" "drscheme" "private")))
+(send (get-the-snip-class-list) add snip-class2)
+
+(define (mk-number-snip% snip-class term?)
+  (define self%
+    (class snip%
+      (init-field number)
+      (define/public (get-number) number)
+      (define/public (get-prefix) decimal-prefix)
+      (init-field [decimal-prefix ""])
+      (define/override (write f)
+	(let ([num (string->bytes/utf-8 (number->string number))]
+	      [pfx (string->bytes/utf-8 decimal-prefix)])
+	  (if term?
+	      (begin
+		(send f put num)
+		(send f put pfx))
+	      (begin
+		(unless (eq? 'ok
+			     (with-handlers ([exn:fail? (lambda (x) 'ok)])
+			       (send f put 5 #"123")
+			       'not-ok))
+		  (error "too-long write should have failed"))
+		(send f put (bytes-length num) num)
+		(send f put (bytes-length pfx) pfx)))))
+      (define/override (copy)
+	(instantiate self% ()
+		     [number number]
+		     [decimal-prefix decimal-prefix]))
+      (inherit get-style)
+      (super-instantiate ())
+      (inherit set-snipclass set-flags get-flags)
+      (set-snipclass snip-class)))
+  self%)
+
+(define number-snip% (mk-number-snip% snip-class #t))
+(define number-snip2% (mk-number-snip% snip-class2 #f))
+
+(define (snip-test term?)
+  (define t (new text%))
+  (define t2 (new text%))
+  (send t insert (new (if term? number-snip% number-snip2%)
+		      [number 1/2]))
+  (send t set-position 0 1)
+  (send t copy)
+  ;; Under X, force snip to be marshalled:
+  (let ([s (send the-clipboard get-clipboard-data "WXME" 0)])
+    (send the-clipboard set-clipboard-client
+	  (make-object (class clipboard-client%
+			 (define/override (get-data fmt)
+			   (and (string=? fmt "WXME")
+				s))
+			 (inherit add-type)
+			 (super-new)
+			 (add-type "WXME")))
+	  0))
+  (send t2 paste)
+  (let ([s (send t2 find-first-snip)])
+    (st 1/2 s get-number)
+    (st "" s get-prefix)))
+
+(snip-test #t)
+(snip-test #f)
+
+(let ()
+  (define orig-snip (make-object string-snip% "hello"))
+  
+  (define out (make-object editor-stream-out-bytes-base%))
+  (define out-stream (make-object editor-stream-out% out))
+  
+  (define _ (send orig-snip write out-stream))
+  
+  (define in (make-object editor-stream-in-bytes-base% (send out get-bytes)))
+  (define in-stream (make-object editor-stream-in% in))
+  
+  (define new-snip
+    (send (send (get-the-snip-class-list) 
+		find 
+		(send (send (new string-snip%) get-snipclass) get-classname))
+	  read in-stream))
+  
+  (st "hello" new-snip get-text 0 10))
+
+;; ----------------------------------------
+;; Check CRLF conversion
+
+(let ([crlf-s (apply
+	       string-append
+	       (let loop ([n 100])
+		 (if (zero? n)
+		     null
+		     (cons (make-string (random 40) #\a)
+			   (cons "\r\n"
+				 (loop (sub1 n)))))))]
+      [e (new text%)])
+  (let ([lf-s (regexp-replace* #rx"\r\n" crlf-s "\n")]
+	[lflf-s (regexp-replace* #rx"\r\n" crlf-s "\n\n")])
+    (st "" e get-text 0 'eof)
+    (send e insert-port (open-input-string crlf-s))
+    (st lf-s e get-text 0 'eof)
+    (send e erase)
+    (send e insert crlf-s)
+    (st lflf-s e get-text 0 'eof)))
+
+;; ----------------------------------------
+;; Check lines and paras without display, but with a max width
+
+(define t (new text%))
+(send t insert "abc\ndef\nghi\n")
+(send t set-max-width 955)
+(st 0 t line-start-position 0)
+(st 4 t line-start-position 1)
+(st 8 t line-start-position 2)
+(st 0 t paragraph-start-position 0)
+(st 4 t paragraph-start-position 1)
+(st 8 t paragraph-start-position 2)
+(st 3 t paragraph-end-position 0)
+(st 7 t paragraph-end-position 1)
+(st 11 t paragraph-end-position 2)
+(st 0 t paragraph-start-line 0)
+(st 1 t paragraph-start-line 1)
+(st 2 t paragraph-start-line 2)
+(st 0 t line-paragraph 0)
+(st 1 t line-paragraph 1)
+(st 2 t line-paragraph 2)
+(st 0 t position-paragraph 0)
+(st 0 t position-paragraph 3)
+(st 1 t position-paragraph 4)
+(st 1 t position-paragraph 7)
+(st 2 t position-paragraph 8)
+(st 2 t position-paragraph 11)
+
+;; ----------------------------------------
+
+(report-errs)
+
diff --git a/collects/tests/mred/frame-edit.ss b/collects/tests/mred/frame-edit.ss
new file mode 100644
index 0000000000..5add33ddd8
--- /dev/null
+++ b/collects/tests/mred/frame-edit.ss
@@ -0,0 +1,73 @@
+;; this file tests frames with various edits in them
+
+(define testing-frame #f)
+
+(define test-frame/edit
+  (lambda (frame% edit% title)
+    (let* ([frame (make-object
+		   (class frame% args
+		     (public [get-edit% (lambda () edit%)])
+		     (inherit show)
+		     (sequence (apply super-init args))))]
+	   [edit (send frame get-edit)]
+	   [string-good "test insert"]
+	   [string-bad "SHOULD NOT SEE THIS"]
+	   [get-insertion
+	    (lambda (string)
+	      (if (is-a? edit wx:media-edit%)
+		  string
+		  (let ([snip (make-object wx:media-snip%)]
+			[snip-e (make-object mred:media-edit%)])
+		    (send snip set-media snip-e)
+		    (send snip-e insert string)
+		    snip)))])
+      (set! testing-frame frame)
+      (send frame set-title-prefix title)
+      (send frame show #t)
+      (send edit insert (get-insertion string-good))
+      (send edit lock #t)
+      (send edit insert (get-insertion string-bad))
+      (send edit lock #f))))
+
+(define continue? #t)
+
+(define close-down
+  (lambda ()
+    (let ([answer (mred:get-choice "Continue the test suite?"
+				   "Yes" "No"
+				   "connections test suite")])
+      (when (send testing-frame on-close)
+	(send testing-frame show #f))
+      (unless answer
+	(error 'close-down)))))
+
+(define-macro frame/edit
+  (lambda (frame% edit%)
+    `(when continue?
+       (printf "testing frame: ~a edit: ~a~n" ',frame% ',edit%)
+       (test-frame/edit ,frame% ,edit% (format "~a ~a" ',frame% ',edit%)))))
+	     
+(define searching-frame% (mred:make-searchable-frame% mred:simple-menu-frame%))
+(define searching-info-frame% (mred:make-searchable-frame% mred:info-frame%))
+
+(frame/edit mred:pasteboard-frame% mred:pasteboard%) (close-down)
+(frame/edit mred:simple-menu-frame% mred:media-edit%) (close-down)
+(frame/edit searching-frame% mred:media-edit%) (close-down)
+
+(frame/edit mred:info-frame% mred:info-edit%) (close-down)
+
+(frame/edit searching-info-frame% mred:searching-edit%)
+(mred:find-string (send testing-frame get-canvas)
+		  null
+		  0 0 (list 'ignore-case))
+(close-down)
+
+(frame/edit mred:info-frame% mred:clever-file-format-edit%) (close-down)
+(frame/edit mred:info-frame% mred:file-edit%) (close-down)
+(frame/edit mred:info-frame% mred:backup-autosave-edit%) (close-down)
+(frame/edit mred:info-frame% mred:scheme-mode-edit%) (close-down)
+
+(frame/edit searching-info-frame% mred:clever-file-format-edit%) (close-down)
+(frame/edit searching-info-frame% mred:file-edit%) (close-down)
+(frame/edit searching-info-frame% mred:backup-autosave-edit%) (close-down)
+(frame/edit searching-info-frame% mred:scheme-mode-edit%) (close-down)
diff --git a/collects/tests/mred/frame-steps.txt b/collects/tests/mred/frame-steps.txt
new file mode 100644
index 0000000000..a68be7a14d
--- /dev/null
+++ b/collects/tests/mred/frame-steps.txt
@@ -0,0 +1,295 @@
+
+These instructions go with the "item.ss" MrEd test file. You probably
+got them by clicking on the "Get Instructions" button.
+
+This file mostly contains instructions for running the "Make Big
+Frame" and "Make Medium Frame" tests. "Big" and "Medium" are silly
+names; they're essentially the same set of tests, but for different
+sets of controls. There are just too many kinds of controls to fit in
+one frame.
+
+The clock in the upper right of the "Test Selector" frame should
+increment every second.
+
+The buttons at the bottom of the Selector frame open little frames for
+testing individual control types in detail. Those frames come with
+their own instructions.
+
+Make XXX Frame
+--------------
+
+Big Frame should contain the following on the left:
+
+  Message (a message) <down-left arrow> (a message)
+  Hello (a button)
+  <BB logo> (a button)
+  List (a list box)
+   Apple
+   Banana
+   Coconut & Donut
+  Check (a check box)
+  <MrEd logo> (a check box)
+  Radio (a radio box)
+   First
+   Second
+   Third
+  Image Radio (a check box)
+   <down-left arrow>
+   <down-right arrow> 
+  Choice (a choice item)
+   Alpha
+   Beta
+   Gamma
+   Delta & Rest
+ Text (a text field)
+   initial & starting
+
+Medium Frame should contain:
+
+ H Slider (a horizontal slider)
+ V Slider (a vertical slider)
+ H Gauge (a horizontal slider)
+ V Gauge (a vertical slider)
+ Text (a multi-line text field)
+   initial & starting
+ A tab panel with two tabs
+   
+
+The names on labels must match the above exactly, except that most
+labels have an "e" or "i" that gets an accent mark to test Latin-1
+labels. Also, <> above indicates an image. Watch out for letters that
+are dropped or &s that are dropped.
+
+Make sure all the controls with moving parts work.
+
+Tabbing and arrow keys should work correctly. The canvas in the bottom
+middle area does not receive the focus via tabs in Big Frame, but it
+does in Medium Frame. When it receives the focus via a tab, "Tab in"
+is drawn in the canvas; when the focus leaves the canvas for any reason
+(tab out, mouse click somewhere else, etc.), "Tab in" is erased.
+
+Window Resizing
+---------------
+
+Stretch the window vertically. Stretch it horizontally.  Unless the
+frame was created with "all stechy" on, then messages, buttons, check
+boxes, and radio boxes should not stretch. Choice and text items 
+should only strech horizontally. Sliders and gauges should only
+resize in the major direction.
+
+If "all stretchy" was on, then everything in the left column should
+stretch both directions.
+
+Show and Hide
+-------------
+
+The second column in the window starts with "Hide and Show".  Click it
+and see that the frame disappears and reappears.  The remaining
+checkboxes can be un-checked to hide items.  The first two hide
+everything in the left column. The remained hide the corresponding
+item on the left.
+
+Click on the canvas at the bottom of the second column. A popup menu
+should accurately report the local visibility of each control. (If a
+control is shown but the panel is hidden, the menu should still say
+SHOWN.)
+
+
+  * hide/show all the controls through each panel
+    checkbox; the menu should say SHOWN for all
+    items
+
+  * click each checkbox to hide an item, then click 
+    again to show it before moving to the next item;
+    check the popup menu for accuracy before and after
+    re-showing
+
+  * hide all of the controls, then hide and unhide the
+    whole panel (one of the top checkboxes); unhiding
+    should not show the hidden controls; unhide one
+    or two to convince yourself that the panel is
+    unhid
+
+  * hide the panel and unhide all of the controls;
+    you should not see any of them; then unhide the
+    panel; they should all appear
+
+  * hide the panel; hide all the controls; unhide the
+    panel (the controls should not appear); unhide
+    all the controls
+
+  * repeat the three steps above with the other panel checkbox
+
+Enable and Disable
+------------------
+
+The third column contains checkboxes for enabling things. Note that
+each radio button has its own enabler, as well as the whole radio
+box. Try each one, clicking on the item to make sure it's really
+disabled.
+
+  * enable/disable all the controls through each panel
+    checkbox
+
+  * click each checkbox to disble an item; click on the
+    item to make sure it's disabled; recheck the checkbox;
+    make sure the item is re-enebaled
+
+  * disable all the controls; disable and re-enable the
+    whole panel; make sure the controls are still disabled
+
+  * disable the panel; re-enable the individual controls;
+    make sure the controls are still not enabled; re-enable
+    the panel and check that the controls are enabled
+
+  * disbale the panel; diable all the controls; enable the
+    panel and make sure the controls are still disabled;
+    enable all the controls
+
+  * repeat the three steps above with the other panel checkbox
+
+  * repeat the three steps for radioboxes and radio items,
+    sintead of panels and controls
+
+Relabeling
+----------
+
+The buttons in the fourth column toggle the labels on items.  The
+control should not resize itself for the new label.
+
+For text labels, the new label is XXXXXXXXX. For icon labels,
+it depends:
+
+  - message: <down-right arrow>
+  - button: <down-left arrow>
+  - checbox: <BB icon>
+
+Note that radio items can't be relabelled.
+
+Be sure to click each button twice, to make sure that the original
+label is restored.
+
+Cursors
+-------
+
+Checking "Control Bullseye Cursors" should change the cursor over
+every control in the left column, plus the canvas in the second
+column.  The cursor should only apply to the "client area" of a
+control, not the label if it is outside the control. The cursor should
+be normal everywhere else.
+
+Checking "Frame Cross Cursor" should change the cursor in the
+frame to a cross. It sets the cursor for the controls only when
+"Controls Bullseye Cursors" is not set.
+
+Checking "Busy Cursor" should change the cursor to a watch everywhere
+in the frame's eventspace. It overrides all other cursor settings.
+
+Combinations to try:
+
+   * Bull only - just controls changed
+   * Cross only - all of frame changed
+   * Bull + Cross - controls are bullseye, cross everywhere else
+       - Uncheck Cross and make sure Bull still works
+       - Recheck Cross, uncheck Bull and make sure Cross works on
+          controls
+   * Busy only - everywhere changed
+   * Busy + Cross - everywhere changed
+       - Uncheck Busy and make sure Cross still works
+       - Recheck Busy, uncheck cross and make sure Busy still works
+       - Uncheck Busy and make sure Cross is still off
+   * Busy + Bull - everywhere changed
+       (same as above, but for Bull)
+   * Busy + Bull + Cross - everywhere changed
+       - Uncheck Busy and verify Bull + Cross
+       (that's enough)
+
+Also, while the busy cursor is on, try creating a new Big/Medium Frame
+and make sure that the busy cursor is active in the new frame and over
+all controls in the new frame.
+
+Deleted Adds
+-------------
+
+The "New Deleted" popup creates subwindow<%>s and adds them to the
+same panel as the "New Deleted" control, but each subwindow<%> is
+created with the 'deleted style, which means that the subwindow<%> is
+initially hidden and deleted. The "*Activate Last*" item activates
+the last-created subwindow<%>, i.e., it shows the subwindow<%> and
+adjusts the panel size to accomodate the activated window<%>. The key
+part of this test is that no deleted subwindow<%> is shown, and no
+deleted subwindow<%> affects the panel's geometry.
+      
+Popup Menus (Big Frame)
+-----------
+
+Hide something. Left-click on the canvas to see the SHOW state.
+Unhide that something. RIGHT-click on the canvas to get the old
+ SHOW state. Then left-click to see the new SHOW state.
+Left-click and pick some item; verify that the canvas shows the
+ select index (counting from 1)
+Right-click and pick some item; verify that the canvas shows the
+ selected index (counting from 1)
+
+Focus Info
+----------
+
+Under "Enable Text", the current focus is show as:
+     label value
+ Sometimes label is () for null (no label)
+ Sometimes value is just #<object> (no known class)
+but usually you can tell what it means.
+
+Click on various controls. Watch how the focus changes (some controls
+on some platforms never get the focus). Verify that the focus
+indicator is always right. (There's about a 1 second delay.)
+
+Event Info
+----------
+
+Under the focus indicator, the last event is reported. If the label of
+the destination is non-null, the label is shown, otherwise the value
+is shown.
+
+As the mouse is moved over a control's client area, the event
+indicator should report the control under the mouse and `mouse' for
+mouse event. This is independent of the location of the focus.
+
+Press a key. Instead of `mouse', the event indicator should say `key',
+and report the item that currently has the focus. (Unfortunately,
+under windows, the key info is immediately replaced with mouse info.)
+
+Event Filtering
+---------------
+
+When "Drop Mouse Events" is checked at the bottom of the thrid column,
+all other controls (except "Drop Mouse Events" and "Drop Key Events")
+shold cease to respond to mouse events. The event indicator will still
+work. Keyboard events should not be affected (though it may be hard to
+get the focus somewhere interesting).
+
+Try every control with mouse events dropped.
+
+"Drop Key Events" does the obvious thing. Try every keybord-responding
+control with events dropped. Try dialog navigation keys on other
+controls, such as TAB or left-arrow.
+
+Different Configuations
+-----------------------
+
+Each Frame can be created in several different configurations (32 or
+64 of them!).
+
+Step through the first 16 configurations, create a frame each time,
+and make sure the resulting controls look right. Resize each frame and
+check stretchiness before closing it.
+
+Go back to the default configuration and try the 3 other combinations
+of label and button fonts. The big label font should apply to external
+control labels, and to message items. The button font should apply to
+the content of controls (names within a button, checkbox, listbox,
+choice, or text control). The "Initially" radio box controls whether
+the control-containing panel is initially enabled (before the controls
+it contains are created). The "Selection" radio box controls the
+initial-value setting for check boxes, radio buttons, list boxes, and
+choices.
diff --git a/collects/tests/mred/gauge-steps.txt b/collects/tests/mred/gauge-steps.txt
new file mode 100644
index 0000000000..7f5610b365
--- /dev/null
+++ b/collects/tests/mred/gauge-steps.txt
@@ -0,0 +1,35 @@
+
+The gauge should be initially empty (i.e., set to 0), and have a
+  maximum value of 10 (although there's no indication of the maximum).
+
+Click "+". The gauge should go up by one.
+
+Click "-". It should go back down to zero.
+
+Click "+" five times. The gauge should be at the halfway point.
+
+Click "-" ten times. (Five type errors.)  Click "+" once. The gauge
+ should be at one.
+
+Click "+" twelve times. (Three mismatch errors.)  Click "-" once. The
+ gauge should be at nine.
+
+Click "-" four times. The gauge should be at the halfway point.
+
+Click "Bigger". The range is now 11 instead of 10, so the gauge
+ should be below halfway.
+
+Click "Smaller". The range is back to 10, so the gauge should be at
+ the halfway point.
+
+Click "Smaller" five times. The range is now 5, so the gauge should
+ be full.
+
+Click "Smaller" once more. The range is now 4, so the gauge value
+ should be 4 also.
+
+Click "Bigger" and the gauge should be 80% full.
+
+Click "Smaller" six times. (Two type errors.)  The minimum gauge range
+ is 1, so click "Bigger" once and the gauge should be at halfway.
+
diff --git a/collects/tests/mred/gui-main.ss b/collects/tests/mred/gui-main.ss
new file mode 100644
index 0000000000..588b125d0f
--- /dev/null
+++ b/collects/tests/mred/gui-main.ss
@@ -0,0 +1,89 @@
+(lambda (new-name save-name console%)
+  (let* ([dir (current-load-relative-directory)]
+	 [console 
+	  (let loop ([printout? #f])
+	    (let ([f (mred:test:get-active-frame)])
+	      (if (and f
+		       (is-a? f console%))
+		  f
+		  (begin
+		    (unless printout?
+		      (printf "please select the console~n"))
+		    (sleep 1/2)
+		    (loop #t)))))]
+	 [wait
+	  (opt-lambda (test desc-string [time 5])
+	    (let ([int 1/2])
+	      (let loop ([sofar 0])
+		(cond
+		  [(> sofar time) (error 'wait desc-string)]
+		  [(test) (void)]
+		  [else (sleep int)
+			(loop (+ sofar int))]))))]
+	 [wait-pending
+	  (lambda ()
+	    (wait (lambda () (= 0 (mred:test:number-pending-actions)))
+		  "pending action sdidn't terminate")
+	    (mred:test:reraise-error))]
+	 [_ (mred:test:menu-select "File" new-name)]
+	 [_ (wait-pending)]
+	 [_ (wait (lambda () (not (eq? (mred:test:get-active-frame) console)))
+		  "focus didn't change from the console after File|New")]
+	 [frame (mred:test:get-active-frame)]
+	 [_ (mred:test:keystroke #\a)]
+	 
+	 [_ (mred:test:menu-select "File" "Close")]
+	 [_ (wait (lambda () (not (eq? frame (mred:test:get-active-frame))))
+		  "active frame remained original frame after File|Close")]
+	 [_ (mred:test:button-push "Cancel")]
+	 [_ (wait-pending)]
+	 
+	 [_ (mred:test:menu-select "File" "Close")]
+	 [_ (wait (lambda () (not (eq? frame (mred:test:get-active-frame))))
+		  "active frame remained original frame after File|Close")]
+	 [_ (mred:test:button-push "Cancel")]
+	 [_ (wait-pending)]
+	 
+	 [_ (wait (lambda () (eq? frame (mred:test:get-active-frame)))
+		  "active frame did not return to editor frame")]
+	 [_ (mred:test:menu-select "File" "Close")]
+	 [_ (wait (lambda () (not (eq? frame (mred:test:get-active-frame))))
+		  "active frame remained original frame after File|Close")]
+	 [_ (mred:test:button-push "Close Anyway")]
+	 [_ (wait-pending)]
+	 
+	 [_ (unless (mred:get-preference 'mred:autosaving-on?)
+	      (error 'autosave "autosaving preference turned off. Turn back on (with preferences dialog)"))]
+	 [tmp-file (build-path dir "tmp.ss")]
+	 [backup-file (build-path dir "#tmp.ss#1#")]
+	 [_ (call-with-output-file tmp-file
+	      (lambda (port) (display "12" port))
+	      'truncate)]
+	 [_ (when (file-exists? backup-file)
+	      (delete-file backup-file))]
+	 [_ (mred:edit-file tmp-file)]
+	 [_ (wait (lambda () (not (eq? console (mred:test:get-active-frame))))
+		  "after mred:edit-file, the console remained active")]
+	 [frame (mred:test:get-active-frame)]
+	 [_ (mred:test:keystroke #\3)]
+	 [autosave-time (+ 10 (mred:get-preference 'mred:autosave-delay))]
+	 [_ (printf "waiting for autosave timeout (~a secs)~n" autosave-time)]
+	 [_ (sleep autosave-time)]
+	 [_ (printf "finished waiting for autosave timeout~n")]
+	 [_ (unless (file-exists? backup-file)
+	      (error 'autosave "autosave file (~a) not created" backup-file))]
+	 [_ (mred:test:menu-select "File" save-name)]
+	 [_ (wait-pending)]
+	 [_ (when (file-exists? backup-file)
+	      (error 'autosave "autosave file (~a) not deleted after original file saved"))]
+	 [_ (mred:test:menu-select "File" "Close")]
+	 [_ (wait-pending)]
+	 [_ (wait (lambda () (eq? (mred:test:get-active-frame) console))
+		  "focus didn't return to the console after closing autosave test frame")])
+    (printf "test finished~n")))
+
+;
+;  when rewriting, apply this function to: 
+; "New Unit"
+; "Save Definitions"
+;  wx:frame%
diff --git a/collects/tests/mred/gui.ss b/collects/tests/mred/gui.ss
new file mode 100644
index 0000000000..1125a133c5
--- /dev/null
+++ b/collects/tests/mred/gui.ss
@@ -0,0 +1,5 @@
+(let ([f (load-relative "gui-main.ss")])
+  (thread 
+   (lambda ()
+     (f "New" "Save" mred:console-frame%))))
+
diff --git a/collects/tests/mred/imred.ss b/collects/tests/mred/imred.ss
new file mode 100644
index 0000000000..f7bda4aeaf
--- /dev/null
+++ b/collects/tests/mred/imred.ss
@@ -0,0 +1,70 @@
+(define make-invokable-unit
+  (lambda (application)
+    (compound-unit/sig (import)
+      (link [wx : wx^ (wx@)]
+	    [core : mzlib:core^ (mzlib:core@)]
+	    [mred : mred^ ((require-library "linkwx.ss" "mred") core wx)]
+	    [application : () (application mred core wx)])
+      (export (unit mred mred2)))))
+
+(define (go flags)
+  (define die? #f)
+  (define my-app
+    (unit/sig ()
+     (import mred^ 
+	     mzlib:core^
+	     [wx : wx^])
+     
+     (define app-name "Tester")
+     (define console (if (memq 'console flags)
+			 (make-object console-frame%)
+			 #f))
+     (define eval-string pretty-print@:pretty-print)
+     (when (memq 'thread flags)
+	   (let ([s (make-semaphore 1)]
+		 [s2 (make-semaphore 0)]
+		 [done (make-semaphore 0)])
+	     ; Use of semaphore-callback insures that thread is a child
+	     ; of the eventspace
+	     (semaphore-callback s
+				 (lambda ()
+				   (semaphore-post done)
+				   (thread (lambda ()
+					     (let loop ()
+					       (sleep 1)
+					       (loop))))
+				   (when (begin0
+					  die?
+					  (set! die? (not die?)))
+				       (kill-thread (current-thread))))) ; kills handler thread
+	     ; Add another callback that we know will not get triggered
+	     (semaphore-callback s2 void)
+	     (wx:yield done)))
+     (when (memq 'eventspace flags)
+	   (let ([e (wx:make-eventspace)])
+	     (parameterize ([wx:current-eventspace e])
+		(send (make-object wx:frame% null "Testing" -1 -1 100 100)
+		      show #t))))
+     (unless (memq 'force flags)
+	     (run-exit-callbacks))))
+  
+  (let loop ()
+    (collect-garbage)
+    (collect-garbage)
+    (wx:yield) (sleep) (wx:yield) (sleep)
+    (wx:yield) (sleep) (wx:yield) (sleep)
+    (wx:yield) (sleep) (wx:yield) (sleep)
+    (wx:yield) (sleep) (wx:yield) (sleep)
+    (wx:yield) (sleep) (wx:yield) (sleep)
+    (dump-memory-stats)
+    (let ([custodian (make-custodian)])
+      (parameterize ([current-custodian custodian]
+		     [wx:current-eventspace 
+		      (if (memq 'force flags)
+			  (wx:make-eventspace)
+			  (wx:current-eventspace))])
+	  (invoke-unit/sig
+	   (make-invokable-unit my-app)))
+      (when (memq 'force flags)
+	    (custodian-shutdown-all custodian)))
+    (loop)))
diff --git a/collects/tests/mred/item.ss b/collects/tests/mred/item.ss
new file mode 100644
index 0000000000..b678d22051
--- /dev/null
+++ b/collects/tests/mred/item.ss
@@ -0,0 +1,2276 @@
+
+(require (lib "class.ss")
+	 (lib "class100.ss")
+	 (lib "etc.ss"))
+
+(define my-txt #f)
+(define my-lb #f)
+(define noisy? #f)
+
+(define mdi-frame #f)
+(define (mdi)
+  (set! mdi-frame (make-object frame% "Item Test" #f
+			       #f #f #f #f
+			       '(mdi-parent)))
+  (send mdi-frame maximize #t)
+  (send mdi-frame show #t))
+
+(define default-parent-frame #f)
+(define (parent-frame)
+  (set! default-parent-frame (make-object frame% "Item Test Parent" #f
+			       100 100))
+  (send default-parent-frame show #t))
+
+(when (namespace-variable-value 'mdi? #t (lambda () #f))
+  (mdi))
+
+(define (add-frame-style style)
+  (let* ([style (if use-metal?
+		    (cons 'metal style)
+		    style)]
+	 [style (if float-frame?
+		    (cons 'float style)
+		    style)]
+	 [style (if no-caption?
+		    (cons 'no-caption style)
+		    style)])
+    style))
+
+(define make-frame
+  (opt-lambda (% name [parent #f] [x #f] [y #f] [w #f] [h #f] [style '()])
+    (make-object % name
+		 (or parent mdi-frame default-parent-frame)
+		 x y w h
+		 (if mdi-frame
+		     (cons 'mdi-child style)
+		     (add-frame-style style)))))
+
+(define special-font (send the-font-list find-or-create-font
+			   20 'decorative 
+			   'normal 'bold
+			   #f))
+(define ($ font) (or font normal-control-font))
+
+(define (make-h&s cp f)
+  (make-object button% "Hide and Show" cp
+	       (lambda (b e) (send f show #f) (send f show #t))))
+
+(define (add-hide name w cp)
+  (let ([c (make-object check-box% (format "Show ~a" name) cp
+			(lambda (c e) (send w show (send c get-value))))])
+    (send c set-value #t)))
+
+(define (add-disable name w ep)
+  (let ([c (make-object check-box% (format "Enable ~a" name) ep
+			(lambda (c e) (send w enable (send c get-value))))])
+    (send c set-value (send w is-enabled?))))
+
+(define (add-disable-radio name w i ep)
+  (let ([c (make-object check-box% (format "Enable ~a" name) ep
+			(lambda (c e) (send w enable i (send c get-value))))])
+    (send c set-value #t)))
+
+(define (add-change-label name w lp orig other)
+  (make-object button% (format "Relabel ~a" name) lp
+	       (let ([orig-name (if orig orig (send w get-label))]
+		     [changed? #f])
+		 (lambda (b e)
+		   (if changed?
+		       (unless (null? orig-name)
+			 (send w set-label orig-name))
+		       (send w set-label other))
+		   (set! changed? (not changed?))))))
+
+(define (add-focus-note frame panel)
+  (define m (make-object message% "focus: ??????????????????????????????" panel))
+  (send
+   (make-object
+    (class100-asi timer%
+      (inherit start)
+      (override
+	[notify
+	 (lambda ()
+	   (when (send frame is-shown?)
+	     (send m set-label
+		   (let* ([w (with-handlers ([void (lambda (x) #f)])
+			       (let ([f (get-top-level-focus-window)])
+				 (and f (send f get-focus-window))))]
+			  [l (and w (send w get-label))])
+		     (let ([s (format "focus: ~a ~a" (or l "") w)])
+		       (substring s 0 (min 200 (string-length s))))))
+	     (start 1000 #t)))])))
+   start 1000 #t))
+
+(define (add-pre-note frame panel)
+  (define m (make-object message% "pre: ??????????????????????????????" panel))
+  (define cm (make-object check-box% "Drop Mouse Events" panel void))
+  (define ck (make-object check-box% "Drop Key Events" panel void))
+  (lambda (win e)
+    (let ([m? (is-a? e mouse-event%)])
+      (send m set-label
+	    (let ([s (format "pre: ~a ~a ~a,~a"
+			     (if m? "mouse" "key")
+			     (let ([l (send win get-label)])
+			       (if (not l)
+				   win
+				   l))
+			     (send e get-x)
+			     (send e get-y))])
+	      (substring s 0 (min 200 (string-length s)))))
+      (and (not (or (eq? win cm) (eq? win ck)))
+	   (or (and m? (send cm get-value))
+	       (and (not m?) (send ck get-value)))))))
+
+(define (add-enter/leave-note frame panel)
+  (define m (make-object message% "enter: ??????????????????????????????" panel))
+  (lambda (win e)
+    (when (memq (send e get-event-type) '(enter leave))
+      (let ([s (format "~a: ~a"
+		    (send e get-event-type)
+		    (let ([l (send win get-label)])
+		      (if (not l)
+			  win
+			  l)))])
+	(when noisy? (printf "~a~n" s))
+	(send m set-label (substring s 0 (min 200 (string-length s))))))))
+
+(define (add-click-intercept frame panel)
+  (define cp (make-object check-box% "Popup on Click" panel void))
+  (lambda (win e)
+    (if (and (send e button-down?)
+	     (not (eq? cp win))
+	     (send cp get-value))
+	(let ([m (make-object popup-menu%)])
+	  (make-object menu-item% (format "Click on ~a" win)
+		       m (lambda (i e)
+			   (unless (eq? (send m get-popup-target) win)
+			     (printf "Wrong owner!~n"))))
+	  (send win popup-menu m 
+		(inexact->exact (send e get-x))
+		(inexact->exact (send e get-y)))
+	  #t)
+	#f)))
+
+(define (add-cursors frame panel ctls)
+  (let ([old #f]
+	[f-old #f]
+	[bc (make-object cursor% 'bullseye)]
+	[cc (make-object cursor% 'cross)])
+    (make-object check-box% "Control Bullseye Cursors" panel
+		 (lambda (c e)
+		   (printf "~a~n" e)
+		   (if (send c get-value)
+		       (set! old 
+			     (map (lambda (b) 
+				    (begin0
+				     (send b get-cursor)
+				     (send b set-cursor bc)))
+				  ctls))
+		       (map (lambda (b c) (send b set-cursor c))
+			    ctls old))))
+    (make-object check-box% "Frame Cross Cursor" panel
+		 (lambda (c e)
+		   (if (send c get-value)
+		       (begin
+			 (set! f-old (send frame get-cursor))
+			 (send frame set-cursor cc))
+		       (send frame set-cursor f-old))))
+    (make-object check-box% "Busy Cursor" panel
+		 (lambda (c e)
+		   (if (send c get-value)
+		       (begin-busy-cursor)
+		       (end-busy-cursor))))))
+		       
+(define OTHER-LABEL "XXXXXXXXXXXXXXXXXXXXXX")
+
+(define-values (icons-path local-path)
+  (let ([d (current-load-relative-directory)])
+    (values
+     (lambda (n)
+       (build-path (collection-path "icons") n))
+     (lambda (n)
+       (build-path d n)))))
+
+(define on-demand-menu-item%
+  (class100 menu-item% (-name . args)
+    (private-field
+     [name -name])
+    (override
+      [on-demand
+       (lambda ()
+	 (printf "Menu item ~a demanded~n" name))])
+    (sequence
+      (apply super-init name args))))
+
+(define popup-test-canvas%
+  (class100 canvas% (-objects -names . args)
+    (inherit popup-menu get-dc refresh)
+    (private-field
+      [objects -objects]
+      [names -names]
+      [tab-in? #f]
+      [last-m null]
+      [last-choice #f])
+    (override
+      [on-paint
+       (lambda ()
+	 (let ([dc (get-dc)])
+	   (send dc clear)
+	   (send dc draw-text "Left: popup hide state" 0 0)
+	   (send dc draw-text "Right: popup previous" 0 20)
+	   (send dc draw-text (format "Last pick: ~s" last-choice) 0 40)
+	   (when tab-in?
+	     (send dc draw-text "Tab in" 0 60))))]
+      [on-event
+       (lambda (e)
+	 (if (send e button-down?)
+	     (let ([x (send e get-x)]
+		   [y (send e get-y)]
+		   [m (if (or (null? last-m)
+			      (send e button-down? 'left)
+			      (send e button-down? 'middle))
+			  (let ([m (make-object popup-menu% "T&itle"
+						(lambda (m e)
+						  (unless (is-a? m popup-menu%)
+						    (error "bad menu object"))
+						  (unless (and (is-a? e control-event%)
+							       (memq (send e get-event-type)
+								     '(menu-popdown menu-popdown-none)))
+						    (error "bad event object"))
+						  (printf "popdown ok~n")))]
+				[make-callback 
+				 (let ([id 0])
+				   (lambda ()
+				     (set! id (add1 id))
+				     (let ([id id])
+				       (lambda (m e)
+					 (set! last-choice id)
+					 (on-paint)))))])
+			    (for-each
+			     (lambda (obj name)
+			       (make-object menu-item%
+					    (string-append
+					     name ": "
+					     (if (send obj is-shown?)
+						 "SHOWN"
+						 "<h i d d e n>"))
+					    m
+					    (make-callback)))
+			     objects names)
+			    (make-object on-demand-menu-item%
+					 "[on-demand hook]"
+					 m
+					 void)
+			    (let mloop ([m m][sub-at-50? #t])
+			      (let ([sm (if (and sub-at-50?
+						 (send e button-down? 'middle))
+					    m
+					    (make-object menu% "Too Tall" m))])
+				(let loop ([n 1])
+				  (unless (= n 101)
+				    (if (and sub-at-50? (= n 50))
+					(let ([m (make-object menu% "Item 50" sm)])
+					  (mloop m #f))
+					(make-object menu-item% (format "Item ~a" n) sm void))
+				    (when (zero? (modulo (- n 5) 10))
+				      (make-object separator-menu-item% sm))
+				    (loop (add1 n))))))
+			    m)
+			  last-m)])
+	       (set! last-m m)
+	       (popup-menu m (inexact->exact x) (inexact->exact y)))))]
+      [on-tab-in (lambda () (set! tab-in? #t) (refresh))]
+      [on-focus (lambda (on?)
+		  (when (and tab-in? (not on?))
+		    (set! tab-in? #f)
+		    (refresh)))])
+    (sequence
+      (apply super-init args))))
+
+(define prev-frame #f)
+
+(define bitmap%
+  (class100 bitmap% args
+    (inherit ok?)
+    (sequence
+      (apply super-init args)
+      (unless (ok?)
+	(printf "bitmap failure: ~s~n" args)))))
+
+(define (active-mixin %)
+  (class100-asi %
+    (private-field
+      [pre-on void]
+      [click-i void]
+      [el void])
+    (rename [super-on-subwindow-event on-subwindow-event]
+	    [super-on-subwindow-char on-subwindow-char])
+    (override [on-subwindow-event (lambda args 
+				    (apply el args)
+				    (or (apply pre-on args)
+					(apply click-i args)
+					(super-on-subwindow-event . args)))]
+	      [on-subwindow-char (lambda args 
+				   (or (apply pre-on args)
+				       (super-on-subwindow-char . args)))]
+	      [on-activate (lambda (on?) (printf "active: ~a~n" on?))]
+	      [on-move (lambda (x y) (printf "moved: ~a ~a~n" x y))]
+	      [on-size (lambda (x y) (printf "sized: ~a ~a~n" x y))])
+    (public [set-info
+	     (lambda (ep)
+	       (set! pre-on (add-pre-note this ep))
+	       (set! click-i (add-click-intercept this ep))
+	       (set! el (add-enter/leave-note this ep)))])))
+
+(define active-frame% (active-mixin frame%))
+(define active-dialog% (active-mixin dialog%))
+
+(define (trace-mixin c%)
+  (class100 c% (-name . args)
+    (private-field [name -name])
+    (override
+      [on-superwindow-show
+       (lambda (on?)
+	 (printf "~a ~a~n" name (if on? "show" "hide")))]
+      [on-superwindow-enable
+       (lambda (on?)
+	 (printf "~a ~a~n" name (if on? "on" "off")))])
+    (sequence
+      (apply super-init name args))))
+
+(define return-bmp 
+  (make-object bitmap% (icons-path "return.xbm") 'xbm))
+(define bb-bmp
+  (make-object bitmap% (icons-path "bb.gif") 'gif))
+(define mred-bmp
+  (make-object bitmap% (icons-path "mred.xbm") 'xbm))
+(define nruter-bmp
+  (make-object bitmap% (local-path "nruter.xbm") 'xbm))
+
+(define (add-label-direction label-h? l)
+  (if (not label-h?)
+      (cons 'vertical-label l)
+      l))
+
+(define (make-ctls ip cp lp add-testers ep radio-h? label-h? null-label? stretchy? alt-inits? font)
+  
+  (define-values (l il)
+    (let ([p (make-object horizontal-panel% ip)])
+      (send p stretchable-width stretchy?)
+      (send p stretchable-height stretchy?)
+      
+      (let ()
+	(define l (make-object (trace-mixin message%) "Messag&\uE9" p null ($ font))) ; \uE9 is e with '
+	(define il (make-object (trace-mixin message%) return-bmp p null ($ font)))
+	
+	(add-testers "Message" l)
+	(add-change-label "Message" l lp #f OTHER-LABEL)
+	
+	(add-testers "Image Message" il)
+	(add-change-label "Image Message" il lp return-bmp nruter-bmp)
+	
+	(values l il))))
+  
+  (define b (make-object (trace-mixin button%)
+			 "H\uE9&llo" ip ; \uE9 is e with '
+			 (lambda (b e)
+			   (send b enable #f)
+			   (sleep/yield 5)
+			   (send b enable #t))
+			 null ($ font)))
+  
+  (define ib (make-object (trace-mixin button%) bb-bmp ip void null ($ font)))
+  
+  ; (define ib2 (make-object button% return-bmp ip void))
+  
+  (define lb (make-object (trace-mixin list-box%)
+			  (if null-label? #f "L\uED&st") ; \uED is i with '
+			  '("Appl\uE9" "Banana" "Coconut & Donuts" "Eclair" "French Fries" "Gatorade" "Huevos Rancheros") ; \uE9 is e with '
+			  ip void
+			  (add-label-direction label-h? '(single))
+			  (if alt-inits? 2 #f)
+			  (or font view-control-font) ($ font)))
+  
+  (define cb (make-object (trace-mixin check-box%) "C&h\u00E9ck" ip void null alt-inits? ($ font))) ; \uE9 is e with '
+  
+  (define icb (make-object (trace-mixin check-box%) mred-bmp ip void null alt-inits? ($ font)))
+  
+  (define rb (make-object (trace-mixin radio-box%)
+			  (if null-label? #f "R&ad\uEDo") ; \uED is i with '
+			  '("F\uEDrst" "Dos" "T&rio")
+			  ip void 
+			  (add-label-direction 
+			   label-h? 
+			   (if radio-h?
+			       '(horizontal)
+			       '(vertical)))
+			  (if alt-inits? 2 0)
+			  ($ font)))
+  
+  (define irb (make-object (trace-mixin radio-box%)
+			   (if null-label? #f "Image Ra&dio")
+			   (list return-bmp nruter-bmp)
+			    ip void 
+			    (add-label-direction 
+			     label-h? 
+			     (if radio-h?
+				 '(horizontal)
+				 '(vertical)))
+			  (if alt-inits? 1 0)
+			  ($ font)))
+  
+  (define ch (make-object (trace-mixin choice%)
+			  (if null-label? #f "Ch&o\u00EDce") ; \uED is i with '
+			  '("Alpha" "Beta" "Gamma" "Delta & R\uE9st") ; \uE9 is e with '
+			  ip void
+			  (add-label-direction label-h? null)
+			  (if alt-inits? 3 0)
+			  ($ font)))
+  
+  (define txt (make-object (trace-mixin text-field%)
+			   (if null-label? #f "T\uE9&xt") ; \uE9 is e with '
+			   ip void
+			   "initial & starting"
+			   (add-label-direction label-h? '(single))
+			   ($ font)))
+  
+  (set! my-txt txt)
+  (set! my-lb lb)
+
+  (add-testers "Button" b)
+  (add-change-label "Button" b lp #f OTHER-LABEL)
+  
+  (add-testers "Image Button" ib)
+  (add-change-label "Image Button" ib lp bb-bmp return-bmp)
+  
+  (add-testers "List" lb)
+  (add-change-label "List" lb lp #f OTHER-LABEL)
+  
+  (add-testers "Checkbox" cb)
+  (add-change-label "Checkbox" cb lp #f OTHER-LABEL)
+  
+  (add-testers "Image Checkbox" icb)
+  (add-change-label "Image Checkbox" icb lp mred-bmp bb-bmp)
+  
+  (add-testers "Radiobox" rb)
+  (add-disable-radio "Radio Item `First'" rb 0 ep)
+  (add-disable-radio "Radio Item `Dos'" rb 1 ep)
+  (add-disable-radio "Radio Item `Trio'" rb 2 ep)
+  (add-change-label "Radiobox" rb lp #f OTHER-LABEL)
+  
+  (add-testers "Image Radiobox" irb)
+  (add-disable-radio "Radio Image Item 1" irb 0 ep)
+  (add-disable-radio "Radio Image Item 2" irb 1 ep)
+  (add-change-label "Image Radiobox" irb lp #f OTHER-LABEL)
+  
+  (add-testers "Choice" ch)
+  (add-change-label "Choice" ch lp #f OTHER-LABEL)
+  
+  (add-testers "Text" txt)
+  (add-change-label "Text" txt lp #f OTHER-LABEL)
+  
+  (let ([items (list l il 
+		     b ib 
+		     lb
+		     cb icb 
+		     rb irb 
+		     ch
+		     txt)]
+	[names (list "label" "image label"
+		     "button" "image button"
+		     "list box"
+		     "checkbox" "image checkbox"
+		     "radio box" "image radiobox"
+		     "choice"
+		     "text")])
+    (make-object choice%
+		 "Set Focus"
+		 (cons "..." names)
+		 lp
+		 (lambda (c e)
+		   (let ([v (send c get-selection)])
+		     (when (positive? v)
+		       (send (list-ref items (sub1 v)) focus)
+		       (send c set-selection 0)))))
+    (cons (make-object popup-test-canvas% 
+		       items
+		       names
+		       cp)
+	  items)))
+
+(define (add-deleted-adds panel l)
+  (define v #f)
+  
+  (make-object choice% "New Deleted"
+	       (list*
+		"..."
+		"*Activate Last*"
+		(map car l))
+	       panel
+	       (lambda (c e)
+		 (let ([i (send c get-selection)])
+		   (send c set-selection 0)
+		   (case i
+		     [(0) (void)]
+		     [(1) (send (send v get-parent) add-child v)]
+		     [else (set! v ((cadr (list-ref l (- i 2)))))])))))
+
+(define (add-big-deleted-adds panel)
+  (add-deleted-adds
+   panel
+   (list (list "Message" (lambda () (instantiate message% ("Hello" panel) [style '(deleted)])))
+	 (list "Bitmap Message" (lambda () (instantiate message% (bb-bmp panel) [style '(deleted)])))
+	 (list "Icon Message" (lambda () (instantiate message% ('app panel) [style '(deleted)])))
+	 (list "Button" (lambda () (instantiate button% ("Hello" panel void) [style '(deleted)])))
+	 (list "Bitmap Button" (lambda () (instantiate button% (bb-bmp panel void) [style '(deleted)])))
+	 (list "Checkbox" (lambda () (instantiate check-box% ("Hello" panel void) [style '(deleted)])))
+	 (list "Bitmap Checkbox" (lambda () (instantiate check-box% (bb-bmp panel void) [style '(deleted)])))
+	 (list "Radio Box" (lambda () (instantiate radio-box% ("Hello" (list "A" "B" "C") panel void) [style '(vertical deleted)])))
+	 (list "Bitmap Radio Box" (lambda () (instantiate radio-box% ("Hello" (list bb-bmp bb-bmp) panel void) [style '(vertical deleted)]))))))
+
+(define (add-med-deleted-adds panel)
+  (add-deleted-adds
+   panel
+   (list (list "Canvas" (lambda () (instantiate canvas% (panel) [style '(deleted)])))
+	 (list "Editor Canvas" (lambda () (instantiate editor-canvas% (panel) [style '(deleted)])))
+	 (list "Slider" (lambda () (instantiate slider% ("Hello" 1 3 panel void) [style '(deleted vertical)])))
+	 (list "Gauge" (lambda () (instantiate gauge% ("Hello" 3 panel) [style '(deleted vertical)])))
+	 (list "Tab Panel" (lambda () (instantiate tab-panel% ('("Hello" "Bye") panel void) [style '(deleted)])))
+	 (list "Group Box Panel" (lambda () (instantiate group-box-panel% ('"Hello" panel) [style '(deleted)])))
+	 (list "Panel" (lambda () (instantiate panel% (panel) [style '(deleted border)]))))))
+
+(define use-dialogs? #f)
+(define use-metal? #f)
+(define float-frame? #f)
+(define no-caption? #f)
+
+(define (big-frame h-radio? v-label? null-label? stretchy? font initially-disabled? alternate-init?)
+  (define f (make-frame (if use-dialogs?
+			    active-dialog%
+			    active-frame%)
+			"T\uE9ster")) ; \uE9 is e with '
+  
+  (define hp (make-object horizontal-panel% f))
+  
+  (define ip (make-object vertical-panel% hp))
+  (define cp (make-object vertical-panel% hp))
+  (define ep (make-object vertical-panel% hp))
+  (define lp (make-object vertical-panel% hp))
+  
+  (define (basic-add-testers name w)
+    (add-hide name w cp)
+    (add-disable name w ep))
+  
+  (define add-testers
+    (if stretchy?
+	(lambda (name control)
+	  (send control stretchable-width #t)
+	  (send control stretchable-height #t)
+	  (basic-add-testers name control))
+	basic-add-testers))
+  
+  (define fp (make-object vertical-panel% ip))
+  
+  (define tp 
+    (if #f
+	(make-object group-box-panel% "Sub" fp null (or font small-control-font))
+	(make-object tab-panel% '("Sub" "Panel") fp void '(no-border) ($ font))))
+
+  (when initially-disabled?
+    (send tp enable #f))
+    
+  (make-h&s cp f)
+  
+  (add-testers "Sub-panel" fp)
+  
+  (send tp set-label "Sub-sub panel")
+  (add-testers "Sub-sub-panel" tp)
+
+  (let ([ctls (make-ctls tp cp lp add-testers ep h-radio? v-label? null-label? stretchy? alternate-init? font)])
+    (add-focus-note f ep)
+    (send f set-info ep)
+    
+    (add-cursors f lp ctls)
+
+    (add-big-deleted-adds lp))
+
+  (send f show #t)
+  (set! prev-frame f)
+  f)
+
+(define (med-frame plain-slider? label-h? null-label? stretchy? font initially-disabled? alternate-init?)
+  (define f2 (make-frame (if use-dialogs?
+			    active-dialog%
+			    active-frame%)
+			 "Tester2"))
+
+  (define hp2 (make-object horizontal-panel% f2))
+  
+  (define ip2-0 (make-object vertical-panel% hp2))
+  (define cp2 (make-object vertical-panel% hp2))
+  (define ep2 (make-object vertical-panel% hp2))
+  (define lp2 (make-object vertical-panel% hp2))
+  
+  (define (basic-add-testers2 name w)
+    (add-hide name w cp2)
+    (add-disable name w ep2))
+  
+  (define add-testers2
+    (if stretchy?
+	(lambda (name control)
+	  (send control stretchable-width #t)
+	  (send control stretchable-height #t)
+	  (basic-add-testers2 name control))
+	basic-add-testers2))
+
+  (define fp2 (make-object vertical-panel% ip2-0))
+  (define ip2 (make-object group-box-panel% "Sub" fp2))
+
+  (when initially-disabled?
+    (send ip2 enable #f))
+
+  (make-h&s cp2 f2)
+  
+  (add-testers2 "Sub-panel" fp2)
+  (send ip2 set-label "Sub-sub panel")
+  (add-testers2 "Sub-sub-panel" ip2)
+  
+  (make-object text-field% #f ip2 void "start focus here")
+
+  (when prev-frame
+    (add-disable "Previous Tester Frame" prev-frame ep2))
+  
+  (let ()
+    (define co
+      (make-object combo-field% "Greet:" '("Hola" "Ni Hao") ip2 void "hello" null ($ font)))
+
+    (define sh (make-object slider% 
+			    (if null-label? #f "H S&lid\uE9r") 0 10 ip2
+			    (lambda (s e)
+			      (send gh set-value (* 10 (send sh get-value))))
+			    5
+			    (add-label-direction 
+			     label-h? 
+			     (if plain-slider? '(horizontal plain) '(horizontal)))
+			    ($ font)))
+    
+    (define sv (make-object slider% 
+			    (if null-label? #f "V Sl&id\uE9r") 0 10 ip2 
+			    (lambda (s e)
+			      (send gv set-value (* 10 (send sv get-value))))
+			    5
+			    (add-label-direction 
+			     label-h? 
+			     (if plain-slider? '(vertical plain) '(vertical)))
+			    ($ font)))
+    
+    (define gh (make-object gauge% 
+			    (if null-label? #f "H G&aug\uE9") 100 ip2
+			    (add-label-direction 
+			     label-h? 
+			     '(horizontal))
+			    ($ font)))
+    
+    (define gv (make-object gauge% 
+			    (if null-label? #f "V Ga&ug\uE9") 100 ip2
+			    (add-label-direction 
+			     label-h? 
+			     '(vertical))
+			    ($ font)))
+    
+    (define txt (make-object text-field% 
+			     (if null-label? #f "T&ext \u7238") ; \u7238 is Chinese "father"
+			     ip2 void 
+			     "initial & starting"
+			     (add-label-direction 
+			      label-h? 
+			      '(multiple))
+			     ($ font)))
+
+    (define tab (make-object tab-panel% 
+			     '("Appl\uE9" "B&anana") ip2 void
+			     null
+			     ($ font)))
+
+    (define grp (make-object group-box-panel% 
+			     "Group\uE9" ip2
+			     null (or font small-control-font)))
+
+    (make-object button% "OK" tab void)
+    (make-object button% "Cancel" grp void)
+
+    (add-testers2 "Combo" co)
+    (add-testers2 "Horiz Slider" sh)
+    (add-testers2 "Vert Slider" sv)
+    (add-testers2 "Horiz Gauge" gh)
+    (add-testers2 "Vert Gauge" gv)
+    ; (add-testers2 "Text Message" cmt)
+    ; (add-testers2 "Image Message" cmi)
+    (add-testers2 "Text" txt)
+    (add-testers2 "Tab" tab)
+    (add-testers2 "Group" grp)
+    
+    (add-change-label "Combo" co lp2 #f OTHER-LABEL)
+    (add-change-label "Horiz Slider" sh lp2 #f OTHER-LABEL)
+    (add-change-label "Vert Slider" sv lp2 #f OTHER-LABEL)
+    (add-change-label "Horiz Gauge" gh lp2 #f OTHER-LABEL)
+    (add-change-label "Vert Gauge" gv lp2 #f OTHER-LABEL)
+    (add-change-label "Text" txt lp2 #f OTHER-LABEL)
+    (add-change-label "Group" grp lp2 #f OTHER-LABEL)
+    
+    (let* ([items (list co
+			sh sv
+			gh gv
+			; cmt cmi
+			txt
+			tab grp)]
+	   [canvas  (make-object popup-test-canvas% 
+				 items
+				 (list "h slider" "v slider"
+				       "v gauge" "v gauge"
+				       ; "text msg" "image msg"
+				       "text"
+				       "tab" "group")
+				 cp2 '(hscroll vscroll))])
+      (send canvas accept-tab-focus #t)
+      (send canvas init-auto-scrollbars 300 300 0.0 0.0)
+      (add-disable "Canvas" canvas ep2)
+
+      (add-focus-note f2 ep2)
+      (send f2 set-info ep2)
+      
+      (add-cursors f2 lp2 (cons canvas items))
+
+      (add-med-deleted-adds lp2))
+
+    (unless use-dialogs?
+      (send f2 create-status-line)
+      (send f2 set-status-text "This is the status line"))
+    (send f2 show #t)
+    (set! prev-frame f2)
+    f2))
+
+; Need: check, check-test, and enable via menubar
+; All operations on Submenus
+(define f%
+  (class100 frame% args
+    (private-field
+      ADD-APPLE
+      ADD-BANANA
+      ADD-COCONUT
+      DELETE-APPLE
+      DELETE-EXTRA-BANANA
+      DELETE-BANANA
+      DELETE-COCONUT-0
+      DELETE-COCONUT
+      DELETE-COCONUT-2
+      COCONUT-ID
+      DELETE-ONCE
+      APPLE-CHECK-ID
+      CHINESE)
+    (private-field
+      menu-bar
+      main-menu
+      apple-menu
+      banana-menu
+      coconut-menu
+      baseball-ids
+      hockey-ids
+      enable-item)
+    (sequence (apply super-init args))
+    (public
+      [make-menu-bar
+       (lambda ()
+	 (let* ([mb (make-object menu-bar% this)]
+		[menu (make-object menu% "&Tester" mb)]
+		[new (case-lambda 
+		      [(l help parent) (make-object menu-item% l parent (lambda (o e) (callback o e)) #f help)]
+		      [(l help) (make-object menu-item% l menu (lambda (o e) (callback o e)) #f help)]
+		      [(l) (make-object menu-item% l menu (lambda (o e) (callback o e)))])]
+		[sep (lambda () (make-object separator-menu-item% menu))])
+	   (set! menu-bar mb)
+	   (set! main-menu menu)
+
+	   (set! ADD-APPLE (new "Add Apple" "Adds the Apple menu"))
+	   (set! ADD-BANANA (new "Add Banana"))
+	   (set! ADD-COCONUT (new "Add Coconut"))
+	   
+	   (make-object on-demand-menu-item% "Append Donut" menu
+			(lambda (m e) 
+			  (make-object menu-item% "Donut" apple-menu void)))
+	   (sep)
+	   (set! DELETE-COCONUT-0 (new "Delete Coconut"))
+	   (make-object menu-item% "Delete Apple" menu
+			(lambda (m e) 
+			  (send apple-menu delete)
+			  (set! apple-installed? #f)))
+	   
+	   (sep)
+	   (set! enable-item
+		 (make-object checkable-menu-item% "Apple Once Disabled" menu
+			      (lambda (m e)
+				(send DELETE-ONCE enable
+				      (not (send enable-item is-checked?))))))
+	   
+	   (let ([mk-enable (lambda (on?)
+			      (lambda (m e)
+				(let ([l (send menu-bar get-items)])
+				  (unless (null? (cdr l))
+				    (send (cadr l) enable on?)))))])
+	     (make-object menu-item% "Disable Second" menu (mk-enable #f))
+	     (make-object menu-item% "Enable Second" menu (mk-enable #t)))
+
+	   (set! CHINESE (make-object menu-item% "Chinese: \U7238" menu void))
+	   
+	   (let ([make-menu
+		  (opt-lambda (title parent help-string)
+		    (let ([m (make-object menu% title parent help-string)])
+		      (send m delete)
+		      m))])
+	     (set! apple-menu (make-menu "Apple" mb #f))
+	     (set! banana-menu (make-menu "Banana" mb #f))
+	     (set! coconut-menu (make-menu "Coconut" apple-menu "Submenu")))
+	   
+	   (set! COCONUT-ID coconut-menu)
+
+	   (set! DELETE-ONCE (new "Delete Once" #f apple-menu))
+	   (set! DELETE-APPLE (new "Delete Apple" "Deletes the Apple menu" apple-menu))
+	   (set! APPLE-CHECK-ID (make-object checkable-menu-item% "Checkable" apple-menu void))
+
+	   (set! DELETE-BANANA (new "Delete Banana" #f banana-menu))
+	   (set! DELETE-EXTRA-BANANA (new "Delete First Banana Item" #f banana-menu))
+
+	   (set! DELETE-COCONUT (new "Delete Coconut" #f coconut-menu))
+	   (set! DELETE-COCONUT-2 (new "Delete Coconut By Position" #f coconut-menu))))]
+      
+      [callback
+       (lambda (op ev)
+	 (cond
+	  [(eq? op ADD-APPLE)
+	   (send apple-menu restore)
+	   (set! apple-installed? #t)]
+	  [(eq? op ADD-BANANA)
+	   (send banana-menu restore)]
+	  [(eq? op ADD-COCONUT)
+	   (send coconut-menu restore)]
+	  [(eq? op DELETE-ONCE)
+	   (send DELETE-ONCE delete)]
+	  [(eq? op DELETE-APPLE)
+	   (send apple-menu delete)
+	   (set! apple-installed? #f)]
+	  [(eq? op DELETE-BANANA)
+	   (send banana-menu delete)]
+	  [(eq? op DELETE-EXTRA-BANANA)
+	   (send (car (send banana-menu get-items)) delete)]
+	  [(or (eq? op DELETE-COCONUT) (eq? op DELETE-COCONUT-0))
+	   (send COCONUT-ID delete)]
+	  [(eq? op DELETE-COCONUT-2)
+	   (send (list-ref (send apple-menu get-items) 3) delete)]))])
+    (private-field
+	[mfp (make-object vertical-panel% this)]
+	[mc (make-object editor-canvas% mfp)]
+	[restp (make-object vertical-panel% mfp)]
+	[sbp (make-object horizontal-panel% restp)]
+	[mfbp (make-object horizontal-panel% restp)]
+	[lblp (make-object horizontal-panel% restp)]
+	[badp (make-object horizontal-panel% restp)]
+	[e (make-object text%)])
+      (sequence
+	(send restp stretchable-height #f)
+	(send mc min-height 250)
+	(send mc set-editor e)
+	(send e load-file (local-path "menu-steps.txt")))
+      (public
+	[make-test-button
+	 (lambda (name pnl menu id)
+	   (make-object button%
+			(format "Test ~a" name) pnl 
+			(lambda (b e)
+			  (message-box
+			   "Checked?"
+			   (if (send id is-checked?)
+			       "yes"
+			       "no")))))]
+	[compare
+	 (lambda (expect v kind)
+	   (unless (or (and (string? expect) (string? v)
+			    (string=? expect v))
+		       (eq? expect v))
+	     (error 'test-compare "~a mismatch: ~s != ~s" kind expect v)))]
+	[check-parent
+	 (lambda (menu id)
+	   (unless use-menubar?
+	     (unless (eq? (send id get-parent) menu)
+	       (error 'check-parent "parent mismatch: for ~a, ~a != ~a"
+		      (send id get-label)
+		      (send menu get-label)
+		      (send (send (send id get-parent) get-item) get-label)))))]
+	[label-test
+	 (lambda (menu id expect)
+	   (check-parent menu id)
+	   (let ([v (send id get-label)])
+	     (compare expect v "label")))]
+	[top-label-test
+	 (lambda (pos expect)
+	   (let ([i (send menu-bar get-items)])
+	     (and (> (length i) pos)
+		  (let ([v (send (list-ref i pos) get-label)])
+		    (compare expect v "top label")))))]
+	[help-string-test
+	 (lambda (menu id expect)
+	   (check-parent menu id)
+	   (let ([v (send id get-help-string)])
+	     (compare expect v "help string")))]
+	[find-test
+	 (lambda (menu title expect string)
+	   (letrec ([find
+		     (lambda (menu str)
+		       (let ([items (send menu get-items)])
+			 (ormap (lambda (i)
+				  (and (is-a? i labelled-menu-item<%>)
+				       (equal? (send i get-plain-label) str)
+				       i))
+				items)))]
+		    [find-item
+		     (lambda (menu str)
+		       (or (find menu str)
+			   (let ([items (send menu get-items)])
+			     (ormap (lambda (i)
+				      (and (is-a? i menu%)
+					   (find-item i str)))
+				    items))))]
+		    [v (if use-menubar? 
+			   (let ([item (find menu-bar title)])
+			     (if item
+				 (find-item item string)
+				 -1))
+			   (find-item menu string))])
+	     (compare expect v (format "label search: ~a" string))))]
+	[tell-ok
+	 (lambda ()
+	   (printf "ok~n"))])
+      (private-field
+	[temp-labels? #f]
+	[use-menubar? #f]
+	[apple-installed? #f])
+      (public
+	[via (lambda (menu) (if use-menubar? menu-bar menu))]
+	[tmp-pick (lambda (a b) (if temp-labels? a b))]
+	[apple-pick (lambda (x a b) (if (and use-menubar? (not apple-installed?))
+					x
+					(tmp-pick a b)))])
+      (sequence
+	(make-menu-bar)
+
+	(send apple-menu restore)
+
+	(make-object button%
+		     "Delete Tester" sbp 
+		     (lambda args
+		       (send main-menu delete)))
+	(make-object button%
+		     "Delete First Menu" sbp
+		     (lambda args
+		       (send (car (send menu-bar get-items)) delete)))
+	(make-object button%
+		     "Add Tester" sbp
+		     (lambda args
+		       (send main-menu restore)))
+	(make-object button%
+		     "Add Delete Banana" sbp
+		     (lambda args
+		       (send DELETE-BANANA restore)))
+	(make-object button%
+		     "Counts" sbp
+		     (lambda args
+		       (message-box
+			"Counts"
+			(format "MB: ~a; T: ~a; A: ~a; B: ~a"
+				(length (send menu-bar get-items))
+				(length (send main-menu get-items))
+				(length (send apple-menu get-items))
+				(length (send banana-menu get-items))))))
+
+	(make-test-button "Apple Item" mfbp apple-menu APPLE-CHECK-ID)
+	(make-object button%
+		     "Check in Apple" mfbp
+		     (lambda args
+		       (send APPLE-CHECK-ID check #t)))
+	(make-object button%
+		     "Toggle Menubar Enable" mfbp
+		     (lambda args
+		       (send menu-bar enable (not (send menu-bar is-enabled?)))))
+	(make-object button%
+		     "Toggle Apple Enable" mfbp
+		     (lambda args
+		       (send apple-menu enable (not (send apple-menu is-enabled?)))))
+	
+	(make-object button%
+		     "Test Labels" lblp 
+		     (lambda args
+		       (label-test (via main-menu) ADD-APPLE (tmp-pick "Apple Adder" "Add Apple"))
+		       (help-string-test (via main-menu) ADD-APPLE (tmp-pick "ADDER" "Adds the Apple menu"))
+		       (label-test (via apple-menu) DELETE-APPLE (apple-pick #f "Apple Deleter" "Delete Apple"))
+		       (help-string-test (via apple-menu) DELETE-APPLE (apple-pick #f "DELETER"
+										   "Deletes the Apple menu"))
+		       (label-test (via apple-menu) COCONUT-ID (apple-pick #f "Coconut!" "Coconut"))
+		       (help-string-test (via apple-menu) COCONUT-ID (apple-pick #f "SUBMENU" "Submenu"))
+		       (label-test (via coconut-menu) DELETE-COCONUT (apple-pick #f "Coconut Deleter" "Delete Coconut")) ; submenu test
+		       (help-string-test (via coconut-menu) DELETE-COCONUT (apple-pick #f "CDELETER" #f))
+		       (top-label-test 0 (if temp-labels? "Hi" "&Tester"))
+		       (top-label-test 1 (if apple-installed? "Apple" #f))
+		       (tell-ok)))
+	(make-object button%
+		     "Find Labels" lblp
+		     (lambda args
+		       (find-test main-menu (tmp-pick "Hi" "&Tester")
+				  ADD-APPLE (tmp-pick "Apple Adder" "Add Apple"))
+		       (find-test apple-menu "Apple" (apple-pick -1 DELETE-APPLE DELETE-APPLE)
+				  (tmp-pick "Apple Deleter" "Delete Apple"))
+		       (find-test apple-menu "Apple" (apple-pick -1 COCONUT-ID COCONUT-ID)
+				  (tmp-pick "Coconut!" "Coconut"))
+		       (find-test apple-menu "Apple" (apple-pick -1 DELETE-COCONUT DELETE-COCONUT)
+				  (tmp-pick "Coconut Deleter" "Delete Coconut"))
+		       (tell-ok)))
+	(make-object button%
+		     "Toggle Labels" lblp
+		     (lambda args
+		       (set! temp-labels? (not temp-labels?))
+		       (let ([menu (via main-menu)])
+			 (send ADD-APPLE set-label (tmp-pick "Apple Adder" "Add Apple"))
+			 (send DELETE-APPLE set-label (tmp-pick "Apple Deleter" "Delete Apple"))
+			 (send COCONUT-ID set-label (tmp-pick "Coconut!" "Coconut"))
+			 (send DELETE-COCONUT set-label (tmp-pick "Coconut Deleter" "Delete Coconut"))
+			 (send ADD-APPLE set-help-string (tmp-pick "ADDER" "Adds the Apple menu"))
+			 (send DELETE-APPLE set-help-string (tmp-pick "DELETER" "Deletes the Apple menu"))
+			 (send COCONUT-ID set-help-string (tmp-pick "SUBMENU" "Submenu"))
+			 (send DELETE-COCONUT set-help-string (tmp-pick "CDELETER" #f))
+			 (send CHINESE set-label (tmp-pick "Chinese: \U7239" "Chinese: \U7238"))
+			 (send CHINESE set-shortcut (tmp-pick #\C #\K))
+			 (send main-menu set-label (if temp-labels? "Hi" "&Tester")))))
+	(letrec ([by-bar (make-object check-box%
+				      "Via Menubar" lblp
+				      (lambda args
+					(set! use-menubar? (send by-bar get-value))))])
+	  by-bar)
+	
+	#f)))
+
+(define (menu-frame)
+  (define mf (make-frame f% "Menu Test"))
+  (set! prev-frame mf)
+  (send mf show #t)
+  mf)
+
+(define (panel-frame)
+  (define make-p% 
+    (lambda (panel%)
+      (class100 panel% (parent)
+	(override
+	  [container-size
+	   (lambda (l)
+	     (values (apply + (map car l))
+		     (apply + (map cadr l))))]
+	  [place-children
+	   (lambda (l w h)
+	     (let-values ([(mw mh) (container-size l)])
+	       (let* ([num-x-stretch (apply + (map (lambda (x) (if (caddr x) 1 0)) l))]
+		      [num-y-stretch (apply + (map (lambda (x) (if (cadddr x) 1 0)) l))]
+		      [dx (floor (/ (- w mw) num-x-stretch))]
+		      [dy (floor (/ (- h mh) num-y-stretch))])
+		 (let loop ([l l][r null][x 0][y 0])
+		   (if (null? l)
+		       (reverse r)
+		       (let ([w (+ (caar l) (if (caddr (car l)) dx 0))]
+			     [h (+ (cadar l) (if (cadddr (car l)) dy 0))])
+			 (loop (cdr l)
+			       (cons (list x y w h) r)
+			       (+ x w) (+ y h))))))))])
+	(sequence (super-init parent)))))
+  (define f (make-frame frame% "Panel Tests"))
+  (define h (make-object horizontal-panel% f))
+  (define kind (begin
+		 (send h set-alignment 'center 'top)
+		 (make-object radio-box%
+			      "Kind"
+			      '("Panel" "Pane")
+			      h
+			      void)))
+  (define direction (make-object radio-box%
+				 "Direction"
+				 '("Horionztal" "Vertical" "Diagonal" "None")
+				 h
+				 void))
+  (define h-align (make-object radio-box%
+			       "H Alignment"
+			       '("Left" "Center" "Right")
+			       h
+			       void))
+  (define v-align (make-object radio-box%
+			       "V Alignment"
+			       '("Top" "Center" "Bottom")
+			       h
+			       void))
+  (make-object button% "Make Container" f
+	       (lambda (b e) (do-panel-frame
+			      (let ([kind (send kind get-selection)]
+				    [direction (send direction get-selection)])
+				(case kind
+				  [(0) (case direction
+					 [(0) horizontal-panel%]
+					 [(1) vertical-panel%]
+					 [(2) (make-p% panel%)]
+					 [else panel%])]
+				  [(1) (case direction
+					 [(0) horizontal-pane%]
+					 [(1) vertical-pane%]
+					 [(2) (make-p% pane%)]
+					 [else pane%])]))
+			      (case (send h-align get-selection)
+				[(0) 'left]
+				[(1) 'center]
+				[(2) 'right])
+			      (case (send v-align get-selection)
+				[(0) 'top]
+				[(1) 'center]
+				[(2) 'bottom]))))
+  (send f show #t))
+
+(define (do-panel-frame p% va ha)
+  (define f (make-frame frame% "Container Test"))
+  (define p (make-object p% f))
+  (define b (make-object button% "Add List or Bad" p
+			 (lambda (b e)
+			   (send p add-child 
+				 (if (send c get-value)
+				     m1
+				     l)))))
+  (define c (make-object check-box% "Remove List" p
+			 (lambda (c e)
+			   (if (send c get-value)
+			       (send p delete-child l)
+			       (send p add-child l)))))
+  (define l (make-object list-box% "List Box" '("A" "B" "C") p
+			 (lambda (l e)
+			   (if (eq? (send e get-event-type) 'list-box)
+			       (send p get-children)
+			       (send p change-children reverse)))))
+  (define p2 (make-object vertical-panel% p '(border)))
+  (define m1 (make-object message% "1" p2))
+  (define m2 (make-object message% "2" p2))
+  (send p set-alignment va ha)
+  (send f show #t))
+
+(define (check-callback-event orig got e types silent?)
+  (unless (eq? orig got)
+    (error "object not the same"))
+  (unless (is-a? e control-event%)
+    (error "bad event object"))
+  (let ([type (send e get-event-type)])
+    (unless (memq type types)
+      (error (format "bad event type: ~a" type))))
+  (unless silent?
+    (printf "Callback Ok~n")))
+
+(define (instructions v-panel file)
+  (define c (make-object editor-canvas% v-panel))
+  (define m (make-object text%))
+  (send c set-editor m)
+  (send m load-file (local-path file))
+  (send m lock #t)
+  (send c min-width 520)
+  (send c min-height 200))
+
+(define (open-file file)
+  (define f (make-object frame% file #f 300 300))
+  (instructions f file)
+  (send f show #t))
+
+(define (button-frame frame% style)
+  (define f (make-frame frame% "Button Test"))
+  (define p (make-object vertical-panel% f))
+  (define old-list null)
+  (define commands (list 'button))
+  (define hit? #f)
+  (define b (make-object button%
+			 "Hit Me" p
+			 (lambda (bx e)
+			   (set! hit? #t)
+			   (set! old-list (cons e old-list))
+			   (check-callback-event b bx e commands #f))
+			 style))
+  (define c (make-object button%
+			 "Check" p
+			 (lambda (c e)
+			   (for-each
+			    (lambda (e)
+			      (check-callback-event b b e commands #t))
+			    old-list)
+			   (printf "All Ok~n"))))
+  (define e (make-object button%
+			 "Disable Test" p
+			 (lambda (c e)
+			   (sleep 1)
+			   (set! hit? #f)
+			   (let ([sema (make-semaphore)])
+			     (send b enable #f)
+			     (thread (lambda () (sleep 0.5) (semaphore-post sema)))
+			     (yield sema)
+			     (when hit?
+			       (printf "un-oh~n"))
+			     (send b enable #t)))))
+  (instructions p "button-steps.txt")
+  (send f show #t))
+
+(define (checkbox-frame)
+  (define f (make-frame frame% "Checkbox Test"))
+  (define p f)
+  (define old-list null)
+  (define commands (list 'check-box))
+  (define cb (make-object check-box%
+			  "On" p
+			  (lambda (cx e)
+			    (set! old-list (cons e old-list))
+			    (check-callback-event cb cx e commands #f))))
+  (define t (make-object button%
+			 "Toggle" p
+			 (lambda (t e)
+			   (let ([on? (send cb get-value)])
+			     (send cb set-value (not on?))))))
+  (define t2 (make-object button%
+			  "Simulation Toggle" p
+			  (lambda (t e)
+			    (let ([on? (send cb get-value)]
+				  [e (make-object control-event% 'check-box)])
+			      (send cb set-value (not on?))
+			      (send cb command e)))))
+  (define c (make-object button%
+			 "Check" p
+			 (lambda (c e)
+			   (for-each
+			    (lambda (e)
+			      (check-callback-event cb cb e commands #t))
+			    old-list)
+			   (printf "All Ok~n"))))
+  (instructions p "checkbox-steps.txt")
+  (send f show #t))
+
+(define (radiobox-frame)
+  (define f (make-frame frame% "Radiobox Test"))
+  (define p f)
+  (define old-list null)
+  (define commands (list 'radio-box))
+  (define hp (make-object horizontal-panel% p))
+  (define _ (send hp stretchable-height #f))
+  (define callback (lambda (rb e)
+		     (set! old-list (cons (cons rb e) old-list))
+		     (check-callback-event rb rb e commands #f)))
+  (define rb1-l (list "Singleton"))
+  (define rb1 (make-object radio-box% "&Left" rb1-l hp callback))
+  (define rb2-l (list "First" "Last"))
+  (define rb2 (make-object radio-box% "&Center" rb2-l hp callback))
+  (define rb3-l (list "Top" "Middle" "Bottom"))
+  (define rb3 (make-object radio-box% "&Right" rb3-l hp callback))
+
+  (define rbs (list rb1 rb2 rb3))
+  (define rbls (list rb1-l rb2-l rb3-l))
+  (define normal-sel (lambda (rb p) (send rb set-selection p)))
+  (define simulate-sel (lambda (rb p)
+			 (let ([e (make-object control-event% 'radio-box)])
+			   (send rb set-selection p)
+			   (send rb command e))))
+  (define (mk-err exn?)
+    (lambda (f)
+      (lambda (rb p)
+	(with-handlers ([exn? void])
+	  (f rb p)
+	  (error "no exn raisd")))))
+  (define type-err (mk-err exn:application:type?))
+  (define mismatch-err (mk-err exn:application:mismatch?))
+
+  (define do-sel (lambda (sel n) (for-each (lambda (rb) (sel rb (n rb))) rbs)))
+  (define sel-minus (lambda (sel) (do-sel (type-err sel) (lambda (rb) -1))))
+  (define sel-first (lambda (sel) (do-sel sel (lambda (rb) 0))))
+  (define sel-middle (lambda (sel) (do-sel sel (lambda (rb) (floor (/ (send rb get-number) 2))))))
+  (define sel-last (lambda (sel) (do-sel sel (lambda (rb) (sub1 (send rb get-number))))))
+  (define sel-N (lambda (sel) (do-sel (mismatch-err sel) (lambda (rb) (send rb get-number)))))
+  (define (make-selectors title sel)
+    (define hp2 (make-object horizontal-panel% p))
+    (send hp2 stretchable-height #f)
+    (make-object button% (format "Select -1~a" title) hp2 (lambda (b e) (sel-minus sel)))
+    (make-object button% (format "Select First~a" title) hp2 (lambda (b e) (sel-first sel)))
+    (make-object button% (format "Select Middle ~a" title) hp2 (lambda (b e) (sel-middle sel)))
+    (make-object button% (format "Select Last~a" title) hp2 (lambda (b e) (sel-last sel)))
+    (make-object button% (format "Select N~a" title) hp2 (lambda (b e) (sel-N sel))))
+  (make-selectors "" normal-sel)
+  (make-selectors " by Simulate" simulate-sel)
+  (make-object button% "Check" p
+	       (lambda (c e)
+		 (for-each
+		  (lambda (rb l)
+		    (let loop ([n 0][l l])
+		      (unless (null? l)
+			(let ([a (car l)]
+			      [b (send rb get-item-label n)])
+			  (unless (string=? a b)
+			    (error "item name mismatch: ~s != ~s" a b)))
+			(loop (add1 n) (cdr l)))))
+		  rbs rbls)
+		 (for-each
+		  (lambda (rbe)
+		    (check-callback-event (car rbe) (car rbe) (cdr rbe) commands #t))
+		  old-list)
+		 (printf "All Ok~n")))
+  (instructions p "radiobox-steps.txt")
+  (send f show #t))
+
+(define (choice-or-list-frame list? list-style empty?)
+  (define f (make-frame frame% (if list? "List Test" "Choice Test")))
+  (define p f)
+  (define-values (actual-content actual-user-data)
+    (if empty?
+	(values null null)
+	(values '("Alpha" "Beta" "Gamma")
+		(list #f #f #f))))
+  (define commands 
+    (if list?
+	(list 'list-box 'list-box-dclick)
+	(list 'choice)))
+  (define old-list null)
+  (define multi? (or (memq 'multiple list-style)
+		     (memq 'extended list-style)))
+  (define callback
+    (lambda (cx e)
+      (when (zero? (send c get-number))
+	    (error "Callback for empty choice/list"))
+      (set! old-list (cons e old-list))
+      (cond
+       [(eq? (send e get-event-type) 'list-box-dclick)
+	; double-click
+	(printf "Double-click~n")
+	(unless (send cx get-selection)
+	  (error "no selection for dclick"))]
+       [else
+	; misc multi-selection
+	(printf "Changed: ~a~n" (if list?
+				    (send cx get-selections)
+				    (send cx get-selection)))])
+      (check-callback-event c cx e commands #f)))
+  (define c (if list?
+		(make-object list-box% "Tester" actual-content p callback list-style)
+		(make-object choice% "Tester" actual-content p callback)))
+  (define counter 0)
+  (define append-with-user-data? #f)
+  (define ab (make-object button%
+			  "Append" p
+			  (lambda (b e)
+			    (set! counter (add1 counter))
+			    (let ([naya (format "~aExtra ~a" 
+						(if (= counter 10)
+						    (string-append
+						     "This is a Really Long Named Item That Would Have Used the Short Name, Yes "
+						     "This is a Really Long Named Item That Would Have Used the Short Name ")
+						    "")
+						counter)]
+				  [naya-data (box 0)])
+			      (set! actual-content (append actual-content (list naya)))
+			      (set! actual-user-data (append actual-user-data (list naya-data)))
+			      (if (and list? append-with-user-data?)
+				  (send c append naya naya-data)
+				  (begin
+				    (send c append naya)
+				    (when list?
+					  (send c set-data 
+						(sub1 (send c get-number))
+						naya-data))))
+			      (set! append-with-user-data?
+				    (not append-with-user-data?))))))
+  (define cs (when list? 
+	       (make-object button%
+			    "Visible Indices" p
+			    (lambda (b e)
+			      (printf "top: ~a~nvisible count: ~a~n"
+				      (send c get-first-visible-item)
+				      (send c number-of-visible-items))))))
+  (define cdp (make-object horizontal-panel% p))
+  (define rb (make-object button% "Clear" cdp
+			  (lambda (b e)
+			    (set! actual-content null)
+			    (set! actual-user-data null)
+			    (send c clear))))
+  (define (delete p)
+    (send c delete p)
+    (when (<= 0 p (sub1 (length actual-content)))
+      (if (zero? p)
+	  (begin
+	    (set! actual-content (cdr actual-content))
+	    (set! actual-user-data (cdr actual-user-data)))
+	  (begin
+	    (set-cdr! (list-tail actual-content (sub1 p)) 
+		      (list-tail actual-content (add1 p)))
+	    (set-cdr! (list-tail actual-user-data (sub1 p)) 
+		      (list-tail actual-user-data (add1 p)))))))
+  (define db (if list?
+		 (make-object button%
+			      "Delete" cdp
+			      (lambda (b e)
+				(let ([p (send c get-selection)])
+				  (delete p))))
+		 null))
+  (define dab (if list?
+		  (make-object button%
+			       "Delete Above" cdp
+			       (lambda (b e)
+				 (let ([p (send c get-selection)])
+				   (delete (sub1 p)))))
+		  null))
+  (define dbb (if list?
+		  (make-object button%
+			       "Delete Below" cdp
+			       (lambda (b e)
+				 (let ([p (send c get-selection)])
+				   (delete (add1 p)))))
+		  null))
+  (define setb (if list?
+		   (make-object button%
+				"Reset" cdp
+				(lambda (b e)
+				  (send c set '("Alpha" "Beta" "Gamma"))
+				  (set! actual-content '("Alpha" "Beta" "Gamma"))
+				  (set! actual-user-data (list #f #f #f))))
+		   null))
+  (define sel (if list?
+		  (make-object button%
+			       "Add Select First" cdp
+			       (lambda (b e)
+				 (send c select 0 #t)))
+		  null))
+  (define unsel (if list?
+		    (make-object button%
+				 "Unselect" cdp
+				 (lambda (b e)
+				   (send c select (send c get-selection) #f)))
+		    null))
+  (define change-button-name (if list? 
+                                 (make-object button%
+                                              "Change Name" cdp
+                                              (lambda (b e)
+						(let ([p (send c get-selection)])
+						  (when p
+						    (send c set-string p "New Name")
+						    (set! actual-content
+							  (let loop ([ac actual-content][p p])
+							    (if (zero? p)
+								(cons "New Name" (cdr ac))
+								(cons (car ac)
+								      (loop (cdr ac) (sub1 p))))))))))
+                                 null))
+  (define (make-selectors method mname numerical?)
+    (define p2 (make-object horizontal-panel% p))
+    (send p2 stretchable-height #f)
+    (when numerical?
+	  (make-object button%
+		       (string-append "Select Bad -1" mname) p2
+		       (lambda (b e)
+			 (with-handlers ([exn:application:type? void])
+			   (method -1)
+			   (error "expected a type exception")))))
+    (make-object button%
+		 (string-append "Select First" mname) p2
+		 (lambda (b e)
+		   (method 0)))
+    (make-object button%
+		 (string-append "Select Middle" mname) p2
+		 (lambda (b e)
+		   (method (floor (/ (send c get-number) 2)))))
+    (make-object button%
+		 (string-append  "Select Last" mname) p2
+		 (lambda (b e)
+		   (method (sub1 (send c get-number)))))
+    (make-object button%
+		 (string-append "Select Bad X" mname) p2
+		 (lambda (b e)
+		   (with-handlers ([exn:application:mismatch? void]) 
+		     (method (if numerical?
+				 (send c get-number)
+				 #f))
+		     (error "expected a mismatch exception"))))
+    #f)
+  (define dummy-1 (make-selectors (lambda (v) (send c set-selection v)) "" #t))
+  (define dummy-2 (make-selectors (lambda (p) 
+				    (if p
+					(when (positive? (length actual-content))
+					      (send c set-string-selection 
+						    (list-ref actual-content p)))
+					(send c set-string-selection "nada")))
+				  " by Name"
+				  #f))
+  (define dummy-3 (make-selectors (lambda (p)
+				    (let ([e (make-object control-event% (if list? 'list-box 'choice))])
+				      (send c set-selection p)
+				      (when list? (send c set-first-visible-item p))
+				      (send c command e)))
+				  " by Simulate" #t))
+  (define tb (make-object button%
+			  "Check" p
+			  (lambda (b e)
+			    (let ([c (send c get-number)])
+			      (unless (= c (length actual-content))
+				(error "bad number response")))
+			    (let loop ([n 0][l actual-content][lud actual-user-data])
+			      (unless (null? l)
+				      (let ([s (car l)]
+					    [sud (car lud)]
+					    [sv (send c get-string n)]
+					    [sudv (if list?
+						      (send c get-data n)
+						      #f)])
+					(unless (string=? s sv)
+					  (error "get-string mismatch"))
+					(unless (or (not list?) (eq? sud sudv))
+					  (error 'get-data "mismatch at ~a: ~s != ~s"
+						 n sud sudv))
+					(unless (= n (send c find-string s))
+					  (error "bad find-string result")))
+				      (loop (add1 n) (cdr l) (cdr lud))))
+			    (let ([bad (lambda (exn? i)
+					 (with-handlers ([exn? void])
+					   (send c get-string i)
+					   (error "out-of-bounds: no exn")))])
+			      (bad exn:application:type? -1)
+			      (bad exn:application:mismatch? (send c get-number)))
+			    (unless (not (send c find-string "nada"))
+			      (error "find-string of nada wasn't #f"))
+			    (for-each
+			     (lambda (e)
+			       (check-callback-event c c e commands #t))
+			     old-list)
+			    (printf "content: ~s~n" actual-content)
+			    (when multi?
+			      (printf "selections: ~s~n" (send c get-selections))))))
+  (send c stretchable-width #t)
+  (instructions p "choice-list-steps.txt")
+  (send f show #t))
+
+(define (slider-frame)
+  (define f (make-frame frame% "Slider Test"))
+  (define p (make-object vertical-panel% f))
+  (define old-list null)
+  (define commands (list 'slider))
+  (define s (make-object slider% "Slide Me" -1 11 p
+			 (lambda (sl e)
+			   (check-callback-event s sl e commands #f)
+			   (printf "slid: ~a~n" (send s get-value)))
+			 3))
+  (define c (make-object button% "Check" p
+			 (lambda (c e)
+			   (for-each
+			    (lambda (e)
+			      (check-callback-event s s e commands #t))
+			    old-list)
+			   (printf "All Ok~n"))))
+  (define (simulate v)
+    (let ([e (make-object control-event% 'slider)])
+      (send s set-value v)
+      (send s command e)))
+  (define p2 (make-object horizontal-panel% p))
+  (define p3 (make-object horizontal-panel% p))
+  (send p3 stretchable-height #f)
+  (make-object button%
+	       "Up" p2
+	       (lambda (c e)
+		 (send s set-value (add1 (send s get-value)))))
+  (make-object button%
+	       "Down" p2
+	       (lambda (c e)
+		 (send s set-value (sub1 (send s get-value)))))
+  (make-object button%
+	       "Simulate Up" p2
+	       (lambda (c e)
+		 (simulate (add1 (send s get-value)))))
+  (make-object button%
+	       "Simulate Down" p2
+	       (lambda (c e)
+		 (simulate (sub1 (send s get-value)))))
+  (instructions p "slider-steps.txt")
+  (send f show #t))
+
+(define (gauge-frame)
+  (define f (make-frame frame% "Gauge Test"))
+  (define p (make-object vertical-panel% f))
+  (define g (make-object gauge% "Tester" 10 p))
+  (define (move d name)
+    (make-object button%
+		 name p
+		 (lambda (c e)
+		   (send g set-value (+ d (send g get-value))))))
+  (define (size d name)
+    (make-object button%
+		 name p
+		 (lambda (c e)
+		   (send g set-range (+ d (send g get-range))))))
+  (move 1 "+")
+  (move -1 "-")
+  (size 1 "Bigger")
+  (size -1 "Smaller")
+  (instructions p "gauge-steps.txt")
+  (send f show #t))
+
+(define (text-frame style)
+  (define (handler get-this)
+    (lambda (c e)
+      (unless (eq? c (get-this))
+	(printf "callback: bad item: ~a~n" c))
+      (let ([t (send e get-event-type)])
+	(cond
+	 [(eq? t 'text-field)
+	  (printf "Changed: ~a~n" (send c get-value))]
+	 [(eq? t 'text-field-enter)
+	  (printf "Return: ~a~n" (send c get-value))]))))
+
+  (define f (make-frame frame% "Text Test"))
+  (define p (make-object vertical-panel% f))
+  (define t1 (make-object text-field% #f p (handler (lambda () t1)) "This should just fit!" style))
+  (define t2 (make-object text-field% "Another" p (handler (lambda () t2)) "This too!" style))
+  (define t3 (make-object text-field% "Catch Returns" p (handler (lambda () t3)) "And, yes, this!"
+			  (cons 'hscroll style)))
+  (send t1 stretchable-width #f)
+  (send t2 stretchable-width #f)
+  (send t3 stretchable-width #f)
+  (send f show #t))
+
+(define (canvas-frame flags)
+  (define f (make-frame frame% "Canvas Test" #f #f 250))
+  (define p (make-object vertical-panel% f))
+  (define c% (class100 canvas% (-name -swapped-name p)
+	       (inherit get-dc get-scroll-pos get-scroll-range get-scroll-page
+			get-client-size get-virtual-size get-view-start)
+	       (rename [super-init-manual-scrollbars init-manual-scrollbars]
+		       [super-init-auto-scrollbars init-auto-scrollbars])
+	       (private-field
+		 [name -name]
+		 [swapped-name -swapped-name]
+		 [auto? #f]
+		 [incremental? #f]
+		 [vw 10]
+		 [vh 10])
+	       (public
+		 [inc-mode (lambda (x) (set! incremental? x))]
+		 [set-vsize (lambda (w h) (set! vw w) (set! vh h))])
+	       (override
+		[on-paint
+		 (lambda ()
+		   (let ([s (format "V: p: ~s r: ~s g: ~s H: ~s ~s ~s"
+				    (get-scroll-pos 'vertical)
+				    (get-scroll-range 'vertical)
+				    (get-scroll-page 'vertical)
+				    (get-scroll-pos 'horizontal)
+				    (get-scroll-range 'horizontal)
+				    (get-scroll-page 'horizontal))]
+			 [dc (get-dc)])
+		     (let-values ([(w h) (get-client-size)]
+				  [(w2 h2) (get-virtual-size)]
+				  [(x y) (get-view-start)])
+		       ; (send dc set-clipping-region 0 0 w2 h2)
+		       (unless incremental? (send dc clear))
+		       (send dc draw-text (if (send ck-w get-value) swapped-name name) 3 3)
+		       ; (draw-line 3 12 40 12)
+		       (send dc draw-text s 3 15)
+		       (send dc draw-text (format "client: ~s x ~s  virtual: ~s x ~s  view: ~s x ~s" 
+						  w h
+						  w2 h2
+						  x y)
+			     3 27)
+		       (send dc draw-line 0 vh vw vh)
+		       (send dc draw-line vw 0 vw vh))))]
+		[on-event
+		 (lambda (e)
+		   (let ([s (format "~a ~a" (send e get-x) (send e get-y))])
+		     (send f set-status-text s)))]
+		[on-scroll
+		 (lambda (e) 
+		   (when auto? (printf "Hey - on-scroll called for auto scrollbars~n"))
+		   (unless incremental? (on-paint)))]
+		[init-auto-scrollbars (lambda x
+					(set! auto? #t)
+					(super-init-auto-scrollbars . x))]
+		[init-manual-scrollbars (lambda x
+					  (set! auto? #f)
+					  (super-init-manual-scrollbars . x))])
+	       (sequence
+		 (super-init p flags))))
+  (define un-name "Unmanaged scroll")
+  (define m-name "Automanaged scroll")
+  (define c1 (make-object c% un-name m-name p))
+  (define c2 (make-object c% m-name un-name p))
+  (define (reset-scrolls for-small?)
+    (let* ([h? (send ck-h get-value)]
+	   [v? (send ck-v get-value)]
+	   [small? (send ck-s get-value)]
+	   [swap? (send ck-w get-value)])
+      (send c1 set-vsize 10 10)
+      (if swap?
+	  (send c1 init-auto-scrollbars (and h? 10) (and v? 10) .1 .1)
+	  (send c1 init-manual-scrollbars (and h? 10) (and v? 10) 3 3 1 1))
+      ; (send c1 set-scrollbars (and h? 1) (and v? 1) 10 10 3 3 1 1 swap?)
+      (send c2 set-vsize (if small? 50 500) (if small? 20 200))
+      (if swap?
+	  (send c2 init-manual-scrollbars (if small? 2 20) (if small? 2 20) 3 3 1 1)
+	  (send c2 init-auto-scrollbars (and h? (if small? 50 500)) (and v? (if small? 20 200)) .2 .2))
+      ; (send c2 set-scrollbars (and h? 25) (and v? 10) (if small? 2 20) (if small? 2 20) 3 3 1 1 (not swap?))
+      (if for-small?
+	  ; Specifically refresh the bottom canvas
+	  (send c2 refresh)
+	  ; Otherwise, we have to specifically refresh the unmanaged canvas
+	  (send (if swap? c2 c1) refresh))))
+  (define (reset-show)
+    (for-each
+     (lambda (c)
+       (send c show-scrollbars 
+	     (and (not (send sh-h get-value)) (memq 'hscroll flags))
+	     (and (not (send sh-v get-value)) (memq 'vscroll flags))))
+     (list c1 c2)))
+  (define p2 (make-object horizontal-panel% p))
+  (define junk (send p2 stretchable-height #f))
+  (define ck-v (make-object check-box% "Vertical Scroll" p2 (lambda (b e) (reset-scrolls #f))))
+  (define ck-h (make-object check-box% "Horizontal Scroll" p2 (lambda (b e) (reset-scrolls #f))))
+  (define ck-s (make-object check-box% "Small" p2 (lambda (b e) (reset-scrolls #t))))
+  (define ck-w (make-object check-box% "Swap" p2 (lambda (b e) (reset-scrolls #f))))
+  (define p3 (make-object horizontal-panel% p))
+  (define junk2 (send p3 stretchable-height #f))
+  (define sh-v (make-object check-box% "Hide Vertical" p3 (lambda (b e) (reset-show))))
+  (define sh-h (make-object check-box% "Hide Horizontal" p3 (lambda (b e) (reset-show))))
+  (define ip (make-object horizontal-panel% p))
+  (send ip stretchable-height #f)
+  (make-object button%
+	       "Get Instructions" ip
+	       (lambda (b e) (open-file "canvas-steps.txt")))
+  (make-object button%
+	       "&1/5 Scroll" ip
+	       (lambda (b e) (send c2 scroll 0.2 0.2)))
+  (make-object button%
+	       "&4/5 Scroll" ip
+	       (lambda (b e) (send c2 scroll 0.8 0.8)))
+  (make-object check-box%
+	       "Inc" ip
+	       (lambda (c e) 
+		 (send c1 inc-mode (send c get-value))
+		 (send c2 inc-mode (send c get-value))))
+  (make-object check-box%
+	       "x2" ip
+	       (lambda (c e) 
+		 (let ([s (if (send c get-value)
+			      2
+			      1)])
+		   (send (send c2 get-dc) set-scale s s)
+		   (send c2 refresh))))
+  (send c1 set-vsize 10 10)
+  (send c2 set-vsize 500 200)
+  (send f create-status-line)
+  (send f show #t))
+
+(define (no-clear-canvas-frame)
+  (define f (new frame% 
+		 [label "No-Clear Canvas Test"]
+		 [height 250]
+		 [width 300]
+		 [style (add-frame-style null)]))
+  (define p (make-object vertical-panel% f))
+  (define c% (class canvas%
+               (inherit get-dc refresh)
+	       (define delta 0)
+	       (define/override (on-paint)
+		 (let ([red (send the-brush-list find-or-create-brush "RED" 'solid)]
+		       [blue (send the-brush-list find-or-create-brush "BLUE" 'solid)]
+		       [dc (get-dc)])
+		   (let loop ([x 0])
+		     (unless (= x 500)
+		       (send dc set-brush red)
+		       (send dc draw-rectangle (- x delta) 0 25 30)
+		       (send dc draw-rectangle (- x delta) 40 25 390)
+		       (send dc set-brush blue)
+		       (send dc draw-rectangle (- (+ x 25) delta) 0 25 30)
+		       (send dc draw-rectangle (- (+ x 25) delta) 40 25 390)
+		       (loop (+ x 50))))))
+	       (define/override (on-event evt)
+		 (when (send evt dragging?)
+		   (set! delta (modulo (add1 delta) 100))
+		   (refresh)))
+	       (super-new)))
+  (new c% [parent p][style '(border)])
+  (new c% [parent p][style '(transparent)])
+  (new c% [parent p][style '(no-autoclear border)])
+  (send f show #t)
+  f)
+
+(define (editor-frame canvas-style canvas-bg)
+  (define f (new frame% 
+		 [label "No-Clear Canvas Test"]
+		 [height 250]
+		 [width 300]
+		 [style (add-frame-style null)]))
+  (define c (new editor-canvas%
+		 [parent f]
+		 [style canvas-style]))
+  (define mb (make-object menu-bar% f))
+  (define edit-menu (make-object menu% "Edit" mb))
+  (define font-menu (make-object menu% "Font" mb))
+
+  (when canvas-bg
+    (send c set-canvas-background (make-object color% canvas-bg)))
+  (send c set-editor (new text%))
+
+  (append-editor-operation-menu-items edit-menu #f)
+  (append-editor-font-menu-items font-menu)
+
+  (send f show #t))
+
+(define (editor-canvas-oneline-frame)
+  (define f (make-frame frame% "x" #f 200 #f))
+  
+  (define (try flags)
+    (define c (make-object editor-canvas% f #f flags))
+    
+    (define e (make-object text%))
+    
+    (send e insert "Xy!")
+    
+    (send c set-line-count 1)
+    
+    (send c set-editor e)
+    (send c stretchable-height #f))
+
+  (send f show #t)
+  
+  (try '(no-hscroll no-vscroll))
+  (try '(no-vscroll))
+  (try '(no-hscroll))
+  (try '()))
+
+(define (minsize-frame)
+  (define f (make-frame frame% "x"))
+  
+  (define bp (make-object horizontal-panel% f))
+  (define tb (make-object button% "Toggle Stretch" bp
+			  (lambda (b e)
+			    (for-each
+			     (lambda (p)
+			       (send p stretchable-width (not (send p stretchable-width)))
+			       (send p stretchable-height (not (send p stretchable-height))))
+			     containers))))
+  (define ps (make-object button% "Print Sizes" bp
+			  (lambda (b e)
+			    (newline)
+			    (for-each
+			     (lambda (p)
+			       (let ([c (car (send p get-children))])
+				 (let-values ([(w h) (send c get-size)]
+					      [(cw ch) (send c get-client-size)])
+				   (printf "~a: (~a x ~a) client[~a x ~a] diff<~a x ~a> min{~a x ~a}~n"
+					   c w h cw ch
+					   (- w cw) (- h ch)
+					   (send c min-width) (send c min-height)))))
+			     (reverse containers))
+			    (newline))))
+  
+  (define containers null)
+
+  (define (make-container p)
+    (let ([p (make-object vertical-panel% p '())])
+      (send p stretchable-width #f)
+      (send p stretchable-height #f)
+      (set! containers (cons p containers))
+      p))
+  
+  (define hp0 (make-object horizontal-panel% f))
+
+  (define p (make-object panel% (make-container hp0)))
+  (define pb (make-object panel% (make-container hp0) '(border)))
+
+  (define hp1 (make-object horizontal-panel% f))
+
+  (define c (make-object canvas% (make-container hp1)))
+  (define cb (make-object canvas% (make-container hp1) '(border)))
+  (define ch (make-object canvas% (make-container hp1) '(hscroll)))
+  (define cv (make-object canvas% (make-container hp1) '(vscroll)))
+  (define chv (make-object canvas% (make-container hp1) '(hscroll vscroll)))
+  (define cbhv (make-object canvas% (make-container hp1) '(border hscroll vscroll)))
+
+  (define hp2 (make-object horizontal-panel% f))
+
+  (define ec (make-object editor-canvas% (make-container hp2) #f '(no-hscroll no-vscroll)))
+  (define ech (make-object editor-canvas% (make-container hp2) #f '(no-vscroll)))
+  (define ecv (make-object editor-canvas% (make-container hp2) #f '(no-hscroll)))
+  (define echv (make-object editor-canvas% (make-container hp2) #f '()))
+
+  (define hp3 (make-object horizontal-panel% f))
+  
+  (define pec (make-object editor-canvas% (make-container hp3) #f '(no-border no-hscroll no-vscroll)))
+  (define pech (make-object editor-canvas% (make-container hp3) #f '(no-border no-vscroll)))
+  (define pecv (make-object editor-canvas% (make-container hp3) #f '(no-border no-hscroll)))
+  (define pechv (make-object editor-canvas% (make-container hp3) #f '(no-border )))
+
+  (define hp4 (make-object horizontal-panel% f))
+  (define chvh (make-object canvas% (make-container hp4) '(border hscroll vscroll)))
+  (define chvv (make-object canvas% (make-container hp4) '(border hscroll vscroll)))
+  (send chvh show-scrollbars #t #f)
+  (send chvv show-scrollbars #f #t)
+
+  (send f show #t))
+
+;----------------------------------------------------------------------
+
+(define (test-tab-panel no-border?)
+  (define f (make-object frame% "Tabby"))
+  (define p (make-object tab-panel% '("App&le" "B&anana" "Co&conut") 
+			 f
+			 (lambda (p e)
+			   (send m set-label (format "Selected: ~a" (send p get-selection))))
+			 (if no-border?
+			     '(no-border)
+			     '())))
+  (define p2 (if no-border?
+		 (new vertical-panel% [parent f])
+		 p))
+  (define count 3)
+  (define on? #t)
+  (define m (make-object message% (format "Selected: ~a" (send p get-selection)) p2))
+
+  (when no-border?
+    (make-object vertical-pane% p2))
+
+  (make-object button% "Append" p2 (lambda (b e) 
+				    (send p append (format "N&ew ~a" count))
+				    (set! count (add1 count))))
+  (make-object button% "Delete" p2 (lambda (b e)
+				     (send p delete 0)))
+  (make-object button% "First" p2 (lambda (b e)
+				    (send p set-selection 0)))
+  (make-object button% "Last" p2 (lambda (b e)
+				   (send p set-selection (sub1 (send p get-number)))))
+  (make-object button% "Rename" p2 (lambda (b e)
+				     (send p set-item-label (quotient (send p get-number) 2) "Do&nut")))
+  (make-object button% "Labels" p2 (lambda (b e)
+				     (printf "~s~n"
+					     (reverse
+					      (let loop ([i (send p get-number)])
+						(if (zero? i)
+						    null
+						    (cons (send p get-item-label (sub1 i)) (loop (sub1 i)))))))))
+  (make-object button% "Set" p2 (lambda (b e)
+				  (send p set '("New One" "New Second" "New Third"))))
+  (when no-border?
+    (make-object button% "Toggle" p2 (lambda (b e)
+				       (if on?
+					   (send f delete-child p)
+					   (send f change-children
+						 (lambda (l) (cons p l))))
+				       (set! on? (not on?)))))
+
+  (send f show #t))
+
+;----------------------------------------------------------------------
+
+(define (test-modified-frame)
+  (define f (new (class frame% 
+		   (define/override (on-toolbar-button-click)
+		     (send f modified (not (send f modified))))
+		   (super-make-object))
+		 [label "Modifiable"]
+		 [style '(toolbar-button)]))
+
+  (make-object button% "Toggle" f (lambda (b e)
+				    (send f on-toolbar-button-click)))
+  (make-object message% "Mac OS X: toolbar button also toggles" f)
+  (send f show #t))
+
+;----------------------------------------------------------------------
+
+(define (message-boxes parent)
+  (define (check expected got)
+    (unless (eq? expected got)
+      (fprintf (current-error-port) "bad result: - expected ~e, got ~e~n"
+	       expected got)))
+  (define (big s)
+    (format "~a~n~a~n~a~n~a~n" s
+	    (make-string 500 #\x)
+	    (make-string 500 #\x)
+	    (make-string 500 #\x)))
+
+  (check 'ok (message-box "Title" "Message OK!" parent '(ok)))
+  (check 'ok (message-box "Title" (big "Message OK!") parent '(ok)))
+
+  (check 'cancel (message-box "Title" "Cancel Me" parent '(ok-cancel)))
+  (check 'ok (message-box "Title" "Ok Me" parent '(ok-cancel)))
+  (check 'ok (message-box "Title" (big "Ok Me") parent '(ok-cancel)))
+
+  (check 'yes (message-box "Title" "Yes, please" parent '(yes-no)))
+  (check 'no (message-box "Title" "No, please" parent '(yes-no)))
+
+  (check 'yes (message-box "Title" "Caution sign?" parent '(yes-no caution)))
+  (check 'yes (message-box "Title" "Stop sign?" parent '(yes-no stop)))
+
+  (check 1 (message-box/custom "Title" "Hello"
+				"Hi" #f #f
+				parent
+				'(default=1)))
+  (check 2 (message-box/custom "Title" "Hello"
+			       #f "Howdy" #f
+			       parent))
+  (check 3 (message-box/custom "Title" "Hello (response should be on left for Mac OS)"
+				#f #f "Howdy"
+				parent))
+  (check #f (message-box/custom "Title" "Escape to close, please"
+				 "Hi" #f #f
+				 parent))
+  (check 'closed (message-box/custom "Title" "Escape to close, again, please"
+				     "Hi" #f #f
+				     parent
+				     '(default=1)
+				     'closed))
+  (check 'closed (message-box/custom "Title" "Escape to close, again, please"
+				     #f #f #f
+				     parent
+				     '(default=1)
+				     'closed))
+  (check 1 (message-box/custom "Title" "Try to escape to close"
+				"I can't" #f #f
+				parent
+				'(default=1 disallow-close)
+				'closed))
+
+  (message-box/custom "Title" "Buttons out of order in Mac OS"
+		       "One" "Two" "Three"
+		       parent)
+  (message-box/custom "Title" "Buttons in order on all platforms"
+		       "One" "Two" "Three"
+		       parent
+		       '(default=1 number-order))
+		       
+  )
+
+;----------------------------------------------------------------------
+
+(define (cursors)
+  (define f (make-object frame% "Cursors"))
+  (for-each (lambda (s)
+	      (make-object button%
+			   (format "~a" s)
+			   f
+			   (lambda (b e)
+			     (send f set-cursor (make-object cursor% s)))))
+	    '(arrow bullseye cross hand ibeam watch arrow-watch blank size-n/s size-e/w size-ne/sw size-nw/se))
+  (send f show #t))
+
+
+;----------------------------------------------------------------------
+
+(define selector (make-frame frame% "Test Selector"))
+(define ap (make-object vertical-panel% selector))
+
+; Test timers while we're at it. And create the "Instructions" button.
+(let ([clockp (make-object horizontal-panel% ap)]
+      [selector selector])
+  (make-object button% "Get Instructions" clockp
+	       (lambda (b e) 
+		 (open-file "frame-steps.txt")))
+  (make-object check-box% "Use Dialogs" clockp
+	       (lambda (c e)
+		 (set! use-dialogs? (send c get-value))))
+  (make-object check-box% "Metal" clockp
+	       (lambda (c e)
+		 (set! use-metal? (send c get-value))))
+  (make-object check-box% "Float" clockp
+	       (lambda (c e)
+		 (set! float-frame? (send c get-value))))
+  (make-object check-box% "No Title" clockp
+	       (lambda (c e)
+		 (set! no-caption? (send c get-value))))
+  (make-object vertical-panel% clockp) ; filler
+  (let ([time (make-object message% "XX:XX:XX" clockp)])
+    (make-object
+     (class100 timer% ()
+       (inherit start)
+       (override
+	 [notify
+	  (lambda ()
+	    (let* ([now (seconds->date (current-seconds))]
+		   [pad (lambda (pc d)
+			  (let ([s (number->string d)])
+			    (if (= 1 (string-length s))
+				(string-append pc s)
+				s)))]
+		   [s (format "~a:~a:~a"
+			      (pad " " (let ([h (modulo (date-hour now) 12)])
+					 (if (zero? h)
+					     12
+					     h)))
+			      (pad "0" (date-minute now))
+			      (pad "0" (date-second now)))])
+	      (send time set-label s)
+	      (when (send selector is-shown?)
+		(start 1000 #t))))])
+       (sequence
+	 (super-init)
+	 (start 1000 #t))))))
+
+(define bp (make-object vertical-panel% ap '(border)))
+(define bp1 (make-object horizontal-panel% bp))
+(define bp2 (make-object horizontal-pane% bp))
+(define mp (make-object vertical-panel% ap '(border)))
+(define mp1 (make-object horizontal-panel% mp))
+(define mp2 (make-object horizontal-pane% mp))
+
+(define pp (make-object horizontal-pane% ap))
+(send bp stretchable-height #f)
+(make-object button% "Make Menus Frame" pp (lambda (b e) (menu-frame)))
+(make-object horizontal-pane% pp)
+(make-object button% "Make Panel Frame" pp (lambda (b e) (panel-frame)))
+(make-object horizontal-pane% pp)
+(make-object button% "Editor Canvas One-liners" pp (lambda (b e) (editor-canvas-oneline-frame)))
+(make-object horizontal-pane% pp)
+(make-object button% "Minsize Windows" pp (lambda (b e) (minsize-frame)))
+(define bp (make-object horizontal-pane% ap))
+(send bp stretchable-width #f)
+(make-object button% "Make Button Frame" bp (lambda (b e) (button-frame frame% null)))
+(make-object button% "Make Default Button Frame" bp (lambda (b e) (button-frame frame% '(border))))
+(make-object button% "Make Button Dialog" bp (lambda (b e) (button-frame dialog% null)))
+(define crp (make-object horizontal-pane% ap))
+(send crp stretchable-height #f)
+(make-object button% "Make Checkbox Frame" crp (lambda (b e) (checkbox-frame)))
+(make-object vertical-pane% crp) ; filler
+(make-object button% "Message Boxes" crp (lambda (b e) (message-boxes #f)))
+(make-object vertical-pane% crp) ; filler
+(make-object button% "Cursors" crp (lambda (b e) (cursors)))
+(make-object vertical-pane% crp) ; filler
+(make-object button% "Make Radiobox Frame" crp (lambda (b e) (radiobox-frame)))
+(define cp (make-object horizontal-pane% ap))
+(send cp stretchable-width #f)
+(make-object button% "Make Choice Frame" cp (lambda (b e) (choice-or-list-frame #f null #f)))
+(make-object button% "Make Empty Choice Frame" cp (lambda (b e) (choice-or-list-frame #f null #t)))
+(define lp (make-object horizontal-pane% ap))
+(send lp stretchable-width #f)
+(make-object button% "Make List Frame" lp (lambda (b e) (choice-or-list-frame #t '(single) #f)))
+(make-object button% "Make Empty List Frame" lp (lambda (b e) (choice-or-list-frame #t '(single) #t)))
+(make-object button% "Make MultiList Frame" lp (lambda (b e) (choice-or-list-frame #t '(multiple) #f)))
+(make-object button% "Make MultiExtendList Frame" lp (lambda (b e) (choice-or-list-frame #t '(extended) #f)))
+(define gsp (make-object horizontal-pane% ap))
+(send gsp stretchable-height #f)
+(make-object button% "Make Gauge Frame" gsp (lambda (b e) (gauge-frame)))
+(make-object vertical-pane% gsp) ; filler
+(make-object button% "Make Slider Frame" gsp (lambda (b e) (slider-frame)))
+(make-object vertical-pane% gsp) ; filler
+(make-object button% "Make Tab Panel" gsp (lambda (b e) (test-tab-panel #f)))
+(make-object button% "Make Tabs" gsp (lambda (b e) (test-tab-panel #t)))
+(make-object vertical-pane% gsp) ; filler
+(make-object button% "Make Modified Frame" gsp (lambda (b e) (test-modified-frame)))
+
+(define tp (make-object horizontal-pane% ap))
+(send tp stretchable-width #f)
+(make-object button% "Make Text Frame" tp (lambda (b e) (text-frame '(single))))
+(make-object button% "Make Multitext Frame" tp (lambda (b e) (text-frame '(multiple))))
+
+(define cnp (make-object horizontal-pane% ap))
+(send cnp stretchable-width #t)
+(send cnp set-alignment 'right 'center)
+(let ([mkf (lambda (flags name)
+	     (make-object button%
+			  (format "Make ~aCanvas Frame" name) cnp 
+			  (lambda (b e) (canvas-frame flags))))])
+  (mkf '(hscroll vscroll) "HV")
+  (mkf '(hscroll) "H")
+  (mkf '(vscroll) "V")
+  (mkf null "")
+  (make-object grow-box-spacer-pane% cnp))
+(make-object button%
+	     "Make No-Clear Canvas" cnp 
+	     (lambda (b e) (no-clear-canvas-frame)))
+
+(define edp (new horizontal-pane% 
+		 [parent ap]
+		 [alignment '(center center)]))
+(make-object button%
+	     "Make Editor" edp 
+	     (lambda (b e) (editor-frame null #f)))
+(make-object button%
+	     "Make Transparent Editor" edp 
+	     (lambda (b e) (editor-frame '(transparent) #f)))
+(make-object button%
+	     "Make Blue Editor" edp 
+	     (lambda (b e) (editor-frame null "blue")))
+
+(define (choose-next radios)
+  (let loop ([l radios])
+    (let* ([c (car l)]
+	   [rest (cdr l)]
+	   [n (send c number)]
+	   [v (send c get-selection)])
+      (if (< v (sub1 n))
+	  (send c set-selection (add1 v))
+	  (if (null? rest)
+	      (map (lambda (c) (send c set-selection 0)) radios)
+	      (begin
+		(send c set-selection 0)
+		(loop rest)))))))
+
+(define make-next-button
+  (lambda (p l)
+    (make-object button%
+		 "Next Configuration" p
+		 (lambda (b e) (choose-next l)))))
+
+(define make-selector-and-runner
+  (lambda (p1 p2 radios? size maker)
+    (define (make-radio-box lbl choices panel cb)
+      (let ([g (instantiate group-box-panel% (lbl panel))])
+	(if (= (length choices) 2)
+	    (make-object radio-box% #f choices g cb)
+	    (make-object choice% #f choices g cb))))
+    (define radio-h-radio
+      (make-radio-box 
+       (if radios? "Radio Box Orientation" "Slider Style")
+       (if radios? '("Vertical" "Horizontal") '("Numbers" "Plain"))
+       p1 void))
+    (define label-h-radio
+      (make-radio-box "Label Orientation" '("Vertical" "Horizontal")
+		      p1 void))
+    (define label-null-radio
+      (make-radio-box "Optional Labels" '("Use Label" "No Label")
+		      p1 void))
+    (define stretchy-radio
+      (make-radio-box "Stretchiness" '("Normal" "All Stretchy")
+		      p1 void))
+    (define font-radio
+      (make-radio-box "Label Font" '("Normal" "Small" "Tiny" "Big")
+		      p1 void))
+    (define enabled-radio
+      (make-radio-box "Initially" '("Enabled" "Disabled")
+		      p1 void))
+    (define selection-radio
+      (make-radio-box "Selection" '("Default" "Alternate")
+		      p1 void))
+    (define next-button
+      (make-next-button p2 (list radio-h-radio label-h-radio label-null-radio 
+				 stretchy-radio font-radio
+				 enabled-radio selection-radio)))
+    (define go-button
+      (make-object button% (format "Make ~a Frame" size) p2
+		   (lambda (b e)
+		     (maker
+		      (positive? (send radio-h-radio get-selection))
+		      (positive? (send label-h-radio get-selection))
+		      (positive? (send label-null-radio get-selection))
+		      (positive? (send stretchy-radio get-selection))
+		      (list-ref (list #f
+				      small-control-font
+				      tiny-control-font
+				      special-font)
+				(send font-radio get-selection))
+		      (positive? (send enabled-radio get-selection))
+		      (positive? (send selection-radio get-selection))))))
+    #t))
+
+(make-selector-and-runner bp1 bp2 #t "Big" big-frame)
+(make-selector-and-runner mp1 mp2 #f "Medium" med-frame)
+
+(send selector show #t)
diff --git a/collects/tests/mred/loadtest.ss b/collects/tests/mred/loadtest.ss
new file mode 100644
index 0000000000..d60140522f
--- /dev/null
+++ b/collects/tests/mred/loadtest.ss
@@ -0,0 +1,5 @@
+
+(unless (with-handlers ([exn:fail? (lambda (x) #f)])
+	  (namespace-variable-binding 'SECTION)
+	  #t)
+  (load-relative "testing.ss"))
diff --git a/collects/tests/mred/media.mre b/collects/tests/mred/media.mre
new file mode 100644
index 0000000000..00a6badbe3
Binary files /dev/null and b/collects/tests/mred/media.mre differ
diff --git a/collects/tests/mred/mediastream.example b/collects/tests/mred/mediastream.example
new file mode 100644
index 0000000000..2cfe56f557
Binary files /dev/null and b/collects/tests/mred/mediastream.example differ
diff --git a/collects/tests/mred/mediastream.ss b/collects/tests/mred/mediastream.ss
new file mode 100644
index 0000000000..a4c8a261c8
--- /dev/null
+++ b/collects/tests/mred/mediastream.ss
@@ -0,0 +1,60 @@
+
+(define out-base (make-object wx:media-stream-out-string-base%))
+(define out (make-object wx:media-stream-out% out-base))
+
+(define items (list 10 3.5 100 0 -1 -100 -3.5 "howdy"))
+
+(define (write-all)
+  (for-each
+   (lambda (i)
+     (send out put i))
+   items))
+
+(write-all)
+
+(let ([start (send out tell)])
+  (send out put-fixed 100)
+  (write-all)
+  (let ([end (send out tell)])
+    (send out jump-to start)
+    (send out put-fixed 99)
+    (send out jump-to end)
+    (send out put "End Second")))
+
+(define file (send out-base get-string))
+
+(define in-base (make-object wx:media-stream-in-string-base% file))
+(define in (make-object wx:media-stream-in% in-base))
+
+(define (test expected got)
+  (unless (equal? expected got)
+    (error 'media-stream-test "expected ~s, got ~s~n" expected got)))
+
+(define (read-all)
+  (for-each
+   (lambda (i)
+     (test i
+	   (cond
+	    [(string? i) (send in get-string)]
+	    [(inexact? i) (send in get-inexact)]
+	    [else (send in get-exact)])))
+   items))
+(read-all)
+(test 99 (let ([b (box 0)])
+	   (send in get-fixed b)
+	   (unbox b)))
+(read-all)
+(test "End Second" (send in get-string))
+
+(define example-file-name (build-path (current-load-relative-directory) "mediastream.example"))
+(define expect (if (file-exists? example-file-name)
+		   (with-input-from-file example-file-name
+		     (lambda ()
+		       (read-string (+ (string-length file) 10))))
+		   (begin
+		     (fprintf (current-error-port) "Warning: ~a does not exist; creating it.~n" example-file-name)
+		     (with-output-to-file example-file-name
+		       (lambda () (display file)))
+		     file)))
+(unless (string=? file expect)
+  (error "generated file does not match expected file"))
diff --git a/collects/tests/mred/mem.ss b/collects/tests/mred/mem.ss
new file mode 100644
index 0000000000..7b25821c66
--- /dev/null
+++ b/collects/tests/mred/mem.ss
@@ -0,0 +1,284 @@
+
+; run with mred -u -- -f mem.ss
+
+(require (lib "class100.ss"))
+
+(define source-dir (current-load-relative-directory))
+
+(define num-times 8)
+(define num-threads 3)
+
+(define dump-stats? #f)
+
+(define edit? #t)
+(define insert? #t)
+(define load-file? #f) ; adds a lot of messy objects
+
+(define menus? #t)
+(define atomic? #t)
+(define offscreen? #t)
+(define frame? #t)
+
+(define subwindows? #t)
+
+(define allocated '())
+(define (remember tag v)
+  (set! allocated
+	(cons (cons tag (make-weak-box v))
+	      allocated))
+  v)
+
+(when subwindows?
+  (namespace-set-variable-value!
+   'sub-collect-frame
+   (make-object frame% "sub-collect"))
+  (namespace-set-variable-value!
+   'sub-collect-panel
+   (make-object panel% sub-collect-frame)))
+
+(define permanent-ready? #f)
+(define mb-lock (make-semaphore 1))
+
+(define htw (make-hash-table 'weak))
+
+(send sub-collect-frame show #t)
+
+(define (get-panel% n)
+  (case (modulo n 3)
+    [(0) panel%]
+    [(1) vertical-panel%]
+    [(2) horizontal-panel%]))
+
+(define (get-pane% n)
+  (case (modulo n 6)
+    [(0) pane%]
+    [(1) vertical-pane%]
+    [(2) horizontal-pane%]
+    [else (get-panel% n)]))
+
+(define (get-image n)
+  (build-path (collection-path "icons")
+   (case (modulo n 4)
+     [(0) "mini-plt.xpm"]
+     [(1) "lock.gif"]
+     [(2) "help.bmp"]
+     [(3) "return.xbm"])))
+
+(define (maker id n)
+  (sleep)
+  (collect-garbage)
+  (collect-garbage)
+  (printf "Thread: ~s Cycle: ~s~n" id n)
+  ; (dump-object-stats)
+  ; (if (and dump-stats? (= id 1))
+  ;    (dump-memory-stats))
+  (unless (zero? n)
+    (let ([tag (cons id n)])
+      (let* ([edit (remember tag (make-object text%))]
+	     [ef (let ([f (make-object frame% "Editor Frame")])
+		   (send (make-object editor-canvas% f) set-editor edit)
+		   (remember tag f))]
+	     [c (make-custodian)]
+	     [es (parameterize ([current-custodian c])
+		   (make-eventspace))])
+
+	(when edit?
+	  (send ef show #t)
+	  (sleep 0.1))
+
+	(parameterize ([current-eventspace es])
+	  (send (remember 
+		 tag
+		 (make-object
+		  (class100 timer% args
+		    (override [notify (lambda () (void))])
+		    (sequence (apply super-init args)))))
+		start 100))
+
+	(if frame?
+	    (let* ([f (remember tag
+	    	       (make-object (if (even? n)
+				       frame% 
+				       dialog%)
+				   "Tester" #f 200 200))]
+		   [cb (lambda (x y) f)]
+		   [p (remember tag (make-object (get-pane% n) f))])
+	      (remember tag (make-object canvas% f))
+	      (when (zero? (modulo n 3))
+		(thread (lambda () (send f show #t)))
+		(let loop () (sleep) (unless (send f is-shown?) (loop))))
+	      (remember tag (make-object button% "one" p cb))
+	      (let ([class check-box%])
+		(let loop ([m 10])
+		  (unless (zero? m)
+		    (remember (cons tag m)
+			      (make-object class "another" p cb))
+		    (loop (sub1 m)))))
+	      (remember tag (make-object check-box% "check" p cb))
+	      (remember tag (make-object choice% "choice" '("a" "b" "c") p cb))
+	      (remember tag (make-object list-box% "list" '("apple" "banana" "coconut")
+					 p cb))
+	      (remember tag (make-object button% "two" p cb))
+	      (send f show #f)))
+
+	(if subwindows?
+	    (let ([p (make-object (get-panel% n) sub-collect-frame)]
+		  [cv (make-object canvas% sub-collect-frame)]
+		  [add-objects
+		   (lambda (p tag hide?)
+		     (let ([b (let* ([x #f]
+				     [bcb (lambda (a b) x)])
+				(set! x (make-object button% "one" p bcb))
+				x)]
+			   [c (make-object check-box% "check" p void)]
+			   [co (make-object choice% "choice" '("a" "b" "c") p void)]
+			   [cv (make-object canvas% p)]
+			   [lb (make-object list-box% "list" '("apple" "banana" "coconut") p void)])
+		       (when hide?
+			 (send p delete-child b)
+			 (send p delete-child c)
+			 (send p delete-child cv)
+			 (send p delete-child co)
+			 (send p delete-child lb))
+		       (remember tag b)
+		       (remember tag c)
+		       (remember tag cv)
+		       (remember tag co)
+		       (remember tag lb)))])
+	      (add-objects sub-collect-panel (cons 'sc1 tag) #t)
+	      (add-objects p (cons 'sc2 tag) #f)
+	      (remember (cons 'sc0 tag) p)
+	      (remember (cons 'sc0 tag) cv)
+	      (send sub-collect-frame delete-child p)
+	      (send sub-collect-frame delete-child cv)))
+
+	(if (and edit? insert?)
+	    (let ([e edit])
+	      (when load-file?
+		(send e load-file (build-path source-dir "mem.ss")))
+	      (let loop ([i 20])
+		(send e insert (number->string i))
+		(unless (zero? i)
+		  (loop (sub1 i))))
+	      (let ([s (make-object editor-snip%)])
+		(send (send s get-editor) insert "Hello!")
+		(send e insert s))
+	      (send e insert #\newline)
+	      (send e insert "done")
+	      (send e set-modified #f)))
+	
+	(when menus?
+	  (let ([f (remember tag (make-object frame% "MB Frame 0"))])
+	    (remember tag (make-object menu% "TM1" (remember (cons 'q tag) (make-object menu-bar% f)))))
+	  (let* ([mb (remember tag (make-object menu-bar% ef))]
+		 [m (remember tag (make-object menu% "Ok" mb))])
+	    (remember tag (make-object menu-item% "Hi" m void))
+	    (remember tag (make-object menu-item% "There" m void #\t))
+	    (remember tag
+		      (make-object checkable-menu-item%
+				   "Checkable"
+				   (remember tag (make-object menu% "Hello" m))
+				   void))
+	    (let ([i (remember tag (make-object menu-item% "Delete Me" m void))])
+	      (send i delete)))
+
+	  (when subwindows?
+	    (unless permanent-ready?
+	      (semaphore-wait mb-lock)
+	      (unless (send sub-collect-frame get-menu-bar)
+		(let ([mb (make-object menu-bar% sub-collect-frame)])
+		  (make-object menu% "Permanent" mb)))
+	      (set! permanent-ready? #t)
+	      (semaphore-post mb-lock))
+	    (let* ([mb (send sub-collect-frame get-menu-bar)]
+		   [mm (car (send mb get-items))])
+	      (send (remember (cons 'm tag) (make-object menu-item% "Delete Me" mm void)) delete)
+	      (let ([m (remember tag (make-object menu% "Temporary" mb))])
+		(remember (cons 't tag) (make-object menu-item% "Temp Hi" m void))
+		(send m delete)))))
+	  	  
+	(when atomic?
+	  (let loop ([m 8])
+	    (unless (zero? m)
+	      (remember (cons tag m) (make-object point% n m))
+	      (let ([br (make-object brush%)])
+		(remember (cons tag m) br)
+		(hash-table-put! htw br 'ok))
+	      (remember (cons tag m) (make-object pen%))
+	      (loop (sub1 m)))))
+	
+	(when offscreen?
+	  (let ([m (remember tag (make-object bitmap-dc%))]
+	        [b0 (remember (cons tag 'f) (make-object bitmap% (get-image n)))]
+		[b (remember (cons tag 'u) (make-object bitmap% 100 100))]
+		[b2 (remember (cons tag 'x) (make-object bitmap% 100 100))])
+	    (unless (send b0 ok?)
+	      (error "bitmap load error"))
+	    (send m set-bitmap b)))
+	
+	(when edit?
+	  (send ef show #f))
+	
+	(custodian-shutdown-all c)
+
+	(collect-garbage)
+
+	(maker id (sub1 n))))))
+
+(define (still)
+  (map (lambda (x)
+	 (let ([v (weak-box-value (cdr x))])
+	   (if v
+	       (printf "~s ~s~n" (car x) v))))
+       allocated)
+  (void))
+
+(define (xthread f)
+  (f))
+
+(define (stw t n)
+  '(thread-weight t (floor (/ (thread-weight t) n))))
+
+(define (breakable t)
+  (if #f
+      (thread (lambda ()
+		(read)
+		(printf "breaking~n")
+		(break-thread t)
+		(thread-wait t)
+		(printf "done~n")))
+      (void)))
+
+(define (do-test)
+  (let ([sema (make-semaphore)])
+    (let loop ([n num-threads])
+      (unless (zero? n)
+	(breakable
+	 (thread (lambda () 
+		   (stw (current-thread) n)
+		   (dynamic-wind
+		    void
+		    (lambda () (maker n num-times))
+		    (lambda () (semaphore-post sema))))))
+	(loop (sub1 n))))
+    (let loop ([n num-threads])
+      (unless (zero? n)
+	(yield sema)
+	(loop (sub1 n)))))
+
+  (collect-garbage)
+  (collect-garbage)
+  (let loop ([n 100]) 
+    (if (zero? n) 0 (sub1 (loop (sub1 n)))))
+  (collect-garbage)
+  (collect-garbage)
+  (still)
+  (when subwindows?
+    (set! sub-collect-frame #f)
+    (set! sub-collect-panel #f))
+  (when dump-stats?
+    (dump-memory-stats)
+    (still)))
+
+(do-test)
+
diff --git a/collects/tests/mred/menu-steps.txt b/collects/tests/mred/menu-steps.txt
new file mode 100644
index 0000000000..42bee5eefb
--- /dev/null
+++ b/collects/tests/mred/menu-steps.txt
@@ -0,0 +1,104 @@
+Instructions:
+ Initial Setup:
+  - Second menu is enabled "Apple"
+  Delete Apple
+  Add Apple - apple menu appears
+  Delete Tester (button)
+  Delete First Menu (button) - empty menu bar
+  Add Tester (button)
+  Add Apple
+  Delete Tester
+  Add Tester - tester now the second menu
+  Delete Apple - only tester left
+
+ Menu Inserting & Deleting:
+  Add Apple - apple menu appears
+  Add Banana - banana menu appears
+  Delete Apple (from apple menu) - apple menu goes, banana menu still there
+  Delete Banana - back to starting point
+  Add Apple
+  Add Banana
+  Delete Banana - apple still there
+  Delete Apple
+  Add Apple
+  Add Coconut - coconut submenu appears
+  Delete Coconut (from sub-menu) - coconut submenu gone
+  Delete Apple
+  Add Coconut
+  Add Apple - apple menu appears with coconut already
+  Delete Apple
+  Delete Coconut
+  Add Apple - apple menu appears without coconut
+
+ Menu Enabling:
+  Disable Second - apple menu gray & unselectable
+  Enable Second - back to normal
+  Disable Second
+  Delete Apple (from tester menu)
+  Add Apple - still gray
+  Enable Second
+
+ Item Enabling:
+  Disable Apple Once Item -> once item grayed & unselectable
+  Un-Disable Apple Once Item -> once item normal
+  Disable Apple Once Item
+  Delete Apple
+  Add Apple -> once item still gray
+  Un-Disable Apple Once Item
+  Delete Apple
+  Disable Apple Once Item
+  Add Apple -> once item gray again
+  Un-Disable Apple Once Item
+  
+ Item Inserting & Deleting:
+  Append Donut - donut item added
+  Delete Once - once item disappears
+  Delete Apple
+  Add Apple - once item still gone
+  Append Donut - another donut
+  Delete Apple
+  Append Donut
+  Add Apple - three donuts total
+
+ Emptying a Menu
+  Add Banana
+  Delete First Banana Item (in Banana Menu) - one left
+  Delete First Banana Item - none left
+  Add Delete Banana - one item again
+  Add Delete Banana - still one item
+  Delete Banana
+
+ Checkable Items & Insertions:
+  Test Apple Item -> "no"
+  Apple | Checkable - on
+  Test Apple Item -> "yes"
+  Delete Apple
+  Test Apple Item -> "yes"
+  Add Apple
+  Apple | Checkable - off
+  Test Apple Item -> "no"
+  Delete Apple
+  Test Apple Item -> "no"
+  Check in Apple (Button)
+  Test Apple Item -> "yes"
+  Add Apple
+  Apple | Checkable - off
+  Check in Apple (Button) - check is on
+  Test Apple Item -> "yes"
+  Apple | Checkable - off
+  Delete Apple
+
+ Labels (Apple & Banana currently deleted):
+  Add Coconut - (coconut item needed for the rest)
+  Test Labels - "ok" in console
+  Find Labels - "ok" in console
+  Toggle Labels - "Tester" -> "Hi", "Add Apple" -> "Apple Adder"
+  Add Apple - check that "Delete Apple" -> "Apple Deleter"
+  Delete Apple
+  Test Labels - "ok" in console
+  Find Labels - "ok" in console
+  Toggle Labels - original labels
+  Add Apple - check for original labels
+  Toggle Labels - "Delete Apple" -> "Apple Deleter"
+  Toggle Labels
+  Delete Apple
diff --git a/collects/tests/mred/nruter.xbm b/collects/tests/mred/nruter.xbm
new file mode 100644
index 0000000000..9e74923da0
--- /dev/null
+++ b/collects/tests/mred/nruter.xbm
@@ -0,0 +1,4 @@
+#define nruter_width 6
+#define nruter_height 9
+static char nruter_bits[] = {
+ 0x1e,0x1f,0x03,0x03,0x27,0x3e,0x3c,0x3c,0x3e};
diff --git a/collects/tests/mred/paramz.ss b/collects/tests/mred/paramz.ss
new file mode 100644
index 0000000000..a74786bfe9
--- /dev/null
+++ b/collects/tests/mred/paramz.ss
@@ -0,0 +1,106 @@
+
+(load-relative "loadtest.ss")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;                             Yield Tests                                    ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define s (make-semaphore))
+(define v 4)
+(queue-callback (lambda () (set! v 5)))
+(yield)
+(test v 'yield-run 5)
+(queue-callback (lambda () (set! v 6)))
+
+(semaphore-post s)
+(yield s)
+(test v 'yield-wait 5)
+(yield)
+(test v 'yield-run 6)
+
+(queue-callback (lambda () (set! v 7) (semaphore-post s)))
+(yield s)
+(test v 'yield-run-post 7)
+
+(queue-callback (lambda () 
+		  (set! v 8)
+		  (semaphore-post s)
+		  (queue-callback
+		   (lambda () (set! v 9)))))
+(yield s)
+(test v 'yield-wait-post 8)
+(yield)
+(test v 'yield-run 9)
+
+(define d (make-object dialog% "hello"))
+(thread (lambda () 
+	  (sleep 1)
+	  (queue-callback (lambda () (set! v 11)))
+	  (send d show #f)))
+(queue-callback (lambda () (set! v 10)))
+(send d show #t)
+(test v 'dialog-wait 10)
+(yield)
+(test v 'dialog-run 11)
+
+(define d (make-object dialog% "Hello"))
+(let ([t (thread (lambda ()
+		   (send d show #t)))])
+  (let loop () (unless (send d is-shown?) (loop)))
+  (st #t d is-shown?)
+  (thread-suspend t)
+  (stv d show #f)
+  (st #f d is-shown?)
+  (thread-resume t)
+  (thread-wait t)
+  (st #f d is-shown?)
+
+  (let ([t (thread (lambda ()
+		   (send d show #t)))])
+    (let loop () (unless (send d is-shown?) (loop)))
+    (st #t d is-shown?)
+    (thread-suspend t)
+    (stv d show #f)
+    (let ([t2 (thread (lambda () (send d show #t)))])
+      (sleep 0.1)
+      (thread-resume t)
+      (sleep 0.1)
+      (st #t d is-shown?)
+      (test #t 'thread2 (thread-running? t2))
+      (stv d show #f)
+      (thread-wait t)
+      (thread-wait t2)
+      (st #f d is-shown?))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;                        Parameterization Tests                              ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Killing an eventspace
+(define c (make-custodian))
+(define e (parameterize ([current-custodian c]) (make-eventspace)))
+(define tmr (parameterize ([current-eventspace e]) 
+	      (new timer% [notify-callback void])))
+(parameterize ([current-eventspace e]) (send (make-object frame% "x" #f 50 50) show #t))
+(test #f 'shutdown? (eventspace-shutdown? e))
+(custodian-shutdown-all c)
+(test #t 'shutdown? (eventspace-shutdown? e))
+(define (try-use-es t)
+  (test
+   'error
+   'shutdown-eventspace
+   (with-handlers ([(lambda (x)
+		      (and (exn:fail? x)
+			   (regexp-match "shutdown" (exn-message x))))
+		    (lambda (x)
+		      (printf "got expected error: ~a~n" (exn-message x))
+		      'error)])
+     (parameterize ([current-eventspace e]) 
+       (t)))))
+(try-use-es (lambda () (make-object frame% "x" #f 50 50)))
+(try-use-es (lambda () (make-object dialog% "x" #f 50 50)))
+(try-use-es (lambda () (make-object timer%)))
+(try-use-es (lambda () (queue-callback void)))
+(try-use-es (lambda () (send tmr start 100 #t)))
+
+(report-errs)
diff --git a/collects/tests/mred/png.ss b/collects/tests/mred/png.ss
new file mode 100644
index 0000000000..0011f1218f
--- /dev/null
+++ b/collects/tests/mred/png.ss
@@ -0,0 +1,176 @@
+(require (lib "list.ss"))
+
+(define png-suite (build-path (or (current-load-relative-directory)
+				  (current-directory))
+			      "png-suite"))
+
+(unless (directory-exists? png-suite)
+  (error 'png-test
+	 (string-append
+	  "The png-suite subdirectory appears to be missing. "
+	  "It should contain the PNG test files (including GIFs for comparisons).")))
+
+(define l (map (lambda (f) (build-path png-suite f))
+	       (quicksort
+		(filter (lambda (x) (regexp-match #rx"^[^x].*[.]png$" x))
+			(directory-list png-suite))
+		string<?)))
+
+(define (png->gif f)
+  (regexp-replace #rx"[.]png$" f ".gif"))
+
+(define f (make-object frame% "Tester"))
+(define name (new message% 
+		  [label (car l)]
+		  [parent f]
+		  [stretchable-width #t]))
+(define no-mask-bm (let* ([bm (make-object bitmap% 32 32 1)]
+			  [dc (make-object bitmap-dc% bm)])
+		     (send dc clear)
+		     (send dc draw-line 0 0 32 32)
+		     (send dc draw-line 0 32 32 0)
+		     (send dc set-bitmap #f)
+		     bm))
+
+(define last-bm (make-object bitmap% (car l)))
+
+(define ppng (make-object horizontal-panel% f))
+(define png (new message%
+		 [label last-bm]
+		 [parent ppng]
+		 [stretchable-width #t]
+		 [stretchable-height #t]))
+(define pngm (new message%
+		 [label no-mask-bm]
+		 [parent ppng]
+		 [stretchable-width #t]
+		 [stretchable-height #t]))
+(define png-canvas (new canvas%
+			[parent ppng]
+			[stretchable-width #t]
+			[stretchable-height #t]
+			[paint-callback (lambda (c dc)
+					  (send dc set-brush 
+						(send the-brush-list find-or-create-brush "GREEN" 'solid))
+					  (send dc draw-rectangle -1 -1 500 500)
+					  (send dc draw-bitmap
+						last-bm 0 0
+						'solid 
+						(send the-color-database find-color "BLACK")
+						(send last-bm get-loaded-mask)))]))
+(define ppng-mono (make-object vertical-panel% ppng))
+(define mono? (new message%
+		   [label "mono"]
+		   [parent ppng-mono]))
+(define mono-mask? (new message%
+			[label "mono mask"]
+			[parent ppng-mono]))
+(unless (= 1 (send last-bm get-depth))
+  (send mono? show #f))
+(unless (and (send last-bm get-loaded-mask)
+	     (= 1 (send (send last-bm get-loaded-mask) get-depth)))
+  (send mono-mask? show #f))
+
+(define gif (new message%
+		 [label (make-object bitmap% (png->gif (car l)))]
+		 [parent f]
+		 [stretchable-width #t]
+		 [stretchable-height #t]))
+
+(define pld (make-object group-box-panel% "Save and Reload" f))
+(new button%
+     [label "Go"]
+     [parent pld]
+     [callback (lambda (b e)
+		 (if (send last-bm save-file "tmp.png" 'png)
+		     (let ([bm (make-object bitmap% "tmp.png" (get-mask-mode) (get-bg-color))])
+		       (send ld-png set-label (if (send bm ok?)
+						  bm
+						  no-mask-bm))
+		       (send ld-pngm set-label (or (send bm get-loaded-mask)
+						   no-mask-bm))
+		       (send ld-mono? show (and (send bm ok?)
+						(= 1 (send bm get-depth))))
+		       (send ld-mono-mask? show (and (send bm get-loaded-mask)
+						     (= 1 (send (send bm get-loaded-mask) get-depth)))))
+		     (error "write failed!")))])
+(define ppld (make-object horizontal-panel% pld))
+(define ld-png (new message%
+		    [label no-mask-bm]
+		    [parent ppld]
+		    [stretchable-width #t]
+		    [stretchable-height #t]))
+(define ld-pngm (new message%
+		     [label no-mask-bm]
+		     [parent ppld]
+		     [stretchable-width #t]
+		     [stretchable-height #t]))
+(define ppld-mono (make-object vertical-panel% ppld))
+(define ld-mono? (new message%
+		      [label "mono"]
+		      [parent ppld-mono]))
+(define ld-mono-mask? (new message%
+			   [label "mono mask"]
+			   [parent ppld-mono]))
+(send ld-mono? show #f)
+(send ld-mono-mask? show #f)
+
+(define mask (new choice%
+		  [label "Alpha"]
+		  [choices '("Auto" "Mask")]
+		  [parent f]
+		  [callback (lambda (c e) (refresh))]))
+(define bg (new choice%
+		[label "Background"]
+		[choices '("Default" "White" "Black" "Red")]
+		[parent f]
+		[callback (lambda (c e) (refresh))]))
+
+(define slider
+  (new slider% 
+       [label #f]
+       [parent f]
+       [min-value 1]
+       [max-value (length l)]
+       [init-value 1]
+       [callback (lambda (s e) (refresh))]))
+(let ([p (make-object horizontal-panel% f)])
+  (make-object button% "Prev" p (lambda (b e) 
+				  (send slider set-value (max 1 (sub1 (send slider get-value))))
+				  (refresh)))
+  (make-object vertical-pane% p)
+  (make-object button% "Next" p (lambda (b e)
+				  (send slider set-value (min (length l) (add1 (send slider get-value))))
+				  (refresh))))
+
+(define (refresh)
+  (let ([n (list-ref l (sub1 (send slider get-value)))])
+    (send name set-label n)
+    (let ([bm (make-object bitmap% n (get-mask-mode) (get-bg-color))])
+      (set! last-bm bm)
+      (send png set-label bm)
+      (send pngm set-label (or (send bm get-loaded-mask)
+			       no-mask-bm)))
+    (send gif set-label (make-object bitmap% (png->gif n)))
+    (send mono? show (= 1 (send last-bm get-depth)))
+    (send mono-mask? show (and (send last-bm get-loaded-mask)
+			       (= 1 (send (send last-bm get-loaded-mask) get-depth))))
+    (send png-canvas refresh)))
+
+(define (get-mask-mode)
+  (case (send mask get-selection)
+    [(0) 'unknown]
+    [(1) 'unknown/mask]))
+
+(define get-bg-color
+  (let ([white (make-object color% 255 255 255)]
+	[black (make-object color% 0 0 0)]
+	[red (make-object color% 255 0 0)])
+    (lambda ()
+      (case (send bg get-selection)
+	[(0) #f]
+	[(1) white]
+	[(2) black]
+	[(3) red]))))
+
+(send f show #t)
diff --git a/collects/tests/mred/radiobox-steps.txt b/collects/tests/mred/radiobox-steps.txt
new file mode 100644
index 0000000000..da4304f9bb
--- /dev/null
+++ b/collects/tests/mred/radiobox-steps.txt
@@ -0,0 +1,31 @@
+
+You should see three radioboxes:
+  "Left" with one radio button: "Singleton"
+  "Center" with two radio button: "First" and "Last"
+  "Right" with three radio button: "Top", "Middle", and "Bottom"
+
+Click the "Check" button. "All Ok" should appear in the console.
+
+Click each radio button once. For each click, "Callback Ok"
+ should be printed in the console, even if the radio button
+ is already selected.
+
+Click the "Check" button. "All Ok" should appear in the console.
+
+Select the first button in all radio boxes.
+
+Click "Select First", "Select Middle", "Select Last" then
+ "Select First" again. The appropriate button should become selected
+ in all radioboxes each time. (For the two-button box, the
+ second one counts as `middle'.)
+
+Click "Select -1" and "Select N". Nothing should happen (because the
+ appropriate exceptions are caught). Select the last button in each
+ box and try "Select -1" again. Nothing should happen. Return the
+ selection to the first item in each box.
+
+Repeat the two steps for the "Select XXX by Simulate" buttons. In this
+ case, "Callback Ok" should be printed three times when any button
+ is hit. The selection should move appropriately.
+
+Click the "Check" button.
diff --git a/collects/tests/mred/random.ss b/collects/tests/mred/random.ss
new file mode 100644
index 0000000000..5a0c0913f8
--- /dev/null
+++ b/collects/tests/mred/random.ss
@@ -0,0 +1,1138 @@
+
+; (require-library "errortrace.ss" "errortrace")
+(require (lib "list.ss")
+	 (lib "etc.ss")
+	 (lib "class100.ss")
+	 (lib "defmacro.ss"))
+
+(define example-list%
+  (class100 object% (-name-in -parents [-filter (lambda (x) (not (void? x)))])
+    (private-field
+       [name-in -name-in]
+       [parents -parents]
+       [filter -filter]
+       [name name-in]
+       [items '()]
+       [num-items 0]
+       [baddies null]
+       
+       [parents-count 
+	(if parents
+	    (map (lambda (parent)
+		   (send parent get-count))
+		 parents)
+	    '())]
+       [parents-choose
+	(if parents
+	    (map (lambda (parent)
+		   (send parent get-choose-example))
+		 parents)
+	    '())])
+      (public
+       [get-count (lambda () (lambda () (count)))]
+       [get-name (lambda () name)]
+       [get-choose-example (lambda () (opt-lambda ([which #f]) (choose-example which)))]
+       [choose-parent-example
+	(lambda (which)
+	  (let loop ([pos which][counts parents-count][chooses parents-choose])
+	    (if (null? counts)
+		(void)
+		(let ([c ((car counts))])
+		  (if (< pos c)
+		      ((car chooses) pos)
+		      (loop (- pos c) (cdr counts) (cdr chooses)))))))]
+
+       [count 
+	(lambda () (+ num-items (apply + (map (lambda (x) (x)) parents-count))))]
+       [set-filter
+	(lambda (f)
+	  (set! filter f))])
+      (private-field
+       [prepare values])
+      (public
+       [set-prepare
+	(lambda (f)
+	  (set! prepare f))]
+       [add
+	(lambda (x)
+	  (if (filter x)
+	      (begin
+		(set! num-items (add1 num-items))
+		(set! items (cons x items)))
+	      (error 'add "rejected: ~a in: ~a" x name)))]
+       [all-examples
+	(lambda ()
+	  (apply append items (map (lambda (p) (send p all-examples)) parents)))]
+       [choose-example
+	(opt-lambda ([which #f])
+	  (let ([n (if which 
+		       which
+		       (let ([c (count)])
+			 (if (zero? c)
+			     0
+			     (random c))))])
+	    (if (< n num-items)
+		(prepare (list-ref items n))
+		(choose-parent-example (- n num-items)))))]
+       [add-bad
+	(lambda (i)
+	  (set! baddies (cons i baddies)))]
+       [bad-examples
+	(lambda () baddies)])
+      (sequence (super-init))))
+
+(define boxed-example-list%
+  (class100 object% (-parent)
+    (private-field [parent -parent])
+    (public
+     [get-name (lambda () `(boxed ,(send parent get-name)))]
+     [all-examples
+      (lambda ()
+	(let ([l (map box (send parent all-examples))])
+	  l))]
+     [choose-example
+      (opt-lambda ([which #f])
+	(let ([ex (send parent choose-example)])
+	  (if (void? ex)
+	      (void)
+	      (box ex))))]
+     [bad-examples
+      (lambda () (cons 5 (map box (send parent bad-examples))))])
+    (sequence (super-init))))
+
+(define listed-example-list%
+  (class100 object% (-parent)
+    (private-field [parent -parent])
+    (public
+     [get-name (lambda () `(listed ,(send parent get-name)))]
+     [all-examples
+      (lambda ()
+	(let ([l (map list (send parent all-examples))])
+	  l))]
+     [add
+      (lambda (v)
+	(unless (list? v)
+	  (error 'add "rejected: ~a in: ~a" v name))
+	(for-each
+	 (lambda (i)
+	   (send parent add i))
+	 v))]
+     [choose-example
+      (opt-lambda ([which #f])
+	(let ([ex (send parent choose-example)])
+	  (if (void? ex)
+	      (void)
+	      (list ex))))]
+     [bad-examples
+      (lambda ()
+	(cons 5 (map list (send parent bad-examples))))])
+    (sequence (super-init))))
+
+(define optional-example-list%
+  (class100 object% (-parent -val)
+    (private-field [parent -parent][val -val])
+    (public
+     [get-name (lambda () `(optional ,(send parent get-name)))]
+     [all-examples
+      (lambda ()
+	(let ([l (map box (send parent all-examples))])
+	  (cons val l)))]
+     [add
+      (lambda (x)
+	(and x (send parent add x)))]
+     [choose-example
+      (opt-lambda ([which #f])
+	(if (zero? (random 2))
+	    val
+	    (send parent choose-example)))]
+     [bad-examples
+      (lambda () (cons #t (send parent bad-examples)))])
+    (sequence (super-init))))
+
+(define choose-example-list%
+  (class100 object% (-parents)
+    (private-field [parents -parents])
+    (public
+     [get-name (lambda () `(choose ,(map (lambda (p) (send p get-name)) parents)))]
+     [all-examples
+      (lambda ()
+	(apply append (map (lambda (p) (send p all-examples)) parents)))]
+     [add (lambda (x) (void))]
+     [choose-example
+      (opt-lambda ([which #f])
+	(send (list-ref parents (random (length parents)))
+	      choose-example which))]
+     [bad-examples
+      (lambda () null)])
+    (sequence (super-init))))
+
+(define unknown-example-list%
+  (class100 object% (-who)
+    (private-field [who -who])
+    (public
+     [get-name (lambda () `(unknown ,who))]
+     [all-examples (lambda () null)]
+     [add (lambda (x) (void))]
+     [choose-example
+      (opt-lambda ([which #f])
+	(format "[dummy for ~a]" (get-name)))]
+     [bad-examples
+      (lambda () null)])
+    (sequence (super-init))))
+
+(define discrete-example-list%
+  (class100 object% (-vals)
+    (private-field [vals -vals])
+    (public
+     [get-name (lambda () `(one-of ,@vals))]
+     [all-examples (lambda () vals)]
+     [add (lambda (x) (unless (member x vals)
+			(error '|add in discrete-example-list|
+				 "no good: ~a" x)))]
+     [choose-example
+      (opt-lambda ([which #f])
+	(list-ref vals (random (length vals))))]
+     [bad-examples
+      (lambda ()
+	(if (member 'bad-example-symbol vals)
+	    null
+	    (list 'bad-example-symbol)))])
+    (sequence (super-init))))
+
+(define number-example-list%
+  (class100 object% (-parent -start -end)
+    (private-field [parent -parent]
+		   [start -start]
+		   [end -end])
+    (public
+      [get-name (lambda () `(number in ,start ,end))]
+      [all-examples
+       (lambda ()
+	 (filter (lambda (x) (ok x)) (send parent all-examples)))]
+      [ok (lambda (v) (<= start v end))]
+      [add (lambda (v)
+	     (send parent add v)
+	     (unless (ok v)
+	       (error 'add "rejected (late): ~a in: ~a" v name)))]
+      [choose-example
+       (opt-lambda ([which #f])
+	 (let loop ()
+	   (let ([v (send parent choose-example which)])
+	     (if (ok v)
+		 v
+		 (loop)))))]
+      [bad-examples
+       (lambda ()
+	 (list* (sub1 start)
+		(if (= (add1 end) end)
+		    (- start 2)
+		    (add1 end))
+		(send parent bad-examples)))])
+    (sequence (super-init))))
+
+
+(define maker-example-list%
+  (class100 object% (-maker)
+    (private-field [maker -maker])
+    (public
+     [get-name (lambda () `(make ,maker))]
+     [all-examples
+      (lambda ()
+	(list (maker)))]
+     [add (lambda (x) (void))]
+     [choose-example
+      (opt-lambda ([which #f])
+	(maker))]
+     [bad-examples
+      (lambda () null)])
+    (sequence (super-init))))
+
+(define-struct (fatal-exn exn) ())
+
+(define (fatal-error name str . args)
+  (raise (make-fatal-exn (apply format (string-append "~a: " str) name args)
+			 ((debug-info-handler)))))
+
+(define trying-class #f)
+(define trying-method #f)
+
+(define null-results null)
+
+(define-macro define-main 
+  (lambda list
+    (let loop ([l list][rest '()])
+      (if (null? l)
+	  (cons 'begin rest)
+	  (loop (cdr l)
+		(let* ([first (car l)]
+		       [name (if (symbol? first)
+				 first
+				 (car first))]
+		       [strname (symbol->string name)]
+		       [bases (if (symbol? first)
+				  ()
+				  (cdr first))]
+		       [el-name (lambda (s)
+				  (if s
+				      (string->symbol
+				       (string-append
+					(symbol->string s)
+					"-example-list"))
+				      #f))])
+		  (append
+		   `((define ,(el-name name)
+		       (make-object example-list% 
+				    ',name
+				    (list ,@(map el-name bases))
+				    (lambda (v) (when (null? v)
+						  (set! null-results (cons (list trying-class trying-method ',name)
+									   null-results))
+						  (error ',name "got null"))))))
+		   (if (or (regexp-match "%$" strname) (regexp-match "<%>$" strname))
+		       `((send ,(el-name name) set-filter (lambda (x) (is-a? x ,name)))
+			 (send ,(el-name name) add-bad 5))
+		       null)
+		   rest)))))))
+
+(define-main
+  void
+  (value char real string-list subarea<%>)
+  char
+  ubyte
+  integer
+  integer-list
+  symbol
+  real
+  real-list
+  string
+  string-list
+  mutable-string
+  bytes
+  path
+  labelstring
+  labelstring-list
+  boolean
+  procedure
+  eventspace
+  container-alignment
+
+  (area<%> window<%> subarea<%> area-container<%>)
+
+  (subarea<%> subwindow<%> pane%)
+
+  (window<%> subwindow<%> area-container-window<%>)
+
+  (area-container<%> area-container-window<%> pane%)
+
+  (subwindow<%> control<%> canvas<%> panel%)
+
+  (area-container-window<%> top-level-window<%> panel%)
+
+  (control<%> message% button% check-box% slider% gauge% text-field% combo-field% radio-box% list-control<%>)
+
+  (list-control<%> choice% list-box%)
+
+  (top-level-window<%> frame% dialog%)
+
+  (pane% horizontal-pane% vertical-pane% grow-box-spacer-pane%)
+  
+  (panel% horizontal-panel% vertical-panel%)
+
+  (canvas<%> canvas% editor-canvas%)
+
+  message%
+  button%
+  check-box%
+  slider%
+  gauge%
+  text-field%
+  combo-field%
+  radio-box%
+
+  choice%
+  list-box%
+
+  canvas%
+  editor-canvas%
+
+  horizontal-pane%
+  vertical-pane%
+  grow-box-spacer-pane%
+
+  horizontal-panel%
+  (vertical-panel% tab-panel% group-box-panel%)
+  tab-panel%
+  group-box-panel%
+
+  frame%
+  dialog%
+
+  point%
+
+  ps-setup%
+  gl-config%
+  gl-context<%>
+
+  color%
+  font%
+  brush%
+  pen%
+  region%
+  dc-path%
+
+  font-list%
+  pen-list%
+  brush-list%
+  color-database<%>
+  font-name-directory<%>
+
+  cursor%
+  bitmap%
+
+  (event% control-event% scroll-event% mouse-event% key-event%)
+  control-event%
+  scroll-event%
+  mouse-event%
+  key-event%
+
+  (dc<%> bitmap-dc% post-script-dc% printer-dc%)
+  bitmap-dc%
+  post-script-dc%
+  printer-dc%
+  
+  (menu-item-container<%> menu% menu-bar% popup-menu%)
+
+  popup-menu%
+  menu-bar%
+  
+  (menu-item<%> separator-menu-item%  labelled-menu-item<%>)
+  (labelled-menu-item<%> selectable-menu-item<%> menu%)
+  (selectable-menu-item<%> menu-item% checkable-menu-item%)
+  separator-menu-item%
+  menu-item%
+  checkable-menu-item%
+
+  menu%
+
+  timer%
+
+  add-color<%>
+  mult-color<%>
+  style-delta%
+  style<%>
+  style-list%
+
+  (editor-admin%  editor-snip-editor-admin<%>)
+  editor-snip-editor-admin<%>
+  snip-admin%
+  
+  (editor<%> text% pasteboard%)
+  text%
+  pasteboard%
+
+  (snip% string-snip% image-snip% editor-snip% readable-snip<%>)
+  (string-snip% tab-snip%)
+  tab-snip%
+  image-snip%
+  editor-snip%
+  readable-snip<%>
+
+  snip-class%
+  snip-class-list<%>
+
+  editor-data%
+  editor-data-class%
+  editor-data-class-list<%>
+
+  keymap%
+  editor-wordbreak-map%
+
+  (editor-stream-in-base% editor-stream-in-bytes-base%)
+  (editor-stream-out-base% editor-stream-out-bytes-base%)
+
+  editor-stream-in-bytes-base%
+  editor-stream-out-bytes-base%
+
+  editor-stream-in%
+  editor-stream-out%
+  
+  clipboard<%>
+  clipboard-client%)
+
+(send bitmap%-example-list set-filter (lambda (bm) (send bm ok?)))
+
+; Avoid stuck states in random testing:
+(send frame%-example-list set-prepare (lambda (w) (send w enable #t) w))
+(send dialog%-example-list set-prepare (lambda (w) (send w enable #t) w))
+
+(send boolean-example-list set-filter boolean?)
+(send char-example-list set-filter char?)
+(send string-example-list set-filter string?)
+(send bytes-example-list set-filter bytes?)
+(send mutable-string-example-list set-filter (lambda (x) (and (string? x) (not (immutable? x)))))
+(send labelstring-example-list set-filter (lambda (x) (and (string? x) ((string-length x) . <= . 200))))
+(send path-example-list set-filter path?)
+(send symbol-example-list set-filter symbol?)
+(send real-example-list set-filter real?)
+(send integer-example-list set-filter (lambda (x) (and (number? x) (exact? x) (integer? x))))
+(send integer-list-example-list set-filter (lambda (x) (and (list? x) (andmap (lambda (x) (and (number? x) (exact? x) (integer? x))) x))))
+(send real-list-example-list set-filter (lambda (x) (and (list? x) (andmap (lambda (x) (and (number? x) (real? x))) x))))
+
+(define false-example-list (make-object example-list% 'false '()))
+(send false-example-list add #f)
+(send false-example-list add-bad #t)
+
+(send char-example-list add-bad 'not-a-char)
+(send string-example-list add-bad 'not-a-string)
+(send mutable-string-example-list add-bad 'not-a-string)
+(send bytes-example-list add-bad 'not-a-bytes)
+(send path-example-list add-bad 'not-a-path)
+(send labelstring-example-list add-bad 'not-a-string)
+(send labelstring-example-list add-bad (make-string 255 #\x))
+(send symbol-example-list add-bad "not a symbol")
+(send real-example-list add-bad 4+5i) 
+(send integer-example-list add-bad 5.0)
+(send integer-list-example-list add-bad 7)
+(send real-list-example-list add-bad 7.0)
+
+(for-each (lambda (h)
+	    (for-each (lambda (v)
+			(send container-alignment-example-list add (list h v)))
+		      '(top center bottom)))
+	  '(left center right))
+
+(define input-port-example-list (make-object maker-example-list%
+					     (lambda () 
+					       (open-input-string (send string-example-list choose-example)))))
+
+(define empty-list-example-list (make-object example-list% 'empty-list '()))
+(send empty-list-example-list add null)
+(send empty-list-example-list add-bad #f)
+
+(send* boolean-example-list
+       (add #t)
+       (add #f))
+
+(send* integer-example-list
+       (add 0) (add 0) (add 0) (add 0)
+       (add 0) (add 0) (add 0) (add 0)
+       (add 0) (add 0) (add 0) (add 0)
+       (add 0) (add 0) (add 0) (add 0)
+       (add -1)
+       (add -2)
+       (add -3)
+       (add -1000)
+       (add 1)
+       (add 2)
+       (add 3)
+       (add 4)
+       (add 5)
+       (add 6)
+       (add 7)
+       (add 8)
+       (add 9)
+       (add 10)
+       (add 16)
+       (add 32)
+       (add 64)
+       (add 128)
+       (add 256)
+       (add 255)
+       (add 1023)
+       (add 1000))
+
+(send* real-example-list
+       (add 0.0) (add 0.0)
+       (add -1.0)
+       (add -2.0)
+       (add -1000.0)
+       (add 1.0)
+       (add 2.0)
+       (add 256.0)
+       (add +inf.0)
+       (add -inf.0)
+       (add 2/3)
+       (add -100/9))
+
+(define non-negative-integer-example-list (make-object number-example-list% integer-example-list 0 +inf.0))
+(define positive-integer-example-list (make-object number-example-list% integer-example-list 1 +inf.0))
+
+(define non-negative-real-example-list (make-object number-example-list% real-example-list 0 +inf.0))
+(define positive-integer-example-list (make-object number-example-list% real-example-list 1e-200 +inf.0))
+
+(define (range-integer-example-list s e)
+  (make-object number-example-list% integer-example-list s e))
+
+(define (range-real-example-list s e)
+  (make-object number-example-list% real-example-list s e))
+
+(send* symbol-example-list
+       (add 'ok) (add 'change-family))
+
+(send* string-list-example-list
+       (add '("apple" "banana" "coconut")))
+
+(send* labelstring-list-example-list
+       (add '("apple" "banana" "coconut")))
+
+(send* char-example-list
+       (add #\nul)
+       (add #\a)
+       (add #\1)
+       (add #\newline)
+       (add #\tab)
+       (add #\z)
+       (add #\C))
+
+(send* real-example-list
+       (add 0.)
+       (add 0.)
+       (add 0.)
+       (add -1.)
+       (add -2.)
+       (add -3.)
+       (add -1000.)
+       (add 1.)
+       (add 2.)
+       (add 3.)
+       (add 1000.)
+       (add 5))
+
+(send* string-example-list
+       (add "")
+       (add "hello")
+       (add "random/mred.xbm")
+       (add "random/mred.bmp")
+       (add "mred.gif")
+       (add "goodbye adious see you later zai jian seeya bye-bye"))
+
+(send* mutable-string-example-list
+       (add (make-string 10 #\x))
+       (add (make-string 10 #\nul)))
+
+(send* bytes-example-list
+       (add #"")
+       (add #"hello")
+       (add #"random/mred.xbm")
+       (add #"random/mred.bmp")
+       (add #"mred.gif")
+       (add #"goodbye adious see you later zai jian seeya bye-bye"))
+
+(send* labelstring-example-list
+       (add "")
+       (add "hello")
+       (add "goodbye adious see you later zai jian seeya bye-bye"))
+
+(send* path-example-list
+       (add (string->path "hello"))
+       (add (string->path "random/mred.xbm"))
+       (add (string->path "random/mred.bmp"))
+       (add (string->path "mred.gif")))
+
+
+(send procedure-example-list add void)
+
+(define classinfo (make-hash-table))
+
+(define (add-all-combinations example-list items)
+  (for-each
+   (lambda (i) (send example-list add i))
+   (let loop ([items items])
+     (cond
+      [(null? (cdr items)) items]
+      [else (let ([l (loop (cdr items))])
+	      (append
+	       (map (lambda (x) (bitwise-ior (car items) x)) l)
+	       l))]))))
+
+(define (optional v l) (make-object optional-example-list% l v))
+(define (boxed l) (make-object boxed-example-list% l))
+(define (unknown s) (make-object unknown-example-list% s))
+(define (choice . l) (make-object choose-example-list% l))
+(define (style-list . l) (make-object listed-example-list% (make-object discrete-example-list% l)))
+(define (symbol-in l) (make-object discrete-example-list% l))
+
+(define message-label-example-list (choice labelstring-example-list bitmap%-example-list (symbol-in '(app caution stop))))
+
+(load-relative "windowing-classes.ss")
+(load-relative "drawing-classes.ss")
+(load-relative "editor-classes.ss")
+
+(define (get-args l)
+  (let/ec bad
+    (let loop ([l l])
+      (if (null? l)
+	  '()
+	  (let* ([source (car l)]
+		 [value (send source choose-example #f)])
+	    (if (void? value)
+		(bad (format "no examples: ~a" (send source get-name)))
+		(cons value (loop (cdr l)))))))))
+
+(define (get-all-args l)
+  (let loop ([l l])
+    (if (null? l)
+	'()
+	(let* ([source (car l)]
+	       [values (send source all-examples)]
+	       [rest (loop (cdr l))])
+	  (if (null? (cdr l))
+	      (list values)
+	      (apply append
+		     (map (lambda (other)
+			    (map (lambda (v) (cons v other)) values))
+			  rest)))))))
+
+(define-struct posargs (good bads))
+
+(define (get-bad-args l)
+  (let/ec bad
+    (let loop ([l l])
+      (if (null? l)
+	  '()
+	  (let* ([source (car l)]
+		 [good (send source choose-example #f)]
+		 [bads (send source bad-examples)])
+	    (if (void? good)
+		(bad (format "no examples: ~a" (send source get-name)))
+		(cons (make-posargs good bads) (loop (cdr l)))))))))
+
+(define thread-output-port current-output-port)
+
+(define print-only? #f)
+
+(define (apply-args v dest name k)
+  (if (list? v)
+      (begin
+	(fprintf (thread-output-port) "~a: ~s" name v)
+	(flush-output (thread-output-port))
+	(if print-only?
+	    (newline)
+	    (with-handlers (((lambda (x) (not (fatal-exn? x)))
+			     (lambda (x)
+			       (fprintf (thread-output-port)
+					": error: ~a~n"
+					(exn-message x)))))
+	      (if (eq? dest 'values)
+		  (k v)
+		  (send dest add (k v)))
+	      (flush-display)
+	      (fprintf (thread-output-port) ": success~n"))))
+      (fprintf (thread-output-port) "~a: failure: ~a~n" name v)))
+
+(define (try-args arg-types dest name k)
+  (apply-args (get-args arg-types) dest name k))
+
+(define (try-all-args arg-types dest name k)
+  (let ([vs (get-all-args arg-types)])
+    (for-each (lambda (v)
+		(apply-args v dest name k))
+	      vs)))
+
+(define (apply-bad-args v dest name k bad)
+  (fprintf (thread-output-port) "~a: ~s" name v)
+  (flush-output (thread-output-port))
+  (with-handlers ([exn:fail:contract?
+		   (lambda (x)
+		     (fprintf (thread-output-port) ": exn: ~a~n"
+			      (exn-message x))
+		     ;; Check that exn is from the right place:
+		     (let ([class (if (list? name) 
+				      (let ([n (car name)])
+					(if (symbol? n)
+					    n
+					    '|.|))
+				      name)]
+			   [method (if (list? name) (cadr name) 'initialization)])
+		       (when (eq? method 'initialization)
+			 ; init is never inherited, so class name really should be present
+			 (unless (regexp-match (symbol->string class) (exn-message x))
+			   (fprintf (thread-output-port) 
+				    "  NO OCCURRENCE of class name ~a in the error message~n"
+				    class)))
+		       (unless (regexp-match (symbol->string method) (exn-message x))
+			 (fprintf (thread-output-port) 
+				  "  NO OCCURRENCE of method ~a in the error message~n"
+				  method))))]
+		  [exn:fail:contract:arity?
+		   (lambda (x)
+		     (fprintf (thread-output-port)
+			      ": UNEXPECTED ARITY MISMATCH: ~a~n"
+			      (exn-message x)))]
+		  [(lambda (x) (not (fatal-exn? x)))
+		   (lambda (x)
+		     (fprintf (thread-output-port)
+			      ": WRONG EXN TYPE: ~a~n"
+			      (exn-message x)))])
+    (k v)
+    (flush-display)
+    (fprintf (thread-output-port) ": NO EXN RAISED~n")))
+
+(define (try-bad-args arg-types dest name k)
+  (let ([args (get-bad-args arg-types)])
+    (cond
+     [(not (list? args)) (fprintf (thread-output-port) "~a: failure in bad-testing: ~a~n" name args)]
+     [else
+      (let loop ([pres null][posts args])
+	(unless (null? posts)
+	  (for-each
+	   (lambda (bad)
+	     (apply-bad-args (append
+			      (map posargs-good pres)
+			      (list bad)
+			      (map posargs-good (cdr posts)))
+			     dest name k bad))
+	   (posargs-bads (car posts)))
+	  (loop (append pres (list (car posts))) (cdr posts))))])))
+
+(define (create-some cls try)
+  (when (class? cls)
+	(let* ([v (hash-table-get classinfo cls)]
+	       [dest (car v)]
+	       [name (cadr v)]
+	       [creators (caddr v)])
+	  (let loop ([l creators])
+	    (unless (null? l)
+		    (try (car l) dest name
+			 (lambda (v)
+			   (apply make-object cls v)))
+		    (loop (cdr l)))))))
+
+(define (create-all-random)
+  (fprintf (thread-output-port) "creating all randomly...~n")
+  (hash-table-for-each classinfo (lambda (k v)
+				   (create-some k try-args))))
+(define (create-all-exhaust)
+  (fprintf (thread-output-port) "creating all exhaustively...~n")
+  (hash-table-for-each classinfo (lambda (k v)
+				   (create-some k try-all-args))))
+
+(define (create-all-bad)
+  (fprintf (thread-output-port) "creating all with bad arguments...~n")
+  (hash-table-for-each classinfo (lambda (k v)
+				   (create-some k try-bad-args))))
+
+(define (try-methods cls try)
+  (let* ([v (hash-table-get classinfo cls)]
+	 [source (car v)]
+	 [use (if source (send source choose-example) #f)]
+	 [name (cadr v)]
+	 [methods (cdddr v)])
+    (if (void? use)
+	(fprintf (thread-output-port) "~s: no examples~n" name)
+	(let loop ([l methods])
+	  (unless (null? l)
+	    (unless (symbol? (car l))
+	      (let* ([method (car l)]
+		     [iv (car method)]
+		     [resulttype (caddr method)]
+		     [argtypes (cdddr method)])
+		(set! trying-class (and source (send source get-name)))
+		(set! trying-method iv)
+		(try argtypes resulttype (list name iv use)
+		     (lambda (args)
+		       (if use
+			   (begin
+
+			     ;; Avoid showing a disabled dialog
+			     (when (and (is-a? use dialog%)
+					(eq? iv 'show)
+					(equal? args '(#t)))
+				 (send use enable #t))
+
+			     ;; Avoid excessive scaling
+			     (when (eq? iv 'set-scale)
+			       (set! args (map (lambda (x) (min x 10)) args)))
+
+			     (send-generic use (make-generic (object-interface use) iv) . args))
+
+			   (apply (namespace-variable-value iv) args))))))
+	    (loop (cdr l)))))))
+
+(define (call-random except)
+  (fprintf (thread-output-port) "calling all except ~a randomly...~n" except)
+  (hash-table-for-each classinfo (lambda (k v)
+				   (unless (member k except)
+				     (try-methods k try-args)))))
+
+(define (call-all-random)
+  (call-random null))
+
+(define (call-all-bad)
+  (fprintf (thread-output-port) "calling all with bad arguments...~n")
+  (hash-table-for-each classinfo (lambda (k v) (try-methods k try-bad-args))))
+
+(define (call-all-non-editor)
+  (call-random (list :editor-buffer% :editor-edit% :editor-snip% :editor-pasteboard% 'EditorGlobal)))
+
+(define (init)
+  (create-all-random)
+  (create-all-random)
+  (create-all-random)
+  (create-all-random))
+
+(printf " Creating Example Instances~n")  
+
+(define f (make-object frame% "Example Frame 1"))
+(send frame%-example-list add f)
+
+(define d (make-object dialog% "Example Dialog 1"))
+(send dialog%-example-list add d)
+
+(define hpl (make-object horizontal-panel% f))
+(send horizontal-panel%-example-list add hpl)
+(define vpl (make-object vertical-panel% d))
+(send vertical-panel%-example-list add vpl)
+(define gbpl (make-object group-box-panel% "ok" d))
+(send group-box-panel%-example-list add gbpl)
+(define tpl (make-object tab-panel% '("Apple" "Banana" "Coconut") d void))
+(send tab-panel%-example-list add tpl)
+(define hp (make-object horizontal-pane% d))
+(send horizontal-pane%-example-list add hp)
+(define vp (make-object vertical-pane% f))
+(send vertical-pane%-example-list add vp)
+(define sp (make-object grow-box-spacer-pane% f))
+(send grow-box-spacer-pane%-example-list add sp)
+
+(send message%-example-list add (make-object message% "Message 1" hpl))
+(send button%-example-list add (make-object button% "Button 1" vpl void))
+(send check-box%-example-list add (make-object check-box% "Check Box 1" hp void))
+(send slider%-example-list add (make-object slider% "Slider 1" -10 10 vp void))
+(send gauge%-example-list add (make-object gauge% "Gauge 1" 100 hpl))
+(send text-field%-example-list add (make-object text-field% "Text Field 1" vpl void))
+(send combo-field%-example-list add (make-object combo-field% "Combo Field 1" '("A" "B") vpl void))
+(send radio-box%-example-list add (make-object radio-box% "Radio Box 1" '("Radio Button 1.1" "Radio Button 1.2") hp void))
+(send choice%-example-list add (make-object choice% "Choice 1" '("Choice 1.1" "Choice 1.2" "Choice 1.3") vp void))
+(send list-box%-example-list add (make-object list-box% "List Box 1" '("List Box 1.1" "List Box 1.2" "List Box 1.3") hpl void))
+
+(send canvas%-example-list add (make-object canvas% f))
+(define c (make-object editor-canvas% d))
+(send editor-canvas%-example-list add c)
+
+(send point%-example-list add (make-object point% 50 60))
+
+(send ps-setup%-example-list add (make-object ps-setup%))
+
+(send color%-example-list add (make-object color% "RED"))
+(send font%-example-list add (make-object font% 12 'roman 'normal 'normal))
+(send brush%-example-list add (make-object brush% "GREEN" 'solid))
+(send pen%-example-list add (make-object pen% "BLUE" 1 'solid))
+(send region%-example-list add (make-object region% (send c get-dc)))
+(send dc-path%-example-list add (make-object dc-path%))
+(send gl-config%-example-list add (make-object gl-config%))
+(send gl-context<%>-example-list add (send (send c get-dc) get-gl-context))
+
+(send font-list%-example-list add the-font-list)
+(send pen-list%-example-list add the-pen-list)
+(send brush-list%-example-list add the-brush-list)
+(send color-database<%>-example-list add the-color-database)
+(send font-name-directory<%>-example-list add the-font-name-directory)
+
+(send cursor%-example-list add (make-object cursor% 'watch))
+(send bitmap%-example-list add (make-object bitmap% (build-path (collection-path "icons") "bb.gif")))
+
+(send control-event%-example-list add (make-object control-event% 'list-box))
+(send scroll-event%-example-list add (make-object scroll-event%))
+(send mouse-event%-example-list add (make-object mouse-event% 'left-down))
+(send key-event%-example-list add (make-object key-event%))
+
+(send bitmap-dc%-example-list add (make-object bitmap-dc%))
+(send post-script-dc%-example-list add (make-object post-script-dc% #f))
+
+(with-handlers ([void void])
+  (send printer-dc%-example-list add (make-object printer-dc%)))
+
+(define mb (make-object menu-bar% f))
+(send menu-bar%-example-list add mb)
+(define m (make-object menu% "Menu1" mb))
+(send menu%-example-list add m)
+(send popup-menu%-example-list add (make-object popup-menu% "Popup Menu 1"))
+  
+(send separator-menu-item%-example-list add (make-object separator-menu-item% m))
+(send menu-item%-example-list add (make-object menu-item% "Menu Item 1" m void))
+(send checkable-menu-item%-example-list add (make-object checkable-menu-item% "Checkable Menu Item 1" m void))
+
+(send timer%-example-list add (make-object timer%))
+
+(define sd (make-object style-delta%))
+(send add-color<%>-example-list add (send sd get-background-add))
+(send mult-color<%>-example-list add (send sd get-background-mult))
+(send style-delta%-example-list add sd)
+(define sl (make-object style-list%))
+(send style-list%-example-list add sl)
+(send style<%>-example-list add (send sl basic-style))
+
+(define e (make-object text%))
+(send c set-editor e)
+(send text%-example-list add e)
+(send pasteboard%-example-list add (make-object pasteboard%))
+
+(define s (make-object editor-snip%))
+(send e insert s)
+(send editor-snip-editor-admin<%>-example-list add (send (send s get-editor) get-admin))
+(send snip-admin%-example-list add (make-object snip-admin%))
+
+(send tab-snip%-example-list add (make-object tab-snip%))
+(send image-snip%-example-list add (make-object image-snip%))
+(send editor-snip%-example-list add (make-object editor-snip%))
+
+(require (prefix graph: (lib "graph.ss" "mrdemo")))
+(send readable-snip<%>-example-list add (make-object graph:graph-snip% '(lambda (x) x)))
+
+(send snip-class%-example-list add (make-object snip-class%))
+(send snip-class-list<%>-example-list add (get-the-snip-class-list))
+
+(send editor-data%-example-list add (make-object editor-data%))
+(send editor-data-class%-example-list add (make-object editor-data-class%))
+(send editor-data-class-list<%>-example-list add (get-the-editor-data-class-list))
+
+(send keymap%-example-list add (make-object keymap%))
+(send editor-wordbreak-map%-example-list add the-editor-wordbreak-map)
+
+(define sib (make-object editor-stream-in-bytes-base% #"Hello"))
+(send editor-stream-in-bytes-base%-example-list add sib)
+(define sob (make-object editor-stream-out-bytes-base%))
+(send editor-stream-out-bytes-base%-example-list add sob)
+
+(send editor-stream-in%-example-list add (make-object editor-stream-in% sib))
+(send editor-stream-out%-example-list add (make-object editor-stream-out% sob))
+  
+(send clipboard<%>-example-list add the-clipboard)
+(send clipboard-client%-example-list add (make-object clipboard-client%))
+
+(printf " Done Creating Example Instances~n")  
+
+(printf " Checking all methods~n")
+(define in-top-level null)
+(hash-table-for-each classinfo 
+		     (lambda (key v)
+		       (let* ([methods (cdddr v)]
+			      [names (map (lambda (x) (if (pair? x) (car x) x)) methods)])
+			 (if (string? key)
+			     ;; Check global procs/values
+			     (for-each
+			      (lambda (name method)
+				(if (void? (with-handlers ([void void])
+					     (namespace-variable-value name)))
+				    ;; Not there
+				    (printf "No such procedure/value: ~a~n" name)
+				    
+				    (let ([v (namespace-variable-value name)])
+				      (when (procedure? v)
+					;; check arity
+					(unless (or (equal? (procedure-arity v) (cadr method))
+						    (let ([a (procedure-arity v)]
+							  [b (cadr method)])
+						      (and (list? a)
+							   (list? b)
+							   (andmap integer? a)
+							   (andmap integer? b)
+							   (equal? (quicksort a <) (quicksort b <)))))
+					  (printf "Arity mismatch for ~a, real: ~a documented: ~a~n" 
+						  name (procedure-arity v) (cadr method))))))
+				
+				(set! in-top-level (cons name in-top-level)))
+			      names methods)
+			     ;; Check intf/class methods
+			     (begin
+			       (set! in-top-level (cons (cadr v) in-top-level))
+			       
+			       ; Check printed form:
+			       (let ([p (open-output-string)])
+				 (display key p)
+				 (let ([sp (get-output-string p)]
+				       [ss (let ([s (symbol->string (cadr v))])
+					     (format "#<struct:~a:~a>"
+						     (if (interface? key) "interface" "class")
+						     s))])
+				   (unless (string=? sp ss)
+				     (printf "bad printed form: ~a != ~a~n" sp ss))))
+			       
+			       ; Check documented methods are right
+			       (let ([ex (send (car v) choose-example)])
+				 (unless (is-a? ex key)
+				   (printf "Bad example: ~a for ~a~n" ex key))
+				 (for-each
+				  (lambda (name method)
+				    (if (or (and (interface? key)
+						 (method-in-interface? name key))
+					    (and (class? key)
+						 (method-in-interface? name (class->interface key))))
+					
+					;; Method is there, check arity
+					'(when (is-a? ex key)
+					  (let ([m (make-generic ex name)])
+					    (unless (equal? (arity m) (cadr method))
+					      (printf "Warning: arity mismatch for ~a in ~a, real: ~a documented: ~a~n" 
+						      name key
+						      (arity m) (cadr method)))))
+					
+					;; Not there
+					(printf "No such method: ~a in ~a~n" name key)))
+				  names methods))
+			       
+			       ; Check everything is documented
+			       (for-each
+				(lambda (n)
+				  (unless (memq n names)
+				    (printf "Undocumented method: ~a in ~a~n" n key)))
+				(interface->method-names (if (interface? key) key (class->interface key)))))))))
+(printf " Method-checking done~n")
+
+(let* ([get-all (lambda (n)
+		  (parameterize ([current-namespace n])
+		    (namespace-mapped-symbols)))]
+       [expect-n (list* 'mred@ 'mred^ 
+			(append (get-all (let ([n (make-namespace)])
+					   (parameterize ([current-namespace n])
+					     (namespace-require '(lib "class.ss")))
+					   n))
+				in-top-level))]
+       [actual-n (get-all (make-namespace-with-mred))])
+  (for-each
+   (lambda (i)
+     (unless (memq i expect-n)
+       (printf "Undocumented global: ~a~n" i)))
+   actual-n))
+
+(unless (and (>= (vector-length argv) 1)
+	     (string=? (vector-ref argv 0) "-r"))
+  (exit 0))
+
+;; Disallow writes outside of random/...
+(unless (directory-exists? "random")
+  (make-directory "random"))
+(current-security-guard (make-security-guard (current-security-guard)
+					     (lambda (who what why)
+					       (when (memq why '(write delete))
+						 (unless (regexp-match "/random/" what)
+						   (error who
+							  "not allowed to write file: ~e"
+							  what))))
+					     (lambda args 'ok)))
+
+;; Remove some things:
+(for-each (lambda (p)
+	    (let ([k (ormap (lambda (k)
+			      (and (equal? k (car p))
+				   k))
+			    (hash-table-map classinfo (lambda (k v) k)))])
+	      (hash-table-put! 
+	       classinfo k
+	       (let ([l (hash-table-get classinfo k)])
+		 (let loop ([l l])
+		   (cond
+		    [(null? l) null]
+		    [(and (pair? (car l))
+			  (eq? (cadr p) (caar l)))
+		     (cdr l)]
+		    [else (cons (car l) (loop (cdr l)))]))))))
+	  '(("Eventspaces" sleep/yield)))
+
+(random-seed 179)
+
+(create-all-bad)
+(call-all-bad)
+
+(create-all-random)
+(call-all-random)
diff --git a/collects/tests/mred/showkey.ss b/collects/tests/mred/showkey.ss
new file mode 100644
index 0000000000..b763d9e516
--- /dev/null
+++ b/collects/tests/mred/showkey.ss
@@ -0,0 +1,65 @@
+
+(require (lib "etc.ss")
+	 (lib "class100.ss"))
+
+(let ()
+  (define c%
+       (class100-asi canvas%
+	 (override
+	   [on-event
+	    (lambda (ev)
+	      (printf "~aMOUSE ~a (~a,~a)~n  meta: ~a  control: ~a  alt: ~a  shift: ~a~n  buttons: ~a ~a ~a~a~a~a~a~n" 
+		      (es-check)
+		      (send ev get-event-type)
+		      (send ev get-x)
+		      (send ev get-y)
+		      (send ev get-meta-down)
+		      (send ev get-control-down)
+		      (send ev get-alt-down)
+		      (send ev get-shift-down)
+		      (send ev get-left-down)
+		      (send ev get-middle-down)
+		      (send ev get-right-down)
+		      (if (send ev dragging?)
+			  " dragging"
+			  "")
+		      (if (send ev moving?)
+			  " moving"
+			  "")
+		      (if (send ev entering?)
+			  " entering"
+			  "")
+		      (if (send ev leaving?)
+			  " leaving"
+			  "")))]
+	   [on-char
+	    (lambda (ev)
+	      (printf "~aKEY code: ~a  rel-code: ~a~n  meta: ~a  control: ~a  alt: ~a  shift: ~a~n" 
+		      (es-check)
+		      (let ([v (send ev get-key-code)])
+			(if (symbol? v)
+			    v
+			    (format "~a = ASCII ~a" v (char->integer v))))
+		      (let ([v (send ev get-key-release-code)])
+			(if (symbol? v)
+			    v
+			    (format "~a = ASCII ~a" v (char->integer v))))
+		      (send ev get-meta-down)
+		      (send ev get-control-down)
+		      (send ev get-alt-down)
+		      (send ev get-shift-down)))])))
+  (define f (make-object (class100 frame% ()
+                           (inherit accept-drop-files)
+                           (override
+                             [on-drop-file (lambda (file)
+                                             (printf "Dropped: ~a~n" file))])
+                           (sequence
+                             (super-init "tests" #f 100 100)
+                             (accept-drop-files #t)))))
+  (define c (make-object c% f))
+  (define (es-check) (if (eq? (send f get-eventspace) (current-eventspace))
+			 ""
+			 ">>WRONG EVENTSPACE<< "))
+  (send c focus)
+  (send f show #t))
+
diff --git a/collects/tests/mred/sixlib.ss b/collects/tests/mred/sixlib.ss
new file mode 100644
index 0000000000..5521d71ea1
--- /dev/null
+++ b/collects/tests/mred/sixlib.ss
@@ -0,0 +1,300 @@
+;; load the graphics
+(require (lib "graphics.ss" "graphics")
+         (lib "etc.ss")
+         (lib "file.ss"))
+(open-graphics)
+
+(define (struct-test)
+  ;; test rgb selectors
+  (let* ([fraction 1/5]
+         [test 
+          (list
+           (rgb-red (make-rgb fraction 0 0))
+           (rgb-green (make-rgb 0 fraction 0))
+           (rgb-blue (make-rgb 0 0 fraction)))])
+    (unless (equal? (list fraction fraction fraction) test)
+      (error 'rgb "wrong: ~s" test)))
+  
+  ;; test posn selectors
+  (let* ([test
+          (list
+           (posn-x (make-posn 1 0))
+           (posn-y (make-posn 0 1)))])
+    (unless (equal? (list 1 1) test)
+      (error 'posn "wrong: ~s" test))))
+
+;; test basic operations
+(define (basic-test)
+  (let ([v (open-viewport "Tester" 200 200)])
+    ((draw-string v) (make-posn 0 20) "Reversed X; click to continue")
+    ((draw-string v) (make-posn 0 40) "(busy-waiting right now!)")
+    ((draw-line v) (make-posn 0 0) (make-posn 100 100))
+    ((draw-line v) (make-posn 100 0) (make-posn 0 100))
+    ((flip-viewport v))
+    (let loop ()
+      (unless (ready-mouse-click v)
+        (loop)))
+    
+    ((clear-viewport v))
+    ((draw-string v) (make-posn 0 20) "Cleared; click")
+    (get-mouse-click v)
+    
+    (let ([rect-draw
+           (lambda (f)
+             (f (make-posn 20 20) 60 60))]
+          [poly-draw
+           (lambda (f)
+             (f (list (make-posn 0 0) (make-posn 40 0) (make-posn 20 40)) (make-posn 20 20)))]
+          [string-draw
+           (lambda (f)
+             (f (make-posn 10 20) "XXXXX"))]
+          [shape
+           (lambda (do-draw draw clear flip name)
+             ((clear-viewport v))
+             ((draw-string v) (make-posn 0 20) (format "Centered ~s" name))
+             (do-draw (draw v))
+             (get-mouse-click v)
+             
+             ((draw-string v) (make-posn 0 40) (format "Erased ~s" name))
+             (do-draw (clear v))
+             (get-mouse-click v)
+             
+             ((clear-viewport v))
+             ((draw-string v) (make-posn 0 20) (format "Centered ~s" name))
+             (do-draw (draw v))
+             (get-mouse-click v)
+             
+             ((draw-string v) (make-posn 0 40) (format "Flipped ~s" name))
+             (do-draw (flip v))
+             (get-mouse-click v)
+             
+             ((draw-string v) (make-posn 0 40) (format "Flipped ~s back" name))
+             (do-draw (flip v))
+             (get-mouse-click v))])
+      (shape rect-draw draw-rectangle clear-rectangle flip-rectangle "box")
+      (shape rect-draw draw-solid-rectangle clear-solid-rectangle flip-solid-rectangle "solid box")
+      (shape rect-draw draw-ellipse clear-ellipse flip-ellipse "circle")
+      (shape rect-draw draw-solid-ellipse clear-solid-ellipse flip-solid-ellipse "solid circle")
+      (shape poly-draw draw-polygon clear-polygon flip-polygon "polygon")
+      (shape poly-draw draw-solid-polygon clear-solid-polygon flip-solid-polygon "solid polygon")
+      (shape string-draw
+             draw-string
+             clear-string
+             flip-string
+             "string"))
+    
+    ((clear-viewport v))
+    ((draw-string v) (make-posn 0 20) "Done; click")
+    (get-mouse-click v)
+    
+    (close-viewport v)))
+
+;; test get-pixel
+(define (pixel-test)
+  (let ([v (open-viewport "test get-pixel" 8 8)]
+        [f (lambda (x y) 
+             (if (= (modulo (+ x y) 2) 0)
+                 (make-rgb 1 1 1)
+                 (make-rgb (/ (modulo (+ x y) 3) 2)
+                           (/ (modulo (+ x y 1) 3) 2)
+                           (/ (modulo (+ x y 2) 3) 2))))]
+        
+        [unmarshall-color
+         (lambda (c)
+           (if (is-a? c color%)
+               (list (send c red)
+                     (send c green)
+                     (send c blue))
+               c))]
+
+        [for-each-point
+         (lambda (f)
+           (let loop ([i 8])
+             (unless (= i 0)
+               (let loop ([j 8])
+                 (unless (= j 0)
+                   (f (- i 1) (- j 1))
+                   (loop (- j 1))))
+               (loop (- i 1)))))])
+    (for-each-point
+     (lambda (i j)
+       ;(printf "(~a, ~a) -> ~a~n" i j (unmarshall-color (f i j)))
+       ((draw-pixel v) (make-posn i j) (f i j))))
+    ;(get-mouse-click v)
+    (for-each-point
+     (lambda (i j)
+       (let* ([cmp
+               (lambda (rgb1 rgb2)
+                 (and (= (rgb-red rgb1) (rgb-red rgb2))
+                      (= (rgb-blue rgb1) (rgb-blue rgb2))
+                      (= (rgb-green rgb1) (rgb-green rgb2))))]
+              [color-expected ((test-pixel v) (f i j))]
+              [bw-expected (if (cmp (make-rgb 1 1 1) color-expected) 0 1)]
+              [color-got ((get-color-pixel v) (make-posn i j))]
+              [bw-got ((get-pixel v) (make-posn i j))])
+         (unless (= bw-got bw-expected)
+           (error 'test-get-pixel "wrong answer for (~a,~a); got ~a expectd ~a"
+                  i j bw-got bw-expected))
+         (unless (cmp color-expected color-got)
+           (error 'test-get-color-pixel "wrong answer for (~a,~a); got ~a expected ~a"
+                  i j
+                  (unmarshall-color color-got)
+                  (unmarshall-color color-expected))))))
+    (close-viewport v)))
+
+(define (snip-test)
+  ;; test snips
+  (let ([vp (open-pixmap "snip test" 100 100)])
+    ((draw-string vp) (make-posn 20 30) "flipped rect")
+    ((flip-solid-rectangle vp) (make-posn 10 10) 80 80)
+    (display (viewport->snip vp))))
+
+(define (color-test)
+  (let ([v (open-viewport "Color Tester" 100 200)])
+    ((draw-solid-rectangle v) (make-posn 10 10) 80 80 (make-rgb 1 0 0))
+    ((draw-solid-ellipse v) (make-posn 10 10) 80 80 (make-rgb 0 1 0))
+    ((draw-line v) (make-posn 10 10) (make-posn 90 90) (make-rgb 0 0 1))
+    ((draw-string v) (make-posn 10 100) "red rectangle")
+    ((draw-string v) (make-posn 10 120) "green ellipse")
+    ((draw-string v) (make-posn 10 140) "blue line")
+    (get-mouse-click v)
+    
+    ((draw-viewport v) (make-rgb 1 0 0))
+    ((draw-string v) (make-posn 10 100) "solid red")
+    (get-mouse-click v)
+    
+    ((draw-viewport v))
+    ((clear-string v) (make-posn 10 100) "solid black")
+    (get-mouse-click v)
+    
+    (close-viewport v)))
+
+(define (pixmap-test)
+  (local [(define width 500)
+          (define height 500)
+          (define pixmap-filename (build-path (collection-path "icons") "plt.gif"))
+          (define view-port (open-viewport "pixmap tests" width height))
+          (define (line)
+            ((draw-line view-port) (make-posn 50 50) (make-posn 450 450)))
+          (define (next desc)
+            ((draw-string view-port) (make-posn 0 (- height 50)) desc)
+            ((draw-string view-port) (make-posn 0 (- height 30)) "click to continue")
+            (get-mouse-click view-port)
+            ((clear-viewport view-port)))]
+    
+    (line)
+    (((draw-pixmap-posn pixmap-filename) view-port) (make-posn 0 0))
+    (next "draw line then draw-pixmap-posn")
+    
+    (line)
+    ((draw-pixmap view-port) pixmap-filename (make-posn 0 0))
+    (next "pixmap-functions: draw line then draw-pixmap")
+    
+    (line)
+    ((draw-pixmap view-port) pixmap-filename (make-posn 0 0))
+    (let ([fn (make-temporary-file)])
+      ((save-pixmap view-port) fn)
+      ((clear-viewport view-port))
+      (next (format "same image; saved to ~a and cleared..." fn))
+      ((draw-pixmap view-port) fn (make-posn 0 0))
+      (delete-file fn)
+      (next "re-loaded"))
+    
+    (close-viewport view-port)))
+
+(define (copy-viewport-test)
+  (let* ([width 100]
+         [height 100]
+         [vs (open-viewport "viewport source" width height)]
+         [vd (open-viewport "viewport dest" width height)])
+    
+    ((draw-ellipse vs) (make-posn 10 10) 80 80)
+    ((draw-string vs) (make-posn 10 30) "Click")
+    (get-mouse-click vs)
+    (copy-viewport vs vd)
+    ((clear-viewport vs))
+    ((draw-string vs) (make-posn 10 30) "Cleared")
+    (get-mouse-click vd)
+    (void)))
+
+(define (keyboard-test)
+  (let ([v (open-viewport "keyboard" 300 200)]
+        [RED (make-rgb 1 0 0)]
+        [BLACK (make-rgb 0 0 0)])
+    ((draw-string v) (make-posn 5 15) "Type, end with return (red is from key-ready):")
+    (let loop ([x 5])
+      (let* ([kv (or (begin
+                       ((draw-rectangle v) (make-posn 290 0) 10 10 RED)
+                       (ready-key-press v))
+                     (begin
+                       ((draw-rectangle v) (make-posn 290 0) 10 10 BLACK)
+                       (cons 'slow (get-key-press v))))]
+             [k (key-value (if (pair? kv) (cdr kv) kv))])
+        ((clear-rectangle v) (make-posn 0 290) 10 10)
+        (cond
+          [(eq? k #\return) 'done]
+          [(char? k) (let ([s (string k)])
+                       ((draw-string v) (make-posn x 50) s
+                        (if (pair? kv)
+                            BLACK
+                            RED))
+                       (sleep 0.05) ; slow down so key-ready takes effect
+                       (loop (+ x (car ((get-string-size v) s)))))]
+          [else (loop x)])))
+    (close-viewport v)))
+
+(define (color-accepting-test)
+  (let* ([vp (open-viewport "viewport" 200 200)]
+	 [operations
+	  (list
+	   (draw-viewport vp)
+	   (lambda (c) ((draw-pixel vp) (make-posn 0 0) c))
+	   (lambda (c) ((draw-line vp) (make-posn 0 0) (make-posn 100 100) c))
+	   (lambda (c) ((draw-rectangle vp) (make-posn 0 0) 10 10 c))
+	   (lambda (c) ((flip-rectangle vp) (make-posn 0 0) 10 10 c))
+	   (lambda (c) ((draw-solid-rectangle vp) (make-posn 0 0) 10 10 c))
+	   (lambda (c) ((flip-solid-rectangle vp) (make-posn 0 0) 10 10 c))
+	   (lambda (c) ((draw-ellipse vp) (make-posn 0 0) 10 10 c))
+	   (lambda (c) ((flip-ellipse vp) (make-posn 0 0) 10 10 c))
+	   (lambda (c) ((draw-solid-ellipse vp) (make-posn 0 0) 10 10 c))
+	   (lambda (c) ((flip-solid-ellipse vp) (make-posn 0 0) 10 10 c))
+	   (lambda (c) ((draw-polygon vp)
+			(list (make-posn 0 0)
+			      (make-posn 10 10)
+			      (make-posn 0 10))
+			(make-posn 20 20)
+			c))
+	   (lambda (c) ((draw-solid-polygon vp)
+			(list (make-posn 0 0)
+			      (make-posn 10 10)
+			      (make-posn 0 10))
+			(make-posn 20 20)
+			c))
+	   (lambda (c) ((draw-string vp) (make-posn 40 40) "abcd" c))
+	   (lambda (c) (((draw-pixmap-posn (build-path (collection-path "icons") "bb.gif"))
+			 vp)
+			(make-posn 20 0)
+			c))
+	   (lambda (c) ((draw-pixmap vp)
+			(build-path (collection-path "icons") "bb.gif")
+			(make-posn 0 0)
+			c)))])
+    (for-each (lambda (c)
+		(c "red")
+		(c "blue")
+		(c "black")
+		(c (make-rgb .3 .5 .1)))
+	      operations)
+    (close-viewport vp)))
+	     
+(struct-test)
+(basic-test)
+(pixel-test)
+(color-test)
+(snip-test)
+(pixmap-test)
+(copy-viewport-test)
+(keyboard-test)
+(color-accepting-test)
+
+(close-graphics)
diff --git a/collects/tests/mred/slider-steps.txt b/collects/tests/mred/slider-steps.txt
new file mode 100644
index 0000000000..41fb488bd7
--- /dev/null
+++ b/collects/tests/mred/slider-steps.txt
@@ -0,0 +1,21 @@
+
+The slider's initial value should be 3. The range is -1 to 11.
+
+Change the slider value in each way allowed by the control (dragging,
+ clicking in page-up/page-down, clicking on one-step arrows). For
+ each change, the console should contain "Callback Ok". When you
+ drag, one callback may be reported for the whole drag, or
+ intermediate callbacks may be reported.
+
+Click "Up" until the slider is at the top; a mismatch exception should
+ be reported. Click "Down" once aand verify that the slider is at 10.
+
+Repeat the above step for "Down" (checking for an exception when the
+ slider is already at its minimum value).
+
+Repeat the above two steps for "Simulate Up" and "Simulate Down". For
+ the simulates, the console should report "Callback Ok" for each click.
+ If you try to go too far up or down, the console should report an
+ error: "slider value mismatch".
+
+Click the "Check" button. The console should report "All Ok".
diff --git a/collects/tests/mred/testing.ss b/collects/tests/mred/testing.ss
new file mode 100644
index 0000000000..2566c51b2d
--- /dev/null
+++ b/collects/tests/mred/testing.ss
@@ -0,0 +1,59 @@
+
+;; MrEd automatic testing basic functions and macros
+
+(require (lib "class.ss"))
+
+(define errs null)
+(define test-count 0)
+
+(define (test expect name got)
+  (set! test-count (add1 test-count))
+  (unless (equal? expect got)
+    (let ([s (format "~a: expected ~e; got ~e" name expect got)])
+      (printf "ERROR: ~a~n" s)
+      (set! errs (cons s errs)))))
+
+(define-syntax mismatch
+  (lambda (stx)
+    (syntax-case stx ()
+      [(_ expr)
+       (syntax
+	(test 'was-mismatch 'mismtach
+	      (with-handlers ([exn:fail:contract?
+			       (lambda (x)
+				 (fprintf (current-error-port) "~a~n" (exn-message x))
+				 'was-mismatch)]
+			      [exn:fail? values])
+		expr)))])))
+
+(define-syntax st
+  (lambda (stx)
+    (syntax-case stx ()
+      [(_ val obj method . args)
+       (syntax
+	(test val 'method (send obj method . args)))])))
+
+(define-syntax stv
+  (lambda (stx)
+    (syntax-case stx ()
+      [(_ . args)
+       (syntax (st (void) . args))])))
+
+(define-syntax stvals
+  (lambda (stx)
+    (syntax-case stx ()
+      [(_ vals obj method . args)
+       (syntax
+	(test vals 'method (call-with-values (lambda () (send obj method . args)) list)))])))
+
+(define (report-errs)
+  (newline)
+  (if (null? errs)
+      (printf "Passed all ~a tests~n" test-count)
+      (begin
+	(printf "~a Error(s) in ~a tests~n" (length errs) test-count)
+	(for-each
+	 (lambda (s)
+	   (printf "~a~n" s))
+	 (reverse errs)))))
+
diff --git a/collects/tests/mred/text-scale.ss b/collects/tests/mred/text-scale.ss
new file mode 100644
index 0000000000..bf5451cc53
--- /dev/null
+++ b/collects/tests/mred/text-scale.ss
@@ -0,0 +1,145 @@
+
+(require (lib "math.ss"))
+
+(define measure-after? #f)
+(define rotate? #f)
+(define symbol? #f)
+(define latin-1? #f)
+(define less-aa? #f)
+(define lucida? #f)
+(define change-font? #f)
+(define big-font? #f)
+(define squash? #f)
+(define one-by-one? #f)
+(define shift+10+20? #f)
+
+(define last-scale 1.5)
+
+(define no-brush (make-object brush% "white" 'transparent))
+(define xor-pen (make-object pen% "black" 0 'xor))
+(define yellow (make-object color% "yellow"))
+
+(define (get-the-font size)
+  (apply
+   make-object font% 
+   size
+   (append
+    (if lucida?
+	'("-*-lucida")
+	'())
+    (list
+     (if symbol? 'symbol 'default)
+     'normal 'normal
+     #f (if less-aa? 'partly-smoothed 'default)))))
+
+(define (draw-one dc str sx sy y w h d)
+  (define csx 1)
+  (define csy 1)
+  (send dc set-text-mode 'solid)
+  (send dc set-text-background yellow)
+  (if change-font?
+      (begin
+	(send dc set-font (get-the-font (inexact->exact (floor (* sy (if big-font? 14 12))))))
+	(set! csx sx)
+	(set! csy sy)
+	(set! sx 1)
+	(set! sy 1))
+      (send dc set-scale sx sy))
+  (if rotate?
+      (send dc draw-text str (/ 100 sx) (/ y sy) #f 0 (* pi -1/4))
+      (if one-by-one?
+	  (let loop ([s (string->list str)]
+		     [x (/ 100 sx)])
+	    (unless (null? s)
+	      (send dc draw-text (string (car s)) x (/ y sy))
+	      (let-values ([(w h d a) (send dc get-text-extent (string (car s)))])
+		(loop (cdr s) (+ x w)))))
+	  (send dc draw-text str  (/ 100 sx) (/ y sy))))
+  (if measure-after?
+      (let-values ([(w h d a) (send dc get-text-extent str)])
+	(send dc draw-rectangle (/ 100 sx) (/ y sy) w h))
+      (send dc draw-rectangle (/ 100 sx) (/ y sy) (* w csx) (* h csy)))
+  (send dc set-scale 1 1))
+
+(define (squash v)
+  (if squash? 1 v))
+
+(define (draw-all dc)
+  (define normal-font (get-the-font (if big-font? 14 12)))
+  (define str (format "This is a t~ast"
+		      (if latin-1? "\351" "e")))
+  (send dc set-font normal-font)
+  (send dc set-brush no-brush)
+  (send dc set-pen xor-pen)
+  (when shift+10+20?
+    (send dc set-origin 10 20))
+  (let-values ([(w h d a) (send dc get-text-extent str)])
+    (draw-one dc str 1 1 10 w h d)
+    (draw-one dc str 2 2 (+ 15 h) w h d)
+    (draw-one dc str 0.9 0.9 (+ 20 (* 3 h)) w h d)
+    (draw-one dc str 0.75 0.75 (+ 25 (* 4 h)) w h d)
+    (draw-one dc str 2 1 (+ 30 (* 5 h)) w h d)
+    (draw-one dc str 1 2 (+ 40 (* 6 h)) w h d)
+    (draw-one dc str 2.1 (squash 2.1) (+ 45 (* 8 h)) w h d)
+    (draw-one dc str 2.05 (squash 2.05) (+ 45 (* 10.2 h)) w h d)
+    (draw-one dc str 1.95 (squash 1.95) (+ 50 (* 12.2 h)) w h d)
+    (draw-one dc str 1.93 (squash 1.93) (+ 55 (* 14.2 h)) w h d)
+    (draw-one dc str 1.90 (squash 1.90) (+ 60 (* 16.2 h)) w h d)
+    (draw-one dc str last-scale (squash last-scale) (+ 65 (* 18.2 h)) w h d))
+  (when shift+10+20?
+    (send dc set-origin 0 0)))
+
+(define f (new frame%
+	       [label "Scale Test"]
+	       [width 400]
+	       [height 500]))
+
+(define pane1 (new horizontal-pane% 
+		   [parent f]
+		   [stretchable-height #f]))
+(define pane2 (new horizontal-pane% 
+		   [parent f]
+		   [stretchable-height #f]))
+
+(define-syntax make-checkbox
+  (syntax-rules ()
+    [(_ who pane)
+     (new check-box% 
+	  [label (symbol->string 'who)]
+	  [parent pane]
+	  [callback (lambda (cb e)
+		      (set! who (send cb get-value))
+		      (send c refresh))])]))
+
+(make-checkbox measure-after? pane1)
+(make-checkbox change-font? pane1)
+(make-checkbox rotate? pane1)
+(make-checkbox one-by-one? pane1)
+(make-checkbox symbol? pane2)
+(make-checkbox latin-1? pane2)
+(make-checkbox less-aa? pane2)
+(make-checkbox lucida? pane2)
+(make-checkbox big-font? pane2)
+(make-checkbox squash? pane2)
+(make-checkbox shift+10+20? pane2)
+
+(new slider%
+     [label #f]
+     [parent f]
+     [style '(horizontal)]
+     [min-value 1]
+     [max-value 100]
+     [init-value 30]
+     [callback (lambda (s e)
+		 (set! last-scale (/ (send s get-value) 20))
+		 (send c refresh))])
+		 
+
+(define c (new canvas%
+	       [parent f]
+	       [paint-callback
+		(lambda (c dc)
+		  (send dc clear)
+		  (draw-all dc))]))
+
+(send f show #t)
diff --git a/collects/tests/mred/windowing.ss b/collects/tests/mred/windowing.ss
new file mode 100644
index 0000000000..e0b0a9efbd
--- /dev/null
+++ b/collects/tests/mred/windowing.ss
@@ -0,0 +1,1025 @@
+
+(load-relative "loadtest.ss")
+
+(define shorter? #t)
+
+; These message boxes mustn't survive
+(let ([c (make-custodian)])
+  (parameterize ([current-custodian c])
+    (parameterize ([current-eventspace (make-eventspace)])
+      (queue-callback
+       (lambda ()
+	 (queue-callback
+	  (lambda ()
+	    (sleep/yield 0.1)
+	    (queue-callback
+	     (lambda ()
+	       (custodian-shutdown-all c)))
+	    (message-box "w" "q")))
+	 (message-box "x" "y"))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;                           Windowing Tests                                  ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-syntax FAILS (lambda (stx) (syntax (void))))
+
+(define (pause)
+  (let ([s (make-semaphore)])
+    (flush-display)
+    (thread (lambda () (sleep 0.01) (semaphore-post s)))
+    (test s 'yield (yield s))))
+
+(let ([s (make-semaphore 1)])
+  (test s 'yield-wrapped (yield s)))
+(let ([s (make-semaphore 1)])
+  (test (list s) 'yield-wrapped (yield (wrap-evt s (lambda (v) (list v))))))
+(let ([s (make-semaphore)])
+  (thread (lambda () (sleep 0.01) (semaphore-post s)))
+  (test (list s) 'yield-wrapped (yield (wrap-evt s (lambda (v) (list v))))))
+
+(define (enable-tests f)
+  (printf "Enable ~a~n" f)
+  (st #t f is-enabled?)
+  (stv f enable #f)
+  (st #f f is-enabled?)
+  (stv f enable #t)
+  (st #t f is-enabled?))
+
+(define (drop-file-tests f)
+  (printf "Drop File ~a~n" f)
+  (st #f f accept-drop-files)
+  (stv f accept-drop-files #t)
+  (st #t f accept-drop-files)
+  (stv f accept-drop-files #f)
+  (st #f f accept-drop-files))
+
+(define (client->screen-tests f)
+  (printf "Client<->Screen ~a~n" f)
+  (let-values ([(x y) (send f client->screen 0 0)])
+    (stvals '(0 0) f screen->client x y))
+  (let-values ([(x y) (send f screen->client 0 0)])
+    (stvals '(0 0) f client->screen x y))
+  (let-values ([(cw ch) (send f get-client-size)]
+	       [(w h) (send f get-size)])
+    (test #t `(client-size ,f ,cw ,ch ,w ,h) (and (<= 1 cw w) (<= 1 ch h))))
+  (stv f refresh))
+
+(define (area-tests f sw? sh? no-stretch?)
+  (printf "Area ~a~n" f)
+  (let ([x (send f min-width)]
+	[y (send f min-height)])
+    (st sw? f stretchable-width)
+    (st sh? f stretchable-height)
+    (stv (send f get-top-level-window) reflow-container)
+    (pause) ; to make sure size has taken effect
+    (let-values ([(w h) (if no-stretch?
+			    (send f get-size)
+			    (values 0 0))])
+      (printf "Size ~a x ~a~n" w h)
+      (when no-stretch?
+	(stv f min-width w) ; when we turn of stretchability, don't resize
+	(stv f min-height h))
+      (stv f stretchable-width #f)
+      (stv f stretchable-height #f)
+      (st #f f stretchable-width)
+      (st #f f stretchable-height)
+      (stv f stretchable-width #t)
+      (stv f stretchable-height #t)
+      (st #t f stretchable-width)
+      (st #t f stretchable-height)
+      (stv f stretchable-width sw?)
+      (stv f stretchable-height sh?))
+    (stv f min-width x)
+    (stv f min-height y)))
+
+(define (containee-tests f sw? sh? m)
+  (area-tests f sw? sh? #f)
+  (printf "Containee ~a~n" f)
+  (st m f horiz-margin)
+  (st m f vert-margin)
+  (stv f horiz-margin 3)
+  (st 3 f horiz-margin)
+  (st m f vert-margin)
+  (stv f horiz-margin m)
+  (stv f vert-margin 3)
+  (st m f horiz-margin)
+  (st 3 f vert-margin)
+  (stv f vert-margin m))
+
+(define (container-tests f win?)
+  (printf "Container ~a~n" f)
+  (let-values ([(x y) (send f get-alignment)])
+    (stv f set-alignment 'right 'bottom)
+    (stvals '(right bottom) f get-alignment)
+    (stv f set-alignment x y)))
+
+(define (cursor-tests f)
+  (printf "Cursor ~a~n" f)
+  (let ([c (send f get-cursor)])
+    (stv f set-cursor c)
+    (st c f get-cursor)
+    (begin-busy-cursor)
+    (end-busy-cursor)
+    (st c f get-cursor)
+    (stv f set-cursor #f)
+    (st #f f get-cursor)
+    (begin-busy-cursor)
+    (end-busy-cursor)
+    (st #f f get-cursor)
+    (stv f set-cursor c)))
+
+(define (show-tests f)
+  (unless (is-a? f dialog%)
+    (printf "Show ~a~n" f)
+    (let ([on? (send f is-shown?)])
+      (stv f show #f)
+      (when on?
+	(stv f show #t)))))
+
+(define (window-tests f sw? sh? parent top m)
+  (st parent f get-parent)
+  (st top f get-top-level-window)
+  (enable-tests f)
+  (drop-file-tests f)
+  (client->screen-tests f)
+  (cursor-tests f)
+  (show-tests f))
+
+(define (containee-window-tests f sw? sh? parent top m)
+  (window-tests f sw? sh? parent top m)
+  (containee-tests f sw? sh? m))
+
+(define (test-control-event e types)
+  (test #t 'event-instance (is-a? e control-event%)) 
+  (test #t 'event-type (pair? (memq (send e get-event-type) types))))
+
+(define (label-test b l)
+  (let ([&-l (format "&~a" l)]
+	[my-l (format "My ~a" l)]
+	[&-my-l (format "&My ~a" l)])
+    (st &-l b get-label)
+    (st l b get-plain-label)
+    (stv b set-label &-my-l)
+    (st &-my-l b get-label)
+    (st my-l b get-plain-label)
+    (stv b set-label &-l)))
+			      
+(let ([f (make-object frame% "Yes & No" #f 150 151 20 21)])
+  (let ([init-tests
+	 (lambda ()
+	   (st "Yes & No" f get-label)
+	   (st "Yes  No" f get-plain-label)
+	   (stv f set-label "Yeah & Nay")
+	   (st "Yeah & Nay" f get-label)
+	   (st "Yeah  Nay" f get-plain-label)
+	   (stv f set-label "Yes & No")
+	   (st #f f get-parent)
+	   (st f f get-top-level-window)
+	   (st 20 f get-x)
+	   (st 21 f get-y)
+	   (st 150 f get-width)
+	   (st 151 f get-height)
+	   (stvals (list (send f get-width) (send f get-height)) f get-size)
+	   (st #f f has-status-line?)
+	   (st #f f is-iconized?)
+	   (st #f f get-menu-bar))]
+	[space-tests
+	 (lambda ()
+	   (printf "Spacing~n")
+	   (let ([b (send f border)])
+	     (stv f border 25)
+	     (st 25 f border)
+	     (stv f border b))
+	   (let ([s (send f spacing)])
+	     (stv f spacing 7)
+	     (st 7 f spacing)
+	     (stv f spacing s)))]
+	[enable-tests
+	 (lambda () (enable-tests f))]
+	[drop-file-tests
+	 (lambda ()
+	   (drop-file-tests f))]
+	[client->screen-tests
+	 (lambda ()
+	   (printf "Client<->Screen~n")
+	   (let-values ([(x y) (send f client->screen 0 0)])
+	     (stvals '(0 0) f screen->client x y))
+	   (let-values ([(x y) (send f screen->client 0 0)])
+	     (stvals '(0 0) f client->screen x y)))]
+	[container-tests
+	 (lambda ()
+	   (printf "Container~n")
+	   (area-tests f #t #t #t)
+	   (let-values ([(x y) (send f container-size null)])
+	     (st x f min-width)
+	     (st y f min-height))
+	   (container-tests f #t))]
+	[cursor-tests
+	 (lambda ()
+	   (test #t 'get-cursor-kind (is-a? (send f get-cursor) cursor%))
+	   (cursor-tests f))])
+
+    (st (current-eventspace) f get-eventspace)
+    (st #t f can-close?)
+    (st #t f can-exit?)
+    (stv f focus)
+
+    (space-tests)
+    (enable-tests)
+    (client->screen-tests)
+    (container-tests)
+    (cursor-tests)
+
+    (printf "Init~n")
+    (init-tests)
+    (stv f show #t)
+    (pause)
+    (printf "Show Init~n")
+    (init-tests)
+    (stv f show #f)
+    (pause)
+    (printf "Hide Init~n")
+    (init-tests)
+    (send f show #t)
+    (pause)
+
+    (space-tests)
+    (enable-tests)
+    (client->screen-tests)
+    (container-tests)
+
+    (stv f change-children values)
+    
+    (printf "Iconize~n")
+    (stv f iconize #t)
+    (pause)
+    (pause)
+    (st #t f is-iconized?)  ; NB: test will fail on MacOS
+    (stv f show #t)
+    (pause)
+    (st #f f is-iconized?)
+    
+    (stv f maximize #t)
+    (pause)
+    (stv f maximize #f)
+    (pause)
+
+    (printf "Move~n")
+    (stv f move 34 37)
+    (pause)
+    (FAILS (st 34 f get-x))
+    (FAILS (st 37 f get-y))
+    (st 150 f get-width)
+    (st 151 f get-height)
+
+    (printf "Resize~n")
+    (stv f resize 56 57)
+    (pause)
+    (FAILS (st 34 f get-x))
+    (FAILS (st 37 f get-y))
+    (st 56 f get-width)
+    (st 57 f get-height)
+
+    (stv f center)
+    (pause)
+    (st 56 f get-width)
+    (st 57 f get-height)
+
+    (client->screen-tests)
+
+    (stv f create-status-line)
+    (stv f set-status-text "Hello")
+
+    (stv f change-children values)
+    (st null f get-children)
+    (stvals '(center top) f get-alignment)
+
+    (stv f focus)
+
+    (cursor-tests)
+
+    (printf "Menu Bar~n")
+    (let ([mb (make-object menu-bar% f)])
+      (st mb f get-menu-bar)
+      (st f mb get-frame)
+      (st null f get-children)
+
+      (st #t mb is-enabled?)
+      (stv mb enable #f)
+      (st #f mb is-enabled?)
+      (stv mb enable #t)
+      (st #t mb is-enabled?)
+      
+      (st null mb get-items)
+
+      (printf "Menu 1~n")
+      (let* ([m (make-object menu% "&File" mb)]
+	     [i m]
+	     [delete-enable-test (lambda (i parent empty)
+				   (printf "Item~n")
+				   (st #f i is-deleted?)
+				   (st #t i is-enabled?)
+				   
+				   (stv i delete)
+				   (st #t i is-deleted?)
+				   (st empty parent get-items)
+				   (stv i restore)
+				   (st #f i is-deleted?)
+				   
+				   (stv i enable #f)
+				   (st #f i is-enabled?)
+				   (stv i enable #t)
+				   (st #t i is-enabled?)
+
+				   (stv i delete)
+				   (st #t i is-enabled?)
+				   (stv i enable #f)
+				   (st #f i is-enabled?)
+				   (stv i restore)
+				   (st #f i is-deleted?)
+				   (st #f i is-enabled?)
+				   (stv i enable #t)
+
+				   (let ([l (send i get-help-string)])
+				     (stv i set-help-string "Yikes")
+				     (st "Yikes" i get-help-string)
+				     (stv i set-help-string #f)
+				     (st #f i get-help-string)
+				     (stv i set-help-string l))
+
+				   (let ([l (send i get-label)])
+				     (stv i set-label "Matthew")
+				     (st "Matthew" i get-label)
+				     (stv i set-label l)))]
+	     [hit #f])
+	(st (list i) mb get-items)
+	(st mb i get-parent)
+
+	(st "&File" i get-label)
+	(st "File" i get-plain-label)
+	(st #f i get-help-string)
+
+	(delete-enable-test i mb null)
+
+	(st null m get-items)
+
+	(printf "Menu Items~n")
+	(let ([i1 (make-object menu-item% "&Plain" m 
+			       (lambda (i e)
+				 (test-control-event e '(menu))
+				 (test hit 'expected-plain-menu i)
+				 (set! hit 'plain)
+				 'oops)
+			       #f "Help")]
+	      [i2 (make-object separator-menu-item% m)]
+	      [i3 (make-object checkable-menu-item% "Che&ckable" m 
+			       (lambda (i e)
+				 (test-control-event e '(menu))
+				 (test hit 'expected-check-menu i)
+				 (set! hit 'check)
+				 'oops)
+			       #\C)]
+	      [shortcut-test
+	       (lambda (i empty name)
+		 (delete-enable-test i m empty)
+		 
+		 (printf "Shortcut~n")
+		 (set! hit i)
+		 (stv i command (make-object control-event% 'menu))
+		 (test name 'hit-command hit)
+		 
+		 (let ([c (send i get-shortcut)])
+		   (stv i set-shortcut #\M)
+		   (st #\M i get-shortcut)
+		   (stv i set-shortcut #f)
+		   (st #f i get-shortcut)
+		   (stv i set-shortcut c))
+		 
+		 (st 'meta i get-x-shortcut-prefix)
+		 (let ([p (send i get-x-shortcut-prefix)])
+		   (stv i set-x-shortcut-prefix 'alt)
+		   (st 'alt i get-x-shortcut-prefix)
+		   (stv i set-x-shortcut-prefix 'ctl)
+		   (st 'ctl i get-x-shortcut-prefix)
+		   (stv i set-x-shortcut-prefix 'ctl-m)
+		   (st 'ctl-m i get-x-shortcut-prefix)
+		   (stv i set-x-shortcut-prefix 'alt)))])
+	  (st (list i1 i2 i3) m get-items)
+	  
+	  (st "&Plain" i1 get-label)
+	  (st "Plain" i1 get-plain-label)
+	  (st "Help" i1 get-help-string)
+	  (st #f i1 get-shortcut)
+
+	  (st "Che&ckable" i3 get-label)
+	  (st "Checkable" i3 get-plain-label)
+	  (st #f i3 get-help-string)
+	  (st #\C i3 get-shortcut)
+
+	  (shortcut-test i1 (list i2 i3) 'plain)
+	  (shortcut-test i3 (list i2 i1) 'check)
+
+	  (st (list i2 i1 i3) m get-items)
+	  (stv i2 delete)
+	  (st #t i2 is-deleted?)
+	  (st (list i1 i3) m get-items)
+	  (stv i2 restore)
+	  (st #f i2 is-deleted?)
+	  (st (list i1 i3 i2) m get-items)
+
+	  'done)
+
+	(printf "Menu 2~n")
+	(let* ([m2 (make-object menu% "&Edit" mb "Help Edit")]
+	       [i2 m2])
+	  (st (list i i2) mb get-items)
+	  (st mb i2 get-parent)
+
+	  (st "&Edit" i2 get-label)
+	  (st "Edit" i2 get-plain-label)
+	  (st "Help Edit" i2 get-help-string)
+
+	  (delete-enable-test i2 mb (list i))
+
+	  (st null m2 get-items)
+
+	  ; Move orig to end
+	  (stv i delete)
+	  (stv i restore)
+	  (st (list i2 i) mb get-items)))
+
+      'done)))
+
+(define frame (let ([l (get-top-level-windows)])
+		(test 1 'list-size (length l))
+		(car l)))
+(st "Yes & No" frame get-label)
+
+(define (test-controls parent frame)
+  (define side-effect #f)
+  
+  (printf "Buttons~n")
+  (letrec ([b (make-object button% 
+			   "&Button"
+			   parent
+			   (lambda (bt e)
+			     (test bt 'same-button b)
+			     (test-control-event e '(button))
+			     (set! side-effect 'button)
+			     'oops)
+			   '(border))])
+    (label-test b "Button")    
+    (stv b command (make-object control-event% 'button))
+    (test 'button 'button-callback side-effect)
+    
+    (containee-window-tests b #f #f parent frame 2))
+
+  (printf "Check Box~n")
+  (letrec ([c (make-object check-box% 
+			   "&Check Box"
+			   parent
+			   (lambda (cb e)
+			     (test cb 'same-check c)
+			     (test-control-event e '(check-box))
+			     (set! side-effect 'check-box)
+			     'oops)
+			   null)])
+    (label-test c "Check Box")
+    (stv c command (make-object control-event% 'check-box))
+    (test 'check-box 'check-box-callback side-effect)
+    
+    (st #f c get-value)
+    (stv c set-value #t)
+    (st #t c get-value)
+    (stv c set-value #f)
+    (st #f c get-value)
+    
+    (containee-window-tests c #f #f parent frame 2))
+  (let ([c (make-object check-box% "True"
+			parent void
+			null
+			#t)])
+    (st #t c get-value))
+
+  (printf "Radio Box~n")
+  (letrec ([r (make-object radio-box%
+			   "&Radio Box"
+			   (list "O&ne" "T&wo" "T&hree")
+			   parent
+			   (lambda (rb e)
+			     (test rb 'same-radio r)
+			     (test-control-event e '(radio-box))
+			     (set! side-effect 'radio-box)
+			     'oops)
+			   '(vertical))])
+    (label-test r "Radio Box")
+    (stv r command (make-object control-event% 'radio-box))
+    (test 'radio-box 'radio-box-callback side-effect)
+
+    ; Try every combination of enable states:
+    (let ([try-all
+	   (lambda ()
+	     (let loop ([n 7])
+	       (let ([0? (positive? (bitwise-and n 1))]
+		     [1? (positive? (bitwise-and n 2))]
+		     [2? (positive? (bitwise-and n 4))])
+		 (st 0? r is-enabled? 0)
+		 (st 1? r is-enabled? 1)
+		 (st 2? r is-enabled? 2)
+		 (let ([0? (positive? (bitwise-and (sub1 n) 1))]
+		       [1? (positive? (bitwise-and (sub1 n) 2))]
+		       [2? (positive? (bitwise-and (sub1 n) 4))])
+		   (stv r enable 0 0?)
+		   (stv r enable 1 1?)
+		   (stv r enable 2 2?)
+		   (unless (zero? n)
+		     (loop (sub1 n))))))
+	     (st #t r is-enabled? 0)
+	     (st #t r is-enabled? 1)
+	     (st #t r is-enabled? 2))])
+      (try-all)
+      (stv r enable #f)
+      (try-all)
+      (stv r enable #t))
+
+    (st "O&ne" r get-item-label 0)
+    (st "T&wo" r get-item-label 1)
+    (st "T&hree" r get-item-label 2)
+    (st "One" r get-item-plain-label 0)
+    (st "Two" r get-item-plain-label 1)
+    (st "Three" r get-item-plain-label 2)
+
+    (st 3 r get-number)
+
+    (st 0 r get-selection)
+    (stv r set-selection 1)
+    (st 1 r get-selection)
+    (stv r set-selection 2)
+    (st 2 r get-selection)
+    (stv r set-selection 1)
+    (st 1 r get-selection)
+    (stv r set-selection 0)
+    (st 0 r get-selection)
+    
+    (containee-window-tests r #f #f parent frame 2))
+  (letrec ([r (make-object radio-box%"Radio Two"
+			   (list "O&ne" "T&wo" "T&hree")
+			   parent
+			   void
+			   '(vertical)
+			   2)])
+    (st 2 r get-selection))
+  (mismatch (make-object radio-box%"Radio Two"
+			 (list "O&ne" "T&wo" "T&hree")
+			 parent
+			 void
+			 '(vertical)
+			 3))
+
+  (printf "Gauge~n")
+  (letrec ([g (make-object gauge% 
+			   "&Gauge"
+			   10
+			   parent
+			   '(horizontal))])
+    (label-test g "Gauge")
+    
+    (st 0 g get-value)
+    (stv g set-value 8)
+    (st 8 g get-value)
+    (stv g set-value 0)
+    (st 0 g get-value)
+    (stv g set-value 10)
+    (st 10 g get-value)
+
+    (st 10 g get-range)
+    (stv g set-range 11)
+    (st 11 g get-range)
+    (st 10 g get-value)
+    (stv g set-range 8)
+    (st 8 g get-range)
+    (st 8 g get-value)
+    (stv g set-range 1)
+    (st 1 g get-range)
+    (st 1 g get-value)
+    (stv g set-range 10)
+    (st 10 g get-range)
+    (st 1 g get-value)
+    
+    (containee-window-tests g #t #f parent frame 2))
+
+  (printf "Slider~n")
+  (letrec ([s (make-object slider% 
+			   "&Slider"
+			   -2 8
+			   parent
+			   (lambda (sl e)
+			     (test sl 'same-slider s)
+			     (test-control-event e '(slider))
+			     (set! side-effect 'slider)
+			     'oops)
+			   3
+			   '(horizontal))])
+    (label-test s "Slider")
+    (stv s command (make-object control-event% 'slider))
+    (test 'slider 'slider-callback side-effect)
+    
+    (st 3 s get-value)
+    (stv s set-value 4)
+    (st 4 s get-value)
+    (stv s set-value -2)
+    (st -2 s get-value)
+    (stv s set-value 8)
+    (st 8 s get-value)
+
+    (containee-window-tests s #t #f parent frame 2))
+
+  (let ([test-list-control
+	 (lambda (l choice? multi?)
+	   (st 3 l get-number)
+	   
+	   (st "A" l get-string 0)
+	   (st "B" l get-string 1)
+	   (st "C & D" l get-string 2)
+
+	   (unless choice?
+	     (st 'a l get-data 0)
+	     (st #f l get-data 1)
+	     (st 'c-&-d l get-data 2))
+	   
+	   (st 0 l find-string "A")
+	   (st 1 l find-string "B")
+	   (st 2 l find-string "C & D")
+	   (st #f l find-string "C")
+
+	   (stv l set-selection 2)
+	   (st 2 l get-selection)
+	   (st "C & D" l get-string-selection)
+	   (stv l set-selection 1)
+	   (st 1 l get-selection)
+	   (st "B" l get-string-selection)
+	   (stv l set-selection 0)
+	   (st 0 l get-selection)
+	   (st "A" l get-string-selection)
+	   
+	   (stv l set-string-selection "C & D")
+	   (st 2 l get-selection)
+	   (st "C & D" l get-string-selection)
+	   (stv l set-string-selection "B")
+	   (st 1 l get-selection)
+	   (st "B" l get-string-selection)
+	   (stv l set-string-selection "A")
+	   (st 0 l get-selection)
+	   (st "A" l get-string-selection)
+
+	   (stv l set-selection 2)
+	   
+	   (unless choice?
+	     (st '(2) l get-selections)
+	     (stv l set-selection 1)
+	     (st #t l is-selected? 1)
+	     (st #f l is-selected? 2)
+	     (st '(1) l get-selections)
+	     (stv l set-selection 2)
+	     (st #f l is-selected? 1)
+	     (st #t l is-selected? 2)
+	     
+	     (stv l select 2 #f)
+	     (st '() l get-selections)
+	     (st #f l get-selection)
+	     (stv l select 0 #t)
+	     (st '(0) l get-selections)
+
+	     (stv l select 2 #t)
+	     (st (if multi? '(0 2) '(2)) l get-selections)
+	     (stv l select 1 #t)
+	     (st (if multi? '(0 1 2) '(1)) l get-selections)
+	     (stv l select 1 #f)
+	     (st (if multi? '(0 2) '()) l get-selections)
+	     (st (if multi? 0 #f) l get-selection)
+	     (stv l select 2 #t)
+	     (st (if multi? '(0 2) '(2)) l get-selections)
+	     (st (if multi? 0 2) l get-selection)
+	     (st multi? l is-selected? 0)
+	     (st #t l is-selected? 2)
+	     (stv l set-selection 2)
+	     (st '(2) l get-selections))
+
+	   (if choice?
+	       (stv l append "E")
+	       (stv l append "E" 'e))
+	   (st 4 l get-number)
+	   (st 2 l get-selection)
+	   (unless choice?
+	     (st 'e l get-data 3))
+	   (stv l append "F & G")
+	   (st 5 l get-number)
+	   (st 2 l get-selection)
+	   (unless choice?
+	     (st #f l get-data 4))
+
+	   (stv l set-selection 4)
+	   (st 4 l get-selection)
+	   (st "F & G" l get-string-selection)
+	   (stv l set-selection 2)
+	   (stv l set-string-selection "F & G")
+	   (st 4 l get-selection)
+	   (st "F & G" l get-string-selection)
+
+	   (unless choice?
+	     (stv l delete 1)
+	     (st 4 l get-number)
+	     (st "A" l get-string 0)
+	     (st 'a l get-data 0)
+	     (st "C & D" l get-string 1)
+	     (st 'c-&-d l get-data 1)
+
+	     (stv l delete 0)
+	     (st 3 l get-number))
+
+	   (stv l clear)
+	   (st 0 l get-number)
+	   (st #f l get-selection)
+	   (st #f l get-string-selection)
+
+	   (stv l append "Z")
+	   (st 1 l get-number)
+	   (when choice?
+	     (st 0 l get-selection)
+	     (st "Z" l get-string-selection))
+
+	   (unless choice?
+	     (st 1 l get-number)
+	     (stv l set '("ONe" "TW&o" "THRee"))
+	     (st 3 l get-number)
+	     (st "ONe" l get-string 0)
+	     (st "TW&o" l get-string 1)
+	     (st "THRee" l get-string 2)
+
+	     (stv l set-data 0 'my-example-data)
+	     (stv l set-data 2 'my-other-data)
+	     (st 'my-example-data l get-data 0)
+	     (st #f l get-data 1)
+	     (st 'my-other-data l get-data 2))
+
+	   'done-list)])
+
+    (printf "Choice~n")
+    (letrec ([c (make-object choice%
+			     "&Choice"
+			     '("A" "B" "C & D")
+			     parent
+			     (lambda (ch e)
+			       (test ch 'same-choice c)
+			       (test-control-event e '(choice))
+			       (set! side-effect 'choice)
+			       'oops)
+			     null)])
+      (label-test c "Choice")
+      (stv c command (make-object control-event% 'choice))
+      (test 'choice 'choice-callback side-effect)
+      
+      (st 0 c get-selection)
+
+      (test-list-control c #t #f)
+      
+      (containee-window-tests c #f #f parent frame 2))
+    (letrec ([c (make-object choice% "Choice 2"
+			     '("A" "B" "C & D")
+			     parent void
+			     null
+			     2)])
+      (st 2 c get-selection))
+    (mismatch (make-object choice% "Choice 2"
+			   '("A" "B" "C & D")
+			   parent void
+			   null
+			   3))
+
+    (let ([mk-list
+	   (lambda (style)
+	     (printf "List Box: ~a~n" style)
+	     (letrec ([l (make-object list-box%
+				      "&List Box"
+				      '("A" "B" "C & D")
+				      parent
+				      (lambda (lb e)
+					(test lb 'same-list-box l)
+					(test-control-event e '(list-box))
+					(set! side-effect 'list-box)
+					'oops)
+				      (list style))])
+	       (label-test l "List Box")
+	       (stv l command (make-object control-event% 'list-box))
+	       (test 'list-box 'list-box-callback side-effect)
+	       
+	       (stv l set-data 0 'a)
+	       (stv l set-data 2 'c-&-d)
+	       
+	       (test-list-control l #f (and (memq style '(multiple extended)) #t))
+	       
+	       (containee-window-tests l #t #t parent frame 2)
+
+	       (stv parent delete-child l)))])
+
+      (mk-list 'single)
+      (mk-list 'multiple)
+      (mk-list 'extended))
+
+    'done-lists)
+  (let ([l (make-object list-box% "List Two"
+			'("A" "B" "C & D")
+			parent
+			void
+			(list 'single)
+			2)])
+    (st 2 l get-selection))
+  (mismatch (make-object list-box% "List Two"
+			 '("A" "B" "C & D")
+			 parent
+			 void
+			 (list 'single)
+			 3))
+
+  (let loop ([styles '((single) (multiple) (multiple hscroll))])
+    (unless (null? styles)
+      (let ([t (make-object text-field% "Label" parent void "Starting Value" (car styles))])
+	(st "Starting Value" t get-value)
+	(stv t set-value "different")
+	(st "different" t get-value)
+
+	(test #t 'is-editor? (is-a? (send t get-editor) text%))
+
+	(containee-window-tests t #t 
+				(and (memq 'multiple (car styles)) #t)
+				parent frame 2)
+
+	(send parent delete-child t)
+	(loop (cdr styles)))))
+
+  (let ([c (make-object canvas% parent '(hscroll vscroll))])
+
+    (printf "Tab Focus~n")
+    (st #f c accept-tab-focus)
+    (stv c accept-tab-focus #t)
+    (st #t c accept-tab-focus)
+    (stv c accept-tab-focus #f)
+    (st #f c accept-tab-focus)
+
+    (stv c init-auto-scrollbars 500 606 .02 .033)
+    ; (stv c set-scrollbars 100 101 5 6 2 3 10 20 #t)
+    (let-values ([(w h) (send c get-virtual-size)]
+		 [(cw ch) (send c get-client-size)])
+      (printf "Canvas size: Virtual: ~a x ~a  Client: ~a x ~a~n" w h cw ch)
+      (let ([check-scroll
+	     (lambda (xpos ypos)
+	       (let-values ([(x y) (send c get-view-start)])
+		 (let ([coerce (lambda (x) (inexact->exact (floor x)))])
+		   (test (coerce (* xpos (- 500 cw))) `(canvas-view-x ,xpos ,ypos ,x ,cw) x)
+		   (test (coerce (* ypos (- 606 ch))) `(canvas-view-y ,xpos ,ypos ,y ,ch) y))))])
+	(test 500 'canvas-virt-w-size w)
+	(test 606 'canvas-virt-h-size h)
+	
+	(check-scroll 0.02 0.033)
+
+	(st 0 c get-scroll-pos 'horizontal)
+	(st 0 c get-scroll-pos 'vertical)
+	(st 0 c get-scroll-page 'horizontal)
+	(st 0 c get-scroll-page 'vertical)
+	(st 0 c get-scroll-range 'horizontal)
+	(st 0 c get-scroll-range 'vertical)
+	
+	(stv c scroll 0.1 0.1)
+	(check-scroll 0.1 0.1)
+	(stv c scroll #f 0.2)
+	(check-scroll 0.1 0.2)
+	(stv c scroll 0.0 #f)
+	(check-scroll 0.0 0.2)
+	
+	'done-sb))
+
+    (stv c init-manual-scrollbars 5 6 2 3 4 5)
+    (let-values ([(w h) (send c get-virtual-size)]
+		 [(cw ch) (send c get-client-size)])
+      (let ([check-scroll
+	     (lambda (xpos ypos)
+	       (st xpos c get-scroll-pos 'horizontal)
+	       (st ypos c get-scroll-pos 'vertical)
+	
+	       (test cw 'canvas-virt-w-size w)
+	       (test ch 'canvas-virt-h-size h)
+	       
+	       (let-values ([(x y) (send c get-view-start)])
+		 (test 0 'canvas-view-x x)
+		 (test 0 'canvas-view-y y)))])
+	
+	(check-scroll 4 5)
+	
+	(st 2 c get-scroll-page 'horizontal)
+	(st 3 c get-scroll-page 'vertical)
+	(st 5 c get-scroll-range 'horizontal)
+	(st 6 c get-scroll-range 'vertical)
+	
+	(stv c scroll 1 1)
+	(check-scroll 4 5)
+
+	(stv c set-scroll-pos 'horizontal 1)
+	(check-scroll 1 5)
+	(stv c set-scroll-pos 'vertical 0)
+	(check-scroll 1 0)
+	
+	(stv c set-scroll-page 'horizontal 1)
+	(st 1 c get-scroll-page 'horizontal)
+	(st 3 c get-scroll-page 'vertical)
+	(stv c set-scroll-page 'vertical 2)
+	(st 1 c get-scroll-page 'horizontal)
+	(st 2 c get-scroll-page 'vertical)
+		
+	'done-sb))
+
+    (stv c warp-pointer 21 23)
+
+    (containee-window-tests c #t #t parent frame 0))
+  
+  (let* ([e (make-object text%)]
+	 [c (make-object editor-canvas%
+			 parent e
+			 null
+			 102)])
+    (let loop ([n 100])
+      (unless (zero? n)
+	(send e insert (format "line ~a~n" n))
+	(loop (sub1 n))))
+
+    (st #f c allow-scroll-to-last)
+    (stv c allow-scroll-to-last #t)
+    (st #t c allow-scroll-to-last)
+    (stv c allow-scroll-to-last #f)
+
+    (st 'hello c call-as-primary-owner (lambda () 'hello))
+
+    (st #f c force-display-focus)
+    (stv c force-display-focus #t)
+    (st #t c force-display-focus)
+    (stv c force-display-focus #f)
+
+    (st e c get-editor)
+    (stv c set-editor #f)
+    (st #f c get-editor)
+    (stv c set-editor e)
+    (st e c get-editor)
+
+    (st #f c lazy-refresh)
+    (stv c lazy-refresh #t)
+    (st #t c lazy-refresh)
+    (stv c lazy-refresh #f)
+
+    (st #f c scroll-with-bottom-base)
+    (stv c scroll-with-bottom-base #t)
+    (st #t c scroll-with-bottom-base)
+    (stv c scroll-with-bottom-base #f)
+
+    (stv c set-line-count 6)
+    (stv c set-line-count #f)
+
+    (containee-window-tests c #t #t parent frame 0))
+
+  'done)
+
+(test-controls frame frame)
+
+(define (panel-tests frame% show?)
+  (define (panel-test % win?)
+    (let* ([frame (make-object frame% "Panel Test" #f 100 100)]
+	   [panel (if %
+		      (make-object % frame)
+		      frame)])
+      (let ([go
+	     (lambda ()
+	       (test-controls panel frame)
+	       (if win?
+		   ((if % containee-window-tests window-tests) panel #t #t (and % frame) frame 0)
+		   (area-tests panel #t #t #f))
+	       (container-tests panel win?)
+	       (send frame show #f))])
+	(when (eq? show? 'dialog)
+	  (queue-callback go))
+	(when show?
+	  (send frame show #t))
+	(unless (eq? show? 'dialog)
+	  (go)))))
+  (panel-test #f #t)
+  (unless shorter?
+    (panel-test vertical-pane% #f)
+    (panel-test horizontal-pane% #f)
+    (panel-test vertical-panel% #t)
+    (panel-test horizontal-panel% #t)))
+
+(panel-tests dialog% #f)
+(panel-tests frame% #t)
+(panel-tests frame% #f)
+(panel-tests dialog% 'dialog)
+
+
+(report-errs)
diff --git a/collects/tests/mysterx/README b/collects/tests/mysterx/README
new file mode 100644
index 0000000000..8153858076
--- /dev/null
+++ b/collects/tests/mysterx/README
@@ -0,0 +1,33 @@
+MysterX test control
+====================
+
+The file mystests.ss in this directory creates a window
+with a test ActiveX control, and runs a number of tests on it.
+After the internal tests are performed, you can interact 
+with the test control using a mouse.
+
+The C++ code in the src subdirectory is supplied uncompiled.
+You need Visual C++ .NET to compile it.
+
+To compile, run "nmake".  Once you've compiled the test ActiveX 
+control, load "mystests.ss".
+
+DHTML test code
+===============
+
+The file dhtmltests.ss contains a number of tests
+for the Dynamic HTML capabilities of MysterX.
+Simply load the file into MzScheme or DrScheme to run the 
+tests.  Any errors will be printed in the REPL.
+The behavior that appears in the window that is created
+may be ignored.
+
+Manual tests
+============
+
+Here are some manual tests to run on MysterX:
+
+  - run mxdemo.ss (in the collection) under IE4, IE5, IE5.5
+  - check for no context menu in browsers
+  - load mxdemo.ss into DrScheme; hit Execute a second time,
+     the browser windows should disappear
diff --git a/collects/tests/mysterx/dhtmltests.ss b/collects/tests/mysterx/dhtmltests.ss
new file mode 100644
index 0000000000..df91f308ce
--- /dev/null
+++ b/collects/tests/mysterx/dhtmltests.ss
@@ -0,0 +1,161 @@
+;;; dhtmltests.ss -- DHTML tests for MysterX
+
+(require (lib "class.ss"))
+
+; set inspector so structures can be compared
+(define insp (current-inspector))
+(current-inspector (make-inspector))
+
+(require (lib "mysterx.ss" "mysterx"))
+
+(current-inspector insp)
+
+(define wb 
+	(instantiate mx-browser% ()
+		     (label "DHTML tests")
+		     (width 300)
+		     (height 300) 
+		     (style-options '(maximize))))
+
+(define doc (send wb current-document))
+
+(send doc insert-html "<P id=\"text\">This is some text</P>")
+
+(define txt (send doc find-element "P" "text"))
+
+(define (test-prop getter setter expected)
+  (printf "Checking ~a~n" getter)
+  (send-generic txt (make-generic mx-element% setter) expected)
+  (let ([got (send-generic txt (make-generic mx-element% getter))])
+    (unless (equal? got expected)
+	    (printf "~a: Expected ~a, got ~a~n" 
+		    getter expected got))))
+
+(define tests
+ `((font-family set-font-family! ("monospace" "fantasy"))
+   (font-size set-font-size! xx-large)
+   (font-style set-font-style! oblique)
+   (font-variant set-font-variant! small-caps)
+   (font-weight set-font-weight! bolder)
+   (background-attachment set-background-attachment! fixed)
+   (background-image 
+    set-background-image! 
+    "http://www.cs.rice.edu/CS/PLT/packages/drscheme/logo.gif")
+   (background-repeat set-background-repeat! no-repeat)
+   (background-position set-background-position! (right bottom))
+   (background-position-x set-background-position-x! 
+			  ,(make-css-length 42 'em))
+   (background-position-y set-background-position-y! 
+	      ,(make-css-percentage 95))
+   (letter-spacing set-letter-spacing! normal)
+   (letter-spacing set-letter-spacing! 
+		   ,(make-css-length 20 'pt))
+   (vertical-align set-vertical-align! super)
+   (text-decoration set-text-decoration! (underline line-through))
+   (text-decoration-underline set-text-decoration-underline! #t)
+   (text-decoration-overline set-text-decoration-overline! #t)
+   (text-decoration-linethrough set-text-decoration-linethrough! #t)
+   (text-decoration-blink set-text-decoration-blink! #t)
+   (color set-color! red)
+   (background-color set-background-color! orange)
+   (pixel-top set-pixel-top! 27)
+   (pixel-left set-pixel-left! 99)
+   (pixel-width set-pixel-width! 99)
+   (pixel-height set-pixel-height! 199)
+   (overflow set-overflow! scroll)
+   (pos-top set-pos-top! 13.0)
+   (pos-left set-pos-left! 17.0)
+   (pos-width set-pos-width! 188.0)
+   (text-transform set-text-transform! uppercase)
+   (text-align set-text-align! justify)
+   (text-indent set-text-indent! ,(make-css-length 50 'pt))
+   (line-height set-line-height! ,(make-css-percentage 200))
+   (margin set-margin! (auto ,(make-css-length 70 'pt) auto auto))
+   (margin-top set-margin-top! ,(make-css-length 70 'pt))
+   (margin-bottom set-margin-bottom! auto)
+   (margin-left set-margin-left! auto)
+   (margin-right set-margin-right! ,(make-css-percentage 200))
+   (pagebreak-before set-pagebreak-before! always)
+   (pagebreak-after set-pagebreak-after! always)
+   (cursor set-cursor! help)
+   (padding set-padding! ,(list (make-css-length 70 'pt) (make-css-percentage 300)))
+   (padding-top set-padding-top! ,(make-css-length 30 'em))
+   (padding-bottom set-padding-bottom! ,(make-css-length 3 'cm))
+   (padding-left set-padding-left! ,(make-css-length 3 'ex))
+   (padding-right set-padding-right! ,(make-css-length 70 'mm))
+   (border set-border! (blue ,(make-css-length 6 'pt) solid))
+   (border-top set-border-top! (red ,(make-css-length 8 'pt) dashed))
+   (border-bottom set-border-bottom! (green ,(make-css-length 4 'pt) dotted))
+   (border-left set-border-left! (pink thick dotted))
+   (border-right set-border-right! (black thin dashed))
+   (border-color set-border-color! orange)
+   (border-top-color set-border-top-color! cyan)
+   (border-bottom-color set-border-bottom-color! darkseagreen)
+   (border-left-color set-border-left-color! goldenrod)
+   (border-right-color set-border-right-color! purple)
+   (border-width set-border-width! ,(make-css-length 20 'pt))
+   (border-top-width set-border-top-width! ,(make-css-length 15 'pt))
+   (border-bottom-width set-border-bottom-width! ,(make-css-length 15 'pt))
+   (border-left-width set-border-left-width! ,(make-css-length 15 'pt))
+   (border-right-width set-border-right-width! ,(make-css-length 15 'pt))
+   (border-bottom-width set-border-bottom-width! ,(make-css-length 30 'pt))
+   (border-left-width set-border-left-width! ,(make-css-length 30 'em))
+   (border-right-width set-border-right-width! ,(make-css-length 1 'in))
+   (border-style set-border-style! solid)
+   (border-top-style set-border-top-style! none)
+   (border-bottom-style set-border-bottom-style! dashed)
+   (border-left-style set-border-left-style! dotted)
+   (border-right-style set-border-right-style! none)
+   (style-float set-style-float! left)
+   (display set-display! list-item)
+   (list-style-type set-list-style-type! lower-roman)
+   (list-style-position set-list-style-position! inside)
+   (visibility set-visibility! hidden)
+   (clip set-clip! 
+	(,(make-css-length 2 'cm) auto 
+	,(make-css-length 5 'in) auto))
+   (clip set-clip! 
+	(,(make-css-length 2 'cm) auto 
+	,(make-css-length 5 'in) auto))
+   (style-float set-style-float! left)	
+   (clear set-clear! both)
+   (width set-width! ,(make-css-percentage 50))
+   (height set-height! ,(make-css-percentage 50))
+   (top set-top! auto)
+   (left set-left! auto)
+   (z-index set-z-index! 4)))
+
+(for-each
+ (lambda (t)
+   (apply test-prop t))
+ tests)
+
+; filter test
+
+(define flt 'glow)
+(define opt1 '(strength 99))
+(define opt2 '(enabled #t))
+(define opt3 '(color "#ff00ff"))
+
+(define filter-spec (list flt opt1 opt2 opt3))
+
+(send-generic txt (make-generic mx-element% 'set-filter!) 
+	      flt opt1 opt2 opt3)
+
+(let ([result (send txt filter)]) 
+  (if (equal? result filter-spec)
+      (printf "Checking filter~n")
+      (error (format "filter test: Expected ~a, got ~a~n"
+		     filter-spec result))))
+
+(printf "Navigating to CNN~n")
+(send wb navigate "http://www.cnn.com")
+(sleep 2)
+(printf "Navigating to IBM~n")
+(send wb navigate/status "http://www.ibm.com")
+(sleep 2)
+(printf "Back to CNN~n")
+(send wb go-back) 
+(sleep 2)
+(printf "Forward to IBM~n")
+(send wb go-forward)
diff --git a/collects/tests/mysterx/mystests.ss b/collects/tests/mysterx/mystests.ss
new file mode 100644
index 0000000000..b1bea7cdd0
--- /dev/null
+++ b/collects/tests/mysterx/mystests.ss
@@ -0,0 +1,126 @@
+;;; mystests.ss -- test suite for MysterX
+
+(require (lib "class.ss"))
+(require (lib "mysterx.ss" "mysterx"))
+
+(define errors? #f)
+
+(define wb 
+  (instantiate mx-browser% ()
+	       (label "MysTest")
+	       (width 230)
+	       (height 250)))
+
+(define doc (send wb current-document))
+
+(define ctrl (send doc insert-object-from-coclass "TestControl Class" 95 95 'percent))
+
+(define (inv f . args) (apply com-invoke ctrl f args))
+
+(define (test-currency n)
+  (= n (com-currency->number (number->com-currency n))))
+
+(define (test-scode n)
+  (= n (com-scode->number (number->com-scode n))))
+
+(define (test-date date)
+  (equal? date (com-date->date (date->com-date date))))
+
+(for-each
+ (lambda (n)
+   (unless (test-scode n)
+	   (printf "Error in test-scode for value ~a~n" n)
+	   (set! errors? #t)))
+ '(25 -22 -1 -233344433 177000000 859489222))
+
+
+(define (test-numprop ndx retval)
+	(com-set-property! ctrl (list "Numprop" ndx) 55)
+	(unless (= (com-get-property ctrl (list "Numprop" ndx)) retval)
+		(printf "Error in setting Numprop")	
+		(set! errors? #t)))
+
+(test-numprop 26 42)
+(test-numprop 10 99)
+
+(print-struct #t)
+
+(let ([date (seconds->date (current-seconds))])
+  (set-date-dst?! date #f)
+  (set-date-time-zone-offset! date 0)
+  (unless (test-date date)
+	  (printf "Error in test-date~n")
+	  (set! errors? #t)))
+
+(for-each
+ (lambda (n)
+   (unless (test-currency n)
+	   (printf "Error in test-currency for value ~a~n" n)
+	   (set! errors? #t)))
+ '(0 1 3.14 25.00 -22.34 11.7832 91000000000 25034343434.9933))
+
+
+
+(define com-tests
+	`(("AddTest" (39 ,(box 420)) ,(+ 39 420))
+	  ("AddTest" (420 ,(box 39)) ,(+ 420 39))
+	  ("FloatTest" (4.7 5.2) ,(- 5.2 4.7))
+	  ("FloatTest" (88.7 33.2) ,(- 33.2 88.7))
+	  ("FloatTest" (-88.7 33.2) ,(- 33.2 -88.7))
+	  ("UnsignedTest" (92 97) ,(- 97 92))
+	  ("UnsignedTest" (20 33) ,(- 33 20))
+	  ("UnsignedTest" (1 12) ,(- 12 1))
+	  ("StringTest" ("abc" "def") ,"abcdef")
+	  ("StringTest" ("Supercali" "fragilistic") ,"Supercalifragilistic")
+          ("ShortTest"  (42 17) ,(* 42 17))
+          ("ShortTest"  (77 -22) ,(* 77 -22))))
+
+(for-each 
+ (lambda (t)
+   (let ([got (apply inv (car t) (cadr t))]
+	 [expected (caddr t)])
+     (unless (equal? got expected)
+	     (set! errors? #t)
+	     (printf "Error in com-tests. Expected: ~a~nGot     : ~a~n"
+		     expected got))))
+ com-tests)
+
+(define caption "SomeCaption")
+
+(com-set-property! ctrl "Caption" caption)
+
+(unless (string=? caption (com-get-property ctrl "Caption"))
+	(set! errors? #t))
+
+(if errors?
+      (printf "There were errors!~n")
+      (printf "No errors in conversions and COM tests~n")) 	
+
+(define (make-mousefun s)
+  (let ([t (string-append s ": button = ~a shift = ~a x = ~a y = ~a~n")])
+    (lambda (button shift x y) 
+      (printf t button shift x y))))
+
+(define (mouse-pair s)
+  (list s (make-mousefun s)))
+
+
+(unless errors?
+	(for-each 
+	 (lambda (sf) 
+	   (com-register-event-handler ctrl (car sf) (cadr sf)))
+	 `(("Click"
+	    ,(lambda () (printf "Click~n")))
+	   ,(mouse-pair "MouseMove")
+	   ,(mouse-pair "MouseDown")
+	   ,(mouse-pair "MouseUp")))
+
+	(printf "Try clicking and moving the mouse over the object~n")
+	(printf "You should see Click, MouseMove, MouseDown, and MouseUp events~n"))
+
+	   
+         
+	
+	
+
+
diff --git a/collects/tests/mysterx/src/Makefile b/collects/tests/mysterx/src/Makefile
new file mode 100644
index 0000000000..2d807d929f
--- /dev/null
+++ b/collects/tests/mysterx/src/Makefile
@@ -0,0 +1,2 @@
+all : 
+	nmake /f testobject.mak
diff --git a/collects/tests/mysterx/src/resource.h b/collects/tests/mysterx/src/resource.h
new file mode 100644
index 0000000000..862c34d5f4
--- /dev/null
+++ b/collects/tests/mysterx/src/resource.h
@@ -0,0 +1,18 @@
+//{{NO_DEPENDENCIES}}
+// Microsoft Developer Studio generated include file.
+// Used by testobject.rc
+//
+#define IDS_PROJNAME                    100
+#define IDB_TESTCONTROL                 101
+#define IDR_TESTCONTROL                 102
+
+// Next default values for new objects
+// 
+#ifdef APSTUDIO_INVOKED
+#ifndef APSTUDIO_READONLY_SYMBOLS
+#define _APS_NEXT_RESOURCE_VALUE        201
+#define _APS_NEXT_COMMAND_VALUE         32768
+#define _APS_NEXT_CONTROL_VALUE         201
+#define _APS_NEXT_SYMED_VALUE           103
+#endif
+#endif
diff --git a/collects/tests/mysterx/src/stdafx.cxx b/collects/tests/mysterx/src/stdafx.cxx
new file mode 100644
index 0000000000..a5eea178f7
--- /dev/null
+++ b/collects/tests/mysterx/src/stdafx.cxx
@@ -0,0 +1,12 @@
+// stdafx.cpp : source file that includes just the standard includes
+//  stdafx.pch will be the pre-compiled header
+//  stdafx.obj will contain the pre-compiled type information
+
+#include "stdafx.h"
+
+#ifdef _ATL_STATIC_REGISTRY
+#include <statreg.h>
+#include <statreg.cpp>
+#endif
+
+#include <atlimpl.cpp>
diff --git a/collects/tests/mysterx/src/stdafx.h b/collects/tests/mysterx/src/stdafx.h
new file mode 100644
index 0000000000..79976b0bfe
--- /dev/null
+++ b/collects/tests/mysterx/src/stdafx.h
@@ -0,0 +1,28 @@
+// stdafx.h : include file for standard system include files,
+//      or project specific include files that are used frequently,
+//      but are changed infrequently
+
+#if !defined(AFX_STDAFX_H__07B31FF3_19EE_11D3_B5DB_0060089002FE__INCLUDED_)
+#define AFX_STDAFX_H__07B31FF3_19EE_11D3_B5DB_0060089002FE__INCLUDED_
+
+#if _MSC_VER > 1000
+#pragma once
+#endif // _MSC_VER > 1000
+
+#define STRICT
+#ifndef _WIN32_WINNT
+#define _WIN32_WINNT 0x0400
+#endif
+#define _ATL_APARTMENT_THREADED
+
+#include <atlbase.h>
+//You may derive a class from CComModule and use it if you want to override
+//something, but do not change the name of _Module
+extern CComModule _Module;
+#include <atlcom.h>
+#include <atlctl.h>
+
+//{{AFX_INSERT_LOCATION}}
+// Microsoft Visual C++ will insert additional declarations immediately before the previous line.
+
+#endif // !defined(AFX_STDAFX_H__07B31FF3_19EE_11D3_B5DB_0060089002FE__INCLUDED)
diff --git a/collects/tests/mysterx/src/testcont.bmp b/collects/tests/mysterx/src/testcont.bmp
new file mode 100644
index 0000000000..122976492c
Binary files /dev/null and b/collects/tests/mysterx/src/testcont.bmp differ
diff --git a/collects/tests/mysterx/src/testcontrol.cxx b/collects/tests/mysterx/src/testcontrol.cxx
new file mode 100644
index 0000000000..c8a0632d21
--- /dev/null
+++ b/collects/tests/mysterx/src/testcontrol.cxx
@@ -0,0 +1,61 @@
+// TestControl.cpp : Implementation of CTestControl
+
+#include "stdafx.h"
+#include "Testobject.h"
+#include "TestControl.h"
+
+/////////////////////////////////////////////////////////////////////////////
+// CTestControl
+
+
+STDMETHODIMP CTestControl::AddTest(long n1, long *n2, long *n3)
+{
+  // note side effect
+  *n3 = n1 + *n2;
+  *n2 = n1;
+  return S_OK;
+}
+
+STDMETHODIMP CTestControl::StringTest (BSTR s1, BSTR s2, BSTR *s3)
+{
+  int len1,len2;
+
+  len1 = SysStringLen(s1);
+  len2 = SysStringLen(s2);
+
+  *s3 = SysAllocStringByteLen (NULL, (len1 + len2)*2);
+  wcsncpy (*s3, s1, len1);
+  wcsncpy (*s3 + len1, s2, len2);
+
+  return S_OK;
+}
+
+STDMETHODIMP CTestControl::ShortTest (short n1, short n2, short *n3)
+{
+  *n3 = n1 * n2;
+  return S_OK;
+}
+
+STDMETHODIMP CTestControl::FloatTest (double n1, double n2, double *n3)
+{
+  *n3 = n2 - n1;
+  return S_OK;
+}
+
+STDMETHODIMP CTestControl::UnsignedTest (unsigned n1, unsigned n2, unsigned *n3)
+{
+  *n3 = n2 - n1;
+  return S_OK;
+}
+
+STDMETHODIMP CTestControl::get_Numprop (long ndx,long *pVal)
+{
+  *pVal = the_value;
+  return S_OK;
+}
+
+STDMETHODIMP CTestControl::put_Numprop (long ndx,long newVal)
+{
+  the_value = (ndx > 21) ? 42 : 99;
+  return S_OK;
+}
diff --git a/collects/tests/mysterx/src/testcontrol.h b/collects/tests/mysterx/src/testcontrol.h
new file mode 100644
index 0000000000..ade8019cf0
--- /dev/null
+++ b/collects/tests/mysterx/src/testcontrol.h
@@ -0,0 +1,186 @@
+// TestControl.h : Declaration of the CTestControl
+
+#ifndef __TESTCONTROL_H_
+#define __TESTCONTROL_H_
+
+#include "resource.h"       // main symbols
+#include <windowsx.h>
+#include <atlctl.h>
+#include "testobjectCP.h"
+
+
+/////////////////////////////////////////////////////////////////////////////
+// CTestControl
+class ATL_NO_VTABLE CTestControl :
+	public CComObjectRootEx<CComSingleThreadModel>,
+	public CStockPropImpl<CTestControl, ITestControl, &IID_ITestControl, &LIBID_TESTOBJECTLib>,
+	public CComControl<CTestControl>,
+	public IPersistStreamInitImpl<CTestControl>,
+	public IOleControlImpl<CTestControl>,
+	public IOleObjectImpl<CTestControl>,
+	public IOleInPlaceActiveObjectImpl<CTestControl>,
+	public IViewObjectExImpl<CTestControl>,
+	public IOleInPlaceObjectWindowlessImpl<CTestControl>,
+	public IConnectionPointContainerImpl<CTestControl>,
+	public IPersistStorageImpl<CTestControl>,
+	public ISpecifyPropertyPagesImpl<CTestControl>,
+	public IQuickActivateImpl<CTestControl>,
+	public IDataObjectImpl<CTestControl>,
+	public IProvideClassInfo2Impl<&CLSID_TestControl, &DIID__ITestControlEvents, &LIBID_TESTOBJECTLib>,
+	public IPropertyNotifySinkCP<CTestControl>,
+	public CComCoClass<CTestControl, &CLSID_TestControl>,
+	public CProxy_ITestControlEvents< CTestControl >
+{
+private:
+  long the_value;
+public:
+	CTestControl()
+	{
+	  the_value = 0L;
+	}
+
+DECLARE_REGISTRY_RESOURCEID(IDR_TESTCONTROL)
+
+DECLARE_PROTECT_FINAL_CONSTRUCT()
+
+BEGIN_COM_MAP(CTestControl)
+	COM_INTERFACE_ENTRY(ITestControl)
+	COM_INTERFACE_ENTRY(IDispatch)
+	COM_INTERFACE_ENTRY(IViewObjectEx)
+	COM_INTERFACE_ENTRY(IViewObject2)
+	COM_INTERFACE_ENTRY(IViewObject)
+	COM_INTERFACE_ENTRY(IOleInPlaceObjectWindowless)
+	COM_INTERFACE_ENTRY(IOleInPlaceObject)
+	COM_INTERFACE_ENTRY2(IOleWindow, IOleInPlaceObjectWindowless)
+	COM_INTERFACE_ENTRY(IOleInPlaceActiveObject)
+	COM_INTERFACE_ENTRY(IOleControl)
+	COM_INTERFACE_ENTRY(IOleObject)
+	COM_INTERFACE_ENTRY(IPersistStreamInit)
+	COM_INTERFACE_ENTRY2(IPersist, IPersistStreamInit)
+	COM_INTERFACE_ENTRY(IConnectionPointContainer)
+	COM_INTERFACE_ENTRY(ISpecifyPropertyPages)
+	COM_INTERFACE_ENTRY(IQuickActivate)
+	COM_INTERFACE_ENTRY(IPersistStorage)
+	COM_INTERFACE_ENTRY(IDataObject)
+	COM_INTERFACE_ENTRY(IProvideClassInfo)
+	COM_INTERFACE_ENTRY(IProvideClassInfo2)
+	COM_INTERFACE_ENTRY_IMPL(IConnectionPointContainer)
+END_COM_MAP()
+
+BEGIN_PROP_MAP(CTestControl)
+	PROP_DATA_ENTRY("_cx", m_sizeExtent.cx, VT_UI4)
+	PROP_DATA_ENTRY("_cy", m_sizeExtent.cy, VT_UI4)
+	PROP_ENTRY("Caption", DISPID_CAPTION, CLSID_NULL)
+	// Example entries
+	// PROP_ENTRY("Property Description", dispid, clsid)
+	// PROP_PAGE(CLSID_StockColorPage)
+END_PROP_MAP()
+
+BEGIN_CONNECTION_POINT_MAP(CTestControl)
+	CONNECTION_POINT_ENTRY(IID_IPropertyNotifySink)
+	CONNECTION_POINT_ENTRY(DIID__ITestControlEvents)
+END_CONNECTION_POINT_MAP()
+
+BEGIN_MSG_MAP(CTestControl)
+	CHAIN_MSG_MAP(CComControl<CTestControl>)
+	DEFAULT_REFLECTION_HANDLER()
+	MESSAGE_HANDLER(WM_LBUTTONDOWN, OnLButtonDown)
+	MESSAGE_HANDLER(WM_LBUTTONUP, OnLButtonUp)
+	MESSAGE_HANDLER(WM_MBUTTONDOWN, OnMButtonDown)
+	MESSAGE_HANDLER(WM_MBUTTONUP, OnMButtonUp)
+	MESSAGE_HANDLER(WM_RBUTTONDOWN, OnRButtonDown)
+	MESSAGE_HANDLER(WM_RBUTTONUP, OnRButtonUp)
+	MESSAGE_HANDLER(WM_MOUSEMOVE, OnMouseMove)
+END_MSG_MAP()
+// Handler prototypes:
+//  LRESULT MessageHandler(UINT uMsg, WPARAM wParam, LPARAM lParam, BOOL& bHandled);
+//  LRESULT CommandHandler(WORD wNotifyCode, WORD wID, HWND hWndCtl, BOOL& bHandled);
+//  LRESULT NotifyHandler(int idCtrl, LPNMHDR pnmh, BOOL& bHandled);
+
+
+
+// IViewObjectEx
+	DECLARE_VIEW_STATUS(VIEWSTATUS_SOLIDBKGND | VIEWSTATUS_OPAQUE)
+
+// ITestControl
+public:
+	STDMETHOD(FloatTest)(double n1,double n2,/*[out,retval]*/double *n3);
+	STDMETHOD(UnsignedTest)(unsigned n1,unsigned n2,/*[out,retval]*/unsigned *n3);
+	STDMETHOD(ShortTest)(short int n1,short int n2,/*[out,retval]*/short int *n3);
+	STDMETHOD(StringTest)(BSTR s1,BSTR s2,/*[out,retval]*/BSTR *s3);
+	STDMETHOD(AddTest)(long n1,long *n2,/*[out,retval]*/long *n3);
+	STDMETHOD(get_Numprop)(long ndx,long *retVal);
+	STDMETHOD(put_Numprop)(long ndx,long newVal);
+
+	HRESULT OnDraw (ATL_DRAWINFO& di)
+	{
+		RECT& rc = *(RECT*)di.prcBounds;
+		Rectangle(di.hdcDraw, rc.left, rc.top, rc.right, rc.bottom);
+
+		SetTextAlign(di.hdcDraw, TA_CENTER|TA_BASELINE);
+		LPCTSTR pszText = _T("MysterX Test Control");
+		TextOut(di.hdcDraw,
+			(rc.left + rc.right) / 2,
+			(rc.top + rc.bottom) / 2,
+			pszText,
+			lstrlen(pszText));
+
+		return S_OK;
+	}
+
+	CComBSTR m_bstrCaption;
+
+	LRESULT OnLButtonDown(UINT uMsg, WPARAM wParam, LPARAM lParam, BOOL& bHandled)
+	{
+	  Fire_MouseDown (0x1, wParam, GET_X_LPARAM (lParam), GET_Y_LPARAM (lParam));
+	  Fire_Click();
+	  return DefWindowProc (uMsg, wParam, lParam);
+	}
+
+	LRESULT OnLButtonUp(UINT uMsg, WPARAM wParam, LPARAM lParam, BOOL& bHandled)
+	{
+	  Fire_MouseUp (0x1, wParam, GET_X_LPARAM (lParam), GET_Y_LPARAM (lParam));
+	  return DefWindowProc (uMsg, wParam, lParam);
+	}
+
+	LRESULT OnMButtonDown (UINT uMsg, WPARAM wParam, LPARAM lParam, BOOL& bHandled)
+	{
+	  Fire_MouseDown (0x4, wParam, GET_X_LPARAM (lParam), GET_Y_LPARAM (lParam));
+	  Fire_Click();
+	  return DefWindowProc (uMsg, wParam, lParam);
+	}
+
+	LRESULT OnMButtonUp (UINT uMsg, WPARAM wParam, LPARAM lParam, BOOL& bHandled)
+	{
+	  Fire_MouseUp (0x4, wParam, GET_X_LPARAM (lParam), GET_Y_LPARAM (lParam));
+	  return DefWindowProc (uMsg, wParam, lParam);
+	}
+
+	LRESULT OnRButtonDown (UINT uMsg, WPARAM wParam, LPARAM lParam, BOOL& bHandled)
+	{
+	  Fire_MouseDown (0x2, wParam, GET_X_LPARAM (lParam), GET_Y_LPARAM (lParam));
+	  Fire_Click();
+	  return DefWindowProc(uMsg, wParam, lParam);
+	}
+
+	LRESULT OnRButtonUp (UINT uMsg, WPARAM wParam, LPARAM lParam, BOOL& bHandled)
+	{
+	  Fire_MouseUp (0x2, wParam, GET_X_LPARAM (lParam), GET_Y_LPARAM (lParam));
+	  return DefWindowProc (uMsg, wParam, lParam);
+	}
+
+	LRESULT OnMouseMove (UINT uMsg, WPARAM wParam, LPARAM lParam, BOOL& bHandled)
+	{
+	  short button;
+	  short shift;
+
+	  button = wParam & (MK_LBUTTON | MK_MBUTTON | MK_RBUTTON);
+	  shift = wParam & (MK_CONTROL | MK_SHIFT);
+
+	  Fire_MouseMove (button, shift, GET_X_LPARAM (lParam), GET_Y_LPARAM (lParam));
+
+	  return DefWindowProc (uMsg, wParam, lParam);
+	}
+};
+
+#endif //__TESTCONTROL_H_
diff --git a/collects/tests/mysterx/src/testcontrol.rgs b/collects/tests/mysterx/src/testcontrol.rgs
new file mode 100644
index 0000000000..8c36991987
--- /dev/null
+++ b/collects/tests/mysterx/src/testcontrol.rgs
@@ -0,0 +1,34 @@
+HKCR
+{
+	Testobject.TestControl.1 = s 'TestControl Class'
+	{
+		CLSID = s '{FED8FE26-19CA-11D3-B5DB-0060089002FE}'
+	}
+	Testobject.TestControl = s 'TestControl Class'
+	{
+		CLSID = s '{FED8FE26-19CA-11D3-B5DB-0060089002FE}'
+		CurVer = s 'Testobject.TestControl.1'
+	}
+	NoRemove CLSID
+	{
+		ForceRemove {FED8FE26-19CA-11D3-B5DB-0060089002FE} = s 'TestControl Class'
+		{
+			ProgID = s 'Testobject.TestControl.1'
+			VersionIndependentProgID = s 'Testobject.TestControl'
+			ForceRemove 'Programmable'
+			InprocServer32 = s '%MODULE%'
+			{
+				val ThreadingModel = s 'Apartment'
+			}
+			ForceRemove 'Control'
+			ForceRemove 'Insertable'
+			ForceRemove 'ToolboxBitmap32' = s '%MODULE%, 101'
+			'MiscStatus' = s '0'
+			{
+			    '1' = s '131473'
+			}
+			'TypeLib' = s '{07B31FF0-19EE-11D3-B5DB-0060089002FE}'
+			'Version' = s '1.0'
+		}
+	}
+}
diff --git a/collects/tests/mysterx/src/testobject.cxx b/collects/tests/mysterx/src/testobject.cxx
new file mode 100644
index 0000000000..343390af08
--- /dev/null
+++ b/collects/tests/mysterx/src/testobject.cxx
@@ -0,0 +1,71 @@
+// testobject.cpp : Implementation of DLL Exports.
+
+
+// Note: Proxy/Stub Information
+//      To build a separate proxy/stub DLL,
+//      run nmake -f testobjectps.mk in the project directory.
+
+#include "stdafx.h"
+#include "resource.h"
+#include <initguid.h>
+#include "testobject.h"
+
+#include "testobject_i.c"
+#include "TestControl.h"
+
+
+CComModule _Module;
+
+BEGIN_OBJECT_MAP(ObjectMap)
+OBJECT_ENTRY(CLSID_TestControl, CTestControl)
+END_OBJECT_MAP()
+
+/////////////////////////////////////////////////////////////////////////////
+// DLL Entry Point
+
+extern "C"
+BOOL WINAPI DllMain (HINSTANCE hInstance, DWORD dwReason, LPVOID /*lpReserved*/)
+{
+  if (dwReason == DLL_PROCESS_ATTACH) {
+      _Module.Init (ObjectMap, hInstance, &LIBID_TESTOBJECTLib);
+      DisableThreadLibraryCalls (hInstance);
+      }
+  else if (dwReason == DLL_PROCESS_DETACH)
+      _Module.Term();
+  return TRUE;    // ok
+}
+
+/////////////////////////////////////////////////////////////////////////////
+// Used to determine whether the DLL can be unloaded by OLE
+
+STDAPI DllCanUnloadNow (void)
+{
+  return (_Module.GetLockCount()==0) ? S_OK : S_FALSE;
+}
+
+/////////////////////////////////////////////////////////////////////////////
+// Returns a class factory to create an object of the requested type
+
+STDAPI DllGetClassObject (REFCLSID rclsid, REFIID riid, LPVOID* ppv)
+{
+  return _Module.GetClassObject (rclsid, riid, ppv);
+}
+
+/////////////////////////////////////////////////////////////////////////////
+// DllRegisterServer - Adds entries to the system registry
+
+STDAPI DllRegisterServer (void)
+{
+  // registers object, typelib and all interfaces in typelib
+  return _Module.RegisterServer (TRUE);
+}
+
+/////////////////////////////////////////////////////////////////////////////
+// DllUnregisterServer - Removes entries from the system registry
+
+STDAPI DllUnregisterServer (void)
+{
+  return _Module.UnregisterServer (TRUE);
+}
+
+
diff --git a/collects/tests/mysterx/src/testobject.def b/collects/tests/mysterx/src/testobject.def
new file mode 100644
index 0000000000..17651e6521
--- /dev/null
+++ b/collects/tests/mysterx/src/testobject.def
@@ -0,0 +1,9 @@
+; testobject.def : Declares the module parameters.
+
+LIBRARY      "testobject.DLL"
+
+EXPORTS
+	DllCanUnloadNow     PRIVATE
+	DllGetClassObject   PRIVATE
+	DllRegisterServer   PRIVATE
+	DllUnregisterServer PRIVATE
diff --git a/collects/tests/mysterx/src/testobject.idl b/collects/tests/mysterx/src/testobject.idl
new file mode 100644
index 0000000000..399be5c973
--- /dev/null
+++ b/collects/tests/mysterx/src/testobject.idl
@@ -0,0 +1,69 @@
+// testobject.idl : IDL source for testobject.dll
+//
+
+// This file will be processed by the MIDL tool to
+// produce the type library (testobject.tlb) and marshalling code.
+
+import "oaidl.idl";
+import "ocidl.idl";
+#include "olectl.h"
+	
+
+	[
+		object,
+		uuid(07B31FFC-19EE-11D3-B5DB-0060089002FE),
+		dual,
+		helpstring("ITestControl Interface"),
+		pointer_default(unique)
+	]
+	interface ITestControl : IDispatch
+	{
+		[propput, id(DISPID_CAPTION)]
+		HRESULT Caption([in]BSTR strCaption);
+		[propget, id(DISPID_CAPTION)]
+		HRESULT Caption([out,retval]BSTR* pstrCaption);
+		[id(1), helpstring("method AddTest")] HRESULT AddTest(long n1,long *n2,[out,retval]long *n3);
+		[id(2), helpstring("method StringTest")] HRESULT StringTest(BSTR s1,BSTR s2,[out,retval]BSTR *s3);
+		[id(3), helpstring("method ShortTest")] HRESULT ShortTest(short int n1,short int n2,[out,retval]short int *n3);
+		[id(4), helpstring("method FloatTest")] HRESULT FloatTest(double n1,double n2,[out,retval]double *n3);
+		[id(5), helpstring("method UnsignedTest")] HRESULT UnsignedTest(unsigned n1,unsigned n2,[out,retval]unsigned *n3);
+	        [propget, id(6), helpstring("property Numprop")] HRESULT Numprop(long ndx,[out, retval] long *pVal);
+		[propput, id(6), helpstring("property Numprop")] HRESULT Numprop(long ndx,[in] long newVal);
+	};
+
+[
+	uuid(07B31FF0-19EE-11D3-B5DB-0060089002FE),
+	version(1.0),
+	helpstring("testobject 1.0 Type Library")
+]
+library TESTOBJECTLib
+{
+	importlib("stdole32.tlb");
+	importlib("stdole2.tlb");
+
+	[
+		uuid(07B31FFD-19EE-11D3-B5DB-0060089002FE),
+		helpstring("_ITestControlEvents Interface")
+	]
+	dispinterface _ITestControlEvents
+	{
+		properties:
+		methods:
+		[id(DISPID_CLICK), helpstring("method Click")] HRESULT Click();
+		[id(DISPID_MOUSEDOWN), helpstring("method MouseDown")] HRESULT MouseDown(short button,short shift,OLE_XPOS_PIXELS x,OLE_YPOS_PIXELS y);
+		[id(DISPID_MOUSEUP), helpstring("method MouseUp")] HRESULT MouseUp(short button,short shift,OLE_XPOS_PIXELS x,OLE_YPOS_PIXELS y);
+		[id(1), helpstring("method KeyDown")] HRESULT KeyDown(short *keyCode,short shift);
+		[id(2), helpstring("method KeyUp")] HRESULT KeyUp(short *keyCode,short shift);
+		[id(3), helpstring("method MouseMove")] HRESULT MouseMove(short button,short shift,OLE_XPOS_PIXELS x,OLE_YPOS_PIXELS y);
+	};
+
+	[
+		uuid(FED8FE26-19CA-11D3-B5DB-0060089002FE),
+		helpstring("TestControl Class")
+	]
+	coclass TestControl
+	{
+		[default] interface ITestControl;
+		[default, source] dispinterface _ITestControlEvents;
+	};
+};
diff --git a/collects/tests/mysterx/src/testobject.mak b/collects/tests/mysterx/src/testobject.mak
new file mode 100644
index 0000000000..8530dc453f
--- /dev/null
+++ b/collects/tests/mysterx/src/testobject.mak
@@ -0,0 +1,46 @@
+# mysterx.mak
+
+all : testobject.dll
+
+clean :
+        -@erase testcontrol.obj
+	-@erase testobject.obj
+	-@erase testobject.dll
+
+CPP=cl.exe
+CPP_FLAGS=/MT /W3 /O2 /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "_ATL_STATIC_REGISTRY" /c
+
+MTL=midl.exe
+MTL_SWITCHES=/tlb testobject.tlb /h testobject.h /iid testobject_i.c /Oicf 
+RSC=rc.exe
+RSC_PROJ=/l 0x409 /fo"testobject.res"
+REGSVR32=regsvr32	
+
+.cxx.obj::
+   $(CPP) $(CPP_FLAGS) $< 
+
+LINK32=link.exe
+LINK32_FLAGS= \
+	kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib \
+	advapi32.lib ole32.lib oleaut32.lib \
+	uuid.lib odbc32.lib odbccp32.lib \
+	/nologo /dll /subsystem:windows /incremental:no /machine:I386 \
+	/def:testobject.def /out:testobject.dll
+DEF_FILE=testobject.def
+LINK32_OBJS= \
+        testobject.obj testcontrol.obj testobject.res 
+
+testobject.dll : $(DEF_FILE) $(LINK32_OBJS)
+	$(LINK32) $(LINK32_FLAGS) $(LINK32_OBJS)
+	$(REGSVR32) /s testobject.dll
+
+testcontrol.obj : testcontrol.cxx testobject.tlb stdafx.h
+
+testobject.obj : testobject.cxx stdafx.h
+
+testobject.tlb : testobject.idl
+	$(MTL) $(MTL_SWITCHES) testobject.idl
+
+testcontrol.res : testcontrol.rc testcontrol.tlb
+	$(RSC) $(RSC_PROJ) testcontrol.rc
+
diff --git a/collects/tests/mysterx/src/testobject.rc b/collects/tests/mysterx/src/testobject.rc
new file mode 100644
index 0000000000..0ae3fa9c1f
--- /dev/null
+++ b/collects/tests/mysterx/src/testobject.rc
@@ -0,0 +1,132 @@
+//Microsoft Developer Studio generated resource script.
+//
+#include "resource.h"
+
+#define APSTUDIO_READONLY_SYMBOLS
+/////////////////////////////////////////////////////////////////////////////
+//
+// Generated from the TEXTINCLUDE 2 resource.
+//
+#include "winres.h"
+
+/////////////////////////////////////////////////////////////////////////////
+#undef APSTUDIO_READONLY_SYMBOLS
+
+/////////////////////////////////////////////////////////////////////////////
+// English (U.S.) resources
+
+#if !defined(AFX_RESOURCE_DLL) || defined(AFX_TARG_ENU)
+#ifdef _WIN32
+LANGUAGE LANG_ENGLISH, SUBLANG_ENGLISH_US
+#pragma code_page(1252)
+#endif //_WIN32
+
+#ifdef APSTUDIO_INVOKED
+/////////////////////////////////////////////////////////////////////////////
+//
+// TEXTINCLUDE
+//
+
+1 TEXTINCLUDE DISCARDABLE 
+BEGIN
+    "resource.h\0"
+END
+
+2 TEXTINCLUDE DISCARDABLE 
+BEGIN
+    "#include ""winres.h""\r\n"
+    "\0"
+END
+
+3 TEXTINCLUDE DISCARDABLE 
+BEGIN
+    "1 TYPELIB ""testobject.tlb""\r\n"
+    "\0"
+END
+
+#endif    // APSTUDIO_INVOKED
+
+
+#ifndef _MAC
+/////////////////////////////////////////////////////////////////////////////
+//
+// Version
+//
+
+VS_VERSION_INFO VERSIONINFO
+ FILEVERSION 1,0,0,1
+ PRODUCTVERSION 1,0,0,1
+ FILEFLAGSMASK 0x3fL
+#ifdef _DEBUG
+ FILEFLAGS 0x1L
+#else
+ FILEFLAGS 0x0L
+#endif
+ FILEOS 0x4L
+ FILETYPE 0x2L
+ FILESUBTYPE 0x0L
+BEGIN
+    BLOCK "StringFileInfo"
+    BEGIN
+        BLOCK "040904B0"
+        BEGIN
+            VALUE "CompanyName", "\0"
+            VALUE "FileDescription", "testobject Module\0"
+            VALUE "FileVersion", "1, 0, 0, 1\0"
+            VALUE "InternalName", "testobject\0"
+            VALUE "LegalCopyright", "Copyright 1999\0"
+            VALUE "OriginalFilename", "testobject.DLL\0"
+            VALUE "ProductName", "testobject Module\0"
+            VALUE "ProductVersion", "1, 0, 0, 1\0"
+            VALUE "OLESelfRegister", "\0"
+        END
+    END
+    BLOCK "VarFileInfo"
+    BEGIN
+        VALUE "Translation", 0x409, 1200
+    END
+END
+
+#endif    // !_MAC
+
+
+/////////////////////////////////////////////////////////////////////////////
+//
+// Bitmap
+//
+
+IDB_TESTCONTROL         BITMAP  DISCARDABLE     "testcont.bmp"
+
+
+/////////////////////////////////////////////////////////////////////////////
+//
+// REGISTRY
+//
+
+IDR_TESTCONTROL         REGISTRY DISCARDABLE    "TestControl.rgs"
+
+/////////////////////////////////////////////////////////////////////////////
+//
+// String Table
+//
+
+STRINGTABLE DISCARDABLE 
+BEGIN
+    IDS_PROJNAME            "testobject"
+END
+
+#endif    // English (U.S.) resources
+/////////////////////////////////////////////////////////////////////////////
+
+
+
+#ifndef APSTUDIO_INVOKED
+/////////////////////////////////////////////////////////////////////////////
+//
+// Generated from the TEXTINCLUDE 3 resource.
+//
+1 TYPELIB "testobject.tlb"
+
+/////////////////////////////////////////////////////////////////////////////
+#endif    // not APSTUDIO_INVOKED
+
diff --git a/collects/tests/mysterx/src/testobjectCP.h b/collects/tests/mysterx/src/testobjectCP.h
new file mode 100644
index 0000000000..9f65ed24a9
--- /dev/null
+++ b/collects/tests/mysterx/src/testobjectCP.h
@@ -0,0 +1,179 @@
+#ifndef _TESTOBJECTCP_H_
+#define _TESTOBJECTCP_H_
+
+
+
+
+
+
+template <class T>
+class CProxy_ITestControlEvents : public IConnectionPointImpl<T, &DIID__ITestControlEvents, CComDynamicUnkArray>
+{
+	//Warning this class may be recreated by the wizard.
+public:
+	HRESULT Fire_Click()
+	{
+		CComVariant varResult;
+		T* pT = static_cast<T*>(this);
+		int nConnectionIndex;
+		int nConnections = m_vec.GetSize();
+		
+		for (nConnectionIndex = 0; nConnectionIndex < nConnections; nConnectionIndex++)
+		{
+			pT->Lock();
+			CComPtr<IUnknown> sp = m_vec.GetAt(nConnectionIndex);
+			pT->Unlock();
+			IDispatch* pDispatch = reinterpret_cast<IDispatch*>(sp.p);
+			if (pDispatch != NULL)
+			{
+				VariantClear(&varResult);
+				DISPPARAMS disp = { NULL, NULL, 0, 0 };
+				pDispatch->Invoke(DISPID_CLICK, IID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, &disp, &varResult, NULL, NULL);
+			}
+		}
+		return varResult.scode;
+	
+	}
+	HRESULT Fire_MouseDown(SHORT button, SHORT shift, OLE_XPOS_PIXELS x, OLE_YPOS_PIXELS y)
+	{
+		CComVariant varResult;
+		T* pT = static_cast<T*>(this);
+		int nConnectionIndex;
+		CComVariant* pvars = new CComVariant[4];
+		int nConnections = m_vec.GetSize();
+		
+		for (nConnectionIndex = 0; nConnectionIndex < nConnections; nConnectionIndex++)
+		{
+			pT->Lock();
+			CComPtr<IUnknown> sp = m_vec.GetAt(nConnectionIndex);
+			pT->Unlock();
+			IDispatch* pDispatch = reinterpret_cast<IDispatch*>(sp.p);
+			if (pDispatch != NULL)
+			{
+				VariantClear(&varResult);
+				pvars[3] = button;
+				pvars[2] = shift;
+				pvars[1] = x;
+				pvars[0] = y;
+				DISPPARAMS disp = { pvars, NULL, 4, 0 };
+				pDispatch->Invoke(DISPID_MOUSEDOWN, IID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, &disp, &varResult, NULL, NULL);
+			}
+		}
+		delete[] pvars;
+		return varResult.scode;
+	
+	}
+	HRESULT Fire_MouseUp(SHORT button, SHORT shift, OLE_XPOS_PIXELS x, OLE_YPOS_PIXELS y)
+	{
+		CComVariant varResult;
+		T* pT = static_cast<T*>(this);
+		int nConnectionIndex;
+		CComVariant* pvars = new CComVariant[4];
+		int nConnections = m_vec.GetSize();
+		
+		for (nConnectionIndex = 0; nConnectionIndex < nConnections; nConnectionIndex++)
+		{
+			pT->Lock();
+			CComPtr<IUnknown> sp = m_vec.GetAt(nConnectionIndex);
+			pT->Unlock();
+			IDispatch* pDispatch = reinterpret_cast<IDispatch*>(sp.p);
+			if (pDispatch != NULL)
+			{
+				VariantClear(&varResult);
+				pvars[3] = button;
+				pvars[2] = shift;
+				pvars[1] = x;
+				pvars[0] = y;
+				DISPPARAMS disp = { pvars, NULL, 4, 0 };
+				pDispatch->Invoke(DISPID_MOUSEUP, IID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, &disp, &varResult, NULL, NULL);
+			}
+		}
+		delete[] pvars;
+		return varResult.scode;
+	
+	}
+	HRESULT Fire_KeyDown(SHORT * keyCode, SHORT shift)
+	{
+		CComVariant varResult;
+		T* pT = static_cast<T*>(this);
+		int nConnectionIndex;
+		CComVariant* pvars = new CComVariant[2];
+		int nConnections = m_vec.GetSize();
+		
+		for (nConnectionIndex = 0; nConnectionIndex < nConnections; nConnectionIndex++)
+		{
+			pT->Lock();
+			CComPtr<IUnknown> sp = m_vec.GetAt(nConnectionIndex);
+			pT->Unlock();
+			IDispatch* pDispatch = reinterpret_cast<IDispatch*>(sp.p);
+			if (pDispatch != NULL)
+			{
+				VariantClear(&varResult);
+				pvars[1] = keyCode;
+				pvars[0] = shift;
+				DISPPARAMS disp = { pvars, NULL, 2, 0 };
+				pDispatch->Invoke(0x1, IID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, &disp, &varResult, NULL, NULL);
+			}
+		}
+		delete[] pvars;
+		return varResult.scode;
+	
+	}
+	HRESULT Fire_KeyUp(SHORT *keyCode, SHORT shift)
+	{
+		CComVariant varResult;
+		T* pT = static_cast<T*>(this);
+		int nConnectionIndex;
+		CComVariant* pvars = new CComVariant[2];
+		int nConnections = m_vec.GetSize();
+		
+		for (nConnectionIndex = 0; nConnectionIndex < nConnections; nConnectionIndex++)
+		{
+			pT->Lock();
+			CComPtr<IUnknown> sp = m_vec.GetAt(nConnectionIndex);
+			pT->Unlock();
+			IDispatch* pDispatch = reinterpret_cast<IDispatch*>(sp.p);
+			if (pDispatch != NULL)
+			{
+				VariantClear(&varResult);
+				pvars[1] = keyCode;
+				pvars[0] = shift;
+				DISPPARAMS disp = { pvars, NULL, 2, 0 };
+				pDispatch->Invoke(0x2, IID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, &disp, &varResult, NULL, NULL);
+			}
+		}
+		delete[] pvars;
+		return varResult.scode;
+	
+	}
+	HRESULT Fire_MouseMove(SHORT button, SHORT shift, OLE_XPOS_PIXELS x, OLE_YPOS_PIXELS y)
+	{
+		CComVariant varResult;
+		T* pT = static_cast<T*>(this);
+		int nConnectionIndex;
+		CComVariant* pvars = new CComVariant[4];
+		int nConnections = m_vec.GetSize();
+		
+		for (nConnectionIndex = 0; nConnectionIndex < nConnections; nConnectionIndex++)
+		{
+			pT->Lock();
+			CComPtr<IUnknown> sp = m_vec.GetAt(nConnectionIndex);
+			pT->Unlock();
+			IDispatch* pDispatch = reinterpret_cast<IDispatch*>(sp.p);
+			if (pDispatch != NULL)
+			{
+				VariantClear(&varResult);
+				pvars[3] = button;
+				pvars[2] = shift;
+				pvars[1] = x;
+				pvars[0] = y;
+				DISPPARAMS disp = { pvars, NULL, 4, 0 };
+				pDispatch->Invoke(0x3, IID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, &disp, &varResult, NULL, NULL);
+			}
+		}
+		delete[] pvars;
+		return varResult.scode;
+	
+	}
+};
+#endif
\ No newline at end of file
diff --git a/collects/tests/mzcom/README b/collects/tests/mzcom/README
new file mode 100644
index 0000000000..762b652441
--- /dev/null
+++ b/collects/tests/mzcom/README
@@ -0,0 +1,17 @@
+Run the MzCOM tests with
+
+ mzscheme -mvqf test.ss
+
+The tests exercise the three COM methods of MzCOM, namely
+
+ About
+ Reset
+ Eval
+
+Note that some of the tests deliberately cause COM exceptions,
+which are handled in the Scheme code.  The details of those
+exceptions are displayed to make sure they're the ones we 
+expected -- these are not errors.
+
+If the number of detected errors is greater than 0, an 
+error count is printed.
diff --git a/collects/tests/mzcom/test.ss b/collects/tests/mzcom/test.ss
new file mode 100644
index 0000000000..33b351f7a8
--- /dev/null
+++ b/collects/tests/mzcom/test.ss
@@ -0,0 +1,59 @@
+; test.ss for MzCOM
+; requires MysterX to be installed
+
+(require (lib "mysterx.ss" "mysterx"))
+(define mzcom (cci/progid "MzCOM.MzObj"))
+
+(define num-errors 0)
+(define (add-error!)
+  (set! num-errors (add1 num-errors)))
+
+(define (run . s)
+  (apply com-invoke mzcom s))
+
+(define (mzeval s)
+  (run "Eval" s))
+
+(print-struct #t)
+
+; should show an About box
+(printf "You should see the About box~n")
+(run "About")
+
+; tests whether Eval returns sensible result
+(if (string=? (mzeval "(+ 20 22)")
+		  "42")
+    (printf "1st Eval test ok~n")
+    (begin
+      (add-error!)
+      (fprintf (current-error-port) "1st Eval test failed~n")))
+
+(mzeval "(define x 42)")
+; tests whether preceding definition really holds
+(if (string=? "42" (mzeval "x"))
+    (printf "define test ok~n")
+    (begin
+      (add-error!)
+      (fprintf (current-error-port) "define test failed~n")))
+
+(printf "Resetting environment~n")
+(run "Reset") ; removes binding for x
+
+; tests for removal of binding
+(with-handlers
+ ([void (lambda (exn) (printf "2nd Eval test looks ok~nexn was: ~a~n" exn))])
+ (mzeval "x") ; binding for x missing
+ (add-error!)
+ (fprintf (current-error-port) "2nd Eval test failed~n"))
+
+; tests if a Scheme error results in a COM error
+(with-handlers
+ ([void (lambda (exn) (printf "3rd Eval test looks ok~nexn was: ~a~n" exn))])
+ (mzeval "(+ 'foo 42)") ; should raise Scheme error
+ (add-error!)
+ (fprintf (current-error-port) "3rd Eval test failed~n"))
+
+(when (> num-errors 0)
+      (fprintf (current-error-port) "There were ~a errors.~n" num-errors))
+
+(printf "End of MzCOM tests.~n")
diff --git a/collects/tests/mzscheme/README b/collects/tests/mzscheme/README
new file mode 100644
index 0000000000..2b66d093d8
--- /dev/null
+++ b/collects/tests/mzscheme/README
@@ -0,0 +1,32 @@
+
+To run most of the tests, run:
+ > (load "PATHTOHERE/all.ss")
+where PATHTOHERE is the path to this directory.  
+
+Test failures may cause the test to stop before finishing, but most
+test failures will let the test continue, and a summary message at the
+end will enummerate the failures that occurred.
+
+Some files are directories are created (in the current directory)
+during the run. The files are named "tmp<N>" where <N> is a number.
+The directory is named "deep". If the test suite passes, the directory
+should be removed, but some "tmp<N>" files will remain. (The "tmp<N>"
+files are automatically replaced if the test suite is run again.)
+
+Additionally, test `expand' by running:
+ > (load "PATHTOHERE/expand.ss")
+
+Test compilation and writing/reading compiled code with:
+ > (load "PATHTOHERE/compile.ss")
+
+Run the standard tests with no output except for the results with:
+ > (load "PATHTOHERE/quiet.ss")
+
+Run 3 copies of the test suite concurrently in separate threads:
+ > (load "PATHTOHERE/parallel.ss")
+
+
+Please report bugs using
+  http://bugs.plt-scheme.org/
+or (as a last resort) send mail to
+  scheme@plt-scheme.org
diff --git a/collects/tests/mzscheme/advanced.ss b/collects/tests/mzscheme/advanced.ss
new file mode 100644
index 0000000000..b7864c2428
--- /dev/null
+++ b/collects/tests/mzscheme/advanced.ss
@@ -0,0 +1,199 @@
+
+;; Basic checks for the advanced language. See also
+;;  beginner.ss
+
+(load-relative "loadtest.ss")
+
+;; Don't need these:
+(define no-extra-if-tests? #t)
+
+;; Check export names:
+(require (lib "docprovide.ss" "syntax"))
+(let ([docs (lookup-documentation '(lib "htdp-advanced.ss" "lang") 'procedures)])
+  (for-each
+   (lambda (row)
+     (for-each
+      (lambda (doc)
+	(let ([v (dynamic-require '(lib "htdp-advanced.ss" "lang") (car doc))])
+	  (when (and (procedure? v)
+		     (not (eq? v call/cc)))
+	    (test (car doc) object-name v))))
+      (cdr row)))
+   docs))
+
+(define current-htdp-lang '(lib "htdp-advanced.ss" "lang"))
+(load-relative "htdp-test.ss")
+
+(require (lib "htdp-advanced.ss" "lang"))
+
+(load-relative "beg-adv.ss")
+(load-relative "bega-adv.ss")
+(load-relative "intm-adv.ss")
+
+(define (f6 a) (a))
+(test (void) f6 void)
+
+(define (x7) 10)
+(test 10 x7)
+(define x8 (lambda () 11))
+(test 11 x8)
+
+(htdp-syntax-test #'begin)
+(htdp-syntax-test #'(begin))
+(htdp-syntax-test #'(begin (define x 10)))
+(htdp-syntax-test #'(begin (define x 10) x))
+(htdp-syntax-test #'(let () (begin (define x 10) x)))
+(htdp-syntax-test #'(+ 1 (begin)))
+
+(test 1 'begin (begin 1))
+(test 2 'begin (begin 1 2))
+(test 3 'begin (begin 1 2 3))
+
+(htdp-syntax-test #'begin0)
+(htdp-syntax-test #'(begin0))
+
+(test 1 'begin0 (begin0 1))
+(test 2 'begin0 (begin0 2 1))
+(test 3 'begin0 (begin0 3 2 1))
+
+(htdp-syntax-test #'set!)
+(htdp-syntax-test #'(set!))
+(htdp-syntax-test #'(set! x))
+(htdp-syntax-test #'(set! 1 2))
+(htdp-syntax-test #'(set! x 2 3))
+(htdp-syntax-test #'(set! set! 2))
+(htdp-syntax-test #'(lambda (x) (set! x 2)))
+(htdp-syntax-test #'(let ([x 5]) (lambda (x) (set! x 2))))
+
+(htdp-top (set! x 'hello))
+(htdp-test 'hello 'access-x x)
+(htdp-test 18 'set! (local [(define x 12)]
+		 (begin
+		   (set! x 18)
+		   x)))
+(htdp-test 19 (lambda (x)
+	   (local [(define x 12)]
+		  (begin
+		    (set! x 19)
+		    x)))
+      45)
+
+(htdp-syntax-test #'delay)
+(htdp-syntax-test #'(delay))
+(htdp-syntax-test #'(delay 1 2))
+
+(htdp-top (define d (delay (begin (set! x 89) 12))))
+(htdp-test #t promise? d)
+(htdp-test 12 force d)
+(htdp-top (force d))
+(htdp-test 89 'access-x x)
+(htdp-top (set! x 13))
+(htdp-test 12 force d)
+(htdp-test 13 'access-x x)
+
+(htdp-syntax-test #'(let name))
+(htdp-syntax-test #'(let name 10))
+(htdp-syntax-test #'(let name ()))
+(htdp-syntax-test #'(let name ([x]) 1))
+(htdp-syntax-test #'(let name ([x 10] 2) 1))
+(htdp-syntax-test #'(let name ([11 10]) 1))
+(htdp-syntax-test #'(let name ([x 10]) 1 2))
+(htdp-syntax-test #'(let name ([x 10][x 11]) 1))
+(htdp-test 10 'lookup (let name () 10))
+(htdp-test 1024 'loop (let loop ([n 10]) (if (zero? n) 1 (* 2 (loop (sub1 n))))))
+
+(htdp-test 19 'lookup (recur empty-f () 19))
+
+(htdp-syntax-test #'case)
+(htdp-syntax-test #'(case))
+(htdp-syntax-test #'(case 5))
+(htdp-syntax-test #'(case 5 12))
+(htdp-syntax-test #'(case 5 []))
+(htdp-syntax-test #'(case 5 [5 10]))
+(htdp-syntax-test #'(case 5 [(5) 10] 12))
+(htdp-syntax-test #'(case 5 [(5)]))
+(htdp-syntax-test #'(case 5 [(5) 12 13]))
+(htdp-syntax-test #'(case 5 [("a") 10]))
+(htdp-syntax-test #'(case 5 [() 10]))
+(htdp-syntax-test #'(case 5 [(5 "a") 10]))
+(htdp-syntax-test #'(case 5 [else 12][(5) 10]))
+(htdp-syntax-test #'(case 5 [(5) 10][else 12][else 13]))
+
+(htdp-test 'a 'case (case 5 [(5) 'a]))
+(htdp-test 'b 'case (case 5 [(6) 'a][else 'b]))
+(htdp-test 'c 'case (case 5 [(6 5) 'c][else 'b]))
+(htdp-test 'd 'case (case 'hello [(6 5 hello) 'd][else 'b]))
+(htdp-test 'd 'case (case 'hello [(no) 10][(6 5 hello) 'd][else 'b]))
+(htdp-test 'cc 'case (case (+ 2 3) [(6 5) 'cc][else 'b]))
+
+(htdp-syntax-test #'when)
+(htdp-syntax-test #'(when))
+(htdp-syntax-test #'(when 10))
+(htdp-syntax-test #'(when 10 12 13))
+
+(htdp-err/rt-test (when 1 2))
+
+(htdp-test (void) 'when (when false 1))
+(htdp-test 11 'when (when true 11))
+
+(htdp-syntax-test #'unless)
+(htdp-syntax-test #'(unless))
+(htdp-syntax-test #'(unless 10))
+(htdp-syntax-test #'(unless 10 12 13))
+
+(htdp-err/rt-test (unless 1 2))
+
+(htdp-test (void) 'unless (unless true 1))
+(htdp-test 11 'unless (unless false 11))
+
+(htdp-syntax-test #'shared)
+(htdp-syntax-test #'(shared))
+(htdp-syntax-test #'(shared ()))
+(htdp-syntax-test #'(shared 1 2))
+(htdp-syntax-test #'(shared () 1 2))
+(htdp-syntax-test #'(shared (x) 2))
+(htdp-syntax-test #'(shared ([]) 2))
+(htdp-syntax-test #'(shared ([x]) 2))
+(htdp-syntax-test #'(shared ([x 1 3]) 2))
+(htdp-syntax-test #'(shared ([1 3]) 2))
+(htdp-syntax-test #'(shared ([x 1][x 2]) 2))
+
+(htdp-test 1 'shared (shared () 1))
+(htdp-test 1 'shared (shared ([x 1]) x))
+(htdp-test '(1) 'shared (shared ([x (cons 1 null)]) x))
+(htdp-test 1 car (shared ([x (cons 1 x)]) x))
+(htdp-test 1 cadr (shared ([x (cons 1 x)][y (cons 2 x)]) y))
+(htdp-test 1 cadddr (shared ([x (cons 1 x)][y (cons 2 x)]) y))
+(htdp-test #t (lambda (l) (eq? l (cdr l))) (shared ([x (cons 1 x)]) x))
+(htdp-test #t (lambda (l) (eq? l (car l))) (shared ([x (list x x)]) x))
+(htdp-test #t (lambda (l) (eq? l (cadr l))) (shared ([x (list x x)]) x))
+(htdp-err/rt-test (shared ([x (cons 1 y)][y 5]) x))
+
+(htdp-syntax-test #'recur)
+(htdp-syntax-test #'(recur))
+(htdp-syntax-test #'(recur 10))
+(htdp-syntax-test #'(recur name))
+(htdp-syntax-test #'(recur name 10))
+(htdp-syntax-test #'(recur name ([x 1])))
+(htdp-syntax-test #'(recur name ([x]) 1))
+(htdp-syntax-test #'(recur name ([x 10] 2) 1))
+(htdp-syntax-test #'(recur name ([11 10]) 1))
+(htdp-syntax-test #'(recur name ([x 10]) 1 2))
+(htdp-syntax-test #'(recur name ([x 10][x 11]) 1))
+(htdp-test 18 'lookup (recur name ([x 18]) x))
+(htdp-test 1024 'loop (recur loop ([n 10]) (if (zero? n) 1 (* 2 (loop (sub1 n))))))
+(htdp-test 13 'loop (recur f ([f 13]) f))
+(htdp-test 14 'loop (let ([f 14]) (recur f ([f f]) f)))
+
+(load (build-path (collection-path "tests" "mzscheme") "shared-tests.ss"))
+
+(htdp-test #t 'equal? (equal? (vector (list 10) 'apple) (vector (list 10) 'apple)))
+(htdp-test #t 'equal~? (equal~? (vector (list 10) 'apple) (vector (list 10) 'apple) 0.1))
+(htdp-test #t 'equal~? (equal~? (vector (list 10) 'apple) (vector (list 10.02) 'apple) 0.1))
+(htdp-test #f 'equal~? (equal~? (vector (list 10) 'apple) (vector (list 10.2) 'apple) 0.1))
+(htdp-test #t 'equal? (equal? (box (list 10)) (box (list 10))))
+(htdp-test #t 'equal~? (equal~? (box (list 10)) (box (list 10)) 0.1))
+(htdp-test #t 'equal~? (equal~? (box (list 10)) (box (list 10.02)) 0.1))
+(htdp-test #f 'equal~? (equal~? (box (list 10)) (box (list 10.2)) 0.1))
+
+(report-errs)
diff --git a/collects/tests/mzscheme/all.ss b/collects/tests/mzscheme/all.ss
new file mode 100644
index 0000000000..ce0bbac6bc
--- /dev/null
+++ b/collects/tests/mzscheme/all.ss
@@ -0,0 +1,4 @@
+
+(load-relative "mz.ss")
+(load-relative "mzlib.ss")
+(load-relative "boundmap-test.ss") 
\ No newline at end of file
diff --git a/collects/tests/mzscheme/async-channel.ss b/collects/tests/mzscheme/async-channel.ss
new file mode 100644
index 0000000000..f02b16ceb4
--- /dev/null
+++ b/collects/tests/mzscheme/async-channel.ss
@@ -0,0 +1,82 @@
+
+
+(load-relative "loadtest.ss")
+
+(require (lib "async-channel.ss"))
+
+(SECTION 'async-channel)
+
+(arity-test make-async-channel 0 1)
+(err/rt-test (make-async-channel 0) exn?)
+(err/rt-test (make-async-channel 1.0) exn?)
+(err/rt-test (make-async-channel -1) exn?)
+
+(err/rt-test (async-channel-get #f) exn?)
+(err/rt-test (async-channel-try-get #f) exn?)
+(err/rt-test (async-channel-put #f 1) exn?)
+(err/rt-test (async-channel-put-evt #f 1) exn?)
+
+(let ([ch (make-async-channel)])
+  (test #t async-channel? ch)
+  (test #f async-channel-try-get ch)
+  (test #f sync/timeout 0 ch)
+  (test (void) async-channel-put ch 12)
+  (test 12 async-channel-get ch)
+  (test #f async-channel-try-get ch)
+  (test (void) async-channel-put ch 1)
+  (test (void) async-channel-put ch 2)
+  (test 1 async-channel-get ch)
+  (test 2 async-channel-get ch)
+  (test #f async-channel-try-get ch)
+  (test (void) async-channel-put ch 1)
+  (test (void) async-channel-put ch 2)
+  (test 1 async-channel-try-get ch)
+  (test 2 async-channel-try-get ch)
+  (test #f async-channel-try-get ch)
+  (let ([p (async-channel-put-evt ch 10)])
+    (test p sync/timeout #f p)
+    (test 10 async-channel-get ch)
+    (test p sync/timeout 0 p)
+    (test p sync/timeout #f p p)
+    (test 10 async-channel-get ch)
+    (test 10 async-channel-get ch)
+    (test #f async-channel-try-get ch)))
+
+;; Make sure a channel isn't managed by a
+;; custodian:
+(for-each
+ (lambda (try-after-shutdown)
+   (let ([c (make-custodian)]
+	 [ch2 #f])
+     (parameterize ([current-custodian c])
+       (thread-wait
+	(thread (lambda ()
+		  (set! ch2 (make-async-channel))
+		  (async-channel-put ch2 42)))))
+     (custodian-shutdown-all c)
+     (try-after-shutdown ch2)))
+ (list
+  (lambda (ch2)
+    (test 42 async-channel-get ch2))
+  (lambda (ch2)
+    (test 42 async-channel-try-get ch2))
+  (lambda (ch2)
+    (test (void) async-channel-put ch2 10))
+  (lambda (ch2)
+    (let ([p (async-channel-put-evt ch2 10)])
+      (test p sync/timeout 0 p)))))
+
+;; Limitted channel:
+(let ([ch (make-async-channel 1)])
+  (async-channel-put ch 42)
+  (test 42 async-channel-get ch)
+  (let ([p (async-channel-put-evt ch 10)])
+    (test p sync/timeout #f p)
+    (test #f sync/timeout 0.01 p)
+    (test #f sync/timeout 0 p)
+    (test 10 async-channel-get ch)
+    (test p sync/timeout #f p)))
+
+
+(report-errs)
+
diff --git a/collects/tests/mzscheme/awk.ss b/collects/tests/mzscheme/awk.ss
new file mode 100644
index 0000000000..60d11f1b72
--- /dev/null
+++ b/collects/tests/mzscheme/awk.ss
@@ -0,0 +1,38 @@
+
+(load-relative "loadtest.ss")
+
+(SECTION 'awk)
+
+(require (lib "awk.ss"))
+
+(define-syntax (test-awk stx)
+  (syntax-case stx ()
+    [(_ val body ...) 
+     (with-syntax ([next (datum->syntax-object stx 'next)]
+		   [result (datum->syntax-object stx 'result)])
+       (syntax
+	(let* ([p (open-input-string "Hello world.")]
+	       [next (lambda () (let ([o (read p)])
+				  (if (eof-object? o)
+				      o
+				      (symbol->string o))))]
+	       [r null]
+	       [result (lambda (v)
+			 (set! r (append r (list v))))])
+	  body ...
+	  (test val 'awk r))))]))
+			
+		
+
+(test-awk '(hi there)
+	  (awk (next) (str) ()
+	       ["ell" (result 'hi)]
+	       ["x" (result 'yikes)]
+	       ["orl" (result 'there)]))
+
+(test-awk '("l" done)
+	  (awk (next) (str) ()
+	       [/ "el(l)" / (#f a) (result a)]
+	       [(equal? str "world.") (result 'done)]))
+
+(report-errs)
diff --git a/collects/tests/mzscheme/basic.ss b/collects/tests/mzscheme/basic.ss
new file mode 100644
index 0000000000..70bdad01f6
--- /dev/null
+++ b/collects/tests/mzscheme/basic.ss
@@ -0,0 +1,2005 @@
+
+(load-relative "loadtest.ss")
+
+(test '() 'null null)
+(test '() 'null ())
+
+(let ([f (lambda () #&7)])
+  (test #t eq? (f) (f)))
+
+(SECTION 2 1);; test that all symbol characters are supported.
+'(+ - ... !.. $.+ %.- &.! *.: /:. :+. <-. =. >. ?. ~. _. ^.)
+
+(SECTION 3 4)
+(define disjoint-type-functions
+  (list boolean? char? null? number? pair? procedure? string? symbol? vector?))
+(define type-examples
+  (list
+   #t #f #\a '() 9739 '(test) record-error "test" "" 'test '#() '#(a b c) ))
+(define i 1)
+(for-each (lambda (x) (display (make-string i #\ ))
+		  (set! i (+ 3 i))
+		  (write x)
+		  (newline))
+	  disjoint-type-functions)
+(define type-matrix
+  (map (lambda (x)
+	 (let ((t (map (lambda (f) (f x)) disjoint-type-functions)))
+	   (write t)
+	   (write x)
+	   (newline)
+	   t))
+       type-examples))
+
+(SECTION 6 1)
+(test #f not #t)
+(test #f not 3)
+(test #f not (list 3))
+(test #t not #f)
+(test #f not '())
+(test #f not (list))
+(test #f not 'nil)
+(arity-test not 1 1)
+
+(test #t boolean? #f)
+(test #t boolean? #t)
+(test #f boolean? 0)
+(test #f boolean? '())
+(arity-test boolean? 1 1)
+
+(SECTION 6 2)
+(test #t eqv? 'a 'a)
+(test #f eqv? 'a 'b)
+(test #t eqv? 2 2)
+(test #f eqv? 2 2.0)
+(test #t eqv? '() '())
+(test #t eqv? '10000 '10000)
+(test #t eqv? 10000000000000000000 10000000000000000000)
+(test #f eqv? 10000000000000000000 10000000000000000001)
+(test #f eqv? 10000000000000000000 20000000000000000000)
+(test #f eqv? (cons 1 2) (cons 1 2))
+(test #f eqv? (lambda () 1) (lambda () 2))
+(test #f eqv? #f 'nil)
+(let ((p (lambda (x) x)))
+  (test #t eqv? p p))
+(define gen-counter
+ (lambda ()
+   (let ((n 0))
+      (lambda () (set! n (+ n 1)) n))))
+(let ((g (gen-counter))) (test #t eqv? g g))
+(test #f eqv? (gen-counter) (gen-counter))
+(letrec ((f (lambda () (if (eqv? f g) 'f 'both)))
+	 (g (lambda () (if (eqv? f g) 'g 'both))))
+  (test #f eqv? f g))
+
+(test #t eq? 'a 'a)
+(test #f eq? (list 'a) (list 'a))
+(test #t eq? '() '())
+(test #t eq? car car)
+(let ((x '(a))) (test #t eq? x x))
+(let ((x '#())) (test #t eq? x x))
+(let ((x (lambda (x) x))) (test #t eq? x x))
+
+(test #t equal? 'a 'a)
+(test #t equal? '("a") '("a"))
+(test #t equal? '(a) '(a))
+(test #t equal? '(a (b) c) '(a (b) c))
+(test #t equal? '("a" ("b") "c") '("a" ("b") "c"))
+(test #t equal? "abc" "abc")
+(test #t equal? 2 2)
+(test #t equal? (make-vector 5 'a) (make-vector 5 'a))
+(test #t equal? (box "a") (box "a"))
+(test #f equal? "" (string #\null))
+
+(test #f equal? 'a "a")
+(test #f equal? 'a 'b)
+(test #f equal? '(a) '(b))
+(test #f equal? '(a (b) d) '(a (b) c))
+(test #f equal? '(a (b) c) '(d (b) c))
+(test #f equal? '(a (b) c) '(a (d) c))
+(test #f equal? "abc" "abcd")
+(test #f equal? "abcd" "abc")
+(test #f equal? 2 3)
+(test #f equal? 2.0 2)
+(test #f equal? (make-vector 5 'b) (make-vector 5 'a))
+(test #f equal? (box "a") (box "b"))
+
+(arity-test eq? 2 2)
+(arity-test eqv? 2 2)
+(arity-test equal? 2 2)
+
+(SECTION 6 3)
+(test '(a b c d e) 'dot '(a . (b . (c . (d . (e . ()))))))
+(define x (list 'a 'b 'c))
+(define y x)
+(and list? (test #t list? y))
+(set-cdr! x 4)
+(test '(a . 4) 'set-cdr! x)
+(test #t eqv? x y)
+(test '(a b c . d) 'dot '(a . (b . (c . d))))
+(test #f list? y)
+(let ((x (list 'a))) (set-cdr! x x) (test #f list? x))
+(arity-test list? 1 1)
+
+(test #t pair? '(a . b))
+(test #t pair? '(a . 1))
+(test #t pair? '(a b c))
+(test #f pair? '())
+(test #f pair? '#(a b))
+(arity-test pair? 1 1)
+
+(test '(a) cons 'a '())
+(test '((a) b c d) cons '(a) '(b c d))
+(test '("a" b c) cons "a" '(b c))
+(test '(a . 3) cons 'a 3)
+(test '((a b) . c) cons '(a b) 'c)
+(arity-test cons 2 2) 
+
+(test 'a car '(a b c))
+(test '(a) car '((a) b c d))
+(test 1 car '(1 . 2))
+(arity-test car 1 1)
+(err/rt-test (car 1))
+
+(test '(b c d) cdr '((a) b c d))
+(test 2 cdr '(1 . 2))
+(arity-test cdr 1 1)
+(err/rt-test (cdr 1))
+
+(test '(a 7 c) list 'a (+ 3 4) 'c)
+(test '() list)
+
+(test 3 length '(a b c))
+(test 3 length '(a (b) (c d e)))
+(test 0 length '())
+(arity-test length 1 1)
+(err/rt-test (length 1))
+(err/rt-test (length '(1 . 2)))
+(err/rt-test (length "a"))
+; (err/rt-test (length (quote #0=(1 . #0#))))
+(err/rt-test (let ([p (cons 1 1)]) (set-cdr! p p) (length p)))
+(define x (cons 4 0))
+(set-cdr! x x) 
+(err/rt-test (length x))
+
+(define l '(1 2 3))
+(set-cdr! l 5)
+(test '(1 . 5) 'set-cdr! l)
+(set-car! l 0)
+(test '(0 . 5) 'set-car! l)
+(arity-test set-car! 2 2)
+(arity-test set-cdr! 2 2)
+(err/rt-test (set-car! 4 4))
+(err/rt-test (set-cdr! 4 4))
+
+(define (box-tests box unbox box? set-box! set-box!-name unbox-name)
+  (define b (box 5))
+  (test 5 unbox b)
+  (when set-box!
+	(set-box! b 6)
+	(test 6 unbox b))
+  (test #t box? b)
+  (test #f box? 5)
+  (arity-test box 1 1)
+  (arity-test unbox 1 1)
+  (arity-test box? 1 1)
+  (when set-box!
+	(arity-test set-box! 2 2))
+  (err/rt-test (unbox 8))
+  (when set-box!
+    (err/rt-test (set-box! 8 8))))
+(box-tests box unbox box? set-box! 'set-box! 'unbox)
+(box-tests make-weak-box weak-box-value weak-box? #f #f 'weak-box-value)
+
+(test '(x y) append '(x) '(y))
+(test '(a b c d) append '(a) '(b c d))
+(test '(a (b) (c)) append '(a (b)) '((c)))
+(test '() append)
+(test '(a b c . d) append '(a b) '(c . d))
+(test 'a append '() 'a)
+(test 1 append 1)
+(test '(1 . 2) append '(1) 2)
+(test '(1 . 2) append '(1) 2)
+(err/rt-test (append '(1 2 . 3) 1))
+(err/rt-test (append '(1 2 3) 1 '(4 5 6)))
+(test '(x y) append! '(x) '(y))
+(test '(a b c d) append! '(a) '(b c d))
+(test '(a (b) (c)) append! '(a (b)) '((c)))
+(test '() append!)
+(test '(a b c . d) append! '(a b) '(c . d))
+(test 'a append! '() 'a)
+(test 1 append! 1)
+(err/rt-test (append! '(1 2 . 3) 1))
+(err/rt-test (append! '(1 2 3) 1 '(4 5 6)))
+(err/rt-test (append! (cons-immutable 1 null) '(4 5 6)))
+
+(define l '(1 2))
+(define l2 '(3 4 . 7))
+(define l3 (append l l2))
+(test '(1 2 3 4 . 7) 'append l3)
+(set-car! l2 5)
+(test '(1 2 5 4 . 7) 'append l3)
+(set-car! l3 0)
+(test '(0 2 5 4 . 7) 'append l3)
+(test '(1 2) 'append l)
+
+(let* ([l '(1 2)]
+       [l2 '(3 4 . 7)]
+       [l3 (append! l l2)])
+  (test '(1 2 3 4 . 7) 'append! l3)
+  (set-car! l2 5)
+  (test '(1 2 5 4 . 7) 'append! l3)
+  (set-car! l3 0)
+  (test '(0 2 5 4 . 7) 'append! l3)
+  (test '(0 2 5 4 . 7) 'append! l))
+
+(test '(c b a) reverse '(a b c))
+(test '((e (f)) d (b c) a) reverse '(a (b c) d (e (f))))
+(arity-test reverse 1 1)
+(err/rt-test (reverse 1))
+(err/rt-test (reverse '(1 . 1)))
+
+(define l '(a b c))
+(test '(c b a) reverse! l)
+(test '(a) 'reverse! l)
+(test '((e (f)) d (b c) a) reverse! '(a (b c) d (e (f))))
+(arity-test reverse! 1 1)
+(err/rt-test (reverse! 1))
+(err/rt-test (reverse! '(1 . 1)))
+
+(test 'c list-ref '(a b c d) 2)
+(test 'c list-ref '(a b c . d) 2)
+(arity-test list-ref 2 2)
+(err/rt-test (list-ref 1 1) exn:application:mismatch?)
+(err/rt-test (list-ref '(a b . c) 2) exn:application:mismatch?)
+(err/rt-test (list-ref '(1 2 3) 2.0))
+(err/rt-test (list-ref '(1) '(1)))
+(err/rt-test (list-ref '(1) 1) exn:application:mismatch?)
+(err/rt-test (list-ref '() 0) exn:application:mismatch?)
+(err/rt-test (list-ref '() 0) exn:application:mismatch?)
+(err/rt-test (list-ref '(1) -1))
+(err/rt-test (list-ref '(1) 2000000000000) exn:application:mismatch?)
+
+(test '(c d) list-tail '(a b c d) 2)
+(test '(a b c d) list-tail '(a b c d) 0)
+(test '(b c . d) list-tail '(a b c . d) 1)
+(test 1 list-tail 1 0)
+(arity-test list-tail 2 2)
+(err/rt-test (list-tail 1 1) exn:application:mismatch?)
+(err/rt-test (list-tail '(1 2 3) 2.0))
+(err/rt-test (list-tail '(1) '(1)))
+(err/rt-test (list-tail '(1) -1))
+(err/rt-test (list-tail '(1) 2) exn:application:mismatch?)
+(err/rt-test (list-tail '(1 2 . 3) 3) exn:application:mismatch?)
+
+(define (test-mem memq memq-name)
+  (test '(a b c) memq 'a '(a b c))
+  (test '(b c) memq 'b '(a b c))
+  (test '(b . c) memq 'b '(a b . c))
+  (test '#f memq 'a '(b c d))
+
+  (arity-test memq 2 2)
+  (err/rt-test (memq 'a 1) exn:application:mismatch?)
+  (err/rt-test (memq 'a '(1 . 2)) exn:application:mismatch?))
+
+(test-mem memq 'memq)
+(test-mem memv 'memv)
+(test-mem member 'member)
+
+(test #f memq "apple" '("apple"))
+(test #f memv "apple" '("apple"))
+(test '("apple") member "apple" '("apple"))
+
+; (test #f memq 1/2 '(1/2)) ; rationals are immutable and we may want to optimize
+(test '(1/2) memv 1/2 '(1/2))
+(test '(1/2) member 1/2 '(1/2))
+
+(test '((1 2)) member '(1 2) '(1 2 (1 2)))
+
+(define (test-ass assq assq-name)
+  (define e '((a 1) (b 2) (c 3)))
+  (test '(a 1) assq 'a e)
+  (test '(b 2) assq 'b e)
+  (test #f assq 'd e)
+  (test '(a 1) assq 'a '((x 0) (a 1) b 2))
+  (test '(a 1) assq 'a '((x 0) (a 1) . 0))
+  (arity-test assq 2 2)
+
+  (err/rt-test (assq 1 1) exn:application:mismatch?)
+  (err/rt-test (assq 1 '(1 2))  exn:application:mismatch?)
+  (err/rt-test (assq 1 '((0) . 2)) exn:application:mismatch?))
+
+(test-ass assq 'assq)
+(test-ass assv 'assv)
+(test-ass assoc 'assoc)
+
+(test #f assq '(a) '(((a)) ((b)) ((c))))
+(test #f assv '(a) '(((a)) ((b)) ((c))))
+(test '((b) 1) assoc '(b) '(((a)) ((b) 1) ((c))))
+
+; (test #f assq '1/2 '(((a)) (1/2) ((c)))) ; rationals are immutable and we may want to optimize
+(test '(1/2) assv '1/2 '(((a)) (1/2) ((c))))
+(test '(1/2) assoc '1/2 '(((a)) (1/2) ((c))))
+
+(test #f immutable? (cons 1 null))
+(test #f immutable? (list 1))
+(test #f immutable? (list 1 2))
+(test #f immutable? (list* 1 null))
+(test #f immutable? (list* 1 2 null))
+(test #f immutable? 1)
+(test #f immutable? #(1 2 3))
+(test #f immutable? #())
+(test #f immutable? (string-copy "hi"))
+
+(test #t immutable? (cons-immutable 1 null))
+(test #t immutable? (list-immutable 1))
+(test #t immutable? (list-immutable 1 2))
+(test #t immutable? (list*-immutable 1 null))
+(test #t immutable? (list*-immutable 1 2 null))
+(test #t immutable? "hi")
+(test #t immutable? (string->immutable-string "hi"))
+(test #t immutable? (string->immutable-string (string-copy "hi")))
+
+(SECTION 6 4)
+(test #t symbol? 'foo)
+(test #t symbol? (car '(a b)))
+(test #f symbol? "bar")
+(test #t symbol? 'nil)
+(test #f symbol? '())
+(test #f symbol? #f)
+;;; But first, what case are symbols in?  Determine the standard case:
+#ci(parameterize ([read-case-sensitive #f])
+     (define char-standard-case char-upcase)
+     (if (string=? (symbol->string 'A) "a")
+	 (set! char-standard-case char-downcase))
+     (test #t 'standard-case
+	   (string=? (symbol->string 'a) (symbol->string 'A)))
+     (test #t 'standard-case
+	   (or (string=? (symbol->string 'a) "A")
+	       (string=? (symbol->string 'A) "a")))
+     (let ()
+       (define (str-copy s)
+	 (let ((v (make-string (string-length s))))
+	   (do ((i (- (string-length v) 1) (- i 1)))
+	       ((< i 0) v)
+	     (string-set! v i (string-ref s i)))))
+       (define (string-standard-case s)
+	 (set! s (str-copy s))
+	 (do ((i 0 (+ 1 i))
+	      (sl (string-length s)))
+	     ((>= i sl) s)
+	   (string-set! s i (char-standard-case (string-ref s i)))))
+       (test (string-standard-case "flying-fish") symbol->string 'flying-fish)
+       (test (string-standard-case "martin") symbol->string 'Martin)
+       (test "Malvina" symbol->string (string->symbol "Malvina"))
+       (test #t 'standard-case (eq? 'a 'A))))
+
+(define x (string #\a #\b))
+(define y (string->symbol x))
+(string-set! x 0 #\c)
+(test "cb" 'string-set! x)
+(test "ab" symbol->string y)
+(test y string->symbol "ab")
+
+#ci(test #t eq? 'mISSISSIppi 'mississippi)
+#ci(test #f 'string->symbol (eq? 'bitBlt (string->symbol "bitBlt")))
+#cs(test #t 'string->symbol (eq? 'bitBlt (string->symbol "bitBlt")))
+(test 'JollyWog string->symbol (symbol->string 'JollyWog))
+#ci(test 'JollyWog string->symbol (symbol->string 'JollyWog))
+
+(arity-test symbol? 1 1)
+
+(SECTION 6 6)
+
+(define (char-tests)
+  (test #t eqv? '#\  #\Space)
+  (test #t eqv? #\space '#\Space)
+  (test #t char? #\a)
+  (test #t char? #\()
+  (test #t char? #\ )
+  (test #t char? '#\newline)
+  (arity-test char? 1 1)
+
+  (test #f char=? #\A #\B)
+  (test #f char=? #\A #\A #\B)
+  (test #f char=? #\A #\B #\A)
+  (test #f char=? #\a #\b)
+  (test #f char=? #\9 #\0)
+  (test #t char=? #\A #\A)
+  (test #t char=? #\A #\A #\A)
+  (test #t char=? #\370 #\370)
+  (test #f char=? #\371 #\370)
+  (test #f char=? #\370 #\371)
+  (arity-test char=? 2 -1)
+  (err/rt-test (char=? #\a 1)) 
+  (err/rt-test (char=? #\a #\b 1)) 
+  (err/rt-test (char=? 1 #\a))
+
+  (test #t char<? #\A #\B)
+  (test #t char<? #\A #\B #\C)
+  (test #f char<? #\A #\B #\A)
+  (test #f char<? #\A #\A #\C)
+  (test #t char<? #\a #\b)
+  (test #f char<? #\9 #\0)
+  (test #f char<? #\A #\A)
+  (test #f char<? #\370 #\370)
+  (test #f char<? #\371 #\370)
+  (test #t char<? #\370 #\371)
+  (arity-test char<? 2 -1)
+  (err/rt-test (char<? #\a 1)) 
+  (err/rt-test (char<? #\a #\a 1)) 
+  (err/rt-test (char<? 1 #\a))
+
+  (test #f char>? #\A #\B)
+  (test #t char>? #\B #\A)
+  (test #f char>? #\A #\B #\C)
+  (test #f char>? #\B #\A #\C)
+  (test #t char>? #\C #\B #\A)
+  (test #f char>? #\a #\b)
+  (test #t char>? #\9 #\0)
+  (test #f char>? #\A #\A)
+  (test #f char>? #\370 #\370)
+  (test #t char>? #\371 #\370)
+  (test #f char>? #\370 #\371)
+  (arity-test char>? 2 -1)
+  (err/rt-test (char>? #\a 1)) 
+  (err/rt-test (char>? #\a #\a 1)) 
+  (err/rt-test (char>? 1 #\a))
+
+  (test #t char<=? #\A #\B)
+  (test #t char<=? #\A #\B #\C)
+  (test #t char<=? #\A #\A #\C)
+  (test #f char<=? #\A #\B #\A)
+  (test #f char<=? #\B #\A #\C)
+  (test #t char<=? #\a #\b)
+  (test #f char<=? #\9 #\0)
+  (test #t char<=? #\A #\A)
+  (test #t char<=? #\370 #\370)
+  (test #f char<=? #\371 #\370)
+  (test #t char<=? #\370 #\371)
+  (arity-test char<=? 2 -1)
+  (err/rt-test (char<=? #\a 1)) 
+  (err/rt-test (char<=? #\b #\a 1)) 
+  (err/rt-test (char<=? 1 #\a))
+
+  (test #f char>=? #\A #\B)
+  (test #f char>=? #\a #\b)
+  (test #t char>=? #\9 #\0)
+  (test #t char>=? #\A #\A)
+  (test #t char>=? #\370 #\370)
+  (test #t char>=? #\371 #\370)
+  (test #f char>=? #\370 #\371)
+  (arity-test char>=? 2 -1)
+  (err/rt-test (char>=? #\a 1)) 
+  (err/rt-test (char>=? #\a #\b 1)) 
+  (err/rt-test (char>=? 1 #\a))
+
+  (test #f char-ci=? #\A #\B)
+  (test #f char-ci=? #\A #\A #\B)
+  (test #f char-ci=? #\a #\B)
+  (test #f char-ci=? #\A #\b)
+  (test #f char-ci=? #\a #\b)
+  (test #f char-ci=? #\9 #\0)
+  (test #t char-ci=? #\A #\A)
+  (test #t char-ci=? #\A #\a)
+  (test #t char-ci=? #\A #\a #\A)
+  (test #t char-ci=? #\370 #\370)
+  (test #f char-ci=? #\371 #\370)
+  (test #f char-ci=? #\370 #\371)
+  (arity-test char-ci=? 2 -1)
+  (err/rt-test (char-ci=? #\a 1)) 
+  (err/rt-test (char-ci=? #\a #\b 1)) 
+  (err/rt-test (char-ci=? 1 #\a))
+
+  (test #t char-ci<? #\A #\B)
+  (test #t char-ci<? #\A #\B #\C)
+  (test #t char-ci<? #\a #\B)
+  (test #t char-ci<? #\A #\b)
+  (test #t char-ci<? #\A #\b #\C)
+  (test #t char-ci<? #\a #\b)
+  (test #f char-ci<? #\9 #\0)
+  (test #f char-ci<? #\A #\A)
+  (test #f char-ci<? #\A #\a)
+  (test #f char-ci<? #\A #\b #\B)
+  (test #f char-ci<? #\370 #\370)
+  (test #f char-ci<? #\371 #\370)
+  (test #t char-ci<? #\370 #\371)
+  (arity-test char-ci<? 2 -1)
+  (err/rt-test (char-ci<? #\a 1)) 
+  (err/rt-test (char-ci<? #\b #\a 1)) 
+  (err/rt-test (char-ci<? 1 #\a))
+
+  (test #f char-ci>? #\A #\B)
+  (test #f char-ci>? #\B #\A #\C)
+  (test #t char-ci>? #\C #\B #\A)
+  (test #f char-ci>? #\a #\B)
+  (test #f char-ci>? #\A #\b)
+  (test #f char-ci>? #\a #\b)
+  (test #t char-ci>? #\C #\b #\A)
+  (test #t char-ci>? #\9 #\0)
+  (test #f char-ci>? #\A #\A)
+  (test #f char-ci>? #\A #\a)
+  (test #f char-ci>? #\370 #\370)
+  (test #t char-ci>? #\371 #\370)
+  (test #f char-ci>? #\370 #\371)
+  (arity-test char-ci>? 2 -1)
+  (err/rt-test (char-ci>? #\a 1)) 
+  (err/rt-test (char-ci>? #\a #\b 1)) 
+  (err/rt-test (char-ci>? 1 #\a))
+
+  (test #t char-ci<=? #\A #\B)
+  (test #t char-ci<=? #\a #\B)
+  (test #t char-ci<=? #\a #\B #\C)
+  (test #f char-ci<=? #\a #\b #\A)
+  (test #t char-ci<=? #\A #\b)
+  (test #t char-ci<=? #\a #\b)
+  (test #f char-ci<=? #\9 #\0)
+  (test #t char-ci<=? #\A #\A)
+  (test #t char-ci<=? #\A #\a)
+  (test #t char-ci<=? #\370 #\370)
+  (test #f char-ci<=? #\371 #\370)
+  (test #t char-ci<=? #\370 #\371)
+  (arity-test char-ci<=? 2 -1)
+  (err/rt-test (char-ci<=? #\a 1)) 
+  (err/rt-test (char-ci<=? #\b #\a 1)) 
+  (err/rt-test (char-ci<=? 1 #\a))
+
+  (test #f char-ci>=? #\A #\B)
+  (test #f char-ci>=? #\B #\A #\C)
+  (test #t char-ci>=? #\B #\B #\A)
+  (test #f char-ci>=? #\a #\B)
+  (test #f char-ci>=? #\A #\b)
+  (test #f char-ci>=? #\a #\b)
+  (test #t char-ci>=? #\9 #\0)
+  (test #t char-ci>=? #\A #\A)
+  (test #t char-ci>=? #\A #\a)
+  (test #t char-ci>=? #\370 #\370)
+  (test #t char-ci>=? #\371 #\370)
+  (test #f char-ci>=? #\370 #\371)
+  (arity-test char-ci>=? 2 -1)
+  (err/rt-test (char-ci>=? #\a 1)) 
+  (err/rt-test (char-ci>=? #\a #\b 1)) 
+  (err/rt-test (char-ci>=? 1 #\a)))
+
+(char-tests)      
+
+(define (ascii-range start end)
+  (let ([s (or (and (number? start) start) (char->integer start))]
+	[e (or (and (number? end) end) (char->integer end))])
+    (let loop ([n e][l (list (integer->char e))])
+      (if (= n s)
+	  l
+	  (let ([n (sub1 n)])
+	    (loop n (cons (integer->char n) l)))))))
+
+(define uppers (ascii-range #\A #\Z))
+(define lowers (ascii-range #\a #\z))
+
+
+(define alphas (append uppers lowers))
+(define digits (ascii-range #\0 #\9))
+(define whites (list #\newline #\return #\space #\page #\tab #\vtab))
+
+(define (test-all is-a? name members)
+  (let loop ([n 0])
+    (unless (= n 128)
+      (let ([c (integer->char n)])
+	(test (and (memq c members) #t) `(,is-a? (integer->char ,n)) (is-a? c))
+	(loop (add1 n)))))
+  (arity-test is-a? 1 1)
+  (err/rt-test (is-a? 1)))
+
+(test-all char-alphabetic? 'char-alphabetic? alphas) 
+(test-all char-numeric? 'char-numeric? digits) 
+(test-all char-whitespace? 'char-whitespace? whites) 
+(test-all char-upper-case? 'char-upper-case? uppers) 
+(test-all char-lower-case? 'char-lower-case? lowers) 
+
+(let loop ([n 0])
+  (unless (= n 512)
+     (test n 'integer->char (char->integer (integer->char n)))
+     (loop (add1 n))))
+
+(test 0 char->integer #\nul)
+(test 10 char->integer #\newline)
+(test 13 char->integer #\return)
+(test 9 char->integer #\tab)
+(test 8 char->integer #\backspace)
+(test 12 char->integer #\page)
+(test 32 char->integer #\space)
+(test 127 char->integer #\rubout)
+(test #\null 'null #\nul)
+(test #\newline 'linefeed #\linefeed)
+
+(test #\. integer->char (char->integer #\.))
+(test #\A integer->char (char->integer #\A))
+(test #\a integer->char (char->integer #\a))
+(test #\371 integer->char (char->integer #\371))
+(test #\U12345 integer->char (char->integer #\U12345))
+(arity-test integer->char 1 1)
+(arity-test char->integer 1 1)
+(err/rt-test (integer->char 5.0))
+(err/rt-test (integer->char 'a))
+(err/rt-test (integer->char -1))
+(err/rt-test (integer->char (expt 2 32)))
+(err/rt-test (integer->char 10000000000000000))
+(err/rt-test (char->integer 5))
+
+(define (test-up/down case case-name members memassoc)
+  (let loop ([n 0])
+    (unless (= n 128)
+      (let ([c (integer->char n)])
+	(if (memq c members)
+	    (test (cdr (assq c memassoc)) case c)
+	    (test c case c)))
+      (loop (add1 n))))
+  (arity-test case 1 1)
+  (err/rt-test (case 2)))
+
+(test-up/down char-upcase 'char-upcase lowers (map cons lowers uppers))
+(test-up/down char-downcase 'char-downcase uppers (map cons uppers lowers))
+
+(SECTION 6 7)
+(test #t string? "The word \"recursion\\\" has many meanings.")
+(test #t string? "")
+(arity-test string? 1 1)
+(test 3 'make-string (string-length (make-string 3)))
+(test "" make-string 0)
+(arity-test make-string 1 2)
+(err/rt-test (make-string "hello"))
+(err/rt-test (make-string 5 "hello"))
+(err/rt-test (make-string 5.0 #\b))
+(err/rt-test (make-string 5.2 #\a))
+(err/rt-test (make-string -5 #\f))
+(err/rt-test (make-string 500000000000000 #\f) exn:fail:out-of-memory?) ;; bignum on 32-bit machines
+(err/rt-test (make-string 50000000000000000000 #\f) exn:fail:out-of-memory?)  ;; bignum on 64-bit machines
+
+
+(define f (make-string 3 #\*))
+(test "?**" 'string-set! (begin (string-set! f 0 #\?) f))
+(arity-test string-set! 3 3)
+(err/rt-test (string-set! "hello" 0 #\a)) ; immutable string constant
+(define hello-string (string-copy "hello"))
+(err/rt-test (string-set! hello-string 'a #\a))
+(err/rt-test (string-set! 'hello 4 #\a))
+(err/rt-test (string-set! hello-string 4 'a))
+(err/rt-test (string-set! hello-string 4.0 'a))
+(err/rt-test (string-set! hello-string 5 #\a) exn:application:mismatch?)
+(err/rt-test (string-set! hello-string -1 #\a))
+(err/rt-test (string-set! hello-string (expt 2 100) #\a) exn:application:mismatch?)
+(test "abc" string #\a #\b #\c)
+(test "" string)
+(err/rt-test (string #\a 1))
+(err/rt-test (string 1 #\a))
+(err/rt-test (string 1))
+(test 3 string-length "abc")
+(test 0 string-length "")
+(arity-test string-length 1 1)
+(err/rt-test (string-length 'apple))
+(test #\a string-ref "abc" 0)
+(test #\c string-ref "abc" 2)
+(arity-test string-ref 2 2)
+(err/rt-test (string-ref 'apple 4))
+(err/rt-test (string-ref "apple" 4.0))
+(err/rt-test (string-ref "apple" '(4)))
+(err/rt-test (string-ref "apple" 5) exn:application:mismatch?)
+(err/rt-test (string-ref "" 0) exn:application:mismatch?)
+(err/rt-test (string-ref "" (expt 2 100)) exn:application:mismatch?)
+(err/rt-test (string-ref "apple" -1))
+(test "" substring "ab" 0 0)
+(test "" substring "ab" 1 1)
+(test "" substring "ab" 2 2)
+(test "a" substring "ab" 0 1)
+(test "b" substring "ab" 1 2)
+(test "ab" substring "ab" 0 2)
+(test "ab" substring "ab" 0)
+(test "b" substring "ab" 1)
+(test "" substring "ab" 2)
+(test (string #\a #\nul #\b) substring (string #\- #\a #\nul #\b #\*) 1 4)
+(arity-test substring 2 3)
+(err/rt-test (substring 'hello 2 3))
+(err/rt-test (substring "hello" "2" 3))
+(err/rt-test (substring "hello" 2.0 3))
+(err/rt-test (substring "hello" 2 3.0))
+(err/rt-test (substring "hello" 2 "3"))
+(err/rt-test (substring "hello" 2 7) exn:application:mismatch?)
+(err/rt-test (substring "hello" -2 3))
+(err/rt-test (substring "hello" 4 3) exn:application:mismatch?)
+(err/rt-test (substring "hello" (expt 2 100) 3) exn:application:mismatch?)
+(err/rt-test (substring "hello" (expt 2 100) 5) exn:application:mismatch?)
+(err/rt-test (substring "hello" 3 (expt 2 100)) exn:application:mismatch?)
+(test "foobar" string-append "foo" "bar")
+(test "foo" string-append "foo")
+(test "foo" string-append "foo" "")
+(test "foogoo" string-append "foo" "" "goo")
+(test "foo" string-append "" "foo")
+(test "" string-append)
+(test (string #\a #\nul #\b #\c #\nul #\d) 
+      string-append (string #\a #\nul #\b) (string #\c #\nul #\d))
+(err/rt-test (string-append 1))
+(err/rt-test (string-append "hello" 1))
+(err/rt-test (string-append "hello" 1 "done"))
+(test "" make-string 0)
+(define s (string-copy "hello"))
+(define s2 (string-copy s))
+(test "hello" 'string-copy s2)
+(string-set! s 2 #\x)
+(test "hello" 'string-copy s2)
+(test (string #\a #\nul #\b) string-copy (string #\a #\nul #\b))
+(string-fill! s #\x)
+(test "xxxxx" 'string-fill! s)
+(arity-test string-copy 1 1)
+(arity-test string-fill! 2 2)
+(err/rt-test (string-copy 'blah))
+(err/rt-test (string-fill! 'sym #\1))
+(err/rt-test (string-fill! "static" #\1))
+(err/rt-test (string-fill! (string-copy "oops") 5))
+
+(let ([s (make-string 10 #\x)])
+  (test (void) string-copy! s 0 "hello")
+  (test "helloxxxxx" values s)
+  (test (void) string-copy! s 3 "hello")
+  (test "helhelloxx" values s)
+  (err/rt-test (string-copy! s 6 "hello") exn:application:mismatch?)
+  (test (void) string-copy! s 5 "hello" 3)
+  (test "helhelooxx" values s)
+  (test (void) string-copy! s 5 "hello" 3)
+  (test "helhelooxx" values s)
+  (test (void) string-copy! s 0 "hello" 3 4)
+  (test "lelhelooxx" values s)
+  (test (void) string-copy! s 1 "hello" 3 5)
+  (test "llohelooxx" values s)
+  (err/rt-test (string-copy! s 1 "hello" 3 6) exn:application:mismatch?))
+
+(arity-test string-copy! 3 5)
+(let ([s (string-copy x)])
+  (err/rt-test (string-copy! "x" 0 "x"))
+  (err/rt-test (string-copy! s "x" "x"))
+  (err/rt-test (string-copy! 0 0 "x"))
+  (err/rt-test (string-copy! s 0 "x" -1))
+  (err/rt-test (string-copy! s 0 "x" 1 0) exn:application:mismatch?)
+  (err/rt-test (string-copy! s 2 "x" 0 1) exn:application:mismatch?))
+
+(test "Hello, and how are you?" string->immutable-string "Hello, and how are you?")
+(arity-test string->immutable-string 1 1)
+(err/rt-test (string->immutable-string 'hello))
+
+(define ax (string #\a #\nul #\370 #\x))
+(define abigx (string #\a #\nul #\370 #\X))
+(define ax2 (string #\a #\nul #\370 #\x))
+(define ay (string #\a #\nul #\371 #\x))
+
+(define (string-tests)
+  (test #t string=? "" "")
+  (test #f string<? "" "")
+  (test #f string>? "" "")
+  (test #t string<=? "" "")
+  (test #t string>=? "" "")
+  (test #t string-ci=? "" "")
+  (test #f string-ci<? "" "")
+  (test #f string-ci>? "" "")
+  (test #t string-ci<=? "" "")
+  (test #t string-ci>=? "" "")
+
+  (test #f string=? "A" "B")
+  (test #f string=? "a" "b")
+  (test #f string=? "9" "0")
+  (test #t string=? "A" "A")
+  (test #f string=? "A" "AB")
+  (test #t string=? ax ax2)
+  (test #f string=? ax abigx)
+  (test #f string=? ax ay)
+  (test #f string=? ay ax)
+
+  (test #t string<? "A" "B")
+  (test #t string<? "a" "b")
+  (test #f string<? "9" "0")
+  (test #f string<? "A" "A")
+  (test #t string<? "A" "AB")
+  (test #f string<? "AB" "A")
+  (test #f string<? ax ax2)
+  (test #t string<? ax ay)
+  (test #f string<? ay ax)
+
+  (test #f string>? "A" "B")
+  (test #f string>? "a" "b")
+  (test #t string>? "9" "0")
+  (test #f string>? "A" "A")
+  (test #f string>? "A" "AB")
+  (test #t string>? "AB" "A")
+  (test #f string>? ax ax2)
+  (test #f string>? ax ay)
+  (test #t string>? ay ax)
+
+  (test #t string<=? "A" "B")
+  (test #t string<=? "a" "b")
+  (test #f string<=? "9" "0")
+  (test #t string<=? "A" "A")
+  (test #t string<=? "A" "AB")
+  (test #f string<=? "AB" "A")
+  (test #t string<=? ax ax2)
+  (test #t string<=? ax ay)
+  (test #f string<=? ay ax)
+
+  (test #f string>=? "A" "B")
+  (test #f string>=? "a" "b")
+  (test #t string>=? "9" "0")
+  (test #t string>=? "A" "A")
+  (test #f string>=? "A" "AB")
+  (test #t string>=? "AB" "A")
+  (test #t string>=? ax ax2)
+  (test #f string>=? ax ay)
+  (test #t string>=? ay ax)
+
+  (test #f string-ci=? "A" "B")
+  (test #f string-ci=? "a" "B")
+  (test #f string-ci=? "A" "b")
+  (test #f string-ci=? "a" "b")
+  (test #f string-ci=? "9" "0")
+  (test #t string-ci=? "A" "A")
+  (test #t string-ci=? "A" "a")
+  (test #f string-ci=? "A" "AB")
+  (test #t string-ci=? ax ax2)
+  (test #t string-ci=? ax abigx)
+  (test #f string-ci=? ax ay)
+  (test #f string-ci=? ay ax)
+  (test #f string-ci=? abigx ay)
+  (test #f string-ci=? ay abigx)
+
+  (test #t string-ci<? "A" "B")
+  (test #t string-ci<? "a" "B")
+  (test #t string-ci<? "A" "b")
+  (test #t string-ci<? "a" "b")
+  (test #f string-ci<? "9" "0")
+  (test #f string-ci<? "A" "A")
+  (test #f string-ci<? "A" "a")
+  (test #t string-ci<? "A" "AB")
+  (test #f string-ci<? "AB" "A")
+  (test #f string-ci<? ax ax2)
+  (test #f string-ci<? ax abigx)
+  (test #t string-ci<? ax ay)
+  (test #f string-ci<? ay ax)
+  (test #t string-ci<? abigx ay)
+  (test #f string-ci<? ay abigx)
+
+  (test #f string-ci>? "A" "B")
+  (test #f string-ci>? "a" "B")
+  (test #f string-ci>? "A" "b")
+  (test #f string-ci>? "a" "b")
+  (test #t string-ci>? "9" "0")
+  (test #f string-ci>? "A" "A")
+  (test #f string-ci>? "A" "a")
+  (test #f string-ci>? "A" "AB")
+  (test #t string-ci>? "AB" "A")
+  (test #f string-ci>? ax ax2)
+  (test #f string-ci>? ax abigx)
+  (test #f string-ci>? ax ay)
+  (test #t string-ci>? ay ax)
+  (test #f string-ci>? abigx ay)
+  (test #t string-ci>? ay abigx)
+
+  (test #t string-ci<=? "A" "B")
+  (test #t string-ci<=? "a" "B")
+  (test #t string-ci<=? "A" "b")
+  (test #t string-ci<=? "a" "b")
+  (test #f string-ci<=? "9" "0")
+  (test #t string-ci<=? "A" "A")
+  (test #t string-ci<=? "A" "a")
+  (test #t string-ci<=? "A" "AB")
+  (test #f string-ci<=? "AB" "A")
+  (test #t string-ci<=? ax ax2)
+  (test #t string-ci<=? ax abigx)
+  (test #t string-ci<=? ax ay)
+  (test #f string-ci<=? ay ax)
+  (test #t string-ci<=? abigx ay)
+  (test #f string-ci<=? ay abigx)
+
+  (test #f string-ci>=? "A" "B")
+  (test #f string-ci>=? "a" "B")
+  (test #f string-ci>=? "A" "b")
+  (test #f string-ci>=? "a" "b")
+  (test #t string-ci>=? "9" "0")
+  (test #t string-ci>=? "A" "A")
+  (test #t string-ci>=? "A" "a")
+  (test #f string-ci>=? "A" "AB")
+  (test #t string-ci>=? "AB" "A")
+  (test #t string-ci>=? ax ax2)
+  (test #t string-ci>=? ax abigx)
+  (test #f string-ci>=? ax ay)
+  (test #t string-ci>=? ay ax)
+  (test #f string-ci>=? abigx ay)
+  (test #t string-ci>=? ay abigx))
+
+(string-tests)
+
+(map (lambda (pred)
+       (arity-test pred 2 -1)
+       (err/rt-test (pred "a" 1))
+       (err/rt-test (pred "a" "b" 5))
+       (err/rt-test (pred 1 "a")))
+     (list string=? 
+	   string>? 
+	   string<? 
+	   string>=? 
+	   string<=? 
+	   string-ci=? 
+	   string-ci>? 
+	   string-ci<? 
+	   string-ci>=? 
+	   string-ci<=?
+	   string-locale=? 
+	   string-locale>? 
+	   string-locale<? 
+	   string-locale-ci=? 
+	   string-locale-ci>? 
+	   string-locale-ci<?))
+
+
+(test #t byte? 10)
+(test #t byte? 0)
+(test #t byte? 255)
+(test #f byte? 256)
+(test #f byte? -1)
+(test #f byte? (expt 2 40))
+(test #f byte? (expt 2 100))
+(test #f byte? #\newline)
+
+(test #t bytes? #"The word \"recursion\\\" has many meanings.")
+(test #t bytes? #"")
+(arity-test bytes? 1 1)
+(test 3 'make-bytes (bytes-length (make-bytes 3)))
+(test #"" make-bytes 0)
+(arity-test make-bytes 1 2)
+(err/rt-test (make-bytes #"hello"))
+(err/rt-test (make-bytes 5 #"hello"))
+(err/rt-test (make-bytes 5.0 98))
+(err/rt-test (make-bytes 5.2 97))
+(err/rt-test (make-bytes -5 98))
+(err/rt-test (make-bytes 500000000000000 #\f) exn:fail:out-of-memory?) ;; bignum on 32-bit machines
+(err/rt-test (make-bytes 50000000000000000000 #\f) exn:fail:out-of-memory?)  ;; bignum on 64-bit machines
+
+
+(define f (make-bytes 3 (char->integer #\*)))
+(test #"?**" 'bytes-set! (begin (bytes-set! f 0 (char->integer #\?)) f))
+(arity-test bytes-set! 3 3)
+(err/rt-test (bytes-set! #"hello" 0 #\a)) ; immutable bytes constant
+(define hello-bytes (bytes-copy #"hello"))
+(err/rt-test (bytes-set! hello-bytes 'a 97))
+(err/rt-test (bytes-set! 'hello 4 97))
+(err/rt-test (bytes-set! hello-bytes 4 'a))
+(err/rt-test (bytes-set! hello-bytes 4.0 'a))
+(err/rt-test (bytes-set! hello-bytes 5 97) exn:application:mismatch?)
+(err/rt-test (bytes-set! hello-bytes -1 97))
+(err/rt-test (bytes-set! hello-bytes (expt 2 100) 97) exn:application:mismatch?)
+(test #"abc" bytes 97 98 99)
+(test #"" bytes)
+(err/rt-test (bytes #\a 1))
+(err/rt-test (bytes 1 #\a))
+(err/rt-test (bytes #\1))
+(test 3 bytes-length #"abc")
+(test 0 bytes-length #"")
+(arity-test bytes-length 1 1)
+(err/rt-test (bytes-length 'apple))
+(test 97 bytes-ref #"abc" 0)
+(test 99 bytes-ref #"abc" 2)
+(arity-test bytes-ref 2 2)
+(err/rt-test (bytes-ref 'apple 4))
+(err/rt-test (bytes-ref #"apple" 4.0))
+(err/rt-test (bytes-ref #"apple" '(4)))
+(err/rt-test (bytes-ref #"apple" 5) exn:application:mismatch?)
+(err/rt-test (bytes-ref #"" 0) exn:application:mismatch?)
+(err/rt-test (bytes-ref #"" (expt 2 100)) exn:application:mismatch?)
+(err/rt-test (bytes-ref #"apple" -1))
+(test #"" subbytes #"ab" 0 0)
+(test #"" subbytes #"ab" 1 1)
+(test #"" subbytes #"ab" 2 2)
+(test #"a" subbytes #"ab" 0 1)
+(test #"b" subbytes #"ab" 1 2)
+(test #"ab" subbytes #"ab" 0 2)
+(test #"ab" subbytes #"ab" 0)
+(test #"b" subbytes #"ab" 1)
+(test #"" subbytes #"ab" 2)
+(test (bytes 97 0 98) subbytes (bytes 32 97 0 98 45) 1 4)
+(arity-test subbytes 2 3)
+(err/rt-test (subbytes 'hello 2 3))
+(err/rt-test (subbytes #"hello" #"2" 3))
+(err/rt-test (subbytes #"hello" 2.0 3))
+(err/rt-test (subbytes #"hello" 2 3.0))
+(err/rt-test (subbytes #"hello" 2 #"3"))
+(err/rt-test (subbytes #"hello" 2 7) exn:application:mismatch?)
+(err/rt-test (subbytes #"hello" -2 3))
+(err/rt-test (subbytes #"hello" 4 3) exn:application:mismatch?)
+(err/rt-test (subbytes #"hello" (expt 2 100) 3) exn:application:mismatch?)
+(err/rt-test (subbytes #"hello" (expt 2 100) 5) exn:application:mismatch?)
+(err/rt-test (subbytes #"hello" 3 (expt 2 100)) exn:application:mismatch?)
+(test #"foobar" bytes-append #"foo" #"bar")
+(test #"foo" bytes-append #"foo")
+(test #"foo" bytes-append #"foo" #"")
+(test #"foogoo" bytes-append #"foo" #"" #"goo")
+(test #"foo" bytes-append #"" #"foo")
+(test #"" bytes-append)
+(test (bytes 97 0 98 99 0 100) 
+      bytes-append (bytes 97 0 98) (bytes 99 0 100))
+(err/rt-test (bytes-append 1))
+(err/rt-test (bytes-append #"hello" 1))
+(err/rt-test (bytes-append #"hello" 1 #"done"))
+(test #"" make-bytes 0)
+(define s (bytes-copy #"hello"))
+(define s2 (bytes-copy s))
+(test #"hello" 'bytes-copy s2)
+(bytes-set! s 2 (char->integer #\x))
+(test #"hello" 'bytes-copy s2)
+(test (bytes 97 0 98) bytes-copy (bytes 97 0 98))
+(bytes-fill! s (char->integer #\x))
+(test #"xxxxx" 'bytes-fill! s)
+(arity-test bytes-copy 1 1)
+(arity-test bytes-fill! 2 2)
+(err/rt-test (bytes-copy 'blah))
+(err/rt-test (bytes-fill! 'sym 1))
+(err/rt-test (bytes-fill! #"static" 1))
+(err/rt-test (bytes-fill! (bytes-copy #"oops") #\5))
+
+(define r (regexp "(-[0-9]*)+"))
+(test '("-12--345" "-345") regexp-match r "a-12--345b")
+(test '((1 . 9) (5 . 9)) regexp-match-positions r "a-12--345b")
+(test '("--345" "-345") regexp-match r "a-12--345b" 2)
+(test '("--34" "-34") regexp-match r "a-12--345b" 2 8)
+(test '((4 . 9) (5 . 9)) regexp-match-positions r "a-12--345b" 2)
+(test '((4 . 8) (5 . 8)) regexp-match-positions r "a-12--345b" 2 8)
+(test '("a-b") regexp-match "a[-c]b" "a-b")
+(test '("a-b") regexp-match "a[c-]b" "a-b")
+(test #f regexp-match "x+" "12345")
+(test "su casa" regexp-replace "mi" "mi casa" "su")
+(define r2 (regexp "([Mm])i ([a-zA-Z]*)"))
+(define insert "\\1y \\2")
+(test "My Casa" regexp-replace r2 "Mi Casa" insert)
+(test "my cerveza Mi Mi Mi" regexp-replace r2 "mi cerveza Mi Mi Mi" insert)
+(test "my cerveza My Mi Mi" regexp-replace* r2 "mi cerveza Mi Mi Mi" insert)
+(test "bbb" regexp-replace* "a" "aaa" "b")
+
+;; Test weird port offsets:
+(define (test-weird-offset regexp-match regexp-match-positions)
+  (test #f regexp-match "e" (open-input-string ""))
+  (test #f regexp-match "e" (open-input-string "") (expt 2 100))
+  (test #f regexp-match "e" (open-input-string "") (expt 2 100) (expt 2 101))
+  (test '((3 . 4)) regexp-match-positions "e" (open-input-string "eaae") 2 (expt 2 101)))
+(test-weird-offset regexp-match regexp-match-positions)
+(test-weird-offset regexp-match-peek regexp-match-peek-positions)
+
+;; Check greedy and non-greedy operators:
+(define (do-the-tests prefix suffix start end)
+  (define input (format "~a~a~a" prefix "<tag1 b=5> <tag2 bb=7>" suffix))
+  (define (check-greedy-stuff mk-input regexp-match regexp-match-positions)
+    (define (testre s-answer p-answer pattern)
+      (let ([p-answer (if (and p-answer start)
+			  (list (cons (+ start (caar p-answer))
+				      (+ start (cdar p-answer))))
+			  p-answer)])
+	(cond
+	 [end
+	  (test s-answer regexp-match pattern (mk-input) start (+ end (string-length input)))
+	  (test p-answer regexp-match-positions pattern (mk-input) start (+ end (string-length input)))]
+	 [start
+	  (test s-answer regexp-match pattern (mk-input) start)
+	  (test p-answer regexp-match-positions pattern (mk-input) start)]
+	 [else
+	  (test s-answer regexp-match pattern (mk-input))
+	  (test p-answer regexp-match-positions pattern (mk-input))])))
+    (define strs
+      (if (string? (mk-input))
+	  list
+	  (lambda l (map string->bytes/utf-8 l))))
+    
+    (testre (strs "<tag1 b=5> <tag2 bb=7>") '((0 . 22)) "<.*>")
+    (testre (strs "<tag1 b=5>") '((0 . 10)) "<.*?>")
+    (testre (strs "<tag1 b=5> <tag2 bb=7>") '((0 . 22)) "<.*?>$")
+    (testre (strs "") '((0 . 0)) "b*")
+    (testre (strs "<tag") '((0 . 4)) "^<[tag]*")
+    (testre (strs "<tag") '((0 . 4)) "<[tag]*")
+    (testre (strs "<tag1") '((0 . 5)) "<[tag]*1")
+    (testre (strs "") '((0 . 0)) "b*?")
+    (testre (strs "<") '((0 . 1)) "<[tag]*?")
+    (testre (strs "<tag1") '((0 . 5)) "<[tag]*?1")
+    (testre (strs "b") '((6 . 7)) "b+?")
+    (testre #f #f "^b+?")
+    (testre (strs "<t") '((0 . 2)) "<[tag]+?")
+    (testre (strs "<tag1") '((0 . 5)) "<[tag]+?1")
+    (testre (strs "") '((0 . 0)) "b??")
+    (testre (strs "") '((0 . 0)) "[tag]??")
+    (testre (strs "g1") '((3 . 5)) "[tag]??1")
+    (testre (strs "ag") '((2 . 4)) "[a-m]+"))
+  
+  (check-greedy-stuff (lambda () input) regexp-match regexp-match-positions)
+  (check-greedy-stuff (lambda () (open-input-string input)) regexp-match regexp-match-positions)
+  (let ([p (open-input-string input)])
+    (check-greedy-stuff (lambda () p) regexp-match-peek regexp-match-peek-positions))
+  (let ([mk (lambda ()
+	      (let-values ([(r w) (make-pipe)])
+		(thread (lambda ()
+			  (let loop ([s 0])
+			    (let ([e (min (+ s 1)
+					  (string-length input))])
+			      (display (substring input s e) w)
+			      (sleep)
+			      (unless (= e s)
+				(loop e))))
+			  (close-output-port w)))
+		r))])
+    (check-greedy-stuff mk regexp-match regexp-match-positions)
+    (let ([p (mk)])
+      (check-greedy-stuff (lambda () p) regexp-match-peek regexp-match-peek-positions))))
+
+(do-the-tests "" "" #f #f)
+(do-the-tests "" "" 0 #f)
+(do-the-tests "" "" 0 0)
+(do-the-tests "ack" "" 3 #f)
+(do-the-tests "ack" "" 3 0)
+(do-the-tests "ack" "hmm" 3 -3)
+
+(test '((10002 . 10003)) regexp-match-positions "a" (open-input-string (format "~abbac" (make-string 10000 #\x))))
+
+;; Test regexp with null chars:
+(let* ([s (string #\a #\b #\nul #\c)]
+       [3s (string-append s s s)])
+  (test #f regexp-match (string #\nul) "no nulls")
+  (test (list s) regexp-match s s)
+  (test (list 3s s) regexp-match (format "(~a)*" s) 3s)
+  (test (list (string #\b #\nul #\c)) regexp-match (string #\[ #\nul #\b #\] #\* #\c) s)
+  (test (list (string #\a #\b #\nul)) regexp-match (string #\a #\[ #\b #\nul #\] #\+) s)
+  (test "hihihi" regexp-replace* (string #\nul) (string #\nul #\nul #\nul) "hi"))
+(test (string #\- #\nul #\+ #\- #\nul #\+ #\- #\nul #\+)
+      regexp-replace* "a" "aaa" (string #\- #\nul #\+))
+
+;; Check extremely many subexpressions:
+(for-each
+ (lambda (mx)
+   (let* ([v (make-vector mx null)]
+	  [open (make-vector mx #t)])
+     (let loop ([n 0][m 0][s null])
+       (cond
+	[(and (= n mx) (zero? m))
+	 (let* ([s (list->string (reverse! s))]
+		[plain (regexp-replace* "[()]" s "")])
+	   (test (cons plain (map list->string (map reverse! (vector->list v)))) regexp-match s plain))]
+	[(or (= n mx) (< (random 10) 3))
+	 (if (and (positive? m)
+		  (< (random 10) 7))
+	     (begin
+	       (let loop ([p 0][m (sub1 m)])
+		 (if (vector-ref open p)
+		     (if (zero? m)
+			 (vector-set! open p #f)
+			 (loop (add1 p) (sub1 m)))
+		     (loop (add1 p) m)))
+	       (loop n (sub1 m) (cons #\) s)))
+
+	     (let ([c (integer->char (+ (char->integer #\a) (random 26)))])
+	       (let loop ([p 0])
+		 (unless (= p n)
+		   (when (vector-ref open p)
+		     (vector-set! v p (cons c (vector-ref v p))))
+		   (loop (add1 p))))
+	       (loop n m (cons c s))))]
+	[else
+	 (loop (add1 n) (add1 m) (cons #\( s))]))))
+ '(1 10 100 500))
+
+(define (test-bad-re-args who)
+  (err/rt-test (who 'e "hello"))
+  (err/rt-test (who "e" 'hello))
+  (err/rt-test (who "e" "hello" -1 5))
+  (err/rt-test (who "e" "hello" (- (expt 2 100)) 5))
+  (err/rt-test (who "e" (open-input-string "") (- (expt 2 100)) 5))
+  (err/rt-test (who "e" "hello" 1 (- (expt 2 100))))
+  (err/rt-test (who "e" (open-input-string "") 1 (- (expt 2 100))))
+  (err/rt-test (who "e" "hello" 1 +inf.0))
+  (err/rt-test (who "e" "" 0 1) exn:application:mismatch?)
+  (err/rt-test (who "e" "hello" 3 2) exn:application:mismatch?)
+  (err/rt-test (who "e" "hello" 3 12) exn:application:mismatch?)
+  (err/rt-test (who "e" "hello" (expt 2 100) 5)  exn:application:mismatch?)
+  (err/rt-test (who "e" (open-input-string "") (expt 2 100) 5)  exn:application:mismatch?)
+  (err/rt-test (who "e" (open-input-string "") (expt 2 100) (sub1 (expt 2 100))) exn:application:mismatch?))
+(test-bad-re-args regexp-match)
+(test-bad-re-args regexp-match-positions)
+
+;; Test non-capturing parens
+(test '("1aaa2" "a") regexp-match #rx"1(a)*2" "01aaa23")
+(test '("1aaa2") regexp-match #rx"1(?:a)*2" "01aaa23")
+(test '("1akakak2" "ak") regexp-match #rx"1(ak)*2" "01akakak23")
+(test '("1akakak2") regexp-match #rx"1(?:ak)*2" "01akakak23")
+(test '("1akakkakkkk2" "akkkk") regexp-match #rx"1(ak*)*2" "01akakkakkkk23")
+(test '("1akakkakkkk2") regexp-match #rx"1(?:ak*)*2" "01akakkakkkk23")
+(test '("01akakkakkkk23" "1akakkakkkk2" "1" "a" "k" "2") 
+      regexp-match #rx"(?:0)(((?:1))(?:(a)(?:(k))*)*((?:2)))(?:3)" "_01akakkakkkk23_")
+
+(test '((1 . 10) (7 . 9)) regexp-match-positions #rx"1(ak*)*2" "01akakkak23")
+(test '((1 . 10)) regexp-match-positions #rx"1(?:ak*)*2" "01akakkak23")
+
+;; Regexps that shouldn't work:
+(err/rt-test (regexp "[a--b]") exn:fail?)
+(err/rt-test (regexp "[a-b-c]") exn:fail?)
+
+;; A good test of unicode-friendly ".":
+(test '("load-extension: couldn't open \\\" (%s)\"") 
+      regexp-match 
+      (regexp "^(?:[^\\\"]|\\\\.)*\"") "load-extension: couldn't open \\\" (%s)\"")
+
+;; Test bounded byte consumption on failure:
+(let ([is (open-input-string "barfoo")]) 
+  (test '(#f #\f) list (regexp-match "^foo" is 0 3) (read-char is)))
+(let ([is (open-input-string "barfoo")]) 
+  (test '(#f #\f) list (regexp-match "foo" is 0 3) (read-char is)))
+
+(arity-test regexp 1 1)
+(arity-test regexp? 1 1)
+(arity-test regexp-match 2 5)
+(arity-test regexp-match-positions 2 5)
+(arity-test regexp-match-peek 2 5)
+(arity-test regexp-match-peek-positions 2 5)
+(arity-test regexp-replace 3 3)
+(arity-test regexp-replace* 3 3)
+
+(SECTION 6 8)
+(test #t vector? '#(0 (2 2 2 2) "Anna"))
+(test #t vector? '#())
+(arity-test vector? 1 1)
+(test '#(a b c) vector 'a 'b 'c)
+(test '#() vector)
+(test 3 vector-length '#(0 (2 2 2 2) "Anna"))
+(test 0 vector-length '#())
+(arity-test vector-length 1 1)
+(err/rt-test (vector-length "apple"))
+(test 8 vector-ref '#(1 1 2 3 5 8 13 21) 5)
+(arity-test vector-ref 2 2)
+(err/rt-test (vector-ref "apple" 3))
+(err/rt-test (vector-ref #(4 5 6) 3) exn:application:mismatch?)
+(err/rt-test (vector-ref #() 0) exn:application:mismatch?)
+(err/rt-test (vector-ref #() (expt 2 100)) exn:application:mismatch?)
+(err/rt-test (vector-ref #(4 5 6) -1))
+(err/rt-test (vector-ref #(4 5 6) 2.0))
+(err/rt-test (vector-ref #(4 5 6) "2"))
+(test '#(0 ("Sue" "Sue") "Anna") 'vector-set
+	(let ((vec (vector 0 '(2 2 2 2) "Anna")))
+	  (vector-set! vec 1 '("Sue" "Sue"))
+	  vec))
+(test '#(hi hi) make-vector 2 'hi)
+(test '#() make-vector 0)
+(test '#() make-vector 0 'a)
+(test 2048 vector-length (make-vector 2048 'a))
+(arity-test make-vector 1 2)
+(err/rt-test (make-vector "a" 'a))
+(err/rt-test (make-vector 1.0 'a))
+(err/rt-test (make-vector 10.2 'a))
+(err/rt-test (make-vector -1 'a))
+(err/rt-test (make-vector 1000000000000000000000 'a) exn:fail:out-of-memory?)
+(arity-test vector-set! 3 3)
+(err/rt-test (vector-set! #() 0 'x) exn:application:mismatch?)
+(err/rt-test (vector-set! #(1 2 3) -1 'x))
+(err/rt-test (vector-set! #(1 2 3) 3 'x) exn:application:mismatch?)
+(err/rt-test (vector-set! #(1 2 3) (expt 2 100) 'x) exn:application:mismatch?)
+(err/rt-test (vector-set! '(1 2 3) 2 'x))
+(err/rt-test (vector-set! #(1 2 3) "2" 'x))
+(define v (quote #(1 2 3)))
+(vector-fill! v 0)
+(test (quote #(0 0 0)) 'vector-fill! v)
+(arity-test vector-fill! 2 2)
+(err/rt-test (vector-fill! '(1 2 3) 0))
+
+(SECTION 6 9)
+(test #t procedure? car)
+(test #f procedure? 'car)
+(test #t procedure? (lambda (x) (* x x)))
+(test #f procedure? '(lambda (x) (* x x)))
+(test #t call-with-current-continuation procedure?)
+(test #t call-with-escape-continuation procedure?)
+(test #t procedure? (case-lambda ((x) x) ((x y) (+ x y))))
+(arity-test procedure? 1 1)
+
+(test 7 apply + (list 3 4))
+(test 7 apply (lambda (a b) (+ a b)) (list 3 4))
+(test 17 apply + 10 (list 3 4))
+(test '() apply list '())
+(define compose (lambda (f g) (lambda args (f (apply g args)))))
+(test 30 (compose sqrt *) 12 75)
+(err/rt-test (apply) exn:application:arity?)
+(err/rt-test (apply (lambda x x)) exn:application:arity?)
+(err/rt-test (apply (lambda x x) 1))
+(err/rt-test (apply (lambda x x) 1 2))
+(err/rt-test (apply (lambda x x) 1 '(2 . 3)))
+
+(test '(b e h) map cadr '((a b) (d e) (g h)))
+(test '(5 7 9) map + '(1 2 3) '(4 5 6))
+(test '#(0 1 4 9 16) 'for-each
+	(let ((v (make-vector 5)))
+		(for-each (lambda (i) (vector-set! v i (* i i)))
+			'(0 1 2 3 4))
+		v))
+
+(err/rt-test (let ([l (list 1 2 3)])
+	       (for-each (lambda (x) (set-cdr! (cdr l) 1)) l))
+	     exn:application:mismatch?)
+
+
+(define (map-tests map)
+  (let ([size? exn:application:mismatch?]
+	[non-list? type?])
+    (err/rt-test (map (lambda (x y) (+ x y)) '(1 2) '1))
+    (err/rt-test (map (lambda (x y) (+ x y)) '2 '(1 2)))
+    (err/rt-test (map (lambda (x y) (+ x y)) '(1 2) '(1 2 3)) size?)
+    (err/rt-test (map (lambda (x y) (+ x y)) '(1 2 3) '(1 2)) size?)
+    (err/rt-test (map (lambda (x) (+ x)) '(1 2 . 3)) non-list?)
+    (err/rt-test (map (lambda (x y) (+ x y)) '(1 2 . 3) '(1 2)) non-list?)
+    (err/rt-test (map (lambda (x y) (+ x y)) '(1 2 . 3) '(1 2 3)) non-list?)
+    (err/rt-test (map (lambda (x y) (+ x y)) '(1 2) '(1 2 . 3)) non-list?)
+    (err/rt-test (map (lambda (x y) (+ x y)) '(1 2 3) '(1 2 . 3)) non-list?)
+    (err/rt-test (map) exn:application:arity?)
+    (err/rt-test (map (lambda (x y) (+ x y))) exn:application:arity?)
+    (err/rt-test (map (lambda () 10) null) exn:application:mismatch?)
+    (err/rt-test (map (case-lambda [() 9] [(x y) 10]) '(1 2 3)) exn:application:mismatch?)
+    (err/rt-test (map (lambda (x) 10) '(1 2) '(3 4)) exn:application:mismatch?)))
+(map-tests map)
+(map-tests for-each)
+(map-tests andmap)
+(map-tests ormap)
+
+(test (void) for-each (lambda (x) (values 1 2)) '(1 2))
+(err/rt-test (map (lambda (x) (values 1 2)) '(1 2)) arity?)
+
+(test #t andmap add1 null)
+(test #f ormap add1 null)
+(test #f andmap positive? '(1 -2 3))
+(test #t ormap positive? '(1 -2 3))
+(test #f andmap negative? '(1 -2 3))
+(test #t ormap negative? '(1 -2 3))
+(test 4 andmap add1 '(1 2 3))
+(test 2 ormap add1 '(1 2 3))
+
+(err/rt-test (ormap (lambda (x) (values 1 2)) '(1 2)) arity?)
+(err/rt-test (andmap (lambda (x) (values 1 2)) '(1 2)) arity?)
+
+(err/rt-test (ormap (lambda (x) (values 1 2)) '(1)) arity?)
+(err/rt-test (andmap (lambda (x) (values 1 2)) '(1)) arity?)
+
+(test -3 call-with-current-continuation
+		(lambda (exit)
+		 (for-each (lambda (x) (if (negative? x) (exit x)))
+		 	'(54 0 37 -3 245 19))
+		#t))
+(define list-length
+ (lambda (obj)
+  (call-with-current-continuation
+   (lambda (return)
+    (letrec ((r (lambda (obj) (cond ((null? obj) 0)
+				((pair? obj) (+ (r (cdr obj)) 1))
+				(else (return #f))))))
+	(r obj))))))
+(test 4 list-length '(1 2 3 4))
+(test #f list-length '(a b . c))
+(test '() map cadr '())
+
+;;; This tests full conformance of call-with-current-continuation.  It
+;;; is a separate test because some schemes do not support call/cc
+;;; other than escape procedures.  I am indebted to
+;;; raja@copper.ucs.indiana.edu (Raja Sooriamurthi) for fixing this
+;;; code.  The function leaf-eq? compares the leaves of 2 arbitrary
+;;; trees constructed of conses.  
+(define (next-leaf-generator obj eot)
+  (letrec ((return #f)
+	   (cont (lambda (x)
+		   (recurx obj)
+		   (set! cont (lambda (x) (return eot)))
+		   (cont #f)))
+	   (recurx (lambda (obj)
+		      (if (pair? obj)
+			  (for-each recurx obj)
+			  (call-with-current-continuation
+			   (lambda (c)
+			     (set! cont c)
+			     (return obj)))))))
+    (lambda () (call-with-current-continuation
+		(lambda (ret) (set! return ret) (cont #f))))))
+(define (leaf-eq? x y)
+  (let* ((eot (list 'eot))
+	 (xf (next-leaf-generator x eot))
+	 (yf (next-leaf-generator y eot)))
+    (letrec ((loop (lambda (x y)
+		     (cond ((not (eq? x y)) #f)
+			   ((eq? eot x) #t)
+			   (else (loop (xf) (yf)))))))
+      (loop (xf) (yf)))))
+(define (test-cont)
+  (newline)
+  (display ";testing continuations; ")
+  (SECTION 6 9)
+  (test #t leaf-eq? '(a (b (c))) '((a) b c))
+  (test #f leaf-eq? '(a (b (c))) '((a) b c d))
+  '(report-errs))
+
+(define (test-cc-values test-call/cc)
+  (test '(a b c)
+	call-with-values
+	(lambda ()
+	  (test-call/cc
+	   (lambda (k)
+	     (dynamic-wind
+	      void
+	      (lambda ()
+		(k 'a 'b 'c))
+	      (lambda ()
+		(values 1 2))))))
+	list)
+
+  (test 1 dynamic-wind
+	(lambda () (test-call/cc void))
+	(lambda () 1)
+	(lambda () (test-call/cc void)))
+
+  ; Try devious jumping with pre- and post-thunks:
+  (test 2 test-call/cc
+	(lambda (exit)
+	  (dynamic-wind
+	   (lambda () (exit 2))
+	   void
+	   void)))
+  (test 3 test-call/cc
+	(lambda (exit)
+	  (dynamic-wind
+	   void
+	   void
+	   (lambda () (exit 3)))))
+
+  (let ([rv
+	 (lambda (get-v)
+	   (let ([x 0])
+	     (test-call/cc
+	      (lambda (exit)
+		(dynamic-wind
+		 void
+		 (lambda () (exit))
+		 (lambda () (set! x (get-v))))))
+	     x))]
+	[r56
+	 (lambda ()
+	   (let ([x 0]
+		 [y 1]
+		 [c1 #f])
+	     (dynamic-wind
+	      (lambda () (set! x (add1 x)))
+	      (lambda () 
+		(let/cc k (set! c1 k))
+		(if (>= x 5)
+		    (set! c1 #f)))
+	      (lambda () (set! y (add1 y))))
+	     (when c1 (c1))
+	     (list x y)))]
+	[rx.y
+	 (lambda (get-x get-y)
+	   (let ([c1 #f]
+		 [x 0]
+		 [y 0])
+	     (let ([v
+		    (dynamic-wind
+		     (lambda () (set! y x))
+		     (lambda () (let/cc k (set! c1 k)))
+		     (lambda () 
+		       (set! x (get-x))
+		       (when c1
+			 ((begin0
+			   c1
+			   (set! c1 #f))
+			  (get-y)))))])
+	       (cons y v))))]
+	[rv2
+	 (lambda (get-v)
+	   (let ([c1 #f]
+		 [give-up #f])
+	     (test-call/cc
+	      (lambda (exit)
+		(dynamic-wind
+		 (lambda () (when give-up (give-up (get-v))))
+		 (lambda () (let/cc k (set! c1 k)))
+		 (lambda () (set! give-up exit) (c1)))))))]
+	[r10-11-12
+	 (lambda ()
+	   (let ([c2 #f]
+		 [x 10]
+		 [y 11])
+	     (let ([v (dynamic-wind
+		       (lambda () (set! y (add1 y)))
+		       (lambda () (begin0 x (set! x (add1 x))))
+		       (lambda () (let/cc k (set! c2 k))))])
+	       (when c2 ((begin0
+			  c2
+			  (set! c2 #f))))
+	       (list v x y))))]
+	[r13.14
+	 (lambda ()
+	   (let ([c0 #f]
+		 [x 11]
+		 [y 12])
+	     (dynamic-wind
+	      (lambda () (let/cc k (set! c0 k)))
+	      (lambda () (set! x (add1 x)))
+	      (lambda () (set! y (add1 y))
+		      (when c0 ((begin0
+				 c0
+				 (set! c0 #f))))))
+	     (cons x y)))]
+	[ra-b-a-b
+	 (lambda (get-a get-b)
+	   (let ([l null])
+	     (let ((k-in (test-call/cc (lambda (k1)
+					 (dynamic-wind
+					  (lambda () (set! l (append l (list (get-a)))))
+					  (lambda ()
+					    (call/cc (lambda (k2) (k1 k2))))
+					  (lambda ()  (set! l (append l (list (get-b))))))))))
+	       (k-in (lambda (v) l)))))])
+
+  (test 4 rv (lambda () 4))
+  (test '(5 6) r56)
+
+  (test '(7 . 8) rx.y (lambda () 7) (lambda () 8))
+
+  (test 9 rv2 (lambda () 9))
+
+  (test '(10 11 12) r10-11-12)
+
+  (test '(13 . 14) r13.14)
+
+  ; !!! fixed in 50:
+  (test '(enter exit enter exit)
+	ra-b-a-b (lambda () 'enter) (lambda () 'exit))
+
+  (test '((13 . 14) (10 11 12) (13 . 14) (10 11 12))
+	ra-b-a-b r13.14 r10-11-12)
+  (test '((10 11 12) (13 . 14) (10 11 12) (13 . 14))
+	ra-b-a-b r10-11-12 r13.14)
+
+  (test '((enter exit enter exit)
+	  (exit enter exit enter)
+	  (enter exit enter exit)
+	  (exit enter exit enter))
+	ra-b-a-b 
+	(lambda () (ra-b-a-b (lambda () 'enter) (lambda () 'exit)))
+	(lambda () (ra-b-a-b (lambda () 'exit) (lambda () 'enter))))
+
+  (test '(enter exit enter exit)
+	rv (lambda () (ra-b-a-b (lambda () 'enter) (lambda () 'exit))))
+  (test '(enter exit enter exit)
+	rv2 (lambda () (ra-b-a-b (lambda () 'enter) (lambda () 'exit))))
+
+  (test '(10 11 12) rv r10-11-12)
+  (test '(10 11 12) rv2 r10-11-12)
+
+  (test '(13 . 14) rv r13.14)
+  (test '(13 . 14) rv2 r13.14)
+
+  (test 12 'dw/ec (test-call/cc
+		   (lambda (k0)
+		     (test-call/cc
+		      (lambda (k1)
+			(test-call/cc
+			 (lambda (k2)
+			   (dynamic-wind
+			    void
+			    (lambda () (k1 6))
+			    (lambda () (k2 12))))))))))
+
+  ;; !!! fixed in 53 (for call/ec)
+  (test 13 'dw/ec (test-call/cc
+		   (lambda (k0)
+		     (test-call/cc
+		      (lambda (k1)
+			(test-call/cc
+			 (lambda (k2)
+			   (dynamic-wind
+			    void
+			    (lambda () (k1 6))
+			    (lambda () (k2 12)))))
+			(k0 13))))))
+
+  ))
+	      
+
+(test-cc-values call/cc)
+(test-cc-values call/ec)
+
+(test 'ok
+      'ec-cc-exn-combo
+      (with-handlers ([void (lambda (x) 'ok)])
+	(define f
+	  (let ([k #f])
+	    (lambda (n)
+	      (case n
+		[(0) (let/ec r (r (set! k (let/cc k k))))]
+		[(1) (k)]))))
+	(f 0)
+	(f 1)))
+
+(test '(1 2 3 4 1 2 3 4) 'dyn-wind-pre/post-order
+      (let ([x null]
+	    [go-back #f])
+	(dynamic-wind
+	 (lambda () (set! x (cons 4 x)))
+	 (lambda () (dynamic-wind
+		     (lambda () (set! x (cons 3 x)))
+		     (lambda () (set! go-back (let/cc k k)))
+		     (lambda () (set! x (cons 2 x)))))
+	 (lambda () (set! x (cons 1 x))))
+	(if (procedure? go-back)
+	    (go-back 1)
+	    x)))
+
+(test '(5 . 5) 'suspended-cont-escape
+      (let ([retry #f])
+	(let ([v (let/ec exit
+		   (dynamic-wind
+		    void
+		    (lambda () (exit 5))
+		    (lambda ()
+		      (let/ec inner-escape
+			(set! retry (let/cc k k))
+			(inner-escape 12)
+			10))))])
+	  (if (procedure? retry)
+	      (retry 10)
+	      (cons v v)))))
+
+(test '(here) 'escape-interrupt-full-jump-up
+      (let ([b #f]
+	    [v null])
+	(define (f g)
+	  (dynamic-wind
+	   void
+	   g
+	   (lambda () 
+	     (set! v (cons 'here v))
+	     (b 10))))
+	
+	(let/ec big
+	  (set! b big)
+	  (let/cc ok
+	    (f (lambda ()
+		 (ok #f)))))
+	
+	v))
+
+;; Check interaction of map and call/cc
+(let ()
+  (define (try n m)
+    (let ([retries (make-vector n)]
+	  [copy #f]
+	  [special -1]
+	  [in (let loop ([i n])
+		(if (= i 0)
+		    null
+		    (cons (- n i) (loop (sub1 i)))))])
+      (let ([v (apply
+		map 
+		(lambda (a . rest)
+		  (+ (let/cc k (vector-set! retries a k) 1)
+		     a))
+		(let loop ([m m])
+		  (if (zero? m)
+		      null
+		      (cons in (loop (sub1 m))))))])
+	(test (map (lambda (i)
+		     (if (= i special)
+			 (+ i 2)
+			 (add1 i)))
+		   in)
+	      `(map/cc ,n ,m)
+	      v))
+      (if copy
+	  (when (pair? copy)
+	    (set! special (add1 special))
+	    ((begin0 (car copy) (set! copy (cdr copy)))
+	     2))
+	  (begin
+	    (set! copy (vector->list retries))
+	    ((vector-ref retries (random n)) 1)))))
+  (try 3 1)
+  (try 10 1)
+  (try 3 2)
+  (try 10 2)
+  (try 5 3)
+  (try 3 5)
+  (try 10 5))
+
+(arity-test call/cc 1 1)
+(arity-test call/ec 1 1)
+(err/rt-test (call/cc 4))
+(err/rt-test (call/cc (lambda () 0)))
+(err/rt-test (call/ec 4))
+(err/rt-test (call/ec (lambda () 0)))
+
+(test #t primitive? car)
+(test #f primitive? leaf-eq?)
+(arity-test primitive? 1 1)
+
+(test 1 procedure-arity procedure-arity)
+(test 2 procedure-arity cons)
+(test (make-arity-at-least 2) procedure-arity >)
+(test (list 0 1) procedure-arity current-output-port)
+(test (list 1 3 (make-arity-at-least 5))
+      procedure-arity (case-lambda [(x) 0] [(x y z) 1] [(x y z w u . rest) 2]))
+(test (make-arity-at-least 0) procedure-arity (lambda x 1))
+(test (list 0 (make-arity-at-least 0)) procedure-arity (case-lambda 
+					       [() 10]
+					       [x 1]))
+(test (make-arity-at-least 0) procedure-arity (lambda x x))
+(arity-test procedure-arity 1 1)
+
+(test #t procedure-arity-includes? cons 2)
+(test #f procedure-arity-includes? cons 0)
+(test #f procedure-arity-includes? cons 3)
+(test #t procedure-arity-includes? list 3)
+(test #t procedure-arity-includes? list 3000)
+(test #t procedure-arity-includes? (lambda () 0) 0)
+(test #f procedure-arity-includes? (lambda () 0) 1)
+(test #f procedure-arity-includes? cons 10000000000000000000000000000)
+(test #t procedure-arity-includes? list 10000000000000000000000000000)
+(test #t procedure-arity-includes? (lambda x x) 10000000000000000000000000000)
+
+(err/rt-test (procedure-arity-includes? cons -1))
+(err/rt-test (procedure-arity-includes? cons 1.0))
+(err/rt-test (procedure-arity-includes? 'cons 1))
+
+(arity-test procedure-arity-includes? 2 2)
+
+(newline)
+(display ";testing scheme 4 functions; ")
+(SECTION 6 7)
+(test '(#\P #\space #\l) string->list "P l")
+(test '() string->list "")
+(test "1\\\"" list->string '(#\1 #\\ #\"))
+(test "" list->string '())
+(arity-test list->string 1 1)
+(arity-test string->list 1 1)
+(err/rt-test (string->list 'hello))
+(err/rt-test (list->string 'hello))
+(err/rt-test (list->string '(#\h . #\e)))
+(err/rt-test (list->string '(#\h 1 #\e)))
+(SECTION 6 8)
+(test '(dah dah didah) vector->list '#(dah dah didah))
+(test '() vector->list '#())
+(test '#(dididit dah) list->vector '(dididit dah))
+(test '#() list->vector '())
+(arity-test list->vector 1 1)
+(arity-test vector->list 1 1)
+(err/rt-test (vector->list 'hello))
+(err/rt-test (list->vector 'hello))
+(err/rt-test (list->vector '(#\h . #\e)))
+
+(test-cont)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; hash tables
+
+(arity-test make-hash-table 0 2)
+(err/rt-test (make-hash-table 'a))
+(err/rt-test (make-hash-table 'weak 'weak) exn:application:mismatch?)
+(err/rt-test (make-hash-table 'equal 'equal) exn:application:mismatch?)
+
+(let ()
+  (define-struct ax (b c)) ; opaque
+  (define-struct a (b c) (make-inspector))
+	 
+  (define an-ax (make-ax 1 2))
+
+  (let ([check-hash-tables
+	 (lambda (maybe-weak reorder?)
+	   (let ([h1 (apply make-hash-table maybe-weak)]
+		 [l (list 1 2 3)])
+	     (test #t eq? (eq-hash-code l) (eq-hash-code l))
+	     (test #t eq? (equal-hash-code l) (equal-hash-code l))
+	     (test #t eq? (equal-hash-code l) (equal-hash-code (list 1 2 3)))
+	     (hash-table-put! h1 l 'ok)
+	     (test 'ok hash-table-get h1 l)
+	     (test 'nope hash-table-get h1 (list 1 2 3) (lambda () 'nope))
+	     (test '(((1 2 3) . ok)) hash-table-map h1 (lambda (k v) (cons k v)))
+	     (hash-table-remove! h1 l)
+	     (test 'nope hash-table-get h1 l (lambda () 'nope)))
+	   
+	   (let ([h1 (apply make-hash-table 'equal maybe-weak)]
+		 [l (list 1 2 3)]
+		 [v (vector 5 6 7)]
+		 [a (make-a 1 (make-a 2 3))]
+		 [b (box (list 1 2 3))]
+		 [save (let ([x null])
+			 (case-lambda 
+			  [() x]
+			  [(a) (set! x (cons a x)) a]))])
+
+	     (test 0 hash-table-count h1)
+
+	     ;; Fill in table. Use `puts1' and `puts2' so we can
+	     ;; vary the order of additions.
+	     (let ([puts1 (lambda ()
+			    (hash-table-put! h1 (save l) 'list)
+			    (hash-table-put! h1 (save "Hello World!") 'string)
+			    (hash-table-put! h1 (save 123456789123456789123456789) 'bignum)
+			    (hash-table-put! h1 (save 3.45) 'flonum)
+			    (hash-table-put! h1 (save 3/45) 'rational)
+			    (hash-table-put! h1 (save 3+45i) 'complex))]
+		   [puts2 (lambda ()
+			    (hash-table-put! h1 (save (list 5 7)) 'another-list)
+			    (hash-table-put! h1 (save 3+0.0i) 'izi-complex)
+			    (hash-table-put! h1 (save v) 'vector)
+			    (hash-table-put! h1 (save a) 'struct)
+			    (hash-table-put! h1 (save an-ax) 'structx)
+			    (hash-table-put! h1 (save b) 'box))])
+	       (if reorder?
+		   (begin 
+		     (puts2) 
+		     (test 6 hash-table-count h1)
+		     (puts1))
+		   (begin 
+		     (puts1) 
+		     (test 6 hash-table-count h1)
+		     (puts2))))
+
+	     (test 12 hash-table-count h1)
+	     (test 'list hash-table-get h1 l)
+	     (test 'list hash-table-get h1 (list 1 2 3))
+	     (test 'another-list hash-table-get h1 (list 5 7))
+	     (test 'string hash-table-get h1 "Hello World!")
+	     (test 'bignum hash-table-get h1 123456789123456789123456789)
+	     (test 'flonum hash-table-get h1 3.45)
+	     (test 'rational hash-table-get h1 3/45)
+	     (test 'complex hash-table-get h1 3+45i)
+	     (test 'izi-complex hash-table-get h1 3+0.0i)
+	     (test 'vector hash-table-get h1 v)
+	     (test 'vector hash-table-get h1 #(5 6 7))
+	     (test 'struct hash-table-get h1 a)
+	     (test 'struct hash-table-get h1 (make-a 1 (make-a 2 3)))
+	     (test 'structx hash-table-get h1 an-ax)
+	     (test #f hash-table-get h1 (make-ax 1 2) (lambda () #f))
+	     (test 'box hash-table-get h1 b)
+	     (test 'box hash-table-get h1 #&(1 2 3))
+	     (test #t
+		   andmap
+		   (lambda (i)
+		     (and (member i 
+				  (hash-table-map h1 (lambda (k v) (cons k v))))
+			  #t))
+		   `(((1 2 3) . list)
+		     ((5 7) . another-list)
+		     ("Hello World!" . string)
+		     (123456789123456789123456789 . bignum)
+		     (3.45 . flonum)
+		     (3/45 . rational)
+		     (3+45i . complex)
+		     (3+0.0i . izi-complex)
+		     (#(5 6 7) . vector)
+		     (,(make-a 1 (make-a 2 3)) . struct)
+		     (,an-ax . structx)
+		     (#&(1 2 3) . box)))
+	     (hash-table-remove! h1 (list 1 2 3))
+	     (test 11 hash-table-count h1)
+	     (test 'not-there hash-table-get h1 l (lambda () 'not-there))
+	     (let ([c 0])
+	       (hash-table-for-each h1 (lambda (k v) (set! c (add1 c))))
+	       (test 11 'count c))
+	     (save) ; prevents gcing of the ht-registered values
+	     ;; return the hash table:
+	     h1))])
+
+    (let ([check-tables-equal
+	   (lambda (t1 t2)
+	     (test #t equal? t1 t2)
+	     (test (equal-hash-code t1) equal-hash-code t2)
+	     (let ([meta-ht (make-hash-table 'equal)])
+	       (hash-table-put! meta-ht t1 'the-table)
+	       (test 'the-table hash-table-get meta-ht t2 (lambda () #f))))])
+
+      (check-tables-equal (check-hash-tables null #f)
+			  (check-hash-tables null #t))
+      (check-tables-equal (check-hash-tables (list 'weak) #f)
+			  (check-hash-tables (list 'weak) #t)))))
+
+(test #f hash-table? 5)
+(test #t hash-table? (make-hash-table))
+(test #f hash-table? 5 'equal)
+(test #f hash-table? (make-hash-table) 'equal)
+(test #t hash-table? (make-hash-table 'equal) 'equal)
+(test #f hash-table? (make-hash-table 'weak) 'equal)
+(test #t hash-table? (make-hash-table 'weak 'equal) 'equal)
+(test #f hash-table? 5 'weak)
+(test #f hash-table? (make-hash-table) 'weak)
+(test #f hash-table? (make-hash-table 'equal) 'weak)
+(test #t hash-table? (make-hash-table 'weak) 'weak)
+(test #t hash-table? (make-hash-table 'weak 'equal) 'weak)
+(test #f hash-table? 5 'weak 'equal)
+(test #f hash-table? (make-hash-table) 'weak 'equal)
+(test #f hash-table? (make-hash-table 'equal) 'weak 'equal)
+(test #f hash-table? (make-hash-table 'weak) 'weak 'equal)
+(test #t hash-table? (make-hash-table 'weak 'equal) 'weak 'equal)
+
+;; Double check that table are equal after deletions
+(let ([test-del-eq
+       (lambda (flags)
+	 (let ([ht1 (apply make-hash-table flags)]
+	       [ht2 (apply make-hash-table flags)])
+	   (test #t equal? ht1 ht2)
+	   (hash-table-put! ht1 'apple 1)
+	   (hash-table-put! ht2 'apple 1)
+	   (test #t equal? ht1 ht2)
+	   (hash-table-put! ht2 'banana 2)
+	   (test #f equal? ht1 ht2)
+	   (hash-table-remove! ht2 'banana)
+	   (test #t equal? ht1 ht2)))])
+  (test-del-eq null)
+  (test-del-eq '(equal))
+  (test-del-eq '(weak)))
+
+(err/rt-test (hash-table-count 0))
+(err/rt-test (hash-table-put! 1 2 3))
+(err/rt-test (hash-table-get 1 2))
+(err/rt-test (hash-table-remove! 1 2))
+(err/rt-test (hash-table-get (make-hash-table) 2) exn:application:mismatch?)
+(err/rt-test (hash-table? 5 5))
+(err/rt-test (hash-table? 5 'equal 5))
+(err/rt-test (hash-table? (make-hash-table) 'equal 'equal) exn:application:mismatch?)
+(err/rt-test (hash-table? (make-hash-table) 'weak 'weak) exn:application:mismatch?)
+
+(define im-t (make-immutable-hash-table null))
+(test #t hash-table? im-t)
+(test #f hash-table? im-t 'equal)
+(test null hash-table-map im-t cons)
+(err/rt-test (hash-table-put! im-t 1 2))
+(test #f hash-table-get im-t 5 (lambda () #f))
+(define im-t (make-immutable-hash-table '((1 . 2))))
+(test '((1 . 2)) hash-table-map im-t cons)
+(test 2 hash-table-get im-t 1)
+(define im-t (make-immutable-hash-table '(("hello" . 2))))
+(test 'none hash-table-get im-t "hello" (lambda () 'none))
+(define im-t (make-immutable-hash-table '(("hello" . 2)) 'equal))
+(test 2 hash-table-get im-t "hello" (lambda () 'none))
+(test #t hash-table? im-t 'equal)
+
+(err/rt-test (hash-table-put! im-t 1 2))
+(err/rt-test (hash-table-remove! im-t 1))
+(err/rt-test (make-immutable-hash-table '(1)))
+(err/rt-test (make-immutable-hash-table '((1 . 2) . 2)))
+(err/rt-test (make-immutable-hash-table '((1 . 2) 3)))
+(define cyclic-alist '#0=((1 . 2) . #0#))
+(err/rt-test (make-immutable-hash-table cyclic-alist))
+(err/rt-test (make-immutable-hash-table '((1 . 2)) 'weak))
+
+(arity-test make-hash-table 0 2)
+(arity-test make-immutable-hash-table 1 2)
+(arity-test hash-table-count 1 1)
+(arity-test hash-table-get 2 3)
+(arity-test hash-table-put! 3 3)
+(arity-test hash-table-remove! 2 2)
+(arity-test hash-table-map 2 2)
+(arity-test hash-table-for-each 2 2)
+(arity-test hash-table? 1 3)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Misc
+
+(test #t string? (version))
+(test #t string? (banner))
+(test #t symbol? (system-type))
+(test (system-type) system-type #f)
+(test #t string? (system-type #t))
+(test #t relative-path? (system-library-subpath))
+
+(test #t 'cmdline (let ([v (current-command-line-arguments)])
+		    (and (vector? v)
+			 (andmap string? (vector->list v)))))
+(err/rt-test (current-command-line-arguments '("a")))
+(err/rt-test (current-command-line-arguments #("a" 1)))
+
+(arity-test version 0 0)
+(arity-test banner 0 0)
+(arity-test system-type 0 1)
+(arity-test system-library-subpath 0 1)
+(arity-test current-command-line-arguments 0 1)
+
+(report-errs)
+
+"last item in file"
diff --git a/collects/tests/mzscheme/beg-adv.ss b/collects/tests/mzscheme/beg-adv.ss
new file mode 100644
index 0000000000..3c6fe63839
--- /dev/null
+++ b/collects/tests/mzscheme/beg-adv.ss
@@ -0,0 +1,186 @@
+
+(htdp-syntax-test #'())
+(htdp-syntax-test #'#%app)
+
+(htdp-syntax-test #'quote)
+(htdp-syntax-test #'(quote 1 2))
+
+(htdp-syntax-test #'define)
+(htdp-syntax-test #'(define))
+(htdp-syntax-test #'(define x))
+(htdp-syntax-test #'(define x 10 12))
+(htdp-syntax-test #'(define (10 y) 12))
+(htdp-syntax-test #'(define ("x" y) 12))
+(htdp-syntax-test #'(define (y 10) 12))
+(htdp-syntax-test #'(define (y "x") 12))
+(htdp-syntax-test #'(define (y z 10) 12))
+(htdp-syntax-test #'(define (x y) 10 12))
+(htdp-syntax-test #'(define (x y y) 10))
+(htdp-syntax-test #'(define () 10))
+(htdp-syntax-test #'(define 1 10))
+(htdp-syntax-test #'(define x lambda))
+(htdp-syntax-test #'(define x (lambda)))
+(htdp-syntax-test #'(define x (lambda (x))))
+(htdp-syntax-test #'(define x (lambda y)))
+(htdp-syntax-test #'(define x (lambda y 10)))
+(htdp-syntax-test #'(define x (lambda (10) 10)))
+(htdp-syntax-test #'(define x (lambda (x 10) 10)))
+(htdp-syntax-test #'(define x (lambda (y) 10 11)))
+(htdp-syntax-test #'(define x (lambda (y) 10 11)))
+(htdp-syntax-test #'(define x (lambda (y y) 10)))
+(htdp-syntax-test #'(+ (define x 5)))
+
+;; Keywords:
+(htdp-syntax-test #'(define (define y) 12))
+(htdp-syntax-test #'(define (lambda y) 12))
+(htdp-syntax-test #'(define (cond y) 12))
+(htdp-syntax-test #'(define (if y) 12))
+(htdp-syntax-test #'(define (y define) 12))
+(htdp-syntax-test #'(define (y lambda) 12))
+(htdp-syntax-test #'(define (y cond) 12))
+(htdp-syntax-test #'(define (y if) 12))
+(htdp-syntax-test #'(define (y and) 12))
+(htdp-syntax-test #'(define (y or) 12))
+(htdp-syntax-test #'(define (y true) 12))
+(htdp-syntax-test #'(define (y false) 12))
+(htdp-syntax-test #'(define (y empty) 12))
+
+(htdp-syntax-test #'define-struct)
+(htdp-syntax-test #'(define-struct))
+(htdp-syntax-test #'(define-struct a))
+(htdp-syntax-test #'(define-struct a (b) 10))
+(htdp-syntax-test #'(define-struct a (b) 10 11 12))
+(htdp-syntax-test #'(define-struct 10 (b)))
+(htdp-syntax-test #'(define-struct a b))
+(htdp-syntax-test #'(define-struct a (10)))
+(htdp-syntax-test #'(define-struct a (b 10)))
+(htdp-syntax-test #'(define-struct (a) (b)))
+(htdp-syntax-test #'(define-struct a (b b)))
+(htdp-syntax-test #'(define-struct lambda (b)))
+(htdp-syntax-test #'(+ 1 (define-struct a (b))))
+
+(htdp-top (define x 5))
+(htdp-top (define (f y) (+ x y)))
+(htdp-test 5 'lookup x)
+(htdp-test 9 'app-f (f 4))
+(htdp-top (define f2 (lambda (y) (+ x y))))
+(htdp-test 15 'app-f (f 10))
+
+(htdp-top (define-struct a0 ()))
+(htdp-top (define-struct a1 (b)))
+(htdp-top (define-struct a3 (b c d)))
+(htdp-test #t 'a0? (a0? (make-a0)))
+(htdp-test #t 'a1? (a1? (make-a1 1)))
+(htdp-test #t 'a3? (a3? (make-a3 1 2 3)))
+(htdp-test #f 'a1? (a1? (make-a3 1 2 3)))
+(htdp-test #f 'a3? (a3? (make-a1 1)))
+
+(htdp-syntax-test #'cond)
+(htdp-syntax-test #'(cond))
+(htdp-syntax-test #'(cond 1))
+(htdp-syntax-test #'(cond [#t 6] 2))
+(htdp-syntax-test #'(cond [else 6] [#f 10]))
+(htdp-syntax-test #'(cond [else 6] [else 10]))
+(htdp-syntax-test #'(cond []))
+(htdp-syntax-test #'(cond [1]))
+(htdp-syntax-test #'(cond [1 2 3]))
+(htdp-syntax-test #'(cond [1 2][]))
+(htdp-syntax-test #'(cond [1 2][3 4 5]))
+
+(htdp-test 17 'cond (cond [else 17]))
+(htdp-test 18 'cond (cond [#t 18]))
+(htdp-test 19 'cond (cond [(zero? 10) 0] [#t 19]))
+(htdp-test 19 'cond (cond [(zero? 10) 0] [else 19]))
+
+(htdp-err/rt-test (cond [#f 10]) exn:fail?) ;; Should it be a different exception?
+(htdp-err/rt-test (cond [1 10]))
+
+(htdp-syntax-test #'if)
+(htdp-syntax-test #'(if))
+(htdp-syntax-test #'(if #t))
+(htdp-syntax-test #'(if #t 1))
+(htdp-syntax-test #'(if #t 1 2 3))
+
+(htdp-err/rt-test (if 1 2 3))
+
+(htdp-syntax-test #'and)
+(htdp-syntax-test #'(and))
+(htdp-syntax-test #'(and #t))
+
+(htdp-err/rt-test (and 1 #t))
+(htdp-err/rt-test (and #t 1))
+(htdp-test #f 'ok-and (and #t #f 1))
+
+(htdp-syntax-test #'or)
+(htdp-syntax-test #'(or))
+(htdp-syntax-test #'(or #t))
+
+(htdp-err/rt-test (or 1 #f))
+(htdp-err/rt-test (or #f 1))
+(htdp-test #t 'ok-or (or #f #t 1))
+
+(htdp-test #t 'empty? (empty? empty))
+(htdp-test #t 'cons? (cons? (cons 1 empty)))
+
+(htdp-err/rt-test (cons 1 2))
+(htdp-err/rt-test (append (list 1) 2))
+
+(htdp-test #t 'boolean? (boolean? true))
+(htdp-test #t 'boolean? (boolean? false))
+(htdp-test #t 'eq? (eq? #t true))
+(htdp-test #t 'eq? (eq? #f false))
+
+(htdp-err/rt-test (+) exn:application:arity?)
+(htdp-err/rt-test (+ 1) exn:application:arity?)
+(htdp-err/rt-test (*) exn:application:arity?)
+(htdp-err/rt-test (* 1) exn:application:arity?)
+(htdp-err/rt-test (-) exn:application:arity?)
+(htdp-err/rt-test (/) exn:application:arity?)
+(htdp-err/rt-test (/ 1) exn:application:arity?)
+
+(htdp-test -9 '- (- 9))
+
+(htdp-top (define-struct an-example-structure (first-field second-field)))
+(htdp-error-test #'(define an-example-structure 5))
+(htdp-error-test #'(define (an-example-structure x) 5))
+(htdp-error-test #'(define-struct an-example-structure (y)))
+(htdp-error-test #'(define-struct an-example (structure y)))
+
+(htdp-top (define an-example-value 12))
+(htdp-error-test #'(define an-example-value 5))
+(htdp-error-test #'(define (an-example-value x) 5))
+(htdp-error-test #'(define-struct an-example-value (y)))
+(htdp-error-test #'(define-struct an-example (value y)))
+
+(htdp-top (define (an-example-function x) x))
+(htdp-error-test #'(define an-example-function 5))
+(htdp-error-test #'(define (an-example-function x) 5))
+(htdp-error-test #'(define-struct an-example-function (y)))
+(htdp-error-test #'(define-struct an-example (function y)))
+
+(htdp-test #t 'equal? (equal? 1 1))
+(htdp-test #t 'equal? (equal? (list 1) (list 1)))
+(htdp-test #t 'equal? (equal? (list #i1.0 2) (list #i1.0 2)))
+(htdp-test #f 'equal? (equal? (list #i1.0 2) (list #i1.0 #i2.0)))
+(htdp-test #t 'equal? (equal? (list "apple") (list "apple")))
+(htdp-test #f 'equal? (equal? (list "apple") (list 'apple)))
+(htdp-test #f 'equal? (equal? (list "apple") (list "banana")))
+(htdp-test #t 'equal? (equal? (make-posn 1 2) (make-posn 1 2)))
+(htdp-test #f 'equal? (equal? (make-posn 1 #i2.0) (make-posn 1 2)))
+(htdp-test #t 'equal? (equal? (make-a1 2) (make-a1 2)))
+(htdp-test #f 'equal? (equal? (make-a1 #i2.0) (make-a1 2)))
+
+(htdp-test #t 'equal~? (equal~? 1 1 #i0.1))
+(htdp-test #t 'equal~? (equal~? (list 1) (list 1) #i0.1))
+(htdp-test #t 'equal~? (equal~? (list #i1.0 2) (list #i1.0 2) #i0.1))
+(htdp-test #t 'equal~? (equal~? (list #i1.0 2) (list #i1.0 #i2.0) #i0.1))
+(htdp-test #f 'equal~? (equal~? (list #i1.0 2) (list #i1.0 2.2) #i0.1))
+(htdp-test #t 'equal~? (equal~? (list "apple") (list "apple") #i0.2))
+(htdp-test #f 'equal~? (equal~? (list "apple") (list 'apple) #i0.2))
+(htdp-test #f 'equal~? (equal~? (list "apple") (list "banana") #i0.2))
+(htdp-test #t 'equal~? (equal~? (make-posn 1 2) (make-posn 1 2) #i0.2))
+(htdp-test #t 'equal~? (equal~? (make-posn 1 #i2.0) (make-posn 1 2) #i0.2))
+(htdp-test #t 'equal~? (equal~? (make-a1 2) (make-a1 2) #i0.2))
+(htdp-test #t 'equal~? (equal~? (make-a1 #i2.0) (make-a1 2) #i0.2))
+(htdp-test #f 'equal~? (equal~? (make-a1 #i2.3) (make-a1 2) #i0.2))
+
diff --git a/collects/tests/mzscheme/beg-bega.ss b/collects/tests/mzscheme/beg-bega.ss
new file mode 100644
index 0000000000..ea491e62bc
--- /dev/null
+++ b/collects/tests/mzscheme/beg-bega.ss
@@ -0,0 +1,26 @@
+
+(htdp-syntax-test #'(local [(define x 5)] x))
+(htdp-syntax-test #'(recur name ([x 18]) x))
+
+(htdp-syntax-test #'(define (f78 a) (a))) ; no functions as arguments
+
+;; See htdp-top uses in beg-adv.ss:
+(htdp-error-test #'f)
+(htdp-error-test #'(x 1))
+(htdp-error-test #'(+ f 1))
+(htdp-error-test #'((f 1)))
+(htdp-error-test #'a1)
+(htdp-error-test #'make-a1)
+(htdp-error-test #'a1?)
+(htdp-error-test #'a1-b)
+
+(htdp-top (define (g w) (h w))) ;; h isn't defined, yet
+(htdp-error-test #'1)
+(htdp-top (define (h j) (add1 j)))
+(htdp-test 3 'h (h 2))
+
+(htdp-top (define (p j) (x j)))
+(htdp-error-test #'1)
+(htdp-top-pop 1)
+
+
diff --git a/collects/tests/mzscheme/beg-intm.ss b/collects/tests/mzscheme/beg-intm.ss
new file mode 100644
index 0000000000..a67cdaa8f7
--- /dev/null
+++ b/collects/tests/mzscheme/beg-intm.ss
@@ -0,0 +1,11 @@
+
+;; For every test here, make sure the opposite test is in intml-adv.ss
+
+(htdp-syntax-test #'(1 2 3))
+(htdp-syntax-test #'("hello" 1 2))
+
+
+(htdp-syntax-test #'(define x17 (lambda (y) (lambda (z) z))))
+(htdp-syntax-test #'(lambda (x) 10))
+
+(htdp-syntax-test #'(lambda (f) (f f)))
diff --git a/collects/tests/mzscheme/beg-intml.ss b/collects/tests/mzscheme/beg-intml.ss
new file mode 100644
index 0000000000..a0e25e74bd
--- /dev/null
+++ b/collects/tests/mzscheme/beg-intml.ss
@@ -0,0 +1,5 @@
+
+;; For every test here, make sure the opposite test is in advanced.ss
+
+(htdp-syntax-test #'(define (xthnk) 10))
+(htdp-syntax-test #'(define xthnk (lambda () 10)))
diff --git a/collects/tests/mzscheme/bega-adv.ss b/collects/tests/mzscheme/bega-adv.ss
new file mode 100644
index 0000000000..52c59596ba
--- /dev/null
+++ b/collects/tests/mzscheme/bega-adv.ss
@@ -0,0 +1,32 @@
+
+(htdp-test 1 'quote '1)
+(htdp-test (list 'quote 1) 'quote ''1)
+(htdp-test "Hello" 'quote '"Hello")
+(htdp-test (list 1 2) 'quote '(1 2))
+(htdp-test (list 1 (list 2 "hi")) 'quote '(1 (2 "hi")))
+
+(htdp-test 1 'qq `1)
+(htdp-test '(1 2) 'qq `(1 2))
+(htdp-test 7 'qq `,(+ 3 4))
+(htdp-test '(1 3) 'qq `(1 ,(+ 1 2)))
+(htdp-test '(99 88 77) 'qq `(,(* 11 9) ,(* 11 `8) ,`,(* 11 7)))
+(htdp-test '(1 2 3 4) 'qq `(1 ,@(list 2 3) 4))
+(htdp-test '(quasiquote 11) 'qq ``11)
+(htdp-test '(quasiquote (unquote 11)) 'qq ``,11)
+(htdp-test '(quasiquote (unquote 22)) 'qq ``,,(* 11 2))
+(htdp-test '(quasiquote ((unquote-splicing (22)))) 'qq ``(,@(,@(list (* 11 2)))))
+
+(htdp-syntax-test #'quasiquote)
+(htdp-syntax-test #'`unquote)
+(htdp-syntax-test #'`unquote-splicing)
+(htdp-syntax-test #'`(unquote-splicing 10))
+
+(htdp-syntax-test #'unquote)
+(htdp-syntax-test #'(unquote))
+(htdp-syntax-test #'(unquote 10))
+
+(htdp-syntax-test #'unquote-splicing)
+(htdp-syntax-test #'(unquote-splicing (list 10)))
+(htdp-syntax-test #'((unquote-splicing (list 10))))
+
+(htdp-err/rt-test `(,@4))
diff --git a/collects/tests/mzscheme/beginner-abbr.ss b/collects/tests/mzscheme/beginner-abbr.ss
new file mode 100644
index 0000000000..8c9f76b732
--- /dev/null
+++ b/collects/tests/mzscheme/beginner-abbr.ss
@@ -0,0 +1,32 @@
+
+;; Basic checks for the beginner language. Error messages really
+;; should be inspected manually.
+
+;; Limitations of this test suite:
+;;  - It doesn't check reader-level parameterization, such as use of quotes
+;;  - It doesn't check format of printed results
+;;  - It doesn't check the absence of MzScheme forms
+
+;; Don't try to run other tests from the test suite after loading this
+;; one into a particular namespace.
+
+(load-relative "loadtest.ss")
+
+;; Don't need these:
+(define no-extra-if-tests? #t)
+
+(require (rename mzscheme exn:fail? exn:fail?)
+	 (rename mzscheme exn:fail:contract? exn:fail:contract?))
+
+(define current-htdp-lang '(lib "htdp-beginner-abbr.ss" "lang"))
+(load-relative "htdp-test.ss")
+
+(require (lib "htdp-beginner-abbr.ss" "lang"))
+
+(load-relative "beg-adv.ss")
+(load-relative "beg-intml.ss")
+(load-relative "beg-intm.ss")
+(load-relative "beg-bega.ss")
+(load-relative "bega-adv.ss")
+
+(report-errs)
diff --git a/collects/tests/mzscheme/beginner.ss b/collects/tests/mzscheme/beginner.ss
new file mode 100644
index 0000000000..e9b0930298
--- /dev/null
+++ b/collects/tests/mzscheme/beginner.ss
@@ -0,0 +1,67 @@
+
+;; Basic checks for the beginner language. Error messages really
+;; should be inspected manually.
+
+;; Limitations of this test suite:
+;;  - It doesn't check reader-level parameterization, such as use of quotes
+;;  - It doesn't check format of printed results
+;;  - It doesn't check the absence of MzScheme forms
+
+;; Don't try to run other tests from the test suite after loading this
+;; one into a particular namespace.
+
+;; See also htdp-image.ss, which must be loaded into MrEd (but is in this
+;; directory anyway)
+
+
+(load-relative "loadtest.ss")
+
+;; Check that expansion doesn't introduce non-equal ids that
+;;  claim to be "original" at the same place
+(let loop ([x (expand #'(module m (lib "htdp-beginner.ss" "lang")
+			  (define (f x) x)))])
+  (let ([orig-ids (let loop ([x x])
+		    (cond
+		     [(identifier? x)
+		      (if (syntax-original? x)
+			  (list x)
+			  null)]
+		     [(null? x) null]
+		     [(pair? x) (append (loop (car x))
+					(loop (cdr x)))]
+		     [(syntax? x) (loop (syntax-e x))]
+		     [else null]))])
+    (for-each (lambda (id1)
+		(for-each (lambda (id2)
+			    (if (and (= (syntax-position id1)
+					(syntax-position id2))
+				     (not (module-identifier=? id1 id2)))
+				(error 'original "mismatch: ~e ~e"
+				       id1 id2)))
+			  orig-ids))
+	      orig-ids)))
+    
+;; Don't need these:
+(define no-extra-if-tests? #t)
+
+(require (rename mzscheme exn:fail? exn:fail?)
+	 (rename mzscheme exn:fail:contract? exn:fail:contract?))
+
+(define current-htdp-lang '(lib "htdp-beginner.ss" "lang"))
+(load-relative "htdp-test.ss")
+
+(require (lib "htdp-beginner.ss" "lang"))
+
+(load-relative "beg-adv.ss")
+(load-relative "beg-intml.ss")
+(load-relative "beg-intm.ss")
+(load-relative "beg-bega.ss")
+
+(htdp-syntax-test #'quote)
+(htdp-syntax-test #''1)
+(htdp-syntax-test #''"hello")
+(htdp-syntax-test #''(1 2))
+(htdp-syntax-test #'''a)
+
+
+(report-errs)
diff --git a/collects/tests/mzscheme/binc.ss b/collects/tests/mzscheme/binc.ss
new file mode 100644
index 0000000000..9dd2939ec9
--- /dev/null
+++ b/collects/tests/mzscheme/binc.ss
@@ -0,0 +1,4 @@
+(begin
+ (define w x)
+ (define z w))
+(define y z)
diff --git a/collects/tests/mzscheme/boundmap-test.ss b/collects/tests/mzscheme/boundmap-test.ss
new file mode 100644
index 0000000000..29593fe17e
--- /dev/null
+++ b/collects/tests/mzscheme/boundmap-test.ss
@@ -0,0 +1,129 @@
+(load-relative "loadtest.ss")
+
+(require (lib "boundmap.ss" "syntax"))
+  
+(section 'BOUNDMAP)
+
+(test #t bound-identifier-mapping? (make-bound-identifier-mapping))
+
+(let ()
+  ;; contains-same? : (listof x) (listof x) -> boolean
+  (define (contains-same? l1 l2)
+    (and (andmap (lambda (x) (member x l2)) l1)
+         (andmap (lambda (x) (member x l1)) l2)
+         #t))
+  
+  (let-values ([(x1 x2 x3 x4)
+                (syntax-case (expand #'((lambda (x) x) (lambda (x) x))) ()
+                  [(x (a (x1) x2) (c (x3) x4))
+                   (values (syntax x1)
+                           (syntax x2)
+                           (syntax x3)
+                           (syntax x4))])])
+    
+    
+    (let ([mapping (make-bound-identifier-mapping)])
+      (bound-identifier-mapping-put! mapping x1 1)
+      (bound-identifier-mapping-put! mapping x2 2)
+      (bound-identifier-mapping-put! mapping x3 3)
+      (bound-identifier-mapping-put! mapping x4 4)
+      (test 2 bound-identifier-mapping-get mapping x1)
+      (test 2 bound-identifier-mapping-get mapping x2)
+      (test 4 bound-identifier-mapping-get mapping x3)
+      (test 4 bound-identifier-mapping-get mapping x4)
+      (test #t
+            contains-same?
+            (list 2 4)
+            (bound-identifier-mapping-map mapping (lambda (x y) y)))
+      
+      (test #t
+            contains-same?
+            (list 2 4)
+            (let ([l '()])
+              (bound-identifier-mapping-for-each
+               mapping
+               (lambda (x y)
+                 (set! l (cons y l))))
+              l)))
+    
+    (let ([mapping (make-module-identifier-mapping)])
+      (module-identifier-mapping-put! mapping x1 1)
+      (module-identifier-mapping-put! mapping x2 2)
+      (module-identifier-mapping-put! mapping x3 3)
+      (module-identifier-mapping-put! mapping x4 4)
+      (test 2 module-identifier-mapping-get mapping x1)
+      (test 2 module-identifier-mapping-get mapping x2)
+      (test 4 module-identifier-mapping-get mapping x3)
+      (test 4 module-identifier-mapping-get mapping x4)
+      (test #t
+            contains-same?
+            (list 2 4)
+            (module-identifier-mapping-map mapping (lambda (x y) y)))
+      
+      (test #t
+            contains-same?
+            (list 2 4)
+            (let ([l '()])
+              (module-identifier-mapping-for-each
+               mapping
+               (lambda (x y)
+                 (set! l (cons y l))))
+              l))))
+  
+  (let-values ([(y1 y2 y3 y4)
+                (syntax-case (expand #'(module m mzscheme (require (prefix x: mzscheme)) + x:+ - x:-)) ()
+                  [(a b c (d e f y1 y2 y3 y4))
+                   (values (syntax y1)
+                           (syntax y2)
+                           (syntax y3)
+                           (syntax y4))])])
+    
+    (let ([mapping (make-bound-identifier-mapping)])
+      (bound-identifier-mapping-put! mapping y1 1)
+      (bound-identifier-mapping-put! mapping y2 2)
+      (bound-identifier-mapping-put! mapping y3 3)
+      (bound-identifier-mapping-put! mapping y4 4)
+      (test 1 bound-identifier-mapping-get mapping y1)
+      (test 2 bound-identifier-mapping-get mapping y2)
+      (test 3 bound-identifier-mapping-get mapping y3)
+      (test 4 bound-identifier-mapping-get mapping y4)
+      (test #t
+            contains-same?
+            (list 1 2 3 4)
+            (bound-identifier-mapping-map mapping (lambda (x y) y)))
+      
+      (test #t
+            contains-same?
+            (list 1 2 3 4)
+            (let ([l '()])
+              (bound-identifier-mapping-for-each
+               mapping
+               (lambda (x y)
+                 (set! l (cons y l))))
+              l)))
+    
+    (let ([mapping (make-module-identifier-mapping)])
+      (module-identifier-mapping-put! mapping y1 1)
+      (module-identifier-mapping-put! mapping y2 2)
+      (module-identifier-mapping-put! mapping y3 3)
+      (module-identifier-mapping-put! mapping y4 4)
+      (test 2 module-identifier-mapping-get mapping y1)
+      (test 2 module-identifier-mapping-get mapping y2)
+      (test 4 module-identifier-mapping-get mapping y3)
+      (test 4 module-identifier-mapping-get mapping y4)
+      (test #t
+            contains-same?
+            (list 2 4)
+            (module-identifier-mapping-map mapping (lambda (x y) y)))
+      
+      (test #t
+            contains-same?
+            (list 2 4)
+            (let ([l '()])
+              (module-identifier-mapping-for-each
+               mapping
+               (lambda (x y)
+                 (set! l (cons y l))))
+              l)))))
+
+(report-errs)
\ No newline at end of file
diff --git a/collects/tests/mzscheme/cache-image-snip-test.ss b/collects/tests/mzscheme/cache-image-snip-test.ss
new file mode 100644
index 0000000000..833a68f0b7
--- /dev/null
+++ b/collects/tests/mzscheme/cache-image-snip-test.ss
@@ -0,0 +1,289 @@
+(load-relative "loadtest.ss")
+
+(require (lib "cache-image-snip.ss" "mrlib")
+         (lib "unit.ss"))
+
+(invoke-unit
+ (unit 
+   (import)
+   (export)
+   
+   (define (overlay-bitmap/ret argb dx dy b1 b2)
+     (overlay-bitmap argb dx dy b1 b2)
+     (argb-vector argb))
+
+   (let ([argb (make-argb (vector 100 10 20 30) 1)]
+         [bm (build-bitmap void 1 1)])
+     (test #(100 10 20 30) overlay-bitmap/ret argb 0 0 bm bm))
+
+   (let ([argb (make-argb (make-vector 4 0) 1)]
+         [bm (build-bitmap 
+              (lambda (dc)
+                (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
+                (send dc draw-line 0 0 0 0))
+              1 1)])
+     (test #4(0) overlay-bitmap/ret argb 0 0 bm bm))
+   
+   (let ([argb (make-argb (make-vector 4 100) 1)]
+         [bm (build-bitmap 
+              (lambda (dc)
+                (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
+                (send dc draw-line 0 0 0 0))
+              1 1)])
+     (test #4(0) overlay-bitmap/ret argb 0 0 bm bm))
+   
+   (let ([argb (make-argb (make-vector 8 254) 1)]
+         [bm (build-bitmap void 1 2)])
+     (test #8(254) overlay-bitmap/ret argb 0 0 bm bm))
+   
+   (let ([argb (make-argb (make-vector 8 0) 1)]
+         [bm (build-bitmap 
+              (lambda (dc)
+                (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
+                (send dc draw-line 0 0 0 1))
+              1 2)])
+     (test #8(0) overlay-bitmap/ret argb 0 0 bm bm))
+      
+   (let ([argb (make-argb (make-vector 16 100) 2)]
+         [bm (build-bitmap 
+              (lambda (dc)
+                (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
+                (send dc draw-line 0 0 0 0))
+              2 2)])
+     (test #16(0 0 0 0
+               100 100 100 100
+               100 100 100 100
+               100 100 100 100)
+           overlay-bitmap/ret argb 0 0 bm bm))
+   
+   (let ([argb (make-argb (make-vector 16 100) 2)]
+         [bm (build-bitmap 
+              (lambda (dc)
+                (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
+                (send dc draw-line 1 0 1 0))
+              2 2)])
+     (test #16(100 100 100 100
+               0 0 0 0
+               100 100 100 100
+               100 100 100 100)
+           overlay-bitmap/ret argb 0 0 bm bm))
+   
+   (let ([argb (make-argb (make-vector 16 100) 2)]
+         [bm (build-bitmap 
+              (lambda (dc)
+                (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
+                (send dc draw-line 0 1 0 1))
+              2 2)])
+     (test #16(100 100 100 100
+               100 100 100 100
+               0 0 0 0
+               100 100 100 100)
+           overlay-bitmap/ret argb 0 0 bm bm))
+   
+   (let ([argb (make-argb (make-vector 16 100) 2)]
+         [bm (build-bitmap 
+              (lambda (dc)
+                (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
+                (send dc draw-line 1 1 1 1))
+              2 2)])
+     (test #16(100 100 100 100
+               100 100 100 100
+               100 100 100 100
+               0 0 0 0)
+           overlay-bitmap/ret argb 0 0 bm bm))
+   
+   (let ([argb (make-argb (make-vector 4 200) 1)]
+         [c (build-bitmap 
+             (lambda (dc)
+               (send dc set-pen 
+                     (send the-pen-list find-or-create-pen (make-object color% 0 0 100) 1 'solid))
+               (send dc draw-line 0 0 0 0))
+             1 1)]
+         [m (build-bitmap 
+             (lambda (dc)
+               (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
+               (send dc draw-line 0 0 0 0))
+             1 1)])
+     (test #4(0 0 0 100) overlay-bitmap/ret argb 0 0 c m))
+   
+   (let ([argb (make-argb (make-vector 4 200) 1)]
+         [c (build-bitmap 
+             (lambda (dc)
+               (send dc set-pen 
+                     (send the-pen-list find-or-create-pen (make-object color% 0 100 0) 1 'solid))
+               (send dc draw-line 0 0 0 0))
+             1 1)]
+         [m (build-bitmap 
+             (lambda (dc)
+               (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
+               (send dc draw-line 0 0 0 0))
+             1 1)])
+     (test #4(0 0 100 0) overlay-bitmap/ret argb 0 0 c m))
+   
+   (let ([argb (make-argb (make-vector 4 200) 1)]
+         [c (build-bitmap 
+             (lambda (dc)
+               (send dc set-pen 
+                     (send the-pen-list find-or-create-pen (make-object color% 100 0 0) 1 'solid))
+               (send dc draw-line 0 0 0 0))
+             1 1)]
+         [m (build-bitmap 
+             (lambda (dc)
+               (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
+               (send dc draw-line 0 0 0 0))
+             1 1)])
+     (test #4(0 100 0 0) overlay-bitmap/ret argb 0 0 c m))
+   
+   (let ([argb (make-argb (make-vector (* 2 2 4) 200) 2)]
+         [bm (build-bitmap 
+              (lambda (dc)
+                (send dc set-pen 
+                      (send the-pen-list find-or-create-pen "black" 1 'solid))
+                (send dc draw-line 0 0 0 1))
+             1 1)])
+     (test #(200 200 200 200 000 000 000 000 
+             200 200 200 200 200 200 200 200)
+           overlay-bitmap/ret
+           argb
+           1 0
+           bm bm))
+   
+   (let ([argb (make-argb (make-vector (* 2 2 4) 200) 2)]
+         [bm (build-bitmap 
+              (lambda (dc)
+                (send dc set-pen 
+                      (send the-pen-list find-or-create-pen "black" 1 'solid))
+                (send dc draw-line 0 0 0 1))
+             1 1)])
+     (test #(200 200 200 200 200 200 200 200 
+             000 000 000 000 200 200 200 200)
+           overlay-bitmap/ret
+           argb
+           0 1
+           bm bm))
+   
+   ;; used to test argb->bitmap
+   (define (argb->bitmap->string argb)
+     (bitmap->string (argb->bitmap argb)))
+   
+   ;; extracts the argb strings from the bitmap and its mask for comparison
+   (define (bitmap->string main-bm)
+     (let* ([w (send main-bm get-width)]
+            [h (send main-bm get-height)]
+            [get-one
+             (lambda (bm)
+               (let ([dc (make-object bitmap-dc% bm)]
+                     [str (make-string (* 4 w h) #\000)])
+                 (send dc get-argb-pixels 0 0 w h str)
+                 (send dc set-bitmap #f)
+                 str))])
+       (list (and (send main-bm get-loaded-mask)
+                  (get-one (send main-bm get-loaded-mask)))
+             (get-one main-bm))))
+   
+   (test '("\377\377\377\377" "\377\377\377\377") argb->bitmap->string (make-argb #(255 255 255 255) 1))
+   (test '("\377\377\377\377" "\377\0\0\0") argb->bitmap->string (make-argb #(255 0 0 0) 1))
+   (test '("\377\1\1\1" "\377\100\100\100") argb->bitmap->string (make-argb #(1 64 64 64) 1))
+   (test '("\377\001\001\001\377\010\010\010\377\377\377\377\377\000\000\000"
+           "\377\100\100\100\377\001\010\100\377\377\377\377\377\000\000\000") 
+         argb->bitmap->string
+         (make-argb #(1 64 64 64 
+                      8 1 8 64
+                      255 255 255 255
+                      0 0 0 0)
+                    2))
+   
+   (define (show-bitmap bm mask title)
+     (define f (new frame% (label title) (width 200) (height 200)))
+     (define c (new canvas%
+                    (parent f)
+                    (paint-callback
+                     (lambda (c dc)
+                       (send dc draw-bitmap bm 0 0 'solid 
+                             (send the-color-database find-color "black")
+                             mask)))))
+     (send f show #t))
+   
+   (let* ([font (send the-font-list find-or-create-font 12 'default 'normal 'normal #f 'partly-smoothed)]
+          [black (send the-color-database find-color "black")]
+          [bkg-color "plum"]
+          [font-color (send the-color-database find-color "forestgreen")]
+          [str "xXxXx"]
+          [w 100]
+          [h 30]
+          [argb-vector (make-vector (* w h 4) 0)]
+          [argb (make-argb argb-vector w)]
+          [c1 (build-bitmap 
+               (lambda (dc)
+                 (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
+                 (send dc set-brush (send the-brush-list find-or-create-brush bkg-color 'solid))
+                 (send dc draw-rectangle 0 0 w h))
+               w h)]
+          [m1 (build-bitmap 
+               (lambda (dc)
+                 (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
+                 (send dc set-brush (send the-brush-list find-or-create-brush "black" 'solid))
+                 (send dc draw-rectangle 0 0 w h))
+               w h)]
+          [c2 (build-bitmap 
+               (lambda (dc)
+                 (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent))
+                 (send dc set-brush (send the-brush-list find-or-create-brush font-color 'solid))
+                 (send dc draw-rectangle 0 0 w h))
+               w h)]
+          [m2 (build-bitmap
+               (lambda (dc)
+                 (send dc set-font font)
+                 (send dc set-text-mode 'solid)
+                 (send dc set-text-foreground black)
+                 (send dc draw-text str 2 2))
+               w h)]
+          [final
+           (build-bitmap
+            (lambda (dc)
+              (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
+              (send dc set-brush (send the-brush-list find-or-create-brush bkg-color 'solid))
+              (send dc draw-rectangle 0 0 w h)
+              (send dc set-font font)
+              (send dc set-text-mode 'transparent)
+              (send dc set-text-foreground font-color)
+              (send dc draw-text str 2 2))
+            w h)])
+     
+     (overlay-bitmap argb 0 0 c1 m1)
+     (overlay-bitmap argb 0 0 c2 m2)
+
+     ;; at this point, the `final' bitmap should be the same as argb,
+     ;; but it isn't, due to rounding error (final is actually wrong!)
+     ;; the stuff below just makes sure that each entry is within 3
+     
+     
+     ;; the expression below shows the truncated bitmap, 
+     ;; the true bitmap (after rounding) and the difference, as a bitmap
+     #;
+     (let* ([argb-bitmap (flatten-bitmap (argb->bitmap argb))]
+            [argb-str (cadr (bitmap->string argb-bitmap))]
+            [bitmap-str (cadr (bitmap->string final))]
+            [new-bitmap-str (make-string (string-length argb-str) #\000)]
+            [new-bitmap (make-object bitmap% w h)]
+            [dc (make-object bitmap-dc% new-bitmap)])
+       (let loop ([i 0])
+         (when (< i (string-length argb-str))
+           (unless (equal? (string-ref argb-str i)
+                           (string-ref bitmap-str i))
+             (string-set! new-bitmap-str i #\377))
+           (loop (+ i 1))))
+       (send dc set-argb-pixels 0 0 w h new-bitmap-str)
+       (send dc set-bitmap #f)
+       (show-bitmap argb-bitmap #f "argb")
+       (show-bitmap final #f "final")
+       (show-bitmap new-bitmap #f "difference"))
+     
+     (let* ([argb-bitmap (flatten-bitmap (argb->bitmap argb))]
+            [argb-ents (map char->integer (string->list (cadr (bitmap->string argb-bitmap))))]
+            [bitmap-ents (map char->integer (string->list (cadr (bitmap->string final))))])
+       (test #t (lambda (x) x) (andmap (lambda (x y) (<= (abs (- x y)) 3))
+                                       argb-ents
+                                       bitmap-ents))))
+  
+   (report-errs)))
\ No newline at end of file
diff --git a/collects/tests/mzscheme/censor.ss b/collects/tests/mzscheme/censor.ss
new file mode 100644
index 0000000000..a1fa115ba5
--- /dev/null
+++ b/collects/tests/mzscheme/censor.ss
@@ -0,0 +1,37 @@
+
+; run a thunk using a censor that removes dangerous chars from a 
+; string for printing to a terminal
+(lambda (thunk)
+  (let ([censor (lambda (s)
+		  (list->bytes
+		   (let loop ([s (bytes->list s)])
+		     (if (null? s)
+			 null
+			 (let ([c (car s)])
+			   (cond
+			    [(and (or (< c 32) (>= c #o200))
+				  (not (= c 10)))
+			     (append (cons (char->integer #\{)
+					   (map
+					    char->integer
+					    (string->list 
+					     (number->string c))))
+				     (cons (char->integer #\})
+					   (loop (cdr s))))]
+			    [else
+			     (cons c (loop (cdr s)))]))))))])
+    (let* ([oldp (current-output-port)]
+	   [cp (make-output-port
+		'censor
+		oldp
+		(lambda (s start end nonblock? breakable?)
+		  (display (censor (subbytes s start end)) oldp)
+		  (- end start))
+		void)])
+      (dynamic-wind
+       (lambda () (current-output-port cp))
+       thunk
+       (lambda ()
+	 (current-output-port oldp))))))
+
+
diff --git a/collects/tests/mzscheme/char-set.ss b/collects/tests/mzscheme/char-set.ss
new file mode 100644
index 0000000000..2d159af952
--- /dev/null
+++ b/collects/tests/mzscheme/char-set.ss
@@ -0,0 +1,495 @@
+
+(load-relative "loadtest.ss")
+
+(SECTION 'char-set/SRFI-14)
+
+(require (lib "char-set.ss" "srfi" "14"))
+
+;; NOTE: tests assume that ! functions are actually functional
+
+;; Check char sets ----------------------------------------
+
+(test #t char-set-contains? char-set:lower-case #\a)
+(test #f char-set-contains? char-set:lower-case #\A)
+(test #t char-set-contains? char-set:lower-case #\u00E0)
+(test #f char-set-contains? char-set:lower-case #\u00C2)
+(test #t char-set-contains? char-set:lower-case #\u00B5)
+
+(test #t char-set-contains? char-set:upper-case #\A)
+(test #f char-set-contains? char-set:upper-case #\a)
+(test #t char-set-contains? char-set:upper-case #\u00C2)
+(test #f char-set-contains? char-set:upper-case #\u00E0)
+
+(test #t char-set-contains? char-set:title-case #\u01C5)
+(test #t char-set-contains? char-set:title-case #\u1FA8)
+(test #f char-set-contains? char-set:title-case #\a)
+(test #f char-set-contains? char-set:title-case #\A)
+
+(test #t char-set-contains? char-set:letter #\a)
+(test #t char-set-contains? char-set:letter #\A)
+(test #f char-set-contains? char-set:letter #\1)
+(test #t char-set-contains? char-set:letter #\u00AA)
+(test #t char-set-contains? char-set:letter #\u00BA)
+
+(test #f char-set-every (lambda (c) (char-set-contains? char-set:lower-case c)) char-set:letter)
+(test #t char-set-any (lambda (c) (char-set-contains? char-set:lower-case c)) char-set:letter)
+(test #f char-set-every (lambda (c) (char-set-contains? char-set:upper-case c)) char-set:letter)
+(test #t char-set-any (lambda (c) (char-set-contains? char-set:upper-case c)) char-set:letter)
+;; Not true?
+;; (test #t char-set<= char-set:letter (char-set-union char-set:lower-case char-set:upper-case char-set:title-case))
+
+(test #t char-set-contains? char-set:digit #\1)
+(test #f char-set-contains? char-set:digit #\a)
+
+(test #t char-set-contains? char-set:hex-digit #\1)
+(test #t char-set-contains? char-set:hex-digit #\a)
+(test #t char-set-contains? char-set:hex-digit #\A)
+(test #f char-set-contains? char-set:hex-digit #\g)
+
+(test #t char-set-contains? char-set:letter+digit #\1)
+(test #t char-set-contains? char-set:letter+digit #\a)
+(test #t char-set-contains? char-set:letter+digit #\z)
+(test #t char-set-contains? char-set:letter+digit #\A)
+(test #t char-set-contains? char-set:letter+digit #\Z)
+
+(test 90547 char-set-size char-set:letter)
+
+(test #t char-set= char-set:letter+digit (char-set-union char-set:letter char-set:digit))
+;; Slow!:
+;;  (test #t char-set-every (lambda (c) (char-set-contains? char-set:letter+digit c)) char-set:letter)
+;; Slow!:
+;;  (test #t char-set-every (lambda (c) (char-set-contains? char-set:letter+digit c)) char-set:digit)
+(test #f char-set-every (lambda (c) (char-set-contains? char-set:letter c)) char-set:letter+digit)
+(test #f char-set-every (lambda (c) (char-set-contains? char-set:digit c)) char-set:letter+digit)
+(test #t char-set-any (lambda (c) (char-set-contains? char-set:letter c)) char-set:letter+digit)
+
+(define char-set:latin-1 (ucs-range->char-set 0 256))
+
+(test #t char-set= 
+      (char-set-intersection char-set:graphic char-set:latin-1)
+      (char-set-intersection (char-set-union char-set:letter char-set:digit char-set:punctuation char-set:symbol)
+			     char-set:latin-1))
+
+(test #t char-set= char-set:printing (char-set-union char-set:graphic char-set:whitespace))
+
+(test #t char-set-contains? char-set:whitespace #\u0009)
+(test #t char-set-contains? char-set:whitespace #\u000D)
+(test #f char-set-contains? char-set:whitespace #\a)
+
+(test #t char-set= char-set:iso-control 
+      (char-set-union (ucs-range->char-set #x0000 #x0020)
+		      (ucs-range->char-set #x007F #x00A0)))
+
+(test #t char-set-contains? char-set:punctuation #\!)
+(test #t char-set-contains? char-set:punctuation #\u00A1)
+(test #f char-set-contains? char-set:punctuation #\a)
+
+(test #t char-set-contains? char-set:symbol #\$)
+(test #t char-set-contains? char-set:symbol #\u00A2)
+(test #f char-set-contains? char-set:symbol #\a)
+
+(test #t char-set-contains?  char-set:blank #\space)
+(test #t char-set-contains?  char-set:blank #\u3000)
+(test #f char-set-contains?  char-set:blank #\a)
+
+;; General procedures ----------------------------------------
+
+(test #t char-set= char-set:letter char-set:letter char-set:letter)
+(test #f char-set= char-set:letter char-set:digit)
+(test #f char-set= char-set:letter char-set:letter char-set:digit)
+(test #f char-set= char-set:letter char-set:digit char-set:letter)
+
+(test #t char-set<= char-set:graphic char-set:printing)
+(test #f char-set<= char-set:printing char-set:graphic)
+(test #t char-set<= char-set:graphic char-set:printing char-set:full)
+(test #f char-set<= char-set:graphic char-set:full char-set:printing)
+  
+(test (char-set-hash char-set:graphic) char-set-hash char-set:graphic)
+
+;; Iterating over character sets ----------------------------------------
+
+;; The number 268 comes from "grep Nd UnicodeData.txt | wc -l"
+(test 268 char-set-size char-set:digit)
+
+(test #t char-set=
+      char-set:digit
+      (list->char-set
+       (let loop ([c (char-set-cursor char-set:digit)][l null])
+	 (if (end-of-char-set? c)
+	     l
+	     (loop (char-set-cursor-next char-set:digit c)
+		   (cons (char-set-ref char-set:digit c)
+			 l))))))
+
+(test #t char-set=
+      (ucs-range->char-set 10 20)
+      (char-set-unfold (lambda (x) (= x 20)) integer->char add1 10))
+(test #t char-set=
+      (ucs-range->char-set 10 21)
+      (char-set-unfold (lambda (x) (= x 20)) integer->char add1 10 (char-set #\u14)))
+(test #t char-set=
+      (ucs-range->char-set 10 20)
+      (char-set-unfold! (lambda (x) (= x 20)) integer->char add1 10 char-set:empty))
+
+(test #t char-set= char-set:digit
+      (let ([cs char-set:empty])
+	(char-set-for-each 
+	 (lambda (c) 
+	   (set! cs (char-set-adjoin cs c)))
+	 char-set:digit)
+	cs))
+
+(test #t char-set= char-set:digit
+      (char-set-map
+       (lambda (c) c)
+       char-set:digit))
+(test #t char-set= char-set:digit
+      (char-set-map
+       (lambda (c) c)
+       char-set:digit))
+(test #t char-set= (char-set-adjoin char-set:digit #\A)
+      (char-set-union
+       (char-set-map
+	(lambda (c) c)
+	char-set:digit)
+       (char-set #\A)))
+
+;; Creating character sets ----------------------------------------
+
+(test #t char-set= char-set:digit (char-set-copy char-set:digit))
+
+(let ([abc (char-set #\a #\b #\c)])
+  (test #t char-set= abc (char-set #\c #\a #\b))
+  (test #t char-set= abc (string->char-set "cba"))
+  (test #t char-set= abc (string->char-set! "cba" char-set:empty))
+  (test #t char-set= abc (string->char-set "cb" (char-set #\a)))
+  (test #t char-set= (char-set #\b) (char-set-filter (lambda (c) (char=? c #\b)) abc))
+  (test #t char-set= (char-set #\b) (char-set-filter (lambda (c) (char=? c #\b)) abc char-set:empty))
+  (test #t char-set= (char-set #\b) (char-set-filter! (lambda (c) (char=? c #\b)) abc char-set:empty))
+  (test #t char-set= abc (->char-set "abc"))
+  (test #t char-set= abc (->char-set abc))
+  (test #t char-set= (char-set #\a) (->char-set #\a)))
+
+(test #t char-set= 
+      (ucs-range->char-set 0 #x20000)
+      (char-set-union (ucs-range->char-set 0 #xD800)
+		      (ucs-range->char-set #xE000 #x20000)))
+(test #t char-set= 
+      (ucs-range->char-set 0 #xD801)
+      (ucs-range->char-set 0 #xD800))
+(test #t char-set= 
+      (ucs-range->char-set 0 #xDFFF)
+      (ucs-range->char-set 0 #xD800))
+(test #t char-set= 
+      (ucs-range->char-set #xD800 #xD810)
+      char-set:empty)
+(test #t char-set= 
+      (ucs-range->char-set #xD810 #xE000)
+      char-set:empty)
+(test #t char-set= 
+      (ucs-range->char-set #xE000 #xE001)
+      (ucs-range->char-set #xD810 #xE001))
+(test #t char-set= 
+      (ucs-range->char-set #xD7FF #xE001)
+      (char-set #\uD7FF #\uE000))
+
+(err/rt-test (ucs-range->char-set -1 10))
+(err/rt-test (ucs-range->char-set 2 2))
+(err/rt-test (ucs-range->char-set 2 1))
+(err/rt-test (ucs-range->char-set 0 #x300000))
+(err/rt-test (ucs-range->char-set #x300000 #x300001))
+
+;; Querying character sets ------------------------------
+
+(test 3 char-set-count (lambda (x) (char<=? #\0 x #\2)) char-set:digit)
+
+(test #t char-set= char-set:digit (list->char-set (char-set->list char-set:digit)))
+(test #t char-set= char-set:digit (list->char-set (char-set->list char-set:digit) char-set:empty))
+(test #t char-set= char-set:digit (list->char-set! (char-set->list char-set:digit) char-set:empty))
+(test #t char-set= char-set:digit (string->char-set (char-set->string char-set:digit)))
+
+;; Character-set algebra ----------------------------------------
+
+(let* ([cs1 (char-set #\U #\t #\a #\h)]
+       [cs2 (char-set-union cs1 (char-set #\S #\L #\C))])
+  (test #t char-set= cs2 (char-set-adjoin cs1 #\S #\L #\C))
+  (test #t char-set= cs2 (char-set-adjoin! cs1 #\S #\L #\C))
+  (test #t char-set= (char-set-delete cs2 #\S #\L #\C) cs1)
+  (test #t char-set= (char-set-delete! cs2 #\S #\L #\C) cs1)
+
+  (test #t char-set= char-set:empty (char-set-union))
+  (test #t char-set= char-set:full (char-set-intersection))
+  (test #t char-set= char-set:empty (char-set-xor))
+  (test #t char-set= char-set:digit (char-set-union char-set:digit))
+  (test #t char-set= char-set:digit (char-set-intersection char-set:digit))
+  (test #t char-set= char-set:digit (char-set-difference char-set:digit))
+  (test #t char-set= char-set:digit (char-set-xor char-set:digit))
+
+  (let ([go 
+	 (lambda (char-set-union)
+	   (test #t char-set= cs1 (char-set-union (char-set #\U #\t #\a #\h)))
+	   (test #t char-set= cs1 (char-set-union (char-set #\U #\t) (char-set #\a #\h)))
+	   (test #t char-set= cs1 (char-set-union (char-set #\U) (char-set #\t #\a) (char-set #\h))))])
+    (go char-set-union)
+    (go char-set-union!))
+
+  (let ([go 
+	 (lambda (char-set-intersect)
+	   (test #t char-set= cs1 (char-set-intersect (char-set #\U #\t #\a #\h)))
+	   (test #t char-set= cs1 (char-set-intersect (char-set #\U #\t #\a #\h #\v) (char-set #\U #\t #\a #\h #\w)))
+	   (test #t char-set= cs1 (char-set-intersect (char-set #\U #\t #\a #\h #\v) 
+						      (char-set #\U #\t #\a #\h #\w)
+						      (char-set #\a #\b #\U #\t #\a #\h #\w))))])
+    (go char-set-intersection)
+    (go char-set-intersection!))
+
+  (let ([go 
+	 (lambda (char-set-diff)
+	   (test #t char-set= cs1 (char-set-diff (char-set #\U #\t #\a #\h #\v) 
+						 (char-set #\v #\b)))
+	   (test #t char-set= cs1 (char-set-diff (char-set #\U #\t #\a #\h #\v #\w) 
+						 (char-set #\v #\b)
+						 (char-set #\w))))])
+    (go char-set-difference)
+    (go char-set-difference!))
+
+  (let ([go 
+	 (lambda (char-set-xor)
+	   (test #t char-set= cs1 (char-set-xor (char-set #\U #\t #\a #\v) 
+						(char-set #\v #\h)))
+	   (test #t char-set= cs1 (char-set-xor (char-set #\U #\h #\v #\w) 
+						(char-set #\v #\a #\b)
+						(char-set #\t #\w #\b))))])
+    (go char-set-xor)
+    (go char-set-xor!))
+
+  (let ([go 
+	 (lambda (char-set-diff+i)
+	   (test #t andmap char-set= (list cs1 (char-set #\v))
+		 (call-with-values
+		     (lambda ()
+		       (char-set-diff+i (char-set #\U #\t #\a #\h #\v) 
+					(char-set #\v #\b)))
+		   list))
+	   (test #t andmap char-set= (list cs1 char-set:empty)
+		 (call-with-values
+		     (lambda ()
+		       (char-set-diff+i (char-set #\U #\t #\a #\h #\v #\w) 
+					(char-set #\v #\b)
+					(char-set #\w)))
+		   list)))])
+    (go char-set-diff+intersection)
+    (go char-set-diff+intersection!))
+
+  )
+
+;; ----------------------------------------
+  
+;;; This is a regression testing suite for the SRFI-14 char-set library.
+;;; Olin Shivers
+
+(letrec-syntax ((tests (syntax-rules ()
+			((_ tst ...)
+			 (begin (one-test tst) ...))))
+		(one-test (syntax-rules (let)
+			    ((_ (let . rest))
+			     (test #t 'let... (let . rest)))
+			    ((_ (op arg ...))
+			     (test #t op arg ...)))))
+  (let ((vowel? (lambda (c) (member c '(#\a #\e #\i #\o #\u)))))
+
+    (tests
+     (not (char-set? 5))
+
+     (char-set? (char-set #\a #\e #\i #\o #\u))
+
+     (char-set=)
+     (char-set= (char-set))
+
+     (char-set= (char-set #\a #\e #\i #\o #\u)
+		(string->char-set "ioeauaiii"))
+
+     (not (char-set= (char-set #\e #\i #\o #\u)
+		     (string->char-set "ioeauaiii")))
+
+     (char-set<=)
+     (char-set<= (char-set))
+
+     (char-set<= (char-set #\a #\e #\i #\o #\u)
+		 (string->char-set "ioeauaiii"))
+
+     (char-set<= (char-set #\e #\i #\o #\u)
+		 (string->char-set "ioeauaiii"))
+
+     (<= 0 (char-set-hash char-set:graphic 100) 99)
+
+     (= 4 (char-set-fold (lambda (c i) (+ i 1)) 0
+			 (char-set #\e #\i #\o #\u #\e #\e)))
+
+     (char-set= (string->char-set "eiaou2468013579999")
+		(char-set-intersection
+		 (char-set-unfold null? car cdr '(#\a #\e #\i #\o #\u #\u #\u)
+				  char-set:digit)
+		 char-set:ascii))
+
+     (char-set= (string->char-set "eiaou246801357999")
+		(char-set-unfold! null? car cdr '(#\a #\e #\i #\o #\u)
+				  (string->char-set "0123456789")))
+
+     (not (char-set= (string->char-set "eiaou246801357")
+		     (char-set-unfold! null? car cdr '(#\a #\e #\i #\o #\u)
+				       (string->char-set "0123456789"))))
+
+     (let ((cs (string->char-set "0123456789")))
+       (char-set-for-each (lambda (c) (set! cs (char-set-delete cs c)))
+			  (string->char-set "02468000"))
+       (char-set= cs (string->char-set "97531")))
+
+     (not (let ((cs (string->char-set "0123456789")))
+	    (char-set-for-each (lambda (c) (set! cs (char-set-delete cs c)))
+			       (string->char-set "02468"))
+	    (char-set= cs (string->char-set "7531"))))
+
+     (char-set= (char-set-map char-upcase (string->char-set "aeiou"))
+		(string->char-set "IOUAEEEE"))
+
+     (not (char-set= (char-set-map char-upcase (string->char-set "aeiou"))
+		     (string->char-set "OUAEEEE")))
+
+     (char-set= (char-set-copy (string->char-set "aeiou"))
+		(string->char-set "aeiou"))
+
+     (char-set= (char-set #\x #\y) (string->char-set "xy"))
+     (not (char-set= (char-set #\x #\y #\z) (string->char-set "xy")))
+
+     (char-set= (string->char-set "xy") (list->char-set '(#\x #\y)))
+     (not (char-set= (string->char-set "axy") (list->char-set '(#\x #\y))))
+
+     (char-set= (string->char-set "xy12345")
+		(list->char-set '(#\x #\y) (string->char-set "12345")))
+     (not (char-set= (string->char-set "y12345")
+		     (list->char-set '(#\x #\y) (string->char-set "12345"))))
+
+     (char-set= (string->char-set "xy12345")
+		(list->char-set! '(#\x #\y) (string->char-set "12345")))
+     (not (char-set= (string->char-set "y12345")
+		     (list->char-set! '(#\x #\y) (string->char-set "12345"))))
+
+     (char-set= (string->char-set "aeiou12345")
+		(char-set-filter vowel? char-set:ascii (string->char-set "12345")))
+     (not (char-set= (string->char-set "aeou12345")
+		     (char-set-filter vowel? char-set:ascii (string->char-set "12345"))))
+
+     (char-set= (string->char-set "aeiou12345")
+		(char-set-filter! vowel? char-set:ascii (string->char-set "12345")))
+     (not (char-set= (string->char-set "aeou12345")
+		     (char-set-filter! vowel? char-set:ascii (string->char-set "12345"))))
+
+
+     (char-set= (string->char-set "abcdef12345")
+		(ucs-range->char-set 97 103 #t (string->char-set "12345")))
+     (not (char-set= (string->char-set "abcef12345")
+		     (ucs-range->char-set 97 103 #t (string->char-set "12345"))))
+
+     (char-set= (string->char-set "abcdef12345")
+		(ucs-range->char-set! 97 103 #t (string->char-set "12345")))
+     (not (char-set= (string->char-set "abcef12345")
+		     (ucs-range->char-set! 97 103 #t (string->char-set "12345"))))
+
+
+     (char-set= (->char-set #\x)
+		(->char-set "x")
+		(->char-set (char-set #\x)))
+
+     (not (char-set= (->char-set #\x)
+		     (->char-set "y")
+		     (->char-set (char-set #\x))))
+
+     (= 10 (char-set-size (char-set-intersection char-set:ascii char-set:digit)))
+
+     (= 5 (char-set-count vowel? char-set:ascii))
+
+     (equal? '(#\x) (char-set->list (char-set #\x)))
+     (not (equal? '(#\X) (char-set->list (char-set #\x))))
+
+     (equal? "x" (char-set->string (char-set #\x)))
+     (not (equal? "X" (char-set->string (char-set #\x))))
+
+     (char-set-contains? (->char-set "xyz") #\x)
+     (not (char-set-contains? (->char-set "xyz") #\a))
+
+     (char-set-every char-lower-case? (->char-set "abcd"))
+     (not (char-set-every char-lower-case? (->char-set "abcD")))
+     (char-set-any char-lower-case? (->char-set "abcd"))
+     (not (char-set-any char-lower-case? (->char-set "ABCD")))
+
+     (char-set= (->char-set "ABCD")
+		(let ((cs (->char-set "abcd")))
+		  (let lp ((cur (char-set-cursor cs)) (ans '()))
+		    (if (end-of-char-set? cur) (list->char-set ans)
+			(lp (char-set-cursor-next cs cur)
+			    (cons (char-upcase (char-set-ref cs cur)) ans))))))
+
+
+     (char-set= (char-set-adjoin (->char-set "123") #\x #\a)
+		(->char-set "123xa"))
+     (not (char-set= (char-set-adjoin (->char-set "123") #\x #\a)
+		     (->char-set "123x")))
+     (char-set= (char-set-adjoin! (->char-set "123") #\x #\a)
+		(->char-set "123xa"))
+     (not (char-set= (char-set-adjoin! (->char-set "123") #\x #\a)
+		     (->char-set "123x")))
+
+     (char-set= (char-set-delete (->char-set "123") #\2 #\a #\2)
+		(->char-set "13"))
+     (not (char-set= (char-set-delete (->char-set "123") #\2 #\a #\2)
+		     (->char-set "13a")))
+     (char-set= (char-set-delete! (->char-set "123") #\2 #\a #\2)
+		(->char-set "13"))
+     (not (char-set= (char-set-delete! (->char-set "123") #\2 #\a #\2)
+		     (->char-set "13a")))
+
+     (char-set= (char-set-intersection char-set:hex-digit (char-set-complement char-set:digit))
+		(->char-set "abcdefABCDEF"))
+     (char-set= (char-set-intersection! (char-set-complement! (->char-set "0123456789"))
+					char-set:hex-digit)
+		(->char-set "abcdefABCDEF"))
+
+     (char-set= (char-set-union char-set:hex-digit
+				(->char-set "abcdefghijkl"))
+		(->char-set "abcdefABCDEFghijkl0123456789"))
+     (char-set= (char-set-union! (->char-set "abcdefghijkl")
+				 char-set:hex-digit)
+		(->char-set "abcdefABCDEFghijkl0123456789"))
+
+     (char-set= (char-set-difference (->char-set "abcdefghijklmn")
+				     char-set:hex-digit)
+		(->char-set "ghijklmn"))
+     (char-set= (char-set-difference! (->char-set "abcdefghijklmn")
+				      char-set:hex-digit)
+		(->char-set "ghijklmn"))
+
+     (char-set= (char-set-xor (->char-set "0123456789")
+			      char-set:hex-digit)
+		(->char-set "abcdefABCDEF"))
+     (char-set= (char-set-xor! (->char-set "0123456789")
+			       char-set:hex-digit)
+		(->char-set "abcdefABCDEF"))
+
+     (call-with-values (lambda ()
+			 (char-set-diff+intersection char-set:hex-digit
+						     char-set:letter))
+       (lambda (d i)
+	 (and (char-set= d (->char-set "0123456789"))
+	      (char-set= i (->char-set "abcdefABCDEF")))))
+
+     (call-with-values (lambda ()
+			 (char-set-diff+intersection! (char-set-copy char-set:hex-digit)
+						      (char-set-copy char-set:letter)))
+       (lambda (d i)
+	 (and (char-set= d (->char-set "0123456789"))
+	      (char-set= i (->char-set "abcdefABCDEF"))))))))
+
+;; ----------------------------------------
+
+(report-errs)
diff --git a/collects/tests/mzscheme/chez-module.ss b/collects/tests/mzscheme/chez-module.ss
new file mode 100644
index 0000000000..88d2673250
--- /dev/null
+++ b/collects/tests/mzscheme/chez-module.ss
@@ -0,0 +1,273 @@
+
+;; Run this file with -r, and inspect the
+;; printouts.
+
+(module helpers mzscheme
+  (require (lib "package.ss"))
+
+  (provide identifier-syntax with-implicit
+	   (rename package module)
+	   (rename open import))
+
+  (define-syntax (identifier-syntax stx)
+    (syntax-case stx ()
+      [(_ id) (if (identifier? #'id)
+		  #'(make-rename-transformer (quote-syntax id))
+		  ;; Cheating in this case... examples only
+		  ;; use this in a non-applied position
+		  #'(lambda (stx) (quote-syntax id)))]))
+
+  (define-syntax with-implicit
+    (syntax-rules ()
+      [(_ (orig id ...) body)
+       (with-syntax ([id (datum->syntax-object #'orig (syntax-e #'id))]
+		     ...)
+	 body)])))
+    
+
+(require helpers)
+(require-for-syntax helpers)
+
+;; Make evaluation print the result, for testing
+(let ([eh (current-eval)])
+  (current-eval (lambda (x)
+		  (let ([v (eh x)])
+		    (unless (void? v)
+		      (printf "~s~n" v))
+		    v))))
+
+(read-case-sensitive #t)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; From "Extending the Scope of Syntactic Abstraction"
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(let ((x 1))
+  (module M (x setter)
+    (define-syntax x (identifier-syntax z))
+    (define setter (lambda (x) (set! z x)))
+    (define z 5))
+  (let ((y x) (z 0))
+    (import M)
+    (setter 3) 
+    (list x y z)))
+"(3 1 0) is correct"
+
+
+(define-syntax from
+  (syntax-rules ()
+    ((_ M id) (let () (import M) id))))
+(let ((x 10))
+  (module m1 (x) (define x 1))
+  (module m2 (x) (define x 2))
+  (list (from m1 x) (from m2 x)))
+"(1 2) is correct"
+
+(define-syntax module*
+  (syntax-rules ()
+    [(_ (id ...) form ...)
+     (begin
+       (module tmp (id ...) form ...)
+       (import tmp))]
+    [(_ name (id ...) form ...)
+     (module name (id ...) form ...)]))
+(let ([w 88])
+  (module* (f)
+   (define (f) w)
+   (define w 17))
+  (list (f) w))
+"(17 88) is correct"
+
+(define-syntax define-alias
+  (syntax-rules ()
+    [(_ x y)
+     (define-syntax x 
+       (identifier-syntax y))]))
+
+(define-syntax import*
+  (syntax-rules ()
+    [(_ M) (begin)]
+    [(_ M (new old))
+     (module* (new)
+      (define-alias new tmp)
+      (module* (tmp)
+       (import M)
+       (define-alias tmp old)))]
+    [(_ M id) (module* (id) (import M))]
+    [(_ M spec0 spec1 ...)
+     (begin (import* M spec0)
+            (import* M spec1 ...))]))
+(module m (x y z)
+  (define x 'x)
+  (define y 'y)
+  (define z 'z))
+(import* m x (y z) (z y))
+(list x y z)
+"(x z y) is correct"
+
+(module A (x y)
+  (define x 1)
+  (define y 2))
+(module B (y z)
+  (define y 3) 
+  (define z 4))
+(module C (a b c d)
+  (import* A (a x) (b y))
+  (import* B (c y) (d z)))
+(module D (a c) 
+  (import C)) 
+(module E (b d) 
+  (import C))
+(let ([a 'a]
+      [b 'b]
+      [c 'c]
+      [d 'd])
+  (import D)
+  (list a b c d))
+"(1 b 3 d) is correct"
+(let ([a 'a]
+      [b 'b]
+      [c 'c]
+      [d 'd])
+  (import E)
+  (list a b c d))
+"(a 2 c 4) is correct"
+
+(module* (A B)
+ (module A (x) 
+   (define x (lambda () y)))
+ (module B (y)
+   (define y (lambda () x)))
+ (import A)
+ (import B))
+(import A)
+(import B)
+(and (eq? x (y)) (eq? (y) x))
+"#t is correct"
+
+
+(define-syntax rec-modules
+  (syntax-rules ()
+    ((_ (module N (id ...) form ...) ...)
+     (module* (N ...)
+      (module N (id ...) form ...) ...
+      (import N) ...))))
+(rec-modules
+ (module O (odd)
+   (define (odd x)
+     (if (zero? x) #f (even (sub1 x)))))
+ (module E (even)
+   (define (even x)
+     (if (zero? x) #t (odd (sub1 x))))))
+(import O)
+(list (odd 17) (odd 32))
+"(#t #f) is correct"
+
+
+(define-syntax define-interface
+  (syntax-rules ()
+    [(_ name (export ...))
+     (define-syntax name
+       (lambda (x)
+	 (syntax-case x ()
+	   [(_ n defs)
+	    (with-implicit (n export ...)
+	     #'(module n (export ...) . defs))])))]))
+(define-syntax define-module
+  (syntax-rules ()
+    [(_ name interface defn ...)
+     (interface name (defn ...))]))
+(define-interface simple (a b))
+(define-module M simple
+  (define-syntax a (identifier-syntax 1))
+  (define b (lambda () c))
+  (define c 2))
+(let ()
+  (import M)
+  (list a (b)))
+"(1 2) is right"
+
+(define-syntax define-interface
+  (syntax-rules (compound-interface)
+    [(_ name (compound-interface i0 i1 ...))
+     (d-i-help name (i0 i1 ...) ())]
+    [(_ name (export ...))
+     (define-syntax name
+       (lambda (x)
+	 (syntax-case x (expand-exports)
+	   [(_ n defs)
+	    (with-implicit (n export ...)
+	     #'(module n (export ...) . defs))]
+	   [(_ (expand-exports i-name mac)) 
+	    (with-implicit (i-name export ...)
+	     #'(mac i-name export ...))])))]))
+(define-syntax d-i-help
+  (syntax-rules ()
+    [(_ name () (export ...))
+     (define-interface name (export ...))]
+    [(_ name (i0 i1 ...) (e ...))
+     (begin
+       (define-syntax tmp
+	 (syntax-rules ()
+	   [(_ name expt (... ...))
+	    (d-i-help name (i1 ...)
+		      (e ... expt (... ...)))]))
+       (i0 (expand-exports name tmp)))]))
+(define-syntax define-module
+  (syntax-rules (compound-interface)
+    [(_ name (compound-interface i ...) defn ...)
+     (begin
+       (define-interface tmp(compound-interface i ...))
+       (define-module name tmp defn ...))]
+    [(_ name interface defn ...) (interface name (defn ...))])) 
+(define-interface one (a b))
+(define-interface two (c d))
+(define-interface both
+  (compound-interface one two))
+(define-module M (compound-interface one two)
+  (define a 1)
+  (define b 2)
+  (define c 3) 
+  (define d 4))
+(let () 
+  (import M) 
+  (list a b c d))
+"(1 2 3 4) is correct"
+
+(define-syntax declare
+  (syntax-rules ()
+    [(_ id) (define id (void))]))
+(define-syntax satisfy
+  (syntax-rules ()
+    [(_ id val) (set! id val)]))
+
+(define-syntax abstract-module
+  (syntax-rules ()
+    ((_ name (ex ...) (mac ...) defn ...)
+     (module name (ex ... mac ...)
+       (declare ex) 
+       ... defn ...))))
+(define-syntax implement
+  (syntax-rules ()
+    ((_ name form ...)
+     (module* () 
+      (import name)
+      form ...))))
+(abstract-module E (even?) ())
+(abstract-module 
+ O (odd?) (pred)
+ (define-syntax pred
+   (syntax-rules () ((_ exp) (- exp 1)))))
+(implement E
+ (import O)
+ (satisfy even? 
+  (lambda (x) (or (zero? x) (odd? (pred x))))))
+(implement O
+ (import E)
+ (satisfy 
+  odd?
+  (lambda (x) (not (even? x))))) 
+(import O)
+(list (odd? 10) (odd? 13))
+"(#f #t) is correct"
+
diff --git a/collects/tests/mzscheme/chkdoc.ss b/collects/tests/mzscheme/chkdoc.ss
new file mode 100644
index 0000000000..c4249aeb06
--- /dev/null
+++ b/collects/tests/mzscheme/chkdoc.ss
@@ -0,0 +1,28 @@
+
+(require-library "mzlib.ss")
+
+(define actual-definitions
+  (filter (lambda (s)
+	    (let ([s (symbol->string s)])
+	      (not (char=? (string-ref s 0) #\#))))
+	  (map car (make-global-value-list))))
+
+(define doc-path (collection-path "doc"))
+
+(define r5rs-keywords (with-input-from-file (build-path doc-path "r5rs" "keywords") read))
+(define mzscheme-keywords (with-input-from-file (build-path doc-path "mzscheme" "keywords") read))
+
+(define documented
+  (map string->symbol (map car (append r5rs-keywords mzscheme-keywords))))
+
+(for-each
+ (lambda (doc)
+   (unless (memq doc actual-definitions)
+     (printf "Documented but doesn't exist: ~a~n" doc)))
+ documented)
+
+(for-each
+ (lambda (act)
+   (unless (memq act documented)
+     (printf "Undocumented: ~a~n" act)))
+ actual-definitions)
diff --git a/collects/tests/mzscheme/cmdline.ss b/collects/tests/mzscheme/cmdline.ss
new file mode 100644
index 0000000000..13ec94e980
--- /dev/null
+++ b/collects/tests/mzscheme/cmdline.ss
@@ -0,0 +1,178 @@
+
+(load-relative "loadtest.ss")
+
+(SECTION 'COMMAND-LINE)
+
+(require (lib "cmdline.ss"))
+
+(define (r-append opt . rest)
+  (append opt (list (list->vector rest))))
+
+(test '("-bye" #())
+      parse-command-line
+      "test"
+      #("--hi" "-bye")
+      (list 
+       (list
+	'multi
+	(list (list "--hi")
+	      (lambda (flag v) v)
+	      (list "Hello" "x"))))
+      r-append
+      '("arg"))
+
+(test '("1" "2" #("3"))
+      parse-command-line
+      "test"
+      #("-xi" "1" "2" "3")
+      (list 
+       (list
+       'multi
+	(list (list "-x" "-i")
+	      (lambda (flag v) v)
+	      (list "x or i" "x"))))
+      r-append
+      '("arg"))
+
+(test '(("-x" "a" "b") ("-i") #())
+      parse-command-line
+      "test"
+      #("-xi" "a" "b")
+      (list 
+       (list
+	'multi
+	(list (list "-x" "-i")
+	      list
+	      (list "xi"))))
+      r-append
+      '("arg"))
+
+(test '("--simple" ("-x" . "a") ("-i" . "b") #())
+      parse-command-line
+      "test"
+      #("--simple" "-xi" "a" "b")
+      (list 
+       (list
+	'multi
+	(list (list "--simple") (lambda (v) v) (list "S"))
+	(list (list "-x" "-i")
+	      cons
+	      (list "xi" "v"))))
+      r-append
+      '("arg"))
+
+(test '(("-x" "a" "c") ("-i" . "b") #("d"))
+      parse-command-line
+      "test"
+      #("-xi" "a" "c" "b" "d")
+      (list 
+       (list
+	'multi
+	(list (list "-x")
+	      (lambda (x y z) (list x y z))
+	      (list "X" "y" "z"))
+	(list (list "-i")
+	      cons
+	      (list "i" "v"))))
+      r-append
+      '("arg"))
+
+(define (test-end-flags v include?)
+  (test (list
+	 (list->vector
+	  (let ([l '("-xi" "--bad" "--")])
+	    (if include?
+		(cons v l)
+		l))))
+	parse-command-line
+	"test"
+	(vector v "-xi" "--bad" "--")
+	(list 
+	 (list
+	  'multi
+	  (list (list "-x" "-i")
+		list
+		(list "xi"))))
+	r-append
+	'("arg")))
+
+(test-end-flags "1" #t)
+(test-end-flags "+" #t)
+(test-end-flags "-" #t)
+(test-end-flags "--" #f)
+(test-end-flags "-1" #t)
+(test-end-flags "+1" #t)
+(test-end-flags "-1.4" #t)
+(test-end-flags "+1999.0" #t)
+
+(define (test-bad-flag v name) ; -h and -i defined
+  (test 'yes-it-worked
+	(lambda (x-ignored y-ignored)
+	  (with-handlers ([void
+			   (lambda (exn)
+			     (if (regexp-match
+				  (format "unknown flag: ~s" name)
+				  (exn-message exn))
+				 'yes-it-worked
+				 exn))])
+	    (parse-command-line
+	     "test"
+	     (vector name "--")
+	     (list 
+	      (list
+	       'multi
+	       (list (list "-x" "-i")
+		     list
+		     (list "x i"))))
+	     r-append
+	     '("arg"))))
+	v name))
+
+(test-bad-flag "--ok" "--ok")
+(test-bad-flag "-xbi" "-b")
+
+(test (void) parse-command-line "test" #() null void '("arg"))
+(test (void) parse-command-line "test" #() (list (list 'once-each (list null void '("")))) void '("arg"))
+(test (void) parse-command-line "test" #() (list (list 'once-any (list null void '("")))) void '("arg"))
+(test (void) parse-command-line "test" #() (list (list 'multi (list null void '("")))) void '("arg"))
+(test (void) parse-command-line "test" #() (list (list 'multi)) void '("arg"))
+
+(test "2" parse-command-line "test" #("1" "2") null (lambda (a b c) c) '("b" "c"))
+
+(err/rt-test (parse-command-line 'test #() null void '("arg")))
+(err/rt-test (parse-command-line "test" 9 null void '("arg")))
+(err/rt-test (parse-command-line "test" #() (list 0) void '("arg")))
+(err/rt-test (parse-command-line "test" #() (list (list 'malti)) void '("arg")))
+(err/rt-test (parse-command-line "test" #() (list (list 'multi (list 0 void '("")))) void '("arg")))
+(err/rt-test (parse-command-line "test" #() (list (list 'multi (list (list 0) void '("")))) void '("arg")))
+(err/rt-test (parse-command-line "test" #() (list (list 'multi (list (list "hi") void '("")))) void '("arg")))
+(err/rt-test (parse-command-line "test" #() (list (list 'multi (list (list "--") void '("")))) void '("arg")))
+(err/rt-test (parse-command-line "test" #() (list (list 'multi (list (list "-xi") void '("")))) void '("arg")))
+(err/rt-test (parse-command-line "test" #() (list (list 'multi (list (list "-x") (lambda () null) '("")))) void '("arg")))
+(err/rt-test (parse-command-line "test" #() (list (list 'multi (list (list "--xi") void ""))) void '("arg")))
+(err/rt-test (parse-command-line "test" #() (list (list 'multi (list (list "--xi") void '("" a)))) void '("arg")))
+(err/rt-test (parse-command-line "test" #() null (lambda () null) null))
+
+(err/rt-test (parse-command-line "test" #() null (lambda (x y) null) null) exn:fail?)
+
+(test (void) 'cmdline (command-line "something" #("-ab")
+				    (once-each
+				     [("-a") "ok" 5]
+				     [("-b" "--more") "Help" 7])))
+
+(syntax-test #'(command-line))
+(syntax-test #'(command-line "hello"))
+(err/rt-test (command-line 'hello #("ok")))
+(syntax-test #'(command-line "hello" #("ok") (bad)))
+(syntax-test #'(command-line "hello" #("ok") (once-any ())))
+(syntax-test #'(command-line "hello" #("ok") (once-any ("-ok"))))
+(syntax-test #'(command-line "hello" #("ok") (once-any ("-ok" "the ok flag"))))
+(syntax-test #'(command-line "hello" #("ok") (once-any ("-ok" a "the ok flag"))))
+(syntax-test #'(command-line "hello" #("ok") (once-any ("-ok" (a) "the ok flag"))))
+(syntax-test #'(command-line "hello" #("ok") (once-any ("-ok" a "the ok flag") ())))
+(syntax-test #'(command-line "hello" #("ok") (args 'done) (once-any ("-ok" a "the ok flag" 7))))
+(syntax-test #'(command-line "hello" #("ok") (args (ok) 'done) (once-any ("-ok" a "the ok flag" 7))))
+(syntax-test #'(command-line "hello" #("ok") (=> 'done) (once-any ("-ok" a "the ok flag" 7))))
+(syntax-test #'(command-line "hello" #("ok") (=> 1 2 3 4) (once-any ("-ok" a "the ok flag" 7))))
+
+(report-errs)
diff --git a/collects/tests/mzscheme/compat.ss b/collects/tests/mzscheme/compat.ss
new file mode 100644
index 0000000000..2d084d32f8
--- /dev/null
+++ b/collects/tests/mzscheme/compat.ss
@@ -0,0 +1,24 @@
+
+
+(load-relative "loadtest.ss")
+
+(SECTION 'compat)
+
+(require (lib "compat.ss"))
+
+(define-structure (add left right) ([sum (+ left right)]))
+(test 9 add-sum (make-add 3 6))
+
+
+(test #f getprop 'hello-world 'any)
+(test 'oops getprop 'hello-world 'any 'oops)
+(test #f getprop 'hello-world 'any)
+(test (void) putprop 'hello-world 'any 'aha)
+(test 'aha getprop 'hello-world 'any)
+(test 'aha getprop 'hello-world 'any 'oops)
+(test #f getprop 'hello-world 'many)
+(test 'oops getprop 'hello-world 'many 'oops)
+(test #f getprop 'bye-world 'any)
+(test 'oops getprop 'bye-world 'any 'oops)
+
+(report-errs)
diff --git a/collects/tests/mzscheme/compfile.ss b/collects/tests/mzscheme/compfile.ss
new file mode 100644
index 0000000000..4cd9181988
--- /dev/null
+++ b/collects/tests/mzscheme/compfile.ss
@@ -0,0 +1,11 @@
+
+(require-library "compat.ss")
+(require-library "compat.ss")
+(require-library "compat.ss")
+
+(defmacro test (x y) (string-append x y))
+
+(test "a" "b")
+
+(load x)
+(require-library)
diff --git a/collects/tests/mzscheme/compile.ss b/collects/tests/mzscheme/compile.ss
new file mode 100644
index 0000000000..2137a8a52f
--- /dev/null
+++ b/collects/tests/mzscheme/compile.ss
@@ -0,0 +1,117 @@
+
+; Tests compilation and writing/reading compiled code
+;  by setting the eval handler and running all tests
+
+(load-relative "loadtest.ss")
+
+(namespace-variable-value 
+ 'compile-load
+ #f
+ (lambda ()
+   (namespace-set-variable-value! 'compile-load "quiet.ss")))
+
+(define file
+  (if #f
+      (open-output-file "x" 'replace)
+      (make-output-port 'nowhere
+			always-evt
+			(lambda (s start end non-block? breakable?) (- end start))
+			void
+			(lambda (special non-block? breakable?) #t)
+			(lambda (s start end) (wrap-evt
+					       always-evt
+					       (lambda (x)
+						 (- end start))))
+			(lambda (special) (wrap-evt always-evt (lambda (x) #t))))))
+
+(define try-one
+  (lambda (e)
+    (let ([c (compile-syntax e)]
+	  [ec (compile-syntax (expand e))]
+	  [p (open-output-bytes)]
+	  [ep (open-output-bytes)])
+      (write c p)
+      (write ec ep)
+      (let ([s (get-output-bytes p)]
+	    [es (get-output-bytes ep)])
+	(unless (equal? s es)
+	  (error 'try "bad expand ~e~n" e))
+	; (write (string->list s)) (newline)
+	(let ([e (parameterize ([read-accept-compiled #t])
+		     (read (open-input-bytes s)))])
+	  (eval e))))))
+
+(letrec ([orig (current-eval)]
+	 [orig-load (current-load)]
+	 [my-load
+	  (lambda (filename expected-module)
+	    (let ([f (open-input-file filename)])
+	      (dynamic-wind
+	       void
+	       (lambda ()
+		 (let loop ([results (list (void))])
+		   (let ([v (parameterize ([read-accept-compiled #t])
+			       (read f))])
+		     (if (eof-object? v)
+			 (apply values results)
+			 (loop (call-with-values
+				(lambda () (my-eval v orig))
+				list))))))
+	       (lambda ()
+		 (close-input-port f)))))]
+	 [my-eval
+	  (case-lambda 
+	   [(x next-eval)
+	    (if (or (compiled-expression? x)
+		    (and (syntax? x) (compiled-expression? (syntax-e x)))
+		    (current-module-name-prefix))
+		(next-eval x)
+		(begin
+		  ;; (fprintf file ": ~a~n" +)
+		  ;; (write x file) (newline file)
+		  (let ([p (open-output-bytes)]
+			[ep (open-output-bytes)]
+			[c ((if (syntax? x) compile-syntax compile) x)]
+			[ec (compile-syntax ((if (syntax? x) expand-syntax expand) x))])
+		    (write c p)
+		    (write ec ep)
+		    (let ([s (get-output-bytes p)]
+			  [es (get-output-bytes ep)])
+		      (unless (equal? s es)
+			'(fprintf (current-error-port) "bad expand (~a,~a) ~e~n" 
+				  (bytes-length s) (bytes-length es) x))
+					; (display s file) (newline file)
+		      (let ([e (parameterize ([read-accept-compiled #t])
+				 (read (open-input-bytes s)))])
+					; (write e file) (newline file)
+			(parameterize ([current-eval next-eval])
+			  (orig e)))))))]
+	   [(x) (my-eval x orig)])])
+  (dynamic-wind
+   (lambda ()
+     (set! teval (lambda (x) (my-eval x my-eval)))
+     ; (read-accept-compiled #t)
+     (current-eval my-eval)
+     (current-load my-load))
+   (lambda ()
+     (load-relative compile-load))
+   (lambda ()
+     (set! teval eval)
+     (close-output-port file)
+     ; (read-accept-compiled #f)
+     (current-eval orig)
+     (current-load orig-load))))
+
+; Check compiled number I/O:
+(let ([l (let loop ([n -512][l null])
+	   (if (= n 513)
+	       l
+	       (loop (add1 n) (cons n l))))]
+      [p (open-output-bytes)])
+  (write (compile `(quote ,l)) p)
+  (let ([s (open-input-bytes (get-output-bytes p))])
+    (let ([l2 (parameterize ([read-accept-compiled #t])
+		    (eval (read s)))])
+      (test #t equal? l l2))))
+
+(report-errs)
diff --git a/collects/tests/mzscheme/compilex.ss b/collects/tests/mzscheme/compilex.ss
new file mode 100644
index 0000000000..5e417fb0a7
--- /dev/null
+++ b/collects/tests/mzscheme/compilex.ss
@@ -0,0 +1,14 @@
+
+; Tests simple compilation by setting the eval handler and
+;  running all tests
+
+(let ([orig (current-eval)])
+  (dynamic-wind
+   (lambda ()
+     (current-eval
+      (lambda (x)
+	(orig (compile x)))))
+   (lambda ()
+     (load "all.ss"))
+   (lambda ()
+     (current-eval orig))))
diff --git a/collects/tests/mzscheme/contmark.ss b/collects/tests/mzscheme/contmark.ss
new file mode 100644
index 0000000000..b73c4b12ae
--- /dev/null
+++ b/collects/tests/mzscheme/contmark.ss
@@ -0,0 +1,423 @@
+
+
+(load-relative "loadtest.ss")
+
+(require (lib "unit.ss"))
+
+(SECTION 'continuation-marks)
+
+(define (extract-current-continuation-marks key)
+  (continuation-mark-set->list (current-continuation-marks) key))
+
+(test null extract-current-continuation-marks 'key)
+
+(syntax-test #'with-continuation-mark)
+(syntax-test #'(with-continuation-mark))
+(syntax-test #'(with-continuation-mark 1))
+(syntax-test #'(with-continuation-mark 1))
+(syntax-test #'(with-continuation-mark 1 2))
+(syntax-test #'(with-continuation-mark 1 2 3 4))
+(syntax-test #'(with-continuation-mark 1 2 3 . 4))
+
+(test '(10) 'wcm (with-continuation-mark 'key 10 
+		   (extract-current-continuation-marks 'key)))
+(test '(#(10 #f)) 'wcm (with-continuation-mark 'key 10 
+			 (continuation-mark-set->list* (current-continuation-marks) '(key no-key))))
+(test '(#(#f 10)) 'wcm (with-continuation-mark 'key 10 
+			 (continuation-mark-set->list* (current-continuation-marks) '(no-key key))))
+(test '(#(nope 10)) 'wcm (with-continuation-mark 'key 10 
+			   (continuation-mark-set->list* (current-continuation-marks) '(no-key key) 'nope)))
+
+(test '(#(10 12)) 'wcm (with-continuation-mark 'key1 10 
+			 (with-continuation-mark 'key2 12 
+			   (continuation-mark-set->list* (current-continuation-marks) '(key1 key2)))))
+(test '(#(#f 12) #(10 #f)) 'wcm 
+      (with-continuation-mark 'key1 10 
+	(let ([x (with-continuation-mark 'key2 12 
+		   (continuation-mark-set->list* (current-continuation-marks) '(key1 key2)))])
+	  (if (void? x)
+	      x
+	      x))))
+
+(test '(11) 'wcm (with-continuation-mark 'key 10 
+		   (with-continuation-mark 'key 11
+		     (extract-current-continuation-marks 'key))))
+(test '(9) 'wcm (with-continuation-mark 'key 10 
+	     (with-continuation-mark 'key2 9
+	       (with-continuation-mark 'key 11
+		 (extract-current-continuation-marks 'key2)))))
+(test '() 'wcm (with-continuation-mark 'key 10 
+	    (with-continuation-mark 'key2 9
+	      (with-continuation-mark 'key 11
+		(extract-current-continuation-marks 'key3)))))
+
+(test '() 'wcm (let ([x (with-continuation-mark 'key 10 (list 100))])
+		 (extract-current-continuation-marks 'key)))
+
+(test '(11) 'wcm (with-continuation-mark 'key 11
+		   (let ([x (with-continuation-mark 'key 10 (extract-current-continuation-marks 'key))])
+		     (extract-current-continuation-marks 'key))))
+
+(test '((11) (10 11) (11)) 'wcm (with-continuation-mark 'key 11
+				  (list (extract-current-continuation-marks 'key)
+					(with-continuation-mark 'key 10 (extract-current-continuation-marks 'key))
+					(extract-current-continuation-marks 'key))))
+
+(test '(11) 'wcm-invoke/tail (with-continuation-mark 'x 10
+			       (invoke-unit
+				(unit 
+				  (import)
+				  (export)
+				  
+				  (with-continuation-mark 'x 11
+				    (continuation-mark-set->list
+				     (current-continuation-marks)
+				     'x))))))
+
+(test '(11 10) 'wcm-invoke/nontail (with-continuation-mark 'x 10
+				     (invoke-unit
+				      (unit 
+					(import)
+					(export)
+					
+					(define l (with-continuation-mark 'x 11
+						    (continuation-mark-set->list
+						     (current-continuation-marks)
+						     'x)))
+					l))))
+
+(test '(11 10) 'wcm-begin0 (with-continuation-mark 'x 10
+			     (begin0
+			      (with-continuation-mark 'x 11
+				(extract-current-continuation-marks 'x))
+			      (+ 2 3))))
+(test '(11 10) 'wcm-begin0/const (with-continuation-mark 'x 10
+				   (begin0
+				    (with-continuation-mark 'x 11
+				      (extract-current-continuation-marks 'x))
+				    'constant)))
+
+;; full continuation, same thread
+(test '(11 10) 'wcm-begin0 
+      (let ([k (with-continuation-mark 'x 10
+		 (begin0
+		  (with-continuation-mark 'x 11
+		    (let/cc k k))
+		  (+ 2 3)))])
+	(continuation-mark-set->list 
+	 (continuation-marks k)
+	 'x)))
+
+;; full continuation, another thread
+(test '(11 10) 'wcm-begin0 
+      (let ([k (with-continuation-mark 'x 10
+		 (begin0
+		  (with-continuation-mark 'x 11
+		    (let/cc k k))
+		  (+ 2 3)))])
+	(continuation-mark-set->list 
+	 (let ([v #f])
+	   (thread-wait (thread (lambda () 
+				  (set! v (continuation-marks k)))))
+	   v)
+	 'x)))
+
+;; escape continuation, same thread
+(test '(11 10) 'wcm-begin0 
+      (let ([m (with-continuation-mark 'x 10
+		 (begin0
+		  (with-continuation-mark 'x 11
+		    (let/ec k 
+		      (begin0
+		       (with-continuation-mark 'x 12
+			 (continuation-marks k))
+		       (+ 17 7))))
+		  (+ 2 3)))])
+	(continuation-mark-set->list m 'x)))
+
+;; escape continuation, another thread => not allowed
+(test #f 'wcm-begin0 
+      (with-continuation-mark 'x 10
+	(let/ec k 
+	  (with-continuation-mark 'x 12
+	    (let ([v #f])
+	      (thread-wait 
+	       (thread (lambda () 
+			 (set! v (continuation-marks k)))))
+	      v)))))
+
+;; escape continuation, dead
+(err/rt-test (continuation-marks (let/ec k k)) exn:application:mismatch?)
+
+(define (get-marks)
+  (extract-current-continuation-marks 'key))
+
+(define (tail-apply f)
+  (with-continuation-mark 'key 'tail
+    (f)))
+
+(define (non-tail-apply f)
+  (with-continuation-mark 'key 'non-tail
+    (car (cons (f) null))))
+
+(test '(tail) tail-apply get-marks)
+(test '(non-tail) non-tail-apply get-marks)
+(test '(tail non-tail) non-tail-apply (lambda () (tail-apply get-marks)))
+(test '(non-tail) tail-apply (lambda () (non-tail-apply get-marks)))
+
+(define (mark-x f)
+  (lambda ()
+    (with-continuation-mark 'key 'x (f))))
+
+(test '(x) tail-apply (mark-x get-marks))
+(test '(x non-tail) non-tail-apply (mark-x get-marks))
+
+(test '(x) tail-apply (lambda () (tail-apply (mark-x get-marks))))
+(test '(x non-tail non-tail) non-tail-apply (lambda () (non-tail-apply (mark-x get-marks))))
+(test '(x non-tail) tail-apply (lambda () (non-tail-apply (mark-x get-marks))))
+(test '(x non-tail) non-tail-apply (lambda () (tail-apply (mark-x get-marks))))
+
+;; Make sure restoring continuations restores the marks:
+(let ([l null])
+ (let ([did-once? #f]
+       [did-twice? #f]
+       [try-again #f]
+       [get-marks #f])
+   
+   (with-continuation-mark
+    'key (let/cc k (set! try-again k) 1)
+    (begin
+      (unless did-once?
+	(set! get-marks (let/cc k k)))
+      (set! l (cons (extract-current-continuation-marks 'key) l))))
+
+   (if did-once?
+       (unless did-twice?
+	 (set! did-twice? #t)
+	 (get-marks #f))
+       (begin
+	 (set! did-once? #t)
+	 (try-again 2))))
+
+ (test '((1) (2) (1)) 'call/cc-restore-marks l))
+
+;; Make sure restoring continuations restores the right marks
+;;  for dynamic-wind thunks
+
+
+(let* ([x (make-parameter 0)]
+       [l null]
+       [add (lambda (a b)
+	      (set! l (append l (list (cons a b)))))]
+       [cp #f])
+  (let ([k (parameterize ([x 5])
+	     (dynamic-wind
+		 (lambda () (add 1 (x)))
+		 (lambda () (parameterize ([x 6])
+			      (let ([k+e (let/cc k (cons k void))])
+				(set! cp (current-parameterization))
+				(add 2 (x))
+				((cdr k+e))
+				(car k+e))))
+		 (lambda () (add 3 (x)))))])
+    (parameterize ([x 7])
+      (let/cc esc
+	(k (cons void esc)))))
+  (test l values '((1 . 5) (2 . 6) (3 . 5) (1 . 5) (2 . 6) (3 . 5)))
+  (test 6 call-with-parameterization cp (lambda () (x)))
+  (test 0 call-with-parameterization (current-parameterization) (lambda () (x))))
+
+(let* ([l null]
+       [add (lambda (a b)
+	      (set! l (append l (list (cons a b)))))]
+       [x (lambda ()
+	    (car (continuation-mark-set->list (current-continuation-marks) 
+					      'x)))])
+  (let ([k (with-continuation-mark 'x 5
+	     (dynamic-wind
+		 (lambda () (add 1 (x)))
+		 (lambda () (with-continuation-mark 'x 6
+			      (let ([k+e (let/cc k (cons k void))])
+				(add 2 (x))
+				((cdr k+e))
+				(car k+e))))
+		 (lambda () (add 3 (x)))))])
+    (with-continuation-mark 'x 7
+      (let/cc esc
+	(k (cons void esc)))))
+  (test l values '((1 . 5) (2 . 6) (3 . 5) (1 . 5) (2 . 6) (3 . 5))))
+
+(let ([k0 #f]
+      [k1 #f]
+      [k2 #f]
+      [k3 #f]
+      [k4 #f]
+      [k5 #f]
+      [esc void])
+  (define (go)
+    (with-continuation-mark 'a 7
+      (dynamic-wind
+	  (lambda ()
+	    ((let/cc k (set! k0 k) void))
+	    (test '(7) extract-current-continuation-marks 'a))
+	  (lambda ()
+	    (with-continuation-mark 'a 8
+	      (begin
+		(test '(8 7) extract-current-continuation-marks 'a)
+		((let/cc k (set! k1 k) void))
+		(test '(8 7) extract-current-continuation-marks 'a)
+		(dynamic-wind
+		    (lambda ()
+		      (test '(8 7) extract-current-continuation-marks 'a)
+		      (with-continuation-mark 'a 9
+			(begin
+			  ((let/cc k (set! k2 k) void))
+			  (test '(9 8 7) extract-current-continuation-marks 'a))))
+		    (lambda ()
+		      ((let/cc k (set! k3 k) void))
+		      (test '(8 7) extract-current-continuation-marks 'a))
+		    (lambda ()
+		      (with-continuation-mark 'a 10
+			(begin
+			  ((let/cc k (set! k4 k) void))
+			  (test '(10 8 7) extract-current-continuation-marks 'a)))
+		      (test '(8 7) extract-current-continuation-marks 'a)))
+		(test '(8 7) extract-current-continuation-marks 'a))))
+	  (lambda ()
+	    ((let/cc k (set! k5 k) void))
+	    (test '(7) extract-current-continuation-marks 'a))))
+    (esc))
+  (go)
+  (let ([k0 k0]
+	[k1 k1]
+	[k2 k2]
+	[k3 k3]
+	[k4 k4]
+	[k5 k5])
+    (let/cc k (set! esc k) (k1 void))
+    (let/cc k (set! esc k) (k1 k))
+    (let/cc k (set! esc k) (k2 void))
+    (let/cc k (set! esc k) (k2 k))
+    (let/cc k (set! esc k) (k3 void))
+    (let/cc k (set! esc k) (k3 k))
+    (let/cc k (set! esc k) (k4 void))
+    (let/cc k (set! esc k) (k4 k))
+    (let/cc k (set! esc k) (k5 void))
+    (let/cc k (set! esc k) (k5 k))))
+
+(test #t parameterization? (current-parameterization))
+(test #f parameterization? (make-parameter 5))
+(arity-test current-parameterization 0 0)
+(arity-test call-with-parameterization 2 2)
+(err/rt-test (call-with-parameterization 10 (lambda () 12)))
+(err/rt-test (call-with-parameterization (current-parameterization) (lambda (x) 12)))
+
+;; Create a deep stack with a deep mark stack
+
+(define (p-equal? a b)
+  (let loop ([a a][b b])
+    (cond
+     [(eq? a b) #t]
+     [(equal? (car a) (car b))
+      (loop (cdr a) (cdr b))]
+     [else
+      (printf "a: ~s~n" a)
+      (printf "b: ~s~n" b)
+      #f])))
+
+(test #t
+      'deep-stacks
+      (p-equal?
+       (let loop ([n 1000][l null])
+	 (if (zero? n)
+	     l
+	     (loop (sub1 n) (cons n l))))
+       (let loop ([n 1000])
+	 (if (zero? n)
+	     (extract-current-continuation-marks 'x)
+	     (let ([x (with-continuation-mark 'x n (loop (sub1 n)))])
+	       x)))))
+
+;; Create a deep mark stack 10 times
+(let loop ([n 10])
+  (unless (zero? n)
+    (let* ([max 1000]
+	   [r (add1 (random max))])
+      (test (list 0 r)
+	    `(loop ,n)
+	    (with-continuation-mark 'base 0
+	      (let loop ([n max])
+		(if (zero? n)
+		    (append
+		     (extract-current-continuation-marks 'base)
+		     (extract-current-continuation-marks r))
+		    (with-continuation-mark n n
+		      (loop (sub1 n))))))))
+    (loop (sub1 n))))
+
+;; Make sure marks are separate in separate threads
+(let ([s1 (make-semaphore 0)]
+      [s2 (make-semaphore 0)]
+      [result null])
+  (thread (lambda ()
+	    (with-continuation-mark 'key 'b.1
+	      (begin
+		(semaphore-wait s1)
+		(with-continuation-mark 'key 'b.2
+		  (begin
+		    (semaphore-post s2)
+		    (semaphore-wait s1)
+		    (with-continuation-mark 'key 'b.4
+		      (begin
+			(set! result (extract-current-continuation-marks 'key))
+			(semaphore-post s2)))
+		    'ok))
+		'ok))))
+  (thread-wait
+   (thread (lambda ()
+	     (with-continuation-mark 'key 'a.1
+	       (begin
+		 (semaphore-post s1)
+		 (with-continuation-mark 'key 'a.2
+		   (begin
+		     (semaphore-wait s2)
+		     (with-continuation-mark 'key 'a.3
+		       (begin
+			 (semaphore-post s1)
+			 (with-continuation-mark 'key 'a.4
+			   (begin
+			     (semaphore-wait s2)
+			     (set! result (append (extract-current-continuation-marks 'key) result))))
+			 'ok))
+		     'ok))
+		 'ok)))))
+  (test '(a.4 a.3 a.2 a.1 b.4 b.2 b.1) 'thread-marks result))
+
+(arity-test current-continuation-marks 0 0)
+(arity-test continuation-mark-set->list 2 2)
+(arity-test continuation-mark-set? 1 1)
+
+(err/rt-test (continuation-mark-set->list 5 1))
+
+(test #f continuation-mark-set? 5)
+(test #t continuation-mark-set? (current-continuation-marks))
+
+(let ([c #f]
+      [l null])
+  (thread-wait
+   (thread (lambda ()
+	     (dynamic-wind
+		 (lambda () (collect-garbage))
+		 (lambda ()
+		   (let-values ([(a b) (let/cc k 
+					 (set! c k)
+					 (values 1 2))])
+		     (set! l (append l (list a b)))))
+		 void))))
+  (thread-wait
+   (thread (lambda ()
+	     (c 4 5))))
+  (test '(1 2 4 5) values l))
+
+  
+(report-errs)
diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss
new file mode 100644
index 0000000000..ad9b2ca6aa
--- /dev/null
+++ b/collects/tests/mzscheme/contract-test.ss
@@ -0,0 +1,3115 @@
+(load-relative "loadtest.ss")
+(require (lib "contract.ss")
+	 (lib "class.ss")
+         (lib "etc.ss"))
+  
+(SECTION 'contract)
+
+(parameterize ([error-print-width 200])
+(let ()
+  ;; test/spec-passed : symbol sexp -> void
+  ;; tests a passing specification
+  (define (test/spec-passed name expression)
+    (printf "testing: ~s\n" name)
+    (test (void)
+          (let ([for-each-eval (lambda (l) (for-each eval l))]) for-each-eval)
+          (list expression '(void))))
+  
+  (define (test/spec-passed/result name expression result)
+    (printf "testing: ~s\n" name)
+    (test result
+          eval
+          expression))
+  
+  (define (test/spec-failed name expression blame)
+    (cond
+      [(equal? blame "pos")
+       (test/pos-blame name expression)]
+      [(equal? blame "neg")
+       (test/neg-blame name expression)]
+      [else
+       (let ()
+         (define (has-proper-blame? msg)
+           (equal?
+            blame
+            (cond
+              [(regexp-match #rx"^([^ ]*) broke" msg) => cadr]
+              [else (format "no blame in error message: \"~a\"" msg)])))
+         (printf "testing: ~s\n" name)
+         (thunk-error-test 
+          (lambda () (eval expression))
+          (datum->syntax-object #'here expression)
+          (lambda (exn)
+            (and (exn? exn)
+                 (has-proper-blame? (exn-message exn))))))]))
+  
+  (define (test/pos-blame name expression)
+    (define (has-pos-blame? exn)
+      (and (exn? exn)
+           (and (regexp-match #rx"^pos broke" (exn-message exn)))))
+    (printf "testing: ~s\n" name)
+    (thunk-error-test 
+     (lambda () (eval expression))
+     (datum->syntax-object #'here expression)
+     has-pos-blame?))
+  
+  (define (test/neg-blame name expression)
+    (define (has-neg-blame? exn)
+      (and (exn? exn)
+           (and (regexp-match #rx"^neg broke" (exn-message exn)))))
+    (printf "testing: ~s\n" name)
+    (thunk-error-test 
+     (lambda () (eval expression))
+     (datum->syntax-object #'here expression)
+     has-neg-blame?))
+  
+  (define (test/well-formed stx)
+    (test (void) 
+          (let ([expand/ret-void (lambda (x) (expand x) (void))]) expand/ret-void)
+          stx))
+  
+  (define (test/no-error sexp)
+    (test (void)
+          eval
+          `(begin ,sexp (void))))
+  
+  (define (test-flat-contract contract pass fail)
+    (let ([name (if (pair? contract)
+                    (car contract)
+                    contract)])
+      (test/spec-failed (format "~a fail" name)
+                        `(contract ,contract ',fail 'pos 'neg)
+                        "pos")
+      (test/spec-passed/result
+       (format "~a pass" name)
+       `(contract ,contract ',pass 'pos 'neg)
+       pass)))
+
+  (define (test-name name contract)
+    (test name contract-name contract))
+  
+  (test/spec-passed
+   'contract-flat1 
+   '(contract not #f 'pos 'neg))
+  
+  (test/pos-blame
+   'contract-flat2 
+   '(contract not #t 'pos 'neg))
+  
+  (test/no-error '(-> integer? integer?))
+  (test/no-error '(-> (flat-contract integer?) (flat-contract integer?)))
+  (test/no-error '(-> integer? any))
+  (test/no-error '(-> (flat-contract integer?) any))
+  
+  (test/no-error '(->* (integer?) (integer?)))
+  (test/no-error '(->* (integer?) integer? (integer?)))
+  (test/no-error '(->* (integer?) integer? any))
+  (test/no-error '(->* ((flat-contract integer?)) ((flat-contract integer?))))
+  (test/no-error '(->* ((flat-contract integer?)) (flat-contract integer?) ((flat-contract integer?))))
+  (test/no-error '(->* ((flat-contract integer?)) (flat-contract integer?) any))
+  
+  (test/no-error '(->d integer? (lambda (x) integer?)))
+  (test/no-error '(->d (flat-contract integer?) (lambda (x) (flat-contract integer?))))
+
+  (test/no-error '(->d* (integer?) (lambda (x) integer?)))
+  (test/no-error '(->d* ((flat-contract integer?)) (lambda (x) (flat-contract integer?))))
+  (test/no-error '(->d* (integer?) integer? (lambda (x . y) integer?)))
+  (test/no-error '(->d* ((flat-contract integer?)) (flat-contract integer?) (lambda (x . y) (flat-contract integer?))))
+  
+  (test/no-error '(opt-> (integer?) (integer?) integer?))
+  (test/no-error '(opt-> ((flat-contract integer?)) ((flat-contract integer?)) (flat-contract integer?)))
+  (test/no-error '(opt-> ((flat-contract integer?)) ((flat-contract integer?)) any))
+  (test/no-error '(opt->* (integer?) (integer?) (integer?)))
+  (test/no-error '(opt->* ((flat-contract integer?)) ((flat-contract integer?)) ((flat-contract integer?))))
+  (test/no-error '(opt->* (integer?) (integer?) any))
+  (test/no-error '(opt->* ((flat-contract integer?)) ((flat-contract integer?)) any))
+  
+  (test/no-error '(listof any/c))
+  (test/no-error '(listof (lambda (x) #t)))
+  
+  (test/spec-passed
+   'contract-arrow-star0a
+   '(contract (->* (integer?) (integer?))
+              (lambda (x) x)
+              'pos
+              'neg))
+  
+  (test/neg-blame
+   'contract-arrow-star0b
+   '((contract (->* (integer?) (integer?))
+               (lambda (x) x)
+               'pos
+               'neg)
+     #f))
+  
+  (test/pos-blame
+   'contract-arrow-star0c
+   '((contract (->* (integer?) (integer?))
+               (lambda (x) #f)
+               'pos
+               'neg)
+     1))
+  
+  (test/spec-passed
+   'contract-arrow-star1
+   '(let-values ([(a b) ((contract (->* (integer?) (integer? integer?))
+                                   (lambda (x) (values x x))
+                                   'pos
+                                   'neg)
+                         2)])
+      1))
+  
+  (test/neg-blame
+   'contract-arrow-star2
+   '((contract (->* (integer?) (integer? integer?))
+               (lambda (x) (values x x))
+               'pos
+               'neg)
+     #f))
+  
+  (test/pos-blame
+   'contract-arrow-star3
+   '((contract (->* (integer?) (integer? integer?))
+               (lambda (x) (values 1 #t))
+               'pos
+               'neg)
+     1))
+  
+  (test/pos-blame
+   'contract-arrow-star4
+   '((contract (->* (integer?) (integer? integer?))
+               (lambda (x) (values #t 1))
+               'pos
+               'neg)
+     1))
+  
+  
+  (test/spec-passed
+   'contract-arrow-star5
+   '(let-values ([(a b) ((contract (->* (integer?) 
+                                        (listof integer?)
+                                        (integer? integer?))
+                                   (lambda (x . y) (values x x))
+                                   'pos
+                                   'neg)
+                         2)])
+      1))
+  
+  (test/neg-blame
+   'contract-arrow-star6
+   '((contract (->* (integer?) (listof integer?) (integer? integer?))
+               (lambda (x . y) (values x x))
+               'pos
+               'neg)
+     #f))
+  
+  (test/pos-blame
+   'contract-arrow-star7
+   '((contract (->* (integer?) (listof integer?) (integer? integer?))
+               (lambda (x . y) (values 1 #t))
+               'pos
+               'neg)
+     1))
+  
+  (test/pos-blame
+   'contract-arrow-star8
+   '((contract (->* (integer?) (listof integer?) (integer? integer?))
+               (lambda (x) (values #t 1))
+               'pos
+               'neg)
+     1))
+  
+  (test/spec-passed
+   'contract-arrow-star9
+   '((contract (->* (integer?) (listof integer?) (integer?))
+               (lambda (x . y) 1)
+               'pos
+               'neg)
+     1 2))
+  
+  (test/neg-blame
+   'contract-arrow-star10
+   '((contract (->* (integer?) (listof integer?) (integer?))
+               (lambda (x . y) 1)
+               'pos
+               'neg)
+     1 2 'bad))
+  
+  (test/spec-passed
+   'contract-arrow-star11
+   '(let-values ([(a b) ((contract (->* (integer?) 
+                                        (listof integer?)
+					any)
+                                   (lambda (x) (values x x))
+                                   'pos
+                                   'neg)
+                         2)])
+      1))
+  
+  (test/neg-blame
+   'contract-arrow-star12
+   '((contract (->* (integer?) (listof integer?) any)
+               (lambda (x . y) (values x x))
+               'pos
+               'neg)
+     #f))
+  
+  (test/spec-passed
+   'contract-arrow-star13
+   '((contract (->* (integer?) (listof integer?) any)
+               (lambda (x . y) 1)
+               'pos
+               'neg)
+     1 2))
+  
+  (test/neg-blame
+   'contract-arrow-star14
+   '((contract (->* (integer?) (listof integer?) any)
+               (lambda (x . y) 1)
+               'pos
+               'neg)
+     1 2 'bad))
+  
+  (test/spec-passed
+   'contract-arrow-star15
+   '(let-values ([(a b) ((contract (->* (integer?) any)
+                                   (lambda (x) (values x x))
+                                   'pos
+                                   'neg)
+                         2)])
+      1))
+  
+  (test/spec-passed
+   'contract-arrow-star16
+   '((contract (->* (integer?) any)
+               (lambda (x) x)
+               'pos
+               'neg)
+     2))
+  
+  (test/neg-blame
+   'contract-arrow-star17
+   '((contract (->* (integer?) any)
+               (lambda (x) (values x x))
+               'pos
+               'neg)
+     #f))
+
+  (test/pos-blame
+   'contract-arrow-star-arity-check1
+   '(contract (->* (integer?) (listof integer?) (integer? integer?))
+              (lambda (x) (values 1 #t))
+              'pos
+              'neg))
+  
+  (test/pos-blame
+   'contract-arrow-star-arity-check2
+   '(contract (->* (integer?) (listof integer?) (integer? integer?))
+              (lambda (x y) (values 1 #t))
+              'pos
+              'neg))
+  
+  (test/pos-blame
+   'contract-arrow-star-arity-check3
+   '(contract (->* (integer?) (listof integer?) (integer? integer?))
+              (case-lambda [(x y) #f] [(x y . z) #t])
+              'pos
+              'neg))
+  
+  (test/spec-passed
+   'contract-arrow-star-arity-check4
+   '(contract (->* (integer?) (listof integer?) (integer? integer?))
+              (case-lambda [(x y) #f] [(x y . z) #t] [(x) #f])
+              'pos
+              'neg))
+  
+  (test/spec-passed
+   'contract-arrow-values1
+   '(let-values ([(a b) ((contract (-> integer? (values integer? integer?))
+                                   (lambda (x) (values x x))
+                                   'pos
+                                   'neg)
+                         2)])
+      1))
+  
+  (test/neg-blame
+   'contract-arrow-values2
+   '((contract (-> integer? (values integer? integer?))
+               (lambda (x) (values x x))
+               'pos
+               'neg)
+     #f))
+  
+  (test/pos-blame
+   'contract-arrow-values3
+   '((contract (-> integer? (values integer? integer?))
+               (lambda (x) (values 1 #t))
+               'pos
+               'neg)
+     1))
+  
+  (test/pos-blame
+   'contract-arrow-values4
+   '((contract (-> integer? (values integer? integer?))
+               (lambda (x) (values #t 1))
+               'pos
+               'neg)
+     1))
+  
+  (test/pos-blame
+   'contract-d1
+   '(contract (integer? . ->d . (lambda (x) (lambda (y) (= x y))))
+              1
+              'pos
+              'neg))
+  
+  (test/spec-passed
+   'contract-d2
+   '(contract (integer? . ->d . (lambda (x) (lambda (y) (= x y))))
+              (lambda (x) x)
+              'pos
+              'neg))
+  
+  (test/pos-blame
+   'contract-d2
+   '((contract (integer? . ->d . (lambda (x) (lambda (y) (= x y))))
+               (lambda (x) (+ x 1))
+               'pos
+               'neg)
+     2))
+
+  (test/spec-passed
+   'contract-arrow1
+   '(contract (integer? . -> . integer?) (lambda (x) x) 'pos 'neg))
+  
+  (test/pos-blame
+   'contract-arrow2
+   '(contract (integer? . -> . integer?) (lambda (x y) x) 'pos 'neg))
+  
+  (test/neg-blame
+   'contract-arrow3
+   '((contract (integer? . -> . integer?) (lambda (x) #f) 'pos 'neg) #t))
+  
+  (test/pos-blame
+   'contract-arrow4
+   '((contract (integer? . -> . integer?) (lambda (x) #f) 'pos 'neg) 1))
+
+
+  (test/spec-passed
+   'contract-arrow-any1
+   '(contract (integer? . -> . any) (lambda (x) x) 'pos 'neg))
+  
+  (test/pos-blame
+   'contract-arrow-any2
+   '(contract (integer? . -> . any) (lambda (x y) x) 'pos 'neg))
+  
+  (test/neg-blame
+   'contract-arrow-any3
+   '((contract (integer? . -> . any) (lambda (x) #f) 'pos 'neg) #t))
+
+  (test/spec-passed
+   'contract-arrow-star-d1
+   '((contract (->d* (integer?) (lambda (arg) (lambda (res) (= arg res))))
+               (lambda (x) x)
+               'pos
+               'neg)
+     1))
+  
+  (test/spec-passed
+   'contract-arrow-star-d2
+   '(let-values ([(a b)
+                  ((contract (->d* (integer?) (lambda (arg) 
+                                                (values (lambda (res) (= arg res)) 
+                                                        (lambda (res) (= arg res)))))
+                             (lambda (x) (values x x))
+                             'pos
+                             'neg)
+                   1)])
+      1))
+  
+  (test/pos-blame
+   'contract-arrow-star-d3
+   '((contract (->d* (integer?) (lambda (arg) 
+                                  (values (lambda (res) (= arg res)) 
+                                          (lambda (res) (= arg res)))))
+               (lambda (x) (values 1 2))
+               'pos
+               'neg)
+     2))
+  
+  (test/pos-blame
+   'contract-arrow-star-d4
+   '((contract (->d* (integer?) (lambda (arg) 
+                                  (values (lambda (res) (= arg res)) 
+                                          (lambda (res) (= arg res)))))
+               (lambda (x) (values 2 1))
+               'pos
+               'neg)
+     2))
+  
+  (test/spec-passed
+   'contract-arrow-star-d5
+   '((contract (->d* ()
+                     (listof integer?)
+                     (lambda args (lambda (res) (= (car args) res))))
+               (lambda x (car x))
+               'pos
+               'neg)
+     1))
+  
+  (test/spec-passed
+   'contract-arrow-star-d6
+   '((contract (->d* () 
+                     (listof integer?)
+                     (lambda args
+                       (values (lambda (res) (= (car args) res)) 
+                               (lambda (res) (= (car args) res)))))
+               (lambda x (values (car x) (car x)))
+               'pos
+               'neg)
+     1))
+  
+  (test/pos-blame
+   'contract-arrow-star-d7
+   '((contract (->d* () 
+                     (listof integer?)
+                     (lambda args
+                       (values (lambda (res) (= (car args) res)) 
+                               (lambda (res) (= (car args) res)))))
+               (lambda x (values 1 2))
+               'pos
+               'neg)
+     2))
+  
+  (test/pos-blame
+   'contract-arrow-star-d8
+   '((contract (->d* ()
+                     (listof integer?)
+                     (lambda args
+                       (values (lambda (res) (= (car args) res)) 
+                               (lambda (res) (= (car args) res)))))
+               (lambda x (values 2 1))
+               'pos
+               'neg)
+     2))
+  
+  (test/pos-blame
+   'contract-arrow-star-d8
+   '(contract (->d* ()
+                    (listof integer?)
+                    (lambda arg
+                      (values (lambda (res) (= (car arg) res)) 
+                              (lambda (res) (= (car arg) res)))))
+              (lambda (x) (values 2 1))
+              'pos
+              'neg))
+  
+  (test/spec-passed
+   '->r1
+   '((contract (->r () number?) (lambda () 1) 'pos 'neg)))
+  
+  (test/spec-passed
+   '->r2
+   '((contract (->r ([x number?]) number?) (lambda (x) (+ x 1)) 'pos 'neg) 1))
+
+  (test/pos-blame
+   '->r3
+   '((contract (->r () number?) 1 'pos 'neg)))
+  
+  (test/pos-blame
+   '->r4
+   '((contract (->r () number?) (lambda (x) x) 'pos 'neg)))
+  
+  (test/neg-blame
+   '->r5
+   '((contract (->r ([x number?]) (<=/c x)) (lambda (x) (+ x 1)) 'pos 'neg) #f))
+  
+  (test/pos-blame
+   '->r6
+   '((contract (->r ([x number?]) (<=/c x)) (lambda (x) (+ x 1)) 'pos 'neg) 1))
+  
+  (test/spec-passed
+   '->r7
+   '((contract (->r ([x number?] [y (<=/c x)]) (<=/c x)) (lambda (x y) (- x 1)) 'pos 'neg) 1 0))
+  
+  (test/neg-blame
+   '->r8
+   '((contract (->r ([x number?] [y (<=/c x)]) (<=/c x)) (lambda (x y) (+ x 1)) 'pos 'neg) 1 2))
+  
+  (test/spec-passed
+   '->r9
+   '((contract (->r ([y (<=/c x)] [x number?]) (<=/c x)) (lambda (y x) (- x 1)) 'pos 'neg) 1 2))
+  
+  (test/neg-blame
+   '->r10
+   '((contract (->r ([y (<=/c x)] [x number?]) (<=/c x)) (lambda (y x) (+ x 1)) 'pos 'neg) 1 0))
+  
+  (test/spec-passed
+   '->r11
+   '((contract (->r () rest any/c number?) (lambda x 1) 'pos 'neg)))
+  
+  (test/spec-passed
+   '->r12
+   '((contract (->r ([x number?]) rest any/c number?) (lambda (x . y) (+ x 1)) 'pos 'neg) 1))
+
+  (test/pos-blame
+   '->r13
+   '((contract (->r () rest any/c number?) 1 'pos 'neg)))
+  
+  (test/pos-blame
+   '->r14
+   '((contract (->r () rest any/c number?) (lambda (x) x) 'pos 'neg)))
+  
+  (test/neg-blame
+   '->r15
+   '((contract (->r ([x number?]) rest any/c (<=/c x)) (lambda (x . y) (+ x 1)) 'pos 'neg) #f))
+  
+  (test/pos-blame
+   '->r16
+   '((contract (->r ([x number?]) rest any/c (<=/c x)) (lambda (x . y) (+ x 1)) 'pos 'neg) 1))
+  
+  (test/spec-passed
+   '->r17
+   '((contract (->r ([x number?] [y (<=/c x)]) rest any/c (<=/c x)) (lambda (x y . z) (- x 1)) 'pos 'neg) 1 0))
+  
+  (test/neg-blame
+   '->r18
+   '((contract (->r ([x number?] [y (<=/c x)]) rest any/c (<=/c x)) (lambda (x y . z) (+ x 1)) 'pos 'neg) 1 2))
+  
+  (test/spec-passed
+   '->r19
+   '((contract (->r ([y (<=/c x)] [x number?]) rest any/c (<=/c x)) (lambda (y x . z) (- x 1)) 'pos 'neg) 1 2))
+  
+  (test/neg-blame
+   '->r20
+   '((contract (->r ([y (<=/c x)] [x number?]) rest any/c (<=/c x)) (lambda (y x . z) (+ x 1)) 'pos 'neg) 1 0))
+
+  (test/spec-passed
+   '->r21
+   '((contract (->r () rst (listof number?) any/c) (lambda w 1) 'pos 'neg) 1))
+  
+  (test/neg-blame
+   '->r22
+   '((contract (->r () rst (listof number?) any/c) (lambda w 1) 'pos 'neg) #f))
+  
+  (test/spec-passed
+   '->r-any1
+   '((contract (->r () any) (lambda () 1) 'pos 'neg)))
+  
+  (test/spec-passed
+   '->r-any2
+   '((contract (->r ([x number?]) any) (lambda (x) (+ x 1)) 'pos 'neg) 1))
+
+  (test/pos-blame
+   '->r-any3
+   '((contract (->r () any) 1 'pos 'neg)))
+  
+  (test/pos-blame
+   '->r-any4
+   '((contract (->r () any) (lambda (x) x) 'pos 'neg)))
+  
+  (test/neg-blame
+   '->r-any5
+   '((contract (->r ([x number?]) any) (lambda (x) (+ x 1)) 'pos 'neg) #f))
+  
+  (test/spec-passed
+   '->r-any6
+   '((contract (->r ([x number?] [y (<=/c x)]) any) (lambda (x y) (- x 1)) 'pos 'neg) 1 0))
+  
+  (test/neg-blame
+   '->r-any7
+   '((contract (->r ([x number?] [y (<=/c x)]) any) (lambda (x y) (+ x 1)) 'pos 'neg) 1 2))
+  
+  (test/spec-passed
+   '->r-any8
+   '((contract (->r ([y (<=/c x)] [x number?]) any) (lambda (y x) (- x 1)) 'pos 'neg) 1 2))
+  
+  (test/neg-blame
+   '->r-any9
+   '((contract (->r ([y (<=/c x)] [x number?]) any) (lambda (y x) (+ x 1)) 'pos 'neg) 1 0))
+  
+  (test/spec-passed
+   '->r-any10
+   '((contract (->r () rest any/c any) (lambda x 1) 'pos 'neg)))
+  
+  (test/spec-passed
+   '->r-any11
+   '((contract (->r ([x number?]) rest any/c any) (lambda (x . y) (+ x 1)) 'pos 'neg) 1))
+
+  (test/pos-blame
+   '->r-any12
+   '((contract (->r () rest any/c any) 1 'pos 'neg)))
+  
+  (test/pos-blame
+   '->r-any13
+   '((contract (->r () rest any/c any) (lambda (x) x) 'pos 'neg)))
+  
+  (test/neg-blame
+   '->r-any14
+   '((contract (->r ([x number?]) rest any/c any) (lambda (x . y) (+ x 1)) 'pos 'neg) #f))
+  
+  (test/spec-passed
+   '->r-any15
+   '((contract (->r ([x number?] [y (<=/c x)]) rest any/c any) (lambda (x y . z) (- x 1)) 'pos 'neg) 1 0))
+  
+  (test/neg-blame
+   '->r-any16
+   '((contract (->r ([x number?] [y (<=/c x)]) rest any/c any) (lambda (x y . z) (+ x 1)) 'pos 'neg) 1 2))
+  
+  (test/spec-passed
+   '->r-any17
+   '((contract (->r ([y (<=/c x)] [x number?]) rest any/c any) (lambda (y x . z) (- x 1)) 'pos 'neg) 1 2))
+  
+  (test/neg-blame
+   '->r-any18
+   '((contract (->r ([y (<=/c x)] [x number?]) rest any/c any) (lambda (y x . z) (+ x 1)) 'pos 'neg) 1 0))
+
+  (test/spec-passed
+   '->r-any19
+   '((contract (->r () rst (listof number?) any) (lambda w 1) 'pos 'neg) 1))
+  
+  (test/neg-blame
+   '->r-any20
+   '((contract (->r () rst (listof number?) any) (lambda w 1) 'pos 'neg) #f))
+  
+  (test/spec-passed
+   '->r-values1
+   '((contract (->r () (values [x boolean?] [y number?])) (lambda () (values #t 1)) 'pos 'neg)))
+  
+  (test/spec-passed
+   '->r-values2
+   '((contract (->r ([x number?]) (values [x boolean?] [y number?])) (lambda (x) (values #t (+ x 1))) 'pos 'neg) 1))
+
+  (test/pos-blame
+   '->r-values3
+   '((contract (->r () (values [x boolean?] [y number?])) 1 'pos 'neg)))
+  
+  (test/pos-blame
+   '->r-values4
+   '((contract (->r () (values [x boolean?] [y number?])) (lambda (x) x) 'pos 'neg)))
+  
+  (test/neg-blame
+   '->r-values5
+   '((contract (->r ([x number?]) (values [y boolean?] [z (<=/c x)])) (lambda (x) (+ x 1)) 'pos 'neg) #f))
+  
+  (test/pos-blame
+   '->r-values6
+   '((contract (->r ([x number?]) (values [y boolean?] [z (<=/c x)])) (lambda (x) (values #t (+ x 1))) 'pos 'neg) 1))
+  
+  (test/spec-passed
+   '->r-values7
+   '((contract (->r ([x number?] [y (<=/c x)]) (values [z boolean?] [w (<=/c x)])) 
+               (lambda (x y) (values #t (- x 1)))
+               'pos
+               'neg) 
+     1
+     0))
+  
+  (test/neg-blame
+   '->r-values8
+   '((contract (->r ([x number?] [y (<=/c x)]) (values [z boolean?] [w (<=/c x)])) 
+               (lambda (x y) (values #f (+ x 1)))
+               'pos
+               'neg)
+     1
+     2))
+  
+  (test/spec-passed
+   '->r-values9
+   '((contract (->r ([y (<=/c x)] [x number?]) (values [z boolean?] [w (<=/c x)]))
+               (lambda (y x) (values #f (- x 1)))
+               'pos 
+               'neg)
+     1
+     2))
+  
+  (test/neg-blame
+   '->r-values10
+   '((contract (->r ([y (<=/c x)] [x number?]) (values [z boolean?] [w (<=/c x)]))
+               (lambda (y x) (values #f (+ x 1))) 'pos 'neg)
+     1 0))
+  
+  (test/spec-passed
+   '->r-values11
+   '((contract (->r () rest any/c (values [z boolean?] [w number?])) (lambda x (values #f 1)) 'pos 'neg)))
+  
+  (test/spec-passed
+   '->r-values12
+   '((contract (->r ([x number?]) rest any/c (values [z boolean?] [w number?]))
+               (lambda (x . y) (values #f (+ x 1)))
+               'pos 
+               'neg)
+     1))
+
+  (test/pos-blame
+   '->r-values13
+   '((contract (->r () rest any/c (values [z boolean?] [w number?])) 1 'pos 'neg)))
+  
+  (test/pos-blame
+   '->r-values14
+   '((contract (->r () rest any/c (values [z boolean?] [w number?])) (lambda (x) x) 'pos 'neg)))
+  
+  (test/neg-blame
+   '->r-values15
+   '((contract (->r ([x number?]) rest any/c  (values [z boolean?] [w (<=/c x)]))
+               (lambda (x . y) (+ x 1)) 'pos 'neg)
+     #f))
+  
+  (test/pos-blame
+   '->r-values16
+   '((contract (->r ([x number?]) rest any/c (values [z boolean?] [w (<=/c x)]))
+               (lambda (x . y) (values #f (+ x 1))) 'pos 'neg) 
+     1))
+  
+  (test/spec-passed
+   '->r-values17
+   '((contract (->r ([x number?] [y (<=/c x)]) rest any/c (values [z boolean?] [w (<=/c x)]))
+               (lambda (x y . z) (values #f (- x 1))) 'pos 'neg) 
+     1 0))
+  
+  (test/neg-blame
+   '->r-values18
+   '((contract (->r ([x number?] [y (<=/c x)]) rest any/c (values [z boolean?] [w (<=/c x)]))
+               (lambda (x y . z) (values #f (+ x 1))) 'pos 'neg) 
+     1 2))
+  
+  (test/spec-passed
+   '->r-values19
+   '((contract (->r ([y (<=/c x)] [x number?]) rest any/c  (values [z boolean?] [w (<=/c x)]))
+               (lambda (y x . z) (values #f (- x 1))) 'pos 'neg)
+     1 2))
+  
+  (test/neg-blame
+   '->r-values20
+   '((contract (->r ([y (<=/c x)] [x number?]) rest any/c  (values [z boolean?] [w (<=/c x)]))
+               (lambda (y x . z) (values #f (+ x 1))) 'pos 'neg) 
+     1 0))
+
+  (test/spec-passed
+   '->r-values21
+   '((contract (->r () rst (listof number?) (values [z boolean?] [w any/c])) (lambda w (values #f 1)) 'pos 'neg) 1))
+  
+  (test/neg-blame
+   '->r-values22
+   '((contract (->r () rst (listof number?) (values [z boolean?] [w any/c])) (lambda w (values #f 1)) 'pos 'neg) #f))
+
+  (test/spec-passed
+   '->r-values23
+   '((contract (->r () (values [x number?] [y (>=/c x)])) (lambda () (values 1 2)) 'pos 'neg)))
+  
+  (test/pos-blame
+   '->r-values24
+   '((contract (->r () (values [x number?] [y (>=/c x)])) (lambda () (values 2 1)) 'pos 'neg)))
+
+  (test/spec-passed
+   '->r-values25
+   '((contract (->r ([x number?]) (values [z number?] [y (>=/c x)])) (lambda (x) (values 1 2)) 'pos 'neg) 1))
+  
+  (test/pos-blame
+   '->r-values26
+   '((contract (->r ([x number?]) (values [z number?] [y (>=/c x)])) (lambda (x) (values 2 1)) 'pos 'neg) 4))
+
+
+    
+  (test/spec-passed
+   '->r1
+   '((contract (->r () number?) (lambda () 1) 'pos 'neg)))
+  
+  (test/spec-passed
+   '->r2
+   '((contract (->r ([x number?]) number?) (lambda (x) (+ x 1)) 'pos 'neg) 1))
+
+  (test/pos-blame
+   '->r3
+   '((contract (->r () number?) 1 'pos 'neg)))
+  
+  (test/pos-blame
+   '->r4
+   '((contract (->r () number?) (lambda (x) x) 'pos 'neg)))
+  
+  (test/neg-blame
+   '->r5
+   '((contract (->r ([x number?]) (<=/c x)) (lambda (x) (+ x 1)) 'pos 'neg) #f))
+  
+  (test/pos-blame
+   '->r6
+   '((contract (->r ([x number?]) (<=/c x)) (lambda (x) (+ x 1)) 'pos 'neg) 1))
+  
+  (test/spec-passed
+   '->r7
+   '((contract (->r ([x number?] [y (<=/c x)]) (<=/c x)) (lambda (x y) (- x 1)) 'pos 'neg) 1 0))
+  
+  (test/neg-blame
+   '->r8
+   '((contract (->r ([x number?] [y (<=/c x)]) (<=/c x)) (lambda (x y) (+ x 1)) 'pos 'neg) 1 2))
+  
+  (test/spec-passed
+   '->r9
+   '((contract (->r ([y (<=/c x)] [x number?]) (<=/c x)) (lambda (y x) (- x 1)) 'pos 'neg) 1 2))
+  
+  (test/neg-blame
+   '->r10
+   '((contract (->r ([y (<=/c x)] [x number?]) (<=/c x)) (lambda (y x) (+ x 1)) 'pos 'neg) 1 0))
+  
+  (test/spec-passed
+   '->r11
+   '((contract (->r () rest any/c number?) (lambda x 1) 'pos 'neg)))
+  
+  (test/spec-passed
+   '->r12
+   '((contract (->r ([x number?]) rest any/c number?) (lambda (x . y) (+ x 1)) 'pos 'neg) 1))
+
+  (test/pos-blame
+   '->r13
+   '((contract (->r () rest any/c number?) 1 'pos 'neg)))
+  
+  (test/pos-blame
+   '->r14
+   '((contract (->r () rest any/c number?) (lambda (x) x) 'pos 'neg)))
+  
+  (test/neg-blame
+   '->r15
+   '((contract (->r ([x number?]) rest any/c (<=/c x)) (lambda (x . y) (+ x 1)) 'pos 'neg) #f))
+  
+  (test/pos-blame
+   '->r16
+   '((contract (->r ([x number?]) rest any/c (<=/c x)) (lambda (x . y) (+ x 1)) 'pos 'neg) 1))
+  
+  (test/spec-passed
+   '->r17
+   '((contract (->r ([x number?] [y (<=/c x)]) rest any/c (<=/c x)) (lambda (x y . z) (- x 1)) 'pos 'neg) 1 0))
+  
+  (test/neg-blame
+   '->r18
+   '((contract (->r ([x number?] [y (<=/c x)]) rest any/c (<=/c x)) (lambda (x y . z) (+ x 1)) 'pos 'neg) 1 2))
+  
+  (test/spec-passed
+   '->r19
+   '((contract (->r ([y (<=/c x)] [x number?]) rest any/c (<=/c x)) (lambda (y x . z) (- x 1)) 'pos 'neg) 1 2))
+  
+  (test/neg-blame
+   '->r20
+   '((contract (->r ([y (<=/c x)] [x number?]) rest any/c (<=/c x)) (lambda (y x . z) (+ x 1)) 'pos 'neg) 1 0))
+
+  (test/spec-passed
+   '->r21
+   '((contract (->r () rst (listof number?) any/c) (lambda w 1) 'pos 'neg) 1))
+  
+  (test/neg-blame
+   '->r22
+   '((contract (->r () rst (listof number?) any/c) (lambda w 1) 'pos 'neg) #f))
+
+  
+  (test/spec-passed/result
+   '->r23
+   '((contract (->r ((i number?) (j (and/c number? (>=/c i)))) number?)
+               (λ (i j) 1)
+               'pos
+               'neg)
+     1
+     2)
+   1)
+
+  (test/spec-passed/result
+   '->r24
+   '((contract (->r ((i number?) (j (and/c number? (>=/c i)))) any)
+               (λ (i j) 1)
+               'pos
+               'neg)
+     1
+     2)
+   1)
+
+  (test/spec-passed/result
+   '->r25
+   '(call-with-values
+    (λ ()
+      ((contract (->r ((i number?) (j (and/c number? (>=/c i)))) (values [x number?] [y number?]))
+                 (λ (i j) (values 1 2))
+                 'pos
+                 'neg)
+       1
+       2))
+    list)
+   '(1 2))
+
+  (test/spec-passed/result
+   '->r26
+   '((contract (->r ((i number?) (j (and/c number? (>=/c i)))) rest-args any/c number?)
+               (λ (i j . z) 1)
+               'pos
+               'neg)
+     1
+     2)
+   1)
+
+  (test/spec-passed/result
+   '->r27
+   '((contract (->r ((i number?) (j (and/c number? (>=/c i)))) rest-args any/c any)
+               (λ (i j . z) 1)
+               'pos
+               'neg)
+     1
+     2)
+   1)
+
+(test/spec-passed/result
+ '->r28
+ '(call-with-values
+   (λ ()
+     ((contract (->r ((i number?) (j (and/c number? (>=/c i)))) rest-args any/c (values [x number?] [y number?]))
+                (λ (i j . z) (values 1 2))
+                'pos
+                'neg)
+      1
+      2))
+   list)
+ '(1 2))
+
+  
+  (test/pos-blame
+   '->pp1
+   '((contract (->pp ([x number?]) (= x 1) number? result (= x 2))
+               (λ (x) x)
+               'pos
+               'neg)
+     1))
+  
+  (test/neg-blame
+   '->pp2
+   '((contract (->pp ([x number?]) (= x 1) number? result (= x 2))
+               (λ (x) x)
+               'pos
+               'neg)
+     2))
+  
+  (test/pos-blame
+   '->pp3
+   '((contract (->pp ([x number?]) (= x 1) number? result (= result 2))
+               (λ (x) x)
+               'pos
+               'neg)
+     1))
+  
+  (test/spec-passed
+   '->pp3.5
+   '((contract (->pp ([x number?]) (= x 1) number? result (= result 2))
+               (λ (x) 2)
+               'pos
+               'neg)
+     1))
+  
+  (test/neg-blame
+   '->pp4
+   '((contract (->pp ([x number?]) (= x 1) any)
+               (λ (x) x)
+               'pos
+               'neg)
+     2))
+  
+  (test/neg-blame
+   '->pp5
+   '((contract (->pp ([x number?]) (= x 1) (values [x number?] [y number?]) (= x y 3))
+               (λ (x) (values 4 5))
+               'pos
+               'neg)
+     2))
+  
+  (test/pos-blame
+   '->pp6
+   '((contract (->pp ([x number?]) (= x 1) (values [x number?] [y number?]) (= x y 3))
+               (λ (x) (values 4 5))
+               'pos
+               'neg)
+     1))
+
+  (test/pos-blame
+   '->pp-r1
+   '((contract (->pp-rest ([x number?]) rst any/c (= x 1) number? result (= x 2))
+               (λ (x . rst) x)
+               'pos
+               'neg)
+     1))
+  
+  (test/neg-blame
+   '->pp-r2
+   '((contract (->pp-rest ([x number?]) rst any/c (= x 1)  number? result (= x 2))
+               (λ (x . rst) x)
+               'pos
+               'neg)
+     2))
+  
+  (test/pos-blame
+   '->pp-r3
+   '((contract (->pp-rest ([x number?]) rst any/c (= x 1) number? result (= result 2))
+               (λ (x . rst) x)
+               'pos
+               'neg)
+     1))
+  
+  (test/spec-passed
+   '->pp-r3.5
+   '((contract (->pp-rest ([x number?]) rst any/c (= x 1) number? result (= result 2))
+               (λ (x . rst) 2)
+               'pos
+               'neg)
+     1))
+  
+  (test/neg-blame
+   '->pp-r4
+   '((contract (->pp-rest ([x number?]) rst any/c (= x 1) any)
+               (λ (x . rst) x)
+               'pos
+               'neg)
+     2))
+  
+  (test/neg-blame
+   '->pp-r5
+   '((contract (->pp-rest ([x number?]) rst any/c (= x 1) (values [x number?] [y number?]) (= x y 3))
+               (λ (x . rst) (values 4 5))
+               'pos
+               'neg)
+     2))
+  
+  (test/pos-blame
+   '->pp-r6
+   '((contract (->pp-rest ([x number?]) rst any/c (= x 1) (values [x number?] [y number?]) (= x y 3))
+               (λ (x . rst) (values 4 5))
+               'pos
+               'neg)
+     1))
+  
+  (test/pos-blame
+   'contract-case->1
+   '(contract (case-> (integer? integer? . -> . integer?) (integer? . -> . integer?))
+              (lambda (x) x)
+              'pos
+              'neg))
+  
+  (test/pos-blame
+   'contract-case->2
+   '((contract (case-> (integer? integer? . -> . integer?) (integer? . -> . integer?))
+               (case-lambda 
+                 [(x y) 'case1]
+                 [(x) 'case2])
+               'pos
+               'neg)
+     1 2))
+  
+  (test/pos-blame
+   'contract-case->3
+   '((contract (case-> (integer? integer? . -> . integer?) (integer? . -> . integer?))
+               (case-lambda 
+                 [(x y) 'case1]
+                 [(x) 'case2])
+               'pos
+               'neg)
+     1))
+  
+  (test/neg-blame
+   'contract-case->4
+   '((contract (case-> (integer? integer? . -> . integer?) (integer? . -> . integer?))
+               (case-lambda 
+                 [(x y) 'case1]
+                 [(x) 'case2])
+               'pos
+               'neg)
+     'a 2))
+  
+  (test/neg-blame
+   'contract-case->5
+   '((contract (case-> (integer? integer? . -> . integer?) (integer? . -> . integer?))
+               (case-lambda 
+                 [(x y) 'case1]
+                 [(x) 'case2])
+               'pos
+               'neg)
+     2 'a))
+  
+  (test/neg-blame
+   'contract-case->6
+   '((contract (case-> (integer? integer? . -> . integer?) (integer? . -> . integer?))
+               (case-lambda 
+                 [(x y) 'case1]
+                 [(x) 'case2])
+               'pos
+               'neg)
+     #t))
+  
+  (test/pos-blame
+   'contract-case->7
+   '((contract (case-> (integer? integer? . -> . integer?) (->* (integer?) any/c (boolean?)))
+               (lambda x #\a)
+               'pos
+               'neg)
+     1 2))
+  
+  (test/pos-blame
+   'contract-case->8
+   '((contract (case-> (integer? integer? . -> . integer?) (->* (integer?) any/c (boolean?)))
+               (lambda x #t)
+               'pos
+               'neg)
+     1 2))
+ 
+  (test/spec-passed
+   'contract-case->8
+   '((contract (case-> (integer? integer? . -> . integer?) (->* (integer?) any/c (boolean?)))
+               (lambda x 1)
+               'pos
+               'neg)
+     1 2))
+  
+  (test/spec-passed
+   'contract-case->9
+   '((contract (case-> (->r ([x number?]) (<=/c x)))
+               (lambda (x) (- x 1))
+               'pos
+               'neg)
+     1))
+  
+  (test/pos-blame 
+   'contract-case->10
+   '((contract (case-> (->r ([x number?]) (<=/c x)))
+               (lambda (x) (+ x 1))
+               'pos
+               'neg)
+     1))
+ 
+  (test/neg-blame
+   'contract-d-protect-shared-state
+   '(let ([x 1])
+      ((contract ((->d (lambda () (let ([pre-x x]) (lambda (res) (= x pre-x)))))
+                  . -> .
+                  (lambda (x) #t))
+                 (lambda (thnk) (thnk))
+                 'pos
+                 'neg)
+       (lambda () (set! x 2)))))
+  
+  #;
+  (test/neg-blame
+   'combo1
+   '(let ([cf (contract (case->
+                         ((class? . ->d . (lambda (%) (lambda (x) #f))) . -> . void?)
+                         ((class? . ->d . (lambda (%) (lambda (x) #f))) boolean? . -> . void?))
+                        (letrec ([c% (class object% (super-instantiate ()))]
+                                 [f
+                                  (case-lambda
+                                    [(class-maker) (f class-maker #t)]
+                                    [(class-maker b) 
+                                     (class-maker c%)
+                                     (void)])])
+                          f)
+                        'pos
+                        'neg)])
+      (cf (lambda (x%) 'going-to-be-bad))))   
+
+  (test/pos-blame
+   'union1
+   '(contract (union false/c) #t 'pos 'neg))
+
+  (test/spec-passed
+   'union2
+   '(contract (union false/c) #f 'pos 'neg))
+
+  (test/spec-passed
+   'union3
+   '((contract (union (-> integer? integer?)) (lambda (x) x) 'pos 'neg) 1))
+  
+  (test/neg-blame
+   'union4
+   '((contract (union (-> integer? integer?)) (lambda (x) x) 'pos 'neg) #f))
+  
+  (test/pos-blame
+   'union5
+   '((contract (union (-> integer? integer?)) (lambda (x) #f) 'pos 'neg) 1))
+  
+  (test/spec-passed
+   'union6
+   '(contract (union false/c (-> integer? integer?)) #f 'pos 'neg))
+  
+  (test/spec-passed
+   'union7
+   '((contract (union false/c (-> integer? integer?)) (lambda (x) x) 'pos 'neg) 1))
+
+  (test/spec-passed
+   'define/contract1
+   '(let ()
+      (define/contract i integer? 1)
+      i))
+  
+  (test/spec-failed
+   'define/contract2
+   '(let ()
+      (define/contract i integer? #t)
+      i)
+   "i")
+  
+  (test/spec-failed
+   'define/contract3
+   '(let ()
+      (define/contract i (-> integer? integer?) (lambda (x) #t))
+      (i 1))
+   "i")
+  
+  (test/spec-failed
+   'define/contract4
+   '(let ()
+      (define/contract i (-> integer? integer?) (lambda (x) 1))
+      (i #f))
+   "")
+  
+  (test/spec-failed
+   'define/contract5
+   '(let ()
+      (define/contract i (-> integer? integer?) (lambda (x) (i #t)))
+      (i 1))
+   "")
+  
+  (test/spec-passed
+   'define/contract6
+   '(let ()
+      (define/contract contracted-func
+                       (string?  string? . -> . string?)
+                       (lambda (label t)
+                         t))
+      (contracted-func
+       "I'm a string constant with side effects"
+       "ans")))
+
+  (test/spec-passed
+   'define/contract7
+   '(let ()
+      (eval '(module contract-test-suite-define1 mzscheme
+               (require (lib "contract.ss"))
+               (define/contract x string? "a")
+               x))
+      (eval '(require contract-test-suite-define1))))
+  
+  (test/spec-passed
+   'provide/contract1
+   '(let ()
+      (eval '(module contract-test-suite1 mzscheme
+               (require (lib "contract.ss"))
+               (provide/contract (x integer?))
+               (define x 1)))
+      (eval '(require contract-test-suite1))
+      (eval 'x)))
+  
+  (test/spec-passed
+   'provide/contract2
+   '(let ()
+      (eval '(module contract-test-suite2 mzscheme
+               (require (lib "contract.ss"))
+               (provide/contract)))
+      (eval '(require contract-test-suite2))))
+  
+  (test/spec-failed
+   'provide/contract3
+   '(let ()
+      (eval '(module contract-test-suite3 mzscheme
+               (require (lib "contract.ss"))
+               (provide/contract (x integer?))
+               (define x #f)))
+      (eval '(require contract-test-suite3))
+      (eval 'x))
+   "contract-test-suite3")
+  
+  (test/spec-passed
+   'provide/contract4
+   '(let ()
+      (eval '(module contract-test-suite4 mzscheme
+               (require (lib "contract.ss"))
+               (provide/contract (struct s ((a any/c))))
+               (define-struct s (a))))
+      (eval '(require contract-test-suite4))
+      (eval '(list (make-s 1)
+                   (s-a (make-s 1))
+                   (s? (make-s 1))
+                   (set-s-a! (make-s 1) 2)))))
+  
+  (test/spec-passed
+   'provide/contract5
+   '(let ()
+      (eval '(module contract-test-suite5 mzscheme
+               (require (lib "contract.ss"))
+               (provide/contract (struct s ((a any/c)))
+                                 (struct t ((a any/c))))
+               (define-struct s (a))
+               (define-struct t (a))))
+      (eval '(require contract-test-suite5))
+      (eval '(list (make-s 1)
+                   (s-a (make-s 1))
+                   (s? (make-s 1))
+                   (set-s-a! (make-s 1) 2)
+                   (make-t 1)
+                   (t-a (make-t 1))
+                   (t? (make-t 1))
+                   (set-t-a! (make-t 1) 2)))))
+  
+  (test/spec-passed
+   'provide/contract6
+   '(let ()
+      (eval '(module contract-test-suite6 mzscheme
+               (require (lib "contract.ss"))
+               (provide/contract (struct s ((a any/c))))
+               (define-struct s (a))))
+      (eval '(require contract-test-suite6))
+      (eval '(define-struct (t s) ()))))
+  
+  (test/spec-passed
+   'provide/contract7
+   '(let ()
+      (eval '(module contract-test-suite7 mzscheme
+               (require (lib "contract.ss"))
+               (define-struct s (a b))
+               (define-struct (t s) (c d))
+               (provide/contract 
+                (struct s ((a any/c) (b any/c)))
+                (struct (t s) ((a any/c) (b any/c) (c any/c) (d any/c))))))
+      (eval '(require contract-test-suite7))
+      (eval '(let ([x (make-t 1 2 3 4)])
+               (s-a x)
+               (s-b x)
+               (t-c x)
+               (t-d x)
+               (void)))))
+  
+  (test/spec-passed
+   'provide/contract8
+   '(let ()
+      (eval '(module contract-test-suite8 mzscheme
+               (require (lib "contract.ss"))
+               (define-struct i-s (contents))
+               (define (w-f-s? x) #t)
+               (provide/contract 
+                (struct i-s ((contents (flat-named-contract "integer-set-list" w-f-s?)))))))
+      (eval '(require contract-test-suite8))
+      (eval '(i-s-contents (make-i-s 1)))))
+   
+  (test/spec-passed
+   'provide/contract8
+   '(let ()
+      (eval '(module contract-test-suite8 mzscheme
+               (require (lib "contract.ss"))
+               (provide/contract (rename the-internal-name the-external-name integer?))
+               (define the-internal-name 1)
+               (+ the-internal-name 1)))
+      (eval '(require contract-test-suite8))
+      (eval '(+ the-external-name 1))))
+
+  
+;                                                                                                     
+;                                                                                                     
+;                                                                                                     
+;           ;       ;                                                                                 
+;           ;                                                                                         
+;           ;                         ;                                   ;                       ;   
+;    ;;;    ; ;;    ;    ;;;    ;;;  ;;;;           ;;;    ;;;    ; ;;   ;;;;  ; ;  ;;;     ;;;  ;;;; 
+;   ;   ;   ;;  ;   ;   ;   ;  ;   ;  ;            ;   ;  ;   ;   ;;  ;   ;    ;;  ;   ;   ;   ;  ;   
+;  ;     ;  ;    ;  ;  ;    ; ;       ;           ;      ;     ;  ;   ;   ;    ;       ;  ;       ;   
+;  ;     ;  ;    ;  ;  ;;;;;; ;       ;    ;;;;;; ;      ;     ;  ;   ;   ;    ;    ;;;;  ;       ;   
+;  ;     ;  ;    ;  ;  ;      ;       ;           ;      ;     ;  ;   ;   ;    ;   ;   ;  ;       ;   
+;   ;   ;   ;;  ;   ;   ;      ;   ;  ;            ;   ;  ;   ;   ;   ;   ;    ;   ;   ;   ;   ;  ;   
+;    ;;;    ; ;;    ;    ;;;;   ;;;    ;;           ;;;    ;;;    ;   ;    ;;  ;    ;;;;;   ;;;    ;; 
+;                   ;                                                                                 
+;                   ;                                                                                 
+;                 ;;                                                                                  
+
+  
+  (test/spec-passed
+   'object-contract0
+   '(contract (object-contract)
+              (new object%)
+              'pos
+              'neg))
+
+  (test/pos-blame
+   'object-contract/field1
+   '(contract (object-contract (field x integer?))
+              (new object%)
+              'pos
+              'neg))
+  
+  (test/pos-blame
+   'object-contract/field2
+   '(contract (object-contract (field x integer?))
+              (new (class object% (field [x #t]) (super-new)))
+              'pos
+              'neg))
+  
+  (test/spec-passed/result
+   'object-contract/field3
+   '(get-field
+     x
+     (contract (object-contract (field x integer?))
+               (new (class object% (field [x 12]) (super-new)))
+               'pos
+               'neg))
+   12)
+  
+  (test/pos-blame
+   'object-contract/field4
+   '(contract (object-contract (field x boolean?) (field y boolean?))
+              (new (class object% (field [x #t] [y 'x]) (super-new)))
+              'pos
+              'neg))
+  
+  (test/pos-blame
+   'object-contract/field5
+   '(contract (object-contract (field x symbol?) (field y symbol?))
+              (new (class object% (field [x #t] [y 'x]) (super-new)))
+              'pos
+              'neg))
+  
+  (test/spec-passed/result
+   'object-contract/field6
+   '(let ([o (contract (object-contract [m (integer? . -> . integer?)])
+                       (new (class object% (field [x 1]) (define/public (m y) x) (super-new)))
+                       'pos
+                       'neg)])
+      (list (send o m 2)
+            (send/apply o m '(2))
+            (let ([x '(2)]) (send o m . x))
+            (with-method ([mm (o m)])
+              (mm 2))
+            (send* o (m 3) (m 4))))
+   (list 1 1 1 1 1))
+  
+  (test/spec-passed/result
+   'object-contract/field7
+   '(let ([o (contract (object-contract)
+                       (new (class object% (field [x 1]) (define/public (m y) x) (super-new)))
+                       'pos
+                       'neg)])
+      (list (send o m 2)
+            (send/apply o m '(2))
+            (let ([x '(2)]) (send o m . x))
+            (with-method ([mm (o m)])
+              (mm 2))
+            (send* o (m 3) (m 4))))
+   (list 1 1 1 1 1))
+  
+  (test/spec-passed/result
+   'object-contract/field8
+   '(let ([o (contract (object-contract [m (integer? . -> . integer?)])
+                       (new (class object% (define x 6) (define/public (m y) x) (super-new)))
+                       'pos
+                       'neg)])
+      (list (send o m 2)
+            (send/apply o m '(2))
+            (let ([x '(2)]) (send o m . x))
+            (with-method ([mm (o m)])
+              (mm 2))
+            (send* o (m 3) (m 4))))
+   (list 6 6 6 6 6))
+  
+  (test/spec-passed/result
+   'object-contract/field9
+   '(let ([o (contract (object-contract)
+                       (new (class object% (define x 6) (define/public (m y) x) (super-new)))
+                       'pos
+                       'neg)])
+      (list (send o m 2)
+            (send/apply o m '(2))
+            (let ([x '(2)]) (send o m . x))
+            (with-method ([mm (o m)])
+              (mm 2))
+            (send* o (m 3) (m 4))))
+   (list 6 6 6 6 6))
+  
+  (test/spec-passed/result
+   'object-contract/field10
+   '(send (contract (object-contract)
+                    (new (class object% (define x 1) (define/public (m y) x) (super-new)))
+                    'pos
+                    'neg)
+          m
+          2)
+   1)
+  
+  (test/spec-passed/result
+   'object-contract->1
+   '(send
+     (contract (object-contract (m (integer? . -> . integer?)))
+               (new (class object% (define/public (m x) x) (super-new)))
+               'pos
+               'neg)
+     m
+     1)
+   1)
+  
+  (test/pos-blame
+   'object-contract->2
+   '(contract (object-contract (m (integer? . -> . integer?)))
+              (make-object object%)
+              'pos
+              'neg))
+  
+  (test/neg-blame
+   'object-contract->3
+   '(send
+     (contract (object-contract (m (integer? . -> . integer?)))
+               (make-object (class object% (define/public (m x) x) (super-instantiate ())))
+               'pos
+               'neg)
+     m
+     'x))
+  
+  (test/pos-blame
+   'object-contract->4
+   '(send
+     (contract (object-contract (m (integer? . -> . integer?)))
+               (make-object (class object% (define/public (m x) 'x) (super-instantiate ())))
+               'pos
+               'neg)
+     m
+     1))
+  
+  (test/pos-blame
+   'object-contract->5
+   '(contract (object-contract (m (integer? integer? . -> . integer?)))
+              (make-object (class object% (define/public (m x) 'x) (super-instantiate ())))
+              'pos
+              'neg))
+
+  (test/spec-passed/result
+   'object-contract->6
+   '(send
+     (contract (object-contract (m (integer? . -> . any)))
+               (new (class object% (define/public (m x) x) (super-new)))
+               'pos
+               'neg)
+     m
+     1)
+   1)
+  
+  (test/neg-blame
+   'object-contract->7
+   '(send
+     (contract (object-contract (m (integer? . -> . any)))
+               (make-object (class object% (define/public (m x) x) (super-instantiate ())))
+               'pos
+               'neg)
+     m
+     'x))
+  
+  (test/spec-passed
+   'object-contract->8
+   '(begin
+      (send
+       (contract (object-contract (m (integer? . -> . any)))
+                 (make-object (class object% (define/public (m x) (values 1 2)) (super-instantiate ())))
+                 'pos
+                 'neg)
+       m
+       1)
+      (void)))
+  
+  (test/spec-passed
+   'object-contract->9
+   '(begin
+      (send
+       (contract (object-contract (m (integer? . -> . any)))
+                 (make-object (class object% (define/public (m x) (values)) (super-instantiate ())))
+                 'pos
+                 'neg)
+       m
+       1)
+      (void)))
+  
+  (test/spec-passed
+   'object-contract->10
+   '(begin
+      (send (contract (object-contract (m (integer? . -> . (values integer? boolean?))))
+                      (make-object (class object% (define/public (m x) (values 1 #t)) (super-instantiate ())))
+                      'pos
+                      'neg)
+            m 1)
+      (void)))
+  
+  (test/neg-blame
+   'object-contract->11
+   '(send 
+     (contract (object-contract (m (integer? . -> . (values integer? boolean?))))
+               (make-object (class object% (define/public (m x) (values #t #t)) (super-instantiate ())))
+               'pos
+               'neg)
+     m
+     #f))
+  
+  (test/pos-blame
+   'object-contract->12
+   '(send 
+     (contract (object-contract (m (integer? . -> . (values integer? boolean?))))
+               (make-object (class object% (define/public (m x) (values #t #t)) (super-instantiate ())))
+               'pos
+               'neg)
+     m
+     1))
+  
+  (test/pos-blame
+   'object-contract->13
+   '(send (contract (object-contract (m (integer? . -> . (values integer? boolean?))))
+                    (make-object (class object% (define/public (m x) (values #f #t)) (super-instantiate ())))
+                    'pos
+                    'neg)
+          m 1))
+  
+  (test/pos-blame
+   'object-contract->14
+   '(send (contract (object-contract (m (integer? . -> . (values integer? boolean?))))
+                    (make-object (class object% (define/public (m x) (values 5 6)) (super-instantiate ())))
+                    'pos
+                    'neg)
+          m 1))
+  
+  (test/pos-blame
+   'object-contract-case->1
+   '(contract (object-contract (m (case-> (boolean? . -> . boolean?)
+                                          (integer? integer? . -> . integer?))))
+              (new object%)
+              'pos
+              'neg))
+  
+  (test/pos-blame
+   'object-contract-case->2
+   '(contract (object-contract (m (case-> (boolean? . -> . boolean?)
+                                          (integer? integer? . -> . integer?))))
+              (new (class object% (define/public (m x) x) (super-new)))
+              'pos
+              'neg))
+  
+  (test/pos-blame
+   'object-contract-case->3
+   '(contract (object-contract (m (case-> (boolean? . -> . boolean?)
+                                          (integer? integer? . -> . integer?))))
+              (new (class object% (define/public (m x y) x) (super-new)))
+              'pos
+              'neg))
+  
+  (test/spec-passed
+   'object-contract-case->4
+   '(contract (object-contract (m (case-> (boolean? . -> . boolean?)
+                                          (integer? integer? . -> . integer?))))
+              (new (class object% 
+                     (define/public m
+                       (case-lambda
+                         [(b) (not b)]
+                         [(x y) (+ x y)]))
+                     (super-new)))
+              'pos
+              'neg))
+  
+  (test/spec-passed/result
+   'object-contract-case->5
+   '(send (contract (object-contract (m (case-> (boolean? . -> . boolean?)
+                                                (integer? integer? . -> . integer?))))
+                    (new (class object% 
+                           (define/public m
+                             (case-lambda
+                               [(b) (not b)]
+                               [(x y) (+ x y)]))
+                           (super-new)))
+                    'pos
+                    'neg)
+          m 
+          #t)
+   #f)
+  
+  (test/spec-passed/result
+   'object-contract-case->6
+   '(send (contract (object-contract (m (case-> (boolean? . -> . boolean?)
+                                                (integer? integer? . -> . integer?))))
+                    (new (class object% 
+                           (define/public m
+                             (case-lambda
+                               [(b) (not b)]
+                               [(x y) (+ x y)]))
+                           (super-new)))
+                    'pos
+                    'neg)
+          m 
+          3
+          4)
+   7)
+  
+  (test/pos-blame
+   'object-contract-opt->*1
+   '(contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number?))))
+              (new (class object%
+                     (define/public m
+                       (opt-lambda (x [y 'a])
+                         x))
+                     (super-new)))
+              'pos
+              'neg))
+  
+  (test/pos-blame
+   'object-contract-opt->*2
+   '(contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number?))))
+              (new (class object%
+                     (define/public m
+                       (opt-lambda (x y [z #t])
+                         x))
+                     (super-new)))
+              'pos
+              'neg))
+  
+  (test/spec-passed
+   'object-contract-opt->*3
+   '(contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number?))))
+              (new (class object%
+                     (define/public m
+                       (opt-lambda (x [y 'a] [z #t])
+                         x))
+                     (super-new)))
+              'pos
+              'neg))
+  
+  (test/spec-passed/result
+   'object-contract-opt->*4
+   '(send (contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number?))))
+                    (new (class object%
+                           (define/public m
+                             (opt-lambda (x [y 'a] [z #t])
+                               x))
+                           (super-new)))
+                    'pos
+                    'neg)
+          m
+          1)
+   1)
+  
+  (test/spec-passed/result
+   'object-contract-opt->*5
+   '(send (contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number?))))
+                    (new (class object%
+                           (define/public m
+                             (opt-lambda (x [y 'a] [z #t])
+                               x))
+                           (super-new)))
+                    'pos
+                    'neg)
+          m
+          2
+          'z)
+   2)
+  
+  (test/spec-passed/result
+   'object-contract-opt->*7
+   '(send (contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number?))))
+                    (new (class object%
+                           (define/public m
+                             (opt-lambda (x [y 'a] [z #t])
+                               x))
+                           (super-new)))
+                    'pos
+                    'neg)
+          m
+          3
+          'z
+          #f)
+   3)
+  
+  (test/neg-blame
+   'object-contract-opt->*8
+   '(send (contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number?))))
+                    (new (class object%
+                           (define/public m
+                             (opt-lambda (x [y 'a] [z #t])
+                               x))
+                           (super-new)))
+                    'pos
+                    'neg)
+          m
+          #f))
+  
+  (test/neg-blame
+   'object-contract-opt->*9
+   '(send (contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number?))))
+                    (new (class object%
+                           (define/public m
+                             (opt-lambda (x [y 'a] [z #t])
+                               x))
+                           (super-new)))
+                    'pos
+                    'neg)
+          m
+          2
+          4))
+  
+  (test/neg-blame
+   'object-contract-opt->*10
+   '(send (contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number?))))
+                    (new (class object%
+                           (define/public m
+                             (opt-lambda (x [y 'a] [z #t])
+                               x))
+                           (super-new)))
+                    'pos
+                    'neg)
+          m
+          3
+          'z
+          'y))
+  
+  (test/pos-blame
+   'object-contract-opt->*11
+   '(send (contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number?))))
+                    (new (class object%
+                           (define/public m
+                             (opt-lambda (x [y 'a] [z #t])
+                               'x))
+                           (super-new)))
+                    'pos
+                    'neg)
+          m
+          3
+          'z
+          #f))
+  
+  (test/spec-passed/result
+   'object-contract-opt->*12
+   '(let-values ([(x y)
+                  (send (contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number? symbol?))))
+                                  (new (class object%
+                                         (define/public m
+                                           (opt-lambda (x [y 'a] [z #t])
+                                             (values 1 'x)))
+                                         (super-new)))
+                                  'pos
+                                  'neg)
+                        m
+                        3
+                        'z
+                        #f)])
+      (cons x y))
+   (cons 1 'x))
+  
+  (test/pos-blame
+   'object-contract-opt->*13
+   '(send (contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number? symbol?))))
+                    (new (class object%
+                           (define/public m
+                             (opt-lambda (x [y 'a] [z #t])
+                               (values 'x 'x)))
+                           (super-new)))
+                    'pos
+                    'neg)
+          m
+          3
+          'z
+          #f))
+  
+  (test/pos-blame
+   'object-contract-opt->*14
+   '(send (contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number? symbol?))))
+                    (new (class object%
+                           (define/public m
+                             (opt-lambda (x [y 'a] [z #t])
+                               (values 1 1)))
+                           (super-new)))
+                    'pos
+                    'neg)
+          m
+          3
+          'z
+          #f))
+
+  (test/pos-blame
+   'object-contract->*1
+   '(contract (object-contract (m (->* (integer?) (boolean?))))
+              (new (class object% (define/public (m x y) x) (super-new)))
+              'pos
+              'neg))
+  
+  (test/neg-blame
+   'object-contract->*2
+   '(send (contract (object-contract (m (->* (integer?) (boolean?))))
+                    (new (class object% (define/public (m x) x) (super-new)))
+                    'pos
+                    'neg)
+          m #f))
+  
+  (test/pos-blame
+   'object-contract->*3
+   '(send (contract (object-contract (m (->* (integer?) (boolean?))))
+                    (new (class object% (define/public (m x) x) (super-new)))
+                    'pos
+                    'neg)
+          m 1))
+  
+  (test/spec-passed
+   'object-contract->*4
+   '(send (contract (object-contract (m (->* (integer?) (boolean?))))
+                    (new (class object% (define/public (m x) #f) (super-new)))
+                    'pos
+                    'neg)
+          m 1))
+  
+  (test/pos-blame
+   'object-contract->*5
+   '(contract (object-contract (m (->* (integer?) any/c (boolean?))))
+              (new (class object% (define/public (m x y . z) x) (super-new)))
+              'pos
+              'neg))
+  
+  (test/neg-blame
+   'object-contract->*6
+   '(send (contract (object-contract (m (->* (integer?) any/c (boolean?))))
+                    (new (class object% (define/public (m x . z) x) (super-new)))
+                    'pos
+                    'neg)
+          m #t))
+  
+  (test/pos-blame
+   'object-contract->*7
+   '(send (contract (object-contract (m (->* (integer?) any/c (boolean?))))
+                    (new (class object% (define/public (m x . z) 1) (super-new)))
+                    'pos
+                    'neg)
+          m 1))
+  
+  (test/spec-passed
+   'object-contract->*8
+   '(send (contract (object-contract (m (->* (integer?) any/c (boolean?))))
+                    (new (class object% (define/public (m x . z) #f) (super-new)))
+                    'pos
+                    'neg)
+          m 1))
+  
+  (test/spec-passed
+   'object-contract->*9
+   '(send (contract (object-contract (m (->* () (listof number?) (boolean?))))
+                    (new (class object% (define/public (m . z) #f) (super-new)))
+                    'pos
+                    'neg)
+          m 1 2 3))
+  
+  (test/neg-blame
+   'object-contract->*10
+   '(send (contract (object-contract (m (->* () (listof number?) (boolean?))))
+                    (new (class object% (define/public (m . z) #f) (super-new)))
+                    'pos
+                    'neg)
+          m 
+          #t))
+  
+  (test/spec-passed
+   'object-contract->d1
+   '(contract (object-contract (m (->d integer? (lambda (x) (lambda (y) (and (integer? y) (= y (+ x 1))))))))
+              (new (class object% (define/public (m x) 1) (super-new)))
+              'pos 
+              'neg))
+  
+  (test/neg-blame
+   'object-contract->d2
+   '(send (contract (object-contract (m (->d integer? (lambda (x) (lambda (y) (and (integer? y) (= y (+ x 1))))))))
+                    (new (class object% (define/public (m x) 1) (super-new)))
+                    'pos 
+                    'neg)
+          m #f))
+  
+  (test/pos-blame
+   'object-contract->d3
+   '(send (contract (object-contract (m (->d integer? (lambda (x) (lambda (y) (and (integer? y) (= y (+ x 1))))))))
+                    (new (class object% (define/public (m x) 1) (super-new)))
+                    'pos 
+                    'neg)
+          m 
+          1))
+  
+  (test/spec-passed
+   'object-contract->d4
+   '(send (contract (object-contract (m (->d integer? (lambda (x) (lambda (y) (and (integer? y) (= y (+ x 1))))))))
+                    (new (class object% (define/public (m x) 1) (super-new)))
+                    'pos 
+                    'neg)
+          m 
+          0))
+  
+  (test/spec-passed
+   'object-contract->d*1
+   '(contract (object-contract (m (->d* (integer? integer?) 
+                                        (lambda (x z) (lambda (y) (and (integer? y) (= y (+ x 1))))))))
+              (new (class object% (define/public (m x y) 1) (super-new)))
+              'pos 
+              'neg))
+  
+  (test/neg-blame
+   'object-contract->d*2
+   '(send (contract (object-contract (m (->d* (integer? boolean?)
+                                              (lambda (x z) (lambda (y) (and (integer? y) (= y (+ x 1))))))))
+                    (new (class object% (define/public (m x y) 1) (super-new)))
+                    'pos 
+                    'neg)
+          m #f #f))
+  
+  (test/neg-blame
+   'object-contract->d*3
+   '(send (contract (object-contract (m (->d* (integer? boolean?)
+                                              (lambda (x z) (lambda (y) (and (integer? y) (= y (+ x 1))))))))
+                    (new (class object% (define/public (m x y) 1) (super-new)))
+                    'pos 
+                    'neg)
+          m 1 1))
+  
+  (test/pos-blame
+   'object-contract->d*4
+   '(send (contract (object-contract (m (->d* (integer? boolean?)
+                                              (lambda (x z) (lambda (y) (and (integer? y) (= y (+ x 1))))))))
+                    (new (class object% (define/public (m x y) 1) (super-new)))
+                    'pos 
+                    'neg)
+          m 
+          1
+          #t))
+  
+  (test/spec-passed
+   'object-contract->d*5
+   '(send (contract (object-contract (m (->d* (integer? boolean?)
+                                              (lambda (x z) (lambda (y) (and (integer? y) (= y (+ x 1))))))))
+                    (new (class object% (define/public (m x y) 1) (super-new)))
+                    'pos 
+                    'neg)
+          m 
+          0
+          #t))
+  
+  (test/spec-passed
+   'object-contract->d*6
+   '(contract (object-contract (m (->d* (integer? integer?) 
+                                        any/c
+                                        (lambda (x z . rst) (lambda (y) 
+                                                              (= y (length rst)))))))
+              (new (class object% (define/public (m x y . z) 2) (super-new)))
+              'pos 
+              'neg))
+  
+  (test/neg-blame
+   'object-contract->d*7
+   '(send (contract (object-contract (m (->d* (integer? boolean?) 
+                                              any/c
+                                              (lambda (x z . rst) (lambda (y) 
+                                                                    (= y (length rst)))))))
+                    (new (class object% (define/public (m x y . z) 2) (super-new)))
+                    'pos 
+                    'neg)
+          m 1 1))
+  
+  (test/neg-blame
+   'object-contract->d*8
+   '(send (contract (object-contract (m (->d* (integer? boolean?) 
+                                              any/c
+                                              (lambda (x z . rst) (lambda (y) 
+                                                                    (= y (length rst)))))))
+                    (new (class object% (define/public (m x y . z) 2) (super-new)))
+                    'pos 
+                    'neg)
+          m #t #t))
+  
+  (test/neg-blame
+   'object-contract->d*9
+   '(send (contract (object-contract (m (->d* (integer? boolean?) 
+                                              (listof symbol?)
+                                              (lambda (x z . rst) (lambda (y) 
+                                                                    (= y (length rst)))))))
+                    (new (class object% (define/public (m x y . z) 2) (super-new)))
+                    'pos 
+                    'neg)
+          m #t #t))
+  
+  (test/neg-blame
+   'object-contract->d*10
+   '(send (contract (object-contract (m (->d* (integer? boolean?) 
+                                              (listof symbol?)
+                                              (lambda (x z . rst) (lambda (y) 
+                                                                    (= y (length rst)))))))
+                    (new (class object% (define/public (m x y . z) 2) (super-new)))
+                    'pos 
+                    'neg)
+          m 1 #t #t))
+  
+  (test/pos-blame
+   'object-contract->d*11
+   '(send (contract (object-contract (m (->d* (integer? boolean?) 
+                                              (listof symbol?)
+                                              (lambda (x z . rst) (lambda (y) 
+                                                                    (= y (length rst)))))))
+                    (new (class object% (define/public (m x y . z) 2) (super-new)))
+                    'pos 
+                    'neg)
+          m 1 #t 'x))
+  
+  (test/spec-passed
+   'object-contract->d*12
+   '(send (contract (object-contract (m (->d* (integer? boolean?) 
+                                              (listof symbol?)
+                                              (lambda (x z . rst) (lambda (y) 
+                                                                    (= y (length rst)))))))
+                    (new (class object% (define/public (m x y . z) 2) (super-new)))
+                    'pos 
+                    'neg)
+          m 1 #t 'x 'y))
+
+  (test/spec-passed
+   'object-contract-->r1
+   '(send (contract (object-contract (m (case-> (->r ([x number?]) (<=/c x)))))
+                    (new (class object% (define/public m (lambda (x) (- x 1))) (super-new)))
+                    'pos
+                    'neg)
+          m
+          1))
+
+  (test/pos-blame 
+   'object-contract-->r2
+   '(send (contract (object-contract (m (case-> (->r ([x number?]) (<=/c x)))))
+                    (new (class object% (define/public m (lambda (x) (+ x 1))) (super-new)))
+                    'pos
+                    'neg)
+          m
+          1))
+  
+  (test/spec-passed
+   'object-contract-->r3
+   '(send (contract (object-contract (m (->r () rst (listof number?) any/c)))
+                    (new (class object% (define/public m (lambda w 1)) (super-new)))
+                    'pos
+                    'neg)
+          m
+          1))
+  
+  (test/neg-blame
+   'object-contract-->r4
+   '(send (contract (object-contract (m (->r () rst (listof number?) any/c)))
+                    (new (class object% (define/public m (lambda w 1)) (super-new)))
+                    'pos 
+                    'neg)
+          m
+          #f))
+    
+  (test/spec-passed
+   'object-contract-->r5
+   '(send (contract (object-contract (m (->r () any)))
+                    (new (class object% (define/public m (lambda () 1)) (super-new)))
+                    'pos
+                    'neg)
+          m))
+  
+  (test/spec-passed
+   'object-contract-->r6
+   '(send (contract (object-contract (m (->r () (values [x number?] [y (>=/c x)]))))
+                    (new (class object% (define/public m (lambda () (values 1 2))) (super-new)))
+                    'pos
+                    'neg)
+          m))
+  
+  (test/pos-blame
+   'object-contract-->r7
+   '(send (contract (object-contract (m (->r () (values [x number?] [y (>=/c x)]))))
+                    (new (class object% (define/public m (lambda () (values 2 1))) (super-new)))
+                    'pos
+                    'neg)
+          m))
+
+  (test/spec-passed
+   'object-contract-->pp1
+   '(send (contract (object-contract (m (case-> (->pp ([x number?]) #t (<=/c x) unused #t))))
+                    (new (class object% (define/public m (lambda (x) (- x 1))) (super-new)))
+                    'pos
+                    'neg)
+          m
+          1))
+
+  (test/pos-blame 
+   'object-contract-->pp2
+   '(send (contract (object-contract (m (case-> (->pp ([x number?]) #t (<=/c x) unused #t))))
+                    (new (class object% (define/public m (lambda (x) (+ x 1))) (super-new)))
+                    'pos
+                    'neg)
+          m
+          1))
+  
+  (test/spec-passed
+   'object-contract-->pp3
+   '(send (contract (object-contract (m (->pp-rest () rst (listof number?) #t any/c unused #t)))
+                    (new (class object% (define/public m (lambda w 1)) (super-new)))
+                    'pos
+                    'neg)
+          m
+          1))
+  
+  (test/neg-blame
+   'object-contract-->pp4
+   '(send (contract (object-contract (m (->pp-rest () rst (listof number?) #t any/c unused #t)))
+                    (new (class object% (define/public m (lambda w 1)) (super-new)))
+                    'pos 
+                    'neg)
+          m
+          #f))
+    
+  (test/spec-passed
+   'object-contract-->pp5
+   '(send (contract (object-contract (m (->pp () #t any)))
+                    (new (class object% (define/public m (lambda () 1)) (super-new)))
+                    'pos
+                    'neg)
+          m))
+  
+  (test/spec-passed
+   'object-contract-->pp6
+   '(send (contract (object-contract (m (->pp () #t (values [x number?] [y (>=/c x)]) #t)))
+                    (new (class object% (define/public m (lambda () (values 1 2))) (super-new)))
+                    'pos
+                    'neg)
+          m))
+  
+  (test/pos-blame
+   'object-contract-->pp7
+   '(send (contract (object-contract (m (->pp () #t (values [x number?] [y (>=/c x)]) #t)))
+                    (new (class object% (define/public m (lambda () (values 2 1))) (super-new)))
+                    'pos
+                    'neg)
+          m))
+  
+  (test/spec-passed/result
+   'object-contract-drop-method1
+   '(send (contract (object-contract (m (-> integer? integer?)))
+                    (new (class object% (define/public (m x) x) (define/public (n x) x) (super-new)))
+                    'pos
+                    'neg)
+          n 1)
+   1)
+  
+  (test/spec-passed/result
+   'object-contract-drop-method2
+   '(let ([o (contract (object-contract (m (-> integer? integer?)))
+                       (new (class object% (define/public (m x) x) (define/public (n x) x) (super-new)))
+                       'pos
+                       'neg)])
+      (with-method ([m (o m)]
+                    [n (o n)])
+        (list (m 1) (n 2))))
+   '(1 2))
+  
+  (test/spec-passed/result
+   'object-contract-drop-field1
+   '(get-field g (contract (object-contract (field f integer?))
+                           (new (class object% (field [f 1] [g 2]) (super-new)))
+                           'pos
+                           'neg))
+   2)
+  
+  (test/spec-passed/result
+   'object-contract-drop-field2
+   '(field-bound? g (contract (object-contract (field f integer?))
+                              (new (class object% (field [f 1] [g 2]) (super-new)))
+                              'pos
+                              'neg))
+   #t)
+  
+  (test/spec-passed/result
+   'object-contract-drop-field3
+   '(field-names
+     (contract (object-contract)
+               (new (class object% (field [g 2]) (super-new)))
+               'pos
+               'neg))
+   '(g))
+
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;
+  ;; test error message has right format
+  ;;
+  
+  (test "procedure m method: expects 1 argument, given 2: 1 2"
+        'wrong-method-arity-error-message
+        (with-handlers ([exn:fail? exn-message])
+          (send (contract (object-contract [m (integer? . -> . integer?)])
+                          (new (class object% (define/public (m x) x) (super-new)))
+                          'pos
+                          'neg)
+                m
+                1
+                2)))
+        
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;
+  ;; tests object utilities to be sure wrappers work right
+  ;;
+  
+  (let* ([o1 (new object%)]
+         [o2 (contract (object-contract) o1 'pos 'neg)])
+    (test #t object=? o1 o1)
+    (test #f object=? o1 (new object%))
+    (test #t object=? o1 o2)
+    (test #t object=? o2 o1)
+    (test #f object=? (new object%) o2))
+  
+  (test #t method-in-interface? 'm 
+        (object-interface 
+         (contract
+          (object-contract (m (integer? . -> . integer?)))
+          (new (class object% (define/public (m x) x) (super-new)))
+          'pos
+          'neg)))
+  
+  (let* ([i<%> (interface ())]
+         [c% (class* object% (i<%>) (super-new))]
+         [o (new c%)])
+    (test #t is-a? o i<%>)
+    (test #t is-a? o c%)
+    (test #t is-a? (contract (object-contract) o 'pos 'neg) i<%>)
+    (test #t is-a? (contract (object-contract) o 'pos 'neg) c%))
+  
+  (let ([c% (parameterize ([current-inspector (make-inspector)])
+              (class object% (super-new)))])
+    (test (list c% #f) 
+          'object-info
+          (call-with-values 
+           (lambda () (object-info (contract (object-contract) (new c%) 'pos 'neg)))
+           list)))
+
+  ;; object->vector tests
+  (let* ([obj
+          (parameterize ([current-inspector (make-inspector)])
+            (new (class object% (field [x 1] [y 2]) (super-new))))]
+         [vec (object->vector obj)])
+    (test vec
+          object->vector
+          (contract (object-contract (field x integer?) (field y integer?))
+                    obj
+                    'pos
+                    'neg)))
+  
+;                                                                     
+;                                                                     
+;                                                                     
+;   ;                                               ;       ;         
+;                                                   ;       ;         
+;                                       ;           ;       ;         
+;   ;   ; ;;  ;;    ; ;;  ;;    ;   ;  ;;;;  ;;;    ; ;;    ;    ;;;  
+;   ;   ;;  ;;  ;   ;;  ;;  ;   ;   ;   ;   ;   ;   ;;  ;   ;   ;   ; 
+;   ;   ;   ;   ;   ;   ;   ;   ;   ;   ;       ;   ;    ;  ;  ;    ; 
+;   ;   ;   ;   ;   ;   ;   ;   ;   ;   ;    ;;;;   ;    ;  ;  ;;;;;; 
+;   ;   ;   ;   ;   ;   ;   ;   ;   ;   ;   ;   ;   ;    ;  ;  ;      
+;   ;   ;   ;   ;   ;   ;   ;   ;  ;;   ;   ;   ;   ;;  ;   ;   ;     
+;   ;   ;   ;   ;   ;   ;   ;    ;; ;    ;;  ;;;;;  ; ;;    ;    ;;;; 
+;                                                                     
+;                                                                     
+;                                                                     
+
+  
+  (test/pos-blame
+   'immutable1
+   '(let ([ct (contract (list-immutableof (boolean? . -> . boolean?)) 
+                        #f 
+                        'pos
+                        'neg)])
+      ((car ct) 1)))
+  
+  (test/pos-blame
+   'immutable2
+   '(let ([ct (contract (list-immutableof (boolean? . -> . boolean?)) 
+                        (list (lambda (x) x)) 
+                        'pos
+                        'neg)])
+      ((car ct) 1)))
+  
+  (test/neg-blame
+   'immutable3
+   '(let ([ct (contract (list-immutableof (number? . -> . boolean?)) 
+                        (list-immutable (lambda (x) 1)) 
+                        'pos
+                        'neg)])
+      ((car ct) #f)))
+  
+  (test/pos-blame
+   'immutable4
+   '(let ([ct (contract (list-immutableof (number? . -> . boolean?)) 
+                        (list-immutable (lambda (x) 1)) 
+                        'pos
+                        'neg)])
+      ((car ct) 1)))
+  
+  (test/spec-passed
+   'immutable5
+   '(let ([ct (contract (list-immutableof (number? . -> . boolean?)) 
+                        (list-immutable (lambda (x) #t)) 
+                        'pos
+                        'neg)])
+      ((car ct) 1)))
+  
+
+  (test/pos-blame
+   'immutable6
+   '(contract (cons-immutable/c (boolean? . -> . boolean?) (boolean? . -> . boolean?)) 
+              #f 
+              'pos
+              'neg))
+  
+  (test/pos-blame
+   'immutable7
+   '(contract (cons-immutable/c (boolean? . -> . boolean?) (boolean? . -> . boolean?)) 
+              (cons (lambda (x) x) (lambda (x) x))
+              'pos
+              'neg))
+  
+  (test/neg-blame
+   'immutable8
+   '(let ([ct (contract (cons-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) 
+                        (cons-immutable (lambda (x) 1) (lambda (x) 1))
+                        'pos
+                        'neg)])
+      ((car ct) #f)))
+  
+  (test/neg-blame
+   'immutable9
+   '(let ([ct (contract (cons-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) 
+                        (cons-immutable (lambda (x) 1) (lambda (x) 1))
+                        'pos
+                        'neg)])
+      ((cdr ct) #f)))
+  
+  (test/pos-blame
+   'immutable10
+   '(let ([ct (contract (cons-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) 
+                        (cons-immutable (lambda (x) 1) (lambda (x) 1)) 
+                        'pos
+                        'neg)])
+      ((car ct) 1)))
+  
+  (test/pos-blame
+   'immutable11
+   '(let ([ct (contract (cons-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) 
+                        (cons-immutable (lambda (x) 1) (lambda (x) 1)) 
+                        'pos
+                        'neg)])
+      ((cdr ct) 1)))
+  
+  (test/spec-passed
+   'immutable12
+   '(let ([ct (contract (cons-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) 
+                        (cons-immutable (lambda (x) #t) (lambda (x) #t)) 
+                        'pos
+                        'neg)])
+      ((car ct) 1)))
+  
+  (test/spec-passed
+   'immutable13
+   '(let ([ct (contract (cons-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) 
+                        (cons-immutable (lambda (x) #t) (lambda (x) #t)) 
+                        'pos
+                        'neg)])
+      ((cdr ct) 1)))
+  
+  (test/spec-passed/result
+   'immutable14
+   '(contract (cons-immutable/c number? boolean?) 
+              (cons-immutable 1 #t) 
+              'pos
+              'neg)
+   (cons-immutable 1 #t))
+  
+  (test/pos-blame
+   'immutable15
+   '(contract (list-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) 
+              #f
+              'pos
+              'neg))
+  
+  (test/pos-blame
+   'immutable16
+   '(contract (list-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) 
+              (list (lambda (x) #t) (lambda (x) #t)) 
+              'pos
+              'neg))
+  
+  (test/pos-blame
+   'immutable17
+   '(contract (list-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) 
+              (list-immutable (lambda (x) #t)) 
+              'pos
+              'neg))
+  
+  (test/pos-blame
+   'immutable18
+   '(contract (list-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) 
+              (list-immutable (lambda (x) #t) (lambda (x) #t) (lambda (x) #t)) 
+              'pos
+              'neg))
+  
+  (test/spec-passed
+   'immutable19
+   '(let ([ctc (contract (list-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) 
+                         (list-immutable (lambda (x) #t) (lambda (x) #t)) 
+                         'pos
+                         'neg)])
+      (for-each (lambda (x) (x 1)) ctc)))
+  
+  (test/spec-passed/result
+   'immutable20
+   '(let ([ctc (contract (list-immutable/c number?) 
+                         (list-immutable 1) 
+                         'pos
+                         'neg)])
+      (immutable? ctc))
+   #t)
+
+  (test/pos-blame
+   'vector-immutable1
+   '(contract (vector-immutableof (boolean? . -> . boolean?)) 
+              #f 
+              'pos
+              'neg))
+  
+  (test/pos-blame
+   'vector-immutable2
+   '(contract (vector-immutableof (boolean? . -> . boolean?)) 
+              (vector (lambda (x) x)) 
+              'pos
+              'neg))
+  
+  (test/neg-blame
+   'vector-immutable3
+   '(let ([ct (contract (vector-immutableof (number? . -> . boolean?)) 
+                        (vector->immutable-vector (vector (lambda (x) 1)))
+                        'pos
+                        'neg)])
+      ((vector-ref ct 0) #f)))
+  
+  (test/pos-blame
+   'vector-immutable4
+   '(let ([ct (contract (vector-immutableof (number? . -> . boolean?)) 
+                        (vector->immutable-vector (vector (lambda (x) 1)))
+                        'pos
+                        'neg)])
+      ((vector-ref ct 0) 1)))
+  
+  (test/spec-passed
+   'vector-immutable5
+   '(let ([ct (contract (vector-immutableof (number? . -> . boolean?)) 
+                        (vector->immutable-vector (vector (lambda (x) #t)))
+                        'pos
+                        'neg)])
+      ((vector-ref ct 0) 1)))
+  
+  (test/pos-blame
+   'vector-immutable6
+   '(contract (vector-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) 
+              #f
+              'pos
+              'neg))
+  
+  (test/pos-blame
+   'vector-immutable7
+   '(contract (vector-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) 
+              (vector (lambda (x) #t) (lambda (x) #t)) 
+              'pos
+              'neg))
+  
+  (test/pos-blame
+   'vector-immutable8
+   '(contract (vector-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) 
+              (vector->immutable-vector (vector (lambda (x) #t)))
+              'pos
+              'neg))
+  
+  (test/pos-blame
+   'vector-immutable9
+   '(contract (vector-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) 
+              (vector->immutable-vector (vector (lambda (x) #t) (lambda (x) #t) (lambda (x) #t)))
+              'pos
+              'neg))
+  
+  (test/spec-passed
+   'vector-immutable10
+   '(let ([ctc (contract (vector-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) 
+                         (vector->immutable-vector (vector (lambda (x) #t) (lambda (x) #t))) 
+                         'pos
+                         'neg)])
+      ((vector-ref ctc 0) 1)
+      ((vector-ref ctc 1) 1)))
+
+  (test/spec-passed/result
+   'vector-immutable11
+   '(contract (vector-immutable/c number? boolean?) 
+              (vector->immutable-vector (vector 1 #t))
+              'pos
+              'neg)
+   (vector->immutable-vector (vector 1 #t)))
+  
+  (test/spec-passed/result
+   'vector-immutable12
+   '(immutable? (contract (vector-immutable/c number? boolean?) 
+                          (vector->immutable-vector (vector 1 #t))
+                          'pos
+                          'neg))
+   #t)
+
+  (test/pos-blame
+   'box-immutable1
+   '(contract (box-immutable/c (number? . -> . boolean?)) 
+              #f
+              'pos
+              'neg))
+  
+  (test/pos-blame
+   'box-immutable2
+   '(contract (box-immutable/c (number? . -> . boolean?)) 
+              (box (lambda (x) #t)) 
+              'pos
+              'neg))
+  
+  (test/neg-blame
+   'box-immutable3
+   '(let ([ctc (contract (box-immutable/c (number? . -> . boolean?)) 
+                         (box-immutable (lambda (x) #t))
+                         'pos
+                         'neg)])
+      ((unbox ctc) #f)))
+  
+  (test/pos-blame
+   'box-immutable4
+   '(let ([ctc (contract (box-immutable/c (number? . -> . boolean?)) 
+                         (box-immutable (lambda (x) 1))
+                         'pos
+                         'neg)])
+      ((unbox ctc) 1)))
+  
+  (test/spec-passed
+   'box-immutable5
+   '(let ([ctc (contract (box-immutable/c (number? . -> . boolean?)) 
+                         (box-immutable (lambda (x) #t))
+                         'pos
+                         'neg)])
+      ((unbox ctc) 1)))
+
+  (test/spec-passed/result
+   'box-immutable6
+   '(contract (box-immutable/c boolean?) 
+              (box-immutable #t)
+              'pos
+              'neg)
+   (box-immutable #t))
+  
+  (test/spec-passed/result
+   'box-immutable7
+   '(immutable? (contract (box-immutable/c boolean?) 
+                          (box-immutable #t)
+                          'pos
+                          'neg))
+   #t)
+
+  
+  (test/spec-passed 
+   'anaphoric1
+   '(contract (let-values ([(in out) (anaphoric-contracts)]) in)
+              1
+              'pos
+              'neg))
+  
+  (test/pos-blame
+   'anaphoric2
+   '(contract (let-values ([(in out) (anaphoric-contracts)]) out)
+              1
+              'pos
+              'neg))
+  
+  (test/spec-passed
+   'anaphoric3
+   '((contract (let-values ([(in out) (anaphoric-contracts)]) (-> in out))
+               (lambda (x) x)
+               'pos
+               'neg)
+     1))
+  
+  (test/pos-blame
+   'anaphoric4
+   '((contract (let-values ([(in out) (anaphoric-contracts)]) (-> in out))
+               (lambda (x) (* 2 x))
+               'pos
+               'neg)
+     1))
+  
+  (test/pos-blame
+   'promise/c1
+   '(force (contract (promise/c boolean?)
+                     (delay 1)
+                     'pos
+                     'neg)))
+  
+  (test/spec-passed
+   'promise/c2
+   '(force (contract (promise/c boolean?)
+                     (delay #t)
+                     'pos
+                     'neg)))
+  
+  (test/spec-passed/result
+   'promise/c3
+   '(let ([x 0])
+      (contract (promise/c any/c)
+                (delay (set! x (+ x 1)))
+                'pos
+                'neg)
+      x)
+   0)
+  
+  (test/spec-passed/result
+   'promise/c4
+   '(let ([x 0])
+      (force (contract (promise/c any/c)
+                       (delay (set! x (+ x 1)))
+                       'pos
+                       'neg))
+      x)
+   1)
+  
+  (test/spec-passed/result
+   'promise/c5
+   '(let ([x 0])
+      (let ([p (contract (promise/c any/c)
+                         (delay (set! x (+ x 1)))
+                         'pos
+                         'neg)])
+        (force p)
+        (force p))
+      x)
+   1)
+  
+  (test/spec-passed
+   'struct/c1
+   '(let ()
+      (define-struct s (a))
+      (contract (struct/c s integer?)
+                (make-s 1)
+                'pos
+                'neg)))
+  
+  (test/pos-blame
+   'struct/c2
+   '(let ()
+      (define-struct s (a))
+      (contract (struct/c s integer?)
+                (make-s #f)
+                'pos
+                'neg)))
+  
+  (test/pos-blame
+   'struct/c3
+   '(let ()
+      (define-struct s (a))
+      (contract (struct/c s integer?)
+                1
+                'pos
+                'neg)))
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;                                                        ;;
+  ;;   Flat Contract Tests                                  ;;
+  ;;                                                        ;;
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  
+  (test #t flat-contract? (union))
+  (test #t flat-contract? (union integer? (lambda (x) (> x 0))))
+  (test #t flat-contract? (union (flat-contract integer?)
+				 (flat-contract boolean?)))
+  (test-flat-contract '(union (flat-contract integer?) char?) #\a #t)
+  (test-flat-contract '(union (flat-contract integer?) char?) 1 #t)
+  
+  (test #t flat-contract? (and/c))
+  (test #t flat-contract? (and/c number? integer?))
+  (test #t flat-contract? (and/c (flat-contract number?)
+				 (flat-contract integer?)))
+  (test-flat-contract '(and/c number? integer?) 1 3/2)
+
+  (test-flat-contract '(not/c integer?) #t 1)
+  (test-flat-contract '(=/c 2) 2 3)
+  (test-flat-contract '(>=/c 5) 5 0)
+  (test-flat-contract '(<=/c 5) 5 10)
+  (test-flat-contract '(</c 5) 0 5)
+  (test-flat-contract '(>/c 5) 10 5)
+  (test-flat-contract '(integer-in 0 10) 0 11)
+  (test-flat-contract '(integer-in 0 10) 10 3/2)
+  (test-flat-contract '(exact-integer-in 0 10) 0 11)
+  (test-flat-contract '(exact-integer-in 0 10) 10 3/2)
+  (test-flat-contract '(exact-integer-in 0 10) 1 1.0)
+  (test-flat-contract '(real-in 1 10) 3/2 20)
+  (test-flat-contract '(string/len 3) "ab" "abc")
+  (test-flat-contract 'natural-number/c 5 -1)
+  (test-flat-contract 'false/c #f #t)
+  (test/spec-passed 'any/c '(contract any/c 1 'pos 'neg))
+  (test-flat-contract 'printable/c (vector (cons 1 (box #f))) (lambda (x) x))
+  (test-flat-contract '(symbols 'a 'b 'c) 'a 'd)
+  
+  (let ([c% (class object% (super-new))])
+    (test-flat-contract (subclass?/c c%) c% object%)
+    (test-flat-contract (subclass?/c c%) (class c%) (class object%)))
+  
+  (let ([i<%> (interface ())])
+    (test-flat-contract `(implementation?/c ,i<%>) (class* object% (i<%>) (super-new)) object%)
+    (test-flat-contract `(implementation?/c ,i<%>) (class* object% (i<%>) (super-new)) #f))
+  
+  (let ([i<%> (interface ())]
+        [c% (class object% (super-new))])
+    (test-flat-contract `(is-a?/c ,i<%>) (new (class* object% (i<%>) (super-new))) (new object%))
+    (test-flat-contract `(is-a?/c ,c%) (new c%) (new object%)))
+  
+  (test-flat-contract '(listof boolean?) (list #t #f) (list #f 3 #t))
+  (test-flat-contract '(listof any/c) (list #t #f) 3)
+  ;(test-flat-contract '(list-immutableof boolean?) (list-immutable #t #f) (list-immutable #f 3 #t))
+  ;(test-flat-contract '(list-immutableof any/c) (list-immutable #t #f) 3)
+  ;(test-flat-contract '(list-immutableof boolean?) (list-immutable) (list))
+  ;(test-flat-contract '(list-immutableof (-> boolean? boolean?)) (list-immutable (lambda (x) x)) (list (lambda (x) x)))
+  
+  (test-flat-contract '(vectorof boolean?) (vector #t #f) (vector #f 3 #t))
+  (test-flat-contract '(vectorof any/c) (vector #t #f) 3)
+  
+  (test-flat-contract '(vector/c boolean? (flat-contract integer?)) (vector #t 1) (vector 1 #f))
+  (test-flat-contract '(vector/c boolean? (flat-contract integer?)) (vector #t 1) #f)
+
+  (test-flat-contract '(cons/c boolean? (flat-contract integer?)) (cons #t 1) (cons 1 #f))
+  (test-flat-contract '(cons/c boolean? (flat-contract integer?)) (cons #t 1) #f)
+  (test-flat-contract '(list/c boolean? (flat-contract integer?)) (list #t 1) (list 1 #f))
+  (test-flat-contract '(list/c boolean? (flat-contract integer?)) (list #t 1) #f)
+
+  ;(test-flat-contract '(cons-immutable/c boolean? (flat-contract integer?)) (cons-immutable #t 1) (cons-immutable 1 #f))
+  ;(test-flat-contract '(cons-immutable/c boolean? (flat-contract integer?)) (cons-immutable #t 1) #f)
+  ;(test-flat-contract '(cons-immutable/c boolean? (flat-contract integer?)) (cons-immutable #t 1) (cons #t 1))
+  ;(test-flat-contract '(cons-immutable/c (-> boolean? boolean?) integer?) (cons-immutable (lambda (x) x) 1) #f)
+  
+  ;(test-flat-contract '(list-immutable/c boolean? (flat-contract integer?)) (list-immutable #t 1) (list-immutable 1 #f))
+  ;(test-flat-contract '(list-immutable/c boolean? (flat-contract integer?)) (list-immutable #t 1) #f)
+  ;(test-flat-contract '(list-immutable/c boolean? (flat-contract integer?)) (list-immutable #t 1) (list #t 1))
+  ;(test-flat-contract '(list-immutable/c (-> boolean? boolean?) integer?) (list-immutable (lambda (x) x) 1) #f)
+  
+  (test-flat-contract '(box/c boolean?) (box #f) (box 1))
+  (test-flat-contract '(box/c (flat-contract boolean?)) (box #t) #f)
+  
+  (test-flat-contract '(flat-rec-contract sexp (cons/c sexp sexp) number?) '(1 2 . 3) '(1 . #f))
+  (test-flat-contract '(flat-murec-contract ([even1 (union null? (cons/c number? even2))] 
+                                             [even2 (cons/c number? even1)])
+                                            even1)
+                      '(1 2 3 4)
+                      '(1 2 3))
+  (syntax-test #'(flat-murec-contract ([(x) y]) x)) ;; malformed binder
+  (syntax-test #'(flat-murec-contract ([x y]))) ;; missing body
+
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;                                                        ;;
+  ;;   case-> arity checking tests                          ;;
+  ;;                                                        ;;
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  
+  (test/well-formed #'(case-> (-> integer? integer?)))
+  (test/well-formed #'(case-> (-> integer? integer?) (-> integer? integer? integer?)))
+  (test/well-formed #'(case-> (-> integer? integer?) (-> integer? integer? any)))
+  (test/well-formed #'(case-> (-> integer? any) (-> integer? integer? any)))
+  
+  (test/well-formed #'(case-> (->d (lambda x any/c)) (-> integer? integer?)))
+
+  (test/well-formed #'(case-> (->* (any/c any/c) (integer?)) (-> integer? integer?)))
+  (test/well-formed #'(case-> (->* (any/c any/c) any/c (integer?)) (-> integer? integer?)))
+  (test/well-formed #'(case-> (->* (any/c any/c) any/c any) (-> integer? integer?)))
+  
+  (test/well-formed #'(case-> (->d* (any/c any/c) (lambda x any/c)) (-> integer? integer?)))
+  (test/well-formed #'(case-> (->d* (any/c any/c) any/c (lambda x any/c)) (-> integer? integer?)))
+
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;                                                        ;;
+  ;;   Inferred Name Tests                                  ;;
+  ;;                                                        ;;
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (eval 
+   '(module contract-test-suite-inferred-name1 mzscheme
+      (require (lib "contract.ss"))
+      (define contract-inferred-name-test-contract (-> integer? any))
+      (define (contract-inferred-name-test x) #t)
+      (provide/contract (contract-inferred-name-test contract-inferred-name-test-contract))
+      
+      (define (contract-inferred-name-test2 x) x)
+      (provide/contract (contract-inferred-name-test2 (-> number? number?)))
+      
+      (define (contract-inferred-name-test3 x) x)
+      (provide/contract (contract-inferred-name-test3 (->* (number?) (number?))))
+
+      (define (contract-inferred-name-test4 x) x)
+      (provide/contract (contract-inferred-name-test4 (case-> (->* (number?) (number?)))))
+
+      (define contract-inferred-name-test5 (case-lambda [(x) x] [(x y) x]))
+      (provide/contract (contract-inferred-name-test5 (case-> (-> number? number?) 
+                                                              (-> number? number? number?))))
+
+      (define contract-inferred-name-test6 (case-lambda [(x) x]
+                                                        [(x y) y]))
+      (provide/contract (contract-inferred-name-test6 (opt-> (number?) (number?) number?)))))
+  (eval '(require contract-test-suite-inferred-name1))
+  (eval '(test 'contract-inferred-name-test object-name contract-inferred-name-test))
+  (eval '(test 'contract-inferred-name-test2 object-name contract-inferred-name-test2))
+  (eval '(test 'contract-inferred-name-test3 object-name contract-inferred-name-test3))
+  (eval '(test 'contract-inferred-name-test4 object-name contract-inferred-name-test4))
+  (eval '(test 'contract-inferred-name-test5 object-name contract-inferred-name-test5))
+  (eval '(test 'contract-inferred-name-test6 object-name contract-inferred-name-test6))
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;                                                        ;;
+  ;;   Contract Name Tests                                  ;;
+  ;;                                                        ;;
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  
+  (test-name 'integer? (flat-contract integer?))
+  (test-name 'boolean? (flat-contract boolean?))
+  (test-name 'char? (flat-contract char?))
+  (test-name 'any/c any/c)
+  (test-name '(-> integer? integer?) (-> integer? integer?))
+  (test-name '(-> integer? any) (-> integer? any))
+  (test-name '(-> integer? (values boolean? char?)) (-> integer? (values boolean? char?)))
+  (test-name '(->* (integer? boolean?) (char? any/c)) (->* (integer? boolean?) (char? any/c)))
+  (test-name '(->* (integer? boolean?) any) (->* (integer? boolean?) any))
+  (test-name '(->* (integer?) boolean? (char? any/c)) (->* (integer?) boolean? (char? any/c)))
+  (test-name '(->* (integer? char?) boolean? any) (->* (integer? char?) boolean? any))
+  (test-name '(->d integer? boolean? ...) (->d integer? boolean? (lambda (x y) char?)))
+  (test-name '(->d* (integer? boolean?) ...) (->d* (integer? boolean?) (lambda (x y) char?)))
+  (test-name '(->d* (integer? boolean?) any/c ...) (->d* (integer? boolean?) any/c (lambda (x y . z) char?)))
+  (test-name '(->r ((x ...)) ...) (->r ((x number?)) number?))
+  (test-name '(->r ((x ...) (y ...) (z ...)) ...) (->r ((x number?) (y boolean?) (z pair?)) number?))
+  (test-name '(->r ((x ...) (y ...) (z ...)) rest-x ... ...) 
+             (->r ((x number?) (y boolean?) (z pair?)) rest-x any/c number?))
+  (test-name '(->pp ((x ...)) ...) (->pp ((x number?)) #t number? blech #t))
+  
+  (test-name '(case-> (->r ((x ...)) ...)) (case-> (->r ((x number?)) number?)))
+  (test-name '(case-> (->r ((x ...) (y ...) (z ...)) ...))
+             (case-> (->r ((x number?) (y boolean?) (z pair?)) number?)))
+  
+  (test-name '(case-> (-> integer? integer?) (-> integer? integer? integer?))
+             (case-> (-> integer? integer?) (-> integer? integer? integer?)))
+  
+  (test-name '(union) (union))
+  (test-name '(union integer? gt0?) (union integer? (let ([gt0? (lambda (x) (> x 0))]) gt0?)))
+  (test-name '(union integer? boolean?)
+             (union (flat-contract integer?)
+                    (flat-contract boolean?)))
+  (test-name '(union (-> (>=/c 5) (>=/c 5)) boolean?)
+             (union (-> (>=/c 5) (>=/c 5)) boolean?))
+  
+  (test-name 'any/c (and/c))
+  (test-name '(and/c any/c) (and/c any/c))
+  (test-name '(and/c any/c any/c) (and/c any/c any/c))
+  (test-name '(and/c number? integer?) (and/c number? integer?))
+  (test-name '(and/c number? integer?) (and/c (flat-contract number?)
+                                              (flat-contract integer?)))
+  (test-name '(and/c number? (-> integer? integer?)) (and/c number? (-> integer? integer?)))
+
+  (test-name '(not/c integer?) (not/c integer?))
+  (test-name '(=/c 5) (=/c 5))
+  (test-name '(>=/c 5) (>=/c 5))
+  (test-name '(<=/c 5) (<=/c 5))
+  (test-name '(</c 5) (</c 5))
+  (test-name '(>/c 5) (>/c 5))
+  (test-name '(integer-in 0 10) (integer-in 0 10))
+  (test-name '(exact-integer-in 0 10) (exact-integer-in 0 10))
+  (test-name '(real-in 1 10) (real-in 1 10))
+  (test-name '(string/len 3) (string/len 3))
+  (test-name 'natural-number/c natural-number/c)
+  (test-name 'false/c false/c)
+  (test-name 'printable/c printable/c)
+  (test-name '(symbols 'a 'b 'c)(symbols 'a 'b 'c))
+  
+  (let ([c% (class object% (super-new))])
+    (test-name '(subclass?/c class:c%) (subclass?/c c%)))
+  
+  (let ([i<%> (interface ())])
+    (test-name '(implementation?/c interface:i<%>) (implementation?/c i<%>)))
+  
+  (let ([i<%> (interface ())]
+        [c% (class object% (super-new))])
+    (test-name '(is-a?/c interface:i<%>) (is-a?/c i<%>))
+    (test-name '(is-a?/c class:c%) (is-a?/c c%)))
+  
+  (test-name '(listof boolean?) (listof boolean?))  
+  (test-name '(listof any/c) (listof any/c))
+  (test-name '(list-immutableof boolean?) (list-immutableof boolean?))
+  (test-name '(list-immutableof any/c) (list-immutableof any/c))
+  (test-name '(list-immutableof boolean?) (list-immutableof boolean?))
+  (test-name '(list-immutableof (-> boolean? boolean?)) (list-immutableof (-> boolean? boolean?)))
+  
+  (test-name '(vectorof boolean?) (vectorof boolean?))
+  (test-name '(vectorof any/c) (vectorof any/c))
+  
+  (test-name '(vector/c boolean? integer?) (vector/c boolean? integer?))
+  (test-name '(vector/c boolean? integer?) (vector/c boolean? (flat-contract integer?)))
+
+  (test-name '(cons/c boolean? integer?) (cons/c boolean? (flat-contract integer?)))
+  (test-name '(cons/c boolean? integer?) (cons/c boolean? (flat-contract integer?)))
+  (test-name '(cons/c boolean? (cons/c integer? null?)) (list/c boolean? (flat-contract integer?)))
+  (test-name '(cons/c boolean? (cons/c integer? null?)) (list/c boolean? (flat-contract integer?)))
+
+  (test-name '(cons-immutable/c boolean? integer?) (cons-immutable/c boolean? (flat-contract integer?)))
+  (test-name '(cons-immutable/c boolean? integer?) (cons-immutable/c boolean? (flat-contract integer?)))
+  (test-name '(cons-immutable/c boolean? integer?) (cons-immutable/c boolean? (flat-contract integer?)))
+  (test-name '(cons-immutable/c (-> boolean? boolean?) integer?) (cons-immutable/c (-> boolean? boolean?) integer?))
+  
+  (test-name '(cons-immutable/c boolean? (cons-immutable/c integer? null?))
+             (list-immutable/c boolean? (flat-contract integer?)))
+  (test-name '(cons-immutable/c boolean? (cons-immutable/c integer? null?)) 
+             (list-immutable/c boolean? (flat-contract integer?)))
+  (test-name '(cons-immutable/c boolean? (cons-immutable/c integer? null?))
+             (list-immutable/c boolean? (flat-contract integer?)))
+  (test-name '(cons-immutable/c (-> boolean? boolean?) (cons-immutable/c integer? null?))
+             (list-immutable/c (-> boolean? boolean?) integer?))
+  
+  (test-name '(box/c boolean?) (box/c boolean?))
+  (test-name '(box/c boolean?) (box/c (flat-contract boolean?)))
+  (test-name 'the-name (flat-rec-contract the-name))
+
+  (test-name '(object-contract) (object-contract))
+  (test-name '(object-contract (field x integer?)) (object-contract (field x integer?)))
+  (test-name '(object-contract (m (-> integer? integer?)))
+             (object-contract (m (-> integer? integer?))))
+  (test-name '(object-contract (m (-> integer? any)))
+             (object-contract (m (-> integer? any))))
+  (test-name '(object-contract (m (-> integer? (values integer? integer?)))) 
+             (object-contract (m (-> integer? (values integer? integer?)))))
+  (test-name '(object-contract (m (case-> (-> integer? integer? integer?)
+                                          (-> integer? (values integer? integer?)))))
+             (object-contract (m (case-> 
+                                  (-> integer? integer? integer?)
+                                  (-> integer? (values integer? integer?))))))
+  (test-name
+   '(object-contract (m (case-> (-> integer? symbol?)
+                                (-> integer? boolean? symbol?)
+                                (-> integer? boolean? number? symbol?))))
+   (object-contract (m (opt->* (integer?) (boolean? number?) (symbol?)))))
+  (test-name
+    '(object-contract (m (case-> (-> integer? symbol?)
+                                 (-> integer? boolean? symbol?)
+                                 (-> integer? boolean? number? symbol?))))
+   (object-contract (m (opt-> (integer?) (boolean? number?) symbol?))))
+  (test-name
+    '(object-contract (m (case-> (-> integer? any)
+                                 (-> integer? boolean? any)
+                                 (-> integer? boolean? number? any))))
+   (object-contract (m (opt->* (integer?) (boolean? number?) any))))
+  (test-name
+    '(object-contract (m (case-> (-> integer? (values symbol? boolean?))
+                                 (-> integer? boolean? (values symbol? boolean?)))))
+   (object-contract (m (opt->* (integer?) (boolean?) (symbol? boolean?)))))
+  
+  (test-name '(object-contract (m (->r ((x ...)) ...))) (object-contract (m (->r ((x number?)) number?))))
+  (test-name '(object-contract (m (->r ((x ...) (y ...) (z ...)) ...))) 
+             (object-contract (m (->r ((x number?) (y boolean?) (z pair?)) number?))))
+  (test-name '(object-contract (m (->r ((x ...) (y ...) (z ...)) rest-x ... ...))) 
+             (object-contract (m (->r ((x number?) (y boolean?) (z pair?)) rest-x any/c number?))))
+  (test-name '(promise/c any/c) (promise/c any/c))
+  (test-name '(struct/c st integer?) 
+             (let ()
+               (define-struct st (a))
+               (struct/c st integer?)))
+  ))
+(report-errs)
diff --git a/collects/tests/mzscheme/cover-teach.ss b/collects/tests/mzscheme/cover-teach.ss
new file mode 100644
index 0000000000..97c4e91903
--- /dev/null
+++ b/collects/tests/mzscheme/cover-teach.ss
@@ -0,0 +1,32 @@
+
+(define teach-dir (build-path (collection-path "lang") "private"))
+(define compiled-file (build-path teach-dir "compiled" "teach.zo"))
+(define saved-file (string-append compiled-file ".save"))
+
+(define compiled? (file-exists? compiled-file))
+(when compiled?
+  (rename-file-or-directory compiled-file saved-file))
+
+(require (lib "errortrace.ss" "errortrace"))
+
+(execute-counts-enabled #t)
+(dynamic-require '(lib "teach.ss" "lang" "private") #f)
+(execute-counts-enabled #f)
+
+(when compiled?
+  (rename-file-or-directory saved-file compiled-file))
+
+(load "beginner.ss")
+(require mzscheme)
+(load "beginner-abbr.ss")
+(require mzscheme)
+(load "intermediate.ss")
+(require mzscheme)
+(load "advanced.ss")
+(require mzscheme)
+
+(with-output-to-file "teach-annotated.ss"
+  (lambda ()
+    (annotate-executed-file (build-path (collection-path "lang") "private" "teach.ss")))
+  'truncate/replace)
+
diff --git a/collects/tests/mzscheme/date.ss b/collects/tests/mzscheme/date.ss
new file mode 100644
index 0000000000..c02f4c85ba
--- /dev/null
+++ b/collects/tests/mzscheme/date.ss
@@ -0,0 +1,41 @@
+
+(load-relative "loadtest.ss")
+
+(SECTION 'date)
+
+(require (lib "date.ss"))
+
+(define (test-find s m h d mo y)
+  (let* ([secs (find-seconds s m h d mo y)]
+	 [date (seconds->date secs)])
+    (test #t 'same
+	  (and (= s (date-second date))
+	       (= m (date-minute date))
+	       (= h (date-hour date))
+	       (= d (date-day date))
+	       (= mo (date-month date))
+	       (= y (date-year date))))))
+
+(test-find 0 0 0 1 4 1975)
+(test-find 0 0 0 1 4 2005)
+
+; Bad dates
+(err/rt-test (find-seconds 0 0 0 0 0 1990) exn:fail?)
+(err/rt-test (find-seconds 0 0 0 0 1 1990) exn:fail?)
+(err/rt-test (find-seconds 0 0 0 1 0 1990) exn:fail?)
+
+; Early/late
+(err/rt-test (find-seconds 0 0 0 1 1 1490) exn:fail?)
+(err/rt-test (find-seconds 0 0 0 1 1 2890) exn:fail?)
+
+; 1990 April 1 was start of daylight savings:
+(test-find 0 0 1 1 4 1990) ; ok
+(let ([s (find-seconds 1 0 3 1 4 1990)]) ; ok
+  (when (date-dst? (seconds->date s))
+	; We have daylight savings here; 2:01 AM doesn't exist
+	(err/rt-test (find-seconds 0 1 2 1 4 1990) exn:fail?)
+	; This date is ambiguous; find-seconds should find
+	;  one of the two possible values, though:
+	(test-find 0 30 1 27 10 1996)))
+
+(report-errs)
diff --git a/collects/tests/mzscheme/deep.ss b/collects/tests/mzscheme/deep.ss
new file mode 100644
index 0000000000..025806e75d
--- /dev/null
+++ b/collects/tests/mzscheme/deep.ss
@@ -0,0 +1,156 @@
+
+(load-relative "loadtest.ss")
+
+(SECTION 'deep)
+
+; Test deep stacks
+
+(define (nontail-loop n esc)
+  (let loop ([n n])
+    (if (zero? n)
+	(esc 0)
+	(sub1 (loop (sub1 n))))))
+
+(define proc-depth (find-depth (lambda (n) (nontail-loop n (lambda (x) x)))))
+(printf "non-tail loop overflows at ~a~n" proc-depth)
+
+(test (- proc-depth) 'deep-recursion (nontail-loop proc-depth (lambda (x) x)))
+
+(test 0 'deep-recursion-escape/ec
+      (let/ec k
+	(nontail-loop proc-depth k)))
+
+(test 0 'deep-recursion-escape/cc
+      (let/cc k
+	(nontail-loop proc-depth k)))
+
+(test 0 'deep-recursion-resume/escape
+      ((let/ec k
+	 (nontail-loop proc-depth
+		       (lambda (v)
+			 (let/cc inside
+			   (k inside))
+			 (k (lambda () 0)))))))
+
+(test 0 'deep-recursion-resume/escape/thread
+      (let ([v #f])
+	(thread-wait
+	 (thread 
+	  (lambda ()
+	    (set! v 
+		  ((let/ec k
+		     (nontail-loop proc-depth
+				   (lambda (v)
+				     (let/cc inside
+				       (k (lambda () 
+					    (thread-wait (thread inside))
+					    0)))
+				     (k (lambda () 0))))))))))
+	v))
+
+(test (- proc-depth) 'deep-recursion-resume
+      ((lambda (x) (if (procedure? x) (x) x))
+       (let/ec k
+	 (nontail-loop proc-depth
+		       (lambda (v)
+			 (let/cc inside
+			   (k inside))
+			 0)))))
+
+(define (read-deep depth)
+  (define paren-port
+    (let* ([depth depth]
+	   [closing? #f]
+	   [count depth])
+      (make-input-port
+       'name
+       (lambda (s)
+	 (bytes-set!
+	  s
+	  0
+	  (cond
+	   [closing?
+	    (if (= count depth)
+		eof
+		(begin
+		  (set! count (add1 count))
+		  (char->integer #\)) ))]
+	   [else
+	    (set! count (sub1 count))
+	    (when (zero? count)
+	      (set! closing? #t))
+	    (char->integer #\()]))
+	 1)
+       #f
+       void)))
+  (read paren-port))
+
+(define read-depth (find-depth read-deep))
+(printf "nested paren read overflows at ~a~n" read-depth)
+
+(define deep-list (read-deep read-depth))
+
+(test #t 'read-deep (pair? deep-list))
+
+(define s (open-output-string))
+(display deep-list s)
+(test 'ok 'display 'ok)
+
+(test #t 'equal? (equal? deep-list (read (open-input-string (get-output-string s)))))
+
+(define going? #t)
+(define (equal?-forever l1 l2 deep?)
+  (let ([t (thread (lambda () 
+		     (equal? l1 l2) ; runs forever; could run out of memory
+		     (set! going? #f)))]
+	[v1 (make-vector 6)]
+	[v2 (make-vector 6)])
+    (if deep?
+	(begin
+	  (sleep)
+	  (vector-set-performance-stats! v1)
+	  (let loop ()
+	    (sleep)
+	    (vector-set-performance-stats! v2)
+	    (unless (> (vector-ref v2 5)
+		       (+ (vector-ref v1 5) 2))
+	      (loop))))
+	(sleep 0.3))
+    (kill-thread t)
+    going?))
+
+
+(define l1 (cons 0 #f))
+(set-cdr! l1 l1)
+(define l2 (cons 0 #f))
+(set-cdr! l2 l2)
+(test #t 'equal?-forever (equal?-forever l1 l2 #f))
+
+(define l1 (cons 0 #f))
+(set-car! l1 l1)
+(define l2 (cons 0 #f))
+(set-car! l2 l2)
+(test #t 'equal?-forever/memory (equal?-forever l1 l2 #t))
+
+(define l1 (vector 0))
+(vector-set! l1 0 l1)
+(define l2 (vector 0))
+(vector-set! l2 0 l2)
+(test #t 'equal?-forever/vector (equal?-forever l1 l2 #t))
+
+(define-struct a (b c) (make-inspector))
+(define l1 (make-a 0 #f))
+(set-a-b! l1 l1)
+(define l2 (make-a 0 #f))
+(set-a-b! l2 l2)
+(test #t 'equal?-forever/struct (equal?-forever l1 l2 #t))
+
+(define l1 (box 0))
+(set-box! l1 l1)
+(define l2 (box 0))
+(set-box! l2 l2)
+(test #t 'equal?-forever/box (equal?-forever l1 l2 #f))
+
+(test #t 'equal?-forever/box (call-in-nested-thread (lambda () (equal?-forever l1 l2 #f))))
+
+(report-errs)
diff --git a/collects/tests/mzscheme/em-imp.ss b/collects/tests/mzscheme/em-imp.ss
new file mode 100644
index 0000000000..69a97a0956
--- /dev/null
+++ b/collects/tests/mzscheme/em-imp.ss
@@ -0,0 +1,467 @@
+;;; -*- scheme -*-
+;;; Fortran-style implementation of an EM clustering algorithm.
+;;;
+;;; Written by Jeffrey Mark Siskind (qobi@cs.toronto.edu)
+;;; R4RS-ified by by Lars Thomas Hansen (lth@cs.uoregon.edu)
+;;; Random number generator by Ozan Yigit.
+;;;
+;;; To run: (run-benchmark)
+;;; You must provide your own timer function.
+;;;
+;;; Some benchmark times:
+;;;
+;;; Chez Scheme 4.1 for SunOS running on Sparc 10/51 (1MB,96MB,50MHz), Solaris:
+;;;   Optimize-level 2: 112s run (CPU), 2.8s gc, 326 MB allocated, 1181 GCs
+;;;   Optimize-level 3:  79s run (CPU), 2.8s gc, 326 MB allocated, 1163 GCs
+
+(define make-model vector)
+(define (model-pi model) (vector-ref model 0))
+(define (set-model-pi! model x) (vector-set! model 0 x))
+(define (model-mu model) (vector-ref model 1))
+(define (model-sigma model) (vector-ref model 2))
+(define (model-log-pi model) (vector-ref model 3))
+(define (set-model-log-pi! model x) (vector-set! model 3 x))
+(define (model-sigma-inverse model) (vector-ref model 4))
+(define (model-log-determinant-sigma model) (vector-ref model 5))
+(define (set-model-log-sigma-determinant! model x) (vector-set! model 5 x))
+
+;---------------------------------------------------------------------------
+; Minimal Standard Random Number Generator
+; Park & Miller, CACM 31(10), Oct 1988, 32 bit integer version.
+; better constants, as proposed by Park.
+; By Ozan Yigit
+
+(define *seed* 1)
+
+(define (srand seed)
+  (set! *seed* seed)
+  *seed*)
+
+(define (rand)
+  (let ((A 48271)
+        (M 2147483647)
+        (Q 44488)
+        (R 3399))
+    (let* ((hi (quotient *seed* Q))
+           (lo (modulo *seed* Q))
+           (test (- (* A lo) (* R hi))))
+      (if (> test 0)
+          (set! *seed* test)
+          (set! *seed* (+ test M)))))
+  *seed*)
+
+;---------------------------------------------------------------------------
+
+(define (panic s) (error 'panic s))
+
+(define *rand-max* 2147483648)
+
+(define log-math-precision 35.0)
+
+(define minus-infinity (- *rand-max*))
+
+(define first car)
+
+(define second cadr)
+
+(define rest cdr)
+
+(define (reduce f l i)
+ (cond ((null? l) i)
+       ((null? (rest l)) (first l))
+       (else (let loop ((l (rest l)) (c (first l)))
+	      (if (null? l) c (loop (rest l) (f c (first l))))))))
+
+(define (every-n p n)
+ (let loop ((i 0)) (or (>= i n) (and (p i) (loop (+ i 1))))))
+
+(define (sum f n)
+ (let loop ((n (- n 1)) (c 0.0))
+  (if (negative? n) c (loop (- n 1) (+ c (f n))))))
+
+(define (add-exp e1 e2)
+ (let* ((e-max (max e1 e2))
+	(e-min (min e1 e2))
+	(factor (floor e-min)))
+  (if (= e-max minus-infinity)
+      minus-infinity
+      (if (> (- e-max factor) log-math-precision)
+	  e-max
+	  (+ (log (+ (exp (- e-max factor)) (exp (- e-min factor))))
+	     factor)))))
+
+(define (map-n f n)
+ (let loop ((i 0) (c '()))
+  (if (< i n) (loop (+ i 1) (cons (f i) c)) (reverse c))))
+
+(define (map-n-vector f n)
+ (let ((v (make-vector n)))
+  (let loop ((i 0))
+   (if (< i n)
+       (begin (vector-set! v i (f i))
+	      (loop (+ i 1)))))
+  v))
+
+(define (remove-if-not p l)
+ (let loop ((l l) (c '()))
+  (cond ((null? l) (reverse c))
+	((p (first l)) (loop (rest l) (cons (first l) c)))
+	(else (loop (rest l) c)))))
+
+(define (positionv x l)
+ (let loop ((l l) (i 0))
+  (cond ((null? l) #f)
+	((eqv? x (first l)) i)
+	(else (loop (rest l) (+ i 1))))))
+
+(define (make-matrix m n)
+  (map-n-vector (lambda (i) (make-vector n)) m))
+
+(define (make-matrix-initial m n initial)
+  (map-n-vector (lambda (i) (make-vector n initial)) m))
+
+(define (matrix-rows a) (vector-length a))
+
+(define (matrix-columns a) (vector-length (vector-ref a 0)))
+
+(define (matrix-ref a i j) (vector-ref (vector-ref a i) j))
+
+(define (matrix-set! a i j x) (vector-set! (vector-ref a i) j x))
+
+(define (matrix-row-ref a i) (vector-ref a i))
+
+(define (matrix-row-set! a i v) (vector-set! a i v))
+
+(define (determinant a)
+ (if (not (= (matrix-rows a) (matrix-columns a)))
+     (panic "Can only find determinant of a square matrix"))
+ (call-with-current-continuation
+  (lambda (return)
+   (let* ((n (matrix-rows a))
+	  (b (make-matrix n n))
+	  (d 1.0))
+    (do ((i 0 (+ i 1))) ((= i n))
+     (do ((j 0 (+ j 1))) ((= j n)) (matrix-set! b i j (matrix-ref a i j))))
+    (do ((i 0 (+ i 1))) ((= i n))
+     ;; partial pivoting reduces rounding errors
+     (let ((greatest (abs (matrix-ref b i i)))
+	   (index i))
+      (do ((j (+ i 1) (+ j 1))) ((= j n))
+       (let ((x (abs (matrix-ref b j i))))
+	(if (> x greatest) (begin (set! index j) (set! greatest x)))))
+      (if (= greatest 0.0) (return 0.0))
+      (if (not (= index i))
+       (let ((v (matrix-row-ref b i)))
+	(matrix-row-set! b i (matrix-row-ref b index))
+	(matrix-row-set! b index v)
+	(set! d (- d))))
+      (let ((c (matrix-ref b i i)))
+       (set! d (* d c))
+       (do ((j i (+ j 1))) ((= j n))
+	(matrix-set! b i j (/ (matrix-ref b i j) c)))
+       (do ((j (+ i 1) (+ j 1))) ((= j n))
+	(let ((e (matrix-ref b j i)))
+	 (do ((k (+ i 1) (+ k 1))) ((= k n))
+	  (matrix-set!
+	   b j k (- (matrix-ref b j k) (* e (matrix-ref b i k))))))))))
+    d))))
+
+(define (invert-matrix! a b)
+ (if (not (= (matrix-rows a) (matrix-columns a)))
+  (panic "Can only invert a square matrix"))
+ (let* ((n (matrix-rows a))
+	(c (make-matrix n n)))
+  (do ((i 0 (+ i 1))) ((= i n))
+   (do ((j 0 (+ j 1))) ((= j n))
+    (matrix-set! b i j 0.0)
+    (matrix-set! c i j (matrix-ref a i j))))
+  (do ((i 0 (+ i 1))) ((= i n)) (matrix-set! b i i 1.0))
+  (do ((i 0 (+ i 1))) ((= i n))
+   (if (zero? (matrix-ref c i i))
+       (call-with-current-continuation
+	(lambda (return)
+	  (do ((j 0 (+ j 1))) ((= j n))
+	    (if (and (> j i) (not (zero? (matrix-ref c j i))))
+		(begin
+		  (let ((e (vector-ref c i)))
+		    (vector-set! c i (vector-ref c j))
+		    (vector-set! c j e))
+		  (let ((e (vector-ref b i)))
+		    (vector-set! b i (vector-ref b j))
+		    (vector-set! b j e))
+		  (return #f))))
+	  (panic "Matrix is singular"))))
+   (let ((d (/ (matrix-ref c i i))))
+    (do ((j 0 (+ j 1))) ((= j n))
+     (matrix-set! c i j (* d (matrix-ref c i j)))
+     (matrix-set! b i j (* d (matrix-ref b i j))))
+    (do ((k 0 (+ k 1))) ((= k n))
+     (let ((d (- (matrix-ref c k i))))
+      (if (not (= k i))
+       (do ((j 0 (+ j 1))) ((= j n))
+	(matrix-set!
+	 c k j (+ (matrix-ref c k j) (* d (matrix-ref c i j))))
+	(matrix-set!
+	 b k j (+ (matrix-ref b k j) (* d (matrix-ref b i j))))))))))))
+
+(define (jacobi! a)
+ (if (not (and (= (matrix-rows a) (matrix-columns a))
+	      (every-n (lambda (i)
+			(every-n (lambda (j)
+				  (= (matrix-ref a i j) (matrix-ref a j i)))
+				 (matrix-rows a)))
+		       (matrix-rows a))))
+  (panic "Can only compute eigenvalues/eigenvectors of a symmetric matrix"))
+ (let* ((n (matrix-rows a))
+	(d (make-vector n))
+	(v (make-matrix-initial n n 0.0))
+	(b (make-vector n))
+	(z (make-vector n 0.0)))
+  (do ((ip 0 (+ ip 1))) ((= ip n))
+   (matrix-set! v ip ip 1.0)
+   (vector-set! b ip (matrix-ref a ip ip))
+   (vector-set! d ip (matrix-ref a ip ip)))
+  (let loop ((i 0))
+   (if (> i 50) (panic "Too many iterations in JACOBI!"))
+   (let ((sm (sum (lambda (ip)
+		   (sum (lambda (ir)
+			 (let ((iq (+ ip ir 1)))
+			  (abs (matrix-ref a ip iq))))
+			(- n ip 1)))
+		  (- n 1))))
+    (if (not (zero? sm))
+	(begin
+	  (let ((tresh (if (< i 3) (/ (* 0.2 sm) (* n n)) 0.0)))
+	    (do ((ip 0 (+ ip 1))) ((= ip (- n 1)))
+	      (do ((ir 0 (+ ir 1))) ((= ir (- n ip 1)))
+		(let* ((iq (+ ip ir 1))
+		       (g (* 100.0 (abs (matrix-ref a ip iq)))))
+		  (cond
+		   ((and (> i 3)
+			 (= (+ (abs (vector-ref d ip)) g)
+			    (abs (vector-ref d ip)))
+			 (= (+ (abs (vector-ref d iq)) g)
+			    (abs (vector-ref d iq))))
+		    (matrix-set! a ip iq 0.0))
+		   ((> (abs (matrix-ref a ip iq)) tresh)
+		    (let* ((h (- (vector-ref d iq) (vector-ref d ip)))
+			   (t (if (= (+ (abs h) g) (abs h))
+				  (/ (matrix-ref a ip iq) h)
+				  (let ((theta (/ (* 0.5 h)
+						  (matrix-ref a ip iq))))
+				    (if (negative? theta)
+					(- (/ (+ (abs theta)
+						 (sqrt (+ (* theta theta) 1.0)))))
+					(/ (+ (abs theta)
+					      (sqrt (+ (* theta theta) 1.0))))))))
+			   (c (/ (sqrt (+ (* t t) 1.0))))
+			   (s (* t c))
+			   (tau (/ s (+ c 1.0)))
+			   (h (* t (matrix-ref a ip iq))))
+		      (define (rotate a i j k l)
+			(let ((g (matrix-ref a i j))
+			      (h (matrix-ref a k l)))
+			  (matrix-set! a i j (- g (* s (+ h (* g tau)))))
+			  (matrix-set! a k l (+ h (* s (- g (* h tau)))))))
+		      (vector-set! z ip (- (vector-ref z ip) h))
+		      (vector-set! z iq (+ (vector-ref z iq) h))
+		      (vector-set! d ip (- (vector-ref d ip) h))
+		      (vector-set! d iq (+ (vector-ref d iq) h))
+		      (matrix-set! a ip iq 0.0)
+		      (do ((j 0 (+ j 1))) ((= j n))
+			(cond ((< j ip) (rotate a j ip j iq))
+			      ((< ip j iq) (rotate a ip j j iq))
+			      ((< iq j) (rotate a ip j iq j)))
+			(rotate v j ip j iq)))))))))
+	  (do ((ip 0 (+ ip 1))) ((= ip n))
+	    (vector-set! b ip (+ (vector-ref b ip) (vector-ref z ip)))
+	    (vector-set! d ip (vector-ref b ip))
+	    (vector-set! z ip 0.0))
+	  (loop (+ i 1))))))
+  (do ((i 0 (+ i 1))) ((= i (- n 1)))
+   (let ((k i)
+	 (p (vector-ref d i)))
+    (do ((l 0 (+ l 1))) ((= l (- n i 1)))
+     (let* ((j (+ i l 1)))
+      (if (>= (vector-ref d j) p)
+	  (begin (set! k j) (set! p (vector-ref d j))))))
+    (if (not (= k i))
+	(begin (vector-set! d k (vector-ref d i))
+	       (vector-set! d i p)
+	       (do ((j 0 (+ j 1))) ((= j n))
+		 (let ((p (matrix-ref v j i)))
+		   (matrix-set! v j i (matrix-ref v j k))
+		   (matrix-set! v j k p)))))))
+  (list d v)))
+
+(define (clip-eigenvalues! a v)
+ (let* ((j (jacobi! a))
+	(l (first j))
+	(e (second j)))
+  (do ((k1 0 (+ k1 1))) ((= k1 (vector-length a)))
+   (let ((a-k1 (vector-ref a k1))
+	 (e-k1 (vector-ref e k1)))
+    (do ((k2 0 (+ k2 1))) ((= k2 (vector-length a-k1)))
+     (let ((e-k2 (vector-ref e k2))
+	   (s 0.0))
+      (do ((k 0 (+ k 1))) ((= k (vector-length a)))
+       (set! s (+ s (* (max (vector-ref v k) (vector-ref l k))
+		       (vector-ref e-k1 k)
+		       (vector-ref e-k2 k)))))
+      (vector-set! a-k1 k2 s)))))))
+
+;;; EM
+
+(define (e-step! x z models)
+ (do ((i 0 (+ i 1))) ((= i (vector-length x)))
+  (let ((xi (vector-ref x i))
+	(zi (vector-ref z i)))
+   (do ((j 0 (+ j 1))) ((= j (vector-length models)))
+    ;; Compute for each model.
+    (let* ((model (vector-ref models j))
+	   (log-pi (model-log-pi model))
+	   (mu (model-mu model))
+	   (sigma-inverse (model-sigma-inverse model))
+	   (log-determinant-sigma (model-log-determinant-sigma model))
+	   (t 0.0))
+     ;; Compute likelihoods (note: up to constant for all models).
+     (set! t 0.0)
+     (do ((k1 0 (+ k1 1))) ((= k1 (vector-length xi)))
+      (let ((sigma-inverse-k1 (vector-ref sigma-inverse k1)))
+       (do ((k2 0 (+ k2 1))) ((= k2 (vector-length xi)))
+	(set! t (+ t (* (- (vector-ref xi k1) (vector-ref mu k1))
+			(vector-ref sigma-inverse-k1 k2)
+			(- (vector-ref xi k2) (vector-ref mu k2))))))))
+     (vector-set! zi j (- log-pi (* 0.5 (+ log-determinant-sigma t))))))))
+ (let ((l 0.0))
+  (do ((i 0 (+ i 1))) ((= i (vector-length x)))
+   (let ((s minus-infinity)
+	 (zi (vector-ref z i)))
+    ;; Normalize ownerships to sum to one.
+    (do ((j 0 (+ j 1))) ((= j (vector-length models)))
+     (set! s (add-exp s (vector-ref zi j))))
+    (do ((j 0 (+ j 1))) ((= j (vector-length models)))
+     (vector-set! zi j (exp (- (vector-ref zi j) s))))
+    (set! l (+ l s))))
+  ;; Return log likelihood.
+  l))
+
+(define (m-step! x models z clip)
+ (let ((kk (vector-length (vector-ref x 0))))
+  ;; For each model, optimize parameters.
+  (do ((j 0 (+ j 1))) ((= j (vector-length models)))
+   (let* ((model (vector-ref models j))
+	  (mu (model-mu model))
+	  (sigma (model-sigma model))
+	  (s 0.0))
+    ;; Optimize values.
+    (do ((k 0 (+ k 1))) ((= k kk))
+     (do ((i 0 (+ i 1))) ((= i (vector-length x)))
+      (set! s (+ s (vector-ref (vector-ref z i) j)))))
+    (do ((k 0 (+ k 1))) ((= k kk))
+     (let ((m 0.0))
+      (do ((i 0 (+ i 1))) ((= i (vector-length x)))
+       (set! m (+ m (* (vector-ref (vector-ref z i) j)
+		       (vector-ref (vector-ref x i) k)))))
+      (vector-set! mu k (/ m s))))
+    (do ((k1 0 (+ k1 1))) ((= k1 kk))
+     (let ((sigma-k1 (vector-ref sigma k1))
+	   (mu-k1 (vector-ref mu k1)))
+      (do ((k2 0 (+ k2 1))) ((= k2 kk))
+       (let ((mu-k2 (vector-ref mu k2))
+	     (m 0.0))
+	(do ((i 0 (+ i 1))) ((= i (vector-length x)))
+	 (set! m (+ m (* (vector-ref (vector-ref z i) j)
+			 (- (vector-ref (vector-ref x i) k1) mu-k1)
+			 (- (vector-ref (vector-ref x i) k2) mu-k2)))))
+	(vector-set! sigma-k1 k2 (/ m s))))))
+    (clip-eigenvalues! sigma clip)
+    (set-model-pi! model (/ s (vector-length x)))
+    (set-model-log-pi! model (log (/ s (vector-length x))))
+    (invert-matrix! sigma (model-sigma-inverse model))
+    (set-model-log-sigma-determinant! model (log (determinant sigma)))))))
+
+(define (em! x z models clip em-kick-off-tolerance em-convergence-tolerance)
+ (let loop ((old-log-likelihood minus-infinity) (starting? #t))
+  (let ((log-likelihood (e-step! x z models)))
+   (cond
+    ((or (and starting? (> log-likelihood old-log-likelihood))
+	 (> log-likelihood (+ old-log-likelihood em-convergence-tolerance)))
+     (m-step! x models z clip)
+     (loop log-likelihood
+	   (and starting?
+		(not (= (vector-length models) 1))
+		(or (= old-log-likelihood minus-infinity)
+		    (< log-likelihood
+		       (+ old-log-likelihood em-kick-off-tolerance))))))
+    (else old-log-likelihood)))))
+
+(define (noise epsilon) (- (* 2.0 epsilon (/ (rand) *rand-max*)) epsilon))
+
+(define (initial-z ii jj)
+ (map-n-vector
+  (lambda (i)
+   (let ((zi (map-n-vector (lambda (j) (+ (/ jj) (noise (/ jj)))) jj))
+	 (s 0.0))
+    (do ((j 0 (+ j 1))) ((= j jj)) (set! s (+ s (vector-ref zi j))))
+    (do ((j 0 (+ j 1))) ((= j jj)) (vector-set! zi j (/ (vector-ref zi j) s)))
+    zi))
+  ii))
+
+(define (ems x clip em-kick-off-tolerance em-convergence-tolerance
+	     ems-convergence-tolerance)
+ (let loop ((jj 1)
+	    (old-z #f)
+	    (old-models #f)
+	    (old-log-likelihood minus-infinity))
+  (let* ((kk (vector-length (vector-ref x 0)))
+	 (z (initial-z (vector-length x) jj))
+	 (models (map-n-vector
+		  (lambda (j)
+		   (make-model 0.0
+			       (make-vector kk)
+			       (make-matrix kk kk)
+			       0.0
+			       (make-matrix kk kk)
+			       0.0))
+		  jj)))
+   (m-step! x models z clip)
+   (let ((new-log-likelihood
+	  (em!
+	   x z models clip em-kick-off-tolerance em-convergence-tolerance)))
+    (if (> (- (/ old-log-likelihood new-log-likelihood) 1.0)
+	   ems-convergence-tolerance)
+	(loop (+ jj 1) z models new-log-likelihood)
+	(list old-z old-models))))))
+
+(define (em-clusterer x clip em-kick-off-tolerance em-convergence-tolerance
+		      ems-convergence-tolerance)
+ (let* ((z-models (ems x clip em-kick-off-tolerance
+		       em-convergence-tolerance
+		       ems-convergence-tolerance))
+	(z (first z-models))
+	(models (second z-models)))
+  (e-step! x z models)
+  (let ((clusters
+	 (map-n (lambda (i)
+		 (let ((zi (vector->list (vector-ref z i))))
+		  (list i (positionv (reduce max zi minus-infinity) zi))))
+		(vector-length z))))
+   (map-n (lambda (j)
+	   (map (lambda (cluster) (vector-ref x (first cluster)))
+		(remove-if-not (lambda (cluster) (= (second cluster) j))
+			       clusters)))
+	  (vector-length (vector-ref z 0))))))
+
+(define (go)
+  (em-clusterer
+   '#(#(1.0) #(2.0) #(3.0) #(11.0) #(12.0) #(13.0)) '#(1.0) 10.0 1.0 0.01))
+
+(define (run-benchmark)
+  (srand 1)
+  (do ((i 0 (+ i 1))) ((= i 100))
+    (write (go))
+    (newline)))
+
+; eof
+
diff --git a/collects/tests/mzscheme/embed-me1.ss b/collects/tests/mzscheme/embed-me1.ss
new file mode 100644
index 0000000000..7e2bb11748
--- /dev/null
+++ b/collects/tests/mzscheme/embed-me1.ss
@@ -0,0 +1,5 @@
+(module embed-me1 mzscheme
+  (with-output-to-file "stdout"
+    (lambda () (printf "This is 1~n"))
+    'append))
+
diff --git a/collects/tests/mzscheme/embed-me2.ss b/collects/tests/mzscheme/embed-me2.ss
new file mode 100644
index 0000000000..f0216b0381
--- /dev/null
+++ b/collects/tests/mzscheme/embed-me2.ss
@@ -0,0 +1,9 @@
+(module embed-me2 mzscheme
+  (require "embed-me1.ss"
+	   (lib "etc.ss"))
+  (with-output-to-file "stdout"
+    (lambda () (printf "This is 2: ~a~n" true))
+    'append))
+
+
+
diff --git a/collects/tests/mzscheme/embed-me3.ss b/collects/tests/mzscheme/embed-me3.ss
new file mode 100644
index 0000000000..a68cf78d4a
--- /dev/null
+++ b/collects/tests/mzscheme/embed-me3.ss
@@ -0,0 +1,7 @@
+(module embed-me3 mzscheme
+  (require (lib "etc.ss"))
+  (with-output-to-file "stdout"
+    (lambda () 
+      (printf "3 is here, too? ~a\n" true))
+    'append))
+
diff --git a/collects/tests/mzscheme/embed-me4.ss b/collects/tests/mzscheme/embed-me4.ss
new file mode 100644
index 0000000000..24e22b0787
--- /dev/null
+++ b/collects/tests/mzscheme/embed-me4.ss
@@ -0,0 +1,4 @@
+(with-output-to-file "stdout"
+  (lambda () (printf "This is the literal expression 4.\n"))
+  'append)
+
diff --git a/collects/tests/mzscheme/embed-me5.ss b/collects/tests/mzscheme/embed-me5.ss
new file mode 100644
index 0000000000..aaf471f21f
--- /dev/null
+++ b/collects/tests/mzscheme/embed-me5.ss
@@ -0,0 +1,6 @@
+(module embed-me5 mzscheme
+  (require (lib "mred.ss" "mred"))
+  (with-output-to-file "stdout"
+    (lambda () (printf "This is 5: ~s\n" button%))
+    'append))
+
diff --git a/collects/tests/mzscheme/embed.ss b/collects/tests/mzscheme/embed.ss
new file mode 100644
index 0000000000..2ffa11ba44
--- /dev/null
+++ b/collects/tests/mzscheme/embed.ss
@@ -0,0 +1,173 @@
+
+(load-relative "loadtest.ss")
+
+(SECTION 'embed)
+
+(require (lib "embed.ss" "compiler")
+	 (lib "process.ss"))
+
+(define (mk-dest mred?)
+  (build-path (find-system-path 'temp-dir) 
+	      (case (system-type)
+		[(windows) "e.exe"]
+		[(unix) "e"]
+		[(macosx) (if mred?
+			      "e.app"
+			      "e")])))
+
+(define mz-dest (mk-dest #f))
+(define mr-dest (mk-dest #t))
+
+(define (prepare exe src)
+  (printf "Making ~a with ~a...~n" exe src)
+  (when (file-exists? exe)
+    (delete-file exe)))
+
+(define (try-exe exe expect mred?)
+  (let ([plthome (getenv "PLTHOME")]
+	[collects (getenv "PLTCOLLECTS")])
+    ;; Try to hide usual collections:
+    (when plthome
+      (putenv "PLTHOME" (path->string (find-system-path 'temp-dir))))
+    (when collects
+      (putenv "PLTCOLLECTS" (path->string (find-system-path 'temp-dir))))
+    ;; Execute:
+    (parameterize ([current-directory (find-system-path 'temp-dir)])
+      (when (file-exists? "stdout")
+	(delete-file "stdout"))
+      (system* (if (and mred? (eq? 'macosx (system-type)))
+		   (let-values ([(base name dir?) (split-path exe)])
+		     (build-path exe "Contents" "MacOS"
+				 (path-replace-suffix name #"")))
+		   exe)))
+    (when plthome
+      (putenv "PLTHOME" plthome))
+    (when collects
+      (putenv "PLTCOLLECTS" collects))
+    (test expect with-input-from-file (build-path (find-system-path 'temp-dir) "stdout") 
+	  (lambda () (read-string 5000)))))
+
+(define (mz-tests mred?)
+  (define dest (if mred? mr-dest mz-dest))
+  (define (flags s)
+    (string-append "-" (if mred? "Z" "") "mvq" s))
+  (define (one-mz-test filename expect)
+    ;; Try simple mode: one module, launched from cmd line:
+    (prepare dest filename)
+    (make-embedding-executable 
+     dest mred? #f
+     `((#t (lib ,filename "tests" "mzscheme")))
+     null
+     null
+     `(,(flags "L") ,filename "tests/mzscheme"))
+    (try-exe dest expect mred?)
+
+    ;; Try explicit prefix:
+    (let ([w/prefix
+	   (lambda (pfx)
+	     (prepare dest filename)
+	     (make-embedding-executable 
+	      dest mred? #f
+	      `((,pfx (lib ,filename "tests" "mzscheme")))
+	      null
+	      null
+	      `(,(flags "e") ,(format "(require ~a~a)" 
+				      (or pfx "")
+				      (regexp-replace #rx"[.].*$" filename ""))))
+	     (try-exe dest expect mred?))])
+      (w/prefix #f)
+      (w/prefix 'before:))
+
+    ;; Try full path, and use literal S-exp to start
+    (prepare dest filename)
+    (let ([path (build-path (collection-path "tests" "mzscheme") filename)])
+      (make-embedding-executable 
+       dest mred? #f
+       `((#t ,path))
+       null
+       `(require (file ,(path->string path)))
+       `(,(flags ""))))
+    (try-exe dest expect mred?)
+
+    ;; Use `file' form:
+    (prepare dest filename)
+    (let ([path (build-path (collection-path "tests" "mzscheme") filename)])
+      (make-embedding-executable 
+       dest mred? #f
+       `((#t (file ,(path->string path))))
+       null
+       `(require (file ,(path->string path)))
+       `(,(flags ""))))
+    (try-exe dest expect mred?)
+
+    ;; Use relative path
+    (prepare dest filename)
+    (parameterize ([current-directory (collection-path "tests" "mzscheme")])
+      (make-embedding-executable 
+       dest mred? #f
+       `((#f ,filename))
+       null
+       `(require ,(string->symbol (regexp-replace #rx"[.].*$" filename "")))
+       `(,(flags ""))))
+    (try-exe dest expect mred?)
+
+    ;; Try multiple modules
+    (prepare dest filename)
+    (make-embedding-executable 
+     dest mred? #f
+     `((#t (lib ,filename "tests" "mzscheme"))
+       (#t (lib "embed-me3.ss" "tests" "mzscheme")))
+     null
+     `(begin
+	(require (lib "embed-me3.ss" "tests" "mzscheme"))
+	(require (lib ,filename "tests" "mzscheme")))
+     `(,(flags "")))
+    (try-exe dest (string-append "3 is here, too? #t\n" expect) mred?)
+
+    ;; Try a literal file
+    (prepare dest filename)
+    (make-embedding-executable 
+     dest mred? #f
+     `((#t (lib ,filename "tests" "mzscheme")))
+     (list (build-path (collection-path "tests" "mzscheme") "embed-me4.ss"))
+     `(with-output-to-file "stdout"
+	(lambda () (display "... and more!\n"))
+	'append)
+     `(,(flags "L") ,filename "tests/mzscheme"))
+    (try-exe dest (string-append 
+		      "This is the literal expression 4.\n" 
+		      "... and more!\n"
+		      expect)
+	     mred?))
+
+  (one-mz-test "embed-me1.ss" "This is 1\n")
+  (one-mz-test "embed-me2.ss" "This is 1\nThis is 2: #t\n")
+
+  ;; Try unicode expr and cmdline:
+  (prepare dest "unicode")
+  (make-embedding-executable 
+   dest mred? #f
+   null
+   null
+   `(begin 
+      (define (out s)
+	(with-output-to-file "stdout"
+	  (lambda () (printf s))
+	  'append))
+      (out "\uA9, \u7238, and \U1D670\n"))
+   `(,(flags "e") "(out \"\u7237...\U1D671\n\")"))
+  (try-exe dest "\uA9, \u7238, and \U1D670\n\u7237...\U1D671\n" mred?))
+
+(mz-tests #f)
+(mz-tests #t)
+
+(prepare mr-dest "embed-me5.ss")
+(make-embedding-executable 
+ mr-dest #t #f
+ `((#t (lib "embed-me5.ss" "tests" "mzscheme")))
+ null
+ null
+ `("-ZmvqL" "embed-me5.ss" "tests/mzscheme"))
+(try-exe mr-dest "This is 5: #<struct:class:button%>\n" #t)
+
+(report-errs)
diff --git a/collects/tests/mzscheme/expand.ss b/collects/tests/mzscheme/expand.ss
new file mode 100644
index 0000000000..0c8a205ecf
--- /dev/null
+++ b/collects/tests/mzscheme/expand.ss
@@ -0,0 +1,154 @@
+
+(require (lib "toplevel.ss" "syntax"))
+
+(load-relative "loadtest.ss")
+
+;; test that expansion preserves source location information
+;; for fully expanded terms
+
+(SECTION 'EXPAND)
+
+(let () 
+  (define (compare-expansion stx) 
+    (let ([expanded (expand stx)])
+      (ensure-good-test-case stx expanded)
+      (test #t compare-objs stx expanded)))
+  
+  ;; o1 is the original, and o2 is the expansion result
+  (define (compare-objs o1 o2)
+    (let loop ([o1 o1]
+               [o2 o2]
+	       [extra-ok? #f])
+      (cond
+        [(both? syntax? o1 o2)
+         (and (sel-same syntax-position o1 o2)
+              (sel-same syntax-source o1 o2)
+              (sel-same syntax-column o1 o2)
+              (sel-same syntax-line o1 o2)
+              (loop (syntax-e o1) (syntax-e o2) #f))]
+        [(both? pair? o1 o2)
+         (and (loop (car o1) (car o2) #f)
+              (loop (cdr o1) (cdr o2) #t))]
+	[(both? vector? o1 o2)
+         (and (sel-same vector-length o1 o2)
+              (andmap (lambda (a b) (loop a b #f))
+                      (vector->list o1)
+                      (vector->list o2)))]
+        [(both? null? o1 o2) #t]
+        [(both? symbol? o1 o2)
+         (eq? o1 o2)]
+        [(both? boolean? o1 o2)
+         (equal? o1 o2)]
+	[(both? number? o1 o2)
+         (equal? o1 o2)]
+	[(both? string? o1 o2)
+         (equal? o1 o2)]
+	;; It's ok for `expand' to make more things syntax objects
+        [(and extra-ok? (pair? o1) (syntax? o2) (pair? (syntax-e o2)))
+	 (and (loop (car o1) (car (syntax-e o2)) #f)
+	      (loop (cdr o1) (cdr (syntax-e o2)) #t))]
+	[(and extra-ok? (null? o1) (syntax? o2) (null? (syntax-e o2)))
+	 #t]
+        [else #f])))
+  
+  ;; this error indicates that the expansion wasn't
+  ;; really idempotent, on the structure. Assume that
+  ;; the test case is broken, not expand.
+  (define (ensure-good-test-case o1 o2)
+    (let ([d1 (syntax-object->datum o1)]
+          [d2 (syntax-object->datum o2)])
+      (unless (equal? d1 d2)
+        (error 'compare-objs "bad test case: ~e ~e" d1 d2))))
+  
+  (define (sel-same sel o1 o2) (equal? (sel o1) (sel o2)))
+  (define (both? p? o1 o2) (and (p? o1) (p? o2)))
+  
+  (compare-expansion #''())
+  (compare-expansion #'(#%datum . 1))
+  (compare-expansion #'(#%datum . #t))
+  (compare-expansion #'(quote 1))
+  (compare-expansion #'(#%top . x))
+  (compare-expansion #'(if (#%top . a) (#%top . b) (#%top . c)))
+  (compare-expansion #'(if (#%top . a) (#%top . b)))
+  (compare-expansion #'(lambda () (#%top . x)))
+  (compare-expansion #'(lambda (x) x))
+  (compare-expansion #'(lambda (x y z) x))
+  (compare-expansion #'(lambda (x) x x x))
+  (compare-expansion #'(case-lambda))
+  (compare-expansion #'(case-lambda [() (#%datum . 1)]))
+  (compare-expansion #'(case-lambda [() (#%datum . 1)] [(x) x]))
+  (compare-expansion #'(case-lambda [(x y) x]))
+  (compare-expansion #'(define-values () (#%top . x)))
+  (compare-expansion #'(define-values (x) (#%top . x)))
+  (compare-expansion #'(define-values (x y z) (#%top . x)))
+  (compare-expansion #'(define-syntaxes () (#%top . x)))
+  (compare-expansion #'(define-syntaxes (s) (#%top . x)))
+  (compare-expansion #'(define-syntaxes (s x y) (#%top . x)))
+  (compare-expansion #'(require mzscheme))
+  (compare-expansion #'(require (lib "list.ss")))
+  (compare-expansion #'(require (lib "list.ss") mzscheme))
+  (compare-expansion #'(require-for-syntax mzscheme))
+  (compare-expansion #'(require-for-syntax (lib "list.ss")))
+  (compare-expansion #'(require-for-syntax (lib "list.ss") mzscheme))
+  (compare-expansion #'(begin))
+  (compare-expansion #'(begin (#%top . x)))
+  (compare-expansion #'(begin (#%top . x) (#%datum . 2)))
+  (compare-expansion #'(begin0 (#%top . x)))
+  (compare-expansion #'(begin0 (#%top . x) (#%datum . 2)))
+  (compare-expansion #'(begin0 (#%top . x) (#%datum . 2) (#%datum . 2)))
+  (compare-expansion #'(let-values () (#%top . q)))
+  (compare-expansion #'(let-values (((x y) (#%top . p))) (#%top . q)))
+  (compare-expansion #'(let-values (((x y) (#%top . p)) ((z) (#%datum . 12))) (#%top . q)))
+  (compare-expansion #'(let-values (((x y) (#%top . p))) (#%top . q) (#%top . p)))
+  (compare-expansion #'(letrec-values () (#%top . q)))
+  (compare-expansion #'(letrec-values (((x y) (#%top . p))) (#%top . q)))
+  (compare-expansion #'(letrec-values (((x y) (#%top . p)) ((z) (#%datum . 12))) (#%top . q)))
+  (compare-expansion #'(letrec-values (((x y) (#%top . p))) (#%top . q) (#%top . p)))
+  (compare-expansion #'(set! x (#%top . y)))
+  (compare-expansion #'(quote-syntax x))
+  (compare-expansion #'(with-continuation-mark (#%top . x) (#%top . x) (#%top . x)))
+  (compare-expansion #'(#%app (#%top . f)))
+  (compare-expansion #'(#%app (#%top . f) (#%datum . 1))))
+
+(define expand-test-use-toplevel? #f)
+
+(define datum->top-level-syntax-object
+  (lambda (v)
+    (namespace-syntax-introduce (datum->syntax-object #f v))))
+
+(define now-expanding (make-parameter #f))
+
+; Tests macro expansion by setting the eval handler and
+;  running all tests
+
+(namespace-variable-value 
+ 'expand-load
+ #f
+ (lambda ()
+   (namespace-set-variable-value! 'expand-load "quiet.ss")))
+
+(let ([orig (current-eval)])
+  (dynamic-wind
+   (lambda ()
+     (current-eval
+      (lambda (x)
+	(if (now-expanding)
+	    (orig x)
+	    (begin
+	      (set! mz-test-syntax-errors-allowed? #t)
+	      (let ([x (if (or (compiled-expression? x)
+			       (and (syntax? x) (compiled-expression? (syntax-e x))))
+			   x
+			   (parameterize ([current-module-name-prefix #f]
+					  [now-expanding expand-test-use-toplevel?])
+			     (expand-syntax
+			      ((if expand-test-use-toplevel?
+				   expand-top-level-with-compile-time-evals
+				   expand-syntax)
+			       ((if (syntax? x) values datum->top-level-syntax-object) x)))))])
+		(set! mz-test-syntax-errors-allowed? #f)
+		(orig x)))))))
+   (lambda ()
+     (load-relative expand-load))
+   (lambda ()
+     (current-eval orig))))
diff --git a/collects/tests/mzscheme/fact.ss b/collects/tests/mzscheme/fact.ss
new file mode 100644
index 0000000000..d991f2fc16
--- /dev/null
+++ b/collects/tests/mzscheme/fact.ss
@@ -0,0 +1,6 @@
+(define fact
+    (lambda (n)
+      (let loop ([n n][res 1])
+	(if (zero? n)
+	    res
+	    (loop (sub1 n) (* n res))))))
diff --git a/collects/tests/mzscheme/file.ss b/collects/tests/mzscheme/file.ss
new file mode 100644
index 0000000000..b64dac602a
--- /dev/null
+++ b/collects/tests/mzscheme/file.ss
@@ -0,0 +1,1397 @@
+
+(load-relative "loadtest.ss")
+
+(define testing.ss (build-path (current-load-relative-directory) "testing.ss"))
+
+(SECTION 6 10 1)
+(test #t input-port? (current-input-port))
+(test #t output-port? (current-output-port))
+(test #t output-port? (current-error-port))
+(test (void) current-input-port (current-input-port))
+(test (void) current-output-port (current-output-port))
+(test (void) current-error-port (current-error-port))
+(test #t call-with-input-file testing.ss input-port?)
+(define this-file (open-input-file testing.ss))
+(test #t input-port? this-file)
+(close-input-port this-file)
+(define this-file (open-input-file testing.ss 'binary))
+(test #t input-port? this-file)
+(close-input-port this-file)
+(define this-file (open-input-file testing.ss 'text))
+(test #t input-port? this-file)
+(arity-test input-port? 1 1)
+(arity-test output-port? 1 1)
+(arity-test current-input-port 0 1)
+(arity-test current-output-port 0 1)
+(arity-test current-error-port 0 1)
+(err/rt-test (current-input-port 8))
+(err/rt-test (current-output-port 8))
+(err/rt-test (current-error-port 8))
+(err/rt-test (current-input-port (current-output-port)))
+(err/rt-test (current-output-port (current-input-port)))
+(err/rt-test (current-error-port (current-input-port)))
+(SECTION 6 10 2)
+(test #\; peek-char this-file)
+(arity-test peek-char 0 2)
+(arity-test peek-char-or-special 0 2)
+(test #\; read-char this-file)
+(arity-test read-char 0 1)
+(arity-test read-char-or-special 0 1)
+(test '(define cur-section '()) read this-file)
+(arity-test read 0 1)
+(test #\( peek-char this-file)
+(test '(define errs '()) read this-file)
+(close-input-port this-file)
+(close-input-port this-file)
+(arity-test close-input-port 1 1)
+(arity-test close-output-port 1 1)
+(err/rt-test (peek-char 5))
+(err/rt-test (peek-char (current-output-port)))
+(err/rt-test (read-char 5))
+(err/rt-test (read-char (current-output-port)))
+(err/rt-test (read 5))
+(err/rt-test (read (current-output-port)))
+(err/rt-test (close-input-port 5))
+(err/rt-test (close-output-port 5))
+(err/rt-test (close-input-port (current-output-port)))
+(err/rt-test (close-output-port (current-input-port)))
+(define (check-test-file name)
+  (define test-file (open-input-file name))
+  (test #t 'input-port?
+	(call-with-input-file
+	    name
+	  (lambda (test-file)
+	    (test load-test-obj read test-file)
+	    (test #t eof-object? (peek-char test-file))
+	    (test #t eof-object? (read-char test-file))
+	    (input-port? test-file))))
+  (test #\; read-char test-file)
+  (test display-test-obj read test-file)
+  (test load-test-obj read test-file)
+  (close-input-port test-file))
+(SECTION 6 10 3)
+(define write-test-obj
+  '(#t #f #\a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)))
+(define display-test-obj
+  '(#t #f a () 9739 -3 . #((test) te " " st test #() b c)))
+(define load-test-obj
+  (list 'define 'foo (list 'quote write-test-obj)))
+(let ([f (lambda (test-file)
+	   (write-char #\; test-file)
+	   (display write-test-obj test-file)
+	   (newline test-file)
+	   (write load-test-obj test-file)
+	   (output-port? test-file))])
+  (test #t call-with-output-file
+	"tmp1" f 'truncate))
+(check-test-file "tmp1")
+
+(test (string #\null #\null #\" #\\ #\u #\0 #\0 #\0 #\0 #\")
+      'write-null
+      (let ([p (open-output-string)])
+	(write-char #\null p)
+	(display (string #\null) p)
+	(write (string #\null) p)
+	(let ([s (get-output-string p)])
+	  s)))
+
+;; Test escapes (input):
+(test (apply 
+       string 
+       (map 
+	integer->char 
+	'(7 8 9 10 12 13 27 11 92 34 65 32 5 65 15 80 15 80 221 68 255 55 1 49)))
+      values "\a\b\t\n\f\r\e\v\\\"\101\40\5A\xFP\xfP\xdDD\3777\0011")
+(err/rt-test (read (open-input-string "\"\\z\"")) exn:fail:read?)
+(err/rt-test (read (open-input-string "\"\\xX\"")) exn:fail:read?)
+(err/rt-test (read (open-input-string "\"\\x\"")) exn:fail:read?)
+(err/rt-test (read (open-input-string "\"\\x")) exn:fail:read:eof?)
+(err/rt-test (read (open-input-string "\"\\400\"")) exn:fail:read?)
+(err/rt-test (read (open-input-string "\"\\8\"")) exn:fail:read?)
+
+;; Test escape printing:
+(parameterize ([current-locale #f])
+  (test "\"\\a\\b\\t\\n\\f\\r\\e\\v\\\\\\\"A \\u0005A\\u000FP\\u000FP\u00DDD\u00FF7\\u00011\\U012345\""
+	'output-escapes
+	(let ([p (open-output-string)])
+	  (write "\a\b\t\n\f\r\e\v\\\"\101\40\5A\xFP\xfP\xdDD\3777\0011\U12345" p)
+	  (get-output-string p))))
+
+(parameterize ([current-locale #f])
+  (test "#\"\\a\\b\\t\\n\\f\\r\\e\\v\\\\\\\"A \\5A\\17P\\17P\\335D\\3777\\0011\""
+	'output-escapes
+	(let ([p (open-output-string)])
+	  (write #"\a\b\t\n\f\r\e\v\\\"\101\40\5A\xFP\xfP\xdDD\3777\0011" p)
+	  (get-output-string p))))
+
+;; Test return, linefeed, and return--linefeed escapes:
+(test "12" values "1\
+2")
+(test "123" read (open-input-string (string #\" #\1 #\\ #\newline #\2 #\\ #\return #\3 #\")))
+(test "123" read (open-input-string (string #\" #\1 #\\ #\return #\2 #\\ #\newline #\3 #\")))
+(test "12\r3" read (open-input-string (string #\" #\1 #\\ #\return #\newline #\2 #\\ #\newline #\return #\3 #\")))
+(test "1\r23" read (open-input-string (string #\" #\1 #\\ #\newline #\return #\2 #\\ #\return #\newline #\3 #\")))
+
+; Test string ports with file-position:
+(let ([s (open-output-string)])
+  (test (string) get-output-string s)
+  (test 0 file-position s)
+  (display "a" s)
+  (test (string #\a) get-output-string s)
+  (test 1 file-position s)
+  (test (void) file-position s 10)
+  (test 10 file-position s)
+  (test (string #\a #\nul #\nul #\nul #\nul #\nul #\nul #\nul #\nul #\nul) get-output-string s)
+  (display "z" s)
+  (test (string #\a #\nul #\nul #\nul #\nul #\nul #\nul #\nul #\nul #\nul #\z) get-output-string s)
+  (test 11 file-position s)
+  (test (void) file-position s 3)
+  (display "mmm" s)
+  (test (string #\a #\nul #\nul #\m #\m #\m #\nul #\nul #\nul #\nul #\z) get-output-string s)
+  (test 6 file-position s)
+  (display "banana" s)
+  (test (string #\a #\nul #\nul #\m #\m #\m #\b #\a #\n #\a #\n #\a) get-output-string s)
+  (test 12 file-position s))
+(let ([s (open-input-string "hello")])
+  (test 0 file-position s)
+  (test #\h read-char s)
+  (test 1 file-position s)
+  (test #\e read-char s)
+  (test (void) file-position s 0)
+  (test 0 file-position s)
+  (test #\h read-char s)
+  (test (void) file-position s 4)
+  (test 4 file-position s)
+  (test #\o read-char s)
+  (test 5 file-position s)
+  (test eof read-char s)
+  (test 5 file-position s)
+  (test (void) file-position s 502)
+  (test eof read-char s)
+  (test eof read-char s)
+  (test 502 file-position s)
+  (test (void) file-position s 2)
+  (test #\l read-char s)
+  (test 3 file-position s))
+
+(define s (open-output-string))
+(err/rt-test (file-position 's 1))
+(err/rt-test (file-position s 'one))
+(err/rt-test (file-position s -1))
+(err/rt-test (file-position s (expt 2 100)) exn:application:mismatch?)
+(err/rt-test (file-position (make-input-port 'name void #f void) 100) exn:application:mismatch?)
+(err/rt-test (file-position (make-output-port 'name always-evt void void) 100) exn:application:mismatch?)
+(arity-test file-position 1 2)
+
+(define (test-read-line r1 r2 s1 s2 flags sep)
+  (let ([p (open-input-string (string-append s1
+					     (apply string sep)
+					     s2))])
+    (test r1 apply read-line p flags)
+    (test r2 apply read-line p flags)))
+(define (add-return s t) (string-append s (string #\return) t))
+(define (add-linefeed s t) (string-append s (string #\linefeed) t))
+
+(test-read-line "ab" "cd" "ab" "cd" null '(#\linefeed))
+(test-read-line (add-return "ab" "cd") eof "ab" "cd" null '(#\return))
+(test-read-line (add-return "ab" "") "cd" "ab" "cd" null '(#\return #\linefeed))
+(test-read-line "ab" "cd" "ab" "cd" '(return) '(#\return))
+(test-read-line (add-linefeed "ab" "cd") eof "ab" "cd" '(return) '(#\linefeed))
+(test-read-line "ab" (add-linefeed "" "cd") "ab" "cd" '(return) '(#\return #\linefeed))
+(test-read-line (add-return "ab" "cd") eof "ab" "cd" '(return-linefeed) '(#\return))
+(test-read-line (add-linefeed "ab" "cd") eof "ab" "cd" '(return-linefeed) '(#\linefeed))
+(test-read-line "ab" "cd" "ab" "cd" '(return-linefeed) '(#\return #\linefeed))
+(test-read-line (add-return "ab" "") "cd" "ab" "cd" '(return-linefeed) '(#\return #\return #\linefeed))
+(test-read-line "ab" (add-linefeed "" "cd") "ab" "cd" '(return-linefeed) '(#\return #\linefeed #\linefeed))
+(test-read-line "ab" "cd" "ab" "cd" '(any) '(#\return))
+(test-read-line "ab" "cd" "ab" "cd" '(any) '(#\linefeed))
+(test-read-line "ab" "cd" "ab" "cd" '(any) '(#\return #\linefeed))
+(test-read-line "ab" "" "ab" "cd" '(any) '(#\linefeed #\return))
+(test-read-line "ab" "cd" "ab" "cd" '(any-one) '(#\return))
+(test-read-line "ab" "cd" "ab" "cd" '(any-one) '(#\linefeed))
+(test-read-line "ab" "" "ab" "cd" '(any-one) '(#\return #\linefeed))
+(test-read-line "ab" "" "ab" "cd" '(any-one) '(#\linefeed #\return))
+
+(arity-test read-line 0 2)
+(err/rt-test (read-line 8))
+(err/rt-test (read-line 'any))
+(err/rt-test (read-line (current-input-port) 8))
+(err/rt-test (read-line (current-input-port) 'anyx))
+
+(arity-test open-input-file 1 2)
+(err/rt-test (open-input-file 8))
+(err/rt-test (open-input-file "x" 8))
+(err/rt-test (open-input-file "x" 'something-else))
+(err/rt-test (open-input-file "badfile") exn:fail:filesystem?)
+
+(arity-test open-output-file 1 3)
+(err/rt-test (open-output-file 8))
+(err/rt-test (open-output-file "x" 8))
+(err/rt-test (open-output-file "x" 'something-else))
+(let ([conflict? exn:application:mismatch?]
+      [modes '(binary text)]
+      [replacement '(error replace truncate append truncate/replace update)])
+  (for-each
+   (lambda (ones)
+     (for-each
+      (lambda (one)
+	(err/rt-test (open-output-file "x" one 'bad))
+	(err/rt-test (open-output-file "x" one 8))
+	(err/rt-test (open-output-file "x" 'bad one))
+	(err/rt-test (open-output-file "x" 8 one))
+	(err/rt-test (call-with-output-file "x" void one 'bad))
+	(err/rt-test (call-with-output-file "x" void one 8))
+	(err/rt-test (call-with-output-file "x" void 'bad one))
+	(err/rt-test (call-with-output-file "x" void 8 one))
+	(err/rt-test (with-output-to-file "x" void one 8))
+	(err/rt-test (with-output-to-file "x" void one 'bad))
+	(err/rt-test (with-output-to-file "x" void 8 one))
+	(err/rt-test (with-output-to-file "x" void 'bad one))
+	(for-each
+	 (lambda (two)
+	   (err/rt-test (open-output-file "x" one two) conflict?)
+	   (err/rt-test (call-with-output-file "x" void one two) conflict?)
+	   (err/rt-test (with-output-to-file "x" void one two) conflict?))
+	 ones))
+      ones))
+   `(,modes ,replacement)))
+(err/rt-test (open-output-file (build-path (current-directory) "baddir" "x"))
+	    exn:fail:filesystem?)
+
+(when (file-exists? "tmp4")
+  (delete-file "tmp4"))
+(let ([p (open-output-file "tmp4")])
+  (err/rt-test (write-special 'foo p) exn:application:mismatch?)
+  (test #t integer? (port-file-identity p))
+  (let ([q (open-input-file "tmp4")])
+    (test (port-file-identity p) port-file-identity q)
+    (close-input-port q)
+    (err/rt-test (file-position q) exn:fail?)
+    (err/rt-test (port-file-identity q) exn:fail?))
+  (close-output-port p)
+  (err/rt-test (file-position p) exn:fail?)
+  (err/rt-test (port-file-identity p) exn:fail?))
+(err/rt-test (let ([c (make-custodian)])
+	       (let ([p (parameterize ([current-custodian c])
+				      (open-output-file "tmp4" 'replace))])
+		 (custodian-shutdown-all c)
+		 (display 'hi p)))
+	    exn:fail?)
+(err/rt-test (open-output-file "tmp4" 'error) exn:fail:filesystem?)
+(define p (open-output-file "tmp4" 'replace))
+(display 7 p)
+(display "" p)
+(close-output-port p)
+(close-output-port (open-output-file "tmp4" 'truncate))
+(define p (open-input-file "tmp4"))
+(test eof read p)
+(close-input-port p)
+(define p (open-output-file "tmp4" 'replace))
+(display 7 p)
+(close-output-port p)
+(define p (open-output-file "tmp4" 'append))
+(display 7 p)
+(close-output-port p)
+(err/rt-test (display 9 p) exn:fail?)
+(err/rt-test (write 9 p) exn:fail?)
+(err/rt-test (write-char #\a p) exn:fail?)
+
+(err/rt-test (let ([c (make-custodian)])
+	       (let ([p (parameterize ([current-custodian c])
+				      (open-input-file "tmp4"))])
+		 (custodian-shutdown-all c)
+		 (read p)))
+	    exn:fail?)
+(define p (open-input-file "tmp4"))
+(test 77 read p)
+(close-input-port p)
+(err/rt-test (read p) exn:fail?)
+(err/rt-test (read-char p) exn:fail?)
+(err/rt-test (char-ready? p) exn:fail?)
+
+(define-values (in-p out-p) (open-input-output-file "tmp4" 'update))
+(test #\7 read-char in-p)
+(close-output-port out-p)
+(test #\7 read-char in-p)
+(test eof read-char in-p)
+(close-input-port in-p)
+
+(define p (open-output-file "tmp4" 'update))
+(display 6 p)
+(close-output-port p)
+(test 2 file-size "tmp4")
+(define p (open-input-file "tmp4"))
+(test 67 read p)
+(test eof read p)
+(close-input-port p)
+
+(define p (open-output-file "tmp4" 'update))
+(file-position p 1)
+(display 68 p)
+(close-output-port p)
+(test 3 file-size "tmp4")
+(define p (open-input-file "tmp4"))
+(test 0 file-position p)
+(test 668 read p)
+(test 3 file-position p)
+(test eof read p)
+(test 3 file-position p)
+(file-position p 1)
+(test 1 file-position p)
+(test #\6 read-char p)
+(test #\8 read-char p)
+(file-position p 0)
+(test 0 file-position p)
+(test #\6 read-char p)
+(test 1 file-position p)
+(file-position p 2)
+(test #\8 read-char p)
+(test 3 file-position p)
+(close-input-port p)
+
+(close-output-port (open-output-file "tmp4" 'truncate/replace))
+(define p (open-input-file "tmp4"))
+(test eof read p)
+(close-input-port p)
+
+(define-values (in-p out-p) (open-input-output-file "tmp4" 'update))
+(fprintf out-p "hi~n")
+(flush-output out-p)
+(test eof read-char in-p)
+(test 3 file-position out-p)
+(test 3 file-position in-p)
+(file-position out-p 0)
+(test 0 file-position out-p)
+(test 0 file-position in-p)
+(test #\h read-char in-p) ; might read more characters into a buffer!
+(file-position out-p 1)
+(close-input-port in-p)
+(test 1 file-position out-p)
+(write-char #\x out-p)
+(close-output-port out-p)
+(test 'hx with-input-from-file "tmp4" read)
+
+(arity-test call-with-input-file 2 3)
+(arity-test call-with-output-file 2 4)
+(arity-test with-input-from-file 2 3)
+(arity-test with-output-to-file 2 4)
+
+(err/rt-test (call-with-input-file "x" 8))
+(err/rt-test (call-with-input-file  8 (lambda (x) x)))
+(err/rt-test (call-with-input-file  8 (lambda () 9)))
+(err/rt-test (call-with-input-file  "x" (lambda (x) x) 8))
+(err/rt-test (call-with-input-file  "x" (lambda (x) x) 'bad))
+
+(err/rt-test (call-with-output-file "x" 8))
+(err/rt-test (call-with-output-file  8 (lambda (x) x)))
+(err/rt-test (call-with-output-file  8 (lambda () 9)))
+(err/rt-test (call-with-output-file  "x" (lambda (x) x) 8))
+(err/rt-test (call-with-output-file  "x" (lambda (x) x) 'bad))
+
+(err/rt-test (with-input-from-file "x" 8))
+(err/rt-test (with-input-from-file  8 (lambda () 9)))
+(err/rt-test (with-input-from-file  8 (lambda (x) x)))
+(err/rt-test (with-input-from-file  "x" (lambda () 9) 8))
+(err/rt-test (with-input-from-file  "x" (lambda () 9) 'bad))
+
+(err/rt-test (with-output-to-file "x" 8))
+(err/rt-test (with-output-to-file  8 (lambda () 9)))
+(err/rt-test (with-output-to-file  8 (lambda (x) x)))
+(err/rt-test (with-output-to-file  "x" (lambda () 9) 8))
+(err/rt-test (with-output-to-file  "x" (lambda () 9) 'bad))
+
+(define s (open-output-string))
+(test #f input-port? s)
+(test #t output-port? s)
+(let ([c (current-output-port)])
+  (current-output-port s) 
+  (display 8)
+  (current-output-port c))
+(test "8" get-output-string s)
+(let ([c (current-error-port)])
+  (current-error-port s) 
+  (display 9 (current-error-port))
+  (current-error-port c))
+(test "89" get-output-string s)
+(define s2 (open-input-string (get-output-string s)))
+(test #t input-port? s2)
+(test #f output-port? s2)
+(test 89 + 0
+      (let ([c (current-input-port)])
+	(current-input-port s2) 
+	(begin0
+	 (read)
+	 (current-input-port c))))
+(test eof read s2)
+
+(arity-test open-output-string 0 1)
+(arity-test open-input-string 1 2)
+(arity-test get-output-string 1 1)
+
+(arity-test open-output-bytes 0 1)
+(arity-test open-input-bytes 1 2)
+(arity-test get-output-bytes 1 1)
+
+(test 75 object-name (open-input-string "x" 75))
+(test 76 object-name (open-input-bytes #"x" 76))
+(test 175 object-name (open-output-string 175))
+(test 176 object-name (open-output-bytes 176))
+
+(err/rt-test (get-output-string 9))
+(err/rt-test (get-output-string (current-output-port)))
+
+(let ([p (open-input-string "a\nb")])
+  (test '(#f #f 1) call-with-values (lambda () (port-next-location p)) list)
+  (port-count-lines! p)
+  (test '(1 0 1) call-with-values (lambda () (port-next-location p)) list)
+  (test #\a read-char p)
+  (test '(1 1 2) call-with-values (lambda () (port-next-location p)) list)
+  (test '(1 1 2) call-with-values (lambda () (port-next-location p)) list)
+  (test #\newline peek-char p)
+  (test '(1 1 2) call-with-values (lambda () (port-next-location p)) list)
+  (test #\newline read-char p)
+  (test '(2 0 3) call-with-values (lambda () (port-next-location p)) list)
+  (test #\b peek-char p)
+  (test '(2 0 3) call-with-values (lambda () (port-next-location p)) list)
+  (test #\b read-char p)
+  (test '(2 1 4) call-with-values (lambda () (port-next-location p)) list)
+  (test eof read-char p)
+  (test '(2 1 4) call-with-values (lambda () (port-next-location p)) list)
+  (test eof read-char p)
+  (test '(2 1 4) call-with-values (lambda () (port-next-location p)) list))
+
+(define-values (out in) (make-pipe))
+(test #t input-port? out)
+(test #t output-port? in)
+(let loop ([n 1000])
+  (unless (zero? n)
+	  (display n in)
+	  (newline in)
+	  (loop (sub1 n))))
+(let loop ([n 999])
+  (unless (zero? n)
+	  (read out)
+	  (loop (sub1 n))))
+(test 1 read out)
+(close-output-port in)
+(test eof read out)
+(close-input-port out)
+
+(define-values (in out) (make-pipe 3))
+(test 3 write-bytes-avail #"12345" out)
+(let ([s (make-bytes 5 (char->integer #\-))])
+  (test 3 read-bytes-avail! s in)
+  (test #"123--" values s))
+(display 1 out)
+(test 2 write-bytes-avail #"2345" out)
+(let ([th1 (thread (lambda ()
+		     (display "a" out)))]
+      [th2 (thread (lambda ()
+		      (display "a" out)))]
+      [th3 (thread (lambda ()
+		      (display "a" out)))])
+  (test #t thread-running? th1)
+  (test #t thread-running? th2)
+  (test #t thread-running? th3)
+
+  (test 49 read-byte in)
+  
+  (sleep 0.1)
+
+  (test 2 + 
+	(if (thread-running? th1) 1 0)
+	(if (thread-running? th2) 1 0)
+	(if (thread-running? th3) 1 0))
+
+  (test 50 read-byte in)
+
+  (sleep 0.1)
+
+  (test 1 + 
+	(if (thread-running? th1) 1 0)
+	(if (thread-running? th2) 1 0)
+	(if (thread-running? th3) 1 0))
+  
+  (test 51 read-byte in)
+  
+  (sleep 0.1)
+
+  (test #f thread-running? th1)
+  (test #f thread-running? th2)
+  (test #f thread-running? th3)
+
+  (close-output-port out)
+
+  (test #"aaa" read-bytes 10 in))
+(close-input-port in)
+
+(arity-test write-bytes-avail 1 4)
+(arity-test write-bytes-avail* 1 4)
+(arity-test write-bytes-avail/enable-break 1 4)
+
+(arity-test make-pipe 0 3)
+(err/rt-test (make-pipe 0))
+(err/rt-test (make-pipe -1))
+(err/rt-test (make-pipe (- (expt 2 40))))
+(err/rt-test (make-pipe "hello"))
+
+(let-values ([(r w) (make-pipe #f 'in)])
+  (test 'in object-name r)
+  (test 'pipe object-name w))
+(let-values ([(r w) (make-pipe #f 'in 'out)])
+  (test 'in object-name r)
+  (test 'out object-name w))
+
+(test #t input-port? (make-input-port void void void void))
+(test #t input-port? (make-input-port void void #f void))
+(test #t input-port? (make-input-port 1000 void #f void))
+(test 1000 object-name (make-input-port 1000 void #f void))
+(err/rt-test (read (make-input-port #f void void void)))
+(err/rt-test (read-char (make-input-port #f void void void)))
+(err/rt-test (peek-char (make-input-port #f void void void)))
+(arity-test make-input-port 4 10)
+(err/rt-test (make-custom-input-port #f 8 void void))
+(err/rt-test (make-custom-input-port #f void 8 void))
+(err/rt-test (make-custom-input-port #f void void 8))
+(err/rt-test (make-custom-input-port #f cons void void))
+(err/rt-test (make-custom-input-port #f void add1 void))
+(err/rt-test (make-custom-input-port #f void void add1))
+
+(test #t output-port? (make-output-port #f always-evt void void))
+(test #t output-port? (make-output-port #f always-evt void void))
+(test 7786 object-name (make-output-port 7786 always-evt void void))
+(arity-test make-output-port 4 11)
+(err/rt-test (make-output-port #f 8 void void void))
+(err/rt-test (make-output-port #f always-evt 8 void))
+(err/rt-test (make-output-port #f always-evt void 8))
+(err/rt-test (make-output-port #f always-evt add1 void))
+(err/rt-test (make-output-port #f always-evt void add1))
+(err/rt-test (write-special 'foo (make-custom-output-port void always-evt void void)) exn:application:mismatch?)
+
+(let ([p (make-input-port 
+	  'name
+	  (lambda (s) (bytes-set! s 0 97) 1)
+	  (lambda (s skip progress-evt)
+	    (test 0 'skip-is-0 skip)
+	    (bytes-set! s 0 98) 1)
+	  void)])
+  (test #\a read-char p)
+  (test #\b peek-char p)
+  (test #\a read-char p)
+  (test #\b peek-char p)
+  (test #\b peek-char p)
+  (test #\a read-char p)
+  (test 3 file-position p))
+
+(let* ([s (open-input-string "(apple \"banana\" [coconut])")]
+       [p (make-input-port 
+	   'name
+	   (lambda (str)
+	     (if (or (byte-ready? s)
+		     (zero? (random 2)))
+		 (begin
+		   (bytes-set! str 0 (read-byte s))
+		   1)
+		 s))
+	   (lambda (str skip progress-evt)
+	     (if (or (byte-ready? s)
+		     (zero? (random 2)))
+		 (begin
+		   (bytes-set! str 0 (peek-byte s))
+		   1)
+		 s))
+	   void)])
+  (test '(apple "banana" [coconut]) read p))
+
+(let ([test-file (open-output-file "tmp2" 'truncate)])
+  (test 7 write-string (make-string 7 #\a) test-file)
+  (test 4095 write-string (make-string 4095 #\b) test-file)
+  (test 4096 write-string (make-string 4096 #\c) test-file)
+  (test 4097 write-string (make-string 4097 #\d) test-file)
+  (test (+ 7 4095 4096 4097) file-position test-file)
+  (close-output-port test-file)
+  (test (+ 7 4095 4096 4097) file-size "tmp2"))
+
+(let ([go
+       (lambda (write-bytes)
+	 (let ([test-file (open-output-file "tmp2" 'truncate)])
+	   (test 7 write-bytes-avail (make-bytes 7 97) test-file)
+	   (test 4095 write-bytes (make-bytes 4095 98) test-file)
+	   (test 4096 write-bytes (make-bytes 4096 99) test-file)
+	   (test 4097 write-bytes (make-bytes 4097 100) test-file)
+	   (test (+ 7 4095 4096 4097) file-position test-file)
+	   (close-output-port test-file)
+	   (test (+ 7 4095 4096 4097) file-size "tmp2")))])
+  (go write-bytes)
+  (go write-bytes-avail)
+  (go write-bytes-avail*))
+
+(let ([p (open-input-file "tmp1")]
+      [q (open-input-file "tmp2")])
+  (test #f = (port-file-identity p) (port-file-identity q))
+  (close-input-port p)
+  (close-input-port q))
+
+(define test-file 
+  (open-output-file "tmp2" 'truncate))
+(write-char #\; test-file)
+(display write-test-obj test-file)
+(newline test-file)
+(write load-test-obj test-file)
+(test #t output-port? test-file)
+(close-output-port test-file)
+(check-test-file "tmp2")
+
+(define ui (make-input-port 'name (lambda (s) (bytes-set! s 0 (char->integer #\")) 1) #f void))
+(test "" read ui)
+(arity-test (port-read-handler ui) 1 2)
+(err/rt-test ((port-read-handler ui) 8))
+(let ([old (port-read-handler ui)])
+  (port-read-handler ui (case-lambda [(x) "hello"][(x y) "goodbye"]))
+  (test "hello" read ui)
+  (port-read-handler ui old)
+  (test "" read ui))
+(arity-test port-read-handler 1 2)
+(err/rt-test (port-read-handler 1))
+(err/rt-test (port-read-handler ui 8))
+(err/rt-test (port-read-handler (current-output-port) 8))
+(err/rt-test (port-read-handler ui (lambda () 9)))
+(err/rt-test (port-read-handler ui (lambda (x) 9)))
+(err/rt-test (port-read-handler ui (lambda (x y) 9)))
+(err/rt-test (port-read-handler ui (lambda (x y z) 9)))
+
+(define sp (open-output-string))
+(test (void) display "hello" sp)
+(test "hello" get-output-string sp)
+(test (void) write "hello" sp)
+(test "hello\"hello\"" get-output-string sp)
+(arity-test (port-display-handler sp) 2 2)
+(arity-test (port-write-handler sp) 2 2)
+(arity-test (port-print-handler sp) 2 2)
+(err/rt-test ((port-display-handler sp) 8 8))
+(err/rt-test ((port-write-handler sp) 8 8))
+(err/rt-test ((port-print-handler sp) 8 8))
+(let ([oldd (port-display-handler sp)]
+      [oldw (port-write-handler sp)]
+      [oldp (port-print-handler sp)]
+      [adding (let ([s "hello\"hello\""])
+		(lambda (a)
+		  (set! s (string-append s a))
+		  s))])
+  (port-display-handler sp (lambda (v p) (oldd "X" p) (values 1 2)))
+  (test (void) display "hello" sp)
+  (test (adding "X") get-output-string sp)
+  (test (void) write "hello" sp)
+  (test (adding "\"hello\"") get-output-string sp)
+  (test (void) print "hello" sp)
+  (test (adding "\"hello\"") get-output-string sp)
+
+  (port-write-handler sp (lambda (v p) (oldd "Y" p) 5))
+  (test (void) display "hello" sp)
+  (test (adding "X") get-output-string sp)
+  (test (void) write "hello" sp)
+  (test (adding "Y") get-output-string sp)
+  (test (void) print "hello" sp)
+  (test (adding "\"hello\"") get-output-string sp)
+  (parameterize ([global-port-print-handler display])
+     (test (void) print "hello" sp)
+     (test (adding "X") get-output-string sp))
+  (parameterize ([global-port-print-handler oldd])
+     (test (void) print "hello" sp)
+     (test (adding "hello") get-output-string sp))
+  (test (void) print "hello" sp)
+  (test (adding "\"hello\"") get-output-string sp)
+		
+
+  (port-print-handler sp (lambda (v p) (oldd "Z" p) 5))
+  (test (void) display "hello" sp)
+  (test (adding "X") get-output-string sp)
+  (test (void) write "hello" sp)
+  (test (adding "Y") get-output-string sp)
+  (test (void) print "hello" sp)
+  (test (adding "Z") get-output-string sp)
+  (parameterize ([global-port-print-handler display])
+     (test (void) print "hello" sp)
+     (test (adding "Z") get-output-string sp))
+  (test (void) print "hello" sp)
+  (test (adding "Z") get-output-string sp)
+
+  (port-display-handler sp oldd)
+  (test (void) display "hello" sp)
+  (test (adding "hello") get-output-string sp)
+  (test (void) write "hello" sp)
+  (test (adding "Y") get-output-string sp)
+
+  (port-write-handler sp oldw)
+  (test (void) display "hello" sp)
+  (test (adding "hello") get-output-string sp)
+  (test (void) write "hello" sp)
+  (test (adding "\"hello\"") get-output-string sp)
+
+  (port-display-handler sp oldw)
+  (port-write-handler sp oldd)
+  (port-print-handler sp oldp)
+  (test (void) display "hello" sp)
+  (test (adding "\"hello\"") get-output-string sp)
+  (test (void) write "hello" sp)
+  (test (adding "hello") get-output-string sp)
+  (test (void) print "goodbye" sp)
+  (test (adding "\"goodbye\"") get-output-string sp)
+  (port-display-handler sp oldd)
+  (port-write-handler sp oldw))
+(err/rt-test (port-display-handler 1))
+(err/rt-test (port-display-handler sp 8))
+(err/rt-test (port-display-handler (current-input-port) 8))
+(err/rt-test (port-display-handler sp (lambda (x) 9)))
+(err/rt-test (port-display-handler sp (lambda (x y z) 9)))
+(err/rt-test (port-write-handler 1))
+(err/rt-test (port-write-handler sp 8))
+(err/rt-test (port-write-handler (current-input-port) 8))
+(err/rt-test (port-write-handler sp (lambda (x) 9)))
+(err/rt-test (port-write-handler sp (lambda (x y z) 9)))
+
+;;------------------------------------------------------------
+;; peek-string and variants:
+
+(let ([p (open-input-string "Hello World!")])
+  (test "World!" peek-string 6 6 p)
+  (test "World!" peek-string 7 6 p)
+  (test "He" read-string 2 p)
+  (test "rld!" peek-string 7 6 p)
+  (test eof peek-string 7 600 p))
+
+(define (test-a-port p go sync)
+  (let* ([s (bytes 49 50 51)]
+	 [reset-s! (lambda ()
+		     (bytes-set! s 0 49)
+		     (bytes-set! s 1 50)
+		     (bytes-set! s 2 51))]
+	 [test-empty (lambda()
+		       (test #f byte-ready? p)
+		       (test 0 peek-bytes-avail!* s 0 #f p)
+		       (test 0 peek-bytes-avail!* s 1 #f p)
+		       (test 0 read-bytes-avail!* s p))])
+    (test-empty)
+
+    (test 0 peek-bytes-avail!* s 500 #f p)
+    (test 0 read-bytes-avail!* s p)
+
+    (let ([test-basic
+	   (lambda (str sync?)
+	     (go) 
+	     (when sync?
+	       (sync p)
+	       (test #t byte-ready? p)
+	       (test 1 peek-bytes-avail!* s 0 #f p)
+	       (test str values s)
+	       (reset-s!))
+	     (test 1 peek-bytes-avail! s 0 #f p)
+	     (test str values s)
+	     (reset-s!)
+	     (test 1 peek-bytes-avail!* s 0 #f p)
+	     (test str values s)
+	     (reset-s!)
+	     (test 1 read-bytes-avail!* s p)
+	     (test str values s)
+	     (reset-s!))])
+      (test-basic #"A23" #t)
+      (test-basic #"B23" #f))
+
+    (test-empty)
+
+    (go) (go)
+
+    (let ([peek0
+	   (lambda ()
+	     (let ([avail (peek-bytes-avail! s 0 #f p)])
+	       (cond
+		[(= avail 1) (test #"C23" values s)]
+		[(= avail 2) (test #"CD3" values s)]
+		[else (test 1-or-2 values avail)])))])
+      (peek0)
+      (reset-s!)  
+      (test 1 peek-bytes-avail! s 1 #f p)
+      (test #"D23" values s)
+      (reset-s!)
+      (peek0)
+      (reset-s!)
+      (test 0 peek-bytes-avail!* s 2 #f p)
+      (test 2 read-bytes-avail! s p)
+      (test #"CD3" values s)
+
+      (test-empty)
+
+      (go) (go) (go)
+      (test #"E" peek-bytes 1 0 p)
+      (test #"F" peek-bytes 1 1 p)
+      (test #"G" peek-bytes 1 2 p)
+      (test 0 peek-bytes-avail!* s 3 #f p)
+      (test #"EFG" read-bytes 3 p)
+
+      (test-empty)
+
+      (go) (go) (go)
+      (test #"HI" peek-bytes 2 0 p)
+      (test #"IJ" peek-bytes 2 1 p)
+      (test #"J" peek-bytes 1 2 p)
+      (test 0 peek-bytes-avail!* s 3 #f p)
+      (test #"HI" read-bytes 2 p)
+      (test #"J" read-bytes 1 p)
+
+      (test-empty)
+
+      (go) (go) (go)
+      (test #"KLM" peek-bytes 3 0 p)
+      (test #"LM" peek-bytes 2 1 p)
+      (test #"M" peek-bytes 1 2 p)
+      (test #"K" read-bytes 1 p)
+      (test #"L" read-bytes 1 p)
+      (test #"M" read-bytes 1 p)
+      
+      (test-empty))))
+
+(define (gdelay go)
+  (lambda ()
+    (thread go)))
+
+(define (gsync port)
+  (sync port))
+
+;; Test custom port with test-a-port
+(define (test-a-custom-port supply-peek? gdelay gsync)
+  (let* ([counter 0]
+	 [lock (make-semaphore 1)]
+	 [ready-sema (make-semaphore)]
+	 [extras null]
+	 [go (lambda ()
+	       (semaphore-wait lock)
+	       (semaphore-post ready-sema)
+	       (for-each semaphore-post extras)
+	       (set! extras null)
+	       (semaphore-post lock))]
+	 [p (make-input-port
+	     'name
+	     ;; read-bytes:
+	     (lambda (s)
+	       (if (semaphore-try-wait? lock)
+		   (begin0
+		    (let loop ([got 0])
+		      (if (and (got . < . (bytes-length s))
+			       (semaphore-try-wait? ready-sema))
+			  (begin
+			    (bytes-set! s got (+ 65 counter))
+			    (set! counter (add1 counter))
+			    (loop (add1 got)))
+			  (if (zero? got)
+			      (wrap-evt
+			       (semaphore-peek-evt ready-sema)
+			       (lambda (x) 0))
+			      got)))
+		    (semaphore-post lock))
+		   (wrap-evt
+		    (semaphore-peek-evt lock)
+		    (lambda (x) 0))))
+	     (and supply-peek?
+		  (lambda (s d progress-evt)
+		    (if (semaphore-try-wait? lock)
+			(begin0
+			 (let loop ([d d][counter counter])
+			   (if (semaphore-try-wait? ready-sema)
+			       (begin0
+				(cond
+				 [(zero? d)
+				  (bytes-set! s 0 (+ 65 counter))
+				  1]
+				 [else
+				  (loop (sub1 d) (add1 counter))])
+				(semaphore-post ready-sema))
+			       ;; Provide a new semaphore to be posted
+			       ;; when new things appear:
+			       (let ([s (make-semaphore)])
+				 (set! extras (cons s extras))
+				 (wrap-evt s (lambda (x) 0)))))
+			 (semaphore-post lock))
+			(wrap-evt
+			 (semaphore-peek-evt lock)
+			 (lambda () 0)))))
+	     void)])
+    (test-a-port p (gdelay go) gsync)))
+
+(test-a-custom-port #f values void)
+(test-a-custom-port #t values void)
+(test-a-custom-port #f gdelay gsync)
+(test-a-custom-port #t gdelay gsync)
+
+;; Pipe
+(define (test-a-pipe gdelay gsync)
+  (let-values ([(r w) (make-pipe)])
+    (let* ([counter 0]
+	   [go (lambda ()
+		 (write-byte (+ 65 counter) w)
+		 (set! counter (add1 counter)))])
+      (test-a-port r (gdelay go) gsync))))
+
+(test-a-pipe values void)
+(test-a-pipe gdelay gsync)
+
+(arity-test read-bytes 1 2)
+(arity-test peek-bytes 2 3)
+(arity-test read-string 1 2)
+(arity-test peek-string 2 3)
+(arity-test read-bytes! 1 4)
+(arity-test peek-bytes! 2 5)
+(arity-test read-string! 1 4)
+(arity-test peek-string! 2 5)
+(arity-test read-bytes-avail! 1 4)
+(arity-test peek-bytes-avail! 2 6)
+(arity-test read-bytes-avail!* 1 4)
+(arity-test peek-bytes-avail!* 2 6)
+(arity-test read-bytes-avail!/enable-break 1 4)
+(arity-test peek-bytes-avail!/enable-break 2 6)
+
+(let ([fill-a
+       (lambda (s pos)
+	 (let ([l (bytes-length s)])
+	   (let loop ([i 0])
+	     (unless (= i l)
+	       (bytes-set! s i (+ 48 (modulo (+ i pos) 10)))
+	       (loop (add1 i))))
+	   l))]
+      [pos 0])
+  (let ([p (make-input-port 
+	    'name
+	    (lambda (s) (let ([n (fill-a s pos)])
+			  (set! pos (+ pos n))
+			  n))
+	    (lambda (s skip progress-evt) (fill-a s (+ pos skip)))
+	    void)])
+    (test 48 read-byte p)
+    (test 49 peek-byte p)
+    (test 49 read-byte p)
+    (test #"234" read-bytes 3 p)
+    (test #"567" peek-bytes 3 0 p)
+    (test #"567890" read-bytes 6 p)
+    (test #"123" peek-bytes 3 500 p)
+    (test #"123" peek-bytes 3 (expt 10 100) p)
+    (test #"567" peek-bytes 3 (+ 4 (expt 10 100)) p)
+    (test #f regexp-match #"11" p 0 10000)
+    (test #"123" read-bytes 3 p)
+    (test '(#"0") regexp-match #"0" p 0)
+    (let ([x (+ 9 (expt 10 100))])
+      (test (list (cons x (add1 x))) regexp-match-peek-positions #"0" p (expt 10 100)))))
+
+;;------------------------------------------------------------
+
+;; Test custom output port
+(let ([l null]
+      [s (make-semaphore)]
+      [flushed? #f]
+      [spec #f])
+  (let ([p (make-output-port
+	    'name
+	    (semaphore-peek-evt s)
+	    (lambda (bytes start end non-block? breakable?)
+	      (define can-block? (not non-block?))
+	      (let loop ()
+		(if (= start end)
+		    (begin
+		      (set! flushed? #t)
+		      0)
+		    (if (if can-block?
+			    (semaphore-wait s)
+			    (semaphore-try-wait? s))
+			(let ([len (if can-block?
+				       (- end start)
+				       1)])
+			  (set! l (append l
+					  (list (subbytes bytes start (+ start len)))))
+			  len)
+			(wrap-evt (semaphore-peek-evt s)
+				  (lambda (x) (loop)))))))
+	    (lambda ()
+	      (set! l #f))
+	    (lambda (s non-block? breakable?)
+	      (set! spec s)
+	      (not non-block?)))])
+    (test 0 write-bytes-avail* #"abc" p)
+    (semaphore-post s)
+    (test 3 write-bytes #"abc" p)
+    (test '(#"abc") values l)
+    (semaphore-post s)
+    (let ([n (write-bytes-avail #"abc" p)])
+      (test #t <= n 1 3)
+      (test (add1 n) length l))
+    (flush-output p)
+    (test #t values flushed?)
+    (test #f write-special-avail* 'thing p)
+    (test 'thing values spec)
+    (test #t write-special 'thung p)
+    (test 'thung values spec)
+    (test (void) close-output-port p)
+    (test #f values l)
+    (set! l 10)
+    (test (void) close-output-port p)
+    (test 10 values l)))
+
+; --------------------------------------------------
+
+(SECTION 6 10 4)
+(load "tmp1")
+(test write-test-obj 'load foo)
+
+(SECTION 'INEXACT-I/IO)
+(define wto write-test-obj)
+(define dto display-test-obj)
+(define lto load-test-obj)
+(define f-3.25 (string->number "-3.25"))
+(define f.25 (string->number ".25"))
+(set! write-test-obj (list f.25 f-3.25));.25 inexact errors less likely.
+(set! display-test-obj (list f.25 f-3.25));.3 often has such errors (~10^-13)
+(set! load-test-obj (list 'define 'foo (list 'quote write-test-obj)))
+(let ([f (lambda (test-file)
+	   (write-char #\; test-file)
+	   (display write-test-obj test-file)
+	   (newline test-file)
+	   (write load-test-obj test-file)
+	   (output-port? test-file))])
+  (test #t call-with-output-file
+	"tmp3" f 'truncate))
+(check-test-file "tmp3")
+(set! write-test-obj wto)
+(set! display-test-obj dto)
+(set! load-test-obj lto)
+
+(define badc-range-start 0)
+(define badc-range-end 255)
+
+(SECTION 'PRINTF)
+(define (test-format format)
+  (test "~" format "~~")
+  (test "hello---~---there" format "~a---~~---~a" "hello" 'there)
+  (test "\"hello\"---~---there" format "~s---~~---~s" "hello" 'there)
+  (test "\"hello\"---~---there" format "~v---~~---~v" "hello" 'there)
+  (test (string #\a #\newline #\b #\newline #\c) format "a~nb~%c")
+  (let ([try-newline-stuff
+	 (lambda (newlines)
+	   (test "12" format (apply string `(#\1 #\~ #\space ,@newlines #\space #\2)))
+	   (test "12" format (apply string `(#\1 #\~ ,@newlines #\space #\2)))
+	   (test "12" format (apply string `(#\1 #\~ ,@newlines #\2)))
+	   (test (apply string `(#\1 ,@newlines #\2)) 
+		 format (apply string `(#\1 #\~ ,@newlines #\space ,@newlines #\2))))])
+    (for-each try-newline-stuff '((#\return) (#\newline) (#\return #\newline))))
+  (test "twenty=20..." format "twenty=~s..." 20)
+  (test "twenty=20..." format "twenty=~v..." 20)
+  (test "twenty=20..." format "twenty=~e..." 20)
+  (test "twenty=14..." format "twenty=~x..." 20)
+  (test "twenty=24..." format "twenty=~o..." 20)
+  (test "twenty=10100..." format "twenty=~b..." 20)
+  (test "zee=z..." format "zee=~c..." #\z)
+
+  (test #\. 
+	(lambda (s) (string-ref s (sub1 (string-length s))))
+	(parameterize ([error-print-width 40])
+	  (format "~e" (make-string 200 #\v))))
+  
+  (let()
+    (define bads
+      (let loop ([i badc-range-end])
+	(cond
+	 [(eq? i badc-range-start) (list (integer->char i))]
+	 [else (let ([c (integer->char i)]
+		     [rest (loop (sub1 i))])
+		 (case c
+		   [(#\~ #\% #\n #\a #\s #\c #\o #\x #\b #\v #\e
+			 #\N #\A #\S #\C #\O #\X #\B #\V #\E)
+		    rest]
+		   [else (if (char-whitespace? c)
+			     rest
+			     (cons c rest))]))])))
+
+    (define with-censor (load-relative "censor.ss"))
+
+    ; test for all bad tags; the string we generate shouldn't
+    ;  be printed to a terminal directly because it can contain contain
+    ;  control characters; censor it
+    (unless building-flat-tests?
+      (with-censor
+       (lambda ()
+	 (for-each (lambda (c)
+		     (err/rt-test (format (format "a~~~cb" c) 0)))
+		   bads)))))
+  
+  (err/rt-test (format 9))
+  (err/rt-test (format "apple~"))
+  (err/rt-test (format "~"))
+  (err/rt-test (format "~~~"))
+  (err/rt-test (format "~o") exn:application:mismatch?)
+  (err/rt-test (format "~o" 1 2) exn:application:mismatch?)
+  (err/rt-test (format "~c" 1) exn:application:mismatch?)
+  (err/rt-test (format "~x" 'a) exn:application:mismatch?)
+  (err/rt-test (format "~x" 4.0) exn:application:mismatch?)
+  (err/rt-test (format "~x" 5+4.0i) exn:application:mismatch?))
+
+(test-format format)
+(test-format
+ (lambda args
+   (let ([p (open-output-string)])
+     (apply fprintf p args)
+     (get-output-string p))))
+(test-format
+ (lambda args
+   (let ([p (open-output-string)])
+     (parameterize ([current-output-port p])
+		   (apply printf args))
+     (get-output-string p))))
+
+(arity-test format 1 -1)
+(arity-test printf 1 -1)
+(arity-test fprintf 2 -1)
+
+(define success-1? (putenv "APPLE" "AnApple"))
+(define success-2? (putenv "BANANA" "AnotherApple"))
+(err/rt-test (getenv 7))
+(err/rt-test (getenv (string #\a #\nul #\b)))
+(err/rt-test (putenv 7 "hi"))
+(err/rt-test (putenv "hi" 7))
+(err/rt-test (putenv (string #\a #\nul #\b) "hi"))
+(err/rt-test (putenv "hi" (string #\a #\nul #\b)))
+(collect-garbage)
+(test #t 'success-1 success-1?)
+(test #t 'success-2 success-2?)
+(test "AnApple" getenv "APPLE")
+(test "AnotherApple" getenv "BANANA")
+(test #f getenv "AnUndefinedEnvironmentVariable")
+
+(arity-test getenv 1 1)
+(arity-test putenv 2 2)
+
+(arity-test read-eval-print-loop 0 0)
+(test (void) 'r-e-p-l-return 
+      (parameterize ([current-input-port (make-input-port
+					  'name
+					  (lambda (s) eof)
+					  #f
+					  void)])
+	   (read-eval-print-loop)))
+
+
+
+(define (cust-test open)
+  (let ([try
+	 (lambda ()
+	   (let ([c (make-custodian)])
+	     (parameterize ([current-custodian c])
+	       (let ([n
+		      (let loop ([n 0])
+			(with-handlers ([exn:fail:filesystem?
+					 (lambda (exn) 
+					   (printf "expected open failure: ~a~n"
+						   (exn-message exn))
+					   n)])
+			  ;; leave the port open:
+			  (open)
+			  (if (= n 5000)
+			      n
+			      (loop (add1 n)))))])
+		 ;; should close all the ports
+		 (custodian-shutdown-all c)
+		 (printf "got ~a ports~n" n)
+		 n))))])
+    (let ([n (try)])
+      (test n try))))
+
+(unless (eq? 'macos (system-type)) ;; no limit in Mac OS Classic!
+  (cust-test (lambda ()
+	       (open-input-file 
+		(build-path (current-load-relative-directory)
+			    "file.ss")))))
+
+;; Too time-consuming, does bad things to the network:
+'(let* ([pn 40001]
+       [l (tcp-listen pn)])
+  (cust-test (lambda ()
+	       (let-values ([(r1 w1) (tcp-connect "localhost" pn)]
+			    [(r2 w2) (tcp-accept l)])
+		 '(close-input-port r1)
+		 '(close-output-port w1)
+		 '(close-output-port w2)
+		 '(close-input-port r2))))
+  (tcp-close l))
+
+;;----------------------------------------------------------------------
+;; TCP
+
+(let ([do-once
+       (lambda (evt?)
+	 (let* ([pn 40001]
+		[l (tcp-listen pn 5 #t)])
+	   (let-values ([(r1 w1) (tcp-connect "localhost" pn)]
+			[(r2 w2) (if evt?
+				     (apply values (sync (tcp-accept-evt l)))
+				     (tcp-accept l))])
+	     (test #t tcp-port? r1)
+	     (test #t tcp-port? r2)
+	     (test #t tcp-port? w1)
+	     (test #t tcp-port? w2)
+	     (fprintf w1 "Hello~n")
+	     (flush-output w1)
+	     (test "Hello" read-line r2)
+	     (tcp-abandon-port r1)
+	     (close-output-port w1)
+	     (close-output-port w2)
+	     (close-input-port r2))
+	   (when evt?
+	     (test #f sync/timeout 0 (tcp-accept-evt l)))
+	   (tcp-close l)))])
+  (do-once #f)
+  (do-once #t))
+
+(test #f tcp-port? (current-input-port))
+(test #f tcp-port? (current-output-port))
+
+(arity-test tcp-port? 1 1)
+
+;;----------------------------------------------------------------------
+;; UDP
+
+(unless (eq? 'macos (system-type))
+  (load-relative "udp.ss"))
+
+(when (eq? 'macos (system-type))
+  (err/rt-test (udp-open-socket) exn:misc:unsupported?)
+  ;; All others fail b/c can't supply a UDP.
+  )
+
+(test #f udp? 5)
+
+;; more type tests in udp.ss, where we have UDP socket values
+(err/rt-test (udp-close 5))
+(err/rt-test (udp-bound? 5))
+(err/rt-test (udp-connected? 5))
+(err/rt-test (udp-bind! 5 #f 40000))
+(err/rt-test (udp-connect! 5 "localhost" 40000))
+(err/rt-test (udp-send-to 5 "localhost" 40000 #"hello"))
+(err/rt-test (udp-send-to* 5 "localhost" 40000 #"hello"))
+(err/rt-test (udp-send-to/enable-break 5 "localhost" 40000 #"hello"))
+(err/rt-test (udp-send 5 #"hello"))
+(err/rt-test (udp-send* 5 #"hello"))
+(err/rt-test (udp-send/enable-break 5 #"hello"))
+(err/rt-test (udp-receive! 5 (make-bytes 10)))
+(err/rt-test (udp-receive!* 5 (make-bytes 10)))
+(err/rt-test (udp-receive!/enable-break 5 (make-bytes 10)))
+(err/rt-test (udp-receive!-evt 5 (make-bytes 10)))
+(err/rt-test (udp-send-ready-evt 5))
+(err/rt-test (udp-receive-ready-evt 5))
+
+(arity-test udp-open-socket 0 0)
+(arity-test udp-close 1 1)
+(arity-test udp? 1 1)
+(arity-test udp-bound? 1 1)
+(arity-test udp-connected? 1 1)
+(arity-test udp-bind! 3 3)
+(arity-test udp-connect! 3 3)
+(arity-test udp-send-to 4 6)
+(arity-test udp-send-to* 4 6)
+(arity-test udp-send-to/enable-break 4 6)
+(arity-test udp-send 2 4)
+(arity-test udp-send* 2 4)
+(arity-test udp-send/enable-break 2 4)
+(arity-test udp-send-to-evt 4 6)
+(arity-test udp-send-evt 2 4)
+(arity-test udp-receive! 2 4)
+(arity-test udp-receive!* 2 4)
+(arity-test udp-receive!/enable-break 2 4)
+(arity-test udp-receive!-evt 2 4)
+(arity-test udp-send-ready-evt 1 1)
+(arity-test udp-receive-ready-evt 1 1)
+
+(SECTION 'file-after-udp)
+
+;;----------------------------------------------------------------------
+;; Security guards:
+
+;; Files - - - - - - - - - - - - - - - - - - - - - -
+
+(define (make-file-sg ok-modes)
+  (make-security-guard (current-security-guard)
+		       (lambda (who path modes)
+			 (unless (andmap (lambda (m) (memq m ok-modes))
+					 modes)
+			   (raise (cons 'fs-reject who))))
+		       void))
+(define (fs-reject? who)
+  (lambda (x) (and (pair? x)
+		   (eq? (car x) 'fs-reject)
+		   (eq? (cdr x) who))))
+  
+(parameterize ([current-security-guard (make-file-sg '(exists read))])
+  (test #t path? (expand-path "tmp1"))
+  (test #t file-exists? "tmp1")
+  (test #f directory-exists? "tmp1")
+  (test #f link-exists? "tmp1")
+
+  (err/rt-test (open-output-file "tmp1") (fs-reject? 'open-output-file))
+  (err/rt-test (delete-file "tmp1") (fs-reject? 'delete-file))
+  (err/rt-test (rename-file-or-directory "tmp1" "tmp11") (fs-reject? 'rename-file-or-directory))
+  (err/rt-test (copy-file "tmp1" "tmp11") (fs-reject? 'copy-file))
+  (let ([p (open-input-file "tmp1")])
+    (test #t input-port? p)
+    (close-input-port p))
+  (test #t list? (directory-list)))
+
+(parameterize ([current-security-guard (make-file-sg '(exists write))])
+  (test #t path? (expand-path "tmp1"))
+  (err/rt-test (open-input-file "tmp1") (fs-reject? 'open-input-file))
+  (err/rt-test (open-output-file "tmp1" 'append) (fs-reject? 'open-output-file))
+  (err/rt-test (open-output-file "tmp1" 'update) (fs-reject? 'open-output-file))
+  (err/rt-test (directory-list) (fs-reject? 'directory-list))
+  (err/rt-test (directory-list (current-directory)) (fs-reject? 'directory-list))
+  (err/rt-test (delete-directory (current-directory)) (fs-reject? 'delete-directory))
+  (err/rt-test (rename-file-or-directory "tmp1" "tmp11") (fs-reject? 'rename-file-or-directory))
+  (err/rt-test (copy-file "tmp1" "tmp11") (fs-reject? 'copy-file))
+  (err/rt-test (file-or-directory-modify-seconds "tmp1") (fs-reject? 'file-or-directory-modify-seconds))
+  (err/rt-test (file-or-directory-permissions "tmp1") (fs-reject? 'file-or-directory-permissions))
+  (err/rt-test (file-size "tmp1") (fs-reject? 'file-size)))
+
+(parameterize ([current-security-guard (make-file-sg '(read write))])
+  (err/rt-test (current-directory) (fs-reject? 'current-directory))
+  (err/rt-test (current-directory "tmp1") (fs-reject? 'current-directory))
+  (err/rt-test (current-drive) (lambda (x)
+				 (or (exn:unsupported? x) ((fs-reject? 'current-drive) x))))
+  (err/rt-test (expand-path "tmp1") (fs-reject? 'expand-path))
+  (err/rt-test (resolve-path "tmp1") (fs-reject? 'resolve-path))
+  (err/rt-test (simplify-path "../tmp1") (fs-reject? 'simplify-path))
+  (err/rt-test (file-exists? "tmp1") (fs-reject? 'file-exists?))
+  (err/rt-test (directory-exists? "tmp1") (fs-reject? 'directory-exists?))
+  (err/rt-test (link-exists? "tmp1") (fs-reject? 'link-exists?))
+  (err/rt-test (path->complete-path "tmp1") (fs-reject? 'path->complete-path))
+  (err/rt-test (filesystem-root-list) (fs-reject? 'filesystem-root-list))
+  (err/rt-test (find-system-path 'temp-dir) (fs-reject? 'find-system-path)))
+
+;; Network - - - - - - - - - - - - - - - - - - - - - -
+
+(define (net-reject? who host port what)
+  (lambda (x) (and (pair? x)
+		   (eq? (car x) 'net-reject)
+		   (eq? (cadr x) who)
+		   (equal? (caddr x) host)
+		   (equal? (cadddr x) port)
+		   (eq? (cddddr x) what))))
+
+(define early-udp (and (not (eq? 'macos (system-type)))
+		       (udp-open-socket)))
+
+(parameterize ([current-security-guard 
+		(make-security-guard (current-security-guard)
+				     void
+				     (lambda (who host port mode)
+				       (raise (list* 'net-reject who host port mode))))])
+  (err/rt-test (tcp-connect "other" 123)  (net-reject? 'tcp-connect "other" 123 'client))
+  (err/rt-test (tcp-listen 123)  (net-reject? 'tcp-listen #f 123 'server))
+  (unless (eq? 'macos (system-type)) ; no UDP in Mac OS Classic
+    (err/rt-test (udp-open-socket)  (net-reject? 'udp-open-socket #f #f 'client))
+    (err/rt-test (udp-bind! early-udp "localhost" 40000)  (net-reject? 'udp-bind! "localhost" 40000 'server))
+    (err/rt-test (udp-connect! early-udp "localhost" 40000)  (net-reject? 'udp-connect! "localhost" 40000 'client))
+    (err/rt-test (udp-send-to early-udp "localhost" 40000 #"hi")  (net-reject? 'udp-send-to "localhost" 40000 'client))))
+
+(report-errs)
diff --git a/collects/tests/mzscheme/filelib.ss b/collects/tests/mzscheme/filelib.ss
new file mode 100644
index 0000000000..c236a84c98
--- /dev/null
+++ b/collects/tests/mzscheme/filelib.ss
@@ -0,0 +1,67 @@
+
+(load-relative "loadtest.ss")
+
+(SECTION 'file)
+
+(require (lib "file.ss")
+	 (lib "process.ss"))
+
+(parameterize ([current-directory (current-load-relative-directory)])
+  (let ([rel (find-files values)]
+	[abs (find-files values (current-directory))])
+    (test #t = (length rel) (sub1 (length abs)))
+    (test #f member "filelib.ss" abs)
+    (test #f null? (member "filelib.ss" rel))
+    (test #f null? (member (build-path (current-directory) "filelib.ss") abs))
+
+    (test (list (string->path "filelib.ss")) find-files (lambda (f) (regexp-match "^filelib[.]ss$" (path->string f))))
+    (test (list (build-path (current-directory) "filelib.ss"))
+	  find-files (lambda (f) (regexp-match "filelib[.]ss$" (path->string f)))
+	  (current-directory))
+
+    (let ([rel2 (fold-files (lambda (name kind accum)
+			      (test kind values (if (file-exists? name)
+						    'file
+						    'dir))
+			      (cons name accum))
+			    null)])
+      (test #t equal? rel rel2)
+
+      (when (eq? (system-type) 'unix)
+	(system "ln -s filelib.ss filelib-link.ss")
+	(system "ln -s . loop-link")
+
+	(test (+ 2 (length rel2))
+	      fold-files 
+	      (lambda (name kind accum)
+		(test kind values (cond
+				   [(link-exists? name) 'link]
+				   [(file-exists? name) 'file]
+				   [else 'dir]))
+		(when (member name '("filelib-link.ss" "loop-link"))
+		  (test kind values 'link))
+		(add1 accum))
+	      0
+	      #f
+	      #f)
+
+	(system "rm loop-link")
+
+	(test (+ 1 (length rel2))
+	      fold-files 
+	      (lambda (name kind accum)
+		(test kind values (cond
+				   [(file-exists? name) 'file]
+				   [else 'dir]))
+		(when (member name '("filelib-link.ss"))
+		  (test kind values 'file))
+		(add1 accum))
+	      0
+	      #f
+	      #t)
+
+	(system "rm filelib-link.ss")
+
+	'done))))
+
+(report-errs)
diff --git a/collects/tests/mzscheme/function.ss b/collects/tests/mzscheme/function.ss
new file mode 100644
index 0000000000..bef1f4b6eb
--- /dev/null
+++ b/collects/tests/mzscheme/function.ss
@@ -0,0 +1,69 @@
+
+(load-relative "loadtest.ss")
+
+(SECTION 'function)
+
+(require (lib "list.ss"))
+(require (lib "etc.ss"))
+
+(test (list 1 2 3 4) foldl cons '() (list 4 3 2 1))
+(test (list 1 2 3 4) foldr cons '() (list 1 2 3 4))
+(test 
+ (list (list 5 6) (list 3 4) (list 1 2))
+ foldl (lambda (x y sofar) (cons (list x y) sofar))
+ '()
+ (list 1 3 5)
+ (list 2 4 6))
+(test 
+ (list (list 1 2) (list 3 4) (list 5 6))
+ foldr (lambda (x y sofar) (cons (list x y) sofar))
+ '()
+ (list 1 3 5)
+ (list 2 4 6))
+
+(arity-test foldl 3 -1)
+(arity-test foldr 3 -1)
+
+(test 0 (compose add1 sub1) 0)
+(test 2 (compose add1 (lambda () 1)))
+(test 5 (compose (lambda (a b) a) (lambda (x) (values (add1 x) x))) 4)
+(test -1 (compose (lambda (a b) (+ a b)) (lambda (x y) (values (- y) x))) 2 3)
+(test 'hi (compose (case-lambda [(x) 'bye][(y z) 'hi]) (lambda () (values 1 2))))
+(test 'ok (compose (lambda () 'ok) (lambda () (values))))
+(test 'ok (compose (lambda () 'ok) (lambda (w) (values))) 5)
+(test-values '(1 2 3) (lambda () ((compose (lambda (x) (values x (add1 x) (+ x 2))) (lambda (y) y)) 1)))
+
+(err/rt-test (compose 5))
+(err/rt-test (compose add1 sub1 5))
+(err/rt-test (compose add1 5 sub1))
+(err/rt-test (compose 5 add1 sub1))
+(err/rt-test ((compose add1 (lambda () (values 1 2)))) exn:application:arity?)
+(err/rt-test ((compose add1 sub1)) exn:application:arity?)
+(err/rt-test ((compose (lambda () 1) add1) 8) exn:application:arity?)
+
+(arity-test compose 1 -1)
+
+(test '(1 2 3) filter number? '(1 a 2 b 3 c d))
+(test '() filter string? '(1 a 2 b 3 c d))
+(err/rt-test (filter string? '(1 2 3 . 4)) exn:application:mismatch?)
+(err/rt-test (filter 2 '(1 2 3)))
+(err/rt-test (filter cons '(1 2 3)))
+(arity-test filter 2 2)
+
+(err/rt-test (assf add1 '(0 1 2)) exn:application:mismatch?)
+(test '(0 x) assf number? '((a 1) (0 x) (1 w) (2 r) (c 17)))
+(test '("ok" . 10) assf string? '((a 0) (0 a) (1 w) ("ok" . 10) (2 .7) c))
+(err/rt-test (assf cons '((1) (2) (3))))
+(err/rt-test (assf string? '((1) (2) (3) . 4)) exn:application:mismatch?)
+
+(test '("a" "b" "c" "c" "d" "e" "f")
+      quicksort 
+      '("d" "f" "e" "c" "a" "c" "b")
+      string<?)
+(let ([s (let loop ([n 1000])
+	   (if (zero? n)
+	       '()
+	       (cons (random 1000) (loop (sub1 n)))))])
+  (test (quicksort s <) mergesort s <))
+
+(report-errs)
diff --git a/collects/tests/mzscheme/gzip.ss b/collects/tests/mzscheme/gzip.ss
new file mode 100644
index 0000000000..895a709aa6
--- /dev/null
+++ b/collects/tests/mzscheme/gzip.ss
@@ -0,0 +1,93 @@
+
+(require (lib "deflate.ss")
+	 (lib "inflate.ss"))
+
+(for-each (lambda (f)
+	    (when (file-exists? f)
+	      (printf "trying ~a~n" f)
+	      (let ([str
+		     (call-with-input-file f
+		       (lambda (p)
+			 (let-values ([(in out) (make-pipe 4096)]
+				      [(out2) (open-output-bytes)])
+			   (thread
+			    (lambda ()
+			      (gzip-through-ports p out "x" 0)
+			      (close-output-port out)))
+			   (thread-wait
+			    (thread
+			     (lambda ()
+			       (gunzip-through-ports in out2)
+			       (close-output-port out2))))
+			   (get-output-bytes out2))))])
+		(let ([orig-str (call-with-input-file f
+				  (lambda (p)
+				    (read-bytes (file-size f) p)))])
+		  (unless (bytes=? str orig-str)
+		    (printf "not the same for ~a" f))))))
+	  (directory-list))
+
+
+#|
+
+;; Uses (unix) `gzip' program from your path.
+;; Run this in a directory with lots of files to use as tests
+
+(require (lib "deflate.ss")
+	 (lib "process.ss"))
+
+(define (check-file/fastest p in)
+  (let ([s1 (make-string 5000)]
+	[s2 (make-string 5000)])
+    (let loop ([leftover 0][startpos 0][pos 0])
+      (let* ([n1 (if (zero? leftover)
+		     (read-string-avail! s1 p)
+		     leftover)]
+	     [n2 (read-string-avail! s2 in 0 (if (eof-object? n1)
+						 1
+						 n1))])
+	(unless (if (or (eof-object? n1)
+			(eof-object? n2))
+		    (and (eof-object? n1)
+			 (eof-object? n2))
+		    (if (= n2 n1 5000)
+			(string=? s1 s2)
+			(string=? (substring s1 startpos (+ startpos n2))
+				  (substring s2 0 n2))))
+	  (error 'check "failed at ~a (~a@~a ~a)" pos n1 startpos n2))
+	(unless (eof-object? n1)
+	  (loop (- n1 n2) 
+		(if (= n1 n2)
+		    0
+		    (+ startpos n2))
+		(+ pos n2)))))))
+
+(define gzip (find-executable-path "gzip" #f))
+(unless gzip
+  (error "cannot find gzip"))
+
+(for-each
+ (lambda (f)
+   (when (file-exists? f)
+     (printf "trying ~a~n" f)
+     (let-values ([(zo zi zn ze zf) 
+		   (apply values (process* gzip "-c" f))]
+		  [(mi mo) (make-pipe 4096)])
+     (close-output-port zi)
+       (close-input-port ze)
+       (thread 
+	(lambda ()
+	  (let ([p (open-input-file f)]
+		[gz (lambda (p mo)
+		      (gzip-through-ports p mo 
+					  (let-values ([(base name dir?) (split-path f)])
+					    name)
+					  (file-or-directory-modify-seconds f)))])
+	    (gz p mo)
+	    (close-output-port mo))))
+       ;; Compare output
+       (check-file/fastest mi zo)
+       (close-input-port zo))))
+ (directory-list))
+
+|#
diff --git a/collects/tests/mzscheme/htdp-image.ss b/collects/tests/mzscheme/htdp-image.ss
new file mode 100644
index 0000000000..7729f22328
--- /dev/null
+++ b/collects/tests/mzscheme/htdp-image.ss
@@ -0,0 +1,992 @@
+;; Load this one with MrEd
+
+(load-relative "loadtest.ss")
+(require (lib "image.ss" "htdp")
+         (lib "error.ss" "htdp")
+         (lib "posn.ss" "lang")
+         (lib "imageeq.ss" "lang"))
+
+(define-values (image-snip1 image-snip2)
+  (let ()
+    (define size 2)
+    
+    (define (do-draw c-bm m-bm)
+      (let ([bdc (make-object bitmap-dc% c-bm)])
+        (send bdc clear)
+        (send bdc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent))
+        (send bdc set-brush (send the-brush-list find-or-create-brush "red" 'solid))
+        (send bdc draw-rectangle 0 0 size size)
+        (send bdc set-bitmap m-bm)
+        (send bdc clear)
+        (send bdc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent))
+        (send bdc set-brush (send the-brush-list find-or-create-brush "black" 'solid))
+        (send bdc draw-rectangle 0 0 (/ size 2) size)
+        (send bdc set-bitmap #f)))
+    
+    (define image-snip1 
+      (let* ([c-bm (make-object bitmap% size size)]
+             [m-bm (make-object bitmap% size size #t)])
+        (do-draw c-bm m-bm)
+        (make-object image-snip% c-bm m-bm)))
+    
+    (define image-snip2 
+      (let* ([c-bm (make-object bitmap% size size)]
+             [m-bm (make-object bitmap% size size)])
+        (do-draw c-bm m-bm)
+        (send c-bm set-loaded-mask m-bm)
+        (make-object image-snip% c-bm)))
+    
+    (values image-snip1 image-snip2)))
+
+(define image-snip3 (make-object image-snip%))
+
+;; check-on-bitmap : symbol snip -> void
+;; checks on various aspects of the bitmap snips to make
+;; sure that they draw properly
+(define (check-on-bitmap name snp)
+  (let-values ([(width height) (send snp get-size)])
+    (let ([bdc (make-object bitmap-dc%)]
+          [max-difference
+           (lambda (s1 s2)
+             (apply max
+                    (map (lambda (x y) (abs (- x y))) 
+                         (bytes->list s1)
+                         (bytes->list s1))))])
+      
+      ;; test that no drawing is outside the snip's drawing claimed drawing area
+      (let ([bm-clip (make-object bitmap% (+ width 100) (+ height 100))]
+            [bm-noclip (make-object bitmap% (+ width 100) (+ height 100))]
+            [s-clip (make-bytes (* (+ width 100) (+ height 100) 4))]
+            [s-noclip (make-bytes (* (+ width 100) (+ height 100) 4))])
+        (send bdc set-bitmap bm-clip)
+        (send bdc clear)
+        (send bdc set-clipping-rect 50 50 width height)
+        (send snp draw bdc 50 50 0 0 (+ width 100) (+ height 100) 0 0 #f)
+        (send bdc set-clipping-region #f)
+        (send bdc get-argb-pixels 0 0 (+ width 100) (+ height 100) s-clip)
+        
+        (send bdc set-bitmap bm-noclip)
+        (send bdc clear)
+        (send snp draw bdc 50 50 0 0 (+ width 100) (+ height 100) 0 0 #f)
+        (send bdc get-argb-pixels 0 0 (+ width 100) (+ height 100) s-noclip)
+        (send bdc set-bitmap #f)
+        (test (list 'bmclip name #t) (lambda () (list 'bmclip name (equal? s-clip s-noclip)))))
+      
+      (let ([bm-normal (make-object bitmap% width height)]
+            [bm-bitmap (make-object bitmap% width height)]
+            [s-normal (make-bytes (* width height 4))]
+            [s-bitmap (make-bytes (* width height 4))])
+        
+        (send bdc set-bitmap bm-normal)
+        (send bdc clear)
+        (send snp draw bdc 0 0 0 0 width height 0 0 #f)
+        (send bdc get-argb-pixels 0 0 width height s-normal)
+        (send bdc set-bitmap bm-bitmap)
+        (send bdc clear)
+        
+        ;; force the snip to switch over to bitmap mode
+        (send snp get-argb)
+        
+        (send snp draw bdc 0 0 0 0 width height 0 0 #f)
+        (send bdc get-argb-pixels 0 0 width height s-bitmap)
+        (send bdc set-bitmap #f)
+        (test (list 'bmsame name #t) 
+              (lambda () (list 'bmsame name 
+                               (<= (max-difference s-normal s-bitmap) 2))))))))
+
+(test #t 'image? (image? (rectangle 10 10 'solid 'blue)))
+(test #f 'image? (image? 5))
+
+(define red (make-color 255 0 0))
+(define blue (make-color 0 0 255))
+(define black (make-color 0 0 0))
+(define white (make-color 255 255 255))
+
+(define awhite (make-alpha-color 0 255 255 255))
+(define ablack (make-alpha-color 0 0 0 0))
+(define ared (make-alpha-color 0 255 0 0))
+(define aclr (make-alpha-color 255 0 0 0))
+
+(define (p00 i) (move-pinhole i (- (pinhole-x i)) (- (pinhole-y i))))
+(define (ignore x) 'ignore)
+
+(test 3 
+      'pinhole-x
+      (pinhole-x (rectangle 6 8 'solid 'black)))
+(test 4
+      'pinhole-y
+      (pinhole-y (rectangle 6 8 'solid 'black)))
+(test 1
+      'move-pinhole1
+      (pinhole-x (move-pinhole (rectangle 6 8 'solid 'black) -2 -2)))
+(test 2
+      'move-pinhole2
+      (pinhole-y (move-pinhole (rectangle 6 8 'solid 'black) -2 -2)))
+
+(test (list red)
+      'color-list
+      (image->color-list (rectangle 1 1 'solid 'red)))
+
+(test (list (list red) (list blue) (list black) (list white))
+      'colors-set-up-properly
+      (list (image->color-list (rectangle 1 1 'solid 'red))
+            (image->color-list (rectangle 1 1 'solid 'blue))
+            (image->color-list (rectangle 1 1 'solid 'black))
+            (image->color-list (rectangle 1 1 'solid 'white))))
+
+(test (list blue blue blue blue)
+      'color-list
+      (image->color-list (rectangle 2 2 'solid 'blue)))
+
+(test #t
+      'color-list
+      (image=? (color-list->image (list blue blue blue blue) 2 2 0 0)
+               (rectangle 2 2 'solid 'blue)))
+(test #f
+      'color-list
+      (image=? (color-list->image (list blue blue blue blue) 2 2 0 0)
+               (rectangle 1 4 'solid 'blue)))
+(test #t
+      'color-list
+      (image=? (color-list->image (list blue blue blue blue) 1 4 0 0)
+               (rectangle 1 4 'solid 'blue)))
+
+(test #t
+      'alpha-color-list1
+      (equal? (make-alpha-color 0 255 0 0)
+              (car (image->alpha-color-list (rectangle 1 1 'solid 'red)))))
+(test #t
+      'alpha-color-list2
+      (equal? (make-alpha-color 0 0 255 0)
+              (car (image->alpha-color-list (rectangle 1 1 'solid 'green)))))
+(test #t
+      'alpha-color-list3
+      (equal? (make-alpha-color 0 0 0 255)
+              (car (image->alpha-color-list (rectangle 1 1 'solid 'blue)))))
+
+(test #t
+      'alpha-color-list4
+      (= (image-width
+          (alpha-color-list->image
+           (list ared aclr ared
+                 aclr aclr aclr)
+           3
+           2
+           0
+           0))
+         3))
+
+(test #t
+      'alpha-color-list5
+      (= (image-height
+          (alpha-color-list->image
+           (list ared aclr ared
+                 aclr aclr aclr)
+           3
+           2
+           0
+           0))
+         2))
+
+(test #t
+      'alpha-color-list6
+      (equal? (image->color-list
+               (alpha-color-list->image
+                (list ared aclr ared
+                      aclr aclr aclr)
+                3 2 0 0))
+              (list red   white red
+                    white white white)))
+(test #t
+      'alpha-color-list7
+      (equal? (image->color-list
+               (overlay
+                (p00 (rectangle 3 3 'solid 'blue))
+                (p00 (alpha-color-list->image
+                      (list ared aclr ared
+                            aclr aclr aclr
+                            ared aclr ared)
+                      3
+                      3
+                      0
+                      0))))
+              (list red  blue red
+                    blue blue blue
+                    red  blue red)))
+
+(test #t
+      'image=?1
+      (image=? (alpha-color-list->image (list (make-alpha-color 200 100 150 175)) 1 1 0 0)
+               (alpha-color-list->image (list (make-alpha-color 200 100 150 175)) 1 1 0 0)))
+
+(test #t
+      'image=?2
+      (image=? (alpha-color-list->image (list (make-alpha-color 255 100 100 100)) 1 1 0 0)
+               (alpha-color-list->image (list (make-alpha-color 255 200 200 200)) 1 1 0 0)))
+
+(test #f
+      'image=?3
+      (image=? (alpha-color-list->image (list (make-alpha-color 200 100 100 100)) 1 1 0 0)
+               (alpha-color-list->image (list (make-alpha-color 200 200 200 200)) 1 1 0 0)))
+
+(test #f
+      'image=?4
+      (image=? (alpha-color-list->image (list (make-alpha-color 200 100 150 175)
+                                              (make-alpha-color 200 100 150 175))
+                                        1
+                                        2
+                                        0
+                                        0)
+               (alpha-color-list->image (list (make-alpha-color 200 100 150 175)
+                                              (make-alpha-color 200 100 150 175)) 
+                                        2
+                                        1
+                                        0
+                                        0)))
+
+(test #f
+      'image=?5
+      (image=? (rectangle 4 4 'outline 'black) 
+               (overlay/xy 
+                (rectangle 4 4 'outline 'black)
+                -1
+                -1
+                (circle 1 'solid 'red))))
+
+(test #t
+      'overlay
+      (image=? (color-list->image (list blue red blue red) 2 2 0 0)
+               (overlay (p00 (rectangle 2 2 'solid 'red))
+                        (p00 (rectangle 1 2 'solid 'blue)))))
+
+(test #t
+      'overlay/multiple
+      (image=? (overlay (rectangle 6 6 'solid 'red)
+                        (overlay (rectangle 4 4 'solid 'white)
+                                 (rectangle 2 2 'solid 'blue)))
+               (overlay (rectangle 6 6 'solid 'red)
+                        (rectangle 4 4 'solid 'white)
+                        (rectangle 2 2 'solid 'blue))))
+
+(test #t
+      'overlay/empty-spaces-are-unmasked
+      (image=? (color-list->image (list red red red blue) 2 2 0 0)
+               (overlay
+                (p00 (rectangle 2 2 'solid 'blue))
+                (overlay (p00 (rectangle 1 2 'solid 'red))
+                         (p00 (rectangle 2 1 'solid 'red))))))
+
+(test #t
+      'overlay/xy1
+      (image=? (color-list->image (list red blue red blue) 2 2 0 0)
+               (overlay/xy (p00 (rectangle 2 2 'solid 'red))
+                           1 0
+                           (p00 (rectangle 1 2 'solid 'blue)))))
+
+(test #t
+      'overlay/xy2
+      (image=? (color-list->image (list red red red blue) 2 2 0 0)
+               (overlay/xy (p00 (rectangle 2 2 'solid 'red))
+                           1 1
+                           (p00 (rectangle 1 1 'solid 'blue)))))
+
+(test #t
+      'overlay/xy3
+      (image=? (color-list->image (list red red blue blue) 2 2 0 0)
+               (overlay/xy (p00 (rectangle 2 1 'solid 'red))
+                           0 1
+                           (p00 (rectangle 2 1 'solid 'blue)))))
+
+(test #t
+      'overlay/xy4
+      (image=? (color-list->image (list blue blue red red) 2 2 0 0)
+               (overlay/xy (p00 (rectangle 2 1 'solid 'red))
+                           0 -1
+                           (p00 (rectangle 2 1 'solid 'blue)))))
+
+(test #t
+      'overlay/xy/white
+      (image=? (alpha-color-list->image (list ablack ablack ablack
+                                              ablack awhite ablack
+                                              ablack ablack ablack)
+                                        3 3 0 0)
+               (overlay/xy (p00 (rectangle 3 3 'solid 'black))
+                           1 1
+                           (p00 (rectangle 1 1 'solid 'white)))))
+
+(test #t
+      'color-list->image/white-in-mask
+      (image=? (color-list->image (list black red   black
+                                        red   red   red
+                                        black red   black)
+                                  3 3 0 0)
+               (overlay (p00 (rectangle 3 3 'solid 'red))
+                        (color-list->image (list black white black
+                                                 white white white
+                                                 black white black)
+                                           3 3 0 0))))
+
+
+(test #t
+      'overlay
+      (image=? (color-list->image (list red blue red red blue red) 3 2 0 0)
+               (overlay/xy (p00 (rectangle 3 2 'solid 'red))
+                           1 0
+                           (p00 (rectangle 1 2 'solid 'blue)))))
+
+(test #t
+      'image-inside?1
+      (image-inside? (overlay/xy (p00 (rectangle 3 2 'solid 'red))
+                                 1 0
+                                 (p00 (rectangle 1 2 'solid 'blue)))
+                     (rectangle 1 2 'solid 'blue)))
+
+(test #f
+      'image-inside?2
+      (image-inside? (overlay/xy (p00 (rectangle 3 2 'solid 'red))
+                                 1 0
+                                 (p00 (rectangle 1 2 'solid 'blue)))
+                     (rectangle 1 2 'solid 'black)))
+
+(test #t
+      'image-inside?3
+      (image-inside? (overlay/xy (p00 (rectangle 3 2 'solid 'red))
+                                 1 0
+                                 (p00 (rectangle 1 2 'solid 'blue)))
+                     (rectangle 1 2 'solid 'red)))
+
+(test #f
+      'image-inside?4
+      (image-inside? (overlay/xy (p00 (rectangle 3 2 'solid 'red))
+                                 1 0
+                                 (p00 (rectangle 1 2 'solid 'blue)))
+                     (rectangle 2 1 'solid 'red)))
+
+(test #t
+      'image-inside?5
+      (image-inside? (alpha-color-list->image (list (make-alpha-color 0 255 0 0)) 1 1 0 0)
+                     (alpha-color-list->image (list (make-alpha-color 255 0 0 0)) 1 1 0 0)))
+
+(test #f
+      'image-inside?6
+      (image-inside? (overlay/xy (p00 (rectangle 3 2 'solid 'red))
+                                 1 0
+                                 (p00 (rectangle 1 2 'solid 'blue)))
+                     (color-list->image (list blue white white) 
+                                        3 1 0 0)))
+
+(test #t
+      'image-inside?7
+      (image-inside? (overlay/xy (p00 (rectangle 16 16 'solid 'red))
+                                 2 5
+                                 (p00 (ellipse 6 6 'outline 'blue)))
+                     (ellipse 6 6 'outline 'blue)))
+
+(test #t
+      'image-inside?8
+      (image-inside?
+       (overlay (p00 (rectangle (image-width (text "x" 12 'red))
+                                (image-height (text "x" 12 'red))
+                                'solid 
+                                'white))
+                (text "x" 12 'red))
+       (text "x" 12 'red)))
+
+(test #t
+      'image-inside?9
+      (image-inside?
+       (text "y x y" 12 'red)
+       (text "x" 12 'red)))
+
+(test (make-posn 2 5)
+      'find-image1
+      (find-image (overlay/xy (p00 (rectangle 16 16 'solid 'red))
+                              2 5
+                              (p00 (ellipse 6 6 'outline 'blue)))
+                  (p00 (ellipse 6 6 'outline 'blue))))
+
+(test (make-posn 0 0)
+      'find-image2
+      (find-image (p00 (rectangle 16 16 'solid 'blue))
+                  (p00 (ellipse 6 6 'outline 'blue))))
+
+(test (make-posn 1 1)
+      'find-image3
+      (find-image (overlay/xy (rectangle 10 10 'solid 'blue)
+                              1
+                              1
+                              (ellipse 5 5 'solid 'red))
+                  (ellipse 5 5 'solid 'red)))
+
+(test 5
+      'image-width
+      (image-width (rectangle 5 7 'solid 'red)))
+
+(test 7
+      'image-height
+      (image-height (rectangle 5 7 'solid 'red)))
+
+(test 1 'color-red (color-red (make-color 1 2 3)))
+(test 2 'color-green (color-green (make-color 1 2 3)))
+(test 3 'color-blue (color-blue (make-color 1 2 3)))
+(test #t 'color?1 (color? (make-color 1 2 3)))
+(test #f 'color?2 (color? 10))
+(test #t 'image-color?1 (image-color? (make-color 1 2 3)))
+(test #t 'image-color?2 (image-color? "blue"))
+(test #t 'image-color?3 (image-color? 'blue))
+(test #f 'image-color?4 (image-color? 10))
+(test #f 'image-color?5 (image-color? "not-a-color"))
+(test #f 'image-color?6 (image-color? 'not-a-color))
+
+(test #t
+      'line 
+      (image=? (line 4 0 'red)
+               (color-list->image (list red red red red red) 5 1 0 0)))
+
+(test #t
+      'line 
+      (image=? (line 0 4 'red)
+               (color-list->image (list red red red red red) 1 5 0 0)))
+
+;; note: next two tests may be platform-specific... I'm not sure.
+;; I developed them under macos x. -robby
+(test #t
+      'triangle1
+      (image=? (triangle 3 'outline 'red)
+               (color-list->image 
+                (list white red   white
+                      white red   white
+                      red   white red
+                      red   red   red)
+                3
+                4
+                0
+                0)))
+
+(test #t
+      'triangle2
+      (image=? (triangle 3 'solid 'red)
+               (color-list->image 
+                (list white red   white
+                      white red   white
+                      red   red   red
+                      red   red   red)
+                3
+                4
+                0
+                0)))
+
+(test #t
+      'add-line1
+      (image=? (overlay (p00 (rectangle 5 4 'solid 'black))
+                        (p00 (rectangle 1 4 'solid 'red)))
+               (add-line (p00 (rectangle 4 4 'solid 'black))
+                         -1 0
+                         -1 3
+                         'red)))
+
+(test #t
+      'add-line2
+      (image=? (overlay (p00 (rectangle 4 5 'solid 'black))
+                        (p00 (rectangle 4 1 'solid 'red)))
+               (add-line (p00 (rectangle 4 4 'solid 'black))
+                         0 -1
+                         3 -1
+                         'red)))
+
+(test 7
+      'add-line3
+      (image-width (add-line (rectangle 7 7 'solid 'black)
+                             -3 0
+                             2 0
+                             'red)))
+
+(test #t
+      'add-line4
+      (image=? (overlay (rectangle 6 6 'solid 'blue)
+                        (rectangle 6 1 'solid 'red))
+               (add-line (rectangle 6 6 'solid 'blue)
+                         -3 0
+                         2 0
+                         'red)))
+
+(test 26
+      'add-line-w1
+      (image-width
+       (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
+                 -20 -20
+                 0 0
+                 'red)))
+(test 26
+      'add-line-w2
+      (image-width
+       (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
+                 -20 20
+                 0 0
+                 'red)))
+(test 26
+      'add-line-w3
+      (image-width
+       (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
+                 20 -20
+                 0 0
+                 'red)))
+(test 26
+      'add-line-w4
+      (image-width
+       (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
+                 20 20
+                 0 0
+                 'red)))
+
+(test 26
+      'add-line-w5
+      (image-width
+       (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
+                 0 0
+                 -20 -20
+                 'red)))
+(test 26
+      'add-line-w6
+      (image-width
+       (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
+                 0 0
+                 -20 20
+                 'red)))
+(test 26
+      'add-line-w7
+      (image-width
+       (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
+                 0 0
+                 20 -20
+                 'red)))
+(test 26
+      'add-line-w8
+      (image-width
+       (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
+                 0 0
+                 20 20
+                 'red)))
+
+(test 26
+      'add-line-h1
+      (image-height
+       (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
+                 -20 -20
+                 0 0
+                 'red)))
+(test 26
+      'add-line-h2
+      (image-height
+       (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
+                 -20 20
+                 0 0
+                 'red)))
+(test 26
+      'add-line-h3
+      (image-height
+       (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
+                 20 -20
+                 0 0
+                 'red)))
+(test 26
+      'add-line-h4
+      (image-height
+       (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
+                 20 20
+                 0 0
+                 'red)))
+
+(test 26
+      'add-line-h5
+      (image-height
+       (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
+                 0 0
+                 -20 -20
+                 'red)))
+(test 26
+      'add-line-h6
+      (image-height
+       (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
+                 0 0
+                 -20 20
+                 'red)))
+(test 26
+      'add-line-h7
+      (image-height
+       (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
+                 0 0
+                 20 -20
+                 'red)))
+(test 26
+      'add-line-h8
+      (image-height
+       (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
+                 0 0
+                 20 20
+                 'red)))
+
+(test (list 3 4)
+      'ph-ellipse
+      (list (pinhole-x (ellipse 6 8 'solid 'red))
+            (pinhole-y (ellipse 6 8 'solid 'red))))
+(test (list 3 3)
+      'ph-circle
+      (list (pinhole-x (circle 3 'solid 'red))
+            (pinhole-y (circle 3 'solid 'red))))
+(test (list 0 0)
+      'ph-line
+      (list (pinhole-x (line 10 10 'red))
+            (pinhole-y (line 10 10 'red))))
+(test (list 0 0)
+      'ph-text
+      (list (pinhole-x (text "10" 10 'red))
+            (pinhole-y (text "10" 10 'red))))
+
+(test (list 3 3)
+      'ph-add-line
+      (list (pinhole-x (add-line (rectangle 6 6 'solid 'red)
+                                 0 0
+                                 3 3
+                                 'black))
+            (pinhole-y (add-line (rectangle 6 6 'solid 'red)
+                                 0 0
+                                 3 3
+                                 'black))))
+(test (list 3 4)
+      'ph-overlay1
+      (list (pinhole-x (overlay (rectangle 6 8 'solid 'red) (rectangle 2 4 'solid 'red)))
+            (pinhole-y (overlay (rectangle 6 8 'solid 'red) (rectangle 2 4 'solid 'red)))))
+(test (list 0 0)
+      'ph-overlay2
+      (list (pinhole-x (overlay (move-pinhole (rectangle 6 8 'solid 'red) -3 -4)
+                                (move-pinhole (rectangle 2 4 'solid 'red) -1 -2)))
+            (pinhole-y (overlay (move-pinhole (rectangle 6 8 'solid 'red) -3 -4)
+                                (move-pinhole (rectangle 2 4 'solid 'red) -1 -2)))))
+(test (list 5 5)
+      'ph-overlay/xy1
+      (list (pinhole-x (overlay/xy (move-pinhole (rectangle 6 8 'solid 'red) -3 -4)
+                                   -5 -5
+                                   (move-pinhole (rectangle 2 4 'solid 'red) -1 -2)))
+            (pinhole-y (overlay/xy (move-pinhole (rectangle 6 8 'solid 'red) -3 -4)
+                                   -5 -5
+                                   (move-pinhole (rectangle 2 4 'solid 'red) -1 -2)))))
+
+
+(check-on-bitmap 'solid-rect (rectangle 2 2 'solid 'red))
+(check-on-bitmap 'outline-rect (rectangle 2 2 'outline 'red))
+(check-on-bitmap 'solid-ellipse (ellipse 2 4 'solid 'red))
+(check-on-bitmap 'outline-ellipse (ellipse 2 4 'outline 'red))
+(check-on-bitmap 'solid-ellipse (circle 4 'solid 'red))
+(check-on-bitmap 'outline-ellipse (circle 4 'outline 'red))
+(check-on-bitmap 'solid-triangle (triangle 10 'solid 'red))
+(check-on-bitmap 'outline-triangle (triangle 10 'outline 'red))
+(check-on-bitmap 'line (line 10 7 'red))
+(check-on-bitmap 'text (text "XX" 12 'red))
+(check-on-bitmap 'overlay1 (overlay (p00 (rectangle 1 4 'solid 'blue))
+                                   (p00 (rectangle 4 1 'solid 'green))))
+(check-on-bitmap 'overlay2 (overlay/xy (p00 (rectangle 4 4 'solid 'blue))
+                                      2 2
+                                      (p00 (rectangle 4 4 'solid 'green))))
+(check-on-bitmap 'overlay3 (overlay image-snip1
+                                    (rectangle (image-width image-snip1) 
+                                               (image-height image-snip1)
+                                               'outline
+                                               'red)))
+(check-on-bitmap 'alpha-color-list
+                 (overlay
+                  (p00 (rectangle 3 3 'solid 'blue))
+                  (alpha-color-list->image
+                   (list ared aclr ared
+                         aclr aclr aclr
+                         ared aclr ared)
+                   3
+                   3
+                   0
+                   0)))
+(check-on-bitmap 'add-line
+                 (add-line
+                  (p00 (rectangle 100 100 'solid 'black))
+                  -10 -10
+                  110 110
+                  'red))
+
+(check-on-bitmap 'add-line1
+                 (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
+                           -20 -20
+                           0 0
+                           'red))
+(check-on-bitmap 'add-line2
+                 (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
+                           -20 20
+                           0 0
+                           'red))
+(check-on-bitmap 'add-line3
+                 (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
+                           20 -20
+                           0 0
+                           'red))
+(check-on-bitmap 'add-line4
+                 (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
+                           20 20
+                           0 0
+                           'red)) 
+(check-on-bitmap 'add-line5
+                 (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
+                           0 0
+                           -20 -20
+                           'red))
+(check-on-bitmap 'add-line6
+                 (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
+                           0 0
+                           -20 20
+                           'red))
+(check-on-bitmap 'add-line7
+                 (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
+                           0 0
+                           20 -20
+                           'red))
+(check-on-bitmap 'add-line8
+                 (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
+                           0 0
+                           20 20
+                           'red))
+
+#|
+
+The tests beginning with "bs-" ensure
+that the operations all can accept bitmap 
+snips as arguments
+
+|#
+
+(test #t
+      'bs-image?
+      (image? image-snip1))
+(test #t
+      'bs-image?
+      (image? image-snip2))
+(test #t
+      'bs-image=?
+      (image=? image-snip1 image-snip2))
+(test 2
+      'bs-image-width
+      (image-width image-snip1))
+(test 2
+      'bs-image-width
+      (image-width image-snip2))
+(test 2
+      'bs-image-height
+      (image-height image-snip1))
+(test 2
+      'bs-image-height
+      (image-height image-snip2))
+(test #t
+      'bs-overlay
+      (image=? image-snip1 (overlay image-snip1 image-snip2)))
+(test #t
+      'bs-overlay/xy
+      (image=? image-snip1 (overlay/xy image-snip1 0 0 image-snip2)))
+(test #t
+      'bs-add-line
+      (image=?
+       (add-line image-snip1 0 0 10 10 'green)
+       (add-line image-snip2 0 0 10 10 'green)))
+(test #t
+      'bs-image-inside?1
+      (image-inside? image-snip1 image-snip2))
+(test #t
+      'bs-image-inside?2
+      (image-inside? image-snip1 image-snip2))
+(test (make-posn 0 0)
+      'bs-find-image1
+      (find-image image-snip1 image-snip2))
+(test (make-posn 0 0)
+      'bs-find-image2
+      (find-image image-snip2 image-snip1))
+(test #t
+      'bs-image->color-list
+      (equal? (image->color-list image-snip1)
+              (image->color-list image-snip2)))
+(test #t
+      'bs-image->alpha-color-list
+      (equal? (image->alpha-color-list image-snip1)
+              (image->alpha-color-list image-snip2)))
+(test 1
+      'bs-pinhole-x
+      (pinhole-x image-snip1))
+(test 1
+      'bs-pinhole-y
+      (pinhole-y image-snip2))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; test image-snip that doesnt' have a bitmap
+;;
+
+(test 20
+      'image-snip-no-bitmap1
+      (image-width image-snip3))
+
+(test 'passed
+      'image-snip-no-bitmap2
+      (begin (overlay/xy image-snip3 10 10 image-snip3) 'passed))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; test color arguments
+;;
+
+(test 'ignore
+      'clr-rectangle-sym
+      (ignore (rectangle 10 10 'solid 'blue)))
+(test 'ignore
+      'clr-rectangle-str
+      (ignore (rectangle 10 10 'solid "blue")))
+(test 'ignore
+      'clr-rectangle-clr
+      (ignore (rectangle 10 10 'solid (make-color 0 0 255))))
+
+(test 'ignore
+      'clr-ellipse-sym
+      (ignore (ellipse 10 10 'solid 'blue)))
+(test 'ignore
+      'clr-ellipse-str
+      (ignore (ellipse 10 10 'solid "blue")))
+(test 'ignore
+      'clr-ellipse-clr
+      (ignore (ellipse 10 10 'solid (make-color 0 0 255))))
+
+(test 'ignore
+      'clr-circle-sym
+      (ignore (circle 10 'solid 'blue)))
+(test 'ignore
+      'clr-circle-str
+      (ignore (circle 10 'solid "blue")))
+(test 'ignore
+      'clr-circle-clr
+      (ignore (circle 10 'solid (make-color 0 0 255))))
+
+(test 'ignore
+      'clr-triangle-sym
+      (ignore (triangle 10 'solid 'blue)))
+(test 'ignore
+      'clr-triangle-str
+      (ignore (triangle 10 'solid "blue")))
+(test 'ignore
+      'clr-triangle-clr
+      (ignore (triangle 10 'solid (make-color 0 0 255))))
+
+(test 'ignore
+      'clr-line-sym
+      (ignore (line 10 10 'blue)))
+(test 'ignore
+      'clr-line-str
+      (ignore (line 10 10 "blue")))
+(test 'ignore
+      'clr-line-clr
+      (ignore (line 10 10 (make-color 0 0 255))))
+
+(test 'ignore
+      'clr-add-line-sym
+      (ignore (add-line (rectangle 1 1 'solid 'blue) 0 0 1 1 'blue)))
+(test 'ignore
+      'clr-add-line-str
+      (ignore (add-line (rectangle 1 1 'solid 'blue) 0 0 1 1 "blue")))
+(test 'ignore
+      'clr-add-line-clr
+      (ignore (add-line (rectangle 1 1 'solid 'blue) 0 0 1 1 (make-color 0 0 255))))
+
+(test 'ignore
+      'clr-text-sym
+      (ignore (text "abc" 12 'blue)))
+(test 'ignore
+      'clr-text-str
+      (ignore (text "abc" 12 "blue")))
+(test 'ignore
+      'clr-text-clr
+      (ignore (text "abc" 12 (make-color 0 0 255))))
+
+(define (tp-exn/num re)
+  (lambda (exn)
+    (and (tp-exn? exn)
+         (regexp-match re (exn-message exn)))))
+
+;; tests that the expression
+;;  a) raises a teachpack exception record,
+;;  b) has the right argument position, and
+;;  c) has the right name.
+(define-syntax (err/rt-name-test stx)
+  (syntax-case stx ()
+    [(_ (name . args) position)
+     (identifier? (syntax name))
+     (syntax 
+      (err/rt-test (name . args)                   
+                   (lambda (exn)
+                     (and (tp-exn? exn)
+                          (let* ([msg (exn-message exn)]
+                                 [beg (format "~a:" 'name)]
+                                 [len (string-length beg)])
+                            (and (regexp-match position msg)
+                                 ((string-length msg) . > . len)
+                                 (string=? (substring msg 0 len) beg)))))))]))
+
+(err/rt-name-test (image-width 1) "first")
+(err/rt-name-test (image-height 1) "first")
+(err/rt-name-test (overlay 1 2) "first")
+(err/rt-name-test (overlay image-snip1 2) "second")
+(err/rt-name-test (overlay image-snip1 image-snip2 3) "3")
+(err/rt-name-test (overlay/xy #f #f #f #f) "first")
+(err/rt-name-test (overlay/xy image-snip1 #f #f #f) "second")
+(err/rt-name-test (overlay/xy image-snip1 1 #f #f) "third")
+(err/rt-name-test (overlay/xy image-snip1 1 1 #f) "fourth")
+(err/rt-name-test (pinhole-x 1) "first")
+(err/rt-name-test (pinhole-y 1) "first")
+(err/rt-name-test (move-pinhole #f #f #f) "first")
+(err/rt-name-test (move-pinhole image-snip1 #f #f) "second")
+(err/rt-name-test (move-pinhole image-snip1 0 #f) "third")
+(err/rt-name-test (rectangle #f #f #f #f) "first")
+(err/rt-name-test (rectangle 10 #f #f #f) "second")
+(err/rt-name-test (rectangle 10 10 #f #f) "third")
+(err/rt-name-test (rectangle 10 10 'solid #f) "fourth")
+(err/rt-name-test (circle #f #f #f) "first")
+(err/rt-name-test (circle 10 #f #f) "second")
+(err/rt-name-test (circle 10 'solid #f) "third")
+(err/rt-name-test (ellipse #f #f #f #f) "first")
+(err/rt-name-test (ellipse 10 #f #f #f) "second")
+(err/rt-name-test (ellipse 10 10 #f #f) "third")
+(err/rt-name-test (ellipse 10 10 'solid #f) "fourth")
+(err/rt-name-test (triangle #f #f #f) "first")
+(err/rt-name-test (triangle 10 #f #f) "second")
+(err/rt-name-test (triangle 10 'solid #f) "third")
+(err/rt-name-test (line #f #f #f) "first")
+(err/rt-name-test (line 10 #f #f) "second")
+(err/rt-name-test (line 10 10 #f) "third")
+(err/rt-name-test (add-line #f #f #f #f #f #f) "first")
+(err/rt-name-test (add-line image-snip1 #f #f #f #f #f) "second")
+(err/rt-name-test (add-line image-snip1 10 #f #f #f #f) "third")
+(err/rt-name-test (add-line image-snip1 10 10 #f #f #f) "fourth")
+(err/rt-name-test (add-line image-snip1 10 10 11 #f #f) "fifth")
+(err/rt-name-test (add-line image-snip1 10 10 11 11 #f) "sixth")
+(err/rt-name-test (text #f #f #f) "first")
+(err/rt-name-test (text "abc" #f #f) "second")
+(err/rt-name-test (text "abc" 10 #f) "third")
+(err/rt-name-test (image-inside? #f #f) "first")
+(err/rt-name-test (image-inside? image-snip1 #f) "second")
+(err/rt-name-test (find-image #f #f) "first")
+(err/rt-name-test (find-image image-snip1 #f) "second")
+(err/rt-name-test (image->color-list 1) "first")
+(err/rt-name-test (color-list->image #f #f #f #f #f) "first")
+(err/rt-name-test (color-list->image (list (make-color 0 0 0)) #f #f #f #f) "second")
+(err/rt-name-test (color-list->image (list (make-color 0 0 0)) 1 #f #f #f) "third")
+(err/rt-name-test (color-list->image (list (make-color 0 0 0)) 1 1 #f #f) "fourth")
+(err/rt-name-test (color-list->image (list (make-color 0 0 0)) 1 1 0 #f) "fifth")
+(err/rt-name-test (image->alpha-color-list #f) "first")
+(err/rt-name-test (alpha-color-list->image #f #f #f #f #f) "first")
+(err/rt-name-test (alpha-color-list->image (list (make-alpha-color 0 0 0 0)) #f #f #f #f) "second")
+(err/rt-name-test (alpha-color-list->image (list (make-alpha-color 0 0 0 0)) 1 #f #f #f) "third")
+(err/rt-name-test (alpha-color-list->image (list (make-alpha-color 0 0 0 0)) 1 1 #f #f) "fourth")
+(err/rt-name-test (alpha-color-list->image (list (make-alpha-color 0 0 0 0)) 1 1 0 #f) "fifth")
+
+(report-errs)
\ No newline at end of file
diff --git a/collects/tests/mzscheme/htdp-test.ss b/collects/tests/mzscheme/htdp-test.ss
new file mode 100644
index 0000000000..fb9d9d6ce7
--- /dev/null
+++ b/collects/tests/mzscheme/htdp-test.ss
@@ -0,0 +1,77 @@
+
+(define (htdp-syntax-test stx)
+  (syntax-test #`(module m #,current-htdp-lang
+		   #,stx)))
+
+(define body-accum null)
+(define-syntax (htdp-top stx)
+  (syntax-case stx (quote)
+    [(_ expr)
+     #'(set! body-accum (append body-accum (list #'expr)))]))
+(define (htdp-top-pop w)
+  (set! body-accum (let loop ([body-accum body-accum])
+		     (if (null? (cdr body-accum))
+			 null
+			 (cons (car body-accum) (loop (cdr body-accum)))))))
+
+(define-syntax (htdp-test stx)
+  (syntax-case stx ()
+    [(_ expect f . args)
+     #'(do-htdp-test #'(test expect f . args) #f #f)]))
+
+(define-syntax (htdp-err/rt-test stx)
+  (syntax-case stx ()
+    [(_ expr)
+     #'(do-htdp-test #'expr #f exn:application:type?)]
+    [(_ expr exn?)
+     #'(do-htdp-test #'expr #f exn?)]))
+
+(define (htdp-error-test stx)
+  (do-htdp-test stx #t #f))
+
+
+(module helper mzscheme
+  (define-syntax (module-begin stx)
+    (syntax-case stx ()
+     [(_ the-test lang to-export . rest)
+      #`(#%module-begin
+	 (require (rename tester the-test test))
+	 (require lang)
+         #,@(if (syntax-object->datum (syntax to-export))
+                (list (syntax (provide to-export)))
+                '())
+	 . rest)]))
+  (provide (rename module-begin #%module-begin)))
+       
+(module tester mzscheme
+  (define test (namespace-variable-value 'test))
+  (provide test))
+
+(define (do-htdp-test stx stx-err? exn?)
+  (let ([name (gensym 'm)])
+    ((if stx-err? syntax-test eval)
+     #`(module #,name helper
+	 test
+	 (all-except #,current-htdp-lang #%module-begin)
+         #f
+	 #,@body-accum
+	 #,stx))
+    (unless stx-err?
+      (if exn?
+	  (err/rt-test (eval #`(require #,name)) exn?)
+	  (eval #`(require #,name))))))
+
+(define-syntax (htdp-eval stx)
+  (syntax-case stx ()
+    [(_ arg) (syntax (do-htdp-eval #'arg))]))
+
+(define (do-htdp-eval stx)
+  (let ([name (gensym 'm)])
+    (eval
+     #`(module #,name helper
+	 test
+	 (all-except #,current-htdp-lang #%module-begin)
+         the-answer
+	 #,@body-accum
+	 (define the-answer #,stx)))
+    (dynamic-require name 'the-answer)))
diff --git a/collects/tests/mzscheme/image.ss b/collects/tests/mzscheme/image.ss
new file mode 100644
index 0000000000..41219f0676
--- /dev/null
+++ b/collects/tests/mzscheme/image.ss
@@ -0,0 +1,32 @@
+
+; Tests image saving/loading by dumping an image
+;  and loading it with every report-errs
+
+(define dump/restore
+  (lambda ()
+    (printf "Dumping image...~n")
+    (let ([result (write-image-to-file "tmp9")])
+      (if (vector? result)
+	  (printf "Continuing ~a~n" result)
+	  (read-image-from-file "tmp9" #("after" "restore"))))))
+
+(define ll null)
+(define load-relative
+  (lambda (f)
+    (set! ll (append ll (list f)))))
+
+(#%load-relative "all.ss")
+
+(define load-relative #%load-relative)
+
+(define go
+  (let ([d (current-load-relative-directory)])
+    (lambda ()
+      (parameterize ([current-load-relative-directory d])
+		    (for-each
+		     (lambda (f)
+		       (load-relative f)
+		       (dump/restore))
+		     ll)))))
+
+(printf "Run `(go)'~n")
diff --git a/collects/tests/mzscheme/imap.ss b/collects/tests/mzscheme/imap.ss
new file mode 100644
index 0000000000..f5209ff273
--- /dev/null
+++ b/collects/tests/mzscheme/imap.ss
@@ -0,0 +1,169 @@
+
+(define imap-server "imap.cs.utah.edu")
+(define imap-port-no 993)
+(define username "mflatt")
+(define pw (with-input-from-file (build-path (current-load-relative-directory) "pw")
+	     read))
+(define mailbox-name "INBOX.tmp") ;; !!! ALL CONTENT WILL BE DELETED !!!
+
+(load-relative "loadtest.ss")
+
+(SECTION 'imap)
+
+(require (lib "mzssl.ss" "openssl")
+	 (lib "imap.ss" "net")
+	 (lib "etc.ss"))
+
+(define (test-connect)
+  (let ([c (ssl-make-client-context)])
+    (let-values ([(in out) (ssl-connect imap-server imap-port-no c)])
+      (imap-connect* in out username pw mailbox-name))))
+
+(define-values (imap cnt recent) (test-connect))
+
+(printf "Msgs: ~a; Validity: ~a~n" cnt (imap-uidvalidity imap))
+
+(test cnt imap-messages imap)
+(test recent imap-recent imap)
+(test #t number? (imap-uidvalidity imap))
+(test #f imap-pending-expunges? imap)
+(test #f imap-pending-updates? imap)
+(test #f imap-new? imap)
+
+(imap-disconnect imap)
+done
+
+(define (delete-all)
+  (let ([cnt (imap-messages imap)])
+    (unless (zero? cnt)
+      (let ([all (build-list cnt add1)])
+	(test (void) imap-store imap '+ all '|\Deleted|)
+	(test (void) imap-expunge imap)
+	(test #t imap-pending-expunges? imap)
+	(test all imap-get-expunges imap)
+	(test null imap-get-expunges imap)
+	(test #f imap-pending-expunges? imap)))))
+
+(delete-all)
+(test #f imap-new? imap)
+(test 0 imap-messages imap)
+(test '(0 0) 'noop (let-values ([(a b) (imap-noop imap)])
+		     (list a b)))
+(test (void) imap-poll imap)
+(test 0 imap-messages imap)
+(test 0 imap-recent imap)
+
+(test #f imap-new? imap)
+
+(define (add-one content total)
+  (test (void) imap-append imap mailbox-name content)
+  (imap-noop imap)
+  (test total imap-messages imap)
+  (test #t imap-new? imap)
+  (let ([uids (imap-get-messages imap (build-list total add1) '(uid))])
+    (test #t list? uids)
+    (test total length uids)
+    (let ([l (list-ref uids (sub1 total))])
+      (test #t list? l)
+      (test 1 length l)
+      (test #t number? (car l))
+      (car l))))
+  
+
+(define sample-head #"Subject: Hello\r\n\r\n")
+(define sample-body #"Hi there.\r\n")
+
+(let ([uid (add-one (bytes-append sample-head sample-body) 1)])
+  (test (list (list uid 
+		    sample-head
+		    sample-body
+		    '(|\Seen|)))
+	imap-get-messages imap '(1) '(uid header body flags)))
+(test (void) imap-store imap '+ '(1) (list (symbol->imap-flag 'answered)))
+(test (list '((|\Answered| |\Seen|))) imap-get-messages imap '(1) '(flags))
+(test (void) imap-store imap '- '(1) (list (symbol->imap-flag 'answered)))
+(test (list '((|\Seen|))) imap-get-messages imap '(1) '(flags))
+(test (void) imap-store imap '+ '(1) (list (symbol->imap-flag 'deleted)))
+(test (list '((|\Seen| |\Deleted|))) imap-get-messages imap '(1) '(flags))
+(test (void) imap-store imap '! '(1) (list (symbol->imap-flag 'answered)))
+(test (list '((|\Answered|))) imap-get-messages imap '(1) '(flags))
+
+(test #f imap-pending-updates? imap)
+(test null imap-get-updates imap)
+
+;; Test multiple-client access:
+(let ()
+  (define-values (imap2 cnt2 recent2) (test-connect))
+  (test '(1 0) list cnt2 recent2)
+  
+  (let ([uid (add-one (bytes-append sample-head sample-body) 2)])
+    (let loop ([n 5])
+      (when (zero? n)
+	(imap-noop imap2))
+      (imap-poll imap2)
+      (unless (imap-new? imap2)
+	(sleep 0.2)
+	(loop (sub1 n))))
+    (test #t imap-new? imap2)
+    (test 2 imap-messages imap2)
+    (let ([uids (imap-get-messages imap2 '(2) '(uid))])
+      (test uid caar uids)))
+
+  ;; Delete message on imap2, check notifcation to imap
+  (test (void) imap-store imap2 '+ '(2) (list (symbol->imap-flag 'deleted)))
+  (test (void) imap-expunge imap2)
+  (test '(2) imap-get-expunges imap2)
+  (imap-noop imap)
+  (err/rt-test (imap-store imap '+ '(2) (list (symbol->imap-flag 'answered))))
+  (test #t imap-pending-expunges? imap)
+  (test '(2) imap-get-expunges imap)
+
+  ;; Adjust flags on imap2, check notifcation to imap
+  (test #f imap-pending-updates? imap)
+  (test (void) imap-store imap2 '+ '(1) (list (symbol->imap-flag 'deleted)))
+  (imap-noop imap)
+  (test #t imap-pending-updates? imap)
+  (test #t list? (imap-get-updates imap))
+  (test #f imap-pending-updates? imap)
+
+  ;; Check that multiple updates are collapsed:
+  (test (void) imap-store imap2 '- '(1) (list (symbol->imap-flag 'deleted)))  
+  (imap-noop imap)
+  (test #t imap-pending-updates? imap)
+  (test (void) imap-store imap2 '+ '(1) (list (symbol->imap-flag 'deleted)))
+  (test (void) imap-store imap2 '- '(1) (list (symbol->imap-flag 'deleted)))
+  (imap-noop imap)
+  (test #t imap-pending-updates? imap)
+  (test 1 length (imap-get-updates imap))
+  
+  (test (void) imap-reset-new! imap2)
+  (add-one (bytes-append sample-head sample-body) 2)
+  (add-one (bytes-append sample-head sample-body) 3)
+  (add-one (bytes-append sample-head sample-body) 4)
+  (add-one (bytes-append sample-head sample-body) 5)
+  (imap-noop imap2)
+  (test #t imap-new? imap2)
+  (test 5 imap-messages imap)
+  (test 5 imap-messages imap2)
+
+  (test #t list? (imap-get-messages imap '(1 2 3 4 5) '(uid)))
+  (test #t list? (imap-get-messages imap2 '(1 2 3 4 5) '(uid)))
+  
+  ;; Test deleteing multiple messages, and shifts in flag updates
+  (test (void) imap-store imap2 '+ '(2 4) (list (symbol->imap-flag 'deleted)))
+  (test (void) imap-store imap2 '+ '(3 5) (list (symbol->imap-flag 'answered)))
+  (test (void) imap-expunge imap2)
+  (imap-noop imap)
+  (imap-noop imap2)
+  (test #t imap-pending-expunges? imap)
+  (test #t imap-pending-expunges? imap2)
+  (test '(2 4) imap-get-expunges imap)
+  (test '(2 4) imap-get-expunges imap2)
+  (test #t imap-pending-updates? imap)
+  (test '(2 3) map car (imap-get-updates imap))
+
+  (imap-disconnect imap2))
+
+(imap-disconnect imap)
+
+(report-errs)
diff --git a/collects/tests/mzscheme/intermediate-lambda.ss b/collects/tests/mzscheme/intermediate-lambda.ss
new file mode 100644
index 0000000000..b00fafad2b
--- /dev/null
+++ b/collects/tests/mzscheme/intermediate-lambda.ss
@@ -0,0 +1,34 @@
+
+;; Basic checks for the intermediate language. See also
+;;  beginner.ss
+
+(load-relative "loadtest.ss")
+
+;; Don't need these:
+(define no-extra-if-tests? #t)
+
+;; Check export names:
+(require (lib "docprovide.ss" "syntax"))
+(let ([docs (lookup-documentation '(lib "htdp-intermediate-lambda.ss" "lang") 'procedures)])
+  (for-each
+   (lambda (row)
+     (for-each
+      (lambda (doc)
+	(let ([v (dynamic-require '(lib "htdp-intermediate-lambda.ss" "lang") (car doc))])
+	  (when (procedure? v)
+	    (test (car doc) object-name v))))
+      (cdr row)))
+   docs))
+
+(define current-htdp-lang '(lib "htdp-intermediate-lambda.ss" "lang"))
+(load-relative "htdp-test.ss")
+
+(require (lib "htdp-intermediate-lambda.ss" "lang"))
+
+(load-relative "beg-adv.ss")
+(load-relative "beg-intml.ss")
+(load-relative "bega-adv.ss")
+(load-relative "intm-intml.ss")
+(load-relative "intm-adv.ss")
+
+(report-errs)
diff --git a/collects/tests/mzscheme/intermediate.ss b/collects/tests/mzscheme/intermediate.ss
new file mode 100644
index 0000000000..920b901cf1
--- /dev/null
+++ b/collects/tests/mzscheme/intermediate.ss
@@ -0,0 +1,35 @@
+
+;; Basic checks for the intermediate language. See also
+;;  beginner.ss
+
+(load-relative "loadtest.ss")
+
+;; Don't need these:
+(define no-extra-if-tests? #t)
+
+;; Check export names:
+(require (lib "docprovide.ss" "syntax"))
+(let ([docs (lookup-documentation '(lib "htdp-intermediate.ss" "lang") 'procedures)])
+  (for-each
+   (lambda (row)
+     (for-each
+      (lambda (doc)
+	(let ([v (dynamic-require '(lib "htdp-intermediate.ss" "lang") (car doc))])
+	  (when (procedure? v)
+	    (test (car doc) object-name v))))
+      (cdr row)))
+   docs))
+
+(define current-htdp-lang '(lib "htdp-intermediate.ss" "lang"))
+(load-relative "htdp-test.ss")
+
+(require (lib "htdp-intermediate.ss" "lang"))
+
+(load-relative "beg-adv.ss")
+(load-relative "beg-intml.ss")
+(load-relative "beg-intm.ss")
+(load-relative "bega-adv.ss")
+(load-relative "intm-intml.ss")
+(load-relative "intm-adv.ss")
+
+(report-errs)
diff --git a/collects/tests/mzscheme/intm-adv.ss b/collects/tests/mzscheme/intm-adv.ss
new file mode 100644
index 0000000000..6b1b47af79
--- /dev/null
+++ b/collects/tests/mzscheme/intm-adv.ss
@@ -0,0 +1,102 @@
+
+;; These are true for beginner, but the operators are syntax, so
+;; arity-test doesn't work.
+(arity-test + 2 -1)
+(arity-test * 2 -1)
+(arity-test / 2 -1)
+(arity-test - 1 -1)
+
+(htdp-syntax-test #'local)
+(htdp-syntax-test #'(local))
+(htdp-syntax-test #'(local ()))
+(htdp-syntax-test #'(local 1))
+(htdp-syntax-test #'(local 1 1))
+(htdp-syntax-test #'(local () 1 2))
+(htdp-syntax-test #'(local [1] 1 2))
+(htdp-syntax-test #'(local [(+ 1 2)] 1))
+(htdp-syntax-test #'(local [(define x)] 1))
+(htdp-syntax-test #'(local [(lambda (x) x)] 1))
+(htdp-syntax-test #'(local [(define x 1) (define x 2)] 1))
+(htdp-syntax-test #'(local [(define (x a) 12) (+ 1 2)] 1))
+
+(htdp-err/rt-test (local [(define x y) (define y 5)] 10) exn:fail:contract:variable?)
+
+(htdp-test 1 'local (local () 1))
+(htdp-test 5 'local (local [(define y 5) (define x y)] x))
+(htdp-test #t 'local (local [(define (even n) (if (zero? n) true (odd (sub1 n))))
+			(define (odd n) (if (zero? n) false (even (sub1 n))))]
+		       (even 100)))
+(htdp-test 19 (local [(define (f x) (+ x 10))] f) 9)
+(htdp-test 16 'local (local [(define (f x) (+ x 10))] (f 6)))
+
+(htdp-syntax-test #'letrec)
+(htdp-syntax-test #'(letrec))
+(htdp-syntax-test #'(letrec ()))
+(htdp-syntax-test #'(letrec 1 2))
+(htdp-syntax-test #'(letrec 1 2 3))
+(htdp-syntax-test #'(letrec (10) 1))
+(htdp-syntax-test #'(letrec ([x]) 1))
+(htdp-syntax-test #'(letrec ([x 2 3]) 1))
+(htdp-syntax-test #'(letrec ([x 5] 10) 1))
+(htdp-syntax-test #'(letrec ([1 5]) 1))
+(htdp-syntax-test #'(letrec ([1 5 6]) 1))
+(htdp-syntax-test #'(letrec ([x 5]) 1 2))
+(htdp-syntax-test #'(letrec ([x 5][x 6]) 1))
+
+(htdp-err/rt-test (letrec ([x y] [y 5]) 10) exn:fail:contract:variable?)
+
+(htdp-test 1 'letrec (letrec () 1))
+(htdp-test 5 'letrec (letrec ([y 5][x y]) x))
+(htdp-test #t 'letrec (letrec ([even (lambda (n) (if (zero? n) true (odd (sub1 n))))]
+			  [odd (lambda (n) (if (zero? n) false (even (sub1 n))))])
+		   (even 100)))
+(htdp-test 19 (letrec ([f (lambda (x) (+ x 10))]) f) 9)
+(htdp-test 16 'letrec (letrec ([f (lambda (x) (+ x 10))]) (f 6)))
+
+(htdp-syntax-test #'let)
+(htdp-syntax-test #'(let))
+(htdp-syntax-test #'(let ()))
+(htdp-syntax-test #'(let 1 2))
+(htdp-syntax-test #'(let 1 2 3))
+(htdp-syntax-test #'(let (10) 1))
+(htdp-syntax-test #'(let ([x]) 1))
+(htdp-syntax-test #'(let ([x 2 3]) 1))
+(htdp-syntax-test #'(let ([x 5] 10) 1))
+(htdp-syntax-test #'(let ([1 5]) 1))
+(htdp-syntax-test #'(let ([1 5 6]) 1))
+(htdp-syntax-test #'(let ([x 5]) 1 2))
+(htdp-syntax-test #'(let ([x 5][x 6]) 1))
+
+(htdp-test 1 'let (let () 1))
+(htdp-test 5 'let (let ([y 5]) (let ([x y]) x)))
+(htdp-test 6 'let (let ([y 6]) (let ([y 10][x y]) x)))
+(htdp-test 19 (let ([f (lambda (x) (+ x 10))]) f) 9)
+(htdp-test 16 'let (let ([f (lambda (x) (+ x 10))]) (f 6)))
+
+(htdp-syntax-test #'let*)
+(htdp-syntax-test #'(let*))
+(htdp-syntax-test #'(let* ()))
+(htdp-syntax-test #'(let* 1 2))
+(htdp-syntax-test #'(let* 1 2 3))
+(htdp-syntax-test #'(let* (10) 1))
+(htdp-syntax-test #'(let* ([x]) 1))
+(htdp-syntax-test #'(let* ([x 2 3]) 1))
+(htdp-syntax-test #'(let* ([x 5] 10) 1))
+(htdp-syntax-test #'(let* ([1 5]) 1))
+(htdp-syntax-test #'(let* ([1 5 6]) 1))
+(htdp-syntax-test #'(let* ([x 5]) 1 2))
+
+(htdp-test 1 'let* (let* () 1))
+(htdp-test 6 'let* (let* ([x 5][x 6]) x))
+(htdp-test 9 'let* (let* ([x 8][x (add1 x)]) x))
+(htdp-test 5 'let* (let* ([y 5]) (let* ([x y]) x)))
+(htdp-test 10 'let* (let* ([y 6]) (let* ([y 10][x y]) x)))
+(htdp-test 19 (let* ([f (lambda (x) (+ x 10))]) f) 9)
+(htdp-test 16 'let* (let* ([f (lambda (x) (+ x 10))]) (f 6)))
+
+(htdp-test 7779 'time (time 7779))
+(htdp-syntax-test #'time)
+(htdp-syntax-test #'(time))
+(htdp-syntax-test #'(time 1 2))
+(htdp-syntax-test #'(time (define x 5)))
+
diff --git a/collects/tests/mzscheme/intm-intml.ss b/collects/tests/mzscheme/intm-intml.ss
new file mode 100644
index 0000000000..471d64accc
--- /dev/null
+++ b/collects/tests/mzscheme/intm-intml.ss
@@ -0,0 +1,5 @@
+
+(htdp-syntax-test #'(recur empty-f () 10))
+
+(htdp-syntax-test #'(let name ([x 12]) 10))
+
diff --git a/collects/tests/mzscheme/intmlam-adv.ss b/collects/tests/mzscheme/intmlam-adv.ss
new file mode 100644
index 0000000000..e8294b1a9c
--- /dev/null
+++ b/collects/tests/mzscheme/intmlam-adv.ss
@@ -0,0 +1,16 @@
+
+(syntax-test #'(lambda (z z) 10))
+
+(define f7 (lambda (y) (lambda (z) z)))
+(test #t procedure? f7)
+(test 778 (lambda (x) 778) 'ignored)
+
+(test values (lambda (f) (f f)) values)
+
+(define (f11 y) ((lambda (x) x) y))
+(test 'id f11 'id)
+
+(err/rt-test (1 2 3))
+(err/rt-test (+) exn:application:arity?)
+
+
diff --git a/collects/tests/mzscheme/iobuf.ss b/collects/tests/mzscheme/iobuf.ss
new file mode 100644
index 0000000000..fab7fff75d
--- /dev/null
+++ b/collects/tests/mzscheme/iobuf.ss
@@ -0,0 +1,70 @@
+
+(load-relative "loadtest.ss")
+
+(when (file-exists? "tmp-pipe")
+  (delete-file "tmp-pipe"))
+
+(require (lib "process.ss"))
+(system "mknod tmp-pipe p")
+
+(define i1 (open-input-file "tmp-pipe"))
+(define i2 (open-input-file "tmp-pipe"))
+(define o (open-output-file "tmp-pipe" 'append))
+
+(let ([t (thread
+	  (lambda ()
+	    (with-handlers ([exn:break? void])
+	      (parameterize-break #f
+		(read-bytes-avail!/enable-break (make-bytes 2) i1)))))])
+  (sleep 0.1)
+  (break-thread t)
+  (sleep 0.1)
+  (test #f thread-running? t))
+
+;; Reading from i1 will pull in all ready chars
+(define (test-buffered i1 i2)
+  (test #"he" read-bytes 2 i1)
+  (test #f char-ready? i2)
+  (test #"ll" read-bytes 2 i1)
+  (test #"o\n" read-bytes 2 i1)
+  (test #f char-ready? i1)
+  (test #f char-ready? i2))
+
+(display "hello\n" o)
+(test-buffered i1 i2)
+(display "hello\n" o)
+(test-buffered i2 i1)
+
+(close-output-port o)
+(test eof read-byte i1)
+(test eof read-byte i2)
+(close-input-port i1)
+(close-input-port i2)
+
+(define i1 (open-input-file "tmp-pipe"))
+(define i2 (open-input-file "tmp-pipe"))
+(define o (open-output-file "tmp-pipe" 'append))
+
+(test 'block file-stream-buffer-mode i1)
+(test 'block file-stream-buffer-mode i2)
+(test (void) file-stream-buffer-mode i1 'none)
+(test (void) file-stream-buffer-mode i2 'none)
+
+(define (test-unbuffered i1 i2)
+  (let ([s (make-bytes 10)])
+    (test 1 peek-bytes-avail! s 0 #f i1)
+    (test 1 peek-bytes-avail! s 0 #f i1))
+  (test #"he" read-bytes 2 i1)
+  (test #t char-ready? i2)
+  (test #"ll" read-bytes 2 i2)
+  (test #"o\n" read-bytes 2 i1)
+  (test #f char-ready? i1)
+  (test #f char-ready? i2))
+
+(display "hello\n" o)
+(test-unbuffered i1 i2)
+(display "hello\n" o)
+(test-unbuffered i2 i1)
+
+
+(report-errs)
diff --git a/collects/tests/mzscheme/ktest.ss b/collects/tests/mzscheme/ktest.ss
new file mode 100644
index 0000000000..86d2d0ddba
--- /dev/null
+++ b/collects/tests/mzscheme/ktest.ss
@@ -0,0 +1,11 @@
+(define k 
+  (call-with-current-continuation
+   (lambda (exit)
+     (let loop ((n 60000))
+       (if (zero? n)
+	   (let ((v (call-with-current-continuation (lambda (k) k))))
+	    (if (number? v)
+		v
+		(exit v)))
+	  (- (loop (- n 1)) 1))))))
+
diff --git a/collects/tests/mzscheme/loadable.ss b/collects/tests/mzscheme/loadable.ss
new file mode 100644
index 0000000000..eb943a3fab
--- /dev/null
+++ b/collects/tests/mzscheme/loadable.ss
@@ -0,0 +1 @@
+"This is a simple file used by param.ss"
diff --git a/collects/tests/mzscheme/loadtest.ss b/collects/tests/mzscheme/loadtest.ss
new file mode 100644
index 0000000000..78776a5dbd
--- /dev/null
+++ b/collects/tests/mzscheme/loadtest.ss
@@ -0,0 +1,3 @@
+
+(unless (namespace-variable-value 'SECTION #f (lambda () #f))
+  (load-relative "testing.ss"))
diff --git a/collects/tests/mzscheme/loop.ss b/collects/tests/mzscheme/loop.ss
new file mode 100644
index 0000000000..18fde593f5
--- /dev/null
+++ b/collects/tests/mzscheme/loop.ss
@@ -0,0 +1,29 @@
+
+
+(define five +)
+
+(define (one v)
+  (if (equal? v 15)
+      (apply five (list 1 2 3 4 5))
+      15))
+
+(define (dloop x d)
+  (if (zero? d)
+      0
+      (if (equal? x 15)
+	  (let ([v (one 10)])
+	    (let ([c (one v)])
+	      (add1 (dloop c (sub1 d)))))
+	  (dloop 15 d))))
+
+(define (loop)
+  (let loop ([n 0])
+    (let ([v (dloop 0 n)])
+      (if (equal? n v)
+	  (begin
+	    (when (zero? (modulo n 100))
+		  (printf "~a~n" n))
+	    (loop (add1 n)))
+	  (error 'loop "messed up: ~a != ~a~n" n v)))))
+
+
diff --git a/collects/tests/mzscheme/ltest.ss b/collects/tests/mzscheme/ltest.ss
new file mode 100644
index 0000000000..5765a97c42
--- /dev/null
+++ b/collects/tests/mzscheme/ltest.ss
@@ -0,0 +1,88 @@
+(printf "nested loop~n")
+(time
+ (let loop ([n 10000])
+  (unless (zero? n)
+      (let loop2 ([m 10])
+	(if (zero? m)
+	    (loop (sub1 n))
+	    (loop2 (sub1 m)))))))
+
+(printf "single loop~n")
+(time
+ (let loop ([n 100000])
+   (unless (zero? n)
+	   (loop (sub1 n)))))
+
+(printf "Y loop~n")
+(time
+ ((lambda (f n) (f f n))
+  (lambda (loop n)
+    (unless (zero? n)
+	    (loop loop (sub1 n))))
+  100000))
+
+
+(printf "let closure recur~n")
+(time
+ (let ([f (lambda (x) (sub1 x))])
+   (let loop ([n 100000])
+     (unless (zero? n)
+	     (loop (f n))))))
+
+(printf "direct closure recur~n")
+(time
+ (let loop ([n 100000])
+   (unless (zero? n)
+	   (loop ((lambda (x) (sub1 x)) n)))))
+
+(printf "direct closure recur if~n")
+(time
+ (let loop ([n 100000])
+   (if (zero? n)
+       (void)
+       (loop ((lambda (x) (sub1 x)) n)))))
+
+(printf "let closure top-level~n")
+(define loop
+ (let ([f (lambda (x) (sub1 x))])
+   (lambda (n)
+     (unless (zero? n)
+	     (loop (f n))))))
+(time (loop 100000))
+
+(printf "direct closure top-level~n")
+(define loop
+  (lambda (n)
+    (unless (zero? n)
+	    (loop ((lambda (x) (sub1 x)) n)))))
+(time (loop 100000))
+
+
+; > (load "ltest.ss")
+; cpu time: 1820  real time: 1826
+; cpu time: 1420  real time: 1422
+; cpu time: 1960  real time: 1957
+; cpu time: 2630  real time: 2626
+; > (load "ltest.ss")
+; cpu time: 1790  real time: 1803
+; cpu time: 1430  real time: 1468
+; cpu time: 2150  real time: 2159
+; cpu time: 2820  real time: 2824
+
+; > (load "ltest.ss")
+; nested loop
+; cpu time: 1750  real time: 1817
+; single loop
+; cpu time: 1430  real time: 1425
+; Y loop
+; cpu time: 1500  real time: 1500
+; let closure recur
+; cpu time: 1830  real time: 1835
+; direct closure recur
+; cpu time: 1790  real time: 1791
+; direct closure recur if
+; cpu time: 1800  real time: 1793
+; let closure top-level
+; cpu time: 1810  real time: 1804
+; direct closure top-level
+; cpu time: 1760  real time: 1758
diff --git a/collects/tests/mzscheme/macro.ss b/collects/tests/mzscheme/macro.ss
new file mode 100644
index 0000000000..b787cf4688
--- /dev/null
+++ b/collects/tests/mzscheme/macro.ss
@@ -0,0 +1,273 @@
+
+(load-relative "loadtest.ss")
+
+(SECTION 'MACRO)
+
+(error-test #'(define-syntaxes () (values 1)) exn:application:arity?)
+(error-test #'(define-syntaxes () (values 1 2)) exn:application:arity?)
+(error-test #'(define-syntaxes (x) (values 1 2)) exn:application:arity?)
+(error-test #'(define-syntaxes (x y) (values 1)) exn:application:arity?)
+(error-test #'(define-syntaxes (x y) (values 1 2 3)) exn:application:arity?)
+
+;; Declarations:
+(define-syntaxes (x) (values))
+(define-syntaxes (x y) (values))
+
+(define-syntax mx
+  (lambda (stx)
+    (syntax-case stx ()
+      [(_ x)
+       (syntax (x 1 8))])))
+(test 9 'macro (mx +))
+(test -7 'macro (mx -))
+(test 18 'macro (let ([mx (lambda (x) (x 1 8 9))]) (mx +)))
+
+(define-syntax (m stx)
+  (syntax-case stx ()
+    [(_) #'(m2 x)]))
+
+(define-syntax (m2 stx)
+  (syntax-case stx ()
+    [(_ y) #'(let ([y 10]
+		   [x 8])
+	       y)]))
+
+(test 10 'hygiene (m))
+(test 10 'hygiene (m2 y))
+(test 10 'hygiene (m2 x))
+(test 10 'hygiene (eval #'(m)))
+(test 10 'hygiene (eval (expand #'(m))))
+(test 10 'hygiene (eval (expand (expand #'(m)))))
+
+(define-syntax define-foo
+  (syntax-rules ()
+    ((_ expr) (define foo expr))))
+
+(test 'o 'hygiene (let ()
+		    (define-foo 'f)
+		    (define-foo 'o)
+		    (define o 'o)
+		    o))
+(test 'o 'hygiene (eval (expand (expand #'(let ()
+					    (define-foo 'f)
+					    (define-foo 'o)
+					    (define o 'o)
+					    o)))))
+
+
+(test 13 'let-macro (let-syntax ([mx (lambda (stx)
+				       (syntax-case stx ()
+					 [(_ x) (syntax (x 6 7))]))])
+		      (mx +)))
+(test -7 'let-macro (let-syntax ([mx2 (lambda (stx)
+					(syntax-case stx ()
+					  [(_ x y) (syntax (mx y))]))])
+		      (mx2 + -)))
+(test '(10) 'let-macro ((lambda () (let-syntax ([x (lambda (stx)
+						     (syntax-case stx ()
+						       [(_ v) (syntax (list v))]))])
+				     (x 10)))))
+
+(test '(10) 'let-macro (let () 
+			 (define-syntax x
+			   (lambda (stx)
+			     (syntax-case stx ()
+			       [(_ v) (syntax (list v))])))
+			 (x 10)))
+(test '(10) 'let-macro ((lambda () 
+			  (define-syntax x
+			    (lambda (stx)
+			      (syntax-case stx ()
+				[(_ v) (syntax (list v))])))
+			  (x 10))))
+
+(test 55 (let ()
+	   (define-syntax (g x) #'f)
+	   (define (f x) x)
+	   (define h g)
+	   h)
+      55)
+
+(test 66 (let ()
+	   (define (f x) x)
+	   (define-syntax (g x) #'f)
+	   (define h g)
+	   h)
+      66)
+
+(test 77 (let ()
+	   (define (f x) x)
+	   (define h g)
+	   (define-syntax (g x) #'f)
+	   h)
+      77)
+
+(test 55 (letrec-syntaxes+values ([(g) (lambda (x) #'f)])
+				 ([(f) (lambda (x) x)]
+				  [(h) f])
+	   h)
+      55)
+
+(test 7 'lrsv (letrec-syntaxes+values () () 7))
+
+(syntax-test #'(set! lambda 5))
+(syntax-test #'(lambda () (define-syntax x 10) (set! x 5)))
+(syntax-test #'(lambda () (define-syntax (x) 10) (set! x 5)))
+
+(syntax-test #'letrec-syntaxes+values)
+(syntax-test #'(letrec-syntaxes+values))
+(syntax-test #'(letrec-syntaxes+values . 1))
+(syntax-test #'(letrec-syntaxes+values ()))
+(syntax-test #'(letrec-syntaxes+values () . 1))
+(syntax-test #'(letrec-syntaxes+values () ()))
+(syntax-test #'(letrec-syntaxes+values () () . 1))
+(syntax-test #'(letrec-syntaxes+values x () 1))
+(syntax-test #'(letrec-syntaxes+values (x) () 1))
+(syntax-test #'(letrec-syntaxes+values ([x]) () 1))
+(syntax-test #'(letrec-syntaxes+values ([(x)]) () 1))
+(syntax-test #'(letrec-syntaxes+values ([(x) 1 2]) () 1))
+(syntax-test #'(letrec-syntaxes+values ([(x) 1] . y) () 1))
+(syntax-test #'(letrec-syntaxes+values () x 1))
+(syntax-test #'(letrec-syntaxes+values () (x) 1))
+(syntax-test #'(letrec-syntaxes+values () ([x]) 1))
+(syntax-test #'(letrec-syntaxes+values () ([(x)]) 1))
+(syntax-test #'(letrec-syntaxes+values () ([(x) 1 2]) 1))
+(syntax-test #'(letrec-syntaxes+values () ([(x) 1] . y) 1))
+
+(test 7 'set!-transformer
+      (let ([x 3])
+	(let-syntax ([f (make-set!-transformer
+			 (lambda (stx)
+			   (syntax-case stx ()
+			     [(_ __ val)
+			      #'(set! x val)])))])
+	  (set! f 7)
+	  x)))
+
+(test 7 'rename-transformer
+      (let ([x 3])
+	(let-syntax ([f (make-rename-transformer #'x)])
+	  (set! f 6)
+	  (set! x (add1 x))
+	  f)))
+
+(test 5 'rename-with-non-hygiene
+      (let-syntax ([f (lambda (stx) (datum->syntax-object stx 'foo))])
+	(let-syntax ([g (make-rename-transformer #'f)])
+	  (let ([foo 5])
+	    g))))
+
+(test 12 'rename-with-non-hygiene/app
+      (let-syntax ([f (lambda (stx) 
+			   (syntax-case stx ()
+			     [(_ arg)
+			      #`(#,(datum->syntax-object stx 'foo) arg)]))])
+	(let-syntax ([g (make-rename-transformer #'f)])
+	  (let ([foo (lambda (x) (sub1 x))])
+	    (g 13)))))
+
+(test 43 'rename-with-non-hygiene/set
+      (let-syntax ([f (make-set!-transformer
+			  (lambda (stx) 
+			    (syntax-case stx ()
+			      [(set! _ arg)
+			       #`(set! #,(datum->syntax-object stx 'foo) arg)])))])
+	(let-syntax ([g (make-rename-transformer #'f)])
+	  (let ([foo 45])
+	    (set! g 43)
+	    foo))))
+
+(define foo 88)
+(test 88 'rename-with-hygiene
+      (let-syntax ([g (make-rename-transformer #'foo)])
+	(let ([foo 5])
+	  g)))
+
+(define (foox w) (+ w 88))
+(test 99 'rename-with-hygiene/app
+      (let-syntax ([g (make-rename-transformer #'foox)])
+	(let ([foox 5])
+	  (g 11))))
+
+(define fooy 12)
+(test '(5 11) 'rename-with-hygiene/set!
+      (list (let-syntax ([g (make-rename-transformer #'fooy)])
+	      (let ([fooy 5])
+		(set! g 11)
+		fooy))
+	    fooy))
+
+(test 12 'rename-internal-define
+      (let-syntax ([fooz (syntax-rules ()
+			   [(_ id) (define id 12)])])
+	(let-syntax ([foozzz (make-rename-transformer #'fooz)])
+	  (foozzz foozz)
+	  foozz)))
+
+(test #t set!-transformer? (make-set!-transformer void))
+(test #t rename-transformer? (make-rename-transformer #'void))
+
+(err/rt-test (make-set!-transformer 5))
+(err/rt-test (make-set!-transformer #'x))
+(err/rt-test (make-rename-transformer 5))
+(err/rt-test (make-rename-transformer void))
+
+(arity-test make-set!-transformer 1 1)
+(arity-test set!-transformer? 1 1)
+(arity-test make-rename-transformer 1 1)
+(arity-test rename-transformer? 1 1)
+
+;; Test inheritance of context when . is used in a pattern
+
+(define-syntax keep-context
+  (syntax-rules () [(a . b) b]))
+(define-syntax (discard-context stx) 
+  (syntax-case stx () 
+    [(v . a) (datum->syntax-object #f (syntax-e #'a))]))
+
+(test 6 'plus (keep-context + 1 2 3))
+(test 6 'plus (keep-context . (+ 1 2 3)))
+
+(unless building-flat-tests?
+  (eval-syntax
+   #'(test 6 'plus (discard-context keep-context . (+ 1 2 3)))))
+
+(syntax-test #'(discard-context + 1 2 3))
+(syntax-test #'(discard-context . (+ 1 2 3)))
+(syntax-test #'(discard-context keep-context + 1 2 3))
+
+;; ----------------------------------------
+
+(define-syntax (et-struct-info stx)
+  (syntax-case stx ()
+    [(_ id) #`(quote #,(syntax-local-value #'id))]))
+
+(let ([v (et-struct-info exn)])
+  (test '(struct:exn make-exn exn? (exn-continuation-marks exn-message) (#f #f) #t) values v))
+
+(let ([v (et-struct-info exn:break)])
+  (test '(struct:exn:break make-exn:break exn:break? (exn:break-continuation exn-continuation-marks exn-message) (#f #f #f) exn) values v))
+
+(let ([v (et-struct-info arity-at-least)])
+  (test '(struct:arity-at-least make-arity-at-least arity-at-least? 
+				(arity-at-least-value) (set-arity-at-least-value!) #t) 
+	values v))
+
+(let ()
+  (define-struct a (x y))
+  (let ([v (et-struct-info a)])
+    (test '(struct:a make-a a? (a-y a-x) (set-a-y! set-a-x!) #t) values v)
+    (let ()
+      (define-struct (b a) (z))
+      (let ([v (et-struct-info b)])
+	(test '(struct:b make-b b? (b-z a-y a-x) (set-b-z! set-a-y! set-a-x!) a) values v)))
+    (let ()
+      (define-struct (b exn) (z))
+      (let ([v (et-struct-info b)])
+	(test '(struct:b make-b b? (b-z exn-continuation-marks exn-message) (set-b-z! #f #f) exn) values v)))))
+    
+  
+
+;; ----------------------------------------
+
+(report-errs)
diff --git a/collects/tests/mzscheme/macrolib.ss b/collects/tests/mzscheme/macrolib.ss
new file mode 100644
index 0000000000..63466461e8
--- /dev/null
+++ b/collects/tests/mzscheme/macrolib.ss
@@ -0,0 +1,141 @@
+
+(load-relative "loadtest.ss")
+
+(SECTION 'macrolib)
+
+(require (lib "etc.ss"))
+
+(let ([u (letrec ([x x]) x)])
+  (let ([l1
+	 (let+ ([rec a a]
+		[recs [b c] [c b]]
+		[rec d 1]
+		[val e 1]
+		[val x 1]
+		[val y 2]
+		[vals (x y) (y x)]
+		[rec (values f) (values 1)]
+		[vals [(values g h) (values 2 3)]]
+		[val i 3]
+		[_ (set! i 4)
+		   (set! i 5)])
+	       'x
+	       (list a b c d e x y f g h i))]
+	[l2 (list u u u 1 1 2 1 1 2 3 5)])
+    (test l1 'let-plus l2)))
+
+(require (lib "shared.ss"))
+
+(test "((car . cdr) #(one two three four five six) #&box (list1 list2 list3 list4) #<weak-box> 3 3)"
+      'shared
+      (let ([s (open-output-string)])
+	(display
+	 (shared ((a (cons 'car 'cdr)) 
+		  (b (vector 'one 'two 'three 'four 'five 'six))
+		  (c (box 'box))
+		  (d (list 'list1 'list2 'list3 'list4))
+		  (e (make-weak-box 'weak-box))
+		  (f (+ 1 2))
+		  (g 3))
+		 (list a b c d e f g))
+	 s)
+	(get-output-string s)))
+
+(test 'hi 'local (local () 'hi))
+(define x 7)
+(test 6 'local (local ((define x 6)) x))
+(test 7 'local x)
+(test '... vector-ref (struct->vector (local ((define x 6) (define-struct a (b))) (make-a x))) 1)
+(test #t 'local (local [(define o (lambda (x) (if (zero? x) #f (e (sub1 x)))))
+			(define e (lambda (x) (if (zero? x) #t (o (sub1 x)))))]
+		       (e 10)))
+(test 'second 'local (local ((define x 10) (define u 'second)) (cons x 1) u))
+(test-values '(4 6) (lambda () (local ((define y 6) (define x 4)) (values x y))))
+(test 10 'local (let ([x 10]) (local ((define y (lambda () x))) (define x 5) (y))))
+(test 5 'local (let ([x 10]) (local ((define y (lambda () x))) (define x 5) x)))
+(test 8 'local (let ([lambda 9]) (local [(define lambda 8)] lambda)))
+(test 9 'local (let ([lambda 10]) (local [(define lambda 9) (define lambda2 lambda)] lambda2)))
+(test 19 'local (local [(define lambda 19) (define lambda2 lambda)] lambda2))
+(test 1 'local (local ((define-values (a b c) (values 1 2 3))) a))
+(test 1 (lambda () (local ((define-values (a b c) (values 1 2 3))) a)))
+(test 8 'local (local [(define lambda 8)] lambda))
+(test 12 'local (local [(define (f y) (add1 y))] (f 11)))
+(test 120 'local (local [(define (f y) 'ignore-me (add1 y))] (f 119)))
+(test 17 'local (local [(define-values (apple b) (values 12 17))] b))
+(test 4 'local (local [(define-struct cons (car cdr))] (cons-car (make-cons 4 5))))
+(test 40 'local (local [(define-struct (cons exn) (car cdr))] (cons-car (make-cons "" (current-continuation-marks) 40 50))))
+(syntax-test #'(local))
+(syntax-test #'(local . 1))
+(syntax-test #'(local ()))
+(syntax-test #'(local () . 1))
+(syntax-test #'(local 1 1))
+(syntax-test #'(local (1) 1))
+(syntax-test #'(local (x) 1))
+(syntax-test #'(local ((+ 1 2)) 1))
+(syntax-test #'(local ((define x)) 1))
+(syntax-test #'(local ((define x 4) (+ 1 2)) 1))
+(syntax-test #'(local ((define x 4) (+ 1 2) (define y 10)) 1))
+(syntax-test #'(local ((define (x 8) 4)) 1))
+(syntax-test #'(local ((define (x . 8) 4)) 1))
+(syntax-test #'(local ((define x 8 4)) 1))
+(syntax-test #'(local ((define 1 8 4)) 1))
+(syntax-test #'(let ([define 10]) (local ((define x 4)) 10)))
+(syntax-test #'(let ([define-values 10]) (local ((define-values (x) 4)) 10)))
+(syntax-test #'(let ([define-struct 10]) (local ((define-struct x ())) 10)))
+
+(for-each syntax-test 
+	  (list #'(evcase)
+		#'(evcase 1 (a))
+		#'(evcase 1 (a b) a)
+		#'(evcase 1 (a . b) a)
+		#'(evcase 1 [else 5] [1 10])))
+(define => 17)
+(test (void) 'void-evcase (with-handlers ([(lambda (x) #t) (lambda (x) 17)]) (evcase 1)))
+(test #t andmap (lambda (x) (= x 17))
+      (list
+       (evcase 3 [3 17])
+       (evcase 3 [(+ 1 2) 17] [3 1])
+       (evcase 3 [3 4 5 17])
+       (evcase 3 [4 1] [3 4 5 17])
+       (evcase 3 [4 1 2 3 4] [3 4 5 17])
+       (evcase 3 [4 4] [2 10] [else 17])
+       (let ([else 10]) (evcase 3 [4 4] [2 10] [else 15] [3 17]))
+       (let ([else 3]) (evcase 3 [else 17] [2 14]))
+       (if (eq? (void) (evcase 1)) 17 'bad)
+       (evcase 3 [3 =>])
+       (evcase 3 [3 => 17])
+       (let ([=> 12]) (evcase 3 [3 => 17]))
+       (let ([=> 17]) (evcase 3 [3 =>]))))
+
+(define (opt-lam-test exp expected)
+   (let ([got (eval exp)])
+     (unless (equal? got expected)
+       (printf  "FAILED test: ~a~n   expected: ~s~n        got: ~s~n"
+                exp expected got))))
+
+(define (opt-lam-test/bad exp expected)
+   (let ([got (with-handlers ([exn:syntax?
+                               (lambda (exn) (exn-message exn))])
+                (cons 'got-result (eval exp)))])
+     (unless (regexp-match expected got)
+       (printf  "FAILED test: ~a~n   expected: ~s~n        got: ~s~n"
+                exp expected got))))
+
+(test 1 (opt-lambda (start) start) 1)
+(test 1 (opt-lambda ([start 1]) start))
+(test 1 (opt-lambda ([start 2]) start) 1)
+(test '(1) (opt-lambda args args) 1)
+(test '(1) (opt-lambda (x . args) args) 2 1)
+(test '(2 1) (opt-lambda ([x 1] . args) (cons x args)) 2 1)
+(test '(1) (opt-lambda ([x 1] . args) (cons x args)))
+(test '(1 2 3) (opt-lambda ([x 1] . args) (cons x args)) 1 2 3)
+
+(syntax-test #'(opt-lambda))
+(syntax-test #'(opt-lambda 1 x))
+(syntax-test #'(opt-lambda (x [x 1]) x))
+(syntax-test #'(opt-lambda ([x 1] y) x))
+(syntax-test #'(opt-lambda (1) x))
+(syntax-test #'(opt-lambda ([2 1]) x))
+
+(report-errs)
+
diff --git a/collects/tests/mzscheme/makeflat.ss b/collects/tests/mzscheme/makeflat.ss
new file mode 100644
index 0000000000..a174a00eab
--- /dev/null
+++ b/collects/tests/mzscheme/makeflat.ss
@@ -0,0 +1,93 @@
+
+(with-handlers ([exn:fail:contract:variable?
+		 (lambda (exn)
+		   (namespace-set-variable-value!
+		    'flat-load
+		    "mz.ss"))])
+  (namespace-variable-value 'flat-load))
+
+(with-handlers ([exn:fail:contract:variable?
+		 (lambda (exn)
+		   (namespace-set-variable-value!
+		    'lines-per-file
+		    +inf.0))])
+  (namespace-variable-value 'lines-per-file))
+
+(require (lib "pretty.ss"))
+
+(define line-count 0)
+(define file-count 0)
+
+(define flatp (open-output-file "flat.ss" 'replace))
+(define old-eval (current-eval))
+(define old-namespace (current-namespace))
+
+(pretty-print '(define error-test void) flatp)
+(pretty-print '(define building-flat-tests? #t) flatp)
+(pretty-print '(define section #f) flatp)
+
+(define (flat-pp v)
+  (parameterize ([print-hash-table #t])
+    (pretty-print (if (syntax? v) (syntax-object->datum v) v) flatp))
+  (set! line-count (add1 line-count))
+  (when (>= line-count lines-per-file)
+    (set! line-count 0)
+    (set! file-count (add1 file-count))
+    (close-output-port flatp)
+    (set! flatp
+	  (open-output-file
+	   (format "flat~a.ss" file-count)
+	   'replace))))
+
+(define error-test
+  (case-lambda
+   [(expr) (error-test expr #f)]
+   [(expr exn?)
+    (unless (or (eq? exn? exn:fail:syntax?)
+		(syntax-case expr (define define-values define-syntax define-syntaxes)
+		  [(define . _) #t]
+		  [(define-values . _) #t]
+		  [(define-syntax . _) #t]
+		  [(define-syntaxes . _) #t]
+		  [_else #f]))
+      (let ([dexpr (syntax-object->datum expr)])
+	(flat-pp 
+	 `(thunk-error-test (lambda () ,dexpr)
+			    (quote-syntax ,dexpr)
+			    ,@(if exn?
+				  (list (object-name exn?))
+				  null)))))]))
+
+(define building-flat-tests? #t)
+
+(dynamic-wind
+ (lambda () 
+   (current-eval
+    (lambda (e)
+      (unless (or (syntax-case* e (load load-relative error-test unless) (lambda (a b)
+									   (eq? (syntax-e a) (syntax-e b)))
+		    [(load . _) #t]
+		    [(load-relative . _) #t]
+		    [(error-test . _) #t]
+		    [(unless _ (load-relative s)) (string? (syntax-e (syntax s))) #t]
+		    [else #f])
+		  (compiled-expression? e)
+		  (and (syntax? e) (compiled-expression? (syntax-e e)))
+		  (not (eq? (current-namespace) old-namespace))
+		  ;; Skip test use of `eval' on unprintable value:
+		  (and (pair? e) (pair? (cdr e))
+		       (eq? void (cadr e))))
+	(flat-pp e))
+      (if (syntax-case* e (quote hygiene) (lambda (a b)
+					    (eq? (syntax-e a) (syntax-e b)))
+	    [(_ __ 'hygiene . ___) #t]
+	    [_else #f])
+	  ;; Don't save the evaluated:
+	  (parameterize ([current-eval old-eval])
+	    (old-eval e))
+	  ;; Normal:
+	  (old-eval e)))))
+ (lambda ()
+   (load-relative flat-load))
+ (lambda ()
+   (current-eval old-eval)))
diff --git a/collects/tests/mzscheme/match-test.ss b/collects/tests/mzscheme/match-test.ss
new file mode 100644
index 0000000000..7df756751b
--- /dev/null
+++ b/collects/tests/mzscheme/match-test.ss
@@ -0,0 +1,6 @@
+(load-relative (build-path "match" "plt-match-test.ss"))
+(load-relative (build-path "match" "match-test.ss"))
+;(load-relative (build-path "match" "match-performance.ss"))
+;(load-relative (build-path "match" "rand-vec-perf.ss"))
+;(load-relative (build-path "match" "rand-list-perf.ss"))
+;(load-relative (build-path "match" "short-rand-list.scm"))
diff --git a/collects/tests/mzscheme/match/drom-algol-structs.scm b/collects/tests/mzscheme/match/drom-algol-structs.scm
new file mode 100644
index 0000000000..c1e75a453e
--- /dev/null
+++ b/collects/tests/mzscheme/match/drom-algol-structs.scm
@@ -0,0 +1,59 @@
+;; structs for dromedary
+(define-struct <user-type> () (make-inspector))
+(define-struct (|NumT| <user-type>) (tlist) (make-inspector))
+(define-struct (|FunT| <user-type>) (tlist) (make-inspector))
+(define-struct (|Num| <user-type>) (tlist) (make-inspector))
+(define-struct (|Lam| <user-type>) (tlist) (make-inspector))
+(define-struct (|Val| <user-type>) (tlist) (make-inspector))
+(define-struct (|Minus| <user-type>) (tlist) (make-inspector))
+(define-struct (|Times| <user-type>) (tlist) (make-inspector))
+(define-struct (|Var| <user-type>) (tlist) (make-inspector))
+(define-struct (|App| <user-type>) (tlist) (make-inspector))
+(define-struct (|IfZero| <user-type>) (tlist) (make-inspector))
+(define-struct (|Fix| <user-type>) (tlist) (make-inspector))
+(define-struct (|exn:Stuck| exn) ())
+(define-struct <tuple> (list) (make-inspector))
+
+;;structs for algol
+(define-syntax (define-a60-structs stx)
+  (syntax-case stx ()
+    [(_ (struct-name (field ...)) ...)
+     (with-syntax ([(a60:struct ...) (map (lambda (id)
+                                            (datum->syntax-object
+                                             id
+                                             (string->symbol
+                                              (format "a60:~a" (syntax-e id)))))
+                                          (syntax->list (syntax (struct-name ...))))])
+       (syntax (begin (define-struct a60:struct (field ...)) ...)))]))
+(define-a60-structs
+  ;; Expressions
+  (if (test then else))
+  (unary (type argtype op arg))
+  (binary (type argtype op arg1 arg2))
+  (subscript (array index))
+  (variable (name indices))
+  (app (func args))
+  ;; plus numbers, strings, and booleans
+
+  ;; Statements
+  (block (decls statements))
+  (compound (statements))
+  (assign (variables rhs))
+  (goto (target))
+  (branch (test then else))
+  (call (proc args))
+  (for (variable values body))
+  (dummy ())
+  (label (name statement))
+
+  ;; for values
+  (for-number (value))
+  (for-step (start step end))
+  (for-while (value test))
+
+  ;; declarations
+  (type-decl (type vars))
+  (array-decl (type vars))
+  (switch-decl (var cases))
+  (proc-decl (result-type var arg-vars by-value-vars arg-specs body)))
+
diff --git a/collects/tests/mzscheme/match/match-compile-perf.scm b/collects/tests/mzscheme/match/match-compile-perf.scm
new file mode 100644
index 0000000000..9aa090d290
--- /dev/null
+++ b/collects/tests/mzscheme/match/match-compile-perf.scm
@@ -0,0 +1,265 @@
+; (match-performance-test
+;  (file
+;   (name "")
+;   write-new
+;   | add-results)
+; (tag
+;    identifier
+;  | date
+;  | time)
+; (display
+;    positive-change
+;  | negative-change
+;  | change
+;  | percent-change
+;  | rt-positive-change
+;  | rt-negative-change
+;  | rt-change
+;  | whole-list
+;  | last-two)
+; (patterns
+;  (pattern clauses ...)
+;  ...)
+; )
+
+; Data
+
+; ((pattern ((date count time) ...))
+;  ...)
+(define-syntax (match-performance-test stx)
+  (syntax-case stx (file patterns display tag)
+    ((_ (file (name file-name) params ...)
+        (tag tag-type)
+        (display dis-type)
+        (patterns pats ...))
+                                        ; decypher params
+     (let* ((prms (syntax-object->datum (syntax (params ...))))
+            (write-new (member
+                        'write-new prms))
+            (read-old-table
+             (lambda ()
+               (if write-new
+                   #`'()
+                   #`(with-input-from-file file-name
+                       (lambda ()
+                         (read))))))
+            (add-results (member
+                          'add-results prms))
+            (write-new-table
+             (lambda ()
+               (if (or write-new add-results)
+                   #`(call-with-output-file file-name
+                       (lambda (port)
+                         (pretty-print old-table port))
+                       'replace)
+                   #`())))
+            (disp-gen-wrap
+             (lambda (pattern stx)
+               (if (not write-new)
+                   #`(begin
+                       (update-table (quote #,pattern) new-res)
+                       (let* ((whole-list (get-entry (quote #,pattern)))
+                              (last-two (get-last-two (quote #,pattern)))
+                              (prev-count (get-count (car last-two)))
+                              (cur-count (get-count (cadr last-two)))
+                              (rt-prev-count (get-rt (car last-two)))
+                              (rt-cur-count (get-rt (cadr last-two)))
+                              )
+                         #,stx))
+                   #`(begin
+                       (update-table (quote #,pattern) new-res)
+                       (let* ((whole-list (get-entry (quote #,pattern))))
+                         #,stx)))))
+            (disp-gen
+             (if write-new
+                 (lambda (pattern)
+                  (disp-gen-wrap
+                   pattern
+                   #'whole-list))
+                 (syntax-case
+                     (syntax dis-type)
+                     (positive-change
+                      negative-change
+                      change
+                      rt-positive-change
+                      rt-negative-change
+                      rt-change
+                      whole-list
+                      last-two
+                      percent-change
+                      rt-percent-change
+                      )
+                   (positive-change
+                    (lambda (pattern)
+                      (disp-gen-wrap
+                       pattern
+                       #`(if (< prev-count cur-count)
+                             `(+ ,(- cur-count prev-count))
+                             #t))))
+                   (negative-change
+                    (lambda (pattern)
+                      (disp-gen-wrap
+                       pattern
+                       #`(if (> prev-count cur-count)
+                             `(- ,(- prev-count cur-count))
+                             #t))))
+                   (change
+                    (lambda (pattern)
+                      (disp-gen-wrap
+                       pattern
+                       #`(cond ((= prev-count cur-count)
+                                #t)
+                               ((> prev-count cur-count)
+                                `(- ,(- prev-count cur-count)))
+                               (else `(+ ,(- cur-count prev-count)))))))
+                   (percent-change
+                    (lambda (pattern)
+                      (disp-gen-wrap
+                       pattern
+                       #`(cond ((= prev-count cur-count)
+                                #t)
+                               ((> prev-count cur-count)
+                                `(-% ,(percent-of cur-count prev-count)))
+                               (else `(+% ,(percent-of cur-count prev-count)))))))
+                   (rt-percent-change
+                    (lambda (pattern)
+                      (disp-gen-wrap
+                       pattern
+                       #`(cond ((= rt-prev-count rt-cur-count)
+                                #t)
+                               ((> rt-prev-count rt-cur-count)
+                            `(-% ,(percent-of rt-cur-count rt-prev-count)))
+                               (else `(+% ,(percent-of rt-cur-count rt-prev-count)))))))
+                   (rt-positive-change
+                    (lambda (pattern)
+                      (disp-gen-wrap
+                       pattern
+                       #`(if (< rt-prev-count rt-cur-count)
+                             `(+ ,(- rt-cur-count rt-prev-count))
+                             #t))))
+                   (rt-negative-change
+                    (lambda (pattern)
+                      (disp-gen-wrap
+                       pattern
+                       #`(if (> rt-prev-count rt-cur-count)
+                             `(- ,(- rt-prev-count rt-cur-count))
+                             #t))))
+                   (rt-change
+                    (lambda (pattern)
+                      (disp-gen-wrap
+                       pattern
+                       #`(cond ((= rt-prev-count rt-cur-count)
+                                #t)
+                               ((> rt-prev-count rt-cur-count)
+                                `(- ,(- rt-prev-count rt-cur-count)))
+                           (else `(+ ,(- rt-cur-count rt-prev-count)))))))
+                   (whole-list
+                    (lambda (pattern)
+                      (disp-gen-wrap
+                       pattern
+                       #'whole-list)))
+                   (last-two
+                    (lambda (pattern)
+                      (disp-gen-wrap
+                       pattern
+                       #'last-two))))))
+            (test-gen
+             (lambda (patt)
+               (syntax-case patt (pattern)
+                 ((pattern clauses ...)
+                  #`(test #t
+                        #,(quasisyntax/loc patt  (lambda ()
+                            (let ((new-res
+                                   (match (list 
+                                           (match-test
+                                            #,@(syntax ((clauses #t) ...)))
+                                          ;  (match-test
+;                                             #,@(syntax ((clauses #t) ...)))
+;                                            (match-test
+;                                             #,@(syntax ((clauses #t) ...)))
+;                                            (match-test
+;                                             #,@(syntax ((clauses #t) ...)))
+;                                            (match-test
+;                                             #,@(syntax ((clauses #t) ...)))
+                                           ;(match-test
+                                           ; #,@(syntax ((clauses #t) ...)))
+                                           )
+                                          ((list (list b c) ..1)
+                                           (list (car b) (round (/ (apply + c) (length c))))))))
+                              #,(disp-gen
+                                 patt))))))
+                 (_ (error 'problem-here)))))
+            (handle-patterns
+             (lambda (pattern-list)
+               #`(begin
+                   #,@(map test-gen (syntax->list pattern-list))))))
+       #`(let* ((old-table #,(read-old-table)))
+           (letrec ((update-table
+                     (lambda (pattern new-res)
+                       (set! old-table
+                             (if (assoc pattern old-table)
+                                 (map
+                                  (lambda (x)
+                                    (if (equal? (car x) pattern)
+                                        (cons (car x)
+                                              (list
+                                               (append (cadr x)
+                                                       (list (cons
+                                                              (let ((dat-struct
+                                                                     (seconds->date
+                                                                      (current-seconds))))
+                                                                #,(syntax-case (syntax tag-type) (date time) 
+                                                                    (date
+                                                                     #'(list (date-month dat-struct)
+                                                                             (date-day dat-struct)
+                                                                             (date-year dat-struct)))
+                                                                    (time
+                                                                     #'(list (date-hour dat-struct)
+                                                                             (date-minute dat-struct)))
+                                                                    (id
+                                                                     (identifier? (syntax id))
+                                                                     (syntax (quote id)))))
+                                                              new-res)))))
+                                        x))
+                                  old-table)
+                                 (cons
+                                  (cons pattern
+                                        (list
+                                         (list
+                                          (cons
+                                           (let ((dat-struct
+                                                  (seconds->date
+                                                   (current-seconds))))
+                                             #,(syntax-case (syntax tag-type) (date time) 
+                                                 (date
+                                                  #'(list (date-month dat-struct)
+                                                          (date-day dat-struct)
+                                                          (date-year dat-struct)))
+                                                 (time
+                                                  #'(list (date-hour dat-struct)
+                                                          (date-minute dat-struct)))
+                                                 (id
+                                                  (identifier? (syntax id))
+                                                  (syntax (quote id)))))
+                                           new-res))))
+                                  old-table)))))
+                    (get-entry
+                     (lambda (pattern)
+                       (let ((entry (assoc pattern old-table)))
+                         entry)))
+                    (get-last-two
+                     (lambda (pattern)
+                       (letrec ((RC (lambda (l)
+                                      (if (= 2 (length l))
+                                          l
+                                          (RC (cdr l))))))
+                         (RC (cadr (get-entry pattern))))))
+                    (get-rt
+                     (lambda (x) (caddr x)))
+                    (get-count
+                     (lambda (x) (cadr x)))
+                    (percent-of 
+                      (lambda (x y) (* 100 (exact->inexact (/ (abs (- x y)) y)))))
+                    )
+             #,(handle-patterns (syntax (pats ...)))
+             #,(write-new-table)))))))
diff --git a/collects/tests/mzscheme/match/match-perf-hist.db b/collects/tests/mzscheme/match/match-perf-hist.db
new file mode 100644
index 0000000000..db47c45dae
--- /dev/null
+++ b/collects/tests/mzscheme/match/match-perf-hist.db
@@ -0,0 +1,5964 @@
+(((pattern
+    (list
+     (not (not #t))
+     tlp2450
+     (or (box
+          (list
+           (struct
+             test-struct
+             ((vector tlp2451 ...)
+              #\d
+              (or tlp2452 tlp2452)
+              (vector tlp2453 ___)))
+           (list tlp2455 ..3)
+           tlp2456))
+         (box
+          (list
+           (struct
+             test-struct
+             ((vector tlp2451 ...)
+              #\d
+              (or tlp2452 tlp2452)
+              (vector tlp2453 ___)))
+           (list tlp2455 ..3)
+           tlp2456)))
+     (or (list tlp2457 ...) (list tlp2457 ...)))
+    (list
+     (list-rest
+       (box (list (or _ _) (list) (list tlp2458 ..3)))
+       tlp2459
+       (vector tlp2460 ___)
+       #t)
+     (and (? test-struct? tlp2470)
+          (app test-struct-a (not (not #\b)))
+          (app
+           test-struct-b
+           (struct
+             test-struct
+             ((list)
+              (not (not #\b))
+              'symbols
+              (or (vector tlp2461 tlp2462 tlp2463 tlp2464)
+                  (vector tlp2461 tlp2462 tlp2463 tlp2464)))))
+          (app test-struct-c #\d)
+          (app
+           test-struct-d
+           (box (list (and tlp2466 tlp2467) (vector tlp2468 ___) _))))
+     (vector tlp2471 ___)
+     (not (not 9)))
+    (list
+     (vector
+       (and (? number? tlp2472) (? even? tlp2473))
+       (list)
+       (struct
+         test-struct
+         ((vector tlp2474 tlp2475 tlp2476 tlp2477)
+          (list tlp2478 ___)
+          (list tlp2479 ..3)
+          '(+ 1 2)))
+       (or _ _))
+     (list tlp2481 ..3)
+     tlp2482
+     (and (? number? tlp2483) (? even? tlp2484))))
+  ((no-hueristics 232 175)
+   (no-hueristics-size 220 270)
+   (rel-1-5 129 168)
+   (rel-1-5-size 123 213)
+   (inverse-in 129 135)
+   (inverse-in-size 123 326)
+   (tag-negate 129 133)
+   (tag-negate-size 123 150)
+   (new-coupling 80 168)
+   (new-coupling-size 80 114)
+   (member-up-count 80 111)
+   (member-up-count-size 80 115)
+   (memoize-up-count 80 180)
+   (memoize-up-count-size 80 135)))
+ ((pattern
+    (list
+     tlp2416
+     (not (not #t))
+     (or (list-rest
+           (and (list tlp2417 ...) (list tlp2418 ...))
+           (vector
+             (list-rest tlp2419 tlp2420 tlp2421 tlp2422)
+             #\c
+             tlp2423
+             (list-rest tlp2424 tlp2425 tlp2426 tlp2427))
+           9
+           'are)
+         (list-rest
+           (and (list tlp2417 ...) (list tlp2418 ...))
+           (vector
+             (list-rest tlp2419 tlp2420 tlp2421 tlp2422)
+             #\c
+             tlp2423
+             (list-rest tlp2424 tlp2425 tlp2426 tlp2427))
+           9
+           'are))
+     (list
+      tlp2428
+      (and (? number? tlp2429) (? even? tlp2430))
+      (not (not '(+ 4 5)))
+      (or (struct
+            test-struct
+            ((box (list tlp2431 tlp2432 tlp2433))
+             #f
+             (vector tlp2434 tlp2435 tlp2436 tlp2437)
+             _))
+          (struct
+            test-struct
+            ((box (list tlp2431 tlp2432 tlp2433))
+             #f
+             (vector tlp2434 tlp2435 tlp2436 tlp2437)
+             _)))))
+    (list
+     (vector
+       (list)
+       (not (not #\d))
+       (box (list (not (not 9)) (list) 'symbols))
+       (list))
+     _
+     tlp2439
+     (list-rest tlp2440 _ tlp2441 #t))
+    (list
+     (or (not (not #\b)) (not (not #\b)))
+     (list
+      tlp2442
+      (list)
+      (list)
+      (and (vector tlp2443 ...) (vector tlp2444 ...)))
+     (list tlp2445 ___)
+     (or (and (? number? tlp2446) (? even? tlp2447))
+         (and (? number? tlp2446) (? even? tlp2447)))))
+  ((no-hueristics 1847 1285)
+   (no-hueristics-size 1617 2409)
+   (rel-1-5 1381 1858)
+   (rel-1-5-size 1283 1391)
+   (inverse-in 1381 1224)
+   (inverse-in-size 1283 1380)
+   (tag-negate 1381 1144)
+   (tag-negate-size 1283 1166)
+   (new-coupling 1025 1272)
+   (new-coupling-size 964 1174)
+   (member-up-count 1025 875)
+   (member-up-count-size 964 1014)
+   (memoize-up-count 1025 803)
+   (memoize-up-count-size 964 1159)))
+ ((pattern
+    (list
+     (not (not #\b))
+     _
+     (list
+      (list tlp2317 ...)
+      (list tlp2318 ..3)
+      (vector
+        tlp2319
+        _
+        (box (list tlp2320 tlp2321 tlp2322))
+        (struct test-struct (tlp2323 tlp2324 tlp2325 tlp2326)))
+      '(+ 4 5))
+     (list tlp2328 __3))
+    (list
+     tlp2329
+     (list tlp2330 ...)
+     (list
+      (struct
+        test-struct
+        (_ (struct test-struct (tlp2331 tlp2332 tlp2333 tlp2334)) _ (list)))
+      tlp2337
+      (and (and (box (list tlp2338 tlp2339 tlp2340))
+                (box (list tlp2341 tlp2342 tlp2343)))
+           (and (box (list tlp2344 tlp2345 tlp2346))
+                (box (list tlp2347 tlp2348 tlp2349))))
+      (and #\d #\d))
+     (list-rest
+       (list-rest
+         (struct test-struct (tlp2350 tlp2351 tlp2352 tlp2353))
+         (or (struct test-struct (tlp2355 tlp2356 tlp2357 tlp2358))
+             (struct test-struct (tlp2355 tlp2356 tlp2357 tlp2358)))
+         (list-rest tlp2360 tlp2361 tlp2362 #\c)
+         #\a)
+       (list tlp2363 ___)
+       (list)
+       3))
+    (list
+     (and (? test-struct? tlp2396)
+          (app
+           test-struct-a
+           (and (? test-struct? tlp2371)
+                (app test-struct-a tlp2364)
+                (app test-struct-b tlp2365)
+                (app test-struct-c (list tlp2366 tlp2367 tlp2368 tlp2369))
+                (app test-struct-d (list))))
+          (app
+           test-struct-b
+           (struct
+             test-struct
+             ((and (? test-struct? tlp2377)
+                   (app test-struct-a tlp2372)
+                   (app test-struct-b tlp2373)
+                   (app test-struct-c tlp2374)
+                   (app test-struct-d tlp2375))
+              (list tlp2378 ..3)
+              (and (? number? tlp2379) (? even? tlp2380))
+              (vector tlp2381 ...))))
+          (app
+           test-struct-c
+           (box
+            (list
+             (list tlp2383 ..3)
+             (and (? test-struct? tlp2389)
+                  (app test-struct-a tlp2384)
+                  (app test-struct-b tlp2385)
+                  (app test-struct-c tlp2386)
+                  (app test-struct-d tlp2387))
+             tlp2390)))
+          (app
+           test-struct-d
+           (and (and (? number? tlp2391) (? even? tlp2392))
+                (and (? number? tlp2393) (? even? tlp2394)))))
+     (list
+      '(+ 1 2)
+      (vector tlp2397 ___)
+      (struct
+        test-struct
+        ((vector tlp2398 tlp2399 tlp2400 tlp2401)
+         (and (? number? tlp2402) (? even? tlp2403))
+         tlp2404
+         (list-rest tlp2405 tlp2406 tlp2407 'symbols)))
+      _)
+     (struct
+       test-struct
+       ((list tlp2409 ..3)
+        (not (not #\a))
+        tlp2410
+        (and (? number? tlp2411) (? even? tlp2412))))
+     (list)))
+  ((no-hueristics 9292 7871)
+   (no-hueristics-size 9149 8308)
+   (rel-1-5 9847 8226)
+   (rel-1-5-size 9677 8118)
+   (inverse-in 8529 8635)
+   (inverse-in-size 8420 7345)
+   (tag-negate 8529 7953)
+   (tag-negate-size 8420 7950)
+   (new-coupling 6952 7523)
+   (new-coupling-size 6852 5642)
+   (member-up-count 6952 6110)
+   (member-up-count-size 6852 6604)
+   (memoize-up-count 6952 6192)
+   (memoize-up-count-size 6852 6649)))
+ ((pattern
+    (list
+     tlp2273
+     (box
+      (list
+       (struct
+         test-struct
+         ((vector tlp2274 ___)
+          (vector tlp2275 ___)
+          (vector tlp2276 ...)
+          (and (list tlp2277 ___) (list tlp2278 ___))))
+       (and (? number? tlp2280) (? even? tlp2281))
+       (list (and tlp2282 tlp2283) tlp2284 _ (list tlp2285 ___))))
+     _
+     (and (? number? tlp2286) (? even? tlp2287)))
+    (list
+     tlp2288
+     (and (list-rest
+            (list-rest
+              '(+ 4 5)
+              (list tlp2289 tlp2290 tlp2291 tlp2292)
+              (not (not #\a))
+              #\b)
+            (list-rest
+              (list)
+              #\a
+              (and (? number? tlp2293) (? even? tlp2294))
+              'these)
+            (list tlp2295 ___)
+            6)
+          (list-rest
+            (list-rest
+              '(+ 4 5)
+              (list tlp2296 tlp2297 tlp2298 tlp2299)
+              (not (not #\a))
+              #\b)
+            (list-rest
+              (list)
+              #\a
+              (and (? number? tlp2300) (? even? tlp2301))
+              'these)
+            (list tlp2302 ___)
+            6))
+     (box
+      (list
+       (list)
+       _
+       (and (? test-struct? tlp2306)
+            (app test-struct-a tlp2303)
+            (app test-struct-b (list))
+            (app test-struct-c #t)
+            (app test-struct-d (or (list tlp2304 ..3) (list tlp2304 ..3))))))
+     (struct
+       test-struct
+       (tlp2307
+         (list)
+         (not (not 'symbols))
+         (or (and (? number? tlp2308) (? even? tlp2309))
+             (and (? number? tlp2308) (? even? tlp2309))))))
+    (list tlp2311 (or tlp2312 tlp2312) (vector tlp2313 ___) tlp2314))
+  ((no-hueristics 290 371)
+   (no-hueristics-size 288 337)
+   (rel-1-5 163 334)
+   (rel-1-5-size 161 265)
+   (inverse-in 163 406)
+   (inverse-in-size 161 382)
+   (tag-negate 163 376)
+   (tag-negate-size 161 440)
+   (new-coupling 161 252)
+   (new-coupling-size 161 320)
+   (member-up-count 161 349)
+   (member-up-count-size 161 316)
+   (memoize-up-count 161 361)
+   (memoize-up-count-size 161 380)))
+ ((pattern
+    (list (not (not #\b)) '(+ 4 (+ 1 1)) (vector tlp2260 ...) _)
+    (list
+     (list)
+     (and (? test-struct? tlp2264)
+          (app test-struct-a (not (not #\a)))
+          (app test-struct-b (vector tlp2261 ...))
+          (app test-struct-c (or (list) (list)))
+          (app
+           test-struct-d
+           (list-rest '(+ 1 2) (list tlp2262 ...) (not (not #\b)) 'these)))
+     (or (list tlp2265 __3) (list tlp2265 __3))
+     (list))
+    (list
+     (list tlp2266 ___)
+     (struct test-struct ((list tlp2267 __3) (not (not 'are)) tlp2268 (list)))
+     (list tlp2270 __3)
+     (and #f #f)))
+  ((no-hueristics 329 143)
+   (no-hueristics-size 245 141)
+   (rel-1-5 203 113)
+   (rel-1-5-size 165 179)
+   (inverse-in 219 123)
+   (inverse-in-size 177 134)
+   (tag-negate 129 70)
+   (tag-negate-size 114 70)
+   (new-coupling 97 185)
+   (new-coupling-size 91 61)
+   (member-up-count 79 60)
+   (member-up-count-size 75 53)
+   (memoize-up-count 79 52)
+   (memoize-up-count-size 75 52)))
+ ((pattern
+    (list
+     (and (? number? tlp2096) (? even? tlp2097))
+     (and (? test-struct? tlp2105)
+          (app test-struct-a #\b)
+          (app
+           test-struct-b
+           (or (and (list tlp2098 ___) (list tlp2099 ___))
+               (and (list tlp2098 ___) (list tlp2099 ___))))
+          (app test-struct-c (and (? number? tlp2100) (? even? tlp2101)))
+          (app test-struct-d (and (? number? tlp2102) (? even? tlp2103))))
+     #t
+     #\a)
+    (list
+     (and (? test-struct? tlp2128)
+          (app test-struct-a _)
+          (app test-struct-b (list))
+          (app
+           test-struct-c
+           (struct
+             test-struct
+             ((struct test-struct (tlp2106 tlp2107 tlp2108 tlp2109))
+              (vector tlp2111 ...)
+              tlp2112
+              (vector tlp2113 tlp2114 tlp2115 tlp2116))))
+          (app
+           test-struct-d
+           (vector
+             (box (list tlp2118 tlp2119 tlp2120))
+             (struct test-struct (tlp2121 tlp2122 tlp2123 tlp2124))
+             tlp2126
+             (list))))
+     (and (? test-struct? tlp2139)
+          (app test-struct-a _)
+          (app
+           test-struct-b
+           (and (? test-struct? tlp2134)
+                (app test-struct-a _)
+                (app test-struct-b (vector tlp2129 ___))
+                (app
+                 test-struct-c
+                 (list-rest tlp2130 tlp2131 tlp2132 'symbols))
+                (app test-struct-d 'these)))
+          (app test-struct-c (and (? number? tlp2135) (? even? tlp2136)))
+          (app test-struct-d tlp2137))
+     (vector tlp2140 ...)
+     tlp2141)
+    (list
+     (struct
+       test-struct
+       ((list-rest
+          (struct test-struct (tlp2142 tlp2143 tlp2144 tlp2145))
+          (not (not #f))
+          tlp2147
+          #t)
+        _
+        tlp2148
+        (list-rest
+          (and (? test-struct? tlp2154)
+               (app test-struct-a tlp2149)
+               (app test-struct-b tlp2150)
+               (app test-struct-c tlp2151)
+               (app test-struct-d tlp2152))
+          (and tlp2155 tlp2156)
+          (box (list tlp2157 tlp2158 tlp2159))
+          #\b)))
+     (list tlp2161 __3)
+     'these
+     (and (? number? tlp2162) (? even? tlp2163))))
+  ((no-hueristics 4641 2440)
+   (no-hueristics-size 3915 2338)
+   (rel-1-5 3336 1990)
+   (rel-1-5-size 2890 1837)
+   (inverse-in 3336 2149)
+   (inverse-in-size 2890 1979)
+   (tag-negate 426 322)
+   (tag-negate-size 374 477)
+   (new-coupling 355 243)
+   (new-coupling-size 311 238)
+   (member-up-count 355 267)
+   (member-up-count-size 311 329)
+   (memoize-up-count 355 345)
+   (memoize-up-count-size 311 362)))
+ ((pattern
+    (list (and (? number? tlp2067) (? even? tlp2068)) _ (or 'these 'these) 8)
+    (list
+     (list tlp2069 ..3)
+     (list tlp2070 ..3)
+     (box
+      (list
+       (not (not 'are))
+       (and (? number? tlp2071) (? even? tlp2072))
+       tlp2073))
+     (list-rest
+       (vector
+         (list)
+         tlp2074
+         tlp2075
+         (list-rest tlp2076 tlp2077 tlp2078 'symbols))
+       tlp2079
+       (and (? test-struct? tlp2086)
+            (app test-struct-a (vector tlp2080 tlp2081 tlp2082 tlp2083))
+            (app test-struct-b _)
+            (app test-struct-c (not (not #\c)))
+            (app test-struct-d (list tlp2084 __3)))
+       'are))
+    (list
+     #\b
+     _
+     (struct
+       test-struct
+       ((list tlp2087 ...)
+        (and (? number? tlp2088) (? even? tlp2089))
+        (or tlp2090 tlp2090)
+        (vector (not (not '(+ 1 2))) tlp2091 (list) tlp2092)))
+     tlp2094))
+  ((no-hueristics 358 278)
+   (no-hueristics-size 350 226)
+   (rel-1-5 318 210)
+   (rel-1-5-size 310 207)
+   (inverse-in 318 210)
+   (inverse-in-size 310 212)
+   (tag-negate 318 212)
+   (tag-negate-size 310 259)
+   (new-coupling 300 315)
+   (new-coupling-size 300 270)
+   (member-up-count 300 243)
+   (member-up-count-size 300 277)
+   (memoize-up-count 300 199)
+   (memoize-up-count-size 300 328)))
+ ((pattern
+    (list (not (not #t)) tlp2016 (list) tlp2017)
+    (list
+     (list-rest
+       (list tlp2018 (not (not '(+ 1 2))) 'are tlp2019)
+       (list
+        (list tlp2020 tlp2021 tlp2022 tlp2023)
+        (and (list-rest tlp2024 tlp2025 tlp2026 tlp2027)
+             (list-rest tlp2028 tlp2029 tlp2030 tlp2031))
+        (list tlp2032 __3)
+        _)
+       (and (? number? tlp2033) (? even? tlp2034))
+       #\b)
+     _
+     (list tlp2035 __3)
+     #f)
+    (list
+     (list
+      (list tlp2036 ...)
+      (and (and (? test-struct? tlp2042)
+                (app test-struct-a tlp2037)
+                (app test-struct-b 7)
+                (app test-struct-c (box (list tlp2038 tlp2039 tlp2040)))
+                (app test-struct-d (not (not #t))))
+           (and (? test-struct? tlp2043)
+                (app test-struct-a tlp2044)
+                (app test-struct-b 7)
+                (app test-struct-c (box (list tlp2045 tlp2046 tlp2047)))
+                (app test-struct-d (not (not #t)))))
+      (and (vector
+             (and tlp2048 tlp2049)
+             (list tlp2050 tlp2051 tlp2052 tlp2053)
+             (and tlp2054 tlp2055)
+             tlp2056)
+           (vector
+             (and tlp2057 tlp2058)
+             (list tlp2059 tlp2060 tlp2061 tlp2062)
+             (and tlp2063 tlp2064)
+             tlp2065))
+      #\c)
+     'symbols
+     (list)
+     (not (not '(+ 4 5)))))
+  ((no-hueristics 2865 1778)
+   (no-hueristics-size 2398 1659)
+   (rel-1-5 1155 839)
+   (rel-1-5-size 1000 768)
+   (inverse-in 1214 1071)
+   (inverse-in-size 1054 854)
+   (tag-negate 401 289)
+   (tag-negate-size 343 449)
+   (new-coupling 339 394)
+   (new-coupling-size 339 270)
+   (member-up-count 315 325)
+   (member-up-count-size 315 295)
+   (memoize-up-count 315 368)
+   (memoize-up-count-size 315 412)))
+ ((pattern
+    (list
+     (list-rest
+       tlp1952
+       (or (struct test-struct (2 tlp1953 tlp1954 (list)))
+           (struct test-struct (2 tlp1953 tlp1954 (list))))
+       (struct
+         test-struct
+         ((vector tlp1956 tlp1957 tlp1958 tlp1959)
+          (and (vector tlp1960 ___) (vector tlp1961 ___))
+          (or #t #t)
+          (list)))
+       'these)
+     (not (not '(+ 4 (+ 1 1))))
+     (vector tlp1963 ___)
+     (list))
+    (list
+     (list tlp1964 ..3)
+     (or (and (? number? tlp1965) (? even? tlp1966))
+         (and (? number? tlp1965) (? even? tlp1966)))
+     (and (? test-struct? tlp1978)
+          (app test-struct-a tlp1967)
+          (app test-struct-b 'symbols)
+          (app test-struct-c tlp1968)
+          (app
+           test-struct-d
+           (list-rest
+             (vector tlp1969 ...)
+             tlp1970
+             (and (? test-struct? tlp1976)
+                  (app test-struct-a tlp1971)
+                  (app test-struct-b tlp1972)
+                  (app test-struct-c tlp1973)
+                  (app test-struct-d tlp1974))
+             5)))
+     (and (list) (list)))
+    (list
+     (list)
+     tlp1979
+     (struct
+       test-struct
+       ((and (? number? tlp1980) (? even? tlp1981))
+        (list)
+        (and (and (? test-struct? tlp1997)
+                  (app
+                   test-struct-a
+                   (list-rest tlp1982 tlp1983 tlp1984 tlp1985))
+                  (app
+                   test-struct-b
+                   (list-rest tlp1986 tlp1987 tlp1988 tlp1989))
+                  (app test-struct-c tlp1990)
+                  (app
+                   test-struct-d
+                   (struct test-struct (tlp1991 tlp1992 tlp1993 tlp1994))))
+             (and (? test-struct? tlp1998)
+                  (app
+                   test-struct-a
+                   (list-rest tlp1999 tlp2000 tlp2001 tlp2002))
+                  (app
+                   test-struct-b
+                   (list-rest tlp2003 tlp2004 tlp2005 tlp2006))
+                  (app test-struct-c tlp2007)
+                  (app
+                   test-struct-d
+                   (struct test-struct (tlp2008 tlp2009 tlp2010 tlp2011)))))
+        (list tlp2012 ..3)))
+     tlp2014))
+  ((no-hueristics 399 386)
+   (no-hueristics-size 369 339)
+   (rel-1-5 410 382)
+   (rel-1-5-size 370 407)
+   (inverse-in 389 369)
+   (inverse-in-size 361 398)
+   (tag-negate 335 341)
+   (tag-negate-size 327 530)
+   (new-coupling 277 379)
+   (new-coupling-size 277 325)
+   (member-up-count 269 263)
+   (member-up-count-size 269 370)
+   (memoize-up-count 269 355)
+   (memoize-up-count-size 269 402)))
+ ((pattern
+    (list (list tlp1907 ___) (list) 'symbols 'these)
+    (list
+     (list #t (and (list) (list)) (and tlp1908 tlp1909) (list tlp1910 ___))
+     (vector tlp1911 ___)
+     (list-rest (not (not #\b)) '(+ 1 2) tlp1912 #\a)
+     tlp1913)
+    (list
+     (vector
+       (and (? test-struct? tlp1920)
+            (app test-struct-a tlp1914)
+            (app test-struct-b tlp1915)
+            (app test-struct-c (box (list tlp1916 tlp1917 tlp1918)))
+            (app test-struct-d #\b))
+       (list-rest _ (list tlp1921 tlp1922 tlp1923 tlp1924) #f #\d)
+       (and (? test-struct? tlp1936)
+            (app test-struct-a (box (list tlp1925 tlp1926 tlp1927)))
+            (app test-struct-b (list tlp1928 tlp1929 tlp1930 tlp1931))
+            (app test-struct-c (box (list tlp1932 tlp1933 tlp1934)))
+            (app test-struct-d _))
+       (and (? test-struct? tlp1949)
+            (app test-struct-a '(+ 4 5))
+            (app
+             test-struct-b
+             (or (struct test-struct (tlp1937 tlp1938 tlp1939 tlp1940))
+                 (struct test-struct (tlp1937 tlp1938 tlp1939 tlp1940))))
+            (app test-struct-c (list tlp1942 __3))
+            (app
+             test-struct-d
+             (struct test-struct (tlp1943 tlp1944 tlp1945 tlp1946)))))
+     #t
+     _
+     tlp1950))
+  ((no-hueristics 422 291)
+   (no-hueristics-size 414 297)
+   (rel-1-5 379 329)
+   (rel-1-5-size 370 293)
+   (inverse-in 379 367)
+   (inverse-in-size 370 231)
+   (tag-negate 227 161)
+   (tag-negate-size 220 238)
+   (new-coupling 68 112)
+   (new-coupling-size 68 106)
+   (member-up-count 68 172)
+   (member-up-count-size 68 171)
+   (memoize-up-count 68 103)
+   (memoize-up-count-size 68 109)))
+ ((pattern
+    (list (vector tlp1748 ...) _ (or _ _) (list tlp1749 __3))
+    (list
+     (list tlp1750 ..3)
+     (and tlp1751 tlp1752)
+     tlp1753
+     (list-rest
+       tlp1754
+       (list (list) tlp1755 (list) (box (list tlp1756 tlp1757 tlp1758)))
+       (list-rest
+         (list tlp1759 ___)
+         (and (? number? tlp1760) (? even? tlp1761))
+         (vector tlp1762 tlp1763 tlp1764 tlp1765)
+         #t)
+       #t))
+    (list
+     (and (? test-struct? tlp1777)
+          (app test-struct-a tlp1766)
+          (app test-struct-b (vector tlp1767 ...))
+          (app test-struct-c (vector tlp1768 ___))
+          (app
+           test-struct-d
+           (struct
+             test-struct
+             ((list tlp1769 tlp1770 tlp1771 tlp1772)
+              (list tlp1773 ___)
+              tlp1774
+              #t))))
+     tlp1778
+     (and (? test-struct? tlp1798)
+          (app
+           test-struct-a
+           (list
+            (list-rest tlp1779 tlp1780 tlp1781 #\a)
+            (and (? test-struct? tlp1787)
+                 (app test-struct-a tlp1782)
+                 (app test-struct-b tlp1783)
+                 (app test-struct-c tlp1784)
+                 (app test-struct-d tlp1785))
+            (list tlp1788 ___)
+            (box (list tlp1789 tlp1790 tlp1791))))
+          (app test-struct-b (or '(+ 4 5) '(+ 4 5)))
+          (app
+           test-struct-c
+           (struct test-struct (tlp1792 (vector tlp1793 ...) tlp1794 tlp1795)))
+          (app test-struct-d _))
+     (and (? test-struct? tlp1819)
+          (app
+           test-struct-a
+           (box (list tlp1799 (list tlp1800 ..3) (and tlp1801 tlp1802))))
+          (app
+           test-struct-b
+           (and (? test-struct? tlp1814)
+                (app test-struct-a (list tlp1803 tlp1804 tlp1805 tlp1806))
+                (app test-struct-b (vector tlp1807 tlp1808 tlp1809 tlp1810))
+                (app
+                 test-struct-c
+                 (and (or tlp1811 tlp1811) (or tlp1812 tlp1812)))
+                (app test-struct-d (or (list) (list)))))
+          (app test-struct-c (box (list tlp1815 (list) tlp1816)))
+          (app test-struct-d (vector tlp1817 ...)))))
+  ((no-hueristics 2049 2808)
+   (no-hueristics-size 2037 2788)
+   (rel-1-5 3472 5577)
+   (rel-1-5-size 3466 5090)
+   (inverse-in 1911 3178)
+   (inverse-in-size 1905 2691)
+   (tag-negate 1911 2914)
+   (tag-negate-size 1905 4011)
+   (new-coupling 1807 3170)
+   (new-coupling-size 1807 2493)
+   (member-up-count 1807 3390)
+   (member-up-count-size 1807 3248)
+   (memoize-up-count 1807 3233)
+   (memoize-up-count-size 1807 3240)))
+ ((pattern
+    (list
+     (list-rest
+       (list)
+       (and (? test-struct? tlp1720)
+            (app test-struct-a (box (list tlp1715 tlp1716 tlp1717)))
+            (app test-struct-b _)
+            (app test-struct-c 0)
+            (app test-struct-d tlp1718))
+       (not (not '(+ 4 5)))
+       8)
+     '(+ 4 (+ 1 1))
+     (and (? number? tlp1721) (? even? tlp1722))
+     (vector
+       (and (? number? tlp1723) (? even? tlp1724))
+       _
+       (box
+        (list (not (not '(+ 4 (+ 1 1)))) (not (not #t)) (list tlp1725 ___)))
+       (not (not '(+ 1 2)))))
+    (list _ (box (list (list tlp1726 ...) tlp1727 (list))) tlp1728 '(+ 4 5))
+    (list
+     tlp1729
+     #\a
+     (vector
+       (and (? number? tlp1730) (? even? tlp1731))
+       (list-rest
+         '(+ 1 2)
+         (list tlp1732 tlp1733 tlp1734 tlp1735)
+         (list tlp1736 __3)
+         #\b)
+       (list-rest
+         (and (? test-struct? tlp1742)
+              (app test-struct-a tlp1737)
+              (app test-struct-b tlp1738)
+              (app test-struct-c tlp1739)
+              (app test-struct-d tlp1740))
+         (list)
+         (box (list tlp1743 tlp1744 tlp1745))
+         'these)
+       (list))
+     #f))
+  ((no-hueristics 619 390)
+   (no-hueristics-size 619 452)
+   (rel-1-5 587 422)
+   (rel-1-5-size 577 413)
+   (inverse-in 587 465)
+   (inverse-in-size 577 426)
+   (tag-negate 131 116)
+   (tag-negate-size 121 225)
+   (new-coupling 73 210)
+   (new-coupling-size 73 165)
+   (member-up-count 73 313)
+   (member-up-count-size 73 178)
+   (memoize-up-count 73 95)
+   (memoize-up-count-size 73 106)))
+ ((pattern
+    (list
+     (box (list (list) (list) (list tlp1670 __3)))
+     (not (not '(+ 1 2)))
+     (box
+      (list
+       'symbols
+       (vector
+         (or (list tlp1671 tlp1672 tlp1673 tlp1674)
+             (list tlp1671 tlp1672 tlp1673 tlp1674))
+         tlp1675
+         (vector tlp1676 ...)
+         (list tlp1677 tlp1678 tlp1679 tlp1680))
+       tlp1681))
+     (box
+      (list
+       (vector tlp1682 #f #\a _)
+       (vector
+         (and (? test-struct? tlp1688)
+              (app test-struct-a tlp1683)
+              (app test-struct-b tlp1684)
+              (app test-struct-c tlp1685)
+              (app test-struct-d tlp1686))
+         _
+         (list tlp1689 __3)
+         (box (list tlp1690 tlp1691 tlp1692)))
+       (list))))
+    (list
+     (struct
+       test-struct
+       ((vector
+          (vector tlp1693 tlp1694 tlp1695 tlp1696)
+          (list tlp1697 __3)
+          (not (not #\c))
+          tlp1698)
+        (vector tlp1699 ___)
+        (list tlp1700 ..3)
+        #\b))
+     (struct
+       test-struct
+       (tlp1702
+         (vector
+           (list)
+           (box (list tlp1703 tlp1704 tlp1705))
+           (or (list) (list))
+           tlp1706)
+         _
+         tlp1707))
+     #t
+     tlp1709)
+    (list tlp1710 (vector tlp1711 ___) _ tlp1712))
+  ((no-hueristics 2779 3354)
+   (no-hueristics-size 2659 3249)
+   (rel-1-5 1873 3226)
+   (rel-1-5-size 1788 3229)
+   (inverse-in 1873 3362)
+   (inverse-in-size 1788 3417)
+   (tag-negate 1873 3406)
+   (tag-negate-size 1788 5057)
+   (new-coupling 1870 3623)
+   (new-coupling-size 1788 3060)
+   (member-up-count 1870 3424)
+   (member-up-count-size 1788 3043)
+   (memoize-up-count 1870 3331)
+   (memoize-up-count-size 1788 3004)))
+ ((pattern
+    (list
+     (vector
+       (and (? test-struct? tlp1564)
+            (app test-struct-a '(+ 4 (+ 1 1)))
+            (app
+             test-struct-b
+             (and (? test-struct? tlp1562)
+                  (app test-struct-a tlp1557)
+                  (app test-struct-b tlp1558)
+                  (app test-struct-c tlp1559)
+                  (app test-struct-d tlp1560)))
+            (app test-struct-c '(+ 4 5))
+            (app test-struct-d (not (not 3))))
+       (and (box
+             (list
+              (box (list tlp1565 tlp1566 tlp1567))
+              (struct test-struct (tlp1568 tlp1569 tlp1570 tlp1571))
+              (struct test-struct (tlp1573 tlp1574 tlp1575 tlp1576))))
+            (box
+             (list
+              (box (list tlp1578 tlp1579 tlp1580))
+              (struct test-struct (tlp1581 tlp1582 tlp1583 tlp1584))
+              (struct test-struct (tlp1585 tlp1586 tlp1587 tlp1588)))))
+       (or (list-rest
+             (or tlp1589 tlp1589)
+             (and (? test-struct? tlp1595)
+                  (app test-struct-a tlp1590)
+                  (app test-struct-b tlp1591)
+                  (app test-struct-c tlp1592)
+                  (app test-struct-d tlp1593))
+             (vector tlp1596 tlp1597 tlp1598 tlp1599)
+             #t)
+           (list-rest
+             (or tlp1589 tlp1589)
+             (and (? test-struct? tlp1595)
+                  (app test-struct-a tlp1590)
+                  (app test-struct-b tlp1591)
+                  (app test-struct-c tlp1592)
+                  (app test-struct-d tlp1593))
+             (vector tlp1596 tlp1597 tlp1598 tlp1599)
+             #t))
+       (and (? test-struct? tlp1610)
+            (app test-struct-a (list tlp1600 ...))
+            (app test-struct-b (list tlp1601 ...))
+            (app test-struct-c (list tlp1602 tlp1603 tlp1604 tlp1605))
+            (app test-struct-d (list-rest tlp1606 tlp1607 tlp1608 #\b))))
+     (list
+      (and (? number? tlp1611) (? even? tlp1612))
+      (or (and (? number? tlp1613) (? even? tlp1614))
+          (and (? number? tlp1613) (? even? tlp1614)))
+      (box
+       (list
+        (struct test-struct (tlp1615 tlp1616 tlp1617 tlp1618))
+        (and (? number? tlp1620) (? even? tlp1621))
+        #f))
+      (and (? number? tlp1622) (? even? tlp1623)))
+     _
+     (list))
+    (list
+     (box
+      (list
+       (list-rest (vector tlp1624 tlp1625 tlp1626 tlp1627) tlp1628 _ #t)
+       (list tlp1629 ___)
+       (list
+        (vector tlp1630 ___)
+        (and (? test-struct? tlp1636)
+             (app test-struct-a tlp1631)
+             (app test-struct-b tlp1632)
+             (app test-struct-c tlp1633)
+             (app test-struct-d tlp1634))
+        tlp1637
+        tlp1638)))
+     (list tlp1639 ..3)
+     (list-rest _ (list tlp1640 __3) _ #t)
+     (box
+      (list
+       tlp1641
+       #t
+       (vector
+         (and (? number? tlp1642) (? even? tlp1643))
+         (list)
+         #\a
+         (box (list tlp1644 tlp1645 tlp1646))))))
+    (list
+     (list
+      (and (list-rest
+             (not (not 'symbols))
+             _
+             (list-rest tlp1647 tlp1648 tlp1649 tlp1650)
+             0)
+           (list-rest
+             (not (not 'symbols))
+             _
+             (list-rest tlp1651 tlp1652 tlp1653 tlp1654)
+             0))
+      _
+      (struct
+        test-struct
+        ((list-rest tlp1655 tlp1656 tlp1657 #f)
+         (list tlp1658 ...)
+         (and (? test-struct? tlp1664)
+              (app test-struct-a tlp1659)
+              (app test-struct-b tlp1660)
+              (app test-struct-c tlp1661)
+              (app test-struct-d tlp1662))
+         (list tlp1665 ___)))
+      (vector _ (and _ _) (not (not 6)) _))
+     (list tlp1667 __3)
+     (or 9 9)
+     '(+ 4 5)))
+  ((no-hueristics 146 372)
+   (no-hueristics-size 146 387)
+   (rel-1-5 347 538)
+   (rel-1-5-size 292 530)
+   (inverse-in 389 569)
+   (inverse-in-size 363 609)
+   (tag-negate 389 609)
+   (tag-negate-size 363 728)
+   (new-coupling 211 662)
+   (new-coupling-size 211 625)
+   (member-up-count 167 502)
+   (member-up-count-size 137 465)
+   (memoize-up-count 167 501)
+   (memoize-up-count-size 137 459)))
+ ((pattern
+    (list
+     (struct test-struct ((list tlp1437 ...) (vector tlp1438 ___) #\d 'are))
+     (and (struct
+            test-struct
+            ((list tlp1440 ___)
+             (list-rest
+               (list-rest tlp1441 tlp1442 tlp1443 tlp1444)
+               (list)
+               (and (? number? tlp1445) (? even? tlp1446))
+               #t)
+             (list
+              (list-rest tlp1447 tlp1448 tlp1449 tlp1450)
+              tlp1451
+              (list-rest tlp1452 tlp1453 tlp1454 tlp1455)
+              (and (? test-struct? tlp1461)
+                   (app test-struct-a tlp1456)
+                   (app test-struct-b tlp1457)
+                   (app test-struct-c tlp1458)
+                   (app test-struct-d tlp1459)))
+             (box
+              (list
+               (and (? number? tlp1462) (? even? tlp1463))
+               tlp1464
+               (or tlp1465 tlp1465)))))
+          (struct
+            test-struct
+            ((list tlp1467 ___)
+             (list-rest
+               (list-rest tlp1468 tlp1469 tlp1470 tlp1471)
+               (list)
+               (and (? number? tlp1472) (? even? tlp1473))
+               #t)
+             (list
+              (list-rest tlp1474 tlp1475 tlp1476 tlp1477)
+              tlp1478
+              (list-rest tlp1479 tlp1480 tlp1481 tlp1482)
+              (and (? test-struct? tlp1483)
+                   (app test-struct-a tlp1484)
+                   (app test-struct-b tlp1485)
+                   (app test-struct-c tlp1486)
+                   (app test-struct-d tlp1487)))
+             (box
+              (list
+               (and (? number? tlp1488) (? even? tlp1489))
+               tlp1490
+               (or tlp1491 tlp1491))))))
+     (vector tlp1492 ...)
+     (vector
+       (box (list _ (vector tlp1493 ___) tlp1494))
+       (not (not #\b))
+       (and (? test-struct? tlp1503)
+            (app test-struct-a (and _ _))
+            (app test-struct-b (and (list) (list)))
+            (app test-struct-c (box (list tlp1495 tlp1496 tlp1497)))
+            (app test-struct-d (vector tlp1498 tlp1499 tlp1500 tlp1501)))
+       _))
+    (list
+     (and (vector
+            (and (? test-struct? tlp1509)
+                 (app test-struct-a #\c)
+                 (app test-struct-b _)
+                 (app
+                  test-struct-c
+                  (list-rest tlp1504 tlp1505 tlp1506 tlp1507))
+                 (app test-struct-d (list)))
+            tlp1510
+            (list tlp1511 __3)
+            #\a)
+          (vector
+            (and (? test-struct? tlp1512)
+                 (app test-struct-a #\c)
+                 (app test-struct-b _)
+                 (app
+                  test-struct-c
+                  (list-rest tlp1513 tlp1514 tlp1515 tlp1516))
+                 (app test-struct-d (list)))
+            tlp1517
+            (list tlp1518 __3)
+            #\a))
+     _
+     (struct
+       test-struct
+       ((struct test-struct (#t #\b #\d (or 6 6)))
+        (and (? number? tlp1520) (? even? tlp1521))
+        (or (struct
+              test-struct
+              ((list-rest tlp1522 tlp1523 tlp1524 tlp1525)
+               (list-rest tlp1526 tlp1527 tlp1528 tlp1529)
+               (not (not '(+ 1 2)))
+               (and (? test-struct? tlp1535)
+                    (app test-struct-a tlp1530)
+                    (app test-struct-b tlp1531)
+                    (app test-struct-c tlp1532)
+                    (app test-struct-d tlp1533))))
+            (struct
+              test-struct
+              ((list-rest tlp1522 tlp1523 tlp1524 tlp1525)
+               (list-rest tlp1526 tlp1527 tlp1528 tlp1529)
+               (not (not '(+ 1 2)))
+               (and (? test-struct? tlp1535)
+                    (app test-struct-a tlp1530)
+                    (app test-struct-b tlp1531)
+                    (app test-struct-c tlp1532)
+                    (app test-struct-d tlp1533)))))
+        tlp1537))
+     (and (list
+           (vector tlp1539 ...)
+           #\b
+           (struct test-struct (tlp1540 3 tlp1541 tlp1542))
+           (list tlp1544 ..3))
+          (list
+           (vector tlp1545 ...)
+           #\b
+           (struct test-struct (tlp1546 3 tlp1547 tlp1548))
+           (list tlp1549 ..3))))
+    (list
+     (and tlp1550 tlp1551)
+     (list tlp1552 __3)
+     (list tlp1553 ___)
+     (list tlp1554 ...)))
+  ((no-hueristics 598 800)
+   (no-hueristics-size 569 756)
+   (rel-1-5 417 801)
+   (rel-1-5-size 393 787)
+   (inverse-in 549 1156)
+   (inverse-in-size 521 1079)
+   (tag-negate 549 981)
+   (tag-negate-size 521 1474)
+   (new-coupling 540 952)
+   (new-coupling-size 517 947)
+   (member-up-count 411 757)
+   (member-up-count-size 390 840)
+   (memoize-up-count 411 812)
+   (memoize-up-count-size 390 797)))
+ ((pattern
+    (list
+     (list
+      (list tlp1284 ..3)
+      (list)
+      tlp1285
+      (box
+       (list
+        (and (? number? tlp1286) (? even? tlp1287))
+        (or (box (list tlp1288 tlp1289 tlp1290))
+            (box (list tlp1288 tlp1289 tlp1290)))
+        (box (list tlp1291 tlp1292 tlp1293)))))
+     (list tlp1294 __3)
+     2
+     (vector tlp1295 ___)))
+  ((no-hueristics 36 31)
+   (no-hueristics-size 36 32)
+   (rel-1-5 36 98)
+   (rel-1-5-size 36 32)
+   (inverse-in 36 35)
+   (inverse-in-size 36 37)
+   (tag-negate 36 33)
+   (tag-negate-size 36 33)
+   (new-coupling 36 33)
+   (new-coupling-size 36 32)
+   (member-up-count 36 31)
+   (member-up-count-size 36 101)
+   (memoize-up-count 36 33)
+   (memoize-up-count-size 36 33)))
+ ((pattern
+    (list
+     (vector tlp1281 ___)
+     tlp1282
+     (not (not #\b))
+     (or (list tlp1283 ___) (list tlp1283 ___))))
+  ((no-hueristics 10 6)
+   (no-hueristics-size 10 6)
+   (rel-1-5 10 7)
+   (rel-1-5-size 10 7)
+   (inverse-in 10 6)
+   (inverse-in-size 10 8)
+   (tag-negate 10 6)
+   (tag-negate-size 10 7)
+   (new-coupling 10 7)
+   (new-coupling-size 10 7)
+   (member-up-count 10 6)
+   (member-up-count-size 10 8)
+   (memoize-up-count 10 7)
+   (memoize-up-count-size 10 7)))
+ ((pattern
+    (list
+     (and (? test-struct? tlp1239)
+          (app test-struct-a (list tlp1235 __3))
+          (app test-struct-b tlp1236)
+          (app test-struct-c (list))
+          (app test-struct-d (list tlp1237 __3)))
+     tlp1240
+     (list-rest
+       (vector tlp1241 ___)
+       (or (or (list tlp1242 tlp1243 tlp1244 tlp1245)
+               (list tlp1242 tlp1243 tlp1244 tlp1245))
+           (or (list tlp1242 tlp1243 tlp1244 tlp1245)
+               (list tlp1242 tlp1243 tlp1244 tlp1245)))
+       (or (struct
+             test-struct
+             ((box (list tlp1246 tlp1247 tlp1248))
+              (list tlp1249 ___)
+              (and (? test-struct? tlp1255)
+                   (app test-struct-a tlp1250)
+                   (app test-struct-b tlp1251)
+                   (app test-struct-c tlp1252)
+                   (app test-struct-d tlp1253))
+              (list tlp1256 tlp1257 tlp1258 tlp1259)))
+           (struct
+             test-struct
+             ((box (list tlp1246 tlp1247 tlp1248))
+              (list tlp1249 ___)
+              (and (? test-struct? tlp1255)
+                   (app test-struct-a tlp1250)
+                   (app test-struct-b tlp1251)
+                   (app test-struct-c tlp1252)
+                   (app test-struct-d tlp1253))
+              (list tlp1256 tlp1257 tlp1258 tlp1259))))
+       'these)
+     (list
+      tlp1261
+      (not (not #t))
+      (box
+       (list
+        (and (? test-struct? tlp1267)
+             (app test-struct-a tlp1262)
+             (app test-struct-b tlp1263)
+             (app test-struct-c tlp1264)
+             (app test-struct-d tlp1265))
+        #\d
+        (list tlp1268 tlp1269 tlp1270 tlp1271)))
+      (list-rest
+        (list)
+        (list-rest tlp1272 tlp1273 tlp1274 #\c)
+        (and (? test-struct? tlp1280)
+             (app test-struct-a tlp1275)
+             (app test-struct-b tlp1276)
+             (app test-struct-c tlp1277)
+             (app test-struct-d tlp1278))
+        #f))))
+  ((no-hueristics 64 162)
+   (no-hueristics-size 64 227)
+   (rel-1-5 64 157)
+   (rel-1-5-size 64 221)
+   (inverse-in 64 229)
+   (inverse-in-size 64 259)
+   (tag-negate 64 216)
+   (tag-negate-size 64 295)
+   (new-coupling 64 264)
+   (new-coupling-size 64 266)
+   (member-up-count 64 152)
+   (member-up-count-size 64 156)
+   (memoize-up-count 64 264)
+   (memoize-up-count-size 64 151)))
+ ((pattern
+    (list
+     (list
+      #f
+      (list tlp1202 ..3)
+      (vector tlp1203 ___)
+      (list
+       (box (list _ (box (list tlp1204 tlp1205 tlp1206)) (list tlp1207 ___)))
+       (and (? number? tlp1208) (? even? tlp1209))
+       (list)
+       (and (list tlp1210 ...) (list tlp1211 ...))))
+     (list 'symbols (and (? number? tlp1212) (? even? tlp1213)) #f 'are)
+     (list
+      (and tlp1214 tlp1215)
+      (and (? test-struct? tlp1233)
+           (app test-struct-a (vector tlp1216 ___))
+           (app
+            test-struct-b
+            (and (? test-struct? tlp1222)
+                 (app test-struct-a tlp1217)
+                 (app test-struct-b (not (not 4)))
+                 (app test-struct-c (list))
+                 (app test-struct-d (list-rest tlp1218 tlp1219 tlp1220 #\d))))
+           (app test-struct-c (box (list (list) (not (not '(+ 1 2))) (list))))
+           (app
+            test-struct-d
+            (and (? test-struct? tlp1231)
+                 (app test-struct-a (list))
+                 (app test-struct-b (vector tlp1223 ...))
+                 (app test-struct-c tlp1224)
+                 (app
+                  test-struct-d
+                  (struct test-struct (tlp1225 tlp1226 tlp1227 tlp1228))))))
+      (list tlp1234 ___)
+      _)))
+  ((no-hueristics 74 179)
+   (no-hueristics-size 74 120)
+   (rel-1-5 74 187)
+   (rel-1-5-size 74 124)
+   (inverse-in 74 129)
+   (inverse-in-size 74 138)
+   (tag-negate 74 122)
+   (tag-negate-size 74 157)
+   (new-coupling 74 123)
+   (new-coupling-size 74 142)
+   (member-up-count 74 190)
+   (member-up-count-size 74 200)
+   (memoize-up-count 74 123)
+   (memoize-up-count-size 74 190)))
+ ((pattern
+    (list
+     (list
+      (struct test-struct (tlp1097 (list) (vector tlp1098 ___) (list)))
+      (and (? test-struct? tlp1119)
+           (app test-struct-a (list tlp1100 tlp1101 tlp1102 #\a))
+           (app
+            test-struct-b
+            (and (? test-struct? tlp1107)
+                 (app test-struct-a (list-rest tlp1103 tlp1104 tlp1105 8))
+                 (app test-struct-b _)
+                 (app test-struct-c (or '(+ 4 (+ 1 1)) '(+ 4 (+ 1 1))))
+                 (app test-struct-d _)))
+           (app test-struct-c tlp1108)
+           (app
+            test-struct-d
+            (box
+             (list
+              (list tlp1109 tlp1110 tlp1111 tlp1112)
+              (list tlp1113 ..3)
+              (list tlp1114 tlp1115 tlp1116 tlp1117)))))
+      (and (? test-struct? tlp1142)
+           (app
+            test-struct-a
+            (list
+             (list)
+             tlp1120
+             (struct test-struct (tlp1121 tlp1122 tlp1123 tlp1124))
+             (vector tlp1126 tlp1127 tlp1128 tlp1129)))
+           (app
+            test-struct-b
+            (and (? test-struct? tlp1140)
+                 (app test-struct-a _)
+                 (app
+                  test-struct-b
+                  (or (list-rest tlp1130 tlp1131 tlp1132 tlp1133)
+                      (list-rest tlp1130 tlp1131 tlp1132 tlp1133)))
+                 (app test-struct-c tlp1134)
+                 (app test-struct-d (vector tlp1135 tlp1136 tlp1137 tlp1138))))
+           (app test-struct-c (list))
+           (app test-struct-d (not (not 5))))
+      (and (? number? tlp1143) (? even? tlp1144)))
+     (list
+      '(+ 1 2)
+      'symbols
+      _
+      (struct
+        test-struct
+        ((list
+          (list tlp1145 tlp1146 tlp1147 tlp1148)
+          (vector tlp1149 ___)
+          (and (? number? tlp1150) (? even? tlp1151))
+          (list tlp1152 __3))
+         2
+         (list-rest (list tlp1153 ___) (vector tlp1154 ___) 'symbols 0)
+         tlp1155)))
+     (list
+      (list-rest
+        (list-rest
+          #\c
+          (struct test-struct (tlp1157 tlp1158 tlp1159 tlp1160))
+          (and (list-rest tlp1162 tlp1163 tlp1164 tlp1165)
+               (list-rest tlp1166 tlp1167 tlp1168 tlp1169))
+          #\b)
+        (struct
+          test-struct
+          ((and (and (? test-struct? tlp1175)
+                     (app test-struct-a tlp1170)
+                     (app test-struct-b tlp1171)
+                     (app test-struct-c tlp1172)
+                     (app test-struct-d tlp1173))
+                (and (? test-struct? tlp1176)
+                     (app test-struct-a tlp1177)
+                     (app test-struct-b tlp1178)
+                     (app test-struct-c tlp1179)
+                     (app test-struct-d tlp1180)))
+           tlp1181
+           (and tlp1182 tlp1183)
+           (box (list tlp1184 tlp1185 tlp1186))))
+        (or _ _)
+        #\a)
+      (list
+       _
+       (and (? number? tlp1188) (? even? tlp1189))
+       (list)
+       (and (? test-struct? tlp1199)
+            (app test-struct-a (list tlp1190 ..3))
+            (app test-struct-b (vector tlp1191 tlp1192 tlp1193 tlp1194))
+            (app test-struct-c #f)
+            (app test-struct-d (box (list tlp1195 tlp1196 tlp1197)))))
+      (and (? number? tlp1200) (? even? tlp1201))
+      '(+ 4 5))))
+  ((no-hueristics 145 705)
+   (no-hueristics-size 145 712)
+   (rel-1-5 145 712)
+   (rel-1-5-size 145 707)
+   (inverse-in 145 857)
+   (inverse-in-size 145 815)
+   (tag-negate 145 706)
+   (tag-negate-size 145 933)
+   (new-coupling 145 758)
+   (new-coupling-size 145 787)
+   (member-up-count 145 668)
+   (member-up-count-size 145 774)
+   (memoize-up-count 145 757)
+   (memoize-up-count-size 145 724)))
+ ((pattern (list (list tlp1094 __3) tlp1095 (list tlp1096 ..3) (list)))
+  ((no-hueristics 11 5)
+   (no-hueristics-size 11 5)
+   (rel-1-5 11 5)
+   (rel-1-5-size 11 5)
+   (inverse-in 11 6)
+   (inverse-in-size 11 20)
+   (tag-negate 11 6)
+   (tag-negate-size 11 5)
+   (new-coupling 11 5)
+   (new-coupling-size 11 5)
+   (member-up-count 11 6)
+   (member-up-count-size 11 6)
+   (memoize-up-count 11 6)
+   (memoize-up-count-size 11 6)))
+ ((pattern
+    (list
+     (and (? test-struct? tlp1092)
+          (app
+           test-struct-a
+           (struct
+             test-struct
+             ((not (not 'are))
+              tlp1063
+              tlp1064
+              (and (? test-struct? tlp1070)
+                   (app test-struct-a tlp1065)
+                   (app test-struct-b tlp1066)
+                   (app test-struct-c tlp1067)
+                   (app test-struct-d tlp1068)))))
+          (app
+           test-struct-b
+           (struct
+             test-struct
+             ((box (list tlp1072 tlp1073 tlp1074))
+              (and tlp1075 tlp1076)
+              tlp1077
+              (and (list tlp1078 ...) (list tlp1079 ...)))))
+          (app
+           test-struct-c
+           (or (vector
+                 (and tlp1081 tlp1082)
+                 (and (? test-struct? tlp1088)
+                      (app test-struct-a tlp1083)
+                      (app test-struct-b tlp1084)
+                      (app test-struct-c tlp1085)
+                      (app test-struct-d tlp1086))
+                 #\c
+                 #f)
+               (vector
+                 (and tlp1081 tlp1082)
+                 (and (? test-struct? tlp1088)
+                      (app test-struct-a tlp1083)
+                      (app test-struct-b tlp1084)
+                      (app test-struct-c tlp1085)
+                      (app test-struct-d tlp1086))
+                 #\c
+                 #f)))
+          (app test-struct-d (and (? number? tlp1089) (? even? tlp1090))))
+     #t
+     (list tlp1093 ..3)
+     _))
+  ((no-hueristics 27 33)
+   (no-hueristics-size 27 33)
+   (rel-1-5 27 33)
+   (rel-1-5-size 27 33)
+   (inverse-in 27 42)
+   (inverse-in-size 27 33)
+   (tag-negate 27 32)
+   (tag-negate-size 27 131)
+   (new-coupling 27 33)
+   (new-coupling-size 27 35)
+   (member-up-count 27 99)
+   (member-up-count-size 27 37)
+   (memoize-up-count 27 33)
+   (memoize-up-count-size 27 37)))
+ ((pattern
+    (list
+     (list)
+     (list tlp1052 ...)
+     (list-rest
+       (list tlp1053 ..3)
+       (vector tlp1054 ...)
+       (vector
+         tlp1055
+         (vector tlp1056 ___)
+         (list tlp1057 ...)
+         (box (list tlp1058 tlp1059 tlp1060)))
+       #\d)
+     (and (? number? tlp1061) (? even? tlp1062))))
+  ((no-hueristics 28 23)
+   (no-hueristics-size 28 23)
+   (rel-1-5 28 23)
+   (rel-1-5-size 28 24)
+   (inverse-in 28 25)
+   (inverse-in-size 28 23)
+   (tag-negate 28 24)
+   (tag-negate-size 28 23)
+   (new-coupling 28 24)
+   (new-coupling-size 28 25)
+   (member-up-count 28 23)
+   (member-up-count-size 28 26)
+   (memoize-up-count 28 24)
+   (memoize-up-count-size 28 29)))
+ ((pattern
+    (list
+     (list)
+     (and (? test-struct? tlp1033)
+          (app test-struct-a tlp1007)
+          (app test-struct-b (and (? number? tlp1008) (? even? tlp1009)))
+          (app
+           test-struct-c
+           (and (? test-struct? tlp1023)
+                (app
+                 test-struct-a
+                 (and (list-rest tlp1010 tlp1011 tlp1012 tlp1013)
+                      (list-rest tlp1014 tlp1015 tlp1016 tlp1017)))
+                (app test-struct-b (list))
+                (app test-struct-c (and (list tlp1018 ___) (list tlp1019 ___)))
+                (app
+                 test-struct-d
+                 (and (? number? tlp1020) (? even? tlp1021)))))
+          (app
+           test-struct-d
+           (and (? test-struct? tlp1031)
+                (app
+                 test-struct-a
+                 (or (and (? number? tlp1024) (? even? tlp1025))
+                     (and (? number? tlp1024) (? even? tlp1025))))
+                (app test-struct-b _)
+                (app test-struct-c (vector tlp1026 tlp1027 tlp1028 tlp1029))
+                (app test-struct-d _))))
+     9
+     (list
+      (struct
+        test-struct
+        ((and (and tlp1034 tlp1035) (and tlp1036 tlp1037))
+         tlp1038
+         (struct test-struct (tlp1039 tlp1040 tlp1041 tlp1042))
+         (and (? test-struct? tlp1049)
+              (app test-struct-a tlp1044)
+              (app test-struct-b tlp1045)
+              (app test-struct-c tlp1046)
+              (app test-struct-d tlp1047))))
+      tlp1051
+      1
+      _)))
+  ((no-hueristics 33 107)
+   (no-hueristics-size 33 52)
+   (rel-1-5 33 109)
+   (rel-1-5-size 33 110)
+   (inverse-in 33 59)
+   (inverse-in-size 33 53)
+   (tag-negate 33 52)
+   (tag-negate-size 33 53)
+   (new-coupling 33 53)
+   (new-coupling-size 33 54)
+   (member-up-count 33 52)
+   (member-up-count-size 33 133)
+   (memoize-up-count 33 53)
+   (memoize-up-count-size 33 52)))
+ ((pattern
+    (list
+     (box
+      (list
+       (list
+        (list-rest tlp973 tlp974 tlp975 'symbols)
+        (not (not 'these))
+        tlp976
+        (and (? test-struct? tlp982)
+             (app test-struct-a tlp977)
+             (app test-struct-b tlp978)
+             (app test-struct-c tlp979)
+             (app test-struct-d tlp980)))
+       (list
+        (list tlp983 tlp984 tlp985 tlp986)
+        (and (? test-struct? tlp992)
+             (app test-struct-a tlp987)
+             (app test-struct-b tlp988)
+             (app test-struct-c tlp989)
+             (app test-struct-d tlp990))
+        (vector tlp993 tlp994 tlp995 tlp996)
+        (box (list tlp997 tlp998 tlp999)))
+       (or tlp1000 tlp1000)))
+     (and (? test-struct? tlp1005)
+          (app test-struct-a #t)
+          (app test-struct-b (or tlp1001 tlp1001))
+          (app test-struct-c tlp1002)
+          (app test-struct-d (list tlp1003 ...)))
+     (not (not 'these))
+     (list tlp1006 ___)))
+  ((no-hueristics 45 75)
+   (no-hueristics-size 45 72)
+   (rel-1-5 45 76)
+   (rel-1-5-size 45 75)
+   (inverse-in 45 95)
+   (inverse-in-size 45 136)
+   (tag-negate 45 76)
+   (tag-negate-size 45 108)
+   (new-coupling 45 184)
+   (new-coupling-size 45 199)
+   (member-up-count 45 74)
+   (member-up-count-size 45 84)
+   (memoize-up-count 45 185)
+   (memoize-up-count-size 45 78)))
+ ((pattern
+    (list
+     (or (and #\c #\c) (and #\c #\c))
+     (list tlp963 __3)
+     (not (not #f))
+     (list
+      (and (or (list-rest tlp964 tlp965 tlp966 'are)
+               (list-rest tlp964 tlp965 tlp966 'are))
+           (or (list-rest tlp967 tlp968 tlp969 'are)
+               (list-rest tlp967 tlp968 tlp969 'are)))
+      (list tlp970 __3)
+      tlp971
+      tlp972)))
+  ((no-hueristics 21 22)
+   (no-hueristics-size 21 22)
+   (rel-1-5 21 22)
+   (rel-1-5-size 21 21)
+   (inverse-in 21 138)
+   (inverse-in-size 21 84)
+   (tag-negate 21 84)
+   (tag-negate-size 21 22)
+   (new-coupling 21 22)
+   (new-coupling-size 21 23)
+   (member-up-count 21 22)
+   (member-up-count-size 21 26)
+   (memoize-up-count 21 21)
+   (memoize-up-count-size 21 22)))
+ ((pattern
+    (list
+     (and (list
+           (list (and (? number? tlp5016) (? even? tlp5017)) (list) #\a (list))
+           (and (? number? tlp5018) (? even? tlp5019))
+           (list)
+           tlp5020)
+          (list
+           (list (and (? number? tlp5021) (? even? tlp5022)) (list) #\a (list))
+           (and (? number? tlp5023) (? even? tlp5024))
+           (list)
+           tlp5025))
+     (or (not (not 'are)) (not (not 'are)))
+     tlp5026
+     (list
+      (struct
+        test-struct
+        (_
+         (or (struct test-struct (tlp5027 tlp5028 tlp5029 tlp5030))
+             (struct test-struct (tlp5027 tlp5028 tlp5029 tlp5030)))
+         (or (list tlp5032 __3) (list tlp5032 __3))
+         (list tlp5033 tlp5034 tlp5035 tlp5036)))
+      (and (? test-struct? tlp5041)
+           (app test-struct-a '(+ 1 2))
+           (app test-struct-b tlp5038)
+           (app test-struct-c (list tlp5039 ___))
+           (app test-struct-d 'are))
+      tlp5042
+      (or (and (? number? tlp5043) (? even? tlp5044))
+          (and (? number? tlp5043) (? even? tlp5044))))))
+  ((no-hueristics 45 65)
+   (no-hueristics-size 45 65)
+   (rel-1-5 45 66)
+   (rel-1-5-size 45 65)
+   (inverse-in 45 65)
+   (inverse-in-size 45 83)
+   (tag-negate 45 63)
+   (tag-negate-size 45 155)
+   (new-coupling 45 65)
+   (new-coupling-size 45 70)
+   (member-up-count 45 64)
+   (member-up-count-size 45 67)
+   (memoize-up-count 45 65)
+   (memoize-up-count-size 45 128)))
+ ((pattern
+    (list
+     (vector tlp5006 ...)
+     _
+     (vector
+       (list tlp5007 ..3)
+       (box (list (list tlp5008 ___) _ (not (not #t))))
+       tlp5009
+       (list tlp5010 (vector tlp5011 ...) (list) (list)))
+     (and (? number? tlp5012) (? even? tlp5013))))
+  ((no-hueristics 30 24)
+   (no-hueristics-size 30 23)
+   (rel-1-5 30 23)
+   (rel-1-5-size 30 23)
+   (inverse-in 30 24)
+   (inverse-in-size 30 23)
+   (tag-negate 30 23)
+   (tag-negate-size 30 55)
+   (new-coupling 30 22)
+   (new-coupling-size 30 27)
+   (member-up-count 30 23)
+   (member-up-count-size 30 83)
+   (memoize-up-count 30 22)
+   (memoize-up-count-size 30 23)))
+ ((pattern (list #\b (and (list) (list)) '(+ 4 (+ 1 1)) tlp5003))
+  ((no-hueristics 9 4)
+   (no-hueristics-size 9 4)
+   (rel-1-5 9 4)
+   (rel-1-5-size 9 4)
+   (inverse-in 9 4)
+   (inverse-in-size 9 4)
+   (tag-negate 9 5)
+   (tag-negate-size 9 4)
+   (new-coupling 9 4)
+   (new-coupling-size 9 5)
+   (member-up-count 9 4)
+   (member-up-count-size 9 4)
+   (memoize-up-count 9 4)
+   (memoize-up-count-size 9 4)))
+ ((pattern
+    (list
+     _
+     (vector tlp4988 ...)
+     tlp4989
+     (box
+      (list
+       (not (not '(+ 4 (+ 1 1))))
+       (struct
+         test-struct
+         ((list-rest tlp4990 tlp4991 tlp4992 4)
+          (struct test-struct (tlp4993 tlp4994 tlp4995 tlp4996))
+          tlp4998
+          #t))
+       tlp5000))))
+  ((no-hueristics 21 19)
+   (no-hueristics-size 21 18)
+   (rel-1-5 21 77)
+   (rel-1-5-size 21 18)
+   (inverse-in 21 19)
+   (inverse-in-size 21 19)
+   (tag-negate 21 19)
+   (tag-negate-size 21 21)
+   (new-coupling 21 19)
+   (new-coupling-size 21 20)
+   (member-up-count 21 21)
+   (member-up-count-size 21 19)
+   (memoize-up-count 21 19)
+   (memoize-up-count-size 21 18)))
+ ((pattern (list tlp4984 'these (not (not #\b)) tlp4985))
+  ((no-hueristics 8 4)
+   (no-hueristics-size 8 4)
+   (rel-1-5 8 4)
+   (rel-1-5-size 8 4)
+   (inverse-in 8 5)
+   (inverse-in-size 8 4)
+   (tag-negate 8 4)
+   (tag-negate-size 8 4)
+   (new-coupling 8 4)
+   (new-coupling-size 8 6)
+   (member-up-count 8 4)
+   (member-up-count-size 8 4)
+   (memoize-up-count 8 4)
+   (memoize-up-count-size 8 4)))
+ ((pattern
+    (list
+     (list tlp4527 __3)
+     (list
+      (and (? test-struct? tlp4540)
+           (app
+            test-struct-a
+            (and (struct test-struct (tlp4528 tlp4529 tlp4530 tlp4531))
+                 (struct test-struct (tlp4533 tlp4534 tlp4535 tlp4536))))
+           (app test-struct-b (list tlp4537 ..3))
+           (app test-struct-c #\d)
+           (app test-struct-d (vector tlp4538 ...)))
+      (and (? test-struct? tlp4556)
+           (app test-struct-a (not (not #\b)))
+           (app
+            test-struct-b
+            (and (vector tlp4541 tlp4542 tlp4543 tlp4544)
+                 (vector tlp4545 tlp4546 tlp4547 tlp4548)))
+           (app test-struct-c (vector tlp4549 ...))
+           (app
+            test-struct-d
+            (struct test-struct (tlp4550 tlp4551 tlp4552 tlp4553))))
+      (box
+       (list
+        (and (list tlp4557 __3) (list tlp4558 __3))
+        tlp4559
+        (not (not 4))))
+      tlp4560)
+     (list)
+     (or 'these 'these)))
+  ((no-hueristics 37 49)
+   (no-hueristics-size 37 49)
+   (rel-1-5 37 49)
+   (rel-1-5-size 37 49)
+   (inverse-in 37 49)
+   (inverse-in-size 37 71)
+   (tag-negate 37 51)
+   (tag-negate-size 37 51)
+   (new-coupling 37 58)
+   (new-coupling-size 37 56)
+   (member-up-count 37 55)
+   (member-up-count-size 37 78)
+   (memoize-up-count 37 51)
+   (memoize-up-count-size 37 51)))
+ ((pattern
+    (list
+     (and (? number? tlp4521) (? even? tlp4522))
+     (or tlp4523 tlp4523)
+     tlp4524
+     (list tlp4525 ...)))
+  ((no-hueristics 9 6)
+   (no-hueristics-size 9 6)
+   (rel-1-5 9 6)
+   (rel-1-5-size 9 6)
+   (inverse-in 9 6)
+   (inverse-in-size 9 5)
+   (tag-negate 9 6)
+   (tag-negate-size 9 6)
+   (new-coupling 9 5)
+   (new-coupling-size 9 6)
+   (member-up-count 9 6)
+   (member-up-count-size 9 6)
+   (memoize-up-count 9 6)
+   (memoize-up-count-size 9 6)))
+ ((pattern
+    (list
+     (list-rest
+       (and (list
+             (vector tlp4474 tlp4475 tlp4476 tlp4477)
+             (vector tlp4478 tlp4479 tlp4480 tlp4481)
+             (list)
+             (or tlp4482 tlp4482))
+            (list
+             (vector tlp4483 tlp4484 tlp4485 tlp4486)
+             (vector tlp4487 tlp4488 tlp4489 tlp4490)
+             (list)
+             (or tlp4491 tlp4491)))
+       (and (? number? tlp4492) (? even? tlp4493))
+       (list '(+ 1 2) (list tlp4494 ...) tlp4495 tlp4496)
+       #f)
+     (and (? test-struct? tlp4517)
+          (app
+           test-struct-a
+           (or (box
+                (list
+                 (and (? test-struct? tlp4502)
+                      (app test-struct-a tlp4497)
+                      (app test-struct-b tlp4498)
+                      (app test-struct-c tlp4499)
+                      (app test-struct-d tlp4500))
+                 (list)
+                 (vector tlp4503 tlp4504 tlp4505 tlp4506)))
+               (box
+                (list
+                 (and (? test-struct? tlp4502)
+                      (app test-struct-a tlp4497)
+                      (app test-struct-b tlp4498)
+                      (app test-struct-c tlp4499)
+                      (app test-struct-d tlp4500))
+                 (list)
+                 (vector tlp4503 tlp4504 tlp4505 tlp4506)))))
+          (app
+           test-struct-b
+           (and (list-rest
+                  (list tlp4507 ___)
+                  (and (? number? tlp4508) (? even? tlp4509))
+                  (list tlp4510 __3)
+                  'these)
+                (list-rest
+                  (list tlp4511 ___)
+                  (and (? number? tlp4512) (? even? tlp4513))
+                  (list tlp4514 __3)
+                  'these)))
+          (app test-struct-c (or (list tlp4515 ..3) (list tlp4515 ..3)))
+          (app test-struct-d (list)))
+     tlp4518
+     tlp4519))
+  ((no-hueristics 51 93)
+   (no-hueristics-size 51 92)
+   (rel-1-5 51 94)
+   (rel-1-5-size 51 93)
+   (inverse-in 51 172)
+   (inverse-in-size 51 176)
+   (tag-negate 51 94)
+   (tag-negate-size 51 189)
+   (new-coupling 51 223)
+   (new-coupling-size 51 200)
+   (member-up-count 51 97)
+   (member-up-count-size 51 91)
+   (memoize-up-count 51 199)
+   (memoize-up-count-size 51 153)))
+ ((pattern
+    (list
+     tlp4451
+     tlp4452
+     (and (? test-struct? tlp4471)
+          (app
+           test-struct-a
+           (and (? test-struct? tlp4461)
+                (app test-struct-a (box (list tlp4453 tlp4454 tlp4455)))
+                (app test-struct-b (list tlp4456 ...))
+                (app
+                 test-struct-c
+                 (list-rest tlp4457 tlp4458 tlp4459 'symbols))
+                (app test-struct-d '(+ 4 5))))
+          (app test-struct-b (and (? number? tlp4462) (? even? tlp4463)))
+          (app test-struct-c tlp4464)
+          (app
+           test-struct-d
+           (or (list-rest
+                 (list)
+                 tlp4465
+                 (list tlp4466 tlp4467 tlp4468 tlp4469)
+                 #\b)
+               (list-rest
+                 (list)
+                 tlp4465
+                 (list tlp4466 tlp4467 tlp4468 tlp4469)
+                 #\b))))
+     tlp4472))
+  ((no-hueristics 31 37)
+   (no-hueristics-size 31 37)
+   (rel-1-5 31 38)
+   (rel-1-5-size 31 39)
+   (inverse-in 31 41)
+   (inverse-in-size 31 37)
+   (tag-negate 31 105)
+   (tag-negate-size 31 38)
+   (new-coupling 31 42)
+   (new-coupling-size 31 37)
+   (member-up-count 31 36)
+   (member-up-count-size 31 37)
+   (memoize-up-count 31 37)
+   (memoize-up-count-size 31 36)))
+ ((pattern
+    (list
+     (not (not 'are))
+     (list-rest
+       tlp4432
+       (list-rest tlp4433 (list tlp4434 ...) tlp4435 'symbols)
+       (not (not 2))
+       'symbols)
+     (not (not #\a))
+     (list
+      (and (? test-struct? tlp4445)
+           (app test-struct-a (list-rest tlp4436 tlp4437 tlp4438 9))
+           (app
+            test-struct-b
+            (and (and tlp4439 tlp4440) (and tlp4441 tlp4442)))
+           (app test-struct-c '(+ 1 2))
+           (app test-struct-d (list tlp4443 ___)))
+      tlp4446
+      (list-rest 'these tlp4447 (list tlp4448 ..3) 'these)
+      (list tlp4449 ___))))
+  ((no-hueristics 38 45)
+   (no-hueristics-size 38 105)
+   (rel-1-5 38 107)
+   (rel-1-5-size 38 107)
+   (inverse-in 38 53)
+   (inverse-in-size 38 63)
+   (tag-negate 38 47)
+   (tag-negate-size 38 45)
+   (new-coupling 38 50)
+   (new-coupling-size 38 45)
+   (member-up-count 38 47)
+   (member-up-count-size 38 49)
+   (memoize-up-count 38 46)
+   (memoize-up-count-size 38 46)))
+ ((pattern
+    (list
+     (and (? test-struct? tlp3903)
+          (app
+           test-struct-a
+           (and (? test-struct? tlp3891)
+                (app test-struct-a tlp3885)
+                (app test-struct-b (list tlp3886 tlp3887 tlp3888 tlp3889))
+                (app test-struct-c (not (not #\d)))
+                (app test-struct-d _)))
+          (app test-struct-b '(+ 4 5))
+          (app test-struct-c (list))
+          (app
+           test-struct-d
+           (vector
+             (list tlp3892 tlp3893 tlp3894 tlp3895)
+             (and (? test-struct? tlp3901)
+                  (app test-struct-a tlp3896)
+                  (app test-struct-b tlp3897)
+                  (app test-struct-c tlp3898)
+                  (app test-struct-d tlp3899))
+             _
+             (or (list) (list)))))
+     (list tlp3904 ..3)
+     (list tlp3905 ...)
+     (vector
+       (list tlp3906 ...)
+       (list-rest
+         (list tlp3907 ..3)
+         (list-rest tlp3908 tlp3909 tlp3910 #\d)
+         5
+         'are)
+       (list-rest
+         tlp3911
+         (and (? number? tlp3912) (? even? tlp3913))
+         (list tlp3914 ...)
+         #\d)
+       (list tlp3915 #\b (vector tlp3916 ...) (list)))))
+  ((no-hueristics 58 89)
+   (no-hueristics-size 58 91)
+   (rel-1-5 58 90)
+   (rel-1-5-size 58 89)
+   (inverse-in 58 166)
+   (inverse-in-size 58 163)
+   (tag-negate 58 90)
+   (tag-negate-size 58 92)
+   (new-coupling 58 103)
+   (new-coupling-size 58 89)
+   (member-up-count 58 154)
+   (member-up-count-size 58 99)
+   (memoize-up-count 58 91)
+   (memoize-up-count-size 58 92)))
+ ((pattern
+    (list
+     (box
+      (list
+       tlp3826
+       tlp3827
+       (list-rest
+         (list-rest tlp3828 tlp3829 tlp3830 #t)
+         (list tlp3831 __3)
+         (list-rest tlp3832 tlp3833 tlp3834 'these)
+         #\b)))
+     (list)
+     (and (? test-struct? tlp3857)
+          (app test-struct-a (box (list tlp3835 #\a tlp3836)))
+          (app
+           test-struct-b
+           (and (list
+                 (list tlp3837 __3)
+                 #t
+                 (and (? number? tlp3838) (? even? tlp3839))
+                 (vector tlp3840 ...))
+                (list
+                 (list tlp3841 __3)
+                 #t
+                 (and (? number? tlp3842) (? even? tlp3843))
+                 (vector tlp3844 ...))))
+          (app test-struct-c (list (vector tlp3845 ...) #t tlp3846 (or #f #f)))
+          (app
+           test-struct-d
+           (or (and (? test-struct? tlp3855)
+                    (app test-struct-a #\b)
+                    (app test-struct-b _)
+                    (app
+                     test-struct-c
+                     (struct test-struct (tlp3847 tlp3848 tlp3849 tlp3850)))
+                    (app
+                     test-struct-d
+                     (and (? number? tlp3852) (? even? tlp3853))))
+               (and (? test-struct? tlp3855)
+                    (app test-struct-a #\b)
+                    (app test-struct-b _)
+                    (app
+                     test-struct-c
+                     (struct test-struct (tlp3847 tlp3848 tlp3849 tlp3850)))
+                    (app
+                     test-struct-d
+                     (and (? number? tlp3852) (? even? tlp3853)))))))
+     (list
+      (list-rest
+        (list-rest tlp3858 tlp3859 tlp3860 'these)
+        (box (list tlp3861 tlp3862 tlp3863))
+        (not (not '(+ 4 (+ 1 1))))
+        #\a)
+      (and (list-rest
+             (vector tlp3864 tlp3865 tlp3866 tlp3867)
+             (vector tlp3868 ...)
+             '(+ 4 5)
+             #\d)
+           (list-rest
+             (vector tlp3869 tlp3870 tlp3871 tlp3872)
+             (vector tlp3873 ...)
+             '(+ 4 5)
+             #\d))
+      (not (not #\b))
+      (vector
+        tlp3874
+        (not (not '(+ 1 2)))
+        (list tlp3875 tlp3876 tlp3877 tlp3878)
+        (list tlp3879 tlp3880 tlp3881 tlp3882)))))
+  ((no-hueristics 103 364)
+   (no-hueristics-size 103 358)
+   (rel-1-5 103 362)
+   (rel-1-5-size 103 380)
+   (inverse-in 103 309)
+   (inverse-in-size 103 334)
+   (tag-negate 103 368)
+   (tag-negate-size 103 363)
+   (new-coupling 103 458)
+   (new-coupling-size 103 793)
+   (member-up-count 103 301)
+   (member-up-count-size 103 385)
+   (memoize-up-count 103 413)
+   (memoize-up-count-size 103 365)))
+ ((pattern
+    (list
+     (struct
+       test-struct
+       ((and (list tlp3735 __3) (list tlp3736 __3))
+        tlp3737
+        (and (? number? tlp3738) (? even? tlp3739))
+        (and (? test-struct? tlp3754)
+             (app
+              test-struct-a
+              (and (? test-struct? tlp3745)
+                   (app test-struct-a tlp3740)
+                   (app test-struct-b tlp3741)
+                   (app test-struct-c tlp3742)
+                   (app test-struct-d tlp3743)))
+             (app
+              test-struct-b
+              (and (vector tlp3746 ___) (vector tlp3747 ___)))
+             (app test-struct-c _)
+             (app
+              test-struct-d
+              (struct test-struct (tlp3748 tlp3749 tlp3750 tlp3751))))))
+     #t
+     (and (vector
+            (list
+             _
+             (and tlp3756 tlp3757)
+             (and (? test-struct? tlp3763)
+                  (app test-struct-a tlp3758)
+                  (app test-struct-b tlp3759)
+                  (app test-struct-c tlp3760)
+                  (app test-struct-d tlp3761))
+             (not (not 'are)))
+            _
+            (struct
+              test-struct
+              ((box (list tlp3764 tlp3765 tlp3766))
+               (vector tlp3767 tlp3768 tlp3769 tlp3770)
+               tlp3771
+               (struct test-struct (tlp3772 tlp3773 tlp3774 tlp3775))))
+            _)
+          (vector
+            (list
+             _
+             (and tlp3778 tlp3779)
+             (and (? test-struct? tlp3780)
+                  (app test-struct-a tlp3781)
+                  (app test-struct-b tlp3782)
+                  (app test-struct-c tlp3783)
+                  (app test-struct-d tlp3784))
+             (not (not 'are)))
+            _
+            (struct
+              test-struct
+              ((box (list tlp3785 tlp3786 tlp3787))
+               (vector tlp3788 tlp3789 tlp3790 tlp3791)
+               tlp3792
+               (struct test-struct (tlp3793 tlp3794 tlp3795 tlp3796))))
+            _))
+     (and (? test-struct? tlp3823)
+          (app
+           test-struct-a
+           (and (? test-struct? tlp3806)
+                (app
+                 test-struct-a
+                 (and (and tlp3797 tlp3798) (and tlp3799 tlp3800)))
+                (app test-struct-b (box (list tlp3801 tlp3802 tlp3803)))
+                (app test-struct-c (or '(+ 4 5) '(+ 4 5)))
+                (app test-struct-d tlp3804)))
+          (app
+           test-struct-b
+           (box
+            (list
+             (box (list tlp3807 tlp3808 tlp3809))
+             #\c
+             (list tlp3810 ..3))))
+          (app test-struct-c _)
+          (app
+           test-struct-d
+           (and (? test-struct? tlp3821)
+                (app test-struct-a tlp3811)
+                (app test-struct-b (list tlp3812 ...))
+                (app
+                 test-struct-c
+                 (and (? test-struct? tlp3818)
+                      (app test-struct-a tlp3813)
+                      (app test-struct-b tlp3814)
+                      (app test-struct-c tlp3815)
+                      (app test-struct-d tlp3816)))
+                (app test-struct-d (vector tlp3819 ___)))))))
+  ((no-hueristics 62 189)
+   (no-hueristics-size 62 183)
+   (rel-1-5 62 243)
+   (rel-1-5-size 62 186)
+   (inverse-in 62 272)
+   (inverse-in-size 62 274)
+   (tag-negate 62 185)
+   (tag-negate-size 62 307)
+   (new-coupling 62 195)
+   (new-coupling-size 62 184)
+   (member-up-count 62 246)
+   (member-up-count-size 62 277)
+   (memoize-up-count 62 184)
+   (memoize-up-count-size 62 253)))
+ ((pattern
+    (list
+     tlp3721
+     tlp3722
+     (or (list
+          (and (? number? tlp3723) (? even? tlp3724))
+          tlp3725
+          (list)
+          (vector
+            tlp3726
+            (list tlp3727 tlp3728 tlp3729 tlp3730)
+            (list)
+            tlp3731))
+         (list
+          (and (? number? tlp3723) (? even? tlp3724))
+          tlp3725
+          (list)
+          (vector
+            tlp3726
+            (list tlp3727 tlp3728 tlp3729 tlp3730)
+            (list)
+            tlp3731)))
+     (or tlp3732 tlp3732)))
+  ((no-hueristics 22 90)
+   (no-hueristics-size 22 32)
+   (rel-1-5 22 33)
+   (rel-1-5-size 22 32)
+   (inverse-in 22 33)
+   (inverse-in-size 22 44)
+   (tag-negate 22 33)
+   (tag-negate-size 22 33)
+   (new-coupling 22 34)
+   (new-coupling-size 22 32)
+   (member-up-count 22 34)
+   (member-up-count-size 22 30)
+   (memoize-up-count 22 30)
+   (memoize-up-count-size 22 38)))
+ ((pattern
+    (list
+     3
+     (and (? number? tlp3716) (? even? tlp3717))
+     (and #f #f)
+     (or (vector tlp3718 ___) (vector tlp3718 ___))))
+  ((no-hueristics 13 9)
+   (no-hueristics-size 13 9)
+   (rel-1-5 13 9)
+   (rel-1-5-size 13 69)
+   (inverse-in 13 9)
+   (inverse-in-size 13 8)
+   (tag-negate 13 14)
+   (tag-negate-size 13 9)
+   (new-coupling 13 10)
+   (new-coupling-size 13 8)
+   (member-up-count 13 8)
+   (member-up-count-size 13 9)
+   (memoize-up-count 13 8)
+   (memoize-up-count-size 13 11)))
+ ((pattern
+    (list
+     (struct
+       test-struct
+       ((not (not #\b))
+        tlp3697
+        (box (list tlp3698 (list tlp3699 ..3) tlp3700))
+        (or _ _)))
+     (list-rest (list) (vector tlp3702 ...) (and 'are 'are) #\d)
+     (box
+      (list
+       tlp3703
+       (vector
+         (list tlp3704 ___)
+         (list tlp3705 ...)
+         (list tlp3706 ___)
+         (vector tlp3707 ...))
+       (list
+        (struct test-struct (tlp3708 tlp3709 tlp3710 tlp3711))
+        #t
+        (list)
+        (list tlp3713 __3))))
+     (vector tlp3714 ___)))
+  ((no-hueristics 47 54)
+   (no-hueristics-size 47 114)
+   (rel-1-5 47 56)
+   (rel-1-5-size 47 55)
+   (inverse-in 47 60)
+   (inverse-in-size 47 59)
+   (tag-negate 47 59)
+   (tag-negate-size 47 59)
+   (new-coupling 47 58)
+   (new-coupling-size 47 55)
+   (member-up-count 47 55)
+   (member-up-count-size 47 59)
+   (memoize-up-count 47 56)
+   (memoize-up-count-size 47 65)))
+ ((pattern
+    (list
+     tlp3688
+     tlp3689
+     (list
+      (box
+       (list
+        (list tlp3690 ___)
+        (and (? number? tlp3691) (? even? tlp3692))
+        (not (not #\c))))
+      (and (list tlp3693 ...) (list tlp3694 ...))
+      tlp3695
+      (not (not #f)))
+     (vector tlp3696 ...)))
+  ((no-hueristics 24 19)
+   (no-hueristics-size 24 19)
+   (rel-1-5 24 19)
+   (rel-1-5-size 24 20)
+   (inverse-in 24 75)
+   (inverse-in-size 24 20)
+   (tag-negate 24 20)
+   (tag-negate-size 24 20)
+   (new-coupling 24 22)
+   (new-coupling-size 24 21)
+   (member-up-count 24 27)
+   (member-up-count-size 24 20)
+   (memoize-up-count 24 21)
+   (memoize-up-count-size 24 84)))
+ ((pattern
+    (list
+     tlp3683
+     (list-rest
+       (and #\d #\d)
+       (or (list tlp3684 __3) (list tlp3684 __3))
+       (list)
+       #\d)
+     (and (vector tlp3685 ___) (vector tlp3686 ___))
+     (list tlp3687 ___)))
+  ((no-hueristics 18 13)
+   (no-hueristics-size 18 12)
+   (rel-1-5 18 72)
+   (rel-1-5-size 18 12)
+   (inverse-in 18 12)
+   (inverse-in-size 18 12)
+   (tag-negate 18 13)
+   (tag-negate-size 18 100)
+   (new-coupling 18 15)
+   (new-coupling-size 18 13)
+   (member-up-count 18 13)
+   (member-up-count-size 18 13)
+   (memoize-up-count 18 13)
+   (memoize-up-count-size 18 13)))
+ ((pattern
+    (list
+     (box
+      (list
+       (struct
+         test-struct
+         ((vector tlp3672 ...)
+          tlp3673
+          (and (not (not #\c)) (not (not #\c)))
+          (list-rest tlp3674 tlp3675 tlp3676 #\d)))
+       tlp3678
+       (and (list tlp3679 ...) (list tlp3680 ...))))
+     _
+     tlp3681
+     tlp3682))
+  ((no-hueristics 20 17)
+   (no-hueristics-size 20 17)
+   (rel-1-5 20 17)
+   (rel-1-5-size 20 17)
+   (inverse-in 20 17)
+   (inverse-in-size 20 16)
+   (tag-negate 20 17)
+   (tag-negate-size 20 17)
+   (new-coupling 20 24)
+   (new-coupling-size 20 19)
+   (member-up-count 20 18)
+   (member-up-count-size 20 17)
+   (memoize-up-count 20 19)
+   (memoize-up-count-size 20 17)))
+ ((pattern
+    (list
+     (vector
+       (vector tlp3663 ___)
+       (list tlp3664 ___)
+       (and (? number? tlp3665) (? even? tlp3666))
+       (box (list (vector tlp3667 ...) (list tlp3668 ..3) _)))
+     tlp3669
+     (list tlp3670 __3)
+     tlp3671))
+  ((no-hueristics 24 16)
+   (no-hueristics-size 24 17)
+   (rel-1-5 24 16)
+   (rel-1-5-size 24 16)
+   (inverse-in 24 19)
+   (inverse-in-size 24 18)
+   (tag-negate 24 16)
+   (tag-negate-size 24 16)
+   (new-coupling 24 21)
+   (new-coupling-size 24 17)
+   (member-up-count 24 16)
+   (member-up-count-size 24 17)
+   (memoize-up-count 24 17)
+   (memoize-up-count-size 24 18)))
+ ((pattern
+    (list
+     (list _ (not (not #f)) (not (not #f)) (vector tlp3610 ___))
+     (list
+      (list tlp3611 ...)
+      (vector
+        (list tlp3612 ...)
+        (and tlp3613 tlp3614)
+        (list tlp3615 ...)
+        (and (? test-struct? tlp3626)
+             (app test-struct-a (and (list) (list)))
+             (app test-struct-b tlp3616)
+             (app test-struct-c (vector tlp3617 tlp3618 tlp3619 tlp3620))
+             (app test-struct-d (vector tlp3621 tlp3622 tlp3623 tlp3624))))
+      (and (vector
+             tlp3627
+             (vector tlp3628 ...)
+             (and (? test-struct? tlp3640)
+                  (app test-struct-a _)
+                  (app
+                   test-struct-b
+                   (struct test-struct (tlp3629 tlp3630 tlp3631 tlp3632)))
+                  (app test-struct-c (box (list tlp3634 tlp3635 tlp3636)))
+                  (app test-struct-d (and tlp3637 tlp3638)))
+             tlp3641)
+           (vector
+             tlp3642
+             (vector tlp3643 ...)
+             (and (? test-struct? tlp3644)
+                  (app test-struct-a _)
+                  (app
+                   test-struct-b
+                   (struct test-struct (tlp3645 tlp3646 tlp3647 tlp3648)))
+                  (app test-struct-c (box (list tlp3649 tlp3650 tlp3651)))
+                  (app test-struct-d (and tlp3652 tlp3653)))
+             tlp3654))
+      tlp3655)
+     (list
+      tlp3656
+      #\c
+      tlp3657
+      (list-rest (list tlp3658 __3) #\d (list tlp3659 ___) #\c))
+     (list tlp3660 _ (list) _)
+     (list 'these tlp3661 (list) tlp3662)))
+  ((no-hueristics 71 218)
+   (no-hueristics-size 71 218)
+   (rel-1-5 71 160)
+   (rel-1-5-size 71 217)
+   (inverse-in 71 181)
+   (inverse-in-size 71 170)
+   (tag-negate 71 158)
+   (tag-negate-size 71 189)
+   (new-coupling 71 175)
+   (new-coupling-size 71 156)
+   (member-up-count 71 221)
+   (member-up-count-size 71 158)
+   (memoize-up-count 71 160)
+   (memoize-up-count-size 71 199)))
+ ((pattern
+    (list
+     (list
+      tlp3534
+      tlp3535
+      (list-rest tlp3536 _ tlp3537 'symbols)
+      (or (or tlp3538 tlp3538) (or tlp3538 tlp3538)))
+     (list
+      (list tlp3539 __3)
+      tlp3540
+      (and (? number? tlp3541) (? even? tlp3542))
+      (and (? number? tlp3543) (? even? tlp3544)))
+     (list
+      (or tlp3545 tlp3545)
+      (or #f #f)
+      (struct
+        test-struct
+        (tlp3546 (list tlp3547 ..3) (list tlp3548 ___) tlp3549))
+      (list-rest (vector tlp3551 ...) 7 #f #\b))
+     (list
+      (box
+       (list
+        (box
+         (list
+          (or tlp3552 tlp3552)
+          tlp3553
+          (and (? number? tlp3554) (? even? tlp3555))))
+        tlp3556
+        (list tlp3557 ___)))
+      (list
+       (list
+        (list-rest tlp3558 tlp3559 tlp3560 #\b)
+        (or (vector tlp3561 ___) (vector tlp3561 ___))
+        (list-rest tlp3562 tlp3563 tlp3564 #\d)
+        tlp3565)
+       (and (? test-struct? tlp3579)
+            (app
+             test-struct-a
+             (struct test-struct (tlp3566 tlp3567 tlp3568 tlp3569)))
+            (app
+             test-struct-b
+             (or (and (? number? tlp3571) (? even? tlp3572))
+                 (and (? number? tlp3571) (? even? tlp3572))))
+            (app
+             test-struct-c
+             (struct test-struct (tlp3573 tlp3574 tlp3575 tlp3576)))
+            (app test-struct-d (not (not 9))))
+       (and tlp3580 tlp3581)
+       (and (? number? tlp3582) (? even? tlp3583)))
+      (vector tlp3584 ___)
+      (or tlp3585 tlp3585))
+     (list
+      (vector tlp3586 ...)
+      #f
+      (list
+       (and (? test-struct? tlp3596)
+            (app test-struct-a (list tlp3587 ...))
+            (app test-struct-b (list-rest tlp3588 tlp3589 tlp3590 #\c))
+            (app test-struct-c (vector tlp3591 tlp3592 tlp3593 tlp3594))
+            (app test-struct-d (not (not #\b))))
+       (struct
+         test-struct
+         (#\a (and (? number? tlp3597) (? even? tlp3598)) _ tlp3599))
+       (list-rest
+         (and (? test-struct? tlp3606)
+              (app test-struct-a tlp3601)
+              (app test-struct-b tlp3602)
+              (app test-struct-c tlp3603)
+              (app test-struct-d tlp3604))
+         (list tlp3607 __3)
+         (and (vector tlp3608 ...) (vector tlp3609 ...))
+         6)
+       '(+ 1 2))
+      #\b)))
+  ((no-hueristics 141 643)
+   (no-hueristics-size 141 638)
+   (rel-1-5 141 689)
+   (rel-1-5-size 141 653)
+   (inverse-in 141 787)
+   (inverse-in-size 141 714)
+   (tag-negate 141 657)
+   (tag-negate-size 141 882)
+   (new-coupling 141 733)
+   (new-coupling-size 141 661)
+   (member-up-count 141 645)
+   (member-up-count-size 141 846)
+   (memoize-up-count 141 655)
+   (memoize-up-count-size 141 745)))
+ ((pattern
+    (list
+     (list
+      _
+      (list tlp3413 ...)
+      (list
+       (box
+        (list
+         (vector tlp3414 ___)
+         (struct test-struct (tlp3415 tlp3416 tlp3417 tlp3418))
+         (and (? number? tlp3420) (? even? tlp3421))))
+       (list-rest
+         (not (not #\b))
+         (list-rest tlp3422 tlp3423 tlp3424 #\a)
+         (list tlp3425 tlp3426 tlp3427 tlp3428)
+         #\c)
+       (list tlp3429 ...)
+       tlp3430)
+      tlp3431)
+     (list tlp3432 tlp3433 (list tlp3434 ...) (list))
+     (list
+      (list tlp3435 ...)
+      (and (? test-struct? tlp3445)
+           (app test-struct-a (list tlp3436 ..3))
+           (app test-struct-b (list))
+           (app
+            test-struct-c
+            (list-rest
+              (list tlp3437 ___)
+              tlp3438
+              (vector tlp3439 tlp3440 tlp3441 tlp3442)
+              5))
+           (app test-struct-d (vector tlp3443 ___)))
+      (vector
+        (and (and (? test-struct? tlp3456)
+                  (app test-struct-a (list))
+                  (app
+                   test-struct-b
+                   (list-rest tlp3446 tlp3447 tlp3448 tlp3449))
+                  (app test-struct-c (box (list tlp3450 tlp3451 tlp3452)))
+                  (app test-struct-d (and tlp3453 tlp3454)))
+             (and (? test-struct? tlp3457)
+                  (app test-struct-a (list))
+                  (app
+                   test-struct-b
+                   (list-rest tlp3458 tlp3459 tlp3460 tlp3461))
+                  (app test-struct-c (box (list tlp3462 tlp3463 tlp3464)))
+                  (app test-struct-d (and tlp3465 tlp3466))))
+        tlp3467
+        #t
+        (box (list (not (not 2)) (box (list tlp3468 tlp3469 tlp3470)) _)))
+      (and (? test-struct? tlp3475)
+           (app
+            test-struct-a
+            (list-rest _ (or tlp3471 tlp3471) (not (not #f)) #\d))
+           (app test-struct-b tlp3472)
+           (app test-struct-c (list))
+           (app test-struct-d (list tlp3473 ...))))
+     (list
+      (struct
+        test-struct
+        ((and (? number? tlp3476) (? even? tlp3477))
+         (list
+          (or (and (? test-struct? tlp3483)
+                   (app test-struct-a tlp3478)
+                   (app test-struct-b tlp3479)
+                   (app test-struct-c tlp3480)
+                   (app test-struct-d tlp3481))
+              (and (? test-struct? tlp3483)
+                   (app test-struct-a tlp3478)
+                   (app test-struct-b tlp3479)
+                   (app test-struct-c tlp3480)
+                   (app test-struct-d tlp3481)))
+          (vector tlp3484 tlp3485 tlp3486 tlp3487)
+          (box (list tlp3488 tlp3489 tlp3490))
+          '(+ 4 5))
+         (vector tlp3491 ___)
+         tlp3492))
+      (list tlp3494 ..3)
+      (list tlp3495 ..3)
+      tlp3496)
+     (list
+      (list
+       (box
+        (list
+         (list tlp3497 tlp3498 tlp3499 tlp3500)
+         (and _ _)
+         (and (? test-struct? tlp3506)
+              (app test-struct-a tlp3501)
+              (app test-struct-b tlp3502)
+              (app test-struct-c tlp3503)
+              (app test-struct-d tlp3504))))
+       (list tlp3507 ...)
+       (and (? test-struct? tlp3513)
+            (app test-struct-a (box (list tlp3508 tlp3509 tlp3510)))
+            (app test-struct-b (list))
+            (app test-struct-c _)
+            (app test-struct-d (list tlp3511 ___)))
+       (or (and (struct test-struct (tlp3514 tlp3515 tlp3516 tlp3517))
+                (struct test-struct (tlp3519 tlp3520 tlp3521 tlp3522)))
+           (and (struct test-struct (tlp3514 tlp3515 tlp3516 tlp3517))
+                (struct test-struct (tlp3519 tlp3520 tlp3521 tlp3522)))))
+      (list
+       (not (not 9))
+       #f
+       '(+ 4 5)
+       (box
+        (list
+         (and (? test-struct? tlp3528)
+              (app test-struct-a tlp3523)
+              (app test-struct-b tlp3524)
+              (app test-struct-c tlp3525)
+              (app test-struct-d tlp3526))
+         (list tlp3529 __3)
+         (vector tlp3530 tlp3531 tlp3532 tlp3533))))
+      (not (not #\d))
+      9)))
+  ((no-hueristics 180 1127)
+   (no-hueristics-size 180 1131)
+   (rel-1-5 180 1094)
+   (rel-1-5-size 180 1129)
+   (inverse-in 180 1231)
+   (inverse-in-size 180 1132)
+   (tag-negate 180 1154)
+   (tag-negate-size 180 1435)
+   (new-coupling 180 1227)
+   (new-coupling-size 180 1143)
+   (member-up-count 180 1087)
+   (member-up-count-size 180 1154)
+   (memoize-up-count 180 1141)
+   (memoize-up-count-size 180 1144)))
+ ((pattern
+    (list
+     (vector tlp3401 ___)
+     '(+ 1 2)
+     (vector
+       _
+       '(+ 1 2)
+       (and (box
+             (list (list tlp3402 tlp3403 tlp3404 tlp3405) tlp3406 '(+ 1 2)))
+            (box
+             (list (list tlp3407 tlp3408 tlp3409 tlp3410) tlp3411 '(+ 1 2))))
+       (list tlp3412 ..3))
+     _))
+  ((no-hueristics 25 26)
+   (no-hueristics-size 25 27)
+   (rel-1-5 25 82)
+   (rel-1-5-size 25 28)
+   (inverse-in 25 117)
+   (inverse-in-size 25 26)
+   (tag-negate 25 122)
+   (tag-negate-size 25 144)
+   (new-coupling 25 27)
+   (new-coupling-size 25 27)
+   (member-up-count 25 26)
+   (member-up-count-size 25 26)
+   (memoize-up-count 25 27)
+   (memoize-up-count-size 25 26)))
+ ((pattern
+    (list
+     _
+     (vector
+       (list-rest
+         (list)
+         (and (vector tlp3379 tlp3380 tlp3381 tlp3382)
+              (vector tlp3383 tlp3384 tlp3385 tlp3386))
+         (list tlp3387 ..3)
+         3)
+       (list
+        (list-rest tlp3388 tlp3389 tlp3390 #\a)
+        (or (list tlp3391 ..3) (list tlp3391 ..3))
+        _
+        (struct test-struct (tlp3392 tlp3393 tlp3394 tlp3395)))
+       (and (? number? tlp3397) (? even? tlp3398))
+       tlp3399)
+     tlp3400
+     (list)))
+  ((no-hueristics 32 34)
+   (no-hueristics-size 32 34)
+   (rel-1-5 32 34)
+   (rel-1-5-size 32 34)
+   (inverse-in 32 33)
+   (inverse-in-size 32 36)
+   (tag-negate 32 34)
+   (tag-negate-size 32 34)
+   (new-coupling 32 35)
+   (new-coupling-size 32 34)
+   (member-up-count 32 39)
+   (member-up-count-size 32 34)
+   (memoize-up-count 32 35)
+   (memoize-up-count-size 32 34)))
+ ((pattern (list (and tlp3376 tlp3377) #\a (list) (vector tlp3378 ...)))
+  ((no-hueristics 10 5)
+   (no-hueristics-size 10 6)
+   (rel-1-5 10 5)
+   (rel-1-5-size 10 5)
+   (inverse-in 10 5)
+   (inverse-in-size 10 6)
+   (tag-negate 10 6)
+   (tag-negate-size 10 5)
+   (new-coupling 10 5)
+   (new-coupling-size 10 6)
+   (member-up-count 10 5)
+   (member-up-count-size 10 5)
+   (memoize-up-count 10 6)
+   (memoize-up-count-size 10 5)))
+ ((pattern
+    (list
+     (list-rest (and (list tlp3343 ...) (list tlp3344 ...)) (list) tlp3345 #\a)
+     (list-rest (not (not #t)) _ _ #f)
+     #\a
+     (vector
+       _
+       (or (list
+            _
+            tlp3346
+            (list tlp3347 tlp3348 tlp3349 tlp3350)
+            (and (? test-struct? tlp3356)
+                 (app test-struct-a tlp3351)
+                 (app test-struct-b tlp3352)
+                 (app test-struct-c tlp3353)
+                 (app test-struct-d tlp3354)))
+           (list
+            _
+            tlp3346
+            (list tlp3347 tlp3348 tlp3349 tlp3350)
+            (and (? test-struct? tlp3356)
+                 (app test-struct-a tlp3351)
+                 (app test-struct-b tlp3352)
+                 (app test-struct-c tlp3353)
+                 (app test-struct-d tlp3354))))
+       (box
+        (list
+         (vector tlp3357 tlp3358 tlp3359 tlp3360)
+         #\d
+         (and (? number? tlp3361) (? even? tlp3362))))
+       (vector
+         (struct test-struct (tlp3363 tlp3364 tlp3365 tlp3366))
+         (struct test-struct (tlp3368 tlp3369 tlp3370 tlp3371))
+         (and (? number? tlp3373) (? even? tlp3374))
+         tlp3375))))
+  ((no-hueristics 47 160)
+   (no-hueristics-size 47 72)
+   (rel-1-5 47 71)
+   (rel-1-5-size 47 125)
+   (inverse-in 47 179)
+   (inverse-in-size 47 73)
+   (tag-negate 47 162)
+   (tag-negate-size 47 214)
+   (new-coupling 47 68)
+   (new-coupling-size 47 70)
+   (member-up-count 47 130)
+   (member-up-count-size 47 71)
+   (memoize-up-count 47 69)
+   (memoize-up-count-size 47 128)))
+ ((pattern
+    (list
+     #\d
+     (list (not (not '(+ 4 5))) tlp3332 (not (not #f)) #t)
+     (box
+      (list
+       tlp3333
+       (not (not 7))
+       (list-rest
+         (vector tlp3334 tlp3335 tlp3336 tlp3337)
+         (box (list tlp3338 tlp3339 tlp3340))
+         tlp3341
+         9)))
+     (or (list tlp3342 ___) (list tlp3342 ___))))
+  ((no-hueristics 33 34)
+   (no-hueristics-size 33 88)
+   (rel-1-5 33 33)
+   (rel-1-5-size 33 34)
+   (inverse-in 33 139)
+   (inverse-in-size 33 131)
+   (tag-negate 33 124)
+   (tag-negate-size 33 123)
+   (new-coupling 33 34)
+   (new-coupling-size 33 34)
+   (member-up-count 33 36)
+   (member-up-count-size 33 91)
+   (memoize-up-count 33 35)
+   (memoize-up-count-size 33 35)))
+ ((pattern
+    (list
+     (list
+      (vector tlp3219 ...)
+      (vector tlp3220 ...)
+      (vector tlp3221 ___)
+      (list))
+     (list 'are tlp3222 #\a 9)
+     (list
+      tlp3223
+      (list
+       (list-rest
+         #\b
+         (struct test-struct (tlp3224 tlp3225 tlp3226 tlp3227))
+         #f
+         'these)
+       (list)
+       (list-rest
+         (vector tlp3229 ...)
+         (or (and (? test-struct? tlp3235)
+                  (app test-struct-a tlp3230)
+                  (app test-struct-b tlp3231)
+                  (app test-struct-c tlp3232)
+                  (app test-struct-d tlp3233))
+             (and (? test-struct? tlp3235)
+                  (app test-struct-a tlp3230)
+                  (app test-struct-b tlp3231)
+                  (app test-struct-c tlp3232)
+                  (app test-struct-d tlp3233)))
+         (vector tlp3236 ___)
+         5)
+       (list))
+      (list tlp3237 ..3)
+      (and (? test-struct? tlp3240)
+           (app test-struct-a (or (list) (list)))
+           (app test-struct-b (vector tlp3238 ...))
+           (app test-struct-c (not (not #\c)))
+           (app test-struct-d #\b)))
+     (list
+      (list tlp3241 ___)
+      (list)
+      (list
+       (and (and (? test-struct? tlp3253)
+                 (app
+                  test-struct-a
+                  (list-rest tlp3242 tlp3243 tlp3244 tlp3245))
+                 (app test-struct-b (vector tlp3246 tlp3247 tlp3248 tlp3249))
+                 (app
+                  test-struct-c
+                  (and (? number? tlp3250) (? even? tlp3251)))
+                 (app test-struct-d _))
+            (and (? test-struct? tlp3254)
+                 (app
+                  test-struct-a
+                  (list-rest tlp3255 tlp3256 tlp3257 tlp3258))
+                 (app test-struct-b (vector tlp3259 tlp3260 tlp3261 tlp3262))
+                 (app
+                  test-struct-c
+                  (and (? number? tlp3263) (? even? tlp3264)))
+                 (app test-struct-d _)))
+       (vector
+         #\a
+         (or 'symbols 'symbols)
+         (vector tlp3265 tlp3266 tlp3267 tlp3268)
+         (box (list tlp3269 tlp3270 tlp3271)))
+       (and (? number? tlp3272) (? even? tlp3273))
+       (list tlp3274 ..3))
+      tlp3275)
+     (list
+      (list-rest
+        tlp3276
+        (struct
+          test-struct
+          (tlp3277
+            (and (vector tlp3278 tlp3279 tlp3280 tlp3281)
+                 (vector tlp3282 tlp3283 tlp3284 tlp3285))
+            (and (not (not #t)) (not (not #t)))
+            tlp3286))
+        (box (list (list tlp3288 ___) (list tlp3289 __3) tlp3290))
+        #\b)
+      (list
+       (or (list) (list))
+       (and (? test-struct? tlp3298)
+            (app test-struct-a _)
+            (app test-struct-b tlp3291)
+            (app test-struct-c (vector tlp3292 ...))
+            (app test-struct-d (vector tlp3293 tlp3294 tlp3295 tlp3296)))
+       tlp3299
+       (and (? test-struct? tlp3313)
+            (app test-struct-a (box (list tlp3300 tlp3301 tlp3302)))
+            (app
+             test-struct-b
+             (struct test-struct (tlp3303 tlp3304 tlp3305 tlp3306)))
+            (app
+             test-struct-c
+             (or (list tlp3308 tlp3309 tlp3310 tlp3311)
+                 (list tlp3308 tlp3309 tlp3310 tlp3311)))
+            (app test-struct-d _)))
+      (box
+       (list
+        (and (? test-struct? tlp3323)
+             (app test-struct-a (list tlp3314 ...))
+             (app test-struct-b (list-rest tlp3315 tlp3316 tlp3317 #\a))
+             (app test-struct-c (vector tlp3318 ___))
+             (app test-struct-d (box (list tlp3319 tlp3320 tlp3321))))
+        (box (list (list tlp3324 __3) (vector tlp3325 ___) (list tlp3326 ___)))
+        (list
+         (list tlp3327 ...)
+         tlp3328
+         (list tlp3329 ...)
+         (list tlp3330 __3))))
+      (list tlp3331 ___))))
+  ((no-hueristics 180 1269)
+   (no-hueristics-size 180 1216)
+   (rel-1-5 180 1206)
+   (rel-1-5-size 180 1175)
+   (inverse-in 180 1336)
+   (inverse-in-size 180 1286)
+   (tag-negate 180 1506)
+   (tag-negate-size 180 1690)
+   (new-coupling 180 1221)
+   (new-coupling-size 180 1266)
+   (member-up-count 180 1113)
+   (member-up-count-size 180 1143)
+   (memoize-up-count 180 1211)
+   (memoize-up-count-size 180 1362)))
+ ((pattern
+    (list
+     (list
+      (and (? number? tlp3212) (? even? tlp3213))
+      (and (? number? tlp3214) (? even? tlp3215))
+      (and (list tlp3216 ___) (list tlp3217 ___))
+      tlp3218)))
+  ((no-hueristics 13 9)
+   (no-hueristics-size 13 64)
+   (rel-1-5 13 9)
+   (rel-1-5-size 13 9)
+   (inverse-in 13 64)
+   (inverse-in-size 13 9)
+   (tag-negate 13 9)
+   (tag-negate-size 13 63)
+   (new-coupling 13 8)
+   (new-coupling-size 13 8)
+   (member-up-count 13 63)
+   (member-up-count-size 13 10)
+   (memoize-up-count 13 8)
+   (memoize-up-count-size 13 10)))
+ ((pattern (list (and (list) (list)) tlp3210 tlp3211 _))
+  ((no-hueristics 7 3)
+   (no-hueristics-size 7 4)
+   (rel-1-5 7 3)
+   (rel-1-5-size 7 4)
+   (inverse-in 7 3)
+   (inverse-in-size 7 4)
+   (tag-negate 7 4)
+   (tag-negate-size 7 4)
+   (new-coupling 7 3)
+   (new-coupling-size 7 4)
+   (member-up-count 7 3)
+   (member-up-count-size 7 5)
+   (memoize-up-count 7 4)
+   (memoize-up-count-size 7 5)))
+ ((pattern
+    (list
+     (list
+      (list (and tlp3202 tlp3203) (list tlp3204 ___) tlp3205 tlp3206)
+      tlp3207
+      tlp3208
+      tlp3209)))
+  ((no-hueristics 14 9)
+   (no-hueristics-size 14 9)
+   (rel-1-5 14 9)
+   (rel-1-5-size 14 9)
+   (inverse-in 14 9)
+   (inverse-in-size 14 9)
+   (tag-negate 14 71)
+   (tag-negate-size 14 9)
+   (new-coupling 14 10)
+   (new-coupling-size 14 47)
+   (member-up-count 14 9)
+   (member-up-count-size 14 9)
+   (memoize-up-count 14 9)
+   (memoize-up-count-size 14 10)))
+ ((pattern
+    (list
+     (and (and (? test-struct? tlp3158)
+               (app
+                test-struct-a
+                (box
+                 (list
+                  (list tlp3125 tlp3126 tlp3127 tlp3128)
+                  (list tlp3129 ___)
+                  (and (? test-struct? tlp3135)
+                       (app test-struct-a tlp3130)
+                       (app test-struct-b tlp3131)
+                       (app test-struct-c tlp3132)
+                       (app test-struct-d tlp3133)))))
+               (app
+                test-struct-b
+                (list-rest
+                  (list tlp3136 tlp3137 tlp3138 tlp3139)
+                  (and (? test-struct? tlp3145)
+                       (app test-struct-a tlp3140)
+                       (app test-struct-b tlp3141)
+                       (app test-struct-c tlp3142)
+                       (app test-struct-d tlp3143))
+                  (vector tlp3146 tlp3147 tlp3148 tlp3149)
+                  #\d))
+               (app test-struct-c (list tlp3150 __3))
+               (app
+                test-struct-d
+                (list
+                 #\b
+                 tlp3151
+                 (and (? number? tlp3152) (? even? tlp3153))
+                 (box (list tlp3154 tlp3155 tlp3156)))))
+          (and (? test-struct? tlp3159)
+               (app
+                test-struct-a
+                (box
+                 (list
+                  (list tlp3160 tlp3161 tlp3162 tlp3163)
+                  (list tlp3164 ___)
+                  (and (? test-struct? tlp3165)
+                       (app test-struct-a tlp3166)
+                       (app test-struct-b tlp3167)
+                       (app test-struct-c tlp3168)
+                       (app test-struct-d tlp3169)))))
+               (app
+                test-struct-b
+                (list-rest
+                  (list tlp3170 tlp3171 tlp3172 tlp3173)
+                  (and (? test-struct? tlp3174)
+                       (app test-struct-a tlp3175)
+                       (app test-struct-b tlp3176)
+                       (app test-struct-c tlp3177)
+                       (app test-struct-d tlp3178))
+                  (vector tlp3179 tlp3180 tlp3181 tlp3182)
+                  #\d))
+               (app test-struct-c (list tlp3183 __3))
+               (app
+                test-struct-d
+                (list
+                 #\b
+                 tlp3184
+                 (and (? number? tlp3185) (? even? tlp3186))
+                 (box (list tlp3187 tlp3188 tlp3189))))))
+     (not (not #\a))
+     (struct
+       test-struct
+       ((vector tlp3190 ...)
+        tlp3191
+        (and (? test-struct? tlp3198)
+             (app test-struct-a (list tlp3192 __3))
+             (app test-struct-b tlp3193)
+             (app test-struct-c (and tlp3194 tlp3195))
+             (app test-struct-d (list tlp3196 ...)))
+        tlp3199))
+     (list tlp3201 __3)))
+  ((no-hueristics 56 208)
+   (no-hueristics-size 56 207)
+   (rel-1-5 56 205)
+   (rel-1-5-size 56 269)
+   (inverse-in 56 215)
+   (inverse-in-size 56 215)
+   (tag-negate 56 218)
+   (tag-negate-size 56 253)
+   (new-coupling 56 208)
+   (new-coupling-size 56 206)
+   (member-up-count 56 154)
+   (member-up-count-size 56 217)
+   (memoize-up-count 56 211)
+   (memoize-up-count-size 56 293)))
+ ((pattern
+    (list
+     (list tlp3121 __3)
+     (list)
+     (list tlp3122 __3)
+     (and (? number? tlp3123) (? even? tlp3124))))
+  ((no-hueristics 13 6)
+   (no-hueristics-size 13 7)
+   (rel-1-5 13 7)
+   (rel-1-5-size 13 7)
+   (inverse-in 13 9)
+   (inverse-in-size 13 6)
+   (tag-negate 13 7)
+   (tag-negate-size 13 8)
+   (new-coupling 13 7)
+   (new-coupling-size 13 6)
+   (member-up-count 13 7)
+   (member-up-count-size 13 7)
+   (memoize-up-count 13 7)
+   (memoize-up-count-size 13 9)))
+ ((pattern (list get! b c))
+  ((no-hueristics 5 2)
+   (no-hueristics-size 5 3)
+   (rel-1-5 5 3)
+   (rel-1-5-size 5 3)
+   (inverse-in 5 3)
+   (inverse-in-size 5 3)
+   (tag-negate 5 4)
+   (tag-negate-size 5 2)
+   (new-coupling 5 2)
+   (new-coupling-size 5 2)
+   (member-up-count 5 2)
+   (member-up-count-size 5 2)
+   (memoize-up-count 5 3)
+   (memoize-up-count-size 5 3)))
+ ((pattern (list set! b c))
+  ((no-hueristics 5 3)
+   (no-hueristics-size 5 2)
+   (rel-1-5 5 3)
+   (rel-1-5-size 5 3)
+   (inverse-in 5 2)
+   (inverse-in-size 5 2)
+   (tag-negate 5 3)
+   (tag-negate-size 5 3)
+   (new-coupling 5 2)
+   (new-coupling-size 5 3)
+   (member-up-count 5 3)
+   (member-up-count-size 5 55)
+   (memoize-up-count 5 3)
+   (memoize-up-count-size 5 4)))
+ ((pattern (list ? b c))
+  ((no-hueristics 5 2)
+   (no-hueristics-size 5 2)
+   (rel-1-5 5 3)
+   (rel-1-5-size 5 2)
+   (inverse-in 5 2)
+   (inverse-in-size 5 3)
+   (tag-negate 5 3)
+   (tag-negate-size 5 2)
+   (new-coupling 5 3)
+   (new-coupling-size 5 4)
+   (member-up-count 5 3)
+   (member-up-count-size 5 3)
+   (memoize-up-count 5 3)
+   (memoize-up-count-size 5 4)))
+ ((pattern (list not b c))
+  ((no-hueristics 5 3)
+   (no-hueristics-size 5 3)
+   (rel-1-5 5 2)
+   (rel-1-5-size 5 3)
+   (inverse-in 5 3)
+   (inverse-in-size 5 3)
+   (tag-negate 5 3)
+   (tag-negate-size 5 3)
+   (new-coupling 5 2)
+   (new-coupling-size 5 3)
+   (member-up-count 5 3)
+   (member-up-count-size 5 3)
+   (memoize-up-count 5 3)
+   (memoize-up-count-size 5 3)))
+ ((pattern (list or b c))
+  ((no-hueristics 5 2)
+   (no-hueristics-size 5 3)
+   (rel-1-5 5 3)
+   (rel-1-5-size 5 3)
+   (inverse-in 5 3)
+   (inverse-in-size 5 3)
+   (tag-negate 5 3)
+   (tag-negate-size 5 2)
+   (new-coupling 5 2)
+   (new-coupling-size 5 3)
+   (member-up-count 5 3)
+   (member-up-count-size 5 2)
+   (memoize-up-count 5 3)
+   (memoize-up-count-size 5 3)))
+ ((pattern (list and b c))
+  ((no-hueristics 5 2)
+   (no-hueristics-size 5 2)
+   (rel-1-5 5 3)
+   (rel-1-5-size 5 2)
+   (inverse-in 5 3)
+   (inverse-in-size 5 3)
+   (tag-negate 5 3)
+   (tag-negate-size 5 3)
+   (new-coupling 5 6)
+   (new-coupling-size 5 3)
+   (member-up-count 5 3)
+   (member-up-count-size 5 2)
+   (memoize-up-count 5 3)
+   (memoize-up-count-size 5 3)))
+ ((pattern (list = b c))
+  ((no-hueristics 5 3)
+   (no-hueristics-size 5 3)
+   (rel-1-5 5 3)
+   (rel-1-5-size 5 2)
+   (inverse-in 5 3)
+   (inverse-in-size 5 2)
+   (tag-negate 5 3)
+   (tag-negate-size 5 3)
+   (new-coupling 5 3)
+   (new-coupling-size 5 3)
+   (member-up-count 5 3)
+   (member-up-count-size 5 3)
+   (memoize-up-count 5 3)
+   (memoize-up-count-size 5 4)))
+ ((pattern (list var b c))
+  ((no-hueristics 5 2)
+   (no-hueristics-size 5 2)
+   (rel-1-5 5 2)
+   (rel-1-5-size 5 3)
+   (inverse-in 5 3)
+   (inverse-in-size 5 3)
+   (tag-negate 5 3)
+   (tag-negate-size 5 2)
+   (new-coupling 5 3)
+   (new-coupling-size 5 4)
+   (member-up-count 5 2)
+   (member-up-count-size 5 3)
+   (memoize-up-count 5 55)
+   (memoize-up-count-size 5 4)))
+ ((pattern (list $ b c))
+  ((no-hueristics 5 2)
+   (no-hueristics-size 5 3)
+   (rel-1-5 5 3)
+   (rel-1-5-size 5 2)
+   (inverse-in 5 2)
+   (inverse-in-size 5 3)
+   (tag-negate 5 2)
+   (tag-negate-size 5 3)
+   (new-coupling 5 2)
+   (new-coupling-size 5 3)
+   (member-up-count 5 3)
+   (member-up-count-size 5 2)
+   (memoize-up-count 5 3)
+   (memoize-up-count-size 5 3)))
+ ((pattern (list (var unquote-splicing) b c))
+  ((no-hueristics 5 3)
+   (no-hueristics-size 5 3)
+   (rel-1-5 5 3)
+   (rel-1-5-size 5 3)
+   (inverse-in 5 5)
+   (inverse-in-size 5 3)
+   (tag-negate 5 2)
+   (tag-negate-size 5 3)
+   (new-coupling 5 3)
+   (new-coupling-size 5 4)
+   (member-up-count 5 3)
+   (member-up-count-size 5 3)
+   (memoize-up-count 5 3)
+   (memoize-up-count-size 5 3)))
+ ((pattern (list (var unquote) b c))
+  ((no-hueristics 5 3)
+   (no-hueristics-size 5 2)
+   (rel-1-5 5 3)
+   (rel-1-5-size 5 2)
+   (inverse-in 5 3)
+   (inverse-in-size 5 53)
+   (tag-negate 5 3)
+   (tag-negate-size 5 3)
+   (new-coupling 5 3)
+   (new-coupling-size 5 2)
+   (member-up-count 5 3)
+   (member-up-count-size 5 3)
+   (memoize-up-count 5 2)
+   (memoize-up-count-size 5 3)))
+ ((pattern (list (var quote) b c))
+  ((no-hueristics 5 2)
+   (no-hueristics-size 5 3)
+   (rel-1-5 5 3)
+   (rel-1-5-size 5 3)
+   (inverse-in 5 2)
+   (inverse-in-size 5 2)
+   (tag-negate 5 3)
+   (tag-negate-size 5 2)
+   (new-coupling 5 2)
+   (new-coupling-size 5 3)
+   (member-up-count 5 2)
+   (member-up-count-size 5 3)
+   (memoize-up-count 5 3)
+   (memoize-up-count-size 5 3)))
+ ((pattern (list (var quasiquote) b c))
+  ((no-hueristics 5 2)
+   (no-hueristics-size 5 3)
+   (rel-1-5 5 54)
+   (rel-1-5-size 5 2)
+   (inverse-in 5 53)
+   (inverse-in-size 5 3)
+   (tag-negate 5 2)
+   (tag-negate-size 5 2)
+   (new-coupling 5 3)
+   (new-coupling-size 5 3)
+   (member-up-count 5 2)
+   (member-up-count-size 5 3)
+   (memoize-up-count 5 3)
+   (memoize-up-count-size 5 3)))
+ ((pattern (list (var ..3) b c))
+  ((no-hueristics 5 2)
+   (no-hueristics-size 5 3)
+   (rel-1-5 5 3)
+   (rel-1-5-size 5 3)
+   (inverse-in 5 3)
+   (inverse-in-size 5 2)
+   (tag-negate 5 3)
+   (tag-negate-size 5 3)
+   (new-coupling 5 3)
+   (new-coupling-size 5 2)
+   (member-up-count 5 3)
+   (member-up-count-size 5 3)
+   (memoize-up-count 5 3)
+   (memoize-up-count-size 5 4)))
+ ((pattern (list (var _) b c))
+  ((no-hueristics 5 2)
+   (no-hueristics-size 5 2)
+   (rel-1-5 5 2)
+   (rel-1-5-size 5 2)
+   (inverse-in 5 2)
+   (inverse-in-size 5 3)
+   (tag-negate 5 3)
+   (tag-negate-size 5 2)
+   (new-coupling 5 3)
+   (new-coupling-size 5 3)
+   (member-up-count 5 5)
+   (member-up-count-size 5 3)
+   (memoize-up-count 5 2)
+   (memoize-up-count-size 5 3)))
+ ((pattern (list-rest (and 1 b) ... a (and c 4)))
+  ((no-hueristics 5 3)
+   (no-hueristics-size 5 4)
+   (rel-1-5 5 4)
+   (rel-1-5-size 5 4)
+   (inverse-in 5 3)
+   (inverse-in-size 5 3)
+   (tag-negate 5 4)
+   (tag-negate-size 5 4)
+   (new-coupling 5 3)
+   (new-coupling-size 5 5)
+   (member-up-count 5 4)
+   (member-up-count-size 5 3)
+   (memoize-up-count 5 3)
+   (memoize-up-count-size 5 4)))
+ ((pattern (list-rest (and 1 b) ... a))
+  ((no-hueristics 3 2)
+   (no-hueristics-size 3 3)
+   (rel-1-5 3 3)
+   (rel-1-5-size 3 3)
+   (inverse-in 3 3)
+   (inverse-in-size 3 2)
+   (tag-negate 3 2)
+   (tag-negate-size 3 3)
+   (new-coupling 3 2)
+   (new-coupling-size 3 2)
+   (member-up-count 3 3)
+   (member-up-count-size 3 3)
+   (memoize-up-count 3 2)
+   (memoize-up-count-size 3 2)))
+ ((pattern (list-rest 1 ... a))
+  ((no-hueristics 3 2)
+   (no-hueristics-size 3 2)
+   (rel-1-5 3 2)
+   (rel-1-5-size 3 55)
+   (inverse-in 3 2)
+   (inverse-in-size 3 2)
+   (tag-negate 3 2)
+   (tag-negate-size 3 1)
+   (new-coupling 3 1)
+   (new-coupling-size 3 2)
+   (member-up-count 3 2)
+   (member-up-count-size 3 2)
+   (memoize-up-count 3 2)
+   (memoize-up-count-size 3 2)))
+ ((pattern (list-no-order a b 1 c))
+  ((no-hueristics 3 4)
+   (no-hueristics-size 3 4)
+   (rel-1-5 3 4)
+   (rel-1-5-size 3 4)
+   (inverse-in 3 4)
+   (inverse-in-size 3 5)
+   (tag-negate 3 56)
+   (tag-negate-size 3 4)
+   (new-coupling 3 5)
+   (new-coupling-size 3 5)
+   (member-up-count 3 4)
+   (member-up-count-size 3 4)
+   (memoize-up-count 3 4)
+   (memoize-up-count-size 3 4)))
+ ((pattern (vector a b (and c (not 5)) ... d))
+  ((no-hueristics 4 4)
+   (no-hueristics-size 4 5)
+   (rel-1-5 4 4)
+   (rel-1-5-size 4 4)
+   (inverse-in 4 4)
+   (inverse-in-size 4 4)
+   (tag-negate 4 4)
+   (tag-negate-size 4 4)
+   (new-coupling 4 4)
+   (new-coupling-size 4 5)
+   (member-up-count 4 8)
+   (member-up-count-size 4 4)
+   (memoize-up-count 4 4)
+   (memoize-up-count-size 4 6)))
+ ((pattern (vector (vector _ _) ..3 a ...))
+  ((no-hueristics 5 4)
+   (no-hueristics-size 5 4)
+   (rel-1-5 5 4)
+   (rel-1-5-size 5 4)
+   (inverse-in 5 4)
+   (inverse-in-size 5 7)
+   (tag-negate 5 4)
+   (tag-negate-size 5 4)
+   (new-coupling 5 4)
+   (new-coupling-size 5 5)
+   (member-up-count 5 5)
+   (member-up-count-size 5 4)
+   (memoize-up-count 5 4)
+   (memoize-up-count-size 5 4)))
+ ((pattern
+    (vector (vector 1 ... a ...) ... 7 ...)
+    (vector (vector 1 ... a ...) ... 6 ...)
+    (vector (vector 1 ... a ...) ... 5 ...))
+  ((no-hueristics 37 95)
+   (no-hueristics-size 37 96)
+   (rel-1-5 37 44)
+   (rel-1-5-size 37 95)
+   (inverse-in 37 96)
+   (inverse-in-size 37 96)
+   (tag-negate 37 45)
+   (tag-negate-size 37 120)
+   (new-coupling 37 97)
+   (new-coupling-size 37 101)
+   (member-up-count 37 42)
+   (member-up-count-size 37 45)
+   (memoize-up-count 37 97)
+   (memoize-up-count-size 37 96)))
+ ((pattern (vector (vector 1 ... 2 ...) ... 5 ...))
+  ((no-hueristics 8 6)
+   (no-hueristics-size 8 6)
+   (rel-1-5 8 58)
+   (rel-1-5-size 8 7)
+   (inverse-in 8 6)
+   (inverse-in-size 8 6)
+   (tag-negate 8 8)
+   (tag-negate-size 8 6)
+   (new-coupling 8 7)
+   (new-coupling-size 8 7)
+   (member-up-count 8 59)
+   (member-up-count-size 8 7)
+   (memoize-up-count 8 7)
+   (memoize-up-count-size 8 6)))
+ ((pattern (vector (and (? odd?) a) ... 8 (and (? even?) b) ... 7 r ...))
+  ((no-hueristics 7 6)
+   (no-hueristics-size 7 6)
+   (rel-1-5 7 6)
+   (rel-1-5-size 7 7)
+   (inverse-in 7 7)
+   (inverse-in-size 7 6)
+   (tag-negate 7 7)
+   (tag-negate-size 7 7)
+   (new-coupling 7 6)
+   (new-coupling-size 7 6)
+   (member-up-count 7 7)
+   (member-up-count-size 7 6)
+   (memoize-up-count 7 8)
+   (memoize-up-count-size 7 6)))
+ ((pattern (list (list 1 ... 2 ...) ... 5 ...))
+  ((no-hueristics 12 6)
+   (no-hueristics-size 12 6)
+   (rel-1-5 12 6)
+   (rel-1-5-size 12 7)
+   (inverse-in 12 8)
+   (inverse-in-size 12 57)
+   (tag-negate 12 5)
+   (tag-negate-size 12 6)
+   (new-coupling 12 6)
+   (new-coupling-size 12 6)
+   (member-up-count 12 6)
+   (member-up-count-size 12 61)
+   (memoize-up-count 12 6)
+   (memoize-up-count-size 12 55)))
+ ((pattern (list (and (not 'in) a) ... (and (not 'is) b) ... c ...))
+  ((no-hueristics 6 6)
+   (no-hueristics-size 6 6)
+   (rel-1-5 6 6)
+   (rel-1-5-size 6 7)
+   (inverse-in 6 6)
+   (inverse-in-size 6 6)
+   (tag-negate 6 9)
+   (tag-negate-size 6 6)
+   (new-coupling 6 6)
+   (new-coupling-size 6 7)
+   (member-up-count 6 6)
+   (member-up-count-size 6 6)
+   (memoize-up-count 6 6)
+   (memoize-up-count-size 6 6)))
+ ((pattern (list _ ... 2 ...))
+  ((no-hueristics 5 3)
+   (no-hueristics-size 5 2)
+   (rel-1-5 5 3)
+   (rel-1-5-size 5 3)
+   (inverse-in 5 2)
+   (inverse-in-size 5 2)
+   (tag-negate 5 3)
+   (tag-negate-size 5 2)
+   (new-coupling 5 2)
+   (new-coupling-size 5 3)
+   (member-up-count 5 3)
+   (member-up-count-size 5 2)
+   (memoize-up-count 5 2)
+   (memoize-up-count-size 5 3)))
+ ((pattern (list a ... 2 ...))
+  ((no-hueristics 5 50)
+   (no-hueristics-size 5 3)
+   (rel-1-5 5 2)
+   (rel-1-5-size 5 2)
+   (inverse-in 5 3)
+   (inverse-in-size 5 2)
+   (tag-negate 5 3)
+   (tag-negate-size 5 3)
+   (new-coupling 5 2)
+   (new-coupling-size 5 3)
+   (member-up-count 5 2)
+   (member-up-count-size 5 3)
+   (memoize-up-count 5 3)
+   (memoize-up-count-size 5 3)))
+ ((pattern (list (and (not 2) a) ... 2 ...))
+  ((no-hueristics 6 3)
+   (no-hueristics-size 6 4)
+   (rel-1-5 6 3)
+   (rel-1-5-size 6 4)
+   (inverse-in 6 4)
+   (inverse-in-size 6 4)
+   (tag-negate 6 4)
+   (tag-negate-size 6 3)
+   (new-coupling 6 3)
+   (new-coupling-size 6 5)
+   (member-up-count 6 3)
+   (member-up-count-size 6 4)
+   (memoize-up-count 6 4)
+   (memoize-up-count-size 6 4)))
+ ((pattern (list 1 ... 2 ...))
+  ((no-hueristics 6 3)
+   (no-hueristics-size 6 2)
+   (rel-1-5 6 2)
+   (rel-1-5-size 6 60)
+   (inverse-in 6 2)
+   (inverse-in-size 6 3)
+   (tag-negate 6 2)
+   (tag-negate-size 6 2)
+   (new-coupling 6 3)
+   (new-coupling-size 6 2)
+   (member-up-count 6 2)
+   (member-up-count-size 6 3)
+   (memoize-up-count 6 53)
+   (memoize-up-count-size 6 2)))
+ ((pattern (list 1 ... 2 2 2 2))
+  ((no-hueristics 12 5)
+   (no-hueristics-size 12 6)
+   (rel-1-5 12 5)
+   (rel-1-5-size 12 6)
+   (inverse-in 12 5)
+   (inverse-in-size 12 4)
+   (tag-negate 12 62)
+   (tag-negate-size 12 5)
+   (new-coupling 12 56)
+   (new-coupling-size 12 6)
+   (member-up-count 12 5)
+   (member-up-count-size 12 6)
+   (memoize-up-count 12 4)
+   (memoize-up-count-size 12 6)))
+ ((pattern
+    (list (list 1 ... a ...) ... 7 ...)
+    (list (list 1 ... a ...) ... 6 ...)
+    (list (list 1 ... a ...) ... 5 ...))
+  ((no-hueristics 51 41)
+   (no-hueristics-size 51 88)
+   (rel-1-5 51 90)
+   (rel-1-5-size 51 46)
+   (inverse-in 51 90)
+   (inverse-in-size 51 89)
+   (tag-negate 51 47)
+   (tag-negate-size 51 113)
+   (new-coupling 51 39)
+   (new-coupling-size 51 51)
+   (member-up-count 51 43)
+   (member-up-count-size 51 47)
+   (memoize-up-count 51 41)
+   (memoize-up-count-size 51 93)))
+ ((pattern
+    (list (vector (list (vector (list (vector a b) ...) ...) ...) ...) ...))
+  ((no-hueristics 10 64)
+   (no-hueristics-size 10 16)
+   (rel-1-5 10 16)
+   (rel-1-5-size 10 78)
+   (inverse-in 10 17)
+   (inverse-in-size 10 16)
+   (tag-negate 10 72)
+   (tag-negate-size 10 16)
+   (new-coupling 10 20)
+   (new-coupling-size 10 20)
+   (member-up-count 10 17)
+   (member-up-count-size 10 18)
+   (memoize-up-count 10 17)
+   (memoize-up-count-size 10 17)))
+ ((pattern
+    (vector
+      (vector (vector (vector (vector (vector a b) ...) ...) ...) ...)
+      ...))
+  ((no-hueristics 13 17)
+   (no-hueristics-size 13 17)
+   (rel-1-5 13 16)
+   (rel-1-5-size 13 20)
+   (inverse-in 13 19)
+   (inverse-in-size 13 17)
+   (tag-negate 13 17)
+   (tag-negate-size 13 18)
+   (new-coupling 13 18)
+   (new-coupling-size 13 20)
+   (member-up-count 13 70)
+   (member-up-count-size 13 20)
+   (memoize-up-count 13 18)
+   (memoize-up-count-size 13 17)))
+ ((pattern (list (list (list (list (list (list a b) ...) ...) ...) ...) ...))
+  ((no-hueristics 9 18)
+   (no-hueristics-size 9 18)
+   (rel-1-5 9 17)
+   (rel-1-5-size 9 67)
+   (inverse-in 9 67)
+   (inverse-in-size 9 67)
+   (tag-negate 9 17)
+   (tag-negate-size 9 67)
+   (new-coupling 9 70)
+   (new-coupling-size 9 79)
+   (member-up-count 9 17)
+   (member-up-count-size 9 21)
+   (memoize-up-count 9 17)
+   (memoize-up-count-size 9 18)))
+ ((pattern
+    (list (vector (list (vector (list (vector _ ...) ...) ...) ...) ...) ...)
+    _)
+  ((no-hueristics 33 78)
+   (no-hueristics-size 33 76)
+   (rel-1-5 33 28)
+   (rel-1-5-size 33 250)
+   (inverse-in 33 28)
+   (inverse-in-size 33 29)
+   (tag-negate 33 80)
+   (tag-negate-size 33 27)
+   (new-coupling 33 28)
+   (new-coupling-size 33 33)
+   (member-up-count 33 28)
+   (member-up-count-size 33 33)
+   (memoize-up-count 33 28)
+   (memoize-up-count-size 33 77)))
+ ((pattern
+    (vector
+      (vector (vector (vector (vector (vector _ ...) ...) ...) ...) ...)
+      ...)
+    _)
+  ((no-hueristics 13 17)
+   (no-hueristics-size 13 18)
+   (rel-1-5 13 66)
+   (rel-1-5-size 13 85)
+   (inverse-in 13 65)
+   (inverse-in-size 13 66)
+   (tag-negate 13 16)
+   (tag-negate-size 13 18)
+   (new-coupling 13 16)
+   (new-coupling-size 13 32)
+   (member-up-count 13 16)
+   (member-up-count-size 13 19)
+   (memoize-up-count 13 16)
+   (memoize-up-count-size 13 17)))
+ ((pattern
+    (list (list (list (list (list (list _ ...) ...) ...) ...) ...) ...)
+    _)
+  ((no-hueristics 34 84)
+   (no-hueristics-size 34 83)
+   (rel-1-5 34 38)
+   (rel-1-5-size 34 216)
+   (inverse-in 34 35)
+   (inverse-in-size 34 34)
+   (tag-negate 34 92)
+   (tag-negate-size 34 83)
+   (new-coupling 34 87)
+   (new-coupling-size 34 90)
+   (member-up-count 34 34)
+   (member-up-count-size 34 42)
+   (memoize-up-count 34 87)
+   (memoize-up-count-size 34 86)))
+ ((pattern
+    (list (vector (list (vector (list (vector a ..2) ..2) ..2) ..2) ..2) ..2))
+  ((no-hueristics 13 18)
+   (no-hueristics-size 13 17)
+   (rel-1-5 13 18)
+   (rel-1-5-size 13 18)
+   (inverse-in 13 69)
+   (inverse-in-size 13 67)
+   (tag-negate 13 21)
+   (tag-negate-size 13 18)
+   (new-coupling 13 19)
+   (new-coupling-size 13 17)
+   (member-up-count 13 72)
+   (member-up-count-size 13 22)
+   (memoize-up-count 13 18)
+   (memoize-up-count-size 13 18)))
+ ((pattern
+    (vector
+      (vector (vector (vector (vector (vector a ..2) ..2) ..2) ..2) ..2)
+      ..2))
+  ((no-hueristics 13 18)
+   (no-hueristics-size 13 66)
+   (rel-1-5 13 65)
+   (rel-1-5-size 13 68)
+   (inverse-in 13 17)
+   (inverse-in-size 13 17)
+   (tag-negate 13 18)
+   (tag-negate-size 13 18)
+   (new-coupling 13 18)
+   (new-coupling-size 13 18)
+   (member-up-count 13 19)
+   (member-up-count-size 13 21)
+   (memoize-up-count 13 17)
+   (memoize-up-count-size 13 24)))
+ ((pattern (list (list (list (list (list (list a ..2) ..2) ..2) ..2) ..2) ..2))
+  ((no-hueristics 13 18)
+   (no-hueristics-size 13 17)
+   (rel-1-5 13 17)
+   (rel-1-5-size 13 17)
+   (inverse-in 13 17)
+   (inverse-in-size 13 17)
+   (tag-negate 13 66)
+   (tag-negate-size 13 17)
+   (new-coupling 13 67)
+   (new-coupling-size 13 17)
+   (member-up-count 13 20)
+   (member-up-count-size 13 20)
+   (memoize-up-count 13 17)
+   (memoize-up-count-size 13 17)))
+ ((pattern
+    (list (vector (list (vector (list (vector a ...) ...) ...) ...) ...) ...))
+  ((no-hueristics 10 63)
+   (no-hueristics-size 10 17)
+   (rel-1-5 10 16)
+   (rel-1-5-size 10 17)
+   (inverse-in 10 66)
+   (inverse-in-size 10 66)
+   (tag-negate 10 17)
+   (tag-negate-size 10 17)
+   (new-coupling 10 17)
+   (new-coupling-size 10 16)
+   (member-up-count 10 17)
+   (member-up-count-size 10 20)
+   (memoize-up-count 10 66)
+   (memoize-up-count-size 10 69)))
+ ((pattern
+    (vector
+      (vector (vector (vector (vector (vector a ...) ...) ...) ...) ...)
+      ...))
+  ((no-hueristics 13 16)
+   (no-hueristics-size 13 17)
+   (rel-1-5 13 17)
+   (rel-1-5-size 13 66)
+   (inverse-in 13 16)
+   (inverse-in-size 13 16)
+   (tag-negate 13 16)
+   (tag-negate-size 13 74)
+   (new-coupling 13 17)
+   (new-coupling-size 13 17)
+   (member-up-count 13 18)
+   (member-up-count-size 13 20)
+   (memoize-up-count 13 16)
+   (memoize-up-count-size 13 16)))
+ ((pattern (list (list (list (list (list (list a ...) ...) ...) ...) ...) ...))
+  ((no-hueristics 7 14)
+   (no-hueristics-size 7 14)
+   (rel-1-5 7 14)
+   (rel-1-5-size 7 14)
+   (inverse-in 7 16)
+   (inverse-in-size 7 14)
+   (tag-negate 7 66)
+   (tag-negate-size 7 14)
+   (new-coupling 7 14)
+   (new-coupling-size 7 15)
+   (member-up-count 7 84)
+   (member-up-count-size 7 74)
+   (memoize-up-count 7 15)
+   (memoize-up-count-size 7 17)))
+ ((pattern (list (list (list a ...) ...) ...))
+  ((no-hueristics 4 5)
+   (no-hueristics-size 4 5)
+   (rel-1-5 4 5)
+   (rel-1-5-size 4 5)
+   (inverse-in 4 5)
+   (inverse-in-size 4 5)
+   (tag-negate 4 5)
+   (tag-negate-size 4 5)
+   (new-coupling 4 5)
+   (new-coupling-size 4 5)
+   (member-up-count 4 5)
+   (member-up-count-size 4 6)
+   (memoize-up-count 4 4)
+   (memoize-up-count-size 4 55)))
+ ((pattern (vector (vector (vector a ...) ...) ...))
+  ((no-hueristics 7 52)
+   (no-hueristics-size 7 5)
+   (rel-1-5 7 5)
+   (rel-1-5-size 7 5)
+   (inverse-in 7 5)
+   (inverse-in-size 7 6)
+   (tag-negate 7 6)
+   (tag-negate-size 7 6)
+   (new-coupling 7 6)
+   (new-coupling-size 7 6)
+   (member-up-count 7 5)
+   (member-up-count-size 7 5)
+   (memoize-up-count 7 7)
+   (memoize-up-count-size 7 5)))
+ ((pattern (box (vector _ (get! get-it))))
+  ((no-hueristics 4 2)
+   (no-hueristics-size 4 2)
+   (rel-1-5 4 52)
+   (rel-1-5-size 4 2)
+   (inverse-in 4 49)
+   (inverse-in-size 4 2)
+   (tag-negate 4 2)
+   (tag-negate-size 4 2)
+   (new-coupling 4 2)
+   (new-coupling-size 4 2)
+   (member-up-count 4 2)
+   (member-up-count-size 4 2)
+   (memoize-up-count 4 2)
+   (memoize-up-count-size 4 3)))
+ ((pattern (box (list _ (get! get-it))))
+  ((no-hueristics 5 2)
+   (no-hueristics-size 5 2)
+   (rel-1-5 5 2)
+   (rel-1-5-size 5 3)
+   (inverse-in 5 3)
+   (inverse-in-size 5 3)
+   (tag-negate 5 2)
+   (tag-negate-size 5 3)
+   (new-coupling 5 2)
+   (new-coupling-size 5 3)
+   (member-up-count 5 2)
+   (member-up-count-size 5 2)
+   (memoize-up-count 5 3)
+   (memoize-up-count-size 5 2)))
+ ((pattern (box (get! get-it)))
+  ((no-hueristics 2 1)
+   (no-hueristics-size 2 1)
+   (rel-1-5 2 1)
+   (rel-1-5-size 2 1)
+   (inverse-in 2 2)
+   (inverse-in-size 2 1)
+   (tag-negate 2 1)
+   (tag-negate-size 2 1)
+   (new-coupling 2 2)
+   (new-coupling-size 2 1)
+   (member-up-count 2 1)
+   (member-up-count-size 2 1)
+   (memoize-up-count 2 1)
+   (memoize-up-count-size 2 2)))
+ ((pattern (vector (get! get-it) _))
+  ((no-hueristics 3 2)
+   (no-hueristics-size 3 2)
+   (rel-1-5 3 2)
+   (rel-1-5-size 3 52)
+   (inverse-in 3 1)
+   (inverse-in-size 3 2)
+   (tag-negate 3 2)
+   (tag-negate-size 3 2)
+   (new-coupling 3 2)
+   (new-coupling-size 3 2)
+   (member-up-count 3 2)
+   (member-up-count-size 3 2)
+   (memoize-up-count 3 2)
+   (memoize-up-count-size 3 2)))
+ ((pattern (vector _ (get! get-it)))
+  ((no-hueristics 3 2)
+   (no-hueristics-size 3 1)
+   (rel-1-5 3 2)
+   (rel-1-5-size 3 2)
+   (inverse-in 3 2)
+   (inverse-in-size 3 2)
+   (tag-negate 3 1)
+   (tag-negate-size 3 2)
+   (new-coupling 3 2)
+   (new-coupling-size 3 2)
+   (member-up-count 3 2)
+   (member-up-count-size 3 2)
+   (memoize-up-count 3 2)
+   (memoize-up-count-size 3 2)))
+ ((pattern (list-rest _ _ (list-rest _ _) (get! get-it)))
+  ((no-hueristics 5 3)
+   (no-hueristics-size 5 2)
+   (rel-1-5 5 3)
+   (rel-1-5-size 5 3)
+   (inverse-in 5 3)
+   (inverse-in-size 5 3)
+   (tag-negate 5 3)
+   (tag-negate-size 5 3)
+   (new-coupling 5 3)
+   (new-coupling-size 5 3)
+   (member-up-count 5 72)
+   (member-up-count-size 5 3)
+   (memoize-up-count 5 3)
+   (memoize-up-count-size 5 3)))
+ ((pattern (list-rest _ _ (list-rest _ (get! get-it)) _))
+  ((no-hueristics 5 2)
+   (no-hueristics-size 5 52)
+   (rel-1-5 5 3)
+   (rel-1-5-size 5 3)
+   (inverse-in 5 3)
+   (inverse-in-size 5 2)
+   (tag-negate 5 3)
+   (tag-negate-size 5 3)
+   (new-coupling 5 3)
+   (new-coupling-size 5 3)
+   (member-up-count 5 3)
+   (member-up-count-size 5 4)
+   (memoize-up-count 5 3)
+   (memoize-up-count-size 5 3)))
+ ((pattern (list-rest _ _ (list-rest (get! get-it) _) _))
+  ((no-hueristics 5 3)
+   (no-hueristics-size 5 2)
+   (rel-1-5 5 3)
+   (rel-1-5-size 5 3)
+   (inverse-in 5 3)
+   (inverse-in-size 5 3)
+   (tag-negate 5 3)
+   (tag-negate-size 5 3)
+   (new-coupling 5 3)
+   (new-coupling-size 5 2)
+   (member-up-count 5 3)
+   (member-up-count-size 5 3)
+   (memoize-up-count 5 3)
+   (memoize-up-count-size 5 3)))
+ ((pattern (list-rest _ (get! get-it) (list-rest _ _) _))
+  ((no-hueristics 5 2)
+   (no-hueristics-size 5 3)
+   (rel-1-5 5 2)
+   (rel-1-5-size 5 5)
+   (inverse-in 5 3)
+   (inverse-in-size 5 6)
+   (tag-negate 5 3)
+   (tag-negate-size 5 3)
+   (new-coupling 5 3)
+   (new-coupling-size 5 2)
+   (member-up-count 5 3)
+   (member-up-count-size 5 3)
+   (memoize-up-count 5 3)
+   (memoize-up-count-size 5 3)))
+ ((pattern (list-rest (get! get-it) _ (list-rest _ _) _))
+  ((no-hueristics 5 3)
+   (no-hueristics-size 5 3)
+   (rel-1-5 5 3)
+   (rel-1-5-size 5 4)
+   (inverse-in 5 3)
+   (inverse-in-size 5 3)
+   (tag-negate 5 3)
+   (tag-negate-size 5 3)
+   (new-coupling 5 3)
+   (new-coupling-size 5 3)
+   (member-up-count 5 2)
+   (member-up-count-size 5 3)
+   (memoize-up-count 5 3)
+   (memoize-up-count-size 5 3)))
+ ((pattern (list _ (get! get-it) (list _ _)))
+  ((no-hueristics 8 4)
+   (no-hueristics-size 8 3)
+   (rel-1-5 8 4)
+   (rel-1-5-size 8 5)
+   (inverse-in 8 4)
+   (inverse-in-size 8 3)
+   (tag-negate 8 4)
+   (tag-negate-size 8 4)
+   (new-coupling 8 4)
+   (new-coupling-size 8 3)
+   (member-up-count 8 4)
+   (member-up-count-size 8 4)
+   (memoize-up-count 8 4)
+   (memoize-up-count-size 8 4)))
+ ((pattern (list (get! get-it) _ (list _ _)))
+  ((no-hueristics 8 4)
+   (no-hueristics-size 8 4)
+   (rel-1-5 8 4)
+   (rel-1-5-size 8 4)
+   (inverse-in 8 4)
+   (inverse-in-size 8 4)
+   (tag-negate 8 3)
+   (tag-negate-size 8 4)
+   (new-coupling 8 4)
+   (new-coupling-size 8 3)
+   (member-up-count 8 4)
+   (member-up-count-size 8 4)
+   (memoize-up-count 8 3)
+   (memoize-up-count-size 8 4)))
+ ((pattern (list _ _ (list _ (get! get-it))))
+  ((no-hueristics 8 49)
+   (no-hueristics-size 8 4)
+   (rel-1-5 8 4)
+   (rel-1-5-size 8 4)
+   (inverse-in 8 51)
+   (inverse-in-size 8 3)
+   (tag-negate 8 3)
+   (tag-negate-size 8 3)
+   (new-coupling 8 4)
+   (new-coupling-size 8 4)
+   (member-up-count 8 4)
+   (member-up-count-size 8 3)
+   (memoize-up-count 8 3)
+   (memoize-up-count-size 8 4)))
+ ((pattern (list _ _ (list (get! get-it) _)))
+  ((no-hueristics 8 4)
+   (no-hueristics-size 8 4)
+   (rel-1-5 8 4)
+   (rel-1-5-size 8 57)
+   (inverse-in 8 4)
+   (inverse-in-size 8 4)
+   (tag-negate 8 4)
+   (tag-negate-size 8 4)
+   (new-coupling 8 3)
+   (new-coupling-size 8 3)
+   (member-up-count 8 3)
+   (member-up-count-size 8 4)
+   (memoize-up-count 8 3)
+   (memoize-up-count-size 8 4)))
+ ((pattern (box (vector _ (set! set-it))))
+  ((no-hueristics 4 3)
+   (no-hueristics-size 4 2)
+   (rel-1-5 4 2)
+   (rel-1-5-size 4 4)
+   (inverse-in 4 2)
+   (inverse-in-size 4 2)
+   (tag-negate 4 2)
+   (tag-negate-size 4 2)
+   (new-coupling 4 3)
+   (new-coupling-size 4 2)
+   (member-up-count 4 2)
+   (member-up-count-size 4 3)
+   (memoize-up-count 4 2)
+   (memoize-up-count-size 4 2)))
+ ((pattern (box (list _ (set! set-it))))
+  ((no-hueristics 5 2)
+   (no-hueristics-size 5 3)
+   (rel-1-5 5 3)
+   (rel-1-5-size 5 3)
+   (inverse-in 5 3)
+   (inverse-in-size 5 2)
+   (tag-negate 5 3)
+   (tag-negate-size 5 2)
+   (new-coupling 5 3)
+   (new-coupling-size 5 2)
+   (member-up-count 5 2)
+   (member-up-count-size 5 2)
+   (memoize-up-count 5 3)
+   (memoize-up-count-size 5 3)))
+ ((pattern (box (set! set-it)))
+  ((no-hueristics 2 1)
+   (no-hueristics-size 2 1)
+   (rel-1-5 2 1)
+   (rel-1-5-size 2 1)
+   (inverse-in 2 1)
+   (inverse-in-size 2 2)
+   (tag-negate 2 1)
+   (tag-negate-size 2 2)
+   (new-coupling 2 1)
+   (new-coupling-size 2 1)
+   (member-up-count 2 2)
+   (member-up-count-size 2 2)
+   (memoize-up-count 2 2)
+   (memoize-up-count-size 2 2)))
+ ((pattern (vector (set! set-it) _))
+  ((no-hueristics 3 1)
+   (no-hueristics-size 3 2)
+   (rel-1-5 3 2)
+   (rel-1-5-size 3 1)
+   (inverse-in 3 2)
+   (inverse-in-size 3 2)
+   (tag-negate 3 2)
+   (tag-negate-size 3 2)
+   (new-coupling 3 2)
+   (new-coupling-size 3 2)
+   (member-up-count 3 1)
+   (member-up-count-size 3 2)
+   (memoize-up-count 3 2)
+   (memoize-up-count-size 3 1)))
+ ((pattern (vector _ (set! set-it)))
+  ((no-hueristics 3 1)
+   (no-hueristics-size 3 1)
+   (rel-1-5 3 5)
+   (rel-1-5-size 3 2)
+   (inverse-in 3 1)
+   (inverse-in-size 3 2)
+   (tag-negate 3 2)
+   (tag-negate-size 3 1)
+   (new-coupling 3 2)
+   (new-coupling-size 3 2)
+   (member-up-count 3 2)
+   (member-up-count-size 3 1)
+   (memoize-up-count 3 2)
+   (memoize-up-count-size 3 2)))
+ ((pattern (list-rest _ _ (list-rest _ _) (set! set-it)))
+  ((no-hueristics 5 3)
+   (no-hueristics-size 5 3)
+   (rel-1-5 5 3)
+   (rel-1-5-size 5 4)
+   (inverse-in 5 2)
+   (inverse-in-size 5 3)
+   (tag-negate 5 3)
+   (tag-negate-size 5 3)
+   (new-coupling 5 3)
+   (new-coupling-size 5 3)
+   (member-up-count 5 3)
+   (member-up-count-size 5 3)
+   (memoize-up-count 5 3)
+   (memoize-up-count-size 5 2)))
+ ((pattern (list-rest _ _ (list-rest _ (set! set-it)) _))
+  ((no-hueristics 5 3)
+   (no-hueristics-size 5 3)
+   (rel-1-5 5 3)
+   (rel-1-5-size 5 3)
+   (inverse-in 5 3)
+   (inverse-in-size 5 3)
+   (tag-negate 5 2)
+   (tag-negate-size 5 3)
+   (new-coupling 5 3)
+   (new-coupling-size 5 3)
+   (member-up-count 5 3)
+   (member-up-count-size 5 3)
+   (memoize-up-count 5 3)
+   (memoize-up-count-size 5 3)))
+ ((pattern (list-rest _ _ (list-rest (set! set-it) _) _))
+  ((no-hueristics 5 3)
+   (no-hueristics-size 5 3)
+   (rel-1-5 5 2)
+   (rel-1-5-size 5 3)
+   (inverse-in 5 3)
+   (inverse-in-size 5 2)
+   (tag-negate 5 3)
+   (tag-negate-size 5 2)
+   (new-coupling 5 3)
+   (new-coupling-size 5 3)
+   (member-up-count 5 3)
+   (member-up-count-size 5 32)
+   (memoize-up-count 5 3)
+   (memoize-up-count-size 5 2)))
+ ((pattern (list-rest _ (set! set-it) (list-rest _ _) _))
+  ((no-hueristics 5 3)
+   (no-hueristics-size 5 3)
+   (rel-1-5 5 3)
+   (rel-1-5-size 5 2)
+   (inverse-in 5 3)
+   (inverse-in-size 5 2)
+   (tag-negate 5 3)
+   (tag-negate-size 5 3)
+   (new-coupling 5 3)
+   (new-coupling-size 5 3)
+   (member-up-count 5 70)
+   (member-up-count-size 5 3)
+   (memoize-up-count 5 2)
+   (memoize-up-count-size 5 3)))
+ ((pattern (list-rest (set! set-it) _ (list-rest _ _) _))
+  ((no-hueristics 5 3)
+   (no-hueristics-size 5 3)
+   (rel-1-5 5 3)
+   (rel-1-5-size 5 3)
+   (inverse-in 5 51)
+   (inverse-in-size 5 3)
+   (tag-negate 5 2)
+   (tag-negate-size 5 3)
+   (new-coupling 5 3)
+   (new-coupling-size 5 3)
+   (member-up-count 5 3)
+   (member-up-count-size 5 3)
+   (memoize-up-count 5 2)
+   (memoize-up-count-size 5 3)))
+ ((pattern (list _ (set! set-it) (list _ _)))
+  ((no-hueristics 8 3)
+   (no-hueristics-size 8 3)
+   (rel-1-5 8 3)
+   (rel-1-5-size 8 5)
+   (inverse-in 8 4)
+   (inverse-in-size 8 4)
+   (tag-negate 8 3)
+   (tag-negate-size 8 51)
+   (new-coupling 8 4)
+   (new-coupling-size 8 4)
+   (member-up-count 8 4)
+   (member-up-count-size 8 4)
+   (memoize-up-count 8 4)
+   (memoize-up-count-size 8 4)))
+ ((pattern (list (set! set-it) _ (list _ _)))
+  ((no-hueristics 8 4)
+   (no-hueristics-size 8 3)
+   (rel-1-5 8 3)
+   (rel-1-5-size 8 56)
+   (inverse-in 8 3)
+   (inverse-in-size 8 4)
+   (tag-negate 8 3)
+   (tag-negate-size 8 4)
+   (new-coupling 8 4)
+   (new-coupling-size 8 4)
+   (member-up-count 8 4)
+   (member-up-count-size 8 4)
+   (memoize-up-count 8 4)
+   (memoize-up-count-size 8 3)))
+ ((pattern (list _ _ (list _ (set! set-it))))
+  ((no-hueristics 8 4)
+   (no-hueristics-size 8 3)
+   (rel-1-5 8 3)
+   (rel-1-5-size 8 4)
+   (inverse-in 8 3)
+   (inverse-in-size 8 4)
+   (tag-negate 8 3)
+   (tag-negate-size 8 4)
+   (new-coupling 8 4)
+   (new-coupling-size 8 4)
+   (member-up-count 8 4)
+   (member-up-count-size 8 3)
+   (memoize-up-count 8 4)
+   (memoize-up-count-size 8 49)))
+ ((pattern (list _ _ (list (set! set-it) _)))
+  ((no-hueristics 8 4)
+   (no-hueristics 8 4)
+   (no-hueristics-size 8 4)
+   (no-hueristics-size 8 3)
+   (rel-1-5 8 4)
+   (rel-1-5 8 4)
+   (rel-1-5-size 8 4)
+   (rel-1-5-size 8 5)
+   (inverse-in 8 4)
+   (inverse-in 8 4)
+   (inverse-in-size 8 3)
+   (inverse-in-size 8 3)
+   (tag-negate 8 5)
+   (tag-negate 8 3)
+   (tag-negate-size 8 4)
+   (tag-negate-size 8 59)
+   (new-coupling 8 4)
+   (new-coupling 8 3)
+   (new-coupling-size 8 4)
+   (new-coupling-size 8 3)
+   (member-up-count 8 3)
+   (member-up-count 8 4)
+   (member-up-count-size 8 4)
+   (member-up-count-size 8 3)
+   (memoize-up-count 8 4)
+   (memoize-up-count 8 3)
+   (memoize-up-count-size 8 4)
+   (memoize-up-count-size 8 4)))
+ ((pattern (list (list _) ...))
+  ((no-hueristics 5 2)
+   (no-hueristics-size 5 2)
+   (rel-1-5 5 3)
+   (rel-1-5-size 5 2)
+   (inverse-in 5 2)
+   (inverse-in-size 5 3)
+   (tag-negate 5 3)
+   (tag-negate-size 5 2)
+   (new-coupling 5 3)
+   (new-coupling-size 5 2)
+   (member-up-count 5 2)
+   (member-up-count-size 5 3)
+   (memoize-up-count 5 2)
+   (memoize-up-count-size 5 3)))
+ ((pattern (list (list a b)))
+  ((no-hueristics 6 2)
+   (no-hueristics-size 6 3)
+   (rel-1-5 6 2)
+   (rel-1-5-size 6 2)
+   (inverse-in 6 2)
+   (inverse-in-size 6 2)
+   (tag-negate 6 2)
+   (tag-negate-size 6 3)
+   (new-coupling 6 3)
+   (new-coupling-size 6 2)
+   (member-up-count 6 3)
+   (member-up-count-size 6 3)
+   (memoize-up-count 6 2)
+   (memoize-up-count-size 6 2)))
+ ((pattern (list (list a b c) (list d e f)))
+  ((no-hueristics 12 6)
+   (no-hueristics-size 12 6)
+   (rel-1-5 12 7)
+   (rel-1-5-size 12 7)
+   (inverse-in 12 7)
+   (inverse-in-size 12 7)
+   (tag-negate 12 7)
+   (tag-negate-size 12 7)
+   (new-coupling 12 6)
+   (new-coupling-size 12 7)
+   (member-up-count 12 7)
+   (member-up-count-size 12 6)
+   (memoize-up-count 12 6)
+   (memoize-up-count-size 12 6)))
+ ((pattern (list a b c))
+  ((no-hueristics 5 2)
+   (no-hueristics-size 5 3)
+   (rel-1-5 5 2)
+   (rel-1-5-size 5 3)
+   (inverse-in 5 3)
+   (inverse-in-size 5 3)
+   (tag-negate 5 3)
+   (tag-negate-size 5 3)
+   (new-coupling 5 3)
+   (new-coupling-size 5 2)
+   (member-up-count 5 2)
+   (member-up-count-size 5 3)
+   (memoize-up-count 5 2)
+   (memoize-up-count-size 5 3)))
+ ((pattern
+    (list
+     (vector
+       #t
+       (list)
+       (list
+        tlp647
+        (or (box (list tlp648 tlp649 tlp650))
+            (box (list tlp648 tlp649 tlp650)))
+        (list tlp651 ...)
+        tlp652)
+       #f)
+     'these
+     tlp653
+     tlp654)
+    (list
+     (list-rest
+       (list tlp655 __3)
+       (list tlp656 ___)
+       (struct
+         test-struct
+         ((and (? test-struct? tlp662)
+               (app test-struct-a tlp657)
+               (app test-struct-b tlp658)
+               (app test-struct-c tlp659)
+               (app test-struct-d tlp660))
+          (list-rest tlp663 tlp664 tlp665 #\a)
+          (list-rest tlp666 tlp667 tlp668 #\b)
+          _))
+       'are)
+     (not (not 'symbols))
+     (and tlp670 tlp671)
+     _))
+  ((no-hueristics 45 44)
+   (no-hueristics-size 45 47)
+   (rel-1-5 105 112)
+   (rel-1-5-size 93 133)
+   (inverse-in 105 119)
+   (inverse-in-size 93 109)
+   (tag-negate 105 62)
+   (tag-negate-size 93 108)
+   (new-coupling 41 99)
+   (new-coupling-size 41 47)
+   (member-up-count 41 45)
+   (member-up-count-size 41 48)
+   (memoize-up-count 41 95)
+   (memoize-up-count-size 41 91)))
+ ((pattern
+    (list
+     (box
+      (list
+       (and (? number? tlp622) (? even? tlp623))
+       (list-rest
+         (list tlp624 ___)
+         (and (? number? tlp625) (? even? tlp626))
+         #\c
+         #\a)
+       tlp627))
+     tlp628
+     (list tlp629 ___)
+     #\c)
+    (list
+     tlp630
+     (or (vector
+           _
+           (vector tlp631 ...)
+           (vector
+             (list-rest tlp632 tlp633 tlp634 tlp635)
+             (and tlp636 tlp637)
+             #\b
+             (struct test-struct (tlp638 tlp639 tlp640 tlp641)))
+           (list))
+         (vector
+           _
+           (vector tlp631 ...)
+           (vector
+             (list-rest tlp632 tlp633 tlp634 tlp635)
+             (and tlp636 tlp637)
+             #\b
+             (struct test-struct (tlp638 tlp639 tlp640 tlp641)))
+           (list)))
+     #f
+     (and (? number? tlp643) (? even? tlp644))))
+  ((no-hueristics 632 1039)
+   (no-hueristics-size 631 1358)
+   (rel-1-5 299 649)
+   (rel-1-5-size 296 742)
+   (inverse-in 299 715)
+   (inverse-in-size 296 720)
+   (tag-negate 43 99)
+   (tag-negate-size 40 57)
+   (new-coupling 39 46)
+   (new-coupling-size 39 45)
+   (member-up-count 39 116)
+   (member-up-count-size 39 107)
+   (memoize-up-count 39 45)
+   (memoize-up-count-size 39 45)))
+ ((pattern
+    (list
+     (list
+      '(+ 4 5)
+      (vector tlp612 ___)
+      (list tlp613 __3)
+      (struct
+        test-struct
+        ((box (list tlp614 tlp615 tlp616)) tlp617 (list) (list))))
+     tlp619
+     (box (list 7 '(+ 4 (+ 1 1)) (list)))
+     _))
+  ((no-hueristics 32 69)
+   (no-hueristics-size 32 23)
+   (rel-1-5 32 24)
+   (rel-1-5-size 32 69)
+   (inverse-in 32 70)
+   (inverse-in-size 32 71)
+   (tag-negate 32 24)
+   (tag-negate-size 32 24)
+   (new-coupling 32 25)
+   (new-coupling-size 32 23)
+   (member-up-count 32 33)
+   (member-up-count-size 32 29)
+   (memoize-up-count 32 24)
+   (memoize-up-count-size 32 25)))
+ ((pattern (list tlp606 tlp607 (list tlp608 ___) tlp609))
+  ((no-hueristics 7 4)
+   (no-hueristics-size 7 4)
+   (rel-1-5 7 4)
+   (rel-1-5-size 7 4)
+   (inverse-in 7 4)
+   (inverse-in-size 7 4)
+   (tag-negate 7 5)
+   (tag-negate-size 7 50)
+   (new-coupling 7 4)
+   (new-coupling-size 7 4)
+   (member-up-count 7 4)
+   (member-up-count-size 7 4)
+   (memoize-up-count 7 5)
+   (memoize-up-count-size 7 4)))
+ ((pattern
+    (list
+     (and (? number? tlp581) (? even? tlp582))
+     tlp583
+     (box
+      (list
+       '(+ 4 5)
+       (box
+        (list
+         tlp584
+         (and (? number? tlp585) (? even? tlp586))
+         (or (or tlp587 tlp587) (or tlp587 tlp587))))
+       '(+ 4 5)))
+     (vector tlp588 ...))
+    (list
+     (and (? test-struct? tlp601)
+          (app test-struct-a #f)
+          (app test-struct-b (list tlp589 ...))
+          (app
+           test-struct-c
+           (list
+            (and (? number? tlp590) (? even? tlp591))
+            (vector tlp592 ...)
+            (and (? test-struct? tlp598)
+                 (app test-struct-a tlp593)
+                 (app test-struct-b tlp594)
+                 (app test-struct-c tlp595)
+                 (app test-struct-d tlp596))
+            (list tlp599 __3)))
+          (app test-struct-d '(+ 4 (+ 1 1))))
+     #f
+     (vector tlp602 ___)
+     (list tlp603 ___)))
+  ((no-hueristics 378 199)
+   (no-hueristics-size 303 198)
+   (rel-1-5 371 204)
+   (rel-1-5-size 302 246)
+   (inverse-in 371 208)
+   (inverse-in-size 302 209)
+   (tag-negate 371 250)
+   (tag-negate-size 302 218)
+   (new-coupling 309 187)
+   (new-coupling-size 249 197)
+   (member-up-count 309 207)
+   (member-up-count-size 249 230)
+   (memoize-up-count 309 185)
+   (memoize-up-count-size 249 194)))
+ ((pattern
+    (list
+     (not (not #f))
+     (box
+      (list
+       tlp556
+       (and (list tlp557 ___) (list tlp558 ___))
+       (and (? number? tlp559) (? even? tlp560))))
+     tlp561
+     (list))
+    (list
+     _
+     (list tlp562 ..3)
+     '(+ 4 (+ 1 1))
+     (vector
+       (list
+        (vector tlp563 tlp564 tlp565 tlp566)
+        tlp567
+        (box (list tlp568 tlp569 tlp570))
+        tlp571)
+       (and tlp572 tlp573)
+       (box
+        (list
+         (box (list tlp574 tlp575 tlp576))
+         (not (not #f))
+         (list-rest tlp577 tlp578 tlp579 #\b)))
+       #f)))
+  ((no-hueristics 52 60)
+   (no-hueristics-size 52 110)
+   (rel-1-5 83 75)
+   (rel-1-5-size 76 124)
+   (inverse-in 83 76)
+   (inverse-in-size 76 79)
+   (tag-negate 83 82)
+   (tag-negate-size 76 85)
+   (new-coupling 49 111)
+   (new-coupling-size 49 116)
+   (member-up-count 49 131)
+   (member-up-count-size 49 78)
+   (memoize-up-count 49 66)
+   (memoize-up-count-size 49 63)))
+ ((pattern
+    (list
+     tlp551
+     (struct test-struct ((vector tlp552 ...) 'are _ tlp553))
+     (list)
+     (list)))
+  ((no-hueristics 12 6)
+   (no-hueristics-size 12 6)
+   (rel-1-5 12 7)
+   (rel-1-5-size 12 7)
+   (inverse-in 12 7)
+   (inverse-in-size 12 53)
+   (tag-negate 12 8)
+   (tag-negate-size 12 6)
+   (new-coupling 12 6)
+   (new-coupling-size 12 10)
+   (member-up-count 12 7)
+   (member-up-count-size 12 8)
+   (memoize-up-count 12 7)
+   (memoize-up-count-size 12 8)))
+ ((pattern
+    (list
+     (box
+      (list
+       #\d
+       (box (list tlp509 'are _))
+       (struct
+         test-struct
+         ((struct test-struct (tlp510 tlp511 tlp512 tlp513))
+          (list-rest tlp515 tlp516 tlp517 #\a)
+          (list-rest tlp518 tlp519 tlp520 #\b)
+          tlp521))))
+     (vector tlp523 ___)
+     (and (? test-struct? tlp548)
+          (app test-struct-a 'are)
+          (app
+           test-struct-b
+           (list
+            tlp524
+            (list tlp525 ...)
+            (and (struct test-struct (tlp526 tlp527 tlp528 tlp529))
+                 (struct test-struct (tlp531 tlp532 tlp533 tlp534)))
+            tlp535))
+          (app test-struct-c (list tlp536 ...))
+          (app
+           test-struct-d
+           (and (? test-struct? tlp546)
+                (app
+                 test-struct-a
+                 (and (? test-struct? tlp542)
+                      (app test-struct-a tlp537)
+                      (app test-struct-b tlp538)
+                      (app test-struct-c tlp539)
+                      (app test-struct-d tlp540)))
+                (app test-struct-b (and (? number? tlp543) (? even? tlp544)))
+                (app test-struct-c (list))
+                (app test-struct-d (list)))))
+     tlp549))
+  ((no-hueristics 46 75)
+   (no-hueristics-size 46 75)
+   (rel-1-5 46 75)
+   (rel-1-5-size 46 79)
+   (inverse-in 46 77)
+   (inverse-in-size 46 80)
+   (tag-negate 46 139)
+   (tag-negate-size 46 85)
+   (new-coupling 46 77)
+   (new-coupling-size 46 79)
+   (member-up-count 46 76)
+   (member-up-count-size 46 78)
+   (memoize-up-count 46 126)
+   (memoize-up-count-size 46 77)))
+ ((pattern
+    (list
+     (list-rest tlp482 tlp483 (list) #\a)
+     (struct
+       test-struct
+       ((list-rest (list tlp484 ___) tlp485 (not (not #t)) 0)
+        (list)
+        tlp486
+        (not (not 7))))
+     (and (? number? tlp488) (? even? tlp489))
+     #\a)
+    (list
+     (list tlp490 ..3)
+     (box
+      (list
+       (and (? number? tlp491) (? even? tlp492))
+       (and (vector
+              (vector tlp493 ...)
+              tlp494
+              (vector tlp495 ...)
+              (box (list tlp496 tlp497 tlp498)))
+            (vector
+              (vector tlp499 ...)
+              tlp500
+              (vector tlp501 ...)
+              (box (list tlp502 tlp503 tlp504))))
+       (and (? number? tlp505) (? even? tlp506))))
+     tlp507
+     #\c))
+  ((no-hueristics 191 170)
+   (no-hueristics-size 191 258)
+   (rel-1-5 227 195)
+   (rel-1-5-size 216 274)
+   (inverse-in 227 503)
+   (inverse-in-size 217 193)
+   (tag-negate 131 153)
+   (tag-negate-size 121 149)
+   (new-coupling 131 137)
+   (new-coupling-size 121 140)
+   (member-up-count 48 55)
+   (member-up-count-size 48 103)
+   (memoize-up-count 48 58)
+   (memoize-up-count-size 48 103)))
+ ((pattern
+    (list
+     (and (list tlp443 ___) (list tlp444 ___))
+     (box
+      (list
+       (box (list #f tlp445 tlp446))
+       (vector
+         (list tlp447 __3)
+         (list)
+         5
+         (or (vector tlp448 ___) (vector tlp448 ___)))
+       (box
+        (list
+         (or (not (not '(+ 4 (+ 1 1)))) (not (not '(+ 4 (+ 1 1)))))
+         (list)
+         (list-rest tlp449 tlp450 tlp451 #f)))))
+     (vector
+       #\d
+       _
+       (box
+        (list
+         (vector tlp452 ___)
+         (and (list) (list))
+         (and (vector tlp453 ___) (vector tlp454 ___))))
+       (vector
+         (list tlp455 ...)
+         (and (? number? tlp456) (? even? tlp457))
+         (vector tlp458 tlp459 tlp460 tlp461)
+         #\b))
+     (list))
+    (list
+     (list tlp462 ..3)
+     tlp463
+     (list-rest
+       (list-rest
+         #\d
+         (list tlp464 tlp465 tlp466 tlp467)
+         (list-rest tlp468 tlp469 tlp470 'these)
+         #\b)
+       'symbols
+       (and (? test-struct? tlp478)
+            (app test-struct-a tlp471)
+            (app test-struct-b (list))
+            (app test-struct-c tlp472)
+            (app test-struct-d (vector tlp473 tlp474 tlp475 tlp476)))
+       7)
+     tlp479))
+  ((no-hueristics 793 809)
+   (no-hueristics-size 793 861)
+   (rel-1-5 759 733)
+   (rel-1-5-size 753 734)
+   (inverse-in 759 802)
+   (inverse-in-size 753 693)
+   (tag-negate 759 719)
+   (tag-negate-size 753 764)
+   (new-coupling 713 608)
+   (new-coupling-size 713 645)
+   (member-up-count 713 657)
+   (member-up-count-size 713 715)
+   (memoize-up-count 713 753)
+   (memoize-up-count-size 713 712)))
+ ((pattern
+    (list
+     (list tlp437 ..3)
+     _
+     (and (list tlp438 ..3) (list tlp439 ..3))
+     tlp440))
+  ((no-hueristics 10 48)
+   (no-hueristics-size 10 6)
+   (rel-1-5 10 6)
+   (rel-1-5-size 10 5)
+   (inverse-in 10 51)
+   (inverse-in-size 10 5)
+   (tag-negate 10 5)
+   (tag-negate-size 10 5)
+   (new-coupling 10 6)
+   (new-coupling-size 10 5)
+   (member-up-count 10 6)
+   (member-up-count-size 10 6)
+   (memoize-up-count 10 6)
+   (memoize-up-count-size 10 6)))
+ ((pattern
+    (list
+     (struct test-struct (tlp406 '(+ 4 (+ 1 1)) (list tlp407 __3) _))
+     _
+     (struct
+       test-struct
+       ((list-rest
+          (vector tlp409 tlp410 tlp411 tlp412)
+          (and (? test-struct? tlp418)
+               (app test-struct-a tlp413)
+               (app test-struct-b tlp414)
+               (app test-struct-c tlp415)
+               (app test-struct-d tlp416))
+          (list-rest tlp419 tlp420 tlp421 'these)
+          #f)
+        (list tlp422 ...)
+        (list)
+        (list tlp423 ...)))
+     (and (? test-struct? tlp434)
+          (app test-struct-a (list))
+          (app test-struct-b tlp425)
+          (app
+           test-struct-c
+           (and (? test-struct? tlp432)
+                (app test-struct-a 'these)
+                (app test-struct-b (and (not (not 3)) (not (not 3))))
+                (app test-struct-c (vector tlp426 tlp427 tlp428 tlp429))
+                (app test-struct-d (list tlp430 ___))))
+          (app test-struct-d 'are))))
+  ((no-hueristics 34 46)
+   (no-hueristics-size 34 45)
+   (rel-1-5 34 90)
+   (rel-1-5-size 34 48)
+   (inverse-in 34 47)
+   (inverse-in-size 34 91)
+   (tag-negate 34 45)
+   (tag-negate-size 34 45)
+   (new-coupling 34 97)
+   (new-coupling-size 34 91)
+   (member-up-count 34 45)
+   (member-up-count-size 34 51)
+   (memoize-up-count 34 48)
+   (memoize-up-count-size 34 47)))
+ ((pattern (list tlp401 tlp402 (list tlp403 ..3) (vector tlp404 ...)))
+  ((no-hueristics 10 5)
+   (no-hueristics-size 10 5)
+   (rel-1-5 10 5)
+   (rel-1-5-size 10 6)
+   (inverse-in 10 5)
+   (inverse-in-size 10 5)
+   (tag-negate 10 6)
+   (tag-negate-size 10 5)
+   (new-coupling 10 6)
+   (new-coupling-size 10 6)
+   (member-up-count 10 6)
+   (member-up-count-size 10 5)
+   (memoize-up-count 10 50)
+   (memoize-up-count-size 10 6)))
+ ((pattern
+    (list
+     tlp394
+     (struct
+       test-struct
+       ((and (? number? tlp395) (? even? tlp396))
+        (list)
+        tlp397
+        (vector tlp398 ___)))
+     _
+     (vector tlp400 ...)))
+  ((no-hueristics 14 50)
+   (no-hueristics-size 14 9)
+   (rel-1-5 14 9)
+   (rel-1-5-size 14 8)
+   (inverse-in 14 9)
+   (inverse-in-size 14 9)
+   (tag-negate 14 9)
+   (tag-negate-size 14 53)
+   (new-coupling 14 8)
+   (new-coupling-size 14 8)
+   (member-up-count 14 57)
+   (member-up-count-size 14 10)
+   (memoize-up-count 14 9)
+   (memoize-up-count-size 14 10)))
+ ((pattern
+    (list
+     (list
+      (box
+       (list
+        (list-rest
+          (not (not 8))
+          (vector tlp380 ...)
+          (and (? test-struct? tlp386)
+               (app test-struct-a tlp381)
+               (app test-struct-b tlp382)
+               (app test-struct-c tlp383)
+               (app test-struct-d tlp384))
+          #\a)
+        (box (list #t (vector tlp387 ___) (list tlp388 ..3)))
+        (and tlp389 tlp390)))
+      (not (not 6))
+      (list)
+      '(+ 4 (+ 1 1)))
+     (list (list tlp391 __3) (not (not 3)) tlp392 (list tlp393 ...))))
+  ((no-hueristics 44 45)
+   (no-hueristics-size 44 91)
+   (rel-1-5 44 44)
+   (rel-1-5-size 44 92)
+   (inverse-in 44 93)
+   (inverse-in-size 44 43)
+   (tag-negate 44 90)
+   (tag-negate-size 44 44)
+   (new-coupling 44 47)
+   (new-coupling-size 44 42)
+   (member-up-count 44 42)
+   (member-up-count-size 44 49)
+   (memoize-up-count 44 43)
+   (memoize-up-count-size 44 97)))
+ ((pattern
+    (list
+     (list
+      tlp352
+      (vector
+        (box
+         (list
+          (or _ _)
+          (and (? number? tlp353) (? even? tlp354))
+          (struct test-struct (tlp355 tlp356 tlp357 tlp358))))
+        (list
+         _
+         (list tlp360 ..3)
+         (and (? number? tlp361) (? even? tlp362))
+         (or (list tlp363 ..3) (list tlp363 ..3)))
+        (list
+         (not (not 'symbols))
+         (and (and tlp364 tlp365) (and tlp366 tlp367))
+         (struct test-struct (tlp368 tlp369 tlp370 tlp371))
+         _)
+        tlp373)
+      (list-rest (list tlp374 ...) (list tlp375 ...) _ #\c)
+      (and (? number? tlp376) (? even? tlp377)))
+     (list (list) (box (list (list) tlp378 (not (not #\c)))) #\b tlp379)))
+  ((no-hueristics 59 126)
+   (no-hueristics-size 59 124)
+   (rel-1-5 59 80)
+   (rel-1-5-size 59 83)
+   (inverse-in 59 80)
+   (inverse-in-size 59 79)
+   (tag-negate 59 81)
+   (tag-negate-size 59 127)
+   (new-coupling 59 130)
+   (new-coupling-size 59 127)
+   (member-up-count 59 126)
+   (member-up-count-size 59 132)
+   (memoize-up-count 59 131)
+   (memoize-up-count-size 59 92)))
+ ((pattern
+    (list
+     (vector tlp333 ...)
+     (list-rest
+       (and (? test-struct? tlp335)
+            (app test-struct-a (and _ _))
+            (app test-struct-b (not (not #f)))
+            (app test-struct-c '(+ 4 5))
+            (app test-struct-d 7))
+       (and (? number? tlp336) (? even? tlp337))
+       tlp338
+       'these)
+     (list-rest
+       tlp339
+       (not (not 'these))
+       (struct
+         test-struct
+         ((list)
+          '(+ 4 (+ 1 1))
+          (and (box (list tlp340 tlp341 tlp342))
+               (box (list tlp343 tlp344 tlp345)))
+          (vector tlp346 tlp347 tlp348 tlp349)))
+       #\a)
+     (vector tlp351 ...)))
+  ((no-hueristics 35 84)
+   (no-hueristics-size 35 42)
+   (rel-1-5 35 42)
+   (rel-1-5-size 35 90)
+   (inverse-in 35 91)
+   (inverse-in-size 35 45)
+   (tag-negate 35 89)
+   (tag-negate-size 35 42)
+   (new-coupling 35 46)
+   (new-coupling-size 35 43)
+   (member-up-count 35 45)
+   (member-up-count-size 35 48)
+   (memoize-up-count 35 90)
+   (memoize-up-count-size 35 48)))
+ ((pattern
+    (list
+     (list
+      (box
+       (list
+        (and (? number? tlp327) (? even? tlp328))
+        (vector tlp329 ...)
+        (list tlp330 ..3)))
+      (list)
+      tlp331
+      (or (vector tlp332 ...) (vector tlp332 ...)))))
+  ((no-hueristics 23 15)
+   (no-hueristics-size 23 64)
+   (rel-1-5 23 61)
+   (rel-1-5-size 23 16)
+   (inverse-in 23 16)
+   (inverse-in-size 23 60)
+   (tag-negate 23 16)
+   (tag-negate-size 23 16)
+   (new-coupling 23 16)
+   (new-coupling-size 23 15)
+   (member-up-count 23 65)
+   (member-up-count-size 23 16)
+   (memoize-up-count 23 16)
+   (memoize-up-count-size 23 18)))
+ ((pattern
+    `#&("hi"
+        1
+        there
+        #\c
+        #t
+        #f
+        (a b c)
+        (a b . c)
+        (a b c ..2)
+        #3(a b c)
+        #4(a b c ..2)
+        #&(a b c)
+        ,(list a b c)
+        ,(list-rest c1 d e)
+        ,(list f g h ...)
+        ,(vector i j k)
+        ,(box (list l m n o))
+        ,@(list 1 2 3 4 p)))
+  ((no-hueristics 90 323)
+   (no-hueristics-size 90 328)
+   (rel-1-5 90 281)
+   (rel-1-5-size 90 277)
+   (inverse-in 90 285)
+   (inverse-in-size 90 289)
+   (tag-negate 90 277)
+   (tag-negate-size 90 281)
+   (new-coupling 90 278)
+   (new-coupling-size 90 280)
+   (member-up-count 90 291)
+   (member-up-count-size 90 318)
+   (memoize-up-count 90 287)
+   (memoize-up-count-size 90 315)))
+ ((pattern
+    `#18("hi"
+         1
+         there
+         #\c
+         #t
+         #f
+         (a b c)
+         (a b . c)
+         (a b c ..2)
+         #3(a b c)
+         #4(a b c ..2)
+         #&(a b c)
+         ,(list a b c)
+         ,(list-rest c1 d e)
+         ,(list f g h ...)
+         ,(vector i j k)
+         ,(box (list l m n o))
+         ,@(list 1 2 3 4 p)))
+  ((no-hueristics 68 119)
+   (no-hueristics-size 68 121)
+   (rel-1-5 68 79)
+   (rel-1-5-size 68 121)
+   (inverse-in 68 78)
+   (inverse-in-size 68 101)
+   (tag-negate 68 78)
+   (tag-negate-size 68 123)
+   (new-coupling 68 79)
+   (new-coupling-size 68 77)
+   (member-up-count 68 78)
+   (member-up-count-size 68 88)
+   (memoize-up-count 68 123)
+   (memoize-up-count-size 68 145)))
+ ((pattern
+    `("hi"
+      1
+      there
+      #\c
+      #t
+      #f
+      (a b c)
+      (a b . c)
+      (a b c ..2)
+      #3(a b c)
+      #4(a b c ..2)
+      #&(a b c)
+      ,(list a b c)
+      ,(list-rest c1 d e)
+      ,(list f g h ...)
+      ,(vector i j k)
+      ,(box (list l m n o))
+      ,@(list 1 2 3 4 p)))
+  ((no-hueristics 89 308)
+   (no-hueristics-size 89 310)
+   (rel-1-5 89 273)
+   (rel-1-5-size 89 263)
+   (inverse-in 89 269)
+   (inverse-in-size 89 280)
+   (tag-negate 89 267)
+   (tag-negate-size 89 267)
+   (new-coupling 89 269)
+   (new-coupling-size 89 280)
+   (member-up-count 89 266)
+   (member-up-count-size 89 279)
+   (memoize-up-count 89 268)
+   (memoize-up-count-size 89 285)))
+ ((pattern `#&(c a b ,@(list a b c) r f i))
+  ((no-hueristics 18 12)
+   (no-hueristics-size 18 11)
+   (rel-1-5 18 12)
+   (rel-1-5-size 18 12)
+   (inverse-in 18 12)
+   (inverse-in-size 18 13)
+   (tag-negate 18 56)
+   (tag-negate-size 18 12)
+   (new-coupling 18 12)
+   (new-coupling-size 18 11)
+   (member-up-count 18 59)
+   (member-up-count-size 18 11)
+   (memoize-up-count 18 12)
+   (memoize-up-count-size 18 13)))
+ ((pattern `#7(c a b ,@(list derby b c) r f i))
+  ((no-hueristics 9 4)
+   (no-hueristics-size 9 5)
+   (rel-1-5 9 5)
+   (rel-1-5-size 9 4)
+   (inverse-in 9 4)
+   (inverse-in-size 9 6)
+   (tag-negate 9 4)
+   (tag-negate-size 9 4)
+   (new-coupling 9 5)
+   (new-coupling-size 9 5)
+   (member-up-count 9 4)
+   (member-up-count-size 9 4)
+   (memoize-up-count 9 5)
+   (memoize-up-count-size 9 5)))
+ ((pattern `#3(x ,x x))
+  ((no-hueristics 5 2)
+   (no-hueristics-size 5 3)
+   (rel-1-5 5 2)
+   (rel-1-5-size 5 3)
+   (inverse-in 5 3)
+   (inverse-in-size 5 52)
+   (tag-negate 5 2)
+   (tag-negate-size 5 2)
+   (new-coupling 5 2)
+   (new-coupling-size 5 2)
+   (member-up-count 5 3)
+   (member-up-count-size 5 3)
+   (memoize-up-count 5 3)
+   (memoize-up-count-size 5 2)))
+ ((pattern
+    `(3 4 #\c a b ,a ,(list b `(c e)))
+    `(3 4 #\c a b ,a ,(list b `(c d))))
+  ((no-hueristics 26 74)
+   (no-hueristics-size 26 32)
+   (rel-1-5 26 36)
+   (rel-1-5-size 23 36)
+   (inverse-in 26 37)
+   (inverse-in-size 23 42)
+   (tag-negate 26 38)
+   (tag-negate-size 23 39)
+   (new-coupling 23 31)
+   (new-coupling-size 23 33)
+   (member-up-count 23 30)
+   (member-up-count-size 23 31)
+   (memoize-up-count 23 76)
+   (memoize-up-count-size 23 31)))
+ ((pattern `(c a b ,@(list a b c) r f i))
+  ((no-hueristics 17 11)
+   (no-hueristics-size 17 10)
+   (rel-1-5 17 11)
+   (rel-1-5-size 17 11)
+   (inverse-in 17 11)
+   (inverse-in-size 17 12)
+   (tag-negate 17 11)
+   (tag-negate-size 17 11)
+   (new-coupling 17 11)
+   (new-coupling-size 17 11)
+   (member-up-count 17 12)
+   (member-up-count-size 17 11)
+   (memoize-up-count 17 10)
+   (memoize-up-count-size 17 15)))
+ ((pattern `(,a ,b ,c))
+  ((no-hueristics 5 3)
+   (no-hueristics-size 5 3)
+   (rel-1-5 5 2)
+   (rel-1-5-size 5 3)
+   (inverse-in 5 3)
+   (inverse-in-size 5 4)
+   (tag-negate 5 3)
+   (tag-negate-size 5 48)
+   (new-coupling 5 3)
+   (new-coupling-size 5 3)
+   (member-up-count 5 3)
+   (member-up-count-size 5 3)
+   (memoize-up-count 5 4)
+   (memoize-up-count-size 5 3)))
+ ((pattern `(,@`(,x ,y) ,@`(,a ,b)))
+  ((no-hueristics 6 4)
+   (no-hueristics-size 6 4)
+   (rel-1-5 6 4)
+   (rel-1-5-size 6 4)
+   (inverse-in 6 4)
+   (inverse-in-size 6 4)
+   (tag-negate 6 4)
+   (tag-negate-size 6 4)
+   (new-coupling 6 4)
+   (new-coupling-size 6 48)
+   (member-up-count 6 4)
+   (member-up-count-size 6 4)
+   (memoize-up-count 6 4)
+   (memoize-up-count-size 6 4)))
+ ((pattern `(,b 2 ,@(list 3 4) . b))
+  ((no-hueristics 9 45)
+   (no-hueristics-size 9 4)
+   (rel-1-5 9 4)
+   (rel-1-5-size 9 4)
+   (inverse-in 9 5)
+   (inverse-in-size 9 5)
+   (tag-negate 9 47)
+   (tag-negate-size 9 5)
+   (new-coupling 9 4)
+   (new-coupling-size 9 4)
+   (member-up-count 9 6)
+   (member-up-count-size 9 4)
+   (memoize-up-count 9 5)
+   (memoize-up-count-size 9 6)))
+ ((pattern `(1 2 ,@(list 3 4) . ,b))
+  ((no-hueristics 9 5)
+   (no-hueristics-size 9 5)
+   (rel-1-5 9 4)
+   (rel-1-5-size 9 4)
+   (inverse-in 9 4)
+   (inverse-in-size 9 6)
+   (tag-negate 9 4)
+   (tag-negate-size 9 6)
+   (new-coupling 9 5)
+   (new-coupling-size 9 4)
+   (member-up-count 9 6)
+   (member-up-count-size 9 5)
+   (memoize-up-count 9 4)
+   (memoize-up-count-size 9 53)))
+ ((pattern `(a ()))
+  ((no-hueristics 6 2)
+   (no-hueristics-size 6 2)
+   (rel-1-5 6 3)
+   (rel-1-5-size 6 3)
+   (inverse-in 6 2)
+   (inverse-in-size 6 4)
+   (tag-negate 6 3)
+   (tag-negate-size 6 4)
+   (new-coupling 6 5)
+   (new-coupling-size 6 2)
+   (member-up-count 6 3)
+   (member-up-count-size 6 2)
+   (memoize-up-count 6 2)
+   (memoize-up-count-size 6 3)))
+ ((pattern
+    (list (struct square (a b c d)) 5)
+    (list (struct shape (a)) 5)
+    (list (struct ovoid (a b c)) 5)
+    (list (struct circle (a b c d)) 5))
+  ((no-hueristics 30 13)
+   (no-hueristics-size 18 13)
+   (rel-1-5 30 58)
+   (rel-1-5-size 9 71)
+   (inverse-in 12 14)
+   (inverse-in-size 9 11)
+   (tag-negate 12 12)
+   (tag-negate-size 9 16)
+   (new-coupling 9 20)
+   (new-coupling-size 9 11)
+   (member-up-count 9 13)
+   (member-up-count-size 9 11)
+   (memoize-up-count 9 53)
+   (memoize-up-count-size 9 11)))
+ ((pattern
+    (list (struct square (a b c d)) 5)
+    (list (struct shape (a)) 2)
+    (list (struct ovoid (a b c)) 5)
+    (list (struct circle (a b c d)) 5))
+  ((no-hueristics 37 57)
+   (no-hueristics-size 26 16)
+   (rel-1-5 39 16)
+   (rel-1-5-size 13 17)
+   (inverse-in 19 14)
+   (inverse-in-size 14 14)
+   (tag-negate 15 13)
+   (tag-negate-size 11 15)
+   (new-coupling 10 11)
+   (new-coupling-size 10 11)
+   (member-up-count 10 14)
+   (member-up-count-size 10 11)
+   (memoize-up-count 10 10)
+   (memoize-up-count-size 10 12)))
+ ((pattern
+    (list (struct square (a b c d)) 5)
+    (list (struct shape (a)) 2)
+    (list (struct ovoid (a b c)) 2)
+    (list (struct circle (a b c d)) 5))
+  ((no-hueristics 38 16)
+   (no-hueristics-size 30 60)
+   (rel-1-5 40 17)
+   (rel-1-5-size 17 17)
+   (inverse-in 19 13)
+   (inverse-in-size 15 15)
+   (tag-negate 15 13)
+   (tag-negate-size 12 15)
+   (new-coupling 13 12)
+   (new-coupling-size 12 11)
+   (member-up-count 10 14)
+   (member-up-count-size 10 10)
+   (memoize-up-count 10 11)
+   (memoize-up-count-size 10 13)))
+ ((pattern
+    (list (struct rectangle (a b c)) 5)
+    (list (struct shape (a)) 5)
+    (list (struct ovoid (a b c)) 5)
+    (list (struct circle (a b c d)) 5))
+  ((no-hueristics 30 14)
+   (no-hueristics-size 18 14)
+   (rel-1-5 30 15)
+   (rel-1-5-size 9 57)
+   (inverse-in 12 11)
+   (inverse-in-size 9 13)
+   (tag-negate 12 12)
+   (tag-negate-size 9 61)
+   (new-coupling 9 11)
+   (new-coupling-size 9 11)
+   (member-up-count 9 60)
+   (member-up-count-size 9 11)
+   (memoize-up-count 9 10)
+   (memoize-up-count-size 9 12)))
+ ((pattern
+    (list (struct rectangle (a b c)) 5)
+    (list (struct shape (a)) 2)
+    (list (struct ovoid (a b c)) 5)
+    (list (struct circle (a b c d)) 5))
+  ((no-hueristics 37 57)
+   (no-hueristics-size 26 62)
+   (rel-1-5 39 16)
+   (rel-1-5-size 13 63)
+   (inverse-in 19 14)
+   (inverse-in-size 14 15)
+   (tag-negate 15 55)
+   (tag-negate-size 11 16)
+   (new-coupling 10 12)
+   (new-coupling-size 10 11)
+   (member-up-count 10 11)
+   (member-up-count-size 10 11)
+   (memoize-up-count 10 10)
+   (memoize-up-count-size 10 61)))
+ ((pattern
+    (list (struct rectangle (a b c)) 5)
+    (list (struct shape (a)) 2)
+    (list (struct ovoid (a b c)) 2)
+    (list (struct circle (a b c d)) 5))
+  ((no-hueristics 38 16)
+   (no-hueristics-size 30 15)
+   (rel-1-5 40 61)
+   (rel-1-5-size 17 17)
+   (inverse-in 19 14)
+   (inverse-in-size 15 65)
+   (tag-negate 15 12)
+   (tag-negate-size 12 15)
+   (new-coupling 13 13)
+   (new-coupling-size 12 12)
+   (member-up-count 10 12)
+   (member-up-count-size 10 55)
+   (memoize-up-count 10 12)
+   (memoize-up-count-size 10 13)))
+ ((pattern
+    (list (struct shape (a)) 5)
+    (list (struct ovoid (a b c)) 5)
+    (list (struct circle (a b c d)) 5)
+    (list (struct shape (a)) 6))
+  ((no-hueristics 40 18)
+   (no-hueristics-size 32 16)
+   (rel-1-5 24 14)
+   (rel-1-5-size 23 15)
+   (inverse-in 22 13)
+   (inverse-in-size 16 15)
+   (tag-negate 22 14)
+   (tag-negate-size 16 16)
+   (new-coupling 10 11)
+   (new-coupling-size 10 11)
+   (member-up-count 10 11)
+   (member-up-count-size 10 10)
+   (memoize-up-count 10 10)
+   (memoize-up-count-size 10 11)))
+ ((pattern
+    (list (struct shape (a)) 5)
+    (list (struct ovoid (a b c)) 5)
+    (list (struct circle (a b c d)) 5))
+  ((no-hueristics 26 10)
+   (no-hueristics-size 14 52)
+   (rel-1-5 26 11)
+   (rel-1-5-size 14 11)
+   (inverse-in 11 9)
+   (inverse-in-size 8 9)
+   (tag-negate 11 10)
+   (tag-negate-size 8 10)
+   (new-coupling 8 8)
+   (new-coupling-size 8 52)
+   (member-up-count 8 9)
+   (member-up-count-size 8 8)
+   (memoize-up-count 8 8)
+   (memoize-up-count-size 8 30)))
+ ((pattern
+    (list (struct shape (a)) 2)
+    (list (struct ovoid (a b c)) 5)
+    (list (struct circle (a b c d)) 5))
+  ((no-hueristics 31 11)
+   (no-hueristics-size 20 11)
+   (rel-1-5 31 13)
+   (rel-1-5-size 18 55)
+   (inverse-in 18 11)
+   (inverse-in-size 13 12)
+   (tag-negate 14 9)
+   (tag-negate-size 10 11)
+   (new-coupling 9 7)
+   (new-coupling-size 9 8)
+   (member-up-count 9 10)
+   (member-up-count-size 9 7)
+   (memoize-up-count 9 8)
+   (memoize-up-count-size 9 25)))
+ ((pattern
+    (list (struct shape (a)) 2)
+    (list (struct ovoid (a b c)) 2)
+    (list (struct circle (a b c d)) 5))
+  ((no-hueristics 32 12)
+   (no-hueristics-size 24 12)
+   (rel-1-5 32 12)
+   (rel-1-5-size 21 18)
+   (inverse-in 16 10)
+   (inverse-in-size 12 11)
+   (tag-negate 12 10)
+   (tag-negate-size 9 56)
+   (new-coupling 10 8)
+   (new-coupling-size 9 9)
+   (member-up-count 10 10)
+   (member-up-count-size 9 8)
+   (memoize-up-count 10 8)
+   (memoize-up-count-size 9 28)))
+ ((pattern (hash-table))
+  ((no-hueristics 3 2)
+   (no-hueristics-size 3 43)
+   (rel-1-5 3 1)
+   (rel-1-5-size 3 1)
+   (inverse-in 3 2)
+   (inverse-in-size 3 2)
+   (tag-negate 3 1)
+   (tag-negate-size 3 2)
+   (new-coupling 3 2)
+   (new-coupling-size 3 1)
+   (member-up-count 3 1)
+   (member-up-count-size 3 2)
+   (memoize-up-count 3 1)
+   (memoize-up-count-size 3 1)))
+ ((pattern (hash-table ('e v1) ('b v2) rest ...))
+  ((no-hueristics 11 10)
+   (no-hueristics-size 11 10)
+   (rel-1-5 11 52)
+   (rel-1-5-size 11 30)
+   (inverse-in 11 9)
+   (inverse-in-size 11 11)
+   (tag-negate 11 53)
+   (tag-negate-size 11 9)
+   (new-coupling 11 9)
+   (new-coupling-size 11 10)
+   (member-up-count 11 11)
+   (member-up-count-size 11 9)
+   (memoize-up-count 11 10)
+   (memoize-up-count-size 11 9)))
+ ((pattern (hash-table (k v) ...))
+  ((no-hueristics 6 5)
+   (no-hueristics-size 6 4)
+   (rel-1-5 6 4)
+   (rel-1-5-size 6 4)
+   (inverse-in 6 4)
+   (inverse-in-size 6 5)
+   (tag-negate 6 5)
+   (tag-negate-size 6 5)
+   (new-coupling 6 5)
+   (new-coupling-size 6 4)
+   (member-up-count 6 5)
+   (member-up-count-size 6 4)
+   (memoize-up-count 6 47)
+   (memoize-up-count-size 6 4)))
+ ((pattern (hash-table (a1 a2) (a (and (not "hello") b)) ...))
+  ((no-hueristics 10 9)
+   (no-hueristics-size 10 51)
+   (rel-1-5 10 9)
+   (rel-1-5-size 10 19)
+   (inverse-in 10 8)
+   (inverse-in-size 10 9)
+   (tag-negate 10 9)
+   (tag-negate-size 10 9)
+   (new-coupling 10 9)
+   (new-coupling-size 10 9)
+   (member-up-count 10 10)
+   (member-up-count-size 10 9)
+   (memoize-up-count 10 11)
+   (memoize-up-count-size 10 99)))
+ ((pattern (hash-table (a1 a2) (a (? number?)) ...))
+  ((no-hueristics 10 49)
+   (no-hueristics-size 10 7)
+   (rel-1-5 10 8)
+   (rel-1-5-size 10 18)
+   (inverse-in 10 8)
+   (inverse-in-size 10 8)
+   (tag-negate 10 8)
+   (tag-negate-size 10 8)
+   (new-coupling 10 8)
+   (new-coupling-size 10 8)
+   (member-up-count 10 10)
+   (member-up-count-size 10 7)
+   (memoize-up-count 10 8)
+   (memoize-up-count-size 10 8)))
+ ((pattern (hash-table (c 3) ('b b) (a 1) ..5) _)
+  ((no-hueristics 15 13)
+   (no-hueristics-size 15 13)
+   (rel-1-5 15 12)
+   (rel-1-5-size 15 114)
+   (inverse-in 15 13)
+   (inverse-in-size 15 12)
+   (tag-negate 15 13)
+   (tag-negate-size 15 13)
+   (new-coupling 15 12)
+   (new-coupling-size 15 13)
+   (member-up-count 15 57)
+   (member-up-count-size 15 58)
+   (memoize-up-count 15 13)
+   (memoize-up-count-size 15 13)))
+ ((pattern (hash-table (c 3) ('b b) (a 1) ..4))
+  ((no-hueristics 15 12)
+   (no-hueristics-size 15 12)
+   (rel-1-5 15 13)
+   (rel-1-5-size 15 92)
+   (inverse-in 15 13)
+   (inverse-in-size 15 12)
+   (tag-negate 15 12)
+   (tag-negate-size 15 53)
+   (new-coupling 15 12)
+   (new-coupling-size 15 12)
+   (member-up-count 15 12)
+   (member-up-count-size 15 12)
+   (memoize-up-count 15 14)
+   (memoize-up-count-size 15 12)))
+ ((pattern (hash-table (c 3) ('b b) (a 1) ...))
+  ((no-hueristics 15 12)
+   (no-hueristics-size 15 12)
+   (rel-1-5 15 58)
+   (rel-1-5-size 15 12)
+   (inverse-in 15 55)
+   (inverse-in-size 15 55)
+   (tag-negate 15 54)
+   (tag-negate-size 15 13)
+   (new-coupling 15 56)
+   (new-coupling-size 15 56)
+   (member-up-count 15 12)
+   (member-up-count-size 15 11)
+   (memoize-up-count 15 12)
+   (memoize-up-count-size 15 12)))
+ ((pattern (hash-table (c 3) ('b b) (a 1)))
+  ((no-hueristics 15 12)
+   (no-hueristics-size 15 54)
+   (rel-1-5 15 12)
+   (rel-1-5-size 15 15)
+   (inverse-in 15 12)
+   (inverse-in-size 15 15)
+   (tag-negate 15 12)
+   (tag-negate-size 15 12)
+   (new-coupling 15 13)
+   (new-coupling-size 15 16)
+   (member-up-count 15 13)
+   (member-up-count-size 15 12)
+   (memoize-up-count 15 12)
+   (memoize-up-count-size 15 37)))
+ ((pattern (hash-table (a 3) (b 1) (c 2)))
+  ((no-hueristics 15 52)
+   (no-hueristics-size 15 12)
+   (rel-1-5 15 12)
+   (rel-1-5-size 15 13)
+   (inverse-in 15 14)
+   (inverse-in-size 15 12)
+   (tag-negate 15 13)
+   (tag-negate-size 15 13)
+   (new-coupling 15 13)
+   (new-coupling-size 15 13)
+   (member-up-count 15 13)
+   (member-up-count-size 15 12)
+   (memoize-up-count 15 13)
+   (memoize-up-count-size 15 12)))
+ ((pattern (hash-table ('c c) ('a a) ('b b)))
+  ((no-hueristics 15 13)
+   (no-hueristics-size 15 56)
+   (rel-1-5 15 13)
+   (rel-1-5-size 15 55)
+   (inverse-in 15 12)
+   (inverse-in-size 15 13)
+   (tag-negate 15 12)
+   (tag-negate-size 15 13)
+   (new-coupling 15 12)
+   (new-coupling-size 15 12)
+   (member-up-count 15 12)
+   (member-up-count-size 15 20)
+   (memoize-up-count 15 13)
+   (memoize-up-count-size 15 13)))
+ ((pattern (hash-table ('a a) b ('c c)))
+  ((no-hueristics 11 49)
+   (no-hueristics-size 11 9)
+   (rel-1-5 11 10)
+   (rel-1-5-size 11 9)
+   (inverse-in 11 9)
+   (inverse-in-size 11 9)
+   (tag-negate 11 10)
+   (tag-negate-size 11 52)
+   (new-coupling 11 9)
+   (new-coupling-size 11 9)
+   (member-up-count 11 10)
+   (member-up-count-size 11 10)
+   (memoize-up-count 11 10)
+   (memoize-up-count-size 11 10)))
+ ((pattern (list-no-order))
+  ((no-hueristics 2 1)
+   (no-hueristics-size 2 1)
+   (rel-1-5 2 1)
+   (rel-1-5-size 2 3)
+   (inverse-in 2 1)
+   (inverse-in-size 2 1)
+   (tag-negate 2 1)
+   (tag-negate-size 2 1)
+   (new-coupling 2 1)
+   (new-coupling-size 2 1)
+   (member-up-count 2 1)
+   (member-up-count-size 2 1)
+   (memoize-up-count 2 1)
+   (memoize-up-count-size 2 1)))
+ ((pattern
+    (list-no-order
+      (and (? number?) a)
+      (and (? symbol?) b)
+      (and (? symbol?) c)
+      (and (? symbol?) d)
+      (and (? symbol?) e)
+      f
+      ...))
+  ((no-hueristics 7 10)
+   (no-hueristics-size 7 51)
+   (rel-1-5 7 54)
+   (rel-1-5-size 7 9)
+   (inverse-in 7 51)
+   (inverse-in-size 7 51)
+   (tag-negate 7 10)
+   (tag-negate-size 7 11)
+   (new-coupling 7 12)
+   (new-coupling-size 7 10)
+   (member-up-count 7 52)
+   (member-up-count-size 7 11)
+   (memoize-up-count 7 11)
+   (memoize-up-count-size 7 11)))
+ ((pattern
+    (list-no-order
+      (and (? number?) a)
+      (and (? number?) b)
+      (and (? number?) c)
+      (and (? number?) d)
+      (and (? symbol?) e)
+      f
+      ...))
+  ((no-hueristics 7 53)
+   (no-hueristics-size 7 10)
+   (rel-1-5 7 10)
+   (rel-1-5-size 7 10)
+   (inverse-in 7 10)
+   (inverse-in-size 7 10)
+   (tag-negate 7 13)
+   (tag-negate-size 7 10)
+   (new-coupling 7 13)
+   (new-coupling-size 7 10)
+   (member-up-count 7 40)
+   (member-up-count-size 7 54)
+   (memoize-up-count 7 11)
+   (memoize-up-count-size 7 60)))
+ ((pattern (list-no-order a b c ...))
+  ((no-hueristics 2 4)
+   (no-hueristics-size 2 3)
+   (rel-1-5 2 4)
+   (rel-1-5-size 2 4)
+   (inverse-in 2 3)
+   (inverse-in-size 2 3)
+   (tag-negate 2 3)
+   (tag-negate-size 2 3)
+   (new-coupling 2 46)
+   (new-coupling-size 2 3)
+   (member-up-count 2 4)
+   (member-up-count-size 2 4)
+   (memoize-up-count 2 3)
+   (memoize-up-count-size 2 4)))
+ ((pattern (list-no-order a b c 3 ...))
+  ((no-hueristics 4 4)
+   (no-hueristics-size 4 4)
+   (rel-1-5 4 5)
+   (rel-1-5-size 4 46)
+   (inverse-in 4 4)
+   (inverse-in-size 4 4)
+   (tag-negate 4 5)
+   (tag-negate-size 4 4)
+   (new-coupling 4 4)
+   (new-coupling-size 4 48)
+   (member-up-count 4 4)
+   (member-up-count-size 4 5)
+   (memoize-up-count 4 4)
+   (memoize-up-count-size 4 5)))
+ ((pattern (list-no-order 5 4 2 3 1 g ...))
+  ((no-hueristics 7 46)
+   (no-hueristics-size 7 6)
+   (rel-1-5 7 6)
+   (rel-1-5-size 7 6)
+   (inverse-in 7 6)
+   (inverse-in-size 7 7)
+   (tag-negate 7 6)
+   (tag-negate-size 7 7)
+   (new-coupling 7 6)
+   (new-coupling-size 7 6)
+   (member-up-count 7 7)
+   (member-up-count-size 7 6)
+   (memoize-up-count 7 7)
+   (memoize-up-count-size 7 6)))
+ ((pattern (list-no-order 5 a 2 b 1 c 7))
+  ((no-hueristics 6 8)
+   (no-hueristics-size 6 8)
+   (rel-1-5 6 7)
+   (rel-1-5-size 6 53)
+   (inverse-in 6 8)
+   (inverse-in-size 6 7)
+   (tag-negate 6 8)
+   (tag-negate-size 6 8)
+   (new-coupling 6 8)
+   (new-coupling-size 6 8)
+   (member-up-count 6 8)
+   (member-up-count-size 6 8)
+   (memoize-up-count 6 7)
+   (memoize-up-count-size 6 7)))
+ ((pattern (list-no-order 5 4 2 3 1 c b))
+  ((no-hueristics 7 8)
+   (no-hueristics-size 7 8)
+   (rel-1-5 7 48)
+   (rel-1-5-size 7 7)
+   (inverse-in 7 8)
+   (inverse-in-size 7 48)
+   (tag-negate 7 7)
+   (tag-negate-size 7 7)
+   (new-coupling 7 7)
+   (new-coupling-size 7 7)
+   (member-up-count 7 11)
+   (member-up-count-size 7 9)
+   (memoize-up-count 7 8)
+   (memoize-up-count-size 7 49)))
+ ((pattern
+    `(fish1 fish1 fish1 fish1 fish1)
+    `(,(or `fish1 `fish2)
+      ,(or `fish1 `fish2)
+      ,(or `fish1 `fish2)
+      ,(or `fish1 `fish2)
+      ,(or `fish1 `fish2))
+    `(,(or `fish1 `fish3)
+      ,(or `fish1 `fish3)
+      ,(or `fish1 `fish3)
+      ,(or `fish1 `fish3)
+      ,(or `fish1 `fish3))
+    `(fish1 fish1 fish1 fish1 ,_)
+    `(,(or `fish1 `fish2)
+      ,(or `fish1 `fish2)
+      ,(or `fish1 `fish2)
+      ,(or `fish1 `fish2)
+      ,_)
+    `(,(or `fish1 `fish3)
+      ,(or `fish1 `fish3)
+      ,(or `fish1 `fish3)
+      ,(or `fish1 `fish3)
+      ,_)
+    `(fish1 fish1 fish1 ,_ ,_)
+    `(,(or `fish1 `fish2) ,(or `fish1 `fish2) ,(or `fish1 `fish2) ,_ ,_)
+    `(,(or `fish1 `fish3) ,(or `fish1 `fish3) ,(or `fish1 `fish3) ,_ ,_)
+    `(fish1 fish1 ,_ ,_ ,_)
+    `(,(or `fish1 `fish2) ,(or `fish1 `fish2) ,_ ,_ ,_)
+    `(,(or `fish1 `fish3) ,(or `fish1 `fish3) ,_ ,_ ,_)
+    `(,(or `fish1 `fish2 `fish3) ,_ ,_ ,_ ,_)
+    `(bells bells bells bells bells)
+    `(bells bells bells bells ,_)
+    `(bells bells bells ,_ ,_)
+    `(eggplant eggplant eggplant eggplant eggplant)
+    `(eggplant eggplant eggplant eggplant ,_)
+    `(eggplant eggplant eggplant ,_ ,_)
+    `(cherry cherry cherry cherry cherry)
+    `(cherry cherry cherry cherry ,_)
+    `(cherry cherry cherry ,_ ,_)
+    `(watermelon watermelon watermelon watermelon watermelon)
+    `(watermelon watermelon watermelon watermelon ,_)
+    `(watermelon watermelon watermelon ,_ ,_)
+    `(orange orange orange orange orange)
+    `(orange orange orange orange ,_)
+    `(orange orange orange ,_ ,_)
+    `(lure1 lure1 lure1 lure1 lure1)
+    (or `(,_ lure1 lure1 lure1 lure1) `(lure1 lure1 lure1 lure1 ,_))
+    (or `(,_ ,_ lure3 lure3 lure3)
+        `(,_ lure3 lure3 lure3 ,_)
+        `(lure3 lure3 lure3 ,_ ,_)
+        `(,_ ,_ lure2 lure2 lure2)
+        `(,_ lure2 lure2 lure2 ,_)
+        `(lure2 lure2 lure2 ,_ ,_)
+        `(,_ ,_ lure1 lure1 lure1)
+        `(,_ lure1 lure1 lure1 ,_)
+        `(lure1 lure1 lure1 ,_ ,_))
+    else)
+  ((no-hueristics 1564 28951)
+   (no-hueristics-size 1564 29294)
+   (rel-1-5 541 8939)
+   (rel-1-5-size 541 11855)
+   (inverse-in 541 10715)
+   (inverse-in-size 541 10142)
+   (tag-negate 541 9749)
+   (tag-negate-size 541 9753)
+   (new-coupling 341 6436)
+   (new-coupling-size 341 6116)
+   (member-up-count 341 7608)
+   (member-up-count-size 341 5909)
+   (memoize-up-count 341 6949)
+   (memoize-up-count-size 341 5712)))
+ ((pattern
+    (struct a60:subscript (array index))
+    (struct a60:binary (type argtype op e1 e2))
+    (struct a60:unary (type argtype op e1))
+    (struct a60:variable (var subscripts))
+    (struct a60:app (func args))
+    else)
+  ((no-hueristics 6 5)
+   (no-hueristics-size 6 6)
+   (rel-1-5 6 6)
+   (rel-1-5-size 6 6)
+   (inverse-in 6 7)
+   (inverse-in-size 6 5)
+   (tag-negate 6 5)
+   (tag-negate-size 6 6)
+   (new-coupling 6 6)
+   (new-coupling-size 6 6)
+   (member-up-count 6 6)
+   (member-up-count-size 6 7)
+   (memoize-up-count 6 6)
+   (memoize-up-count-size 6 6)))
+ ((pattern
+    (? (lambda (x) (and (syntax? x) (number? (syntax-e x)))) n)
+    (? (lambda (x) (and (syntax? x) (boolean? (syntax-e x)))) n)
+    (? (lambda (x) (and (syntax? x) (string? (syntax-e x)))) n)
+    (? identifier? i)
+    (? symbol? i)
+    (struct a60:subscript (array index))
+    (struct a60:binary (t argt op e1 e2))
+    (struct a60:unary (t argt op e1))
+    (struct a60:variable (var subscripts))
+    (struct a60:app (func args))
+    (struct a60:if (test then else))
+    else)
+  ((no-hueristics 12 48)
+   (no-hueristics-size 12 49)
+   (rel-1-5 12 48)
+   (rel-1-5-size 12 49)
+   (inverse-in 12 50)
+   (inverse-in-size 12 55)
+   (tag-negate 12 10)
+   (tag-negate-size 12 10)
+   (new-coupling 12 10)
+   (new-coupling-size 12 58)
+   (member-up-count 12 52)
+   (member-up-count-size 12 60)
+   (memoize-up-count 12 10)
+   (memoize-up-count-size 12 11)))
+ ((pattern
+    (struct a60:block (decls statements))
+    (struct
+      a60:branch
+      (test (struct a60:goto (then)) (struct a60:goto (else))))
+    (struct a60:goto (label))
+    (struct a60:dummy ())
+    (struct a60:call (proc args))
+    (struct a60:assign (vars val))
+    else)
+  ((no-hueristics 9 6)
+   (no-hueristics-size 9 6)
+   (rel-1-5 9 6)
+   (rel-1-5-size 9 7)
+   (inverse-in 9 7)
+   (inverse-in-size 9 8)
+   (tag-negate 9 7)
+   (tag-negate-size 9 7)
+   (new-coupling 9 8)
+   (new-coupling-size 9 8)
+   (member-up-count 9 6)
+   (member-up-count-size 9 6)
+   (memoize-up-count 9 7)
+   (memoize-up-count-size 9 7)))
+ ((pattern
+    (struct
+      |Minus|
+      ((struct
+         <tuple>
+         ((list
+           (struct |Val| ((struct |Num| (n1))))
+           (struct |Val| ((struct |Num| (n2)))))))))
+    (struct |Minus| ((struct <tuple> ((list (struct |Val| (v1)) m2)))))
+    (struct |Minus| ((struct <tuple> ((list m1 m2)))))
+    (struct
+      |Times|
+      ((struct
+         <tuple>
+         ((list
+           (struct |Val| ((struct |Num| (n1))))
+           (struct |Val| ((struct |Num| (n2)))))))))
+    (struct |Times| ((struct <tuple> ((list (struct |Val| (v1)) m2)))))
+    (struct |Times| ((struct <tuple> ((list m1 m2)))))
+    (struct
+      |App|
+      ((struct
+         <tuple>
+         ((list
+           (struct |Val| ((struct |Lam| ((struct <tuple> ((list x t m)))))))
+           (struct |Val| (v)))))))
+    (struct |App| ((struct <tuple> ((list (struct |Val| (f)) m2)))))
+    (struct |App| ((struct <tuple> ((list m1 m2)))))
+    (struct
+      |IfZero|
+      ((struct <tuple> ((list (struct |Val| ((struct |Num| (0)))) m2 m3)))))
+    (struct
+      |IfZero|
+      ((struct <tuple> ((list (struct |Val| ((struct |Num| (n)))) m2 m3)))))
+    (struct |IfZero| ((struct <tuple> ((list m1 m2 m3)))))
+    (struct
+      |Fix|
+      ((struct |Val| ((struct |Lam| ((struct <tuple> ((list x t m)))))))))
+    (struct |Fix| (m))
+    _)
+  ((no-hueristics 85 181)
+   (no-hueristics-size 85 371)
+   (rel-1-5 49 186)
+   (rel-1-5-size 49 248)
+   (inverse-in 49 190)
+   (inverse-in-size 49 224)
+   (tag-negate 49 201)
+   (tag-negate-size 49 208)
+   (new-coupling 49 155)
+   (new-coupling-size 49 168)
+   (member-up-count 49 127)
+   (member-up-count-size 49 128)
+   (memoize-up-count 49 75)
+   (memoize-up-count-size 49 118)))
+ ((pattern
+    (list 1 2 3 4 5)
+    (list 2 3 4 5 6)
+    (list 4 5 3 6 2)
+    (list 7 8 9 3 4)
+    (list 4 8 3 2 3))
+  ((no-hueristics 50 77)
+   (no-hueristics-size 50 111)
+   (rel-1-5 57 89)
+   (rel-1-5-size 31 118)
+   (inverse-in 57 93)
+   (inverse-in-size 31 100)
+   (tag-negate 55 93)
+   (tag-negate-size 32 84)
+   (new-coupling 32 38)
+   (new-coupling-size 32 64)
+   (member-up-count 32 32)
+   (member-up-count-size 32 33)
+   (memoize-up-count 32 109)
+   (memoize-up-count-size 32 69)))
+ ((pattern (list 1 2 3) (list 4 5 6))
+  ((no-hueristics 14 46)
+   (no-hueristics-size 14 44)
+   (rel-1-5 17 6)
+   (rel-1-5-size 11 45)
+   (inverse-in 17 7)
+   (inverse-in-size 11 50)
+   (tag-negate 17 8)
+   (tag-negate-size 11 8)
+   (new-coupling 11 6)
+   (new-coupling-size 11 6)
+   (member-up-count 11 5)
+   (member-up-count-size 11 6)
+   (memoize-up-count 11 6)
+   (memoize-up-count-size 11 5))))
diff --git a/collects/tests/mzscheme/match/match-perf.db b/collects/tests/mzscheme/match/match-perf.db
new file mode 100644
index 0000000000..7e695b6ff7
--- /dev/null
+++ b/collects/tests/mzscheme/match/match-perf.db
@@ -0,0 +1,3894 @@
+(((pattern
+    (list
+     (not (not #t))
+     tlp2450
+     (or (box
+          (list
+           (struct
+             test-struct
+             ((vector tlp2451 ...)
+              #\d
+              (or tlp2452 tlp2452)
+              (vector tlp2453 ___)))
+           (list tlp2455 ..3)
+           tlp2456))
+         (box
+          (list
+           (struct
+             test-struct
+             ((vector tlp2451 ...)
+              #\d
+              (or tlp2452 tlp2452)
+              (vector tlp2453 ___)))
+           (list tlp2455 ..3)
+           tlp2456)))
+     (or (list tlp2457 ...) (list tlp2457 ...)))
+    (list
+     (list-rest
+       (box (list (or _ _) (list) (list tlp2458 ..3)))
+       tlp2459
+       (vector tlp2460 ___)
+       #t)
+     (and (? test-struct? tlp2470)
+          (app test-struct-a (not (not #\b)))
+          (app
+           test-struct-b
+           (struct
+             test-struct
+             ((list)
+              (not (not #\b))
+              'symbols
+              (or (vector tlp2461 tlp2462 tlp2463 tlp2464)
+                  (vector tlp2461 tlp2462 tlp2463 tlp2464)))))
+          (app test-struct-c #\d)
+          (app
+           test-struct-d
+           (box (list (and tlp2466 tlp2467) (vector tlp2468 ___) _))))
+     (vector tlp2471 ___)
+     (not (not 9)))
+    (list
+     (vector
+       (and (? number? tlp2472) (? even? tlp2473))
+       (list)
+       (struct
+         test-struct
+         ((vector tlp2474 tlp2475 tlp2476 tlp2477)
+          (list tlp2478 ___)
+          (list tlp2479 ..3)
+          '(+ 1 2)))
+       (or _ _))
+     (list tlp2481 ..3)
+     tlp2482
+     (and (? number? tlp2483) (? even? tlp2484))))
+  ((baseline 92 293)
+   (reord-no-negate 129 129)
+   (tag-negate 129 292)
+   (code-size-negate 123 193)))
+ ((pattern
+    (list
+     tlp2416
+     (not (not #t))
+     (or (list-rest
+           (and (list tlp2417 ...) (list tlp2418 ...))
+           (vector
+             (list-rest tlp2419 tlp2420 tlp2421 tlp2422)
+             #\c
+             tlp2423
+             (list-rest tlp2424 tlp2425 tlp2426 tlp2427))
+           9
+           'are)
+         (list-rest
+           (and (list tlp2417 ...) (list tlp2418 ...))
+           (vector
+             (list-rest tlp2419 tlp2420 tlp2421 tlp2422)
+             #\c
+             tlp2423
+             (list-rest tlp2424 tlp2425 tlp2426 tlp2427))
+           9
+           'are))
+     (list
+      tlp2428
+      (and (? number? tlp2429) (? even? tlp2430))
+      (not (not '(+ 4 5)))
+      (or (struct
+            test-struct
+            ((box (list tlp2431 tlp2432 tlp2433))
+             #f
+             (vector tlp2434 tlp2435 tlp2436 tlp2437)
+             _))
+          (struct
+            test-struct
+            ((box (list tlp2431 tlp2432 tlp2433))
+             #f
+             (vector tlp2434 tlp2435 tlp2436 tlp2437)
+             _)))))
+    (list
+     (vector
+       (list)
+       (not (not #\d))
+       (box (list (not (not 9)) (list) 'symbols))
+       (list))
+     _
+     tlp2439
+     (list-rest tlp2440 _ tlp2441 #t))
+    (list
+     (or (not (not #\b)) (not (not #\b)))
+     (list
+      tlp2442
+      (list)
+      (list)
+      (and (vector tlp2443 ...) (vector tlp2444 ...)))
+     (list tlp2445 ___)
+     (or (and (? number? tlp2446) (? even? tlp2447))
+         (and (? number? tlp2446) (? even? tlp2447)))))
+  ((baseline 680 1660)
+   (reord-no-negate 1381 1257)
+   (tag-negate 1381 1328)
+   (code-size-negate 1283 1075)))
+ ((pattern
+    (list
+     (not (not #\b))
+     _
+     (list
+      (list tlp2317 ...)
+      (list tlp2318 ..3)
+      (vector
+        tlp2319
+        _
+        (box (list tlp2320 tlp2321 tlp2322))
+        (struct test-struct (tlp2323 tlp2324 tlp2325 tlp2326)))
+      '(+ 4 5))
+     (list tlp2328 __3))
+    (list
+     tlp2329
+     (list tlp2330 ...)
+     (list
+      (struct
+        test-struct
+        (_ (struct test-struct (tlp2331 tlp2332 tlp2333 tlp2334)) _ (list)))
+      tlp2337
+      (and (and (box (list tlp2338 tlp2339 tlp2340))
+                (box (list tlp2341 tlp2342 tlp2343)))
+           (and (box (list tlp2344 tlp2345 tlp2346))
+                (box (list tlp2347 tlp2348 tlp2349))))
+      (and #\d #\d))
+     (list-rest
+       (list-rest
+         (struct test-struct (tlp2350 tlp2351 tlp2352 tlp2353))
+         (or (struct test-struct (tlp2355 tlp2356 tlp2357 tlp2358))
+             (struct test-struct (tlp2355 tlp2356 tlp2357 tlp2358)))
+         (list-rest tlp2360 tlp2361 tlp2362 #\c)
+         #\a)
+       (list tlp2363 ___)
+       (list)
+       3))
+    (list
+     (and (? test-struct? tlp2396)
+          (app
+           test-struct-a
+           (and (? test-struct? tlp2371)
+                (app test-struct-a tlp2364)
+                (app test-struct-b tlp2365)
+                (app test-struct-c (list tlp2366 tlp2367 tlp2368 tlp2369))
+                (app test-struct-d (list))))
+          (app
+           test-struct-b
+           (struct
+             test-struct
+             ((and (? test-struct? tlp2377)
+                   (app test-struct-a tlp2372)
+                   (app test-struct-b tlp2373)
+                   (app test-struct-c tlp2374)
+                   (app test-struct-d tlp2375))
+              (list tlp2378 ..3)
+              (and (? number? tlp2379) (? even? tlp2380))
+              (vector tlp2381 ...))))
+          (app
+           test-struct-c
+           (box
+            (list
+             (list tlp2383 ..3)
+             (and (? test-struct? tlp2389)
+                  (app test-struct-a tlp2384)
+                  (app test-struct-b tlp2385)
+                  (app test-struct-c tlp2386)
+                  (app test-struct-d tlp2387))
+             tlp2390)))
+          (app
+           test-struct-d
+           (and (and (? number? tlp2391) (? even? tlp2392))
+                (and (? number? tlp2393) (? even? tlp2394)))))
+     (list
+      '(+ 1 2)
+      (vector tlp2397 ___)
+      (struct
+        test-struct
+        ((vector tlp2398 tlp2399 tlp2400 tlp2401)
+         (and (? number? tlp2402) (? even? tlp2403))
+         tlp2404
+         (list-rest tlp2405 tlp2406 tlp2407 'symbols)))
+      _)
+     (struct
+       test-struct
+       ((list tlp2409 ..3)
+        (not (not #\a))
+        tlp2410
+        (and (? number? tlp2411) (? even? tlp2412))))
+     (list)))
+  ((baseline 12556 10461)
+   (reord-no-negate 8529 7673)
+   (tag-negate 8529 8733)
+   (code-size-negate 8420 7772)))
+ ((pattern
+    (list
+     tlp2273
+     (box
+      (list
+       (struct
+         test-struct
+         ((vector tlp2274 ___)
+          (vector tlp2275 ___)
+          (vector tlp2276 ...)
+          (and (list tlp2277 ___) (list tlp2278 ___))))
+       (and (? number? tlp2280) (? even? tlp2281))
+       (list (and tlp2282 tlp2283) tlp2284 _ (list tlp2285 ___))))
+     _
+     (and (? number? tlp2286) (? even? tlp2287)))
+    (list
+     tlp2288
+     (and (list-rest
+            (list-rest
+              '(+ 4 5)
+              (list tlp2289 tlp2290 tlp2291 tlp2292)
+              (not (not #\a))
+              #\b)
+            (list-rest
+              (list)
+              #\a
+              (and (? number? tlp2293) (? even? tlp2294))
+              'these)
+            (list tlp2295 ___)
+            6)
+          (list-rest
+            (list-rest
+              '(+ 4 5)
+              (list tlp2296 tlp2297 tlp2298 tlp2299)
+              (not (not #\a))
+              #\b)
+            (list-rest
+              (list)
+              #\a
+              (and (? number? tlp2300) (? even? tlp2301))
+              'these)
+            (list tlp2302 ___)
+            6))
+     (box
+      (list
+       (list)
+       _
+       (and (? test-struct? tlp2306)
+            (app test-struct-a tlp2303)
+            (app test-struct-b (list))
+            (app test-struct-c #t)
+            (app test-struct-d (or (list tlp2304 ..3) (list tlp2304 ..3))))))
+     (struct
+       test-struct
+       (tlp2307
+         (list)
+         (not (not 'symbols))
+         (or (and (? number? tlp2308) (? even? tlp2309))
+             (and (? number? tlp2308) (? even? tlp2309))))))
+    (list tlp2311 (or tlp2312 tlp2312) (vector tlp2313 ___) tlp2314))
+  ((baseline 306 370)
+   (reord-no-negate 163 273)
+   (tag-negate 163 334)
+   (code-size-negate 161 333)))
+ ((pattern
+    (list (not (not #\b)) '(+ 4 (+ 1 1)) (vector tlp2260 ...) _)
+    (list
+     (list)
+     (and (? test-struct? tlp2264)
+          (app test-struct-a (not (not #\a)))
+          (app test-struct-b (vector tlp2261 ...))
+          (app test-struct-c (or (list) (list)))
+          (app
+           test-struct-d
+           (list-rest '(+ 1 2) (list tlp2262 ...) (not (not #\b)) 'these)))
+     (or (list tlp2265 __3) (list tlp2265 __3))
+     (list))
+    (list
+     (list tlp2266 ___)
+     (struct test-struct ((list tlp2267 __3) (not (not 'are)) tlp2268 (list)))
+     (list tlp2270 __3)
+     (and #f #f)))
+  ((baseline 81 64)
+   (reord-no-negate 219 182)
+   (tag-negate 129 71)
+   (code-size-negate 114 73)))
+ ((pattern
+    (list
+     (and (? number? tlp2096) (? even? tlp2097))
+     (and (? test-struct? tlp2105)
+          (app test-struct-a #\b)
+          (app
+           test-struct-b
+           (or (and (list tlp2098 ___) (list tlp2099 ___))
+               (and (list tlp2098 ___) (list tlp2099 ___))))
+          (app test-struct-c (and (? number? tlp2100) (? even? tlp2101)))
+          (app test-struct-d (and (? number? tlp2102) (? even? tlp2103))))
+     #t
+     #\a)
+    (list
+     (and (? test-struct? tlp2128)
+          (app test-struct-a _)
+          (app test-struct-b (list))
+          (app
+           test-struct-c
+           (struct
+             test-struct
+             ((struct test-struct (tlp2106 tlp2107 tlp2108 tlp2109))
+              (vector tlp2111 ...)
+              tlp2112
+              (vector tlp2113 tlp2114 tlp2115 tlp2116))))
+          (app
+           test-struct-d
+           (vector
+             (box (list tlp2118 tlp2119 tlp2120))
+             (struct test-struct (tlp2121 tlp2122 tlp2123 tlp2124))
+             tlp2126
+             (list))))
+     (and (? test-struct? tlp2139)
+          (app test-struct-a _)
+          (app
+           test-struct-b
+           (and (? test-struct? tlp2134)
+                (app test-struct-a _)
+                (app test-struct-b (vector tlp2129 ___))
+                (app
+                 test-struct-c
+                 (list-rest tlp2130 tlp2131 tlp2132 'symbols))
+                (app test-struct-d 'these)))
+          (app test-struct-c (and (? number? tlp2135) (? even? tlp2136)))
+          (app test-struct-d tlp2137))
+     (vector tlp2140 ...)
+     tlp2141)
+    (list
+     (struct
+       test-struct
+       ((list-rest
+          (struct test-struct (tlp2142 tlp2143 tlp2144 tlp2145))
+          (not (not #f))
+          tlp2147
+          #t)
+        _
+        tlp2148
+        (list-rest
+          (and (? test-struct? tlp2154)
+               (app test-struct-a tlp2149)
+               (app test-struct-b tlp2150)
+               (app test-struct-c tlp2151)
+               (app test-struct-d tlp2152))
+          (and tlp2155 tlp2156)
+          (box (list tlp2157 tlp2158 tlp2159))
+          #\b)))
+     (list tlp2161 __3)
+     'these
+     (and (? number? tlp2162) (? even? tlp2163))))
+  ((baseline 5464 2896)
+   (reord-no-negate 3378 2028)
+   (tag-negate 426 319)
+   (code-size-negate 374 320)))
+ ((pattern
+    (list (and (? number? tlp2067) (? even? tlp2068)) _ (or 'these 'these) 8)
+    (list
+     (list tlp2069 ..3)
+     (list tlp2070 ..3)
+     (box
+      (list
+       (not (not 'are))
+       (and (? number? tlp2071) (? even? tlp2072))
+       tlp2073))
+     (list-rest
+       (vector
+         (list)
+         tlp2074
+         tlp2075
+         (list-rest tlp2076 tlp2077 tlp2078 'symbols))
+       tlp2079
+       (and (? test-struct? tlp2086)
+            (app test-struct-a (vector tlp2080 tlp2081 tlp2082 tlp2083))
+            (app test-struct-b _)
+            (app test-struct-c (not (not #\c)))
+            (app test-struct-d (list tlp2084 __3)))
+       'are))
+    (list
+     #\b
+     _
+     (struct
+       test-struct
+       ((list tlp2087 ...)
+        (and (? number? tlp2088) (? even? tlp2089))
+        (or tlp2090 tlp2090)
+        (vector (not (not '(+ 1 2))) tlp2091 (list) tlp2092)))
+     tlp2094))
+  ((baseline 371 291)
+   (reord-no-negate 318 230)
+   (tag-negate 318 213)
+   (code-size-negate 310 208)))
+ ((pattern
+    (list (not (not #t)) tlp2016 (list) tlp2017)
+    (list
+     (list-rest
+       (list tlp2018 (not (not '(+ 1 2))) 'are tlp2019)
+       (list
+        (list tlp2020 tlp2021 tlp2022 tlp2023)
+        (and (list-rest tlp2024 tlp2025 tlp2026 tlp2027)
+             (list-rest tlp2028 tlp2029 tlp2030 tlp2031))
+        (list tlp2032 __3)
+        _)
+       (and (? number? tlp2033) (? even? tlp2034))
+       #\b)
+     _
+     (list tlp2035 __3)
+     #f)
+    (list
+     (list
+      (list tlp2036 ...)
+      (and (and (? test-struct? tlp2042)
+                (app test-struct-a tlp2037)
+                (app test-struct-b 7)
+                (app test-struct-c (box (list tlp2038 tlp2039 tlp2040)))
+                (app test-struct-d (not (not #t))))
+           (and (? test-struct? tlp2043)
+                (app test-struct-a tlp2044)
+                (app test-struct-b 7)
+                (app test-struct-c (box (list tlp2045 tlp2046 tlp2047)))
+                (app test-struct-d (not (not #t)))))
+      (and (vector
+             (and tlp2048 tlp2049)
+             (list tlp2050 tlp2051 tlp2052 tlp2053)
+             (and tlp2054 tlp2055)
+             tlp2056)
+           (vector
+             (and tlp2057 tlp2058)
+             (list tlp2059 tlp2060 tlp2061 tlp2062)
+             (and tlp2063 tlp2064)
+             tlp2065))
+      #\c)
+     'symbols
+     (list)
+     (not (not '(+ 4 5)))))
+  ((baseline 728 545)
+   (reord-no-negate 1214 942)
+   (tag-negate 401 286)
+   (code-size-negate 343 285)))
+ ((pattern
+    (list
+     (list-rest
+       tlp1952
+       (or (struct test-struct (2 tlp1953 tlp1954 (list)))
+           (struct test-struct (2 tlp1953 tlp1954 (list))))
+       (struct
+         test-struct
+         ((vector tlp1956 tlp1957 tlp1958 tlp1959)
+          (and (vector tlp1960 ___) (vector tlp1961 ___))
+          (or #t #t)
+          (list)))
+       'these)
+     (not (not '(+ 4 (+ 1 1))))
+     (vector tlp1963 ___)
+     (list))
+    (list
+     (list tlp1964 ..3)
+     (or (and (? number? tlp1965) (? even? tlp1966))
+         (and (? number? tlp1965) (? even? tlp1966)))
+     (and (? test-struct? tlp1978)
+          (app test-struct-a tlp1967)
+          (app test-struct-b 'symbols)
+          (app test-struct-c tlp1968)
+          (app
+           test-struct-d
+           (list-rest
+             (vector tlp1969 ...)
+             tlp1970
+             (and (? test-struct? tlp1976)
+                  (app test-struct-a tlp1971)
+                  (app test-struct-b tlp1972)
+                  (app test-struct-c tlp1973)
+                  (app test-struct-d tlp1974))
+             5)))
+     (and (list) (list)))
+    (list
+     (list)
+     tlp1979
+     (struct
+       test-struct
+       ((and (? number? tlp1980) (? even? tlp1981))
+        (list)
+        (and (and (? test-struct? tlp1997)
+                  (app
+                   test-struct-a
+                   (list-rest tlp1982 tlp1983 tlp1984 tlp1985))
+                  (app
+                   test-struct-b
+                   (list-rest tlp1986 tlp1987 tlp1988 tlp1989))
+                  (app test-struct-c tlp1990)
+                  (app
+                   test-struct-d
+                   (struct test-struct (tlp1991 tlp1992 tlp1993 tlp1994))))
+             (and (? test-struct? tlp1998)
+                  (app
+                   test-struct-a
+                   (list-rest tlp1999 tlp2000 tlp2001 tlp2002))
+                  (app
+                   test-struct-b
+                   (list-rest tlp2003 tlp2004 tlp2005 tlp2006))
+                  (app test-struct-c tlp2007)
+                  (app
+                   test-struct-d
+                   (struct test-struct (tlp2008 tlp2009 tlp2010 tlp2011)))))
+        (list tlp2012 ..3)))
+     tlp2014))
+  ((baseline 435 414)
+   (reord-no-negate 389 429)
+   (tag-negate 335 340)
+   (code-size-negate 327 335)))
+ ((pattern
+    (list (list tlp1907 ___) (list) 'symbols 'these)
+    (list
+     (list #t (and (list) (list)) (and tlp1908 tlp1909) (list tlp1910 ___))
+     (vector tlp1911 ___)
+     (list-rest (not (not #\b)) '(+ 1 2) tlp1912 #\a)
+     tlp1913)
+    (list
+     (vector
+       (and (? test-struct? tlp1920)
+            (app test-struct-a tlp1914)
+            (app test-struct-b tlp1915)
+            (app test-struct-c (box (list tlp1916 tlp1917 tlp1918)))
+            (app test-struct-d #\b))
+       (list-rest _ (list tlp1921 tlp1922 tlp1923 tlp1924) #f #\d)
+       (and (? test-struct? tlp1936)
+            (app test-struct-a (box (list tlp1925 tlp1926 tlp1927)))
+            (app test-struct-b (list tlp1928 tlp1929 tlp1930 tlp1931))
+            (app test-struct-c (box (list tlp1932 tlp1933 tlp1934)))
+            (app test-struct-d _))
+       (and (? test-struct? tlp1949)
+            (app test-struct-a '(+ 4 5))
+            (app
+             test-struct-b
+             (or (struct test-struct (tlp1937 tlp1938 tlp1939 tlp1940))
+                 (struct test-struct (tlp1937 tlp1938 tlp1939 tlp1940))))
+            (app test-struct-c (list tlp1942 __3))
+            (app
+             test-struct-d
+             (struct test-struct (tlp1943 tlp1944 tlp1945 tlp1946)))))
+     #t
+     _
+     tlp1950))
+  ((baseline 434 288)
+   (reord-no-negate 379 323)
+   (tag-negate 227 162)
+   (code-size-negate 220 165)))
+ ((pattern
+    (list (vector tlp1748 ...) _ (or _ _) (list tlp1749 __3))
+    (list
+     (list tlp1750 ..3)
+     (and tlp1751 tlp1752)
+     tlp1753
+     (list-rest
+       tlp1754
+       (list (list) tlp1755 (list) (box (list tlp1756 tlp1757 tlp1758)))
+       (list-rest
+         (list tlp1759 ___)
+         (and (? number? tlp1760) (? even? tlp1761))
+         (vector tlp1762 tlp1763 tlp1764 tlp1765)
+         #t)
+       #t))
+    (list
+     (and (? test-struct? tlp1777)
+          (app test-struct-a tlp1766)
+          (app test-struct-b (vector tlp1767 ...))
+          (app test-struct-c (vector tlp1768 ___))
+          (app
+           test-struct-d
+           (struct
+             test-struct
+             ((list tlp1769 tlp1770 tlp1771 tlp1772)
+              (list tlp1773 ___)
+              tlp1774
+              #t))))
+     tlp1778
+     (and (? test-struct? tlp1798)
+          (app
+           test-struct-a
+           (list
+            (list-rest tlp1779 tlp1780 tlp1781 #\a)
+            (and (? test-struct? tlp1787)
+                 (app test-struct-a tlp1782)
+                 (app test-struct-b tlp1783)
+                 (app test-struct-c tlp1784)
+                 (app test-struct-d tlp1785))
+            (list tlp1788 ___)
+            (box (list tlp1789 tlp1790 tlp1791))))
+          (app test-struct-b (or '(+ 4 5) '(+ 4 5)))
+          (app
+           test-struct-c
+           (struct test-struct (tlp1792 (vector tlp1793 ...) tlp1794 tlp1795)))
+          (app test-struct-d _))
+     (and (? test-struct? tlp1819)
+          (app
+           test-struct-a
+           (box (list tlp1799 (list tlp1800 ..3) (and tlp1801 tlp1802))))
+          (app
+           test-struct-b
+           (and (? test-struct? tlp1814)
+                (app test-struct-a (list tlp1803 tlp1804 tlp1805 tlp1806))
+                (app test-struct-b (vector tlp1807 tlp1808 tlp1809 tlp1810))
+                (app
+                 test-struct-c
+                 (and (or tlp1811 tlp1811) (or tlp1812 tlp1812)))
+                (app test-struct-d (or (list) (list)))))
+          (app test-struct-c (box (list tlp1815 (list) tlp1816)))
+          (app test-struct-d (vector tlp1817 ...)))))
+  ((baseline 2088 2527)
+   (reord-no-negate 1911 3594)
+   (tag-negate 1911 2828)
+   (code-size-negate 1905 2841)))
+ ((pattern
+    (list
+     (list-rest
+       (list)
+       (and (? test-struct? tlp1720)
+            (app test-struct-a (box (list tlp1715 tlp1716 tlp1717)))
+            (app test-struct-b _)
+            (app test-struct-c 0)
+            (app test-struct-d tlp1718))
+       (not (not '(+ 4 5)))
+       8)
+     '(+ 4 (+ 1 1))
+     (and (? number? tlp1721) (? even? tlp1722))
+     (vector
+       (and (? number? tlp1723) (? even? tlp1724))
+       _
+       (box
+        (list (not (not '(+ 4 (+ 1 1)))) (not (not #t)) (list tlp1725 ___)))
+       (not (not '(+ 1 2)))))
+    (list _ (box (list (list tlp1726 ...) tlp1727 (list))) tlp1728 '(+ 4 5))
+    (list
+     tlp1729
+     #\a
+     (vector
+       (and (? number? tlp1730) (? even? tlp1731))
+       (list-rest
+         '(+ 1 2)
+         (list tlp1732 tlp1733 tlp1734 tlp1735)
+         (list tlp1736 __3)
+         #\b)
+       (list-rest
+         (and (? test-struct? tlp1742)
+              (app test-struct-a tlp1737)
+              (app test-struct-b tlp1738)
+              (app test-struct-c tlp1739)
+              (app test-struct-d tlp1740))
+         (list)
+         (box (list tlp1743 tlp1744 tlp1745))
+         'these)
+       (list))
+     #f))
+  ((baseline 664 441)
+   (reord-no-negate 587 701)
+   (tag-negate 131 118)
+   (code-size-negate 121 119)))
+ ((pattern
+    (list
+     (box (list (list) (list) (list tlp1670 __3)))
+     (not (not '(+ 1 2)))
+     (box
+      (list
+       'symbols
+       (vector
+         (or (list tlp1671 tlp1672 tlp1673 tlp1674)
+             (list tlp1671 tlp1672 tlp1673 tlp1674))
+         tlp1675
+         (vector tlp1676 ...)
+         (list tlp1677 tlp1678 tlp1679 tlp1680))
+       tlp1681))
+     (box
+      (list
+       (vector tlp1682 #f #\a _)
+       (vector
+         (and (? test-struct? tlp1688)
+              (app test-struct-a tlp1683)
+              (app test-struct-b tlp1684)
+              (app test-struct-c tlp1685)
+              (app test-struct-d tlp1686))
+         _
+         (list tlp1689 __3)
+         (box (list tlp1690 tlp1691 tlp1692)))
+       (list))))
+    (list
+     (struct
+       test-struct
+       ((vector
+          (vector tlp1693 tlp1694 tlp1695 tlp1696)
+          (list tlp1697 __3)
+          (not (not #\c))
+          tlp1698)
+        (vector tlp1699 ___)
+        (list tlp1700 ..3)
+        #\b))
+     (struct
+       test-struct
+       (tlp1702
+         (vector
+           (list)
+           (box (list tlp1703 tlp1704 tlp1705))
+           (or (list) (list))
+           tlp1706)
+         _
+         tlp1707))
+     #t
+     tlp1709)
+    (list tlp1710 (vector tlp1711 ___) _ tlp1712))
+  ((baseline 2157 3180)
+   (reord-no-negate 1873 4703)
+   (tag-negate 1873 3225)
+   (code-size-negate 1788 3241)))
+ ((pattern
+    (list
+     (vector
+       (and (? test-struct? tlp1564)
+            (app test-struct-a '(+ 4 (+ 1 1)))
+            (app
+             test-struct-b
+             (and (? test-struct? tlp1562)
+                  (app test-struct-a tlp1557)
+                  (app test-struct-b tlp1558)
+                  (app test-struct-c tlp1559)
+                  (app test-struct-d tlp1560)))
+            (app test-struct-c '(+ 4 5))
+            (app test-struct-d (not (not 3))))
+       (and (box
+             (list
+              (box (list tlp1565 tlp1566 tlp1567))
+              (struct test-struct (tlp1568 tlp1569 tlp1570 tlp1571))
+              (struct test-struct (tlp1573 tlp1574 tlp1575 tlp1576))))
+            (box
+             (list
+              (box (list tlp1578 tlp1579 tlp1580))
+              (struct test-struct (tlp1581 tlp1582 tlp1583 tlp1584))
+              (struct test-struct (tlp1585 tlp1586 tlp1587 tlp1588)))))
+       (or (list-rest
+             (or tlp1589 tlp1589)
+             (and (? test-struct? tlp1595)
+                  (app test-struct-a tlp1590)
+                  (app test-struct-b tlp1591)
+                  (app test-struct-c tlp1592)
+                  (app test-struct-d tlp1593))
+             (vector tlp1596 tlp1597 tlp1598 tlp1599)
+             #t)
+           (list-rest
+             (or tlp1589 tlp1589)
+             (and (? test-struct? tlp1595)
+                  (app test-struct-a tlp1590)
+                  (app test-struct-b tlp1591)
+                  (app test-struct-c tlp1592)
+                  (app test-struct-d tlp1593))
+             (vector tlp1596 tlp1597 tlp1598 tlp1599)
+             #t))
+       (and (? test-struct? tlp1610)
+            (app test-struct-a (list tlp1600 ...))
+            (app test-struct-b (list tlp1601 ...))
+            (app test-struct-c (list tlp1602 tlp1603 tlp1604 tlp1605))
+            (app test-struct-d (list-rest tlp1606 tlp1607 tlp1608 #\b))))
+     (list
+      (and (? number? tlp1611) (? even? tlp1612))
+      (or (and (? number? tlp1613) (? even? tlp1614))
+          (and (? number? tlp1613) (? even? tlp1614)))
+      (box
+       (list
+        (struct test-struct (tlp1615 tlp1616 tlp1617 tlp1618))
+        (and (? number? tlp1620) (? even? tlp1621))
+        #f))
+      (and (? number? tlp1622) (? even? tlp1623)))
+     _
+     (list))
+    (list
+     (box
+      (list
+       (list-rest (vector tlp1624 tlp1625 tlp1626 tlp1627) tlp1628 _ #t)
+       (list tlp1629 ___)
+       (list
+        (vector tlp1630 ___)
+        (and (? test-struct? tlp1636)
+             (app test-struct-a tlp1631)
+             (app test-struct-b tlp1632)
+             (app test-struct-c tlp1633)
+             (app test-struct-d tlp1634))
+        tlp1637
+        tlp1638)))
+     (list tlp1639 ..3)
+     (list-rest _ (list tlp1640 __3) _ #t)
+     (box
+      (list
+       tlp1641
+       #t
+       (vector
+         (and (? number? tlp1642) (? even? tlp1643))
+         (list)
+         #\a
+         (box (list tlp1644 tlp1645 tlp1646))))))
+    (list
+     (list
+      (and (list-rest
+             (not (not 'symbols))
+             _
+             (list-rest tlp1647 tlp1648 tlp1649 tlp1650)
+             0)
+           (list-rest
+             (not (not 'symbols))
+             _
+             (list-rest tlp1651 tlp1652 tlp1653 tlp1654)
+             0))
+      _
+      (struct
+        test-struct
+        ((list-rest tlp1655 tlp1656 tlp1657 #f)
+         (list tlp1658 ...)
+         (and (? test-struct? tlp1664)
+              (app test-struct-a tlp1659)
+              (app test-struct-b tlp1660)
+              (app test-struct-c tlp1661)
+              (app test-struct-d tlp1662))
+         (list tlp1665 ___)))
+      (vector _ (and _ _) (not (not 6)) _))
+     (list tlp1667 __3)
+     (or 9 9)
+     '(+ 4 5)))
+  ((baseline 146 377)
+   (reord-no-negate 389 767)
+   (tag-negate 389 575)
+   (code-size-negate 363 579)))
+ ((pattern
+    (list
+     (struct test-struct ((list tlp1437 ...) (vector tlp1438 ___) #\d 'are))
+     (and (struct
+            test-struct
+            ((list tlp1440 ___)
+             (list-rest
+               (list-rest tlp1441 tlp1442 tlp1443 tlp1444)
+               (list)
+               (and (? number? tlp1445) (? even? tlp1446))
+               #t)
+             (list
+              (list-rest tlp1447 tlp1448 tlp1449 tlp1450)
+              tlp1451
+              (list-rest tlp1452 tlp1453 tlp1454 tlp1455)
+              (and (? test-struct? tlp1461)
+                   (app test-struct-a tlp1456)
+                   (app test-struct-b tlp1457)
+                   (app test-struct-c tlp1458)
+                   (app test-struct-d tlp1459)))
+             (box
+              (list
+               (and (? number? tlp1462) (? even? tlp1463))
+               tlp1464
+               (or tlp1465 tlp1465)))))
+          (struct
+            test-struct
+            ((list tlp1467 ___)
+             (list-rest
+               (list-rest tlp1468 tlp1469 tlp1470 tlp1471)
+               (list)
+               (and (? number? tlp1472) (? even? tlp1473))
+               #t)
+             (list
+              (list-rest tlp1474 tlp1475 tlp1476 tlp1477)
+              tlp1478
+              (list-rest tlp1479 tlp1480 tlp1481 tlp1482)
+              (and (? test-struct? tlp1483)
+                   (app test-struct-a tlp1484)
+                   (app test-struct-b tlp1485)
+                   (app test-struct-c tlp1486)
+                   (app test-struct-d tlp1487)))
+             (box
+              (list
+               (and (? number? tlp1488) (? even? tlp1489))
+               tlp1490
+               (or tlp1491 tlp1491))))))
+     (vector tlp1492 ...)
+     (vector
+       (box (list _ (vector tlp1493 ___) tlp1494))
+       (not (not #\b))
+       (and (? test-struct? tlp1503)
+            (app test-struct-a (and _ _))
+            (app test-struct-b (and (list) (list)))
+            (app test-struct-c (box (list tlp1495 tlp1496 tlp1497)))
+            (app test-struct-d (vector tlp1498 tlp1499 tlp1500 tlp1501)))
+       _))
+    (list
+     (and (vector
+            (and (? test-struct? tlp1509)
+                 (app test-struct-a #\c)
+                 (app test-struct-b _)
+                 (app
+                  test-struct-c
+                  (list-rest tlp1504 tlp1505 tlp1506 tlp1507))
+                 (app test-struct-d (list)))
+            tlp1510
+            (list tlp1511 __3)
+            #\a)
+          (vector
+            (and (? test-struct? tlp1512)
+                 (app test-struct-a #\c)
+                 (app test-struct-b _)
+                 (app
+                  test-struct-c
+                  (list-rest tlp1513 tlp1514 tlp1515 tlp1516))
+                 (app test-struct-d (list)))
+            tlp1517
+            (list tlp1518 __3)
+            #\a))
+     _
+     (struct
+       test-struct
+       ((struct test-struct (#t #\b #\d (or 6 6)))
+        (and (? number? tlp1520) (? even? tlp1521))
+        (or (struct
+              test-struct
+              ((list-rest tlp1522 tlp1523 tlp1524 tlp1525)
+               (list-rest tlp1526 tlp1527 tlp1528 tlp1529)
+               (not (not '(+ 1 2)))
+               (and (? test-struct? tlp1535)
+                    (app test-struct-a tlp1530)
+                    (app test-struct-b tlp1531)
+                    (app test-struct-c tlp1532)
+                    (app test-struct-d tlp1533))))
+            (struct
+              test-struct
+              ((list-rest tlp1522 tlp1523 tlp1524 tlp1525)
+               (list-rest tlp1526 tlp1527 tlp1528 tlp1529)
+               (not (not '(+ 1 2)))
+               (and (? test-struct? tlp1535)
+                    (app test-struct-a tlp1530)
+                    (app test-struct-b tlp1531)
+                    (app test-struct-c tlp1532)
+                    (app test-struct-d tlp1533)))))
+        tlp1537))
+     (and (list
+           (vector tlp1539 ...)
+           #\b
+           (struct test-struct (tlp1540 3 tlp1541 tlp1542))
+           (list tlp1544 ..3))
+          (list
+           (vector tlp1545 ...)
+           #\b
+           (struct test-struct (tlp1546 3 tlp1547 tlp1548))
+           (list tlp1549 ..3))))
+    (list
+     (and tlp1550 tlp1551)
+     (list tlp1552 __3)
+     (list tlp1553 ___)
+     (list tlp1554 ...)))
+  ((baseline 669 876)
+   (reord-no-negate 549 1251)
+   (tag-negate 549 970)
+   (code-size-negate 521 965)))
+ ((pattern
+    (list
+     (list
+      (list tlp1284 ..3)
+      (list)
+      tlp1285
+      (box
+       (list
+        (and (? number? tlp1286) (? even? tlp1287))
+        (or (box (list tlp1288 tlp1289 tlp1290))
+            (box (list tlp1288 tlp1289 tlp1290)))
+        (box (list tlp1291 tlp1292 tlp1293)))))
+     (list tlp1294 __3)
+     2
+     (vector tlp1295 ___)))
+  ((baseline 36 31)
+   (reord-no-negate 36 33)
+   (tag-negate 36 33)
+   (code-size-negate 36 32)))
+ ((pattern
+    (list
+     (vector tlp1281 ___)
+     tlp1282
+     (not (not #\b))
+     (or (list tlp1283 ___) (list tlp1283 ___))))
+  ((baseline 10 6)
+   (reord-no-negate 10 54)
+   (tag-negate 10 6)
+   (code-size-negate 10 6)))
+ ((pattern
+    (list
+     (and (? test-struct? tlp1239)
+          (app test-struct-a (list tlp1235 __3))
+          (app test-struct-b tlp1236)
+          (app test-struct-c (list))
+          (app test-struct-d (list tlp1237 __3)))
+     tlp1240
+     (list-rest
+       (vector tlp1241 ___)
+       (or (or (list tlp1242 tlp1243 tlp1244 tlp1245)
+               (list tlp1242 tlp1243 tlp1244 tlp1245))
+           (or (list tlp1242 tlp1243 tlp1244 tlp1245)
+               (list tlp1242 tlp1243 tlp1244 tlp1245)))
+       (or (struct
+             test-struct
+             ((box (list tlp1246 tlp1247 tlp1248))
+              (list tlp1249 ___)
+              (and (? test-struct? tlp1255)
+                   (app test-struct-a tlp1250)
+                   (app test-struct-b tlp1251)
+                   (app test-struct-c tlp1252)
+                   (app test-struct-d tlp1253))
+              (list tlp1256 tlp1257 tlp1258 tlp1259)))
+           (struct
+             test-struct
+             ((box (list tlp1246 tlp1247 tlp1248))
+              (list tlp1249 ___)
+              (and (? test-struct? tlp1255)
+                   (app test-struct-a tlp1250)
+                   (app test-struct-b tlp1251)
+                   (app test-struct-c tlp1252)
+                   (app test-struct-d tlp1253))
+              (list tlp1256 tlp1257 tlp1258 tlp1259))))
+       'these)
+     (list
+      tlp1261
+      (not (not #t))
+      (box
+       (list
+        (and (? test-struct? tlp1267)
+             (app test-struct-a tlp1262)
+             (app test-struct-b tlp1263)
+             (app test-struct-c tlp1264)
+             (app test-struct-d tlp1265))
+        #\d
+        (list tlp1268 tlp1269 tlp1270 tlp1271)))
+      (list-rest
+        (list)
+        (list-rest tlp1272 tlp1273 tlp1274 #\c)
+        (and (? test-struct? tlp1280)
+             (app test-struct-a tlp1275)
+             (app test-struct-b tlp1276)
+             (app test-struct-c tlp1277)
+             (app test-struct-d tlp1278))
+        #f))))
+  ((baseline 64 201)
+   (reord-no-negate 64 264)
+   (tag-negate 64 213)
+   (code-size-negate 64 213)))
+ ((pattern
+    (list
+     (list
+      #f
+      (list tlp1202 ..3)
+      (vector tlp1203 ___)
+      (list
+       (box (list _ (box (list tlp1204 tlp1205 tlp1206)) (list tlp1207 ___)))
+       (and (? number? tlp1208) (? even? tlp1209))
+       (list)
+       (and (list tlp1210 ...) (list tlp1211 ...))))
+     (list 'symbols (and (? number? tlp1212) (? even? tlp1213)) #f 'are)
+     (list
+      (and tlp1214 tlp1215)
+      (and (? test-struct? tlp1233)
+           (app test-struct-a (vector tlp1216 ___))
+           (app
+            test-struct-b
+            (and (? test-struct? tlp1222)
+                 (app test-struct-a tlp1217)
+                 (app test-struct-b (not (not 4)))
+                 (app test-struct-c (list))
+                 (app test-struct-d (list-rest tlp1218 tlp1219 tlp1220 #\d))))
+           (app test-struct-c (box (list (list) (not (not '(+ 1 2))) (list))))
+           (app
+            test-struct-d
+            (and (? test-struct? tlp1231)
+                 (app test-struct-a (list))
+                 (app test-struct-b (vector tlp1223 ...))
+                 (app test-struct-c tlp1224)
+                 (app
+                  test-struct-d
+                  (struct test-struct (tlp1225 tlp1226 tlp1227 tlp1228))))))
+      (list tlp1234 ___)
+      _)))
+  ((baseline 74 117)
+   (reord-no-negate 74 167)
+   (tag-negate 74 122)
+   (code-size-negate 74 119)))
+ ((pattern
+    (list
+     (list
+      (struct test-struct (tlp1097 (list) (vector tlp1098 ___) (list)))
+      (and (? test-struct? tlp1119)
+           (app test-struct-a (list tlp1100 tlp1101 tlp1102 #\a))
+           (app
+            test-struct-b
+            (and (? test-struct? tlp1107)
+                 (app test-struct-a (list-rest tlp1103 tlp1104 tlp1105 8))
+                 (app test-struct-b _)
+                 (app test-struct-c (or '(+ 4 (+ 1 1)) '(+ 4 (+ 1 1))))
+                 (app test-struct-d _)))
+           (app test-struct-c tlp1108)
+           (app
+            test-struct-d
+            (box
+             (list
+              (list tlp1109 tlp1110 tlp1111 tlp1112)
+              (list tlp1113 ..3)
+              (list tlp1114 tlp1115 tlp1116 tlp1117)))))
+      (and (? test-struct? tlp1142)
+           (app
+            test-struct-a
+            (list
+             (list)
+             tlp1120
+             (struct test-struct (tlp1121 tlp1122 tlp1123 tlp1124))
+             (vector tlp1126 tlp1127 tlp1128 tlp1129)))
+           (app
+            test-struct-b
+            (and (? test-struct? tlp1140)
+                 (app test-struct-a _)
+                 (app
+                  test-struct-b
+                  (or (list-rest tlp1130 tlp1131 tlp1132 tlp1133)
+                      (list-rest tlp1130 tlp1131 tlp1132 tlp1133)))
+                 (app test-struct-c tlp1134)
+                 (app test-struct-d (vector tlp1135 tlp1136 tlp1137 tlp1138))))
+           (app test-struct-c (list))
+           (app test-struct-d (not (not 5))))
+      (and (? number? tlp1143) (? even? tlp1144)))
+     (list
+      '(+ 1 2)
+      'symbols
+      _
+      (struct
+        test-struct
+        ((list
+          (list tlp1145 tlp1146 tlp1147 tlp1148)
+          (vector tlp1149 ___)
+          (and (? number? tlp1150) (? even? tlp1151))
+          (list tlp1152 __3))
+         2
+         (list-rest (list tlp1153 ___) (vector tlp1154 ___) 'symbols 0)
+         tlp1155)))
+     (list
+      (list-rest
+        (list-rest
+          #\c
+          (struct test-struct (tlp1157 tlp1158 tlp1159 tlp1160))
+          (and (list-rest tlp1162 tlp1163 tlp1164 tlp1165)
+               (list-rest tlp1166 tlp1167 tlp1168 tlp1169))
+          #\b)
+        (struct
+          test-struct
+          ((and (and (? test-struct? tlp1175)
+                     (app test-struct-a tlp1170)
+                     (app test-struct-b tlp1171)
+                     (app test-struct-c tlp1172)
+                     (app test-struct-d tlp1173))
+                (and (? test-struct? tlp1176)
+                     (app test-struct-a tlp1177)
+                     (app test-struct-b tlp1178)
+                     (app test-struct-c tlp1179)
+                     (app test-struct-d tlp1180)))
+           tlp1181
+           (and tlp1182 tlp1183)
+           (box (list tlp1184 tlp1185 tlp1186))))
+        (or _ _)
+        #\a)
+      (list
+       _
+       (and (? number? tlp1188) (? even? tlp1189))
+       (list)
+       (and (? test-struct? tlp1199)
+            (app test-struct-a (list tlp1190 ..3))
+            (app test-struct-b (vector tlp1191 tlp1192 tlp1193 tlp1194))
+            (app test-struct-c #f)
+            (app test-struct-d (box (list tlp1195 tlp1196 tlp1197)))))
+      (and (? number? tlp1200) (? even? tlp1201))
+      '(+ 4 5))))
+  ((baseline 145 671)
+   (reord-no-negate 145 942)
+   (tag-negate 145 714)
+   (code-size-negate 145 712)))
+ ((pattern (list (list tlp1094 __3) tlp1095 (list tlp1096 ..3) (list)))
+  ((baseline 11 5)
+   (reord-no-negate 11 50)
+   (tag-negate 11 5)
+   (code-size-negate 11 6)))
+ ((pattern
+    (list
+     (and (? test-struct? tlp1092)
+          (app
+           test-struct-a
+           (struct
+             test-struct
+             ((not (not 'are))
+              tlp1063
+              tlp1064
+              (and (? test-struct? tlp1070)
+                   (app test-struct-a tlp1065)
+                   (app test-struct-b tlp1066)
+                   (app test-struct-c tlp1067)
+                   (app test-struct-d tlp1068)))))
+          (app
+           test-struct-b
+           (struct
+             test-struct
+             ((box (list tlp1072 tlp1073 tlp1074))
+              (and tlp1075 tlp1076)
+              tlp1077
+              (and (list tlp1078 ...) (list tlp1079 ...)))))
+          (app
+           test-struct-c
+           (or (vector
+                 (and tlp1081 tlp1082)
+                 (and (? test-struct? tlp1088)
+                      (app test-struct-a tlp1083)
+                      (app test-struct-b tlp1084)
+                      (app test-struct-c tlp1085)
+                      (app test-struct-d tlp1086))
+                 #\c
+                 #f)
+               (vector
+                 (and tlp1081 tlp1082)
+                 (and (? test-struct? tlp1088)
+                      (app test-struct-a tlp1083)
+                      (app test-struct-b tlp1084)
+                      (app test-struct-c tlp1085)
+                      (app test-struct-d tlp1086))
+                 #\c
+                 #f)))
+          (app test-struct-d (and (? number? tlp1089) (? even? tlp1090))))
+     #t
+     (list tlp1093 ..3)
+     _))
+  ((baseline 27 31)
+   (reord-no-negate 27 33)
+   (tag-negate 27 35)
+   (code-size-negate 27 32)))
+ ((pattern
+    (list
+     (list)
+     (list tlp1052 ...)
+     (list-rest
+       (list tlp1053 ..3)
+       (vector tlp1054 ...)
+       (vector
+         tlp1055
+         (vector tlp1056 ___)
+         (list tlp1057 ...)
+         (box (list tlp1058 tlp1059 tlp1060)))
+       #\d)
+     (and (? number? tlp1061) (? even? tlp1062))))
+  ((baseline 28 25)
+   (reord-no-negate 28 24)
+   (tag-negate 28 77)
+   (code-size-negate 28 24)))
+ ((pattern
+    (list
+     (list)
+     (and (? test-struct? tlp1033)
+          (app test-struct-a tlp1007)
+          (app test-struct-b (and (? number? tlp1008) (? even? tlp1009)))
+          (app
+           test-struct-c
+           (and (? test-struct? tlp1023)
+                (app
+                 test-struct-a
+                 (and (list-rest tlp1010 tlp1011 tlp1012 tlp1013)
+                      (list-rest tlp1014 tlp1015 tlp1016 tlp1017)))
+                (app test-struct-b (list))
+                (app test-struct-c (and (list tlp1018 ___) (list tlp1019 ___)))
+                (app
+                 test-struct-d
+                 (and (? number? tlp1020) (? even? tlp1021)))))
+          (app
+           test-struct-d
+           (and (? test-struct? tlp1031)
+                (app
+                 test-struct-a
+                 (or (and (? number? tlp1024) (? even? tlp1025))
+                     (and (? number? tlp1024) (? even? tlp1025))))
+                (app test-struct-b _)
+                (app test-struct-c (vector tlp1026 tlp1027 tlp1028 tlp1029))
+                (app test-struct-d _))))
+     9
+     (list
+      (struct
+        test-struct
+        ((and (and tlp1034 tlp1035) (and tlp1036 tlp1037))
+         tlp1038
+         (struct test-struct (tlp1039 tlp1040 tlp1041 tlp1042))
+         (and (? test-struct? tlp1049)
+              (app test-struct-a tlp1044)
+              (app test-struct-b tlp1045)
+              (app test-struct-c tlp1046)
+              (app test-struct-d tlp1047))))
+      tlp1051
+      1
+      _)))
+  ((baseline 33 49)
+   (reord-no-negate 33 153)
+   (tag-negate 33 52)
+   (code-size-negate 33 109)))
+ ((pattern
+    (list
+     (box
+      (list
+       (list
+        (list-rest tlp973 tlp974 tlp975 'symbols)
+        (not (not 'these))
+        tlp976
+        (and (? test-struct? tlp982)
+             (app test-struct-a tlp977)
+             (app test-struct-b tlp978)
+             (app test-struct-c tlp979)
+             (app test-struct-d tlp980)))
+       (list
+        (list tlp983 tlp984 tlp985 tlp986)
+        (and (? test-struct? tlp992)
+             (app test-struct-a tlp987)
+             (app test-struct-b tlp988)
+             (app test-struct-c tlp989)
+             (app test-struct-d tlp990))
+        (vector tlp993 tlp994 tlp995 tlp996)
+        (box (list tlp997 tlp998 tlp999)))
+       (or tlp1000 tlp1000)))
+     (and (? test-struct? tlp1005)
+          (app test-struct-a #t)
+          (app test-struct-b (or tlp1001 tlp1001))
+          (app test-struct-c tlp1002)
+          (app test-struct-d (list tlp1003 ...)))
+     (not (not 'these))
+     (list tlp1006 ___)))
+  ((baseline 45 72)
+   (reord-no-negate 45 75)
+   (tag-negate 45 75)
+   (code-size-negate 45 74)))
+ ((pattern
+    (list
+     (or (and #\c #\c) (and #\c #\c))
+     (list tlp963 __3)
+     (not (not #f))
+     (list
+      (and (or (list-rest tlp964 tlp965 tlp966 'are)
+               (list-rest tlp964 tlp965 tlp966 'are))
+           (or (list-rest tlp967 tlp968 tlp969 'are)
+               (list-rest tlp967 tlp968 tlp969 'are)))
+      (list tlp970 __3)
+      tlp971
+      tlp972)))
+  ((baseline 21 24)
+   (reord-no-negate 21 68)
+   (tag-negate 21 23)
+   (code-size-negate 21 22)))
+ ((pattern
+    (list
+     (and (list
+           (list (and (? number? tlp5016) (? even? tlp5017)) (list) #\a (list))
+           (and (? number? tlp5018) (? even? tlp5019))
+           (list)
+           tlp5020)
+          (list
+           (list (and (? number? tlp5021) (? even? tlp5022)) (list) #\a (list))
+           (and (? number? tlp5023) (? even? tlp5024))
+           (list)
+           tlp5025))
+     (or (not (not 'are)) (not (not 'are)))
+     tlp5026
+     (list
+      (struct
+        test-struct
+        (_
+         (or (struct test-struct (tlp5027 tlp5028 tlp5029 tlp5030))
+             (struct test-struct (tlp5027 tlp5028 tlp5029 tlp5030)))
+         (or (list tlp5032 __3) (list tlp5032 __3))
+         (list tlp5033 tlp5034 tlp5035 tlp5036)))
+      (and (? test-struct? tlp5041)
+           (app test-struct-a '(+ 1 2))
+           (app test-struct-b tlp5038)
+           (app test-struct-c (list tlp5039 ___))
+           (app test-struct-d 'are))
+      tlp5042
+      (or (and (? number? tlp5043) (? even? tlp5044))
+          (and (? number? tlp5043) (? even? tlp5044))))))
+  ((baseline 45 64)
+   (reord-no-negate 45 64)
+   (tag-negate 45 65)
+   (code-size-negate 45 62)))
+ ((pattern
+    (list
+     (vector tlp5006 ...)
+     _
+     (vector
+       (list tlp5007 ..3)
+       (box (list (list tlp5008 ___) _ (not (not #t))))
+       tlp5009
+       (list tlp5010 (vector tlp5011 ...) (list) (list)))
+     (and (? number? tlp5012) (? even? tlp5013))))
+  ((baseline 30 22)
+   (reord-no-negate 30 22)
+   (tag-negate 30 23)
+   (code-size-negate 30 23)))
+ ((pattern (list #\b (and (list) (list)) '(+ 4 (+ 1 1)) tlp5003))
+  ((baseline 9 55)
+   (reord-no-negate 9 5)
+   (tag-negate 9 5)
+   (code-size-negate 9 4)))
+ ((pattern
+    (list
+     _
+     (vector tlp4988 ...)
+     tlp4989
+     (box
+      (list
+       (not (not '(+ 4 (+ 1 1))))
+       (struct
+         test-struct
+         ((list-rest tlp4990 tlp4991 tlp4992 4)
+          (struct test-struct (tlp4993 tlp4994 tlp4995 tlp4996))
+          tlp4998
+          #t))
+       tlp5000))))
+  ((baseline 21 18)
+   (reord-no-negate 21 21)
+   (tag-negate 21 72)
+   (code-size-negate 21 19)))
+ ((pattern (list tlp4984 'these (not (not #\b)) tlp4985))
+  ((baseline 8 4)
+   (reord-no-negate 8 49)
+   (tag-negate 8 4)
+   (code-size-negate 8 4)))
+ ((pattern
+    (list
+     (list tlp4527 __3)
+     (list
+      (and (? test-struct? tlp4540)
+           (app
+            test-struct-a
+            (and (struct test-struct (tlp4528 tlp4529 tlp4530 tlp4531))
+                 (struct test-struct (tlp4533 tlp4534 tlp4535 tlp4536))))
+           (app test-struct-b (list tlp4537 ..3))
+           (app test-struct-c #\d)
+           (app test-struct-d (vector tlp4538 ...)))
+      (and (? test-struct? tlp4556)
+           (app test-struct-a (not (not #\b)))
+           (app
+            test-struct-b
+            (and (vector tlp4541 tlp4542 tlp4543 tlp4544)
+                 (vector tlp4545 tlp4546 tlp4547 tlp4548)))
+           (app test-struct-c (vector tlp4549 ...))
+           (app
+            test-struct-d
+            (struct test-struct (tlp4550 tlp4551 tlp4552 tlp4553))))
+      (box
+       (list
+        (and (list tlp4557 __3) (list tlp4558 __3))
+        tlp4559
+        (not (not 4))))
+      tlp4560)
+     (list)
+     (or 'these 'these)))
+  ((baseline 37 47)
+   (reord-no-negate 37 104)
+   (tag-negate 37 49)
+   (code-size-negate 37 51)))
+ ((pattern
+    (list
+     (and (? number? tlp4521) (? even? tlp4522))
+     (or tlp4523 tlp4523)
+     tlp4524
+     (list tlp4525 ...)))
+  ((baseline 9 5)
+   (reord-no-negate 9 6)
+   (tag-negate 9 5)
+   (code-size-negate 9 5)))
+ ((pattern
+    (list
+     (list-rest
+       (and (list
+             (vector tlp4474 tlp4475 tlp4476 tlp4477)
+             (vector tlp4478 tlp4479 tlp4480 tlp4481)
+             (list)
+             (or tlp4482 tlp4482))
+            (list
+             (vector tlp4483 tlp4484 tlp4485 tlp4486)
+             (vector tlp4487 tlp4488 tlp4489 tlp4490)
+             (list)
+             (or tlp4491 tlp4491)))
+       (and (? number? tlp4492) (? even? tlp4493))
+       (list '(+ 1 2) (list tlp4494 ...) tlp4495 tlp4496)
+       #f)
+     (and (? test-struct? tlp4517)
+          (app
+           test-struct-a
+           (or (box
+                (list
+                 (and (? test-struct? tlp4502)
+                      (app test-struct-a tlp4497)
+                      (app test-struct-b tlp4498)
+                      (app test-struct-c tlp4499)
+                      (app test-struct-d tlp4500))
+                 (list)
+                 (vector tlp4503 tlp4504 tlp4505 tlp4506)))
+               (box
+                (list
+                 (and (? test-struct? tlp4502)
+                      (app test-struct-a tlp4497)
+                      (app test-struct-b tlp4498)
+                      (app test-struct-c tlp4499)
+                      (app test-struct-d tlp4500))
+                 (list)
+                 (vector tlp4503 tlp4504 tlp4505 tlp4506)))))
+          (app
+           test-struct-b
+           (and (list-rest
+                  (list tlp4507 ___)
+                  (and (? number? tlp4508) (? even? tlp4509))
+                  (list tlp4510 __3)
+                  'these)
+                (list-rest
+                  (list tlp4511 ___)
+                  (and (? number? tlp4512) (? even? tlp4513))
+                  (list tlp4514 __3)
+                  'these)))
+          (app test-struct-c (or (list tlp4515 ..3) (list tlp4515 ..3)))
+          (app test-struct-d (list)))
+     tlp4518
+     tlp4519))
+  ((baseline 51 88)
+   (reord-no-negate 51 138)
+   (tag-negate 51 94)
+   (code-size-negate 51 144)))
+ ((pattern
+    (list
+     tlp4451
+     tlp4452
+     (and (? test-struct? tlp4471)
+          (app
+           test-struct-a
+           (and (? test-struct? tlp4461)
+                (app test-struct-a (box (list tlp4453 tlp4454 tlp4455)))
+                (app test-struct-b (list tlp4456 ...))
+                (app
+                 test-struct-c
+                 (list-rest tlp4457 tlp4458 tlp4459 'symbols))
+                (app test-struct-d '(+ 4 5))))
+          (app test-struct-b (and (? number? tlp4462) (? even? tlp4463)))
+          (app test-struct-c tlp4464)
+          (app
+           test-struct-d
+           (or (list-rest
+                 (list)
+                 tlp4465
+                 (list tlp4466 tlp4467 tlp4468 tlp4469)
+                 #\b)
+               (list-rest
+                 (list)
+                 tlp4465
+                 (list tlp4466 tlp4467 tlp4468 tlp4469)
+                 #\b))))
+     tlp4472))
+  ((baseline 31 37)
+   (reord-no-negate 31 37)
+   (tag-negate 31 37)
+   (code-size-negate 31 38)))
+ ((pattern
+    (list
+     (not (not 'are))
+     (list-rest
+       tlp4432
+       (list-rest tlp4433 (list tlp4434 ...) tlp4435 'symbols)
+       (not (not 2))
+       'symbols)
+     (not (not #\a))
+     (list
+      (and (? test-struct? tlp4445)
+           (app test-struct-a (list-rest tlp4436 tlp4437 tlp4438 9))
+           (app
+            test-struct-b
+            (and (and tlp4439 tlp4440) (and tlp4441 tlp4442)))
+           (app test-struct-c '(+ 1 2))
+           (app test-struct-d (list tlp4443 ___)))
+      tlp4446
+      (list-rest 'these tlp4447 (list tlp4448 ..3) 'these)
+      (list tlp4449 ___))))
+  ((baseline 38 46)
+   (reord-no-negate 38 90)
+   (tag-negate 38 45)
+   (code-size-negate 38 47)))
+ ((pattern
+    (list
+     (and (? test-struct? tlp3903)
+          (app
+           test-struct-a
+           (and (? test-struct? tlp3891)
+                (app test-struct-a tlp3885)
+                (app test-struct-b (list tlp3886 tlp3887 tlp3888 tlp3889))
+                (app test-struct-c (not (not #\d)))
+                (app test-struct-d _)))
+          (app test-struct-b '(+ 4 5))
+          (app test-struct-c (list))
+          (app
+           test-struct-d
+           (vector
+             (list tlp3892 tlp3893 tlp3894 tlp3895)
+             (and (? test-struct? tlp3901)
+                  (app test-struct-a tlp3896)
+                  (app test-struct-b tlp3897)
+                  (app test-struct-c tlp3898)
+                  (app test-struct-d tlp3899))
+             _
+             (or (list) (list)))))
+     (list tlp3904 ..3)
+     (list tlp3905 ...)
+     (vector
+       (list tlp3906 ...)
+       (list-rest
+         (list tlp3907 ..3)
+         (list-rest tlp3908 tlp3909 tlp3910 #\d)
+         5
+         'are)
+       (list-rest
+         tlp3911
+         (and (? number? tlp3912) (? even? tlp3913))
+         (list tlp3914 ...)
+         #\d)
+       (list tlp3915 #\b (vector tlp3916 ...) (list)))))
+  ((baseline 58 85)
+   (reord-no-negate 58 123)
+   (tag-negate 58 143)
+   (code-size-negate 58 89)))
+ ((pattern
+    (list
+     (box
+      (list
+       tlp3826
+       tlp3827
+       (list-rest
+         (list-rest tlp3828 tlp3829 tlp3830 #t)
+         (list tlp3831 __3)
+         (list-rest tlp3832 tlp3833 tlp3834 'these)
+         #\b)))
+     (list)
+     (and (? test-struct? tlp3857)
+          (app test-struct-a (box (list tlp3835 #\a tlp3836)))
+          (app
+           test-struct-b
+           (and (list
+                 (list tlp3837 __3)
+                 #t
+                 (and (? number? tlp3838) (? even? tlp3839))
+                 (vector tlp3840 ...))
+                (list
+                 (list tlp3841 __3)
+                 #t
+                 (and (? number? tlp3842) (? even? tlp3843))
+                 (vector tlp3844 ...))))
+          (app test-struct-c (list (vector tlp3845 ...) #t tlp3846 (or #f #f)))
+          (app
+           test-struct-d
+           (or (and (? test-struct? tlp3855)
+                    (app test-struct-a #\b)
+                    (app test-struct-b _)
+                    (app
+                     test-struct-c
+                     (struct test-struct (tlp3847 tlp3848 tlp3849 tlp3850)))
+                    (app
+                     test-struct-d
+                     (and (? number? tlp3852) (? even? tlp3853))))
+               (and (? test-struct? tlp3855)
+                    (app test-struct-a #\b)
+                    (app test-struct-b _)
+                    (app
+                     test-struct-c
+                     (struct test-struct (tlp3847 tlp3848 tlp3849 tlp3850)))
+                    (app
+                     test-struct-d
+                     (and (? number? tlp3852) (? even? tlp3853)))))))
+     (list
+      (list-rest
+        (list-rest tlp3858 tlp3859 tlp3860 'these)
+        (box (list tlp3861 tlp3862 tlp3863))
+        (not (not '(+ 4 (+ 1 1))))
+        #\a)
+      (and (list-rest
+             (vector tlp3864 tlp3865 tlp3866 tlp3867)
+             (vector tlp3868 ...)
+             '(+ 4 5)
+             #\d)
+           (list-rest
+             (vector tlp3869 tlp3870 tlp3871 tlp3872)
+             (vector tlp3873 ...)
+             '(+ 4 5)
+             #\d))
+      (not (not #\b))
+      (vector
+        tlp3874
+        (not (not '(+ 1 2)))
+        (list tlp3875 tlp3876 tlp3877 tlp3878)
+        (list tlp3879 tlp3880 tlp3881 tlp3882)))))
+  ((baseline 103 344)
+   (reord-no-negate 103 724)
+   (tag-negate 103 302)
+   (code-size-negate 103 468)))
+ ((pattern
+    (list
+     (struct
+       test-struct
+       ((and (list tlp3735 __3) (list tlp3736 __3))
+        tlp3737
+        (and (? number? tlp3738) (? even? tlp3739))
+        (and (? test-struct? tlp3754)
+             (app
+              test-struct-a
+              (and (? test-struct? tlp3745)
+                   (app test-struct-a tlp3740)
+                   (app test-struct-b tlp3741)
+                   (app test-struct-c tlp3742)
+                   (app test-struct-d tlp3743)))
+             (app
+              test-struct-b
+              (and (vector tlp3746 ___) (vector tlp3747 ___)))
+             (app test-struct-c _)
+             (app
+              test-struct-d
+              (struct test-struct (tlp3748 tlp3749 tlp3750 tlp3751))))))
+     #t
+     (and (vector
+            (list
+             _
+             (and tlp3756 tlp3757)
+             (and (? test-struct? tlp3763)
+                  (app test-struct-a tlp3758)
+                  (app test-struct-b tlp3759)
+                  (app test-struct-c tlp3760)
+                  (app test-struct-d tlp3761))
+             (not (not 'are)))
+            _
+            (struct
+              test-struct
+              ((box (list tlp3764 tlp3765 tlp3766))
+               (vector tlp3767 tlp3768 tlp3769 tlp3770)
+               tlp3771
+               (struct test-struct (tlp3772 tlp3773 tlp3774 tlp3775))))
+            _)
+          (vector
+            (list
+             _
+             (and tlp3778 tlp3779)
+             (and (? test-struct? tlp3780)
+                  (app test-struct-a tlp3781)
+                  (app test-struct-b tlp3782)
+                  (app test-struct-c tlp3783)
+                  (app test-struct-d tlp3784))
+             (not (not 'are)))
+            _
+            (struct
+              test-struct
+              ((box (list tlp3785 tlp3786 tlp3787))
+               (vector tlp3788 tlp3789 tlp3790 tlp3791)
+               tlp3792
+               (struct test-struct (tlp3793 tlp3794 tlp3795 tlp3796))))
+            _))
+     (and (? test-struct? tlp3823)
+          (app
+           test-struct-a
+           (and (? test-struct? tlp3806)
+                (app
+                 test-struct-a
+                 (and (and tlp3797 tlp3798) (and tlp3799 tlp3800)))
+                (app test-struct-b (box (list tlp3801 tlp3802 tlp3803)))
+                (app test-struct-c (or '(+ 4 5) '(+ 4 5)))
+                (app test-struct-d tlp3804)))
+          (app
+           test-struct-b
+           (box
+            (list
+             (box (list tlp3807 tlp3808 tlp3809))
+             #\c
+             (list tlp3810 ..3))))
+          (app test-struct-c _)
+          (app
+           test-struct-d
+           (and (? test-struct? tlp3821)
+                (app test-struct-a tlp3811)
+                (app test-struct-b (list tlp3812 ...))
+                (app
+                 test-struct-c
+                 (and (? test-struct? tlp3818)
+                      (app test-struct-a tlp3813)
+                      (app test-struct-b tlp3814)
+                      (app test-struct-c tlp3815)
+                      (app test-struct-d tlp3816)))
+                (app test-struct-d (vector tlp3819 ___)))))))
+  ((baseline 62 174)
+   (reord-no-negate 62 280)
+   (tag-negate 62 248)
+   (code-size-negate 62 547)))
+ ((pattern
+    (list
+     tlp3721
+     tlp3722
+     (or (list
+          (and (? number? tlp3723) (? even? tlp3724))
+          tlp3725
+          (list)
+          (vector
+            tlp3726
+            (list tlp3727 tlp3728 tlp3729 tlp3730)
+            (list)
+            tlp3731))
+         (list
+          (and (? number? tlp3723) (? even? tlp3724))
+          tlp3725
+          (list)
+          (vector
+            tlp3726
+            (list tlp3727 tlp3728 tlp3729 tlp3730)
+            (list)
+            tlp3731)))
+     (or tlp3732 tlp3732)))
+  ((baseline 22 32)
+   (reord-no-negate 22 76)
+   (tag-negate 22 32)
+   (code-size-negate 22 34)))
+ ((pattern
+    (list
+     3
+     (and (? number? tlp3716) (? even? tlp3717))
+     (and #f #f)
+     (or (vector tlp3718 ___) (vector tlp3718 ___))))
+  ((baseline 14 10)
+   (reord-no-negate 13 8)
+   (tag-negate 13 9)
+   (code-size-negate 13 9)))
+ ((pattern
+    (list
+     (struct
+       test-struct
+       ((not (not #\b))
+        tlp3697
+        (box (list tlp3698 (list tlp3699 ..3) tlp3700))
+        (or _ _)))
+     (list-rest (list) (vector tlp3702 ...) (and 'are 'are) #\d)
+     (box
+      (list
+       tlp3703
+       (vector
+         (list tlp3704 ___)
+         (list tlp3705 ...)
+         (list tlp3706 ___)
+         (vector tlp3707 ...))
+       (list
+        (struct test-struct (tlp3708 tlp3709 tlp3710 tlp3711))
+        #t
+        (list)
+        (list tlp3713 __3))))
+     (vector tlp3714 ___)))
+  ((baseline 47 55)
+   (reord-no-negate 47 53)
+   (tag-negate 47 57)
+   (code-size-negate 47 56)))
+ ((pattern
+    (list
+     tlp3688
+     tlp3689
+     (list
+      (box
+       (list
+        (list tlp3690 ___)
+        (and (? number? tlp3691) (? even? tlp3692))
+        (not (not #\c))))
+      (and (list tlp3693 ...) (list tlp3694 ...))
+      tlp3695
+      (not (not #f)))
+     (vector tlp3696 ...)))
+  ((baseline 24 20)
+   (reord-no-negate 24 19)
+   (tag-negate 24 20)
+   (code-size-negate 24 21)))
+ ((pattern
+    (list
+     tlp3683
+     (list-rest
+       (and #\d #\d)
+       (or (list tlp3684 __3) (list tlp3684 __3))
+       (list)
+       #\d)
+     (and (vector tlp3685 ___) (vector tlp3686 ___))
+     (list tlp3687 ___)))
+  ((baseline 18 12)
+   (reord-no-negate 18 16)
+   (tag-negate 18 13)
+   (code-size-negate 18 70)))
+ ((pattern
+    (list
+     (box
+      (list
+       (struct
+         test-struct
+         ((vector tlp3672 ...)
+          tlp3673
+          (and (not (not #\c)) (not (not #\c)))
+          (list-rest tlp3674 tlp3675 tlp3676 #\d)))
+       tlp3678
+       (and (list tlp3679 ...) (list tlp3680 ...))))
+     _
+     tlp3681
+     tlp3682))
+  ((baseline 20 17)
+   (reord-no-negate 20 59)
+   (tag-negate 20 17)
+   (code-size-negate 20 17)))
+ ((pattern
+    (list
+     (vector
+       (vector tlp3663 ___)
+       (list tlp3664 ___)
+       (and (? number? tlp3665) (? even? tlp3666))
+       (box (list (vector tlp3667 ...) (list tlp3668 ..3) _)))
+     tlp3669
+     (list tlp3670 __3)
+     tlp3671))
+  ((baseline 24 67)
+   (reord-no-negate 24 17)
+   (tag-negate 24 74)
+   (code-size-negate 24 16)))
+ ((pattern
+    (list
+     (list _ (not (not #f)) (not (not #f)) (vector tlp3610 ___))
+     (list
+      (list tlp3611 ...)
+      (vector
+        (list tlp3612 ...)
+        (and tlp3613 tlp3614)
+        (list tlp3615 ...)
+        (and (? test-struct? tlp3626)
+             (app test-struct-a (and (list) (list)))
+             (app test-struct-b tlp3616)
+             (app test-struct-c (vector tlp3617 tlp3618 tlp3619 tlp3620))
+             (app test-struct-d (vector tlp3621 tlp3622 tlp3623 tlp3624))))
+      (and (vector
+             tlp3627
+             (vector tlp3628 ...)
+             (and (? test-struct? tlp3640)
+                  (app test-struct-a _)
+                  (app
+                   test-struct-b
+                   (struct test-struct (tlp3629 tlp3630 tlp3631 tlp3632)))
+                  (app test-struct-c (box (list tlp3634 tlp3635 tlp3636)))
+                  (app test-struct-d (and tlp3637 tlp3638)))
+             tlp3641)
+           (vector
+             tlp3642
+             (vector tlp3643 ...)
+             (and (? test-struct? tlp3644)
+                  (app test-struct-a _)
+                  (app
+                   test-struct-b
+                   (struct test-struct (tlp3645 tlp3646 tlp3647 tlp3648)))
+                  (app test-struct-c (box (list tlp3649 tlp3650 tlp3651)))
+                  (app test-struct-d (and tlp3652 tlp3653)))
+             tlp3654))
+      tlp3655)
+     (list
+      tlp3656
+      #\c
+      tlp3657
+      (list-rest (list tlp3658 __3) #\d (list tlp3659 ___) #\c))
+     (list tlp3660 _ (list) _)
+     (list 'these tlp3661 (list) tlp3662)))
+  ((baseline 71 152)
+   (reord-no-negate 71 310)
+   (tag-negate 71 158)
+   (code-size-negate 71 272)))
+ ((pattern
+    (list
+     (list
+      tlp3534
+      tlp3535
+      (list-rest tlp3536 _ tlp3537 'symbols)
+      (or (or tlp3538 tlp3538) (or tlp3538 tlp3538)))
+     (list
+      (list tlp3539 __3)
+      tlp3540
+      (and (? number? tlp3541) (? even? tlp3542))
+      (and (? number? tlp3543) (? even? tlp3544)))
+     (list
+      (or tlp3545 tlp3545)
+      (or #f #f)
+      (struct
+        test-struct
+        (tlp3546 (list tlp3547 ..3) (list tlp3548 ___) tlp3549))
+      (list-rest (vector tlp3551 ...) 7 #f #\b))
+     (list
+      (box
+       (list
+        (box
+         (list
+          (or tlp3552 tlp3552)
+          tlp3553
+          (and (? number? tlp3554) (? even? tlp3555))))
+        tlp3556
+        (list tlp3557 ___)))
+      (list
+       (list
+        (list-rest tlp3558 tlp3559 tlp3560 #\b)
+        (or (vector tlp3561 ___) (vector tlp3561 ___))
+        (list-rest tlp3562 tlp3563 tlp3564 #\d)
+        tlp3565)
+       (and (? test-struct? tlp3579)
+            (app
+             test-struct-a
+             (struct test-struct (tlp3566 tlp3567 tlp3568 tlp3569)))
+            (app
+             test-struct-b
+             (or (and (? number? tlp3571) (? even? tlp3572))
+                 (and (? number? tlp3571) (? even? tlp3572))))
+            (app
+             test-struct-c
+             (struct test-struct (tlp3573 tlp3574 tlp3575 tlp3576)))
+            (app test-struct-d (not (not 9))))
+       (and tlp3580 tlp3581)
+       (and (? number? tlp3582) (? even? tlp3583)))
+      (vector tlp3584 ___)
+      (or tlp3585 tlp3585))
+     (list
+      (vector tlp3586 ...)
+      #f
+      (list
+       (and (? test-struct? tlp3596)
+            (app test-struct-a (list tlp3587 ...))
+            (app test-struct-b (list-rest tlp3588 tlp3589 tlp3590 #\c))
+            (app test-struct-c (vector tlp3591 tlp3592 tlp3593 tlp3594))
+            (app test-struct-d (not (not #\b))))
+       (struct
+         test-struct
+         (#\a (and (? number? tlp3597) (? even? tlp3598)) _ tlp3599))
+       (list-rest
+         (and (? test-struct? tlp3606)
+              (app test-struct-a tlp3601)
+              (app test-struct-b tlp3602)
+              (app test-struct-c tlp3603)
+              (app test-struct-d tlp3604))
+         (list tlp3607 __3)
+         (and (vector tlp3608 ...) (vector tlp3609 ...))
+         6)
+       '(+ 1 2))
+      #\b)))
+  ((baseline 196 668)
+   (reord-no-negate 141 863)
+   (tag-negate 141 651)
+   (code-size-negate 141 940)))
+ ((pattern
+    (list
+     (list
+      _
+      (list tlp3413 ...)
+      (list
+       (box
+        (list
+         (vector tlp3414 ___)
+         (struct test-struct (tlp3415 tlp3416 tlp3417 tlp3418))
+         (and (? number? tlp3420) (? even? tlp3421))))
+       (list-rest
+         (not (not #\b))
+         (list-rest tlp3422 tlp3423 tlp3424 #\a)
+         (list tlp3425 tlp3426 tlp3427 tlp3428)
+         #\c)
+       (list tlp3429 ...)
+       tlp3430)
+      tlp3431)
+     (list tlp3432 tlp3433 (list tlp3434 ...) (list))
+     (list
+      (list tlp3435 ...)
+      (and (? test-struct? tlp3445)
+           (app test-struct-a (list tlp3436 ..3))
+           (app test-struct-b (list))
+           (app
+            test-struct-c
+            (list-rest
+              (list tlp3437 ___)
+              tlp3438
+              (vector tlp3439 tlp3440 tlp3441 tlp3442)
+              5))
+           (app test-struct-d (vector tlp3443 ___)))
+      (vector
+        (and (and (? test-struct? tlp3456)
+                  (app test-struct-a (list))
+                  (app
+                   test-struct-b
+                   (list-rest tlp3446 tlp3447 tlp3448 tlp3449))
+                  (app test-struct-c (box (list tlp3450 tlp3451 tlp3452)))
+                  (app test-struct-d (and tlp3453 tlp3454)))
+             (and (? test-struct? tlp3457)
+                  (app test-struct-a (list))
+                  (app
+                   test-struct-b
+                   (list-rest tlp3458 tlp3459 tlp3460 tlp3461))
+                  (app test-struct-c (box (list tlp3462 tlp3463 tlp3464)))
+                  (app test-struct-d (and tlp3465 tlp3466))))
+        tlp3467
+        #t
+        (box (list (not (not 2)) (box (list tlp3468 tlp3469 tlp3470)) _)))
+      (and (? test-struct? tlp3475)
+           (app
+            test-struct-a
+            (list-rest _ (or tlp3471 tlp3471) (not (not #f)) #\d))
+           (app test-struct-b tlp3472)
+           (app test-struct-c (list))
+           (app test-struct-d (list tlp3473 ...))))
+     (list
+      (struct
+        test-struct
+        ((and (? number? tlp3476) (? even? tlp3477))
+         (list
+          (or (and (? test-struct? tlp3483)
+                   (app test-struct-a tlp3478)
+                   (app test-struct-b tlp3479)
+                   (app test-struct-c tlp3480)
+                   (app test-struct-d tlp3481))
+              (and (? test-struct? tlp3483)
+                   (app test-struct-a tlp3478)
+                   (app test-struct-b tlp3479)
+                   (app test-struct-c tlp3480)
+                   (app test-struct-d tlp3481)))
+          (vector tlp3484 tlp3485 tlp3486 tlp3487)
+          (box (list tlp3488 tlp3489 tlp3490))
+          '(+ 4 5))
+         (vector tlp3491 ___)
+         tlp3492))
+      (list tlp3494 ..3)
+      (list tlp3495 ..3)
+      tlp3496)
+     (list
+      (list
+       (box
+        (list
+         (list tlp3497 tlp3498 tlp3499 tlp3500)
+         (and _ _)
+         (and (? test-struct? tlp3506)
+              (app test-struct-a tlp3501)
+              (app test-struct-b tlp3502)
+              (app test-struct-c tlp3503)
+              (app test-struct-d tlp3504))))
+       (list tlp3507 ...)
+       (and (? test-struct? tlp3513)
+            (app test-struct-a (box (list tlp3508 tlp3509 tlp3510)))
+            (app test-struct-b (list))
+            (app test-struct-c _)
+            (app test-struct-d (list tlp3511 ___)))
+       (or (and (struct test-struct (tlp3514 tlp3515 tlp3516 tlp3517))
+                (struct test-struct (tlp3519 tlp3520 tlp3521 tlp3522)))
+           (and (struct test-struct (tlp3514 tlp3515 tlp3516 tlp3517))
+                (struct test-struct (tlp3519 tlp3520 tlp3521 tlp3522)))))
+      (list
+       (not (not 9))
+       #f
+       '(+ 4 5)
+       (box
+        (list
+         (and (? test-struct? tlp3528)
+              (app test-struct-a tlp3523)
+              (app test-struct-b tlp3524)
+              (app test-struct-c tlp3525)
+              (app test-struct-d tlp3526))
+         (list tlp3529 __3)
+         (vector tlp3530 tlp3531 tlp3532 tlp3533))))
+      (not (not #\d))
+      9)))
+  ((baseline 180 1159)
+   (reord-no-negate 180 1726)
+   (tag-negate 180 1262)
+   (code-size-negate 180 1837)))
+ ((pattern
+    (list
+     (vector tlp3401 ___)
+     '(+ 1 2)
+     (vector
+       _
+       '(+ 1 2)
+       (and (box
+             (list (list tlp3402 tlp3403 tlp3404 tlp3405) tlp3406 '(+ 1 2)))
+            (box
+             (list (list tlp3407 tlp3408 tlp3409 tlp3410) tlp3411 '(+ 1 2))))
+       (list tlp3412 ..3))
+     _))
+  ((baseline 25 25)
+   (reord-no-negate 25 28)
+   (tag-negate 25 27)
+   (code-size-negate 25 26)))
+ ((pattern
+    (list
+     _
+     (vector
+       (list-rest
+         (list)
+         (and (vector tlp3379 tlp3380 tlp3381 tlp3382)
+              (vector tlp3383 tlp3384 tlp3385 tlp3386))
+         (list tlp3387 ..3)
+         3)
+       (list
+        (list-rest tlp3388 tlp3389 tlp3390 #\a)
+        (or (list tlp3391 ..3) (list tlp3391 ..3))
+        _
+        (struct test-struct (tlp3392 tlp3393 tlp3394 tlp3395)))
+       (and (? number? tlp3397) (? even? tlp3398))
+       tlp3399)
+     tlp3400
+     (list)))
+  ((baseline 32 33)
+   (reord-no-negate 32 34)
+   (tag-negate 32 106)
+   (code-size-negate 32 178)))
+ ((pattern (list (and tlp3376 tlp3377) #\a (list) (vector tlp3378 ...)))
+  ((baseline 10 5)
+   (reord-no-negate 10 5)
+   (tag-negate 10 5)
+   (code-size-negate 10 5)))
+ ((pattern
+    (list
+     (list-rest (and (list tlp3343 ...) (list tlp3344 ...)) (list) tlp3345 #\a)
+     (list-rest (not (not #t)) _ _ #f)
+     #\a
+     (vector
+       _
+       (or (list
+            _
+            tlp3346
+            (list tlp3347 tlp3348 tlp3349 tlp3350)
+            (and (? test-struct? tlp3356)
+                 (app test-struct-a tlp3351)
+                 (app test-struct-b tlp3352)
+                 (app test-struct-c tlp3353)
+                 (app test-struct-d tlp3354)))
+           (list
+            _
+            tlp3346
+            (list tlp3347 tlp3348 tlp3349 tlp3350)
+            (and (? test-struct? tlp3356)
+                 (app test-struct-a tlp3351)
+                 (app test-struct-b tlp3352)
+                 (app test-struct-c tlp3353)
+                 (app test-struct-d tlp3354))))
+       (box
+        (list
+         (vector tlp3357 tlp3358 tlp3359 tlp3360)
+         #\d
+         (and (? number? tlp3361) (? even? tlp3362))))
+       (vector
+         (struct test-struct (tlp3363 tlp3364 tlp3365 tlp3366))
+         (struct test-struct (tlp3368 tlp3369 tlp3370 tlp3371))
+         (and (? number? tlp3373) (? even? tlp3374))
+         tlp3375))))
+  ((baseline 47 158)
+   (reord-no-negate 47 185)
+   (tag-negate 47 70)
+   (code-size-negate 47 263)))
+ ((pattern
+    (list
+     #\d
+     (list (not (not '(+ 4 5))) tlp3332 (not (not #f)) #t)
+     (box
+      (list
+       tlp3333
+       (not (not 7))
+       (list-rest
+         (vector tlp3334 tlp3335 tlp3336 tlp3337)
+         (box (list tlp3338 tlp3339 tlp3340))
+         tlp3341
+         9)))
+     (or (list tlp3342 ___) (list tlp3342 ___))))
+  ((baseline 33 35)
+   (reord-no-negate 33 73)
+   (tag-negate 33 35)
+   (code-size-negate 33 34)))
+ ((pattern
+    (list
+     (list
+      (vector tlp3219 ...)
+      (vector tlp3220 ...)
+      (vector tlp3221 ___)
+      (list))
+     (list 'are tlp3222 #\a 9)
+     (list
+      tlp3223
+      (list
+       (list-rest
+         #\b
+         (struct test-struct (tlp3224 tlp3225 tlp3226 tlp3227))
+         #f
+         'these)
+       (list)
+       (list-rest
+         (vector tlp3229 ...)
+         (or (and (? test-struct? tlp3235)
+                  (app test-struct-a tlp3230)
+                  (app test-struct-b tlp3231)
+                  (app test-struct-c tlp3232)
+                  (app test-struct-d tlp3233))
+             (and (? test-struct? tlp3235)
+                  (app test-struct-a tlp3230)
+                  (app test-struct-b tlp3231)
+                  (app test-struct-c tlp3232)
+                  (app test-struct-d tlp3233)))
+         (vector tlp3236 ___)
+         5)
+       (list))
+      (list tlp3237 ..3)
+      (and (? test-struct? tlp3240)
+           (app test-struct-a (or (list) (list)))
+           (app test-struct-b (vector tlp3238 ...))
+           (app test-struct-c (not (not #\c)))
+           (app test-struct-d #\b)))
+     (list
+      (list tlp3241 ___)
+      (list)
+      (list
+       (and (and (? test-struct? tlp3253)
+                 (app
+                  test-struct-a
+                  (list-rest tlp3242 tlp3243 tlp3244 tlp3245))
+                 (app test-struct-b (vector tlp3246 tlp3247 tlp3248 tlp3249))
+                 (app
+                  test-struct-c
+                  (and (? number? tlp3250) (? even? tlp3251)))
+                 (app test-struct-d _))
+            (and (? test-struct? tlp3254)
+                 (app
+                  test-struct-a
+                  (list-rest tlp3255 tlp3256 tlp3257 tlp3258))
+                 (app test-struct-b (vector tlp3259 tlp3260 tlp3261 tlp3262))
+                 (app
+                  test-struct-c
+                  (and (? number? tlp3263) (? even? tlp3264)))
+                 (app test-struct-d _)))
+       (vector
+         #\a
+         (or 'symbols 'symbols)
+         (vector tlp3265 tlp3266 tlp3267 tlp3268)
+         (box (list tlp3269 tlp3270 tlp3271)))
+       (and (? number? tlp3272) (? even? tlp3273))
+       (list tlp3274 ..3))
+      tlp3275)
+     (list
+      (list-rest
+        tlp3276
+        (struct
+          test-struct
+          (tlp3277
+            (and (vector tlp3278 tlp3279 tlp3280 tlp3281)
+                 (vector tlp3282 tlp3283 tlp3284 tlp3285))
+            (and (not (not #t)) (not (not #t)))
+            tlp3286))
+        (box (list (list tlp3288 ___) (list tlp3289 __3) tlp3290))
+        #\b)
+      (list
+       (or (list) (list))
+       (and (? test-struct? tlp3298)
+            (app test-struct-a _)
+            (app test-struct-b tlp3291)
+            (app test-struct-c (vector tlp3292 ...))
+            (app test-struct-d (vector tlp3293 tlp3294 tlp3295 tlp3296)))
+       tlp3299
+       (and (? test-struct? tlp3313)
+            (app test-struct-a (box (list tlp3300 tlp3301 tlp3302)))
+            (app
+             test-struct-b
+             (struct test-struct (tlp3303 tlp3304 tlp3305 tlp3306)))
+            (app
+             test-struct-c
+             (or (list tlp3308 tlp3309 tlp3310 tlp3311)
+                 (list tlp3308 tlp3309 tlp3310 tlp3311)))
+            (app test-struct-d _)))
+      (box
+       (list
+        (and (? test-struct? tlp3323)
+             (app test-struct-a (list tlp3314 ...))
+             (app test-struct-b (list-rest tlp3315 tlp3316 tlp3317 #\a))
+             (app test-struct-c (vector tlp3318 ___))
+             (app test-struct-d (box (list tlp3319 tlp3320 tlp3321))))
+        (box (list (list tlp3324 __3) (vector tlp3325 ___) (list tlp3326 ___)))
+        (list
+         (list tlp3327 ...)
+         tlp3328
+         (list tlp3329 ...)
+         (list tlp3330 __3))))
+      (list tlp3331 ___))))
+  ((baseline 180 1166)
+   (reord-no-negate 180 1606)
+   (tag-negate 180 1288)
+   (code-size-negate 180 1814)))
+ ((pattern
+    (list
+     (list
+      (and (? number? tlp3212) (? even? tlp3213))
+      (and (? number? tlp3214) (? even? tlp3215))
+      (and (list tlp3216 ___) (list tlp3217 ___))
+      tlp3218)))
+  ((baseline 13 8)
+   (reord-no-negate 13 9)
+   (tag-negate 13 9)
+   (code-size-negate 13 10)))
+ ((pattern (list (and (list) (list)) tlp3210 tlp3211 _))
+  ((baseline 7 3)
+   (reord-no-negate 7 3)
+   (tag-negate 7 4)
+   (code-size-negate 7 3)))
+ ((pattern
+    (list
+     (list
+      (list (and tlp3202 tlp3203) (list tlp3204 ___) tlp3205 tlp3206)
+      tlp3207
+      tlp3208
+      tlp3209)))
+  ((baseline 14 8)
+   (reord-no-negate 14 9)
+   (tag-negate 14 9)
+   (code-size-negate 14 9)))
+ ((pattern
+    (list
+     (and (and (? test-struct? tlp3158)
+               (app
+                test-struct-a
+                (box
+                 (list
+                  (list tlp3125 tlp3126 tlp3127 tlp3128)
+                  (list tlp3129 ___)
+                  (and (? test-struct? tlp3135)
+                       (app test-struct-a tlp3130)
+                       (app test-struct-b tlp3131)
+                       (app test-struct-c tlp3132)
+                       (app test-struct-d tlp3133)))))
+               (app
+                test-struct-b
+                (list-rest
+                  (list tlp3136 tlp3137 tlp3138 tlp3139)
+                  (and (? test-struct? tlp3145)
+                       (app test-struct-a tlp3140)
+                       (app test-struct-b tlp3141)
+                       (app test-struct-c tlp3142)
+                       (app test-struct-d tlp3143))
+                  (vector tlp3146 tlp3147 tlp3148 tlp3149)
+                  #\d))
+               (app test-struct-c (list tlp3150 __3))
+               (app
+                test-struct-d
+                (list
+                 #\b
+                 tlp3151
+                 (and (? number? tlp3152) (? even? tlp3153))
+                 (box (list tlp3154 tlp3155 tlp3156)))))
+          (and (? test-struct? tlp3159)
+               (app
+                test-struct-a
+                (box
+                 (list
+                  (list tlp3160 tlp3161 tlp3162 tlp3163)
+                  (list tlp3164 ___)
+                  (and (? test-struct? tlp3165)
+                       (app test-struct-a tlp3166)
+                       (app test-struct-b tlp3167)
+                       (app test-struct-c tlp3168)
+                       (app test-struct-d tlp3169)))))
+               (app
+                test-struct-b
+                (list-rest
+                  (list tlp3170 tlp3171 tlp3172 tlp3173)
+                  (and (? test-struct? tlp3174)
+                       (app test-struct-a tlp3175)
+                       (app test-struct-b tlp3176)
+                       (app test-struct-c tlp3177)
+                       (app test-struct-d tlp3178))
+                  (vector tlp3179 tlp3180 tlp3181 tlp3182)
+                  #\d))
+               (app test-struct-c (list tlp3183 __3))
+               (app
+                test-struct-d
+                (list
+                 #\b
+                 tlp3184
+                 (and (? number? tlp3185) (? even? tlp3186))
+                 (box (list tlp3187 tlp3188 tlp3189))))))
+     (not (not #\a))
+     (struct
+       test-struct
+       ((vector tlp3190 ...)
+        tlp3191
+        (and (? test-struct? tlp3198)
+             (app test-struct-a (list tlp3192 __3))
+             (app test-struct-b tlp3193)
+             (app test-struct-c (and tlp3194 tlp3195))
+             (app test-struct-d (list tlp3196 ...)))
+        tlp3199))
+     (list tlp3201 __3)))
+  ((baseline 56 141)
+   (reord-no-negate 56 271)
+   (tag-negate 56 201)
+   (code-size-negate 56 306)))
+ ((pattern
+    (list
+     (list tlp3121 __3)
+     (list)
+     (list tlp3122 __3)
+     (and (? number? tlp3123) (? even? tlp3124))))
+  ((baseline 13 7)
+   (reord-no-negate 13 6)
+   (tag-negate 13 7)
+   (code-size-negate 13 7)))
+ ((pattern (list get! b c))
+  ((baseline 5 2)
+   (reord-no-negate 5 3)
+   (tag-negate 5 3)
+   (code-size-negate 5 2)))
+ ((pattern (list set! b c))
+  ((baseline 5 2)
+   (reord-no-negate 5 3)
+   (tag-negate 5 3)
+   (code-size-negate 5 49)))
+ ((pattern (list ? b c))
+  ((baseline 5 2)
+   (reord-no-negate 5 3)
+   (tag-negate 5 2)
+   (code-size-negate 5 3)))
+ ((pattern (list not b c))
+  ((baseline 5 3)
+   (reord-no-negate 5 3)
+   (tag-negate 5 3)
+   (code-size-negate 5 3)))
+ ((pattern (list or b c))
+  ((baseline 5 3)
+   (reord-no-negate 5 2)
+   (tag-negate 5 2)
+   (code-size-negate 5 3)))
+ ((pattern (list and b c))
+  ((baseline 5 2)
+   (reord-no-negate 5 3)
+   (tag-negate 5 3)
+   (code-size-negate 5 2)))
+ ((pattern (list = b c))
+  ((baseline 5 2)
+   (reord-no-negate 5 2)
+   (tag-negate 5 2)
+   (code-size-negate 5 3)))
+ ((pattern (list var b c))
+  ((baseline 5 3)
+   (reord-no-negate 5 3)
+   (tag-negate 5 3)
+   (code-size-negate 5 3)))
+ ((pattern (list $ b c))
+  ((baseline 5 3)
+   (reord-no-negate 5 2)
+   (tag-negate 5 3)
+   (code-size-negate 5 2)))
+ ((pattern (list (var unquote-splicing) b c))
+  ((baseline 5 2)
+   (reord-no-negate 5 3)
+   (tag-negate 5 2)
+   (code-size-negate 5 3)))
+ ((pattern (list (var unquote) b c))
+  ((baseline 5 49)
+   (reord-no-negate 5 4)
+   (tag-negate 5 3)
+   (code-size-negate 5 2)))
+ ((pattern (list (var quote) b c))
+  ((baseline 5 3)
+   (reord-no-negate 5 2)
+   (tag-negate 5 2)
+   (code-size-negate 5 3)))
+ ((pattern (list (var quasiquote) b c))
+  ((baseline 5 5)
+   (reord-no-negate 5 3)
+   (tag-negate 5 3)
+   (code-size-negate 5 2)))
+ ((pattern (list (var ..3) b c))
+  ((baseline 5 2)
+   (reord-no-negate 5 2)
+   (tag-negate 5 2)
+   (code-size-negate 5 3)))
+ ((pattern (list (var _) b c))
+  ((baseline 5 2)
+   (reord-no-negate 5 39)
+   (tag-negate 5 3)
+   (code-size-negate 5 55)))
+ ((pattern (list-rest (and 1 b) ... a (and c 4)))
+  ((baseline 5 4)
+   (reord-no-negate 5 4)
+   (tag-negate 5 51)
+   (code-size-negate 5 3)))
+ ((pattern (list-rest (and 1 b) ... a))
+  ((baseline 3 2)
+   (reord-no-negate 3 2)
+   (tag-negate 3 2)
+   (code-size-negate 3 3)))
+ ((pattern (list-rest 1 ... a))
+  ((baseline 3 2)
+   (reord-no-negate 3 2)
+   (tag-negate 3 2)
+   (code-size-negate 3 2)))
+ ((pattern (list-no-order a b 1 c))
+  ((baseline 3 5)
+   (reord-no-negate 3 4)
+   (tag-negate 3 4)
+   (code-size-negate 3 4)))
+ ((pattern (vector a b (and c (not 5)) ... d))
+  ((baseline 4 3)
+   (reord-no-negate 4 3)
+   (tag-negate 4 4)
+   (code-size-negate 4 5)))
+ ((pattern (vector (vector _ _) ..3 a ...))
+  ((baseline 5 4)
+   (reord-no-negate 5 53)
+   (tag-negate 5 4)
+   (code-size-negate 5 4)))
+ ((pattern
+    (vector (vector 1 ... a ...) ... 7 ...)
+    (vector (vector 1 ... a ...) ... 6 ...)
+    (vector (vector 1 ... a ...) ... 5 ...))
+  ((baseline 37 43)
+   (reord-no-negate 37 44)
+   (tag-negate 37 43)
+   (code-size-negate 37 90)))
+ ((pattern (vector (vector 1 ... 2 ...) ... 5 ...))
+  ((baseline 8 6)
+   (reord-no-negate 8 6)
+   (tag-negate 8 7)
+   (code-size-negate 8 21)))
+ ((pattern (vector (and (? odd?) a) ... 8 (and (? even?) b) ... 7 r ...))
+  ((baseline 7 6)
+   (reord-no-negate 7 6)
+   (tag-negate 7 7)
+   (code-size-negate 7 5)))
+ ((pattern (list (list 1 ... 2 ...) ... 5 ...))
+  ((baseline 12 6)
+   (reord-no-negate 12 41)
+   (tag-negate 12 53)
+   (code-size-negate 12 16)))
+ ((pattern (list (and (not 'in) a) ... (and (not 'is) b) ... c ...))
+  ((baseline 6 6)
+   (reord-no-negate 6 6)
+   (tag-negate 6 6)
+   (code-size-negate 6 27)))
+ ((pattern (list _ ... 2 ...))
+  ((baseline 5 3)
+   (reord-no-negate 5 3)
+   (tag-negate 5 2)
+   (code-size-negate 5 2)))
+ ((pattern (list a ... 2 ...))
+  ((baseline 5 3)
+   (reord-no-negate 5 6)
+   (tag-negate 5 3)
+   (code-size-negate 5 2)))
+ ((pattern (list (and (not 2) a) ... 2 ...))
+  ((baseline 6 4)
+   (reord-no-negate 6 3)
+   (tag-negate 6 4)
+   (code-size-negate 6 3)))
+ ((pattern (list 1 ... 2 ...))
+  ((baseline 6 3)
+   (reord-no-negate 6 3)
+   (tag-negate 6 2)
+   (code-size-negate 6 3)))
+ ((pattern (list 1 ... 2 2 2 2))
+  ((baseline 12 4)
+   (reord-no-negate 12 4)
+   (tag-negate 12 5)
+   (code-size-negate 12 26)))
+ ((pattern
+    (list (list 1 ... a ...) ... 7 ...)
+    (list (list 1 ... a ...) ... 6 ...)
+    (list (list 1 ... a ...) ... 5 ...))
+  ((baseline 51 88)
+   (reord-no-negate 51 39)
+   (tag-negate 51 40)
+   (code-size-negate 51 169)))
+ ((pattern
+    (list (vector (list (vector (list (vector a b) ...) ...) ...) ...) ...))
+  ((baseline 10 17)
+   (reord-no-negate 10 52)
+   (tag-negate 10 65)
+   (code-size-negate 10 36)))
+ ((pattern
+    (vector
+      (vector (vector (vector (vector (vector a b) ...) ...) ...) ...)
+      ...))
+  ((baseline 13 18)
+   (reord-no-negate 13 63)
+   (tag-negate 13 17)
+   (code-size-negate 13 37)))
+ ((pattern (list (list (list (list (list (list a b) ...) ...) ...) ...) ...))
+  ((baseline 9 17)
+   (reord-no-negate 9 17)
+   (tag-negate 9 18)
+   (code-size-negate 9 28)))
+ ((pattern
+    (list (vector (list (vector (list (vector _ ...) ...) ...) ...) ...) ...)
+    _)
+  ((baseline 33 28)
+   (reord-no-negate 33 29)
+   (tag-negate 33 27)
+   (code-size-negate 33 155)))
+ ((pattern
+    (vector
+      (vector (vector (vector (vector (vector _ ...) ...) ...) ...) ...)
+      ...)
+    _)
+  ((baseline 13 16)
+   (reord-no-negate 13 16)
+   (tag-negate 13 63)
+   (code-size-negate 13 97)))
+ ((pattern
+    (list (list (list (list (list (list _ ...) ...) ...) ...) ...) ...)
+    _)
+  ((baseline 34 80)
+   (reord-no-negate 34 117)
+   (tag-negate 34 35)
+   (code-size-negate 34 86)))
+ ((pattern
+    (list (vector (list (vector (list (vector a ..2) ..2) ..2) ..2) ..2) ..2))
+  ((baseline 13 20)
+   (reord-no-negate 13 18)
+   (tag-negate 13 18)
+   (code-size-negate 13 18)))
+ ((pattern
+    (vector
+      (vector (vector (vector (vector (vector a ..2) ..2) ..2) ..2) ..2)
+      ..2))
+  ((baseline 13 17)
+   (reord-no-negate 13 18)
+   (tag-negate 13 66)
+   (code-size-negate 13 70)))
+ ((pattern (list (list (list (list (list (list a ..2) ..2) ..2) ..2) ..2) ..2))
+  ((baseline 13 18)
+   (reord-no-negate 13 100)
+   (tag-negate 13 17)
+   (code-size-negate 13 17)))
+ ((pattern
+    (list (vector (list (vector (list (vector a ...) ...) ...) ...) ...) ...))
+  ((baseline 10 17)
+   (reord-no-negate 10 15)
+   (tag-negate 10 17)
+   (code-size-negate 10 65)))
+ ((pattern
+    (vector
+      (vector (vector (vector (vector (vector a ...) ...) ...) ...) ...)
+      ...))
+  ((baseline 13 63)
+   (reord-no-negate 13 17)
+   (tag-negate 13 16)
+   (code-size-negate 13 16)))
+ ((pattern (list (list (list (list (list (list a ...) ...) ...) ...) ...) ...))
+  ((baseline 7 14)
+   (reord-no-negate 7 14)
+   (tag-negate 7 15)
+   (code-size-negate 7 14)))
+ ((pattern (list (list (list a ...) ...) ...))
+  ((baseline 4 4)
+   (reord-no-negate 4 6)
+   (tag-negate 4 5)
+   (code-size-negate 4 5)))
+ ((pattern (vector (vector (vector a ...) ...) ...))
+  ((baseline 7 5)
+   (reord-no-negate 7 6)
+   (tag-negate 7 53)
+   (code-size-negate 7 55)))
+ ((pattern (box (vector _ (get! get-it))))
+  ((baseline 4 2)
+   (reord-no-negate 4 2)
+   (tag-negate 4 2)
+   (code-size-negate 4 2)))
+ ((pattern (box (list _ (get! get-it))))
+  ((baseline 5 2)
+   (reord-no-negate 5 83)
+   (tag-negate 5 2)
+   (code-size-negate 5 2)))
+ ((pattern (box (get! get-it)))
+  ((baseline 2 2)
+   (reord-no-negate 2 3)
+   (tag-negate 2 2)
+   (code-size-negate 2 1)))
+ ((pattern (vector (get! get-it) _))
+  ((baseline 3 1)
+   (reord-no-negate 3 2)
+   (tag-negate 3 2)
+   (code-size-negate 3 2)))
+ ((pattern (vector _ (get! get-it)))
+  ((baseline 3 1)
+   (reord-no-negate 3 1)
+   (tag-negate 3 2)
+   (code-size-negate 3 1)))
+ ((pattern (list-rest _ _ (list-rest _ _) (get! get-it)))
+  ((baseline 5 2)
+   (reord-no-negate 5 3)
+   (tag-negate 5 2)
+   (code-size-negate 5 3)))
+ ((pattern (list-rest _ _ (list-rest _ (get! get-it)) _))
+  ((baseline 5 2)
+   (reord-no-negate 5 3)
+   (tag-negate 5 3)
+   (code-size-negate 5 3)))
+ ((pattern (list-rest _ _ (list-rest (get! get-it) _) _))
+  ((baseline 5 3)
+   (reord-no-negate 5 2)
+   (tag-negate 5 3)
+   (code-size-negate 5 3)))
+ ((pattern (list-rest _ (get! get-it) (list-rest _ _) _))
+  ((baseline 5 3)
+   (reord-no-negate 5 3)
+   (tag-negate 5 2)
+   (code-size-negate 5 49)))
+ ((pattern (list-rest (get! get-it) _ (list-rest _ _) _))
+  ((baseline 5 3)
+   (reord-no-negate 5 3)
+   (tag-negate 5 3)
+   (code-size-negate 5 3)))
+ ((pattern (list _ (get! get-it) (list _ _)))
+  ((baseline 8 4)
+   (reord-no-negate 8 4)
+   (tag-negate 8 4)
+   (code-size-negate 8 4)))
+ ((pattern (list (get! get-it) _ (list _ _)))
+  ((baseline 8 4)
+   (reord-no-negate 8 4)
+   (tag-negate 8 4)
+   (code-size-negate 8 4)))
+ ((pattern (list _ _ (list _ (get! get-it))))
+  ((baseline 8 4)
+   (reord-no-negate 8 4)
+   (tag-negate 8 4)
+   (code-size-negate 8 3)))
+ ((pattern (list _ _ (list (get! get-it) _)))
+  ((baseline 8 4)
+   (reord-no-negate 8 3)
+   (tag-negate 8 3)
+   (code-size-negate 8 4)))
+ ((pattern (box (vector _ (set! set-it))))
+  ((baseline 4 2)
+   (reord-no-negate 4 3)
+   (tag-negate 4 2)
+   (code-size-negate 4 3)))
+ ((pattern (box (list _ (set! set-it))))
+  ((baseline 5 2)
+   (reord-no-negate 5 3)
+   (tag-negate 5 4)
+   (code-size-negate 5 2)))
+ ((pattern (box (set! set-it)))
+  ((baseline 2 1)
+   (reord-no-negate 2 1)
+   (tag-negate 2 1)
+   (code-size-negate 2 1)))
+ ((pattern (vector (set! set-it) _))
+  ((baseline 3 2)
+   (reord-no-negate 3 1)
+   (tag-negate 3 1)
+   (code-size-negate 3 2)))
+ ((pattern (vector _ (set! set-it)))
+  ((baseline 3 2)
+   (reord-no-negate 3 3)
+   (tag-negate 3 2)
+   (code-size-negate 3 3)))
+ ((pattern (list-rest _ _ (list-rest _ _) (set! set-it)))
+  ((baseline 5 3)
+   (reord-no-negate 5 3)
+   (tag-negate 5 3)
+   (code-size-negate 5 3)))
+ ((pattern (list-rest _ _ (list-rest _ (set! set-it)) _))
+  ((baseline 5 3)
+   (reord-no-negate 5 3)
+   (tag-negate 5 3)
+   (code-size-negate 5 56)))
+ ((pattern (list-rest _ _ (list-rest (set! set-it) _) _))
+  ((baseline 5 3)
+   (reord-no-negate 5 3)
+   (tag-negate 5 3)
+   (code-size-negate 5 3)))
+ ((pattern (list-rest _ (set! set-it) (list-rest _ _) _))
+  ((baseline 5 3)
+   (reord-no-negate 5 2)
+   (tag-negate 5 2)
+   (code-size-negate 5 3)))
+ ((pattern (list-rest (set! set-it) _ (list-rest _ _) _))
+  ((baseline 5 3)
+   (reord-no-negate 5 3)
+   (tag-negate 5 3)
+   (code-size-negate 5 2)))
+ ((pattern (list _ (set! set-it) (list _ _)))
+  ((baseline 8 4)
+   (reord-no-negate 8 4)
+   (tag-negate 8 4)
+   (code-size-negate 8 4)))
+ ((pattern (list (set! set-it) _ (list _ _)))
+  ((baseline 8 4)
+   (reord-no-negate 8 4)
+   (tag-negate 8 4)
+   (code-size-negate 8 4)))
+ ((pattern (list _ _ (list _ (set! set-it))))
+  ((baseline 8 4)
+   (reord-no-negate 8 4)
+   (tag-negate 8 4)
+   (code-size-negate 8 3)))
+ ((pattern (list _ _ (list (set! set-it) _)))
+  ((baseline 8 4)
+   (baseline 8 4)
+   (reord-no-negate 8 38)
+   (reord-no-negate 8 4)
+   (tag-negate 8 3)
+   (tag-negate 8 4)
+   (code-size-negate 8 4)
+   (code-size-negate 8 4)))
+ ((pattern (list (list _) ...))
+  ((baseline 5 3)
+   (reord-no-negate 5 3)
+   (tag-negate 5 3)
+   (code-size-negate 5 2)))
+ ((pattern (list (list a b)))
+  ((baseline 6 2)
+   (reord-no-negate 6 2)
+   (tag-negate 6 3)
+   (code-size-negate 6 2)))
+ ((pattern (list (list a b c) (list d e f)))
+  ((baseline 12 6)
+   (reord-no-negate 12 7)
+   (tag-negate 12 51)
+   (code-size-negate 12 7)))
+ ((pattern (list a b c))
+  ((baseline 5 2)
+   (reord-no-negate 5 4)
+   (tag-negate 5 3)
+   (code-size-negate 5 2)))
+ ((pattern
+    (list
+     (vector
+       #t
+       (list)
+       (list
+        tlp647
+        (or (box (list tlp648 tlp649 tlp650))
+            (box (list tlp648 tlp649 tlp650)))
+        (list tlp651 ...)
+        tlp652)
+       #f)
+     'these
+     tlp653
+     tlp654)
+    (list
+     (list-rest
+       (list tlp655 __3)
+       (list tlp656 ___)
+       (struct
+         test-struct
+         ((and (? test-struct? tlp662)
+               (app test-struct-a tlp657)
+               (app test-struct-b tlp658)
+               (app test-struct-c tlp659)
+               (app test-struct-d tlp660))
+          (list-rest tlp663 tlp664 tlp665 #\a)
+          (list-rest tlp666 tlp667 tlp668 #\b)
+          _))
+       'are)
+     (not (not 'symbols))
+     (and tlp670 tlp671)
+     _))
+  ((baseline 45 91)
+   (reord-no-negate 105 97)
+   (tag-negate 105 63)
+   (code-size-negate 93 156)))
+ ((pattern
+    (list
+     (box
+      (list
+       (and (? number? tlp622) (? even? tlp623))
+       (list-rest
+         (list tlp624 ___)
+         (and (? number? tlp625) (? even? tlp626))
+         #\c
+         #\a)
+       tlp627))
+     tlp628
+     (list tlp629 ___)
+     #\c)
+    (list
+     tlp630
+     (or (vector
+           _
+           (vector tlp631 ...)
+           (vector
+             (list-rest tlp632 tlp633 tlp634 tlp635)
+             (and tlp636 tlp637)
+             #\b
+             (struct test-struct (tlp638 tlp639 tlp640 tlp641)))
+           (list))
+         (vector
+           _
+           (vector tlp631 ...)
+           (vector
+             (list-rest tlp632 tlp633 tlp634 tlp635)
+             (and tlp636 tlp637)
+             #\b
+             (struct test-struct (tlp638 tlp639 tlp640 tlp641)))
+           (list)))
+     #f
+     (and (? number? tlp643) (? even? tlp644))))
+  ((baseline 500 779)
+   (reord-no-negate 299 878)
+   (tag-negate 299 711)
+   (code-size-negate 296 950)))
+ ((pattern
+    (list
+     (list
+      '(+ 4 5)
+      (vector tlp612 ___)
+      (list tlp613 __3)
+      (struct
+        test-struct
+        ((box (list tlp614 tlp615 tlp616)) tlp617 (list) (list))))
+     tlp619
+     (box (list 7 '(+ 4 (+ 1 1)) (list)))
+     _))
+  ((baseline 32 23)
+   (reord-no-negate 32 23)
+   (tag-negate 32 25)
+   (code-size-negate 32 23)))
+ ((pattern (list tlp606 tlp607 (list tlp608 ___) tlp609))
+  ((baseline 7 4)
+   (reord-no-negate 7 4)
+   (tag-negate 7 4)
+   (code-size-negate 7 4)))
+ ((pattern
+    (list
+     (and (? number? tlp581) (? even? tlp582))
+     tlp583
+     (box
+      (list
+       '(+ 4 5)
+       (box
+        (list
+         tlp584
+         (and (? number? tlp585) (? even? tlp586))
+         (or (or tlp587 tlp587) (or tlp587 tlp587))))
+       '(+ 4 5)))
+     (vector tlp588 ...))
+    (list
+     (and (? test-struct? tlp601)
+          (app test-struct-a #f)
+          (app test-struct-b (list tlp589 ...))
+          (app
+           test-struct-c
+           (list
+            (and (? number? tlp590) (? even? tlp591))
+            (vector tlp592 ...)
+            (and (? test-struct? tlp598)
+                 (app test-struct-a tlp593)
+                 (app test-struct-b tlp594)
+                 (app test-struct-c tlp595)
+                 (app test-struct-d tlp596))
+            (list tlp599 __3)))
+          (app test-struct-d '(+ 4 (+ 1 1))))
+     #f
+     (vector tlp602 ___)
+     (list tlp603 ___)))
+  ((baseline 416 253)
+   (reord-no-negate 379 301)
+   (tag-negate 379 257)
+   (code-size-negate 310 302)))
+ ((pattern
+    (list
+     (not (not #f))
+     (box
+      (list
+       tlp556
+       (and (list tlp557 ___) (list tlp558 ___))
+       (and (? number? tlp559) (? even? tlp560))))
+     tlp561
+     (list))
+    (list
+     _
+     (list tlp562 ..3)
+     '(+ 4 (+ 1 1))
+     (vector
+       (list
+        (vector tlp563 tlp564 tlp565 tlp566)
+        tlp567
+        (box (list tlp568 tlp569 tlp570))
+        tlp571)
+       (and tlp572 tlp573)
+       (box
+        (list
+         (box (list tlp574 tlp575 tlp576))
+         (not (not #f))
+         (list-rest tlp577 tlp578 tlp579 #\b)))
+       #f)))
+  ((baseline 89 132)
+   (reord-no-negate 83 251)
+   (tag-negate 83 122)
+   (code-size-negate 76 167)))
+ ((pattern
+    (list
+     tlp551
+     (struct test-struct ((vector tlp552 ...) 'are _ tlp553))
+     (list)
+     (list)))
+  ((baseline 12 7)
+   (reord-no-negate 12 7)
+   (tag-negate 12 6)
+   (code-size-negate 12 7)))
+ ((pattern
+    (list
+     (box
+      (list
+       #\d
+       (box (list tlp509 'are _))
+       (struct
+         test-struct
+         ((struct test-struct (tlp510 tlp511 tlp512 tlp513))
+          (list-rest tlp515 tlp516 tlp517 #\a)
+          (list-rest tlp518 tlp519 tlp520 #\b)
+          tlp521))))
+     (vector tlp523 ___)
+     (and (? test-struct? tlp548)
+          (app test-struct-a 'are)
+          (app
+           test-struct-b
+           (list
+            tlp524
+            (list tlp525 ...)
+            (and (struct test-struct (tlp526 tlp527 tlp528 tlp529))
+                 (struct test-struct (tlp531 tlp532 tlp533 tlp534)))
+            tlp535))
+          (app test-struct-c (list tlp536 ...))
+          (app
+           test-struct-d
+           (and (? test-struct? tlp546)
+                (app
+                 test-struct-a
+                 (and (? test-struct? tlp542)
+                      (app test-struct-a tlp537)
+                      (app test-struct-b tlp538)
+                      (app test-struct-c tlp539)
+                      (app test-struct-d tlp540)))
+                (app test-struct-b (and (? number? tlp543) (? even? tlp544)))
+                (app test-struct-c (list))
+                (app test-struct-d (list)))))
+     tlp549))
+  ((baseline 46 83)
+   (reord-no-negate 46 227)
+   (tag-negate 46 118)
+   (code-size-negate 46 76)))
+ ((pattern
+    (list
+     (list-rest tlp482 tlp483 (list) #\a)
+     (struct
+       test-struct
+       ((list-rest (list tlp484 ___) tlp485 (not (not #t)) 0)
+        (list)
+        tlp486
+        (not (not 7))))
+     (and (? number? tlp488) (? even? tlp489))
+     #\a)
+    (list
+     (list tlp490 ..3)
+     (box
+      (list
+       (and (? number? tlp491) (? even? tlp492))
+       (and (vector
+              (vector tlp493 ...)
+              tlp494
+              (vector tlp495 ...)
+              (box (list tlp496 tlp497 tlp498)))
+            (vector
+              (vector tlp499 ...)
+              tlp500
+              (vector tlp501 ...)
+              (box (list tlp502 tlp503 tlp504))))
+       (and (? number? tlp505) (? even? tlp506))))
+     tlp507
+     #\c))
+  ((baseline 206 183)
+   (reord-no-negate 227 303)
+   (tag-negate 131 203)
+   (code-size-negate 121 177)))
+ ((pattern
+    (list
+     (and (list tlp443 ___) (list tlp444 ___))
+     (box
+      (list
+       (box (list #f tlp445 tlp446))
+       (vector
+         (list tlp447 __3)
+         (list)
+         5
+         (or (vector tlp448 ___) (vector tlp448 ___)))
+       (box
+        (list
+         (or (not (not '(+ 4 (+ 1 1)))) (not (not '(+ 4 (+ 1 1)))))
+         (list)
+         (list-rest tlp449 tlp450 tlp451 #f)))))
+     (vector
+       #\d
+       _
+       (box
+        (list
+         (vector tlp452 ___)
+         (and (list) (list))
+         (and (vector tlp453 ___) (vector tlp454 ___))))
+       (vector
+         (list tlp455 ...)
+         (and (? number? tlp456) (? even? tlp457))
+         (vector tlp458 tlp459 tlp460 tlp461)
+         #\b))
+     (list))
+    (list
+     (list tlp462 ..3)
+     tlp463
+     (list-rest
+       (list-rest
+         #\d
+         (list tlp464 tlp465 tlp466 tlp467)
+         (list-rest tlp468 tlp469 tlp470 'these)
+         #\b)
+       'symbols
+       (and (? test-struct? tlp478)
+            (app test-struct-a tlp471)
+            (app test-struct-b (list))
+            (app test-struct-c tlp472)
+            (app test-struct-d (vector tlp473 tlp474 tlp475 tlp476)))
+       7)
+     tlp479))
+  ((baseline 1364 1184)
+   (reord-no-negate 759 900)
+   (tag-negate 759 1279)
+   (code-size-negate 753 977)))
+ ((pattern
+    (list
+     (list tlp437 ..3)
+     _
+     (and (list tlp438 ..3) (list tlp439 ..3))
+     tlp440))
+  ((baseline 10 6)
+   (reord-no-negate 10 7)
+   (tag-negate 10 6)
+   (code-size-negate 10 6)))
+ ((pattern
+    (list
+     (struct test-struct (tlp406 '(+ 4 (+ 1 1)) (list tlp407 __3) _))
+     _
+     (struct
+       test-struct
+       ((list-rest
+          (vector tlp409 tlp410 tlp411 tlp412)
+          (and (? test-struct? tlp418)
+               (app test-struct-a tlp413)
+               (app test-struct-b tlp414)
+               (app test-struct-c tlp415)
+               (app test-struct-d tlp416))
+          (list-rest tlp419 tlp420 tlp421 'these)
+          #f)
+        (list tlp422 ...)
+        (list)
+        (list tlp423 ...)))
+     (and (? test-struct? tlp434)
+          (app test-struct-a (list))
+          (app test-struct-b tlp425)
+          (app
+           test-struct-c
+           (and (? test-struct? tlp432)
+                (app test-struct-a 'these)
+                (app test-struct-b (and (not (not 3)) (not (not 3))))
+                (app test-struct-c (vector tlp426 tlp427 tlp428 tlp429))
+                (app test-struct-d (list tlp430 ___))))
+          (app test-struct-d 'are))))
+  ((baseline 34 91)
+   (reord-no-negate 34 141)
+   (tag-negate 34 46)
+   (code-size-negate 34 141)))
+ ((pattern (list tlp401 tlp402 (list tlp403 ..3) (vector tlp404 ...)))
+  ((baseline 10 6)
+   (reord-no-negate 10 5)
+   (tag-negate 10 5)
+   (code-size-negate 10 5)))
+ ((pattern
+    (list
+     tlp394
+     (struct
+       test-struct
+       ((and (? number? tlp395) (? even? tlp396))
+        (list)
+        tlp397
+        (vector tlp398 ___)))
+     _
+     (vector tlp400 ...)))
+  ((baseline 14 8)
+   (reord-no-negate 14 10)
+   (tag-negate 14 87)
+   (code-size-negate 14 9)))
+ ((pattern
+    (list
+     (list
+      (box
+       (list
+        (list-rest
+          (not (not 8))
+          (vector tlp380 ...)
+          (and (? test-struct? tlp386)
+               (app test-struct-a tlp381)
+               (app test-struct-b tlp382)
+               (app test-struct-c tlp383)
+               (app test-struct-d tlp384))
+          #\a)
+        (box (list #t (vector tlp387 ___) (list tlp388 ..3)))
+        (and tlp389 tlp390)))
+      (not (not 6))
+      (list)
+      '(+ 4 (+ 1 1)))
+     (list (list tlp391 __3) (not (not 3)) tlp392 (list tlp393 ...))))
+  ((baseline 44 41)
+   (reord-no-negate 44 80)
+   (tag-negate 44 43)
+   (code-size-negate 44 42)))
+ ((pattern
+    (list
+     (list
+      tlp352
+      (vector
+        (box
+         (list
+          (or _ _)
+          (and (? number? tlp353) (? even? tlp354))
+          (struct test-struct (tlp355 tlp356 tlp357 tlp358))))
+        (list
+         _
+         (list tlp360 ..3)
+         (and (? number? tlp361) (? even? tlp362))
+         (or (list tlp363 ..3) (list tlp363 ..3)))
+        (list
+         (not (not 'symbols))
+         (and (and tlp364 tlp365) (and tlp366 tlp367))
+         (struct test-struct (tlp368 tlp369 tlp370 tlp371))
+         _)
+        tlp373)
+      (list-rest (list tlp374 ...) (list tlp375 ...) _ #\c)
+      (and (? number? tlp376) (? even? tlp377)))
+     (list (list) (box (list (list) tlp378 (not (not #\c)))) #\b tlp379)))
+  ((baseline 59 119)
+   (reord-no-negate 59 181)
+   (tag-negate 59 162)
+   (code-size-negate 59 171)))
+ ((pattern
+    (list
+     (vector tlp333 ...)
+     (list-rest
+       (and (? test-struct? tlp335)
+            (app test-struct-a (and _ _))
+            (app test-struct-b (not (not #f)))
+            (app test-struct-c '(+ 4 5))
+            (app test-struct-d 7))
+       (and (? number? tlp336) (? even? tlp337))
+       tlp338
+       'these)
+     (list-rest
+       tlp339
+       (not (not 'these))
+       (struct
+         test-struct
+         ((list)
+          '(+ 4 (+ 1 1))
+          (and (box (list tlp340 tlp341 tlp342))
+               (box (list tlp343 tlp344 tlp345)))
+          (vector tlp346 tlp347 tlp348 tlp349)))
+       #\a)
+     (vector tlp351 ...)))
+  ((baseline 35 41)
+   (reord-no-negate 35 49)
+   (tag-negate 35 120)
+   (code-size-negate 35 42)))
+ ((pattern
+    (list
+     (list
+      (box
+       (list
+        (and (? number? tlp327) (? even? tlp328))
+        (vector tlp329 ...)
+        (list tlp330 ..3)))
+      (list)
+      tlp331
+      (or (vector tlp332 ...) (vector tlp332 ...)))))
+  ((baseline 25 16)
+   (reord-no-negate 23 52)
+   (tag-negate 23 16)
+   (code-size-negate 23 61)))
+ ((pattern
+    `#&("hi"
+        1
+        there
+        #\c
+        #t
+        #f
+        (a b c)
+        (a b . c)
+        (a b c ..2)
+        #3(a b c)
+        #4(a b c ..2)
+        #&(a b c)
+        ,(list a b c)
+        ,(list-rest c1 d e)
+        ,(list f g h ...)
+        ,(vector i j k)
+        ,(box (list l m n o))
+        ,@(list 1 2 3 4 p)))
+  ((baseline 90 278)
+   (reord-no-negate 90 360)
+   (tag-negate 90 393)
+   (code-size-negate 90 376)))
+ ((pattern
+    `#18("hi"
+         1
+         there
+         #\c
+         #t
+         #f
+         (a b c)
+         (a b . c)
+         (a b c ..2)
+         #3(a b c)
+         #4(a b c ..2)
+         #&(a b c)
+         ,(list a b c)
+         ,(list-rest c1 d e)
+         ,(list f g h ...)
+         ,(vector i j k)
+         ,(box (list l m n o))
+         ,@(list 1 2 3 4 p)))
+  ((baseline 68 118)
+   (reord-no-negate 68 162)
+   (tag-negate 68 160)
+   (code-size-negate 68 170)))
+ ((pattern
+    `("hi"
+      1
+      there
+      #\c
+      #t
+      #f
+      (a b c)
+      (a b . c)
+      (a b c ..2)
+      #3(a b c)
+      #4(a b c ..2)
+      #&(a b c)
+      ,(list a b c)
+      ,(list-rest c1 d e)
+      ,(list f g h ...)
+      ,(vector i j k)
+      ,(box (list l m n o))
+      ,@(list 1 2 3 4 p)))
+  ((baseline 89 294)
+   (reord-no-negate 89 336)
+   (tag-negate 89 414)
+   (code-size-negate 89 355)))
+ ((pattern `#&(c a b ,@(list a b c) r f i))
+  ((baseline 18 15)
+   (reord-no-negate 18 12)
+   (tag-negate 18 12)
+   (code-size-negate 18 12)))
+ ((pattern `#7(c a b ,@(list derby b c) r f i))
+  ((baseline 9 4)
+   (reord-no-negate 9 4)
+   (tag-negate 9 46)
+   (code-size-negate 9 4)))
+ ((pattern `#3(x ,x x))
+  ((baseline 5 3)
+   (reord-no-negate 5 3)
+   (tag-negate 5 2)
+   (code-size-negate 5 3)))
+ ((pattern
+    `(3 4 #\c a b ,a ,(list b `(c e)))
+    `(3 4 #\c a b ,a ,(list b `(c d))))
+  ((baseline 26 36)
+   (reord-no-negate 26 67)
+   (tag-negate 26 72)
+   (code-size-negate 23 37)))
+ ((pattern `(c a b ,@(list a b c) r f i))
+  ((baseline 17 13)
+   (reord-no-negate 17 11)
+   (tag-negate 17 53)
+   (code-size-negate 17 11)))
+ ((pattern `(,a ,b ,c))
+  ((baseline 5 3)
+   (reord-no-negate 5 45)
+   (tag-negate 5 3)
+   (code-size-negate 5 89)))
+ ((pattern `(,@`(,x ,y) ,@`(,a ,b)))
+  ((baseline 6 4)
+   (reord-no-negate 6 4)
+   (tag-negate 6 4)
+   (code-size-negate 6 5)))
+ ((pattern `(,b 2 ,@(list 3 4) . b))
+  ((baseline 9 4)
+   (reord-no-negate 9 6)
+   (tag-negate 9 5)
+   (code-size-negate 9 4)))
+ ((pattern `(1 2 ,@(list 3 4) . ,b))
+  ((baseline 9 4)
+   (reord-no-negate 9 4)
+   (tag-negate 9 5)
+   (code-size-negate 9 4)))
+ ((pattern `(a ()))
+  ((baseline 6 3)
+   (reord-no-negate 6 3)
+   (tag-negate 6 3)
+   (code-size-negate 6 2)))
+ ((pattern
+    (list (struct square (a b c d)) 5)
+    (list (struct shape (a)) 5)
+    (list (struct ovoid (a b c)) 5)
+    (list (struct circle (a b c d)) 5))
+  ((baseline 30 70)
+   (reord-no-negate 12 14)
+   (tag-negate 12 13)
+   (code-size-negate 9 15)))
+ ((pattern
+    (list (struct square (a b c d)) 5)
+    (list (struct shape (a)) 2)
+    (list (struct ovoid (a b c)) 5)
+    (list (struct circle (a b c d)) 5))
+  ((baseline 37 17)
+   (reord-no-negate 19 16)
+   (tag-negate 15 86)
+   (code-size-negate 11 12)))
+ ((pattern
+    (list (struct square (a b c d)) 5)
+    (list (struct shape (a)) 2)
+    (list (struct ovoid (a b c)) 2)
+    (list (struct circle (a b c d)) 5))
+  ((baseline 38 17)
+   (reord-no-negate 19 49)
+   (tag-negate 15 13)
+   (code-size-negate 12 13)))
+ ((pattern
+    (list (struct rectangle (a b c)) 5)
+    (list (struct shape (a)) 5)
+    (list (struct ovoid (a b c)) 5)
+    (list (struct circle (a b c d)) 5))
+  ((baseline 30 15)
+   (reord-no-negate 12 14)
+   (tag-negate 12 12)
+   (code-size-negate 9 12)))
+ ((pattern
+    (list (struct rectangle (a b c)) 5)
+    (list (struct shape (a)) 2)
+    (list (struct ovoid (a b c)) 5)
+    (list (struct circle (a b c d)) 5))
+  ((baseline 37 17)
+   (reord-no-negate 19 17)
+   (tag-negate 15 56)
+   (code-size-negate 11 13)))
+ ((pattern
+    (list (struct rectangle (a b c)) 5)
+    (list (struct shape (a)) 2)
+    (list (struct ovoid (a b c)) 2)
+    (list (struct circle (a b c d)) 5))
+  ((baseline 38 37)
+   (reord-no-negate 19 15)
+   (tag-negate 15 12)
+   (code-size-negate 12 56)))
+ ((pattern
+    (list (struct shape (a)) 5)
+    (list (struct ovoid (a b c)) 5)
+    (list (struct circle (a b c d)) 5)
+    (list (struct shape (a)) 6))
+  ((baseline 40 18)
+   (reord-no-negate 22 93)
+   (tag-negate 22 14)
+   (code-size-negate 16 61)))
+ ((pattern
+    (list (struct shape (a)) 5)
+    (list (struct ovoid (a b c)) 5)
+    (list (struct circle (a b c d)) 5))
+  ((baseline 26 53)
+   (reord-no-negate 11 12)
+   (tag-negate 11 9)
+   (code-size-negate 8 8)))
+ ((pattern
+    (list (struct shape (a)) 2)
+    (list (struct ovoid (a b c)) 5)
+    (list (struct circle (a b c d)) 5))
+  ((baseline 31 12)
+   (reord-no-negate 18 12)
+   (tag-negate 14 53)
+   (code-size-negate 10 11)))
+ ((pattern
+    (list (struct shape (a)) 2)
+    (list (struct ovoid (a b c)) 2)
+    (list (struct circle (a b c d)) 5))
+  ((baseline 32 12)
+   (reord-no-negate 16 11)
+   (tag-negate 12 9)
+   (code-size-negate 9 8)))
+ ((pattern (hash-table))
+  ((baseline 3 1)
+   (reord-no-negate 3 1)
+   (tag-negate 3 1)
+   (code-size-negate 3 2)))
+ ((pattern (hash-table ('e v1) ('b v2) rest ...))
+  ((baseline 11 9)
+   (reord-no-negate 11 11)
+   (tag-negate 11 9)
+   (code-size-negate 11 10)))
+ ((pattern (hash-table (k v) ...))
+  ((baseline 6 4)
+   (reord-no-negate 6 5)
+   (tag-negate 6 5)
+   (code-size-negate 6 5)))
+ ((pattern (hash-table (a1 a2) (a (and (not "hello") b)) ...))
+  ((baseline 10 8)
+   (reord-no-negate 10 11)
+   (tag-negate 10 84)
+   (code-size-negate 10 52)))
+ ((pattern (hash-table (a1 a2) (a (? number?)) ...))
+  ((baseline 10 8)
+   (reord-no-negate 10 11)
+   (tag-negate 10 8)
+   (code-size-negate 10 8)))
+ ((pattern (hash-table (c 3) ('b b) (a 1) ..5) _)
+  ((baseline 15 13)
+   (reord-no-negate 15 12)
+   (tag-negate 15 13)
+   (code-size-negate 15 12)))
+ ((pattern (hash-table (c 3) ('b b) (a 1) ..4))
+  ((baseline 15 12)
+   (reord-no-negate 15 82)
+   (tag-negate 15 12)
+   (code-size-negate 15 55)))
+ ((pattern (hash-table (c 3) ('b b) (a 1) ...))
+  ((baseline 15 52)
+   (reord-no-negate 15 13)
+   (tag-negate 15 84)
+   (code-size-negate 15 12)))
+ ((pattern (hash-table (c 3) ('b b) (a 1)))
+  ((baseline 15 12)
+   (reord-no-negate 15 12)
+   (tag-negate 15 13)
+   (code-size-negate 15 12)))
+ ((pattern (hash-table (a 3) (b 1) (c 2)))
+  ((baseline 15 13)
+   (reord-no-negate 15 12)
+   (tag-negate 15 13)
+   (code-size-negate 15 13)))
+ ((pattern (hash-table ('c c) ('a a) ('b b)))
+  ((baseline 15 13)
+   (reord-no-negate 15 16)
+   (tag-negate 15 54)
+   (code-size-negate 15 13)))
+ ((pattern (hash-table ('a a) b ('c c)))
+  ((baseline 11 10)
+   (reord-no-negate 11 11)
+   (tag-negate 11 10)
+   (code-size-negate 11 11)))
+ ((pattern (list-no-order))
+  ((baseline 2 1)
+   (reord-no-negate 2 2)
+   (tag-negate 2 1)
+   (code-size-negate 2 1)))
+ ((pattern
+    (list-no-order
+      (and (? number?) a)
+      (and (? symbol?) b)
+      (and (? symbol?) c)
+      (and (? symbol?) d)
+      (and (? symbol?) e)
+      f
+      ...))
+  ((baseline 7 10)
+   (reord-no-negate 7 13)
+   (tag-negate 7 10)
+   (code-size-negate 7 10)))
+ ((pattern
+    (list-no-order
+      (and (? number?) a)
+      (and (? number?) b)
+      (and (? number?) c)
+      (and (? number?) d)
+      (and (? symbol?) e)
+      f
+      ...))
+  ((baseline 7 10)
+   (reord-no-negate 7 88)
+   (tag-negate 7 86)
+   (code-size-negate 7 54)))
+ ((pattern (list-no-order a b c ...))
+  ((baseline 2 3)
+   (reord-no-negate 2 4)
+   (tag-negate 2 3)
+   (code-size-negate 2 3)))
+ ((pattern (list-no-order a b c 3 ...))
+  ((baseline 4 4)
+   (reord-no-negate 4 5)
+   (tag-negate 4 4)
+   (code-size-negate 4 4)))
+ ((pattern (list-no-order 5 4 2 3 1 g ...))
+  ((baseline 7 50)
+   (reord-no-negate 7 7)
+   (tag-negate 7 7)
+   (code-size-negate 7 7)))
+ ((pattern (list-no-order 5 a 2 b 1 c 7))
+  ((baseline 6 8)
+   (reord-no-negate 6 8)
+   (tag-negate 6 8)
+   (code-size-negate 6 8)))
+ ((pattern (list-no-order 5 4 2 3 1 c b))
+  ((baseline 7 7)
+   (reord-no-negate 7 8)
+   (tag-negate 7 7)
+   (code-size-negate 7 7)))
+ ((pattern
+    `(fish1 fish1 fish1 fish1 fish1)
+    `(,(or `fish1 `fish2)
+      ,(or `fish1 `fish2)
+      ,(or `fish1 `fish2)
+      ,(or `fish1 `fish2)
+      ,(or `fish1 `fish2))
+    `(,(or `fish1 `fish3)
+      ,(or `fish1 `fish3)
+      ,(or `fish1 `fish3)
+      ,(or `fish1 `fish3)
+      ,(or `fish1 `fish3))
+    `(fish1 fish1 fish1 fish1 ,_)
+    `(,(or `fish1 `fish2)
+      ,(or `fish1 `fish2)
+      ,(or `fish1 `fish2)
+      ,(or `fish1 `fish2)
+      ,_)
+    `(,(or `fish1 `fish3)
+      ,(or `fish1 `fish3)
+      ,(or `fish1 `fish3)
+      ,(or `fish1 `fish3)
+      ,_)
+    `(fish1 fish1 fish1 ,_ ,_)
+    `(,(or `fish1 `fish2) ,(or `fish1 `fish2) ,(or `fish1 `fish2) ,_ ,_)
+    `(,(or `fish1 `fish3) ,(or `fish1 `fish3) ,(or `fish1 `fish3) ,_ ,_)
+    `(fish1 fish1 ,_ ,_ ,_)
+    `(,(or `fish1 `fish2) ,(or `fish1 `fish2) ,_ ,_ ,_)
+    `(,(or `fish1 `fish3) ,(or `fish1 `fish3) ,_ ,_ ,_)
+    `(,(or `fish1 `fish2 `fish3) ,_ ,_ ,_ ,_)
+    `(bells bells bells bells bells)
+    `(bells bells bells bells ,_)
+    `(bells bells bells ,_ ,_)
+    `(eggplant eggplant eggplant eggplant eggplant)
+    `(eggplant eggplant eggplant eggplant ,_)
+    `(eggplant eggplant eggplant ,_ ,_)
+    `(cherry cherry cherry cherry cherry)
+    `(cherry cherry cherry cherry ,_)
+    `(cherry cherry cherry ,_ ,_)
+    `(watermelon watermelon watermelon watermelon watermelon)
+    `(watermelon watermelon watermelon watermelon ,_)
+    `(watermelon watermelon watermelon ,_ ,_)
+    `(orange orange orange orange orange)
+    `(orange orange orange orange ,_)
+    `(orange orange orange ,_ ,_)
+    `(lure1 lure1 lure1 lure1 lure1)
+    (or `(,_ lure1 lure1 lure1 lure1) `(lure1 lure1 lure1 lure1 ,_))
+    (or `(,_ ,_ lure3 lure3 lure3)
+        `(,_ lure3 lure3 lure3 ,_)
+        `(lure3 lure3 lure3 ,_ ,_)
+        `(,_ ,_ lure2 lure2 lure2)
+        `(,_ lure2 lure2 lure2 ,_)
+        `(lure2 lure2 lure2 ,_ ,_)
+        `(,_ ,_ lure1 lure1 lure1)
+        `(,_ lure1 lure1 lure1 ,_)
+        `(lure1 lure1 lure1 ,_ ,_))
+    else)
+  ((baseline 961 46369)
+   (reord-no-negate 541 9980)
+   (tag-negate 541 12023)
+   (code-size-negate 541 11543)))
+ ((pattern
+    (struct a60:subscript (array index))
+    (struct a60:binary (type argtype op e1 e2))
+    (struct a60:unary (type argtype op e1))
+    (struct a60:variable (var subscripts))
+    (struct a60:app (func args))
+    else)
+  ((baseline 6 5)
+   (reord-no-negate 6 5)
+   (tag-negate 6 5)
+   (code-size-negate 6 5)))
+ ((pattern
+    (? (lambda (x) (and (syntax? x) (number? (syntax-e x)))) n)
+    (? (lambda (x) (and (syntax? x) (boolean? (syntax-e x)))) n)
+    (? (lambda (x) (and (syntax? x) (string? (syntax-e x)))) n)
+    (? identifier? i)
+    (? symbol? i)
+    (struct a60:subscript (array index))
+    (struct a60:binary (t argt op e1 e2))
+    (struct a60:unary (t argt op e1))
+    (struct a60:variable (var subscripts))
+    (struct a60:app (func args))
+    (struct a60:if (test then else))
+    else)
+  ((baseline 12 10)
+   (reord-no-negate 12 10)
+   (tag-negate 12 62)
+   (code-size-negate 12 73)))
+ ((pattern
+    (struct a60:block (decls statements))
+    (struct
+      a60:branch
+      (test (struct a60:goto (then)) (struct a60:goto (else))))
+    (struct a60:goto (label))
+    (struct a60:dummy ())
+    (struct a60:call (proc args))
+    (struct a60:assign (vars val))
+    else)
+  ((baseline 9 7)
+   (reord-no-negate 9 7)
+   (tag-negate 9 7)
+   (code-size-negate 9 7)))
+ ((pattern
+    (struct
+      |Minus|
+      ((struct
+         <tuple>
+         ((list
+           (struct |Val| ((struct |Num| (n1))))
+           (struct |Val| ((struct |Num| (n2)))))))))
+    (struct |Minus| ((struct <tuple> ((list (struct |Val| (v1)) m2)))))
+    (struct |Minus| ((struct <tuple> ((list m1 m2)))))
+    (struct
+      |Times|
+      ((struct
+         <tuple>
+         ((list
+           (struct |Val| ((struct |Num| (n1))))
+           (struct |Val| ((struct |Num| (n2)))))))))
+    (struct |Times| ((struct <tuple> ((list (struct |Val| (v1)) m2)))))
+    (struct |Times| ((struct <tuple> ((list m1 m2)))))
+    (struct
+      |App|
+      ((struct
+         <tuple>
+         ((list
+           (struct |Val| ((struct |Lam| ((struct <tuple> ((list x t m)))))))
+           (struct |Val| (v)))))))
+    (struct |App| ((struct <tuple> ((list (struct |Val| (f)) m2)))))
+    (struct |App| ((struct <tuple> ((list m1 m2)))))
+    (struct
+      |IfZero|
+      ((struct <tuple> ((list (struct |Val| ((struct |Num| (0)))) m2 m3)))))
+    (struct
+      |IfZero|
+      ((struct <tuple> ((list (struct |Val| ((struct |Num| (n)))) m2 m3)))))
+    (struct |IfZero| ((struct <tuple> ((list m1 m2 m3)))))
+    (struct
+      |Fix|
+      ((struct |Val| ((struct |Lam| ((struct <tuple> ((list x t m)))))))))
+    (struct |Fix| (m))
+    _)
+  ((baseline 85 266)
+   (reord-no-negate 49 210)
+   (tag-negate 49 210)
+   (code-size-negate 49 318)))
+ ((pattern
+    (list 1 2 3 4 5)
+    (list 2 3 4 5 6)
+    (list 4 5 3 6 2)
+    (list 7 8 9 3 4)
+    (list 4 8 3 2 3))
+  ((baseline 50 88)
+   (reord-no-negate 57 244)
+   (tag-negate 55 94)
+   (code-size-negate 32 149)))
+ ((pattern (list 1 2 3) (list 4 5 6))
+  ((baseline 14 7)
+   (reord-no-negate 17 28)
+   (tag-negate 17 6)
+   (code-size-negate 11 6))))
diff --git a/collects/tests/mzscheme/match/match-performance.ss b/collects/tests/mzscheme/match/match-performance.ss
new file mode 100644
index 0000000000..5d639a1b20
--- /dev/null
+++ b/collects/tests/mzscheme/match/match-performance.ss
@@ -0,0 +1,3496 @@
+(load-relative "../loadtest.ss")
+(SECTION 'MATCH-PERFORMANCE)
+
+(require (lib "pretty.ss"))
+(require-for-syntax (lib "pretty.ss"))
+(require (lib "include.ss"))
+(require (lib "plt-match.ss"))
+
+(include "match-compile-perf.scm")
+(include "drom-algol-structs.scm")
+(include "misc-structs.scm")
+
+(match-performance-test
+ (file
+  ;; this is the name of the underlying file that handles the 
+  ;; persistance of test data between invocations of this performance test
+  ;; Each time a test is run one has the option to only compare current
+  ;; data with previous data or one can modify the database file by appending
+  ;; hopefullly improved data.
+  ;; For most purposes it is advisable not to alter the database.
+  (name "match-perf-hist.db")
+  ;; onlly one of the following options is allowed
+  ;; write-new   ;; uncomment to write an new test database 
+                 ;; (this requires the whole-list display option below)
+  ;; add-results ;; uncomment to append the results of the current test
+                 ;; to the database
+  )
+ (tag
+  ;; only one option is allowed 
+  ;; this is the name of the tag placed on data generted by this test
+  backtrack
+  ;; other options are 
+  ;; date ;; to tag new date with a date
+  ;; time ;; to tag new date with a time
+  )
+ (display
+  ;; only one option is allowed
+  ;; remember negative -> good  and positive -> bad 
+  ;; positive-change       ;; displays increases in node counts
+  ;; other options are:
+  ;; negative-change    ;; displays decreases in node counts
+  ;; change             ;; to display any change in node count
+  percent-change             ;; to display any change in node count
+  ;; rt-percent-change             ;; to display any change in node count
+  ;; rt-positive-change ;; same as above but for real compile time
+  ;; rt-negative-change
+  ;; rt-change
+  ;; whole-list         ;; display whole database line with current test appended
+  ;; last-two ;; display only the current result with the previous result
+  )
+ (patterns
+  (pattern (list 1 2 3)
+           (list 4 5 6))
+  (pattern (list 1 2 3 4 5)
+           (list 2 3 4 5 6)
+           (list 4 5 3 6 2)
+           (list 7 8 9 3 4)
+           (list 4 8 3 2 3))
+  ;; dromedary
+  (pattern
+   (struct |Minus| ((struct <tuple> ((list (struct |Val| ((struct |Num| (n1)))) (struct |Val| ((struct |Num| (n2)))))))))
+   (struct |Minus| ((struct <tuple> ((list (struct |Val| (v1)) m2)))))
+   (struct |Minus| ((struct <tuple> ((list m1 m2)))))
+   (struct |Times| ((struct <tuple> ((list (struct |Val| ((struct |Num| (n1)))) (struct |Val| ((struct |Num| (n2)))))))))
+   (struct |Times| ((struct <tuple> ((list (struct |Val| (v1)) m2)))))
+   (struct |Times| ((struct <tuple> ((list m1 m2)))))
+   (struct |App| ((struct <tuple> ((list (struct |Val| ((struct |Lam| ((struct <tuple>
+                                                                               ((list x t m))))))) (struct |Val| (v)))))))
+   (struct |App| ((struct <tuple> ((list (struct |Val| (f)) m2)))))
+   (struct |App| ((struct <tuple> ((list m1 m2)))))
+   (struct |IfZero| ((struct <tuple> ((list (struct |Val| ((struct |Num| (0)))) m2 m3)))))
+   (struct |IfZero| ((struct <tuple> ((list (struct |Val| ((struct |Num| (n)))) m2 m3)))))
+   (struct |IfZero| ((struct <tuple> ((list m1 m2 m3)))))
+   (struct |Fix| ((struct |Val| ((struct |Lam| ((struct <tuple> ((list x t m)))))))))
+   (struct |Fix| (m))
+   _)
+;; algol test
+  (pattern
+   (struct a60:block (decls statements))
+   (struct a60:branch (test (struct a60:goto (then)) (struct a60:goto (else))))
+   (struct a60:goto (label))
+   (struct a60:dummy ())
+   (struct a60:call (proc args))
+   (struct a60:assign (vars val))
+   else)
+  (pattern
+   (? (lambda (x) (and (syntax? x) (number? (syntax-e x)))) n)
+   (? (lambda (x) (and (syntax? x) (boolean? (syntax-e x)))) n)
+   (? (lambda (x) (and (syntax? x) (string? (syntax-e x)))) n)
+   (? identifier? i)
+   (? symbol? i)
+   (struct a60:subscript (array index))
+   (struct a60:binary (t argt op e1 e2))
+   (struct a60:unary (t argt op e1))
+   (struct a60:variable (var subscripts))
+   (struct a60:app (func args))
+   (struct a60:if (test then else))
+   else)
+  (pattern
+   (struct a60:subscript (array index))
+   (struct a60:binary (type argtype op e1 e2))
+   (struct a60:unary (type argtype op e1))
+   (struct a60:variable (var subscripts))
+   (struct a60:app (func args))
+   else)
+
+  ;; tahoe test
+  (pattern
+   `(fish1 fish1 fish1 fish1 fish1)
+   `(,(or `fish1 `fish2) ,(or `fish1 `fish2) ,(or `fish1 `fish2) ,(or `fish1 `fish2) ,(or `fish1 `fish2))
+   `(,(or `fish1 `fish3) ,(or `fish1 `fish3) ,(or `fish1 `fish3) ,(or `fish1 `fish3) ,(or `fish1 `fish3))
+   `(fish1 fish1 fish1 fish1 ,_)
+    `(,(or `fish1 `fish2) ,(or `fish1 `fish2) ,(or `fish1 `fish2) ,(or `fish1 `fish2) ,_)
+    `(,(or `fish1 `fish3) ,(or `fish1 `fish3) ,(or `fish1 `fish3) ,(or `fish1 `fish3) ,_)
+   `(fish1 fish1 fish1 ,_ ,_)
+   `(,(or `fish1 `fish2) ,(or `fish1 `fish2) ,(or `fish1 `fish2) ,_ ,_)
+   `(,(or `fish1 `fish3) ,(or `fish1 `fish3) ,(or `fish1 `fish3) ,_ ,_)
+   `(fish1 fish1 ,_ ,_ ,_)
+  `(,(or `fish1 `fish2) ,(or `fish1 `fish2) ,_ ,_ ,_)
+  `(,(or `fish1 `fish3) ,(or `fish1 `fish3) ,_ ,_ ,_)
+  `(,(or `fish1 `fish2 `fish3) ,_ ,_ ,_ ,_)
+   `(bells bells bells bells bells)
+   `(bells bells bells bells ,_)
+   `(bells bells bells ,_ ,_)
+   `(eggplant eggplant eggplant eggplant eggplant)
+   `(eggplant eggplant eggplant eggplant ,_)
+   `(eggplant eggplant eggplant ,_ ,_)
+   `(cherry cherry cherry cherry cherry)
+   `(cherry cherry cherry cherry ,_)
+   `(cherry cherry cherry ,_ ,_)
+   `(watermelon watermelon watermelon watermelon watermelon)
+   `(watermelon watermelon watermelon watermelon ,_)
+   `(watermelon watermelon watermelon ,_ ,_)
+   `(orange orange orange orange orange)
+   `(orange orange orange orange ,_)
+   `(orange orange orange ,_ ,_)
+   `(lure1 lure1 lure1 lure1 lure1)
+   (or `(,_ lure1 lure1 lure1 lure1)
+       `(lure1 lure1 lure1 lure1 ,_))
+   (or `(,_ ,_ lure3 lure3 lure3)
+       `(,_ lure3 lure3 lure3 ,_)
+       `(lure3 lure3 lure3 ,_ ,_)
+       `(,_ ,_ lure2 lure2 lure2)
+       `(,_ lure2 lure2 lure2 ,_)
+       `(lure2 lure2 lure2 ,_ ,_)
+       `(,_ ,_ lure1 lure1 lure1)
+       `(,_ lure1 lure1 lure1 ,_)
+       `(lure1 lure1 lure1 ,_ ,_))
+   else)
+
+;; misc patterns
+  (pattern
+   (list-no-order 5 4 2 3 1 c b)
+   )
+
+  (pattern
+   (list-no-order 5 a 2 b 1 c 7)
+   )
+
+  (pattern
+   (list-no-order 5 4 2 3 1 g ...)
+   )
+
+  (pattern
+   (list-no-order a b c 3 ...)
+   )
+
+  (pattern
+   (list-no-order a b c ...)
+   )
+
+  (pattern
+   (list-no-order
+    (and (? number?) a)
+    (and (? number?) b)
+    (and (? number?) c)
+    (and (? number?) d)
+    (and (? symbol?) e)
+    f
+    ...)
+   )
+
+  (pattern
+   (list-no-order
+    (and (? number?) a)
+    (and (? symbol?) b)
+    (and (? symbol?) c)
+    (and (? symbol?) d)
+    (and (? symbol?) e)
+    f
+    ...)
+   )
+
+  (pattern
+   (list-no-order)
+   )
+
+  (pattern
+   (hash-table ('a a) b ('c c))
+   )
+
+  (pattern
+   (hash-table ('c c) ('a a) ('b b))
+   )
+
+  (pattern
+   (hash-table (a 3) (b 1) (c 2))
+   )
+
+  (pattern
+   (hash-table (c 3) ('b b) (a 1))
+   )
+
+  (pattern
+   (hash-table (c 3) ('b b) (a 1) ...)
+   )
+
+  (pattern
+   (hash-table (c 3) ('b b) (a 1) ..4)
+   )
+
+  (pattern
+   (hash-table (c 3) ('b b) (a 1) ..5)
+   _
+   )
+
+  (pattern
+   (hash-table (a1 a2) (a (? number?)) ...)
+   )
+
+  (pattern
+   (hash-table (a1 a2) (a (and (not "hello") b)) ...)
+   )
+
+  (pattern
+   (hash-table (k v) ...)
+   )
+
+  (pattern
+   (hash-table ('e v1) ('b v2) rest ...)
+   )
+
+  (pattern
+   (hash-table)
+   )
+
+  (pattern
+   (list (struct shape (a)) 2)
+   (list (struct ovoid (a b c)) 2)
+   (list (struct circle (a b c d)) 5)
+   )
+
+  (pattern
+   (list (struct shape (a)) 2)
+   (list (struct ovoid (a b c)) 5)
+   (list (struct circle (a b c d)) 5)
+   )
+
+  (pattern
+   (list (struct shape (a)) 5)
+   (list (struct ovoid (a b c)) 5)
+   (list (struct circle (a b c d)) 5)
+   )
+
+  (pattern
+   (list (struct shape (a)) 5)
+   (list (struct ovoid (a b c)) 5)
+   (list (struct circle (a b c d)) 5)
+   (list (struct shape (a)) 6)
+   )
+
+  (pattern
+   (list (struct rectangle (a b c)) 5)
+   (list (struct shape (a)) 2)
+   (list (struct ovoid (a b c)) 2)
+   (list (struct circle (a b c d)) 5)
+   )
+
+  (pattern
+   (list (struct rectangle (a b c)) 5)
+   (list (struct shape (a)) 2)
+   (list (struct ovoid (a b c)) 5)
+   (list (struct circle (a b c d)) 5)
+   )
+
+  (pattern
+   (list (struct rectangle (a b c)) 5)
+   (list (struct shape (a)) 5)
+   (list (struct ovoid (a b c)) 5)
+   (list (struct circle (a b c d)) 5)
+   )
+
+  (pattern
+   (list (struct square (a b c d)) 5)
+   (list (struct shape (a)) 2)
+   (list (struct ovoid (a b c)) 2)
+   (list (struct circle (a b c d)) 5)
+   )
+
+  (pattern
+   (list (struct square (a b c d)) 5)
+   (list (struct shape (a)) 2)
+   (list (struct ovoid (a b c)) 5)
+   (list (struct circle (a b c d)) 5)
+   )
+
+  (pattern
+   (list (struct square (a b c d)) 5)
+   (list (struct shape (a)) 5)
+   (list (struct ovoid (a b c)) 5)
+   (list (struct circle (a b c d)) 5)
+   )
+
+  (pattern
+   `(a ())
+   )
+
+  (pattern
+   `(1 2 ,@(list 3 4) . ,b)
+   )
+
+  (pattern
+   `(,b 2 ,@(list 3 4) . b)
+   )
+
+  (pattern
+   `(,@`(,x ,y) ,@`(,a ,b))
+   )
+
+  (pattern
+   `(,a ,b ,c)
+   )
+
+  (pattern
+   `(c a b ,@(list a b c) r f i)
+   )
+
+  (pattern
+   `(3 4 #\c a b ,a ,(list b `(c e)))
+   `(3 4 #\c a b ,a ,(list b `(c d)))
+   )
+
+  (pattern
+   `#3(x ,x x)
+   )
+
+  (pattern
+   `#7(c a b ,@(list derby b c) r f i)
+   )
+
+  (pattern
+   `#&(c a b ,@(list a b c) r f i)
+   )
+
+  (pattern
+   `("hi"
+     1
+     there
+     #\c
+     #t
+     #f
+     (a b c)
+     (a b . c)
+     (a b c ..2)
+     #3(a b c)
+     #4(a b c ..2)
+     #&(a b c)
+     ,(list a b c)
+     ,(list-rest c1 d e)
+     ,(list f g h ...)
+     ,(vector i j k)
+     ,(box (list l m n o))
+     ,@(list 1 2 3 4 p))
+   )
+
+  (pattern
+   `#18("hi"
+        1
+        there
+        #\c
+        #t
+        #f
+        (a b c)
+        (a b . c)
+        (a b c ..2)
+        #3(a b c)
+        #4(a b c ..2)
+        #&(a b c)
+        ,(list a b c)
+        ,(list-rest c1 d e)
+        ,(list f g h ...)
+        ,(vector i j k)
+        ,(box (list l m n o))
+        ,@(list 1 2 3 4 p))
+   )
+
+  (pattern
+   `#&("hi"
+       1
+       there
+       #\c
+       #t
+       #f
+       (a b c)
+       (a b . c)
+       (a b c ..2)
+       #3(a b c)
+       #4(a b c ..2)
+       #&(a b c)
+       ,(list a b c)
+       ,(list-rest c1 d e)
+       ,(list f g h ...)
+       ,(vector i j k)
+       ,(box (list l m n o))
+       ,@(list 1 2 3 4 p))
+   )
+
+  (pattern
+   (list
+    (list
+     (box
+      (list
+       (and (? number? tlp327) (? even? tlp328))
+       (vector tlp329 ...)
+       (list tlp330 ..3)))
+     (list)
+     tlp331
+     (or (vector tlp332 ...) (vector tlp332 ...))))
+   )
+
+  (pattern
+   (list
+    (vector tlp333 ...)
+    (list-rest
+     (and (? test-struct? tlp335)
+          (app test-struct-a (and _ _))
+          (app test-struct-b (not (not #f)))
+          (app test-struct-c '(+ 4 5))
+          (app test-struct-d 7))
+     (and (? number? tlp336) (? even? tlp337))
+     tlp338
+     'these)
+    (list-rest
+     tlp339
+     (not (not 'these))
+     (struct
+      test-struct
+      ((list)
+       '(+ 4 (+ 1 1))
+       (and (box (list tlp340 tlp341 tlp342)) (box (list tlp343 tlp344 tlp345)))
+       (vector tlp346 tlp347 tlp348 tlp349)))
+     #\a)
+    (vector tlp351 ...))
+   )
+
+  (pattern
+   (list
+    (list
+     tlp352
+     (vector
+      (box
+       (list
+        (or _ _)
+        (and (? number? tlp353) (? even? tlp354))
+        (struct test-struct (tlp355 tlp356 tlp357 tlp358))))
+      (list
+       _
+       (list tlp360 ..3)
+       (and (? number? tlp361) (? even? tlp362))
+       (or (list tlp363 ..3) (list tlp363 ..3)))
+      (list
+       (not (not 'symbols))
+       (and (and tlp364 tlp365) (and tlp366 tlp367))
+       (struct test-struct (tlp368 tlp369 tlp370 tlp371))
+       _)
+      tlp373)
+     (list-rest (list tlp374 ...) (list tlp375 ...) _ #\c)
+     (and (? number? tlp376) (? even? tlp377)))
+    (list (list) (box (list (list) tlp378 (not (not #\c)))) #\b tlp379))
+   )
+
+  (pattern
+   (list
+    (list
+     (box
+      (list
+       (list-rest
+        (not (not 8))
+        (vector tlp380 ...)
+        (and (? test-struct? tlp386)
+             (app test-struct-a tlp381)
+             (app test-struct-b tlp382)
+             (app test-struct-c tlp383)
+             (app test-struct-d tlp384))
+        #\a)
+       (box (list #t (vector tlp387 ___) (list tlp388 ..3)))
+       (and tlp389 tlp390)))
+     (not (not 6))
+     (list)
+     '(+ 4 (+ 1 1)))
+    (list (list tlp391 __3) (not (not 3)) tlp392 (list tlp393 ...)))
+   )
+
+  (pattern
+   (list
+    tlp394
+    (struct
+     test-struct
+     ((and (? number? tlp395) (? even? tlp396))
+      (list)
+      tlp397
+      (vector tlp398 ___)))
+    _
+    (vector tlp400 ...))
+   )
+
+  (pattern
+   (list tlp401 tlp402 (list tlp403 ..3) (vector tlp404 ...))
+   )
+
+  (pattern
+   (list
+    (struct test-struct (tlp406 '(+ 4 (+ 1 1)) (list tlp407 __3) _))
+    _
+    (struct
+     test-struct
+     ((list-rest
+       (vector tlp409 tlp410 tlp411 tlp412)
+       (and (? test-struct? tlp418)
+            (app test-struct-a tlp413)
+            (app test-struct-b tlp414)
+            (app test-struct-c tlp415)
+            (app test-struct-d tlp416))
+       (list-rest tlp419 tlp420 tlp421 'these)
+       #f)
+      (list tlp422 ...)
+      (list)
+      (list tlp423 ...)))
+    (and (? test-struct? tlp434)
+         (app test-struct-a (list))
+         (app test-struct-b tlp425)
+         (app
+          test-struct-c
+          (and (? test-struct? tlp432)
+               (app test-struct-a 'these)
+               (app test-struct-b (and (not (not 3)) (not (not 3))))
+               (app test-struct-c (vector tlp426 tlp427 tlp428 tlp429))
+               (app test-struct-d (list tlp430 ___))))
+         (app test-struct-d 'are)))
+   )
+
+  (pattern
+   (list (list tlp437 ..3) _ (and (list tlp438 ..3) (list tlp439 ..3)) tlp440)
+   )
+
+  (pattern
+   (list
+    (and (list tlp443 ___) (list tlp444 ___))
+    (box
+     (list
+      (box (list #f tlp445 tlp446))
+      (vector
+       (list tlp447 __3)
+       (list)
+       5
+       (or (vector tlp448 ___) (vector tlp448 ___)))
+      (box
+       (list
+        (or (not (not '(+ 4 (+ 1 1)))) (not (not '(+ 4 (+ 1 1)))))
+        (list)
+        (list-rest tlp449 tlp450 tlp451 #f)))))
+    (vector
+     #\d
+     _
+     (box
+      (list
+       (vector tlp452 ___)
+       (and (list) (list))
+       (and (vector tlp453 ___) (vector tlp454 ___))))
+     (vector
+      (list tlp455 ...)
+      (and (? number? tlp456) (? even? tlp457))
+      (vector tlp458 tlp459 tlp460 tlp461)
+      #\b))
+    (list))
+   (list
+    (list tlp462 ..3)
+    tlp463
+    (list-rest
+     (list-rest
+      #\d
+      (list tlp464 tlp465 tlp466 tlp467)
+      (list-rest tlp468 tlp469 tlp470 'these)
+      #\b)
+     'symbols
+     (and (? test-struct? tlp478)
+          (app test-struct-a tlp471)
+          (app test-struct-b (list))
+          (app test-struct-c tlp472)
+          (app test-struct-d (vector tlp473 tlp474 tlp475 tlp476)))
+     7)
+    tlp479)
+   )
+
+  (pattern
+   (list
+    (list-rest tlp482 tlp483 (list) #\a)
+    (struct
+     test-struct
+     ((list-rest (list tlp484 ___) tlp485 (not (not #t)) 0)
+      (list)
+      tlp486
+      (not (not 7))))
+    (and (? number? tlp488) (? even? tlp489))
+    #\a)
+   (list
+    (list tlp490 ..3)
+    (box
+     (list
+      (and (? number? tlp491) (? even? tlp492))
+      (and (vector
+            (vector tlp493 ...)
+            tlp494
+            (vector tlp495 ...)
+            (box (list tlp496 tlp497 tlp498)))
+           (vector
+            (vector tlp499 ...)
+            tlp500
+            (vector tlp501 ...)
+            (box (list tlp502 tlp503 tlp504))))
+      (and (? number? tlp505) (? even? tlp506))))
+    tlp507
+    #\c)
+   )
+
+  (pattern
+   (list
+    (box
+     (list
+      #\d
+      (box (list tlp509 'are _))
+      (struct
+       test-struct
+       ((struct test-struct (tlp510 tlp511 tlp512 tlp513))
+        (list-rest tlp515 tlp516 tlp517 #\a)
+        (list-rest tlp518 tlp519 tlp520 #\b)
+        tlp521))))
+    (vector tlp523 ___)
+    (and (? test-struct? tlp548)
+         (app test-struct-a 'are)
+         (app
+          test-struct-b
+          (list
+           tlp524
+           (list tlp525 ...)
+           (and (struct test-struct (tlp526 tlp527 tlp528 tlp529))
+                (struct test-struct (tlp531 tlp532 tlp533 tlp534)))
+           tlp535))
+         (app test-struct-c (list tlp536 ...))
+         (app
+          test-struct-d
+          (and (? test-struct? tlp546)
+               (app
+                test-struct-a
+                (and (? test-struct? tlp542)
+                     (app test-struct-a tlp537)
+                     (app test-struct-b tlp538)
+                     (app test-struct-c tlp539)
+                     (app test-struct-d tlp540)))
+               (app test-struct-b (and (? number? tlp543) (? even? tlp544)))
+               (app test-struct-c (list))
+               (app test-struct-d (list)))))
+    tlp549)
+   )
+
+  (pattern
+   (list
+    tlp551
+    (struct test-struct ((vector tlp552 ...) 'are _ tlp553))
+    (list)
+    (list))
+   )
+
+  (pattern
+   (list
+    (not (not #f))
+    (box
+     (list
+      tlp556
+      (and (list tlp557 ___) (list tlp558 ___))
+      (and (? number? tlp559) (? even? tlp560))))
+    tlp561
+    (list))
+   (list
+    _
+    (list tlp562 ..3)
+    '(+ 4 (+ 1 1))
+    (vector
+     (list
+      (vector tlp563 tlp564 tlp565 tlp566)
+      tlp567
+      (box (list tlp568 tlp569 tlp570))
+      tlp571)
+     (and tlp572 tlp573)
+     (box
+      (list
+       (box (list tlp574 tlp575 tlp576))
+       (not (not #f))
+       (list-rest tlp577 tlp578 tlp579 #\b)))
+     #f))
+   )
+
+  (pattern
+   (list
+    (and (? number? tlp581) (? even? tlp582))
+    tlp583
+    (box
+     (list
+      '(+ 4 5)
+      (box
+       (list
+        tlp584
+        (and (? number? tlp585) (? even? tlp586))
+        (or (or tlp587 tlp587) (or tlp587 tlp587))))
+      '(+ 4 5)))
+    (vector tlp588 ...))
+   (list
+    (and (? test-struct? tlp601)
+         (app test-struct-a #f)
+         (app test-struct-b (list tlp589 ...))
+         (app
+          test-struct-c
+          (list
+           (and (? number? tlp590) (? even? tlp591))
+           (vector tlp592 ...)
+           (and (? test-struct? tlp598)
+                (app test-struct-a tlp593)
+                (app test-struct-b tlp594)
+                (app test-struct-c tlp595)
+                (app test-struct-d tlp596))
+           (list tlp599 __3)))
+         (app test-struct-d '(+ 4 (+ 1 1))))
+    #f
+    (vector tlp602 ___)
+    (list tlp603 ___))
+   )
+
+  (pattern
+   (list tlp606 tlp607 (list tlp608 ___) tlp609)
+   )
+
+  (pattern
+   (list
+    (list
+     '(+ 4 5)
+     (vector tlp612 ___)
+     (list tlp613 __3)
+     (struct
+      test-struct
+      ((box (list tlp614 tlp615 tlp616)) tlp617 (list) (list))))
+    tlp619
+    (box (list 7 '(+ 4 (+ 1 1)) (list)))
+    _)
+   )
+
+  (pattern
+   (list
+    (box
+     (list
+      (and (? number? tlp622) (? even? tlp623))
+      (list-rest
+       (list tlp624 ___)
+       (and (? number? tlp625) (? even? tlp626))
+       #\c
+       #\a)
+      tlp627))
+    tlp628
+    (list tlp629 ___)
+    #\c)
+   (list
+    tlp630
+    (or (vector
+         _
+         (vector tlp631 ...)
+         (vector
+          (list-rest tlp632 tlp633 tlp634 tlp635)
+          (and tlp636 tlp637)
+          #\b
+          (struct test-struct (tlp638 tlp639 tlp640 tlp641)))
+         (list))
+        (vector
+         _
+         (vector tlp631 ...)
+         (vector
+          (list-rest tlp632 tlp633 tlp634 tlp635)
+          (and tlp636 tlp637)
+          #\b
+          (struct test-struct (tlp638 tlp639 tlp640 tlp641)))
+         (list)))
+    #f
+    (and (? number? tlp643) (? even? tlp644)))
+   )
+
+  (pattern
+   (list
+    (vector
+     #t
+     (list)
+     (list
+      tlp647
+      (or (box (list tlp648 tlp649 tlp650)) (box (list tlp648 tlp649 tlp650)))
+      (list tlp651 ...)
+      tlp652)
+     #f)
+    'these
+    tlp653
+    tlp654)
+   (list
+    (list-rest
+     (list tlp655 __3)
+     (list tlp656 ___)
+     (struct
+      test-struct
+      ((and (? test-struct? tlp662)
+            (app test-struct-a tlp657)
+            (app test-struct-b tlp658)
+            (app test-struct-c tlp659)
+            (app test-struct-d tlp660))
+       (list-rest tlp663 tlp664 tlp665 #\a)
+       (list-rest tlp666 tlp667 tlp668 #\b)
+       _))
+     'are)
+    (not (not 'symbols))
+    (and tlp670 tlp671)
+    _)
+   )
+
+  (pattern
+   (list a b c)
+   )
+
+  (pattern
+   (list (list a b c) (list d e f))
+   )
+
+  (pattern
+   (list (list a b))
+   )
+
+  (pattern
+   (list (list _) ...)
+   )
+
+  (pattern
+   (list _ _ (list (set! set-it) _))
+   )
+
+  (pattern
+   (list _ _ (list _ (set! set-it)))
+   )
+
+  (pattern
+   (list (set! set-it) _ (list _ _))
+   )
+
+  (pattern
+   (list _ (set! set-it) (list _ _))
+   )
+
+  (pattern
+   (list-rest (set! set-it) _ (list-rest _ _) _)
+   )
+
+  (pattern
+   (list-rest _ (set! set-it) (list-rest _ _) _)
+   )
+
+  (pattern
+   (list-rest _ _ (list-rest (set! set-it) _) _)
+   )
+
+  (pattern
+   (list-rest _ _ (list-rest _ (set! set-it)) _)
+   )
+
+  (pattern
+   (list-rest _ _ (list-rest _ _) (set! set-it))
+   )
+
+  (pattern
+   (vector _ (set! set-it))
+   )
+
+  (pattern
+   (vector (set! set-it) _)
+   )
+
+  (pattern
+   (box (set! set-it))
+   )
+
+  (pattern
+   (box (list _ (set! set-it)))
+   )
+
+  (pattern
+   (box (vector _ (set! set-it)))
+   )
+
+  (pattern
+   (list _ _ (list (get! get-it) _))
+   )
+
+  (pattern
+   (list _ _ (list (set! set-it) _))
+   )
+
+  (pattern
+   (list _ _ (list _ (get! get-it)))
+   )
+
+  (pattern
+   (list (get! get-it) _ (list _ _))
+   )
+
+  (pattern
+   (list _ (get! get-it) (list _ _))
+   )
+
+  (pattern
+   (list-rest (get! get-it) _ (list-rest _ _) _)
+   )
+
+  (pattern
+   (list-rest _ (get! get-it) (list-rest _ _) _)
+   )
+
+  (pattern
+   (list-rest _ _ (list-rest (get! get-it) _) _)
+   )
+
+  (pattern
+   (list-rest _ _ (list-rest _ (get! get-it)) _)
+   )
+
+  (pattern
+   (list-rest _ _ (list-rest _ _) (get! get-it))
+   )
+
+  (pattern
+   (vector _ (get! get-it))
+   )
+
+  (pattern
+   (vector (get! get-it) _)
+   )
+
+  (pattern
+   (box (get! get-it))
+   )
+
+  (pattern
+   (box (list _ (get! get-it)))
+   )
+
+  (pattern
+   (box (vector _ (get! get-it)))
+   )
+
+  (pattern
+   (vector (vector (vector a ...) ...) ...)
+   )
+
+  (pattern
+   (list (list (list a ...) ...) ...)
+   )
+
+  (pattern
+   (list (list (list (list (list (list a ...) ...) ...) ...) ...) ...)
+   )
+
+  (pattern
+   (vector (vector (vector (vector (vector (vector a ...) ...) ...) ...) ...) ...)
+   )
+
+  (pattern
+   (list (vector (list (vector (list (vector a ...) ...) ...) ...) ...) ...)
+   )
+
+  (pattern
+   (list (list (list (list (list (list a ..2) ..2) ..2) ..2) ..2) ..2)
+   )
+
+  (pattern
+   (vector (vector (vector (vector (vector (vector a ..2) ..2) ..2) ..2) ..2) ..2)
+   )
+
+  (pattern
+   (list (vector (list (vector (list (vector a ..2) ..2) ..2) ..2) ..2) ..2)
+   )
+
+  (pattern
+   (list (list (list (list (list (list _ ...) ...) ...) ...) ...) ...)
+   _
+   )
+
+  (pattern
+   (vector (vector (vector (vector (vector (vector _ ...) ...) ...) ...) ...) ...)
+   _
+   )
+
+  (pattern
+   (list (vector (list (vector (list (vector _ ...) ...) ...) ...) ...) ...)
+   _
+   )
+
+  (pattern
+   (list (list (list (list (list (list a b) ...) ...) ...) ...) ...)
+   )
+
+  (pattern
+   (vector (vector (vector (vector (vector (vector a b) ...) ...) ...) ...) ...)
+   )
+
+  (pattern
+   (list (vector (list (vector (list (vector a b) ...) ...) ...) ...) ...)
+   )
+
+  (pattern
+   (list (list 1 ... a ...) ... 7 ...)
+   (list (list 1 ... a ...) ... 6 ...)
+   (list (list 1 ... a ...) ... 5 ...)
+   )
+
+  (pattern
+   (list 1 ... 2 2 2 2)
+   )
+
+  (pattern
+   (list 1 ... 2 ...)
+   )
+
+  (pattern
+   (list (and (not 2) a) ... 2 ...)
+   )
+
+  (pattern
+   (list a ... 2 ...)
+   )
+
+  (pattern
+   (list _ ... 2 ...)
+   )
+
+  (pattern
+   (list (and (not 'in) a) ... (and (not 'is) b) ... c ...)
+   )
+
+  (pattern
+   (list (list 1 ... 2 ...) ... 5 ...)
+   )
+
+  (pattern
+   (vector (and (? odd?) a) ... 8 (and (? even?) b) ... 7 r ...)
+   )
+
+  (pattern
+   (vector (vector 1 ... 2 ...) ... 5 ...)
+   )
+
+  (pattern
+   (vector (vector 1 ... a ...) ... 7 ...)
+   (vector (vector 1 ... a ...) ... 6 ...)
+   (vector (vector 1 ... a ...) ... 5 ...)
+   )
+
+  (pattern
+   (vector (vector _ _) ..3 a ...)
+   )
+
+  (pattern
+   (vector a b (and c (not 5)) ... d)
+   )
+
+  (pattern
+   (list-no-order a b 1 c)
+   )
+
+  (pattern
+   (list-rest 1 ... a)
+   )
+
+  (pattern
+   (list-rest (and 1 b) ... a)
+   )
+
+  (pattern
+   (list-rest (and 1 b) ... a (and c 4))
+   )
+
+  (pattern
+   (list (var _) b c)
+   )
+
+  (pattern
+   (list (var ..3) b c)
+   )
+
+  (pattern
+   (list (var quasiquote) b c)
+   )
+
+  (pattern
+   (list (var quote) b c)
+   )
+
+  (pattern
+   (list (var unquote) b c)
+   )
+
+  (pattern
+   (list (var unquote-splicing) b c)
+   )
+
+  (pattern
+   (list $ b c)
+   )
+
+  (pattern
+   (list var b c)
+   )
+
+  (pattern
+   (list = b c)
+   )
+
+  (pattern
+   (list and b c)
+   )
+
+  (pattern
+   (list or b c)
+   )
+
+  (pattern
+   (list not b c)
+   )
+
+  (pattern
+   (list ? b c)
+   )
+
+  (pattern
+   (list set! b c)
+   )
+
+  (pattern
+   (list get! b c)
+   )
+
+  (pattern
+   (list
+    (list tlp3121 __3)
+    (list)
+    (list tlp3122 __3)
+    (and (? number? tlp3123) (? even? tlp3124)))
+   )
+
+  (pattern
+   (list
+    (and (and (? test-struct? tlp3158)
+              (app
+               test-struct-a
+               (box
+                (list
+                 (list tlp3125 tlp3126 tlp3127 tlp3128)
+                 (list tlp3129 ___)
+                 (and (? test-struct? tlp3135)
+                      (app test-struct-a tlp3130)
+                      (app test-struct-b tlp3131)
+                      (app test-struct-c tlp3132)
+                      (app test-struct-d tlp3133)))))
+              (app
+               test-struct-b
+               (list-rest
+                (list tlp3136 tlp3137 tlp3138 tlp3139)
+                (and (? test-struct? tlp3145)
+                     (app test-struct-a tlp3140)
+                     (app test-struct-b tlp3141)
+                     (app test-struct-c tlp3142)
+                     (app test-struct-d tlp3143))
+                (vector tlp3146 tlp3147 tlp3148 tlp3149)
+                #\d))
+              (app test-struct-c (list tlp3150 __3))
+              (app
+               test-struct-d
+               (list
+                #\b
+                tlp3151
+                (and (? number? tlp3152) (? even? tlp3153))
+                (box (list tlp3154 tlp3155 tlp3156)))))
+         (and (? test-struct? tlp3159)
+              (app
+               test-struct-a
+               (box
+                (list
+                 (list tlp3160 tlp3161 tlp3162 tlp3163)
+                 (list tlp3164 ___)
+                 (and (? test-struct? tlp3165)
+                      (app test-struct-a tlp3166)
+                      (app test-struct-b tlp3167)
+                      (app test-struct-c tlp3168)
+                      (app test-struct-d tlp3169)))))
+              (app
+               test-struct-b
+               (list-rest
+                (list tlp3170 tlp3171 tlp3172 tlp3173)
+                (and (? test-struct? tlp3174)
+                     (app test-struct-a tlp3175)
+                     (app test-struct-b tlp3176)
+                     (app test-struct-c tlp3177)
+                     (app test-struct-d tlp3178))
+                (vector tlp3179 tlp3180 tlp3181 tlp3182)
+                #\d))
+              (app test-struct-c (list tlp3183 __3))
+              (app
+               test-struct-d
+               (list
+                #\b
+                tlp3184
+                (and (? number? tlp3185) (? even? tlp3186))
+                (box (list tlp3187 tlp3188 tlp3189))))))
+    (not (not #\a))
+    (struct
+     test-struct
+     ((vector tlp3190 ...)
+      tlp3191
+      (and (? test-struct? tlp3198)
+           (app test-struct-a (list tlp3192 __3))
+           (app test-struct-b tlp3193)
+           (app test-struct-c (and tlp3194 tlp3195))
+           (app test-struct-d (list tlp3196 ...)))
+      tlp3199))
+    (list tlp3201 __3))
+   )
+
+  (pattern
+   (list
+    (list
+     (list (and tlp3202 tlp3203) (list tlp3204 ___) tlp3205 tlp3206)
+     tlp3207
+     tlp3208
+     tlp3209))
+   )
+
+  (pattern
+   (list (and (list) (list)) tlp3210 tlp3211 _)
+   )
+
+  (pattern
+   (list
+    (list
+     (and (? number? tlp3212) (? even? tlp3213))
+     (and (? number? tlp3214) (? even? tlp3215))
+     (and (list tlp3216 ___) (list tlp3217 ___))
+     tlp3218))
+   )
+
+  (pattern
+   (list
+    (list (vector tlp3219 ...) (vector tlp3220 ...) (vector tlp3221 ___) (list))
+    (list 'are tlp3222 #\a 9)
+    (list
+     tlp3223
+     (list
+      (list-rest
+       #\b
+       (struct test-struct (tlp3224 tlp3225 tlp3226 tlp3227))
+       #f
+       'these)
+      (list)
+      (list-rest
+       (vector tlp3229 ...)
+       (or (and (? test-struct? tlp3235)
+                (app test-struct-a tlp3230)
+                (app test-struct-b tlp3231)
+                (app test-struct-c tlp3232)
+                (app test-struct-d tlp3233))
+           (and (? test-struct? tlp3235)
+                (app test-struct-a tlp3230)
+                (app test-struct-b tlp3231)
+                (app test-struct-c tlp3232)
+                (app test-struct-d tlp3233)))
+       (vector tlp3236 ___)
+       5)
+      (list))
+     (list tlp3237 ..3)
+     (and (? test-struct? tlp3240)
+          (app test-struct-a (or (list) (list)))
+          (app test-struct-b (vector tlp3238 ...))
+          (app test-struct-c (not (not #\c)))
+          (app test-struct-d #\b)))
+    (list
+     (list tlp3241 ___)
+     (list)
+     (list
+      (and (and (? test-struct? tlp3253)
+                (app test-struct-a (list-rest tlp3242 tlp3243 tlp3244 tlp3245))
+                (app test-struct-b (vector tlp3246 tlp3247 tlp3248 tlp3249))
+                (app test-struct-c (and (? number? tlp3250) (? even? tlp3251)))
+                (app test-struct-d _))
+           (and (? test-struct? tlp3254)
+                (app test-struct-a (list-rest tlp3255 tlp3256 tlp3257 tlp3258))
+                (app test-struct-b (vector tlp3259 tlp3260 tlp3261 tlp3262))
+                (app test-struct-c (and (? number? tlp3263) (? even? tlp3264)))
+                (app test-struct-d _)))
+      (vector
+       #\a
+       (or 'symbols 'symbols)
+       (vector tlp3265 tlp3266 tlp3267 tlp3268)
+       (box (list tlp3269 tlp3270 tlp3271)))
+      (and (? number? tlp3272) (? even? tlp3273))
+      (list tlp3274 ..3))
+     tlp3275)
+    (list
+     (list-rest
+      tlp3276
+      (struct
+       test-struct
+       (tlp3277
+        (and (vector tlp3278 tlp3279 tlp3280 tlp3281)
+             (vector tlp3282 tlp3283 tlp3284 tlp3285))
+        (and (not (not #t)) (not (not #t)))
+        tlp3286))
+      (box (list (list tlp3288 ___) (list tlp3289 __3) tlp3290))
+      #\b)
+     (list
+      (or (list) (list))
+      (and (? test-struct? tlp3298)
+           (app test-struct-a _)
+           (app test-struct-b tlp3291)
+           (app test-struct-c (vector tlp3292 ...))
+           (app test-struct-d (vector tlp3293 tlp3294 tlp3295 tlp3296)))
+      tlp3299
+      (and (? test-struct? tlp3313)
+           (app test-struct-a (box (list tlp3300 tlp3301 tlp3302)))
+           (app
+            test-struct-b
+            (struct test-struct (tlp3303 tlp3304 tlp3305 tlp3306)))
+           (app
+            test-struct-c
+            (or (list tlp3308 tlp3309 tlp3310 tlp3311)
+                (list tlp3308 tlp3309 tlp3310 tlp3311)))
+           (app test-struct-d _)))
+     (box
+      (list
+       (and (? test-struct? tlp3323)
+            (app test-struct-a (list tlp3314 ...))
+            (app test-struct-b (list-rest tlp3315 tlp3316 tlp3317 #\a))
+            (app test-struct-c (vector tlp3318 ___))
+            (app test-struct-d (box (list tlp3319 tlp3320 tlp3321))))
+       (box (list (list tlp3324 __3) (vector tlp3325 ___) (list tlp3326 ___)))
+       (list (list tlp3327 ...) tlp3328 (list tlp3329 ...) (list tlp3330 __3))))
+     (list tlp3331 ___)))
+   )
+
+  (pattern
+   (list
+    #\d
+    (list (not (not '(+ 4 5))) tlp3332 (not (not #f)) #t)
+    (box
+     (list
+      tlp3333
+      (not (not 7))
+      (list-rest
+       (vector tlp3334 tlp3335 tlp3336 tlp3337)
+       (box (list tlp3338 tlp3339 tlp3340))
+       tlp3341
+       9)))
+    (or (list tlp3342 ___) (list tlp3342 ___)))
+   )
+
+  (pattern
+   (list
+    (list-rest (and (list tlp3343 ...) (list tlp3344 ...)) (list) tlp3345 #\a)
+    (list-rest (not (not #t)) _ _ #f)
+    #\a
+    (vector
+     _
+     (or (list
+          _
+          tlp3346
+          (list tlp3347 tlp3348 tlp3349 tlp3350)
+          (and (? test-struct? tlp3356)
+               (app test-struct-a tlp3351)
+               (app test-struct-b tlp3352)
+               (app test-struct-c tlp3353)
+               (app test-struct-d tlp3354)))
+         (list
+          _
+          tlp3346
+          (list tlp3347 tlp3348 tlp3349 tlp3350)
+          (and (? test-struct? tlp3356)
+               (app test-struct-a tlp3351)
+               (app test-struct-b tlp3352)
+               (app test-struct-c tlp3353)
+               (app test-struct-d tlp3354))))
+     (box
+      (list
+       (vector tlp3357 tlp3358 tlp3359 tlp3360)
+       #\d
+       (and (? number? tlp3361) (? even? tlp3362))))
+     (vector
+      (struct test-struct (tlp3363 tlp3364 tlp3365 tlp3366))
+      (struct test-struct (tlp3368 tlp3369 tlp3370 tlp3371))
+      (and (? number? tlp3373) (? even? tlp3374))
+      tlp3375)))
+   )
+
+  (pattern
+   (list (and tlp3376 tlp3377) #\a (list) (vector tlp3378 ...))
+   )
+
+  (pattern
+   (list
+    _
+    (vector
+     (list-rest
+      (list)
+      (and (vector tlp3379 tlp3380 tlp3381 tlp3382)
+           (vector tlp3383 tlp3384 tlp3385 tlp3386))
+      (list tlp3387 ..3)
+      3)
+     (list
+      (list-rest tlp3388 tlp3389 tlp3390 #\a)
+      (or (list tlp3391 ..3) (list tlp3391 ..3))
+      _
+      (struct test-struct (tlp3392 tlp3393 tlp3394 tlp3395)))
+     (and (? number? tlp3397) (? even? tlp3398))
+     tlp3399)
+    tlp3400
+    (list))
+   )
+
+  (pattern
+   (list
+    (vector tlp3401 ___)
+    '(+ 1 2)
+    (vector
+     _
+     '(+ 1 2)
+     (and (box (list (list tlp3402 tlp3403 tlp3404 tlp3405) tlp3406 '(+ 1 2)))
+          (box (list (list tlp3407 tlp3408 tlp3409 tlp3410) tlp3411 '(+ 1 2))))
+     (list tlp3412 ..3))
+    _)
+   )
+
+  (pattern
+   (list
+    (list
+     _
+     (list tlp3413 ...)
+     (list
+      (box
+       (list
+        (vector tlp3414 ___)
+        (struct test-struct (tlp3415 tlp3416 tlp3417 tlp3418))
+        (and (? number? tlp3420) (? even? tlp3421))))
+      (list-rest
+       (not (not #\b))
+       (list-rest tlp3422 tlp3423 tlp3424 #\a)
+       (list tlp3425 tlp3426 tlp3427 tlp3428)
+       #\c)
+      (list tlp3429 ...)
+      tlp3430)
+     tlp3431)
+    (list tlp3432 tlp3433 (list tlp3434 ...) (list))
+    (list
+     (list tlp3435 ...)
+     (and (? test-struct? tlp3445)
+          (app test-struct-a (list tlp3436 ..3))
+          (app test-struct-b (list))
+          (app
+           test-struct-c
+           (list-rest
+            (list tlp3437 ___)
+            tlp3438
+            (vector tlp3439 tlp3440 tlp3441 tlp3442)
+            5))
+          (app test-struct-d (vector tlp3443 ___)))
+     (vector
+      (and (and (? test-struct? tlp3456)
+                (app test-struct-a (list))
+                (app test-struct-b (list-rest tlp3446 tlp3447 tlp3448 tlp3449))
+                (app test-struct-c (box (list tlp3450 tlp3451 tlp3452)))
+                (app test-struct-d (and tlp3453 tlp3454)))
+           (and (? test-struct? tlp3457)
+                (app test-struct-a (list))
+                (app test-struct-b (list-rest tlp3458 tlp3459 tlp3460 tlp3461))
+                (app test-struct-c (box (list tlp3462 tlp3463 tlp3464)))
+                (app test-struct-d (and tlp3465 tlp3466))))
+      tlp3467
+      #t
+      (box (list (not (not 2)) (box (list tlp3468 tlp3469 tlp3470)) _)))
+     (and (? test-struct? tlp3475)
+          (app
+           test-struct-a
+           (list-rest _ (or tlp3471 tlp3471) (not (not #f)) #\d))
+          (app test-struct-b tlp3472)
+          (app test-struct-c (list))
+          (app test-struct-d (list tlp3473 ...))))
+    (list
+     (struct
+      test-struct
+      ((and (? number? tlp3476) (? even? tlp3477))
+       (list
+        (or (and (? test-struct? tlp3483)
+                 (app test-struct-a tlp3478)
+                 (app test-struct-b tlp3479)
+                 (app test-struct-c tlp3480)
+                 (app test-struct-d tlp3481))
+            (and (? test-struct? tlp3483)
+                 (app test-struct-a tlp3478)
+                 (app test-struct-b tlp3479)
+                 (app test-struct-c tlp3480)
+                 (app test-struct-d tlp3481)))
+        (vector tlp3484 tlp3485 tlp3486 tlp3487)
+        (box (list tlp3488 tlp3489 tlp3490))
+        '(+ 4 5))
+       (vector tlp3491 ___)
+       tlp3492))
+     (list tlp3494 ..3)
+     (list tlp3495 ..3)
+     tlp3496)
+    (list
+     (list
+      (box
+       (list
+        (list tlp3497 tlp3498 tlp3499 tlp3500)
+        (and _ _)
+        (and (? test-struct? tlp3506)
+             (app test-struct-a tlp3501)
+             (app test-struct-b tlp3502)
+             (app test-struct-c tlp3503)
+             (app test-struct-d tlp3504))))
+      (list tlp3507 ...)
+      (and (? test-struct? tlp3513)
+           (app test-struct-a (box (list tlp3508 tlp3509 tlp3510)))
+           (app test-struct-b (list))
+           (app test-struct-c _)
+           (app test-struct-d (list tlp3511 ___)))
+      (or (and (struct test-struct (tlp3514 tlp3515 tlp3516 tlp3517))
+               (struct test-struct (tlp3519 tlp3520 tlp3521 tlp3522)))
+          (and (struct test-struct (tlp3514 tlp3515 tlp3516 tlp3517))
+               (struct test-struct (tlp3519 tlp3520 tlp3521 tlp3522)))))
+     (list
+      (not (not 9))
+      #f
+      '(+ 4 5)
+      (box
+       (list
+        (and (? test-struct? tlp3528)
+             (app test-struct-a tlp3523)
+             (app test-struct-b tlp3524)
+             (app test-struct-c tlp3525)
+             (app test-struct-d tlp3526))
+        (list tlp3529 __3)
+        (vector tlp3530 tlp3531 tlp3532 tlp3533))))
+     (not (not #\d))
+     9))
+   )
+
+  (pattern
+   (list
+    (list
+     tlp3534
+     tlp3535
+     (list-rest tlp3536 _ tlp3537 'symbols)
+     (or (or tlp3538 tlp3538) (or tlp3538 tlp3538)))
+    (list
+     (list tlp3539 __3)
+     tlp3540
+     (and (? number? tlp3541) (? even? tlp3542))
+     (and (? number? tlp3543) (? even? tlp3544)))
+    (list
+     (or tlp3545 tlp3545)
+     (or #f #f)
+     (struct test-struct (tlp3546 (list tlp3547 ..3) (list tlp3548 ___) tlp3549))
+     (list-rest (vector tlp3551 ...) 7 #f #\b))
+    (list
+     (box
+      (list
+       (box
+        (list
+         (or tlp3552 tlp3552)
+         tlp3553
+         (and (? number? tlp3554) (? even? tlp3555))))
+       tlp3556
+       (list tlp3557 ___)))
+     (list
+      (list
+       (list-rest tlp3558 tlp3559 tlp3560 #\b)
+       (or (vector tlp3561 ___) (vector tlp3561 ___))
+       (list-rest tlp3562 tlp3563 tlp3564 #\d)
+       tlp3565)
+      (and (? test-struct? tlp3579)
+           (app
+            test-struct-a
+            (struct test-struct (tlp3566 tlp3567 tlp3568 tlp3569)))
+           (app
+            test-struct-b
+            (or (and (? number? tlp3571) (? even? tlp3572))
+                (and (? number? tlp3571) (? even? tlp3572))))
+           (app
+            test-struct-c
+            (struct test-struct (tlp3573 tlp3574 tlp3575 tlp3576)))
+           (app test-struct-d (not (not 9))))
+      (and tlp3580 tlp3581)
+      (and (? number? tlp3582) (? even? tlp3583)))
+     (vector tlp3584 ___)
+     (or tlp3585 tlp3585))
+    (list
+     (vector tlp3586 ...)
+     #f
+     (list
+      (and (? test-struct? tlp3596)
+           (app test-struct-a (list tlp3587 ...))
+           (app test-struct-b (list-rest tlp3588 tlp3589 tlp3590 #\c))
+           (app test-struct-c (vector tlp3591 tlp3592 tlp3593 tlp3594))
+           (app test-struct-d (not (not #\b))))
+      (struct
+       test-struct
+       (#\a (and (? number? tlp3597) (? even? tlp3598)) _ tlp3599))
+      (list-rest
+       (and (? test-struct? tlp3606)
+            (app test-struct-a tlp3601)
+            (app test-struct-b tlp3602)
+            (app test-struct-c tlp3603)
+            (app test-struct-d tlp3604))
+       (list tlp3607 __3)
+       (and (vector tlp3608 ...) (vector tlp3609 ...))
+       6)
+      '(+ 1 2))
+     #\b))
+   )
+
+  (pattern
+   (list
+    (list _ (not (not #f)) (not (not #f)) (vector tlp3610 ___))
+    (list
+     (list tlp3611 ...)
+     (vector
+      (list tlp3612 ...)
+      (and tlp3613 tlp3614)
+      (list tlp3615 ...)
+      (and (? test-struct? tlp3626)
+           (app test-struct-a (and (list) (list)))
+           (app test-struct-b tlp3616)
+           (app test-struct-c (vector tlp3617 tlp3618 tlp3619 tlp3620))
+           (app test-struct-d (vector tlp3621 tlp3622 tlp3623 tlp3624))))
+     (and (vector
+           tlp3627
+           (vector tlp3628 ...)
+           (and (? test-struct? tlp3640)
+                (app test-struct-a _)
+                (app
+                 test-struct-b
+                 (struct test-struct (tlp3629 tlp3630 tlp3631 tlp3632)))
+                (app test-struct-c (box (list tlp3634 tlp3635 tlp3636)))
+                (app test-struct-d (and tlp3637 tlp3638)))
+           tlp3641)
+          (vector
+           tlp3642
+           (vector tlp3643 ...)
+           (and (? test-struct? tlp3644)
+                (app test-struct-a _)
+                (app
+                 test-struct-b
+                 (struct test-struct (tlp3645 tlp3646 tlp3647 tlp3648)))
+                (app test-struct-c (box (list tlp3649 tlp3650 tlp3651)))
+                (app test-struct-d (and tlp3652 tlp3653)))
+           tlp3654))
+     tlp3655)
+    (list
+     tlp3656
+     #\c
+     tlp3657
+     (list-rest (list tlp3658 __3) #\d (list tlp3659 ___) #\c))
+    (list tlp3660 _ (list) _)
+    (list 'these tlp3661 (list) tlp3662))
+   )
+
+  (pattern
+   (list
+    (vector
+     (vector tlp3663 ___)
+     (list tlp3664 ___)
+     (and (? number? tlp3665) (? even? tlp3666))
+     (box (list (vector tlp3667 ...) (list tlp3668 ..3) _)))
+    tlp3669
+    (list tlp3670 __3)
+    tlp3671)
+   )
+
+  (pattern
+   (list
+    (box
+     (list
+      (struct
+       test-struct
+       ((vector tlp3672 ...)
+        tlp3673
+        (and (not (not #\c)) (not (not #\c)))
+        (list-rest tlp3674 tlp3675 tlp3676 #\d)))
+      tlp3678
+      (and (list tlp3679 ...) (list tlp3680 ...))))
+    _
+    tlp3681
+    tlp3682)
+   )
+
+  (pattern
+   (list
+    tlp3683
+    (list-rest
+     (and #\d #\d)
+     (or (list tlp3684 __3) (list tlp3684 __3))
+     (list)
+     #\d)
+    (and (vector tlp3685 ___) (vector tlp3686 ___))
+    (list tlp3687 ___))
+   )
+
+  (pattern
+   (list
+    tlp3688
+    tlp3689
+    (list
+     (box
+      (list
+       (list tlp3690 ___)
+       (and (? number? tlp3691) (? even? tlp3692))
+       (not (not #\c))))
+     (and (list tlp3693 ...) (list tlp3694 ...))
+     tlp3695
+     (not (not #f)))
+    (vector tlp3696 ...))
+   )
+
+  (pattern
+   (list
+    (struct
+     test-struct
+     ((not (not #\b))
+      tlp3697
+      (box (list tlp3698 (list tlp3699 ..3) tlp3700))
+      (or _ _)))
+    (list-rest (list) (vector tlp3702 ...) (and 'are 'are) #\d)
+    (box
+     (list
+      tlp3703
+      (vector
+       (list tlp3704 ___)
+       (list tlp3705 ...)
+       (list tlp3706 ___)
+       (vector tlp3707 ...))
+      (list
+       (struct test-struct (tlp3708 tlp3709 tlp3710 tlp3711))
+       #t
+       (list)
+       (list tlp3713 __3))))
+    (vector tlp3714 ___))
+   )
+
+  (pattern
+   (list
+    3
+    (and (? number? tlp3716) (? even? tlp3717))
+    (and #f #f)
+    (or (vector tlp3718 ___) (vector tlp3718 ___)))
+   )
+
+  (pattern
+   (list
+    tlp3721
+    tlp3722
+    (or (list
+         (and (? number? tlp3723) (? even? tlp3724))
+         tlp3725
+         (list)
+         (vector tlp3726 (list tlp3727 tlp3728 tlp3729 tlp3730) (list) tlp3731))
+        (list
+         (and (? number? tlp3723) (? even? tlp3724))
+         tlp3725
+         (list)
+         (vector tlp3726 (list tlp3727 tlp3728 tlp3729 tlp3730) (list) tlp3731)))
+    (or tlp3732 tlp3732))
+   )
+
+  (pattern
+   (list
+    (struct
+     test-struct
+     ((and (list tlp3735 __3) (list tlp3736 __3))
+      tlp3737
+      (and (? number? tlp3738) (? even? tlp3739))
+      (and (? test-struct? tlp3754)
+           (app
+            test-struct-a
+            (and (? test-struct? tlp3745)
+                 (app test-struct-a tlp3740)
+                 (app test-struct-b tlp3741)
+                 (app test-struct-c tlp3742)
+                 (app test-struct-d tlp3743)))
+           (app test-struct-b (and (vector tlp3746 ___) (vector tlp3747 ___)))
+           (app test-struct-c _)
+           (app
+            test-struct-d
+            (struct test-struct (tlp3748 tlp3749 tlp3750 tlp3751))))))
+    #t
+    (and (vector
+          (list
+           _
+           (and tlp3756 tlp3757)
+           (and (? test-struct? tlp3763)
+                (app test-struct-a tlp3758)
+                (app test-struct-b tlp3759)
+                (app test-struct-c tlp3760)
+                (app test-struct-d tlp3761))
+           (not (not 'are)))
+          _
+          (struct
+           test-struct
+           ((box (list tlp3764 tlp3765 tlp3766))
+            (vector tlp3767 tlp3768 tlp3769 tlp3770)
+            tlp3771
+            (struct test-struct (tlp3772 tlp3773 tlp3774 tlp3775))))
+          _)
+         (vector
+          (list
+           _
+           (and tlp3778 tlp3779)
+           (and (? test-struct? tlp3780)
+                (app test-struct-a tlp3781)
+                (app test-struct-b tlp3782)
+                (app test-struct-c tlp3783)
+                (app test-struct-d tlp3784))
+           (not (not 'are)))
+          _
+          (struct
+           test-struct
+           ((box (list tlp3785 tlp3786 tlp3787))
+            (vector tlp3788 tlp3789 tlp3790 tlp3791)
+            tlp3792
+            (struct test-struct (tlp3793 tlp3794 tlp3795 tlp3796))))
+          _))
+    (and (? test-struct? tlp3823)
+         (app
+          test-struct-a
+          (and (? test-struct? tlp3806)
+               (app
+                test-struct-a
+                (and (and tlp3797 tlp3798) (and tlp3799 tlp3800)))
+               (app test-struct-b (box (list tlp3801 tlp3802 tlp3803)))
+               (app test-struct-c (or '(+ 4 5) '(+ 4 5)))
+               (app test-struct-d tlp3804)))
+         (app
+          test-struct-b
+          (box
+           (list (box (list tlp3807 tlp3808 tlp3809)) #\c (list tlp3810 ..3))))
+         (app test-struct-c _)
+         (app
+          test-struct-d
+          (and (? test-struct? tlp3821)
+               (app test-struct-a tlp3811)
+               (app test-struct-b (list tlp3812 ...))
+               (app
+                test-struct-c
+                (and (? test-struct? tlp3818)
+                     (app test-struct-a tlp3813)
+                     (app test-struct-b tlp3814)
+                     (app test-struct-c tlp3815)
+                     (app test-struct-d tlp3816)))
+               (app test-struct-d (vector tlp3819 ___))))))
+   )
+
+  (pattern
+   (list
+    (box
+     (list
+      tlp3826
+      tlp3827
+      (list-rest
+       (list-rest tlp3828 tlp3829 tlp3830 #t)
+       (list tlp3831 __3)
+       (list-rest tlp3832 tlp3833 tlp3834 'these)
+       #\b)))
+    (list)
+    (and (? test-struct? tlp3857)
+         (app test-struct-a (box (list tlp3835 #\a tlp3836)))
+         (app
+          test-struct-b
+          (and (list
+                (list tlp3837 __3)
+                #t
+                (and (? number? tlp3838) (? even? tlp3839))
+                (vector tlp3840 ...))
+               (list
+                (list tlp3841 __3)
+                #t
+                (and (? number? tlp3842) (? even? tlp3843))
+                (vector tlp3844 ...))))
+         (app test-struct-c (list (vector tlp3845 ...) #t tlp3846 (or #f #f)))
+         (app
+          test-struct-d
+          (or (and (? test-struct? tlp3855)
+                   (app test-struct-a #\b)
+                   (app test-struct-b _)
+                   (app
+                    test-struct-c
+                    (struct test-struct (tlp3847 tlp3848 tlp3849 tlp3850)))
+                   (app
+                    test-struct-d
+                    (and (? number? tlp3852) (? even? tlp3853))))
+              (and (? test-struct? tlp3855)
+                   (app test-struct-a #\b)
+                   (app test-struct-b _)
+                   (app
+                    test-struct-c
+                    (struct test-struct (tlp3847 tlp3848 tlp3849 tlp3850)))
+                   (app
+                    test-struct-d
+                    (and (? number? tlp3852) (? even? tlp3853)))))))
+    (list
+     (list-rest
+      (list-rest tlp3858 tlp3859 tlp3860 'these)
+      (box (list tlp3861 tlp3862 tlp3863))
+      (not (not '(+ 4 (+ 1 1))))
+      #\a)
+     (and (list-rest
+           (vector tlp3864 tlp3865 tlp3866 tlp3867)
+           (vector tlp3868 ...)
+           '(+ 4 5)
+           #\d)
+          (list-rest
+           (vector tlp3869 tlp3870 tlp3871 tlp3872)
+           (vector tlp3873 ...)
+           '(+ 4 5)
+           #\d))
+     (not (not #\b))
+     (vector
+      tlp3874
+      (not (not '(+ 1 2)))
+      (list tlp3875 tlp3876 tlp3877 tlp3878)
+      (list tlp3879 tlp3880 tlp3881 tlp3882))))
+   )
+
+  (pattern
+   (list
+    (and (? test-struct? tlp3903)
+         (app
+          test-struct-a
+          (and (? test-struct? tlp3891)
+               (app test-struct-a tlp3885)
+               (app test-struct-b (list tlp3886 tlp3887 tlp3888 tlp3889))
+               (app test-struct-c (not (not #\d)))
+               (app test-struct-d _)))
+         (app test-struct-b '(+ 4 5))
+         (app test-struct-c (list))
+         (app
+          test-struct-d
+          (vector
+           (list tlp3892 tlp3893 tlp3894 tlp3895)
+           (and (? test-struct? tlp3901)
+                (app test-struct-a tlp3896)
+                (app test-struct-b tlp3897)
+                (app test-struct-c tlp3898)
+                (app test-struct-d tlp3899))
+           _
+           (or (list) (list)))))
+    (list tlp3904 ..3)
+    (list tlp3905 ...)
+    (vector
+     (list tlp3906 ...)
+     (list-rest
+      (list tlp3907 ..3)
+      (list-rest tlp3908 tlp3909 tlp3910 #\d)
+      5
+      'are)
+     (list-rest
+      tlp3911
+      (and (? number? tlp3912) (? even? tlp3913))
+      (list tlp3914 ...)
+      #\d)
+     (list tlp3915 #\b (vector tlp3916 ...) (list))))
+   )
+
+  (pattern
+   (list
+    (not (not 'are))
+    (list-rest
+     tlp4432
+     (list-rest tlp4433 (list tlp4434 ...) tlp4435 'symbols)
+     (not (not 2))
+     'symbols)
+    (not (not #\a))
+    (list
+     (and (? test-struct? tlp4445)
+          (app test-struct-a (list-rest tlp4436 tlp4437 tlp4438 9))
+          (app test-struct-b (and (and tlp4439 tlp4440) (and tlp4441 tlp4442)))
+          (app test-struct-c '(+ 1 2))
+          (app test-struct-d (list tlp4443 ___)))
+     tlp4446
+     (list-rest 'these tlp4447 (list tlp4448 ..3) 'these)
+     (list tlp4449 ___)))
+   )
+
+  (pattern
+   (list
+    tlp4451
+    tlp4452
+    (and (? test-struct? tlp4471)
+         (app
+          test-struct-a
+          (and (? test-struct? tlp4461)
+               (app test-struct-a (box (list tlp4453 tlp4454 tlp4455)))
+               (app test-struct-b (list tlp4456 ...))
+               (app test-struct-c (list-rest tlp4457 tlp4458 tlp4459 'symbols))
+               (app test-struct-d '(+ 4 5))))
+         (app test-struct-b (and (? number? tlp4462) (? even? tlp4463)))
+         (app test-struct-c tlp4464)
+         (app
+          test-struct-d
+          (or (list-rest
+               (list)
+               tlp4465
+               (list tlp4466 tlp4467 tlp4468 tlp4469)
+               #\b)
+              (list-rest
+               (list)
+               tlp4465
+               (list tlp4466 tlp4467 tlp4468 tlp4469)
+               #\b))))
+    tlp4472)
+   )
+
+  (pattern
+   (list
+    (list-rest
+     (and (list
+           (vector tlp4474 tlp4475 tlp4476 tlp4477)
+           (vector tlp4478 tlp4479 tlp4480 tlp4481)
+           (list)
+           (or tlp4482 tlp4482))
+          (list
+           (vector tlp4483 tlp4484 tlp4485 tlp4486)
+           (vector tlp4487 tlp4488 tlp4489 tlp4490)
+           (list)
+           (or tlp4491 tlp4491)))
+     (and (? number? tlp4492) (? even? tlp4493))
+     (list '(+ 1 2) (list tlp4494 ...) tlp4495 tlp4496)
+     #f)
+    (and (? test-struct? tlp4517)
+         (app
+          test-struct-a
+          (or (box
+               (list
+                (and (? test-struct? tlp4502)
+                     (app test-struct-a tlp4497)
+                     (app test-struct-b tlp4498)
+                     (app test-struct-c tlp4499)
+                     (app test-struct-d tlp4500))
+                (list)
+                (vector tlp4503 tlp4504 tlp4505 tlp4506)))
+              (box
+               (list
+                (and (? test-struct? tlp4502)
+                     (app test-struct-a tlp4497)
+                     (app test-struct-b tlp4498)
+                     (app test-struct-c tlp4499)
+                     (app test-struct-d tlp4500))
+                (list)
+                (vector tlp4503 tlp4504 tlp4505 tlp4506)))))
+         (app
+          test-struct-b
+          (and (list-rest
+                (list tlp4507 ___)
+                (and (? number? tlp4508) (? even? tlp4509))
+                (list tlp4510 __3)
+                'these)
+               (list-rest
+                (list tlp4511 ___)
+                (and (? number? tlp4512) (? even? tlp4513))
+                (list tlp4514 __3)
+                'these)))
+         (app test-struct-c (or (list tlp4515 ..3) (list tlp4515 ..3)))
+         (app test-struct-d (list)))
+    tlp4518
+    tlp4519)
+   )
+
+  (pattern
+   (list
+    (and (? number? tlp4521) (? even? tlp4522))
+    (or tlp4523 tlp4523)
+    tlp4524
+    (list tlp4525 ...))
+   )
+
+  (pattern
+   (list
+    (list tlp4527 __3)
+    (list
+     (and (? test-struct? tlp4540)
+          (app
+           test-struct-a
+           (and (struct test-struct (tlp4528 tlp4529 tlp4530 tlp4531))
+                (struct test-struct (tlp4533 tlp4534 tlp4535 tlp4536))))
+          (app test-struct-b (list tlp4537 ..3))
+          (app test-struct-c #\d)
+          (app test-struct-d (vector tlp4538 ...)))
+     (and (? test-struct? tlp4556)
+          (app test-struct-a (not (not #\b)))
+          (app
+           test-struct-b
+           (and (vector tlp4541 tlp4542 tlp4543 tlp4544)
+                (vector tlp4545 tlp4546 tlp4547 tlp4548)))
+          (app test-struct-c (vector tlp4549 ...))
+          (app
+           test-struct-d
+           (struct test-struct (tlp4550 tlp4551 tlp4552 tlp4553))))
+     (box
+      (list (and (list tlp4557 __3) (list tlp4558 __3)) tlp4559 (not (not 4))))
+     tlp4560)
+    (list)
+    (or 'these 'these))
+   )
+
+  (pattern
+   (list tlp4984 'these (not (not #\b)) tlp4985)
+   )
+
+  (pattern
+   (list
+    _
+    (vector tlp4988 ...)
+    tlp4989
+    (box
+     (list
+      (not (not '(+ 4 (+ 1 1))))
+      (struct
+       test-struct
+       ((list-rest tlp4990 tlp4991 tlp4992 4)
+        (struct test-struct (tlp4993 tlp4994 tlp4995 tlp4996))
+        tlp4998
+        #t))
+      tlp5000)))
+   )
+
+  (pattern
+   (list #\b (and (list) (list)) '(+ 4 (+ 1 1)) tlp5003)
+   )
+
+  (pattern
+   (list
+    (vector tlp5006 ...)
+    _
+    (vector
+     (list tlp5007 ..3)
+     (box (list (list tlp5008 ___) _ (not (not #t))))
+     tlp5009
+     (list tlp5010 (vector tlp5011 ...) (list) (list)))
+    (and (? number? tlp5012) (? even? tlp5013)))
+   )
+
+  (pattern
+   (list
+    (and (list
+          (list (and (? number? tlp5016) (? even? tlp5017)) (list) #\a (list))
+          (and (? number? tlp5018) (? even? tlp5019))
+          (list)
+          tlp5020)
+         (list
+          (list (and (? number? tlp5021) (? even? tlp5022)) (list) #\a (list))
+          (and (? number? tlp5023) (? even? tlp5024))
+          (list)
+          tlp5025))
+    (or (not (not 'are)) (not (not 'are)))
+    tlp5026
+    (list
+     (struct
+      test-struct
+      (_
+       (or (struct test-struct (tlp5027 tlp5028 tlp5029 tlp5030))
+           (struct test-struct (tlp5027 tlp5028 tlp5029 tlp5030)))
+       (or (list tlp5032 __3) (list tlp5032 __3))
+       (list tlp5033 tlp5034 tlp5035 tlp5036)))
+     (and (? test-struct? tlp5041)
+          (app test-struct-a '(+ 1 2))
+          (app test-struct-b tlp5038)
+          (app test-struct-c (list tlp5039 ___))
+          (app test-struct-d 'are))
+     tlp5042
+     (or (and (? number? tlp5043) (? even? tlp5044))
+         (and (? number? tlp5043) (? even? tlp5044)))))
+   )
+
+  (pattern
+   (list
+    (or (and #\c #\c) (and #\c #\c))
+    (list tlp963 __3)
+    (not (not #f))
+    (list
+     (and (or (list-rest tlp964 tlp965 tlp966 'are)
+              (list-rest tlp964 tlp965 tlp966 'are))
+          (or (list-rest tlp967 tlp968 tlp969 'are)
+              (list-rest tlp967 tlp968 tlp969 'are)))
+     (list tlp970 __3)
+     tlp971
+     tlp972))
+   )
+
+  (pattern
+   (list
+    (box
+     (list
+      (list
+       (list-rest tlp973 tlp974 tlp975 'symbols)
+       (not (not 'these))
+       tlp976
+       (and (? test-struct? tlp982)
+            (app test-struct-a tlp977)
+            (app test-struct-b tlp978)
+            (app test-struct-c tlp979)
+            (app test-struct-d tlp980)))
+      (list
+       (list tlp983 tlp984 tlp985 tlp986)
+       (and (? test-struct? tlp992)
+            (app test-struct-a tlp987)
+            (app test-struct-b tlp988)
+            (app test-struct-c tlp989)
+            (app test-struct-d tlp990))
+       (vector tlp993 tlp994 tlp995 tlp996)
+       (box (list tlp997 tlp998 tlp999)))
+      (or tlp1000 tlp1000)))
+    (and (? test-struct? tlp1005)
+         (app test-struct-a #t)
+         (app test-struct-b (or tlp1001 tlp1001))
+         (app test-struct-c tlp1002)
+         (app test-struct-d (list tlp1003 ...)))
+    (not (not 'these))
+    (list tlp1006 ___))
+   )
+
+  (pattern
+   (list
+    (list)
+    (and (? test-struct? tlp1033)
+         (app test-struct-a tlp1007)
+         (app test-struct-b (and (? number? tlp1008) (? even? tlp1009)))
+         (app
+          test-struct-c
+          (and (? test-struct? tlp1023)
+               (app
+                test-struct-a
+                (and (list-rest tlp1010 tlp1011 tlp1012 tlp1013)
+                     (list-rest tlp1014 tlp1015 tlp1016 tlp1017)))
+               (app test-struct-b (list))
+               (app test-struct-c (and (list tlp1018 ___) (list tlp1019 ___)))
+               (app test-struct-d (and (? number? tlp1020) (? even? tlp1021)))))
+         (app
+          test-struct-d
+          (and (? test-struct? tlp1031)
+               (app
+                test-struct-a
+                (or (and (? number? tlp1024) (? even? tlp1025))
+                    (and (? number? tlp1024) (? even? tlp1025))))
+               (app test-struct-b _)
+               (app test-struct-c (vector tlp1026 tlp1027 tlp1028 tlp1029))
+               (app test-struct-d _))))
+    9
+    (list
+     (struct
+      test-struct
+      ((and (and tlp1034 tlp1035) (and tlp1036 tlp1037))
+       tlp1038
+       (struct test-struct (tlp1039 tlp1040 tlp1041 tlp1042))
+       (and (? test-struct? tlp1049)
+            (app test-struct-a tlp1044)
+            (app test-struct-b tlp1045)
+            (app test-struct-c tlp1046)
+            (app test-struct-d tlp1047))))
+     tlp1051
+     1
+     _))
+   )
+
+  (pattern
+   (list
+    (list)
+    (list tlp1052 ...)
+    (list-rest
+     (list tlp1053 ..3)
+     (vector tlp1054 ...)
+     (vector
+      tlp1055
+      (vector tlp1056 ___)
+      (list tlp1057 ...)
+      (box (list tlp1058 tlp1059 tlp1060)))
+     #\d)
+    (and (? number? tlp1061) (? even? tlp1062)))
+   )
+
+  (pattern
+   (list
+    (and (? test-struct? tlp1092)
+         (app
+          test-struct-a
+          (struct
+           test-struct
+           ((not (not 'are))
+            tlp1063
+            tlp1064
+            (and (? test-struct? tlp1070)
+                 (app test-struct-a tlp1065)
+                 (app test-struct-b tlp1066)
+                 (app test-struct-c tlp1067)
+                 (app test-struct-d tlp1068)))))
+         (app
+          test-struct-b
+          (struct
+           test-struct
+           ((box (list tlp1072 tlp1073 tlp1074))
+            (and tlp1075 tlp1076)
+            tlp1077
+            (and (list tlp1078 ...) (list tlp1079 ...)))))
+         (app
+          test-struct-c
+          (or (vector
+               (and tlp1081 tlp1082)
+               (and (? test-struct? tlp1088)
+                    (app test-struct-a tlp1083)
+                    (app test-struct-b tlp1084)
+                    (app test-struct-c tlp1085)
+                    (app test-struct-d tlp1086))
+               #\c
+               #f)
+              (vector
+               (and tlp1081 tlp1082)
+               (and (? test-struct? tlp1088)
+                    (app test-struct-a tlp1083)
+                    (app test-struct-b tlp1084)
+                    (app test-struct-c tlp1085)
+                    (app test-struct-d tlp1086))
+               #\c
+               #f)))
+         (app test-struct-d (and (? number? tlp1089) (? even? tlp1090))))
+    #t
+    (list tlp1093 ..3)
+    _)
+   )
+
+  (pattern
+   (list (list tlp1094 __3) tlp1095 (list tlp1096 ..3) (list))
+   )
+
+  (pattern
+   (list
+    (list
+     (struct test-struct (tlp1097 (list) (vector tlp1098 ___) (list)))
+     (and (? test-struct? tlp1119)
+          (app test-struct-a (list tlp1100 tlp1101 tlp1102 #\a))
+          (app
+           test-struct-b
+           (and (? test-struct? tlp1107)
+                (app test-struct-a (list-rest tlp1103 tlp1104 tlp1105 8))
+                (app test-struct-b _)
+                (app test-struct-c (or '(+ 4 (+ 1 1)) '(+ 4 (+ 1 1))))
+                (app test-struct-d _)))
+          (app test-struct-c tlp1108)
+          (app
+           test-struct-d
+           (box
+            (list
+             (list tlp1109 tlp1110 tlp1111 tlp1112)
+             (list tlp1113 ..3)
+             (list tlp1114 tlp1115 tlp1116 tlp1117)))))
+     (and (? test-struct? tlp1142)
+          (app
+           test-struct-a
+           (list
+            (list)
+            tlp1120
+            (struct test-struct (tlp1121 tlp1122 tlp1123 tlp1124))
+            (vector tlp1126 tlp1127 tlp1128 tlp1129)))
+          (app
+           test-struct-b
+           (and (? test-struct? tlp1140)
+                (app test-struct-a _)
+                (app
+                 test-struct-b
+                 (or (list-rest tlp1130 tlp1131 tlp1132 tlp1133)
+                     (list-rest tlp1130 tlp1131 tlp1132 tlp1133)))
+                (app test-struct-c tlp1134)
+                (app test-struct-d (vector tlp1135 tlp1136 tlp1137 tlp1138))))
+          (app test-struct-c (list))
+          (app test-struct-d (not (not 5))))
+     (and (? number? tlp1143) (? even? tlp1144)))
+    (list
+     '(+ 1 2)
+     'symbols
+     _
+     (struct
+      test-struct
+      ((list
+        (list tlp1145 tlp1146 tlp1147 tlp1148)
+        (vector tlp1149 ___)
+        (and (? number? tlp1150) (? even? tlp1151))
+        (list tlp1152 __3))
+       2
+       (list-rest (list tlp1153 ___) (vector tlp1154 ___) 'symbols 0)
+       tlp1155)))
+    (list
+     (list-rest
+      (list-rest
+       #\c
+       (struct test-struct (tlp1157 tlp1158 tlp1159 tlp1160))
+       (and (list-rest tlp1162 tlp1163 tlp1164 tlp1165)
+            (list-rest tlp1166 tlp1167 tlp1168 tlp1169))
+       #\b)
+      (struct
+       test-struct
+       ((and (and (? test-struct? tlp1175)
+                  (app test-struct-a tlp1170)
+                  (app test-struct-b tlp1171)
+                  (app test-struct-c tlp1172)
+                  (app test-struct-d tlp1173))
+             (and (? test-struct? tlp1176)
+                  (app test-struct-a tlp1177)
+                  (app test-struct-b tlp1178)
+                  (app test-struct-c tlp1179)
+                  (app test-struct-d tlp1180)))
+        tlp1181
+        (and tlp1182 tlp1183)
+        (box (list tlp1184 tlp1185 tlp1186))))
+      (or _ _)
+      #\a)
+     (list
+      _
+      (and (? number? tlp1188) (? even? tlp1189))
+      (list)
+      (and (? test-struct? tlp1199)
+           (app test-struct-a (list tlp1190 ..3))
+           (app test-struct-b (vector tlp1191 tlp1192 tlp1193 tlp1194))
+           (app test-struct-c #f)
+           (app test-struct-d (box (list tlp1195 tlp1196 tlp1197)))))
+     (and (? number? tlp1200) (? even? tlp1201))
+     '(+ 4 5)))
+   )
+
+  (pattern
+   (list
+    (list
+     #f
+     (list tlp1202 ..3)
+     (vector tlp1203 ___)
+     (list
+      (box (list _ (box (list tlp1204 tlp1205 tlp1206)) (list tlp1207 ___)))
+      (and (? number? tlp1208) (? even? tlp1209))
+      (list)
+      (and (list tlp1210 ...) (list tlp1211 ...))))
+    (list 'symbols (and (? number? tlp1212) (? even? tlp1213)) #f 'are)
+    (list
+     (and tlp1214 tlp1215)
+     (and (? test-struct? tlp1233)
+          (app test-struct-a (vector tlp1216 ___))
+          (app
+           test-struct-b
+           (and (? test-struct? tlp1222)
+                (app test-struct-a tlp1217)
+                (app test-struct-b (not (not 4)))
+                (app test-struct-c (list))
+                (app test-struct-d (list-rest tlp1218 tlp1219 tlp1220 #\d))))
+          (app test-struct-c (box (list (list) (not (not '(+ 1 2))) (list))))
+          (app
+           test-struct-d
+           (and (? test-struct? tlp1231)
+                (app test-struct-a (list))
+                (app test-struct-b (vector tlp1223 ...))
+                (app test-struct-c tlp1224)
+                (app
+                 test-struct-d
+                 (struct test-struct (tlp1225 tlp1226 tlp1227 tlp1228))))))
+     (list tlp1234 ___)
+     _))
+   )
+
+  (pattern
+   (list
+    (and (? test-struct? tlp1239)
+         (app test-struct-a (list tlp1235 __3))
+         (app test-struct-b tlp1236)
+         (app test-struct-c (list))
+         (app test-struct-d (list tlp1237 __3)))
+    tlp1240
+    (list-rest
+     (vector tlp1241 ___)
+     (or (or (list tlp1242 tlp1243 tlp1244 tlp1245)
+             (list tlp1242 tlp1243 tlp1244 tlp1245))
+         (or (list tlp1242 tlp1243 tlp1244 tlp1245)
+             (list tlp1242 tlp1243 tlp1244 tlp1245)))
+     (or (struct
+          test-struct
+          ((box (list tlp1246 tlp1247 tlp1248))
+           (list tlp1249 ___)
+           (and (? test-struct? tlp1255)
+                (app test-struct-a tlp1250)
+                (app test-struct-b tlp1251)
+                (app test-struct-c tlp1252)
+                (app test-struct-d tlp1253))
+           (list tlp1256 tlp1257 tlp1258 tlp1259)))
+         (struct
+          test-struct
+          ((box (list tlp1246 tlp1247 tlp1248))
+           (list tlp1249 ___)
+           (and (? test-struct? tlp1255)
+                (app test-struct-a tlp1250)
+                (app test-struct-b tlp1251)
+                (app test-struct-c tlp1252)
+                (app test-struct-d tlp1253))
+           (list tlp1256 tlp1257 tlp1258 tlp1259))))
+     'these)
+    (list
+     tlp1261
+     (not (not #t))
+     (box
+      (list
+       (and (? test-struct? tlp1267)
+            (app test-struct-a tlp1262)
+            (app test-struct-b tlp1263)
+            (app test-struct-c tlp1264)
+            (app test-struct-d tlp1265))
+       #\d
+       (list tlp1268 tlp1269 tlp1270 tlp1271)))
+     (list-rest
+      (list)
+      (list-rest tlp1272 tlp1273 tlp1274 #\c)
+      (and (? test-struct? tlp1280)
+           (app test-struct-a tlp1275)
+           (app test-struct-b tlp1276)
+           (app test-struct-c tlp1277)
+           (app test-struct-d tlp1278))
+      #f)))
+   )
+
+  (pattern
+   (list
+    (vector tlp1281 ___)
+    tlp1282
+    (not (not #\b))
+    (or (list tlp1283 ___) (list tlp1283 ___)))
+   )
+
+  (pattern
+   (list
+    (list
+     (list tlp1284 ..3)
+     (list)
+     tlp1285
+     (box
+      (list
+       (and (? number? tlp1286) (? even? tlp1287))
+       (or (box (list tlp1288 tlp1289 tlp1290))
+           (box (list tlp1288 tlp1289 tlp1290)))
+       (box (list tlp1291 tlp1292 tlp1293)))))
+    (list tlp1294 __3)
+    2
+    (vector tlp1295 ___))
+   )
+
+  (pattern
+   (list
+    (struct test-struct ((list tlp1437 ...) (vector tlp1438 ___) #\d 'are))
+    (and (struct
+          test-struct
+          ((list tlp1440 ___)
+           (list-rest
+            (list-rest tlp1441 tlp1442 tlp1443 tlp1444)
+            (list)
+            (and (? number? tlp1445) (? even? tlp1446))
+            #t)
+           (list
+            (list-rest tlp1447 tlp1448 tlp1449 tlp1450)
+            tlp1451
+            (list-rest tlp1452 tlp1453 tlp1454 tlp1455)
+            (and (? test-struct? tlp1461)
+                 (app test-struct-a tlp1456)
+                 (app test-struct-b tlp1457)
+                 (app test-struct-c tlp1458)
+                 (app test-struct-d tlp1459)))
+           (box
+            (list
+             (and (? number? tlp1462) (? even? tlp1463))
+             tlp1464
+             (or tlp1465 tlp1465)))))
+         (struct
+          test-struct
+          ((list tlp1467 ___)
+           (list-rest
+            (list-rest tlp1468 tlp1469 tlp1470 tlp1471)
+            (list)
+            (and (? number? tlp1472) (? even? tlp1473))
+            #t)
+           (list
+            (list-rest tlp1474 tlp1475 tlp1476 tlp1477)
+            tlp1478
+            (list-rest tlp1479 tlp1480 tlp1481 tlp1482)
+            (and (? test-struct? tlp1483)
+                 (app test-struct-a tlp1484)
+                 (app test-struct-b tlp1485)
+                 (app test-struct-c tlp1486)
+                 (app test-struct-d tlp1487)))
+           (box
+            (list
+             (and (? number? tlp1488) (? even? tlp1489))
+             tlp1490
+             (or tlp1491 tlp1491))))))
+    (vector tlp1492 ...)
+    (vector
+     (box (list _ (vector tlp1493 ___) tlp1494))
+     (not (not #\b))
+     (and (? test-struct? tlp1503)
+          (app test-struct-a (and _ _))
+          (app test-struct-b (and (list) (list)))
+          (app test-struct-c (box (list tlp1495 tlp1496 tlp1497)))
+          (app test-struct-d (vector tlp1498 tlp1499 tlp1500 tlp1501)))
+     _))
+   (list
+    (and (vector
+          (and (? test-struct? tlp1509)
+               (app test-struct-a #\c)
+               (app test-struct-b _)
+               (app test-struct-c (list-rest tlp1504 tlp1505 tlp1506 tlp1507))
+               (app test-struct-d (list)))
+          tlp1510
+          (list tlp1511 __3)
+          #\a)
+         (vector
+          (and (? test-struct? tlp1512)
+               (app test-struct-a #\c)
+               (app test-struct-b _)
+               (app test-struct-c (list-rest tlp1513 tlp1514 tlp1515 tlp1516))
+               (app test-struct-d (list)))
+          tlp1517
+          (list tlp1518 __3)
+          #\a))
+    _
+    (struct
+     test-struct
+     ((struct test-struct (#t #\b #\d (or 6 6)))
+      (and (? number? tlp1520) (? even? tlp1521))
+      (or (struct
+           test-struct
+           ((list-rest tlp1522 tlp1523 tlp1524 tlp1525)
+            (list-rest tlp1526 tlp1527 tlp1528 tlp1529)
+            (not (not '(+ 1 2)))
+            (and (? test-struct? tlp1535)
+                 (app test-struct-a tlp1530)
+                 (app test-struct-b tlp1531)
+                 (app test-struct-c tlp1532)
+                 (app test-struct-d tlp1533))))
+          (struct
+           test-struct
+           ((list-rest tlp1522 tlp1523 tlp1524 tlp1525)
+            (list-rest tlp1526 tlp1527 tlp1528 tlp1529)
+            (not (not '(+ 1 2)))
+            (and (? test-struct? tlp1535)
+                 (app test-struct-a tlp1530)
+                 (app test-struct-b tlp1531)
+                 (app test-struct-c tlp1532)
+                 (app test-struct-d tlp1533)))))
+      tlp1537))
+    (and (list
+          (vector tlp1539 ...)
+          #\b
+          (struct test-struct (tlp1540 3 tlp1541 tlp1542))
+          (list tlp1544 ..3))
+         (list
+          (vector tlp1545 ...)
+          #\b
+          (struct test-struct (tlp1546 3 tlp1547 tlp1548))
+          (list tlp1549 ..3))))
+   (list
+    (and tlp1550 tlp1551)
+    (list tlp1552 __3)
+    (list tlp1553 ___)
+    (list tlp1554 ...))
+   )
+
+  (pattern
+   (list
+    (vector
+     (and (? test-struct? tlp1564)
+          (app test-struct-a '(+ 4 (+ 1 1)))
+          (app
+           test-struct-b
+           (and (? test-struct? tlp1562)
+                (app test-struct-a tlp1557)
+                (app test-struct-b tlp1558)
+                (app test-struct-c tlp1559)
+                (app test-struct-d tlp1560)))
+          (app test-struct-c '(+ 4 5))
+          (app test-struct-d (not (not 3))))
+     (and (box
+           (list
+            (box (list tlp1565 tlp1566 tlp1567))
+            (struct test-struct (tlp1568 tlp1569 tlp1570 tlp1571))
+            (struct test-struct (tlp1573 tlp1574 tlp1575 tlp1576))))
+          (box
+           (list
+            (box (list tlp1578 tlp1579 tlp1580))
+            (struct test-struct (tlp1581 tlp1582 tlp1583 tlp1584))
+            (struct test-struct (tlp1585 tlp1586 tlp1587 tlp1588)))))
+     (or (list-rest
+          (or tlp1589 tlp1589)
+          (and (? test-struct? tlp1595)
+               (app test-struct-a tlp1590)
+               (app test-struct-b tlp1591)
+               (app test-struct-c tlp1592)
+               (app test-struct-d tlp1593))
+          (vector tlp1596 tlp1597 tlp1598 tlp1599)
+          #t)
+         (list-rest
+          (or tlp1589 tlp1589)
+          (and (? test-struct? tlp1595)
+               (app test-struct-a tlp1590)
+               (app test-struct-b tlp1591)
+               (app test-struct-c tlp1592)
+               (app test-struct-d tlp1593))
+          (vector tlp1596 tlp1597 tlp1598 tlp1599)
+          #t))
+     (and (? test-struct? tlp1610)
+          (app test-struct-a (list tlp1600 ...))
+          (app test-struct-b (list tlp1601 ...))
+          (app test-struct-c (list tlp1602 tlp1603 tlp1604 tlp1605))
+          (app test-struct-d (list-rest tlp1606 tlp1607 tlp1608 #\b))))
+    (list
+     (and (? number? tlp1611) (? even? tlp1612))
+     (or (and (? number? tlp1613) (? even? tlp1614))
+         (and (? number? tlp1613) (? even? tlp1614)))
+     (box
+      (list
+       (struct test-struct (tlp1615 tlp1616 tlp1617 tlp1618))
+       (and (? number? tlp1620) (? even? tlp1621))
+       #f))
+     (and (? number? tlp1622) (? even? tlp1623)))
+    _
+    (list))
+   (list
+    (box
+     (list
+      (list-rest (vector tlp1624 tlp1625 tlp1626 tlp1627) tlp1628 _ #t)
+      (list tlp1629 ___)
+      (list
+       (vector tlp1630 ___)
+       (and (? test-struct? tlp1636)
+            (app test-struct-a tlp1631)
+            (app test-struct-b tlp1632)
+            (app test-struct-c tlp1633)
+            (app test-struct-d tlp1634))
+       tlp1637
+       tlp1638)))
+    (list tlp1639 ..3)
+    (list-rest _ (list tlp1640 __3) _ #t)
+    (box
+     (list
+      tlp1641
+      #t
+      (vector
+       (and (? number? tlp1642) (? even? tlp1643))
+       (list)
+       #\a
+       (box (list tlp1644 tlp1645 tlp1646))))))
+   (list
+    (list
+     (and (list-rest
+           (not (not 'symbols))
+           _
+           (list-rest tlp1647 tlp1648 tlp1649 tlp1650)
+           0)
+          (list-rest
+           (not (not 'symbols))
+           _
+           (list-rest tlp1651 tlp1652 tlp1653 tlp1654)
+           0))
+     _
+     (struct
+      test-struct
+      ((list-rest tlp1655 tlp1656 tlp1657 #f)
+       (list tlp1658 ...)
+       (and (? test-struct? tlp1664)
+            (app test-struct-a tlp1659)
+            (app test-struct-b tlp1660)
+            (app test-struct-c tlp1661)
+            (app test-struct-d tlp1662))
+       (list tlp1665 ___)))
+     (vector _ (and _ _) (not (not 6)) _))
+    (list tlp1667 __3)
+    (or 9 9)
+    '(+ 4 5))
+   )
+
+  (pattern
+   (list
+    (box (list (list) (list) (list tlp1670 __3)))
+    (not (not '(+ 1 2)))
+    (box
+     (list
+      'symbols
+      (vector
+       (or (list tlp1671 tlp1672 tlp1673 tlp1674)
+           (list tlp1671 tlp1672 tlp1673 tlp1674))
+       tlp1675
+       (vector tlp1676 ...)
+       (list tlp1677 tlp1678 tlp1679 tlp1680))
+      tlp1681))
+    (box
+     (list
+      (vector tlp1682 #f #\a _)
+      (vector
+       (and (? test-struct? tlp1688)
+            (app test-struct-a tlp1683)
+            (app test-struct-b tlp1684)
+            (app test-struct-c tlp1685)
+            (app test-struct-d tlp1686))
+       _
+       (list tlp1689 __3)
+       (box (list tlp1690 tlp1691 tlp1692)))
+      (list))))
+   (list
+    (struct
+     test-struct
+     ((vector
+       (vector tlp1693 tlp1694 tlp1695 tlp1696)
+       (list tlp1697 __3)
+       (not (not #\c))
+       tlp1698)
+      (vector tlp1699 ___)
+      (list tlp1700 ..3)
+      #\b))
+    (struct
+     test-struct
+     (tlp1702
+      (vector
+       (list)
+       (box (list tlp1703 tlp1704 tlp1705))
+       (or (list) (list))
+       tlp1706)
+      _
+      tlp1707))
+    #t
+    tlp1709)
+   (list tlp1710 (vector tlp1711 ___) _ tlp1712)
+   )
+
+  (pattern
+   (list
+    (list-rest
+     (list)
+     (and (? test-struct? tlp1720)
+          (app test-struct-a (box (list tlp1715 tlp1716 tlp1717)))
+          (app test-struct-b _)
+          (app test-struct-c 0)
+          (app test-struct-d tlp1718))
+     (not (not '(+ 4 5)))
+     8)
+    '(+ 4 (+ 1 1))
+    (and (? number? tlp1721) (? even? tlp1722))
+    (vector
+     (and (? number? tlp1723) (? even? tlp1724))
+     _
+     (box (list (not (not '(+ 4 (+ 1 1)))) (not (not #t)) (list tlp1725 ___)))
+     (not (not '(+ 1 2)))))
+   (list _ (box (list (list tlp1726 ...) tlp1727 (list))) tlp1728 '(+ 4 5))
+   (list
+    tlp1729
+    #\a
+    (vector
+     (and (? number? tlp1730) (? even? tlp1731))
+     (list-rest
+      '(+ 1 2)
+      (list tlp1732 tlp1733 tlp1734 tlp1735)
+      (list tlp1736 __3)
+      #\b)
+     (list-rest
+      (and (? test-struct? tlp1742)
+           (app test-struct-a tlp1737)
+           (app test-struct-b tlp1738)
+           (app test-struct-c tlp1739)
+           (app test-struct-d tlp1740))
+      (list)
+      (box (list tlp1743 tlp1744 tlp1745))
+      'these)
+     (list))
+    #f)
+   )
+
+  (pattern
+   (list (vector tlp1748 ...) _ (or _ _) (list tlp1749 __3))
+   (list
+    (list tlp1750 ..3)
+    (and tlp1751 tlp1752)
+    tlp1753
+    (list-rest
+     tlp1754
+     (list (list) tlp1755 (list) (box (list tlp1756 tlp1757 tlp1758)))
+     (list-rest
+      (list tlp1759 ___)
+      (and (? number? tlp1760) (? even? tlp1761))
+      (vector tlp1762 tlp1763 tlp1764 tlp1765)
+      #t)
+     #t))
+   (list
+    (and (? test-struct? tlp1777)
+         (app test-struct-a tlp1766)
+         (app test-struct-b (vector tlp1767 ...))
+         (app test-struct-c (vector tlp1768 ___))
+         (app
+          test-struct-d
+          (struct
+           test-struct
+           ((list tlp1769 tlp1770 tlp1771 tlp1772)
+            (list tlp1773 ___)
+            tlp1774
+            #t))))
+    tlp1778
+    (and (? test-struct? tlp1798)
+         (app
+          test-struct-a
+          (list
+           (list-rest tlp1779 tlp1780 tlp1781 #\a)
+           (and (? test-struct? tlp1787)
+                (app test-struct-a tlp1782)
+                (app test-struct-b tlp1783)
+                (app test-struct-c tlp1784)
+                (app test-struct-d tlp1785))
+           (list tlp1788 ___)
+           (box (list tlp1789 tlp1790 tlp1791))))
+         (app test-struct-b (or '(+ 4 5) '(+ 4 5)))
+         (app
+          test-struct-c
+          (struct test-struct (tlp1792 (vector tlp1793 ...) tlp1794 tlp1795)))
+         (app test-struct-d _))
+    (and (? test-struct? tlp1819)
+         (app
+          test-struct-a
+          (box (list tlp1799 (list tlp1800 ..3) (and tlp1801 tlp1802))))
+         (app
+          test-struct-b
+          (and (? test-struct? tlp1814)
+               (app test-struct-a (list tlp1803 tlp1804 tlp1805 tlp1806))
+               (app test-struct-b (vector tlp1807 tlp1808 tlp1809 tlp1810))
+               (app test-struct-c (and (or tlp1811 tlp1811) (or tlp1812 tlp1812)))
+               (app test-struct-d (or (list) (list)))))
+         (app test-struct-c (box (list tlp1815 (list) tlp1816)))
+         (app test-struct-d (vector tlp1817 ...))))
+   )
+
+  (pattern
+   (list (list tlp1907 ___) (list) 'symbols 'these)
+   (list
+    (list #t (and (list) (list)) (and tlp1908 tlp1909) (list tlp1910 ___))
+    (vector tlp1911 ___)
+    (list-rest (not (not #\b)) '(+ 1 2) tlp1912 #\a)
+    tlp1913)
+   (list
+    (vector
+     (and (? test-struct? tlp1920)
+          (app test-struct-a tlp1914)
+          (app test-struct-b tlp1915)
+          (app test-struct-c (box (list tlp1916 tlp1917 tlp1918)))
+          (app test-struct-d #\b))
+     (list-rest _ (list tlp1921 tlp1922 tlp1923 tlp1924) #f #\d)
+     (and (? test-struct? tlp1936)
+          (app test-struct-a (box (list tlp1925 tlp1926 tlp1927)))
+          (app test-struct-b (list tlp1928 tlp1929 tlp1930 tlp1931))
+          (app test-struct-c (box (list tlp1932 tlp1933 tlp1934)))
+          (app test-struct-d _))
+     (and (? test-struct? tlp1949)
+          (app test-struct-a '(+ 4 5))
+          (app
+           test-struct-b
+           (or (struct test-struct (tlp1937 tlp1938 tlp1939 tlp1940))
+               (struct test-struct (tlp1937 tlp1938 tlp1939 tlp1940))))
+          (app test-struct-c (list tlp1942 __3))
+          (app
+           test-struct-d
+           (struct test-struct (tlp1943 tlp1944 tlp1945 tlp1946)))))
+    #t
+    _
+    tlp1950)
+   )
+
+  (pattern
+   (list
+    (list-rest
+     tlp1952
+     (or (struct test-struct (2 tlp1953 tlp1954 (list)))
+         (struct test-struct (2 tlp1953 tlp1954 (list))))
+     (struct
+      test-struct
+      ((vector tlp1956 tlp1957 tlp1958 tlp1959)
+       (and (vector tlp1960 ___) (vector tlp1961 ___))
+       (or #t #t)
+       (list)))
+     'these)
+    (not (not '(+ 4 (+ 1 1))))
+    (vector tlp1963 ___)
+    (list))
+   (list
+    (list tlp1964 ..3)
+    (or (and (? number? tlp1965) (? even? tlp1966))
+        (and (? number? tlp1965) (? even? tlp1966)))
+    (and (? test-struct? tlp1978)
+         (app test-struct-a tlp1967)
+         (app test-struct-b 'symbols)
+         (app test-struct-c tlp1968)
+         (app
+          test-struct-d
+          (list-rest
+           (vector tlp1969 ...)
+           tlp1970
+           (and (? test-struct? tlp1976)
+                (app test-struct-a tlp1971)
+                (app test-struct-b tlp1972)
+                (app test-struct-c tlp1973)
+                (app test-struct-d tlp1974))
+           5)))
+    (and (list) (list)))
+   (list
+    (list)
+    tlp1979
+    (struct
+     test-struct
+     ((and (? number? tlp1980) (? even? tlp1981))
+      (list)
+      (and (and (? test-struct? tlp1997)
+                (app test-struct-a (list-rest tlp1982 tlp1983 tlp1984 tlp1985))
+                (app test-struct-b (list-rest tlp1986 tlp1987 tlp1988 tlp1989))
+                (app test-struct-c tlp1990)
+                (app
+                 test-struct-d
+                 (struct test-struct (tlp1991 tlp1992 tlp1993 tlp1994))))
+           (and (? test-struct? tlp1998)
+                (app test-struct-a (list-rest tlp1999 tlp2000 tlp2001 tlp2002))
+                (app test-struct-b (list-rest tlp2003 tlp2004 tlp2005 tlp2006))
+                (app test-struct-c tlp2007)
+                (app
+                 test-struct-d
+                 (struct test-struct (tlp2008 tlp2009 tlp2010 tlp2011)))))
+      (list tlp2012 ..3)))
+    tlp2014)
+   )
+
+  (pattern
+   (list (not (not #t)) tlp2016 (list) tlp2017)
+   (list
+    (list-rest
+     (list tlp2018 (not (not '(+ 1 2))) 'are tlp2019)
+     (list
+      (list tlp2020 tlp2021 tlp2022 tlp2023)
+      (and (list-rest tlp2024 tlp2025 tlp2026 tlp2027)
+           (list-rest tlp2028 tlp2029 tlp2030 tlp2031))
+      (list tlp2032 __3)
+      _)
+     (and (? number? tlp2033) (? even? tlp2034))
+     #\b)
+    _
+    (list tlp2035 __3)
+    #f)
+   (list
+    (list
+     (list tlp2036 ...)
+     (and (and (? test-struct? tlp2042)
+               (app test-struct-a tlp2037)
+               (app test-struct-b 7)
+               (app test-struct-c (box (list tlp2038 tlp2039 tlp2040)))
+               (app test-struct-d (not (not #t))))
+          (and (? test-struct? tlp2043)
+               (app test-struct-a tlp2044)
+               (app test-struct-b 7)
+               (app test-struct-c (box (list tlp2045 tlp2046 tlp2047)))
+               (app test-struct-d (not (not #t)))))
+     (and (vector
+           (and tlp2048 tlp2049)
+           (list tlp2050 tlp2051 tlp2052 tlp2053)
+           (and tlp2054 tlp2055)
+           tlp2056)
+          (vector
+           (and tlp2057 tlp2058)
+           (list tlp2059 tlp2060 tlp2061 tlp2062)
+           (and tlp2063 tlp2064)
+           tlp2065))
+     #\c)
+    'symbols
+    (list)
+    (not (not '(+ 4 5))))
+   )
+
+  (pattern
+   (list (and (? number? tlp2067) (? even? tlp2068)) _ (or 'these 'these) 8)
+   (list
+    (list tlp2069 ..3)
+    (list tlp2070 ..3)
+    (box
+     (list (not (not 'are)) (and (? number? tlp2071) (? even? tlp2072)) tlp2073))
+    (list-rest
+     (vector (list) tlp2074 tlp2075 (list-rest tlp2076 tlp2077 tlp2078 'symbols))
+     tlp2079
+     (and (? test-struct? tlp2086)
+          (app test-struct-a (vector tlp2080 tlp2081 tlp2082 tlp2083))
+          (app test-struct-b _)
+          (app test-struct-c (not (not #\c)))
+          (app test-struct-d (list tlp2084 __3)))
+     'are))
+   (list
+    #\b
+    _
+    (struct
+     test-struct
+     ((list tlp2087 ...)
+      (and (? number? tlp2088) (? even? tlp2089))
+      (or tlp2090 tlp2090)
+      (vector (not (not '(+ 1 2))) tlp2091 (list) tlp2092)))
+    tlp2094)
+   )
+
+  (pattern
+   (list
+    (and (? number? tlp2096) (? even? tlp2097))
+    (and (? test-struct? tlp2105)
+         (app test-struct-a #\b)
+         (app
+          test-struct-b
+          (or (and (list tlp2098 ___) (list tlp2099 ___))
+              (and (list tlp2098 ___) (list tlp2099 ___))))
+         (app test-struct-c (and (? number? tlp2100) (? even? tlp2101)))
+         (app test-struct-d (and (? number? tlp2102) (? even? tlp2103))))
+    #t
+    #\a)
+   (list
+    (and (? test-struct? tlp2128)
+         (app test-struct-a _)
+         (app test-struct-b (list))
+         (app
+          test-struct-c
+          (struct
+           test-struct
+           ((struct test-struct (tlp2106 tlp2107 tlp2108 tlp2109))
+            (vector tlp2111 ...)
+            tlp2112
+            (vector tlp2113 tlp2114 tlp2115 tlp2116))))
+         (app
+          test-struct-d
+          (vector
+           (box (list tlp2118 tlp2119 tlp2120))
+           (struct test-struct (tlp2121 tlp2122 tlp2123 tlp2124))
+           tlp2126
+           (list))))
+    (and (? test-struct? tlp2139)
+         (app test-struct-a _)
+         (app
+          test-struct-b
+          (and (? test-struct? tlp2134)
+               (app test-struct-a _)
+               (app test-struct-b (vector tlp2129 ___))
+               (app test-struct-c (list-rest tlp2130 tlp2131 tlp2132 'symbols))
+               (app test-struct-d 'these)))
+         (app test-struct-c (and (? number? tlp2135) (? even? tlp2136)))
+         (app test-struct-d tlp2137))
+    (vector tlp2140 ...)
+    tlp2141)
+   (list
+    (struct
+     test-struct
+     ((list-rest
+       (struct test-struct (tlp2142 tlp2143 tlp2144 tlp2145))
+       (not (not #f))
+       tlp2147
+       #t)
+      _
+      tlp2148
+      (list-rest
+       (and (? test-struct? tlp2154)
+            (app test-struct-a tlp2149)
+            (app test-struct-b tlp2150)
+            (app test-struct-c tlp2151)
+            (app test-struct-d tlp2152))
+       (and tlp2155 tlp2156)
+       (box (list tlp2157 tlp2158 tlp2159))
+       #\b)))
+    (list tlp2161 __3)
+    'these
+    (and (? number? tlp2162) (? even? tlp2163)))
+   )
+
+  (pattern
+   (list (not (not #\b)) '(+ 4 (+ 1 1)) (vector tlp2260 ...) _)
+   (list
+    (list)
+    (and (? test-struct? tlp2264)
+         (app test-struct-a (not (not #\a)))
+         (app test-struct-b (vector tlp2261 ...))
+         (app test-struct-c (or (list) (list)))
+         (app
+          test-struct-d
+          (list-rest '(+ 1 2) (list tlp2262 ...) (not (not #\b)) 'these)))
+    (or (list tlp2265 __3) (list tlp2265 __3))
+    (list))
+   (list
+    (list tlp2266 ___)
+    (struct test-struct ((list tlp2267 __3) (not (not 'are)) tlp2268 (list)))
+    (list tlp2270 __3)
+    (and #f #f))
+   )
+
+  (pattern
+   (list
+    tlp2273
+    (box
+     (list
+      (struct
+       test-struct
+       ((vector tlp2274 ___)
+        (vector tlp2275 ___)
+        (vector tlp2276 ...)
+        (and (list tlp2277 ___) (list tlp2278 ___))))
+      (and (? number? tlp2280) (? even? tlp2281))
+      (list (and tlp2282 tlp2283) tlp2284 _ (list tlp2285 ___))))
+    _
+    (and (? number? tlp2286) (? even? tlp2287)))
+   (list
+    tlp2288
+    (and (list-rest
+          (list-rest
+           '(+ 4 5)
+           (list tlp2289 tlp2290 tlp2291 tlp2292)
+           (not (not #\a))
+           #\b)
+          (list-rest
+           (list)
+           #\a
+           (and (? number? tlp2293) (? even? tlp2294))
+           'these)
+          (list tlp2295 ___)
+          6)
+         (list-rest
+          (list-rest
+           '(+ 4 5)
+           (list tlp2296 tlp2297 tlp2298 tlp2299)
+           (not (not #\a))
+           #\b)
+          (list-rest
+           (list)
+           #\a
+           (and (? number? tlp2300) (? even? tlp2301))
+           'these)
+          (list tlp2302 ___)
+          6))
+    (box
+     (list
+      (list)
+      _
+      (and (? test-struct? tlp2306)
+           (app test-struct-a tlp2303)
+           (app test-struct-b (list))
+           (app test-struct-c #t)
+           (app test-struct-d (or (list tlp2304 ..3) (list tlp2304 ..3))))))
+    (struct
+     test-struct
+     (tlp2307
+      (list)
+      (not (not 'symbols))
+      (or (and (? number? tlp2308) (? even? tlp2309))
+          (and (? number? tlp2308) (? even? tlp2309))))))
+   (list tlp2311 (or tlp2312 tlp2312) (vector tlp2313 ___) tlp2314)
+   )
+
+  (pattern
+   (list
+    (not (not #\b))
+    _
+    (list
+     (list tlp2317 ...)
+     (list tlp2318 ..3)
+     (vector
+      tlp2319
+      _
+      (box (list tlp2320 tlp2321 tlp2322))
+      (struct test-struct (tlp2323 tlp2324 tlp2325 tlp2326)))
+     '(+ 4 5))
+    (list tlp2328 __3))
+   (list
+    tlp2329
+    (list tlp2330 ...)
+    (list
+     (struct
+      test-struct
+      (_ (struct test-struct (tlp2331 tlp2332 tlp2333 tlp2334)) _ (list)))
+     tlp2337
+     (and (and (box (list tlp2338 tlp2339 tlp2340))
+               (box (list tlp2341 tlp2342 tlp2343)))
+          (and (box (list tlp2344 tlp2345 tlp2346))
+               (box (list tlp2347 tlp2348 tlp2349))))
+     (and #\d #\d))
+    (list-rest
+     (list-rest
+      (struct test-struct (tlp2350 tlp2351 tlp2352 tlp2353))
+      (or (struct test-struct (tlp2355 tlp2356 tlp2357 tlp2358))
+          (struct test-struct (tlp2355 tlp2356 tlp2357 tlp2358)))
+      (list-rest tlp2360 tlp2361 tlp2362 #\c)
+      #\a)
+     (list tlp2363 ___)
+     (list)
+     3))
+   (list
+    (and (? test-struct? tlp2396)
+         (app
+          test-struct-a
+          (and (? test-struct? tlp2371)
+               (app test-struct-a tlp2364)
+               (app test-struct-b tlp2365)
+               (app test-struct-c (list tlp2366 tlp2367 tlp2368 tlp2369))
+               (app test-struct-d (list))))
+         (app
+          test-struct-b
+          (struct
+           test-struct
+           ((and (? test-struct? tlp2377)
+                 (app test-struct-a tlp2372)
+                 (app test-struct-b tlp2373)
+                 (app test-struct-c tlp2374)
+                 (app test-struct-d tlp2375))
+            (list tlp2378 ..3)
+            (and (? number? tlp2379) (? even? tlp2380))
+            (vector tlp2381 ...))))
+         (app
+          test-struct-c
+          (box
+           (list
+            (list tlp2383 ..3)
+            (and (? test-struct? tlp2389)
+                 (app test-struct-a tlp2384)
+                 (app test-struct-b tlp2385)
+                 (app test-struct-c tlp2386)
+                 (app test-struct-d tlp2387))
+            tlp2390)))
+         (app
+          test-struct-d
+          (and (and (? number? tlp2391) (? even? tlp2392))
+               (and (? number? tlp2393) (? even? tlp2394)))))
+    (list
+     '(+ 1 2)
+     (vector tlp2397 ___)
+     (struct
+      test-struct
+      ((vector tlp2398 tlp2399 tlp2400 tlp2401)
+       (and (? number? tlp2402) (? even? tlp2403))
+       tlp2404
+       (list-rest tlp2405 tlp2406 tlp2407 'symbols)))
+     _)
+    (struct
+     test-struct
+     ((list tlp2409 ..3)
+      (not (not #\a))
+      tlp2410
+      (and (? number? tlp2411) (? even? tlp2412))))
+    (list))
+   )
+
+  (pattern
+   (list
+    tlp2416
+    (not (not #t))
+    (or (list-rest
+         (and (list tlp2417 ...) (list tlp2418 ...))
+         (vector
+          (list-rest tlp2419 tlp2420 tlp2421 tlp2422)
+          #\c
+          tlp2423
+          (list-rest tlp2424 tlp2425 tlp2426 tlp2427))
+         9
+         'are)
+        (list-rest
+         (and (list tlp2417 ...) (list tlp2418 ...))
+         (vector
+          (list-rest tlp2419 tlp2420 tlp2421 tlp2422)
+          #\c
+          tlp2423
+          (list-rest tlp2424 tlp2425 tlp2426 tlp2427))
+         9
+         'are))
+    (list
+     tlp2428
+     (and (? number? tlp2429) (? even? tlp2430))
+     (not (not '(+ 4 5)))
+     (or (struct
+          test-struct
+          ((box (list tlp2431 tlp2432 tlp2433))
+           #f
+           (vector tlp2434 tlp2435 tlp2436 tlp2437)
+           _))
+         (struct
+          test-struct
+          ((box (list tlp2431 tlp2432 tlp2433))
+           #f
+           (vector tlp2434 tlp2435 tlp2436 tlp2437)
+           _)))))
+   (list
+    (vector
+     (list)
+     (not (not #\d))
+     (box (list (not (not 9)) (list) 'symbols))
+     (list))
+    _
+    tlp2439
+    (list-rest tlp2440 _ tlp2441 #t))
+   (list
+    (or (not (not #\b)) (not (not #\b)))
+    (list tlp2442 (list) (list) (and (vector tlp2443 ...) (vector tlp2444 ...)))
+    (list tlp2445 ___)
+    (or (and (? number? tlp2446) (? even? tlp2447))
+        (and (? number? tlp2446) (? even? tlp2447))))
+   )
+
+  (pattern
+   (list
+    (not (not #t))
+    tlp2450
+    (or (box
+         (list
+          (struct
+           test-struct
+           ((vector tlp2451 ...) #\d (or tlp2452 tlp2452) (vector tlp2453 ___)))
+          (list tlp2455 ..3)
+          tlp2456))
+        (box
+         (list
+          (struct
+           test-struct
+           ((vector tlp2451 ...) #\d (or tlp2452 tlp2452) (vector tlp2453 ___)))
+          (list tlp2455 ..3)
+          tlp2456)))
+    (or (list tlp2457 ...) (list tlp2457 ...)))
+   (list
+    (list-rest
+     (box (list (or _ _) (list) (list tlp2458 ..3)))
+     tlp2459
+     (vector tlp2460 ___)
+     #t)
+    (and (? test-struct? tlp2470)
+         (app test-struct-a (not (not #\b)))
+         (app
+          test-struct-b
+          (struct
+           test-struct
+           ((list)
+            (not (not #\b))
+            'symbols
+            (or (vector tlp2461 tlp2462 tlp2463 tlp2464)
+                (vector tlp2461 tlp2462 tlp2463 tlp2464)))))
+         (app test-struct-c #\d)
+         (app
+          test-struct-d
+          (box (list (and tlp2466 tlp2467) (vector tlp2468 ___) _))))
+    (vector tlp2471 ___)
+    (not (not 9)))
+   (list
+    (vector
+     (and (? number? tlp2472) (? even? tlp2473))
+     (list)
+     (struct
+      test-struct
+      ((vector tlp2474 tlp2475 tlp2476 tlp2477)
+       (list tlp2478 ___)
+       (list tlp2479 ..3)
+       '(+ 1 2)))
+     (or _ _))
+    (list tlp2481 ..3)
+    tlp2482
+    (and (? number? tlp2483) (? even? tlp2484)))
+   )
+
+  ))
+
+(report-errs)
diff --git a/collects/tests/mzscheme/match/match-test.ss b/collects/tests/mzscheme/match/match-test.ss
new file mode 100644
index 0000000000..418a6570a7
--- /dev/null
+++ b/collects/tests/mzscheme/match/match-test.ss
@@ -0,0 +1,8544 @@
+(load-relative "../loadtest.ss")
+(SECTION 'MATCH)
+(require  (lib "match.ss"))
+;(require  "../match.ss")
+
+(define-syntax test-mac
+  (syntax-rules ()
+    ((id to-test eval-to)
+     (with-handlers ([(lambda exn #t)
+                      (lambda (exn) (failed-test (exn-message exn) 
+                                                  (quote to-test)
+                                                 '() eval-to))])
+                    (let ((res to-test))
+                      (if (equal? res eval-to)
+                          #t
+                          (failed-test '() (quote to-test) res eval-to)))))))
+
+(define (failed-test exn-msg test-code result should-have-been)
+  `((Test-Failure)
+    (Code ,test-code)
+    (Expected-Result ,should-have-been)
+    ,(if (null? exn-msg) 
+         `(Actual-Result ,result)
+         `(Exception ,exn-msg))))
+
+; (define-syntax mytest
+;   (lambda (stx)
+;     (syntax-case stx ()
+;       ((_ t result)
+;        #`(test result #,(syntax/loc stx (lambda () t))))))) 
+
+
+(define-syntax mytest
+  (lambda (stx)
+    (syntax-case stx ()
+      ((_ t result)
+       #`(test #t #,(syntax/loc stx (lambda () (test-mac t result)))))))) 
+
+
+  (define-struct test-struct (a b c d))
+  (define inst-struct-name29 (make-test-struct `#\b `2 `(+ 4 5) `symbols))
+  (define inst-struct-name33
+    (make-test-struct
+      `(,inst-struct-name29 (+ 1 2) #\c (+ 4 5))
+      `()
+      `(these #\d #t)
+      `16))
+  (define inst-struct-name46 (make-test-struct `#\c `#\d `16 `4))
+  (define inst-struct-name54 (make-test-struct `#\c `4 `#\c `#\b))
+  (define inst-struct-name72 (make-test-struct `#f `4 `4 `#\c))
+  (define inst-struct-name75
+    (make-test-struct
+      `(+ 4 (+ 1 1))
+      `,inst-struct-name72
+      `#(9 #\b 9)
+      `(+ 4 5)))
+  (define inst-struct-name77
+    (make-test-struct `#\c `(#\d symbols these) `,inst-struct-name75 `these))
+  (define inst-struct-name84 (make-test-struct `#\b `4 `#\c `#\d))
+  (define inst-struct-name90 (make-test-struct `symbols `#\a `#\c `symbols))
+  (define inst-struct-name116
+    (make-test-struct `symbols `(+ 4 (+ 1 1)) `4 `#\b))
+  (define inst-struct-name145 (make-test-struct `(+ 1 2) `4 `symbols `these))
+  (define inst-struct-name147
+    (make-test-struct
+      `#f
+      `((+ 4 (+ 1 1)) these 6)
+      `#(are () ,inst-struct-name145 (+ 4 (+ 1 1)))
+      `()))
+  (define inst-struct-name158
+    (make-test-struct `18 `(#\b 2 #t) `() `(+ 4 (+ 1 1))))
+  (define inst-struct-name164
+    (make-test-struct
+      `()
+      `,inst-struct-name158
+      `#\d
+      `(#(these these 1) #\b (#\c #f (+ 4 (+ 1 1))) . #f)))
+  (define inst-struct-name173 (make-test-struct `#\b `#\b `#\b `are))
+  (define inst-struct-name175
+    (make-test-struct `() `#&((+ 1 2) #t (+ 4 5)) `,inst-struct-name173 `#t))
+  (define inst-struct-name190
+    (make-test-struct
+      `,inst-struct-name175
+      `()
+      `#f
+      `((are #\b 5) these #((+ 1 2) 8 these (+ 1 2)) . #f)))
+  (define inst-struct-name198 (make-test-struct `these `#t `7 `(+ 4 5)))
+  (define inst-struct-name218
+    (make-test-struct `(+ 4 (+ 1 1)) `#((+ 4 5) symbols 2 4) `#\a `#\d))
+  (define inst-struct-name224 (make-test-struct `#\b `(+ 1 2) `4 `these))
+  (define inst-struct-name250 (make-test-struct `7 `symbols `are `these))
+  (define inst-struct-name260
+    (make-test-struct
+      `(symbols #\b symbols)
+      `()
+      `(symbols (+ 1 2) 5 #\d)
+      `(#\a #\c #\c . 1)))
+  (define inst-struct-name272
+    (make-test-struct `#&(#\b #\a #f) `#((+ 4 5) #\b #t) `#\b `(+ 4 (+ 1 1))))
+  (define inst-struct-name281 (make-test-struct `#\b `5 `(+ 1 2) `4))
+  (define inst-struct-name286 (make-test-struct `#\b `(+ 4 5) `0 `1))
+  (define inst-struct-name288
+    (make-test-struct
+      `#&(#\b #\b #\b)
+      `(these (+ 1 2) #\c)
+      `,inst-struct-name281
+      `,inst-struct-name286))
+  (define inst-struct-name304 (make-test-struct `#\d `are `#f `7))
+  (define inst-struct-name305
+    (make-test-struct `#\d `(7 #\c #\c) `2 `,inst-struct-name304))
+  (define inst-struct-name317 (make-test-struct `9 `#\c `symbols `#\b))
+  (define inst-struct-name318
+    (make-test-struct `() `,inst-struct-name317 `symbols `0))
+  (define inst-struct-name334 (make-test-struct `#\d `#f `(+ 4 5) `7))
+  (define inst-struct-name350
+    (make-test-struct
+      `()
+      `(+ 4 (+ 1 1))
+      `#&(#\d 2 #f)
+      `#(#\a these #t (+ 1 2))))
+  (define inst-struct-name359
+    (make-test-struct `(+ 4 (+ 1 1)) `(+ 4 5) `#\b `#\a))
+  (define inst-struct-name372 (make-test-struct `symbols `6 `4 `#\c))
+  (define inst-struct-name385 (make-test-struct `#\d `8 `#\a `#\a))
+  (define inst-struct-name399 (make-test-struct `4 `() `#\a `#(#f (+ 4 5) #f)))
+  (define inst-struct-name408
+    (make-test-struct `these `(+ 4 (+ 1 1)) `((+ 4 (+ 1 1)) (+ 4 5) are) `#\a))
+  (define inst-struct-name417
+    (make-test-struct `6 `#\b `(+ 4 (+ 1 1)) `(+ 4 5)))
+  (define inst-struct-name424
+    (make-test-struct
+      `(#((+ 4 (+ 1 1)) #\b 7 #\a)
+        ,inst-struct-name417
+        ((+ 4 5) are 9 . these)
+        .
+        #f)
+      `(#t #\a #f)
+      `()
+      `(are #\b 4)))
+  (define inst-struct-name431
+    (make-test-struct
+      `these
+      `3
+      `#((+ 4 (+ 1 1)) symbols 1 are)
+      `(8 #t (+ 4 (+ 1 1)))))
+  (define inst-struct-name433
+    (make-test-struct `() `1 `,inst-struct-name431 `are))
+  (define inst-struct-name477
+    (make-test-struct `#t `() `these `#((+ 4 5) #t #t #\c)))
+  (define inst-struct-name487
+    (make-test-struct `((7 these #\b) (+ 4 (+ 1 1)) #t . 0) `() `(+ 4 5) `7))
+  (define inst-struct-name514
+    (make-test-struct `(+ 4 5) `#\b `(+ 4 (+ 1 1)) `#t))
+  (define inst-struct-name522
+    (make-test-struct
+      `,inst-struct-name514
+      `(#\b #t #\d . #\a)
+      `(7 5 #f . #\b)
+      `#\c))
+  (define inst-struct-name530 (make-test-struct `8 `5 `#\c `7))
+  (define inst-struct-name541 (make-test-struct `(+ 1 2) `4 `symbols `(+ 1 2)))
+  (define inst-struct-name545
+    (make-test-struct `,inst-struct-name541 `8 `() `()))
+  (define inst-struct-name547
+    (make-test-struct
+      `are
+      `(9 (#f symbols #\d) ,inst-struct-name530 symbols)
+      `(4 #\b #t)
+      `,inst-struct-name545))
+  (define inst-struct-name554
+    (make-test-struct `#(#\d #f #\d) `are `1 `(+ 4 (+ 1 1))))
+  (define inst-struct-name597 (make-test-struct `#\d `(+ 4 (+ 1 1)) `2 `#\a))
+  (define inst-struct-name600
+    (make-test-struct
+      `#f
+      `(these #\b 7)
+      `(18 #(#f (+ 4 5) #t) ,inst-struct-name597 (#t 8 these))
+      `(+ 4 (+ 1 1))))
+  (define inst-struct-name618
+    (make-test-struct `#&((+ 4 5) #\d #\c) `are `() `()))
+  (define inst-struct-name642
+    (make-test-struct `#\d `(+ 4 5) `(+ 4 5) `(+ 1 2)))
+  (define inst-struct-name661 (make-test-struct `#\a `#\c `#f `#\c))
+  (define inst-struct-name669
+    (make-test-struct
+      `,inst-struct-name661
+      `(#\b #\b #f . #\a)
+      `(#\d #t (+ 1 2) . #\b)
+      `#t))
+  (define (let-tests)
+    (list
+     (mytest
+      (match-letrec
+        (((#&((and (? number? tlp327) (? even? tlp328))
+              #(tlp329 ...)
+              (tlp330 ..3))
+           ()
+           tlp331
+           (or #(tlp332 ...) #(tlp332 ...)))
+          `(#&(2 #(6 (+ 1 2) #t) (#\c #t symbols)) () #\b #(#\d #f #\b))))
+        (list tlp327 tlp329 tlp330 tlp331 tlp332))
+      '(2 (6 (+ 1 2) #t) (#\c #t symbols) #\b (#\d #f #\b)))
+     (mytest
+      (match-let*
+        (((#(tlp333 ...)
+           ((and (? test-struct? tlp335)
+                 (= test-struct-a (and _ _))
+                 (= test-struct-b (not (not #f)))
+                 (= test-struct-c '(+ 4 5))
+                 (= test-struct-d 7))
+            (and (? number? tlp336) (? even? tlp337))
+            tlp338
+            quote
+            these)
+           (tlp339
+             (not (not 'these))
+             ($
+              test-struct
+              ()
+              '(+ 4 (+ 1 1))
+              (and #&(tlp340 tlp341 tlp342) #&(tlp343 tlp344 tlp345))
+              #(tlp346 tlp347 tlp348 tlp349))
+             .
+             #\a)
+           #(tlp351 ...))
+          `(#(#\a #\a 4)
+            (,inst-struct-name334 12 (+ 1 2) . these)
+            ((+ 4 (+ 1 1)) these ,inst-struct-name350 . #\a)
+            #(#\b #\d 4))))
+        (list
+         tlp333
+         tlp336
+         tlp338
+         tlp339
+         tlp340
+         tlp341
+         tlp342
+         tlp346
+         tlp347
+         tlp348
+         tlp349
+         tlp351))
+      '((#\a #\a 4)
+        12
+        (+ 1 2)
+        (+ 4 (+ 1 1))
+        #\d
+        2
+        #f
+        #\a
+        these
+        #t
+        (+ 1 2)
+        (#\b #\d 4)))))
+  (define (multi-let-tests)
+    (list
+     (mytest
+      (match-let
+        (((tlp352
+            #(#&((or _ _)
+                 (and (? number? tlp353) (? even? tlp354))
+                 ($ test-struct tlp355 tlp356 tlp357 tlp358))
+              (_
+               (tlp360 ..3)
+               (and (? number? tlp361) (? even? tlp362))
+               (or (tlp363 ..3) (tlp363 ..3)))
+              ((not (not 'symbols))
+               (and (and tlp364 tlp365) (and tlp366 tlp367))
+               ($ test-struct tlp368 tlp369 tlp370 tlp371)
+               _)
+              tlp373)
+            ((tlp374 ...) (tlp375 ...) _ . #\c)
+            (and (? number? tlp376) (? even? tlp377)))
+          `((+ 1 2)
+            #(#&(2 16 ,inst-struct-name359)
+              (#\a (are #\c #t) 8 (#\b #\a #\d))
+              (symbols #\b ,inst-struct-name372 4)
+              #\b)
+            ((2 6 #\c) (#\d #t #t) 1 . #\c)
+            16))
+         ((() #&(() tlp378 (not (not #\c))) #\b tlp379)
+          `(() #&(() #\c #\c) #\b #\d)))
+        (list
+         tlp352
+         tlp353
+         tlp355
+         tlp356
+         tlp357
+         tlp358
+         tlp360
+         tlp361
+         tlp363
+         tlp364
+         tlp368
+         tlp369
+         tlp370
+         tlp371
+         tlp373
+         tlp374
+         tlp375
+         tlp376
+         tlp378
+         tlp379))
+      '((+ 1 2)
+        16
+        (+ 4 (+ 1 1))
+        (+ 4 5)
+        #\b
+        #\a
+        (are #\c #t)
+        8
+        (#\b #\a #\d)
+        #\b
+        symbols
+        6
+        4
+        #\c
+        #\b
+        (2 6 #\c)
+        (#\d #t #t)
+        16
+        #\c
+        #\d))
+     (mytest
+      (match-letrec
+        (((#&(((not (not 8))
+               #(tlp380 ...)
+               (and (? test-struct? tlp386)
+                    (= test-struct-a tlp381)
+                    (= test-struct-b tlp382)
+                    (= test-struct-c tlp383)
+                    (= test-struct-d tlp384))
+               .
+               #\a)
+              #&(#t #(tlp387 ___) (tlp388 ..3))
+              (and tlp389 tlp390))
+           (not (not 6))
+           ()
+           '(+ 4 (+ 1 1)))
+          `(#&((8 #(#\c #\a are) ,inst-struct-name385 . #\a)
+               #&(#t #(#f #\c #t) (these #\b (+ 1 2)))
+               (+ 4 5))
+            6
+            ()
+            (+ 4 (+ 1 1))))
+         (((tlp391 __3) (not (not 3)) tlp392 (tlp393 ...))
+          `(((+ 1 2) #f (+ 4 (+ 1 1))) 3 are (symbols #\a #\d))))
+        (list
+         tlp380
+         tlp381
+         tlp382
+         tlp383
+         tlp384
+         tlp387
+         tlp388
+         tlp389
+         tlp391
+         tlp392
+         tlp393))
+      '((#\c #\a are)
+        #\d
+        8
+        #\a
+        #\a
+        (#f #\c #t)
+        (these #\b (+ 1 2))
+        (+ 4 5)
+        ((+ 1 2) #f (+ 4 (+ 1 1)))
+        are
+        (symbols #\a #\d)))))
+  (define (define-tests)
+    (list
+     (mytest
+      (let ()
+        (match-define
+          (tlp394
+            ($
+             test-struct
+             (and (? number? tlp395) (? even? tlp396))
+             ()
+             tlp397
+             #(tlp398 ___))
+            _
+            #(tlp400 ...))
+          `(symbols ,inst-struct-name399 #t #(these #f 6)))
+        (list tlp394 tlp395 tlp397 tlp398 tlp400))
+      '(symbols 4 #\a (#f (+ 4 5) #f) (these #f 6)))
+     (mytest
+      (let ()
+        (match-define
+          (tlp401 tlp402 (tlp403 ..3) #(tlp404 ...))
+          `(#\a #t ((+ 4 5) #\d #t) #((+ 1 2) #t 6)))
+        (list tlp401 tlp402 tlp403 tlp404))
+      '(#\a #t ((+ 4 5) #\d #t) ((+ 1 2) #t 6)))))
+
+
+
+
+  (define (sing-match-tests)
+    (list
+     (let ((tlp435
+             (lambda (tlp405)
+               (match
+                tlp405
+                ((($ test-struct tlp406 '(+ 4 (+ 1 1)) (tlp407 __3) _)
+                  _
+                  ($
+                   test-struct
+                   (#(tlp409 tlp410 tlp411 tlp412)
+                    (and (? test-struct? tlp418)
+                         (= test-struct-a tlp413)
+                         (= test-struct-b tlp414)
+                         (= test-struct-c tlp415)
+                         (= test-struct-d tlp416))
+                    (tlp419 tlp420 tlp421 quote these)
+                    .
+                    #f)
+                   (tlp422 ...)
+                   ()
+                   (tlp423 ...))
+                  (and (? test-struct? tlp434)
+                       (= test-struct-a ())
+                       (= test-struct-b tlp425)
+                       (=
+                        test-struct-c
+                        (and (? test-struct? tlp432)
+                             (= test-struct-a 'these)
+                             (=
+                              test-struct-b
+                              (and (not (not 3)) (not (not 3))))
+                             (= test-struct-c #(tlp426 tlp427 tlp428 tlp429))
+                             (= test-struct-d (tlp430 ___))))
+                       (= test-struct-d 'are)))
+                 (list
+                  tlp406
+                  tlp407
+                  tlp409
+                  tlp410
+                  tlp411
+                  tlp412
+                  tlp413
+                  tlp414
+                  tlp415
+                  tlp416
+                  tlp419
+                  tlp420
+                  tlp421
+                  tlp422
+                  tlp423
+                  tlp425
+                  tlp426
+                  tlp427
+                  tlp428
+                  tlp429
+                  tlp430))))))
+       (list
+        (mytest
+         (tlp435
+           `(,inst-struct-name408
+             #\d
+             ,inst-struct-name424
+             ,inst-struct-name433))
+         '(these
+           ((+ 4 (+ 1 1)) (+ 4 5) are)
+           (+ 4 (+ 1 1))
+           #\b
+           7
+           #\a
+           6
+           #\b
+           (+ 4 (+ 1 1))
+           (+ 4 5)
+           (+ 4 5)
+           are
+           9
+           (#t #\a #f)
+           (are #\b 4)
+           1
+           (+ 4 (+ 1 1))
+           symbols
+           1
+           are
+           (8 #t (+ 4 (+ 1 1)))))))
+     (let ((tlp441
+             (lambda (tlp436)
+               (match
+                tlp436
+                (((tlp437 ..3) _ (and (tlp438 ..3) (tlp439 ..3)) tlp440)
+                 (list tlp437 tlp438 tlp440))))))
+       (list
+        (mytest
+         (tlp441 `((#f #t #f) #t (these #\c #\b) 1))
+         '((#f #t #f) (these #\c #\b) 1))))))
+  (define (mult-match-tests)
+    (list
+     (let ((tlp480
+             (lambda (tlp442)
+               (match
+                tlp442
+                (((and (tlp443 ___) (tlp444 ___))
+                  #&(#&(#f tlp445 tlp446)
+                     #((tlp447 __3) () 5 (or #(tlp448 ___) #(tlp448 ___)))
+                     #&((or (not (not '(+ 4 (+ 1 1))))
+                            (not (not '(+ 4 (+ 1 1)))))
+                        ()
+                        (tlp449 tlp450 tlp451 . #f)))
+                  #(#\d
+                    _
+                    #&(#(tlp452 ___)
+                       (and () ())
+                       (and #(tlp453 ___) #(tlp454 ___)))
+                    #((tlp455 ...)
+                      (and (? number? tlp456) (? even? tlp457))
+                      #(tlp458 tlp459 tlp460 tlp461)
+                      #\b))
+                  ())
+                 (list
+                  tlp443
+                  tlp445
+                  tlp446
+                  tlp447
+                  tlp448
+                  tlp449
+                  tlp450
+                  tlp451
+                  tlp452
+                  tlp453
+                  tlp455
+                  tlp456
+                  tlp458
+                  tlp459
+                  tlp460
+                  tlp461))
+                (((tlp462 ..3)
+                  tlp463
+                  ((#\d
+                    (tlp464 tlp465 tlp466 tlp467)
+                    (tlp468 tlp469 tlp470 quote these)
+                    .
+                    #\b)
+                   'symbols
+                   (and (? test-struct? tlp478)
+                        (= test-struct-a tlp471)
+                        (= test-struct-b ())
+                        (= test-struct-c tlp472)
+                        (= test-struct-d #(tlp473 tlp474 tlp475 tlp476)))
+                   .
+                   7)
+                  tlp479)
+                 (list
+                  tlp462
+                  tlp463
+                  tlp464
+                  tlp465
+                  tlp466
+                  tlp467
+                  tlp468
+                  tlp469
+                  tlp470
+                  tlp471
+                  tlp472
+                  tlp473
+                  tlp474
+                  tlp475
+                  tlp476
+                  tlp479))))))
+       (list
+        (mytest
+         (tlp480
+           `((#t #\d symbols)
+             #&(#&(#f 3 #\d)
+                #((are #\b #\c) () 5 #(#\b #f #f))
+                #&((+ 4 (+ 1 1)) () (symbols #\c #\a . #f)))
+             #(#\d
+               2
+               #&(#(#t 9 #f) () #((+ 4 5) #f 6))
+               #((#\c 8 symbols) 2 #(7 (+ 1 2) #f #\d) #\b))
+             ()))
+         '((#t #\d symbols)
+           3
+           #\d
+           (are #\b #\c)
+           (#\b #f #f)
+           symbols
+           #\c
+           #\a
+           (#t 9 #f)
+           ((+ 4 5) #f 6)
+           (#\c 8 symbols)
+           2
+           7
+           (+ 1 2)
+           #f
+           #\d))
+        (mytest
+         (tlp480
+           `((are 0 are)
+             #\b
+             ((#\d ((+ 1 2) #\c symbols #\b) (#\a (+ 4 5) 3 . these) . #\b)
+              symbols
+              ,inst-struct-name477
+              .
+              7)
+             #\d))
+         '((are 0 are)
+           #\b
+           (+ 1 2)
+           #\c
+           symbols
+           #\b
+           #\a
+           (+ 4 5)
+           3
+           #t
+           these
+           (+ 4 5)
+           #t
+           #t
+           #\c
+           #\d))))
+     (let ((tlp508
+             (lambda (tlp481)
+               (match
+                tlp481
+                (((tlp482 tlp483 () . #\a)
+                  ($
+                   test-struct
+                   ((tlp484 ___) tlp485 (not (not #t)) . 0)
+                   ()
+                   tlp486
+                   (not (not 7)))
+                  (and (? number? tlp488) (? even? tlp489))
+                  #\a)
+                 (list tlp482 tlp483 tlp484 tlp485 tlp486 tlp488))
+                (((tlp490 ..3)
+                  #&((and (? number? tlp491) (? even? tlp492))
+                     (and #(#(tlp493 ...)
+                            tlp494
+                            #(tlp495 ...)
+                            #&(tlp496 tlp497 tlp498))
+                          #(#(tlp499 ...)
+                            tlp500
+                            #(tlp501 ...)
+                            #&(tlp502 tlp503 tlp504)))
+                     (and (? number? tlp505) (? even? tlp506)))
+                  tlp507
+                  #\c)
+                 (list
+                  tlp490
+                  tlp491
+                  tlp493
+                  tlp494
+                  tlp495
+                  tlp496
+                  tlp497
+                  tlp498
+                  tlp505
+                  tlp507))))))
+       (list
+        (mytest
+         (tlp508 `((symbols 4 () . #\a) ,inst-struct-name487 18 #\a))
+         '(symbols 4 (7 these #\b) (+ 4 (+ 1 1)) (+ 4 5) 18))
+        (mytest
+         (tlp508
+           `((7 #t #f)
+             #&(14
+                #(#(#\c are 7)
+                  (+ 4 (+ 1 1))
+                  #(#f 9 symbols)
+                  #&(symbols #\a are))
+                18)
+             these
+             #\c))
+         '((7 #t #f)
+           14
+           (#\c are 7)
+           (+ 4 (+ 1 1))
+           (#f 9 symbols)
+           symbols
+           #\a
+           are
+           18
+           these))))))
+  (define (sing-match-lambda-tests)
+    (list
+     (let ((tlp550
+             (match-lambda
+               ((#&(#\d
+                    #&(tlp509 'are _)
+                    ($
+                     test-struct
+                     ($ test-struct tlp510 tlp511 tlp512 tlp513)
+                     (tlp515 tlp516 tlp517 . #\a)
+                     (tlp518 tlp519 tlp520 . #\b)
+                     tlp521))
+                 #(tlp523 ___)
+                 (and (? test-struct? tlp548)
+                      (= test-struct-a 'are)
+                      (=
+                       test-struct-b
+                       (tlp524
+                         (tlp525 ...)
+                         (and ($ test-struct tlp526 tlp527 tlp528 tlp529)
+                              ($ test-struct tlp531 tlp532 tlp533 tlp534))
+                         tlp535))
+                      (= test-struct-c (tlp536 ...))
+                      (=
+                       test-struct-d
+                       (and (? test-struct? tlp546)
+                            (=
+                             test-struct-a
+                             (and (? test-struct? tlp542)
+                                  (= test-struct-a tlp537)
+                                  (= test-struct-b tlp538)
+                                  (= test-struct-c tlp539)
+                                  (= test-struct-d tlp540)))
+                            (=
+                             test-struct-b
+                             (and (? number? tlp543) (? even? tlp544)))
+                            (= test-struct-c ())
+                            (= test-struct-d ()))))
+                 tlp549)
+                (list
+                 tlp509
+                 tlp510
+                 tlp511
+                 tlp512
+                 tlp513
+                 tlp515
+                 tlp516
+                 tlp517
+                 tlp518
+                 tlp519
+                 tlp520
+                 tlp521
+                 tlp523
+                 tlp524
+                 tlp525
+                 tlp526
+                 tlp527
+                 tlp528
+                 tlp529
+                 tlp535
+                 tlp536
+                 tlp537
+                 tlp538
+                 tlp539
+                 tlp540
+                 tlp543
+                 tlp549)))))
+       (list
+        (mytest
+         (tlp550
+           `(#&(#\d #&(#\a are are) ,inst-struct-name522)
+             #(#\c #\b #f)
+             ,inst-struct-name547
+             7))
+         '(#\a
+           (+ 4 5)
+           #\b
+           (+ 4 (+ 1 1))
+           #t
+           #\b
+           #t
+           #\d
+           7
+           5
+           #f
+           #\c
+           (#\c #\b #f)
+           9
+           (#f symbols #\d)
+           8
+           5
+           #\c
+           7
+           symbols
+           (4 #\b #t)
+           (+ 1 2)
+           4
+           symbols
+           (+ 1 2)
+           8
+           7))))
+     (let ((tlp555
+             (match-lambda
+               ((tlp551 ($ test-struct #(tlp552 ...) 'are _ tlp553) () ())
+                (list tlp551 tlp552 tlp553)))))
+       (list
+        (mytest
+         (tlp555 `(#\b ,inst-struct-name554 () ()))
+         '(#\b (#\d #f #\d) (+ 4 (+ 1 1))))))))
+  (define (mult-match-lambda-tests)
+    (list
+     (let ((tlp580
+             (match-lambda
+               (((not (not #f))
+                 #&(tlp556
+                     (and (tlp557 ___) (tlp558 ___))
+                     (and (? number? tlp559) (? even? tlp560)))
+                 tlp561
+                 ())
+                (list tlp556 tlp557 tlp559 tlp561))
+               ((_
+                 (tlp562 ..3)
+                 '(+ 4 (+ 1 1))
+                 #((#(tlp563 tlp564 tlp565 tlp566)
+                    tlp567
+                    #&(tlp568 tlp569 tlp570)
+                    tlp571)
+                   (and tlp572 tlp573)
+                   #&(#&(tlp574 tlp575 tlp576)
+                      (not (not #f))
+                      (tlp577 tlp578 tlp579 . #\b))
+                   #f))
+                (list
+                 tlp562
+                 tlp563
+                 tlp564
+                 tlp565
+                 tlp566
+                 tlp567
+                 tlp568
+                 tlp569
+                 tlp570
+                 tlp571
+                 tlp572
+                 tlp574
+                 tlp575
+                 tlp576
+                 tlp577
+                 tlp578
+                 tlp579)))))
+       (list
+        (mytest
+         (tlp580 `(#f #&(9 (#\c (+ 1 2) symbols) 16) #\c ()))
+         '(9 (#\c (+ 1 2) symbols) 16 #\c))
+        (mytest
+         (tlp580
+           `(#f
+             (#\a #t 5)
+             (+ 4 (+ 1 1))
+             #((#(9 #\c (+ 4 (+ 1 1)) symbols) 7 #&(#\a #t (+ 4 5)) #t)
+               #\b
+               #&(#&(5 #\d #t) #f ((+ 1 2) #t #\b . #\b))
+               #f)))
+         '((#\a #t 5)
+           9
+           #\c
+           (+ 4 (+ 1 1))
+           symbols
+           7
+           #\a
+           #t
+           (+ 4 5)
+           #t
+           #\b
+           5
+           #\d
+           #t
+           (+ 1 2)
+           #t
+           #\b))))
+     (let ((tlp604
+             (match-lambda
+               (((and (? number? tlp581) (? even? tlp582))
+                 tlp583
+                 #&('(+ 4 5)
+                    #&(tlp584
+                        (and (? number? tlp585) (? even? tlp586))
+                        (or (or tlp587 tlp587) (or tlp587 tlp587)))
+                    '(+ 4 5))
+                 #(tlp588 ...))
+                (list tlp581 tlp583 tlp584 tlp585 tlp587 tlp588))
+               (((and (? test-struct? tlp601)
+                      (= test-struct-a #f)
+                      (= test-struct-b (tlp589 ...))
+                      (=
+                       test-struct-c
+                       ((and (? number? tlp590) (? even? tlp591))
+                        #(tlp592 ...)
+                        (and (? test-struct? tlp598)
+                             (= test-struct-a tlp593)
+                             (= test-struct-b tlp594)
+                             (= test-struct-c tlp595)
+                             (= test-struct-d tlp596))
+                        (tlp599 __3)))
+                      (= test-struct-d '(+ 4 (+ 1 1))))
+                 #f
+                 #(tlp602 ___)
+                 (tlp603 ___))
+                (list
+                 tlp589
+                 tlp590
+                 tlp592
+                 tlp593
+                 tlp594
+                 tlp595
+                 tlp596
+                 tlp599
+                 tlp602
+                 tlp603)))))
+       (list
+        (mytest
+         (tlp604
+           `(18 #\a #&((+ 4 5) #&(these 0 #\d) (+ 4 5)) #(1 (+ 1 2) symbols)))
+         '(18 #\a these 0 #\d (1 (+ 1 2) symbols)))
+        (mytest
+         (tlp604 `(,inst-struct-name600 #f #(4 0 #\d) (are 7 #\c)))
+         '((these #\b 7)
+           18
+           (#f (+ 4 5) #t)
+           #\d
+           (+ 4 (+ 1 1))
+           2
+           #\a
+           (#t 8 these)
+           (4 0 #\d)
+           (are 7 #\c)))))))
+  (define (sing-match-lambda*-tests)
+    (list
+     (let ((tlp610
+             (match-lambda*
+               ((tlp606 tlp607 (tlp608 ___) tlp609)
+                (list tlp606 tlp607 tlp608 tlp609)))))
+       (list
+        (mytest
+         (tlp610 `#f `#\c `((+ 4 (+ 1 1)) 7 #t) `3)
+         '(#f #\c ((+ 4 (+ 1 1)) 7 #t) 3))))
+     (let ((tlp620
+             (match-lambda*
+               ((('(+ 4 5)
+                  #(tlp612 ___)
+                  (tlp613 __3)
+                  ($ test-struct #&(tlp614 tlp615 tlp616) tlp617 () ()))
+                 tlp619
+                 #&(7 '(+ 4 (+ 1 1)) ())
+                 _)
+                (list tlp612 tlp613 tlp614 tlp615 tlp616 tlp617 tlp619)))))
+       (list
+        (mytest
+         (tlp620
+           `((+ 4 5) #(1 9 (+ 1 2)) (3 these these) ,inst-struct-name618)
+           `#\c
+           `#&(7 (+ 4 (+ 1 1)) ())
+           `(+ 1 2))
+         '((1 9 (+ 1 2)) (3 these these) (+ 4 5) #\d #\c are #\c))))))
+  (define (mult-match-lambda*-tests)
+    (list
+     (let ((tlp645
+             (match-lambda*
+               ((#&((and (? number? tlp622) (? even? tlp623))
+                    ((tlp624 ___)
+                     (and (? number? tlp625) (? even? tlp626))
+                     #\c
+                     .
+                     #\a)
+                    tlp627)
+                 tlp628
+                 (tlp629 ___)
+                 #\c)
+                (list tlp622 tlp624 tlp625 tlp627 tlp628 tlp629))
+               ((tlp630
+                  (or #(_
+                        #(tlp631 ...)
+                        #((tlp632 tlp633 tlp634 . tlp635)
+                          (and tlp636 tlp637)
+                          #\b
+                          ($ test-struct tlp638 tlp639 tlp640 tlp641))
+                        ())
+                      #(_
+                        #(tlp631 ...)
+                        #((tlp632 tlp633 tlp634 . tlp635)
+                          (and tlp636 tlp637)
+                          #\b
+                          ($ test-struct tlp638 tlp639 tlp640 tlp641))
+                        ()))
+                  #f
+                  (and (? number? tlp643) (? even? tlp644)))
+                (list
+                 tlp630
+                 tlp631
+                 tlp632
+                 tlp633
+                 tlp634
+                 tlp635
+                 tlp636
+                 tlp638
+                 tlp639
+                 tlp640
+                 tlp641
+                 tlp643)))))
+       (list
+        (mytest
+         (tlp645 `#&(4 ((1 these 7) 2 #\c . #\a) #t) `#\a `(7 #f #t) `#\c)
+         '(4 (1 these 7) 2 #t #\a (7 #f #t)))
+        (mytest
+         (tlp645
+           `#\c
+           `#(are
+              #(#\a (+ 1 2) #\d)
+              #((#\c #\b #t . #\b) #f #\b ,inst-struct-name642)
+              ())
+           `#f
+           `14)
+         '(#\c
+           (#\a (+ 1 2) #\d)
+           #\c
+           #\b
+           #t
+           #\b
+           #f
+           #\d
+           (+ 4 5)
+           (+ 4 5)
+           (+ 1 2)
+           14))))
+     (let ((tlp672
+             (match-lambda*
+               ((#(#t
+                   ()
+                   (tlp647
+                     (or #&(tlp648 tlp649 tlp650) #&(tlp648 tlp649 tlp650))
+                     (tlp651 ...)
+                     tlp652)
+                   #f)
+                 'these
+                 tlp653
+                 tlp654)
+                (list tlp647 tlp648 tlp649 tlp650 tlp651 tlp652 tlp653 tlp654))
+               ((((tlp655 __3)
+                  (tlp656 ___)
+                  ($
+                   test-struct
+                   (and (? test-struct? tlp662)
+                        (= test-struct-a tlp657)
+                        (= test-struct-b tlp658)
+                        (= test-struct-c tlp659)
+                        (= test-struct-d tlp660))
+                   (tlp663 tlp664 tlp665 . #\a)
+                   (tlp666 tlp667 tlp668 . #\b)
+                   _)
+                  quote
+                  are)
+                 (not (not 'symbols))
+                 (and tlp670 tlp671)
+                 _)
+                (list
+                 tlp655
+                 tlp656
+                 tlp657
+                 tlp658
+                 tlp659
+                 tlp660
+                 tlp663
+                 tlp664
+                 tlp665
+                 tlp666
+                 tlp667
+                 tlp668
+                 tlp670)))))
+       (list
+        (mytest
+         (tlp672
+           `#(#t () (#\c #&(#\a #t symbols) (symbols 2 #\a) (+ 4 5)) #f)
+           `these
+           `#\d
+           `3)
+         '(#\c #\a #t symbols (symbols 2 #\a) (+ 4 5) #\d 3))
+        (mytest
+         (tlp672
+           `((#\d symbols #t) (symbols #t #\c) ,inst-struct-name669 . are)
+           `symbols
+           `#\c
+           `#f)
+         '((#\d symbols #t)
+           (symbols #t #\c)
+           #\a
+           #\c
+           #f
+           #\c
+           #\b
+           #\b
+           #f
+           #\d
+           #t
+           (+ 1 2)
+           #\c))))))
+  
+
+  (define (test-all)
+    (list
+     (let-tests)
+     (define-tests)
+     (sing-match-tests)
+     (mult-match-tests)
+     (sing-match-lambda-tests)
+     (mult-match-lambda-tests)
+     (sing-match-lambda*-tests)
+     (mult-match-lambda*-tests)))
+
+(test-all)
+
+
+(mytest (letrec ((z 
+                (lambda (x) 
+                  (match x
+                         ((a b c) 
+                          (if (= a 10)
+                              (list a b c)
+                              (begin (cons a (z (list (add1 a) 2 3)))))))))) 
+        (z '(1 2 3)))
+      '(1 2 3 4 5 6 7 8 9 10 2 3))
+
+; this is the same test for match-lambda
+
+(mytest (letrec ((z 
+                (match-lambda ((a b c) 
+                               (if (= a 10)
+                                   (list a b c)
+                                   (cons a (z (list (add1 a) 2 3)))))))) 
+        (z '(1 2 3)))
+      '(1 2 3 4 5 6 7 8 9 10 2 3))
+
+(mytest (letrec ((z 
+                (match-lambda* ((a b c) 
+                                (if (= a 10)
+                                    (list a b c)
+                                    (cons a (z (add1 a) 2 3))))))) 
+        (z 1 2 3))
+      '(1 2 3 4 5 6 7 8 9 10 2 3))
+; matchlet tests
+
+(mytest (match-let (((a b c) '(1 2 3))
+                  ((d e f) '(4 5 6)))
+                 (list a b c d e f))
+      '(1 2 3 4 5 6))
+
+
+; match: syntax error in (match (hey (((a b c) (d e f)) (list a b c d e f))))
+(mytest (match-let hey (((a b c) '(1 2 3))
+                      ((d e f) '(4 5 6)))
+                 (list a b c d e f))
+      '(1 2 3 4 5 6))
+
+(mytest (match-let hey (((a b c) '(1 2 3))
+                ((d e f) '(4 5 6)))
+           (if (= a 10)
+               '()
+               (cons a  (hey (list (add1 a) b c) '(d e f)))))
+      '(1 2 3 4 5 6 7 8 9))
+
+ (mytest (let ((f 7))
+         (match-let ([(a b c) (list 1 2 f)] [(d e) '(5 6)]) (list a d c f)))
+       '(1 5 7 7))
+
+; match-let*
+
+(mytest (match-let* (((a b c) '(1 2 3))
+                  ((d e f) '(4 5 6)))
+                 (list a b c d e f))
+      '(1 2 3 4 5 6))
+
+(mytest (match-let* ([(a b c) '(1 2 3)]
+                   [(d e f) (list a b c)])
+                  (list d e f)) ; should be (1 2 3)
+      '(1 2 3))
+
+
+(mytest (let ((f 7))
+        (match-let* ([(a b c) (list 1 2 f)] [(d e) '(5 6)]) (list a d c f)))
+      '(1 5 7 7))
+; match-letrec
+
+;; let rec does not work this well on chez or plt
+;(match-letrec ([(a b) (list (lambda (x) (if (zero? x) '() (cons x (a (sub1 x)))))
+;                            (lambda (x) (if (= x 10) '() (cons x (b (add1 x))))))]
+;               [(c d) (list (a 10) (b 0))])
+;              (list c d))
+
+(mytest (match-letrec (((a b c) '(1 2 3))
+                  ((d e f) '(4 5 6)))
+                 (list a b c d e f))
+      '(1 2 3 4 5 6))
+
+(mytest (match-letrec ([(a b) (list (lambda (x) (if (zero? x) '() (cons x (a (sub1 x)))))
+                            (lambda (x) (if (= x 10) '() (cons x (b (add1 x))))))])
+              (a 10)) 
+      '(10 9 8 7 6 5 4 3 2 1))
+
+(mytest (match-letrec ([(a b) (list (lambda (x) (if (zero? x) '() (cons (b x) (a (sub1 x)))))
+                            (lambda (x) (if (= x 10) '() (cons  x (b (add1 x))))))])
+              (a 10)) 
+      '(() (9) (8 9) (7 8 9) (6 7 8 9) (5 6 7 8 9) (4 5 6 7 8 9) 
+        (3 4 5 6 7 8 9) (2 3 4 5 6 7 8 9) (1 2 3 4 5 6 7 8 9)))
+                                                       
+
+(mytest (let ((f 7))
+        (match-letrec ([(a b c) (list 1 2 f)] [(d e) '(5 6)]) (list a d c f)))
+      '(1 5 7 7))
+
+
+; match-lambda
+
+
+(mytest (let ((f 7))
+        ((match-lambda ((a b) (list a b f))) '(4 5)))
+      '(4 5 7))
+
+(mytest (let ((f 7))
+        ((match-lambda* ((a b) (list a b f))) 4 5))
+      '(4 5 7))
+
+; match-define
+
+(mytest (let ((f 7))
+        (match-define (a b c) (list 1 2 f))
+        (list a b c f))
+      '(1 2 7 7))
+
+
+(let () (match-define (a b) (list (lambda (x) (if (zero? x) '() (cons (b x) (a (sub1 x)))))
+                                (lambda (x) (if (= x 10) '() (cons  x (b (add1 x)))))))
+        (mytest (a 10) 
+              '(() (9) (8 9) (7 8 9) (6 7 8 9) (5 6 7 8 9) (4 5 6 7 8 9) 
+                (3 4 5 6 7 8 9) (2 3 4 5 6 7 8 9) (1 2 3 4 5 6 7 8 9))))
+
+
+; this is some thing that I missed before
+
+(mytest (match '((1) (2) (3))
+       (((_) ...) 'hey))
+      'hey)
+
+; failure tests
+
+(mytest (match '(1 2 3)
+             ((a b c) (=> fail) (if (= a 1) (fail) 'bad))
+             ((a b c) (=> fail) (if (= a 1) (fail) 'bad))
+             ((a b c) (=> fail) (if (= a 1) (fail) 'bad))
+             ((a b c) (=> fail) (if (= a 1) (fail) 'bad))
+             ((a b c) (=> fail) (if (= a 1) (fail) 'bad))
+             ((a b c) (=> fail) (if (= a 1) (fail) 'bad))
+             ((a b c)  (list a b c)))
+      '(1 2 3))
+
+;(mytest (match '(1 2 3)
+;             ((a b c) (=> fail) (if (= a 1) (fail) 'bad)))
+;      '()) ; this should through a different exception
+      
+
+
+
+; set! tests
+
+; set! for lists
+(mytest (let ((x '(1 2 (3 4))))
+        (match x
+               ((_ _ ((set! set-it) _)) (set-it 17)))
+        x)
+      '(1 2 (17 4)))
+
+(mytest (let ((x '(1 2 (3 4))))
+        (match x
+               ((_ _ (_ (set! set-it))) (set-it 17)))
+        x)
+      '(1 2 (3 17)))
+
+(mytest (let ((x '(1 2 (3 4))))
+        (match x
+               (((set! set-it) _ (_ _)) (set-it 17)))
+        x)
+      '(17 2 (3 4)))
+
+(mytest (let ((x '(1 2 (3 4))))
+        (match x
+               ((_ (set! set-it) (_ _)) (set-it 17)))
+        x)
+      '(1 17 (3 4)))
+
+;set! for improper lists
+
+(mytest (let ((x '(1 2 (3 . 4) . 5)))
+        (match x
+               (((set! set-it) _ (_ . _) . _) (set-it 17)))
+        x)
+      '(17 2 (3 . 4) . 5))
+
+(mytest (let ((x '(1 2 (3 . 4) . 5)))
+        (match x
+               ((_ (set! set-it) (_ . _) . _) (set-it 17)))
+        x)
+      '(1 17 (3 . 4) . 5))
+
+(mytest (let ((x '(1 2 (3 . 4) . 5)))
+        (match x
+               ((_ _ ((set! set-it) . _) . _) (set-it 17)))
+        x)
+      '(1 2 (17 . 4) . 5))
+
+(mytest (let ((x '(1 2 (3 . 4) . 5)))
+        (match x
+               ((_ _ (_ . (set! set-it)) . _) (set-it 17)))
+        x)
+      '(1 2 (3 . 17) . 5))
+
+(mytest (let ((x '(1 2 (3 . 4) . 5)))
+        (match x
+               ((_ _ (_ . _) . (set! set-it)) (set-it 17)))
+        x)
+      '(1 2 (3 . 4) . 17))
+
+;; set! for vectors
+
+(mytest (let ((x #(1 2)))
+        (match x
+               (#(_ (set! set-it)) (set-it 17)))
+        x)
+      #(1 17))
+
+(mytest (let ((x #(1 2)))
+        (match x
+               (#((set! set-it) _) (set-it 17)))
+        x)
+      #(17 2))
+
+;; set! for boxes
+
+(mytest (let ((x #&1))
+        (match x
+               (#&(set! set-it) (set-it 17)))
+        x)
+      #&17)
+
+(mytest (let ((x #&(1 2)))
+        (match x
+               (#&(_ (set! set-it)) (set-it 17)))
+        x)
+      #&(1 17))
+
+(mytest (let ((x #&#(1 2)))
+        (match x
+               (#&#(_ (set! set-it)) (set-it 17)))
+        x)
+      #&#(1 17))
+
+
+; get! tests
+
+; get! for lists
+
+(mytest (let* ((x '(1 2 (3 4)))
+             (f
+        (match x
+               ((_ _ ((get! get-it) _)) get-it))))
+        (match x
+               ((_ _ ((set! set-it) _)) (set-it 17)))
+        (f)) 17)
+
+(mytest (let* ((x '(1 2 (3 4)))
+             (f
+        (match x
+               ((_ _ (_ (get! get-it))) get-it))))
+        (match x
+               ((_ _ (_ (set! set-it))) (set-it 17))) 
+        (f)) 17)
+
+(mytest (let* ((x '(1 2 (3 4)))
+             (f
+        (match x
+               (((get! get-it) _ (_ _)) get-it))))
+        (match x
+               (((set! set-it) _ (_ _)) (set-it 17)))
+        (f)) 17)
+
+
+(mytest (let* ((x '(1 2 (3 4)))
+             (f
+        (match x
+               ((_ (get! get-it) (_ _)) get-it))))
+        (match x
+               ((_ (set! set-it) (_ _)) (set-it 17)))
+        (f)) 17)
+
+
+;get! for improper lists
+
+(mytest (let* ((x '(1 2 (3 . 4) . 5))
+             (f
+        (match x
+               (((get! get-it) _ (_ . _) . _) get-it))))
+        (match x
+               (((set! set-it) _ (_ . _) . _) (set-it 17)))
+        (f)) 17)
+
+
+(mytest (let* ((x '(1 2 (3 . 4) . 5))
+             (f
+        (match x
+               ((_ (get! get-it) (_ . _) . _) get-it))))
+        (match x
+               ((_ (set! set-it) (_ . _) . _) (set-it 17)))
+        (f)) 17)
+
+
+(mytest (let* ((x '(1 2 (3 . 4) . 5))
+             (f
+        (match x
+               ((_ _ ((get! get-it) . _) . _) get-it))))
+        (match x
+               ((_ _ ((set! set-it) . _) . _) (set-it 17)))
+        (f)) 17)
+
+
+(mytest (let* ((x '(1 2 (3 . 4) . 5))
+             (f
+        (match x
+               ((_ _ (_ . (get! get-it)) . _) get-it))))
+        (match x
+               ((_ _ (_ . (set! set-it)) . _) (set-it 17)))
+        (f)) 17)
+
+
+(mytest (let* ((x '(1 2 (3 . 4) . 5))
+             (f
+        (match x
+               ((_ _ (_ . _) . (get! get-it)) get-it))))
+        (match x
+               ((_ _ (_ . _) . (set! set-it)) (set-it 17)))
+        (f)) 17)
+
+
+;; get! for vectors
+
+(mytest (let* ((x #(1 2))
+             (f
+        (match x
+               (#(_ (get! get-it)) get-it))))
+        (match x
+               (#(_ (set! set-it)) (set-it 17)))
+        (f)) 17)
+
+
+(mytest (let* ((x #(1 2))
+             (f
+        (match x
+               (#((get! get-it) _) get-it))))
+        (match x
+               (#((set! set-it) _) (set-it 17)))
+        (f)) 17)
+
+
+;; get! for boxes
+
+(mytest (let* ((x #&1)
+             (f
+        (match x
+               (#&(get! get-it) get-it))))
+        (match x
+               (#&(set! set-it) (set-it 17)))
+        (f)) 17)
+
+
+(mytest (let* ((x #&(1 2))
+             (f
+        (match x
+               (#&(_ (get! get-it)) get-it))))
+        (match x
+               (#&(_ (set! set-it)) (set-it 17)))
+        (f)) 17)
+
+
+(mytest (let* ((x #&#(1 2))
+             (f
+        (match x
+               (#&#(_ (get! get-it)) get-it))))
+        (match x
+               (#&#(_ (set! set-it)) (set-it 17)))
+        (f)) 17)
+
+
+
+;; quasi quote tests
+
+
+(mytest (match '(1 2 3 4 . b)
+             (`(,b 2 ,@(3 4) . b) b))
+      1)
+
+(mytest (match '(1 2 3 4 . 5)
+             (`(1 2 ,@(3 4) . ,b) b))
+      5)
+  
+(mytest (match '(a ()) (`(a ()) #t))
+        #t)
+
+(mytest (match '(1 2 3)
+             (`(,a ,b ,c) (list a b c)))
+      '(1 2 3))
+
+(mytest (match '(c a b 1 2 3 r f i) 
+             (`(c a b ,@(a b c) r f i) (list a b c)))
+      '(1 2 3))
+
+(mytest (match '(3 4 #\c a b 1 (2 (c d)))
+             (`(3 4 #\c a b ,a ,(b `(c e))) 'not-good)
+             (`(3 4 #\c a b ,a ,(b `(c d))) (list a b)))
+      '(1 2))
+
+(mytest (match #(x 2 x)
+       (`#(x ,x x) (list x)))
+      '(2))
+
+(mytest (match #(x 2 x)        ;remember that the x's are symbols here
+       (`#(x ,x x) (list x)))
+      '(2))
+
+(mytest (match #(c a b 1 2 3 r f i) 
+             (`#(c a b ,@(a b c) r f i) (list a b c)))
+      '(1 2 3))
+
+(mytest (match #&(c a b 1 2 3 r f i) 
+             (`#&(c a b ,@(a b c) r f i) (list a b c)))
+      '(1 2 3))
+
+(mytest (match (list 
+        "hi" 
+        1 
+        'there 
+        #\c 
+        #t 
+        #f 
+         '(a b c) 
+         '(a b . c) 
+         '(a b c c c c) 
+         #(a b c) 
+         #(a b c c c c) 
+         #&(a b c) 
+         '(1 2 3) 
+         '(4 5 . 6) 
+         '(7 8 9) 
+         #(10 11 12)
+         #&(13 14 15 16) 
+         1 
+         2 
+        3 
+         4 
+         17
+        )
+ (`(
+    "hi" 
+    1 
+    there 
+    #\c 
+    #t 
+    #f 
+   (a b c) 
+    (a b . c) 
+     (a b c ..2) 
+     #(a b c) 
+     #(a b c ..2) 
+     #&(a b c) 
+     ,(a b c) 
+     ,(c1 d . e) 
+     ,(f g h ...) 
+     ,#(i j k)
+     ,#&(l m n o) 
+     ,@(1 2 3 4 p)
+    )
+  (list 
+    a b c 
+    c1 d e 
+    f g h 
+    i j k 
+    l m n o 
+    p
+   )))
+'(1 2 3 4 5 6 7 8 (9) 10 11 12 13 14 15 16 17))
+
+(mytest (match (vector 
+              "hi" 
+              1 
+              'there 
+              #\c 
+              #t 
+              #f 
+              '(a b c) 
+              '(a b . c) 
+              '(a b c c c c) 
+              #(a b c) 
+              #(a b c c c c) 
+              #&(a b c) 
+              '(1 2 3) 
+              '(4 5 . 6) 
+              '(7 8 9) 
+              #(10 11 12)
+              #&(13 14 15 16) 
+              1 
+              2 
+              3 
+              4 
+              17
+              )
+             (`#(
+                 "hi" 
+                 1 
+                 there 
+                 #\c 
+                 #t 
+                 #f 
+                 (a b c) 
+                 (a b . c) 
+                 (a b c ..2) 
+                 #(a b c) 
+                 #(a b c ..2) 
+                 #&(a b c) 
+                 ,(a b c) 
+                 ,(c1 d . e) 
+                 ,(f g h ...) 
+                 ,#(i j k)
+                 ,#&(l m n o) 
+                 ,@(1 2 3 4 p)
+                 )
+              (list 
+               a b c 
+               c1 d e 
+               f g h 
+               i j k 
+               l m n o 
+               p
+               )))
+'(1 2 3 4 5 6 7 8 (9) 10 11 12 13 14 15 16 17))
+
+(mytest (match (box (list 
+              "hi" 
+              1 
+              'there 
+              #\c 
+              #t 
+              #f 
+              '(a b c) 
+              '(a b . c) 
+              '(a b c c c c) 
+              #(a b c) 
+              #(a b c c c c) 
+              #&(a b c) 
+              '(1 2 3) 
+              '(4 5 . 6) 
+              '(7 8 9) 
+              #(10 11 12)
+              #&(13 14 15 16) 
+              1 
+              2 
+              3 
+              4 
+              17
+              ))
+             (`#&(
+                 "hi" 
+                 1 
+                 there 
+                 #\c 
+                 #t 
+                 #f 
+                 (a b c) 
+                 (a b . c) 
+                 (a b c ..2) 
+                 #(a b c) 
+                 #(a b c ..2) 
+                 #&(a b c) 
+                 ,(a b c) 
+                 ,(c1 d . e) 
+                 ,(f g h ...) 
+                 ,#(i j k)
+                 ,#&(l m n o) 
+                 ,@(1 2 3 4 p)
+                 )
+              (list 
+               a b c 
+               c1 d e 
+               f g h 
+               i j k 
+               l m n o 
+               p
+               )))
+'(1 2 3 4 5 6 7 8 (9) 10 11 12 13 14 15 16 17))
+
+(mytest (match '(1 2 3 4)
+            (`(,@`(,x ,y) ,@`(,a ,b)) (list x y a b)))
+      '(1 2 3 4))
+
+
+;; deep nesting 
+
+(mytest (match #(#(#(1 2 3) #(1 2 3) #(2 3 4)) #(#(1 2 3) #(1 2 3) #(2 3 4)))
+             (#(#(#(a ...) ...) ...) a))
+      '(((1 2 3) (1 2 3) (2 3 4)) ((1 2 3) (1 2 3) (2 3 4))))
+
+(mytest (match '(((1 2 3) (1 2 3) (2 3 4)) ((1 2 3) (1 2 3) (2 3 4)))
+             ((((a ...) ...) ...) a))
+      '(((1 2 3) (1 2 3) (2 3 4)) ((1 2 3) (1 2 3) (2 3 4))))
+
+(mytest (match '((((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))
+                ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))))
+               (((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))
+                ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))))
+             (((((((a ...) ...) ...) ...) ...) ...) a))
+      '((((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))
+                ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))))
+               (((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))
+                ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))))))
+
+
+
+(mytest (match #(#(#(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))))
+                 #(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8)))))
+               #(#(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))))
+                 #(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))))))
+             (#(#(#(#(#(#(a ...) ...) ...) ...) ...) ...) a))
+      '((((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))
+                ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))))
+               (((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))
+                ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))))))
+
+(mytest (match '(#((#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8))))
+                 (#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8)))))
+               #((#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8))))
+                 (#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8))))))
+             ((#((#((#(a ...) ...) ...) ...) ...) ...) a))
+      '((((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))
+                ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))))
+               (((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))
+                ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))))))
+
+(mytest (match '((((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))
+                ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))))
+               (((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))
+                ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))))
+             (((((((a ..2) ..2) ..2) ..2) ..2) ..2) a))
+      '((((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))
+                ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))))
+               (((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))
+                ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))))))
+
+
+
+(mytest (match #(#(#(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))))
+                 #(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8)))))
+               #(#(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))))
+                 #(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))))))
+             (#(#(#(#(#(#(a ..2) ..2) ..2) ..2) ..2) ..2) a))
+      '((((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))
+                ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))))
+               (((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))
+                ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))))))
+
+(mytest (match '(#((#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8))))
+                 (#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8)))))
+               #((#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8))))
+                 (#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8))))))
+             ((#((#((#(a ..2) ..2) ..2) ..2) ..2) ..2) a))
+      '((((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))
+                ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))))
+               (((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))
+                ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))))))
+
+
+(mytest (match '((((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))
+                ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))))
+               (((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))
+                ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))))
+             (((((((_ ...) ...) ...) ...) ...) ...) #t)
+             (_ #f))
+      #t)
+
+(mytest (match #(#(#(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))))
+                 #(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8)))))
+               #(#(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))))
+                 #(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))))))
+             (#(#(#(#(#(#(_ ...) ...) ...) ...) ...) ...) #t)
+             (_ #f))
+      #t)
+
+(mytest (match '(#((#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8))))
+                 (#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8)))))
+               #((#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8))))
+                 (#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8))))))
+             ((#((#((#(_ ...) ...) ...) ...) ...) ...) #t)
+             (_ #f))
+      #t)
+
+(mytest (match '((((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))
+                ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))))
+               (((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))
+                ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))))
+             (((((((a b) ...) ...) ...) ...) ...) (list a b)))
+       '((((((1 3) (5 7)) ((1 3) (5 7))) (((1 3) (5 7)) ((1 3) (5 7)))) ((((1 3) (5 7)) ((1 3) (5 7))) (((1 3) (5 7)) ((1 3) (5 7)))))
+ (((((2 4) (6 8)) ((2 4) (6 8))) (((2 4) (6 8)) ((2 4) (6 8)))) ((((2 4) (6 8)) ((2 4) (6 8))) (((2 4) (6 8)) ((2 4) (6 8))))))) 
+
+
+(mytest (match #(#(#(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))))
+                 #(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8)))))
+               #(#(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))))
+                 #(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))))))
+             (#(#(#(#(#(#(a b) ...) ...) ...) ...) ...) (list a b)))
+      '((((((1 3) (5 7)) ((1 3) (5 7))) (((1 3) (5 7)) ((1 3) (5 7)))) ((((1 3) (5 7)) ((1 3) (5 7))) (((1 3) (5 7)) ((1 3) (5 7)))))
+ (((((2 4) (6 8)) ((2 4) (6 8))) (((2 4) (6 8)) ((2 4) (6 8)))) ((((2 4) (6 8)) ((2 4) (6 8))) (((2 4) (6 8)) ((2 4) (6 8)))))))
+
+(mytest (match '(#((#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8))))
+                 (#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8)))))
+               #((#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8))))
+                 (#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8))))))
+             ((#((#((#(a b) ...) ...) ...) ...) ...) (list a b)))
+      '((((((1 3) (5 7)) ((1 3) (5 7))) (((1 3) (5 7)) ((1 3) (5 7)))) ((((1 3) (5 7)) ((1 3) (5 7))) (((1 3) (5 7)) ((1 3) (5 7)))))
+ (((((2 4) (6 8)) ((2 4) (6 8))) (((2 4) (6 8)) ((2 4) (6 8)))) ((((2 4) (6 8)) ((2 4) (6 8))) (((2 4) (6 8)) ((2 4) (6 8)))))))
+
+
+;the new var pattern
+; this allows one to use 
+; var, $, =, and, or, not, ?, set!, or get!
+; as pattern variables
+; (mytest (match '(1 2 3)
+;             (((var $) b c) (list $ b c)))
+;       '(1 2 3))
+
+; (mytest (match '(1 2 3)
+;             (((var var) b c) (list var b c)))
+;       '(1 2 3))
+
+; (mytest (match '(1 2 3)
+;             (((var =) b c) (list = b c)))
+;       '(1 2 3))
+
+; (mytest (match '(1 2 3)
+;             (((var and) b c) (list and b c)))
+;       '(1 2 3))
+
+; (mytest (match '(1 2 3)
+;             (((var or) b c) (list or b c)))
+;       '(1 2 3))
+
+; (mytest (match '(1 2 3)
+;             (((var not) b c) (list not b c)))
+;       '(1 2 3))
+
+; (mytest (match '(1 2 3)
+;             (((var ?) b c) (list ? b c)))
+;       '(1 2 3))
+
+; (mytest (match '(1 2 3)
+;             (((var set!) b c) (list set! b c)))
+;       '(1 2 3))
+
+; (mytest (match '(1 2 3)
+;             (((var get!) b c) (list get! b c)))
+;       '(1 2 3))
+
+
+(mytest (match '((1 1 2 2) (1 1 2 2) 5 5 5)
+             (((1 ... a ...) ... 7 ...) #f)
+             (((1 ... a ...) ... 6 ...) #f)
+             (((1 ... a ...) ... 5 ...) a))
+      '((2 2) (2 2)))
+
+(mytest (match '(1 1 1 1 1 2 2 2 2)
+             ((1 ... 2 2 2 2) #t))
+      #t)
+(mytest (match '(1 1 1 1 1 2 2 2 2)
+             ((1 ... 2 ...) #t))
+      #t)
+
+(mytest (match '(1 1 1 1 1 2 2 2 2)
+             (((and (not 2) a) ... 2 ...) a))
+      '(1 1 1 1 1))
+
+(mytest (match '(1 1 1 1 1 2 2 2 2)
+             ((a ... 2 ...) a))
+      '(1 1 1 1 1 2 2 2 2))
+
+(mytest (match '(1 1 1 1 1 2 2 2 2)
+             ((_ ... 2 ...) #t))
+      #t)
+
+(mytest (match '(pattern matching in scheme is very cool)
+             (((and (not 'in) a) ... (and (not 'is) b) ... c ...) (list a c b)))
+      '((pattern matching) (is very cool) (in scheme)))
+
+(mytest (match '((1 1 2 2) (1 1 2 2) 5 5 5)
+       (((1 ... 2 ...) ... 5 ...) #t))
+      #t)
+
+(mytest (match #(1 3 1 9 8 4 2 2 4 7 a b c) (#((and (? odd?) a) ... 8 (and (? even?) b) ... 7 r ...) (list a b r)))
+      '((1 3 1 9) (4 2 2 4) (a b c)))
+
+(mytest (match #(#(1 1 2 2) #(1 1 2 2) 5 5 5)
+             (#(#(1 ... 2 ...) ... 5 ...) #t))
+      #t)
+
+
+(mytest (match #(#(1 1 2 2) #(1 1 2 2) 5 5 5)
+             (#(#(1 ... a ...) ... 7 ...) #f)
+             (#(#(1 ... a ...) ... 6 ...) #f)
+             (#(#(1 ... a ...) ... 5 ...) a))
+      '((2 2) (2 2)))
+
+(mytest (match #(#(1 2) #(1 2) #(1 2) 5 6) (#(#(_ _) ..3 a ...) a))
+      '(5 6))
+; should not work
+; (match x ((... ...) #t))
+
+
+; should not work
+; (match x ((pat ... ... pat) #t))
+
+(mytest (match #(1 2 3 4 5) (#(a b (and c (not 5)) ... d) (list a b c d)))
+      '(1 2 (3 4) 5))
+
+
+;; list-no-order
+
+;(mytest (match '(1 2 3 4) ((list-no-order a b 1 c) (list a b c)))
+;      '(2 3 4))
+
+
+
+  (define inst-struct-name3134 (make-test-struct `6 `#t `(+ 4 (+ 1 1)) `#\a))
+  (define inst-struct-name3144 (make-test-struct `#\a `3 `(+ 4 5) `7))
+  (define inst-struct-name3157
+    (make-test-struct
+      `#&((#f (+ 1 2) #\d #\b) (#\d 1 symbols) ,inst-struct-name3134)
+      `((5 7 symbols #t)
+        ,inst-struct-name3144
+        #((+ 4 (+ 1 1)) #f #\a #\d)
+        .
+        #\d)
+      `(#\a (+ 4 (+ 1 1)) these)
+      `(#\b 3 4 #&((+ 4 (+ 1 1)) #f 2))))
+  (define inst-struct-name3197
+    (make-test-struct `(8 #\b (+ 1 2)) `(+ 1 2) `#\a `((+ 1 2) #f 5)))
+  (define inst-struct-name3200
+    (make-test-struct
+      `#(#\b symbols (+ 1 2))
+      `symbols
+      `,inst-struct-name3197
+      `5))
+  (define inst-struct-name3228 (make-test-struct `these `3 `#\d `#t))
+  (define inst-struct-name3234 (make-test-struct `(+ 4 5) `#\a `#\a `#f))
+  (define inst-struct-name3239
+    (make-test-struct `() `#(#\d #\b #\b) `#\c `#\b))
+  (define inst-struct-name3252
+    (make-test-struct
+      `(#t #\c #\c . are)
+      `#((+ 1 2) (+ 4 5) #\b 9)
+      `16
+      `(+ 4 5)))
+  (define inst-struct-name3287
+    (make-test-struct `#\d `#((+ 4 5) #t (+ 4 5) #t) `#t `(+ 4 (+ 1 1))))
+  (define inst-struct-name3297
+    (make-test-struct `these `#f `#(are symbols #\c) `#(these symbols #t #\d)))
+  (define inst-struct-name3307 (make-test-struct `#t `(+ 4 (+ 1 1)) `#\d `#f))
+  (define inst-struct-name3312
+    (make-test-struct
+      `#&(symbols #\d #\c)
+      `,inst-struct-name3307
+      `(these are (+ 1 2) (+ 4 5))
+      `#f))
+  (define inst-struct-name3322
+    (make-test-struct
+      `(#t 6 #\c)
+      `(#t #\d 2 . #\a)
+      `#(#f 6 #\b)
+      `#&(#f 7 symbols)))
+  (define inst-struct-name3355 (make-test-struct `(+ 1 2) `these `#t `#t))
+  (define inst-struct-name3367 (make-test-struct `#\d `#\a `6 `(+ 1 2)))
+  (define inst-struct-name3372 (make-test-struct `symbols `#\a `3 `#\c))
+  (define inst-struct-name3396 (make-test-struct `0 `#\d `#\a `#\b))
+  (define inst-struct-name3419 (make-test-struct `#\c `#\c `symbols `9))
+  (define inst-struct-name3444
+    (make-test-struct
+      `(#\c (+ 4 (+ 1 1)) (+ 4 5))
+      `()
+      `((6 #\a 2) 0 #(these #\c these 1) . 5)
+      `#(#f #\a #\d)))
+  (define inst-struct-name3455
+    (make-test-struct
+      `()
+      `(#\d #t symbols . #\d)
+      `#&(#\d (+ 4 (+ 1 1)) these)
+      `2))
+  (define inst-struct-name3474
+    (make-test-struct `(#t #\c #f . #\d) `#\a `() `(#t #\a #\a)))
+  (define inst-struct-name3482 (make-test-struct `symbols `#\b `#f `#f))
+  (define inst-struct-name3493
+    (make-test-struct
+      `16
+      `(,inst-struct-name3482 #(#f #\c (+ 4 5) #f) #&((+ 4 5) #\d are) (+ 4 5))
+      `#(#t #f 4)
+      `#\d))
+  (define inst-struct-name3505 (make-test-struct `4 `(+ 4 (+ 1 1)) `#f `these))
+  (define inst-struct-name3512
+    (make-test-struct
+      `#&(symbols #f 2)
+      `()
+      `#t
+      `(are (+ 4 (+ 1 1)) (+ 4 (+ 1 1)))))
+  (define inst-struct-name3518 (make-test-struct `8 `#\b `#\c `symbols))
+  (define inst-struct-name3527 (make-test-struct `#\a `#t `4 `#t))
+  (define inst-struct-name3550
+    (make-test-struct `(+ 4 (+ 1 1)) `(#t 8 symbols) `(#\a #\c #t) `0))
+  (define inst-struct-name3570 (make-test-struct `#\b `#\c `#\d `#\c))
+  (define inst-struct-name3577 (make-test-struct `#\b `(+ 1 2) `#\b `#\b))
+  (define inst-struct-name3578
+    (make-test-struct `,inst-struct-name3570 `16 `,inst-struct-name3577 `9))
+  (define inst-struct-name3595
+    (make-test-struct
+      `(0 these are)
+      `(#\d #f (+ 4 (+ 1 1)) . #\c)
+      `#(#\b #\a these symbols)
+      `#\b))
+  (define inst-struct-name3600 (make-test-struct `#\a `0 `2 `2))
+  (define inst-struct-name3605 (make-test-struct `are `1 `3 `#\d))
+  (define inst-struct-name3625
+    (make-test-struct
+      `()
+      `#\a
+      `#(#\a #\c (+ 1 2) #t)
+      `#((+ 4 (+ 1 1)) #\b 5 these)))
+  (define inst-struct-name3633 (make-test-struct `(+ 4 (+ 1 1)) `are `#f `#\c))
+  (define inst-struct-name3639
+    (make-test-struct `#\a `,inst-struct-name3633 `#&(are symbols 4) `#\c))
+  (define inst-struct-name3677
+    (make-test-struct `#(#\b are #\b) `#\a `#\c `(#\b #\c #\d . #\d)))
+  (define inst-struct-name3701
+    (make-test-struct `#\b `9 `#&(#\c (#f #\d (+ 1 2)) are) `#\d))
+  (define inst-struct-name3712
+    (make-test-struct `#\d `#\d `(+ 4 (+ 1 1)) `are))
+  (define inst-struct-name3744
+    (make-test-struct `symbols `(+ 1 2) `symbols `#\b))
+  (define inst-struct-name3752 (make-test-struct `#\b `#t `(+ 4 5) `#\b))
+  (define inst-struct-name3753
+    (make-test-struct
+      `,inst-struct-name3744
+      `#(#\c #\d #\d)
+      `#\b
+      `,inst-struct-name3752))
+  (define inst-struct-name3755
+    (make-test-struct `(these 0 3) `(+ 4 5) `2 `,inst-struct-name3753))
+  (define inst-struct-name3762 (make-test-struct `these `(+ 1 2) `2 `#\d))
+  (define inst-struct-name3776 (make-test-struct `#\b `#\b `symbols `these))
+  (define inst-struct-name3777
+    (make-test-struct
+      `#&(symbols (+ 4 (+ 1 1)) (+ 1 2))
+      `#(#\c 6 #\c #t)
+      `#\b
+      `,inst-struct-name3776))
+  (define inst-struct-name3805
+    (make-test-struct `#\d `#&((+ 1 2) #\d 1) `(+ 4 5) `#\b))
+  (define inst-struct-name3817 (make-test-struct `1 `(+ 1 2) `#\d `(+ 1 2)))
+  (define inst-struct-name3820
+    (make-test-struct
+      `#\d
+      `(2 (+ 4 (+ 1 1)) symbols)
+      `,inst-struct-name3817
+      `#((+ 1 2) 8 (+ 4 5))))
+  (define inst-struct-name3822
+    (make-test-struct
+      `,inst-struct-name3805
+      `#&(#&(#f (+ 4 (+ 1 1)) #\d) #\c (#t #\c #f))
+      `(+ 4 5)
+      `,inst-struct-name3820))
+  (define inst-struct-name3851 (make-test-struct `#f `(+ 1 2) `#\a `#f))
+  (define inst-struct-name3854
+    (make-test-struct `#\b `#\b `,inst-struct-name3851 `18))
+  (define inst-struct-name3856
+    (make-test-struct
+      `#&(#t #\a symbols)
+      `(((+ 4 (+ 1 1)) (+ 4 5) #\b) #t 12 #(these #\c #f))
+      `(#(#\d these #\d) #t 7 #f)
+      `,inst-struct-name3854))
+  (define inst-struct-name3890
+    (make-test-struct `#f `(#t #f are symbols) `#\d `#t))
+  (define inst-struct-name3900 (make-test-struct `(+ 4 (+ 1 1)) `0 `#\d `0))
+  (define inst-struct-name3902
+    (make-test-struct
+      `,inst-struct-name3890
+      `(+ 4 5)
+      `()
+      `#((#\a 7 #\b (+ 1 2)) ,inst-struct-name3900 #\b ())))
+  (define inst-struct-name3928
+    (make-test-struct `8 `#\c `#\c `#(8 #\d #f #\a)))
+  (define inst-struct-name3939 (make-test-struct `6 `#\d `(+ 4 (+ 1 1)) `7))
+  (define inst-struct-name3944
+    (make-test-struct
+      `#\d
+      `,inst-struct-name3928
+      `(,inst-struct-name3939 () #&(#\b #f #\b) #t)
+      `(4 (+ 1 2) 3)))
+  (define inst-struct-name3952
+    (make-test-struct `() `7 `(+ 1 2) `(#\d #\d #\c)))
+  (define inst-struct-name3957
+    (make-test-struct `#t `(#\a #\b symbols) `#\d `10))
+  (define inst-struct-name3962 (make-test-struct `4 `(+ 4 (+ 1 1)) `#\c `6))
+  (define inst-struct-name3973 (make-test-struct `#t `1 `2 `#t))
+  (define inst-struct-name3974
+    (make-test-struct `(+ 4 (+ 1 1)) `9 `#f `,inst-struct-name3973))
+  (define inst-struct-name3986 (make-test-struct `these `#\d `#f `#t))
+  (define inst-struct-name3998 (make-test-struct `(+ 4 5) `#f `0 `#\a))
+  (define inst-struct-name4008 (make-test-struct `#\c `#t `#\c `#t))
+  (define inst-struct-name4019
+    (make-test-struct
+      `((+ 4 5) #\b these . 1)
+      `,inst-struct-name4008
+      `(2 #f #t #\d)
+      `#(9 #\b 2)))
+  (define inst-struct-name4024
+    (make-test-struct `#\a `(+ 4 (+ 1 1)) `(+ 4 (+ 1 1)) `#t))
+  (define inst-struct-name4026
+    (make-test-struct `(+ 1 2) `,inst-struct-name4024 `() `#\d))
+  (define inst-struct-name4028
+    (make-test-struct
+      `(#\a 8 #f)
+      `,inst-struct-name4019
+      `()
+      `,inst-struct-name4026))
+  (define inst-struct-name4042
+    (make-test-struct
+      `#\b
+      `(5 (+ 4 5) (+ 4 (+ 1 1)) #\d)
+      `(are #\b these . 2)
+      `#\b))
+  (define inst-struct-name4060 (make-test-struct `0 `symbols `#f `#\a))
+  (define inst-struct-name4063
+    (make-test-struct `8 `#&(5 #\c #f) `,inst-struct-name4060 `10))
+  (define inst-struct-name4064
+    (make-test-struct `4 `#f `0 `,inst-struct-name4063))
+  (define inst-struct-name4088
+    (make-test-struct
+      `#\a
+      `(#\d symbols these)
+      `(#\a are 2 #(#\b 0 symbols #\d))
+      `#f))
+  (define inst-struct-name4109 (make-test-struct `4 `symbols `(+ 4 5) `#\b))
+  (define inst-struct-name4137
+    (make-test-struct `(+ 4 5) `(+ 4 5) `are `these))
+  (define inst-struct-name4145
+    (make-test-struct
+      `,inst-struct-name4137
+      `#\d
+      `#(2 #\c (+ 1 2) #\c)
+      `(#\c 6 9 . 7)))
+  (define inst-struct-name4146
+    (make-test-struct `these `(+ 4 (+ 1 1)) `(+ 1 2) `,inst-struct-name4145))
+  (define inst-struct-name4160 (make-test-struct `4 `#\d `2 `#\a))
+  (define inst-struct-name4174
+    (make-test-struct
+      `these
+      `#((#t (+ 1 2) #\c are) #(#\d (+ 4 5) #\a #\d) ,inst-struct-name4160 #t)
+      `(#\b #\b 9)
+      `#(#\c #(#\c #\c #\c #f) these ())))
+  (define inst-struct-name4181 (make-test-struct `#\c `#(#f #\c #t) `#f `#t))
+  (define inst-struct-name4194 (make-test-struct `#\a `#t `6 `symbols))
+  (define inst-struct-name4208
+    (make-test-struct
+      `(#f 7 #t)
+      `,inst-struct-name4181
+      `#&(#(#f symbols (+ 1 2) #\a)
+          ((+ 1 2) symbols #\b #\c)
+          ,inst-struct-name4194)
+      `#t))
+  (define inst-struct-name4214
+    (make-test-struct `(+ 4 5) `symbols `#\d `these))
+  (define inst-struct-name4239
+    (make-test-struct `(#\c 6 (+ 4 5) . #f) `() `14 `(#\a (+ 4 5) #\a . #\c)))
+  (define inst-struct-name4241
+    (make-test-struct
+      `()
+      `#(these (#\b #\a these #t) (#\a #\c are) (these 4 #\d))
+      `,inst-struct-name4239
+      `()))
+  (define inst-struct-name4252 (make-test-struct `#t `5 `symbols `(+ 1 2)))
+  (define inst-struct-name4260
+    (make-test-struct `() `symbols `#t `(#\d (+ 4 5) #\b 6)))
+  (define inst-struct-name4266
+    (make-test-struct `symbols `symbols `(+ 4 (+ 1 1)) `(+ 1 2)))
+  (define inst-struct-name4280 (make-test-struct `#\c `8 `#\d `#t))
+  (define inst-struct-name4287
+    (make-test-struct `,inst-struct-name4280 `4 `#\b `(#\b #t #f . #t)))
+  (define inst-struct-name4293
+    (make-test-struct `#\c `#\a `symbols `(#\d #t (+ 4 (+ 1 1)))))
+  (define inst-struct-name4314
+    (make-test-struct
+      `,inst-struct-name4293
+      `8
+      `(#(#\c #\a #t 5) #&((+ 1 2) 6 these) (+ 1 2) (#\c #\c #t))
+      `#&(#(#\c (+ 4 (+ 1 1)) these #t) these (#\a symbols (+ 1 2)))))
+  (define inst-struct-name4325
+    (make-test-struct
+      `#(symbols are (are (+ 4 5) (+ 4 (+ 1 1)) . #\b) 3)
+      `(#\a these (+ 4 5))
+      `()
+      `(#\b #(#\a these #\b) 12 . #t)))
+  (define inst-struct-name4343
+    (make-test-struct `(+ 4 5) `#\a `#t `(+ 4 (+ 1 1))))
+  (define inst-struct-name4348 (make-test-struct `(+ 1 2) `#\a `9 `#\a))
+  (define inst-struct-name4351
+    (make-test-struct
+      `#f
+      `#\c
+      `(+ 1 2)
+      `(,inst-struct-name4343
+        ,inst-struct-name4348
+        #(#\a (+ 4 5) (+ 4 5))
+        #\c)))
+  (define inst-struct-name4363 (make-test-struct `(+ 4 5) `are `#f `#t))
+  (define inst-struct-name4369
+    (make-test-struct
+      `#\b
+      `are
+      `,inst-struct-name4363
+      `((+ 4 (+ 1 1)) (+ 1 2) these #f)))
+  (define inst-struct-name4376 (make-test-struct `#f `#\d `#t `are))
+  (define inst-struct-name4391 (make-test-struct `#t `#\d `6 `#\d))
+  (define inst-struct-name4405 (make-test-struct `(+ 4 5) `symbols `#f `#\b))
+  (define inst-struct-name4409
+    (make-test-struct
+      `#(6 (+ 1 2) #\a)
+      `,inst-struct-name4405
+      `((+ 1 2) 8 8)
+      `((+ 1 2) #\b #f)))
+  (define inst-struct-name4429
+    (make-test-struct
+      `(#\d (+ 4 5) 1 . #\a)
+      `#\a
+      `#(are these are are)
+      `(are #f #\a)))
+  (define inst-struct-name4430
+    (make-test-struct
+      `,inst-struct-name4409
+      `#&(5 #&(symbols #\b #\a) (4 6 #\a #\c))
+      `,inst-struct-name4429
+      `()))
+  (define inst-struct-name4444
+    (make-test-struct
+      `(#\b (+ 1 2) are . 9)
+      `(+ 1 2)
+      `(+ 1 2)
+      `(#\c (+ 1 2) #\d)))
+  (define inst-struct-name4460
+    (make-test-struct
+      `#&(#t (+ 4 5) #\c)
+      `(1 #\c 1)
+      `(#f (+ 4 5) #\a . symbols)
+      `(+ 4 5)))
+  (define inst-struct-name4470
+    (make-test-struct
+      `,inst-struct-name4460
+      `10
+      `#t
+      `(() #\d (#f #\d #\c are) . #\b)))
+  (define inst-struct-name4501 (make-test-struct `#\b `8 `are `#\a))
+  (define inst-struct-name4516
+    (make-test-struct
+      `#&(,inst-struct-name4501 () #(#\b #\b #t #t))
+      `((#\b #\c #t) 0 ((+ 4 5) #t these) . these)
+      `(#\a #\b 0)
+      `()))
+  (define inst-struct-name4532 (make-test-struct `(+ 4 (+ 1 1)) `#\c `#f `#\c))
+  (define inst-struct-name4539
+    (make-test-struct
+      `,inst-struct-name4532
+      `(#f 9 symbols)
+      `#\d
+      `#(are #f are)))
+  (define inst-struct-name4554 (make-test-struct `#f `#\b `(+ 4 5) `these))
+  (define inst-struct-name4555
+    (make-test-struct
+      `#\b
+      `#(#\c #\b #f (+ 4 5))
+      `#(#f 5 #\a)
+      `,inst-struct-name4554))
+  (define inst-struct-name4578
+    (make-test-struct
+      `5
+      `#&(#\c #((+ 4 (+ 1 1)) 9 these (+ 1 2)) are)
+      `#((#\a 1 #t #\c) #f (#f #\c #\a) (+ 4 (+ 1 1)))
+      `#(#\a #t #t)))
+  (define inst-struct-name4593 (make-test-struct `#t `(+ 4 5) `#\d `#t))
+  (define inst-struct-name4594
+    (make-test-struct
+      `these
+      `#(these #\d symbols #\c)
+      `#((+ 4 5) 0 #f #t)
+      `,inst-struct-name4593))
+  (define inst-struct-name4629 (make-test-struct `(+ 4 5) `2 `are `#\d))
+  (define inst-struct-name4635 (make-test-struct `#f `#\d `1 `2))
+  (define inst-struct-name4644
+    (make-test-struct
+      `,inst-struct-name4629
+      `,inst-struct-name4635
+      `#(7 #\c #\b (+ 1 2))
+      `#(#\c (+ 4 5) #t these)))
+  (define inst-struct-name4656
+    (make-test-struct `symbols `these `#f `(+ 4 (+ 1 1))))
+  (define inst-struct-name4663 (make-test-struct `#\c `#\b `#\a `6))
+  (define inst-struct-name4668
+    (make-test-struct
+      `,inst-struct-name4656
+      `18
+      `,inst-struct-name4663
+      `#&(#\b #\c #\a)))
+  (define inst-struct-name4676 (make-test-struct `#\a `#\a `5 `are))
+  (define inst-struct-name4710
+    (make-test-struct
+      `#(#\b #f #f)
+      `#t
+      `18
+      `#(9 (#\a #\a #t) #&(#t #\d #t) (+ 1 2))))
+  (define inst-struct-name4724 (make-test-struct `#\b `#t `#\a `7))
+  (define inst-struct-name4742
+    (make-test-struct `#\a `#\a `(+ 4 (+ 1 1)) `#\c))
+  (define inst-struct-name4748 (make-test-struct `#\c `#\c `#t `symbols))
+  (define inst-struct-name4767
+    (make-test-struct `8 `#&((+ 1 2) these #\b) `8 `10))
+  (define inst-struct-name4787
+    (make-test-struct
+      `#f
+      `(are #f 8 #f)
+      `(+ 4 (+ 1 1))
+      `(#\d #\b (+ 1 2) . 7)))
+  (define inst-struct-name4798
+    (make-test-struct
+      `#\b
+      `#f
+      `#&(3 ((+ 4 (+ 1 1)) #\d (+ 4 (+ 1 1))) ((+ 1 2) #\a 8))
+      `#\d))
+  (define inst-struct-name4804
+    (make-test-struct `5 `(+ 4 (+ 1 1)) `(+ 4 5) `#(symbols 8 #\a)))
+  (define inst-struct-name4835
+    (make-test-struct `#&(#f (+ 1 2) #f) `(+ 1 2) `#\d `(5 #f #\d are)))
+  (define inst-struct-name4844 (make-test-struct `7 `#t `(+ 1 2) `symbols))
+  (define inst-struct-name4850 (make-test-struct `these `symbols `4 `are))
+  (define inst-struct-name4851
+    (make-test-struct
+      `(#f #\d #\a)
+      `7
+      `,inst-struct-name4844
+      `,inst-struct-name4850))
+  (define inst-struct-name4871 (make-test-struct `#f `symbols `#\a `#t))
+  (define inst-struct-name4879
+    (make-test-struct
+      `(#f #\c #\d)
+      `(,inst-struct-name4871 are #(are symbols #\b) (8 #\b (+ 1 2)))
+      `14
+      `#((+ 4 5) (+ 1 2) (+ 4 5))))
+  (define inst-struct-name4891 (make-test-struct `5 `(+ 4 5) `5 `#\a))
+  (define inst-struct-name4893
+    (make-test-struct
+      `(#\a 9 #\a (+ 1 2))
+      `,inst-struct-name4891
+      `(+ 4 (+ 1 1))
+      `#\d))
+  (define inst-struct-name4902 (make-test-struct `#\a `#\d `7 `5))
+  (define inst-struct-name4934 (make-test-struct `are `#\d `(+ 4 5) `symbols))
+  (define inst-struct-name4940 (make-test-struct `#\a `1 `#t `#f))
+  (define inst-struct-name4946 (make-test-struct `are `3 `4 `these))
+  (define inst-struct-name4980 (make-test-struct `#\d `#t `2 `1))
+  (define inst-struct-name4997 (make-test-struct `(+ 1 2) `#\d `these `#\d))
+  (define inst-struct-name4999
+    (make-test-struct
+      `((+ 1 2) #t (+ 4 (+ 1 1)) . 4)
+      `,inst-struct-name4997
+      `9
+      `#t))
+  (define inst-struct-name5031 (make-test-struct `#f `#\b `#\c `are))
+  (define inst-struct-name5037
+    (make-test-struct
+      `#\d
+      `,inst-struct-name5031
+      `(7 2 (+ 1 2))
+      `((+ 1 2) (+ 4 (+ 1 1)) are these)))
+  (define inst-struct-name5040
+    (make-test-struct `(+ 1 2) `symbols `(7 0 #t) `are))
+  (define inst-struct-name5059 (make-test-struct `5 `#f `#\c `(+ 4 (+ 1 1))))
+  (define inst-struct-name5060
+    (make-test-struct
+      `#f
+      `(are 6 #\a)
+      `#t
+      `((+ 4 (+ 1 1)) ,inst-struct-name5059 #t . 5)))
+  (define inst-struct-name5078 (make-test-struct `#\d `#t `#t `#\a))
+  (define inst-struct-name5086
+    (make-test-struct `,inst-struct-name5078 `#\a `() `#\a))
+  (define inst-struct-name5094 (make-test-struct `0 `#(#\d #\a 1 #t) `() `#\b))
+  (define inst-struct-name5097
+    (make-test-struct `() `(#\b #f are) `symbols `#t))
+  (define inst-struct-name5105 (make-test-struct `#\a `these `#\d `2))
+  (define inst-struct-name5110
+    (make-test-struct
+      `(+ 4 5)
+      `#t
+      `#\b
+      `#(,inst-struct-name5105 #\b #(8 #f #f (+ 4 (+ 1 1))) #\b)))
+  (define inst-struct-name5126
+    (make-test-struct `(3 these these) `(#\c 3 #\b) `#t `(#\b #f are)))
+  (define inst-struct-name5137
+    (make-test-struct `#f `7 `(+ 4 (+ 1 1)) `(+ 4 (+ 1 1))))
+  (define inst-struct-name5138
+    (make-test-struct
+      `#\d
+      `#((+ 4 (+ 1 1)) (+ 4 5) 2 #t)
+      `(+ 4 5)
+      `,inst-struct-name5137))
+  (define inst-struct-name5140
+    (make-test-struct
+      `#(() #\a #f #\a)
+      `(10 ((+ 4 (+ 1 1)) #t 9 . #\b) (#\c #\a #\a #\a) #t)
+      `,inst-struct-name5126
+      `,inst-struct-name5138))
+  (define inst-struct-name5172
+    (make-test-struct
+      `(#\c are #t #\d)
+      `(+ 4 5)
+      `(#f #t (+ 4 (+ 1 1)) . these)
+      `16))
+  (define inst-struct-name5175
+    (make-test-struct
+      `,inst-struct-name5172
+      `#\a
+      `(are #\a 7)
+      `#(#f (+ 1 2) (+ 4 5))))
+  (define inst-struct-name5182
+    (make-test-struct `#\c `(are (+ 4 5) (+ 4 5)) `4 `(7 (+ 4 (+ 1 1)) 4)))
+  (define inst-struct-name5195
+    (make-test-struct `0 `these `() `((+ 1 2) symbols #f)))
+  (define inst-struct-name5207
+    (make-test-struct `3 `(+ 1 2) `(+ 4 (+ 1 1)) `4))
+  (define inst-struct-name5210
+    (make-test-struct
+      `()
+      `#\a
+      `(((+ 4 5) (+ 1 2) (+ 4 5))
+        (#\b (+ 4 (+ 1 1)) are . symbols)
+        ,inst-struct-name5207
+        .
+        #t)
+      `4))
+  (define inst-struct-name5226 (make-test-struct `#\b `#\a `(+ 4 5) `#\b))
+  (define inst-struct-name5230
+    (make-test-struct
+      `(#((+ 4 (+ 1 1)) #\b #\a symbols) #\b ,inst-struct-name5226 #\c)
+      `(#\d #\b #\b)
+      `#(5 8 #\d)
+      `#t))
+  (define inst-struct-name5238 (make-test-struct `0 `6 `7 `#f))
+  (define inst-struct-name5244 (make-test-struct `these `(+ 1 2) `#f `#t))
+  (define inst-struct-name5247
+    (make-test-struct
+      `#(#\b #\a (+ 4 5))
+      `,inst-struct-name5244
+      `(0 #\b these)
+      `#t))
+  (define inst-struct-name5249
+    (make-test-struct
+      `((+ 1 2) (5 #\b #f) #\d ,inst-struct-name5238)
+      `,inst-struct-name5247
+      `#\c
+      `#f))
+  (define inst-struct-name5259 (make-test-struct `6 `#\b `(+ 1 2) `8))
+  (define inst-struct-name5267
+    (make-test-struct `,inst-struct-name5259 `() `8 `(#\c #\d symbols)))
+  (define inst-struct-name5299
+    (make-test-struct `4 `#\a `(these #(7 are #t) 8 . #t) `(+ 4 (+ 1 1))))
+  (define inst-struct-name5336
+    (make-test-struct
+      `()
+      `((#f are #\a) #(#t are symbols #t) (#\d #\b #\b) . #\a)
+      `#&(#t #(are (+ 4 5) 1 are) #\d)
+      `symbols))
+  (define inst-struct-name5350
+    (make-test-struct
+      `(#\d #f (+ 4 5) (+ 1 2))
+      `#t
+      `these
+      `(#\c #\b #\b . symbols)))
+  (define inst-struct-name5363 (make-test-struct `#\c `#t `#f `(+ 1 2)))
+  (define inst-struct-name5381
+    (make-test-struct
+      `these
+      `#(7 #t #\c (+ 4 (+ 1 1)))
+      `(symbols 2 (+ 1 2) #\a)
+      `#((+ 4 5) (+ 4 (+ 1 1)) these 5)))
+  (define inst-struct-name5395
+    (make-test-struct `6 `(+ 4 (+ 1 1)) `symbols `#\c))
+  (define inst-struct-name5402 (make-test-struct `#\b `#t `#\d `#\b))
+  (define inst-struct-name5413 (make-test-struct `#\a `#\d `(+ 4 (+ 1 1)) `5))
+  (define inst-struct-name5417
+    (make-test-struct
+      `()
+      `()
+      `()
+      `#&(,inst-struct-name5413 #\a (#t (+ 1 2) #\d))))
+  (define inst-struct-name5423 (make-test-struct `8 `4 `1 `#\d))
+  (define inst-struct-name5430 (make-test-struct `(+ 4 5) `2 `#\b `7))
+  (define inst-struct-name5431
+    (make-test-struct `#\a `5 `#\d `,inst-struct-name5430))
+  (define inst-struct-name5445 (make-test-struct `#\a `#\b `#\c `these))
+  (define inst-struct-name5449
+    (make-test-struct
+      `(#f (0 9 are (+ 1 2)) (#\d (+ 1 2) 2 . #f) #f)
+      `()
+      `(,inst-struct-name5445 (9 #\c (+ 1 2)) #(are symbols #\a) #\c)
+      `#(#\c #\a symbols)))
+  (define inst-struct-name5454 (make-test-struct `2 `#\a `3 `are))
+  (define inst-struct-name5459
+    (make-test-struct `(+ 4 (+ 1 1)) `#\c `(+ 1 2) `#f))
+  (define inst-struct-name5472 (make-test-struct `4 `8 `#t `#\a))
+  (define inst-struct-name5482
+    (make-test-struct
+      `these
+      `(#f #\b #t . these)
+      `((+ 4 (+ 1 1)) #\d #t . #f)
+      `#\a))
+  (define inst-struct-name5484
+    (make-test-struct
+      `#f
+      `#&((7 #\a #\d) #(#\b (+ 4 (+ 1 1)) 3) ,inst-struct-name5472)
+      `,inst-struct-name5482
+      `#\d))
+
+
+
+(define (let-tests)
+    (list
+     (mytest
+      (match-let*
+        ((((tlp3121 __3)
+           ()
+           (tlp3122 __3)
+           (and (? number? tlp3123) (? even? tlp3124)))
+          `((#\a symbols #\a) () (#\b #f 0) 6)))
+        (list tlp3121 tlp3122 tlp3123))
+      '((#\a symbols #\a) (#\b #f 0) 6))
+     (mytest
+      (match-let*
+        ((((and (and (? test-struct? tlp3158)
+                     (=
+                      test-struct-a
+                      #&((tlp3125 tlp3126 tlp3127 tlp3128)
+                         (tlp3129 ___)
+                         (and (? test-struct? tlp3135)
+                              (= test-struct-a tlp3130)
+                              (= test-struct-b tlp3131)
+                              (= test-struct-c tlp3132)
+                              (= test-struct-d tlp3133))))
+                     (=
+                      test-struct-b
+                      ((tlp3136 tlp3137 tlp3138 tlp3139)
+                       (and (? test-struct? tlp3145)
+                            (= test-struct-a tlp3140)
+                            (= test-struct-b tlp3141)
+                            (= test-struct-c tlp3142)
+                            (= test-struct-d tlp3143))
+                       #(tlp3146 tlp3147 tlp3148 tlp3149)
+                       .
+                       #\d))
+                     (= test-struct-c (tlp3150 __3))
+                     (=
+                      test-struct-d
+                      (#\b
+                       tlp3151
+                       (and (? number? tlp3152) (? even? tlp3153))
+                       #&(tlp3154 tlp3155 tlp3156))))
+                (and (? test-struct? tlp3159)
+                     (=
+                      test-struct-a
+                      #&((tlp3160 tlp3161 tlp3162 tlp3163)
+                         (tlp3164 ___)
+                         (and (? test-struct? tlp3165)
+                              (= test-struct-a tlp3166)
+                              (= test-struct-b tlp3167)
+                              (= test-struct-c tlp3168)
+                              (= test-struct-d tlp3169))))
+                     (=
+                      test-struct-b
+                      ((tlp3170 tlp3171 tlp3172 tlp3173)
+                       (and (? test-struct? tlp3174)
+                            (= test-struct-a tlp3175)
+                            (= test-struct-b tlp3176)
+                            (= test-struct-c tlp3177)
+                            (= test-struct-d tlp3178))
+                       #(tlp3179 tlp3180 tlp3181 tlp3182)
+                       .
+                       #\d))
+                     (= test-struct-c (tlp3183 __3))
+                     (=
+                      test-struct-d
+                      (#\b
+                       tlp3184
+                       (and (? number? tlp3185) (? even? tlp3186))
+                       #&(tlp3187 tlp3188 tlp3189)))))
+           (not (not #\a))
+           ($
+            test-struct
+            #(tlp3190 ...)
+            tlp3191
+            (and (? test-struct? tlp3198)
+                 (= test-struct-a (tlp3192 __3))
+                 (= test-struct-b tlp3193)
+                 (= test-struct-c (and tlp3194 tlp3195))
+                 (= test-struct-d (tlp3196 ...)))
+            tlp3199)
+           (tlp3201 __3))
+          `(,inst-struct-name3157 #\a ,inst-struct-name3200 (#t #\b symbols))))
+        (list
+         tlp3125
+         tlp3126
+         tlp3127
+         tlp3128
+         tlp3129
+         tlp3130
+         tlp3131
+         tlp3132
+         tlp3133
+         tlp3136
+         tlp3137
+         tlp3138
+         tlp3139
+         tlp3140
+         tlp3141
+         tlp3142
+         tlp3143
+         tlp3146
+         tlp3147
+         tlp3148
+         tlp3149
+         tlp3150
+         tlp3151
+         tlp3152
+         tlp3154
+         tlp3155
+         tlp3156
+         tlp3190
+         tlp3191
+         tlp3192
+         tlp3193
+         tlp3194
+         tlp3196
+         tlp3199
+         tlp3201))
+      '(#f
+        (+ 1 2)
+        #\d
+        #\b
+        (#\d 1 symbols)
+        6
+        #t
+        (+ 4 (+ 1 1))
+        #\a
+        5
+        7
+        symbols
+        #t
+        #\a
+        3
+        (+ 4 5)
+        7
+        (+ 4 (+ 1 1))
+        #f
+        #\a
+        #\d
+        (#\a (+ 4 (+ 1 1)) these)
+        3
+        4
+        (+ 4 (+ 1 1))
+        #f
+        2
+        (#\b symbols (+ 1 2))
+        symbols
+        (8 #\b (+ 1 2))
+        (+ 1 2)
+        #\a
+        ((+ 1 2) #f 5)
+        5
+        (#t #\b symbols)))
+     (mytest
+      (match-let
+        (((((and tlp3202 tlp3203) (tlp3204 ___) tlp3205 tlp3206)
+           tlp3207
+           tlp3208
+           tlp3209)
+          `((these ((+ 4 5) #\b 6) #\a #\c) #\b (+ 4 5) 0)))
+        (list tlp3202 tlp3204 tlp3205 tlp3206 tlp3207 tlp3208 tlp3209))
+      '(these ((+ 4 5) #\b 6) #\a #\c #\b (+ 4 5) 0))
+     (mytest
+      (match-let*
+        ((((and () ()) tlp3210 tlp3211 _) `(() #t (+ 4 (+ 1 1)) #\a)))
+        (list tlp3210 tlp3211))
+      '(#t (+ 4 (+ 1 1))))
+     (mytest
+      (match-let
+        ((((and (? number? tlp3212) (? even? tlp3213))
+           (and (? number? tlp3214) (? even? tlp3215))
+           (and (tlp3216 ___) (tlp3217 ___))
+           tlp3218)
+          `(2 16 (#\c symbols (+ 1 2)) 7)))
+        (list tlp3212 tlp3214 tlp3216 tlp3218))
+      '(2 16 (#\c symbols (+ 1 2)) 7))))
+
+(let-tests)
+
+(define (multi-let-tests)
+    (list
+     (mytest
+      (match-let
+        (((#(tlp3219 ...) #(tlp3220 ...) #(tlp3221 ___) ())
+          `(#(#\d #f #f) #(#t (+ 1 2) (+ 4 5)) #(#t are #t) ()))
+         (('are tlp3222 #\a 9) `(are 3 #\a 9))
+         ((tlp3223
+            ((#\b
+              ($ test-struct tlp3224 tlp3225 tlp3226 tlp3227)
+              #f
+              quote
+              these)
+             ()
+             (#(tlp3229 ...)
+              (or (and (? test-struct? tlp3235)
+                       (= test-struct-a tlp3230)
+                       (= test-struct-b tlp3231)
+                       (= test-struct-c tlp3232)
+                       (= test-struct-d tlp3233))
+                  (and (? test-struct? tlp3235)
+                       (= test-struct-a tlp3230)
+                       (= test-struct-b tlp3231)
+                       (= test-struct-c tlp3232)
+                       (= test-struct-d tlp3233)))
+              #(tlp3236 ___)
+              .
+              5)
+             ())
+            (tlp3237 ..3)
+            (and (? test-struct? tlp3240)
+                 (= test-struct-a (or () ()))
+                 (= test-struct-b #(tlp3238 ...))
+                 (= test-struct-c (not (not #\c)))
+                 (= test-struct-d #\b)))
+          `(#f
+            ((#\b ,inst-struct-name3228 #f . these)
+             ()
+             (#((+ 1 2) #\c 2) ,inst-struct-name3234 #(#t #\b are) . 5)
+             ())
+            (#\d are (+ 4 5))
+            ,inst-struct-name3239))
+         (((tlp3241 ___)
+           ()
+           ((and (and (? test-struct? tlp3253)
+                      (= test-struct-a (tlp3242 tlp3243 tlp3244 . tlp3245))
+                      (= test-struct-b #(tlp3246 tlp3247 tlp3248 tlp3249))
+                      (=
+                       test-struct-c
+                       (and (? number? tlp3250) (? even? tlp3251)))
+                      (= test-struct-d _))
+                 (and (? test-struct? tlp3254)
+                      (= test-struct-a (tlp3255 tlp3256 tlp3257 . tlp3258))
+                      (= test-struct-b #(tlp3259 tlp3260 tlp3261 tlp3262))
+                      (=
+                       test-struct-c
+                       (and (? number? tlp3263) (? even? tlp3264)))
+                      (= test-struct-d _)))
+            #(#\a
+              (or 'symbols 'symbols)
+              #(tlp3265 tlp3266 tlp3267 tlp3268)
+              #&(tlp3269 tlp3270 tlp3271))
+            (and (? number? tlp3272) (? even? tlp3273))
+            (tlp3274 ..3))
+           tlp3275)
+          `((#t #\b symbols)
+            ()
+            (,inst-struct-name3252
+             #(#\a symbols #(these #\a #f #\a) #&(#t (+ 4 (+ 1 1)) #\b))
+             4
+             (#t #\d #\c))
+            are))
+         (((tlp3276
+             ($
+              test-struct
+              tlp3277
+              (and #(tlp3278 tlp3279 tlp3280 tlp3281)
+                   #(tlp3282 tlp3283 tlp3284 tlp3285))
+              (and (not (not #t)) (not (not #t)))
+              tlp3286)
+             #&((tlp3288 ___) (tlp3289 __3) tlp3290)
+             .
+             #\b)
+           ((or () ())
+            (and (? test-struct? tlp3298)
+                 (= test-struct-a _)
+                 (= test-struct-b tlp3291)
+                 (= test-struct-c #(tlp3292 ...))
+                 (= test-struct-d #(tlp3293 tlp3294 tlp3295 tlp3296)))
+            tlp3299
+            (and (? test-struct? tlp3313)
+                 (= test-struct-a #&(tlp3300 tlp3301 tlp3302))
+                 (=
+                  test-struct-b
+                  ($ test-struct tlp3303 tlp3304 tlp3305 tlp3306))
+                 (=
+                  test-struct-c
+                  (or (tlp3308 tlp3309 tlp3310 tlp3311)
+                      (tlp3308 tlp3309 tlp3310 tlp3311)))
+                 (= test-struct-d _)))
+           #&((and (? test-struct? tlp3323)
+                   (= test-struct-a (tlp3314 ...))
+                   (= test-struct-b (tlp3315 tlp3316 tlp3317 . #\a))
+                   (= test-struct-c #(tlp3318 ___))
+                   (= test-struct-d #&(tlp3319 tlp3320 tlp3321)))
+              #&((tlp3324 __3) #(tlp3325 ___) (tlp3326 ___))
+              ((tlp3327 ...) tlp3328 (tlp3329 ...) (tlp3330 __3)))
+           (tlp3331 ___))
+          `((these
+             ,inst-struct-name3287
+             #&((5 #\a 4) (#\b #\a #f) these)
+             .
+             #\b)
+            (() ,inst-struct-name3297 (+ 4 5) ,inst-struct-name3312)
+            #&(,inst-struct-name3322
+               #&((are 6 2) #((+ 4 5) these #\a) ((+ 1 2) 0 #\b))
+               ((#\b these 2) 0 (1 (+ 4 (+ 1 1)) #t) (#\a #t #\a)))
+            (these #\d #\b))))
+        (list
+         tlp3219
+         tlp3220
+         tlp3221
+         tlp3222
+         tlp3223
+         tlp3224
+         tlp3225
+         tlp3226
+         tlp3227
+         tlp3229
+         tlp3230
+         tlp3231
+         tlp3232
+         tlp3233
+         tlp3236
+         tlp3237
+         tlp3238
+         tlp3241
+         tlp3242
+         tlp3243
+         tlp3244
+         tlp3245
+         tlp3246
+         tlp3247
+         tlp3248
+         tlp3249
+         tlp3250
+         tlp3265
+         tlp3266
+         tlp3267
+         tlp3268
+         tlp3269
+         tlp3270
+         tlp3271
+         tlp3272
+         tlp3274
+         tlp3275
+         tlp3276
+         tlp3277
+         tlp3278
+         tlp3279
+         tlp3280
+         tlp3281
+         tlp3286
+         tlp3288
+         tlp3289
+         tlp3290
+         tlp3291
+         tlp3292
+         tlp3293
+         tlp3294
+         tlp3295
+         tlp3296
+         tlp3299
+         tlp3300
+         tlp3301
+         tlp3302
+         tlp3303
+         tlp3304
+         tlp3305
+         tlp3306
+         tlp3308
+         tlp3309
+         tlp3310
+         tlp3311
+         tlp3314
+         tlp3315
+         tlp3316
+         tlp3317
+         tlp3318
+         tlp3319
+         tlp3320
+         tlp3321
+         tlp3324
+         tlp3325
+         tlp3326
+         tlp3327
+         tlp3328
+         tlp3329
+         tlp3330
+         tlp3331))
+      '((#\d #f #f)
+        (#t (+ 1 2) (+ 4 5))
+        (#t are #t)
+        3
+        #f
+        these
+        3
+        #\d
+        #t
+        ((+ 1 2) #\c 2)
+        (+ 4 5)
+        #\a
+        #\a
+        #f
+        (#t #\b are)
+        (#\d are (+ 4 5))
+        (#\d #\b #\b)
+        (#t #\b symbols)
+        #t
+        #\c
+        #\c
+        are
+        (+ 1 2)
+        (+ 4 5)
+        #\b
+        9
+        16
+        these
+        #\a
+        #f
+        #\a
+        #t
+        (+ 4 (+ 1 1))
+        #\b
+        4
+        (#t #\d #\c)
+        are
+        these
+        #\d
+        (+ 4 5)
+        #t
+        (+ 4 5)
+        #t
+        (+ 4 (+ 1 1))
+        (5 #\a 4)
+        (#\b #\a #f)
+        these
+        #f
+        (are symbols #\c)
+        these
+        symbols
+        #t
+        #\d
+        (+ 4 5)
+        symbols
+        #\d
+        #\c
+        #t
+        (+ 4 (+ 1 1))
+        #\d
+        #f
+        these
+        are
+        (+ 1 2)
+        (+ 4 5)
+        (#t 6 #\c)
+        #t
+        #\d
+        2
+        (#f 6 #\b)
+        #f
+        7
+        symbols
+        (are 6 2)
+        ((+ 4 5) these #\a)
+        ((+ 1 2) 0 #\b)
+        (#\b these 2)
+        0
+        (1 (+ 4 (+ 1 1)) #t)
+        (#\a #t #\a)
+        (these #\d #\b)))
+     (mytest
+      (match-let*
+        (((#\d
+           ((not (not '(+ 4 5))) tlp3332 (not (not #f)) #t)
+           #&(tlp3333
+               (not (not 7))
+               (#(tlp3334 tlp3335 tlp3336 tlp3337)
+                #&(tlp3338 tlp3339 tlp3340)
+                tlp3341
+                .
+                9))
+           (or (tlp3342 ___) (tlp3342 ___)))
+          `(#\d
+            ((+ 4 5) 9 #f #t)
+            #&(#f 7 (#(4 symbols are are) #&((+ 4 (+ 1 1)) #\d 3) these . 9))
+            (#\d these 7)))
+         ((((and (tlp3343 ...) (tlp3344 ...)) () tlp3345 . #\a)
+           ((not (not #t)) _ _ . #f)
+           #\a
+           #(_
+             (or (_
+                  tlp3346
+                  (tlp3347 tlp3348 tlp3349 tlp3350)
+                  (and (? test-struct? tlp3356)
+                       (= test-struct-a tlp3351)
+                       (= test-struct-b tlp3352)
+                       (= test-struct-c tlp3353)
+                       (= test-struct-d tlp3354)))
+                 (_
+                  tlp3346
+                  (tlp3347 tlp3348 tlp3349 tlp3350)
+                  (and (? test-struct? tlp3356)
+                       (= test-struct-a tlp3351)
+                       (= test-struct-b tlp3352)
+                       (= test-struct-c tlp3353)
+                       (= test-struct-d tlp3354))))
+             #&(#(tlp3357 tlp3358 tlp3359 tlp3360)
+                #\d
+                (and (? number? tlp3361) (? even? tlp3362)))
+             #(($ test-struct tlp3363 tlp3364 tlp3365 tlp3366)
+               ($ test-struct tlp3368 tlp3369 tlp3370 tlp3371)
+               (and (? number? tlp3373) (? even? tlp3374))
+               tlp3375)))
+          `(((#\a #\b #f) () #f . #\a)
+            (#t #f #t . #f)
+            #\a
+            #((+ 1 2)
+              (3 #f (#\d are #\c these) ,inst-struct-name3355)
+              #&(#(#t (+ 1 2) #\a #\b) #\d 0)
+              #(,inst-struct-name3367 ,inst-struct-name3372 4 (+ 4 5)))))
+         (((and tlp3376 tlp3377) #\a () #(tlp3378 ...)) `(3 #\a () #(1 #t 1)))
+         ((_
+           #((()
+              (and #(tlp3379 tlp3380 tlp3381 tlp3382)
+                   #(tlp3383 tlp3384 tlp3385 tlp3386))
+              (tlp3387 ..3)
+              .
+              3)
+             ((tlp3388 tlp3389 tlp3390 . #\a)
+              (or (tlp3391 ..3) (tlp3391 ..3))
+              _
+              ($ test-struct tlp3392 tlp3393 tlp3394 tlp3395))
+             (and (? number? tlp3397) (? even? tlp3398))
+             tlp3399)
+           tlp3400
+           ())
+          `(#\d
+            #((() #(these 7 #t #\a) (#\d #f #t) . 3)
+              (((+ 1 2) (+ 4 5) are . #\a)
+               (#\d #t these)
+               (+ 4 5)
+               ,inst-struct-name3396)
+              6
+              (+ 1 2))
+            #\a
+            ()))
+         ((#(tlp3401 ___)
+           '(+ 1 2)
+           #(_
+             '(+ 1 2)
+             (and #&((tlp3402 tlp3403 tlp3404 tlp3405) tlp3406 '(+ 1 2))
+                  #&((tlp3407 tlp3408 tlp3409 tlp3410) tlp3411 '(+ 1 2)))
+             (tlp3412 ..3))
+           _)
+          `(#(#\c #\b these)
+            (+ 1 2)
+            #(these (+ 1 2) #&((are 4 #f #\d) symbols (+ 1 2)) (#f #\a 6))
+            these)))
+        (list
+         tlp3332
+         tlp3333
+         tlp3334
+         tlp3335
+         tlp3336
+         tlp3337
+         tlp3338
+         tlp3339
+         tlp3340
+         tlp3341
+         tlp3342
+         tlp3343
+         tlp3345
+         tlp3346
+         tlp3347
+         tlp3348
+         tlp3349
+         tlp3350
+         tlp3351
+         tlp3352
+         tlp3353
+         tlp3354
+         tlp3357
+         tlp3358
+         tlp3359
+         tlp3360
+         tlp3361
+         tlp3363
+         tlp3364
+         tlp3365
+         tlp3366
+         tlp3368
+         tlp3369
+         tlp3370
+         tlp3371
+         tlp3373
+         tlp3375
+         tlp3376
+         tlp3378
+         tlp3379
+         tlp3380
+         tlp3381
+         tlp3382
+         tlp3387
+         tlp3388
+         tlp3389
+         tlp3390
+         tlp3391
+         tlp3392
+         tlp3393
+         tlp3394
+         tlp3395
+         tlp3397
+         tlp3399
+         tlp3400
+         tlp3401
+         tlp3402
+         tlp3403
+         tlp3404
+         tlp3405
+         tlp3406
+         tlp3412))
+      '(9
+        #f
+        4
+        symbols
+        are
+        are
+        (+ 4 (+ 1 1))
+        #\d
+        3
+        these
+        (#\d these 7)
+        (#\a #\b #f)
+        #f
+        #f
+        #\d
+        are
+        #\c
+        these
+        (+ 1 2)
+        these
+        #t
+        #t
+        #t
+        (+ 1 2)
+        #\a
+        #\b
+        0
+        #\d
+        #\a
+        6
+        (+ 1 2)
+        symbols
+        #\a
+        3
+        #\c
+        4
+        (+ 4 5)
+        3
+        (1 #t 1)
+        these
+        7
+        #t
+        #\a
+        (#\d #f #t)
+        (+ 1 2)
+        (+ 4 5)
+        are
+        (#\d #t these)
+        0
+        #\d
+        #\a
+        #\b
+        6
+        (+ 1 2)
+        #\a
+        (#\c #\b these)
+        are
+        4
+        #f
+        #\d
+        symbols
+        (#f #\a 6)))
+     (mytest
+      (match-let
+        (((_
+           (tlp3413 ...)
+           (#&(#(tlp3414 ___)
+               ($ test-struct tlp3415 tlp3416 tlp3417 tlp3418)
+               (and (? number? tlp3420) (? even? tlp3421)))
+            ((not (not #\b))
+             (tlp3422 tlp3423 tlp3424 . #\a)
+             (tlp3425 tlp3426 tlp3427 tlp3428)
+             .
+             #\c)
+            (tlp3429 ...)
+            tlp3430)
+           tlp3431)
+          `((+ 4 5)
+            (these #f #\b)
+            (#&(#(7 4 2) ,inst-struct-name3419 8)
+             (#\b (#\c 2 #t . #\a) (#f (+ 4 (+ 1 1)) #t #\b) . #\c)
+             (#\b 0 2)
+             #f)
+            #\b))
+         ((tlp3432 tlp3433 (tlp3434 ...) ()) `((+ 4 5) #\c (7 #t #\c) ()))
+         (((tlp3435 ...)
+           (and (? test-struct? tlp3445)
+                (= test-struct-a (tlp3436 ..3))
+                (= test-struct-b ())
+                (=
+                 test-struct-c
+                 ((tlp3437 ___)
+                  tlp3438
+                  #(tlp3439 tlp3440 tlp3441 tlp3442)
+                  .
+                  5))
+                (= test-struct-d #(tlp3443 ___)))
+           #((and (and (? test-struct? tlp3456)
+                       (= test-struct-a ())
+                       (= test-struct-b (tlp3446 tlp3447 tlp3448 . tlp3449))
+                       (= test-struct-c #&(tlp3450 tlp3451 tlp3452))
+                       (= test-struct-d (and tlp3453 tlp3454)))
+                  (and (? test-struct? tlp3457)
+                       (= test-struct-a ())
+                       (= test-struct-b (tlp3458 tlp3459 tlp3460 . tlp3461))
+                       (= test-struct-c #&(tlp3462 tlp3463 tlp3464))
+                       (= test-struct-d (and tlp3465 tlp3466))))
+             tlp3467
+             #t
+             #&((not (not 2)) #&(tlp3468 tlp3469 tlp3470) _))
+           (and (? test-struct? tlp3475)
+                (= test-struct-a (_ (or tlp3471 tlp3471) (not (not #f)) . #\d))
+                (= test-struct-b tlp3472)
+                (= test-struct-c ())
+                (= test-struct-d (tlp3473 ...))))
+          `((these symbols 9)
+            ,inst-struct-name3444
+            #(,inst-struct-name3455 #\c #t #&(2 #&(are #f (+ 1 2)) #\b))
+            ,inst-struct-name3474))
+         ((($
+            test-struct
+            (and (? number? tlp3476) (? even? tlp3477))
+            ((or (and (? test-struct? tlp3483)
+                      (= test-struct-a tlp3478)
+                      (= test-struct-b tlp3479)
+                      (= test-struct-c tlp3480)
+                      (= test-struct-d tlp3481))
+                 (and (? test-struct? tlp3483)
+                      (= test-struct-a tlp3478)
+                      (= test-struct-b tlp3479)
+                      (= test-struct-c tlp3480)
+                      (= test-struct-d tlp3481)))
+             #(tlp3484 tlp3485 tlp3486 tlp3487)
+             #&(tlp3488 tlp3489 tlp3490)
+             '(+ 4 5))
+            #(tlp3491 ___)
+            tlp3492)
+           (tlp3494 ..3)
+           (tlp3495 ..3)
+           tlp3496)
+          `(,inst-struct-name3493
+            (#t #\a (+ 4 (+ 1 1)))
+            (are (+ 1 2) these)
+            (+ 4 (+ 1 1))))
+         (((#&((tlp3497 tlp3498 tlp3499 tlp3500)
+               (and _ _)
+               (and (? test-struct? tlp3506)
+                    (= test-struct-a tlp3501)
+                    (= test-struct-b tlp3502)
+                    (= test-struct-c tlp3503)
+                    (= test-struct-d tlp3504)))
+            (tlp3507 ...)
+            (and (? test-struct? tlp3513)
+                 (= test-struct-a #&(tlp3508 tlp3509 tlp3510))
+                 (= test-struct-b ())
+                 (= test-struct-c _)
+                 (= test-struct-d (tlp3511 ___)))
+            (or (and ($ test-struct tlp3514 tlp3515 tlp3516 tlp3517)
+                     ($ test-struct tlp3519 tlp3520 tlp3521 tlp3522))
+                (and ($ test-struct tlp3514 tlp3515 tlp3516 tlp3517)
+                     ($ test-struct tlp3519 tlp3520 tlp3521 tlp3522))))
+           ((not (not 9))
+            #f
+            '(+ 4 5)
+            #&((and (? test-struct? tlp3528)
+                    (= test-struct-a tlp3523)
+                    (= test-struct-b tlp3524)
+                    (= test-struct-c tlp3525)
+                    (= test-struct-d tlp3526))
+               (tlp3529 __3)
+               #(tlp3530 tlp3531 tlp3532 tlp3533)))
+           (not (not #\d))
+           9)
+          `((#&((#f #\c (+ 4 5) #\d) #t ,inst-struct-name3505)
+             (4 #\d #\c)
+             ,inst-struct-name3512
+             ,inst-struct-name3518)
+            (9
+             #f
+             (+ 4 5)
+             #&(,inst-struct-name3527 (#\c #\d #\c) #(symbols #\a #f #\c)))
+            #\d
+            9)))
+        (list
+         tlp3413
+         tlp3414
+         tlp3415
+         tlp3416
+         tlp3417
+         tlp3418
+         tlp3420
+         tlp3422
+         tlp3423
+         tlp3424
+         tlp3425
+         tlp3426
+         tlp3427
+         tlp3428
+         tlp3429
+         tlp3430
+         tlp3431
+         tlp3432
+         tlp3433
+         tlp3434
+         tlp3435
+         tlp3436
+         tlp3437
+         tlp3438
+         tlp3439
+         tlp3440
+         tlp3441
+         tlp3442
+         tlp3443
+         tlp3446
+         tlp3447
+         tlp3448
+         tlp3449
+         tlp3450
+         tlp3451
+         tlp3452
+         tlp3453
+         tlp3467
+         tlp3468
+         tlp3469
+         tlp3470
+         tlp3471
+         tlp3472
+         tlp3473
+         tlp3476
+         tlp3478
+         tlp3479
+         tlp3480
+         tlp3481
+         tlp3484
+         tlp3485
+         tlp3486
+         tlp3487
+         tlp3488
+         tlp3489
+         tlp3490
+         tlp3491
+         tlp3492
+         tlp3494
+         tlp3495
+         tlp3496
+         tlp3497
+         tlp3498
+         tlp3499
+         tlp3500
+         tlp3501
+         tlp3502
+         tlp3503
+         tlp3504
+         tlp3507
+         tlp3508
+         tlp3509
+         tlp3510
+         tlp3511
+         tlp3514
+         tlp3515
+         tlp3516
+         tlp3517
+         tlp3523
+         tlp3524
+         tlp3525
+         tlp3526
+         tlp3529
+         tlp3530
+         tlp3531
+         tlp3532
+         tlp3533))
+      '((these #f #\b)
+        (7 4 2)
+        #\c
+        #\c
+        symbols
+        9
+        8
+        #\c
+        2
+        #t
+        #f
+        (+ 4 (+ 1 1))
+        #t
+        #\b
+        (#\b 0 2)
+        #f
+        #\b
+        (+ 4 5)
+        #\c
+        (7 #t #\c)
+        (these symbols 9)
+        (#\c (+ 4 (+ 1 1)) (+ 4 5))
+        (6 #\a 2)
+        0
+        these
+        #\c
+        these
+        1
+        (#f #\a #\d)
+        #\d
+        #t
+        symbols
+        #\d
+        #\d
+        (+ 4 (+ 1 1))
+        these
+        2
+        #\c
+        are
+        #f
+        (+ 1 2)
+        #\c
+        #\a
+        (#t #\a #\a)
+        16
+        symbols
+        #\b
+        #f
+        #f
+        #f
+        #\c
+        (+ 4 5)
+        #f
+        (+ 4 5)
+        #\d
+        are
+        (#t #f 4)
+        #\d
+        (#t #\a (+ 4 (+ 1 1)))
+        (are (+ 1 2) these)
+        (+ 4 (+ 1 1))
+        #f
+        #\c
+        (+ 4 5)
+        #\d
+        4
+        (+ 4 (+ 1 1))
+        #f
+        these
+        (4 #\d #\c)
+        symbols
+        #f
+        2
+        (are (+ 4 (+ 1 1)) (+ 4 (+ 1 1)))
+        8
+        #\b
+        #\c
+        symbols
+        #\a
+        #t
+        4
+        #t
+        (#\c #\d #\c)
+        symbols
+        #\a
+        #f
+        #\c))
+     (mytest
+      (match-let
+        (((tlp3534
+            tlp3535
+            (tlp3536 _ tlp3537 quote symbols)
+            (or (or tlp3538 tlp3538) (or tlp3538 tlp3538)))
+          `(symbols #\b (3 (+ 1 2) 2 . symbols) (+ 4 (+ 1 1))))
+         (((tlp3539 __3)
+           tlp3540
+           (and (? number? tlp3541) (? even? tlp3542))
+           (and (? number? tlp3543) (? even? tlp3544)))
+          `((#\c #f (+ 1 2)) #t 2 2))
+         (((or tlp3545 tlp3545)
+           (or #f #f)
+           ($ test-struct tlp3546 (tlp3547 ..3) (tlp3548 ___) tlp3549)
+           (#(tlp3551 ...) 7 #f . #\b))
+          `(#\b #f ,inst-struct-name3550 (#(#f #\b symbols) 7 #f . #\b)))
+         ((#&(#&((or tlp3552 tlp3552)
+                 tlp3553
+                 (and (? number? tlp3554) (? even? tlp3555)))
+              tlp3556
+              (tlp3557 ___))
+           (((tlp3558 tlp3559 tlp3560 . #\b)
+             (or #(tlp3561 ___) #(tlp3561 ___))
+             (tlp3562 tlp3563 tlp3564 . #\d)
+             tlp3565)
+            (and (? test-struct? tlp3579)
+                 (=
+                  test-struct-a
+                  ($ test-struct tlp3566 tlp3567 tlp3568 tlp3569))
+                 (=
+                  test-struct-b
+                  (or (and (? number? tlp3571) (? even? tlp3572))
+                      (and (? number? tlp3571) (? even? tlp3572))))
+                 (=
+                  test-struct-c
+                  ($ test-struct tlp3573 tlp3574 tlp3575 tlp3576))
+                 (= test-struct-d (not (not 9))))
+            (and tlp3580 tlp3581)
+            (and (? number? tlp3582) (? even? tlp3583)))
+           #(tlp3584 ___)
+           (or tlp3585 tlp3585))
+          `(#&(#&(9 #\a 4) symbols ((+ 1 2) 0 (+ 4 5)))
+            (((#\b (+ 1 2) #f . #\b)
+              #((+ 4 5) #\c #\c)
+              ((+ 4 5) (+ 4 5) #f . #\d)
+              7)
+             ,inst-struct-name3578
+             symbols
+             18)
+            #(are #\b #t)
+            #\a))
+         ((#(tlp3586 ...)
+           #f
+           ((and (? test-struct? tlp3596)
+                 (= test-struct-a (tlp3587 ...))
+                 (= test-struct-b (tlp3588 tlp3589 tlp3590 . #\c))
+                 (= test-struct-c #(tlp3591 tlp3592 tlp3593 tlp3594))
+                 (= test-struct-d (not (not #\b))))
+            ($
+             test-struct
+             #\a
+             (and (? number? tlp3597) (? even? tlp3598))
+             _
+             tlp3599)
+            ((and (? test-struct? tlp3606)
+                  (= test-struct-a tlp3601)
+                  (= test-struct-b tlp3602)
+                  (= test-struct-c tlp3603)
+                  (= test-struct-d tlp3604))
+             (tlp3607 __3)
+             (and #(tlp3608 ...) #(tlp3609 ...))
+             .
+             6)
+            '(+ 1 2))
+           #\b)
+          `(#(#\a 0 7)
+            #f
+            (,inst-struct-name3595
+             ,inst-struct-name3600
+             (,inst-struct-name3605 (#\d 6 #\c) #(2 symbols 1) . 6)
+             (+ 1 2))
+            #\b)))
+        (list
+         tlp3534
+         tlp3535
+         tlp3536
+         tlp3537
+         tlp3538
+         tlp3539
+         tlp3540
+         tlp3541
+         tlp3543
+         tlp3545
+         tlp3546
+         tlp3547
+         tlp3548
+         tlp3549
+         tlp3551
+         tlp3552
+         tlp3553
+         tlp3554
+         tlp3556
+         tlp3557
+         tlp3558
+         tlp3559
+         tlp3560
+         tlp3561
+         tlp3562
+         tlp3563
+         tlp3564
+         tlp3565
+         tlp3566
+         tlp3567
+         tlp3568
+         tlp3569
+         tlp3571
+         tlp3573
+         tlp3574
+         tlp3575
+         tlp3576
+         tlp3580
+         tlp3582
+         tlp3584
+         tlp3585
+         tlp3586
+         tlp3587
+         tlp3588
+         tlp3589
+         tlp3590
+         tlp3591
+         tlp3592
+         tlp3593
+         tlp3594
+         tlp3597
+         tlp3599
+         tlp3601
+         tlp3602
+         tlp3603
+         tlp3604
+         tlp3607
+         tlp3608))
+      '(symbols
+         #\b
+         3
+         2
+         (+ 4 (+ 1 1))
+         (#\c #f (+ 1 2))
+         #t
+         2
+         2
+         #\b
+         (+ 4 (+ 1 1))
+         (#t 8 symbols)
+         (#\a #\c #t)
+         0
+         (#f #\b symbols)
+         9
+         #\a
+         4
+         symbols
+         ((+ 1 2) 0 (+ 4 5))
+         #\b
+         (+ 1 2)
+         #f
+         ((+ 4 5) #\c #\c)
+         (+ 4 5)
+         (+ 4 5)
+         #f
+         7
+         #\b
+         #\c
+         #\d
+         #\c
+         16
+         #\b
+         (+ 1 2)
+         #\b
+         #\b
+         symbols
+         18
+         (are #\b #t)
+         #\a
+         (#\a 0 7)
+         (0 these are)
+         #\d
+         #f
+         (+ 4 (+ 1 1))
+         #\b
+         #\a
+         these
+         symbols
+         0
+         2
+         are
+         1
+         3
+         #\d
+         (#\d 6 #\c)
+         (2 symbols 1)))
+     (mytest
+      (match-let
+        (((_ (not (not #f)) (not (not #f)) #(tlp3610 ___))
+          `(#t #f #f #(#\b #\d these)))
+         (((tlp3611 ...)
+           #((tlp3612 ...)
+             (and tlp3613 tlp3614)
+             (tlp3615 ...)
+             (and (? test-struct? tlp3626)
+                  (= test-struct-a (and () ()))
+                  (= test-struct-b tlp3616)
+                  (= test-struct-c #(tlp3617 tlp3618 tlp3619 tlp3620))
+                  (= test-struct-d #(tlp3621 tlp3622 tlp3623 tlp3624))))
+           (and #(tlp3627
+                  #(tlp3628 ...)
+                  (and (? test-struct? tlp3640)
+                       (= test-struct-a _)
+                       (=
+                        test-struct-b
+                        ($ test-struct tlp3629 tlp3630 tlp3631 tlp3632))
+                       (= test-struct-c #&(tlp3634 tlp3635 tlp3636))
+                       (= test-struct-d (and tlp3637 tlp3638)))
+                  tlp3641)
+                #(tlp3642
+                  #(tlp3643 ...)
+                  (and (? test-struct? tlp3644)
+                       (= test-struct-a _)
+                       (=
+                        test-struct-b
+                        ($ test-struct tlp3645 tlp3646 tlp3647 tlp3648))
+                       (= test-struct-c #&(tlp3649 tlp3650 tlp3651))
+                       (= test-struct-d (and tlp3652 tlp3653)))
+                  tlp3654))
+           tlp3655)
+          `((4 are #\c)
+            #((#\b #t symbols) these ((+ 4 5) 6 #\b) ,inst-struct-name3625)
+            #(#f #(#\c #\c 6) ,inst-struct-name3639 4)
+            #\a))
+         ((tlp3656 #\c tlp3657 ((tlp3658 __3) #\d (tlp3659 ___) . #\c))
+          `(#t #\c (+ 1 2) ((5 #\b 1) #\d (0 symbols #\d) . #\c)))
+         ((tlp3660 _ () _) `(#\c #\a () #f))
+         (('these tlp3661 () tlp3662) `(these #\a () #f)))
+        (list
+         tlp3610
+         tlp3611
+         tlp3612
+         tlp3613
+         tlp3615
+         tlp3616
+         tlp3617
+         tlp3618
+         tlp3619
+         tlp3620
+         tlp3621
+         tlp3622
+         tlp3623
+         tlp3624
+         tlp3627
+         tlp3628
+         tlp3629
+         tlp3630
+         tlp3631
+         tlp3632
+         tlp3634
+         tlp3635
+         tlp3636
+         tlp3637
+         tlp3641
+         tlp3655
+         tlp3656
+         tlp3657
+         tlp3658
+         tlp3659
+         tlp3660
+         tlp3661
+         tlp3662))
+      '((#\b #\d these)
+        (4 are #\c)
+        (#\b #t symbols)
+        these
+        ((+ 4 5) 6 #\b)
+        #\a
+        #\a
+        #\c
+        (+ 1 2)
+        #t
+        (+ 4 (+ 1 1))
+        #\b
+        5
+        these
+        #f
+        (#\c #\c 6)
+        (+ 4 (+ 1 1))
+        are
+        #f
+        #\c
+        are
+        symbols
+        4
+        #\c
+        4
+        #\a
+        #t
+        (+ 1 2)
+        (5 #\b 1)
+        (0 symbols #\d)
+        #\c
+        #\a
+        #f))))
+
+(multi-let-tests)
+
+(define (define-tests)
+    (list
+     (mytest
+      (let ()
+        (match-define
+          (#(#(tlp3663 ___)
+             (tlp3664 ___)
+             (and (? number? tlp3665) (? even? tlp3666))
+             #&(#(tlp3667 ...) (tlp3668 ..3) _))
+           tlp3669
+           (tlp3670 __3)
+           tlp3671)
+          `(#(#(symbols #t (+ 1 2))
+              ((+ 4 (+ 1 1)) symbols (+ 1 2))
+              14
+              #&(#(1 #t #\d) (are 6 #\c) (+ 1 2)))
+            #\b
+            (symbols #f #\a)
+            #\a))
+        (list tlp3663 tlp3664 tlp3665 tlp3667 tlp3668 tlp3669 tlp3670 tlp3671))
+      '((symbols #t (+ 1 2))
+        ((+ 4 (+ 1 1)) symbols (+ 1 2))
+        14
+        (1 #t #\d)
+        (are 6 #\c)
+        #\b
+        (symbols #f #\a)
+        #\a))
+     (mytest
+      (let ()
+        (match-define
+          (#&(($
+               test-struct
+               #(tlp3672 ...)
+               tlp3673
+               (and (not (not #\c)) (not (not #\c)))
+               (tlp3674 tlp3675 tlp3676 . #\d))
+              tlp3678
+              (and (tlp3679 ...) (tlp3680 ...)))
+           _
+           tlp3681
+           tlp3682)
+          `(#&(,inst-struct-name3677 #\c (are (+ 1 2) (+ 1 2))) 1 3 #f))
+        (list
+         tlp3672
+         tlp3673
+         tlp3674
+         tlp3675
+         tlp3676
+         tlp3678
+         tlp3679
+         tlp3681
+         tlp3682))
+      '((#\b are #\b) #\a #\b #\c #\d #\c (are (+ 1 2) (+ 1 2)) 3 #f))
+     (mytest
+      (let ()
+        (match-define
+          (tlp3683
+            ((and #\d #\d) (or (tlp3684 __3) (tlp3684 __3)) () . #\d)
+            (and #(tlp3685 ___) #(tlp3686 ___))
+            (tlp3687 ___))
+          `((+ 1 2)
+            (#\d (symbols #\d #f) () . #\d)
+            #((+ 4 5) these #f)
+            ((+ 1 2) these symbols)))
+        (list tlp3683 tlp3684 tlp3685 tlp3687))
+      '((+ 1 2) (symbols #\d #f) ((+ 4 5) these #f) ((+ 1 2) these symbols)))
+     (mytest
+      (let ()
+        (match-define
+          (tlp3688
+            tlp3689
+            (#&((tlp3690 ___)
+                (and (? number? tlp3691) (? even? tlp3692))
+                (not (not #\c)))
+             (and (tlp3693 ...) (tlp3694 ...))
+             tlp3695
+             (not (not #f)))
+            #(tlp3696 ...))
+          `(#\b
+            (+ 4 (+ 1 1))
+            (#&((#f #\d 9) 10 #\c) (#\d #t #f) these #f)
+            #(#t #\c #f)))
+        (list tlp3688 tlp3689 tlp3690 tlp3691 tlp3693 tlp3695 tlp3696))
+      '(#\b (+ 4 (+ 1 1)) (#f #\d 9) 10 (#\d #t #f) these (#t #\c #f)))
+     (mytest
+      (let ()
+        (match-define
+          (($
+            test-struct
+            (not (not #\b))
+            tlp3697
+            #&(tlp3698 (tlp3699 ..3) tlp3700)
+            (or _ _))
+           (() #(tlp3702 ...) (and 'are 'are) . #\d)
+           #&(tlp3703
+               #((tlp3704 ___) (tlp3705 ...) (tlp3706 ___) #(tlp3707 ...))
+               (($ test-struct tlp3708 tlp3709 tlp3710 tlp3711)
+                #t
+                ()
+                (tlp3713 __3)))
+           #(tlp3714 ___))
+          `(,inst-struct-name3701
+            (() #(0 #\a (+ 4 5)) are . #\d)
+            #&((+ 1 2)
+               #((2 (+ 4 (+ 1 1)) #\d)
+                 (#\b 0 (+ 4 (+ 1 1)))
+                 ((+ 4 5) symbols #\d)
+                 #(4 #\a are))
+               (,inst-struct-name3712 #t () (#\c 5 0)))
+            #(#f #\d #\a)))
+        (list
+         tlp3697
+         tlp3698
+         tlp3699
+         tlp3700
+         tlp3702
+         tlp3703
+         tlp3704
+         tlp3705
+         tlp3706
+         tlp3707
+         tlp3708
+         tlp3709
+         tlp3710
+         tlp3711
+         tlp3713
+         tlp3714))
+      '(9
+        #\c
+        (#f #\d (+ 1 2))
+        are
+        (0 #\a (+ 4 5))
+        (+ 1 2)
+        (2 (+ 4 (+ 1 1)) #\d)
+        (#\b 0 (+ 4 (+ 1 1)))
+        ((+ 4 5) symbols #\d)
+        (4 #\a are)
+        #\d
+        #\d
+        (+ 4 (+ 1 1))
+        are
+        (#\c 5 0)
+        (#f #\d #\a)))))
+(define-tests)
+
+(define (sing-match-tests)
+    (list
+     (let ((tlp3719
+             (lambda (tlp3715)
+               (match
+                tlp3715
+                ((3
+                  (and (? number? tlp3716) (? even? tlp3717))
+                  (and #f #f)
+                  (or #(tlp3718 ___) #(tlp3718 ___)))
+                 (list tlp3716 tlp3718))))))
+       (list
+        (mytest (tlp3719 `(3 2 #f #((+ 1 2) are #\a))) '(2 ((+ 1 2) are #\a)))))
+     (let ((tlp3733
+             (lambda (tlp3720)
+               (match
+                tlp3720
+                ((tlp3721
+                   tlp3722
+                   (or ((and (? number? tlp3723) (? even? tlp3724))
+                        tlp3725
+                        ()
+                        #(tlp3726
+                          (tlp3727 tlp3728 tlp3729 tlp3730)
+                          ()
+                          tlp3731))
+                       ((and (? number? tlp3723) (? even? tlp3724))
+                        tlp3725
+                        ()
+                        #(tlp3726
+                          (tlp3727 tlp3728 tlp3729 tlp3730)
+                          ()
+                          tlp3731)))
+                   (or tlp3732 tlp3732))
+                 (list
+                  tlp3721
+                  tlp3722
+                  tlp3723
+                  tlp3725
+                  tlp3726
+                  tlp3727
+                  tlp3728
+                  tlp3729
+                  tlp3730
+                  tlp3731
+                  tlp3732))))))
+       (list
+        (mytest
+         (tlp3733
+           `(these
+             (+ 4 5)
+             (16
+              (+ 4 5)
+              ()
+              #(#f ((+ 4 (+ 1 1)) (+ 1 2) (+ 1 2) (+ 4 (+ 1 1))) () are))
+             #\c))
+         '(these
+           (+ 4 5)
+           16
+           (+ 4 5)
+           #f
+           (+ 4 (+ 1 1))
+           (+ 1 2)
+           (+ 1 2)
+           (+ 4 (+ 1 1))
+           are
+           #\c))))
+     (let ((tlp3824
+             (lambda (tlp3734)
+               (match
+                tlp3734
+                ((($
+                   test-struct
+                   (and (tlp3735 __3) (tlp3736 __3))
+                   tlp3737
+                   (and (? number? tlp3738) (? even? tlp3739))
+                   (and (? test-struct? tlp3754)
+                        (=
+                         test-struct-a
+                         (and (? test-struct? tlp3745)
+                              (= test-struct-a tlp3740)
+                              (= test-struct-b tlp3741)
+                              (= test-struct-c tlp3742)
+                              (= test-struct-d tlp3743)))
+                        (= test-struct-b (and #(tlp3746 ___) #(tlp3747 ___)))
+                        (= test-struct-c _)
+                        (=
+                         test-struct-d
+                         ($ test-struct tlp3748 tlp3749 tlp3750 tlp3751))))
+                  #t
+                  (and #((_
+                          (and tlp3756 tlp3757)
+                          (and (? test-struct? tlp3763)
+                               (= test-struct-a tlp3758)
+                               (= test-struct-b tlp3759)
+                               (= test-struct-c tlp3760)
+                               (= test-struct-d tlp3761))
+                          (not (not 'are)))
+                         _
+                         ($
+                          test-struct
+                          #&(tlp3764 tlp3765 tlp3766)
+                          #(tlp3767 tlp3768 tlp3769 tlp3770)
+                          tlp3771
+                          ($ test-struct tlp3772 tlp3773 tlp3774 tlp3775))
+                         _)
+                       #((_
+                          (and tlp3778 tlp3779)
+                          (and (? test-struct? tlp3780)
+                               (= test-struct-a tlp3781)
+                               (= test-struct-b tlp3782)
+                               (= test-struct-c tlp3783)
+                               (= test-struct-d tlp3784))
+                          (not (not 'are)))
+                         _
+                         ($
+                          test-struct
+                          #&(tlp3785 tlp3786 tlp3787)
+                          #(tlp3788 tlp3789 tlp3790 tlp3791)
+                          tlp3792
+                          ($ test-struct tlp3793 tlp3794 tlp3795 tlp3796))
+                         _))
+                  (and (? test-struct? tlp3823)
+                       (=
+                        test-struct-a
+                        (and (? test-struct? tlp3806)
+                             (=
+                              test-struct-a
+                              (and (and tlp3797 tlp3798)
+                                   (and tlp3799 tlp3800)))
+                             (= test-struct-b #&(tlp3801 tlp3802 tlp3803))
+                             (= test-struct-c (or '(+ 4 5) '(+ 4 5)))
+                             (= test-struct-d tlp3804)))
+                       (=
+                        test-struct-b
+                        #&(#&(tlp3807 tlp3808 tlp3809) #\c (tlp3810 ..3)))
+                       (= test-struct-c _)
+                       (=
+                        test-struct-d
+                        (and (? test-struct? tlp3821)
+                             (= test-struct-a tlp3811)
+                             (= test-struct-b (tlp3812 ...))
+                             (=
+                              test-struct-c
+                              (and (? test-struct? tlp3818)
+                                   (= test-struct-a tlp3813)
+                                   (= test-struct-b tlp3814)
+                                   (= test-struct-c tlp3815)
+                                   (= test-struct-d tlp3816)))
+                             (= test-struct-d #(tlp3819 ___))))))
+                 (list
+                  tlp3735
+                  tlp3737
+                  tlp3738
+                  tlp3740
+                  tlp3741
+                  tlp3742
+                  tlp3743
+                  tlp3746
+                  tlp3748
+                  tlp3749
+                  tlp3750
+                  tlp3751
+                  tlp3756
+                  tlp3758
+                  tlp3759
+                  tlp3760
+                  tlp3761
+                  tlp3764
+                  tlp3765
+                  tlp3766
+                  tlp3767
+                  tlp3768
+                  tlp3769
+                  tlp3770
+                  tlp3771
+                  tlp3772
+                  tlp3773
+                  tlp3774
+                  tlp3775
+                  tlp3797
+                  tlp3801
+                  tlp3802
+                  tlp3803
+                  tlp3804
+                  tlp3807
+                  tlp3808
+                  tlp3809
+                  tlp3810
+                  tlp3811
+                  tlp3812
+                  tlp3813
+                  tlp3814
+                  tlp3815
+                  tlp3816
+                  tlp3819))))))
+       (list
+        (mytest
+         (tlp3824
+           `(,inst-struct-name3755
+             #t
+             #((#f 8 ,inst-struct-name3762 are)
+               symbols
+               ,inst-struct-name3777
+               these)
+             ,inst-struct-name3822))
+         '((these 0 3)
+           (+ 4 5)
+           2
+           symbols
+           (+ 1 2)
+           symbols
+           #\b
+           (#\c #\d #\d)
+           #\b
+           #t
+           (+ 4 5)
+           #\b
+           8
+           these
+           (+ 1 2)
+           2
+           #\d
+           symbols
+           (+ 4 (+ 1 1))
+           (+ 1 2)
+           #\c
+           6
+           #\c
+           #t
+           #\b
+           #\b
+           #\b
+           symbols
+           these
+           #\d
+           (+ 1 2)
+           #\d
+           1
+           #\b
+           #f
+           (+ 4 (+ 1 1))
+           #\d
+           (#t #\c #f)
+           #\d
+           (2 (+ 4 (+ 1 1)) symbols)
+           1
+           (+ 1 2)
+           #\d
+           (+ 1 2)
+           ((+ 1 2) 8 (+ 4 5))))))
+     (let ((tlp3883
+             (lambda (tlp3825)
+               (match
+                tlp3825
+                ((#&(tlp3826
+                      tlp3827
+                      ((tlp3828 tlp3829 tlp3830 . #t)
+                       (tlp3831 __3)
+                       (tlp3832 tlp3833 tlp3834 quote these)
+                       .
+                       #\b))
+                  ()
+                  (and (? test-struct? tlp3857)
+                       (= test-struct-a #&(tlp3835 #\a tlp3836))
+                       (=
+                        test-struct-b
+                        (and ((tlp3837 __3)
+                              #t
+                              (and (? number? tlp3838) (? even? tlp3839))
+                              #(tlp3840 ...))
+                             ((tlp3841 __3)
+                              #t
+                              (and (? number? tlp3842) (? even? tlp3843))
+                              #(tlp3844 ...))))
+                       (= test-struct-c (#(tlp3845 ...) #t tlp3846 (or #f #f)))
+                       (=
+                        test-struct-d
+                        (or (and (? test-struct? tlp3855)
+                                 (= test-struct-a #\b)
+                                 (= test-struct-b _)
+                                 (=
+                                  test-struct-c
+                                  ($
+                                   test-struct
+                                   tlp3847
+                                   tlp3848
+                                   tlp3849
+                                   tlp3850))
+                                 (=
+                                  test-struct-d
+                                  (and (? number? tlp3852) (? even? tlp3853))))
+                            (and (? test-struct? tlp3855)
+                                 (= test-struct-a #\b)
+                                 (= test-struct-b _)
+                                 (=
+                                  test-struct-c
+                                  ($
+                                   test-struct
+                                   tlp3847
+                                   tlp3848
+                                   tlp3849
+                                   tlp3850))
+                                 (=
+                                  test-struct-d
+                                  (and (? number? tlp3852)
+                                       (? even? tlp3853)))))))
+                  (((tlp3858 tlp3859 tlp3860 quote these)
+                    #&(tlp3861 tlp3862 tlp3863)
+                    (not (not '(+ 4 (+ 1 1))))
+                    .
+                    #\a)
+                   (and (#(tlp3864 tlp3865 tlp3866 tlp3867)
+                         #(tlp3868 ...)
+                         '(+ 4 5)
+                         .
+                         #\d)
+                        (#(tlp3869 tlp3870 tlp3871 tlp3872)
+                         #(tlp3873 ...)
+                         '(+ 4 5)
+                         .
+                         #\d))
+                   (not (not #\b))
+                   #(tlp3874
+                     (not (not '(+ 1 2)))
+                     (tlp3875 tlp3876 tlp3877 tlp3878)
+                     (tlp3879 tlp3880 tlp3881 tlp3882))))
+                 (list
+                  tlp3826
+                  tlp3827
+                  tlp3828
+                  tlp3829
+                  tlp3830
+                  tlp3831
+                  tlp3832
+                  tlp3833
+                  tlp3834
+                  tlp3835
+                  tlp3836
+                  tlp3837
+                  tlp3838
+                  tlp3840
+                  tlp3845
+                  tlp3846
+                  tlp3847
+                  tlp3848
+                  tlp3849
+                  tlp3850
+                  tlp3852
+                  tlp3858
+                  tlp3859
+                  tlp3860
+                  tlp3861
+                  tlp3862
+                  tlp3863
+                  tlp3864
+                  tlp3865
+                  tlp3866
+                  tlp3867
+                  tlp3868
+                  tlp3874
+                  tlp3875
+                  tlp3876
+                  tlp3877
+                  tlp3878
+                  tlp3879
+                  tlp3880
+                  tlp3881
+                  tlp3882))))))
+       (list
+        (mytest
+         (tlp3883
+           `(#&(2
+                #\d
+                ((#t (+ 4 5) are . #t) (#t 8 #\a) (#\c 2 these . these) . #\b))
+             ()
+             ,inst-struct-name3856
+             (((#\a #\b (+ 1 2) . these) #&(8 are #\b) (+ 4 (+ 1 1)) . #\a)
+              (#((+ 1 2) these #\b #\c) #(these are #\d) (+ 4 5) . #\d)
+              #\b
+              #(#\b (+ 1 2) ((+ 4 (+ 1 1)) #\d #\d #\c) (2 are #\a #t)))))
+         '(2
+           #\d
+           #t
+           (+ 4 5)
+           are
+           (#t 8 #\a)
+           #\c
+           2
+           these
+           #t
+           symbols
+           ((+ 4 (+ 1 1)) (+ 4 5) #\b)
+           12
+           (these #\c #f)
+           (#\d these #\d)
+           7
+           #f
+           (+ 1 2)
+           #\a
+           #f
+           18
+           #\a
+           #\b
+           (+ 1 2)
+           8
+           are
+           #\b
+           (+ 1 2)
+           these
+           #\b
+           #\c
+           (these are #\d)
+           #\b
+           (+ 4 (+ 1 1))
+           #\d
+           #\d
+           #\c
+           2
+           are
+           #\a
+           #t))))
+     (let ((tlp3917
+             (lambda (tlp3884)
+               (match
+                tlp3884
+                (((and (? test-struct? tlp3903)
+                       (=
+                        test-struct-a
+                        (and (? test-struct? tlp3891)
+                             (= test-struct-a tlp3885)
+                             (=
+                              test-struct-b
+                              (tlp3886 tlp3887 tlp3888 tlp3889))
+                             (= test-struct-c (not (not #\d)))
+                             (= test-struct-d _)))
+                       (= test-struct-b '(+ 4 5))
+                       (= test-struct-c ())
+                       (=
+                        test-struct-d
+                        #((tlp3892 tlp3893 tlp3894 tlp3895)
+                          (and (? test-struct? tlp3901)
+                               (= test-struct-a tlp3896)
+                               (= test-struct-b tlp3897)
+                               (= test-struct-c tlp3898)
+                               (= test-struct-d tlp3899))
+                          _
+                          (or () ()))))
+                  (tlp3904 ..3)
+                  (tlp3905 ...)
+                  #((tlp3906 ...)
+                    ((tlp3907 ..3) (tlp3908 tlp3909 tlp3910 . #\d) 5 quote are)
+                    (tlp3911
+                      (and (? number? tlp3912) (? even? tlp3913))
+                      (tlp3914 ...)
+                      .
+                      #\d)
+                    (tlp3915 #\b #(tlp3916 ...) ())))
+                 (list
+                  tlp3885
+                  tlp3886
+                  tlp3887
+                  tlp3888
+                  tlp3889
+                  tlp3892
+                  tlp3893
+                  tlp3894
+                  tlp3895
+                  tlp3896
+                  tlp3897
+                  tlp3898
+                  tlp3899
+                  tlp3904
+                  tlp3905
+                  tlp3906
+                  tlp3907
+                  tlp3908
+                  tlp3909
+                  tlp3910
+                  tlp3911
+                  tlp3912
+                  tlp3914
+                  tlp3915
+                  tlp3916))))))
+       (list
+        (mytest
+         (tlp3917
+           `(,inst-struct-name3902
+             (these (+ 4 (+ 1 1)) symbols)
+             (#\b #\c 7)
+             #((these #\a #\d)
+               ((#t #\d 9) ((+ 4 5) (+ 4 5) 6 . #\d) 5 . are)
+               (#\b 4 (#\a symbols #\c) . #\d)
+               ((+ 4 (+ 1 1)) #\b #(#t #\d 8) ()))))
+         '(#f
+           #t
+           #f
+           are
+           symbols
+           #\a
+           7
+           #\b
+           (+ 1 2)
+           (+ 4 (+ 1 1))
+           0
+           #\d
+           0
+           (these (+ 4 (+ 1 1)) symbols)
+           (#\b #\c 7)
+           (these #\a #\d)
+           (#t #\d 9)
+           (+ 4 5)
+           (+ 4 5)
+           6
+           #\b
+           4
+           (#\a symbols #\c)
+           (+ 4 (+ 1 1))
+           (#t #\d 8)))))))
+(sing-match-tests)
+
+(define (sing-match-lambda*-tests)
+    (list
+     (let ((tlp4986
+             (match-lambda*
+               ((tlp4984 'these (not (not #\b)) tlp4985)
+                (list tlp4984 tlp4985)))))
+       (list (mytest (tlp4986 `3 `these `#\b `symbols) '(3 symbols))))
+     (let ((tlp5001
+             (match-lambda*
+               ((_
+                 #(tlp4988 ...)
+                 tlp4989
+                 #&((not (not '(+ 4 (+ 1 1))))
+                    ($
+                     test-struct
+                     (tlp4990 tlp4991 tlp4992 . 4)
+                     ($ test-struct tlp4993 tlp4994 tlp4995 tlp4996)
+                     tlp4998
+                     #t)
+                    tlp5000))
+                (list
+                 tlp4988
+                 tlp4989
+                 tlp4990
+                 tlp4991
+                 tlp4992
+                 tlp4993
+                 tlp4994
+                 tlp4995
+                 tlp4996
+                 tlp4998
+                 tlp5000)))))
+       (list
+        (mytest
+         (tlp5001
+           `(+ 1 2)
+           `#(#t #\b #\d)
+           `#\d
+           `#&((+ 4 (+ 1 1)) ,inst-struct-name4999 1))
+         '((#t #\b #\d)
+           #\d
+           (+ 1 2)
+           #t
+           (+ 4 (+ 1 1))
+           (+ 1 2)
+           #\d
+           these
+           #\d
+           9
+           1))))
+     (let ((tlp5004
+             (match-lambda*
+               ((#\b (and () ()) '(+ 4 (+ 1 1)) tlp5003) (list tlp5003)))))
+       (list (mytest (tlp5004 `#\b `() `(+ 4 (+ 1 1)) `(+ 4 5)) '((+ 4 5)))))
+     (let ((tlp5014
+             (match-lambda*
+               ((#(tlp5006 ...)
+                 _
+                 #((tlp5007 ..3)
+                   #&((tlp5008 ___) _ (not (not #t)))
+                   tlp5009
+                   (tlp5010 #(tlp5011 ...) () ()))
+                 (and (? number? tlp5012) (? even? tlp5013)))
+                (list
+                 tlp5006
+                 tlp5007
+                 tlp5008
+                 tlp5009
+                 tlp5010
+                 tlp5011
+                 tlp5012)))))
+       (list
+        (mytest
+         (tlp5014
+           `#(#\b (+ 4 (+ 1 1)) #f)
+           `(+ 4 5)
+           `#((#\c #\d #\c)
+              #&((#\c #\c #\a) are #t)
+              #\c
+              (#\c #(these 3 #\c) () ()))
+           `6)
+         '((#\b (+ 4 (+ 1 1)) #f)
+           (#\c #\d #\c)
+           (#\c #\c #\a)
+           #\c
+           #\c
+           (these 3 #\c)
+           6))))
+     (let ((tlp5045
+             (match-lambda*
+               (((and (((and (? number? tlp5016) (? even? tlp5017)) () #\a ())
+                       (and (? number? tlp5018) (? even? tlp5019))
+                       ()
+                       tlp5020)
+                      (((and (? number? tlp5021) (? even? tlp5022)) () #\a ())
+                       (and (? number? tlp5023) (? even? tlp5024))
+                       ()
+                       tlp5025))
+                 (or (not (not 'are)) (not (not 'are)))
+                 tlp5026
+                 (($
+                   test-struct
+                   _
+                   (or ($ test-struct tlp5027 tlp5028 tlp5029 tlp5030)
+                       ($ test-struct tlp5027 tlp5028 tlp5029 tlp5030))
+                   (or (tlp5032 __3) (tlp5032 __3))
+                   (tlp5033 tlp5034 tlp5035 tlp5036))
+                  (and (? test-struct? tlp5041)
+                       (= test-struct-a '(+ 1 2))
+                       (= test-struct-b tlp5038)
+                       (= test-struct-c (tlp5039 ___))
+                       (= test-struct-d 'are))
+                  tlp5042
+                  (or (and (? number? tlp5043) (? even? tlp5044))
+                      (and (? number? tlp5043) (? even? tlp5044)))))
+                (list
+                 tlp5016
+                 tlp5018
+                 tlp5020
+                 tlp5026
+                 tlp5027
+                 tlp5028
+                 tlp5029
+                 tlp5030
+                 tlp5032
+                 tlp5033
+                 tlp5034
+                 tlp5035
+                 tlp5036
+                 tlp5038
+                 tlp5039
+                 tlp5042
+                 tlp5043)))))
+       (list
+        (mytest
+         (tlp5045
+           `((10 () #\a ()) 0 () #f)
+           `are
+           `2
+           `(,inst-struct-name5037 ,inst-struct-name5040 are 16))
+         '(10
+           0
+           #f
+           2
+           #f
+           #\b
+           #\c
+           are
+           (7 2 (+ 1 2))
+           (+ 1 2)
+           (+ 4 (+ 1 1))
+           are
+           these
+           symbols
+           (7 0 #t)
+           are
+           16))))))
+(sing-match-lambda*-tests)
+
+(define (sing-match-lambda-tests)
+    (list
+     (let ((tlp4450
+             (match-lambda
+               (((not (not 'are))
+                 (tlp4432
+                   (tlp4433 (tlp4434 ...) tlp4435 quote symbols)
+                   (not (not 2))
+                   quote
+                   symbols)
+                 (not (not #\a))
+                 ((and (? test-struct? tlp4445)
+                       (= test-struct-a (tlp4436 tlp4437 tlp4438 . 9))
+                       (=
+                        test-struct-b
+                        (and (and tlp4439 tlp4440) (and tlp4441 tlp4442)))
+                       (= test-struct-c '(+ 1 2))
+                       (= test-struct-d (tlp4443 ___)))
+                  tlp4446
+                  ('these tlp4447 (tlp4448 ..3) quote these)
+                  (tlp4449 ___)))
+                (list
+                 tlp4432
+                 tlp4433
+                 tlp4434
+                 tlp4435
+                 tlp4436
+                 tlp4437
+                 tlp4438
+                 tlp4439
+                 tlp4443
+                 tlp4446
+                 tlp4447
+                 tlp4448
+                 tlp4449)))))
+       (list
+        (mytest
+         (tlp4450
+           `(are
+             (symbols ((+ 1 2) (#f (+ 4 5) (+ 4 5)) #t . symbols) 2 . symbols)
+             #\a
+             (,inst-struct-name4444
+              7
+              (these (+ 4 5) (9 (+ 4 5) #\d) . these)
+              (#t #f #\b))))
+         '(symbols
+            (+ 1 2)
+            (#f (+ 4 5) (+ 4 5))
+            #t
+            #\b
+            (+ 1 2)
+            are
+            (+ 1 2)
+            (#\c (+ 1 2) #\d)
+            7
+            (+ 4 5)
+            (9 (+ 4 5) #\d)
+            (#t #f #\b)))))
+     (let ((tlp4473
+             (match-lambda
+               ((tlp4451
+                  tlp4452
+                  (and (? test-struct? tlp4471)
+                       (=
+                        test-struct-a
+                        (and (? test-struct? tlp4461)
+                             (= test-struct-a #&(tlp4453 tlp4454 tlp4455))
+                             (= test-struct-b (tlp4456 ...))
+                             (=
+                              test-struct-c
+                              (tlp4457 tlp4458 tlp4459 quote symbols))
+                             (= test-struct-d '(+ 4 5))))
+                       (=
+                        test-struct-b
+                        (and (? number? tlp4462) (? even? tlp4463)))
+                       (= test-struct-c tlp4464)
+                       (=
+                        test-struct-d
+                        (or (()
+                             tlp4465
+                             (tlp4466 tlp4467 tlp4468 tlp4469)
+                             .
+                             #\b)
+                            (()
+                             tlp4465
+                             (tlp4466 tlp4467 tlp4468 tlp4469)
+                             .
+                             #\b))))
+                  tlp4472)
+                (list
+                 tlp4451
+                 tlp4452
+                 tlp4453
+                 tlp4454
+                 tlp4455
+                 tlp4456
+                 tlp4457
+                 tlp4458
+                 tlp4459
+                 tlp4462
+                 tlp4464
+                 tlp4465
+                 tlp4466
+                 tlp4467
+                 tlp4468
+                 tlp4469
+                 tlp4465
+                 tlp4466
+                 tlp4467
+                 tlp4468
+                 tlp4469
+                 tlp4472)))))
+       (list
+        (mytest
+         (tlp4473 `(#f #\a ,inst-struct-name4470 5))
+         '(#f
+           #\a
+           #t
+           (+ 4 5)
+           #\c
+           (1 #\c 1)
+           #f
+           (+ 4 5)
+           #\a
+           10
+           #t
+           #\d
+           #f
+           #\d
+           #\c
+           are
+           #\d
+           #f
+           #\d
+           #\c
+           are
+           5))))
+     (let ((tlp4520
+             (match-lambda
+               ((((and (#(tlp4474 tlp4475 tlp4476 tlp4477)
+                        #(tlp4478 tlp4479 tlp4480 tlp4481)
+                        ()
+                        (or tlp4482 tlp4482))
+                       (#(tlp4483 tlp4484 tlp4485 tlp4486)
+                        #(tlp4487 tlp4488 tlp4489 tlp4490)
+                        ()
+                        (or tlp4491 tlp4491)))
+                  (and (? number? tlp4492) (? even? tlp4493))
+                  ('(+ 1 2) (tlp4494 ...) tlp4495 tlp4496)
+                  .
+                  #f)
+                 (and (? test-struct? tlp4517)
+                      (=
+                       test-struct-a
+                       (or #&((and (? test-struct? tlp4502)
+                                   (= test-struct-a tlp4497)
+                                   (= test-struct-b tlp4498)
+                                   (= test-struct-c tlp4499)
+                                   (= test-struct-d tlp4500))
+                              ()
+                              #(tlp4503 tlp4504 tlp4505 tlp4506))
+                           #&((and (? test-struct? tlp4502)
+                                   (= test-struct-a tlp4497)
+                                   (= test-struct-b tlp4498)
+                                   (= test-struct-c tlp4499)
+                                   (= test-struct-d tlp4500))
+                              ()
+                              #(tlp4503 tlp4504 tlp4505 tlp4506))))
+                      (=
+                       test-struct-b
+                       (and ((tlp4507 ___)
+                             (and (? number? tlp4508) (? even? tlp4509))
+                             (tlp4510 __3)
+                             quote
+                             these)
+                            ((tlp4511 ___)
+                             (and (? number? tlp4512) (? even? tlp4513))
+                             (tlp4514 __3)
+                             quote
+                             these)))
+                      (= test-struct-c (or (tlp4515 ..3) (tlp4515 ..3)))
+                      (= test-struct-d ()))
+                 tlp4518
+                 tlp4519)
+                (list
+                 tlp4474
+                 tlp4475
+                 tlp4476
+                 tlp4477
+                 tlp4478
+                 tlp4479
+                 tlp4480
+                 tlp4481
+                 tlp4482
+                 tlp4492
+                 tlp4494
+                 tlp4495
+                 tlp4496
+                 tlp4497
+                 tlp4498
+                 tlp4499
+                 tlp4500
+                 tlp4503
+                 tlp4504
+                 tlp4505
+                 tlp4506
+                 tlp4507
+                 tlp4508
+                 tlp4510
+                 tlp4515
+                 tlp4518
+                 tlp4519)))))
+       (list
+        (mytest
+         (tlp4520
+           `(((#(#\c #\c 0 (+ 4 (+ 1 1))) #(#f 9 8 #\a) () #t)
+              10
+              ((+ 1 2) ((+ 4 5) symbols (+ 4 (+ 1 1))) #f 3)
+              .
+              #f)
+             ,inst-struct-name4516
+             (+ 1 2)
+             5))
+         '(#\c
+           #\c
+           0
+           (+ 4 (+ 1 1))
+           #f
+           9
+           8
+           #\a
+           #t
+           10
+           ((+ 4 5) symbols (+ 4 (+ 1 1)))
+           #f
+           3
+           #\b
+           8
+           are
+           #\a
+           #\b
+           #\b
+           #t
+           #t
+           (#\b #\c #t)
+           0
+           ((+ 4 5) #t these)
+           (#\a #\b 0)
+           (+ 1 2)
+           5))))
+     (let ((tlp4526
+             (match-lambda
+               (((and (? number? tlp4521) (? even? tlp4522))
+                 (or tlp4523 tlp4523)
+                 tlp4524
+                 (tlp4525 ...))
+                (list tlp4521 tlp4523 tlp4524 tlp4525)))))
+       (list
+        (mytest
+         (tlp4526 `(4 #\a (+ 4 (+ 1 1)) (are symbols #\c)))
+         '(4 #\a (+ 4 (+ 1 1)) (are symbols #\c)))))
+     (let ((tlp4561
+             (match-lambda
+               (((tlp4527 __3)
+                 ((and (? test-struct? tlp4540)
+                       (=
+                        test-struct-a
+                        (and ($ test-struct tlp4528 tlp4529 tlp4530 tlp4531)
+                             ($ test-struct tlp4533 tlp4534 tlp4535 tlp4536)))
+                       (= test-struct-b (tlp4537 ..3))
+                       (= test-struct-c #\d)
+                       (= test-struct-d #(tlp4538 ...)))
+                  (and (? test-struct? tlp4556)
+                       (= test-struct-a (not (not #\b)))
+                       (=
+                        test-struct-b
+                        (and #(tlp4541 tlp4542 tlp4543 tlp4544)
+                             #(tlp4545 tlp4546 tlp4547 tlp4548)))
+                       (= test-struct-c #(tlp4549 ...))
+                       (=
+                        test-struct-d
+                        ($ test-struct tlp4550 tlp4551 tlp4552 tlp4553)))
+                  #&((and (tlp4557 __3) (tlp4558 __3)) tlp4559 (not (not 4)))
+                  tlp4560)
+                 ()
+                 (or 'these 'these))
+                (list
+                 tlp4527
+                 tlp4528
+                 tlp4529
+                 tlp4530
+                 tlp4531
+                 tlp4537
+                 tlp4538
+                 tlp4541
+                 tlp4542
+                 tlp4543
+                 tlp4544
+                 tlp4549
+                 tlp4550
+                 tlp4551
+                 tlp4552
+                 tlp4553
+                 tlp4557
+                 tlp4559
+                 tlp4560)))))
+       (list
+        (mytest
+         (tlp4561
+           `((4 2 #f)
+             (,inst-struct-name4539
+              ,inst-struct-name4555
+              #&((symbols are these) 6 4)
+              2)
+             ()
+             these))
+         '((4 2 #f)
+           (+ 4 (+ 1 1))
+           #\c
+           #f
+           #\c
+           (#f 9 symbols)
+           (are #f are)
+           #\c
+           #\b
+           #f
+           (+ 4 5)
+           (#f 5 #\a)
+           #f
+           #\b
+           (+ 4 5)
+           these
+           (symbols are these)
+           6
+           2))))))
+(sing-match-lambda-tests)
+
+  (define-struct test-struct (a b c d))
+  (define inst-struct-name782 (make-test-struct `#\d `9 `6 `#\c))
+  (define inst-struct-name788 (make-test-struct `(+ 4 5) `#\d `0 `are))
+  (define inst-struct-name793 (make-test-struct `(+ 4 (+ 1 1)) `#\b `#\c `3))
+  (define inst-struct-name810 (make-test-struct `#f `8 `#\d `(+ 4 (+ 1 1))))
+  (define inst-struct-name816 (make-test-struct `6 `4 `#f `#\b))
+  (define inst-struct-name818
+    (make-test-struct `symbols `() `,inst-struct-name816 `()))
+  (define inst-struct-name830 (make-test-struct `#\d `#\b `#t `6))
+  (define inst-struct-name836
+    (make-test-struct `are `,inst-struct-name830 `(9 are 6 2) `#\d))
+  (define inst-struct-name841 (make-test-struct `#f `are `symbols `7))
+  (define inst-struct-name862 (make-test-struct `#t `#t `9 `(+ 4 (+ 1 1))))
+  (define inst-struct-name876 (make-test-struct `3 `6 `#f `#\d))
+  (define inst-struct-name882
+    (make-test-struct
+      `(#\c (+ 4 (+ 1 1)) (+ 4 (+ 1 1)))
+      `(6 #f 4 . #\c)
+      `,inst-struct-name876
+      `(#\c #\a 9 #\a)))
+  (define inst-struct-name888 (make-test-struct `symbols `symbols `#\c `#f))
+  (define inst-struct-name891
+    (make-test-struct `(+ 1 2) `,inst-struct-name888 `#\d `#f))
+  (define inst-struct-name903
+    (make-test-struct `#\c `(#f #f symbols) `14 `#(are #\b #f)))
+  (define inst-struct-name925
+    (make-test-struct `are `(+ 4 (+ 1 1)) `0 `(#t (+ 4 (+ 1 1)) #t)))
+  (define inst-struct-name928
+    (make-test-struct
+      `(((+ 1 2) (+ 4 (+ 1 1)) are) these these (#t #\b #\d))
+      `,inst-struct-name925
+      `#f
+      `#\c))
+  (define inst-struct-name941 (make-test-struct `these `(+ 1 2) `6 `#\d))
+  (define inst-struct-name952 (make-test-struct `#f `#t `8 `(+ 4 (+ 1 1))))
+  (define inst-struct-name958 (make-test-struct `#f `#\a `#\b `#\a))
+  (define inst-struct-name981
+    (make-test-struct `symbols `#\a `(+ 1 2) `(+ 1 2)))
+  (define inst-struct-name991 (make-test-struct `#\b `#\c `(+ 4 5) `#\d))
+  (define inst-struct-name1004
+    (make-test-struct `#t `#\b `#\a `((+ 4 (+ 1 1)) #t #\d)))
+  (define inst-struct-name1022
+    (make-test-struct `(#\b #f #t + 4 (+ 1 1)) `() `(#t #\b #\b) `12))
+  (define inst-struct-name1030
+    (make-test-struct `2 `these `#(#\d symbols #\a #\c) `3))
+  (define inst-struct-name1032
+    (make-test-struct `#\b `6 `,inst-struct-name1022 `,inst-struct-name1030))
+  (define inst-struct-name1043 (make-test-struct `#\d `6 `8 `(+ 1 2)))
+  (define inst-struct-name1048
+    (make-test-struct `#\b `(+ 1 2) `#\b `(+ 4 (+ 1 1))))
+  (define inst-struct-name1050
+    (make-test-struct
+      `(+ 4 5)
+      `#f
+      `,inst-struct-name1043
+      `,inst-struct-name1048))
+  (define inst-struct-name1069 (make-test-struct `#\b `(+ 1 2) `8 `symbols))
+  (define inst-struct-name1071
+    (make-test-struct `are `symbols `#t `,inst-struct-name1069))
+  (define inst-struct-name1080
+    (make-test-struct `#&(#\d 6 (+ 4 (+ 1 1))) `#t `0 `(#\d #\d (+ 4 5))))
+  (define inst-struct-name1087 (make-test-struct `symbols `#t `#\d `(+ 1 2)))
+  (define inst-struct-name1091
+    (make-test-struct
+      `,inst-struct-name1071
+      `,inst-struct-name1080
+      `#(6 ,inst-struct-name1087 #\c #f)
+      `0))
+  (define inst-struct-name1099 (make-test-struct `8 `() `#(#\d (+ 1 2) 9) `()))
+  (define inst-struct-name1106
+    (make-test-struct
+      `(#\c 5 #\a . 8)
+      `(+ 4 (+ 1 1))
+      `(+ 4 (+ 1 1))
+      `(+ 4 (+ 1 1))))
+  (define inst-struct-name1118
+    (make-test-struct
+      `((+ 4 (+ 1 1)) these #\d #\a)
+      `,inst-struct-name1106
+      `#\a
+      `#&((are #\c #t (+ 4 5)) (#\b 0 #\c) (1 are (+ 1 2) (+ 4 (+ 1 1))))))
+  (define inst-struct-name1125 (make-test-struct `#\b `(+ 4 5) `#\c `these))
+  (define inst-struct-name1139
+    (make-test-struct
+      `#t
+      `(#t #\c these . 9)
+      `#\a
+      `#(9 (+ 4 (+ 1 1)) #t (+ 1 2))))
+  (define inst-struct-name1141
+    (make-test-struct
+      `(() these ,inst-struct-name1125 #(6 1 5 #\c))
+      `,inst-struct-name1139
+      `()
+      `5))
+  (define inst-struct-name1156
+    (make-test-struct
+      `((#t 5 9 5) #(symbols symbols these) 14 (are these are))
+      `2
+      `(((+ 4 (+ 1 1)) these #f) #((+ 4 (+ 1 1)) #t #\b) symbols . 0)
+      `are))
+  (define inst-struct-name1161 (make-test-struct `#\d `#\c `these `1))
+  (define inst-struct-name1174 (make-test-struct `#f `(+ 4 5) `#\d `#f))
+  (define inst-struct-name1187
+    (make-test-struct `,inst-struct-name1174 `#\c `#\c `#&(symbols 2 #\a)))
+  (define inst-struct-name1198
+    (make-test-struct
+      `(#\d #\b #t)
+      `#(#f (+ 4 5) symbols (+ 1 2))
+      `#f
+      `#&(#\d 8 3)))
+  (define inst-struct-name1221
+    (make-test-struct `#\c `4 `() `(#\d #\c #\c . #\d)))
+  (define inst-struct-name1229
+    (make-test-struct `#\c `(+ 4 (+ 1 1)) `these `#f))
+  (define inst-struct-name1230
+    (make-test-struct `() `#(#\b 0 (+ 4 5)) `#\b `,inst-struct-name1229))
+  (define inst-struct-name1232
+    (make-test-struct
+      `#((+ 1 2) #\a 2)
+      `,inst-struct-name1221
+      `#&(() (+ 1 2) ())
+      `,inst-struct-name1230))
+  (define inst-struct-name1238
+    (make-test-struct `(#f #\c #\c) `#\b `() `(#\d these these)))
+  (define inst-struct-name1254
+    (make-test-struct `#\b `(+ 4 (+ 1 1)) `#f `(+ 4 5)))
+  (define inst-struct-name1260
+    (make-test-struct
+      `#&(are #\c #t)
+      `(9 these #\d)
+      `,inst-struct-name1254
+      `(are #\b (+ 1 2) 3)))
+  (define inst-struct-name1266 (make-test-struct `#t `#\b `#t `#\b))
+  (define inst-struct-name1279 (make-test-struct `#\d `#\c `#\a `#t))
+  (define inst-struct-name1312
+    (make-test-struct `these `#f `#(#\b #\c 2 #f) `1))
+  (define inst-struct-name1316
+    (make-test-struct `,inst-struct-name1312 `#t `#\d `(+ 1 2)))
+  (define inst-struct-name1325 (make-test-struct `these `#\a `#t `these))
+  (define inst-struct-name1340
+    (make-test-struct `(+ 4 5) `#\c `symbols `(+ 1 2)))
+  (define inst-struct-name1342
+    (make-test-struct
+      `#t
+      `#(,inst-struct-name1325
+         (4 (+ 4 5) #\a)
+         (#\d symbols #\b)
+         #(#\c #\c #\b #t))
+      `((#\c symbols (+ 4 (+ 1 1)) . #\a) #f 3 ,inst-struct-name1340)
+      `#(8 9 1)))
+  (define inst-struct-name1351
+    (make-test-struct
+      `(these #\a #t)
+      `4
+      `(#\c (0 #t #\b) #\c #t)
+      `(#\a these (+ 1 2))))
+  (define inst-struct-name1364
+    (make-test-struct `#f `symbols `(+ 1 2) `symbols))
+  (define inst-struct-name1367
+    (make-test-struct
+      `(#\b symbols #\b . 5)
+      `(#\b 7 #\a)
+      `,inst-struct-name1364
+      `these))
+  (define inst-struct-name1383 (make-test-struct `#t `#\d `#\a `#f))
+  (define inst-struct-name1403 (make-test-struct `(+ 1 2) `#\c `#\b `#\d))
+  (define inst-struct-name1409
+    (make-test-struct
+      `(#\a (+ 4 5) #\b)
+      `1
+      `,inst-struct-name1403
+      `(#\a 1 #\c . are)))
+  (define inst-struct-name1439
+    (make-test-struct `(#t 8 #f) `#(#\a are 3) `#\d `are))
+  (define inst-struct-name1460 (make-test-struct `#f `#\d `5 `#\b))
+  (define inst-struct-name1466
+    (make-test-struct
+      `(#\a 4 #t)
+      `((#\a (+ 1 2) 7 . #\d) () 0 . #t)
+      `((#f #\a #\b . #\a)
+        are
+        (2 symbols #f + 4 (+ 1 1))
+        ,inst-struct-name1460)
+      `#&(2 #\b #\b)))
+  (define inst-struct-name1502
+    (make-test-struct `#\c `() `#&(2 are 8) `#(these #\c #\a #\a)))
+  (define inst-struct-name1508
+    (make-test-struct `#\c `#\d `(#t (+ 4 (+ 1 1)) #\c . symbols) `()))
+  (define inst-struct-name1519 (make-test-struct `#t `#\b `#\d `6))
+  (define inst-struct-name1534 (make-test-struct `these `#\b `#\c `are))
+  (define inst-struct-name1536
+    (make-test-struct
+      `(#\d #f 0 . #\d)
+      `(are are #\c . #\b)
+      `(+ 1 2)
+      `,inst-struct-name1534))
+  (define inst-struct-name1538
+    (make-test-struct
+      `,inst-struct-name1519
+      `2
+      `,inst-struct-name1536
+      `(+ 4 5)))
+  (define inst-struct-name1543 (make-test-struct `2 `3 `#\d `(+ 4 5)))
+  (define inst-struct-name1561 (make-test-struct `#f `symbols `#\b `#t))
+  (define inst-struct-name1563
+    (make-test-struct `(+ 4 (+ 1 1)) `,inst-struct-name1561 `(+ 4 5) `3))
+  (define inst-struct-name1572 (make-test-struct `(+ 1 2) `#\a `#\b `#\d))
+  (define inst-struct-name1577 (make-test-struct `#\b `#\b `#\b `4))
+  (define inst-struct-name1594 (make-test-struct `#f `are `#\b `#f))
+  (define inst-struct-name1609
+    (make-test-struct
+      `(symbols (+ 1 2) #\d)
+      `(#\c symbols are)
+      `(are are #\c (+ 1 2))
+      `(symbols #\d (+ 1 2) . #\b)))
+  (define inst-struct-name1619 (make-test-struct `#t `(+ 4 (+ 1 1)) `#\c `#t))
+  (define inst-struct-name1635
+    (make-test-struct `#\b `#\d `(+ 4 (+ 1 1)) `#\c))
+  (define inst-struct-name1663 (make-test-struct `#f `#\a `#f `(+ 1 2)))
+  (define inst-struct-name1666
+    (make-test-struct
+      `(#\c these symbols . #f)
+      `(4 5 #f)
+      `,inst-struct-name1663
+      `(#f (+ 4 5) (+ 4 5))))
+  (define inst-struct-name1687 (make-test-struct `symbols `are `1 `are))
+  (define inst-struct-name1701
+    (make-test-struct
+      `#(#(these #\d these symbols) (are 6 these) #\c #\d)
+      `#(#f 8 (+ 4 5))
+      `(#\b are symbols)
+      `#\b))
+  (define inst-struct-name1708
+    (make-test-struct
+      `(+ 1 2)
+      `#(() #&((+ 4 5) #\a #f) () (+ 4 (+ 1 1)))
+      `#\b
+      `#\a))
+  (define inst-struct-name1719
+    (make-test-struct `#&(#\d #t #t) `(+ 4 (+ 1 1)) `0 `(+ 4 (+ 1 1))))
+  (define inst-struct-name1741 (make-test-struct `these `#t `7 `#\b))
+  (define inst-struct-name1775
+    (make-test-struct `(8 #f #f (+ 4 (+ 1 1))) `(9 #\c #t) `#f `#t))
+  (define inst-struct-name1776
+    (make-test-struct
+      `symbols
+      `#(#\d #\c (+ 4 (+ 1 1)))
+      `#(symbols #\a #\d)
+      `,inst-struct-name1775))
+  (define inst-struct-name1786 (make-test-struct `0 `#\a `0 `#t))
+  (define inst-struct-name1796
+    (make-test-struct `3 `#(#\b #\c 0) `#t `(+ 4 5)))
+  (define inst-struct-name1797
+    (make-test-struct
+      `((these #t (+ 4 (+ 1 1)) . #\a)
+        ,inst-struct-name1786
+        (#\a #t 7)
+        #&(9 #\b symbols))
+      `(+ 4 5)
+      `,inst-struct-name1796
+      `(+ 4 (+ 1 1))))
+  (define inst-struct-name1813
+    (make-test-struct
+      `(symbols #\d #\b are)
+      `#(#\d (+ 4 (+ 1 1)) #f #\b)
+      `are
+      `()))
+  (define inst-struct-name1818
+    (make-test-struct
+      `#&(#\a (9 #\c symbols) #f)
+      `,inst-struct-name1813
+      `#&(8 () #\d)
+      `#(#\a these symbols)))
+  (define inst-struct-name1832 (make-test-struct `are `1 `() `(12 #\c #t . 4)))
+  (define inst-struct-name1873 (make-test-struct `#t `7 `#\b `(+ 4 5)))
+  (define inst-struct-name1876
+    (make-test-struct
+      `0
+      `#&(#f 0 these)
+      `,inst-struct-name1873
+      `(+ 4 (+ 1 1))))
+  (define inst-struct-name1896
+    (make-test-struct `#(5 (+ 1 2) these) `(+ 4 (+ 1 1)) `0 `#(#\a #\d these)))
+  (define inst-struct-name1900
+    (make-test-struct `0 `these `#(6 are symbols) `#((+ 4 5) #t 8)))
+  (define inst-struct-name1919
+    (make-test-struct `(+ 1 2) `#\b `#&((+ 1 2) #\a #t) `#\b))
+  (define inst-struct-name1935
+    (make-test-struct `#&(2 #\c #\c) `(#f 0 6 #f) `#&(1 #\a symbols) `#\b))
+  (define inst-struct-name1941 (make-test-struct `#\b `(+ 4 5) `#f `are))
+  (define inst-struct-name1947 (make-test-struct `(+ 4 (+ 1 1)) `#\d `5 `#\d))
+  (define inst-struct-name1948
+    (make-test-struct
+      `(+ 4 5)
+      `,inst-struct-name1941
+      `(1 #\b (+ 4 5))
+      `,inst-struct-name1947))
+  (define inst-struct-name1955 (make-test-struct `2 `5 `#\c `()))
+  (define inst-struct-name1962
+    (make-test-struct `#(#t are #\b #f) `#(#f #f (+ 4 5)) `#t `()))
+  (define inst-struct-name1975 (make-test-struct `(+ 1 2) `(+ 1 2) `#\c `#f))
+  (define inst-struct-name1977
+    (make-test-struct
+      `symbols
+      `symbols
+      `(+ 4 (+ 1 1))
+      `(#(2 (+ 4 5) #\b) are ,inst-struct-name1975 . 5)))
+  (define inst-struct-name1995 (make-test-struct `#\a `(+ 4 5) `8 `8))
+  (define inst-struct-name1996
+    (make-test-struct
+      `(#\c (+ 4 (+ 1 1)) 2 . #\a)
+      `(#\b #\c (+ 4 (+ 1 1)) . are)
+      `#\b
+      `,inst-struct-name1995))
+  (define inst-struct-name2013
+    (make-test-struct `18 `() `,inst-struct-name1996 `(are #\c symbols)))
+  (define inst-struct-name2041
+    (make-test-struct `(+ 1 2) `7 `#&(#\c #\d (+ 4 5)) `#t))
+  (define inst-struct-name2085
+    (make-test-struct `#(#t (+ 4 5) (+ 4 5) #t) `0 `#\c `(these these 7)))
+  (define inst-struct-name2093
+    (make-test-struct `(#\b 9 #\b) `16 `#\a `#((+ 1 2) 9 () 2)))
+  (define inst-struct-name2104
+    (make-test-struct `#\b `(symbols 1 (+ 4 5)) `12 `0))
+  (define inst-struct-name2110 (make-test-struct `#\a `#\a `these `symbols))
+  (define inst-struct-name2117
+    (make-test-struct
+      `,inst-struct-name2110
+      `#(#t 4 7)
+      `(+ 1 2)
+      `#(2 symbols (+ 4 (+ 1 1)) 5)))
+  (define inst-struct-name2125 (make-test-struct `#\c `(+ 4 (+ 1 1)) `#\c `2))
+  (define inst-struct-name2127
+    (make-test-struct
+      `(+ 4 5)
+      `()
+      `,inst-struct-name2117
+      `#(#&(are 6 #\c) ,inst-struct-name2125 9 ())))
+  (define inst-struct-name2133
+    (make-test-struct
+      `symbols
+      `#(#\b #\a #\d)
+      `((+ 4 5) #\d #\b . symbols)
+      `these))
+  (define inst-struct-name2138
+    (make-test-struct `0 `,inst-struct-name2133 `10 `#\d))
+  (define inst-struct-name2146 (make-test-struct `9 `#t `#t `(+ 4 5)))
+  (define inst-struct-name2153
+    (make-test-struct `#\c `symbols `(+ 4 (+ 1 1)) `#\a))
+  (define inst-struct-name2160
+    (make-test-struct
+      `(,inst-struct-name2146 #f 3 . #t)
+      `2
+      `#\c
+      `(,inst-struct-name2153 #f #&(7 0 2) . #\b)))
+  (define inst-struct-name2170 (make-test-struct `6 `8 `#f `(+ 4 (+ 1 1))))
+  (define inst-struct-name2188
+    (make-test-struct `#t `symbols `(+ 4 (+ 1 1)) `#t))
+  (define inst-struct-name2190
+    (make-test-struct
+      `#(7 #\a (these 9 (+ 1 2)) ())
+      `2
+      `#\b
+      `#(#(are #\a #\c) #\a ,inst-struct-name2188 #\d)))
+  (define inst-struct-name2202 (make-test-struct `are `#f `#t `are))
+  (define inst-struct-name2204
+    (make-test-struct `(+ 1 2) `6 `,inst-struct-name2202 `#\c))
+  (define inst-struct-name2211
+    (make-test-struct `#t `(+ 4 (+ 1 1)) `symbols `these))
+  (define inst-struct-name2215
+    (make-test-struct
+      `(+ 4 (+ 1 1))
+      `,inst-struct-name2211
+      `(#f 6 #\c)
+      `(#\b #\b 1)))
+  (define inst-struct-name2245
+    (make-test-struct `#\c `#\a `symbols `(+ 4 (+ 1 1))))
+  (define inst-struct-name2252 (make-test-struct `2 `5 `#t `2))
+  (define inst-struct-name2263
+    (make-test-struct
+      `#\a
+      `#(#\d symbols (+ 4 5))
+      `()
+      `((+ 1 2) (are #\b #\d) #\b . these)))
+  (define inst-struct-name2269
+    (make-test-struct `(symbols #\a #\a) `are `#f `()))
+  (define inst-struct-name2279
+    (make-test-struct
+      `#(#\a #\b symbols)
+      `#((+ 4 (+ 1 1)) #\d 2)
+      `#(#f #\b (+ 1 2))
+      `(these #\b are)))
+  (define inst-struct-name2305 (make-test-struct `#\c `() `#t `(#\c 0 9)))
+  (define inst-struct-name2310 (make-test-struct `#\b `() `symbols `18))
+  (define inst-struct-name2327 (make-test-struct `#\d `#f `these `3))
+  (define inst-struct-name2335 (make-test-struct `#f `#\c `#\d `2))
+  (define inst-struct-name2336
+    (make-test-struct `#\b `,inst-struct-name2335 `#\c `()))
+  (define inst-struct-name2354 (make-test-struct `(+ 1 2) `#\b `0 `#\d))
+  (define inst-struct-name2359 (make-test-struct `#\d `#f `(+ 4 (+ 1 1)) `#f))
+  (define inst-struct-name2370
+    (make-test-struct `#\d `#\c `(these 6 #\a (+ 1 2)) `()))
+  (define inst-struct-name2376 (make-test-struct `(+ 1 2) `1 `3 `#\a))
+  (define inst-struct-name2382
+    (make-test-struct
+      `,inst-struct-name2376
+      `(#\b (+ 4 5) (+ 1 2))
+      `18
+      `#(8 #\a (+ 4 5))))
+  (define inst-struct-name2388 (make-test-struct `#f `4 `3 `#t))
+  (define inst-struct-name2395
+    (make-test-struct
+      `,inst-struct-name2370
+      `,inst-struct-name2382
+      `#&((#\c #\c (+ 1 2)) ,inst-struct-name2388 (+ 4 5))
+      `14))
+  (define inst-struct-name2408
+    (make-test-struct
+      `#(#\d #f these symbols)
+      `10
+      `these
+      `((+ 4 (+ 1 1)) symbols (+ 4 5) . symbols)))
+  (define inst-struct-name2413
+    (make-test-struct `(0 #\b #\b) `#\a `symbols `2))
+  (define inst-struct-name2438
+    (make-test-struct
+      `#&((+ 4 (+ 1 1)) (+ 1 2) (+ 4 5))
+      `#f
+      `#((+ 4 (+ 1 1)) 9 #t #\c)
+      `6))
+  (define inst-struct-name2454
+    (make-test-struct `#(#\a symbols 8) `#\d `#f `#(1 #\c 4)))
+  (define inst-struct-name2465
+    (make-test-struct `() `#\b `symbols `#(#t (+ 4 5) #t #\d)))
+  (define inst-struct-name2469
+    (make-test-struct
+      `#\b
+      `,inst-struct-name2465
+      `#\d
+      `#&(#\b #(4 are 1) (+ 1 2))))
+  (define inst-struct-name2480
+    (make-test-struct
+      `#((+ 1 2) 7 are #\b)
+      `(#\b symbols #\d)
+      `(#\d symbols symbols)
+      `(+ 1 2)))
+
+  (define (multi-let-tests)
+    (list
+     (mytest
+      (match-let*
+        ((((or (and #\c #\c) (and #\c #\c))
+           (tlp963 __3)
+           (not (not #f))
+           ((and (or (tlp964 tlp965 tlp966 quote are)
+                     (tlp964 tlp965 tlp966 quote are))
+                 (or (tlp967 tlp968 tlp969 quote are)
+                     (tlp967 tlp968 tlp969 quote are)))
+            (tlp970 __3)
+            tlp971
+            tlp972))
+          `(#\c (#\d #f #\c) #f ((6 8 2 . are) ((+ 1 2) #t #\c) are #f)))
+         ((#&(((tlp973 tlp974 tlp975 quote symbols)
+               (not (not 'these))
+               tlp976
+               (and (? test-struct? tlp982)
+                    (= test-struct-a tlp977)
+                    (= test-struct-b tlp978)
+                    (= test-struct-c tlp979)
+                    (= test-struct-d tlp980)))
+              ((tlp983 tlp984 tlp985 tlp986)
+               (and (? test-struct? tlp992)
+                    (= test-struct-a tlp987)
+                    (= test-struct-b tlp988)
+                    (= test-struct-c tlp989)
+                    (= test-struct-d tlp990))
+               #(tlp993 tlp994 tlp995 tlp996)
+               #&(tlp997 tlp998 tlp999))
+              (or tlp1000 tlp1000))
+           (and (? test-struct? tlp1005)
+                (= test-struct-a #t)
+                (= test-struct-b (or tlp1001 tlp1001))
+                (= test-struct-c tlp1002)
+                (= test-struct-d (tlp1003 ...)))
+           (not (not 'these))
+           (tlp1006 ___))
+          `(#&(((symbols are these . symbols) these #\c ,inst-struct-name981)
+               ((#t #\a #\c (+ 1 2))
+                ,inst-struct-name991
+                #(#t are #\a #\d)
+                #&(#\a (+ 1 2) (+ 4 (+ 1 1))))
+               #\d)
+            ,inst-struct-name1004
+            these
+            (#\d symbols #t)))
+         ((()
+           (and (? test-struct? tlp1033)
+                (= test-struct-a tlp1007)
+                (= test-struct-b (and (? number? tlp1008) (? even? tlp1009)))
+                (=
+                 test-struct-c
+                 (and (? test-struct? tlp1023)
+                      (=
+                       test-struct-a
+                       (and (tlp1010 tlp1011 tlp1012 . tlp1013)
+                            (tlp1014 tlp1015 tlp1016 . tlp1017)))
+                      (= test-struct-b ())
+                      (= test-struct-c (and (tlp1018 ___) (tlp1019 ___)))
+                      (=
+                       test-struct-d
+                       (and (? number? tlp1020) (? even? tlp1021)))))
+                (=
+                 test-struct-d
+                 (and (? test-struct? tlp1031)
+                      (=
+                       test-struct-a
+                       (or (and (? number? tlp1024) (? even? tlp1025))
+                           (and (? number? tlp1024) (? even? tlp1025))))
+                      (= test-struct-b _)
+                      (= test-struct-c #(tlp1026 tlp1027 tlp1028 tlp1029))
+                      (= test-struct-d _))))
+           9
+           (($
+             test-struct
+             (and (and tlp1034 tlp1035) (and tlp1036 tlp1037))
+             tlp1038
+             ($ test-struct tlp1039 tlp1040 tlp1041 tlp1042)
+             (and (? test-struct? tlp1049)
+                  (= test-struct-a tlp1044)
+                  (= test-struct-b tlp1045)
+                  (= test-struct-c tlp1046)
+                  (= test-struct-d tlp1047)))
+            tlp1051
+            1
+            _))
+          `(() ,inst-struct-name1032 9 (,inst-struct-name1050 #f 1 these))))
+        (list
+         tlp963
+         tlp964
+         tlp965
+         tlp966
+         tlp964
+         tlp965
+         tlp966
+         tlp970
+         tlp971
+         tlp972
+         tlp973
+         tlp974
+         tlp975
+         tlp976
+         tlp977
+         tlp978
+         tlp979
+         tlp980
+         tlp983
+         tlp984
+         tlp985
+         tlp986
+         tlp987
+         tlp988
+         tlp989
+         tlp990
+         tlp993
+         tlp994
+         tlp995
+         tlp996
+         tlp997
+         tlp998
+         tlp999
+         tlp1000
+         tlp1001
+         tlp1002
+         tlp1003
+         tlp1006
+         tlp1007
+         tlp1008
+         tlp1010
+         tlp1011
+         tlp1012
+         tlp1013
+         tlp1018
+         tlp1020
+         tlp1024
+         tlp1026
+         tlp1027
+         tlp1028
+         tlp1029
+         tlp1034
+         tlp1038
+         tlp1039
+         tlp1040
+         tlp1041
+         tlp1042
+         tlp1044
+         tlp1045
+         tlp1046
+         tlp1047
+         tlp1051))
+      '((#\d #f #\c)
+        6
+        8
+        2
+        6
+        8
+        2
+        ((+ 1 2) #t #\c)
+        are
+        #f
+        symbols
+        are
+        these
+        #\c
+        symbols
+        #\a
+        (+ 1 2)
+        (+ 1 2)
+        #t
+        #\a
+        #\c
+        (+ 1 2)
+        #\b
+        #\c
+        (+ 4 5)
+        #\d
+        #t
+        are
+        #\a
+        #\d
+        #\a
+        (+ 1 2)
+        (+ 4 (+ 1 1))
+        #\d
+        #\b
+        #\a
+        ((+ 4 (+ 1 1)) #t #\d)
+        (#\d symbols #t)
+        #\b
+        6
+        #\b
+        #f
+        #t
+        (+ 4 (+ 1 1))
+        (#t #\b #\b)
+        12
+        2
+        #\d
+        symbols
+        #\a
+        #\c
+        (+ 4 5)
+        #f
+        #\d
+        6
+        8
+        (+ 1 2)
+        #\b
+        (+ 1 2)
+        #\b
+        (+ 4 (+ 1 1))
+        #f))
+     (mytest
+      (match-let*
+        (((()
+           (tlp1052 ...)
+           ((tlp1053 ..3)
+            #(tlp1054 ...)
+            #(tlp1055 #(tlp1056 ___) (tlp1057 ...) #&(tlp1058 tlp1059 tlp1060))
+            .
+            #\d)
+           (and (? number? tlp1061) (? even? tlp1062)))
+          `(()
+            (6 #f #f)
+            ((1 symbols (+ 4 (+ 1 1)))
+             #(#\c are #f)
+             #(3 #(#\b #\a #\a) (#\a #t (+ 1 2)) #&(3 #\d #\b))
+             .
+             #\d)
+            14))
+         (((and (? test-struct? tlp1092)
+                (=
+                 test-struct-a
+                 ($
+                  test-struct
+                  (not (not 'are))
+                  tlp1063
+                  tlp1064
+                  (and (? test-struct? tlp1070)
+                       (= test-struct-a tlp1065)
+                       (= test-struct-b tlp1066)
+                       (= test-struct-c tlp1067)
+                       (= test-struct-d tlp1068))))
+                (=
+                 test-struct-b
+                 ($
+                  test-struct
+                  #&(tlp1072 tlp1073 tlp1074)
+                  (and tlp1075 tlp1076)
+                  tlp1077
+                  (and (tlp1078 ...) (tlp1079 ...))))
+                (=
+                 test-struct-c
+                 (or #((and tlp1081 tlp1082)
+                       (and (? test-struct? tlp1088)
+                            (= test-struct-a tlp1083)
+                            (= test-struct-b tlp1084)
+                            (= test-struct-c tlp1085)
+                            (= test-struct-d tlp1086))
+                       #\c
+                       #f)
+                     #((and tlp1081 tlp1082)
+                       (and (? test-struct? tlp1088)
+                            (= test-struct-a tlp1083)
+                            (= test-struct-b tlp1084)
+                            (= test-struct-c tlp1085)
+                            (= test-struct-d tlp1086))
+                       #\c
+                       #f)))
+                (= test-struct-d (and (? number? tlp1089) (? even? tlp1090))))
+           #t
+           (tlp1093 ..3)
+           _)
+          `(,inst-struct-name1091 #t ((+ 4 5) #t these) (+ 4 5)))
+         (((tlp1094 __3) tlp1095 (tlp1096 ..3) ())
+          `((are symbols #t) #\c (these are (+ 4 (+ 1 1))) ())))
+        (list
+         tlp1052
+         tlp1053
+         tlp1054
+         tlp1055
+         tlp1056
+         tlp1057
+         tlp1058
+         tlp1059
+         tlp1060
+         tlp1061
+         tlp1063
+         tlp1064
+         tlp1065
+         tlp1066
+         tlp1067
+         tlp1068
+         tlp1072
+         tlp1073
+         tlp1074
+         tlp1075
+         tlp1077
+         tlp1078
+         tlp1081
+         tlp1083
+         tlp1084
+         tlp1085
+         tlp1086
+         tlp1089
+         tlp1093
+         tlp1094
+         tlp1095
+         tlp1096))
+      '((6 #f #f)
+        (1 symbols (+ 4 (+ 1 1)))
+        (#\c are #f)
+        3
+        (#\b #\a #\a)
+        (#\a #t (+ 1 2))
+        3
+        #\d
+        #\b
+        14
+        symbols
+        #t
+        #\b
+        (+ 1 2)
+        8
+        symbols
+        #\d
+        6
+        (+ 4 (+ 1 1))
+        #t
+        0
+        (#\d #\d (+ 4 5))
+        6
+        symbols
+        #t
+        #\d
+        (+ 1 2)
+        0
+        ((+ 4 5) #t these)
+        (are symbols #t)
+        #\c
+        (these are (+ 4 (+ 1 1)))))
+     (mytest
+      (match-letrec
+        (((($ test-struct tlp1097 () #(tlp1098 ___) ())
+           (and (? test-struct? tlp1119)
+                (= test-struct-a (tlp1100 tlp1101 tlp1102 #\a))
+                (=
+                 test-struct-b
+                 (and (? test-struct? tlp1107)
+                      (= test-struct-a (tlp1103 tlp1104 tlp1105 . 8))
+                      (= test-struct-b _)
+                      (= test-struct-c (or '(+ 4 (+ 1 1)) '(+ 4 (+ 1 1))))
+                      (= test-struct-d _)))
+                (= test-struct-c tlp1108)
+                (=
+                 test-struct-d
+                 #&((tlp1109 tlp1110 tlp1111 tlp1112)
+                    (tlp1113 ..3)
+                    (tlp1114 tlp1115 tlp1116 tlp1117))))
+           (and (? test-struct? tlp1142)
+                (=
+                 test-struct-a
+                 (()
+                  tlp1120
+                  ($ test-struct tlp1121 tlp1122 tlp1123 tlp1124)
+                  #(tlp1126 tlp1127 tlp1128 tlp1129)))
+                (=
+                 test-struct-b
+                 (and (? test-struct? tlp1140)
+                      (= test-struct-a _)
+                      (=
+                       test-struct-b
+                       (or (tlp1130 tlp1131 tlp1132 . tlp1133)
+                           (tlp1130 tlp1131 tlp1132 . tlp1133)))
+                      (= test-struct-c tlp1134)
+                      (= test-struct-d #(tlp1135 tlp1136 tlp1137 tlp1138))))
+                (= test-struct-c ())
+                (= test-struct-d (not (not 5))))
+           (and (? number? tlp1143) (? even? tlp1144)))
+          `(,inst-struct-name1099
+            ,inst-struct-name1118
+            ,inst-struct-name1141
+            12))
+         (('(+ 1 2)
+           'symbols
+           _
+           ($
+            test-struct
+            ((tlp1145 tlp1146 tlp1147 tlp1148)
+             #(tlp1149 ___)
+             (and (? number? tlp1150) (? even? tlp1151))
+             (tlp1152 __3))
+            2
+            ((tlp1153 ___) #(tlp1154 ___) 'symbols . 0)
+            tlp1155))
+          `((+ 1 2) symbols 5 ,inst-struct-name1156))
+         ((((#\c
+             ($ test-struct tlp1157 tlp1158 tlp1159 tlp1160)
+             (and (tlp1162 tlp1163 tlp1164 . tlp1165)
+                  (tlp1166 tlp1167 tlp1168 . tlp1169))
+             .
+             #\b)
+            ($
+             test-struct
+             (and (and (? test-struct? tlp1175)
+                       (= test-struct-a tlp1170)
+                       (= test-struct-b tlp1171)
+                       (= test-struct-c tlp1172)
+                       (= test-struct-d tlp1173))
+                  (and (? test-struct? tlp1176)
+                       (= test-struct-a tlp1177)
+                       (= test-struct-b tlp1178)
+                       (= test-struct-c tlp1179)
+                       (= test-struct-d tlp1180)))
+             tlp1181
+             (and tlp1182 tlp1183)
+             #&(tlp1184 tlp1185 tlp1186))
+            (or _ _)
+            .
+            #\a)
+           (_
+            (and (? number? tlp1188) (? even? tlp1189))
+            ()
+            (and (? test-struct? tlp1199)
+                 (= test-struct-a (tlp1190 ..3))
+                 (= test-struct-b #(tlp1191 tlp1192 tlp1193 tlp1194))
+                 (= test-struct-c #f)
+                 (= test-struct-d #&(tlp1195 tlp1196 tlp1197))))
+           (and (? number? tlp1200) (? even? tlp1201))
+           '(+ 4 5))
+          `(((#\c ,inst-struct-name1161 (#\a are 4 . #t) . #\b)
+             ,inst-struct-name1187
+             (+ 1 2)
+             .
+             #\a)
+            (#\b 6 () ,inst-struct-name1198)
+            0
+            (+ 4 5))))
+        (list
+         tlp1097
+         tlp1098
+         tlp1100
+         tlp1101
+         tlp1102
+         tlp1103
+         tlp1104
+         tlp1105
+         tlp1108
+         tlp1109
+         tlp1110
+         tlp1111
+         tlp1112
+         tlp1113
+         tlp1114
+         tlp1115
+         tlp1116
+         tlp1117
+         tlp1120
+         tlp1121
+         tlp1122
+         tlp1123
+         tlp1124
+         tlp1126
+         tlp1127
+         tlp1128
+         tlp1129
+         tlp1130
+         tlp1131
+         tlp1132
+         tlp1133
+         tlp1130
+         tlp1131
+         tlp1132
+         tlp1133
+         tlp1134
+         tlp1135
+         tlp1136
+         tlp1137
+         tlp1138
+         tlp1143
+         tlp1145
+         tlp1146
+         tlp1147
+         tlp1148
+         tlp1149
+         tlp1150
+         tlp1152
+         tlp1153
+         tlp1154
+         tlp1155
+         tlp1157
+         tlp1158
+         tlp1159
+         tlp1160
+         tlp1162
+         tlp1163
+         tlp1164
+         tlp1165
+         tlp1170
+         tlp1171
+         tlp1172
+         tlp1173
+         tlp1181
+         tlp1182
+         tlp1184
+         tlp1185
+         tlp1186
+         tlp1188
+         tlp1190
+         tlp1191
+         tlp1192
+         tlp1193
+         tlp1194
+         tlp1195
+         tlp1196
+         tlp1197
+         tlp1200))
+      '(8
+        (#\d (+ 1 2) 9)
+        (+ 4 (+ 1 1))
+        these
+        #\d
+        #\c
+        5
+        #\a
+        #\a
+        are
+        #\c
+        #t
+        (+ 4 5)
+        (#\b 0 #\c)
+        1
+        are
+        (+ 1 2)
+        (+ 4 (+ 1 1))
+        these
+        #\b
+        (+ 4 5)
+        #\c
+        these
+        6
+        1
+        5
+        #\c
+        #t
+        #\c
+        these
+        9
+        #t
+        #\c
+        these
+        9
+        #\a
+        9
+        (+ 4 (+ 1 1))
+        #t
+        (+ 1 2)
+        12
+        #t
+        5
+        9
+        5
+        (symbols symbols these)
+        14
+        (are these are)
+        ((+ 4 (+ 1 1)) these #f)
+        ((+ 4 (+ 1 1)) #t #\b)
+        are
+        #\d
+        #\c
+        these
+        1
+        #\a
+        are
+        4
+        #t
+        #f
+        (+ 4 5)
+        #\d
+        #f
+        #\c
+        #\c
+        symbols
+        2
+        #\a
+        6
+        (#\d #\b #t)
+        #f
+        (+ 4 5)
+        symbols
+        (+ 1 2)
+        #\d
+        8
+        3
+        0))
+     (mytest
+      (match-let
+        (((#f
+           (tlp1202 ..3)
+           #(tlp1203 ___)
+           (#&(_ #&(tlp1204 tlp1205 tlp1206) (tlp1207 ___))
+            (and (? number? tlp1208) (? even? tlp1209))
+            ()
+            (and (tlp1210 ...) (tlp1211 ...))))
+          `(#f
+            (these are #\a)
+            #(#\b (+ 4 5) #\c)
+            (#&(9 #&(#t #\b #\a) ((+ 4 (+ 1 1)) #\b are)) 18 () (#t #\b #t))))
+         (('symbols (and (? number? tlp1212) (? even? tlp1213)) #f 'are)
+          `(symbols 2 #f are))
+         (((and tlp1214 tlp1215)
+           (and (? test-struct? tlp1233)
+                (= test-struct-a #(tlp1216 ___))
+                (=
+                 test-struct-b
+                 (and (? test-struct? tlp1222)
+                      (= test-struct-a tlp1217)
+                      (= test-struct-b (not (not 4)))
+                      (= test-struct-c ())
+                      (= test-struct-d (tlp1218 tlp1219 tlp1220 . #\d))))
+                (= test-struct-c #&(() (not (not '(+ 1 2))) ()))
+                (=
+                 test-struct-d
+                 (and (? test-struct? tlp1231)
+                      (= test-struct-a ())
+                      (= test-struct-b #(tlp1223 ...))
+                      (= test-struct-c tlp1224)
+                      (=
+                       test-struct-d
+                       ($ test-struct tlp1225 tlp1226 tlp1227 tlp1228)))))
+           (tlp1234 ___)
+           _)
+          `((+ 4 5) ,inst-struct-name1232 ((+ 4 5) #t #\c) #\d)))
+        (list
+         tlp1202
+         tlp1203
+         tlp1204
+         tlp1205
+         tlp1206
+         tlp1207
+         tlp1208
+         tlp1210
+         tlp1212
+         tlp1214
+         tlp1216
+         tlp1217
+         tlp1218
+         tlp1219
+         tlp1220
+         tlp1223
+         tlp1224
+         tlp1225
+         tlp1226
+         tlp1227
+         tlp1228
+         tlp1234))
+      '((these are #\a)
+        (#\b (+ 4 5) #\c)
+        #t
+        #\b
+        #\a
+        ((+ 4 (+ 1 1)) #\b are)
+        18
+        (#t #\b #t)
+        2
+        (+ 4 5)
+        ((+ 1 2) #\a 2)
+        #\c
+        #\d
+        #\c
+        #\c
+        (#\b 0 (+ 4 5))
+        #\b
+        #\c
+        (+ 4 (+ 1 1))
+        these
+        #f
+        ((+ 4 5) #t #\c)))
+     (mytest
+      (match-let*
+        ((((and (? test-struct? tlp1239)
+                (= test-struct-a (tlp1235 __3))
+                (= test-struct-b tlp1236)
+                (= test-struct-c ())
+                (= test-struct-d (tlp1237 __3)))
+           tlp1240
+           (#(tlp1241 ___)
+            (or (or (tlp1242 tlp1243 tlp1244 tlp1245)
+                    (tlp1242 tlp1243 tlp1244 tlp1245))
+                (or (tlp1242 tlp1243 tlp1244 tlp1245)
+                    (tlp1242 tlp1243 tlp1244 tlp1245)))
+            (or ($
+                 test-struct
+                 #&(tlp1246 tlp1247 tlp1248)
+                 (tlp1249 ___)
+                 (and (? test-struct? tlp1255)
+                      (= test-struct-a tlp1250)
+                      (= test-struct-b tlp1251)
+                      (= test-struct-c tlp1252)
+                      (= test-struct-d tlp1253))
+                 (tlp1256 tlp1257 tlp1258 tlp1259))
+                ($
+                 test-struct
+                 #&(tlp1246 tlp1247 tlp1248)
+                 (tlp1249 ___)
+                 (and (? test-struct? tlp1255)
+                      (= test-struct-a tlp1250)
+                      (= test-struct-b tlp1251)
+                      (= test-struct-c tlp1252)
+                      (= test-struct-d tlp1253))
+                 (tlp1256 tlp1257 tlp1258 tlp1259)))
+            quote
+            these)
+           (tlp1261
+             (not (not #t))
+             #&((and (? test-struct? tlp1267)
+                     (= test-struct-a tlp1262)
+                     (= test-struct-b tlp1263)
+                     (= test-struct-c tlp1264)
+                     (= test-struct-d tlp1265))
+                #\d
+                (tlp1268 tlp1269 tlp1270 tlp1271))
+             (()
+              (tlp1272 tlp1273 tlp1274 . #\c)
+              (and (? test-struct? tlp1280)
+                   (= test-struct-a tlp1275)
+                   (= test-struct-b tlp1276)
+                   (= test-struct-c tlp1277)
+                   (= test-struct-d tlp1278))
+              .
+              #f)))
+          `(,inst-struct-name1238
+            1
+            (#(#\c #\c (+ 1 2))
+             (#\c #\b (+ 4 (+ 1 1)) #\d)
+             ,inst-struct-name1260
+             .
+             these)
+            ((+ 4 (+ 1 1))
+             #t
+             #&(,inst-struct-name1266 #\d (symbols #\a #t #\d))
+             (() (#t #f #\c . #\c) ,inst-struct-name1279 . #f))))
+         ((#(tlp1281 ___)
+           tlp1282
+           (not (not #\b))
+           (or (tlp1283 ___) (tlp1283 ___)))
+          `(#((+ 4 5) are #\c) are #\b (#\a #\a symbols)))
+         ((((tlp1284 ..3)
+            ()
+            tlp1285
+            #&((and (? number? tlp1286) (? even? tlp1287))
+               (or #&(tlp1288 tlp1289 tlp1290) #&(tlp1288 tlp1289 tlp1290))
+               #&(tlp1291 tlp1292 tlp1293)))
+           (tlp1294 __3)
+           2
+           #(tlp1295 ___))
+          `(((are #\c (+ 4 (+ 1 1)))
+             ()
+             #\d
+             #&(2 #&(8 (+ 4 5) #\b) #&(are 3 #\a)))
+            (3 1 these)
+            2
+            #(3 (+ 4 5) #\b))))
+        (list
+         tlp1235
+         tlp1236
+         tlp1237
+         tlp1240
+         tlp1241
+         tlp1242
+         tlp1243
+         tlp1244
+         tlp1245
+         tlp1246
+         tlp1247
+         tlp1248
+         tlp1249
+         tlp1250
+         tlp1251
+         tlp1252
+         tlp1253
+         tlp1256
+         tlp1257
+         tlp1258
+         tlp1259
+         tlp1261
+         tlp1262
+         tlp1263
+         tlp1264
+         tlp1265
+         tlp1268
+         tlp1269
+         tlp1270
+         tlp1271
+         tlp1272
+         tlp1273
+         tlp1274
+         tlp1275
+         tlp1276
+         tlp1277
+         tlp1278
+         tlp1281
+         tlp1282
+         tlp1283
+         tlp1284
+         tlp1285
+         tlp1286
+         tlp1288
+         tlp1289
+         tlp1290
+         tlp1291
+         tlp1292
+         tlp1293
+         tlp1294
+         tlp1295))
+      '((#f #\c #\c)
+        #\b
+        (#\d these these)
+        1
+        (#\c #\c (+ 1 2))
+        #\c
+        #\b
+        (+ 4 (+ 1 1))
+        #\d
+        are
+        #\c
+        #t
+        (9 these #\d)
+        #\b
+        (+ 4 (+ 1 1))
+        #f
+        (+ 4 5)
+        are
+        #\b
+        (+ 1 2)
+        3
+        (+ 4 (+ 1 1))
+        #t
+        #\b
+        #t
+        #\b
+        symbols
+        #\a
+        #t
+        #\d
+        #t
+        #f
+        #\c
+        #\d
+        #\c
+        #\a
+        #t
+        ((+ 4 5) are #\c)
+        are
+        (#\a #\a symbols)
+        (are #\c (+ 4 (+ 1 1)))
+        #\d
+        2
+        8
+        (+ 4 5)
+        #\b
+        are
+        3
+        #\a
+        (3 1 these)
+        (3 (+ 4 5) #\b)))))
+
+  (define (mult-match-tests)
+    (list
+     (let ((tlp1555
+             (lambda (tlp1436)
+               (match
+                tlp1436
+                ((($ test-struct (tlp1437 ...) #(tlp1438 ___) #\d 'are)
+                  (and ($
+                        test-struct
+                        (tlp1440 ___)
+                        ((tlp1441 tlp1442 tlp1443 . tlp1444)
+                         ()
+                         (and (? number? tlp1445) (? even? tlp1446))
+                         .
+                         #t)
+                        ((tlp1447 tlp1448 tlp1449 . tlp1450)
+                         tlp1451
+                         (tlp1452 tlp1453 tlp1454 . tlp1455)
+                         (and (? test-struct? tlp1461)
+                              (= test-struct-a tlp1456)
+                              (= test-struct-b tlp1457)
+                              (= test-struct-c tlp1458)
+                              (= test-struct-d tlp1459)))
+                        #&((and (? number? tlp1462) (? even? tlp1463))
+                           tlp1464
+                           (or tlp1465 tlp1465)))
+                       ($
+                        test-struct
+                        (tlp1467 ___)
+                        ((tlp1468 tlp1469 tlp1470 . tlp1471)
+                         ()
+                         (and (? number? tlp1472) (? even? tlp1473))
+                         .
+                         #t)
+                        ((tlp1474 tlp1475 tlp1476 . tlp1477)
+                         tlp1478
+                         (tlp1479 tlp1480 tlp1481 . tlp1482)
+                         (and (? test-struct? tlp1483)
+                              (= test-struct-a tlp1484)
+                              (= test-struct-b tlp1485)
+                              (= test-struct-c tlp1486)
+                              (= test-struct-d tlp1487)))
+                        #&((and (? number? tlp1488) (? even? tlp1489))
+                           tlp1490
+                           (or tlp1491 tlp1491))))
+                  #(tlp1492 ...)
+                  #(#&(_ #(tlp1493 ___) tlp1494)
+                    (not (not #\b))
+                    (and (? test-struct? tlp1503)
+                         (= test-struct-a (and _ _))
+                         (= test-struct-b (and () ()))
+                         (= test-struct-c #&(tlp1495 tlp1496 tlp1497))
+                         (= test-struct-d #(tlp1498 tlp1499 tlp1500 tlp1501)))
+                    _))
+                 (list
+                  tlp1437
+                  tlp1438
+                  tlp1440
+                  tlp1441
+                  tlp1442
+                  tlp1443
+                  tlp1444
+                  tlp1445
+                  tlp1447
+                  tlp1448
+                  tlp1449
+                  tlp1450
+                  tlp1451
+                  tlp1452
+                  tlp1453
+                  tlp1454
+                  tlp1455
+                  tlp1456
+                  tlp1457
+                  tlp1458
+                  tlp1459
+                  tlp1462
+                  tlp1464
+                  tlp1465
+                  tlp1492
+                  tlp1493
+                  tlp1494
+                  tlp1495
+                  tlp1496
+                  tlp1497
+                  tlp1498
+                  tlp1499
+                  tlp1500
+                  tlp1501))
+                (((and #((and (? test-struct? tlp1509)
+                              (= test-struct-a #\c)
+                              (= test-struct-b _)
+                              (=
+                               test-struct-c
+                               (tlp1504 tlp1505 tlp1506 . tlp1507))
+                              (= test-struct-d ()))
+                         tlp1510
+                         (tlp1511 __3)
+                         #\a)
+                       #((and (? test-struct? tlp1512)
+                              (= test-struct-a #\c)
+                              (= test-struct-b _)
+                              (=
+                               test-struct-c
+                               (tlp1513 tlp1514 tlp1515 . tlp1516))
+                              (= test-struct-d ()))
+                         tlp1517
+                         (tlp1518 __3)
+                         #\a))
+                  _
+                  ($
+                   test-struct
+                   ($ test-struct #t #\b #\d (or 6 6))
+                   (and (? number? tlp1520) (? even? tlp1521))
+                   (or ($
+                        test-struct
+                        (tlp1522 tlp1523 tlp1524 . tlp1525)
+                        (tlp1526 tlp1527 tlp1528 . tlp1529)
+                        (not (not '(+ 1 2)))
+                        (and (? test-struct? tlp1535)
+                             (= test-struct-a tlp1530)
+                             (= test-struct-b tlp1531)
+                             (= test-struct-c tlp1532)
+                             (= test-struct-d tlp1533)))
+                       ($
+                        test-struct
+                        (tlp1522 tlp1523 tlp1524 . tlp1525)
+                        (tlp1526 tlp1527 tlp1528 . tlp1529)
+                        (not (not '(+ 1 2)))
+                        (and (? test-struct? tlp1535)
+                             (= test-struct-a tlp1530)
+                             (= test-struct-b tlp1531)
+                             (= test-struct-c tlp1532)
+                             (= test-struct-d tlp1533))))
+                   tlp1537)
+                  (and (#(tlp1539 ...)
+                        #\b
+                        ($ test-struct tlp1540 3 tlp1541 tlp1542)
+                        (tlp1544 ..3))
+                       (#(tlp1545 ...)
+                        #\b
+                        ($ test-struct tlp1546 3 tlp1547 tlp1548)
+                        (tlp1549 ..3))))
+                 (list
+                  tlp1504
+                  tlp1505
+                  tlp1506
+                  tlp1507
+                  tlp1510
+                  tlp1511
+                  tlp1520
+                  tlp1522
+                  tlp1523
+                  tlp1524
+                  tlp1525
+                  tlp1526
+                  tlp1527
+                  tlp1528
+                  tlp1529
+                  tlp1530
+                  tlp1531
+                  tlp1532
+                  tlp1533
+                  tlp1537
+                  tlp1539
+                  tlp1540
+                  tlp1541
+                  tlp1542
+                  tlp1544))
+                (((and tlp1550 tlp1551)
+                  (tlp1552 __3)
+                  (tlp1553 ___)
+                  (tlp1554 ...))
+                 (list tlp1550 tlp1552 tlp1553 tlp1554))))))
+       (list
+        (mytest
+         (tlp1555
+           `(,inst-struct-name1439
+             ,inst-struct-name1466
+             #(#\a #\b (+ 4 (+ 1 1)))
+             #(#&(#t #((+ 1 2) #f symbols) 2)
+               #\b
+               ,inst-struct-name1502
+               (+ 4 (+ 1 1)))))
+         '((#t 8 #f)
+           (#\a are 3)
+           (#\a 4 #t)
+           #\a
+           (+ 1 2)
+           7
+           #\d
+           0
+           #f
+           #\a
+           #\b
+           #\a
+           are
+           2
+           symbols
+           #f
+           (+ 4 (+ 1 1))
+           #f
+           #\d
+           5
+           #\b
+           2
+           #\b
+           #\b
+           (#\a #\b (+ 4 (+ 1 1)))
+           ((+ 1 2) #f symbols)
+           2
+           2
+           are
+           8
+           these
+           #\c
+           #\a
+           #\a))
+        (mytest
+         (tlp1555
+           `(#(,inst-struct-name1508 #f (#\c symbols 9) #\a)
+             #f
+             ,inst-struct-name1538
+             (#(#\b are (+ 4 (+ 1 1)))
+              #\b
+              ,inst-struct-name1543
+              (#f #\c #\d))))
+         '(#t
+           (+ 4 (+ 1 1))
+           #\c
+           symbols
+           #f
+           (#\c symbols 9)
+           2
+           #\d
+           #f
+           0
+           #\d
+           are
+           are
+           #\c
+           #\b
+           these
+           #\b
+           #\c
+           are
+           (+ 4 5)
+           (#\b are (+ 4 (+ 1 1)))
+           2
+           #\d
+           (+ 4 5)
+           (#f #\c #\d)))
+        (mytest
+         (tlp1555 `(#t (#\c 8 #\a) (#\d #\b #\d) (#\d symbols 8)))
+         '(#t (#\c 8 #\a) (#\d #\b #\d) (#\d symbols 8)))))
+     (let ((tlp1668
+             (lambda (tlp1556)
+               (match
+                tlp1556
+                ((#((and (? test-struct? tlp1564)
+                         (= test-struct-a '(+ 4 (+ 1 1)))
+                         (=
+                          test-struct-b
+                          (and (? test-struct? tlp1562)
+                               (= test-struct-a tlp1557)
+                               (= test-struct-b tlp1558)
+                               (= test-struct-c tlp1559)
+                               (= test-struct-d tlp1560)))
+                         (= test-struct-c '(+ 4 5))
+                         (= test-struct-d (not (not 3))))
+                    (and #&(#&(tlp1565 tlp1566 tlp1567)
+                            ($ test-struct tlp1568 tlp1569 tlp1570 tlp1571)
+                            ($ test-struct tlp1573 tlp1574 tlp1575 tlp1576))
+                         #&(#&(tlp1578 tlp1579 tlp1580)
+                            ($ test-struct tlp1581 tlp1582 tlp1583 tlp1584)
+                            ($ test-struct tlp1585 tlp1586 tlp1587 tlp1588)))
+                    (or ((or tlp1589 tlp1589)
+                         (and (? test-struct? tlp1595)
+                              (= test-struct-a tlp1590)
+                              (= test-struct-b tlp1591)
+                              (= test-struct-c tlp1592)
+                              (= test-struct-d tlp1593))
+                         #(tlp1596 tlp1597 tlp1598 tlp1599)
+                         .
+                         #t)
+                        ((or tlp1589 tlp1589)
+                         (and (? test-struct? tlp1595)
+                              (= test-struct-a tlp1590)
+                              (= test-struct-b tlp1591)
+                              (= test-struct-c tlp1592)
+                              (= test-struct-d tlp1593))
+                         #(tlp1596 tlp1597 tlp1598 tlp1599)
+                         .
+                         #t))
+                    (and (? test-struct? tlp1610)
+                         (= test-struct-a (tlp1600 ...))
+                         (= test-struct-b (tlp1601 ...))
+                         (= test-struct-c (tlp1602 tlp1603 tlp1604 tlp1605))
+                         (= test-struct-d (tlp1606 tlp1607 tlp1608 . #\b))))
+                  ((and (? number? tlp1611) (? even? tlp1612))
+                   (or (and (? number? tlp1613) (? even? tlp1614))
+                       (and (? number? tlp1613) (? even? tlp1614)))
+                   #&(($ test-struct tlp1615 tlp1616 tlp1617 tlp1618)
+                      (and (? number? tlp1620) (? even? tlp1621))
+                      #f)
+                   (and (? number? tlp1622) (? even? tlp1623)))
+                  _
+                  ())
+                 (list
+                  tlp1557
+                  tlp1558
+                  tlp1559
+                  tlp1560
+                  tlp1565
+                  tlp1566
+                  tlp1567
+                  tlp1568
+                  tlp1569
+                  tlp1570
+                  tlp1571
+                  tlp1573
+                  tlp1574
+                  tlp1575
+                  tlp1576
+                  tlp1589
+                  tlp1590
+                  tlp1591
+                  tlp1592
+                  tlp1593
+                  tlp1596
+                  tlp1597
+                  tlp1598
+                  tlp1599
+                  tlp1589
+                  tlp1590
+                  tlp1591
+                  tlp1592
+                  tlp1593
+                  tlp1596
+                  tlp1597
+                  tlp1598
+                  tlp1599
+                  tlp1600
+                  tlp1601
+                  tlp1602
+                  tlp1603
+                  tlp1604
+                  tlp1605
+                  tlp1606
+                  tlp1607
+                  tlp1608
+                  tlp1611
+                  tlp1613
+                  tlp1615
+                  tlp1616
+                  tlp1617
+                  tlp1618
+                  tlp1620
+                  tlp1622))
+                ((#&((#(tlp1624 tlp1625 tlp1626 tlp1627) tlp1628 _ . #t)
+                     (tlp1629 ___)
+                     (#(tlp1630 ___)
+                      (and (? test-struct? tlp1636)
+                           (= test-struct-a tlp1631)
+                           (= test-struct-b tlp1632)
+                           (= test-struct-c tlp1633)
+                           (= test-struct-d tlp1634))
+                      tlp1637
+                      tlp1638))
+                  (tlp1639 ..3)
+                  (_ (tlp1640 __3) _ . #t)
+                  #&(tlp1641
+                      #t
+                      #((and (? number? tlp1642) (? even? tlp1643))
+                        ()
+                        #\a
+                        #&(tlp1644 tlp1645 tlp1646))))
+                 (list
+                  tlp1624
+                  tlp1625
+                  tlp1626
+                  tlp1627
+                  tlp1628
+                  tlp1629
+                  tlp1630
+                  tlp1631
+                  tlp1632
+                  tlp1633
+                  tlp1634
+                  tlp1637
+                  tlp1638
+                  tlp1639
+                  tlp1640
+                  tlp1641
+                  tlp1642
+                  tlp1644
+                  tlp1645
+                  tlp1646))
+                ((((and ((not (not 'symbols))
+                         _
+                         (tlp1647 tlp1648 tlp1649 . tlp1650)
+                         .
+                         0)
+                        ((not (not 'symbols))
+                         _
+                         (tlp1651 tlp1652 tlp1653 . tlp1654)
+                         .
+                         0))
+                   _
+                   ($
+                    test-struct
+                    (tlp1655 tlp1656 tlp1657 . #f)
+                    (tlp1658 ...)
+                    (and (? test-struct? tlp1664)
+                         (= test-struct-a tlp1659)
+                         (= test-struct-b tlp1660)
+                         (= test-struct-c tlp1661)
+                         (= test-struct-d tlp1662))
+                    (tlp1665 ___))
+                   #(_ (and _ _) (not (not 6)) _))
+                  (tlp1667 __3)
+                  (or 9 9)
+                  '(+ 4 5))
+                 (list
+                  tlp1647
+                  tlp1648
+                  tlp1649
+                  tlp1650
+                  tlp1655
+                  tlp1656
+                  tlp1657
+                  tlp1658
+                  tlp1659
+                  tlp1660
+                  tlp1661
+                  tlp1662
+                  tlp1665
+                  tlp1667))))))
+       (list
+        (mytest
+         (tlp1668
+           `(#(,inst-struct-name1563
+               #&(#&(#\c (+ 4 (+ 1 1)) these)
+                  ,inst-struct-name1572
+                  ,inst-struct-name1577)
+               (4 ,inst-struct-name1594 #(#t #\d these #\c) . #t)
+               ,inst-struct-name1609)
+             (0 10 #&(,inst-struct-name1619 2 #f) 2)
+             are
+             ()))
+         '(#f
+           symbols
+           #\b
+           #t
+           #\c
+           (+ 4 (+ 1 1))
+           these
+           (+ 1 2)
+           #\a
+           #\b
+           #\d
+           #\b
+           #\b
+           #\b
+           4
+           4
+           #f
+           are
+           #\b
+           #f
+           #t
+           #\d
+           these
+           #\c
+           4
+           #f
+           are
+           #\b
+           #f
+           #t
+           #\d
+           these
+           #\c
+           (symbols (+ 1 2) #\d)
+           (#\c symbols are)
+           are
+           are
+           #\c
+           (+ 1 2)
+           symbols
+           #\d
+           (+ 1 2)
+           0
+           10
+           #t
+           (+ 4 (+ 1 1))
+           #\c
+           #t
+           2
+           2))
+        (mytest
+         (tlp1668
+           `(#&((#(#\c symbols #\a 8) #\b #f . #t)
+                ((+ 4 (+ 1 1)) (+ 4 5) #\c)
+                (#(#\d (+ 4 5) 8) ,inst-struct-name1635 7 #t))
+             (3 7 #\d)
+             (#\b (#\b (+ 1 2) #f) #f . #t)
+             #&(#\a #t #(10 () #\a #&(symbols symbols 7)))))
+         '(#\c
+           symbols
+           #\a
+           8
+           #\b
+           ((+ 4 (+ 1 1)) (+ 4 5) #\c)
+           (#\d (+ 4 5) 8)
+           #\b
+           #\d
+           (+ 4 (+ 1 1))
+           #\c
+           7
+           #t
+           (3 7 #\d)
+           (#\b (+ 1 2) #f)
+           #\a
+           10
+           symbols
+           symbols
+           7))
+        (mytest
+         (tlp1668
+           `(((symbols #\d (symbols #\d are . 8) . 0)
+              #\b
+              ,inst-struct-name1666
+              #(#f #\d 6 #\c))
+             (#\c are (+ 1 2))
+             9
+             (+ 4 5)))
+         '(symbols
+            #\d
+            are
+            8
+            #\c
+            these
+            symbols
+            (4 5 #f)
+            #f
+            #\a
+            #f
+            (+ 1 2)
+            (#f (+ 4 5) (+ 4 5))
+            (#\c are (+ 1 2))))))
+     (let ((tlp1713
+             (lambda (tlp1669)
+               (match
+                tlp1669
+                ((#&(() () (tlp1670 __3))
+                  (not (not '(+ 1 2)))
+                  #&('symbols
+                     #((or (tlp1671 tlp1672 tlp1673 tlp1674)
+                           (tlp1671 tlp1672 tlp1673 tlp1674))
+                       tlp1675
+                       #(tlp1676 ...)
+                       (tlp1677 tlp1678 tlp1679 tlp1680))
+                     tlp1681)
+                  #&(#(tlp1682 #f #\a _)
+                     #((and (? test-struct? tlp1688)
+                            (= test-struct-a tlp1683)
+                            (= test-struct-b tlp1684)
+                            (= test-struct-c tlp1685)
+                            (= test-struct-d tlp1686))
+                       _
+                       (tlp1689 __3)
+                       #&(tlp1690 tlp1691 tlp1692))
+                     ()))
+                 (list
+                  tlp1670
+                  tlp1671
+                  tlp1672
+                  tlp1673
+                  tlp1674
+                  tlp1675
+                  tlp1676
+                  tlp1677
+                  tlp1678
+                  tlp1679
+                  tlp1680
+                  tlp1681
+                  tlp1682
+                  tlp1683
+                  tlp1684
+                  tlp1685
+                  tlp1686
+                  tlp1689
+                  tlp1690
+                  tlp1691
+                  tlp1692))
+                ((($
+                   test-struct
+                   #(#(tlp1693 tlp1694 tlp1695 tlp1696)
+                     (tlp1697 __3)
+                     (not (not #\c))
+                     tlp1698)
+                   #(tlp1699 ___)
+                   (tlp1700 ..3)
+                   #\b)
+                  ($
+                   test-struct
+                   tlp1702
+                   #(() #&(tlp1703 tlp1704 tlp1705) (or () ()) tlp1706)
+                   _
+                   tlp1707)
+                  #t
+                  tlp1709)
+                 (list
+                  tlp1693
+                  tlp1694
+                  tlp1695
+                  tlp1696
+                  tlp1697
+                  tlp1698
+                  tlp1699
+                  tlp1700
+                  tlp1702
+                  tlp1703
+                  tlp1704
+                  tlp1705
+                  tlp1706
+                  tlp1707
+                  tlp1709))
+                ((tlp1710 #(tlp1711 ___) _ tlp1712)
+                 (list tlp1710 tlp1711 tlp1712))))))
+       (list
+        (mytest
+         (tlp1713
+           `(#&(() () (#f are #\d))
+             (+ 1 2)
+             #&(symbols
+                 #((#\a 3 (+ 1 2) 3)
+                   (+ 4 5)
+                   #(#f #\c 2)
+                   (#t (+ 4 5) (+ 4 (+ 1 1)) symbols))
+                 these)
+             #&(#(#t #f #\a #f)
+                #(,inst-struct-name1687 8 (3 5 #\d) #&(#\d 8 #\a))
+                ())))
+         '((#f are #\d)
+           #\a
+           3
+           (+ 1 2)
+           3
+           (+ 4 5)
+           (#f #\c 2)
+           #t
+           (+ 4 5)
+           (+ 4 (+ 1 1))
+           symbols
+           these
+           #t
+           symbols
+           are
+           1
+           are
+           (3 5 #\d)
+           #\d
+           8
+           #\a))
+        (mytest
+         (tlp1713 `(,inst-struct-name1701 ,inst-struct-name1708 #t #\c))
+         '(these
+           #\d
+           these
+           symbols
+           (are 6 these)
+           #\d
+           (#f 8 (+ 4 5))
+           (#\b are symbols)
+           (+ 1 2)
+           (+ 4 5)
+           #\a
+           #f
+           (+ 4 (+ 1 1))
+           #\a
+           #\c))
+        (mytest (tlp1713 `(#f #(9 (+ 4 5) 9) #t #\d)) '(#f (9 (+ 4 5) 9) #\d))))
+     (let ((tlp1746
+             (lambda (tlp1714)
+               (match
+                tlp1714
+                (((()
+                   (and (? test-struct? tlp1720)
+                        (= test-struct-a #&(tlp1715 tlp1716 tlp1717))
+                        (= test-struct-b _)
+                        (= test-struct-c 0)
+                        (= test-struct-d tlp1718))
+                   (not (not '(+ 4 5)))
+                   .
+                   8)
+                  '(+ 4 (+ 1 1))
+                  (and (? number? tlp1721) (? even? tlp1722))
+                  #((and (? number? tlp1723) (? even? tlp1724))
+                    _
+                    #&((not (not '(+ 4 (+ 1 1)))) (not (not #t)) (tlp1725 ___))
+                    (not (not '(+ 1 2)))))
+                 (list
+                  tlp1715
+                  tlp1716
+                  tlp1717
+                  tlp1718
+                  tlp1721
+                  tlp1723
+                  tlp1725))
+                ((_ #&((tlp1726 ...) tlp1727 ()) tlp1728 '(+ 4 5))
+                 (list tlp1726 tlp1727 tlp1728))
+                ((tlp1729
+                   #\a
+                   #((and (? number? tlp1730) (? even? tlp1731))
+                     ('(+ 1 2)
+                      (tlp1732 tlp1733 tlp1734 tlp1735)
+                      (tlp1736 __3)
+                      .
+                      #\b)
+                     ((and (? test-struct? tlp1742)
+                           (= test-struct-a tlp1737)
+                           (= test-struct-b tlp1738)
+                           (= test-struct-c tlp1739)
+                           (= test-struct-d tlp1740))
+                      ()
+                      #&(tlp1743 tlp1744 tlp1745)
+                      quote
+                      these)
+                     ())
+                   #f)
+                 (list
+                  tlp1729
+                  tlp1730
+                  tlp1732
+                  tlp1733
+                  tlp1734
+                  tlp1735
+                  tlp1736
+                  tlp1737
+                  tlp1738
+                  tlp1739
+                  tlp1740
+                  tlp1743
+                  tlp1744
+                  tlp1745))))))
+       (list
+        (mytest
+         (tlp1746
+           `((() ,inst-struct-name1719 (+ 4 5) . 8)
+             (+ 4 (+ 1 1))
+             2
+             #(6 2 #&((+ 4 (+ 1 1)) #t (2 (+ 4 (+ 1 1)) are)) (+ 1 2))))
+         '(#\d #t #t (+ 4 (+ 1 1)) 2 6 (2 (+ 4 (+ 1 1)) are)))
+        (mytest
+         (tlp1746 `(are #&(((+ 4 5) are these) (+ 1 2) ()) are (+ 4 5)))
+         '(((+ 4 5) are these) (+ 1 2) are))
+        (mytest
+         (tlp1746
+           `(#\d
+             #\a
+             #(4
+               ((+ 1 2) (4 #t #\b #f) (0 (+ 4 5) these) . #\b)
+               (,inst-struct-name1741 () #&(#\d #\c #\a) . these)
+               ())
+             #f))
+         '(#\d 4 4 #t #\b #f (0 (+ 4 5) these) these #t 7 #\b #\d #\c #\a))))
+     (let ((tlp1820
+             (lambda (tlp1747)
+               (match
+                tlp1747
+                ((#(tlp1748 ...) _ (or _ _) (tlp1749 __3))
+                 (list tlp1748 tlp1749))
+                (((tlp1750 ..3)
+                  (and tlp1751 tlp1752)
+                  tlp1753
+                  (tlp1754
+                    (() tlp1755 () #&(tlp1756 tlp1757 tlp1758))
+                    ((tlp1759 ___)
+                     (and (? number? tlp1760) (? even? tlp1761))
+                     #(tlp1762 tlp1763 tlp1764 tlp1765)
+                     .
+                     #t)
+                    .
+                    #t))
+                 (list
+                  tlp1750
+                  tlp1751
+                  tlp1753
+                  tlp1754
+                  tlp1755
+                  tlp1756
+                  tlp1757
+                  tlp1758
+                  tlp1759
+                  tlp1760
+                  tlp1762
+                  tlp1763
+                  tlp1764
+                  tlp1765))
+                (((and (? test-struct? tlp1777)
+                       (= test-struct-a tlp1766)
+                       (= test-struct-b #(tlp1767 ...))
+                       (= test-struct-c #(tlp1768 ___))
+                       (=
+                        test-struct-d
+                        ($
+                         test-struct
+                         (tlp1769 tlp1770 tlp1771 tlp1772)
+                         (tlp1773 ___)
+                         tlp1774
+                         #t)))
+                  tlp1778
+                  (and (? test-struct? tlp1798)
+                       (=
+                        test-struct-a
+                        ((tlp1779 tlp1780 tlp1781 . #\a)
+                         (and (? test-struct? tlp1787)
+                              (= test-struct-a tlp1782)
+                              (= test-struct-b tlp1783)
+                              (= test-struct-c tlp1784)
+                              (= test-struct-d tlp1785))
+                         (tlp1788 ___)
+                         #&(tlp1789 tlp1790 tlp1791)))
+                       (= test-struct-b (or '(+ 4 5) '(+ 4 5)))
+                       (=
+                        test-struct-c
+                        ($ test-struct tlp1792 #(tlp1793 ...) tlp1794 tlp1795))
+                       (= test-struct-d _))
+                  (and (? test-struct? tlp1819)
+                       (=
+                        test-struct-a
+                        #&(tlp1799 (tlp1800 ..3) (and tlp1801 tlp1802)))
+                       (=
+                        test-struct-b
+                        (and (? test-struct? tlp1814)
+                             (=
+                              test-struct-a
+                              (tlp1803 tlp1804 tlp1805 tlp1806))
+                             (=
+                              test-struct-b
+                              #(tlp1807 tlp1808 tlp1809 tlp1810))
+                             (=
+                              test-struct-c
+                              (and (or tlp1811 tlp1811) (or tlp1812 tlp1812)))
+                             (= test-struct-d (or () ()))))
+                       (= test-struct-c #&(tlp1815 () tlp1816))
+                       (= test-struct-d #(tlp1817 ...))))
+                 (list
+                  tlp1766
+                  tlp1767
+                  tlp1768
+                  tlp1769
+                  tlp1770
+                  tlp1771
+                  tlp1772
+                  tlp1773
+                  tlp1774
+                  tlp1778
+                  tlp1779
+                  tlp1780
+                  tlp1781
+                  tlp1782
+                  tlp1783
+                  tlp1784
+                  tlp1785
+                  tlp1788
+                  tlp1789
+                  tlp1790
+                  tlp1791
+                  tlp1792
+                  tlp1793
+                  tlp1794
+                  tlp1795
+                  tlp1799
+                  tlp1800
+                  tlp1801
+                  tlp1803
+                  tlp1804
+                  tlp1805
+                  tlp1806
+                  tlp1807
+                  tlp1808
+                  tlp1809
+                  tlp1810
+                  tlp1811
+                  tlp1815
+                  tlp1816
+                  tlp1817))))))
+       (list
+        (mytest
+         (tlp1820 `(#(#\d symbols #\a) #f 2 (3 #f these)))
+         '((#\d symbols #\a) (3 #f these)))
+        (mytest
+         (tlp1820
+           `(((+ 4 (+ 1 1)) #\c 6)
+             #\d
+             #\b
+             (#\d
+              (() #\a () #&(symbols are #t))
+              ((#\b #f 0) 18 #(0 (+ 4 5) #\d these) . #t)
+              .
+              #t)))
+         '(((+ 4 (+ 1 1)) #\c 6)
+           #\d
+           #\b
+           #\d
+           #\a
+           symbols
+           are
+           #t
+           (#\b #f 0)
+           18
+           0
+           (+ 4 5)
+           #\d
+           these))
+        (mytest
+         (tlp1820
+           `(,inst-struct-name1776
+             (+ 4 (+ 1 1))
+             ,inst-struct-name1797
+             ,inst-struct-name1818))
+         '(symbols
+            (#\d #\c (+ 4 (+ 1 1)))
+            (symbols #\a #\d)
+            8
+            #f
+            #f
+            (+ 4 (+ 1 1))
+            (9 #\c #t)
+            #f
+            (+ 4 (+ 1 1))
+            these
+            #t
+            (+ 4 (+ 1 1))
+            0
+            #\a
+            0
+            #t
+            (#\a #t 7)
+            9
+            #\b
+            symbols
+            3
+            (#\b #\c 0)
+            #t
+            (+ 4 5)
+            #\a
+            (9 #\c symbols)
+            #f
+            symbols
+            #\d
+            #\b
+            are
+            #\d
+            (+ 4 (+ 1 1))
+            #f
+            #\b
+            are
+            8
+            #\d
+            (#\a these symbols)))))))
+
+  (define (mult-match-lambda-tests)
+    (list
+     (let ((tlp1951
+             (match-lambda
+               (((tlp1907 ___) () 'symbols 'these) (list tlp1907))
+               (((#t (and () ()) (and tlp1908 tlp1909) (tlp1910 ___))
+                 #(tlp1911 ___)
+                 ((not (not #\b)) '(+ 1 2) tlp1912 . #\a)
+                 tlp1913)
+                (list tlp1908 tlp1910 tlp1911 tlp1912 tlp1913))
+               ((#((and (? test-struct? tlp1920)
+                        (= test-struct-a tlp1914)
+                        (= test-struct-b tlp1915)
+                        (= test-struct-c #&(tlp1916 tlp1917 tlp1918))
+                        (= test-struct-d #\b))
+                   (_ (tlp1921 tlp1922 tlp1923 tlp1924) #f . #\d)
+                   (and (? test-struct? tlp1936)
+                        (= test-struct-a #&(tlp1925 tlp1926 tlp1927))
+                        (= test-struct-b (tlp1928 tlp1929 tlp1930 tlp1931))
+                        (= test-struct-c #&(tlp1932 tlp1933 tlp1934))
+                        (= test-struct-d _))
+                   (and (? test-struct? tlp1949)
+                        (= test-struct-a '(+ 4 5))
+                        (=
+                         test-struct-b
+                         (or ($ test-struct tlp1937 tlp1938 tlp1939 tlp1940)
+                             ($ test-struct tlp1937 tlp1938 tlp1939 tlp1940)))
+                        (= test-struct-c (tlp1942 __3))
+                        (=
+                         test-struct-d
+                         ($ test-struct tlp1943 tlp1944 tlp1945 tlp1946))))
+                 #t
+                 _
+                 tlp1950)
+                (list
+                 tlp1914
+                 tlp1915
+                 tlp1916
+                 tlp1917
+                 tlp1918
+                 tlp1921
+                 tlp1922
+                 tlp1923
+                 tlp1924
+                 tlp1925
+                 tlp1926
+                 tlp1927
+                 tlp1928
+                 tlp1929
+                 tlp1930
+                 tlp1931
+                 tlp1932
+                 tlp1933
+                 tlp1934
+                 tlp1937
+                 tlp1938
+                 tlp1939
+                 tlp1940
+                 tlp1942
+                 tlp1943
+                 tlp1944
+                 tlp1945
+                 tlp1946
+                 tlp1950)))))
+       (list
+        (mytest (tlp1951 `((#\b 5 these) () symbols these)) '((#\b 5 these)))
+        (mytest
+         (tlp1951
+           `((#t () #\d ((+ 1 2) 0 1))
+             #(#\c (+ 1 2) these)
+             (#\b (+ 1 2) (+ 4 5) . #\a)
+             #\d))
+         '(#\d ((+ 1 2) 0 1) (#\c (+ 1 2) these) (+ 4 5) #\d))
+        (mytest
+         (tlp1951
+           `(#(,inst-struct-name1919
+               (#\b ((+ 4 (+ 1 1)) #\d are #t) #f . #\d)
+               ,inst-struct-name1935
+               ,inst-struct-name1948)
+             #t
+             these
+             #f))
+         '((+ 1 2)
+           #\b
+           (+ 1 2)
+           #\a
+           #t
+           (+ 4 (+ 1 1))
+           #\d
+           are
+           #t
+           2
+           #\c
+           #\c
+           #f
+           0
+           6
+           #f
+           1
+           #\a
+           symbols
+           #\b
+           (+ 4 5)
+           #f
+           are
+           (1 #\b (+ 4 5))
+           (+ 4 (+ 1 1))
+           #\d
+           5
+           #\d
+           #f))))
+     (let ((tlp2015
+             (match-lambda
+               (((tlp1952
+                   (or ($ test-struct 2 tlp1953 tlp1954 ())
+                       ($ test-struct 2 tlp1953 tlp1954 ()))
+                   ($
+                    test-struct
+                    #(tlp1956 tlp1957 tlp1958 tlp1959)
+                    (and #(tlp1960 ___) #(tlp1961 ___))
+                    (or #t #t)
+                    ())
+                   quote
+                   these)
+                 (not (not '(+ 4 (+ 1 1))))
+                 #(tlp1963 ___)
+                 ())
+                (list
+                 tlp1952
+                 tlp1953
+                 tlp1954
+                 tlp1956
+                 tlp1957
+                 tlp1958
+                 tlp1959
+                 tlp1960
+                 tlp1963))
+               (((tlp1964 ..3)
+                 (or (and (? number? tlp1965) (? even? tlp1966))
+                     (and (? number? tlp1965) (? even? tlp1966)))
+                 (and (? test-struct? tlp1978)
+                      (= test-struct-a tlp1967)
+                      (= test-struct-b 'symbols)
+                      (= test-struct-c tlp1968)
+                      (=
+                       test-struct-d
+                       (#(tlp1969 ...)
+                        tlp1970
+                        (and (? test-struct? tlp1976)
+                             (= test-struct-a tlp1971)
+                             (= test-struct-b tlp1972)
+                             (= test-struct-c tlp1973)
+                             (= test-struct-d tlp1974))
+                        .
+                        5)))
+                 (and () ()))
+                (list
+                 tlp1964
+                 tlp1965
+                 tlp1967
+                 tlp1968
+                 tlp1969
+                 tlp1970
+                 tlp1971
+                 tlp1972
+                 tlp1973
+                 tlp1974))
+               ((()
+                 tlp1979
+                 ($
+                  test-struct
+                  (and (? number? tlp1980) (? even? tlp1981))
+                  ()
+                  (and (and (? test-struct? tlp1997)
+                            (=
+                             test-struct-a
+                             (tlp1982 tlp1983 tlp1984 . tlp1985))
+                            (=
+                             test-struct-b
+                             (tlp1986 tlp1987 tlp1988 . tlp1989))
+                            (= test-struct-c tlp1990)
+                            (=
+                             test-struct-d
+                             ($ test-struct tlp1991 tlp1992 tlp1993 tlp1994)))
+                       (and (? test-struct? tlp1998)
+                            (=
+                             test-struct-a
+                             (tlp1999 tlp2000 tlp2001 . tlp2002))
+                            (=
+                             test-struct-b
+                             (tlp2003 tlp2004 tlp2005 . tlp2006))
+                            (= test-struct-c tlp2007)
+                            (=
+                             test-struct-d
+                             ($ test-struct tlp2008 tlp2009 tlp2010 tlp2011))))
+                  (tlp2012 ..3))
+                 tlp2014)
+                (list
+                 tlp1979
+                 tlp1980
+                 tlp1982
+                 tlp1983
+                 tlp1984
+                 tlp1985
+                 tlp1986
+                 tlp1987
+                 tlp1988
+                 tlp1989
+                 tlp1990
+                 tlp1991
+                 tlp1992
+                 tlp1993
+                 tlp1994
+                 tlp2012
+                 tlp2014)))))
+       (list
+        (mytest
+         (tlp2015
+           `((#f ,inst-struct-name1955 ,inst-struct-name1962 . these)
+             (+ 4 (+ 1 1))
+             #(#t #\a #\c)
+             ()))
+         '(#f 5 #\c #t are #\b #f (#f #f (+ 4 5)) (#t #\a #\c)))
+        (mytest
+         (tlp2015 `((these #t #t) 18 ,inst-struct-name1977 ()))
+         '((these #t #t)
+           18
+           symbols
+           (+ 4 (+ 1 1))
+           (2 (+ 4 5) #\b)
+           are
+           (+ 1 2)
+           (+ 1 2)
+           #\c
+           #f))
+        (mytest
+         (tlp2015 `(() (+ 1 2) ,inst-struct-name2013 (+ 4 (+ 1 1))))
+         '((+ 1 2)
+           18
+           #\c
+           (+ 4 (+ 1 1))
+           2
+           #\a
+           #\b
+           #\c
+           (+ 4 (+ 1 1))
+           are
+           #\b
+           #\a
+           (+ 4 5)
+           8
+           8
+           (are #\c symbols)
+           (+ 4 (+ 1 1))))))
+     (let ((tlp2066
+             (match-lambda
+               (((not (not #t)) tlp2016 () tlp2017) (list tlp2016 tlp2017))
+               ((((tlp2018 (not (not '(+ 1 2))) 'are tlp2019)
+                  ((tlp2020 tlp2021 tlp2022 tlp2023)
+                   (and (tlp2024 tlp2025 tlp2026 . tlp2027)
+                        (tlp2028 tlp2029 tlp2030 . tlp2031))
+                   (tlp2032 __3)
+                   _)
+                  (and (? number? tlp2033) (? even? tlp2034))
+                  .
+                  #\b)
+                 _
+                 (tlp2035 __3)
+                 #f)
+                (list
+                 tlp2018
+                 tlp2019
+                 tlp2020
+                 tlp2021
+                 tlp2022
+                 tlp2023
+                 tlp2024
+                 tlp2025
+                 tlp2026
+                 tlp2027
+                 tlp2032
+                 tlp2033
+                 tlp2035))
+               ((((tlp2036 ...)
+                  (and (and (? test-struct? tlp2042)
+                            (= test-struct-a tlp2037)
+                            (= test-struct-b 7)
+                            (= test-struct-c #&(tlp2038 tlp2039 tlp2040))
+                            (= test-struct-d (not (not #t))))
+                       (and (? test-struct? tlp2043)
+                            (= test-struct-a tlp2044)
+                            (= test-struct-b 7)
+                            (= test-struct-c #&(tlp2045 tlp2046 tlp2047))
+                            (= test-struct-d (not (not #t)))))
+                  (and #((and tlp2048 tlp2049)
+                         (tlp2050 tlp2051 tlp2052 tlp2053)
+                         (and tlp2054 tlp2055)
+                         tlp2056)
+                       #((and tlp2057 tlp2058)
+                         (tlp2059 tlp2060 tlp2061 tlp2062)
+                         (and tlp2063 tlp2064)
+                         tlp2065))
+                  #\c)
+                 'symbols
+                 ()
+                 (not (not '(+ 4 5))))
+                (list
+                 tlp2036
+                 tlp2037
+                 tlp2038
+                 tlp2039
+                 tlp2040
+                 tlp2048
+                 tlp2050
+                 tlp2051
+                 tlp2052
+                 tlp2053
+                 tlp2054
+                 tlp2056)))))
+       (list
+        (mytest (tlp2066 `(#t #\c () #\c)) '(#\c #\c))
+        (mytest
+         (tlp2066
+           `((((+ 4 5) (+ 1 2) are these)
+              ((#\d 3 #\b #\c)
+               ((+ 4 (+ 1 1)) #\c (+ 4 (+ 1 1)) + 4 (+ 1 1))
+               (#\a 1 #\d)
+               0)
+              0
+              .
+              #\b)
+             #\c
+             (#\d these #t)
+             #f))
+         '((+ 4 5)
+           these
+           #\d
+           3
+           #\b
+           #\c
+           (+ 4 (+ 1 1))
+           #\c
+           (+ 4 (+ 1 1))
+           (+ 4 (+ 1 1))
+           (#\a 1 #\d)
+           0
+           (#\d these #t)))
+        (mytest
+         (tlp2066
+           `(((#\a #f #\a)
+              ,inst-struct-name2041
+              #((+ 4 5) (#\a (+ 1 2) (+ 4 5) #\c) #f 7)
+              #\c)
+             symbols
+             ()
+             (+ 4 5)))
+         '((#\a #f #\a)
+           (+ 1 2)
+           #\c
+           #\d
+           (+ 4 5)
+           (+ 4 5)
+           #\a
+           (+ 1 2)
+           (+ 4 5)
+           #\c
+           #f
+           7))))
+     (let ((tlp2095
+             (match-lambda
+               (((and (? number? tlp2067) (? even? tlp2068))
+                 _
+                 (or 'these 'these)
+                 8)
+                (list tlp2067))
+               (((tlp2069 ..3)
+                 (tlp2070 ..3)
+                 #&((not (not 'are))
+                    (and (? number? tlp2071) (? even? tlp2072))
+                    tlp2073)
+                 (#(() tlp2074 tlp2075 (tlp2076 tlp2077 tlp2078 quote symbols))
+                  tlp2079
+                  (and (? test-struct? tlp2086)
+                       (= test-struct-a #(tlp2080 tlp2081 tlp2082 tlp2083))
+                       (= test-struct-b _)
+                       (= test-struct-c (not (not #\c)))
+                       (= test-struct-d (tlp2084 __3)))
+                  quote
+                  are))
+                (list
+                 tlp2069
+                 tlp2070
+                 tlp2071
+                 tlp2073
+                 tlp2074
+                 tlp2075
+                 tlp2076
+                 tlp2077
+                 tlp2078
+                 tlp2079
+                 tlp2080
+                 tlp2081
+                 tlp2082
+                 tlp2083
+                 tlp2084))
+               ((#\b
+                 _
+                 ($
+                  test-struct
+                  (tlp2087 ...)
+                  (and (? number? tlp2088) (? even? tlp2089))
+                  (or tlp2090 tlp2090)
+                  #((not (not '(+ 1 2))) tlp2091 () tlp2092))
+                 tlp2094)
+                (list tlp2087 tlp2088 tlp2090 tlp2091 tlp2092 tlp2094)))))
+       (list
+        (mytest (tlp2095 `(18 1 these 8)) '(18))
+        (mytest
+         (tlp2095
+           `((#f #\a #\c)
+             (#f #f are)
+             #&(are 10 #f)
+             (#(() #\b are (#t symbols 0 . symbols))
+              6
+              ,inst-struct-name2085
+              .
+              are)))
+         '((#f #\a #\c)
+           (#f #f are)
+           10
+           #f
+           #\b
+           are
+           #t
+           symbols
+           0
+           6
+           #t
+           (+ 4 5)
+           (+ 4 5)
+           #t
+           (these these 7)))
+        (mytest
+         (tlp2095 `(#\b these ,inst-struct-name2093 #\a))
+         '((#\b 9 #\b) 16 #\a 9 2 #\a))))
+     (let ((tlp2164
+             (match-lambda
+               (((and (? number? tlp2096) (? even? tlp2097))
+                 (and (? test-struct? tlp2105)
+                      (= test-struct-a #\b)
+                      (=
+                       test-struct-b
+                       (or (and (tlp2098 ___) (tlp2099 ___))
+                           (and (tlp2098 ___) (tlp2099 ___))))
+                      (=
+                       test-struct-c
+                       (and (? number? tlp2100) (? even? tlp2101)))
+                      (=
+                       test-struct-d
+                       (and (? number? tlp2102) (? even? tlp2103))))
+                 #t
+                 #\a)
+                (list tlp2096 tlp2098 tlp2100 tlp2102))
+               (((and (? test-struct? tlp2128)
+                      (= test-struct-a _)
+                      (= test-struct-b ())
+                      (=
+                       test-struct-c
+                       ($
+                        test-struct
+                        ($ test-struct tlp2106 tlp2107 tlp2108 tlp2109)
+                        #(tlp2111 ...)
+                        tlp2112
+                        #(tlp2113 tlp2114 tlp2115 tlp2116)))
+                      (=
+                       test-struct-d
+                       #(#&(tlp2118 tlp2119 tlp2120)
+                         ($ test-struct tlp2121 tlp2122 tlp2123 tlp2124)
+                         tlp2126
+                         ())))
+                 (and (? test-struct? tlp2139)
+                      (= test-struct-a _)
+                      (=
+                       test-struct-b
+                       (and (? test-struct? tlp2134)
+                            (= test-struct-a _)
+                            (= test-struct-b #(tlp2129 ___))
+                            (=
+                             test-struct-c
+                             (tlp2130 tlp2131 tlp2132 quote symbols))
+                            (= test-struct-d 'these)))
+                      (=
+                       test-struct-c
+                       (and (? number? tlp2135) (? even? tlp2136)))
+                      (= test-struct-d tlp2137))
+                 #(tlp2140 ...)
+                 tlp2141)
+                (list
+                 tlp2106
+                 tlp2107
+                 tlp2108
+                 tlp2109
+                 tlp2111
+                 tlp2112
+                 tlp2113
+                 tlp2114
+                 tlp2115
+                 tlp2116
+                 tlp2118
+                 tlp2119
+                 tlp2120
+                 tlp2121
+                 tlp2122
+                 tlp2123
+                 tlp2124
+                 tlp2126
+                 tlp2129
+                 tlp2130
+                 tlp2131
+                 tlp2132
+                 tlp2135
+                 tlp2137
+                 tlp2140
+                 tlp2141))
+               ((($
+                  test-struct
+                  (($ test-struct tlp2142 tlp2143 tlp2144 tlp2145)
+                   (not (not #f))
+                   tlp2147
+                   .
+                   #t)
+                  _
+                  tlp2148
+                  ((and (? test-struct? tlp2154)
+                        (= test-struct-a tlp2149)
+                        (= test-struct-b tlp2150)
+                        (= test-struct-c tlp2151)
+                        (= test-struct-d tlp2152))
+                   (and tlp2155 tlp2156)
+                   #&(tlp2157 tlp2158 tlp2159)
+                   .
+                   #\b))
+                 (tlp2161 __3)
+                 'these
+                 (and (? number? tlp2162) (? even? tlp2163)))
+                (list
+                 tlp2142
+                 tlp2143
+                 tlp2144
+                 tlp2145
+                 tlp2147
+                 tlp2148
+                 tlp2149
+                 tlp2150
+                 tlp2151
+                 tlp2152
+                 tlp2155
+                 tlp2157
+                 tlp2158
+                 tlp2159
+                 tlp2161
+                 tlp2162)))))
+       (list
+        (mytest
+         (tlp2164 `(14 ,inst-struct-name2104 #t #\a))
+         '(14 (symbols 1 (+ 4 5)) 12 0))
+        (mytest
+         (tlp2164
+           `(,inst-struct-name2127
+             ,inst-struct-name2138
+             #(#\a #\a (+ 4 5))
+             #\d))
+         '(#\a
+           #\a
+           these
+           symbols
+           (#t 4 7)
+           (+ 1 2)
+           2
+           symbols
+           (+ 4 (+ 1 1))
+           5
+           are
+           6
+           #\c
+           #\c
+           (+ 4 (+ 1 1))
+           #\c
+           2
+           9
+           (#\b #\a #\d)
+           (+ 4 5)
+           #\d
+           #\b
+           10
+           #\d
+           (#\a #\a (+ 4 5))
+           #\d))
+        (mytest
+         (tlp2164 `(,inst-struct-name2160 (#\a 0 are) these 0))
+         '(9
+           #t
+           #t
+           (+ 4 5)
+           3
+           #\c
+           #\c
+           symbols
+           (+ 4 (+ 1 1))
+           #\a
+           #f
+           7
+           0
+           2
+           (#\a 0 are)
+           0))))))
+
+  (define (mult-match-lambda*-tests)
+    (list
+     (let ((tlp2271
+             (match-lambda*
+               (((not (not #\b)) '(+ 4 (+ 1 1)) #(tlp2260 ...) _)
+                (list tlp2260))
+               ((()
+                 (and (? test-struct? tlp2264)
+                      (= test-struct-a (not (not #\a)))
+                      (= test-struct-b #(tlp2261 ...))
+                      (= test-struct-c (or () ()))
+                      (=
+                       test-struct-d
+                       ('(+ 1 2) (tlp2262 ...) (not (not #\b)) quote these)))
+                 (or (tlp2265 __3) (tlp2265 __3))
+                 ())
+                (list tlp2261 tlp2262 tlp2265))
+               (((tlp2266 ___)
+                 ($ test-struct (tlp2267 __3) (not (not 'are)) tlp2268 ())
+                 (tlp2270 __3)
+                 (and #f #f))
+                (list tlp2266 tlp2267 tlp2268 tlp2270)))))
+       (list
+        (mytest
+         (tlp2271 `#\b `(+ 4 (+ 1 1)) `#((+ 1 2) #f symbols) `#\d)
+         '(((+ 1 2) #f symbols)))
+        (mytest
+         (tlp2271 `() `,inst-struct-name2263 `(symbols 1 symbols) `())
+         '((#\d symbols (+ 4 5)) (are #\b #\d) (symbols 1 symbols)))
+        (mytest
+         (tlp2271
+           `(#t #\b (+ 4 5))
+           `,inst-struct-name2269
+           `((+ 4 (+ 1 1)) #f these)
+           `#f)
+         '((#t #\b (+ 4 5)) (symbols #\a #\a) #f ((+ 4 (+ 1 1)) #f these)))))
+     (let ((tlp2315
+             (match-lambda*
+               ((tlp2273
+                  #&(($
+                      test-struct
+                      #(tlp2274 ___)
+                      #(tlp2275 ___)
+                      #(tlp2276 ...)
+                      (and (tlp2277 ___) (tlp2278 ___)))
+                     (and (? number? tlp2280) (? even? tlp2281))
+                     ((and tlp2282 tlp2283) tlp2284 _ (tlp2285 ___)))
+                  _
+                  (and (? number? tlp2286) (? even? tlp2287)))
+                (list
+                 tlp2273
+                 tlp2274
+                 tlp2275
+                 tlp2276
+                 tlp2277
+                 tlp2280
+                 tlp2282
+                 tlp2284
+                 tlp2285
+                 tlp2286))
+               ((tlp2288
+                  (and (('(+ 4 5)
+                         (tlp2289 tlp2290 tlp2291 tlp2292)
+                         (not (not #\a))
+                         .
+                         #\b)
+                        (()
+                         #\a
+                         (and (? number? tlp2293) (? even? tlp2294))
+                         quote
+                         these)
+                        (tlp2295 ___)
+                        .
+                        6)
+                       (('(+ 4 5)
+                         (tlp2296 tlp2297 tlp2298 tlp2299)
+                         (not (not #\a))
+                         .
+                         #\b)
+                        (()
+                         #\a
+                         (and (? number? tlp2300) (? even? tlp2301))
+                         quote
+                         these)
+                        (tlp2302 ___)
+                        .
+                        6))
+                  #&(()
+                     _
+                     (and (? test-struct? tlp2306)
+                          (= test-struct-a tlp2303)
+                          (= test-struct-b ())
+                          (= test-struct-c #t)
+                          (= test-struct-d (or (tlp2304 ..3) (tlp2304 ..3)))))
+                  ($
+                   test-struct
+                   tlp2307
+                   ()
+                   (not (not 'symbols))
+                   (or (and (? number? tlp2308) (? even? tlp2309))
+                       (and (? number? tlp2308) (? even? tlp2309)))))
+                (list
+                 tlp2288
+                 tlp2289
+                 tlp2290
+                 tlp2291
+                 tlp2292
+                 tlp2293
+                 tlp2295
+                 tlp2303
+                 tlp2304
+                 tlp2307
+                 tlp2308))
+               ((tlp2311 (or tlp2312 tlp2312) #(tlp2313 ___) tlp2314)
+                (list tlp2311 tlp2312 tlp2313 tlp2314)))))
+       (list
+        (mytest
+         (tlp2315
+           `1
+           `#&(,inst-struct-name2279 4 (#f #f #\d (#\b #\c #t)))
+           `(+ 1 2)
+           `12)
+         '(1
+           (#\a #\b symbols)
+           ((+ 4 (+ 1 1)) #\d 2)
+           (#f #\b (+ 1 2))
+           (these #\b are)
+           4
+           #f
+           #f
+           (#\b #\c #t)
+           12))
+        (mytest
+         (tlp2315
+           `#f
+           `(((+ 4 5) (#f symbols (+ 4 (+ 1 1)) #\a) #\a . #\b)
+             (() #\a 0 . these)
+             (symbols symbols #\c)
+             .
+             6)
+           `#&(() #\d ,inst-struct-name2305)
+           `,inst-struct-name2310)
+         '(#f
+           #f
+           symbols
+           (+ 4 (+ 1 1))
+           #\a
+           0
+           (symbols symbols #\c)
+           #\c
+           (#\c 0 9)
+           #\b
+           18))
+        (mytest
+         (tlp2315 `(+ 4 (+ 1 1)) `(+ 1 2) `#(6 4 #t) `#\d)
+         '((+ 4 (+ 1 1)) (+ 1 2) (6 4 #t) #\d))))
+     (let ((tlp2414
+             (match-lambda*
+               (((not (not #\b))
+                 _
+                 ((tlp2317 ...)
+                  (tlp2318 ..3)
+                  #(tlp2319
+                    _
+                    #&(tlp2320 tlp2321 tlp2322)
+                    ($ test-struct tlp2323 tlp2324 tlp2325 tlp2326))
+                  '(+ 4 5))
+                 (tlp2328 __3))
+                (list
+                 tlp2317
+                 tlp2318
+                 tlp2319
+                 tlp2320
+                 tlp2321
+                 tlp2322
+                 tlp2323
+                 tlp2324
+                 tlp2325
+                 tlp2326
+                 tlp2328))
+               ((tlp2329
+                  (tlp2330 ...)
+                  (($
+                    test-struct
+                    _
+                    ($ test-struct tlp2331 tlp2332 tlp2333 tlp2334)
+                    _
+                    ())
+                   tlp2337
+                   (and (and #&(tlp2338 tlp2339 tlp2340)
+                             #&(tlp2341 tlp2342 tlp2343))
+                        (and #&(tlp2344 tlp2345 tlp2346)
+                             #&(tlp2347 tlp2348 tlp2349)))
+                   (and #\d #\d))
+                  ((($ test-struct tlp2350 tlp2351 tlp2352 tlp2353)
+                    (or ($ test-struct tlp2355 tlp2356 tlp2357 tlp2358)
+                        ($ test-struct tlp2355 tlp2356 tlp2357 tlp2358))
+                    (tlp2360 tlp2361 tlp2362 . #\c)
+                    .
+                    #\a)
+                   (tlp2363 ___)
+                   ()
+                   .
+                   3))
+                (list
+                 tlp2329
+                 tlp2330
+                 tlp2331
+                 tlp2332
+                 tlp2333
+                 tlp2334
+                 tlp2337
+                 tlp2338
+                 tlp2339
+                 tlp2340
+                 tlp2350
+                 tlp2351
+                 tlp2352
+                 tlp2353
+                 tlp2355
+                 tlp2356
+                 tlp2357
+                 tlp2358
+                 tlp2360
+                 tlp2361
+                 tlp2362
+                 tlp2363))
+               (((and (? test-struct? tlp2396)
+                      (=
+                       test-struct-a
+                       (and (? test-struct? tlp2371)
+                            (= test-struct-a tlp2364)
+                            (= test-struct-b tlp2365)
+                            (= test-struct-c (tlp2366 tlp2367 tlp2368 tlp2369))
+                            (= test-struct-d ())))
+                      (=
+                       test-struct-b
+                       ($
+                        test-struct
+                        (and (? test-struct? tlp2377)
+                             (= test-struct-a tlp2372)
+                             (= test-struct-b tlp2373)
+                             (= test-struct-c tlp2374)
+                             (= test-struct-d tlp2375))
+                        (tlp2378 ..3)
+                        (and (? number? tlp2379) (? even? tlp2380))
+                        #(tlp2381 ...)))
+                      (=
+                       test-struct-c
+                       #&((tlp2383 ..3)
+                          (and (? test-struct? tlp2389)
+                               (= test-struct-a tlp2384)
+                               (= test-struct-b tlp2385)
+                               (= test-struct-c tlp2386)
+                               (= test-struct-d tlp2387))
+                          tlp2390))
+                      (=
+                       test-struct-d
+                       (and (and (? number? tlp2391) (? even? tlp2392))
+                            (and (? number? tlp2393) (? even? tlp2394)))))
+                 ('(+ 1 2)
+                  #(tlp2397 ___)
+                  ($
+                   test-struct
+                   #(tlp2398 tlp2399 tlp2400 tlp2401)
+                   (and (? number? tlp2402) (? even? tlp2403))
+                   tlp2404
+                   (tlp2405 tlp2406 tlp2407 quote symbols))
+                  _)
+                 ($
+                  test-struct
+                  (tlp2409 ..3)
+                  (not (not #\a))
+                  tlp2410
+                  (and (? number? tlp2411) (? even? tlp2412)))
+                 ())
+                (list
+                 tlp2364
+                 tlp2365
+                 tlp2366
+                 tlp2367
+                 tlp2368
+                 tlp2369
+                 tlp2372
+                 tlp2373
+                 tlp2374
+                 tlp2375
+                 tlp2378
+                 tlp2379
+                 tlp2381
+                 tlp2383
+                 tlp2384
+                 tlp2385
+                 tlp2386
+                 tlp2387
+                 tlp2390
+                 tlp2391
+                 tlp2397
+                 tlp2398
+                 tlp2399
+                 tlp2400
+                 tlp2401
+                 tlp2402
+                 tlp2404
+                 tlp2405
+                 tlp2406
+                 tlp2407
+                 tlp2409
+                 tlp2410
+                 tlp2411)))))
+       (list
+        (mytest
+         (tlp2414
+           `#\b
+           `#\c
+           `((#f (+ 4 (+ 1 1)) #\a)
+             (#\c are (+ 4 (+ 1 1)))
+             #(are #\c #&(#t 5 (+ 4 (+ 1 1))) ,inst-struct-name2327)
+             (+ 4 5))
+           `((+ 4 5) #\b #\a))
+         '((#f (+ 4 (+ 1 1)) #\a)
+           (#\c are (+ 4 (+ 1 1)))
+           are
+           #t
+           5
+           (+ 4 (+ 1 1))
+           #\d
+           #f
+           these
+           3
+           ((+ 4 5) #\b #\a)))
+        (mytest
+         (tlp2414
+           `#t
+           `(#\b #\c (+ 4 5))
+           `(,inst-struct-name2336 #\b #&(#\a symbols #\d) #\d)
+           `((,inst-struct-name2354
+              ,inst-struct-name2359
+              ((+ 4 (+ 1 1)) #\a (+ 1 2) . #\c)
+              .
+              #\a)
+             (#t 7 6)
+             ()
+             .
+             3))
+         '(#t
+           (#\b #\c (+ 4 5))
+           #f
+           #\c
+           #\d
+           2
+           #\b
+           #\a
+           symbols
+           #\d
+           (+ 1 2)
+           #\b
+           0
+           #\d
+           #\d
+           #f
+           (+ 4 (+ 1 1))
+           #f
+           (+ 4 (+ 1 1))
+           #\a
+           (+ 1 2)
+           (#t 7 6)))
+        (mytest
+         (tlp2414
+           `,inst-struct-name2395
+           `((+ 1 2) #(#\a 7 #f) ,inst-struct-name2408 (+ 1 2))
+           `,inst-struct-name2413
+           `())
+         '(#\d
+           #\c
+           these
+           6
+           #\a
+           (+ 1 2)
+           (+ 1 2)
+           1
+           3
+           #\a
+           (#\b (+ 4 5) (+ 1 2))
+           18
+           (8 #\a (+ 4 5))
+           (#\c #\c (+ 1 2))
+           #f
+           4
+           3
+           #t
+           (+ 4 5)
+           14
+           (#\a 7 #f)
+           #\d
+           #f
+           these
+           symbols
+           10
+           these
+           (+ 4 (+ 1 1))
+           symbols
+           (+ 4 5)
+           (0 #\b #\b)
+           symbols
+           2))))
+     (let ((tlp2448
+             (match-lambda*
+               ((tlp2416
+                  (not (not #t))
+                  (or ((and (tlp2417 ...) (tlp2418 ...))
+                       #((tlp2419 tlp2420 tlp2421 . tlp2422)
+                         #\c
+                         tlp2423
+                         (tlp2424 tlp2425 tlp2426 . tlp2427))
+                       9
+                       quote
+                       are)
+                      ((and (tlp2417 ...) (tlp2418 ...))
+                       #((tlp2419 tlp2420 tlp2421 . tlp2422)
+                         #\c
+                         tlp2423
+                         (tlp2424 tlp2425 tlp2426 . tlp2427))
+                       9
+                       quote
+                       are))
+                  (tlp2428
+                    (and (? number? tlp2429) (? even? tlp2430))
+                    (not (not '(+ 4 5)))
+                    (or ($
+                         test-struct
+                         #&(tlp2431 tlp2432 tlp2433)
+                         #f
+                         #(tlp2434 tlp2435 tlp2436 tlp2437)
+                         _)
+                        ($
+                         test-struct
+                         #&(tlp2431 tlp2432 tlp2433)
+                         #f
+                         #(tlp2434 tlp2435 tlp2436 tlp2437)
+                         _))))
+                (list
+                 tlp2416
+                 tlp2417
+                 tlp2419
+                 tlp2420
+                 tlp2421
+                 tlp2422
+                 tlp2423
+                 tlp2424
+                 tlp2425
+                 tlp2426
+                 tlp2427
+                 tlp2417
+                 tlp2419
+                 tlp2420
+                 tlp2421
+                 tlp2422
+                 tlp2423
+                 tlp2424
+                 tlp2425
+                 tlp2426
+                 tlp2427
+                 tlp2428
+                 tlp2429
+                 tlp2431
+                 tlp2432
+                 tlp2433
+                 tlp2434
+                 tlp2435
+                 tlp2436
+                 tlp2437))
+               ((#(() (not (not #\d)) #&((not (not 9)) () 'symbols) ())
+                 _
+                 tlp2439
+                 (tlp2440 _ tlp2441 . #t))
+                (list tlp2439 tlp2440 tlp2441))
+               (((or (not (not #\b)) (not (not #\b)))
+                 (tlp2442 () () (and #(tlp2443 ...) #(tlp2444 ...)))
+                 (tlp2445 ___)
+                 (or (and (? number? tlp2446) (? even? tlp2447))
+                     (and (? number? tlp2446) (? even? tlp2447))))
+                (list tlp2442 tlp2443 tlp2445 tlp2446)))))
+       (list
+        (mytest
+         (tlp2448
+           `3
+           `#t
+           `((#\b #f are)
+             #((#\d these symbols . #f) #\c #\c (these 4 #t . are))
+             9
+             .
+             are)
+           `(#\b 8 (+ 4 5) ,inst-struct-name2438))
+         '(3
+           (#\b #f are)
+           #\d
+           these
+           symbols
+           #f
+           #\c
+           these
+           4
+           #t
+           are
+           (#\b #f are)
+           #\d
+           these
+           symbols
+           #f
+           #\c
+           these
+           4
+           #t
+           are
+           #\b
+           8
+           (+ 4 (+ 1 1))
+           (+ 1 2)
+           (+ 4 5)
+           (+ 4 (+ 1 1))
+           9
+           #t
+           #\c))
+        (mytest
+         (tlp2448
+           `#(() #\d #&(9 () symbols) ())
+           `#\a
+           `#\c
+           `(#\c #\a (+ 4 (+ 1 1)) . #t))
+         '(#\c #\c (+ 4 (+ 1 1))))
+        (mytest
+         (tlp2448
+           `#\b
+           `((+ 4 (+ 1 1)) () () #(#\a these these))
+           `((+ 4 5) these (+ 4 5))
+           `18)
+         '((+ 4 (+ 1 1)) (#\a these these) ((+ 4 5) these (+ 4 5)) 18))))
+     (let ((tlp2485
+             (match-lambda*
+               (((not (not #t))
+                 tlp2450
+                 (or #&(($
+                         test-struct
+                         #(tlp2451 ...)
+                         #\d
+                         (or tlp2452 tlp2452)
+                         #(tlp2453 ___))
+                        (tlp2455 ..3)
+                        tlp2456)
+                     #&(($
+                         test-struct
+                         #(tlp2451 ...)
+                         #\d
+                         (or tlp2452 tlp2452)
+                         #(tlp2453 ___))
+                        (tlp2455 ..3)
+                        tlp2456))
+                 (or (tlp2457 ...) (tlp2457 ...)))
+                (list tlp2450 tlp2451 tlp2452 tlp2453 tlp2455 tlp2456 tlp2457))
+               (((#&((or _ _) () (tlp2458 ..3)) tlp2459 #(tlp2460 ___) . #t)
+                 (and (? test-struct? tlp2470)
+                      (= test-struct-a (not (not #\b)))
+                      (=
+                       test-struct-b
+                       ($
+                        test-struct
+                        ()
+                        (not (not #\b))
+                        'symbols
+                        (or #(tlp2461 tlp2462 tlp2463 tlp2464)
+                            #(tlp2461 tlp2462 tlp2463 tlp2464))))
+                      (= test-struct-c #\d)
+                      (=
+                       test-struct-d
+                       #&((and tlp2466 tlp2467) #(tlp2468 ___) _)))
+                 #(tlp2471 ___)
+                 (not (not 9)))
+                (list
+                 tlp2458
+                 tlp2459
+                 tlp2460
+                 tlp2461
+                 tlp2462
+                 tlp2463
+                 tlp2464
+                 tlp2466
+                 tlp2468
+                 tlp2471))
+               ((#((and (? number? tlp2472) (? even? tlp2473))
+                   ()
+                   ($
+                    test-struct
+                    #(tlp2474 tlp2475 tlp2476 tlp2477)
+                    (tlp2478 ___)
+                    (tlp2479 ..3)
+                    '(+ 1 2))
+                   (or _ _))
+                 (tlp2481 ..3)
+                 tlp2482
+                 (and (? number? tlp2483) (? even? tlp2484)))
+                (list
+                 tlp2472
+                 tlp2474
+                 tlp2475
+                 tlp2476
+                 tlp2477
+                 tlp2478
+                 tlp2479
+                 tlp2481
+                 tlp2482
+                 tlp2483)))))
+       (list
+        (mytest
+         (tlp2485
+           `#t
+           `#\d
+           `#&(,inst-struct-name2454 ((+ 1 2) #t #\a) (+ 1 2))
+           `(symbols #\b #\c))
+         '(#\d
+           (#\a symbols 8)
+           #f
+           (1 #\c 4)
+           ((+ 1 2) #t #\a)
+           (+ 1 2)
+           (symbols #\b #\c)))
+        (mytest
+         (tlp2485
+           `(#&(#t () (3 these #t)) #\c #(are 3 (+ 4 (+ 1 1))) . #t)
+           `,inst-struct-name2469
+           `#(#f (+ 1 2) #t)
+           `9)
+         '((3 these #t)
+           #\c
+           (are 3 (+ 4 (+ 1 1)))
+           #t
+           (+ 4 5)
+           #t
+           #\d
+           #\b
+           (4 are 1)
+           (#f (+ 1 2) #t)))
+        (mytest
+         (tlp2485 `#(10 () ,inst-struct-name2480 #\b) `(4 #\c (+ 4 5)) `#\c `6)
+         '(10
+           (+ 1 2)
+           7
+           are
+           #\b
+           (#\b symbols #\d)
+           (#\d symbols symbols)
+           (4 #\c (+ 4 5))
+           #\c
+           6))))))
+  ;(define (extra-tests) (list (include "hand-made-match-tests.scm")))
+  (define (test-all2)
+    (list
+   ;  (let-tests)
+   ;  (define-tests)
+   ;  (sing-match-tests)
+     (mult-match-tests)
+   ;  (sing-match-lambda-tests)
+     (mult-match-lambda-tests)
+   ;  (sing-match-lambda*-tests)
+     (mult-match-lambda*-tests)
+     ;(extra-tests)
+     ))
+
+(test-all2)
+
+(report-errs)
\ No newline at end of file
diff --git a/collects/tests/mzscheme/match/misc-structs.scm b/collects/tests/mzscheme/match/misc-structs.scm
new file mode 100644
index 0000000000..0691b37e4b
--- /dev/null
+++ b/collects/tests/mzscheme/match/misc-structs.scm
@@ -0,0 +1,1215 @@
+;; structure tests
+
+(define-struct shape (color))
+(define-struct (ovoid shape) (x-diam y-diam))
+(define-struct (circle ovoid) (radius))
+(define-struct (rectangle shape) (height width))
+(define-struct (square rectangle) (width))
+(define c (make-circle 5 4 3 2))
+
+
+(define-struct test-struct (a b c d))
+  (define inst-struct-name29 (make-test-struct `#\b `2 `(+ 4 5) `symbols))
+  (define inst-struct-name33
+    (make-test-struct
+      `(,inst-struct-name29 (+ 1 2) #\c (+ 4 5))
+      `()
+      `(these #\d #t)
+      `16))
+  (define inst-struct-name46 (make-test-struct `#\c `#\d `16 `4))
+  (define inst-struct-name54 (make-test-struct `#\c `4 `#\c `#\b))
+  (define inst-struct-name72 (make-test-struct `#f `4 `4 `#\c))
+  (define inst-struct-name75
+    (make-test-struct
+      `(+ 4 (+ 1 1))
+      `,inst-struct-name72
+      `#3(9 #\b 9)
+      `(+ 4 5)))
+  (define inst-struct-name77
+    (make-test-struct `#\c `(#\d symbols these) `,inst-struct-name75 `these))
+  (define inst-struct-name84 (make-test-struct `#\b `4 `#\c `#\d))
+  (define inst-struct-name90 (make-test-struct `symbols `#\a `#\c `symbols))
+  (define inst-struct-name116
+    (make-test-struct `symbols `(+ 4 (+ 1 1)) `4 `#\b))
+  (define inst-struct-name145 (make-test-struct `(+ 1 2) `4 `symbols `these))
+  (define inst-struct-name147
+    (make-test-struct
+      `#f
+      `((+ 4 (+ 1 1)) these 6)
+      `#4(are () ,inst-struct-name145 (+ 4 (+ 1 1)))
+      `()))
+  (define inst-struct-name158
+    (make-test-struct `18 `(#\b 2 #t) `() `(+ 4 (+ 1 1))))
+  (define inst-struct-name164
+    (make-test-struct
+      `()
+      `,inst-struct-name158
+      `#\d
+      `(#3(these these 1) #\b (#\c #f (+ 4 (+ 1 1))) . #f)))
+  (define inst-struct-name173 (make-test-struct `#\b `#\b `#\b `are))
+  (define inst-struct-name175
+    (make-test-struct `() `#&((+ 1 2) #t (+ 4 5)) `,inst-struct-name173 `#t))
+  (define inst-struct-name190
+    (make-test-struct
+      `,inst-struct-name175
+      `()
+      `#f
+      `((are #\b 5) these #4((+ 1 2) 8 these (+ 1 2)) . #f)))
+  (define inst-struct-name198 (make-test-struct `these `#t `7 `(+ 4 5)))
+  (define inst-struct-name218
+    (make-test-struct `(+ 4 (+ 1 1)) `#4((+ 4 5) symbols 2 4) `#\a `#\d))
+  (define inst-struct-name224 (make-test-struct `#\b `(+ 1 2) `4 `these))
+  (define inst-struct-name250 (make-test-struct `7 `symbols `are `these))
+  (define inst-struct-name260
+    (make-test-struct
+      `(symbols #\b symbols)
+      `()
+      `(symbols (+ 1 2) 5 #\d)
+      `(#\a #\c #\c . 1)))
+  (define inst-struct-name272
+    (make-test-struct `#&(#\b #\a #f) `#3((+ 4 5) #\b #t) `#\b `(+ 4 (+ 1 1))))
+  (define inst-struct-name281 (make-test-struct `#\b `5 `(+ 1 2) `4))
+  (define inst-struct-name286 (make-test-struct `#\b `(+ 4 5) `0 `1))
+  (define inst-struct-name288
+    (make-test-struct
+      `#&(#\b #\b #\b)
+      `(these (+ 1 2) #\c)
+      `,inst-struct-name281
+      `,inst-struct-name286))
+  (define inst-struct-name304 (make-test-struct `#\d `are `#f `7))
+  (define inst-struct-name305
+    (make-test-struct `#\d `(7 #\c #\c) `2 `,inst-struct-name304))
+  (define inst-struct-name317 (make-test-struct `9 `#\c `symbols `#\b))
+  (define inst-struct-name318
+    (make-test-struct `() `,inst-struct-name317 `symbols `0))
+  (define inst-struct-name334 (make-test-struct `#\d `#f `(+ 4 5) `7))
+  (define inst-struct-name350
+    (make-test-struct
+      `()
+      `(+ 4 (+ 1 1))
+      `#&(#\d 2 #f)
+      `#4(#\a these #t (+ 1 2))))
+  (define inst-struct-name359
+    (make-test-struct `(+ 4 (+ 1 1)) `(+ 4 5) `#\b `#\a))
+  (define inst-struct-name372 (make-test-struct `symbols `6 `4 `#\c))
+  (define inst-struct-name385 (make-test-struct `#\d `8 `#\a `#\a))
+  (define inst-struct-name399
+    (make-test-struct `4 `() `#\a `#3(#f (+ 4 5) #f)))
+  (define inst-struct-name408
+    (make-test-struct `these `(+ 4 (+ 1 1)) `((+ 4 (+ 1 1)) (+ 4 5) are) `#\a))
+  (define inst-struct-name417
+    (make-test-struct `6 `#\b `(+ 4 (+ 1 1)) `(+ 4 5)))
+  (define inst-struct-name424
+    (make-test-struct
+      `(#4((+ 4 (+ 1 1)) #\b 7 #\a)
+        ,inst-struct-name417
+        ((+ 4 5) are 9 . these)
+        .
+        #f)
+      `(#t #\a #f)
+      `()
+      `(are #\b 4)))
+  (define inst-struct-name431
+    (make-test-struct
+      `these
+      `3
+      `#4((+ 4 (+ 1 1)) symbols 1 are)
+      `(8 #t (+ 4 (+ 1 1)))))
+  (define inst-struct-name433
+    (make-test-struct `() `1 `,inst-struct-name431 `are))
+  (define inst-struct-name477
+    (make-test-struct `#t `() `these `#4((+ 4 5) #t #t #\c)))
+  (define inst-struct-name487
+    (make-test-struct `((7 these #\b) (+ 4 (+ 1 1)) #t . 0) `() `(+ 4 5) `7))
+  (define inst-struct-name514
+    (make-test-struct `(+ 4 5) `#\b `(+ 4 (+ 1 1)) `#t))
+  (define inst-struct-name522
+    (make-test-struct
+      `,inst-struct-name514
+      `(#\b #t #\d . #\a)
+      `(7 5 #f . #\b)
+      `#\c))
+  (define inst-struct-name530 (make-test-struct `8 `5 `#\c `7))
+  (define inst-struct-name541 (make-test-struct `(+ 1 2) `4 `symbols `(+ 1 2)))
+  (define inst-struct-name545
+    (make-test-struct `,inst-struct-name541 `8 `() `()))
+  (define inst-struct-name547
+    (make-test-struct
+      `are
+      `(9 (#f symbols #\d) ,inst-struct-name530 symbols)
+      `(4 #\b #t)
+      `,inst-struct-name545))
+  (define inst-struct-name554
+    (make-test-struct `#3(#\d #f #\d) `are `1 `(+ 4 (+ 1 1))))
+  (define inst-struct-name597 (make-test-struct `#\d `(+ 4 (+ 1 1)) `2 `#\a))
+  (define inst-struct-name600
+    (make-test-struct
+      `#f
+      `(these #\b 7)
+      `(18 #3(#f (+ 4 5) #t) ,inst-struct-name597 (#t 8 these))
+      `(+ 4 (+ 1 1))))
+  (define inst-struct-name618
+    (make-test-struct `#&((+ 4 5) #\d #\c) `are `() `()))
+  (define inst-struct-name642
+    (make-test-struct `#\d `(+ 4 5) `(+ 4 5) `(+ 1 2)))
+  (define inst-struct-name661 (make-test-struct `#\a `#\c `#f `#\c))
+  (define inst-struct-name669
+    (make-test-struct
+      `,inst-struct-name661
+      `(#\b #\b #f . #\a)
+      `(#\d #t (+ 1 2) . #\b)
+      `#t))
+
+ (define inst-struct-name3134 (make-test-struct `6 `#t `(+ 4 (+ 1 1)) `#\a))
+  (define inst-struct-name3144 (make-test-struct `#\a `3 `(+ 4 5) `7))
+  (define inst-struct-name3157
+    (make-test-struct
+      `#&((#f (+ 1 2) #\d #\b) (#\d 1 symbols) ,inst-struct-name3134)
+      `((5 7 symbols #t)
+        ,inst-struct-name3144
+        #((+ 4 (+ 1 1)) #f #\a #\d)
+        .
+        #\d)
+      `(#\a (+ 4 (+ 1 1)) these)
+      `(#\b 3 4 #&((+ 4 (+ 1 1)) #f 2))))
+  (define inst-struct-name3197
+    (make-test-struct `(8 #\b (+ 1 2)) `(+ 1 2) `#\a `((+ 1 2) #f 5)))
+  (define inst-struct-name3200
+    (make-test-struct
+      `#(#\b symbols (+ 1 2))
+      `symbols
+      `,inst-struct-name3197
+      `5))
+  (define inst-struct-name3228 (make-test-struct `these `3 `#\d `#t))
+  (define inst-struct-name3234 (make-test-struct `(+ 4 5) `#\a `#\a `#f))
+  (define inst-struct-name3239
+    (make-test-struct `() `#(#\d #\b #\b) `#\c `#\b))
+  (define inst-struct-name3252
+    (make-test-struct
+      `(#t #\c #\c . are)
+      `#((+ 1 2) (+ 4 5) #\b 9)
+      `16
+      `(+ 4 5)))
+  (define inst-struct-name3287
+    (make-test-struct `#\d `#((+ 4 5) #t (+ 4 5) #t) `#t `(+ 4 (+ 1 1))))
+  (define inst-struct-name3297
+    (make-test-struct `these `#f `#(are symbols #\c) `#(these symbols #t #\d)))
+  (define inst-struct-name3307 (make-test-struct `#t `(+ 4 (+ 1 1)) `#\d `#f))
+  (define inst-struct-name3312
+    (make-test-struct
+      `#&(symbols #\d #\c)
+      `,inst-struct-name3307
+      `(these are (+ 1 2) (+ 4 5))
+      `#f))
+  (define inst-struct-name3322
+    (make-test-struct
+      `(#t 6 #\c)
+      `(#t #\d 2 . #\a)
+      `#(#f 6 #\b)
+      `#&(#f 7 symbols)))
+  (define inst-struct-name3355 (make-test-struct `(+ 1 2) `these `#t `#t))
+  (define inst-struct-name3367 (make-test-struct `#\d `#\a `6 `(+ 1 2)))
+  (define inst-struct-name3372 (make-test-struct `symbols `#\a `3 `#\c))
+  (define inst-struct-name3396 (make-test-struct `0 `#\d `#\a `#\b))
+  (define inst-struct-name3419 (make-test-struct `#\c `#\c `symbols `9))
+  (define inst-struct-name3444
+    (make-test-struct
+      `(#\c (+ 4 (+ 1 1)) (+ 4 5))
+      `()
+      `((6 #\a 2) 0 #(these #\c these 1) . 5)
+      `#(#f #\a #\d)))
+  (define inst-struct-name3455
+    (make-test-struct
+      `()
+      `(#\d #t symbols . #\d)
+      `#&(#\d (+ 4 (+ 1 1)) these)
+      `2))
+  (define inst-struct-name3474
+    (make-test-struct `(#t #\c #f . #\d) `#\a `() `(#t #\a #\a)))
+  (define inst-struct-name3482 (make-test-struct `symbols `#\b `#f `#f))
+  (define inst-struct-name3493
+    (make-test-struct
+      `16
+      `(,inst-struct-name3482 #(#f #\c (+ 4 5) #f) #&((+ 4 5) #\d are) (+ 4 5))
+      `#(#t #f 4)
+      `#\d))
+  (define inst-struct-name3505 (make-test-struct `4 `(+ 4 (+ 1 1)) `#f `these))
+  (define inst-struct-name3512
+    (make-test-struct
+      `#&(symbols #f 2)
+      `()
+      `#t
+      `(are (+ 4 (+ 1 1)) (+ 4 (+ 1 1)))))
+  (define inst-struct-name3518 (make-test-struct `8 `#\b `#\c `symbols))
+  (define inst-struct-name3527 (make-test-struct `#\a `#t `4 `#t))
+  (define inst-struct-name3550
+    (make-test-struct `(+ 4 (+ 1 1)) `(#t 8 symbols) `(#\a #\c #t) `0))
+  (define inst-struct-name3570 (make-test-struct `#\b `#\c `#\d `#\c))
+  (define inst-struct-name3577 (make-test-struct `#\b `(+ 1 2) `#\b `#\b))
+  (define inst-struct-name3578
+    (make-test-struct `,inst-struct-name3570 `16 `,inst-struct-name3577 `9))
+  (define inst-struct-name3595
+    (make-test-struct
+      `(0 these are)
+      `(#\d #f (+ 4 (+ 1 1)) . #\c)
+      `#(#\b #\a these symbols)
+      `#\b))
+  (define inst-struct-name3600 (make-test-struct `#\a `0 `2 `2))
+  (define inst-struct-name3605 (make-test-struct `are `1 `3 `#\d))
+  (define inst-struct-name3625
+    (make-test-struct
+      `()
+      `#\a
+      `#(#\a #\c (+ 1 2) #t)
+      `#((+ 4 (+ 1 1)) #\b 5 these)))
+  (define inst-struct-name3633 (make-test-struct `(+ 4 (+ 1 1)) `are `#f `#\c))
+  (define inst-struct-name3639
+    (make-test-struct `#\a `,inst-struct-name3633 `#&(are symbols 4) `#\c))
+  (define inst-struct-name3677
+    (make-test-struct `#(#\b are #\b) `#\a `#\c `(#\b #\c #\d . #\d)))
+  (define inst-struct-name3701
+    (make-test-struct `#\b `9 `#&(#\c (#f #\d (+ 1 2)) are) `#\d))
+  (define inst-struct-name3712
+    (make-test-struct `#\d `#\d `(+ 4 (+ 1 1)) `are))
+  (define inst-struct-name3744
+    (make-test-struct `symbols `(+ 1 2) `symbols `#\b))
+  (define inst-struct-name3752 (make-test-struct `#\b `#t `(+ 4 5) `#\b))
+  (define inst-struct-name3753
+    (make-test-struct
+      `,inst-struct-name3744
+      `#(#\c #\d #\d)
+      `#\b
+      `,inst-struct-name3752))
+  (define inst-struct-name3755
+    (make-test-struct `(these 0 3) `(+ 4 5) `2 `,inst-struct-name3753))
+  (define inst-struct-name3762 (make-test-struct `these `(+ 1 2) `2 `#\d))
+  (define inst-struct-name3776 (make-test-struct `#\b `#\b `symbols `these))
+  (define inst-struct-name3777
+    (make-test-struct
+      `#&(symbols (+ 4 (+ 1 1)) (+ 1 2))
+      `#(#\c 6 #\c #t)
+      `#\b
+      `,inst-struct-name3776))
+  (define inst-struct-name3805
+    (make-test-struct `#\d `#&((+ 1 2) #\d 1) `(+ 4 5) `#\b))
+  (define inst-struct-name3817 (make-test-struct `1 `(+ 1 2) `#\d `(+ 1 2)))
+  (define inst-struct-name3820
+    (make-test-struct
+      `#\d
+      `(2 (+ 4 (+ 1 1)) symbols)
+      `,inst-struct-name3817
+      `#((+ 1 2) 8 (+ 4 5))))
+  (define inst-struct-name3822
+    (make-test-struct
+      `,inst-struct-name3805
+      `#&(#&(#f (+ 4 (+ 1 1)) #\d) #\c (#t #\c #f))
+      `(+ 4 5)
+      `,inst-struct-name3820))
+  (define inst-struct-name3851 (make-test-struct `#f `(+ 1 2) `#\a `#f))
+  (define inst-struct-name3854
+    (make-test-struct `#\b `#\b `,inst-struct-name3851 `18))
+  (define inst-struct-name3856
+    (make-test-struct
+      `#&(#t #\a symbols)
+      `(((+ 4 (+ 1 1)) (+ 4 5) #\b) #t 12 #(these #\c #f))
+      `(#(#\d these #\d) #t 7 #f)
+      `,inst-struct-name3854))
+  (define inst-struct-name3890
+    (make-test-struct `#f `(#t #f are symbols) `#\d `#t))
+  (define inst-struct-name3900 (make-test-struct `(+ 4 (+ 1 1)) `0 `#\d `0))
+  (define inst-struct-name3902
+    (make-test-struct
+      `,inst-struct-name3890
+      `(+ 4 5)
+      `()
+      `#((#\a 7 #\b (+ 1 2)) ,inst-struct-name3900 #\b ())))
+  (define inst-struct-name3928
+    (make-test-struct `8 `#\c `#\c `#(8 #\d #f #\a)))
+  (define inst-struct-name3939 (make-test-struct `6 `#\d `(+ 4 (+ 1 1)) `7))
+  (define inst-struct-name3944
+    (make-test-struct
+      `#\d
+      `,inst-struct-name3928
+      `(,inst-struct-name3939 () #&(#\b #f #\b) #t)
+      `(4 (+ 1 2) 3)))
+  (define inst-struct-name3952
+    (make-test-struct `() `7 `(+ 1 2) `(#\d #\d #\c)))
+  (define inst-struct-name3957
+    (make-test-struct `#t `(#\a #\b symbols) `#\d `10))
+  (define inst-struct-name3962 (make-test-struct `4 `(+ 4 (+ 1 1)) `#\c `6))
+  (define inst-struct-name3973 (make-test-struct `#t `1 `2 `#t))
+  (define inst-struct-name3974
+    (make-test-struct `(+ 4 (+ 1 1)) `9 `#f `,inst-struct-name3973))
+  (define inst-struct-name3986 (make-test-struct `these `#\d `#f `#t))
+  (define inst-struct-name3998 (make-test-struct `(+ 4 5) `#f `0 `#\a))
+  (define inst-struct-name4008 (make-test-struct `#\c `#t `#\c `#t))
+  (define inst-struct-name4019
+    (make-test-struct
+      `((+ 4 5) #\b these . 1)
+      `,inst-struct-name4008
+      `(2 #f #t #\d)
+      `#(9 #\b 2)))
+  (define inst-struct-name4024
+    (make-test-struct `#\a `(+ 4 (+ 1 1)) `(+ 4 (+ 1 1)) `#t))
+  (define inst-struct-name4026
+    (make-test-struct `(+ 1 2) `,inst-struct-name4024 `() `#\d))
+  (define inst-struct-name4028
+    (make-test-struct
+      `(#\a 8 #f)
+      `,inst-struct-name4019
+      `()
+      `,inst-struct-name4026))
+  (define inst-struct-name4042
+    (make-test-struct
+      `#\b
+      `(5 (+ 4 5) (+ 4 (+ 1 1)) #\d)
+      `(are #\b these . 2)
+      `#\b))
+  (define inst-struct-name4060 (make-test-struct `0 `symbols `#f `#\a))
+  (define inst-struct-name4063
+    (make-test-struct `8 `#&(5 #\c #f) `,inst-struct-name4060 `10))
+  (define inst-struct-name4064
+    (make-test-struct `4 `#f `0 `,inst-struct-name4063))
+  (define inst-struct-name4088
+    (make-test-struct
+      `#\a
+      `(#\d symbols these)
+      `(#\a are 2 #(#\b 0 symbols #\d))
+      `#f))
+  (define inst-struct-name4109 (make-test-struct `4 `symbols `(+ 4 5) `#\b))
+  (define inst-struct-name4137
+    (make-test-struct `(+ 4 5) `(+ 4 5) `are `these))
+  (define inst-struct-name4145
+    (make-test-struct
+      `,inst-struct-name4137
+      `#\d
+      `#(2 #\c (+ 1 2) #\c)
+      `(#\c 6 9 . 7)))
+  (define inst-struct-name4146
+    (make-test-struct `these `(+ 4 (+ 1 1)) `(+ 1 2) `,inst-struct-name4145))
+  (define inst-struct-name4160 (make-test-struct `4 `#\d `2 `#\a))
+  (define inst-struct-name4174
+    (make-test-struct
+      `these
+      `#((#t (+ 1 2) #\c are) #(#\d (+ 4 5) #\a #\d) ,inst-struct-name4160 #t)
+      `(#\b #\b 9)
+      `#(#\c #(#\c #\c #\c #f) these ())))
+  (define inst-struct-name4181 (make-test-struct `#\c `#(#f #\c #t) `#f `#t))
+  (define inst-struct-name4194 (make-test-struct `#\a `#t `6 `symbols))
+  (define inst-struct-name4208
+    (make-test-struct
+      `(#f 7 #t)
+      `,inst-struct-name4181
+      `#&(#(#f symbols (+ 1 2) #\a)
+          ((+ 1 2) symbols #\b #\c)
+          ,inst-struct-name4194)
+      `#t))
+  (define inst-struct-name4214
+    (make-test-struct `(+ 4 5) `symbols `#\d `these))
+  (define inst-struct-name4239
+    (make-test-struct `(#\c 6 (+ 4 5) . #f) `() `14 `(#\a (+ 4 5) #\a . #\c)))
+  (define inst-struct-name4241
+    (make-test-struct
+      `()
+      `#(these (#\b #\a these #t) (#\a #\c are) (these 4 #\d))
+      `,inst-struct-name4239
+      `()))
+  (define inst-struct-name4252 (make-test-struct `#t `5 `symbols `(+ 1 2)))
+  (define inst-struct-name4260
+    (make-test-struct `() `symbols `#t `(#\d (+ 4 5) #\b 6)))
+  (define inst-struct-name4266
+    (make-test-struct `symbols `symbols `(+ 4 (+ 1 1)) `(+ 1 2)))
+  (define inst-struct-name4280 (make-test-struct `#\c `8 `#\d `#t))
+  (define inst-struct-name4287
+    (make-test-struct `,inst-struct-name4280 `4 `#\b `(#\b #t #f . #t)))
+  (define inst-struct-name4293
+    (make-test-struct `#\c `#\a `symbols `(#\d #t (+ 4 (+ 1 1)))))
+  (define inst-struct-name4314
+    (make-test-struct
+      `,inst-struct-name4293
+      `8
+      `(#(#\c #\a #t 5) #&((+ 1 2) 6 these) (+ 1 2) (#\c #\c #t))
+      `#&(#(#\c (+ 4 (+ 1 1)) these #t) these (#\a symbols (+ 1 2)))))
+  (define inst-struct-name4325
+    (make-test-struct
+      `#(symbols are (are (+ 4 5) (+ 4 (+ 1 1)) . #\b) 3)
+      `(#\a these (+ 4 5))
+      `()
+      `(#\b #(#\a these #\b) 12 . #t)))
+  (define inst-struct-name4343
+    (make-test-struct `(+ 4 5) `#\a `#t `(+ 4 (+ 1 1))))
+  (define inst-struct-name4348 (make-test-struct `(+ 1 2) `#\a `9 `#\a))
+  (define inst-struct-name4351
+    (make-test-struct
+      `#f
+      `#\c
+      `(+ 1 2)
+      `(,inst-struct-name4343
+        ,inst-struct-name4348
+        #(#\a (+ 4 5) (+ 4 5))
+        #\c)))
+  (define inst-struct-name4363 (make-test-struct `(+ 4 5) `are `#f `#t))
+  (define inst-struct-name4369
+    (make-test-struct
+      `#\b
+      `are
+      `,inst-struct-name4363
+      `((+ 4 (+ 1 1)) (+ 1 2) these #f)))
+  (define inst-struct-name4376 (make-test-struct `#f `#\d `#t `are))
+  (define inst-struct-name4391 (make-test-struct `#t `#\d `6 `#\d))
+  (define inst-struct-name4405 (make-test-struct `(+ 4 5) `symbols `#f `#\b))
+  (define inst-struct-name4409
+    (make-test-struct
+      `#(6 (+ 1 2) #\a)
+      `,inst-struct-name4405
+      `((+ 1 2) 8 8)
+      `((+ 1 2) #\b #f)))
+  (define inst-struct-name4429
+    (make-test-struct
+      `(#\d (+ 4 5) 1 . #\a)
+      `#\a
+      `#(are these are are)
+      `(are #f #\a)))
+  (define inst-struct-name4430
+    (make-test-struct
+      `,inst-struct-name4409
+      `#&(5 #&(symbols #\b #\a) (4 6 #\a #\c))
+      `,inst-struct-name4429
+      `()))
+  (define inst-struct-name4444
+    (make-test-struct
+      `(#\b (+ 1 2) are . 9)
+      `(+ 1 2)
+      `(+ 1 2)
+      `(#\c (+ 1 2) #\d)))
+  (define inst-struct-name4460
+    (make-test-struct
+      `#&(#t (+ 4 5) #\c)
+      `(1 #\c 1)
+      `(#f (+ 4 5) #\a . symbols)
+      `(+ 4 5)))
+  (define inst-struct-name4470
+    (make-test-struct
+      `,inst-struct-name4460
+      `10
+      `#t
+      `(() #\d (#f #\d #\c are) . #\b)))
+  (define inst-struct-name4501 (make-test-struct `#\b `8 `are `#\a))
+  (define inst-struct-name4516
+    (make-test-struct
+      `#&(,inst-struct-name4501 () #(#\b #\b #t #t))
+      `((#\b #\c #t) 0 ((+ 4 5) #t these) . these)
+      `(#\a #\b 0)
+      `()))
+  (define inst-struct-name4532 (make-test-struct `(+ 4 (+ 1 1)) `#\c `#f `#\c))
+  (define inst-struct-name4539
+    (make-test-struct
+      `,inst-struct-name4532
+      `(#f 9 symbols)
+      `#\d
+      `#(are #f are)))
+  (define inst-struct-name4554 (make-test-struct `#f `#\b `(+ 4 5) `these))
+  (define inst-struct-name4555
+    (make-test-struct
+      `#\b
+      `#(#\c #\b #f (+ 4 5))
+      `#(#f 5 #\a)
+      `,inst-struct-name4554))
+  (define inst-struct-name4578
+    (make-test-struct
+      `5
+      `#&(#\c #((+ 4 (+ 1 1)) 9 these (+ 1 2)) are)
+      `#((#\a 1 #t #\c) #f (#f #\c #\a) (+ 4 (+ 1 1)))
+      `#(#\a #t #t)))
+  (define inst-struct-name4593 (make-test-struct `#t `(+ 4 5) `#\d `#t))
+  (define inst-struct-name4594
+    (make-test-struct
+      `these
+      `#(these #\d symbols #\c)
+      `#((+ 4 5) 0 #f #t)
+      `,inst-struct-name4593))
+  (define inst-struct-name4629 (make-test-struct `(+ 4 5) `2 `are `#\d))
+  (define inst-struct-name4635 (make-test-struct `#f `#\d `1 `2))
+  (define inst-struct-name4644
+    (make-test-struct
+      `,inst-struct-name4629
+      `,inst-struct-name4635
+      `#(7 #\c #\b (+ 1 2))
+      `#(#\c (+ 4 5) #t these)))
+  (define inst-struct-name4656
+    (make-test-struct `symbols `these `#f `(+ 4 (+ 1 1))))
+  (define inst-struct-name4663 (make-test-struct `#\c `#\b `#\a `6))
+  (define inst-struct-name4668
+    (make-test-struct
+      `,inst-struct-name4656
+      `18
+      `,inst-struct-name4663
+      `#&(#\b #\c #\a)))
+  (define inst-struct-name4676 (make-test-struct `#\a `#\a `5 `are))
+  (define inst-struct-name4710
+    (make-test-struct
+      `#(#\b #f #f)
+      `#t
+      `18
+      `#(9 (#\a #\a #t) #&(#t #\d #t) (+ 1 2))))
+  (define inst-struct-name4724 (make-test-struct `#\b `#t `#\a `7))
+  (define inst-struct-name4742
+    (make-test-struct `#\a `#\a `(+ 4 (+ 1 1)) `#\c))
+  (define inst-struct-name4748 (make-test-struct `#\c `#\c `#t `symbols))
+  (define inst-struct-name4767
+    (make-test-struct `8 `#&((+ 1 2) these #\b) `8 `10))
+  (define inst-struct-name4787
+    (make-test-struct
+      `#f
+      `(are #f 8 #f)
+      `(+ 4 (+ 1 1))
+      `(#\d #\b (+ 1 2) . 7)))
+  (define inst-struct-name4798
+    (make-test-struct
+      `#\b
+      `#f
+      `#&(3 ((+ 4 (+ 1 1)) #\d (+ 4 (+ 1 1))) ((+ 1 2) #\a 8))
+      `#\d))
+  (define inst-struct-name4804
+    (make-test-struct `5 `(+ 4 (+ 1 1)) `(+ 4 5) `#(symbols 8 #\a)))
+  (define inst-struct-name4835
+    (make-test-struct `#&(#f (+ 1 2) #f) `(+ 1 2) `#\d `(5 #f #\d are)))
+  (define inst-struct-name4844 (make-test-struct `7 `#t `(+ 1 2) `symbols))
+  (define inst-struct-name4850 (make-test-struct `these `symbols `4 `are))
+  (define inst-struct-name4851
+    (make-test-struct
+      `(#f #\d #\a)
+      `7
+      `,inst-struct-name4844
+      `,inst-struct-name4850))
+  (define inst-struct-name4871 (make-test-struct `#f `symbols `#\a `#t))
+  (define inst-struct-name4879
+    (make-test-struct
+      `(#f #\c #\d)
+      `(,inst-struct-name4871 are #(are symbols #\b) (8 #\b (+ 1 2)))
+      `14
+      `#((+ 4 5) (+ 1 2) (+ 4 5))))
+  (define inst-struct-name4891 (make-test-struct `5 `(+ 4 5) `5 `#\a))
+  (define inst-struct-name4893
+    (make-test-struct
+      `(#\a 9 #\a (+ 1 2))
+      `,inst-struct-name4891
+      `(+ 4 (+ 1 1))
+      `#\d))
+  (define inst-struct-name4902 (make-test-struct `#\a `#\d `7 `5))
+  (define inst-struct-name4934 (make-test-struct `are `#\d `(+ 4 5) `symbols))
+  (define inst-struct-name4940 (make-test-struct `#\a `1 `#t `#f))
+  (define inst-struct-name4946 (make-test-struct `are `3 `4 `these))
+  (define inst-struct-name4980 (make-test-struct `#\d `#t `2 `1))
+  (define inst-struct-name4997 (make-test-struct `(+ 1 2) `#\d `these `#\d))
+  (define inst-struct-name4999
+    (make-test-struct
+      `((+ 1 2) #t (+ 4 (+ 1 1)) . 4)
+      `,inst-struct-name4997
+      `9
+      `#t))
+  (define inst-struct-name5031 (make-test-struct `#f `#\b `#\c `are))
+  (define inst-struct-name5037
+    (make-test-struct
+      `#\d
+      `,inst-struct-name5031
+      `(7 2 (+ 1 2))
+      `((+ 1 2) (+ 4 (+ 1 1)) are these)))
+  (define inst-struct-name5040
+    (make-test-struct `(+ 1 2) `symbols `(7 0 #t) `are))
+  (define inst-struct-name5059 (make-test-struct `5 `#f `#\c `(+ 4 (+ 1 1))))
+  (define inst-struct-name5060
+    (make-test-struct
+      `#f
+      `(are 6 #\a)
+      `#t
+      `((+ 4 (+ 1 1)) ,inst-struct-name5059 #t . 5)))
+  (define inst-struct-name5078 (make-test-struct `#\d `#t `#t `#\a))
+  (define inst-struct-name5086
+    (make-test-struct `,inst-struct-name5078 `#\a `() `#\a))
+  (define inst-struct-name5094 (make-test-struct `0 `#(#\d #\a 1 #t) `() `#\b))
+  (define inst-struct-name5097
+    (make-test-struct `() `(#\b #f are) `symbols `#t))
+  (define inst-struct-name5105 (make-test-struct `#\a `these `#\d `2))
+  (define inst-struct-name5110
+    (make-test-struct
+      `(+ 4 5)
+      `#t
+      `#\b
+      `#(,inst-struct-name5105 #\b #(8 #f #f (+ 4 (+ 1 1))) #\b)))
+  (define inst-struct-name5126
+    (make-test-struct `(3 these these) `(#\c 3 #\b) `#t `(#\b #f are)))
+  (define inst-struct-name5137
+    (make-test-struct `#f `7 `(+ 4 (+ 1 1)) `(+ 4 (+ 1 1))))
+  (define inst-struct-name5138
+    (make-test-struct
+      `#\d
+      `#((+ 4 (+ 1 1)) (+ 4 5) 2 #t)
+      `(+ 4 5)
+      `,inst-struct-name5137))
+  (define inst-struct-name5140
+    (make-test-struct
+      `#(() #\a #f #\a)
+      `(10 ((+ 4 (+ 1 1)) #t 9 . #\b) (#\c #\a #\a #\a) #t)
+      `,inst-struct-name5126
+      `,inst-struct-name5138))
+  (define inst-struct-name5172
+    (make-test-struct
+      `(#\c are #t #\d)
+      `(+ 4 5)
+      `(#f #t (+ 4 (+ 1 1)) . these)
+      `16))
+  (define inst-struct-name5175
+    (make-test-struct
+      `,inst-struct-name5172
+      `#\a
+      `(are #\a 7)
+      `#(#f (+ 1 2) (+ 4 5))))
+  (define inst-struct-name5182
+    (make-test-struct `#\c `(are (+ 4 5) (+ 4 5)) `4 `(7 (+ 4 (+ 1 1)) 4)))
+  (define inst-struct-name5195
+    (make-test-struct `0 `these `() `((+ 1 2) symbols #f)))
+  (define inst-struct-name5207
+    (make-test-struct `3 `(+ 1 2) `(+ 4 (+ 1 1)) `4))
+  (define inst-struct-name5210
+    (make-test-struct
+      `()
+      `#\a
+      `(((+ 4 5) (+ 1 2) (+ 4 5))
+        (#\b (+ 4 (+ 1 1)) are . symbols)
+        ,inst-struct-name5207
+        .
+        #t)
+      `4))
+  (define inst-struct-name5226 (make-test-struct `#\b `#\a `(+ 4 5) `#\b))
+  (define inst-struct-name5230
+    (make-test-struct
+      `(#((+ 4 (+ 1 1)) #\b #\a symbols) #\b ,inst-struct-name5226 #\c)
+      `(#\d #\b #\b)
+      `#(5 8 #\d)
+      `#t))
+  (define inst-struct-name5238 (make-test-struct `0 `6 `7 `#f))
+  (define inst-struct-name5244 (make-test-struct `these `(+ 1 2) `#f `#t))
+  (define inst-struct-name5247
+    (make-test-struct
+      `#(#\b #\a (+ 4 5))
+      `,inst-struct-name5244
+      `(0 #\b these)
+      `#t))
+  (define inst-struct-name5249
+    (make-test-struct
+      `((+ 1 2) (5 #\b #f) #\d ,inst-struct-name5238)
+      `,inst-struct-name5247
+      `#\c
+      `#f))
+  (define inst-struct-name5259 (make-test-struct `6 `#\b `(+ 1 2) `8))
+  (define inst-struct-name5267
+    (make-test-struct `,inst-struct-name5259 `() `8 `(#\c #\d symbols)))
+  (define inst-struct-name5299
+    (make-test-struct `4 `#\a `(these #(7 are #t) 8 . #t) `(+ 4 (+ 1 1))))
+  (define inst-struct-name5336
+    (make-test-struct
+      `()
+      `((#f are #\a) #(#t are symbols #t) (#\d #\b #\b) . #\a)
+      `#&(#t #(are (+ 4 5) 1 are) #\d)
+      `symbols))
+  (define inst-struct-name5350
+    (make-test-struct
+      `(#\d #f (+ 4 5) (+ 1 2))
+      `#t
+      `these
+      `(#\c #\b #\b . symbols)))
+  (define inst-struct-name5363 (make-test-struct `#\c `#t `#f `(+ 1 2)))
+  (define inst-struct-name5381
+    (make-test-struct
+      `these
+      `#(7 #t #\c (+ 4 (+ 1 1)))
+      `(symbols 2 (+ 1 2) #\a)
+      `#((+ 4 5) (+ 4 (+ 1 1)) these 5)))
+  (define inst-struct-name5395
+    (make-test-struct `6 `(+ 4 (+ 1 1)) `symbols `#\c))
+  (define inst-struct-name5402 (make-test-struct `#\b `#t `#\d `#\b))
+  (define inst-struct-name5413 (make-test-struct `#\a `#\d `(+ 4 (+ 1 1)) `5))
+  (define inst-struct-name5417
+    (make-test-struct
+      `()
+      `()
+      `()
+      `#&(,inst-struct-name5413 #\a (#t (+ 1 2) #\d))))
+  (define inst-struct-name5423 (make-test-struct `8 `4 `1 `#\d))
+  (define inst-struct-name5430 (make-test-struct `(+ 4 5) `2 `#\b `7))
+  (define inst-struct-name5431
+    (make-test-struct `#\a `5 `#\d `,inst-struct-name5430))
+  (define inst-struct-name5445 (make-test-struct `#\a `#\b `#\c `these))
+  (define inst-struct-name5449
+    (make-test-struct
+      `(#f (0 9 are (+ 1 2)) (#\d (+ 1 2) 2 . #f) #f)
+      `()
+      `(,inst-struct-name5445 (9 #\c (+ 1 2)) #(are symbols #\a) #\c)
+      `#(#\c #\a symbols)))
+  (define inst-struct-name5454 (make-test-struct `2 `#\a `3 `are))
+  (define inst-struct-name5459
+    (make-test-struct `(+ 4 (+ 1 1)) `#\c `(+ 1 2) `#f))
+  (define inst-struct-name5472 (make-test-struct `4 `8 `#t `#\a))
+  (define inst-struct-name5482
+    (make-test-struct
+      `these
+      `(#f #\b #t . these)
+      `((+ 4 (+ 1 1)) #\d #t . #f)
+      `#\a))
+  (define inst-struct-name5484
+    (make-test-struct
+      `#f
+      `#&((7 #\a #\d) #(#\b (+ 4 (+ 1 1)) 3) ,inst-struct-name5472)
+      `,inst-struct-name5482
+      `#\d))
+(define inst-struct-name782 (make-test-struct `#\d `9 `6 `#\c))
+  (define inst-struct-name788 (make-test-struct `(+ 4 5) `#\d `0 `are))
+  (define inst-struct-name793 (make-test-struct `(+ 4 (+ 1 1)) `#\b `#\c `3))
+  (define inst-struct-name810 (make-test-struct `#f `8 `#\d `(+ 4 (+ 1 1))))
+  (define inst-struct-name816 (make-test-struct `6 `4 `#f `#\b))
+  (define inst-struct-name818
+    (make-test-struct `symbols `() `,inst-struct-name816 `()))
+  (define inst-struct-name830 (make-test-struct `#\d `#\b `#t `6))
+  (define inst-struct-name836
+    (make-test-struct `are `,inst-struct-name830 `(9 are 6 2) `#\d))
+  (define inst-struct-name841 (make-test-struct `#f `are `symbols `7))
+  (define inst-struct-name862 (make-test-struct `#t `#t `9 `(+ 4 (+ 1 1))))
+  (define inst-struct-name876 (make-test-struct `3 `6 `#f `#\d))
+  (define inst-struct-name882
+    (make-test-struct
+      `(#\c (+ 4 (+ 1 1)) (+ 4 (+ 1 1)))
+      `(6 #f 4 . #\c)
+      `,inst-struct-name876
+      `(#\c #\a 9 #\a)))
+  (define inst-struct-name888 (make-test-struct `symbols `symbols `#\c `#f))
+  (define inst-struct-name891
+    (make-test-struct `(+ 1 2) `,inst-struct-name888 `#\d `#f))
+  (define inst-struct-name903
+    (make-test-struct `#\c `(#f #f symbols) `14 `#3(are #\b #f)))
+  (define inst-struct-name925
+    (make-test-struct `are `(+ 4 (+ 1 1)) `0 `(#t (+ 4 (+ 1 1)) #t)))
+  (define inst-struct-name928
+    (make-test-struct
+      `(((+ 1 2) (+ 4 (+ 1 1)) are) these these (#t #\b #\d))
+      `,inst-struct-name925
+      `#f
+      `#\c))
+  (define inst-struct-name941 (make-test-struct `these `(+ 1 2) `6 `#\d))
+  (define inst-struct-name952 (make-test-struct `#f `#t `8 `(+ 4 (+ 1 1))))
+  (define inst-struct-name958 (make-test-struct `#f `#\a `#\b `#\a))
+  (define inst-struct-name981
+    (make-test-struct `symbols `#\a `(+ 1 2) `(+ 1 2)))
+  (define inst-struct-name991 (make-test-struct `#\b `#\c `(+ 4 5) `#\d))
+  (define inst-struct-name1004
+    (make-test-struct `#t `#\b `#\a `((+ 4 (+ 1 1)) #t #\d)))
+  (define inst-struct-name1022
+    (make-test-struct `(#\b #f #t + 4 (+ 1 1)) `() `(#t #\b #\b) `12))
+  (define inst-struct-name1030
+    (make-test-struct `2 `these `#4(#\d symbols #\a #\c) `3))
+  (define inst-struct-name1032
+    (make-test-struct `#\b `6 `,inst-struct-name1022 `,inst-struct-name1030))
+  (define inst-struct-name1043 (make-test-struct `#\d `6 `8 `(+ 1 2)))
+  (define inst-struct-name1048
+    (make-test-struct `#\b `(+ 1 2) `#\b `(+ 4 (+ 1 1))))
+  (define inst-struct-name1050
+    (make-test-struct
+      `(+ 4 5)
+      `#f
+      `,inst-struct-name1043
+      `,inst-struct-name1048))
+  (define inst-struct-name1069 (make-test-struct `#\b `(+ 1 2) `8 `symbols))
+  (define inst-struct-name1071
+    (make-test-struct `are `symbols `#t `,inst-struct-name1069))
+  (define inst-struct-name1080
+    (make-test-struct `#&(#\d 6 (+ 4 (+ 1 1))) `#t `0 `(#\d #\d (+ 4 5))))
+  (define inst-struct-name1087 (make-test-struct `symbols `#t `#\d `(+ 1 2)))
+  (define inst-struct-name1091
+    (make-test-struct
+      `,inst-struct-name1071
+      `,inst-struct-name1080
+      `#4(6 ,inst-struct-name1087 #\c #f)
+      `0))
+  (define inst-struct-name1099
+    (make-test-struct `8 `() `#3(#\d (+ 1 2) 9) `()))
+  (define inst-struct-name1106
+    (make-test-struct
+      `(#\c 5 #\a . 8)
+      `(+ 4 (+ 1 1))
+      `(+ 4 (+ 1 1))
+      `(+ 4 (+ 1 1))))
+  (define inst-struct-name1118
+    (make-test-struct
+      `((+ 4 (+ 1 1)) these #\d #\a)
+      `,inst-struct-name1106
+      `#\a
+      `#&((are #\c #t (+ 4 5)) (#\b 0 #\c) (1 are (+ 1 2) (+ 4 (+ 1 1))))))
+  (define inst-struct-name1125 (make-test-struct `#\b `(+ 4 5) `#\c `these))
+  (define inst-struct-name1139
+    (make-test-struct
+      `#t
+      `(#t #\c these . 9)
+      `#\a
+      `#4(9 (+ 4 (+ 1 1)) #t (+ 1 2))))
+  (define inst-struct-name1141
+    (make-test-struct
+      `(() these ,inst-struct-name1125 #4(6 1 5 #\c))
+      `,inst-struct-name1139
+      `()
+      `5))
+  (define inst-struct-name1156
+    (make-test-struct
+      `((#t 5 9 5) #3(symbols symbols these) 14 (are these are))
+      `2
+      `(((+ 4 (+ 1 1)) these #f) #3((+ 4 (+ 1 1)) #t #\b) symbols . 0)
+      `are))
+  (define inst-struct-name1161 (make-test-struct `#\d `#\c `these `1))
+  (define inst-struct-name1174 (make-test-struct `#f `(+ 4 5) `#\d `#f))
+  (define inst-struct-name1187
+    (make-test-struct `,inst-struct-name1174 `#\c `#\c `#&(symbols 2 #\a)))
+  (define inst-struct-name1198
+    (make-test-struct
+      `(#\d #\b #t)
+      `#4(#f (+ 4 5) symbols (+ 1 2))
+      `#f
+      `#&(#\d 8 3)))
+  (define inst-struct-name1221
+    (make-test-struct `#\c `4 `() `(#\d #\c #\c . #\d)))
+  (define inst-struct-name1229
+    (make-test-struct `#\c `(+ 4 (+ 1 1)) `these `#f))
+  (define inst-struct-name1230
+    (make-test-struct `() `#3(#\b 0 (+ 4 5)) `#\b `,inst-struct-name1229))
+  (define inst-struct-name1232
+    (make-test-struct
+      `#3((+ 1 2) #\a 2)
+      `,inst-struct-name1221
+      `#&(() (+ 1 2) ())
+      `,inst-struct-name1230))
+  (define inst-struct-name1238
+    (make-test-struct `(#f #\c #\c) `#\b `() `(#\d these these)))
+  (define inst-struct-name1254
+    (make-test-struct `#\b `(+ 4 (+ 1 1)) `#f `(+ 4 5)))
+  (define inst-struct-name1260
+    (make-test-struct
+      `#&(are #\c #t)
+      `(9 these #\d)
+      `,inst-struct-name1254
+      `(are #\b (+ 1 2) 3)))
+  (define inst-struct-name1266 (make-test-struct `#t `#\b `#t `#\b))
+  (define inst-struct-name1279 (make-test-struct `#\d `#\c `#\a `#t))
+  (define inst-struct-name1312
+    (make-test-struct `these `#f `#4(#\b #\c 2 #f) `1))
+  (define inst-struct-name1316
+    (make-test-struct `,inst-struct-name1312 `#t `#\d `(+ 1 2)))
+  (define inst-struct-name1325 (make-test-struct `these `#\a `#t `these))
+  (define inst-struct-name1340
+    (make-test-struct `(+ 4 5) `#\c `symbols `(+ 1 2)))
+  (define inst-struct-name1342
+    (make-test-struct
+      `#t
+      `#4(,inst-struct-name1325
+          (4 (+ 4 5) #\a)
+          (#\d symbols #\b)
+          #4(#\c #\c #\b #t))
+      `((#\c symbols (+ 4 (+ 1 1)) . #\a) #f 3 ,inst-struct-name1340)
+      `#3(8 9 1)))
+  (define inst-struct-name1351
+    (make-test-struct
+      `(these #\a #t)
+      `4
+      `(#\c (0 #t #\b) #\c #t)
+      `(#\a these (+ 1 2))))
+  (define inst-struct-name1364
+    (make-test-struct `#f `symbols `(+ 1 2) `symbols))
+  (define inst-struct-name1367
+    (make-test-struct
+      `(#\b symbols #\b . 5)
+      `(#\b 7 #\a)
+      `,inst-struct-name1364
+      `these))
+  (define inst-struct-name1383 (make-test-struct `#t `#\d `#\a `#f))
+  (define inst-struct-name1403 (make-test-struct `(+ 1 2) `#\c `#\b `#\d))
+  (define inst-struct-name1409
+    (make-test-struct
+      `(#\a (+ 4 5) #\b)
+      `1
+      `,inst-struct-name1403
+      `(#\a 1 #\c . are)))
+  (define inst-struct-name1439
+    (make-test-struct `(#t 8 #f) `#3(#\a are 3) `#\d `are))
+  (define inst-struct-name1460 (make-test-struct `#f `#\d `5 `#\b))
+  (define inst-struct-name1466
+    (make-test-struct
+      `(#\a 4 #t)
+      `((#\a (+ 1 2) 7 . #\d) () 0 . #t)
+      `((#f #\a #\b . #\a)
+        are
+        (2 symbols #f + 4 (+ 1 1))
+        ,inst-struct-name1460)
+      `#&(2 #\b #\b)))
+  (define inst-struct-name1502
+    (make-test-struct `#\c `() `#&(2 are 8) `#4(these #\c #\a)))
+  (define inst-struct-name1508
+    (make-test-struct `#\c `#\d `(#t (+ 4 (+ 1 1)) #\c . symbols) `()))
+  (define inst-struct-name1519 (make-test-struct `#t `#\b `#\d `6))
+  (define inst-struct-name1534 (make-test-struct `these `#\b `#\c `are))
+  (define inst-struct-name1536
+    (make-test-struct
+      `(#\d #f 0 . #\d)
+      `(are are #\c . #\b)
+      `(+ 1 2)
+      `,inst-struct-name1534))
+  (define inst-struct-name1538
+    (make-test-struct
+      `,inst-struct-name1519
+      `2
+      `,inst-struct-name1536
+      `(+ 4 5)))
+  (define inst-struct-name1543 (make-test-struct `2 `3 `#\d `(+ 4 5)))
+  (define inst-struct-name1561 (make-test-struct `#f `symbols `#\b `#t))
+  (define inst-struct-name1563
+    (make-test-struct `(+ 4 (+ 1 1)) `,inst-struct-name1561 `(+ 4 5) `3))
+  (define inst-struct-name1572 (make-test-struct `(+ 1 2) `#\a `#\b `#\d))
+  (define inst-struct-name1577 (make-test-struct `#\b `#\b `#\b `4))
+  (define inst-struct-name1594 (make-test-struct `#f `are `#\b `#f))
+  (define inst-struct-name1609
+    (make-test-struct
+      `(symbols (+ 1 2) #\d)
+      `(#\c symbols are)
+      `(are are #\c (+ 1 2))
+      `(symbols #\d (+ 1 2) . #\b)))
+  (define inst-struct-name1619 (make-test-struct `#t `(+ 4 (+ 1 1)) `#\c `#t))
+  (define inst-struct-name1635
+    (make-test-struct `#\b `#\d `(+ 4 (+ 1 1)) `#\c))
+  (define inst-struct-name1663 (make-test-struct `#f `#\a `#f `(+ 1 2)))
+  (define inst-struct-name1666
+    (make-test-struct
+      `(#\c these symbols . #f)
+      `(4 5 #f)
+      `,inst-struct-name1663
+      `(#f (+ 4 5) (+ 4 5))))
+  (define inst-struct-name1687 (make-test-struct `symbols `are `1 `are))
+  (define inst-struct-name1701
+    (make-test-struct
+      `#4(#4(these #\d these symbols) (are 6 these) #\c #\d)
+      `#3(#f 8 (+ 4 5))
+      `(#\b are symbols)
+      `#\b))
+  (define inst-struct-name1708
+    (make-test-struct
+      `(+ 1 2)
+      `#4(() #&((+ 4 5) #\a #f) () (+ 4 (+ 1 1)))
+      `#\b
+      `#\a))
+  (define inst-struct-name1719
+    (make-test-struct `#&(#\d #t #t) `(+ 4 (+ 1 1)) `0 `(+ 4 (+ 1 1))))
+  (define inst-struct-name1741 (make-test-struct `these `#t `7 `#\b))
+  (define inst-struct-name1775
+    (make-test-struct `(8 #f #f (+ 4 (+ 1 1))) `(9 #\c #t) `#f `#t))
+  (define inst-struct-name1776
+    (make-test-struct
+      `symbols
+      `#3(#\d #\c (+ 4 (+ 1 1)))
+      `#3(symbols #\a #\d)
+      `,inst-struct-name1775))
+  (define inst-struct-name1786 (make-test-struct `0 `#\a `0 `#t))
+  (define inst-struct-name1796
+    (make-test-struct `3 `#3(#\b #\c 0) `#t `(+ 4 5)))
+  (define inst-struct-name1797
+    (make-test-struct
+      `((these #t (+ 4 (+ 1 1)) . #\a)
+        ,inst-struct-name1786
+        (#\a #t 7)
+        #&(9 #\b symbols))
+      `(+ 4 5)
+      `,inst-struct-name1796
+      `(+ 4 (+ 1 1))))
+  (define inst-struct-name1813
+    (make-test-struct
+      `(symbols #\d #\b are)
+      `#4(#\d (+ 4 (+ 1 1)) #f #\b)
+      `are
+      `()))
+  (define inst-struct-name1818
+    (make-test-struct
+      `#&(#\a (9 #\c symbols) #f)
+      `,inst-struct-name1813
+      `#&(8 () #\d)
+      `#3(#\a these symbols)))
+  (define inst-struct-name1832 (make-test-struct `are `1 `() `(12 #\c #t . 4)))
+  (define inst-struct-name1873 (make-test-struct `#t `7 `#\b `(+ 4 5)))
+  (define inst-struct-name1876
+    (make-test-struct
+      `0
+      `#&(#f 0 these)
+      `,inst-struct-name1873
+      `(+ 4 (+ 1 1))))
+  (define inst-struct-name1896
+    (make-test-struct
+      `#3(5 (+ 1 2) these)
+      `(+ 4 (+ 1 1))
+      `0
+      `#3(#\a #\d these)))
+  (define inst-struct-name1900
+    (make-test-struct `0 `these `#3(6 are symbols) `#3((+ 4 5) #t 8)))
+  (define inst-struct-name1919
+    (make-test-struct `(+ 1 2) `#\b `#&((+ 1 2) #\a #t) `#\b))
+  (define inst-struct-name1935
+    (make-test-struct `#&(2 #\c #\c) `(#f 0 6 #f) `#&(1 #\a symbols) `#\b))
+  (define inst-struct-name1941 (make-test-struct `#\b `(+ 4 5) `#f `are))
+  (define inst-struct-name1947 (make-test-struct `(+ 4 (+ 1 1)) `#\d `5 `#\d))
+  (define inst-struct-name1948
+    (make-test-struct
+      `(+ 4 5)
+      `,inst-struct-name1941
+      `(1 #\b (+ 4 5))
+      `,inst-struct-name1947))
+  (define inst-struct-name1955 (make-test-struct `2 `5 `#\c `()))
+  (define inst-struct-name1962
+    (make-test-struct `#4(#t are #\b #f) `#3(#f #f (+ 4 5)) `#t `()))
+  (define inst-struct-name1975 (make-test-struct `(+ 1 2) `(+ 1 2) `#\c `#f))
+  (define inst-struct-name1977
+    (make-test-struct
+      `symbols
+      `symbols
+      `(+ 4 (+ 1 1))
+      `(#3(2 (+ 4 5) #\b) are ,inst-struct-name1975 . 5)))
+  (define inst-struct-name1995 (make-test-struct `#\a `(+ 4 5) `8 `8))
+  (define inst-struct-name1996
+    (make-test-struct
+      `(#\c (+ 4 (+ 1 1)) 2 . #\a)
+      `(#\b #\c (+ 4 (+ 1 1)) . are)
+      `#\b
+      `,inst-struct-name1995))
+  (define inst-struct-name2013
+    (make-test-struct `18 `() `,inst-struct-name1996 `(are #\c symbols)))
+  (define inst-struct-name2041
+    (make-test-struct `(+ 1 2) `7 `#&(#\c #\d (+ 4 5)) `#t))
+  (define inst-struct-name2085
+    (make-test-struct `#4(#t (+ 4 5) (+ 4 5) #t) `0 `#\c `(these these 7)))
+  (define inst-struct-name2093
+    (make-test-struct `(#\b 9 #\b) `16 `#\a `#4((+ 1 2) 9 () 2)))
+  (define inst-struct-name2104
+    (make-test-struct `#\b `(symbols 1 (+ 4 5)) `12 `0))
+  (define inst-struct-name2110 (make-test-struct `#\a `#\a `these `symbols))
+  (define inst-struct-name2117
+    (make-test-struct
+      `,inst-struct-name2110
+      `#3(#t 4 7)
+      `(+ 1 2)
+      `#4(2 symbols (+ 4 (+ 1 1)) 5)))
+  (define inst-struct-name2125 (make-test-struct `#\c `(+ 4 (+ 1 1)) `#\c `2))
+  (define inst-struct-name2127
+    (make-test-struct
+      `(+ 4 5)
+      `()
+      `,inst-struct-name2117
+      `#4(#&(are 6 #\c) ,inst-struct-name2125 9 ())))
+  (define inst-struct-name2133
+    (make-test-struct
+      `symbols
+      `#3(#\b #\a #\d)
+      `((+ 4 5) #\d #\b . symbols)
+      `these))
+  (define inst-struct-name2138
+    (make-test-struct `0 `,inst-struct-name2133 `10 `#\d))
+  (define inst-struct-name2146 (make-test-struct `9 `#t `#t `(+ 4 5)))
+  (define inst-struct-name2153
+    (make-test-struct `#\c `symbols `(+ 4 (+ 1 1)) `#\a))
+  (define inst-struct-name2160
+    (make-test-struct
+      `(,inst-struct-name2146 #f 3 . #t)
+      `2
+      `#\c
+      `(,inst-struct-name2153 #f #&(7 0 2) . #\b)))
+  (define inst-struct-name2170 (make-test-struct `6 `8 `#f `(+ 4 (+ 1 1))))
+  (define inst-struct-name2188
+    (make-test-struct `#t `symbols `(+ 4 (+ 1 1)) `#t))
+  (define inst-struct-name2190
+    (make-test-struct
+      `#4(7 #\a (these 9 (+ 1 2)) ())
+      `2
+      `#\b
+      `#4(#3(are #\a #\c) #\a ,inst-struct-name2188 #\d)))
+  (define inst-struct-name2202 (make-test-struct `are `#f `#t `are))
+  (define inst-struct-name2204
+    (make-test-struct `(+ 1 2) `6 `,inst-struct-name2202 `#\c))
+  (define inst-struct-name2211
+    (make-test-struct `#t `(+ 4 (+ 1 1)) `symbols `these))
+  (define inst-struct-name2215
+    (make-test-struct
+      `(+ 4 (+ 1 1))
+      `,inst-struct-name2211
+      `(#f 6 #\c)
+      `(#\b #\b 1)))
+  (define inst-struct-name2245
+    (make-test-struct `#\c `#\a `symbols `(+ 4 (+ 1 1))))
+  (define inst-struct-name2252 (make-test-struct `2 `5 `#t `2))
+  (define inst-struct-name2263
+    (make-test-struct
+      `#\a
+      `#3(#\d symbols (+ 4 5))
+      `()
+      `((+ 1 2) (are #\b #\d) #\b . these)))
+  (define inst-struct-name2269
+    (make-test-struct `(symbols #\a #\a) `are `#f `()))
+  (define inst-struct-name2279
+    (make-test-struct
+      `#3(#\a #\b symbols)
+      `#3((+ 4 (+ 1 1)) #\d 2)
+      `#3(#f #\b (+ 1 2))
+      `(these #\b are)))
+  (define inst-struct-name2305 (make-test-struct `#\c `() `#t `(#\c 0 9)))
+  (define inst-struct-name2310 (make-test-struct `#\b `() `symbols `18))
+  (define inst-struct-name2327 (make-test-struct `#\d `#f `these `3))
+  (define inst-struct-name2335 (make-test-struct `#f `#\c `#\d `2))
+  (define inst-struct-name2336
+    (make-test-struct `#\b `,inst-struct-name2335 `#\c `()))
+  (define inst-struct-name2354 (make-test-struct `(+ 1 2) `#\b `0 `#\d))
+  (define inst-struct-name2359 (make-test-struct `#\d `#f `(+ 4 (+ 1 1)) `#f))
+  (define inst-struct-name2370
+    (make-test-struct `#\d `#\c `(these 6 #\a (+ 1 2)) `()))
+  (define inst-struct-name2376 (make-test-struct `(+ 1 2) `1 `3 `#\a))
+  (define inst-struct-name2382
+    (make-test-struct
+      `,inst-struct-name2376
+      `(#\b (+ 4 5) (+ 1 2))
+      `18
+      `#3(8 #\a (+ 4 5))))
+  (define inst-struct-name2388 (make-test-struct `#f `4 `3 `#t))
+  (define inst-struct-name2395
+    (make-test-struct
+      `,inst-struct-name2370
+      `,inst-struct-name2382
+      `#&((#\c #\c (+ 1 2)) ,inst-struct-name2388 (+ 4 5))
+      `14))
+  (define inst-struct-name2408
+    (make-test-struct
+      `#4(#\d #f these symbols)
+      `10
+      `these
+      `((+ 4 (+ 1 1)) symbols (+ 4 5) . symbols)))
+  (define inst-struct-name2413
+    (make-test-struct `(0 #\b #\b) `#\a `symbols `2))
+  (define inst-struct-name2438
+    (make-test-struct
+      `#&((+ 4 (+ 1 1)) (+ 1 2) (+ 4 5))
+      `#f
+      `#4((+ 4 (+ 1 1)) 9 #t #\c)
+      `6))
+  (define inst-struct-name2454
+    (make-test-struct `#3(#\a symbols 8) `#\d `#f `#3(1 #\c 4)))
+  (define inst-struct-name2465
+    (make-test-struct `() `#\b `symbols `#4(#t (+ 4 5) #t #\d)))
+  (define inst-struct-name2469
+    (make-test-struct
+      `#\b
+      `,inst-struct-name2465
+      `#\d
+      `#&(#\b #3(4 are 1) (+ 1 2))))
+  (define inst-struct-name2480
+    (make-test-struct
+      `#4((+ 1 2) 7 are #\b)
+      `(#\b symbols #\d)
+      `(#\d symbols symbols)
+      `(+ 1 2)))
diff --git a/collects/tests/mzscheme/match/plt-match-test.ss b/collects/tests/mzscheme/match/plt-match-test.ss
new file mode 100644
index 0000000000..aa936299e8
--- /dev/null
+++ b/collects/tests/mzscheme/match/plt-match-test.ss
@@ -0,0 +1,9496 @@
+(load-relative "../loadtest.ss")
+(SECTION 'PLT-MATCH)
+
+
+(require (lib "plt-match.ss"))
+;(require "../plt-match.ss")
+(require (lib "list.ss"))
+(require (lib "pregexp.ss"))
+
+(define-syntax test-mac
+  (syntax-rules ()
+    ((id to-test eval-to)
+     (with-handlers ([(lambda exn #t)
+                      (lambda (exn) (failed-test (exn-message exn) 
+                                                  (quote to-test)
+                                                 '() eval-to))])
+                    (let ((res to-test))
+                      (if (equal? res eval-to)
+                          #t
+                          (failed-test '() (quote to-test) res eval-to)))))))
+
+(define (failed-test exn-msg test-code result should-have-been)
+  `((Test-Failure)
+    (Code ,test-code)
+    (Expected-Result ,should-have-been)
+    ,(if (null? exn-msg) 
+         `(Actual-Result ,result)
+         `(Exception ,exn-msg))))
+
+; (define-syntax mytest
+;   (lambda (stx)
+;     (syntax-case stx ()
+;       ((_ t result)
+;        #`(test result #,(syntax/loc stx (lambda () t))))))) 
+
+(define (set-equal? set-1 set-2)
+  (null? (set-diff set-1 set-2)))
+(define (set-diff set-1 set-2)
+  (filter (lambda (a) (if (member a set-2)
+                          #f
+                          a)) set-1) )
+
+
+(define-syntax mytest
+  (lambda (stx)
+    (syntax-case stx ()
+      ((_ t result)
+       #`(test #t #,(syntax/loc stx (lambda () (test-mac t result)))))))) 
+
+(define-syntax test-mac-no-order
+  (syntax-rules ()
+    ((id to-test eval-to)
+     (with-handlers ([(lambda exn #t)
+                      (lambda (exn) (failed-test (exn-message exn) 
+                                                  (quote to-test)
+                                                 '() eval-to))])
+                    (let ((res to-test))
+                      (if (set-equal? res eval-to)
+                          #t
+                          (failed-test '() (quote to-test) res eval-to)))))))
+
+(define-syntax mytest-no-order
+  (lambda (stx)
+    (syntax-case stx ()
+      ((_ t result)
+       #`(test #t #,(syntax/loc stx (lambda () (test-mac-no-order t result)))))))) 
+
+
+;;
+
+
+;(mytest (match "hello"
+;               (#rx"he..o" #t)
+;               (else #f))
+;        #t)
+
+;(mytest (match "hello"
+;               (#rx"heffo" #t)
+;               (else #f))
+;        #f)
+
+(mytest (match "hello"
+               ((pregexp (pregexp "hello")) #t)
+               (else #f))
+        #t)
+  
+(mytest (match 123
+                ((pregexp "123") #t)
+                (else #f))
+        #f)
+(mytest (match 123
+                ((regexp "123") #t)
+                (else #f))
+        #f)
+(mytest (match 123
+                ((pregexp "123" (list a ...)) #t)
+                (else #f))
+        #f)
+(mytest (match 123
+               ((regexp "123" (list a ...)) #t)
+               (else #f))
+        #f)
+
+(mytest (match "hello"
+           ((regexp "hello") #t)
+           (else #f))
+        #t)
+
+(mytest (match "frank"
+           ((regexp "hello") #t)
+           ((regexp "frank") 2)
+           (else #f))
+        2)
+
+(mytest (match "frank"
+           ((pregexp "hello") #t)
+           ((pregexp "frank") 2)
+           (else #f))
+        2)
+
+(mytest (match "frank"
+           ((regexp "hello") #t)
+           (else #f))
+        #f)
+
+(mytest (match "hello"
+           ((regexp "(hel)lo" (list whol a rest ...)) a)
+           (else #f))
+        "hel")
+
+(mytest (match "hello"
+           ((pregexp "(hel)lo" (list whole a rest ...)) a)
+           (else #f))
+        "hel")
+
+(mytest (match-let*
+         ((a 1)
+          (c 2)
+          (d 3))
+         (list a c d))
+        '(1 2 3))
+
+
+(mytest (match (list (cons "a" "b"))
+         [(list) ""]
+         [(list (list-rest name value))
+          (string-append name
+                         "="
+                          value)]
+         [(list-rest (list-rest name value) rest)
+          (string-append name
+                         "="
+                         value
+                         "&"
+                         (alist->form-urlencoded rest))])
+        "a=b")
+
+(mytest (match '(case->)
+               [(list 'case-> types ...) 1]
+               [(list '->) 2]
+               [(list '-> types ...) 3]
+               [else 4])
+        1)
+
+(mytest (match '(->)
+               [(list 'case-> types ...) 1]
+               [(list '->) 2]
+               [(list '-> types ...) 3]
+               [else 4])
+        2)
+
+(mytest (match '(-> a b)
+               [(list 'case-> types ...) 1]
+               [(list '->) 2]
+               [(list '-> types ...) 3]
+               [else 4])
+        3)
+
+(mytest (match 'x
+               [(list 'case-> types ...) 1]
+               [(list '->) 2]
+               [(list '-> types ...) 3]
+               [else 4])
+        4)
+
+(mytest (match '((r a)) 
+               ((list (and (list 'a) (list 'b)) ...) 1)
+               ((list (list 'r 'a) ...) 2)
+               )
+        2)
+
+(mytest (match '((r a)) 
+               ((list (and (list 'a) (list 'b)) ... g ...) 1)
+               ((list (list 'r 'a) ...) 2)
+               )
+        2)
+
+(mytest (match '((r a)) 
+               ((vector (and (list 'a) (list 'b)) ...) 1)
+               ((list (list 'r 'a) ...) 2)
+               )
+        2)
+
+(mytest (match '((r a)) 
+               ((vector (and (list 'a) (list 'b)) ... g ...) 1)
+               ((list (list 'r 'a) ...) 2)
+               )
+        2)
+
+(mytest (match '((a 1) (b 1)) ((list (or (list 'a x) (list 'b x)) ..1) #t)) #t)
+(mytest (match '((a 1) (b 1)) ((list (or (list 'a x) (list 'b x)) ..1 g ...) #t)) #t)
+(mytest (match (vector '(a 1) '(b 1)) ((vector (or (list 'a x) (list 'b x)) ..1) #t)) #t)
+(mytest (match (vector '(a 1) '(b 1)) ((vector (or (list 'a x) (list 'b x)) ..1 g ...) #t)) #t)
+
+(mytest (match '(1 2 (3 4 5 6))
+               ((list 1 2 (or (list 3 4 5 3)
+                              (list 7 8 9 0))) 1)
+               ((list 1 2 (list 3 4 5 a)) 2))
+        2)
+
+
+
+;; list-no-oreder tests
+
+
+(mytest-no-order (match '(1 2 3 4 5 6 7)
+               ((list-no-order 5 4 2 3 1 c b) (list c b)))
+        '(6 7))
+
+(mytest-no-order (match '(1 2 3 4 5 6 7)
+               ((list-no-order 5 a 2 b 1 c 7) (list a c b)))
+        '(3 4 6))
+
+(mytest-no-order (match '(1 2 3 4 5 6 7)
+               ((list-no-order 5 4 2 3 1 g ...) g))
+        '(6 7))
+
+(mytest-no-order (match '(3 2 3 4 3 6 3)
+                        ((list-no-order a b c 3 ...) (list a b c)))
+                 '(2 4 6))
+
+(mytest-no-order (match '(3 3 3 3 3 2 4 6)
+                        ((list-no-order a b c 3 ...) (list a b c)))
+                 '(2 4 6))
+
+(mytest (match '(3 2 3 4 3 6 3)
+               ((list-no-order a b c ...) #t))
+        #t)
+
+(mytest-no-order 
+ (match '(3 s 4 g 5 e s 7)
+  ((list-no-order (and (? number?) a)
+                  (and (? number?) b)
+                  (and (? number?) c)
+                  (and (? number?) d)
+                  (and (? symbol?) e)
+                  f ...) (list a b c d)))
+ '(4 5 3 7))
+
+(mytest-no-order 
+ (match '(3 s 4 g 5 e s 7)
+  ((list-no-order (and (? number?) a)
+                  (and (? symbol?) b)
+                  (and (? symbol?) c)
+                  (and (? symbol?) d)
+                  (and (? symbol?) e)
+                  f ...) (list b c d e)))
+ '(s g e s))
+
+(mytest-no-order 
+ (match '("yes" a y 3 "no" e s "maybe")
+  ((list-no-order (and (? number?) a)
+                  (and (? symbol?) b)
+                  (and (? symbol?) c)
+                  (and (? symbol?) d)
+                  (and (? symbol?) e)
+                  f ...) f))
+ '("yes" "no" "maybe"))
+
+(mytest
+ (match '()
+  ((list-no-order) 5))
+ 5)
+
+;; hash-table pattern tests
+
+(define (list->hash-table list)
+  (let ((ht (make-hash-table)))
+    (map (lambda (el)
+           (hash-table-put! ht (car el) (cadr el)))
+         list)
+    ht))
+
+(define-syntax hash-table 
+  (lambda (stx) 
+    (syntax-case stx ()
+      ((_ (k v) ...)
+       (syntax (list->hash-table (list (list k v) ...)))))))
+
+
+(mytest (match (hash-table ('a 1) ('b 2) ('c 3))
+               ((hash-table ('a a) b ('c c)) (list a b c)))
+        '(1 (b 2) 3))
+
+(mytest (match (hash-table ('a 1) ('b 2) ('c 3))
+               ((hash-table ('c c) ('a a) ('b b)) (list a b c )))
+        '(1 2 3))
+
+(mytest (match (hash-table ('a 1) ('b 2) ('c 3))
+               ((hash-table (a 3) (b 1) (c 2)) (list a b c)))
+        '(c a b))
+
+(mytest (match (hash-table ('a 1) ('b 2) ('c 3))
+               ((hash-table (c 3) ('b b) (a 1)) (list a b c)))
+        '(a 2 c))
+
+(mytest (match (hash-table ('a 1) ('b 2) ('c 3) ('d 1) ('e 1) ('f 1))
+               ((hash-table (c 3) ('b b) (a 1) ...) (list b c)))
+        '(2 c))
+
+(mytest-no-order (match (hash-table ('a 1) ('b 2) ('c 3) ('d 1) ('e 1) ('f 1))
+                        ((hash-table (c 3) ('b b) (a 1) ...)  a))
+                 '(a d e f))
+
+(mytest (match (hash-table ('a 1) ('b 2) ('c 3) ('d 1) ('e 1) ('f 1))
+               ((hash-table (c 3) ('b b) (a 1) ..4) (list b c)))
+        '(2 c))
+
+(mytest-no-order (match (hash-table ('a 1) ('b 2) ('c 3) ('d 1) ('e 1) ('f 1))
+                        ((hash-table (c 3) ('b b) (a 1) ..4)  a))
+                 '(a d e f))
+
+(mytest (match (hash-table ('a 1) ('b 2) ('c 3) ('d 1) ('e 1) ('f 1))
+               ((hash-table (c 3) ('b b) (a 1) ..5) (list b c))
+               (_ #f))
+        #f)
+
+(mytest (match (hash-table ('a 1) ('b 2) ('c "hello") ('d 1) ('e 1) ('f 1))
+               ((hash-table (a1 a2) (a (? number?)) ...) (list a1 a2)))
+        '(c "hello"))
+
+(mytest-no-order (match (hash-table ('a 1) ('b 2) ('c "hello") ('d 1) ('e 1) ('f 1))
+                        ((hash-table (a1 a2) (a (? number?)) ...)  a))
+                 '(a b d e f))
+
+(mytest (match (hash-table ('a "hey") ('b "ma") ('c "hello") ('d "sup") ('e "down") ('f "dat"))
+               ((hash-table (a1 a2) (a (and (not "hello") b)) ...) (list a1 a2)))
+        '(c "hello"))
+
+(mytest-no-order (match (hash-table ('a "hey") ('b "ma") ('c "hello") ('d "sup") ('e "down") ('f "dat"))
+                        ((hash-table (a1 a2) (a (and (not "hello") b)) ...) a))
+                 '(a b d e f))
+
+(mytest-no-order (match (hash-table ('a "hey") ('b "ma") ('c "hello") ('d "sup") ('e "down") ('f "dat"))
+                        ((hash-table (a1 a2) (a (and (not "hello") b)) ...) b))
+                 '("sup" "hey" "ma" "dat" "down"))
+
+
+(mytest-no-order (match (hash-table ('a "hey") ('b "ma") ('c "hello") ('d "sup") ('e "down") ('f "dat"))
+                        ((hash-table (k v)  ...) k))
+                 '(d a b f e c))
+
+(mytest-no-order (match (hash-table ('a "hey") ('b "ma") ('c "hello") ('d "sup") ('e "down") ('f "dat"))
+                        ((hash-table (k v)  ...) v))
+                 '("sup" "hey" "ma" "dat" "down" "hello"))
+
+(mytest (match (hash-table ('a "hey") ('b "ma") ('c "hello") ('d "sup") ('e "down") ('f "dat"))
+               ((hash-table ('e v1) ('b v2) rest  ...) (list v1 v2)))
+        '("down" "ma"))
+
+(mytest-no-order (match (hash-table ('a "hey") ('b "ma") ('c "hello") ('d "sup") ('e "down") ('f "dat"))
+                        ((hash-table ('e v1) ('b v2) rest  ...) rest))
+                 '((d "sup") (a "hey") (f "dat") (c "hello")))
+
+(mytest (match (hash-table)
+               ((hash-table) 5))
+        5)
+                 
+; These cases work but I need a better way of testing them.
+; (mytest (match (hash-table ('a "hey") ('b "sup") ('c "sup") ('d "sup") ('e "down") ('f "dat"))
+;                ((hash-table (k "sup") (k2 "sup") (k3 "dat") rest ...) (list k k2 k3)))
+;         '(c b f))
+
+; (mytest-no-order (match (hash-table ('a "hey") ('b "sup") ('c "sup") ('d "sup") ('e "down") ('f "dat"))
+;                         ((hash-table (k "sup") (k2 "sup") (k3 "dat") rest ...) rest))
+;                  '((d "sup") (a "hey") (e "down")))
+
+
+
+
+
+;; structure tests
+
+(define-struct shape (color))
+(define-struct (ovoid shape) (x-diam y-diam))
+(define-struct (circle ovoid) (radius))
+(define-struct (rectangle shape) (height width))
+(define-struct (square rectangle) (width))
+(define c (make-circle 5 4 3 2))
+(mytest (match (list c 5)
+               ((list (struct shape (a)) 2) 1)
+               ((list (struct ovoid (a b c)) 2) 2)
+               ((list (struct circle (a b c d)) 5) 3))
+        3)
+
+(mytest (match (list c 5)
+               ((list (struct shape (a)) 2) 1)
+               ((list (struct ovoid (a b c)) 5) 2)
+               ((list (struct circle (a b c d)) 5) 3))
+        2)
+
+(mytest (match (list c 5)
+               ((list (struct shape (a)) 5) 1)
+               ((list (struct ovoid (a b c)) 5) 2)
+               ((list (struct circle (a b c d)) 5) 3))
+        1)
+
+(mytest (match (list c 6)
+               ((list (struct shape (a)) 5) 1)
+               ((list (struct ovoid (a b c)) 5) 2)
+               ((list (struct circle (a b c d)) 5) 3)
+               ((list (struct shape (a)) 6) 4))
+        4)
+
+(mytest (match (list c 5)
+               ((list (struct rectangle (a b c)) 5) 0)
+               ((list (struct shape (a)) 2) 1)
+               ((list (struct ovoid (a b c)) 2) 2)
+               ((list (struct circle (a b c d)) 5) 3))
+        3)
+
+(mytest (match (list c 5)
+               ((list (struct rectangle (a b c)) 5) 0)
+               ((list (struct shape (a)) 2) 1)
+               ((list (struct ovoid (a b c)) 5) 2)
+               ((list (struct circle (a b c d)) 5) 3))
+        2)
+
+(mytest (match (list c 5)
+               ((list (struct rectangle (a b c)) 5) 0)
+               ((list (struct shape (a)) 5) 1)
+               ((list (struct ovoid (a b c)) 5) 2)
+               ((list (struct circle (a b c d)) 5) 3))
+        1)
+
+(mytest (match (list c 5)
+               ((list (struct square (a b c d)) 5) 0)
+               ((list (struct shape (a)) 2) 1)
+               ((list (struct ovoid (a b c)) 2) 2)
+               ((list (struct circle (a b c d)) 5) 3))
+        3)
+
+(mytest (match (list c 5)
+               ((list (struct square (a b c d)) 5) 0)
+               ((list (struct shape (a)) 2) 1)
+               ((list (struct ovoid (a b c)) 5) 2)
+               ((list (struct circle (a b c d)) 5) 3))
+        2)
+
+(mytest (match (list c 5)
+               ((list (struct square (a b c d)) 5) 0)
+               ((list (struct shape (a)) 5) 1)
+               ((list (struct ovoid (a b c)) 5) 2)
+               ((list (struct circle (a b c d)) 5) 3))
+        1)
+
+
+;;quasi-quote tests 
+
+(mytest (match '(a ()) (`(a ()) #t))
+        #t)
+
+(mytest (match '(1 2 3 4 . 5)
+             (`(1 2 ,@(list 3 4) . ,b) b))
+      5)
+
+(mytest (match '(1 2 3 4 . b)
+             (`(,b 2 ,@(list 3 4) . b) b))
+      1)
+
+(mytest (match '(1 2 3 4)
+            (`(,@`(,x ,y) ,@`(,a ,b)) (list x y a b)))
+      '(1 2 3 4))
+
+(mytest (match '(1 2 3)
+             (`(,a ,b ,c) (list a b c)))
+      '(1 2 3))
+
+;(unquote-splicing (list a b c))
+
+(mytest (match '(c a b 1 2 3 r f i) 
+             (`(c a b ,@(list a b c) r f i) (list a b c)))
+      '(1 2 3))
+
+(mytest (match '(c a b 1 2 3 r f i) 
+             (`(c a b (unquote-splicing (list a b c)) r f i) (list a b c)))
+      '(1 2 3))
+
+(mytest (match '(3 4 #\c a b 1 (2 (c d)))
+             (`(3 4 #\c a b ,a ,(list b `(c e))) 'not-good)
+             (`(3 4 #\c a b ,a ,(list b `(c d))) (list a b)))
+      '(1 2))
+
+(mytest (match #(x 2 x)        ;remember that the x's are symbols here
+       (`#(x ,x x) (list x)))
+      '(2))
+
+(mytest (match #(c a b 1 2 3 r f i) 
+             (`#(c a b ,@(list derby b c) r f i) (list derby b c)))
+      '(1 2 3))
+
+(mytest (match #&(c a b 1 2 3 r f i) 
+             (`#&(c a b ,@(list a b c) r f i) (list a b c)))
+      '(1 2 3))
+
+(mytest (match (list 
+        "hi" 
+        1 
+        'there 
+        #\c 
+        #t 
+        #f 
+         '(a b c) 
+         '(a b . c) 
+         '(a b c c c c) 
+         #(a b c) 
+         #(a b c c c c) 
+         #&(a b c) 
+         '(1 2 3) 
+         '(4 5 . 6) 
+         '(7 8 9) 
+         #(10 11 12)
+         #&(13 14 15 16) 
+         1 
+         2 
+        3 
+         4 
+         17
+        )
+ (`(
+    "hi" 
+    1 
+    there 
+    #\c 
+    #t 
+    #f 
+   (a b c) 
+    (a b . c) 
+     (a b c ..2) 
+     #(a b c) 
+     #(a b c ..2) 
+     #&(a b c) 
+     ,(list a b c) 
+     ,(list-rest c1 d  e) 
+     ,(list f g h ...) 
+     ,(vector i j k)
+     ,(box (list l m n o)) 
+     ,@(list 1 2 3 4 p)
+    )
+  (list 
+    a b c 
+    c1 d e 
+    f g h 
+    i j k 
+    l m n o 
+    p
+   )))
+'(1 2 3 4 5 6 7 8 (9) 10 11 12 13 14 15 16 17))
+
+(mytest (match (vector 
+              "hi" 
+              1 
+              'there 
+              #\c 
+              #t 
+              #f 
+              '(a b c) 
+              '(a b . c) 
+              '(a b c c c c) 
+              #(a b c) 
+              #(a b c c c c) 
+              #&(a b c) 
+              '(1 2 3) 
+              '(4 5 . 6) 
+              '(7 8 9) 
+              #(10 11 12)
+              #&(13 14 15 16) 
+              1 
+              2 
+              3 
+              4 
+              17
+              )
+             (`#(
+                 "hi" 
+                 1 
+                 there 
+                 #\c 
+                 #t 
+                 #f 
+                 (a b c) 
+                 (a b . c) 
+                 (a b c ..2) 
+                 #(a b c) 
+                 #(a b c ..2) 
+                 #&(a b c) 
+                 ,(list a b c) 
+                 ,(list-rest c1 d e) 
+                 ,(list f g h ...) 
+                 ,(vector i j k)
+                 ,(box (list l m n o))
+                 ,@(list 1 2 3 4 p)
+                 )
+              (list 
+               a b c 
+               c1 d e 
+               f g h 
+               i j k 
+               l m n o 
+               p
+               )))
+'(1 2 3 4 5 6 7 8 (9) 10 11 12 13 14 15 16 17))
+
+(mytest (match (box (list 
+              "hi" 
+              1 
+              'there 
+              #\c 
+              #t 
+              #f 
+              '(a b c) 
+               '(a b . c) 
+               '(a b c c c c) 
+               #(a b c) 
+               #(a b c c c c) 
+               #&(a b c) 
+               '(1 2 3) 
+               '(4 5 . 6) 
+               '(7 8 9) 
+               #(10 11 12)
+               #&(13 14 15 16) 
+              1 
+              2 
+              3 
+              4 
+              17
+              ))
+             (`#&(
+                 "hi" 
+                 1 
+                 there 
+                 #\c 
+                 #t 
+                 #f 
+                  (a b c) 
+                  (a b . c) 
+                  (a b c ..2) 
+                  #(a b c) 
+                  #(a b c ..2) 
+                  #&(a b c) 
+                  ,(list a b c) 
+                  ,(list-rest c1 d e) 
+                  ,(list f g h ...) 
+                  ,(vector i j k)
+                  ,(box (list l m n o)) 
+                 ,@(list 1 2 3 4 p)
+                 )
+              (list 
+                a b c 
+                c1 d e 
+                f g h 
+                i j k 
+                l m n o 
+                p
+               )))
+'(1 2 3 4 5 6 7 8 (9) 10 11 12 13 14 15 16 17))
+
+;; separate
+
+
+  (define-struct test-struct (a b c d))
+  (define inst-struct-name29 (make-test-struct `#\b `2 `(+ 4 5) `symbols))
+  (define inst-struct-name33
+    (make-test-struct
+      `(,inst-struct-name29 (+ 1 2) #\c (+ 4 5))
+      `()
+      `(these #\d #t)
+      `16))
+  (define inst-struct-name46 (make-test-struct `#\c `#\d `16 `4))
+  (define inst-struct-name54 (make-test-struct `#\c `4 `#\c `#\b))
+  (define inst-struct-name72 (make-test-struct `#f `4 `4 `#\c))
+  (define inst-struct-name75
+    (make-test-struct
+      `(+ 4 (+ 1 1))
+      `,inst-struct-name72
+      `#3(9 #\b 9)
+      `(+ 4 5)))
+  (define inst-struct-name77
+    (make-test-struct `#\c `(#\d symbols these) `,inst-struct-name75 `these))
+  (define inst-struct-name84 (make-test-struct `#\b `4 `#\c `#\d))
+  (define inst-struct-name90 (make-test-struct `symbols `#\a `#\c `symbols))
+  (define inst-struct-name116
+    (make-test-struct `symbols `(+ 4 (+ 1 1)) `4 `#\b))
+  (define inst-struct-name145 (make-test-struct `(+ 1 2) `4 `symbols `these))
+  (define inst-struct-name147
+    (make-test-struct
+      `#f
+      `((+ 4 (+ 1 1)) these 6)
+      `#4(are () ,inst-struct-name145 (+ 4 (+ 1 1)))
+      `()))
+  (define inst-struct-name158
+    (make-test-struct `18 `(#\b 2 #t) `() `(+ 4 (+ 1 1))))
+  (define inst-struct-name164
+    (make-test-struct
+      `()
+      `,inst-struct-name158
+      `#\d
+      `(#3(these these 1) #\b (#\c #f (+ 4 (+ 1 1))) . #f)))
+  (define inst-struct-name173 (make-test-struct `#\b `#\b `#\b `are))
+  (define inst-struct-name175
+    (make-test-struct `() `#&((+ 1 2) #t (+ 4 5)) `,inst-struct-name173 `#t))
+  (define inst-struct-name190
+    (make-test-struct
+      `,inst-struct-name175
+      `()
+      `#f
+      `((are #\b 5) these #4((+ 1 2) 8 these (+ 1 2)) . #f)))
+  (define inst-struct-name198 (make-test-struct `these `#t `7 `(+ 4 5)))
+  (define inst-struct-name218
+    (make-test-struct `(+ 4 (+ 1 1)) `#4((+ 4 5) symbols 2 4) `#\a `#\d))
+  (define inst-struct-name224 (make-test-struct `#\b `(+ 1 2) `4 `these))
+  (define inst-struct-name250 (make-test-struct `7 `symbols `are `these))
+  (define inst-struct-name260
+    (make-test-struct
+      `(symbols #\b symbols)
+      `()
+      `(symbols (+ 1 2) 5 #\d)
+      `(#\a #\c #\c . 1)))
+  (define inst-struct-name272
+    (make-test-struct `#&(#\b #\a #f) `#3((+ 4 5) #\b #t) `#\b `(+ 4 (+ 1 1))))
+  (define inst-struct-name281 (make-test-struct `#\b `5 `(+ 1 2) `4))
+  (define inst-struct-name286 (make-test-struct `#\b `(+ 4 5) `0 `1))
+  (define inst-struct-name288
+    (make-test-struct
+      `#&(#\b #\b #\b)
+      `(these (+ 1 2) #\c)
+      `,inst-struct-name281
+      `,inst-struct-name286))
+  (define inst-struct-name304 (make-test-struct `#\d `are `#f `7))
+  (define inst-struct-name305
+    (make-test-struct `#\d `(7 #\c #\c) `2 `,inst-struct-name304))
+  (define inst-struct-name317 (make-test-struct `9 `#\c `symbols `#\b))
+  (define inst-struct-name318
+    (make-test-struct `() `,inst-struct-name317 `symbols `0))
+  (define inst-struct-name334 (make-test-struct `#\d `#f `(+ 4 5) `7))
+  (define inst-struct-name350
+    (make-test-struct
+      `()
+      `(+ 4 (+ 1 1))
+      `#&(#\d 2 #f)
+      `#4(#\a these #t (+ 1 2))))
+  (define inst-struct-name359
+    (make-test-struct `(+ 4 (+ 1 1)) `(+ 4 5) `#\b `#\a))
+  (define inst-struct-name372 (make-test-struct `symbols `6 `4 `#\c))
+  (define inst-struct-name385 (make-test-struct `#\d `8 `#\a `#\a))
+  (define inst-struct-name399
+    (make-test-struct `4 `() `#\a `#3(#f (+ 4 5) #f)))
+  (define inst-struct-name408
+    (make-test-struct `these `(+ 4 (+ 1 1)) `((+ 4 (+ 1 1)) (+ 4 5) are) `#\a))
+  (define inst-struct-name417
+    (make-test-struct `6 `#\b `(+ 4 (+ 1 1)) `(+ 4 5)))
+  (define inst-struct-name424
+    (make-test-struct
+      `(#4((+ 4 (+ 1 1)) #\b 7 #\a)
+        ,inst-struct-name417
+        ((+ 4 5) are 9 . these)
+        .
+        #f)
+      `(#t #\a #f)
+      `()
+      `(are #\b 4)))
+  (define inst-struct-name431
+    (make-test-struct
+      `these
+      `3
+      `#4((+ 4 (+ 1 1)) symbols 1 are)
+      `(8 #t (+ 4 (+ 1 1)))))
+  (define inst-struct-name433
+    (make-test-struct `() `1 `,inst-struct-name431 `are))
+  (define inst-struct-name477
+    (make-test-struct `#t `() `these `#4((+ 4 5) #t #t #\c)))
+  (define inst-struct-name487
+    (make-test-struct `((7 these #\b) (+ 4 (+ 1 1)) #t . 0) `() `(+ 4 5) `7))
+  (define inst-struct-name514
+    (make-test-struct `(+ 4 5) `#\b `(+ 4 (+ 1 1)) `#t))
+  (define inst-struct-name522
+    (make-test-struct
+      `,inst-struct-name514
+      `(#\b #t #\d . #\a)
+      `(7 5 #f . #\b)
+      `#\c))
+  (define inst-struct-name530 (make-test-struct `8 `5 `#\c `7))
+  (define inst-struct-name541 (make-test-struct `(+ 1 2) `4 `symbols `(+ 1 2)))
+  (define inst-struct-name545
+    (make-test-struct `,inst-struct-name541 `8 `() `()))
+  (define inst-struct-name547
+    (make-test-struct
+      `are
+      `(9 (#f symbols #\d) ,inst-struct-name530 symbols)
+      `(4 #\b #t)
+      `,inst-struct-name545))
+  (define inst-struct-name554
+    (make-test-struct `#3(#\d #f #\d) `are `1 `(+ 4 (+ 1 1))))
+  (define inst-struct-name597 (make-test-struct `#\d `(+ 4 (+ 1 1)) `2 `#\a))
+  (define inst-struct-name600
+    (make-test-struct
+      `#f
+      `(these #\b 7)
+      `(18 #3(#f (+ 4 5) #t) ,inst-struct-name597 (#t 8 these))
+      `(+ 4 (+ 1 1))))
+  (define inst-struct-name618
+    (make-test-struct `#&((+ 4 5) #\d #\c) `are `() `()))
+  (define inst-struct-name642
+    (make-test-struct `#\d `(+ 4 5) `(+ 4 5) `(+ 1 2)))
+  (define inst-struct-name661 (make-test-struct `#\a `#\c `#f `#\c))
+  (define inst-struct-name669
+    (make-test-struct
+      `,inst-struct-name661
+      `(#\b #\b #f . #\a)
+      `(#\d #t (+ 1 2) . #\b)
+      `#t))
+
+  (define (let-tests)
+    (list
+     (mytest
+      (match-letrec
+        (((list
+           (box
+            (list
+             (and (? number? tlp327) (? even? tlp328))
+             (vector tlp329 ...)
+             (list tlp330 ..3)))
+           #0=(list)
+           tlp331
+           (or (vector tlp332 ...) (vector tlp332 ...)))
+          `(#&(2 #3(6 (+ 1 2) #t) (#\c #t symbols)) () #\b #3(#\d #f #\b))))
+        (list tlp327 tlp329 tlp330 tlp331 tlp332))
+      '(2 (6 (+ 1 2) #t) (#\c #t symbols) #\b (#\d #f #\b)))
+     (mytest
+      (match-let*
+        (((list
+           (vector tlp333 ...)
+           (list-rest
+             (and (? test-struct? tlp335)
+                  (app test-struct-a (and _ _))
+                  (app test-struct-b (not (not #f)))
+                  (app test-struct-c '(+ 4 5))
+                  (app test-struct-d 7))
+             (and (? number? tlp336) (? even? tlp337))
+             tlp338
+             'these)
+           (list-rest
+             tlp339
+             (not (not 'these))
+             (struct
+               test-struct
+               ((list)
+                '(+ 4 (+ 1 1))
+                (and (box (list tlp340 tlp341 tlp342))
+                     (box (list tlp343 tlp344 tlp345)))
+                (vector tlp346 tlp347 tlp348 tlp349)))
+             #\a)
+           (vector tlp351 ...))
+          `(#3(#\a #\a 4)
+            (,inst-struct-name334 12 (+ 1 2) . these)
+            ((+ 4 (+ 1 1)) these ,inst-struct-name350 . #\a)
+            #3(#\b #\d 4))))
+        (list
+         tlp333
+         tlp336
+         tlp338
+         tlp339
+         tlp340
+         tlp341
+         tlp342
+         tlp346
+         tlp347
+         tlp348
+         tlp349
+         tlp351))
+      '((#\a #\a 4)
+        12
+        (+ 1 2)
+        (+ 4 (+ 1 1))
+        #\d
+        2
+        #f
+        #\a
+        these
+        #t
+        (+ 1 2)
+        (#\b #\d 4)))))
+  (define (multi-let-tests)
+    (list
+     (mytest
+      (match-let
+        (((list
+           tlp352
+           (vector
+             (box
+              (list
+               (or _ _)
+               (and (? number? tlp353) (? even? tlp354))
+               (struct test-struct (tlp355 tlp356 tlp357 tlp358))))
+             (list
+              _
+              (list tlp360 ..3)
+              (and (? number? tlp361) (? even? tlp362))
+              (or (list tlp363 ..3) (list tlp363 ..3)))
+             (list
+              (not (not 'symbols))
+              (and (and tlp364 tlp365) (and tlp366 tlp367))
+              (struct test-struct (tlp368 tlp369 tlp370 tlp371))
+              _)
+             tlp373)
+           (list-rest (list tlp374 ...) (list tlp375 ...) _ #\c)
+           (and (? number? tlp376) (? even? tlp377)))
+          `((+ 1 2)
+            #4(#&(2 16 ,inst-struct-name359)
+               (#\a (are #\c #t) 8 (#\b #\a #\d))
+               (symbols #\b ,inst-struct-name372 4)
+               #\b)
+            ((2 6 #\c) (#\d #t #t) 1 . #\c)
+            16))
+         ((list (list) (box (list (list) tlp378 (not (not #\c)))) #\b tlp379)
+          `(() #&(() #\c #\c) #\b #\d)))
+        (list
+         tlp352
+         tlp353
+         tlp355
+         tlp356
+         tlp357
+         tlp358
+         tlp360
+         tlp361
+         tlp363
+         tlp364
+         tlp368
+         tlp369
+         tlp370
+         tlp371
+         tlp373
+         tlp374
+         tlp375
+         tlp376
+         tlp378
+         tlp379))
+      '((+ 1 2)
+        16
+        (+ 4 (+ 1 1))
+        (+ 4 5)
+        #\b
+        #\a
+        (are #\c #t)
+        8
+        (#\b #\a #\d)
+        #\b
+        symbols
+        6
+        4
+        #\c
+        #\b
+        (2 6 #\c)
+        (#\d #t #t)
+        16
+        #\c
+        #\d))
+     (mytest
+      (match-letrec
+        (((list
+           (box
+            (list
+             (list-rest
+               (not (not 8))
+               (vector tlp380 ...)
+               (and (? test-struct? tlp386)
+                    (app test-struct-a tlp381)
+                    (app test-struct-b tlp382)
+                    (app test-struct-c tlp383)
+                    (app test-struct-d tlp384))
+               #\a)
+             (box (list #t (vector tlp387 ___) (list tlp388 ..3)))
+             (and tlp389 tlp390)))
+           (not (not 6))
+           (list)
+           '(+ 4 (+ 1 1)))
+          `(#&((8 #3(#\c #\a are) ,inst-struct-name385 . #\a)
+               #&(#t #3(#f #\c #t) (these #\b (+ 1 2)))
+               (+ 4 5))
+            6
+            ()
+            (+ 4 (+ 1 1))))
+         ((list (list tlp391 __3) (not (not 3)) tlp392 (list tlp393 ...))
+          `(((+ 1 2) #f (+ 4 (+ 1 1))) 3 are (symbols #\a #\d))))
+        (list
+         tlp380
+         tlp381
+         tlp382
+         tlp383
+         tlp384
+         tlp387
+         tlp388
+         tlp389
+         tlp391
+         tlp392
+         tlp393))
+      '((#\c #\a are)
+        #\d
+        8
+        #\a
+        #\a
+        (#f #\c #t)
+        (these #\b (+ 1 2))
+        (+ 4 5)
+        ((+ 1 2) #f (+ 4 (+ 1 1)))
+        are
+        (symbols #\a #\d)))))
+  (define (define-tests)
+    (list
+     (mytest
+      (let ()
+        (match-define
+          (list
+           tlp394
+           (struct
+             test-struct
+             ((and (? number? tlp395) (? even? tlp396))
+              (list)
+              tlp397
+              (vector tlp398 ___)))
+           _
+           (vector tlp400 ...))
+          `(symbols ,inst-struct-name399 #t #3(these #f 6)))
+        (list tlp394 tlp395 tlp397 tlp398 tlp400))
+      '(symbols 4 #\a (#f (+ 4 5) #f) (these #f 6)))
+     (mytest
+      (let ()
+        (match-define
+          (list tlp401 tlp402 (list tlp403 ..3) (vector tlp404 ...))
+          `(#\a #t ((+ 4 5) #\d #t) #3((+ 1 2) #t 6)))
+        (list tlp401 tlp402 tlp403 tlp404))
+      '(#\a #t ((+ 4 5) #\d #t) ((+ 1 2) #t 6)))))
+  (define (sing-match-tests)
+    (list
+     (let ((tlp435
+             (lambda (tlp405)
+               (match
+                tlp405
+                ((list
+                  (struct
+                    test-struct
+                    (tlp406 '(+ 4 (+ 1 1)) (list tlp407 __3) _))
+                  _
+                  (struct
+                    test-struct
+                    ((list-rest
+                       (vector tlp409 tlp410 tlp411 tlp412)
+                       (and (? test-struct? tlp418)
+                            (app test-struct-a tlp413)
+                            (app test-struct-b tlp414)
+                            (app test-struct-c tlp415)
+                            (app test-struct-d tlp416))
+                       (list-rest tlp419 tlp420 tlp421 'these)
+                       #f)
+                     (list tlp422 ...)
+                     (list)
+                     (list tlp423 ...)))
+                  (and (? test-struct? tlp434)
+                       (app test-struct-a (list))
+                       (app test-struct-b tlp425)
+                       (app
+                        test-struct-c
+                        (and (? test-struct? tlp432)
+                             (app test-struct-a 'these)
+                             (app
+                              test-struct-b
+                              (and (not (not 3)) (not (not 3))))
+                             (app
+                              test-struct-c
+                              (vector tlp426 tlp427 tlp428 tlp429))
+                             (app test-struct-d (list tlp430 ___))))
+                       (app test-struct-d 'are)))
+                 (list
+                  tlp406
+                  tlp407
+                  tlp409
+                  tlp410
+                  tlp411
+                  tlp412
+                  tlp413
+                  tlp414
+                  tlp415
+                  tlp416
+                  tlp419
+                  tlp420
+                  tlp421
+                  tlp422
+                  tlp423
+                  tlp425
+                  tlp426
+                  tlp427
+                  tlp428
+                  tlp429
+                  tlp430))))))
+       (list
+        (mytest
+         (tlp435
+           `(,inst-struct-name408
+             #\d
+             ,inst-struct-name424
+             ,inst-struct-name433))
+         '(these
+           ((+ 4 (+ 1 1)) (+ 4 5) are)
+           (+ 4 (+ 1 1))
+           #\b
+           7
+           #\a
+           6
+           #\b
+           (+ 4 (+ 1 1))
+           (+ 4 5)
+           (+ 4 5)
+           are
+           9
+           (#t #\a #f)
+           (are #\b 4)
+           1
+           (+ 4 (+ 1 1))
+           symbols
+           1
+           are
+           (8 #t (+ 4 (+ 1 1)))))))
+     (let ((tlp441
+             (lambda (tlp436)
+               (match
+                tlp436
+                ((list
+                  (list tlp437 ..3)
+                  _
+                  (and (list tlp438 ..3) (list tlp439 ..3))
+                  tlp440)
+                 (list tlp437 tlp438 tlp440))))))
+       (list
+        (mytest
+         (tlp441 `((#f #t #f) #t (these #\c #\b) 1))
+         '((#f #t #f) (these #\c #\b) 1))))))
+  (define (mult-match-tests)
+    (list
+     (let ((tlp480
+             (lambda (tlp442)
+               (match
+                tlp442
+                ((list
+                  (and (list tlp443 ___) (list tlp444 ___))
+                  (box
+                   (list
+                    (box (list #f tlp445 tlp446))
+                    (vector
+                      (list tlp447 __3)
+                      (list)
+                      5
+                      (or (vector tlp448 ___) (vector tlp448 ___)))
+                    (box
+                     (list
+                      (or (not (not '(+ 4 (+ 1 1))))
+                          (not (not '(+ 4 (+ 1 1)))))
+                      (list)
+                      (list-rest tlp449 tlp450 tlp451 #f)))))
+                  (vector
+                    #\d
+                    _
+                    (box
+                     (list
+                      (vector tlp452 ___)
+                      (and (list) (list))
+                      (and (vector tlp453 ___) (vector tlp454 ___))))
+                    (vector
+                      (list tlp455 ...)
+                      (and (? number? tlp456) (? even? tlp457))
+                      (vector tlp458 tlp459 tlp460 tlp461)
+                      #\b))
+                  (list))
+                 (list
+                  tlp443
+                  tlp445
+                  tlp446
+                  tlp447
+                  tlp448
+                  tlp449
+                  tlp450
+                  tlp451
+                  tlp452
+                  tlp453
+                  tlp455
+                  tlp456
+                  tlp458
+                  tlp459
+                  tlp460
+                  tlp461))
+                ((list
+                  (list tlp462 ..3)
+                  tlp463
+                  (list-rest
+                    (list-rest
+                      #\d
+                      (list tlp464 tlp465 tlp466 tlp467)
+                      (list-rest tlp468 tlp469 tlp470 'these)
+                      #\b)
+                    'symbols
+                    (and (? test-struct? tlp478)
+                         (app test-struct-a tlp471)
+                         (app test-struct-b (list))
+                         (app test-struct-c tlp472)
+                         (app
+                          test-struct-d
+                          (vector tlp473 tlp474 tlp475 tlp476)))
+                    7)
+                  tlp479)
+                 (list
+                  tlp462
+                  tlp463
+                  tlp464
+                  tlp465
+                  tlp466
+                  tlp467
+                  tlp468
+                  tlp469
+                  tlp470
+                  tlp471
+                  tlp472
+                  tlp473
+                  tlp474
+                  tlp475
+                  tlp476
+                  tlp479))))))
+       (list
+        (mytest
+         (tlp480
+           `((#t #\d symbols)
+             #&(#&(#f 3 #\d)
+                #4((are #\b #\c) () 5 #3(#\b #f))
+                #&((+ 4 (+ 1 1)) () (symbols #\c #\a . #f)))
+             #4(#\d
+                2
+                #&(#3(#t 9 #f) () #3((+ 4 5) #f 6))
+                #4((#\c 8 symbols) 2 #4(7 (+ 1 2) #f #\d) #\b))
+             ()))
+         '((#t #\d symbols)
+           3
+           #\d
+           (are #\b #\c)
+           (#\b #f #f)
+           symbols
+           #\c
+           #\a
+           (#t 9 #f)
+           ((+ 4 5) #f 6)
+           (#\c 8 symbols)
+           2
+           7
+           (+ 1 2)
+           #f
+           #\d))
+        (mytest
+         (tlp480
+           `((are 0 are)
+             #\b
+             ((#\d ((+ 1 2) #\c symbols #\b) (#\a (+ 4 5) 3 . these) . #\b)
+              symbols
+              ,inst-struct-name477
+              .
+              7)
+             #\d))
+         '((are 0 are)
+           #\b
+           (+ 1 2)
+           #\c
+           symbols
+           #\b
+           #\a
+           (+ 4 5)
+           3
+           #t
+           these
+           (+ 4 5)
+           #t
+           #t
+           #\c
+           #\d))))
+     (let ((tlp508
+             (lambda (tlp481)
+               (match
+                tlp481
+                ((list
+                  (list-rest tlp482 tlp483 (list) #\a)
+                  (struct
+                    test-struct
+                    ((list-rest (list tlp484 ___) tlp485 (not (not #t)) 0)
+                     (list)
+                     tlp486
+                     (not (not 7))))
+                  (and (? number? tlp488) (? even? tlp489))
+                  #\a)
+                 (list tlp482 tlp483 tlp484 tlp485 tlp486 tlp488))
+                ((list
+                  (list tlp490 ..3)
+                  (box
+                   (list
+                    (and (? number? tlp491) (? even? tlp492))
+                    (and (vector
+                           (vector tlp493 ...)
+                           tlp494
+                           (vector tlp495 ...)
+                           (box (list tlp496 tlp497 tlp498)))
+                         (vector
+                           (vector tlp499 ...)
+                           tlp500
+                           (vector tlp501 ...)
+                           (box (list tlp502 tlp503 tlp504))))
+                    (and (? number? tlp505) (? even? tlp506))))
+                  tlp507
+                  #\c)
+                 (list
+                  tlp490
+                  tlp491
+                  tlp493
+                  tlp494
+                  tlp495
+                  tlp496
+                  tlp497
+                  tlp498
+                  tlp505
+                  tlp507))))))
+       (list
+        (mytest
+         (tlp508 `((symbols 4 () . #\a) ,inst-struct-name487 18 #\a))
+         '(symbols 4 (7 these #\b) (+ 4 (+ 1 1)) (+ 4 5) 18))
+        (mytest
+         (tlp508
+           `((7 #t #f)
+             #&(14
+                #4(#3(#\c are 7)
+                   (+ 4 (+ 1 1))
+                   #3(#f 9 symbols)
+                   #&(symbols #\a are))
+                18)
+             these
+             #\c))
+         '((7 #t #f)
+           14
+           (#\c are 7)
+           (+ 4 (+ 1 1))
+           (#f 9 symbols)
+           symbols
+           #\a
+           are
+           18
+           these))))))
+  (define (sing-match-lambda-tests)
+    (list
+     (let ((tlp550
+             (match-lambda
+               ((list
+                 (box
+                  (list
+                   #\d
+                   (box (list tlp509 'are _))
+                   (struct
+                     test-struct
+                     ((struct test-struct (tlp510 tlp511 tlp512 tlp513))
+                      (list-rest tlp515 tlp516 tlp517 #\a)
+                      (list-rest tlp518 tlp519 tlp520 #\b)
+                      tlp521))))
+                 (vector tlp523 ___)
+                 (and (? test-struct? tlp548)
+                      (app test-struct-a 'are)
+                      (app
+                       test-struct-b
+                       (list
+                        tlp524
+                        (list tlp525 ...)
+                        (and (struct test-struct (tlp526 tlp527 tlp528 tlp529))
+                             (struct
+                               test-struct
+                               (tlp531 tlp532 tlp533 tlp534)))
+                        tlp535))
+                      (app test-struct-c (list tlp536 ...))
+                      (app
+                       test-struct-d
+                       (and (? test-struct? tlp546)
+                            (app
+                             test-struct-a
+                             (and (? test-struct? tlp542)
+                                  (app test-struct-a tlp537)
+                                  (app test-struct-b tlp538)
+                                  (app test-struct-c tlp539)
+                                  (app test-struct-d tlp540)))
+                            (app
+                             test-struct-b
+                             (and (? number? tlp543) (? even? tlp544)))
+                            (app test-struct-c (list))
+                            (app test-struct-d (list)))))
+                 tlp549)
+                (list
+                 tlp509
+                 tlp510
+                 tlp511
+                 tlp512
+                 tlp513
+                 tlp515
+                 tlp516
+                 tlp517
+                 tlp518
+                 tlp519
+                 tlp520
+                 tlp521
+                 tlp523
+                 tlp524
+                 tlp525
+                 tlp526
+                 tlp527
+                 tlp528
+                 tlp529
+                 tlp535
+                 tlp536
+                 tlp537
+                 tlp538
+                 tlp539
+                 tlp540
+                 tlp543
+                 tlp549)))))
+       (list
+        (mytest
+         (tlp550
+           `(#&(#\d #&(#\a are are) ,inst-struct-name522)
+             #3(#\c #\b #f)
+             ,inst-struct-name547
+             7))
+         '(#\a
+           (+ 4 5)
+           #\b
+           (+ 4 (+ 1 1))
+           #t
+           #\b
+           #t
+           #\d
+           7
+           5
+           #f
+           #\c
+           (#\c #\b #f)
+           9
+           (#f symbols #\d)
+           8
+           5
+           #\c
+           7
+           symbols
+           (4 #\b #t)
+           (+ 1 2)
+           4
+           symbols
+           (+ 1 2)
+           8
+           7))))
+     (let ((tlp555
+             (match-lambda
+               ((list
+                 tlp551
+                 (struct test-struct ((vector tlp552 ...) 'are _ tlp553))
+                 (list)
+                 (list))
+                (list tlp551 tlp552 tlp553)))))
+       (list
+        (mytest
+         (tlp555 `(#\b ,inst-struct-name554 () ()))
+         '(#\b (#\d #f #\d) (+ 4 (+ 1 1))))))))
+  (define (mult-match-lambda-tests)
+    (list
+     (let ((tlp580
+             (match-lambda
+               ((list
+                 (not (not #f))
+                 (box
+                  (list
+                   tlp556
+                   (and (list tlp557 ___) (list tlp558 ___))
+                   (and (? number? tlp559) (? even? tlp560))))
+                 tlp561
+                 (list))
+                (list tlp556 tlp557 tlp559 tlp561))
+               ((list
+                 _
+                 (list tlp562 ..3)
+                 '(+ 4 (+ 1 1))
+                 (vector
+                   (list
+                    (vector tlp563 tlp564 tlp565 tlp566)
+                    tlp567
+                    (box (list tlp568 tlp569 tlp570))
+                    tlp571)
+                   (and tlp572 tlp573)
+                   (box
+                    (list
+                     (box (list tlp574 tlp575 tlp576))
+                     (not (not #f))
+                     (list-rest tlp577 tlp578 tlp579 #\b)))
+                   #f))
+                (list
+                 tlp562
+                 tlp563
+                 tlp564
+                 tlp565
+                 tlp566
+                 tlp567
+                 tlp568
+                 tlp569
+                 tlp570
+                 tlp571
+                 tlp572
+                 tlp574
+                 tlp575
+                 tlp576
+                 tlp577
+                 tlp578
+                 tlp579)))))
+       (list
+        (mytest
+         (tlp580 `(#f #&(9 (#\c (+ 1 2) symbols) 16) #\c ()))
+         '(9 (#\c (+ 1 2) symbols) 16 #\c))
+        (mytest
+         (tlp580
+           `(#f
+             (#\a #t 5)
+             (+ 4 (+ 1 1))
+             #4((#4(9 #\c (+ 4 (+ 1 1)) symbols) 7 #&(#\a #t (+ 4 5)) #t)
+                #\b
+                #&(#&(5 #\d #t) #f ((+ 1 2) #t #\b . #\b))
+                #f)))
+         '((#\a #t 5)
+           9
+           #\c
+           (+ 4 (+ 1 1))
+           symbols
+           7
+           #\a
+           #t
+           (+ 4 5)
+           #t
+           #\b
+           5
+           #\d
+           #t
+           (+ 1 2)
+           #t
+           #\b))))
+     (let ((tlp604
+             (match-lambda
+               ((list
+                 (and (? number? tlp581) (? even? tlp582))
+                 tlp583
+                 (box
+                  (list
+                   '(+ 4 5)
+                   (box
+                    (list
+                     tlp584
+                     (and (? number? tlp585) (? even? tlp586))
+                     (or (or tlp587 tlp587) (or tlp587 tlp587))))
+                   '(+ 4 5)))
+                 (vector tlp588 ...))
+                (list tlp581 tlp583 tlp584 tlp585 tlp587 tlp588))
+               ((list
+                 (and (? test-struct? tlp601)
+                      (app test-struct-a #f)
+                      (app test-struct-b (list tlp589 ...))
+                      (app
+                       test-struct-c
+                       (list
+                        (and (? number? tlp590) (? even? tlp591))
+                        (vector tlp592 ...)
+                        (and (? test-struct? tlp598)
+                             (app test-struct-a tlp593)
+                             (app test-struct-b tlp594)
+                             (app test-struct-c tlp595)
+                             (app test-struct-d tlp596))
+                        (list tlp599 __3)))
+                      (app test-struct-d '(+ 4 (+ 1 1))))
+                 #f
+                 (vector tlp602 ___)
+                 (list tlp603 ___))
+                (list
+                 tlp589
+                 tlp590
+                 tlp592
+                 tlp593
+                 tlp594
+                 tlp595
+                 tlp596
+                 tlp599
+                 tlp602
+                 tlp603)))))
+       (list
+        (mytest
+         (tlp604
+           `(18 #\a #&((+ 4 5) #&(these 0 #\d) (+ 4 5)) #3(1 (+ 1 2) symbols)))
+         '(18 #\a these 0 #\d (1 (+ 1 2) symbols)))
+        (mytest
+         (tlp604 `(,inst-struct-name600 #f #3(4 0 #\d) (are 7 #\c)))
+         '((these #\b 7)
+           18
+           (#f (+ 4 5) #t)
+           #\d
+           (+ 4 (+ 1 1))
+           2
+           #\a
+           (#t 8 these)
+           (4 0 #\d)
+           (are 7 #\c)))))))
+  (define (sing-match-lambda*-tests)
+    (list
+     (let ((tlp610
+             (match-lambda*
+               ((list tlp606 tlp607 (list tlp608 ___) tlp609)
+                (list tlp606 tlp607 tlp608 tlp609)))))
+       (list
+        (mytest
+         (tlp610 `#f `#\c `((+ 4 (+ 1 1)) 7 #t) `3)
+         '(#f #\c ((+ 4 (+ 1 1)) 7 #t) 3))))
+     (let ((tlp620
+             (match-lambda*
+               ((list
+                 (list
+                  '(+ 4 5)
+                  (vector tlp612 ___)
+                  (list tlp613 __3)
+                  (struct
+                    test-struct
+                    ((box (list tlp614 tlp615 tlp616)) tlp617 (list) (list))))
+                 tlp619
+                 (box (list 7 '(+ 4 (+ 1 1)) (list)))
+                 _)
+                (list tlp612 tlp613 tlp614 tlp615 tlp616 tlp617 tlp619)))))
+       (list
+        (mytest
+         (tlp620
+           `((+ 4 5) #3(1 9 (+ 1 2)) (3 these these) ,inst-struct-name618)
+           `#\c
+           `#&(7 (+ 4 (+ 1 1)) ())
+           `(+ 1 2))
+         '((1 9 (+ 1 2)) (3 these these) (+ 4 5) #\d #\c are #\c))))))
+  (define (mult-match-lambda*-tests)
+    (list
+     (let ((tlp645
+             (match-lambda*
+               ((list
+                 (box
+                  (list
+                   (and (? number? tlp622) (? even? tlp623))
+                   (list-rest
+                     (list tlp624 ___)
+                     (and (? number? tlp625) (? even? tlp626))
+                     #\c
+                     #\a)
+                   tlp627))
+                 tlp628
+                 (list tlp629 ___)
+                 #\c)
+                (list tlp622 tlp624 tlp625 tlp627 tlp628 tlp629))
+               ((list
+                 tlp630
+                 (or (vector
+                       _
+                       (vector tlp631 ...)
+                       (vector
+                         (list-rest tlp632 tlp633 tlp634 tlp635)
+                         (and tlp636 tlp637)
+                         #\b
+                         (struct test-struct (tlp638 tlp639 tlp640 tlp641)))
+                       (list))
+                     (vector
+                       _
+                       (vector tlp631 ...)
+                       (vector
+                         (list-rest tlp632 tlp633 tlp634 tlp635)
+                         (and tlp636 tlp637)
+                         #\b
+                         (struct test-struct (tlp638 tlp639 tlp640 tlp641)))
+                       (list)))
+                 #f
+                 (and (? number? tlp643) (? even? tlp644)))
+                (list
+                 tlp630
+                 tlp631
+                 tlp632
+                 tlp633
+                 tlp634
+                 tlp635
+                 tlp636
+                 tlp638
+                 tlp639
+                 tlp640
+                 tlp641
+                 tlp643)))))
+       (list
+        (mytest
+         (tlp645 `#&(4 ((1 these 7) 2 #\c . #\a) #t) `#\a `(7 #f #t) `#\c)
+         '(4 (1 these 7) 2 #t #\a (7 #f #t)))
+        (mytest
+         (tlp645
+           `#\c
+           `#4(are
+               #3(#\a (+ 1 2) #\d)
+               #4((#\c #\b #t . #\b) #f #\b ,inst-struct-name642)
+               ())
+           `#f
+           `14)
+         '(#\c
+           (#\a (+ 1 2) #\d)
+           #\c
+           #\b
+           #t
+           #\b
+           #f
+           #\d
+           (+ 4 5)
+           (+ 4 5)
+           (+ 1 2)
+           14))))
+     (let ((tlp672
+             (match-lambda*
+               ((list
+                 (vector
+                   #t
+                   (list)
+                   (list
+                    tlp647
+                    (or (box (list tlp648 tlp649 tlp650))
+                        (box (list tlp648 tlp649 tlp650)))
+                    (list tlp651 ...)
+                    tlp652)
+                   #f)
+                 'these
+                 tlp653
+                 tlp654)
+                (list tlp647 tlp648 tlp649 tlp650 tlp651 tlp652 tlp653 tlp654))
+               ((list
+                 (list-rest
+                   (list tlp655 __3)
+                   (list tlp656 ___)
+                   (struct
+                     test-struct
+                     ((and (? test-struct? tlp662)
+                           (app test-struct-a tlp657)
+                           (app test-struct-b tlp658)
+                           (app test-struct-c tlp659)
+                           (app test-struct-d tlp660))
+                      (list-rest tlp663 tlp664 tlp665 #\a)
+                      (list-rest tlp666 tlp667 tlp668 #\b)
+                      _))
+                   'are)
+                 (not (not 'symbols))
+                 (and tlp670 tlp671)
+                 _)
+                (list
+                 tlp655
+                 tlp656
+                 tlp657
+                 tlp658
+                 tlp659
+                 tlp660
+                 tlp663
+                 tlp664
+                 tlp665
+                 tlp666
+                 tlp667
+                 tlp668
+                 tlp670)))))
+       (list
+        (mytest
+         (tlp672
+           `#4(#t () (#\c #&(#\a #t symbols) (symbols 2 #\a) (+ 4 5)) #f)
+           `these
+           `#\d
+           `3)
+         '(#\c #\a #t symbols (symbols 2 #\a) (+ 4 5) #\d 3))
+        (mytest
+         (tlp672
+           `((#\d symbols #t) (symbols #t #\c) ,inst-struct-name669 . are)
+           `symbols
+           `#\c
+           `#f)
+         '((#\d symbols #t)
+           (symbols #t #\c)
+           #\a
+           #\c
+           #f
+           #\c
+           #\b
+           #\b
+           #f
+           #\d
+           #t
+           (+ 1 2)
+           #\c))))))
+ (define (test-all1)
+    (list
+     (let-tests)
+     (define-tests)
+     (sing-match-tests)
+     (mult-match-tests)
+     (sing-match-lambda-tests)
+     (mult-match-lambda-tests)
+     (sing-match-lambda*-tests)
+     (mult-match-lambda*-tests)))
+(test-all1)
+
+;; hand made match tests
+
+ (mytest
+  (letrec ((z
+            (lambda (x)
+              (match
+               x
+               ((list a b c)
+                (if (= a 10)
+                  (list a b c)
+                  (begin (cons a (z (list (add1 a) 2 3))))))))))
+    (z '(1 2 3)))
+  '(1 2 3 4 5 6 7 8 9 10 2 3))
+ (mytest
+  (letrec ((z
+            (match-lambda
+              ((list a b c)
+               (if (= a 10) (list a b c) (cons a (z (list (add1 a) 2 3))))))))
+    (z '(1 2 3)))
+  '(1 2 3 4 5 6 7 8 9 10 2 3))
+ (mytest
+  (letrec ((z
+            (match-lambda*
+              ((list a b c)
+               (if (= a 10) (list a b c) (cons a (z (add1 a) 2 3)))))))
+    (z 1 2 3))
+  '(1 2 3 4 5 6 7 8 9 10 2 3))
+ (mytest
+  (match-let
+    (((list a b c) '(1 2 3)) ((list d e f) '(4 5 6)))
+    (list a b c d e f))
+  '(1 2 3 4 5 6))
+ (mytest
+  (match-let
+    hey
+    (((list a b c) '(1 2 3)) ((list d e f) '(4 5 6)))
+    (list a b c d e f))
+  '(1 2 3 4 5 6))
+ (mytest
+  (match-let
+    hey
+    (((list a b c) '(1 2 3)) ((list d e f) '(4 5 6)))
+    (if (= a 10) '() (cons a (hey (list (add1 a) b c) '(d e f)))))
+  '(1 2 3 4 5 6 7 8 9))
+ (mytest
+  (let ((f 7))
+    (match-let
+      (((list a b c) (list 1 2 f)) ((list d e) '(5 6)))
+      (list a d c f)))
+  '(1 5 7 7))
+ (mytest
+  (match-let*
+    (((list a b c) '(1 2 3)) ((list d e f) '(4 5 6)))
+    (list a b c d e f))
+  '(1 2 3 4 5 6))
+ (mytest
+  (match-let*
+    (((list a b c) '(1 2 3)) ((list d e f) (list a b c)))
+    (list d e f))
+  '(1 2 3))
+ (mytest
+  (let ((f 7))
+    (match-let*
+      (((list a b c) (list 1 2 f)) ((list d e) '(5 6)))
+      (list a d c f)))
+  '(1 5 7 7))
+ (mytest
+  (match-letrec
+    (((list a b c) '(1 2 3)) ((list d e f) '(4 5 6)))
+    (list a b c d e f))
+  '(1 2 3 4 5 6))
+ (mytest
+  (match-letrec
+    (((list a b)
+      (list
+       (lambda (x) (if (zero? x) '() (cons x (a (sub1 x)))))
+       (lambda (x) (if (= x 10) '() (cons x (b (add1 x))))))))
+    (a 10))
+  '(10 9 8 7 6 5 4 3 2 1))
+ (mytest
+  (match-letrec
+    (((list a b)
+      (list
+       (lambda (x) (if (zero? x) '() (cons (b x) (a (sub1 x)))))
+       (lambda (x) (if (= x 10) '() (cons x (b (add1 x))))))))
+    (a 10))
+  '(()
+    (9)
+    (8 9)
+    (7 8 9)
+    (6 7 8 9)
+    (5 6 7 8 9)
+    (4 5 6 7 8 9)
+    (3 4 5 6 7 8 9)
+    (2 3 4 5 6 7 8 9)
+    (1 2 3 4 5 6 7 8 9)))
+ (mytest
+  (let ((f 7))
+    (match-letrec
+      (((list a b c) (list 1 2 f)) ((list d e) '(5 6)))
+      (list a d c f)))
+  '(1 5 7 7))
+ (mytest
+  (let ((f 7)) ((match-lambda ((list a b) (list a b f))) '(4 5)))
+  '(4 5 7))
+ (mytest (let ((f 7)) ((match-lambda* ((list a b) (list a b f))) 4 5)) '(4 5 7))
+ (mytest
+  (let ((f 7)) (match-define (list a b c) (list 1 2 f)) (list a b c f))
+  '(1 2 7 7))
+ (let ()
+   (match-define
+     (list a b)
+     (list
+      (lambda (x) (if (zero? x) '() (cons (b x) (a (sub1 x)))))
+      (lambda (x) (if (= x 10) '() (cons x (b (add1 x)))))))
+   (mytest
+    (a 10)
+    '(()
+      (9)
+      (8 9)
+      (7 8 9)
+      (6 7 8 9)
+      (5 6 7 8 9)
+      (4 5 6 7 8 9)
+      (3 4 5 6 7 8 9)
+      (2 3 4 5 6 7 8 9)
+      (1 2 3 4 5 6 7 8 9))))
+ (mytest (match '((1) (2) (3)) ((list (list _) ...) 'hey)) 'hey)
+ (mytest
+  (match
+   '(1 2 3)
+   ((list a b c) (=> fail) (if (= a 1) (fail) 'bad))
+   ((list a b c) (=> fail) (if (= a 1) (fail) 'bad))
+   ((list a b c) (=> fail) (if (= a 1) (fail) 'bad))
+   ((list a b c) (=> fail) (if (= a 1) (fail) 'bad))
+   ((list a b c) (=> fail) (if (= a 1) (fail) 'bad))
+   ((list a b c) (=> fail) (if (= a 1) (fail) 'bad))
+   ((list a b c) (list a b c)))
+  '(1 2 3))
+ (mytest
+  (let ((x '(1 2 (3 4))))
+    (match x ((list _ _ (list (set! set-it) _)) (set-it 17)))
+    x)
+  '(1 2 (17 4)))
+ (mytest
+  (let ((x '(1 2 (3 4))))
+    (match x ((list _ _ (list _ (set! set-it))) (set-it 17)))
+    x)
+  '(1 2 (3 17)))
+ (mytest
+  (let ((x '(1 2 (3 4))))
+    (match x ((list (set! set-it) _ (list _ _)) (set-it 17)))
+    x)
+  '(17 2 (3 4)))
+ (mytest
+  (let ((x '(1 2 (3 4))))
+    (match x ((list _ (set! set-it) (list _ _)) (set-it 17)))
+    x)
+  '(1 17 (3 4)))
+ (mytest
+  (let ((x '(1 2 (3 . 4) . 5)))
+    (match x ((list-rest (set! set-it) _ (list-rest _ _) _) (set-it 17)))
+    x)
+  '(17 2 (3 . 4) . 5))
+ (mytest
+  (let ((x '(1 2 (3 . 4) . 5)))
+    (match x ((list-rest _ (set! set-it) (list-rest _ _) _) (set-it 17)))
+    x)
+  '(1 17 (3 . 4) . 5))
+ (mytest
+  (let ((x '(1 2 (3 . 4) . 5)))
+    (match x ((list-rest _ _ (list-rest (set! set-it) _) _) (set-it 17)))
+    x)
+  '(1 2 (17 . 4) . 5))
+ (mytest
+  (let ((x '(1 2 (3 . 4) . 5)))
+    (match x ((list-rest _ _ (list-rest _ (set! set-it)) _) (set-it 17)))
+    x)
+  '(1 2 (3 . 17) . 5))
+ (mytest
+  (let ((x '(1 2 (3 . 4) . 5)))
+    (match x ((list-rest _ _ (list-rest _ _) (set! set-it)) (set-it 17)))
+    x)
+  '(1 2 (3 . 4) . 17))
+ (mytest
+  (let ((x #2(1 2))) (match x ((vector _ (set! set-it)) (set-it 17))) x)
+  #2(1 17))
+ (mytest
+  (let ((x #2(1 2))) (match x ((vector (set! set-it) _) (set-it 17))) x)
+  #2(17 2))
+ (mytest (let ((x #&1)) (match x ((box (set! set-it)) (set-it 17))) x) #&17)
+ (mytest
+  (let ((x #&(1 2))) (match x ((box (list _ (set! set-it))) (set-it 17))) x)
+  #&(1 17))
+ (mytest
+  (let ((x #&#2(1 2)))
+    (match x ((box (vector _ (set! set-it))) (set-it 17)))
+    x)
+  #&#2(1 17))
+ (mytest
+  (let* ((x '(1 2 (3 4)))
+         (f (match x ((list _ _ (list (get! get-it) _)) get-it))))
+    (match x ((list _ _ (list (set! set-it) _)) (set-it 17)))
+    (f))
+  17)
+ (mytest
+  (let* ((x '(1 2 (3 4)))
+         (f (match x ((list _ _ (list _ (get! get-it))) get-it))))
+    (match x ((list _ _ (list _ (set! set-it))) (set-it 17)))
+    (f))
+  17)
+ (mytest
+  (let* ((x '(1 2 (3 4)))
+         (f (match x ((list (get! get-it) _ (list _ _)) get-it))))
+    (match x ((list (set! set-it) _ (list _ _)) (set-it 17)))
+    (f))
+  17)
+ (mytest
+  (let* ((x '(1 2 (3 4)))
+         (f (match x ((list _ (get! get-it) (list _ _)) get-it))))
+    (match x ((list _ (set! set-it) (list _ _)) (set-it 17)))
+    (f))
+  17)
+ (mytest
+  (let* ((x '(1 2 (3 . 4) . 5))
+         (f (match x ((list-rest (get! get-it) _ (list-rest _ _) _) get-it))))
+    (match x ((list-rest (set! set-it) _ (list-rest _ _) _) (set-it 17)))
+    (f))
+  17)
+ (mytest
+  (let* ((x '(1 2 (3 . 4) . 5))
+         (f (match x ((list-rest _ (get! get-it) (list-rest _ _) _) get-it))))
+    (match x ((list-rest _ (set! set-it) (list-rest _ _) _) (set-it 17)))
+    (f))
+  17)
+ (mytest
+  (let* ((x '(1 2 (3 . 4) . 5))
+         (f (match x ((list-rest _ _ (list-rest (get! get-it) _) _) get-it))))
+    (match x ((list-rest _ _ (list-rest (set! set-it) _) _) (set-it 17)))
+    (f))
+  17)
+ (mytest
+  (let* ((x '(1 2 (3 . 4) . 5))
+         (f (match x ((list-rest _ _ (list-rest _ (get! get-it)) _) get-it))))
+    (match x ((list-rest _ _ (list-rest _ (set! set-it)) _) (set-it 17)))
+    (f))
+  17)
+ (mytest
+  (let* ((x '(1 2 (3 . 4) . 5))
+         (f (match x ((list-rest _ _ (list-rest _ _) (get! get-it)) get-it))))
+    (match x ((list-rest _ _ (list-rest _ _) (set! set-it)) (set-it 17)))
+    (f))
+  17)
+ (mytest
+  (let* ((x #2(1 2)) (f (match x ((vector _ (get! get-it)) get-it))))
+    (match x ((vector _ (set! set-it)) (set-it 17)))
+    (f))
+  17)
+ (mytest
+  (let* ((x #2(1 2)) (f (match x ((vector (get! get-it) _) get-it))))
+    (match x ((vector (set! set-it) _) (set-it 17)))
+    (f))
+  17)
+ (mytest
+  (let* ((x #&1) (f (match x ((box (get! get-it)) get-it))))
+    (match x ((box (set! set-it)) (set-it 17)))
+    (f))
+  17)
+ (mytest
+  (let* ((x #&(1 2)) (f (match x ((box (list _ (get! get-it))) get-it))))
+    (match x ((box (list _ (set! set-it))) (set-it 17)))
+    (f))
+  17)
+ (mytest
+  (let* ((x #&#2(1 2)) (f (match x ((box (vector _ (get! get-it))) get-it))))
+    (match x ((box (vector _ (set! set-it))) (set-it 17)))
+    (f))
+  17)
+ (mytest
+  (match
+   #2(#3(#3(1 2 3) #3(1 2 3) #3(2 3 4)) #3(#3(1 2 3) #3(1 2 3) #3(2 3 4)))
+   ((vector (vector (vector a ...) ...) ...) a))
+  '(((1 2 3) (1 2 3) (2 3 4)) ((1 2 3) (1 2 3) (2 3 4))))
+ (mytest
+  (match
+   '(((1 2 3) (1 2 3) (2 3 4)) ((1 2 3) (1 2 3) (2 3 4)))
+   ((list (list (list a ...) ...) ...) a))
+  '(((1 2 3) (1 2 3) (2 3 4)) ((1 2 3) (1 2 3) (2 3 4))))
+ (mytest
+  (match
+   '((((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))
+      ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))))
+     (((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))
+      ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))))
+   ((list (list (list (list (list (list a ...) ...) ...) ...) ...) ...) a))
+  '((((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))
+     ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))))
+    (((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))
+     ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))))))
+ (mytest
+  (match
+   #2(#2(#2(#2(#2(#2(1 2) #2(3 4)) #2(#2(5 6) #2(7 8)))
+            #2(#2(#2(1 2) #2(3 4)) #2(#2(5 6) #2(7 8))))
+         #2(#2(#2(#2(1 2) #2(3 4)) #2(#2(5 6) #2(7 8)))
+            #2(#2(#2(1 2) #2(3 4)) #2(#2(5 6) #2(7 8)))))
+      #2(#2(#2(#2(#2(1 2) #2(3 4)) #2(#2(5 6) #2(7 8)))
+            #2(#2(#2(1 2) #2(3 4)) #2(#2(5 6) #2(7 8))))
+         #2(#2(#2(#2(1 2) #2(3 4)) #2(#2(5 6) #2(7 8)))
+            #2(#2(#2(1 2) #2(3 4)) #2(#2(5 6) #2(7 8))))))
+   ((vector
+      (vector (vector (vector (vector (vector a ...) ...) ...) ...) ...)
+      ...)
+    a))
+  '((((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))
+     ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))))
+    (((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))
+     ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))))))
+ (mytest
+  (match
+   '(#2((#2((#2(1 2) #2(3 4)) (#2(5 6) #2(7 8)))
+         #2((#2(1 2) #2(3 4)) (#2(5 6) #2(7 8))))
+        (#2((#2(1 2) #2(3 4)) (#2(5 6) #2(7 8)))
+         #2((#2(1 2) #2(3 4)) (#2(5 6) #2(7 8)))))
+     #2((#2((#2(1 2) #2(3 4)) (#2(5 6) #2(7 8)))
+         #2((#2(1 2) #2(3 4)) (#2(5 6) #2(7 8))))
+        (#2((#2(1 2) #2(3 4)) (#2(5 6) #2(7 8)))
+         #2((#2(1 2) #2(3 4)) (#2(5 6) #2(7 8))))))
+   ((list (vector (list (vector (list (vector a ...) ...) ...) ...) ...) ...)
+    a))
+  '((((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))
+     ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))))
+    (((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))
+     ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))))))
+ (mytest
+  (match
+   '((((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))
+      ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))))
+     (((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))
+      ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))))
+   ((list (list (list (list (list (list a ..2) ..2) ..2) ..2) ..2) ..2) a))
+  '((((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))
+     ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))))
+    (((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))
+     ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))))))
+ (mytest
+  (match
+   #2(#2(#2(#2(#2(#2(1 2) #2(3 4)) #2(#2(5 6) #2(7 8)))
+            #2(#2(#2(1 2) #2(3 4)) #2(#2(5 6) #2(7 8))))
+         #2(#2(#2(#2(1 2) #2(3 4)) #2(#2(5 6) #2(7 8)))
+            #2(#2(#2(1 2) #2(3 4)) #2(#2(5 6) #2(7 8)))))
+      #2(#2(#2(#2(#2(1 2) #2(3 4)) #2(#2(5 6) #2(7 8)))
+            #2(#2(#2(1 2) #2(3 4)) #2(#2(5 6) #2(7 8))))
+         #2(#2(#2(#2(1 2) #2(3 4)) #2(#2(5 6) #2(7 8)))
+            #2(#2(#2(1 2) #2(3 4)) #2(#2(5 6) #2(7 8))))))
+   ((vector
+      (vector (vector (vector (vector (vector a ..2) ..2) ..2) ..2) ..2)
+      ..2)
+    a))
+  '((((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))
+     ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))))
+    (((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))
+     ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))))))
+ (mytest
+  (match
+   '(#2((#2((#2(1 2) #2(3 4)) (#2(5 6) #2(7 8)))
+         #2((#2(1 2) #2(3 4)) (#2(5 6) #2(7 8))))
+        (#2((#2(1 2) #2(3 4)) (#2(5 6) #2(7 8)))
+         #2((#2(1 2) #2(3 4)) (#2(5 6) #2(7 8)))))
+     #2((#2((#2(1 2) #2(3 4)) (#2(5 6) #2(7 8)))
+         #2((#2(1 2) #2(3 4)) (#2(5 6) #2(7 8))))
+        (#2((#2(1 2) #2(3 4)) (#2(5 6) #2(7 8)))
+         #2((#2(1 2) #2(3 4)) (#2(5 6) #2(7 8))))))
+   ((list (vector (list (vector (list (vector a ..2) ..2) ..2) ..2) ..2) ..2)
+    a))
+  '((((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))
+     ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))))
+    (((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))
+     ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))))))
+ (mytest
+  (match
+   '((((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))
+      ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))))
+     (((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))
+      ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))))
+   ((list (list (list (list (list (list _ ...) ...) ...) ...) ...) ...) #t)
+   (_ #f))
+  #t)
+ (mytest
+  (match
+   #2(#2(#2(#2(#2(#2(1 2) #2(3 4)) #2(#2(5 6) #2(7 8)))
+            #2(#2(#2(1 2) #2(3 4)) #2(#2(5 6) #2(7 8))))
+         #2(#2(#2(#2(1 2) #2(3 4)) #2(#2(5 6) #2(7 8)))
+            #2(#2(#2(1 2) #2(3 4)) #2(#2(5 6) #2(7 8)))))
+      #2(#2(#2(#2(#2(1 2) #2(3 4)) #2(#2(5 6) #2(7 8)))
+            #2(#2(#2(1 2) #2(3 4)) #2(#2(5 6) #2(7 8))))
+         #2(#2(#2(#2(1 2) #2(3 4)) #2(#2(5 6) #2(7 8)))
+            #2(#2(#2(1 2) #2(3 4)) #2(#2(5 6) #2(7 8))))))
+   ((vector
+      (vector (vector (vector (vector (vector _ ...) ...) ...) ...) ...)
+      ...)
+    #t)
+   (_ #f))
+  #t)
+ (mytest
+  (match
+   '(#2((#2((#2(1 2) #2(3 4)) (#2(5 6) #2(7 8)))
+         #2((#2(1 2) #2(3 4)) (#2(5 6) #2(7 8))))
+        (#2((#2(1 2) #2(3 4)) (#2(5 6) #2(7 8)))
+         #2((#2(1 2) #2(3 4)) (#2(5 6) #2(7 8)))))
+     #2((#2((#2(1 2) #2(3 4)) (#2(5 6) #2(7 8)))
+         #2((#2(1 2) #2(3 4)) (#2(5 6) #2(7 8))))
+        (#2((#2(1 2) #2(3 4)) (#2(5 6) #2(7 8)))
+         #2((#2(1 2) #2(3 4)) (#2(5 6) #2(7 8))))))
+   ((list (vector (list (vector (list (vector _ ...) ...) ...) ...) ...) ...)
+    #t)
+   (_ #f))
+  #t)
+ (mytest
+  (match
+   '((((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))
+      ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))))
+     (((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))
+      ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))))
+   ((list (list (list (list (list (list a b) ...) ...) ...) ...) ...)
+    (list a b)))
+  '((((((1 3) (5 7)) ((1 3) (5 7))) (((1 3) (5 7)) ((1 3) (5 7))))
+     ((((1 3) (5 7)) ((1 3) (5 7))) (((1 3) (5 7)) ((1 3) (5 7)))))
+    (((((2 4) (6 8)) ((2 4) (6 8))) (((2 4) (6 8)) ((2 4) (6 8))))
+     ((((2 4) (6 8)) ((2 4) (6 8))) (((2 4) (6 8)) ((2 4) (6 8)))))))
+ (mytest
+  (match
+   #2(#2(#2(#2(#2(#2(1 2) #2(3 4)) #2(#2(5 6) #2(7 8)))
+            #2(#2(#2(1 2) #2(3 4)) #2(#2(5 6) #2(7 8))))
+         #2(#2(#2(#2(1 2) #2(3 4)) #2(#2(5 6) #2(7 8)))
+            #2(#2(#2(1 2) #2(3 4)) #2(#2(5 6) #2(7 8)))))
+      #2(#2(#2(#2(#2(1 2) #2(3 4)) #2(#2(5 6) #2(7 8)))
+            #2(#2(#2(1 2) #2(3 4)) #2(#2(5 6) #2(7 8))))
+         #2(#2(#2(#2(1 2) #2(3 4)) #2(#2(5 6) #2(7 8)))
+            #2(#2(#2(1 2) #2(3 4)) #2(#2(5 6) #2(7 8))))))
+   ((vector
+      (vector (vector (vector (vector (vector a b) ...) ...) ...) ...)
+      ...)
+    (list a b)))
+  '((((((1 3) (5 7)) ((1 3) (5 7))) (((1 3) (5 7)) ((1 3) (5 7))))
+     ((((1 3) (5 7)) ((1 3) (5 7))) (((1 3) (5 7)) ((1 3) (5 7)))))
+    (((((2 4) (6 8)) ((2 4) (6 8))) (((2 4) (6 8)) ((2 4) (6 8))))
+     ((((2 4) (6 8)) ((2 4) (6 8))) (((2 4) (6 8)) ((2 4) (6 8)))))))
+ (mytest
+  (match
+   '(#2((#2((#2(1 2) #2(3 4)) (#2(5 6) #2(7 8)))
+         #2((#2(1 2) #2(3 4)) (#2(5 6) #2(7 8))))
+        (#2((#2(1 2) #2(3 4)) (#2(5 6) #2(7 8)))
+         #2((#2(1 2) #2(3 4)) (#2(5 6) #2(7 8)))))
+     #2((#2((#2(1 2) #2(3 4)) (#2(5 6) #2(7 8)))
+         #2((#2(1 2) #2(3 4)) (#2(5 6) #2(7 8))))
+        (#2((#2(1 2) #2(3 4)) (#2(5 6) #2(7 8)))
+         #2((#2(1 2) #2(3 4)) (#2(5 6) #2(7 8))))))
+   ((list (vector (list (vector (list (vector a b) ...) ...) ...) ...) ...)
+    (list a b)))
+  '((((((1 3) (5 7)) ((1 3) (5 7))) (((1 3) (5 7)) ((1 3) (5 7))))
+     ((((1 3) (5 7)) ((1 3) (5 7))) (((1 3) (5 7)) ((1 3) (5 7)))))
+    (((((2 4) (6 8)) ((2 4) (6 8))) (((2 4) (6 8)) ((2 4) (6 8))))
+     ((((2 4) (6 8)) ((2 4) (6 8))) (((2 4) (6 8)) ((2 4) (6 8)))))))
+ (mytest
+  (match
+   '((1 1 2 2) (1 1 2 2) 5 5 5)
+   ((list (list 1 ... a ...) ... 7 ...) #f)
+   ((list (list 1 ... a ...) ... 6 ...) #f)
+   ((list (list 1 ... a ...) ... 5 ...) a))
+  '((2 2) (2 2)))
+ (mytest (match '(1 1 1 1 1 2 2 2 2) ((list 1 ... 2 2 2 2) #t)) #t)
+ (mytest (match '(1 1 1 1 1 2 2 2 2) ((list 1 ... 2 ...) #t)) #t)
+ (mytest
+  (match '(1 1 1 1 1 2 2 2 2) ((list (and (not 2) a) ... 2 ...) a))
+  '(1 1 1 1 1))
+ (mytest
+  (match '(1 1 1 1 1 2 2 2 2) ((list a ... 2 ...) a))
+  '(1 1 1 1 1 2 2 2 2))
+ (mytest (match '(1 1 1 1 1 2 2 2 2) ((list _ ... 2 ...) #t)) #t)
+ (mytest
+  (match
+   '(pattern matching in scheme is very cool)
+   ((list (and (not 'in) a) ... (and (not 'is) b) ... c ...) (list a c b)))
+  '((pattern matching) (is very cool) (in scheme)))
+ (mytest
+  (match '((1 1 2 2) (1 1 2 2) 5 5 5) ((list (list 1 ... 2 ...) ... 5 ...) #t))
+  #t)
+ (mytest
+  (match
+   #13(1 3 1 9 8 4 2 2 4 7 a b c)
+   ((vector (and (? odd?) a) ... 8 (and (? even?) b) ... 7 r ...)
+    (list a b r)))
+  '((1 3 1 9) (4 2 2 4) (a b c)))
+ (mytest
+  (match
+   #5(#4(1 1 2) #4(1 1 2) 5)
+   ((vector (vector 1 ... 2 ...) ... 5 ...) #t))
+  #t)
+ (mytest
+  (match
+   #5(#4(1 1 2) #4(1 1 2) 5)
+   ((vector (vector 1 ... a ...) ... 7 ...) #f)
+   ((vector (vector 1 ... a ...) ... 6 ...) #f)
+   ((vector (vector 1 ... a ...) ... 5 ...) a))
+  '((2 2) (2 2)))
+ (mytest
+  (match #5(#2(1 2) #2(1 2) #2(1 2) 5 6) ((vector (vector _ _) ..3 a ...) a))
+  '(5 6))
+ (mytest
+  (match #5(1 2 3 4 5) ((vector a b (and c (not 5)) ... d) (list a b c d)))
+  '(1 2 (3 4) 5))
+
+ (mytest (match '(1 2 3 4) ((list-no-order a b 1 c) (list a b c))) '(2 3 4))
+
+;; ddk-patterns for list-rest
+(mytest (match '(1 1 1 1 . 2)
+             ((list-rest 1 ... a) a))
+      2)
+
+(mytest (match '(1 1 1 1 . 2)
+             ((list-rest (and 1 b) ... a) (list b a)))
+      '((1 1 1 1) 2))
+
+(mytest (match '(1 1 1 1 2 . 4)
+             ((list-rest (and 1 b) ... a (and c 4)) (list b a c)))
+      '((1 1 1 1) 2 4))
+
+;the new var pattern
+; this allows one to use 
+; var, $, =, and, or, not, ?, set!, or get!
+; as pattern variables
+(mytest (match '(1 2 3)
+            ((list (var _) b c) (list _ b c)))
+      '(1 2 3))
+
+(mytest (match '(1 2 3)
+            ((list (var ..3) b c) (list ..3 b c)))
+      '(1 2 3))
+
+(mytest (match '(1 2 3)
+            ((list (var quasiquote) b c) (list quasiquote b c)))
+      '(1 2 3))
+
+(mytest (match '(1 2 3)
+            ((list (var quote) b c) (list quote b c)))
+      '(1 2 3))
+
+(mytest (match '(1 2 3)
+            ((list (var unquote) b c) (list unquote b c)))
+      '(1 2 3))
+
+(mytest (match '(1 2 3)
+            ((list (var unquote-splicing) b c) (list unquote-splicing b c)))
+      '(1 2 3))
+
+;the new var pattern
+; this allows one to use 
+; var, $, =, and, or, not, ?, set!, or get!
+; as pattern variables
+(mytest (match '(1 2 3)
+            ((list $ b c) (list $ b c)))
+      '(1 2 3))
+
+(mytest (match '(1 2 3)
+            ((list var b c) (list var b c)))
+      '(1 2 3))
+
+(mytest (match '(1 2 3)
+            ((list  = b c) (list = b c)))
+      '(1 2 3))
+
+(mytest (match '(1 2 3)
+            ((list and b c) (list and b c)))
+      '(1 2 3))
+
+(mytest (match '(1 2 3)
+            ((list or b c) (list or b c)))
+      '(1 2 3))
+
+(mytest (match '(1 2 3)
+            ((list not b c) (list not b c)))
+      '(1 2 3))
+
+(mytest (match '(1 2 3)
+            ((list  ? b c) (list ? b c)))
+      '(1 2 3))
+
+(mytest (match '(1 2 3)
+            ((list set! b c) (list set! b c)))
+      '(1 2 3))
+
+(mytest (match '(1 2 3)
+            ((list get! b c) (list get! b c)))
+      '(1 2 3))
+
+;; structures for the next tests
+
+  (define inst-struct-name3134 (make-test-struct `6 `#t `(+ 4 (+ 1 1)) `#\a))
+  (define inst-struct-name3144 (make-test-struct `#\a `3 `(+ 4 5) `7))
+  (define inst-struct-name3157
+    (make-test-struct
+      `#&((#f (+ 1 2) #\d #\b) (#\d 1 symbols) ,inst-struct-name3134)
+      `((5 7 symbols #t)
+        ,inst-struct-name3144
+        #((+ 4 (+ 1 1)) #f #\a #\d)
+        .
+        #\d)
+      `(#\a (+ 4 (+ 1 1)) these)
+      `(#\b 3 4 #&((+ 4 (+ 1 1)) #f 2))))
+  (define inst-struct-name3197
+    (make-test-struct `(8 #\b (+ 1 2)) `(+ 1 2) `#\a `((+ 1 2) #f 5)))
+  (define inst-struct-name3200
+    (make-test-struct
+      `#(#\b symbols (+ 1 2))
+      `symbols
+      `,inst-struct-name3197
+      `5))
+  (define inst-struct-name3228 (make-test-struct `these `3 `#\d `#t))
+  (define inst-struct-name3234 (make-test-struct `(+ 4 5) `#\a `#\a `#f))
+  (define inst-struct-name3239
+    (make-test-struct `() `#(#\d #\b #\b) `#\c `#\b))
+  (define inst-struct-name3252
+    (make-test-struct
+      `(#t #\c #\c . are)
+      `#((+ 1 2) (+ 4 5) #\b 9)
+      `16
+      `(+ 4 5)))
+  (define inst-struct-name3287
+    (make-test-struct `#\d `#((+ 4 5) #t (+ 4 5) #t) `#t `(+ 4 (+ 1 1))))
+  (define inst-struct-name3297
+    (make-test-struct `these `#f `#(are symbols #\c) `#(these symbols #t #\d)))
+  (define inst-struct-name3307 (make-test-struct `#t `(+ 4 (+ 1 1)) `#\d `#f))
+  (define inst-struct-name3312
+    (make-test-struct
+      `#&(symbols #\d #\c)
+      `,inst-struct-name3307
+      `(these are (+ 1 2) (+ 4 5))
+      `#f))
+  (define inst-struct-name3322
+    (make-test-struct
+      `(#t 6 #\c)
+      `(#t #\d 2 . #\a)
+      `#(#f 6 #\b)
+      `#&(#f 7 symbols)))
+  (define inst-struct-name3355 (make-test-struct `(+ 1 2) `these `#t `#t))
+  (define inst-struct-name3367 (make-test-struct `#\d `#\a `6 `(+ 1 2)))
+  (define inst-struct-name3372 (make-test-struct `symbols `#\a `3 `#\c))
+  (define inst-struct-name3396 (make-test-struct `0 `#\d `#\a `#\b))
+  (define inst-struct-name3419 (make-test-struct `#\c `#\c `symbols `9))
+  (define inst-struct-name3444
+    (make-test-struct
+      `(#\c (+ 4 (+ 1 1)) (+ 4 5))
+      `()
+      `((6 #\a 2) 0 #(these #\c these 1) . 5)
+      `#(#f #\a #\d)))
+  (define inst-struct-name3455
+    (make-test-struct
+      `()
+      `(#\d #t symbols . #\d)
+      `#&(#\d (+ 4 (+ 1 1)) these)
+      `2))
+  (define inst-struct-name3474
+    (make-test-struct `(#t #\c #f . #\d) `#\a `() `(#t #\a #\a)))
+  (define inst-struct-name3482 (make-test-struct `symbols `#\b `#f `#f))
+  (define inst-struct-name3493
+    (make-test-struct
+      `16
+      `(,inst-struct-name3482 #(#f #\c (+ 4 5) #f) #&((+ 4 5) #\d are) (+ 4 5))
+      `#(#t #f 4)
+      `#\d))
+  (define inst-struct-name3505 (make-test-struct `4 `(+ 4 (+ 1 1)) `#f `these))
+  (define inst-struct-name3512
+    (make-test-struct
+      `#&(symbols #f 2)
+      `()
+      `#t
+      `(are (+ 4 (+ 1 1)) (+ 4 (+ 1 1)))))
+  (define inst-struct-name3518 (make-test-struct `8 `#\b `#\c `symbols))
+  (define inst-struct-name3527 (make-test-struct `#\a `#t `4 `#t))
+  (define inst-struct-name3550
+    (make-test-struct `(+ 4 (+ 1 1)) `(#t 8 symbols) `(#\a #\c #t) `0))
+  (define inst-struct-name3570 (make-test-struct `#\b `#\c `#\d `#\c))
+  (define inst-struct-name3577 (make-test-struct `#\b `(+ 1 2) `#\b `#\b))
+  (define inst-struct-name3578
+    (make-test-struct `,inst-struct-name3570 `16 `,inst-struct-name3577 `9))
+  (define inst-struct-name3595
+    (make-test-struct
+      `(0 these are)
+      `(#\d #f (+ 4 (+ 1 1)) . #\c)
+      `#(#\b #\a these symbols)
+      `#\b))
+  (define inst-struct-name3600 (make-test-struct `#\a `0 `2 `2))
+  (define inst-struct-name3605 (make-test-struct `are `1 `3 `#\d))
+  (define inst-struct-name3625
+    (make-test-struct
+      `()
+      `#\a
+      `#(#\a #\c (+ 1 2) #t)
+      `#((+ 4 (+ 1 1)) #\b 5 these)))
+  (define inst-struct-name3633 (make-test-struct `(+ 4 (+ 1 1)) `are `#f `#\c))
+  (define inst-struct-name3639
+    (make-test-struct `#\a `,inst-struct-name3633 `#&(are symbols 4) `#\c))
+  (define inst-struct-name3677
+    (make-test-struct `#(#\b are #\b) `#\a `#\c `(#\b #\c #\d . #\d)))
+  (define inst-struct-name3701
+    (make-test-struct `#\b `9 `#&(#\c (#f #\d (+ 1 2)) are) `#\d))
+  (define inst-struct-name3712
+    (make-test-struct `#\d `#\d `(+ 4 (+ 1 1)) `are))
+  (define inst-struct-name3744
+    (make-test-struct `symbols `(+ 1 2) `symbols `#\b))
+  (define inst-struct-name3752 (make-test-struct `#\b `#t `(+ 4 5) `#\b))
+  (define inst-struct-name3753
+    (make-test-struct
+      `,inst-struct-name3744
+      `#(#\c #\d #\d)
+      `#\b
+      `,inst-struct-name3752))
+  (define inst-struct-name3755
+    (make-test-struct `(these 0 3) `(+ 4 5) `2 `,inst-struct-name3753))
+  (define inst-struct-name3762 (make-test-struct `these `(+ 1 2) `2 `#\d))
+  (define inst-struct-name3776 (make-test-struct `#\b `#\b `symbols `these))
+  (define inst-struct-name3777
+    (make-test-struct
+      `#&(symbols (+ 4 (+ 1 1)) (+ 1 2))
+      `#(#\c 6 #\c #t)
+      `#\b
+      `,inst-struct-name3776))
+  (define inst-struct-name3805
+    (make-test-struct `#\d `#&((+ 1 2) #\d 1) `(+ 4 5) `#\b))
+  (define inst-struct-name3817 (make-test-struct `1 `(+ 1 2) `#\d `(+ 1 2)))
+  (define inst-struct-name3820
+    (make-test-struct
+      `#\d
+      `(2 (+ 4 (+ 1 1)) symbols)
+      `,inst-struct-name3817
+      `#((+ 1 2) 8 (+ 4 5))))
+  (define inst-struct-name3822
+    (make-test-struct
+      `,inst-struct-name3805
+      `#&(#&(#f (+ 4 (+ 1 1)) #\d) #\c (#t #\c #f))
+      `(+ 4 5)
+      `,inst-struct-name3820))
+  (define inst-struct-name3851 (make-test-struct `#f `(+ 1 2) `#\a `#f))
+  (define inst-struct-name3854
+    (make-test-struct `#\b `#\b `,inst-struct-name3851 `18))
+  (define inst-struct-name3856
+    (make-test-struct
+      `#&(#t #\a symbols)
+      `(((+ 4 (+ 1 1)) (+ 4 5) #\b) #t 12 #(these #\c #f))
+      `(#(#\d these #\d) #t 7 #f)
+      `,inst-struct-name3854))
+  (define inst-struct-name3890
+    (make-test-struct `#f `(#t #f are symbols) `#\d `#t))
+  (define inst-struct-name3900 (make-test-struct `(+ 4 (+ 1 1)) `0 `#\d `0))
+  (define inst-struct-name3902
+    (make-test-struct
+      `,inst-struct-name3890
+      `(+ 4 5)
+      `()
+      `#((#\a 7 #\b (+ 1 2)) ,inst-struct-name3900 #\b ())))
+  (define inst-struct-name3928
+    (make-test-struct `8 `#\c `#\c `#(8 #\d #f #\a)))
+  (define inst-struct-name3939 (make-test-struct `6 `#\d `(+ 4 (+ 1 1)) `7))
+  (define inst-struct-name3944
+    (make-test-struct
+      `#\d
+      `,inst-struct-name3928
+      `(,inst-struct-name3939 () #&(#\b #f #\b) #t)
+      `(4 (+ 1 2) 3)))
+  (define inst-struct-name3952
+    (make-test-struct `() `7 `(+ 1 2) `(#\d #\d #\c)))
+  (define inst-struct-name3957
+    (make-test-struct `#t `(#\a #\b symbols) `#\d `10))
+  (define inst-struct-name3962 (make-test-struct `4 `(+ 4 (+ 1 1)) `#\c `6))
+  (define inst-struct-name3973 (make-test-struct `#t `1 `2 `#t))
+  (define inst-struct-name3974
+    (make-test-struct `(+ 4 (+ 1 1)) `9 `#f `,inst-struct-name3973))
+  (define inst-struct-name3986 (make-test-struct `these `#\d `#f `#t))
+  (define inst-struct-name3998 (make-test-struct `(+ 4 5) `#f `0 `#\a))
+  (define inst-struct-name4008 (make-test-struct `#\c `#t `#\c `#t))
+  (define inst-struct-name4019
+    (make-test-struct
+      `((+ 4 5) #\b these . 1)
+      `,inst-struct-name4008
+      `(2 #f #t #\d)
+      `#(9 #\b 2)))
+  (define inst-struct-name4024
+    (make-test-struct `#\a `(+ 4 (+ 1 1)) `(+ 4 (+ 1 1)) `#t))
+  (define inst-struct-name4026
+    (make-test-struct `(+ 1 2) `,inst-struct-name4024 `() `#\d))
+  (define inst-struct-name4028
+    (make-test-struct
+      `(#\a 8 #f)
+      `,inst-struct-name4019
+      `()
+      `,inst-struct-name4026))
+  (define inst-struct-name4042
+    (make-test-struct
+      `#\b
+      `(5 (+ 4 5) (+ 4 (+ 1 1)) #\d)
+      `(are #\b these . 2)
+      `#\b))
+  (define inst-struct-name4060 (make-test-struct `0 `symbols `#f `#\a))
+  (define inst-struct-name4063
+    (make-test-struct `8 `#&(5 #\c #f) `,inst-struct-name4060 `10))
+  (define inst-struct-name4064
+    (make-test-struct `4 `#f `0 `,inst-struct-name4063))
+  (define inst-struct-name4088
+    (make-test-struct
+      `#\a
+      `(#\d symbols these)
+      `(#\a are 2 #(#\b 0 symbols #\d))
+      `#f))
+  (define inst-struct-name4109 (make-test-struct `4 `symbols `(+ 4 5) `#\b))
+  (define inst-struct-name4137
+    (make-test-struct `(+ 4 5) `(+ 4 5) `are `these))
+  (define inst-struct-name4145
+    (make-test-struct
+      `,inst-struct-name4137
+      `#\d
+      `#(2 #\c (+ 1 2) #\c)
+      `(#\c 6 9 . 7)))
+  (define inst-struct-name4146
+    (make-test-struct `these `(+ 4 (+ 1 1)) `(+ 1 2) `,inst-struct-name4145))
+  (define inst-struct-name4160 (make-test-struct `4 `#\d `2 `#\a))
+  (define inst-struct-name4174
+    (make-test-struct
+      `these
+      `#((#t (+ 1 2) #\c are) #(#\d (+ 4 5) #\a #\d) ,inst-struct-name4160 #t)
+      `(#\b #\b 9)
+      `#(#\c #(#\c #\c #\c #f) these ())))
+  (define inst-struct-name4181 (make-test-struct `#\c `#(#f #\c #t) `#f `#t))
+  (define inst-struct-name4194 (make-test-struct `#\a `#t `6 `symbols))
+  (define inst-struct-name4208
+    (make-test-struct
+      `(#f 7 #t)
+      `,inst-struct-name4181
+      `#&(#(#f symbols (+ 1 2) #\a)
+          ((+ 1 2) symbols #\b #\c)
+          ,inst-struct-name4194)
+      `#t))
+  (define inst-struct-name4214
+    (make-test-struct `(+ 4 5) `symbols `#\d `these))
+  (define inst-struct-name4239
+    (make-test-struct `(#\c 6 (+ 4 5) . #f) `() `14 `(#\a (+ 4 5) #\a . #\c)))
+  (define inst-struct-name4241
+    (make-test-struct
+      `()
+      `#(these (#\b #\a these #t) (#\a #\c are) (these 4 #\d))
+      `,inst-struct-name4239
+      `()))
+  (define inst-struct-name4252 (make-test-struct `#t `5 `symbols `(+ 1 2)))
+  (define inst-struct-name4260
+    (make-test-struct `() `symbols `#t `(#\d (+ 4 5) #\b 6)))
+  (define inst-struct-name4266
+    (make-test-struct `symbols `symbols `(+ 4 (+ 1 1)) `(+ 1 2)))
+  (define inst-struct-name4280 (make-test-struct `#\c `8 `#\d `#t))
+  (define inst-struct-name4287
+    (make-test-struct `,inst-struct-name4280 `4 `#\b `(#\b #t #f . #t)))
+  (define inst-struct-name4293
+    (make-test-struct `#\c `#\a `symbols `(#\d #t (+ 4 (+ 1 1)))))
+  (define inst-struct-name4314
+    (make-test-struct
+      `,inst-struct-name4293
+      `8
+      `(#(#\c #\a #t 5) #&((+ 1 2) 6 these) (+ 1 2) (#\c #\c #t))
+      `#&(#(#\c (+ 4 (+ 1 1)) these #t) these (#\a symbols (+ 1 2)))))
+  (define inst-struct-name4325
+    (make-test-struct
+      `#(symbols are (are (+ 4 5) (+ 4 (+ 1 1)) . #\b) 3)
+      `(#\a these (+ 4 5))
+      `()
+      `(#\b #(#\a these #\b) 12 . #t)))
+  (define inst-struct-name4343
+    (make-test-struct `(+ 4 5) `#\a `#t `(+ 4 (+ 1 1))))
+  (define inst-struct-name4348 (make-test-struct `(+ 1 2) `#\a `9 `#\a))
+  (define inst-struct-name4351
+    (make-test-struct
+      `#f
+      `#\c
+      `(+ 1 2)
+      `(,inst-struct-name4343
+        ,inst-struct-name4348
+        #(#\a (+ 4 5) (+ 4 5))
+        #\c)))
+  (define inst-struct-name4363 (make-test-struct `(+ 4 5) `are `#f `#t))
+  (define inst-struct-name4369
+    (make-test-struct
+      `#\b
+      `are
+      `,inst-struct-name4363
+      `((+ 4 (+ 1 1)) (+ 1 2) these #f)))
+  (define inst-struct-name4376 (make-test-struct `#f `#\d `#t `are))
+  (define inst-struct-name4391 (make-test-struct `#t `#\d `6 `#\d))
+  (define inst-struct-name4405 (make-test-struct `(+ 4 5) `symbols `#f `#\b))
+  (define inst-struct-name4409
+    (make-test-struct
+      `#(6 (+ 1 2) #\a)
+      `,inst-struct-name4405
+      `((+ 1 2) 8 8)
+      `((+ 1 2) #\b #f)))
+  (define inst-struct-name4429
+    (make-test-struct
+      `(#\d (+ 4 5) 1 . #\a)
+      `#\a
+      `#(are these are are)
+      `(are #f #\a)))
+  (define inst-struct-name4430
+    (make-test-struct
+      `,inst-struct-name4409
+      `#&(5 #&(symbols #\b #\a) (4 6 #\a #\c))
+      `,inst-struct-name4429
+      `()))
+  (define inst-struct-name4444
+    (make-test-struct
+      `(#\b (+ 1 2) are . 9)
+      `(+ 1 2)
+      `(+ 1 2)
+      `(#\c (+ 1 2) #\d)))
+  (define inst-struct-name4460
+    (make-test-struct
+      `#&(#t (+ 4 5) #\c)
+      `(1 #\c 1)
+      `(#f (+ 4 5) #\a . symbols)
+      `(+ 4 5)))
+  (define inst-struct-name4470
+    (make-test-struct
+      `,inst-struct-name4460
+      `10
+      `#t
+      `(() #\d (#f #\d #\c are) . #\b)))
+  (define inst-struct-name4501 (make-test-struct `#\b `8 `are `#\a))
+  (define inst-struct-name4516
+    (make-test-struct
+      `#&(,inst-struct-name4501 () #(#\b #\b #t #t))
+      `((#\b #\c #t) 0 ((+ 4 5) #t these) . these)
+      `(#\a #\b 0)
+      `()))
+  (define inst-struct-name4532 (make-test-struct `(+ 4 (+ 1 1)) `#\c `#f `#\c))
+  (define inst-struct-name4539
+    (make-test-struct
+      `,inst-struct-name4532
+      `(#f 9 symbols)
+      `#\d
+      `#(are #f are)))
+  (define inst-struct-name4554 (make-test-struct `#f `#\b `(+ 4 5) `these))
+  (define inst-struct-name4555
+    (make-test-struct
+      `#\b
+      `#(#\c #\b #f (+ 4 5))
+      `#(#f 5 #\a)
+      `,inst-struct-name4554))
+  (define inst-struct-name4578
+    (make-test-struct
+      `5
+      `#&(#\c #((+ 4 (+ 1 1)) 9 these (+ 1 2)) are)
+      `#((#\a 1 #t #\c) #f (#f #\c #\a) (+ 4 (+ 1 1)))
+      `#(#\a #t #t)))
+  (define inst-struct-name4593 (make-test-struct `#t `(+ 4 5) `#\d `#t))
+  (define inst-struct-name4594
+    (make-test-struct
+      `these
+      `#(these #\d symbols #\c)
+      `#((+ 4 5) 0 #f #t)
+      `,inst-struct-name4593))
+  (define inst-struct-name4629 (make-test-struct `(+ 4 5) `2 `are `#\d))
+  (define inst-struct-name4635 (make-test-struct `#f `#\d `1 `2))
+  (define inst-struct-name4644
+    (make-test-struct
+      `,inst-struct-name4629
+      `,inst-struct-name4635
+      `#(7 #\c #\b (+ 1 2))
+      `#(#\c (+ 4 5) #t these)))
+  (define inst-struct-name4656
+    (make-test-struct `symbols `these `#f `(+ 4 (+ 1 1))))
+  (define inst-struct-name4663 (make-test-struct `#\c `#\b `#\a `6))
+  (define inst-struct-name4668
+    (make-test-struct
+      `,inst-struct-name4656
+      `18
+      `,inst-struct-name4663
+      `#&(#\b #\c #\a)))
+  (define inst-struct-name4676 (make-test-struct `#\a `#\a `5 `are))
+  (define inst-struct-name4710
+    (make-test-struct
+      `#(#\b #f #f)
+      `#t
+      `18
+      `#(9 (#\a #\a #t) #&(#t #\d #t) (+ 1 2))))
+  (define inst-struct-name4724 (make-test-struct `#\b `#t `#\a `7))
+  (define inst-struct-name4742
+    (make-test-struct `#\a `#\a `(+ 4 (+ 1 1)) `#\c))
+  (define inst-struct-name4748 (make-test-struct `#\c `#\c `#t `symbols))
+  (define inst-struct-name4767
+    (make-test-struct `8 `#&((+ 1 2) these #\b) `8 `10))
+  (define inst-struct-name4787
+    (make-test-struct
+      `#f
+      `(are #f 8 #f)
+      `(+ 4 (+ 1 1))
+      `(#\d #\b (+ 1 2) . 7)))
+  (define inst-struct-name4798
+    (make-test-struct
+      `#\b
+      `#f
+      `#&(3 ((+ 4 (+ 1 1)) #\d (+ 4 (+ 1 1))) ((+ 1 2) #\a 8))
+      `#\d))
+  (define inst-struct-name4804
+    (make-test-struct `5 `(+ 4 (+ 1 1)) `(+ 4 5) `#(symbols 8 #\a)))
+  (define inst-struct-name4835
+    (make-test-struct `#&(#f (+ 1 2) #f) `(+ 1 2) `#\d `(5 #f #\d are)))
+  (define inst-struct-name4844 (make-test-struct `7 `#t `(+ 1 2) `symbols))
+  (define inst-struct-name4850 (make-test-struct `these `symbols `4 `are))
+  (define inst-struct-name4851
+    (make-test-struct
+      `(#f #\d #\a)
+      `7
+      `,inst-struct-name4844
+      `,inst-struct-name4850))
+  (define inst-struct-name4871 (make-test-struct `#f `symbols `#\a `#t))
+  (define inst-struct-name4879
+    (make-test-struct
+      `(#f #\c #\d)
+      `(,inst-struct-name4871 are #(are symbols #\b) (8 #\b (+ 1 2)))
+      `14
+      `#((+ 4 5) (+ 1 2) (+ 4 5))))
+  (define inst-struct-name4891 (make-test-struct `5 `(+ 4 5) `5 `#\a))
+  (define inst-struct-name4893
+    (make-test-struct
+      `(#\a 9 #\a (+ 1 2))
+      `,inst-struct-name4891
+      `(+ 4 (+ 1 1))
+      `#\d))
+  (define inst-struct-name4902 (make-test-struct `#\a `#\d `7 `5))
+  (define inst-struct-name4934 (make-test-struct `are `#\d `(+ 4 5) `symbols))
+  (define inst-struct-name4940 (make-test-struct `#\a `1 `#t `#f))
+  (define inst-struct-name4946 (make-test-struct `are `3 `4 `these))
+  (define inst-struct-name4980 (make-test-struct `#\d `#t `2 `1))
+  (define inst-struct-name4997 (make-test-struct `(+ 1 2) `#\d `these `#\d))
+  (define inst-struct-name4999
+    (make-test-struct
+      `((+ 1 2) #t (+ 4 (+ 1 1)) . 4)
+      `,inst-struct-name4997
+      `9
+      `#t))
+  (define inst-struct-name5031 (make-test-struct `#f `#\b `#\c `are))
+  (define inst-struct-name5037
+    (make-test-struct
+      `#\d
+      `,inst-struct-name5031
+      `(7 2 (+ 1 2))
+      `((+ 1 2) (+ 4 (+ 1 1)) are these)))
+  (define inst-struct-name5040
+    (make-test-struct `(+ 1 2) `symbols `(7 0 #t) `are))
+  (define inst-struct-name5059 (make-test-struct `5 `#f `#\c `(+ 4 (+ 1 1))))
+  (define inst-struct-name5060
+    (make-test-struct
+      `#f
+      `(are 6 #\a)
+      `#t
+      `((+ 4 (+ 1 1)) ,inst-struct-name5059 #t . 5)))
+  (define inst-struct-name5078 (make-test-struct `#\d `#t `#t `#\a))
+  (define inst-struct-name5086
+    (make-test-struct `,inst-struct-name5078 `#\a `() `#\a))
+  (define inst-struct-name5094 (make-test-struct `0 `#(#\d #\a 1 #t) `() `#\b))
+  (define inst-struct-name5097
+    (make-test-struct `() `(#\b #f are) `symbols `#t))
+  (define inst-struct-name5105 (make-test-struct `#\a `these `#\d `2))
+  (define inst-struct-name5110
+    (make-test-struct
+      `(+ 4 5)
+      `#t
+      `#\b
+      `#(,inst-struct-name5105 #\b #(8 #f #f (+ 4 (+ 1 1))) #\b)))
+  (define inst-struct-name5126
+    (make-test-struct `(3 these these) `(#\c 3 #\b) `#t `(#\b #f are)))
+  (define inst-struct-name5137
+    (make-test-struct `#f `7 `(+ 4 (+ 1 1)) `(+ 4 (+ 1 1))))
+  (define inst-struct-name5138
+    (make-test-struct
+      `#\d
+      `#((+ 4 (+ 1 1)) (+ 4 5) 2 #t)
+      `(+ 4 5)
+      `,inst-struct-name5137))
+  (define inst-struct-name5140
+    (make-test-struct
+      `#(() #\a #f #\a)
+      `(10 ((+ 4 (+ 1 1)) #t 9 . #\b) (#\c #\a #\a #\a) #t)
+      `,inst-struct-name5126
+      `,inst-struct-name5138))
+  (define inst-struct-name5172
+    (make-test-struct
+      `(#\c are #t #\d)
+      `(+ 4 5)
+      `(#f #t (+ 4 (+ 1 1)) . these)
+      `16))
+  (define inst-struct-name5175
+    (make-test-struct
+      `,inst-struct-name5172
+      `#\a
+      `(are #\a 7)
+      `#(#f (+ 1 2) (+ 4 5))))
+  (define inst-struct-name5182
+    (make-test-struct `#\c `(are (+ 4 5) (+ 4 5)) `4 `(7 (+ 4 (+ 1 1)) 4)))
+  (define inst-struct-name5195
+    (make-test-struct `0 `these `() `((+ 1 2) symbols #f)))
+  (define inst-struct-name5207
+    (make-test-struct `3 `(+ 1 2) `(+ 4 (+ 1 1)) `4))
+  (define inst-struct-name5210
+    (make-test-struct
+      `()
+      `#\a
+      `(((+ 4 5) (+ 1 2) (+ 4 5))
+        (#\b (+ 4 (+ 1 1)) are . symbols)
+        ,inst-struct-name5207
+        .
+        #t)
+      `4))
+  (define inst-struct-name5226 (make-test-struct `#\b `#\a `(+ 4 5) `#\b))
+  (define inst-struct-name5230
+    (make-test-struct
+      `(#((+ 4 (+ 1 1)) #\b #\a symbols) #\b ,inst-struct-name5226 #\c)
+      `(#\d #\b #\b)
+      `#(5 8 #\d)
+      `#t))
+  (define inst-struct-name5238 (make-test-struct `0 `6 `7 `#f))
+  (define inst-struct-name5244 (make-test-struct `these `(+ 1 2) `#f `#t))
+  (define inst-struct-name5247
+    (make-test-struct
+      `#(#\b #\a (+ 4 5))
+      `,inst-struct-name5244
+      `(0 #\b these)
+      `#t))
+  (define inst-struct-name5249
+    (make-test-struct
+      `((+ 1 2) (5 #\b #f) #\d ,inst-struct-name5238)
+      `,inst-struct-name5247
+      `#\c
+      `#f))
+  (define inst-struct-name5259 (make-test-struct `6 `#\b `(+ 1 2) `8))
+  (define inst-struct-name5267
+    (make-test-struct `,inst-struct-name5259 `() `8 `(#\c #\d symbols)))
+  (define inst-struct-name5299
+    (make-test-struct `4 `#\a `(these #(7 are #t) 8 . #t) `(+ 4 (+ 1 1))))
+  (define inst-struct-name5336
+    (make-test-struct
+      `()
+      `((#f are #\a) #(#t are symbols #t) (#\d #\b #\b) . #\a)
+      `#&(#t #(are (+ 4 5) 1 are) #\d)
+      `symbols))
+  (define inst-struct-name5350
+    (make-test-struct
+      `(#\d #f (+ 4 5) (+ 1 2))
+      `#t
+      `these
+      `(#\c #\b #\b . symbols)))
+  (define inst-struct-name5363 (make-test-struct `#\c `#t `#f `(+ 1 2)))
+  (define inst-struct-name5381
+    (make-test-struct
+      `these
+      `#(7 #t #\c (+ 4 (+ 1 1)))
+      `(symbols 2 (+ 1 2) #\a)
+      `#((+ 4 5) (+ 4 (+ 1 1)) these 5)))
+  (define inst-struct-name5395
+    (make-test-struct `6 `(+ 4 (+ 1 1)) `symbols `#\c))
+  (define inst-struct-name5402 (make-test-struct `#\b `#t `#\d `#\b))
+  (define inst-struct-name5413 (make-test-struct `#\a `#\d `(+ 4 (+ 1 1)) `5))
+  (define inst-struct-name5417
+    (make-test-struct
+      `()
+      `()
+      `()
+      `#&(,inst-struct-name5413 #\a (#t (+ 1 2) #\d))))
+  (define inst-struct-name5423 (make-test-struct `8 `4 `1 `#\d))
+  (define inst-struct-name5430 (make-test-struct `(+ 4 5) `2 `#\b `7))
+  (define inst-struct-name5431
+    (make-test-struct `#\a `5 `#\d `,inst-struct-name5430))
+  (define inst-struct-name5445 (make-test-struct `#\a `#\b `#\c `these))
+  (define inst-struct-name5449
+    (make-test-struct
+      `(#f (0 9 are (+ 1 2)) (#\d (+ 1 2) 2 . #f) #f)
+      `()
+      `(,inst-struct-name5445 (9 #\c (+ 1 2)) #(are symbols #\a) #\c)
+      `#(#\c #\a symbols)))
+  (define inst-struct-name5454 (make-test-struct `2 `#\a `3 `are))
+  (define inst-struct-name5459
+    (make-test-struct `(+ 4 (+ 1 1)) `#\c `(+ 1 2) `#f))
+  (define inst-struct-name5472 (make-test-struct `4 `8 `#t `#\a))
+  (define inst-struct-name5482
+    (make-test-struct
+      `these
+      `(#f #\b #t . these)
+      `((+ 4 (+ 1 1)) #\d #t . #f)
+      `#\a))
+  (define inst-struct-name5484
+    (make-test-struct
+      `#f
+      `#&((7 #\a #\d) #(#\b (+ 4 (+ 1 1)) 3) ,inst-struct-name5472)
+      `,inst-struct-name5482
+      `#\d))
+
+;; let-testsuite
+
+
+   (mytest
+    (match-let*
+      (((list
+         (list tlp3121 __3)
+         (list)
+         (list tlp3122 __3)
+         (and (? number? tlp3123) (? even? tlp3124)))
+        `((#\a symbols #\a) () (#\b #f 0) 6)))
+      (list tlp3121 tlp3122 tlp3123))
+    '((#\a symbols #\a) (#\b #f 0) 6))
+   (mytest
+    (match-let*
+      (((list
+         (and (and (? test-struct? tlp3158)
+                   (app
+                    test-struct-a
+                    (box
+                     (list
+                      (list tlp3125 tlp3126 tlp3127 tlp3128)
+                      (list tlp3129 ___)
+                      (and (? test-struct? tlp3135)
+                           (app test-struct-a tlp3130)
+                           (app test-struct-b tlp3131)
+                           (app test-struct-c tlp3132)
+                           (app test-struct-d tlp3133)))))
+                   (app
+                    test-struct-b
+                    (list-rest
+                      (list tlp3136 tlp3137 tlp3138 tlp3139)
+                      (and (? test-struct? tlp3145)
+                           (app test-struct-a tlp3140)
+                           (app test-struct-b tlp3141)
+                           (app test-struct-c tlp3142)
+                           (app test-struct-d tlp3143))
+                      (vector tlp3146 tlp3147 tlp3148 tlp3149)
+                      #\d))
+                   (app test-struct-c (list tlp3150 __3))
+                   (app
+                    test-struct-d
+                    (list
+                     #\b
+                     tlp3151
+                     (and (? number? tlp3152) (? even? tlp3153))
+                     (box (list tlp3154 tlp3155 tlp3156)))))
+              (and (? test-struct? tlp3159)
+                   (app
+                    test-struct-a
+                    (box
+                     (list
+                      (list tlp3160 tlp3161 tlp3162 tlp3163)
+                      (list tlp3164 ___)
+                      (and (? test-struct? tlp3165)
+                           (app test-struct-a tlp3166)
+                           (app test-struct-b tlp3167)
+                           (app test-struct-c tlp3168)
+                           (app test-struct-d tlp3169)))))
+                   (app
+                    test-struct-b
+                    (list-rest
+                      (list tlp3170 tlp3171 tlp3172 tlp3173)
+                      (and (? test-struct? tlp3174)
+                           (app test-struct-a tlp3175)
+                           (app test-struct-b tlp3176)
+                           (app test-struct-c tlp3177)
+                           (app test-struct-d tlp3178))
+                      (vector tlp3179 tlp3180 tlp3181 tlp3182)
+                      #\d))
+                   (app test-struct-c (list tlp3183 __3))
+                   (app
+                    test-struct-d
+                    (list
+                     #\b
+                     tlp3184
+                     (and (? number? tlp3185) (? even? tlp3186))
+                     (box (list tlp3187 tlp3188 tlp3189))))))
+         (not (not #\a))
+         (struct
+           test-struct
+           ((vector tlp3190 ...)
+            tlp3191
+            (and (? test-struct? tlp3198)
+                 (app test-struct-a (list tlp3192 __3))
+                 (app test-struct-b tlp3193)
+                 (app test-struct-c (and tlp3194 tlp3195))
+                 (app test-struct-d (list tlp3196 ...)))
+            tlp3199))
+         (list tlp3201 __3))
+        `(,inst-struct-name3157 #\a ,inst-struct-name3200 (#t #\b symbols))))
+      (list
+       tlp3125
+       tlp3126
+       tlp3127
+       tlp3128
+       tlp3129
+       tlp3130
+       tlp3131
+       tlp3132
+       tlp3133
+       tlp3136
+       tlp3137
+       tlp3138
+       tlp3139
+       tlp3140
+       tlp3141
+       tlp3142
+       tlp3143
+       tlp3146
+       tlp3147
+       tlp3148
+       tlp3149
+       tlp3150
+       tlp3151
+       tlp3152
+       tlp3154
+       tlp3155
+       tlp3156
+       tlp3190
+       tlp3191
+       tlp3192
+       tlp3193
+       tlp3194
+       tlp3196
+       tlp3199
+       tlp3201))
+    '(#f
+      (+ 1 2)
+      #\d
+      #\b
+      (#\d 1 symbols)
+      6
+      #t
+      (+ 4 (+ 1 1))
+      #\a
+      5
+      7
+      symbols
+      #t
+      #\a
+      3
+      (+ 4 5)
+      7
+      (+ 4 (+ 1 1))
+      #f
+      #\a
+      #\d
+      (#\a (+ 4 (+ 1 1)) these)
+      3
+      4
+      (+ 4 (+ 1 1))
+      #f
+      2
+      (#\b symbols (+ 1 2))
+      symbols
+      (8 #\b (+ 1 2))
+      (+ 1 2)
+      #\a
+      ((+ 1 2) #f 5)
+      5
+      (#t #\b symbols)))
+   (mytest
+    (match-let
+      (((list
+         (list (and tlp3202 tlp3203) (list tlp3204 ___) tlp3205 tlp3206)
+         tlp3207
+         tlp3208
+         tlp3209)
+        `((these ((+ 4 5) #\b 6) #\a #\c) #\b (+ 4 5) 0)))
+      (list tlp3202 tlp3204 tlp3205 tlp3206 tlp3207 tlp3208 tlp3209))
+    '(these ((+ 4 5) #\b 6) #\a #\c #\b (+ 4 5) 0))
+   (mytest
+    (match-let*
+      (((list (and (list) (list)) tlp3210 tlp3211 _)
+        `(() #t (+ 4 (+ 1 1)) #\a)))
+      (list tlp3210 tlp3211))
+    '(#t (+ 4 (+ 1 1))))
+   (mytest
+    (match-let
+      (((list
+         (and (? number? tlp3212) (? even? tlp3213))
+         (and (? number? tlp3214) (? even? tlp3215))
+         (and (list tlp3216 ___) (list tlp3217 ___))
+         tlp3218)
+        `(2 16 (#\c symbols (+ 1 2)) 7)))
+      (list tlp3212 tlp3214 tlp3216 tlp3218))
+    '(2 16 (#\c symbols (+ 1 2)) 7))
+
+
+   (mytest
+    (match-let
+      (((list
+         (vector tlp3219 ...)
+         (vector tlp3220 ...)
+         (vector tlp3221 ___)
+         (list))
+        `(#3(#\d #f) #3(#t (+ 1 2) (+ 4 5)) #3(#t are #t) ()))
+       ((list 'are tlp3222 #\a 9) `(are 3 #\a 9))
+       ((list
+         tlp3223
+         (list
+          (list-rest
+            #\b
+            (struct test-struct (tlp3224 tlp3225 tlp3226 tlp3227))
+            #f
+            'these)
+          (list)
+          (list-rest
+            (vector tlp3229 ...)
+            (or (and (? test-struct? tlp3235)
+                     (app test-struct-a tlp3230)
+                     (app test-struct-b tlp3231)
+                     (app test-struct-c tlp3232)
+                     (app test-struct-d tlp3233))
+                (and (? test-struct? tlp3235)
+                     (app test-struct-a tlp3230)
+                     (app test-struct-b tlp3231)
+                     (app test-struct-c tlp3232)
+                     (app test-struct-d tlp3233)))
+            (vector tlp3236 ___)
+            5)
+          (list))
+         (list tlp3237 ..3)
+         (and (? test-struct? tlp3240)
+              (app test-struct-a (or (list) (list)))
+              (app test-struct-b (vector tlp3238 ...))
+              (app test-struct-c (not (not #\c)))
+              (app test-struct-d #\b)))
+        `(#f
+          ((#\b ,inst-struct-name3228 #f . these)
+           ()
+           (#3((+ 1 2) #\c 2) ,inst-struct-name3234 #3(#t #\b are) . 5)
+           ())
+          (#\d are (+ 4 5))
+          ,inst-struct-name3239))
+       ((list
+         (list tlp3241 ___)
+         (list)
+         (list
+          (and (and (? test-struct? tlp3253)
+                    (app
+                     test-struct-a
+                     (list-rest tlp3242 tlp3243 tlp3244 tlp3245))
+                    (app
+                     test-struct-b
+                     (vector tlp3246 tlp3247 tlp3248 tlp3249))
+                    (app
+                     test-struct-c
+                     (and (? number? tlp3250) (? even? tlp3251)))
+                    (app test-struct-d _))
+               (and (? test-struct? tlp3254)
+                    (app
+                     test-struct-a
+                     (list-rest tlp3255 tlp3256 tlp3257 tlp3258))
+                    (app
+                     test-struct-b
+                     (vector tlp3259 tlp3260 tlp3261 tlp3262))
+                    (app
+                     test-struct-c
+                     (and (? number? tlp3263) (? even? tlp3264)))
+                    (app test-struct-d _)))
+          (vector
+            #\a
+            (or 'symbols 'symbols)
+            (vector tlp3265 tlp3266 tlp3267 tlp3268)
+            (box (list tlp3269 tlp3270 tlp3271)))
+          (and (? number? tlp3272) (? even? tlp3273))
+          (list tlp3274 ..3))
+         tlp3275)
+        `((#t #\b symbols)
+          ()
+          (,inst-struct-name3252
+           #4(#\a symbols #4(these #\a #f #\a) #&(#t (+ 4 (+ 1 1)) #\b))
+           4
+           (#t #\d #\c))
+          are))
+       ((list
+         (list-rest
+           tlp3276
+           (struct
+             test-struct
+             (tlp3277
+               (and (vector tlp3278 tlp3279 tlp3280 tlp3281)
+                    (vector tlp3282 tlp3283 tlp3284 tlp3285))
+               (and (not (not #t)) (not (not #t)))
+               tlp3286))
+           (box (list (list tlp3288 ___) (list tlp3289 __3) tlp3290))
+           #\b)
+         (list
+          (or (list) (list))
+          (and (? test-struct? tlp3298)
+               (app test-struct-a _)
+               (app test-struct-b tlp3291)
+               (app test-struct-c (vector tlp3292 ...))
+               (app test-struct-d (vector tlp3293 tlp3294 tlp3295 tlp3296)))
+          tlp3299
+          (and (? test-struct? tlp3313)
+               (app test-struct-a (box (list tlp3300 tlp3301 tlp3302)))
+               (app
+                test-struct-b
+                (struct test-struct (tlp3303 tlp3304 tlp3305 tlp3306)))
+               (app
+                test-struct-c
+                (or (list tlp3308 tlp3309 tlp3310 tlp3311)
+                    (list tlp3308 tlp3309 tlp3310 tlp3311)))
+               (app test-struct-d _)))
+         (box
+          (list
+           (and (? test-struct? tlp3323)
+                (app test-struct-a (list tlp3314 ...))
+                (app test-struct-b (list-rest tlp3315 tlp3316 tlp3317 #\a))
+                (app test-struct-c (vector tlp3318 ___))
+                (app test-struct-d (box (list tlp3319 tlp3320 tlp3321))))
+           (box
+            (list (list tlp3324 __3) (vector tlp3325 ___) (list tlp3326 ___)))
+           (list
+            (list tlp3327 ...)
+            tlp3328
+            (list tlp3329 ...)
+            (list tlp3330 __3))))
+         (list tlp3331 ___))
+        `((these ,inst-struct-name3287 #&((5 #\a 4) (#\b #\a #f) these) . #\b)
+          (() ,inst-struct-name3297 (+ 4 5) ,inst-struct-name3312)
+          #&(,inst-struct-name3322
+             #&((are 6 2) #3((+ 4 5) these #\a) ((+ 1 2) 0 #\b))
+             ((#\b these 2) 0 (1 (+ 4 (+ 1 1)) #t) (#\a #t #\a)))
+          (these #\d #\b))))
+      (list
+       tlp3219
+       tlp3220
+       tlp3221
+       tlp3222
+       tlp3223
+       tlp3224
+       tlp3225
+       tlp3226
+       tlp3227
+       tlp3229
+       tlp3230
+       tlp3231
+       tlp3232
+       tlp3233
+       tlp3236
+       tlp3237
+       tlp3238
+       tlp3241
+       tlp3242
+       tlp3243
+       tlp3244
+       tlp3245
+       tlp3246
+       tlp3247
+       tlp3248
+       tlp3249
+       tlp3250
+       tlp3265
+       tlp3266
+       tlp3267
+       tlp3268
+       tlp3269
+       tlp3270
+       tlp3271
+       tlp3272
+       tlp3274
+       tlp3275
+       tlp3276
+       tlp3277
+       tlp3278
+       tlp3279
+       tlp3280
+       tlp3281
+       tlp3286
+       tlp3288
+       tlp3289
+       tlp3290
+       tlp3291
+       tlp3292
+       tlp3293
+       tlp3294
+       tlp3295
+       tlp3296
+       tlp3299
+       tlp3300
+       tlp3301
+       tlp3302
+       tlp3303
+       tlp3304
+       tlp3305
+       tlp3306
+       tlp3308
+       tlp3309
+       tlp3310
+       tlp3311
+       tlp3314
+       tlp3315
+       tlp3316
+       tlp3317
+       tlp3318
+       tlp3319
+       tlp3320
+       tlp3321
+       tlp3324
+       tlp3325
+       tlp3326
+       tlp3327
+       tlp3328
+       tlp3329
+       tlp3330
+       tlp3331))
+    '((#\d #f #f)
+      (#t (+ 1 2) (+ 4 5))
+      (#t are #t)
+      3
+      #f
+      these
+      3
+      #\d
+      #t
+      ((+ 1 2) #\c 2)
+      (+ 4 5)
+      #\a
+      #\a
+      #f
+      (#t #\b are)
+      (#\d are (+ 4 5))
+      (#\d #\b #\b)
+      (#t #\b symbols)
+      #t
+      #\c
+      #\c
+      are
+      (+ 1 2)
+      (+ 4 5)
+      #\b
+      9
+      16
+      these
+      #\a
+      #f
+      #\a
+      #t
+      (+ 4 (+ 1 1))
+      #\b
+      4
+      (#t #\d #\c)
+      are
+      these
+      #\d
+      (+ 4 5)
+      #t
+      (+ 4 5)
+      #t
+      (+ 4 (+ 1 1))
+      (5 #\a 4)
+      (#\b #\a #f)
+      these
+      #f
+      (are symbols #\c)
+      these
+      symbols
+      #t
+      #\d
+      (+ 4 5)
+      symbols
+      #\d
+      #\c
+      #t
+      (+ 4 (+ 1 1))
+      #\d
+      #f
+      these
+      are
+      (+ 1 2)
+      (+ 4 5)
+      (#t 6 #\c)
+      #t
+      #\d
+      2
+      (#f 6 #\b)
+      #f
+      7
+      symbols
+      (are 6 2)
+      ((+ 4 5) these #\a)
+      ((+ 1 2) 0 #\b)
+      (#\b these 2)
+      0
+      (1 (+ 4 (+ 1 1)) #t)
+      (#\a #t #\a)
+      (these #\d #\b)))
+   (mytest
+    (match-let*
+      (((list
+         #\d
+         (list (not (not '(+ 4 5))) tlp3332 (not (not #f)) #t)
+         (box
+          (list
+           tlp3333
+           (not (not 7))
+           (list-rest
+             (vector tlp3334 tlp3335 tlp3336 tlp3337)
+             (box (list tlp3338 tlp3339 tlp3340))
+             tlp3341
+             9)))
+         (or (list tlp3342 ___) (list tlp3342 ___)))
+        `(#\d
+          ((+ 4 5) 9 #f #t)
+          #&(#f 7 (#4(4 symbols are) #&((+ 4 (+ 1 1)) #\d 3) these . 9))
+          (#\d these 7)))
+       ((list
+         (list-rest
+           (and (list tlp3343 ...) (list tlp3344 ...))
+           (list)
+           tlp3345
+           #\a)
+         (list-rest (not (not #t)) _ _ #f)
+         #\a
+         (vector
+           _
+           (or (list
+                _
+                tlp3346
+                (list tlp3347 tlp3348 tlp3349 tlp3350)
+                (and (? test-struct? tlp3356)
+                     (app test-struct-a tlp3351)
+                     (app test-struct-b tlp3352)
+                     (app test-struct-c tlp3353)
+                     (app test-struct-d tlp3354)))
+               (list
+                _
+                tlp3346
+                (list tlp3347 tlp3348 tlp3349 tlp3350)
+                (and (? test-struct? tlp3356)
+                     (app test-struct-a tlp3351)
+                     (app test-struct-b tlp3352)
+                     (app test-struct-c tlp3353)
+                     (app test-struct-d tlp3354))))
+           (box
+            (list
+             (vector tlp3357 tlp3358 tlp3359 tlp3360)
+             #\d
+             (and (? number? tlp3361) (? even? tlp3362))))
+           (vector
+             (struct test-struct (tlp3363 tlp3364 tlp3365 tlp3366))
+             (struct test-struct (tlp3368 tlp3369 tlp3370 tlp3371))
+             (and (? number? tlp3373) (? even? tlp3374))
+             tlp3375)))
+        `(((#\a #\b #f) () #f . #\a)
+          (#t #f #t . #f)
+          #\a
+          #4((+ 1 2)
+             (3 #f (#\d are #\c these) ,inst-struct-name3355)
+             #&(#4(#t (+ 1 2) #\a #\b) #\d 0)
+             #4(,inst-struct-name3367 ,inst-struct-name3372 4 (+ 4 5)))))
+       ((list (and tlp3376 tlp3377) #\a (list) (vector tlp3378 ...))
+        `(3 #\a () #3(1 #t 1)))
+       ((list
+         _
+         (vector
+           (list-rest
+             (list)
+             (and (vector tlp3379 tlp3380 tlp3381 tlp3382)
+                  (vector tlp3383 tlp3384 tlp3385 tlp3386))
+             (list tlp3387 ..3)
+             3)
+           (list
+            (list-rest tlp3388 tlp3389 tlp3390 #\a)
+            (or (list tlp3391 ..3) (list tlp3391 ..3))
+            _
+            (struct test-struct (tlp3392 tlp3393 tlp3394 tlp3395)))
+           (and (? number? tlp3397) (? even? tlp3398))
+           tlp3399)
+         tlp3400
+         (list))
+        `(#\d
+          #4((() #4(these 7 #t #\a) (#\d #f #t) . 3)
+             (((+ 1 2) (+ 4 5) are . #\a)
+              (#\d #t these)
+              (+ 4 5)
+              ,inst-struct-name3396)
+             6
+             (+ 1 2))
+          #\a
+          ()))
+       ((list
+         (vector tlp3401 ___)
+         '(+ 1 2)
+         (vector
+           _
+           '(+ 1 2)
+           (and (box
+                 (list
+                  (list tlp3402 tlp3403 tlp3404 tlp3405)
+                  tlp3406
+                  '(+ 1 2)))
+                (box
+                 (list
+                  (list tlp3407 tlp3408 tlp3409 tlp3410)
+                  tlp3411
+                  '(+ 1 2))))
+           (list tlp3412 ..3))
+         _)
+        `(#3(#\c #\b these)
+          (+ 1 2)
+          #4(these (+ 1 2) #&((are 4 #f #\d) symbols (+ 1 2)) (#f #\a 6))
+          these)))
+      (list
+       tlp3332
+       tlp3333
+       tlp3334
+       tlp3335
+       tlp3336
+       tlp3337
+       tlp3338
+       tlp3339
+       tlp3340
+       tlp3341
+       tlp3342
+       tlp3343
+       tlp3345
+       tlp3346
+       tlp3347
+       tlp3348
+       tlp3349
+       tlp3350
+       tlp3351
+       tlp3352
+       tlp3353
+       tlp3354
+       tlp3357
+       tlp3358
+       tlp3359
+       tlp3360
+       tlp3361
+       tlp3363
+       tlp3364
+       tlp3365
+       tlp3366
+       tlp3368
+       tlp3369
+       tlp3370
+       tlp3371
+       tlp3373
+       tlp3375
+       tlp3376
+       tlp3378
+       tlp3379
+       tlp3380
+       tlp3381
+       tlp3382
+       tlp3387
+       tlp3388
+       tlp3389
+       tlp3390
+       tlp3391
+       tlp3392
+       tlp3393
+       tlp3394
+       tlp3395
+       tlp3397
+       tlp3399
+       tlp3400
+       tlp3401
+       tlp3402
+       tlp3403
+       tlp3404
+       tlp3405
+       tlp3406
+       tlp3412))
+    '(9
+      #f
+      4
+      symbols
+      are
+      are
+      (+ 4 (+ 1 1))
+      #\d
+      3
+      these
+      (#\d these 7)
+      (#\a #\b #f)
+      #f
+      #f
+      #\d
+      are
+      #\c
+      these
+      (+ 1 2)
+      these
+      #t
+      #t
+      #t
+      (+ 1 2)
+      #\a
+      #\b
+      0
+      #\d
+      #\a
+      6
+      (+ 1 2)
+      symbols
+      #\a
+      3
+      #\c
+      4
+      (+ 4 5)
+      3
+      (1 #t 1)
+      these
+      7
+      #t
+      #\a
+      (#\d #f #t)
+      (+ 1 2)
+      (+ 4 5)
+      are
+      (#\d #t these)
+      0
+      #\d
+      #\a
+      #\b
+      6
+      (+ 1 2)
+      #\a
+      (#\c #\b these)
+      are
+      4
+      #f
+      #\d
+      symbols
+      (#f #\a 6)))
+   (mytest
+    (match-let
+      (((list
+         _
+         (list tlp3413 ...)
+         (list
+          (box
+           (list
+            (vector tlp3414 ___)
+            (struct test-struct (tlp3415 tlp3416 tlp3417 tlp3418))
+            (and (? number? tlp3420) (? even? tlp3421))))
+          (list-rest
+            (not (not #\b))
+            (list-rest tlp3422 tlp3423 tlp3424 #\a)
+            (list tlp3425 tlp3426 tlp3427 tlp3428)
+            #\c)
+          (list tlp3429 ...)
+          tlp3430)
+         tlp3431)
+        `((+ 4 5)
+          (these #f #\b)
+          (#&(#3(7 4 2) ,inst-struct-name3419 8)
+           (#\b (#\c 2 #t . #\a) (#f (+ 4 (+ 1 1)) #t #\b) . #\c)
+           (#\b 0 2)
+           #f)
+          #\b))
+       ((list tlp3432 tlp3433 (list tlp3434 ...) (list))
+        `((+ 4 5) #\c (7 #t #\c) ()))
+       ((list
+         (list tlp3435 ...)
+         (and (? test-struct? tlp3445)
+              (app test-struct-a (list tlp3436 ..3))
+              (app test-struct-b (list))
+              (app
+               test-struct-c
+               (list-rest
+                 (list tlp3437 ___)
+                 tlp3438
+                 (vector tlp3439 tlp3440 tlp3441 tlp3442)
+                 5))
+              (app test-struct-d (vector tlp3443 ___)))
+         (vector
+           (and (and (? test-struct? tlp3456)
+                     (app test-struct-a (list))
+                     (app
+                      test-struct-b
+                      (list-rest tlp3446 tlp3447 tlp3448 tlp3449))
+                     (app test-struct-c (box (list tlp3450 tlp3451 tlp3452)))
+                     (app test-struct-d (and tlp3453 tlp3454)))
+                (and (? test-struct? tlp3457)
+                     (app test-struct-a (list))
+                     (app
+                      test-struct-b
+                      (list-rest tlp3458 tlp3459 tlp3460 tlp3461))
+                     (app test-struct-c (box (list tlp3462 tlp3463 tlp3464)))
+                     (app test-struct-d (and tlp3465 tlp3466))))
+           tlp3467
+           #t
+           (box (list (not (not 2)) (box (list tlp3468 tlp3469 tlp3470)) _)))
+         (and (? test-struct? tlp3475)
+              (app
+               test-struct-a
+               (list-rest _ (or tlp3471 tlp3471) (not (not #f)) #\d))
+              (app test-struct-b tlp3472)
+              (app test-struct-c (list))
+              (app test-struct-d (list tlp3473 ...))))
+        `((these symbols 9)
+          ,inst-struct-name3444
+          #4(,inst-struct-name3455 #\c #t #&(2 #&(are #f (+ 1 2)) #\b))
+          ,inst-struct-name3474))
+       ((list
+         (struct
+           test-struct
+           ((and (? number? tlp3476) (? even? tlp3477))
+            (list
+             (or (and (? test-struct? tlp3483)
+                      (app test-struct-a tlp3478)
+                      (app test-struct-b tlp3479)
+                      (app test-struct-c tlp3480)
+                      (app test-struct-d tlp3481))
+                 (and (? test-struct? tlp3483)
+                      (app test-struct-a tlp3478)
+                      (app test-struct-b tlp3479)
+                      (app test-struct-c tlp3480)
+                      (app test-struct-d tlp3481)))
+             (vector tlp3484 tlp3485 tlp3486 tlp3487)
+             (box (list tlp3488 tlp3489 tlp3490))
+             '(+ 4 5))
+            (vector tlp3491 ___)
+            tlp3492))
+         (list tlp3494 ..3)
+         (list tlp3495 ..3)
+         tlp3496)
+        `(,inst-struct-name3493
+          (#t #\a (+ 4 (+ 1 1)))
+          (are (+ 1 2) these)
+          (+ 4 (+ 1 1))))
+       ((list
+         (list
+          (box
+           (list
+            (list tlp3497 tlp3498 tlp3499 tlp3500)
+            (and _ _)
+            (and (? test-struct? tlp3506)
+                 (app test-struct-a tlp3501)
+                 (app test-struct-b tlp3502)
+                 (app test-struct-c tlp3503)
+                 (app test-struct-d tlp3504))))
+          (list tlp3507 ...)
+          (and (? test-struct? tlp3513)
+               (app test-struct-a (box (list tlp3508 tlp3509 tlp3510)))
+               (app test-struct-b (list))
+               (app test-struct-c _)
+               (app test-struct-d (list tlp3511 ___)))
+          (or (and (struct test-struct (tlp3514 tlp3515 tlp3516 tlp3517))
+                   (struct test-struct (tlp3519 tlp3520 tlp3521 tlp3522)))
+              (and (struct test-struct (tlp3514 tlp3515 tlp3516 tlp3517))
+                   (struct test-struct (tlp3519 tlp3520 tlp3521 tlp3522)))))
+         (list
+          (not (not 9))
+          #f
+          '(+ 4 5)
+          (box
+           (list
+            (and (? test-struct? tlp3528)
+                 (app test-struct-a tlp3523)
+                 (app test-struct-b tlp3524)
+                 (app test-struct-c tlp3525)
+                 (app test-struct-d tlp3526))
+            (list tlp3529 __3)
+            (vector tlp3530 tlp3531 tlp3532 tlp3533))))
+         (not (not #\d))
+         9)
+        `((#&((#f #\c (+ 4 5) #\d) #t ,inst-struct-name3505)
+           (4 #\d #\c)
+           ,inst-struct-name3512
+           ,inst-struct-name3518)
+          (9
+           #f
+           (+ 4 5)
+           #&(,inst-struct-name3527 (#\c #\d #\c) #4(symbols #\a #f #\c)))
+          #\d
+          9)))
+      (list
+       tlp3413
+       tlp3414
+       tlp3415
+       tlp3416
+       tlp3417
+       tlp3418
+       tlp3420
+       tlp3422
+       tlp3423
+       tlp3424
+       tlp3425
+       tlp3426
+       tlp3427
+       tlp3428
+       tlp3429
+       tlp3430
+       tlp3431
+       tlp3432
+       tlp3433
+       tlp3434
+       tlp3435
+       tlp3436
+       tlp3437
+       tlp3438
+       tlp3439
+       tlp3440
+       tlp3441
+       tlp3442
+       tlp3443
+       tlp3446
+       tlp3447
+       tlp3448
+       tlp3449
+       tlp3450
+       tlp3451
+       tlp3452
+       tlp3453
+       tlp3467
+       tlp3468
+       tlp3469
+       tlp3470
+       tlp3471
+       tlp3472
+       tlp3473
+       tlp3476
+       tlp3478
+       tlp3479
+       tlp3480
+       tlp3481
+       tlp3484
+       tlp3485
+       tlp3486
+       tlp3487
+       tlp3488
+       tlp3489
+       tlp3490
+       tlp3491
+       tlp3492
+       tlp3494
+       tlp3495
+       tlp3496
+       tlp3497
+       tlp3498
+       tlp3499
+       tlp3500
+       tlp3501
+       tlp3502
+       tlp3503
+       tlp3504
+       tlp3507
+       tlp3508
+       tlp3509
+       tlp3510
+       tlp3511
+       tlp3514
+       tlp3515
+       tlp3516
+       tlp3517
+       tlp3523
+       tlp3524
+       tlp3525
+       tlp3526
+       tlp3529
+       tlp3530
+       tlp3531
+       tlp3532
+       tlp3533))
+    '((these #f #\b)
+      (7 4 2)
+      #\c
+      #\c
+      symbols
+      9
+      8
+      #\c
+      2
+      #t
+      #f
+      (+ 4 (+ 1 1))
+      #t
+      #\b
+      (#\b 0 2)
+      #f
+      #\b
+      (+ 4 5)
+      #\c
+      (7 #t #\c)
+      (these symbols 9)
+      (#\c (+ 4 (+ 1 1)) (+ 4 5))
+      (6 #\a 2)
+      0
+      these
+      #\c
+      these
+      1
+      (#f #\a #\d)
+      #\d
+      #t
+      symbols
+      #\d
+      #\d
+      (+ 4 (+ 1 1))
+      these
+      2
+      #\c
+      are
+      #f
+      (+ 1 2)
+      #\c
+      #\a
+      (#t #\a #\a)
+      16
+      symbols
+      #\b
+      #f
+      #f
+      #f
+      #\c
+      (+ 4 5)
+      #f
+      (+ 4 5)
+      #\d
+      are
+      (#t #f 4)
+      #\d
+      (#t #\a (+ 4 (+ 1 1)))
+      (are (+ 1 2) these)
+      (+ 4 (+ 1 1))
+      #f
+      #\c
+      (+ 4 5)
+      #\d
+      4
+      (+ 4 (+ 1 1))
+      #f
+      these
+      (4 #\d #\c)
+      symbols
+      #f
+      2
+      (are (+ 4 (+ 1 1)) (+ 4 (+ 1 1)))
+      8
+      #\b
+      #\c
+      symbols
+      #\a
+      #t
+      4
+      #t
+      (#\c #\d #\c)
+      symbols
+      #\a
+      #f
+      #\c))
+   (mytest
+    (match-let
+      (((list
+         tlp3534
+         tlp3535
+         (list-rest tlp3536 _ tlp3537 'symbols)
+         (or (or tlp3538 tlp3538) (or tlp3538 tlp3538)))
+        `(symbols #\b (3 (+ 1 2) 2 . symbols) (+ 4 (+ 1 1))))
+       ((list
+         (list tlp3539 __3)
+         tlp3540
+         (and (? number? tlp3541) (? even? tlp3542))
+         (and (? number? tlp3543) (? even? tlp3544)))
+        `((#\c #f (+ 1 2)) #t 2 2))
+       ((list
+         (or tlp3545 tlp3545)
+         (or #f #f)
+         (struct
+           test-struct
+           (tlp3546 (list tlp3547 ..3) (list tlp3548 ___) tlp3549))
+         (list-rest (vector tlp3551 ...) 7 #f #\b))
+        `(#\b #f ,inst-struct-name3550 (#3(#f #\b symbols) 7 #f . #\b)))
+       ((list
+         (box
+          (list
+           (box
+            (list
+             (or tlp3552 tlp3552)
+             tlp3553
+             (and (? number? tlp3554) (? even? tlp3555))))
+           tlp3556
+           (list tlp3557 ___)))
+         (list
+          (list
+           (list-rest tlp3558 tlp3559 tlp3560 #\b)
+           (or (vector tlp3561 ___) (vector tlp3561 ___))
+           (list-rest tlp3562 tlp3563 tlp3564 #\d)
+           tlp3565)
+          (and (? test-struct? tlp3579)
+               (app
+                test-struct-a
+                (struct test-struct (tlp3566 tlp3567 tlp3568 tlp3569)))
+               (app
+                test-struct-b
+                (or (and (? number? tlp3571) (? even? tlp3572))
+                    (and (? number? tlp3571) (? even? tlp3572))))
+               (app
+                test-struct-c
+                (struct test-struct (tlp3573 tlp3574 tlp3575 tlp3576)))
+               (app test-struct-d (not (not 9))))
+          (and tlp3580 tlp3581)
+          (and (? number? tlp3582) (? even? tlp3583)))
+         (vector tlp3584 ___)
+         (or tlp3585 tlp3585))
+        `(#&(#&(9 #\a 4) symbols ((+ 1 2) 0 (+ 4 5)))
+          (((#\b (+ 1 2) #f . #\b)
+            #3((+ 4 5) #\c)
+            ((+ 4 5) (+ 4 5) #f . #\d)
+            7)
+           ,inst-struct-name3578
+           symbols
+           18)
+          #3(are #\b #t)
+          #\a))
+       ((list
+         (vector tlp3586 ...)
+         #f
+         (list
+          (and (? test-struct? tlp3596)
+               (app test-struct-a (list tlp3587 ...))
+               (app test-struct-b (list-rest tlp3588 tlp3589 tlp3590 #\c))
+               (app test-struct-c (vector tlp3591 tlp3592 tlp3593 tlp3594))
+               (app test-struct-d (not (not #\b))))
+          (struct
+            test-struct
+            (#\a (and (? number? tlp3597) (? even? tlp3598)) _ tlp3599))
+          (list-rest
+            (and (? test-struct? tlp3606)
+                 (app test-struct-a tlp3601)
+                 (app test-struct-b tlp3602)
+                 (app test-struct-c tlp3603)
+                 (app test-struct-d tlp3604))
+            (list tlp3607 __3)
+            (and (vector tlp3608 ...) (vector tlp3609 ...))
+            6)
+          '(+ 1 2))
+         #\b)
+        `(#3(#\a 0 7)
+          #f
+          (,inst-struct-name3595
+           ,inst-struct-name3600
+           (,inst-struct-name3605 (#\d 6 #\c) #3(2 symbols 1) . 6)
+           (+ 1 2))
+          #\b)))
+      (list
+       tlp3534
+       tlp3535
+       tlp3536
+       tlp3537
+       tlp3538
+       tlp3539
+       tlp3540
+       tlp3541
+       tlp3543
+       tlp3545
+       tlp3546
+       tlp3547
+       tlp3548
+       tlp3549
+       tlp3551
+       tlp3552
+       tlp3553
+       tlp3554
+       tlp3556
+       tlp3557
+       tlp3558
+       tlp3559
+       tlp3560
+       tlp3561
+       tlp3562
+       tlp3563
+       tlp3564
+       tlp3565
+       tlp3566
+       tlp3567
+       tlp3568
+       tlp3569
+       tlp3571
+       tlp3573
+       tlp3574
+       tlp3575
+       tlp3576
+       tlp3580
+       tlp3582
+       tlp3584
+       tlp3585
+       tlp3586
+       tlp3587
+       tlp3588
+       tlp3589
+       tlp3590
+       tlp3591
+       tlp3592
+       tlp3593
+       tlp3594
+       tlp3597
+       tlp3599
+       tlp3601
+       tlp3602
+       tlp3603
+       tlp3604
+       tlp3607
+       tlp3608))
+    '(symbols
+       #\b
+       3
+       2
+       (+ 4 (+ 1 1))
+       (#\c #f (+ 1 2))
+       #t
+       2
+       2
+       #\b
+       (+ 4 (+ 1 1))
+       (#t 8 symbols)
+       (#\a #\c #t)
+       0
+       (#f #\b symbols)
+       9
+       #\a
+       4
+       symbols
+       ((+ 1 2) 0 (+ 4 5))
+       #\b
+       (+ 1 2)
+       #f
+       ((+ 4 5) #\c #\c)
+       (+ 4 5)
+       (+ 4 5)
+       #f
+       7
+       #\b
+       #\c
+       #\d
+       #\c
+       16
+       #\b
+       (+ 1 2)
+       #\b
+       #\b
+       symbols
+       18
+       (are #\b #t)
+       #\a
+       (#\a 0 7)
+       (0 these are)
+       #\d
+       #f
+       (+ 4 (+ 1 1))
+       #\b
+       #\a
+       these
+       symbols
+       0
+       2
+       are
+       1
+       3
+       #\d
+       (#\d 6 #\c)
+       (2 symbols 1)))
+   (mytest
+    (match-let
+      (((list _ (not (not #f)) (not (not #f)) (vector tlp3610 ___))
+        `(#t #f #f #3(#\b #\d these)))
+       ((list
+         (list tlp3611 ...)
+         (vector
+           (list tlp3612 ...)
+           (and tlp3613 tlp3614)
+           (list tlp3615 ...)
+           (and (? test-struct? tlp3626)
+                (app test-struct-a (and (list) (list)))
+                (app test-struct-b tlp3616)
+                (app test-struct-c (vector tlp3617 tlp3618 tlp3619 tlp3620))
+                (app test-struct-d (vector tlp3621 tlp3622 tlp3623 tlp3624))))
+         (and (vector
+                tlp3627
+                (vector tlp3628 ...)
+                (and (? test-struct? tlp3640)
+                     (app test-struct-a _)
+                     (app
+                      test-struct-b
+                      (struct test-struct (tlp3629 tlp3630 tlp3631 tlp3632)))
+                     (app test-struct-c (box (list tlp3634 tlp3635 tlp3636)))
+                     (app test-struct-d (and tlp3637 tlp3638)))
+                tlp3641)
+              (vector
+                tlp3642
+                (vector tlp3643 ...)
+                (and (? test-struct? tlp3644)
+                     (app test-struct-a _)
+                     (app
+                      test-struct-b
+                      (struct test-struct (tlp3645 tlp3646 tlp3647 tlp3648)))
+                     (app test-struct-c (box (list tlp3649 tlp3650 tlp3651)))
+                     (app test-struct-d (and tlp3652 tlp3653)))
+                tlp3654))
+         tlp3655)
+        `((4 are #\c)
+          #4((#\b #t symbols) these ((+ 4 5) 6 #\b) ,inst-struct-name3625)
+          #4(#f #3(#\c #\c 6) ,inst-struct-name3639 4)
+          #\a))
+       ((list
+         tlp3656
+         #\c
+         tlp3657
+         (list-rest (list tlp3658 __3) #\d (list tlp3659 ___) #\c))
+        `(#t #\c (+ 1 2) ((5 #\b 1) #\d (0 symbols #\d) . #\c)))
+       ((list tlp3660 _ (list) _) `(#\c #\a () #f))
+       ((list 'these tlp3661 (list) tlp3662) `(these #\a () #f)))
+      (list
+       tlp3610
+       tlp3611
+       tlp3612
+       tlp3613
+       tlp3615
+       tlp3616
+       tlp3617
+       tlp3618
+       tlp3619
+       tlp3620
+       tlp3621
+       tlp3622
+       tlp3623
+       tlp3624
+       tlp3627
+       tlp3628
+       tlp3629
+       tlp3630
+       tlp3631
+       tlp3632
+       tlp3634
+       tlp3635
+       tlp3636
+       tlp3637
+       tlp3641
+       tlp3655
+       tlp3656
+       tlp3657
+       tlp3658
+       tlp3659
+       tlp3660
+       tlp3661
+       tlp3662))
+    '((#\b #\d these)
+      (4 are #\c)
+      (#\b #t symbols)
+      these
+      ((+ 4 5) 6 #\b)
+      #\a
+      #\a
+      #\c
+      (+ 1 2)
+      #t
+      (+ 4 (+ 1 1))
+      #\b
+      5
+      these
+      #f
+      (#\c #\c 6)
+      (+ 4 (+ 1 1))
+      are
+      #f
+      #\c
+      are
+      symbols
+      4
+      #\c
+      4
+      #\a
+      #t
+      (+ 1 2)
+      (5 #\b 1)
+      (0 symbols #\d)
+      #\c
+      #\a
+      #f))
+
+
+   (mytest
+    (let ()
+      (match-define
+        (list
+         (vector
+           (vector tlp3663 ___)
+           (list tlp3664 ___)
+           (and (? number? tlp3665) (? even? tlp3666))
+           (box (list (vector tlp3667 ...) (list tlp3668 ..3) _)))
+         tlp3669
+         (list tlp3670 __3)
+         tlp3671)
+        `(#4(#3(symbols #t (+ 1 2))
+             ((+ 4 (+ 1 1)) symbols (+ 1 2))
+             14
+             #&(#3(1 #t #\d) (are 6 #\c) (+ 1 2)))
+          #\b
+          (symbols #f #\a)
+          #\a))
+      (list tlp3663 tlp3664 tlp3665 tlp3667 tlp3668 tlp3669 tlp3670 tlp3671))
+    '((symbols #t (+ 1 2))
+      ((+ 4 (+ 1 1)) symbols (+ 1 2))
+      14
+      (1 #t #\d)
+      (are 6 #\c)
+      #\b
+      (symbols #f #\a)
+      #\a))
+   (mytest
+    (let ()
+      (match-define
+        (list
+         (box
+          (list
+           (struct
+             test-struct
+             ((vector tlp3672 ...)
+              tlp3673
+              (and (not (not #\c)) (not (not #\c)))
+              (list-rest tlp3674 tlp3675 tlp3676 #\d)))
+           tlp3678
+           (and (list tlp3679 ...) (list tlp3680 ...))))
+         _
+         tlp3681
+         tlp3682)
+        `(#&(,inst-struct-name3677 #\c (are (+ 1 2) (+ 1 2))) 1 3 #f))
+      (list
+       tlp3672
+       tlp3673
+       tlp3674
+       tlp3675
+       tlp3676
+       tlp3678
+       tlp3679
+       tlp3681
+       tlp3682))
+    '((#\b are #\b) #\a #\b #\c #\d #\c (are (+ 1 2) (+ 1 2)) 3 #f))
+   (mytest
+    (let ()
+      (match-define
+        (list
+         tlp3683
+         (list-rest
+           (and #\d #\d)
+           (or (list tlp3684 __3) (list tlp3684 __3))
+           (list)
+           #\d)
+         (and (vector tlp3685 ___) (vector tlp3686 ___))
+         (list tlp3687 ___))
+        `((+ 1 2)
+          (#\d (symbols #\d #f) () . #\d)
+          #3((+ 4 5) these #f)
+          ((+ 1 2) these symbols)))
+      (list tlp3683 tlp3684 tlp3685 tlp3687))
+    '((+ 1 2) (symbols #\d #f) ((+ 4 5) these #f) ((+ 1 2) these symbols)))
+   (mytest
+    (let ()
+      (match-define
+        (list
+         tlp3688
+         tlp3689
+         (list
+          (box
+           (list
+            (list tlp3690 ___)
+            (and (? number? tlp3691) (? even? tlp3692))
+            (not (not #\c))))
+          (and (list tlp3693 ...) (list tlp3694 ...))
+          tlp3695
+          (not (not #f)))
+         (vector tlp3696 ...))
+        `(#\b
+          (+ 4 (+ 1 1))
+          (#&((#f #\d 9) 10 #\c) (#\d #t #f) these #f)
+          #3(#t #\c #f)))
+      (list tlp3688 tlp3689 tlp3690 tlp3691 tlp3693 tlp3695 tlp3696))
+    '(#\b (+ 4 (+ 1 1)) (#f #\d 9) 10 (#\d #t #f) these (#t #\c #f)))
+   (mytest
+    (let ()
+      (match-define
+        (list
+         (struct
+           test-struct
+           ((not (not #\b))
+            tlp3697
+            (box (list tlp3698 (list tlp3699 ..3) tlp3700))
+            (or _ _)))
+         (list-rest (list) (vector tlp3702 ...) (and 'are 'are) #\d)
+         (box
+          (list
+           tlp3703
+           (vector
+             (list tlp3704 ___)
+             (list tlp3705 ...)
+             (list tlp3706 ___)
+             (vector tlp3707 ...))
+           (list
+            (struct test-struct (tlp3708 tlp3709 tlp3710 tlp3711))
+            #t
+            (list)
+            (list tlp3713 __3))))
+         (vector tlp3714 ___))
+        `(,inst-struct-name3701
+          (() #3(0 #\a (+ 4 5)) are . #\d)
+          #&((+ 1 2)
+             #4((2 (+ 4 (+ 1 1)) #\d)
+                (#\b 0 (+ 4 (+ 1 1)))
+                ((+ 4 5) symbols #\d)
+                #3(4 #\a are))
+             (,inst-struct-name3712 #t () (#\c 5 0)))
+          #3(#f #\d #\a)))
+      (list
+       tlp3697
+       tlp3698
+       tlp3699
+       tlp3700
+       tlp3702
+       tlp3703
+       tlp3704
+       tlp3705
+       tlp3706
+       tlp3707
+       tlp3708
+       tlp3709
+       tlp3710
+       tlp3711
+       tlp3713
+       tlp3714))
+    '(9
+      #\c
+      (#f #\d (+ 1 2))
+      are
+      (0 #\a (+ 4 5))
+      (+ 1 2)
+      (2 (+ 4 (+ 1 1)) #\d)
+      (#\b 0 (+ 4 (+ 1 1)))
+      ((+ 4 5) symbols #\d)
+      (4 #\a are)
+      #\d
+      #\d
+      (+ 4 (+ 1 1))
+      are
+      (#\c 5 0)
+      (#f #\d #\a)))
+
+
+   (let ((tlp3719
+           (lambda (tlp3715)
+             (match
+              tlp3715
+              ((list
+                3
+                (and (? number? tlp3716) (? even? tlp3717))
+                (and #f #f)
+                (or (vector tlp3718 ___) (vector tlp3718 ___)))
+               (list tlp3716 tlp3718))))))
+     (list
+      (mytest (tlp3719 `(3 2 #f #3((+ 1 2) are #\a))) '(2 ((+ 1 2) are #\a)))))
+   (let ((tlp3733
+           (lambda (tlp3720)
+             (match
+              tlp3720
+              ((list
+                tlp3721
+                tlp3722
+                (or (list
+                     (and (? number? tlp3723) (? even? tlp3724))
+                     tlp3725
+                     (list)
+                     (vector
+                       tlp3726
+                       (list tlp3727 tlp3728 tlp3729 tlp3730)
+                       (list)
+                       tlp3731))
+                    (list
+                     (and (? number? tlp3723) (? even? tlp3724))
+                     tlp3725
+                     (list)
+                     (vector
+                       tlp3726
+                       (list tlp3727 tlp3728 tlp3729 tlp3730)
+                       (list)
+                       tlp3731)))
+                (or tlp3732 tlp3732))
+               (list
+                tlp3721
+                tlp3722
+                tlp3723
+                tlp3725
+                tlp3726
+                tlp3727
+                tlp3728
+                tlp3729
+                tlp3730
+                tlp3731
+                tlp3732))))))
+     (list
+      (mytest
+       (tlp3733
+         `(these
+           (+ 4 5)
+           (16
+            (+ 4 5)
+            ()
+            #4(#f ((+ 4 (+ 1 1)) (+ 1 2) (+ 1 2) (+ 4 (+ 1 1))) () are))
+           #\c))
+       '(these
+         (+ 4 5)
+         16
+         (+ 4 5)
+         #f
+         (+ 4 (+ 1 1))
+         (+ 1 2)
+         (+ 1 2)
+         (+ 4 (+ 1 1))
+         are
+         #\c))))
+   (let ((tlp3824
+           (lambda (tlp3734)
+             (match
+              tlp3734
+              ((list
+                (struct
+                  test-struct
+                  ((and (list tlp3735 __3) (list tlp3736 __3))
+                   tlp3737
+                   (and (? number? tlp3738) (? even? tlp3739))
+                   (and (? test-struct? tlp3754)
+                        (app
+                         test-struct-a
+                         (and (? test-struct? tlp3745)
+                              (app test-struct-a tlp3740)
+                              (app test-struct-b tlp3741)
+                              (app test-struct-c tlp3742)
+                              (app test-struct-d tlp3743)))
+                        (app
+                         test-struct-b
+                         (and (vector tlp3746 ___) (vector tlp3747 ___)))
+                        (app test-struct-c _)
+                        (app
+                         test-struct-d
+                         (struct
+                           test-struct
+                           (tlp3748 tlp3749 tlp3750 tlp3751))))))
+                #t
+                (and (vector
+                       (list
+                        _
+                        (and tlp3756 tlp3757)
+                        (and (? test-struct? tlp3763)
+                             (app test-struct-a tlp3758)
+                             (app test-struct-b tlp3759)
+                             (app test-struct-c tlp3760)
+                             (app test-struct-d tlp3761))
+                        (not (not 'are)))
+                       _
+                       (struct
+                         test-struct
+                         ((box (list tlp3764 tlp3765 tlp3766))
+                          (vector tlp3767 tlp3768 tlp3769 tlp3770)
+                          tlp3771
+                          (struct
+                            test-struct
+                            (tlp3772 tlp3773 tlp3774 tlp3775))))
+                       _)
+                     (vector
+                       (list
+                        _
+                        (and tlp3778 tlp3779)
+                        (and (? test-struct? tlp3780)
+                             (app test-struct-a tlp3781)
+                             (app test-struct-b tlp3782)
+                             (app test-struct-c tlp3783)
+                             (app test-struct-d tlp3784))
+                        (not (not 'are)))
+                       _
+                       (struct
+                         test-struct
+                         ((box (list tlp3785 tlp3786 tlp3787))
+                          (vector tlp3788 tlp3789 tlp3790 tlp3791)
+                          tlp3792
+                          (struct
+                            test-struct
+                            (tlp3793 tlp3794 tlp3795 tlp3796))))
+                       _))
+                (and (? test-struct? tlp3823)
+                     (app
+                      test-struct-a
+                      (and (? test-struct? tlp3806)
+                           (app
+                            test-struct-a
+                            (and (and tlp3797 tlp3798) (and tlp3799 tlp3800)))
+                           (app
+                            test-struct-b
+                            (box (list tlp3801 tlp3802 tlp3803)))
+                           (app test-struct-c (or '(+ 4 5) '(+ 4 5)))
+                           (app test-struct-d tlp3804)))
+                     (app
+                      test-struct-b
+                      (box
+                       (list
+                        (box (list tlp3807 tlp3808 tlp3809))
+                        #\c
+                        (list tlp3810 ..3))))
+                     (app test-struct-c _)
+                     (app
+                      test-struct-d
+                      (and (? test-struct? tlp3821)
+                           (app test-struct-a tlp3811)
+                           (app test-struct-b (list tlp3812 ...))
+                           (app
+                            test-struct-c
+                            (and (? test-struct? tlp3818)
+                                 (app test-struct-a tlp3813)
+                                 (app test-struct-b tlp3814)
+                                 (app test-struct-c tlp3815)
+                                 (app test-struct-d tlp3816)))
+                           (app test-struct-d (vector tlp3819 ___))))))
+               (list
+                tlp3735
+                tlp3737
+                tlp3738
+                tlp3740
+                tlp3741
+                tlp3742
+                tlp3743
+                tlp3746
+                tlp3748
+                tlp3749
+                tlp3750
+                tlp3751
+                tlp3756
+                tlp3758
+                tlp3759
+                tlp3760
+                tlp3761
+                tlp3764
+                tlp3765
+                tlp3766
+                tlp3767
+                tlp3768
+                tlp3769
+                tlp3770
+                tlp3771
+                tlp3772
+                tlp3773
+                tlp3774
+                tlp3775
+                tlp3797
+                tlp3801
+                tlp3802
+                tlp3803
+                tlp3804
+                tlp3807
+                tlp3808
+                tlp3809
+                tlp3810
+                tlp3811
+                tlp3812
+                tlp3813
+                tlp3814
+                tlp3815
+                tlp3816
+                tlp3819))))))
+     (list
+      (mytest
+       (tlp3824
+         `(,inst-struct-name3755
+           #t
+           #4((#f 8 ,inst-struct-name3762 are)
+              symbols
+              ,inst-struct-name3777
+              these)
+           ,inst-struct-name3822))
+       '((these 0 3)
+         (+ 4 5)
+         2
+         symbols
+         (+ 1 2)
+         symbols
+         #\b
+         (#\c #\d #\d)
+         #\b
+         #t
+         (+ 4 5)
+         #\b
+         8
+         these
+         (+ 1 2)
+         2
+         #\d
+         symbols
+         (+ 4 (+ 1 1))
+         (+ 1 2)
+         #\c
+         6
+         #\c
+         #t
+         #\b
+         #\b
+         #\b
+         symbols
+         these
+         #\d
+         (+ 1 2)
+         #\d
+         1
+         #\b
+         #f
+         (+ 4 (+ 1 1))
+         #\d
+         (#t #\c #f)
+         #\d
+         (2 (+ 4 (+ 1 1)) symbols)
+         1
+         (+ 1 2)
+         #\d
+         (+ 1 2)
+         ((+ 1 2) 8 (+ 4 5))))))
+   (let ((tlp3883
+           (lambda (tlp3825)
+             (match
+              tlp3825
+              ((list
+                (box
+                 (list
+                  tlp3826
+                  tlp3827
+                  (list-rest
+                    (list-rest tlp3828 tlp3829 tlp3830 #t)
+                    (list tlp3831 __3)
+                    (list-rest tlp3832 tlp3833 tlp3834 'these)
+                    #\b)))
+                (list)
+                (and (? test-struct? tlp3857)
+                     (app test-struct-a (box (list tlp3835 #\a tlp3836)))
+                     (app
+                      test-struct-b
+                      (and (list
+                            (list tlp3837 __3)
+                            #t
+                            (and (? number? tlp3838) (? even? tlp3839))
+                            (vector tlp3840 ...))
+                           (list
+                            (list tlp3841 __3)
+                            #t
+                            (and (? number? tlp3842) (? even? tlp3843))
+                            (vector tlp3844 ...))))
+                     (app
+                      test-struct-c
+                      (list (vector tlp3845 ...) #t tlp3846 (or #f #f)))
+                     (app
+                      test-struct-d
+                      (or (and (? test-struct? tlp3855)
+                               (app test-struct-a #\b)
+                               (app test-struct-b _)
+                               (app
+                                test-struct-c
+                                (struct
+                                  test-struct
+                                  (tlp3847 tlp3848 tlp3849 tlp3850)))
+                               (app
+                                test-struct-d
+                                (and (? number? tlp3852) (? even? tlp3853))))
+                          (and (? test-struct? tlp3855)
+                               (app test-struct-a #\b)
+                               (app test-struct-b _)
+                               (app
+                                test-struct-c
+                                (struct
+                                  test-struct
+                                  (tlp3847 tlp3848 tlp3849 tlp3850)))
+                               (app
+                                test-struct-d
+                                (and (? number? tlp3852)
+                                     (? even? tlp3853)))))))
+                (list
+                 (list-rest
+                   (list-rest tlp3858 tlp3859 tlp3860 'these)
+                   (box (list tlp3861 tlp3862 tlp3863))
+                   (not (not '(+ 4 (+ 1 1))))
+                   #\a)
+                 (and (list-rest
+                        (vector tlp3864 tlp3865 tlp3866 tlp3867)
+                        (vector tlp3868 ...)
+                        '(+ 4 5)
+                        #\d)
+                      (list-rest
+                        (vector tlp3869 tlp3870 tlp3871 tlp3872)
+                        (vector tlp3873 ...)
+                        '(+ 4 5)
+                        #\d))
+                 (not (not #\b))
+                 (vector
+                   tlp3874
+                   (not (not '(+ 1 2)))
+                   (list tlp3875 tlp3876 tlp3877 tlp3878)
+                   (list tlp3879 tlp3880 tlp3881 tlp3882))))
+               (list
+                tlp3826
+                tlp3827
+                tlp3828
+                tlp3829
+                tlp3830
+                tlp3831
+                tlp3832
+                tlp3833
+                tlp3834
+                tlp3835
+                tlp3836
+                tlp3837
+                tlp3838
+                tlp3840
+                tlp3845
+                tlp3846
+                tlp3847
+                tlp3848
+                tlp3849
+                tlp3850
+                tlp3852
+                tlp3858
+                tlp3859
+                tlp3860
+                tlp3861
+                tlp3862
+                tlp3863
+                tlp3864
+                tlp3865
+                tlp3866
+                tlp3867
+                tlp3868
+                tlp3874
+                tlp3875
+                tlp3876
+                tlp3877
+                tlp3878
+                tlp3879
+                tlp3880
+                tlp3881
+                tlp3882))))))
+     (list
+      (mytest
+       (tlp3883
+         `(#&(2
+              #\d
+              ((#t (+ 4 5) are . #t) (#t 8 #\a) (#\c 2 these . these) . #\b))
+           ()
+           ,inst-struct-name3856
+           (((#\a #\b (+ 1 2) . these) #&(8 are #\b) (+ 4 (+ 1 1)) . #\a)
+            (#4((+ 1 2) these #\b #\c) #3(these are #\d) (+ 4 5) . #\d)
+            #\b
+            #4(#\b (+ 1 2) ((+ 4 (+ 1 1)) #\d #\d #\c) (2 are #\a #t)))))
+       '(2
+         #\d
+         #t
+         (+ 4 5)
+         are
+         (#t 8 #\a)
+         #\c
+         2
+         these
+         #t
+         symbols
+         ((+ 4 (+ 1 1)) (+ 4 5) #\b)
+         12
+         (these #\c #f)
+         (#\d these #\d)
+         7
+         #f
+         (+ 1 2)
+         #\a
+         #f
+         18
+         #\a
+         #\b
+         (+ 1 2)
+         8
+         are
+         #\b
+         (+ 1 2)
+         these
+         #\b
+         #\c
+         (these are #\d)
+         #\b
+         (+ 4 (+ 1 1))
+         #\d
+         #\d
+         #\c
+         2
+         are
+         #\a
+         #t))))
+   (let ((tlp3917
+           (lambda (tlp3884)
+             (match
+              tlp3884
+              ((list
+                (and (? test-struct? tlp3903)
+                     (app
+                      test-struct-a
+                      (and (? test-struct? tlp3891)
+                           (app test-struct-a tlp3885)
+                           (app
+                            test-struct-b
+                            (list tlp3886 tlp3887 tlp3888 tlp3889))
+                           (app test-struct-c (not (not #\d)))
+                           (app test-struct-d _)))
+                     (app test-struct-b '(+ 4 5))
+                     (app test-struct-c (list))
+                     (app
+                      test-struct-d
+                      (vector
+                        (list tlp3892 tlp3893 tlp3894 tlp3895)
+                        (and (? test-struct? tlp3901)
+                             (app test-struct-a tlp3896)
+                             (app test-struct-b tlp3897)
+                             (app test-struct-c tlp3898)
+                             (app test-struct-d tlp3899))
+                        _
+                        (or (list) (list)))))
+                (list tlp3904 ..3)
+                (list tlp3905 ...)
+                (vector
+                  (list tlp3906 ...)
+                  (list-rest
+                    (list tlp3907 ..3)
+                    (list-rest tlp3908 tlp3909 tlp3910 #\d)
+                    5
+                    'are)
+                  (list-rest
+                    tlp3911
+                    (and (? number? tlp3912) (? even? tlp3913))
+                    (list tlp3914 ...)
+                    #\d)
+                  (list tlp3915 #\b (vector tlp3916 ...) (list))))
+               (list
+                tlp3885
+                tlp3886
+                tlp3887
+                tlp3888
+                tlp3889
+                tlp3892
+                tlp3893
+                tlp3894
+                tlp3895
+                tlp3896
+                tlp3897
+                tlp3898
+                tlp3899
+                tlp3904
+                tlp3905
+                tlp3906
+                tlp3907
+                tlp3908
+                tlp3909
+                tlp3910
+                tlp3911
+                tlp3912
+                tlp3914
+                tlp3915
+                tlp3916))))))
+     (list
+      (mytest
+       (tlp3917
+         `(,inst-struct-name3902
+           (these (+ 4 (+ 1 1)) symbols)
+           (#\b #\c 7)
+           #4((these #\a #\d)
+              ((#t #\d 9) ((+ 4 5) (+ 4 5) 6 . #\d) 5 . are)
+              (#\b 4 (#\a symbols #\c) . #\d)
+              ((+ 4 (+ 1 1)) #\b #3(#t #\d 8) ()))))
+       '(#f
+         #t
+         #f
+         are
+         symbols
+         #\a
+         7
+         #\b
+         (+ 1 2)
+         (+ 4 (+ 1 1))
+         0
+         #\d
+         0
+         (these (+ 4 (+ 1 1)) symbols)
+         (#\b #\c 7)
+         (these #\a #\d)
+         (#t #\d 9)
+         (+ 4 5)
+         (+ 4 5)
+         6
+         #\b
+         4
+         (#\a symbols #\c)
+         (+ 4 (+ 1 1))
+         (#t #\d 8)))))
+
+;; sing match-lambda tests
+   (let ((tlp4450
+           (match-lambda
+             ((list
+               (not (not 'are))
+               (list-rest
+                 tlp4432
+                 (list-rest tlp4433 (list tlp4434 ...) tlp4435 'symbols)
+                 (not (not 2))
+                 'symbols)
+               (not (not #\a))
+               (list
+                (and (? test-struct? tlp4445)
+                     (app test-struct-a (list-rest tlp4436 tlp4437 tlp4438 9))
+                     (app
+                      test-struct-b
+                      (and (and tlp4439 tlp4440) (and tlp4441 tlp4442)))
+                     (app test-struct-c '(+ 1 2))
+                     (app test-struct-d (list tlp4443 ___)))
+                tlp4446
+                (list-rest 'these tlp4447 (list tlp4448 ..3) 'these)
+                (list tlp4449 ___)))
+              (list
+               tlp4432
+               tlp4433
+               tlp4434
+               tlp4435
+               tlp4436
+               tlp4437
+               tlp4438
+               tlp4439
+               tlp4443
+               tlp4446
+               tlp4447
+               tlp4448
+               tlp4449)))))
+     (list
+      (mytest
+       (tlp4450
+         `(are
+           (symbols ((+ 1 2) (#f (+ 4 5) (+ 4 5)) #t . symbols) 2 . symbols)
+           #\a
+           (,inst-struct-name4444
+            7
+            (these (+ 4 5) (9 (+ 4 5) #\d) . these)
+            (#t #f #\b))))
+       '(symbols
+          (+ 1 2)
+          (#f (+ 4 5) (+ 4 5))
+          #t
+          #\b
+          (+ 1 2)
+          are
+          (+ 1 2)
+          (#\c (+ 1 2) #\d)
+          7
+          (+ 4 5)
+          (9 (+ 4 5) #\d)
+          (#t #f #\b)))))
+   (let ((tlp4473
+           (match-lambda
+             ((list
+               tlp4451
+               tlp4452
+               (and (? test-struct? tlp4471)
+                    (app
+                     test-struct-a
+                     (and (? test-struct? tlp4461)
+                          (app
+                           test-struct-a
+                           (box (list tlp4453 tlp4454 tlp4455)))
+                          (app test-struct-b (list tlp4456 ...))
+                          (app
+                           test-struct-c
+                           (list-rest tlp4457 tlp4458 tlp4459 'symbols))
+                          (app test-struct-d '(+ 4 5))))
+                    (app
+                     test-struct-b
+                     (and (? number? tlp4462) (? even? tlp4463)))
+                    (app test-struct-c tlp4464)
+                    (app
+                     test-struct-d
+                     (or (list-rest
+                           (list)
+                           tlp4465
+                           (list tlp4466 tlp4467 tlp4468 tlp4469)
+                           #\b)
+                         (list-rest
+                           (list)
+                           tlp4465
+                           (list tlp4466 tlp4467 tlp4468 tlp4469)
+                           #\b))))
+               tlp4472)
+              (list
+               tlp4451
+               tlp4452
+               tlp4453
+               tlp4454
+               tlp4455
+               tlp4456
+               tlp4457
+               tlp4458
+               tlp4459
+               tlp4462
+               tlp4464
+               tlp4465
+               tlp4466
+               tlp4467
+               tlp4468
+               tlp4469
+               tlp4465
+               tlp4466
+               tlp4467
+               tlp4468
+               tlp4469
+               tlp4472)))))
+     (list
+      (mytest
+       (tlp4473 `(#f #\a ,inst-struct-name4470 5))
+       '(#f
+         #\a
+         #t
+         (+ 4 5)
+         #\c
+         (1 #\c 1)
+         #f
+         (+ 4 5)
+         #\a
+         10
+         #t
+         #\d
+         #f
+         #\d
+         #\c
+         are
+         #\d
+         #f
+         #\d
+         #\c
+         are
+         5))))
+   (let ((tlp4520
+           (match-lambda
+             ((list
+               (list-rest
+                 (and (list
+                       (vector tlp4474 tlp4475 tlp4476 tlp4477)
+                       (vector tlp4478 tlp4479 tlp4480 tlp4481)
+                       (list)
+                       (or tlp4482 tlp4482))
+                      (list
+                       (vector tlp4483 tlp4484 tlp4485 tlp4486)
+                       (vector tlp4487 tlp4488 tlp4489 tlp4490)
+                       (list)
+                       (or tlp4491 tlp4491)))
+                 (and (? number? tlp4492) (? even? tlp4493))
+                 (list '(+ 1 2) (list tlp4494 ...) tlp4495 tlp4496)
+                 #f)
+               (and (? test-struct? tlp4517)
+                    (app
+                     test-struct-a
+                     (or (box
+                          (list
+                           (and (? test-struct? tlp4502)
+                                (app test-struct-a tlp4497)
+                                (app test-struct-b tlp4498)
+                                (app test-struct-c tlp4499)
+                                (app test-struct-d tlp4500))
+                           (list)
+                           (vector tlp4503 tlp4504 tlp4505 tlp4506)))
+                         (box
+                          (list
+                           (and (? test-struct? tlp4502)
+                                (app test-struct-a tlp4497)
+                                (app test-struct-b tlp4498)
+                                (app test-struct-c tlp4499)
+                                (app test-struct-d tlp4500))
+                           (list)
+                           (vector tlp4503 tlp4504 tlp4505 tlp4506)))))
+                    (app
+                     test-struct-b
+                     (and (list-rest
+                            (list tlp4507 ___)
+                            (and (? number? tlp4508) (? even? tlp4509))
+                            (list tlp4510 __3)
+                            'these)
+                          (list-rest
+                            (list tlp4511 ___)
+                            (and (? number? tlp4512) (? even? tlp4513))
+                            (list tlp4514 __3)
+                            'these)))
+                    (app
+                     test-struct-c
+                     (or (list tlp4515 ..3) (list tlp4515 ..3)))
+                    (app test-struct-d (list)))
+               tlp4518
+               tlp4519)
+              (list
+               tlp4474
+               tlp4475
+               tlp4476
+               tlp4477
+               tlp4478
+               tlp4479
+               tlp4480
+               tlp4481
+               tlp4482
+               tlp4492
+               tlp4494
+               tlp4495
+               tlp4496
+               tlp4497
+               tlp4498
+               tlp4499
+               tlp4500
+               tlp4503
+               tlp4504
+               tlp4505
+               tlp4506
+               tlp4507
+               tlp4508
+               tlp4510
+               tlp4515
+               tlp4518
+               tlp4519)))))
+     (list
+      (mytest
+       (tlp4520
+         `(((#4(#\c #\c 0 (+ 4 (+ 1 1))) #4(#f 9 8 #\a) () #t)
+            10
+            ((+ 1 2) ((+ 4 5) symbols (+ 4 (+ 1 1))) #f 3)
+            .
+            #f)
+           ,inst-struct-name4516
+           (+ 1 2)
+           5))
+       '(#\c
+         #\c
+         0
+         (+ 4 (+ 1 1))
+         #f
+         9
+         8
+         #\a
+         #t
+         10
+         ((+ 4 5) symbols (+ 4 (+ 1 1)))
+         #f
+         3
+         #\b
+         8
+         are
+         #\a
+         #\b
+         #\b
+         #t
+         #t
+         (#\b #\c #t)
+         0
+         ((+ 4 5) #t these)
+         (#\a #\b 0)
+         (+ 1 2)
+         5))))
+   (let ((tlp4526
+           (match-lambda
+             ((list
+               (and (? number? tlp4521) (? even? tlp4522))
+               (or tlp4523 tlp4523)
+               tlp4524
+               (list tlp4525 ...))
+              (list tlp4521 tlp4523 tlp4524 tlp4525)))))
+     (list
+      (mytest
+       (tlp4526 `(4 #\a (+ 4 (+ 1 1)) (are symbols #\c)))
+       '(4 #\a (+ 4 (+ 1 1)) (are symbols #\c)))))
+   (let ((tlp4561
+           (match-lambda
+             ((list
+               (list tlp4527 __3)
+               (list
+                (and (? test-struct? tlp4540)
+                     (app
+                      test-struct-a
+                      (and (struct
+                             test-struct
+                             (tlp4528 tlp4529 tlp4530 tlp4531))
+                           (struct
+                             test-struct
+                             (tlp4533 tlp4534 tlp4535 tlp4536))))
+                     (app test-struct-b (list tlp4537 ..3))
+                     (app test-struct-c #\d)
+                     (app test-struct-d (vector tlp4538 ...)))
+                (and (? test-struct? tlp4556)
+                     (app test-struct-a (not (not #\b)))
+                     (app
+                      test-struct-b
+                      (and (vector tlp4541 tlp4542 tlp4543 tlp4544)
+                           (vector tlp4545 tlp4546 tlp4547 tlp4548)))
+                     (app test-struct-c (vector tlp4549 ...))
+                     (app
+                      test-struct-d
+                      (struct test-struct (tlp4550 tlp4551 tlp4552 tlp4553))))
+                (box
+                 (list
+                  (and (list tlp4557 __3) (list tlp4558 __3))
+                  tlp4559
+                  (not (not 4))))
+                tlp4560)
+               (list)
+               (or 'these 'these))
+              (list
+               tlp4527
+               tlp4528
+               tlp4529
+               tlp4530
+               tlp4531
+               tlp4537
+               tlp4538
+               tlp4541
+               tlp4542
+               tlp4543
+               tlp4544
+               tlp4549
+               tlp4550
+               tlp4551
+               tlp4552
+               tlp4553
+               tlp4557
+               tlp4559
+               tlp4560)))))
+     (list
+      (mytest
+       (tlp4561
+         `((4 2 #f)
+           (,inst-struct-name4539
+            ,inst-struct-name4555
+            #&((symbols are these) 6 4)
+            2)
+           ()
+           these))
+       '((4 2 #f)
+         (+ 4 (+ 1 1))
+         #\c
+         #f
+         #\c
+         (#f 9 symbols)
+         (are #f are)
+         #\c
+         #\b
+         #f
+         (+ 4 5)
+         (#f 5 #\a)
+         #f
+         #\b
+         (+ 4 5)
+         these
+         (symbols are these)
+         6
+         2))))
+
+;; sing match-lambda* tests
+   (let ((tlp4986
+           (match-lambda*
+             ((list tlp4984 'these (not (not #\b)) tlp4985)
+              (list tlp4984 tlp4985)))))
+     (list (mytest (tlp4986 `3 `these `#\b `symbols) '(3 symbols))))
+   (let ((tlp5001
+           (match-lambda*
+             ((list
+               _
+               (vector tlp4988 ...)
+               tlp4989
+               (box
+                (list
+                 (not (not '(+ 4 (+ 1 1))))
+                 (struct
+                   test-struct
+                   ((list-rest tlp4990 tlp4991 tlp4992 4)
+                    (struct test-struct (tlp4993 tlp4994 tlp4995 tlp4996))
+                    tlp4998
+                    #t))
+                 tlp5000)))
+              (list
+               tlp4988
+               tlp4989
+               tlp4990
+               tlp4991
+               tlp4992
+               tlp4993
+               tlp4994
+               tlp4995
+               tlp4996
+               tlp4998
+               tlp5000)))))
+     (list
+      (mytest
+       (tlp5001
+         `(+ 1 2)
+         `#3(#t #\b #\d)
+         `#\d
+         `#&((+ 4 (+ 1 1)) ,inst-struct-name4999 1))
+       '((#t #\b #\d)
+         #\d
+         (+ 1 2)
+         #t
+         (+ 4 (+ 1 1))
+         (+ 1 2)
+         #\d
+         these
+         #\d
+         9
+         1))))
+   (let ((tlp5004
+           (match-lambda*
+             ((list #\b (and (list) (list)) '(+ 4 (+ 1 1)) tlp5003)
+              (list tlp5003)))))
+     (list (mytest (tlp5004 `#\b `() `(+ 4 (+ 1 1)) `(+ 4 5)) '((+ 4 5)))))
+   (let ((tlp5014
+           (match-lambda*
+             ((list
+               (vector tlp5006 ...)
+               _
+               (vector
+                 (list tlp5007 ..3)
+                 (box (list (list tlp5008 ___) _ (not (not #t))))
+                 tlp5009
+                 (list tlp5010 (vector tlp5011 ...) (list) (list)))
+               (and (? number? tlp5012) (? even? tlp5013)))
+              (list
+               tlp5006
+               tlp5007
+               tlp5008
+               tlp5009
+               tlp5010
+               tlp5011
+               tlp5012)))))
+     (list
+      (mytest
+       (tlp5014
+         `#3(#\b (+ 4 (+ 1 1)) #f)
+         `(+ 4 5)
+         `#4((#\c #\d #\c)
+             #&((#\c #\c #\a) are #t)
+             #\c
+             (#\c #3(these 3 #\c) () ()))
+         `6)
+       '((#\b (+ 4 (+ 1 1)) #f)
+         (#\c #\d #\c)
+         (#\c #\c #\a)
+         #\c
+         #\c
+         (these 3 #\c)
+         6))))
+   (let ((tlp5045
+           (match-lambda*
+             ((list
+               (and (list
+                     (list
+                      (and (? number? tlp5016) (? even? tlp5017))
+                      (list)
+                      #\a
+                      (list))
+                     (and (? number? tlp5018) (? even? tlp5019))
+                     (list)
+                     tlp5020)
+                    (list
+                     (list
+                      (and (? number? tlp5021) (? even? tlp5022))
+                      (list)
+                      #\a
+                      (list))
+                     (and (? number? tlp5023) (? even? tlp5024))
+                     (list)
+                     tlp5025))
+               (or (not (not 'are)) (not (not 'are)))
+               tlp5026
+               (list
+                (struct
+                  test-struct
+                  (_
+                   (or (struct test-struct (tlp5027 tlp5028 tlp5029 tlp5030))
+                       (struct test-struct (tlp5027 tlp5028 tlp5029 tlp5030)))
+                   (or (list tlp5032 __3) (list tlp5032 __3))
+                   (list tlp5033 tlp5034 tlp5035 tlp5036)))
+                (and (? test-struct? tlp5041)
+                     (app test-struct-a '(+ 1 2))
+                     (app test-struct-b tlp5038)
+                     (app test-struct-c (list tlp5039 ___))
+                     (app test-struct-d 'are))
+                tlp5042
+                (or (and (? number? tlp5043) (? even? tlp5044))
+                    (and (? number? tlp5043) (? even? tlp5044)))))
+              (list
+               tlp5016
+               tlp5018
+               tlp5020
+               tlp5026
+               tlp5027
+               tlp5028
+               tlp5029
+               tlp5030
+               tlp5032
+               tlp5033
+               tlp5034
+               tlp5035
+               tlp5036
+               tlp5038
+               tlp5039
+               tlp5042
+               tlp5043)))))
+     (list
+      (mytest
+       (tlp5045
+         `((10 () #\a ()) 0 () #f)
+         `are
+         `2
+         `(,inst-struct-name5037 ,inst-struct-name5040 are 16))
+       '(10
+         0
+         #f
+         2
+         #f
+         #\b
+         #\c
+         are
+         (7 2 (+ 1 2))
+         (+ 1 2)
+         (+ 4 (+ 1 1))
+         are
+         these
+         symbols
+         (7 0 #t)
+         are
+         16))))
+
+;; testsuite583
+
+
+  (define inst-struct-name782 (make-test-struct `#\d `9 `6 `#\c))
+  (define inst-struct-name788 (make-test-struct `(+ 4 5) `#\d `0 `are))
+  (define inst-struct-name793 (make-test-struct `(+ 4 (+ 1 1)) `#\b `#\c `3))
+  (define inst-struct-name810 (make-test-struct `#f `8 `#\d `(+ 4 (+ 1 1))))
+  (define inst-struct-name816 (make-test-struct `6 `4 `#f `#\b))
+  (define inst-struct-name818
+    (make-test-struct `symbols `() `,inst-struct-name816 `()))
+  (define inst-struct-name830 (make-test-struct `#\d `#\b `#t `6))
+  (define inst-struct-name836
+    (make-test-struct `are `,inst-struct-name830 `(9 are 6 2) `#\d))
+  (define inst-struct-name841 (make-test-struct `#f `are `symbols `7))
+  (define inst-struct-name862 (make-test-struct `#t `#t `9 `(+ 4 (+ 1 1))))
+  (define inst-struct-name876 (make-test-struct `3 `6 `#f `#\d))
+  (define inst-struct-name882
+    (make-test-struct
+      `(#\c (+ 4 (+ 1 1)) (+ 4 (+ 1 1)))
+      `(6 #f 4 . #\c)
+      `,inst-struct-name876
+      `(#\c #\a 9 #\a)))
+  (define inst-struct-name888 (make-test-struct `symbols `symbols `#\c `#f))
+  (define inst-struct-name891
+    (make-test-struct `(+ 1 2) `,inst-struct-name888 `#\d `#f))
+  (define inst-struct-name903
+    (make-test-struct `#\c `(#f #f symbols) `14 `#3(are #\b #f)))
+  (define inst-struct-name925
+    (make-test-struct `are `(+ 4 (+ 1 1)) `0 `(#t (+ 4 (+ 1 1)) #t)))
+  (define inst-struct-name928
+    (make-test-struct
+      `(((+ 1 2) (+ 4 (+ 1 1)) are) these these (#t #\b #\d))
+      `,inst-struct-name925
+      `#f
+      `#\c))
+  (define inst-struct-name941 (make-test-struct `these `(+ 1 2) `6 `#\d))
+  (define inst-struct-name952 (make-test-struct `#f `#t `8 `(+ 4 (+ 1 1))))
+  (define inst-struct-name958 (make-test-struct `#f `#\a `#\b `#\a))
+  (define inst-struct-name981
+    (make-test-struct `symbols `#\a `(+ 1 2) `(+ 1 2)))
+  (define inst-struct-name991 (make-test-struct `#\b `#\c `(+ 4 5) `#\d))
+  (define inst-struct-name1004
+    (make-test-struct `#t `#\b `#\a `((+ 4 (+ 1 1)) #t #\d)))
+  (define inst-struct-name1022
+    (make-test-struct `(#\b #f #t + 4 (+ 1 1)) `() `(#t #\b #\b) `12))
+  (define inst-struct-name1030
+    (make-test-struct `2 `these `#4(#\d symbols #\a #\c) `3))
+  (define inst-struct-name1032
+    (make-test-struct `#\b `6 `,inst-struct-name1022 `,inst-struct-name1030))
+  (define inst-struct-name1043 (make-test-struct `#\d `6 `8 `(+ 1 2)))
+  (define inst-struct-name1048
+    (make-test-struct `#\b `(+ 1 2) `#\b `(+ 4 (+ 1 1))))
+  (define inst-struct-name1050
+    (make-test-struct
+      `(+ 4 5)
+      `#f
+      `,inst-struct-name1043
+      `,inst-struct-name1048))
+  (define inst-struct-name1069 (make-test-struct `#\b `(+ 1 2) `8 `symbols))
+  (define inst-struct-name1071
+    (make-test-struct `are `symbols `#t `,inst-struct-name1069))
+  (define inst-struct-name1080
+    (make-test-struct `#&(#\d 6 (+ 4 (+ 1 1))) `#t `0 `(#\d #\d (+ 4 5))))
+  (define inst-struct-name1087 (make-test-struct `symbols `#t `#\d `(+ 1 2)))
+  (define inst-struct-name1091
+    (make-test-struct
+      `,inst-struct-name1071
+      `,inst-struct-name1080
+      `#4(6 ,inst-struct-name1087 #\c #f)
+      `0))
+  (define inst-struct-name1099
+    (make-test-struct `8 `() `#3(#\d (+ 1 2) 9) `()))
+  (define inst-struct-name1106
+    (make-test-struct
+      `(#\c 5 #\a . 8)
+      `(+ 4 (+ 1 1))
+      `(+ 4 (+ 1 1))
+      `(+ 4 (+ 1 1))))
+  (define inst-struct-name1118
+    (make-test-struct
+      `((+ 4 (+ 1 1)) these #\d #\a)
+      `,inst-struct-name1106
+      `#\a
+      `#&((are #\c #t (+ 4 5)) (#\b 0 #\c) (1 are (+ 1 2) (+ 4 (+ 1 1))))))
+  (define inst-struct-name1125 (make-test-struct `#\b `(+ 4 5) `#\c `these))
+  (define inst-struct-name1139
+    (make-test-struct
+      `#t
+      `(#t #\c these . 9)
+      `#\a
+      `#4(9 (+ 4 (+ 1 1)) #t (+ 1 2))))
+  (define inst-struct-name1141
+    (make-test-struct
+      `(() these ,inst-struct-name1125 #4(6 1 5 #\c))
+      `,inst-struct-name1139
+      `()
+      `5))
+  (define inst-struct-name1156
+    (make-test-struct
+      `((#t 5 9 5) #3(symbols symbols these) 14 (are these are))
+      `2
+      `(((+ 4 (+ 1 1)) these #f) #3((+ 4 (+ 1 1)) #t #\b) symbols . 0)
+      `are))
+  (define inst-struct-name1161 (make-test-struct `#\d `#\c `these `1))
+  (define inst-struct-name1174 (make-test-struct `#f `(+ 4 5) `#\d `#f))
+  (define inst-struct-name1187
+    (make-test-struct `,inst-struct-name1174 `#\c `#\c `#&(symbols 2 #\a)))
+  (define inst-struct-name1198
+    (make-test-struct
+      `(#\d #\b #t)
+      `#4(#f (+ 4 5) symbols (+ 1 2))
+      `#f
+      `#&(#\d 8 3)))
+  (define inst-struct-name1221
+    (make-test-struct `#\c `4 `() `(#\d #\c #\c . #\d)))
+  (define inst-struct-name1229
+    (make-test-struct `#\c `(+ 4 (+ 1 1)) `these `#f))
+  (define inst-struct-name1230
+    (make-test-struct `() `#3(#\b 0 (+ 4 5)) `#\b `,inst-struct-name1229))
+  (define inst-struct-name1232
+    (make-test-struct
+      `#3((+ 1 2) #\a 2)
+      `,inst-struct-name1221
+      `#&(() (+ 1 2) ())
+      `,inst-struct-name1230))
+  (define inst-struct-name1238
+    (make-test-struct `(#f #\c #\c) `#\b `() `(#\d these these)))
+  (define inst-struct-name1254
+    (make-test-struct `#\b `(+ 4 (+ 1 1)) `#f `(+ 4 5)))
+  (define inst-struct-name1260
+    (make-test-struct
+      `#&(are #\c #t)
+      `(9 these #\d)
+      `,inst-struct-name1254
+      `(are #\b (+ 1 2) 3)))
+  (define inst-struct-name1266 (make-test-struct `#t `#\b `#t `#\b))
+  (define inst-struct-name1279 (make-test-struct `#\d `#\c `#\a `#t))
+  (define inst-struct-name1312
+    (make-test-struct `these `#f `#4(#\b #\c 2 #f) `1))
+  (define inst-struct-name1316
+    (make-test-struct `,inst-struct-name1312 `#t `#\d `(+ 1 2)))
+  (define inst-struct-name1325 (make-test-struct `these `#\a `#t `these))
+  (define inst-struct-name1340
+    (make-test-struct `(+ 4 5) `#\c `symbols `(+ 1 2)))
+  (define inst-struct-name1342
+    (make-test-struct
+      `#t
+      `#4(,inst-struct-name1325
+          (4 (+ 4 5) #\a)
+          (#\d symbols #\b)
+          #4(#\c #\c #\b #t))
+      `((#\c symbols (+ 4 (+ 1 1)) . #\a) #f 3 ,inst-struct-name1340)
+      `#3(8 9 1)))
+  (define inst-struct-name1351
+    (make-test-struct
+      `(these #\a #t)
+      `4
+      `(#\c (0 #t #\b) #\c #t)
+      `(#\a these (+ 1 2))))
+  (define inst-struct-name1364
+    (make-test-struct `#f `symbols `(+ 1 2) `symbols))
+  (define inst-struct-name1367
+    (make-test-struct
+      `(#\b symbols #\b . 5)
+      `(#\b 7 #\a)
+      `,inst-struct-name1364
+      `these))
+  (define inst-struct-name1383 (make-test-struct `#t `#\d `#\a `#f))
+  (define inst-struct-name1403 (make-test-struct `(+ 1 2) `#\c `#\b `#\d))
+  (define inst-struct-name1409
+    (make-test-struct
+      `(#\a (+ 4 5) #\b)
+      `1
+      `,inst-struct-name1403
+      `(#\a 1 #\c . are)))
+  (define inst-struct-name1439
+    (make-test-struct `(#t 8 #f) `#3(#\a are 3) `#\d `are))
+  (define inst-struct-name1460 (make-test-struct `#f `#\d `5 `#\b))
+  (define inst-struct-name1466
+    (make-test-struct
+      `(#\a 4 #t)
+      `((#\a (+ 1 2) 7 . #\d) () 0 . #t)
+      `((#f #\a #\b . #\a)
+        are
+        (2 symbols #f + 4 (+ 1 1))
+        ,inst-struct-name1460)
+      `#&(2 #\b #\b)))
+  (define inst-struct-name1502
+    (make-test-struct `#\c `() `#&(2 are 8) `#4(these #\c #\a)))
+  (define inst-struct-name1508
+    (make-test-struct `#\c `#\d `(#t (+ 4 (+ 1 1)) #\c . symbols) `()))
+  (define inst-struct-name1519 (make-test-struct `#t `#\b `#\d `6))
+  (define inst-struct-name1534 (make-test-struct `these `#\b `#\c `are))
+  (define inst-struct-name1536
+    (make-test-struct
+      `(#\d #f 0 . #\d)
+      `(are are #\c . #\b)
+      `(+ 1 2)
+      `,inst-struct-name1534))
+  (define inst-struct-name1538
+    (make-test-struct
+      `,inst-struct-name1519
+      `2
+      `,inst-struct-name1536
+      `(+ 4 5)))
+  (define inst-struct-name1543 (make-test-struct `2 `3 `#\d `(+ 4 5)))
+  (define inst-struct-name1561 (make-test-struct `#f `symbols `#\b `#t))
+  (define inst-struct-name1563
+    (make-test-struct `(+ 4 (+ 1 1)) `,inst-struct-name1561 `(+ 4 5) `3))
+  (define inst-struct-name1572 (make-test-struct `(+ 1 2) `#\a `#\b `#\d))
+  (define inst-struct-name1577 (make-test-struct `#\b `#\b `#\b `4))
+  (define inst-struct-name1594 (make-test-struct `#f `are `#\b `#f))
+  (define inst-struct-name1609
+    (make-test-struct
+      `(symbols (+ 1 2) #\d)
+      `(#\c symbols are)
+      `(are are #\c (+ 1 2))
+      `(symbols #\d (+ 1 2) . #\b)))
+  (define inst-struct-name1619 (make-test-struct `#t `(+ 4 (+ 1 1)) `#\c `#t))
+  (define inst-struct-name1635
+    (make-test-struct `#\b `#\d `(+ 4 (+ 1 1)) `#\c))
+  (define inst-struct-name1663 (make-test-struct `#f `#\a `#f `(+ 1 2)))
+  (define inst-struct-name1666
+    (make-test-struct
+      `(#\c these symbols . #f)
+      `(4 5 #f)
+      `,inst-struct-name1663
+      `(#f (+ 4 5) (+ 4 5))))
+  (define inst-struct-name1687 (make-test-struct `symbols `are `1 `are))
+  (define inst-struct-name1701
+    (make-test-struct
+      `#4(#4(these #\d these symbols) (are 6 these) #\c #\d)
+      `#3(#f 8 (+ 4 5))
+      `(#\b are symbols)
+      `#\b))
+  (define inst-struct-name1708
+    (make-test-struct
+      `(+ 1 2)
+      `#4(() #&((+ 4 5) #\a #f) () (+ 4 (+ 1 1)))
+      `#\b
+      `#\a))
+  (define inst-struct-name1719
+    (make-test-struct `#&(#\d #t #t) `(+ 4 (+ 1 1)) `0 `(+ 4 (+ 1 1))))
+  (define inst-struct-name1741 (make-test-struct `these `#t `7 `#\b))
+  (define inst-struct-name1775
+    (make-test-struct `(8 #f #f (+ 4 (+ 1 1))) `(9 #\c #t) `#f `#t))
+  (define inst-struct-name1776
+    (make-test-struct
+      `symbols
+      `#3(#\d #\c (+ 4 (+ 1 1)))
+      `#3(symbols #\a #\d)
+      `,inst-struct-name1775))
+  (define inst-struct-name1786 (make-test-struct `0 `#\a `0 `#t))
+  (define inst-struct-name1796
+    (make-test-struct `3 `#3(#\b #\c 0) `#t `(+ 4 5)))
+  (define inst-struct-name1797
+    (make-test-struct
+      `((these #t (+ 4 (+ 1 1)) . #\a)
+        ,inst-struct-name1786
+        (#\a #t 7)
+        #&(9 #\b symbols))
+      `(+ 4 5)
+      `,inst-struct-name1796
+      `(+ 4 (+ 1 1))))
+  (define inst-struct-name1813
+    (make-test-struct
+      `(symbols #\d #\b are)
+      `#4(#\d (+ 4 (+ 1 1)) #f #\b)
+      `are
+      `()))
+  (define inst-struct-name1818
+    (make-test-struct
+      `#&(#\a (9 #\c symbols) #f)
+      `,inst-struct-name1813
+      `#&(8 () #\d)
+      `#3(#\a these symbols)))
+  (define inst-struct-name1832 (make-test-struct `are `1 `() `(12 #\c #t . 4)))
+  (define inst-struct-name1873 (make-test-struct `#t `7 `#\b `(+ 4 5)))
+  (define inst-struct-name1876
+    (make-test-struct
+      `0
+      `#&(#f 0 these)
+      `,inst-struct-name1873
+      `(+ 4 (+ 1 1))))
+  (define inst-struct-name1896
+    (make-test-struct
+      `#3(5 (+ 1 2) these)
+      `(+ 4 (+ 1 1))
+      `0
+      `#3(#\a #\d these)))
+  (define inst-struct-name1900
+    (make-test-struct `0 `these `#3(6 are symbols) `#3((+ 4 5) #t 8)))
+  (define inst-struct-name1919
+    (make-test-struct `(+ 1 2) `#\b `#&((+ 1 2) #\a #t) `#\b))
+  (define inst-struct-name1935
+    (make-test-struct `#&(2 #\c #\c) `(#f 0 6 #f) `#&(1 #\a symbols) `#\b))
+  (define inst-struct-name1941 (make-test-struct `#\b `(+ 4 5) `#f `are))
+  (define inst-struct-name1947 (make-test-struct `(+ 4 (+ 1 1)) `#\d `5 `#\d))
+  (define inst-struct-name1948
+    (make-test-struct
+      `(+ 4 5)
+      `,inst-struct-name1941
+      `(1 #\b (+ 4 5))
+      `,inst-struct-name1947))
+  (define inst-struct-name1955 (make-test-struct `2 `5 `#\c `()))
+  (define inst-struct-name1962
+    (make-test-struct `#4(#t are #\b #f) `#3(#f #f (+ 4 5)) `#t `()))
+  (define inst-struct-name1975 (make-test-struct `(+ 1 2) `(+ 1 2) `#\c `#f))
+  (define inst-struct-name1977
+    (make-test-struct
+      `symbols
+      `symbols
+      `(+ 4 (+ 1 1))
+      `(#3(2 (+ 4 5) #\b) are ,inst-struct-name1975 . 5)))
+  (define inst-struct-name1995 (make-test-struct `#\a `(+ 4 5) `8 `8))
+  (define inst-struct-name1996
+    (make-test-struct
+      `(#\c (+ 4 (+ 1 1)) 2 . #\a)
+      `(#\b #\c (+ 4 (+ 1 1)) . are)
+      `#\b
+      `,inst-struct-name1995))
+  (define inst-struct-name2013
+    (make-test-struct `18 `() `,inst-struct-name1996 `(are #\c symbols)))
+  (define inst-struct-name2041
+    (make-test-struct `(+ 1 2) `7 `#&(#\c #\d (+ 4 5)) `#t))
+  (define inst-struct-name2085
+    (make-test-struct `#4(#t (+ 4 5) (+ 4 5) #t) `0 `#\c `(these these 7)))
+  (define inst-struct-name2093
+    (make-test-struct `(#\b 9 #\b) `16 `#\a `#4((+ 1 2) 9 () 2)))
+  (define inst-struct-name2104
+    (make-test-struct `#\b `(symbols 1 (+ 4 5)) `12 `0))
+  (define inst-struct-name2110 (make-test-struct `#\a `#\a `these `symbols))
+  (define inst-struct-name2117
+    (make-test-struct
+      `,inst-struct-name2110
+      `#3(#t 4 7)
+      `(+ 1 2)
+      `#4(2 symbols (+ 4 (+ 1 1)) 5)))
+  (define inst-struct-name2125 (make-test-struct `#\c `(+ 4 (+ 1 1)) `#\c `2))
+  (define inst-struct-name2127
+    (make-test-struct
+      `(+ 4 5)
+      `()
+      `,inst-struct-name2117
+      `#4(#&(are 6 #\c) ,inst-struct-name2125 9 ())))
+  (define inst-struct-name2133
+    (make-test-struct
+      `symbols
+      `#3(#\b #\a #\d)
+      `((+ 4 5) #\d #\b . symbols)
+      `these))
+  (define inst-struct-name2138
+    (make-test-struct `0 `,inst-struct-name2133 `10 `#\d))
+  (define inst-struct-name2146 (make-test-struct `9 `#t `#t `(+ 4 5)))
+  (define inst-struct-name2153
+    (make-test-struct `#\c `symbols `(+ 4 (+ 1 1)) `#\a))
+  (define inst-struct-name2160
+    (make-test-struct
+      `(,inst-struct-name2146 #f 3 . #t)
+      `2
+      `#\c
+      `(,inst-struct-name2153 #f #&(7 0 2) . #\b)))
+  (define inst-struct-name2170 (make-test-struct `6 `8 `#f `(+ 4 (+ 1 1))))
+  (define inst-struct-name2188
+    (make-test-struct `#t `symbols `(+ 4 (+ 1 1)) `#t))
+  (define inst-struct-name2190
+    (make-test-struct
+      `#4(7 #\a (these 9 (+ 1 2)) ())
+      `2
+      `#\b
+      `#4(#3(are #\a #\c) #\a ,inst-struct-name2188 #\d)))
+  (define inst-struct-name2202 (make-test-struct `are `#f `#t `are))
+  (define inst-struct-name2204
+    (make-test-struct `(+ 1 2) `6 `,inst-struct-name2202 `#\c))
+  (define inst-struct-name2211
+    (make-test-struct `#t `(+ 4 (+ 1 1)) `symbols `these))
+  (define inst-struct-name2215
+    (make-test-struct
+      `(+ 4 (+ 1 1))
+      `,inst-struct-name2211
+      `(#f 6 #\c)
+      `(#\b #\b 1)))
+  (define inst-struct-name2245
+    (make-test-struct `#\c `#\a `symbols `(+ 4 (+ 1 1))))
+  (define inst-struct-name2252 (make-test-struct `2 `5 `#t `2))
+  (define inst-struct-name2263
+    (make-test-struct
+      `#\a
+      `#3(#\d symbols (+ 4 5))
+      `()
+      `((+ 1 2) (are #\b #\d) #\b . these)))
+  (define inst-struct-name2269
+    (make-test-struct `(symbols #\a #\a) `are `#f `()))
+  (define inst-struct-name2279
+    (make-test-struct
+      `#3(#\a #\b symbols)
+      `#3((+ 4 (+ 1 1)) #\d 2)
+      `#3(#f #\b (+ 1 2))
+      `(these #\b are)))
+  (define inst-struct-name2305 (make-test-struct `#\c `() `#t `(#\c 0 9)))
+  (define inst-struct-name2310 (make-test-struct `#\b `() `symbols `18))
+  (define inst-struct-name2327 (make-test-struct `#\d `#f `these `3))
+  (define inst-struct-name2335 (make-test-struct `#f `#\c `#\d `2))
+  (define inst-struct-name2336
+    (make-test-struct `#\b `,inst-struct-name2335 `#\c `()))
+  (define inst-struct-name2354 (make-test-struct `(+ 1 2) `#\b `0 `#\d))
+  (define inst-struct-name2359 (make-test-struct `#\d `#f `(+ 4 (+ 1 1)) `#f))
+  (define inst-struct-name2370
+    (make-test-struct `#\d `#\c `(these 6 #\a (+ 1 2)) `()))
+  (define inst-struct-name2376 (make-test-struct `(+ 1 2) `1 `3 `#\a))
+  (define inst-struct-name2382
+    (make-test-struct
+      `,inst-struct-name2376
+      `(#\b (+ 4 5) (+ 1 2))
+      `18
+      `#3(8 #\a (+ 4 5))))
+  (define inst-struct-name2388 (make-test-struct `#f `4 `3 `#t))
+  (define inst-struct-name2395
+    (make-test-struct
+      `,inst-struct-name2370
+      `,inst-struct-name2382
+      `#&((#\c #\c (+ 1 2)) ,inst-struct-name2388 (+ 4 5))
+      `14))
+  (define inst-struct-name2408
+    (make-test-struct
+      `#4(#\d #f these symbols)
+      `10
+      `these
+      `((+ 4 (+ 1 1)) symbols (+ 4 5) . symbols)))
+  (define inst-struct-name2413
+    (make-test-struct `(0 #\b #\b) `#\a `symbols `2))
+  (define inst-struct-name2438
+    (make-test-struct
+      `#&((+ 4 (+ 1 1)) (+ 1 2) (+ 4 5))
+      `#f
+      `#4((+ 4 (+ 1 1)) 9 #t #\c)
+      `6))
+  (define inst-struct-name2454
+    (make-test-struct `#3(#\a symbols 8) `#\d `#f `#3(1 #\c 4)))
+  (define inst-struct-name2465
+    (make-test-struct `() `#\b `symbols `#4(#t (+ 4 5) #t #\d)))
+  (define inst-struct-name2469
+    (make-test-struct
+      `#\b
+      `,inst-struct-name2465
+      `#\d
+      `#&(#\b #3(4 are 1) (+ 1 2))))
+  (define inst-struct-name2480
+    (make-test-struct
+      `#4((+ 1 2) 7 are #\b)
+      `(#\b symbols #\d)
+      `(#\d symbols symbols)
+      `(+ 1 2)))
+
+
+
+;; multi tests
+
+
+     (mytest
+      (match-let*
+        (((list
+           (or (and #\c #\c) (and #\c #\c))
+           (list tlp963 __3)
+           (not (not #f))
+           (list
+            (and (or (list-rest tlp964 tlp965 tlp966 'are)
+                     (list-rest tlp964 tlp965 tlp966 'are))
+                 (or (list-rest tlp967 tlp968 tlp969 'are)
+                     (list-rest tlp967 tlp968 tlp969 'are)))
+            (list tlp970 __3)
+            tlp971
+            tlp972))
+          `(#\c (#\d #f #\c) #f ((6 8 2 . are) ((+ 1 2) #t #\c) are #f)))
+         ((list
+           (box
+            (list
+             (list
+              (list-rest tlp973 tlp974 tlp975 'symbols)
+              (not (not 'these))
+              tlp976
+              (and (? test-struct? tlp982)
+                   (app test-struct-a tlp977)
+                   (app test-struct-b tlp978)
+                   (app test-struct-c tlp979)
+                   (app test-struct-d tlp980)))
+             (list
+              (list tlp983 tlp984 tlp985 tlp986)
+              (and (? test-struct? tlp992)
+                   (app test-struct-a tlp987)
+                   (app test-struct-b tlp988)
+                   (app test-struct-c tlp989)
+                   (app test-struct-d tlp990))
+              (vector tlp993 tlp994 tlp995 tlp996)
+              (box (list tlp997 tlp998 tlp999)))
+             (or tlp1000 tlp1000)))
+           (and (? test-struct? tlp1005)
+                (app test-struct-a #t)
+                (app test-struct-b (or tlp1001 tlp1001))
+                (app test-struct-c tlp1002)
+                (app test-struct-d (list tlp1003 ...)))
+           (not (not 'these))
+           (list tlp1006 ___))
+          `(#&(((symbols are these . symbols) these #\c ,inst-struct-name981)
+               ((#t #\a #\c (+ 1 2))
+                ,inst-struct-name991
+                #4(#t are #\a #\d)
+                #&(#\a (+ 1 2) (+ 4 (+ 1 1))))
+               #\d)
+            ,inst-struct-name1004
+            these
+            (#\d symbols #t)))
+         ((list
+           (list)
+           (and (? test-struct? tlp1033)
+                (app test-struct-a tlp1007)
+                (app test-struct-b (and (? number? tlp1008) (? even? tlp1009)))
+                (app
+                 test-struct-c
+                 (and (? test-struct? tlp1023)
+                      (app
+                       test-struct-a
+                       (and (list-rest tlp1010 tlp1011 tlp1012 tlp1013)
+                            (list-rest tlp1014 tlp1015 tlp1016 tlp1017)))
+                      (app test-struct-b (list))
+                      (app
+                       test-struct-c
+                       (and (list tlp1018 ___) (list tlp1019 ___)))
+                      (app
+                       test-struct-d
+                       (and (? number? tlp1020) (? even? tlp1021)))))
+                (app
+                 test-struct-d
+                 (and (? test-struct? tlp1031)
+                      (app
+                       test-struct-a
+                       (or (and (? number? tlp1024) (? even? tlp1025))
+                           (and (? number? tlp1024) (? even? tlp1025))))
+                      (app test-struct-b _)
+                      (app
+                       test-struct-c
+                       (vector tlp1026 tlp1027 tlp1028 tlp1029))
+                      (app test-struct-d _))))
+           9
+           (list
+            (struct
+              test-struct
+              ((and (and tlp1034 tlp1035) (and tlp1036 tlp1037))
+               tlp1038
+               (struct test-struct (tlp1039 tlp1040 tlp1041 tlp1042))
+               (and (? test-struct? tlp1049)
+                    (app test-struct-a tlp1044)
+                    (app test-struct-b tlp1045)
+                    (app test-struct-c tlp1046)
+                    (app test-struct-d tlp1047))))
+            tlp1051
+            1
+            _))
+          `(() ,inst-struct-name1032 9 (,inst-struct-name1050 #f 1 these))))
+        (list
+         tlp963
+         tlp964
+         tlp965
+         tlp966
+         tlp964
+         tlp965
+         tlp966
+         tlp970
+         tlp971
+         tlp972
+         tlp973
+         tlp974
+         tlp975
+         tlp976
+         tlp977
+         tlp978
+         tlp979
+         tlp980
+         tlp983
+         tlp984
+         tlp985
+         tlp986
+         tlp987
+         tlp988
+         tlp989
+         tlp990
+         tlp993
+         tlp994
+         tlp995
+         tlp996
+         tlp997
+         tlp998
+         tlp999
+         tlp1000
+         tlp1001
+         tlp1002
+         tlp1003
+         tlp1006
+         tlp1007
+         tlp1008
+         tlp1010
+         tlp1011
+         tlp1012
+         tlp1013
+         tlp1018
+         tlp1020
+         tlp1024
+         tlp1026
+         tlp1027
+         tlp1028
+         tlp1029
+         tlp1034
+         tlp1038
+         tlp1039
+         tlp1040
+         tlp1041
+         tlp1042
+         tlp1044
+         tlp1045
+         tlp1046
+         tlp1047
+         tlp1051))
+      '((#\d #f #\c)
+        6
+        8
+        2
+        6
+        8
+        2
+        ((+ 1 2) #t #\c)
+        are
+        #f
+        symbols
+        are
+        these
+        #\c
+        symbols
+        #\a
+        (+ 1 2)
+        (+ 1 2)
+        #t
+        #\a
+        #\c
+        (+ 1 2)
+        #\b
+        #\c
+        (+ 4 5)
+        #\d
+        #t
+        are
+        #\a
+        #\d
+        #\a
+        (+ 1 2)
+        (+ 4 (+ 1 1))
+        #\d
+        #\b
+        #\a
+        ((+ 4 (+ 1 1)) #t #\d)
+        (#\d symbols #t)
+        #\b
+        6
+        #\b
+        #f
+        #t
+        (+ 4 (+ 1 1))
+        (#t #\b #\b)
+        12
+        2
+        #\d
+        symbols
+        #\a
+        #\c
+        (+ 4 5)
+        #f
+        #\d
+        6
+        8
+        (+ 1 2)
+        #\b
+        (+ 1 2)
+        #\b
+        (+ 4 (+ 1 1))
+        #f))
+     (mytest
+      (match-let*
+        (((list
+           (list)
+           (list tlp1052 ...)
+           (list-rest
+             (list tlp1053 ..3)
+             (vector tlp1054 ...)
+             (vector
+               tlp1055
+               (vector tlp1056 ___)
+               (list tlp1057 ...)
+               (box (list tlp1058 tlp1059 tlp1060)))
+             #\d)
+           (and (? number? tlp1061) (? even? tlp1062)))
+          `(()
+            (6 #f #f)
+            ((1 symbols (+ 4 (+ 1 1)))
+             #3(#\c are #f)
+             #4(3 #3(#\b #\a) (#\a #t (+ 1 2)) #&(3 #\d #\b))
+             .
+             #\d)
+            14))
+         ((list
+           (and (? test-struct? tlp1092)
+                (app
+                 test-struct-a
+                 (struct
+                   test-struct
+                   ((not (not 'are))
+                    tlp1063
+                    tlp1064
+                    (and (? test-struct? tlp1070)
+                         (app test-struct-a tlp1065)
+                         (app test-struct-b tlp1066)
+                         (app test-struct-c tlp1067)
+                         (app test-struct-d tlp1068)))))
+                (app
+                 test-struct-b
+                 (struct
+                   test-struct
+                   ((box (list tlp1072 tlp1073 tlp1074))
+                    (and tlp1075 tlp1076)
+                    tlp1077
+                    (and (list tlp1078 ...) (list tlp1079 ...)))))
+                (app
+                 test-struct-c
+                 (or (vector
+                       (and tlp1081 tlp1082)
+                       (and (? test-struct? tlp1088)
+                            (app test-struct-a tlp1083)
+                            (app test-struct-b tlp1084)
+                            (app test-struct-c tlp1085)
+                            (app test-struct-d tlp1086))
+                       #\c
+                       #f)
+                     (vector
+                       (and tlp1081 tlp1082)
+                       (and (? test-struct? tlp1088)
+                            (app test-struct-a tlp1083)
+                            (app test-struct-b tlp1084)
+                            (app test-struct-c tlp1085)
+                            (app test-struct-d tlp1086))
+                       #\c
+                       #f)))
+                (app
+                 test-struct-d
+                 (and (? number? tlp1089) (? even? tlp1090))))
+           #t
+           (list tlp1093 ..3)
+           _)
+          `(,inst-struct-name1091 #t ((+ 4 5) #t these) (+ 4 5)))
+         ((list (list tlp1094 __3) tlp1095 (list tlp1096 ..3) (list))
+          `((are symbols #t) #\c (these are (+ 4 (+ 1 1))) ())))
+        (list
+         tlp1052
+         tlp1053
+         tlp1054
+         tlp1055
+         tlp1056
+         tlp1057
+         tlp1058
+         tlp1059
+         tlp1060
+         tlp1061
+         tlp1063
+         tlp1064
+         tlp1065
+         tlp1066
+         tlp1067
+         tlp1068
+         tlp1072
+         tlp1073
+         tlp1074
+         tlp1075
+         tlp1077
+         tlp1078
+         tlp1081
+         tlp1083
+         tlp1084
+         tlp1085
+         tlp1086
+         tlp1089
+         tlp1093
+         tlp1094
+         tlp1095
+         tlp1096))
+      '((6 #f #f)
+        (1 symbols (+ 4 (+ 1 1)))
+        (#\c are #f)
+        3
+        (#\b #\a #\a)
+        (#\a #t (+ 1 2))
+        3
+        #\d
+        #\b
+        14
+        symbols
+        #t
+        #\b
+        (+ 1 2)
+        8
+        symbols
+        #\d
+        6
+        (+ 4 (+ 1 1))
+        #t
+        0
+        (#\d #\d (+ 4 5))
+        6
+        symbols
+        #t
+        #\d
+        (+ 1 2)
+        0
+        ((+ 4 5) #t these)
+        (are symbols #t)
+        #\c
+        (these are (+ 4 (+ 1 1)))))
+     (mytest
+      (match-letrec
+        (((list
+           (struct test-struct (tlp1097 (list) (vector tlp1098 ___) (list)))
+           (and (? test-struct? tlp1119)
+                (app test-struct-a (list tlp1100 tlp1101 tlp1102 #\a))
+                (app
+                 test-struct-b
+                 (and (? test-struct? tlp1107)
+                      (app test-struct-a (list-rest tlp1103 tlp1104 tlp1105 8))
+                      (app test-struct-b _)
+                      (app test-struct-c (or '(+ 4 (+ 1 1)) '(+ 4 (+ 1 1))))
+                      (app test-struct-d _)))
+                (app test-struct-c tlp1108)
+                (app
+                 test-struct-d
+                 (box
+                  (list
+                   (list tlp1109 tlp1110 tlp1111 tlp1112)
+                   (list tlp1113 ..3)
+                   (list tlp1114 tlp1115 tlp1116 tlp1117)))))
+           (and (? test-struct? tlp1142)
+                (app
+                 test-struct-a
+                 (list
+                  (list)
+                  tlp1120
+                  (struct test-struct (tlp1121 tlp1122 tlp1123 tlp1124))
+                  (vector tlp1126 tlp1127 tlp1128 tlp1129)))
+                (app
+                 test-struct-b
+                 (and (? test-struct? tlp1140)
+                      (app test-struct-a _)
+                      (app
+                       test-struct-b
+                       (or (list-rest tlp1130 tlp1131 tlp1132 tlp1133)
+                           (list-rest tlp1130 tlp1131 tlp1132 tlp1133)))
+                      (app test-struct-c tlp1134)
+                      (app
+                       test-struct-d
+                       (vector tlp1135 tlp1136 tlp1137 tlp1138))))
+                (app test-struct-c (list))
+                (app test-struct-d (not (not 5))))
+           (and (? number? tlp1143) (? even? tlp1144)))
+          `(,inst-struct-name1099
+            ,inst-struct-name1118
+            ,inst-struct-name1141
+            12))
+         ((list
+           '(+ 1 2)
+           'symbols
+           _
+           (struct
+             test-struct
+             ((list
+               (list tlp1145 tlp1146 tlp1147 tlp1148)
+               (vector tlp1149 ___)
+               (and (? number? tlp1150) (? even? tlp1151))
+               (list tlp1152 __3))
+              2
+              (list-rest (list tlp1153 ___) (vector tlp1154 ___) 'symbols 0)
+              tlp1155)))
+          `((+ 1 2) symbols 5 ,inst-struct-name1156))
+         ((list
+           (list-rest
+             (list-rest
+               #\c
+               (struct test-struct (tlp1157 tlp1158 tlp1159 tlp1160))
+               (and (list-rest tlp1162 tlp1163 tlp1164 tlp1165)
+                    (list-rest tlp1166 tlp1167 tlp1168 tlp1169))
+               #\b)
+             (struct
+               test-struct
+               ((and (and (? test-struct? tlp1175)
+                          (app test-struct-a tlp1170)
+                          (app test-struct-b tlp1171)
+                          (app test-struct-c tlp1172)
+                          (app test-struct-d tlp1173))
+                     (and (? test-struct? tlp1176)
+                          (app test-struct-a tlp1177)
+                          (app test-struct-b tlp1178)
+                          (app test-struct-c tlp1179)
+                          (app test-struct-d tlp1180)))
+                tlp1181
+                (and tlp1182 tlp1183)
+                (box (list tlp1184 tlp1185 tlp1186))))
+             (or _ _)
+             #\a)
+           (list
+            _
+            (and (? number? tlp1188) (? even? tlp1189))
+            (list)
+            (and (? test-struct? tlp1199)
+                 (app test-struct-a (list tlp1190 ..3))
+                 (app test-struct-b (vector tlp1191 tlp1192 tlp1193 tlp1194))
+                 (app test-struct-c #f)
+                 (app test-struct-d (box (list tlp1195 tlp1196 tlp1197)))))
+           (and (? number? tlp1200) (? even? tlp1201))
+           '(+ 4 5))
+          `(((#\c ,inst-struct-name1161 (#\a are 4 . #t) . #\b)
+             ,inst-struct-name1187
+             (+ 1 2)
+             .
+             #\a)
+            (#\b 6 () ,inst-struct-name1198)
+            0
+            (+ 4 5))))
+        (list
+         tlp1097
+         tlp1098
+         tlp1100
+         tlp1101
+         tlp1102
+         tlp1103
+         tlp1104
+         tlp1105
+         tlp1108
+         tlp1109
+         tlp1110
+         tlp1111
+         tlp1112
+         tlp1113
+         tlp1114
+         tlp1115
+         tlp1116
+         tlp1117
+         tlp1120
+         tlp1121
+         tlp1122
+         tlp1123
+         tlp1124
+         tlp1126
+         tlp1127
+         tlp1128
+         tlp1129
+         tlp1130
+         tlp1131
+         tlp1132
+         tlp1133
+         tlp1130
+         tlp1131
+         tlp1132
+         tlp1133
+         tlp1134
+         tlp1135
+         tlp1136
+         tlp1137
+         tlp1138
+         tlp1143
+         tlp1145
+         tlp1146
+         tlp1147
+         tlp1148
+         tlp1149
+         tlp1150
+         tlp1152
+         tlp1153
+         tlp1154
+         tlp1155
+         tlp1157
+         tlp1158
+         tlp1159
+         tlp1160
+         tlp1162
+         tlp1163
+         tlp1164
+         tlp1165
+         tlp1170
+         tlp1171
+         tlp1172
+         tlp1173
+         tlp1181
+         tlp1182
+         tlp1184
+         tlp1185
+         tlp1186
+         tlp1188
+         tlp1190
+         tlp1191
+         tlp1192
+         tlp1193
+         tlp1194
+         tlp1195
+         tlp1196
+         tlp1197
+         tlp1200))
+      '(8
+        (#\d (+ 1 2) 9)
+        (+ 4 (+ 1 1))
+        these
+        #\d
+        #\c
+        5
+        #\a
+        #\a
+        are
+        #\c
+        #t
+        (+ 4 5)
+        (#\b 0 #\c)
+        1
+        are
+        (+ 1 2)
+        (+ 4 (+ 1 1))
+        these
+        #\b
+        (+ 4 5)
+        #\c
+        these
+        6
+        1
+        5
+        #\c
+        #t
+        #\c
+        these
+        9
+        #t
+        #\c
+        these
+        9
+        #\a
+        9
+        (+ 4 (+ 1 1))
+        #t
+        (+ 1 2)
+        12
+        #t
+        5
+        9
+        5
+        (symbols symbols these)
+        14
+        (are these are)
+        ((+ 4 (+ 1 1)) these #f)
+        ((+ 4 (+ 1 1)) #t #\b)
+        are
+        #\d
+        #\c
+        these
+        1
+        #\a
+        are
+        4
+        #t
+        #f
+        (+ 4 5)
+        #\d
+        #f
+        #\c
+        #\c
+        symbols
+        2
+        #\a
+        6
+        (#\d #\b #t)
+        #f
+        (+ 4 5)
+        symbols
+        (+ 1 2)
+        #\d
+        8
+        3
+        0))
+     (mytest
+      (match-let
+        (((list
+           #f
+           (list tlp1202 ..3)
+           (vector tlp1203 ___)
+           (list
+            (box
+             (list _ (box (list tlp1204 tlp1205 tlp1206)) (list tlp1207 ___)))
+            (and (? number? tlp1208) (? even? tlp1209))
+            (list)
+            (and (list tlp1210 ...) (list tlp1211 ...))))
+          `(#f
+            (these are #\a)
+            #3(#\b (+ 4 5) #\c)
+            (#&(9 #&(#t #\b #\a) ((+ 4 (+ 1 1)) #\b are)) 18 () (#t #\b #t))))
+         ((list 'symbols (and (? number? tlp1212) (? even? tlp1213)) #f 'are)
+          `(symbols 2 #f are))
+         ((list
+           (and tlp1214 tlp1215)
+           (and (? test-struct? tlp1233)
+                (app test-struct-a (vector tlp1216 ___))
+                (app
+                 test-struct-b
+                 (and (? test-struct? tlp1222)
+                      (app test-struct-a tlp1217)
+                      (app test-struct-b (not (not 4)))
+                      (app test-struct-c (list))
+                      (app
+                       test-struct-d
+                       (list-rest tlp1218 tlp1219 tlp1220 #\d))))
+                (app test-struct-c (box (list (list) (not (not '(+ 1 2))) (list))))
+                (app
+                 test-struct-d
+                 (and (? test-struct? tlp1231)
+                      (app test-struct-a (list))
+                      (app test-struct-b (vector tlp1223 ...))
+                      (app test-struct-c tlp1224)
+                      (app
+                       test-struct-d
+                       (struct
+                         test-struct
+                         (tlp1225 tlp1226 tlp1227 tlp1228))))))
+           (list tlp1234 ___)
+           _)
+          `((+ 4 5) ,inst-struct-name1232 ((+ 4 5) #t #\c) #\d)))
+        (list
+         tlp1202
+         tlp1203
+         tlp1204
+         tlp1205
+         tlp1206
+         tlp1207
+         tlp1208
+         tlp1210
+         tlp1212
+         tlp1214
+         tlp1216
+         tlp1217
+         tlp1218
+         tlp1219
+         tlp1220
+         tlp1223
+         tlp1224
+         tlp1225
+         tlp1226
+         tlp1227
+         tlp1228
+         tlp1234))
+      '((these are #\a)
+        (#\b (+ 4 5) #\c)
+        #t
+        #\b
+        #\a
+        ((+ 4 (+ 1 1)) #\b are)
+        18
+        (#t #\b #t)
+        2
+        (+ 4 5)
+        ((+ 1 2) #\a 2)
+        #\c
+        #\d
+        #\c
+        #\c
+        (#\b 0 (+ 4 5))
+        #\b
+        #\c
+        (+ 4 (+ 1 1))
+        these
+        #f
+        ((+ 4 5) #t #\c)))
+     (mytest
+      (match-let*
+        (((list
+           (and (? test-struct? tlp1239)
+                (app test-struct-a (list tlp1235 __3))
+                (app test-struct-b tlp1236)
+                (app test-struct-c (list))
+                (app test-struct-d (list tlp1237 __3)))
+           tlp1240
+           (list-rest
+             (vector tlp1241 ___)
+             (or (or (list tlp1242 tlp1243 tlp1244 tlp1245)
+                     (list tlp1242 tlp1243 tlp1244 tlp1245))
+                 (or (list tlp1242 tlp1243 tlp1244 tlp1245)
+                     (list tlp1242 tlp1243 tlp1244 tlp1245)))
+             (or (struct
+                   test-struct
+                   ((box (list tlp1246 tlp1247 tlp1248))
+                    (list tlp1249 ___)
+                    (and (? test-struct? tlp1255)
+                         (app test-struct-a tlp1250)
+                         (app test-struct-b tlp1251)
+                         (app test-struct-c tlp1252)
+                         (app test-struct-d tlp1253))
+                    (list tlp1256 tlp1257 tlp1258 tlp1259)))
+                 (struct
+                   test-struct
+                   ((box (list tlp1246 tlp1247 tlp1248))
+                    (list tlp1249 ___)
+                    (and (? test-struct? tlp1255)
+                         (app test-struct-a tlp1250)
+                         (app test-struct-b tlp1251)
+                         (app test-struct-c tlp1252)
+                         (app test-struct-d tlp1253))
+                    (list tlp1256 tlp1257 tlp1258 tlp1259))))
+             'these)
+           (list
+            tlp1261
+            (not (not #t))
+            (box
+             (list
+              (and (? test-struct? tlp1267)
+                   (app test-struct-a tlp1262)
+                   (app test-struct-b tlp1263)
+                   (app test-struct-c tlp1264)
+                   (app test-struct-d tlp1265))
+              #\d
+              (list tlp1268 tlp1269 tlp1270 tlp1271)))
+            (list-rest
+              (list)
+              (list-rest tlp1272 tlp1273 tlp1274 #\c)
+              (and (? test-struct? tlp1280)
+                   (app test-struct-a tlp1275)
+                   (app test-struct-b tlp1276)
+                   (app test-struct-c tlp1277)
+                   (app test-struct-d tlp1278))
+              #f)))
+          `(,inst-struct-name1238
+            1
+            (#3(#\c #\c (+ 1 2))
+             (#\c #\b (+ 4 (+ 1 1)) #\d)
+             ,inst-struct-name1260
+             .
+             these)
+            ((+ 4 (+ 1 1))
+             #t
+             #&(,inst-struct-name1266 #\d (symbols #\a #t #\d))
+             (() (#t #f #\c . #\c) ,inst-struct-name1279 . #f))))
+         ((list
+           (vector tlp1281 ___)
+           tlp1282
+           (not (not #\b))
+           (or (list tlp1283 ___) (list tlp1283 ___)))
+          `(#3((+ 4 5) are #\c) are #\b (#\a #\a symbols)))
+         ((list
+           (list
+            (list tlp1284 ..3)
+            (list)
+            tlp1285
+            (box
+             (list
+              (and (? number? tlp1286) (? even? tlp1287))
+              (or (box (list tlp1288 tlp1289 tlp1290))
+                  (box (list tlp1288 tlp1289 tlp1290)))
+              (box (list tlp1291 tlp1292 tlp1293)))))
+           (list tlp1294 __3)
+           2
+           (vector tlp1295 ___))
+          `(((are #\c (+ 4 (+ 1 1)))
+             ()
+             #\d
+             #&(2 #&(8 (+ 4 5) #\b) #&(are 3 #\a)))
+            (3 1 these)
+            2
+            #3(3 (+ 4 5) #\b))))
+        (list
+         tlp1235
+         tlp1236
+         tlp1237
+         tlp1240
+         tlp1241
+         tlp1242
+         tlp1243
+         tlp1244
+         tlp1245
+         tlp1246
+         tlp1247
+         tlp1248
+         tlp1249
+         tlp1250
+         tlp1251
+         tlp1252
+         tlp1253
+         tlp1256
+         tlp1257
+         tlp1258
+         tlp1259
+         tlp1261
+         tlp1262
+         tlp1263
+         tlp1264
+         tlp1265
+         tlp1268
+         tlp1269
+         tlp1270
+         tlp1271
+         tlp1272
+         tlp1273
+         tlp1274
+         tlp1275
+         tlp1276
+         tlp1277
+         tlp1278
+         tlp1281
+         tlp1282
+         tlp1283
+         tlp1284
+         tlp1285
+         tlp1286
+         tlp1288
+         tlp1289
+         tlp1290
+         tlp1291
+         tlp1292
+         tlp1293
+         tlp1294
+         tlp1295))
+      '((#f #\c #\c)
+        #\b
+        (#\d these these)
+        1
+        (#\c #\c (+ 1 2))
+        #\c
+        #\b
+        (+ 4 (+ 1 1))
+        #\d
+        are
+        #\c
+        #t
+        (9 these #\d)
+        #\b
+        (+ 4 (+ 1 1))
+        #f
+        (+ 4 5)
+        are
+        #\b
+        (+ 1 2)
+        3
+        (+ 4 (+ 1 1))
+        #t
+        #\b
+        #t
+        #\b
+        symbols
+        #\a
+        #t
+        #\d
+        #t
+        #f
+        #\c
+        #\d
+        #\c
+        #\a
+        #t
+        ((+ 4 5) are #\c)
+        are
+        (#\a #\a symbols)
+        (are #\c (+ 4 (+ 1 1)))
+        #\d
+        2
+        8
+        (+ 4 5)
+        #\b
+        are
+        3
+        #\a
+        (3 1 these)
+        (3 (+ 4 5) #\b)))
+  
+
+
+     (let ((tlp1555
+             (lambda (tlp1436)
+               (match
+                tlp1436
+                ((list
+                  (struct
+                    test-struct
+                    ((list tlp1437 ...) (vector tlp1438 ___) #\d 'are))
+                  (and (struct
+                         test-struct
+                         ((list tlp1440 ___)
+                          (list-rest
+                            (list-rest tlp1441 tlp1442 tlp1443 tlp1444)
+                            (list)
+                            (and (? number? tlp1445) (? even? tlp1446))
+                            #t)
+                          (list
+                           (list-rest tlp1447 tlp1448 tlp1449 tlp1450)
+                           tlp1451
+                           (list-rest tlp1452 tlp1453 tlp1454 tlp1455)
+                           (and (? test-struct? tlp1461)
+                                (app test-struct-a tlp1456)
+                                (app test-struct-b tlp1457)
+                                (app test-struct-c tlp1458)
+                                (app test-struct-d tlp1459)))
+                          (box
+                           (list
+                            (and (? number? tlp1462) (? even? tlp1463))
+                            tlp1464
+                            (or tlp1465 tlp1465)))))
+                       (struct
+                         test-struct
+                         ((list tlp1467 ___)
+                          (list-rest
+                            (list-rest tlp1468 tlp1469 tlp1470 tlp1471)
+                            (list)
+                            (and (? number? tlp1472) (? even? tlp1473))
+                            #t)
+                          (list
+                           (list-rest tlp1474 tlp1475 tlp1476 tlp1477)
+                           tlp1478
+                           (list-rest tlp1479 tlp1480 tlp1481 tlp1482)
+                           (and (? test-struct? tlp1483)
+                                (app test-struct-a tlp1484)
+                                (app test-struct-b tlp1485)
+                                (app test-struct-c tlp1486)
+                                (app test-struct-d tlp1487)))
+                          (box
+                           (list
+                            (and (? number? tlp1488) (? even? tlp1489))
+                            tlp1490
+                            (or tlp1491 tlp1491))))))
+                  (vector tlp1492 ...)
+                  (vector
+                    (box (list _ (vector tlp1493 ___) tlp1494))
+                    (not (not #\b))
+                    (and (? test-struct? tlp1503)
+                         (app test-struct-a (and _ _))
+                         (app test-struct-b (and (list) (list)))
+                         (app
+                          test-struct-c
+                          (box (list tlp1495 tlp1496 tlp1497)))
+                         (app
+                          test-struct-d
+                          (vector tlp1498 tlp1499 tlp1500 tlp1501)))
+                    _))
+                 (list
+                  tlp1437
+                  tlp1438
+                  tlp1440
+                  tlp1441
+                  tlp1442
+                  tlp1443
+                  tlp1444
+                  tlp1445
+                  tlp1447
+                  tlp1448
+                  tlp1449
+                  tlp1450
+                  tlp1451
+                  tlp1452
+                  tlp1453
+                  tlp1454
+                  tlp1455
+                  tlp1456
+                  tlp1457
+                  tlp1458
+                  tlp1459
+                  tlp1462
+                  tlp1464
+                  tlp1465
+                  tlp1492
+                  tlp1493
+                  tlp1494
+                  tlp1495
+                  tlp1496
+                  tlp1497
+                  tlp1498
+                  tlp1499
+                  tlp1500
+                  tlp1501))
+                ((list
+                  (and (vector
+                         (and (? test-struct? tlp1509)
+                              (app test-struct-a #\c)
+                              (app test-struct-b _)
+                              (app
+                               test-struct-c
+                               (list-rest tlp1504 tlp1505 tlp1506 tlp1507))
+                              (app test-struct-d (list)))
+                         tlp1510
+                         (list tlp1511 __3)
+                         #\a)
+                       (vector
+                         (and (? test-struct? tlp1512)
+                              (app test-struct-a #\c)
+                              (app test-struct-b _)
+                              (app
+                               test-struct-c
+                               (list-rest tlp1513 tlp1514 tlp1515 tlp1516))
+                              (app test-struct-d (list)))
+                         tlp1517
+                         (list tlp1518 __3)
+                         #\a))
+                  _
+                  (struct
+                    test-struct
+                    ((struct test-struct (#t #\b #\d (or 6 6)))
+                     (and (? number? tlp1520) (? even? tlp1521))
+                     (or (struct
+                           test-struct
+                           ((list-rest tlp1522 tlp1523 tlp1524 tlp1525)
+                            (list-rest tlp1526 tlp1527 tlp1528 tlp1529)
+                            (not (not '(+ 1 2)))
+                            (and (? test-struct? tlp1535)
+                                 (app test-struct-a tlp1530)
+                                 (app test-struct-b tlp1531)
+                                 (app test-struct-c tlp1532)
+                                 (app test-struct-d tlp1533))))
+                         (struct
+                           test-struct
+                           ((list-rest tlp1522 tlp1523 tlp1524 tlp1525)
+                            (list-rest tlp1526 tlp1527 tlp1528 tlp1529)
+                            (not (not '(+ 1 2)))
+                            (and (? test-struct? tlp1535)
+                                 (app test-struct-a tlp1530)
+                                 (app test-struct-b tlp1531)
+                                 (app test-struct-c tlp1532)
+                                 (app test-struct-d tlp1533)))))
+                     tlp1537))
+                  (and (list
+                        (vector tlp1539 ...)
+                        #\b
+                        (struct test-struct (tlp1540 3 tlp1541 tlp1542))
+                        (list tlp1544 ..3))
+                       (list
+                        (vector tlp1545 ...)
+                        #\b
+                        (struct test-struct (tlp1546 3 tlp1547 tlp1548))
+                        (list tlp1549 ..3))))
+                 (list
+                  tlp1504
+                  tlp1505
+                  tlp1506
+                  tlp1507
+                  tlp1510
+                  tlp1511
+                  tlp1520
+                  tlp1522
+                  tlp1523
+                  tlp1524
+                  tlp1525
+                  tlp1526
+                  tlp1527
+                  tlp1528
+                  tlp1529
+                  tlp1530
+                  tlp1531
+                  tlp1532
+                  tlp1533
+                  tlp1537
+                  tlp1539
+                  tlp1540
+                  tlp1541
+                  tlp1542
+                  tlp1544))
+                ((list
+                  (and tlp1550 tlp1551)
+                  (list tlp1552 __3)
+                  (list tlp1553 ___)
+                  (list tlp1554 ...))
+                 (list tlp1550 tlp1552 tlp1553 tlp1554))))))
+       (list
+        (mytest
+         (tlp1555
+           `(,inst-struct-name1439
+             ,inst-struct-name1466
+             #3(#\a #\b (+ 4 (+ 1 1)))
+             #4(#&(#t #3((+ 1 2) #f symbols) 2)
+                #\b
+                ,inst-struct-name1502
+                (+ 4 (+ 1 1)))))
+         '((#t 8 #f)
+           (#\a are 3)
+           (#\a 4 #t)
+           #\a
+           (+ 1 2)
+           7
+           #\d
+           0
+           #f
+           #\a
+           #\b
+           #\a
+           are
+           2
+           symbols
+           #f
+           (+ 4 (+ 1 1))
+           #f
+           #\d
+           5
+           #\b
+           2
+           #\b
+           #\b
+           (#\a #\b (+ 4 (+ 1 1)))
+           ((+ 1 2) #f symbols)
+           2
+           2
+           are
+           8
+           these
+           #\c
+           #\a
+           #\a))
+        (mytest
+         (tlp1555
+           `(#4(,inst-struct-name1508 #f (#\c symbols 9) #\a)
+             #f
+             ,inst-struct-name1538
+             (#3(#\b are (+ 4 (+ 1 1)))
+              #\b
+              ,inst-struct-name1543
+              (#f #\c #\d))))
+         '(#t
+           (+ 4 (+ 1 1))
+           #\c
+           symbols
+           #f
+           (#\c symbols 9)
+           2
+           #\d
+           #f
+           0
+           #\d
+           are
+           are
+           #\c
+           #\b
+           these
+           #\b
+           #\c
+           are
+           (+ 4 5)
+           (#\b are (+ 4 (+ 1 1)))
+           2
+           #\d
+           (+ 4 5)
+           (#f #\c #\d)))
+        (mytest
+         (tlp1555 `(#t (#\c 8 #\a) (#\d #\b #\d) (#\d symbols 8)))
+         '(#t (#\c 8 #\a) (#\d #\b #\d) (#\d symbols 8)))))
+     (let ((tlp1668
+             (lambda (tlp1556)
+               (match
+                tlp1556
+                ((list
+                  (vector
+                    (and (? test-struct? tlp1564)
+                         (app test-struct-a '(+ 4 (+ 1 1)))
+                         (app
+                          test-struct-b
+                          (and (? test-struct? tlp1562)
+                               (app test-struct-a tlp1557)
+                               (app test-struct-b tlp1558)
+                               (app test-struct-c tlp1559)
+                               (app test-struct-d tlp1560)))
+                         (app test-struct-c '(+ 4 5))
+                         (app test-struct-d (not (not 3))))
+                    (and (box
+                          (list
+                           (box (list tlp1565 tlp1566 tlp1567))
+                           (struct
+                             test-struct
+                             (tlp1568 tlp1569 tlp1570 tlp1571))
+                           (struct
+                             test-struct
+                             (tlp1573 tlp1574 tlp1575 tlp1576))))
+                         (box
+                          (list
+                           (box (list tlp1578 tlp1579 tlp1580))
+                           (struct
+                             test-struct
+                             (tlp1581 tlp1582 tlp1583 tlp1584))
+                           (struct
+                             test-struct
+                             (tlp1585 tlp1586 tlp1587 tlp1588)))))
+                    (or (list-rest
+                          (or tlp1589 tlp1589)
+                          (and (? test-struct? tlp1595)
+                               (app test-struct-a tlp1590)
+                               (app test-struct-b tlp1591)
+                               (app test-struct-c tlp1592)
+                               (app test-struct-d tlp1593))
+                          (vector tlp1596 tlp1597 tlp1598 tlp1599)
+                          #t)
+                        (list-rest
+                          (or tlp1589 tlp1589)
+                          (and (? test-struct? tlp1595)
+                               (app test-struct-a tlp1590)
+                               (app test-struct-b tlp1591)
+                               (app test-struct-c tlp1592)
+                               (app test-struct-d tlp1593))
+                          (vector tlp1596 tlp1597 tlp1598 tlp1599)
+                          #t))
+                    (and (? test-struct? tlp1610)
+                         (app test-struct-a (list tlp1600 ...))
+                         (app test-struct-b (list tlp1601 ...))
+                         (app
+                          test-struct-c
+                          (list tlp1602 tlp1603 tlp1604 tlp1605))
+                         (app
+                          test-struct-d
+                          (list-rest tlp1606 tlp1607 tlp1608 #\b))))
+                  (list
+                   (and (? number? tlp1611) (? even? tlp1612))
+                   (or (and (? number? tlp1613) (? even? tlp1614))
+                       (and (? number? tlp1613) (? even? tlp1614)))
+                   (box
+                    (list
+                     (struct test-struct (tlp1615 tlp1616 tlp1617 tlp1618))
+                     (and (? number? tlp1620) (? even? tlp1621))
+                     #f))
+                   (and (? number? tlp1622) (? even? tlp1623)))
+                  _
+                  (list))
+                 (list
+                  tlp1557
+                  tlp1558
+                  tlp1559
+                  tlp1560
+                  tlp1565
+                  tlp1566
+                  tlp1567
+                  tlp1568
+                  tlp1569
+                  tlp1570
+                  tlp1571
+                  tlp1573
+                  tlp1574
+                  tlp1575
+                  tlp1576
+                  tlp1589
+                  tlp1590
+                  tlp1591
+                  tlp1592
+                  tlp1593
+                  tlp1596
+                  tlp1597
+                  tlp1598
+                  tlp1599
+                  tlp1589
+                  tlp1590
+                  tlp1591
+                  tlp1592
+                  tlp1593
+                  tlp1596
+                  tlp1597
+                  tlp1598
+                  tlp1599
+                  tlp1600
+                  tlp1601
+                  tlp1602
+                  tlp1603
+                  tlp1604
+                  tlp1605
+                  tlp1606
+                  tlp1607
+                  tlp1608
+                  tlp1611
+                  tlp1613
+                  tlp1615
+                  tlp1616
+                  tlp1617
+                  tlp1618
+                  tlp1620
+                  tlp1622))
+                ((list
+                  (box
+                   (list
+                    (list-rest
+                      (vector tlp1624 tlp1625 tlp1626 tlp1627)
+                      tlp1628
+                      _
+                      #t)
+                    (list tlp1629 ___)
+                    (list
+                     (vector tlp1630 ___)
+                     (and (? test-struct? tlp1636)
+                          (app test-struct-a tlp1631)
+                          (app test-struct-b tlp1632)
+                          (app test-struct-c tlp1633)
+                          (app test-struct-d tlp1634))
+                     tlp1637
+                     tlp1638)))
+                  (list tlp1639 ..3)
+                  (list-rest _ (list tlp1640 __3) _ #t)
+                  (box
+                   (list
+                    tlp1641
+                    #t
+                    (vector
+                      (and (? number? tlp1642) (? even? tlp1643))
+                      (list)
+                      #\a
+                      (box (list tlp1644 tlp1645 tlp1646))))))
+                 (list
+                  tlp1624
+                  tlp1625
+                  tlp1626
+                  tlp1627
+                  tlp1628
+                  tlp1629
+                  tlp1630
+                  tlp1631
+                  tlp1632
+                  tlp1633
+                  tlp1634
+                  tlp1637
+                  tlp1638
+                  tlp1639
+                  tlp1640
+                  tlp1641
+                  tlp1642
+                  tlp1644
+                  tlp1645
+                  tlp1646))
+                ((list
+                  (list
+                   (and (list-rest
+                          (not (not 'symbols))
+                          _
+                          (list-rest tlp1647 tlp1648 tlp1649 tlp1650)
+                          0)
+                        (list-rest
+                          (not (not 'symbols))
+                          _
+                          (list-rest tlp1651 tlp1652 tlp1653 tlp1654)
+                          0))
+                   _
+                   (struct
+                     test-struct
+                     ((list-rest tlp1655 tlp1656 tlp1657 #f)
+                      (list tlp1658 ...)
+                      (and (? test-struct? tlp1664)
+                           (app test-struct-a tlp1659)
+                           (app test-struct-b tlp1660)
+                           (app test-struct-c tlp1661)
+                           (app test-struct-d tlp1662))
+                      (list tlp1665 ___)))
+                   (vector _ (and _ _) (not (not 6)) _))
+                  (list tlp1667 __3)
+                  (or 9 9)
+                  '(+ 4 5))
+                 (list
+                  tlp1647
+                  tlp1648
+                  tlp1649
+                  tlp1650
+                  tlp1655
+                  tlp1656
+                  tlp1657
+                  tlp1658
+                  tlp1659
+                  tlp1660
+                  tlp1661
+                  tlp1662
+                  tlp1665
+                  tlp1667))))))
+       (list
+        (mytest
+         (tlp1668
+           `(#4(,inst-struct-name1563
+                #&(#&(#\c (+ 4 (+ 1 1)) these)
+                   ,inst-struct-name1572
+                   ,inst-struct-name1577)
+                (4 ,inst-struct-name1594 #4(#t #\d these #\c) . #t)
+                ,inst-struct-name1609)
+             (0 10 #&(,inst-struct-name1619 2 #f) 2)
+             are
+             ()))
+         '(#f
+           symbols
+           #\b
+           #t
+           #\c
+           (+ 4 (+ 1 1))
+           these
+           (+ 1 2)
+           #\a
+           #\b
+           #\d
+           #\b
+           #\b
+           #\b
+           4
+           4
+           #f
+           are
+           #\b
+           #f
+           #t
+           #\d
+           these
+           #\c
+           4
+           #f
+           are
+           #\b
+           #f
+           #t
+           #\d
+           these
+           #\c
+           (symbols (+ 1 2) #\d)
+           (#\c symbols are)
+           are
+           are
+           #\c
+           (+ 1 2)
+           symbols
+           #\d
+           (+ 1 2)
+           0
+           10
+           #t
+           (+ 4 (+ 1 1))
+           #\c
+           #t
+           2
+           2))
+        (mytest
+         (tlp1668
+           `(#&((#4(#\c symbols #\a 8) #\b #f . #t)
+                ((+ 4 (+ 1 1)) (+ 4 5) #\c)
+                (#3(#\d (+ 4 5) 8) ,inst-struct-name1635 7 #t))
+             (3 7 #\d)
+             (#\b (#\b (+ 1 2) #f) #f . #t)
+             #&(#\a #t #4(10 () #\a #&(symbols symbols 7)))))
+         '(#\c
+           symbols
+           #\a
+           8
+           #\b
+           ((+ 4 (+ 1 1)) (+ 4 5) #\c)
+           (#\d (+ 4 5) 8)
+           #\b
+           #\d
+           (+ 4 (+ 1 1))
+           #\c
+           7
+           #t
+           (3 7 #\d)
+           (#\b (+ 1 2) #f)
+           #\a
+           10
+           symbols
+           symbols
+           7))
+        (mytest
+         (tlp1668
+           `(((symbols #\d (symbols #\d are . 8) . 0)
+              #\b
+              ,inst-struct-name1666
+              #4(#f #\d 6 #\c))
+             (#\c are (+ 1 2))
+             9
+             (+ 4 5)))
+         '(symbols
+            #\d
+            are
+            8
+            #\c
+            these
+            symbols
+            (4 5 #f)
+            #f
+            #\a
+            #f
+            (+ 1 2)
+            (#f (+ 4 5) (+ 4 5))
+            (#\c are (+ 1 2))))))
+     (let ((tlp1713
+             (lambda (tlp1669)
+               (match
+                tlp1669
+                ((list
+                  (box (list (list) (list) (list tlp1670 __3)))
+                  (not (not '(+ 1 2)))
+                  (box
+                   (list
+                    'symbols
+                    (vector
+                      (or (list tlp1671 tlp1672 tlp1673 tlp1674)
+                          (list tlp1671 tlp1672 tlp1673 tlp1674))
+                      tlp1675
+                      (vector tlp1676 ...)
+                      (list tlp1677 tlp1678 tlp1679 tlp1680))
+                    tlp1681))
+                  (box
+                   (list
+                    (vector tlp1682 #f #\a _)
+                    (vector
+                      (and (? test-struct? tlp1688)
+                           (app test-struct-a tlp1683)
+                           (app test-struct-b tlp1684)
+                           (app test-struct-c tlp1685)
+                           (app test-struct-d tlp1686))
+                      _
+                      (list tlp1689 __3)
+                      (box (list tlp1690 tlp1691 tlp1692)))
+                    (list))))
+                 (list
+                  tlp1670
+                  tlp1671
+                  tlp1672
+                  tlp1673
+                  tlp1674
+                  tlp1675
+                  tlp1676
+                  tlp1677
+                  tlp1678
+                  tlp1679
+                  tlp1680
+                  tlp1681
+                  tlp1682
+                  tlp1683
+                  tlp1684
+                  tlp1685
+                  tlp1686
+                  tlp1689
+                  tlp1690
+                  tlp1691
+                  tlp1692))
+                ((list
+                  (struct
+                    test-struct
+                    ((vector
+                       (vector tlp1693 tlp1694 tlp1695 tlp1696)
+                       (list tlp1697 __3)
+                       (not (not #\c))
+                       tlp1698)
+                     (vector tlp1699 ___)
+                     (list tlp1700 ..3)
+                     #\b))
+                  (struct
+                    test-struct
+                    (tlp1702
+                      (vector
+                        (list)
+                        (box (list tlp1703 tlp1704 tlp1705))
+                        (or (list) (list))
+                        tlp1706)
+                      _
+                      tlp1707))
+                  #t
+                  tlp1709)
+                 (list
+                  tlp1693
+                  tlp1694
+                  tlp1695
+                  tlp1696
+                  tlp1697
+                  tlp1698
+                  tlp1699
+                  tlp1700
+                  tlp1702
+                  tlp1703
+                  tlp1704
+                  tlp1705
+                  tlp1706
+                  tlp1707
+                  tlp1709))
+                ((list tlp1710 (vector tlp1711 ___) _ tlp1712)
+                 (list tlp1710 tlp1711 tlp1712))))))
+       (list
+        (mytest
+         (tlp1713
+           `(#&(() () (#f are #\d))
+             (+ 1 2)
+             #&(symbols
+                 #4((#\a 3 (+ 1 2) 3)
+                    (+ 4 5)
+                    #3(#f #\c 2)
+                    (#t (+ 4 5) (+ 4 (+ 1 1)) symbols))
+                 these)
+             #&(#4(#t #f #\a #f)
+                #4(,inst-struct-name1687 8 (3 5 #\d) #&(#\d 8 #\a))
+                ())))
+         '((#f are #\d)
+           #\a
+           3
+           (+ 1 2)
+           3
+           (+ 4 5)
+           (#f #\c 2)
+           #t
+           (+ 4 5)
+           (+ 4 (+ 1 1))
+           symbols
+           these
+           #t
+           symbols
+           are
+           1
+           are
+           (3 5 #\d)
+           #\d
+           8
+           #\a))
+        (mytest
+         (tlp1713 `(,inst-struct-name1701 ,inst-struct-name1708 #t #\c))
+         '(these
+           #\d
+           these
+           symbols
+           (are 6 these)
+           #\d
+           (#f 8 (+ 4 5))
+           (#\b are symbols)
+           (+ 1 2)
+           (+ 4 5)
+           #\a
+           #f
+           (+ 4 (+ 1 1))
+           #\a
+           #\c))
+        (mytest (tlp1713 `(#f #3(9 (+ 4 5) 9) #t #\d)) '(#f (9 (+ 4 5) 9) #\d))))
+     (let ((tlp1746
+             (lambda (tlp1714)
+               (match
+                tlp1714
+                ((list
+                  (list-rest
+                    (list)
+                    (and (? test-struct? tlp1720)
+                         (app
+                          test-struct-a
+                          (box (list tlp1715 tlp1716 tlp1717)))
+                         (app test-struct-b _)
+                         (app test-struct-c 0)
+                         (app test-struct-d tlp1718))
+                    (not (not '(+ 4 5)))
+                    8)
+                  '(+ 4 (+ 1 1))
+                  (and (? number? tlp1721) (? even? tlp1722))
+                  (vector
+                    (and (? number? tlp1723) (? even? tlp1724))
+                    _
+                    (box
+                     (list
+                      (not (not '(+ 4 (+ 1 1))))
+                      (not (not #t))
+                      (list tlp1725 ___)))
+                    (not (not '(+ 1 2)))))
+                 (list
+                  tlp1715
+                  tlp1716
+                  tlp1717
+                  tlp1718
+                  tlp1721
+                  tlp1723
+                  tlp1725))
+                ((list
+                  _
+                  (box (list (list tlp1726 ...) tlp1727 (list)))
+                  tlp1728
+                  '(+ 4 5))
+                 (list tlp1726 tlp1727 tlp1728))
+                ((list
+                  tlp1729
+                  #\a
+                  (vector
+                    (and (? number? tlp1730) (? even? tlp1731))
+                    (list-rest
+                      '(+ 1 2)
+                      (list tlp1732 tlp1733 tlp1734 tlp1735)
+                      (list tlp1736 __3)
+                      #\b)
+                    (list-rest
+                      (and (? test-struct? tlp1742)
+                           (app test-struct-a tlp1737)
+                           (app test-struct-b tlp1738)
+                           (app test-struct-c tlp1739)
+                           (app test-struct-d tlp1740))
+                      (list)
+                      (box (list tlp1743 tlp1744 tlp1745))
+                      'these)
+                    (list))
+                  #f)
+                 (list
+                  tlp1729
+                  tlp1730
+                  tlp1732
+                  tlp1733
+                  tlp1734
+                  tlp1735
+                  tlp1736
+                  tlp1737
+                  tlp1738
+                  tlp1739
+                  tlp1740
+                  tlp1743
+                  tlp1744
+                  tlp1745))))))
+       (list
+        (mytest
+         (tlp1746
+           `((() ,inst-struct-name1719 (+ 4 5) . 8)
+             (+ 4 (+ 1 1))
+             2
+             #4(6 2 #&((+ 4 (+ 1 1)) #t (2 (+ 4 (+ 1 1)) are)) (+ 1 2))))
+         '(#\d #t #t (+ 4 (+ 1 1)) 2 6 (2 (+ 4 (+ 1 1)) are)))
+        (mytest
+         (tlp1746 `(are #&(((+ 4 5) are these) (+ 1 2) ()) are (+ 4 5)))
+         '(((+ 4 5) are these) (+ 1 2) are))
+        (mytest
+         (tlp1746
+           `(#\d
+             #\a
+             #4(4
+                ((+ 1 2) (4 #t #\b #f) (0 (+ 4 5) these) . #\b)
+                (,inst-struct-name1741 () #&(#\d #\c #\a) . these)
+                ())
+             #f))
+         '(#\d 4 4 #t #\b #f (0 (+ 4 5) these) these #t 7 #\b #\d #\c #\a))))
+     (let ((tlp1820
+             (lambda (tlp1747)
+               (match
+                tlp1747
+                ((list (vector tlp1748 ...) _ (or _ _) (list tlp1749 __3))
+                 (list tlp1748 tlp1749))
+                ((list
+                  (list tlp1750 ..3)
+                  (and tlp1751 tlp1752)
+                  tlp1753
+                  (list-rest
+                    tlp1754
+                    (list (list) tlp1755 (list) (box (list tlp1756 tlp1757 tlp1758)))
+                    (list-rest
+                      (list tlp1759 ___)
+                      (and (? number? tlp1760) (? even? tlp1761))
+                      (vector tlp1762 tlp1763 tlp1764 tlp1765)
+                      #t)
+                    #t))
+                 (list
+                  tlp1750
+                  tlp1751
+                  tlp1753
+                  tlp1754
+                  tlp1755
+                  tlp1756
+                  tlp1757
+                  tlp1758
+                  tlp1759
+                  tlp1760
+                  tlp1762
+                  tlp1763
+                  tlp1764
+                  tlp1765))
+                ((list
+                  (and (? test-struct? tlp1777)
+                       (app test-struct-a tlp1766)
+                       (app test-struct-b (vector tlp1767 ...))
+                       (app test-struct-c (vector tlp1768 ___))
+                       (app
+                        test-struct-d
+                        (struct
+                          test-struct
+                          ((list tlp1769 tlp1770 tlp1771 tlp1772)
+                           (list tlp1773 ___)
+                           tlp1774
+                           #t))))
+                  tlp1778
+                  (and (? test-struct? tlp1798)
+                       (app
+                        test-struct-a
+                        (list
+                         (list-rest tlp1779 tlp1780 tlp1781 #\a)
+                         (and (? test-struct? tlp1787)
+                              (app test-struct-a tlp1782)
+                              (app test-struct-b tlp1783)
+                              (app test-struct-c tlp1784)
+                              (app test-struct-d tlp1785))
+                         (list tlp1788 ___)
+                         (box (list tlp1789 tlp1790 tlp1791))))
+                       (app test-struct-b (or '(+ 4 5) '(+ 4 5)))
+                       (app
+                        test-struct-c
+                        (struct
+                          test-struct
+                          (tlp1792 (vector tlp1793 ...) tlp1794 tlp1795)))
+                       (app test-struct-d _))
+                  (and (? test-struct? tlp1819)
+                       (app
+                        test-struct-a
+                        (box
+                         (list
+                          tlp1799
+                          (list tlp1800 ..3)
+                          (and tlp1801 tlp1802))))
+                       (app
+                        test-struct-b
+                        (and (? test-struct? tlp1814)
+                             (app
+                              test-struct-a
+                              (list tlp1803 tlp1804 tlp1805 tlp1806))
+                             (app
+                              test-struct-b
+                              (vector tlp1807 tlp1808 tlp1809 tlp1810))
+                             (app
+                              test-struct-c
+                              (and (or tlp1811 tlp1811) (or tlp1812 tlp1812)))
+                             (app test-struct-d (or (list) (list)))))
+                       (app test-struct-c (box (list tlp1815 (list) tlp1816)))
+                       (app test-struct-d (vector tlp1817 ...))))
+                 (list
+                  tlp1766
+                  tlp1767
+                  tlp1768
+                  tlp1769
+                  tlp1770
+                  tlp1771
+                  tlp1772
+                  tlp1773
+                  tlp1774
+                  tlp1778
+                  tlp1779
+                  tlp1780
+                  tlp1781
+                  tlp1782
+                  tlp1783
+                  tlp1784
+                  tlp1785
+                  tlp1788
+                  tlp1789
+                  tlp1790
+                  tlp1791
+                  tlp1792
+                  tlp1793
+                  tlp1794
+                  tlp1795
+                  tlp1799
+                  tlp1800
+                  tlp1801
+                  tlp1803
+                  tlp1804
+                  tlp1805
+                  tlp1806
+                  tlp1807
+                  tlp1808
+                  tlp1809
+                  tlp1810
+                  tlp1811
+                  tlp1815
+                  tlp1816
+                  tlp1817))))))
+       (list
+        (mytest
+         (tlp1820 `(#3(#\d symbols #\a) #f 2 (3 #f these)))
+         '((#\d symbols #\a) (3 #f these)))
+        (mytest
+         (tlp1820
+           `(((+ 4 (+ 1 1)) #\c 6)
+             #\d
+             #\b
+             (#\d
+              (() #\a () #&(symbols are #t))
+              ((#\b #f 0) 18 #4(0 (+ 4 5) #\d these) . #t)
+              .
+              #t)))
+         '(((+ 4 (+ 1 1)) #\c 6)
+           #\d
+           #\b
+           #\d
+           #\a
+           symbols
+           are
+           #t
+           (#\b #f 0)
+           18
+           0
+           (+ 4 5)
+           #\d
+           these))
+        (mytest
+         (tlp1820
+           `(,inst-struct-name1776
+             (+ 4 (+ 1 1))
+             ,inst-struct-name1797
+             ,inst-struct-name1818))
+         '(symbols
+            (#\d #\c (+ 4 (+ 1 1)))
+            (symbols #\a #\d)
+            8
+            #f
+            #f
+            (+ 4 (+ 1 1))
+            (9 #\c #t)
+            #f
+            (+ 4 (+ 1 1))
+            these
+            #t
+            (+ 4 (+ 1 1))
+            0
+            #\a
+            0
+            #t
+            (#\a #t 7)
+            9
+            #\b
+            symbols
+            3
+            (#\b #\c 0)
+            #t
+            (+ 4 5)
+            #\a
+            (9 #\c symbols)
+            #f
+            symbols
+            #\d
+            #\b
+            are
+            #\d
+            (+ 4 (+ 1 1))
+            #f
+            #\b
+            are
+            8
+            #\d
+            (#\a these symbols)))))
+ 
+
+
+     (let ((tlp1951
+             (match-lambda
+               ((list (list tlp1907 ___) (list) 'symbols 'these) (list tlp1907))
+               ((list
+                 (list
+                  #t
+                  (and (list) (list))
+                  (and tlp1908 tlp1909)
+                  (list tlp1910 ___))
+                 (vector tlp1911 ___)
+                 (list-rest (not (not #\b)) '(+ 1 2) tlp1912 #\a)
+                 tlp1913)
+                (list tlp1908 tlp1910 tlp1911 tlp1912 tlp1913))
+               ((list
+                 (vector
+                   (and (? test-struct? tlp1920)
+                        (app test-struct-a tlp1914)
+                        (app test-struct-b tlp1915)
+                        (app
+                         test-struct-c
+                         (box (list tlp1916 tlp1917 tlp1918)))
+                        (app test-struct-d #\b))
+                   (list-rest _ (list tlp1921 tlp1922 tlp1923 tlp1924) #f #\d)
+                   (and (? test-struct? tlp1936)
+                        (app
+                         test-struct-a
+                         (box (list tlp1925 tlp1926 tlp1927)))
+                        (app
+                         test-struct-b
+                         (list tlp1928 tlp1929 tlp1930 tlp1931))
+                        (app
+                         test-struct-c
+                         (box (list tlp1932 tlp1933 tlp1934)))
+                        (app test-struct-d _))
+                   (and (? test-struct? tlp1949)
+                        (app test-struct-a '(+ 4 5))
+                        (app
+                         test-struct-b
+                         (or (struct
+                               test-struct
+                               (tlp1937 tlp1938 tlp1939 tlp1940))
+                             (struct
+                               test-struct
+                               (tlp1937 tlp1938 tlp1939 tlp1940))))
+                        (app test-struct-c (list tlp1942 __3))
+                        (app
+                         test-struct-d
+                         (struct
+                           test-struct
+                           (tlp1943 tlp1944 tlp1945 tlp1946)))))
+                 #t
+                 _
+                 tlp1950)
+                (list
+                 tlp1914
+                 tlp1915
+                 tlp1916
+                 tlp1917
+                 tlp1918
+                 tlp1921
+                 tlp1922
+                 tlp1923
+                 tlp1924
+                 tlp1925
+                 tlp1926
+                 tlp1927
+                 tlp1928
+                 tlp1929
+                 tlp1930
+                 tlp1931
+                 tlp1932
+                 tlp1933
+                 tlp1934
+                 tlp1937
+                 tlp1938
+                 tlp1939
+                 tlp1940
+                 tlp1942
+                 tlp1943
+                 tlp1944
+                 tlp1945
+                 tlp1946
+                 tlp1950)))))
+       (list
+        (mytest (tlp1951 `((#\b 5 these) () symbols these)) '((#\b 5 these)))
+        (mytest
+         (tlp1951
+           `((#t () #\d ((+ 1 2) 0 1))
+             #3(#\c (+ 1 2) these)
+             (#\b (+ 1 2) (+ 4 5) . #\a)
+             #\d))
+         '(#\d ((+ 1 2) 0 1) (#\c (+ 1 2) these) (+ 4 5) #\d))
+        (mytest
+         (tlp1951
+           `(#4(,inst-struct-name1919
+                (#\b ((+ 4 (+ 1 1)) #\d are #t) #f . #\d)
+                ,inst-struct-name1935
+                ,inst-struct-name1948)
+             #t
+             these
+             #f))
+         '((+ 1 2)
+           #\b
+           (+ 1 2)
+           #\a
+           #t
+           (+ 4 (+ 1 1))
+           #\d
+           are
+           #t
+           2
+           #\c
+           #\c
+           #f
+           0
+           6
+           #f
+           1
+           #\a
+           symbols
+           #\b
+           (+ 4 5)
+           #f
+           are
+           (1 #\b (+ 4 5))
+           (+ 4 (+ 1 1))
+           #\d
+           5
+           #\d
+           #f))))
+     (let ((tlp2015
+             (match-lambda
+               ((list
+                 (list-rest
+                   tlp1952
+                   (or (struct test-struct (2 tlp1953 tlp1954 (list)))
+                       (struct test-struct (2 tlp1953 tlp1954 (list))))
+                   (struct
+                     test-struct
+                     ((vector tlp1956 tlp1957 tlp1958 tlp1959)
+                      (and (vector tlp1960 ___) (vector tlp1961 ___))
+                      (or #t #t)
+                      (list)))
+                   'these)
+                 (not (not '(+ 4 (+ 1 1))))
+                 (vector tlp1963 ___)
+                 (list))
+                (list
+                 tlp1952
+                 tlp1953
+                 tlp1954
+                 tlp1956
+                 tlp1957
+                 tlp1958
+                 tlp1959
+                 tlp1960
+                 tlp1963))
+               ((list
+                 (list tlp1964 ..3)
+                 (or (and (? number? tlp1965) (? even? tlp1966))
+                     (and (? number? tlp1965) (? even? tlp1966)))
+                 (and (? test-struct? tlp1978)
+                      (app test-struct-a tlp1967)
+                      (app test-struct-b 'symbols)
+                      (app test-struct-c tlp1968)
+                      (app
+                       test-struct-d
+                       (list-rest
+                         (vector tlp1969 ...)
+                         tlp1970
+                         (and (? test-struct? tlp1976)
+                              (app test-struct-a tlp1971)
+                              (app test-struct-b tlp1972)
+                              (app test-struct-c tlp1973)
+                              (app test-struct-d tlp1974))
+                         5)))
+                 (and (list) (list)))
+                (list
+                 tlp1964
+                 tlp1965
+                 tlp1967
+                 tlp1968
+                 tlp1969
+                 tlp1970
+                 tlp1971
+                 tlp1972
+                 tlp1973
+                 tlp1974))
+               ((list
+                 (list)
+                 tlp1979
+                 (struct
+                   test-struct
+                   ((and (? number? tlp1980) (? even? tlp1981))
+                    (list)
+                    (and (and (? test-struct? tlp1997)
+                              (app
+                               test-struct-a
+                               (list-rest tlp1982 tlp1983 tlp1984 tlp1985))
+                              (app
+                               test-struct-b
+                               (list-rest tlp1986 tlp1987 tlp1988 tlp1989))
+                              (app test-struct-c tlp1990)
+                              (app
+                               test-struct-d
+                               (struct
+                                 test-struct
+                                 (tlp1991 tlp1992 tlp1993 tlp1994))))
+                         (and (? test-struct? tlp1998)
+                              (app
+                               test-struct-a
+                               (list-rest tlp1999 tlp2000 tlp2001 tlp2002))
+                              (app
+                               test-struct-b
+                               (list-rest tlp2003 tlp2004 tlp2005 tlp2006))
+                              (app test-struct-c tlp2007)
+                              (app
+                               test-struct-d
+                               (struct
+                                 test-struct
+                                 (tlp2008 tlp2009 tlp2010 tlp2011)))))
+                    (list tlp2012 ..3)))
+                 tlp2014)
+                (list
+                 tlp1979
+                 tlp1980
+                 tlp1982
+                 tlp1983
+                 tlp1984
+                 tlp1985
+                 tlp1986
+                 tlp1987
+                 tlp1988
+                 tlp1989
+                 tlp1990
+                 tlp1991
+                 tlp1992
+                 tlp1993
+                 tlp1994
+                 tlp2012
+                 tlp2014)))))
+       (list
+        (mytest
+         (tlp2015
+           `((#f ,inst-struct-name1955 ,inst-struct-name1962 . these)
+             (+ 4 (+ 1 1))
+             #3(#t #\a #\c)
+             ()))
+         '(#f 5 #\c #t are #\b #f (#f #f (+ 4 5)) (#t #\a #\c)))
+        (mytest
+         (tlp2015 `((these #t #t) 18 ,inst-struct-name1977 ()))
+         '((these #t #t)
+           18
+           symbols
+           (+ 4 (+ 1 1))
+           (2 (+ 4 5) #\b)
+           are
+           (+ 1 2)
+           (+ 1 2)
+           #\c
+           #f))
+        (mytest
+         (tlp2015 `(() (+ 1 2) ,inst-struct-name2013 (+ 4 (+ 1 1))))
+         '((+ 1 2)
+           18
+           #\c
+           (+ 4 (+ 1 1))
+           2
+           #\a
+           #\b
+           #\c
+           (+ 4 (+ 1 1))
+           are
+           #\b
+           #\a
+           (+ 4 5)
+           8
+           8
+           (are #\c symbols)
+           (+ 4 (+ 1 1))))))
+     (let ((tlp2066
+             (match-lambda
+               ((list (not (not #t)) tlp2016 (list) tlp2017)
+                (list tlp2016 tlp2017))
+               ((list
+                 (list-rest
+                   (list tlp2018 (not (not '(+ 1 2))) 'are tlp2019)
+                   (list
+                    (list tlp2020 tlp2021 tlp2022 tlp2023)
+                    (and (list-rest tlp2024 tlp2025 tlp2026 tlp2027)
+                         (list-rest tlp2028 tlp2029 tlp2030 tlp2031))
+                    (list tlp2032 __3)
+                    _)
+                   (and (? number? tlp2033) (? even? tlp2034))
+                   #\b)
+                 _
+                 (list tlp2035 __3)
+                 #f)
+                (list
+                 tlp2018
+                 tlp2019
+                 tlp2020
+                 tlp2021
+                 tlp2022
+                 tlp2023
+                 tlp2024
+                 tlp2025
+                 tlp2026
+                 tlp2027
+                 tlp2032
+                 tlp2033
+                 tlp2035))
+               ((list
+                 (list
+                  (list tlp2036 ...)
+                  (and (and (? test-struct? tlp2042)
+                            (app test-struct-a tlp2037)
+                            (app test-struct-b 7)
+                            (app
+                             test-struct-c
+                             (box (list tlp2038 tlp2039 tlp2040)))
+                            (app test-struct-d (not (not #t))))
+                       (and (? test-struct? tlp2043)
+                            (app test-struct-a tlp2044)
+                            (app test-struct-b 7)
+                            (app
+                             test-struct-c
+                             (box (list tlp2045 tlp2046 tlp2047)))
+                            (app test-struct-d (not (not #t)))))
+                  (and (vector
+                         (and tlp2048 tlp2049)
+                         (list tlp2050 tlp2051 tlp2052 tlp2053)
+                         (and tlp2054 tlp2055)
+                         tlp2056)
+                       (vector
+                         (and tlp2057 tlp2058)
+                         (list tlp2059 tlp2060 tlp2061 tlp2062)
+                         (and tlp2063 tlp2064)
+                         tlp2065))
+                  #\c)
+                 'symbols
+                 (list)
+                 (not (not '(+ 4 5))))
+                (list
+                 tlp2036
+                 tlp2037
+                 tlp2038
+                 tlp2039
+                 tlp2040
+                 tlp2048
+                 tlp2050
+                 tlp2051
+                 tlp2052
+                 tlp2053
+                 tlp2054
+                 tlp2056)))))
+       (list
+        (mytest (tlp2066 `(#t #\c () #\c)) '(#\c #\c))
+        (mytest
+         (tlp2066
+           `((((+ 4 5) (+ 1 2) are these)
+              ((#\d 3 #\b #\c)
+               ((+ 4 (+ 1 1)) #\c (+ 4 (+ 1 1)) + 4 (+ 1 1))
+               (#\a 1 #\d)
+               0)
+              0
+              .
+              #\b)
+             #\c
+             (#\d these #t)
+             #f))
+         '((+ 4 5)
+           these
+           #\d
+           3
+           #\b
+           #\c
+           (+ 4 (+ 1 1))
+           #\c
+           (+ 4 (+ 1 1))
+           (+ 4 (+ 1 1))
+           (#\a 1 #\d)
+           0
+           (#\d these #t)))
+        (mytest
+         (tlp2066
+           `(((#\a #f #\a)
+              ,inst-struct-name2041
+              #4((+ 4 5) (#\a (+ 1 2) (+ 4 5) #\c) #f 7)
+              #\c)
+             symbols
+             ()
+             (+ 4 5)))
+         '((#\a #f #\a)
+           (+ 1 2)
+           #\c
+           #\d
+           (+ 4 5)
+           (+ 4 5)
+           #\a
+           (+ 1 2)
+           (+ 4 5)
+           #\c
+           #f
+           7))))
+     (let ((tlp2095
+             (match-lambda
+               ((list
+                 (and (? number? tlp2067) (? even? tlp2068))
+                 _
+                 (or 'these 'these)
+                 8)
+                (list tlp2067))
+               ((list
+                 (list tlp2069 ..3)
+                 (list tlp2070 ..3)
+                 (box
+                  (list
+                   (not (not 'are))
+                   (and (? number? tlp2071) (? even? tlp2072))
+                   tlp2073))
+                 (list-rest
+                   (vector
+                     (list)
+                     tlp2074
+                     tlp2075
+                     (list-rest tlp2076 tlp2077 tlp2078 'symbols))
+                   tlp2079
+                   (and (? test-struct? tlp2086)
+                        (app
+                         test-struct-a
+                         (vector tlp2080 tlp2081 tlp2082 tlp2083))
+                        (app test-struct-b _)
+                        (app test-struct-c (not (not #\c)))
+                        (app test-struct-d (list tlp2084 __3)))
+                   'are))
+                (list
+                 tlp2069
+                 tlp2070
+                 tlp2071
+                 tlp2073
+                 tlp2074
+                 tlp2075
+                 tlp2076
+                 tlp2077
+                 tlp2078
+                 tlp2079
+                 tlp2080
+                 tlp2081
+                 tlp2082
+                 tlp2083
+                 tlp2084))
+               ((list
+                 #\b
+                 _
+                 (struct
+                   test-struct
+                   ((list tlp2087 ...)
+                    (and (? number? tlp2088) (? even? tlp2089))
+                    (or tlp2090 tlp2090)
+                    (vector (not (not '(+ 1 2))) tlp2091 (list) tlp2092)))
+                 tlp2094)
+                (list tlp2087 tlp2088 tlp2090 tlp2091 tlp2092 tlp2094)))))
+       (list
+        (mytest (tlp2095 `(18 1 these 8)) '(18))
+        (mytest
+         (tlp2095
+           `((#f #\a #\c)
+             (#f #f are)
+             #&(are 10 #f)
+             (#4(() #\b are (#t symbols 0 . symbols))
+              6
+              ,inst-struct-name2085
+              .
+              are)))
+         '((#f #\a #\c)
+           (#f #f are)
+           10
+           #f
+           #\b
+           are
+           #t
+           symbols
+           0
+           6
+           #t
+           (+ 4 5)
+           (+ 4 5)
+           #t
+           (these these 7)))
+        (mytest
+         (tlp2095 `(#\b these ,inst-struct-name2093 #\a))
+         '((#\b 9 #\b) 16 #\a 9 2 #\a))))
+     (let ((tlp2164
+             (match-lambda
+               ((list
+                 (and (? number? tlp2096) (? even? tlp2097))
+                 (and (? test-struct? tlp2105)
+                      (app test-struct-a #\b)
+                      (app
+                       test-struct-b
+                       (or (and (list tlp2098 ___) (list tlp2099 ___))
+                           (and (list tlp2098 ___) (list tlp2099 ___))))
+                      (app
+                       test-struct-c
+                       (and (? number? tlp2100) (? even? tlp2101)))
+                      (app
+                       test-struct-d
+                       (and (? number? tlp2102) (? even? tlp2103))))
+                 #t
+                 #\a)
+                (list tlp2096 tlp2098 tlp2100 tlp2102))
+               ((list
+                 (and (? test-struct? tlp2128)
+                      (app test-struct-a _)
+                      (app test-struct-b (list))
+                      (app
+                       test-struct-c
+                       (struct
+                         test-struct
+                         ((struct
+                            test-struct
+                            (tlp2106 tlp2107 tlp2108 tlp2109))
+                          (vector tlp2111 ...)
+                          tlp2112
+                          (vector tlp2113 tlp2114 tlp2115 tlp2116))))
+                      (app
+                       test-struct-d
+                       (vector
+                         (box (list tlp2118 tlp2119 tlp2120))
+                         (struct test-struct (tlp2121 tlp2122 tlp2123 tlp2124))
+                         tlp2126
+                         (list))))
+                 (and (? test-struct? tlp2139)
+                      (app test-struct-a _)
+                      (app
+                       test-struct-b
+                       (and (? test-struct? tlp2134)
+                            (app test-struct-a _)
+                            (app test-struct-b (vector tlp2129 ___))
+                            (app
+                             test-struct-c
+                             (list-rest tlp2130 tlp2131 tlp2132 'symbols))
+                            (app test-struct-d 'these)))
+                      (app
+                       test-struct-c
+                       (and (? number? tlp2135) (? even? tlp2136)))
+                      (app test-struct-d tlp2137))
+                 (vector tlp2140 ...)
+                 tlp2141)
+                (list
+                 tlp2106
+                 tlp2107
+                 tlp2108
+                 tlp2109
+                 tlp2111
+                 tlp2112
+                 tlp2113
+                 tlp2114
+                 tlp2115
+                 tlp2116
+                 tlp2118
+                 tlp2119
+                 tlp2120
+                 tlp2121
+                 tlp2122
+                 tlp2123
+                 tlp2124
+                 tlp2126
+                 tlp2129
+                 tlp2130
+                 tlp2131
+                 tlp2132
+                 tlp2135
+                 tlp2137
+                 tlp2140
+                 tlp2141))
+               ((list
+                 (struct
+                   test-struct
+                   ((list-rest
+                      (struct test-struct (tlp2142 tlp2143 tlp2144 tlp2145))
+                      (not (not #f))
+                      tlp2147
+                      #t)
+                    _
+                    tlp2148
+                    (list-rest
+                      (and (? test-struct? tlp2154)
+                           (app test-struct-a tlp2149)
+                           (app test-struct-b tlp2150)
+                           (app test-struct-c tlp2151)
+                           (app test-struct-d tlp2152))
+                      (and tlp2155 tlp2156)
+                      (box (list tlp2157 tlp2158 tlp2159))
+                      #\b)))
+                 (list tlp2161 __3)
+                 'these
+                 (and (? number? tlp2162) (? even? tlp2163)))
+                (list
+                 tlp2142
+                 tlp2143
+                 tlp2144
+                 tlp2145
+                 tlp2147
+                 tlp2148
+                 tlp2149
+                 tlp2150
+                 tlp2151
+                 tlp2152
+                 tlp2155
+                 tlp2157
+                 tlp2158
+                 tlp2159
+                 tlp2161
+                 tlp2162)))))
+       (list
+        (mytest
+         (tlp2164 `(14 ,inst-struct-name2104 #t #\a))
+         '(14 (symbols 1 (+ 4 5)) 12 0))
+        (mytest
+         (tlp2164
+           `(,inst-struct-name2127
+             ,inst-struct-name2138
+             #3(#\a #\a (+ 4 5))
+             #\d))
+         '(#\a
+           #\a
+           these
+           symbols
+           (#t 4 7)
+           (+ 1 2)
+           2
+           symbols
+           (+ 4 (+ 1 1))
+           5
+           are
+           6
+           #\c
+           #\c
+           (+ 4 (+ 1 1))
+           #\c
+           2
+           9
+           (#\b #\a #\d)
+           (+ 4 5)
+           #\d
+           #\b
+           10
+           #\d
+           (#\a #\a (+ 4 5))
+           #\d))
+        (mytest
+         (tlp2164 `(,inst-struct-name2160 (#\a 0 are) these 0))
+         '(9
+           #t
+           #t
+           (+ 4 5)
+           3
+           #\c
+           #\c
+           symbols
+           (+ 4 (+ 1 1))
+           #\a
+           #f
+           7
+           0
+           2
+           (#\a 0 are)
+           0))))
+
+     (let ((tlp2271
+             (match-lambda*
+               ((list (not (not #\b)) '(+ 4 (+ 1 1)) (vector tlp2260 ...) _)
+                (list tlp2260))
+               ((list
+                 (list)
+                 (and (? test-struct? tlp2264)
+                      (app test-struct-a (not (not #\a)))
+                      (app test-struct-b (vector tlp2261 ...))
+                      (app test-struct-c (or (list) (list)))
+                      (app
+                       test-struct-d
+                       (list-rest
+                         '(+ 1 2)
+                         (list tlp2262 ...)
+                         (not (not #\b))
+                         'these)))
+                 (or (list tlp2265 __3) (list tlp2265 __3))
+                 (list))
+                (list tlp2261 tlp2262 tlp2265))
+               ((list
+                 (list tlp2266 ___)
+                 (struct
+                   test-struct
+                   ((list tlp2267 __3) (not (not 'are)) tlp2268 (list)))
+                 (list tlp2270 __3)
+                 (and #f #f))
+                (list tlp2266 tlp2267 tlp2268 tlp2270)))))
+       (list
+        (mytest
+         (tlp2271 `#\b `(+ 4 (+ 1 1)) `#3((+ 1 2) #f symbols) `#\d)
+         '(((+ 1 2) #f symbols)))
+        (mytest
+         (tlp2271 `() `,inst-struct-name2263 `(symbols 1 symbols) `())
+         '((#\d symbols (+ 4 5)) (are #\b #\d) (symbols 1 symbols)))
+        (mytest
+         (tlp2271
+           `(#t #\b (+ 4 5))
+           `,inst-struct-name2269
+           `((+ 4 (+ 1 1)) #f these)
+           `#f)
+         '((#t #\b (+ 4 5)) (symbols #\a #\a) #f ((+ 4 (+ 1 1)) #f these)))))
+     (let ((tlp2315
+             (match-lambda*
+               ((list
+                 tlp2273
+                 (box
+                  (list
+                   (struct
+                     test-struct
+                     ((vector tlp2274 ___)
+                      (vector tlp2275 ___)
+                      (vector tlp2276 ...)
+                      (and (list tlp2277 ___) (list tlp2278 ___))))
+                   (and (? number? tlp2280) (? even? tlp2281))
+                   (list (and tlp2282 tlp2283) tlp2284 _ (list tlp2285 ___))))
+                 _
+                 (and (? number? tlp2286) (? even? tlp2287)))
+                (list
+                 tlp2273
+                 tlp2274
+                 tlp2275
+                 tlp2276
+                 tlp2277
+                 tlp2280
+                 tlp2282
+                 tlp2284
+                 tlp2285
+                 tlp2286))
+               ((list
+                 tlp2288
+                 (and (list-rest
+                        (list-rest
+                          '(+ 4 5)
+                          (list tlp2289 tlp2290 tlp2291 tlp2292)
+                          (not (not #\a))
+                          #\b)
+                        (list-rest
+                          (list)
+                          #\a
+                          (and (? number? tlp2293) (? even? tlp2294))
+                          'these)
+                        (list tlp2295 ___)
+                        6)
+                      (list-rest
+                        (list-rest
+                          '(+ 4 5)
+                          (list tlp2296 tlp2297 tlp2298 tlp2299)
+                          (not (not #\a))
+                          #\b)
+                        (list-rest
+                          (list)
+                          #\a
+                          (and (? number? tlp2300) (? even? tlp2301))
+                          'these)
+                        (list tlp2302 ___)
+                        6))
+                 (box
+                  (list
+                   (list)
+                   _
+                   (and (? test-struct? tlp2306)
+                        (app test-struct-a tlp2303)
+                        (app test-struct-b (list))
+                        (app test-struct-c #t)
+                        (app
+                         test-struct-d
+                         (or (list tlp2304 ..3) (list tlp2304 ..3))))))
+                 (struct
+                   test-struct
+                   (tlp2307
+                     (list)
+                     (not (not 'symbols))
+                     (or (and (? number? tlp2308) (? even? tlp2309))
+                         (and (? number? tlp2308) (? even? tlp2309))))))
+                (list
+                 tlp2288
+                 tlp2289
+                 tlp2290
+                 tlp2291
+                 tlp2292
+                 tlp2293
+                 tlp2295
+                 tlp2303
+                 tlp2304
+                 tlp2307
+                 tlp2308))
+               ((list
+                 tlp2311
+                 (or tlp2312 tlp2312)
+                 (vector tlp2313 ___)
+                 tlp2314)
+                (list tlp2311 tlp2312 tlp2313 tlp2314)))))
+       (list
+        (mytest
+         (tlp2315
+           `1
+           `#&(,inst-struct-name2279 4 (#f #f #\d (#\b #\c #t)))
+           `(+ 1 2)
+           `12)
+         '(1
+           (#\a #\b symbols)
+           ((+ 4 (+ 1 1)) #\d 2)
+           (#f #\b (+ 1 2))
+           (these #\b are)
+           4
+           #f
+           #f
+           (#\b #\c #t)
+           12))
+        (mytest
+         (tlp2315
+           `#f
+           `(((+ 4 5) (#f symbols (+ 4 (+ 1 1)) #\a) #\a . #\b)
+             (() #\a 0 . these)
+             (symbols symbols #\c)
+             .
+             6)
+           `#&(() #\d ,inst-struct-name2305)
+           `,inst-struct-name2310)
+         '(#f
+           #f
+           symbols
+           (+ 4 (+ 1 1))
+           #\a
+           0
+           (symbols symbols #\c)
+           #\c
+           (#\c 0 9)
+           #\b
+           18))
+        (mytest
+         (tlp2315 `(+ 4 (+ 1 1)) `(+ 1 2) `#3(6 4 #t) `#\d)
+         '((+ 4 (+ 1 1)) (+ 1 2) (6 4 #t) #\d))))
+     (let ((tlp2414
+             (match-lambda*
+               ((list
+                 (not (not #\b))
+                 _
+                 (list
+                  (list tlp2317 ...)
+                  (list tlp2318 ..3)
+                  (vector
+                    tlp2319
+                    _
+                    (box (list tlp2320 tlp2321 tlp2322))
+                    (struct test-struct (tlp2323 tlp2324 tlp2325 tlp2326)))
+                  '(+ 4 5))
+                 (list tlp2328 __3))
+                (list
+                 tlp2317
+                 tlp2318
+                 tlp2319
+                 tlp2320
+                 tlp2321
+                 tlp2322
+                 tlp2323
+                 tlp2324
+                 tlp2325
+                 tlp2326
+                 tlp2328))
+               ((list
+                 tlp2329
+                 (list tlp2330 ...)
+                 (list
+                  (struct
+                    test-struct
+                    (_
+                     (struct test-struct (tlp2331 tlp2332 tlp2333 tlp2334))
+                     _
+                     (list)))
+                  tlp2337
+                  (and (and (box (list tlp2338 tlp2339 tlp2340))
+                            (box (list tlp2341 tlp2342 tlp2343)))
+                       (and (box (list tlp2344 tlp2345 tlp2346))
+                            (box (list tlp2347 tlp2348 tlp2349))))
+                  (and #\d #\d))
+                 (list-rest
+                   (list-rest
+                     (struct test-struct (tlp2350 tlp2351 tlp2352 tlp2353))
+                     (or (struct test-struct (tlp2355 tlp2356 tlp2357 tlp2358))
+                         (struct
+                           test-struct
+                           (tlp2355 tlp2356 tlp2357 tlp2358)))
+                     (list-rest tlp2360 tlp2361 tlp2362 #\c)
+                     #\a)
+                   (list tlp2363 ___)
+                   (list)
+                   3))
+                (list
+                 tlp2329
+                 tlp2330
+                 tlp2331
+                 tlp2332
+                 tlp2333
+                 tlp2334
+                 tlp2337
+                 tlp2338
+                 tlp2339
+                 tlp2340
+                 tlp2350
+                 tlp2351
+                 tlp2352
+                 tlp2353
+                 tlp2355
+                 tlp2356
+                 tlp2357
+                 tlp2358
+                 tlp2360
+                 tlp2361
+                 tlp2362
+                 tlp2363))
+               ((list
+                 (and (? test-struct? tlp2396)
+                      (app
+                       test-struct-a
+                       (and (? test-struct? tlp2371)
+                            (app test-struct-a tlp2364)
+                            (app test-struct-b tlp2365)
+                            (app
+                             test-struct-c
+                             (list tlp2366 tlp2367 tlp2368 tlp2369))
+                            (app test-struct-d (list))))
+                      (app
+                       test-struct-b
+                       (struct
+                         test-struct
+                         ((and (? test-struct? tlp2377)
+                               (app test-struct-a tlp2372)
+                               (app test-struct-b tlp2373)
+                               (app test-struct-c tlp2374)
+                               (app test-struct-d tlp2375))
+                          (list tlp2378 ..3)
+                          (and (? number? tlp2379) (? even? tlp2380))
+                          (vector tlp2381 ...))))
+                      (app
+                       test-struct-c
+                       (box
+                        (list
+                         (list tlp2383 ..3)
+                         (and (? test-struct? tlp2389)
+                              (app test-struct-a tlp2384)
+                              (app test-struct-b tlp2385)
+                              (app test-struct-c tlp2386)
+                              (app test-struct-d tlp2387))
+                         tlp2390)))
+                      (app
+                       test-struct-d
+                       (and (and (? number? tlp2391) (? even? tlp2392))
+                            (and (? number? tlp2393) (? even? tlp2394)))))
+                 (list
+                  '(+ 1 2)
+                  (vector tlp2397 ___)
+                  (struct
+                    test-struct
+                    ((vector tlp2398 tlp2399 tlp2400 tlp2401)
+                     (and (? number? tlp2402) (? even? tlp2403))
+                     tlp2404
+                     (list-rest tlp2405 tlp2406 tlp2407 'symbols)))
+                  _)
+                 (struct
+                   test-struct
+                   ((list tlp2409 ..3)
+                    (not (not #\a))
+                    tlp2410
+                    (and (? number? tlp2411) (? even? tlp2412))))
+                 (list))
+                (list
+                 tlp2364
+                 tlp2365
+                 tlp2366
+                 tlp2367
+                 tlp2368
+                 tlp2369
+                 tlp2372
+                 tlp2373
+                 tlp2374
+                 tlp2375
+                 tlp2378
+                 tlp2379
+                 tlp2381
+                 tlp2383
+                 tlp2384
+                 tlp2385
+                 tlp2386
+                 tlp2387
+                 tlp2390
+                 tlp2391
+                 tlp2397
+                 tlp2398
+                 tlp2399
+                 tlp2400
+                 tlp2401
+                 tlp2402
+                 tlp2404
+                 tlp2405
+                 tlp2406
+                 tlp2407
+                 tlp2409
+                 tlp2410
+                 tlp2411)))))
+       (list
+        (mytest
+         (tlp2414
+           `#\b
+           `#\c
+           `((#f (+ 4 (+ 1 1)) #\a)
+             (#\c are (+ 4 (+ 1 1)))
+             #4(are #\c #&(#t 5 (+ 4 (+ 1 1))) ,inst-struct-name2327)
+             (+ 4 5))
+           `((+ 4 5) #\b #\a))
+         '((#f (+ 4 (+ 1 1)) #\a)
+           (#\c are (+ 4 (+ 1 1)))
+           are
+           #t
+           5
+           (+ 4 (+ 1 1))
+           #\d
+           #f
+           these
+           3
+           ((+ 4 5) #\b #\a)))
+        (mytest
+         (tlp2414
+           `#t
+           `(#\b #\c (+ 4 5))
+           `(,inst-struct-name2336 #\b #&(#\a symbols #\d) #\d)
+           `((,inst-struct-name2354
+              ,inst-struct-name2359
+              ((+ 4 (+ 1 1)) #\a (+ 1 2) . #\c)
+              .
+              #\a)
+             (#t 7 6)
+             ()
+             .
+             3))
+         '(#t
+           (#\b #\c (+ 4 5))
+           #f
+           #\c
+           #\d
+           2
+           #\b
+           #\a
+           symbols
+           #\d
+           (+ 1 2)
+           #\b
+           0
+           #\d
+           #\d
+           #f
+           (+ 4 (+ 1 1))
+           #f
+           (+ 4 (+ 1 1))
+           #\a
+           (+ 1 2)
+           (#t 7 6)))
+        (mytest
+         (tlp2414
+           `,inst-struct-name2395
+           `((+ 1 2) #3(#\a 7 #f) ,inst-struct-name2408 (+ 1 2))
+           `,inst-struct-name2413
+           `())
+         '(#\d
+           #\c
+           these
+           6
+           #\a
+           (+ 1 2)
+           (+ 1 2)
+           1
+           3
+           #\a
+           (#\b (+ 4 5) (+ 1 2))
+           18
+           (8 #\a (+ 4 5))
+           (#\c #\c (+ 1 2))
+           #f
+           4
+           3
+           #t
+           (+ 4 5)
+           14
+           (#\a 7 #f)
+           #\d
+           #f
+           these
+           symbols
+           10
+           these
+           (+ 4 (+ 1 1))
+           symbols
+           (+ 4 5)
+           (0 #\b #\b)
+           symbols
+           2))))
+     (let ((tlp2448
+             (match-lambda*
+               ((list
+                 tlp2416
+                 (not (not #t))
+                 (or (list-rest
+                       (and (list tlp2417 ...) (list tlp2418 ...))
+                       (vector
+                         (list-rest tlp2419 tlp2420 tlp2421 tlp2422)
+                         #\c
+                         tlp2423
+                         (list-rest tlp2424 tlp2425 tlp2426 tlp2427))
+                       9
+                       'are)
+                     (list-rest
+                       (and (list tlp2417 ...) (list tlp2418 ...))
+                       (vector
+                         (list-rest tlp2419 tlp2420 tlp2421 tlp2422)
+                         #\c
+                         tlp2423
+                         (list-rest tlp2424 tlp2425 tlp2426 tlp2427))
+                       9
+                       'are))
+                 (list
+                  tlp2428
+                  (and (? number? tlp2429) (? even? tlp2430))
+                  (not (not '(+ 4 5)))
+                  (or (struct
+                        test-struct
+                        ((box (list tlp2431 tlp2432 tlp2433))
+                         #f
+                         (vector tlp2434 tlp2435 tlp2436 tlp2437)
+                         _))
+                      (struct
+                        test-struct
+                        ((box (list tlp2431 tlp2432 tlp2433))
+                         #f
+                         (vector tlp2434 tlp2435 tlp2436 tlp2437)
+                         _)))))
+                (list
+                 tlp2416
+                 tlp2417
+                 tlp2419
+                 tlp2420
+                 tlp2421
+                 tlp2422
+                 tlp2423
+                 tlp2424
+                 tlp2425
+                 tlp2426
+                 tlp2427
+                 tlp2417
+                 tlp2419
+                 tlp2420
+                 tlp2421
+                 tlp2422
+                 tlp2423
+                 tlp2424
+                 tlp2425
+                 tlp2426
+                 tlp2427
+                 tlp2428
+                 tlp2429
+                 tlp2431
+                 tlp2432
+                 tlp2433
+                 tlp2434
+                 tlp2435
+                 tlp2436
+                 tlp2437))
+               ((list
+                 (vector
+                   (list)
+                   (not (not #\d))
+                   (box (list (not (not 9)) (list) 'symbols))
+                   (list))
+                 _
+                 tlp2439
+                 (list-rest tlp2440 _ tlp2441 #t))
+                (list tlp2439 tlp2440 tlp2441))
+               ((list
+                 (or (not (not #\b)) (not (not #\b)))
+                 (list
+                  tlp2442
+                  (list)
+                  (list)
+                  (and (vector tlp2443 ...) (vector tlp2444 ...)))
+                 (list tlp2445 ___)
+                 (or (and (? number? tlp2446) (? even? tlp2447))
+                     (and (? number? tlp2446) (? even? tlp2447))))
+                (list tlp2442 tlp2443 tlp2445 tlp2446)))))
+       (list
+        (mytest
+         (tlp2448
+           `3
+           `#t
+           `((#\b #f are)
+             #4((#\d these symbols . #f) #\c #\c (these 4 #t . are))
+             9
+             .
+             are)
+           `(#\b 8 (+ 4 5) ,inst-struct-name2438))
+         '(3
+           (#\b #f are)
+           #\d
+           these
+           symbols
+           #f
+           #\c
+           these
+           4
+           #t
+           are
+           (#\b #f are)
+           #\d
+           these
+           symbols
+           #f
+           #\c
+           these
+           4
+           #t
+           are
+           #\b
+           8
+           (+ 4 (+ 1 1))
+           (+ 1 2)
+           (+ 4 5)
+           (+ 4 (+ 1 1))
+           9
+           #t
+           #\c))
+        (mytest
+         (tlp2448
+           `#4(() #\d #&(9 () symbols) ())
+           `#\a
+           `#\c
+           `(#\c #\a (+ 4 (+ 1 1)) . #t))
+         '(#\c #\c (+ 4 (+ 1 1))))
+        (mytest
+         (tlp2448
+           `#\b
+           `((+ 4 (+ 1 1)) () () #3(#\a these))
+           `((+ 4 5) these (+ 4 5))
+           `18)
+         '((+ 4 (+ 1 1)) (#\a these these) ((+ 4 5) these (+ 4 5)) 18))))
+     (let ((tlp2485
+             (match-lambda*
+               ((list
+                 (not (not #t))
+                 tlp2450
+                 (or (box
+                      (list
+                       (struct
+                         test-struct
+                         ((vector tlp2451 ...)
+                          #\d
+                          (or tlp2452 tlp2452)
+                          (vector tlp2453 ___)))
+                       (list tlp2455 ..3)
+                       tlp2456))
+                     (box
+                      (list
+                       (struct
+                         test-struct
+                         ((vector tlp2451 ...)
+                          #\d
+                          (or tlp2452 tlp2452)
+                          (vector tlp2453 ___)))
+                       (list tlp2455 ..3)
+                       tlp2456)))
+                 (or (list tlp2457 ...) (list tlp2457 ...)))
+                (list 
+                  tlp2450 
+                  tlp2451 
+                  tlp2452 
+                  tlp2453 
+                  tlp2455 
+                  tlp2456 
+                  tlp2457
+                  ))
+               ((list
+                 (list-rest
+                   (box (list (or _ _) (list) (list tlp2458 ..3)))
+                   tlp2459
+                   (vector tlp2460 ___)
+                   #t)
+                 (and (? test-struct? tlp2470)
+                      (app test-struct-a (not (not #\b)))
+                      (app
+                       test-struct-b
+                       (struct
+                         test-struct
+                         ((list)
+                          (not (not #\b))
+                          'symbols
+                          (or (vector tlp2461 tlp2462 tlp2463 tlp2464)
+                              (vector tlp2461 tlp2462 tlp2463 tlp2464)))))
+                      (app test-struct-c #\d)
+                      (app
+                       test-struct-d
+                       (box
+                        (list (and tlp2466 tlp2467) (vector tlp2468 ___) _))))
+                 (vector tlp2471 ___)
+                 (not (not 9)))
+                (list
+                 tlp2458
+                 tlp2459
+                 tlp2460
+                 tlp2461
+                 tlp2462
+                 tlp2463
+                 tlp2464
+                 tlp2466
+                 tlp2468
+                 tlp2471
+                 )
+                )
+               ((list
+                 (vector
+                   (and (? number? tlp2472) (? even? tlp2473))
+                   (list)
+                   (struct
+                     test-struct
+                     ((vector tlp2474 tlp2475 tlp2476 tlp2477)
+                      (list tlp2478 ___)
+                      (list tlp2479 ..3)
+                      '(+ 1 2)))
+                   (or _ _))
+                 (list tlp2481 ..3)
+                 tlp2482
+                 (and (? number? tlp2483) (? even? tlp2484)))
+                (list
+                 tlp2472
+                 tlp2474
+                 tlp2475
+                 tlp2476
+                 tlp2477
+                 tlp2478
+                 tlp2479
+                 tlp2481
+                 tlp2482
+                 tlp2483)))))
+       (list
+        (mytest
+         (tlp2485
+           `#t
+           `#\d
+           `#&(,inst-struct-name2454 ((+ 1 2) #t #\a) (+ 1 2))
+           `(symbols #\b #\c))
+         '(#\d
+           (#\a symbols 8)
+           #f
+           (1 #\c 4)
+           ((+ 1 2) #t #\a)
+           (+ 1 2)
+           (symbols #\b #\c)))
+        (mytest
+         (tlp2485
+           `(#&(#t () (3 these #t)) #\c #3(are 3 (+ 4 (+ 1 1))) . #t)
+           `,inst-struct-name2469
+           `#3(#f (+ 1 2) #t)
+           `9)
+         '((3 these #t)
+           #\c
+           (are 3 (+ 4 (+ 1 1)))
+           #t
+           (+ 4 5)
+           #t
+           #\d
+           #\b
+           (4 are 1)
+           (#f (+ 1 2) #t)))
+        (mytest
+         (tlp2485
+           `#4(10 () ,inst-struct-name2480 #\b)
+           `(4 #\c (+ 4 5))
+           `#\c
+           `6)
+         '(10
+           (+ 1 2)
+           7
+           are
+           #\b
+           (#\b symbols #\d)
+           (#\d symbols symbols)
+           (4 #\c (+ 4 5))
+           #\c
+           6))))
+
+
+
+(report-errs)
diff --git a/collects/tests/mzscheme/match/rand-list-hist.db b/collects/tests/mzscheme/match/rand-list-hist.db
new file mode 100644
index 0000000000..ebb6ddd7e2
--- /dev/null
+++ b/collects/tests/mzscheme/match/rand-list-hist.db
@@ -0,0 +1,210 @@
+(((pattern
+    (list 8 4 5 1 0 9 7 8)
+    (list 7 5 6 2 6 9 7 5)
+    (list 2 7 7 8 4 7 8 8)
+    (list 6 6 8 2 4 2 3 2)
+    (list 6 0 3 6 9 1 6 8)
+    (list 8 2 2 4 4 9 1 6)
+    (list 7 9 6 3 8 4 1 4)
+    (list 3 2 9 7 4 2 9 0)
+    (list 3 5 8 4 6 7 5 6)
+    (list 1 9 1 5 9 4 3 8)
+    (list 5 0 3 4 6 7 0 9)
+    (list 9 9 8 5 4 0 7 9)
+    (list 5 7 5 3 4 0 9 8)
+    (list 0 2 3 1 7 7 1 2)
+    (list 9 6 8 5 3 9 7 4))
+  ((no-hueristics 230 637)
+   (no-hueristics-size 230 779)
+   (rel-1-5 2936 7453)
+   (rel-1-5-size 141 7608)
+   (inverse-in 2936 7629)
+   (inverse-in-size 141 7465)
+   (tag-negate 166 672)
+   (tag-negate-size 130 744)
+   (new-coupling 130 610)
+   (new-coupling-size 130 529)
+   (member-up-count 130 494)
+   (member-up-count-size 130 661)
+   (memoize-up-count 130 323)
+   (memoize-up-count-size 130 385)))
+ ((pattern
+    (list 3 1 9 0 3 3 2 3)
+    (list 5 7 0 5 4 2 7 7)
+    (list 3 5 8 3 3 3 8 8)
+    (list 0 5 3 6 9 9 3 2)
+    (list 2 2 3 6 7 7 1 5)
+    (list 7 3 2 1 5 9 1 1)
+    (list 6 1 4 9 4 4 9 6)
+    (list 0 2 4 9 3 9 4 6)
+    (list 4 9 4 1 8 5 8 5)
+    (list 8 0 9 5 9 2 6 7)
+    (list 3 2 8 9 9 8 7 9)
+    (list 2 1 0 6 0 6 2 6)
+    (list 7 8 8 6 3 8 3 3)
+    (list 9 2 8 0 4 7 8 9)
+    (list 1 6 8 0 6 5 1 9))
+  ((no-hueristics 232 606)
+   (no-hueristics-size 232 712)
+   (rel-1-5 2677 6863)
+   (rel-1-5-size 148 6688)
+   (inverse-in 2677 6851)
+   (inverse-in-size 148 6709)
+   (tag-negate 267 745)
+   (tag-negate-size 138 774)
+   (new-coupling 183 680)
+   (new-coupling-size 126 574)
+   (member-up-count 183 503)
+   (member-up-count-size 126 673)
+   (memoize-up-count 183 400)
+   (memoize-up-count-size 126 439)))
+ ((pattern
+    (list 5 3 3 2 9 4 5 6)
+    (list 8 0 7 1 9 4 7 1)
+    (list 8 1 1 3 6 8 4 9)
+    (list 0 1 3 8 7 7 4 4)
+    (list 2 0 7 2 4 2 8 5)
+    (list 4 5 8 5 1 5 6 2)
+    (list 9 9 7 5 9 1 7 9)
+    (list 2 0 0 2 0 4 6 2)
+    (list 6 5 6 3 7 5 8 3)
+    (list 2 8 8 6 5 6 8 4)
+    (list 8 5 2 7 9 9 9 1)
+    (list 9 9 3 1 5 2 4 2)
+    (list 7 0 5 7 7 5 0 2)
+    (list 3 1 8 8 7 6 5 5)
+    (list 3 7 5 2 6 4 6 5))
+  ((no-hueristics 226 638)
+   (no-hueristics-size 226 767)
+   (rel-1-5 2912 7461)
+   (rel-1-5-size 144 7648)
+   (inverse-in 2912 7764)
+   (inverse-in-size 144 7537)
+   (tag-negate 200 761)
+   (tag-negate-size 136 703)
+   (new-coupling 151 803)
+   (new-coupling-size 126 629)
+   (member-up-count 151 492)
+   (member-up-count-size 126 668)
+   (memoize-up-count 151 323)
+   (memoize-up-count-size 126 440)))
+ ((pattern
+    (list 4 6 8 6 4 5 0 2)
+    (list 2 6 2 3 6 4 8 4)
+    (list 8 6 2 7 6 2 8 9)
+    (list 2 8 8 4 0 9 8 6)
+    (list 5 8 3 9 5 3 3 7)
+    (list 1 7 1 9 1 1 3 1)
+    (list 9 5 9 5 9 9 5 3)
+    (list 9 3 7 9 4 7 5 1)
+    (list 5 8 1 2 3 6 2 6)
+    (list 4 3 5 7 6 8 9 6)
+    (list 5 0 3 6 9 8 9 8)
+    (list 3 8 9 9 5 4 1 2)
+    (list 5 4 5 0 0 7 7 6)
+    (list 2 2 4 8 3 3 6 8)
+    (list 3 0 5 4 8 6 4 4))
+  ((no-hueristics 224 622)
+   (no-hueristics-size 224 913)
+   (rel-1-5 1285 5020)
+   (rel-1-5-size 144 5252)
+   (inverse-in 1285 4842)
+   (inverse-in-size 144 4863)
+   (tag-negate 166 738)
+   (tag-negate-size 130 646)
+   (new-coupling 130 601)
+   (new-coupling-size 130 571)
+   (member-up-count 130 510)
+   (member-up-count-size 130 605)
+   (memoize-up-count 130 349)
+   (memoize-up-count-size 130 420)))
+ ((pattern
+    (list 9 7 7 1 2 3 7 8)
+    (list 8 0 4 6 2 4 6 7)
+    (list 1 6 8 3 8 7 8 0)
+    (list 8 2 4 4 5 4 5 7)
+    (list 1 4 8 5 9 7 4 7)
+    (list 0 0 6 2 5 2 9 8)
+    (list 8 7 1 8 4 1 0 4)
+    (list 5 4 0 3 8 5 0 1)
+    (list 1 0 9 2 0 3 0 0)
+    (list 3 8 2 0 0 3 0 0)
+    (list 1 3 8 7 5 0 2 0)
+    (list 4 2 5 4 0 5 5 3)
+    (list 8 4 6 8 9 8 0 5)
+    (list 6 4 7 8 7 8 0 0)
+    (list 1 0 8 8 0 2 1 4))
+  ((no-hueristics 226 605)
+   (no-hueristics-size 226 691)
+   (rel-1-5 1307 4804)
+   (rel-1-5-size 135 4836)
+   (inverse-in 1307 4868)
+   (inverse-in-size 135 4859)
+   (tag-negate 186 694)
+   (tag-negate-size 130 675)
+   (new-coupling 130 560)
+   (new-coupling-size 130 615)
+   (member-up-count 130 538)
+   (member-up-count-size 130 619)
+   (memoize-up-count 130 337)
+   (memoize-up-count-size 130 429)))
+ ((pattern
+    (list 4 6 5 7 4 7 6 3)
+    (list 1 7 8 2 4 6 3 8)
+    (list 8 0 1 6 2 8 0 1)
+    (list 9 6 3 4 5 7 4 9)
+    (list 5 1 7 9 8 5 5 2)
+    (list 4 5 6 8 1 9 9 9)
+    (list 1 0 8 5 0 8 7 2)
+    (list 6 2 8 1 1 2 3 6)
+    (list 3 2 7 4 9 4 8 4)
+    (list 9 4 4 0 5 3 2 6)
+    (list 5 0 2 6 8 1 8 6)
+    (list 5 6 9 6 0 2 4 5)
+    (list 4 3 1 4 8 9 0 7)
+    (list 5 4 0 0 0 2 7 5)
+    (list 2 1 3 2 4 1 8 1))
+  ((no-hueristics 228 594)
+   (no-hueristics-size 228 689)
+   (rel-1-5 2693 9171)
+   (rel-1-5-size 140 9526)
+   (inverse-in 2693 9328)
+   (inverse-in-size 140 9192)
+   (tag-negate 166 734)
+   (tag-negate-size 130 725)
+   (new-coupling 130 567)
+   (new-coupling-size 130 592)
+   (member-up-count 130 473)
+   (member-up-count-size 130 644)
+   (memoize-up-count 130 382)
+   (memoize-up-count-size 130 426)))
+ ((pattern
+    (list 2 4 6 5 1 7 1 0)
+    (list 3 7 3 4 5 7 7 4)
+    (list 3 6 9 0 5 9 6 5)
+    (list 4 6 8 0 9 0 6 3)
+    (list 4 2 8 5 2 9 5 5)
+    (list 8 0 1 3 8 0 7 3)
+    (list 7 8 6 4 9 2 2 5)
+    (list 0 0 7 9 0 3 2 4)
+    (list 7 2 1 9 3 6 4 1)
+    (list 8 5 6 6 8 3 2 5)
+    (list 3 8 1 2 0 3 9 2)
+    (list 3 6 2 5 1 6 1 9)
+    (list 9 2 8 2 0 5 6 9)
+    (list 2 2 7 0 8 9 7 1)
+    (list 9 9 6 9 4 7 4 8))
+  ((no-hueristics 224 617)
+   (no-hueristics-size 224 721)
+   (rel-1-5 3288 9496)
+   (rel-1-5-size 142 8903)
+   (inverse-in 3288 9587)
+   (inverse-in-size 142 9959)
+   (tag-negate 230 774)
+   (tag-negate-size 136 745)
+   (new-coupling 221 607)
+   (new-coupling-size 128 675)
+   (member-up-count 221 566)
+   (member-up-count-size 128 700)
+   (memoize-up-count 221 382)
+   (memoize-up-count-size 128 459))))
diff --git a/collects/tests/mzscheme/match/rand-list-perf.ss b/collects/tests/mzscheme/match/rand-list-perf.ss
new file mode 100644
index 0000000000..7ae8e4bcff
--- /dev/null
+++ b/collects/tests/mzscheme/match/rand-list-perf.ss
@@ -0,0 +1,344 @@
+(load-relative "../loadtest.ss")
+(SECTION 'MATCH-PERFORMANCE)
+
+(require (lib "pretty.ss"))
+(require-for-syntax (lib "pretty.ss"))
+(require (lib "include.ss"))
+(require (lib "plt-match.ss"))
+(require (lib "list.ss"))
+
+(include "match-compile-perf.scm")
+
+(match-performance-test
+ (file
+  ;; this is the name of the underlying file that handles the 
+  ;; persistance of test data between invocations of this performance test
+  ;; Each time a test is run one has the option to only compare current
+  ;; data with previous data or one can modify the database file by appending
+  ;; hopefullly improved data.
+  ;; For most purposes it is advisable not to alter the database.
+  (name "rand-list-hist.db")
+  ;; onlly one of the following options is allowed
+  ;; write-new   ;; uncomment to write an new test database 
+                 ;; (this requires the whole-list display option below)
+  ;; add-results ;; uncomment to append the results of the current test
+                 ;; to the database
+  )
+ (tag
+  ;; only one option is allowed 
+  ;; this is the name of the tag placed on data generted by this test
+  current
+  ;; other options are 
+  ;; date ;; to tag new date with a date
+  ;; time ;; to tag new date with a time
+  )
+ (display
+  ;; only one option is allowed
+  ;; remember negative -> good  and positive -> bad 
+  ;; positive-change       ;; displays increases in node counts
+  ;; other options are:
+  ;; negative-change    ;; displays decreases in node counts
+  ;; change             ;; to display any change in node count
+  percent-change             ;; to display any change in node count
+  ;; rt-percent-change             ;; to display any change in node count
+  ;; rt-positive-change ;; same as above but for real compile time
+  ;; rt-negative-change
+  ;; rt-change
+  ;; whole-list         ;; display whole database line with current test appended
+  ;; last-two ;; display only the current result with the previous result
+  )
+ (patterns
+
+(pattern
+   (list 2 4 6 5 1 7 1 0)
+   (list 3 7 3 4 5 7 7 4)
+   (list 3 6 9 0 5 9 6 5)
+   (list 4 6 8 0 9 0 6 3)
+   (list 4 2 8 5 2 9 5 5)
+   (list 8 0 1 3 8 0 7 3)
+   (list 7 8 6 4 9 2 2 5)
+   (list 0 0 7 9 0 3 2 4)
+   (list 7 2 1 9 3 6 4 1)
+   (list 8 5 6 6 8 3 2 5)
+   (list 3 8 1 2 0 3 9 2)
+   (list 3 6 2 5 1 6 1 9)
+   (list 9 2 8 2 0 5 6 9)
+   (list 2 2 7 0 8 9 7 1)
+   (list 9 9 6 9 4 7 4 8))
+ (pattern
+   (list 4 6 5 7 4 7 6 3)
+   (list 1 7 8 2 4 6 3 8)
+   (list 8 0 1 6 2 8 0 1)
+   (list 9 6 3 4 5 7 4 9)
+   (list 5 1 7 9 8 5 5 2)
+   (list 4 5 6 8 1 9 9 9)
+   (list 1 0 8 5 0 8 7 2)
+   (list 6 2 8 1 1 2 3 6)
+   (list 3 2 7 4 9 4 8 4)
+   (list 9 4 4 0 5 3 2 6)
+   (list 5 0 2 6 8 1 8 6)
+   (list 5 6 9 6 0 2 4 5)
+   (list 4 3 1 4 8 9 0 7)
+   (list 5 4 0 0 0 2 7 5)
+   (list 2 1 3 2 4 1 8 1))
+ (pattern
+   (list 9 7 7 1 2 3 7 8)
+   (list 8 0 4 6 2 4 6 7)
+   (list 1 6 8 3 8 7 8 0)
+   (list 8 2 4 4 5 4 5 7)
+   (list 1 4 8 5 9 7 4 7)
+   (list 0 0 6 2 5 2 9 8)
+   (list 8 7 1 8 4 1 0 4)
+   (list 5 4 0 3 8 5 0 1)
+   (list 1 0 9 2 0 3 0 0)
+   (list 3 8 2 0 0 3 0 0)
+   (list 1 3 8 7 5 0 2 0)
+   (list 4 2 5 4 0 5 5 3)
+   (list 8 4 6 8 9 8 0 5)
+   (list 6 4 7 8 7 8 0 0)
+   (list 1 0 8 8 0 2 1 4))
+ (pattern
+   (list 4 6 8 6 4 5 0 2)
+   (list 2 6 2 3 6 4 8 4)
+   (list 8 6 2 7 6 2 8 9)
+   (list 2 8 8 4 0 9 8 6)
+   (list 5 8 3 9 5 3 3 7)
+   (list 1 7 1 9 1 1 3 1)
+   (list 9 5 9 5 9 9 5 3)
+   (list 9 3 7 9 4 7 5 1)
+   (list 5 8 1 2 3 6 2 6)
+   (list 4 3 5 7 6 8 9 6)
+   (list 5 0 3 6 9 8 9 8)
+   (list 3 8 9 9 5 4 1 2)
+   (list 5 4 5 0 0 7 7 6)
+   (list 2 2 4 8 3 3 6 8)
+   (list 3 0 5 4 8 6 4 4))
+ (pattern
+   (list 5 3 3 2 9 4 5 6)
+   (list 8 0 7 1 9 4 7 1)
+   (list 8 1 1 3 6 8 4 9)
+   (list 0 1 3 8 7 7 4 4)
+   (list 2 0 7 2 4 2 8 5)
+   (list 4 5 8 5 1 5 6 2)
+   (list 9 9 7 5 9 1 7 9)
+   (list 2 0 0 2 0 4 6 2)
+   (list 6 5 6 3 7 5 8 3)
+   (list 2 8 8 6 5 6 8 4)
+   (list 8 5 2 7 9 9 9 1)
+   (list 9 9 3 1 5 2 4 2)
+   (list 7 0 5 7 7 5 0 2)
+   (list 3 1 8 8 7 6 5 5)
+   (list 3 7 5 2 6 4 6 5))
+ (pattern
+   (list 3 1 9 0 3 3 2 3)
+   (list 5 7 0 5 4 2 7 7)
+   (list 3 5 8 3 3 3 8 8)
+   (list 0 5 3 6 9 9 3 2)
+   (list 2 2 3 6 7 7 1 5)
+   (list 7 3 2 1 5 9 1 1)
+   (list 6 1 4 9 4 4 9 6)
+   (list 0 2 4 9 3 9 4 6)
+   (list 4 9 4 1 8 5 8 5)
+   (list 8 0 9 5 9 2 6 7)
+   (list 3 2 8 9 9 8 7 9)
+   (list 2 1 0 6 0 6 2 6)
+   (list 7 8 8 6 3 8 3 3)
+   (list 9 2 8 0 4 7 8 9)
+   (list 1 6 8 0 6 5 1 9))
+ (pattern
+   (list 8 4 5 1 0 9 7 8)
+   (list 7 5 6 2 6 9 7 5)
+   (list 2 7 7 8 4 7 8 8)
+   (list 6 6 8 2 4 2 3 2)
+   (list 6 0 3 6 9 1 6 8)
+   (list 8 2 2 4 4 9 1 6)
+   (list 7 9 6 3 8 4 1 4)
+   (list 3 2 9 7 4 2 9 0)
+   (list 3 5 8 4 6 7 5 6)
+   (list 1 9 1 5 9 4 3 8)
+   (list 5 0 3 4 6 7 0 9)
+   (list 9 9 8 5 4 0 7 9)
+   (list 5 7 5 3 4 0 9 8)
+   (list 0 2 3 1 7 7 1 2)
+   (list 9 6 8 5 3 9 7 4))
+
+))
+
+(report-errs)
+
+; (define-syntax test-mac
+;   (syntax-rules ()
+;     ((id to-test eval-to)
+;      (with-handlers ([(lambda exn #t)
+;                       (lambda (exn) (failed-test (exn-message exn) 
+;                                                   (quote to-test)
+;                                                  '() eval-to))])
+;                     (let ((res to-test))
+;                       (if (equal? res eval-to)
+;                           (begin (write res) #t)
+;                           (failed-test '() (quote to-test) res eval-to)))))))
+
+
+
+; (define (failed-test exn-msg test-code result should-have-been)
+;   `((Test-Failure)
+;     (Code ,test-code)
+;     (Expected-Result ,should-have-been)
+;     ,(if (null? exn-msg) 
+;          `(Actual-Result ,result)
+;          `(Exception ,exn-msg))))
+
+
+; (define-syntax mytest
+;   (lambda (stx)
+;     (syntax-case stx ()
+;       ((_ t result)
+;        #`(test #t #,(syntax/loc stx (lambda () (test-mac t result)))))))) 
+
+
+; (define-syntax pattern-test-gen
+;   (lambda (stx)
+;     (let ((helper (lambda (stx)
+;                     (syntax-case stx (pattern)
+;                       ((pattern pats ...)
+;                        (let ((patter (map 
+;                                       (lambda (x)
+;                                         (syntax-case x (list)
+;                                           ((list a b c d e f g h) 
+;                                            (syntax ((list a b c d e f g z) z)))))
+;                                       (syntax->list (syntax (pats ...))))))
+;                        #`(let ((matcher 
+;                                 (match-lambda #,@patter)))
+                           
+;                            #,@(map (lambda (x)
+;                                      (let ((res (syntax-case x (list)
+;                                                   ((list a b c d e f g z) (syntax z)))))
+;                                        (quasisyntax/loc 
+;                                         x
+;                                         (mytest
+;                                          (matcher #,x)
+;                                          #,res))))
+;                                    (syntax->list (syntax (pats ...)))))))))))
+;       (syntax-case stx ()
+;         ((_ ptg ...)
+;          #`(begin #,@(map helper (syntax->list (syntax (ptg ...))))))))))
+
+
+
+
+; (pattern-test-gen
+
+; (pattern
+;    (list 2 4 6 5 1 7 1 0)
+;    (list 3 7 3 4 5 7 7 4)
+;    (list 3 6 9 0 5 9 6 5)
+;    (list 4 6 8 0 9 0 6 3)
+;    (list 4 2 8 5 2 9 5 5)
+;    (list 8 0 1 3 8 0 7 3)
+;    (list 7 8 6 4 9 2 2 5)
+;    (list 0 0 7 9 0 3 2 4)
+;    (list 7 2 1 9 3 6 4 1)
+;    (list 8 5 6 6 8 3 2 5)
+;    (list 3 8 1 2 0 3 9 2)
+;    (list 3 6 2 5 1 6 1 9)
+;    (list 9 2 8 2 0 5 6 9)
+;    (list 2 2 7 0 8 9 7 1)
+;    (list 9 9 6 9 4 7 4 8))
+;  (pattern
+;    (list 4 6 5 7 4 7 6 3)
+;    (list 1 7 8 2 4 6 3 8)
+;    (list 8 0 1 6 2 8 0 1)
+;    (list 9 6 3 4 5 7 4 9)
+;    (list 5 1 7 9 8 5 5 2)
+;    (list 4 5 6 8 1 9 9 9)
+;    (list 1 0 8 5 0 8 7 2)
+;    (list 6 2 8 1 1 2 3 6)
+;    (list 3 2 7 4 9 4 8 4)
+;    (list 9 4 4 0 5 3 2 6)
+;    (list 5 0 2 6 8 1 8 6)
+;    (list 5 6 9 6 0 2 4 5)
+;    (list 4 3 1 4 8 9 0 7)
+;    (list 5 4 0 0 0 2 7 5)
+;    (list 2 1 3 2 4 1 8 1))
+;  (pattern
+;    (list 9 7 7 1 2 3 7 8)
+;    (list 8 0 4 6 2 4 6 7)
+;    (list 1 6 8 3 8 7 8 0)
+;    (list 8 2 4 4 5 4 5 7)
+;    (list 1 4 8 5 9 7 4 7)
+;    (list 0 0 6 2 5 2 9 8)
+;    (list 8 7 1 8 4 1 0 4)
+;    (list 5 4 0 3 8 5 0 1)
+;    (list 1 0 9 2 0 3 0 0)
+;    (list 3 8 2 0 0 3 0 0)
+;    (list 1 3 8 7 5 0 2 0)
+;    (list 4 2 5 4 0 5 5 3)
+;    (list 8 4 6 8 9 8 0 5)
+;    (list 6 4 7 8 7 8 0 0)
+;    (list 1 0 8 8 0 2 1 4))
+;  (pattern
+;    (list 4 6 8 6 4 5 0 2)
+;    (list 2 6 2 3 6 4 8 4)
+;    (list 8 6 2 7 6 2 8 9)
+;    (list 2 8 8 4 0 9 8 6)
+;    (list 5 8 3 9 5 3 3 7)
+;    (list 1 7 1 9 1 1 3 1)
+;    (list 9 5 9 5 9 9 5 3)
+;    (list 9 3 7 9 4 7 5 1)
+;    (list 5 8 1 2 3 6 2 6)
+;    (list 4 3 5 7 6 8 9 6)
+;    (list 5 0 3 6 9 8 9 8)
+;    (list 3 8 9 9 5 4 1 2)
+;    (list 5 4 5 0 0 7 7 6)
+;    (list 2 2 4 8 3 3 6 8)
+;    (list 3 0 5 4 8 6 4 4))
+;  (pattern
+;    (list 5 3 3 2 9 4 5 6)
+;    (list 8 0 7 1 9 4 7 1)
+;    (list 8 1 1 3 6 8 4 9)
+;    (list 0 1 3 8 7 7 4 4)
+;    (list 2 0 7 2 4 2 8 5)
+;    (list 4 5 8 5 1 5 6 2)
+;    (list 9 9 7 5 9 1 7 9)
+;    (list 2 0 0 2 0 4 6 2)
+;    (list 6 5 6 3 7 5 8 3)
+;    (list 2 8 8 6 5 6 8 4)
+;    (list 8 5 2 7 9 9 9 1)
+;    (list 9 9 3 1 5 2 4 2)
+;    (list 7 0 5 7 7 5 0 2)
+;    (list 3 1 8 8 7 6 5 5)
+;    (list 3 7 5 2 6 4 6 5))
+;  (pattern
+;    (list 3 1 9 0 3 3 2 3)
+;    (list 5 7 0 5 4 2 7 7)
+;    (list 3 5 8 3 3 3 8 8)
+;    (list 0 5 3 6 9 9 3 2)
+;    (list 2 2 3 6 7 7 1 5)
+;    (list 7 3 2 1 5 9 1 1)
+;    (list 6 1 4 9 4 4 9 6)
+;    (list 0 2 4 9 3 9 4 6)
+;    (list 4 9 4 1 8 5 8 5)
+;    (list 8 0 9 5 9 2 6 7)
+;    (list 3 2 8 9 9 8 7 9)
+;    (list 2 1 0 6 0 6 2 6)
+;    (list 7 8 8 6 3 8 3 3)
+;    (list 9 2 8 0 4 7 8 9)
+;    (list 1 6 8 0 6 5 1 9))
+;  (pattern
+;    (list 8 4 5 1 0 9 7 8)
+;    (list 7 5 6 2 6 9 7 5)
+;    (list 2 7 7 8 4 7 8 8)
+;    (list 6 6 8 2 4 2 3 2)
+;    (list 6 0 3 6 9 1 6 8)
+;    (list 8 2 2 4 4 9 1 6)
+;    (list 7 9 6 3 8 4 1 4)
+;    (list 3 2 9 7 4 2 9 0)
+;    (list 3 5 8 4 6 7 5 6)
+;    (list 1 9 1 5 9 4 3 8)
+;    (list 5 0 3 4 6 7 0 9)
+;    (list 9 9 8 5 4 0 7 9)
+;    (list 5 7 5 3 4 0 9 8)
+;    (list 0 2 3 1 7 7 1 2)
+;    (list 9 6 8 5 3 9 7 4))
+
+;  )
\ No newline at end of file
diff --git a/collects/tests/mzscheme/match/rand-short-list-hist.db b/collects/tests/mzscheme/match/rand-short-list-hist.db
new file mode 100644
index 0000000000..20b175cd02
--- /dev/null
+++ b/collects/tests/mzscheme/match/rand-short-list-hist.db
@@ -0,0 +1,282 @@
+(((pattern
+    (list 3 5 9 8)
+    (list 0 2 3 1)
+    (list 2 4 3 9)
+    (list 0 4 9 5)
+    (list 9 3 0 2)
+    (list 0 9 6 8)
+    (list 5 6 2 3))
+  ((no-hueristics 54 66)
+   (no-hueristics-size 54 70)
+   (rel-1-5 68 95)
+   (rel-1-5-size 33 95)
+   (inverse-in 68 101)
+   (inverse-in-size 33 123)
+   (tag-negate 44 72)
+   (tag-negate-size 34 72)
+   (new-coupling 34 43)
+   (new-coupling-size 34 72)
+   (member-up-count 34 68)
+   (member-up-count-size 34 68)
+   (memoize-up-count 34 38)
+   (memoize-up-count-size 34 63)
+   (currnet 34 108)))
+ ((pattern
+    (list 0 5 3 4)
+    (list 9 6 1 4)
+    (list 9 0 5 6)
+    (list 4 9 2 6)
+    (list 3 8 3 8)
+    (list 5 5 3 3)
+    (list 8 7 9 0)
+    (list 7 6 1 7)
+    (list 3 4 4 4)
+    (list 1 5 9 2)
+    (list 7 6 0 4)
+    (list 6 2 0 1))
+  ((no-hueristics 90 148)
+   (no-hueristics-size 90 155)
+   (rel-1-5 275 457)
+   (rel-1-5-size 64 415)
+   (inverse-in 275 454)
+   (inverse-in-size 64 421)
+   (tag-negate 89 170)
+   (tag-negate-size 63 170)
+   (new-coupling 68 134)
+   (new-coupling-size 51 146)
+   (member-up-count 68 118)
+   (member-up-count-size 51 117)
+   (memoize-up-count 68 109)
+   (memoize-up-count-size 51 145)
+   (currnet 63 163)))
+ ((pattern
+    (list 6 5 0 1)
+    (list 4 0 8 4)
+    (list 6 1 2 1)
+    (list 6 6 3 1)
+    (list 8 0 8 1)
+    (list 4 3 1 7)
+    (list 3 2 6 1)
+    (list 5 4 2 3)
+    (list 9 2 6 5)
+    (list 4 4 1 3)
+    (list 8 3 4 4)
+    (list 9 0 7 9))
+  ((no-hueristics 86 146)
+   (no-hueristics-size 86 152)
+   (rel-1-5 100 277)
+   (rel-1-5-size 51 263)
+   (inverse-in 100 268)
+   (inverse-in-size 51 269)
+   (tag-negate 69 140)
+   (tag-negate-size 56 138)
+   (new-coupling 60 137)
+   (new-coupling-size 52 146)
+   (member-up-count 60 93)
+   (member-up-count-size 52 93)
+   (memoize-up-count 60 105)
+   (memoize-up-count-size 52 147)
+   (currnet 56 152)))
+ ((pattern
+    (list 5 9 0 5)
+    (list 8 6 3 6)
+    (list 3 2 4 2)
+    (list 3 2 4 7)
+    (list 3 4 3 0)
+    (list 2 0 9 9)
+    (list 7 3 8 1))
+  ((no-hueristics 50 65)
+   (no-hueristics-size 50 71)
+   (rel-1-5 48 86)
+   (rel-1-5-size 31 91)
+   (inverse-in 48 85)
+   (inverse-in-size 31 88)
+   (tag-negate 44 48)
+   (tag-negate-size 34 72)
+   (new-coupling 34 73)
+   (new-coupling-size 34 109)
+   (member-up-count 34 71)
+   (member-up-count-size 34 66)
+   (memoize-up-count 34 36)
+   (memoize-up-count-size 34 33)
+   (currnet 34 52)))
+ ((pattern
+    (list 1 2 1 7)
+    (list 1 5 8 9)
+    (list 2 9 0 1)
+    (list 9 4 9 8)
+    (list 5 0 2 1)
+    (list 8 7 3 8)
+    (list 8 7 9 6)
+    (list 9 0 8 0)
+    (list 2 9 8 5)
+    (list 4 6 5 9)
+    (list 7 7 2 6)
+    (list 1 3 7 9))
+  ((no-hueristics 84 142)
+   (no-hueristics-size 84 148)
+   (rel-1-5 156 336)
+   (rel-1-5-size 52 369)
+   (inverse-in 156 349)
+   (inverse-in-size 52 347)
+   (tag-negate 64 161)
+   (tag-negate-size 54 133)
+   (new-coupling 54 102)
+   (new-coupling-size 54 171)
+   (member-up-count 54 126)
+   (member-up-count-size 54 116)
+   (memoize-up-count 54 98)
+   (memoize-up-count-size 54 145)
+   (currnet 54 147)))
+ ((pattern
+    (list 7 8 8 3)
+    (list 2 2 5 1)
+    (list 4 0 2 9)
+    (list 0 7 8 1)
+    (list 4 9 0 7)
+    (list 4 9 1 0)
+    (list 6 7 1 9)
+    (list 8 0 1 8)
+    (list 9 1 1 1)
+    (list 6 8 5 0)
+    (list 8 9 1 0)
+    (list 6 2 1 2))
+  ((no-hueristics 86 122)
+   (no-hueristics-size 86 147)
+   (rel-1-5 157 395)
+   (rel-1-5-size 58 383)
+   (inverse-in 157 337)
+   (inverse-in-size 58 342)
+   (tag-negate 68 161)
+   (tag-negate-size 54 161)
+   (new-coupling 54 132)
+   (new-coupling-size 54 141)
+   (member-up-count 54 93)
+   (member-up-count-size 54 87)
+   (memoize-up-count 54 87)
+   (memoize-up-count-size 54 140)
+   (currnet 54 147)))
+ ((pattern
+    (list 3 4 4 2)
+    (list 9 1 3 0)
+    (list 5 9 3 7)
+    (list 9 7 1 9)
+    (list 3 4 8 2)
+    (list 4 7 4 0)
+    (list 0 9 7 0))
+  ((no-hueristics 52 64)
+   (no-hueristics 52 68)
+   (no-hueristics-size 52 65)
+   (no-hueristics-size 52 39)
+   (rel-1-5 65 92)
+   (rel-1-5 65 110)
+   (rel-1-5-size 31 133)
+   (rel-1-5-size 31 95)
+   (inverse-in 65 139)
+   (inverse-in 65 95)
+   (inverse-in-size 31 121)
+   (inverse-in-size 31 97)
+   (tag-negate 46 76)
+   (tag-negate 46 74)
+   (tag-negate-size 31 76)
+   (tag-negate-size 31 74)
+   (new-coupling 33 72)
+   (new-coupling 33 70)
+   (new-coupling-size 31 73)
+   (new-coupling-size 31 71)
+   (member-up-count 33 77)
+   (member-up-count 33 76)
+   (member-up-count-size 31 66)
+   (member-up-count-size 31 67)
+   (memoize-up-count 33 68)
+   (memoize-up-count 33 58)
+   (memoize-up-count-size 31 113)
+   (memoize-up-count-size 31 33)
+   (currnet 31 99)
+   (currnet 31 87)))
+ ((pattern
+    (list 0 1 0 9)
+    (list 6 2 6 0)
+    (list 1 4 2 3)
+    (list 3 5 3 0)
+    (list 5 3 5 7)
+    (list 8 3 5 9)
+    (list 1 4 6 2)
+    (list 1 7 4 2)
+    (list 0 4 3 7)
+    (list 8 0 9 0)
+    (list 4 3 3 7)
+    (list 8 8 9 5))
+  ((no-hueristics 86 146)
+   (no-hueristics 86 144)
+   (no-hueristics-size 86 148)
+   (no-hueristics-size 86 121)
+   (rel-1-5 147 382)
+   (rel-1-5 147 406)
+   (rel-1-5-size 56 329)
+   (rel-1-5-size 56 376)
+   (inverse-in 147 415)
+   (inverse-in 147 342)
+   (inverse-in-size 56 371)
+   (inverse-in-size 56 334)
+   (tag-negate 64 160)
+   (tag-negate 64 161)
+   (tag-negate-size 54 158)
+   (tag-negate-size 54 162)
+   (new-coupling 54 128)
+   (new-coupling 54 103)
+   (new-coupling-size 54 215)
+   (new-coupling-size 54 321)
+   (member-up-count 54 132)
+   (member-up-count 54 128)
+   (member-up-count-size 54 116)
+   (member-up-count-size 54 113)
+   (memoize-up-count 54 103)
+   (memoize-up-count 54 68)
+   (memoize-up-count-size 54 62)
+   (memoize-up-count-size 54 145)
+   (currnet 54 135)
+   (currnet 54 114)))
+ ((pattern
+    (list 9 8 7 9)
+    (list 6 9 4 3)
+    (list 6 3 8 7)
+    (list 5 2 8 3)
+    (list 0 3 9 9)
+    (list 7 5 1 7)
+    (list 3 7 7 0)
+    (list 1 7 3 0)
+    (list 7 0 9 3)
+    (list 9 3 8 8)
+    (list 9 6 7 6)
+    (list 9 7 9 1))
+  ((no-hueristics 88 142)
+   (no-hueristics 88 117)
+   (no-hueristics-size 88 144)
+   (no-hueristics-size 88 118)
+   (rel-1-5 147 392)
+   (rel-1-5 147 355)
+   (rel-1-5-size 57 352)
+   (rel-1-5-size 57 355)
+   (inverse-in 147 363)
+   (inverse-in 147 371)
+   (inverse-in-size 57 360)
+   (inverse-in-size 57 331)
+   (tag-negate 62 162)
+   (tag-negate 62 133)
+   (tag-negate-size 52 163)
+   (tag-negate-size 52 134)
+   (new-coupling 52 103)
+   (new-coupling 52 100)
+   (new-coupling-size 52 220)
+   (new-coupling-size 52 219)
+   (member-up-count 52 85)
+   (member-up-count 52 101)
+   (member-up-count-size 52 86)
+   (member-up-count-size 52 88)
+   (memoize-up-count 52 82)
+   (memoize-up-count 52 101)
+   (memoize-up-count-size 52 62)
+   (memoize-up-count-size 52 87)
+   (currnet 52 134)
+   (currnet 52 120))))
diff --git a/collects/tests/mzscheme/match/rand-vec-hist.db b/collects/tests/mzscheme/match/rand-vec-hist.db
new file mode 100644
index 0000000000..41d62371cd
--- /dev/null
+++ b/collects/tests/mzscheme/match/rand-vec-hist.db
@@ -0,0 +1,434 @@
+(((pattern
+    (vector 2 3 8 1 1 3 0 9)
+    (vector 1 1 4 7 2 9 8 6)
+    (vector 2 8 7 3 5 0 0 1)
+    (vector 4 1 3 0 0 8 6 2)
+    (vector 1 4 5 4 7 8 6 0)
+    (vector 1 0 9 3 9 7 1 4)
+    (vector 8 0 7 5 0 7 6 4)
+    (vector 0 1 6 2 9 2 6 2)
+    (vector 8 4 7 7 2 3 7 3)
+    (vector 3 9 8 4 8 9 8 6)
+    (vector 1 7 4 1 7 0 7 7)
+    (vector 2 6 2 3 0 8 6 9)
+    (vector 2 5 6 6 0 6 9 5)
+    (vector 7 7 9 5 8 0 2 1)
+    (vector 7 6 2 4 8 2 4 0))
+  ((no-hueristics 115 258)
+   (no-hueristics-size 115 286)
+   (rel-1-5 1926 3388)
+   (rel-1-5-size 129 3162)
+   (inverse-in 1926 3962)
+   (inverse-in-size 129 3149)
+   (tag-negate 141 312)
+   (tag-negate-size 123 310)
+   (new-coupling 143 256)
+   (new-coupling-size 119 248)
+   (member-up-count 143 216)
+   (member-up-count-size 119 248)
+   (memoize-up-count 143 202)
+   (memoize-up-count-size 119 170)
+   (new-no-hueristics 115 258)))
+ ((pattern
+    (vector 3 1 5 5 4 5 8 1)
+    (vector 9 9 6 7 2 4 5 1)
+    (vector 2 1 9 1 4 2 4 8)
+    (vector 1 2 8 3 6 4 2 9)
+    (vector 5 7 7 2 4 7 3 5)
+    (vector 6 1 4 0 8 2 4 2)
+    (vector 5 5 4 9 8 8 7 1)
+    (vector 0 7 4 7 3 6 8 1)
+    (vector 5 7 3 1 4 8 8 3)
+    (vector 2 3 3 0 5 7 2 0)
+    (vector 5 8 1 3 6 1 6 9)
+    (vector 8 1 8 2 9 8 3 7)
+    (vector 6 8 0 2 6 9 5 8)
+    (vector 4 1 0 9 0 5 1 5)
+    (vector 3 4 0 2 5 9 3 4))
+  ((no-hueristics 116 263)
+   (no-hueristics-size 116 265)
+   (rel-1-5 2686 3644)
+   (rel-1-5-size 127 3494)
+   (inverse-in 2686 4891)
+   (inverse-in-size 127 3466)
+   (tag-negate 123 293)
+   (tag-negate-size 123 294)
+   (new-coupling 123 232)
+   (new-coupling-size 123 263)
+   (member-up-count 123 202)
+   (member-up-count-size 123 196)
+   (memoize-up-count 123 155)
+   (memoize-up-count-size 123 154)
+   (new-no-hueristics 116 257)))
+ ((pattern
+    (vector 4 8 2 4 0 8 3 4)
+    (vector 3 7 6 2 5 7 1 0)
+    (vector 6 7 5 5 2 0 8 1)
+    (vector 7 5 2 4 6 7 4 0)
+    (vector 5 8 6 8 9 9 2 2)
+    (vector 6 1 6 3 0 9 3 6)
+    (vector 6 0 4 1 0 4 4 9)
+    (vector 9 7 5 5 6 9 7 4)
+    (vector 8 4 2 7 5 6 1 4)
+    (vector 7 7 7 7 6 1 6 3)
+    (vector 3 0 6 4 4 0 3 6)
+    (vector 7 1 3 6 0 3 0 0)
+    (vector 7 2 9 2 8 2 8 6)
+    (vector 9 6 5 6 9 1 1 2)
+    (vector 3 9 6 8 9 2 6 9))
+  ((no-hueristics 115 262)
+   (no-hueristics-size 115 291)
+   (rel-1-5 1827 3165)
+   (rel-1-5-size 134 2703)
+   (inverse-in 1827 3553)
+   (inverse-in-size 134 2538)
+   (tag-negate 184 313)
+   (tag-negate-size 130 313)
+   (new-coupling 182 255)
+   (new-coupling-size 119 283)
+   (member-up-count 182 219)
+   (member-up-count-size 119 254)
+   (memoize-up-count 182 174)
+   (memoize-up-count-size 119 205)
+   (new-no-hueristics 115 287)))
+ ((pattern
+    (vector 1 3 5 9 9 7 0 7)
+    (vector 5 0 0 8 2 1 6 6)
+    (vector 2 5 0 9 6 5 1 0)
+    (vector 1 9 7 7 7 6 5 0)
+    (vector 2 0 2 1 7 2 0 4)
+    (vector 4 2 5 6 3 1 2 8)
+    (vector 8 2 7 4 7 0 4 1)
+    (vector 0 3 8 7 9 5 9 1)
+    (vector 6 1 4 5 4 6 2 0)
+    (vector 8 7 7 4 0 9 2 8)
+    (vector 2 1 2 1 2 8 4 4)
+    (vector 1 3 3 2 8 2 6 6)
+    (vector 4 2 4 0 9 6 0 9)
+    (vector 5 7 3 5 9 5 3 1)
+    (vector 7 7 4 9 7 9 5 8))
+  ((no-hueristics 114 281)
+   (no-hueristics-size 114 257)
+   (rel-1-5 2900 4304)
+   (rel-1-5-size 135 4518)
+   (inverse-in 2900 5796)
+   (inverse-in-size 135 4268)
+   (tag-negate 123 297)
+   (tag-negate-size 123 263)
+   (new-coupling 123 231)
+   (new-coupling-size 123 229)
+   (member-up-count 123 229)
+   (member-up-count-size 123 196)
+   (memoize-up-count 123 182)
+   (memoize-up-count-size 123 154)
+   (new-no-hueristics 114 254)))
+ ((pattern
+    (vector 4 2 4 5 4 4 5 8)
+    (vector 4 7 9 7 5 3 4 9)
+    (vector 5 3 6 4 9 6 5 7)
+    (vector 9 9 2 3 8 6 3 2)
+    (vector 1 9 7 7 5 4 5 2)
+    (vector 1 6 9 9 1 6 8 6)
+    (vector 9 4 1 8 0 8 8 2)
+    (vector 9 0 7 9 8 0 1 9)
+    (vector 1 0 8 8 5 3 0 8)
+    (vector 2 2 7 3 0 6 0 9)
+    (vector 2 3 9 5 1 9 9 2)
+    (vector 9 6 2 8 6 5 9 9)
+    (vector 6 8 7 3 3 0 1 5)
+    (vector 4 9 9 4 7 9 5 1)
+    (vector 2 6 6 5 6 5 9 5))
+  ((no-hueristics 114 257)
+   (no-hueristics-size 114 259)
+   (rel-1-5 3687 5037)
+   (rel-1-5-size 142 4924)
+   (inverse-in 3687 6196)
+   (inverse-in-size 142 5489)
+   (tag-negate 123 292)
+   (tag-negate-size 123 293)
+   (new-coupling 123 232)
+   (new-coupling-size 123 231)
+   (member-up-count 123 198)
+   (member-up-count-size 123 229)
+   (memoize-up-count 123 149)
+   (memoize-up-count-size 123 148)
+   (new-no-hueristics 114 256)))
+ ((pattern
+    (vector 5 4 8 9 6 9 2 8)
+    (vector 8 1 9 0 6 6 4 4)
+    (vector 7 8 4 3 5 7 7 4)
+    (vector 1 2 0 5 0 1 8 5)
+    (vector 5 6 5 3 7 9 1 6)
+    (vector 0 3 8 6 1 3 1 0)
+    (vector 3 7 3 8 5 3 4 6)
+    (vector 5 6 3 6 7 1 3 4)
+    (vector 9 0 7 9 9 1 7 0)
+    (vector 6 5 6 7 0 9 8 3)
+    (vector 7 1 3 4 4 8 2 0)
+    (vector 6 5 8 4 9 1 0 0)
+    (vector 2 8 9 1 1 6 1 7)
+    (vector 4 0 6 4 9 4 0 8)
+    (vector 8 3 4 2 3 6 4 0))
+  ((no-hueristics 116 289)
+   (no-hueristics-size 116 288)
+   (rel-1-5 3525 4863)
+   (rel-1-5-size 141 4713)
+   (inverse-in 3525 5727)
+   (inverse-in-size 141 6082)
+   (tag-negate 123 296)
+   (tag-negate-size 123 290)
+   (new-coupling 123 261)
+   (new-coupling-size 123 229)
+   (member-up-count 123 249)
+   (member-up-count-size 123 196)
+   (memoize-up-count 123 152)
+   (memoize-up-count-size 123 152)
+   (new-no-hueristics 116 286)))
+ ((pattern
+    (vector 1 0 3 6 5 0 0 0)
+    (vector 7 3 5 9 2 0 8 8)
+    (vector 4 2 9 9 0 5 4 7)
+    (vector 2 6 4 1 8 8 5 9)
+    (vector 8 8 7 3 9 0 3 8)
+    (vector 5 1 7 7 1 7 8 8)
+    (vector 9 7 7 9 4 1 8 8)
+    (vector 9 3 0 7 1 7 9 2)
+    (vector 6 8 7 7 8 1 5 4)
+    (vector 2 2 3 5 9 1 3 1)
+    (vector 0 0 0 6 4 1 5 3)
+    (vector 4 5 3 7 4 2 9 0)
+    (vector 0 7 7 1 0 4 5 4)
+    (vector 8 0 1 0 4 7 1 4)
+    (vector 9 3 3 5 4 8 9 0))
+  ((no-hueristics 116 268)
+   (no-hueristics-size 116 269)
+   (rel-1-5 3760 5991)
+   (rel-1-5-size 134 5308)
+   (inverse-in 3760 5984)
+   (inverse-in-size 134 6234)
+   (tag-negate 123 331)
+   (tag-negate-size 123 289)
+   (new-coupling 123 232)
+   (new-coupling-size 123 249)
+   (member-up-count 123 238)
+   (member-up-count-size 123 200)
+   (memoize-up-count 123 151)
+   (memoize-up-count-size 123 149)
+   (new-no-hueristics 116 260)))
+ ((pattern
+    (vector 8 4 7 9 8 3 9 0)
+    (vector 6 6 9 5 6 0 1 4)
+    (vector 6 3 9 2 6 6 3 8)
+    (vector 7 8 7 8 9 8 6 9)
+    (vector 2 3 9 0 8 0 2 5)
+    (vector 9 2 2 5 4 6 1 0)
+    (vector 9 2 4 8 9 7 6 8)
+    (vector 8 3 7 7 4 3 9 6)
+    (vector 8 8 9 6 0 3 3 9)
+    (vector 7 8 7 2 4 8 4 3)
+    (vector 3 9 1 2 8 9 0 6)
+    (vector 5 9 6 9 4 5 5 4)
+    (vector 3 6 3 5 0 6 5 9)
+    (vector 4 2 1 0 2 6 4 5)
+    (vector 7 7 9 5 7 2 4 2))
+  ((no-hueristics 113 250)
+   (no-hueristics-size 113 284)
+   (rel-1-5 3025 3714)
+   (rel-1-5-size 129 3662)
+   (inverse-in 3025 4049)
+   (inverse-in-size 129 3897)
+   (tag-negate 201 349)
+   (tag-negate-size 124 321)
+   (new-coupling 180 293)
+   (new-coupling-size 115 304)
+   (member-up-count 180 264)
+   (member-up-count-size 115 262)
+   (memoize-up-count 180 211)
+   (memoize-up-count-size 115 181)
+   (new-no-hueristics 113 283)))
+ ((pattern
+    (vector 5 7 3 1 7 4 6 4)
+    (vector 1 0 7 8 5 0 9 7)
+    (vector 4 7 6 2 4 5 8 5)
+    (vector 9 8 0 2 0 4 3 5)
+    (vector 2 8 7 1 2 5 5 6)
+    (vector 6 3 6 3 5 6 0 9)
+    (vector 5 8 1 9 3 1 6 5)
+    (vector 1 6 7 1 1 2 9 5)
+    (vector 0 8 6 5 3 4 1 1)
+    (vector 7 7 4 2 5 6 3 2)
+    (vector 7 6 1 0 8 0 7 9)
+    (vector 6 7 3 9 9 4 4 0)
+    (vector 2 3 5 7 7 8 9 6)
+    (vector 7 5 0 3 4 3 5 1)
+    (vector 9 9 3 9 9 1 9 7))
+  ((no-hueristics 116 291)
+   (no-hueristics-size 116 262)
+   (rel-1-5 3370 4413)
+   (rel-1-5-size 140 4525)
+   (inverse-in 3370 4609)
+   (inverse-in-size 140 4485)
+   (tag-negate 123 319)
+   (tag-negate-size 123 288)
+   (new-coupling 123 230)
+   (new-coupling-size 123 353)
+   (member-up-count 123 205)
+   (member-up-count-size 123 200)
+   (memoize-up-count 123 157)
+   (memoize-up-count-size 123 153)
+   (new-no-hueristics 116 254)))
+ ((pattern
+    (vector 8 0 5 1 6 3 5 8)
+    (vector 9 5 1 3 2 0 1 8)
+    (vector 4 7 7 8 3 5 9 7)
+    (vector 6 6 0 8 4 2 3 4)
+    (vector 4 0 7 0 6 2 0 5)
+    (vector 8 4 1 2 4 2 3 9)
+    (vector 9 0 7 5 7 6 4 3)
+    (vector 5 5 3 1 9 8 7 3)
+    (vector 9 4 5 5 7 8 2 7)
+    (vector 2 3 1 6 7 4 5 9)
+    (vector 5 4 4 4 3 8 0 0)
+    (vector 5 3 1 4 4 0 9 5)
+    (vector 4 7 2 3 5 4 0 9)
+    (vector 0 4 7 7 8 5 8 5)
+    (vector 9 2 0 4 3 0 4 8))
+  ((no-hueristics 114 258)
+   (no-hueristics-size 114 255)
+   (rel-1-5 1785 2793)
+   (rel-1-5-size 134 2587)
+   (inverse-in 1785 2604)
+   (inverse-in-size 134 2829)
+   (tag-negate 158 308)
+   (tag-negate-size 128 307)
+   (new-coupling 149 245)
+   (new-coupling-size 119 353)
+   (member-up-count 149 269)
+   (member-up-count-size 119 238)
+   (memoize-up-count 149 163)
+   (memoize-up-count-size 119 164)
+   (new-no-hueristics 114 280)))
+ ((pattern
+    (vector 7 0 4 7 8 4 4 5)
+    (vector 2 0 7 9 2 2 7 5)
+    (vector 7 3 2 4 3 9 0 8)
+    (vector 3 4 4 9 2 5 5 0)
+    (vector 8 9 7 6 5 3 2 9)
+    (vector 5 1 8 7 3 6 4 2)
+    (vector 1 6 6 7 7 7 5 3)
+    (vector 3 0 2 6 7 9 6 7)
+    (vector 0 5 4 7 0 8 6 5)
+    (vector 1 7 5 7 3 9 9 6)
+    (vector 8 8 3 5 5 9 8 0)
+    (vector 1 2 6 0 1 4 8 1)
+    (vector 1 4 8 1 4 7 7 5)
+    (vector 4 2 4 9 3 6 5 1)
+    (vector 4 1 7 1 2 5 1 5))
+  ((no-hueristics 116 287)
+   (no-hueristics-size 116 292)
+   (rel-1-5 3904 4924)
+   (rel-1-5-size 142 4634)
+   (inverse-in 3904 4985)
+   (inverse-in-size 142 4782)
+   (tag-negate 230 340)
+   (tag-negate-size 134 318)
+   (new-coupling 232 288)
+   (new-coupling-size 120 401)
+   (member-up-count 232 252)
+   (member-up-count-size 120 228)
+   (memoize-up-count 232 213)
+   (memoize-up-count-size 120 182)
+   (new-no-hueristics 116 306)))
+ ((pattern
+    (vector 3 2 7 2 0 6 3 5)
+    (vector 7 5 4 5 6 9 4 7)
+    (vector 5 1 8 2 3 8 9 2)
+    (vector 2 6 6 7 2 8 8 8)
+    (vector 2 5 2 2 4 6 9 1)
+    (vector 3 4 6 0 5 2 9 0)
+    (vector 4 7 3 7 8 4 1 0)
+    (vector 2 9 9 6 7 8 4 2)
+    (vector 5 9 6 9 7 6 3 0)
+    (vector 2 1 0 7 4 0 0 8)
+    (vector 9 5 7 7 1 9 0 3)
+    (vector 8 9 9 8 9 6 0 5)
+    (vector 5 6 6 2 4 9 2 8)
+    (vector 1 5 6 7 5 8 5 6)
+    (vector 3 4 4 6 3 6 1 4))
+  ((no-hueristics 115 256)
+   (no-hueristics-size 115 256)
+   (rel-1-5 1321 1966)
+   (rel-1-5-size 132 1941)
+   (inverse-in 1321 1961)
+   (inverse-in-size 132 1981)
+   (tag-negate 123 320)
+   (tag-negate-size 123 292)
+   (new-coupling 123 257)
+   (new-coupling-size 123 364)
+   (member-up-count 123 252)
+   (member-up-count-size 123 229)
+   (memoize-up-count 123 151)
+   (memoize-up-count-size 123 149)
+   (new-no-hueristics 115 448)))
+ ((pattern
+    (vector 2 7 7 2 4 9 8 3)
+    (vector 9 8 8 9 2 6 4 8)
+    (vector 9 5 7 8 1 2 9 7)
+    (vector 3 9 5 8 8 0 0 0)
+    (vector 9 0 2 3 9 3 9 8)
+    (vector 3 7 9 5 5 5 5 6)
+    (vector 2 3 4 3 5 3 1 9)
+    (vector 4 8 7 2 8 0 3 0)
+    (vector 0 7 3 9 2 2 9 5)
+    (vector 1 0 2 6 5 8 2 0)
+    (vector 1 8 3 8 1 6 7 8)
+    (vector 7 7 0 7 9 5 7 9)
+    (vector 5 1 0 7 5 1 3 9)
+    (vector 1 5 5 8 5 0 8 6)
+    (vector 8 4 5 2 2 4 0 9))
+  ((no-hueristics 117 258)
+   (no-hueristics-size 117 287)
+   (rel-1-5 1833 2973)
+   (rel-1-5-size 133 2785)
+   (inverse-in 1833 2754)
+   (inverse-in-size 133 2939)
+   (tag-negate 123 313)
+   (tag-negate-size 123 289)
+   (new-coupling 123 229)
+   (new-coupling-size 123 337)
+   (member-up-count 123 204)
+   (member-up-count-size 123 194)
+   (memoize-up-count 123 154)
+   (memoize-up-count-size 123 153)
+   (new-no-hueristics 117 273)))
+ ((pattern
+    (vector 1 2 4 4 9 8 8 7)
+    (vector 9 0 0 2 5 6 0 9)
+    (vector 9 5 5 2 2 1 8 8)
+    (vector 5 8 7 5 5 1 7 9)
+    (vector 5 1 5 4 2 6 1 3)
+    (vector 8 1 6 3 9 8 5 0)
+    (vector 5 0 3 8 3 3 6 8)
+    (vector 1 5 6 8 8 3 9 4)
+    (vector 7 5 8 9 3 0 4 1)
+    (vector 3 2 7 3 0 2 5 6)
+    (vector 4 8 6 7 1 2 6 4)
+    (vector 7 4 5 5 9 4 9 6)
+    (vector 9 8 7 2 0 2 6 3)
+    (vector 4 3 8 7 7 4 5 1)
+    (vector 4 1 8 8 3 6 2 2))
+  ((no-hueristics 115 287)
+   (no-hueristics-size 115 288)
+   (rel-1-5 2843 4811)
+   (rel-1-5-size 143 4492)
+   (inverse-in 2843 4655)
+   (inverse-in-size 143 4717)
+   (tag-negate 122 298)
+   (tag-negate-size 122 313)
+   (new-coupling 122 229)
+   (new-coupling-size 122 330)
+   (member-up-count 122 196)
+   (member-up-count-size 122 198)
+   (memoize-up-count 122 151)
+   (memoize-up-count-size 122 148)
+   (new-no-hueristics 115 294))))
diff --git a/collects/tests/mzscheme/match/rand-vec-perf.ss b/collects/tests/mzscheme/match/rand-vec-perf.ss
new file mode 100644
index 0000000000..a7ebc43d4c
--- /dev/null
+++ b/collects/tests/mzscheme/match/rand-vec-perf.ss
@@ -0,0 +1,278 @@
+(load-relative "../loadtest.ss")
+(SECTION 'MATCH-PERFORMANCE)
+
+(require (lib "pretty.ss"))
+(require-for-syntax (lib "pretty.ss"))
+(require (lib "include.ss"))
+(require (lib "plt-match.ss"))
+
+
+(include "match-compile-perf.scm")
+
+
+
+(match-performance-test
+ (file
+  ;; this is the name of the underlying file that handles the 
+  ;; persistance of test data between invocations of this performance test
+  ;; Each time a test is run one has the option to only compare current
+  ;; data with previous data or one can modify the database file by appending
+  ;; hopefullly improved data.
+  ;; For most purposes it is advisable not to alter the database.
+  (name "rand-vec-hist.db")
+  ;; onlly one of the following options is allowed
+  ;; write-new   ;; uncomment to write an new test database 
+                 ;; (this requires the whole-list display option below)
+  ;; add-results ;; uncomment to append the results of the current test
+                 ;; to the database
+  )
+ (tag
+  ;; only one option is allowed 
+  ;; this is the name of the tag placed on data generted by this test
+  current
+  ;; other options are 
+  ;; date ;; to tag new date with a date
+  ;; time ;; to tag new date with a time
+  )
+ (display
+  ;; only one option is allowed
+  ;; remember negative -> good  and positive -> bad 
+  ;; positive-change       ;; displays increases in node counts
+  ;; other options are:
+  ;; negative-change    ;; displays decreases in node counts
+  percent-change             ;; to display any change in node count
+  ;; rt-positive-change ;; same as above but for real compile time
+  ;; rt-negative-change
+  ;; rt-change
+  ;; whole-list         ;; display whole database line with current test appended
+  ;; last-two ;; display only the current result with the previous result
+  )
+ (patterns
+ (pattern
+   (vector 1 2 4 4 9 8 8 7)
+   (vector 9 0 0 2 5 6 0 9)
+   (vector 9 5 5 2 2 1 8 8)
+   (vector 5 8 7 5 5 1 7 9)
+   (vector 5 1 5 4 2 6 1 3)
+   (vector 8 1 6 3 9 8 5 0)
+   (vector 5 0 3 8 3 3 6 8)
+   (vector 1 5 6 8 8 3 9 4)
+   (vector 7 5 8 9 3 0 4 1)
+   (vector 3 2 7 3 0 2 5 6)
+   (vector 4 8 6 7 1 2 6 4)
+   (vector 7 4 5 5 9 4 9 6)
+   (vector 9 8 7 2 0 2 6 3)
+   (vector 4 3 8 7 7 4 5 1)
+   (vector 4 1 8 8 3 6 2 2))
+ (pattern
+   (vector 2 7 7 2 4 9 8 3)
+   (vector 9 8 8 9 2 6 4 8)
+   (vector 9 5 7 8 1 2 9 7)
+   (vector 3 9 5 8 8 0 0 0)
+   (vector 9 0 2 3 9 3 9 8)
+   (vector 3 7 9 5 5 5 5 6)
+   (vector 2 3 4 3 5 3 1 9)
+   (vector 4 8 7 2 8 0 3 0)
+   (vector 0 7 3 9 2 2 9 5)
+   (vector 1 0 2 6 5 8 2 0)
+   (vector 1 8 3 8 1 6 7 8)
+   (vector 7 7 0 7 9 5 7 9)
+   (vector 5 1 0 7 5 1 3 9)
+   (vector 1 5 5 8 5 0 8 6)
+   (vector 8 4 5 2 2 4 0 9))
+ (pattern
+   (vector 3 2 7 2 0 6 3 5)
+   (vector 7 5 4 5 6 9 4 7)
+   (vector 5 1 8 2 3 8 9 2)
+   (vector 2 6 6 7 2 8 8 8)
+   (vector 2 5 2 2 4 6 9 1)
+   (vector 3 4 6 0 5 2 9 0)
+   (vector 4 7 3 7 8 4 1 0)
+   (vector 2 9 9 6 7 8 4 2)
+   (vector 5 9 6 9 7 6 3 0)
+   (vector 2 1 0 7 4 0 0 8)
+   (vector 9 5 7 7 1 9 0 3)
+   (vector 8 9 9 8 9 6 0 5)
+   (vector 5 6 6 2 4 9 2 8)
+   (vector 1 5 6 7 5 8 5 6)
+   (vector 3 4 4 6 3 6 1 4))
+ (pattern
+   (vector 7 0 4 7 8 4 4 5)
+   (vector 2 0 7 9 2 2 7 5)
+   (vector 7 3 2 4 3 9 0 8)
+   (vector 3 4 4 9 2 5 5 0)
+   (vector 8 9 7 6 5 3 2 9)
+   (vector 5 1 8 7 3 6 4 2)
+   (vector 1 6 6 7 7 7 5 3)
+   (vector 3 0 2 6 7 9 6 7)
+   (vector 0 5 4 7 0 8 6 5)
+   (vector 1 7 5 7 3 9 9 6)
+   (vector 8 8 3 5 5 9 8 0)
+   (vector 1 2 6 0 1 4 8 1)
+   (vector 1 4 8 1 4 7 7 5)
+   (vector 4 2 4 9 3 6 5 1)
+   (vector 4 1 7 1 2 5 1 5))
+ (pattern
+   (vector 8 0 5 1 6 3 5 8)
+   (vector 9 5 1 3 2 0 1 8)
+   (vector 4 7 7 8 3 5 9 7)
+   (vector 6 6 0 8 4 2 3 4)
+   (vector 4 0 7 0 6 2 0 5)
+   (vector 8 4 1 2 4 2 3 9)
+   (vector 9 0 7 5 7 6 4 3)
+   (vector 5 5 3 1 9 8 7 3)
+   (vector 9 4 5 5 7 8 2 7)
+   (vector 2 3 1 6 7 4 5 9)
+   (vector 5 4 4 4 3 8 0 0)
+   (vector 5 3 1 4 4 0 9 5)
+   (vector 4 7 2 3 5 4 0 9)
+   (vector 0 4 7 7 8 5 8 5)
+   (vector 9 2 0 4 3 0 4 8))
+ (pattern
+   (vector 5 7 3 1 7 4 6 4)
+   (vector 1 0 7 8 5 0 9 7)
+   (vector 4 7 6 2 4 5 8 5)
+   (vector 9 8 0 2 0 4 3 5)
+   (vector 2 8 7 1 2 5 5 6)
+   (vector 6 3 6 3 5 6 0 9)
+   (vector 5 8 1 9 3 1 6 5)
+   (vector 1 6 7 1 1 2 9 5)
+   (vector 0 8 6 5 3 4 1 1)
+   (vector 7 7 4 2 5 6 3 2)
+   (vector 7 6 1 0 8 0 7 9)
+   (vector 6 7 3 9 9 4 4 0)
+   (vector 2 3 5 7 7 8 9 6)
+   (vector 7 5 0 3 4 3 5 1)
+   (vector 9 9 3 9 9 1 9 7))
+ (pattern
+   (vector 8 4 7 9 8 3 9 0)
+   (vector 6 6 9 5 6 0 1 4)
+   (vector 6 3 9 2 6 6 3 8)
+   (vector 7 8 7 8 9 8 6 9)
+   (vector 2 3 9 0 8 0 2 5)
+   (vector 9 2 2 5 4 6 1 0)
+   (vector 9 2 4 8 9 7 6 8)
+   (vector 8 3 7 7 4 3 9 6)
+   (vector 8 8 9 6 0 3 3 9)
+   (vector 7 8 7 2 4 8 4 3)
+   (vector 3 9 1 2 8 9 0 6)
+   (vector 5 9 6 9 4 5 5 4)
+   (vector 3 6 3 5 0 6 5 9)
+   (vector 4 2 1 0 2 6 4 5)
+   (vector 7 7 9 5 7 2 4 2))
+ (pattern
+   (vector 1 0 3 6 5 0 0 0)
+   (vector 7 3 5 9 2 0 8 8)
+   (vector 4 2 9 9 0 5 4 7)
+   (vector 2 6 4 1 8 8 5 9)
+   (vector 8 8 7 3 9 0 3 8)
+   (vector 5 1 7 7 1 7 8 8)
+   (vector 9 7 7 9 4 1 8 8)
+   (vector 9 3 0 7 1 7 9 2)
+   (vector 6 8 7 7 8 1 5 4)
+   (vector 2 2 3 5 9 1 3 1)
+   (vector 0 0 0 6 4 1 5 3)
+   (vector 4 5 3 7 4 2 9 0)
+   (vector 0 7 7 1 0 4 5 4)
+   (vector 8 0 1 0 4 7 1 4)
+   (vector 9 3 3 5 4 8 9 0))
+ (pattern
+   (vector 5 4 8 9 6 9 2 8)
+   (vector 8 1 9 0 6 6 4 4)
+   (vector 7 8 4 3 5 7 7 4)
+   (vector 1 2 0 5 0 1 8 5)
+   (vector 5 6 5 3 7 9 1 6)
+   (vector 0 3 8 6 1 3 1 0)
+   (vector 3 7 3 8 5 3 4 6)
+   (vector 5 6 3 6 7 1 3 4)
+   (vector 9 0 7 9 9 1 7 0)
+   (vector 6 5 6 7 0 9 8 3)
+   (vector 7 1 3 4 4 8 2 0)
+   (vector 6 5 8 4 9 1 0 0)
+   (vector 2 8 9 1 1 6 1 7)
+   (vector 4 0 6 4 9 4 0 8)
+   (vector 8 3 4 2 3 6 4 0))
+ (pattern
+   (vector 4 2 4 5 4 4 5 8)
+   (vector 4 7 9 7 5 3 4 9)
+   (vector 5 3 6 4 9 6 5 7)
+   (vector 9 9 2 3 8 6 3 2)
+   (vector 1 9 7 7 5 4 5 2)
+   (vector 1 6 9 9 1 6 8 6)
+   (vector 9 4 1 8 0 8 8 2)
+   (vector 9 0 7 9 8 0 1 9)
+   (vector 1 0 8 8 5 3 0 8)
+   (vector 2 2 7 3 0 6 0 9)
+   (vector 2 3 9 5 1 9 9 2)
+   (vector 9 6 2 8 6 5 9 9)
+   (vector 6 8 7 3 3 0 1 5)
+   (vector 4 9 9 4 7 9 5 1)
+   (vector 2 6 6 5 6 5 9 5))
+ (pattern
+   (vector 1 3 5 9 9 7 0 7)
+   (vector 5 0 0 8 2 1 6 6)
+   (vector 2 5 0 9 6 5 1 0)
+   (vector 1 9 7 7 7 6 5 0)
+   (vector 2 0 2 1 7 2 0 4)
+   (vector 4 2 5 6 3 1 2 8)
+   (vector 8 2 7 4 7 0 4 1)
+   (vector 0 3 8 7 9 5 9 1)
+   (vector 6 1 4 5 4 6 2 0)
+   (vector 8 7 7 4 0 9 2 8)
+   (vector 2 1 2 1 2 8 4 4)
+   (vector 1 3 3 2 8 2 6 6)
+   (vector 4 2 4 0 9 6 0 9)
+   (vector 5 7 3 5 9 5 3 1)
+   (vector 7 7 4 9 7 9 5 8))
+ (pattern
+   (vector 4 8 2 4 0 8 3 4)
+   (vector 3 7 6 2 5 7 1 0)
+   (vector 6 7 5 5 2 0 8 1)
+   (vector 7 5 2 4 6 7 4 0)
+   (vector 5 8 6 8 9 9 2 2)
+   (vector 6 1 6 3 0 9 3 6)
+   (vector 6 0 4 1 0 4 4 9)
+   (vector 9 7 5 5 6 9 7 4)
+   (vector 8 4 2 7 5 6 1 4)
+   (vector 7 7 7 7 6 1 6 3)
+   (vector 3 0 6 4 4 0 3 6)
+   (vector 7 1 3 6 0 3 0 0)
+   (vector 7 2 9 2 8 2 8 6)
+   (vector 9 6 5 6 9 1 1 2)
+   (vector 3 9 6 8 9 2 6 9))
+ (pattern
+   (vector 3 1 5 5 4 5 8 1)
+   (vector 9 9 6 7 2 4 5 1)
+   (vector 2 1 9 1 4 2 4 8)
+   (vector 1 2 8 3 6 4 2 9)
+   (vector 5 7 7 2 4 7 3 5)
+   (vector 6 1 4 0 8 2 4 2)
+   (vector 5 5 4 9 8 8 7 1)
+   (vector 0 7 4 7 3 6 8 1)
+   (vector 5 7 3 1 4 8 8 3)
+   (vector 2 3 3 0 5 7 2 0)
+   (vector 5 8 1 3 6 1 6 9)
+   (vector 8 1 8 2 9 8 3 7)
+   (vector 6 8 0 2 6 9 5 8)
+   (vector 4 1 0 9 0 5 1 5)
+   (vector 3 4 0 2 5 9 3 4))
+ (pattern
+   (vector 2 3 8 1 1 3 0 9)
+   (vector 1 1 4 7 2 9 8 6)
+   (vector 2 8 7 3 5 0 0 1)
+   (vector 4 1 3 0 0 8 6 2)
+   (vector 1 4 5 4 7 8 6 0)
+   (vector 1 0 9 3 9 7 1 4)
+   (vector 8 0 7 5 0 7 6 4)
+   (vector 0 1 6 2 9 2 6 2)
+   (vector 8 4 7 7 2 3 7 3)
+   (vector 3 9 8 4 8 9 8 6)
+   (vector 1 7 4 1 7 0 7 7)
+   (vector 2 6 2 3 0 8 6 9)
+   (vector 2 5 6 6 0 6 9 5)
+   (vector 7 7 9 5 8 0 2 1)
+   (vector 7 6 2 4 8 2 4 0))
+
+))
+
+(report-errs)
\ No newline at end of file
diff --git a/collects/tests/mzscheme/match/short-rand-list.scm b/collects/tests/mzscheme/match/short-rand-list.scm
new file mode 100644
index 0000000000..48c48fba45
--- /dev/null
+++ b/collects/tests/mzscheme/match/short-rand-list.scm
@@ -0,0 +1,189 @@
+(load-relative "../loadtest.ss")
+(SECTION 'MATCH-PERFORMANCE)
+
+(require (lib "pretty.ss"))
+(require-for-syntax (lib "pretty.ss"))
+(require (lib "include.ss"))
+(require (lib "plt-match.ss"))
+
+(include "match-compile-perf.scm")
+
+(match-performance-test
+ (file
+  ;; this is the name of the underlying file that handles the 
+  ;; persistance of test data between invocations of this performance test
+  ;; Each time a test is run one has the option to only compare current
+  ;; data with previous data or one can modify the database file by appending
+  ;; hopefullly improved data.
+  ;; For most purposes it is advisable not to alter the database.
+  (name "rand-short-list-hist.db")
+  ;; onlly one of the following options is allowed
+  ;; write-new   ;; uncomment to write an new test database 
+                 ;; (this requires the whole-list display option below)
+  ;; add-results ;; uncomment to append the results of the current test
+                 ;; to the database
+  )
+ (tag
+  ;; only one option is allowed 
+  ;; this is the name of the tag placed on data generted by this test
+  currnet
+  ;; other options are 
+  ;; date ;; to tag new date with a date
+  ;; time ;; to tag new date with a time
+  )
+ (display
+  ;; only one option is allowed
+  ;; remember negative -> good  and positive -> bad 
+  ;; positive-change       ;; displays increases in node counts
+  ;; other options are:
+  ;; negative-change    ;; displays decreases in node counts
+  percent-change             ;; to display any change in node count
+  ;; rt-positive-change ;; same as above but for real compile time
+  ;; rt-negative-change
+  ;; rt-change
+  ;; whole-list         ;; display whole database line with current test appended
+  ;; last-two ;; display only the current result with the previous result
+  )
+ (patterns
+(pattern
+   (list 9 8 7 9)
+   (list 6 9 4 3)
+   (list 6 3 8 7)
+   (list 5 2 8 3)
+   (list 0 3 9 9)
+   (list 7 5 1 7)
+   (list 3 7 7 0)
+   (list 1 7 3 0)
+   (list 7 0 9 3)
+   (list 9 3 8 8)
+   (list 9 6 7 6)
+   (list 9 7 9 1))
+ (pattern
+   (list 0 1 0 9)
+   (list 6 2 6 0)
+   (list 1 4 2 3)
+   (list 3 5 3 0)
+   (list 5 3 5 7)
+   (list 8 3 5 9)
+   (list 1 4 6 2)
+   (list 1 7 4 2)
+   (list 0 4 3 7)
+   (list 8 0 9 0)
+   (list 4 3 3 7)
+   (list 8 8 9 5))
+ (pattern
+   (list 3 4 4 2)
+   (list 9 1 3 0)
+   (list 5 9 3 7)
+   (list 9 7 1 9)
+   (list 3 4 8 2)
+   (list 4 7 4 0)
+   (list 0 9 7 0))
+(pattern
+   (list 9 8 7 9)
+   (list 6 9 4 3)
+   (list 6 3 8 7)
+   (list 5 2 8 3)
+   (list 0 3 9 9)
+   (list 7 5 1 7)
+   (list 3 7 7 0)
+   (list 1 7 3 0)
+   (list 7 0 9 3)
+   (list 9 3 8 8)
+   (list 9 6 7 6)
+   (list 9 7 9 1))
+ (pattern
+   (list 0 1 0 9)
+   (list 6 2 6 0)
+   (list 1 4 2 3)
+   (list 3 5 3 0)
+   (list 5 3 5 7)
+   (list 8 3 5 9)
+   (list 1 4 6 2)
+   (list 1 7 4 2)
+   (list 0 4 3 7)
+   (list 8 0 9 0)
+   (list 4 3 3 7)
+   (list 8 8 9 5))
+ (pattern
+   (list 3 4 4 2)
+   (list 9 1 3 0)
+   (list 5 9 3 7)
+   (list 9 7 1 9)
+   (list 3 4 8 2)
+   (list 4 7 4 0)
+   (list 0 9 7 0))
+
+(pattern
+   (list 7 8 8 3)
+   (list 2 2 5 1)
+   (list 4 0 2 9)
+   (list 0 7 8 1)
+   (list 4 9 0 7)
+   (list 4 9 1 0)
+   (list 6 7 1 9)
+   (list 8 0 1 8)
+   (list 9 1 1 1)
+   (list 6 8 5 0)
+   (list 8 9 1 0)
+   (list 6 2 1 2))
+ (pattern
+   (list 1 2 1 7)
+   (list 1 5 8 9)
+   (list 2 9 0 1)
+   (list 9 4 9 8)
+   (list 5 0 2 1)
+   (list 8 7 3 8)
+   (list 8 7 9 6)
+   (list 9 0 8 0)
+   (list 2 9 8 5)
+   (list 4 6 5 9)
+   (list 7 7 2 6)
+   (list 1 3 7 9))
+ (pattern
+   (list 5 9 0 5)
+   (list 8 6 3 6)
+   (list 3 2 4 2)
+   (list 3 2 4 7)
+   (list 3 4 3 0)
+   (list 2 0 9 9)
+   (list 7 3 8 1))
+
+ (pattern
+   (list 6 5 0 1)
+   (list 4 0 8 4)
+   (list 6 1 2 1)
+   (list 6 6 3 1)
+   (list 8 0 8 1)
+   (list 4 3 1 7)
+   (list 3 2 6 1)
+   (list 5 4 2 3)
+   (list 9 2 6 5)
+   (list 4 4 1 3)
+   (list 8 3 4 4)
+   (list 9 0 7 9))
+ (pattern
+   (list 0 5 3 4)
+   (list 9 6 1 4)
+   (list 9 0 5 6)
+   (list 4 9 2 6)
+   (list 3 8 3 8)
+   (list 5 5 3 3)
+   (list 8 7 9 0)
+   (list 7 6 1 7)
+   (list 3 4 4 4)
+   (list 1 5 9 2)
+   (list 7 6 0 4)
+   (list 6 2 0 1))
+ (pattern
+   (list 3 5 9 8)
+   (list 0 2 3 1)
+   (list 2 4 3 9)
+   (list 0 4 9 5)
+   (list 9 3 0 2)
+   (list 0 9 6 8)
+   (list 5 6 2 3))
+
+))
+
+(report-errs)
\ No newline at end of file
diff --git a/collects/tests/mzscheme/md5.ss b/collects/tests/mzscheme/md5.ss
new file mode 100644
index 0000000000..ad4691c8b4
--- /dev/null
+++ b/collects/tests/mzscheme/md5.ss
@@ -0,0 +1,16 @@
+
+(load-relative "loadtest.ss")
+
+(SECTION 'md5)
+
+(require (lib "md5.ss"))
+
+(test #"d41d8cd98f00b204e9800998ecf8427e" md5 #"")
+(test #"0cc175b9c0f1b6a831c399e269772661" md5 #"a")
+(test #"900150983cd24fb0d6963f7d28e17f72" md5 #"abc")
+(test #"f96b697d7cb7938d525a2f31aaf161d0" md5 #"message digest")
+(test #"c3fcd3d76192e4007dfb496cca67e13b" md5 #"abcdefghijklmnopqrstuvwxyz")
+(test #"d174ab98d277d9f5a5611c2c9f419d9f" md5 #"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789")
+(test #"57edf4a22be3c955ac49da2e2107b67a" md5 #"12345678901234567890123456789012345678901234567890123456789012345678901234567890")
+
+(report-errs)
diff --git a/collects/tests/mzscheme/module.ss b/collects/tests/mzscheme/module.ss
new file mode 100644
index 0000000000..2b305a9254
--- /dev/null
+++ b/collects/tests/mzscheme/module.ss
@@ -0,0 +1,228 @@
+
+(load-relative "loadtest.ss")
+
+(SECTION 'module)
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(module n mzscheme 
+  (define n 'n) 
+  (define-struct s (field1 field2))
+  (provide n
+	   (struct s (field1 field2))
+	   (rename n m)))
+
+(require n)
+(test 'n 'required-n n)
+(test 'n 'required-n m)
+
+(test 's-field1 object-name s-field1)
+(test 's-field2 object-name s-field2)
+(test 'set-s-field1! object-name set-s-field1!)
+(test 'set-s-field2! object-name set-s-field2!)
+(test 's? object-name s?)
+(test 7 s-field1 (make-s 7 8))
+(test 8 s-field2 (make-s 7 8))
+(define an-s (make-s 7 8))
+(test (void) set-s-field1! an-s 12)
+(test (void) set-s-field2! an-s 13)
+(test 12 s-field1 an-s)
+(test 13 s-field2 an-s)
+
+(syntax-test #'(set! n 10))
+(syntax-test #'(set! m 10))
+(syntax-test #'(set! make-s 10))
+
+(syntax-test #'(module))
+(syntax-test #'(module m))
+(syntax-test #'(module 5 mzscheme))
+
+(syntax-test #'(module m 5))
+
+(syntax-test #'(module m mzscheme . 1))
+
+(syntax-test #'(#%module-begin))
+(syntax-test #'(+ (#%module-begin) 2))
+
+(syntax-test #'(module n+ mzscheme (#%module-begin (#%module-begin (define n+ 'n+) (provide n+)))))
+(syntax-test #'(module n+ mzscheme (define n+ 'n+) (#%module-begin (provide n+))))
+(syntax-test #'(module n+ mzscheme (define n+ 'n+) (#%module-begin) (provide n+)))
+(syntax-test #'(module n+ mzscheme (#%module-begin) (define n+ 'n+) (provide n+)))
+(module n+ mzscheme (#%module-begin (define n+ 'n+) (provide n+)))
+
+(syntax-test #'(provide))
+(syntax-test #'(provide . x))
+(syntax-test #'(provide y . x))
+(syntax-test #'(module m mzscheme (define x 10) (provide . x)))
+(syntax-test #'(module m mzscheme (define x 10) (define y 11) (provide y . x)))
+(syntax-test #'(module m mzscheme (define x 10) (provide 1)))
+(syntax-test #'(module m mzscheme (define x 10) (provide "bad")))
+(syntax-test #'(module m mzscheme (define x 10) (provide not-here)))
+(syntax-test #'(module m mzscheme (define x 10) (define y 11) (provide x x)))
+(syntax-test #'(module m mzscheme (define x 10) (define y 11) (provide x z)))
+(syntax-test #'(module m mzscheme (define x 10) (define y 11) (provide x y x)))
+(syntax-test #'(module m mzscheme (define x 10) (define y 11) (provide (rename))))
+(syntax-test #'(module m mzscheme (define x 10) (define y 11) (provide (rename x))))
+(syntax-test #'(module m mzscheme (define x 10) (define y 11) (provide (rename x y z))))
+(syntax-test #'(module m mzscheme (define x 10) (define y 11) (provide (rename not-here x))))
+(syntax-test #'(module m mzscheme (define x 10) (define y 11) (provide (rename x 1))))
+(syntax-test #'(module m mzscheme (define x 10) (define y 11) (provide (rename 1 x))))
+(syntax-test #'(module m mzscheme (define-struct x (y)) (provide (struct))))
+(syntax-test #'(module m mzscheme (define-struct x (y)) (provide (struct . x))))
+(syntax-test #'(module m mzscheme (define-struct x (y)) (provide (struct x))))
+(syntax-test #'(module m mzscheme (define-struct x (y)) (provide (struct x (y) z))))
+(syntax-test #'(module m mzscheme (define-struct x (y)) (provide (struct x (y) . z))))
+(syntax-test #'(module m mzscheme (define-struct x (y)) (provide (struct 1 ()))))
+(syntax-test #'(module m mzscheme (define-struct x (y)) (provide (struct x (1)))))
+(syntax-test #'(module m mzscheme (define-struct x (y)) (provide (struct x (y . 1)))))
+(syntax-test #'(module m mzscheme (define-struct x (y)) (provide (struct x (y y)))))
+(syntax-test #'(module m mzscheme (define x 10) (define y 11) (provide (all-from))))
+(syntax-test #'(module m mzscheme (define x 10) (define y 11) (provide (all-from . mzscheme))))
+(syntax-test #'(module m mzscheme (define x 10) (define y 11) (provide (all-from 1))))
+(syntax-test #'(module m mzscheme (define x 10) (define y 11) (provide (all-from xxxx))))
+(syntax-test #'(module m mzscheme (define x 10) (define y 11) (provide (all-from mzscheme x))))
+(syntax-test #'(module m mzscheme (define x 10) (define y 11) (provide (all-from-except))))
+(syntax-test #'(module m mzscheme (define x 10) (define y 11) (provide (all-from-except . mzscheme))))
+(syntax-test #'(module m mzscheme (define x 10) (define y 11) (provide (all-from-except 1))))
+(syntax-test #'(module m mzscheme (define x 10) (define y 11) (provide (all-from-except mzscheme + . -))))
+(syntax-test #'(module m mzscheme (define x 10) (define y 11) (provide (all-from-except mzscheme 1))))
+(syntax-test #'(module m mzscheme (define x 10) (define y 11) (provide (all-from-except xxxx +))))
+(syntax-test #'(module m mzscheme (define x 10) (define y 11) (provide (all-from-except mzscheme no))))
+(syntax-test #'(module m mzscheme (define x 10) (define y 11) (provide (all-from-except mzscheme + no))))
+(syntax-test #'(module m mzscheme (define x 10) (define y 11) (provide (all-defined x))))
+(syntax-test #'(module m mzscheme (define x 10) (define y 11) (provide (all-defined . x))))
+(syntax-test #'(module m mzscheme (define x 10) (define y 11) (provide (all-defined 1))))
+(syntax-test #'(module m mzscheme (define x 10) (define y 11) (provide (all-defined-except . x))))
+(syntax-test #'(module m mzscheme (define x 10) (define y 11) (provide (all-defined-except 1))))
+(syntax-test #'(module m mzscheme (define x 10) (define y 11) (provide (all-defined-except x 1))))
+(syntax-test #'(module m mzscheme (define x 10) (define y 11) (provide (all-defined-except no))))
+
+(syntax-test #'(require . x))
+(syntax-test #'(require m . x))
+(syntax-test #'(module m mzscheme (require n . x)))
+(syntax-test #'(module m mzscheme (require (prefix))))
+(syntax-test #'(module m mzscheme (require (prefix n))))
+(syntax-test #'(module m mzscheme (require (prefix . pre:))))
+(syntax-test #'(module m mzscheme (require (prefix pre: . n))))
+(syntax-test #'(module m mzscheme (require (prefix 1 n))))
+(syntax-test #'(module m mzscheme (require (prefix pre: n more))))
+(syntax-test #'(module m mzscheme (require (prefix pre: n . more))))
+(syntax-test #'(module m mzscheme (require (all-except))))
+(syntax-test #'(module m mzscheme (require (all-except . n))))
+(syntax-test #'(module m mzscheme (require (all-except n 1))))
+(syntax-test #'(module m mzscheme (require (all-except n . n))))
+(syntax-test #'(module m mzscheme (require (rename))))
+(syntax-test #'(module m mzscheme (require (rename . n))))
+(syntax-test #'(module m mzscheme (require (rename n))))
+(syntax-test #'(module m mzscheme (require (rename n . n))))
+(syntax-test #'(module m mzscheme (require (rename n n))))
+(syntax-test #'(module m mzscheme (require (rename n n . m))))
+(syntax-test #'(module m mzscheme (require (rename n 1 m))))
+(syntax-test #'(module m mzscheme (require (rename n n 1))))
+(syntax-test #'(module m mzscheme (require (rename n n not-there))))
+(syntax-test #'(module m mzscheme (require (rename n n m extra))))
+
+(syntax-test #'(module m mzscheme (define car 5)))
+(syntax-test #'(module m mzscheme (define x 6) (define x 5)))
+(syntax-test #'(module m mzscheme (define x 10) (define-syntax x 10)))
+(syntax-test #'(module m mzscheme (define-syntax x 10) (define x 10)))
+
+;; Cyclic re-def of n:
+(syntax-test #'(module n n 10))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Check namespace-attach-module:
+
+(let* ([n (make-namespace)]
+       [l null]
+       [here (lambda (v)
+	       (set! l (cons v l)))])
+  (parameterize ([current-namespace n])
+    (eval `(module a mzscheme
+	     (define a 1)
+	     (,here 'a)
+	     (provide a)))
+    (test null values l)
+    (eval `(module b mzscheme
+	     (require-for-template a)
+	     (define b 1)
+	     (,here 'b)
+	     (provide b)))
+    (test null values l)
+    (eval `(module c mzscheme
+	     (require-for-template b)
+	     (define c 1)
+	     (,here 'c)
+	     (provide c)))
+    (test null values l)
+    (eval `(module d mzscheme
+	     (require-for-syntax c)
+	     (define d 1)
+	     (,here 'd)
+	     (provide d)))
+    (test '(c) values l)
+    (eval `(module e mzscheme
+	     (require-for-syntax d)
+	     (define e 1)
+	     (,here 'e)
+	     (provide e)))
+    (test '(d c b c) values l)
+    (eval `(module f mzscheme
+	     (,here 'f)
+	     (require b e)))
+    (test '(d c b d c b c) values l)
+    (eval `(require f))
+    (let ([finished '(f b e  d c b a  d c b d c b c)])
+      (test finished values l)
+      (let ([n2 (make-namespace)])
+	(namespace-attach-module n 'f)
+	(test finished values l)
+	(eval `(require a))
+	(eval `(require f))
+	(test finished values l)))))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Check redundant import and re-provide
+
+(module m_cr mzscheme
+  (provide x_cr y_cr z_cr w_cr)
+  (define x_cr 12)
+  (define y_cr 14)
+  (define z_cr 16)
+  (define w_cr 18))
+
+(syntax-test #'(module n_cr mzscheme
+		 (require m_cr)
+		 (provide (all-from-except m_cr no-such-var))))
+(syntax-test #'(module n_cr mzscheme
+		 (require m_cr)
+		 (provide (all-from-except m_cr cons))))
+
+(module n_cr mzscheme
+  (require m_cr)
+  (provide (all-from-except m_cr x_cr)))
+
+(module p_cr mzscheme
+  (require n_cr m_cr)
+  (provide (all-from m_cr)))
+
+(require p_cr)
+(test 14 values y_cr)
+
+(module p2_cr mzscheme
+  (require m_cr n_cr)
+  (provide (all-from m_cr)))
+
+(require p2_cr)
+(test 16 values z_cr)
+
+(module p3_cr mzscheme
+  (require m_cr n_cr)
+  (provide (all-from n_cr)))
+
+(require p3_cr)
+(test 18 values w_cr)
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(report-errs)
diff --git a/collects/tests/mzscheme/mz.ss b/collects/tests/mzscheme/mz.ss
new file mode 100644
index 0000000000..a85217e6a1
--- /dev/null
+++ b/collects/tests/mzscheme/mz.ss
@@ -0,0 +1,35 @@
+
+(load-relative "loadtest.ss")
+
+(load-relative "basic.ss")
+(load-relative "unicode.ss")
+(load-relative "read.ss")
+(load-relative "macro.ss")
+(load-relative "syntax.ss")
+(load-relative "stx.ss")
+(load-relative "module.ss")
+(load-relative "number.ss")
+(load-relative "object.ss")
+(load-relative "struct.ss")
+(load-relative "unit.ss")
+(load-relative "unitsig.ss")
+(load-relative "thread.ss")
+(load-relative "sync.ss")
+(load-relative "deep.ss")
+(load-relative "contmark.ss")
+(load-relative "will.ss")
+(load-relative "namespac.ss")
+(unless (or building-flat-tests? in-drscheme?)
+  (load-relative "param.ss"))
+(load-relative "port.ss")
+(load-relative "file.ss")
+(load-relative "path.ss")
+(unless (or building-flat-tests? in-drscheme?)
+  (load-relative "optimize.ss"))
+(unless building-flat-tests?
+  (load-relative "name.ss"))
+
+;; Ok, so this isn't really all of them. Here are more:
+; thrport.ss
+
+; See also README
diff --git a/collects/tests/mzscheme/mzlib.ss b/collects/tests/mzscheme/mzlib.ss
new file mode 100644
index 0000000000..d37718fe47
--- /dev/null
+++ b/collects/tests/mzscheme/mzlib.ss
@@ -0,0 +1,47 @@
+
+; Test MzLib
+; See also pptest.ss and ztest.ss
+
+(load-relative "loadtest.ss")
+
+(load-relative "md5.ss")
+
+(load-relative "structlib.ss")
+
+(load-relative "async-channel.ss")
+
+(load-relative "restart.ss")
+
+(load-relative "function.ss")
+
+(load-relative "string.ss")
+
+(load-relative "filelib.ss")
+
+(load-relative "portlib.ss")
+
+(load-relative "threadlib.ss")
+
+(load-relative "date.ss")
+
+(load-relative "compat.ss")
+
+(load-relative "cmdline.ss")
+
+(load-relative "pconvert.ss")
+
+(load-relative "pretty.ss")
+
+(load-relative "package.ss")
+
+(load-relative "contract-test.ss")
+
+(load-relative "match-test.ss")
+
+; Next-to-last, because it `require's mzscheme
+(load-relative "shared.ss")
+
+; Last - so macros are not present by accident
+(load-relative "macrolib.ss")
+
+(report-errs)
diff --git a/collects/tests/mzscheme/mzlonglong.c b/collects/tests/mzscheme/mzlonglong.c
new file mode 100644
index 0000000000..230bbc4bbd
--- /dev/null
+++ b/collects/tests/mzscheme/mzlonglong.c
@@ -0,0 +1,96 @@
+
+#include "escheme.h"
+
+static Scheme_Object *llsize(int argc, Scheme_Object **argv)
+{
+  return scheme_make_integer(sizeof(mzlonglong));
+}
+
+static Scheme_Object *toll(int argc, Scheme_Object **argv)
+{
+  mzlonglong l;
+
+  if (scheme_get_long_long_val(argv[0], &l))
+    return scheme_make_sized_byte_string((char *)&l, sizeof(mzlonglong), 1);
+  else
+    return scheme_false;
+}
+
+static Scheme_Object *toull(int argc, Scheme_Object **argv)
+{
+  umzlonglong l;
+
+  if (scheme_get_unsigned_long_long_val(argv[0], &l))
+    return scheme_make_sized_byte_string((char *)&l, sizeof(umzlonglong), 1);
+  else
+    return scheme_false;
+}
+
+static Scheme_Object *fromll(int argc, Scheme_Object **argv)
+{
+  mzlonglong l;
+
+  if (!SCHEME_BYTE_STRINGP(argv[0])
+      || (SCHEME_BYTE_STRTAG_VAL(argv[0]) != sizeof(mzlonglong)))
+    scheme_wrong_type("long-long-bytes->integer", 
+		      "byte string of mzlonglong size",
+		      0, argc, argv);
+
+
+  l = *(mzlonglong *)SCHEME_BYTE_STR_VAL(argv[0]);
+
+  return scheme_make_integer_value_from_long_long(l);
+}
+
+static Scheme_Object *fromull(int argc, Scheme_Object **argv)
+{
+  umzlonglong l;
+
+  if (!SCHEME_BYTE_STRINGP(argv[0])
+      || (SCHEME_BYTE_STRTAG_VAL(argv[0]) != sizeof(umzlonglong)))
+    scheme_wrong_type("unsigned-long-long-bytes->integer", 
+		      "byte string of mzlonglong size",
+		      0, argc, argv);
+
+
+  l = *(umzlonglong *)SCHEME_BYTE_STR_VAL(argv[0]);
+
+  return scheme_make_integer_value_from_unsigned_long_long(l);
+}
+
+
+
+Scheme_Object *scheme_reload(Scheme_Env *env)
+{
+  scheme_add_global("long-long-size", 
+		    scheme_make_prim_w_arity(llsize, "long-long-size", 0, 0),
+		    env);
+
+  scheme_add_global("integer->long-long-bytes", 
+		    scheme_make_prim_w_arity(toll, "integer->long-long-bytes", 1, 1),
+		    env);
+  scheme_add_global("integer->unsigned-long-long-bytes", 
+		    scheme_make_prim_w_arity(toull, "integer->unsigned-long-long-bytes", 1, 1),
+		    env);
+
+  scheme_add_global("long-long-bytes->integer", 
+		    scheme_make_prim_w_arity(fromll, "long-long-bytes->integer", 1, 1),
+		    env);
+  scheme_add_global("unsigned-long-long-bytes->integer", 
+		    scheme_make_prim_w_arity(fromull, "unsigned-long-long-bytes->integer", 1, 1),
+		    env);
+
+  return scheme_void;
+}
+
+Scheme_Object *scheme_initialize(Scheme_Env *env)
+{
+  /* First load is same as every load: */
+  return scheme_reload(env);
+}
+
+Scheme_Object *scheme_module_name()
+{
+  /* This extension doesn't define a module: */
+  return scheme_false;
+}
diff --git a/collects/tests/mzscheme/mzq.ss b/collects/tests/mzscheme/mzq.ss
new file mode 100644
index 0000000000..f3bb3dcbe8
--- /dev/null
+++ b/collects/tests/mzscheme/mzq.ss
@@ -0,0 +1,3 @@
+
+(define quiet-load "mz.ss")
+(load-relative "quiet.ss")
diff --git a/collects/tests/mzscheme/mzthr.ss b/collects/tests/mzscheme/mzthr.ss
new file mode 100644
index 0000000000..18b4f51e2f
--- /dev/null
+++ b/collects/tests/mzscheme/mzthr.ss
@@ -0,0 +1,75 @@
+
+(if (not (defined? 'SECTION))
+    (load-relative "testing.ss"))
+
+(SECTION 'mzlib-threads)
+
+(require-library "thread.ss")
+
+(define sema (make-semaphore))
+(define sema2 (make-semaphore))
+(define c-out 0)
+(define SLEEP-TIME 0.1)
+
+;;; consumer-thread ;;;
+
+(define-values (th g) (consumer-thread (case-lambda
+					[(f arg) (set! c-out (f arg))
+						 (semaphore-post sema)]
+					[(f arg1 arg2) (set! c-out (f arg1 arg2))
+						       (semaphore-post sema)])))
+(g + 1 2)
+(semaphore-wait sema)
+(test 3 'consumer-thread c-out)
+
+; queue 2
+(g car '(4 5))
+(g semaphore-wait sema2)
+(semaphore-wait sema)
+(test 4 'consumer-thread c-out)
+(semaphore-post sema2)
+(semaphore-wait sema)
+(test (void) 'consumer-thread c-out)
+
+; queue 3
+(g / 2)
+(g semaphore-wait sema2)
+(g (lambda (s) (semaphore-wait s) 5) sema2)
+(semaphore-wait sema)
+(test 1/2 'consumer-thread c-out)
+(semaphore-post sema2)
+(semaphore-wait sema)
+(test (void) 'consumer-thread c-out)
+(semaphore-post sema2)
+(semaphore-wait sema)
+(test 5 'consumer-thread c-out)
+
+; kill the consumer
+(kill-thread th)
+(g - 7)
+(sleep SLEEP-TIME)
+(test 5 'consumer-thread c-out)
+
+(arity-test consumer-thread 1 2)
+(error-test '(consumer-thread 9))
+(arity-test g 2 3)
+
+;;; semaphore-wait-multiple ;;;
+
+(test #f semaphore-wait-multiple (list sema sema2) SLEEP-TIME)
+(semaphore-post sema)
+(test sema semaphore-wait-multiple (list sema sema2))
+(test #f semaphore-wait-multiple (list sema sema2) SLEEP-TIME)
+(semaphore-post sema2)
+(test sema2 semaphore-wait-multiple (list sema sema2))
+(test #f semaphore-wait-multiple (list sema sema2) SLEEP-TIME)
+(semaphore-post sema)
+(semaphore-post sema2)
+(let ([first (semaphore-wait-multiple (list sema sema2))])
+  (test #t semaphore? first)
+  (test (if (eq? first sema) sema2 sema) semaphore-wait-multiple (list sema sema2)))
+(test #f semaphore-wait-multiple (list sema sema2) SLEEP-TIME)
+
+(arity-test semaphore-wait-multiple 1 3)
+
+(report-errs)
diff --git a/collects/tests/mzscheme/name.ss b/collects/tests/mzscheme/name.ss
new file mode 100644
index 0000000000..3bd1c9e85d
--- /dev/null
+++ b/collects/tests/mzscheme/name.ss
@@ -0,0 +1,105 @@
+
+; Test MzScheme's name inference
+
+(load-relative "loadtest.ss")
+
+(require (lib "class.ss"))
+(require (lib "unit.ss"))
+
+(SECTION 'NAMES)
+
+(arity-test object-name 1 1)
+(test #f object-name 0)
+(test #f object-name 'hello)
+(test #f object-name "hi")
+
+(define (src-name? s)
+  (and (symbol? s)
+       (regexp-match ":[0-9]+.[0-9]+$" (symbol->string s))
+       #t))
+
+; Test ok when no name for proc
+(test #t src-name? (object-name (lambda () 0)))
+(test #t src-name? (object-name (case-lambda)))
+(test #t src-name? (object-name (case-lambda [(x) 9])))
+(test #t src-name? (object-name (case-lambda [(x) 9][(y z) 12])))
+
+; Test constructs that don't provide a name
+(test #t src-name? (object-name (let ([x (cons (lambda () 10) 0)]) (car x))))
+(test #t src-name? (object-name (let ([x (let ([y (lambda (x) x)]) (y (lambda () 10)))]) x)))
+
+; Test ok when name for proc
+(define f (lambda () 0))
+(define f2 (lambda (a) 0))
+(define f3 (case-lambda))
+(define f4 (case-lambda [(x) 9]))
+(define f5 (case-lambda [(x) 9][(y z) 10]))
+
+(test 'f object-name f)
+(test 'f2 object-name f2)
+(test 'f3 object-name f3)
+(test 'f4 object-name f4)
+(test 'f5 object-name f5)
+
+; Test constructs that do provide a name
+(test 'a object-name (let ([a (lambda () 0)]) a))
+(test 'a object-name (let ([a (lambda () 0)]) (let ([b a]) b)))
+(test 'b object-name (let* ([b (lambda () 0)]) b))
+(test 'c object-name (letrec ([c (lambda () 0)]) c))
+(test 'loop object-name (let loop () loop))
+
+(test 'd object-name (let ([d (begin (lambda () x))]) d))
+(test 'e object-name (let ([e (begin0 (lambda () x))]) e))
+
+(test 'd2 object-name (let ([d2 (begin 7 (lambda () x))]) d2))
+(test 'e2 object-name (let ([e2 (begin0 (lambda () x) 7)]) e2))
+
+(test 'd3 object-name (let ([d3 (begin (cons 1 2) (lambda () x))]) d3))
+(test 'e3 object-name (let ([e3 (begin0 (lambda () x) (cons 1 2))]) e3))
+
+(test 'f object-name (let ([f (begin0 (begin (cons 1 2) (lambda () x)) (cons 1 2))]) f))
+
+(test 'g1 object-name (let ([g1 (if (cons 1 2) (lambda () x) #f)]) g1))
+(test 'g2 object-name (let ([g2 (if (negative? (car (cons 1 2))) #t (lambda () x))]) g2))
+
+(test 'w object-name (let ([w (let ([x 5]) (lambda () x))]) w))
+(test 'z object-name (let ([z (let ([x 5]) (cons 1 2) (lambda () x))]) z))
+
+(set! f (lambda () 10))
+(test 'f object-name f)
+
+; Test class stuff ok when no name
+(test #t src-name? (object-name (class object% () (super-make-object))))
+(test #t src-name? (object-name (interface ())))
+
+; Test class stuff ok when name
+(test 'class:c1 object-name (let ([c1 (class object% () (super-make-object))]) c1))
+(test 'interface:i1 object-name (let ([i1 (interface ())]) i1))
+
+; Test unit stuff ok when no name
+(test #t src-name? (object-name (unit (import) (export))))
+(test #t src-name? (object-name (compound-unit (import) (link) (export))))
+
+; Test unit stuff ok when name
+(test 'unit:u1 object-name (let ([u1 (unit (import) (export))]) u1))
+(test 'unit:u2 object-name (let ([u2 (compound-unit (import) (link) (export))]) u2))
+
+(test 'x object-name (invoke-unit
+		       (unit (import) (export) (define x (lambda () 0)) x)))
+(test 'x2 object-name (invoke-unit
+		        (unit (import) (export x2) (define x2 (lambda () 0)) x2)))
+
+;; Use external name instead?:
+(test 'x object-name (invoke-unit
+		       (unit (import) (export (x x3)) (define x (lambda () 0)) x)))
+
+; Test case sensitivity
+(parameterize ([read-case-sensitive #t])
+  (test (string->symbol "Capital")
+	object-name
+	(eval (read (open-input-string "(let ([Capital (lambda () 10)]) Capital)"))))
+  (test (string->symbol "make-CP")
+	object-name
+	(eval (read (open-input-string "(let-struct CP (a) make-CP)")))))
+
+(report-errs)
diff --git a/collects/tests/mzscheme/namespac.ss b/collects/tests/mzscheme/namespac.ss
new file mode 100644
index 0000000000..70f81c5db3
--- /dev/null
+++ b/collects/tests/mzscheme/namespac.ss
@@ -0,0 +1,111 @@
+
+(load-relative "loadtest.ss")
+
+(SECTION 'namespaces)
+
+(arity-test eval 1 2)
+(arity-test compile 1 1)
+(arity-test compiled-expression? 1 1)
+
+(test #f compiled-expression? 1)
+(test #t values (compiled-expression? (compile 1)))
+(test #t values (compiled-expression? (let ([c (compile 1)]
+					    [p (open-output-bytes)])
+					(display c p)
+					(parameterize ([read-accept-compiled #t])
+					  (read (open-input-bytes (get-output-bytes p)))))))
+
+(test `,void eval `',void)
+
+(test car eval 'car (scheme-report-environment 5))
+(err/rt-test (eval 'car (null-environment 5)) exn:fail:contract:variable?)
+(err/rt-test (eval 'lambda (null-environment 5)) exn:fail:syntax?)
+(err/rt-test (eval 'lambda (scheme-report-environment 5)) exn:fail:syntax?)
+(err/rt-test (eval 'lambda (null-environment 5)) exn:fail:syntax?)
+
+; Test primitive-name
+(let ([gvl (parameterize ([current-namespace (make-namespace)]) 
+	     (map (lambda (s)
+		    (cons s (with-handlers ([exn:fail? (lambda (x) #f)])
+			      (namespace-variable-value s))))
+		  (namespace-mapped-symbols)))]
+      [aliases (list (cons "call/cc" "call-with-current-continuation")
+		     (cons "call/ec" "call-with-escape-continuation")
+		     (cons "interaction-environment" "current-namespace"))])
+  (test #t 'names
+	(andmap
+	 (lambda (nv-pair)
+	   (let ([name (car nv-pair)]
+		 [value (cdr nv-pair)])
+	     (or (not (primitive? value))
+		 (let* ([s (symbol->string name)]
+			[sr (if (char=? #\# (string-ref s 0))
+				(substring s 2 (string-length s))
+				s)]
+			[st (let ([m (assoc sr aliases)])
+			      (if m
+				  (cdr m)
+				  sr))])
+		   (or (equal? st (symbol->string (object-name value)))
+		       (and (fprintf (current-error-port)
+				     "different: ~s ~s~n" st (object-name value))
+			    #f))))))
+	 gvl)))
+
+(define (test-empty . flags)
+  (let ([e (apply make-namespace flags)]
+	[orig (current-namespace)])
+    (parameterize ([current-namespace e])
+      (test null namespace-mapped-symbols)
+      (test 'unbound 'empty-namespace
+	    (with-handlers ([void (lambda (exn) 'unbound)])
+	      (eval 'car)))
+      (test 'unbound 'empty-namespace
+	    (with-handlers ([void (lambda (exn) 'unbound)])
+	      (eval '#%car)))
+      (namespace-set-variable-value! 'hello 5)
+      (namespace-attach-module orig 'mzscheme)
+      (namespace-require '(rename mzscheme #%top #%top))
+      (test 5 'empty-namespace (eval 'hello))
+      (test #t 'top+hello (let ([s (namespace-mapped-symbols)])
+			    (or (equal? s '(#%top hello))
+				(equal? s '(hello #%top))))))))
+(test-empty 'empty)
+
+(arity-test namespace-mapped-symbols 0 1)
+(arity-test namespace-variable-value 1 4)
+(arity-test namespace-set-variable-value! 2 4)
+(arity-test namespace-undefine-variable! 1 2)
+
+(define n (make-namespace))
+(test #t 'same-with-arg-and-param
+      ((lambda (a b)
+	 (and (andmap (lambda (ai) (memq ai b)) a)
+	      (andmap (lambda (bi) (memq bi a)) b)
+	      #t))
+       (parameterize ([current-namespace n])
+	 (namespace-mapped-symbols))
+       (namespace-mapped-symbols n)))
+
+(test (void) namespace-set-variable-value! 'foo 17 #t n)
+(test 17 namespace-variable-value 'foo #t #f n)
+(test (void) namespace-set-variable-value! 'lambda 18 #t n)
+(test 18 namespace-variable-value 'lambda #t #f n)
+(test (void) namespace-set-variable-value! 'define 19 #f n)
+(test 19 namespace-variable-value 'define #f #f n)
+(test 20 namespace-variable-value 'define #t (lambda () 20) n)
+(test 21 'stx-err (with-handlers ([exn:fail:syntax? (lambda (x) 21)])
+		    (namespace-variable-value 'define #t #f n)))
+(test 22 'stx-err (with-handlers ([exn:fail:contract:variable? (lambda (x) 22)])
+		    (namespace-variable-value 'not-ever-defined #t #f n)))
+(test 23 'stx-err (with-handlers ([exn:fail:contract:variable? (lambda (x) 23)])
+		    (namespace-variable-value 'define-values #f #f n)))
+(test (void) namespace-undefine-variable! 'foo n)
+(test 25 namespace-variable-value 'foo #t (lambda () 25) n)
+(parameterize ([current-namespace n])
+  (test (void) namespace-set-variable-value! 'bar 27)
+  (test 27 namespace-variable-value 'bar)
+  (test (void) namespace-undefine-variable! 'bar)
+  (test 28 namespace-variable-value 'bar #t (lambda () 28)))
+
+(report-errs)
diff --git a/collects/tests/mzscheme/nch.ss b/collects/tests/mzscheme/nch.ss
new file mode 100644
index 0000000000..45398e6fb7
--- /dev/null
+++ b/collects/tests/mzscheme/nch.ss
@@ -0,0 +1,30 @@
+
+(define (fact n)
+  (if (zero? n)
+      1
+      (* n (fact (- n 1)))))
+
+(define f1000 (fact 1000))
+
+(define (divall n d)
+  (if (<= n 1)
+      d
+      (divall (/ n d) (+ 1 d))))
+
+(define (nch n c)
+  (/ (fact n) (fact (- n c)) (fact c)))
+
+(define (snch n)
+  (letrec ((loop
+	    (lambda (i)
+	      (if (> i n)
+		  0
+		  (+ (nch n i) (loop (+ i 1)))))))
+    (loop 0)))
+
+(define (fsum n)
+  (if (zero? n)
+      1
+      (+ (fact n) (fsum (- n 1)))))
+
+
diff --git a/collects/tests/mzscheme/net.ss b/collects/tests/mzscheme/net.ss
new file mode 100644
index 0000000000..7f39274eae
--- /dev/null
+++ b/collects/tests/mzscheme/net.ss
@@ -0,0 +1,346 @@
+
+(load-relative "loadtest.ss")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; url.ss tests
+;;
+
+(require (lib "url.ss" "net")
+	 (lib "uri-codec.ss" "net")
+         (lib "string.ss"))
+
+(test "%Pq" uri-decode "%Pq")
+(test "%P" uri-decode "%P")
+(test "a=hel%2blo+%e7%88%b8" alist->form-urlencoded '((a . "hel+lo \u7238")))
+(test '((a . "hel+lo \u7238")) form-urlencoded->alist (alist->form-urlencoded '((a . "hel+lo \u7238"))))
+(test "a=hel%2blo;b=good-bye" alist->form-urlencoded '((a . "hel+lo") (b . "good-bye")))
+(parameterize ([current-alist-separator-mode 'semi])
+  (test "a=hel%2blo;b=good-bye" alist->form-urlencoded '((a . "hel+lo") (b . "good-bye"))))
+(parameterize ([current-alist-separator-mode 'amp])
+  (test "a=hel%2blo&b=good-bye" alist->form-urlencoded '((a . "hel+lo") (b . "good-bye"))))
+(test '((a . "hel+lo") (b . "good-bye")) form-urlencoded->alist (alist->form-urlencoded '((a . "hel+lo") (b . "good-bye"))))
+(parameterize ([current-alist-separator-mode 'amp])
+  (test '((a . "hel+lo") (b . "good-bye")) form-urlencoded->alist (alist->form-urlencoded '((a . "hel+lo") (b . "good-bye")))))
+(test '((a . "hel+lo") (b . "good-bye")) form-urlencoded->alist 
+      (parameterize ([current-alist-separator-mode 'amp])
+	(alist->form-urlencoded '((a . "hel+lo") (b . "good-bye")))))
+(parameterize ([current-alist-separator-mode 'semi])
+  (test '((a . "hel+lo&b=good-bye")) form-urlencoded->alist 
+	(parameterize ([current-alist-separator-mode 'amp])
+	  (alist->form-urlencoded '((a . "hel+lo") (b . "good-bye"))))))
+(parameterize ([current-alist-separator-mode 'amp])
+  (test '((a . "hel+lo;b=good-bye")) form-urlencoded->alist 
+	(parameterize ([current-alist-separator-mode 'semi])
+	  (alist->form-urlencoded '((a . "hel+lo") (b . "good-bye"))))))
+
+(test 'amp-or-semi current-alist-separator-mode)
+(err/rt-test (current-alist-separator-mode 'bad))
+
+(let ([with-censor (load-relative "censor.ss")])
+  (with-censor
+   (lambda ()
+     ;; Test all ASCII chars
+     (let ([p (let loop ([n 0])
+		(if (= n 128)
+		    null
+		    (let ([s (string (char-downcase (integer->char n)))])
+		      (cons (cons (string->symbol s) s)
+			    (loop (add1 n))))))])
+       (test p form-urlencoded->alist (alist->form-urlencoded p))
+       (let ([l (apply string-append (map cdr p))])
+	 (test l uri-decode (uri-encode l)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; tests adapted from Noel Welsh's original test suite
+;;
+
+(let ()
+  (define-syntax (for stx)
+    (syntax-case stx (code)
+      [(_ (i from to) e)
+       (and (identifier? (syntax code))
+            (number? (syntax-e (syntax from)))
+            (number? (syntax-e (syntax to))))
+       (syntax (let loop ([i from])
+                 e
+                 (unless (= i to)
+                   (loop (+ i 1)))))]))
+  
+  
+  (test "hello" uri-encode "hello")
+  (test "hello%20there" uri-encode "hello there")
+  
+  (let ((pad (lambda (str)
+               (if (= (string-length str) 1)
+                   (string-append "0" str)
+                   str))))
+    (for (code 0 127)
+         (if (or (= code 45) (= code 33) (= code 95)
+                 (= code 46) (= code 126) (= code 42)
+                 (= code 39) (= code 40) (= code 41) 
+                 (and (<= 48 code) (<= code 57))   ; 0-9
+                 (and (<= 65 code) (<= code 90))   ; A-Z
+                 (and (<= 97 code) (<= code 122))) ; a-z
+             (test (string (integer->char code)) uri-encode (string (integer->char code)))
+             (test (string-append "%" (pad (number->string code 16)))
+                   uri-encode
+                   (string (integer->char code))))))
+  
+  
+  (test "" alist->form-urlencoded '())
+  (test "key=hello+there" alist->form-urlencoded '((key . "hello there")))
+  (test "key1=hi;key2=hello" alist->form-urlencoded '((key1 . "hi") (key2 . "hello")))
+  (test "key1=hello+there" alist->form-urlencoded '((key1 . "hello there")))
+  
+  (test "hello" uri-decode "hello")
+  (test "hello there" uri-decode "hello%20there")
+  
+  (let* ((pad (lambda (str)
+                (if (= (string-length str) 1)
+                    (string-append "0" str)
+                    str)))
+         (uppercase (lambda (str)
+                      (string-uppercase! str)
+                      str))
+         (lowercase (lambda (str)
+                      (string-lowercase! str)
+                      str))
+         (hexcode (lambda (code)
+                    (string-append "%"
+                                   (pad (number->string code 16))))))
+
+    ;; each of the next three of these were going from 0 to 255 in Noel's
+    ;; original test suite. Those fail here, however.
+    
+    (for (code 0 127)
+         (test (string (integer->char code)) uri-decode (uppercase (hexcode code))))
+    (for (code 0 127)
+         (test (string (integer->char code)) uri-decode (lowercase (hexcode code)))))
+  
+  (for (code 0 127)
+       (test (string (integer->char code)) uri-decode (string (integer->char code))))
+  
+  ;; form-urlencoded->alist
+  (test '() form-urlencoded->alist "")
+  (test '((key . "value")) form-urlencoded->alist "key=value")
+  (test '((key . "hello there")) form-urlencoded->alist "key=hello+there")
+  (test '((key . "a value")) form-urlencoded->alist "key=a%20value")
+  (test '((key . ""))  form-urlencoded->alist "key")
+  (test '((key1 . "value 1") (key2 . "value 2")) form-urlencoded->alist "key1=value+1&key2=value+2"))
+
+;;
+;; end Noel's original tests
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(let ()
+  (define (test-s->u vec str)
+    (define (string->url/vec str) (url->vec (string->url str)))
+    (define (url/vec->string vec) (url->string (vec->url vec)))
+    (test vec string->url/vec str)
+    (test str url/vec->string vec))
+  
+  (define (test-c-u/r expected base relative)
+    (define (combine-url/relative-vec x y)
+      (url->vec (combine-url/relative (vec->url x) y)))
+    (test (url->vec expected) combine-url/relative-vec (url->vec base) relative))
+  
+  (define (vec->url vec)
+    (make-url
+     (vector-ref vec 0)
+     (vector-ref vec 1)
+     (vector-ref vec 2)
+     (vector-ref vec 3)
+     (map (lambda (x) (if (string? x)
+                          x
+                          (make-path/param (vector-ref x 0) (vector-ref x 1))))
+          (vector-ref vec 4))
+     (vector-ref vec 5)
+     (vector-ref vec 6)))
+  
+  (define (url->vec url)
+    (vector (url-scheme url)
+            (url-user url)
+            (url-host url)
+            (url-port url)
+            (map (lambda (x) (if (string? x)
+                                 x
+                                 (vector (path/param-path x) (path/param-param x))))
+                 (url-path url))
+            (url-query url)
+            (url-fragment url)))
+  
+  (test-s->u (vector #f #f #f #f '("") '() #f)
+             "/")
+  (test-s->u (vector #f #f #f #f '() '() #f)
+             "")
+  (test-s->u (vector "http" #f "www.drscheme.org" #f '("") '() #f)
+             "http://www.drscheme.org/")
+  (test-s->u (vector "http" #f "www.drscheme.org" #f (list "a" "b" "c") '() #f)
+             "http://www.drscheme.org/a/b/c")
+  (test-s->u (vector "http" "robby" "www.drscheme.org" #f (list "a" "b" "c") '() #f)
+             "http://robby@www.drscheme.org/a/b/c")
+  (test-s->u (vector "http" #f "www.drscheme.org" 8080 (list "a" "b" "c") '() #f)
+             "http://www.drscheme.org:8080/a/b/c")
+  (test-s->u (vector "http" #f "www.drscheme.org" #f (list "a" "b" "c") '() "joe")
+             "http://www.drscheme.org/a/b/c#joe")
+  (test-s->u (vector "http" #f "www.drscheme.org" #f (list "a" "b" "c") '((tim . "")) #f)
+             "http://www.drscheme.org/a/b/c?tim=")
+  (test-s->u (vector "http" #f "www.drscheme.org" #f (list "a" "b" "c") '((tim . "")) "joe")
+             "http://www.drscheme.org/a/b/c?tim=#joe")
+  (test-s->u (vector "http" #f "www.drscheme.org" #f (list "a" "b" "c") '((tim . "tim")) "joe")
+             "http://www.drscheme.org/a/b/c?tim=tim#joe")
+  (test-s->u (vector "http" #f "www.drscheme.org" #f (list "a" "b" "c") '((tam . "tom")) "joe")
+             "http://www.drscheme.org/a/b/c?tam=tom#joe")
+  (test-s->u (vector "http" #f "www.drscheme.org" #f (list "a" "b" "c") '((tam . "tom") (pam . "pom")) "joe")
+             "http://www.drscheme.org/a/b/c?tam=tom;pam=pom#joe")
+  (parameterize ([current-alist-separator-mode 'semi])  
+    (test-s->u (vector "http" #f "www.drscheme.org" #f (list "a" "b" "c") '((tam . "tom") (pam . "pom")) "joe")
+	       "http://www.drscheme.org/a/b/c?tam=tom;pam=pom#joe"))
+  (parameterize ([current-alist-separator-mode 'amp])  
+    (test-s->u (vector "http" #f "www.drscheme.org" #f (list "a" "b" "c") '((tam . "tom") (pam . "pom")) "joe")
+	       "http://www.drscheme.org/a/b/c?tam=tom&pam=pom#joe"))
+  (test-s->u (vector "http" #f "www.drscheme.org" #f (list "a" "b" #("c" "b")) '() #f)
+             "http://www.drscheme.org/a/b/c;b")
+  (test-s->u (vector "http" #f "www.drscheme.org" #f (list #("a" "x") "b" #("c" "b")) '() #f)
+             "http://www.drscheme.org/a;x/b/c;b")
+    
+  ;; test unquoting for %
+  (test-s->u (vector "http" #f "www.drscheme.org" #f (list "a" "b" "c") '((ti#m . "")) "jo e")
+             "http://www.drscheme.org/a/b/c?ti%23m=#jo%20e")
+  (test-s->u (vector "http" #f "www.drscheme.org" #f (list #("a " " a") " b " " c ") '() #f)
+             "http://www.drscheme.org/a ; a/ b / c ")
+  (test-s->u (vector "http" "robb y" "www.drscheme.org" #f '("") '() #f)
+             "http://robb%20y@www.drscheme.org/")
+  
+  (let ([empty-url (make-url #f #f #f #f '() '() #f)])
+    (test-c-u/r (string->url "http://www.drscheme.org")
+                empty-url
+                "http://www.drscheme.org")
+    (test-c-u/r (string->url "http://www.drscheme.org")
+                (string->url "http://www.drscheme.org")
+                ""))
+  
+  (test-c-u/r (string->url "http://www.mzscheme.org")
+              (string->url "http://www.drscheme.org/")
+              "http://www.mzscheme.org")
+  (test-c-u/r (string->url "http://www.drscheme.org/index.html")
+              (string->url "http://www.drscheme.org/")
+              "index.html")
+  (test-c-u/r (string->url "http://www.drscheme.org/index.html")
+              (string->url "http://www.drscheme.org/")
+              "/index.html")
+  (test-c-u/r (string->url "http://www.drscheme.org/index.html")
+              (string->url "http://www.drscheme.org/a/b/c/")
+              "/index.html")
+  (test-c-u/r (string->url "http://www.drscheme.org/a/b/index.html")
+              (string->url "http://www.drscheme.org/a/b/c")
+              "index.html")
+  (test-c-u/r (string->url "http://www.drscheme.org/a/b/c/index.html")
+              (string->url "http://www.drscheme.org/a/b/c/")
+              "index.html")
+  (test-c-u/r (string->url "http://www.drscheme.org/a/b/d/index.html")
+              (string->url "http://www.drscheme.org/a/b/c")
+              "d/index.html")
+  (test-c-u/r (string->url "http://www.drscheme.org/a/b/c/d/index.html")
+              (string->url "http://www.drscheme.org/a/b/c/")
+              "d/index.html")
+  
+  (test-c-u/r (string->url "file:///a/b/c/d/index.html")
+              (string->url "file:///a/b/c/")
+              "d/index.html")
+  (test-c-u/r (string->url "file:///a/b/d/index.html")
+              (string->url "file:///a/b/c")
+              "d/index.html")
+  )
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; other net tests
+;;
+
+(require (lib "base64.ss" "net")
+	 (lib "qp.ss" "net")
+	 (lib "port.ss"))
+
+(define tricky-strings
+  (let ([dir (collection-path "tests" "mzscheme")])
+    (list (make-bytes 200 32)
+	  (make-bytes 200 9)
+	  (make-bytes 200 (char->integer #\x))
+	  (list->bytes
+	   (let loop ([i 0])
+	     (if (= i 256)
+		 null
+		 (cons i (loop (add1 i))))))
+	  ;; Something that doesn't end with a LF:
+	  (bytes-append 
+	   (with-input-from-file (build-path dir "net.ss") (lambda () (read-bytes 500)))
+	   #"xxx")
+	  ;; CRLF:
+	  (regexp-replace
+	   #rx#"\n"
+	   (with-input-from-file (build-path dir "net.ss") (lambda () (read-bytes 500)))
+	   #"\r\n"))))
+
+(define (check-same encode decode port line-rx max-w)
+  (let ([p (open-output-bytes)])
+    (copy-port port p)
+    (let ([bytes (get-output-bytes p)]
+	  [r (open-output-bytes)])
+      (encode (open-input-bytes bytes) r)
+      (let ([p (open-input-bytes (get-output-bytes r))])
+	(let loop ()
+	  (let ([l (read-bytes-line p 'any)])
+	    (unless (eof-object? l)
+	      (unless (<= (bytes-length l) max-w)
+		(test encode "line too long" l))
+	      (let ([m (regexp-match-positions line-rx l)])
+		(unless (and m
+			     (= (bytes-length l) (cdar m)))
+		  (test encode 'bad-line l)))
+	      (loop))))
+	(let ([q (open-output-bytes)])
+	  (decode (open-input-bytes (get-output-bytes r)) q)
+	  (unless (equal? (get-output-bytes q) bytes)
+	    (with-output-to-file "/tmp/x0" (lambda () (display (get-output-bytes r))) 'truncate)
+	    (with-output-to-file "/tmp/x1" (lambda () (display (get-output-bytes q))) 'truncate)
+	    (with-output-to-file "/tmp/x2" (lambda () (display bytes)) 'truncate)
+	    (error 'decode "failed")))))))
+
+(define (check-same-file encode decode file line-rx max-w)
+  ;; This "test" is really just a progress report:
+  (test #t list? (list file encode))
+  (call-with-input-file file
+    (lambda (p)
+      (check-same encode decode p line-rx max-w))))
+
+(define (check-same-all encode decode line-rx max-w)
+  (for-each (lambda (tricky-string)
+	      (check-same encode decode 
+			  (open-input-bytes tricky-string)
+			  line-rx max-w))
+	    tricky-strings)
+  (parameterize ([current-pseudo-random-generator (make-pseudo-random-generator)])
+    (random-seed 17)
+    (let ([dir (collection-path "tests" "mzscheme")])
+      (for-each (lambda (p)
+		  (when (regexp-match #rx"[.]ss$" (path->string p))
+		    (unless (or (positive? (random 10)) ; check random 1/10 of files
+				(equal? (path->string p) "flat.ss"))
+		      (check-same-file encode decode (build-path dir p) line-rx max-w))))
+		(directory-list dir)))))
+
+(check-same-all (lambda (i o) (qp-encode-stream i o))
+		qp-decode-stream
+		#rx#"^(|[\t \41-\176]*[\41-\176]+)$"
+		76)
+
+(check-same-all base64-encode-stream 
+		base64-decode-stream
+		#rx#"^[0-9a-zA-Z+=/]*$"
+		72)
+
+(report-errs)
diff --git a/collects/tests/mzscheme/number.ss b/collects/tests/mzscheme/number.ss
new file mode 100644
index 0000000000..10d092d1a1
--- /dev/null
+++ b/collects/tests/mzscheme/number.ss
@@ -0,0 +1,2518 @@
+
+(load-relative "loadtest.ss")
+
+(SECTION 'numbers)
+
+(SECTION 6 5 5)
+(test #f number? 'a)
+(test #f complex? 'a)
+(test #f real? 'a)
+(test #f rational? 'a)
+(test #f integer? 'a)
+
+(test #t number? 3)
+(test #t complex? 3)
+(test #t real? 3)
+(test #t rational? 3)
+(test #t integer? 3)
+
+(test #t number? 3.0)
+(test #t complex? 3.0)
+(test #t real? 3.0)
+(test #t rational? 3.0)
+(test #t integer? 3.0)
+
+(test #t number? 3.1)
+(test #t complex? 3.1)
+(test #t real? 3.1)
+(test #t rational? 3.1)
+(test #f integer? 3.1)
+
+(test #t number? 3/2)
+(test #t complex? 3/2)
+(test #t real? 3/2)
+(test #t rational? 3/2)
+(test #f integer? 3/2)
+
+(test #t number? 3+i)
+(test #t complex? 3+i)
+(test #f real? 3+i)
+(test #f rational? 3+i)
+(test #f integer? 3+i)
+
+(test #t number? 3.0+0i)
+(test #t complex? 3.0+0i)
+(test #t real? 3.0+0i)
+(test #t rational? 3.0+0i)
+(test #t integer? 3.0+0i)
+
+(test #t number? 3.0+0.0i)
+(test #t complex? 3.0+0.0i)
+(test #t real? 3.0+0.0i)
+(test #t rational? 3.0+0.0i)
+(test #t integer? 3.0+0.0i)
+
+(test #t number? 3.1+0.0i)
+(test #t complex? 3.1+0.0i)
+(test #t real? 3.1+0.0i)
+(test #t rational? 3.1+0.0i)
+(test #f integer? 3.1+0.0i)
+
+(test #t exact? 3)
+(test #t exact? 3/4)
+(test #f exact? 3.0)
+(test #t exact? (expt 2 100))
+(test #t exact? 3+4i)
+(test #f exact? 3.0+4i)
+
+(test #f inexact? 3)
+(test #f inexact? 3/4)
+(test #t inexact? 3.0)
+(test #f inexact? (expt 2 100))
+(test #f inexact? 3+4i)
+(test #t inexact? 3.0+4i)
+(test #t inexact? 0+4.0i)
+(test #t inexact? 4+0.i)
+
+(test #t complex? -4.242154731064108e-5-6.865001427422244e-5i)
+(test #f exact? -4.242154731064108e-5-6.865001427422244e-5i)
+(test #t inexact? -4.242154731064108e-5-6.865001427422244e-5i)
+
+(test #t complex? -4.242154731064108f-5-6.865001427422244f-5i)
+(test #f exact? -4.242154731064108f-5-6.865001427422244f-5i)
+(test #t inexact? -4.242154731064108f-5-6.865001427422244f-5i)
+
+(test #t number? +inf.0)
+(test #t complex? +inf.0)
+(test #t real? +inf.0)
+(test #t rational? +inf.0)
+(test #t integer? +inf.0)
+
+(test #t number? -inf.0)
+(test #t complex? -inf.0)
+(test #t real? -inf.0)
+(test #t rational? -inf.0)
+(test #t integer? -inf.0)
+
+(test #t number? +nan.0)
+(test #t complex? +nan.0)
+(test #t real? +nan.0)
+(test #t rational? +nan.0)
+(test #f integer? +nan.0)
+
+(arity-test inexact? 1 1)
+(arity-test number? 1 1)
+(arity-test complex? 1 1)
+(arity-test real? 1 1)
+(arity-test rational? 1 1)
+(arity-test integer? 1 1)
+(arity-test exact? 1 1)
+(arity-test inexact? 1 1)
+
+(err/rt-test (exact? 'a))
+(err/rt-test (inexact? 'a))
+
+(test "+inf.0" number->string +inf.0)
+(test "-inf.0" number->string -inf.0)
+(test "+nan.0" number->string +nan.0)
+(test "+nan.0" number->string +nan.0)
+
+(map (lambda (n)
+       ;; test that fresh strings are generated:
+       (let ([n1 (number->string n)]
+	     [n2 (number->string n)])
+	 (string-set! n1 0 #\?)
+	 (test n2 number->string n)
+	 (test n1 string-append "?" (substring n2 1 (string-length n2)))))
+     '(+inf.0 -inf.0 +nan.0 -nan.0 0.0 -0.0 0 1/2 3.4 1+2i))
+
+(test #t = 0.0 -0.0)
+(test #t eqv? 0.0 -0.0)
+
+(test #t = 22 22 22)
+(test #t = 22 22)
+(test #f = 34 34 35)
+(test #f = 34 35)
+(test #t > 3 -6246)
+(test #f > 9 9 -2424)
+(test #t >= 3 -4 -6246)
+(test #t >= 9 9)
+(test #f >= 8 9)
+(test #t < -1 2 3 4 5 6 7 8)
+(test #f < -1 2 3 4 4 5 6 7)
+(test #t <= -1 2 3 4 5 6 7 8)
+(test #t <= -1 2 3 4 4 5 6 7)
+(test #f < 1 3 2)
+(test #f >= 1 3 2)
+
+(define (test-compare lo m hi) ; all positive!
+  (define -lo (- lo))
+  (define -m (- m))
+  (define -hi (- hi))
+
+  (define (test-lh l h)
+    (test #f > l h)
+    (test #t < l h)
+    (test #f = l h)
+    (test #f >= l h)
+    (test #t <= l h))
+
+  (define (test-hl h l)
+    (test #t > h l)
+    (test #f < h l)
+    (test #f = h l)
+    (test #t >= h l)
+    (test #f <= h l))
+
+  (define (test-zero z)
+    (test-hl m z)
+    (test-lh -m z)
+    (test-hl z -m)
+    (test-lh z m))
+
+  (test-lh m hi)
+  (test-hl -m -hi)
+
+  (test #f > m m)
+  (test #f < m m)
+  (test #t = m m)
+  (test #t >= m m)
+  (test #t <= m m)
+
+  (test-hl m -m)
+  (test-lh -m m)
+
+  (test-hl m lo)
+  (test-lh -m -lo)
+
+  (test-zero 0)
+  (test-zero 0.0))
+  
+(test-compare 0.5 1.2 2.3)
+(test-compare 2/5 1/2 2/3)
+(test #t = 1/2 2/4)
+(test #f = 2/3 2/5)
+(test #f = 2/3 2/500000000000000000000000000)
+
+(test-compare 0.5 6/5 2.3)
+(test-compare 1 11922615739/10210200 3000)
+(test-compare 1.0 11922615739/10210200 3000.0)
+
+(test-compare 0.4+0.i 1/2 2.3+0.i)
+
+(test #f > 0 (/ 1 (expt 2 400)))
+
+(test #t < 0.5 2/3)
+(test #f < 2/3 0.5)
+(test #t = 0.5 1/2)
+(test #t = +0.5i +1/2i)
+(test #f = +0.5i 1+1/2i)
+(test #t = 1 1.0+0i)
+(test #t = 1 1.0+0.0i)
+(test #f eqv? 1.0 1.0+0.0i)
+(test #t eqv? 1.0-0.0i 1.0+0.0i)
+
+(test #f = 1+2i 2+i)
+
+;; Test transitivity in mixed exact--inexact settings
+;; (Thanks again to Aubrey Jaffer for the starting point.)
+(define (test-trans expect op nop a b c)
+  ;; Make sure the tests check what we want to check:
+  (test #t = (exact->inexact a) b)
+  (test #t = (exact->inexact c) b)
+  (test #t = (exact->inexact (- a)) (- b))
+  (test #t = (exact->inexact (- c)) (- b))
+  ;; The real tests:
+  (test expect op a b)
+  (test expect op b c)
+  (test expect op a b c)
+  (test expect nop (- a) (- b))
+  (test expect nop (- b) (- c))
+  (test expect nop (- a) (- b) (- c))
+  (test expect nop c b)
+  (test expect nop b a)
+  (test expect nop c b a)
+  (test expect op (- c) (- b))
+  (test expect op (- b) (- a))
+  (test expect op (- c) (- b) (- a)))
+(test-trans #t < >= 1237940039285380274899124223 1.2379400392853803e+27 1237940039285380274899124225)
+(test-trans #t < >= 3713820117856140824697372668/3 1.2379400392853803e+27 3713820117856140824697372676/3)
+(test-trans #f > <= 1237940039285380274899124223 1.2379400392853803e+27 1237940039285380274899124225)
+(test-trans #f > <= 3713820117856140824697372668/3 1.2379400392853803e+27 3713820117856140824697372676/3)
+(test-trans #f = = 1237940039285380274899124223 1.2379400392853803e+27 1237940039285380274899124225)
+(test-trans #f = = 3713820117856140824697372668/3 1.2379400392853803e+27 3713820117856140824697372676/3)
+(test-trans #t <= > 1237940039285380274899124223 1.2379400392853803e+27 1237940039285380274899124225)
+(test-trans #t <= > 3713820117856140824697372668/3 1.2379400392853803e+27 3713820117856140824697372676/3)
+(test-trans #f >= < 1237940039285380274899124223 1.2379400392853803e+27 1237940039285380274899124225)
+(test-trans #f >= < 3713820117856140824697372668/3 1.2379400392853803e+27 3713820117856140824697372676/3)
+
+(define (test-nan.0 f . args)
+  (apply test +nan.0 f args))
+
+(define (test-i-nan.0 f . args)
+  (apply test (make-rectangular +nan.0 +nan.0) f args))
+
+(define (test-nan c)
+  (test #f < +nan.0 c)
+  (test #f > +nan.0 c)
+  (test #f = +nan.0 c)
+  (test #f <= +nan.0 c)
+  (test #f >= +nan.0 c))
+(test-nan 0)
+(test-nan 0.0)
+(test-nan 0.3)
+(test-nan +nan.0)
+(test-nan +inf.0)
+(test-nan -inf.0)
+(test-nan 0.3+0.0i)
+(test #f = +nan.0 1+2i)
+(test #f = +nan.0 (make-rectangular +inf.0 -inf.0))
+
+(test-compare 999999999999 1000000000000 1000000000001)
+(define big-num (expt 2 1500))
+(test-compare (sub1 big-num) big-num (add1 big-num))
+(test-compare 1.0 (expt 10 100) 1e200)
+
+(define (inf-zero-test inf rx negnot)
+  (let ([inf-test-x
+	 (lambda (r v)
+	   (test r < v inf)
+	   (test (not r) > v inf)
+	   (test r <= v inf)
+	   (test (not r) >= v inf)
+	   
+	   (test (not r) < inf v)
+	   (test r > inf v)
+	   (test (not r) <= inf v)
+	   (test r >= inf v))])
+    (inf-test-x rx 5)
+    (inf-test-x (negnot rx) -5)
+    (inf-test-x rx big-num)
+    (inf-test-x (negnot rx) (- big-num))
+    (inf-test-x rx (/ big-num 3))
+    (inf-test-x (negnot rx) (/ (- big-num) 3))
+    (inf-test-x rx (/ 1 big-num))
+    (inf-test-x (negnot rx) (/ 1 (- big-num)))))
+(inf-zero-test +inf.0 #t (lambda (x) x))
+(inf-zero-test -inf.0 #f (lambda (x) x))
+(inf-zero-test 0.0 #f not)
+
+(err/rt-test (= 1 'a))
+(err/rt-test (= 1 1 'a))
+(err/rt-test (= 1 2 'a))
+(err/rt-test (= 'a 1))
+(err/rt-test (> 1 'a))
+(err/rt-test (> 1 0 'a))
+(err/rt-test (> 1 2 'a))
+(err/rt-test (> 'a 1))
+(err/rt-test (> 0.5+0.1i 1))
+(err/rt-test (> 1 0.5+0.1i))
+(err/rt-test (< 1 'a))
+(err/rt-test (< 1 2 'a))
+(err/rt-test (< 1 0 'a))
+(err/rt-test (< 'a 1))
+(err/rt-test (< 0.5+0.1i 1))
+(err/rt-test (< 1 0.5+0.1i))
+(err/rt-test (>= 1 'a))
+(err/rt-test (>= 1 1 'a))
+(err/rt-test (>= 1 2 'a))
+(err/rt-test (>= 'a 1))
+(err/rt-test (>= 0.5+0.1i 1))
+(err/rt-test (>= 1 0.5+0.1i))
+(err/rt-test (<= 1 'a))
+(err/rt-test (<= 1 1 'a))
+(err/rt-test (<= 1 0 'a))
+(err/rt-test (<= 'a 1))
+(err/rt-test (<= 0.5+0.1i 1))
+(err/rt-test (<= 1 0.5+0.1i))
+
+(arity-test = 2 -1)
+(arity-test < 2 -1)
+(arity-test > 2 -1)
+(arity-test <= 2 -1)
+(arity-test >= 2 -1)
+
+(test #t zero? 0)
+(test #t zero? 0.0)
+(test #t zero? +0.0i)
+(test #t zero? -0.0i)
+(test #t zero? 0.0+0.0i)
+(test #f zero? 1.0+0.0i)
+(test #f zero? 1.0+1.0i)
+(test #f zero? 0.0+1.0i)
+(test #t zero? 0/1)
+(test #f zero? 1)
+(test #f zero? -1)
+(test #f zero? -100)
+(test #f zero? 1.0)
+(test #f zero? -1.0)
+(test #f zero? 1/2)
+(test #f zero? -1/2)
+(test #f zero? -1/2+2i)
+(test #f zero? +inf.0)
+(test #f zero? -inf.0)
+(test #f zero? +nan.0)
+(test #f zero? (expt 2 37))
+(test #f zero? (expt -2 37))
+(test #t positive? 4)
+(test #f positive? -4)
+(test #f positive? 0)
+(test #t positive? 4.0)
+(test #f positive? -4.0)
+(test #f positive? 0.0)
+(test #t positive? 2/4)
+(test #f positive? -2/4)
+(test #f positive? 0/2)
+(test #t positive? +inf.0)
+(test #f positive? -inf.0)
+(test #f positive? +nan.0)
+(test #t positive? 5+0.0i)
+(test #f positive? -5+0.0i)
+(test #t positive? (expt 2 37))
+(test #f positive? (expt -2 37))
+(test #f negative? 4)
+(test #t negative? -4)
+(test #f negative? 0)
+(test #f negative? 4.0)
+(test #t negative? -4.0)
+(test #f negative? 0.0)
+(test #f negative? 2/4)
+(test #t negative? -2/4)
+(test #f negative? 0/4)
+(test #f negative? (expt 2 37))
+(test #t negative? (expt -2 37))
+(test #f negative? +inf.0)
+(test #t negative? -inf.0)
+(test #f negative? +nan.0)
+(test #f negative? 5+0.0i)
+(test #t negative? -5+0.0i)
+(test #t odd? 3)
+(test #f odd? 2)
+(test #f odd? -4)
+(test #t odd? -1)
+(test #t odd? +inf.0)
+(test #t odd? -inf.0)
+(test #t odd? 5+0.0i)
+(test #f odd? 4+0.0i)
+(test #f odd? (expt 2 37))
+(test #f odd? (expt -2 37))
+(test #t odd? (add1 (expt 2 37)))
+(test #t odd? (sub1 (expt -2 37)))
+(test #f even? 3)
+(test #t even? 2)
+(test #t even? -4)
+(test #f even? -1)
+(test #t even? +inf.0)
+(test #t even? -inf.0)
+(test #t even? 4+0.0i)
+(test #f even? 5+0.0i)
+(test #t even? (expt 2 37))
+(test #t even? (expt -2 37))
+(test #f even? (add1 (expt 2 37)))
+(test #f even? (sub1 (expt -2 37)))
+
+(arity-test zero? 1 1)
+(arity-test positive? 1 1)
+(arity-test negative? 1 1)
+(arity-test odd? 1 1)
+(arity-test even? 1 1)
+
+(err/rt-test (positive? 2+i))
+(err/rt-test (negative? 2+i))
+(err/rt-test (odd? 4.1))
+(err/rt-test (odd? 4.1+0.0i))
+(err/rt-test (odd? 4+1i))
+(err/rt-test (even? 4.1))
+(err/rt-test (even? 4.1+0.0i))
+(err/rt-test (even? 4+1i))
+(err/rt-test (even? +nan.0))
+
+(err/rt-test (positive? 'i))
+(err/rt-test (negative? 'i))
+(err/rt-test (odd? 'a))
+(err/rt-test (even? 'a))
+(err/rt-test (odd? 'i))
+(err/rt-test (even? 'i))
+
+(test 5 max 5)
+(test 5 min 5)
+(test 38 max 34 5 7 38 6)
+(test -24 min 3  5 5 330 4 -24)
+(test 38.0 max 34 5.0 7 38 6)
+(test -24.0 min 3  5 5 330 4 -24.0)
+(test 2/3 max 1/2 2/3)
+(test 2/3 max 2/3 1/2)
+(test 2/3 max 2/3 -4/5)
+(test 1/2 min 1/2 2/3)
+(test 1/2 min 2/3 1/2)
+(test -4/5 min 2/3 -4/5)
+(test +inf.0 max +inf.0 0 -inf.0)
+(test -inf.0 min +inf.0 0 -inf.0)
+(test-nan.0 max +inf.0 +nan.0 0 -inf.0)
+(test-nan.0 min +inf.0 0 +nan.0 -inf.0)
+(test 9.0 min 9.0+0.0i 100)
+(test 8.0 min 9.0+0.0i 8)
+(test 9.0 min 100 9.0+0.0i)
+(test 8.0 min 8 9.0+0.0i)
+(test 100.0 max 9.0+0.0i 100)
+(test 9.0 max 9.0+0.0i 8)
+(test 100.0 max 100 9.0+0.0i)
+(test 9.0 max 8 9.0+0.0i)
+
+(test (expt 5 27) max 9 (expt 5 27))
+(test (expt 5 29) max (expt 5 29) (expt 5 27))
+(test (expt 5 29) max (expt 5 27) (expt 5 29))
+(test (expt 5 27) max (expt 5 27) 9)
+(test (expt 5 27) max (expt 5 27) (- (expt 5 29)))
+(test (expt 5 27) max (- (expt 5 29)) (expt 5 27))
+(test (- (expt 5 27)) max (- (expt 5 27)) (- (expt 5 29)))
+(test (- (expt 5 27)) max (- (expt 5 29)) (- (expt 5 27)))
+(test 9 min 9 (expt 5 27))
+(test (expt 5 27) min (expt 5 29) (expt 5 27))
+(test (expt 5 27) min (expt 5 27) (expt 5 29))
+(test 9 min (expt 5 27) 9)
+(test (- (expt 5 29)) min (expt 5 27) (- (expt 5 29)))
+(test (- (expt 5 29)) min (- (expt 5 29)) (expt 5 27))
+(test (- (expt 5 29)) min (- (expt 5 27)) (- (expt 5 29)))
+(test (- (expt 5 29)) min (- (expt 5 29)) (- (expt 5 27)))
+
+(err/rt-test (max 0 'a))
+(err/rt-test (min 0 'a))
+(err/rt-test (max 'a 0))
+(err/rt-test (min 'a 0))
+(err/rt-test (max 'a))
+(err/rt-test (min 'a))
+(err/rt-test (min 2 4+i))
+(err/rt-test (max 2 4+i))
+(err/rt-test (min 4+i))
+(err/rt-test (max 4+i))
+
+(arity-test max 1 -1)
+(arity-test min 1 -1)
+
+(test 0 +)
+(test 7 + 3 4)
+(test 6 + 1 2 3)
+(test 7.0 + 3 4.0)
+(test 6.0 + 1 2.0 3)
+(test 19/12 + 1/4 1/3 1)
+(test +i + +i)
+(test 3/2+1i + 1 2+2i -i -3/2)
+(test 3 + 3)
+(test 0 +)
+(test 4 * 4)
+(test 16.0 * 4 4.0)
+(test 1 *)
+(test 6/25 * 3/5 1/5 2)
+(test #i+6/25 * 3/5 1/5 2.0)
+(test +6/25i * 3/5 1/5 2 +i)
+(test (make-rectangular 0 #i+6/25) * 3/5 1/5 2.0 +i)
+(test 18805208620685182736256260714897 
+      * (sub1 (expt 2 31))  
+      8756857658476587568751)
+(test 1073741874 + (- (expt 2 30) 50) 100) ; fixnum -> bignum for 32 bits
+(test -1073741874 - (- 50 (expt 2 30)) 100) ; fixnum -> bignum for 32 bits
+(test 10.0+0.0i + 9.0+0.0i 1)
+(test 10.0+0.0i + 9.0+0.0i 1-0.0i)
+(test 9.0+0.0i * 9.0+0.0i 1)
+(test 10.0-1.0i + 9.0+0.0i 1-1.0i)
+(test 0 * 0 10.0)
+(test 0 * 0 +inf.0)
+(test 0 * 0 +nan.0)
+(test 0 / 0 0.0)
+(test 0 / 0 +inf.0)
+(test 0 / 0 -inf.0)
+(test 0 / 0 +nan.0)
+(test -0.0 + 0 -0.0)
+(test -0.0 + -0.0 0)
+(test -0.0 - -0.0 0)
+
+(test -0.0 - 0.0)
+(test 0.0 - -0.0)
+(test -0.0 - 0 0.0)
+(test 0.0 - 0 -0.0)
+
+(arity-test * 0 -1)
+(arity-test + 0 -1)
+(arity-test - 1 -1)
+(arity-test / 1 -1)
+
+(test 2 add1 1)
+(test 0 add1 -1)
+(test 2.0 add1 1.0)
+(test 0.0 add1 -1.0)
+(test 3/2 add1 1/2)
+(test 1/2 add1 -1/2)
+(test 2.0+i add1 1.0+i)
+(test 0.0+i add1 -1.0+i)
+(test 0.0+0.0i add1 -1+0.0i)
+(test 0.0-0.0i add1 -1-0.0i)
+(test 1073741824 add1 #x3FFFFFFF) ; fixnum boundary case
+
+(err/rt-test (add1 "a"))
+(arity-test add1 1 1)
+
+(test 1 sub1 2)
+(test -2 sub1 -1)
+(test 1.0 sub1 2.0)
+(test -2.0 sub1 -1.0)
+(test -1/2 sub1 1/2)
+(test -3/2 sub1 -1/2)
+(test 1.0+i sub1 2.0+i)
+(test -2.0+i sub1 -1.0+i)
+(test -2.0+0.0i sub1 -1+0.0i)
+(test -2.0-0.0i sub1 -1-0.0i)
+(test -1073741824 sub1 -1073741823) ; fixnum boundary case
+
+(err/rt-test (sub1 "a"))
+(arity-test sub1 1 1)
+
+(test 1024 expt 2 10)
+(test 1/1024 expt 2 -10)
+(test 1/1024 expt 1/2 10)
+(test (/ 1 (expt 2 10000)) expt 1/2 10000)
+(arity-test expt 2 2)
+
+(test 31525197391593472 inexact->exact 31525197391593473.0)
+(test 31525197391593476 inexact->exact 31525197391593476.0)
+(test 31525197391593476 inexact->exact 31525197391593476.0)
+
+(test 0 apply + (map inexact->exact (list 3.2d+270 -2.4d+270 -8d+269)))
+(test 0 apply + (map inexact->exact (list 3.2f+7 -2.4f+7 -8f+6)))
+
+(test #t positive? (inexact->exact 0.1))
+(test #t negative? (inexact->exact -0.1))
+(test 0 + (inexact->exact -0.1) (inexact->exact 0.1))
+(arity-test inexact->exact 1 1)
+(err/rt-test (inexact->exact 'a))
+(test 1+i inexact->exact 1.0+1.0i)
+(test 1 inexact->exact 1.0+0.0i)
+(test 1 inexact->exact 1.0-0.0i)
+
+(test #t positive? (exact->inexact 1/10))
+(test #t negative? (exact->inexact -1/10))
+(test 0.0 + (exact->inexact -1/10) (exact->inexact 1/10))
+(arity-test exact->inexact 1 1)
+(err/rt-test (exact->inexact 'a))
+(test 1.0+1.0i exact->inexact 1+1i)
+(test 1.0+0.0i exact->inexact 1+0.0i)
+(test (expt 7 30) inexact->exact (expt 7 30))
+
+(err/rt-test (inexact->exact +inf.0))
+(err/rt-test (inexact->exact -inf.0))
+(err/rt-test (inexact->exact +nan.0))
+
+(err/rt-test (* 'a 0))
+(err/rt-test (+ 'a 0))
+(err/rt-test (/ 'a 0))
+(err/rt-test (- 'a 0))
+(err/rt-test (+ 0 'a))
+(err/rt-test (* 0 'a))
+(err/rt-test (- 0 'a))
+(err/rt-test (/ 0 'a))
+(err/rt-test (+ 'a))
+(err/rt-test (* 'a))
+(err/rt-test (- 'a))
+(err/rt-test (/ 'a))
+
+(define (test-inf-plus-times v)
+  (define (test+ +)
+    (test +inf.0 + v (+ +inf.0))
+    (test -inf.0 + v (+ -inf.0))
+    (test +inf.0 + (- v) (+ +inf.0))
+    (test -inf.0 + (- v) (+ -inf.0))
+    
+    (test +inf.0 + +inf.0 v)
+    (test -inf.0 + -inf.0 v)
+    (test +inf.0 + +inf.0 (- v))
+    (test -inf.0 + -inf.0 (- v))
+
+    (test-nan.0 + +nan.0 v)
+    (test-nan.0 + v +nan.0))
+
+  (test+ +)
+  (test+ -)
+  
+  (test +inf.0 * +inf.0 v)
+  (test -inf.0 * -inf.0 v)
+  (test -inf.0 * +inf.0 (- v))
+  (test +inf.0 * -inf.0 (- v))
+
+  (test +inf.0 * v +inf.0)
+  (test -inf.0 * v -inf.0)
+  (test -inf.0 * (- v) +inf.0)
+  (test +inf.0 * (- v) -inf.0)
+
+  (test-nan.0 * +nan.0 v)
+  (test-nan.0 * v +nan.0))
+
+(test-inf-plus-times 1)
+(test-inf-plus-times 1.0)
+(test-inf-plus-times (expt 2 100))
+
+(test -inf.0 - +inf.0)
+(test +inf.0 - -inf.0)
+(test +inf.0 + +inf.0 +inf.0)
+(test -inf.0 + -inf.0 -inf.0)
+(test-nan.0 + +inf.0 -inf.0)
+(test-nan.0 - +inf.0 +inf.0)
+(test-nan.0 - -inf.0 -inf.0)
+(test +inf.0 * +inf.0 +inf.0)
+(test -inf.0 * +inf.0 -inf.0)
+(test 0 * +inf.0 0)
+(test-nan.0 * +inf.0 0.0)
+(test-nan.0 + +nan.0 +nan.0)
+(test-nan.0 - +nan.0 +nan.0)
+(test-nan.0 * +nan.0 +nan.0)
+
+(test 1/2 / 1 2)
+(test -1/3 / -1 3)
+(test -1/3 / 1 -3)
+(test 1/2 / 1/4 1/2)
+(test 0.5 / 1 2.0)
+(test 0.5 / 1.0 2)
+(test 1/2+3/2i / 1+3i 2)
+(test 1/5-3/5i / 2 1+3i)
+(test 0.5+0.0i / 1+0.0i 2)
+(test 0.25-0.0i / 1 4+0.0i)
+(test 0.25+0.0i / 1+0.0i 4+0.0i)
+(test 0 / 0 4+3i)
+
+(test 3 / 1 1/3)
+(test -3 / 1 -1/3)
+(test -3 / -1 1/3)
+(test 3 / -1 -1/3)
+(test 1/3 / 1 3)
+(test -1/3 / 1 -3)
+(test -1/3 / -1 3)
+(test 1/3 / -1 -3)
+(test 3/2 / 1 2/3)
+(test -3/2 / 1 -2/3)
+(test -3/2 / -1 2/3)
+(test 3/2 / -1 -2/3)
+
+(test (expt 3 50) / 1 (/ 1 (expt 3 50)))
+(test (- (expt 3 50)) / 1 (- (/ 1 (expt 3 50))))
+(test (- (expt 3 50)) / -1 (/ 1 (expt 3 50)))
+(test (expt 3 50) / -1 (- (/ 1 (expt 3 50))))
+(test (/ 1 (expt 3 50)) / 1 (expt 3 50))
+(test (- (/ 1 (expt 3 50))) / 1 (- (expt 3 50)))
+(test (- (/ 1 (expt 3 50))) / -1 (expt 3 50))
+(test (/ 1 (expt 3 50)) / -1 (- (expt 3 50)))
+(test (/ (expt 3 50) (expt 2 70)) / 1 (/ (expt 2 70) (expt 3 50)))
+(test (- (/ (expt 3 50) (expt 2 70))) / 1 (- (/ (expt 2 70) (expt 3 50))))
+(test (- (/ (expt 3 50) (expt 2 70))) / -1 (/ (expt 2 70) (expt 3 50)))
+(test (/ (expt 3 50) (expt 2 70)) / -1 (/ (- (expt 2 70)) (expt 3 50)))
+
+(test (- (expt 2 30)) / (- (expt 2 30)) 1)
+(test (expt 2 30) / (- (expt 2 30)) -1)
+(test (expt 2 29) / (- (expt 2 30)) -2)
+(test -1/1073741824 / (- (expt 2 30)))
+
+(test +inf.0 / 1.0 0.0)
+(test -inf.0 / -1.0 0.0)
+(test +inf.0 / -1.0 -0.0)
+(test -inf.0 / 1.0 -0.0)
+
+(define (make-test-inf-zero-div zero -zero inf -inf)
+  (lambda (v)
+    (test zero / v +inf.0)
+    (test -zero / v -inf.0)
+    (test -zero / (- v) +inf.0)
+    (test zero / (- v) -inf.0)
+    
+    (test inf / +inf.0 v)
+    (test -inf / -inf.0 v)
+    (test -inf / +inf.0 (- v))
+    (test inf / -inf.0 (- v))
+    
+    (unless (zero? v)
+      (test zero / 0.0 v)
+      (test -zero / 0.0 (- v))
+      (test -zero / -0.0 v)
+      (test zero / -0.0 (- v))
+      
+      (test inf / v 0.0)
+      (test -inf / (- v) 0.0)
+      (test -inf / v -0.0)
+      (test inf / (- v) -0.0))
+    
+    (test-nan.0 / +nan.0 v)
+    (test-nan.0 / v +nan.0)))
+
+(define test-inf-zero-div (make-test-inf-zero-div 0.0 -0.0 +inf.0 -inf.0))
+(define test-neg-inf-zero-div (make-test-inf-zero-div -0.0 0.0 -inf.0 +inf.0))
+
+(test-inf-zero-div big-num)
+(test-inf-zero-div (/ big-num 3))
+(test-inf-zero-div 0.0)
+
+(test-neg-inf-zero-div (- big-num))
+(test-neg-inf-zero-div (- (/ big-num 3)))
+(test-neg-inf-zero-div -0.0)
+
+(test-nan.0 / +inf.0 +inf.0)
+(test-nan.0 / +inf.0 -inf.0)
+(test-nan.0 / +nan.0 -nan.0)
+
+(test 1.0 exact->inexact (/ big-num (add1 big-num)))
+
+(err/rt-test (/ 0) exn:fail:contract:divide-by-zero?)
+(err/rt-test (/ 1 0) exn:fail:contract:divide-by-zero?)
+(err/rt-test (/ 1/2 0) exn:fail:contract:divide-by-zero?)
+(err/rt-test (/ 1+2i 0) exn:fail:contract:divide-by-zero?)
+(err/rt-test (/ 1.0 0) exn:fail:contract:divide-by-zero?)
+
+(test -1 - 3 4)
+(test -3 - 3)
+(test -1.0 - 3.0 4)
+(test -3.0 - 3.0)
+(test 7 abs -7)
+(test (expt 7 100) abs (- (expt 7 100)))
+(test (expt 7 100) abs (expt 7 100))
+(test 7.0 abs -7.0)
+(test 7 abs 7)
+(test 0 abs 0)
+(test 1/2 abs 1/2)
+(test 1/2 abs -1/2)
+(test +inf.0 abs +inf.0)
+(test +inf.0 abs -inf.0)
+(test-nan.0 abs -nan.0)
+(test 4.0 abs -4.0+0.0i)
+
+(test 1073741823 abs -1073741823)
+(test 1073741823 abs 1073741823)
+(test 1073741824 abs -1073741824)
+(test 1073741824 abs 1073741824)
+(test 1073741825 abs -1073741825)
+(test 1073741825 abs 1073741825)
+
+(arity-test abs 1 1)
+(err/rt-test (-) exn:application:arity?)
+(err/rt-test (abs 'a))
+(err/rt-test (abs +5i))
+
+(test 5 quotient 35 7)
+(test 5.0 quotient 35 7.0)
+(test 5.0 quotient 36 7.0)
+(test 5.0 quotient 36.0 7)
+(test -5 quotient -35 7)
+(test -5.0 quotient -35 7.0)
+(test -5 quotient 35 -7)
+(test -5.0 quotient 35 -7.0)
+(test 5 quotient -35 -7)
+(test 5.0 quotient -35 -7.0)
+(test -5.0 quotient -36 7.0)
+(test -5.0 quotient 36.0 -7)
+(test -5.0 quotient 36.0 -7+0.0i)
+(test -5.0 quotient 36.0+0.0i -7)
+(test 0 quotient 0 5.0)
+(test 0 quotient 0 -5.0)
+(test 1 modulo 13 4)
+(test 1 remainder 13 4)
+(test 1.0 modulo 13 4.0)
+(test 1.0 remainder 13 4.0)
+(test 3 modulo -13 4)
+(test -1 remainder -13 4)
+(test 3.0 modulo -13 4.0)
+(test -1.0 remainder -13 4.0)
+(test -3 modulo 13 -4)
+(test 1 remainder 13 -4)
+(test -3.0 modulo 13.0 -4)
+(test 1.0 remainder 13.0 -4)
+(test -1 modulo -13 -4)
+(test -1 remainder -13 -4)
+(test -1.0 modulo -13 -4.0)
+(test -1.0 remainder -13 -4.0)
+(test -1.0 modulo -13 -4.0+0.0i)
+(test -1.0 remainder -13 -4.0+0.0i)
+(test -1.0 modulo -13+0.0i -4.0)
+(test -1.0 remainder -13+0.0i -4.0)
+(test -2 remainder -3333333332 -3)
+(test -2 modulo -3333333332 -3)
+(test 2 remainder 3333333332 -3)
+(test -1 modulo 3333333332 -3)
+(test 0 modulo 4 2)
+(test 0 modulo -4 2)
+(test 0 modulo 4 -2)
+(test 0 modulo -4 -2)
+(test 0.0 modulo 4.0 2)
+(test 0.0 modulo -4.0 2)
+(test 0.0 modulo 4.0 -2)
+(test 0.0 modulo -4.0 -2)
+(test 0 remainder 4 2)
+(test 0 remainder -4 2)
+(test 0 remainder 4 -2)
+(test 0 remainder -4 -2)
+(test 0.0 remainder 4.0 2)
+(test 0.0 remainder -4.0 2)
+(test 0.0 remainder 4.0 -2)
+(test 0.0 remainder -4.0 -2)
+(test 0 modulo 0 5.0)
+(test 0 modulo 0 -5.0)
+(test 0 remainder 0 5.0)
+(test 0 remainder 0 -5.0)
+(define (divtest n1 n2)
+	(= n1 (+ (* n2 (quotient n1 n2))
+		 (remainder n1 n2))))
+(test #t divtest 238 9)
+(test #t divtest -238 9)
+(test #t divtest 238 -9)
+(test #t divtest -238 -9)
+
+(test 13.0 quotient 1324.0 100)
+
+(err/rt-test (quotient 6 0) exn:fail:contract:divide-by-zero?)
+(err/rt-test (modulo 6 0) exn:fail:contract:divide-by-zero?)
+(err/rt-test (remainder 6 0) exn:fail:contract:divide-by-zero?)
+(err/rt-test (quotient 6 0.0) exn:fail:contract:divide-by-zero?)
+(err/rt-test (modulo 6 0.0) exn:fail:contract:divide-by-zero?)
+(err/rt-test (remainder 6 0.0) exn:fail:contract:divide-by-zero?)
+(err/rt-test (quotient 6 -0.0) exn:fail:contract:divide-by-zero?)
+(err/rt-test (modulo 6 -0.0) exn:fail:contract:divide-by-zero?)
+(err/rt-test (remainder 6 -0.0) exn:fail:contract:divide-by-zero?)
+
+(define (test-qrm-inf v)
+  (define iv (exact->inexact v))
+
+  (test 0.0 quotient v +inf.0)
+  (test -0.0 quotient v -inf.0)
+  (test iv remainder v +inf.0)
+  (test iv remainder v -inf.0)
+  (test iv modulo v +inf.0)
+  (test -inf.0 modulo v -inf.0)
+
+  (test +inf.0 quotient +inf.0 v)
+  (test -inf.0 quotient -inf.0 v)
+  (test 0.0 remainder +inf.0 v)
+  (test 0.0 remainder -inf.0 v)
+  (test 0.0 modulo +inf.0 v)
+  (test 0.0 modulo -inf.0 v))
+
+(test-qrm-inf 9)
+(test-qrm-inf 9.0)
+(test-qrm-inf (expt 2 100))
+
+;; Check 0.0 combinations
+(test -0.0 quotient -0.0 +inf.0)
+(test 0.0 quotient -0.0 -inf.0)
+(test -0.0 quotient -0.0 2.0)
+(test 0.0 quotient -0.0 -2.0)
+(test 0.0 quotient 0.0 +inf.0)
+(test -0.0 quotient 0.0 -inf.0)
+(test 0.0 quotient 0.0 2.0)
+(test -0.0 quotient 0.0 -2.0)
+(test 0.0 modulo -0.0 +inf.0)
+(test 0.0 modulo -0.0 -inf.0)
+(test 0.0 modulo -0.0 2.0)
+(test 0.0 modulo -0.0 -2.0)
+(test 0.0 modulo 0.0 +inf.0)
+(test 0.0 modulo 0.0 -inf.0)
+(test 0.0 modulo 0.0 2.0)
+(test 0.0 modulo 0.0 -2.0)
+(test 0.0 remainder -0.0 +inf.0)
+(test 0.0 remainder -0.0 -inf.0)
+(test 0.0 remainder -0.0 2.0)
+(test 0.0 remainder -0.0 -2.0)
+(test 0.0 remainder 0.0 +inf.0)
+(test 0.0 remainder 0.0 -inf.0)
+(test 0.0 remainder 0.0 2.0)
+(test 0.0 remainder 0.0 -2.0)
+
+(arity-test quotient 2 2)
+(arity-test modulo 2 2)
+(arity-test remainder 2 2)
+
+(err/rt-test (quotient 'a 1))
+(err/rt-test (quotient 1 'a))
+(err/rt-test (quotient 1 +nan.0))
+(err/rt-test (quotient +nan.0 1))
+(err/rt-test (modulo 'a 1))
+(err/rt-test (modulo 1 'a))
+(err/rt-test (modulo +nan.0 1))
+(err/rt-test (modulo 1 +nan.0))
+(err/rt-test (remainder 'a 1))
+(err/rt-test (remainder 1 'a))
+(err/rt-test (remainder +nan.0 1))
+(err/rt-test (remainder 1 +nan.0))
+(err/rt-test (quotient 'a 1.0))
+(err/rt-test (quotient 1.0 'a))
+(err/rt-test (modulo 'a 1.0))
+(err/rt-test (modulo 1.0 'a))
+(err/rt-test (remainder 'a 1.0))
+(err/rt-test (remainder 1.0 'a))
+(err/rt-test (quotient 1/2 1))
+(err/rt-test (remainder 1/2 1))
+(err/rt-test (modulo 1/2 1))
+(err/rt-test (quotient 2 1/2))
+(err/rt-test (remainder 2 1/2))
+(err/rt-test (modulo 2 1/2))
+(err/rt-test (quotient 12.3 1))
+(err/rt-test (remainder 12.3 1))
+(err/rt-test (modulo 12.3 1))
+(err/rt-test (quotient 2 12.3))
+(err/rt-test (remainder 2 12.3))
+(err/rt-test (modulo 2 12.3))
+(err/rt-test (quotient 1+2i 1))
+(err/rt-test (remainder 1+2i 1))
+(err/rt-test (modulo 1+2i 1))
+(err/rt-test (quotient 2 1+2i))
+(err/rt-test (remainder 2 1+2i))
+(err/rt-test (modulo 2 1+2i))
+
+(test 10 bitwise-ior 10)
+(test 10 bitwise-and 10)
+(test 10 bitwise-xor 10)
+(test 7 bitwise-ior 3 4)
+(test 0 bitwise-and 3 4)
+(test 7 bitwise-xor 3 4)
+(test 7 bitwise-ior 3 4 1)
+(test 1 bitwise-and 3 5 1)
+(test 6 bitwise-xor 3 4 1)
+
+(test #x1ffff7777 bitwise-ior #x1aaaa5555 #x155553333)
+(test #x100001111 bitwise-and #x1aaaa5555 #x155553333)
+(test #x0ffff6666 bitwise-xor #x1aaaa5555 #x155553333)
+
+(test #x3ffff7777 bitwise-ior #x2aaaa5555 #x155553333)
+(test #x000001111 bitwise-and #x2aaaa5555 #x155553333)
+(test #x3ffff6666 bitwise-xor #x2aaaa5555 #x155553333)
+
+(test #x3ffff7777 bitwise-ior #x2aaaa5555 #x155553333)
+(test #x000001111 bitwise-and #x2aaaa5555 #x155553333)
+(test #x3ffff6666 bitwise-xor #x2aaaa5555 #x155553333)
+
+(test #xfffffffffffffe bitwise-not #x-FFFFFFFFFFFFFF)
+(test #x-100000000000000 bitwise-not #xFFFFFFFFFFFFFF)
+
+(test (bitwise-and (bitwise-not #x-2aaaa5555) (bitwise-not #x-15555aaaa))
+      bitwise-not (bitwise-ior #x-2aaaa5555 #x-15555aaaa))
+(test (bitwise-and (bitwise-not #x-2aaaa5555) (bitwise-not #x-155553333))
+      bitwise-not (bitwise-ior #x-2aaaa5555 #x-155553333))
+(test (bitwise-and (bitwise-not #x-2aaaa5555) (bitwise-not #x-15555333))
+      bitwise-not (bitwise-ior #x-2aaaa5555 #x-15555333))
+
+(test #x-155553333 bitwise-xor #x-2aaaa5555 (bitwise-xor #x-2aaaa5555 #x-155553333))
+(test #x-15555333 bitwise-xor #x-2aaaa5555 (bitwise-xor #x-2aaaa5555 #x-15555333))
+
+(arity-test bitwise-ior 1 -1)
+(arity-test bitwise-and 1 -1)
+(arity-test bitwise-xor 1 -1)
+(arity-test bitwise-not 1 1)
+
+(define error-test-bitwise-procs
+  (lambda (v)
+    (err/rt-test (bitwise-ior v))
+    (err/rt-test (bitwise-and v))
+    (err/rt-test (bitwise-xor v))
+    (err/rt-test (bitwise-not v))
+    (err/rt-test (bitwise-ior 1 v))
+    (err/rt-test (bitwise-and 1 v))
+    (err/rt-test (bitwise-xor 1 v))
+    (err/rt-test (bitwise-ior v 1))
+    (err/rt-test (bitwise-and v 1))
+    (err/rt-test (bitwise-xor v 1))))
+
+(error-test-bitwise-procs 1.0)
+(error-test-bitwise-procs 1/2)
+(error-test-bitwise-procs 1+2i)
+(error-test-bitwise-procs 1.0+0.0i)
+(error-test-bitwise-procs +inf.0)
+(error-test-bitwise-procs ''a)
+
+(test 1 arithmetic-shift 1 0)
+(test 1024 arithmetic-shift 1 10)
+(test 1 arithmetic-shift 1024 -10)
+(test 256 arithmetic-shift 1024 -2)
+(test 0 arithmetic-shift 1024 -11)
+(test 0 arithmetic-shift 1024 -20)
+(test 0 arithmetic-shift 1024 -40)
+(test 0 arithmetic-shift 1024 -20000000000000000000)
+(test 0 arithmetic-shift 0 100)
+(test 0 arithmetic-shift 0 -100)
+(test 0 arithmetic-shift 17 -32)
+
+(test (expt 2 40) arithmetic-shift (expt 2 40) 0)
+(test (expt 2 50) arithmetic-shift (expt 2 40) 10)
+(test (expt 2 30) arithmetic-shift (expt 2 40) -10) ; somewhere close to here is a boundary...
+(test (expt 2 29) arithmetic-shift (expt 2 40) -11)
+(test (expt 2 31) arithmetic-shift (expt 2 40) -9)
+(test 1 arithmetic-shift (expt 2 40) -40)
+(test 0 arithmetic-shift (expt 2 40) -41)
+(test 0 arithmetic-shift (expt 2 40) -100)
+
+(test -1 arithmetic-shift -1 0)
+(test -1024 arithmetic-shift -1 10)
+(test -1 arithmetic-shift -1024 -10)
+(test -256 arithmetic-shift -1024 -2)
+(test -1 arithmetic-shift -1024 -11)
+(test -1 arithmetic-shift -1024 -20)
+(test -1 arithmetic-shift -1024 -20000000000000000000)
+
+(test (- (expt 2 40)) arithmetic-shift (- (expt 2 40)) 0)
+(test (- (expt 2 50)) arithmetic-shift (- (expt 2 40)) 10)
+(test (- (expt 2 30)) arithmetic-shift (- (expt 2 40)) -10) ; somewhere close to here is a boundary...
+(test (- (expt 2 29)) arithmetic-shift (- (expt 2 40)) -11)
+(test (- (expt 2 31)) arithmetic-shift (- (expt 2 40)) -9)
+(test -1 arithmetic-shift (- (expt 2 40)) -40)
+(test -1 arithmetic-shift (- (expt 2 40)) -41)
+(test -1 arithmetic-shift (- (expt 2 40)) -100)
+
+(test 0 arithmetic-shift (sub1 (expt 2 30)) -32)
+(test 0 arithmetic-shift (sub1 (expt 2 31)) -32)
+(test 0 arithmetic-shift (sub1 (expt 2 32)) -32)
+(test 1 arithmetic-shift (expt 2 32) -32)
+
+(arity-test arithmetic-shift 2 2)
+(err/rt-test (arithmetic-shift "a" 1))
+(err/rt-test (arithmetic-shift 1 "a"))
+(err/rt-test (arithmetic-shift 1.0 1))
+(err/rt-test (arithmetic-shift 1 1.0))
+(err/rt-test (arithmetic-shift 1 1.0+0.0i))
+(err/rt-test (arithmetic-shift 1 (expt 2 80)) exn:fail:out-of-memory?)
+
+(test 4 gcd 0 4)
+(test 4 gcd -4 0)
+(test 4 gcd 32 -36)
+(test 2 gcd 6 10 14)
+(test 0 gcd)
+(test 5 gcd 5)
+(test 5.0 gcd 5.0 10)
+(test 5.0 gcd -5.0 10)
+(test 5.0 gcd 5.0 -10)
+(test 5.0 gcd 5.0+0.0i 10)
+(test 5.0 gcd 5.0 10+0.0i)
+(test (expt 3 37) gcd (expt 9 35) (expt 6 37))
+(test (expt 3 37) gcd (- (expt 9 35)) (expt 6 37))
+(test (expt 3 37) gcd (expt 9 35) (- (expt 6 37)))
+(test 201 gcd (* 67 (expt 3 20)) (* 67 3))
+(test 201 gcd (* 67 3) (* 67 (expt 3 20)))
+(test 6 gcd (* 3 (expt 2 100)) 66)
+(test 6 gcd 66 (* 3 (expt 2 100)))
+(test 201.0 gcd (* 67 (expt 3 20)) (* 67. 3))
+(test 201.0 gcd (* 67. 3) (* 67 (expt 3 20)))
+(test 9.0 gcd +inf.0 9)
+(test 9.0 gcd -inf.0 9)
+(test (expt 9 35) gcd (expt 9 35) 0)
+(test (expt 9 35) gcd 0 (expt 9 35))
+(test 288 lcm 32 -36)
+(test 12 lcm 2 3 4)
+(test 1 lcm)
+(test 5 lcm 5)
+(test 0 lcm 123 0)
+(test 30.0 lcm 5 6.0)
+(test 30.0 lcm 5 6.0+0.0i)
+(test 30.0 lcm 5+0.0i 6.0)
+(test 0.0 lcm 123 0.0)
+(test 0.0 lcm 123 -0.0)
+(test (* (expt 2 37) (expt 9 35)) lcm (expt 9 35) (expt 6 37))
+(test (* (expt 2 37) (expt 9 35)) lcm (- (expt 9 35)) (expt 6 37))
+(test (* (expt 2 37) (expt 9 35)) lcm (expt 9 35) (- (expt 6 37)))
+
+(err/rt-test (gcd +nan.0))
+(err/rt-test (gcd 'a))
+(err/rt-test (gcd 'a 1))
+(err/rt-test (gcd 1 'a))
+(err/rt-test (lcm +nan.0))
+(err/rt-test (lcm 'a))
+(err/rt-test (lcm 'a 1))
+(err/rt-test (lcm 1 'a))
+(err/rt-test (gcd 1/2))
+(err/rt-test (gcd 3 1/2))
+(err/rt-test (gcd 1/2 3))
+(err/rt-test (lcm 1/2))
+(err/rt-test (lcm 3 1/2))
+(err/rt-test (lcm 1/2 3))
+(err/rt-test (gcd 1+2i))
+(err/rt-test (lcm 1+2i))
+(err/rt-test (gcd 1 1+2i))
+(err/rt-test (lcm 1 1+2i))
+(err/rt-test (gcd +nan.0 5.0))
+(err/rt-test (gcd 5.0 +nan.0))
+(err/rt-test (lcm +nan.0 5.0))
+(err/rt-test (lcm 5.0 +nan.0))
+
+(arity-test gcd 0 -1)
+(arity-test lcm 0 -1)
+
+(test 2 floor 5/2)
+(test 3 ceiling 5/2)
+(test 2 round 5/2)
+(test 2 truncate 5/2)
+(test -3 floor -5/2)
+(test -2 ceiling -5/2)
+(test -2 round -5/2)
+(test -2 truncate -5/2)
+
+(test 1 floor 4/3)
+(test 2 ceiling 4/3)
+(test 1 round 4/3)
+(test 1 truncate 4/3)
+(test -2 floor -4/3)
+(test -1 ceiling -4/3)
+(test -1 round -4/3)
+(test -1 truncate -4/3)
+
+(test 1 floor 5/3)
+(test 2 ceiling 5/3)
+(test 2 round 5/3)
+(test 1 truncate 5/3)
+(test -2 floor -5/3)
+(test -1 ceiling -5/3)
+(test -2 round -5/3)
+(test -1 truncate -5/3)
+
+(test 2 floor 11/4)
+(test 3 ceiling 11/4)
+(test 3 round 11/4)
+(test 2 truncate 11/4)
+(test -3 floor -11/4)
+(test -2 ceiling -11/4)
+(test -3 round -11/4)
+(test -2 truncate -11/4)
+
+(test 2 floor 9/4)
+(test 3 ceiling 9/4)
+(test 2 round 9/4)
+(test 2 truncate 9/4)
+(test -3 floor -9/4)
+(test -2 ceiling -9/4)
+(test -2 round -9/4)
+(test -2 truncate -9/4)
+
+(test 2.0 floor 2.4)
+(test 3.0 ceiling 2.4)
+(test 2.0 round 2.4)
+(test 2.0 truncate 2.4)
+(test -3.0 floor -2.4)
+(test -2.0 ceiling -2.4)
+(test -2.0 round -2.4)
+(test -2.0 truncate -2.4)
+
+(test 2.0 floor 2.6)
+(test 3.0 ceiling 2.6)
+(test 3.0 round 2.6)
+(test 2.0 truncate 2.6)
+(test -3.0 floor -2.6)
+(test -2.0 ceiling -2.6)
+(test -3.0 round -2.6)
+(test -2.0 truncate -2.6)
+
+(test 2.0 round 2.5)
+(test -2.0 round -2.5)
+(test 4.0 round 3.5)
+(test -4.0 round -3.5)
+
+(test 2.0 floor 2.6+0.0i)
+(test 3.0 ceiling 2.6+0.0i)
+(test 3.0 round 2.6+0.0i)
+(test 2.0 truncate 2.6+0.0i)
+
+(define (test-fcrt-int v)
+  (test v floor v)
+  (test v ceiling v)
+  (test v round v)
+  (test v truncate v))
+
+(test-fcrt-int 2)
+(test-fcrt-int 2.0)
+(test-fcrt-int (expt 2 100))
+(test-fcrt-int +inf.0)
+(test-fcrt-int -inf.0)
+
+(test-nan.0 floor +nan.0)
+(test-nan.0 ceiling +nan.0)
+(test-nan.0 round +nan.0)
+(test-nan.0 truncate +nan.0)
+
+(arity-test round 1 1)
+(arity-test floor 1 1)
+(arity-test ceiling 1 1)
+(arity-test truncate 1 1)
+
+(err/rt-test (floor 2+i))
+(err/rt-test (ceiling 2+i))
+(err/rt-test (truncate 2+i))
+(err/rt-test (round 2+i))
+
+(err/rt-test (floor "a"))
+(err/rt-test (ceiling "a"))
+(err/rt-test (truncate "a"))
+(err/rt-test (round "a"))
+
+(test 5 numerator 5)
+(test 5000000000000 numerator 5000000000000)
+(test 5.0 numerator 5.0)
+(test 5.0 numerator 5.0+0.0i)
+(test 1 denominator 5)
+(test 1 denominator 5000000000000)
+(test 1.0 denominator 5.0)
+(test 1.0 denominator 5.0+0.0i)
+(test 2 numerator 2/3)
+(test 3 denominator 2/3)
+(test 1000.0 round (* 10000.0 (/ (numerator 0.1) (denominator 0.1))))
+
+(test +inf.0 numerator +inf.0)
+(test -inf.0 numerator -inf.0)
+(test-nan.0 numerator +nan.0)
+(test 1.0 denominator +inf.0)
+(test 1.0 denominator -inf.0)
+(test-nan.0 denominator +nan.0)
+
+(err/rt-test (numerator 'a))
+(err/rt-test (numerator 1+2i))
+(err/rt-test (denominator 'a))
+(err/rt-test (denominator 1+2i))
+
+(arity-test numerator 1 1)
+(arity-test denominator 1 1)
+
+(define (test-on-reals f filter)
+  (test (filter 5) f 5)
+  (test (filter 5.0) f 5.0)
+  (test (filter 1/5) f 1/5)
+  (test (filter (expt 2 100)) f (expt 2 100)))
+
+(test 1+2i make-rectangular 1 2)
+(test 1.0+2.0i make-rectangular 1.0 2)
+(test 1.0+2.0i make-rectangular 1.0+0.0i 2)
+(test 1.0+2.0i make-rectangular 1.0 2+0.0i)
+(test-nan.0 real-part (make-rectangular +nan.0 1))
+(test 1.0 imag-part (make-rectangular +nan.0 1))
+(test-nan.0 imag-part (make-rectangular 1 +nan.0))
+(test 1.0 real-part (make-rectangular 1 +nan.0))
+(test +inf.0 real-part (make-rectangular +inf.0 -inf.0))
+(test -inf.0 imag-part (make-rectangular +inf.0 -inf.0))
+
+(test (make-rectangular +inf.0 -inf.0) * 1. (make-rectangular +inf.0 -inf.0))
+(test (make-rectangular +inf.0 +inf.0) * +1.0i (make-rectangular +inf.0 -inf.0))
+(test (make-rectangular -inf.0 +inf.0) * -3. (make-rectangular +inf.0 -inf.0))
+(test (make-rectangular +inf.0 -inf.0) * (make-rectangular +inf.0 -inf.0) 1.)
+(test (make-rectangular +inf.0 +inf.0) * (make-rectangular +inf.0 -inf.0) +1.0i)
+(test (make-rectangular -inf.0 +inf.0) * (make-rectangular +inf.0 -inf.0) -3.)
+(test (make-rectangular +inf.0 -inf.0) / (make-rectangular +inf.0 -inf.0) 1.)
+(test (make-rectangular -inf.0 -inf.0) / (make-rectangular +inf.0 -inf.0) +1.0i)
+(test (make-rectangular -inf.0 +inf.0) / (make-rectangular +inf.0 -inf.0) -3.)
+
+;; Test division with exact zeros in demoniator where
+;;  the exact zero gets polluted to an inexact zero unless
+;;  it's special-cased
+(test 0-0.0i / 0+1.0i -inf.0)
+(test -0.0-0.0i / 1.0+1.0i -inf.0)
+(test -0.0 / 0+1.0i 0-inf.0i)
+(test -0.0+0.0i / 1.0+1.0i 0-inf.0i)
+
+(test-i-nan.0 * 1.+0.i (make-rectangular +inf.0 -inf.0))
+(test-i-nan.0 * 0.+1.0i (make-rectangular +inf.0 -inf.0))
+(test-i-nan.0 * -3.+0.i (make-rectangular +inf.0 -inf.0))
+(test-i-nan.0 * (make-rectangular +inf.0 -inf.0) 1.+0.i)
+(test-i-nan.0 * (make-rectangular +inf.0 -inf.0) 0.+1.0i)
+(test-i-nan.0 * (make-rectangular +inf.0 -inf.0) -3.+0.i)
+(test-i-nan.0 / (make-rectangular +inf.0 -inf.0) 1.+0.i)
+(test-i-nan.0 / (make-rectangular +inf.0 -inf.0) 0.+1.0i)
+(test-i-nan.0 / (make-rectangular +inf.0 -inf.0) -3.+0.i)
+
+(test 1 magnitude 1)
+(test 1 magnitude -1)
+(test 1.0 magnitude 1.0)
+(test 1.0 magnitude -1.0)
+(test big-num magnitude big-num)
+(test big-num magnitude (- big-num))
+(test 3/4 magnitude 3/4)
+(test 3/4 magnitude -3/4)
+(test 10.0 magnitude 10.0+0.0i)
+(test 10.0 magnitude -10.0+0.0i)
+
+(test 0 angle 1)
+(test 0 angle 1.0)
+(test 0 angle 0.0)
+(test 0 angle big-num)
+(test 0 angle 3/4)
+(test 0.0 angle 3+0.0i)
+(test-nan.0 angle +nan.0)
+(let ([pi (atan 0 -1)])
+  (test pi angle -1)
+  (test pi angle -1.0)
+  (test pi angle -0.0)
+  (test pi angle (- big-num))
+  (test pi angle -3/4)
+  (test pi angle -3+0.0i))
+(test -inf.0 atan 0+i)
+(test -inf.0 atan 0-i)
+
+(err/rt-test (angle 'a))
+(err/rt-test (angle 0) exn:fail:contract:divide-by-zero?)
+(err/rt-test (magnitude 'a))
+(arity-test angle 1 1)
+(arity-test magnitude 1 1)
+
+(test 1 real-part 1+2i)
+(test 1.0 real-part 1+2.0i)
+(test 1.0 real-part 1+0.0i)
+(test 1/5 real-part 1/5+2i)
+(test-on-reals real-part (lambda (x) x))
+(test 2.0 imag-part 1+2.0i)
+(test 0.0 imag-part 1+0.0i)
+(test -0.0 imag-part 1-0.0i)
+(test 1/5 imag-part 1+1/5i)
+(test-on-reals imag-part (lambda (x) 0))
+(test-nan.0 real-part +nan.0)
+(test 0 imag-part +nan.0)
+(test 6@1 (lambda (x) x) 6.0@1.0)
+(test 324.0 floor (* 100 (real-part 6@1)))
+(test 50488.0 floor (* 10000 (imag-part 6@1)))
+(test 1 make-polar 1 0)
+(test 1.0+0.0i make-polar 1 0.0)
+(test 1.0 make-polar 1.0 0)
+(test 1.0+0.0i make-polar 1.0 0.0)
+(test 1.0+0.0i make-polar 1.0 0.0+0.0i)
+(test 1.0+0.0i make-polar 1.0+0.0i 0.0)
+(let ([v (make-polar 1 1)])
+  (test 5403.0 floor (* 10000 (real-part v)))
+  (test 84147.0 floor (* 100000 (imag-part v)))
+  (test 10000.0 round (* 10000.0 (magnitude v))))
+(let ([v (make-polar 1 2)])
+  (test -416.0 ceiling (* 1000 (real-part v)))
+  (test 909.0 floor (* 1000 (imag-part v)))
+  (test 1.0 magnitude v)
+  (test 2.0 angle v))
+(test-nan.0 make-polar +nan.0 0)
+(test-i-nan.0 make-polar +nan.0 1)
+(test-i-nan.0 make-polar 1 +nan.0)
+(test-i-nan.0 make-polar 1 +inf.0)
+(test-i-nan.0 make-polar 1 -inf.0)
+(test +inf.0 make-polar +inf.0 0)
+(test -inf.0 make-polar -inf.0 0)
+(test (make-rectangular +inf.0 +inf.0) make-polar +inf.0 (atan 1 1))
+(test (make-rectangular -inf.0 +inf.0) make-polar +inf.0 (atan 1 -1))
+(test (make-rectangular +inf.0 -inf.0) make-polar +inf.0 (atan -1 1))
+(test 785.0 floor (* 1000 (angle (make-rectangular 1 1))))
+(test 14142.0 floor (* 10000 (magnitude (make-rectangular 1 1))))
+
+(err/rt-test (make-rectangular 1 'a))
+(err/rt-test (make-rectangular 'a 1))
+(err/rt-test (make-rectangular 1+2i 1))
+(err/rt-test (make-rectangular 1 1+2i))
+(arity-test make-rectangular 2 2)
+
+(err/rt-test (make-polar 1 'a))
+(err/rt-test (make-polar 'a 1))
+(err/rt-test (make-polar 1+2i 1))
+(err/rt-test (make-polar 1 1+2i))
+(arity-test make-polar 2 2)
+
+(err/rt-test (real-part 'a))
+(err/rt-test (imag-part 'a))
+(arity-test real-part 1 1)
+(arity-test imag-part 1 1)
+
+(define (z-round c) (make-rectangular (round (real-part c)) (round (imag-part c))))
+
+(test -1 * +i +i)
+(test 1 * +i -i)
+(test 2 * 1+i 1-i)
+(test +2i * 1+i 1+i)
+(test -3+4i - 3-4i)
+(test 0.5+0.0i - (+ 0.5 +i) +i)
+(test 1/2 - (+ 1/2 +i) +i)
+(test 1.0+0.0i - (+ 1 +0.5i) +1/2i)
+
+(test 1 sqrt 1)
+(test 1.0 sqrt 1.0)
+(test 25 sqrt 625)
+(test 3/7 sqrt 9/49)
+(test 0.5 sqrt 0.25)
+(test +1i sqrt -1)
+(test +2/3i sqrt -4/9)
+(test +1.0i sqrt -1.0)
+(test 1+1i sqrt +2i)
+(test 2+1i sqrt 3+4i)
+(test 2.0+0.0i sqrt 4+0.0i)
+(test +inf.0 sqrt +inf.0)
+(test (make-rectangular 0 +inf.0) sqrt -inf.0)
+(test-nan.0 sqrt +nan.0)
+
+(test (expt 5 13) sqrt (expt 5 26))
+(test 545915034.0 round (sqrt (expt 5 25)))
+(test (make-rectangular 0 (expt 5 13)) sqrt (- (expt 5 26)))
+(test (make-rectangular 0 545915034.0) z-round (sqrt (- (expt 5 25))))
+
+(err/rt-test (sqrt "a"))
+(arity-test sqrt 1 1)
+
+(test 3 integer-sqrt 10)
+(test 420 integer-sqrt (expt 3 11))
+(test 97184015999 integer-sqrt (expt 2 73))
+(test 0+3i integer-sqrt -10)
+(test 0+420i integer-sqrt (expt -3 11))
+(test 0+97184015999i integer-sqrt (expt -2 73))
+
+(test 2.0 integer-sqrt 5.0)
+(test 0+2.0i integer-sqrt -5.0)
+(test 2.0+0.0i integer-sqrt 5.0+0.0i)
+(test 0+2.0i integer-sqrt -5.0+0.0i)
+
+(err/rt-test (integer-sqrt "a"))
+(err/rt-test (integer-sqrt 1.1))
+(err/rt-test (integer-sqrt 1+1i))
+(arity-test integer-sqrt 1 1)
+
+(test '(3 1) call-with-values (lambda () (integer-sqrt/remainder 10)) list)
+(test '(420 747) call-with-values (lambda () (integer-sqrt/remainder (expt 3 11))) list)
+(test '(97184015999 45402459391) call-with-values (lambda () (integer-sqrt/remainder (expt 2 73))) list)
+(test '(0+3i -1) call-with-values (lambda () (integer-sqrt/remainder -10)) list)
+(test '(0+420i -747) call-with-values (lambda () (integer-sqrt/remainder (expt -3 11))) list)
+(test '(0+97184015999i -45402459391) call-with-values (lambda () (integer-sqrt/remainder (expt -2 73))) list)
+
+(test '(2.0 1.0) call-with-values (lambda () (integer-sqrt/remainder 5.0)) list)
+(test '(0+2.0i -1.0) call-with-values (lambda () (integer-sqrt/remainder -5.0)) list)
+(test '(2.0+0.0i 1.0+0.0i) call-with-values (lambda () (integer-sqrt/remainder 5.0+0.0i)) list)
+(test '(0+2.0i -1.0+0.0i) call-with-values (lambda () (integer-sqrt/remainder -5.0+0.0i)) list)
+
+(err/rt-test (integer-sqrt/remainder "a"))
+(err/rt-test (integer-sqrt/remainder 1.1))
+(err/rt-test (integer-sqrt/remainder 1+1i))
+(arity-test integer-sqrt/remainder 1 1)
+
+(test -13/64-21/16i expt -3/4+7/8i 2)
+(let ([v (expt -3/4+7/8i 2+3i)])
+  (test 3826.0 floor (* 10000000 (real-part v)))
+  (test -137.0 ceiling (* 100000 (imag-part v))))
+(test 49.0+0.0i expt 7 2+0.0i)
+(test 49.0 floor (* 10 (expt 2 2.3)))
+(test 189.0 floor (* 1000 (expt 2.3 -2)))
+(test 1/4 expt 2 -2)
+(test 1/1125899906842624 expt 2 -50)
+(test 1/1024 expt 1/2 10)
+(test 1024 expt 1/2 -10)
+(test 707.0 floor (* 1000 (expt 1/2 1/2)))
+(test 707.0 floor (* 1000 (expt 1/2 0.5)))
+(test 707.0 floor (* 1000 (expt 0.5 1/2)))
+(test 100.0+173.0i z-round (* 100 (expt -8 1/3)))
+(test 100.0+173.0i z-round (* 100 (expt -8.0 1/3)))
+(test 101.0+171.0i z-round (* 100 (expt -8 0.33)))
+(test 101.0+171.0i z-round (* 100 (expt -8.0 0.33)))
+(test 108.0+29.0i z-round (* 100 (expt 1+i 1/3)))
+(test 25.0-43.0i z-round (* 100 (expt -8 -1/3)))
+
+(test +inf.0 expt 2 +inf.0)
+(test +inf.0 expt +inf.0 10)
+(test 1 expt +inf.0 0)
+(test 1.0 expt +inf.0 0.)
+(test 0.0 expt 2 -inf.0)
+(test -inf.0 expt -inf.0 11)
+(test +inf.0 expt -inf.0 10)
+(test 1 expt -inf.0 0)
+(test 1.0 expt -inf.0 0.0)
+(test 1 expt +nan.0 0)
+(test 0 expt 0 10)
+(test 0 expt 0 10.0)
+(test 0 expt 0 +inf.0)
+(test-nan.0 expt 0 +nan.0)
+(test 1 expt 1 +inf.0)
+(test 1 expt 1 -inf.0)
+(test 1 expt 1 -nan.0)
+(test 0.0 expt 0.0 10)
+(test 0.0 expt 0.0 +inf.0)
+(test +inf.0 expt 0.0 -5)
+(test -inf.0 expt -0.0 -5)
+(test +inf.0 expt 0.0 -4)
+(test +inf.0 expt -0.0 -4)
+(test +inf.0 expt 0.0 -4.3)
+(test +inf.0 expt -0.0 -4.3)
+(test +inf.0 expt 0.0 -inf.0)
+(test-nan.0 expt 0.0 +nan.0)
+(test 1 expt 0 0)
+(test 1.0 expt 0 0.0) ; to match (expt 0 0)
+(test 1.0 expt 0 -0.0)
+(test 1.0 expt 0.0 0.0)
+(test 1.0 expt 0.0 0.0)
+(test 1 expt 0.0 0)
+(test 1 expt -0.0 0)
+(test -0.0 expt -0.0 1)
+(test-nan.0 expt +nan.0 10)
+(test-nan.0 expt 2 +nan.0)
+
+(test 0 expt 0 1+i)
+(test 0 expt 0 1-i)
+
+(test-nan.0 expt 1.0 +inf.0)
+(test-nan.0 expt 1.0 -inf.0)
+(test-nan.0 expt 1.0 +nan.0)
+
+(test 0.0 expt 0.0 5)
+(test -0.0 expt -0.0 5)
+(test 0.0 expt 0.0 4)
+(test 0.0 expt -0.0 4)
+(test 0.0 expt 0.0 4.3)
+(test 0.0 expt -0.0 4.3)
+
+(test 0.0 expt 0.5 +inf.0)
+(test +inf.0 expt 0.5 -inf.0)
+(test +inf.0 expt 1.5 +inf.0)
+(test 0.0 expt 1.5 -inf.0)
+(test 0.0 expt -0.5 +inf.0)
+(test +inf.0 expt -0.5 -inf.0)
+(test +inf.0 expt -1.5 +inf.0)
+(test 0.0 expt -1.5 -inf.0)
+
+(err/rt-test (expt 0 -1) exn:fail:contract:divide-by-zero?)
+(err/rt-test (expt 0 -1.0) exn:fail:contract:divide-by-zero?)
+(err/rt-test (expt 0 -inf.0) exn:fail:contract:divide-by-zero?)
+(err/rt-test (expt 0 -1+2i) exn:fail:contract:divide-by-zero?)
+(err/rt-test (expt 0 -1.0+2i) exn:fail:contract:divide-by-zero?)
+(err/rt-test (expt 0 0+2i) exn:fail:contract:divide-by-zero?)
+(err/rt-test (expt 0 0.0+2i) exn:fail:contract:divide-by-zero?)
+(err/rt-test (expt 0 -0.0+2i) exn:fail:contract:divide-by-zero?)
+(err/rt-test (expt 0 0+0.0i) exn:fail:contract:divide-by-zero?)
+
+(err/rt-test (expt 'a 0))
+(err/rt-test (expt 'a 1))
+(err/rt-test (expt 'a 3))
+(err/rt-test (expt 0 'a))
+(err/rt-test (expt 1 'a))
+(err/rt-test (expt 3 'a))
+
+;;;;From: fred@sce.carleton.ca (Fred J Kaudel)
+;;; Modified by jaffer.
+(define f3.9 (string->number "3.9"))
+(define f4.0 (string->number "4.0"))
+(define f-3.25 (string->number "-3.25"))
+(define f.25 (string->number ".25"))
+(define f4.5 (string->number "4.5"))
+(define f3.5 (string->number "3.5"))
+(define f0.0 (string->number "0.0"))
+(define f0.8 (string->number "0.8"))
+(define f1.0 (string->number "1.0"))
+(newline)
+(display ";testing inexact numbers; ")
+(newline)
+(SECTION 6 5 5)
+(test #t inexact? f3.9)
+(test #f exact? f3.9)
+(test #t 'inexact? (inexact? (max f3.9 4)))
+(test f4.0 'max (max f3.9 4))
+(test f4.0 'exact->inexact (exact->inexact 4))
+
+; Should at least be close...
+(test 4.0 round (log (exp 4.0)))
+(test 125.0 round (* 1000 (asin (sin 0.125))))
+(test 125.0d0 round (* 1000 (asin (sin 0.125+0.0d0i))))
+(test 125.0 round (* 1000 (asin (sin 1/8))))
+(test 125.0 round (* 1000 (acos (cos 0.125))))
+(test 125.0d0 round (* 1000 (acos (cos 0.125+0.0d0i))))
+(test 125.0 round (* 1000 (acos (cos 1/8))))
+(test 785.0 round (* 1000 (atan 1 1)))
+(test 785.0 round (* 1000 (atan 1.0 1.0)))
+(test 785.0 round (* 1000 (atan 1.0 1.0+0.0i)))
+(test 785.0 round (* 1000 (atan 1.0+0.0i 1.0)))
+(test 2356.0 round (* 1000 (atan 1 -1)))
+(test -785.0 round (* 1000 (atan -1 1)))
+(test 785.0 round (* 1000 (atan 1)))
+(test 100.0 round (* 100 (tan (atan 1))))
+(test 100.0 round (* 100 (tan (+ +0.0i (atan 1)))))
+(test 0.0 atan 0.0 0)
+(err/rt-test (atan 0 0) exn:fail:contract:divide-by-zero?)
+(test 1024.0 round (expt 2.0 10.0))
+(test 1024.0 round (expt -2.0 10.0))
+(test -512.0 round (expt -2.0 9.0))
+(test 32.0 round (sqrt 1024.0))
+(test 32.0 round (sqrt 1024.0+0.0i))
+(test 1.0+1.5e-10i sqrt 1+3e-10i)
+
+(test 1 exp 0)
+(test 1.0 exp 0.0)
+(test 1.0 exp -0.0)
+(test 272.0 round (* 100 (exp 1)))
+
+(test 0 log 1)
+(test 0.0 log 1.0)
+(test -inf.0 log 0.0)
+(test -inf.0 log -0.0)
+(err/rt-test (log 0) exn:fail:contract:divide-by-zero?)
+
+(test 1 cos 0)
+(test 1.0 cos 0.0)
+(test 0 sin 0)
+(test 0.0 sin 0.0)
+(test -0.0 sin -0.0)
+(test 0 tan 0)
+(test 0.0 tan 0.0)
+(test -0.0 tan -0.0)
+
+(test #t >= 1 (sin 12345678901234567890123))
+(test #t >= 1 (cos 12345678901234567890123))
+(test #t <= -inf.0 (tan 12345678901234567890123) +inf.0)
+
+(test 0 atan 0)
+(test 0.0 atan 0.0)
+(test -0.0 atan -0.0)
+(test 314.0 round (* 400 (atan 1)))
+(test 314.0 round (* 400 (atan 1.0)))
+(test 0 asin 0)
+(test 0.0 asin 0.0)
+(test -0.0 asin -0.0)
+(test 314.0 round (* 200 (asin 1)))
+(test 314.0 round (* 200 (asin 1.0)))
+(test 0 acos 1)
+(test 0.0 acos 1.0)
+(test 314.0 round (* 200 (acos 0)))
+(test 314.0 round (* 200 (acos 0.0)))
+(test 314.0 round (* 200 (acos -0.0)))
+
+(test 71034.0 round (* 100 (log 312918491891666147403524564598095080760332972643192197862041633988540637438735086398143104076897116667450730097183397289314559387355872839339937813881411504027225774279272518360586167057501686099965513263132778526566297754301647311975918380842568054630540214544682491386730004162058539391336047825248736472519)))
+(test 71117.0 round (* 100 (log (expt 2 1026))))
+(test 71048.0 round (* 100 (log (expt 2 1025))))
+(test 70978.0 round (* 100 (log (expt 2 1024))))
+(test 70909.0 round (* 100 (log (expt 2 1023))))
+(test 35420.0 round (* 100 (log (expt 2 511))))
+(test 35489.0 round (* 100 (log (expt 2 512))))
+(test 35558.0 round (* 100 (log (expt 2 513))))
+(test 141887.0 round (* 100 (log (expt 2 2047))))
+(test 141957.0 round (* 100 (log (expt 2 2048))))
+(test 142026.0 round (* 100 (log (expt 2 2049))))
+(test 23026.0 round (log (expt 10 10000)))
+(test 23026.0 round (real-part (log (- (expt 10 10000)))))
+(test 3.0 round (imag-part (log (- (expt 10 10000)))))
+
+(define (test-inf-bad f)
+  (test-nan.0 f +inf.0)
+  (test-nan.0 f -inf.0)
+  (test-nan.0 f +nan.0))
+
+(test-inf-bad tan)
+(test-inf-bad sin)
+(test-inf-bad cos)
+(test-inf-bad asin)
+(test-inf-bad acos)
+
+(test 11/7 rationalize (inexact->exact (atan +inf.0 1)) 1/100)
+(test -11/7 rationalize (inexact->exact (atan -inf.0 1)) 1/100)
+(test 0.0 atan 1 +inf.0)
+(test 22/7 rationalize (inexact->exact (atan 1 -inf.0)) 1/100)
+
+; Note on the following tests with atan and inf.0:
+;  The IEEE standard makes this decision. I think it's a bad one,
+;  since (limit (atan (g x) (f x))) as x -> +inf.0 is not necessarily
+;  (atan 1 1) when (limit (f x)) and (limit (g x)) are +inf.0.
+;  Perhaps IEEE makes this choice because it's easiest to compute.
+(test 7/9 rationalize (inexact->exact (atan +inf.0 +inf.0)) 1/100)
+(test 26/11 rationalize (inexact->exact (atan +inf.0 -inf.0)) 1/100)
+(test -7/9 rationalize (inexact->exact (atan -inf.0 +inf.0)) 1/100)
+
+(test-nan.0 atan +nan.0)
+(test-nan.0 atan 1 +nan.0)
+(test-nan.0 atan +nan.0 1)
+
+(test -1178.+173.i  z-round (* 1000 (atan -2+1i)))
+
+(map (lambda (f) 
+       (err/rt-test (f "a"))
+       (arity-test f 1 1))
+     (list log exp asin acos tan))
+(err/rt-test (atan "a" 1))
+(err/rt-test (atan 2+i 1))
+(err/rt-test (atan "a"))
+(err/rt-test (atan 1 "a"))
+(err/rt-test (atan 1 2+i))
+(arity-test atan 1 2)
+
+(test 3166.+1960.i  z-round (* 1000 (sin 1+2i)))
+(test -3166.-1960.i  z-round (* 1000 (sin -1-2i)))
+(test 0+1175.i z-round (* 1000 (sin 0+i)))
+(test -642.-1069.i z-round (* 1000 (cos 2+i)))
+(test -642.-1069.i z-round (* 1000 (cos -2-i)))
+(test 1543. z-round (* 1000 (cos 0+i)))
+(test 272-1084.i z-round (* 1000 (tan 1-i)))
+(test -272+1084.i z-round (* 1000 (tan -1+i)))
+
+(test 693.+3142.i z-round (* 1000 (log -2)))
+(test 1571.-1317.i z-round (* 1000 (asin 2)))
+(test -1571.+1317.i z-round (* 1000 (asin -2)))
+(test 0+3688.i z-round (* 1000 (acos 20)))
+(test 3142.-3688.i z-round (* 1000 (acos -20)))
+
+(define (cs2 c) (+ (* (cos c) (cos c)) (* (sin c) (sin c))))
+(test 0.0 imag-part (cs2 2+3i))
+(test 1000.0 round (* 1000 (real-part (cs2 2+3i))))
+(test 0.0 imag-part (cs2 -2+3i))
+(test 1000.0 round (* 1000 (real-part (cs2 -2+3i))))
+(test 0.0 imag-part (cs2 2-3i))
+(test 1000.0 round (* 1000 (real-part (cs2 2-3i))))
+
+(test #t positive? (real-part (sqrt (- 1 (* 2+3i 2+3i)))))
+
+(test (- f4.0) round (- f4.5))
+(test (- f4.0) round (- f3.5))
+(test (- f4.0) round (- f3.9))
+(test f0.0 round f0.0)
+(test f0.0 round f.25)
+(test f1.0 round f0.8)
+(test f4.0 round f3.5)
+(test f4.0 round f4.5)
+(let ((x (string->number "4195835.0"))
+      (y (string->number "3145727.0")))
+  (test #t 'pentium-fdiv-bug (> f1.0 (- x (* (/ x y) y)))))
+
+(test (exact->inexact 1/3) rationalize .3 1/10)
+(test 1/3 rationalize 3/10 1/10)
+(test (exact->inexact 1/3) rationalize .3 -1/10)
+(test 1/3 rationalize 3/10 -1/10)
+(test 0 rationalize 3/10 4/10)
+(test 0.0 rationalize .3 4/10)
+(test 0.0 rationalize .3+0.0i 4/10)
+(test #i1/3 rationalize .3+0.0i 1/10)
+
+(define (test-rat-inf v)
+  (define zero (if (exact? v) 0 0.0))
+
+  (test +inf.0 rationalize +inf.0 v)
+  (test -inf.0 rationalize -inf.0 v)
+  (test-nan.0 rationalize +nan.0 v)
+
+  (test zero rationalize v +inf.0)
+  (test zero rationalize v -inf.0)
+  (test-nan.0 rationalize v +nan.0))
+
+(let loop ([i 100])
+  (unless (= i -100)
+	  (test (/ i 100) rationalize (inexact->exact (/ i 100.0)) 1/100000)
+	  (loop (sub1 i))))
+
+(arity-test rationalize 2 2)
+
+(define tb
+  (lambda (n1 n2)
+    (= n1 (+ (* n2 (quotient n1 n2))
+	     (remainder n1 n2)))))
+
+
+(SECTION 6 5 5)
+
+(test -2147483648 - 2147483648)
+(test 2147483648 - -2147483648)
+(test #f = -2147483648 2147483648)
+(test #t = -2147483648 -2147483648)
+(test #t = 2147483648 2147483648)
+(test 2147483647 sub1 2147483648)
+(test 2147483648 add1 2147483647)
+(test 2147483648 * 1 2147483648)
+
+(test 437893890380859375 expt 15 15)
+
+(test 0 modulo -2177452800 86400)
+(test 0 modulo 2177452800 -86400)
+(test 0 modulo 2177452800 86400)
+(test 0 modulo -2177452800 -86400)
+
+(test 86399 modulo -2177452801 86400)
+(test -1 modulo 2177452799 -86400)
+(test 1 modulo 2177452801 86400)
+(test -86399 modulo -2177452799 -86400)
+
+(test #t 'remainder (tb 281474976710655 65535))
+(test #t 'remainder (tb 281474976710654 65535))
+(SECTION 6 5 6)
+(test 281474976710655 string->number "281474976710655")
+(test "281474976710655" number->string 281474976710655)
+(test "-4" number->string -4 16)
+(test "-e" number->string -14 16)
+(test "0" number->string 0 16)
+(test "30000000" number->string #x30000000 16)
+
+
+(SECTION 6 5 6)
+(test "0" number->string 0)
+(test "100" number->string 100)
+(test "100" number->string 256 16)
+(test 256 string->number "100" 16)
+(test 15 string->number "#o17")
+(test 15 string->number "#o17" 10)
+
+(load-relative "numstrs.ss")
+(let loop ([l number-table])
+  (unless (null? l)
+	  (let* ([pair (car l)]
+		 [v (car pair)]
+		 [v (if (or (eq? v 'X)
+			    (symbol? v)
+			    (eof-object? v))
+			#f 
+			v)]
+		 [s (cadr pair)])
+	    (test v string->number s))
+	  (loop (cdr l))))
+
+;; Test special inexact names in complex combinations:
+(let ([parts '(+inf.0 -inf.0 +nan.0 1 0 0.0 1/2)])
+  (for-each
+   (lambda (a)
+     (for-each
+      (lambda (b)
+	(let ([rect (format "~a~a~ai"
+			    a
+			    (if (member b '(+inf.0 -inf.0 +nan.0))
+				""
+				"+")
+			    b)]
+	      [polar (format "~a@~a" a b)])
+	  (test (make-rectangular a b) string->number rect)
+	  (test (make-polar a b) string->number polar)))
+      parts))
+   parts)
+
+  (for-each
+   (lambda (a)
+     (let ([rect1 (format "~a+1/0i" a)]
+	   [rect2 (format "1/0~a~ai"
+			  (if (member a '(+inf.0 -inf.0 +nan.0))
+			      ""
+			      "+")
+			  a)]
+	   [polar1 (format "~a@1/0" a)]
+	   [polar2 (format "1/0@~a" a)]
+	   [dbz-test (lambda (s)
+		       (test 'div 'divide-by-zero
+			     (with-handlers ([(lambda (x)
+						(and (exn:fail:read? x)
+						     (regexp-match "division by zero" 
+								   (exn-message x))))
+					      (lambda (x) 'div)])
+			       (read (open-input-string s)))))])
+       (test #f string->number rect1)
+       (test #f string->number rect2)
+       (test #f string->number polar1)
+       (test #f string->number polar2)
+       (dbz-test rect1)
+       (dbz-test rect2)
+       (dbz-test polar1)
+       (dbz-test polar2)))
+   parts))
+
+(test #f string->number "88" 7)
+(test #f string->number "")
+(test #f string->number " 1")
+(test #f string->number ".")
+(test #f string->number "#4@#i5")
+(test #f string->number "190888 qwerqwerq")
+(test #t symbol? '1/x)
+(test #t symbol? '1+ei)
+(test #t symbol? '|1/0|)
+
+(arity-test string->number 1 2)
+(arity-test number->string 1 2)
+
+(err/rt-test (number->string 'a))
+(err/rt-test (number->string 1 'a))
+(err/rt-test (number->string 'a 10))
+(err/rt-test (number->string 1.8 8) exn:application:mismatch?)
+(err/rt-test (number->string 1 -1))
+
+(err/rt-test (string->number 'a))
+(err/rt-test (string->number 'a 'a))
+(err/rt-test (string->number "12" -1))
+(err/rt-test (string->number "12" 17))
+(err/rt-test (string->number "1" "1"))
+(err/rt-test (string->number 1 1))
+
+(test #t andmap (lambda (x) (and (>= x 0) (< x 10))) (map random '(10 10 10 10)))
+(test (void) random-seed 5)
+(test (begin (random-seed 23) (list (random 10) (random 20) (random 30)))
+      'random-seed-same
+      (begin (random-seed 23) (list (random 10) (random 20) (random 30))))
+(arity-test random-seed 1 1)
+(arity-test random 0 1)
+(err/rt-test (random-seed "apple"))
+(err/rt-test (random-seed 4.5))
+(err/rt-test (random-seed -1))
+(err/rt-test (random-seed (expt 2 31)))
+(err/rt-test (random-seed big-num))
+(err/rt-test (random "apple"))
+(err/rt-test (random 0))
+(err/rt-test (random -6))
+(err/rt-test (random (expt 2 31)))
+(err/rt-test (random big-num))
+
+(random-seed 101)
+(define x (list (random 10) (random 20) (random 30)))
+(random-seed 101)
+(parameterize ([current-pseudo-random-generator (make-pseudo-random-generator)])
+  (random 10)
+  (random 10))
+(test x 'generator-preserved (list (random 10) (random 20) (random 30)))
+(random-seed 101)
+(thread-wait (thread (lambda ()
+		       (random 10)
+		       (random 10))))
+(test #f 'generator-not-preserved (equal? x (list (random 10) (random 20) (random 30))))
+(test #t pseudo-random-generator? (make-pseudo-random-generator))
+(test #t pseudo-random-generator? (current-pseudo-random-generator))
+(test #t pseudo-random-generator? (current-sync-pseudo-random-generator))
+(test #f pseudo-random-generator? 10)
+(arity-test pseudo-random-generator? 1 1)
+(arity-test make-pseudo-random-generator 0 0)
+(arity-test current-pseudo-random-generator 0 1)
+(arity-test current-sync-pseudo-random-generator 0 1)
+(err/rt-test (current-pseudo-random-generator 10))
+
+
+(SECTION 'bignum)
+
+(test #t = 0 0)
+(test #f = 0 (expt 2 32))
+(test #f = (expt 2 32) 0)
+(test #f = (- (expt 2 32)) (expt 2 32))
+(test #f = (expt 2 32) (- (expt 2 32)))
+(test #t = 1234567890987654321 1234567890987654321)
+
+(test #f < 0 0)
+(test #t < 0 (expt 2 32))
+(test #f < (expt 2 32) 0)
+(test #t < (- (expt 2 32)) 0)
+(test #f < 0 (- (expt 2 32)))
+(test #f < 1234567890987654321 1234567890987654321)
+(test #t < (- (expt 3 64)) (- (expt 2 13)))
+(test #f < (- (expt 2 13)) (- (expt 3 64)))
+(test #t < (- 123456789876543200) 123456789876543200)
+(test #f < 123456789876543200 (- 123456789876543200))
+
+(test 1234567890987654321 + 1234567890987654321 0)
+(test 1234567890987654321 + 0 1234567890987654321)
+(test 1234567890987654321 - 1234567890987654321 0)
+(test -1234567890987654321 - 0 1234567890987654321)
+(test (expt 2 33) + (expt 2 32) (expt 2 32))
+(test 0 - (expt 2 32) (expt 2 32))
+(test (expt 2 31) - (expt 2 32) (expt 2 31))
+(test (- (expt 2 31)) - (expt 2 31) (expt 2 32))
+(test 18446744073709551621 + 18446744073709551615 6)
+(test 18446744073709551621 + 6 18446744073709551615)
+(test 0 - #xfffffffffffffffff #xfffffffffffffffff)
+(test -1 - #xffffffffffffffffe #xfffffffffffffffff)
+(test 1 - #xfffffffffffffffff #xffffffffffffffffe)
+(test #x1000000000000000000000000 + #xffffffffffffffffffffffff 1)
+
+(test 0 * 1234567890987654321 0)
+(test 0 * 0 1234567890987654321)
+(test #x100000000000000000000 * #x100000000000 #x1000000000)
+(test #x-100000000000000000000 * #x100000000000 #x-1000000000)
+(test #x100000000000000000000 * #x-100000000000 #x-1000000000)
+(test #x-100000000000000000000 * #x-100000000000 #x1000000000)
+(test #x100000000000000000000 * #x1000000000 #x100000000000)
+(test #x-100000000000000000000 * #x1000000000 #x-100000000000)
+(test #x100000000000000000000 * #x-1000000000 #x-100000000000)
+(test #x-100000000000000000000 * #x-1000000000 #x100000000000)
+(test 4521191813415169 * #x100000000001 #x101)
+(test 4521191813415169 * #x101 #x100000000001)
+
+(test (expt 2 35) * (expt 2 32) 8)
+(test (- (expt 2 35)) * (- (expt 2 32)) 8)
+(test (- (expt 2 35)) * (expt 2 32) -8)
+(test (expt 2 35) * (- (expt 2 32)) -8)
+(test (- (add1 (expt 2 128)) (expt 2 65)) * (sub1 (expt 2 64)) (sub1 (expt 2 64)))
+
+(test 4294967296 expt 2 32)
+(test 3433683820292512484657849089281 expt 3 64)
+(test 8192 expt 2 13)
+(test 8589934592 expt 2 33)
+(test 2147483648 expt 2 31)
+(test 34359738368 expt 2 35)
+(test 36893488147419103232 expt 2 65)
+(test 18446744073709551616 expt 2 64)
+(test 340282366920938463463374607431768211456 expt 2 128)
+(test 340282366920938463463374607431768211456 expt -2 128)
+(test 174449211009120179071170507 expt 3 55)
+(test -174449211009120179071170507 expt -3 55)
+(test 59768263894155949306790119265585619217025149412430681649 expt 7 66)
+(test 1 expt 1234567890987654321 0)
+(test 0 expt 0 1234567890987654321)
+(test 1 expt 1 1234567890987654321)
+(test 1234567890987654321 expt 1234567890987654321 1)
+(test 828179745220145502584084235957368498016122811853894435464201864103254919330121223037770283296858019385573376 expt 953962166440690129601298432 4)
+
+(test 0 bitwise-and 0 1234567890987654321)
+(test 0 bitwise-and 1234567890987654321 0)
+(test 0 bitwise-and -1234567890987654321 0)
+(test 0 bitwise-and 0 -1234567890987654321)
+(test 1234567890987654321 bitwise-and -1 1234567890987654321)
+(test 1234567890987654321 bitwise-and 1234567890987654321 -1)
+(test -1234567890987654321 bitwise-and -1 -1234567890987654321)
+(test -1234567890987654321 bitwise-and -1234567890987654321 -1)
+(test 19687594650088321058936321 bitwise-and (expt 3 55) (expt 7 66))
+(test 59768263894155949306790119265565931622375061091371745329 bitwise-and (- (expt 3 55)) (expt 7 66))
+(test 154761616359031858012234187 bitwise-and (expt 3 55) (- (expt 7 66)))
+(test -59768263894155949306790119265740380833384181270442915835 bitwise-and (- (expt 3 55)) (- (expt 7 66)))
+(test 19687594650088321058936321 bitwise-and (expt 7 66) (expt 3 55))
+(test 59768263894155949306790119265565931622375061091371745329 bitwise-and (expt 7 66) (- (expt 3 55)))
+(test 154761616359031858012234187 bitwise-and (- (expt 7 66)) (expt 3 55))
+(test -59768263894155949306790119265740380833384181270442915835 bitwise-and (- (expt 7 66)) (- (expt 3 55)))
+(test #x-10000000000000000 bitwise-and #x-100000000 #x-ffffffff00000001)
+(test -9223372036854775808 bitwise-and (- (expt 2 31)) (- (expt 2 63)))
+(test -57896044618658097711785492504343953926634992332820282019728792003956564819968 bitwise-and (- (expt 2 127)) (- (expt 2 255)))
+(test -115792089237316195423570985008687907853269984665640564039457584007913129639936 bitwise-and (- (expt 2 128)) (- (expt 2 256)))
+(test 0 bitwise-and #x10101010101010101010101010 #x1010101010101010101010101)
+(test 0 bitwise-and #x10101010101010101010101010 #x101010101)
+(test #xf0000000 bitwise-and #x101010101010101010f0101010 #xf1010101)
+
+(test 1234567890987654321 bitwise-ior 0 1234567890987654321)
+(test 1234567890987654321 bitwise-ior 1234567890987654321 0)
+(test -1234567890987654321 bitwise-ior -1234567890987654321 0)
+(test -1234567890987654321 bitwise-ior 0 -1234567890987654321)
+(test -1 bitwise-ior -1 1234567890987654321)
+(test -1 bitwise-ior 1234567890987654321 -1)
+(test -1 bitwise-ior -1 -1234567890987654321)
+(test -1 bitwise-ior -1234567890987654321 -1)
+(test -1 bitwise-ior #x-100000000 #x-ffffffff00000001)
+(test 59768263894155949306790119265740380833384181270442915835 bitwise-ior (expt 3 55) (expt 7 66))
+(test -154761616359031858012234187 bitwise-ior (- (expt 3 55)) (expt 7 66))
+(test -59768263894155949306790119265565931622375061091371745329 bitwise-ior (expt 3 55) (- (expt 7 66)))
+(test -19687594650088321058936321 bitwise-ior (- (expt 3 55)) (- (expt 7 66)))
+(test 59768263894155949306790119265740380833384181270442915835 bitwise-ior (expt 7 66) (expt 3 55))
+(test -154761616359031858012234187 bitwise-ior (expt 7 66) (- (expt 3 55)))
+(test -59768263894155949306790119265565931622375061091371745329 bitwise-ior (- (expt 7 66)) (expt 3 55))
+(test -19687594650088321058936321 bitwise-ior (- (expt 7 66)) (- (expt 3 55)))
+(test 9223372039002259456 bitwise-ior (expt 2 31) (expt 2 63))
+(test #xf000000f bitwise-ior #xf0000000 #x0000000f)
+(test -15 bitwise-ior #xf0000000 #x-f000000f)
+(test #x-100000000 bitwise-ior #x-100000000 #x-1000000000000)
+(test #x-10000000000000000 bitwise-ior #x-10000000000000000 #x-10000000000000000)
+(test #x-100000000 bitwise-ior #xffff00000000 #x-1000000000000)
+(test #x-ffffffff bitwise-ior #x-100000000 1)
+
+(test 1234567890987654321 bitwise-xor 0 1234567890987654321)
+(test 1234567890987654321 bitwise-xor 1234567890987654321 0)
+(test -1234567890987654321 bitwise-xor -1234567890987654321 0)
+(test -1234567890987654321 bitwise-xor 0 -1234567890987654321)
+(test -1234567890987654322 bitwise-xor -1 1234567890987654321)
+(test -1234567890987654322 bitwise-xor 1234567890987654321 -1)
+(test 1234567890987654320 bitwise-xor -1 -1234567890987654321)
+(test 1234567890987654320 bitwise-xor -1234567890987654321 -1)
+(test 59768263894155949306790119265720693238734092949383979514 bitwise-xor (expt 3 55) (expt 7 66))
+(test -59768263894155949306790119265720693238734092949383979516 bitwise-xor (- (expt 3 55)) (expt 7 66))
+(test -59768263894155949306790119265720693238734092949383979516 bitwise-xor (expt 3 55) (- (expt 7 66)))
+(test 59768263894155949306790119265720693238734092949383979514 bitwise-xor (- (expt 3 55)) (- (expt 7 66)))
+(test 59768263894155949306790119265720693238734092949383979514 bitwise-xor (expt 7 66) (expt 3 55))
+(test -59768263894155949306790119265720693238734092949383979516 bitwise-xor (expt 7 66) (- (expt 3 55)))
+(test -59768263894155949306790119265720693238734092949383979516 bitwise-xor (- (expt 7 66)) (expt 3 55))
+(test 59768263894155949306790119265720693238734092949383979514 bitwise-xor (- (expt 7 66)) (- (expt 3 55)))
+(test #xffffffffffffffff bitwise-xor #xf0f0f0f0f0f0f0f0 #x0f0f0f0f0f0f0f0f)
+(test #x-ffffffffffffffff bitwise-xor #xf0f0f0f0f0f0f0f0 #x-0f0f0f0f0f0f0f0f)
+(test #xffffffffffffffe1 bitwise-xor #x-f0f0f0f0f0f0f0f0 #x-0f0f0f0f0f0f0f0f)
+(test #x-ffffffffffffffe1 bitwise-xor #x-f0f0f0f0f0f0f0f0 #x0f0f0f0f0f0f0f0f)
+(test 0 bitwise-xor #xff00ff00ff00 #xff00ff00ff00)
+(test 1 bitwise-xor #xff00ff00ff00 #xff00ff00ff01)
+
+(test -1 bitwise-not 0)
+(test -2 bitwise-not 1)
+(test 0 bitwise-not -1)
+(test -170141183460469231731687303715884105729 bitwise-not (expt 2 127))
+(test -115792089237316195423570985008687907853269984665640564039457584007913129639937 bitwise-not (expt 2 256))
+(test 170141183460469231731687303715884105727 bitwise-not (- (expt 2 127)))
+(test 115792089237316195423570985008687907853269984665640564039457584007913129639935 bitwise-not (- (expt 2 256)))
+(test -6495847189879200919523571558866128178519676272281183726839381003906688615833519556218736219093975317609794137607877958572218335473711513642939050 bitwise-not (expt 13 130))
+(test 6495847189879200919523571558866128178519676272281183726839381003906688615833519556218736219093975317609794137607877958572218335473711513642939048 bitwise-not (- (expt 13 130)))
+(test #x40000000 bitwise-not #x-40000001)
+
+(test 1234567890987654321 arithmetic-shift 1234567890987654321 0)
+(test -1234567890987654321 arithmetic-shift -1234567890987654321 0)
+(test (expt 2 32) arithmetic-shift (expt 2 31) 1)
+(test (expt 2 256) arithmetic-shift (expt 2 128) 128)
+(test (expt 2 277) arithmetic-shift (expt 2 125) 152)
+(test (- (expt 2 256)) arithmetic-shift (- (expt 2 128)) 128)
+(test (- (expt 2 277)) arithmetic-shift (- (expt 2 125)) 152)
+(test (* (expt 13 55) (expt 2 97)) arithmetic-shift (expt 13 55) 97)
+(test (* (- (expt 13 55)) (expt 2 97)) arithmetic-shift (- (expt 13 55)) 97)
+(test 0 arithmetic-shift 1234567890987654321 -10000)
+(test -1 arithmetic-shift -1234567890987654321 -10000)
+(test (quotient (expt 13 55) (expt 2 100)) arithmetic-shift (expt 13 55) -100)
+(test (quotient (expt 13 55) (expt 2 128)) arithmetic-shift (expt 13 55) -128)
+(test (expt 2 13) arithmetic-shift (expt 2 256) -243)
+(test (sub1 (quotient (- (expt 13 55)) (expt 2 100))) arithmetic-shift (- (expt 13 55)) -100)
+(test (sub1 (quotient (- (expt 13 55)) (expt 2 128))) arithmetic-shift (- (expt 13 55)) -128)
+(test (- (expt 2 13)) arithmetic-shift (- (expt 2 256)) -243)
+(test #x100000000 arithmetic-shift #x200000000 -1)
+(test #x200000000 arithmetic-shift #x100000000 1)
+
+(test "0" number->string 0)
+(test "1" number->string 1)
+(test "-1" number->string -1)
+(test "7284132478923046920834523467890234589203467590267382904573942345703" number->string 7284132478923046920834523467890234589203467590267382904573942345703)
+(test "-7284132478923046920834523467890234589203467590267382904573942345703" number->string -7284132478923046920834523467890234589203467590267382904573942345703)
+(test "1000101001010101011111011000101001011011100111110001111111010101000100010110001001011011101111011001111101000100110100010101111001111001001011111001000100111000011111110010101010110110001011011111101110000001010111111100111" number->string 7284132478923046920834523467890234589203467590267382904573942345703 2)
+(test "-1000101001010101011111011000101001011011100111110001111111010101000100010110001001011011101111011001111101000100110100010101111001111001001011111001000100111000011111110010101010110110001011011111101110000001010111111100111" number->string -7284132478923046920834523467890234589203467590267382904573942345703 2)
+(test "105125373051334761772504261133573175046425717113710470376252661337560127747" number->string 7284132478923046920834523467890234589203467590267382904573942345703 8)
+(test "-105125373051334761772504261133573175046425717113710470376252661337560127747" number->string -7284132478923046920834523467890234589203467590267382904573942345703 8)
+(test "452abec52dcf8fea88b12ddecfa268af3c97c89c3f955b16fdc0afe7" number->string 7284132478923046920834523467890234589203467590267382904573942345703 16)
+(test "-452abec52dcf8fea88b12ddecfa268af3c97c89c3f955b16fdc0afe7" number->string -7284132478923046920834523467890234589203467590267382904573942345703 16)
+(test "115792089237316195423570985008687907853269984665640564039457584007913129639936" number->string (expt 2 256))
+(test "115792089237316195423570985008687907853269984665640564039457584007913129639935" number->string (sub1 (expt 2 256)))
+(test "10000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000" number->string (expt 2 256) 2)
+(test "1111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111" number->string (sub1 (expt 2 256)) 2)
+(test "20000000000000000000000000000000000000000000000000000000000000000000000000000000000000" number->string (expt 2 256) 8)
+(test "17777777777777777777777777777777777777777777777777777777777777777777777777777777777777" number->string (sub1 (expt 2 256)) 8)
+(test "10000000000000000000000000000000000000000000000000000000000000000" number->string (expt 2 256) 16)
+(test "ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff" number->string (sub1 (expt 2 256)) 16)
+(test "-115792089237316195423570985008687907853269984665640564039457584007913129639936" number->string (- (expt 2 256)))
+(test "-115792089237316195423570985008687907853269984665640564039457584007913129639935" number->string (- (sub1 (expt 2 256))))
+(test "-10000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000" number->string (- (expt 2 256)) 2)
+(test "-1111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111" number->string (- (sub1 (expt 2 256))) 2)
+(test "-20000000000000000000000000000000000000000000000000000000000000000000000000000000000000" number->string (- (expt 2 256)) 8)
+(test "-17777777777777777777777777777777777777777777777777777777777777777777777777777777777777" number->string (- (sub1 (expt 2 256))) 8)
+(test "-10000000000000000000000000000000000000000000000000000000000000000" number->string (- (expt 2 256)) 16)
+(test "-ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff" number->string (- (sub1 (expt 2 256))) 16)
+
+
+(test 0 string->number "0")
+(test 1 string->number "1")
+(test -1 string->number "-1")
+(test 7284132478923046920834523467890234589203467590267382904573942345703 string->number "7284132478923046920834523467890234589203467590267382904573942345703")
+(test -7284132478923046920834523467890234589203467590267382904573942345703 string->number "-7284132478923046920834523467890234589203467590267382904573942345703")
+(test 7284132478923046920834523467890234589203467590267382904573942345703 string->number "1000101001010101011111011000101001011011100111110001111111010101000100010110001001011011101111011001111101000100110100010101111001111001001011111001000100111000011111110010101010110110001011011111101110000001010111111100111" 2)
+(test -7284132478923046920834523467890234589203467590267382904573942345703 string->number "-1000101001010101011111011000101001011011100111110001111111010101000100010110001001011011101111011001111101000100110100010101111001111001001011111001000100111000011111110010101010110110001011011111101110000001010111111100111" 2)
+(test  7284132478923046920834523467890234589203467590267382904573942345703 string->number "105125373051334761772504261133573175046425717113710470376252661337560127747" 8)
+(test -7284132478923046920834523467890234589203467590267382904573942345703 string->number "-105125373051334761772504261133573175046425717113710470376252661337560127747" 8)
+(test 7284132478923046920834523467890234589203467590267382904573942345703 string->number "452abec52dcf8fea88b12ddecfa268af3c97c89c3f955b16fdc0afe7" 16)
+(test -7284132478923046920834523467890234589203467590267382904573942345703 string->number "-452abec52dcf8fea88b12ddecfa268af3c97c89c3f955b16fdc0afe7" 16)
+(test (expt 2 256) string->number "115792089237316195423570985008687907853269984665640564039457584007913129639936")
+(test (sub1 (expt 2 256)) string->number "115792089237316195423570985008687907853269984665640564039457584007913129639935")
+(test (expt 2 256) string->number "10000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000" 2)
+(test (sub1 (expt 2 256)) string->number "1111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111" 2)
+(test (expt 2 256) string->number "20000000000000000000000000000000000000000000000000000000000000000000000000000000000000" 8)
+(test (sub1 (expt 2 256)) string->number "17777777777777777777777777777777777777777777777777777777777777777777777777777777777777" 8)
+(test (expt 2 256) string->number "10000000000000000000000000000000000000000000000000000000000000000" 16)
+(test (sub1 (expt 2 256)) string->number "ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff" 16)
+(test (- (expt 2 256)) string->number "-115792089237316195423570985008687907853269984665640564039457584007913129639936")
+(test (- (sub1 (expt 2 256))) string->number "-115792089237316195423570985008687907853269984665640564039457584007913129639935")
+(test (- (expt 2 256)) string->number "-10000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000" 2)
+(test (- (sub1 (expt 2 256))) string->number "-1111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111" 2)
+(test (- (expt 2 256)) string->number "-20000000000000000000000000000000000000000000000000000000000000000000000000000000000000" 8)
+(test (- (sub1 (expt 2 256))) string->number "-17777777777777777777777777777777777777777777777777777777777777777777777777777777777777" 8)
+(test (- (expt 2 256)) string->number "-10000000000000000000000000000000000000000000000000000000000000000" 16)
+(test (- (sub1 (expt 2 256))) string->number "-ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff" 16)
+(test #f string->number "144r" 10)
+(err/rt-test (string->number "10" 30))
+
+(define (q-test quotient)
+  (test 0 quotient 0 12345678909876532341)
+  (test 0 quotient 0 -1235782934075829307)
+  (test 2374865902374859023745 quotient 2374865902374859023745 1)
+  (test -2374865902374859023745 quotient -2374865902374859023745 1)
+  (test 0 quotient 1 13748910785903278450)
+  (test 1 quotient 13748910785903278450 13748910785903278449)
+  (test 0 quotient 13748910785903278450 13748910785903278451)
+  (test -1 quotient -13748910785903278450 13748910785903278449)
+  (test 0 quotient -13748910785903278450 13748910785903278451)
+  (test -1 quotient 13748910785903278450 -13748910785903278449)
+  (test 0 quotient 13748910785903278450 -13748910785903278451)
+  (test 1 quotient -13748910785903278450 -13748910785903278449)
+  (test 0 quotient -13748910785903278450 -13748910785903278451)
+  (test 1 quotient 13748910785903278450 13748910785903278450)
+  (test -1 quotient -13748910785903278450 13748910785903278450)
+  (test -1 quotient 13748910785903278450 -13748910785903278450)
+  (test 1 quotient -13748910785903278450 -13748910785903278450)
+  (test (expt 5 64) quotient (expt 5 256) (expt 5 192))
+  (test 0 quotient (expt 5 192) (expt 5 256))
+  (test 8636168555094444625386351862800399571116000364436281385023703470168591803162427057971507503472288226560547293946149 quotient (expt 5 192) (expt 2 64)))
+(q-test quotient)
+(q-test (lambda (n1 n2) (let-values ([(q r) (quotient/remainder n1 n2)]) q)))
+
+(define (r-test remainder)
+  (test 0 remainder 0 12345678909876532341)
+  (test 0 remainder 0 -1235782934075829307)
+  (test 0 remainder 2374865902374859023745 1)
+  (test 0 remainder -2374865902374859023745 1)
+  (test 1 remainder 1 13748910785903278450)
+  (test 1 remainder 13748910785903278450 13748910785903278449)
+  (test 13748910785903278450 remainder 13748910785903278450 13748910785903278451)
+  (test -1 remainder -13748910785903278450 13748910785903278449)
+  (test -13748910785903278450 remainder -13748910785903278450 13748910785903278451)
+  (test 1 remainder 13748910785903278450 -13748910785903278449)
+  (test 13748910785903278450 remainder 13748910785903278450 -13748910785903278451)
+  (test -1 remainder -13748910785903278450 -13748910785903278449)
+  (test -13748910785903278450 remainder -13748910785903278450 -13748910785903278451)
+  (test 0 remainder 13748910785903278450 13748910785903278450)
+  (test 0 remainder -13748910785903278450 13748910785903278450)
+  (test 0 remainder 13748910785903278450 -13748910785903278450)
+  (test 0 remainder -13748910785903278450 -13748910785903278450)
+  (test 0 remainder (expt 5 256) (expt 5 192))
+  (test (expt 5 192) remainder (expt 5 192) (expt 5 256))
+  (test 12241203936672963841 remainder (expt 5 192) (expt 2 64)))
+(r-test remainder)
+(r-test (lambda (n1 n2) (let-values ([(q r) (quotient/remainder n1 n2)]) r)))
+
+(define (s-test sqrt)
+  (test 0 sqrt 0)
+  (test 1 sqrt 1)
+  (test 2 sqrt 4)
+  (test 3 sqrt 9)
+  (test (expt 2 64) sqrt (* (expt 2 64) (expt 2 64)))
+  (test (expt 13 70) sqrt (* (expt 13 70) (expt 13 70)))
+  (test (sub1 (expt 2 200)) sqrt (* (sub1 (expt 2 200)) (sub1 (expt 2 200))))
+  (test (expt 2 25) sqrt (expt 2 50))
+  (test 1 sqrt 3)
+  (test #xffffffff sqrt (sub1 (expt 2 64)))
+  (test 2876265888493261300027370452880859375 sqrt (expt 15 62))
+  (test #x8f0767e50d4d0c07563bd81f530d36 sqrt (expt 15 61)))
+(s-test integer-sqrt)
+(s-test (lambda (a) (let-values ([(root rem) (integer-sqrt/remainder a)]) root)))
+
+(define (sr-test sqrt)
+  (test 0 sqrt 0)
+  (test 0 sqrt 1)
+  (test 0 sqrt 4)
+  (test 0 sqrt 9)
+  (test 0 sqrt (* (expt 2 64) (expt 2 64)))
+  (test 0 sqrt (* (expt 13 70) (expt 13 70)))
+  (test 0 sqrt (* (sub1 (expt 2 200)) (sub1 (expt 2 200))))
+  (test 0 sqrt (expt 2 50))
+  (test 2 sqrt 3)
+  (test 8589934590 sqrt (sub1 (expt 2 64)))
+  (test 0 sqrt (expt 15 62))
+  (test 1306106749204831357295958563982718571 sqrt (expt 15 61)))
+(sr-test (lambda (a) (let-values ([(root rem) (integer-sqrt/remainder a)]) rem)))
+
+(test 1.7320508075688772 sqrt 3)
+(test 4294967296.0 sqrt (sub1 (expt 2 64)))
+(test 2876265888493261300027370452880859375 sqrt (expt 15 62))
+(test 7.426486590265921e+35 sqrt (expt 15 61))
+
+
+
+(test 5.515270307539953e+71 exact->inexact (expt 15 61))
+(test -5.515270307539953e+71 exact->inexact (- (expt 15 61)))
+(test 1.8446744073709552e+19 exact->inexact (expt 2 64))
+(test 1.157920892373162e+77 exact->inexact (expt 2 256))
+(test 1.157920892373162e+77 exact->inexact (sub1 (expt 2 256)))
+
+(test 551527030753995340375346347667240734743269800540264151034260072897183744 inexact->exact 5.515270307539953d+71)
+(test (expt 2 64) inexact->exact 1.8446744073709552e+19)
+(test (- (expt 2 64)) inexact->exact -1.8446744073709552e+19)
+(test (expt 2 256) inexact->exact 1.157920892373162d+77)
+(test 115792089237316195423570985008687907853269984665640564039457584007913129639936 inexact->exact 1.157920892373162d+77)
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(test (integer-bytes->integer #"\1\2" #f) integer-bytes->integer #"\1\2" #f (system-big-endian?))
+
+(test 0 integer-bytes->integer #"\0\0" #t)
+(test -1 integer-bytes->integer #"\377\377" #t)
+(test 65535 integer-bytes->integer #"\377\377" #f)
+;;
+(test 0 integer-bytes->integer #"\0\0" #t #t)
+(test -1 integer-bytes->integer #"\377\377" #t #t)
+(test 65535 integer-bytes->integer #"\377\377" #f #t)
+(test -256 integer-bytes->integer #"\377\0" #t #t)
+(test -255 integer-bytes->integer #"\377\1" #t #t)
+(test 511 integer-bytes->integer #"\1\377" #t #t)
+(test 513 integer-bytes->integer #"\1\2" #f #f)
+;;
+(test 0 integer-bytes->integer #"\0\0" #t #f)
+(test -1 integer-bytes->integer #"\377\377" #t #f)
+(test 65535 integer-bytes->integer #"\377\377" #f #f)
+(test 511 integer-bytes->integer #"\377\1" #t #f)
+(test -255 integer-bytes->integer #"\1\377" #t #f)
+(test 258 integer-bytes->integer #"\1\2" #f #t)
+
+(test 0 integer-bytes->integer #"\0\0\0\0" #t)
+(test -1 integer-bytes->integer #"\377\377\377\377" #t)
+(test 4294967295 integer-bytes->integer #"\377\377\377\377" #f)
+;;
+(test 0 integer-bytes->integer #"\0\0\0\0" #t #t)
+(test -1 integer-bytes->integer #"\377\377\377\377" #t #t)
+(test 4294967295 integer-bytes->integer #"\377\377\377\377" #f #t)
+(test -16777216 integer-bytes->integer #"\377\0\0\0" #t #t)
+(test 255 integer-bytes->integer #"\0\0\0\377" #t #t)
+;;
+(test 0 integer-bytes->integer #"\0\0\0\0" #t #f)
+(test -1 integer-bytes->integer #"\377\377\377\377" #t #f)
+(test 4294967295 integer-bytes->integer #"\377\377\377\377" #f #f)
+(test 16777471 integer-bytes->integer #"\377\0\0\1" #t #f)
+(test -16777216 integer-bytes->integer #"\0\0\0\377" #t #f)
+(test -16777215 integer-bytes->integer #"\1\0\0\377" #t #f)
+
+(test 1835103348 integer-bytes->integer #"matt" #t #t)
+(test 1953784173 integer-bytes->integer #"matt" #t #f)
+
+(test 0 integer-bytes->integer #"\0\0\0\0\0\0\0\0" #t #t)
+(test -1 integer-bytes->integer #"\377\377\377\377\377\377\377\377" #t #f)
+(test 18446744073709551615 integer-bytes->integer #"\377\377\377\377\377\377\377\377" #f #f)
+(test 4294967295 integer-bytes->integer #"\377\377\377\377\0\0\0\0" #t #f)
+(test -4294967296 integer-bytes->integer #"\0\0\0\0\377\377\377\377" #t #f)
+(test 8589934591 integer-bytes->integer #"\377\377\377\377\1\0\0\0" #t #f)
+(test -4294967295 integer-bytes->integer #"\1\0\0\0\377\377\377\377" #t #f)
+;;
+(test 0 integer-bytes->integer #"\0\0\0\0\0\0\0\0" #t #f)
+(test -1 integer-bytes->integer #"\377\377\377\377\377\377\377\377" #t #f)
+(test 18446744073709551615 integer-bytes->integer #"\377\377\377\377\377\377\377\377" #f #f)
+(test -4294967296 integer-bytes->integer #"\377\377\377\377\0\0\0\0" #t #t)
+(test 4294967295 integer-bytes->integer #"\0\0\0\0\377\377\377\377" #t #t)
+(test -4294967295 integer-bytes->integer #"\377\377\377\377\0\0\0\1" #t #t)
+(test 8589934591 integer-bytes->integer #"\0\0\0\1\377\377\377\377" #t #t)
+
+(arity-test integer-bytes->integer 2 3)
+(err/rt-test (integer-bytes->integer 'ok #t))
+(err/rt-test (integer-bytes->integer #"" #t))
+(err/rt-test (integer-bytes->integer #"a" #t))
+(err/rt-test (integer-bytes->integer #"abc" #t))
+(err/rt-test (integer-bytes->integer #"abcdefghi" #t))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(test (integer->integer-bytes 42 2 #f) integer->integer-bytes 42 2 #f (system-big-endian?))
+
+(test #"\0\0" integer->integer-bytes 0 2 #t)
+(test #"\377\377" integer->integer-bytes -1 2 #t)
+(test #"\377\377" integer->integer-bytes 65535 2 #f)
+;;
+(test #"\0\0" integer->integer-bytes 0 2 #t #t)
+(test #"\377\377" integer->integer-bytes -1 2 #t #t)
+(test #"\377\377" integer->integer-bytes 65535 2 #f #t)
+(test #"\377\0" integer->integer-bytes -256 2 #t #t)
+(test #"\377\1" integer->integer-bytes -255 2 #t #t)
+(test #"\1\377" integer->integer-bytes 511 2 #t #t)
+(test #"\1\2" integer->integer-bytes 513 2 #f #f)
+;;
+(test #"\0\0" integer->integer-bytes 0 2 #t #f)
+(test #"\377\377" integer->integer-bytes -1 2 #t #f)
+(test #"\377\377" integer->integer-bytes 65535 2 #f #f)
+(test #"\377\1" integer->integer-bytes 511 2 #t #f)
+(test #"\1\377" integer->integer-bytes -255 2 #t #f)
+(test #"\1\2" integer->integer-bytes 258 2 #f #t)
+
+(test #"\0\0\0\0" integer->integer-bytes 0 4 #t)
+(test #"\377\377\377\377" integer->integer-bytes -1 4 #t)
+(test #"\377\377\377\377" integer->integer-bytes 4294967295 4 #f)
+;;
+(test #"\0\0\0\0" integer->integer-bytes 0 4 #t #t)
+(test #"\377\377\377\377" integer->integer-bytes -1 4 #t #t)
+(test #"\377\377\377\377" integer->integer-bytes 4294967295 4 #f #t)
+(test #"\377\0\0\0" integer->integer-bytes -16777216 4 #t #t)
+(test #"\0\0\0\377" integer->integer-bytes 255 4 #t #t)
+;;
+(test #"\0\0\0\0" integer->integer-bytes 0 4 #t #f)
+(test #"\377\377\377\377" integer->integer-bytes -1 4 #t #f)
+(test #"\377\377\377\377" integer->integer-bytes 4294967295 4 #f #f)
+(test #"\377\0\0\1" integer->integer-bytes 16777471 4 #t #f)
+(test #"\0\0\0\377" integer->integer-bytes -16777216 4 #t #f)
+(test #"\1\0\0\377" integer->integer-bytes -16777215 4 #t #f)
+
+(test #"matt" integer->integer-bytes 1835103348 4 #t #t)
+(test #"matt" integer->integer-bytes 1953784173 4 #t #f)
+
+(test #"\0\0\0\0\0\0\0\0" integer->integer-bytes 0 8 #t #t)
+(test #"\377\377\377\377\377\377\377\377" integer->integer-bytes -1 8 #t #f)
+(test #"\377\377\377\377\377\377\377\377" integer->integer-bytes 18446744073709551615 8 #f #f)
+(test #"\377\377\377\377\0\0\0\0" integer->integer-bytes 4294967295 8 #t #f)
+(test #"\0\0\0\0\377\377\377\377" integer->integer-bytes -4294967296 8 #t #f)
+(test #"\377\377\377\377\1\0\0\0" integer->integer-bytes 8589934591 8 #t #f)
+(test #"\1\0\0\0\377\377\377\377" integer->integer-bytes -4294967295 8 #t #f)
+;;
+(test #"\0\0\0\0\0\0\0\0" integer->integer-bytes 0 8 #t #f)
+(test #"\377\377\377\377\377\377\377\377" integer->integer-bytes -1 8 #t #f)
+(test #"\377\377\377\377\377\377\377\377" integer->integer-bytes 18446744073709551615 8 #f #f)
+(test #"\377\377\377\377\0\0\0\0" integer->integer-bytes -4294967296 8 #t #t)
+(test #"\0\0\0\0\377\377\377\377" integer->integer-bytes 4294967295 8 #t #t)
+(test #"\377\377\377\377\0\0\0\1" integer->integer-bytes -4294967295 8 #t #t)
+(test #"\0\0\0\1\377\377\377\377" integer->integer-bytes 8589934591 8 #t #t)
+
+(arity-test integer->integer-bytes 3 5)
+(err/rt-test (integer->integer-bytes 'ack 2 #t))
+(err/rt-test (integer->integer-bytes 10 'ack #t))
+(err/rt-test (integer->integer-bytes 10 20 #t))
+(err/rt-test (integer->integer-bytes 10 2 #t #t 'ack))
+(err/rt-test (integer->integer-bytes 10 2 #t #t #"ack")) ; <-- immutable string
+(err/rt-test (integer->integer-bytes 100000 2 #t) exn:application:mismatch?)
+(err/rt-test (integer->integer-bytes 65536 2 #f) exn:application:mismatch?)
+(err/rt-test (integer->integer-bytes 32768 2 #t) exn:application:mismatch?)
+(err/rt-test (integer->integer-bytes -32769 2 #t) exn:application:mismatch?)
+(err/rt-test (integer->integer-bytes (expt 2 32) 4 #f) exn:application:mismatch?)
+(err/rt-test (integer->integer-bytes (expt 2 31) 4 #t) exn:application:mismatch?)
+(err/rt-test (integer->integer-bytes (sub1 (- (expt 2 31))) 4 #t) exn:application:mismatch?)
+(err/rt-test (integer->integer-bytes (expt 2 64) 8 #f) exn:application:mismatch?)
+(err/rt-test (integer->integer-bytes (expt 2 63) 4 #t) exn:application:mismatch?)
+(err/rt-test (integer->integer-bytes (sub1 (- (expt 2 63))) 8 #t) exn:application:mismatch?)
+(err/rt-test (integer->integer-bytes 100 2 #t #t (make-bytes 3)) exn:application:mismatch?)
+(err/rt-test (integer->integer-bytes 100 4 #t #t (make-bytes 3)) exn:application:mismatch?)
+
+(map (lambda (v)
+       (let-values ([(n size signed?) (apply values v)])
+	 (test n integer-bytes->integer (integer->integer-bytes n size signed? #f) signed? #f)
+	 (test n integer-bytes->integer (integer->integer-bytes n size signed? #t) signed? #t)))
+     (list
+      (list 10 2 #t)
+
+      (list (sub1 (expt 2 16)) 2 #f)
+      (list (sub1 (expt 2 15)) 2 #t)
+      (list (- (expt 2 15)) 2 #t)
+
+      (list (sub1 (expt 2 32)) 4 #f)
+      (list (sub1 (expt 2 31)) 4 #t)
+      (list (- (expt 2 31)) 4 #t)
+
+      (list (sub1 (expt 2 64)) 8 #f)
+      (list (sub1 (expt 2 63)) 8 #t)
+      (list (- (expt 2 63)) 8 #t)))
+
+(let ([s (make-bytes 4)]
+      [n (random 10000)])
+  (test s integer->integer-bytes n 4 #f #f s)
+  (test s integer->integer-bytes n 4 #f #f))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Used for comparison after loss of precision in 4-byte conversion
+(define (close? a b)
+  (or (equal? a b)
+      (if (negative? a)
+	  (>= (* b 0.999) a (* b 1.001))
+	  (<= (* b 0.999) a (* b 1.001)))
+      (and (= b +inf.0)
+	   (> a 1e38))
+      (and (= b -inf.0)
+	   (< a -1e38))))
+
+(map (lambda (n)
+       (test #t close? n (floating-point-bytes->real (real->floating-point-bytes n 4 #t) #t))
+       (test #t close? n (floating-point-bytes->real (real->floating-point-bytes n 4 #f) #f))
+       (test n floating-point-bytes->real (real->floating-point-bytes n 8 #t) #t)
+       (test n floating-point-bytes->real (real->floating-point-bytes n 8 #f) #f))
+     (append
+      (list 0.0
+	    -0.0
+	    +inf.0
+	    -inf.0
+	    +nan.0
+	    1.0
+	    0.1
+	    1e10)
+      (let loop ([n 50])
+	(if (zero? n)
+	    null
+	    (cons (* (if (= 1 (random 2)) 1 -1)
+		     (sqrt (/ (random 3000) 3000.0))
+		     (expt 2.0 (random 300)))
+		  (loop (sub1 n)))))))
+
+(define (there-and-back n)
+  (floating-point-bytes->real (real->floating-point-bytes n 8)))
+
+(test 1.0 there-and-back 1.0+0.0i)
+(test 100.0 there-and-back 100.0+0.0i)
+(test 101.0 there-and-back 101)
+(test 1e30 there-and-back 1000000000000000000000000000000)
+(test 0.5 there-and-back 1/2)
+
+(let ([s (make-bytes 8)]
+      [n (expt (random 100) (- (random 100)))])
+  (test s real->floating-point-bytes n 8 #f s)
+  (test s real->floating-point-bytes n 8 #f))
+
+(err/rt-test (real->floating-point-bytes 1 -4))
+(err/rt-test (real->floating-point-bytes 1 7))
+(err/rt-test (real->floating-point-bytes 1 7000000000000000000000000))
+(err/rt-test (real->floating-point-bytes 1+2i 8))
+(err/rt-test (real->floating-point-bytes 1.0+2.0i 8))
+(err/rt-test (real->floating-point-bytes 1.0 8 #f (make-bytes 7)) exn:application:mismatch?)
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(report-errs)
diff --git a/collects/tests/mzscheme/numstrs.ss b/collects/tests/mzscheme/numstrs.ss
new file mode 100644
index 0000000000..94b2235446
--- /dev/null
+++ b/collects/tests/mzscheme/numstrs.ss
@@ -0,0 +1,211 @@
+
+;; #f means a symbol
+;; X means fails (syntax forces it to be a number)
+;; DBZ means fails because divide-by-zero
+;; NOE means fails because no such exact
+
+(define number-table
+  `((,(+ 1/2 +i) "1/2+i")
+    (100 "100")
+    (100 "#d100")
+    (0.1 ".1")
+    (0.1 "#d.1")
+    (1/20000 "#e1/2e-4")
+    (10.0 "1e1")
+    (10.0 "1E1")
+    (10.0 "1s1")
+    (10.0 "1S1")
+    (10.0 "1f1")
+    (10.0 "1F1")
+    (10.0 "1l1")
+    (10.0 "1L1")
+    (10.0 "1d1")
+    (10.0 "1D1")
+    (0.0 "0e13")
+    (0.0 "#i0")
+    (-0.0 "#i-0")
+    (+inf.0 ".3e2666666666")
+    (+inf.0 "+INF.0")
+    (+nan.0 "+NaN.0")
+    (+inf.0 "1e500") ; Check simple overflows
+    (-inf.0 "-1e500")
+    (0.0 "1e-500")
+    (-0.0 "-1e-500")
+    (+inf.0 "1#e500")
+    (-inf.0 "-1#e500")
+    (0.0 "1#e-500")
+    (-0.0 "-1#e-500")
+    (+inf.0 "1e10000000000000000000000000000000") ; Check avoidance of extreme computations
+    (-inf.0 "-1e10000000000000000000000000000000")
+    (+inf.0 "1#e10000000000000000000000000000000")
+    (-inf.0 "-1#e10000000000000000000000000000000")
+    (+0.0 "1e-10000000000000000000000000000000")
+    (-0.0 "-1e-10000000000000000000000000000000")
+    (+0.0 "1#e-10000000000000000000000000000000")
+    (-0.0 "-1#e-10000000000000000000000000000000")
+    (10.0 "1#")
+    (10.0 "1#e0")
+    (10.0 "1####e-3")
+    (10.0 "1#.e0")
+    (10.0 "10.#e0")
+    (10.0 "10.e0")
+    (10.0 "1#.e0")
+    (10.0 "10.0#e0")
+    (10.0 "1#.##e0")
+    (10 "#e1#")
+    (10 "#e1#e0")
+    (10 "#e1#.e0")
+    (5e-5 "1/2e-4")
+    (5e-5 "#i1/2e-4")
+    (0.5 "#i1/2")
+    (1/2 "#e1/2")
+    (0.5 "#i0.5")
+    (1/2 "#e0.5")
+    (1/20 "#e0.5e-1")
+    (1/20 "#e0.005e1")
+    (1.0+0.5i "1+0.5i")
+    (1/2 "1/2@0")
+    (-1/2 "-1/2@0")
+    (1/2 "1/2@-0")
+    (0 "#o#e0")
+    (8 "#o#e10")
+    (0 "#b#e0")
+    (0.0 "#b#i0")
+    (4.0 "#b1e10")
+    (4 "#b#e1e10")
+    (1/10+1/5i "#e0.1+0.2i")
+    (0.0+80.0i "#i+8#i")
+    (521976 "#x7f6f8")
+    (1+8i "#b#e1+1#e10i")
+    (1.125 "#x1.2")
+    (1.1640625 "#x1.2a")
+    (1.1640625 "#x1.2a####")
+    (10.0 "#xa.")
+    (10.25 "#xa.4")
+    (160.0 "#xa#.")
+    (416.0 "#x1a#.")
+    (2816.0 "#xb##.##")
+    (4e62 "#i4000000000000000000000000000000000000000000000000000000000000e2")
+    (-0.0 "#b-0.0")
+    (X "#b1000000000020e1")
+    (#f "1.0/3")
+    (#f "1/3.0")
+    (#i10/3 "1#/3")
+    (#i1/300 "1/3##")
+    (#f "1#/#3")
+    (#i10/3 "#d1#/3")
+    (X "#d1#/#3")
+    (+inf.0 "1/0#")
+    (-inf.0 "-1/0#")
+    (NOE "#e+inf.0")
+    (NOE "#e-inf.0")
+    (NOE "#e+nan.0")
+    (NOE "#e1/0#")
+    (500.0 "1/2#e4")
+    (5000.0 "1#/2#e4")
+    (500000000.0 "1/2#e10")
+    (500000000 "#e1/2#e10")
+    (1.6140901064495858e+019-50176.0i "#e#x+e#s+e@-e#l-e")
+
+    (#f "d")
+    (D "D")
+    (#f "i")
+    (I "I")
+    (#f "3i")
+    (3I "3I")
+    (#f "33i")
+    (33I "33I")
+    (#f "3.3i")
+    (3.3I "3.3I")
+    (#f "e")
+    (#f "e1")
+    (#f "e1")
+    (#f "-")
+    (#f "+")
+    (X "#e-")
+    (X "#e+")
+    (X "#i-")
+    (X "#i+")
+    (#f "+.")
+    (X "#e+.")
+    (#f "/")
+    (#f "+1+1")
+    (#f "+1/+1")
+    (#f "1//2")
+    (#f "mod//")
+    (#f "-1.0/2")
+    (#f "/2")
+    (#f "2..")
+    (#f ".2.")
+    (X "#e2..")
+    (X "#e.2.")
+    (#f "1#.0e4")
+    (#f "1#0e4")
+    (#f "1#0.e4")
+    (#f "1##.##0e4")
+    (#f "2i")
+    (#f "/2i")
+    (#f "2@2i")
+    (#f "2@@2")
+    (#f "-2@-+2")
+    (#f "1/1-e4")
+    (#f "1.-2")
+    (#f "--1")
+    (#f "-+1")
+    (#f "-1+3-4")
+    (#f "1\0002")
+    (X "#xg")
+    (X "#x")
+    (X "#xa#a")
+    (X "#i#j0")
+    (X "#x12.a#b")
+    (X "#e1.-2")
+    (X "#b#b0")
+    (X "#b#o0")
+    (X "#i#i0")
+    (X "#e#e0")
+    (X "#i8#i")
+    (X "#i4@#i5")
+    (X "#i4+#d6i")
+    (X "#i4+#d6")
+    (#f "4ef5")
+    (X "#e4ef5")
+    (X "#d1e")
+    (X "#b1e")
+    (X "#o1e")
+    (DBZ "1/0")
+    (DBZ "5+1/0i")
+    (DBZ "1/0+5i")
+    (DBZ "5@1/0")
+    (DBZ "1/0@5")
+    (DBZ "1/0e2")
+    (#f "1/0+hi")
+    (#f "x+1/0i")
+    (+nan.0+1i "+nan.0+1i")
+    (1+nan.0i "1+nan.0i")
+    (#f "1++nan.0i")
+    (0.5+nan.0i "1/2+nan.0i")
+    (1+inf.0i "1+inf.0i")
+    (1-inf.0i "1-inf.0i")
+    (-inf.0-nan.0i "-inf.0-nan.0i")
+    (#f "1++inf.0i")
+    (+nan.0@1 "+nan.0@1")
+    (+inf.0@1 "+inf.0@1")
+    (#f "+inf.0@1@1")
+    (1@+inf.0 "1@+inf.0")
+    (1@+inf.0 "1/1@+inf.0")
+    (+inf.0@1 "+inf.0@1/1")
+    (1.0+0.0i "1@0000.0")
+    (1.0 "0001.0@0")
+    (#f "+inf.0@3@0")
+    (#f "+inf.0@3+4i")
+    (#f "+ina.0")
+    (#f "1@3+4i")
+    (#f "@2")
+    (#f "+a@2")
+    (DBZ "1/0+inf.0i")
+    (DBZ "+inf.0+1/0i")
+    (DBZ "1/0@+inf.0")
+    (DBZ "+inf.0@1/0")
+    (#f "1e1/0")
+    (#f "011111122222222223333333333444444x")))
diff --git a/collects/tests/mzscheme/object-old.ss b/collects/tests/mzscheme/object-old.ss
new file mode 100644
index 0000000000..49ae150e71
--- /dev/null
+++ b/collects/tests/mzscheme/object-old.ss
@@ -0,0 +1,657 @@
+
+; Test MzScheme's object system
+
+(load-relative "loadtest.ss")
+
+(require (lib "class.ss"))
+
+(SECTION 'OBJECT)
+
+(define (stx-test e)
+  (syntax-test (datum->syntax-object #f e #f)))
+(define (err-test e exn)
+  (error-test (datum->syntax-object #f e #f) exn))
+
+(define (test-class* cl* renames)
+  (stx-test  `(,cl*))
+  (stx-test  `(,cl* ,@renames . x))
+  (stx-test  `(,cl* ,@renames 0))
+  (stx-test  `(,cl* ,@renames object% . x))
+  (stx-test  `(,cl* ,@renames object% 0))
+  (stx-test  `(,cl* ,@renames object% x))
+  (stx-test  `(,cl* ,@renames object% ()))
+  (stx-test  `(,cl* ,@renames object% () (0) x))
+  (stx-test  `(,cl* ,@renames object% () 0))
+  (stx-test  `(,cl* ,@renames object% () . x))
+  (stx-test  `(,cl* ,@renames object% () () . x))
+  (stx-test  `(,cl* ,@renames object% () () x))
+  (stx-test  `(,cl* ,@renames object% () () public))
+  (stx-test  `(,cl* ,@renames object% () () (x)))
+  (stx-test  `(,cl* ,@renames object% () (x) ()))
+
+  (let ()
+    (define (try-dotted cl)
+      (stx-test  `(,cl* ,@renames object% () () (,cl . x))))
+    
+    (map try-dotted '(public override private inherit rename
+			     inherit-from rename-from
+			     sequence)))
+  
+  (let ()
+    (define (try-defn-kind cl)
+      (stx-test  `(,cl* ,@renames object% () () (,cl 8)))
+      (stx-test  `(,cl* ,@renames object% () () (,cl [8 9])))
+      (stx-test  `(,cl* ,@renames object% () () (,cl [(x) 9])))
+      (stx-test  `(,cl* ,@renames object% () () (,cl [(x y x) 9])))
+      (stx-test  `(,cl* ,@renames object% () () (,cl [x . 1])))
+      (stx-test  `(,cl* ,@renames object% () () (,cl [x 1 . 3])))
+      (stx-test  `(,cl* ,@renames object% () () (,cl [x 1 3]))))
+    
+    (try-defn-kind 'public)
+    (try-defn-kind 'override)
+    (try-defn-kind 'private))
+
+  (let ()
+    (define (try-defn-rename-kind cl)
+      (stx-test  `(,cl* ,@renames object% () () (,cl [((x) y) 9])))
+      (stx-test  `(,cl* ,@renames object% () () (,cl [(x (y)) 9])))
+      (stx-test  `(,cl* ,@renames object% () () (,cl [(x . y) 9])))
+      (stx-test  `(,cl* ,@renames object% () () (,cl [(x 1) 9])))
+      (stx-test  `(,cl* ,@renames object% () () (,cl [(1 x) 9]))))
+    (try-defn-rename-kind 'public)
+    (try-defn-rename-kind 'override))
+
+  (let ()
+    (define (try-ref-kind cl)
+      (stx-test  `(,cl* ,@renames object% () () (,cl 8)))
+      (stx-test  `(,cl* ,@renames object% () () (,cl x 8)))
+      (stx-test  `(,cl* ,@renames object% () () (,cl (x . y))))
+      (stx-test  `(,cl* ,@renames object% () () (,cl (x y z)))))
+    
+    (map try-ref-kind '(inherit rename share)))
+  (err-test `(,cl* ,@renames object% () () (inherit x)) exn:object?)
+  (err-test `(,cl* ,@renames object% () () (inherit (x y))) exn:object?)
+  (err-test `(,cl* ,@renames object% () () (override [x void])) exn:object?)
+  (err-test `(,cl* ,@renames object% () () (override [(x y) void])) exn:object?)
+  (stx-test  `(,cl* ,@renames object% () () (inherit (x y z))))
+  (stx-test  `(,cl* ,@renames object% () () (inherit (x 5))))
+  (stx-test  `(,cl* ,@renames object% () () (inherit (x))))
+  (stx-test  `(,cl* ,@renames object% () () (rename x)))
+  (stx-test  `(,cl* ,@renames object% () () (rename (x))))
+  (stx-test  `(,cl* ,@renames object% () () (rename ((x) y))))
+  (stx-test  `(,cl* ,@renames object% () () (rename ((x y) y))))
+  (stx-test  `(,cl* ,@renames object% () () (rename ((1) y))))
+
+  (stx-test  `(,cl* ,@renames object% () () (inherit x) (sequence (set! x 5))))
+  (stx-test  `(,cl* ,@renames object% () () (rename [x y]) (sequence (set! x 5))))
+
+  (stx-test  `(,cl* ,@renames object% () () (sequence 1 . 2)))
+  
+  (stx-test  `(,cl* ,@renames object% () () (public [x 7] [x 9])))
+  (stx-test  `(,cl* ,@renames object% () (x) (public [x 7])))
+  (stx-test  `(,cl* ,@renames object% () (x) (public [(x w) 7])))
+  (stx-test  `(,cl* ,@renames object% () () (public [(x y) 7] [(z y) 9])))
+  (stx-test  `(,cl* ,@renames object% () () (public [(x y) 7] [(x z) 9])))
+
+  (stx-test  `(,cl* ,@renames object% a ()))
+  (stx-test  `(,cl* ,@renames object% (1 . a) ())))
+
+(test-class* 'class* ())
+(test-class* 'class*/names '((this super)))
+
+(stx-test #'(class*/names 8 object% () () ()))
+(stx-test #'(class*/names () object% () ()))
+(stx-test #'(class*/names (8) object% () ()))
+(stx-test #'(class*/names (this . 8) object% () ()))
+(stx-test #'(class*/names (this 8) object% () ()))
+(stx-test #'(class*/names (this super-init . 8) object% () ()))
+(stx-test #'(class*/names (this super-init 8) object% () ()))
+
+(test #t class? (class* object% () ()))
+(test #t class? (class* object% () ()))
+(test #t class? (class* object% () x))
+(test #t class? (class* object% () () (public)))
+(test #t class? (class* object% () () (public sequence)))
+(test #t class? (class* object% () (x) (public [(y x) 9])))
+(test #t class? (class*/names (this super-init) object% () () (public)))
+
+(define c (class object% () (public x)))
+(err/rt-test (class c () (public x)) exn:object?)
+(err/rt-test (class c () (public ([y x] 5))) exn:object?)
+(err/rt-test (class c () (override ([x y] 5))) exn:object?)
+
+(stx-test #'(interface))
+(stx-test #'(interface . x))
+(stx-test #'(interface 8))
+(stx-test #'(interface () 8))
+(stx-test #'(interface () x . y))
+(stx-test #'(interface () x 8))
+(stx-test #'(interface () x x))
+(err/rt-test (interface (8) x) exn:object?)
+
+(err/rt-test (interface ((class->interface (class object% ()))
+			 (class->interface (class object% ()))))
+	    exn:object?)
+
+(err/rt-test (interface ((interface () x)) x) exn:object?)
+(err/rt-test (interface ((interface ((interface () x)) y)) x) exn:object?)
+(test #t interface? (let ([i (interface () x)]
+			  [j (interface () x)])
+		      (interface (i j) y)))
+(err/rt-test (let ([i (interface () x)]
+		   [j (interface () x)])
+	       (interface (i j) x))
+	    exn:object?)
+(err/rt-test (interface ((class->interface (class object% () (public w)))) w)
+	    exn:object?)
+
+(test #t interface? (interface ()))
+(test #t interface? (interface () x))
+(test #f interface? (class* object% () ()))
+
+(define i0.1 (interface () x y))
+(define i0.2 (interface () y c d))
+(define i1 (interface (i0.1 i0.2) e))
+(define ix (interface () x y))
+
+(test #t interface-extension? i1 i0.1)
+(test #t interface-extension? i1 i0.2)
+(test #f interface-extension? i0.1 i1)
+(test #f interface-extension? i0.2 i1)
+(test #f interface-extension? i0.2 i0.1)
+(test #f interface-extension? i0.1 i0.2)
+
+(err/rt-test (let [(bad (class* object% (i0.1) ()))] bad) exn:object?)
+(test #t class? (class* object% (i0.1) () (public x y)))
+(err/rt-test (let ([cl (class* object% (i0.1 i0.2) () (public x y c))]) cl) exn:object?)
+(err/rt-test (class* object% (i1) () (public x y c)) exn:object?)
+(test #t class? (class* object% (i0.1 i0.1) () (public x y c d)))
+(err/rt-test (class* object% (i1) () (public x y c d)) exn:object?)
+(test #t class? (class* object% (i1) () (public x y c d e)))
+
+; No initialization:
+(define no-init-c% (class* object% () ()))
+(err/rt-test (make-object no-init-c%) exn:object?)
+
+(define c1 
+  (let ((v 10))
+    (class* object% (i1) (in [in-2 'banana] . in-rest)
+	   (public (x 1) (y 2))
+	   (private (a in) (b3 3))
+	   (public (b1 2) (b2 2) (e 0))
+	   (public (c 3) (d 7)
+		   (f-1-a (lambda () a))
+		   (f-1-b1 (lambda () b1))
+		   (f-1-b2 (lambda () b2))
+		   (f-1-c (lambda () c))
+		   (f-1-v (lambda () v))
+		   (f-1-x (lambda () x))
+		   (f-1-top-a (lambda () (ivar this a)))
+		   (f-1-other-e (lambda (o) (ivar o e)))
+		   (f-1-set-b2 (lambda (v) (set! b2 v) b2))
+		   (f-1-in-2 (lambda () in-2))
+		   (f-1-in-rest (lambda () in-rest)))
+	   (sequence
+	     (set! e in)
+	     (super-init)))))
+  
+(test #t implementation? c1 i0.1)
+(test #t implementation? c1 i0.2)
+(test #t implementation? c1 (class->interface c1))
+(test #t implementation? c1 i1)
+(test #f implementation? c1 ix)
+
+(test #t implementation? object% (class->interface object%))
+(test #t implementation? c1 (class->interface c1))
+(test #t implementation? (class c1 ()) (class->interface c1))
+(let ([i (interface ((class->interface c1)))])
+  (test #f implementation? c1 i)
+  (test #t implementation? (class* c1 (i) ()) i))
+
+(define o1 (make-object c1 0 'apple "first" "last"))
+
+(define c2 
+  (let ((v 20))
+    (class c1 ()
+	   (inherit b2 (sup-set-b2 f-1-set-b2))
+	   (rename (also-e e)
+		   (also-b2 b2))
+	   (override (b1 5) (c 6))
+	   (public (a 4)
+		   (f-2-a (lambda () a))
+		   (f-2-b1 (lambda () b1))
+		   (f-2-b2 (lambda () b2))
+		   (f-2-also-b2 (lambda () also-b2))
+		   (f-2-c (lambda () c))
+		   ((i-f-2-v f-2-v) (lambda () v))
+		   (f-2-v-copy (lambda () (i-f-2-v)))
+		   (f-2-set-b2 (lambda (v) (sup-set-b2 v))))
+	   (private (y 3))
+	   (sequence
+	     (super-init 1)))))
+
+(test #t implementation? c2 i0.1)
+(test #t implementation? c2 i0.2)
+(test #t implementation? c2 i1)
+(test #f implementation? c2 ix)
+(test #t implementation? c2 (class->interface c2))
+(test #t implementation? c2 (class->interface c1))
+(test #f implementation? c1 (class->interface c2))
+
+(test #t interface-extension? (class->interface c2) (class->interface object%))
+(test #t interface-extension? (class->interface c2) (class->interface c1))
+(test #t interface-extension? (class->interface c2) (class->interface c2))
+(test #f interface-extension? (class->interface c1) (class->interface c2))
+(test #t interface-extension? (class->interface c2) i0.1)
+(test #f interface-extension? i0.1 (class->interface c2))
+
+(define o2 (make-object c2))
+
+(define c2.1
+  (class*/names (this c2-init) c2 () ()
+	  (sequence
+	    (c2-init))))
+
+(define o2.1 (make-object c2.1))
+
+(test #t interface? (interface ((class->interface c2)
+				(class->interface c2.1))))
+
+(define c3
+  (class* object% () ()
+	  (public (x 6) (z 7) (b2 8)
+		  (f-3-b2 (lambda () b2)))
+	  (sequence (super-init))))
+
+(define o3 (make-object c3))
+
+(define c6
+  (class object% (x-x)
+    (public
+     [(i-a x-a) (lambda () 'x-a)]
+     [(x-a i-a) (lambda () 'i-a)]
+     [(i-x x-x) (lambda () 'x-x)]
+     [x-a-copy (lambda () (i-a))]
+     [i-a-copy (lambda () (x-a))])
+    (sequence (super-init))))
+
+(define o6 (make-object c6 'bad))
+
+(define c7
+  (class*/names (self super-init) object% () ()
+    (public
+     [get-self (lambda () self)])
+    (sequence (super-init))))
+
+(define o7 (make-object c7))
+
+(define display-test 
+  (lambda (p v)
+    (printf "Should be ~s: ~s ~a~n"
+	    p v (if (equal? p v)
+		    ""
+		    "ERROR"))))
+
+(define ivar? exn:object?)
+
+(test #t is-a? o1 c1)
+(test #t is-a? o1 i1)
+(test #t is-a? o1 (class->interface c1))
+(test #f is-a? o1 (interface ((class->interface c1))))
+(test #t is-a? o2 c1)
+(test #t is-a? o2 i1)
+(test #f is-a? o1 c2)
+(test #f is-a? o1 (class->interface c2))
+(test #t is-a? o2 c2)
+(test #t is-a? o2.1 c1)
+(test #f is-a? o1 c3)
+(test #f is-a? o2 c3)
+(test #f is-a? o1 ix)
+(test #f is-a? o2 ix)
+(test #f is-a? o3 i1)
+(test #f is-a? i1 i1)
+(test #t subclass? c2 c1)
+(test #t subclass? c2.1 c1)
+(test #f subclass? c1 c2)
+(test #f subclass? c1 c3)
+(test #f subclass? i1 c3)
+(test #t ivar-in-interface? 'f-1-a (class->interface c1))
+(test #t ivar-in-interface? 'f-1-a (class->interface c2))
+(test #f ivar-in-interface? 'f-2-a (class->interface c1))
+(test #t ivar-in-interface? 'f-2-a (class->interface c2))
+(test #t ivar-in-interface? 'x i0.1)
+(test #t ivar-in-interface? 'x i1)
+(test #f ivar-in-interface? 'x i0.2)
+(test #f ivar-in-interface? 'c i0.1)
+(test #t ivar-in-interface? 'c i0.2)
+(test #t ivar-in-interface? 'c i1)
+(test #f ivar-in-interface? 'zzz i1)
+(test #t ivar-in-interface? 'f-1-a (class->interface c2))
+(test #t ivar-in-interface? 'f-1-a (interface ((class->interface c2)) one-more-method))
+(test #f ivar-in-interface? 'f-2-a (class->interface c1))
+
+(err/rt-test (is-a? o1 o1))
+(err/rt-test (subclass? o1 o1))
+(err/rt-test (subclass? o1 i1))
+(err/rt-test (implementation? o1 o1))
+(err/rt-test (implementation? o1 c1))
+(err/rt-test (ivar-in-interface? 0 i1))
+(err/rt-test (ivar-in-interface? 'a o1))
+(err/rt-test (ivar-in-interface? 'a c1))
+(err/rt-test (ivar-in-interface? 'a o1))
+
+(define (test/list l1 l2)
+  (test #t 'ivar-list (and (= (length l1)
+			      (length l2))
+			   (andmap (lambda (i) (member i l2))
+				   l1)
+			   #t)))
+
+(test/list '(hi there)
+	   (interface->ivar-names 
+	    (interface () hi there)))
+(test/list '(hi too mee there)
+	   (interface->ivar-names 
+	    (interface ((interface () hi there)) mee too)))
+(test/list '(hi too mee z y there) 
+	   (interface->ivar-names 
+	    (interface ((interface ((class->interface 
+				     (class object% () 
+				       (public y z)
+				       (private nono)))) 
+			  hi there)) 
+	      mee too)))
+
+
+(test 0 class-initialization-arity object%)
+(test #t arity-at-least? (class-initialization-arity c1))
+(test 1 arity-at-least-value (class-initialization-arity c1))
+(test 0 class-initialization-arity c2)
+
+(test '(1 2) class-initialization-arity (class object% (a [b 2])))
+
+(arity-test object? 1 1)
+(arity-test class? 1 1)
+(arity-test interface? 1 1)
+(arity-test is-a? 2 2)
+(arity-test subclass? 2 2)
+(arity-test interface-extension? 2 2)
+(arity-test ivar-in-interface? 2 2)
+(arity-test class-initialization-arity 1 1)
+
+(arity-test ivar/proc 2 2)
+(arity-test make-generic/proc 2 2)
+
+(err/rt-test (ivar o1 a) ivar?)
+(test 4 ivar/proc o2 'a)
+
+(define (ivar-tests -ivar xtra-ok?)
+  (stx-test  `(,-ivar))
+  (stx-test  `(,-ivar 7))
+  (stx-test  `(,-ivar 7 8))
+  (stx-test  `(,-ivar 7 (x)))
+  (stx-test  `(,-ivar 7 8 9))
+  (unless xtra-ok?
+    (stx-test  `(,-ivar 7 x 9))))
+(ivar-tests 'ivar #f)
+(ivar-tests 'send #t)
+(ivar-tests 'make-generic #f)
+
+(test 0 'send (send o1 f-1-a))
+(test 1 'send (send o2 f-1-a))
+(test 4 'send (send o2 f-2-a))
+
+(test 'apple 'send (send o1 f-1-in-2))
+(test 'banana 'send (send o2 f-1-in-2))
+(test '("first" "last") 'send (send o1 f-1-in-rest))
+(test '() 'send (send o2 f-1-in-rest))
+
+(err/rt-test (send o1 f-1-top-a) ivar?)
+(test 4 'send (send o2 f-1-top-a))
+
+(test 5 ivar/proc o2 'b1)
+
+(test 2 'send (send o1 f-1-b1))
+(test 2 'send (send o1 f-1-b2))
+(test 5 'send (send o2 f-1-b1))
+(test 2 'send (send o2 f-1-b2))
+(test 5 'send (send o2 f-2-b1))
+(test 2 'send (send o2 f-2-b2))
+(test 2 'send (send o2 f-2-also-b2))
+
+(test 3 ivar/proc o1 'c)
+(test 6 ivar/proc o2 'c)
+
+(test 3 'send (send o1 f-1-c))
+(test 6 'send (send o2 f-1-c))
+(test 6 'send (send o2 f-2-c))
+
+(test 7 ivar/proc o1 'd)
+(test 7 ivar/proc o2 'd)
+
+(test 10 'send (send o1 f-1-v))
+(test 10 'send (send o2 f-1-v))
+(test 20 'send (send o2 f-2-v))
+(test 20 'send (send o2 f-2-v-copy))
+
+(err/rt-test (ivar o2 i-f-2-v) ivar?)
+
+(test 0 'send (send o1 f-1-other-e o1))
+(test 1 'send (send o1 f-1-other-e o2))
+
+(test 2 ivar/proc o2 'y)
+
+(test 3 'send (send o2 f-2-set-b2 3))
+(test 3 'send (send o2 f-2-also-b2))
+
+(test 'i-a 'send (send o6 i-a))
+(test 'x-a 'send (send o6 x-a))
+(test 'i-a 'send (send o6 i-a-copy))
+(test 'x-a 'send (send o6 x-a-copy))
+(test 'x-x 'send (send o6 x-x))
+
+(test #t eq? o7 (send o7 get-self))
+
+(define g1 (make-generic c1 x))
+(test 1 g1 o1)
+(test 1 g1 o2)
+(arity-test g1 1 1)
+
+(err/rt-test (make-generic c1 www)  exn:object?)
+
+(define g2 (make-generic c2 x))
+(test 1 g2 o2)
+
+(define g0 (make-generic i0.1 x))
+(test 1 g0 o1)
+(test 1 g0 o2)
+(arity-test g0 1 1)
+(test 'hi g0 (make-object (class* object% (i0.1) () 
+				  (public [x 'hi][y 'bye])
+				  (sequence (super-init)))))
+
+(err/rt-test (make-generic i0.1 www) exn:object?)
+
+(err/rt-test (g2 o1) exn:object?)
+(err/rt-test (g0 o3) exn:object?)
+
+(err/rt-test (class* 7 () ()) exn:object?)
+(err/rt-test (class* null () ()) exn:object?)
+(err/rt-test (let ([c (class* 7 () ())]) c) exn:object?)
+(err/rt-test (class* object% (i1 7) ()) exn:object?)
+(err/rt-test (let ([c (class* object% (i1 7) ())]) c) exn:object?)
+(err/rt-test (interface (8) x) exn:object?)
+(err/rt-test (let ([i (interface (8) x)]) i) exn:object?)
+(err/rt-test (interface (i1 8) x) exn:object?)
+(err/rt-test (make-generic c2 not-there) exn:object?)
+
+(err/rt-test (make-object (class* c1 () ())) exn:object?)
+(err/rt-test (make-object (let ([c (class* c1 () ())]) c)) exn:object?)
+
+(err/rt-test (make-object 
+	      (class* c2 () () (sequence (super-init) (super-init)))) 
+	    exn:object?)
+(err/rt-test (make-object 
+	      (let ([c (class* c2 () () (sequence (super-init) (super-init)))]) c))
+	    exn:object?)
+
+(err/rt-test (make-object (class object% (x))) exn:application:arity?)
+(err/rt-test (make-object (let ([c (class object% (x))]) c)) exn:application:arity?)
+	      
+
+(define c100
+  (let loop ([n 99][c (class c1 args (public [z -1]) (sequence (apply super-init args)))])
+    (if (zero? n)
+	c
+	(loop (sub1 n) (class c args 
+			      (override (z n))
+			      (sequence
+				(apply super-init args)))))))
+
+(define o100 (make-object c100 100))
+(test 100 'send (send o100 f-1-a))
+(test 1 'ivar (ivar o100 z))
+
+(test 5 'init (let ([g-x 8]) (make-object (class* object% () ([x (set! g-x 5)]) (sequence (super-init)))) g-x))
+(test 8 'init (let ([g-x 8]) (make-object (class* object% () ([x (set! g-x 5)]) (sequence (super-init))) 0) g-x))
+
+(test (letrec ([x x]) x) 'init (send (make-object 
+				      (class* object% () ([x y] [y x]) 
+					      (public (f (lambda () x)))
+					      (sequence (super-init))))
+				     f))
+
+(define inh-test-expr
+ (lambda (super derive-pre? rename? override? override-pre?)
+   (let* ([order
+	   (lambda (pre? a b)
+	     (if pre?
+		 (list a b)
+		 (list b a)))]
+	  [base-class
+	   `(class ,(if super
+			super
+			'(class object% (n) 
+				(public [name (lambda () n)])
+				(sequence (super-init))))
+		   ()
+		   ,(if (not rename?)
+			'(inherit name)
+			'(rename [super-name name]))
+		   ,@(order
+		      derive-pre?
+		      `(public [w ,(if rename? 'super-name 'name)])
+		      '(sequence (super-init 'tester))))])
+     `(ivar
+       (make-object
+	,(if override?
+	     `(class ,base-class ()
+		     ,@(order
+			override-pre?
+			'(sequence (super-init))
+			'(override [name (lambda () 'o-tester)])))
+	     base-class))
+       w))))
+
+(define (do-override-tests super)
+  (define (eval-test v e)
+    (teval `(test ,v (quote, e)
+		  (let ([v ,e]) 
+		    (if (procedure? v)
+			(v)
+			v)))))
+
+  (eval-test '(letrec ([x x]) x) (inh-test-expr super #t #f  #f #f))
+  (eval-test '(letrec ([x x]) x) (inh-test-expr super #t #f  #t #t))
+  (eval-test '(letrec ([x x]) x) (inh-test-expr super #f #f  #t #t))
+
+  (eval-test '(letrec ([x x]) x) (inh-test-expr super #t #t  #f #f))
+  (eval-test '(letrec ([x x]) x) (inh-test-expr super #t #t  #t #f))
+  (eval-test '(letrec ([x x]) x) (inh-test-expr super #t #t  #t #t))
+  
+  (eval-test ''tester (inh-test-expr super #f #f  #f #f))
+  (eval-test ''o-tester (inh-test-expr super #t #f  #t #f))
+  (eval-test ''o-tester (inh-test-expr super #f #f  #t #f))
+
+  (eval-test ''tester (inh-test-expr super #f #t  #f #f))  
+  (eval-test ''tester (inh-test-expr super #f #t  #t #t))
+  (eval-test ''tester (inh-test-expr super #f #t  #t #f)))
+
+(do-override-tests #f)
+
+'(when (defined? 'primclass%)
+  (err/rt-test (make-object primclass%) exn:application:arity?)
+  (err/rt-test (make-object primsubclass%) exn:application:arity?)
+
+  (let ()
+    (define o (make-object primclass% 'tester))
+    (arity-test (ivar o name) 0 0)
+    (test 'tester (ivar o name))
+    (test "primclass%" (ivar o class-name))
+    
+    (let ()
+      (define o2 (make-object primsubclass% 'tester))
+      (arity-test (ivar o2 name) 0 0)
+      (arity-test (ivar o2 detail) 0 0)
+      (test 'tester (ivar o2 name))
+      (test #f (ivar o2 detail))
+      (test "primsubclass%" (ivar o2 class-name))
+      
+      (do-override-tests 'primclass%)
+      (do-override-tests 'primsubclass%)
+
+      (let ()
+	(define name-g (make-generic primclass% name))
+	(define class-name-g (make-generic primclass% class-name))
+	
+	(define sub-name-g (make-generic primsubclass% name))
+	(define sub-class-name-g (make-generic primsubclass% class-name))
+	(define sub-detail-g (make-generic primsubclass% detail))
+	
+	(test 'tester (name-g o))
+	(test "primclass%" (class-name-g o))
+	
+	(test 'tester (name-g o2))
+	(test "primsubclass%" (class-name-g o2))
+	(test 'tester (sub-name-g o2))
+	(test "primsubclass%" (sub-class-name-g o2))
+	(test #f (sub-detail-g o2))
+
+	(let ()
+	  (define c%
+	    (class primsubclass% ()
+	      (inherit name detail class-name)
+	      (sequence (super-init 'example))
+	      (public
+		[n name]
+		[d detail]
+		[c class-name])))
+
+	  (define o3 (make-object c%))
+	  (test 'example (ivar o3 n))
+	  (test #f (ivar o3 d))
+	  (test "primsubclass%" (ivar o3 c))
+	  (test 'example (ivar o3 name))
+	  (test #f (ivar o3 detail))
+	  (test "primsubclass%" (ivar o3 class-name))
+
+	  (test 'example (name-g o3))
+	  (test "primsubclass%" (class-name-g o3))
+	  (test 'example (sub-name-g o3))
+	  (test "primsubclass%" (sub-class-name-g o3))
+	  (test #f (sub-detail-g o3)))))))
+
+
+; Test for override/rename order
+(define bsc (class object% ()
+		   (public [x (lambda () 10)])
+		   (sequence (super-init))))
+(define orc (class bsc ()
+	      (public [y (lambda () (super-x))])
+	      (override [x (lambda () 20)])
+	      (rename [super-x x])
+	      (sequence (super-init))))
+(test 10 (ivar (make-object orc) y))
+
+(report-errs)
+
diff --git a/collects/tests/mzscheme/object.ss b/collects/tests/mzscheme/object.ss
new file mode 100644
index 0000000000..63b97a67b2
--- /dev/null
+++ b/collects/tests/mzscheme/object.ss
@@ -0,0 +1,1106 @@
+
+; Test MzScheme's new object system
+
+(load-relative "loadtest.ss")
+
+(require (lib "class.ss"))
+
+(SECTION 'OBJECT)
+
+
+;; ------------------------------------------------------------
+;; Test syntax errors
+
+(syntax-test #'class)
+(syntax-test #'(class))
+(syntax-test #'(class . object%))
+(test #t class? (class object%))
+(syntax-test #'(class object% . 10))
+
+(define (test-init/field init)
+  (teval #`(test #t class? (class object% (#,init))))
+  (syntax-test #`(class object% (#,init . x)))
+  (syntax-test #`(class object% (#,init 10)))
+  (syntax-test #`(class object% (#,init (x . 10))))
+  (syntax-test #`(class object% (#,init (x 10 10))))
+  (syntax-test #`(class object% (#,init (x 10 . 10))))
+  (syntax-test #`(class object% (#,init (10 10))))
+  (teval #`(test #t class? (class object% (#,init (x 10)))))
+  (syntax-test #`(class object% (#,init ((x) 10))))
+  (syntax-test #`(class object% (#,init ((x . y) 10))))
+  (syntax-test #`(class object% (#,init ((x y . z) 10))))
+  (syntax-test #`(class object% (#,init ((x y z) 10))))
+  (syntax-test #`(class object% (#,init ((x 10) 10))))
+  (syntax-test #`(class object% (#,init ((10 x) 10))))
+  (teval #`(test #t class? (class object% (#,init ((x y) 10)))))
+  (syntax-test #`(class object% (#,init ((x y) 10) . z)))
+  (syntax-test #`(class object% (#,init ((x y) 10) z)))
+  (syntax-test #`(class object% (#,init ((x y) 10) (z))))
+  (teval #`(test #t class? (class object% (#,init ((x y) 10) (z 5)))))
+  (syntax-test #`(class object% (#,init (x 10) y)))
+  (syntax-test #`(class object% (#,init (x 10)) (#,init y)))
+
+  (syntax-test #`(class object% (#,init x x)))
+  (syntax-test #`(class object% (#,init x) (#,init x)))
+  (syntax-test #`(class object% (#,init x) (#,init (x 10))))
+  (syntax-test #`(class object% (#,init (x 10)) (#,init (x 10))))
+  (syntax-test #`(class object% (#,init ((x y) 10)) (#,init (x 10))))
+  (syntax-test #`(class object% (#,init ((x y) 10)) (#,init ((x z) 10))))
+  (syntax-test #`(class object% (#,init ((x y) 10)) (#,init ((x z) 10))))
+  (syntax-test #`(class object% (#,init ((y x) 10)) (#,init ((z x) 10))))
+  (syntax-test #`(class object% (#,init x) (#,init x)))
+  (syntax-test #`(class object% (#,init x) (#,init (x 10))))
+  (syntax-test #`(class object% (#,init (x 10)) (#,init (x 10))))
+  (syntax-test #`(class object% (#,init ((x y) 10)) (#,init (x 10))))
+  (syntax-test #`(class object% (#,init ((x y) 10)) (#,init ((x z) 10))))
+  (syntax-test #`(class object% (#,init ((x y) 10)) (#,init ((x z) 10))))
+  (syntax-test #`(class object% (#,init ((y x) 10)) (#,init ((z x) 10))))
+
+  (teval #`(test #t class? (class object% (#,init ((x x) 10)))))
+  (teval #`(test #t class? (class object% (#,init ((x x) 10) ((y y) 10)))))
+  (teval #`(test #t class? (class object% (#,init ((x x) 10)) (#,init ((y y) 10)))))
+  (teval #`(test #t class? (class object% (#,init ((x y) 10)) (#,init ((y x) 10)))))
+
+  'ok)
+
+(define (test-init init)
+  (teval #`(test #t class? (class object% (#,init x))))
+  (teval #`(test #t class? (class object% (#,init ((x y))))))
+  (test-init/field init)
+
+  (syntax-test #`(class object% (init-rest) (#,init y)))
+  (syntax-test #`(class object% (#,init x) (init-rest) (#,init y)))
+  (syntax-test #`(class object% (#,init y) (init-rest y)))
+  (teval #`(test #t class? (class object% (#,init [(x y)]) (init-rest y))))
+
+  'ok)
+
+(test-init #'init)
+(test-init #'init-field)
+(test-init/field #'field)
+
+(syntax-test #'(class object% (init-rest 10)))
+(syntax-test #'(class object% (init-rest . x)))
+(syntax-test #'(class object% (init-rest x y)))
+(syntax-test #'(class object% (init-rest) (init-rest x)))
+(syntax-test #'(class object% (init-rest x) (init-rest)))
+
+(syntax-test #'(class object% (init-field (x 10)) (init y)))
+(syntax-test #'(class object% (init (x 10)) (init-field y)))
+(syntax-test #'(class object% (init-rest x) (init y)))
+(syntax-test #'(class object% (init-rest x) (init-field y)))
+
+(define to-override-class%
+  (class object%
+    (public x y)
+    (define (x) 1)
+    (define (y) 2)))
+(define to-augment-class%
+  (class object%
+    (pubment x y)
+    (define (x) 1)
+    (define (y) 2)))
+
+(define (test-method basic? public object% over? aug? super-ok? inner-ok? over-ok? aug-ok?)
+  (when basic?
+    (teval #`(test #t class? (class #,object% (#,public))))
+    
+    (syntax-test #`(class #,object% (#,public . x)))
+    (syntax-test #`(class #,object% (#,public 10)))
+    (syntax-test #`(class #,object% (#,public (x))))
+    (syntax-test #`(class #,object% (#,public (x . y))))
+    (syntax-test #`(class #,object% (#,public (x 10))))
+    (syntax-test #`(class #,object% (#,public (10 x))))
+    (syntax-test #`(class #,object% (#,public x . y)))
+    (syntax-test #`(class #,object% (#,public x 10)))
+    
+    (syntax-test #`(class #,object% (#,public x x)))
+    (syntax-test #`(class #,object% (#,public x) (#,public x)))
+    (syntax-test #`(class #,object% (#,public (x y) (x y))))
+    (syntax-test #`(class #,object% (#,public (x y1) (x y))))
+    (syntax-test #`(class #,object% (#,public (x y) (x2 y)))))
+
+  (unless (module-identifier=? public #'private)
+    (if (and (or (not over?) over-ok?)
+	     (or (not aug?) aug-ok?))
+	(begin
+	  (teval #`(test #t class? (class #,object% (#,public (x x)) (define (x) 1))))
+	  (teval #`(test #t class? (class #,object% (#,public (x y) (y x)) (define (x) 1) (define (y) 2)))))
+	(begin
+	  (teval #`(err/rt-test (class #,object% (#,public (x x)) (define (x) 1)) exn:fail:object?))
+	  (teval #`(err/rt-test (class #,object% (#,public (x y) (y x)) (define (x) 1) (define (y) 2)) exn:fail:object?)))))
+	
+
+  ;; Use of external name for super/inner is always wrong (but
+  ;; maybe because super/inner isn't allowed):
+  (syntax-test #`(class #,object% (#,public [x ex]) (define (x y) (super ex 12))))
+  (syntax-test #`(class #,object% (#,public [x ex]) (define (x y) (inner 5 ex 12))))
+
+  (let ([expr #`(class #,object% 
+		  (#,public x)
+		  (define (x y) (super x 10)))])
+    (if (and super-ok? over-ok?)
+	(begin
+	  (teval #`(test #t class? #,expr))
+	  (teval #`(test #t class? (class #,object% 
+				     (#,public [ex x])
+				     (define (ex y) (super ex 10))))))
+	(if super-ok?
+	    (teval #`(err/rt-test #,expr exn:fail:object?))
+	    (syntax-test expr))))
+  (let ([expr #`(class #,object% 
+		  (#,public x)
+		  (define (x y) (inner 5 x 10)))])
+    (if (and inner-ok? aug? aug-ok?)
+	(begin
+	  (teval #`(test #t class? #,expr))
+	  (teval #`(test #t class? (class #,object% 
+				     (#,public [ex x])
+				     (define (ex y) (inner 5 ex 10))))))
+	(if inner-ok?
+	    (if (or (and aug? (not aug-ok?))
+		    (and over? (not over-ok?)))
+		(teval #`(err/rt-test #,expr exn:fail:object?))
+		(teval #`(test #t class? #,expr)))
+	    (syntax-test expr))))
+
+  'ok)
+
+(test-method #t #'public #'object% #f #f #f #f #f #f)
+(test-method #t #'public-final #'object% #f #f #f #f #f #f)
+(test-method #t #'pubment #'object% #f #f #f #t #f #f)
+(test-method #t #'override #'to-override-class% #t #f #t #f #t #f)
+(test-method #f #'override #'to-augment-class% #t #f #t #f #f #t)
+(test-method #t #'override-final #'to-override-class% #t #f #t #f #t #f)
+(test-method #f #'override-final #'to-augment-class% #t #f #t #f #f #t)
+(test-method #t #'overment #'to-override-class% #t #f #t #t #t #f)
+(test-method #f #'overment #'to-augment-class% #t #f #t #t #f #t)
+(test-method #t #'augment #'to-override-class% #f #t #f #t #t #f)
+(test-method #f #'augment #'to-augment-class% #f #t #f #t #f #t)
+(test-method #t #'augment-final #'to-override-class% #f #t #f #f #t #f)
+(test-method #f #'augment-final #'to-augment-class% #f #t #f #f #f #t)
+(test-method #t #'augride #'to-override-class% #f #t #f #f #t #f)
+(test-method #f #'augride #'to-augment-class% #f #t #f #f #f #t)
+(test-method #t #'private #'object% #f #f #f #f #f #f)
+
+(define (test-rename rename object%)
+  (teval #`(test #t class? (class #,object% (#,rename))))
+  (teval #`(err/rt-test (class #,object% (#,rename [x x])) exn:fail:object?))
+  (teval #`(err/rt-test (class #,object% (#,rename [y x])) exn:fail:object?))
+  (teval #`(err/rt-test (class #,object% (#,rename [y x][z x])) exn:fail:object?))
+  (syntax-test #`(class #,object% (#,rename . x)))
+  (syntax-test #`(class #,object% (#,rename x)))
+  (syntax-test #`(class #,object% (#,rename [x 1])))
+  (syntax-test #`(class #,object% (#,rename [1 x])))
+  (syntax-test #`(class #,object% (#,rename [x 1 2])))
+  (syntax-test #`(class #,object% (#,rename [x y][x y])))
+  
+  10)
+
+(test-rename #'rename-super #'object%)
+(test-rename #'rename-inner #'object%)
+
+(define (class-keyword-test kw)
+  (syntax-test kw)
+  (syntax-test #`(#,kw (x) 10)))
+  
+(class-keyword-test #'public)
+(class-keyword-test #'public-final)
+(class-keyword-test #'private)
+(class-keyword-test #'pubment)
+(class-keyword-test #'override)
+(class-keyword-test #'override-final)
+(class-keyword-test #'overment)
+(class-keyword-test #'augment)
+(class-keyword-test #'augment-final)
+(class-keyword-test #'augride)
+(class-keyword-test #'rename-super)
+(class-keyword-test #'rename-inner)
+(class-keyword-test #'inherit)
+(class-keyword-test #'public*)
+(class-keyword-test #'private*)
+(class-keyword-test #'pubment*)
+(class-keyword-test #'override*)
+(class-keyword-test #'overment*)
+(class-keyword-test #'augment*)
+(class-keyword-test #'augride*)
+(class-keyword-test #'define/public)
+(class-keyword-test #'define/private)
+(class-keyword-test #'define/pubment)
+(class-keyword-test #'define/override)
+(class-keyword-test #'define/overment)
+(class-keyword-test #'define/augment)
+(class-keyword-test #'define/augride)
+(class-keyword-test #'super)
+(class-keyword-test #'inner)
+(class-keyword-test #'this)
+(class-keyword-test #'super-new)
+(class-keyword-test #'super-make-object)
+(class-keyword-test #'super-instantiate)
+(class-keyword-test #'inspect)
+
+;; ------------------------------------------------------------
+;; Test basic functionality
+
+(define eater<%> (interface () eat))
+
+(define-syntax mk-noop
+  (syntax-rules 
+   ()
+   [(_ name)
+    (begin
+      (define (name) (blah))
+      (define (blah)
+	(printf "hi~n")))]))
+
+(define fish%
+  (class* object% (eater<%>)
+    (public get-size grow eat)
+    (public-final noop)
+
+    (mk-noop noop)
+    (private increase-size eat-sized-fish)
+
+    (init-field [size 1])
+
+    ;; Private methods
+    (define (increase-size s)
+      (set! size (+ s size)))
+    (define (eat-sized-fish s)
+      (grow s))
+
+    ;; Public methods
+    (define (get-size) size)
+    (define (grow s)
+      (noop)
+      (set! size (+ s size))
+      size)
+    (define (eat f)
+      (let ([this 5]) ; <- make sure methods still work...
+	(grow (send f get-size))))
+
+    (super-instantiate ())))
+
+(define fish1 (make-object fish% 10))
+(define fish2 (make-object fish% 100))
+
+(test 10 'f1 (send fish1 get-size))
+(test 100 'f2 (send fish2 get-size))
+
+(test 12 'g1 (send fish1 grow 2))
+(test 103 'g2 (send fish2 grow 3))
+
+(test 115 'e (send fish2 eat fish1))
+
+(define fish-size (class-field-accessor fish% size))
+(test 12 fish-size fish1)
+(test 115 fish-size fish2)
+
+(define color-fish%
+  (class fish%
+    (pubment die)
+    (public-final die2)
+    (inherit get-size)
+    (inherit-field size)
+
+    (init-field [color 'red])
+
+    (define (die)
+      (unless (= size (get-size))
+	(error 'bad))
+      (set! color 'black))
+    (define (die2) (die))
+
+    (super-new)))
+
+(define blue-fish (instantiate color-fish% () (color 'blue) (size 10)))
+(define red-fish (instantiate color-fish% () (size 1)))
+
+(define color-fish-color (class-field-accessor color-fish% color))
+
+(test 'red color-fish-color red-fish)
+(test 'blue color-fish-color blue-fish)
+
+(test 1 'fr (send red-fish get-size))
+(test 10 'fb (send blue-fish get-size))
+
+(send red-fish grow 30)
+
+(test 31 'fr (send red-fish get-size))
+
+(test (void) 'fv (send blue-fish die))
+(test 'black color-fish-color blue-fish)
+
+(let ([exn (with-handlers ([exn:fail? (lambda (exn) exn)])
+	     (send red-fish get-size 10))])
+  (test #t exn:fail:contract:arity? exn)
+  ;; (test 1 exn:application-value exn)
+  ;; (test 0 exn:application:arity-expected exn)
+  )
+
+(define picky-fish%
+  (class fish%
+    (override grow)
+    (public set-limit)
+    (rename-super [super-grow grow])
+
+    (define pickiness 1)
+    (define upper-limit 50)
+
+    (define grow
+      ;; Test method-declaration shape with variable:
+      (let ([grow (lambda (s)
+		    (super-grow (min upper-limit (- s pickiness))))])
+	grow))
+    (define set-limit 
+      ;; Test method-declaration shape with body method:
+      (let* ([check-pickiness (lambda (p)
+				(unless (= p pickiness)
+				  (error 'ack)))]
+	     [set-upper (lambda (v p)
+			  (check-pickiness p)
+			  (set! upper-limit v))])
+	(lambda (v)
+	  (set-upper v pickiness))))
+
+    (super-instantiate () (size 12))))
+
+(define picky (make-object picky-fish%))
+
+(test 12 'pf (send picky get-size))
+(test 42 'pfe (send picky eat red-fish))
+(test 42 'pf (send picky get-size))
+
+(test (void) 'pfp (send picky set-limit 20))
+(test 62 'pfe (send picky eat red-fish))
+
+(test #t is-a? picky object%)
+(test #t is-a? picky fish%)
+(test #t is-a? picky picky-fish%)
+(test #f is-a? picky color-fish%)
+
+(test #t is-a? red-fish object%)
+(test #t is-a? red-fish fish%)
+(test #f is-a? red-fish picky-fish%)
+(test #t is-a? red-fish color-fish%)
+
+(test #t is-a? fish1 eater<%>)
+(test #t is-a? picky eater<%>)
+(test #t is-a? red-fish eater<%>)
+
+(test #f is-a? 5 picky-fish%)
+(test #f is-a? 5 eater<%>)
+
+(test #t is-a? picky (class->interface picky-fish%))
+(test #f is-a? red-fish (class->interface picky-fish%))
+
+(err/rt-test (instantiate fish% () (bad-size 10)) exn:fail:object?)
+(err/rt-test (instantiate fish% () (size 10) (size 12)) exn:fail:object?)
+(err/rt-test (instantiate fish% (10) (size 12)) exn:fail:object?)
+(err/rt-test (instantiate picky-fish% () (size 17)) exn:fail:object?)
+
+(err/rt-test (color-fish-color picky))
+(err/rt-test (color-fish-color 6))
+
+;; ----------------------------------------
+;;  Final and inner
+
+;; Can't actually override `final', but it might call `inner'...
+
+;; color-fish%'s die doesn't call inner:
+(test (void) 
+      'no-overment
+      (send (new (class color-fish% (augment die) (define die (lambda () 'x)) (super-new))) die))
+;; Can't override (only augment):
+(err/rt-test (class color-fish% (override die) (define die (lambda () 'x))) exn:fail:object?)
+(err/rt-test (class color-fish% (overment die) (define die (lambda () 'x))) exn:fail:object?)
+
+;; color-fish%'s die2 is final:
+(err/rt-test (class color-fish% (override die2) (define die2 (lambda () 'x))) exn:fail:object?)
+(err/rt-test (class color-fish% (augment die2) (define die2 (lambda () 'x))) exn:fail:object?)
+(err/rt-test (class color-fish% (overment die2) (define die2 (lambda () 'x))) exn:fail:object?)
+(err/rt-test (class color-fish% (augride die2) (define die2 (lambda () 'x))) exn:fail:object?)
+
+;; Can't augment (only override):
+(err/rt-test (class color-fish% (augment eat) (define eat (lambda (f) 'x))) exn:fail:object?)
+(err/rt-test (class color-fish% (augride eat) (define eat (lambda (f) 'x))) exn:fail:object?)
+
+;; Can't use inner without a `final' here or in superclass
+(syntax-test #'(class object% (define/public (f x) x) (rename-inner [inner-f f])))
+(syntax-test #'(class object% (define/public (f x) (inner (void) f x))))
+(err/rt-test (class object% (rename-inner [inner-f f])) exn:fail:object?)
+(err/rt-test (class (class object% (define/public (f x) x)) (rename-inner [inner-f f])) exn:fail:object?)
+
+;; Can't use `rename-super' for a final method:
+(err/rt-test (class (class object% (define/pubment (f x) x)) 
+	       (rename-super [super-f f])) exn:fail:object?)
+
+(define bfoo-jgoo%
+  (class object%
+    (define/pubment (foo x)
+      (inner (list 1 x) foo (list 2 x)))
+    (define/public (goo x)
+      (list 3 x))
+    (define/public (zoo x)
+      (inner (list 10 x) foo (list 20 x)))
+    (super-new)))
+
+(define bjfoo-jbgoo% 
+  (class bfoo-jgoo%
+    (define/augride (foo x) (list 4 x))
+    (define/overment (goo x) 
+      (let ([y (super goo x)])
+	(inner (list 5 y) goo (list 6 y))))
+    (rename-super [super-zoo zoo])
+    (define/public (hoo y) (super-zoo (list 7 y)))
+    (super-new)))
+
+(define bjjfoo-jbjgoo% 
+  (class bjfoo-jbgoo% 
+    (define/override (foo x)
+      (list 8 x))
+    (define/augride (goo x) 
+      (list 9 x))
+    (super-new)))
+
+(define bjjbfoo-jbjjgoo% 
+  (class bjjfoo-jbjgoo% 
+    (define/overment (foo x) 
+      (let ([z (super foo (list 10 x))])
+	(inner (list 11 z) foo (list 12 z))))
+    (define/override (goo x) 
+      (super goo (list 13 x)))
+    (super-new)))
+
+(define bjjbjfoo-jbjjbgoo% 
+  (class bjjbfoo-jbjjgoo% 
+    (define/augride (foo x) 
+      (list 14 x))
+    (define/overment (goo x) 
+      (super goo (list 15 x)))
+    (super-new)))
+
+(test '(1 12) 'bjt (send (new bfoo-jgoo%) foo 12))
+(test '(3 13) 'bjt (send (new bfoo-jgoo%) goo 13))
+(test '(10 13.5) 'bjt (send (new bfoo-jgoo%) zoo 13.5))
+
+(test '(4 (2 14)) 'bjt (send (new bjfoo-jbgoo%) foo 14))
+(test '(5 (3 15)) 'bjt (send (new bjfoo-jbgoo%) goo 15))
+(test '(4 (20 (7 16))) 'bjt (send (new bjfoo-jbgoo%) hoo 16))
+
+(test '(8 (2 17)) 'bjt (send (new bjjfoo-jbjgoo%) foo 17))
+(test '(9 (6 (3 18))) 'bjt (send (new bjjfoo-jbjgoo%) goo 18))
+(test '(8 (20 (7 19))) 'bjt (send (new bjjfoo-jbjgoo%) hoo 19))
+
+(test '(11 (8 (10 (2 20)))) 'bjt (send (new bjjbfoo-jbjjgoo%) foo 20))
+(test '(9 (13 (6 (3 21)))) 'bjt (send (new bjjbfoo-jbjjgoo%) goo 21))
+(test '(11 (8 (10 (20 (7 22))))) 'bjt (send (new bjjbfoo-jbjjgoo%) hoo 22))
+
+(test '(14 (12 (8 (10 (2 23))))) 'bjt (send (new bjjbjfoo-jbjjbgoo%) foo 23))
+(test '(9 (13 (15 (6 (3 24))))) 'bjt (send (new bjjbjfoo-jbjjbgoo%) goo 24))
+(test '(14 (12 (8 (10 (20 (7 25)))))) 'bjt (send (new bjjbjfoo-jbjjbgoo%) hoo 25))
+
+;; ----------------------------------------
+
+(define rest-arg-fish%
+  (class fish%
+    (public greeting)
+
+    (begin ; should get flattened
+      (init -first-name)
+      (init-field last-name)
+      (init-rest -nicknames))
+
+    (define first-name -first-name) 
+    (define nicknames -nicknames) 
+
+    (define greeting
+      (letrec ([loop
+		(case-lambda
+		 [() (loop first-name last-name)]
+		 [(last-name first-name) ;; intentionally backwards to test scope
+		  (format "~a ~a, a.k.a.: ~a"
+			  last-name first-name
+			  nicknames)]
+		 [(a b c d . rest) 'never-get-here])])
+	loop))
+
+    (define/public useless-method (case-lambda))
+
+    (super-new (size 12))))
+
+(define rest-fish (make-object rest-arg-fish% "Gil" "Finn" "Slick"))
+
+(test "Gil Finn, a.k.a.: (Slick)" 'osf (send rest-fish greeting))
+
+(let ([exn (with-handlers ([exn:fail? (lambda (exn) exn)])
+	     (send rest-fish greeting 1 2 3))])
+  (test #t exn:fail:contract:arity? exn)
+  ;; (test 3 exn:application-value exn)
+  ;; (test (list 0 2 (make-arity-at-least 4)) exn:application:arity-expected exn)
+  )
+(let ([exn (with-handlers ([exn:fail? (lambda (exn) exn)])
+	     (send rest-fish useless-method 3))])
+  (test #t exn:fail:contract:arity? exn)
+  ;; (test 1 exn:application-value exn)
+  ;; (test null exn:application:arity-expected exn)
+  )
+
+;; Missing last-name:
+(err/rt-test (instantiate rest-arg-fish% () (-first-name "Gil") (-nicknames null)) 
+	     exn:fail:object?)
+
+(define rest-fish-0 (instantiate rest-arg-fish% () (-first-name "Gil") (last-name "Finn")))
+(test "Gil Finn, a.k.a.: ()" 'osf (send rest-fish-0 greeting))
+
+;; Keyword order doesn't matter:
+(define rest-fish-0.5 (instantiate rest-arg-fish% () (last-name "Finn") (-first-name "Gil")))
+(test "Gil Finn, a.k.a.: ()" 'osf (send rest-fish-0.5 greeting))
+
+(err/rt-test (instantiate rest-arg-fish% () 
+			  (-first-name "Gil") (last-name "Finn") 
+			  (-nicknames "Slick"))
+	     exn:fail:object?)
+(err/rt-test (instantiate rest-arg-fish% () 
+			  (-first-name "Gil") (last-name "Finn") 
+			  (anything "Slick"))
+	     exn:fail:object?)
+
+;; Redundant by-pos:
+(err/rt-test (instantiate rest-arg-fish% ("Gil") (-first-name "Gilly") (last-name "Finn"))
+	     exn:fail:object?)
+
+(define no-rest-fish%
+  (class fish%
+    (public greeting)
+
+    (init-field first-name)
+    (init-field last-name)
+    (init-rest)
+
+    (define (greeting)
+      (format "~a ~a" last-name first-name))
+
+    (super-instantiate (12))))
+
+;; Too many by-pos:
+(err/rt-test (instantiate no-rest-fish% ("Gil" "Finn" "hi" "there"))
+	     exn:fail:object?)
+
+(define no-rest-0 (instantiate no-rest-fish% ("Gil" "Finn")))
+(test 12 'norest (send no-rest-0 get-size))
+
+(define allow-rest-fish%
+  (class fish%
+    (public greeting)
+
+    (init-field first-name)
+    (init-field last-name)
+
+    (define (greeting)
+      (format "~a ~a" last-name first-name))
+
+    (super-instantiate ())))
+
+;; Too many by-pos:
+(err/rt-test (instantiate no-rest-fish% ("Gil" "Finn" 18 20))
+	     exn:fail:object?)
+
+(define no-rest-0 (instantiate allow-rest-fish% ("Gil" "Finn" 18)))
+(test 18 'allowrest (send no-rest-0 get-size))
+
+
+(define allow-rest/size-already-fish%
+  (class fish%
+    (public greeting)
+
+    (init-field first-name)
+    (init-field last-name)
+
+    (define (greeting)
+      (format "~a ~a" last-name first-name))
+
+    (super-instantiate (12))))
+
+;; Unused by-pos:
+(err/rt-test (instantiate allow-rest/size-already-fish% ("Gil" "Finn" 18))
+	     exn:fail:object?)
+
+
+;; Subclass where superclass has rest arg, check by-pos:
+
+(define with-rest%
+  (class object%
+    (init-rest args)
+    (field [a args])
+
+    (public get-args)
+    (define (get-args) a)
+    (super-instantiate ())))
+
+(define to-rest%
+  (class with-rest%
+    (super-instantiate ())))
+
+(test '("hi" "there") 'to-rest (send (instantiate to-rest% ("hi" "there")) get-args))
+(err/rt-test (instantiate to-rest% () (by-name "hi"))
+	     exn:fail:object?)
+
+;; Check by-pos with super-instantiate:
+
+(define to-rest2%
+  (class with-rest%
+    (super-instantiate ("hey,"))))
+
+(test '("hey," "hi" "there") 'to-rest (send (instantiate to-rest2% ("hi" "there")) get-args))
+(err/rt-test (instantiate to-rest2% () (by-name "hi"))
+	     exn:fail:object?)
+
+;; Even more nested:
+
+(define to-rest3%
+  (class to-rest2%
+    (super-instantiate ("um..."))))
+
+(test '("hey," "um..." "hi" "there") 'to-rest (send (instantiate to-rest3% ("hi" "there")) get-args))
+
+;; ------------------------------------------------------------
+;; ...-final  clauses.
+;; Internal calls to public-final and and pubment are direct,
+;;  but other calls must be indirect.
+
+(let ()
+  (define c% (class object%
+	       (define/pubment (foo x)
+		 1)
+	       (define/public-final (fool x)
+		 10)
+	       (define/public (aoo x) (foo x))
+	       (define/public (aool x) (fool x))
+	       (define/public (foo2 x) 2)
+	       (super-new)))
+  (define d% (class c%
+	       (define/augment (foo y)
+		 2)
+	       (define/public (goo z)
+		 (foo z))
+	       (define/override-final (foo2 x) 
+		 20)
+	       (define/public (goo2 z)
+		 (foo2 z))
+	       (super-new)))
+  (define e% (class c%
+	       (define/augment-final (foo y)
+		 2)
+	       (define/public (goo z)
+		 (foo z))
+	       (super-new)))
+  
+  (test 1 'foo (send (new c%) foo 0))
+  (test 1 'foo (send (new d%) foo 0))
+  (test 1 'foo (send (new d%) goo 0))
+  (test 1 'foo (send (new e%) goo 0))
+
+  (test 2 'foo (send (new c%) foo2 0))
+  (test 20 'foo (send (new d%) foo2 0))
+  (test 20 'foo (send (new d%) goo2 0))
+
+  (test 1 'aoo (send (new c%) aoo 0))
+  (test 10 'aool (send (new d%) aool 0))
+  (test 10 'aool (send (new d%) aool 0))
+
+  (err/rt-test (class c% (define/override (fool x) 12)) exn:fail:object?)
+  (err/rt-test (class c% (define/augment (fool x) 12)) exn:fail:object?)
+  (err/rt-test (class d% (define/override (foo2 x) 12)) exn:fail:object?)
+  (err/rt-test (class d% (define/augment (foo2 x) 12)) exn:fail:object?)
+  (err/rt-test (class e% (define/override (foo x) 12)) exn:fail:object?)
+  (err/rt-test (class e% (define/augment (foo x) 12)) exn:fail:object?)
+  )
+
+;; ------------------------------------------------------------
+;; Test send/apply dotted send and method-call forms:
+
+(define dotted% (class object%
+		  (public f g)
+		  (define (f x y z)
+		    (list z y x))
+		  (define (g x)
+		    (let ([w (list x (add1 x) (+ x 2))])
+		      (f . w)))
+		  (super-make-object)))
+(define dotted (make-object dotted%))
+(test '(3 2 1) 'dotted (send dotted f 1 2 3))
+(test '(9 8 7) 'dotted (send dotted g 7))
+(let ([l (list 3 5 6)])
+  (test '(6 5 3) 'dotted (send dotted f . l))
+  (test '(6 5 3) 'dotted (send/apply dotted f l))
+  (test '(9 8 7) 'dotted (send/apply dotted f '(7 8 9))))
+(let ([l (list 6 8)])
+  (test '(8 6 2) 'dotted (send dotted f 2 . l))
+  (test '(8 6 2) 'dotted (send/apply dotted f 2 l))
+  (test '(9 7 3) 'dotted (send/apply dotted f 3 '(7 9))))
+
+(syntax-test #'(send/apply dotted f 2 . l))
+
+;; ------------------------------------------------------------
+;; Test init & feld external names
+
+(define many-fields% (class object%
+		       (init i1
+			     [(i2* i2)])
+		       (init-field i3
+				   [(i4* i4)])
+		       (init [i5 5]
+			     [(i6* i6) 6])
+		       (init-field (i7 7)
+				   [(i8* i8) 8])
+		       (field [a 10]
+			      [(b* b) 12])
+		       (define inits+fields (list i1 i2* i3 i4* i5 i6* i7 i8* a b*))
+		       (define/public (get-fields)
+			 (list i3 i4* i7 i8* a b*))
+		       (define/public (get-inits+fields)
+			 inits+fields)
+		       (super-instantiate ())))
+
+(let ([om1 (make-object many-fields% 10 20 30 40)]
+      [oi1 (instantiate many-fields% () [i1 11] [i2 21] [i3 31] [i4 41])]
+      [om2 (make-object many-fields% 12 22 32 42 52 62 72 82)]
+      [oi2 (instantiate many-fields% () [i1 13] [i2 23] [i3 33] [i4 43] [i5 53] [i6 63] [i7 73] [i8 83])])
+  (test '(10 20 30 40 5 6 7 8 10 12) 'om1-if (send om1 get-inits+fields))
+  (test '(11 21 31 41 5 6 7 8 10 12) 'oi1-if (send oi1 get-inits+fields))
+  (test '(30 40 7 8 10 12) 'om1-f (send om1 get-fields))
+  (test '(31 41 7 8 10 12) 'oi1-f (send oi1 get-fields))
+  (test '(12 22 32 42 52 62 72 82 10 12) 'om2-if (send om2 get-inits+fields))
+  (test '(13 23 33 43 53 63 73 83 10 12) 'oi2-if (send oi2 get-inits+fields))
+  (test '(32 42 72 82 10 12) 'om2-f (send om2 get-fields))
+  (test '(33 43 73 83 10 12) 'oi2-f (send oi2 get-fields))
+  (test 10 (class-field-accessor many-fields% a) om1)
+  (test 12 (class-field-accessor many-fields% b) om1))
+
+
+;; ------------------------------------------------------------
+;; Test public*, define-public, etc.
+
+(syntax-test #'(class object% public*))
+(syntax-test #'(class object% (public* . x)))
+(syntax-test #'(class object% (public* x)))
+(syntax-test #'(class object% (public* [x])))
+(syntax-test #'(class object% (public* [x . y])))
+(syntax-test #'(class object% (public* [x 7 8])))
+(syntax-test #'(class object% (public* [7 8])))
+
+(syntax-test #'(class object% override*))
+(syntax-test #'(class object% (override* . x)))
+(syntax-test #'(class object% (override* x)))
+(syntax-test #'(class object% (override* [x])))
+(syntax-test #'(class object% (override* [x . y])))
+(syntax-test #'(class object% (override* [x 7 8])))
+(syntax-test #'(class object% (override* [7 8])))
+
+(syntax-test #'(class object% private*))
+(syntax-test #'(class object% (private* . x)))
+(syntax-test #'(class object% (private* x)))
+(syntax-test #'(class object% (private* [x])))
+(syntax-test #'(class object% (private* [x . y])))
+(syntax-test #'(class object% (private* [x 7 8])))
+(syntax-test #'(class object% (private* [7 8])))
+
+(syntax-test #'(class object% define/public))
+(syntax-test #'(class object% (define/public)))
+(syntax-test #'(class object% (define/public x)))
+(syntax-test #'(class object% (define/public x 1 2)))
+(syntax-test #'(class object% (define/public 1 2)))
+(syntax-test #'(class object% (define/public (x 1) 2)))
+(syntax-test #'(class object% (define/public (1 x) 2)))
+(syntax-test #'(class object% (define/public (x . 1) 2)))
+(syntax-test #'(class object% (define/public ((x 1) . a) 2)))
+(syntax-test #'(class object% (define/public ((x b b) a) 2)))
+
+(syntax-test #'(class object% define/override))
+(syntax-test #'(class object% (define/override)))
+(syntax-test #'(class object% (define/override x)))
+(syntax-test #'(class object% (define/override x 1 2)))
+(syntax-test #'(class object% (define/override 1 2)))
+(syntax-test #'(class object% (define/override (x 1) 2)))
+(syntax-test #'(class object% (define/override (1 x) 2)))
+(syntax-test #'(class object% (define/override (x . 1) 2)))
+
+(syntax-test #'(class object% define/private))
+(syntax-test #'(class object% (define/private)))
+(syntax-test #'(class object% (define/private x)))
+(syntax-test #'(class object% (define/private x 1 2)))
+(syntax-test #'(class object% (define/private 1 2)))
+(syntax-test #'(class object% (define/private (x 1) 2)))
+(syntax-test #'(class object% (define/private (1 x) 2)))
+(syntax-test #'(class object% (define/private (x . 1) 2)))
+
+(define c*1% (class object%
+	       (define/public (x) (f))
+	       (define/public ((higher-order a) b) (+ a b))
+	       (public*
+		[y (lambda () 2)]
+		[z (lambda () 3)])
+	       (private*
+		[f (lambda () 1)])
+	       (super-make-object)))
+
+(define c*2% (class c*1%
+	       (override*
+		[y (lambda () 20)])
+	       (define/override z (lambda () (g)))
+	       (define/private (g) 30)
+	       (super-make-object)))
+
+(define o*1 (make-object c*1%))
+(define o*2 (make-object c*2%))
+
+(test 1 'o1 (send o*1 x))
+(test 2 'o1 (send o*1 y))
+(test 3 'o1 (send o*1 z))
+(test 1 'o2 (send o*2 x))
+(test 20 'o2 (send o*2 y))
+(test 30 'o2 (send o*2 z))
+(test 7 'o2 ((send o*2 higher-order 1) 6))
+
+;; ----------------------------------------
+;; Macro definitions in classes
+
+(define cm1%
+  (class object%
+    (public meth)
+    
+    (define-syntax (macro stx)
+      (syntax 10))
+    
+    (field [x (macro)])
+    (init-field [y (macro)])
+    (init  [-z (macro)])
+    (field [z -z])
+
+    (define w (macro))
+
+    (define meth (lambda () (macro)))
+    (define meth2 (lambda () (macro)))
+
+    (define/public get-z (lambda () z))
+    (define/public get-w (lambda () w))
+    
+    (super-instantiate ())))
+
+(test 10 'cm1-meth (send (make-object cm1%) meth))
+(test 10 'cm1-x ((class-field-accessor cm1% x) (make-object cm1%)))
+(test 10 'cm1-y ((class-field-accessor cm1% y) (make-object cm1%)))
+(test 10 'cm1-z (send (make-object cm1%) get-z))
+(test 10 'cm1-w (send (make-object cm1%) get-w))
+
+;; Make sure that local and syntax names do not shadow enclosing syntax for
+;; definition RHSs
+(test #t class? (let-syntax ([see-outer (lambda (x) (syntax (lambda () 10)))])
+		  (class object%
+		    (define see-outer 10)
+		    (public meth)
+		    (define meth (see-outer)))))
+(test #t class? (let-syntax ([see-outer (lambda (x) (syntax (lambda () 10)))])
+		  (class object%
+		    (define-macro see-outer 10)
+		    (public meth)
+		    (define meth (see-outer)))))
+
+;; Make sure that declared method names, field names, etc.
+;; *do* shadow for definition RHSs
+(let ([mk-syntax-test
+       (lambda (mk)
+	 (syntax-test (datum->syntax-object
+		       (quote-syntax here)
+		       `(let-syntax ([dont-see-outer (lambda (x) (syntax (lambda () 10)))])
+			  (class object% 
+			    ,@(mk 'dont-see-outer)
+			    (public meth)
+			    (define meth (dont-see-outer)))))))])
+  (mk-syntax-test (lambda (id) `((init ,id))))
+  (mk-syntax-test (lambda (id) `((init-rest ,id))))
+  (mk-syntax-test (lambda (id) `((field [,id 10]))))
+  (mk-syntax-test (lambda (id) `((inherit-field ,id))))
+  (mk-syntax-test (lambda (id) `((inherit ,id))))
+  (mk-syntax-test (lambda (id) `((rename-super [,id old-id]))))
+  (mk-syntax-test (lambda (id) `((public ,id) (define (id) 10))))
+  (mk-syntax-test (lambda (id) `((private ,id) (define (id) 10))))
+  (mk-syntax-test (lambda (id) `((override ,id) (define (id) 10)))))
+
+
+(syntax-test #'(class-field-accessor))
+(syntax-test #'(class-field-accessor ok))
+(syntax-test #'(class-field-accessor ok 7))
+(syntax-test #'(class-field-accessor ok% ok ok))
+(syntax-test #'(class-field-accessor ok% . ok))
+(syntax-test #'(class-field-mutator))
+(syntax-test #'(class-field-mutator ok))
+(syntax-test #'(class-field-mutator ok 7))
+(syntax-test #'(class-field-mutator ok% ok ok))
+(syntax-test #'(class-field-mutator ok% . ok))
+
+(syntax-test #'(define-local-member-name . a))
+(syntax-test #'(define-local-member-name 7))
+(syntax-test #'(define-local-member-name a 7))
+(syntax-test #'(define-local-member-name a a))
+
+;; ------------------------------------------------------
+;; Private names
+
+(let ([o (let ()
+	   (define-local-member-name priv)
+	   (let ([o (make-object
+		     (class object%
+		       (define/public (priv) (let ([priv 73]) priv))
+		       (super-make-object)))])
+	     (test 73 'priv (send o priv))
+	     o))])
+  (err/rt-test (send o priv) exn:fail:object?))
+
+(let ([c% (let ()
+	    (define-local-member-name priv)
+	    (let ([c% (class object%
+			(init-field priv)
+			(super-make-object))])
+	      (test 100 'priv ((class-field-accessor c% priv) (make-object c% 100)))
+	      (test 100 'priv ((class-field-accessor c% priv) (instantiate c% () [priv 100])))
+	      c%))])
+  (err/rt-test (class-field-accessor c% priv) exn:fail:object?)
+  (test #t object? (make-object c% 10))
+  (err/rt-test (instantiate c% () [priv 10]) exn:fail:object?))
+
+(let ([c% (let ()
+	    (define-local-member-name priv)
+	    (let ([c% (class object%
+			(init priv)
+			(define xpriv priv)
+			(define/public (m) xpriv)
+			(super-make-object))])
+	      (test 100 'priv (send (make-object c% 100) m))
+	      (test 100 'priv (send (instantiate c% () [priv 100]) m))
+	      c%))])
+  (test 101 'priv (send (make-object c% 101) m))
+  (err/rt-test (instantiate c% () [priv 101]) exn:fail:object?))
+
+(let ([c% (let ()
+	    (define-local-member-name priv)
+	    (let ([c% (class object%
+			(init xpriv)
+			(field [priv xpriv])
+			(define/public (m) priv)
+			(super-make-object))])
+	      (test 100 'priv ((class-field-accessor c% priv) (make-object c% 100)))
+	      (test 101 'priv (send (make-object c% 101) m))
+	      (test 100 'priv (send (instantiate c% () [xpriv 100]) m))
+	      (test 100 'priv ((class-field-accessor c% priv) (instantiate c% () [xpriv 100])))
+	      c%))])
+  (err/rt-test (class-field-accessor c% priv) exn:fail:object?)
+  (test 101 'priv (send (make-object c% 101) m))
+  (test 101 'priv (send (instantiate c% () [xpriv 101]) m))
+  (err/rt-test (instantiate c% () [priv 10]) exn:fail:object?))
+
+(let ([c% (let ()
+	    (define-local-member-name priv)
+	    (let* ([i<%> (interface () priv)]
+                   [c% (class* object% (i<%>)
+                         (init-field val)
+                         (define/public (priv) val)
+                         (super-make-object))])
+	      (test 100 'priv (send (make-object c% 100) priv))
+	      (test 100 'priv (send* (make-object c% 100) (priv)))
+	      (test 100 'priv (with-method ([p ((make-object c% 100) priv)]) (p)))
+	      (test 100 'gen-priv-cls (send-generic (make-object c% 100) (generic c% priv)))
+              (test 100 'gen-priv-intf (send-generic (make-object c% 100) (generic i<%> priv)))
+	      (err/rt-test (make-generic c% 'priv) exn:fail:object?)
+	      c%))])
+  (test #t object? (make-object c% 10))
+  (err/rt-test (send (make-object c% 10) priv) exn:fail:object?)
+  (err/rt-test (send* (make-object c% 10) (priv)) exn:fail:object?)
+  (err/rt-test (with-method ([p ((make-object c% 100) priv)]) (p)) exn:fail:object?)
+  (err/rt-test (generic c% priv) exn:fail:object?)
+  (err/rt-test (make-generic c% 'priv) exn:fail:object?))
+
+;; Make sure local name works with `send' in an area where the
+;;  name is also directly bound:
+(let ([c% (let ()
+	    (define-local-member-name priv)
+	    (class object%
+	      (define/public (priv x) (+ x 10))
+	      (define/public (pub y) (send this priv (* 2 y)))
+	      (super-new)))])
+  (test 16 'send-using-local (send (new c%) pub 3)))
+
+;; ------------------------------------------------------------
+;; `new' tests
+
+(syntax-test #'(new))
+(syntax-test #'(new x x))
+(syntax-test #'(new x ()))
+(syntax-test #'(new x (x)))
+(syntax-test #'(new x ("a" x)))
+
+(test #t object? (new object%))
+(test #t object? (new (class object% () (init-field x) (super-instantiate ())) (x 1)))
+
+;; ------------------------------------------------------------
+;; `field' tests
+
+
+(syntax-test #'(get-field))
+(syntax-test #'(get-field a))
+(syntax-test #'(get-field 1 b))
+(syntax-test #'(get-field a b c))
+
+(error-test #'(get-field x 1) exn:application:mismatch?)
+(error-test #'(get-field x (new object%)) exn:application:mismatch?)
+(error-test #'(get-field x (new (class object% (define x 1) (super-new))))
+            exn:application:mismatch?)
+(error-test #'(let ([o (let ()
+                         (define-local-member-name f)
+                         (new (class object%
+                                (field [f 0])
+                                (super-new))))])
+                (get-field f o))
+            exn:application:mismatch?)
+(test 0 'get-field1 (get-field x (new (class object% (field [x 0]) (super-new)))))
+(test 0 'get-field2 (let ()
+                      (define-local-member-name f)
+                      (get-field f (new (class object% (field [f 0]) (super-new))))))
+(let ([o (new (class (class object% (field [f 10]) (super-new))
+		(field [g 11])
+		(super-new)))])
+  (test 10 'get-field3 (get-field f o))
+  (test 11 'get-field3 (get-field g o)))
+
+(syntax-test #'(field-bound?))
+(syntax-test #'(field-bound? a))
+(syntax-test #'(field-bound? 1 b))
+(syntax-test #'(field-bound? a b c))
+
+(error-test #'(field-bound? x 1) exn:application:mismatch?)
+(test #t 'field-bound?1 (field-bound? x (new (class object% (field [x 0]) (super-new)))))
+(test #f 'field-bound?2 (field-bound? y (new (class object% (field [x 0]) (super-new)))))
+(test #f 'field-bound?3 (field-bound? y (new object%)))
+
+(test #f
+      'field-bound?/local-name1
+      (let ([o (let ()
+                 (define-local-member-name f)
+                 (new (class object% (field [f 10]) (super-new))))])
+        (field-bound? f o)))
+
+(test #t
+      'field-bound?/local-name2
+      (let ()
+        (define-local-member-name f)
+        (field-bound? f (new (class object% (field [f 10]) (super-new))))))
+
+(test '(f) field-names (new (class object% (field [f 1]) (super-new))))
+(test '(g)
+      field-names 
+      (let ()
+        (define-local-member-name f)
+        (new (class object% (field [f 1] [g 1]) (super-new)))))
+
+(report-errs)
diff --git a/collects/tests/mzscheme/oe.ss b/collects/tests/mzscheme/oe.ss
new file mode 100644
index 0000000000..b2b1740699
--- /dev/null
+++ b/collects/tests/mzscheme/oe.ss
@@ -0,0 +1,42 @@
+(define-values (odd) (lambda (x) (if (zero? x) #f (even (- x 1)))))
+(define-values (even) (lambda (x) (if (zero? x) #t (odd (- x 1)))))
+
+(define-values (odd2)
+  (letrec ([even (lambda (x) (if (zero? x) #t (odd (- x 1))))]
+	   [odd (lambda (x) (if (zero? x) #f (even (- x 1))))])
+    odd))
+
+(define-values (odd3)
+  (let ([test (lambda (base other)
+		(lambda (x) (if (zero? x) base ((other) (- x 1)))))])
+    (letrec ([odd (test #f (lambda () even))]
+	     [even (test #t (lambda () odd))])
+      odd)))
+
+(define-values (fib)
+  (lambda (n)
+    (if (<= n 1)
+	1
+	(+ (fib (- n 1)) (fib (- n 2))))))
+
+(define-values (mutate)
+  (lambda (n)
+    (let loop ()
+      (unless (zero? n)
+	      (set! n (sub1 n))
+	      (loop)))))
+
+(define-values (mutate-evil)
+  (lambda (n)
+    (let loop ([n n])
+      (unless (zero? n)
+	      (set! n (sub1 n))
+	      (loop n)))))
+
+(define-values (c-loop)
+  (let-values ([(a b c d e f g) (values 1 2 3 4 5 6 7)])
+    (lambda (n)
+      (let loop ([n n])
+	(if (zero? n)
+	    (+ a b c d e f g)
+	    (loop (sub1 n)))))))
diff --git a/collects/tests/mzscheme/oee.ss b/collects/tests/mzscheme/oee.ss
new file mode 100644
index 0000000000..d7e70adfb3
--- /dev/null
+++ b/collects/tests/mzscheme/oee.ss
@@ -0,0 +1,45 @@
+
+; Test the oe extension
+
+(if (not (defined? 'SECTION))
+    (load-relative "testing.ss"))
+
+(define b1 (class object% () (public [z1 7][z2 8]) (sequence (super-init))))
+(define b3 (class object% () (public [z1 13][z2 14]) (sequence (super-init))))
+
+(define i1 (mktinterface (interface () z1)))
+(define i3 (mktinterface (interface () z2)))
+
+(define c1 (mktclass b1 i1))
+(define c3 (mktclass b3 i3))
+
+(define o1 (make-object c1 1 2))
+(define o2 (make-object c1 3 4))
+(define o3 (make-object c3 5 6))
+
+(test 5 'oee (send o1 get-y))
+(test 5 'oee (send o2 get-y))
+(test 5 'oee (send o3 get-y))
+
+(test 7 'oee (send o1 get-z1))
+(test 7 'oee (send o2 get-z1))
+(test 13 'oee (send o3 get-z1))
+
+(test 8 'oee (send o1 get-z2))
+(test 8 'oee (send o2 get-z2))
+(test 14 'oee (send o3 get-z2))
+
+(test 1 'oee (send o1 get-x1))
+(test 3 'oee (send o2 get-x1))
+(test 5 'oee (send o3 get-x1))
+
+(test 2 'oee (send o1 get-x2))
+(test 4 'oee (send o2 get-x2))
+(test 6 'oee (send o3 get-x2))
+
+(error-test '(mktinterface 0) exn:object:interface-type?)
+(error-test '(mktclass 0 i1) exn:object:class-type?)
+(error-test '(mktclass b1 0) exn:object:interface-type?)
+(error-test '(mktclass b1 (interface () not-there)) exn:object:implement?)
+
+(report-errs)
diff --git a/collects/tests/mzscheme/optimize.ss b/collects/tests/mzscheme/optimize.ss
new file mode 100644
index 0000000000..09f92e0fe4
--- /dev/null
+++ b/collects/tests/mzscheme/optimize.ss
@@ -0,0 +1,110 @@
+
+(load-relative "loadtest.ss")
+
+(SECTION 'optimization)
+
+;; For some comparison, ignore the stack-depth
+;;  part of the compilation result (since it's
+;;  an approximation, anyway).
+(define maybe-different-depths? #f)
+
+(define (comp=? c1 c2)
+  (let ([s1 (open-output-string)]
+	[s2 (open-output-string)])
+    (write c1 s1)
+    (write c2 s2)
+    (let ([t1 (get-output-string s1)]
+	  [t2 (get-output-string s2)])
+      (or (string=? t1 t2)
+	  (and maybe-different-depths?
+	       (string=? (substring t1 5 (string-length t1))
+			 (substring t2 5 (string-length t2))))))))
+
+(define test-comp
+  (case-lambda
+   [(expr1 expr2) (test-comp expr1 expr2 #t)]
+   [(expr1 expr2 same?)
+    (test same? `(compile ,same? ,expr2) (comp=? (compile expr1) (compile expr2)))]))
+
+(let ([x (compile '(lambda (x) x))])
+  (test #t 'fixpt (eq? x (compile x))))
+
+(test-comp 5 '(if #t 5 (cons 1 2)))
+(test-comp 5 '(if #f (cons 1 2) 5))
+
+(test-comp 5 '(begin0 5 'hi "apple" 1.5))
+(test-comp 5 '(begin0 5 (begin0 'hi "apple" 1.5)))
+(test-comp 5 '(begin0 5 (begin0 'hi "apple") 1.5))
+(test-comp 5 '(begin0 5 (begin 'hi "apple" 1.5)))
+(test-comp 5 '(begin0 5 (begin 'hi "apple") 1.5))
+(test-comp 5 '(begin0 (begin0 5 'hi "apple" 1.5)))
+(test-comp 5 '(begin0 (begin0 5 'hi "apple") 1.5))
+
+; Can't drop `begin0' if the first expresson is not valueable:
+(test-comp '(begin0 (begin0 (+ 1 2) 0) 0) '(begin0 (begin0 (+ 1 2) 'hi "apple") 1.5))
+
+(test-comp 5 '(begin 'hi "apple" 1.5 5))
+(test-comp 5 '(begin (begin 'hi "apple" 1.5) 5))
+(test-comp 5 '(begin (begin 'hi "apple") 1.5 5))
+(test-comp 5 '(begin (begin0 'hi "apple" 1.5) 5))
+(test-comp 5 '(begin (begin0 'hi "apple") 1.5 5))
+(test-comp 5 '(begin (begin 'hi "apple" 1.5 5)))
+(test-comp 5 '(begin 'hi (begin "apple" 1.5 5)))
+
+(test-comp '(let ([x 8][y 9]) (lambda () x))
+	   '(let ([x 8][y 9]) (lambda () (if #f y x))))
+(test-comp '(let ([x 8][y 9]) (lambda () (+ x y)))
+	   '(let ([x 8][y 9]) (lambda () (if #f y (+ x y)))))
+
+(test-comp '(let ([x 5]) (set! x 2)) '(let ([x 5]) (set! x x) (set! x 2)))
+
+(test-comp '(let* () (f 5))
+	   '(f 5))
+(test-comp '(letrec () (f 5))
+	   '(f 5))
+(test-comp '(with-handlers () (f 5))
+	   '(f 5))
+(test-comp '(parameterize () (f 5))
+	   '(f 5))
+(test-comp '(fluid-let () (f 5))
+	   '(f 5))
+
+(test-comp '(let ([i (cons 0 1)]) (let ([j i]) j))
+	   '(let ([i (cons 0 1)]) i))
+
+(define (normalize-depth s)
+  `(let ([a ,s]
+	 [b (let-values ([(a b c d e f) (values 1 2 3 4 5 6)])
+	      (list a b c d e f))])
+     10))
+
+(test-comp (normalize-depth '(let* ([i (cons 0 1)][j i]) j))
+	   (normalize-depth '(let* ([i (cons 0 1)]) i)))
+
+(test-comp (normalize-depth '(let* ([i (cons 0 1)][j (list 2)][k (list 3)][g i]) g))
+	   (normalize-depth '(let* ([i (cons 0 1)][j (list 2)][k (list 3)]) i)))
+
+(test-comp (normalize-depth '(let* ([i (cons 0 1)][j (list 2)][k (list 3)][g i][h g]) h))
+	   (normalize-depth '(let* ([i (cons 0 1)][j (list 2)][k (list 3)]) i)))
+
+(test-comp (normalize-depth '(let* ([i (cons 0 1)][g i][h (car g)][m h]) m))
+	   (normalize-depth '(let* ([i (cons 0 1)][h (car i)]) h)))
+
+(set! maybe-different-depths? #t)
+
+(require #%kernel) ; 
+
+(test-comp (void) '(void))
+(test-comp 3 '(+ 1 2))
+(test-comp 65 '(char->integer #\A))
+(test-comp (expt 5 30)
+	   '(expt 5 (* 5 6)))
+(test-comp 88
+	   '(if (pair? null) 89 88))
+
+(test-comp '(let ([x 3]) x)
+	   '((lambda (x) x) 3))
+(test-comp '(let ([x 3][y 4]) (+ x y))
+	   '((lambda (x y) (+ x y)) 3 4))
+
+(report-errs)
diff --git a/collects/tests/mzscheme/package-gen.ss b/collects/tests/mzscheme/package-gen.ss
new file mode 100644
index 0000000000..e05af41ef7
--- /dev/null
+++ b/collects/tests/mzscheme/package-gen.ss
@@ -0,0 +1,142 @@
+
+(require (lib "package.ss")
+	 (lib "pretty.ss")
+	 (lib "toplevel.ss" "syntax"))
+
+(define (check x)
+  (unless (equal? x 'this-is-right)
+    (error "check" "nopde: ~e" x)))
+
+(define open-context-forms
+  (list (lambda (l) `(begin ,@l))
+	(lambda (l) `(let () ,@l))
+	(lambda (l) `(package other () ,@l))))
+
+(define open-forms
+  (apply
+   append
+   (map
+    (lambda (open-form)
+      (map (lambda (ctx)
+	     (ctx `((,open-form pk-to-open) (check var-to-use))))
+	   open-context-forms))
+    (list 'open 'open*))))
+
+(define (mk-package-shell-forms name)
+  (list (lambda (body) `(package ,name all-defined ,@body))
+	(lambda (body) `(package ,name (var-to-use) ,@body))
+	(lambda (body) `(package* ,name all-defined ,@body))
+	(lambda (body) `(package* ,name (var-to-use) ,@body))))
+
+(define package-shell-forms
+  (append (mk-package-shell-forms 'pk-to-open)
+	  (apply
+	   append
+	   (map (lambda (rename-potential-package)
+		  (map (lambda (psf)
+			 (lambda (body)
+			   `(begin ,(psf body) (,rename-potential-package pk-to-open hidden-pk-to-open))))
+		       (mk-package-shell-forms 'hidden-pk-to-open)))
+		(list 'rename-potential-package
+		      'rename*-potential-package)))))
+
+(define defn-forms
+  (list '(define var-to-use 'this-is-right)
+	'(define* var-to-use 'this-is-right)
+	'(begin
+	    (define* var-to-use 'this-is-wrong)
+	    (define* var-to-use 'this-is-right))))
+
+(define body-forms
+  (apply
+   append
+   (map (lambda (body-ctx)
+	  (map body-ctx defn-forms))
+	(list
+	 (lambda (d) `(,d))
+	 (lambda (d) `((begin ,d)))
+	 (lambda (d) `((define y 'no-this-one) ,d))
+	 (lambda (d) `(,d (define y 'no-this-one)))))))
+
+
+(define package-forms
+  (apply 
+   append
+   (map
+    (lambda (ps)
+      (map ps body-forms))
+    package-shell-forms)))
+
+(define combo-context-forms
+  (list (lambda (p o) `(begin ,p ,o))
+	(lambda (p o) `(let () ,p ,o 10))
+	(lambda (p o) `(package out1 all-defined ,p ,o))
+	(lambda (p o) `(package out2 all-defined (package out1 all-defined ,p ,o)))))
+
+(define all-forms
+  (apply
+   append
+   (map (lambda (cc)
+	  (apply
+	   append
+	   (map (lambda (p)
+		  (map (lambda (o)
+			 (cc p o))
+		       open-forms))
+		package-forms)))
+	combo-context-forms)))
+
+(define do-threshold 3)
+
+(let ([m ((current-module-name-resolver) '(lib "package.ss") #f #f)]
+      [ns (current-namespace)]
+      [total (length all-forms)]
+      [cnt 0])
+  (for-each (lambda (form)
+	      (set! cnt (add1 cnt))
+	      (when (zero? (modulo cnt 100))
+		(printf "~a/~a~n" cnt total))
+	      (when ((add1 (random 10)) . >= . do-threshold)
+		; (pretty-print form)
+		(parameterize ([current-namespace (make-namespace)])
+		  (namespace-attach-module ns m)
+		  (let ([done? #f]
+			[mode "top-level"])
+		    (with-handlers ([exn:fail?
+				     (lambda (x)
+				       (printf "At ~a:~n" mode)
+				       (pretty-print form)
+				       (raise x))])
+		      (eval `(require (lib "package.ss")))
+		      (eval `(define check ,(lambda (x)
+					      (check x)
+					      (set! done? #t))))
+		      (eval form)
+		      (unless done?
+			(error "check" "didn't execute"))
+		      (set! done? #f)
+		      (set! mode "top-level expand")
+		      (eval-syntax (expand-top-level-with-compile-time-evals 
+				    (datum->syntax-object #f form)))
+		      (unless done?
+			(error "check" "didn't execute after expand"))
+		      (let ([mod (lambda (name)
+				   `(module ,name mzscheme
+				      (require (lib "package.ss"))
+				      (define check ,(lambda (x)
+						       (check x)
+						       (set! done? #t)))
+				      ,form))])
+			(set! done? #f)
+			(set! mode "module")
+			(eval (mod 'm))
+			(eval `(require m))
+			(unless done?
+			  (error "check" "module didn't execute"))
+			(set! done? #f)
+			(set! mode "module expand")
+			(eval-syntax (expand (mod 'n)))
+			(eval `(require n))
+			(unless done?
+			  (error "check" "module didn't execute after expand"))))))))
+	    all-forms))
diff --git a/collects/tests/mzscheme/package.ss b/collects/tests/mzscheme/package.ss
new file mode 100644
index 0000000000..62b05a9699
--- /dev/null
+++ b/collects/tests/mzscheme/package.ss
@@ -0,0 +1,309 @@
+
+(load-relative "loadtest.ss")
+(require (lib "package.ss"))
+
+
+(SECTION 'packages)
+
+(define expand-test-use-toplevel? #t)
+
+;; syntax
+(syntax-test #'(dot))
+(syntax-test #'(dot 1))
+(syntax-test #'(dot 1 2))
+(syntax-test #'(dot 1 x))
+
+(syntax-test #'(open))
+(syntax-test #'(open 1))
+(syntax-test #'(open 1 2))
+(syntax-test #'(open 1 x))
+
+(syntax-test #'(define-dot))
+(syntax-test #'(define-dot 1))
+(syntax-test #'(define-dot x))
+(syntax-test #'(define-dot 1 2))
+(syntax-test #'(define-dot 1 x))
+(syntax-test #'(define-dot x 1))
+(syntax-test #'(define-dot x y))
+(syntax-test #'(define-dot 1 x y))
+(syntax-test #'(define-dot x y 3))
+(syntax-test #'(define-dot x 2 y))
+
+(syntax-test #'(package))
+(syntax-test #'(package x))
+(syntax-test #'(package 1))
+(syntax-test #'(package x 1))
+(syntax-test #'(package x x))
+(syntax-test #'(package x (1)))
+
+
+
+;; Providing
+(package p1 all-defined
+  (define x 10)
+  (package y all-defined
+    (define x 12)))
+
+(package p2 ()
+  (define x 10))
+
+(package p3 (x)
+  (package x all-defined
+    (define x 10)))
+
+(package p4 all-defined
+  (package x (x)
+    (define x 10)
+    (define y 11)))
+
+(define exn:variable? exn:fail:contract:variable?)
+
+(err/rt-test xxxx exn:variable?)
+(test 10 "" (dot p1 x))
+(test 12 "" (dot p1 y x))
+(syntax-test #'(dot p2 x))
+(test 10 "" (dot p3 x x))
+(test 10 "" (dot p4 x x))
+(syntax-test #'(dot p4 x y))
+(syntax-test #'(package p (x)))
+(syntax-test #'(package p (x) (package y (x) (define x 10))))
+
+;; Internal-defines
+(let ((p1 1)
+      (x 2))
+  (define x 1111)
+  (package p1 all-defined
+    (define x 10)
+    (package y all-defined
+      (define x 12)))
+  
+  (package p2 ()
+    (define x 10))
+  
+  (package p3 (x)
+    (package x all-defined
+      (define x 10)))
+  
+  (package p4 all-defined
+    (package x (x)
+      (define x 10)
+      (define y 11)))
+  
+  (test 10 "" (dot p1 x))
+  (test 12 "" (dot p1 y x))
+  (syntax-test #'(dot p2 x))
+  (test 10 "" (dot p3 x x))
+  (test 10 "" (dot p4 x x))
+  (syntax-test #'(dot p4 x y)))
+(syntax-test #'(let () (package p (x)) 1))
+(syntax-test #'(let () (package p (x) (package y (x) (define x 10))) 1))
+(syntax-test #'(let ((all-defined 1)) (package p all-defined (define s 1)) 1))
+
+;; starred defines
+(package p5 all-defined
+  (define*-values (x) 10)
+  (define*-values (f) (lambda () x))
+  (define*-values (x) 12))
+(test 12 "" (dot p5 x))
+(test 10 "" ((dot p5 f)))
+
+;; mutual references
+(package p99 all-defined
+  (define (f) x)
+  (define x 77))
+(test 77 "" (dot p99 x))
+(test 77 "" ((dot p99 f)))
+(let ()
+  (package p99. all-defined
+    (define (f) x)
+    (define x 177))
+  (test 177 "" (dot p99. x))
+  (test 177 "" ((dot p99. f))))
+;;
+(package p98 all-defined
+  (define (f) x)
+  (define* y 11)
+  (define x 78))
+(test 78 "" (dot p98 x))
+(test 11 "" (dot p98 y))
+(test 78 "" ((dot p98 f)))
+(let ()
+  (package p98. all-defined
+    (define (f) x)
+    (define* y 111)
+    (define x 178))
+  (test 178 "" (dot p98. x))
+  (test 111 "" (dot p98. y))
+  (test 178 "" ((dot p98. f))))
+
+;; nesting
+(package p6 all-defined
+  (package xx all-defined
+    (define x 10))
+  (package z all-defined
+    (package a all-defined
+      (define z 111)))
+  (define y (dot xx x))
+  (define x 11))
+
+(test 11 "" (dot p6 x))
+(test 10 "" (dot p6 y))
+(syntax-test #'(dot p6 x x))
+(test 111 "" (dot p6 z a z))
+
+;; open
+(let ()
+  (package p7 all-defined
+    (define a 1)
+    (define b 2)
+    (define c 3))
+  (let ()
+    (package p8 all-defined
+      (open* p7)
+      (define* c 4))
+    (test 1 "" (dot p8 a))
+    (test 1 "" (dot p7 a))
+    (test 2 "" (dot p8 b))
+    (test 2 "" (dot p7 b))
+    (test 4 "" (dot p8 c))
+    (test 3 "" (dot p7 c))))
+
+(let ()
+  ;; Same test as above, but without nested lets:
+  (package p7. all-defined
+    (define a 10)
+    (define b 20)
+    (define c 30))
+  (package p8. all-defined
+    (open* p7.)
+    (define* c 40))
+  (test 10 "" (dot p8. a))
+  (test 10 "" (dot p7. a))
+  (test 20 "" (dot p8. b))
+  (test 20 "" (dot p7. b))
+  (test 40 "" (dot p8. c))
+  (test 30 "" (dot p7. c)))
+
+(let ()
+  (package p9 all-defined
+    (package x all-defined
+      (define x 1)))
+  (let ()
+    (open p9)
+    (test 1 "" (dot x x))))
+
+(let ()
+  (package p9 all-defined
+    (package x all-defined
+      (define x 1)))
+  (let ()
+    (open p9 x)
+    (test 1 "" x)))
+
+(syntax-test #'(open x))
+(syntax-test #'(let () (package y all-defined (package z ())) (let () (open y a))))
+(syntax-test #'(let () (package y all-defined (package z ())) (let () (open y z a))))
+
+;; open* after use => no capture
+(let ([x 99])
+  (package yyy () 
+    (package p (x) (define x 8)) 
+    (define (f) x) 
+    (open* p) 
+    (test 99 f))
+  'ok)
+;; open after use => capture
+(package yyy () 
+  (package p (x) 
+    (define x 88)) 
+  (define (f) x) 
+  (open p) 
+  (test 88 f))
+
+;; Mutually referential packages:
+(let ()
+  (package o (odd)
+    (define (odd x) (if (zero? x) #f (even (sub1 x)))))
+  (package e (even)
+    (define (even x) (if (zero? x) #t (odd (sub1 x)))))
+  (open o)
+  (open e)
+  (test #t odd 17)
+  (test #f even 19))
+(err/rt-test
+ ;; Like above, but omit an open:
+ (let ()
+   (package o (odd)
+     (define (odd x) (if (zero? x) #f (even (sub1 x)))))
+   (package e (even)
+     (define (even x) (if (zero? x) #t (odd (sub1 x)))))
+   (open o)
+   (odd 17))
+ exn:variable?)
+(err/rt-test
+ ;; Omit the other open:
+ (let ()
+   (package o (odd)
+     (define (odd x) (if (zero? x) #f (even (sub1 x)))))
+   (package e (even)
+     (define (even x) (if (zero? x) #t (odd (sub1 x)))))
+   (open e)
+   (even 17))
+ exn:variable?)
+;; Same as working, but in a package:
+(package yyy ()
+  (package o (odd)
+    (define (odd x) (if (zero? x) #f (even (sub1 x)))))
+  (package e (even)
+    (define (even x) (if (zero? x) #t (odd (sub1 x)))))
+  (open o)
+  (open e)
+  (test #t odd 17)
+  (test #f even 19))
+(err/rt-test
+ ;; open* shouldn't work:
+ (let ()
+   (package yyy ()
+     (package o (odd)
+       (define (odd x) (if (zero? x) #f (even (sub1 x)))))
+     (package e (even)
+       (define (even x) (if (zero? x) #t (odd (sub1 x)))))
+     (open* o)
+     (open e)
+     (odd 17))
+   'ok)
+ exn:variable?)
+
+;; define-dot
+(let ()
+  (package x all-defined
+    (define z 10))
+  (define-dot a x z)
+  (test 10 "" a))
+(let ()
+  (package x all-defined
+    (package y all-defined
+      (define z 10)))
+  (define-dot a x y)
+  (define-dot b a z)
+  (test 10 "" b))
+
+(syntax-test #'(let () (package x ()) (define-dot a x c) 1))
+
+;; dot
+(let ()
+  (package x all-defined
+    (define z 10))
+  (test 10 "" (dot x z)))
+(let ()
+  (package x all-defined
+    (package y all-defined
+      (define z 10)))
+  (define-dot a x y)
+  (test 10 "" (dot a z)))
+(syntax-test #'(let () (package x ()) (dot x c)))
+
+
+(define expand-test-use-toplevel? #f)
+
+(report-errs)
diff --git a/collects/tests/mzscheme/parallel.ss b/collects/tests/mzscheme/parallel.ss
new file mode 100644
index 0000000000..b89513f5f9
--- /dev/null
+++ b/collects/tests/mzscheme/parallel.ss
@@ -0,0 +1,72 @@
+
+;; Runs 3 threads perfoming the test suite simultaneously. Each
+;;  thread creates a directory sub<n> to run in, so that filesystem
+;;  tests don't collide.
+
+(with-handlers ([exn:fail?
+		 (lambda (exn)
+		   (namespace-set-variable-value!
+		    'parallel-load
+		    "quiet.ss"))])
+  (namespace-variable-value 'parallel-load))
+
+(define (start x) (x))
+
+;; Uncomment the following expression to have threads start with the
+;;  same continuation, which forces sharing of the Scheme stack:
+#;
+(thread-wait
+ (thread (lambda () ((let/cc k (set! start k) void)))))
+
+; Runs n versions of test in parallel threads and namespaces, 
+; waiting until all are done
+(define (parallel n test)
+  (let ([done (make-semaphore)]
+	[go (make-semaphore)])
+    (let loop ([n n])
+      (unless (zero? n)
+	      (let ([ns (make-namespace)])
+		(thread
+		 (lambda ()
+		   (start
+		    (lambda ()
+		      (parameterize ([current-namespace ns])
+			(namespace-transformer-require 'mzscheme)
+			(let ([dirname (format "sub~s" n)])
+			  (when (directory-exists? dirname)
+			    (delete-directory* dirname))
+			  (make-directory dirname)
+			  (current-directory dirname)
+			  (dynamic-wind
+			      void
+			      (lambda ()
+				(load test))
+			      (lambda ()
+				(semaphore-post done)
+				(semaphore-wait go)
+				(printf "~nThread ~s:" n)
+				(eval '(report-errs))
+				(current-directory (build-path 'up))
+				(delete-directory* dirname)
+				(semaphore-post done)))))))))
+		(loop (sub1 n)))))
+    (let loop ([n n])
+      (unless (zero? n)
+	      (semaphore-wait done)
+	      (loop (sub1 n))))
+    (let loop ([n n])
+      (unless (zero? n)
+	      (semaphore-post go)
+	      (semaphore-wait done)
+	      (loop (sub1 n))))))
+
+(define (delete-directory* dir)
+  (for-each (lambda (f)
+	      (let ([f (build-path dir f)])
+		(if (or (link-exists? f) (file-exists? f))
+		    (delete-file f)
+		    (delete-directory* f))))
+	    (directory-list dir))
+  (delete-directory dir))
+
+(parallel 3 (path->complete-path parallel-load (current-load-relative-directory)))
diff --git a/collects/tests/mzscheme/param.ss b/collects/tests/mzscheme/param.ss
new file mode 100644
index 0000000000..0fc8e5f407
--- /dev/null
+++ b/collects/tests/mzscheme/param.ss
@@ -0,0 +1,469 @@
+
+(load-relative "loadtest.ss")
+
+(SECTION 'parameters)
+
+(let ([p (open-output-file "tmp5" 'replace)])
+  (display (compile '(cons 1 2)) p)
+  (close-output-port p))
+
+(define-struct tester (x) (make-inspector))
+(define a-tester (make-tester 5))
+
+(define (check-write-string display v s)
+  (let ([p (open-output-string)])
+    (display v p)
+    (let ([s2 (get-output-string p)])
+      (or (string=? s s2)
+	  (error 'check-string "strings didn't match: ~s vs. ~s"
+		 s s2)))))
+
+(define exn:check-string? exn:fail?)
+
+(define called-break? #f)
+
+(define erroring-set? #f)
+
+(define erroring-port
+  (make-output-port 'errors
+		    always-evt
+		    (let ([orig (current-output-port)])
+		      (lambda (s start end flush? breakable?) 
+			(if erroring-set?
+			    (begin
+			      (set! erroring-set? #f)
+			      (error 'output))
+			    (display (subbytes s start end) orig))
+			(- end start)))
+		    void))
+
+(define erroring-eval
+  (let ([orig (current-eval)])
+    (lambda (x)
+      (if erroring-set?
+	  (begin
+	    (set! erroring-set? #f)
+	    (error 'eval))
+	  (orig x)))))
+
+(define blocking-thread
+  (lambda (thunk)
+    (let ([x #f])
+      (thread-wait (thread (lambda () (set! x (thunk)))))
+      x)))
+
+(define main-cust (current-custodian))
+
+(define zero-arg-proc (lambda () #t))
+(define one-arg-proc (lambda (x) #t))
+(define two-arg-proc (lambda (x y) #t))
+(define three-arg-proc (lambda (x y z) #t))
+
+(define test-param1 (make-parameter 'one))
+(define test-param2 (make-parameter 
+		     'two
+		     ; generates type error:
+		     (lambda (x) (if (symbol? x)
+				     x
+				     (add1 'x)))))
+(define test-param3 (make-parameter 'three list))
+
+(test 'one test-param1)
+(test 'two test-param2) 
+(test 'three test-param3) 
+
+(test-param2 'other-two)
+(test 'other-two test-param2) 
+(test-param2 'two)
+(test 'two test-param2) 
+(parameterize ([test-param2 'yet-another-two])
+  (test 'yet-another-two test-param2) 
+  (parameterize ([test-param2 'yet-another-two!!])
+    (test 'yet-another-two!! test-param2))
+  (test-param2 'more-two?)
+  (test 'more-two? test-param2) 
+  (parameterize ([test-param2 'yet-another-two!!!])
+    (test 'yet-another-two!!! test-param2)
+    (test-param2 'more-two??)
+    (test 'more-two?? test-param2))
+  (test 'more-two? test-param2))
+(test 'two test-param2) 
+
+(test-param3 'other-three)
+(test '(other-three) test-param3) 
+(test-param3 'three)
+(test '(three) test-param3) 
+(parameterize ([test-param3 'yet-another-three])
+  (test '(yet-another-three) test-param3) 
+  (parameterize ([test-param3 'yet-another-three!!])
+    (test '(yet-another-three!!) test-param3))
+  (test-param3 'more-three?)
+  (test '(more-three?) test-param3) 
+  (parameterize ([test-param3 'yet-another-three!!!])
+    (test '(yet-another-three!!!) test-param3)
+    (test-param3 'more-three??)
+    (test '(more-three??) test-param3))
+  (test '(more-three?) test-param3))
+(test '(three) test-param3) 
+
+(arity-test make-parameter 1 2)
+(err/rt-test (make-parameter 0 zero-arg-proc))
+(err/rt-test (make-parameter 0 two-arg-proc))
+
+(define-struct bad-test (value exn?))
+
+(define params (list
+		(list read-case-sensitive 
+		      (list #f #t) 
+		      '(if (eq? (read (open-input-string "HELLO")) (quote hello))
+			   (void) 
+			   (error (quote hello)))
+		      exn:fail?
+		      #f)
+		(list read-square-bracket-as-paren
+		      (list #t #f)
+		      '(when (symbol? (read (open-input-string "[4]")))
+			     (error 'read))
+		      exn:fail?
+		      #f)
+		(list read-curly-brace-as-paren
+		      (list #t #f)
+		      '(when (symbol? (read (open-input-string "{4}")))
+			     (error 'read))
+		      exn:fail?
+		      #f)
+		(list read-accept-box
+		      (list #t #f)
+		      '(read (open-input-string "#&5"))
+		      exn:fail:read?
+		      #f)
+		(list read-accept-graph
+		      (list #t #f)
+		      '(read (open-input-string "#0=(1 . #0#)"))
+		      exn:fail:read?
+		      #f)
+		(list read-accept-compiled
+		      (list #t #f)
+		      '(let ([p (open-input-file "tmp5")])
+			 (dynamic-wind
+			  void
+			  (lambda () (void (read p)))
+			  (lambda () (close-input-port p))))
+		      exn:fail:read?
+		      #f)
+		(list read-accept-bar-quote
+		      (list #t #f)
+		      '(let ([p (open-input-string "|hello #$ there| x")])
+			 (read p)
+			 (read p))
+		      exn:fail:read?
+		      #f)
+		(list read-accept-dot
+		      (list #t #f)
+		      '(let ([p (open-input-string "(1 . 2)")])
+			 (read p))
+		      exn:fail:read?
+		      #f)
+		(list read-accept-quasiquote
+		      (list #t #f)
+		      '(let ([p (open-input-string "`1")])
+			 (read p)
+			 (read p))
+		      exn:fail:read?
+		      #f)
+		(list read-decimal-as-inexact
+		      (list #f #t)
+		      '(let ([p (open-input-string "1.0")])
+			 (list-ref '(1 2) (read p)))
+		      exn:application:type?
+		      #f)
+		(list print-graph
+		      (list #t #f)
+		      '(check-write-string display (quote (#0=(1 2) . #0#)) "(#0=(1 2) . #0#)")
+		      exn:check-string?
+		      #f)
+		(list print-struct
+		      (list #t #f)
+		      '(check-write-string display a-tester "#(struct:tester 5)")
+		      exn:check-string?
+		      #f)
+		(list print-box
+		      (list #t #f)
+		      '(check-write-string display (box 5) "#&5")
+		      exn:check-string?
+		      #f)
+		(list print-vector-length
+		      (list #t #f)
+		      '(check-write-string write (vector 1 2 2) "#3(1 2)")
+		      exn:check-string?
+		      #f)
+
+		(list current-input-port
+		      (list (make-input-port 'in (lambda (s) (bytes-set! s 0 (char->integer #\x)) 1) #f void)
+			    (make-input-port 'in (lambda (s) (error 'bad)) #f void))
+		      '(read-char)
+		      exn:fail?
+		      '("bad string"))
+		(list current-output-port
+		      (list (current-output-port)
+			    erroring-port)
+		      '(begin 
+			 (set! erroring-set? #t) 
+			 (display 5) 
+			 (set! erroring-set? #f))
+		      exn:fail?
+		      '("bad string"))
+
+#|
+		; Doesn't work since error-test sets the port!
+		(list current-error-port
+		      (list (current-error-port)
+			    erroring-port)
+		      '(begin 
+			 (set! erroring-set? #t) 
+			 ((error-display-handler) "hello")
+			 (set! erroring-set? #f))
+		      exn:fail?
+		      "bad setting")
+|#
+		
+		(list compile-allow-set!-undefined
+		      (list #t #f)
+		      '(eval `(set! ,(gensym) 9))
+		      exn:fail:contract:variable?
+		      #f)
+
+		(list current-namespace
+		      (list (make-namespace)
+			    (make-namespace 'empty))
+		      '(begin 0)
+		      exn:fail:syntax?
+		      '("bad setting"))
+
+		(list error-print-width
+		      (list 10 50)
+		      '(when (< 10 (error-print-width)) (error 'print-width))
+		      exn:fail?
+		      '("bad setting"))
+		(list error-value->string-handler
+		      (list (error-value->string-handler) (lambda (x w) (error 'converter)))
+		      '(format "~e" 10)
+		      exn:fail?
+		      (list "bad setting" zero-arg-proc one-arg-proc three-arg-proc))
+
+		(list current-print
+		      (list (current-print)
+			    (lambda (x) (display "frog")))
+		      `(let ([i (open-input-string "5")]
+			     [o (open-output-string)])
+			 (parameterize ([current-input-port i]
+					[current-output-port o])
+			     (read-eval-print-loop))
+			 (let ([s (get-output-string o)])
+			   (printf "**~a**~n" s)
+			   (unless (char=? #\5 (string-ref s 2))
+				   (error "print:" s))))
+		      exn:fail?
+		      (list "bad setting" zero-arg-proc two-arg-proc))
+
+		(list current-prompt-read
+		      (list (current-prompt-read)
+			    (let ([x #f]) 
+			      (lambda () 
+				(set! x (not x))
+				(if x
+				    '(quote hi)
+				    eof))))
+		      `(let ([i (open-input-string "5")]
+			     [o (open-output-string)])
+			 (parameterize ([current-input-port i]
+					[current-output-port o])
+			     (read-eval-print-loop))
+			 (let ([s (get-output-string o)])
+			   (unless (and (char=? #\> (string-ref s 0))
+					(not (char=? #\h (string-ref s 0))))
+				   (error 'prompt))))
+		      exn:fail?
+		      (list "bad setting" one-arg-proc two-arg-proc))
+
+		(list current-load
+		      (list (current-load) (lambda (f e) (error "This won't do it")))
+		      '(load "tmp5")
+		      exn:fail?
+		      (list "bad setting" zero-arg-proc one-arg-proc))
+		(list current-eval	
+		      (list (current-eval) erroring-eval)
+		      '(begin 
+			 (set! erroring-set? #t) 
+			 (eval 5)
+			 (set! erroring-set? #f))
+		      exn:fail?
+		      (list "bad setting" zero-arg-proc two-arg-proc))
+
+		(list current-load-relative-directory
+		      (list (current-load-relative-directory) 
+			    (build-path (current-load-relative-directory) 'up))
+		      '(load-relative "loadable.ss")
+		      exn:fail:filesystem?
+		      (append (list 0)
+			      (map
+			       (lambda (t)
+				 (make-bad-test t exn:fail:contract?))
+			       (list
+				"definitely a bad path"
+				(string #\a #\nul #\b)
+				"relative"
+				(build-path 'up))))
+		      equal?)
+
+		(list global-port-print-handler
+		      (list write display)
+		      '(let ([s (open-output-string)])
+			 (print "hi" s)
+			 (unless (char=? #\" (string-ref (get-output-string s) 0))
+				 (error 'global-port-print-handler)))
+		      exn:fail?
+		      (list "bad setting" zero-arg-proc one-arg-proc three-arg-proc))
+
+		(list current-custodian
+		      (list main-cust (make-custodian))
+		      '(let ([th (parameterize ([current-custodian main-cust])
+				    (thread (lambda () (sleep 1))))])
+			 (kill-thread th))
+		      exn:application:mismatch?
+		      (list "bad setting"))
+
+		(list exit-handler
+		      (list void (lambda (x) (error 'exit-handler)))
+		      '(exit)
+		      exn:fail?
+		      (list "bad setting" zero-arg-proc two-arg-proc))
+
+		(list test-param1
+		      (list 'one 'bad-one)
+		      '(when (eq? (test-param1) 'bad-one)
+			     (error 'bad-one))
+		      exn:fail?
+		      #f)
+		(list test-param2
+		      (list 'two 'bad-two)
+		      '(when (eq? (test-param2) 'bad-two)
+			     (error 'bad-two))
+		      exn:fail?
+		      '("bad string"))))
+
+(for-each
+ (lambda (d)
+   (let ([param (car d)]
+	 [alt1 (caadr d)]
+	 [alt2 (cadadr d)]
+	 [expr (caddr d)]
+	 [exn? (cadddr d)])
+     (parameterize ([param alt1])
+	  (test (void) void (teval expr)))
+     (parameterize ([param alt2])
+	  (error-test (datum->syntax-object #f expr #f) exn?))))
+ params)
+
+(define test-param3 (make-parameter 'hi))
+(test 'hi test-param3)
+(test 'hi 'thread-param
+      (let ([v #f])
+	(thread-wait (thread
+		      (lambda ()
+			(set! v (test-param3)))))
+	v))
+(test (void) test-param3 'bye)
+(test 'bye test-param3)
+(test 'bye 'thread-param
+      (let* ([v #f]
+	     [r (make-semaphore)]
+	     [s (make-semaphore)]
+	     [t (thread
+		 (lambda ()
+		   (semaphore-post r)
+		   (semaphore-wait s)
+		   (set! v (test-param3))))])
+	(semaphore-wait r)
+	(test-param3 'bye-again)
+	(semaphore-post s)
+	(thread-wait t)
+	v))
+(test 'bye-again test-param3)
+
+(test #f parameter? add1)
+
+(for-each
+ (lambda (d)
+   (let* ([param (car d)]
+	  [alt1 (caadr d)]
+	  [bads (cadddr (cdr d))])
+     (test #t parameter? param)
+     (arity-test param 0 1)
+     (when bads
+	   (for-each
+	    (lambda (bad)
+	      (let-values ([(bad exn?)
+			    (if (bad-test? bad)
+				(values (bad-test-value bad)
+					(bad-test-exn? bad))
+				(values bad
+					exn:application:type?))])
+		(err/rt-test (param bad) exn?)))
+	    bads))))
+ params)
+
+(test #t parameter-procedure=? read-accept-compiled read-accept-compiled)
+(test #f parameter-procedure=? read-accept-compiled read-case-sensitive)
+(err/rt-test (parameter-procedure=? read-accept-compiled 5))
+(err/rt-test (parameter-procedure=? 5 read-accept-compiled))
+(arity-test parameter-procedure=? 2 2)
+(arity-test parameter? 1 1)
+
+;; ----------------------------------------
+
+(let ([ch (make-channel)]
+      [k-ch (make-channel)]
+      [p1 (make-parameter 1)]
+      [p2 (make-parameter 2)])
+  (parameterize ([p1 0])
+    (thread (lambda ()
+	      (channel-put ch (cons (p1) (p2))))))
+  (test '(0 . 2) channel-get ch)
+
+  (let ([send-k
+	 (lambda ()
+	   (parameterize ([p1 0])
+	     (thread (lambda ()
+		       (let/ec esc
+			 (channel-put ch
+				      ((let/cc k
+					 (channel-put k-ch k)
+					 (esc)))))))))])
+    (send-k)
+    (thread (lambda () ((channel-get k-ch) (let ([v (p1)]) (lambda () v)))))
+    (test 1 channel-get ch)
+    (send-k)
+    (thread (lambda () ((channel-get k-ch) p1)))
+    (test 0 channel-get ch))
+
+  (let ([send-k-param-in-thread
+	 (lambda ()
+	   (thread (lambda ()
+		     (parameterize ([p1 3])
+		       (let/ec esc
+			 (channel-put ch
+				      ((let/cc k
+					 (channel-put k-ch k)
+					 (esc)))))))))])
+    (send-k-param-in-thread)
+    (thread (lambda () ((channel-get k-ch) (let ([v (p1)]) (lambda () v)))))
+    (test 1 channel-get ch)
+    (send-k-param-in-thread)
+    (thread (lambda () ((channel-get k-ch) p1)))
+    (test 3 channel-get ch)))
+
+; Test current-library-collection-paths?
+; Test require-library-use-compiled?
+
+(report-errs)
diff --git a/collects/tests/mzscheme/path.ss b/collects/tests/mzscheme/path.ss
new file mode 100644
index 0000000000..edc360e6c1
--- /dev/null
+++ b/collects/tests/mzscheme/path.ss
@@ -0,0 +1,399 @@
+
+(load-relative "loadtest.ss")
+
+(SECTION 'PATH)
+
+(define (make-/tf p exn?)
+  (lambda args
+    (with-handlers ([exn? (lambda (x) #f)]
+		    [void (lambda (x) 'wrong-exn)])
+      (if (void? (apply p args))
+	  #t
+	  'not-void))))
+(define delete-file/tf (lambda (x) ((make-/tf delete-file exn:fail:filesystem?) x)))
+(define delete-directory/tf (lambda (x) ((make-/tf delete-directory exn:fail:filesystem?) x)))
+(define rename-file-or-directory/tf (lambda (x y) ((make-/tf rename-file-or-directory exn:fail:filesystem?) x y)))
+(define make-directory/tf (lambda (x) ((make-/tf make-directory exn:fail:filesystem?) x)))
+(define copy-file/tf (lambda (x y) ((make-/tf copy-file exn:fail:filesystem?) x y)))
+
+(test #f relative-path? (current-directory))
+(test #t relative-path? "down")
+(test #t relative-path? (build-path 'up "down"))
+(test #t relative-path? (build-path 'same "down"))
+(test #t relative-path? (build-path 'same "down" "deep"))
+(test #f relative-path? (build-path (current-directory) 'up "down"))
+(test #f relative-path? (build-path (current-directory) 'same "down"))
+(test #f relative-path? (build-path (current-directory) 'same "down" "deep"))
+(test #f relative-path? (string #\a #\nul #\b))
+
+(arity-test relative-path? 1 1)
+(err/rt-test (relative-path? 'a))
+
+(test #t absolute-path? (current-directory))
+(test #f absolute-path? (build-path 'up))
+(test #f absolute-path? (string #\a #\nul #\b))
+
+(arity-test absolute-path? 1 1)
+(err/rt-test (absolute-path? 'a))
+
+(test #t complete-path? (current-directory))
+(test #f complete-path? (build-path 'up))
+(test #f complete-path? (string #\a #\nul #\b))
+
+(arity-test complete-path? 1 1)
+(err/rt-test (complete-path? 'a))
+
+(call-with-output-file "tmp6" void 'replace)
+(define existant "tmp6")
+
+(test #t file-exists? existant)
+
+(define deepdir (build-path "down" "deep"))
+
+(when (directory-exists? deepdir) 
+  (for-each delete-file (directory-list deepdir))
+  (delete-directory deepdir))
+(when (directory-exists? "down")
+  (for-each delete-file (directory-list "down"))
+  (delete-directory "down"))
+  
+(test #t make-directory/tf "down")
+(test #f make-directory/tf "down")
+(test #t directory-exists? "down")
+(test #f file-exists? "down")
+
+(test #t make-directory/tf deepdir)
+(test #f make-directory/tf deepdir)
+(test #t directory-exists? deepdir)
+(test #f file-exists? deepdir)
+
+(test #t file-exists? (build-path "down" 'up existant))
+(test #t file-exists? (build-path deepdir 'up 'up existant))
+(test #t file-exists? (build-path 'same deepdir 'same 'up 'same 'up existant))
+
+(test #f file-exists? (build-path "down" existant))
+(test #f file-exists? (build-path deepdir 'up existant))
+(test #f file-exists? (build-path 'same deepdir 'same 'same 'up existant))
+
+(delete-file "tmp6")
+
+(test #f file-exists? (build-path "down" 'up "badfile"))
+(test #f file-exists? (build-path deepdir 'up 'up "badfile"))
+(test #f file-exists? (build-path 'same deepdir 'same 'up 'same 'up "badfile"))
+
+(err/rt-test (open-output-file (build-path "wrong" "down" "tmp8"))
+	    exn:fail:filesystem?)
+(err/rt-test (open-output-file (build-path deepdir "wrong" "tmp7"))
+	    exn:fail:filesystem?)
+
+(define start-time (current-seconds))
+(let ([p (open-output-file "tmp5" 'replace)])
+  (display "123456789" p)
+  (close-output-port p))
+(close-output-port (open-output-file (build-path "down" "tmp8") 'replace))
+(close-output-port (open-output-file (build-path deepdir "tmp7") 'replace))
+(define end-time (current-seconds))
+
+(map
+ (lambda (f)
+   (let ([time (seconds->date (file-or-directory-modify-seconds f))]
+	 [start (seconds->date start-time)]
+	 [end (seconds->date end-time)])
+     (test #t = (date-year start) (date-year time) (date-year end))
+     (test #t = (date-month start) (date-month time) (date-month end))
+     (test #t = (date-day start) (date-day time) (date-day end))
+     (test #t = (date-week-day start) (date-week-day time) (date-week-day end))
+     (test #t = (date-year-day start) (date-year-day time) (date-year-day end))
+     (test #t = (date-hour start) (date-hour time) (date-hour end))
+     (test #t <= (date-minute start) (date-minute time) (date-minute end))
+     (test #t <= (- (date-second start) 5) (date-second time) (+ (date-second end) 5))))
+ (list "tmp5"
+       "down"
+       (build-path "down" "tmp8")
+       (build-path deepdir "tmp7")))
+
+(test 'no-exists 'no-file-for-seconds (with-handlers ([void (lambda (x) 'no-exists)]) (file-or-directory-modify-seconds "non-existent-file")))
+(map
+ (lambda (f)
+   (test #t number? (file-or-directory-modify-seconds f)))
+ (filesystem-root-list))
+
+(test #t file-exists? "tmp5")
+(test #t file-exists? (build-path "down" "tmp8"))
+(test #t file-exists? (build-path deepdir "tmp7"))
+
+(test #t copy-file/tf "tmp5" "tmp5y")
+(test #f copy-file/tf "tmp5" "tmp5y")
+(test #f copy-file/tf "tmp5" "down")
+(test #f copy-file/tf "tmp5" (build-path deepdir "moredeep" "tmp5y"))
+(test (file-size "tmp5") file-size "tmp5y")
+(delete-file "tmp5y")
+
+(test #t rename-file-or-directory/tf "tmp5" "tmp5x")
+(test #f rename-file-or-directory/tf "tmp5" "tmp5x")
+(close-output-port (open-output-file "tmp5"))
+(test #t file-exists? "tmp5")
+(test #t file-exists? "tmp5x")
+(test #f rename-file-or-directory/tf "tmp5" "tmp5x")
+(test #f rename-file-or-directory/tf "tmp5" "down")
+(delete-file "tmp5")
+(test #f file-exists? "tmp5")
+(test #t rename-file-or-directory/tf (build-path "down" "tmp8") (build-path "down" "tmp8x"))
+(test #f rename-file-or-directory/tf (build-path "down" "tmp8") (build-path "down" "tmp8x"))
+(test #t rename-file-or-directory/tf (build-path deepdir "tmp7") (build-path deepdir "tmp7x"))
+(test #f rename-file-or-directory/tf (build-path deepdir "tmp7") (build-path deepdir "tmp7x"))
+
+(test #t make-directory/tf "downx")
+(test #f rename-file-or-directory/tf "down" "downx")
+(test #t delete-directory/tf "downx")
+
+(test #t rename-file-or-directory/tf "down" "downx")
+(test #t directory-exists? "downx")
+(test #f directory-exists? "down")
+(test #t file-exists? (build-path "downx" "tmp8x"))
+(test #f file-exists? (build-path "down" "tmp8x"))
+(test #f rename-file-or-directory/tf "down" "downx")
+(test #t rename-file-or-directory/tf "downx" "down")
+(test #t file-exists? (build-path "down" "tmp8x"))
+
+(test #t rename-file-or-directory/tf (build-path deepdir "tmp7x") "tmp7x")
+(test #f rename-file-or-directory/tf (build-path deepdir "tmp7x") "tmp7x")
+(test #t rename-file-or-directory/tf "tmp7x" (build-path deepdir "tmp7x"))
+(test #f rename-file-or-directory/tf "tmp7x" (build-path deepdir "tmp7x"))
+
+(test #f not (member (bytes->path #"tmp5x") (directory-list)))
+(test #t 'directory-list 
+      (let ([l (directory-list "down")])
+	(or (equal? l (map bytes->path '(#"deep" #"tmp8x")))
+	    (equal? l (map bytes->path '(#"tmp8x" #"deep"))))))
+(test (list (bytes->path #"tmp7x")) directory-list deepdir)
+
+(test #f delete-directory/tf deepdir)
+(test #f delete-directory/tf "down")
+
+(test #t delete-file/tf (build-path deepdir "tmp7x"))
+(test #f delete-file/tf (build-path deepdir "tmp7x"))
+(test #t delete-file/tf (build-path "down" "tmp8x"))
+(test #f delete-file/tf (build-path "down" "tmp8x"))
+(test #t delete-file/tf "tmp5x")
+(test #f delete-file/tf "tmp5x")
+
+(test #f delete-directory/tf "down")
+(test #t delete-directory/tf deepdir)
+(test #f delete-directory/tf deepdir)
+(test #t delete-directory/tf "down")
+(test #f delete-directory/tf "down")
+
+; Redefine these per-platform
+(define drives null)
+(define nondrive-roots (list "/"))
+(define -a (list "a"))
+(define a/b (list "a/b" "a//b"))
+(define a/b/c (list "a/b/c" "a//b/c"))
+(define /a/b (list "/a/b"))
+(define a/../b (list "a/../b"))
+(define a/./b (list "a/./b"))
+(define a/../../b (list "a/../../b"))
+(define trail-sep "/")
+
+(define add-slashes
+  (lambda (l)
+    (if (null? l)
+	null
+	(let loop ([s (car l)][rest (add-slashes (cdr l))])
+	  (let ([naya (regexp-replace "/" s "\\")])
+	    (if (string=? naya s)
+		(cons s rest)
+		(loop naya (cons s rest))))))))
+
+(when (eq? (system-type) 'windows)
+      (set! drives (list "c:" "c:/" "//hello/start" "//hello/start/"))
+      (set! nondrive-roots null)
+      (for-each
+       (lambda (var)
+	 (eval `(set! ,var (add-slashes ,var))))
+       '(-a a/b a/b/c /a/b a/../b a/./b a/../../b)))
+
+
+(when (eq? (system-type) 'macos)
+      (set! drives null)
+      (set! nondrive-roots (filesystem-root-list))
+      (set! -a (list ":a"))
+	  (set! a/b (list ":a:b"))
+	  (set! a/b/c (list ":a:b:c"))
+      (set! /a/b (list "a:b"))
+      (set! a/../b (list ":a::b"))
+      (set! a/./b null)
+	  (set! a/../../b (list ":a:::b"))
+	  (set! trail-sep ":"))
+
+(define roots (append drives nondrive-roots))
+
+(define a/ (map (lambda (s) (string-append s trail-sep)) -a))
+(define a/b/ (map (lambda (s) (string-append s trail-sep)) a/b))
+(define a/b/c/ (map (lambda (s) (string-append s trail-sep)) a/b/c))
+(define /a/b/ (map (lambda (s) (string-append s trail-sep)) /a/b))
+
+(define absols (append roots /a/b /a/b/))
+(define nondrive-absols (append nondrive-roots /a/b /a/b/))
+(define rels (append -a a/ a/b a/b/ a/b/c a/b/c/ a/../b a/./b a/../../b))
+
+(define i (lambda (x) x))
+
+(test #f ormap i (map relative-path? roots))
+(test #t andmap i (map relative-path? a/b))
+(test #f ormap i (map relative-path? /a/b))
+
+(test #t andmap i (map absolute-path? roots))
+(test #f ormap i (map absolute-path? a/b))
+
+(test #t andmap i (map complete-path? drives))
+(test #t andmap i (map complete-path? nondrive-roots))
+(test #f ormap i (map complete-path? a/b))
+
+(for-each
+ (lambda (abs)
+   (for-each
+    (lambda (rel)
+      (test #t path? (build-path abs rel))
+      (for-each
+       (lambda (rel2)
+	 (test #t path? (build-path abs rel rel2)))
+       rels))
+    rels))
+ absols)
+
+(for-each
+ (lambda (drive)
+   (for-each
+    (lambda (root)
+      (test #t path? (build-path drive root))
+      (for-each
+       (lambda (rel)
+	 (test #t path? (build-path drive root rel)))
+       rels))
+    nondrive-absols))
+ drives)
+
+(for-each
+ (lambda (rel)
+   (test (build-path (current-directory) rel)
+	 path->complete-path rel))
+ rels)
+
+(define (test-path expect f . args)
+  (test (normal-case-path (expand-path expect))
+	(or (object-name f) 'unknown)
+	(normal-case-path (expand-path (apply f args)))))
+
+(for-each
+ (lambda (absol)
+   (let ([cabsol (path->complete-path absol)])
+     (for-each
+      (lambda (rel)
+	(test-path (build-path cabsol rel) path->complete-path rel cabsol)
+	(test-path (build-path cabsol rel rel) path->complete-path rel (build-path cabsol rel))
+	(err/rt-test (path->complete-path rel rel) exn:fail:contract?))
+      rels)))
+ absols)
+
+(for-each
+ (lambda (drive)
+   (for-each
+    (lambda (rel)
+      (unless (relative-path? rel)
+	      (test-path (build-path (current-drive) rel)
+			 path->complete-path rel))
+      (test-path (build-path drive rel) path->complete-path rel drive)
+      (test-path (if (relative-path? rel)
+		     (build-path drive rel rel)
+		     (build-path drive rel))
+		 path->complete-path rel (build-path drive rel)))
+    (append rels nondrive-absols)))
+ drives)
+
+(for-each
+ (lambda (drive)
+   (test (string->path drive) path->complete-path drive)
+   (test (string->path drive) path->complete-path drive drive))
+ drives)
+
+(unless (eq? (system-type) 'macos)
+ (for-each
+  (lambda (abs1)
+    (for-each
+     (lambda (abs2)
+       (err/rt-test (build-path abs1 abs2) exn:fail:contract?))
+     absols))
+  nondrive-roots))
+
+(for-each
+ (lambda (root)
+   (let-values ([(base name dir?) (split-path root)])
+     (when (eq? (system-type) 'macos)
+       (test root 'split-path name))
+     (test #f 'split-path base)
+     (test #t 'split-path dir?)))
+ roots)
+
+(let ([check-a/b
+       (lambda (a/b end/?)
+	 (for-each
+	  (lambda (path)
+	    (let*-values ([(base name dir?) (split-path path)]
+			  [(base2 name2 dir?2) (split-path base)])
+	       (test #"b" subbytes (path->bytes name) 0 1)
+	       (test end/? 'split-path dir?)
+	       (test #"a" subbytes (path->bytes name2) 0 1)
+	       (test 'relative 'split-path base2)
+	       (test #t 'split-path dir?2)
+	       (for-each 
+		(lambda (root)
+		  (let ([bigpath (build-path root path)])
+		    (let*-values ([(base name dir?) (split-path bigpath)]
+				  [(base2 name2 dir?2) (split-path base)]
+				  [(base3 name3 dir?3) (split-path base2)])
+		       (test #f 'split-path base3)
+		       (test #t 'split-path dir?3))))
+		roots)))
+	  a/b))])
+  (check-a/b a/b #f)
+  (check-a/b a/b/ #t))
+
+(arity-test split-path 1 1)
+
+(arity-test path->complete-path 1 2)
+(err/rt-test (path->complete-path 1))
+(err/rt-test (path->complete-path "a" 1))
+
+(test-path (build-path "a" "b") simplify-path (build-path "a" "b"))
+(let ([full-path
+       (lambda args (apply build-path (current-directory) args))])
+  (unless (equal? (build-path "a" "b") (build-path "a" 'same "b"))
+    (test-path (full-path "a" "b") simplify-path (build-path "a" 'same "b")))
+  (test-path (full-path "a" "b") simplify-path (build-path "a" 'same "noexistsdir" 'up "b"))
+  (test-path (full-path "a" "b") simplify-path (build-path "a" 'same "noexistsdir" 'same 'up "b" 'same 'same))
+  (test-path (full-path "a" "b") simplify-path (build-path 'same "noexistsdir" 'same 'up "a" 'same "b" 'same 'same)))
+(arity-test simplify-path 1 1)
+
+(arity-test expand-path 1 1)
+(arity-test resolve-path 1 1)
+
+(map
+ (lambda (f)
+   (err/rt-test (f (string #\a #\nul #\b)) exn:fail:contract?))
+ (list build-path split-path file-exists? directory-exists?
+       delete-file directory-list make-directory delete-directory
+       file-or-directory-modify-seconds file-or-directory-permissions 
+       expand-path resolve-path simplify-path path->complete-path
+       open-input-file open-output-file))
+(map 
+ (lambda (f)
+   (err/rt-test (f (string #\a #\nul #\b) "a") exn:fail:contract?)
+   (err/rt-test (f "a" (string #\a #\nul #\b)) exn:fail:contract?))
+ (list rename-file-or-directory path->complete-path))
+
+; normal-case-path now checks for pathness:
+(err/rt-test (normal-case-path (string #\a #\nul #\b)))
+
+(report-errs)
diff --git a/collects/tests/mzscheme/pconvert.ss b/collects/tests/mzscheme/pconvert.ss
new file mode 100644
index 0000000000..129b23963c
--- /dev/null
+++ b/collects/tests/mzscheme/pconvert.ss
@@ -0,0 +1,415 @@
+
+(load-relative "loadtest.ss")
+
+(SECTION 'pconvert)
+
+(require (lib "unit.ss")
+         (lib "file.ss")
+         (lib "class.ss")
+         (lib "pconvert.ss"))
+
+(constructor-style-printing #t)
+(quasi-read-style-printing #f)
+
+(define (xl) 1)
+(define (xu) (unit (import) (export)))
+(define (xc) (class object% () (sequence (super-init))))
+
+(let ()
+  (define-struct pctest (value constructor-sexp
+                               whole/frac-constructor-sexp
+                               shared-constructor-sexp
+                               quasi-sexp
+                               whole/frac-quasi-sexp
+                               shared-quasi-sexp
+                               cons-as-list))
+  
+  (define-struct no-cons-test (value constructor-sexp shared-constructor-sexp
+                                     quasi-sexp shared-quasi-sexp))
+  (define-struct same-test (value sexp))
+  (define get-value
+    (lambda (test-case)
+      (cond
+        [(pctest? test-case)
+         (pctest-value test-case)]
+        [(no-cons-test? test-case)
+         (no-cons-test-value test-case)]
+        [(same-test? test-case)
+         (same-test-value test-case)])))
+  (define run-test
+    (lambda (test-case)
+      (let* ([before (get-value test-case)]
+             [cmp
+              (lambda (selector constructor-style?
+                                quasi-read?
+                                sharing?
+                                cons-as-list?
+                                whole/fractional-numbers?)
+                (unless (parameterize ([constructor-style-printing constructor-style?]
+                                       [show-sharing sharing?]
+                                       [quasi-read-style-printing quasi-read?]
+                                       [abbreviate-cons-as-list cons-as-list?]
+                                       [whole/fractional-exact-numbers whole/fractional-numbers?])
+                          (test (selector test-case) print-convert before))
+                  (printf
+                   ">> (constructor-style-printing ~a) (quasi-read-style-printing ~a) (show-sharing ~a) (abbreviate-cons-as-list ~a) (whole/fractional-exact-numbers ~a)~n"
+                   constructor-style? quasi-read? 
+                   sharing? cons-as-list?
+                   whole/fractional-numbers?)))])
+        ;(printf "testing: ~s~n" before)
+        ;(printf ".") (flush-output (current-output-port))
+        (cond
+          [(pctest? test-case)
+           (cmp pctest-constructor-sexp #t #f #f #t #f)
+           (cmp pctest-whole/frac-constructor-sexp #t #f #f #t #t)
+           (cmp pctest-shared-constructor-sexp #t #f #t #t #f)
+           (cmp pctest-quasi-sexp #f #f #f #t #f)
+           (cmp pctest-whole/frac-quasi-sexp #f #f #f #t #t)
+           (cmp pctest-shared-quasi-sexp #f #f #t #t #f)
+           (cmp pctest-cons-as-list #t #f #f #f #f)]
+          [(no-cons-test? test-case)
+           (cmp no-cons-test-shared-constructor-sexp #t #f #t #t #t)
+           (cmp no-cons-test-constructor-sexp #t #f #f #t #t)
+           (cmp no-cons-test-shared-quasi-sexp #f #f #t #t #t)
+           (cmp no-cons-test-quasi-sexp #f #f #f #t #t)]
+          [(same-test? test-case)
+           (cmp same-test-sexp #t #t #t #t #t)
+           (cmp same-test-sexp #t #t #t #t #f)
+           (cmp same-test-sexp #t #t #t #f #t)
+           (cmp same-test-sexp #t #t #t #f #f)
+           (cmp same-test-sexp #t #t #f #t #t)
+           (cmp same-test-sexp #t #t #f #t #f)
+           (cmp same-test-sexp #t #t #f #f #t)
+           (cmp same-test-sexp #t #t #f #f #f)
+           
+           (cmp same-test-sexp #t #f #t #t #t)
+           (cmp same-test-sexp #t #f #t #t #f)
+           (cmp same-test-sexp #t #f #t #f #t)
+           (cmp same-test-sexp #t #f #t #f #f)
+           (cmp same-test-sexp #t #f #f #t #t)
+           (cmp same-test-sexp #t #f #f #t #f)
+           (cmp same-test-sexp #t #f #f #f #t)
+           (cmp same-test-sexp #t #f #f #f #f)
+           
+           (cmp same-test-sexp #f #t #t #t #t)
+           (cmp same-test-sexp #f #t #t #t #f)
+           (cmp same-test-sexp #f #t #t #f #t)
+           (cmp same-test-sexp #f #t #t #f #f)
+           (cmp same-test-sexp #f #t #f #t #t)
+           (cmp same-test-sexp #f #t #f #t #f)
+           (cmp same-test-sexp #f #t #f #f #t)
+           (cmp same-test-sexp #f #t #f #f #f)
+           
+           (cmp same-test-sexp #f #f #t #t #t)
+           (cmp same-test-sexp #f #f #t #t #f)
+           (cmp same-test-sexp #f #f #t #f #t)
+           (cmp same-test-sexp #f #f #t #f #f)
+           (cmp same-test-sexp #f #f #f #t #t)
+           (cmp same-test-sexp #f #f #f #t #f)
+           (cmp same-test-sexp #f #f #f #f #t)
+           (cmp same-test-sexp #f #f #f #f #f)]))))
+  
+  (define 
+    tests
+    (list
+     (make-same-test "abc" "abc")
+     (make-same-test 'a ''a)
+     
+     (make-same-test 8 8)
+     (make-same-test 1/2 1/2)
+     (make-same-test 1.1 1.1)
+     
+     (make-pctest -10/3 -10/3 '(+ -3 -1/3) -10/3 -10/3 '(+ -3 -1/3) -10/3 -10/3)
+     (make-pctest 3/2 3/2 '(+ 1 1/2) 3/2 3/2 '(+ 1 1/2) 3/2 3/2)
+     
+     (make-pctest (list 1) '(list 1) '(list 1) '(list 1) '`(1) '`(1) '`(1) '(cons 1 empty))
+     (make-pctest (list 1/2) '(list 1/2) '(list 1/2) '(list 1/2)
+                  '`(1/2) '`(1/2)  '`(1/2)
+                  '(cons 1/2 empty))
+     (make-pctest (list 3/2) '(list 3/2) '(list (+ 1 1/2)) '(list 3/2)
+                  '`(3/2) '`(,(+ 1 1/2)) '`(3/2)
+                  '(cons 3/2 empty))
+     (make-pctest (list 1/2+1/2i) 
+                  '(list 1/2+1/2i) 
+                  '(list (+ 1/2 (* 0+1i 1/2))) 
+                  '(list 1/2+1/2i)
+                  '`(1/2+1/2i) 
+                  '`(,(+ 1/2 (* 0+1i 1/2)))  
+                  '`(1/2+1/2i)
+                  '(cons 1/2+1/2i empty))
+     (make-pctest (list 3/2+1/2i) 
+                  '(list 3/2+1/2i) 
+                  '(list (+ (+ 1 1/2) (* 0+1i 1/2))) 
+                  '(list 3/2+1/2i)
+                  '`(3/2+1/2i) 
+                  '`(,(+ (+ 1 1/2) (* 0+1i 1/2)))  
+                  '`(3/2+1/2i)
+                  '(cons 3/2+1/2i empty))
+     (make-pctest (list 1/2+3/2i) 
+                  '(list 1/2+3/2i) 
+                  '(list (+ 1/2 (* 0+1i (+ 1 1/2)))) 
+                  '(list 1/2+3/2i)
+                  '`(1/2+3/2i) 
+                  '`(,(+ 1/2 (* 0+1i (+ 1 1/2))))  
+                  '`(1/2+3/2i)
+                  '(cons 1/2+3/2i empty))
+     (make-pctest (list 3/2+3/2i) 
+                  '(list 3/2+3/2i) 
+                  '(list (+ (+ 1 1/2) (* 0+1i (+ 1 1/2)))) 
+                  '(list 3/2+3/2i)
+                  '`(3/2+3/2i) 
+                  '`(,(+ (+ 1 1/2) (* 0+1i (+ 1 1/2))))  
+                  '`(3/2+3/2i)
+                  '(cons 3/2+3/2i empty))
+     
+     (make-same-test (vector 0 0 0 0 0 0 0 0 0 0) '(vector 0 0 0 0 0 0 0 0 0 0))
+     (make-same-test #t 'true)
+     (make-same-test #f 'false)
+     
+     (make-same-test (interface () a b c) '(interface ...))
+     
+     (make-same-test (delay 1) '(delay ...))
+     (make-same-test (let () (define-struct a (a) (make-inspector)) (make-a 3)) '(make-a 3))
+     (make-same-test (box 3) '(box 3))
+     (make-pctest null 'empty 'empty 'empty '`() '`() '`() 'empty)
+     (make-same-test add1 'add1)
+     (make-same-test (void) '(void))
+     (make-same-test (unit (import) (export)) '(unit ...))
+     (make-same-test (make-weak-box 12) '(make-weak-box 12))
+     (make-same-test (regexp "1") '(regexp "1"))
+     (make-same-test (module-path-index-join #f #f) '(module-path-index-join false false))
+     (make-same-test (lambda () 0) '(lambda () ...))
+
+     (make-same-test xl 'xl)
+     (make-same-test (letrec ([xl (lambda () 1)]) xl) '(lambda () ...))
+     (make-same-test (letrec ([xl-ID-BETTER-NOT-BE-DEFINED (lambda () 1)]) 
+                       xl-ID-BETTER-NOT-BE-DEFINED)
+                     '(lambda () ...))
+     (make-same-test xc 'xc)
+     (make-same-test (letrec ([xc (class object% ())]) xc) '(class ...))
+     (make-same-test (letrec ([xc-ID-BETTER-NOT-BE-DEFINED (class object% ())]) 
+                       xc-ID-BETTER-NOT-BE-DEFINED)
+                     '(class ...))
+     (make-same-test xu 'xu)
+     (make-same-test (letrec ([xu (unit (import) (export))]) xu)
+                     '(unit ...))
+     (make-same-test (letrec ([xu-ID-BETTER-NOT-BE-DEFINED (unit (import) (export))]) 
+                       xu-ID-BETTER-NOT-BE-DEFINED)
+                     '(unit ...))
+     (make-same-test (lambda (x) x) '(lambda (a1) ...))
+     (make-same-test (lambda x x) '(lambda args ...))
+     (make-same-test (lambda (a b . c) a) '(lambda (a1 a2 . args) ...))
+     (make-same-test (case-lambda) '(case-lambda))
+     (make-same-test (case-lambda [() 'a] [(x) 'a]) '(case-lambda [() ...] [(a1) ...]))
+     (make-same-test (case-lambda [() 'a] [(x y) 'a])
+                     '(case-lambda [() ...] [(a1 a2) ...]))
+     (make-same-test (case-lambda [() 'a] [(x . y) 'a])
+                     '(case-lambda [() ...] [(a1 . args) ...]))
+     (make-same-test (case-lambda [() 'a] [x 'a])
+                     '(case-lambda [() ...] [args ...]))
+     (make-same-test (case-lambda [() 'a] [(x y z) 'a] [x 'a])
+                     '(case-lambda [() ...] [(a1 a2 a3) ...] [args ...]))
+     (make-same-test (make-hash-table)
+                     '(hash-table))
+     (make-same-test (make-hash-table 'weak)
+                     '(hash-table 'weak))
+     (make-same-test (make-hash-table 'equal)
+                     '(hash-table 'equal))
+     (make-same-test (make-hash-table 'equal 'weak)
+                     '(hash-table 'equal 'weak))
+     (make-same-test (let ([ht (make-hash-table)])
+                       (hash-table-put! ht 'x 1)
+                       ht)
+                     '(hash-table ('x 1)))
+     (make-pctest (list 'a (box (list ())) (cons 1 '()))
+                  '(list (quote a) (box (list empty)) (list 1))
+                  '(list (quote a) (box (list empty)) (list 1))
+                  '(list (quote a) (box (list empty)) (list 1))
+                  '`(a ,(box `(())) (1))
+                  '`(a ,(box `(())) (1))
+                  '`(a ,(box `(())) (1))
+                  '(cons 'a 
+                         (cons (box (cons empty empty))
+                               (cons (cons 1 empty)
+                                     empty))))
+     (make-pctest (list "" "" (vector) (vector))
+                  '(list "" "" (vector) (vector))
+                  '(list "" "" (vector) (vector))
+                  '(list "" "" (vector) (vector))
+                  '`("" "" ,(vector) ,(vector))
+                  '`("" "" ,(vector) ,(vector))
+                  '`("" "" ,(vector) ,(vector))
+                  '(cons "" (cons "" (cons (vector) (cons (vector) empty)))))
+     (make-pctest (let ([x (list 1)]) (set-car! x x) x)
+                  '(shared ([-0- (list -0-)]) -0-)
+                  '(shared ([-0- (list -0-)]) -0-)
+                  '(shared ([-0- (list -0-)]) -0-)
+                  '(shared ([-0- `(,-0-)]) -0-)
+                  '(shared ([-0- `(,-0-)]) -0-)
+                  '(shared ([-0- `(,-0-)]) -0-)
+                  '(shared ([-0- (cons -0- empty)]) -0-))
+     (make-pctest (let ([x (list 1)]) (set-cdr! x x) x)
+                  '(shared ([-0- (cons 1 -0-)]) -0-)
+                  '(shared ([-0- (cons 1 -0-)]) -0-)
+                  '(shared ([-0- (cons 1 -0-)]) -0-)
+                  '(shared ([-0- `(1 . ,-0-)]) -0-)
+                  '(shared ([-0- `(1 . ,-0-)]) -0-)
+                  '(shared ([-0- `(1 . ,-0-)]) -0-)
+                  '(shared ([-0- (cons 1 -0-)]) -0-))
+     (make-pctest (let* ([a (list 1 2 3)]
+                         [b (list 1 a (cdr a))])
+                    (set-car! b b)
+                    (append b (list (list 2 3))))
+                  '(shared ([-1- (list -1- (list 1 2 3) (list 2 3))])
+                     (list -1- (list 1 2 3) (list 2 3) (list 2 3)))
+                  '(shared ([-1- (list -1- (list 1 2 3) (list 2 3))])
+                     (list -1- (list 1 2 3) (list 2 3) (list 2 3)))
+                  '(shared ([-1- (list -1- -3- -4-)]
+                            [-3- (cons 1 -4-)]
+                            [-4- (list 2 3)])
+                     (list -1- -3- -4- (list 2 3)))
+                  '(shared ([-1- `(,-1- (1 2 3) (2 3))])
+                     `(,-1- (1 2 3) (2 3) (2 3)))
+                  '(shared ([-1- `(,-1- (1 2 3) (2 3))])
+                     `(,-1- (1 2 3) (2 3) (2 3)))
+                  '(shared ([-1- `(,-1- ,-3- ,-4-)]
+                            [-3- `(1 . ,-4-)]
+                            [-4- `(2 3)])
+                     `(,-1- ,-3- ,-4- (2 3)))
+                  '(shared ([-1- (cons -1- 
+                                       (cons (cons 1 (cons 2 (cons 3 empty)))
+                                             (cons (cons 2 (cons 3 empty))
+                                                   empty)))])
+                     (cons -1- 
+                           (cons (cons 1 (cons 2 (cons 3 empty)))
+                                 (cons (cons 2 (cons 3 empty)) 
+                                       (cons (cons 2 (cons 3 empty))
+                                             empty))))))
+     (make-no-cons-test (let* ([a (list 1 2 3)]
+                               [b (list 1 a (cdr a))])
+                          (set-car! b b)
+                          (let* ([share-list (append b (list (list 2 3)))]
+                                 [v (vector 1 share-list (cdr share-list))])
+                            (vector-set! v 0 v)
+                            v))
+                        '(shared
+                             ((-0- (vector -0-
+                                           (list -2-
+                                                 (list 1 2 3)
+                                                 (list 2 3)
+                                                 (list 2 3))
+                                           (list (list 1 2 3)
+                                                 (list 2 3)
+                                                 (list 2 3))))
+                              (-2- (list -2- (list 1 2 3) (list 2 3))))
+                           -0-)
+                        '(shared
+                             ((-0- (vector -0- (cons -2- -8-) -8-))
+                              (-2- (list -2- -4- -5-))
+                              (-4- (cons 1 -5-))
+                              (-5- (list 2 3))
+                              (-8- (list -4- -5- (list 2 3))))
+                           -0-)
+                        '(shared
+                             ((-0- (vector -0-
+                                           `(,-2-
+                                             (1 2 3)
+                                             (2 3)
+                                             (2 3))
+                                           `((1 2 3)
+                                             (2 3)
+                                             (2 3))))
+                              (-2- `(,-2- (1 2 3) (2 3))))
+                           -0-)
+                        '(shared
+                             ((-0- (vector -0- `(,-2- . ,-8-) -8-))
+                              (-2- `(,-2- ,-4- ,-5-))
+                              (-4- `(1 . ,-5-))
+                              (-5- `(2 3))
+                              (-8- `(,-4- ,-5- (2 3))))
+                           -0-))))
+  (for-each run-test tests))
+
+(let ()
+  (define make-pctest-shared
+    (lambda (shared?)
+      (lambda (object output)
+        (parameterize ([constructor-style-printing #t]
+                       [show-sharing #t]
+                       [quasi-read-style-printing #f]
+                       [abbreviate-cons-as-list #t])
+          (test (if shared?
+                    `(shared ((-1- ,output))
+                       (list -1- -1-))
+                    `(list ,output ,output))
+                print-convert
+                (list object object))))))
+  (define test-shared (make-pctest-shared #t))
+  (define test-not-shared (make-pctest-shared #f))
+  
+  (test-not-shared #t 'true)
+  (test-not-shared #f 'false)
+  (test-not-shared 1 1)
+  (test-not-shared 3276832768327683276832768327683276832768
+                   3276832768327683276832768327683276832768)
+  (test-shared (regexp "") '(regexp ""))
+  (let ([in (open-input-string "")]) (test-shared in in))
+  (let ([out (open-output-string)]) (test-shared out out))
+  (test-not-shared #\a #\a)
+  (test-not-shared 'x ''x)
+  (test-shared (lambda (x) x) '(lambda (a1) ...))
+  (test-shared (delay 1) '(delay ...))
+  (test-shared (class object% ()) '(class ...))
+  (test-shared (unit (import) (export)) '(unit ...))
+  (test-shared (new (class object% (super-new))) '(instantiate (class ...) ...))
+  
+  (test-shared "abc" "abc")
+  (test-shared (list 1 2 3) '(list 1 2 3))
+  (test-shared (vector 1 2 3) '(vector 1 2 3))
+  (let () (define-struct a () (make-inspector)) (test-shared (make-a) '(make-a)))
+  (test-shared (box 1) '(box 1))
+  (test-shared (make-hash-table) '(hash-table)))
+
+(arity-test print-convert 1 2)
+(arity-test build-share 1 1)
+(arity-test get-shared 1 2)
+(arity-test print-convert-expr 3 3)
+
+(test 'empty print-convert '())
+
+(let ([fn (make-temporary-file "pconvert.ss-test~a")])
+  (let ([in (open-input-file fn)])
+    (test `(open-input-file ,fn) print-convert in)
+    (close-input-port in))
+  (delete-file fn))
+
+(let ()
+  (define-struct hidden (a))
+  (define-struct visible (b) (make-inspector))
+  (test '(make-hidden ...) print-convert (make-hidden 1))
+  (test '(make-visible 2) print-convert (make-visible 2)))
+
+(let ([pc
+       (lambda (pv)
+         (lambda (x)
+           (parameterize ([booleans-as-true/false pv])
+             (print-convert x))))])
+  (test 'false (pc #t) #f)
+  (test 'true (pc #t) #t)
+  (test #f (pc #f) #f)
+  (test #t (pc #f) #t))
+
+(let ([pc
+       (lambda (pv)
+         (lambda (x)
+           (parameterize ([named/undefined-handler (lambda (x) 'whee)]
+                          [use-named/undefined-handler
+                           (lambda (x) pv)])
+             (print-convert x))))])
+  (test '(lambda (a1) ...) (pc #f) (let ([f (lambda (x) x)]) f))
+  (test 'whee (pc #t) (let ([f (lambda (x) x)]) f))
+  (test '(list whee whee) 
+        (pc #t) 
+        (let ([g (lambda (y) (let ([f (lambda (x) y)]) f))]) (list (g 1) (g 2)))))
+
+(report-errs)
diff --git a/collects/tests/mzscheme/port.ss b/collects/tests/mzscheme/port.ss
new file mode 100644
index 0000000000..0bb5279156
--- /dev/null
+++ b/collects/tests/mzscheme/port.ss
@@ -0,0 +1,561 @@
+
+(load-relative "loadtest.ss")
+
+(SECTION 'PORT)
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Tests for progress events and commits
+
+(define (test-hello-port p commit-eof?)
+  (let ([progress-evt1 (port-progress-evt p)])
+    (test #t evt? progress-evt1)
+    (test #f sync/timeout 0 progress-evt1)
+    (test #f sync/timeout 0 progress-evt1)
+    (test #\h read-char p)
+    (test progress-evt1 sync/timeout 0 progress-evt1)
+    (let ([progress-evt2 (port-progress-evt p)])
+      (test #f sync/timeout 0 progress-evt2)
+      (test #\e peek-char p)
+      (test #f sync/timeout 0 progress-evt2)
+      (test #f port-commit-peeked 1 progress-evt1 always-evt p)
+      (test #t port-commit-peeked 1 progress-evt2 always-evt p)
+      (test progress-evt1 sync/timeout 0 progress-evt1)
+      (test progress-evt2 sync/timeout 0 progress-evt2)
+      (let ([progress-evt3 (port-progress-evt p)])
+	(test #\l peek-char p)
+	(test #\l peek-char p 1)
+	(test #\o peek-char p 2)
+	(test eof peek-char p 3)
+	(test eof peek-char p 4)
+	(test #t port-commit-peeked 2 progress-evt3 always-evt p)
+	(test #\o peek-char p)
+	(test eof peek-char p 1)
+	(let ([progress-evt4 (port-progress-evt p)])
+	  (test #f sync/timeout 0 progress-evt4)
+	  (test #t port-commit-peeked (if commit-eof? 2 1) progress-evt4 always-evt p)
+	  (test progress-evt4 sync/timeout 0 progress-evt4)
+	  (let ([progress-evt5 (port-progress-evt p)])
+	    (test #f sync/timeout 0 progress-evt5)
+	    (test eof peek-char p)
+	    (test eof read-char p)
+	    (test #f sync/timeout 0 progress-evt5)
+	    (test #f port-commit-peeked 1 progress-evt5 always-evt p)))))))
+
+(test-hello-port (open-input-string "hello") #f)
+(test-hello-port (open-input-string "hello") #t)
+(let ([test-pipe
+       (lambda (commit-eof?)
+	 (let-values ([(r w) (make-pipe)])
+	   (write-string "hello" w)
+	   (close-output-port w)
+	   (test-hello-port r commit-eof?)))])
+  (test-pipe #f)
+  (test-pipe #t))
+(let ([test-file
+       (lambda (commit-eof?)
+	 (let ([p (begin
+		    (with-output-to-file "tmp8"
+		      (lambda ()
+			(write-string "hello"))
+		      'truncate/replace)
+		    (open-input-file "tmp8"))])
+	   (test-hello-port p commit-eof?)
+	   (close-input-port p)))])
+  (test-file #f)
+  (test-file #t))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Based on the MzScheme manual...
+
+;; A port with no input...
+;; Easy: \scheme{(open-input-bytes #"")}
+;; Hard:
+(define /dev/null-in 
+  (make-input-port 'null
+		   (lambda (s) eof)
+		   (lambda (skip s progress-evt) eof)
+		   void
+		   (lambda () never-evt)
+		   (lambda (k progress-evt done-evt)
+		     (error "no successful peeks!"))))
+(test eof read-char /dev/null-in)
+(test eof peek-char /dev/null-in)
+(test eof read-byte-or-special /dev/null-in)
+(test eof peek-byte-or-special /dev/null-in 100)
+(test #t evt? (port-progress-evt /dev/null-in))
+(test #f sync/timeout 0 (port-progress-evt /dev/null-in))
+(err/rt-test (port-commit-peeked 100 (port-progress-evt /dev/null-in) always-evt /dev/null-in)
+	     exn:fail?)
+(err/rt-test (port-commit-peeked 100 never-evt always-evt /dev/null-in))
+
+;; A port that produces a stream of 1s:
+(define infinite-ones 
+  (make-input-port
+   'ones
+   (lambda (s) 
+     (bytes-set! s 0 (char->integer #\1)) 1)
+   #f
+   void))
+(test "11111" read-string 5 infinite-ones)
+
+;; An infinite stream of 1s with a specific peek procedure:
+(define infinite-ones 
+  (let ([one! (lambda (s) 
+	        (bytes-set! s 0 (char->integer #\1)) 1)])
+    (make-input-port
+     'ones
+     one!
+     (lambda (s skip progress-evt) (one! s))
+     void)))
+(test "11111" read-string 5 infinite-ones)
+
+;; Now we can peek ahead arbitrarily far:
+(test "11111" peek-string 5 (expt 2 5000) infinite-ones)
+
+;; The port doesn't supply procedures to implement progress events:
+(test #f port-provides-progress-evts? infinite-ones)
+(err/rt-test (port-progress-evt infinite-ones) exn:application:mismatch?)
+
+;; This port produces 0, 1, 2, 0, 1, 2, etc,
+;;  but it is not thread-safe, because multiple
+;;  threads might read and change n
+(define mod3-cycle/one-thread
+  (let* ([n 2]
+	 [mod! (lambda (s delta)
+		 (bytes-set! s 0 (+ 48 (modulo (+ n delta) 3)))
+                 1)])
+    (make-input-port
+     'mod3-cycle/not-thread-safe
+     (lambda (s) 
+       (set! n (modulo (add1 n) 3))
+       (mod! s 0))
+     (lambda (s skip progress-evt) 
+       (mod! s skip))
+     void)))
+(test "01201" read-string 5 mod3-cycle/one-thread)
+(test "20120" peek-string 5 (expt 2 5000) mod3-cycle/one-thread)
+
+;; Same thing, but thread-safe and kill-safe, and with progress
+;; events. Only the server thread touches the stateful part
+;; directly. (See the output port examples for a simpler thread-safe
+;; example, but this one is more general.)
+(define (make-mod3-cycle)
+  (define read-req-ch (make-channel))
+  (define peek-req-ch (make-channel))
+  (define progress-req-ch (make-channel))
+  (define commit-req-ch (make-channel))
+  (define close-req-ch (make-channel))
+  (define closed? #f)
+  (define n 0)
+  (define progress-sema #f)
+  (define (mod! s delta)
+    (bytes-set! s 0 (+ 48 (modulo (+ n delta) 3)))
+    1)
+  (define (remq v l)
+    (if (eq? (car l) v)
+	(cdr l)
+	(cons (car l) (remq (cdr l) v))))
+  ;; ----------------------------------------
+  ;; The server has a list of outstanding commit requests,
+  ;;  and it also must service each port operation (read, 
+  ;;  progress-evt, etc.)
+  (define (serve commit-reqs response-evts)
+    (apply
+     sync
+     (handle-evt read-req-ch (handle-read commit-reqs response-evts))
+     (handle-evt progress-req-ch (handle-progress commit-reqs response-evts))
+     (handle-evt commit-req-ch (add-commit commit-reqs response-evts))
+     (handle-evt close-req-ch (handle-close commit-reqs response-evts))
+     (append
+      (map (make-handle-response commit-reqs response-evts) response-evts)
+      (map (make-handle-commit commit-reqs response-evts) commit-reqs))))
+  ;; Read/peek request: fill in the string and commit
+  (define ((handle-read commit-reqs response-evts) r)
+    (let ([s (car r)]
+	  [skip (cadr r)]
+	  [ch (caddr r)]
+	  [nack (cadddr r)]
+	  [peek? (car (cddddr r))]
+	  [progress-evt (cdr (cddddr r))])
+      (let ([nothing? (or closed?
+			  (and progress-evt
+			       (sync/timeout 0 progress-evt)))])
+	(unless nothing?
+	  (mod! s skip)
+	  (unless peek?
+	    (commit! 1)))
+	;; Add an event to respond:
+	(serve commit-reqs
+	       (cons (choice-evt nack
+				 (channel-put-evt ch (if nothing? 
+							 #f
+							 (if closed? 0 1))))
+		     response-evts)))))
+  ;; Progress request: send a peek evt for the current 
+  ;;  progress-sema
+  (define ((handle-progress commit-reqs response-evts) r)
+    (let ([ch (car r)]
+	  [nack (cdr r)])
+      (unless progress-sema
+	(set! progress-sema (make-semaphore (if closed? 1 0))))
+      ;; Add an event to respond:
+      (serve commit-reqs
+	     (cons (choice-evt nack
+			       (channel-put-evt
+				ch
+				(semaphore-peek-evt progress-sema)))
+		   response-evts))))
+  ;; Commit request: add the request to the list
+  (define ((add-commit commit-reqs response-evts) r)
+    (serve (cons r commit-reqs) response-evts))
+  ;; Commit handling: watch out for progress, in which case
+  ;;  the response is a commit failure; otherwise, try
+  ;;  to sync for a commit. In either event, remove the
+  ;;  request from the list
+  (define ((make-handle-commit commit-reqs response-evts) r)
+    (let ([k (car r)]
+	  [progress-evt (cadr r)]
+	  [done-evt (caddr r)]
+	  [ch (cadddr r)]
+	  [nack (cddddr r)])
+      ;; Note: we don't check that k is $\leq$ the sum of
+      ;;  previous peeks, because the entire stream is actually
+      ;;  known, but we could send an exception in that case.
+      (choice-evt
+       (handle-evt progress-evt
+		   (lambda (x) 
+		     (sync nack (channel-put-evt ch #f))
+		     (serve (remq r commit-reqs) response-evts)))
+       ;; Only create an event to satisfy done-evt if progress-evt
+       ;;  isn't already ready.
+       ;; Afterward, if progress-evt becomes ready, then this
+       ;;  event-making function will be called again.) We know this
+       ;;  only because the server control all posts to progress-evt.
+       (if (sync/timeout 0 progress-evt)
+	   never-evt
+	   (handle-evt done-evt
+		       (lambda (v)
+			 (commit! k)
+			 (sync nack (channel-put-evt ch #t))
+			 (serve (remq r commit-reqs) response-evts)))))))
+  ;; Response handling: as soon as the respondee listerns,
+  ;;  remove the response
+  (define ((make-handle-response commit-reqs response-evts) evt)
+    (handle-evt evt
+		(lambda (x)
+		  (serve commit-reqs
+			 (remq evt response-evts)))))
+  ;; Close handling: post the progress sema, if any, and set
+  ;;   the \scheme{closed?} flag
+  (define ((handle-close commit-reqs response-evts) r)
+    (let ([ch (car r)]
+	  [nack (cdr r)])
+      (set! closed? #t)
+      (when progress-sema
+	(semaphore-post progress-sema))
+      (serve commit-reqs
+	     (cons (choice-evt nack
+			       (channel-put-evt ch (void)))
+		   response-evts))))
+  ;; Helper for reads and post-peek commits:
+  (define (commit! k)
+    (when progress-sema
+      (semaphore-post progress-sema)
+      (set! progress-sema #f))
+    (set! n (+ n k)))
+  ;; Start the server thread:
+  (define server-thread (thread (lambda () (serve null null))))
+  ;; ----------------------------------------
+  ;; Client-side helpers:
+  (define (req-evt f)
+    (nack-guard-evt
+     (lambda (nack)
+       ;; Be sure that the server thread is running:
+       (thread-resume server-thread (current-thread))
+       ;; Create a channel to hold the reply:
+       (let ([ch (make-channel)])
+	 (f ch nack)
+	 ch))))
+  (define (read-or-peek-evt s skip peek? progress-evt)
+    (req-evt (lambda (ch nack)
+	       (channel-put read-req-ch (list* s skip ch nack peek? progress-evt)))))
+  ;; Make the port:
+  (make-input-port 'mod3-cycle
+		   ;; Each handler for the port just sends
+		   ;;  a request to the server
+		   (lambda (s) (read-or-peek-evt s 0 #f #f))
+		   (lambda (s skip progress-evt) (read-or-peek-evt s skip #t progress-evt))
+		   (lambda () ; close
+		     (sync (req-evt
+			    (lambda (ch nack)
+			      (channel-put progress-req-ch (list* ch nack))))))
+		   (lambda () ; progress-evt
+		     (sync (req-evt
+			    (lambda (ch nack)
+			      (channel-put progress-req-ch (list* ch nack))))))
+		   (lambda (k progress-evt done-evt)  ; commit
+		     (sync (req-evt
+			    (lambda (ch nack)
+			      (channel-put commit-req-ch
+					   (list* k progress-evt done-evt ch nack))))))))
+
+(let ([mod3-cycle (make-mod3-cycle)])
+  (port-progress-evt mod3-cycle)
+  (let ([result1 #f]
+	[result2 #f])
+    (let ([t1 (thread (lambda ()
+			(set! result1 (read-string 5 mod3-cycle))))]
+	  [t2 (thread (lambda ()
+			(set! result2 (read-string 5 mod3-cycle))))])
+      (thread-wait t1)
+      (thread-wait t2)
+      (test 11 string-length (string-append result1 "," result2))))
+  (let ([s (make-bytes 1)]
+	[progress-evt (port-progress-evt mod3-cycle)])
+    (test 1 peek-bytes-avail! s 0 progress-evt mod3-cycle)
+    (test #"1" values s)
+    (test #t 
+	  port-commit-peeked 1 progress-evt (make-semaphore 1)
+	  mod3-cycle)
+    (test #t evt? (sync/timeout 0 progress-evt))
+    (test 0 peek-bytes-avail! s 0 progress-evt mod3-cycle)
+    (test #f 
+	  port-commit-peeked 1 progress-evt (make-semaphore 1) 
+	  mod3-cycle))
+  (close-input-port mod3-cycle))
+
+;; Non-byte port results:
+(define infinite-voids
+  (make-input-port
+   'voids
+   (lambda (s) (lambda args 'void))
+   (lambda (skip s progress-evt) (lambda args 'void))
+   void))
+(err/rt-test (read-char infinite-voids) exn:application:mismatch?)
+(test 'void read-byte-or-special infinite-voids)
+(test 'void read-char-or-special infinite-voids)
+(let ([go
+       (lambda (get-avail!)
+	 (define (get)
+	   (if (procedure-arity-includes? get-avail! 1)
+	       (get-avail! (make-bytes 10) infinite-voids)
+	       (get-avail! (make-bytes 10) 0 #f infinite-voids)))
+	 (let ([p (get)])
+	   (test #t procedure? p)
+	   (test 4 procedure-arity p)
+	   (test 'void p 'apple 1 0 1)
+	   (err/rt-test (p 'apple 1 0 1) exn:fail:contract?))
+	 (let ([p (get)])
+	   (err/rt-test (p 'apple 0 0 1))
+	   (err/rt-test (p 'apple 1 0 0))
+	   (err/rt-test (p 'apple 1 -1 1))))])
+  (go read-bytes-avail!)
+  (go read-bytes-avail!*)
+  (go read-bytes-avail!/enable-break)
+  (go peek-bytes-avail!)
+  (go peek-bytes-avail!*)
+  (go peek-bytes-avail!/enable-break))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Also based on the MzScheme manual...
+
+(define should-be-breakable? #t)
+
+(define /dev/null-out
+  (make-output-port 
+   'null
+   always-evt
+   (lambda (s start end non-block? breakable?)
+     (test should-be-breakable? 'breakable breakable?)
+     (- end start))
+   void
+   (lambda (special non-block? breakable?) 
+     (test should-be-breakable? 'spec-breakable breakable?)
+     #t)
+   (lambda (s start end) (wrap-evt
+			  always-evt
+			  (lambda (x)
+			    (- end start))))
+   (lambda (special) always-evt)))
+(test (void) display "hello" /dev/null-out)
+(test 5 write-bytes-avail #"hello" /dev/null-out)
+(test #t write-special 'hello /dev/null-out)
+(test 5 sync (write-bytes-avail-evt #"hello" /dev/null-out))
+(test 5 write-bytes-avail/enable-break #"hello" /dev/null-out)
+(test #t write-special-avail* 'hello /dev/null-out)
+(parameterize-break #f
+  (test 5 write-bytes-avail/enable-break #"hello" /dev/null-out)
+  (set! should-be-breakable? #f)
+  (test #t write-special-avail* 'hello /dev/null-out)
+  (test 5 write-bytes-avail #"hello" /dev/null-out))
+
+;; A part that accumulates bytes as characters in a list,
+;;  but not in a thread-safe way:
+(define accum-list null)
+(define accumulator/not-thread-safe
+  (make-output-port 
+   'accum/not-thread-safe
+   always-evt
+   (lambda (s start end non-block? breakable?)
+     (set! accum-list
+           (append accum-list
+                   (map integer->char
+                        (bytes->list (subbytes s start end)))))
+     (- end start))
+   void))
+(display "hello" accumulator/not-thread-safe)
+(test '(#\h #\e #\l #\l #\o) values accum-list)
+
+;; Same as before, but with simple thread-safety:
+(define accum-list null)
+(define accumulator 
+  (let* ([lock (make-semaphore 1)]
+	 [lock-peek-evt (semaphore-peek-evt lock)])
+    (make-output-port
+     'accum
+     lock-peek-evt
+     (lambda (s start end non-block? breakable?)
+       (let loop ()
+	 (if (semaphore-try-wait? lock)
+	     (begin
+	       (set! accum-list
+		     (append accum-list
+			     (map integer->char
+				  (bytes->list (subbytes s start end)))))
+	       (semaphore-post lock)
+	       (- end start))
+	     ;; Cheap strategy: block until the list is unlocked,
+	     ;;   then try again
+	     (wrap-evt
+	      lock-peek
+	      (lambda (x) (loop))))))
+     void)))
+(display "hello" accumulator)
+(test '(#\h #\e #\l #\l #\o) values accum-list)
+
+;; A port that transforms data before sending it on
+;;  to another port. Atomic writes exploit the
+;;  underlying port's ability for atomic writes.
+(define (make-latin-1-capitalize port)
+  (define (byte-upcase s start end)
+    (list->bytes
+     (map (lambda (b) (char->integer
+		       (char-upcase
+			(integer->char b))))
+	  (bytes->list (subbytes s start end)))))
+  (make-output-port
+   'byte-upcase
+   ;; This port is ready when the original is ready:
+   port
+   ;; Writing procedure:
+   (lambda (s start end non-block? breakable?)
+     (let ([s (byte-upcase s start end)])
+       (if non-block?
+           (write-bytes-avail* s port)
+           (begin
+             (display s port)
+             (bytes-length s)))))
+   ;; Close procedure --- close original port:
+   (lambda () (close-output-port port))
+   #f
+   ;; Write event:
+   (and (port-writes-atomic? port)
+	(lambda (s start end)
+	  (write-bytes-avail-evt (byte-upcase s start end) port)))))
+(define orig-port (open-output-string))
+(define cap-port (make-latin-1-capitalize orig-port))
+(display "Hello" cap-port)
+(test "HELLO" get-output-string orig-port)
+(test 3 sync (write-bytes-avail-evt #"Bye" cap-port))
+(test "HELLOBYE" get-output-string orig-port)
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Peeking in a limited pipe extends the limit:
+
+(let-values ([(in out) (make-pipe 3)])
+  (test 3 write-bytes-avail #"12345" out)
+  (test #\1 peek-char in)
+  (test 1 write-bytes-avail #"12345" out)
+  (test #\1 peek-char in)
+  (test 0 write-bytes-avail* #"12345" out)
+  (test #\2 peek-char in 1)
+  (test 1 write-bytes-avail* #"12345" out)
+  (let ([s (make-bytes 6 (char->integer #\-))])
+    (test 5 read-bytes-avail! s in)
+    (test #"12311-" values s))
+  (test 3 write-bytes-avail #"1234" out))
+
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Provide a location proc:
+
+(let ([mk
+       (lambda (adjust-locs)
+	 (let ([p (open-input-string "Hello\n\n world")])
+	   (port-count-lines! p)
+	   (let ([p2 (make-input-port 'with-loc
+				      (lambda (s) (read-bytes-avail! s p))
+				      (lambda (s skip progress-evt)
+					(peek-bytes-avail! s skip progress-evt p))
+				      void
+				      (lambda () (prot-progress-evt p))
+				      (lambda (k progress-evt done-evt)
+					(port-commit-peeked k progress-evt done-evt p))
+				      (lambda ()
+					(let-values ([(line col pos) (port-next-location p)])
+					  (adjust-locs line col pos))))])
+	     (port-count-lines! p2)
+	     p2)))])
+  (let ([plain (let ([p (open-input-string "Hello\n\n world")])
+		 (port-count-lines! p)
+		 p)]
+	[double (mk (lambda (l c p)
+		      (values (* 2 l) (* 2 c) (* 2 p))))]
+	[none (mk (lambda (l c p) (values #f #f #f)))]
+	[bad (mk (let ([did-once? #f])
+		   (lambda (l c p)
+		     (if did-once?
+			 #f
+			 (begin
+			   ;; First call is from `port-count-lines!'
+			   (set! did-once? #t)
+			   (values l c p))))))])
+    (test-values '(1 0 1) (lambda () (port-next-location plain)))
+    (test-values '(2 0 2) (lambda () (port-next-location double)))
+    (test-values '(#f #f #f) (lambda () (port-next-location none)))
+    (err/rt-test (port-next-location bad) exn:fail:contract:arity?)
+    
+    (test 'Hello read plain)
+    (test 'Hello read double)
+    (test 'Hello read none)
+    (err/rt-test (read bad) exn:fail:contract:arity?)
+
+    (test-values '(1 5 6) (lambda () (port-next-location plain)))
+    (test-values '(2 10 12) (lambda () (port-next-location double)))
+    (test-values '(#f #f #f) (lambda () (port-next-location none)))
+    (err/rt-test (port-next-location bad))
+
+    (let ([stx (read-syntax #f plain)])
+      (test 3 syntax-line stx)
+      (test 1 syntax-column stx)
+      (test 9 syntax-position stx))
+    (let ([stx (read-syntax #f double)])
+      (test 6 syntax-line stx)
+      ;; The next two should be 2 and 18, but the reader
+      ;;  actually reads the character first, the subtracts
+      ;;  1 from the column and position.
+      (test 3 syntax-column stx)
+      (test 19 syntax-position stx))
+    (let ([stx (read-syntax #f none)])
+      (test #f syntax-line stx)
+      (test #f syntax-column stx)
+      (test #f syntax-position stx))
+    (err/rt-test (read-syntax #f bad) exn:fail:contract:arity?)
+    
+    (test-values '(3 6 14) (lambda () (port-next-location plain)))
+    (test-values '(6 12 28) (lambda () (port-next-location double)))
+    (test-values '(#f #f #f) (lambda () (port-next-location none)))))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(report-errs)
diff --git a/collects/tests/mzscheme/portlib.ss b/collects/tests/mzscheme/portlib.ss
new file mode 100644
index 0000000000..2c1d626d09
--- /dev/null
+++ b/collects/tests/mzscheme/portlib.ss
@@ -0,0 +1,618 @@
+
+(load-relative "loadtest.ss")
+
+(SECTION 'port)
+
+(define SLEEP-TIME 0.1)
+
+(require (lib "port.ss"))
+
+;; ----------------------------------------
+
+;; pipe and pipe-with-specials commmit tests
+(define (test-pipe-commit make-pipe)
+  (let-values ([(in out) (make-pipe)])
+    (display "apple" out)
+    (test #"app" peek-bytes 3 0 in)
+    (let ([sema (make-semaphore 1)])
+      (test #t port-commit-peeked 3 (port-progress-evt in) sema in)
+      (test #f semaphore-try-wait? sema))
+    (test #"le" read-bytes 2 in)
+    (display "banana" out)
+    (test #"ban" peek-bytes 3 0 in)
+    ;; Set up a commit that fails, because the done-evt never becomes ready:
+    (let* ([r '?]
+	   [unless-evt (port-progress-evt in)]
+	   [th (thread
+		(lambda ()
+		  (set! r (port-commit-peeked 3 unless-evt never-evt in))))])
+      (sleep SLEEP-TIME)
+      (test #t thread-running? th)
+      (test #\b peek-char in)
+      (sleep SLEEP-TIME)
+      (test #t thread-running? th)
+      (test #f sync/timeout 0 unless-evt)
+      (test #\b read-char in)
+      (sleep SLEEP-TIME)
+      (test th sync th)
+      (test #f values r))
+    (test "anana" read-string 5 in)
+    ;; Set up two commits, pick one to succeed:
+    (let ([go (lambda (which peek? suspend/kill)
+		(printf "~a ~a ~a~n" which peek? suspend/kill)
+		(display "donut" out)
+		(test #"don" peek-bytes 3 0 in)
+		(let* ([r1 '?]
+		       [r2 '?]
+		       [s1 (make-semaphore)]
+		       [s2 (make-semaphore)]
+		       [unless-evt (port-progress-evt in)]
+		       [th1 (thread
+			     (lambda ()
+			       (set! r1 (port-commit-peeked 1 unless-evt s1 in))))]
+		       [_ (sleep SLEEP-TIME)]
+		       [th2 (thread
+			     (lambda ()
+			       (set! r2 (port-commit-peeked 2 unless-evt (semaphore-peek-evt s2) in))))])
+		  (sleep SLEEP-TIME)
+		  (when suspend/kill
+		    (case suspend/kill
+		      [(suspend) (thread-suspend th1)]
+		      [(kill) (kill-thread th1)])
+		    (sleep SLEEP-TIME))
+		  (test (eq? suspend/kill 'kill) thread-dead? th1)
+		  (test #f thread-dead? th2)
+		  (when peek?
+		    (test #"do" peek-bytes 2 0 in)
+		    (sleep SLEEP-TIME))
+		  (unless (= which 3)
+		    (semaphore-post (if (= which 1) s1 s2)))
+		  (when (= which 3)
+		    (test #"do" read-bytes 2 in))
+		  (sleep SLEEP-TIME)
+		  (test unless-evt sync/timeout 0 unless-evt)
+		  (test (not (eq? suspend/kill 'suspend)) thread-dead? th1)
+		  (sleep SLEEP-TIME)
+		  (test #t thread-dead? th2)
+		  (test (if (= which 1) #t (if suspend/kill '? #f)) values r1)
+		  (test (= which 2) values r2)
+		  (test (if (= which 1) #\o #\n) read-char in)
+		  (test (if (= which 1) #"nut" #"ut") read-bytes (if (= which 1) 3 2) in)))])
+      (go 1 #f #f)
+      (go 2 #f #f)
+      (go 1 #t #f)
+      (go 2 #t #f)
+      (go 3 #f #f)
+      (go 2 #f 'suspend)
+      (go 2 #t 'suspend)
+      (go 3 #f 'suspend)
+      (go 2 #f 'kill)
+      (go 2 #t 'kill)
+      (go 3 #f 'kill))))
+(test-pipe-commit make-pipe)
+(test-pipe-commit (lambda () (make-pipe-with-specials 10000 'special-pipe 'spec-pipe)))
+
+;; pipe-with-specials and limit; also used to test peeked-input-port
+(define (test-special-pipe make-pipe-with-specials)
+  (let-values ([(in out) (make-pipe-with-specials 10)])
+    ;; Check that write events work
+    (test 5 sync (write-bytes-avail-evt #"12345" out))
+    (test #"12345" read-bytes 5 in)
+    (test #f char-ready? in)
+    (test #t sync (write-special-evt 'okay out))
+    (test 11 write-bytes-avail (make-bytes 11 65) out)
+    (test 'okay read-char-or-special in)
+    (test (make-bytes 11 65) read-bytes 11 in)
+
+    (let ()
+      (define (bg thunk runs? spec? exn?)
+	;; Fill the pipe, again:
+	(test 10 write-bytes (make-bytes 10 66) out)
+	(let* ([ex #f]
+	       [th (thread 
+		    (lambda ()
+		      (with-handlers ([exn:fail? (lambda (x) 
+						   (set! ex #t)
+						   (raise x))])
+			(sync (write-bytes-avail-evt #"x" out)))))])
+	  (sleep SLEEP-TIME)
+	  (test #t thread-running? th)
+	  ;; This thunk (and sometimes read) should go through the manager:
+	  (thunk)
+	  (sleep SLEEP-TIME)
+	  (test (not runs?) thread-running? th)
+	  (test (make-bytes 10 66) read-bytes 10 in)
+	  (thread-wait th)
+	  (test ex values exn?))
+	(when spec?
+	  (test 'c read-char-or-special in))
+	(test (if exn? eof #"x") read-bytes 1 in))
+      
+      (bg (lambda () (test 0 write-bytes-avail* #"c" out)) #f #f #f)
+      (bg (lambda () (test #t write-special 'c out)) #t #t #f)
+      (bg (lambda () (test (void) close-output-port out)) #t #f #t))))
+(test-special-pipe make-pipe-with-specials)
+(test-special-pipe (lambda (limit)
+		     (let-values ([(in out) (make-pipe-with-specials limit)])
+		       (values (peeking-input-port in) out))))
+
+;; copy-port and make-pipe-with-specials tests
+(let ([s (let loop ([n 10000][l null])
+	   (if (zero? n)
+	       (apply bytes l)
+	       (loop (sub1 n) (cons (random 256) l))))])
+  (let-values ([(in out) (make-pipe-with-specials)])
+    (display s out)
+    (test #t 'pipe-same? (bytes=? s (read-bytes (bytes-length s) in)))
+    (test out sync/timeout 0 out)
+    (test #f sync/timeout 0 in)
+    (write-special 'hello? out)
+    (test 'hello? read-char-or-special in)
+    (display "123" out)
+    (write-special 'again! out)
+    (display "45" out)
+    (let ([s (make-bytes 5)])
+      (test 3 read-bytes-avail! s in)
+      (test #"123\0\0" values s)
+      (let ([p (read-bytes-avail! s in)])
+	(test #t procedure? p)
+	(test 'again! p 'ok 1 2 3))
+      (test 2 read-bytes-avail! s in)
+      (test #"453\0\0" values s)))
+  (let ([in (open-input-bytes s)]
+	[out (open-output-bytes)])
+    (copy-port in out)
+    (test #t 'copy-same? (bytes=? s (get-output-bytes out))))
+  (let* ([a (subbytes s 0 (max 1 (random (bytes-length s))))]
+	 [b (subbytes s (bytes-length a) (+ (bytes-length a)
+					    (max 1 (random (- (bytes-length s) (bytes-length a))))))]
+	 [c (subbytes s (+ (bytes-length a) (bytes-length b)))])
+    (define (go-stream close? copy? threads? peek?)
+      (printf "Go stream: ~a ~a ~a ~a~n" close? copy? threads? peek?)
+      (let*-values ([(in1 out) (make-pipe-with-specials)]
+		    [(in out1) (if copy?
+				   (make-pipe-with-specials)
+				   (values in1 out))])
+	(let ([w-th
+	       (lambda ()
+		 (display a out)
+		 (write-special '(first one) out)
+		 (display b out)
+		 (write-special '(second one) out)
+		 (display c out)
+		 (when close?
+		   (close-output-port out)))]
+	      [c-th (lambda ()
+		      (when copy?
+			(copy-port in1 out1)
+			(close-output-port out1)))]
+	      [r-th (lambda ()
+		      (let ([get-one-str
+			     (lambda (a)
+			       (let ([dest (make-bytes (bytes-length s))]
+				     [target (bytes-length a)])
+				 (let loop ([n 0])
+				   (let ([v (read-bytes-avail! dest in n)])
+				     (if (= target (+ v n))
+					 (test #t `(same? ,target) (equal? (subbytes dest 0 target) a))
+					 (loop (+ n v)))))))]
+			    [get-one-special
+			     (lambda (spec)
+			       (let ([v (read-bytes-avail! (make-bytes 10) in)])
+				 (test #t procedure? v)
+				 (test spec v 'ok 5 5 5)))])
+			(when peek?
+			  (test '(second one) peek-byte-or-special in (+ (bytes-length a) 1 (bytes-length b))))
+			(get-one-str a)
+			(get-one-special '(first one))
+			(get-one-str b)
+			(get-one-special '(second one))
+			(get-one-str c)
+			(if close?
+			    (test eof read-byte in)
+			    (test #f sync/timeout 0 in))))])
+	  (let ([th (if threads?
+			thread
+			(lambda (f) (f)))])
+	    (for-each (lambda (t)
+			(and (thread? t) (thread-wait t)))
+		      (list
+		       (th w-th)
+		       (th c-th)
+		       (th r-th)))))))
+    (go-stream #f #f #f #f)
+    (go-stream #t #f #f #f)
+    (go-stream #t #t #f #f)
+    (go-stream #t #f #t #f)
+    (go-stream #t #t #t #f)
+    (go-stream #t #f #f #t)
+    (go-stream #t #t #f #t)
+    (go-stream #t #f #t #t)
+    (go-stream #t #t #t #t)))
+
+;; make-input-port/read-to-peek
+(define (make-list-port . l)
+  (make-input-port/read-to-peek 
+   'list-port
+   (lambda (bytes)
+     (cond
+      [(null? l) eof]
+      [(byte? (car l))
+       (bytes-set! bytes 0 (car l))
+       (set! l (cdr l))
+       1]
+      [(and (char? (car l))
+	    (byte? (char->integer (car l))))
+       (bytes-set! bytes 0 (char->integer (car l)))
+       (set! l (cdr l))
+       1]
+      [else
+       (let ([v (car l)])
+	 (set! l (cdr l))
+	 (lambda (a b c d) v))]))
+   #f
+   void))
+
+(let ([p (make-list-port #\h #\e #\l #\l #\o)])
+  (test (char->integer #\h) peek-byte p)
+  (test (char->integer #\e) peek-byte p 1)
+  (test (char->integer #\l) peek-byte p 2)
+  (test #"hel" read-bytes 3 p)
+  (test (char->integer #\l) peek-byte p)
+  (test (char->integer #\o) peek-byte p 1)
+  (test #"lo" read-bytes 3 p)
+  (test eof peek-byte p)
+  (test eof peek-byte p)
+  (test eof read-byte p)
+  (test eof read-byte p))
+
+(let ([p (make-list-port #\h #\e #\l 'ack #\l #\o)])
+  (test (char->integer #\h) read-byte p)
+  (test (char->integer #\e) read-byte p)
+  (test (char->integer #\l) read-byte p)
+  (test 'ack read-byte-or-special p)
+  (test (char->integer #\l) read-byte p)
+  (test (char->integer #\o) read-byte p))
+
+(let ([p (make-list-port #\h #\e #\l 'ack #\l #\o)])
+  (test (char->integer #\h) peek-byte p)
+  (test (char->integer #\l) peek-byte p 2)
+  (test 'ack peek-byte-or-special p 3)
+  (test (char->integer #\l) peek-byte p 4)
+  (test #"hel" read-bytes 3 p)
+  (test 'ack read-byte-or-special p)
+  (test #"lo" read-bytes 4 p))
+
+(test 'hello read (make-list-port #\h #\e #\l #\l #\o))
+(let ([p (make-list-port #\h #\e #\l eof #\l #\o)])
+  (test 'hel read p)
+  (test eof read p)
+  (test 'lo read p)
+  (test eof read p)
+  (test eof read p))
+(let ([p (make-list-port #\h #\e #\l #\u7238 #\l #\o)])
+  (test 'hel read p)
+  (test #\u7238 read p)
+  (test 'lo read p))
+
+;; read synchronization events
+(define (go mk-hello sync atest btest)
+  (test #t list? (list mk-hello sync atest btest))
+  (test #"" sync (peek-bytes-evt 0 0 #f (mk-hello)))
+  (test #"" sync (read-bytes-evt 0 (mk-hello)))
+  (let ([p (mk-hello)])
+    (atest #"hello" sync (peek-bytes-evt 5 0 #f p))
+    (atest #"llo" sync (peek-bytes-evt 5 2 #f p))
+    (atest #"hello" sync (read-bytes-evt 5 p))
+    (atest eof sync (peek-bytes-evt 5 0 #f p))
+    (atest eof sync (read-bytes-evt 5 p)))
+  (test 0 sync (peek-bytes!-evt (make-bytes 0) 0 #f (mk-hello)))
+  (test 0 sync (read-bytes!-evt (make-bytes 0) (mk-hello)))
+  (let ([s (make-bytes 5)]
+	[p (mk-hello)])
+    (atest 5 sync (peek-bytes!-evt s 0 #f p))
+    (btest #"hello" values s)
+    (atest 3 sync (peek-bytes!-evt s 2 #f p))
+    (btest #"llolo" values s)
+    (bytes-copy! s 0 #"\0\0\0\0\0")
+    (atest 5 sync (read-bytes!-evt s p))
+    (btest #"hello" values s)
+    (atest eof sync (read-bytes!-evt s p)))
+  (test 0 sync (read-bytes-avail!-evt (make-bytes 0) (mk-hello)))
+  (let ([s (make-bytes 5)]
+	[p (mk-hello)])
+    (atest 5 sync (peek-bytes-avail!-evt s 0 #f p))
+    (btest #"hello" values s)
+    (atest 2 sync (peek-bytes-avail!-evt s 3 #f p))
+    (btest #"lollo" values s)
+    (bytes-copy! s 0 #"\0\0\0\0\0")
+    (atest 5 sync (read-bytes-avail!-evt s p))
+    (btest #"hello" values s)
+    (atest eof sync (read-bytes-avail!-evt s p)))
+  (test "" sync (read-string-evt 0 (mk-hello)))
+  (let ([p (mk-hello)])
+    (atest "hello" sync (peek-string-evt 5 0 #f p))
+    (atest "lo" sync (peek-string-evt 5 3 #f p))
+    (atest "hello" sync (read-string-evt 5 p))
+    (atest eof sync (peek-string-evt 5 0 #f p))
+    (atest eof sync (peek-string-evt 5 100 #f p))
+    (atest eof sync (read-string-evt 5 p)))
+  (test 0 sync (read-string!-evt (make-string 0) (mk-hello)))
+  (let ([s (make-string 5)]
+	[p (mk-hello)])
+    (let ([s2 (make-string 5)])
+      (atest 5 sync (peek-string!-evt s2 0 #f p))
+      (btest "hello" values s2))
+    (atest 5 sync (read-string!-evt s p))
+    (btest "hello" values s)
+    (atest eof sync (read-string!-evt s p)))
+  (let ([p (mk-hello)])
+    (atest '(#"hello") sync (regexp-match-evt #rx"....." p)))
+  (let ([p (mk-hello)])
+    (atest '(#"hello") sync (regexp-match-evt #rx".*" p)))
+  (let ([p (mk-hello)])
+    (atest '(#"hel") sync (regexp-match-evt #rx"..." p))
+    (atest '(#"lo") sync (regexp-match-evt #rx".." p)))
+  (let ([p (mk-hello)])
+    (atest #"hello" sync (read-bytes-line-evt p))
+    (atest eof sync (read-bytes-line-evt p))
+    (atest eof sync (eof-evt p)))
+  (let ([p (mk-hello)])
+    (atest "hello" sync (read-line-evt p))
+    (atest eof sync (read-line-evt p))))
+(go (lambda () (open-input-bytes #"hello")) sync test test)
+
+(define (sync/poll . args) (apply sync/timeout 0 args))
+(go (lambda () (open-input-bytes #"hello")) sync/poll test test)
+
+(define (delay-hello)
+  (let-values ([(r w) (make-pipe)])
+    (thread (lambda ()
+	      (sleep 0.1)
+	      (write-string "hello" w)
+	      (close-output-port w)))
+    r))
+(go delay-hello sync test test)
+
+(go (lambda ()
+      (let-values ([(r w) (make-pipe)])
+	r))
+    sync/poll 
+    (lambda args
+      (apply test #f (cdr args)))
+    (lambda args
+      (apply test (if (string? (car args))
+		      (make-string (string-length (car args)))
+		      (make-bytes (bytes-length (car args))))
+	     (cdr args))))
+
+
+;; extra checks for read-line-evt:
+(let ([p (open-input-string "ab\nc")])
+  (test "ab" sync (read-line-evt p))
+  (test "c" sync (read-line-evt p))
+  (test eof sync (read-line-evt p)))
+(let ([p (open-input-string "ab\nc")])
+  (test "ab\nc" sync (read-line-evt p 'return))
+  (test eof sync (read-line-evt p 'return)))
+(let ([p (open-input-string "ab\r\nc\r")])
+  (test "ab" sync (read-line-evt p 'return))
+  (test "\nc" sync (read-line-evt p 'return))
+  (test eof sync (read-line-evt p 'return)))
+(let ([p (open-input-string "ab\r\nc\r")])
+  (test "ab" sync (read-line-evt p 'return-linefeed))
+  (test "c\r" sync (read-line-evt p 'return-linefeed))
+  (test eof sync (read-line-evt p 'return-linefeed)))
+(let ([p (open-input-string "ab\r\nc\r")])
+  (test "ab" sync (read-line-evt p 'any))
+  (test "c" sync (read-line-evt p 'any))
+  (test eof sync (read-line-evt p 'any)))
+(let ([p (open-input-string "ab\r\nc\r")])
+  (test "ab" sync (read-line-evt p 'any-one))
+  (test "" sync (read-line-evt p 'any-one))
+  (test "c" sync (read-line-evt p 'any-one))
+  (test eof sync (read-line-evt p 'any-one)))
+
+;; input-port-append tests
+(let* ([do-test
+	;; ls is a list of strings for ports
+	;;  n, m, q are positive
+	;;  n and n+m < total length
+	;;  n+m+q can be greater than total length
+	(lambda (ls n m q)
+	  (let* ([p (apply input-port-append #f (map open-input-string ls))]
+		 [s (apply string-append ls)]
+		 [l (string-length s)])
+	    (test (substring s 0 n) peek-string n 0 p)
+	    (test (substring s n (min l (+ n m q))) peek-string (+ m q) n p)
+	    (test (substring s (+ n m) (min l (+ n m q))) peek-string q (+ n m) p)
+
+	    (test (substring s 0 n) read-string n p)
+	    
+	    (test (substring s n (+ n m)) peek-string m 0 p)
+	    (test (substring s (+ n m) (min l (+ n m q))) peek-string q m p)
+
+	    (test (substring s n (+ n m)) read-string m p)
+
+	    (test (substring s (+ n m) (min l (+ n m q))) peek-string q 0 p)))]
+       [do-tests
+	(lambda (ls)
+	  (let ([l (apply + (map string-length ls))])
+	    (let loop ([n 1])
+	      (unless (= n (- l 2))
+		(let loop ([m 1])
+		  (unless (= (+ m n) (- l 1))
+		    (do-test ls n m 1)
+		    (do-test ls n m (- l n m))
+		    (do-test ls n m (+ (- l n m) 2))
+		    (loop (add1 m))))
+		(loop (add1 n))))))])
+  (do-tests '("apple" "banana"))
+  (do-tests '("ax" "b" "cz")))
+;; input-port-append and not-ready inputs
+(let ([p0 (open-input-bytes #"123")])
+  (let-values ([(p1 out) (make-pipe)])
+    (let ([p (input-port-append #f p0 p1)])
+      (display "4" out)
+      (test #"1234" peek-bytes 4 0 p)
+      (test #"34" peek-bytes 2 2 p)
+      (test #"4" peek-bytes 1 3 p)
+      (let* ([v #f]
+	     [t (thread (lambda ()
+			  (set! v (read-bytes 6 p))))])
+	(test #f sync/timeout SLEEP-TIME t)
+	(display "56" out)
+	(test t sync/timeout SLEEP-TIME t)
+	(test #"123456" values v)))))
+
+;; make-limited-input-port tests
+(let* ([s (open-input-string "123456789")]
+       [s2 (make-limited-input-port s 5)])
+  (test #"123" peek-bytes 3 0 s2)
+  (test #"12345" peek-bytes 6 0 s2)
+  (test #"12" read-bytes 2 s2)
+  (test #"345" read-bytes 6 s2)
+  (test eof read-bytes 6 s2)
+  (test #f port-provides-progress-evts? s2))
+(let-values ([(i o) (make-pipe)])
+  (let ([s (make-limited-input-port i 5)])
+    (test #f char-ready? s)
+    (display "123" o)
+    (test #t char-ready? s)
+    (let ([b (make-bytes 10)])
+      (test 3 peek-bytes-avail!* b 0 #f s)
+      (test 3 read-bytes-avail!* b s)
+      (test 0 peek-bytes-avail!* b 0 #f s)
+      (display "456" o)
+      (test 2 peek-bytes-avail!* b 0 #f s)
+      (test 1 peek-bytes-avail!* b 1 #f s)
+      (test 2 read-bytes-avail!* b s))))
+	     
+;; ----------------------------------------
+;; Conversion wrappers
+
+(define (try-eip-seq encoding bytes try-map)
+  (let* ([p (open-input-bytes bytes)]
+	 [p2 (reencode-input-port p encoding #".!")])
+    (for-each (lambda (one-try)
+		(let ([p (if (car one-try)
+			     p2
+			     p)]
+		      [len (cadr one-try)]
+		      [expect (caddr one-try)])
+		  (test expect read-bytes len p)))
+	      try-map)))
+
+(try-eip-seq "UTF-8" #"apple" `((#t 3 #"app") (#f 2 #"le") (#t 4 ,eof)))
+(try-eip-seq "UTF-8" #"ap\303\251ple" `((#t 3 #"ap\303") (#f 2 #"pl") (#t 4 #"\251e") (#t 5 ,eof)))
+(try-eip-seq "ISO-8859-1" #"ap\303\251ple" `((#t 3 #"ap\303") (#f 2 #"\251p") (#t 4 #"\203le") (#t 5 ,eof)))
+(try-eip-seq "UTF-8" #"ap\251ple" `((#t 2 #"ap") (#f 2 #"\251p") (#t 4 #"le") (#t 5 ,eof)))
+(try-eip-seq "UTF-8" #"ap\251ple" `((#t 3 #"ap.") (#f 1 #"p") (#t 4 #"!le") (#t 5 ,eof)))
+(try-eip-seq "UTF-8" #"ap\251ple" `((#t 4 #"ap.!") (#f 1 #"l") (#t 4 #"pe") (#t 5 ,eof)))
+
+(let-values ([(in out) (make-pipe-with-specials)])
+  (display "ok" out)
+  (write-special 'special! out)
+  (display "yz" out)
+  (let ([p (reencode-input-port in "UTF-8")])
+    (test #"ok" read-bytes 2 p)
+    (test 'special! read-byte-or-special p)
+    (test #"yz" read-bytes 2 p)
+    (close-output-port out)
+    (test eof read-bytes 3 p)))
+
+(let*-values ([(r w) (make-pipe 10)]
+	      [(w2) (reencode-output-port w "UTF-8" #"!?")])
+  (test 4 write-bytes #"abcd" w2)
+  (flush-output w2)
+  (test #"abcd" read-bytes 4 r)
+  
+  (test 3 write-bytes #"abc" w2)
+  (test 0 read-bytes-avail!* (make-bytes 10) r)
+  (test 1 write-bytes-avail #"wx" w2)
+  (test #"abcw" read-bytes 4 r)
+
+  ;; Check encoding error
+  (test 4 write-bytes #"ab\303x" w2)
+  (flush-output w2)
+  (test #"ab!?x" read-bytes 5 r)
+
+  ;; Check flushing in middle of encoding:
+  (test 3 write-bytes #"ab\303" w2)
+  (test 0 read-bytes-avail!* (make-bytes 10) r)
+  (test 1 write-bytes-avail #"\251x" w2)
+  (test #"ab\303\251" read-bytes 4 r)
+  (test 1 write-bytes-avail #"abc" w2)
+  (test #"a" read-bytes 1 r)
+
+  ;; Check blocking on full pipe:
+  (test 10 write-bytes #"1234567890" w2)
+  (flush-output w2)
+  (test #f sync/timeout 0.0 w)
+  (test #f sync/timeout 0.0 w2)
+  (test 0 write-bytes-avail* #"123" w2)
+  (test 0 write-bytes-avail* #"123" w2)
+  (test 0 write-bytes-avail* #"123" w2)
+  (test #"1234567890" read-bytes 10 r)
+  (test w2 sync/timeout 0.0 w2)
+  (test 1 write-bytes-avail #"123" w2)
+
+  ;; Check specials:
+  (let*-values ([(in out) (make-pipe-with-specials)]
+		[(out2) (reencode-output-port out "UTF-8" #"!")])
+    (test 3 write-bytes #"123" out2)
+    (test #t write-special 'spec out2)
+    (test 3 write-bytes #"456" out2)
+    (flush-output out2)
+    (test #"123" read-bytes 3 in)
+    (test 'spec read-char-or-special in)
+    (test #"456" read-bytes 3 in))
+
+  (void))
+
+;; Check buffer modes:
+(let ([i (open-input-string "abc")]
+      [o (open-output-string)])
+  (test #f file-stream-buffer-mode i)
+  (test #f file-stream-buffer-mode o)
+  (let ([ei (reencode-input-port i "UTF-8")]
+	[eo (reencode-output-port o "UTF-8")])
+    (test 'none file-stream-buffer-mode ei)
+    (test 'block file-stream-buffer-mode eo)
+
+    (test (void) display 10 eo)
+    (test (void) display 12 eo)
+    (test (void) newline eo)
+    (test #"" get-output-bytes o)
+    (test (void) flush-output eo)
+    (test #"1012\n" get-output-bytes o)
+    
+    (test (void) file-stream-buffer-mode eo 'line)
+    (test 'line file-stream-buffer-mode eo)
+    (test (void) display 13 eo)
+    (test #"1012\n" get-output-bytes o)
+    (test (void) newline eo)
+    (test #"1012\n13\n" get-output-bytes o)
+    (test (void) flush-output eo)
+    (test #"1012\n13\n" get-output-bytes o)
+
+    (test (void) display 14 eo)
+    (test #"1012\n13\n" get-output-bytes o)
+    (test (void) file-stream-buffer-mode eo 'none)
+    (test #"1012\n13\n14" get-output-bytes o)
+    (test 'none file-stream-buffer-mode eo)
+    (test (void) display 15 eo)
+    (test #"1012\n13\n1415" get-output-bytes o)
+
+    (test #\a read-char ei)
+    (test #\b peek-char i)
+    (test (void) file-stream-buffer-mode ei 'block)
+    (test 'block file-stream-buffer-mode ei)
+    (test #\b read-char ei)
+    (test eof peek-char i)
+    (test #\c read-char ei)
+    (test eof read-char ei)))
+
+;; --------------------------------------------------
+
+(report-errs)
diff --git a/collects/tests/mzscheme/pp-regression.ss b/collects/tests/mzscheme/pp-regression.ss
new file mode 100644
index 0000000000..af706464a4
--- /dev/null
+++ b/collects/tests/mzscheme/pp-regression.ss
@@ -0,0 +1 @@
+(((mode 31) . #"\"DEPTH=2\" \"GRAPH-ON\" \"STRUCT-ON\" \"LINE-NO-ON\" \"SUPER-WIDE\" :\n0    1!\n0    a!\n0    \"a\"!\n0    (long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line)!\n0    (#<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s>)!\n0    (1)!\n0    (1 2 3)!\n0    (1 . 2)!\n0    #5(1 2 3 4 5)!\n0    (())!\n0    #0=(1 . #0#)!\n0    (#&1 #&a #&\"a\" #&(...) #&(...) #&(...) #&(...) #&(...) #&#5(...) #&(...) #&#0=(...) #&(...) #&(...) #&W{... ...} #&W{... ...} #&#1=W{... ...})!\n0    (1 a \"a\" (long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line) (#<struct:s>) (1) (1 2 3) (1 . 2) #5(1 2 3 4 5) (()) #0=(1 . #0#) (#&...) (end) W{1 2} W{long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line} #1=W{#1# \"c\"})!\n0    W{1 2}!\n0    W{long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line}!\n0    #0=W{#0# \"c\"}!\n") ((mode 30) . #"\"GRAPH-ON\" \"STRUCT-ON\" \"LINE-NO-ON\" \"SUPER-WIDE\" :\n0    1!\n0    a!\n0    \"a\"!\n0    (long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line)!\n0    (#<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s>)!\n0    (1)!\n0    (1 2 3)!\n0    (1 . 2)!\n0    #5(1 2 3 4 5)!\n0    (())!\n0    #0=(1 . #0#)!\n0    (#&1\n1     #&a\n2     #&\"a\"\n3     #&(long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line)\n4     #&(#<struct:s>)\n5     #&(1)\n6     #&(1 2 3)\n7     #&(1 . 2)\n8     #&#5(1 2 3 4 5)\n9     #&(())\n10    #&#1=(1 . #1#)\n11    #&(#&end)\n12    #&(end)\n13    #&W{1 2}\n14    #&W{long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line}\n15    #&#2=W{#2# \"c\"})!\n0    (1 a \"a\" (long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line) (#<struct:s>) (1) (1 2 3) (1 . 2) #5(1 2 3 4 5) (()) #0=(1 . #0#) (#&end) (end) W{1 2} W{long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line} #1=W{#1# \"c\"})!\n0    W{1 2}!\n0    W{long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line}!\n0    #0=W{#0# \"c\"}!\n") ((mode 29) . #"\"DEPTH=2\" \"STRUCT-ON\" \"LINE-NO-ON\" \"SUPER-WIDE\" :\n0    1!\n0    a!\n0    \"a\"!\n0    (long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line)!\n0    (#<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s>)!\n0    (1)!\n0    (1 2 3)!\n0    (1 . 2)!\n0    #5(1 2 3 4 5)!\n0    (())!\n0    #0=(1 . #0#)!\n0    (#&1 #&a #&\"a\" #&(...) #&(...) #&(...) #&(...) #&(...) #&#5(...) #&(...) #&#0=(...) #&(...) #&(...) #&W{... ...} #&W{... ...} #&#1=W{... ...})!\n0    (1 a \"a\" (long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line) (#<struct:s>) (1) (1 2 3) (1 . 2) #5(1 2 3 4 5) (()) #0=(1 . #0#) (#&...) (end) W{1 2} W{long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line} #1=W{#1# \"c\"})!\n0    W{1 2}!\n0    W{long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line}!\n0    #0=W{#0# \"c\"}!\n") ((mode 28) . #"\"STRUCT-ON\" \"LINE-NO-ON\" \"SUPER-WIDE\" :\n0    1!\n0    a!\n0    \"a\"!\n0    (long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line)!\n0    (#<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s>)!\n0    (1)!\n0    (1 2 3)!\n0    (1 . 2)!\n0    #5(1 2 3 4 5)!\n0    (())!\n0    #0=(1 . #0#)!\n0    (#&1\n1     #&a\n2     #&\"a\"\n3     #&(long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line)\n4     #&(#<struct:s>)\n5     #&(1)\n6     #&(1 2 3)\n7     #&(1 . 2)\n8     #&#5(1 2 3 4 5)\n9     #&(())\n10    #&#1=(1 . #1#)\n11    #&(#&end)\n12    #&(end)\n13    #&W{1 2}\n14    #&W{long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line}\n15    #&#2=W{#2# \"c\"})!\n0    (1 a \"a\" (long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line) (#<struct:s>) (1) (1 2 3) (1 . 2) #5(1 2 3 4 5) (()) #0=(1 . #0#) (#&end) (end) W{1 2} W{long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line} #1=W{#1# \"c\"})!\n0    W{1 2}!\n0    W{long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line}!\n0    #0=W{#0# \"c\"}!\n") ((mode 27) . #"\"DEPTH=2\" \"GRAPH-ON\" \"LINE-NO-ON\" \"SUPER-WIDE\" :\n0    1!\n0    a!\n0    \"a\"!\n0    (long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line)!\n0    (#<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s>)!\n0    (1)!\n0    (1 2 3)!\n0    (1 . 2)!\n0    #5(1 2 3 4 5)!\n0    (())!\n0    #0=(1 . #0#)!\n0    (#&1 #&a #&\"a\" #&(...) #&(...) #&(...) #&(...) #&(...) #&#5(...) #&(...) #&#0=(...) #&(...) #&(...) #&W{... ...} #&W{... ...} #&#1=W{... ...})!\n0    (1 a \"a\" (long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line) (#<struct:s>) (1) (1 2 3) (1 . 2) #5(1 2 3 4 5) (()) #0=(1 . #0#) (#&...) (end) W{1 2} W{long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line} #1=W{#1# \"c\"})!\n0    W{1 2}!\n0    W{long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line}!\n0    #0=W{#0# \"c\"}!\n") ((mode 26) . #"\"GRAPH-ON\" \"LINE-NO-ON\" \"SUPER-WIDE\" :\n0    1!\n0    a!\n0    \"a\"!\n0    (long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line)!\n0    (#<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s>)!\n0    (1)!\n0    (1 2 3)!\n0    (1 . 2)!\n0    #5(1 2 3 4 5)!\n0    (())!\n0    #0=(1 . #0#)!\n0    (#&1\n1     #&a\n2     #&\"a\"\n3     #&(long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line)\n4     #&(#<struct:s>)\n5     #&(1)\n6     #&(1 2 3)\n7     #&(1 . 2)\n8     #&#5(1 2 3 4 5)\n9     #&(())\n10    #&#1=(1 . #1#)\n11    #&(#&end)\n12    #&(end)\n13    #&W{1 2}\n14    #&W{long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line}\n15    #&#2=W{#2# \"c\"})!\n0    (1 a \"a\" (long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line) (#<struct:s>) (1) (1 2 3) (1 . 2) #5(1 2 3 4 5) (()) #0=(1 . #0#) (#&end) (end) W{1 2} W{long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line} #1=W{#1# \"c\"})!\n0    W{1 2}!\n0    W{long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line}!\n0    #0=W{#0# \"c\"}!\n") ((mode 25) . #"\"DEPTH=2\" \"LINE-NO-ON\" \"SUPER-WIDE\" :\n0    1!\n0    a!\n0    \"a\"!\n0    (long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line)!\n0    (#<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s>)!\n0    (1)!\n0    (1 2 3)!\n0    (1 . 2)!\n0    #5(1 2 3 4 5)!\n0    (())!\n0    #0=(1 . #0#)!\n0    (#&1 #&a #&\"a\" #&(...) #&(...) #&(...) #&(...) #&(...) #&#5(...) #&(...) #&#0=(...) #&(...) #&(...) #&W{... ...} #&W{... ...} #&#1=W{... ...})!\n0    (1 a \"a\" (long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line) (#<struct:s>) (1) (1 2 3) (1 . 2) #5(1 2 3 4 5) (()) #0=(1 . #0#) (#&...) (end) W{1 2} W{long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line} #1=W{#1# \"c\"})!\n0    W{1 2}!\n0    W{long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line}!\n0    #0=W{#0# \"c\"}!\n") ((mode 24) . #"\"LINE-NO-ON\" \"SUPER-WIDE\" :\n0    1!\n0    a!\n0    \"a\"!\n0    (long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line)!\n0    (#<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s>)!\n0    (1)!\n0    (1 2 3)!\n0    (1 . 2)!\n0    #5(1 2 3 4 5)!\n0    (())!\n0    #0=(1 . #0#)!\n0    (#&1\n1     #&a\n2     #&\"a\"\n3     #&(long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line)\n4     #&(#<struct:s>)\n5     #&(1)\n6     #&(1 2 3)\n7     #&(1 . 2)\n8     #&#5(1 2 3 4 5)\n9     #&(())\n10    #&#1=(1 . #1#)\n11    #&(#&end)\n12    #&(end)\n13    #&W{1 2}\n14    #&W{long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line}\n15    #&#2=W{#2# \"c\"})!\n0    (1 a \"a\" (long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line) (#<struct:s>) (1) (1 2 3) (1 . 2) #5(1 2 3 4 5) (()) #0=(1 . #0#) (#&end) (end) W{1 2} W{long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line} #1=W{#1# \"c\"})!\n0    W{1 2}!\n0    W{long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line}!\n0    #0=W{#0# \"c\"}!\n") ((mode 23) . #"\"DEPTH=2\" \"GRAPH-ON\" \"STRUCT-ON\" \"SUPER-WIDE\" :\n1\na\n\"a\"\n(long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line)\n(#<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s>)\n(1)\n(1 2 3)\n(1 . 2)\n#5(1 2 3 4 5)\n(())\n#0=(1 . #0#)\n(#&1 #&a #&\"a\" #&(...) #&(...) #&(...) #&(...) #&(...) #&#5(...) #&(...) #&#0=(...) #&(...) #&(...) #&W{... ...} #&W{... ...} #&#1=W{... ...})\n(1 a \"a\" (long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line) (#<struct:s>) (1) (1 2 3) (1 . 2) #5(1 2 3 4 5) (()) #0=(1 . #0#) (#&...) (end) W{1 2} W{long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line} #1=W{#1# \"c\"})\nW{1 2}\nW{long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line}\n#0=W{#0# \"c\"}\n") ((mode 22) . #"\"GRAPH-ON\" \"STRUCT-ON\" \"SUPER-WIDE\" :\n1\na\n\"a\"\n(long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line)\n(#<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s>)\n(1)\n(1 2 3)\n(1 . 2)\n#5(1 2 3 4 5)\n(())\n#0=(1 . #0#)\n(#&1\n #&a\n #&\"a\"\n #&(long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line)\n #&(#<struct:s>)\n #&(1)\n #&(1 2 3)\n #&(1 . 2)\n #&#5(1 2 3 4 5)\n #&(())\n #&#1=(1 . #1#)\n #&(#&end)\n #&(end)\n #&W{1 2}\n #&W{long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line}\n #&#2=W{#2# \"c\"})\n(1 a \"a\" (long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line) (#<struct:s>) (1) (1 2 3) (1 . 2) #5(1 2 3 4 5) (()) #0=(1 . #0#) (#&end) (end) W{1 2} W{long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line} #1=W{#1# \"c\"})\nW{1 2}\nW{long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line}\n#0=W{#0# \"c\"}\n") ((mode 21) . #"\"DEPTH=2\" \"STRUCT-ON\" \"SUPER-WIDE\" :\n1\na\n\"a\"\n(long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line)\n(#<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s>)\n(1)\n(1 2 3)\n(1 . 2)\n#5(1 2 3 4 5)\n(())\n#0=(1 . #0#)\n(#&1 #&a #&\"a\" #&(...) #&(...) #&(...) #&(...) #&(...) #&#5(...) #&(...) #&#0=(...) #&(...) #&(...) #&W{... ...} #&W{... ...} #&#1=W{... ...})\n(1 a \"a\" (long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line) (#<struct:s>) (1) (1 2 3) (1 . 2) #5(1 2 3 4 5) (()) #0=(1 . #0#) (#&...) (end) W{1 2} W{long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line} #1=W{#1# \"c\"})\nW{1 2}\nW{long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line}\n#0=W{#0# \"c\"}\n") ((mode 20) . #"\"STRUCT-ON\" \"SUPER-WIDE\" :\n1\na\n\"a\"\n(long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line)\n(#<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s>)\n(1)\n(1 2 3)\n(1 . 2)\n#5(1 2 3 4 5)\n(())\n#0=(1 . #0#)\n(#&1\n #&a\n #&\"a\"\n #&(long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line)\n #&(#<struct:s>)\n #&(1)\n #&(1 2 3)\n #&(1 . 2)\n #&#5(1 2 3 4 5)\n #&(())\n #&#1=(1 . #1#)\n #&(#&end)\n #&(end)\n #&W{1 2}\n #&W{long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line}\n #&#2=W{#2# \"c\"})\n(1 a \"a\" (long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line) (#<struct:s>) (1) (1 2 3) (1 . 2) #5(1 2 3 4 5) (()) #0=(1 . #0#) (#&end) (end) W{1 2} W{long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line} #1=W{#1# \"c\"})\nW{1 2}\nW{long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line}\n#0=W{#0# \"c\"}\n") ((mode 19) . #"\"DEPTH=2\" \"GRAPH-ON\" \"SUPER-WIDE\" :\n1\na\n\"a\"\n(long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line)\n(#<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s>)\n(1)\n(1 2 3)\n(1 . 2)\n#5(1 2 3 4 5)\n(())\n#0=(1 . #0#)\n(#&1 #&a #&\"a\" #&(...) #&(...) #&(...) #&(...) #&(...) #&#5(...) #&(...) #&#0=(...) #&(...) #&(...) #&W{... ...} #&W{... ...} #&#1=W{... ...})\n(1 a \"a\" (long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line) (#<struct:s>) (1) (1 2 3) (1 . 2) #5(1 2 3 4 5) (()) #0=(1 . #0#) (#&...) (end) W{1 2} W{long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line} #1=W{#1# \"c\"})\nW{1 2}\nW{long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line}\n#0=W{#0# \"c\"}\n") ((mode 18) . #"\"GRAPH-ON\" \"SUPER-WIDE\" :\n1\na\n\"a\"\n(long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line)\n(#<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s>)\n(1)\n(1 2 3)\n(1 . 2)\n#5(1 2 3 4 5)\n(())\n#0=(1 . #0#)\n(#&1\n #&a\n #&\"a\"\n #&(long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line)\n #&(#<struct:s>)\n #&(1)\n #&(1 2 3)\n #&(1 . 2)\n #&#5(1 2 3 4 5)\n #&(())\n #&#1=(1 . #1#)\n #&(#&end)\n #&(end)\n #&W{1 2}\n #&W{long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line}\n #&#2=W{#2# \"c\"})\n(1 a \"a\" (long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line) (#<struct:s>) (1) (1 2 3) (1 . 2) #5(1 2 3 4 5) (()) #0=(1 . #0#) (#&end) (end) W{1 2} W{long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line} #1=W{#1# \"c\"})\nW{1 2}\nW{long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line}\n#0=W{#0# \"c\"}\n") ((mode 17) . #"\"DEPTH=2\" \"SUPER-WIDE\" :\n1\na\n\"a\"\n(long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line)\n(#<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s>)\n(1)\n(1 2 3)\n(1 . 2)\n#5(1 2 3 4 5)\n(())\n#0=(1 . #0#)\n(#&1 #&a #&\"a\" #&(...) #&(...) #&(...) #&(...) #&(...) #&#5(...) #&(...) #&#0=(...) #&(...) #&(...) #&W{... ...} #&W{... ...} #&#1=W{... ...})\n(1 a \"a\" (long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line) (#<struct:s>) (1) (1 2 3) (1 . 2) #5(1 2 3 4 5) (()) #0=(1 . #0#) (#&...) (end) W{1 2} W{long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line} #1=W{#1# \"c\"})\nW{1 2}\nW{long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line}\n#0=W{#0# \"c\"}\n") ((mode 16) . #"\"SUPER-WIDE\" :\n1\na\n\"a\"\n(long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line)\n(#<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s> #<struct:s>)\n(1)\n(1 2 3)\n(1 . 2)\n#5(1 2 3 4 5)\n(())\n#0=(1 . #0#)\n(#&1\n #&a\n #&\"a\"\n #&(long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line)\n #&(#<struct:s>)\n #&(1)\n #&(1 2 3)\n #&(1 . 2)\n #&#5(1 2 3 4 5)\n #&(())\n #&#1=(1 . #1#)\n #&(#&end)\n #&(end)\n #&W{1 2}\n #&W{long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line}\n #&#2=W{#2# \"c\"})\n(1 a \"a\" (long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line) (#<struct:s>) (1) (1 2 3) (1 . 2) #5(1 2 3 4 5) (()) #0=(1 . #0#) (#&end) (end) W{1 2} W{long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line} #1=W{#1# \"c\"})\nW{1 2}\nW{long-name-numero-uno-one-the-first-supreme-item long-name-number-two-di-ar-ge-second-line}\n#0=W{#0# \"c\"}\n") ((mode 15) . #"\"DEPTH=2\" \"GRAPH-ON\" \"STRUCT-ON\" \"LINE-NO-ON\" :\n0    1!\n0    a!\n0    \"a\"!\n0    (long-name-numero-uno-one-the-first-supreme-item\n1      long-name-number-two-di-ar-ge-second-line)!\n0    (#<struct:s>\n1     #<struct:s>\n2     #<struct:s>\n3     #<struct:s>\n4     #<struct:s>\n5     #<struct:s>\n6     #<struct:s>\n7     #<struct:s>\n8     #<struct:s>\n9     #<struct:s>\n10    #<struct:s>\n11    #<struct:s>\n12    #<struct:s>\n13    #<struct:s>\n14    #<struct:s>\n15    #<struct:s>)!\n0    (1)!\n0    (1 2 3)!\n0    (1 . 2)!\n0    #5(1 2 3 4 5)!\n0    (())!\n0    #0=(1 . #0#)!\n0    (#&1\n1     #&a\n2     #&\"a\"\n3     #&(...)\n4     #&(...)\n5     #&(...)\n6     #&(...)\n7     #&(...)\n8     #&#5(...)\n9     #&(...)\n10    #&#0=(...)\n11    #&(...)\n12    #&(...)\n13    #&W{... ...}\n14    #&W{... ...}\n15    #&#1=W{... ...})!\n0    (1\n1     a\n2     \"a\"\n3     (long-name-numero-uno-one-the-first-supreme-item\n4       long-name-number-two-di-ar-ge-second-line)\n5     (#<struct:s>)\n6     (1)\n7     (1 2 3)\n8     (1 . 2)\n9     #5(1 2 3 4 5)\n10    (())\n11    #0=(1 . #0#)\n12    (#&...)\n13    (end)\n14    W{1 2}\n15    W{long-name-numero-uno-one-the-first-supreme-item\n16      long-name-number-two-di-ar-ge-second-line}\n17    #1=W{#1# \"c\"})!\n0    W{1 2}!\n0    W{long-name-numero-uno-one-the-first-supreme-item\n1      long-name-number-two-di-ar-ge-second-line}!\n0    #0=W{#0# \"c\"}!\n") ((mode 14) . #"\"GRAPH-ON\" \"STRUCT-ON\" \"LINE-NO-ON\" :\n0    1!\n0    a!\n0    \"a\"!\n0    (long-name-numero-uno-one-the-first-supreme-item\n1      long-name-number-two-di-ar-ge-second-line)!\n0    (#<struct:s>\n1     #<struct:s>\n2     #<struct:s>\n3     #<struct:s>\n4     #<struct:s>\n5     #<struct:s>\n6     #<struct:s>\n7     #<struct:s>\n8     #<struct:s>\n9     #<struct:s>\n10    #<struct:s>\n11    #<struct:s>\n12    #<struct:s>\n13    #<struct:s>\n14    #<struct:s>\n15    #<struct:s>)!\n0    (1)!\n0    (1 2 3)!\n0    (1 . 2)!\n0    #5(1 2 3 4 5)!\n0    (())!\n0    #0=(1 . #0#)!\n0    (#&1\n1     #&a\n2     #&\"a\"\n3     #&(long-name-numero-uno-one-the-first-supreme-item\n4         long-name-number-two-di-ar-ge-second-line)\n5     #&(#<struct:s>)\n6     #&(1)\n7     #&(1 2 3)\n8     #&(1 . 2)\n9     #&#5(1 2 3 4 5)\n10    #&(())\n11    #&#0=(1 . #0#)\n12    #&(#&end)\n13    #&(end)\n14    #&W{1 2}\n15    #&W{long-name-numero-uno-one-the-first-supreme-item\n16        long-name-number-two-di-ar-ge-second-line}\n17    #&#1=W{#1# \"c\"})!\n0    (1\n1     a\n2     \"a\"\n3     (long-name-numero-uno-one-the-first-supreme-item\n4       long-name-number-two-di-ar-ge-second-line)\n5     (#<struct:s>)\n6     (1)\n7     (1 2 3)\n8     (1 . 2)\n9     #5(1 2 3 4 5)\n10    (())\n11    #0=(1 . #0#)\n12    (#&end)\n13    (end)\n14    W{1 2}\n15    W{long-name-numero-uno-one-the-first-supreme-item\n16      long-name-number-two-di-ar-ge-second-line}\n17    #1=W{#1# \"c\"})!\n0    W{1 2}!\n0    W{long-name-numero-uno-one-the-first-supreme-item\n1      long-name-number-two-di-ar-ge-second-line}!\n0    #0=W{#0# \"c\"}!\n") ((mode 13) . #"\"DEPTH=2\" \"STRUCT-ON\" \"LINE-NO-ON\" :\n0    1!\n0    a!\n0    \"a\"!\n0    (long-name-numero-uno-one-the-first-supreme-item\n1      long-name-number-two-di-ar-ge-second-line)!\n0    (#<struct:s>\n1     #<struct:s>\n2     #<struct:s>\n3     #<struct:s>\n4     #<struct:s>\n5     #<struct:s>\n6     #<struct:s>\n7     #<struct:s>\n8     #<struct:s>\n9     #<struct:s>\n10    #<struct:s>\n11    #<struct:s>\n12    #<struct:s>\n13    #<struct:s>\n14    #<struct:s>\n15    #<struct:s>)!\n0    (1)!\n0    (1 2 3)!\n0    (1 . 2)!\n0    #5(1 2 3 4 5)!\n0    (())!\n0    #0=(1 . #0#)!\n0    (#&1\n1     #&a\n2     #&\"a\"\n3     #&(...)\n4     #&(...)\n5     #&(...)\n6     #&(...)\n7     #&(...)\n8     #&#5(...)\n9     #&(...)\n10    #&#0=(...)\n11    #&(...)\n12    #&(...)\n13    #&W{... ...}\n14    #&W{... ...}\n15    #&#1=W{... ...})!\n0    (1\n1     a\n2     \"a\"\n3     (long-name-numero-uno-one-the-first-supreme-item\n4       long-name-number-two-di-ar-ge-second-line)\n5     (#<struct:s>)\n6     (1)\n7     (1 2 3)\n8     (1 . 2)\n9     #5(1 2 3 4 5)\n10    (())\n11    #0=(1 . #0#)\n12    (#&...)\n13    (end)\n14    W{1 2}\n15    W{long-name-numero-uno-one-the-first-supreme-item\n16      long-name-number-two-di-ar-ge-second-line}\n17    #1=W{#1# \"c\"})!\n0    W{1 2}!\n0    W{long-name-numero-uno-one-the-first-supreme-item\n1      long-name-number-two-di-ar-ge-second-line}!\n0    #0=W{#0# \"c\"}!\n") ((mode 12) . #"\"STRUCT-ON\" \"LINE-NO-ON\" :\n0    1!\n0    a!\n0    \"a\"!\n0    (long-name-numero-uno-one-the-first-supreme-item\n1      long-name-number-two-di-ar-ge-second-line)!\n0    (#<struct:s>\n1     #<struct:s>\n2     #<struct:s>\n3     #<struct:s>\n4     #<struct:s>\n5     #<struct:s>\n6     #<struct:s>\n7     #<struct:s>\n8     #<struct:s>\n9     #<struct:s>\n10    #<struct:s>\n11    #<struct:s>\n12    #<struct:s>\n13    #<struct:s>\n14    #<struct:s>\n15    #<struct:s>)!\n0    (1)!\n0    (1 2 3)!\n0    (1 . 2)!\n0    #5(1 2 3 4 5)!\n0    (())!\n0    #0=(1 . #0#)!\n0    (#&1\n1     #&a\n2     #&\"a\"\n3     #&(long-name-numero-uno-one-the-first-supreme-item\n4         long-name-number-two-di-ar-ge-second-line)\n5     #&(#<struct:s>)\n6     #&(1)\n7     #&(1 2 3)\n8     #&(1 . 2)\n9     #&#5(1 2 3 4 5)\n10    #&(())\n11    #&#0=(1 . #0#)\n12    #&(#&end)\n13    #&(end)\n14    #&W{1 2}\n15    #&W{long-name-numero-uno-one-the-first-supreme-item\n16        long-name-number-two-di-ar-ge-second-line}\n17    #&#1=W{#1# \"c\"})!\n0    (1\n1     a\n2     \"a\"\n3     (long-name-numero-uno-one-the-first-supreme-item\n4       long-name-number-two-di-ar-ge-second-line)\n5     (#<struct:s>)\n6     (1)\n7     (1 2 3)\n8     (1 . 2)\n9     #5(1 2 3 4 5)\n10    (())\n11    #0=(1 . #0#)\n12    (#&end)\n13    (end)\n14    W{1 2}\n15    W{long-name-numero-uno-one-the-first-supreme-item\n16      long-name-number-two-di-ar-ge-second-line}\n17    #1=W{#1# \"c\"})!\n0    W{1 2}!\n0    W{long-name-numero-uno-one-the-first-supreme-item\n1      long-name-number-two-di-ar-ge-second-line}!\n0    #0=W{#0# \"c\"}!\n") ((mode 11) . #"\"DEPTH=2\" \"GRAPH-ON\" \"LINE-NO-ON\" :\n0    1!\n0    a!\n0    \"a\"!\n0    (long-name-numero-uno-one-the-first-supreme-item\n1      long-name-number-two-di-ar-ge-second-line)!\n0    (#<struct:s>\n1     #<struct:s>\n2     #<struct:s>\n3     #<struct:s>\n4     #<struct:s>\n5     #<struct:s>\n6     #<struct:s>\n7     #<struct:s>\n8     #<struct:s>\n9     #<struct:s>\n10    #<struct:s>\n11    #<struct:s>\n12    #<struct:s>\n13    #<struct:s>\n14    #<struct:s>\n15    #<struct:s>)!\n0    (1)!\n0    (1 2 3)!\n0    (1 . 2)!\n0    #5(1 2 3 4 5)!\n0    (())!\n0    #0=(1 . #0#)!\n0    (#&1\n1     #&a\n2     #&\"a\"\n3     #&(...)\n4     #&(...)\n5     #&(...)\n6     #&(...)\n7     #&(...)\n8     #&#5(...)\n9     #&(...)\n10    #&#0=(...)\n11    #&(...)\n12    #&(...)\n13    #&W{... ...}\n14    #&W{... ...}\n15    #&#1=W{... ...})!\n0    (1\n1     a\n2     \"a\"\n3     (long-name-numero-uno-one-the-first-supreme-item\n4       long-name-number-two-di-ar-ge-second-line)\n5     (#<struct:s>)\n6     (1)\n7     (1 2 3)\n8     (1 . 2)\n9     #5(1 2 3 4 5)\n10    (())\n11    #0=(1 . #0#)\n12    (#&...)\n13    (end)\n14    W{1 2}\n15    W{long-name-numero-uno-one-the-first-supreme-item\n16      long-name-number-two-di-ar-ge-second-line}\n17    #1=W{#1# \"c\"})!\n0    W{1 2}!\n0    W{long-name-numero-uno-one-the-first-supreme-item\n1      long-name-number-two-di-ar-ge-second-line}!\n0    #0=W{#0# \"c\"}!\n") ((mode 10) . #"\"GRAPH-ON\" \"LINE-NO-ON\" :\n0    1!\n0    a!\n0    \"a\"!\n0    (long-name-numero-uno-one-the-first-supreme-item\n1      long-name-number-two-di-ar-ge-second-line)!\n0    (#<struct:s>\n1     #<struct:s>\n2     #<struct:s>\n3     #<struct:s>\n4     #<struct:s>\n5     #<struct:s>\n6     #<struct:s>\n7     #<struct:s>\n8     #<struct:s>\n9     #<struct:s>\n10    #<struct:s>\n11    #<struct:s>\n12    #<struct:s>\n13    #<struct:s>\n14    #<struct:s>\n15    #<struct:s>)!\n0    (1)!\n0    (1 2 3)!\n0    (1 . 2)!\n0    #5(1 2 3 4 5)!\n0    (())!\n0    #0=(1 . #0#)!\n0    (#&1\n1     #&a\n2     #&\"a\"\n3     #&(long-name-numero-uno-one-the-first-supreme-item\n4         long-name-number-two-di-ar-ge-second-line)\n5     #&(#<struct:s>)\n6     #&(1)\n7     #&(1 2 3)\n8     #&(1 . 2)\n9     #&#5(1 2 3 4 5)\n10    #&(())\n11    #&#0=(1 . #0#)\n12    #&(#&end)\n13    #&(end)\n14    #&W{1 2}\n15    #&W{long-name-numero-uno-one-the-first-supreme-item\n16        long-name-number-two-di-ar-ge-second-line}\n17    #&#1=W{#1# \"c\"})!\n0    (1\n1     a\n2     \"a\"\n3     (long-name-numero-uno-one-the-first-supreme-item\n4       long-name-number-two-di-ar-ge-second-line)\n5     (#<struct:s>)\n6     (1)\n7     (1 2 3)\n8     (1 . 2)\n9     #5(1 2 3 4 5)\n10    (())\n11    #0=(1 . #0#)\n12    (#&end)\n13    (end)\n14    W{1 2}\n15    W{long-name-numero-uno-one-the-first-supreme-item\n16      long-name-number-two-di-ar-ge-second-line}\n17    #1=W{#1# \"c\"})!\n0    W{1 2}!\n0    W{long-name-numero-uno-one-the-first-supreme-item\n1      long-name-number-two-di-ar-ge-second-line}!\n0    #0=W{#0# \"c\"}!\n") ((mode 9) . #"\"DEPTH=2\" \"LINE-NO-ON\" :\n0    1!\n0    a!\n0    \"a\"!\n0    (long-name-numero-uno-one-the-first-supreme-item\n1      long-name-number-two-di-ar-ge-second-line)!\n0    (#<struct:s>\n1     #<struct:s>\n2     #<struct:s>\n3     #<struct:s>\n4     #<struct:s>\n5     #<struct:s>\n6     #<struct:s>\n7     #<struct:s>\n8     #<struct:s>\n9     #<struct:s>\n10    #<struct:s>\n11    #<struct:s>\n12    #<struct:s>\n13    #<struct:s>\n14    #<struct:s>\n15    #<struct:s>)!\n0    (1)!\n0    (1 2 3)!\n0    (1 . 2)!\n0    #5(1 2 3 4 5)!\n0    (())!\n0    #0=(1 . #0#)!\n0    (#&1\n1     #&a\n2     #&\"a\"\n3     #&(...)\n4     #&(...)\n5     #&(...)\n6     #&(...)\n7     #&(...)\n8     #&#5(...)\n9     #&(...)\n10    #&#0=(...)\n11    #&(...)\n12    #&(...)\n13    #&W{... ...}\n14    #&W{... ...}\n15    #&#1=W{... ...})!\n0    (1\n1     a\n2     \"a\"\n3     (long-name-numero-uno-one-the-first-supreme-item\n4       long-name-number-two-di-ar-ge-second-line)\n5     (#<struct:s>)\n6     (1)\n7     (1 2 3)\n8     (1 . 2)\n9     #5(1 2 3 4 5)\n10    (())\n11    #0=(1 . #0#)\n12    (#&...)\n13    (end)\n14    W{1 2}\n15    W{long-name-numero-uno-one-the-first-supreme-item\n16      long-name-number-two-di-ar-ge-second-line}\n17    #1=W{#1# \"c\"})!\n0    W{1 2}!\n0    W{long-name-numero-uno-one-the-first-supreme-item\n1      long-name-number-two-di-ar-ge-second-line}!\n0    #0=W{#0# \"c\"}!\n") ((mode 8) . #"\"LINE-NO-ON\" :\n0    1!\n0    a!\n0    \"a\"!\n0    (long-name-numero-uno-one-the-first-supreme-item\n1      long-name-number-two-di-ar-ge-second-line)!\n0    (#<struct:s>\n1     #<struct:s>\n2     #<struct:s>\n3     #<struct:s>\n4     #<struct:s>\n5     #<struct:s>\n6     #<struct:s>\n7     #<struct:s>\n8     #<struct:s>\n9     #<struct:s>\n10    #<struct:s>\n11    #<struct:s>\n12    #<struct:s>\n13    #<struct:s>\n14    #<struct:s>\n15    #<struct:s>)!\n0    (1)!\n0    (1 2 3)!\n0    (1 . 2)!\n0    #5(1 2 3 4 5)!\n0    (())!\n0    #0=(1 . #0#)!\n0    (#&1\n1     #&a\n2     #&\"a\"\n3     #&(long-name-numero-uno-one-the-first-supreme-item\n4         long-name-number-two-di-ar-ge-second-line)\n5     #&(#<struct:s>)\n6     #&(1)\n7     #&(1 2 3)\n8     #&(1 . 2)\n9     #&#5(1 2 3 4 5)\n10    #&(())\n11    #&#0=(1 . #0#)\n12    #&(#&end)\n13    #&(end)\n14    #&W{1 2}\n15    #&W{long-name-numero-uno-one-the-first-supreme-item\n16        long-name-number-two-di-ar-ge-second-line}\n17    #&#1=W{#1# \"c\"})!\n0    (1\n1     a\n2     \"a\"\n3     (long-name-numero-uno-one-the-first-supreme-item\n4       long-name-number-two-di-ar-ge-second-line)\n5     (#<struct:s>)\n6     (1)\n7     (1 2 3)\n8     (1 . 2)\n9     #5(1 2 3 4 5)\n10    (())\n11    #0=(1 . #0#)\n12    (#&end)\n13    (end)\n14    W{1 2}\n15    W{long-name-numero-uno-one-the-first-supreme-item\n16      long-name-number-two-di-ar-ge-second-line}\n17    #1=W{#1# \"c\"})!\n0    W{1 2}!\n0    W{long-name-numero-uno-one-the-first-supreme-item\n1      long-name-number-two-di-ar-ge-second-line}!\n0    #0=W{#0# \"c\"}!\n") ((mode 7) . #"\"DEPTH=2\" \"GRAPH-ON\" \"STRUCT-ON\" :\n1\na\n\"a\"\n(long-name-numero-uno-one-the-first-supreme-item\n  long-name-number-two-di-ar-ge-second-line)\n(#<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>)\n(1)\n(1 2 3)\n(1 . 2)\n#5(1 2 3 4 5)\n(())\n#0=(1 . #0#)\n(#&1\n #&a\n #&\"a\"\n #&(...)\n #&(...)\n #&(...)\n #&(...)\n #&(...)\n #&#5(...)\n #&(...)\n #&#1=(...)\n #&(...)\n #&(...)\n #&W{... ...}\n #&W{... ...}\n #&#2=W{... ...})\n(1\n a\n \"a\"\n (long-name-numero-uno-one-the-first-supreme-item\n   long-name-number-two-di-ar-ge-second-line)\n (#<struct:s>)\n (1)\n (1 2 3)\n (1 . 2)\n #5(1 2 3 4 5)\n (())\n #0=(1 . #0#)\n (#&...)\n (end)\n W{1 2}\n W{long-name-numero-uno-one-the-first-supreme-item\n   long-name-number-two-di-ar-ge-second-line}\n #1=W{#1# \"c\"})\nW{1 2}\nW{long-name-numero-uno-one-the-first-supreme-item\n  long-name-number-two-di-ar-ge-second-line}\n#0=W{#0# \"c\"}\n") ((mode 6) . #"\"GRAPH-ON\" \"STRUCT-ON\" :\n1\na\n\"a\"\n(long-name-numero-uno-one-the-first-supreme-item\n  long-name-number-two-di-ar-ge-second-line)\n(#<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>)\n(1)\n(1 2 3)\n(1 . 2)\n#5(1 2 3 4 5)\n(())\n#0=(1 . #0#)\n(#&1\n #&a\n #&\"a\"\n #&(long-name-numero-uno-one-the-first-supreme-item\n     long-name-number-two-di-ar-ge-second-line)\n #&(#<struct:s>)\n #&(1)\n #&(1 2 3)\n #&(1 . 2)\n #&#5(1 2 3 4 5)\n #&(())\n #&#0=(1 . #0#)\n #&(#&end)\n #&(end)\n #&W{1 2}\n #&W{long-name-numero-uno-one-the-first-supreme-item\n     long-name-number-two-di-ar-ge-second-line}\n #&#1=W{#1# \"c\"})\n(1\n a\n \"a\"\n (long-name-numero-uno-one-the-first-supreme-item\n   long-name-number-two-di-ar-ge-second-line)\n (#<struct:s>)\n (1)\n (1 2 3)\n (1 . 2)\n #5(1 2 3 4 5)\n (())\n #0=(1 . #0#)\n (#&end)\n (end)\n W{1 2}\n W{long-name-numero-uno-one-the-first-supreme-item\n   long-name-number-two-di-ar-ge-second-line}\n #1=W{#1# \"c\"})\nW{1 2}\nW{long-name-numero-uno-one-the-first-supreme-item\n  long-name-number-two-di-ar-ge-second-line}\n#0=W{#0# \"c\"}\n") ((mode 5) . #"\"DEPTH=2\" \"STRUCT-ON\" :\n1\na\n\"a\"\n(long-name-numero-uno-one-the-first-supreme-item\n  long-name-number-two-di-ar-ge-second-line)\n(#<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>)\n(1)\n(1 2 3)\n(1 . 2)\n#5(1 2 3 4 5)\n(())\n#0=(1 . #0#)\n(#&1\n #&a\n #&\"a\"\n #&(...)\n #&(...)\n #&(...)\n #&(...)\n #&(...)\n #&#5(...)\n #&(...)\n #&#1=(...)\n #&(...)\n #&(...)\n #&W{... ...}\n #&W{... ...}\n #&#2=W{... ...})\n(1\n a\n \"a\"\n (long-name-numero-uno-one-the-first-supreme-item\n   long-name-number-two-di-ar-ge-second-line)\n (#<struct:s>)\n (1)\n (1 2 3)\n (1 . 2)\n #5(1 2 3 4 5)\n (())\n #0=(1 . #0#)\n (#&...)\n (end)\n W{1 2}\n W{long-name-numero-uno-one-the-first-supreme-item\n   long-name-number-two-di-ar-ge-second-line}\n #1=W{#1# \"c\"})\nW{1 2}\nW{long-name-numero-uno-one-the-first-supreme-item\n  long-name-number-two-di-ar-ge-second-line}\n#0=W{#0# \"c\"}\n") ((mode 4) . #"\"STRUCT-ON\" :\n1\na\n\"a\"\n(long-name-numero-uno-one-the-first-supreme-item\n  long-name-number-two-di-ar-ge-second-line)\n(#<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>)\n(1)\n(1 2 3)\n(1 . 2)\n#5(1 2 3 4 5)\n(())\n#0=(1 . #0#)\n(#&1\n #&a\n #&\"a\"\n #&(long-name-numero-uno-one-the-first-supreme-item\n     long-name-number-two-di-ar-ge-second-line)\n #&(#<struct:s>)\n #&(1)\n #&(1 2 3)\n #&(1 . 2)\n #&#5(1 2 3 4 5)\n #&(())\n #&#0=(1 . #0#)\n #&(#&end)\n #&(end)\n #&W{1 2}\n #&W{long-name-numero-uno-one-the-first-supreme-item\n     long-name-number-two-di-ar-ge-second-line}\n #&#1=W{#1# \"c\"})\n(1\n a\n \"a\"\n (long-name-numero-uno-one-the-first-supreme-item\n   long-name-number-two-di-ar-ge-second-line)\n (#<struct:s>)\n (1)\n (1 2 3)\n (1 . 2)\n #5(1 2 3 4 5)\n (())\n #0=(1 . #0#)\n (#&end)\n (end)\n W{1 2}\n W{long-name-numero-uno-one-the-first-supreme-item\n   long-name-number-two-di-ar-ge-second-line}\n #1=W{#1# \"c\"})\nW{1 2}\nW{long-name-numero-uno-one-the-first-supreme-item\n  long-name-number-two-di-ar-ge-second-line}\n#0=W{#0# \"c\"}\n") ((mode 3) . #"\"DEPTH=2\" \"GRAPH-ON\" :\n1\na\n\"a\"\n(long-name-numero-uno-one-the-first-supreme-item\n  long-name-number-two-di-ar-ge-second-line)\n(#<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>)\n(1)\n(1 2 3)\n(1 . 2)\n#5(1 2 3 4 5)\n(())\n#0=(1 . #0#)\n(#&1\n #&a\n #&\"a\"\n #&(...)\n #&(...)\n #&(...)\n #&(...)\n #&(...)\n #&#5(...)\n #&(...)\n #&#1=(...)\n #&(...)\n #&(...)\n #&W{... ...}\n #&W{... ...}\n #&#2=W{... ...})\n(1\n a\n \"a\"\n (long-name-numero-uno-one-the-first-supreme-item\n   long-name-number-two-di-ar-ge-second-line)\n (#<struct:s>)\n (1)\n (1 2 3)\n (1 . 2)\n #5(1 2 3 4 5)\n (())\n #0=(1 . #0#)\n (#&...)\n (end)\n W{1 2}\n W{long-name-numero-uno-one-the-first-supreme-item\n   long-name-number-two-di-ar-ge-second-line}\n #1=W{#1# \"c\"})\nW{1 2}\nW{long-name-numero-uno-one-the-first-supreme-item\n  long-name-number-two-di-ar-ge-second-line}\n#0=W{#0# \"c\"}\n") ((mode 2) . #"\"GRAPH-ON\" :\n1\na\n\"a\"\n(long-name-numero-uno-one-the-first-supreme-item\n  long-name-number-two-di-ar-ge-second-line)\n(#<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>)\n(1)\n(1 2 3)\n(1 . 2)\n#5(1 2 3 4 5)\n(())\n#0=(1 . #0#)\n(#&1\n #&a\n #&\"a\"\n #&(long-name-numero-uno-one-the-first-supreme-item\n     long-name-number-two-di-ar-ge-second-line)\n #&(#<struct:s>)\n #&(1)\n #&(1 2 3)\n #&(1 . 2)\n #&#5(1 2 3 4 5)\n #&(())\n #&#0=(1 . #0#)\n #&(#&end)\n #&(end)\n #&W{1 2}\n #&W{long-name-numero-uno-one-the-first-supreme-item\n     long-name-number-two-di-ar-ge-second-line}\n #&#1=W{#1# \"c\"})\n(1\n a\n \"a\"\n (long-name-numero-uno-one-the-first-supreme-item\n   long-name-number-two-di-ar-ge-second-line)\n (#<struct:s>)\n (1)\n (1 2 3)\n (1 . 2)\n #5(1 2 3 4 5)\n (())\n #0=(1 . #0#)\n (#&end)\n (end)\n W{1 2}\n W{long-name-numero-uno-one-the-first-supreme-item\n   long-name-number-two-di-ar-ge-second-line}\n #1=W{#1# \"c\"})\nW{1 2}\nW{long-name-numero-uno-one-the-first-supreme-item\n  long-name-number-two-di-ar-ge-second-line}\n#0=W{#0# \"c\"}\n") ((mode 1) . #"\"DEPTH=2\" :\n1\na\n\"a\"\n(long-name-numero-uno-one-the-first-supreme-item\n  long-name-number-two-di-ar-ge-second-line)\n(#<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>)\n(1)\n(1 2 3)\n(1 . 2)\n#5(1 2 3 4 5)\n(())\n#0=(1 . #0#)\n(#&1\n #&a\n #&\"a\"\n #&(...)\n #&(...)\n #&(...)\n #&(...)\n #&(...)\n #&#5(...)\n #&(...)\n #&#1=(...)\n #&(...)\n #&(...)\n #&W{... ...}\n #&W{... ...}\n #&#2=W{... ...})\n(1\n a\n \"a\"\n (long-name-numero-uno-one-the-first-supreme-item\n   long-name-number-two-di-ar-ge-second-line)\n (#<struct:s>)\n (1)\n (1 2 3)\n (1 . 2)\n #5(1 2 3 4 5)\n (())\n #0=(1 . #0#)\n (#&...)\n (end)\n W{1 2}\n W{long-name-numero-uno-one-the-first-supreme-item\n   long-name-number-two-di-ar-ge-second-line}\n #1=W{#1# \"c\"})\nW{1 2}\nW{long-name-numero-uno-one-the-first-supreme-item\n  long-name-number-two-di-ar-ge-second-line}\n#0=W{#0# \"c\"}\n") ((mode 0) . #":\n1\na\n\"a\"\n(long-name-numero-uno-one-the-first-supreme-item\n  long-name-number-two-di-ar-ge-second-line)\n(#<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>\n #<struct:s>)\n(1)\n(1 2 3)\n(1 . 2)\n#5(1 2 3 4 5)\n(())\n#0=(1 . #0#)\n(#&1\n #&a\n #&\"a\"\n #&(long-name-numero-uno-one-the-first-supreme-item\n     long-name-number-two-di-ar-ge-second-line)\n #&(#<struct:s>)\n #&(1)\n #&(1 2 3)\n #&(1 . 2)\n #&#5(1 2 3 4 5)\n #&(())\n #&#0=(1 . #0#)\n #&(#&end)\n #&(end)\n #&W{1 2}\n #&W{long-name-numero-uno-one-the-first-supreme-item\n     long-name-number-two-di-ar-ge-second-line}\n #&#1=W{#1# \"c\"})\n(1\n a\n \"a\"\n (long-name-numero-uno-one-the-first-supreme-item\n   long-name-number-two-di-ar-ge-second-line)\n (#<struct:s>)\n (1)\n (1 2 3)\n (1 . 2)\n #5(1 2 3 4 5)\n (())\n #0=(1 . #0#)\n (#&end)\n (end)\n W{1 2}\n W{long-name-numero-uno-one-the-first-supreme-item\n   long-name-number-two-di-ar-ge-second-line}\n #1=W{#1# \"c\"})\nW{1 2}\nW{long-name-numero-uno-one-the-first-supreme-item\n  long-name-number-two-di-ar-ge-second-line}\n#0=W{#0# \"c\"}\n"))
\ No newline at end of file
diff --git a/collects/tests/mzscheme/pretty.ss b/collects/tests/mzscheme/pretty.ss
new file mode 100644
index 0000000000..9f097baf1a
--- /dev/null
+++ b/collects/tests/mzscheme/pretty.ss
@@ -0,0 +1,215 @@
+
+; Test pretty-print.
+
+;; Regression test results in pp-regression.ss. When things
+;;  have to change, re-run with `record-for-regression?' to #t.
+(define record-for-regression? #f)
+;; Disable `use-regression?' when inspecting results after a
+;;  changed; when it's ok, then record the new regression results.
+(define use-regression? #t)
+
+(load-relative "loadtest.ss")
+
+(SECTION 'PRETTY)
+
+(require (lib "pretty.ss"))
+
+(define (pprec-print pprec port write?)
+  (define (print-one n port)
+    ((if write? write display) (pprec-ref pprec n) port))
+  (let ([pp? (and (pretty-printing)
+		  (number? (pretty-print-columns)))])
+    (write-string (if write? "W{" "D{") port)
+    (let-values ([(l c p) (if pp?
+			      (port-next-location port)
+			      (values 0 0 0))])
+      (print-one 0 port)
+      (if pp?
+	  (let* ([mx (- (pretty-print-columns) 1)]
+		 [tp (make-tentative-pretty-print-output-port
+		      port
+		      mx
+		      void)])
+	    (write-string " " tp)
+	    (print-one 1 tp)
+	    (let-values ([(xl xc xp) (port-next-location tp)])
+	      (if (xc . < . mx)
+		  (tentative-pretty-print-port-transfer tp port)
+		  (begin
+		    (tentative-pretty-print-port-cancel tp)
+		    (let ([cnt (pretty-print-newline port mx)])
+		      (write-string (make-string (max 0 (- c cnt)) #\space) port))
+		    (print-one 1 port)))))
+	  (begin
+	    (write-string " " port)
+	    (print-one 1 port)))
+      (write-string "}" port))))
+
+(define-values (s:pprec make-pprec pprec? pprec-ref pprec-set!)
+  (make-struct-type 'pprec #f 2 0 #f
+		    (list (cons prop:custom-write pprec-print))))
+
+(define (pp-string v)
+  (let ([p (open-output-string)])
+    (pretty-print v p)
+    (let ([s (get-output-string p)])
+      (substring s 0 (sub1 (string-length s))))))
+
+(test "10" pp-string 10)
+(test "1/2" pp-string 1/2)
+(test "-1/2" pp-string -1/2)
+(test "1/2+3/4i" pp-string 1/2+3/4i)
+(test "0.333" pp-string #i0.333)
+(test "2.0+1.0i" pp-string #i2+1i)
+(test "'a" pp-string ''a)
+(test "`a" pp-string '`a)
+(test ",a" pp-string ',a)
+(test ",@a" pp-string ',@a)
+(test "#'a" pp-string '#'a)
+(test "W{1 2}" pp-string (make-pprec 1 2))
+
+(test #t pretty-print-style-table? (pretty-print-current-style-table))
+(test #t pretty-print-style-table? (pretty-print-extend-style-table #f null null))
+(test #t pretty-print-style-table? (pretty-print-extend-style-table (pretty-print-current-style-table) null null))
+
+(parameterize ([pretty-print-columns 20])
+  (test "(1234567890 1 2 3 4)" pp-string '(1234567890 1 2 3 4))
+  (test "(1234567890xx\n  1\n  2\n  3\n  4)" pp-string '(1234567890xx 1 2 3 4))
+  (test "(lambda 1234567890\n  1\n  2\n  3\n  4)" pp-string '(lambda 1234567890 1 2 3 4))
+  (let ([table (pretty-print-extend-style-table #f null null)])
+    (parameterize ([pretty-print-current-style-table 
+                    (pretty-print-extend-style-table table '(lambda) '(list))])
+      (test "(lambda\n  1234567890\n  1\n  2\n  3\n  4)" pp-string '(lambda 1234567890 1 2 3 4)))
+    (test "(lambda 1234567890\n  1\n  2\n  3\n  4)" pp-string '(lambda 1234567890 1 2 3 4))
+    (parameterize ([pretty-print-current-style-table table])
+      (test "(lambda 1234567890\n  1\n  2\n  3\n  4)" pp-string '(lambda 1234567890 1 2 3 4)))))
+
+(parameterize ([pretty-print-exact-as-decimal #t])
+  (test "10" pp-string 10)
+  (test "0.5" pp-string 1/2)
+  (test "-0.5" pp-string -1/2)
+  (test "3500.5" pp-string 7001/2)
+  (test "0.0001220703125" pp-string 1/8192)
+  (test "0.0000000000000006869768746897623487"
+	pp-string 6869768746897623487/10000000000000000000000000000000000)
+  (test "0.00000000000001048576" pp-string (/ (expt 5 20)))
+  
+  (test "1/3" pp-string 1/3)
+  (test "1/300000000000000000000000" pp-string 1/300000000000000000000000)
+  
+  (test "0.5+0.75i" pp-string 1/2+3/4i)
+  (test "0.5-0.75i" pp-string 1/2-3/4i)
+  (test "1/9+3/17i" pp-string 1/9+3/17i)
+  (test "0.333" pp-string #i0.333)
+  (test "2.0+1.0i" pp-string #i2+1i))
+
+(parameterize ([print-struct #t])
+  (let ()
+    (define-struct s (x) (make-inspector))
+    (test "#(struct:s 1)" pp-string (make-s 1))))
+
+(err/rt-test (pretty-print-extend-style-table 'ack '(a) '(b)))
+(err/rt-test (pretty-print-extend-style-table (pretty-print-current-style-table) 'a '(b)))
+(err/rt-test (pretty-print-extend-style-table (pretty-print-current-style-table) '(1) '(b)))
+(err/rt-test (pretty-print-extend-style-table (pretty-print-current-style-table) '(a) 'b))
+(err/rt-test (pretty-print-extend-style-table (pretty-print-current-style-table) '(a) '(1)))
+(err/rt-test (pretty-print-extend-style-table (pretty-print-current-style-table) '(a) '(b c)) exn:application:mismatch?)
+
+(define-struct s (a b c))
+
+(define (make k?)
+  (let ([make (if k? make (lambda (x) '(end)))])
+    (list
+     1
+     'a
+     "a"
+     (list 'long-name-numero-uno-one-the-first-supreme-item
+	   'long-name-number-two-di-ar-ge-second-line)
+     (map (lambda (v v2)
+	    (make-s v 2 v2))
+	  (make #f)
+	  (reverse (make #f)))
+     '(1)
+     '(1 2 3)
+     '(1 . 2)
+     #(1 2 3 4 5)
+     (read (open-input-string "(#0=() . #0#)"))
+     (read (open-input-string "#1=(1 . #1#)"))
+     (map box (make #f))
+     (make #f)
+     (make-pprec 1 2)
+     (make-pprec 'long-name-numero-uno-one-the-first-supreme-item
+		 'long-name-number-two-di-ar-ge-second-line)
+     (let ([p (make-pprec "a" "c")])
+       (pprec-set! p 0 p)
+       p))))
+
+(define vs (make #t))
+
+(define print-line-no
+  (lambda (line port offset width) 
+    (if line         
+	(begin
+	  (when (positive? line) (write-char #\newline port))
+	  (fprintf port "~s~a~a~a " line
+		   (if (< line 10) " " "")
+		   (if (< line 100) " " "")
+		   (if (< line 1000) " " ""))
+	  5)
+	(fprintf port "!~n"))))
+
+(define modes
+  (list
+   (list "DEPTH=2" pretty-print-depth 2)
+   (list "GRAPH-ON" print-graph #t)
+   (list "STRUCT-ON" print-struct #t)
+   (list "LINE-NO-ON" pretty-print-print-line print-line-no)
+   (list "SUPER-WIDE" pretty-print-columns 300)))
+
+(define num-combinations (arithmetic-shift 1 (length modes)))
+
+(define regression-path
+  (build-path (current-load-relative-directory)
+	      "pp-regression.ss"))
+
+(define recorded (if record-for-regression?
+		     null
+		     (with-input-from-file regression-path
+		       read)))
+
+(define (record-or-check id thunk)
+  (if use-regression?
+      (let ([str (let ([p (open-output-bytes)])
+		   (parameterize ([current-output-port p])
+		     (thunk))
+		   (get-output-bytes p))])
+	(if record-for-regression?
+	    (set! recorded (cons (cons id str) recorded))
+	    (test (cdr (assoc id recorded)) values str)))
+      (thunk)))
+
+(let loop ([n 0])
+  (when (< n num-combinations)
+    (record-or-check
+     `(mode ,n)
+     (lambda ()
+       (let loop ([modes modes][n n])
+	 (cond
+	  [(null? modes) (printf ":~n") (map pretty-print vs)]
+	  [(positive? (bitwise-and n 1))
+	   (let ([mode (car modes)])
+	     (printf "~s " (car mode))
+	     (parameterize ([(cadr mode) (caddr mode)])
+	       (loop (cdr modes) (arithmetic-shift n -1))))]
+	  [else
+	   (loop (cdr modes) (arithmetic-shift n -1))]))))
+    (loop (add1 n))))
+
+(when record-for-regression?
+  (with-output-to-file regression-path
+    (lambda () (write recorded))
+    'truncate/replace))
+
+(test #t 'use-regression? use-regression?)
+
+(report-errs)
diff --git a/collects/tests/mzscheme/quiet.ss b/collects/tests/mzscheme/quiet.ss
new file mode 100644
index 0000000000..f966c9295e
--- /dev/null
+++ b/collects/tests/mzscheme/quiet.ss
@@ -0,0 +1,14 @@
+
+(namespace-variable-value 
+ 'quiet-load
+ #f
+ (lambda ()
+   (namespace-set-variable-value! 'quiet-load "all.ss")))
+
+(let ([p (make-output-port 'quiet 
+			   always-evt
+			   (lambda (str s e nonblock? breakable?) (- e s))
+			   void)])
+  (parameterize ([current-output-port p])
+      (load-relative quiet-load))
+  (report-errs))
diff --git a/collects/tests/mzscheme/read.ss b/collects/tests/mzscheme/read.ss
new file mode 100644
index 0000000000..a1dcaf4086
--- /dev/null
+++ b/collects/tests/mzscheme/read.ss
@@ -0,0 +1,918 @@
+
+(load-relative "loadtest.ss")
+
+(SECTION 'READING)
+(define readstr
+  (lambda (s)
+    (let* ([o (open-input-string s)]
+	   [read (lambda () (read o))])
+      (let loop ([last eof])
+	(let ([v (read)])
+	  (if (eof-object? v)
+	      last
+	      (loop v)))))))
+
+(define readerrtype
+  (lambda (x) x))
+
+; Make sure {whitespace} == {delimiter}
+(let ([with-censor (load-relative "censor.ss")])
+  (with-censor
+   (lambda ()
+     (let loop ([n 0])
+       (unless (= n 256)
+	 (let* ([c0 (integer->char n)]
+		[c (if (read-case-sensitive)
+		       c0
+		       (char-downcase c0))])
+	   (cond
+	    [(char-whitespace? c)
+	     (test 'b readstr (string #\a c #\b))]
+	    [(char=? #\\ c) (test 'ab readstr (string #\a c #\b))]
+	    [(char=? #\; c) (test 'a readstr (string #\a c #\b))]
+	    [(char=? #\' c) (test ''b readstr (string #\a c #\b))]
+	    [(char=? #\` c) (test '`b readstr (string #\a c #\b))]
+	    [(char=? #\, c) (test ',b readstr (string #\a c #\b))]
+	    [else
+	     (test (string->symbol (string #\a c #\b))
+		   'readstr
+		   (with-handlers ([void 
+				    (lambda (x) 
+				      (string->symbol (string #\a c #\b)))])
+		     (readstr (string #\a c0 #\b))))]))
+	 (loop (add1 n)))))))
+
+(err/rt-test (readstr ")") exn:fail:read?)
+(err/rt-test (readstr "[)") exn:fail:read?)
+(err/rt-test (readstr "[}") exn:fail:read?)
+(err/rt-test (readstr "8 )") exn:fail:read?)
+(err/rt-test (readstr "(. )") exn:fail:read?)
+(err/rt-test (readstr "(. 8)") exn:fail:read?)
+(err/rt-test (readstr "(8 . )") exn:fail:read?)
+(err/rt-test (readstr "(8 . ]") exn:fail:read?)
+(err/rt-test (readstr "(8 . 9 . )") exn:fail:read?)
+(err/rt-test (readstr "(8 . 9 . ]") exn:fail:read?)
+(err/rt-test (readstr "(8 . 9 . 1 . )") exn:fail:read?)
+(err/rt-test (readstr "(8 . 9 . 1 . 10)") exn:fail:read?)
+
+(test (integer->char 0) readstr "#\\nul")
+(test (integer->char 0) readstr "#\\Nul")
+(test (integer->char 0) readstr "#\\NuL")
+(test (integer->char 0) readstr "#\\null")
+(test (integer->char 0) readstr "#\\Null")
+(test (integer->char 0) readstr "#\\NulL")
+(test (integer->char 8) readstr "#\\Backspace")
+(test (integer->char 8) readstr "#\\BacksPace")
+(test (integer->char 9) readstr "#\\tab")
+(test (integer->char 9) readstr "#\\Tab")
+(test (integer->char 9) readstr "#\\TaB")
+(test (integer->char 10) readstr "#\\newline")
+(test (integer->char 10) readstr "#\\Newline")
+(test (integer->char 10) readstr "#\\NewLine")
+(test (integer->char 10) readstr "#\\linefeed")
+(test (integer->char 10) readstr "#\\Linefeed")
+(test (integer->char 10) readstr "#\\LinefEeD")
+(test (integer->char 11) readstr "#\\vtab")
+(test (integer->char 11) readstr "#\\Vtab")
+(test (integer->char 11) readstr "#\\VtAb")
+(test (integer->char 12) readstr "#\\page")
+(test (integer->char 12) readstr "#\\Page")
+(test (integer->char 12) readstr "#\\PaGe")
+(test (integer->char 13) readstr "#\\return")
+(test (integer->char 13) readstr "#\\Return")
+(test (integer->char 13) readstr "#\\retUrn")
+(test (integer->char 127) readstr "#\\rubout")
+(test (integer->char 127) readstr "#\\Rubout")
+(test (integer->char 127) readstr "#\\RubOut")
+(test (integer->char #x1) readstr "#\\u1")
+(test (integer->char #x10) readstr "#\\u10")
+(test (integer->char #x100) readstr "#\\u100")
+(test (integer->char #x1000) readstr "#\\u1000")
+(test (integer->char #xa) readstr "#\\ua")
+(test (integer->char #xa7) readstr "#\\uA7")
+(test (integer->char #xa77) readstr "#\\ua77")
+(test (integer->char #xa77C) readstr "#\\uA77C")
+(test 0 readstr "#\\u10000")
+(test 'a readstr "#\\ua000a")
+(test 'x readstr "#\\ua000x")
+(test (integer->char #xa) readstr "#\\Ua")
+(test (integer->char #xa7) readstr "#\\UA7")
+(test (integer->char #xa77) readstr "#\\Ua77")
+(test (integer->char #xa77C) readstr "#\\UA77C")
+(test (integer->char #x10000) readstr "#\\U10000")
+(test (integer->char #x100000) readstr "#\\U100000")
+(test (integer->char #x10FFFF) readstr "#\\U10FFFF")
+(test 0 readstr "#\\U100000000")
+
+(err/rt-test (readstr "#\\uD800") exn:fail:read?)
+(err/rt-test (readstr "#\\uD900") exn:fail:read?)
+(err/rt-test (readstr "#\\UDFFF") exn:fail:read?)
+(err/rt-test (readstr "#\\UFFFFFF") exn:fail:read?)
+(err/rt-test (readstr "#\\U110000") exn:fail:read?)
+
+(define (astring n) (string (integer->char n)))
+
+(test (astring 7) readstr "\"\\a\"")
+(test (astring 8) readstr "\"\\b\"")
+(test (astring 9) readstr "\"\\t\"")
+(test (astring 10) readstr "\"\\n\"")
+(test (astring 11) readstr "\"\\v\"")
+(test (astring 12) readstr "\"\\f\"")
+(test (astring 13) readstr "\"\\r\"")
+(test #\u1B string-ref (readstr "\"\\e\"") 0)
+(test #\u0 string-ref (readstr "\"\\0\"") 0)
+(test #\u8 string-ref (readstr "\"\\10\"") 0)
+(test #\uC string-ref (readstr "\"\\14\"") 0)
+(test (integer->char #o114)  string-ref (readstr "\"\\114\"") 0)
+(test (integer->char #o111)  string-ref (readstr "\"\\1111\"") 0)
+(test (astring #x24) readstr "\"\\x24\"")
+(test (string #\u24 #\space) readstr "\"\\x24 \"")
+(test (string #\u24 #\5) readstr "\"\\x245\"")
+(test (astring #x1024) readstr "\"\\u1024\"")
+(test (astring #x1C24) readstr "\"\\u1C24\"")
+(test (string #\u0001) readstr "\"\\u1\"")
+(test (string #\u0001 #\space) readstr "\"\\u1 \"")
+(test (string #\u0001) readstr "\"\\u01\"")
+(test (string #\u0001 #\space) readstr "\"\\u01 \"")
+(test (string #\u0001) readstr "\"\\u001\"")
+(test (string #\u0001 #\space) readstr "\"\\u001 \"")
+(test (string #\u0001) readstr "\"\\u0001\"")
+(test (string #\u0001 #\space) readstr "\"\\u0001 \"")
+(test (string #\u0001 #\1) readstr "\"\\u00011\"")
+
+(err/rt-test (readstr "\"\\c\"") exn:fail:read?)
+(err/rt-test (readstr "\"\\777\"") exn:fail:read?)
+(err/rt-test (readstr "\"\\uD800\"") exn:fail:read?)
+(err/rt-test (readstr "\"\\UB0000000\"") exn:fail:read?)
+(err/rt-test (readstr "\"\\UFFFFFFFF\"") exn:fail:read?)
+
+(test (bytes 7) readstr "#\"\\a\"")
+(test (bytes 8) readstr "#\"\\b\"")
+(test (bytes 9) readstr "#\"\\t\"")
+(test (bytes 10) readstr "#\"\\n\"")
+(test (bytes 11) readstr "#\"\\v\"")
+(test (bytes 12) readstr "#\"\\f\"")
+(test (bytes 13) readstr "#\"\\r\"")
+(test #x1B bytes-ref (readstr "#\"\\e\"") 0)
+(test #x0 bytes-ref (readstr "#\"\\0\"") 0)
+(test #x8 bytes-ref (readstr "#\"\\10\"") 0)
+(test #xC bytes-ref (readstr "#\"\\14\"") 0)
+(test #o114 bytes-ref (readstr "#\"\\114\"") 0)
+(test #o111 bytes-ref (readstr "#\"\\1111\"") 0)
+(test (bytes #x24) readstr "#\"\\x24\"")
+(test (bytes #x24 32) readstr "#\"\\x24 \"")
+(test (bytes #x24 53) readstr "#\"\\x245\"")
+
+(err/rt-test (readstr "#\"\\c\"") exn:fail:read?)
+(err/rt-test (readstr "#\"\\777\"") exn:fail:read?)
+(err/rt-test (readstr "#\"\\u0040\"") exn:fail:read?)
+
+(load-relative "numstrs.ss")
+(let loop ([l number-table])
+  (unless (null? l)
+	  (let* ([pair (car l)]
+		 [v (car pair)]
+		 [s (cadr pair)])
+	    (cond
+	     [(memq v '(X DBZ NOE))
+	      (err/rt-test (readstr s) exn:fail:read?)
+	      (test #f string->number s)]
+	     [v 
+	      (test v readstr s)
+	      (test (if (symbol? v) #f v) string->number s)]
+	     [else 
+	      (test (string->symbol s) readstr s)
+	      (test #f string->number s)
+	      (unless (regexp-match "#" s)
+		(err/rt-test (readstr (string-append "#d" s)) exn:fail:read?)
+		(test #f string->number (string-append "#d" s)))]))
+	  (loop (cdr l))))
+
+(test 5 readstr "#| hi |# 5")
+(test 5 readstr "#| #| #| #| hi |# |# |# |# 5")
+(test '(5) readstr "(#| #| #| #| hi |# |# |# |# 5)")
+(test '(10 1) readstr "(10 #|z#|#f|#z|# 1)")
+(test 17 readstr "#|z#|#f|#z|# 17")
+
+(err/rt-test (readstr "#\\silly") exn:fail:read?)
+(err/rt-test (readstr "#\\nully") exn:fail:read?)
+(err/rt-test (readstr "#\\nu") exn:fail:read?)
+(err/rt-test (readstr "#\\733") exn:fail:read?)
+(err/rt-test (readstr "#\\433") exn:fail:read?)
+(err/rt-test (readstr "#\\longerthanthrityonecharcterswhichisthebufsize") exn:fail:read?)
+(err/rt-test (readstr "#\\rcase") exn:fail:read?)
+(err/rt-test (readstr "#\\pcase") exn:fail:read?)
+(err/rt-test (readstr "#\\tcase") exn:fail:read?)
+(err/rt-test (readstr "#\\vcase") exn:fail:read?)
+(err/rt-test (readstr "#\\bcase") exn:fail:read?)
+(err/rt-test (readstr "#\\lcase") exn:fail:read?)
+
+(err/rt-test (readstr "(hi") exn:fail:read:eof?)
+(err/rt-test (readstr "\"hi") exn:fail:read:eof?)
+(err/rt-test (readstr "\"hi\\") exn:fail:read:eof?)
+(err/rt-test (readstr "#(hi") exn:fail:read:eof?)
+(err/rt-test (readstr "#[hi") exn:fail:read:eof?)
+(err/rt-test (readstr "#{hi") exn:fail:read:eof?)
+(err/rt-test (readstr "#4(hi") exn:fail:read:eof?)
+(err/rt-test (readstr "#4[hi") exn:fail:read:eof?)
+(err/rt-test (readstr "#4{hi") exn:fail:read:eof?)
+(err/rt-test (readstr "|hi") exn:fail:read:eof?)
+(err/rt-test (readstr "hi\\") exn:fail:read:eof?)
+(err/rt-test (readstr "#\\") exn:fail:read:eof?)
+(err/rt-test (readstr "#\\12") exn:fail:read:eof?)
+(err/rt-test (readstr "#| hi") exn:fail:read:eof?)
+(err/rt-test (readstr "(1 #| hi") exn:fail:read:eof?)
+(err/rt-test (readstr "'") exn:fail:read:eof?)
+(err/rt-test (readstr "`") exn:fail:read:eof?)
+(err/rt-test (readstr ",@") exn:fail:read:eof?)
+(err/rt-test (readstr ",") exn:fail:read:eof?)
+(err/rt-test (readstr "#'") exn:fail:read:eof?)
+(err/rt-test (readstr "#&") exn:fail:read:eof?)
+
+(err/rt-test (readstr ".") exn:fail:read?)
+(err/rt-test (readstr "a .") exn:fail:read?)
+(err/rt-test (readstr "a . b") exn:fail:read?)
+(err/rt-test (readstr "( . )") exn:fail:read?)
+(err/rt-test (readstr "(1 .") exn:fail:read:eof?)
+(err/rt-test (readstr "(1 .   ") exn:fail:read:eof?)
+(err/rt-test (readstr "(1 . 2") exn:fail:read:eof?)
+(err/rt-test (readstr "( . 8)") exn:fail:read?)
+(err/rt-test (readstr "(0 . 8 9)") exn:fail:read?)
+(err/rt-test (readstr "( . 8 9)") exn:fail:read?)
+(err/rt-test (readstr "(1 . 2 3 . 4)") exn:fail:read?)
+(err/rt-test (readstr "(1 . 2 . 3 . 4)") exn:fail:read?)
+(err/rt-test (readstr "#(8 . )") exn:fail:read?)
+(err/rt-test (readstr "#( . )") exn:fail:read?)
+(err/rt-test (readstr "#( . 8)") exn:fail:read?)
+(err/rt-test (readstr "#(0 . 8 9)") exn:fail:read?)
+(err/rt-test (readstr "#( . 8 9)") exn:fail:read?)
+(err/rt-test (readstr "#( 8 . 9)") exn:fail:read?)
+(err/rt-test (readstr "#( 8 . (9))") exn:fail:read?)
+(err/rt-test (readstr "#(1 . 2 . 3)") exn:fail:read?)
+
+(err/rt-test (readstr "#Q") exn:fail:read?)
+(err/rt-test (readstr "##") exn:fail:read?)
+(err/rt-test (readstr "#?") exn:fail:read?)
+(err/rt-test (readstr "#-1()") exn:fail:read?)
+(err/rt-test (readstr "#<a>") exn:fail:read?)
+(err/rt-test (readstr "#") exn:fail:read:eof?)
+
+(test #(1 a c) readstr "#[1 a c]")
+(test #(1 a c) readstr "#{1 a c}")
+(test #(1 a a) readstr "#3[1 a]")
+(test #(1 a a) readstr "#3{1 a}")
+(parameterize ([read-square-bracket-as-paren #f]
+	       [read-curly-brace-as-paren #f]
+	       [read-accept-quasiquote #f])
+  (err/rt-test (readstr "[2") exn:fail:read?)
+  (err/rt-test (readstr "{2") exn:fail:read?)
+  (err/rt-test (readstr "}2") exn:fail:read?)
+  (err/rt-test (readstr "]2") exn:fail:read?)
+  (err/rt-test (readstr "#{1}") exn:fail:read?)
+  (err/rt-test (readstr "#[1]") exn:fail:read?)
+  (err/rt-test (readstr "#2{1}") exn:fail:read?)
+  (err/rt-test (readstr "#2[1]") exn:fail:read?)
+  (err/rt-test (readstr ",2") exn:fail:read?)
+  (err/rt-test (readstr ",@2") exn:fail:read?)
+  (err/rt-test (readstr "`2") exn:fail:read?))
+
+(test '(1 2 3) readstr "(2 . 1 . 3)")
+(test '(1 2 3 4) readstr "(2 . 1 . 3 4)")
+(test '(1 2 3 4) readstr "(2 3 . 1 . 4)")
+
+(err/rt-test (readstr "#ha") exn:fail:read:eof?)
+(err/rt-test (readstr "#ham") exn:fail:read?)
+(err/rt-test (readstr "#hash") exn:fail:read:eof?)
+(err/rt-test (readstr "#hashe") exn:fail:read:eof?)
+(err/rt-test (readstr "#hasheq") exn:fail:read:eof?)
+(err/rt-test (readstr "#hash(") exn:fail:read:eof?)
+(err/rt-test (readstr "#hash((1") exn:fail:read:eof?)
+(err/rt-test (readstr "#hash((1 .") exn:fail:read:eof?)
+(err/rt-test (readstr "#hash((1 . 2)") exn:fail:read:eof?)
+(err/rt-test (readstr "#hash(1)") exn:fail:read?)
+(err/rt-test (readstr "#hash(1 2)") exn:fail:read?)
+(err/rt-test (readstr "#hash(1 . 2)") exn:fail:read?)
+(err/rt-test (readstr "#hash((1))") exn:fail:read?)
+(err/rt-test (readstr "#hash((1 2))") exn:fail:read?)
+(err/rt-test (readstr "#hash((1. 2))") exn:fail:read?)
+(err/rt-test (readstr "#hash((1 .2))") exn:fail:read?)
+(err/rt-test (readstr "#hash((1 . 2 3))") exn:fail:read?)
+(err/rt-test (readstr "#hash((1 . 2) . ((3 . 4)))") exn:fail:read?)
+(err/rt-test (readstr "#hash((1 . 2) . (3 . 4) . (5 . 6))") exn:fail:read?)
+(err/rt-test (readstr "#hash((1 . 2 . 3))") exn:fail:read?)
+(err/rt-test (readstr "#hash(#0=(1 . 2))") exn:fail:read?)
+(err/rt-test (readstr "#hash#0=((1 . 2))") exn:fail:read?)
+(err/rt-test (readstr "#hash((1 #0=(2)))") exn:fail:read?)
+(err/rt-test (readstr "#0=#hash#0#") exn:fail:read?)
+(err/rt-test (readstr "#0=#hash(#0#)") exn:fail:read?)
+(err/rt-test (readstr "#hash([1 . 2))") exn:fail:read?)
+
+(define (test-ht t size eq? key val)
+  (test #t hash-table? t)
+  (test (not eq?) hash-table? t 'equal)
+  (test size length (hash-table-map t cons))
+  (test 'nope hash-table-get t 'not-there (lambda () 'nope))
+  (test val hash-table-get t key (lambda () #f)))
+(test-ht (readstr "#hash()") 0 #f 'none #f)
+(test-ht (readstr "#hash((1 . 2))") 1 #f 1 2)
+(test-ht (readstr "#hash([1 . 2])") 1 #f 1 2)
+(test-ht (readstr "#hash[(1 . 2)]") 1 #f 1 2)
+(test-ht (readstr "#hash({1 . 2})") 1 #f 1 2)
+(test-ht (readstr "#hash{(1 . 2)}") 1 #f 1 2)
+(test-ht (readstr "#hash{[1 . 2]}") 1 #f 1 2)
+(test-ht (readstr "#hasheq((1 . 2))") 1 #t 1 2)
+(test-ht (readstr "#hash((\"apple\" . 1))") 1 #f "apple" 1)
+(test-ht (readstr "#hasheq((\"apple\" . 1))") 1 #t "apple" #f)
+(test-ht (readstr "#hash((\"apple\" . 1) (\"apple\" . 10))") 1 #f "apple" 10)
+(test-ht (readstr "#hasheq((\"apple\" . 1) (\"apple\" . 10))") 2 #t "apple" #f)
+(test-ht (readstr "#hash((apple . 1) (apple . 10))") 1 #f 'apple 10)
+(test-ht (readstr "#hasheq((apple . 1) (apple . 10))") 1 #t 'apple 10)
+(test-ht (readstr "#hasheq((#0=\"apple\" . 1) (#0# . 10))") 1 #t "apple" #f)
+(test-ht (readstr "#hash((#0=\"apple\" . 1) (\"banana\" . #0#))") 2 #f "banana" "apple")
+(test-ht (readstr "#hash((a . 1) (b . 2) (c . 3) (e . 4) (f . 5) (g . 6) (h . 7) (i . 8))") 8 #f 'f 5)
+(let ([t (readstr "#0=#hash((\"apple\" . #0#))")])
+  (test-ht t 1 #f "apple" t))
+(test-ht (readstr "#hash((#hash((1 . 2)) . 11) (#hash((3 . 4)) . 12))") 2 #f #hash((1 . 2)) 11)
+(test-ht (readstr "#hash((#hash((1 . 2)) . 11) (#hash((3 . 4)) . 12))") 2 #f #hash((3 . 4)) 12)
+(let ([t (readstr "#0=#hasheq((#0# . 17))")])
+  (test-ht t 1 #t t 17))
+(let ([t (readstr "#0=#hash((#0# . 17))")])
+  ;; Don't look for t, because that's a hash on a circular object!
+  (test-ht t 1 #f 'none #f))
+
+(define (test-write-ht writer t . strings)
+  (let ([o (open-output-string)])
+    (writer t o)
+    (test #t (car strings) (and (member (get-output-string o) strings) #t))))
+(test-write-ht write #hash((1 . 2)) "#<hash-table>")
+
+(parameterize ([print-hash-table #t])
+  (test-write-ht write #hash((1 . 2)) "#hash((1 . 2))")
+  (test-write-ht write #hash((1 . 2) (3 . 4)) "#hash((1 . 2) (3 . 4))" "#hash((3 . 4) (1 . 2))")
+  (test-write-ht write #hash(("apple" . |coconut !|)) "#hash((\"apple\" . |coconut !|))")
+  (test-write-ht display #hash(("apple" . |coconut !|)) "#hash((apple . coconut !))")
+  (test-write-ht write #3=#hash((1 . #3#)) "#0=#hash((1 . #0#))")
+  (test-write-ht write #hash((#37=(1 2) . #37#)) "#hash(((1 2) . (1 2)))")
+  (test-write-ht write #hash((a . #9=(1 2)) (b . #9#)) 
+		 "#hash((a . (1 2)) (b . (1 2)))"
+		 "#hash((b . (1 2)) (a . (1 2)))")
+  (parameterize ([print-graph #t])
+    (test-write-ht write #hash((#33=(1 2) . #33#)) "#hash((#0=(1 2) . #0#))")
+    (test-write-ht write #hash((a . #7=(1 2)) (b . #7#)) 
+		   "#hash((a . #0=(1 2)) (b . #0#))"
+		   "#hash((b . #0=(1 2)) (a . #0#))")))
+
+
+(test #t regexp? (readstr "#rx\".\""))
+(test '("abc") regexp-match #rx"a.." "123abcdef")
+
+(err/rt-test (readstr "#r") exn:fail:read:eof?)
+(err/rt-test (readstr "#rx") exn:fail:read:eof?)
+(err/rt-test (readstr "#rx\"") exn:fail:read:eof?)
+(err/rt-test (readstr "#ra") exn:fail:read?)
+(err/rt-test (readstr "#rxa") exn:fail:read?)
+(err/rt-test (readstr "#rx\"?\"") exn:fail:read?)
+
+(test 2 vector-length (readstr "#2()"))
+(test 0 vector-ref (readstr "#2()") 1)
+(test 2 vector-length (readstr "#000000000000000000000000000000002()"))
+
+(err/rt-test (readstr "#2(1 2 3)") exn:fail:read?)
+(err/rt-test (readstr "#200000000000(1 2 3)") (readerrtype exn:fail:out-of-memory?))
+(err/rt-test (readstr "#111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111x1(1 2 3)") exn:fail:read?)
+
+(test #t (lambda (x) (eq? (car x) (cdr x))) (readstr "(#1=(1 2) . #0001#)"))
+(test #t (lambda (x) (and (box? x) (eq? x (unbox x)))) (readstr "#0=#&#0#"))
+(test #t (lambda (x) (and (vector? x) (eq? x (vector-ref x 0)) (eq? x (vector-ref x 1)))) (readstr "#0=#2(#0#)"))
+(test #t (lambda (x) (and (vector? x) (eq? (vector-ref x 1) (vector-ref x 2)))) (readstr "#3(#0=(1 2) #0#)"))
+(test '(1 1 1) readstr "(#0=1 #1=#0# #1#)")
+
+;; Check that syntax, expansion, etc. preserve vector sharing
+(test #t (lambda (x) (and (vector? x) (eq? (vector-ref x 0) (vector-ref x 1)))) #2((1 2)))
+
+(define (graph-error-tests readstr)
+  (err/rt-test (readstr "#0#") exn:fail:read?)
+  (err/rt-test (readstr "#0=#0#") exn:fail:read?)
+  (err/rt-test (readstr "#0=#0#") exn:fail:read?)
+  (err/rt-test (readstr "(#0# #0=7)") exn:fail:read?)
+  (err/rt-test (readstr "(#0=7 #1#)") exn:fail:read?)
+  (err/rt-test (readstr "(#0=7 #0=7)") exn:fail:read?)
+  (err/rt-test (readstr "#0=") exn:fail:read:eof?)
+  (err/rt-test (readstr "#0") exn:fail:read:eof?)
+  (err/rt-test (readstr "#012345678=7") exn:fail:read?)
+  (err/rt-test (readstr "(#12345678=7 #012345678#)") exn:fail:read?)
+  (err/rt-test (readstr "#111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111x1=(1 2 3)") exn:fail:read?)
+  (parameterize ([read-accept-graph #f])
+    (err/rt-test (readstr "#1=1") exn:fail:read?)
+    (err/rt-test (readstr "#1#") exn:fail:read?)))
+(graph-error-tests readstr)
+(graph-error-tests (lambda (s)
+		     (read-syntax "string" (open-input-string s))))
+
+;; Long symbol:
+(test 'abcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefg
+      readstr "abcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefgabcdefg")
+
+(test 3 string-length (readstr (string #\" #\a #\nul #\b #\")))
+(test (string->symbol (string #\a #\nul #\b)) 'sym (readstr (string #\a #\nul #\b)))
+(test (string->symbol (string #\1 #\nul #\b)) 'sym (readstr (string #\1 #\nul #\b)))
+
+; Test read/write invariance on symbols and use of pipe quotes
+(define (test-write-sym with-bar without-bar s)
+  (let ([sym (string->symbol s)])
+    (parameterize ([read-case-sensitive #t])
+      (let ([p (open-output-string)])
+	(write sym p)
+	(test with-bar 'write-sym-with-bar (get-output-string p))
+	(test sym read (open-input-string (get-output-string p))))
+      (let ([p (open-output-string)])
+	(parameterize ([read-accept-bar-quote #f])
+	  (write sym p)
+	  (test without-bar 'write-sym-no-bar (get-output-string p))
+	  (test sym read (open-input-string (get-output-string p)))))
+      (let ([p (open-output-string)])
+	(display sym p)
+	(test s 'display-sym (get-output-string p))))))
+
+(test-write-sym "a->b" "a->b" "a->b")
+(test-write-sym "|a,b|" "a\\,b" "a,b")
+(test-write-sym "a\\|b" "a|b" "a|b")
+(test-write-sym "|a\\b|" "a\\\\b" "a\\b")
+
+(test 'a 'quote '\a)
+(test '|\a| 'quote '\\a)
+(test 'a 'quote '||||a||)
+#ci(test (string->symbol "aaa") 'quote 'aAa)
+#ci(test (string->symbol "aAa") 'quote 'A\AA)
+#ci(test (string->symbol "aAa") 'quote '|aAa|)
+#ci(test (string->symbol "aAa") 'quote 'A|A|A)
+
+(load-relative "numstrs.ss")
+(let loop ([l number-table])
+  (cond
+   [(null? l) 'done]
+   [(or (number? (caar l)) (memq (caar l) '(X DBZ NOE)))
+    (test-write-sym (string-append "|" (cadar l) "|") 
+		    (string-append "\\" (cadar l)) 
+		    (cadar l))
+    (loop (cdr l))]
+   [else 
+    (test-write-sym (cadar l) (cadar l) (cadar l))
+    (loop (cdr l))]))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Test mid-stream EOF
+
+(define (test-mid-stream-eof use-peek?)
+  (define chars (map (lambda (x)
+		       (if (char? x) (char->integer x) x))
+		     (append
+		      (string->list "1 2")
+		      (list eof)
+		      (string->list "\"a\" \"b\"")
+		      (list eof)
+		      (string->list "(a) (b)")
+		      (list eof)
+		      (string->list "eof"))))
+  (define cp (make-input-port
+	      'mid-stream
+	      (lambda (b)
+		(if (null? chars)
+		    eof
+		    (let ([c (car chars)])
+		      (set! chars (cdr chars))
+		      (cond 
+		       [(eof-object? c)
+			eof]
+		       [else
+			(bytes-set! b 0 c)
+			1]))))
+	      (and use-peek?
+		   (lambda (b skip progress-evt)
+		     (when (positive? skip)
+		       (error 'ouch!))
+		     (if (null? chars)
+			 eof
+			 (let ([c (car chars)])
+			   (cond 
+			    [(eof-object? c)
+			     eof]
+			    [else
+			     (bytes-set! b 0 c)
+			     1])))))
+	      void))
+  (define (f) (read cp))
+
+  (test 1 f)
+  (test 2 f)
+  (test eof f)
+  (test "a" f)
+  (test "b" f)
+  (test eof f)
+  (test '(a) f)
+  (test '(b) f)
+  (test eof f)
+  (test 'eof f)
+  (test eof f)
+  (test eof f))
+
+(test-mid-stream-eof #f)
+(test-mid-stream-eof #t)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Test non-character results for getc
+
+(define-struct special (size))
+
+(define a-special (make-special 1))
+(define b-special (make-special 1))
+(define special-comment (make-special 1))
+
+(define (make-p stream special-size check-pos)
+  ;; The `stream' arg is a list of strings and non-strings;
+  ;;  characters from the strings are returned one by one,
+  ;;  and the non-strings are returns as "special" literals.
+  ;; The `special-size' arg meansures the size (in char
+  ;;  positions) of a non-string special literal.
+  (let* ([pos 0]
+	 [incpos! (lambda () (set! pos (add1 pos)))]
+	 [read-one (lambda (str)
+		     (let loop ([s stream][p pos])
+		       (if (null? s)
+			   eof
+			   (let ([i (car s)])
+			     (if (bytes? i)
+				 (if ((bytes-length i) . > . p)
+				     (begin
+				       (incpos!)
+				       (bytes-set! str 0 (bytes-ref i p))
+				       1)
+				     (loop (cdr s) (- p (bytes-length i))))
+				 ;; a special:
+				 (cond
+				  [(zero? p) (incpos!)
+				   (if (and (number? i) 
+					    (or (inexact? i)
+						(negative? i)))
+				       i ; creates an error
+				       (lambda (where line col pos)
+					 (check-pos where line col pos)
+					 (cond
+					  [(symbol? i) (i)]
+					  [(eq? i special-comment)
+					   (make-special-comment i)]
+					  [(number? i)
+					   (if (inexact? i)
+					       (make-special-comment i)
+					       'aha)]
+					  [else i])))]
+				  [else (loop (cdr s) (sub1 p))]))))))])
+    (make-input-port
+     'specializer
+     ;; Non-blocking read string:
+     (lambda (str)
+       (read-one str))
+     ;; Peek char
+     (lambda (str skip progress-evt)
+       (let ([old-p pos])
+	 (let loop ([skip skip])
+	   (unless (zero? skip)
+	     (read-one str)
+	     (loop (sub1 skip))))
+	 (begin0
+	  (read-one str)
+	  (set! pos old-p))))
+     ;; Close proc
+     (lambda () #t))))
+
+;; Read without specials:
+(let* ([p (make-p `(#"(list "
+		    #"a"
+		    #" "
+		    #"b"
+		    #"))")
+		  special-size
+		  (lambda (w l c p)
+		    (error "shouldn't get here")))]
+       [_ (port-count-lines! p)]
+       [v (syntax-e (read-syntax 'ok p))])
+  (test 'list syntax-e (car v))
+  (test 'a syntax-e (cadr v))
+  (test 'b syntax-e (caddr v))
+  (test 1 syntax-line (car v))
+  (test 1 syntax-column (car v))
+  (test 1 syntax-line (cadr v))
+  (test 6 syntax-column (cadr v))
+  (test 1 syntax-line (caddr v))
+  (test 8 syntax-column (caddr v)))
+
+;; Without specials, with newlines:
+(let* ([p (make-p `(#"(list\n"
+		    #"a"
+		    #"\n"
+		    #"b"
+		    #"))")
+		  special-size
+		  (lambda (w l c p)
+		    (error "shouldn't get here")))]
+       [_ (port-count-lines! p)]
+       [v (syntax-e (read-syntax 'ok p))])
+  (test 'list syntax-e (car v))
+  (test 'a syntax-e (cadr v))
+  (test 'b syntax-e (caddr v))
+  (test 1 syntax-line (car v))
+  (test 1 syntax-column (car v))
+  (test 2 syntax-line (cadr v))
+  (test 0 syntax-column (cadr v))
+  (test 3 syntax-line (caddr v))
+  (test 0 syntax-column (caddr v)))
+  
+;; Simple read:
+(let* ([p (make-p `(#"(list "
+		    ,a-special
+		    #" "
+		    ,b-special
+		    #"))")
+		  special-size
+		  (lambda (w l c p)
+		    (test #f 'no-place1 w)
+		    (test 1 'no-place2 l)
+		    (test (and p (sub1 p)) 'no-place3 c)
+		    (test #f not (memq p '(7 9)))))]
+       [_ (port-count-lines! p)]
+       [v (read p)])
+  (test 'list car v)
+  (test a-special cadr v)
+  (test b-special caddr v))
+
+;; Read with newlines
+(let* ([p (make-p `(#"(list\n"
+		    ,a-special
+		    #"\n"
+		    ,b-special
+		    #"))")
+		  special-size
+		  (lambda (w l c p)
+		    (test l 'no-place4 l)
+		    (test #f 'no-place5 w)
+		    (test 0 'no-place6 c)
+		    (test #f not (memq p '(7 9)))
+		    (test #f not (memq l '(2 3)))))]
+       [_ (port-count-lines! p)]
+       [v (read p)])
+  (test 'list car v)
+  (test a-special cadr v)
+  (test b-special caddr v))
+
+(require (rename (lib "port.ss") relocate-input-port relocate-input-port))
+(define (shift-port p count-lines? deltas)
+  (let ([p (relocate-input-port p 
+				(add1 (car deltas))
+				(cadr deltas)
+				(add1 (caddr deltas)))])
+    (when count-lines?
+      (port-count-lines! p))
+    p))
+
+;; Read with src loc:
+(let* ([p (make-p `(#"(list "
+		    ,a-special
+		    #" "
+		    ,b-special
+		    #" end))")
+		  special-size
+		  (lambda (w l c p)
+		    (test 'dk 'dk-place w)
+		    (test 8 'no-place7 l)
+		    (test p + c 631)
+		    (test #f not (memq p '(707 709)))))]
+       [_ (port-count-lines! p)]
+       [v (read-syntax 'dk (shift-port p #t '(7 70 700)))]
+       [l (syntax->list v)]
+       [v2 (syntax-object->datum v)])
+  (test 'list car v2)
+  (test a-special cadr v2)
+  (test b-special caddr v2)
+  (test 'end cadddr v2)
+  
+  (test 702 syntax-position (car l))
+  (test 707 syntax-position (cadr l))
+  (test 709 syntax-position (caddr l))
+  (test 711 syntax-position (cadddr l))
+
+  ;; Read with specials as syntax syntax already:
+  (let* ([stx v]
+	 [p (make-p `(#"(list "
+		      ,stx
+		      #" end))")
+		    (lambda (x)
+		      ;; it's 1 wide
+		      1)
+		    (lambda (w l c p)
+		      (test 'dk 'dk-place w)
+		    (test #f 'no-place8 l)
+		    (test #f 'no-place9 c)
+		    (test 7 'place p)))]
+	 [v (read-syntax 'dk p)]
+	 [l (syntax->list v)])
+    ;; make sure syntax object is intact:
+    (test stx cadr l)
+    (test 9 syntax-position (caddr l))
+
+    ;; Check that plain read performs a syntax-object->datum:
+    (let* ([p (make-p `(#"(list "
+			,stx
+			#" end))")
+		      (lambda (x) 100)
+		    (lambda (w l c p)
+		      (test #f 'no-place10 w)
+		      (test #f 'no-place11 l)
+		      (test #f 'no-place12 c)
+		      (test 7 'place p)))]
+	   [v (read p)])
+      (test `(list (list ,a-special ,b-special end) end) values v))))
+
+;; Check that syntax read with with a list special
+;;  syntaxizes the list.
+(let* ([p (make-p `(#"(list "
+		    ,(list a-special b-special)
+		    #" end))")
+		  (lambda (x)
+		    1)
+		  (lambda (w l c p)
+		    (test 'dk 'dk-place w)
+		    (test #f 'no-place13 l)
+		    (test #f 'no-place14 c)
+		    (test 7 'place p)))]
+       [v (read-syntax 'dk p)]
+       [l (syntax->list v)])
+  (test #t syntax? (cadr l))
+  (test #t list? (syntax-e (cadr l)))
+  (test a-special syntax-e (car (syntax-e (cadr l))))
+  (test b-special syntax-e (cadr (syntax-e (cadr l))))
+  (test 9 syntax-position (caddr l)))
+
+;; Test delimitting and unsupported positions:
+(test (list 1 a-special) read (make-p (list #"(1" a-special #")") (lambda (x) 1) void))
+(test (list 1) read (make-p (list #"(1" special-comment #")") (lambda (x) 1) void))
+(test (list 'a a-special 'b) read (make-p (list #"(a" a-special #"b)") (lambda (x) 1) void))
+(test (list #\a a-special) read (make-p (list #"(#\\a" a-special #")") (lambda (x) 1) void))
+(test (list #\newline a-special) read (make-p (list #"(#\\newline" a-special #")") (lambda (x) 1) void))
+(test (list #\newline) read (make-p (list #"(#\\newline" special-comment #")") (lambda (x) 1) void))
+(test a-special read-char-or-special (make-p (list a-special) (lambda (x) 1) void))
+
+;; Type error triggered by symbol 'z --- make sure it's propagated:
+(err/rt-test (read (make-p (list #"(a" 'z #")") (lambda (x) 1) void)))
+;; Negative number triggers bad special result:
+(err/rt-test (read (make-p (list #"(a" -42 #")") (lambda (x) 1) void)))
+;; Inexact number triggers bad special-comment result:
+(err/rt-test (read (make-p (list #"(a" 42.0 #")") (lambda (x) 1) void)))
+
+(define (run-delim-special a-special)
+  (test (list 5) read (make-p (list #"(; \"" a-special #"\n5)") (lambda (x) 1) void))
+  (test (list 5) read (make-p (list #"(#| \"" a-special #" |# 5)") (lambda (x) 1) void))
+  (test (list 5) read (make-p (list #"(;" a-special #"\n 5)") (lambda (x) 1) void))
+  (test 5 read (make-p (list #"#| \"" a-special #" |# 5") (lambda (x) 1) void))
+  (test 5 read (make-p (list #";" a-special #"\n 5") (lambda (x) 1) void))
+  (err/rt-test (read (make-p (list #"\"a" a-special #"\"") (lambda (x) 1) void)) exn:fail:read:non-char?)
+  (err/rt-test (read (make-p (list #"\"" a-special #"\"") (lambda (x) 1) void)) exn:fail:read:non-char?)
+  (err/rt-test (read (make-p (list #"\"\\" a-special #"\"") (lambda (x) 1) void)) exn:fail:read:non-char?)
+  (err/rt-test (read (make-p (list #"\"\\x" a-special #"\"") (lambda (x) 1) void)) exn:fail:read:non-char?)
+  (err/rt-test (read (make-p (list #"\"\\x1" a-special #"\"") (lambda (x) 1) void)) exn:fail:read:non-char?)
+  (err/rt-test (read (make-p (list #"#\\" a-special #"") (lambda (x) 1) void)) exn:fail:read:non-char?)
+  (err/rt-test (read (make-p (list #"#\\12" a-special #"") (lambda (x) 1) void)) exn:fail:read:non-char?)
+  (err/rt-test (read (make-p (list #"#" a-special #"") (lambda (x) 1) void)) exn:fail:read:non-char?)
+  (err/rt-test (read (make-p (list #"x\\" a-special #"y") (lambda (x) 1) void)) exn:fail:read:non-char?)
+  (err/rt-test (read (make-p (list #"|" a-special #"y|") (lambda (x) 1) void)) exn:fail:read:non-char?)
+  (err/rt-test (read (make-p (list #"|x" a-special #"y|") (lambda (x) 1) void)) exn:fail:read:non-char?))
+(run-delim-special a-special)
+(run-delim-special special-comment)
+
+;; Test read-char-or-special:
+(let ([p (make-p (list #"x" a-special #"y") (lambda (x) 5) void)])
+  (test #\x peek-char-or-special p)
+  (test 0 file-position p)
+  (test #\x peek-char-or-special p 0)
+  (test a-special peek-char-or-special p 1)
+  (test #\y peek-char-or-special p 2)
+  (test 0 file-position p)
+  (test #\x read-char-or-special p)
+  (test 1 file-position p)
+  (test a-special peek-char-or-special p)
+  (test 1 file-position p)
+  (test a-special read-char-or-special p)
+  (test 2 file-position p)
+  (test #\y peek-char-or-special p)
+  (test 2 file-position p)
+  (test #\y read-char-or-special p)
+  (test 3 file-position p))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Test read-syntax offsets:
+
+(let ([p (open-input-string " a ")])
+  (let ([v (read-syntax 'ok (shift-port p #f (list 70 700 7000)))])
+    (test #f syntax-line v)
+    (test #f syntax-column v)
+    (test 7002 syntax-position v)))
+
+(let ([p (open-input-string " a ")])
+  (port-count-lines! p)
+  (let ([v (read-syntax 'ok (shift-port p #t (list 70 700 7000)))])
+    (test 71 syntax-line v)
+    (test 701 syntax-column v)
+    (test 7002 syntax-position v)))
+
+(let ([p (open-input-string " \n a ")])
+  (port-count-lines! p)
+  (let ([v (read-syntax 'ok (shift-port p #t (list 70 700 7000)))])
+    (test 72 syntax-line v)
+    (test 1 syntax-column v)
+    (test 7004 syntax-position v)))
+
+;; Check exception record:
+(let ([p (open-input-string " . ")])
+  (let ([x (with-handlers ([values values])
+	     (read-syntax 'ok (shift-port p #f (list 70 700 7000))))])
+    (test 'ok srcloc-source (car (exn:fail:read-srclocs x)))
+    (test #f srcloc-line (car (exn:fail:read-srclocs x)))
+    (test #f srcloc-column (car (exn:fail:read-srclocs x)))
+    (test 7002 srcloc-position (car (exn:fail:read-srclocs x)))))
+    
+(let ([p (open-input-string " . ")])
+  (port-count-lines! p)
+  (let ([x (with-handlers ([values values])
+	     (read-syntax 'ok (shift-port p #t (list 70 700 7000))))])
+    (test 'ok srcloc-source (car (exn:fail:read-srclocs x)))
+    (test 71 srcloc-line (car (exn:fail:read-srclocs x)))
+    (test 701 srcloc-column (car (exn:fail:read-srclocs x)))
+    (test 7002 srcloc-position (car (exn:fail:read-srclocs x)))))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(let ([p (open-output-bytes)])
+  (display void p)
+  (test "#<primitive:void>" get-output-string p)
+  (let ([try-bad
+	 (lambda (x)
+	   (test (void) (list x)
+		 (parameterize ([print-unreadable #f])
+		   (display x p)))
+	   (err/rt-test (parameterize ([print-unreadable #f])
+			  (write x p))))]
+	[try-good
+	 (lambda (x)
+	   (test (void) (list x)
+		 (parameterize ([print-unreadable #f])
+		   (write x p))))])
+    (try-bad void)
+    (try-bad (lambda () 10))
+    (try-bad (seconds->date (current-seconds)))
+    (try-bad (let ()
+	   (define-struct s (x))
+	   (make-s 10)))
+    (try-bad #'apple)
+    
+    (try-good 'ex)
+    (try-good '(1 ex))
+    (try-good '(1 . ex))
+    (try-good #(1 2))
+    (try-good #&(1))
+    (try-good 1)
+    (try-good 1.0)
+    (try-good "apple")
+    (try-good #"apple")
+    (try-good #rx"ok")
+    (try-good #rx#"ok")
+    (try-good #f)))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Test #reader
+
+(err/rt-test (parameterize ([read-accept-reader #f])
+	       (read (open-input-string "#reader mzscheme 10")))
+	     exn:fail:read?)
+(test 10 'ten (parameterize ([read-accept-reader #t])
+	       (read (open-input-string "#reader mzscheme 10"))))
+
+(module reader-test-module mzscheme
+  (define (my-read port)
+    `(READ ,(read port)))
+  (define (my-read-syntax name port)
+    `(READ-SYNTAX ,(read-syntax name port)))
+  (provide (rename my-read read)
+	   (rename my-read-syntax read-syntax)))
+
+(test `(READ 10) 'ten 
+      (parameterize ([read-accept-reader #t])
+	(read (open-input-string "#reader reader-test-module 10"))))
+(test `(READ-SYNTAX 10) 'ten 
+      (syntax-object->datum
+       (parameterize ([read-accept-reader #t])
+	 (read-syntax '??? (open-input-string "#reader reader-test-module 10")))))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(report-errs)
+
+(load-relative "readtable.ss")
diff --git a/collects/tests/mzscheme/readtable.ss b/collects/tests/mzscheme/readtable.ss
new file mode 100644
index 0000000000..759259b553
--- /dev/null
+++ b/collects/tests/mzscheme/readtable.ss
@@ -0,0 +1,258 @@
+
+(load-relative "loadtest.ss")
+
+(SECTION 'READTABLE)
+
+(require (rename (lib "port.ss") relocate-input-port relocate-input-port))
+(define (shift-rt-port p deltas)
+  (let ([p (relocate-input-port p 
+				(add1 (car deltas))
+				(cadr deltas)
+				(add1 (caddr deltas)))])
+    (port-count-lines! p)
+    p))
+	
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Basic readtable tests
+
+(arity-test make-readtable 1 -1)
+(arity-test readtable? 1 1)
+(arity-test readtable-mapping 2 2)
+
+(err/rt-test (make-readtable 5))
+(err/rt-test (make-readtable #f 5))
+(err/rt-test (make-readtable #f #\a))
+(err/rt-test (make-readtable #f #\a 5))
+(err/rt-test (make-readtable #f #\a #\b))
+(err/rt-test (make-readtable #f #\a 'terkminating-macro))
+
+(test #f current-readtable)
+(test #t readtable? (make-readtable #f))
+(test #t readtable? (make-readtable (make-readtable #f)))
+
+(let ([plain-dollar
+       (case-lambda
+	[(ch port)
+	 (test #t ormap (lambda (x) (char=? ch x)) '(#\$ #\&))
+	 `dollar]
+	[(ch port src line col pos)
+	 (test #t ormap (lambda (x) (char=? ch x)) '(#\$ #\&))
+	 `dollar])]
+      [plain-percent
+       (case-lambda
+	[(ch port)
+	 (test #\% values ch)
+	 `(percent ,(read/recursive port))]
+	[(ch port src line col pos)
+	 (test #\% values ch)
+	 (test 'string values src)
+	 `(percent ,(read-syntax/recursive src port))])]
+      [hash-dollar
+       (case-lambda
+	[(ch port)
+	 (test #\$ values ch)
+	 `(dollar . ,(read/recursive port))]
+	[(ch port src line col pos)
+	 (test #\$ values ch)
+	 `(dollar . ,(read-syntax/recursive src port))])]
+      [comment3
+       (case-lambda
+	[(ch port src line col pos)
+	 (test #\_ values ch)
+	 (read-char port) (read-char port) (read-char port)
+	 (make-special-comment #f)])])
+  (let ([t (make-readtable #f 
+			   #\$ 'terminating-macro plain-dollar
+			   #\% 'non-terminating-macro plain-percent
+			   #\^ #\| #f
+			   #\< #\( #f
+			   #\= #\\ #f
+			   #\~ #\space #f
+			   #\_ 'terminating-macro comment3
+			   #\$ 'dispatch-macro  hash-dollar)])
+    (test-values '(#\a #f #f) (lambda () (readtable-mapping t #\a)))
+    (test-values '(#\| #f #f) (lambda () (readtable-mapping t #\^)))
+    (test-values '(#\( #f #f) (lambda () (readtable-mapping t #\<)))
+    (test-values '(#\\ #f #f) (lambda () (readtable-mapping t #\=)))
+    (test-values '(#\space #f #f) (lambda () (readtable-mapping t #\~)))
+    (test-values (list 'terminating-macro plain-dollar hash-dollar) (lambda () (readtable-mapping t #\$)))
+    (test-values (list 'terminating-macro comment3 #f) (lambda () (readtable-mapping t #\_)))
+    (test-values (list 'non-terminating-macro plain-percent #f) (lambda () (readtable-mapping t #\%)))
+    (let ([t2 (make-readtable t
+			      #\& #\$ t
+			      #\a #\a t
+			      #\^ #\^ #f)])
+      (test-values '(#\a #f #f) (lambda () (readtable-mapping t2 #\a)))
+      (test-values '(#\^ #f #f) (lambda () (readtable-mapping t2 #\^)))
+      (test-values '(#\space #f #f) (lambda () (readtable-mapping t #\~)))
+      (test-values (list 'terminating-macro plain-dollar #f) (lambda () (readtable-mapping t2 #\&)))
+
+      (letrec ([test-read
+		(case-lambda 
+		 [(s l check-pos?)
+		  (define (go read)
+		    (let* ([o (open-input-string s)])
+		      (port-count-lines! o)
+		      (let loop ()
+			(let ([v (read o)])
+			  (if (eof-object? v)
+			      null
+			      (cons v (loop)))))))
+		  (test l (lambda (a b) (go read)) 'read s)
+		  (test l (lambda (a b) (map syntax-object->datum 
+					     (go (lambda (p) (read-syntax 'string p)))))
+			'read-syntax s)
+		  (when check-pos?
+		    (let ([stx (car (go (lambda (p) (read-syntax 'string (shift-rt-port p (list 1 2 3))))))])
+		      (test 2 syntax-line stx)
+		      (test 2 syntax-column stx)
+		      (test 4 syntax-position stx)))]
+		 [(s l) (test-read s l #t)])])
+	
+	(test-read "a$%_^b" '(a$%_^b))
+
+	(let ([try-table
+	       (lambda (t old-caret?)
+		 (parameterize ([current-readtable t])
+		   (test-read "a$b" '(a dollar b))
+		   (when old-caret?
+		     (test-read "a&b" '(a dollar b)))
+		   (test-read "a #$ b" '(a (dollar . b)))
+		   (test-read "(#1=a #$ #1#)" '((a (dollar . a))))
+		   (test-read "(#1=a #$ (#1#))" '((a (dollar a))))
+		   (test-read "a%b" '(a%b))
+		   (test-read "a % b" '(a (percent b)))
+		   (test-read "(#1=a % #1#)" '((a (percent a))))
+		   (test-read "(#1=a % (#1#))" '((a (percent (a)))))
+		   (test-read "a _xxx b" '(a b))
+		   (test-read "(a _xxx b)" '((a b)))
+		   (test-read "(a _xxx . b)" '((a . b)))
+		   (test-read "(a . _xxx b)" '((a . b)))
+		   (if old-caret?
+		       (test-read "(a ^_xxx^ b)" '((a ^ ^ b)))
+		       (test-read "(a ^_xxx^ b)" '((a _xxx b))))
+		   (test-read "(a =_xxx b)" '((a _xxx b)))
+		   (test-read "<a xxx b)" '((a xxx b)))
+		   (test-read "<a~xxx~b)" '((a xxx b)))))])
+	  (try-table t #f)
+	  (try-table t2 #t))
+
+	(let ([try-as-plain (lambda (ch)
+			      (parameterize ([current-readtable (make-readtable #f
+										ch #\a #f)])
+				(let ([s1 (format "a~ab" ch)]
+				      [s2 (format "~aab~a" ch ch)])
+				  (test-read s1 (list (string->symbol s1)))
+				  (test-read s2 (list (string->symbol s2)) #f)
+				  (let ([blank (if (char=? ch #\space)
+						   #\newline
+						   #\space)])
+				    (test-read (format "a~a~a~ab" blank ch blank) 
+					       (list 'a (string->symbol (string ch)) 'b))))))])
+	  (for-each try-as-plain (string->list "()[]{}|\\ \r\n\t\v',\"#")))
+
+	;; Check /recursive functions with pre char and initial readtable
+	(for-each
+	 (lambda (base-readtable swap?)
+	   (for-each
+	    (lambda (read/recursive)
+	      (let ([t (make-readtable #f 
+				       #\~ 'terminating-macro (lambda (ch port src line col pos)
+								(define read/rec
+								  (if src
+								      (lambda (port char readtable)
+									(read-syntax/recursive 
+									 src port
+									 char readtable))
+								      read/recursive))
+								(if (eq? (char=? #\! (peek-char port)) (not swap?))
+								    (read/rec port #\( base-readtable)
+								    (read/rec port #\{ base-readtable))))])
+		(parameterize ([current-readtable t])
+		  (test-read "~!a (b))" `((!a (b))))
+		  (test-read "~?a (b)}" `((?a (b)))))))
+	    (list read/recursive (lambda (port char readtable)
+				   (read-syntax/recursive 'ok port char readtable)))))
+	 (list #f (make-readtable #f
+				  #\! 'terminating-macro (lambda (ch port src line col pos) (error 'ack))
+				  #\? 'terminating-macro (lambda (ch port src line col pos) (error 'ack))
+				  #\( #\{ #f
+				  #\{ #\( #f))
+	 (list #f #t))
+	
+	(void)))))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Make sure we can't expose fixup process for graphs and cycles
+
+(let ([result #f]
+      [mk (lambda (v)
+	    `(,v ,(vector v) ,(box v) ,(let ([ht (make-hash-table)])
+					 (hash-table-put! ht v v)
+					 ht)))])
+  (let ([get-zero
+	 (case-lambda
+	  [(ch port)
+	   (let ([v (read/recursive (open-input-string "#0#"))])
+	     (set! result (mk v))
+	     result)]
+	  [(ch port src line col pos)
+	   (let ([v (read-syntax/recursive src (open-input-string "#0#"))])
+	     (set! result (datum->syntax-object #f (mk v) #f))
+	     result)])])
+    (let ([t (make-readtable #f 
+			     #\$ 'terminating-macro get-zero)])
+      (let ([go
+	     (lambda (read car cadr caddr cadddr unbox vector-ref hash-table-map
+			   list? vector? box? hash-table?)
+	       (let ([v (parameterize ([current-readtable t])
+			  (read (open-input-string "#0=$")))])
+		 (test #t list? v)
+		 (test #t list? (car v))
+		 (test #t vector? (cadr v))
+		 (test #t box? (caddr v))
+		 (test #t hash-table? (cadddr v))
+		 (test #t eq? v (car v))
+		 (test #t eq? v (vector-ref (cadr v) 0))
+		 (test #t eq? v (unbox (caddr v)))
+		 (test #f memq v (hash-table-map (cadddr v) (lambda (k v) k)))
+		 (test #f memq v (hash-table-map (cadddr v) (lambda (k v) v)))
+		 (test #f eq? v result)))])
+	(go read car cadr caddr cadddr unbox vector-ref hash-table-map
+	    list? vector? box? hash-table?)
+	(go (lambda (p) (read-syntax 'string p))
+	    (lambda (stx) (car (syntax->list stx))) 
+	    (lambda (stx) (cadr (syntax->list stx))) 
+	    (lambda (stx) (caddr (syntax->list stx))) 
+	    (lambda (stx) (cadddr (syntax->list stx))) 
+	    (lambda (stx) (unbox (syntax-e stx)))
+	    (lambda (stx p) (vector-ref  (syntax-e stx) p))
+	    (lambda (stx f) (hash-table-map (syntax-e stx) f))
+	    (lambda (stx) (and (syntax->list stx) #t))
+	    (lambda (stx) (vector? (syntax-e stx)))
+	    (lambda (stx) (box? (syntax-e stx)))
+	    (lambda (stx) (hash-table? (syntax-e stx))))))))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Check that sharing is preserved
+	    
+(let ([get-graph
+       (case-lambda
+	[(ch port) '#0=(#0#)]
+	[(ch port src line col pos)
+	 (datum->syntax-object #f '#1=(#1#) #f)])])
+  (let ([t (make-readtable #f 
+			   #\$ 'terminating-macro get-graph)])
+    (let ([go
+	   (lambda (read car)
+	     (let ([v (parameterize ([current-readtable t])
+			(read (open-input-string "$")))])
+	       ;; Check that cycle is preserved by unrolling lots
+	       (test #f boolean? (car (car (car (car v)))))))])
+      (go read car)
+      (go (lambda (p) (read-syntax 'string p))
+	  (lambda (stx) (car (syntax->list stx)))))))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(report-errs)
diff --git a/collects/tests/mzscheme/restart.ss b/collects/tests/mzscheme/restart.ss
new file mode 100644
index 0000000000..d2eedc2517
--- /dev/null
+++ b/collects/tests/mzscheme/restart.ss
@@ -0,0 +1,25 @@
+
+(load-relative "loadtest.ss")
+
+(require (lib "restart.ss"))
+
+(SECTION 'restart)
+
+(test #t restart-mzscheme #("ignore-me") values #("-qmv") void)
+(let ([test-in-out 
+       (lambda (pre post in out)
+	 (test (string-append "> " out "\n> ")
+	       'result
+	       (let ([s (open-output-string)])
+		 (parameterize ([current-input-port (open-input-string in)]
+				[current-output-port s])
+		   (restart-mzscheme pre values post void)
+		   (get-output-string s)))))])
+  (test-in-out #("ignore-me") #("-qm") "(current-command-line-arguments)" "#0()")
+  (test-in-out #("") #("-qm") "'Hello" "hello")
+  (test-in-out #("-g") #("-qm") "'Hello" "Hello")
+  (test-in-out #("") #("-qmg") "'Hello" "Hello"))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(report-errs)
diff --git a/collects/tests/mzscheme/serialize.ss b/collects/tests/mzscheme/serialize.ss
new file mode 100644
index 0000000000..d64b12f044
--- /dev/null
+++ b/collects/tests/mzscheme/serialize.ss
@@ -0,0 +1,448 @@
+
+
+(load-relative "loadtest.ss")
+
+(SECTION 'serialization)
+
+(require (lib "serialize.ss"))
+
+;; ----------------------------------------
+
+(define insp (current-inspector))
+
+(define-serializable-struct a () insp)
+(define-serializable-struct b (x y) insp)
+(define-serializable-struct (c a) (z) insp)
+(define-serializable-struct (d b) (w) insp)
+
+(define (same? v1 v2)
+  (define ht (make-hash-table))
+  (let loop ([v1 v1][v2 v2])
+    (cond
+     [(hash-table-get ht v1 (lambda () #f))
+      => (lambda (x) (eq? x v2))]
+     [(and (a? v1)
+	   (a? v2)
+	   (not (c? v1))
+	   (not (c? v2)))
+      #t]
+     [(and (b? v1)
+	   (b? v2)
+	   (not (d? v1))
+	   (not (d? v2)))
+      (hash-table-put! ht v1 v2)
+      (and (loop (b-x v1) (b-x v2))
+	   (loop (b-y v1) (b-y v2)))]
+     [(and (c? v1) (c? v2))
+      (hash-table-put! ht v1 v2)
+      (loop (c-z v1) (c-z v2))]
+     [(and (d? v1) (d? v2))
+      (hash-table-put! ht v1 v2)
+      (and (loop (b-x v1) (b-x v2))
+	   (loop (b-y v1) (b-y v2))
+	   (loop (d-w v1) (d-w v2)))]
+     [(and (pair? v1)
+	   (pair? v2))
+      (hash-table-put! ht v1 v2)
+      (and (eq? (immutable? v1) (immutable? v2))
+	   (loop (car v1) (car v2))
+	   (loop (cdr v1) (cdr v2)))]
+     [(and (vector? v1)
+	   (vector? v2))
+      (hash-table-put! ht v1 v2)
+      (and (eq? (immutable? v1) (immutable? v2))
+	   (= (vector-length v1) (vector-length v2))
+	   (andmap loop
+		   (vector->list v1)
+		   (vector->list v2)))]
+     [(and (box? v1) (box? v2))
+      (hash-table-put! ht v1 v2)
+      (and (eq? (immutable? v1) (immutable? v2))
+	   (loop (unbox v1) (unbox v2)))]
+     [(and (hash-table? v1) (hash-table? v2))
+      (hash-table-put! ht v1 v2)
+      (and (eq? (immutable? v1) (immutable? v2))
+	   (eq? (hash-table? v1 'equal) (hash-table? v2 'equal))
+	   (eq? (hash-table? v1 'weak) (hash-table? v2 'weak))
+	   (= (hash-table-count v1) (hash-table-count v2))
+	   (let ([ok? #t])
+	     (hash-table-for-each
+	      v1
+	      (lambda (k v)
+		(set! ok?
+		      (and ok?
+			   (loop v (hash-table-get v2 k (lambda () 'not-found)))))))
+	     ok?))]
+     [(and (date? v1) (date? v2))
+      (hash-table-put! ht v1 v2)
+      (andmap loop 
+	      (vector->list (struct->vector v1))
+	      (vector->list (struct->vector v2)))]
+     [(and (arity-at-least? v1) (arity-at-least? v2))
+      (hash-table-put! ht v1 v2)
+      (loop (arity-at-least-value v1)
+	    (arity-at-least-value v2))]
+     [else
+      (and (equal? v1 v2)
+	   (eq? (immutable? v1) (immutable? v2)))])))
+      
+
+(define (test-ser v)
+  (parameterize ([print-graph #t])
+    (test #t serializable? v)
+    (test #t same? v v)
+    (test #t same? v (deserialize (serialize v)))))
+
+(define (mk-ht . args)
+  (let ([ht (apply make-hash-table args)])
+    (hash-table-put! ht 'apple 'ok)
+    (hash-table-put! ht 'banana 'better)
+    ht))
+
+;; ----------------------------------------
+
+(test-ser 1)
+(test-ser "apple")
+(test-ser (string-copy "apple"))
+(test-ser #"apple")
+(test-ser (bytes-copy #"apple"))
+(test-ser #\c)
+(test-ser 145.79)
+(test-ser 2/3)
+(test-ser #t)
+(test-ser #f)
+(test-ser (void))
+(test-ser 'ok)
+(test-ser null)
+(test-ser (current-directory))
+(test-ser (seconds->date (current-seconds)))
+(test-ser (procedure-arity (lambda (x . y) 10)))
+(test-ser (make-immutable-hash-table '((1 . a) (2 . b))))
+(test-ser (make-immutable-hash-table '(("x" . a) ("y" . b)) 'equal))
+(test-ser (mk-ht))
+(test-ser (mk-ht 'equal))
+(test-ser (mk-ht 'weak))
+(test-ser (mk-ht 'equal 'weak))
+
+(test-ser '(1))
+(test-ser '#(1))
+(test-ser '#&1)
+
+(test-ser (cons 1 2))
+(test-ser (cons-immutable 1 2))
+(test-ser (vector))
+(test-ser (vector 1 2))
+(test-ser (vector-immutable))
+(test-ser (vector-immutable 1 2))
+(test-ser (box 10))
+(test-ser (box-immutable 10))
+
+(test-ser (make-a))
+(test-ser (make-b 1 2))
+(test-ser (make-c 30))
+(test-ser (make-d 100 200 300))
+
+;; Simple sharing
+(let ([p (cons 1 2)])
+  (test-ser (cons p p))
+  (test-ser (vector p p))
+  (test-ser (make-b p p))
+  (test-ser (make-d p 1 p)))
+(let ([p (vector 1 2 3)])
+  (test-ser (cons p p))
+  (test-ser (vector p p))
+  (test-ser (make-b p p))
+  (test-ser (make-d p 1 p)))
+(let ([p (box 1)])
+  (test-ser (cons p p))
+  (test-ser (vector p p))
+  (test-ser (make-b p p))
+  (test-ser (make-d p 1 p)))
+(let ([p (make-a)])
+  (test-ser (cons p p)))
+(let ([p (make-d 1 2 3)])
+  (test-ser (vector p p p)))
+(let ([p (seconds->date (current-seconds))])
+  (test-ser (cons p p)))
+(let ([p (make-arity-at-least 10)])
+  (test-ser (cons p p)))
+(let ([p (mk-ht)])
+  (test-ser (cons p p)))
+
+;; Cycles
+(let ([p (cons 1 2)])
+  (set-car! p p)
+  (test-ser p)
+  (set-cdr! p p)
+  (test-ser p)
+  (test-ser (make-c p))
+  (test-ser (make-b p p)))
+(let ([p (vector 1 2 3)])
+  (vector-set! p 1 p)
+  (test-ser p)
+  (vector-set! p 2 p)
+  (test-ser p)
+  (test-ser (make-c p))
+  (test-ser (make-b p p)))
+(let ([p (box 1)])
+  (set-box! p p)
+  (test-ser p)
+  (test-ser (make-c p))
+  (test-ser (make-b p p)))
+(let ([p (make-c 1)])
+  (set-c-z! p p)
+  (test-ser p)
+  (test-ser (make-c p)))
+(let ([p (make-b 1 2)])
+  (set-b-x! p p)
+  (test-ser p)
+  (set-b-y! p p)
+  (test-ser p)
+  (set-b-x! p 1)
+  (test-ser p)
+  (test-ser (make-c p)))
+(let ([p (make-d 1 2 3)])
+  (set-b-x! p p)
+  (test-ser p)
+  (set-b-y! p p)
+  (test-ser p)
+  (set-d-w! p p)
+  (test-ser p)
+  (set-b-x! p 1)
+  (test-ser p)
+  (set-b-y! p 2)
+  (test-ser p)
+  (test-ser (make-c p)))
+(let ([p (seconds->date (current-seconds))])
+  (set-date-second! p p)
+  (test-ser p)
+  (test-ser (cons p p)))
+(let ([p (make-arity-at-least 10)])
+  (set-arity-at-least-value! p p)
+  (test-ser p)
+  (test-ser (cons p p)))
+(let ([p (mk-ht)])
+  (hash-table-put! p 'banana p)
+  (test-ser p)
+  (test-ser (cons p p)))
+
+;; Cycles with immutable parts
+(let* ([p1 (cons 1 2)]
+       [p2 (cons-immutable 0 p1)])
+  (set-cdr! p1 p2)
+  (test-ser p1)
+  (test-ser p2)
+  (test-ser (cons p1 p2))
+  (test-ser (cons p2 p1))
+  (test-ser (make-c p1))
+  (test-ser (make-b p1 p2))
+  (test-ser (make-b p2 p1)))
+(let* ([p1 (vector 1 2 3)]
+       [p2 (vector-immutable 0 p1 4)])
+  (vector-set! p1 1 p2)
+  (test-ser p1)
+  (test-ser p2)
+  (test-ser (make-c p1))
+  (test-ser (make-b p1 p2))
+  (test-ser (make-b p2 p1)))
+(let* ([p1 (box 1)]
+       [p2 (box-immutable p1)])
+  (set-box! p1 p2)
+  (test-ser p1)
+  (test-ser p2)
+  (test-ser (make-c p1))
+  (test-ser (make-b p1 p2))
+  (test-ser (make-b p2 p1)))
+(let* ([p1 (cons 1 2)]
+       [p2 (make-immutable-hash-table
+	    (cons (cons 'x p1) '((a . 2) (b . 4))))])
+  (set-cdr! p1 p2)
+  (test-ser p1)
+  (test-ser p2)
+  (test-ser (cons p1 p2))
+  (test-ser (cons p2 p1)))
+      
+;; ----------------------------------------
+
+(module ser-mod mzscheme
+   (require (lib "serialize.ss"))
+   (provide ser-mod-test)
+
+   (define-serializable-struct foo (a b))
+
+   (define (ser-mod-test)
+     (foo-a (deserialize (serialize (make-foo 1 2))))))
+
+(require ser-mod)
+(test 1 ser-mod-test)
+
+;; ----------------------------------------
+;; Classes
+
+(require (lib "class.ss"))
+
+(define-serializable-class s:c% object%
+  (init-field [one 0])
+  (define f1 one)
+  (define f2 1)
+  (define/public (get-f1) f1)
+  (define/public (get-f2) f2)
+  (define/public (set-f1 v) (set! f1 v))
+  (define/public (set-f2 v) (set! f2 v))
+  (super-new))
+
+(let ([o (new s:c% [one 17])])
+  (test 17 'o (send (deserialize (serialize o)) get-f1))
+  (test 1 'o (send (deserialize (serialize o)) get-f2)))
+
+(define-serializable-class s:d% s:c% object%
+  (define f3 3)
+  (define/public (get-f3) f3)
+  (define/public (set-f3 v) (set! f3 v))
+  (super-new [one (+ f3 4)]))
+
+(let ([o (new s:d%)])
+  (test 3 'o (send (deserialize (serialize o)) get-f3))
+  (test 7 'o (send (deserialize (serialize o)) get-f1))
+  (test 1 'o (send (deserialize (serialize o)) get-f2)))
+
+(let* ([e% (class s:d% (define goo 12) (super-new))]
+       [o (new e%)])
+  (test #f is-a? (deserialize (serialize o)) e%)
+  (test #t is-a? (deserialize (serialize o)) s:d%))
+
+;; Can't define serializable from non-transparent, non-externalizable<%>:
+(test 'right-error 'dsc
+      (with-handlers ([exn:fail:object? (lambda (x) 'right-error)])
+	(eval #'(define-serializable-class foo% (class s:d% (super-new))))))
+
+(define s:transparent%
+  (class object%
+    (inspect #f)
+    (define f1 12)
+    (define/public (get-f1) f1)
+    (define/public (set-f1 v) (set! f1 v))
+    (super-new)))
+
+(err/rt-test (serialize (new s:transparent%)))
+
+(define-serializable-class s:g% s:transparent%
+  (define f2 18)
+  (define/public (get-f2) f2)
+  (define/public (set-f2 v) (set! f2 v))
+  (super-new))
+
+;; Adding more transperant was ok, and check cycle:
+(let ([o (new s:g%)])
+  (send o set-f1 6)
+  (send o set-f2 16)
+  (test #t is-a? (deserialize (serialize o)) s:g%)
+  (test 6 'o (send (deserialize (serialize o)) get-f1))
+  (test 16 'o (send (deserialize (serialize o)) get-f2))
+  (test #(struct:object:s:g% 6 ...) struct->vector o))
+
+(define-serializable-class s:h% (class s:g%
+				  (inspect #f)
+				  (define hoo 34)
+				  (super-new))
+  (define f3 80)
+  (define/public (get-f3) f3)
+  (define/public (set-f3 v) (set! f3 v))
+  (super-new))
+
+(let ([o (new s:h%)])
+  (send o set-f1 6)
+  (send o set-f2 16)
+  (test #t is-a? (deserialize (serialize o)) s:h%)
+  (test 6 'o (send (deserialize (serialize o)) get-f1))
+  (test 16 'o (send (deserialize (serialize o)) get-f2))
+  (test #(struct:object:s:h% 6 ... 34 ...) struct->vector o)
+  (send o set-f3 o)
+  (let ([o2 (deserialize (serialize o))])
+    (test o2 'cycle (send o2 get-f3))))
+
+(define-serializable-class* s:k% object% (externalizable<%>)
+  (define z 12)
+  (define/public (externalize) '(ok))
+  (define/public (internalize v) (set! z 13))
+  (define/public (get-z) z)
+  (super-new))
+
+(let ([o (new s:k%)])
+  (test 12 'z (send o get-z))
+  (let ([o2 (deserialize (serialize o))])
+    (test #t is-a? o2 s:k%)
+    (test 13 'z (send o2 get-z))))
+
+(define s:m%
+  (class object%
+    (define x 12)
+    (define/public (mm v) (begin0 x (set! x v)))
+    (super-new)))
+
+(define s:n%
+  (class* s:m% (externalizable<%>)
+    (inherit mm)
+    (define x 18)
+    (define/public (nm v) (begin0 x (set! x v)))
+    (define/public (externalize) (list x (let ([v (mm 0)]) (mm v) v)))
+    (define/public (internalize v) 
+      (set! x (car v))
+      (mm (cadr v)))
+    (super-new)))
+
+;; Just implementing externalize<%> isn't enough
+(err/rt-test (serialize (new s:n%)))
+
+;; Derive from externalizable class
+(define-serializable-class s:p% s:n%
+  (define x 0)
+  (define/public (pm v) (begin0 x (set! x v)))
+  (super-new))
+
+(let ([o (new s:p%)])
+  (test 12 'n (send o mm 12))
+  (test 18 'n (send o nm 17))
+  (test 0 'n (send o pm 10))
+  (test 10 'n (send o pm 10))
+  (let ([o2 (deserialize (serialize o))])
+    (test #t is-a? o2 s:p%)
+    (test 12 'n (send o2 mm 14))
+    (test 14 'n (send o2 mm 15))
+    (test 12 'n (send o mm 12))
+    (test 17 'n (send o2 nm 0))
+    (test 17 'n (send o nm 17))
+    (test 0 'n (send o2 pm 0))))
+
+;; Override doesn't matter until it's made serializable again:
+(let ([s:q% (class s:p% 
+	      (define/override (externalize) (error "ack"))
+	      (super-new))])
+  (test #t is-a? (deserialize (serialize (new s:q%))) s:p%)
+  (test #f is-a? (deserialize (serialize (new s:q%))) s:q%))
+
+;; override externalize
+(define-serializable-class s:r% s:n%
+  (inherit nm)
+  (define/override (externalize) 10)
+  (define/override (internalize v) (nm 77))
+  (super-new))
+
+(let ([o (new s:r%)])
+  (send o mm 1)
+  (send o nm 2)
+  (let ([o2 (deserialize (serialize o))])
+    (test #t is-a? o2 s:r%)
+    (test 12 'n (send o2 mm 14))
+    (test 77 'n (send o2 nm 15))))
+
+(define-serializable-class s:bad% s:n%
+  (init foo)
+  (super-new))
+
+(test #t pair? (serialize (new s:bad% [foo 10])))
+(err/rt-test (deserialize (serialize (new s:bad% [foo 10]))) exn:fail:object?)
+
+;; ----------------------------------------
+
+(report-errs)
diff --git a/collects/tests/mzscheme/shared-tests.ss b/collects/tests/mzscheme/shared-tests.ss
new file mode 100644
index 0000000000..be677597f4
--- /dev/null
+++ b/collects/tests/mzscheme/shared-tests.ss
@@ -0,0 +1,38 @@
+
+;; this writes values to strings and compares the strings
+;; to implements an equal? predicate that works for cyclic
+;; structures.
+
+(define (gs v)
+  (let ([p (open-output-string)])
+    (begin
+      (write v p)
+      (get-output-string p))))
+(define (stest expect expression)
+  (test
+   (gs expect)
+   (let ([shared-tester (lambda (x) (gs (eval x)))]) shared-tester)
+   expression))
+
+(stest '(1 2) '(shared ([x (list 1 2)]) x))
+(stest #(1 2) '(shared ([x (vector 1 2)]) x))
+(stest (box 1) '(shared ([x (box 1)]) x))
+(stest '(1) '(shared ([x (cons 1 null)]) x))
+
+(stest '#1=(#1# 1) '(shared ([x (list x 1)]) x))
+(stest '#2=#(#2# 1) '(shared ([x (vector x 1)]) x))
+(stest '#3=#&#3# '(shared ([x (box x)]) x))
+(stest '#4=(#4#) '(shared ([x (cons x null)]) x))
+(stest '#5=(1 . #5#) '(shared ([x (cons 1 x)]) x))
+
+(stest '#11=(#11#) '(shared ([x `(,x)]) x))
+
+
+(define-struct s (a b))
+(shared ([x (make-s 17 x)])
+  (begin
+    (test #t s? x)
+    (test 17 s-a x)
+    (test #t eq? x (s-b x))))
+
+
diff --git a/collects/tests/mzscheme/shared.ss b/collects/tests/mzscheme/shared.ss
new file mode 100644
index 0000000000..fabd89832a
--- /dev/null
+++ b/collects/tests/mzscheme/shared.ss
@@ -0,0 +1,13 @@
+
+(load-relative "loadtest.ss")
+
+(SECTION 'shared)
+
+(require (lib "shared.ss"))
+
+(load-relative "shared-tests.ss")
+  
+(require mzscheme)
+(load-relative "shared-tests.ss")
+  
+(report-errs)
diff --git a/collects/tests/mzscheme/stream.ss b/collects/tests/mzscheme/stream.ss
new file mode 100644
index 0000000000..443166ea84
--- /dev/null
+++ b/collects/tests/mzscheme/stream.ss
@@ -0,0 +1,335 @@
+
+(printf "Stream Tests (current dir must be startup dir)~n")
+
+(define (log . args)
+  '(begin
+     (apply printf args)
+     (newline)))
+
+(define cs-prog
+  '(define (copy-stream in out)
+     (lambda ()
+       (let ([s (make-string 4096)])
+	 (let loop ()
+	   (let ([l (read-string-avail! s in)])
+	     (log "in: ~a" l)
+	     (unless (eof-object? l)
+	       (let loop ([p 0][l l])
+		 (let ([r (write-string-avail s out p (+ p l))])
+		   (log "out: ~a" r)
+		   (when (< r l)
+		     (loop (+ p r) (- l r)))))
+	       (loop))))))))
+
+(eval cs-prog)
+
+(define test-file (find-executable-path (find-system-path 'exec-file) #f))
+(define tmp-file (build-path (find-system-path 'temp-dir) "ZstreamZ"))
+
+(define (feed-file out)
+  (let ([p (open-input-file test-file)])
+    (let loop ()
+      (let ([c (read-char p)])
+	(unless (eof-object? c)
+	  (write-char c out)
+	  (loop))))))
+	
+(define (feed-file/fast out)
+  (let ([p (open-input-file test-file)])
+    ((copy-stream p out))
+    (close-input-port p)))
+	
+(define (check-file in)
+  (let ([p (open-input-file test-file)])
+    (let loop ([badc 0])
+      (let ([c (read-char p)]
+	    [c2 (read-char in)])
+	(unless (eq? c c2)
+	  (if (= badc 30)
+	      (error "check-failed" (file-position p) c c2)
+	      (begin
+		(fprintf (current-error-port)
+			 "fail: ~a ~s ~s~n"
+			 (file-position p) c c2)
+		(loop (add1 badc)))))
+	(unless (eof-object? c)
+	  (loop badc))))
+    (close-input-port p)))
+
+(define (check-file/fast in)
+  (let ([p (open-input-file test-file)])
+    (let loop ()
+      (let* ([s (read-string 5000 p)]
+	     [s2 (read-string (if (string? s) (string-length s) 100) in)])
+	(unless (equal? s s2)
+	  (error "fast check failed"))
+	(unless (eof-object? s)
+	  (loop))))
+    (close-input-port p)))
+
+(define (check-file/fastest in)
+  (let ([p (open-input-file test-file)]
+	[s1 (make-string 5000)]
+	[s2 (make-string 5000)])
+    (let loop ([leftover 0][startpos 0][pos 0])
+      (let* ([n1 (if (zero? leftover)
+		     (read-string-avail! s1 p)
+		     leftover)]
+	     [n2 (read-string-avail! s2 in 0 (if (eof-object? n1)
+						 1
+						 n1))])
+	(unless (if (or (eof-object? n1)
+			(eof-object? n2))
+		    (and (eof-object? n1)
+			 (eof-object? n2))
+		    (if (= n2 n1 5000)
+			(string=? s1 s2)
+			(string=? (substring s1 startpos (+ startpos n2))
+				  (substring s2 0 n2))))
+	  (error 'check "failed at ~a (~a@~a ~a)" pos n1 startpos n2))
+	(unless (eof-object? n1)
+	  (loop (- n1 n2) 
+		(if (= n1 n2)
+		    0
+		    (+ startpos n2))
+		(+ pos n2)))))
+    (close-input-port p)))
+
+(define portno 40000)
+
+(define (setup-mzscheme-echo tcp?)
+  (define p (process* test-file "-q" "-b"))
+  (define s (make-string 256))
+  (define r #f)
+  (define w #f)
+  (define r2 #f)
+  (define w2 #f)
+  (thread (copy-stream (cadddr p) (current-error-port)))
+  (fprintf (cadr p) "(define log void)~n")
+  (fprintf (cadr p) "~s~n" cs-prog)
+  (if tcp?
+      (let ([t 
+	     (thread (lambda ()
+		       (define-values (rr ww) (tcp-accept l1))
+		       (define-values (rr2 ww2) (tcp-accept l2))
+		       (set! r rr)
+		       (set! w ww)
+		       (set! r2 rr2)
+		       (set! w2 ww2)))])
+	(fprintf (cadr p) "(define-values (r w) (tcp-connect \"localhost\" ~a))~n" portno)
+	(fprintf (cadr p) "(define-values (r2 w2) (tcp-connect \"localhost\" ~a))~n" (add1 portno))
+	(thread-wait t)
+	(fprintf (cadr p) "(begin ((copy-stream r w2)) (exit))~n"))
+      (fprintf (cadr p) "(begin ((copy-stream (current-input-port) (current-output-port))) (exit))~n"))
+
+  ;; Flush initial output:
+  (read-string (string-length (banner)) (car p))
+  (sleep 0.3)
+  (when (char-ready? (car p))
+    (read-string-avail! s (car p)))
+  (sleep 0.3)
+  (when (char-ready? (car p))
+    (read-string-avail! s (car p)))
+
+  (if tcp?
+      (values r w r2 w2)
+      p))
+
+(define start-ms 0)
+(define start-ps-ms 0)
+(define start-gc-ms 0)
+(define (start s)
+  (printf s)
+  (set! start-ms (current-milliseconds))
+  (set! start-gc-ms (current-gc-milliseconds))
+  (set! start-ps-ms (current-process-milliseconds)))
+(define (end)
+  (let ([ps-ms (current-process-milliseconds)]
+	[gc-ms (current-gc-milliseconds)]
+	[ms (current-milliseconds)])
+    (printf "cpu: ~a real: ~a gc ~a~n" 
+	    (- ps-ms start-ps-ms)
+	    (- ms start-ms)
+	    (- gc-ms start-gc-ms))))
+
+'(thread (lambda ()
+	  (let loop ()
+	    (printf "alive~n")
+	    (sleep 1)
+	    (loop))))
+
+(start "Quick check:~n")
+(define p (open-input-file test-file))
+(check-file/fast p)
+(close-input-port p)
+(end)
+
+(start "Quicker check:~n")
+(define p (open-input-file test-file))
+(check-file/fastest p)
+(close-input-port p)
+(end)
+
+(start "Plain pipe...~n")
+(define-values (r w) (make-pipe))
+(feed-file w)
+(close-output-port w)
+(check-file r)
+(end)
+
+(start "Plain pipe, faster...~n")
+(define-values (r w) (make-pipe))
+(feed-file/fast w)
+(close-output-port w)
+(check-file/fast r)
+(end)
+
+(start "Plain pipe, fastest...~n")
+(define-values (r w) (make-pipe))
+(feed-file/fast w)
+(close-output-port w)
+(check-file/fastest r)
+(end)
+
+(start "Limited pipe...~n")
+(define-values (r w) (make-pipe 253))
+(thread (lambda ()
+	  (feed-file w)
+	  (close-output-port w)))
+(check-file r)
+(end)
+
+(start "Limited pipe, faster...~n")
+(define-values (r w) (make-pipe 253))
+(thread (lambda ()
+	  (feed-file/fast w)
+	  (close-output-port w)))
+(check-file/fast r)
+(end)
+
+(start "Limited pipe, fastest...~n")
+(define-values (r w) (make-pipe 253))
+(thread (lambda ()
+	  (feed-file/fast w)
+	  (close-output-port w)))
+(check-file/fastest r)
+(end)
+
+(start "To file and back:~n")
+(start " to...~n")
+(define-values (r w) (make-pipe))
+(define p (open-output-file tmp-file 'truncate))
+(define t (thread (copy-stream r p)))
+(feed-file w)
+(close-output-port w)
+(thread-wait t)
+(close-output-port p)
+(end)
+
+(start " back...~n")
+(define-values (r w) (make-pipe))
+(define p (open-input-file tmp-file))
+(define t (thread (copy-stream p w)))
+(thread-wait t)
+(close-output-port w)
+(close-input-port p)
+(check-file r)
+(end)
+
+(start "To file and back, faster:~n")
+(start " to...~n")
+(define-values (r w) (make-pipe))
+(define p (open-output-file tmp-file 'truncate))
+(define t (thread (copy-stream r p)))
+(feed-file/fast w)
+(close-output-port w)
+(thread-wait t)
+(close-output-port p)
+(end)
+
+(start " back...~n")
+(define-values (r w) (make-pipe))
+(define p (open-input-file tmp-file))
+(define t (thread (copy-stream p w)))
+(thread-wait t)
+(close-output-port w)
+(close-input-port p)
+(check-file/fast r)
+(end)
+
+(start "File back, fastest:~n")
+(define-values (r w) (make-pipe))
+(define p (open-input-file tmp-file))
+(define t (thread (copy-stream p w)))
+(thread-wait t)
+(close-output-port w)
+(close-input-port p)
+(check-file/fastest r)
+(end)
+
+(start "Echo...~n")
+(define p (setup-mzscheme-echo #f))
+(thread (lambda () 
+	  (feed-file (cadr p))
+	  (close-output-port (cadr p))))
+(check-file (car p))
+(end)
+
+(start "Echo, faster...~n")
+(define p (setup-mzscheme-echo #f))
+(thread (lambda () 
+	  (feed-file/fast (cadr p))
+	  (close-output-port (cadr p))))
+(check-file/fast (car p))
+(end)
+
+(start "Echo, indirect...~n")
+(define p (setup-mzscheme-echo #f))
+(define-values (rp1 wp1) (make-pipe))
+(define-values (rp2 wp2) (make-pipe))
+(thread (lambda () ((copy-stream rp1 (cadr p))) (close-output-port (cadr p))))
+(thread (lambda () ((copy-stream (car p) wp2)) (close-output-port wp2)))
+(thread (lambda () 
+	  (feed-file/fast wp1)
+	  (close-output-port wp1)))
+(check-file/fast rp2)
+(end)
+
+(define l1 (tcp-listen portno))
+(define l2 (tcp-listen (add1 portno)))
+
+(start "TCP Echo...~n")
+(define-values (r w r2 w2) (setup-mzscheme-echo #t))
+(close-input-port r)
+(thread (lambda () 
+	  (feed-file w)
+	  (close-output-port w)))
+(check-file r2)
+(close-input-port r2)
+(end)
+
+(start "TCP Echo, faster...~n")
+(define-values (r w r2 w2) (setup-mzscheme-echo #t))
+(close-input-port r)
+(thread (lambda () 
+	  (feed-file/fast w)
+	  (close-output-port w)))
+(check-file/fast r2)
+(close-input-port r2)
+(end)
+
+(start "TCP Echo, indirect...~n")
+(define-values (rp1 wp1) (make-pipe))
+(define-values (rp2 wp2) (make-pipe))
+(define-values (r w r2 w2) (setup-mzscheme-echo #t))
+(close-input-port r)
+(thread (lambda () ((copy-stream rp1 w)) (close-output-port w)))
+(thread (lambda () ((copy-stream r2 wp2)) (close-output-port wp2)))
+(thread (lambda () 
+	  (feed-file/fast wp1)
+	  (close-output-port wp1)))
+(check-file/fast rp2)
+(end)
+
+(tcp-close l1)
+(tcp-close l2)
diff --git a/collects/tests/mzscheme/string.ss b/collects/tests/mzscheme/string.ss
new file mode 100644
index 0000000000..254e7f3284
--- /dev/null
+++ b/collects/tests/mzscheme/string.ss
@@ -0,0 +1,99 @@
+
+(load-relative "loadtest.ss")
+
+(SECTION 'mzlib-string)
+
+(require (lib "string.ss"))
+
+(let ([s1 (string-copy "Hello!")])
+  (string-lowercase! s1)
+  (test "hello!" 'lowercase s1)
+  (string-uppercase! s1)
+  (test "HELLO!" 'uppercase s1))
+
+(let ([s (list->string
+	  (let loop ([i 0])
+	    (if (= i 256)
+		null
+		(cons (integer->char i) (loop (add1 i))))))])
+  (test (list s) regexp-match (regexp-quote s) s)
+  (test (string-append "!" s "!")
+	regexp-replace (regexp-quote s) s (regexp-replace-quote (string-append "!" s "!"))))
+
+(let ([s (open-input-string "hello there")])
+  (test #f regexp-match/fail-without-reading #rx"not there" s)
+  (test #f regexp-match/fail-without-reading #rx"t$" s)
+  (test #f regexp-match/fail-without-reading #rx"hello there!!!" s)
+  (test "hello there" read-string 50 s))
+
+
+(test '("a" "b" "c") regexp-match* "[abc]" "here's a buck")
+(test '("b" "c") regexp-match* "[abc]" "here's a buck" 8)
+(test '("a") regexp-match* "[abc]" "here's a buck" 0 8)
+(test '("a" "b" "c") regexp-match* "[abc]" "here's a buck" 0 #f)
+
+(test '(#"a" #"b" #"c") regexp-match* "[abc]" #"here's a buck")
+(test '(#"b" #"c") regexp-match* "[abc]" #"here's a buck" 8)
+(test '(#"a") regexp-match* "[abc]" #"here's a buck" 0 8)
+(test '(#"a" #"b" #"c") regexp-match* "[abc]" #"here's a buck" 0 #f)
+
+(test '(#"a" #"b" #"c") regexp-match* #"[abc]" "here's a buck")
+(test '(#"b" #"c") regexp-match* #"[abc]" "here's a buck" 8)
+(test '(#"a") regexp-match* #"[abc]" "here's a buck" 0 8)
+(test '(#"a" #"b" #"c") regexp-match* #"[abc]" "here's a buck" 0 #f)
+
+(test '(#"a" #"b" #"c") regexp-match* "[abc]" (open-input-string "here's a buck"))
+(test '(#"b" #"c") regexp-match* "[abc]" (open-input-string "here's a buck") 8)
+(let ([s (open-input-string "here's a buck")])
+  (test '(#"a") regexp-match* "[abc]" s 0 8)
+  (test " buck" read-string 50 s))
+(let ([s (open-input-string "here's a buck")])
+  (test '(#"a" #"b" #"c") regexp-match* "[abc]" s 0 #f)
+  (test eof read-char s))
+
+(test '((7 . 8) (9 . 10) (11 . 12)) regexp-match-positions* "[abc]" "here's a buck")
+(test '((9 . 10) (11 . 12)) regexp-match-positions* "[abc]" "here's a buck" 8)
+(test '((7 . 8)) regexp-match-positions* "[abc]" "here's a buck" 0 8)
+(test '((7 . 8) (9 . 10) (11 . 12)) regexp-match-positions* "[abc]" "here's a buck" 0 #f)
+
+(test '((7 . 8) (9 . 10) (11 . 12)) regexp-match-positions* "[abc]" (open-input-string "here's a buck"))
+(test '((9 . 10) (11 . 12)) regexp-match-positions* "[abc]" (open-input-string "here's a buck") 8)
+(let ([s (open-input-string "here's a buck")])
+  (test '((7 . 8)) regexp-match-positions* "[abc]" s 0 8)
+  (test " buck" read-string 50 s))
+(let ([s (open-input-string "here's a buck")])
+  (test '((7 . 8) (9 . 10) (11 . 12)) regexp-match-positions* "[abc]" s 0 #f)
+  (test eof read-char s))
+
+(let ([s (open-input-string "here's a buck")])
+  (test '((7 . 8) (9 . 10) (11 . 12)) regexp-match-peek-positions* "[abc]" (open-input-string "here's a buck"))
+  (test '((9 . 10) (11 . 12)) regexp-match-peek-positions* "[abc]" (open-input-string "here's a buck") 8)
+  (test '((7 . 8)) regexp-match-peek-positions* "[abc]" s 0 8)
+  (test '((7 . 8) (9 . 10) (11 . 12)) regexp-match-peek-positions* "[abc]" s 0 #f)
+  (test "here's a buck" read-string 50 s))
+
+(test '("here's " " " "u" "k") regexp-split "[abc]" "here's a buck")
+(test '(" " "u" "k") regexp-split "[abc]" "here's a buck" 8)
+(test '("" "u" "k") regexp-split "[abc]" "here's a buck" 9)
+(test '("" "u" "") regexp-split "[abc]" "here's a buck" 9 12)
+(test '("here's " "") regexp-split "[abc]" "here's a buck" 0 8)
+(test '("here's " " ") regexp-split "[abc]" "here's a buck" 0 9)
+(test '("here's " " " "u" "k") regexp-split "[abc]" "here's a buck" 0 #f)
+
+(test '(#"here's " #" " #"u" #"k") regexp-split "[abc]" (open-input-string "here's a buck"))
+(test '(#" " #"u" #"k") regexp-split "[abc]" (open-input-string "here's a buck") 8)
+(test '(#"" #"u" #"k") regexp-split "[abc]" (open-input-string "here's a buck") 9)
+(let ([s (open-input-string "here's a buck")])
+  (test '(#"" #"u" #"") regexp-split "[abc]" s 9 12)
+  (test "k" read-string 50 s))
+(let ([s (open-input-string "here's a buck")])
+  (test '(#"here's " #"") regexp-split "[abc]" s 0 8)
+  (test " buck" read-string 50 s))
+(let ([s (open-input-string "here's a buck")])
+  (test '(#"here's " #" ") regexp-split "[abc]" s 0 9)
+  (test "buck" read-string 50 s))
+(let ([s (open-input-string "here's a buck")])
+  (test '(#"here's " #" " #"u" #"k") regexp-split "[abc]" s 0 #f)
+  (test eof read-char s))
+
+(report-errs)
diff --git a/collects/tests/mzscheme/struct.ss b/collects/tests/mzscheme/struct.ss
new file mode 100644
index 0000000000..9009b4bba1
--- /dev/null
+++ b/collects/tests/mzscheme/struct.ss
@@ -0,0 +1,723 @@
+
+(load-relative "loadtest.ss")
+
+(SECTION 'STRUCT)
+
+(let-values ([(prop:p p? p-ref) (make-struct-type-property 'prop (lambda (x y) (add1 x)))]
+	     [(prop:p2 p2? p2-ref) (make-struct-type-property 'prop2)]
+	     [(insp1) (make-inspector)]
+	     [(insp2) (make-inspector)])
+  (arity-test make-struct-type-property 1 2)
+  (test 3 primitive-result-arity make-struct-type-property)
+  (arity-test p? 1 1)
+  (arity-test p-ref 1 1)
+  (arity-test struct-type-property? 1 1)
+  (test #t struct-type-property? prop:p)
+  (test #f struct-type-property? 5)
+  (let-values ([(type make pred sel set) (make-struct-type 'a #f 2 1 'un (list (cons prop:p 87)) (make-inspector insp1))]
+	       [(typex makex predx selx setx) (make-struct-type 'ax #f 0 5 #f null (make-inspector insp2))])
+    (arity-test make-struct-type 4 10)
+    (test 5 primitive-result-arity make-struct-type)
+    (test #t struct-type? type)
+    (test #t procedure? make)
+    (arity-test make 2 2)
+    (arity-test makex 0 0)
+    (arity-test sel 2 2)
+    (arity-test set 3 3)
+    (test #t struct-mutator-procedure? set)
+    (test #t struct-accessor-procedure? sel)
+    (test #f struct-mutator-procedure? sel)
+    (test #f struct-accessor-procedure? set)
+    (test #t p? type)
+    (test #f p2? type)
+    (test #f p? 5)
+    (test 88 p-ref type)
+    (err/rt-test (p-ref 5))
+    (err/rt-test (p2-ref type))
+    (let ([sel1 (make-struct-field-accessor sel 0)]
+	  [set1 (make-struct-field-mutator set 0)]
+	  [sel2 (make-struct-field-accessor sel 2)]
+	  [set2 (make-struct-field-mutator set 2)])
+      (err/rt-test (make-struct-field-accessor set 0))
+      (err/rt-test (make-struct-field-mutator sel 0))
+      (err/rt-test (make-struct-field-accessor sel -1))
+      (err/rt-test (make-struct-field-mutator set -1))
+      (err/rt-test (make-struct-field-accessor sel 0.0))
+      (err/rt-test (make-struct-field-mutator set 0.0))
+      (arity-test sel1 1 1)
+      (arity-test set1 2 2)
+      (arity-test sel2 1 1)
+      (arity-test set2 2 2)
+      (test #t struct-mutator-procedure? set2)
+      (test #t struct-accessor-procedure? sel2)
+      (test #t struct-mutator-procedure? set1)
+      (test #t struct-accessor-procedure? sel1)
+      (test #f struct-mutator-procedure? sel2)
+      (test #f struct-accessor-procedure? set2)
+      (test #f struct-mutator-procedure? sel1)
+      (test #f struct-accessor-procedure? set1)
+      (err/rt-test (make-struct-field-accessor sel 3) exn:application:mismatch?)
+      (let ([an-a (make 'one 'two)]
+	    [an-ax (makex)])
+	(test #f procedure? an-a)
+	(test #f procedure? an-ax)
+
+	(test 'one sel an-a 0)
+	(test 'two sel an-a 1)
+	(test 'un sel an-a 2)
+	(test 'one sel1 an-a)
+	(test 'un sel2 an-a)
+
+	(err/rt-test (sel an-a -1))
+	(err/rt-test (sel an-a 3) exn:application:mismatch?)
+	(err/rt-test (set an-a -1 'v))
+	(err/rt-test (set an-a 3 'v) exn:application:mismatch?)
+
+	(test #t p? an-a)
+	(test 88 p-ref an-a)
+	(err/rt-test (p2-ref an-a))
+
+	(test #f selx an-ax 0)
+	(test #f selx an-ax 1)
+	(test #f selx an-ax 2)
+	(test #f selx an-ax 3)
+	(test #f selx an-ax 4)
+
+	(test (void) set an-a 0 'yi)
+	(test 'yi sel an-a 0)
+	(test (void) set an-a 2 'san)
+	(test 'san sel2 an-a)
+
+	(err/rt-test (sel 5 0))
+	(err/rt-test (set 5 0 10))
+	(err/rt-test (sel an-ax 0))
+	(err/rt-test (set an-ax 0 10))
+	(err/rt-test (sel1 5))
+	(err/rt-test (set1 5 10))
+
+	(let-values ([(prop:p3 p3? p3-ref) (make-struct-type-property 'prop3)]
+		     [(prop:p4 p4? p4-ref) (make-struct-type-property 'prop4)])
+	  (let-values ([(btype bmake bpred bsel bset) (make-struct-type 'b type 0 3 'unun (list (cons prop:p3 33) (cons prop:p4 44)) (make-inspector insp2))]
+		       [(btypex bmakex bpredx bselx bsetx) (make-struct-type 'bx typex 1 5 'nope (list (cons prop:p3 330)) (make-inspector insp1))])
+	    (arity-test bmake 2 2)
+	    (arity-test bmakex 1 1)
+
+	    (err/rt-test (make-struct-type 'bb type 0 0 #f (list (cons prop:p 12))) exn:application:mismatch?)
+	    (err/rt-test (make-struct-type 'bb btype 0 0 #f (list (cons prop:p3 12))) exn:application:mismatch?)
+	    (err/rt-test (make-struct-type 'bb #f 0 0 #f (list (cons prop:p 12) (cons prop:p2 12) (cons prop:p 12))) exn:application:mismatch?)
+	    (err/rt-test (make-struct-type 'bb type 0 0 #f (list (cons (let-values ([(p p? p-v)
+										     (make-struct-type-property 'p (lambda (v s)
+														     ;; this guard will fail!
+														     (/ 1 v)))])
+									 p)
+								       0))) exn:fail:contract:divide-by-zero?)
+	    
+	    (test #t p3? btype)
+	    (test #t p3? btypex)
+	    (test #f p3? type)
+	    (test #t p4? btype)
+	    (test #f p4? btypex)
+
+	    (test 88 p-ref btype)
+	    (test 33 p3-ref btype)
+	    (test 44 p4-ref btype)
+	    (err/rt-test (p2-ref btype))
+	    
+	    (test 330 p3-ref btypex)
+	    (err/rt-test (p2-ref btypex))
+	    (err/rt-test (p4-ref btypex))
+	    
+	    (let ([a-b (bmake 'bone 'btwo)]
+		  [a-bx (bmakex 'byi)])
+	      (test 'bone sel a-b 0)
+	      (test 'btwo sel a-b 1)
+	      (test 'bone sel1 a-b)
+	      (test 'un sel2 a-b)
+
+	      (test 'unun bsel a-b 0)
+	      (test 'unun bsel a-b 1)
+	      (test 'unun bsel a-b 2)
+	      (test (void) bset a-b 1 'did)
+	      (test 'unun bsel a-b 0)
+	      (test 'did bsel a-b 1)
+	      (test 'unun bsel a-b 2)
+
+	      (err/rt-test (sel a-b 3) exn:application:mismatch?)
+	      (err/rt-test (set a-b 3 'v) exn:application:mismatch?)
+	      (err/rt-test (bsel a-b 3) exn:application:mismatch?)
+
+	      (err/rt-test (bsel an-a 0))
+	      (err/rt-test (bset an-a 0 10))
+
+	      (arity-test struct->vector 1 2)
+
+	      (parameterize ([current-inspector insp1])
+		(test #(struct:a yi two san) struct->vector an-a)
+		(test #(struct:b bone btwo un ...) struct->vector a-b)
+		(test #(struct:ax ...) struct->vector an-ax)
+		(test #(struct:bx ... byi nope nope nope nope nope) struct->vector a-bx)
+
+		(test-values (list type #f) (lambda () (struct-info an-a)))
+		(test-values (list type #t) (lambda () (struct-info a-b)))
+
+		(test-values (list #f #t) (lambda () (struct-info an-ax)))
+		(test-values (list btypex #f) (lambda () (struct-info a-bx)))
+		
+		(err/rt-test (struct-type-info typex) exn:application:mismatch?)
+		(err/rt-test (struct-type-info btype) exn:application:mismatch?)
+
+		(let-values ([(name isize asize get put const super skipped?) (struct-type-info type)])
+		  (test 'bone get a-b 0)
+		  (put a-b 0 'ok)
+		  (test 'ok get a-b 0)
+		  (test (list 'a 2 1 null #f #f) list name isize asize const super skipped?))
+		(let-values ([(name isize asize get put const super skipped?) (struct-type-info btypex)])
+		  (test 'byi get a-bx 0)
+		  (put a-bx 0 'yep)
+		  (test 'yep get a-bx 0)
+		  (test (list 'bx 1 5 null #f #t) list name isize asize const super skipped?))
+
+		'...))))))))
+
+(err/rt-test (make-struct-type-property 1))
+(err/rt-test (make-struct-type-property 's (lambda () 10)))
+(err/rt-test (make-struct-type-property 's (lambda (x) 10)))
+
+(let ([t-insp (make-inspector)])
+  (define (try-proc-structs proc proc2 bad-arity name re 1-2-value t-insp)
+    (letrec-values ([(type make pred sel set) (make-struct-type 'p #f 1 2 (lambda (x) (pred x)) null t-insp proc)]
+		    ;; Derived from proc
+		    [(type2 make2 pred2 sel2 set2) (make-struct-type 'q type 1 2 (lambda (x) (pred2 x)) null t-insp #f)]
+		    ;; Derived, adds proc
+		    [(type3 make3 pred3 sel3 set3) (make-struct-type 'r struct:arity-at-least 1 1 (lambda (x) (pred3 x)) 
+								     null t-insp proc)])
+      (let* ([bad1 (make 17)]
+	     [bad2 (make2 18 -18)]
+	     [bad3 (make3 #f 19)]
+	     [bad11 (make bad1)])
+	(test #t pred bad1)
+	(test #t pred2 bad2)
+	(test #t pred3 bad3)
+	(test #t pred bad11)
+
+	(test #t procedure? bad1)
+	(test #t procedure? bad2)
+	(test #t procedure? bad3)
+	(test #t procedure? bad11)
+
+	(test bad-arity procedure-arity bad1)
+	(test bad-arity procedure-arity bad2)
+	(test bad-arity procedure-arity bad3)
+	(test bad-arity procedure-arity bad11)
+
+	(test 'p object-name bad1)
+	(test 'q object-name bad2)
+	(test 'r object-name bad3)
+	(test 'p object-name bad11)
+
+	(when (equal? 2 bad-arity)
+	  (test 1-2-value bad1 1 2)
+	  (test 1-2-value bad2 1 2)
+	  (test 1-2-value bad3 1 2)
+	  (test 1-2-value bad11 1 2))
+
+	(err/rt-test (bad1) exn:application:arity?)
+	(err/rt-test (bad2) exn:application:arity?)
+	(err/rt-test (bad3) exn:application:arity?)
+	(err/rt-test (bad11) exn:application:arity?)
+	(err/rt-test (bad1 1) exn:application:arity?)
+	(err/rt-test (bad2 1) exn:application:arity?)
+	(err/rt-test (bad3 1) exn:application:arity?)
+	(err/rt-test (bad11 1) exn:application:arity?)
+
+	(test '("p:") regexp-match "p:"
+	      (with-handlers ([exn:fail? exn-message])
+		(bad1)))
+	(test '("q:") regexp-match "q:"
+	      (with-handlers ([exn:fail? exn-message])
+		(bad2)))
+	(test '("r:") regexp-match "r:"
+	      (with-handlers ([exn:fail? exn-message])
+		(bad3)))
+	(test '("p:") regexp-match "p:"
+	      (with-handlers ([exn:fail? exn-message])
+		(bad11))))
+
+      (let* ([cons1 (make cons)]
+	     [cons2 (make2 cons -18)]
+	     [cons3 (make3 #f cons)]
+	     [cons11 (make cons1)])
+	(test #t pred cons1)
+	(test #t pred2 cons2)
+	(test #t pred3 cons3)
+	(test #t pred cons11)
+
+	(test #t procedure? cons1)
+	(test #t procedure? cons2)
+	(test #t procedure? cons3)
+	(test #t procedure? cons11)
+
+	(test 2 procedure-arity cons1)
+	(test 2 procedure-arity cons2)
+	(test 2 procedure-arity cons3)
+	(test 2 procedure-arity cons11)
+
+	(test (name 'p) object-name cons1)
+	(test (name 'q) object-name cons2)
+	(test (name 'r) object-name cons3)
+	(test (name 'p) object-name cons11)
+
+	(arity-test cons1 2 2)
+	(arity-test cons2 2 2)
+	(arity-test cons3 2 2)
+	(arity-test cons11 2 2)
+
+	(test 1-2-value cons1 1 2)
+	(test 1-2-value cons2 1 2)
+	(test 1-2-value cons3 1 2)
+	(test 1-2-value cons11 1 2)
+
+	(test #f not (regexp-match (re "p:")
+				   (with-handlers ([exn:fail? exn-message])
+				     (cons1))))
+	(test #f not (regexp-match (re "q:")
+				   (with-handlers ([exn:fail? exn-message])
+				     (cons2))))
+	(test #f not (regexp-match (re "r:")
+				   (with-handlers ([exn:fail? exn-message])
+				     (cons3))))
+	(test #f not (regexp-match (re "p:")
+				   (with-handlers ([exn:fail? exn-message])
+				     (cons11)))))
+      
+      'done))
+
+  (try-proc-structs 0 0 null (lambda (x) 'cons) (lambda (x) "cons:") '(1 . 2) (current-inspector))
+  (try-proc-structs 0 0 null (lambda (x) 'cons) (lambda (x) "cons:") '(1 . 2) t-insp)
+  (try-proc-structs (lambda (s a b) 
+		      (when (and (struct? s) (not (arity-at-least? s)))
+			(error "should be opaque"))
+		      (cons b a)) 
+		    (lambda (s a b) 
+		      (when (struct? s)
+			(error "should be opaque"))
+		      (cons b a))
+		    2 values values '(2 . 1) (current-inspector))
+  (try-proc-structs (lambda (s a b) 
+		      (unless (struct? s) (error "should be transparent"))
+		      (unless ((vector-ref (struct->vector s) 3) s) (error "should be instance"))
+		      (cons b a))
+		    (lambda (s a b) 
+		      (unless (struct? s) (error "should be transparent"))
+		      (unless ((vector-ref (struct->vector s) 3) s) (error "should be instance"))
+		      (unless ((vector-ref (struct->vector s) 5) s) (error "should be instance"))
+		      (cons b a))
+		    2 values values '(2 . 1) t-insp))
+
+(err/rt-test (let-values ([(s:s make-s s? s-ref s-set!)
+			   (make-struct-type 'a #f 1 1 #f null (current-inspector) 0)])
+	       (make-struct-type 'b s:s 1 1 #f null (current-inspector) 0))
+	     exn:application:mismatch?)
+
+(let-values ([(type make pred sel set) (make-struct-type 'p #f 1 0 #f null (current-inspector) (lambda () 5))])
+  (let ([useless (make 7)])
+    (test #t pred useless)
+    (test #t procedure? useless)
+    (test null procedure-arity useless)
+    (test 'p object-name useless)
+    (err/rt-test (useless) exn:application:arity?)
+    (err/rt-test (useless 1) exn:application:arity?)
+    (err/rt-test (useless 1 2) exn:application:arity?)))
+
+(let-values ([(type make pred sel set) (make-struct-type 'p #f 1 0 #f null (current-inspector)
+							 (case-lambda 
+							  [(x) 7]
+							  [() 5]
+							  [(x y z) 8]))]) 
+  (let ([useless (make 7)])
+    (test #t pred useless)
+    (test #t procedure? useless)
+    (test '(0 2) procedure-arity useless)
+    (test 'p object-name useless)
+    (test 7 useless)
+    (err/rt-test (useless 1) exn:application:arity?)
+    (test 8 useless 1 2)
+    (err/rt-test (useless 1 2 3) exn:application:arity?)))
+
+;; Test constructor guard
+(let ()
+  (define got null)
+  (define mode 'normal)
+  (define-values (s:o make-o o? o-ref o-set!)
+    (make-struct-type 'o #f 1 0 'odefault
+		      null
+		      (make-inspector) #f
+		      null (lambda (o n) 
+			     (+ o 1))))
+  (define-values (s:a make-a a? a-ref a-set!)
+    (make-struct-type 'a #f 2 1 'adefault
+		      null
+		      (make-inspector) #f
+		      null (lambda (a b n) 
+			     (set! got (cons (list a b n) got))
+			     (case mode
+			       [(normal) (values 1 2)]
+			       [(reject) (/ 1 0)]
+			       [(bad) 'one]))))
+  (define-values (s:b make-b b? b-ref b-set!)
+    (make-struct-type 'b s:a 1 2 'bdefault
+		      null
+		      (make-inspector) #f
+		      null (lambda (a b c n) 
+			     (set! got (cons (list a b c n) got))
+			     (case mode
+			       [(normal) (values 10 20 30)]
+			       [(reject) ((let/ec k k))]))))
+  (let ([o1 (make-o 10)])
+    (test 11 o-ref o1 0))
+  (let ([a1 (make-a 'x 'y)])
+    (test 1 a-ref a1 0)
+    (test 2 a-ref a1 1)
+    (test 'adefault a-ref a1 2)
+    (test '((x y a)) values got))
+  (let ([b1 (make-b 'x 'y 'z)])
+    (test 1 a-ref b1 0)
+    (test 2 a-ref b1 1)
+    (test 'adefault a-ref b1 2)
+    (test 30 b-ref b1 0)
+    (test 'bdefault b-ref b1 1)
+    (test '((10 20 b) (x y z b) (x y a)) values got))
+  (set! mode 'reject)
+  (err/rt-test (make-a 'x 'y) exn:fail:contract:divide-by-zero?)
+  (err/rt-test (make-b 'x 'y 'z) exn:fail:contract:continuation?)
+  (set! mode 'bad)
+  (err/rt-test (make-a 'x 'y) exn:application:arity?)
+  (err/rt-test (make-b 'x 'y 'z) exn:application:arity?))
+(err/rt-test (make-struct-type 'a #f 2 1 'adefault null (make-inspector) #f null 
+			       ;; Not a proc:
+			       10))
+(err/rt-test (make-struct-type 'a #f 2 1 'adefault null (make-inspector) #f null 
+			       ;; Wrong arg count:
+			       (lambda (x y) (void)))
+	     exn:application:mismatch?)
+(err/rt-test (make-struct-type 'a #f 2 0 'adefault null (make-inspector) #f null 
+			       ;; Wrong arg count, again:
+			       (lambda (x y) (void)))
+	     exn:application:mismatch?)
+
+
+(define-struct a (b c))
+(define-struct aa ())
+(define ai (make-a 1 2))
+(define aai (make-aa))
+(test #t struct-type? struct:a)
+(test #f struct-type? 5)
+(test #t procedure? a?)
+(test #t a? ai)
+(test #f a? 1)
+(test #f aa? ai)
+(test #f struct? ai)
+(test 1 a-b ai)
+(test 2 a-c ai)
+(define ai2 (make-a 1 2))
+(set-a-b! ai2 3)
+(set-a-c! ai2 4)
+(test 1 a-b ai)
+(test 2 a-c ai)
+(test 3 a-b ai2)
+(test 4 a-c ai2)
+(define-struct a (b c))
+(test #f a? ai)
+(arity-test make-a 2 2)
+(err/rt-test (make-aa 1) exn:application:arity?)
+(arity-test a? 1 1)
+(arity-test a-b 1 1)
+(arity-test a-c 1 1)
+(arity-test set-a-b! 2 2)
+(arity-test set-a-c! 2 2)
+(err/rt-test (a-b 5))
+(err/rt-test (a-b ai))
+(err/rt-test (set-a-b! ai 5))
+(err/rt-test (set-a-c! ai 5))
+
+(arity-test struct-type? 1 1)
+
+(define (gen-struct-syntax-test formname suffix)
+  (syntax-test (datum->syntax-object #f `(,formname 1 (x) ,@suffix) #f))
+  (syntax-test (datum->syntax-object #f `(,formname a (1) ,@suffix) #f))
+  (syntax-test (datum->syntax-object #f `(,formname a (x 1) ,@suffix) #f))
+  (syntax-test (datum->syntax-object #f `(,formname a (x . y) ,@suffix) #f))
+  (syntax-test (datum->syntax-object #f `(,formname (a) (x) ,@suffix) #f))
+  (syntax-test (datum->syntax-object #f `(,formname (a . y) (x) ,@suffix) #f))
+  (syntax-test (datum->syntax-object #f `(,formname (a 2) (x) ,@suffix) #f))
+  (syntax-test (datum->syntax-object #f `(,formname (a 2 3) (x) ,@suffix) #f)))
+(define (struct-syntax-test formname)
+  (syntax-test (datum->syntax-object #f `(,formname) #f))
+  (syntax-test (datum->syntax-object #f `(,formname . a) #f))
+  (syntax-test (datum->syntax-object #f `(,formname a . x) #f))
+  (syntax-test (datum->syntax-object #f `(,formname (a 9) (x)) #f))
+  (syntax-test (datum->syntax-object #f `(,formname a x) #f))
+  (gen-struct-syntax-test formname '()))
+
+(struct-syntax-test 'define-struct)
+(gen-struct-syntax-test 'let-struct '(5))
+
+(define-struct base0 ())
+(define-struct base1 (a))
+(define-struct base2 (l r))
+(define-struct base3 (x y z))
+
+(define-struct (one00 base0) ())
+(define-struct (one01 base1) ())
+(define-struct (one02 base2) ())
+(define-struct (one03 base3) ())
+
+(define-struct (one10 base0) (a))
+(define-struct (one11 base1) (a))
+(define-struct (one12 base2) (a))
+(define-struct (one13 base3) (a))
+
+(define-struct (one20 base0) (l r))
+(define-struct (one21 base1) (l r))
+(define-struct (one22 base2) (l r))
+(define-struct (one23 base3) (l r))
+
+(define-struct (one30 base0) (x y z))
+(define-struct (one31 base1) (x y z))
+(define-struct (one32 base2) (x y z))
+(define-struct (one33 base3) (x y z))
+
+(define-struct (two100 one00) (a))
+(define-struct (two101 one01) (a))
+(define-struct (two102 one02) (a))
+(define-struct (two103 one03) (a))
+(define-struct (two110 one10) (a))
+(define-struct (two111 one11) (a))
+(define-struct (two112 one12) (a))
+(define-struct (two113 one13) (a))
+(define-struct (two120 one20) (a))
+(define-struct (two121 one21) (a))
+(define-struct (two122 one22) (a))
+(define-struct (two123 one23) (a))
+(define-struct (two130 one30) (a))
+(define-struct (two131 one31) (a))
+(define-struct (two132 one32) (a))
+(define-struct (two133 one33) (a))
+
+(define x00 (make-one00))
+
+(define x01 (make-one01 1))
+
+(define x10 (make-one10 1))
+(define x11 (make-one11 1 2))
+(define x12 (make-one12 1 2 3))
+(define x13 (make-one13 1 2 3 4))
+
+(define x31 (make-one31 1 2 3 4))
+
+(define x33 (make-one33 1 2 3 4 5 6))
+
+(define x132 (make-two132 1 2 3 4 5 6))
+
+(define (ones v)
+  (cond
+   [(one00? v) 'one00]
+   [(one01? v) 'one01]
+   [(one02? v) 'one02]
+   [(one03? v) 'one03]
+   
+   [(one10? v) 'one10]
+   [(one11? v) 'one11]
+   [(one12? v) 'one12]
+   [(one13? v) 'one13]
+   
+   [(one20? v) 'one20]
+   [(one21? v) 'one21]
+   [(one22? v) 'one22]
+   [(one23? v) 'one23]
+   
+   [(one30? v) 'one30]
+   [(one31? v) 'one31]
+   [(one32? v) 'one32]
+   [(one33? v) 'one33]))
+
+(define (multi v)
+  (cond
+   [(two130? v) 'two130]
+   [(two131? v) 'two131]
+   [(two132? v) 'two132]
+   [(two133? v) 'two133]
+   
+   [(one10? v) 'one10]
+   [(one11? v) 'one11]
+   [(one12? v) 'one12]
+   [(one13? v) 'one13]
+   
+   [(one20? v) 'one20]
+   [(one21? v) 'one21]
+   [(one22? v) 'one22]
+   [(one23? v) 'one23]
+   
+   [(base0? v) 'base0]
+   [(base1? v) 'base1]
+   [(base2? v) 'base2]
+   [(base3? v) 'base3]))
+
+(define (dummy v)
+  'ok)
+
+(define (go f v n)
+  (time
+   (let loop ([n n])
+     (unless (zero? n)
+	     (f v)
+	     (loop (sub1 n))))))
+
+(define check
+  (lambda (l)
+    (cond
+     [(null? l) #f]
+     [else
+      (test (caddr l) (car l) (cadr l))
+      (check (cdddr l))])))
+
+(define ones-test
+  (list x00 'one00
+	x10 'one10
+	x11 'one11
+	x12 'one12
+	x13 'one13
+	x33 'one33))
+	
+(define multi-test
+  (list x00 'base0
+	x10 'one10
+	x11 'one11
+	x12 'one12
+	x13 'one13
+	x33 'base3
+	x132 'two132))	     
+
+(letrec ([bundle
+	  (lambda (l f)
+	    (if (null? l)
+		null
+		(list* f (car l) (cadr l)
+		       (bundle (cddr l) f))))])
+  (check (append
+	  (bundle ones-test ones)
+	  (bundle multi-test multi)
+	  (list base1-a x11 1
+		one11-a x11 2
+		one10-a x10 1
+		
+		base1-a x31 1
+		one31-z x31 4
+		
+		base2-l x132 1
+		two132-a x132 6
+		one32-y x132 4))))
+
+;; ------------------------------------------------------------
+;; Check that struct definiton sequences work:
+
+(let ()
+  (define-struct a (x y))
+  (define-struct (b a) (z))
+  (define-struct (c b) (w))
+
+  (test 1 a-x (make-a 1 2))
+  (test 10 a-x (make-b 10 20 30))
+  (test 100 a-x (make-c 100 200 300 400)))
+
+;; ------------------------------------------------------------
+;; Misc. built-in structures
+
+(test #f srcloc? 10)
+(test #t srcloc? (make-srcloc 'ok 1 2 3 4))
+(test 'ok srcloc-source (make-srcloc 'ok 1 2 3 4))
+(test 1 srcloc-line (make-srcloc 'ok 1 2 3 4))
+(test #f srcloc-line (make-srcloc 'ok #f 2 3 4))
+(test 2 srcloc-column (make-srcloc 'ok 1 2 3 4))
+(test 0 srcloc-column (make-srcloc 'ok 1 0 3 4))
+(test #f srcloc-column (make-srcloc 'ok 1 #f 3 4))
+(test 3 srcloc-position (make-srcloc 'ok 1 2 3 4))
+(test #f srcloc-position (make-srcloc 'ok 1 2 #f 4))
+(test 4 srcloc-span (make-srcloc 'ok 1 2 3 4))
+(test 0 srcloc-span (make-srcloc 'ok 1 2 3 0))
+(test #f srcloc-span (make-srcloc 'ok 1 2 3 #f))
+
+(err/rt-test (make-srcloc 'ok 'no 2 3 4))
+(err/rt-test (make-srcloc 'ok 0 2 3 4))
+(err/rt-test (make-srcloc 'ok 1 'no 3 4))
+(err/rt-test (make-srcloc 'ok 1 -1 3 4))
+(err/rt-test (make-srcloc 'ok 1 2 'no 4))
+(err/rt-test (make-srcloc 'ok 1 2 0 4))
+(err/rt-test (make-srcloc 'ok 1 2 3 'no))
+(err/rt-test (make-srcloc 'ok 1 2 3 -1))
+
+;; ------------------------------------------------------------
+;; Custom write
+
+(define (custom-write-check normal?)
+  (define (tuple-print tuple port write?)
+    (when write? (write-string "<" port))
+    (let ([l (tuple-ref tuple 0)])
+      (unless (null? l)
+	((if write? write display) (car l) port)
+	(for-each (lambda (e)
+		    (write-string ", " port)
+		    (if normal?
+			;; Test normal recusrive write:
+			((if write? write display) e port)
+			;; Test writing recursively to a string:
+			(let ([p (open-output-string)])
+			  (port-write-handler p (port-write-handler port))
+			  (port-display-handler p (port-display-handler port))
+			  (port-print-handler p (port-print-handler port))
+			  ((if write? write display) e p)
+			  (write-string (get-output-string p) port))))
+		  (cdr l))))
+    (when write? (write-string ">" port)))
+
+  (define-values (s:tuple make-tuple tuple? tuple-ref tuple-set!)
+    (make-struct-type 'tuple #f 1 0 #f
+		      (list (cons prop:custom-write tuple-print))))
+  
+  (define (with-output-string thunk)
+    (let ([p (open-output-string)])
+      (parameterize ([current-output-port p])
+	(thunk))
+      (get-output-string p)))
+
+  (test "<1, 2, \"a\">" with-output-string 
+	(lambda ()
+	  (tuple-print (make-tuple '(1 2 "a")) (current-output-port) #t)))
+
+  (test "1, 2, a" with-output-string 
+	(lambda ()
+	  (display (make-tuple '(1 2 "a")))))
+  (test "#0=<#0#, 2, \"a\">" with-output-string 
+	(lambda ()
+	  (let ([t (make-tuple (list 1 2 "a"))])
+	    (set-car! (tuple-ref t 0) t)
+	    (write t))))
+  (test "ack: here: <10, 2, \"a\">" with-output-string 
+	(lambda ()
+	  (with-handlers ([exn:fail? (lambda (exn)
+				       (printf "~a" (exn-message exn)))])
+	    (error 'ack "here: ~e" (make-tuple (list 10 2 "a"))))))
+  
+  (test "ack: here: <100000..." with-output-string 
+	(lambda ()
+	  (parameterize ([error-print-width 10])  
+	    (with-handlers ([exn:fail? (lambda (exn)
+					 (printf "~a" (exn-message exn)))])
+	      (error 'ack "here: ~e" (make-tuple (list 10000000000000000000000000000000000 2 "a"))))))))
+
+(custom-write-check #t)
+(custom-write-check #f)
+
+;; ----------------------------------------
+
+(report-errs)
diff --git a/collects/tests/mzscheme/structc.ss b/collects/tests/mzscheme/structc.ss
new file mode 100644
index 0000000000..2e7d616fb6
--- /dev/null
+++ b/collects/tests/mzscheme/structc.ss
@@ -0,0 +1,182 @@
+
+(define ones-case
+  (make-struct-case
+   (list
+    one00?
+    one01?
+    one02?
+    one03?
+    
+    one10?
+    one11?
+    one12?
+    one13?
+    
+    one20?
+    one21?
+    one22?
+    one23?
+    
+    one30?
+    one31?
+    one32?
+    one33?)
+   
+   (list
+    (lambda (x) 'one00)
+    (lambda (x) 'one01)
+    (lambda (x) 'one02)
+    (lambda (x) 'one03)
+    
+    (lambda (x) 'one10)
+    (lambda (x) 'one11)
+    (lambda (x) 'one12)
+    (lambda (x) 'one13)
+    
+    (lambda (x) 'one20)
+    (lambda (x) 'one21)
+    (lambda (x) 'one22)
+    (lambda (x) 'one23)
+    
+    (lambda (x) 'one30)
+    (lambda (x) 'one31)
+    (lambda (x) 'one32)
+    (lambda (x) 'one33))))
+
+(define multi-case
+  (make-struct-case
+   (list
+    two130?
+    two131?
+    two132?
+    two133?
+    
+    one10?
+    one11?
+    one12?
+    one13?
+    
+    one20?
+    one21?
+    one22?
+    one23?
+    
+    base0?
+    base1?
+    base2?
+    base3?)
+
+   (list
+    (lambda (x) 'two130)
+    (lambda (x) 'two131)
+    (lambda (x) 'two132)
+    (lambda (x) 'two133)
+    
+    (lambda (x) 'one10)
+    (lambda (x) 'one11)
+    (lambda (x) 'one12)
+    (lambda (x) 'one13)
+    
+    (lambda (x) 'one20)
+    (lambda (x) 'one21)
+    (lambda (x) 'one22)
+    (lambda (x) 'one23)
+    
+    (lambda (x) 'base0)
+    (lambda (x) 'base1)
+    (lambda (x) 'base2)
+    (lambda (x) 'base3))
+   
+   (lambda (x) x)))
+
+(letrec ([bundle
+	  (lambda (l f)
+	    (if (null? l)
+		null
+		(list* f (car l) (cadr l)
+		       (bundle (cddr l) f))))])
+  (check (append
+	  (bundle ones-test ones-case)
+	  (bundle multi-test multi-case)
+	  (list base1-a x11 1
+		one11-a x11 2
+		one10-a x10 1
+		
+		base1-a x31 1
+		one31-z x31 4
+		
+		base2-l x132 1
+		two132-a x132 6
+		one32-y x132 4))))
+
+(test #t arity-at-least? (multi-case (arity void)))
+
+(arity-test multi-case 1 1)
+
+(error-test `(,ones-case 6) type?)
+(error-test `(,multi-case 6) type?)
+
+(error-test `(,ones-case (arity void)) exn:else?)
+
+(test (void) (make-struct-case null null void) x00)
+(test #t procedure? (make-struct-case null null))
+
+(error-test `((make-struct-case null null) x00) exn:else?)
+
+(error-test `(make-struct-case (list 8) (list void)))
+(error-test `(make-struct-case (list exn:misc? 8) (list void void)))
+(error-test `(make-struct-case (list exn:misc? 8 exn?) (list void void void)))
+(error-test `(make-struct-case exn? (list void)))
+(error-test `(make-struct-case (list* exn:misc? exn?) (list void)))
+
+(error-test `(make-struct-case (list exn?) (list 8)))
+(error-test `(make-struct-case (list exn?) (list (lambda () 8))))
+(error-test `(make-struct-case (list exn:misc? exn?) 
+			       (list void string-set!)))
+(error-test `(make-struct-case (list exn:misc? exn:syntax? exn?) 
+			       (list void void string-set!)))
+(error-test `(make-struct-case (list exn?) void))
+(error-test `(make-struct-case (list exn?) (list* void void)))
+
+(error-test `(make-struct-case (list exn:misc?) (list void void)) 
+	    exn:application:list-sizes?)
+(error-test `(make-struct-case (list exn:misc? exn?) (list void)) 
+	    exn:application:list-sizes?)
+
+(arity-test make-struct-case 2 3)
+
+(test 0 (struct-case-lambda x (else 0)) (arity void))
+(test (arity void) (struct-case-lambda x (else)) (arity void))
+(test (arity void) (struct-case-lambda x (arity-at-least?)) (arity void))
+(test 0 (struct-case-lambda x (arity-at-least? 0) (else 1)) (arity void))
+
+(define s (struct-case-lambda x
+	    [exn? 'exn]
+	    [arity-at-least? x]
+	    [else (cons x 5)]))
+
+(test 'exn s (make-exn 1 2))
+(test (arity void) s (arity void))
+(test (cons x00 5) s x00)
+
+(arity-test s 1 1)
+
+(error-test '(s 9))
+(error-test '(struct-case-lambda) syntaxe?)
+(error-test '(struct-case-lambda 5) syntaxe?)
+(error-test '(struct-case-lambda x . 5) syntaxe?)
+(error-test '(struct-case-lambda x ()) syntaxe?)
+(error-test '(struct-case-lambda x else) syntaxe?)
+(error-test '(struct-case-lambda x (else 9) (exn? 8)) syntaxe?))
+
+(define time-branch
+  (lambda (proc list)
+    (time
+     (let loop ([n 1000])
+       (unless (zero? n)
+	       (let loop ([l list])
+		 (unless (null? l)
+			 (proc (car l))
+			 (loop (cddr l))))
+	       (loop (sub1 n)))))))
+
diff --git a/collects/tests/mzscheme/structlib.ss b/collects/tests/mzscheme/structlib.ss
new file mode 100644
index 0000000000..f4f7d10c5c
--- /dev/null
+++ b/collects/tests/mzscheme/structlib.ss
@@ -0,0 +1,39 @@
+
+(load-relative "loadtest.ss")
+
+(SECTION 'structlib)
+
+(require (lib "struct.ss"))
+
+(let ([now (seconds->date (current-seconds))])
+  (test #t equal? now (copy-struct date now))
+  (test #f equal? now (copy-struct date now (date-second -1)))
+  (test -1 date-second (copy-struct date now (date-second -1)))
+  (test (date-year now) date-year (copy-struct date now (date-second -1))))
+
+(err/rt-test (copy-struct date 10))
+(err/rt-test (copy-struct date 10 (date-second 0)))
+
+(syntax-test #'copy-struct)
+(syntax-test #'(copy-struct))
+(syntax-test #'(copy-struct date))
+(syntax-test #'(copy-struct date 10 foo))
+(syntax-test #'(copy-struct date 10 . foo))
+(syntax-test #'(copy-struct date 10 (foo)))
+(syntax-test #'(copy-struct date 10 (foo . bar)))
+
+(syntax-test #'(copy-struct x 10))
+(syntax-test #'(copy-struct date 10 (date-foo 12)))
+(syntax-test #'(copy-struct date 10 (date-second 12) (date-yeeer 10)))
+(syntax-test #'(copy-struct date 10 (date-second 12) (date-second 10)))
+
+(require (rename mzscheme mz:date-second date-second))
+(syntax-test #'(copy-struct date 10 (date-second 12) (mz:date-second 10)))
+
+(let ([v (let ()
+	   (define-struct a (b c) (make-inspector))
+	   ;; This `copy-struct' is expanded in an internal-defn context
+	   (copy-struct a (make-a 1 2) (a-c 13)))])
+  (test #(struct:a 1 13) struct->vector v))
+
+(report-errs)
diff --git a/collects/tests/mzscheme/stx.ss b/collects/tests/mzscheme/stx.ss
new file mode 100644
index 0000000000..1ca2c78c3c
--- /dev/null
+++ b/collects/tests/mzscheme/stx.ss
@@ -0,0 +1,1007 @@
+
+(load-relative "loadtest.ss")
+
+(SECTION 'stx)
+
+(test #t syntax? (datum->syntax-object #f 'hello #f))
+
+(test #f syntax-line (datum->syntax-object #f 10 '(aha #f #f 19 #f)))
+(test #f syntax-column (datum->syntax-object #f 10 '(aha #f #f 19 #f)))
+(test 19 syntax-position (datum->syntax-object #f 10 '(aha #f #f 19 #f)))
+(test 'aha syntax-source (datum->syntax-object #f 10 '(aha #f #f 19 #f)))
+(test #f syntax-span (datum->syntax-object #f 10 '(aha #f #f 19 #f)))
+(test 88 syntax-span (datum->syntax-object #f 10 '(aha #f #f 19 88)))
+
+(test 7 syntax-line (datum->syntax-object #f 10 '(aha 7 88 999 #f)))
+(test 88 syntax-column (datum->syntax-object #f 10 '(aha 7 88 999 #f)))
+(test 999 syntax-position (datum->syntax-object #f 10 '(aha 7 88 999 #f)))
+(test 'aha syntax-source (datum->syntax-object #f 10 '(aha 7 88 999 #f)))
+(test #f syntax-span (datum->syntax-object #f 10 '(aha 7 88 999 #f)))
+(test 22 syntax-span (datum->syntax-object #f 10 '(aha 7 88 999 22)))
+(test 0 syntax-span (datum->syntax-object #f 10 '(aha 1 1 1 0)))
+(test 0 syntax-column (datum->syntax-object #f 10 '(aha 1 0 1 0)))
+
+(err/rt-test (datum->syntax-object #f 10 10))
+(err/rt-test (datum->syntax-object #f 10 '(10)))
+(err/rt-test (datum->syntax-object #f 10 '(10 11)))
+(err/rt-test (datum->syntax-object #f 10 '(10 11 12)))
+(err/rt-test (datum->syntax-object #f 10 '(10 11 12 13)))
+(err/rt-test (datum->syntax-object #f 10 '(10 11 12 13 14 15)))
+(err/rt-test (datum->syntax-object #f 10 '(a 11.0 12 13 14)))
+(err/rt-test (datum->syntax-object #f 10 '(a 11 12 -13 14)))
+(err/rt-test (datum->syntax-object #f 10 '(a 11 12 -13 14)))
+(err/rt-test (datum->syntax-object #f 10 '(a 11 12 13 -1)))
+(err/rt-test (datum->syntax-object #f 10 '(a 0 12 13 0)))
+(err/rt-test (datum->syntax-object #f 10 '(a 11 -1 13 0)))
+(err/rt-test (datum->syntax-object #f 10 '(a 11 12 0 0)))
+
+(syntax-test #'quote-syntax)
+(syntax-test #'(quote-syntax))
+(syntax-test #'(quote-syntax . 7))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; some syntax-case patterns
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(test 17 'syntax-case (syntax-case '(1 1 1) () [(1 ...) 17]))
+
+(define-syntax sd (syntax-rules () [(_ v) (syntax-object->datum (syntax v))]))
+
+(test '(3 1 2) 'syntax-case (syntax-case '(1 2 3) () [(a ... b) (sd (b a ...))]))
+(test 5 'syntax-case (syntax-case '(1 2 3) () [(a ... b . c) (sd (b a ... c))][_else 5]))
+(test '(3 1 2 4) 'syntax-case (syntax-case '(1 2 3 . 4) () [(a ... b . c) (sd (b a ... c))][_else 5]))
+(test '(3 1 2 4) 'syntax-case (syntax-case '(1 2 (3 . 4)) () [(a ... (b . c)) (sd (b a ... c))][_else 5]))
+(test '((3) 1 2 4) 'syntax-case (syntax-case '(1 2 (3 . 4)) () [(a ... (b ... . c)) (sd ((b ...) a ... c))][_else 5]))
+(test '(3 1 2 4) 'syntax-case (syntax-case '(1 2 (3 . 4)) () [(a ... (b ... . c)) (sd (b ... a ... c))][_else 5]))
+(test '((3) 1 2 4) 'syntax-case (syntax-case '(1 2 ((3) . 4)) () [(a ... ((b ...) ... . c)) (sd ((b ...) ... a ... c))][_else 5]))
+(test '(3 1 2 4) 'syntax-case (syntax-case '(1 2 ((3) . 4)) () [(a ... ((b ...) ... . c)) (sd (b ... ... a ... c))][_else 5]))
+
+(syntax-test (quote-syntax (syntax-case 0 () [(a ... b c ...) 1][_else 5])))
+(syntax-test (quote-syntax (syntax-case 0 () [(a ... b . (c ...)) 1][_else 5])))
+(syntax-test (quote-syntax (syntax-case 0 () [(a ... ...) 1][_else 5])))
+(syntax-test (quote-syntax (syntax-case 0 () [(a ...) #'a][_else 5])))
+(syntax-test (quote-syntax (syntax-case 0 () [(a ...) #'((a ...) ...)][_else 5])))
+(syntax-test (quote-syntax (syntax-case 0 () [(a ...) #'(a ... ...)][_else 5])))
+(syntax-test (quote-syntax (syntax-case 0 () [((a ...) ...) #'a][_else 5])))
+(syntax-test (quote-syntax (syntax-case 0 () [((a ...) ...) #'(a ...)][_else 5])))
+(syntax-test (quote-syntax (syntax-case 0 () [((a ...) ...) #'(a ... ... ...)][_else 5])))
+
+(test 'no 'dot-literal (syntax-case #'(1 2) () [(_ . #t) 'yes] [_ 'no]))
+(test 'yes 'dot-literal (syntax-case #'(1 . #t) () [(_ . #t) 'yes] [_ 'no]))
+
+(test '(((x 3) (y 3) (z 3)) ;; each line should be x y z, not x x x...
+	((x 4) (y 4) (z 4))
+	((x 5) (y 5) (z 5)))
+      'ellipses
+      (syntax-object->datum (syntax-case '(_ 1 (x y z) ((3 3 3) (4 4 4) (5 5 5))) () 
+			      [(_ x (a ...) ((b ...) ...)) #'(((a b) ...) ...)])))
+
+(test '(((x y z 3) (x y z 3) (x y z 3))
+	((x y z 4) (x y z 4) (x y z 4))
+	((x y z 5) (x y z 5) (x y z 5)))
+      'ellipses
+      (syntax-object->datum (syntax-case '(_ 1 (x y z) ((3 3 3) (4 4 4) (5 5 5))) () 
+			      [(_ x (a ...) ((b ...) ...)) #'(((a ... b) ...) ...)])))
+
+
+(test '((1 z) (2 w) (x z) (y w))
+      'ellipses
+      (syntax-object->datum (syntax-case '(((1 2) (x y)) (z w)) () 
+			      [(((a ...) ...) (b ...)) #'((a b) ... ...)])))
+
+(test '(#(1) #(2 3))
+      'ellipses+vector
+      (syntax-object->datum 
+       (syntax-case '((1) (2 3)) () [((a ...) ...) #'(#(a ...) ...)])))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Test basic expansion and property propagation
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (tree-map f)
+  (lambda (l)
+    (if (pair? l)
+	(cons ((tree-map f) (car l))
+	      ((tree-map f) (cdr l)))
+	(if (null? l)
+	    null
+	    (f l)))))
+
+(define-syntax mcr
+  (lambda (stx)
+    (syntax-case stx ()
+      [(_ x) (syntax (begin x))])))
+
+(define s (quote-syntax (mcr 5)))
+(define se (expand-once s))
+
+(syntax-case se ()
+  [(bg five)
+   (let ([bg (syntax bg)]
+	 [five (syntax five)])
+     (test 'begin syntax-e bg)
+     (test 5 syntax-e five)
+
+     (test #t syntax-original? five)
+     (test #f syntax-original? bg)
+
+     'ok)])
+
+(test #f syntax-property s 'testing)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Plain s, se derived from part of s
+
+(define s (syntax-property (quote-syntax (mcr 5)) 'testing 10))
+(define se (expand-once s))
+
+(test 10 syntax-property s 'testing)
+(test 10 syntax-property se 'testing)
+(test '(mcr) (tree-map syntax-e) (syntax-property se 'origin))
+
+(test 10 syntax-property (datum->syntax-object #f 0 #f s) 'testing)
+
+(test #t syntax-original? s)
+(test #f syntax-original? se)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Plain s, se is part of s
+
+(define-syntax mcr2
+  (lambda (stx)
+    (syntax-case stx ()
+      [(_ x) (syntax x)])))
+
+(define s (syntax-property (quote-syntax (mcr2 5)) 'testing 10))
+(define se (expand-once s))
+
+(test (syntax-e (cadr (syntax-e s))) syntax-e se)
+
+(test 10 syntax-property s 'testing)
+(test 10 syntax-property se 'testing)
+(test '(mcr2) (tree-map syntax-e) (syntax-property se 'origin))
+
+(test #t syntax-original? s)
+(test #t syntax-original? se)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Constructed s, se is part of s, part of s tagged
+
+(define s (syntax-property (with-syntax ([five (syntax-property (quote-syntax 5)
+								'testing
+								12)])
+			     (syntax (mcr2 five)))
+			   'testing 10))
+(define se (expand-once s))
+
+(test (syntax-e (cadr (syntax-e s))) syntax-e se)
+
+(test 10 syntax-property s 'testing)
+(test '(12 . 10) syntax-property se 'testing)
+(test '(mcr2) (tree-map syntax-e) (syntax-property se 'origin))
+
+(test #f syntax-original? s)
+(test #t syntax-original? se)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Two-step macro chain
+
+(define-syntax mcr5
+  (lambda (stx)
+    (syntax-case stx ()
+      [(_ x) (syntax x)])))
+
+(define s (quote-syntax (mcr5 (mcr2 5))))
+(define se (expand-once (expand-once s)))
+
+(test (syntax-e (cadr (syntax-e (cadr (syntax-e s))))) syntax-e se)
+
+(test '(mcr2 mcr5)
+      (tree-map syntax-e)
+      (syntax-property se 'origin))
+
+(test #t syntax-original? s)
+(test #t syntax-original? se)
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Two-step macro chain with expansion
+
+(define-syntax mcr7
+  (lambda (stx)
+    (syntax-case stx ()
+      [(_ x) (local-expand (syntax x) '(internal-define) (list (quote-syntax #%datum)))])))
+
+(define s (quote-syntax (mcr7 (mcr2 5))))
+(define se (expand-once s))
+
+(test (syntax-e (cadr (syntax-e (cadr (syntax-e s))))) syntax-e se)
+
+(test '((mcr2) mcr7)
+      (tree-map syntax-e)
+      (syntax-property se 'origin))
+
+(test #t syntax-original? s)
+(test #t syntax-original? se)
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Three-step macro chain, with one expansion
+
+(define s (quote-syntax (mcr5 (mcr7 (mcr2 5)))))
+(define se (expand-once (expand-once s)))
+
+(test '((mcr2) mcr7 mcr5)
+      (tree-map syntax-e)
+      (syntax-property se 'origin))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Three-step macro chain, with other expansion
+
+(define s (quote-syntax (mcr7 (mcr5 (mcr2 5)))))
+(define se (expand-once s))
+
+(test '((mcr2 mcr5) mcr7)
+      (tree-map syntax-e)
+      (syntax-property se 'origin))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; #%app, etc.
+
+(define s (syntax-property (quote-syntax (add1 5)) 'testing 10))
+(test 10 syntax-property (expand s) 'testing)
+
+(define s (syntax-property (quote-syntax 5) 'testing 10))
+(test 10 syntax-property (expand s) 'testing)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Check tracking of primitive expanders
+
+(test '(let) (tree-map syntax-e) (syntax-property (expand #'(let ([x 10]) x)) 'origin))
+(test '(let let*) (tree-map syntax-e) (syntax-property (expand #'(let* ([x 10]) x)) 'origin))
+(test '(let) (tree-map syntax-e) (syntax-property (expand #'(let loop ([x 10]) x)) 'origin))
+(test '(letrec) (tree-map syntax-e) (syntax-property (expand #'(letrec ([x 10]) x)) 'origin))
+(test '(let*-values) (tree-map syntax-e) (syntax-property (expand #'(let*-values ([(x) 10]) x)) 'origin))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Symbol Keys
+(test null syntax-property-symbol-keys #'a)
+(let ([ssort (lambda (l)
+	       (if (equal? l '(yep aha))
+		   '(aha yep)
+		   l))])
+  (test '(aha) syntax-property-symbol-keys (syntax-property #'a 'aha 1))
+  (test '(aha yep) ssort (syntax-property-symbol-keys (syntax-property (syntax-property #'a 'aha 1) 'yep 2)))
+  (test '(aha yep) ssort (syntax-property-symbol-keys (syntax-property 
+						       (syntax-property 
+							(syntax-property #'a 'aha 1) 
+							'yep 2)
+						       'aha 3))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Test module-identifier=? on different phases via syntax-case*
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(module mta mzscheme
+  (define mtax 10)
+  (provide mtax))
+
+(module mtb mzscheme
+  (define mtby 10)
+  (provide mtby))
+
+(module mt1 mzscheme
+  (require (prefix a: mta))
+  (require-for-syntax (prefix b: mtb))
+  (require (prefix mz: mzscheme))
+
+  (define-syntax ck
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ id et?)
+	 (with-syntax ([cmp (if (syntax-e (syntax et?))
+				(syntax module-transformer-identifier=?)
+				(syntax module-identifier=?))])
+	   (syntax
+	    (lambda (x)
+	      (syntax-case* x (id) cmp
+	        [(_ id) #t]
+		[else #f]))))])))
+
+  (define has-lam? (ck lambda #f))
+  (define has-mz:lam? (ck mz:lambda #f))
+  (define has-mtax? (ck a:mtax #f))
+  (define has-mtby? (ck b:mtby #f))
+
+  (define has-et-lam? (ck lambda #t))
+  (define has-et-mz:lam? (ck mz:lambda #t))
+  (define has-et-mtax? (ck a:mtax #t))
+  (define has-et-mtby? (ck b:mtby #t))
+
+  (provide has-lam? has-mz:lam? has-mtax? has-mtby?
+	   has-et-lam? has-et-mz:lam? has-et-mtax? has-et-mtby?))
+
+(require mt1)
+(require-for-syntax mtb)
+
+(test #t has-lam? #'(any lambda))
+(test #f has-lam? #'(any lambada))
+
+(test #t has-et-lam? #'(any lambda))
+(test #f has-et-lam? #'(any lambada))
+
+;; mz: prefix is there in normal environment:
+(test #t has-mz:lam? #'(any lambda))
+(test #f has-et-mz:lam? #'(any lambda))
+(test #f has-mz:lam? #'(any mz:lambda))
+(test #t has-et-mz:lam? #'(any mz:lambda))
+
+;; No mtax anywhere:
+(test #f has-mtax? #'(any mtax))
+(test #f has-mtax? #'(any a:mtax))
+(test #f has-et-mtax? #'(any mtax))
+(test #t has-et-mtax? #'(any a:mtax))
+
+;; mtby (without prefix) in trans env
+(test #f has-mtby? #'(any mtby))
+(test #t has-mtby? #'(any b:mtby))
+(test #t has-et-mtby? #'(any mtby))
+(test #f has-et-mtby? #'(any b:mtby))
+
+(module mt2 #%kernel
+  (require-for-syntax #%kernel)
+  (require mt1)
+  (require mta)
+
+  ;; For #':
+  (define-syntaxes (syntax)
+    (lambda (stx)
+      (datum->syntax-object
+       stx
+       (cons
+	(quote-syntax quote-syntax)
+	(cdr (syntax-e stx)))
+       stx)))
+
+  (define-values (run-mt2-test)
+    (lambda (test)
+      
+      (test #t has-lam? #'(any lambda))
+      (test #f has-lam? #'(any lambada))
+
+      (test #t has-et-lam? #'(any lambda))
+      (test #f has-et-lam? #'(any lambada))
+
+      ;; mz: prefix is there in normal environment:
+      (test #t has-mz:lam? #'(any lambda))
+      (test #f has-et-mz:lam? #'(any lambda))
+      (test #f has-mz:lam? #'(any mz:lambda))
+      (test #t has-et-mz:lam? #'(any mz:lambda))
+
+      ;; mtax in both places normal env:
+      (test #t has-mtax? #'(any mtax))
+      (test #f has-mtax? #'(any a:mtax))
+      (test #f has-et-mtax? #'(any mtax))
+      (test #t has-et-mtax? #'(any a:mtax))
+
+      ;; no mtby here
+      (test #f has-mtby? #'(any mtby))
+      (test #t has-mtby? #'(any b:mtby))
+      (test #f has-et-mtby? #'(any mtby))
+      (test #f has-et-mtby? #'(any b:mtby))))
+
+  (provide run-mt2-test))
+
+(require mt2)
+(run-mt2-test test)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(test '(1 2 3) syntax-object->datum (syntax (1 2 3)))
+(test '(1 ... 2 3) syntax-object->datum (syntax (... (1 ... 2 3))))
+
+(syntax-test #'(syntax (a (... ...))))
+(syntax-test #'(syntax (... ...)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; identifier-binding
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(test '(#%kernel lambda mzscheme lambda #f)  identifier-binding #'lambda)
+(test '(#%more-scheme delay mzscheme delay #f)  identifier-binding #'delay)
+(test '(#%kernel #%module-begin mzscheme #%plain-module-begin #f)  identifier-binding #'#%plain-module-begin)
+(require (rename mzscheme #%pmb #%plain-module-begin))
+(test '(#%kernel #%module-begin mzscheme #%plain-module-begin #f)  identifier-binding #'#%pmb)
+
+(let ([b (identifier-binding (syntax-case (expand #'(module m mzscheme
+						      (require (rename (lib "htdp-intermediate.ss" "lang") bcons cons))
+						      bcons)) ()
+			       [(mod m mz (#%mod-beg for-syntax req cons))
+				(let ([s (syntax cons)])
+				  (test 'bcons syntax-e s)
+				  s)]))])
+  (let-values ([(real real-base) (module-path-index-split (car b))]
+	       [(nominal nominal-base) (module-path-index-split (caddr b))])
+    (test '"teachprims.ss" values real)
+    (test 'beginner-cons cadr b)
+    (test '(lib "htdp-intermediate.ss" "lang") values nominal)
+    (test 'cons cadddr b)))
+
+(let ([b (identifier-binding (syntax-case (expand #'(module m (lib "htdp-intermediate.ss" "lang")
+						      cons)) ()
+			       [(mod m beg (#%mod-beg cons))
+				(let ([s (syntax cons)])
+				  (test 'cons syntax-e s)
+				  s)]))])
+  (let-values ([(real real-base) (module-path-index-split (car b))]
+	       [(nominal nominal-base) (module-path-index-split (caddr b))])
+    (test '"teachprims.ss" values real)
+    (test 'beginner-cons cadr b)
+    (test '(lib "htdp-intermediate.ss" "lang") values nominal)
+    (test 'cons cadddr b)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; eval versus eval-syntax, etc.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(unless building-flat-tests?
+
+  (test eval eval 'eval)
+  (test eval eval eval)
+  (test eval eval #'eval)
+  (test eval eval (datum->syntax-object #f 'eval))
+
+  (err/rt-test (eval-syntax 'eval))
+  (err/rt-test (eval-syntax eval))
+  (test eval eval-syntax #'eval)
+  (test #t 
+	'eval-syntax
+	(with-handlers ([exn:fail:syntax? (lambda (x) #t)])
+	  (eval-syntax (datum->syntax-object #f 'eval))))
+
+  (test eval (current-eval) 'eval)
+  (test eval (current-eval) eval)
+  (test eval (current-eval) #'eval)
+  (test #t 
+	'current-eval-syntax
+	(with-handlers ([exn:fail:syntax? (lambda (x) #t)])
+	  ((current-eval) (datum->syntax-object #f 'eval))))
+
+  (test eval 'compile (eval (compile 'eval)))
+  (test eval 'compile (eval (compile eval)))
+  (test eval 'compile (eval (compile #'eval)))
+  (test eval 'compile (eval (compile (datum->syntax-object #f 'eval))))
+
+  (err/rt-test (compile-syntax 'eval))
+  (err/rt-test (compile-syntax eval))
+  (test eval 'compile (eval (compile-syntax #'eval)))
+  (test #t 
+	'compile-syntax
+	(with-handlers ([exn:fail:syntax? (lambda (x) #t)])
+	  (compile-syntax (datum->syntax-object #f 'eval))))
+
+  (test eval 'expand (eval (expand 'eval)))
+  (test eval 'expand (eval (expand eval)))
+  (test eval 'expand (eval (expand #'eval)))
+  (test eval 'expand (eval (expand (datum->syntax-object #f 'eval))))
+
+  (err/rt-test (expand-syntax 'eval))
+  (err/rt-test (expand-syntax eval))
+  (test eval 'expand (eval (expand-syntax #'eval)))
+  (test #t 
+	'expand-syntax
+	(with-handlers ([exn:fail:syntax? (lambda (x) #t)])
+	  (expand-syntax (datum->syntax-object #f 'eval))))
+
+  (test eval 'expand-once (eval (expand-once 'eval)))
+  (test eval 'expand-once (eval (expand-once eval)))
+  (test eval 'expand-once (eval (expand-once #'eval)))
+  (test eval 'expand-once (eval (expand-once (datum->syntax-object #f 'eval))))
+
+  (err/rt-test (expand-syntax-once 'eval))
+  (err/rt-test (expand-syntax-once eval))
+  (test eval 'expand-once (eval (expand-syntax-once #'eval)))
+  (test #t 
+	'expand-syntax-once
+	(with-handlers ([exn:fail:syntax? (lambda (x) #t)])
+	  (expand-syntax-once (datum->syntax-object #f 'eval))))
+
+  (test eval 'expand-to-top-form (eval (expand-to-top-form 'eval)))
+  (test eval 'expand-to-top-form (eval (expand-to-top-form eval)))
+  (test eval 'expand-to-top-form (eval (expand-to-top-form #'eval)))
+  (test eval 'expand-to-top-form (eval (expand-to-top-form (datum->syntax-object #f 'eval))))
+
+  (err/rt-test (expand-syntax-to-top-form 'eval))
+  (err/rt-test (expand-syntax-to-top-form eval))
+  (test eval 'expand-to-top-form (eval (expand-syntax-to-top-form #'eval)))
+  (test #t syntax? (expand-syntax-to-top-form (datum->syntax-object #f 'eval))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; origin tracking
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Checks whether stx includes an mapping for
+;;  a `where' form (indicated by a symbol) going back to
+;;  a `what' form (another symbol)
+;; If `where' is #f, look for the annotation on a let...-values
+;;  binding clause
+(define (has-stx-property? stx where what prop)
+  (define (has-p? stx)
+    (let ([p (syntax-property stx prop)])
+      (and p
+	   (let loop ([p p])
+	     (cond
+	      [(pair? p) (or (loop (car p))
+			     (loop (cdr p)))]
+	      [else (and (identifier? p)
+			 (eq? what (syntax-e p)))])))))
+  
+  (let loop ([stx stx])
+    (or (and (has-p? stx)
+	     (or (eq? #t where)
+		 (eq? (syntax-e stx) where)
+		 (and (pair? (syntax-e stx))
+		      (eq? (syntax-e (car (syntax-e stx)))
+			   where))))
+	(syntax-case stx (lambda case-lambda begin begin0
+				 set! with-continuation-mark
+				 if #%app module #%plain-module-begin
+				 define-values)
+	  [(lambda formals expr ...)
+	   (ormap loop (syntax->list #'(expr ...)))]
+	  [(case-lambda [formals expr ...] ...)
+	   (ormap (lambda (l)
+		    (ormap loop (syntax->list l)))
+		  (syntax->list #'((expr ...) ...)))]
+	  [(let ([(id ...) rhs] ...) expr ...)
+	   (or (module-identifier=? #'let #'let-values)
+	       (module-identifier=? #'let #'letrec-values))
+	   (or (and (boolean? where)
+		    (syntax-case stx ()
+		      [(let [clause ...] expr)
+		       (ormap has-p? (syntax->list #'(clause ...)))]))
+	       (ormap loop (syntax->list #'(expr ...)))
+	       (ormap loop (syntax->list #'(rhs ...))))]
+	  [(begin expr ...)
+	   (ormap loop (syntax->list #'(expr ...)))]
+	  [(begin0 expr ...)
+	   (ormap loop (syntax->list #'(expr ...)))]
+	  [(set! id expr)
+	   (loop #'expr)]
+	  [(with-continuation-mark key val expr)
+	   (or (loop #'key) (loop #'val) (loop #'expr))]
+	  [(if test then else)
+	   (or (loop #'test) (loop #'then) (loop #'else))]
+	  [(#%app expr ...)
+	   (ormap loop (syntax->list #'(expr ...)))]
+	  [(module name init body)
+	   (loop #'body)]
+	  [(#%plain-module-begin expr ...)
+	   (ormap loop (syntax->list #'(expr ...)))]
+	  [(define-values (id ...) expr)
+	   (loop #'expr)]
+	  [_else #f]))))
+
+(test #t has-stx-property? (expand #'(let ([x 1]) 2)) 'let-values 'let 'origin)
+
+;; The define-struct macro expands to begin,
+(test #t has-stx-property? (expand #'(define-struct x (a))) 'begin 'define-struct 'origin)
+(test #t has-stx-property? (expand #'(module m mzscheme (define-struct x (a)))) 'define-values 'define-struct 'origin)
+(test #t has-stx-property? (expand #'(module m mzscheme (define-struct x (a)))) 'define-syntaxes 'define-struct 'origin)
+
+;; The s macro also expands to begin:
+(test #t has-stx-property? (expand #'(module m mzscheme 
+				 (define-syntax (s stx)
+				   #'(begin
+				       (+ 1 10)
+				       14))
+				 s))
+      '#%app 's 'origin)
+(test #t has-stx-property? (expand #'(module m mzscheme 
+				 (define-syntax (s stx)
+				   #'(begin
+				       (+ 1 10)
+				       14))
+				 (let ()
+				   s)))
+      '#%app 's 'origin)
+
+;; Check per-clause origin from internal-defn conversion
+(test #t has-stx-property? (expand #'(let () (define x 1) x)) #f 'define 'origin)
+(test #t has-stx-property? (expand #'(let () (define-struct x (a)) 12)) #f 'define-struct 'origin)
+
+;; Disappearing syntax decls:
+(test #t has-stx-property? (expand #'(let () (define-syntax x 1) (define y 12) 10)) 'letrec-values 'x 'disappeared-binding)
+(test #t has-stx-property? (expand #'(let () (define-struct s (x)) 10)) 'letrec-values 's 'disappeared-binding)
+(test #t has-stx-property? (expand #'(let () (define-syntax x 1) 10)) 'begin 'x 'disappeared-binding)
+(test #f has-stx-property? (expand #'(fluid-let-syntax ([x 1]) 10)) 'begin 'x 'disappeared-binding)
+
+;; Disappearing use:
+(test #t has-stx-property? (expand #'(let () (define-struct a (x)) (define-struct (b a) (z)) 10))
+      #f 'a 'disappeared-use)
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; protected identifiers
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(module ++p mzscheme 
+  (define ++c 12)
+  (define-syntax (++goo stx) #'++c)
+  (provide ++goo))
+(module ++q mzscheme 
+  (require-for-syntax ++p)
+  (define ++d 11) 
+  (define-syntax (++o stx) #'++d)
+  (define-syntax (++s stx)
+    (syntax-case stx ()
+      [(_ id) #'(define-syntax (id stx) 
+		  (datum->syntax-object #'here (++goo)))]))
+  (define-syntax (++t stx) (syntax-case stx () [(_ id) #'(define-values (id) ++d)]))
+  (define-syntax (++t2 stx) #'(begin ++d))
+  (define-syntax (++t3 stx) (syntax-property #'(begin0 ++d) 'certify-mode 'transparent))
+  (define-syntax (++t4 stx) (syntax-case stx () [(_ id) #'(define id ++d)]))
+  (define-syntax (++v stx) #'(begin0 ++d))
+  (define-syntax (++v2 stx) #'(++d))
+  (define-syntax (++v3 stx) (syntax-property #'(begin ++d) 'certify-mode 'opaque))
+  (define-syntax ++ds 17)
+  (define-syntax (++check-val stx)
+    (syntax-case stx ()
+      [(_ id) (datum->syntax-object #'here (add1 (syntax-local-value #'id)))]))
+  (define-syntax (++o2 stx) #'(++check-val ++ds))
+  (define-syntax (++apply-to-ds stx) 
+    (syntax-case stx ()
+      [(_ id) #'(id ++ds)]))
+  (define-syntax (++apply-to-d stx) 
+    (syntax-case stx ()
+      [(_ id) #'(id ++d)]))
+  (provide ++o ++o2 ++s ++t ++t2 ++t3 ++t4 ++v ++v2 ++v3
+	   ++apply-to-d ++apply-to-ds))
+
+(require ++q)
+(++s ++ack)
+(test 12 values ++ack)
+(test 11 values ++v)
+(test 11 values ++o)
+(test 18 values ++o2)
+(test 13 values (let () (++t id) 13))
+
+(let-syntax ([goo (lambda (stx)
+		    (syntax-case stx ()
+		      [(_ id) (datum->syntax-object #'here (sub1 (syntax-local-value #'id)))]))])
+  (test 16 'goo (++apply-to-ds goo)))
+
+(unless building-flat-tests?
+  (test 11 eval-syntax (expand-syntax #'++o))
+
+  (test 11 eval-syntax (syntax-case (expand-syntax #'++t2) ()
+			 [(_ x) #'x]))
+  (test 11 eval-syntax (syntax-case (expand #'(++t z)) ()
+			 [(d-v (_) x) #'x]))
+  (test 11 eval-syntax (syntax-case (expand-syntax #'++t3) ()
+			 [(_ x) #'x]))
+  (test 11 eval-syntax (syntax-case (expand #'(++t4 z)) ()
+			 [(d-v (_) x) #'x]))
+
+  (err/rt-test (teval (syntax-case (expand #'++v) ()
+			[(_ x) #'x]))
+	       exn:fail:syntax?)
+  (err/rt-test (teval (syntax-case (expand #'++v2) ()
+			[(_ x) #'x]))
+	       exn:fail:syntax?)
+  (err/rt-test (teval (syntax-case (expand #'++v3) ()
+			[(_ x) #'x]))
+	       exn:fail:syntax?))
+
+(let ([expr (expand-syntax #'++v)])
+  (test expr syntax-recertify expr expr (current-inspector) #f)
+    (let ([new (syntax-recertify #'no-marks expr (current-inspector) #f)])
+      (test #t syntax? new)
+      (test 'no-marks syntax-e new))
+    (test #t syntax? (syntax-recertify (syntax-case expr ()
+					 [(beg id) #'beg])
+				       expr (current-inspector) #f))
+    ;; we'd prefer this to fail, but it's defined to succeed:
+    (test #t syntax? (syntax-recertify (syntax-case expr ()
+					 [(beg id) #'id])
+				       expr (current-inspector) #f))
+    (test #t syntax? (syntax-recertify (datum->syntax-object expr (syntax-e expr))
+				       expr (current-inspector) #f))
+    ;; we'd prefer this to fail, but it's defined to succeed:
+    (test #t syntax? (syntax-recertify (syntax-case expr ()
+					 [(beg id) #'(ack id)])
+				       expr (current-inspector) #f)))
+
+(let ([expr (expand-syntax #'(++apply-to-d ack))])
+  (test '(#%app (#%top . ack) ++d) syntax-object->datum expr)
+  (let ([try (lambda (cvt? other)
+	       (syntax-recertify (datum->syntax-object 
+				  expr
+				  (cons (car (syntax-e expr))
+					((if cvt?
+					     (lambda (x) (datum->syntax-object
+							  (cdr (syntax-e expr))
+							  x))
+					     values)
+					 (cons
+					  other
+					  (cdr (syntax-e (cdr (syntax-e expr))))))))
+				 expr
+				 (current-inspector)
+				 #f))])
+    (test #t syntax? (try #f #'other!))
+    (let ([new (try #t #'other!)])
+      (test #t syntax? new)
+      (test '(#%app other! ++d) syntax-object->datum new))
+    ;; we'd prefer this to fail, but it's defined to succeed:
+    (test #t syntax? (try #t (syntax-case expr ()
+			       [(ap _ d) #'d])))))
+
+    
+;; ----------------------------------------
+
+(module ++m mzscheme 
+  (define ++x 10) 
+  (provide (protect ++x)))
+(module ++n mzscheme 
+  (require ++m) 
+  (define ++y ++x)
+  (define-syntax (++y-macro stx) #'++x)
+  (define-syntax (++y-macro2 stx) (datum->syntax-object stx '++x))
+  (define-syntax (++u-macro stx) #'++u)
+  (define-syntax ++u2 (make-rename-transformer #'++u))
+  (define ++u 8) ; unexported
+  (provide ++y ++y-macro ++y-macro2 ++u-macro ++u2))
+(require ++n)
+
+(test 10 values ++y)
+(test 10 values ++y-macro)
+(test 8 values ++u-macro)
+(test 8 values ++u2)
+
+(require ++m)
+
+(test 10 values ++x)
+(test 10 values ++y-macro2)
+
+(let ()
+  (define n (current-namespace))
+  (define n2 (make-namespace))
+  (define i (make-inspector))
+
+  (parameterize ([current-namespace n2])
+    (namespace-attach-module n '++n))
+
+  (parameterize ([current-code-inspector i]
+		 [current-namespace n2])
+    (teval '(require ++n))
+
+    (test 10 teval '++y)
+    (test 10 teval '++y-macro)
+    (test 8 teval '++u-macro)
+    (test 8 teval '++u2)
+
+    (err/rt-test (teval '++y-macro2) exn:fail:contract:variable?)
+    (err/rt-test (teval '++x) exn:fail:contract:variable?)
+
+    (teval '(require ++m))
+    (err/rt-test (teval '++x) exn:fail:syntax?)
+    (err/rt-test (teval '++y-macro2) exn:fail:syntax?)
+    
+    (teval '(module zrt mzscheme 
+	      (require ++n)
+	      (define (vy) ++y)
+	      (define (vy2) ++y-macro)
+	      (define (vu) ++u-macro)
+	      (define (vu2) ++u2)
+	      (provide vy vy2 vu vu2)))
+    (teval '(module zct mzscheme 
+	      (require-for-syntax ++n)
+	      (define-syntax (wy stx) (datum->syntax-object #'here ++y))
+	      (let-syntax ([goo ++y-macro]) 10)
+	      (define-syntax (wy2 stx) (datum->syntax-object #'here ++y-macro))
+	      (define-syntax (wu stx) (datum->syntax-object #'here ++u-macro))
+	      (provide wy wy2 wu)))
+
+    (teval '(require zct))
+
+    (test 10 teval 'wy)
+    (test 10 teval 'wy2)
+    (test 8 teval 'wu)
+
+    (teval '(require zrt))
+
+    (test 10 teval '(vy))
+    (test 10 teval '(vy2))
+    (test 8 teval '(vu))
+    (test 8 teval '(vu2)))
+  
+  (let ([old-insp (current-code-inspector)])
+    (parameterize ([current-code-inspector i]
+		   [current-namespace n2])
+      (namespace-unprotect-module old-insp '++m)))
+
+  (parameterize ([current-code-inspector i]
+		 [current-namespace n2])
+    (test 10 teval '++y-macro)
+    (test 10 teval '++y-macro2)))
+
+
+(module ++/n mzscheme
+  (provide ++/get-foo)
+  (define-syntax foo #'10)
+  (define-syntax (++/get-foo stx)
+    (syntax-local-value #'foo)))
+(require ++/n)
+(test 10 values ++/get-foo)
+
+(module ++//n mzscheme
+  (provide ++//def)
+  (define-syntax foo #'17)
+  (define-syntax ++//def
+    (syntax-rules ()
+      [(_ get-foo)
+       (define-syntax (get-foo stx)
+	 (syntax-local-value #'foo))])))
+(require ++//n)
+(++//def ++//get-foo)
+(test 17 values ++//get-foo)
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; lifting expressions
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-syntax (@@foo stx)
+  (syntax-case stx ()
+    [(_ n)
+     (if (zero? (syntax-e #'n))
+	 #'0
+	 (with-syntax ([m (sub1 (syntax-e #'n))])
+	   (syntax-local-lift-expression #'(add1 (@@foo m)))))]))
+
+(define lifted-output #f) 
+
+(define-syntax (@@goo stx)
+  (syntax-case stx ()
+    [(_)
+     (with-syntax ([id (syntax-local-lift-expression #'(set! lifted-output "lifted!"))])
+       #'(list lifted-output id))]))
+
+(test 2 '@@foo (@@foo 2))
+(test 2 eval (expand-once #'(@@foo 2)))
+(test 2 eval (expand #'(@@foo 2)))
+(test 2 eval (expand-to-top-form #'(@@foo 2)))
+(test (list "lifted!" (void)) '@@goo (@@goo))
+(set! lifted-output #f)
+(test (list "lifted!" (void)) eval (expand-once #'(@@goo)))
+(test (list "lifted!" (void)) eval (expand #'(@@goo)))
+(test (list "lifted!" (void)) eval (expand-to-top-form #'(@@goo)))
+
+(module @@n mzscheme
+  (define-syntax (@@foo stx)
+    (syntax-case stx ()
+      [(_ n)
+       (if (zero? (syntax-e #'n))
+	   #'0
+	   (with-syntax ([m (sub1 (syntax-e #'n))])
+	     (syntax-local-lift-expression #'(add1 (@@foo m)))))]))
+  (define-syntax (@@foox stx)
+    (syntax-case stx ()
+      [(_ n)
+       (syntax-local-lift-expression #'n)]))
+  (provide @@foo @@foox))
+
+(require-for-syntax @@n)
+
+(test (void) eval (expand #'(define-syntax (@@x stx) #`(list #,(@@foo 1) #,(@@foo 2) #,(@@foo 3)))))
+(test (list 1 2 3) '@@x @@x)
+(test (void) eval (expand #'(define-syntax (@@x stx) #`(list #,(@@foox 1) #,(@@foox 2) #,(@@foox 3)))))
+(test (list 1 2 3) '@@x @@x)
+(define-syntax (@@x stx) #`(list #,(@@foox 1) #,(@@foox 2) #,(@@foox 3)))
+(test (list 1 2 3) '@@x @@x)
+(define-syntax (@@x stx) #`(list #,(@@foo 1) #,(@@foo 2) #,(@@foo 3)))
+(test (list 1 2 3) '@@x @@x)
+(define-syntax (@@x stx) #`#,(@@foo 2))
+(test 2 '@@x @@x)
+
+(test 3
+      'ls-foo
+      (let-syntax ([z (lambda (stx) #`#,(@@foo 3))])
+	z))
+
+(test (void) eval (expand #'(begin-for-syntax (define @@zoo (@@foo 2)))))
+(define-syntax (@@x stx) #`#, @@zoo)
+(test 2 '@@x/@@zoo @@x)
+(begin-for-syntax (define @@zoo2 (@@foo 2)))
+(define-syntax (@@x stx) #`#, @@zoo2)
+(test 2 '@@x/@@zoo @@x)
+
+(begin-for-syntax (@@foo 1))
+(test (void) eval (expand #'(begin-for-syntax (@@foo 1))))
+
+(module @@p mzscheme
+  (require-for-syntax @@n)
+  (provide @@goo)
+  (define-syntax (@@goo stx) #`#,(@@foo 10)))
+
+(require @@p)
+(test 10 '@@goo (@@goo))
+
+(module @@m mzscheme
+  (define-syntax (@@foo stx)
+    (syntax-case stx ()
+      [(_ n)
+       (if (zero? (syntax-e #'n))
+	   #'0
+	   (with-syntax ([m (sub1 (syntax-e #'n))])
+	     (syntax-local-lift-expression #'(add1 (@@foo m)))))]))
+  (define @@local #f)
+  (define (set-local v)
+    (set! @@local v))
+  (set-local (@@foo 2))
+  (provide @@local))
+
+(require @@m)
+(test 2 '@@local @@local)
+
+(define-syntax (@@local-top stx)
+  (syntax-case stx ()
+    [(_ expr)
+     (local-expand/capture-lifts #'expr
+				 (list (gensym))
+				 (list #'begin #'#%top))]))
+
+(test 1 'let-foo (let ([x 5]) (@@foo 1)))
+(test 1 eval (expand #'(let ([x 5]) (@@foo 1))))
+(test 1 'local-foo (let ([x 5]) (@@local-top (@@foo 1))))
+(test 1 eval (expand #'(let ([x 5]) (@@local-top (@@foo 1)))))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Check interaction of macro-introduced/lifted names and
+;;  module->namespace
+
+(let ([go-once
+       (lambda (eval)
+	 (parameterize ([current-namespace (make-namespace)])
+	   (eval '(module mm mzscheme
+		    (define-syntax (define$ stx)
+		      (syntax-case stx ()
+			[(_ id val)
+			 (with-syntax ([x (datum->syntax-object #f 'x)])
+			   #'(begin
+			       (define x val)
+			       (define-syntax (id stx) #'x)))]))
+		    (define$ a 1)
+		    (define$ b 2)
+		    (printf "~a ~a~n" a b)))
+	   (eval '(require mm))
+	   (eval '(current-namespace (module->namespace 'mm)))
+
+	   (eval '(define$ c 7))
+	   (test '(1 2 7) eval '(list a b c))
+	   (eval '(define$ d 8))
+	   (test '(1 2 7 8) eval '(list a b c d)))
+
+	 (parameterize ([current-namespace (make-namespace)])
+	   (eval '(module mm mzscheme
+		    (define-syntax (define$ stx)
+		      (syntax-case stx ()
+			[(_ id val)
+			 (with-syntax ([x (syntax-local-lift-expression #'val)])
+			   #'(define-syntax (id stx) #'x))]))
+		    (define$ a 1)
+		    (define$ b 2)
+		    (printf "~a ~a~n" a b)))
+	   (eval '(require mm))
+	   (eval '(current-namespace (module->namespace 'mm)))
+
+	   (eval '(define$ c 7))
+	   (test '(1 2 7) eval '(list a b c))
+	   (eval '(define$ d 8))
+	   (test '(1 2 7 8) eval '(list a b c d))))])
+  (go-once eval)
+  (go-once (lambda (e) (eval (expand e)))))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(report-errs)
diff --git a/collects/tests/mzscheme/subproc2.ss b/collects/tests/mzscheme/subproc2.ss
new file mode 100644
index 0000000000..96dc185fbe
--- /dev/null
+++ b/collects/tests/mzscheme/subproc2.ss
@@ -0,0 +1,56 @@
+
+(define child? (member "child" (vector->list (current-command-line-arguments))))
+
+(define a-lot 500000)
+
+(unless child?
+  (load-relative "loadtest.ss")
+
+  (let ([path (find-executable-path (find-system-path 'exec-file) #f)])
+    (let-values ([(subproc in out /err) (subprocess #f #f (current-error-port)
+                                                    path "-rq"  
+                                                    (build-path (current-load-relative-directory)
+                                                                "subproc2.ss")
+                                                    "child")])
+      (test 'running subprocess-status subproc)
+      (test out object-wait-multiple 0 out)
+      (test #f object-wait-multiple 0 in)
+      (fprintf out "go~n")
+      
+      (test "going" read-line in)
+      
+      (test #t
+            positive?
+            ;; Push a-lot chars; should block at least once:
+            (let ([s (make-string a-lot #\a)])
+              (let loop ([offset 0])
+                (let ([ready? (object-wait-multiple 0 out)])
+                  (printf "~a ~a~n" offset ready?)
+                  (+ (if ready? 0 1)
+                     (let ([n (write-string-avail s out offset)])
+                       (if (= (+ n offset) a-lot)
+                           0
+                           (loop (+ offset n)))))))))
+
+      (test "done" read-line in)
+      
+      'ok)))
+
+(when child?
+  (with-handlers ([void (lambda (x)
+                          (fprintf (current-error-port) "CHILD ")
+                          (raise x))])
+    (if (equal? "go" (read-line (current-input-port) 'any))
+        (printf "going~n")
+        (printf "not go!~n"))
+  
+    (fprintf (current-error-port) "CHILD: starting sleep~n")
+    (sleep 1)
+    (fprintf (current-error-port) "CHILD: finished sleep; reading...~n")
+
+    (unless (= a-lot (string-length (read-string a-lot)))
+      (fprintf (current-error-port) "CHILD: bad read count"))
+
+    (printf "done~n")
+    
+    'ok))
diff --git a/collects/tests/mzscheme/subprocess.ss b/collects/tests/mzscheme/subprocess.ss
new file mode 100644
index 0000000000..20d65621ee
--- /dev/null
+++ b/collects/tests/mzscheme/subprocess.ss
@@ -0,0 +1,263 @@
+
+(load-relative "testing.ss")
+
+(require (lib "process.ss"))
+
+(SECTION 'SUBPROCESS)
+
+(define self (find-executable-path (find-system-path 'exec-file) #f))
+(define cat (find-executable-path "cat" #f))
+(define tmpfile (build-path (find-system-path 'temp-dir) "cattmp"))
+(define tmpfile2 (build-path (find-system-path 'temp-dir) "cattmp2"))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; process* tests
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Simple `process' tests using "cat"
+
+(let ([p (process* cat)])
+  (fprintf (cadr p) "Hello~n")
+  (close-output-port (cadr p))
+  (test "Hello" read-line (car p))
+  (test eof read-line (car p))
+  (test eof read-line (cadddr p))
+
+  ((list-ref p 4) 'wait)
+  (test 'done-ok (list-ref p 4) 'status)
+
+  (close-input-port (car p))
+  (close-input-port (cadddr p)))
+
+;; Generate output to stderr as well as stdout
+
+(let ([p (process* cat "-" "nosuchfile")])
+  (fprintf (cadr p) "Hello~n")
+  (close-output-port (cadr p))
+  (test "Hello" read-line (car p))
+  (test eof read-line (car p))
+  (test '("nosuchfile")
+	regexp-match "nosuchfile" (read-line (cadddr p)))
+  (test eof read-line (cadddr p))
+
+  ((list-ref p 4) 'wait)
+  (test 'done-error (list-ref p 4) 'status)
+
+  (close-input-port (car p))
+  (close-input-port (cadddr p)))
+
+;; Supply file for stdout
+
+(let ([f (open-output-file tmpfile 'truncate/replace)])
+  (let ([p (process*/ports f #f #f cat)])
+    (test #f car p)
+
+    (fprintf (cadr p) "Hello~n")
+    (close-output-port (cadr p))
+    (test eof read-line (cadddr p))
+
+    ((list-ref p 4) 'wait)
+    (test 'done-ok (list-ref p 4) 'status)
+
+    (close-output-port f)
+    (test 6 file-size tmpfile)
+    (test 'Hello with-input-from-file tmpfile read)
+
+    (close-input-port (cadddr p))))
+
+;; Supply file for stdout & stderr, only stdout writes
+
+(let ([f (open-output-file tmpfile 'truncate/replace)])
+  (let ([p (process*/ports f #f f cat)])
+    (test #f car p)
+    (test #f cadddr p)
+
+    (fprintf (cadr p) "Hello~n")
+    (close-output-port (cadr p))
+
+    ((list-ref p 4) 'wait)
+    (test 'done-ok (list-ref p 4) 'status)
+
+    (close-output-port f)
+    (test 6 file-size tmpfile)
+    (test 'Hello with-input-from-file tmpfile read)))
+
+;; Supply file for stderr
+
+(let ([f (open-output-file tmpfile 'truncate/replace)])
+  (let ([p (process*/ports #f #f f cat "nosuchfile")])
+    (test #f cadddr p)
+
+    (close-output-port (cadr p))
+
+    (test eof read-line (car p))
+    
+    ((list-ref p 4) 'wait)
+    (test 'done-error (list-ref p 4) 'status)
+
+    (close-output-port f)
+    (test '("nosuchfile")
+	  regexp-match "nosuchfile" (with-input-from-file tmpfile
+				      read-line))
+    
+    (close-input-port (car p))))
+
+;; Supply file for stdout & stderr, only stderr writes
+
+(let ([f (open-output-file tmpfile 'truncate/replace)])
+  (let ([p (process*/ports f #f f cat "nosuchfile")])
+    (test #f car p)
+    (test #f cadddr p)
+
+    (close-output-port (cadr p))
+
+    ((list-ref p 4) 'wait)
+    (test 'done-error (list-ref p 4) 'status)
+    
+    (close-output-port f)
+    (test '("nosuchfile")
+	  regexp-match "nosuchfile" (with-input-from-file tmpfile
+				      read-line))))
+
+;; Supply file for stdout & stderr, both write
+
+(let ([f (open-output-file tmpfile 'truncate/replace)])
+  (let ([p (process*/ports f #f f cat "-" "nosuchfile")])
+    (test #f car p)
+    (test #f cadddr p)
+
+    (fprintf (cadr p) "First line~n")
+    (close-output-port (cadr p))
+
+    ((list-ref p 4) 'wait)
+    (test 'done-error (list-ref p 4) 'status)
+    
+    (close-output-port f)
+    (with-input-from-file tmpfile
+      (lambda ()
+	(test "First line" read-line)
+	(test '("nosuchfile") regexp-match "nosuchfile" (read-line))
+	(test eof read-line)))))
+
+;; Supply separate files for stdout & stderr
+
+(let ([f (open-output-file tmpfile 'truncate/replace)]
+      [f2 (open-output-file tmpfile2 'truncate/replace)])
+  (let ([p (process*/ports f #f f2 cat "-" "nosuchfile")])
+    (test #f car p)
+    (test #f cadddr p)
+
+    (fprintf (cadr p) "The line~n")
+    (close-output-port (cadr p))
+
+    ((list-ref p 4) 'wait)
+    (test 'done-error (list-ref p 4) 'status)
+    
+    (close-output-port f)
+    (close-output-port f2)
+
+    (with-input-from-file tmpfile
+      (lambda ()
+	(test "The line" read-line)
+	(test eof read-line)))
+    
+    (with-input-from-file tmpfile2
+      (lambda ()
+	(test '("nosuchfile") regexp-match "nosuchfile" (read-line))
+	(test eof read-line)))))
+
+;; Supply file for stdin
+
+(let ([f (open-output-file tmpfile 'truncate/replace)])
+  (fprintf f "Howdy~n")
+  (close-output-port f))
+(let ([f (open-input-file tmpfile)])
+  (let ([p (process*/ports #f f #f cat)])
+    (test #f cadr p)
+
+    (test "Howdy" read-line (car p))
+    (test eof read-line (car p))
+    (test eof read-line (cadddr p))
+
+    (close-input-port f)
+
+    (close-input-port (car p))
+    (close-input-port (cadddr p))))
+
+;; Files for everyone
+
+(let ([f (open-input-file tmpfile)]
+      [f2 (open-output-file tmpfile2 'truncate/replace)])
+  (let ([p (process*/ports f2 f f2 cat "-" "nosuchfile")])
+    (test #f car p)
+    (test #f cadr p)
+    (test #f cadddr p)
+
+    ((list-ref p 4) 'wait)
+    (test 'done-error (list-ref p 4) 'status)
+    
+    (close-input-port f)
+    (close-output-port f2)
+
+    (with-input-from-file tmpfile2
+      (lambda ()
+	(test "Howdy" read-line)
+	(test '("nosuchfile") regexp-match "nosuchfile" (read-line))))))
+
+;; strings for everyone
+
+(let ([f (open-input-string (string-append
+			     "1"
+			     (make-string 50000 #\0)
+			     "\n"))]
+      [f2 (open-output-string)])
+  (let ([p (process*/ports f2 f f2 cat "-" "nosuchfile")])
+    (test #f car p)
+    (test #f cadr p)
+    (test #f cadddr p)
+
+    ((list-ref p 4) 'wait)
+    (test 'done-error (list-ref p 4) 'status)
+    
+    (let ([p (open-input-string (get-output-string f2))])
+      (test (expt 10 50000) read p)
+      (test "" read-line p)
+      (test '("nosuchfile") regexp-match "nosuchfile" (read-line p)))))
+
+;; Check error cases
+
+(let ([f (open-input-file tmpfile)]
+      [f2 (open-output-file tmpfile2 'truncate/replace)])
+
+  (let ([test
+	 (lambda (o i e)
+	   (err/rt-test (process*/ports o i e cat)))])
+    (test f #f #f)
+    (test #f f2 #f)
+    (test #f #f f)
+
+    (test f f f2)
+    (test f2 f2 f2)
+    (test f2 f f)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; nested tests
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-values (r w id e f)
+  (apply values (process* self "-mvq" 
+			  "-e" 
+			  "(let loop () (unless (eof-object? (eval (read))) (loop)))")))
+
+(define (test-line out in)
+  (fprintf w "~a~n" in)
+  (when out
+    (test out (lambda (ignored) (read-line r)) in)))
+			  
+(test-line "17" "(display 17) (newline)")
+
+(close-input-port r)
+(close-input-port e)
+(close-output-port w)
+
+(report-errs)
diff --git a/collects/tests/mzscheme/sync.ss b/collects/tests/mzscheme/sync.ss
new file mode 100644
index 0000000000..e7a05c6d51
--- /dev/null
+++ b/collects/tests/mzscheme/sync.ss
@@ -0,0 +1,1035 @@
+
+
+(load-relative "loadtest.ss")
+
+(SECTION 'synchronization)
+
+(define SYNC-SLEEP-DELAY 0.025)
+(define SYNC-BUSY-DELAY 0.1) ; go a little slower to check busy waits
+
+;; ----------------------------------------
+;;  Semaphore peeks
+
+(let* ([s (make-semaphore)]
+       [p (semaphore-peek-evt s)]
+       [ch (make-channel)])
+  (test #f sync/timeout 0 s p)
+  (test #f sync/timeout 0 s p)
+  (semaphore-post s)
+  (test p sync/timeout 0 p)
+  (test p sync p)
+  (test s sync s)
+  (test #f sync/timeout 0 p)
+  (thread (lambda () (sleep SYNC-SLEEP-DELAY) (semaphore-post s)))
+  (test p sync p)
+  (test p sync p)
+  (test s sync s)
+  (test #f sync/timeout 0 p)
+  (thread (lambda () (sync/timeout 0 p) (channel-put ch 7)))
+  (thread (lambda () (sync/timeout 0 p) (channel-put ch 7)))
+  (thread (lambda () (sync/timeout 0 p) (channel-put ch 7)))
+  (semaphore-post s)
+  (test 7 channel-get ch)
+  (test 7 channel-get ch)
+  (test 7 channel-get ch)
+  (test #f channel-try-get ch)
+  (thread (lambda () (channel-put ch 9)))
+  (sleep SYNC-SLEEP-DELAY)
+  (test 9 channel-try-get ch)
+  (test #f channel-try-get ch))
+
+(arity-test semaphore-peek-evt 1 1)
+(err/rt-test (semaphore-peek-evt #f))
+(err/rt-test (semaphore-peek-evt (semaphore-peek-evt (make-semaphore))))
+
+;; ----------------------------------------
+;; Channels
+
+(arity-test make-channel 0 0)
+
+(let ([c (make-channel)]
+      [v 'nope])
+  (test #f sync/timeout 0 c)
+  (thread (lambda () (sleep SYNC-SLEEP-DELAY) (set! v (channel-get c))))
+  (test (void) channel-put c 10)
+  (sleep)
+  (test 10 'thread-v v)
+  (thread (lambda () (sleep SYNC-SLEEP-DELAY) (channel-put c 11)))
+  (test #f sync/timeout 0 c)
+  (test 11 sync c)
+  (let ([p (channel-put-evt c 45)])
+    (thread (lambda () (sleep SYNC-SLEEP-DELAY) (set! v (sync c))))
+    (test #f sync/timeout 0 p)
+    (test p sync p)
+    (test #f sync/timeout 0 p)
+    (sleep)
+    (test 45 'thread-v v))
+  ;;;;; Make sure break/kill before action => break/kill only
+  ;; get:
+  (let ([try (lambda (break-thread)
+	       (let ([t (thread (lambda ()
+				  (set! v (channel-get c))))])
+		 (test #t thread-running? t)
+		 (sleep)
+		 (test #t thread-running? t)
+		 (test (void) break-thread t)
+		 (test #f sync/timeout 0 (channel-put-evt c 32))
+		 (sleep)
+		 (test #f thread-running? t)
+		 (test 45 'old-v v)))])
+    (try break-thread)
+    (try kill-thread))
+  ;; put:
+  (let ([try (lambda (break-thread)
+	       (let ([t (thread (lambda () (channel-put c 17)))])
+		 (test #t thread-running? t)
+		 (sleep)
+		 (test #t thread-running? t)
+		 (test (void) break-thread t)
+		 (test #f sync/timeout 0 c)
+		 (sleep)
+		 (test #f thread-running? t)))])
+    (try break-thread)
+    (try kill-thread))
+  ;; put in main thread:
+  (let ([t (current-thread)])
+    (thread (lambda () 
+	      (sleep SYNC-SLEEP-DELAY) 
+	      (break-thread t) 
+	      (set! v (channel-get c)))))
+  (test 77
+	'broken
+	(with-handlers ([exn:break? (lambda (x) 77)])
+	  (sync (channel-put-evt c 32))))
+  (test 45 'old-v v)
+  (channel-put c 89)
+  (sleep)
+  (test 89 'new-v v)
+  ;; get in main thread:
+  (let ([t (current-thread)])
+    (thread (lambda () 
+	      (sleep SYNC-SLEEP-DELAY) 
+	      (break-thread t) 
+	      (channel-put c 66))))
+  (test 99
+	'broken
+	(with-handlers ([exn:break? (lambda (x) 99)])
+	  (sync c)))
+  (test 66 sync/timeout 0 c)
+
+  ;;; Can't sync with self!
+  (test #f sync/timeout 0 c (channel-put-evt c 100))
+  ;; Test cross sync:
+  (let ([c2 (make-channel)]
+	[ok-result? (lambda (r)
+		      (or (eq? r 100) (evt? r)))])
+    (thread (lambda () (channel-put c2 (sync c (channel-put-evt c 100)))))
+    (thread (lambda () (channel-put c2 (sync c (channel-put-evt c 100)))))
+    (test #t ok-result? (channel-get c2))
+    (test #t ok-result? (channel-get c2))))
+
+;; ----------------------------------------
+;; Alarms
+
+(test #f sync/timeout 0.1 (alarm-evt (+ (current-inexact-milliseconds) 200)))
+(test 'ok sync/timeout 0.1 
+      (wrap-evt
+       (alarm-evt (+ (current-inexact-milliseconds) 50))
+       (lambda (x) 'ok)))
+(test 'ok sync/timeout 100
+      (wrap-evt
+       (alarm-evt (+ (current-inexact-milliseconds) 50))
+       (lambda (x) 'ok)))
+
+;; ----------------------------------------
+;; Waitable sets
+
+(err/rt-test (choice-evt 7))
+(err/rt-test (choice-evt (make-semaphore) 7))
+
+(arity-test choice-evt 0 -1)
+
+(test #f sync/timeout SYNC-SLEEP-DELAY (choice-evt))
+(test #f sync/timeout SYNC-SLEEP-DELAY (choice-evt) (choice-evt))
+(test #f sync/timeout SYNC-SLEEP-DELAY (choice-evt (choice-evt) (choice-evt)))
+
+(let ([s1 (make-semaphore)]
+      [s2 (make-semaphore)]
+      [s3 (make-semaphore)])
+  (test #f sync/timeout SYNC-SLEEP-DELAY (choice-evt s1 s2 s3))
+  (semaphore-post s2)
+  (test s2 sync/timeout SYNC-SLEEP-DELAY (choice-evt s1 s2 s3))
+  (test #f sync/timeout SYNC-SLEEP-DELAY (choice-evt s1 s2 s3))
+  (let ([set (choice-evt s1 s2 s3)])
+    (test #f sync/timeout SYNC-SLEEP-DELAY set)
+    (semaphore-post s2)
+    (test s2 sync/timeout SYNC-SLEEP-DELAY set)
+    (test #f sync/timeout SYNC-SLEEP-DELAY set))
+  (thread (lambda () (sleep) (semaphore-post s3)))
+  (test s3 sync/timeout SYNC-SLEEP-DELAY (choice-evt s1 s2 s3))
+  (test #f sync/timeout SYNC-SLEEP-DELAY (choice-evt s1 s2 s3))
+  (semaphore-post s3)
+  (test s3 sync/timeout SYNC-SLEEP-DELAY s1 (choice-evt s2 s3))
+  (test #f sync/timeout SYNC-SLEEP-DELAY s1 (choice-evt s2 s3))
+  (semaphore-post s3)
+  (test s3 sync/timeout SYNC-SLEEP-DELAY (choice-evt s1 s2) s3)
+  (test #f sync/timeout SYNC-SLEEP-DELAY (choice-evt s1 s2) s3)
+  (let ([set (choice-evt s1 s2)])
+    (test #f sync/timeout SYNC-SLEEP-DELAY s1 set s3)
+    (semaphore-post s2)
+    (test s2 sync/timeout SYNC-SLEEP-DELAY set s3)
+    (test #f sync/timeout SYNC-SLEEP-DELAY set s3))
+  (test #f sync/timeout SYNC-SLEEP-DELAY (choice-evt s1 (choice-evt s2 s3)))
+  (semaphore-post s3)
+  (test s3 sync/timeout SYNC-SLEEP-DELAY (choice-evt s1 (choice-evt s2 s3)))
+  (test #f sync/timeout SYNC-SLEEP-DELAY (choice-evt s1 (choice-evt s2 s3)))
+  (semaphore-post s3)
+  (test s3 sync/timeout SYNC-SLEEP-DELAY (choice-evt (choice-evt s1 s2) s3))
+  (test #f sync/timeout SYNC-SLEEP-DELAY (choice-evt (choice-evt s1 s2) s3))
+  (let ([set (choice-evt s1 (choice-evt s2 s3))])
+    (test #f sync/timeout SYNC-SLEEP-DELAY set)
+    (semaphore-post s3)
+    (test s3 sync/timeout SYNC-SLEEP-DELAY set)
+    (test #f sync/timeout SYNC-SLEEP-DELAY set))
+  
+  (let* ([c (make-channel)]
+	 [set (choice-evt s1 s2 c)])
+    (test #f sync/timeout SYNC-SLEEP-DELAY set)
+    (thread (lambda () (channel-put c 12)))
+    (test 12 sync/timeout SYNC-SLEEP-DELAY set)
+    (test #f sync/timeout SYNC-SLEEP-DELAY set)
+    (let* ([p (channel-put-evt c 85)]
+	   [set (choice-evt s1 s2 p)])
+      (test #f sync/timeout SYNC-SLEEP-DELAY set)
+      (thread (lambda () (channel-get c)))
+      (test p sync/timeout SYNC-SLEEP-DELAY set)
+      (test #f sync/timeout SYNC-SLEEP-DELAY set))))
+
+(test 77 sync/timeout 
+      #f 
+      (wrap-evt (make-semaphore) void) 
+      (guard-evt 
+       (lambda () 
+	 (choice-evt 
+	  (make-semaphore) (make-semaphore) (make-semaphore) (make-semaphore) 
+	  (make-semaphore) (make-semaphore) (make-semaphore) (make-semaphore) 
+	  (let ([sema (make-semaphore 1)])
+	    (wrap-evt sema (lambda (x)
+					  (test sema values x)
+					  77)))))))
+
+;; More alarms:
+(let ([make-delay
+       (lambda (amt)
+	 (guard-evt
+	  (lambda ()
+	    (wrap-evt
+	     (alarm-evt (+ (current-inexact-milliseconds) (* 1000 amt)))
+	     (lambda (v) amt)))))])
+  (test #f sync/timeout 0.1 (make-delay 0.15) (make-delay 0.2))
+  (test 0.15 sync/timeout 18 (make-delay 0.15) (make-delay 0.2))
+  (test 0.15 sync/timeout 18 (make-delay 0.2) (make-delay 0.15))
+  (test 0.15 sync/timeout 0.18 (make-delay 0.15) (make-delay 0.2))
+  (test 0.15 sync/timeout 18 
+	(choice-evt (make-delay 0.2) (make-delay 0.15))))
+
+;; ----------------------------------------
+;; Wrapped waitables
+
+(arity-test wrap-evt 2 2)
+
+(err/rt-test (wrap-evt 1 void))
+(err/rt-test (wrap-evt (make-semaphore) 10))
+(err/rt-test (wrap-evt (make-semaphore) (lambda () 10)))
+
+(test 17 sync (wrap-evt (make-semaphore 1) (lambda (sema) 17)))
+(test 17 sync (choice-evt
+				  (make-semaphore)
+				  (wrap-evt (make-semaphore 1) (lambda (sema) 17))))
+(test #t sync (wrap-evt (make-semaphore 1) semaphore?))
+(test 18 'sync
+      (let ([n 17]
+	    [s (make-semaphore)])
+	(thread (lambda () (sleep SYNC-SLEEP-DELAY) (semaphore-post s)))
+	(sync 
+			      (wrap-evt 
+			       s 
+			       (lambda (sema) (set! n (add1 n)) n))
+			      (wrap-evt 
+			       s 
+			       (lambda (sema) (set! n (add1 n)) n)))))
+
+(let ([c (make-channel)])
+  (thread (lambda () (channel-put c 76)))
+  (test 77 sync (wrap-evt c add1)))
+
+(test 78 sync 
+      (wrap-evt (choice-evt (make-semaphore 1) (make-semaphore 1))
+			     (lambda (x) 78)))
+
+;; ----------------------------------------
+;; Nack waitables
+
+(arity-test nack-guard-evt 1 1)
+(arity-test guard-evt 1 1)
+
+(err/rt-test (nack-guard-evt 10))
+(err/rt-test (nack-guard-evt (lambda () 10)))
+(err/rt-test (guard-evt 10))
+(err/rt-test (guard-evt (lambda (x) 10)))
+
+(let ([s (make-semaphore 1)]
+      [nack-try-wait? (lambda (n)
+			(let ([v (sync/timeout 0 n)])
+			  (when v
+			    (test #t void? v)
+			    (test (void) sync n))
+			  (and v #t)))])
+  (test s sync (nack-guard-evt (lambda (nack) s)))
+  (test #f semaphore-try-wait? s)
+  (semaphore-post s)
+  (let ([v #f])
+    (test #f sync/timeout 0
+	  (nack-guard-evt (lambda (nack) 
+				      (set! v nack)
+				      (make-semaphore))))
+    (test #t nack-try-wait? v)
+    (set! v #f)
+    (test #f sync/timeout SYNC-SLEEP-DELAY
+	  (nack-guard-evt (lambda (nack) 
+				      (set! v nack)
+				      (make-semaphore))))
+    (test #t nack-try-wait? v)
+    (set! v #f)
+    (test #f sync/timeout 0
+	  (nack-guard-evt (lambda (nack) 
+				      (set! v nack)
+				      (make-semaphore)))
+	  (nack-guard-evt (lambda (nack) 
+				      (set! v nack)
+				      (make-semaphore))))
+    (test #t nack-try-wait? v)
+    (set! v #f)
+    (test #f sync/timeout SYNC-SLEEP-DELAY
+	  (nack-guard-evt (lambda (nack) 
+				      (set! v nack)
+				      (make-semaphore)))
+	  (nack-guard-evt (lambda (nack) 
+				      (set! v nack)
+				      (make-semaphore))))
+    (test #t nack-try-wait? v)
+    (set! v #f)
+    (test #f sync/timeout SYNC-SLEEP-DELAY
+	  (choice-evt 
+	   (nack-guard-evt (lambda (nack) 
+				       (set! v nack)
+				       (make-semaphore)))
+	   (nack-guard-evt (lambda (nack) 
+				       (set! v nack)
+				       (make-semaphore)))))
+    (test #t nack-try-wait? v)
+    (set! v #f)
+    (test s sync/timeout 0
+	  (nack-guard-evt (lambda (nack) 
+				      (set! v nack)
+				      s)))
+    (test #f nack-try-wait? v) ; ... but not an exception!
+    (semaphore-post s)
+    (set! v #f)
+    (let loop ()
+      (test s sync/timeout 0
+	    (nack-guard-evt (lambda (nack) 
+					(set! v nack)
+					(make-semaphore)))
+	    s)
+      (if v
+	  (test #t nack-try-wait? v)
+	  (begin  ; tried the 2nd first, so do test again
+	    (semaphore-post s)
+	    (loop))))
+    (set! v #f)
+    (let loop ()
+      (err/rt-test (sync/timeout 0
+					 (nack-guard-evt (lambda (nack) 
+								     (set! v nack)
+								     (make-semaphore)))
+					 (nack-guard-evt (lambda (nack)
+								     (/ 1 0))))
+		   exn:fail:contract:divide-by-zero?)
+      (if v
+	  (test #t nack-try-wait? v)
+	  (loop)))
+    (set! v #f)
+    (let loop ()
+      (err/rt-test (sync/timeout 0
+					 (nack-guard-evt (lambda (nack)
+								     (/ 10 0)))
+					 (nack-guard-evt (lambda (nack) 
+								     (set! v nack)
+								     (make-semaphore))))
+		   exn:fail:contract:divide-by-zero?)
+      (if v
+	  (begin
+	    (set! v #f)
+	    (loop))
+	  (test #t not v)))
+    (set! v null)
+    (test #f sync/timeout 0
+	  (nack-guard-evt (lambda (nack) 
+				(set! v (cons nack v))
+				(make-semaphore)))
+	  (nack-guard-evt (lambda (nack) 
+				(set! v (cons nack v))
+				(make-semaphore))))
+    (test '(#t #t) map nack-try-wait? v)
+
+    ;; Check that thread kill also implies nack:
+    (set! v #f)
+    (let* ([ready (make-semaphore)]
+	   [t (thread (lambda ()
+			(sync/timeout 
+			 #f
+			 (nack-guard-evt
+			  (lambda (nack)
+			    (set! v nack)
+			    (semaphore-post ready)
+			    (make-semaphore))))))])
+      (semaphore-wait ready)
+      (kill-thread t)
+      (test #t nack-try-wait? v))))
+		       
+
+(let ([s (make-semaphore 1)])
+  (test s sync/timeout 0 (guard-evt (lambda () s))))
+
+(let ([v #f])
+  (test #f sync/timeout 0
+	(nack-guard-evt
+	 (lambda (nack)
+	   (set! v nack)
+	   (choice-evt (make-semaphore) (make-semaphore)))))
+  (test (void) sync/timeout 0 v))
+
+(let ([ch (make-channel)]
+      [n #f])
+  (let ([t (thread
+	    (lambda ()
+	      (sync
+	       (nack-guard-evt
+		(lambda (nack)
+		  (set! n nack)
+		  never-evt))
+	       (channel-put-evt ch 10))))])
+    (sleep)
+    (test 10 channel-get ch)
+    (test (void) sync/timeout 0 n)))
+	       
+
+;; ----------------------------------------
+;; Poll waitables
+
+(arity-test poll-guard-evt 1 1)
+
+(err/rt-test (poll-guard-evt 10))
+(err/rt-test (poll-guard-evt (lambda () 10)))
+
+(let ([s (semaphore-peek-evt (make-semaphore 1))])
+  (test s sync/timeout 0 (poll-guard-evt (lambda (poll?)
+							     (test #t values poll?)
+							     s)))
+  (test s sync (poll-guard-evt (lambda (poll?)
+							      (test #f values poll?)
+							      s)))
+  (test s sync/timeout 0 (choice-evt
+				  (poll-guard-evt (lambda (poll?)
+							      (test #t values poll?)
+							      s))
+				  (make-semaphore)))
+  (test s sync (choice-evt
+				   (poll-guard-evt (lambda (poll?)
+							       (test #f values poll?)
+							       s))
+				   (make-semaphore))))
+
+;; ----------------------------------------
+;; Structures as waitables
+
+;; Bad property value:
+(err/rt-test (make-struct-type 'wt #f 2 0 #f (list (cons prop:evt -1))) exn:application:mismatch?)
+;; slot index 1 not immutable:
+(err/rt-test (make-struct-type 'wt #f 2 0 #f (list (cons prop:evt 1))) exn:application:mismatch?)
+
+(define-values (struct:wt make-wt wt? wt-ref wt-set!)
+  (make-struct-type 'wt #f 2 0 #f (list (cons prop:evt 1)) (make-inspector) #f '(1)))
+
+(let ([always-ready (make-wt #f (lambda (self) #t))]
+      [always-stuck (make-wt 1 2)])
+  (test always-ready sync always-ready)
+  (test always-ready sync/timeout 0 always-ready)
+  (test #f sync/timeout 0 always-stuck)
+  (test #f sync/timeout SYNC-SLEEP-DELAY always-stuck))
+
+;; Check whether something that takes at least SYNC-SLEEP-DELAY
+;;  seconds in fact takes roughly that much CPU time. We
+;;  expect non-busy-wait takes to take a very small fraction
+;;  of the time.
+;; This test only works well if there are no other
+;;  threads running and the underlying OS is not loaded.
+(define (check-busy-wait go busy?)
+  (collect-garbage) ; reduces false-positives in detecting busy wait
+  (let ([msecs (current-process-milliseconds)]
+	[gc-msecs (current-gc-milliseconds)]
+	[real-msecs (current-milliseconds)])
+    (go)
+    (let ([took (/ (abs (- (current-process-milliseconds) msecs
+			   (abs (- (current-gc-milliseconds) gc-msecs))))
+		   1000.0)]
+	  [real-took (/ (abs (- (current-milliseconds) real-msecs)) 1000.0)]
+	  [boundary (/ SYNC-BUSY-DELAY 6)])
+      ;; Hack.
+      ;; The following test isn't reliable, so only Matthew should see it.
+      (when (regexp-match #rx"(mflatt)|(matthewf)" (path->string (find-system-path 'home-dir)))
+	(test busy? (lambda (a ax b c d) (> b c)) 'busy-wait? go took boundary real-took)))))
+
+(define (test-good-waitable wrap-sema)
+  (let ([sema (make-semaphore)])
+    (letrec-values ([(sema-ready-part get-sema-result) (wrap-sema sema sema (lambda () sema-ready))]
+		    [(sema-ready) (make-wt 1 sema-ready-part)])
+      (test #f 'initial-sema (sync/timeout 0 sema-ready))
+      (semaphore-post sema)
+      (test (get-sema-result) sync/timeout 0 sema-ready)
+      (test #f semaphore-try-wait? sema)
+      (test #f sync/timeout 0 sema-ready)
+      (semaphore-post sema)
+      (let ()
+	(define (non-busy-wait waitable get-result)
+	  (check-busy-wait
+	   (lambda ()
+	     (thread (lambda ()
+		       (sleep SYNC-BUSY-DELAY)
+		       (semaphore-post sema)))
+	     (test (get-result) sync waitable))
+	   #f)
+	  (test #f sync/timeout 0 waitable)
+	  (semaphore-post sema)
+	  (test (get-result) sync waitable)
+	  (test #f sync/timeout 0 waitable)
+	  (semaphore-post sema)
+	  (test (get-result) sync waitable)
+	  (test #f semaphore-try-wait? sema)
+	  (test #f sync/timeout 0 waitable))
+	(non-busy-wait sema-ready get-sema-result)
+	(semaphore-post sema)
+	(letrec-values ([(wrapped-part get-wrapped-result)
+			 (wrap-sema (make-wt 2 (lambda (self) sema-ready))
+				    (get-sema-result)
+				    (lambda () sema-ready))]
+			[(wrapped) (make-wt 3 wrapped-part)])
+	  (non-busy-wait (get-wrapped-result) get-wrapped-result))))))
+
+(test-good-waitable (lambda (x x-result get-self)
+		      (values x (lambda () x-result))))
+(test-good-waitable (lambda (x x-result get-self)
+		      (let ([ws (choice-evt
+				 x
+				 (make-wt 99 (lambda (self) (make-semaphore))))])
+			(values ws (lambda () x-result)))))
+
+(check-busy-wait
+ (letrec ([s (make-semaphore)]
+	  [wt (make-wt 1 (lambda (self) (unless (or (eq? wt s)
+						    (eq? self wt) )
+					  (error 'wt "yikes: ~s != ~s" self wt)) 
+				 wt))])
+   (thread (lambda () (sleep (/ SYNC-BUSY-DELAY 2)) (set! wt s)))
+   (lambda ()
+     (test #f sync/timeout SYNC-BUSY-DELAY wt)))
+ #t)
+
+;; ----------------------------------------
+
+(define (test-stuck-port ready-waitable make-waitable-unready make-waitable-ready)
+  (let* ([go? #f]
+	 [bad-stuck-port (make-input-port
+			  'name
+			  (lambda (str)
+			    (if go?
+				(begin
+				  (bytes-set! str 0 (char->integer #\x))
+				  1)
+				(if (zero? (random 2))
+				    0
+				    ready-waitable)))
+			  #f
+			  void)])
+    (make-waitable-unready ready-waitable)
+    (test #f char-ready? bad-stuck-port)
+    (test #f sync/timeout SYNC-SLEEP-DELAY bad-stuck-port)
+    (test 0 read-bytes-avail!* (make-bytes 10) bad-stuck-port)
+    (set! go? #t)
+    (test #t char-ready? bad-stuck-port)
+    (test bad-stuck-port sync/timeout SYNC-SLEEP-DELAY bad-stuck-port)
+    (test #t positive? (read-bytes-avail!* (make-bytes 10) bad-stuck-port))
+    (set! go? #f)
+    (test #f char-ready? bad-stuck-port)
+    (test #f sync/timeout SYNC-SLEEP-DELAY bad-stuck-port)
+    (test 0 read-bytes-avail!* (make-bytes 10) bad-stuck-port)
+    (set! ready-waitable 0)
+    (test #f sync/timeout 0 bad-stuck-port)
+    (test #f sync/timeout 0 bad-stuck-port)
+    (check-busy-wait
+     (lambda ()
+       (test #f sync/timeout SYNC-BUSY-DELAY bad-stuck-port))
+     #t)
+    (check-busy-wait
+     (lambda ()
+       (thread (lambda ()
+		 (sleep SYNC-BUSY-DELAY)
+		 (set! go? #t)))
+       (test bad-stuck-port sync/timeout (* 3 SYNC-BUSY-DELAY) bad-stuck-port))
+     #t)))
+
+(test-stuck-port (make-semaphore 1) semaphore-try-wait? semaphore-post)
+(let ([ready? #t])
+  (test-stuck-port (make-wt 77 (lambda (self)
+				 (if ready?
+				     #t
+				     (make-semaphore))))
+		   (lambda (wt) (set! ready? #f))
+		   (lambda (wt) (set! ready? #t))))
+(let ([s (make-semaphore 1)])
+  (test-stuck-port (make-wt 77 s)
+		   (lambda (wt) (semaphore-try-wait? s))
+		   (lambda (wt) (semaphore-post s))))
+(let ([s (make-semaphore 1)])
+  (test-stuck-port (make-wt 177 (lambda (self) s))
+		   (lambda (wt) (semaphore-try-wait? s))
+		   (lambda (wt) (semaphore-post s))))
+
+;; ----------------------------------------
+
+;; In the current implemenation, a depth of 10 for 
+;;  waitable chains is a magic number; it causes the scheduler to
+;;  swap a thread in to check whether it can run, instead of
+;;  checking in the thread. (For a well-behaved chain, this 
+;;  swap in will lead to a more friendly semaphore wait, for
+;;  example.)
+
+(letrec ([stack-em (lambda (n s)
+		     ;; This needs to be tail-recursive to
+		     ;; the find-depth check below (to check
+		     ;; blocking depth, not precdure depth)
+		     (if (zero? n)
+			 s
+			 (stack-em (sub1 n) (make-wt n s))))])
+  (let* ([s1 (make-semaphore 1)]
+	 [s20 (make-semaphore 1)]
+	 [wt1 (stack-em 1 s1)]
+	 [wt20 (stack-em 20 s20)])
+    (test s1 sync/timeout 0 wt1)
+    (test s20 sync/timeout 0 wt20)
+    (test #f semaphore-try-wait? s1)
+    (test #f semaphore-try-wait? s20)
+    (let ([t20
+	   (thread (lambda ()
+		     (test s20 sync/timeout 1.0 wt20)))])
+      (let loop ([n 20])
+	(unless (zero? n)
+	  (sleep)
+	  (loop (sub1 n))))
+      (semaphore-post s20)
+      (test (void) thread-wait t20))))
+
+
+;; ----------------------------------------
+;;  Thread suspend, resume, and dead waitables
+
+(let ([d (thread-dead-evt (thread void))])
+  (test d sync d))
+
+(let* ([sema (make-semaphore)]
+       [t (thread (lambda () (semaphore-wait sema)))]
+       [r (thread-resume-evt t)]
+       [s (thread-suspend-evt t)])
+  (test #f sync/timeout 0 t s)
+  (test t sync/timeout 0 t s r)
+  (test t sync/timeout 0 r)
+  (thread-suspend t)
+  (test t sync/timeout 0 r)
+  (test t sync/timeout 0 s)
+  (let* ([r (thread-resume-evt t)]
+	 [s (thread-suspend-evt t)])
+    (test #f sync/timeout 0 t r)
+    (test t sync/timeout 0 t s r)
+    (test t sync/timeout 0 s)
+    (thread-resume t)
+    (test t sync/timeout 0 s)
+    (test t sync/timeout 0 r)
+    (let* ([s (thread-suspend-evt t)])
+      (thread (lambda () (sleep SYNC-SLEEP-DELAY) (thread-suspend t)))
+      (test #f sync/timeout 0 s)
+      (test t sync s)
+      (let* ([r (thread-resume-evt t)]
+	     [d (thread-dead-evt t)])
+	(thread (lambda () (sleep SYNC-SLEEP-DELAY) (thread-resume t)))
+	(test #f sync/timeout 0 r)
+	(test t sync r)
+
+	(test #f sync/timeout 0 d)
+	(semaphore-post sema)
+	(test d sync d)
+	(test t sync r)
+	(test t sync s)
+	(test #f sync/timeout 0 (thread-resume-evt t))
+	(test #f sync/timeout 0 (thread-suspend-evt t))
+	(test d thread-dead-evt t)))))
+
+;; ----------------------------------------
+;;  Garbage collection
+
+(define (num-scheduled)
+  (let ([v (make-vector 7)])
+    (vector-set-performance-stats! v)
+    (vector-ref v 6)))
+
+(define (check-threads-gcable label blocking-thunk)
+  ;; Actually, we approximate the gcable check as a num-scheduled check,
+  ;;  even though there's still a lot of machinery here to try to check
+  ;;  GCing. The explicit gc has been commented out.
+  (define orig-scheduled (num-scheduled))
+  (let ([l (let loop ([n 20][die? #f])
+	     (if (zero? n)
+		 null
+		 (cons (make-weak-box (thread (if die? void blocking-thunk)))
+		       (loop (if die? n (sub1 n)) (not die?)))))]
+	[sl (lambda ()
+	      (let loop ([n 20])
+		(unless (zero? n) (sleep) (loop (sub1 n)))))]
+	[ok-done? (lambda (r) (<= (list-ref r 3) orig-scheduled))])
+    (test #t
+	  ok-done?
+	  (let loop ([tries 0][n 100])
+	    (if (or (= tries 3) (< n 10))
+		(list tries n label (num-scheduled))
+		(begin
+		  (sl) 
+		  ;; (collect-garbage)
+		  (loop (add1 tries)
+			(apply + (map (lambda (b) (if (weak-box-value b) 1 0)) l)))))))))
+
+(check-threads-gcable 'sema (lambda () (semaphore-wait (make-semaphore))))
+(define (check/combine c)
+  (check-threads-gcable 'semaw (lambda () (sync (c (make-semaphore)))))
+  (check-threads-gcable 'semap (lambda () (sync (c (semaphore-peek-evt (make-semaphore))))))
+  (check-threads-gcable 'ch (lambda () (sync (c (make-channel)))))
+  (check-threads-gcable 'chput (lambda () (sync (c (channel-put-evt (make-channel) 10)))))
+  (check-threads-gcable 'wrapped (lambda () (sync (c (wrap-evt (make-semaphore) void)))))
+  (check-threads-gcable 'guard (lambda () (sync (c (guard-evt (lambda () (make-semaphore)))))))
+  (check-threads-gcable 'nack (lambda () (sync (c (nack-guard-evt (lambda (nack) (make-semaphore)))))))
+  (check-threads-gcable 'poll (lambda () (sync (c (poll-guard-evt (lambda (poll?) (make-semaphore)))))))
+  (check-threads-gcable 'never (lambda () (sync (c never-evt)))))
+(check/combine values)
+(check/combine (lambda (x) (choice-evt x (make-semaphore))))
+(check/combine (lambda (x) (choice-evt (make-semaphore) x)))
+(check/combine (lambda (x) (choice-evt (make-semaphore) x)))
+
+(check-threads-gcable 'nested (lambda () (call-in-nested-thread (lambda () (semaphore-wait (make-semaphore))))))
+(pseudo-random-generator? 10)
+(check-threads-gcable 'suspended (lambda () (thread-suspend (current-thread))))
+(check-threads-gcable 'nested-suspend (lambda () (call-in-nested-thread (lambda () (thread-suspend (current-thread))))))
+
+(check-threads-gcable 'resume (lambda () (let ([t (thread (lambda () (sleep 10)))])
+					   (thread-suspend t)
+					   (sync (thread-resume-evt t)))))
+(check-threads-gcable 'suspend (lambda () (let ([t (thread (lambda () (semaphore-wait (make-semaphore))))])
+					    (sync (thread-suspend-evt t)))))
+(check-threads-gcable 'suspend-self (lambda () (sync (thread-suspend-evt (current-thread)))))
+
+;; ----------------------------------------
+;;  Fairness in wait selection
+
+(let ([try (lambda (t1 t2 r min max)
+	     (test #t 
+		   < 
+		   min
+		   (let loop ([n 100][r-n 0])
+		     (if (zero? n)
+			 r-n
+			 (loop (sub1 n) (+ r-n
+					   (if (eq? r (sync t1 t2))
+					       1
+					       0)))))
+		   max))])
+  (let ([t1 (semaphore-peek-evt (make-semaphore 1))]
+	[t2 (semaphore-peek-evt (make-semaphore 1))])
+    (let-values ([(r w) (make-pipe)])
+      (fprintf w "Hi!~n")
+      ;; Between 20% and 80% is fair, and surely < 20% or > 80% is unlikely
+      (try t1 t2 t1 20 80)
+      (try t1 t2 t2 20 80)
+      (try t1 w w 20 80)
+      (try w t1 w 20 80)
+      (try t1 (choice-evt t2 w) t1 10 50)
+      (try t1 (choice-evt t2 w) w 10 50)
+      (try (choice-evt t2 w) t1 w 10 50))))
+
+;; ----------------------------------------
+;;  No starvation, despite hack to increase throughput for
+;;  semaphore-protected data structures:
+
+(let ([s1 (make-semaphore)])
+  (define t1
+    (thread (lambda ()
+	      (semaphore-wait s1)
+	      (semaphore-post s1))))
+  (let loop ()
+    (sleep)
+    (semaphore-post s1)
+    (semaphore-wait s1)
+    (when (thread-running? t1)
+      (loop)))
+  (test #t string? "No starvation - good!"))
+
+(let ([s1 (make-semaphore)]
+      [s2 (make-semaphore)])
+  (define t1
+    (thread (lambda ()
+	      (semaphore-post (sync s1 s2)))))
+  (define t2
+    (thread (lambda ()
+	      (semaphore-post (sync s1 s2)))))
+  (let loop ()
+    (sleep)
+    (semaphore-post s1)
+    (semaphore-wait s1)
+    (semaphore-post s2)
+    (semaphore-wait s2)
+    (when (or (thread-running? t1)
+	      (thread-running? t2))
+      (loop)))
+  (test #t string? "No starvation - good!"))
+
+;; ----------------------------------------
+;;  Breaks and dynamic-wind
+
+(let ([s #f]
+      [p #f]
+      [/dev/null-for-err
+       (make-output-port #f always-evt (lambda (s start end ? ??) (- end start)) void void)]
+      [did-pre1 #f]
+      [did-pre2 #f]
+      [did-act1 #f]
+      [did-act2 #f]
+      [did-post1 #f]
+      [did-post2 #f]
+      [did-done #f]
+      [break-on (lambda () (break-enabled #t))]
+      [sw semaphore-wait])
+  (let ([mk-t
+	 (lambda (init ;; how to start
+		  ;; functions that can capture the continuation:
+		  capture-pre capture-act capture-post
+		  ;; whether to start the thread with breaks off (imperatively)
+		  break-off?
+		  ;; things to do in pre, act, and post
+		  pre-thunk act-thunk post-thunk
+		  ;; sema-wait or sema-wait/enable-break:
+		  pre-semaphore-wait act-semaphore-wait post-semaphore-wait)
+	   ;; This reset function is called for a cptured continuation
+	   ;;  to reset the effective arguments
+	   (define (reset
+		    -capture-pre -capture-act -capture-post
+		    -break-off?
+		    -pre-thunk -act-thunk -post-thunk
+		    -pre-semaphore-wait -act-semaphore-wait -post-semaphore-wait)
+	     (when -break-off?
+	       (break-enabled #f))
+	     (set! capture-pre -capture-pre)
+	     (set! capture-act -capture-act)
+	     (set! capture-post -capture-post)
+	     (set! pre-thunk -pre-thunk)
+	     (set! act-thunk -act-thunk)
+	     (set! post-thunk -post-thunk)
+	     (set! pre-semaphore-wait -pre-semaphore-wait)
+	     (set! act-semaphore-wait -act-semaphore-wait)
+	     (set! post-semaphore-wait -post-semaphore-wait))
+	   ;; initially, thread hasn't gotten anywhere:
+	   (set! did-pre1 #f) (set! did-pre2 #f)
+	   (set! did-act1 #f) (set! did-act2 #f)
+	   (set! did-post1 #f) (set! did-post2 #f)
+	   (set! did-done #f)
+	   (thread 
+	    (lambda ()
+	      (current-error-port /dev/null-for-err)
+	      (when break-off?
+		(break-enabled #f))
+	      (init ;; init function gets to decide whether to do the normal body:
+	       (lambda ()
+		 (dynamic-wind
+		     (lambda ()
+		       (capture-pre
+			reset
+			(lambda ()
+			  (set! did-pre1 #t)
+			  (semaphore-post p)
+			  (pre-thunk)
+			  (pre-semaphore-wait s)
+			  (set! did-pre2 #t))))
+		     (lambda () 
+		       (capture-act
+			reset
+			(lambda ()
+			  (set! did-act1 #t)
+			  (semaphore-post p)
+			  (act-thunk)
+			  (act-semaphore-wait s)
+			  (set! did-act2 #t))))
+		     (lambda ()
+		       (capture-post
+			reset
+			(lambda ()
+			  (set! did-post1 #t)
+			  (semaphore-post p)
+			  (post-thunk)
+			  (post-semaphore-wait s)
+			  (set! did-post2 #t)))))
+		 (set! did-done #t))))))])
+    ;; `go' runs the tests, parameterized by when to break the other
+    ;;  thread and when it should take effect in the other thread
+    (define (go
+	     mk-t* break-off?
+	     pre-thunk act-thunk post-thunk
+	     pre-semaphore-wait act-semaphore-wait post-semaphore-wait
+	     try-pre-break 
+	     should-pre-break?
+	     should-preact-break?
+	     try-act-break 
+	     should-act-break?
+	     try-post-break 
+	     should-post-break?
+	     should-done-break?)
+      ;; print the state for this test:
+      (test #t list? (list 'go 
+			   pre-thunk act-thunk post-thunk
+			   pre-semaphore-wait act-semaphore-wait post-semaphore-wait
+			   try-pre-break 
+			   should-pre-break?
+			   should-preact-break?
+			   try-act-break 
+			   should-act-break?
+			   try-post-break 
+			   should-post-break?
+			   should-done-break?))
+      ;; create fresh semaphores
+      (set! s (make-semaphore))
+      (set! p (make-semaphore))
+      ;; create the thread
+      (let ([t (mk-t* break-off?
+		      pre-thunk act-thunk post-thunk
+		      pre-semaphore-wait act-semaphore-wait post-semaphore-wait)])
+	(semaphore-wait p)
+	(test #t 'pre1 did-pre1)
+	(try-pre-break t)
+	(semaphore-post s)
+	(if should-pre-break?
+	    (begin
+	      (thread-wait t)
+	      (test #f 'pre2 did-pre2))
+	    (if should-preact-break?
+		(begin
+		  (semaphore-post s) ; for post
+		  (thread-wait t)
+		  (test #t 'pre2 did-pre2)
+		  (test #f 'act1 did-act1))
+		(begin
+		  (semaphore-wait p)
+		  (test #t 'pre2 did-pre2)
+		  (test #t 'act1 did-act1)
+		  (try-act-break t)
+		  (semaphore-post s)
+		  (if should-act-break?
+		      (begin
+			(semaphore-post s) ; for post
+			(thread-wait t)
+			(test #f 'act2 did-act2))
+		      (begin
+			(semaphore-wait p)
+			(test #t 'act2 did-act2)
+			(test #t 'post1 did-post1)
+			(try-post-break t)
+			(semaphore-post s)
+			(if should-post-break?
+			    (begin
+			      (thread-wait t)
+			      (test #f 'post2 did-post2))
+			    (begin
+			      (thread-wait t)
+			      (test #t 'post2 did-post2)
+			      (test (not should-done-break?) 'done did-done))))))))))
+    (for-each 
+     (lambda (mk-t)
+       (for-each 
+	(lambda (nada)
+	  ;; Basic checks --- dynamic-wind thunks don't explicitly enable breaks
+	  (go mk-t #f  nada nada nada  sw sw sw  void #f #f void #f void #f #f)
+	  (go mk-t #f  nada nada nada  sw sw sw  break-thread #f 'pre-act void #f void #f #f)
+	  (go mk-t #f  nada nada nada  sw sw sw  void #f #f break-thread 'act void #f #f)
+	  (go mk-t #f  nada nada nada  sw sw sw  void #f #f void #f break-thread #f 'done)
+
+	  ;; All dynamic-wind thunks enable breaks
+	  (map (lambda (break-on sw)
+		 (go mk-t #f  break-on break-on break-on  sw sw sw  void #f #f void #f void #f #f)
+		 (go mk-t #f  break-on break-on break-on  sw sw sw  break-thread 'pre #f void #f void #f #f)
+		 (go mk-t #f  break-on break-on break-on  sw sw sw  void #f #f break-thread 'act void #f #f)
+		 (go mk-t #f  break-on break-on break-on  sw sw sw  void #f #f void #f break-thread 'post #f))
+	       (list break-on void)
+	       (list sw semaphore-wait/enable-break))
+
+	  ;; Enable break in pre or act shouldn't affect post
+	  (go mk-t #f  break-on nada nada  sw sw sw  void #f #f void #f break-thread #f 'done)
+	  (go mk-t #f  nada break-on nada  sw sw sw  void #f #f void #f break-thread #f 'done)
+	  
+	  ;; Enable break in pre shouldn't affect act/done
+	  (go mk-t #t  break-on nada nada  sw sw sw  void #f #f break-thread #f void #f #f)
+	  (go mk-t #t  break-on nada nada  sw sw sw  void #f #f void #f break-thread #f #f))
+	(list void sleep)))
+     ;; We'll make threads in three modes: normal, restore a continuation into pre,
+     ;;  and restore a continuation into act
+     (let* ([no-capture (lambda (reset body) (body))]
+	    [plain-mk-t (lambda args
+			  (apply mk-t 
+				 (lambda (f) (f))
+				 no-capture no-capture no-capture
+				 args))]
+	    [mk-capturing (lambda (which)
+			    (let* ([k+reset #f]
+				   [capture (lambda (reset body)
+					      (let/cc k 
+						(set! k+reset (cons k reset)))
+					      (body))])
+			      ;; Grab a continuation for the dyn-wind's pre/act/post
+			      (go (lambda args
+				    (apply mk-t 
+					   (lambda (f) (f))
+					   (if (eq? which 'pre) capture no-capture)
+					   (if (eq? which 'act) capture no-capture)
+					   (if (eq? which 'post) capture no-capture)
+					   args))
+				  #f  void void void  sw sw sw  void #f #f void #f void #f #f)
+			      (lambda args
+				(apply mk-t 
+				       (lambda (f)
+					 ;; First, reset the arguments that are in the continuation's
+					 ;;  state
+					 (apply (cdr k+reset) no-capture no-capture no-capture args)
+					 ;; Now restore the continuation
+					 ((car k+reset)))
+				       no-capture no-capture no-capture
+				       args))))])
+       (list plain-mk-t
+	     (mk-capturing 'pre)
+	     (mk-capturing 'act))))))
+
+;; ----------------------------------------
+
+(report-errs)
diff --git a/collects/tests/mzscheme/syntax.ss b/collects/tests/mzscheme/syntax.ss
new file mode 100644
index 0000000000..5794a1d2e7
--- /dev/null
+++ b/collects/tests/mzscheme/syntax.ss
@@ -0,0 +1,1046 @@
+
+(load-relative "loadtest.ss")
+
+(test 0 'with-handlers (with-handlers () 0))
+(test 1 'with-handlers (with-handlers ([void void]) 1))
+(test 2 'with-handlers (with-handlers ([void void]) 1 2))
+(test 'zero 'zero
+      (with-handlers ((zero? (lambda (x) 'zero)))
+		     (raise 0)))
+(test 'zero 'zero
+      (with-handlers ((zero? (lambda (x) 'zero))
+		      (positive? (lambda (x) 'positive)))
+		     (raise 0)))
+(test 'positive 'positive
+      (with-handlers ((zero? (lambda (x) 'zero))
+		      (positive? (lambda (x) 'positive)))
+		     (raise 1)))
+(test 5 'with-handlers
+        (with-handlers ([void (lambda (x) 5)])
+	     (with-handlers ((zero? (lambda (x) 'zero)))
+		  (/ 0))))
+(error-test #'(with-handlers ()
+	         (/ 0))
+	    exn:fail:contract:divide-by-zero?)
+(error-test #'(with-handlers ((zero? (lambda (x) 'zero)))
+		 (/ 0))
+	    exn:application:type?)
+(error-test #'(with-handlers ((zero? (lambda (x) 'zero))
+			     (boolean? (lambda (x) 'boolean)))
+		 (/ 0))
+	    exn:application:type?)
+(syntax-test #'with-handlers)
+(syntax-test #'(with-handlers))
+(syntax-test #'(with-handlers . 1))
+(syntax-test #'(with-handlers ((zero? (lambda (x) 'zero)))))
+(syntax-test #'(with-handlers ((zero? (lambda (x) 'zero))) . 1))
+(syntax-test #'(with-handlers (zero?) 1))
+(syntax-test #'(with-handlers ((zero?)) 1))
+(syntax-test #'(with-handlers ((zero? . zero?)) 1))
+(syntax-test #'(with-handlers ((zero? zero?) . 2) 1))
+(syntax-test #'(with-handlers ((zero? zero?) zero?) 1))
+(syntax-test #'(with-handlers ((zero? zero?) (zero?)) 1))
+(syntax-test #'(with-handlers ((zero? zero?) (zero?)) 1))
+(syntax-test #'(with-handlers ((zero? zero? zero?)) 1))
+(syntax-test #'(with-handlers ((zero? zero? . zero?)) 1))
+(syntax-test #'(with-handlers ((zero? zero?)) 1 . 2))
+
+(error-test #'(with-handlers ((0 void)) (/ 0)) 
+	    exn:application:type?)
+(error-test #'(with-handlers ((void 0)) (/ 0))
+	    exn:application:type?)
+(error-test #'(with-handlers ((unbound-variable void)) 0)
+	    exn:fail:contract:variable?)
+(error-test #'(with-handlers ((void unbound-variable)) 0)
+	    exn:fail:contract:variable?)
+(error-test #'(with-handlers (((values 1 2) void)) 0)
+	    arity?)
+(error-test #'(with-handlers ((void (values 1 2))) 0)
+	    arity?)
+
+(test-values '(1 2) (lambda () (with-handlers ([void void])
+					      (values 1 2))))
+
+(SECTION 4 1 2)
+(test '(quote a) 'quote (quote 'a))
+(test '(quote a) 'quote ''a)
+(syntax-test #'quote)
+(syntax-test #'(quote))
+(syntax-test #'(quote 1 2))
+
+(SECTION 4 1 3)
+(test 12 (if #f + *) 3 4)
+(syntax-test #'(+ 3 . 4))
+
+(SECTION 4 1 4)
+(test 8 (lambda (x) (+ x x)) 4)
+(define reverse-subtract
+  (lambda (x y) (- y x)))
+(test 3 reverse-subtract 7 10)
+(define add4
+  (let ((x 4))
+    (lambda (y) (+ x y))))
+(test 10 add4 6)
+(test (letrec([x x]) x) 'lambda (let ([x (lambda () (define d d) d)]) (x)))
+(test (letrec([x x]) x) 'lambda ((lambda () (define d d) d)))
+(test '(3 4 5 6) (lambda x x) 3 4 5 6)
+(test '(5 6) (lambda (x y . z) z) 3 4 5 6)
+(test 'second (lambda () (cons 'first 2) 'second))
+(syntax-test #'lambda)
+(syntax-test #'(lambda))
+(syntax-test #'(lambda x))
+(syntax-test #'(lambda ()))
+(syntax-test #'(lambda () (begin)))
+(syntax-test #'(lambda . x))
+(syntax-test #'(lambda x . x))
+(syntax-test #'(lambda x . 5))
+(syntax-test #'(lambda ((x)) x))
+(syntax-test #'(lambda 5 x))
+(syntax-test #'(lambda (5) x))
+(syntax-test #'(lambda (x (y)) x))
+(syntax-test #'(lambda (x . 5) x))
+(syntax-test #'(lambda (x) x . 5))
+
+(let ([f
+       (case-lambda
+	[() 'zero]
+	[(x) (cons 1 1) 'one]
+	[(x y) 'two]
+	[(x y z . rest) 'three+]
+	[x 'bad])]
+      [g
+       (case-lambda
+	[(x y z) 'three]
+	[(x y) (cons 2 2) 'two]
+	[(x) 'one]
+	[() 'zero]
+	[x (cons 0 'more!) 'more])]
+      [h
+       (case-lambda
+	[(x y) 'two]
+	[(x y z w) 'four])])
+  (test 'zero f)
+  (test 'one f 1)
+  (test 'two f 1 2)
+  (test 'three+ f 1 2 3)
+  (test 'three+ f 1 2 3 4)
+  (test 'three+ f 1 2 3 4 5 6 7 8 9 10)
+
+  (test 'zero g)
+  (test 'one g 1)
+  (test 'two g 1 2)
+  (test 'three g 1 2 3)
+  (test 'more g 1 2 3 4 5 6 7 8 9 10)
+
+  (test 'two h 1 2)
+  (test 'four h 1 2 3 4)
+  (let ([h '(case-lambda
+	     [(x y) 'two]
+	     [(x y z w) 'four])])
+    (error-test (datum->syntax-object #f (list h) #f) arity?)
+    (error-test (datum->syntax-object #f (list* h '(1)) #f) arity?)
+    (error-test (datum->syntax-object #f (list* h '(1 2 3)) #f) arity?)
+    (error-test (datum->syntax-object #f (list* h '(1 2 3 4 5 6)) #f) arity?)))
+
+(error-test #'((case-lambda)) arity?)
+
+(syntax-test #'case-lambda)
+(syntax-test #'(case-lambda . 1))
+(syntax-test #'(case-lambda []))
+(syntax-test #'(case-lambda 1))
+(syntax-test #'(case-lambda x))
+(syntax-test #'(case-lambda [x]))
+(syntax-test #'(case-lambda [x 8][y]))
+(syntax-test #'(case-lambda [x][y 9]))
+(syntax-test #'(case-lambda [8 8]))
+(syntax-test #'(case-lambda [((x)) 8]))
+(syntax-test #'(case-lambda [(8) 8]))
+(syntax-test #'(case-lambda [(x . 9) 8]))
+(syntax-test #'(case-lambda [x . 8]))
+(syntax-test #'(case-lambda [(x) . 8]))
+(syntax-test #'(case-lambda . [(x) 8]))
+(syntax-test #'(case-lambda [(x) 8] . y))
+(syntax-test #'(case-lambda [(x) 8] . [y 7]))
+(syntax-test #'(case-lambda [(x) 8] [8 7]))
+(syntax-test #'(case-lambda [(x) 8] [((y)) 7]))
+(syntax-test #'(case-lambda [(x) 8] [(8) 7]))
+(syntax-test #'(case-lambda [(x) 8] [(y . 8) 7]))
+(syntax-test #'(case-lambda [(x) 8] [y . 7]))
+(syntax-test #'(case-lambda [(x) 8] [(y) . 7]))
+(syntax-test #'(case-lambda [(x x) 8] [(y) 7]))
+(syntax-test #'(case-lambda [(x . x) 8] [(y) 7]))
+(syntax-test #'(case-lambda [(y) 7] [(x x) 8]))
+(syntax-test #'(case-lambda [(y) 7] [(x . x) 8]))
+
+(SECTION 4 1 5)
+(test 'yes 'if (if (> 3 2) 'yes 'no))
+(test 'no 'if (if (> 2 3) 'yes 'no))
+(test '1 'if (if (> 3 2) (- 3 2) (+ 3 2)))
+(test-values '(1 2) (lambda () (if (cons 1 2) (values 1 2) 0)))
+(test-values '(1 2) (lambda () (if (not (cons 1 2)) 0 (values 1 2))))
+(syntax-test #'if)
+(syntax-test #'(if))
+(syntax-test #'(if . #t))
+(syntax-test #'(if #t . 1))
+(syntax-test #'(if #t 1 . 2))
+(syntax-test #'(if #t))
+(syntax-test #'(if #t 1 2 3))
+(syntax-test #'(if #t 1 2 . 3))
+(error-test #'(if (values 1 2) 3 4) arity?)
+
+(test (void) 'when (when (> 1 2) 0))
+(test (void) 'when (when (> 1 2) (cons 1 2) 0))
+(test 0 'when (when (< 1 2) 0))
+(test 0 'when (when (< 1 2) (cons 1 2) 0))
+(test-values '(0 10) (lambda () (when (< 1 2) (values 0 10))))
+(syntax-test #'when)
+(syntax-test #'(when))
+(syntax-test #'(when . 1))
+(syntax-test #'(when 1))
+(syntax-test #'(when 1 . 2))
+(error-test #'(when (values 1 2) 0) arity?)
+
+(test (void) 'unless (unless (< 1 2) 0))
+(test (void) 'unless (unless (< 1 2) (cons 1 2) 0))
+(test 0 'unless (unless (> 1 2) 0))
+(test 0 'unless (unless (> 1 2) (cons 1 2) 0))
+(test-values '(0 10) (lambda () (unless (> 1 2) (values 0 10))))
+(syntax-test #'unless)
+(syntax-test #'(unless))
+(syntax-test #'(unless . 1))
+(syntax-test #'(unless 1))
+(syntax-test #'(unless 1 . 2))
+(error-test #'(unless (values 1 2) 0) arity?)
+
+(SECTION 4 1 6)
+(define x 2)
+(test 3 'define (+ x 1))
+(set! x 4)
+(test 5 'set! (+ x 1))
+(syntax-test #'set!)
+(syntax-test #'(set!))
+(syntax-test #'(set! x))
+(syntax-test #'(set! x 1 2))
+(syntax-test #'(set! 1 2))
+(syntax-test #'(set! (x) 1))
+(syntax-test #'(set! . x))
+(syntax-test #'(set! x . 1))
+(syntax-test #'(set! x 1 . 2))
+
+(set!-values (x) 9)
+(test 9 'set!-values x)
+(test (void) 'set!-values (set!-values () (values)))
+(syntax-test #'set!-values)
+(syntax-test #'(set!-values))
+(syntax-test #'(set!-values . x))
+(syntax-test #'(set!-values x))
+(syntax-test #'(set!-values 8))
+(syntax-test #'(set!-values (x)))
+(syntax-test #'(set!-values (x) . 0))
+(syntax-test #'(set!-values x 0))
+(syntax-test #'(set!-values (x . y) 0))
+(syntax-test #'(set!-values (x . 8) 0))
+(syntax-test #'(set!-values (x 8) 0))
+(syntax-test #'(set!-values (x) 0 1))
+(syntax-test #'(set!-values (x) 0 . 1))
+(syntax-test #'(set!-values (x x) 0))
+(syntax-test #'(set!-values (x y x) 0))
+(syntax-test #'(set!-values (y x x) 0))
+
+(error-test #'(set!-values () 1) arity?)
+(error-test #'(set!-values () (values 1 2)) arity?)
+(error-test #'(set!-values (x) (values)) arity?)
+(error-test #'(set!-values (x) (values 1 2)) arity?)
+(error-test #'(set!-values (x y) 1) arity?)
+(error-test #'(set!-values (x y) (values 1 2 3)) arity?)
+
+(error-test #'(set! unbound-variable 5) exn:fail:contract:variable?)
+
+(SECTION 4 2 1)
+(test 'greater 'cond (cond ((> 3 2) 'greater)
+			   ((< 3 2) 'less)))
+(test 'equal 'cond (cond ((> 3 3) 'greater)
+			 ((< 3 3) 'less)
+			 (else 'equal)))
+(test 2 'cond (cond ((assv 'b '((a 1) (b 2))) => cadr)
+		     (else #f)))
+(test #f 'cond (cond ((assv 'z '((a 1) (b 2))) => cadr)
+		     (else #f)))
+(syntax-test #'(cond ((assv 'z '((a 1) (b 2))) => cadr)
+		    (else 8)
+		    (else #f)))
+(test #f 'cond (let ([else #f])
+		 (cond ((assv 'z '((a 1) (b 2))) => cadr)
+		       (else 8)
+		       (#t #f))))
+(test 'second 'cond (cond ((< 1 2) (cons 1 2) 'second)))
+(test 'second-again 'cond (cond ((> 1 2) 'ok) (else (cons 1 2) 'second-again)))
+(test 1 'cond (cond (1)))
+(test 1 'cond (cond (#f) (1)))
+(test 1 'cond (cond (#f 7) (1)))
+(test 2 'cond (cond (#f 7) (1 => add1)))
+(test add1 'cond (let ([=> 9]) (cond (#f 7) (1 => add1))))
+(non-z '(test 0 'case (case (* 2 3)
+		(6 0)
+		(else 7))))
+(test 'composite 'case (case (* 2 3)
+			 ((2 3 5 7) 'prime)
+			 ((1 4 6 8 9) 'composite)))
+(test 'consonant 'case (case (car '(c d))
+			 ((a e i o u) 'vowel)
+			 ((w y) 'semivowel)
+			 (else 'consonant)))
+(test 'second 'case (case 10
+		      [(10) (cons 1 2) 'second]
+		      [else 5]))
+(test 'second-again 'case (case 11
+			    [(10) (cons 1 2) 'second]
+			    [else (cons 1 2) 'second-again]))
+(test-values '(10 9) (lambda ()
+		       (cond
+			[(positive? 0) 'a]
+			[(positive? 10) (values 10 9)]
+			[else #f])))
+(test-values '(10 9) (lambda ()
+		       (case (string->symbol "hello")
+			[(bye) 'a]
+			[(hello) (values 10 9)]
+			[else #f])))
+(error-test #'(cond [(values 1 2) 8]) arity?)
+(error-test #'(case (values 1 2) [(a) 8]) arity?)
+
+(test #t 'and (and (= 2 2) (> 2 1)))
+(test #f 'and (and (= 2 2) (< 2 1)))
+(test '(f g) 'and (and 1 2 'c '(f g)))
+(test #t 'and (and))
+(test-values '(1 12) (lambda () (and (cons 1 2) (values 1 12))))
+(test #t 'or (or (= 2 2) (> 2 1)))
+(test #t 'or (or (= 2 2) (< 2 1)))
+(test #f 'or (or #f #f #f))
+(test #f 'or (or))
+(test '(b c) 'or (or (memq 'b '(a b c)) (+ 3 0)))
+(test-values '(1 12) (lambda () (or (not (cons 1 2)) (values 1 12))))
+(syntax-test #'(cond #t))
+(syntax-test #'(cond ())  )
+(syntax-test #'(cond (1 =>))  )
+(syntax-test #'(cond (1 => 3 4))  )
+(syntax-test #'(cond . #t))
+(syntax-test #'(cond (#t . 1)))
+(syntax-test #'(cond (#t 1) #f))
+(syntax-test #'(cond (#t 1) . #f))
+(error-test #'(cond ((values #t #f) 1)) arity?)
+(syntax-test #'case)
+(syntax-test #'(case))
+(syntax-test #'(case 0 #t))
+(syntax-test #'(case . 0))
+(syntax-test #'(case 0 . #t))
+(syntax-test #'(case 0 (0 #t)))
+(syntax-test #'(case 0 ()))
+(syntax-test #'(case 0 (0)))
+(syntax-test #'(case 0 (0 . 8)))
+(syntax-test #'(case 0 ((0 . 1) 8)))
+(syntax-test #'(case 0 (0 8) #f))
+(syntax-test #'(case 0 (0 8) . #f))
+(syntax-test #'(case 0 (else 1) (else 2)))
+(error-test #'(case 0 ((0) =>))  exn:fail:contract:variable?)
+(syntax-test #'(and . 1))
+(syntax-test #'(and 1 . 2))
+(syntax-test #'(or . 1))
+(syntax-test #'(or 1 . 2))
+(error-test #'(and #t (values 1 2) 8) arity?)
+(error-test #'(or #f (values 1 2) 8) arity?)
+
+(SECTION 4 2 2)
+(test 6 'let (let ((x 2) (y 3)) (* x y)))
+(test 'second 'let (let ((x 2) (y 3)) (* x y) 'second))
+(test 6 'let-values (let-values (((x) 2) ((y) 3)) (* x y)))
+(test 6 'let-values (let-values (((x y) (values 2 3))) (* x y)))
+(test 35 'let (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x))))
+(test 35 'let-values (let-values (((x y) (values 2 3))) (let-values (((x) 7) ((z) (+ x y))) (* z x))))
+(test 70 'let* (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x))))
+(test 70 'let*-values (let ((x 2) (y 3)) (let*-values (((x) 7) ((z) (+ x y))) (* z x))))
+(test #t 'letrec (letrec ((-even?
+			   (lambda (n) (if (zero? n) #t (-odd? (- n 1)))))
+			  (-odd?
+			   (lambda (n) (if (zero? n) #f (-even? (- n 1))))))
+		   (-even? 88)))
+(test #t 'letrec-values (letrec-values (((-even? -odd?)
+					 (values
+					  (lambda (n) (if (zero? n) #t (-odd? (- n 1))))
+					  (lambda (n) (if (zero? n) #f (-even? (- n 1)))))))
+				       (-even? 88)))
+(define x 34)
+(test 5 'let (let ((x 3)) (define x 5) x))
+(test 5 'let (let ((x 3)) (define-values (x w) (values 5 8)) x))
+(test 34 'let x)
+(test 6 'let (let () (define x 6) x))
+(test 34 'let x)
+(test 7 'let* (let* ((x 3)) (define x 7) x))
+(test 34 'let* x)
+(test 8 'let* (let* () (define x 8) x))
+(test 34 'let* x)
+(test 9 'letrec (letrec () (define x 9) x))
+(test 34 'letrec x)
+(test 10 'letrec (letrec ((x 3)) (define x 10) x))
+(test 34 'letrec x)
+(teval '(test 5 'letrec (letrec ((x 5)(y x)) y)))
+(test 3 'let (let ((y 'apple) (x 3) (z 'banana)) x))
+(test 3 'let* (let* ((y 'apple) (x 3) (z 'banana)) x))
+(test 3 'letrec (letrec ((y 'apple) (x 3) (z 'banana)) x))
+(test 3 'let* (let* ((x 7) (y 'apple) (z (set! x 3))) x))
+(test 3 'let* (let* ((x 7) (y 'apple) (z (if (not #f) (set! x 3) #f))) x))
+(test 3 'let* (let* ((x 7) (y 'apple) (z (if (not #t) #t (set! x 3)))) x))
+(test 3 'let-values (let-values (((y x z) (values 'apple 3 'banana))) x))
+(test 3 'let*-values (let*-values (((y x z) (values 'apple 3 'banana))) x))
+(test 3 'letrec-values (letrec-values (((y x z) (values 'apple 3 'banana))) x))
+(test 3 'let*-values (let*-values (((x y) (values 7 'apple)) ((z) (set! x 3))) x))
+(test 3 'let*-values (let*-values (((x y) (values 7 'apple)) ((z) (if (not #f) (set! x 3) #f))) x))
+(test 3 'let*-values (let*-values (((x y) (values 7 'apple)) ((z) (if (not #t) #t (set! x 3)))) x))
+(test 1 'named-let-scope (let ([f add1]) (let f ([n (f 0)]) n)))
+
+(test-values '(3 4) (lambda () (let ([x 3][y 4]) (values x y))))
+(test-values '(3 -4) (lambda () (let loop ([x 3][y -4]) (values x y))))
+(test-values '(3 14) (lambda () (let* ([x 3][y 14]) (values x y))))
+(test-values '(3 24) (lambda () (letrec ([x 3][y 24]) (values x y))))
+(test-values '(3 54) (lambda () (let-values ([(x y) (values 3 54)]) (values x y))))
+(test-values '(3 64) (lambda () (let*-values ([(x y) (values 3 64)]) (values x y))))
+(test-values '(3 74) (lambda () (letrec-values ([(x y) (values 3 74)]) (values x y))))
+
+(test 'one 'let-values (let-values ([() (values)]) 'one))
+(test 'two 'let*-values (let*-values ([() (values)]) 'two))
+(test 'three 'letrec-values (letrec-values ([() (values)]) 'three))
+(test 'onex 'let-values (let-values ([() (values)][() (values)]) 'onex))
+(test 'twox 'let*-values (let*-values ([() (values)][() (values)]) 'twox))
+(test 'threex 'letrec-values (letrec-values ([() (values)][() (values)]) 'threex))
+
+(test '(10 11) 'letrec-values (letrec-values ([(names kps)
+					       (letrec ([oloop 10])
+						 (values oloop (add1 oloop)))])
+					     (list names kps)))
+
+(define (error-test-let/no-* expr)
+  (syntax-test (datum->syntax-object #f (cons 'let expr) #f))
+  (syntax-test (datum->syntax-object #f (cons 'let (cons 'name expr)) #f))
+  (syntax-test (datum->syntax-object #f (cons 'letrec expr) #f)))
+(define (error-test-let expr)
+  (error-test-let/no-* expr)
+  (syntax-test (datum->syntax-object #f (cons 'let* expr) #f)))
+(error-test-let #'x)
+(error-test-let #'(x))
+(error-test-let #'(()))
+(error-test-let #'(x ()))
+(syntax-test #'(let* x () 1))
+(syntax-test #'(letrec x () 1))
+(error-test-let #'(x . 1))
+(error-test-let #'(() . 1))
+(error-test-let #'(((x 1))))
+(error-test-let #'(((x 1)) . 1))
+(error-test-let #'(((x . 1)) 1))
+(error-test-let #'(((1 1)) 1))
+(error-test-let #'(((x 1) 1)  1))
+(error-test-let #'(((x 1) . 1)  1))
+(error-test-let #'(((x 1 1)) 1))
+(error-test-let #'(((x 1 1)) 1))
+(error-test-let #'(((x 1)) 1 . 2))
+(error-test-let/no-* #'(((x 1) (x 2)) 1))
+(error-test-let/no-* #'(((x 1) (y 3) (x 2)) 1))
+(error-test-let/no-* #'(((y 3) (x 1) (x 2)) 1))
+(error-test-let/no-* #'(((x 1) (x 2) (y 3)) 1))
+(test 5 'let* (let* ([x 4][x 5]) x))
+(error-test-let #'(() (define x 10)))
+(error-test-let #'(() (define x 10) (define y 20)))
+
+(define (do-error-test-let-values/no-* expr syntax-test)
+  (syntax-test (datum->syntax-object #f (cons 'let-values expr) #f))
+  (syntax-test (datum->syntax-object #f (cons 'letrec-values expr) #f)))
+(define (do-error-test-let-values expr syntax-test)
+  (do-error-test-let-values/no-* expr syntax-test)
+  (syntax-test (datum->syntax-object #f (cons 'let*-values expr) #f)))
+(define (error-test-let-values/no-* expr)
+  (do-error-test-let-values/no-* expr syntax-test))
+(define (error-test-let-values expr)
+  (do-error-test-let-values expr syntax-test))
+(error-test-let-values #'x)
+(error-test-let-values #'(x))
+(error-test-let-values #'(()))
+(error-test-let-values #'(x ()))
+(syntax-test #'(let*-values x () 1))
+(syntax-test #'(letrec-values x () 1))
+(error-test-let-values #'(x . 1))
+(error-test-let-values #'(() . 1))
+(error-test-let-values #'((((x) 1))))
+(error-test-let-values #'((((x) 1)) . 1))
+(error-test-let-values #'((((x) . 1)) 1))
+(error-test-let-values #'((((1) 1)) 1))
+(error-test-let-values #'((((x 1) 1)) 1))
+(error-test-let-values #'((((1 x) 1)) 1))
+(error-test-let-values #'((((x) 1) . 1)  1))
+(error-test-let-values #'((((x) 1 1)) 1))
+(error-test-let-values #'((((x . y) 1)) 1))
+(error-test-let-values #'((((x . 1) 1)) 1))
+(error-test-let-values #'((((x) 1)) 1 . 2))
+(error-test-let-values #'((((x x) 1)) 1))
+(error-test-let-values #'((((y) 0) ((x x) 1)) 1))
+(error-test-let-values #'((((x x) 1) ((y) 0)) 1))
+(error-test-let-values/no-* #'((((x) 1) ((x) 2)) 1))
+(error-test-let-values/no-* #'((((x) 1) ((y) 3) ((x) 2)) 1))
+(error-test-let-values/no-* #'((((y) 3) ((x) 1) ((x) 2)) 1))
+(error-test-let-values/no-* #'((((x) 1) ((x) 2) ((y) 3)) 1))
+(test 5 'let* (let*-values ([(x) 4][(x) 5]) x))
+
+(do-error-test-let-values #'((((x y) 1)) 1) (lambda (x) (error-test x arity?)))
+(do-error-test-let-values #'((((x) (values 1 2))) 1) (lambda (x) (error-test x arity?)))
+(do-error-test-let-values #'(((() (values 1))) 1) (lambda (x) (error-test x arity?)))
+(do-error-test-let-values #'((((x) (values))) 1) (lambda (x) (error-test x arity?)))
+
+(test 5 'embedded (let () (define y (lambda () x)) (define x 5) (y)))
+
+(let ([wrap (lambda (body)
+	      (syntax-test (datum->syntax-object #f `(let () ,@body) #f))
+	      (syntax-test (datum->syntax-object #f `(let () (begin ,@body)) #f)))])
+  (wrap '((define x 7) (define x 8) x))
+  (wrap '((define 3 8) x))
+  (wrap '((define-values x 8) x)))
+
+(let ([wrap
+       (lambda (val body)
+	 (teval `(test ,val 'let-begin (let () ,@body)))
+	 (teval `(test ,val 'let-begin (let ([xyzw 12]) ,@body)))
+	 (teval `(test ,val (lambda () ,@body)))
+	 (teval `(test ,val 'parameterize-begin
+		       (parameterize () ,@body)))
+	 (teval `(test ,val 'parameterize-begin
+		       (parameterize ([current-directory (current-directory)])
+			 ,@body)))
+	 (teval `(test ,val 'with-handlers-begin
+		       (with-handlers () ,@body)))
+	 (teval `(test ,val 'with-handlers-begin
+		       (with-handlers ([void void]) ,@body)))
+	 (teval `(test ,val 'fluid-let-begin (fluid-let () ,@body)))
+	 (teval `(test ,val 'fluid-let-begin (fluid-let ([x 20]) ,@body)))
+	 (syntax-test (datum->syntax-object #f `(when (positive? 1) ,@body) #f))
+	 (syntax-test (datum->syntax-object #f `(unless (positive? -1) ,@body) #f))
+	 (syntax-test (datum->syntax-object #f `(cond [(positive? 1) ,@body][else #f]) #f))
+	 (syntax-test (datum->syntax-object #f `(cond [(positive? -1) 0][else ,@body]) #f))
+	 (syntax-test (datum->syntax-object #f `(case (positive? 1) [(#t) ,@body][else -12]) #f))
+	 (syntax-test (datum->syntax-object #f `(cond [#t ,@body]) #f))
+	 (syntax-test (datum->syntax-object #f `(do ((x 1)) (#t ,@body) ,@body) #f))
+	 (syntax-test (datum->syntax-object #f `(begin0 12 ,@body) #f)))])
+  (wrap 5 '((begin (define x 5)) x))
+  (wrap 5 '((begin (define x 5) x)))
+  (wrap 15 '((begin (define x 5)) (begin (define y (+ x 10)) y)))
+  (wrap 13 '((begin) 13))
+  (wrap 7 '((begin) (begin) (begin (define x 7) (begin) x)))
+  (wrap 7 '((begin (begin (begin (define x 7) (begin) x))))))
+
+(SECTION 4 2 3)
+(define x 0)
+(define (test-begin bg nested-bg)
+  (let* ([make-args
+	  (lambda (bg b)
+	    (if (eq? bg 'begin)
+		b
+		(let* ([len (length b)]
+		       [last (list-ref b (sub1 len))])
+		  (cons last
+			(let loop ([l b])
+			  (if (null? (cdr l))
+			      null
+			      (cons (car l) (loop (cdr l)))))))))]
+	 [test-bg
+	  (lambda (v b)
+	    (let* ([args (make-args bg b)]
+		   [expr (cons bg args)])
+	      (printf "~s:~n" expr)
+	      (teval `(test ,v (quote ,bg) ,expr))))]
+	 [make-bg
+	  (lambda (b)
+	    (cons nested-bg (make-args nested-bg b)))]
+	 [make-test-bg-d
+	  (lambda (bg)
+	    (lambda (v1 v2 b)
+	      (test-bg (if (eq? bg 'begin)
+			   v1
+			   v2)
+		       b)))]
+	 [test-bg-d (make-test-bg-d bg)]
+	 [test-bg-d2 (make-test-bg-d nested-bg)])
+  (teval '(set! x 0))
+  (test-bg-d 6 1 '((set! x 5) (+ x 1)))
+  (test-bg 5 '(5))
+  (test-bg 3 '(2 3))
+  (test-bg 3 `(2 (,bg 3)))
+  (test-bg 3 `(,(make-bg '(2)) ,(make-bg '(3))))
+  (test-bg-d 7 6 '((set! x 6) 'a (+ x 1)))
+  (test-bg ''w '((set! x 6) 'a (+ x 1) 'w))
+  (test-bg-d 8 7 '('b (set! x 7) (+ x 1)))
+  (test-bg-d 9 8 '('b (set! x 8) 'a (+ x 1)))
+  (test-bg ''z '('b (set! x 8) 'a (+ x 1) 'z))
+  (test-bg-d 7 9 `(,(make-bg '((set! x 6) 'a)) (+ x 1)))
+  (test-bg 10 `(,(make-bg '((set! x 60) 'a)) 10))
+  (teval '(test 60 'x x))
+  (test-bg 10 `(,(make-bg '((set! x 65) 'a)) (add1 20) 10))
+  (teval '(test 65 'x x))
+  (test-bg ''a `(10 ,(make-bg '((set! x 66) 'a))))
+  (teval '(test 66 'x x))
+  (test-bg ''a `(10 (add1 32) ,(make-bg '((set! x 67) 'a))))
+  (teval '(test 67 'x x))
+  (teval '(set! x 6))
+  (test-bg-d 8 7 `(,(make-bg '('b (set! x 7) 'a)) (+ x 1)))
+  (test-bg-d 9 8 `(,(make-bg '('b (set! x 8))) ,(make-bg '('a (+ x 1)))))
+  (test-bg-d2 10 9 `(,(make-bg `(,(make-bg `('b (set! x 9) ,(make-bg '('a (+ x 1)))))))))
+  (test-bg ''s `(,(make-bg `(,(make-bg `('b (set! x 9) ,(make-bg '('a (+ x 1) 's))))))))
+  (test-bg ''t `(,(make-bg `(,(make-bg `('b (set! x 9) ,(make-bg '('a (+ x 1))))))) 't))
+  (teval `(test 5 call-with-values (lambda () ,(make-bg '((values 1 2) (values 1 3 1)))) +))
+  (syntax-test (datum->syntax-object #f `(,bg . 1) #f))
+  (syntax-test (datum->syntax-object #f `(,bg 1 . 2) #f))))
+
+(test-begin 'begin 'begin)
+(test-begin 'begin0 'begin)
+(test-begin 'begin0 'begin0)
+(test-begin 'begin 'begin0)
+
+(syntax-test #'(begin0))
+(begin) ; must succeed, but we can't wrap it
+
+(test 4 'implicit-begin (let ([x 4][y 7]) 'y x))
+(test 4 'implicit-begin (let ([x 4][y 7]) y x))
+
+(test 5 'implicit-begin (let () (begin) 10 5))
+
+(error-test #'(begin (define foo (let/cc k k)) (foo 10)) exn:application:type?) ; not exn:application:continuation?
+
+(SECTION 4 2 5)
+(define f-check #t)
+(define f (delay (begin (set! f-check #f) 5)))
+(test #t (lambda () f-check))
+(test 5 force f)
+(test #f (lambda () f-check))
+(test 5 force f)
+(define f-check-2 (delay (values 1 5)))
+(test-values '(1 5) (lambda () (force f-check-2)))
+(values 1 2)
+(test-values '(1 5) (lambda () (force f-check-2)))
+(syntax-test #'delay)
+(syntax-test #'(delay))
+(syntax-test #'(delay . 1))
+(syntax-test #'(delay 1 . 2))
+(syntax-test #'(delay 1 2))
+
+(SECTION 4 2 6)
+(test '(list 3 4) 'quasiquote `(list ,(+ 1 2) 4))
+(test '(list a (quote a)) 'quasiquote (let ((name 'a)) `(list ,name ',name)))
+(test '(a 3 4 5 6 b) 'quasiquote `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b))
+(test '((foo 7) . cons)
+	'quasiquote
+	`((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons))))
+(test '#(10 5 2 4 3 8) 'quasiquote `#(10 5 ,(sqrt 4) ,@(map sqrt '(16 9)) 8))
+(test 5 'quasiquote `,(+ 2 3))
+(test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f)
+      'quasiquote `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f))
+(test '(a `(b ,x ,'y d) e) 'quasiquote
+	(let ((name1 'x) (name2 'y)) `(a `(b ,,name1 ,',name2 d) e)))
+(test '(list 3 4) 'quasiquote (quasiquote (list (unquote (+ 1 2)) 4)))
+(test '`(list ,(+ 1 2) 4) 'quasiquote '(quasiquote (list (unquote (+ 1 2)) 4)))
+(test '(()) 'qq `((,@())))
+(define x 5)
+(test '(quasiquote (unquote x)) 'qq ``,x)
+(test '(quasiquote (unquote 5)) 'qq ``,,x)
+(test '(quasiquote (unquote-splicing x)) 'qq ``,@x)
+(test '(quasiquote (unquote-splicing 5)) 'qq ``,@,x)
+(test '(quasiquote (quasiquote (quasiquote (unquote (unquote (unquote x)))))) 'qq ````,,,x)
+(test '(quasiquote (quasiquote (quasiquote (unquote (unquote (unquote 5)))))) 'qq ````,,,,x)
+
+(test '(quasiquote (unquote result)) 'qq `(quasiquote ,result))
+(test (list 'quasiquote car) 'qq `(,'quasiquote ,car))
+
+(syntax-test #'quasiquote)
+(syntax-test #'(quasiquote))
+(syntax-test #'(quasiquote . 5))
+(syntax-test #'(quasiquote 1 . 2))
+(syntax-test #'(quasiquote 1 2))
+(syntax-test #'(unquote 7))
+(syntax-test #'(unquote-splicing 7))
+
+(syntax-test #'`(1 . ,@5))
+(error-test #'`(1 ,@5))
+(error-test #'`(1 ,@5 2))
+
+(define (qq-test e)
+  (syntax-test (datum->syntax-object #f e #f))
+  (syntax-test (datum->syntax-object #f (list 'quasiquote e) #f))
+  (syntax-test (datum->syntax-object #f (list 'quasiquote e) #f))
+  (syntax-test (datum->syntax-object #f (list 'quasiquote (list 'quasiquote e)) #f))
+  (syntax-test (datum->syntax-object #f (list 'quasiquote (list 'quasiquote (list 'unquote e))) #f))
+  (syntax-test (datum->syntax-object #f (list 'quasiquote (list 'quasiquote (list 'unquote-splicing e))) #f)))
+(qq-test #'(unquote))
+(qq-test #'(unquote 7 8 9))
+(qq-test #'(unquote-splicing))
+(qq-test #'(unquote-splicing 7 8 9))
+
+(test '(unquote . 5) 'qq (quasiquote (unquote . 5)))
+(test '(unquote 1 . 5) 'qq (quasiquote (unquote 1 . 5)))
+(test '(unquote 1 2 . 5) 'qq (quasiquote (unquote 1 2 . 5)))
+
+(test '(unquote 1 2 7 . 5) 'qq (quasiquote (unquote 1 2 ,(+ 3 4) . 5)))
+(test '(unquote 1 2 (unquote (+ 3 4)) . 5) 'qq (quasiquote (unquote 1 2 ,',(+ 3 4) . 5)))
+
+(test '(1 2 3 4 . 5) 'qq `(1 ,@'(2 3 4) . 5))
+
+(error-test #'`(10 ,(values 1 2)) arity?)
+(error-test #'`(10 ,@(values 1 2)) arity?)
+
+(SECTION 5 2 1)
+(define add3 (lambda (x) (+ x 3)))
+(test 6 'define (add3 3))
+(define (add3 x) (+ x 3))
+(test 6 'define (add3 3))
+(define first car)
+(test 1 'define (first '(1 2)))
+(syntax-test #'define)
+(syntax-test #'(define))
+(syntax-test #'(define . x))
+(syntax-test #'(define x))
+(syntax-test #'(define x . 1))
+(syntax-test #'(define 1 2))
+(syntax-test #'(define (1) 1))
+(syntax-test #'(define (x 1) 1))
+(syntax-test #'(define (x a a) 1))
+(syntax-test #'(define ((x 1) a) 1))
+(syntax-test #'(define ((x b b) a) 1))
+(syntax-test #'(define x 1 . 2))
+(syntax-test #'(define x 1 2))
+
+(let ()
+  (define ((f x) y z) (list x y z))
+  (test '(1 2 3) (f 1) 2 3))
+(let ()
+  (define ((g a) a b) (list a b))
+  (test '(2 3) (g 1) 2 3))
+
+(define-values (add3) (lambda (x) (+ x 3)))
+(test 6 'define (add3 3))
+(define-values (add3 another) (values (lambda (x) (+ x 3)) 9))
+(test 6 'define (add3 3))
+(test 9 'define another)
+(define-values (first second third) (values car cadr caddr))
+(test 1 'define (first '(1 2)))
+(test 2 'define (second '(1 2)))
+(test 3 'define (third '(1 2 3)))
+(define-values () (values))
+(syntax-test #'define-values)
+(syntax-test #'(define-values))
+(syntax-test #'(define-values . x))
+(syntax-test #'(define-values x))
+(syntax-test #'(define-values (x)))
+(syntax-test #'(define-values x . 1))
+(syntax-test #'(define-values (x) . 1))
+(syntax-test #'(define-values 1 2))
+(syntax-test #'(define-values (1) 2))
+(syntax-test #'(define-values (x 1) 1))
+(syntax-test #'(define-values (x . y) 1))
+(syntax-test #'(define-values (x) 1 . 2))
+(syntax-test #'(define-values (x) 1 2))
+(syntax-test #'(define-values (x x) 10))
+(syntax-test #'(define-values (x y x) 10))
+
+(syntax-test #'((define x 2) 0 1))
+(syntax-test #'(+ (define x 2) 1))
+(syntax-test #'(if (define x 2) 0 1))
+(syntax-test #'(begin0 (define x 2)))
+(syntax-test #'(begin0 (define x 2) 0))
+(syntax-test #'(begin0 0 (define x 2)))
+(syntax-test #'(begin0 0 (define x 2) (define x 12)))
+(syntax-test #'(let () (define x 2)))
+(syntax-test #'(letrec () (define x 2)))
+(syntax-test #'(lambda () (define x 2)))
+(syntax-test #'(lambda () (void (define x 2)) 1))
+(syntax-test #'(cond [(< 2 3) (define x 2)] [else 5]))
+(syntax-test #'(cond [else (define x 2)]))
+(syntax-test #'(cond [else (define x 2) 0]))
+
+;; No good way to test in mzc:
+(error-test #'(define x (values)) exn:application:arity?)
+(error-test #'(define x (values 1 2)) exn:application:arity?)
+(error-test #'(define-values () 3) exn:application:arity?)
+(error-test #'(define-values () (values 1 3)) exn:application:arity?)
+(error-test #'(define-values (x y) (values)) exn:application:arity?)
+(error-test #'(define-values (x y) 3) exn:application:arity?)
+(error-test #'(define-values (x y) (values 1 2 3)) exn:application:arity?)
+
+(begin (define ed-t1 1) (define ed-t2 2))
+(test 1 'begin-define ed-t1)
+(test 2 'begin-define ed-t2)
+(begin (begin (begin (begin 10 (define ed-t2.5 2.5) 12))))
+(test 2.5 'begin-define ed-t2.5)
+(syntax-test #'(if (zero? 0) (define ed-t3 3) (define ed-t3 -3)))
+(syntax-test #'(if #t (define ed-t3 3) (define ed-t3 -3)))
+(syntax-test #'(if #f (define ed-t3 3) (define ed-t3 -3)))
+
+(SECTION 5 2 2)
+(test 45 'define
+	(let ((x 5))
+		(define foo (lambda (y) (bar x y)))
+		(define bar (lambda (a b) (+ (* a b) a)))
+		(foo (+ x 3))))
+(define x 34)
+(define (foo) (define x 5) x)
+(test 5 foo)
+(test 34 'define x)
+(define foo (lambda () (define x 5) x))
+(test 5 foo)
+(test 34 'define x)
+(define (foo x) ((lambda () (define x 5) x)) x)
+(test 88 foo 88)
+(test 4 foo 4)
+(test 34 'define x)
+
+(test 5 'define
+      (let ()
+	(define x 5)
+	(define define (lambda (a b) (+ a b)))
+	8
+	(define x 7)
+	x))
+(test 6 'define 
+      (let ()
+	(define define 5)
+	(define y 6)
+	y))
+
+(syntax-test #'(let ()
+		(define x 5)))
+(syntax-test #'(let ()
+		(if #t
+		    (define x 5))
+		5))
+
+; Can shadow syntax/macros with embedded defines
+(test 5 'intdef (let ()
+		  (define lambda 5)
+		  lambda))
+(test 5 'intdef (let ()
+		  (define define 5)
+		  'ok
+		  define))
+
+(syntax-test #'(lambda () (define x 10) (begin)))
+(syntax-test #'(lambda () (define x 10) (begin) (begin)))
+(syntax-test #'(lambda () (define x 10) (begin) (begin x) (begin)))
+(syntax-test #'(lambda () (define-values (x) . 10) x))
+(syntax-test #'(lambda () (define-values (x) 10) (begin 1 . 2) x))
+(syntax-test #'(lambda () (begin (define-values (x) 10) . 2) x))
+(syntax-test #'(lambda () (begin)))
+(syntax-test #'(lambda () (define-values . 10) x))
+(syntax-test #'(lambda () (define-values x 10) x))
+(syntax-test #'(lambda () (define-values (1) 10) x))
+
+(test 87 (lambda () (define x 87) (begin) (begin x)))
+
+(SECTION 4 2 4)
+(test '#(0 1 2 3 4) 'do (do ((vec (make-vector 5))
+			     (i 0 (+ i 1)))
+			    ((= i 5) vec)
+			  (vector-set! vec i i)))
+(test 25 'do (let ((x '(1 3 5 7 9)))
+	       (do ((x x (cdr x))
+		    (sum 0 (+ sum (car x))))
+		   ((null? x) sum))))
+(test 1 'let (let foo () 1))
+(test '((6 1 3) (-5 -2)) 'let
+      (let loop ((numbers '(3 -2 1 6 -5))
+		 (nonneg '())
+		 (neg '()))
+	(cond ((null? numbers) (list nonneg neg))
+	      ((negative? (car numbers))
+	       (loop (cdr numbers)
+		     nonneg
+		     (cons (car numbers) neg)))
+	      (else
+	       (loop (cdr numbers)
+		     (cons (car numbers) nonneg)
+		     neg)))))
+(test 5 'do (do ((x 1)) (#t 5)))
+(test-values '(10 5) (lambda () (do ((x 1)) (#t (values 10 5)))))
+(syntax-test #'do)
+(syntax-test #'(do))
+(syntax-test #'(do ()) )
+(syntax-test #'(do () ()) )
+(syntax-test #'(do (1) (#t 5) 5))
+(syntax-test #'(do ((1)) (#t 5) 5))
+(syntax-test #'(do ((1 7)) (#t 5) 5))
+(syntax-test #'(do ((x . 1)) (#t 5) 5))
+(syntax-test #'(do ((x 1) 2) (#t 5) 5))
+(syntax-test #'(do ((x 1) . 2) (#t 5) 5))
+(syntax-test #'(do ((x 1)) (#t . 5) 5))
+(syntax-test #'(do ((x 1)) (#t 5) . 5))
+
+(SECTION 'let/cc)
+
+(test 0 'let/cc (let/cc k (k 0) 1))
+(test 0 'let/cc (let/cc k 0))
+(test 1 'let/cc (let/cc k (cons 1 2) 1))
+(test-values '(2 1) (lambda () (let/cc k (values 2 1))))
+(test-values '(2 1) (lambda () (let/cc k (k 2 1))))
+(syntax-test #'(let/cc))
+(syntax-test #'(let/cc . k))
+(syntax-test #'(let/cc k))
+(syntax-test #'(let/cc k . 1))
+(syntax-test #'(let/cc 1 1))
+
+(test 0 'let/ec (let/ec k (k 0) 1))
+(test 0 'let/ec (let/ec k 0))
+(test 1 'let/ec (let/ec k (cons 1 2) 1))
+(test-values '(2 1) (lambda () (let/ec k (values 2 1))))
+(test-values '(2 1) (lambda () (let/ec k (k 2 1))))
+(syntax-test #'(let/ec))
+(syntax-test #'(let/ec . k))
+(syntax-test #'(let/ec k))
+(syntax-test #'(let/ec k . 1))
+(syntax-test #'(let/ec 1 1))
+
+(SECTION 'fluid-let)
+(define x 1)
+(define y -1)
+(define (get-x) x)
+(test 5 'fluid-let (fluid-let () 5))
+(test 2 'fluid-let (fluid-let ([x 2]) x))
+(test 0 'fluid-let (fluid-let ([x 2][y -2]) (+ x y)))
+(test 20 'fluid-let (fluid-let ([x 20]) (get-x)))
+(test 1 'fluid-let-done x)
+(error-test #'(fluid-let ([x 10]) (error 'bad)) exn:fail?)
+(test 1 'fluid-let-done-escape x)
+(test 3 'fluid-let (let* ([x 0][y (lambda () x)]) (fluid-let ([x 3]) (y))))
+(test 0 'fluid-let (let* ([x 0][y (lambda () x)]) (fluid-let ([x 3]) (y)) (y)))
+(test-values '(34 56) (lambda () (fluid-let ([x 34][y 56]) (values x y))))
+(test 'second 'fluid-let (fluid-let ([x 2][y -2]) (+ x y) 'second))
+
+(error-test #'(fluid-let ([undefined-variable 0]) 8) exn:fail:contract:variable?)
+
+(syntax-test #'fluid-let)
+(syntax-test #'(fluid-let))
+(syntax-test #'(fluid-let . 1))
+(syntax-test #'(fluid-let x 9))
+(syntax-test #'(fluid-let 1 9))
+(syntax-test #'(fluid-let (x) 9))
+(syntax-test #'(fluid-let ([x]) 9))
+(syntax-test #'(fluid-let ([x . 5]) 9))
+(syntax-test #'(fluid-let ([x 5] . y) 9))
+(syntax-test #'(fluid-let ([x 5] [y]) 9))
+(syntax-test #'(fluid-let ([x 5]) . 9))
+(syntax-test #'(fluid-let ([x 5]) 9 . 10))
+
+(SECTION 'parameterize)
+
+(test 5 'parameterize (parameterize () 5))
+(test 6 'parameterize (parameterize ([error-print-width 10]) 6))
+(test 7 'parameterize (parameterize ([error-print-width 10]
+				     [current-exception-handler void]) 
+				    7))
+(define oepw (error-print-width))
+(error-test #'(parameterize ([error-print-width 777]) (error 'bad)) exn:fail?)
+(test oepw 'parameterize (error-print-width))
+(error-test #'(parameterize ([error-print-width 777]
+			    [current-output-port (current-error-port)])
+			   (error 'bad)) 
+	    exn:fail?)
+(error-test #'(parameterize ([error-print-width 'a]) 10))
+
+(define p (make-parameter 1))
+(define q (make-parameter 2))
+(test '1 'pz-order (parameterize ([p 3][q (p)]) (q)))
+
+(error-test #'(parameterize) syntaxe?)
+(error-test #'(parameterize ()) syntaxe?)
+(error-test #'(parameterize ((x y))) syntaxe?)
+(error-test #'(parameterize ((x y)) . 8) syntaxe?)
+(error-test #'(parameterize (x) 8) syntaxe?)
+(error-test #'(parameterize (9) 8) syntaxe?)
+(error-test #'(parameterize ((x z) . y) 8) syntaxe?)
+(error-test #'(parameterize ((x . z)) 8) syntaxe?)
+(error-test #'(parameterize ((x . 9)) 8) syntaxe?)
+(error-test #'(parameterize ((x . 9)) 8) syntaxe?)
+
+(error-test #'(parameterize ([10 10]) 8))
+(error-test #'(parameterize ([(lambda () 10) 10]) 8))
+(error-test #'(parameterize ([(lambda (a) 10) 10]) 8))
+(error-test #'(parameterize ([(lambda (a b) 10) 10]) 8))
+
+#|
+(test #t procedure? (check-parameter-procedure current-directory))
+(test #t procedure? (check-parameter-procedure (case-lambda
+						[() 0]
+						[(x) 0])))
+(test 'exn 'not-param (with-handlers ([void (lambda (x) 'exn)])
+		    (check-parameter-procedure (lambda () 10))))
+(test 'exn 'not-param (with-handlers ([void (lambda (x) 'exn)])
+			(check-parameter-procedure (lambda (x) 10))))
+(test 'exn 'not-param (with-handlers ([void (lambda (x) 'exn)])
+			(check-parameter-procedure (lambda (x y) 10))))
+(arity-test check-parameter-procedure 1 1)
+|#
+
+(SECTION 'time)
+(test 1 'time (time 1))
+(test -1 'time (time (cons 1 2) -1))
+(test-values '(-1 1) (lambda () (time (values -1 1))))
+(syntax-test #'time)
+(syntax-test #'(time))
+(syntax-test #'(time . 1))
+(syntax-test #'(time 1 . 2))
+
+(SECTION 'compiler)
+; Tests specifically aimed at the compiler
+(error-test #'(let ([x (values 1 2)]) x) exn:application:arity?)
+; Known primitive
+(error-test #'(let ([x (make-pipe)]) x) exn:application:arity?)
+; Known local
+(error-test #'(let* ([f (lambda () (values 1 2))][x (f)]) x) exn:application:arity?)
+
+; Known local with global in its closure
+(test 15 'known (let ([g (lambda ()
+			   (letrec ([f (lambda (x)
+					 (+ x 5))])
+			     (f 10)))])
+		  (g)))
+; Known local with a set!
+(test 16 'known (let ([g (lambda ()
+			   (letrec ([f (lambda (x)
+					 (let ([y x])
+					   (set! x 7)
+					   (+ y 5)))])
+			     (f 11)))])
+		  (g)))
+; Known local non-function
+(error-test #'(apply (lambda () (let ([f 12]) (f))) null) exn:application:type?)
+; Known local with revsed arguments:
+(test 10 (letrec ([f (lambda (a b) (if (zero? a) b (f b a)))]) f) 10 0)
+
+(SECTION '#%datum-et-al)
+
+(syntax-test #'#%datum)
+(syntax-test #'(let ([#%datum 5])
+		 1))
+(test '(1) '#%datum (#%datum 1))
+(test 1 '#%datum (#%datum . 1))
+(test 'a '#%datum (#%datum . a))
+
+(syntax-test #'#%app)
+(syntax-test #'(#%app . 1))
+(syntax-test #'(#%app 2 . 1))
+(syntax-test #'(#%app lambda 1))
+(syntax-test #'(let ([#%app 5])
+		 (+ 1 2)))
+
+(test 3 '#%app (#%app + 1 2))
+(test null '#%app (#%app))
+
+(syntax-test #'#%top)
+(syntax-test #'(#%top 1))
+(syntax-test #'(let ([#%top 5])
+		 x))
+(err/rt-test (#%top . lambda) exn:fail:contract:variable?)
+(define x 5)
+(test 5 '#%top (#%top . x))
+
+(report-errs)
diff --git a/collects/tests/mzscheme/tcp.ss b/collects/tests/mzscheme/tcp.ss
new file mode 100644
index 0000000000..3a917a63d7
--- /dev/null
+++ b/collects/tests/mzscheme/tcp.ss
@@ -0,0 +1,59 @@
+
+(define id 40000)
+
+(define max-send 100000)
+(define print-mod 10000)
+
+(define (client host)
+  (lambda ()
+    (let-values ([(r w) (tcp-connect host id)])
+      (values r w void))))
+  
+(define server
+  (lambda ()
+    (let ([l (tcp-listen id)])
+      (let-values ([(r w) (tcp-accept l)])
+	(values r w (lambda () (tcp-close l)))))))
+
+(define (tread connect)
+  (let-values ([(r w close) (connect)])
+    (printf "Hit return to start reading~n")
+    (read-line)
+    (let loop ([last -1])
+      (let ([v (read r)])
+	(if (eof-object? v)
+	    (begin
+	      (close-input-port r)
+	      (close-output-port w)
+	      (close)
+	      last)
+	    (begin
+	      (unless (= v (add1 last))
+		(printf "skipped! ~a ~a~n" last v))
+	      (when (zero? (modulo v print-mod))
+		(printf "got ~a~n" v))
+	      (loop v)))))))
+
+(define (twrite connect)
+  (let-values ([(r w close) (connect)]
+	       [(t) (thread (lambda ()
+			      (let loop ()
+				(sleep 1)
+				(printf "tick~n")
+				(loop))))])
+    (let ([done (lambda ()
+		  (close-output-port w)
+		  (close-input-port r)
+		  (close)
+		  (kill-thread t))])
+      (let loop ([n 0])
+	(if (= n max-send)
+	    (begin
+	      (printf "stopped before ~a~n" n)
+	      (done))
+	    
+	    (begin
+	      (fprintf w "~s~n" n)
+	      (when (zero? (modulo n print-mod))
+		(printf "sent ~a~n" n))
+	      (loop (add1 n))))))))
diff --git a/collects/tests/mzscheme/testing.ss b/collects/tests/mzscheme/testing.ss
new file mode 100644
index 0000000000..3b9899c1d5
--- /dev/null
+++ b/collects/tests/mzscheme/testing.ss
@@ -0,0 +1,310 @@
+;;; `test.scm' Test correctness of MzScheme implementations.
+;;; Copyright (C) 1991, 1992, 1993, 1994 Aubrey Jaffer.
+;;; Modified for MzScheme by Matthew
+
+;;; MODIFIED for MzScheme - Matthew 8/95
+;;;  Added a few more tests, like append!, reverse!, etc.
+;;;  Added testing for inexact numbers
+;;;  Added a lot of error testing
+;;; modified for rational and complex numbers - Matthew 12/95
+;;; modified to test exceptions and more of MzScheme - Matthew 4/96
+;;; split into multiple files - Matthew 4/96
+;;; extended, extended, extended
+
+;;; This includes examples from
+;;; William Clinger and Jonathan Rees, editors.
+;;; Revised^4 Report on the Algorithmic Language Scheme
+;;; and the IEEE specification.
+
+; The format of the next line is important: file.ss relies on it
+(define cur-section '())(define errs '())
+
+#|
+
+The test form has these two shapes:
+
+  (test <expected> <procdure> <argument1> <argument2> ...)
+  
+  (test <expected> <symbolic-name> <expression>)
+
+In the first case, it applies the result of <procedure> 
+to the results of <argument1> etc and compares that (with equal?)
+to the result of the <expected>
+
+In the second case, it evaluates the <expression> and compares
+the results of that (with equal?) to the value of the
+<expected>. In this case, <symbolic-name> must evaluate to
+something that isn't a procedure. That name is used in the
+transcript.
+  
+|#
+
+
+
+(define teval eval)
+
+(namespace-variable-value 
+ 'building-flat-tests?
+ #f
+ (lambda ()
+   (namespace-set-variable-value! 'building-flat-tests? #f)))
+(namespace-variable-value 
+ 'in-drscheme?
+ #f
+ (lambda ()
+   (namespace-set-variable-value! 'in-drscheme? #f)))
+
+(define SECTION (lambda args
+		  (let ([ep (current-error-port)])
+		    (display "SECTION" ep) (write args ep) (newline ep)
+		    (set! cur-section args) #t)))
+(define record-error (lambda (e) (set! errs (cons (list cur-section e) errs))))
+
+(print-struct #t)
+
+(define number-of-tests 0)
+(define number-of-error-tests 0)
+(define number-of-exn-tests 0)
+
+(define test
+  (lambda (expect fun . args)
+    (set! number-of-tests (add1 number-of-tests))
+    (write (cons fun args))
+    (display "  ==> ")
+    (flush-output)
+    ((lambda (res)
+      (write res)
+      (newline)
+      (cond ((not (equal? expect res))
+	     (record-error (list res expect (cons fun args)))
+	     (display " BUT EXPECTED ")
+	     (write expect)
+	     (newline)
+	     #f)
+	    (else #t)))
+     (if (procedure? fun) (apply fun args) (car args)))))
+
+
+(define (nonneg-exact? x)
+  (and (exact? x)
+       (integer? x)
+       (x . >= . 0)))
+
+(define (pos-exact? x)
+  (and (exact? x)
+       (integer? x)
+       (positive? x)))
+
+(define exn-table
+  (list (cons exn? (cons exn-message string?))
+	(cons exn? (cons exn-continuation-marks continuation-mark-set?))
+	(cons exn:fail:contract:variable? (cons exn:fail:contract:variable-id symbol?))
+	(cons exn:fail:syntax? (cons exn:fail:syntax-exprs (lambda (x) (and (list? x) (andmap syntax? x)))))
+	
+	(cons exn:fail:read? (cons exn:fail:read-srclocs (lambda (x) (and (list? x) (andmap srcloc? x)))))))
+
+(define exn:application:mismatch? exn:fail:contract?)
+(define exn:application:type? exn:fail:contract?)
+(define exn:application:arity? exn:fail:contract:arity?)
+
+(define mz-test-syntax-errors-allowed? #t)
+
+(define thunk-error-test
+  (case-lambda 
+   [(th expr) (thunk-error-test th expr exn:application:type?)]
+   [(th expr exn?)
+    (set! expr (syntax-object->datum expr))
+    (set! number-of-error-tests (add1 number-of-error-tests))
+    (write expr)
+    (display "  =e=> ")
+    (call/ec (lambda (escape)
+	       (let* ([old-esc-handler (error-escape-handler)]
+		      [old-handler (current-exception-handler)]
+		      [orig-err-port (current-error-port)]
+		      [test-handler
+		       (lambda ()
+			 (escape #t))]
+		      [test-exn-handler
+		       (lambda (e)
+			 (when (and exn? (not (exn? e)))
+			       (printf " WRONG EXN TYPE: ~s " e)
+			       (record-error (list e 'exn-type expr)))
+			 (when (and (exn:fail:syntax? e)
+				    (not mz-test-syntax-errors-allowed?))
+			       (printf " LATE SYNTAX EXN: ~s " e)
+			       (record-error (list e 'exn-late expr)))
+
+			 (for-each
+			  (lambda (row)
+			    (let ([pred? (car row)])
+			      (when (pred? e)
+				    (set! number-of-exn-tests 
+					  (add1 number-of-exn-tests))
+				    (let ([sel (cadr row)]
+					  [pred? (cddr row)])
+				      (unless (pred? (sel e))
+					      (printf " WRONG EXN ELEM ~s: ~s " sel e)
+					      (record-error (list e (cons 'exn-elem sel) expr)))))))
+			  exn-table)
+						 
+			 (old-handler e))])
+		 (dynamic-wind
+		  (lambda () 
+		    (current-error-port (current-output-port))
+		    (current-exception-handler test-exn-handler)
+		    (error-escape-handler test-handler))
+		  (lambda ()
+		    (let ([v (th)])
+		      (write v)
+		      (display " BUT EXPECTED ERROR")
+		      (record-error (list v 'Error expr))
+		      (newline)
+		      #f))
+		  (lambda () 
+		    (current-error-port orig-err-port)
+		    (current-exception-handler old-handler)
+		    (error-escape-handler old-esc-handler))))))]))
+
+(namespace-variable-value
+ 'error-test 
+ #f
+ (lambda ()
+  (namespace-set-variable-value!
+   'error-test
+   (case-lambda 
+    [(expr) (error-test expr exn:application:type?)]
+    [(expr exn?)
+     (thunk-error-test (lambda () (eval expr)) expr exn?)]))))
+
+(require (rename mzscheme err:mz:lambda lambda)) ; so err/rt-test works with beginner.ss
+(define-syntax err/rt-test
+  (lambda (stx)
+    (syntax-case stx ()
+      [(_ e exn?)
+       (syntax
+	(thunk-error-test (err:mz:lambda () e) (quote-syntax e) exn?))]
+      [(_ e)
+       (syntax
+	(err/rt-test e exn:application:type?))])))
+  
+(define no-extra-if-tests? #f)
+
+(define (syntax-test expr)
+  (error-test expr exn:fail:syntax?)
+  (unless no-extra-if-tests?
+    (error-test (datum->syntax-object expr `(if #f ,expr) expr) exn:fail:syntax?)))
+
+(define arity-test 
+  (case-lambda
+   [(f min max except)
+    (letrec ([aok?
+	      (lambda (a)
+		(cond
+		 [(integer? a) (= a min max)]
+		 [(arity-at-least? a) (and (negative? max)
+					   (= (arity-at-least-value a) min))]
+		 [(and (list? a) (andmap integer? a))
+		  (and (= min (car a)) (= max
+					  (let loop ([l a])
+					    (if (null? (cdr l))
+						(car l)
+						(loop (cdr l))))))]
+		 [(list? a)
+		  ;; Just check that all are consistent for now.
+		  ;; This should be improved.
+		  (andmap
+		   (lambda (a)
+		     (if (number? a)
+			 (<= min a (if (negative? max) a max))
+			 (>= (arity-at-least-value a) min)))
+		   a)]
+		 [else #f]))]
+	     [make-ok?
+	      (lambda (v)
+		(lambda (e)
+		  (exn:application:arity? e)))]
+	     [do-test
+	      (lambda (f args check?)
+		(set! number-of-error-tests (add1 number-of-error-tests))
+		(printf "(apply ~s '~s)  =e=> " f args)
+		(let/ec done
+		  (let ([v (with-handlers ([void
+					    (lambda (exn)
+					      (if (check? exn)
+						  (printf " ~a~n" (exn-message exn))
+						  (let ([ok-type? (exn:application:arity? exn)])
+						    (printf " WRONG EXN ~a: ~s~n" 
+							    (if ok-type?
+								"FIELD"
+								"TYPE")
+							    exn)
+						    (record-error (list exn 
+									(if ok-type?
+									    'exn-field
+									    'exn-type)
+									(cons f args)))))
+					      (done (void)))])
+			     (apply f args))])
+		    (printf "~s~n BUT EXPECTED ERROR~n" v)
+		    (record-error (list v 'Error (cons f args))))))])
+      (let loop ([n 0][l '()])
+	(unless (>= n min)
+	  (unless (memq n except)
+	    (do-test f l (make-ok? n)))
+	  (loop (add1 n) (cons 1 l))))
+      (let loop ([n min])
+	(unless (memq n except)
+	  (test #t procedure-arity-includes? f n))
+	(unless (>= n max)
+	  (loop (add1 n))))
+      (if (>= max 0)
+	  (do-test f (let loop ([n 0][l '(1)])
+		       (if (= n max)
+			   l
+			   (loop (add1 n) (cons 1 l))))
+		   (make-ok? (add1 max)))
+	  (test #t procedure-arity-includes? f (arithmetic-shift 1 100))))]
+   [(f min max) (arity-test f min max null)]))
+
+(define (test-values l thunk)
+  (test l call-with-values thunk list))
+
+(define (report-errs)
+  (printf "~nPerformed ~a expression tests (~a good expressions, ~a bad expressions)~n"
+	  (+ number-of-tests number-of-error-tests)
+	  number-of-tests 
+	  number-of-error-tests)
+  (printf "and ~a exception field tests.~n~n" 
+	  number-of-exn-tests)
+  (if (null? errs) 
+      (display "Passed all tests.")
+      (begin
+	(display "Errors were:")
+	(newline)
+	(display "(SECTION (got expected (call)))")
+	(newline)
+	(for-each (lambda (l) (write l) (newline))
+		  errs)))
+  (newline)
+  (display "(Other messages report successful tests of error-handling behavior.)")
+  (newline))
+
+(define type? exn:application:type?)
+(define arity? exn:application:arity?)
+(define syntaxe? exn:fail:syntax?)
+
+(define non-z void)
+
+(define (find-depth go)
+  ; Find depth that triggers a stack overflow (assuming no other
+  ; threads are running and overflowing)
+  (let ([v0 (make-vector 6)]
+	[v1 (make-vector 6)])
+    (let find-loop ([d 100])
+      (vector-set-performance-stats! v0)
+      (go d)
+      (vector-set-performance-stats! v1)
+      (if (> (vector-ref v1 5)
+	     (vector-ref v0 5))
+	  d
+	  (find-loop (* 2 d))))))
diff --git a/collects/tests/mzscheme/thread.ss b/collects/tests/mzscheme/thread.ss
new file mode 100644
index 0000000000..19a15382e4
--- /dev/null
+++ b/collects/tests/mzscheme/thread.ss
@@ -0,0 +1,1141 @@
+
+
+(load-relative "loadtest.ss")
+
+(SECTION 'threads)
+
+(define SLEEP-TIME 0.1)
+
+;; ----------------------------------------
+
+(define t (thread (lambda () 8)))
+(test #t thread? t)
+
+(arity-test thread 1 1)
+(err/rt-test (thread 5) type?)
+(err/rt-test (thread (lambda (x) 8)) type?)
+(arity-test thread? 1 1)
+
+;; ----------------------------------------
+;; Thread sets
+
+(define (test-set-balance as bs cs ds
+			  sa sb sc sd
+			  a% b% c% d%)
+  (let ([a (box 0)]
+	[b (box 0)]
+	[c (box 0)]
+	[d (box 0)]
+	[stop? #f])
+    
+    (define (go box s s-amt)
+      (parameterize ([current-thread-group s])
+	(thread (lambda ()
+		  (let loop ()
+		    (set-box! box (add1 (unbox box)))
+		    (sleep s-amt)
+		    (unless stop?
+		      (loop)))))))
+    
+    (go a as sa)
+    (go b bs sb)
+    (go c cs sc)
+    (go d ds sd)
+
+    (sleep SLEEP-TIME)
+
+    (set! stop? #t)
+
+    (let ([va (/ (unbox a) a%)]
+	  [vb (unbox b)]
+	  [vc (unbox c)]
+	  [vd (unbox d)])
+      (define (roughly= x y)
+	(<= (* (- x 1) 0.9) y (* (+ x 1) 1.1)))
+
+      (test #t roughly= vb (* b% va))
+      (test #t roughly= vc (* c% va))
+      (test #t roughly= vd (* d% va)))))
+
+;; Simple test:
+(let ([ts (make-thread-group)])
+  (test-set-balance (current-thread-group) ts ts ts
+		    0 0 0 0
+		    1 1/3 1/3 1/3))
+
+;; Make two sets, should be balanced:
+(let ([ts1 (make-thread-group)]
+      [ts2 (make-thread-group)])
+  (test-set-balance ts1 ts2 ts2 ts1
+		    0 0 0 0
+		    1 1 1 1))
+
+;; Like first test, but with an explicit "root" set
+(let* ([ts1 (make-thread-group)]
+       [ts2 (make-thread-group ts1)])
+  (test-set-balance ts1 ts2 ts2 ts2
+		    0 0 0 0
+		    1 1/3 1/3 1/3))
+
+;; Like second test, but with an explicit "root" set
+(let* ([ts0 (make-thread-group)]
+       [ts1 (make-thread-group ts0)]
+       [ts2 (make-thread-group ts0)])
+  (test-set-balance ts1 ts2 ts2 ts1
+		    0 0 0 0
+		    1 1 1 1))
+
+;; Check that suspended threads don't break
+;;  scheduling. (The test really continues past this
+;;  one, since the threads don't die right away.)
+(let* ([ts0 (make-thread-group)]
+       [ts1 (make-thread-group ts0)]
+       [ts2 (make-thread-group ts0)])
+  (test-set-balance ts1 ts2 ts2 ts1
+		    0 0 (* SLEEP-TIME 10) (* SLEEP-TIME 10)
+		    1 1 0 0))
+
+(arity-test make-thread-group 0 1)
+(err/rt-test (make-thread-group 5) type?)
+(arity-test thread-group? 1 1)
+(test #t thread-group? (make-thread-group))
+(test #f thread-group? 5)
+(arity-test current-thread-group 0 1)
+(err/rt-test (current-thread-group 5))
+
+;; ----------------------------------------
+
+; Should be able to make an arbitrarily deep chain of custodians
+; if only the first & last are accssible:
+(test #t custodian?
+      (let loop ([n 1000][c (current-custodian)])
+	(if (zero? n)
+	    c
+	    (loop (sub1 n) (make-custodian c)))))
+
+(define result 0)
+(define th1 0)
+(define set-ready
+  (let ([s (make-semaphore 1)]
+	[r #f])
+    (lambda (v)
+      (semaphore-wait s)
+      (begin0
+       r
+       (set! r v)
+       (semaphore-post s)))))
+(define cm (make-custodian))
+(define th2 (parameterize ([current-custodian cm])
+              (thread 
+	       (lambda ()
+		 (let ([cm2 (make-custodian cm)])
+		   (parameterize ([current-custodian cm2])
+		      (set! th1 (thread 
+				 (lambda ()
+				   (let loop ()
+				     (let ([r (set-ready #f)])
+				       (sleep SLEEP-TIME)
+				       (set! result (add1 result))
+				       (when r (semaphore-post r)))
+				     (loop)))))))))))
+(define start result)
+(let ([r (make-semaphore)])
+  (set-ready r)
+  (semaphore-wait r))
+(test #f eq? start result)
+(kill-thread th2)
+(set! start result)
+(let ([r (make-semaphore)])
+  (set-ready r)
+  (semaphore-wait r))
+(test #f eq? start result)
+(test #t thread-running? th1)
+(test #f thread-dead? th1)
+(custodian-shutdown-all cm)
+(thread-wait th1)
+(set! start result)
+(test #f thread-running? th1)
+(test #t thread-dead? th1)
+(sleep SLEEP-TIME)
+(test #t eq? start result)
+
+(let ([kept-going? #f])
+  (let ([c (make-custodian)])
+    (parameterize ([current-custodian c])
+     (thread-wait
+      (thread
+       (lambda ()
+	 (custodian-shutdown-all c)
+	 (set! kept-going? #t))))))
+  (test #f 'kept-going-after-shutdown? kept-going?))
+
+(err/rt-test (parameterize ([current-custodian cm]) (kill-thread (current-thread)))
+	     exn:application:mismatch?)
+
+(test #t custodian? cm)
+(test #f custodian? 1)
+(arity-test custodian? 1 1)
+
+(arity-test custodian-shutdown-all 1 1)
+(err/rt-test (custodian-shutdown-all 0))
+
+(arity-test make-custodian 0 1)
+(err/rt-test (make-custodian 0))
+
+(test (void) kill-thread t)
+(arity-test kill-thread 1 1)
+(err/rt-test (kill-thread 5) type?)
+
+(arity-test break-thread 1 1)
+(err/rt-test (break-thread 5) type?)
+
+(arity-test thread-wait 1 1)
+(err/rt-test (thread-wait 5) type?)
+
+(test #t thread-running? (current-thread))
+(arity-test thread-running? 1 1)
+(err/rt-test (thread-running? 5) type?)
+
+(test #f thread-dead? (current-thread))
+(arity-test thread-dead? 1 1)
+(err/rt-test (thread-dead? 5) type?)
+
+(arity-test sleep 0 1)
+(err/rt-test (sleep 'a) type?)
+(err/rt-test (sleep 1+3i) type?)
+(err/rt-test (sleep -1.0) type?)
+
+(define s (make-semaphore 1))
+
+(test #t semaphore? s)
+
+(arity-test make-semaphore 0 1)
+(err/rt-test (make-semaphore "a") type?)
+(err/rt-test (make-semaphore -1) type?)
+(err/rt-test (make-semaphore 1.0) type?)
+(err/rt-test (make-semaphore (expt 2 64)) exn:fail?)
+(arity-test semaphore? 1 1)
+
+(define test-block
+  (lambda (block? thunk)
+    (let* ([hit? #f]
+	   [t (parameterize ([current-custodian (make-custodian)])
+		(thread (lambda () (thunk) (set! hit? #t))))])
+      (sleep SLEEP-TIME)
+      (begin0 (test block? 'nondeterministic-block-test (not hit?))
+	      (kill-thread t)))))
+
+(test #t semaphore-try-wait? s) 
+(test #f semaphore-try-wait? s) 
+(semaphore-post s) 
+(test #t semaphore-try-wait? s) 
+(test #f semaphore-try-wait? s) 
+(semaphore-post s) 
+(test-block #f (lambda () (semaphore-wait s)))
+(test-block #t (lambda () (semaphore-wait s)))
+(semaphore-post s) 
+(test-block #f (lambda () (semaphore-wait/enable-break s)))
+(test-block #t (lambda () (semaphore-wait/enable-break s)))
+
+(arity-test semaphore-try-wait? 1 1)
+(arity-test semaphore-wait 1 1)
+(arity-test semaphore-post 1 1)
+
+(define s (make-semaphore))
+(define result 0)
+(define t-loop
+  (lambda (n m)
+    (lambda ()
+      (if (zero? n)
+	  (begin
+	    (set! result m)
+	    (semaphore-post s))
+	  (thread (t-loop (sub1 n) (add1 m)))))))
+(thread (t-loop 25 1))
+(semaphore-wait s)
+(test 26 'thread-loop result)
+
+; Make sure you can break a semaphore-wait:
+'(test 'ok
+      'break-semaphore-wait
+      (let* ([s1 (make-semaphore 0)]
+	     [s2 (make-semaphore 0)]
+	     [t (thread (lambda ()
+			  (semaphore-post s1)
+			  (with-handlers ([exn:break? (lambda (x) (semaphore-post s2))])
+			    (semaphore-wait (make-semaphore 0)))))])
+	(semaphore-wait s1)
+	(sleep SLEEP-TIME)
+	(break-thread t)
+	(semaphore-wait s2)
+	'ok))
+
+; Make sure two waiters can be released
+(test 'ok
+      'double-semaphore-wait
+      (let* ([s1 (make-semaphore 0)]
+	     [s2 (make-semaphore 0)]
+	     [go (lambda ()
+		   (semaphore-post s2)
+		   (semaphore-wait s1)
+		   (semaphore-post s2))])
+	(thread go) (thread go)
+	(semaphore-wait s2) (semaphore-wait s2)
+	(semaphore-post s1) (semaphore-post s1)
+	(semaphore-wait s2) (semaphore-wait s2)
+	'ok))
+
+; Tests inspired by a question from David Tillman
+(define (read-line/expire1 port expiration)
+  (with-handlers ([exn:break? (lambda (exn) #f)])
+    (let ([timer (thread (let ([id (current-thread)])
+			   (lambda () 
+			     (sleep expiration)
+			     (break-thread id))))])
+      (dynamic-wind
+       void
+       (lambda () (read-line port))
+       (lambda () (kill-thread timer))))))
+(define (read-line/expire2 port expiration)
+  (let ([done (make-semaphore 0)]
+	[result #f])
+    (let ([t1 (thread (lambda () 
+			(set! result (read-line port))
+			(semaphore-post done)))]
+	  [t2 (thread (lambda () 
+			(sleep expiration)
+			(semaphore-post done)))])
+      (semaphore-wait done)
+      (kill-thread t1)
+      (kill-thread t2)
+      result)))
+;; the main thread is special for semaphore blocking,
+;;  so we try read-line/expire1 in sub-threads for a couple
+;;  of configurations:
+(define (read-line/expire3 port expiration)
+  (call-in-nested-thread (lambda ()
+			   (read-line/expire1 port expiration))))
+(define (read-line/expire4 port expiration)
+  (let ([v #f])
+    (let ([t (thread (lambda ()
+		       (set! v (read-line/expire1 port expiration))))])
+      (thread-wait t)
+      v)))
+
+(define (go read-line/expire)
+  (define p (let ([c 0]
+		  [nl-sema (make-semaphore 1)]
+		  [ready? #f]
+		  [nl? #f])
+	      (make-input-port
+	       'read-line/expire
+	       (lambda (s) 
+		 (let ([c (if nl?
+			      (if ready?
+				  #\newline
+				  (wrap-evt nl-sema
+					       (lambda (x) 0)))
+			      (begin
+				(set! nl? #t)
+				(semaphore-try-wait? nl-sema)
+				(set! ready? #f)
+				(thread (lambda ()
+					  (sleep 0.4)
+					  (set! ready? #t)
+					  (semaphore-post nl-sema)))
+				(set! c (add1 c))
+				(integer->char c)))])
+		   (if c
+		       (if (char? c)
+			   (begin
+			     (bytes-set! s 0 (char->integer c))
+			     1)
+			   c)
+		       0)))
+	       #f
+	       void)))
+  (test #f read-line/expire p 0.2) ; should get char but not newline
+  (test "" read-line/expire p 0.6)) ; picks up newline
+
+(go read-line/expire1)
+(go read-line/expire2)
+(go read-line/expire3)
+(go read-line/expire4)
+
+;; Make sure queueing works, and check kill/wait interaction:
+(let* ([s (make-semaphore)]
+       [l null]
+       [wait (lambda (who)
+	       (thread
+		(lambda ()
+		  (semaphore-wait s)
+		  (set! l (cons who l)))))]
+       [pause (lambda () (sleep 0.01))])
+  (wait 0) (pause)
+  (wait 1) (pause)
+  (wait 2)
+  (pause)
+  (test null 'queue l)
+  (semaphore-post s) (pause)
+  (test '(0) 'queue l)
+  (semaphore-post s) (pause)
+  (test '(1 0) 'queue l)
+  (semaphore-post s) (pause)
+  (test '(2 1 0) 'queue l)
+  
+  (set! l null)
+  (wait 0) (pause)
+  (let ([t (wait 1)])
+    (pause)
+    (wait 2)
+    (pause)
+    (test null 'queue l)
+    (kill-thread t)
+    (semaphore-post s) (pause)
+    (test '(0) 'queue l)
+    (semaphore-post s) (pause)
+    (test '(2 0) 'queue l)
+    (semaphore-post s) (pause)
+    (test '(2 0) 'queue l)
+    (wait 3) (pause)
+    (test '(3 2 0) 'queue l)))
+
+;; Nested threads
+(test 5 call-in-nested-thread (lambda () 5))
+
+(define (exn:thread? e)
+  (and (exn:fail? e) (not (exn:fail:contract? e))))
+
+(err/rt-test (call-in-nested-thread (lambda () (kill-thread (current-thread)))) exn:thread?)
+(err/rt-test (call-in-nested-thread (lambda () ((error-escape-handler)))) exn:thread?)
+(err/rt-test (call-in-nested-thread (lambda () (raise (box 5)))) box?)
+
+(define output-stream null)
+(define (output v)
+  (set! output-stream 
+	(append output-stream (list v))))
+(define (test-stream v)
+  (test v 'output-stream output-stream))
+
+(define (chain c)
+  (define c1 (make-custodian))
+  (define c2 (make-custodian))
+  (define c3 (make-custodian))
+
+
+  (set! output-stream null)
+  
+  (output 'os)
+  (with-handlers ([void (lambda (x) x)])
+    (call-in-nested-thread
+     (lambda ()
+       (output 'ms)
+       (begin0
+	(dynamic-wind
+	 (lambda () (output 'mpre))
+	 (lambda ()
+	   (let ([t1 (current-thread)])
+	     (call-in-nested-thread
+	      (lambda ()
+		(output 'is)
+		(with-handlers ([void (lambda (x) 
+					(if (exn:break? x)
+					    (output 'ibreak)
+					    (output 'iother))
+					(raise x))])
+		  (let ([get-c (lambda (c)
+				 (case c
+				   [(1) c1]
+				   [(2) c2]
+				   [(3) c3]
+				   [else c]))])
+		    (if (procedure? c)
+			(c t1 get-c)
+			(custodian-shutdown-all (get-c c)))))
+		(output 'ie)
+		'inner-result)
+	      c2)))
+	 (lambda () (output 'mpost)))
+	(output 'me)))
+     c1)))
+
+(test 'inner-result chain 3)
+(test-stream '(os ms mpre is ie mpost me))
+
+(test #t exn:thread? (chain 1))
+(test-stream '(os ms mpre is ibreak))
+
+(parameterize-break #f
+  (test #t exn:thread? (chain 1))
+  (test-stream '(os ms mpre is ie))
+  (test (void) 'discard-break
+	(with-handlers ([void void])
+	  (break-enabled #t)
+	  (sleep)
+	  'not-void)))
+
+(test #t exn:thread? (chain 2))
+(test-stream '(os ms mpre is mpost))
+
+(test #t exn:thread? (chain (lambda (t1 get-c) (kill-thread (current-thread)))))
+(test-stream '(os ms mpre is mpost))
+
+(test #t exn:fail:contract? (chain 'wrong))
+(test-stream '(os ms mpre is iother mpost))
+
+(test #t exn:break? (chain (let ([t (current-thread)]) (lambda (t1 get-c) (break-thread t)))))
+(test-stream '(os ms mpre is ibreak mpost))
+
+(test #t exn:thread? (chain (lambda (t1 get-c) (kill-thread t1))))
+(test-stream '(os ms mpre is ibreak))
+
+(parameterize-break #f
+  (test #t exn:thread? (let ([t (current-thread)])
+			 (chain (lambda (t1 get-c)
+				  (custodian-shutdown-all (get-c 1))
+				  (test #t thread-running? (current-thread))
+				  (test #t thread-running? t)
+				  (test #f thread-running? t1)))))
+  (test-stream '(os ms mpre is ie))
+  (test (void) 'discard-break
+	(with-handlers ([void void])
+	  (break-enabled #t)
+	  (sleep)
+	  'not-void)))
+
+(err/rt-test (let/cc k (call-in-nested-thread (lambda () (k)))) exn:fail:contract:continuation?)
+(err/rt-test (let/ec k (call-in-nested-thread (lambda () (k)))) exn:fail:contract:continuation?)
+(err/rt-test ((call-in-nested-thread (lambda () (let/cc k k)))) exn:fail:contract:continuation?)
+(err/rt-test ((call-in-nested-thread (lambda () (let/ec k k)))) exn:fail:contract:continuation?)
+
+(err/rt-test (call-in-nested-thread 5))
+(err/rt-test (call-in-nested-thread (lambda (x) 10)))
+(err/rt-test (call-in-nested-thread (lambda () 10) 5))
+
+(arity-test call-in-nested-thread 1 2)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Test wait-multiple:
+
+(let ([s (make-semaphore 1)]
+      [s2 (make-semaphore 1)])
+  (let ([w (list
+	    (sync s s2)
+	    (sync s s2))])
+    (test #t 'both (or (equal? w (list s s2))
+		       (equal? w (list s2 s))))
+    (test #f semaphore-try-wait? s)
+    (test #f semaphore-try-wait? s2)))
+
+;; same test, but throw in an empty pipe to avoid the
+;;  special case for just semaphores:
+(let ([s (make-semaphore 1)]
+      [s2 (make-semaphore 1)])
+  (let-values ([(r w) (make-pipe)])
+    (let ([w (list
+	      (sync s r s2)
+	      (sync s r s2))])
+      (test #t 'both (or (equal? w (list s s2))
+			 (equal? w (list s2 s))))
+      (test #f semaphore-try-wait? s)
+      (test #f semaphore-try-wait? s2))))
+
+(let ([s (make-semaphore)]
+      [s-t (make-semaphore)]
+      [portnum (+ 40000 (random 100))]) ; so parallel tests work ok
+  (let ([t (thread
+	    (lambda ()
+	      (sync s-t)))]
+	[l (tcp-listen portnum 5 #t)]
+	[orig-thread (current-thread)])
+    (let-values ([(r w) (make-pipe)])
+      
+      (define (try-all-blocked* wait)
+	(let ([v #f])
+	  (let ([bt (thread
+		     (lambda ()
+		       (with-handlers ([exn:break? (lambda (x) (set! v 'break))])
+			 (set! v (wait #f s t l r)))))])
+	    (sleep 0.05) ;;;     <---------- race condition (that's unlikely to fail)
+	    (break-thread bt)
+	    (sleep 0.05) ;;;     <----------
+	    )
+	  (test 'break 'broken-wait v)))
+
+      (define (try-all-blocked)
+	(test #f sync/timeout 0.05 s t l r))
+
+      (try-all-blocked* sync/timeout)
+      (try-all-blocked* sync/timeout/enable-break)
+      (parameterize-break #f
+	(try-all-blocked* sync/timeout/enable-break))
+
+      (display #\x w)
+      (test r sync s t l r)
+      (test r sync s t l r)
+      (peek-char r)
+      (test r sync s t l r)
+      (read-char r)
+      (try-all-blocked)
+	  
+      ;; pipe write always available, since no limit:
+      (test w sync s t l r w)
+
+      (semaphore-post s)
+      (test s sync s t l r)
+      (try-all-blocked)
+
+      (semaphore-post s-t)
+      (test t sync s t l r)
+      (test t sync s t l r)
+
+      (set! t (thread (lambda () (semaphore-wait (make-semaphore)))))
+
+      (let-values ([(cr cw) (tcp-connect "localhost" portnum)])
+	(test l sync s t l r)
+	(test l sync s t l r)
+
+	(let-values ([(sr sw) (tcp-accept l)])
+	  (try-all-blocked)
+
+	  (close-output-port w)
+	  (test r sync s t l r)
+	  (test r sync s t l r)
+
+	  (set! r cr)
+	  (try-all-blocked)
+
+	  (display #\y sw)
+	  (flush-output sw)
+	  (test cr sync s t l sr cr)
+	  (read-char cr)
+	  (try-all-blocked)
+	  (test sw sync s t l sr cr sw)
+	  
+	  (display #\z cw)
+	  (flush-output cw)
+	  (test sr sync s t l sr cr)
+	  (read-char sr)
+	  (try-all-blocked)
+	  (test cw sync s t l sr cr cw)
+
+	  ;; Fill up output buffer:
+	  (test sw sync/timeout 0 sw)
+	  (test #t
+		positive?
+		(let loop ([n 0])
+		  (if (and (sync/timeout 0 sw)
+			   (= 4096 (write-bytes-avail (make-bytes 4096 (char->integer #\x)) sw)))
+		      (loop (add1 n))
+		      n)))
+	  (test #f sync/timeout 0 sw sr)
+	  (test cr sync/timeout 0 sw sr cr)
+	  ;; Flush cr:
+	  (let ([s (make-bytes 4096)])
+	    (let loop ()
+	      (when (and (char-ready? cr)
+			 (= 4096 (read-bytes-avail! s cr)))
+		(loop))))
+
+	  (close-output-port sw)
+	  (test cr sync s t l sr cr)
+	  (test cr sync s t l sr cr)
+
+	  (close-output-port cw)
+	  (test sr sync s t l sr))))
+    (tcp-close l)))
+
+;; Test limited pipe output waiting:
+(let-values ([(r w) (make-pipe 5000)])
+  (test #f sync/timeout 0 r)
+  (test w sync/timeout 0 r w)
+  (display (make-bytes 4999 (char->integer #\x)) w)
+  (test w sync/timeout 0 w)
+  (display #\y w)
+  (test #f sync/timeout 0 w)
+  (test 0 write-bytes-avail* #"hello" w)
+  (test r sync/timeout 0 r w)
+  (read-char r)
+  (test w sync/timeout 0 w)
+  (display #\z w)
+  (test #f sync/timeout 0 w)
+  (read-bytes 5000 r)
+  (test #f sync/timeout 0 r)
+  (test w sync/timeout 0 r w)
+  (display (make-bytes 5000 (char->integer #\x)) w)
+  (test r sync/timeout 0 r w)
+  (test #f sync/timeout 0 w))
+
+;; ----------------------------------------
+;; Suspend and resume
+
+;; Suspend main thread:
+(let ([v 17]
+      [s (make-semaphore)]
+      [t (current-thread)])
+  (let ([t2 (thread (lambda () 
+		      (thread-suspend t)
+		      (test #f thread-running? t)
+		      (test #f thread-dead? t)
+		      (semaphore-post s)
+		      (sleep SLEEP-TIME)
+		      (test 17 values v)
+		      (thread-resume t)))])
+    (semaphore-wait s)
+    (set! v 99)
+    (thread-wait t2)))
+
+;; Self-suspend main thread:
+(let ([v 19]
+      [t (current-thread)])
+  (let ([t2 (thread (lambda () 
+		      (sleep SLEEP-TIME)
+		      (test 19 values v)
+		      (thread-resume t)))])
+    (thread-suspend t)
+    (set! v 99)
+    (thread-wait t2)))
+
+;; Self-suspend child thread:
+(let ([v 20])
+  (let ([t2 (thread (lambda () 
+		      (thread-suspend (current-thread))
+		      (set! v 99)))])
+    (sleep SLEEP-TIME)
+    (test #f thread-running? t2)
+    (test #f thread-dead? t2)
+    (thread-resume t2)
+    (test 20 values v)
+    (thread-wait t2)
+    (test #f thread-running? t2)
+    (test #t thread-dead? t2)
+    (test 99 values v)))
+
+;; Suspend child thread:
+(let ([v 17]
+      [s (make-semaphore)]
+      [t (current-thread)])
+  (let ([t2 (thread (lambda () 
+		      (semaphore-wait s)
+		      (set! v 99)))])
+    (thread-suspend t2)
+    (test #f thread-dead? t2)
+    (test #f thread-running? t2)
+    (semaphore-post s)
+    (sleep SLEEP-TIME)
+    (test 17 values v)
+    (thread-resume t2)
+    (thread-wait t2)
+    (test #f thread-running? t2)
+    (test #t thread-dead? t2)
+    (test 99 values v)))
+
+;; Breaking/killing:
+(define /dev/null-for-err
+  (make-output-port 'dev/null always-evt (lambda (s start end ? ??) (- end start)) void void))
+(for-each
+ (lambda (sleep0)
+   (test (list 'start-sleep0 sleep0) values (list 'start-sleep0 sleep0))
+   (let ([goes
+	  (lambda (sleep1 sleep2 break-thread)
+	    (test (list 'start-goes sleep1 sleep2 break-thread) values (list 'start-goes sleep1 sleep2 break-thread))
+	    (test 'external-suspend values 'external-suspend)
+	    (let ([v 10])
+	      (let ([t2 (parameterize ([current-error-port /dev/null-for-err])
+			  (thread
+			   (lambda () 
+			     (let loop () (when (= v 10) (sleep) (loop)))
+			     (sleep0)
+			     (set! v 99))))])
+		(sleep1)
+		(thread-suspend t2)
+		(set! v 20)
+		(test (void) break-thread t2)
+		(sleep2)
+		(test (void) thread-resume t2)
+		(test (void) thread-wait t2)
+		(test 20 values v)))
+	    (test 'self-suspend values 'self-suspend)
+	    (let ([v 20])
+	      (let ([t2 (parameterize ([current-error-port /dev/null-for-err])
+			  (thread (lambda () 
+				    (thread-suspend (current-thread))
+				    (sleep0)
+				    (set! v 99))))])
+		(sleep1)
+		(break-thread t2)
+		(sleep2)
+		;; keep trying to resume until the thread stops:
+		(let loop ()
+		  (unless (sync/timeout 0 t2)
+		    (thread-resume t2)
+		    (loop)))
+		(thread-wait t2)
+		(test 20 values v)))
+	    (let ([w-block
+		   (lambda (post wait)
+		     (test (list 'start-w-block post wait) values (list 'start-w-block post wait))
+		     ;; Child thread sleeps
+		     (let ([v 20])
+		       (let ([t2 (parameterize ([current-error-port /dev/null-for-err])
+				   (thread (lambda () 
+					     (wait)
+					     (sleep0)
+					     (set! v 99)
+					     (fprintf (current-error-port) "Thread shouldn't get here! ~a~n" (break-enabled)))))])
+			 (sleep1)
+			 (thread-suspend t2)
+			 (post)
+			 (sleep2)
+			 (break-thread t2)
+			 (sleep2)
+			 (thread-resume t2)
+			 (thread-wait t2)
+			 (test 20 values v)))
+		     (unless (eq? break-thread kill-thread)
+		       (wait)
+		       ;; Main thread sleeps
+		       (let ([v 25]
+			     [t (current-thread)]
+			     [done (make-semaphore)])
+			 (with-handlers ([exn:break?
+					  (lambda (x) (semaphore-post done))])
+			   (let ([t2 (thread (lambda () 
+					       (sleep1)
+					       (thread-suspend t)
+					       (post)
+					       (sleep2)
+					       (break-thread t)
+					       (sleep2)
+					       (thread-resume t)
+					       (semaphore-wait done)
+					       (test 25 values v)))])
+			     (wait)
+			     (sleep0)
+			     (set! v 99)
+			     (fprintf (current-error-port) "Shouldn't get here! ~a~n" (break-enabled)))))))])
+	      (test 'sema-block values 'sema-block)
+	      (let ([s (make-semaphore)])
+		(w-block (lambda () (semaphore-post s))
+			 (lambda () (semaphore-wait s))))
+	      (for-each
+	       (lambda (init)
+		 (test (list 'sema-block/enable-break init) values (list 'sema-block/enable-break init))
+		 (let ([s (make-semaphore)])
+		   (parameterize-break init
+		     (w-block (lambda () (semaphore-post s))
+			      (lambda () (semaphore-wait/enable-break s))))))
+	       '(#t #f))
+	      (test 'ch-block values 'ch-block)
+	      (let ([ch (make-channel)])
+		(w-block (lambda () (thread (lambda () (channel-put ch 10))))
+			 (lambda () (sync (make-semaphore) ch))))
+	      (for-each
+	       (lambda (init)
+		 (test (list 'ch-block/enable-break init) values (list 'ch-block/enable-break init))
+		 (let ([ch (make-channel)])
+		   (parameterize-break #f
+		     (w-block (lambda () (thread (lambda () (channel-put ch 10))))
+			      (lambda () (sync/timeout/enable-break #f (make-semaphore) ch))))))
+	       '(#t #f))))])
+     (define BKT-SLEEP-TIME (/ SLEEP-TIME 4))
+     (goes void void break-thread)
+     (goes void void kill-thread)
+     (goes sleep void break-thread)
+     (goes sleep void kill-thread)
+     (goes void sleep break-thread)
+     (goes void sleep kill-thread)
+     (goes sleep sleep break-thread)
+     (goes sleep sleep kill-thread)
+     (goes (lambda () (sleep BKT-SLEEP-TIME)) void break-thread)
+     (goes (lambda () (sleep BKT-SLEEP-TIME)) void kill-thread)
+     (goes void (lambda () (sleep BKT-SLEEP-TIME)) break-thread)
+     (goes void (lambda () (sleep BKT-SLEEP-TIME)) kill-thread)
+     (goes (lambda () (sleep BKT-SLEEP-TIME)) (lambda () (sleep BKT-SLEEP-TIME)) break-thread)
+     (goes (lambda () (sleep BKT-SLEEP-TIME)) (lambda () (sleep BKT-SLEEP-TIME)) kill-thread)))
+ (list sleep void))
+
+;; ----------------------------------------
+;;  Simple multi-custodian threads
+
+(let ([go
+       (lambda (1st1st? derived?)
+	 (let* ([c1 (make-custodian)]
+		[c2 (make-custodian (if derived? c1 (current-custodian)))])
+	   (let ([t (parameterize ([current-custodian c1])
+		      (thread (lambda () (sleep 1000))))])
+	     (test #t thread-running? t)
+	     (thread-resume t c2)
+	     (test #t thread-running? t)
+	     (custodian-shutdown-all (if 1st1st? c1 c2))
+	     (test (not (and derived? 1st1st?)) thread-running? t)
+	     (custodian-shutdown-all (if 1st1st? c1 c2))
+	     (test (not (and derived? 1st1st?)) thread-running? t)
+	     (custodian-shutdown-all (if 1st1st? c2 c1))
+	     (test #f thread-running? t))))])
+  (go #t #f)
+  (go #f #f)
+  (go #t #t)
+  (go #f #t))
+
+;; Test collapsing custodians for resume
+(let* ([c0 (make-custodian)]
+       [c1 (make-custodian c0)]
+       [c2 (make-custodian c0)]
+       [c3 (make-custodian c0)])
+  (let ([t (parameterize ([current-custodian c1])
+	     (thread (lambda () (sleep 1000))))])
+    (thread-resume t c2)
+    (thread-resume t c3)
+    (thread-resume t c0)
+    (custodian-shutdown-all c0)
+    (test #f thread-running? t)))
+	     
+;; ----------------------------------------
+;; Kill versus Suspend
+
+(let* ([v 0]
+       [loop (lambda ()
+	       (let loop ()
+		 (set! v (add1 v))
+		 (sleep (/ SLEEP-TIME 2))
+		 (loop)))]
+       [c0 (make-custodian)])
+  (let ([try
+	 (lambda (resumable?)
+	   (let* ([c (parameterize ([current-custodian c0])
+		       (make-custodian))]
+		  [t (parameterize ([current-custodian c])
+		       ((if resumable? thread/suspend-to-kill thread) loop))]
+		  [check-inc (lambda (inc?)
+			       (let ([v0 v]) 
+				 (sleep SLEEP-TIME)
+				 (test inc? > v v0)))])
+	     (test #t thread-running? t)
+	     (check-inc #t)
+	     (custodian-shutdown-all c)
+	     (test #f thread-running? t)
+	     (test (not resumable?) thread-dead? t)
+	     (test (and resumable? t) sync/timeout 0 (thread-suspend-evt t))
+	     (check-inc #f)
+	     (let ([r (thread-resume-evt t)])
+	       (test #f sync/timeout 0 r)
+	       (set! c (make-custodian))
+	       (thread-resume t c)
+	       (test (and resumable? t) sync/timeout 0 r))
+	     (test resumable? thread-running? t)
+	     (when resumable?
+	       (check-inc #t)
+	       (custodian-shutdown-all c)
+	       (test #f thread-running? t)
+	       (test #f thread-dead? t)
+	       (check-inc #f)
+	       (set! c (make-custodian))
+	       (thread-resume t c)
+	       (test #t thread-running? t)
+	       (check-inc #t)
+	       (kill-thread t)
+	       (test #f thread-running? t)
+	       (test #f thread-dead? t)
+	       (check-inc #f)
+	       (thread-resume t)
+	       (check-inc #t)
+	       (custodian-shutdown-all c)
+	       (thread-wait
+		(parameterize ([current-custodian c0])
+		  (thread (lambda () (thread-resume t (current-thread))))))
+	       (check-inc #t)
+	       (custodian-shutdown-all c)
+	       (test #t thread-running? t)
+	       (check-inc #t)
+	       (set! c (make-custodian))
+	       (thread-resume t c)
+	       (custodian-shutdown-all c)
+	       (test #t thread-running? t)
+	       (check-inc #t)
+	       (custodian-shutdown-all c0)
+	       (check-inc #f)
+	       (thread-resume t (current-thread))
+	       (check-inc #t)
+	       (custodian-shutdown-all c)
+	       (test #t thread-running? t)
+	       (check-inc #t)
+	       (kill-thread t)
+	       (check-inc #f))))])
+    (try #f)
+    (try #t)))
+
+;; Transitive resume:
+(let ([go
+       (lambda (thread c-suspend?)
+	 (parameterize ([current-custodian (make-custodian)])
+	   (letrec ([setup-transitive
+		     (lambda (t depth)
+		       (if (= depth 0)
+			   null
+			   (let ([t1 (thread (lambda () (sleep 1000)))]
+				 [t2 (thread (lambda () (semaphore-wait (make-semaphore))))])
+			     (thread-resume t1 t)
+			     (thread-resume t2 t)
+			     (append
+			      (setup-transitive t1 (sub1 depth))
+			      (setup-transitive t2 (sub1 depth))
+			      (list t1 t2)))))])
+	     (let ([t (thread (lambda () (sleep 10000)))])
+	       (let ([threads (cons t (setup-transitive t 5))])
+		 (for-each (lambda (t)
+			     (test #t thread-running? t))
+			   threads)
+		 (if c-suspend?
+		     (custodian-shutdown-all (current-custodian))
+		     (for-each thread-suspend threads))
+		 (for-each (lambda (t)
+			     (test #f thread-running? t))
+			   threads)
+		 (test (void) thread-resume t)
+		 (for-each (lambda (t)
+			     (test (not c-suspend?) thread-running? t))
+			   threads)))
+	     (custodian-shutdown-all (current-custodian)))))])
+  (go thread #f)
+  (go thread/suspend-to-kill #t)
+  (go thread/suspend-to-kill #f))
+
+(let ([t1 (thread (lambda () (semaphore-wait (make-semaphore))))]
+      [t2 (thread (lambda () (semaphore-wait (make-semaphore))))]
+      [t3 (thread (lambda () (semaphore-wait (make-semaphore))))])
+  (test (void) thread-resume t2 t1)
+  (test (void) thread-resume t3 t2)
+  (thread-suspend t1)
+  (thread-suspend t3)
+  (test #f thread-running? t1)
+  (test #t thread-running? t2)
+  (test #f thread-running? t3)
+  (thread-resume t1)
+  ;; Thread t3 should not have been resumed...
+  (test #f thread-running? t3)
+  (thread-resume t2)
+  ;; Still, thread t3 should not have been resumed...
+  (test #f thread-running? t3)
+  (thread-suspend t2)
+  (thread-resume t2)
+  ;; Now it should be resumed!
+  (test #t thread-running? t3)
+  (kill-thread t3)
+  (thread-suspend t2)
+  (thread-resume t2)
+  (test #f thread-running? t3))
+
+;; Transitive custodian addition:
+(let ([c1 (make-custodian)]
+      [c2 (make-custodian)]
+      [c3 (make-custodian)])
+  (let ([t1 (parameterize ([current-custodian c1])
+	      (thread/suspend-to-kill (lambda () (sleep 10000))))]
+	[t2 (parameterize ([current-custodian c2])
+	      (thread/suspend-to-kill (lambda () (sleep 10000))))])
+    (let ([t2-2 (let loop ([n 5][t t2])
+		  (if (zero? n)
+		      t
+		      (loop (sub1 n)
+			    (parameterize ([current-custodian c2])
+			      (let ([t2 (thread/suspend-to-kill (lambda () (sleep 10000)))])
+				(thread-resume t2 t)
+				t2)))))])
+      (custodian-shutdown-all c2)
+      (test #f thread-running? t2)
+      (test #f thread-running? t2-2)
+      (thread-resume t2)
+      (test #f thread-running? t2)
+      (test #f thread-running? t2-2)
+      (thread-resume t2 t1)
+      (test #t thread-running? t2)
+      (test #t thread-running? t2-2)
+      (thread-resume t1 c3)
+      (custodian-shutdown-all c1)
+      (test #t thread-running? t1)
+      (test #t thread-running? t2)
+      (test #t thread-running? t2-2)
+      (custodian-shutdown-all c3)
+      (test #f thread-running? t1)
+      (test #f thread-running? t2)
+      (test #f thread-running? t2-2))))
+
+;; Cyclic thread yokes should be ok:
+(let* ([c1 (make-custodian)]
+       [c2 (make-custodian)]
+       [t1 (parameterize ([current-custodian c1])
+	     (thread (lambda () (sleep 10000))))]
+       [t2 (parameterize ([current-custodian c2])
+	     (thread (lambda () (sleep 10000))))])
+  (thread-resume t1 t2)
+  (thread-resume t2 t1)
+  (thread-suspend t1)
+  (thread-suspend t2)
+  (test #f thread-running? t1)
+  (test #f thread-running? t2)
+  (thread-resume t1)
+  (test #t thread-running? t1)
+  (test #t thread-running? t2)
+  (thread-suspend t1)
+  (thread-suspend t2)
+  (test #f thread-running? t1)
+  (test #f thread-running? t2)
+  (thread-resume t2)
+  (test #t thread-running? t1)
+  (test #t thread-running? t2)
+  (custodian-shutdown-all c1)
+  (test #t thread-running? t1)
+  (test #t thread-running? t2)
+  (custodian-shutdown-all c2)
+  (test #f thread-running? t1)
+  (test #f thread-running? t2))
+
+;; ----------------------------------------
+
+;; Check that a terminated thread cleans up ownership
+;;  of runstack and mark stack (crashes or doesn't).
+;; Also checks that deep runstacks are ok.
+(let ()
+  (define bye #f)
+  (define hi #f)
+  (define k #f)
+  
+  (define s (make-semaphore))
+  (define s2 (make-semaphore))
+  (define s3 (make-semaphore))
+  (define s4 (make-semaphore))
+  (define s5 (make-semaphore))
+  
+  (define t0
+    (thread (lambda ()
+	      (semaphore-wait s)
+	      (semaphore-wait s)
+	      (kill-thread t))))
+
+  (define t
+    (thread (lambda () 
+	      (let loop ([n 4000])
+		(with-continuation-mark 'x 10 
+		  (dynamic-wind
+		      void
+		      (lambda ()
+			(let ()
+			  (if (zero? n)
+			      (let ()
+				(let/cc x 
+				  (set! k x) 
+				  (printf "Bye\n")
+				  (semaphore-post s)
+				  (sync s2 s3 s4 s5))
+				(printf "Hi\n"))
+			      (loop (sub1 n)))))
+		      void))))))
+  (semaphore-post s)
+  
+  (thread-wait t)
+  (thread-wait (thread k)))
+
+; ----------------------------------------
+
+(report-errs)
diff --git a/collects/tests/mzscheme/threadlib.ss b/collects/tests/mzscheme/threadlib.ss
new file mode 100644
index 0000000000..055dec41bc
--- /dev/null
+++ b/collects/tests/mzscheme/threadlib.ss
@@ -0,0 +1,97 @@
+
+(load-relative "loadtest.ss")
+
+(SECTION 'thread)
+
+(require (lib "thread.ss"))
+
+(define sema (make-semaphore))
+(define sema2 (make-semaphore))
+(define c-out 0)
+(define SLEEP-TIME 0.1)
+
+;;; consumer-thread ;;;
+
+(define-values (th g) (consumer-thread (case-lambda
+					[(f arg) (set! c-out (f arg))
+						 (semaphore-post sema)]
+					[(f arg1 arg2) (set! c-out (f arg1 arg2))
+						       (semaphore-post sema)])))
+(g + 1 2)
+(semaphore-wait sema)
+(test 3 'consumer-thread c-out)
+
+; queue 2
+(g car '(4 5))
+(g semaphore-wait sema2)
+(semaphore-wait sema)
+(test 4 'consumer-thread c-out)
+(semaphore-post sema2)
+(semaphore-wait sema)
+(test (void) 'consumer-thread c-out)
+
+; queue 3
+(g / 2)
+(g semaphore-wait sema2)
+(g (lambda (s) (semaphore-wait s) 5) sema2)
+(semaphore-wait sema)
+(test 1/2 'consumer-thread c-out)
+(semaphore-post sema2)
+(semaphore-wait sema)
+(test (void) 'consumer-thread c-out)
+(semaphore-post sema2)
+(semaphore-wait sema)
+(test 5 'consumer-thread c-out)
+
+; kill the consumer
+(kill-thread th)
+(g - 7)
+(sleep SLEEP-TIME)
+(test 5 'consumer-thread c-out)
+
+(arity-test consumer-thread 1 2)
+(err/rt-test (consumer-thread 9))
+(arity-test g 2 3)
+
+
+;; coroutines ----------------------------------------
+
+(define cntr 0)
+(define w (coroutine (lambda (enable-stop)
+		       (let loop ((i 0))
+			 (enable-stop #f)
+			 (set! cntr i)
+			 (enable-stop #t)
+			 (loop (add1 i))))))
+(test #t coroutine? w)
+(test #f coroutine-result w)
+(test #f coroutine-run 0.1 w)
+(test #t positive? cntr)
+(test (void) coroutine-kill w)
+(test #t coroutine-run 100 w)
+
+(define w2 (coroutine (lambda (enable-stop)
+			(let loop ((i 100))
+			  (cond 
+			   ((< i 0) 13)
+			   (else
+			    (enable-stop #f)
+			    (set! cntr i)
+			    (enable-stop #t)
+			    (loop (sub1 i))))))))
+(test #t coroutine-run 0.1 w2)
+(test 13 coroutine-result w2)
+(test #t coroutine-run 100 w2)
+
+(define w3 (coroutine (lambda (enable-stop)
+			(raise 14))))
+(err/rt-test (coroutine-run 0.1 w3) (lambda (x) (eq? x 14)))
+(test #f coroutine-result w3)
+(test #t coroutine-run 100 w3)
+
+(define w4 (coroutine (lambda (enable-stop)
+			(enable-stop #f)
+			(raise 15))))
+(test #f coroutine-result w4)
+(err/rt-test (coroutine-run 0.1 w4) (lambda (x) (eq? x 15)))
+(test #t coroutine-run 100 w4)
diff --git a/collects/tests/mzscheme/thrport.ss b/collects/tests/mzscheme/thrport.ss
new file mode 100644
index 0000000000..3119814f5e
--- /dev/null
+++ b/collects/tests/mzscheme/thrport.ss
@@ -0,0 +1,58 @@
+
+(load-relative "loadtest.ss")
+
+(SECTION 'multi-threaded-ports)
+
+; Read from file with 3 threads, all writing to the same pipe
+; read from pipe with 3 threads, all writing to the same output string
+; compare resulting character content to the original file
+(test 0 'threaded-ports
+      (let*-values ([(f-in) (open-input-file 
+			     (path->complete-path "testing.ss" 
+						  (current-load-relative-directory)))]
+		    [(p-in p-out) (make-pipe)]
+		    [(s-out) (open-output-string)]
+		    [(in->out) (lambda (in out)
+				 (lambda ()
+				   (let loop ()
+				     (let ([c (read-char in)]
+					   [dummy (lambda () 'hi)])
+				       (unless (eof-object? c)
+					       (write-char c out)
+					       (loop))))))]
+		    [(f->p) (in->out f-in p-out)]
+		    [(p->s) (in->out p-in s-out)]
+		    [(sthread) (lambda (thunk)
+				 (let ([t (thread (lambda () (sleep) (thunk)))])
+				   (thread-weight t 101)
+				   t))])
+		   (thread
+		    (lambda ()
+		      (for-each thread-wait
+				(list (sthread f->p)
+				      (sthread f->p)
+				      (sthread f->p)))
+		      (close-output-port p-out)))
+		   (for-each thread-wait
+			     (list (sthread p->s)
+				   (sthread p->s)
+				   (sthread p->s)))
+		   (let ([s (get-output-string s-out)]
+			 [hits (make-vector 256 0)])
+		     (for-each (lambda (c)
+				 (let ([n (char->integer c)])
+				   (vector-set! hits n (add1 (vector-ref hits n)))))
+			       (string->list s))
+		     (file-position f-in 0)
+		     (let loop ()
+		       (let ([c (read-char f-in)])
+			 (unless (eof-object? c)
+				 (let ([n (char->integer c)])
+				   (vector-set! hits n (sub1 (vector-ref hits n))))
+				 (loop))))
+		     (let loop ([i 0][total 0])
+		       (if (= i 256)
+			   total
+			   (loop (add1 i) (+ total (abs (vector-ref hits i)))))))))
+
+(report-errs)
diff --git a/collects/tests/mzscheme/ttt/listlib.ss b/collects/tests/mzscheme/ttt/listlib.ss
new file mode 100644
index 0000000000..15221d58fd
--- /dev/null
+++ b/collects/tests/mzscheme/ttt/listlib.ss
@@ -0,0 +1,42 @@
+;; --------------------------------------------------------------------------
+;; list-library.ss
+;; export: 
+;; collect: 
+;;   (A ((cons B (listof B)) (listof B) (union A C) -> (union A C))
+;;    -> 
+;;    ((listof B) -> (union A C)))
+
+; #|
+; (unit/sig
+;   (collect filter set-minus subset?)
+;   (import plt:userspace^)
+; |#
+
+  (define collect
+    (lambda (base combine)
+      (letrec ([C 
+		(lambda (l)
+		  (cond
+		   ((null? l) base)
+		   (else (combine l (car l) (C (cdr l))))))])
+	C)))
+
+  (define filter
+    (lambda (p? l)
+      [(collect null (lambda (_ x rest) (if (p? x) (cons x rest) rest))) l]))
+
+  ;; set library
+  (define set-minus
+    (lambda (set1 set2)
+      [(collect null (lambda (_ e1 rest) (if (member e1 set2) rest (cons e1 rest))))
+       set1]))
+
+  (define subset?
+    (lambda (state1 state2)
+      (cond
+	((null? state1) #t)
+	(else (and (member (car state1) state2)
+		(subset? (cdr state1) state2))))))
+; #|
+;   )
+; |#
diff --git a/collects/tests/mzscheme/ttt/tic-bang.ss b/collects/tests/mzscheme/ttt/tic-bang.ss
new file mode 100644
index 0000000000..85422cdcd9
--- /dev/null
+++ b/collects/tests/mzscheme/ttt/tic-bang.ss
@@ -0,0 +1,123 @@
+;; --------------------------------------------------------------------------
+;; tic-bang.ss
+;; This is an imperative version.
+
+;; This program plays through all possibilities of a tic-tac-toe
+;; game, given the first move of a player. It only prints how many
+;; states are being processed and how many states are terminal at
+;; each stage of the game.
+
+;; This program lacks the capability to print how a situation arose. 
+
+;; It relies on list-library.ss. 
+
+;; representations of fields, states, and collections of states
+(define BLANK 0)
+
+(define new-state
+  (lambda ()
+    (make-2vec 3 BLANK)))
+
+(define update-state
+  (lambda (state x y token)
+    (2vec-set! state x y token)
+    state))
+
+(define blank?
+  (lambda (astate i j)
+    (eq? (2vec-ref astate i j) BLANK)))
+
+(define clone-state
+  (lambda (state)
+    (let ((s (new-state)))
+      (let loop ((i 0) (j 0))
+	(cond
+	  ((and (= i 3) (= j 0)) (void))
+	  ((< j 3) (update-state s i j (2vec-ref state i j)) (loop i (+ j 1)))
+	  ((< i 3) (loop (+ i 1) 0))
+	  (else 'bad)))
+      s)))
+
+;(define-type state (2vector (union 'x 'o '_)))
+;(define-type states (listof state))
+
+(define PLAYER 1)
+(define OPPONENT 2)
+
+(define tic-tac-toe
+  (lambda (x y)
+    (tic (list (update-state (new-state) (- x 1) (- y 1) PLAYER)))))
+
+(define make-move
+  (lambda (other-move p/o tag)
+    (lambda (states)
+      (printf "~s: processing ~s states ~n" tag (length states))
+      (let ((t (print&remove-terminals states)))
+	(printf "terminal states removed: ~s~n" 
+		(- (length states) (length t)))
+	(if (null? t) 
+	    (void)
+	    (other-move (apply append (map p/o t))))))))
+
+(define tic (make-move (lambda (x) (tac x)) (lambda (x) (opponent x)) 'tic))
+
+(define tac (make-move (lambda (x) (tic x)) (lambda (x) (player x)) 'tac))
+
+(define make-players
+  (lambda (p/o)
+    (lambda (astate)
+      (let loop ((i 0) (j 0))
+	(cond
+	  ((and (= i 3) (= j 0)) null)
+	  ((< j 3) (if (blank? astate i j)
+		       (cons (update-state (clone-state astate) i j p/o)
+			     (loop i (+ j 1)))
+		       (loop i (+ j 1))))
+	  ((< i 3) (loop (+ i 1) 0))
+	  (else (error 'make-player "ouch")))))))
+
+(define player (make-players PLAYER))
+
+(define opponent (make-players OPPONENT))
+
+(define print&remove-terminals
+  (local ((define print-state
+	    (lambda (x)
+	      ;(display ".")
+	      (void))))
+
+    (collect null (lambda (_ astate rest)
+		    (if (terminal? astate)
+			(begin (print-state astate) rest)
+			(cons astate rest))))))
+
+(define terminal?
+  (lambda (astate)
+    (or (terminal-row 0 astate)
+	(terminal-row 1 astate)
+	(terminal-row 2 astate)
+	(terminal-col 0 astate)
+	(terminal-col 1 astate)
+	(terminal-col 2 astate)
+	(terminal-posdg astate)
+	(terminal-negdg astate))))
+
+(define terminal-row 
+  (lambda (n state)
+    (and (not (blank? state n 0))
+	 (= (2vec-ref state n 0) (2vec-ref state n 1) (2vec-ref state n 2)))))
+
+(define terminal-col
+  (lambda (n state)
+    (and (not (blank? state 0 n))
+	 (= (2vec-ref state 0 n) (2vec-ref state 1 n) (2vec-ref state 2 n)))))
+
+(define terminal-posdg
+  (lambda (state)
+    (and (not (blank? state 0 0))
+	 (= (2vec-ref state 0 0) (2vec-ref state 1 1) (2vec-ref state 2 2)))))
+
+(define terminal-negdg
+  (lambda (state)
+    (and (not (blank? state 0 2))
+	 (= (2vec-ref state 0 2) (2vec-ref state 1 1) (2vec-ref state 2 0)))))
diff --git a/collects/tests/mzscheme/ttt/tic-func.ss b/collects/tests/mzscheme/ttt/tic-func.ss
new file mode 100644
index 0000000000..538d4569f8
--- /dev/null
+++ b/collects/tests/mzscheme/ttt/tic-func.ss
@@ -0,0 +1,120 @@
+;; --------------------------------------------------------------------------
+;; tic-func.ss 
+;; This program plays through all possibilities of a tic-tac-toe
+;; game, given the first move of a player. It only prints how many
+;; states are being processed and how many states are terminal at
+;; each stage of the game. But it is constructed so that it can
+;; print how to get to a winning terminal state. 
+
+;; It relies on list-library.ss. 
+
+;; representations of fields, states, and collections of states
+(define null '())
+(define-structure (entry x y who))
+(define entry-field
+  (lambda (an-entry)
+    (list (entry-x an-entry) (entry-y an-entry))))
+;(define-type state  (listof (structure:entry num num (union 'x 'o)))
+;(define-type states (listof state))
+
+(define PLAYER 'x)
+(define OPPONENT 'o)
+
+(define tic-tac-toe
+  (lambda (x y)
+    (tic (list (list (make-entry x y PLAYER))))))
+
+(define make-move
+  (lambda (other-move p/o tag)
+    (lambda (states)
+      (printf "~s: processing ~s states of length ~s ~n"
+	tag (length states) (length (car states)))
+      (let ((t (print&remove-terminals states)))
+	(printf "terminal states removed: ~s~n"
+	  (- (length states) (length t)))
+	(if (null? t) 
+	    (void)
+	    (other-move (apply append (map p/o t))))))))
+
+(define tic (make-move (lambda (x) (tac x)) (lambda (x) (opponent x)) 'tic))
+
+(define tac (make-move (lambda (x) (tic x)) (lambda (x) (player x)) 'tac))
+
+(define make-players
+  (let ()
+    (define rest-of-fields
+      (lambda (used-fields)
+	(set-minus ALL-FIELDS used-fields)))
+    (lambda (player/opponent)
+      (lambda (astate)
+	(map (lambda (counter-move)
+	       (let ((counter-x (car counter-move))
+		     (counter-y (cadr counter-move)))
+		 (cons (make-entry counter-x counter-y player/opponent)
+		       astate)))
+	     (rest-of-fields (map entry-field astate)))))))
+
+(define player (make-players PLAYER))
+
+(define opponent (make-players OPPONENT))
+
+(define terminal?
+  (let () (define filter-p/o
+	    (lambda (p/o astate)
+	      (map entry-field
+		(filter (lambda (x) (eq? (entry-who x) p/o)) astate))))
+    (lambda (astate)
+      (and (>= (length astate) 5)
+	(let ((PLAYERf (filter-p/o PLAYER astate))
+	      (OPPONENTf (filter-p/o OPPONENT astate)))
+	  (or 
+	    (= (length astate) 9)
+	    (ormap (lambda (ts) (subset? ts PLAYERf)) TERMINAL-STATES)
+	    (ormap (lambda (ts) (subset? ts OPPONENTf)) TERMINAL-STATES)))))))
+
+(define print&remove-terminals
+  (let ()
+
+	  (define print-state1
+	    (lambda (x)
+	      (display x)
+	      (newline)))
+
+	  (define print-state2
+	    (lambda (astate)
+	      (cond
+		((null? astate) (printf "------------~n"))
+		(else (print-state (cdr astate))
+		  (let ((x (car astate)))
+		    (printf " ~s @ (~s,~s) ~n"
+		      (entry-who x) (entry-x x) (entry-y x)))))))
+
+	  (define print-state
+	    (lambda (x)
+	      ;(display ".")
+	      (void)))
+
+    (collect null (lambda (_ astate rest)
+		    (if (terminal? astate)
+			(begin (print-state astate) rest)
+			(cons astate rest))))))
+;; fields
+(define T
+  (lambda (alof)
+    (cond
+      ((null? alof) null)
+      (else (cons (list (cadr (car alof)) (car (car alof)))
+		  (T (cdr alof)))))))
+
+(define row1 (list (list 1 1) (list 1 2) (list 1 3)))
+(define row2 (list (list 2 1) (list 2 2) (list 2 3)))
+(define row3 (list (list 3 1) (list 3 2) (list 3 3)))
+(define col1 (list (list 1 1) (list 2 1) (list 3 1)))
+(define col2 (list (list 1 2) (list 2 2) (list 3 2)))
+(define col3 (list (list 1 3) (list 2 3) (list 3 3)))
+(define posd (list (list 1 1) (list 2 2) (list 3 3)))
+(define negd (list (list 1 3) (list 2 2) (list 3 1)))
+
+(define TERMINAL-STATES (list row1 row2 row3 col1 col2 col3 posd negd))
+
+(define ALL-FIELDS (append row1 row2 row3))
diff --git a/collects/tests/mzscheme/ttt/ttt.ss b/collects/tests/mzscheme/ttt/ttt.ss
new file mode 100644
index 0000000000..178e078aba
--- /dev/null
+++ b/collects/tests/mzscheme/ttt/ttt.ss
@@ -0,0 +1,13 @@
+
+(require (lib "etc.ss") (lib "compat.ss"))
+(load-relative "listlib.ss")
+(load-relative "veclib.ss")
+(load-relative "tic-func.ss")
+
+(let loop ()
+  (collect-garbage)
+  (collect-garbage)
+  (collect-garbage)
+  ; (dump-memory-stats)
+  (time (tic-tac-toe 1 1))
+  '(loop))
diff --git a/collects/tests/mzscheme/ttt/uinc4.ss b/collects/tests/mzscheme/ttt/uinc4.ss
new file mode 100644
index 0000000000..75fc25d642
--- /dev/null
+++ b/collects/tests/mzscheme/ttt/uinc4.ss
@@ -0,0 +1,5 @@
+
+(define also-unused 'ok)
+
+(include (build-path up "uinc.ss"))
+
diff --git a/collects/tests/mzscheme/ttt/veclib.ss b/collects/tests/mzscheme/ttt/veclib.ss
new file mode 100644
index 0000000000..d840f09910
--- /dev/null
+++ b/collects/tests/mzscheme/ttt/veclib.ss
@@ -0,0 +1,57 @@
+;; --------------------------------------------------------------------------
+;; 2vec-library.ss
+
+; #|
+; (unit/sig
+;   (make-2vec 2vec-ref 2vec-set! collect)
+;   (import plt:userspace^)
+; |#
+  
+  ;; 2 dimensional, square vectors
+
+    (define collect
+      (lambda (base combine)
+	(define C 
+	  (lambda (l)
+	    (cond
+	     ((null? l) base)
+	     (else (combine l (car l) (C (cdr l)))))))
+	C))
+    
+  (define (make-2vec N element)
+    (make-vector (* N N) element))
+  
+  (define (2vec-ref 2vec i j)
+    (let ((L (sqrt (vector-length 2vec))))
+      (vector-ref 2vec (+ (* i L) j))))
+  
+  (define (2vec-set! 2vec i j element)
+    (let ((L (sqrt (vector-length 2vec))))
+      (if (and (< i L) (< j L))
+	  (vector-set! 2vec (+ (* i L) j) element)
+	  (error '2vec-set! "~s ~s" i j))))
+  
+  (define (I N)
+    (let ((2vec (make-2vec N 0)))
+      (let loop ((i 0) (j 0))
+	(if (= i N)
+	    (void)
+	    (begin
+	      (2vec-set! 2vec i j 1)
+	      (loop (add1 i) (add1 j)))))
+      2vec))
+  
+  (define (P N)
+    (let ((2vec (make-2vec N 0)))
+      (let loop ((i 0) (j 0))
+	(cond
+	  [(and (= i N) (= j 0)) (void)]
+	  [(< j N) (2vec-set! 2vec i j (list i j)) (loop i (add1 j))]
+	  [(< i N) (loop (add1 i) 0)]
+	  [else (error 'P "impossible ~s ~s" i j)]))
+      2vec))
+
+; #|
+;   )
+; |#
+
diff --git a/collects/tests/mzscheme/udp.ss b/collects/tests/mzscheme/udp.ss
new file mode 100644
index 0000000000..e3dd07f872
--- /dev/null
+++ b/collects/tests/mzscheme/udp.ss
@@ -0,0 +1,165 @@
+
+(load-relative "loadtest.ss")
+
+(SECTION 'UDP)
+
+(define udp1 (udp-open-socket))
+(define us1 (make-bytes 10))
+
+(test #t udp? udp1)
+(test #f udp-bound? udp1)
+(test #f udp-connected? udp1)
+
+;; not bound:
+(err/rt-test (udp-receive! udp1 us1) exn:fail:network?)
+(err/rt-test (udp-receive!* udp1 us1) exn:fail:network?)
+(err/rt-test (udp-receive!/enable-break udp1 us1) exn:fail:network?)
+;; not connected:
+(err/rt-test (udp-send udp1 us1) exn:fail:network?)
+(err/rt-test (udp-send* udp1 us1) exn:fail:network?)
+(err/rt-test (udp-send/enable-break udp1 us1) exn:fail:network?)
+
+(test (void) udp-send-to udp1 "localhost" 45678 #"knock knock")
+(sleep 0.05)
+(test-values '(#f #f #f) (lambda () 
+			   ;; The send above might cause an error on the next
+			   ;;  action, so we try up to 2 times:
+			   (with-handlers ([exn:fail?
+					    (lambda (x)
+					      (udp-receive!* udp1 us1))])
+			     (udp-receive!* udp1 us1))))
+
+(test #t udp-bound? udp1)
+(test #f udp-connected? udp1)
+
+;; still not connected:
+(err/rt-test (udp-send udp1 us1) exn:fail:network?)
+
+(define udp2 (udp-open-socket))
+(test (void) udp-bind! udp2 #f 40007)
+(test-values '(#f #f #f) (lambda () (udp-receive!* udp2 us1)))
+
+(test (void) udp-send-to udp1 "localhost" 40007 #"Hiya.")
+(define recv-got (call-with-values (lambda () (udp-receive! udp2 us1)) list))
+(test 5 car recv-got)
+(test #"127.0.0.1" cadr recv-got)
+(define udp1-port (caddr recv-got))
+(test #"Hiya.\0\0\0\0\0" values us1)
+
+(test (void) udp-send-to udp1 "localhost" 40007 #"...another?..." 3 11)
+(test-values (list 8 #"127.0.0.1" udp1-port) (lambda () (udp-receive! udp2 us1 1)))
+(test #"Hanother?\0" values us1)
+
+(test (void) udp-connect! udp1 "localhost" 40007)
+(test #t udp-connected? udp1)
+(test #f udp-connected? udp2)
+
+(test (void) udp-send udp1 #"truncate me")
+(test-values (list 6 #"127.0.0.1" udp1-port) (lambda () (udp-receive! udp2 us1 2 8)))
+(test #"Hatrunca?\0" values us1)
+
+(test #t udp-send* udp1 #"SKIPall of it" 4)
+(test-values (list 9 #"127.0.0.1" udp1-port) (lambda () (udp-receive! udp2 us1 0)))
+(test #"all of it\0" values us1)
+
+(define (flush-udp-errors udp)
+  (let loop ()
+    (with-handlers ([exn:fail?
+		     (lambda (x) (loop))])
+       (udp-receive!* udp1 us1))))
+
+;; re-connect
+(test (void) udp-connect! udp1 "localhost" 40008)
+(test #t udp-connected? udp1)
+(test (void) udp-send udp1 #"lots of stuff")
+(sleep 0.05)
+(flush-udp-errors udp1)
+(test-values '(#f #f #f) (lambda () (udp-receive!* udp2 us1)))
+(err/rt-test (udp-send-to udp1 "localhost" 40007 #"not ok -- currently connected") exn:fail:network?)
+(test #t udp-send* udp1 #"lots of stuff")
+(sleep 0.05)
+(flush-udp-errors udp1)
+(test-values '(#f #f #f) (lambda () (udp-receive!* udp2 us1)))
+
+;; disconnect
+(test (void) udp-connect! udp1 #f #f)
+(test #f udp-connected? udp1)
+(test (void) udp-connect! udp2 #f #f)
+(test #f udp-connected? udp2)
+
+;; waitables
+(define udp1-s (udp-send-ready-evt udp1))
+(test #t evt? udp1-s)
+(test udp1-s sync udp1-s)
+
+(define udp2-r (udp-receive-ready-evt udp2))
+(test #t evt? udp2-r)
+(test #f sync/timeout 0.05 udp2-r)
+
+(test (void) sync (udp-send-to-evt udp1 "localhost" 40007 #"here's more"))
+(sleep 0.05)
+(test udp2-r sync udp2-r)
+(test udp2-r sync udp2-r)
+(test (list 10 #"127.0.0.1" udp1-port) sync (udp-receive!-evt udp2 us1))
+(test #f sync/timeout 0.05 udp2-r)
+(test #f sync/timeout 0.05 (udp-receive!-evt udp2 us1))
+
+;; break behavior
+(let ([t (parameterize-break #f
+           (thread (lambda ()
+		     (udp-receive!/enable-break udp1 us1)
+		     (set! udp1 #f))))])
+  (sleep 0.05)
+  (break-thread t)
+  (thread-wait t)
+  (test #t udp? udp1))
+;; filling up an output queue is difficult; we don't even try here
+
+(err/rt-test (udp-bind! udp1 #f #f))
+(err/rt-test (udp-bind! udp1 "localhost" #f))
+(err/rt-test (udp-connect! udp1 "localhost" #f) exn:application:mismatch?)
+(err/rt-test (udp-connect! udp1 #f 5) exn:application:mismatch?)
+(err/rt-test (udp-send-to udp1 #f 40000 #"hello"))
+(err/rt-test (udp-send-to udp1 "localhost" #f #"hello"))
+(err/rt-test (udp-send-to udp1 "localhost" 40000 'hello))
+(err/rt-test (udp-send-to udp1 "localhost" 40000 "hello"))
+(err/rt-test (udp-send-to udp1 "localhost" 40000 #"hello" #f))
+(err/rt-test (udp-send-to udp1 "localhost" 40000 #"hello" 1 #f))
+(err/rt-test (udp-send-to udp1 "localhost" 40000 #"hello" 10) exn:application:mismatch?)
+(err/rt-test (udp-send-to udp1 "localhost" 40000 #"hello" 1 11) exn:application:mismatch?)
+(err/rt-test (udp-send-to udp1 "localhost" 40000 #"hello" 1 0) exn:application:mismatch?)
+(err/rt-test (udp-send udp1 'hello))
+(err/rt-test (udp-send udp1 #"hello" #f))
+(err/rt-test (udp-send udp1 #"hello" 2 #f))
+(err/rt-test (udp-send udp1 #"hello" 12) exn:application:mismatch?)
+(err/rt-test (udp-send udp1 #"hello" 1 13) exn:application:mismatch?)
+(err/rt-test (udp-send udp1 #"hello" 1 0) exn:application:mismatch?)
+(err/rt-test (udp-receive! udp1 "constant"))
+(err/rt-test (udp-receive! udp1 'hello))
+(err/rt-test (udp-receive!* udp1 (make-bytes 10) #f))
+(err/rt-test (udp-receive!* udp1 (make-bytes 10) 2 #f))
+(err/rt-test (udp-receive!* udp1 (make-bytes 10) 12) exn:application:mismatch?)
+(err/rt-test (udp-receive!* udp1 (make-bytes 10) 2 12) exn:application:mismatch?)
+(err/rt-test (udp-receive!* udp1 (make-bytes 10) 2 0) exn:application:mismatch?)
+
+
+(test (void) udp-close udp1)
+(test (void) udp-close udp2)
+
+;; udp1 is now closed...
+(err/rt-test (udp-bind! udp1 "localhost" 40008) exn:fail:network?)
+(err/rt-test (udp-connect! udp1 "localhost" 40007) exn:fail:network?)
+(err/rt-test (udp-send-to udp1 "localhost" 40000 #"hello") exn:fail:network?)
+(err/rt-test (udp-send udp1 #"hello") exn:fail:network?)
+(err/rt-test (udp-receive! udp1 (make-bytes 10)) exn:fail:network?)
+(err/rt-test (udp-close udp1) exn:fail:network?)
+
+;; Can still get waitable after closed:
+(test #t evt? (udp-send-ready-evt udp1))
+(test #t evt? (udp-receive-ready-evt udp1))
+(let ([w (udp-send-ready-evt udp1)])
+  (test w sync w))
+(let ([w (udp-receive-ready-evt udp1)])
+  (test w sync w))
+(test #t evt? (udp-receive!-evt udp1 us1))
+(test #t evt? (udp-send-to-evt udp1 "localhost" 40007 #"here's more"))
diff --git a/collects/tests/mzscheme/uinc.ss b/collects/tests/mzscheme/uinc.ss
new file mode 100644
index 0000000000..ea489aaa3f
--- /dev/null
+++ b/collects/tests/mzscheme/uinc.ss
@@ -0,0 +1,2 @@
+
+(+ 4 5)
diff --git a/collects/tests/mzscheme/uinc2.ss b/collects/tests/mzscheme/uinc2.ss
new file mode 100644
index 0000000000..c1de73fb3e
--- /dev/null
+++ b/collects/tests/mzscheme/uinc2.ss
@@ -0,0 +1,2 @@
+
+(define x 8)
diff --git a/collects/tests/mzscheme/uinc3.ss b/collects/tests/mzscheme/uinc3.ss
new file mode 100644
index 0000000000..6016697b7d
--- /dev/null
+++ b/collects/tests/mzscheme/uinc3.ss
@@ -0,0 +1,7 @@
+
+(define unused 'hello)
+
+(include (build-path "ttt" "uinc4.ss"))
+
+
+
diff --git a/collects/tests/mzscheme/unicode.ss b/collects/tests/mzscheme/unicode.ss
new file mode 100644
index 0000000000..39152812d1
--- /dev/null
+++ b/collects/tests/mzscheme/unicode.ss
@@ -0,0 +1,1431 @@
+
+(load-relative "loadtest.ss")
+
+(SECTION 'unicode)
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;  UTF-8 boundary tests based on Markus Kuhn's test suite
+
+(define basic-utf-8-tests
+  '((#(#x3ba #x1f79 #x3c3 #x3bc #x3b5) complete
+     (#o316 #o272 #o341 #o275 #o271 #o317 #o203 #o316 #o274 #o316 #o265))
+    (#(0) complete
+     (#o0))
+    (#(#x00000080) complete
+     (#o302 #o200))
+    (#(#x00000800) complete
+     (#o340 #o240 #o200))
+    (#(#x00010000) complete
+     (#o360 #o220 #o200 #o200))
+    (#(#x0010FFFF) complete
+     (#o364 #o217 #o277 #o277))
+    (#(#f #f #f #f) error ; would be #x00110000 without UTF-8 limit
+     (#o364 #o220 #o200 #o200))
+    (#(#f #f  #f #f #f) error
+     (#o370 #o210 #o200 #o200 #o200))
+    (#(#f #f #f #f #f #f) error
+     (#o374 #o204 #o200 #o200 #o200 #o200))
+    (#(#x0000007F) complete
+     (127))
+    (#(#x000007FF) complete
+     (#o337 #o277))
+    (#(#f #f #f #f) error ; #x001FFFFF
+     (#o367 #o277 #o277 #o277))
+    (#(#f #f #f #f #f) error ; #x03FFFFFF
+     (#o373 #o277 #o277 #o277 #o277))
+    (#(#f #f #f #f #f #f) error ; #x7FFFFFFF
+     (#o375 #o277 #o277 #o277 #o277 #o277))
+    (#(#x0000D7FF) complete
+     (#o355 #o237 #o277))
+    (#(#x0000E000) complete
+     (#o356 #o200 #o200))
+    (#(#x0000FFFD) complete
+     (#o357 #o277 #o275))
+    (#(#x0010FFFF) complete
+     (#o364 #o217 #o277 #o277))
+    ;; Missing start byte
+    (#(#f) error
+     (#o200))
+    (#(#f) error
+     (#o277))
+    (#(#f #f) error
+     (#o200 #o277))
+    (#(#f #f #f) error
+     (#o200 #o277 #o200))
+    (#(#f #f #f #f) error
+     (#o200 #o277 #o200 #o277))
+    (#(#f #f #f #f #f) error
+     (#o200 #o277 #o200 #o277 #o200))
+    (#(#f #f #f #f #f #f) error
+     (#o200 #o277 #o200 #o277 #o200 #o277))
+    (#(#f #f #f #f #f #f #f) error
+     (#o200 #o277 #o200 #o277 #o200 #o277 #o200))
+    (#(#f) error
+     (#o200))
+    (#(#f) error
+     (#o201))
+    (#(#f) error
+     (#o202))
+    (#(#f) error
+     (#o203))
+    (#(#f) error
+     (#o204))
+    (#(#f) error
+     (#o205))
+    (#(#f) error
+     (#o206))
+    (#(#f) error
+     (#o207))
+    (#(#f) error
+     (#o210))
+    (#(#f) error
+     (#o211))
+    (#(#f) error
+     (#o212))
+    (#(#f) error
+     (#o213))
+    (#(#f) error
+     (#o214))
+    (#(#f) error
+     (#o215))
+    (#(#f) error
+     (#o216))
+    (#(#f) error
+     (#o217))
+    (#(#f) error
+     (#o220))
+    (#(#f) error
+     (#o221))
+    (#(#f) error
+     (#o222))
+    (#(#f) error
+     (#o223))
+    (#(#f) error
+     (#o224))
+    (#(#f) error
+     (#o225))
+    (#(#f) error
+     (#o226))
+    (#(#f) error
+     (#o227))
+    (#(#f) error
+     (#o230))
+    (#(#f) error
+     (#o231))
+    (#(#f) error
+     (#o232))
+    (#(#f) error
+     (#o233))
+    (#(#f) error
+     (#o234))
+    (#(#f) error
+     (#o235))
+    (#(#f) error
+     (#o236))
+    (#(#f) error
+     (#o237))
+    (#(#f) error
+     (#o240))
+    (#(#f) error
+     (#o241))
+    (#(#f) error
+     (#o242))
+    (#(#f) error
+     (#o243))
+    (#(#f) error
+     (#o244))
+    (#(#f) error
+     (#o245))
+    (#(#f) error
+     (#o246))
+    (#(#f) error
+     (#o247))
+    (#(#f) error
+     (#o250))
+    (#(#f) error
+     (#o251))
+    (#(#f) error
+     (#o252))
+    (#(#f) error
+     (#o253))
+    (#(#f) error
+     (#o254))
+    (#(#f) error
+     (#o255))
+    (#(#f) error
+     (#o256))
+    (#(#f) error
+     (#o257))
+    (#(#f) error
+     (#o260))
+    (#(#f) error
+     (#o261))
+    (#(#f) error
+     (#o262))
+    (#(#f) error
+     (#o263))
+    (#(#f) error
+     (#o264))
+    (#(#f) error
+     (#o265))
+    (#(#f) error
+     (#o266))
+    (#(#f) error
+     (#o267))
+    (#(#f) error
+     (#o270))
+    (#(#f) error
+     (#o271))
+    (#(#f) error
+     (#o272))
+    (#(#f) error
+     (#o273))
+    (#(#f) error
+     (#o274))
+    (#(#f) error
+     (#o275))
+    (#(#f) error
+     (#o276))
+    (#(#f) error
+     (#o277))
+    ;; 2-byte seqs with no continuation
+    (#(#f 32) error
+     (#o300 #o40))
+    (#(#f 32) error
+     (#o301 #o40))
+    (#(#f 32) error
+     (#o302 #o40))
+    (#(#f 32) error
+     (#o303 #o40))
+    (#(#f 32) error
+     (#o304 #o40))
+    (#(#f 32) error
+     (#o305 #o40))
+    (#(#f 32) error
+     (#o306 #o40))
+    (#(#f 32) error
+     (#o307 #o40))
+    (#(#f 32) error
+     (#o310 #o40))
+    (#(#f 32) error
+     (#o311 #o40))
+    (#(#f 32) error
+     (#o312 #o40))
+    (#(#f 32) error
+     (#o313 #o40))
+    (#(#f 32) error
+     (#o314 #o40))
+    (#(#f 32) error
+     (#o315 #o40))
+    (#(#f 32) error
+     (#o316 #o40))
+    (#(#f 32) error
+     (#o317 #o40))
+    (#(#f 32) error
+     (#o320 #o40))
+    (#(#f 32) error
+     (#o321 #o40))
+    (#(#f 32) error
+     (#o322 #o40))
+    (#(#f 32) error
+     (#o323 #o40))
+    (#(#f 32) error
+     (#o324 #o40))
+    (#(#f 32) error
+     (#o325 #o40))
+    (#(#f 32) error
+     (#o326 #o40))
+    (#(#f 32) error
+     (#o327 #o40))
+    (#(#f 32) error
+     (#o330 #o40))
+    (#(#f 32) error
+     (#o331 #o40))
+    (#(#f 32) error
+     (#o332 #o40))
+    (#(#f 32) error
+     (#o333 #o40))
+    (#(#f 32) error
+     (#o334 #o40))
+    (#(#f 32) error
+     (#o335 #o40))
+    (#(#f 32) error
+     (#o336 #o40))
+    (#(#f 32) error
+     (#o337 #o40))
+    ;; 3-byte seqs with no continuation
+    (#(#f 32) error
+     (#o340 #o40))
+    (#(#f 32) error
+     (#o341 #o40))
+    (#(#f 32) error
+     (#o342 #o40))
+    (#(#f 32) error
+     (#o343 #o40))
+    (#(#f 32) error
+     (#o344 #o40))
+    (#(#f 32) error
+     (#o345 #o40))
+    (#(#f 32) error
+     (#o346 #o40))
+    (#(#f 32) error
+     (#o347 #o40))
+    (#(#f 32) error
+     (#o350 #o40))
+    (#(#f 32) error
+     (#o351 #o40))
+    (#(#f 32) error
+     (#o352 #o40))
+    (#(#f 32) error
+     (#o353 #o40))
+    (#(#f 32) error
+     (#o354 #o40))
+    (#(#f 32) error
+     (#o355 #o40))
+    (#(#f 32) error
+     (#o356 #o40))
+    (#(#f 32) error
+     (#o357 #o40))
+    ;; 3-byte seqs with partial continuation
+    (#(#f #f 32) error
+     (#o340 #o203 #o40))
+    (#(#f #f 32) error
+     (#o341 #o203 #o40))
+    (#(#f #f 32) error
+     (#o342 #o203 #o40))
+    (#(#f #f 32) error
+     (#o343 #o203 #o40))
+    (#(#f #f 32) error
+     (#o344 #o203 #o40))
+    (#(#f #f 32) error
+     (#o345 #o203 #o40))
+    (#(#f #f 32) error
+     (#o346 #o203 #o40))
+    (#(#f #f 32) error
+     (#o347 #o203 #o40))
+    (#(#f #f 32) error
+     (#o350 #o203 #o40))
+    (#(#f #f 32) error
+     (#o351 #o203 #o40))
+    (#(#f #f 32) error
+     (#o352 #o203 #o40))
+    (#(#f #f 32) error
+     (#o353 #o203 #o40))
+    (#(#f #f 32) error
+     (#o354 #o203 #o40))
+    (#(#f #f 32) error
+     (#o355 #o203 #o40))
+    (#(#f #f 32) error
+     (#o356 #o203 #o40))
+    (#(#f #f 32) error
+     (#o357 #o203 #o40))
+    ;; 4-byte seq with no continuations
+    (#(#f 32) error
+     (#o360 #o40))
+    (#(#f 32) error
+     (#o361 #o40))
+    (#(#f 32) error
+     (#o362 #o40))
+    (#(#f 32) error
+     (#o363 #o40))
+    (#(#f 32) error
+     (#o364 #o40))
+    (#(#f 32) error
+     (#o365 #o40))
+    (#(#f 32) error
+     (#o366 #o40))
+    (#(#f 32) error
+     (#o367 #o40))
+    ;; 4-byte seq with only 1 continuation
+    (#(#f #f 32) error
+     (#o360 #o203 #o40))
+    (#(#f #f 32) error
+     (#o361 #o203 #o40))
+    (#(#f #f 32) error
+     (#o362 #o203 #o40))
+    (#(#f #f 32) error
+     (#o363 #o203 #o40))
+    (#(#f #f 32) error
+     (#o364 #o203 #o40))
+    (#(#f #f 32) error
+     (#o365 #o203 #o40))
+    (#(#f #f 32) error
+     (#o366 #o203 #o40))
+    (#(#f #f 32) error
+     (#o367 #o203 #o40))
+    ;; 4-byte seq with only 2 continuation
+    (#(#f #f #f 32) error
+     (#o360 #o203 #o203 #o40))
+    (#(#f #f #f 32) error
+     (#o361 #o203 #o203 #o40))
+    (#(#f #f #f 32) error
+     (#o362 #o203 #o203 #o40))
+    (#(#f #f #f 32) error
+     (#o363 #o203 #o203 #o40))
+    (#(#f #f #f 32) error
+     (#o364 #o203 #o203 #o40))
+    (#(#f #f #f 32) error
+     (#o365 #o203 #o203 #o40))
+    (#(#f #f #f 32) error
+     (#o366 #o203 #o203 #o40))
+    (#(#f #f #f 32) error
+     (#o367 #o203 #o203 #o40))
+    ;; 5-byte seqs with no continuation
+    (#(#f 32) error
+     (#o370 #o40))
+    (#(#f 32) error
+     (#o371 #o40))
+    (#(#f 32) error
+     (#o372 #o40))
+    (#(#f 32) error
+     (#o373 #o40))
+    ;; 5-byte seqs with only 1 continuation
+    (#(#f #f 32) error
+     (#o370 #o203 #o40))
+    (#(#f #f 32) error
+     (#o371 #o203 #o40))
+    (#(#f #f 32) error
+     (#o372 #o203 #o40))
+    (#(#f #f 32) error
+     (#o373 #o203 #o40))
+    ;; 5-byte seqs with only 2 continuations
+    (#(#f #f #f 32) error
+     (#o370 #o203 #o203 #o40))
+    (#(#f #f #f 32) error
+     (#o371 #o203 #o203 #o40))
+    (#(#f #f #f 32) error
+     (#o372 #o203 #o203 #o40))
+    (#(#f #f #f 32) error
+     (#o373 #o203 #o203 #o40))
+    ;; 5-byte seqs with only 3 continuations
+    (#(#f #f #f #f 32) error
+     (#o370 #o203 #o203 #o203 #o40))
+    (#(#f #f #f #f 32) error
+     (#o371 #o203 #o203 #o203 #o40))
+    (#(#f #f #f #f 32) error
+     (#o372 #o203 #o203 #o203 #o40))
+    (#(#f #f #f #f 32) error
+     (#o373 #o203 #o203 #o203 #o40))
+    ;; 6-byte seqs with no continuation
+    (#(#f 32) error
+     (#o374 #o40))
+    (#(#f 32) error
+     (#o375 #o40))
+    ;; 6-byte seqs with only 1 continuation
+    (#(#f #f 32) error
+     (#o374 #o203 #o40))
+    (#(#f #f 32) error
+     (#o375 #o203 #o40))
+    ;; 6-byte seqs with only 2 continuation
+    (#(#f #f #f 32) error
+     (#o374 #o203 #o203 #o40))
+    (#(#f #f #f 32) error
+     (#o375 #o203 #o203 #o40))
+    ;; 6-byte seqs with only 3 continuation
+    (#(#f #f #f #f 32) error
+     (#o374 #o203 #o203 #o203 #o40))
+    (#(#f #f #f #f 32) error
+     (#o375 #o203 #o203 #o203 #o40))
+    ;; 6-byte seqs with only 4 continuation
+    (#(#f #f #f #f #f 32) error
+     (#o374 #o203 #o203 #o203 #o203 #o40))
+    (#(#f #f #f #f #f 32) error
+     (#o375 #o203 #o203 #o203 #o203 #o40))
+    ;; Sequences with last continuation byte missing, eol instead of space
+    (#(#f) error ; aborts
+     (#o300))
+    (#(#f) aborts
+     (#o310))
+    (#(#f #f) error ; aborts
+     (#o340 #o200))
+    (#(#f #f) aborts
+     (#o350 #o200))
+    (#(#f #f) aborts
+     (#o340 #o240))
+    (#(#f) aborts
+     (#o340))
+    (#(#f #f #f) error ; aborts
+     (#o360 #o200 #o200))
+    (#(#f #f #f) aborts
+     (#o361 #o200 #o200))
+    (#(#f #f) error ; aborts
+     (#o360 #o200))
+    (#(#f #f) aborts
+     (#o361 #o200))
+    (#(#f) aborts
+     (#o360))
+    (#(#f) aborts
+     (#o361))
+    (#(#f #f #f #f) error ; aborts
+     (#o370 #o200 #o200 #o200))
+    (#(#f #f #f #f) error ;; aborts
+     (#o371 #o200 #o200 #o200))
+    (#(#f) error ;; aborts
+     (#o370))
+    (#(#f) error ;; aborts
+     (#o371))
+    (#(#f #f) error ; aborts
+     (#o370 #o200))
+    (#(#f #f) error ;; aborts
+     (#o371 #o200))
+    (#(#f #f #f) error ; aborts
+     (#o370 #o200 #o200))
+    (#(#f #f #f) error ;; aborts
+     (#o371 #o200 #o200))
+    (#(#f #f #f #f #f) error ; aborts
+     (#o374 #o200 #o200 #o200 #o200))
+    (#(#f #f #f #f #f) error ;; aborts
+     (#o375 #o200 #o200 #o200 #o200))
+    (#(#f) error ;; aborts
+     (#o374))
+    (#(#f) error ;; aborts
+     (#o375))
+    (#(#f #f) error ; aborts
+     (#o374 #o200))
+    (#(#f #f) error ;; aborts
+     (#o375 #o200))
+    (#(#f #f #f) error ; aborts
+     (#o374 #o200 #o200))
+    (#(#f #f #f) error ;; aborts
+     (#o375 #o200 #o200))
+    (#(#f #f #f #f) error ; aborts
+     (#o374 #o200 #o200 #o200))
+    (#(#f #f #f #f) error ; aborts
+     (#o375 #o200 #o200 #o200))
+    (#(#f) aborts
+     (#o337))
+    (#(#f #f) aborts
+     (#o357 #o277))
+    (#(#f #f #f) aborts
+     (#o364 #o277 #o277))
+    (#(#f #f #f) error ;; aborts
+     (#o365 #o277 #o277))
+    (#(#f #f #f) error ;; aborts
+     (#o366 #o277 #o277))
+    (#(#f #f #f) error ;; aborts
+     (#o367 #o277 #o277))
+    (#(#f #f #f #f) error ;; aborts
+     (#o373 #o277 #o277 #o277))
+    (#(#f #f #f #f #f) error ; aborts
+     (#o375 #o277 #o277 #o277 #o277))
+    ;; Concatenation of incomplete sequences
+    (#(#f #f #f #f #f #f #f #f #f) error/aborts
+     (#o300 #o340 #o200 #o360 #o200 #o200 #o361 #o200 #o200)
+     3)
+    ;; Impossible bytes
+    (#(#f) error
+     (#o376))
+    (#(#f) error
+     (#o377))
+    (#(#f #f #f #f) error
+     (#o376 #o376 #o377 #o377))
+    ;; Overlong
+    (#(#f #f) error
+     (#o300 #o257))
+    (#(#f #f #f) error
+     (#o340 #o200 #o257))
+    (#(#f #f #f #f) error
+     (#o360 #o200 #o200 #o257))
+    (#(#f #f #f #f #f) error
+     (#o370 #o200 #o200 #o200 #o257))
+    (#(#f #f #f #f #f #f) error
+     (#o374 #o200 #o200 #o200 #o200 #o257))
+    (#(#f #f) error
+     (#o301 #o277))
+    (#(#f #f #f) error
+     (#o340 #o237 #o277))
+    (#(#f #f #f #f) error
+     (#o360 #o217 #o277 #o277))
+    (#(#f #f #f #f #f) error
+     (#o370 #o207 #o277 #o277 #o277))
+    (#(#f #f #f #f #f #f) error
+     (#o374 #o203 #o277 #o277 #o277 #o277))
+    (#(#f #f) error
+     (#o300 #o200))
+    (#(#f #f #f) error
+     (#o340 #o200 #o200))
+    (#(#f #f #f #f) error
+     (#o360 #o200 #o200 #o200))
+    (#(#f #f #f #f #f) error
+     (#o370 #o200 #o200 #o200 #o200))
+    (#(#f #f #f #f #f #f) error
+     (#o374 #o200 #o200 #o200 #o200 #o200))
+    ;; illedgal surrogates
+    (#(#f #f #f) error
+     (#o355 #o240 #o200))
+    (#(#f #f #f) error
+     (#o355 #o255 #o277))
+    (#(#f #f #f) error
+     (#o355 #o256 #o200))
+    (#(#f #f #f) error
+     (#o355 #o257 #o277))
+    (#(#f #f #f) error
+     (#o355 #o260 #o200))
+    (#(#f #f #f) error
+     (#o355 #o276 #o200))
+    (#(#f #f #f) error
+     (#o355 #o277 #o277))
+    (#(#f #f #f #f #f #f) error
+     (#o355 #o240 #o200 #o355 #o260 #o200))
+    (#(#f #f #f #f #f #f) error
+     (#o355 #o240 #o200 #o355 #o277 #o277))
+    (#(#f #f #f #f #f #f) error
+     (#o355 #o255 #o277 #o355 #o260 #o200))
+    (#(#f #f #f #f #f #f) error
+     (#o355 #o255 #o277 #o355 #o277 #o277))
+    (#(#f #f #f #f #f #f) error
+     (#o355 #o256 #o200 #o355 #o260 #o200))
+    (#(#f #f #f #f #f #f) error
+     (#o355 #o256 #o200 #o355 #o277 #o277))
+    (#(#f #f #f #f #f #f) error
+     (#o355 #o257 #o277 #o355 #o260 #o200))
+    (#(#f #f #f #f #f #f) error
+     (#o355 #o257 #o277 #o355 #o277 #o277))
+    ;; 0xFFFE and 0xFFFF
+    (#(#xFFFE) complete
+     (#o357 #o277 #o276))
+    (#(#xFFFF) complete
+     (#o357 #o277 #o277))))
+
+(define (string->print s) (map char->integer (string->list s)))
+
+(define bytes->unicode-vector
+  (case-lambda
+   [(s)
+    (list->vector (map char->integer (string->list (bytes->string/utf-8 s))))]
+   [(s start)
+    (bytes->unicode-vector (subbytes s start))]
+   [(s start end)
+    (bytes->unicode-vector (subbytes s start end))]))
+(define (bytes-any->unicode-vector s non-v)
+  (list->vector 
+   (map (lambda (x) (if (= x (char->integer #\?)) non-v x))
+	(map char->integer (string->list (bytes->string/utf-8 s #\?))))))
+(define (unicode-vector->bytes v)
+  (string->bytes/utf-8 (list->string (map integer->char (vector->list v)))))
+
+(define (list->string/eof l)
+  (if (and (pair? l) (eof-object? (car l)) (null? (cdr l)))
+      eof
+      (list->string l)))
+
+(let ([utf-8-iconv (bytes-open-converter "UTF-8" "UTF-8")]
+      [utf-8-iconv-p (bytes-open-converter "UTF-8-permissive" "UTF-8")])
+  ;; First, check some simple conversions
+  (let-values ([(z1 z2 more) (bytes-convert utf-8-iconv #"xyz" 0 3 (bytes))])
+    (test '(0 0 continues) list z1 z2 more))
+  (let-values ([(z1 z2 more) (bytes-convert utf-8-iconv #"xyz" 0 3 (bytes 0))])
+    (test '(1 1 continues) list z1 z2 more))
+  (let-values ([(z1 z2 more) (bytes-convert utf-8-iconv #"xyz" 0 3 (bytes 0 0 0))])
+    (test '(3 3 complete) list z1 z2 more))
+
+  ;; The real tests:
+  (for-each (lambda (p)
+	      (let ([code-points (car p)]
+		    [parse-status (cadr p)]
+		    [s (apply bytes (caddr p))])
+		(if (and (positive? (vector-length code-points))
+			 (vector-ref code-points 0))
+		    (begin
+		      (test (vector-length code-points) bytes-utf-8-length s)
+		      (test code-points bytes->unicode-vector s)
+		      (test code-points bytes-any->unicode-vector s #f)
+		      (test s unicode-vector->bytes code-points)
+		      (test 0 bytes-utf-8-index s 0)
+		      (test (bytes-length s) bytes-utf-8-index 
+			    (bytes-append s #"x")
+			    (vector-length code-points))
+		      (if ((vector-length code-points) . > . 1)
+			  (begin
+			    (test (integer->char (vector-ref code-points 0))
+				  bytes-utf-8-ref s 0)
+			    (test (integer->char (vector-ref code-points
+							     (sub1 (vector-length code-points))))
+				  bytes-utf-8-ref s (sub1 (vector-length code-points)))
+			    (let ([post-1 (bytes-utf-8-index s 1)])
+			      (test #t positive? post-1)
+			      (test (list->vector (cdr (vector->list code-points)))
+				    bytes->unicode-vector s post-1))
+			    (let ([last-1 (bytes-utf-8-index s (sub1 (vector-length code-points)))])
+			      (test #t positive? last-1)
+			      (test code-points
+				    list->vector (append
+						  (vector->list (bytes->unicode-vector s 0 last-1))
+						  (vector->list (bytes->unicode-vector s last-1))))))
+			  (test #f bytes-utf-8-index s 1))
+		      (test-values (list s (bytes-length s) 'complete)
+				   (lambda () (bytes-convert utf-8-iconv s)))
+		      (test (list s) regexp-match #rx"^.*$" s))
+		    (begin
+		      (test code-points bytes-any->unicode-vector s #f)
+		      (test (list->vector (append '(97) (vector->list code-points) '(98)))
+			    bytes-any->unicode-vector (bytes-append #"a" s #"b") #f)
+		      (test (list->vector (append (vector->list code-points) (vector->list code-points)))
+			    bytes-any->unicode-vector (bytes-append s s) #f)
+		      (test #f bytes-utf-8-length s)
+		      (test 0 bytes-utf-8-index s 0)
+		      (let-values ([(s2 n status) (bytes-convert utf-8-iconv s)])
+			(test (case parse-status 
+				[(error/aborts) 'error]
+				[else parse-status ])
+			      'status status))
+		      (let ([convert
+			     (lambda (prefix)
+			       (test (+ (vector-length code-points) (bytes-length prefix))
+				     bytes-utf-8-length (bytes-append prefix s) #\?)
+			       (test (vector-length code-points)
+				     bytes-utf-8-length (bytes-append prefix s) #\? (bytes-length prefix))
+			       (test (if (equal? prefix #"") 
+					 #f 
+					 (integer->char (bytes-ref prefix 0)))
+				     bytes-utf-8-ref (bytes-append prefix s) 0)
+			       (test (if (equal? prefix #"") 
+					 (if (equal? #() code-points)
+					     #f
+					     #\?)
+					 (integer->char (bytes-ref prefix 0)))
+				     bytes-utf-8-ref (bytes-append prefix s) 0 #\?)
+			       (test (if (equal? #() code-points)
+					 (if (equal? #"" prefix)
+					     #f
+					     (integer->char (bytes-ref prefix (sub1 (bytes-length prefix)))))
+					 (integer->char
+					  (or (vector-ref code-points (sub1 (vector-length code-points)))
+					      (char->integer #\?))))
+				     bytes-utf-8-ref (bytes-append prefix s) 
+				     (max 0 (+ (bytes-length prefix) (sub1 (vector-length code-points))))
+				     #\?)
+
+			       (let-values ([(s2 n status) 
+					     (bytes-convert utf-8-iconv-p (bytes-append prefix s))]
+					    [(pl) (bytes-length prefix)])
+				 (case parse-status
+				   [(error)
+				    (test 'complete 'status status)
+				    (test (+ (bytes-length s) pl) 'n n)
+				    (test (+ (vector-length code-points) pl) bytes-length s2)
+				    (test (append (bytes->list prefix)
+						  (map 
+						   (lambda (i) (or i (char->integer #\?)))
+						   (vector->list code-points)))
+					  vector->list (bytes->unicode-vector s2))]
+				   [(error/aborts)
+				    (test 'aborts 'status status)
+				    (let ([code-points (list->vector
+							(reverse
+							 (list-tail
+							  (reverse
+							   (vector->list code-points))
+							  ;; indicates how many to be unused due to abort:
+							  (cadddr p))))])
+				      (test (+ (vector-length code-points) pl) bytes-length s2)
+				      (test (append (bytes->list prefix)
+						    (map 
+						     (lambda (i) (or i (char->integer #\?)))
+						     (vector->list code-points)))
+					    vector->list (bytes->unicode-vector s2)))]
+				   [else
+				    (test parse-status 'status status)])))])
+			(convert #"")
+			(convert #"so"))
+		      (let-values ([(s2 n status) (bytes-convert utf-8-iconv-p (bytes-append s #"xxxxx"))])
+			(test 'complete 'status status)
+			(test '(#"xxxxx") regexp-match #rx#"xxxxx$" s2)
+			(test (+ 5 (bytes-length s)) 'n n))
+		      (test #f regexp-match #rx"^.*$" s)))
+		;; Test byte reading and port positions
+		(let ([v (bytes-any->unicode-vector s #f)])
+		  (define (check-full-read read-all-bytes)
+		    (let ([p (open-input-bytes s)])
+		      (port-count-lines! p)
+		      (read-all-bytes p)
+		      (let-values ([(l c p) (port-next-location p)])
+			(test (vector-length v) 'c c)
+			(test (add1 (vector-length v)) 'p p)))
+		    (let ([p (open-input-string (format "\t~a\t" s))])
+		      (port-count-lines! p)
+		      (read-all-bytes p)
+		      (let-values ([(l c p) (port-next-location p)])
+			(test p 'p (add1 (+ 2 (vector-length v))))
+			(test c 'tab (+ 16
+					(- (vector-length v)
+					   (bitwise-and (vector-length v) 7))))))
+		    (let ([p (open-input-string (format "~a\t~a" s s))])
+		      (port-count-lines! p)
+		      (read-all-bytes p)
+		      (let-values ([(l c p) (port-next-location p)])
+			(test p 'p (add1 (+ 1 (* 2 (vector-length v)))))
+			(test c 'tab (+ 8
+					(- (vector-length v)
+					   (bitwise-and (vector-length v) 7))
+					(vector-length v)))))
+		    (let ([p (open-input-string (format "~a\n~a" s s))])
+		      (port-count-lines! p)
+		      (read-all-bytes p)
+		      (let-values ([(l c p) (port-next-location p)])
+			(test p 'p (+ 2 (* 2 (vector-length v))))
+			(test c 'cr (vector-length v)))))
+		  (check-full-read (lambda (p) (read-bytes 500 p)))
+		  (check-full-read (lambda (p)
+				     (let loop ()
+				       (unless (eof-object? (read-byte p))
+					 (loop)))))
+		  ;; Check result char-by-char:
+		  (let ([p (open-input-bytes s)])
+		    (port-count-lines! p)
+		    (let loop ([old-c 0][old-p 1])
+		      (let ([i (read-char p)])
+			(let-values ([(l c p) (port-next-location p)])
+			  (if (eof-object? i)
+			      (begin
+				(test (cons s old-c) values (cons s c))
+				(test (cons s old-p) values (cons s p)))
+			      (begin
+				(test (cons s (add1 old-c)) values (cons s c))
+				(test (cons s (add1 old-p)) values (cons s p))
+				(loop c p))))))))
+		;; Test read-string decoding
+		(let ([us (apply string (map (lambda (i)
+					       (if i (integer->char i) #\?))
+					     (vector->list code-points)))])
+		  (test us bytes->string/utf-8 s #\?)
+		  (test us read-string (vector-length code-points) (open-input-bytes s))
+		  (test us read-string (* 100 (vector-length code-points)) (open-input-bytes s))
+		  (unless (string=? "" us)
+		    (test (substring us 0 1) read-string 1 (open-input-bytes s)))
+		  (let ([go (lambda (read-string)
+			      (let-values ([(in out) (make-pipe)])
+				(let loop ([i 0])
+				  (unless (= i 10)
+				    (write-bytes s out)
+				    (loop (add1 i))))
+				(close-output-port out)
+				(test #t 'read-10
+				      (let loop ([i 0])
+					(if (= i 10)
+					    (let ([v (read-string 1 in)])
+					      (or (eof-object? v)
+						  (and (test eof `(eof for ,(caddr p) = ,us with ,read-string) v)
+						       #t)))
+					    (let ([rs (read-string (string-length us) in)])
+					      (and (or (equal? us rs)
+						       (test (string->print us) `(,i of 10 for ,(caddr p) with ,read-string) 
+							     (string->print rs)))
+						   (loop (add1 i)))))))))])
+		    (go read-string)
+		    ;; Peek-string at front, consistent with read-string:
+		    (go (lambda (n p)
+			  (let ([a (peek-string n 0 p)]
+				[b (read-string n p)])
+			    (if (equal? a b)
+				a
+				(list a b)))))
+		    ;; Peek-string, using offset calculated from s
+		    (go (let ([pos 0])
+			  (lambda (n p)
+			    (begin0
+			     (peek-string n pos p)
+			     (set! pos (+ (bytes-length s) pos))))))
+		    ;; Read-char
+		    (go (lambda (n p)
+			  (list->string/eof
+			   (let loop ([i 0])
+			     (if (= i n)
+				 null
+				 (cons (read-char p) (loop (add1 i))))))))
+		    ;; Peek-char, consistent with read-char
+		    (go (lambda (n p)
+			    (list->string/eof
+			     (let loop ([i 0])
+			       (if (= i n)
+				   null
+				   (let ([a (peek-char p 0)]
+					 [b (read-char p)])
+				     (if (equal? a b)
+					 (cons a (loop (add1 i)))
+					 (list* #\* a b #\* (loop (add1 i))))))))))
+		    ;; Read-string, one or two at a time
+		    (let ([read-n
+			   (lambda (n p d)
+			     (let loop ([n n][a null])
+			       (if (zero? n)
+				   (apply string-append (reverse a))
+				   (let ([s (read-string (min d n) p)])
+				     (if (eof-object? s)
+					 (if (null? a)
+					     s
+					     (loop 0 a))
+					 (loop (- n (min d n)) (cons s a)))))))])
+		      (go (lambda (n p) (read-n n p 1)))
+		      (go (lambda (n p) (read-n n p 2))))))))
+	    basic-utf-8-tests))
+
+;; Seems like this sort of thing should be covered above, and maybe it
+;;  it after some other corrections. But just in case:
+(let ([check-one
+       (lambda (str)
+	 (for-each
+	  (lambda (str)
+	    (for-each
+	     (lambda (peek?)
+	       (for-each
+		(lambda (byte?)
+		  (let ([p (open-input-string str)])
+		    (test str read-string (string-length str) p)
+		    (test eof 
+			  (if peek? 
+			      (if byte? peek-byte peek-char)
+			      (if byte? read-byte read-char))
+			  p)
+		    (test eof (if byte? read-byte read-char) p)))
+		'(#t #f)))
+	     '(#t #f)))
+	  (list str 
+		(string-append str "a") 
+		(string-append "a" str) 
+		(string-append str str))))])
+  (check-one "a")
+  (check-one "\uA4")
+  (check-one "\u104")
+  (check-one "\u7238")
+  (check-one "\Ua7238")
+  (check-one "\U107238"))
+
+(test '(#o302 #o251) bytes->list (unicode-vector->bytes (vector 169)))
+(test '(#o304 #o250) bytes->list (unicode-vector->bytes (vector 296)))
+
+(test '("\uA9") regexp-match #rx"." "\uA9")
+(test '(#"\302") regexp-match #rx#"." #"\302\251")
+(test '(#"\302") regexp-match #rx#"." "\uA9")
+(test '(#"\302\251") regexp-match #rx"." #"\302\251")
+
+(test #f regexp-match #rx"[a-z]" "\uA9")
+(test '("\uA9") regexp-match #rx"\uA9" "\uA9")
+(test '("\uA9") regexp-match #rx"\uA9+" "\uA9")
+(test '("\uA9\uA9") regexp-match #rx"\uA9+" "\uA9\uA9")
+(test '("\uA9\uA9") regexp-match #rx"\uA9+" "x\uA9\uA9y")
+(test '("\uA9") regexp-match #rx"[a-z\uA9]" "\uA9mm")
+(test '("\uA9mm") regexp-match #rx"[a-z\uA9]+" "\uA9mm")
+(test '("\uA9") regexp-match #rx"[\uA9-\uE9]+" "xx\uA9mm")
+(test '("\uE9") regexp-match #rx"[\uA9-\uE9]+" "xx\uE9mm")
+(test #f regexp-match #rx"[\uA9-\uE9]+" "xx\u129")
+(test #f regexp-match #rx"[\uA9-\uE9]+" "xx\uA8mm")
+(test '("\uE9\uA9") regexp-match #rx"[\uA9-\u128]+" "xx\uE9\uA9mm")
+
+(test #f regexp-match #rx"[^a-z][^a-z]" "\uA9")
+(test #f regexp-match #rx"[^a-z][^a-z]" (string->bytes/utf-8 "\uA9"))
+(test (list (string->bytes/utf-8 "\uA9")) regexp-match #rx#"[^a-z][^a-z]" "\uA9")
+(test (list (string->bytes/utf-8 "\uA9")) regexp-match #rx#"[^a-z][^a-z]" (string->bytes/utf-8 "\uA9"))
+
+;; Nots of patterns and ranges:
+(test #f regexp-match #rx"[^a-z\uA9]" "\uA9mm")
+(test '("") regexp-match #rx"[^a-d\uA9]*" "\uA9mm")
+(test '("xx") regexp-match #rx"[^\uA9-\u128]+" "xx\uA9mm")
+(test '("xx") regexp-match #rx"[^\uA9-\u128]+" "xx\303\251mm")
+(test '("xx\u129mm") regexp-match #rx"[^\uA9-\u128]+" "xx\u129mm")
+(test '("xx\uA8mm") regexp-match #rx"[^\uA9-\u128]+" "xx\uA8mm")
+(test '("xx") regexp-match #rx"[^\uA9-\u128]+" "xx\uE9\uA9mm")
+
+;; 3-char seqs
+(test '("\u1F79") regexp-match #rx"\u1F79" "a\u1F79\u1F79b")
+(test '("\u1F79\u1F79") regexp-match #rx"\u1F79+" "a\u1F79\u1F79b")
+
+(test '("\u1F79\uA9\u1F79r") regexp-match #rx"[c-\u1F79]+" "a\u1F79\uA9\u1F79r")
+(test '("d\u1F79\uA9\u1F79r") regexp-match #rx"[c-\u1F79]+" "d\u1F79\uA9\u1F79r")
+
+(test '("\u2F79") regexp-match #rx"[\u1F79-\u3F79]" "\u2F79")
+(test '("\u1F79") regexp-match #rx"[\u1F79-\u3F79]" "\u1F79")
+(test #f regexp-match #rx"[\u1F79-\u3F79]" "\u1F39")
+(test #f regexp-match #rx"[\u1F79-\u3F79]" "\u1F78")
+
+;; Nots of 3-char seqs:
+(test #f regexp-match #rx"[^\u1F79-\u3F79]" "\u2F79")
+(test #f regexp-match #rx"[^\u1F79-\u3F79]" "\u1F79")
+(test '("\u1F39") regexp-match #rx"[^\u1F79-\u3F79]" "\u1F39")
+(test '("\u1F78") regexp-match #rx"[^\u1F79-\u3F79]" "\u1F78")
+
+
+;; Regexps that shouldn't parse:
+(err/rt-test (regexp "[a--b\u1F78]") exn:fail?)
+(err/rt-test (regexp "[a-b-c\u1F78]") exn:fail?)
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Let Matthew perform some basic sanity checks for locale-sensitive
+;; comparisons:
+(define known-locale? (and (regexp-match "mflatt|matthewf" (path->string (find-system-path 'home-dir)))
+			   (or (regexp-match "linux" (path->string (system-library-subpath)))
+			       (eq? 'macosx (system-type)))))
+
+(printf "Known locale?: ~a~n" known-locale?)
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; String comparison. Relies on the default locale knowing
+;;  about upper A with hat (\303\202) and lower a with hat (\303\242),
+;;  and also relies on a "C" locale that can't encode those
+;;  two characters. It doesn't rely on a relative order of A-hat
+;;  and a-hat --- only that they're the same case-insensitively.
+(when known-locale?
+  (let ()
+    (define (stest r comp? a b)
+      (test r comp? a b)
+      (test r comp? (format "xx~ayy" a) (format "xx~ayy" b))
+      (test r comp? (format "x\000x~ay" a) (format "x\000x~ay" b))
+      (test r comp? (format "x\000~ay" a) (format "x\000~ay" b))
+      (test r comp? (format "x\000~a\000y" a) (format "x\000~a\000y" b)))
+    (define (go c?)
+      (stest #f string=? "A" "a")
+      (stest #t string-ci=? "A" "a")
+      (stest #t string-locale-ci=? "A" "a")
+      (stest #f string=? "\uC2" "\uE2") 
+      (stest #t string-ci=? "\uC2" "\uE2")
+      (stest #f string-locale=? "\uC2" "\uE2")
+      (stest (if c? #f #t) string-locale-ci=? "\uC2" "\uE2")
+      (stest #f string<? "\uE2" "b")
+      (stest (if c? #f #t) string-locale<? "\uE2" "b")
+      (stest #t string>? "\uE2" "b")
+      (stest (if c? #t #f) string-locale>? "\uE2" "b")
+      (stest #t string<? "b" "\uE2")
+      (stest (if c? #t #f) string-locale<? "b" "\uE2")
+      (stest #f string>? "b" "\uE2")
+      (stest (if c? #f #t) string-locale>? "b" "\uE2")
+      (test "ABC" string-locale-upcase "aBc")
+      (test (if c? "\uE2" "\uC2") string-locale-upcase "\uE2")
+      (test (if c? "A\uE2\0B" "A\uC2\0B") string-locale-upcase "a\uE2\0b")
+      (test (if c? "A\uE2\0\uE2\0B" "A\uC2\0\uC2\0B") string-locale-upcase "a\uE2\0\uE2\0b"))
+    (go #f)
+    (parameterize ([current-locale "C"])
+      (go #t))))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;  locale<->UTF-8 conversions
+
+(test #f bytes-open-converter "UTF-8" "nowhere")
+(test #f bytes-open-converter "nowhere" "UTF-8")
+(when known-locale?
+  (let ([c (bytes-open-converter "UTF-8" "")])
+    (test (void) bytes-close-converter c)
+    (test (void) bytes-close-converter c)
+    (err/rt-test (bytes-convert c #"hello") exn:application:mismatch?)))
+
+(define (bytes-encode-... from to)
+  (lambda args
+    (let ([c (bytes-open-converter from to)])
+      (dynamic-wind
+	  void
+	  (lambda ()
+	    (apply bytes-convert c args))
+	  (lambda ()
+	    (bytes-close-converter c))))))
+
+(define bytes-encode-locale->utf-8 (bytes-encode-... "" "UTF-8"))
+(define bytes-encode-utf-8->locale (bytes-encode-... "UTF-8" ""))
+
+;; Relies on a default locale that extends Latin-1:
+(when known-locale?
+  (let-values ([(s l ok?) (bytes-encode-utf-8->locale #"abc")])
+    (test 3 'count l)
+    (test 'complete 'ok ok?))
+  (let-values ([(s l ok?) (bytes-encode-utf-8->locale #"a\300\300")])
+    (test 1 'count l)
+    (test 'error 'ok ok?))
+  (let-values ([(s l ok?) (bytes-encode-utf-8->locale #"a\302\200")])
+    (test 3 'count l)
+    (test 'complete 'ok ok?))
+  (test-values '(#"abcd" 4 complete) (lambda () (bytes-encode-locale->utf-8 #"abcd")))
+  (test-values '(#"bcd" 3 complete) (lambda () (bytes-encode-locale->utf-8 #"abcd" 1)))
+  (test-values '(#"bc" 2 complete) (lambda () (bytes-encode-locale->utf-8 #"abcd" 1 3)))
+  (test-values '(#"a" 1 aborts) (lambda () (bytes-encode-locale->utf-8 #"a\302\200" 0 2)))
+  (test-values '(2 2 complete) (lambda () (bytes-encode-locale->utf-8 #"abcd" 1 3 (make-bytes 2))))
+  (let ([s (make-bytes 10)])
+    (test-values '(2 2 complete) (lambda () (bytes-encode-locale->utf-8 #"abcd" 1 3 s 4 7)))
+    (test 98 bytes-ref s 4)
+    (test 99 bytes-ref s 5))
+  (let ([s (make-bytes 10)])
+    (test-values '(1 1 continues) (lambda () (bytes-encode-locale->utf-8 #"abcd" 1 3 s 4 5)))
+    (test 98 bytes-ref s 4))
+  ;; The rest relies on the "C" locale:
+  (parameterize ([current-locale "C"])
+    (test-values '(#"abc" 3 complete) (lambda () (bytes-encode-utf-8->locale #"abc")))
+    (test-values '(#"a" 1 error) (lambda () (bytes-encode-utf-8->locale #"a\300\300")))
+    (test-values '(#"ab" 2 aborts) (lambda () (bytes-encode-utf-8->locale #"ab\303")))
+    ;; Well-formed, but can't be converted to "C":
+    (test-values '(#"a" 1 error) (lambda () (bytes-encode-utf-8->locale #"a\303\342")))))
+
+(err/rt-test (bytes-encode-utf-8->locale 'ok))
+(err/rt-test (bytes-encode-utf-8->locale "ok"))
+(err/rt-test (bytes-encode-utf-8->locale #"ok" -1))
+(err/rt-test (bytes-encode-utf-8->locale #"ok" 3) exn:application:mismatch?)
+(err/rt-test (bytes-encode-utf-8->locale #"ok" 1 0) exn:application:mismatch?)
+(err/rt-test (bytes-encode-utf-8->locale #"ok" 1 3) exn:application:mismatch?)
+(err/rt-test (bytes-encode-utf-8->locale #"ok" 1 2 'nope))
+(err/rt-test (bytes-encode-utf-8->locale #"ok" 1 2 #"nope"))
+(let ([s (make-string 4)])
+  (err/rt-test (bytes-encode-utf-8->locale #"ok" 1 3 s -1) exn:application:mismatch?)
+  (err/rt-test (bytes-encode-utf-8->locale #"ok" 1 3 s 5) exn:application:mismatch?)
+  (err/rt-test (bytes-encode-utf-8->locale #"ok" 1 3 s 2 1) exn:application:mismatch?)
+  (err/rt-test (bytes-encode-utf-8->locale #"ok" 1 3 s 2 7) exn:application:mismatch?))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; The following tests are derived from SRFI-14
+
+(define (check-all-latin-1 ? l)
+  (for-each (lambda (c)
+	      (test #t ? c))
+	    l)
+  (let loop ([i 0])
+    (unless (= i 256)
+      (unless (memq (integer->char i) l)
+	(test #f ? (integer->char i)))
+      (loop (add1 i)))))
+
+(define (check-all-unicode ? l)
+  (define (unless-in-l ? c)
+    (and (? c)
+	 (not (member c l))))
+  (define (qtest expect f . args)
+    (unless (equal? expect (apply f args))
+      (apply test expect f args)))
+  (for-each (lambda (c)
+	      (test #t ? c))
+	    l)
+  (for-each (lambda (r)
+	      (if (caddr r)
+		  (qtest #f unless-in-l ? (integer->char (car r)))
+		  (let loop ([i (car r)])
+		    (qtest #f unless-in-l  ? (integer->char i))
+		    (unless (= i (cadr r))
+		      (loop (add1 i))))))
+	    (make-known-char-range-list)))
+
+(check-all-latin-1
+ char-lower-case?
+ '(#\a
+   #\b
+   #\c
+   #\d
+   #\e
+   #\f
+   #\g
+   #\h
+   #\i
+   #\j
+   #\k
+   #\l
+   #\m
+   #\n
+   #\o
+   #\p
+   #\q
+   #\r
+   #\s
+   #\t
+   #\u
+   #\v
+   #\w
+   #\x
+   #\y
+   #\z
+   #\u00B5
+   #\u00DF
+   #\u00E0
+   #\u00E1
+   #\u00E2
+   #\u00E3
+   #\u00E4
+   #\u00E5
+   #\u00E6
+   #\u00E7
+   #\u00E8
+   #\u00E9
+   #\u00EA
+   #\u00EB
+   #\u00EC
+   #\u00ED
+   #\u00EE
+   #\u00EF
+   #\u00F0
+   #\u00F1
+   #\u00F2
+   #\u00F3
+   #\u00F4
+   #\u00F5
+   #\u00F6
+   #\u00F8
+   #\u00F9
+   #\u00FA
+   #\u00FB
+   #\u00FC
+   #\u00FD
+   #\u00FE
+   #\u00FF))
+
+;; No upper case in latin-1
+(check-all-latin-1
+ (lambda (x) (and (char-lower-case? x)
+		  (or (eq? x (char-upcase x))
+		      (> (char->integer (char-upcase x)) 255))))
+ '(#\u00B5
+   #\u00DF
+   #\u00FF))
+
+;; Latin-1 uppercase:
+(check-all-latin-1
+ char-upper-case?
+ '(#\A
+   #\B
+   #\C
+   #\D
+   #\E
+   #\F
+   #\G
+   #\H
+   #\I
+   #\J
+   #\K
+   #\L
+   #\M
+   #\N
+   #\O
+   #\P
+   #\Q
+   #\R
+   #\S
+   #\T
+   #\U
+   #\V
+   #\W
+   #\X
+   #\Y
+   #\Z
+   #\u00C0
+   #\u00C1
+   #\u00C2
+   #\u00C3
+   #\u00C4
+   #\u00C5
+   #\u00C6
+   #\u00C7
+   #\u00C8
+   #\u00C9
+   #\u00CA
+   #\u00CB
+   #\u00CC
+   #\u00CD
+   #\u00CE
+   #\u00CF
+   #\u00D0
+   #\u00D1
+   #\u00D2
+   #\u00D3
+   #\u00D4
+   #\u00D5
+   #\u00D6
+   #\u00D8
+   #\u00D9
+   #\u00DA
+   #\u00DB
+   #\u00DC
+   #\u00DD
+   #\u00DE))
+
+;; Extra letters (not lower or upper) in Latin-1:
+(check-all-latin-1
+ (lambda (c)
+   (and (char-alphabetic? c)
+	(not (char-upper-case? c))
+	(not (char-lower-case? c))))
+ '(#\u00AA
+   #\u00BA))
+
+;; Complete titlecase list:
+(check-all-unicode
+ char-title-case?
+ '(#\u01C5
+   #\u01C8
+   #\u01CB
+   #\u01F2
+   #\u1F88
+   #\u1F89
+   #\u1F8A
+   #\u1F8B
+   #\u1F8C
+   #\u1F8D
+   #\u1F8E
+   #\u1F8F
+   #\u1F98
+   #\u1F99
+   #\u1F9A
+   #\u1F9B
+   #\u1F9C
+   #\u1F9D
+   #\u1F9E
+   #\u1F9F
+   #\u1FA8
+   #\u1FA9
+   #\u1FAA
+   #\u1FAB
+   #\u1FAC
+   #\u1FAD
+   #\u1FAE
+   #\u1FAF
+   #\u1FBC
+   #\u1FCC
+   #\u1FFC))
+
+;; Complete whitspace list:
+(check-all-unicode
+ char-whitespace?
+ '(#\u0009
+   #\u000A
+   #\u000B
+   #\u000C
+   #\u000D
+   #\u0020
+   #\u00A0
+   #\u1680
+   #\u2000
+   #\u2001
+   #\u2002
+   #\u2003
+   #\u2004
+   #\u2005
+   #\u2006
+   #\u2007
+   #\u2008
+   #\u2009
+   #\u200A
+   #\u200B
+   #\u2028
+   #\u2029
+   #\u202F
+   #\u3000
+   ;; Post SRFI-14?
+   #\u205F
+   #\u180E))
+
+;; Punctuation in Latin-1:
+(check-all-latin-1
+ char-punctuation?
+ '(#\!
+   #\"
+   #\#
+   #\%
+   #\&
+   #\'
+   #\(
+   #\)
+   #\*
+   #\,
+   #\-
+   #\.
+   #\/
+   #\:
+   #\;
+   #\?
+   #\@
+   #\[
+   #\\
+   #\]
+   #\_
+   #\{
+   #\}
+   #\u00A1
+   #\u00AB
+   ;; #\u00AD ;; Treated as a control character now?
+   #\u00B7
+   #\u00BB
+   #\u00BF))
+
+;; Symbols in Latin-1
+(check-all-latin-1
+ char-symbolic?
+ '(#\$
+   #\+
+   #\<
+   #\=
+   #\>
+   #\^
+   #\`
+   #\|
+   #\~
+   #\u00A2
+   #\u00A3
+   #\u00A4
+   #\u00A5
+   #\u00A6
+   #\u00A7
+   #\u00A8
+   #\u00A9
+   #\u00AC
+   #\u00AE
+   #\u00AF
+   #\u00B0
+   #\u00B1
+   #\u00B4
+   #\u00B6
+   #\u00B8
+   #\u00D7
+   #\u00F7))
+
+;; Complete blank list:
+(check-all-unicode
+ char-blank?
+ '(#\u0009
+   #\u0020
+   #\u00A0
+   #\u1680
+   #\u2000
+   #\u2001
+   #\u2002
+   #\u2003
+   #\u2004
+   #\u2005
+   #\u2006
+   #\u2007
+   #\u2008
+   #\u2009
+   #\u200A
+   #\u200B
+   #\u202F
+   #\u3000
+   ;; Post SRFI-14?
+   #\u205F
+   #\u180E
+   ))
+
+
+;; Every letter, digit, punct, and symbol is graphic
+(check-all-unicode
+ (lambda (c)
+   (and (not (char-graphic? c))
+	(or (char-alphabetic? c)
+	    (char-numeric? c)
+	    (char-punctuation? c)
+	    (char-symbolic? c))))
+ null)
+
+;; Letter, digit, punct, and symbol are distinct
+(check-all-unicode
+ (lambda (c)
+   (> (+ (if (char-alphabetic? c) 1 0)
+	 (if (char-numeric? c) 1 0)
+	 (if (char-punctuation? c) 1 0)
+	 (if (char-symbolic? c) 1 0))
+      1))
+ null)
+
+(check-all-unicode
+ char-iso-control?
+ (append
+  (let loop ([i 0])
+    (if (= i #x20)
+	null
+	(cons (integer->char i) (loop (add1 i)))))
+  (let loop ([i #x7F])
+    (if (= i #xA0)
+	null
+	(cons (integer->char i) (loop (add1 i)))))))
+
+
+(report-errs)
diff --git a/collects/tests/mzscheme/unit.ss b/collects/tests/mzscheme/unit.ss
new file mode 100644
index 0000000000..4d90a6b2f1
--- /dev/null
+++ b/collects/tests/mzscheme/unit.ss
@@ -0,0 +1,606 @@
+
+(load-relative "loadtest.ss")
+
+(SECTION 'unit)
+(require (lib "unit.ss"))
+
+(syntax-test #'(unit))
+(syntax-test #'(unit (import)))
+(syntax-test #'(unit (impLort)))
+(syntax-test #'(unit (impLort) (export) 5))
+(syntax-test #'(unit (import) (expLort) 5))
+(syntax-test #'(unit import (export) 5))
+(syntax-test #'(unit (import) export 5))
+(syntax-test #'(unit (import) (export) . 5))
+(syntax-test #'(unit (import 8) (export) 5))
+(syntax-test #'(unit (import . i) (export) 5))
+(syntax-test #'(unit (import (i)) (export) 5))
+(syntax-test #'(unit (import i 8) (export) 5))
+(syntax-test #'(unit (import i . b) (export) 5))
+(syntax-test #'(unit (import i (b)) (export) 5))
+(syntax-test #'(unit (import i) (export 7) 5))
+(syntax-test #'(unit (import i) (export . a) (define a 6)))
+(syntax-test #'(unit (import i) (export a . b) (define a 5) (define b 6)))
+(syntax-test #'(unit (import i) (export (a x) . b) (define a 5) (define b 6)))
+(syntax-test #'(unit (import i) (export (a 8) b) (define a 5) (define b 6)))
+(syntax-test #'(unit (import i) (export b (a 8)) (define a 5) (define b 6)))
+(syntax-test #'(unit (import i) (export (a . x) b) (define a 5) (define b 6)))
+(syntax-test #'(unit (import i) (export b (a . x)) (define a 5) (define b 6)))
+(syntax-test #'(unit (import i) (export (a x y) b) (define a 5) (define b 6)))
+(syntax-test #'(unit (import i) (export (a x . y) b) (define a 5) (define b 6)))
+(syntax-test #'(unit (import i) (export b (a x . y)) (define a 5) (define b 6)))
+
+(syntax-test #'(unit (import i) (export) (begin 1 . 2)))
+(syntax-test #'(unit (import i) (export b a) (begin (define a 5) (define b 6) . x)))
+(syntax-test #'(unit (import i) (export b a) (begin (define a 5) (define b 6)) (define b 6)))
+
+(syntax-test #'(unit (import) (export) (define-values (3) 5)))
+
+(syntax-test #'(unit (import a) (export (a x) b) (define a 5) (define b 6)))
+(syntax-test #'(unit (import a) (export (a x) (a y)) (define a 5) (define b 6)))
+(syntax-test #'(unit (import i a) (export (a x) b) (define a 5) (define b 6)))
+(syntax-test #'(unit (import b) (export (a x) b) (define a 5) (define b 6)))
+(syntax-test #'(unit (import i j i) (export (a x) b) (define a 5) (define b 6)))
+(syntax-test #'(unit (import i j j) (export (a x) b) (define a 5) (define b 6)))
+(syntax-test #'(unit (import i) (export a a) (define a 5) (define b 6)))
+(syntax-test #'(unit (import i) (export (a x) (b x)) (define a 5) (define b 6)))
+(syntax-test #'(unit (import i) (export (a x) b) (define a 5) (define a 6) (define b 6)))
+(syntax-test #'(unit (import make-i) (export (a x) b) (define a 5) (define-struct i ()) (define b 6)))
+(syntax-test #'(unit (import i) (export (make-a x) b) (define make-a 5) (define-struct a ()) (define b 6)))
+(syntax-test #'(unit (import i) (export (a x) b) (define a 5) (define r 6) (define r 7) (define b 6)))
+
+(syntax-test #'(unit (import i) (export b (a x)) 5))
+(syntax-test #'(unit (import i) (export (a x) b) (define x 5) (define b 6)))
+(syntax-test #'(unit (import i) (export (a x) b) (set! a 5) (define b 6)))
+
+(syntax-test #'(unit (import i) (export) (set! i 5)))
+
+; Empty exports are syntactically ok::
+(error-test #'(compound-unit (import) (link (A (0))) (export (A))) exn:fail:unit?)
+(error-test #'(compound-unit (import) (link (A (0 (B))) (B (0))) (export)) exn:fail:unit?)
+(error-test #'(compound-unit (import) (link (A (0)) (B (0))) (export (A x) (B))) exn:fail:unit?)
+
+; Self-import is now allowed
+; (syntax-test #'(compound-unit (import) (link (A (0 (A)))) (export))) 
+; (syntax-test #'(compound-unit (import) (link (A (0 (A x)))) (export)))
+(test (list (letrec ([x x]) x) 5)
+      'self-import
+      (invoke-unit 
+       (compound-unit
+	(import)
+	(link [U ((unit (import a) (export b) (define x a) (define b 5) (list x a))
+		  (U b))])
+	(export))))
+
+(error-test #'(invoke-unit (unit (import not-defined) (export) 10) not-defined) exn:fail:contract:variable?)
+
+(test #t unit? (unit (import) (export)))
+(test #t unit? (unit (import) (export) 5))
+(test #t unit? (unit (import i) (export (a x)) (define a 8) (define x 5)))
+(test 5 (lambda (f) (invoke-unit f)) (unit (import) (export) 5))
+
+(test #t unit? (unit (import i) (export b a) (begin (define a 5) (define b 6))))
+(test #t unit? (unit (import i) (export b a) 'a (begin (define a 5) (define b 6)) 'b))
+(test #t unit? (unit (import i) (export b a) (begin (define a 5)) (define b 6)))
+(test #t unit? (unit (import i) (export b a) (define a 5) (begin (define b 6))))
+(test #t unit? (unit (import i) (export b a) (define a 5) (begin (define y 7) (define b 6)) (+ y b a)))
+
+(test 3 'embedded-deeply ((invoke-unit (unit (import) (export) (lambda () (define x 3) x)))))
+(test 1 'embedded-deeply-struct ((invoke-unit (unit (import) (export) (lambda () 
+									(define-struct a ())
+									make-a
+									1)))))
+
+; Empty begin is OK in a unit context:
+(test #t unit? (unit (import i) (export) (begin)))
+(test #t unit? (unit (import i) (export) (begin (begin))))
+
+(syntax-test #'(compound-unit))
+(syntax-test #'(compound-unit . x))
+(syntax-test #'(compound-unit (import)))
+(syntax-test #'(compound-unit (import) . x))
+(syntax-test #'(compound-unit (import) (link)))
+(syntax-test #'(compound-unit (import) (link) . x))
+(syntax-test #'(compound-unit import (link) (export)))
+(syntax-test #'(compound-unit (import) link (export)))
+(syntax-test #'(compound-unit (import) (link) export))
+(syntax-test #'(compound-unit ((import)) (link) (export)))
+(syntax-test #'(compound-unit (import) ((link)) (export)))
+(syntax-test #'(compound-unit (import) (link) ((export))))
+(syntax-test #'(compound-unit (import . a) (link) (export)))
+(syntax-test #'(compound-unit (import b . a) (link) (export)))
+(syntax-test #'(compound-unit (import 1) (link) (export)))
+(syntax-test #'(compound-unit (import (a)) (link) (export)))
+(syntax-test #'(compound-unit (import (a . b)) (link) (export)))
+(syntax-test #'(compound-unit (import (a (b))) (link) (export)))
+(syntax-test #'(compound-unit (import ((a) b)) (link) (export)))
+(syntax-test #'(compound-unit (import) (link . a) (export)))
+(syntax-test #'(compound-unit (import) (link a) (export)))
+(syntax-test #'(compound-unit (import) (link (a)) (export)))
+(syntax-test #'(compound-unit (import) (link (a (b)) . c) (export)))
+(syntax-test #'(compound-unit (import) (link (a (b) . c)) (export)))
+(syntax-test #'(compound-unit (import) (link (a (b . c)) (c (d))) (export)))
+(syntax-test #'(compound-unit (import) (link (a (b c . e)) (c (d)) (e (f))) (export)))
+(syntax-test #'(compound-unit (import) (link (a (b 1))) (export)))
+(syntax-test #'(compound-unit (import) (link (a (b))) (export . a)))
+(syntax-test #'(compound-unit (import) (link (a (b))) (export a)))
+(syntax-test #'(compound-unit (import) (link (a (b))) (export (a w) . a)))
+(syntax-test #'(compound-unit (import) (link (a (b))) (export (a 1))))
+(syntax-test #'(compound-unit (import) (link (a (b))) (export (a (x)))))
+(syntax-test #'(compound-unit (import) (link (a (b))) (export (1 w))))
+
+(test #t unit? (compound-unit (import) (link) (export)))
+
+; Simple:
+
+(define m1
+  (unit
+   (import)
+   (export x y a? set-a-b!)
+   
+   (define-struct a (b c))
+
+   (define x 7)
+   (define z 8)
+   (define y (lambda () (* z x)))
+
+   (list x y z)))
+
+(test #t apply (lambda (x y z) (and (= x 7) (= z 8) (procedure? y) (= 0 (procedure-arity y))))
+      (invoke-unit m1))
+
+(test #t apply
+      (lambda (x y-val a? set-a-b!)
+	(and (= x 7) (= y-val 56)
+	     (= 1 (procedure-arity a?))
+	     (= 2 (procedure-arity set-a-b!))))
+      (invoke-unit
+       (compound-unit 
+	(import)
+	(link [M (m1)]
+	      [N ((unit 
+		   (import x y a? set-a-b!)
+		   (export)
+		   (list x (y) a? set-a-b!))
+		  (M x y a? set-a-b!))])
+	(export))))
+
+; Structures:
+
+
+(define m2-1
+  (unit 
+   (import)
+   (export x struct:a a? v y)
+
+   (define x 5)
+   (define-struct a (b c))
+   (define v (make-a 5 6))
+   (define (y v) (a? v))))
+
+(define m2-2
+  (unit
+   (import struct:a a?)
+   (export x? make-x x-z both)
+   
+   (define-syntax a (list #'struct:a #f #'a? (list #f) (list #f) #f))
+
+   (define-struct (x a) (y z))
+   (define both (lambda (v)
+		  (and (a? v) (x? v))))))
+
+(define m2-3
+  (compound-unit
+   (import)
+   (link [O (m2-1)][T (m2-2 (O struct:a) (O a?))])
+   (export [O x struct:a v y]
+	   [T x? make-x x-z both])))
+
+
+(let ([p (open-output-string)])
+  (invoke-unit
+   (compound-unit
+    (import)
+    (link [M (m2-3)]
+	  [N ((unit
+	       (import x v struct:a y x? make-x x-z both)
+	       (export)
+	       (define (filter v)
+		 (if (procedure? v)
+		     `(proc: ,(object-name v))
+		     v))
+	       (display 
+		(map filter (list x v struct:a y make-x x? x-z both))
+		p)
+	       (let ([v2 (make-x 1 2 3 4)])
+		 (display (map filter
+			       (list x (struct-type? struct:a)
+				     v (y v) (y x)
+				     v2
+				     (y v2)
+				     (x? v2)
+				     (both v)
+				     (both v2)))
+			  p)))
+	      (M x v struct:a y x? make-x x-z both))])
+    (export)))
+
+  (test (string-append "(5 #<struct:a> #<struct-type:a> (proc: y)"
+		       " (proc: make-x) (proc: x?)"
+		       " (proc: x-z) (proc: both))"
+		       "(5 #t #<struct:a> #t #f #<struct:x> #t #t #f #t)")
+	get-output-string p))
+
+; Compound with circularity
+
+(define make-z
+  (lambda (x-val)
+    (unit
+     (import z)
+     (export (x z) y)
+     
+     (define x x-val)
+     (define y (lambda () (- z x))))))
+    
+(define z1 (make-z 8))
+(define z2 (make-z 7))
+
+; Dynamic linking
+
+(let ([u
+       (unit
+	(import x)
+	(export)
+	
+	(+ x 8))])
+
+  (test 10 'dynamic (invoke-unit
+		     (unit
+		      (import)
+		      (export w)
+		      
+		      (define w 2)
+
+		      (invoke-unit u w)))))
+
+; Misc
+
+(test 12 'nested-units
+      (invoke-unit
+       (compound-unit
+	(import)
+	(link (a@ ((unit (import) (export s@:a) (define s@:a 5))))
+	      (u@ ((compound-unit
+		    (import a@:s@:a)
+		    (link (r@ ((unit (import a) (export) (+ a 7)) a@:s@:a)))
+		    (export))
+		   (a@ s@:a))))
+	(export))))
+
+; Import linking via invoke-unit
+
+(test '(5 7 (7 7)) 'invoke-unit-linking
+      (let ([u (unit (import x) (export) x)]
+	    [v (unit (import x) (export) (lambda () x))]
+	    [x 5])
+	(list (invoke-unit u x)
+	      (begin 
+		(set! x 7)
+		(invoke-unit u x))
+	      (let ([f (invoke-unit v x)])
+		(list
+		 (f)
+		 (begin
+		   (set! x 2)
+		   (f)))))))
+
+
+; Multiple values
+(test '(1 2 3) 
+      call-with-values
+      (lambda () (invoke-unit (unit (import) (export) (values 1 2 3))))
+      list)
+
+; Units within units:
+
+(define u (unit
+	   (import)
+	   (export)
+	   (define y 10)
+	   (define x 5)
+	   (unit
+	    (import)
+	    (export)
+	    x)))
+(test #t unit? u)
+(define u2 (invoke-unit u))
+(test #t unit? u2)
+(test 5 'invoke-unit-in-unit (invoke-unit u2))
+
+
+; Units and objects combined:
+
+(require (lib "class.ss"))
+
+(define u@
+  (unit (import x) (export)  
+	(class* object% ()
+		(public y)
+		(define y (lambda () x))
+		(super-make-object))))
+(define v (invoke-unit u@ car))
+(test #t class? v)
+(define w (make-object v))
+(test car 'ivar (send w y))
+
+(define c%
+  (class* object% ()
+    (init x)
+    (define -x x)
+    (public z)
+    (define (z) (unit (import) (export) -x))
+    (super-make-object)))
+(define u (send (make-object c% car) z))
+(test #t unit? u)
+(test car 'invoke (invoke-unit u))
+
+(define c%
+  (class* object% () 
+	  (init x) 
+	  (define -x x)
+	  (public y z)
+	  (define (y) -x)
+	  (define (z) (unit (import) (export) (y)))
+	  (super-make-object)))
+(define u (make-object c% 3))
+(define u2 (send u z))
+(test #t unit? u2)
+(test 3 'invoke (invoke-unit u2))
+
+(test (letrec ([x y][y 0]) x) 'invoke 
+      (invoke-unit (unit (import) (export) (define x y) (define y 7) x)))
+
+; Can shadow syntax/macros in unit
+(test #t unit? (unit 
+		 (import) 
+		 (export)
+		 (define define 10)))
+(test #t unit? (unit 
+		 (import) 
+		 (export)
+		 (define lambda 10)))
+
+; Shadowing also ok if it's in the export list:
+(test #t unit? (unit 
+		(import) 
+		(export define-values)
+		(define define-values 10)))
+(test #t unit? (unit 
+		(import) 
+		(export lambda)
+		(define lambda 10)))
+(test #t unit? (unit 
+		(import) 
+		(export [lambda l])
+		(define lambda 10)))
+
+; These are ok, too:
+(test #t unit? (unit
+		(import define)
+		(export)
+		(define define 10)))
+(test #t unit? (let ([define-values 5])
+		 (unit
+		  (import)
+		  (export)
+		  (define define-values 10))))
+(test 10 'invoke-w/shadowed 
+      (let ([define-values 5])
+	(invoke-unit
+	 (unit
+	   (import)
+	   (export define-values)
+	   (define define-values 10)
+	   define-values))))
+	
+; Check set! of shadowed variable:
+(test #t unit? (unit 
+		 (import x)
+		 (export)
+		 (let ([x 10])
+		   (set! x 5))))
+(test #t unit? (unit 
+		 (import x)
+		 (export)
+		 (class object% ()
+		   (field
+		     [x 10])
+		   (set! x 5))))
+(syntax-test #'(let ([x 10])
+		(unit 
+		  (import x)
+		  (export)
+		  (set! x 5))))
+
+; Especially for zodiac:
+(test '(b c 10 b a (c a b) (c b a) (c . c) (a) #t
+	  (nested-b a b c) (a 2 b) (10 b c) (cl-unit-a 12 c))
+      'invoke-w/shadowed-a-lot
+      (let ([a 'bad-a]
+	    [b 'bad-b]
+	    [c 'bad-c]
+	    [struct:d 'bad-d]
+	    [i 'bad-i])
+	(invoke-unit
+	 (unit
+	   (import)
+	   (export b)
+	   (define a 'a)
+	   (define b 'b)
+	   (begin
+	     (define c 'c)
+	     (define-struct d (w)))
+	   (define x '...)
+
+	   (define-struct (e d) ())
+	   (set! x (cons c c))
+
+	   (define i (interface ()))
+
+	   (list
+	    (if (eq? a 'a)
+		b
+		c)
+	    (if (eq? a 'bad-a)
+		b
+		c)
+	    (d-w (make-e 10))
+	    (begin a b)
+	    (begin0 a b)
+	    (let ([ab (list a b)])
+	      (cons c ab))
+	    (letrec ([mk-ba (lambda ()
+			      (list b a))])
+	      (cons c (mk-ba)))
+	    x
+	    (with-continuation-mark 
+	     b a 
+	     (continuation-mark-set->list (current-continuation-marks) b))
+	    (interface? (interface (i)))
+	    (invoke-unit
+	     (unit
+	       (import w a)
+	       (export)
+	       (define b 'nested-b)
+	       (list b w a c))
+	     a b)
+	    (invoke-unit
+	      (compound-unit
+	       (import a)
+	       (link [u ((unit (import c) (export (xa a) (b xb))
+			       (define xa 1)
+			       (define b 2)
+			       (list a b c))
+			 a)])
+	       (export))
+	      b)
+	    (send
+	     (make-object
+	      (class object%
+		(field [a 10])
+		(public tester)
+		(define tester
+		  (lambda () (list a b c)))
+		(super-make-object)))
+	     tester)
+	    (send
+	     (make-object
+	      (class object%
+		(field
+		 [a 10]
+		 [b 12])
+		(public tester)
+		(define tester
+		   (lambda () 
+		     (invoke-unit
+		      (unit 
+			(import)
+			(export)
+			(define a 'cl-unit-a)
+			(list a b c)))))
+		(super-make-object)))
+	     tester))))))
+
+; Not ok if defining an imported name, but error should be about
+; redefining an imported name. (This behavior is not actually tested.)
+(syntax-test #'(unit 
+	       (import define-values) 
+	       (export)
+	       (define define-values 10)))
+
+(test #t unit? (unit 
+		(import define-values) 
+		(export)
+		(let () (define define-values 10) define-values)))
+
+;; Invoke-unit linking in let-bound variables
+(test '(the-x 10) 'invoke 
+      (let ([x 'the-x])
+	(invoke-unit
+	 (unit (import w) (export)
+	       (list w 10))
+	 x)))
+
+;; ----------------------------------------
+;; Macro definitions in units
+
+(test 5 'stx-def
+      (invoke-unit
+       (unit 
+	 (import)
+	 (export)
+	 
+	 (define-syntax (five stx) #'5)
+	 five)))
+
+(test 5 'stx-def
+      (let ()
+	(define-values/invoke-unit (x)
+	  (unit 
+	    (import)
+	    (export x)
+	 
+	    (define-syntax (five stx) #'5)
+	    (define x five)))
+	x))
+
+(test 50 'stx-def
+      (let ()
+	(define-values/invoke-unit (x)
+	  (unit 
+	    (import)
+	    (export x)
+	 
+	    (define-syntax (five stx) #'fifty)
+	    (define fifty 50)
+	    (define x five)))
+	x))
+
+(test 60 'stx-def
+      (let ()
+	(define-values/invoke-unit (x)
+	  (unit 
+	    (import)
+	    (export x sixty)
+	 
+	    (define-syntax (five stx) #'sixty)
+	    (define sixty 60)
+	    (define x five)))
+	x))
+
+(test 70 'stx-def
+      (let ([y 70])
+	(define-values/invoke-unit (x)
+	  (unit 
+	    (import seventy)
+	    (export x)
+	 
+	    (define-syntax (five stx) #'seventy)
+	    (define x five))
+	  #f y)
+	x))
+
+(test 55 'namespace
+      (parameterize ([current-namespace (make-namespace)])
+	(namespace-variable-bind/invoke-unit
+	 (x)
+	 (unit 
+	   (import)
+	   (export x)
+	   
+	   (define-syntax (five stx) #'55)
+	   (define x five)))
+	(eval 'x)))
+
+
+(report-errs)
diff --git a/collects/tests/mzscheme/unitsig.ss b/collects/tests/mzscheme/unitsig.ss
new file mode 100644
index 0000000000..93aaeb9bb1
--- /dev/null
+++ b/collects/tests/mzscheme/unitsig.ss
@@ -0,0 +1,685 @@
+
+(load-relative "loadtest.ss")
+
+(require (lib "unit.ss"))
+(require (lib "unitsig.ss"))
+(require (lib "include.ss"))
+
+(SECTION 'unit/sig)
+
+(syntax-test #'(define-signature))
+(syntax-test #'(define-signature))
+(syntax-test #'(define-signature 8))
+(syntax-test #'(define-signature . x))
+(syntax-test #'(define-signature x))
+(syntax-test #'(define-signature 8))
+(syntax-test #'(define-signature x (8)))
+(syntax-test #'(define-signature x (a . 8)))
+(syntax-test #'(define-signature x (a . y)))
+(syntax-test #'(define-signature x (y y)))
+(syntax-test #'(define-signature x ((y))))
+(syntax-test #'(define-signature x ((struct))))
+(syntax-test #'(define-signature x ((struct y))))
+(syntax-test #'(define-signature x ((struct . y))))
+(syntax-test #'(define-signature x ((struct y . x))))
+(syntax-test #'(define-signature x ((struct y x))))
+(syntax-test #'(define-signature x ((struct y (x)) . x)))
+(syntax-test #'(define-signature x ((unit))))
+(syntax-test #'(define-signature x ((unit y))))
+(syntax-test #'(define-signature x ((unit . y))))
+(syntax-test #'(define-signature x ((unit y : a))))
+(define-signature a ())
+(syntax-test #'(define-signature x ((unit y a))))
+(syntax-test #'(define-signature x ((unit y . a))))
+(syntax-test #'(define-signature x ((unit y : . a))))
+(syntax-test #'(define-signature x ((unit y a) . x)))
+(syntax-test #'(define-signature x (y (unit y a))))
+
+(syntax-test #'(unit/sig))
+(syntax-test #'(unit/sig 8))
+(syntax-test #'(unit/sig b))
+(define-signature b (x y))
+(syntax-test #'(unit/sig (a)))
+(syntax-test #'(unit/sig a (impLort)))
+(syntax-test #'(unit/sig a (impLort) 5))
+(syntax-test #'(unit/sig a import 5))
+(syntax-test #'(unit/sig a (import . x) . 5))
+(syntax-test #'(unit/sig a (import (x) 8) 5))
+(syntax-test #'(unit/sig a (import (x) . i) 5))
+(syntax-test #'(unit/sig a (import (i : a) . b) 5))
+(syntax-test #'(unit/sig b (import (i : a)) 5))
+(syntax-test #'(unit/sig a (import (i : a x)) 5))
+(syntax-test #'(unit/sig a (import (i : a) x) 5))
+(syntax-test #'(unit/sig b (import (i : a)) (define x 7)))
+(syntax-test #'(unit/sig b (import (i : a)) (define x 7) (define i:y 6)))
+(syntax-test #'(unit/sig blah (import) (define x 7)))
+
+(syntax-test #'(unit/sig () (import) (begin 1 . 2)))
+(syntax-test #'(unit/sig () (import) (begin (define x 5)) (define x 5)))
+
+(define b@ (unit/sig b (import) (define x 9) (define y 9)))
+(define b2@ (unit/sig b (import (i : a)) (define x 9) (define y 9)))
+(define b3@ (unit/sig b (import (i : ())) (define x 9) (define y 9)))
+(define b3u@ (unit/sig b (import ()) (define x 9) (define y 9)))
+(define b3u2@ (unit/sig b (import a) (define x 9) (define y 9)))
+(define-signature >b ((unit b@ : b)))
+(define b3u3@ (unit/sig b (import (i : >b)) (define x 9) (define y 9)))
+
+(define >b@ (compound-unit/sig (import) (link [b@ : b (b@)]) (export (unit b@))))
+
+(syntax-test #'(compound-unit/sig))
+(syntax-test #'(compound-unit/sig 8))
+(syntax-test #'(compound-unit/sig b))
+(syntax-test #'(compound-unit/sig (import) (link) (export (var (U x)))))
+(syntax-test #'(compound-unit/sig (import a) (link) (export)))
+(syntax-test #'(compound-unit/sig (import 5) (link) (export)))
+(syntax-test #'(compound-unit/sig (import . i) (link) (export)))
+(syntax-test #'(compound-unit/sig (import (i : a)) (link ()) (export)))
+(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@)) (export)))
+(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ b)) (export)))
+(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b)) (export)))
+(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b ())) (export)))
+(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@ 5))) (export)))
+(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@ . i))) (export)))
+(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@ (i . a)))) (export)))
+(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@ (i a a)))) (export)))
+(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@ c@))) (export)))
+(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@ (c@ a)))) (export)))
+(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export . b@)))
+(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export b@)))
+(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (unit))))
+(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (unit c@))))
+(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (unit b@ : c))))
+(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (unit b@ (b@)))))
+(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (unit b@ : (b@)))))
+(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var))))
+(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (open))))
+(error-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@ (i : a)))) (export)) exn:fail:unit?)
+(error-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (5 (i : a)))) (export)) exn:fail:unit?)
+(error-test #'(compound-unit/sig (import (i : b)) (link (b@ : b (b3@ (i : b)))) (export)) exn:fail:unit?)
+(error-test #'(compound-unit/sig (import (i : b)) (link (b@ : b (b3u@ (i : b)))) (export)) exn:fail:unit?)
+(error-test #'(compound-unit/sig (import (i : b)) (link (b@ : b (b3u2@ (i : b)))) (export)) exn:fail:unit?)
+(error-test #'(compound-unit/sig (import (i : >b)) (link (b@ : b (b3@ (i : >b)))) (export)) exn:fail:unit?)
+(error-test #'(compound-unit/sig (import (i : ((open a) x))) (link (b@ : b (b3@ (i : ((open a) x))))) (export)) exn:fail:unit?)
+(error-test #'(compound-unit/sig (import (i : ((unit b@ : ((open b) w))))) (link (b@ : b (b3u3@ i))) (export)) exn:fail:unit?)
+(error-test #'(compound-unit/sig (import (i : a)) (link (b@ : (w) (b@))) (export)) exn:fail:unit?)
+(error-test #'(compound-unit/sig (import (i : ())) (link (b@ : b (b3u3@ i))) (export)) exn:fail:unit?)
+(error-test #'(compound-unit/sig (import (i : ((unit b@ : ())))) (link (b@ : b (b3u3@ i))) (export)) exn:fail:unit?)
+(error-test #'(compound-unit/sig (import (i : (b@))) (link (b@ : b (b3u3@ i))) (export)) exn:fail:unit?)
+(error-test #'(compound-unit/sig (import (i : ((unit b@ : (x (unit y : ())))))) (link (b@ : b (b3u3@ i))) (export)) exn:fail:unit?)
+(syntax-test #'(compound-unit/sig (import) (link [b@ : b (0 5)]) (export)))
+(syntax-test #'(compound-unit/sig (import) (link [b@ : b (0 ())]) (export)))
+(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : a (5 (i : b)))) (export)))
+(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var b@))))
+(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var (b@)))))
+(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var (b@ x y)))))
+(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var (5 x)))))
+(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var (b@ 5)))))
+(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var ((b@ w) 5)))))
+(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var ((b@ 7) 5)))))
+(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var (b@ x . a)))))
+
+; Self-import is now allowed
+; (syntax-test #'(compound-unit/sig (import) (link (A : () (0 A))) (export))) ; self-import
+; (syntax-test #'(compound-unit/sig (import) (link (A : (x) (0 A))) (export))) ; self-import
+(test (list (letrec ([x x]) x) 5)
+      'self-import
+      (invoke-unit/sig
+       (compound-unit/sig
+	(import)
+	(link [U : (a) ((unit/sig (a) (import (a)) (rename (b a)) (define x a) (define b 5) (list x a))
+			U)])
+	(export))))
+
+(define-signature not-defined^ (not-defined))
+(error-test #'(invoke-unit/sig (unit/sig () (import not-defined^) 10) not-defined^) exn:fail:contract:variable?)
+
+(test #t unit/sig? (unit/sig a (import)))
+(test #t unit/sig? (unit/sig b (import) (define x 1) (define y 2)))
+(test #t unit/sig? (unit/sig a (import (i : b)) i:x))
+(test 5 (lambda (f) (invoke-unit/sig f ())) (unit/sig a (import ()) 5))
+(test #t unit/sig? (unit/sig (x) (import) (begin (define x 5))))
+(test #t unit/sig? (unit/sig (x) (import) (define a 14) (begin (define x 5) (define y 10)) (define z 12)))
+(test #t unit/sig? (compound-unit/sig (import) (link) (export)))
+(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export)))
+(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b2@ (i : a)))) (export)))
+(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b2@ ((i) : a)))) (export)))
+(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b2@ ((i) : ())))) (export)))
+(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var (b@ x)))))
+(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var (b@ x) w))))
+(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var ((b@) x) w))))
+(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (unit b@))))
+(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (unit (b@)))))
+(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (unit b@ b@))))
+(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (open b@))))
+(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (open (b@ : b)))))
+
+(test #t unit/sig? (compound-unit/sig (import)
+		      (link [compound-unit : () ((unit/sig () (import) 10))])
+		      (export)))
+(test #t unit/sig? (compound-unit/sig 
+		    (import)
+		    (link [export : () ((unit/sig () (import) 10))])
+		    (export)))
+
+; Empty begin is OK in a unit context:
+(test #t unit/sig? (unit/sig () (import) (begin)))
+(test #t unit/sig? (unit/sig () (import) (begin (begin))))
+
+; Include:
+
+(define i1@
+  (unit/sig 
+   ()
+   (import)
+   
+   (include "uinc.ss")))
+
+(test 9 'include (invoke-unit/sig i1@))
+
+;; Nested includes, macros that expand to `(include ...)'
+(define i1.5@
+  (unit/sig 
+   ()
+   (import)
+   
+   (+ 3 4)
+   (include "uinc3.ss")))
+
+(test 9 'include (invoke-unit/sig i1.5@))
+
+(define i2@
+  (unit/sig 
+   ()
+   (import)
+   
+   (include "uinc.ss")
+   (include "uinc2.ss")
+   (include "uinc.ss")
+   (+ x 2)))
+
+(test 10 'include (invoke-unit/sig i2@))
+
+;; Include with begin:
+
+(test 5 'include-begin
+      (invoke-unit/sig
+       (unit/sig ()
+	 (import)
+	 (define x 5)
+	 (include "binc.ss")
+	 y)))
+
+; Simple:
+
+(define-signature m1^
+  (x y a? set-a-b!))
+
+(define m1@
+  (unit/sig 
+   m1^
+   (import)
+   
+   (define-struct a (b c))
+
+   (define x 7)
+   (define z 8)
+   (define y (lambda () (* z x)))
+
+   (list x y z)))
+
+(test #t apply (lambda (x y z) (and (= x 7) (= z 8) (procedure? y) (= 0 (procedure-arity y))))
+      (invoke-unit/sig m1@))
+
+(test #t apply
+      (lambda (x y-val a? set-a-b!)
+	(and (= x 7) (= y-val 56)
+	     (= 1 (procedure-arity a?))
+	     (= 2 (procedure-arity set-a-b!))))
+      (invoke-unit/sig
+       (compound-unit/sig 
+	(import)
+	(link [M@ : m1^ (m1@)]
+	      [N@ : () ((unit/sig
+			 ()
+			 (import (i@ : m1^))
+			 (list i@:x (i@:y) i@:a? i@:set-a-b!))
+			M@)])
+	(export (open M@)))))
+
+; More:
+
+(define-signature m2-1-lite^
+  (xx struct:a v y))
+
+(define-signature m2-1^
+  (a?
+   (open m2-1-lite^)))
+
+(define-signature m2-2^
+  (x? make-x x-z both))
+
+(define m2-1@
+  (unit/sig 
+   m2-1^
+   (import)
+
+   (define xx 5)
+   (define-struct a (b c) (make-inspector))
+   (define v (make-a 5 6))
+   (define (y v) (a? v))))
+
+(define m2-2@
+  (unit/sig
+   m2-2^
+   (import m2-1^)
+
+   (define-syntax a (list #'struct:a #f #f (list #f) (list #f) #f))
+
+   (define-struct (x a) (y z))
+   (define both (lambda (v)
+		  (and (a? v) (x? v))))))
+
+(define-signature m2-3^
+  (simple))
+
+(let-signature m2-3^
+  ((unit one@ : m2-1-lite^)
+   (unit two@ : m2-2^)
+   a?-again)
+
+  (define m2-3@
+    (compound-unit/sig
+     (import)
+     (link [O@ : m2-1^ (m2-1@)]
+	   [T@ : m2-2^ (m2-2@ O@)])
+     (export (unit (O@ : m2-1-lite^) one@)
+	     (unit T@ two@)
+	     (var (O@ a?) a?-again))))
+
+  (let ([p (open-output-string)]
+	[filter (lambda (v)
+		  (if (procedure? v)
+		      `(proc: ,(object-name v))
+		      v))])
+    (invoke-unit/sig
+     (compound-unit/sig
+      (import)
+      (link [M@ : m2-3^ (m2-3@)]
+	    [N@ : () ((unit/sig
+		       ()
+		       (import (i : m2-3^))
+		       (display (map
+				 filter
+				 (list i:one@:xx i:one@:v i:one@:struct:a i:one@:y 
+				       i:two@:make-x i:two@:x? i:two@:x-z i:two@:both
+				       i:a?-again))
+				p)
+		       (let ([v2 (i:two@:make-x 1 2 3 4)])
+			 (display (map
+				   filter
+				   (list i:one@:xx (struct-type? i:one@:struct:a)
+					 i:one@:v (i:one@:y i:one@:v) (i:one@:y i:one@:xx)
+					 v2
+					 (i:one@:y v2)
+					 (i:two@:x? v2)
+					 (i:two@:both i:one@:v)
+					 (i:two@:both v2)))
+				  p)))
+		      M@)])
+      (export)))
+    (test (string-append "(5 #(struct:a 5 6) #<struct-type:a> (proc: y)"
+			 " (proc: make-x) (proc: x?)"
+			 " (proc: x-z) (proc: both) (proc: a?))"
+			 "(5 #t #(struct:a 5 6) #t #f #(struct:x 1 2 ...) #t #t #f #t)")
+	  get-output-string p)))
+
+(test 5 'let-sig
+      (invoke-unit/sig
+       (unit/sig
+	m2-3^
+	(import)
+	(define simple 5)
+	simple)))
+
+(define-signature big^
+  (a b c))
+(define-signature little^
+  (a b c))
+
+(test 11
+      'link-restrict 
+      (invoke-unit/sig
+       (compound-unit/sig
+	(import)
+	(link [a@ : big^ ((unit/sig big^ (import) (define a 5) (define b 6) (define c 7)))]
+	      [b@ : () ((unit/sig () (import (i : little^)) (+ i:a i:b)) 
+			(a@ : little^))])
+	(export))))
+
+(define-signature just-a^
+  (a))
+(define-signature >just-a^
+  ((unit s@ : just-a^)))
+
+; Test a path for linking: root is a constiuent
+(test 12
+      'link-path
+      (invoke-unit/sig
+       (compound-unit/sig
+	(import)
+	(link [a@ : >just-a^ ((compound-unit/sig
+			       (import)
+			       (link [i@ : just-a^ ((unit/sig 
+						     just-a^ 
+						     (import) 
+						     (define a 5)))])
+			       (export (unit i@ s@))))]
+	      [r@ : () ((unit/sig 
+			 () 
+			 (import (i : just-a^))
+			 (+ i:a 7))
+			(a@ s@))])
+	(export))))
+
+; Test a path for linking: root is a constituent, interface is restricted
+(test 12
+      'import-path
+      (invoke-unit/sig
+       (compound-unit/sig
+	(import)
+	(link [a@ : >just-a^ ((compound-unit/sig
+			       (import)
+			       (link [i@ : just-a^ ((unit/sig 
+						     just-a^ 
+						     (import) 
+						     (define a 5)))])
+			       (export (unit i@ s@))))]
+	      [u@ : () ((compound-unit/sig
+			 (import (a@ : >just-a^))
+			 (link [r@ : () ((unit/sig 
+					  () 
+					  (import (i : just-a^))
+					  (+ i:a 7))
+					 (a@ s@))])
+			 (export))
+			a@)])
+	(export))))
+
+; Test a path for linking: 
+(test 85
+      'import-path
+      (invoke-unit/sig
+       (compound-unit/sig
+	(import)
+	(link [zodiac : (z)
+		      ((unit/sig (z)
+			 (import (i))
+			 
+			 (define z 1))
+		       ((export* interface) : (i)))]
+	      [export* : ((unit interface : (i extra)))
+		       ((compound-unit/sig
+			 (import)
+			 (link [interface : (i extra)
+					  ((unit/sig (i extra)
+					     (import)
+					     (define i 1)
+					     (define extra 2)
+					     85))])
+			 (export (unit interface))))])
+	(export))))
+
+; Signature ordering
+
+(define o1 (unit/sig (num sym) (import) (define num 5) (define sym 'a)))
+(define o2 (unit/sig () (import (sym num)) (list sym (+ num))))
+
+(test (list 'a 5)
+      'order
+      (invoke-unit/sig
+       (compound-unit/sig
+	(import)
+	(link [one : (num sym) (o1)]
+	      [two : () (o2 one)])
+	(export))))
+
+; unit->unit/sig, etc.
+
+(define-signature s1
+  (a b c))
+(define-signature s2
+  (+))
+
+(define us1 
+  (unit
+   (import +)
+   (export a b c)
+   
+   (define a 1)
+   (define b 2)
+   (define c 3)
+   (+ a b c)))
+   
+(test 6 'u->s (invoke-unit us1 +))
+(test 6 'u->s (invoke-unit/sig (unit->unit/sig us1 (s2) s1) s2))
+
+; Exporting a name twice:
+
+(syntax-test
+ #'(compound-unit/sig
+    (import)
+    (link [A : (a) ((unit/sig (a) (import) (define a 1)))])
+    (export (var (A a)) (open A))))
+
+(syntax-test
+ #'(compound-unit/sig
+    (import)
+    (link [A : (a) ((unit/sig (a) (import) (define a 1)))]
+	  [B : (b) ((unit/sig (b) (import) (define b 2)))])
+    (export (unit A x) (unit B x))))
+
+(syntax-test
+ #'(compound-unit/sig
+    (import)
+    (link [A : (a) ((unit/sig (a) (import) (define a 1)))]
+	  [B : (b) ((unit/sig (b) (import) (define b 2)))])
+    (export (unit A) (unit B A))))
+
+; Can shadow syntax/macros in unit
+(test #t unit/sig? (unit/sig ()
+		     (import) 
+		     (define define 10)))
+(test #t unit/sig? (unit/sig ()
+		     (import) 
+		     (define lambda 11)))
+
+; Shadowing ok if it's in the export list:
+(test #t unit/sig? (unit/sig (define-values)
+		    (import) 
+		    (define define-values 12)))
+(test #t unit/sig? (unit/sig (lambda)
+		    (import) 
+		    (define lambda 13)))
+(test #t unit/sig? (unit/sig (l)
+		    (import) 
+		    (rename (lambda l))
+		    (define lambda 14)))
+
+; These are ok, too:
+(test #t unit/sig? (unit/sig ()
+		    (import (define))
+		    (define define 15)))
+(test #t unit/sig? (let ([define-values 5])
+		     (unit/sig ()
+		      (import)
+		      (define define-values 16))))
+
+; Not ok if defining an imported name, but error should be about
+; redefining an imported name. (This behavior is not actually tested.)
+(syntax-test #'(unit/sig ()
+		 (import (define-values))
+		 (define define-values 17)))
+
+(test #t unit/sig? (unit/sig ()
+		     (import (define-values))
+		     (let () (define define-values 10) define-values)))
+
+;; Invoke-unit linking in let-bound variables
+(define x 'not-the-right-x)
+(test '(the-x 10) 'invoke/sig 
+      (let ([x 'the-x])
+	(invoke-unit/sig
+	 (unit/sig () (import (x))
+		   (list x 10))
+	 (x))))
+
+;; Check -setters, -selectors, and -
+
+(let ([foo-bar 10]
+      [set-foo-bar! 100]
+      [foo@ (unit/sig ((struct foo (bar)))
+	      (import)
+	      (define-struct foo (bar)))])
+  (define-syntax (go stx)
+    (syntax-case stx ()
+      [(_ lookup omit ...)
+       (syntax
+	(invoke-unit/sig
+	 (compound-unit/sig
+	  (import)
+	  (link [FOO : ((struct foo (bar))) (foo@)]
+		[CLIENT : () ((unit/sig ()
+				(import ((struct foo (bar) omit ...)))
+				(if (eq? 'foo-bar 'lookup)
+				    foo-bar
+				    set-foo-bar!))
+			      (FOO : ((struct foo (bar) omit ...))))])
+	  (export))))]))
+
+  (test #t struct-accessor-procedure? (go foo-bar))
+  (test #t struct-mutator-procedure? (go set-foo-bar!))
+  (test 10 'no-sel (go foo-bar -selectors))
+  (test #t struct-mutator-procedure? (go set-foo-bar! -selectors))
+  (test #t struct-accessor-procedure? (go foo-bar -setters))
+  (test 100 'no-set (go set-foo-bar! -setters))
+  (test 10 'no-sel (go foo-bar (- foo-bar)))
+  (test 100 'no-set (go set-foo-bar! (- set-foo-bar!)))
+  (test #t struct-accessor-procedure? (go foo-bar (- set-foo-bar!)))
+  (test #t struct-mutator-procedure? (go set-foo-bar! (- foo-bar)))
+  (test #t struct-accessor-procedure? (go foo-bar (- make-foo)))
+  (test #t struct-mutator-procedure? (go set-foo-bar! (- make-foo))))
+
+;; Definitions and namespace:
+(test 12
+      'def-val
+      (let ()
+	(define-values/invoke-unit/sig (foo)
+	  (unit/sig (foo)
+	    (import) 
+	    (define foo 12)))
+	foo))
+(test 120
+      'namespace
+      (parameterize ([current-namespace (make-namespace)])
+	(namespace-variable-bind/invoke-unit/sig
+	 (foo)
+	 (unit/sig (foo)
+	   (import) 
+	   (define foo 120)))
+	(eval 'foo)))
+
+;; -- Macro interaction ----------------------------------------
+
+(define-syntax let-values/invoke-unit/sig
+  (syntax-rules ()
+    [(_ (sig unit) exp ...)
+     (let ()
+       (define-values/invoke-unit/sig sig unit)
+       (let () exp ...))]))
+
+(define-signature b (y z))
+(define-signature a (x (open b)))
+(define-signature c (x (unit i : b)))
+
+(define u@ (unit/sig a
+	     (import)
+	     (define x 1)
+	     (define y 2)
+	     (define z 3)))
+
+(test '(1 2 3) 'macro-unitsig
+      (let-values/invoke-unit/sig ((x y z) u@) (list x y z)))
+(test '(1 2 3) 'macro-unitsig
+      (let-values/invoke-unit/sig ((x (open b)) u@) (list x y z)))
+
+(define-syntax goo
+  (syntax-rules ()
+    [(_ id body)
+     (let-values/invoke-unit/sig ((x id) u@) body)]))
+
+(test '(0 2 0) 'macro-unitsig
+      (let ([x 0][y 0][z 0])
+	(goo y (list x y z))))
+
+(test '(0 2 3) 'macro-unitsig
+      (let ([x 0][y 0][z 0])
+	(goo (open b) (list x y z))))
+
+(define-syntax goow
+  (syntax-rules ()
+    [(_ sid body)
+     (let-values/invoke-unit/sig ((x (open sid)) u@) body)]))
+
+(test '(0 2 3) 'macro-unitsig
+      (let ([x 0][y 0][z 0])
+	(goow b (list x y z))))
+
+(define t@ (compound-unit/sig
+	    (import)
+	    (link [u1 : a (u@)]
+		  [u2 : b (u@)])
+	    (export (open u1) (unit u2 i))))
+
+(test '(1 2 3) 'macro-unitsig
+      (let-values/invoke-unit/sig (c t@) (list x i:y i:z)))
+
+(define-syntax moo
+  (syntax-rules ()
+    [(_ id body)
+     (let-values/invoke-unit/sig ((x id) t@) body)]))
+
+(test '(0 2 3) 'macro-unitsig
+      (let ([x 0][i:y 0][i:z 0])
+	(moo (unit i : b) (list x i:y i:z))))
+
+(define-syntax moow
+  (syntax-rules ()
+    [(_ id body)
+     (let-values/invoke-unit/sig ((x (unit i : id)) t@) body)]))
+
+(test '(0 2 3) 'macro-unitsig
+      (let ([x 0][i:y 0][i:z 0])
+	(moow b (list x i:y i:z))))
+
+(test '(0 2 3) 'macro-unitsig
+      (let ([x 0][i:y 0][i:z 0])
+	(moow (y z) (list x i:y i:z))))
+
+(test '(0 0 3) 'macro-unitsig
+      (let ([x 0][i:y 0][i:z 0])
+	(moow (z) (list x i:y i:z))))
+
+(define-syntax moot
+  (syntax-rules ()
+    [(_ id body)
+     (let-values/invoke-unit/sig ((id (unit i : b)) t@) body)]))
+
+(test '(1 0 0) 'macro-unitsig
+      (let ([x 0][i:y 0][i:z 0])
+	(moot x (list x i:y i:z))))
+
+;; --------------------------------------------------
+	
+(report-errs)
+
diff --git a/collects/tests/mzscheme/will.ss b/collects/tests/mzscheme/will.ss
new file mode 100644
index 0000000000..87ed647703
--- /dev/null
+++ b/collects/tests/mzscheme/will.ss
@@ -0,0 +1,58 @@
+
+(load-relative "loadtest.ss")
+
+(SECTION 'wills)
+
+(test #f will-executor? 5)
+(test #t will-executor? (make-will-executor))
+
+(define we (make-will-executor))
+
+;; Never GC this one:
+(test (void) will-register we test (lambda (x) (error 'bad-will-call)))
+
+; There's no excuse for not GCing half or more:
+(define counter null)
+(let loop ([n 10])
+  (unless (zero? n)
+    (will-register we (cons n null)
+		   (lambda (s)
+		     (set! counter (cons (car s) counter))
+		     12))
+    (loop (sub1 n))))
+(collect-garbage)
+(collect-garbage)
+(let* ([v #f]
+       [t (thread (lambda () (set! v (will-execute we))))])
+  (sleep 0.1)
+  (test #f thread-running? t)
+  (test v values 12))
+(let loop ([m 1])
+  (if (let ([v (will-try-execute we)])
+	(test #t 'good-result (or (not v) (= v 12)))
+	v)
+      (loop (add1 m))
+      (begin
+	(test #t >= m 5)
+	;; Make sure counter grew ok
+	(test m length counter)
+	;; Make sure they're all different
+	(let loop ([l counter])
+	  (unless (or (null? l) (null? (cdr l)))
+	    (test #f member (car l) (cdr l))
+	    (loop (cdr l)))))))
+
+(err/rt-test (will-register we we we))
+(err/rt-test (will-register we we (lambda () 10)))
+(err/rt-test (will-register 5 we (lambda (s) 10)))
+
+(err/rt-test (will-execute "bad"))
+(err/rt-test (will-try-execute "bad"))
+
+(arity-test make-will-executor 0 0)
+(arity-test will-executor? 1 1)
+(arity-test will-register 3 3)
+(arity-test will-execute 1 1)
+(arity-test will-try-execute 1 1)
+
+(report-errs)
diff --git a/collects/tests/mzscheme/ztest.ss b/collects/tests/mzscheme/ztest.ss
new file mode 100644
index 0000000000..6d7bfb6a56
--- /dev/null
+++ b/collects/tests/mzscheme/ztest.ss
@@ -0,0 +1,20 @@
+;; rudimentary test harness for complex math routines in 
+;; zmath.ss 
+
+(require (lib "zmath.ss"))
+
+(define ztest
+  (lambda (z)
+    (printf "z = ~a~n" z)
+    (printf " zabs(z) = ~a~n" (zabs z))
+    (printf " zlog(z) = ~a~n" (zlog z))
+    (printf " zexp(z) = ~a~n" (zexp z))
+    (printf " zsqrt(z) = ~a~n" (zsqrt z))
+    (printf " zsin(z) = ~a~n" (zsin z))
+    (printf " zcos(z) = ~a~n" (zcos z))
+    (printf " ztan(z) = ~a~n" (ztan z))
+    (printf " zasin(z) = ~a~n" (zasin z))
+    (printf " zacos(z) = ~a~n" (zacos z))
+    (printf " zatan(z) = ~a~n" (zatan z))))
+
+(ztest 0.5)
diff --git a/collects/tests/srpersist/srptests.ss b/collects/tests/srpersist/srptests.ss
new file mode 100644
index 0000000000..82540c0ee5
--- /dev/null
+++ b/collects/tests/srpersist/srptests.ss
@@ -0,0 +1,188 @@
+;;; some tests for SrPersist
+
+;; we can't depend on the available of a DBMS for these tests
+;; and most DBMSs don't implement many parts of ODBC
+
+;; but we can test SrPersist-specific procedures
+
+;; we can't construct all possible ODBC values from Scheme (yet)
+;;  so we don't do comparisons against expected results
+;;  basically, looking for segfaults and garbage values
+
+(require (lib "srpersist.ss" "srpersist"))
+
+(define c-types
+ '(sql-c-char
+   sql-c-wchar
+   sql-c-long
+   sql-c-short
+   sql-c-float
+   sql-c-double
+   sql-c-date
+   sql-c-time
+   sql-c-timestamp
+   sql-c-binary
+   sql-c-bit
+   sql-c-tinyint
+   sql-c-slong
+   sql-c-sshort
+   sql-c-stinyint
+   sql-c-ulong
+   sql-c-ushort
+   sql-c-utinyint
+   sql-c-bookmark
+   ; [ODBC 3.0 or greater]
+   sql-c-numeric
+   sql-c-type-timestamp
+   sql-c-type-date
+   sql-c-type-time
+   sql-c-interval-year
+   sql-c-interval-month
+   sql-c-interval-day
+   sql-c-interval-hour
+   sql-c-interval-minute
+   sql-c-interval-second
+   sql-c-interval-year-to-month
+   sql-c-interval-day-to-hour
+   sql-c-interval-day-to-minute
+   sql-c-interval-day-to-second
+   sql-c-interval-hour-to-minute
+   sql-c-interval-hour-to-second
+   sql-c-interval-minute-to-second
+   sql-c-sbigint
+   sql-c-ubigint
+   sql-c-varbookmark
+   ; [ODBC 3.5 or greater]
+   sql-c-guid))
+ 
+(define buff-len 10)
+
+(define buffs-1 
+  (map make-buffer c-types))
+
+(define buffs-2
+  (map (lambda (ty)
+	 (make-buffer ty buff-len))
+       c-types))
+
+(define count 0)
+
+(define results-1
+  (map read-buffer buffs-1))
+
+(define results-2
+  (map (lambda (buff)
+	 (let loop ([n 0])
+	   (if (>= n buff-len)
+	       '()
+	       (cons (read-buffer buff n)
+		     (loop (add1 n))))))
+       buffs-2))
+
+(define results-3
+  (map read-buffer buffs-2))
+
+(define ind-1
+  (make-indicator))
+
+(define ind-2
+  (make-indicator 100))
+
+(define ind-result-1 (read-indicator ind-1))
+
+(define ind-result-2 (read-indicator ind-1 0))
+
+(define ind-result-3 (read-indicator ind-2))
+
+(define ind-result-4 (let loop ([n 0])
+		       (if (>= n 100)
+			   '()
+			   (cons (read-indicator ind-2 n)
+				 (loop (add1 n))))))
+
+(define bi (make-boxed-uint 42))
+
+(printf "~a~n" results-1)
+(printf "~a~n" results-2)
+(printf "~a~n" results-3)
+(printf "~a~n" ind-result-1)
+(printf "~a~n" ind-result-2)
+(printf "~a~n" ind-result-3)
+(printf "~a~n" ind-result-4)
+
+(printf "~a~n" (read-boxed-uint bi))
+
+
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+    
+    
+    
+    
+    
+    
+    
+    
+    
+    
+    
+    
+    
+    
+    
+    
+    
+    
+    
+    
+    
diff --git a/collects/tests/stepper/already-defined.ss b/collects/tests/stepper/already-defined.ss
new file mode 100644
index 0000000000..8f5f52e80b
--- /dev/null
+++ b/collects/tests/stepper/already-defined.ss
@@ -0,0 +1,2 @@
+(define first 3)
+3
\ No newline at end of file
diff --git a/collects/tests/stepper/annotate-test.ss b/collects/tests/stepper/annotate-test.ss
new file mode 100644
index 0000000000..8c48ce0f7a
--- /dev/null
+++ b/collects/tests/stepper/annotate-test.ss
@@ -0,0 +1,706 @@
+(require (prefix annotate: (lib "annotate.ss" "stepper" "private")))
+(require (prefix kernel: (lib "kerncase.ss" "syntax")))
+(require (lib "syncheck-debug.ss" "drscheme" "private"))
+(require (lib "marks.ss" "stepper" "private"))
+(require "tests-common.ss")
+
+(load "/Users/clements/plt/tests/mzscheme/testing.ss")
+
+(reset-namespaces) 
+
+(SECTION 'stepper-annotater)
+
+
+; check-mark : test the validity of a mark.  the symbols in 'binding-ids' must be included. the symbols
+; in excluded-ids must not appear in the list.  If binding-ids is 'all, then no symbols other than those
+; in the binding-ids may appear.
+; 
+; note: cheap hack: if a string is supplied rather than a symbol in binding-ids, it passes if the string
+; is a prefix of (symbol->string) of one of the present symbols.
+; (syntax-object (listof (union symbol string)) (union (listof symbol) 'all) -> void)
+
+(define (binding-match? input actual)
+  (if (string? input)
+      (and (>= (string-length (symbol->string actual)) (string-length input))
+           (string=? (substring (symbol->string actual) 0 (string-length input)) input))
+      (eq? input actual)))
+
+(define (check-mark mark-stx binding-ids excluded-ids) 
+  (let* ([bindings (syntax-case mark-stx (lambda )
+                     [(lambda ()
+                        (mark-maker
+                         source
+                         label
+                         . bindings))
+                      (let loop ([binding-list (syntax->list (syntax bindings))])
+                        (cond [(null? binding-list) null]
+                              [(null? (cdr binding-list)) 
+                               (error 'check-mark "odd number of elements in binding list: ~a" (syntax-object->datum (syntax bindings)))]
+                              [else
+                               (let* ([quoted-stx (stx-protector-stx (syntax-e (cadr binding-list)))])
+                                 (when (not (module-identifier=?
+                                             (car binding-list)
+                                             quoted-stx))
+                                   (error 'check-mark "binding pair does not match: ~a, ~a" (syntax-object->datum (car binding-list))
+                                          (syntax-object->datum (cadr binding-list))))
+                                 (when (not (identifier? (car binding-list)))
+                                   (error 'check-mark "syntax object is not an identifier: ~a" (syntax-object->datum (car bindings-list))))
+                                 (cons (syntax-e (car binding-list))
+                                     (loop (cddr binding-list))))]))])])
+    (let loop ([remaining bindings])
+      (unless (null? remaining)
+        (when (memq (car remaining) (cdr remaining))
+          (error 'check-mark "binding ~a appears twice in binding-list: ~a" (car remaining) bindings))
+        (loop (cdr remaining))))
+    (for-each (lambda (desired)
+                (unless (ormap (lambda (binding)
+                                 (binding-match? desired binding))
+                               bindings)
+                  (error 'check-mark "binding ~a not contained in binding-list: ~a" desired bindings)))
+              binding-ids)
+    (if (eq? excluded-ids 'all)
+        (for-each (lambda (binding)
+                    (unless (ormap (lambda (binding-id)
+                                     (binding-match? binding-id binding))
+                                   binding-ids)
+                      (error 'check-mark "binding ~a does not appear in desired list: ~a" binding binding-ids)))
+                  bindings)
+        (for-each (lambda (not-desired)
+                    (when (memq not-desired bindings)
+                      (error 'check-mark "excluded binding ~a contained in binding-list: ~a" not-desired bindings)))
+                  excluded-ids))))
+
+; test cases
+
+(syntax-case (expand #'(let ([a 1] [b 2]) (begin a b))) (let-values begin)
+  [(let-values bindings a b)
+   (begin
+     (err/rt-test (check-mark (let* ([a-var #'a]) (make-full-mark #'3 'a (list a-var a-var))) '() '()) exn:user?) ; binding appears twice
+     (test (void) check-mark (make-full-mark #'3 'a (list #'a #'b)) '(a b) 'all)
+     (err/rt-test (check-mark (make-full-mark #'3 'a (list #'a #'b)) '(a b c) 'all) exn:user?) ; c isn't there
+     (err/rt-test (check-mark (make-full-mark #'3 'a (list #'a #'b)) '(a) 'all) exn:user?) ; bad 'all
+     (test (void) check-mark (make-full-mark #'3 'a (list #'a #'b)) '(a) '(c))
+     (err/rt-test (check-mark (make-full-mark #'3 'a (list #'a #'b)) '(a) '(b c)) exn:user?) ; b is there
+     (test (void) check-mark (make-full-mark #'3 'a (list #'a #'b)) '(a) '())
+     (test (void) check-mark (make-full-mark #'3 'a (list #'arg0-436 #'c)) '("arg0" c) '())
+     (err/rt-test (check-mark (make-full-mark #'3 'a (list #'arg0-436 #'c)) '("djs") '()) exn:user?))])
+
+; syntax-symbol=? : compares a list of symbols to a given symbol (or to each other if sym = #f)
+; (union symbol #f) (listof syntax-object) -> boolean
+
+(define (syntax-symbol=? sym lostx)
+  (if sym
+      (andmap (lambda (stx) (eq? sym (syntax-e stx))) lostx)
+      (if (pair? lostx)
+          (andmap (lambda (stx) (eq? (syntax-e stx) (syntax-e (car lostx)))) lostx)
+          #t)))
+
+(define (wrap-expand-unwrap stx language-level-spec)
+  (let* ([wrapped (datum->syntax-object #f `(module test-module ,language-level-spec
+                                              ,@stx))]
+         [expanded (expand wrapped)])
+    (with-syntax ([(module name lang (_ . exprs)) expanded])
+      (syntax->list (syntax exprs)))))
+
+(test '((if (#%app verify-boolean (#%datum . 3) 'if) (#%datum . 4) (#%datum . 5)))
+      map syntax-object->datum (wrap-expand-unwrap (list #'(if 3 4 5)) '(lib "htdp-beginner.ss" "lang")))
+         
+(define (annotate-exprs-no-break stx-list)
+  (annotate-exprs (map expand stx-list) void))
+
+(define (namespace-annotate-expr stx namespace)
+  ;(when (syntax? stx)
+  ;  (error 'namespace-rewrite-expr "namespace-rewrite-expr accepts s-exps, not syntax-objects"))
+  (parameterize ([current-namespace namespace])
+    (let*-values ([(annotated new-env)
+                   (annotate:annotate (expand stx) annotate:initial-env-package break 'foot-wrap)])
+      annotated)))
+
+; the following procedure is used to test just the top-level-rewrite part of the annotater:
+
+(define (namespace-rewrite-expr stx namespace)
+  ;(when (syntax? stx)
+  ;  (error 'namespace-rewrite-expr "namespace-rewrite-expr accepts s-exps, not syntax-objects"))
+  (parameterize ([current-namespace namespace])
+    (annotate:top-level-rewrite (expand stx))))
+
+; strip-outer-lambda takes off a lambda wrapped around a test expression. For testing purposes,
+; we often want to establish lexical bindings, then strip them off to check the test expr
+
+(define (strip-outer-lambda stx)
+  (syntax-case stx (lambda begin with-continuation-mark)
+    [(with-continuation-mark
+      debug-key-1
+      debug-mark-1
+      (closure-storing-proc
+       (lambda args
+         content)
+       debug-mark-2))
+     (syntax content)]))
+
+
+; test case:
+(test #t 
+      (lambda ()
+        (syntax-case  (strip-outer-lambda (car (annotate-exprs-no-break (list #'(lambda (a b c) 3)))))
+          (with-continuation-mark lambda quote-syntax #%datum)
+          [(with-continuation-mark 
+            key
+            bogus-key
+            (begin
+              break-proc-1
+              (#%datum . 3)))
+           #t])))
+
+(define (strip-return-value-wrap stx)
+  (syntax-case stx (let*)
+    [(let* ([result-var-0 expr])
+       break-0
+       result-var-1)
+     (begin
+       (test 'result syntax-e (syntax result-var-0))
+       (test 'result syntax-e (syntax result-var-1))
+       (syntax expr))]))
+
+(test 'a syntax-e
+      (strip-return-value-wrap 
+       (syntax-case (car (annotate-exprs-no-break (list #'a))) (with-continuation-mark begin)
+         [(with-continuation-mark
+           key-0
+           mark-0
+           (begin
+             break-0
+             expr))
+          (syntax expr)])))
+     
+; test notes to myself:
+; the never-undefined property can only be tested in the non-foot-wrap modes
+; hard to test 3D values like closure-capturing-proc
+; hard to test whether the source pointer is right.
+
+(define test-cases
+  ; begin
+  (list (list (list #'(lambda (a b c) (begin a b (begin a c))))
+              (lambda (stx)
+                (syntax-case (strip-outer-lambda stx) (with-continuation-mark begin)
+                  [(with-continuation-mark
+                    debug-key-1
+                    debug-mark-1
+                    (begin
+                      pre-break-1
+                      (begin
+                        (with-continuation-mark
+                         debug-key-2
+                         debug-mark-2
+                         a-var-0)
+                        (with-continuation-mark
+                         debug-key-3
+                         debug-mark-3
+                         b-var-0)
+                        (with-continuation-mark
+                         debug-key-4
+                         debug-mark-4
+                         begin-body-4))))
+                   (begin
+                     (test 'a syntax-e (syntax a-var-0))
+                     (test 'b syntax-e (syntax b-var-0))
+                     (test (void) check-mark (syntax debug-mark-1) '(a b c) 'all)
+                     (test (void) check-mark (syntax debug-mark-2) '() 'all)
+                     (test (void) check-mark (syntax debug-mark-3) '() 'all)
+                     (test (void) check-mark (syntax debug-mark-4) '(a c) 'all))])))
+         
+        ; lambda : general test
+        (list (list #'(lambda (a b) (lambda (b c) (+ b c) (+ a b 4))))
+              (lambda (stx)
+                (syntax-case (strip-outer-lambda stx) (with-continuation-mark begin lambda)
+                  [(with-continuation-mark
+                    debug-key
+                    debug-mark-1
+                    (begin
+                      pre-break-1
+                      (closure-capturing-proc
+                       (lambda (b c) 
+                         (with-continuation-mark
+                          debug-key-2
+                          debug-mark-lambda-body
+                          (begin
+                            pre-break-2
+                            (begin
+                              . begin-bodies))))
+                       debug-mark-3)))
+                    (begin (test (void) check-mark (syntax debug-mark-1) '(a) 'all)
+                           (test (void) check-mark (syntax debug-mark-3) '(a) 'all))])))
+        
+        ; improper arg-list:
+        (list (list #'(lambda (a b . c) (begin b c)))
+              (lambda (stx)
+                (syntax-case stx (with-continuation-mark begin lambda)
+                  [(with-continuation-mark
+                    key-0
+                    mark-0
+                    (closure-capturing-proc
+                     (lambda (a b . c)
+                       (with-continuation-mark
+                        key-1
+                        mark-1
+                        body))
+                     mark-2))
+                   (begin (test (void) check-mark (syntax mark-0) '() 'all)
+                          (test (void) check-mark (syntax mark-1) '(b c) 'all)
+                          (test (void) check-mark (syntax mark-2) '() 'all))])))
+                    
+        ; test of lambda's one-label inferred-names :
+        (list (list #'(define (a x) (+ x 1)))
+              (lambda (stx)
+                (kernel:kernel-syntax-case stx #f
+                   [(define-values (a)
+                      (with-continuation-mark
+                       debug-key
+                       debug-mark
+                       (closure-capturing-proc
+                        lambda-exp
+                        closure-info)))
+                    (test 'a syntax-property (syntax lambda-exp) 'inferred-name)])))
+        
+        ; test of lambda's cons-pair inferred-names (that is, with lifting):
+        (list (list #'(let ([a (lambda (x) (+ x 1))]) 3))
+              (lambda (stx)
+                (syntax-case stx (let*-values with-continuation-mark begin set!-values set!)
+                   [(let*-values _c
+                       (with-continuation-mark debug-key_1 debug_mark_1
+                                               ;(begin
+                                               ;  (break-proc_1)
+                                                 (begin
+                                                   (set!-values a-label
+                                                                (with-continuation-mark
+                                                                 debug-key
+                                                                 debug-mark
+                                                                 (closure-capturing-proc
+                                                                  lambda-exp
+                                                                  closure-info
+                                                                  lifter-val)))
+                                                   (set! counter 1)
+                                                   body)
+                                               ;  )
+                                               ))
+                    (test 'a syntax-property (syntax lambda-exp) 'inferred-name)])))
+        
+        ; case-lambda
+        (list (list #'(lambda (d e) (case-lambda ((b) b d) ((c) c e))))
+              (lambda (stx)
+                (syntax-case (strip-outer-lambda stx) (with-continuation-mark lambda quote-syntax)
+                  [(with-continuation-mark
+                    debug-key
+                    debug-mark-1
+                    (begin
+                      pre-break-1
+                      (closure-storing-proc
+                       (case-lambda ((b) . bodies_1)
+                                    ((c) . bodies_2))
+                       closure-info)))
+                   (test (void) check-mark (syntax debug-mark-1) '(d e) '(b c))])))
+        
+        ; if
+        (list (list #'(lambda (a b c d) (if (a b) (a c) (a d))))
+              (lambda (stx)
+                (syntax-case (strip-outer-lambda stx) (with-continuation-mark if let-values begin let)
+                  [(let ([test-0 *unevaluated*-0])
+                     (with-continuation-mark
+                      debug-key_1
+                      debug-mark-1
+                      (begin
+                        pre-break-1
+                        (begin
+                          (set! test-1 (let-values temp-bindings
+                                         (with-continuation-mark
+                                          debug-key_2
+                                          debug-mark-test
+                                          . test-clauses)))
+                          (break-0)
+                          (if test-2
+                              (let-values temp-bindings_2
+                                (with-continuation-mark
+                                 debug-key_3
+                                 debug-mark-then
+                                 . then-clauses))
+                              (let-values temp-bindings-3
+                                (with-continuation-mark
+                                 debug-key-4
+                                 debug-mark-else
+                                 . else-clauses)))))))
+                   (begin
+                     (test 'if-temp syntax-e (syntax test-0))
+                     (test 'if-temp syntax-e (syntax test-1))
+                     (test 'if-temp syntax-e (syntax test-2))
+                     (test (void) check-mark (syntax debug-mark-1) '(a b c d if-temp) '())
+                     (test (void) check-mark (syntax debug-mark-test) '() '(a b c d if-temp))
+                     (test (void) check-mark (syntax debug-mark-then) '(a c) '(b d if-temp))
+                     (test (void) check-mark (syntax debug-mark-else) '(a d) '(b c if-temp)))])))
+        
+        ; one-armed if
+        (list (list #'(lambda (a b c) (if (begin a b) (begin a c))))
+              (lambda (stx)
+                (syntax-case (strip-outer-lambda stx) (with-continuation-mark if let-values begin)
+                  [(let ([test-0 *unevaluated*-0])
+                     (with-continuation-mark
+                      debug-key-1
+                      debug-mark-1
+                      (begin
+                        pre-break-1
+                        (begin
+                          (set! test-1 (with-continuation-mark
+                                        debug-key_2
+                                        debug-mark-test
+                                        . test-clauses))
+                          (break-0)
+                          (if test-2
+                              (with-continuation-mark
+                               debug-key_3
+                               debug-mark-then
+                               . then-clauses))))))
+                   (begin
+                     (test 'if-temp syntax-e (syntax test-0))
+                     (test 'if-temp syntax-e (syntax test-1))
+                     (test 'if-temp syntax-e (syntax test-2))
+                     (test (void) check-mark (syntax debug-mark-1) '(a b c if-temp) 'all)
+                     (test (void) check-mark (syntax debug-mark-test) '() 'all)
+                     (test (void) check-mark (syntax debug-mark-then) '(a c ) 'all))])))
+        
+        ; top-level begin
+        (list (list #'(begin (define a 3) (begin (begin a))))
+              (lambda (stx)
+                (syntax-case stx (begin with-continuation-mark define-values)
+                  [(begin
+                     (define-values . rest)
+                     (begin
+                       (begin
+                         (with-continuation-mark key-3 mark-3 (begin var-break-1 a-exp-3)))))
+                   (test 'a syntax-e (strip-return-value-wrap (syntax a-exp-3)))])))
+        
+        ; begin0
+        (list (list #'(lambda (a b) (begin0 a b)))
+              (lambda (stx)
+                (syntax-case (strip-outer-lambda stx) (begin begin0 with-continuation-mark)
+                  [(with-continuation-mark
+                    key-0
+                    mark-0
+                    (begin
+                      pre-break-0
+                      (begin0
+                        (with-continuation-mark
+                         key-result
+                         mark-result
+                         result-expr)
+                        (with-continuation-mark
+                         key-other
+                         mark-other
+                         other-expr))))
+                   (begin
+                     (test (void) check-mark (syntax mark-0) '(a b) 'all)
+                     (test (void) check-mark (syntax mark-result) '() 'all)
+                     (test (void) check-mark (syntax mark-other) '() 'all))])))
+        
+        ; begin0 : inferred-name transfer
+        (list (list #'(define-values (a) (begin0 (lambda () 3) 4)))
+              (lambda (stx)
+                (syntax-case stx (begin0 define-values with-continuation-mark)
+                  [(define-values names
+                     (with-continuation-mark
+                      key-0
+                      mark-0
+                      (begin0
+                        (with-continuation-mark
+                         key-1
+                         mark-1
+                         (procedure-capturing-proc
+                          procedure
+                          mark-2))
+                        . rest)))
+                   (test 'a syntax-property (syntax procedure) 'inferred-name)])))
+        ; let 
+        (list (list #'(lambda (a b c) (let* ([d b] [e (begin a d)]) (begin a b c d))))
+              (lambda (stx)
+                (syntax-case (strip-outer-lambda stx) (begin with-continuation-mark let*-values set!-values set!)
+                  [(let*-values bindings
+                     (with-continuation-mark
+                      key-0
+                      mark-0
+                      (begin
+                        pre-break-0
+                        ;(begin
+                        ;  break-1
+                          (begin
+                            (set!-values vars-0 (with-continuation-mark key-1 mark-1 body-1))
+                            (set! let-counter-0 1)
+                            (set!-values vars-1 (with-continuation-mark key-2 mark-2 body-2))
+                            (set! let-counter-1 2)
+                            ;(begin
+                            ;  break-2
+                              body-3
+                            ;  )
+                            )
+                        ;  )
+                        )))
+                   (begin
+                     (test (void) check-mark (syntax mark-0) '(a b c d e lifter-d-1 lifter-e-2 let-counter) 'all)
+                     (test '(d) syntax-object->datum (syntax vars-0))
+                     (test '(e) syntax-object->datum (syntax vars-1))
+                     (test (void) check-mark (syntax mark-1) '() 'all)
+                     (test (void) check-mark (syntax mark-2) '() 'all))])))
+        
+        ; letrec --- the only thing that needs to be tested with letrec is that the undefined value is properly used.
+        
+        ; set!
+        (list (list #'(lambda (a b c) (set! a (begin b c))))
+              (lambda (stx)
+                (syntax-case (strip-outer-lambda stx) (begin with-continuation-mark set!)
+                  [(with-continuation-mark
+                    key-0
+                    mark-0
+                    (begin
+                      pre-break-0
+                      (set! var (with-continuation-mark key-1 mark-1 body))))
+                   (begin
+                     (test (void) check-mark (syntax mark-0) '(a b c) 'all)
+                     (test 'a syntax-object->datum (syntax var))
+                     (test (void) check-mark (syntax mark-1) '() 'all))])))
+        
+        ; set! with top-level-var
+        (list (list #'(set! a 9))
+              (lambda (stx)
+                (syntax-case stx (set! with-continuation-mark)
+                  [(with-continuation-mark
+                    key-0
+                    mark-0
+                    (set! var val))
+                   (begin
+                     (test (void) check-mark (syntax mark-0) '(a) 'all)
+                     (test 'a syntax-e (syntax var)))])))
+        
+        ; quote
+        (list (list #'(quote a))
+              (lambda (stx)
+                (syntax-case stx (quote with-continuation-mark)
+                  [(with-continuation-mark
+                    key-0
+                    mark-0
+                    (quote sym))
+                   (begin
+                     (test (void) check-mark (syntax mark-0) '() 'all)
+                     (test 'a syntax-e (syntax sym)))])))
+                     
+        ; quote-syntax
+        (list (list #'(quote-syntax a))
+              (lambda (stx)
+                (syntax-case stx (quote-syntax with-continuation-mark)
+                  [(with-continuation-mark
+                    key-0
+                    mark-0
+                    (quote-syntax sym))
+                   (begin
+                     (test (void) check-mark (syntax mark-0) '() 'all)
+                     (test 'a syntax-e (syntax sym)))])))
+        
+        ; wcm is explicitly not working (as opposed to _lots_ of other forms, which simply won't work in 
+        ; a stepper sense.  Begin0, for example.  I think.  And set!.  etc., etc.
+        
+        ; application
+        
+        (list (list #'(lambda (a b c) (a b)))
+              (lambda (stx)
+                (syntax-case (strip-outer-lambda stx) (let-values with-continuation-mark begin set!)
+                  [(let-values arg-temps
+                     (with-continuation-mark
+                      key-0
+                      mark-0
+                      (begin
+                        pre-break-0
+                        (begin
+                          (set! var-0 (with-continuation-mark key-1 mark-1 sym-1))
+                          (set! var-1 (with-continuation-mark key-2 mark-2 sym-2))
+                          (begin 
+                            break-0
+                            (with-continuation-mark key-3 mark-3 (sym-3 sym-4)))))))
+                   (begin
+                     (test (void) check-mark (syntax mark-0) '(a b "arg0" "arg1") 'all)
+                     (test "arg0" substring (symbol->string (syntax-e (syntax var-0))) 0 4)
+                     (test (void) check-mark (syntax mark-1) '() 'all)
+                     (test 'a syntax-e (syntax sym-1))
+                     (test "arg1" substring (symbol->string (syntax-e (syntax var-1))) 0 4)
+                     (test (void) check-mark (syntax mark-2) '() 'all)
+                     (test 'b syntax-e (syntax sym-2))
+                     (test (void) check-mark (syntax mark-3) '("arg0" "arg1") 'all)
+                     (test "arg0" substring (symbol->string (syntax-e (syntax sym-3))) 0 4)
+                     (test "arg1" substring (symbol->string (syntax-e (syntax sym-4))) 0 4))])))
+        
+        ; application with return-wrap
+        (list (list #'(+ 3 4))
+              (lambda (stx)
+                (syntax-case stx (let-values with-continuation-mark begin set!)
+                  [(let-values arg-temps
+                     (with-continuation-mark
+                      key-0
+                      mark-0
+                      (begin
+                        (set! var-1 rhs-1)
+                        (set! var-2 rhs-2)
+                        (set! var-3 rhs-3)
+                        (begin
+                          break-0
+                          (with-continuation-mark 
+                           key-3
+                           mark-3
+                           result-expr)))))
+                   (syntax-case (strip-return-value-wrap (syntax result-expr)) ()
+                     [(var-4 var-5 var-6)
+                      (begin
+                        (test "arg0" substring (symbol->string (syntax-e (syntax var-4))) 0 4)
+                        (test "arg1" substring (symbol->string (syntax-e (syntax var-5))) 0 4)
+                        (test "arg2" substring (symbol->string (syntax-e (syntax var-6))) 0 4))])])))
+        
+         ; application with non-var in fun pos
+        (list (list #'(4 3 4))
+              (lambda (stx)
+                (syntax-case stx (let-values with-continuation-mark begin set!)
+                  [(let-values arg-temps
+                     (with-continuation-mark
+                      key-0
+                      mark-0
+                      (begin
+                        (set! var-1 rhs-1)
+                        (set! var-2 rhs-2)
+                        (set! var-3 rhs-3)
+                        (begin
+                          break-0
+                          (with-continuation-mark key-3 mark-3 (var-4 var-5 var-6))))))
+                   (begin 
+                     (test "arg0" substring (symbol->string (syntax-e (syntax var-4))) 0 4)
+                     (test "arg1" substring (symbol->string (syntax-e (syntax var-5))) 0 4)
+                     (test "arg2" substring (symbol->string (syntax-e (syntax var-6))) 0 4))])))
+                    
+        ; datum
+        (list (list #'3)
+              (lambda (stx)
+                (syntax-case stx (with-continuation-mark #%datum)
+                  [(with-continuation-mark
+                    key-0
+                    mark-0
+                    (#%datum . 3))
+                   #t])))
+        
+        ; define-values
+        (list (list #'(define-values (a b) b))
+              (lambda (stx)
+                (syntax-case stx (with-continuation-mark define-values)
+                  [(define-values (sym-0 sym-1)
+                     (with-continuation-mark
+                      key-0
+                      mark-0
+                      body))
+                   (begin
+                     (test 'a syntax-e (syntax sym-0))
+                     (test 'b syntax-e (syntax sym-1))
+                     (test (void) check-mark (syntax mark-0) '() 'all))])))
+        
+        ; top-level vars
+        (list (list #'a)
+              (lambda (stx)
+                (syntax-case stx (begin with-continuation-mark)
+                  [(with-continuation-mark
+                    key-0
+                    mark-0
+                    (begin 
+                      break-0
+                      body))
+                   (begin
+                     (test (void) check-mark (syntax mark-0) '() 'all)
+                     (test 'a syntax-e (strip-return-value-wrap (syntax body))))])))
+        
+        ; lexical vars
+        (list (list #'(lambda (a b) a))
+              (lambda (stx)
+                (syntax-case (strip-outer-lambda stx) (begin with-continuation-mark)
+                  [(with-continuation-mark
+                    key-0
+                    mark-0
+                    (begin
+                      pre-break-0
+                      sym-0))
+                   (begin
+                     (test (void) check-mark (syntax mark-0) '(a) 'all)
+                     (test 'a syntax-e (syntax sym-0)))])))
+        
+        ; correct labelling of variables:
+        (list (list #'(lambda (b) (let ([a 13]) (begin a b))))
+              (lambda (stx)
+                (syntax-case (strip-outer-lambda stx) (begin with-continuation-mark let*-values set!-values)
+                  [(let*-values bindings
+                     (with-continuation-mark
+                      key-0
+                      mark-0
+                      (begin
+                        pre-break-0
+                        ;(begin
+                        ;  break-0
+                          (begin
+                            (set!-values (a-var-0) rest0)
+                            (set! counter-0 1)
+                            ;(begin 
+                            ;  break-1
+                              (with-continuation-mark
+                               key-1
+                               mark-1
+                               (begin
+                                 (with-continuation-mark key-2 mark-2 (begin break-2 a-var-1))
+                                 (with-continuation-mark key-3 mark-3 (begin pre-break-1 b-var-0))))
+                            ;  )
+                            )
+                        ;  )
+                        )))
+                   (begin
+                     (test 'a syntax-e (syntax a-var-0))
+                     (test 'a syntax-e (strip-return-value-wrap (syntax a-var-1)))
+                     (test 'b syntax-e (syntax b-var-0))
+                     (test 'let-bound syntax-property (syntax a-var-0) 'stepper-binding-type)
+                     (test 'let-bound syntax-property (strip-return-value-wrap (syntax a-var-1)) 'stepper-binding-type)
+                     (test 'lambda-bound syntax-property (syntax b-var-0) 'stepper-binding-type)
+                     )])))
+                        
+        
+        ))
+
+(for-each (lambda (test-case)
+            ((cadr test-case) (car (annotate-exprs-no-break (car test-case)))))
+          test-cases)
+
+;(namespace-annotate-expr '(or 3 4 5) beginner-namespace)
+  
+(syntax-case (namespace-rewrite-expr '(lambda (a) a) mz-namespace) (lambda)
+  [(lambda (a-var-0) a-var-1)
+   (begin
+     (test 'lambda-bound syntax-property (syntax a-var-0) 'stepper-binding-type)
+     (test 'lexical identifier-binding (syntax a-var-0)) 
+     (test 'lambda-bound syntax-property (syntax a-var-1) 'stepper-binding-type)
+     (test 'lexical identifier-binding (syntax a-var-1)))])
+
+(syntax-case (namespace-rewrite-expr (datum->syntax-object #'here '(case-lambda ((a) a) ((a b) b))) mz-namespace) (case-lambda)
+  [(case-lambda ((a-0) a-1) ((a-2 b-0) b-1))
+   (begin
+     (test 'lexical identifier-binding (syntax b-0))
+     (test 'lexical identifier-binding (syntax b-1)))])
+
+;(syntax-case (car (namespace-rewrite-expr "(or true false true)" beginner-namespace)) (let-values if)
+;  [(let-values ([(or-part-0) true-0]) (if or-part-1 or-part-2 rest))
+;   (begin
+;     (test 'or-part syntax-e (syntax or-part-0))
+;     (test 'let-bound syntax-property (syntax or-part-0) 'stepper-binding-type)
+;     (test 'or-part syntax-e (syntax or-part-1))
+;     (test 'let-bound syntax-property (syntax or-part-1) 'stepper-binding-type))])
+
+(parameterize ([current-namespace beginner-namespace])
+  (err/rt-test (eval (car (annotate-exprs-no-break (string->stx-list "(define first 3)")))) exn:user?))
+
+;(test 7 eval (car (annotate-exprs-no-break (list #'(begin (+ 3 4) (+ 4 5))))))
+;(test 9 eval (car (annotate-exprs-no-break (list #'(begin (+ 3 4) (+ 4 5))))))
+
+(report-errs)
diff --git a/collects/tests/stepper/bad-letrec-test.ss b/collects/tests/stepper/bad-letrec-test.ss
new file mode 100644
index 0000000000..1b42d6b79f
--- /dev/null
+++ b/collects/tests/stepper/bad-letrec-test.ss
@@ -0,0 +1 @@
+(letrec ([a a]) 3)
\ No newline at end of file
diff --git a/collects/tests/stepper/constructor-redexes.ss b/collects/tests/stepper/constructor-redexes.ss
new file mode 100644
index 0000000000..4c95b71786
--- /dev/null
+++ b/collects/tests/stepper/constructor-redexes.ss
@@ -0,0 +1,17 @@
+(cons 3 (cons 1 empty))
+
+(cons 1 2)
+
+(list 1 2 3)
+
+(define-struct a (b))
+
+(make-a 3)
+
+(make-a 4 3 5)
+
+(make-b 32)
+
+(make-b 3 4 5)
+
+(define-struct b (c d e))
diff --git a/collects/tests/stepper/debugger-annotate-test.ss b/collects/tests/stepper/debugger-annotate-test.ss
new file mode 100644
index 0000000000..e3b67c8362
--- /dev/null
+++ b/collects/tests/stepper/debugger-annotate-test.ss
@@ -0,0 +1,6 @@
+(module debugger-annotate-test mzscheme
+  
+  (require (lib "private/debugger-annotate.ss" "stepper"))
+  
+
+  )
\ No newline at end of file
diff --git a/collects/tests/stepper/global-prim-reduction.ss b/collects/tests/stepper/global-prim-reduction.ss
new file mode 100644
index 0000000000..902fcf1d0e
--- /dev/null
+++ b/collects/tests/stepper/global-prim-reduction.ss
@@ -0,0 +1,13 @@
+#t
+
+true
+
+#f 
+
+false
+
+null
+
+empty
+
+pi
diff --git a/collects/tests/stepper/image-test.ss b/collects/tests/stepper/image-test.ss
new file mode 100644
index 0000000000..c0c22557ef
Binary files /dev/null and b/collects/tests/stepper/image-test.ss differ
diff --git a/collects/tests/stepper/intermediate-y.ss b/collects/tests/stepper/intermediate-y.ss
new file mode 100644
index 0000000000..a2bfcfe2ab
--- /dev/null
+++ b/collects/tests/stepper/intermediate-y.ss
@@ -0,0 +1,13 @@
+(let ((Y (lambda (f)
+           (let ((g (lambda (x)
+                      (apply f (list (lambda (z1 z2)
+                           (apply (apply x (list x)) (list z1 z2))))))))
+             (g g))))
+      (newappend (lambda (ap)
+                   (lambda (x y)
+                     (if (null? x)
+                         y
+                         (cons (first x)
+                               (apply ap (list (rest x) y)))))))
+      (l (cons 1 (cons 2 (cons 3 null)))))
+  (apply (Y newappend) (list l l)))
diff --git a/collects/tests/stepper/lambda-test.ss b/collects/tests/stepper/lambda-test.ss
new file mode 100644
index 0000000000..d55e345e4f
--- /dev/null
+++ b/collects/tests/stepper/lambda-test.ss
@@ -0,0 +1,11 @@
+(define ident (lambda (x) (+ (- x 1) 1)))
+
+(ident 14)
+
+(ident 3)
+
+(define (ident-2 x) (+ (- x 1) 1))
+
+(ident-2 14)
+
+(ident-2 3)
diff --git a/collects/tests/stepper/let-test.ss b/collects/tests/stepper/let-test.ss
new file mode 100644
index 0000000000..f816b25c99
--- /dev/null
+++ b/collects/tests/stepper/let-test.ss
@@ -0,0 +1,13 @@
+(define a 15)
+
+; basic testing
+
+(define (test x)
+  (let ([a (+ a 3)]
+        [b (- a 39)])
+    (+ a b)))
+
+(test 1) 
+(test 2)
+
+
diff --git a/collects/tests/stepper/letrec-test.ss b/collects/tests/stepper/letrec-test.ss
new file mode 100644
index 0000000000..e3c9fb7a97
--- /dev/null
+++ b/collects/tests/stepper/letrec-test.ss
@@ -0,0 +1,9 @@
+(define a 15)
+
+(define (test c)
+  (letrec ([a (+ c 13)]
+           [b (+ a 90)])
+    (+ a b)))
+
+(test 13)
+(test 14)
diff --git a/collects/tests/stepper/local-define-struct.ss b/collects/tests/stepper/local-define-struct.ss
new file mode 100644
index 0000000000..2d0ac5433d
--- /dev/null
+++ b/collects/tests/stepper/local-define-struct.ss
@@ -0,0 +1,9 @@
+(define (gen ignored)
+  (local ((define-struct local-struct (local-field))
+          (define silly-def (+ 3 4)))
+    (make-local-struct 13)))
+
+(define p (gen 1))
+(define q (gen 1))
+
+  
\ No newline at end of file
diff --git a/collects/tests/stepper/local-test-2.ss b/collects/tests/stepper/local-test-2.ss
new file mode 100644
index 0000000000..8c9fcb09d9
--- /dev/null
+++ b/collects/tests/stepper/local-test-2.ss
@@ -0,0 +1,10 @@
+(define (create-closure x)
+  (local ((define a 13)
+          (define (closure y)
+            (+ a x y)))
+    closure))
+
+(define closure-1 (create-closure 1))
+(define closure-2 (create-closure 2))
+
+(closure-1 100)
\ No newline at end of file
diff --git a/collects/tests/stepper/local-test.ss b/collects/tests/stepper/local-test.ss
new file mode 100644
index 0000000000..1a445f58a7
--- /dev/null
+++ b/collects/tests/stepper/local-test.ss
@@ -0,0 +1,10 @@
+(+ 14
+   (local
+       ((define (fact x)
+          (if (= x 0)
+              1
+              (* x (fact (- x 1)))))
+        (define nother (lambda (x) x))
+        (define a (+ 3 5))
+        (define b (+ a 13)))
+     (fact b)))
\ No newline at end of file
diff --git a/collects/tests/stepper/long-error-message.ss b/collects/tests/stepper/long-error-message.ss
new file mode 100644
index 0000000000..4ecfdf512c
--- /dev/null
+++ b/collects/tests/stepper/long-error-message.ss
@@ -0,0 +1 @@
+(add1 3 (list 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1))
\ No newline at end of file
diff --git a/collects/tests/stepper/manual-tests b/collects/tests/stepper/manual-tests
new file mode 100644
index 0000000000..4b48437e7f
--- /dev/null
+++ b/collects/tests/stepper/manual-tests
@@ -0,0 +1,8 @@
+open stepper, make sure it works for (+ 3 4).  Make sure it only works
+for the language levels it's supposed to.  Make sure that you get a warning
+when you change the underlying program, and a warning when the program 
+window disappears. Try stepping backward and forward through programs with correct
+and erroneous (syntax errors, runtime errors) executions.  Make sure that the 
+buttons are enabled and disabled as necessary.  Try programs which print snips
+(print-convert-test.ss)
+
diff --git a/collects/tests/stepper/module-elaborator.ss b/collects/tests/stepper/module-elaborator.ss
new file mode 100644
index 0000000000..6822e7a965
--- /dev/null
+++ b/collects/tests/stepper/module-elaborator.ss
@@ -0,0 +1,115 @@
+(module module-elaborator mzscheme
+  
+  (require (lib "list.ss")
+           (lib "contract.ss"))
+
+  (provide/contract [wrap-in-module ((listof syntax?) any/c (listof any/c) . -> . (listof syntax?))] )
+  
+  ;; full-on COPIED from plt/collects/lang/htdp-langs.ss
+  
+  (define (wrap-in-module exps language-module-spec teachpack-specs)
+    (let ([new-module-id (gensym "-htdp")])
+      (with-syntax ([(tp-spec ...) teachpack-specs])
+      (list (let ([mod (expand #`(module #,new-module-id #,language-module-spec 
+                                   (require-for-syntax mzscheme)
+                                   (require tp-spec ...)
+                                   #,@exps))])
+              (rewrite-module mod))
+            #`(require #,new-module-id)
+;            #`(let ([done-already? #f])
+;                (dynamic-wind
+;                 void
+;                 (lambda () (dynamic-require '#,new-module-id #f))
+;                 (lambda () 
+;                   (unless done-already?
+;                     (set! done-already? #t)
+;                     (current-namespace (module->namespace '#,new-module-id))))))
+            ))))
+  
+  ;; rewrite-module : syntax -> syntax
+  ;; rewrites te module to provide all definitions and 
+  ;; print out all results.
+  
+  (define (rewrite-module stx)
+    (syntax-case stx (module #%plain-module-begin)
+      [(module name lang (#%plain-module-begin bodies ...))
+       (with-syntax ([(rewritten-bodies ...) 
+                      (rewrite-bodies (syntax->list (syntax (bodies ...))))])
+         (syntax (module name lang
+                   (#%plain-module-begin 
+                    rewritten-bodies ...))))]
+      [else
+       (raise-syntax-error 'htdp-languages "internal error .1")]))
+  
+  ;; rewrite-bodies : (listof syntax) -> syntax
+  (define (rewrite-bodies bodies)
+    (let loop ([bodies bodies]
+               [ids null])
+      (cond
+        [(null? bodies) 
+         (list
+          (with-syntax ([(ids ...) ids])
+            (syntax (provide ids ...))))]
+        [else
+         (let ([body (car bodies)])
+           (syntax-case body (define-values define-syntaxes require require-for-syntax provide)
+             [(define-values (new-vars ...) e)
+              (cons body (loop (cdr bodies)
+                               (append
+                                ids 
+                                (filter-ids (syntax (new-vars ...))))))]
+             [(define-syntaxes (new-vars ...) e)
+              (cons body (loop (cdr bodies)
+                               (append
+                                ids 
+                                (filter-ids (syntax (new-vars ...))))))]
+             [(require specs ...)
+              (cons body (loop (cdr bodies) ids))]
+             [(require-for-syntax specs ...)
+              (cons body (loop (cdr bodies) ids))]
+             [(provide specs ...)
+              (loop (cdr bodies) ids)]
+             [else 
+              (let ([new-exp
+                     (with-syntax ([body body]
+                                   [print-results
+                                    (lambda (dont-care)
+                                      (void) ; intended to simulate the code in drscheme that actually does something.
+                                      )])
+                       (syntax 
+                         (call-with-values
+                          (lambda () body)
+                          print-results)))])
+                (cons new-exp (loop (cdr bodies) ids)))]))])))
+  
+  (define (filter-ids ids)
+    ;; When a `define-values' or `define-syntax' declaration
+    ;; is macro-generated, if the defined name also originates
+    ;; from a macro, then the name is hidden to anything
+    ;; that wasn't generated by the same macro invocation. This
+    ;; hiding relies on renaming at the symbol level, and it's
+    ;; exposed by the fact that `syntax-e' of the identifier 
+    ;; returns a different name than `identifier-binding'.
+    (filter
+     (lambda (id)
+       (let ([ib (identifier-binding id)])
+         ;; ib should always be a 4-elem list, but
+         ;; check, just in case:
+         (or (not (pair? ib)) 
+             (eq? (syntax-e id)
+                  (cadr ib)))))
+     (syntax->list ids)))
+  
+  
+  ; pathetic 'verified-by-inspection' test case:
+  
+  `(define test-reader
+    (let ([done? #f])
+      (lambda ()
+        (if done?
+            eof
+            (begin
+              (set! done? #t)
+              #'(+ 3 4))))))
+  `(printf "~a\n" (wrap-in-module test-reader `(lib "htdp-beginner.ss" "lang")))
+  )
\ No newline at end of file
diff --git a/collects/tests/stepper/multiply-defined.ss b/collects/tests/stepper/multiply-defined.ss
new file mode 100644
index 0000000000..980be5fe85
--- /dev/null
+++ b/collects/tests/stepper/multiply-defined.ss
@@ -0,0 +1,3 @@
+(define d 3)
+
+(define (d x) 3)
\ No newline at end of file
diff --git a/collects/tests/stepper/name-chaining.ss b/collects/tests/stepper/name-chaining.ss
new file mode 100644
index 0000000000..b2d49515a2
--- /dev/null
+++ b/collects/tests/stepper/name-chaining.ss
@@ -0,0 +1,9 @@
+(define (add-1 x) (+ 1 x))
+
+(define g add-1)
+
+g
+
+(define h g)
+
+(h 4)
\ No newline at end of file
diff --git a/collects/tests/stepper/no-else-clause.ss b/collects/tests/stepper/no-else-clause.ss
new file mode 100644
index 0000000000..c74df07deb
--- /dev/null
+++ b/collects/tests/stepper/no-else-clause.ss
@@ -0,0 +1,3 @@
+(cond [#f 3]
+      [(= 3 4) 4])
+      
\ No newline at end of file
diff --git a/collects/tests/stepper/non-procedure.ss b/collects/tests/stepper/non-procedure.ss
new file mode 100644
index 0000000000..fbb7d3d738
--- /dev/null
+++ b/collects/tests/stepper/non-procedure.ss
@@ -0,0 +1,3 @@
+(define my-var 15)
+
+(my-var 3)
diff --git a/collects/tests/stepper/print-convert-test.ss b/collects/tests/stepper/print-convert-test.ss
new file mode 100644
index 0000000000..6571ee4642
Binary files /dev/null and b/collects/tests/stepper/print-convert-test.ss differ
diff --git a/collects/tests/stepper/printing-reducing-test.ss b/collects/tests/stepper/printing-reducing-test.ss
new file mode 100644
index 0000000000..f27190f557
--- /dev/null
+++ b/collects/tests/stepper/printing-reducing-test.ss
@@ -0,0 +1,3 @@
+(first (cons 1 empty))
+
+(vector 1 2 3)
\ No newline at end of file
diff --git a/collects/tests/stepper/procedure-display.ss b/collects/tests/stepper/procedure-display.ss
new file mode 100644
index 0000000000..c3a8553319
--- /dev/null
+++ b/collects/tests/stepper/procedure-display.ss
@@ -0,0 +1,5 @@
+(define a (lambda (b c) (+ b c)))
+
+(define (b c) (+ c 5))
+
+(+ (a 3 5) (b 9))
diff --git a/collects/tests/stepper/reconstruct-test.ss b/collects/tests/stepper/reconstruct-test.ss
new file mode 100644
index 0000000000..b9523351bd
--- /dev/null
+++ b/collects/tests/stepper/reconstruct-test.ss
@@ -0,0 +1,554 @@
+(require (prefix annotate: (lib "annotate.ss" "stepper" "private"))
+         (prefix kernel: (lib "kerncase.ss" "syntax"))
+         (prefix reconstruct: (lib "reconstruct.ss" "stepper" "private"))
+         (lib "shared.ss" "stepper" "private")
+         (lib "highlight-placeholder.ss" "stepper" "private")
+         (lib "my-macros.ss" "stepper" "private")
+         (lib "model-settings.ss" "stepper" "private")
+         (lib "marks.ss" "stepper" "private")
+         (lib "class.ss")
+         (lib "etc.ss")
+         "tests-common.ss")
+
+(load "/Users/clements/plt/tests/mzscheme/testing.ss")
+
+(SECTION 'stepper-reconstruct)  
+
+(reset-namespaces)
+
+; this following code is probably a good idea, but not right now. For now, I just want
+; to get the stepper working.
+
+;; a step-queue object collects steps that come from
+;; breakpoints, and sends them to the view in nice
+;; tidy little bundles
+;(define step-queue%
+;  (class object% ()
+;    
+;    (field (queue #f)) ; : (listof (list syntax symbol mark-list (listof TST)))
+;    
+;    ; : (syntax symbol mark-list (listof TST)) -> (void)
+;    ; effects: queue
+;    (define (add-step . args)
+;      (set! queue (append queue (list args)))
+;      (try-match))
+;
+;    ; ( -> (void))
+;    ; effects: queue
+;    ; take action based on the head of the queue
+;    (define (try-match)
+;      (unless (null? queue)
+;        (case (cadr (car queue))
+;          ((
+;      
+
+; collect-in-pairs-maker : ((list 'a 'a) -> 'b) -> (boolean 'a -> (union 'b void)) 
+(define (collect-in-pairs-maker action)
+  (let ([stored-first #f]
+        [have-first? #f])
+    (lambda (first-kind? value)
+      (if first-kind?
+          (begin 
+            (set! stored-first value)
+            (set! have-first? #t))
+          (let ([temp-stored stored-first]
+                [temp-have? have-first?])
+            (set! stored-first #f)
+            (set! have-first? #f)
+            (if temp-have?
+                (action (list temp-stored value))
+                (action (list no-sexp value))))))))
+
+(define t (collect-in-pairs-maker (lx _)))
+(test (list no-sexp 'ahe) t #f 'ahe)
+(test (void) t #t 13)
+(test (void) t #t 'apple)
+(test (list 'apple 'banana) t #f 'banana)
+(test (list no-sexp 'oetu) t #f 'oetu)
+
+; : ((recon-result recon-result -> (void)) box -> syntax -> break-contract)
+(define (make-break action expr-box)
+  (let* ([recon-call (lx (if (eq? _ no-sexp) `((...) ()) (apply reconstruct:reconstruct-current _)))]
+         [pair-action (lambda (2-list)
+                        (unless (eq? (car 2-list) skipped-step)
+                          (apply action (map recon-call 2-list))))]
+         [collector (collect-in-pairs-maker pair-action)])
+    (lambda (mark-set break-kind returned-value-list)
+      (let ([mark-list (extract-mark-list mark-set)])
+        (if (reconstruct:skip-step? break-kind mark-list)
+            (when (eq? break-kind 'normal-break)
+              (collector #t skipped-step))
+            (case break-kind
+              ((normal-break)
+               (collector #t (list (unbox expr-box) mark-list break-kind returned-value-list)))
+              ((result-exp-break result-value-break)
+               (collector #f (list (unbox expr-box) mark-list break-kind returned-value-list)))
+              (else (error 'break "unexpected break-kind: ~a" break-kind))))))))
+
+
+(define (test-sequence stx expected-queue expected-completed namespace)
+  (let/ec k
+    (let* ([expr-box (box #f)]
+           [action (lambda (before after)
+                     (when (null? expected-queue)
+                       (when expected-completed
+                         (fprintf (current-error-port) "got an extra pair:\nbefore: ~e\nafter: ~e\n"
+                                  before after)
+                         (test #f (lambda (x) x) expected-completed))
+                       (k (void)))
+                     (test (car expected-queue) (lambda () before))
+                     (test (cadr expected-queue) (lambda () after))
+                     (set! expected-queue (cddr expected-queue)))])
+      (parameterize ([current-namespace namespace])
+        (let* ([stx-list (string->stx-list stx)]
+               [expanded (map expand stx-list)]
+               [annotated (annotate-exprs expanded (make-break action expr-box))]
+               [eval-expr (lambda (expanded annotated)
+                            (set-box! expr-box expanded)
+                            (reconstruct:reconstruct-completed expanded (eval annotated)))])
+          (if expected-completed
+              (test expected-completed map eval-expr expanded annotated)
+              (map eval-expr expanded annotated))
+          (test #t null? expected-queue))))))
+
+(define (namespace-rewrite-expr stx namespace)
+  (parameterize ([current-namespace namespace])
+    (map annotate:top-level-rewrite (map expand (string->stx-list stx)))))
+
+(define mz-render-settings fake-mz-render-settings)
+(define (test-mz-sequence source-list result-list)
+  (reconstruct:set-render-settings! mz-render-settings)
+  (test-sequence source-list result-list #f mz-namespace))
+
+(define (make-language-level-tester settings namespace)
+  (lambda (source-list result-list completed-list)
+    (reconstruct:set-render-settings! settings)
+    (test-sequence source-list result-list completed-list namespace)))
+
+(define test-beginner-sequence 
+  (make-language-level-tester fake-beginner-render-settings beginner-namespace))
+
+(define test-beginner-wla-sequence 
+  (make-language-level-tester fake-beginner-wla-render-settings beginner-wla-namespace))
+
+(define test-intermediate-sequence
+  (make-language-level-tester fake-intermediate-render-settings intermediate-namespace))
+
+(map syntax-object->datum
+     (parameterize ([current-namespace beginner-namespace])
+       (map expand (string->stx-list "(list a 3 4)"))))
+
+;;;;;;;;;;;;;
+;;
+;;  mz tests
+;;
+;;;;;;;;;;;;;
+
+(test-mz-sequence "(for-each (lambda (x) x) '(1 2 3))"
+                  `(((,highlight-placeholder) ((for-each (lambda (x) x) `(1 2 3))))
+                    (((... ,highlight-placeholder ...)) (1))
+                    ((...) ())
+                    (((... ,highlight-placeholder ...)) (2))
+                    ((...) ())
+                    (((... ,highlight-placeholder ...)) (3))
+                    ((...) ())
+                    ((,highlight-placeholder) ((void)))))
+
+(test-mz-sequence "(+ 3 4)"
+                  `(((,highlight-placeholder) ((+ 3 4)))
+                    ((,highlight-placeholder) (7))))
+
+(test-mz-sequence "((lambda (x) (+ x 3)) 4)"
+                  `(((,highlight-placeholder) (((lambda (x) (+ x 3)) 4)))
+                    ((,highlight-placeholder) ((+ 4 3)))
+                    ((,highlight-placeholder) ((+ 4 3)))
+                    ((,highlight-placeholder) (7))))
+
+(test-mz-sequence "(if 3 4 5)"
+                  `(((,highlight-placeholder) ((if 3 4 5)))
+                    ((,highlight-placeholder) (4))))
+
+(test-beginner-sequence "(if (if true false true) false true)"
+                        `((((if ,highlight-placeholder false true)) ((if true false true)))
+                          (((if ,highlight-placeholder false true)) (false))
+                          ((,highlight-placeholder) ((if false false true)))
+                          ((,highlight-placeholder) (true)))
+                        `(true))
+
+(test-mz-sequence "((lambda (x) x) 3)"
+                  `(((,highlight-placeholder) (((lambda (x) x) 3)))
+                    ((,highlight-placeholder) (3))))
+
+; 'begin' not yet supported by reconstruct
+;(test-mz-sequence "((lambda (x) x) (begin (+ 3 4) (+ 4 5)"))
+;                  `((((begin ,highlight-placeholder (+ 4 5))) ((+ 3 4)))
+;                    (((begin ,highlight-placeholder (+ 4 5))) (7))
+;                    ((,highlight-placeholder) ((begin 7 (+ 4 5))))
+;                    ((,highlight-placeholder) ((+ 4 5)))
+;                    ((,highlight-placeholder) ((+ 4 5)))
+;                    ((,highlight-placeholder) (9))))
+
+(test-mz-sequence "((lambda (a) (lambda (b) (+ a b))) 14)"
+                  `(((,highlight-placeholder) (((lambda (a) (lambda (b) (+ a b))) 14)))
+                    ((,highlight-placeholder) ((lambda (b) (+ 14 b))))))
+
+(test-mz-sequence "((case-lambda ((a) 3) ((b c) (+ b c))) 5 6)"
+                  `(((,highlight-placeholder) (((case-lambda ((a) 3) ((b c) (+ b c))) 5 6)))
+                    ((,highlight-placeholder) ((+ 5 6)))
+                    ((,highlight-placeholder) ((+ 5 6)))
+                    ((,highlight-placeholder) (11))))
+
+; reconstruct does not handle one-armed if's:
+;(test-mz-sequence "(if 3 4)"
+;                  `(((,highlight-placeholder) ((if 3 4)))
+;                    ((,highlight-placeholder) (4))))
+
+; reconstruct does not handle begin0
+
+;(test-mz-sequence "(let ([a 3]) 4)"
+;                  `(((,highlight-placeholder) ((let-values ([(a) 3]) 4)) (,highlight-placeholder ,highlight-placeholder) ((define-values (a_0) 3) (begin 4)))
+;                    (((define a_0 3))))) 
+;
+;(test-mz-sequence "(let ([a (+ 4 5)] [b (+ 9 20)]) (+ a b))"
+;                  `(((,highlight-placeholder) ((let-values ([(a) (+ 4 5)] [(b) (+ 9 20)]) (+ a b))) 
+;                     (,highlight-placeholder ,highlight-placeholder ,highlight-placeholder) 
+;                     ((define-values (a_0) (+ 4 5)) (define-values (b_1) (+ 9 20)) (begin (+ a_0 b_1))))
+;                    (((define-values (a_0) ,highlight-placeholder) (define-values (b_1) (+ 9 20)) (begin (+ a_0 b_1))) ((+ 4 5)))
+;                    (((define-values (a_0) ,highlight-placeholder) (define-values (b_1) (+ 9 20)) (begin (+ a_0 b_1))) (9))
+;                    (((define a_0 9) (define-values (b_1) ,highlight-placeholder) (begin (+ a_0 b_1))) ((+ 9 20)))
+;                    (((define a_0 9) (define-values (b_1) ,highlight-placeholder) (begin (+ a_0 b_1))) (29))
+;                    (((define a_0 9) (define b_1 29)))
+;                    (((+ ,highlight-placeholder b_1)) (a_0))
+;                    (((+ ,highlight-placeholder b_1)) (9))
+;                    (((+ 9 ,highlight-placeholder)) (b_1))
+;                    (((+ 9 ,highlight-placeholder)) (29))
+;                    ((,highlight-placeholder) ((+ 9 29)))
+;                    ((,highlight-placeholder) (38))))
+
+;(test-mz-sequence "((call-with-current-continuation call-with-current-continuation) (call-with-current-continuation call-with-current-continuation))"
+;                  `((((,highlight-placeholder (call-with-current-continuation call-with-current-continuation))) ((call-with-current-continuation call-with-current-continuation)))
+;                    (((,highlight-placeholder (call-with-current-continuation call-with-current-continuation))) ((lambda args ...)))
+;                    ((((lambda args ...) ,highlight-placeholder)) ((call-with-current-continuation call-with-current-continuation)))
+;                    ((((lambda args ...) ,highlight-placeholder)) ((lambda args ...)))))
+
+;(test-mz-sequence '(begin (define g 3) g)
+;                  `(((,highlight-placeholder) (g))
+;                    ((,highlight-placeholder) 3)))
+
+;(syntax-object->datum (cadr (annotate-expr test2 'mzscheme 0 (lambda (x) x))))
+
+(test-beginner-sequence "(define a (+ 3 4))"
+                        `((((define a ,highlight-placeholder)) ((+ 3 4)))
+                          (((define a ,highlight-placeholder)) (7)))
+                        `((define a 7)))
+
+(test-beginner-sequence "(+ 4 129)"
+                        `(((,highlight-placeholder) ((+ 4 129)))
+                          ((,highlight-placeholder) (133)))
+                        `(133))
+
+(test-beginner-sequence "(if true 3 4)"
+                        `(((,highlight-placeholder) ((if true 3 4)))
+                          ((,highlight-placeholder) (3)))
+                        `(3))
+
+;;;;;;;;;;;;;
+;;
+;;  COND
+;;
+;;;;;;;;;;;;;
+
+(parameterize ([current-namespace beginner-namespace])
+  (let* ([stx (expand (car (string->stx-list "(cond [else 3])")))]
+         [stx-source (syntax-source stx)]
+         [stx-posn (syntax-position stx)])
+    (printf "expanded: ~a\n" (syntax-object->datum stx))
+    (syntax-case stx (if begin #%datum)
+      [(if dc dc2 stx2)
+       (printf "stepper-else: ~a\n" (syntax-property stx 'stepper-else))
+       ]
+      [stx
+       (printf "outer thing has wrong shape: ~a\n" (syntax-object->datum (syntax stx)))])))
+
+(test-beginner-sequence "(cond [false 4] [false 5] [true 3])"
+                        `(((,highlight-placeholder) ((cond (false 4) (false 5) (true 3))))
+                          ((,highlight-placeholder) ((cond (false 5) (true 3))))
+                          ((,highlight-placeholder) ((cond (false 5) (true 3))))
+                          ((,highlight-placeholder) ((cond (true 3))))
+                          ((,highlight-placeholder) ((cond (true 3))))
+                          ((,highlight-placeholder) (3)))
+                        `(3))
+
+(test-beginner-sequence "(cond [false 4] [else 9])"
+                        `(((,highlight-placeholder) ((cond [false 4] [else 9])))
+                          ((,highlight-placeholder) ((cond [else 9])))
+                          ((,highlight-placeholder) ((cond [else 9])))
+                          ((,highlight-placeholder) (9)))
+                        `(9))
+
+(test-beginner-sequence "(cond [true 3] [else (and true true)])"
+                        `(((,highlight-placeholder) ((cond (true 3) (else (and true true)))))
+                          ((,highlight-placeholder) (3)))
+                        `(3))
+
+
+; syntactic error: (test-beginner-sequence "(cond)")
+
+(test-beginner-sequence "(cond [else 3])"
+                        `(((,highlight-placeholder) ((cond (else 3))))
+                          ((,highlight-placeholder) (3)))
+                        `(3))
+
+(test-beginner-sequence "(cond [else (cond [else 3])])"
+                        `(((,highlight-placeholder) ((cond (else (cond (else 3))))))
+                          ((,highlight-placeholder) ((cond (else 3))))
+                          ((,highlight-placeholder) ((cond (else 3))))
+                          ((,highlight-placeholder) (3)))
+                        `(3))
+
+; reconstruct can't handle begin
+;(test-mz-sequence "(cond [#f 3 4] [#t (+ 3 4) (+ 4 9)])"
+;                  `(((,highlight-placeholder) ((cond (#f 3 4) (#t (+ 3 4) (+ 4 9)))))
+;                    ((,highlight-placeholder) ((cond (#t (+ 3 4) (+ 4 9)))))
+;                    ((,highlight-placeholder) ((cond (#t (+ 3 4) (+ 4 9)))))
+;                    ((,highlight-placeholder) (begin (+ 3 4) (+ 4 9)))
+;                    (((begin ,highlight-placeholder (+ 4 9))) ((+ 3 4)))
+;                    (((begin ,highlight-placeholder (+ 4 9)))  (7))
+;                    ((,highlight-placeholder) ((begin 7 (+ 4 9))))
+;                    ((,highlight-placeholder) ((+ 4 9)))
+;                    ((,highlight-placeholder) ((+ 4 9)))
+;                    ((,highlight-placeholder) (13))))
+;
+
+
+(test-beginner-sequence "(cond [false 3] [else (cond [true 4])])"
+                        `(((,highlight-placeholder) ((cond (false 3) (else (cond (true 4))))))
+                          ((,highlight-placeholder) ((cond (else (cond (true 4))))))
+                          ((,highlight-placeholder) ((cond (else (cond (true 4))))))
+                          ((,highlight-placeholder) ((cond (true 4))))
+                          ((,highlight-placeholder) ((cond (true 4))))
+                          ((,highlight-placeholder) (4)))
+                        `(4))
+
+;;;;;;;;;;;;;
+;;
+;;  OR / AND
+;;
+;;;;;;;;;;;;;
+
+(test-beginner-sequence "(or false true false)"
+                        `(((,highlight-placeholder) ((or false true false)))
+                          ((,highlight-placeholder) ((or true false)))
+                          ((,highlight-placeholder) ((or true false)))
+                          ((,highlight-placeholder) (true)))
+                        `(true))
+
+(test-beginner-sequence "(and true false true)"
+                        `(((,highlight-placeholder) ((and true false true)))
+                          ((,highlight-placeholder) ((and false true)))
+                          ((,highlight-placeholder) ((and false true)))
+                          ((,highlight-placeholder) (false)))
+                        `(false))
+
+(parameterize ([current-namespace beginner-namespace])
+  (map syntax-object->datum
+       ;(map expand
+       (annotate-exprs (map expand (list '(define (a19 x) x) '(a19 4))) (lambda (x y z) 3))
+       ;)
+       ))
+
+(parameterize ([current-namespace beginner-namespace])
+  (map syntax-object->datum
+       (map expand (map expand (map expand (list 'a19))))))
+
+(test-beginner-sequence "(define (a2 x) x) (a2 4)"
+                        `(((,highlight-placeholder) ((a2 4)))
+                          ((,highlight-placeholder) (4)))
+                        `((define (a2 x) x) 4))
+
+(test-beginner-sequence "(define (a3 x) (if true x x)) (a3 false)"
+                        `(((,highlight-placeholder) ((a3 false)))
+                          ((,highlight-placeholder) ((if true false false)))
+                          ((,highlight-placeholder) ((if true false false)))
+                          ((,highlight-placeholder) (false)))
+                        `((define (a3 x) (if true x x)) false))
+
+(test-beginner-sequence "(define (b2 x) (and true x)) (b2 false)"
+                        `(((,highlight-placeholder) ((b2 false)))
+                          ((,highlight-placeholder) ((and true false)))
+                          ((,highlight-placeholder) ((and true false)))
+                          ((,highlight-placeholder) (false)))
+                        `((define (b2 x) (and true x)) false))
+
+(test-beginner-sequence "(define a1 true)(define (b1 x) (and a1 true x)) (b1 false)"
+                        `(((,highlight-placeholder) ((b1 false)))
+                          ((,highlight-placeholder) ((and a1 true false)))
+                          (((and ,highlight-placeholder true false)) (a1))
+                          (((and ,highlight-placeholder true false)) (true))
+                          ((,highlight-placeholder) ((and true true false)))
+                          ((,highlight-placeholder) ((and true false)))
+                          ((,highlight-placeholder) ((and true false)))
+                          ((,highlight-placeholder) (false)))
+                        `((define a1 true) (define (b1 x) (and a1 true x)) false))
+
+
+(test-intermediate-sequence "(define a4 +) a4"
+                            `(((,highlight-placeholder) (a4))
+                              ((,highlight-placeholder) (+)))
+                            `((define a4 +) +))
+
+(test-intermediate-sequence "(define (f123 x) (+ x 13)) f123"
+                            `()
+                            `((define (f123 x) (+ x 13)) f123))
+
+(test-beginner-sequence "(define (b x) (+ x 13)) (b 9)"
+                        `(((,highlight-placeholder) ((b 9)))
+                          ((,highlight-placeholder) ((+ 9 13)))
+                          ((,highlight-placeholder) ((+ 9 13)))
+                          ((,highlight-placeholder) (22)))
+                        `((define (b x) (+ x 13)) 22))
+
+(test-beginner-sequence "(define-struct mamba (rhythm tempo)) (mamba-rhythm (make-mamba 24 2))"
+                        `(((,highlight-placeholder) ((mamba-rhythm (make-mamba 24 2))))
+                          ((,highlight-placeholder) (24)))
+                        `((define-struct mamba (rhythm tempo)) 24))
+
+(test-beginner-sequence "(define a5 (lambda (a5) (+ a5 13))) (a5 23)"
+                        `(((,highlight-placeholder) ((a5 23)))
+                          ((,highlight-placeholder) ((+ 23 13)))
+                          ((,highlight-placeholder) ((+ 23 13)))
+                          ((,highlight-placeholder) (36)))
+                        `((define a5 (lambda (a5) (+ a5 13))) 36))
+
+(test-beginner-sequence "(define c1 false) (define (d2 x) (or c1 false x)) (d2 false)"
+                        `(((,highlight-placeholder) ((d2 false)))
+                          ((,highlight-placeholder) ((or c1 false false)))
+                          (((or ,highlight-placeholder false false)) (c1))
+                          (((or ,highlight-placeholder false false)) (false))
+                          ((,highlight-placeholder) ((or false false false)))
+                          ((,highlight-placeholder) ((or false false)))
+                          ((,highlight-placeholder) ((or false false)))
+                          ((,highlight-placeholder) (false)))
+                        `((define c1 false) (define (d2 x) (or c1 false x)) false))
+
+(test-beginner-sequence "(define (silly-choice str)
+                           (string-append str (if false str str) str))
+(silly-choice \"family\")"
+                        `(((,highlight-placeholder) ((silly-choice "family")))
+                          ((,highlight-placeholder) ((string-append "family" (if false "family" "family") "family")))
+                          (((string-append "family" ,highlight-placeholder "family")) ((if false "family" "family")))
+                          (((string-append "family" ,highlight-placeholder "family")) ("family"))
+                          ((,highlight-placeholder) ((string-append "family" "family" "family")))
+                          ((,highlight-placeholder) ("familyfamilyfamily")))
+                        '((define (silly-choice str) (string-append str (if false str str) str)) "familyfamilyfamily"))
+
+(test-beginner-sequence "(define (f x) (+ (g x) 10)) (define (g x) (- x 22)) (f 13)"
+                        `(((,highlight-placeholder) ((f 13)))
+                          ((,highlight-placeholder) ((+ (g 13) 10)))
+                          (((+ ,highlight-placeholder 10)) ((g 13)))
+                          (((+ ,highlight-placeholder 10)) ((- 13 22)))
+                          (((+ ,highlight-placeholder 10)) ((- 13 22)))
+                          (((+ ,highlight-placeholder 10)) (-9))
+                          ((,highlight-placeholder) ((+ -9 10)))
+                          ((,highlight-placeholder) (1)))
+                        `((define (f x) (+ (g x) 10)) (define (g x) (- x 22)) 1))
+
+(test-beginner-sequence "(define (f2 x) (+ (g2 x) 10))"
+                        `()
+                        `((define (f2 x) (+ (g2 x) 10))))
+
+(err/rt-test (test-beginner-sequence "(cons 1 2)" `() `()) exn:application:type?)
+
+(test-beginner-sequence "(cons 3 (cons 1 empty)) (list 1 2 3) (define-struct aa (b)) (make-aa 3)"
+                        `(((,highlight-placeholder) ((list 1 2 3)))
+                          ((,highlight-placeholder) ((cons 1 (cons 2 (cons 3 empty))))))
+                        `((cons 3 (cons 1 empty)) (cons 1 (cons 2 (cons 3 empty))) (define-struct aa (b)) (make-aa 3)))
+
+(test-beginner-sequence "(define a11 4)"
+                        `()
+                        `((define a11 4)))
+
+(test-mz-sequence "(map (lambda (x) x) (list 3 4 5))"
+                  `((((map (lambda (x) x) ,highlight-placeholder)) ((list 3 4 5)))
+                    (((map (lambda (x) x) ,highlight-placeholder)) (`( 3 4 5)))
+                    ((,highlight-placeholder) ((map (lambda (x) x) `(3 4 5))))
+                    (((... ,highlight-placeholder ...)) (3))
+                    ((...) ())
+                    (((... ,highlight-placeholder ...)) (4))
+                    ((...) ())
+                    (((... ,highlight-placeholder ...)) (5))
+                    ((...) ())
+                    ((,highlight-placeholder) (`(3 4 5)))))
+
+(test-beginner-wla-sequence "'(3 4 5)"
+                            `()
+                            `((list 3 4 5)))
+
+; note: we currently punt on trying to unwind quasiquote.
+
+(test-beginner-wla-sequence "`(3 4 ,(+ 4 5))"
+                            `((((cons 3 (cons 4 (cons ,highlight-placeholder empty)))) ((+ 4 5)))
+                              (((cons 3 (cons 4 (cons ,highlight-placeholder empty)))) (9))
+                              (((cons 3 (cons 4 ,highlight-placeholder))) ((cons 9 empty)))
+                              (((cons 3 (cons 4 ,highlight-placeholder))) ((list 9)))
+                              (((cons 3 ,highlight-placeholder)) ((cons 4 (list 9))))
+                              (((cons 3 ,highlight-placeholder)) ((list 4 9)))
+                              ((,highlight-placeholder) ((cons 3 (list 4 9))))
+                              ((,highlight-placeholder) ((list 3 4 9))))
+                            `((list 3 4 9)))
+
+(test-beginner-wla-sequence "`(3 ,@(list (+ 3 4) 5) 6)"
+                            `((((cons 3 (append (list ,highlight-placeholder 5) (cons 6 empty)))) ((+ 3 4)))
+                              (((cons 3 (append (list ,highlight-placeholder 5) (cons 6 empty)))) (7))
+                              (((cons 3 (append (list 7 5) ,highlight-placeholder))) ((cons 6 empty)))
+                              (((cons 3 (append (list 7 5) ,highlight-placeholder))) ((list 6)))
+                              (((cons 3 ,highlight-placeholder)) ((append (list 7 5) (list 6))))
+                              (((cons 3 ,highlight-placeholder)) ((list 7 5 6)))
+                              ((,highlight-placeholder) ((cons 3 (list 7 5 6))))
+                              ((,highlight-placeholder) ((list 3 7 5 6))))
+                            `((list 3 7 5 6)))
+
+(test-intermediate-sequence "(local () (+ 3 4))"
+                            `(((,highlight-placeholder) ((local () (+ 3 4))))
+                              ((,highlight-placeholder) ((+ 3 4)))
+                              ((,highlight-placeholder) ((+ 3 4)))
+                              ((,highlight-placeholder) (7)))
+                            `(7))
+
+(test-intermediate-sequence "(local ((define (a x) (+ x 9))) (a 6))"
+                            `((())))
+
+(test-intermediate-sequence "(local ((define (a x) (+ x 13))) a)"
+                            `((())))
+(test-intermediate-sequence "(local ((define (a x) (+ x 9)) (define b a)) (b 1))")
+
+
+;;;;;;;;;;;;;
+;;
+;;  TEACHPACK TESTS
+;;
+;;;;;;;;;;;;;
+
+(require (lib "mred.ss" "mred"))
+
+(define tp-namespace
+  (let ([ns (current-namespace)]
+        [mred-name ((current-module-name-resolver) '(lib "mred.ss" "mred") #f #f)]
+        [new-namespace (make-namespace 'empty)])
+    (parameterize ([current-namespace new-namespace])
+      (namespace-attach-module ns 'mzscheme)
+      (namespace-attach-module ns mred-name)
+      (namespace-require '(lib "htdp-beginner.ss" "lang"))
+      (namespace-require '(lib "guess.ss" "htdp"))
+      new-namespace)))
+
+(reconstruct:set-render-settings! fake-beginner-render-settings)
+(test-sequence "(define (check-guess guess target) 'TooSmall) (guess-with-gui check-guess)"
+               `(((,highlight-placeholder) ((guess-with-gui check-guess)))
+                 ((,highlight-placeholder) (true)))
+               `((define (check-guess guess target) 'toosmall) true)
+               tp-namespace)
+
+
+
+(report-errs)
diff --git a/collects/tests/stepper/recur-test b/collects/tests/stepper/recur-test
new file mode 100644
index 0000000000..41f55979ac
--- /dev/null
+++ b/collects/tests/stepper/recur-test
@@ -0,0 +1,5 @@
+(define (my-proc x)
+  (+ (my-proc (- x 1)) x))
+
+(my-proc 34)
+
diff --git a/collects/tests/stepper/right-redex.ss b/collects/tests/stepper/right-redex.ss
new file mode 100644
index 0000000000..46f18846e5
--- /dev/null
+++ b/collects/tests/stepper/right-redex.ss
@@ -0,0 +1 @@
+(+ #t (if #t #t #t) #t)
\ No newline at end of file
diff --git a/collects/tests/stepper/structures.ss b/collects/tests/stepper/structures.ss
new file mode 100644
index 0000000000..594c474324
--- /dev/null
+++ b/collects/tests/stepper/structures.ss
@@ -0,0 +1,15 @@
+(define-struct item (name price))
+
+(define inventory (cons (make-item 'rabbit 32.42)
+                        (cons (make-item 'twiggy 3.18)
+                              (cons (make-item 'richard-nixon 0.45)
+                                    empty))))
+
+(+ 3 4)
+
+(define (sum-up-prices item-list)
+  (cond ([null? item-list] 0)
+        (else (+ (item-price (car item-list))
+                 (sum-up-prices (cdr item-list))))))
+
+(sum-up-prices inventory)
diff --git a/collects/tests/stepper/symbol-identifier.ss b/collects/tests/stepper/symbol-identifier.ss
new file mode 100644
index 0000000000..1d7471e111
--- /dev/null
+++ b/collects/tests/stepper/symbol-identifier.ss
@@ -0,0 +1,3 @@
+(define (appy x) (list x 'x))
+
+(define foo (appy 'putz))
\ No newline at end of file
diff --git a/collects/tests/stepper/symbols.ss b/collects/tests/stepper/symbols.ss
new file mode 100644
index 0000000000..4458acc428
--- /dev/null
+++ b/collects/tests/stepper/symbols.ss
@@ -0,0 +1,7 @@
+(+ 3 4)
+
+(define f 'foo)
+
+(define g f)
+
+(+ 3 4)
\ No newline at end of file
diff --git a/collects/tests/stepper/syntax-error-ordering.ss b/collects/tests/stepper/syntax-error-ordering.ss
new file mode 100644
index 0000000000..dc8d91835d
--- /dev/null
+++ b/collects/tests/stepper/syntax-error-ordering.ss
@@ -0,0 +1,3 @@
+(lambda) 
+
+(
\ No newline at end of file
diff --git a/collects/tests/stepper/test-or.ss b/collects/tests/stepper/test-or.ss
new file mode 100644
index 0000000000..bed89ad668
--- /dev/null
+++ b/collects/tests/stepper/test-or.ss
@@ -0,0 +1,3 @@
+(define a 3)
+
+(or #f a #t)
\ No newline at end of file
diff --git a/collects/tests/stepper/tests-common.ss b/collects/tests/stepper/tests-common.ss
new file mode 100644
index 0000000000..38fdd079ea
--- /dev/null
+++ b/collects/tests/stepper/tests-common.ss
@@ -0,0 +1,54 @@
+(module tests-common mzscheme
+  
+  (require (lib "private/annotate.ss" "stepper")
+           (lib "contract.ss")
+           (lib "shared.ss" "stepper" "private"))
+  
+  (provide/contract (reset-namespaces (-> void?))
+                    (annotate-exprs (-> (listof syntax?) break-contract (listof syntax?)))
+                    (string->stx-list (-> string? (listof syntax?))))
+  
+  (provide mz-namespace
+           beginner-namespace
+           beginner-wla-namespace
+           intermediate-namespace
+           intermediate/lambda-namespace)
+  
+  ; : ((listof syntax?) (recon-result recon-result -> (void)) -> (listof syntax)
+  (define (annotate-exprs stx-list break)
+    (let loop ([env (make-initial-env-package)] [stx-list stx-list])
+      (if (null? stx-list)
+          null
+          (let*-values ([(annotated new-env)
+                         (annotate (car stx-list) env break 'foot-wrap)])
+            (cons annotated (loop new-env (cdr stx-list)))))))
+ 
+  ; : (string -> (listof syntax)
+  (define (string->stx-list stx)
+    (let ([port (open-input-string stx)])
+      (let loop ([first-stx (read-syntax 'test-program port)])
+        (if (eof-object? first-stx)
+            null
+            (cons first-stx (loop (read-syntax 'test-program port)))))))
+
+  (define source-namespace (current-namespace))
+  
+  (define mz-namespace #f)
+  (define beginner-namespace #f)
+  (define beginner-wla-namespace #f)
+  (define intermediate-namespace #f)
+  (define intermediate/lambda-namespace #f)
+  
+  (define (new-namespace-from-spec spec)
+    (let ([new-namespace (make-namespace 'empty)])
+      (parameterize ([current-namespace new-namespace])
+        (namespace-attach-module source-namespace 'mzscheme)
+        (namespace-require spec))
+      new-namespace))
+  
+  (define (reset-namespaces)
+    (set! mz-namespace (new-namespace-from-spec '(lib "plt-mzscheme.ss" "lang")))
+    (set! beginner-namespace (new-namespace-from-spec '(lib "htdp-beginner.ss" "lang")))
+    (set! beginner-wla-namespace (new-namespace-from-spec '(lib "htdp-beginner-abbr.ss" "lang")))
+    (set! intermediate-namespace (new-namespace-from-spec '(lib "htdp-intermediate.ss" "lang")))
+    (set! intermediate/lambda-namespace (new-namespace-from-spec '(lib "htdp-intermediate-lambda.ss" "lang")))))
diff --git a/collects/tests/stepper/through-tests.ss b/collects/tests/stepper/through-tests.ss
new file mode 100644
index 0000000000..3ac3922041
--- /dev/null
+++ b/collects/tests/stepper/through-tests.ss
@@ -0,0 +1,1198 @@
+(module through-tests mzscheme
+  (require (lib "shared.ss" "stepper" "private")
+           (lib "model.ss" "stepper" "private")
+           (lib "model-settings.ss" "stepper" "private")
+           (lib "match.ss")
+           (lib "sexp-diff.ss" "tests" "utils")
+           "module-elaborator.ss"
+           ; for xml testing:
+           #;(lib "class.ss")
+           #;(all-except (lib "xml-snipclass.ss" "xml") snip-class)
+           #;(all-except (lib "scheme-snipclass.ss" "xml") snip-class)
+           #;(lib "mred.ss" "mred"))
+  
+  (define test-directory (find-system-path 'temp-dir))
+  
+  (define (stream-ify expr-list iter)
+    (lambda ()
+      (if (null? expr-list)
+          (iter eof void)
+          (iter (expand (car expr-list)) (stream-ify (cdr expr-list) iter)))))
+ 
+  
+  (define (test-sequence-core namespace-spec teachpack-specs render-settings track-inferred-names? in-port expected-steps)
+    (let* ([current-error-display-handler (error-display-handler)]) 
+        (let* ([all-steps
+                (append expected-steps 
+                        '((finished-stepping)))]
+               [receive-result
+                (lambda (result)
+                  (if (null? all-steps)
+                      (fprintf (current-error-port) "test-sequence: ran out of expected steps. Given result: ~v\n" result)
+                      (begin
+                        (unless (compare-steps result (car all-steps))
+                          (fprintf (current-error-port) "test-sequence: steps do not match.\ngiven: ~v\nexpected: ~v\n" result (car all-steps)))
+
+                        ; uncomment for testing:
+                        ; (when (compare-steps result (car all-steps))
+                        ;   (printf "test-sequence: steps match for expected result: ~v\n" result))
+
+                        (set! all-steps (cdr all-steps)))))]
+               [program-expander
+                (lambda (init iter)
+                  (init)
+                  (let* ([exps (let read-loop ()
+                                     (let ([expr (read-syntax "test-input" in-port)])
+                                       (if (eof-object? expr)
+                                           null
+                                           (cons expr (read-loop)))))]
+                         [exprs (wrap-in-module exps namespace-spec teachpack-specs)])
+                    ((stream-ify exprs iter))))])
+          (let/ec escape
+            (parameterize ([error-escape-handler (lambda () (escape (void)))])
+              (go program-expander receive-result render-settings track-inferred-names?)))
+          (error-display-handler current-error-display-handler))))
+  
+  (define (test-sequence namespace-spec teachpack-specs render-settings track-inferred-names? exp-str expected-steps)
+    (let ([filename (build-path test-directory "stepper-test")])
+      (call-with-output-file filename
+        (lambda (port)
+          (fprintf port "~a" exp-str))
+        'truncate)
+      (printf "testing string: ~v\n" exp-str)
+      (letrec ([port (open-input-file filename)])
+        (test-sequence-core namespace-spec teachpack-specs render-settings track-inferred-names? port expected-steps))))
+
+  
+  (define (lang-level-test-sequence namespace-spec rs track-inferred-names?)
+    (lambda args
+      (apply test-sequence namespace-spec `() rs track-inferred-names? args)))
+  
+  (define (make-multi-level-test-sequence level-fns)
+    (lambda args
+      (for-each (lambda (fn) (apply fn args)) level-fns)))
+  
+  (define test-mz-sequence (lang-level-test-sequence 'mzscheme fake-mz-render-settings #f))
+  (define test-beginner-sequence (lang-level-test-sequence `(lib "htdp-beginner.ss" "lang") fake-beginner-render-settings #t))
+  (define test-beginner-wla-sequence (lang-level-test-sequence `(lib "htdp-beginner-abbr.ss" "lang") fake-beginner-wla-render-settings #t))
+  (define test-intermediate-sequence (lang-level-test-sequence `(lib "htdp-intermediate.ss" "lang") fake-intermediate-render-settings #t))
+  (define test-intermediate/lambda-sequence (lang-level-test-sequence `(lib "htdp-intermediate-lambda.ss" "lang")
+                                                                      fake-intermediate/lambda-render-settings
+                                                                      #f))
+  
+  (define test-upto-int/lam (make-multi-level-test-sequence (list test-beginner-sequence
+                                                                  test-beginner-wla-sequence
+                                                                  test-intermediate-sequence
+                                                                  test-intermediate/lambda-sequence)))
+  
+  (define test-upto-int (make-multi-level-test-sequence (list test-beginner-sequence
+                                                              test-beginner-wla-sequence
+                                                              test-intermediate-sequence)))
+  
+  (define test-bwla-to-int/lam (make-multi-level-test-sequence (list test-beginner-wla-sequence
+                                                                     test-intermediate-sequence
+                                                                     test-intermediate/lambda-sequence)))
+  
+  (define test-both-ints (make-multi-level-test-sequence (list test-intermediate-sequence
+                                                               test-intermediate/lambda-sequence)))
+  
+  ; mutate these to values you want to examine in the repl:
+  (define bell-jar-specimen-1 #f)
+  (define bell-jar-specimen-2 #f)
+  
+  ;; so->d/finished : call (syntax-object->hilite-datum stx #t).  For finished steps,
+  ;; we want to ignore the highlight but not the xml boxes (and other future stuff?)
+  (define (so->d/finished stx)
+    (syntax-object->hilite-datum stx #t))
+  
+  ; (-> step-result? sexp? boolean?)
+  (define (compare-steps actual expected)
+    (match expected
+      [`(before-after ,before ,after)
+       (and (before-after-result? actual)
+            (andmap (lambda (fn expected) 
+                      (unless (list? (fn actual))
+                        (fprintf (current-error-port) "not a list: ~v\n" (syntax-object->hilite-datum (fn actual))))
+                      (noisy-equal? (map syntax-object->hilite-datum (fn actual)) expected))
+                    (list before-after-result-exp before-after-result-post-exp)
+                    (list before after)))]
+      [`(before-after-waiting ,before ,after ,waiting)
+       (and (before-after-result? actual)
+            (and (noisy-equal? (map syntax-object->hilite-datum (before-after-result-after-exprs actual)) waiting)
+                 (compare-steps actual `(before-after ,before ,after))))]
+      [`(before-after-finished ,finished-exprs . ,rest)
+       (and (before-after-result? actual)
+            (compare-finished (map so->d/finished (before-after-result-finished-exprs actual)) finished-exprs)
+            (compare-steps actual `(before-after ,@rest)))]
+      [`(before-after-finished-waiting ,finished-exprs . ,rest)
+       (and (before-after-result? actual)
+            (compare-finished (map so->d/finished (before-after-result-finished-exprs actual)) finished-exprs)
+            (compare-steps actual `(before-after-waiting ,@rest)))]
+      [`(finished ,finished-exprs)
+       (and (finished-result? actual)
+            (compare-finished (map so->d/finished (finished-result-finished-exprs actual)) finished-exprs))]
+      [`(error ,err-msg)
+       (and (error-result? actual)
+            (equal? err-msg (error-result-err-msg actual)))]
+      [`(before-error ,before ,err-msg)
+       (and (before-error-result? actual)
+            (and (noisy-equal? (map syntax-object->hilite-datum (before-error-result-exp actual)) before)
+                 (equal? (before-error-result-err-msg actual) err-msg)))]
+      [`(finished-stepping) (finished-stepping? actual)]
+      [else 
+       (begin (fprintf (current-error-port) "compare-steps: unexpected expected step type: ~v\n" expected)
+              #f)]))
+  
+  ; noisy-equal? : (any any . -> . boolean)
+  ; like equal?, but prints a noisy error message
+  (define (noisy-equal? a b)
+    (if (equal? a b)
+        #t
+        (begin (fprintf (current-error-port) "~e is not equal? to ~e\nhere's the diff: ~e\n" a b (sexp-diff a b))
+               #f)))
+   
+  ; (-> (listof sexp) (listof sexp) boolean?)
+  (define (compare-finished finished-exps expected-exps)
+    (and 
+     (>= (length finished-exps) (length expected-exps))
+     (andmap (lambda (x y) (if (equal? x y)
+                               #t
+                               (begin (fprintf (current-error-port) "~e is not equal? to ~e\nhere's the diff: ~e\n" x y (sexp-diff x y))
+                                      #f)))
+             (list-tail finished-exps (- (length finished-exps) (length expected-exps)))
+             expected-exps)))
+  
+  (define list-of-tests null)
+  
+  (define (add-test name thunk)
+    (when (assq name list-of-tests)
+      (error 'add-test "name ~v is already in the list of tests" name))
+    (set! list-of-tests (append list-of-tests (list (list name thunk)))))
+  
+  (define-syntax (t stx)
+    (syntax-case stx ()
+      [(_ name test)
+       (syntax/loc stx (add-test `name (lambda () test)))]))
+  
+  (define (run-all-tests)
+    (for-each (lambda (test-pair)
+                (printf "running test: ~v\n" (car test-pair))
+                ((cadr test-pair)))
+              list-of-tests))
+  
+  (define (run-test name)
+    (printf "running test: ~v\n" name)
+    ((cadr (assq name list-of-tests))))
+  
+  (define (run-tests names)
+    (map run-test names))
+  
+  (t mz1
+     (test-mz-sequence "(for-each (lambda (x) x) '(1 2 3))"
+                       `((before-after ((hilite (for-each (lambda (x) x) `(1 2 3)))) ((... (hilite 1) ...)))
+                         (before-after ((hilite ...)) ((... (hilite 2) ...)))
+                         (before-after ((hilite ...)) ((... (hilite 3) ...)))
+                         (before-after ((hilite ...)) ((hilite (void))))
+                         (finished ((void))))))
+  
+  (t mz-app
+     (test-mz-sequence "(+ 3 4)"
+                       `((before-after ((hilite (+ 3 4))) ((hilite 7)))
+                         (finished (7)))))
+  
+  (t mz-app2
+     (test-mz-sequence "((lambda (x) (+ x 3)) 4)"
+		       `((before-after ((hilite ((lambda (x) (+ x 3)) 4)))
+                                       ((hilite (+ 4 3))))
+                         (before-after ((hilite (+ 4 3)))
+                                       ((hilite 7)))
+                         (finished (7)))))
+  
+  (t mz-if
+     (test-mz-sequence "(if 3 4 5)"
+                    `((before-after ((hilite (if 3 4 5))) ((hilite 4)))
+		      (finished (4)))))
+
+  (t simple-if
+     (test-upto-int/lam "(if true false true)"
+                        `((before-after ((hilite (if true false true)))
+                                       ((hilite false)))
+                          (finished (false)))))
+  
+  (t if-bool
+     (test-upto-int/lam "(if (if true false true) false true)"
+                     `((before-after ((if (hilite (if true false true)) false true))
+                                     ((if (hilite false) false true)))
+                       (before-after ((hilite (if false false true))) ((hilite true)))
+                       (finished (true)))))
+
+  (t direct-app
+     (test-mz-sequence "((lambda (x) x) 3)"
+		       `((before-after ((hilite ((lambda (x) x) 3))) ((hilite 3)))
+			 (finished (3)))))
+  
+  
+ ;   (test-mz-sequence "((lambda (x) x) (begin (+ 3 4) (+ 4 5)))"
+;		      `((before-after ((begin (hilite (+ 3 4)) (+ 4 5)))
+;				      ((begin (hilite 7) (+ 4 5))))
+;			(before-after ((hilite (begin 7 (+ 4 5)))) ((hilite (+ 4 5))))
+;                        (before-after ((hilite (+ 4 5))) ((hilite 9)))
+;			(finished (9))))
+  
+  (t curried
+     (test-mz-sequence "((lambda (a) (lambda (b) (+ a b))) 14)"
+                       `((before-after ((hilite ((lambda (a) (lambda (b) (+ a b))) 14))) 
+				       ((hilite (lambda (b) (+ 14 b)))))
+                         (finished ((lambda (b) (+ 14 b)))))))
+  
+  (t case-lambda
+     (test-mz-sequence "((case-lambda ((a) 3) ((b c) (+ b c))) 5 6)"
+                    `((before-after ((hilite ((case-lambda ((a) 3) ((b c) (+ b c))) 5 6))) ((hilite (+ 5 6))))
+                      (before-after ((hilite (+ 5 6))) ((hilite 11)))
+		      (finished (11)))))
+  
+  (t 2armed-if
+     (test-mz-sequence "(if 3 4)"
+		       `((before-after ((hilite (if 3 4))) ((hilite 4)))
+			 (finished (4)))))
+
+   
+  ;(test-mz-sequence "((call-with-current-continuation call-with-current-continuation) (call-with-current-continuation call-with-current-continuation))"
+  ;                  `((before-after (((hilite ,h-p) (call-with-current-continuation call-with-current-continuation))) ((call-with-current-continuation call-with-current-continuation))
+  ;                    (((hilite ,h-p) (call-with-current-continuation call-with-current-continuation))) ((lambda args ...)))
+  ;                    (before-after (((lambda args ...) (hilite ,h-p))) ((call-with-current-continuation call-with-current-continuation))
+  ;                    (((lambda args ...) (hilite ,h-p))) ((lambda args ...)))))
+  
+  ;(test-mz-sequence '(begin (define g 3) g)
+  ;                  `((before-after ((hilite ,h-p)) (g)
+  ;                    ((hilite ,h-p)) 3)))
+  
+  ;(syntax-object->datum (cadr (annotate-expr test2 'mzscheme 0 (lambda (x) x))))
+  
+  (t top-def
+     (test-upto-int/lam "(define a (+ 3 4))"
+                        `((before-after ((define a (hilite (+ 3 4)))) ((define a (hilite 7))))
+                          (finished ((define a 7))))))
+
+  (t top-def-ref
+     (test-upto-int/lam "(define a 6) a"
+                        `((before-after-finished ((define a 6))
+                                                 ((hilite a))
+                                                 ((hilite 6)))
+                          (finished (6)))))
+  
+  (t app
+     (test-upto-int/lam "(+ 4 129)" 
+                     `((before-after ((hilite (+ 4 129))) ((hilite 133)))
+                       (finished (133)))))
+
+  (t if
+  (test-upto-int/lam "(if true 3 4)"
+                     `((before-after ((hilite (if true 3 4))) ((hilite 3)))
+                       (finished (3)))))
+  
+  (t top-app
+  (test-upto-int "(define (a3 x) (if true x x)) (a3 false)"
+                     `((before-after-finished ((define (a3 x) (if true x x))) ((hilite (a3 false))) 
+					      ((hilite (if true false false))))
+                       (before-after ((hilite (if true false false))) ((hilite false)))
+                       (finished (false)))))
+  
+  (t top-app/lam
+  (test-intermediate/lambda-sequence "(define (a3 x) (if true x x)) (a3 false)"
+                                     `((before-after-finished ((define (a3 x) (if true x x)))
+                                                              (((hilite a3) false)) (((hilite (lambda (x) (if true x x))) false)))
+                                       (before-after ((hilite ((lambda (x) (if true x x)) false))) 
+						     ((hilite (if true false false))))
+                                       (before-after ((hilite (if true false false))) ((hilite false)))
+                                       (finished (false)))))
+  
+  (t top-interref
+     (test-intermediate-sequence "(define (a12 x) (+ x 9)) (define b12 a12) (b12 12)"
+                                 `((before-after-finished ((define (a12 x) (+ x 9)) (define b12 a12))
+                                                          (((hilite b12) 12)) (((hilite a12) 12)))
+                                   (before-after ((hilite (a12 12))) ((hilite (+ 12 9))))
+                                   (before-after ((hilite (+ 12 9))) ((hilite 21)))
+                                   (finished (21)))))
+  
+  
+
+  ;;;;;;;;;;;;
+  ;;
+  ;;  OR / AND
+  ;;
+  ;;;;;;;;;;;;;.
+  
+ 
+  (t or1
+  (test-upto-int/lam "(or false true false)"
+                     `((before-after ((hilite (or false true false))) ((hilite true)))
+                       (finished (true)))))
+  
+  (t and1
+  (test-upto-int/lam "(and true false true)"
+                     `((before-after ((hilite (and true false true))) ((hilite false)))
+                       (finished (false)))))
+   
+  (t and2
+  (test-upto-int/lam "(and true (if true true false))"
+                     `((before-after ((and true (hilite (if true true false)))) ((and true (hilite true))))
+                       (before-after ((hilite (and true true))) ((hilite true)))
+                       (finished (true)))))
+  
+  (t and3
+  (test-upto-int "(define (b2 x) (and true x)) (b2 false)"
+                     `((before-after-finished ((define (b2 x) (and true x))) ((hilite (b2 false))) ((hilite (and true false))))
+                       (before-after ((hilite (and true false))) ((hilite false)))
+                       (finished (false)))))
+  
+  (t and3/lam
+  (test-intermediate/lambda-sequence "(define (b2 x) (and true x)) (b2 false)"
+                                     `((before-after-finished ((define (b2 x) (and true x)))
+                                                              (((hilite b2) false))
+                                                              (((hilite (lambda (x) (and true x))) false)))
+                                       (before-after ((hilite ((lambda (x) (and true x)) false))) 
+						     ((hilite (and true false))))
+                                       (before-after ((hilite (and true false))) ((hilite false)))
+                                       (finished (false)))))
+  
+  (t and4
+  (test-upto-int "(define a1 true)(define (b1 x) (and a1 true x)) (b1 false)"
+                 `((before-after-finished ((define a1 true)
+                                           (define (b1 x) (and a1 true x)))
+					  ((hilite (b1 false))) 
+					   ((hilite (and a1 true false))))
+                   (before-after ((and (hilite a1) true false)) ((and (hilite true) true false)))
+                   (before-after ((hilite (and true true false))) ((hilite false)))
+                   (finished (false)))))
+  
+  
+  (t and4/lam
+  (test-intermediate/lambda-sequence "(define a1 true)(define (b1 x) (and a1 true x)) (b1 false)"
+                                     `((before-after-finished ((define a1 true)
+                                                               (define (b1 x) (and a1 true x))) 
+                                                              (((hilite b1) false))
+                                                              (((hilite (lambda (x) (and a1 true x))) false)))
+                                       (before-after ((hilite ((lambda (x) (and a1 true x)) false))) ((hilite (and a1 true false))))
+                                       (before-after ((and (hilite a1) true false)) ((and (hilite true) true false)))
+                                       (before-after ((hilite (and true true false))) ((hilite false)))
+                                       (finished (false)))))
+
+  (t bad-and
+  (test-upto-int/lam "(and true 1)"
+                     `((before-error ((hilite (and true 1))) "and: question result is not true or false: 1"))))
+  
+  ;;;;;;;;;;;;;
+  ;;
+  ;;  COND
+  ;;
+  ;;;;;;;;;;;;;
+  
+  
+  (t cond1
+     (test-upto-int/lam "(cond [false 4] [false 5] [true 3])"
+			`((before-after ((hilite (cond (false 4) (false 5) (true 3)))) 
+					((hilite (cond (false 5) (true 3)))))
+			  (before-after ((hilite (cond (false 5) (true 3)))) ((hilite (cond (true 3)))))
+			  (before-after ((hilite (cond (true 3)))) ((hilite 3)))
+			  (finished (3)))))
+  
+  (t cond-else
+  (test-upto-int/lam "(cond [false 4] [else 9])"
+                     `((before-after ((hilite (cond [false 4] [else 9]))) ((hilite (cond [else 9]))))
+                       (before-after ((hilite (cond [else 9]))) ((hilite 9)))
+                       (finished (9)))))
+  
+  (t cond-andelse
+  (test-upto-int/lam "(cond [true 3] [else (and true true)])"
+                     `((before-after ((hilite (cond (true 3) (else (and true true))))) ((hilite 3)))
+                       (finished (3)))))
+  
+  (t bad-cond
+  (test-upto-int/lam "(cond)"
+                     `((error "cond: expected a question--answer clause after `cond', but nothing's there"))))
+  
+  (t just-else
+  (test-upto-int/lam "(cond [else 3])"
+                     `((before-after ((hilite (cond (else 3)))) ((hilite 3)))
+                       (finished (3)))))
+  
+  (t nested-cond
+  (test-upto-int/lam "(cond [else (cond [else 3])])"
+                     `((before-after ((hilite (cond (else (cond (else 3)))))) ((hilite (cond (else 3)))))
+                       (before-after ((hilite (cond (else 3)))) ((hilite 3)))
+                       (finished (3)))))
+  
+  ;  reconstruct can't handle 'begin'
+  ;  (test-mz-sequence "(cond [#f 3 4] [#t (+ 3 4) (+ 4 9)])"
+  ;                    `((before-after ((hilite (cond (#f 3 4) (#t (+ 3 4) (+ 4 9))))) 
+;				      ((hilite (cond (#t (+ 3 4) (+ 4 9))))))
+;                        (before-after ((hilite (cond (#t (+ 3 4) (+ 4 9))))) ((hilite (begin (+ 3 4) (+ 4 9)))))
+;                        (before-after ((begin (hilite (+ 3 4)) (+ 4 9)))
+;    				    ((begin (hilite 7) (+ 4 9))))
+;                        (before-after ((hilite (begin 7 (+ 4 9)))) ((hilite (+ 4 9))))
+;                        (before-after ((hilite (+ 4 9))) ((hilite 13)))
+;			(finished (13))))
+  
+  (t nested-cond2
+  (test-upto-int/lam "(cond [false 3] [else (cond [true 4])])"
+                     `((before-after ((hilite (cond (false 3) (else (cond (true 4)))))) 
+				     ((hilite (cond (else (cond (true 4)))))))
+                       (before-after ((hilite (cond (else (cond (true 4)))))) ((hilite (cond (true 4)))))
+                       (before-after ((hilite (cond (true 4)))) ((hilite 4)))
+                       (finished (4)))))
+
+  (t top-ref
+  (test-intermediate-sequence "(define a4 +) a4"
+                              `((before-after ((hilite a4)) ((hilite +)))
+                                (finished (+)))))
+  
+  (t top-ref2
+  (test-intermediate-sequence "(define (f123 x) (+ x 13)) f123"
+                              `((finished ((define (f123 x) (+ x 13))
+                                           f123)))))
+  
+  (t define-struct
+  (test-upto-int/lam "(define-struct mamba (rhythm tempo)) (mamba-rhythm (make-mamba 24 2))"
+                     `((before-after-finished ((define-struct mamba (rhythm tempo)))
+                                              ((hilite (mamba-rhythm (make-mamba 24 2)))) ((hilite 24)))
+                       (finished (24)))))
+  
+  (t lam-def
+  (test-upto-int "(define a5 (lambda (a5) (+ a5 13))) (a5 23)"
+                     `((before-after-finished ((define a5 (lambda (a5) (+ a5 13)))) ((hilite (a5 23))) ((hilite (+ 23 13))))
+                       (before-after ((hilite (+ 23 13))) ((hilite 36)))
+                       (finished (36)))))
+  
+  (t lam-def/lam
+  (test-intermediate/lambda-sequence "(define a5 (lambda (a5) (+ a5 13))) (a5 23)"
+                                     `((before-after-finished ((define a5 (lambda (a5) (+ a5 13))))
+                                                              (((hilite a5) 23))
+                                                              (((hilite (lambda (a5) (+ a5 13))) 23)))
+                                       (before-after ((hilite ((lambda (a5) (+ a5 13)) 23))) 
+						     ((hilite (+ 23 13))))
+                                       (before-after ((hilite (+ 23 13))) ((hilite 36)))
+                                       (finished (36)))))
+  
+  (t lam-let
+     (test-intermediate-sequence "(let ([a (lambda (x) (+ x 5))]) (a 6))"
+                                 `((before-after ((hilite (let ([a (lambda (x) (+ x 5))]) (a 6))))
+                                                 ((hilite (define a_0 (lambda (x) (+ x 5)))) (hilite (a_0 6))))
+                                   (before-after-finished ((define a_0 (lambda (x) (+ x 5))))
+                                                          ((hilite (a_0 6)))
+                                                          ((hilite (+ 6 5))))
+                                   (before-after ((hilite (+ 6 5)))
+                                                 ((hilite 11)))
+                                   (finished (11)))))
+  
+  (t whocares
+  (test-upto-int "(define c1 false) (define (d2 x) (or c1 false x)) (d2 false)"
+                     `((before-after-finished ((define c1 false)
+                                               (define (d2 x) (or c1 false x))) 
+					      ((hilite (d2 false)))
+					      ((hilite (or c1 false false))))
+                       (before-after ((or (hilite c1) false false)) ((or (hilite false) false false)))
+                       (before-after ((hilite (or false false false))) ((hilite false)))
+                       (finished (false)))))
+  
+  (t whocares/lam
+  (test-intermediate/lambda-sequence "(define c1 false) (define (d2 x) (or c1 false x)) (d2 false)"
+                                     `((before-after-finished ((define c1 false)
+                                                               (define (d2 x) (or c1 false x)))
+                                                              (((hilite d2) false)) (((hilite (lambda (x) (or c1 false x))) false)))
+                                       (before-after ((hilite ((lambda (x) (or c1 false x)) false))) 
+						     ((hilite (or c1 false false))))
+                                       (before-after ((or (hilite c1) false false)) ((or (hilite false) false false)))
+                                       (before-after ((hilite (or false false false))) ((hilite false)))
+                                       (finished (false)))))
+  
+
+  (t forward-ref
+  (test-upto-int "(define (f x) (+ (g x) 10)) (define (g x) (- x 22)) (f 13)"
+                     `((before-after-finished ((define (f x) (+ (g x) 10)) (define (g x) (- x 22))) 
+					      ((hilite (f 13)))
+					      ((hilite (+ (g 13) 10))))
+                       (before-after ((+ (hilite (g 13)) 10)) ((+ (hilite (- 13 22)) 10)))
+                       (before-after ((+ (hilite (- 13 22)) 10)) ((+ (hilite -9) 10)))
+                       (before-after ((hilite (+ -9 10))) ((hilite 1)))
+                       (finished (1)))))
+  
+  (t forward-ref/lam
+  (test-intermediate/lambda-sequence "(define (f x) (+ (g x) 10)) (define (g x) (- x 22)) (f 13)"
+                                     `((before-after-finished ((define (f x) (+ (g x) 10)) (define (g x) (- x 22)))
+                                                              (((hilite f) 13))
+                                                              (((hilite (lambda (x) (+ (g x) 10))) 13)))
+                                       (before-after ((hilite ((lambda (x) (+ (g x) 10)) 13))) 
+						     ((hilite (+ (g 13) 10))))
+                                       (before-after ((+ ((hilite g) 13) 10)) ((+ ((hilite (lambda (x) (- x 22))) 13) 10)))
+                                       (before-after ((+ (hilite ((lambda (x) (- x 22)) 13)) 10)) ((+ (hilite (- 13 22)) 10)))
+                                       (before-after ((+ (hilite (- 13 22)) 10)) ((+ (hilite -9) 10)))
+                                       (before-after ((hilite (+ -9 10))) ((hilite 1)))
+                                       (finished (1)))))
+  
+
+  (t bad-cons
+  (test-upto-int/lam "(cons 1 2)" 
+                     `((before-error ((hilite (cons 1 2))) "cons: second argument must be of type <list>, given 1 and 2"))))
+  
+  (t prims
+  (test-beginner-sequence "(cons 3 (cons 1 empty)) (list 1 2 3) (define-struct aa (b)) (make-aa 3)"
+                          `((before-after-finished ((cons 3 (cons 1 empty))) 
+						   ((hilite (list 1 2 3)))
+						   ((hilite (cons 1 (cons 2 (cons 3 empty))))))
+                            (finished ((cons 1 (cons 2 (cons 3 empty))) (define-struct aa (b)) (make-aa 3))))))
+
+  (t prims/non-beginner
+  (test-bwla-to-int/lam "(cons 3 (cons 1 empty)) (list 1 2 3) (define-struct aa (b)) (make-aa 3)"
+                        `((before-after ((cons 3 (hilite (cons 1 empty)))) ((cons 3 (hilite (list 1)))))
+                          (before-after ((hilite (cons 3 (list 1)))) ((hilite (list 3 1))))
+                          (finished ((list 3 1) (list 1 2 3) (define-struct aa (b)) (make-aa 3))))))
+  
+
+  (t map
+  (test-mz-sequence "(map (lambda (x) x) (list 3 4 5))"
+                    `((before-after ((map (lambda (x) x) (hilite (list 3 4 5))))
+                                    ((map (lambda (x) x) (hilite `( 3 4 5)))))
+                      (before-after ((hilite (map (lambda (x) x) `(3 4 5))))
+                                    ((... (hilite 3) ...)))
+                      (before-after ((hilite ...))
+                                    ((... (hilite 4) ...)))
+                      (before-after ((hilite ...))
+                                    ((... (hilite 5) ...)))
+                      (before-after ((hilite ...)) ((hilite `(3 4 5))))
+                      (finished (`(3 4 5))))))
+
+  (t quoted-list
+  (test-beginner-wla-sequence "'(3 4 5)"
+                              `((finished ((list 3 4 5))))))
+  
+  
+  ;;;;;;;;;;;;;
+  ;;
+  ;;  QUASIQUOTE
+  ;;
+  ;;;;;;;;;;;;;.
+  
+  ; note: we currently punt on trying to unwind quasiquote.
+  
+  (t qq1
+  (test-beginner-wla-sequence "`(3 4 ,(+ 4 5))"
+                              `((before-after ((cons 3 (cons 4 (cons (hilite (+ 4 5)) empty))))
+                                              ((cons 3 (cons 4 (cons (hilite 9) empty)))))
+                                (before-after ((cons 3 (cons 4 (hilite (cons 9 empty)))))
+                                              ((cons 3 (cons 4 (hilite (list 9))))))
+                                (before-after ((cons 3 (hilite (cons 4 (list 9)))))
+                                              ((cons 3 (hilite (list 4 9)))))
+                                (before-after ((hilite (cons 3 (list 4 9)))) ((hilite (list 3 4 9))))
+                                (finished ((list 3 4 9))))))
+  
+  (t qq-splice
+  (test-beginner-wla-sequence "`(3 ,@(list (+ 3 4) 5) 6)"
+                              `((before-after ((cons 3 (append (list (hilite (+ 3 4)) 5) (cons 6 empty)))) ((cons 3 (append (list (hilite 7) 5) (cons 6 empty)))))
+                                (before-after ((cons 3 (append (list 7 5) (hilite (cons 6 empty))))) ((cons 3 (append (list 7 5) (list 6)))))
+                                (before-after ((cons 3 (hilite (append (list 7 5) (list 6))))) ((cons 3 (hilite (list 7 5 6)))))
+                                (before-after ((hilite (cons 3 (list 7 5 6)))) ((hilite (list 3 7 5 6))))
+                                (finished ((list 3 7 5 6))))))
+  
+  ;;;;;;;;;;;;;
+  ;;
+  ;;  LET
+  ;;
+  ;;;;;;;;;;;;;
+  
+  (t let1 (test-both-ints "(let ([a 3]) 4)"
+                                       `((before-after ((hilite (let ([a 3]) 4))) ((hilite (define a_0 3)) (hilite 4)))
+                                         (finished ((define a_0 3) 4))))) 
+  
+  (t let2
+     (test-both-ints "(let ([a (+ 4 5)] [b (+ 9 20)]) (+ a b))"
+                                 `((before-after ((hilite (let ([a (+ 4 5)] [b (+ 9 20)]) (+ a b))))
+                                                 ((hilite (define a_0 (+ 4 5))) (hilite (define b_0 (+ 9 20))) (hilite (+ a_0 b_0))))
+                                   (before-after-waiting ((define a_0 (hilite (+ 4 5)))) ((define a_0 (hilite 9)))
+                                                         ((define b_0 (+ 9 20))
+                                                          (+ a_0 b_0)))
+                                   (before-after-finished-waiting ((define a_0 9))
+                                                                  ((define b_0 (hilite (+ 9 20)))) ((define b_0 (hilite 29)))
+                                                                  ((+ a_0 b_0)))
+                                   (before-after-finished ((define b_0 29))
+                                                          ((+ (hilite a_0) b_0)) ((+ (hilite 9) b_0)))
+                                   (before-after ((+ 9 (hilite b_0))) ((+ 9 (hilite 29))))
+                                   (before-after ((hilite (+ 9 29))) ((hilite 38)))
+                                   (finished (38)))))
+  
+  (t let-scoping1
+     (test-intermediate-sequence "(let ([a 3]) (let ([a (lambda (x) (+ a x))]) (a 4)))"
+                                 `((before-after ((hilite (let ([a 3]) (let ([a (lambda (x) (+ a x))]) (a 4))))) ((hilite (define a_0 3)) (hilite (let ([a (lambda (x) (+ a_0 x))]) (a 4)))))
+                                   (before-after-finished ((define a_0 3)) ((hilite (let ([a (lambda (x) (+ a_0 x))]) (a 4)))) ((hilite (define a_1 (lambda (x) (+ a_0 x)))) (hilite (a_1 4))))
+                                   (before-after-finished ((define a_1 (lambda (x) (+ a_0 x)))) 
+							  ((hilite (a_1 4)))
+							  ((hilite (+ a_0 4))))
+                                   (before-after ((+ (hilite a_0) 4)) ((+ (hilite 3) 4)))
+                                   (before-after ((hilite (+ 3 4))) ((hilite 7)))
+                                   (finished (7)))))
+  
+  (t let-scoping2
+     (test-intermediate/lambda-sequence "(let ([a 3]) (let ([a (lambda (x) (+ a x))]) (a 4)))"
+                                        `((before-after ((hilite (let ([a 3]) (let ([a (lambda (x) (+ a x))]) (a 4))))) 
+							((hilite (define a_0 3)) (hilite (let ([a (lambda (x) (+ a_0 x))]) (a 4)))))
+                                          (before-after-finished ((define a_0 3)) ((hilite (let ([a (lambda (x) (+ a_0 x))]) (a 4)))) 
+								 ((hilite (define a_1 (lambda (x) (+ a_0 x)))) (hilite (a_1 4))))
+                                          (before-after-finished ((define a_1 (lambda (x) (+ a_0 x))))
+                                                                 (((hilite a_1) 4)) (((hilite (lambda (x) (+ a_0 x))) 4)))
+                                          (before-after ((hilite ((lambda (x) (+ a_0 x)) 4))) ((hilite (+ a_0 4))))
+                                          (before-after ((+ (hilite a_0) 4)) ((+ (hilite 3) 4)))
+                                          (before-after ((hilite (+ 3 4))) ((hilite 7)))
+                                          (finished (7)))))
+  
+  (t let-scoping3
+     (test-intermediate-sequence "(define a12 3) (define c12 19) (let ([a12 13] [b12 a12]) (+ b12 a12 c12))"
+                              `((before-after-finished ((define a12 3) (define c12 19))
+                                                       ((hilite (let ([a12 13] [b12 a12]) (+ b12 a12 c12)))) 
+						       ((hilite (define a12_0 13)) (hilite (define b12_0 a12)) (hilite (+ b12_0 a12_0 c12))))
+                                (before-after-finished-waiting ((define a12_0 13))
+                                                       ((define b12_0 (hilite a12))) ((define b12_0 (hilite 3)))
+                                                       ( (+ b12_0 a12_0 c12)))
+                                (before-after-finished ((define b12_0 3))
+                                                       ((+ (hilite b12_0) a12_0 c12)) ((+ (hilite 3) a12_0 c12)))
+                                (before-after ((+ 3 (hilite a12_0) c12)) ((+ 3 (hilite 13) c12)))
+                                (before-after ((+ 3 13 (hilite c12))) ((+ 3 13 (hilite 19))))
+                                (before-after ((hilite (+ 3 13 19))) ((hilite 35)))
+                                (finished (35)))))
+    
+  (t let-lifting1
+     (test-intermediate-sequence "(let ([a (lambda (x) (+ x 14))] [b (+ 3 4)]) 9)"
+                                 `((before-after ((hilite (let ([a (lambda (x) (+ x 14))] [b (+ 3 4)]) 9))) 
+                                                 ((hilite (define a_0 (lambda (x) (+ x 14)))) (hilite (define b_0 (+ 3 4))) (hilite 9)))
+                                   (before-after-finished-waiting ((define a_0 (lambda (x) (+ x 14))))
+                                                                  ((define b_0 (hilite (+ 3 4)))) ((define b_0 (hilite 7)))
+                                                                  (9))
+                                   (finished ((define b_0 7) 9)))))
+    
+    (t let-deriv
+       (test-intermediate-sequence "(define (f g) (let ([gp (lambda (x) (/ (- (g (+ x 0.1)) (g x)) 0.001))]) gp)) (define gprime (f cos))"
+                                   `((before-after-finished ((define (f g) (let ([gp (lambda (x) (/ (- (g (+ x 0.1)) (g x)) 0.001))]) gp)))
+                                                            ((define gprime (hilite (f cos)))) ((define gprime (hilite (let ([gp (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))]) gp)))))
+                                     (before-after ((define gprime (hilite (let ([gp (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))]) gp))))
+                                                   ((hilite (define gp_0 (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001)))) (define gprime (hilite gp_0))))
+                                     (finished ((define gp_0 (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))) (define gprime gp_0))))))
+    
+    ;;;;;;;;;;;;;
+    ;;
+    ;;  LET*
+    ;;
+    ;;;;;;;;;;;;;
+    
+    (t let*-scoping1
+       (test-both-ints "(define a 3) (define c 19) (let* ([a 13] [b a]) (+ b a c))"
+                                `((before-after-finished ((define a 3) (define c 19))
+							 ((hilite (let* ([a 13] [b a]) (+ b a c)))) 
+							 ((hilite (define a_0 13)) (hilite (let* ([b a_0]) (+ b a_0 c)))))
+                                  (before-after-finished ((define a_0 13))
+							 ((hilite (let* ([b a_0]) (+ b a_0 c))))
+							 ((hilite (define b_1 a_0)) (hilite (+ b_1 a_0 c))))
+                                  (before-after-finished-waiting () 
+                                                                 ((define b_1 (hilite a_0))) ((define b_1 (hilite 13)))
+                                                                 ((+ b_1 a_0 c)))
+                                  (before-after-finished ((define b_1 13))
+                                                         ((+ (hilite b_1) a_0 c)) ((+ (hilite 13) a_0 c)))
+                                  (before-after ((+ 13 (hilite a_0) c)) ((+ 13 (hilite 13) c)))
+                                  (before-after ((+ 13 13 (hilite c))) ((+ 13 13 (hilite 19))))
+                                  (before-after ((hilite (+ 13 13 19))) ((hilite 45)))
+                                  (finished (45)))))
+    
+    (t let*-lifting1
+       (test-intermediate-sequence "(let* ([a (lambda (x) (+ x 14))] [b (+ 3 4)]) 9)"
+                                `((before-after ((hilite (let* ([a (lambda (x) (+ x 14))] [b (+ 3 4)]) 9))) 
+						((hilite (define a_0 (lambda (x) (+ x 14)))) (hilite (let* ([b (+ 3 4)]) 9))))
+                                  (before-after-finished ((define a_0 (lambda (x) (+ x 14)))) 
+							 ((hilite (let* ([b (+ 3 4)]) 9)))
+							 ((hilite (define b_1 (+ 3 4))) (hilite 9)))
+                                  (before-after-finished-waiting ()
+                                                                 ((define b_1 (hilite (+ 3 4)))) ((define b_1 (hilite 7)))
+                                                                 (9))
+                                  (finished ((define b_1 7) 9)))))
+    
+  (t let*-deriv
+     (test-intermediate-sequence "(define (f g) (let* ([gp (lambda (x) (/ (- (g (+ x 0.1)) (g x)) 0.001))]) gp)) (define gprime (f cos))"
+                              `((before-after-finished ((define (f g) (let* ([gp (lambda (x) (/ (- (g (+ x 0.1)) (g x)) 0.001))]) gp)))
+                                                       ((define gprime (hilite (f cos)))) ((define gprime (hilite (let* ([gp (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))]) gp)))))
+                                (before-after ((define gprime (hilite (let* ([gp (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))]) gp))))
+                                              ((hilite (define gp_0 (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001)))) (define gprime (hilite gp_0))))
+                                (finished ((define gp_0 (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))) (define gprime gp_0))))))
+  
+  (t let/let*
+     (test-both-ints "(let* ([a 9]) (let ([b 6]) a))"
+                     `((before-after ((hilite (let* ([a 9]) (let ([b 6]) a)))) ((hilite (define a_0 9)) (hilite (let ([b 6]) a_0))))
+                       (before-after-finished ((define a_0 9)) ((hilite (let ([b 6]) a_0))) ((hilite (define b_1 6)) (hilite a_0)))
+                       (before-after-finished ((define b_1 6)) ((hilite a_0)) ((hilite 9)))
+                       (finished (9)))))
+    
+    ;;;;;;;;;;;;;
+    ;;
+    ;;  LETREC
+    ;;
+    ;;;;;;;;;;;;;
+    
+  (t letrec1
+     (test-intermediate-sequence "(define a 3) (define c 19) (letrec ([a 13] [b a]) (+ b a c))"
+                                 `((before-after-finished ((define a 3) (define c 19))
+                                                          ((hilite (letrec ([a 13] [b a]) (+ b a c)))) 
+                                                          ((hilite (define a_0 13)) (hilite (define b_0 a_0)) (hilite (+ b_0 a_0 c))))
+                                   (before-after-finished-waiting ((define a_0 13))
+                                                          ((define b_0 (hilite a_0))) ((define b_0 (hilite 13)))
+                                                          ( (+ b_0 a_0 c)))
+                                   (before-after-finished ((define b_0 13))
+                                                          ((+ (hilite b_0) a_0 c)) ((+ (hilite 13) a_0 c)))
+                                   (before-after ((+ 13 (hilite a_0) c)) ((+ 13 (hilite 13) c)))
+                                   (before-after ((+ 13 13 (hilite c))) ((+ 13 13 (hilite 19))))
+                                   (before-after ((hilite (+ 13 13 19))) ((hilite 45)))
+                                   (finished (45)))))
+      
+  (t letrec2
+      (test-intermediate-sequence "(letrec ([a (lambda (x) (+ x 14))] [b (+ 3 4)]) 9)"
+                                  `((before-after ((hilite (letrec ([a (lambda (x) (+ x 14))] [b (+ 3 4)]) 9))) 
+                                                  ((hilite (define a_0 (lambda (x) (+ x 14)))) (hilite (define b_0 (+ 3 4))) (hilite 9)))
+                                    (before-after-finished-waiting ((define a_0 (lambda (x) (+ x 14))))
+                                                                   ((define b_0 (hilite (+ 3 4)))) ((define b_0 (hilite 7)))
+                                                                   (9))
+                                    (finished ((define b_0 7) 9)))))
+      
+  (t letrec3
+     (test-intermediate-sequence "(define (f g) (letrec ([gp (lambda (x) (/ (- (g (+ x 0.1)) (g x)) 0.001))]) gp)) (define gprime (f cos))"
+                                 `((before-after-finished ((define (f g) (letrec ([gp (lambda (x) (/ (- (g (+ x 0.1)) (g x)) 0.001))]) gp)))
+                                                          ((define gprime (hilite (f cos)))) 
+                                                          ((define gprime (hilite (letrec ([gp (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))]) gp)))))
+                                   (before-after ((define gprime (hilite (letrec ([gp (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))]) gp))))
+                                                 ((hilite (define gp_0 (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001)))) (define gprime (hilite gp_0))))
+                                   (finished ((define gp_0 (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))) (define gprime gp_0))))))
+      ;;;;;;;;;;;;;
+      ;;
+      ;;  RECUR
+      ;;
+      ;;;;;;;;;;;;;
+ 
+  ;; N.B. : we cheat here.  In particular, the rhs of the double-break expression should highlight the whole application, and not
+  ;; just the applied loop identifier.  This is hard to fix because we have an application which is initially hidden, but then later
+  ;; not hidden.  Fixing this involves parameterizing the unwind by what kind of break it was.  Yuck!  So we just fudge the test case.
+  
+  (t recur
+      (test-intermediate-sequence "(define (countdown n) (recur loop ([n n]) (if (= n 0) 13 (loop (- n 1))))) (countdown 2)"
+                                  `((before-after-finished ((define (countdown n) (recur loop ([n n]) (if (= n 0) 13 (loop (- n 1)))))) 
+  							 ((hilite (countdown 2)))
+  							 ((hilite (recur loop ([n 2]) (if (= n 0) 13 (loop (- n 1)))))))
+                                    (before-after ((hilite (recur loop ([n 2]) (if (= n 0) 13 (loop (- n 1)))))) 
+  						((hilite (define (loop_0 n) (if (= n 0) 13 (loop_0 (- n 1))))) ((hilite loop_0) 2)))
+                                    (before-after-finished ((define (loop_0 n) (if (= n 0) 13 (loop_0 (- n 1)))))
+                                                           ((hilite (loop_0 2)))
+  							 ((hilite (if (= 2 0) 13 (loop_0 (- 2 1))))))
+                                    (before-after ((if (hilite (= 2 0)) 13 (loop_0 (- 2 1)))) ((if (hilite false) 13 (loop_0 (- 2 1)))))
+                                    (before-after ((hilite (if false 13 (loop_0 (- 2 1))))) ((hilite (loop_0 (- 2 1)))))
+                                    (before-after ((loop_0 (hilite (- 2 1)))) ((loop_0 (hilite 1))))
+                                    (before-after ((hilite (loop_0 1))) ((hilite (if (= 1 0) 13 (loop_0 (- 1 1))))))
+                                    (before-after ((if (hilite (= 1 0)) 13 (loop_0 (- 1 1)))) ((if (hilite false) 13 (loop_0 (- 1 1)))))
+                                    (before-after ((hilite (if false 13 (loop_0 (- 1 1))))) ((hilite (loop_0 (- 1 1)))))
+                                    (before-after ((loop_0 (hilite (- 1 1)))) ((loop_0 (hilite 0))))
+                                    (before-after ((hilite (loop_0 0))) ((hilite (if (= 0 0) 13 (loop_0 (- 0 1))))))
+                                    (before-after ((if (hilite (= 0 0)) 13 (loop_0 (- 0 1)))) ((if (hilite true) 13 (loop_0 (- 0 1)))))
+                                    (before-after ((hilite (if true 13 (loop_0 (- 0 1))))) ((hilite 13)))
+  				  (finished (13)))))
+  
+    ;;;;;;;;;;;;;
+    ;;
+    ;;  LOCAL
+    ;;
+    ;;;;;;;;;;;;;
+    
+  
+  (t empty-local
+     (test-both-ints "(local () (+ 3 4))"
+                     `((before-after ((hilite (local () (+ 3 4)))) ((hilite (+ 3 4))))
+                       (before-after ((hilite (+ 3 4))) ((hilite 7)))
+                       (finished (7)))))
+  
+  (t local1
+     (test-both-ints "(local ((define a 3) (define b 8)) 4)"
+                     `((before-after ((hilite (local ((define a 3) (define b 8)) 4)))
+                                     ((hilite (define a_0 3)) (hilite (define b_0 8)) (hilite 4)))
+                       (finished ((define a_0 3) (define b_0 8) 4)))))
+    
+  (t local2
+     (test-intermediate-sequence "(local ((define (a x) (+ x 9))) (a 6))"
+                                 `((before-after ((hilite (local ((define (a x) (+ x 9))) (a 6)))) 
+						 ((hilite (define (a_0 x) (+ x 9))) (hilite (a_0 6))))
+                                   (before-after-finished ((define (a_0 x) (+ x 9)))
+                                                          ((hilite (a_0 6))) ((hilite (+ 6 9))))
+                                   (before-after ((hilite (+ 6 9))) ((hilite 15)))
+                                   (finished (15)))))
+  
+  (t local3
+     (test-intermediate/lambda-sequence "(local ((define (a x) (+ x 9))) (a 6))"
+                                        `((before-after ((hilite (local ((define (a x) (+ x 9))) (a 6)))) 
+							((hilite (define (a_0 x) (+ x 9))) (hilite (a_0 6))))
+                                          (before-after-finished ((define (a_0 x) (+ x 9)))
+                                                                 (((hilite a_0) 6)) (((hilite (lambda (x) (+ x 9))) 6)))
+                                          (before-after ((hilite ((lambda (x) (+ x 9)) 6))) ((hilite (+ 6 9))))
+                                          (before-after ((hilite (+ 6 9))) ((hilite 15)))
+                                          (finished (15)))))
+    
+  (t local4
+     (test-intermediate-sequence "(local ((define (a x) (+ x 13))) a)"
+                                 `((before-after ((hilite (local ((define (a x) (+ x 13))) a))) ((hilite (define (a_0 x) (+ x 13))) (hilite a_0)))
+                                   (finished ((define (a_0 x) (+ x 13)) a_0)))))
+  
+  (t local5
+     (test-intermediate/lambda-sequence "(local ((define (a x) (+ x 13))) a)"
+                                        `((before-after ((hilite (local ((define (a x) (+ x 13))) a))) ((hilite (define (a_0 x) (+ x 13))) (hilite a_0)))
+                                          (before-after ((hilite a_0)) ((hilite (lambda (x) (+ x 13)))))
+                                          (finished ((define (a_0 x) (+ x 13)) (lambda (x) (+ x 13)))))))
+  
+  (t local-interref1
+     (test-intermediate-sequence "(local ((define (a x) (+ x 9)) (define b a) (define p (+ 3 4))) (b 1))"
+                                 `((before-after ((hilite (local ((define (a x) (+ x 9)) (define b a) (define p (+ 3 4))) (b 1))))
+                                                 ((hilite (define (a_0 x) (+ x 9))) (hilite (define b_0 a_0)) (hilite (define p_0 (+ 3 4))) (hilite (b_0 1))))
+                                   (before-after-finished-waiting ((define (a_0 x) (+ x 9)) (define b_0 a_0))
+                                                                  ((define p_0 (hilite (+ 3 4)))) ((define p_0 (hilite 7))) ((b_0 1)))
+                                   (before-after-finished ((define p_0 7))
+                                                          (((hilite b_0) 1)) (((hilite a_0) 1)))
+                                   (before-after ((hilite (a_0 1))) ((hilite (+ 1 9))))
+                                   (before-after ((hilite (+ 1 9))) ((hilite 10)))
+                                   (finished (10)))))
+  
+  (t local-interref2
+     (test-intermediate/lambda-sequence "(local ((define (a x) (+ x 9)) (define b a) (define p (+ 3 4))) (b 1))"
+                                        `((before-after ((hilite (local ((define (a x) (+ x 9)) (define b a) (define p (+ 3 4))) (b 1))))
+                                                        ((hilite (define (a_0 x) (+ x 9))) (hilite (define b_0 a_0)) (hilite (define p_0 (+ 3 4))) (hilite (b_0 1))))
+                                          (before-after-finished-waiting ((define (a_0 x) (+ x 9)))
+                                                                         ((define b_0 (hilite a_0))) ((define b_0 (hilite (lambda (x) (+ x 9))))) ((define p_0 (+ 3 4)) (b_0 1)))
+                                          (before-after-finished-waiting ((define b_0 (lambda (x) (+ x 9))))
+                                                                         ((define p_0 (hilite (+ 3 4)))) ((define p_0 (hilite 7))) ((b_0 1)))
+                                          (before-after-finished ((define p_0 7))
+                                                                 (((hilite b_0) 1)) (((hilite (lambda (x) (+ x 9))) 1)))
+                                          (before-after ((hilite ((lambda (x) (+ x 9)) 1))) ((hilite (+ 1 9))))
+                                          (before-after ((hilite (+ 1 9))) ((hilite 10)))
+                                          (finished (10)))))
+    
+  (t local-gprime
+     (test-intermediate-sequence "(define (f12 g) (local ([define (gp x) (/ (- (g (+ x 0.1)) (g x)) 0.1)]) gp)) (define gprime (f12 cos))"
+                                 `((before-after-finished ((define (f12 g) (local ([define (gp x) (/ (- (g (+ x 0.1)) (g x)) 0.1)]) gp)))
+                                                          ((define gprime (hilite (f12 cos)))) 
+                                                          ((define gprime (hilite (local ([define (gp x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1)]) gp)))))
+                                   (before-after ((define gprime (hilite (local ([define (gp x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1)]) gp))))
+                                                 ((hilite (define (gp_0 x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1))) (define gprime (hilite gp_0))))
+                                   (finished ((define (gp_0 x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1)) (define gprime gp_0))))))
+  
+  (t local-gprime/lambda
+     (test-intermediate/lambda-sequence "(define (f12 g) (local ([define (gp x) (/ (- (g (+ x 0.1)) (g x)) 0.1)]) gp)) (define gprime (f12 cos))"
+                                        `((before-after-finished ((define (f12 g) (local ([define (gp x) (/ (- (g (+ x 0.1)) (g x)) 0.1)]) gp)))
+                                                                 ((define gprime ((hilite f12) cos))) 
+                                                                 ((define gprime ((hilite (lambda (g) (local ([define (gp x) (/ (- (g (+ x 0.1)) (g x)) 0.1)]) gp))) cos))))
+                                          (before-after ((define gprime (hilite ((lambda (g) (local ([define (gp x) (/ (- (g (+ x 0.1)) (g x)) 0.1)]) gp)) cos))))
+                                                        ((define gprime (hilite (local ([define (gp x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1)]) gp)))))
+                                          (before-after ((define gprime (hilite (local ([define (gp x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1)]) gp))))
+                                                        ((hilite (define (gp_0 x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1))) (define gprime (hilite gp_0))))
+                                          (before-after-finished ((define (gp_0 x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1)))
+                                                                 ((define gprime (hilite gp_0))) ((define gprime (hilite (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1))))))
+                                          (finished ((define (gp_0 x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1)) (define gprime (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1))))))))
+  
+  ; test generativity... that is, multiple evaluations of a local get different lifted names:
+  
+  (t local-generative
+     (test-intermediate-sequence "(define (a13 b13 c13) (b13 c13)) (define (f9 x) (local ((define (maker dc) x)) maker)) (define m1 (f9 3)) (a13 (f9 4) 1)"
+                                 `((before-after-finished ((define (a13 b13 c13) (b13 c13))
+                                                           (define (f9 x) (local ((define (maker dc) x)) maker)))
+                                                          ((define m1 (hilite (f9 3)))) ((define m1 (hilite (local ((define (maker dc) 3)) maker)))))
+                                   (before-after ((define m1 (hilite (local ((define (maker dc) 3)) maker))))
+                                                 ((hilite (define (maker_0 dc) 3)) (define m1 (hilite maker_0))))
+                                   (before-after-finished ((define (maker_0 dc) 3) (define m1 maker_0))
+                                                          ((a13 (hilite (f9 4)) 1)) ((a13 (hilite (local ((define (maker dc) 4)) maker)) 1)))
+                                   (before-after ((a13 (hilite (local ((define (maker dc) 4)) maker)) 1))
+                                                 ((hilite (define (maker_1 dc) 4)) (a13 (hilite maker_1) 1)))
+                                   (before-after-finished ((define (maker_1 dc) 4))
+                                                          ((hilite (a13 maker_1 1))) ((hilite (maker_1 1))))
+                                   (before-after ((hilite (maker_1 1))) ((hilite 4)))
+                                   (finished (4)))))
+  
+  (t local-generative/lambda
+     (test-intermediate/lambda-sequence "(define (a13 b13 c13) (b13 c13)) (define (f9 x) (local ((define (maker dc) x)) maker)) (define m1 (f9 3)) (a13 (f9 4) 1)"
+                                        `((before-after-finished ((define (a13 b13 c13) (b13 c13))
+                                                                  (define (f9 x) (local ((define (maker dc) x)) maker)))
+                                                                 ((define m1 ((hilite f9) 3))) ((define m1 ((hilite (lambda (x) (local ((define (maker dc) x)) maker))) 3))))
+                                          (before-after ((define m1 (hilite ((lambda (x) (local ((define (maker dc) x)) maker)) 3)))) 
+                                                        ((define m1 (hilite (local ((define (maker dc) 3)) maker)))))
+                                          (before-after ((define m1 (hilite (local ((define (maker dc) 3)) maker))))
+                                                        ((hilite (define (maker_0 dc) 3)) (define m1 (hilite maker_0))))
+                                          (before-after-finished ((define (maker_0 dc) 3)) 
+                                                                 ((define m1 (hilite maker_0))) ((define m1 (hilite (lambda (dc) 3)))))
+                                          (before-after-finished ((define m1 (lambda (dc) 3)))
+                                                                 (((hilite a13) (f9 4) 1)) (((hilite (lambda (b13 c13) (b13 c13))) (f9 4) 1)))
+                                          (before-after (((lambda (b13 c13) (b13 c13)) ((hilite f9) 4) 1)) 
+                                                        (((lambda (b13 c13) (b13 c13)) ((hilite (lambda (x) (local ((define (maker dc) x)) maker))) 4) 1)))
+                                          (before-after (((lambda (b13 c13) (b13 c13)) (hilite ((lambda (x) (local ((define (maker dc) x)) maker)) 4)) 1)) 
+                                                        (((lambda (b13 c13) (b13 c13)) (hilite (local ((define (maker dc) 4)) maker)) 1)))
+                                          (before-after (((lambda (b13 c13) (b13 c13)) (hilite (local ((define (maker dc) 4)) maker)) 1))
+                                                        ((hilite (define (maker_1 dc) 4)) ((lambda (b13 c13) (b13 c13)) (hilite maker_1) 1)))
+                                          (before-after-finished ((define (maker_1 dc) 4))
+                                                                 (((lambda (b13 c13) (b13 c13)) (hilite maker_1) 1)) 
+                                                                 (((lambda (b13 c13) (b13 c13)) (hilite (lambda (dc) 4)) 1)))
+                                          (before-after ((hilite ((lambda (b13 c13) (b13 c13)) (lambda (dc) 4) 1))) ((hilite ((lambda (dc) 4) 1))))
+                                          (before-after ((hilite ((lambda (dc) 4) 1))) ((hilite 4)))
+                                          (finished (4)))))
+  
+  ;;;;;;;;;;;;;
+  ;;
+  ;;  Reduction of Lambda in int/lambda
+  ;;
+  ;;;;;;;;;;;;;
+  
+  (t int/lam1
+     (test-intermediate/lambda-sequence "(define f ((lambda (x) x) (lambda (x) x))) (f f)"
+                                        `((before-after ((define f (hilite ((lambda (x) x) (lambda (x) x))))) ((define f (hilite (lambda (x) x)))))
+                                          (before-after-finished ((define f (lambda (x) x)))
+                                                                 (((hilite f) f)) (((hilite (lambda (x) x)) f)))
+                                          (before-after (((lambda (x) x) (hilite f))) (((lambda (x) x) (hilite (lambda (x) x)))))
+                                          (before-after ((hilite ((lambda (x) x) (lambda (x) x)))) ((hilite (lambda (x) x))))
+                                          (finished ((define f (lambda (x) x)) (lambda (x) x))))))
+  
+  
+  (t int/lam2
+     (test-intermediate/lambda-sequence "(define f (if false (lambda (x) x) (lambda (x) x))) (f f)"
+                                        `((before-after ((define f (hilite (if false (lambda (x) x) (lambda (x) x))))) 
+                                                        ((define f (hilite (lambda (x) x)))))
+                                          (before-after-finished ((define f (lambda (x) x)))
+                                                                 (((hilite f) f)) (((hilite (lambda (x) x)) f)))
+                                          (before-after (((lambda (x) x) (hilite f))) (((lambda (x) x) (hilite (lambda (x) x)))))
+                                          (before-after ((hilite ((lambda (x) x) (lambda (x) x)))) ((hilite (lambda (x) x))))
+                                          (finished ((define f (lambda (x) x)) (lambda (x) x))))))
+  
+  
+  (t time
+     (test-intermediate-sequence "(time (+ 3 4))"
+                                 `((before-after ((hilite (+ 3 4)))
+                                                 ((hilite 7)))
+                                   (finished (7)))))
+  
+  
+  ;;;;;;;;;;;;;;;;
+  ;;
+  ;;  XML (uses MrEd)
+  ;;
+  ;;;;;;;;;;;;;;;;
+    
+  #;(t ddj-screenshot
+     (test-mz-sequence (define-syntax (xml stx)
+                                (letrec ([process-xexpr 
+                                          (lambda (xexpr)
+                                            (syntax-case xexpr (lmx lmx-splice)
+                                              [(lmx-splice unquoted) #`(unquote-splicing unquoted)]
+                                              [(lmx unquoted) #`(unquote unquoted)]
+                                              [(tag ([attr val] ...) . sub-xexprs)
+                                               (identifier? #`tag)
+                                               #`(tag ([attr val] ...) #,@(map process-xexpr (syntax->list #`sub-xexprs)))]
+                                              [(tag . sub-xexprs)
+                                               (identifier? #`tag)
+                                               #`(tag () #,@(map process-xexpr (syntax->list #`sub-xexprs)))]
+                                              [str
+                                               (string? (syntax-e #`str))
+                                               xexpr]))])
+                                  (syntax-case stx ()
+                                    [(_ xexpr) #`(quasiquote #,(process-xexpr #`xexpr))])))
+     (xml (article (header (author "John Clements")
+                           (title (if (< 3 4)
+                                      (xml "No Title Available")
+                                      (get-title))))
+                   (text "More Sample Text")))
+     '((before-after-finished ((define-syntax (xml stx)
+                                 (letrec ([process-xexpr 
+                                           (lambda (xexpr)
+                                             (syntax-case xexpr (lmx lmx-splice)
+                                               [(lmx-splice unquoted) #`(unquote-splicing unquoted)]
+                                               [(lmx unquoted) #`(unquote unquoted)]
+                                               [(tag ([attr val] ...) . sub-xexprs)
+                                                (identifier? #`tag)
+                                                #`(tag ([attr val] ...) #,@(map process-xexpr (syntax->list #`sub-xexprs)))]
+                                               [(tag . sub-xexprs)
+                                                (identifier? #`tag)
+                                                #`(tag () #,@(map process-xexpr (syntax->list #`sub-xexprs)))]
+                                               [str
+                                                (string? (syntax-e #`str))
+                                                xexpr]))])
+                                   (syntax-case stx ()
+                                     [(_ xexpr) #`(quasiquote #,(process-xexpr #`xexpr))]))))
+                              ((xml ))
+                              ((xml (a ([a "x"]) "ab" "hdo" "hon")))))))
+  
+  #;(define (test-xml-sequence namespace-spec render-settings track-inferred-names? spec expected-steps)
+    (letrec ([port (open-input-text-editor (construct-text spec))])
+      (test-sequence-core namespace-spec render-settings track-inferred-names? port expected-steps)))
+  
+  #;(define (construct-text spec)
+    (let ([new-text (instantiate text% ())])
+      (for-each
+       (match-lambda 
+         [`(xml-box ,@(xmlspec ...)) (send new-text insert (construct-xml-box xmlspec))]
+         [(? string? text) (send new-text insert text)])
+       spec)
+      new-text))
+  
+  #;(define (test-xml-beginner-sequence spec expected)
+    (test-xml-sequence `(lib "htdp-beginner.ss" "lang")
+                        fake-beginner-render-settings
+                        #t
+                        spec
+                        expected))
+  
+  #;(t xml-box1
+     (test-xml-beginner-sequence `((xml-box "<abba>3</abba>"))
+                                 `((finished ((xml-box-value (cons 'abba (cons empty (cons "3" empty)))))))))
+  
+  #;(t xml-box2
+     (text-xml-beginnner-sequence `("(cdr (cdr " (xml-box "<foozle>a b</foozle>") "))")
+                                  `((before-after ((cdr (cdr (xml-box "<foozle>a b</foozle>"))))))))
+  
+  ;  
+  ;  ;;;;;;;;;;;;;
+  ;  ;;
+  ;  ;;  TIME
+  ;  ;;
+  ;  ;;;;;;;;;;;;;
+  ;  
+  ;  (test-intermediate-sequence "(time (+ 3 4))"
+  ;                              `((before-after ((time (hilite ,h-p))) ((+ 3 4)) same (7))
+  ;                                (before-after ((hilite ,h-p)) ((time 7)) same (7))
+  ;                                (result (7))))
+  
+  
+  ;(t filled-rect-image 
+  ;   (test-upto-int-lam "(image-width (filled-rect 10 10 'blue))"
+  ;                      `((before-after ((image-width (hilite (filled-rect 10 10 'blue)))) ((image-width (hilite )))))))
+  ; add image test: (image-width (filled-rect 10 10 'blue))
+  
+  ;;;;;;;;;;;;;;
+  ;;
+  ;;  PRIM TESTS
+  ;;
+  ;;;;;;;;;;;;;;
+
+  
+  
+  
+  ;  ;;;;;;;;;;;;;
+  ;  ;;
+  ;  ;;  TEACHPACK TESTS
+  ;  ;;
+  ;  ;;;;;;;;;;;;;
+  ;  
+  
+  ; as you can see, many teachpack tests work only in mred:
+  #; (require (lib "mred.ss" "mred"))
+  
+  
+  (define test-teachpack-sequence (lambda (teachpack-specs expr-string expected-results)
+                                    ;(let ([new-custodian (make-custodian)])
+                                     ; (parameterize ([current-custodian new-custodian])
+                                      ;  (parameterize ([current-eventspace (make-eventspace)])
+                                          (test-sequence `(lib "htdp-beginner.ss" "lang") teachpack-specs fake-beginner-render-settings #t expr-string expected-results)
+                                    ;))
+                                     ; (custodian-shutdown-all new-custodian))
+      ))
+  
+    
+  ; uses set-render-settings!
+  ;(reconstruct:set-render-settings! fake-beginner-render-settings)
+  ;(test-sequence "(define (check-guess guess target) 'TooSmall) (guess-with-gui check-guess)"
+  ;               `((before-after ((hilite ,h-p)) ((guess-with-gui check-guess)))
+  ;                 (((hilite ,h-p)) (true)))
+  ;               `((define (check-guess guess target) 'toosmall) true)
+  ;               tp-namespace)
+  
+  #;(t teachpack-drawing
+  (test-teachpack-sequence 
+   `((lib "draw.ss" "htdp"))
+   "(define (draw-limb i) (cond  
+ [(= i 1) (draw-solid-line (make-posn 20 20) (make-posn 20 100) 'blue)] 
+ [(= i 0) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)]))  
+ (and (start 100 100)
+ (draw-limb 0))"
+   `((before-after-finished ((define (draw-limb i) (cond [(= i 1) (draw-solid-line (make-posn 20 20) (make-posn 20 100) 'blue)] 
+                                                         [(= i 0) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)])))
+                            ((and (hilite (start 100 100)) (draw-limb 0)))
+                            ((and (hilite true) (draw-limb 0))))
+     (before-after ((and true (hilite (draw-limb 0))))
+                   ((and true (hilite (cond [(= 0 1) (draw-solid-line (make-posn 20 20) (make-posn 20 100) 'blue)] 
+                                            [(= 0 0) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)])))))
+     (before-after ((and true (cond [(hilite (= 0 1)) (draw-solid-line (make-posn 20 20) (make-posn 20 100) 'blue)] 
+                                    [(= 0 0) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)])))
+                   ((and true (cond [(hilite false) (draw-solid-line (make-posn 20 20) (make-posn 20 100) 'blue)] 
+                                    [(= 0 0) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)]))))
+     (before-after ((and true (hilite (cond [false (draw-solid-line (make-posn 20 20) (make-posn 20 100) 'blue)] 
+                                            [(= 0 0) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)]))))
+                   ((and true (hilite (cond [(= 0 0) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)])))))
+     (before-after ((and true (cond [(hilite (= 0 0)) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)])))
+                   ((and true (cond [(hilite true) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)]))))
+     (before-after ((and true (hilite (cond [true (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)]))))
+                   ((and true (hilite (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)))))
+     (before-after ((and true (draw-solid-line (make-posn (hilite (+ 1 10)) 10) (make-posn 10 100) 'red)))
+                   ((and true (draw-solid-line (make-posn (hilite 11) 10) (make-posn 10 100) 'red))))
+     (before-after ((and true (hilite (draw-solid-line (make-posn 11 10) (make-posn 10 100) 'red)))) 
+                   ((and true (hilite true))))
+     (before-after ((hilite (and true true)))
+                   ((hilite true)))
+     (finished (true)))))
+  
+  #;(t teachpack-name-rendering
+     (test-teachpack-sequence
+      `((file "/Users/clements/plt/teachpack/htdp/draw.ss"))
+      "(start 300 300) (if true (get-key-event) 3)"
+      `((before-after ((hilite (start 300 300)))
+                     ((hilite true)))
+        (before-after-finished (true)
+                               ((hilite (if true (get-key-event) 3)))
+                               ((hilite (get-key-event))))
+        (before-after ((hilite (get-key-event)))
+                      ((hilite false)))
+        (finished (false)))))
+  
+  #;(t teachpack-hop-names
+     (test-teachpack-sequence
+      `((file "/Users/clements/plt/teachpack/htdp/draw.ss"))
+      "(start 300 300) (define (a x y) (+ 3 4)) (if true (on-key-event a) 3)"
+      `((before-after ((hilite (start 300 300)))
+                      ((hilite true)))
+        (before-after-finished (true (define (a x y) (+ 3 4)))
+                               ((hilite (if true (on-key-event a) 3)))
+                               ((hilite (on-key-event a))))
+        (before-after ((hilite (on-key-event a)))
+                      ((hilite true)))
+        (finished (true)))))
+ 
+  #;(t teachpack-web-interaction
+  (test-teachpack-sequence
+   `((lib "servlet2.ss" "htdp"))
+"(define (adder go) (inform (number->string (+ (single-query (make-number \"enter 10\")) (single-query (make-number \"enter 20\"))))))
+(adder true)"
+`((before-after-finished ((define (adder go) (inform (number->string (+ (single-query (make-number "enter 10")) (single-query (make-number "enter 20")))))))
+                         ((hilite (adder true)))
+                         ((hilite (inform (number->string (+ (single-query (make-number "enter 10")) (single-query (make-number "enter 20"))))))))
+  (before-after ((inform (number->string (+ (single-query (hilite (make-number "enter 10"))) (single-query (make-number "enter 20")))))) ; this step looks wrong wrong wrong.
+                ((inform (number->string (+ (single-query (hilite (make-numeric "enter 10"))) (single-query (make-number "enter 20")))))))
+  (before-after ((inform (number->string (+ (hilite (single-query (make-numeric "enter 10"))) (single-query (make-number "enter 20"))))))
+                ((inform (number->string (+ (hilite 10) (single-query (make-number "enter 20")))))))
+  (before-after ((inform (number->string (+ 10 (single-query (hilite (make-number "enter 20")))))))
+                ((inform (number->string (+ 10 (single-query (hilite (make-numeric "enter 20"))))))))
+  (before-after ((inform (number->string (+ 10 (hilite (single-query (make-numeric "enter 20")))))))
+                ((inform (number->string (+ 10 (hilite 20))))))
+  (before-after ((inform (number->string (hilite (+ 10 20))))) 
+                ((inform (number->string (hilite 30)))))
+  (before-after ((inform (hilite (number->string 30)))) 
+                ((inform (hilite "30"))))
+  (before-after ((hilite (inform "30")))
+                ((hilite true)))
+  (finished (true)))))
+  
+  #;(t teachpack-callbacks
+     (test-teachpack-sequence " (define (f2c x) x) (convert-gui f2c)" `() ; placeholder
+                               ))
+  
+  #;(run-tests '(let-scoping1))
+  (run-all-tests)
+  )
diff --git a/collects/tests/stepper/two-tests.ss b/collects/tests/stepper/two-tests.ss
new file mode 100644
index 0000000000..8f631e25e4
--- /dev/null
+++ b/collects/tests/stepper/two-tests.ss
@@ -0,0 +1,8 @@
+(define (mult a b) (* a b))
+(define g (if #f mult +))
+(define (f a b)  (g 3 4))
+(f 5 6)
+
+;(define (f x) x)
+;(define g +)
+;g
\ No newline at end of file
diff --git a/collects/tests/stepper/unannotated.ss b/collects/tests/stepper/unannotated.ss
new file mode 100644
index 0000000000..d3d5f1b8d5
--- /dev/null
+++ b/collects/tests/stepper/unannotated.ss
@@ -0,0 +1,14 @@
+(define (squar x) (* x x))
+
+(define (square-all list-of-numbers)
+  (map squar list-of-numbers))
+
+(define (my-map a-list)
+  (cond [(empty? a-list) empty]
+        [else (cons (square-all (car a-list))
+                    (my-map (cdr a-list)))]))
+
+(my-map (cons (cons 1 (cons 3 (cons 14 empty)))
+              (cons (cons 3 (cons 4 empty))
+                    (cons (cons 43 empty)
+                          empty))))
\ No newline at end of file
diff --git a/collects/tests/stepper/undefined.ss b/collects/tests/stepper/undefined.ss
new file mode 100644
index 0000000000..c1b0730e01
--- /dev/null
+++ b/collects/tests/stepper/undefined.ss
@@ -0,0 +1 @@
+x
\ No newline at end of file
diff --git a/collects/tests/stepper/write-display.ss b/collects/tests/stepper/write-display.ss
new file mode 100644
index 0000000000..67ce9bb113
--- /dev/null
+++ b/collects/tests/stepper/write-display.ss
@@ -0,0 +1,3 @@
+(define (f x) "some string")
+
+(f 3)
\ No newline at end of file
diff --git a/collects/tests/syntax-color/paren-tree.ss b/collects/tests/syntax-color/paren-tree.ss
new file mode 100644
index 0000000000..e850c0e540
--- /dev/null
+++ b/collects/tests/syntax-color/paren-tree.ss
@@ -0,0 +1,235 @@
+(load-relative "../mzscheme/loadtest.ss")
+(require (lib "class.ss")
+         (lib "paren-tree.ss" "syntax-color"))
+
+(define t (new paren-tree% (matches '((|(| |)|)
+                                      (|[| |]|)))))
+
+
+(SECTION 'add-token)
+(send t add-token #f 12)
+(test '(((0 12 (#f . 12))) ())
+      'add-token
+      (send t test))
+(send t add-token #f 1)
+(test '(((0 13 (#f . 12))) ())
+      'add-token
+      (send t test))
+(send t add-token '|)| 3)
+(test '(((0 13 (#f . 12))
+         (13 3 (|)| . 3)))
+        ())
+      'add-token
+      (send t test))
+(send t add-token #f 3)
+(test '(((0 13 (#f . 12))
+         (13 6 (|)| . 3)))
+        ())
+      'add-token
+      (send t test))
+
+(SECTION 'split-tree)
+(define (build-tree)
+  (set! t (new paren-tree% (matches '((|(| |)|) (|[| |]|)))))
+  (send t add-token #f 2)
+  (send t add-token #f 2)
+  (send t add-token '|(| 2)
+  (send t add-token #f 2)
+  (send t add-token '|(| 2)
+  (send t add-token '|(| 2)
+  (send t add-token #f 2)
+  (send t add-token #f 2))
+(build-tree)
+(test '(((0 4 (#f . 2))
+         (4 4 (|(| . 2))
+         (8 2 (|(| . 2))
+         (10 6 (|(| . 2)))
+        ())
+      'add-token
+      (send t test))
+(define (split-test pos res)
+  (send t split-tree pos)
+  (test res 'split-tree (send t test)))
+(split-test 16 '(((0 4 (#f . 2))
+                  (4 4 (|(| . 2))
+                  (8 2 (|(| . 2))
+                  (10 6 (|(| . 2)))
+                 ((0 0 (#f . 0)))))
+(split-test 14 '(((0 4 (#f . 2))
+                  (4 4 (|(| . 2))
+                  (8 2 (|(| . 2))
+                  (10 4 (|(| . 2)))
+                 ((0 2 (#f . 0)))))
+(split-test 12 '(((0 4 (#f . 2))
+                  (4 4 (|(| . 2))
+                  (8 2 (|(| . 2))
+                  (10 2 (|(| . 2)))
+                 ((0 2 (#f . 0)))))
+(split-test 10 '(((0 4 (#f . 2))
+                  (4 4 (|(| . 2))
+                  (8 2 (|(| . 2)))
+                 ((0 2 (|(| . 2)))))
+(split-test 8 '(((0 4 (#f . 2))
+                  (4 4 (|(| . 2)))
+                 ((0 2 (|(| . 2)))))
+(split-test 6 '(((0 4 (#f . 2))
+                 (4 2 (|(| . 2)))
+                ((0 2 (#f . 0)))))
+(split-test 4 '(((0 4 (#f . 2)))
+                ((0 2 (|(| . 2)))))
+(split-test 2 '(((0 2 (#f . 2)))
+                ((0 2 (#f . 0)))))
+(split-test 0 '(()
+                ((0 2 (#f . 2)))))
+(build-tree)
+(split-test 6 '(((0 4 (#f . 2))
+                 (4 2 (|(| . 2)))
+                ((0 2 (#f . 0))
+                 (2 2 (|(| . 2))
+                 (4 6 (|(| . 2)))))
+
+(set! t (new paren-tree% (matches '((|(| |)|) (|[| |]|)))))
+(split-test 0 '(()()))
+
+(SECTION 'merge-tree)
+(build-tree)
+(send t split-tree 6)
+(send t merge-tree 10)
+(test '(((0 4 (#f . 2))
+         (4 4 (|(| . 2))
+         (8 2 (|(| . 2))
+         (10 6 (|(| . 2)))
+        ())
+      'merge-tree
+      (send t test))
+(send t split-tree 6)
+(send t merge-tree 0)
+(test '(((0 4 (#f . 2))
+         (4 2 (|(| . 2)))
+        ())
+      'merge-tree
+      (send t test))
+(send t split-tree 6)
+(send t merge-tree 0)
+(test '(((0 4 (#f . 2))
+         (4 2 (|(| . 2)))
+        ())
+      'merge-tree
+      (send t test))
+
+(SECTION 'truncate)
+(build-tree)
+(send t truncate 0)
+(test '(()())
+      'truncate
+      (send t test))
+(build-tree)
+(send t truncate 6)
+(test '(((0 4 (#f . 2))
+         (4 2 (|(| . 2)))
+        ())
+      'truncate
+      (send t test))
+
+(define (build-tree)
+  (set! t (new paren-tree% (matches '((|(| |)|) (|[| |]|)))))
+  (send t add-token '|(| 2)
+  (send t add-token '|[| 2)
+  (send t add-token '|]| 2)
+  (send t add-token #f 2)
+  (send t add-token '|[| 2)
+  (send t add-token #f 2)
+  (send t add-token '|]| 2)
+  (send t add-token '|)| 2))
+(build-tree)
+(test '(((0 2 (|(| . 2))
+         (2 2 (|[| . 2))
+         (4 4 (|]| . 2))
+         (8 4 (|[| . 2))
+         (12 2 (|]| . 2))
+         (14 2 (|)| . 2)))
+        ())
+      'add-token
+      (send t test))
+
+(SECTION 'is-open-pos?)
+(build-tree)
+(test '|)| 'is-open-pos? (send t is-open-pos? 0))
+(test '|]| 'is-open-pos? (send t is-open-pos? 2))
+(test #f 'is-open-pos? (send t is-open-pos? 4))
+(test #f 'is-open-pos? (send t is-open-pos? 6))
+(test '|]| 'is-open-pos? (send t is-open-pos? 8))
+(test #f 'is-open-pos? (send t is-open-pos? 10))
+(test #f 'is-open-pos? (send t is-open-pos? 12))
+(test #f 'is-open-pos? (send t is-open-pos? 14))
+(test #f 'is-open-pos? (send t is-open-pos? 16))
+
+(SECTION 'is-close-pos?)
+(test #f 'is-close-pos? (send t is-close-pos? 0))
+(test #f 'is-close-pos? (send t is-close-pos? 2))
+(test '|[| 'is-close-pos? (send t is-close-pos? 4))
+(test #f 'is-close-pos? (send t is-close-pos? 6))
+(test #f 'is-close-pos? (send t is-close-pos? 8))
+(test #f 'is-close-pos? (send t is-close-pos? 10))
+(test '|[| 'is-close-pos? (send t is-close-pos? 12))
+(test '|(| 'is-close-pos? (send t is-close-pos? 14))
+(test #f 'is-close-pos? (send t is-close-pos? 16))
+
+(SECTION 'match)
+(define (test-match-forward num res)
+  (let-values (((a b c) (send t match-forward num)))
+    (test res 'match-forward (list a b c))))
+(define (test-match-backward num res)
+  (let-values (((a b c) (send t match-backward num)))
+    (test res 'match-backward (list a b c))))
+(test-match-forward 0 '(0 16 #f))
+(test-match-forward 2 '(2 6 #f))
+(test-match-forward 4 '(#f #f #f))
+(test-match-forward 6 '(#f #f #f))
+(test-match-forward 8 '(8 14 #f))
+(test-match-forward 10 '(#f #f #f))
+(test-match-forward 12 '(#f #f #f))
+(test-match-forward 14 '(#f #f #f))
+(test-match-forward 16 '(#f #f #f))
+
+(test-match-backward 0 '(#f #f #f))
+(test-match-backward 2 '(#f #f #f))
+(test-match-backward 4 '(#f #f #f))
+(test-match-backward 6 '(2 6 #f))
+(test-match-backward 8 '(#f #f #f))
+(test-match-backward 10 '(#f #f #f))
+(test-match-backward 12 '(#f #f #f))
+(test-match-backward 14 '(8 14 #f))
+(test-match-backward 16 '(0 16 #f))
+
+(define (build-tree)
+  (set! t (new paren-tree% (matches '((|(| |)|) (|[| |]|)))))
+  (send t add-token '|(| 2)
+  (send t add-token '|[| 2)
+  (send t add-token '|)| 2)
+  (send t add-token #f 2)
+  (send t add-token '|[| 2)
+  (send t add-token #f 2)
+  (send t add-token '|]| 2)
+  (send t add-token '|)| 2))
+(build-tree)
+(test-match-forward 0 '(0 2 16))
+(test-match-backward 14 '(8 14 #f))
+(test-match-backward 16 '(14 16 #t))
+(test-match-backward 100 '(#f #f #f))
+
+(set! t (new paren-tree% (matches '((|(| |)|) (|[| |]|)))))
+(send t add-token '|(| 2)
+(test-match-forward 0 '(0 2 2))
+
+(set! t (new paren-tree% (matches '((|(| |)|) (|[| |]|)))))
+(send t add-token '|)| 2)
+(test-match-backward 2 '(0 2 #t))
+
+
+(report-errs)
+
+
+
+;match-forward
+;match-backward
diff --git a/collects/tests/syntax-color/token-tree.ss b/collects/tests/syntax-color/token-tree.ss
new file mode 100644
index 0000000000..fd586229ad
--- /dev/null
+++ b/collects/tests/syntax-color/token-tree.ss
@@ -0,0 +1,178 @@
+(load-relative "../mzscheme/loadtest.ss")
+(require (lib "class.ss")
+         (lib "token-tree.ss" "syntax-color"))
+
+(define t (new token-tree% (length 1) (data 'a)))
+
+(define (check-only-root)
+  (test #f 'get-root (not (send t get-root)))
+  (test #f node-left (send t get-root))
+  (test #f node-right (send t get-root)))
+
+(define (check-root len dat sp ep)
+  (test len 'get-root-length (send t get-root-length))
+  (test dat 'get-root-data (send t get-root-data))
+  (test sp 'get-root-start-position (send t get-root-start-position))
+  (test ep 'get-root-end-position (send t get-root-end-position)))
+
+(SECTION 'init-tree)
+(test #f 'is-empty (send t is-empty?))
+(check-only-root)
+(check-root 1 'a 0 1)
+
+(send t reset-tree)
+(SECTION 'empty-tree)
+(test #f 'get-root (send t get-root))
+(test #t 'is-empty (send t is-empty?))
+(check-root 0 #f 0 0)
+
+(define (build-tree n len?)
+  (when (> n 0)
+    (insert-first! t (new token-tree% (length (if len? 5 n)) (data (list n 1))))
+    (insert-last! t (new token-tree% (length (if len? 5 n)) (data (list n 2))))
+    (build-tree (sub1 n) len?)))
+(define (check-tree n)
+  (let ((tot-len (* n 10)))
+    (let loop ((i 0))
+      (when (< i n)
+        (let* ((x (* i 5))
+               (y (- tot-len x 5)))
+          (send t search! x)
+          (check-root 5 (list (add1 i) 1) x (+ 5 x))
+          (send t search! y)
+          (check-root 5 (list (add1 i) 2) y (+ 5 y)))
+        (loop (add1 i))))))
+      
+
+(build-tree 4 #t)
+(SECTION 'check-tree)
+(check-tree 4)
+(send t search-min!)
+(check-root 5 '(1 1) 0 5)
+(send t search-max!)
+(check-root 5 '(1 2) 35 40)
+
+(SECTION 'remove-root)
+(send t search! 20)
+(send t remove-root!)
+(send t search-max!)
+(check-root 5 '(1 2) 30 35)
+
+(SECTION 'add-to-root-length)
+(send t search-min!)
+(send t add-to-root-length 1)
+(check-root 6 '(1 1) 0 6)
+(send t search! 15)
+(check-root 5 '(3 1) 11 16)
+(send t search-max!)
+(check-root 5 '(1 2) 31 36)
+
+(SECTION 'for-each)
+(send t reset-tree)
+(build-tree 4 #f)
+(let loop ((i 0))
+  (when (< i 1000)
+    (send t search! (random 20))
+    (loop (add1 i))))
+(define (to-list t)
+  (let ((x null))
+    (send t for-each (lambda (start len data) (set! x (cons (list start len data) x))))
+    (reverse x)))
+(test '((0 1 (1 1))
+        (1 2 (2 1))
+        (3 3 (3 1))
+        (6 4 (4 1))
+        (10 4 (4 2))
+        (14 3 (3 2))
+        (17 2 (2 2))
+        (19 1 (1 2)))
+      'for-each  (to-list t))
+
+(SECTION 'stress)
+(send t reset-tree)
+(build-tree 100 #f)
+(let loop ((i 0))
+  (when (< i 10000)
+    (send t search! (random 10100))
+    (loop (add1 i))))
+(send t search-max!)
+(check-root 1 '(1 2) 10099 10100)
+
+(SECTION 'splits)
+(send t reset-tree)
+(build-tree 5 #f)
+(let-values (((s e t1 t2)
+              (send t split 16)))
+  (test 15 'split s)
+  (test 20 'split e)
+  (test '((0 1 (1 1))
+          (1 2 (2 1))
+          (3 3 (3 1))
+          (6 4 (4 1))
+          (10 5 (5 1)))
+        'split (to-list t1))
+  (test '((0 4 (4 2))
+          (4 3 (3 2))
+          (7 2 (2 2))
+          (9 1 (1 2)))
+        'split (to-list t2)))
+(build-tree 5 #f)
+(let-values (((s e t1 t2)
+              (send t split 15)))
+  (test 10 'split s)
+  (test 20 'split e)
+  (test '((0 1 (1 1))
+          (1 2 (2 1))
+          (3 3 (3 1))
+          (6 4 (4 1)))
+        'split (to-list t1))
+  (test '((0 4 (4 2))
+          (4 3 (3 2))
+          (7 2 (2 2))
+          (9 1 (1 2)))
+        'split (to-list t2)))
+(send t reset-tree)
+(build-tree 5 #f)
+(send t search! 15)
+(let-values (((t1 t2) (send t split-after)))
+  (test '((0 1 (1 1))
+          (1 2 (2 1))
+          (3 3 (3 1))
+          (6 4 (4 1))
+          (10 5 (5 1))
+          (15 5 (5 2)))
+        'split-after (to-list t1))
+  (test '((0 4 (4 2))
+          (4 3 (3 2))
+          (7 2 (2 2))
+          (9 1 (1 2)))
+        'split-after (to-list t2)))
+(send t reset-tree)
+(build-tree 5 #f)
+(send t search! 15)
+(let-values (((t1 t2) (send t split-before)))
+  (test '((0 1 (1 1))
+          (1 2 (2 1))
+          (3 3 (3 1))
+          (6 4 (4 1))
+          (10 5 (5 1)))
+        'split-before (to-list t1))
+  (test '((0 5 (5 2))
+          (5 4 (4 2))
+          (9 3 (3 2))
+          (12 2 (2 2))
+          (14 1 (1 2)))
+        'split-before (to-list t2)))
+
+(send t reset-tree)
+(insert-last! t (new token-tree% (length 1) (data 1)))
+(insert-last! t (new token-tree% (length 1) (data 2)))
+(insert-last! t (new token-tree% (length 1) (data 3)))
+(test '((0 1 1) (1 1 2) (2 1 3)) 'insert-last (to-list t))
+(let-values (((s e t1 t2) (send t split 2)))
+  (test 1 'split s)
+  (test 3 'split e)
+  (test '((0 1 1)) 'split (to-list t1))
+  (test '() 'split (to-list t2)))
+
+(report-errs)
diff --git a/collects/tests/utils/gui.ss b/collects/tests/utils/gui.ss
new file mode 100644
index 0000000000..e78883f646
--- /dev/null
+++ b/collects/tests/utils/gui.ss
@@ -0,0 +1,118 @@
+(module gui mzscheme
+  (require (lib "mred.ss" "mred")
+           (lib "class.ss")
+           (lib "etc.ss"))
+  (provide find-labelled-window whitespace-string=?)
+  
+  ;; whitespace-string=? : string string -> boolean
+  ;; determines if two strings are equal, up to their whitespace.
+  ;; each string is required to have whitespace in the same place,
+  ;; but not necessarily the same kinds or amount.
+  (define (whitespace-string=? string1 string2)
+    (let loop ([i 0]
+               [j 0]
+               [in-whitespace? #t])
+      (cond
+        [(= i (string-length string1)) (only-whitespace? string2 j)]
+        [(= j (string-length string2)) (only-whitespace? string1 i)]
+        [else (let ([c1 (string-ref string1 i)]
+                    [c2 (string-ref string2 j)])
+                (cond
+                  [in-whitespace?
+                   (cond
+                     [(whitespace? c1)
+                      (loop (+ i 1)
+                            j
+                            #t)]
+                     [(whitespace? c2)
+                      (loop i
+                            (+ j 1)
+                            #t)]
+                     [else (loop i j #f)])]
+                  [(and (whitespace? c1)
+                        (whitespace? c2))
+                   (loop (+ i 1)
+                         (+ j 1)
+                         #t)]
+                  [(char=? c1 c2)
+                   (loop (+ i 1)
+                         (+ j 1)
+                         #f)]
+                  [else #f]))])))
+  
+  ;; whitespace? : char -> boolean
+  ;; deteremines if `c' is whitespace
+  (define (whitespace? c)
+    (or (char=? c #\newline)
+        (char=? c #\space)
+        (char=? c #\tab)
+        (char=? c #\return)))
+  
+  ;; only-whitespace? : string number -> boolean
+  ;; returns true if string only contains whitespace, from index `i' onwards
+  (define (only-whitespace? str i)
+    (let loop ([n i])
+      (cond
+        [(= n (string-length str))
+         #t]
+        [(whitespace? (string-ref str n))
+         (loop (+ n 1))]
+        [else #f])))
+  
+  ;; whitespace-string=? tests
+  '(map (lambda (x) (apply equal? x))
+        (list (list #t (whitespace-string=? "a" "a"))
+              (list #f (whitespace-string=? "a" "A"))
+              (list #f (whitespace-string=? "a" " "))
+              (list #f (whitespace-string=? " " "A"))
+              (list #t (whitespace-string=? " " " "))
+              (list #t (whitespace-string=? " " "  "))
+              (list #t (whitespace-string=? "  " "  "))
+              (list #t (whitespace-string=? "  " " "))
+              (list #t (whitespace-string=? "a a" "a a"))
+              (list #t (whitespace-string=? "a a" "a  a"))
+              (list #t (whitespace-string=? "a  a" "a a"))
+              (list #t (whitespace-string=? " a" "a"))
+              (list #t (whitespace-string=? "a" " a"))
+              (list #t (whitespace-string=? "a " "a"))
+              (list #t (whitespace-string=? "a" "a "))))
+
+  ;;; find-labelled-window : (union ((union #f string) -> window<%>)
+  ;;;                               ((union #f string) (union #f class) -> window<%>)
+  ;;;                               ((union #f string) (union class #f) area-container<%> -> window<%>))
+  ;;;;  may call error, if no control with the label is found
+  (define find-labelled-window
+    (opt-lambda (label 
+                 [class #f] 
+                 [window (get-top-level-focus-window)] 
+                 [failure (lambda ()
+                            (error 'find-labelled-window "no window labelled ~e in ~e~a"
+                                   label
+                                   window 
+                                   (if class
+                                       (format " matching class ~e" class)
+                                       "")))])
+      (unless (or (not label)
+                  (string? label))
+	(error 'find-labelled-window "first argument must be a string or #f, got ~e; other args: ~e ~e"
+	       label class window))
+      (unless (or (class? class)
+		  (not class))
+	(error 'find-labelled-window "second argument must be a class or #f, got ~e; other args: ~e ~e"
+	       class label window))
+      (unless (is-a? window area-container<%>)
+	(error 'find-labelled-window "third argument must be a area-container<%>, got ~e; other args: ~e ~e"
+	       window label class))
+      (let ([ans
+	     (let loop ([window window])
+	       (cond
+                 [(and (or (not class)
+                           (is-a? window class))
+                       (let ([win-label (and (is-a? window window<%>)
+                                             (send window get-label))])
+                         (equal? label win-label)))
+                  window]
+                 [(is-a? window area-container<%>) (ormap loop (send window get-children))]
+                 [else #f]))])
+	(or ans
+	    (failure))))))
\ No newline at end of file
diff --git a/collects/tests/utils/info.ss b/collects/tests/utils/info.ss
new file mode 100644
index 0000000000..c4fd4dbe61
--- /dev/null
+++ b/collects/tests/utils/info.ss
@@ -0,0 +1,2 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Testing Utilities"))
diff --git a/collects/tests/utils/mz-testing.ss b/collects/tests/utils/mz-testing.ss
new file mode 100644
index 0000000000..45bba873e6
--- /dev/null
+++ b/collects/tests/utils/mz-testing.ss
@@ -0,0 +1,305 @@
+(module mz-testing mzscheme
+
+;;; `test.scm' Test correctness of MzScheme implementations.
+;;; Copyright (C) 1991, 1992, 1993, 1994 Aubrey Jaffer.
+;;; Modified for MzScheme by Matthew
+
+;;; MODIFIED for MzScheme - Matthew 8/95
+;;;  Added a few more tests, like append!, reverse!, etc.
+;;;  Added testing for inexact numbers
+;;;  Added a lot of error testing
+;;; modified for rational and complex numbers - Matthew 12/95
+;;; modified to test exceptions and more of MzScheme - Matthew 4/96
+;;; split into multiple files - Matthew 4/96
+;;; extended, extended, extended
+;;; turned into a module - John Clements, 5/03
+  
+;;; This includes examples from
+;;; William Clinger and Jonathan Rees, editors.
+;;; Revised^4 Report on the Algorithmic Language Scheme
+;;; and the IEEE specification.
+
+  (provide building-flat-tests?
+           in-drscheme?
+           SECTION
+           test
+           err/rt-test
+           arity-test
+           report-errs
+
+	   ;; Backward compatibility:
+	   exn:application:mismatch?
+	   exn:application:type?
+	   exn:application:arity?)
+  
+  ; The format of the next line is important: file.ss relies on it
+  ; JBC : not in this version...
+  (define cur-section '())(define errs '())
+  
+  (define teval eval)
+  
+  ; JBC : changed instances of namespace-variable-value into plain old module var refs & defs.
+  ; I freely admit I don't see why the file didn't just use set!, unless it was out of concern
+  ; for capture when this code was embedded...?
+  ; Also, I now see that the old code admitted the possibility of set!'s to these variables
+  ; from outside of this code.  This will no longer be possible.  I'll make them parameters, then.
+  
+  (define building-flat-tests?
+    (make-parameter #f))
+  
+  (define in-drscheme?
+    (make-parameter #f))
+
+  (define SECTION (lambda args
+                    (let ([ep (current-error-port)])
+                      (display "SECTION" ep) (write args ep) (newline ep)
+                      (set! cur-section args) #t)))
+  
+  (define record-error (lambda (e) (set! errs (cons (list cur-section e) errs))))
+
+  (print-struct #t)
+
+  (define number-of-tests 0)
+  (define number-of-error-tests 0)
+  (define number-of-exn-tests 0)
+
+  (define test
+    (lambda (expect fun . args)
+      (set! number-of-tests (add1 number-of-tests))
+      (write (cons fun args))
+      (display "  ==> ")
+      (flush-output)
+      ((lambda (res)
+         (write res)
+         (newline)
+         (cond ((not (equal? expect res))
+                (record-error (list res expect (cons fun args)))
+                (display " BUT EXPECTED ")
+                (write expect)
+                (newline)
+                #f)
+               (else #t)))
+       (if (procedure? fun) (apply fun args) (car args)))))
+
+  
+  (define (nonneg-exact? x)
+    (and (exact? x)
+         (integer? x)
+         (x . >= . 0)))
+  
+  (define (pos-exact? x)
+    (and (exact? x)
+         (integer? x)
+         (positive? x)))
+
+  (define exn-table
+    (list (cons exn? (cons exn-message string?))
+	  (cons exn? (cons exn-continuation-marks continuation-mark-set?))
+	  (cons exn:fail:contract:variable? (cons exn:fail:contract:variable-id symbol?))
+	  (cons exn:fail:syntax? (cons exn:fail:syntax-exprs (lambda (x) (and (list? x) (andmap syntax? x)))))
+	  
+	  (cons exn:fail:read? (cons exn:fail:read-srclocs (lambda (x) (and (list? x) (andmap srcloc? x)))))))
+
+  (define exn:application:mismatch? exn:fail:contract?)
+  (define exn:application:type? exn:fail:contract?)
+  (define exn:application:arity? exn:fail:contract:arity?)
+
+  (define mz-test-syntax-errors-allowed? #t)
+
+  (define thunk-error-test
+    (case-lambda 
+      [(th expr) (thunk-error-test th expr exn:application:type?)]
+      [(th expr exn?)
+       (set! expr (syntax-object->datum expr))
+       (set! number-of-error-tests (add1 number-of-error-tests))
+       (write expr)
+       (display "  =e=> ")
+       (call/ec (lambda (escape)
+                  (let* ([old-esc-handler (error-escape-handler)]
+                         [old-handler (current-exception-handler)]
+                         [orig-err-port (current-error-port)]
+                         [test-handler
+                          (lambda ()
+                            (escape #t))]
+                         [test-exn-handler
+                          (lambda (e)
+                            (when (and exn? (not (exn? e)))
+                              (printf " WRONG EXN TYPE: ~s " e)
+                              (record-error (list e 'exn-type expr)))
+                            (when (and (exn:fail:syntax? e)
+                                       (not mz-test-syntax-errors-allowed?))
+                              (printf " LATE SYNTAX EXN: ~s " e)
+                              (record-error (list e 'exn-late expr)))
+                            
+                            (for-each
+                             (lambda (row)
+                               (let ([pred? (car row)])
+                                 (when (pred? e)
+                                   (set! number-of-exn-tests 
+                                         (add1 number-of-exn-tests))
+                                   (let ([sel (cadr row)]
+                                         [pred? (cddr row)])
+                                     (unless (pred? (sel e))
+                                       (printf " WRONG EXN ELEM ~s: ~s " sel e)
+                                       (record-error (list e (cons 'exn-elem sel) expr)))))))
+                             exn-table)
+                            
+                            (old-handler e))])
+                    (dynamic-wind
+                     (lambda () 
+                       (current-error-port (current-output-port))
+                       (current-exception-handler test-exn-handler)
+                       (error-escape-handler test-handler))
+                     (lambda ()
+                       (let ([v (th)])
+                         (write v)
+                         (display " BUT EXPECTED ERROR")
+                         (record-error (list v 'Error expr))
+                         (newline)
+                         #f))
+                     (lambda () 
+                       (current-error-port orig-err-port)
+                       (current-exception-handler old-handler)
+                       (error-escape-handler old-esc-handler))))))]))
+
+  (define error-test
+    (make-parameter
+     (case-lambda 
+       [(expr) (error-test expr exn:application:type?)]
+       [(expr exn?)
+        (thunk-error-test (lambda () (eval expr)) expr exn?)])))
+  
+  ; JBC : I'm not going to worry about this for the time being :
+  ; (require (rename mzscheme err:mz:lambda lambda)) ; so err/rt-test works with beginner.ss
+
+  (define-syntax err/rt-test
+    (lambda (stx)
+      (syntax-case stx ()
+        [(_ e exn?)
+         (syntax
+          (thunk-error-test (lambda () e) (quote-syntax e) exn?))]
+        [(_ e)
+         (syntax
+          (err/rt-test e exn:application:type?))])))
+  
+  (define no-extra-if-tests? #f)
+
+  (define (syntax-test expr)
+    (error-test expr exn:fail:syntax?)
+    (unless no-extra-if-tests?
+      (error-test (datum->syntax-object expr `(if #f ,expr) expr) exn:fail:syntax?)))
+
+  (define arity-test 
+    (case-lambda
+      [(f min max except)
+       (letrec ([aok?
+                 (lambda (a)
+                   (cond
+                     [(integer? a) (= a min max)]
+                     [(arity-at-least? a) (and (negative? max)
+                                               (= (arity-at-least-value a) min))]
+                     [(and (list? a) (andmap integer? a))
+                      (and (= min (car a)) (= max
+                                              (let loop ([l a])
+                                                (if (null? (cdr l))
+                                                    (car l)
+                                                    (loop (cdr l))))))]
+                     [(list? a)
+                      ;; Just check that all are consistent for now.
+                      ;; This should be improved.
+                      (andmap
+                       (lambda (a)
+                         (if (number? a)
+                             (<= min a (if (negative? max) a max))
+                             (>= (arity-at-least-value a) min)))
+                       a)]
+                     [else #f]))]
+                [make-ok?
+                 (lambda (v)
+                   (lambda (e)
+		     (exn:application:arity? e)))]
+                [do-test
+                 (lambda (f args check?)
+                   (set! number-of-error-tests (add1 number-of-error-tests))
+                   (printf "(apply ~s '~s)  =e=> " f args)
+                   (let/ec done
+                     (let ([v (with-handlers ([void
+                                               (lambda (exn)
+                                                 (if (check? exn)
+                                                     (printf " ~a~n" (exn-message exn))
+                                                     (let ([ok-type? (exn:application:arity? exn)])
+                                                       (printf " WRONG EXN ~a: ~s~n" 
+                                                               (if ok-type?
+                                                                   "FIELD"
+                                                                   "TYPE")
+                                                               exn)
+                                                       (record-error (list exn 
+                                                                           (if ok-type?
+                                                                               'exn-field
+                                                                               'exn-type)
+                                                                           (cons f args)))))
+                                                 (done (void)))])
+                                (apply f args))])
+                       (printf "~s~n BUT EXPECTED ERROR~n" v)
+                       (record-error (list v 'Error (cons f args))))))])
+         (let loop ([n 0][l '()])
+           (unless (>= n min)
+             (unless (memq n except)
+               (do-test f l (make-ok? n)))
+             (loop (add1 n) (cons 1 l))))
+         (let loop ([n min])
+           (unless (memq n except)
+             (test #t procedure-arity-includes? f n))
+           (unless (>= n max)
+             (loop (add1 n))))
+         (if (>= max 0)
+             (do-test f (let loop ([n 0][l '(1)])
+                          (if (= n max)
+                              l
+                              (loop (add1 n) (cons 1 l))))
+                      (make-ok? (add1 max)))
+             (test #t procedure-arity-includes? f (arithmetic-shift 1 100))))]
+      [(f min max) (arity-test f min max null)]))
+
+  (define (test-values l thunk)
+    (test l call-with-values thunk list))
+
+  (define (report-errs)
+    (printf "~nPerformed ~a expression tests (~a good expressions, ~a bad expressions)~n"
+            (+ number-of-tests number-of-error-tests)
+            number-of-tests 
+            number-of-error-tests)
+    (printf "and ~a exception field tests.~n~n" 
+            number-of-exn-tests)
+    (if (null? errs) 
+        (display "Passed all tests.")
+        (begin
+          (display "Errors were:")
+          (newline)
+          (display "(SECTION (got expected (call)))")
+          (newline)
+          (for-each (lambda (l) (write l) (newline))
+                    errs)))
+    (newline)
+    (display "(Other messages report successful tests of error-handling behavior.)")
+    (newline))
+
+  (define type? exn:application:type?)
+  (define arity? exn:application:arity?)
+  (define syntaxe? exn:fail:syntax?)
+  
+  (define non-z void)
+
+  (define (find-depth go)
+    ; Find depth that triggers a stack overflow (assuming no other
+    ; threads are running and overflowing)
+    (let ([v0 (make-vector 6)]
+          [v1 (make-vector 6)])
+      (let find-loop ([d 100])
+        (vector-set-performance-stats! v0)
+        (go d)
+        (vector-set-performance-stats! v1)
+        (if (> (vector-ref v1 5)
+               (vector-ref v0 5))
+            d
+            (find-loop (* 2 d)))))))
diff --git a/collects/tests/utils/sexp-diff.ss b/collects/tests/utils/sexp-diff.ss
new file mode 100644
index 0000000000..bc340e07f5
--- /dev/null
+++ b/collects/tests/utils/sexp-diff.ss
@@ -0,0 +1,101 @@
+(module sexp-diff mzscheme
+  (require (lib "mz-testing.ss" "tests" "utils"))
+
+  (define-syntax (test-begin stx)
+    (syntax-case stx ()
+      [(_ expr ...)
+       ;#'(begin expr ...) ; testing version
+       #'(void) ; non-testing version
+       ]))
+  
+  (test-begin (section 'sexp-diff))
+
+  ; sexp-diff and sexp-diff/expound show the difference between two specified s-expressions.
+  ; in each case, the part of the s-expression that is the same is preserved in the result. When
+  ; traversal reveals a difference, the point that is different is replaced with either the symbol
+  ; different!-g##### (in the sexp-diff function) or a list of the form (different!-g#### <thing-from-a> <thing-from-b>)
+  ; in the sexp-diff/expound function.
+  
+  (provide sexp-diff sexp-diff/expound)
+  
+  (define (sexp-diff/core expound? collect?)    
+    (letrec ([construct-diff-result (if expound? 
+                                        (lambda (a b) (list diff-id a b))
+                                        (lambda (a b) diff-id))]
+             [diff-result-test (if expound? 
+                                   (lambda (a) (and (pair? a) (eq? (car a) diff-id)))
+                                   (lambda (a) (eq? a diff-id)))]
+             [combine-diff-results (if expound? 
+                                       (lambda (a b) 
+                                         (if (diff-result-test a)
+                                             (list diff-id (cons (cadr a) (cadr b)) (cons (caddr a) (caddr b)))
+                                             (let-values ([(a-side b-side) (separate-sides a)])
+                                               (list diff-id (cons a-side (cadr b)) (cons b-side (caddr b))))))
+                                       (lambda (a b) diff-id))]
+             ; if a previously diff'-ed result is re-separated (because it occurs in a list which is being recombined),
+             ; the diff'ed result should be split again.
+             [separate-sides 
+              (lambda (a)
+                (cond [(diff-result-test a)
+                       (values (cadr a) (caddr a))]
+                      ; otherwise, recur structurally
+                      [(pair? a)
+                       (let-values ([(car-a car-b) (separate-sides (car a))]
+                                    [(cdr-a cdr-b) (separate-sides (cdr a))])
+                         (values (cons car-a cdr-a)
+                                 (cons car-b cdr-b)))]
+                      [else
+                       (values a a)]))]
+             [sexp-diff 
+              (lambda (a b)
+                (cond [(and (null? a) (null? b)) 
+                       null]
+                      [(and (pair? a) (pair? b))
+                       (let ([car-result (sexp-diff (car a) (car b))]
+                             [cdr-result (sexp-diff (cdr a) (cdr b))])
+                         (if collect?
+                             (cond [(diff-result-test cdr-result)
+                                    (combine-diff-results car-result cdr-result)]
+                                   [else (cons car-result cdr-result)])
+                             (cons car-result cdr-result)))]
+                      [(equal? a b) a]
+                      [else (construct-diff-result a b)]))])
+      sexp-diff))
+  
+  (define sexp-diff (sexp-diff/core #f #f))
+  (define sexp-diff/expound (sexp-diff/core #t #f))
+  
+  (define diff-id (gensym "different!-"))
+  
+  ; list-diff does a diff at a list level, rather than at a pair list.  The difference may be 
+  ; observed in the result of applying sexp-diff/expound and list-diff/expound to `(3 4 5) and `(5 6).
+  ; the prior gives `((different! 3 5) (different! 4 6) . (different! (5) ()), whereas the latter
+  ; gives `(different! (3 4 5) (5 6)).  The difference from an implementation standpoint is that if the
+  ; cdr's of two pair elements is different, the results are recombined to make the whole pair labeled
+  ; different.
+  
+  (provide list-diff list-diff/expound)
+  
+  (define list-diff (sexp-diff/core #f #t))
+  (define list-diff/expound (sexp-diff/core #t #t))
+  
+  (test-begin
+   (test null sexp-diff null null)
+   (define a `(1 2 (3 4 (5 6) (6 7) () 8) 9))
+   (test a sexp-diff a a)
+   (define b `(1 0 (3 0 (5 7) 0 0 8 3 4) 9))
+   (test `(1 ,diff-id (3 ,diff-id (5 ,diff-id) ,diff-id ,diff-id 8 . ,diff-id) 9) sexp-diff a b)
+   
+   (test null sexp-diff/expound null null)
+   (test a sexp-diff/expound a a)
+   (test `(1 (,diff-id 2 0) (3 (,diff-id 4 0) (5 (,diff-id 6 7)) (,diff-id (6 7) 0) (,diff-id () 0) 8 . (,diff-id () (3 4))) 9) sexp-diff/expound a b)
+   
+   (test null list-diff null null)
+   (test null list-diff/expound null null)
+   (test a list-diff a a)
+   (test a list-diff/expound a a)
+   (test `(1 ,diff-id ,diff-id 9) list-diff a b)
+   (test `(1 (,diff-id 2 0) (,diff-id (3 4 (5 6) (6 7) () 8) (3 0 (5 7) 0 0 8 3 4)) 9) list-diff/expound a b)
+   
+   (report-errs)))
+
diff --git a/collects/tests/web-server/answers/a-module b/collects/tests/web-server/answers/a-module
new file mode 100644
index 0000000000..446cbce8a3
--- /dev/null
+++ b/collects/tests/web-server/answers/a-module
@@ -0,0 +1 @@
+<html><head><title>A Test Page</title></head><body bgcolor="white"><p>A simple module servlet works.</p></body></html>
diff --git a/collects/tests/web-server/answers/b-module b/collects/tests/web-server/answers/b-module
new file mode 100644
index 0000000000..c28433c307
--- /dev/null
+++ b/collects/tests/web-server/answers/b-module
@@ -0,0 +1 @@
+<html><head><title>A Test Page</title></head><body bgcolor="white"><p>Here are the initial bindings: ((texan . "big-hat"))</p></body></html>
diff --git a/collects/tests/web-server/answers/bad-require b/collects/tests/web-server/answers/bad-require
new file mode 100644
index 0000000000..e73ba70cf7
--- /dev/null
+++ b/collects/tests/web-server/answers/bad-require
@@ -0,0 +1,2 @@
+Servlet didn't load.
+open-input-file: cannot open input file: "/home/ptg/plt/collects/web-server/default-web-root/servlets/tests/not-there-on-purpose.ss" (No such file or directory; errno=2)
\ No newline at end of file
diff --git a/collects/tests/web-server/answers/incremental b/collects/tests/web-server/answers/incremental
new file mode 100644
index 0000000000..10fba28544
--- /dev/null
+++ b/collects/tests/web-server/answers/incremental
@@ -0,0 +1,3 @@
+<html><head><title>my-title</title></head>
+<body><p>The first paragraph</p>
+<p>The second paragraph</p></body></html>
diff --git a/collects/tests/web-server/answers/incremental2 b/collects/tests/web-server/answers/incremental2
new file mode 100644
index 0000000000..aaad80c3a7
--- /dev/null
+++ b/collects/tests/web-server/answers/incremental2
@@ -0,0 +1,11 @@
+2b
+<html><head><title>my-title</title></head>
+
+21
+<body><p>The first paragraph</p>
+
+2a
+<p>The second paragraph</p></body></html>
+
+0
+
diff --git a/collects/tests/web-server/answers/mime-servlet b/collects/tests/web-server/answers/mime-servlet
new file mode 100644
index 0000000000..7064dc67c6
--- /dev/null
+++ b/collects/tests/web-server/answers/mime-servlet
@@ -0,0 +1 @@
+uber uber uber-de-doo
\ No newline at end of file
diff --git a/collects/tests/web-server/answers/non-unit b/collects/tests/web-server/answers/non-unit
new file mode 100644
index 0000000000..faab9dc58a
--- /dev/null
+++ b/collects/tests/web-server/answers/non-unit
@@ -0,0 +1,2 @@
+Servlet didn't load.
+"Loading \"/home/ptg/plt/collects/web-server/default-web-root/./servlets/tests/non-unit.ss\" produced \n5\n instead of a servlet."
diff --git a/collects/tests/web-server/answers/suspended-module b/collects/tests/web-server/answers/suspended-module
new file mode 100644
index 0000000000..4a46f74914
--- /dev/null
+++ b/collects/tests/web-server/answers/suspended-module
@@ -0,0 +1 @@
+<html><head><meta http-equiv="Pragma" content="no-cache" /><meta http-equiv="expires" content="-1" /><title>What is your name?</title></head><body bgcolor="white"><form action="/servlets/tests/suspended-module.ss;id15*k1-590544085" method="post">What is your name?<input type="text" name="name" /></form></body></html>
diff --git a/collects/tests/web-server/answers/test.servlet-1 b/collects/tests/web-server/answers/test.servlet-1
new file mode 100644
index 0000000000..3621cdcb75
--- /dev/null
+++ b/collects/tests/web-server/answers/test.servlet-1
@@ -0,0 +1,5 @@
+<html><head><title>Testing 1...2...3</title></head><body><p>This is a generated web page.</p><p>Here are the bindings:
+()
+<br />Count = 1<br />Here are the headers:
+((host . #"127.0.0.1"))
+</p></body></html>
diff --git a/collects/tests/web-server/answers/test.servlet-2 b/collects/tests/web-server/answers/test.servlet-2
new file mode 100644
index 0000000000..e9ea2d5b98
--- /dev/null
+++ b/collects/tests/web-server/answers/test.servlet-2
@@ -0,0 +1,5 @@
+<html><head><title>Testing 1...2...3</title></head><body><p>This is a generated web page.</p><p>Here are the bindings:
+((a . "b") (see . "def"))
+<br />Count = 2<br />Here are the headers:
+((host . #"127.0.0.1"))
+</p></body></html>
diff --git a/collects/tests/web-server/build-plt.ss b/collects/tests/web-server/build-plt.ss
new file mode 100644
index 0000000000..d0589acc71
--- /dev/null
+++ b/collects/tests/web-server/build-plt.ss
@@ -0,0 +1,25 @@
+(module build-plt mzscheme
+  (require (lib "pack.ss" "setup")
+           (lib "date.ss")
+           "suite.ss")
+  
+  (define web-root (build-path "collects" "web-server" "default-web-root"))
+  
+  (define exclude
+    (list (build-path web-root "servlets" "tests")
+          (build-path web-root "htdocs" "secret")
+          (build-path web-root "passwords")
+          (build-path web-root "log")))
+  
+  (let ([why-broken (broken? 8180)])
+    (when why-broken
+      (error 'build-plt "The web server is broken~n~a" why-broken)))
+  
+  (current-directory (build-path (collection-path "web-server") 'up 'up))
+  (pack "/home/ptg/.www/packages/web-server.plt"
+        (format "Web Server: ~a" (date->string (seconds->date (current-seconds))))
+        (list (build-path "collects" "web-server"))
+        '(("web-server"))
+        (lambda (p)
+          (and (not (member p exclude))
+               (std-filter p)))))
diff --git a/collects/tests/web-server/configuration-table b/collects/tests/web-server/configuration-table
new file mode 100644
index 0000000000..995e799bd0
--- /dev/null
+++ b/collects/tests/web-server/configuration-table
@@ -0,0 +1,28 @@
+((port 80)
+ (max-waiting 40)
+ (initial-connection-timeout 30)
+ (default-host-table
+   (host-table
+     (default-indices "index.html" "index.htm")
+     (log-format parenthesized-default)
+     (messages
+       (servlet-message "servlet-error.html")
+       (authentication-message "forbidden.html")
+       (servlets-refreshed "servlet-refresh.html")
+       (passwords-refreshed "passwords-refresh.html")
+       (file-not-found-message "not-found.html")
+       (protocol-message "protocol-error.html"))
+     (timeouts
+       (default-servlet-timeout 120)
+       (password-connection-timeout 300)
+       (servlet-connection-timeout 86400)
+       (file-per-byte-connection-timeout 1/20)
+       (file-base-connection-timeout 30))
+     (paths
+      (configuration-root "conf")
+      (host-root "web-root")
+      (log-file-path "log")
+      (file-root "htdocs")
+      (servlet-root ".")
+      (password-authentication "passwords"))))
+ (virtual-host-table))
diff --git a/collects/tests/web-server/my-url.ss b/collects/tests/web-server/my-url.ss
new file mode 100644
index 0000000000..7b9f0c5511
--- /dev/null
+++ b/collects/tests/web-server/my-url.ss
@@ -0,0 +1,32 @@
+(module my-url mzscheme
+  (require (all-except (lib "url.ss" "net") purify-port))
+  (provide purify-port
+           (struct mime-header (name value)))
+  ;(provide (all-from-except url purify-port))
+  ;(provide (all-from-except (lib "url.ss" "net") purify-port))
+  ; the -except is not needed, since purify-port was not imported.
+  (provide (all-from (lib "url.ss" "net")))
+
+  ; mime-header = (make-mime-header str str)
+  (define-struct mime-header (name value))
+
+  (define COLON:REGEXP (regexp (format "^([^:]*):[ ~a]*(.*)" #\tab)))
+
+  ; match-colon : str -> (list str str str)
+  (define (match-colon s) (regexp-match COLON:REGEXP s))
+
+  ; purify-port : iport -> (listof mime-header)
+  ; Note: this function is silently robust.  It ignores invalid input
+  (define (purify-port in)
+    (read-line in) ; skip HTTP/x.y NNN mumble
+    (let read-headers ()
+      (let ([line (read-line in 'any)])
+        (cond
+	  [(eof-object? line) null]
+	  [(zero? (string-length line)) null]
+	  [(match-colon line) =>
+	   (lambda (x)
+	     (cons (make-mime-header (cadr x) (caddr x))
+		   (read-headers)))]
+	  [else ; error - bad header
+	   (read-headers)])))))
diff --git a/collects/tests/web-server/perf-tests.ss b/collects/tests/web-server/perf-tests.ss
new file mode 100644
index 0000000000..2e362f3046
--- /dev/null
+++ b/collects/tests/web-server/perf-tests.ss
@@ -0,0 +1,11 @@
+(require-library "suite.ss" "server" "test")
+(require-library "web-hammer.ss" "server" "test")
+
+; more here - search for a port that works
+(define port 8080)
+(broken? port)
+; calling broken? also starts a server in another underlying OS process on the same machine
+
+(define run1
+  (server-performance (string->url (format "http://127.0.0.1:~a/" port))
+                      16 0 120))
diff --git a/collects/tests/web-server/scheme-units/assertions.ss b/collects/tests/web-server/scheme-units/assertions.ss
new file mode 100644
index 0000000000..863dbb74b0
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/assertions.ss
@@ -0,0 +1,93 @@
+;; Mike Burns, July 8th, 2004, netgeek@speakeasy.net
+;; Useful assertions
+(module assertions mzscheme
+  (require (lib "test.ss" "schemeunit")
+           (lib "web-server.ss" "web-server")
+           (lib "configuration.ss" "web-server")
+           (lib "url.ss" "net")
+           (lib "head.ss" "net")
+           (lib "contract.ss"))
+
+  (provide assert-serve assert-serve/string assert-status-number assert-with-server)
+  (provide/contract
+    (start-server (-> (-> any)))
+    (full-url (string? . -> . url?))
+    (web-root path?)
+    (input-port-equal? (input-port? input-port? . -> . boolean?))
+    (THE-PORT number?)
+    (THE-IP string?))
+
+  (define THE-PORT 8135)
+
+  (define THE-IP "127.0.0.1")
+
+  (define web-root (build-path (collection-path "tests")
+                               "web-server"
+                               "scheme-units"
+                               "test-web-root"))
+
+  (define-simple-assertion (assert-serve url-path file-path content-type)
+    (assert-with-server
+      url-path
+      (lambda (http-port)
+        (and (content-type-equal? (purify-port http-port) content-type)
+             (call-with-input-file
+               file-path
+               (lambda (f-port)
+                 (input-port-equal? http-port f-port)))))))
+
+  (define-simple-assertion (assert-serve/string url-path str content-type)
+    (assert-with-server
+      url-path
+      (lambda (http-port)
+        (and (content-type-equal? (purify-port http-port) content-type)
+             (let ((is (open-input-string str)))
+               (input-port-equal? http-port is))))))
+
+  (define-simple-assertion (assert-status-number url-path status-number)
+    (assert-with-server
+      url-path
+      (lambda (http-port)
+        (regexp-match
+          (format "^HTTP/... ~a" status-number)
+          (read-line http-port)))))
+
+  (define-simple-assertion (assert-with-server url-path assertion)
+    ;; Ordering matters, so use let*
+    (let* ((stop-server (start-server))
+           (http-port (get-impure-port (full-url url-path))))
+      (begin0
+        (assertion http-port)
+        (stop-server))))
+
+  ;; Format a URL
+  (define (full-url url-path)
+    (string->url (format "http://~a:~a~a" THE-IP THE-PORT url-path)))
+
+  ;; Start the Web server
+  (define (start-server)
+      (serve (load-configuration (expand-path "configuration-table")) THE-PORT THE-IP))
+
+  ;; It is a HTML MIME header if the Content-type header exists as a string,
+  ;; and is "text/plain". In practice, it can be anything matching the regexp
+  ;; "^text/plain;*.*", but not in the PLT Web server.
+  (define/contract content-type-equal?
+    (string? string? . -> . boolean?)
+    (lambda (header content-type)
+      (let ((header-content-type (extract-field "Content-type" header)))
+        (and header-content-type
+             (string? header-content-type)
+             (string=? header-content-type content-type)))))
+
+  ;; Two input ports are equal if each line read from them are equal, and they
+  ;; are the same size.
+  (define (input-port-equal? a b)
+    (let ((a-line (read-line a))
+          (b-line (read-line b)))
+      (cond
+        ((eof-object? a-line) (eof-object? b-line))
+        ((eof-object? b-line) (eof-object? a-line))
+        ((equal? a-line b-line) (input-port-equal? a b))
+        (else #f))))
+
+  )
diff --git a/collects/tests/web-server/scheme-units/configuration-table b/collects/tests/web-server/scheme-units/configuration-table
new file mode 100644
index 0000000000..d0b3cc9816
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/configuration-table
@@ -0,0 +1,28 @@
+((port 8135)
+ (max-waiting 40)
+ (initial-connection-timeout 30)
+ (default-host-table
+   (host-table
+     (default-indices "index.html" "index.htm")
+     (log-format parenthesized-default)
+     (messages
+       (servlet-message "servlet-error.html")
+       (authentication-message "forbidden.html")
+       (servlets-refreshed "servlet-refresh.html")
+       (passwords-refreshed "passwords-refresh.html")
+       (file-not-found-message "not-found.html")
+       (protocol-message "protocol-error.html"))
+     (timeouts
+       (default-servlet-timeout 120)
+       (password-connection-timeout 300)
+       (servlet-connection-timeout 86400)
+       (file-per-byte-connection-timeout 1/20)
+       (file-base-connection-timeout 30))
+     (paths
+      (configuration-root "conf")
+      (host-root "test-web-root")
+      (log-file-path "log")
+      (file-root "htdocs")
+      (servlet-root ".")
+      (password-authentication "passwords"))))
+ (virtual-host-table))
diff --git a/collects/tests/web-server/scheme-units/test-authentication.ss b/collects/tests/web-server/scheme-units/test-authentication.ss
new file mode 100644
index 0000000000..1f07256b3d
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/test-authentication.ss
@@ -0,0 +1,66 @@
+;; Mike Burns, July 28th, 2004, netgeek@speakeasy.net
+;; Test serving files that require authentication.
+(module test-authentication mzscheme
+  (require (lib "contract.ss")
+           (lib "test.ss" "schemeunit")
+           (lib "url.ss" "net")
+           (lib "head.ss" "net")
+           (lib "base64.ss" "net")
+           "assertions.ss"
+           )
+
+  (provide/contract
+    (test-authentication test-suite?))
+
+  ;; Check for 403.
+  (define-simple-assertion (assert-no-serve url-path)
+    ;; Ordering matters, so use let*
+    (let* ((stop-server (start-server))
+           (http-port (get-impure-port (full-url url-path))))
+      (begin0
+        (not (equal? (read-line http-port) "HTTP/1.1 200 Okay\r"))
+        (stop-server))))
+
+  (define-simple-assertion (assert-auth url-path auth-string)
+     (let* ((stop-server (start-server))
+            (http-port (get-impure-port (full-url url-path)
+                                        (auth-headers auth-string))))
+       (begin0
+         (equal? (read-line http-port) "HTTP/1.1 200 Okay\r")
+         (stop-server))))
+
+  ;; Create the headers for an authorization string.
+  (define/contract auth-headers
+    (bytes? . -> . (listof string?))
+    (lambda (auth-string)
+      (list (format "authorization: Basic ~a"
+                    (base64-encode auth-string)))))
+
+  (define test-authentication
+    (make-test-suite
+      (make-test-case
+        "Authorization-only file without providing authorization, implicit file"
+        (assert-no-serve "/secret/"))
+      (make-test-case
+        "Authorization-only file with provided authorization, implicit file"
+        (assert-auth "/secret/" #"bubba:bbq"))
+      (make-test-case
+        "Authorization-only file without providing authorization, explicit file"
+        (assert-no-serve "/secret/index.html"))
+      (make-test-case
+        "Authorization-only file with provided authorization, explicit file"
+        (assert-auth "/secret/index.html" #"bubba:bbq"))))
+
+  ;;; TODO
+  ;;; browser requests file,
+  ;;; browser gives 403,
+  ;;; browser provides creditentials,
+  ;;; server provides file
+
+  ;;; browser requests file,
+  ;;; browser gives 403,
+  ;;; browser provides creditentials,
+  ;;; creditentials are bogus,
+  ;;; server does not provide file
+  
+  )
diff --git a/collects/tests/web-server/scheme-units/test-channel.ss b/collects/tests/web-server/scheme-units/test-channel.ss
new file mode 100644
index 0000000000..4c960d7e04
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/test-channel.ss
@@ -0,0 +1,28 @@
+;; Mike Burns, July 8th, 2004, netgeek@speakeasy.net
+;; Test async-channel:
+(module test-channel mzscheme
+  (require (lib "test.ss" "schemeunit")
+           (lib "channel.ss" "web-server"))
+
+  (provide test-channel)
+
+  (define test-channel
+    (let ((c (make-async-channel))
+          (v (gensym)))
+      (make-test-suite
+        "Test async-channel"
+        (make-test-case
+          "async-channel-get-available of the empty channel"
+          (assert-eq? (void) (async-channel-get-available c (lambda (x) #f))))
+        (make-test-case
+          "async-channel-get-available of the non-empty channel"
+          (assert-false (begin (async-channel-put c v)
+                               (async-channel-get-available c (lambda (x) #f)))))
+        (make-test-case
+          "async-channel-try-get of the empty channel"
+          (assert-false (async-channel-try-get c (lambda () #f))))
+        (make-test-case
+          "async-channel-try-get of the non-empty channel" 
+          (assert-eq? v (begin (async-channel-put c v)
+                               (async-channel-try-get c (lambda () #f))))))))
+  )
diff --git a/collects/tests/web-server/scheme-units/test-errors.ss b/collects/tests/web-server/scheme-units/test-errors.ss
new file mode 100644
index 0000000000..38b02af6d3
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/test-errors.ss
@@ -0,0 +1,70 @@
+;; Mike Burns, July 28th, 2004, netgeek@speakeasy.net
+;; Test the error messages for both headers and content.
+(module test-errors mzscheme
+  (require (lib "test.ss" "schemeunit")
+           (lib "url.ss" "net")
+           "assertions.ss"
+           )
+
+  (provide test-errors)
+
+  (define test-errors
+    (make-test-suite
+      "Test the error messages for both headers and content"
+
+      (make-test-case
+        "404 with an absolute filename"
+        (assert-status-number "/does-not-exist" 404))
+
+      (make-test-case
+        "404 with a relative filename"
+        (assert-status-number "does-not-exist" 404))
+
+      (make-test-case
+        "404 with an absolute directory name"
+        (assert-status-number "/does-not-exist/" 404))
+
+      (make-test-case
+        "404 with an relative directory name"
+        (assert-status-number "does-not-exist/" 404))
+
+      (make-test-case
+        "404 with an absolute servlet"
+        (assert-status-number "/servlets/does-not-exist" 404))
+
+      ; Not in suite.ss
+      ;(make-test-case
+      ; "Unit servlet not returning a response"
+      ; ...)
+      ;;; TODO check headers
+
+      (make-test-case
+        "Require failure"
+        (assert-with-server
+          "/servlets/bad-require.ss"
+          (lambda (http-port)
+            (purify-port http-port) ;; For the effect
+            (input-port-equal? 
+              http-port
+              (open-input-string
+                (format
+                  (string-append
+                    "Servlet didn't load.~ndefault-load-handler: cannot open "
+                    "input file: \"~a\" (No such file or directory; "
+                    "errno=2)")
+                  (path->string
+                    (build-path web-root
+                                "servlets"
+                                "I-do-not-exist.ss"))))))))
+
+      (make-test-case
+        "Exception raised"
+        (assert-serve "/servlets/raise-exception.ss"
+                      (path->string
+                        (build-path web-root
+                                    "htdocs"
+                                    "servlet-output"
+                                    "raise-exception.ss"))
+                      "text/plain"))))
+
+  )
diff --git a/collects/tests/web-server/scheme-units/test-serve-static-html.ss b/collects/tests/web-server/scheme-units/test-serve-static-html.ss
new file mode 100644
index 0000000000..9aa1de9c23
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/test-serve-static-html.ss
@@ -0,0 +1,26 @@
+;; Mike Burns, July 28th, 2004, netgeek@speakeasy.net
+;; Test whether a static, HTML file can be sent correctly.
+(module test-serve-static-html mzscheme
+  (require (lib "test.ss" "schemeunit")
+           (lib "contract.ss")
+           "assertions.ss"
+           )
+
+  (provide/contract
+    (test-serve-static-html test-suite?))
+
+  (define test-serve-static-html
+    (make-test-suite
+      "Test whether static HTML can be served"
+      (make-test-case
+        "Serve HTML explicitly"
+        (assert-serve "/index.html"
+                      (build-path web-root "htdocs" "index.html")
+                      "text/html"))
+      (make-test-case
+        "Serve HTML implicitly"
+        (assert-serve "/"
+                      (build-path web-root "htdocs" "index.html")
+                      "text/html"))))
+  ;;; TODO test that additional indices work, too.
+  )
diff --git a/collects/tests/web-server/scheme-units/test-serve-static-jpeg.ss b/collects/tests/web-server/scheme-units/test-serve-static-jpeg.ss
new file mode 100644
index 0000000000..cd750d64d1
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/test-serve-static-jpeg.ss
@@ -0,0 +1,25 @@
+;; Mike Burns, July 28th, 2004, netgeek@speakeasy.net
+;; Test serving JPEGs. This also tests PR #6302.
+(module test-serve-static-jpeg mzscheme
+  (require (lib "contract.ss")
+           (lib "test.ss" "schemeunit")
+           "assertions.ss")
+
+  (provide/contract
+    (test-serve-static-jpeg test-suite?))
+
+  (define test-serve-static-jpeg
+    (make-test-suite
+      "Test whether static JPEGs can be served"
+      (make-test-case
+        "Serve JPEG"
+        (assert-serve "/me.jpg"
+                      (build-path web-root "htdocs" "me.jpg")
+                      "image/jpeg"))
+      (make-test-case
+        "Serve JPEG with upper-case \"extension\""
+        (assert-serve "/me2.JPG"
+                      (build-path web-root "htdocs" "me2.JPG")
+                      "image/jpeg"))))
+
+  )
diff --git a/collects/tests/web-server/scheme-units/test-servlets.ss b/collects/tests/web-server/scheme-units/test-servlets.ss
new file mode 100644
index 0000000000..b6c58accd9
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/test-servlets.ss
@@ -0,0 +1,175 @@
+;; Mike Burns, July 28th, 2004, netgeek@speakeasy.net
+;; Test servlets.
+;; - Normal servlet call.
+;; - Servlet call plus arguments on the URL
+;; - Incremental servlets
+;; - Various MIME formats
+;; - URL paths
+(module test-servlets mzscheme
+  (require (lib "contract.ss")
+           (lib "test.ss" "schemeunit")
+           "assertions.ss"
+           )
+
+  (provide/contract
+    (test-servlets test-suite?))
+
+  (define test1-output "<html><head><title>Title</title></head></html>")
+
+  (define test2-output
+    (string-append
+      "<html><head><title>Title</title></head><body><h1>Title</h1><p>Current "
+      "path: " (path->string (build-path web-root "servlets"))
+      "</p></body></html>"))
+
+  (define test2-incremental-output
+    (string-append
+      "<html><head><title>Title</title></head><body><h1>Title</h1><p>Current "
+      "path: " (path->string (build-path web-root "servlets"))
+      "</p></body></html>"))
+
+  (define test3-output "blah blah plain text")
+
+  (define test4-output
+    (string-append
+      "<html><head><title>Title</title></head><body><h1>Title</h1><p>ab</p>"
+      "<p>seed</p></body></html>"))
+
+  (define test5-output
+    (string-append
+      "<html><head><title>Title</title></head><body><h1>Title</h1><p>ab</p>"
+      "<p>seed</p><p>Current path: " (path->string
+                                       (build-path web-root "servlets"))
+      "</p></body></html>"))
+
+  (define test6-output "abseed")
+
+  (define test7-output (path->string (build-path web-root "servlets")))
+
+  (define test8-output (string-append (path->string
+                                        (build-path web-root "servlets"))
+                                      "abseed"))
+
+  (define test-servlets
+    (make-test-suite
+
+      ;; Non-incrementals
+      (make-test-case
+        (string-append
+          "Non-incremental servlet with no arguments on the URL, "
+          "in text/html, no URL path")
+        (assert-serve/string "/servlets/test1.ss"
+                      test1-output
+                      "text/html"))
+
+      (make-test-case
+        (string-append
+          "Non-incremental servlet with no arguments on the URL, "
+          "in text/html, with URL path")
+        (assert-serve/string "/servlets/test2.ss/home"
+                      test2-output
+                      "text/html"))
+
+      (make-test-case
+        (string-append
+          "Non-incremental servlet with no arguments on the URL, "
+          "in text/plain, no URL path")
+        (assert-serve/string "/servlets/test3.ss"
+                      test3-output
+                      "text/plain"))
+
+      (make-test-case
+        (string-append
+          "Non-incremental servlet with arguments on the URL, "
+          "in text/html, no URL path")
+        (assert-serve/string "/servlets/test4.ss?a=b&see=d"
+                      test4-output
+                      "text/html"))
+
+      (make-test-case
+        (string-append
+          "Non-incremental servlet with arguments on the URL, "
+          "in text/html, with URL path")
+        (assert-serve/string "/servlets/test5.ss/home?a=b&see=d"
+                      test5-output
+                      "text/html"))
+
+      (make-test-case
+        (string-append
+          "Non-incremental servlet with arguments on the URL, "
+          "in text/plain, no URL path")
+        (assert-serve/string "/servlets/test6.ss?a=b&see=d"
+                      test6-output
+                      "text/plain"))
+
+      (make-test-case
+        (string-append
+          "Non-incremental servlet no arguments on the URL, "
+          "in text/plain, with URL path")
+        (assert-serve/string "/servlets/test7.ss/home"
+                      test7-output
+                      "text/plain"))
+
+      (make-test-case
+        (string-append
+          "Non-incremental servlet with arguments on the URL, "
+          "in text/plain, with URL path")
+        (assert-serve/string "/servlets/test8.ss/home?a=b&see=d"
+                      test8-output
+                      "text/plain"))
+
+      ;; Incrementals
+      (make-test-case
+        (string-append
+          "Incremental servlet with no arguments on the URL, "
+          "in text/html, no URL path")
+        (assert-serve/string "/servlets/test1-incremental.ss"
+                      test1-output
+                      "text/html"))
+
+      (make-test-case
+        (string-append
+          "Incremental servlet with no arguments on the URL, "
+          "in text/html, with URL path")
+        (assert-serve/string "/servlets/test2-incremental.ss/home"
+                      test2-incremental-output
+                      "text/html"))
+      ;; Only the first two are tested incrementally.
+
+      ;;; TODO
+      ;;; - <form action="...?a=b;c=d" method="POST"> ... </form>
+
+      ;; A servlet with an implicit send/back.
+      (make-test-case
+        "Implicit send/back"
+        (let ((stop-server (start-server)))
+          (let* ((p1 (get-pure-port
+                       (string->url
+                         (format "http://~a:~a/servlets/add.ss"
+                                 THE-IP THE-PORT))))
+                 (m1 (regexp-match #rx"action=\"([^\"]*)\"" p1))
+                 (p2 (post-pure-port
+                       (string->url
+                         (format "http://~a:~a~a" THE-IP THE-PORT (cadr m1)))
+                       #"number=1"
+                       null))
+                 (m2 (regexp-match #rx"action=\"([^\"]*)\"" p2))
+                 (p3 (sync/timeout
+                       5
+                       (post-impure-port
+                         (string->url
+                           (format "http://~a:~a~a" THE-IP THE-PORT (cadr m2)))
+                         #"number=2"
+                         null))))
+            (printf "p3 = ~s~n" p3)
+            (if p3
+              (begin0
+                (begin
+                  (purify-port p3)
+                  (equal? (read-string 100 p3) add-output))
+                (stop-server))
+              (begin (stop-server) (fail))))))
+
+      ))
+
+  )
diff --git a/collects/tests/web-server/scheme-units/test-suite.ss b/collects/tests/web-server/scheme-units/test-suite.ss
new file mode 100644
index 0000000000..9ff6be89ec
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/test-suite.ss
@@ -0,0 +1,22 @@
+#!/bin/sh
+#|
+exec mzscheme -r "$0" "$@"
+|#
+;; Mike Burns, July 28th, 2004, netgeek@speakeasy.net
+;; Run from collects/tests/web-server/scheme-units
+(require (lib "text-ui.ss" "schemeunit")
+         "test-authentication.ss"
+         "test-serve-static-html.ss"
+         "test-serve-static-jpeg.ss"
+         "test-web-server.ss"
+         "test-servlets.ss"
+         "test-errors.ss"
+         "test-send.ss")
+
+(test/text-ui test-web-server)
+(test/text-ui test-serve-static-html)
+(test/text-ui test-serve-static-jpeg)
+(test/text-ui test-authentication)
+(test/text-ui test-errors)
+(test/text-ui test-servlets)
+(test/text-ui test-send)
diff --git a/collects/tests/web-server/scheme-units/test-timeout.ss b/collects/tests/web-server/scheme-units/test-timeout.ss
new file mode 100644
index 0000000000..a17989f402
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/test-timeout.ss
@@ -0,0 +1,28 @@
+;; Mike Burns, July 28th, 2004, netgeek@speakeasy.net
+;; Test if the server does timeout
+(module test-timeout mzscheme
+  (require (lib "test.ss" "schemeunit")
+           "assertions.ss"
+           )
+
+  (provide test-timeout)
+
+  (define *timeout* 40)
+
+  (define test-timeout
+    (make-test-suite
+      "Does the server time out?"
+      (make-test-case
+        (format "Does the server time out after ~a seconds?" *timeout*)
+        (assert-with-server
+          "/servlets/test1.ss"
+          (lambda (http-port)
+            (assert-pred
+              (lambda (in)
+                (sleep *timeout*) ;; Wait for it to timeout
+                (and (char-ready? in) (eof-object? (read-char in))))
+              (let-values (((in out) (tcp-connect THE-IP THE-PORT)))
+                in)))))))
+
+  ;;; TODO adjust-timeout!
+  )
diff --git a/collects/tests/web-server/scheme-units/test-web-root/conf/forbidden.html b/collects/tests/web-server/scheme-units/test-web-root/conf/forbidden.html
new file mode 100644
index 0000000000..fcd2eb9032
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/test-web-root/conf/forbidden.html
@@ -0,0 +1,7 @@
+<html>
+<head><title>Access Denied</title></head>
+<body>
+<p>The server could not verify that you have permissions to access the requested document.</p>
+<p>Powered by <a href="http://www.plt-scheme.org/">PLT</a></p>
+</body>
+</html>
\ No newline at end of file
diff --git a/collects/tests/web-server/scheme-units/test-web-root/conf/not-found.html b/collects/tests/web-server/scheme-units/test-web-root/conf/not-found.html
new file mode 100644
index 0000000000..19bc1a0570
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/test-web-root/conf/not-found.html
@@ -0,0 +1,7 @@
+<html>
+<head><title>Not Found</title></head>
+<body bgcolor='white'>
+<p>The file you were looking for was not found on this server.</p>
+<p>Powered by <a href="http://www.plt-scheme.org/">PLT</a></p>
+</body>
+</html>
diff --git a/collects/tests/web-server/scheme-units/test-web-root/conf/passwords-refresh.html b/collects/tests/web-server/scheme-units/test-web-root/conf/passwords-refresh.html
new file mode 100644
index 0000000000..3f283393ab
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/test-web-root/conf/passwords-refresh.html
@@ -0,0 +1,7 @@
+<html>
+<head><title>Passwords Refreshed</title></head>
+<body bgcolor='white'>
+<p>The Web server is now using the new password file.</p>
+<p>Powered by <a href="http://www.plt-scheme.org/">PLT</a></p>
+</body>
+</html>
diff --git a/collects/tests/web-server/scheme-units/test-web-root/conf/protocol-error.html b/collects/tests/web-server/scheme-units/test-web-root/conf/protocol-error.html
new file mode 100644
index 0000000000..122732cc8d
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/test-web-root/conf/protocol-error.html
@@ -0,0 +1,7 @@
+<html>
+<head><title>Browser Error</title></head>
+<body>
+<p>The browser sent a malformed request.</p>
+<p>Powered by <a href="http://www.plt-scheme.org/">PLT</a></p>
+</body>
+</html>
diff --git a/collects/tests/web-server/scheme-units/test-web-root/conf/servlet-error.html b/collects/tests/web-server/scheme-units/test-web-root/conf/servlet-error.html
new file mode 100644
index 0000000000..bf6b698231
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/test-web-root/conf/servlet-error.html
@@ -0,0 +1,9 @@
+<html>
+<head><title>Servlet Error</title></head>
+<body>
+<p>The servlet terminated abnormally.<br />
+   Please ask the author to fix the problem based on the details in
+   the Web server's log file.</p>
+<p>Powered by <a href="http://www.plt-scheme.org/">PLT</a></p>
+</body>
+</html>
diff --git a/collects/tests/web-server/scheme-units/test-web-root/conf/servlet-refresh.html b/collects/tests/web-server/scheme-units/test-web-root/conf/servlet-refresh.html
new file mode 100644
index 0000000000..8db24b53c5
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/test-web-root/conf/servlet-refresh.html
@@ -0,0 +1,7 @@
+<html>
+<head><title>Servlets Refreshed</title></head>
+<body bgcolor='white'>
+<p>Fresh copies of Servlets will now be (re)loaded from disk.</p>
+<p>Powered by <a href="http://www.plt-scheme.org/">PLT</a></p>
+</body>
+</html>
diff --git a/collects/tests/web-server/scheme-units/test-web-root/htdocs/index.html b/collects/tests/web-server/scheme-units/test-web-root/htdocs/index.html
new file mode 100644
index 0000000000..c49a72f0fc
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/test-web-root/htdocs/index.html
@@ -0,0 +1,40 @@
+<html>
+ <head>
+   <title>Welcome to the PLT Web server!</title>
+ </head>
+
+ <body bgcolor="white">
+ <img src="/Defaults/documentation/web-server.gif" width="61" height="57" />
+
+<blockquote>
+
+<table width="66%" bgcolor="white">
+<tr><td>
+  <h2>Welcome to the PLT Web Server</h2>
+
+  <p>
+    Find out more about <a href='/Defaults/'>the server and configure</a> it.
+  </p>
+
+  <p>Please replace this page with your favorite index page. 
+  <br />For future configuration changes, remember to look up
+  <br />
+<center>
+   <code> http://127.0.0.1:<var>port</var>/Defaults/ </code>
+</center>
+
+  <p>Powered by 
+  <a href="http://www.plt-scheme.org/">
+   <img width="53" height="19" src="/Defaults/documentation/plt-logo.gif" />
+   </a>
+  <p><font size="-2">
+  For more information on PLT Software, please follow the icon link.
+  </font>
+  </p>
+  </p>
+</table>
+
+</blockquote>
+
+ </body>
+</html>
diff --git a/collects/tests/web-server/scheme-units/test-web-root/htdocs/me.jpg b/collects/tests/web-server/scheme-units/test-web-root/htdocs/me.jpg
new file mode 100644
index 0000000000..2b3e9ac372
Binary files /dev/null and b/collects/tests/web-server/scheme-units/test-web-root/htdocs/me.jpg differ
diff --git a/collects/tests/web-server/scheme-units/test-web-root/htdocs/me2.JPG b/collects/tests/web-server/scheme-units/test-web-root/htdocs/me2.JPG
new file mode 100644
index 0000000000..2b3e9ac372
Binary files /dev/null and b/collects/tests/web-server/scheme-units/test-web-root/htdocs/me2.JPG differ
diff --git a/collects/tests/web-server/scheme-units/test-web-root/htdocs/secret/index.html b/collects/tests/web-server/scheme-units/test-web-root/htdocs/secret/index.html
new file mode 100644
index 0000000000..47a10821a2
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/test-web-root/htdocs/secret/index.html
@@ -0,0 +1,9 @@
+<html>
+  <head>
+    <title>You win nothing!</title>
+  </head>
+  <body>
+    <h1>You win nothing!</h1>
+    <p>Congrats, loser!</p>
+  </body>
+</html>
diff --git a/collects/tests/web-server/scheme-units/test-web-root/htdocs/servlet-output/raise-exception.ss b/collects/tests/web-server/scheme-units/test-web-root/htdocs/servlet-output/raise-exception.ss
new file mode 100644
index 0000000000..25841c94ff
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/test-web-root/htdocs/servlet-output/raise-exception.ss
@@ -0,0 +1,2 @@
+Servlet didn't load.
+ka-boom!
diff --git a/collects/tests/web-server/scheme-units/test-web-root/htdocs/servlet-output/test1.ss b/collects/tests/web-server/scheme-units/test-web-root/htdocs/servlet-output/test1.ss
new file mode 100644
index 0000000000..b548f3264a
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/test-web-root/htdocs/servlet-output/test1.ss
@@ -0,0 +1 @@
+<html><head><title>Title</title></head></html>
diff --git a/collects/tests/web-server/scheme-units/test-web-root/htdocs/servlet-output/test2-incremental.ss b/collects/tests/web-server/scheme-units/test-web-root/htdocs/servlet-output/test2-incremental.ss
new file mode 100644
index 0000000000..6fc6650151
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/test-web-root/htdocs/servlet-output/test2-incremental.ss
@@ -0,0 +1 @@
+<html><head><title>Title</title></head><body><h1>Title</h1><p>Current path: /proj/scheme/netgeek/collects/tests/web-server/scheme-units</p></body></html>
diff --git a/collects/tests/web-server/scheme-units/test-web-root/htdocs/servlet-output/test2.ss b/collects/tests/web-server/scheme-units/test-web-root/htdocs/servlet-output/test2.ss
new file mode 100644
index 0000000000..5a7812d3f6
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/test-web-root/htdocs/servlet-output/test2.ss
@@ -0,0 +1 @@
+<html><head><title>Title</title></head><body><h1>Title</h1><p>Current path: /proj/scheme/netgeek/collects/tests/web-server/scheme-units/test-web-root/servlets</p></body></html>
diff --git a/collects/tests/web-server/scheme-units/test-web-root/htdocs/servlet-output/test3.ss b/collects/tests/web-server/scheme-units/test-web-root/htdocs/servlet-output/test3.ss
new file mode 100644
index 0000000000..6cf065190e
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/test-web-root/htdocs/servlet-output/test3.ss
@@ -0,0 +1 @@
+blah blah plain text
diff --git a/collects/tests/web-server/scheme-units/test-web-root/htdocs/servlet-output/test4.ss b/collects/tests/web-server/scheme-units/test-web-root/htdocs/servlet-output/test4.ss
new file mode 100644
index 0000000000..17d29b73b9
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/test-web-root/htdocs/servlet-output/test4.ss
@@ -0,0 +1 @@
+<html><head><title>Title</title></head><body><h1>Title</h1><p>ab</p><p>seed</p></body></html>
diff --git a/collects/tests/web-server/scheme-units/test-web-root/htdocs/servlet-output/test5.ss b/collects/tests/web-server/scheme-units/test-web-root/htdocs/servlet-output/test5.ss
new file mode 100644
index 0000000000..fab799d9d4
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/test-web-root/htdocs/servlet-output/test5.ss
@@ -0,0 +1 @@
+<html><head><title>Title</title></head><body><h1>Title</h1><p>ab</p><p>seed</p><p>Current path: /proj/scheme/netgeek/collects/tests/web-server/scheme-units/test-web-root/servlets</p></body></html>
diff --git a/collects/tests/web-server/scheme-units/test-web-root/htdocs/servlet-output/test6.ss b/collects/tests/web-server/scheme-units/test-web-root/htdocs/servlet-output/test6.ss
new file mode 100644
index 0000000000..403b79b8f5
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/test-web-root/htdocs/servlet-output/test6.ss
@@ -0,0 +1 @@
+abseed
diff --git a/collects/tests/web-server/scheme-units/test-web-root/htdocs/servlet-output/test7.ss b/collects/tests/web-server/scheme-units/test-web-root/htdocs/servlet-output/test7.ss
new file mode 100644
index 0000000000..99c333ab47
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/test-web-root/htdocs/servlet-output/test7.ss
@@ -0,0 +1 @@
+/proj/scheme/netgeek/collects/tests/web-server/scheme-units/test-web-root/servlets
diff --git a/collects/tests/web-server/scheme-units/test-web-root/htdocs/servlet-output/test8.ss b/collects/tests/web-server/scheme-units/test-web-root/htdocs/servlet-output/test8.ss
new file mode 100644
index 0000000000..01455f6af8
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/test-web-root/htdocs/servlet-output/test8.ss
@@ -0,0 +1 @@
+/proj/scheme/netgeek/collects/tests/web-server/scheme-units/test-web-root/servletsabseed
diff --git a/collects/tests/web-server/scheme-units/test-web-root/log b/collects/tests/web-server/scheme-units/test-web-root/log
new file mode 100644
index 0000000000..e9e191d07a
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/test-web-root/log
@@ -0,0 +1,1053 @@
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Thursday, July 8th, 2004 10:56:47pm")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Thursday, July 8th, 2004 10:56:47pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Thursday, July 8th, 2004 10:57:35pm")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Thursday, July 8th, 2004 10:57:35pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Thursday, July 8th, 2004 11:01:34pm")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Thursday, July 8th, 2004 11:01:44pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Thursday, July 8th, 2004 11:01:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Thursday, July 8th, 2004 11:01:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Friday, July 9th, 2004 12:26:21pm")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Friday, July 9th, 2004 12:26:21pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Friday, July 9th, 2004 12:30:25pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me.jpg" at "Friday, July 9th, 2004 12:30:25pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, July 9th, 2004 1:08:21pm")
+(from "129.10.117.166" to "129.10.117.166" for "/secret/" at "Friday, July 9th, 2004 1:12:31pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, July 9th, 2004 1:32:21pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, July 9th, 2004 1:32:22pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Friday, July 9th, 2004 1:32:22pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, July 9th, 2004 1:32:43pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, July 9th, 2004 1:32:43pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Friday, July 9th, 2004 1:32:43pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, July 9th, 2004 2:13:47pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, July 9th, 2004 2:13:47pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Friday, July 9th, 2004 2:13:47pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, July 9th, 2004 2:14:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, July 9th, 2004 2:14:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Friday, July 9th, 2004 2:14:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Friday, July 9th, 2004 2:15:32pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, July 9th, 2004 2:16:25pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, July 9th, 2004 2:16:25pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Friday, July 9th, 2004 2:16:25pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, July 9th, 2004 2:16:28pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, July 9th, 2004 2:16:28pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Friday, July 9th, 2004 2:16:29pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Friday, July 9th, 2004 2:16:48pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Friday, July 9th, 2004 2:17:37pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Friday, July 9th, 2004 2:21:19pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Friday, July 9th, 2004 2:22:23pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Friday, July 9th, 2004 2:23:28pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, July 9th, 2004 2:24:20pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, July 9th, 2004 2:24:20pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Friday, July 9th, 2004 2:24:20pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Friday, July 9th, 2004 2:25:20pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Friday, July 9th, 2004 2:51:50pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Friday, July 9th, 2004 2:52:57pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Friday, July 9th, 2004 2:54:04pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Friday, July 9th, 2004 2:56:32pm")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Friday, July 9th, 2004 2:56:32pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Friday, July 9th, 2004 2:56:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Friday, July 9th, 2004 2:56:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Friday, July 9th, 2004 2:57:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me.jpg" at "Friday, July 9th, 2004 2:57:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, July 9th, 2004 2:57:13pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, July 9th, 2004 2:57:13pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Friday, July 9th, 2004 2:57:13pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, July 9th, 2004 2:58:55pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, July 9th, 2004 2:58:55pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Friday, July 9th, 2004 2:58:55pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, July 9th, 2004 2:59:42pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, July 9th, 2004 2:59:42pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Friday, July 9th, 2004 2:59:42pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, July 9th, 2004 3:00:49pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, July 9th, 2004 3:00:49pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Friday, July 9th, 2004 3:00:49pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, July 9th, 2004 3:01:15pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, July 9th, 2004 3:01:15pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Friday, July 9th, 2004 3:01:16pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, July 9th, 2004 3:04:40pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, July 9th, 2004 3:04:40pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Friday, July 9th, 2004 3:04:40pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Friday, July 9th, 2004 3:04:41pm")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Friday, July 9th, 2004 3:04:41pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Friday, July 9th, 2004 3:04:41pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me.jpg" at "Friday, July 9th, 2004 3:04:41pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, July 9th, 2004 3:05:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, July 9th, 2004 3:05:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Friday, July 9th, 2004 3:05:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Friday, July 9th, 2004 3:05:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Friday, July 9th, 2004 3:05:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Friday, July 9th, 2004 3:05:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me.jpg" at "Friday, July 9th, 2004 3:05:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, July 9th, 2004 3:05:25pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, July 9th, 2004 3:05:25pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Friday, July 9th, 2004 3:05:25pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Friday, July 9th, 2004 3:05:25pm")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Friday, July 9th, 2004 3:05:25pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Friday, July 9th, 2004 3:05:25pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me.jpg" at "Friday, July 9th, 2004 3:05:25pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test1.ss" at "Friday, July 9th, 2004 3:41:04pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test1.ss" at "Friday, July 9th, 2004 4:00:10pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test2.ss/home" at "Friday, July 9th, 2004 4:00:23pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test2.ss/home" at "Friday, July 9th, 2004 4:00:37pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test2.ss/home" at "Friday, July 9th, 2004 4:01:00pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test2.ss" at "Friday, July 9th, 2004 5:00:15pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test2.ss/home" at "Friday, July 9th, 2004 5:00:18pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test2.ss/home" at "Friday, July 9th, 2004 5:00:31pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test2.ss/home" at "Friday, July 9th, 2004 5:00:40pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test2.ss/foo" at "Friday, July 9th, 2004 5:00:47pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test2.ss/home" at "Friday, July 9th, 2004 5:00:51pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test2.ss/home" at "Friday, July 9th, 2004 5:00:54pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test3.ss" at "Friday, July 9th, 2004 5:01:15pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test4.ss?a=b&see=d" at "Friday, July 9th, 2004 5:02:11pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test4.ss?a=b&see=d" at "Friday, July 9th, 2004 5:02:43pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test4.ss?a=b&see=d" at "Friday, July 9th, 2004 5:02:47pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test4.ss?a=b&see=d" at "Friday, July 9th, 2004 5:03:15pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test4.ss?a=b&see=d" at "Friday, July 9th, 2004 5:03:36pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test4.ss?a=b&see=d" at "Friday, July 9th, 2004 5:04:02pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test4.ss?a=b&see=d" at "Friday, July 9th, 2004 5:04:26pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test5.ss?a=b&see=d" at "Friday, July 9th, 2004 5:04:41pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test5.ss?a=b&see=d" at "Friday, July 9th, 2004 5:05:00pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test5.ss?a=b&see=d" at "Friday, July 9th, 2004 5:05:15pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test5.ss?a=b&see=d" at "Friday, July 9th, 2004 5:05:37pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test5.ss/home?a=b&see=d" at "Friday, July 9th, 2004 5:05:44pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test6.ss" at "Friday, July 9th, 2004 5:06:01pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test6.ss" at "Friday, July 9th, 2004 5:06:26pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test6.ss?a=b&see=d" at "Friday, July 9th, 2004 5:06:33pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test6.ss?a=b&see=d" at "Friday, July 9th, 2004 5:06:56pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test6.ss?a=b&see=d" at "Friday, July 9th, 2004 5:07:04pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test7.ss" at "Friday, July 9th, 2004 5:07:18pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test7.ss/home" at "Friday, July 9th, 2004 5:07:24pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test8.ss" at "Friday, July 9th, 2004 5:07:38pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test8.ss" at "Friday, July 9th, 2004 5:08:26pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test8.ss?a=b&see=d" at "Friday, July 9th, 2004 5:08:33pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test8.ss?a=b&see=d" at "Friday, July 9th, 2004 5:09:00pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test8.ss/home?a=b&see=d" at "Friday, July 9th, 2004 5:09:08pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test8.ss/home?a=b&see=d" at "Friday, July 9th, 2004 5:10:15pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test7.ss/home" at "Friday, July 9th, 2004 5:10:15pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test6.ss?a=b&see=d" at "Friday, July 9th, 2004 5:10:16pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test8.ss/home?a=b&see=d" at "Friday, July 9th, 2004 7:07:05pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test7.ss/home" at "Friday, July 9th, 2004 7:07:06pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test6.ss?a=b&see=d" at "Friday, July 9th, 2004 7:07:06pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test8.ss/home?a=b&see=d" at "Friday, July 9th, 2004 7:07:18pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test7.ss/home" at "Friday, July 9th, 2004 7:07:18pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test6.ss?a=b&see=d" at "Friday, July 9th, 2004 7:07:19pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test1.ss" at "Friday, July 9th, 2004 7:09:17pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test1.ss" at "Friday, July 9th, 2004 7:09:22pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test2.ss" at "Friday, July 9th, 2004 7:09:42pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test2.ss" at "Friday, July 9th, 2004 7:09:47pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test3.ss" at "Friday, July 9th, 2004 7:10:41pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test3.ss" at "Friday, July 9th, 2004 7:10:45pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test4.ss?a=b&see=d" at "Friday, July 9th, 2004 7:21:56pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test4.ss?a=b&see=d" at "Friday, July 9th, 2004 7:22:00pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test5.ss?a=b&see=d" at "Friday, July 9th, 2004 7:22:24pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test5.ss?a=b&see=d" at "Friday, July 9th, 2004 7:22:27pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test6.ss?a=b&see=d" at "Friday, July 9th, 2004 7:22:46pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test6.ss?a=b&see=d" at "Friday, July 9th, 2004 7:22:51pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test7.ss" at "Friday, July 9th, 2004 7:23:06pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test8.ss/home?a=b&see=d" at "Friday, July 9th, 2004 7:23:30pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test8.ss?a=b&see=d" at "Friday, July 9th, 2004 7:23:34pm")
+(from "129.10.114.106" to "129.10.117.166" for "/servlets/test8.ss?a=b&see=d" at "Friday, July 9th, 2004 7:23:37pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test8.ss/home?a=b&see=d" at "Friday, July 9th, 2004 7:24:12pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test7.ss/home" at "Friday, July 9th, 2004 7:24:12pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test6.ss?a=b&see=d" at "Friday, July 9th, 2004 7:24:13pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test5.ss/home?a=b&see=d" at "Friday, July 9th, 2004 7:24:13pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test4.ss?a=b&see=d" at "Friday, July 9th, 2004 7:24:13pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test3.ss" at "Friday, July 9th, 2004 7:24:14pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2.ss/home" at "Friday, July 9th, 2004 7:24:14pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test8.ss/home?a=b&see=r" at "Friday, July 9th, 2004 7:24:38pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test7.ss/home" at "Friday, July 9th, 2004 7:24:39pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test6.ss?a=b&see=d" at "Friday, July 9th, 2004 7:24:39pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test5.ss/home?a=b&see=d" at "Friday, July 9th, 2004 7:24:40pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test4.ss?a=b&see=d" at "Friday, July 9th, 2004 7:24:40pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test3.ss" at "Friday, July 9th, 2004 7:24:41pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2.ss/home" at "Friday, July 9th, 2004 7:24:41pm")
+(from "129.10.117.166" to "129.10.117.166" for "/servlets/test8.ss/home?a=b&see=d" at "Friday, July 9th, 2004 7:29:01pm")
+(from "129.10.117.166" to "129.10.117.166" for "/servlets/test8.ss/home?a=b&see=d" at "Friday, July 9th, 2004 7:45:19pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test8.ss/home?a=b&see=d" at "Friday, July 9th, 2004 7:47:46pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test7.ss/home" at "Friday, July 9th, 2004 7:47:46pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test8.ss/home?a=b&see=d" at "Friday, July 9th, 2004 8:07:33pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test7.ss/home" at "Friday, July 9th, 2004 8:07:34pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test6.ss?a=b&see=d" at "Friday, July 9th, 2004 8:07:35pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test5.ss/home?a=b&see=d" at "Friday, July 9th, 2004 8:07:35pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test4.ss?a=b&see=d" at "Friday, July 9th, 2004 8:07:35pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test3.ss" at "Friday, July 9th, 2004 8:07:36pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2.ss/home" at "Friday, July 9th, 2004 8:07:36pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test8.ss/home?a=b&see=d" at "Friday, July 9th, 2004 8:09:43pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test7.ss/home" at "Friday, July 9th, 2004 8:09:44pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test6.ss?a=b&see=d" at "Friday, July 9th, 2004 8:09:44pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test5.ss/home?a=b&see=d" at "Friday, July 9th, 2004 8:09:45pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test4.ss?a=b&see=d" at "Friday, July 9th, 2004 8:09:45pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test3.ss" at "Friday, July 9th, 2004 8:09:46pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2.ss/home" at "Friday, July 9th, 2004 8:09:46pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test8.ss/home?a=b&see=d" at "Friday, July 9th, 2004 8:10:48pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test7.ss/home" at "Friday, July 9th, 2004 8:10:49pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test6.ss?a=b&see=d" at "Friday, July 9th, 2004 8:10:49pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test5.ss/home?a=b&see=d" at "Friday, July 9th, 2004 8:10:50pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test4.ss?a=b&see=d" at "Friday, July 9th, 2004 8:10:50pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test3.ss" at "Friday, July 9th, 2004 8:10:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2.ss/home" at "Friday, July 9th, 2004 8:10:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test8.ss/home?a=b&see=d" at "Friday, July 9th, 2004 8:11:17pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test7.ss/home" at "Friday, July 9th, 2004 8:11:17pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test6.ss?a=b&see=d" at "Friday, July 9th, 2004 8:11:18pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test5.ss/home?a=b&see=d" at "Friday, July 9th, 2004 8:11:18pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test4.ss?a=b&see=d" at "Friday, July 9th, 2004 8:11:19pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test3.ss" at "Friday, July 9th, 2004 8:11:19pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2.ss/home" at "Friday, July 9th, 2004 8:11:20pm")
+(from "129.10.116.80" to "129.10.117.166" for "/" at "Monday, July 12th, 2004 8:34:12pm")
+(from "129.10.116.80" to "129.10.117.166" for "/Defaults/documentation/web-server.gif" at "Monday, July 12th, 2004 8:34:12pm")
+(from "129.10.116.80" to "129.10.117.166" for "/Defaults/documentation/plt-logo.gif" at "Monday, July 12th, 2004 8:34:12pm")
+(from "129.10.116.80" to "129.10.117.166" for "/favicon.ico" at "Monday, July 12th, 2004 8:34:12pm")
+(from "129.10.116.80" to "129.10.117.166" for "/servlets/missing.ss" at "Monday, July 12th, 2004 8:34:22pm")
+(from "129.10.116.80" to "129.10.117.166" for "/servlets/bad-require.ss" at "Monday, July 12th, 2004 8:35:22pm")
+(from "129.10.116.80" to "129.10.117.166" for "/servlets/raise-exception.ss" at "Monday, July 12th, 2004 8:41:44pm")
+(from "129.10.116.80" to "129.10.117.166" for "/servlets/bad-require.ss" at "Monday, July 12th, 2004 8:41:56pm")
+(from "129.10.117.166" to "129.10.117.166" for "/does-not-exist" at "Monday, July 12th, 2004 8:48:50pm")
+(from "129.10.117.166" to "129.10.117.166" for "/also-does-not-exist" at "Monday, July 12th, 2004 8:53:31pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Monday, July 12th, 2004 9:09:58pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Monday, July 12th, 2004 9:09:58pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Monday, July 12th, 2004 9:09:58pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist/" at "Monday, July 12th, 2004 9:09:58pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Monday, July 12th, 2004 9:09:58pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist" at "Monday, July 12th, 2004 9:09:59pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Monday, July 12th, 2004 9:09:59pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Monday, July 12th, 2004 9:24:23pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Monday, July 12th, 2004 9:24:23pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Monday, July 12th, 2004 9:27:20pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Monday, July 12th, 2004 9:27:20pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Monday, July 12th, 2004 9:27:21pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist/" at "Monday, July 12th, 2004 9:27:21pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Monday, July 12th, 2004 9:27:21pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist" at "Monday, July 12th, 2004 9:27:21pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Monday, July 12th, 2004 9:27:21pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Monday, July 12th, 2004 9:28:42pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Monday, July 12th, 2004 9:28:42pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Monday, July 12th, 2004 9:28:42pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist/" at "Monday, July 12th, 2004 9:28:42pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Monday, July 12th, 2004 9:28:42pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist" at "Monday, July 12th, 2004 9:28:42pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Monday, July 12th, 2004 9:28:42pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Monday, July 12th, 2004 9:29:06pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Monday, July 12th, 2004 9:29:06pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Monday, July 12th, 2004 9:29:06pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist/" at "Monday, July 12th, 2004 9:29:06pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Monday, July 12th, 2004 9:29:07pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist" at "Monday, July 12th, 2004 9:29:07pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Monday, July 12th, 2004 9:29:07pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Monday, July 12th, 2004 9:29:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Monday, July 12th, 2004 9:29:52pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist/" at "Monday, July 12th, 2004 9:29:52pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Monday, July 12th, 2004 9:29:52pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist" at "Monday, July 12th, 2004 9:29:52pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Monday, July 12th, 2004 9:29:52pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Monday, July 12th, 2004 9:31:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Monday, July 12th, 2004 9:31:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Monday, July 12th, 2004 9:31:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist/" at "Monday, July 12th, 2004 9:31:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Monday, July 12th, 2004 9:31:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist" at "Monday, July 12th, 2004 9:31:02pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Monday, July 12th, 2004 9:31:02pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Monday, July 12th, 2004 9:32:15pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Monday, July 12th, 2004 9:32:15pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Monday, July 12th, 2004 9:32:15pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist/" at "Monday, July 12th, 2004 9:32:15pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Monday, July 12th, 2004 9:32:15pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist" at "Monday, July 12th, 2004 9:32:15pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Monday, July 12th, 2004 9:32:15pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Monday, July 12th, 2004 9:34:22pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Monday, July 12th, 2004 9:34:22pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Monday, July 12th, 2004 9:34:22pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist/" at "Monday, July 12th, 2004 9:34:22pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Monday, July 12th, 2004 9:34:22pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist" at "Monday, July 12th, 2004 9:34:22pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Monday, July 12th, 2004 9:34:22pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Monday, July 12th, 2004 9:34:39pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Monday, July 12th, 2004 9:34:39pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Monday, July 12th, 2004 9:34:39pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist/" at "Monday, July 12th, 2004 9:34:39pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Monday, July 12th, 2004 9:34:39pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist" at "Monday, July 12th, 2004 9:34:39pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Monday, July 12th, 2004 9:34:39pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Monday, July 12th, 2004 9:35:10pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Monday, July 12th, 2004 9:35:10pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Monday, July 12th, 2004 9:35:10pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist/" at "Monday, July 12th, 2004 9:35:10pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Monday, July 12th, 2004 9:35:11pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist" at "Monday, July 12th, 2004 9:35:11pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Monday, July 12th, 2004 9:35:11pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test1.ss" at "Monday, July 12th, 2004 11:06:25pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Monday, July 26th, 2004 11:27:19am")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Monday, July 26th, 2004 11:27:19am")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Monday, July 26th, 2004 11:27:28am")
+(from "127.0.0.1" to "127.0.0.1" for "/me.jpg" at "Monday, July 26th, 2004 11:27:28am")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Monday, July 26th, 2004 11:27:33am")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Monday, July 26th, 2004 11:27:33am")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Monday, July 26th, 2004 11:27:33am")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Monday, July 26th, 2004 11:27:37am")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Monday, July 26th, 2004 11:27:38am")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Monday, July 26th, 2004 11:27:38am")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist/" at "Monday, July 26th, 2004 11:27:38am")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Monday, July 26th, 2004 11:27:38am")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist" at "Monday, July 26th, 2004 11:27:38am")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Monday, July 26th, 2004 11:27:38am")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Monday, July 26th, 2004 11:33:11am")
+(from "127.0.0.1" to "127.0.0.1" for "/Defaults/documentation/web-server.gif" at "Monday, July 26th, 2004 11:33:11am")
+(from "127.0.0.1" to "127.0.0.1" for "/Defaults/documentation/plt-logo.gif" at "Monday, July 26th, 2004 11:33:11am")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Monday, July 26th, 2004 2:18:27pm")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Monday, July 26th, 2004 2:18:27pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Monday, July 26th, 2004 2:18:27pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me.jpg" at "Monday, July 26th, 2004 2:18:27pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Monday, July 26th, 2004 2:18:27pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Monday, July 26th, 2004 2:18:27pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Monday, July 26th, 2004 2:18:27pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Monday, July 26th, 2004 2:18:28pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Monday, July 26th, 2004 2:18:28pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Monday, July 26th, 2004 2:18:28pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist/" at "Monday, July 26th, 2004 2:18:28pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Monday, July 26th, 2004 2:18:28pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist" at "Monday, July 26th, 2004 2:18:28pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Monday, July 26th, 2004 2:18:28pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Monday, July 26th, 2004 2:18:56pm")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Monday, July 26th, 2004 2:18:56pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Monday, July 26th, 2004 2:18:56pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me.jpg" at "Monday, July 26th, 2004 2:18:56pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Monday, July 26th, 2004 2:18:57pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Monday, July 26th, 2004 2:18:57pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Monday, July 26th, 2004 2:18:57pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Monday, July 26th, 2004 2:18:57pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Monday, July 26th, 2004 2:18:57pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Monday, July 26th, 2004 2:18:57pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist/" at "Monday, July 26th, 2004 2:18:57pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Monday, July 26th, 2004 2:18:57pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist" at "Monday, July 26th, 2004 2:18:57pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Monday, July 26th, 2004 2:18:57pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Monday, July 26th, 2004 2:19:21pm")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Monday, July 26th, 2004 2:19:21pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Monday, July 26th, 2004 2:19:21pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me.jpg" at "Monday, July 26th, 2004 2:19:22pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Monday, July 26th, 2004 2:19:22pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Monday, July 26th, 2004 2:19:22pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Monday, July 26th, 2004 2:19:22pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Monday, July 26th, 2004 2:19:22pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Monday, July 26th, 2004 2:19:22pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Monday, July 26th, 2004 2:19:22pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist/" at "Monday, July 26th, 2004 2:19:22pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Monday, July 26th, 2004 2:19:22pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist" at "Monday, July 26th, 2004 2:19:22pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Monday, July 26th, 2004 2:19:22pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Monday, July 26th, 2004 2:20:30pm")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Monday, July 26th, 2004 2:20:30pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Monday, July 26th, 2004 2:20:31pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me.jpg" at "Monday, July 26th, 2004 2:20:31pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Monday, July 26th, 2004 2:20:31pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Monday, July 26th, 2004 2:20:31pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Monday, July 26th, 2004 2:20:31pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Monday, July 26th, 2004 2:20:31pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Monday, July 26th, 2004 2:20:31pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Monday, July 26th, 2004 2:20:31pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist/" at "Monday, July 26th, 2004 2:20:31pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Monday, July 26th, 2004 2:20:31pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist" at "Monday, July 26th, 2004 2:20:32pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Monday, July 26th, 2004 2:20:32pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Monday, July 26th, 2004 2:21:09pm")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Monday, July 26th, 2004 2:21:09pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Monday, July 26th, 2004 2:21:09pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me.jpg" at "Monday, July 26th, 2004 2:21:09pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Monday, July 26th, 2004 2:21:10pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Monday, July 26th, 2004 2:21:10pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Monday, July 26th, 2004 2:21:10pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Monday, July 26th, 2004 2:21:10pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Monday, July 26th, 2004 2:21:10pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Monday, July 26th, 2004 2:21:10pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist/" at "Monday, July 26th, 2004 2:21:10pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Monday, July 26th, 2004 2:21:10pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist" at "Monday, July 26th, 2004 2:21:10pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Monday, July 26th, 2004 2:21:10pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Monday, July 26th, 2004 2:30:11pm")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Monday, July 26th, 2004 2:30:11pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Monday, July 26th, 2004 2:30:11pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me.jpg" at "Monday, July 26th, 2004 2:30:12pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Monday, July 26th, 2004 2:30:12pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Monday, July 26th, 2004 2:30:12pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Monday, July 26th, 2004 2:30:12pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Monday, July 26th, 2004 2:30:12pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Monday, July 26th, 2004 2:30:12pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Monday, July 26th, 2004 2:30:12pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist/" at "Monday, July 26th, 2004 2:30:12pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Monday, July 26th, 2004 2:30:12pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist" at "Monday, July 26th, 2004 2:30:12pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Monday, July 26th, 2004 2:30:12pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Monday, July 26th, 2004 2:31:07pm")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Monday, July 26th, 2004 2:31:08pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Monday, July 26th, 2004 2:31:08pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me.jpg" at "Monday, July 26th, 2004 2:31:08pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Monday, July 26th, 2004 2:31:08pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Monday, July 26th, 2004 2:31:08pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Monday, July 26th, 2004 2:31:08pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Monday, July 26th, 2004 2:31:08pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Monday, July 26th, 2004 2:31:08pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Monday, July 26th, 2004 2:31:08pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist/" at "Monday, July 26th, 2004 2:31:08pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Monday, July 26th, 2004 2:31:08pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist" at "Monday, July 26th, 2004 2:31:09pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Monday, July 26th, 2004 2:31:09pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test1-incremental.ss" at "Monday, July 26th, 2004 2:31:09pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test8.ss/home?a=b&see=d" at "Monday, July 26th, 2004 2:31:09pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test7.ss/home" at "Monday, July 26th, 2004 2:31:09pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test6.ss?a=b&see=d" at "Monday, July 26th, 2004 2:31:10pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test5.ss/home?a=b&see=d" at "Monday, July 26th, 2004 2:31:10pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test4.ss?a=b&see=d" at "Monday, July 26th, 2004 2:31:11pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test3.ss" at "Monday, July 26th, 2004 2:31:11pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2.ss/home" at "Monday, July 26th, 2004 2:31:12pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Monday, July 26th, 2004 2:32:55pm")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Monday, July 26th, 2004 2:32:55pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Monday, July 26th, 2004 2:32:55pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me.jpg" at "Monday, July 26th, 2004 2:32:55pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Monday, July 26th, 2004 2:32:55pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Monday, July 26th, 2004 2:32:55pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Monday, July 26th, 2004 2:32:56pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Monday, July 26th, 2004 2:32:56pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Monday, July 26th, 2004 2:32:56pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Monday, July 26th, 2004 2:32:56pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist/" at "Monday, July 26th, 2004 2:32:56pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Monday, July 26th, 2004 2:32:56pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist" at "Monday, July 26th, 2004 2:32:56pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Monday, July 26th, 2004 2:32:56pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test1-incremental.ss" at "Monday, July 26th, 2004 2:32:56pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test8.ss/home?a=b&see=d" at "Monday, July 26th, 2004 2:32:56pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test7.ss/home" at "Monday, July 26th, 2004 2:32:57pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test6.ss?a=b&see=d" at "Monday, July 26th, 2004 2:32:57pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test5.ss/home?a=b&see=d" at "Monday, July 26th, 2004 2:32:58pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test4.ss?a=b&see=d" at "Monday, July 26th, 2004 2:32:58pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test3.ss" at "Monday, July 26th, 2004 2:32:58pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2.ss/home" at "Monday, July 26th, 2004 2:32:59pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Monday, July 26th, 2004 2:33:07pm")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Monday, July 26th, 2004 2:33:07pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Monday, July 26th, 2004 2:33:08pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me.jpg" at "Monday, July 26th, 2004 2:33:08pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Monday, July 26th, 2004 2:33:08pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Monday, July 26th, 2004 2:33:08pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Monday, July 26th, 2004 2:33:08pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Monday, July 26th, 2004 2:33:08pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Monday, July 26th, 2004 2:33:08pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Monday, July 26th, 2004 2:33:08pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist/" at "Monday, July 26th, 2004 2:33:08pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Monday, July 26th, 2004 2:33:08pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist" at "Monday, July 26th, 2004 2:33:09pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Monday, July 26th, 2004 2:33:09pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test1-incremental.ss" at "Monday, July 26th, 2004 2:33:09pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test8.ss/home?a=b&see=d" at "Monday, July 26th, 2004 2:33:09pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test7.ss/home" at "Monday, July 26th, 2004 2:33:09pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test6.ss?a=b&see=d" at "Monday, July 26th, 2004 2:33:10pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test5.ss/home?a=b&see=d" at "Monday, July 26th, 2004 2:33:10pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test4.ss?a=b&see=d" at "Monday, July 26th, 2004 2:33:11pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test3.ss" at "Monday, July 26th, 2004 2:33:11pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2.ss/home" at "Monday, July 26th, 2004 2:33:11pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Monday, July 26th, 2004 2:34:20pm")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Monday, July 26th, 2004 2:34:20pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Monday, July 26th, 2004 2:34:20pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me.jpg" at "Monday, July 26th, 2004 2:34:20pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Monday, July 26th, 2004 2:34:20pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Monday, July 26th, 2004 2:34:21pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Monday, July 26th, 2004 2:34:21pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Monday, July 26th, 2004 2:34:21pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Monday, July 26th, 2004 2:34:21pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Monday, July 26th, 2004 2:34:21pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist/" at "Monday, July 26th, 2004 2:34:21pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Monday, July 26th, 2004 2:34:21pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist" at "Monday, July 26th, 2004 2:34:21pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Monday, July 26th, 2004 2:34:21pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test1-incremental.ss" at "Monday, July 26th, 2004 2:34:21pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test8.ss/home?a=b&see=d" at "Monday, July 26th, 2004 2:34:21pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test7.ss/home" at "Monday, July 26th, 2004 2:34:22pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test6.ss?a=b&see=d" at "Monday, July 26th, 2004 2:34:22pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test5.ss/home?a=b&see=d" at "Monday, July 26th, 2004 2:34:23pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test4.ss?a=b&see=d" at "Monday, July 26th, 2004 2:34:23pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test3.ss" at "Monday, July 26th, 2004 2:34:24pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2.ss/home" at "Monday, July 26th, 2004 2:34:24pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test1-incremental.ss" at "Monday, July 26th, 2004 2:40:01pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test1-incremental.ss" at "Monday, July 26th, 2004 2:40:50pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test1-incremental.ss" at "Monday, July 26th, 2004 2:41:22pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test1-incremental.ss" at "Monday, July 26th, 2004 2:41:33pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Monday, July 26th, 2004 2:41:50pm")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Monday, July 26th, 2004 2:41:50pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Monday, July 26th, 2004 2:41:50pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me.jpg" at "Monday, July 26th, 2004 2:41:50pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Monday, July 26th, 2004 2:41:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Monday, July 26th, 2004 2:41:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Monday, July 26th, 2004 2:41:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Monday, July 26th, 2004 2:41:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Monday, July 26th, 2004 2:41:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Monday, July 26th, 2004 2:41:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist/" at "Monday, July 26th, 2004 2:41:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Monday, July 26th, 2004 2:41:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist" at "Monday, July 26th, 2004 2:41:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Monday, July 26th, 2004 2:41:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test1-incremental.ss" at "Monday, July 26th, 2004 2:41:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test8.ss/home?a=b&see=d" at "Monday, July 26th, 2004 2:41:56pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test7.ss/home" at "Monday, July 26th, 2004 2:41:56pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Monday, July 26th, 2004 2:48:17pm")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Monday, July 26th, 2004 2:48:17pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Monday, July 26th, 2004 2:48:17pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me.jpg" at "Monday, July 26th, 2004 2:48:17pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Monday, July 26th, 2004 2:48:17pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Monday, July 26th, 2004 2:48:18pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Monday, July 26th, 2004 2:48:18pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Monday, July 26th, 2004 2:48:18pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Monday, July 26th, 2004 2:48:18pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Monday, July 26th, 2004 2:48:18pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist/" at "Monday, July 26th, 2004 2:48:18pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Monday, July 26th, 2004 2:48:18pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist" at "Monday, July 26th, 2004 2:48:18pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Monday, July 26th, 2004 2:48:18pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test1-incremental.ss" at "Monday, July 26th, 2004 2:48:18pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test8.ss/home?a=b&see=d" at "Monday, July 26th, 2004 2:48:23pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test7.ss/home" at "Monday, July 26th, 2004 2:48:23pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test6.ss?a=b&see=d" at "Monday, July 26th, 2004 2:48:23pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test5.ss/home?a=b&see=d" at "Monday, July 26th, 2004 2:48:24pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test4.ss?a=b&see=d" at "Monday, July 26th, 2004 2:48:24pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test3.ss" at "Monday, July 26th, 2004 2:48:25pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2.ss/home" at "Monday, July 26th, 2004 2:48:25pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test1-incremental.ss" at "Monday, July 26th, 2004 2:48:49pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test2-incremental.ss" at "Monday, July 26th, 2004 2:49:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Monday, July 26th, 2004 2:54:22pm")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Monday, July 26th, 2004 2:54:22pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Monday, July 26th, 2004 2:54:22pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me.jpg" at "Monday, July 26th, 2004 2:54:22pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Monday, July 26th, 2004 2:54:22pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Monday, July 26th, 2004 2:54:22pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Monday, July 26th, 2004 2:54:22pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Monday, July 26th, 2004 2:54:22pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Monday, July 26th, 2004 2:54:22pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Monday, July 26th, 2004 2:54:23pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist/" at "Monday, July 26th, 2004 2:54:23pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Monday, July 26th, 2004 2:54:23pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist" at "Monday, July 26th, 2004 2:54:23pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Monday, July 26th, 2004 2:54:23pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2-incremental.ss/home" at "Monday, July 26th, 2004 2:54:23pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test1-incremental.ss" at "Monday, July 26th, 2004 2:54:24pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test8.ss/home?a=b&see=d" at "Monday, July 26th, 2004 2:54:28pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test7.ss/home" at "Monday, July 26th, 2004 2:54:29pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test6.ss?a=b&see=d" at "Monday, July 26th, 2004 2:54:29pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test5.ss/home?a=b&see=d" at "Monday, July 26th, 2004 2:54:30pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test4.ss?a=b&see=d" at "Monday, July 26th, 2004 2:54:30pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test3.ss" at "Monday, July 26th, 2004 2:54:30pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2.ss/home" at "Monday, July 26th, 2004 2:54:31pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Monday, July 26th, 2004 2:55:11pm")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Monday, July 26th, 2004 2:55:11pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Monday, July 26th, 2004 2:55:11pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me.jpg" at "Monday, July 26th, 2004 2:55:12pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Monday, July 26th, 2004 2:55:12pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Monday, July 26th, 2004 2:55:12pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Monday, July 26th, 2004 2:55:12pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Monday, July 26th, 2004 2:55:12pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Monday, July 26th, 2004 2:55:12pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Monday, July 26th, 2004 2:55:12pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist/" at "Monday, July 26th, 2004 2:55:12pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Monday, July 26th, 2004 2:55:12pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist" at "Monday, July 26th, 2004 2:55:12pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Monday, July 26th, 2004 2:55:12pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2-incremental.ss/home" at "Monday, July 26th, 2004 2:55:12pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test1-incremental.ss" at "Monday, July 26th, 2004 2:55:13pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test8.ss/home?a=b&see=d" at "Monday, July 26th, 2004 2:55:17pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test7.ss/home" at "Monday, July 26th, 2004 2:55:18pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test6.ss?a=b&see=d" at "Monday, July 26th, 2004 2:55:18pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Monday, July 26th, 2004 3:04:24pm")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Monday, July 26th, 2004 3:04:24pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Monday, July 26th, 2004 3:04:24pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me.jpg" at "Monday, July 26th, 2004 3:04:25pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Monday, July 26th, 2004 3:04:25pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Monday, July 26th, 2004 3:04:25pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Monday, July 26th, 2004 3:04:25pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Monday, July 26th, 2004 3:04:25pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Monday, July 26th, 2004 3:04:25pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Monday, July 26th, 2004 3:04:25pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist/" at "Monday, July 26th, 2004 3:04:25pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Monday, July 26th, 2004 3:04:25pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist" at "Monday, July 26th, 2004 3:04:25pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Monday, July 26th, 2004 3:04:25pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2-incremental.ss/home" at "Monday, July 26th, 2004 3:04:25pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test1-incremental.ss" at "Monday, July 26th, 2004 3:04:26pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test8.ss/home?a=b&see=d" at "Monday, July 26th, 2004 3:04:31pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test7.ss/home" at "Monday, July 26th, 2004 3:04:31pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test6.ss?a=b&see=d" at "Monday, July 26th, 2004 3:04:32pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test5.ss/home?a=b&see=d" at "Monday, July 26th, 2004 3:04:32pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test4.ss?a=b&see=d" at "Monday, July 26th, 2004 3:04:33pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test3.ss" at "Monday, July 26th, 2004 3:04:33pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2.ss/home" at "Monday, July 26th, 2004 3:04:34pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Monday, July 26th, 2004 3:51:52pm")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Monday, July 26th, 2004 3:51:52pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Monday, July 26th, 2004 3:51:52pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me.jpg" at "Monday, July 26th, 2004 3:51:52pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Monday, July 26th, 2004 3:51:53pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Monday, July 26th, 2004 3:51:53pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Monday, July 26th, 2004 3:51:53pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Monday, July 26th, 2004 3:51:53pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Monday, July 26th, 2004 3:51:53pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Monday, July 26th, 2004 3:51:53pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist/" at "Monday, July 26th, 2004 3:51:53pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Monday, July 26th, 2004 3:51:53pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist" at "Monday, July 26th, 2004 3:51:53pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Monday, July 26th, 2004 3:51:53pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2-incremental.ss/home" at "Monday, July 26th, 2004 3:51:53pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test1-incremental.ss" at "Monday, July 26th, 2004 3:51:54pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Monday, July 26th, 2004 3:55:00pm")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Monday, July 26th, 2004 3:55:00pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Monday, July 26th, 2004 3:55:00pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me.jpg" at "Monday, July 26th, 2004 3:55:00pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Monday, July 26th, 2004 3:55:00pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Monday, July 26th, 2004 3:55:00pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Monday, July 26th, 2004 3:55:00pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Monday, July 26th, 2004 3:55:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Monday, July 26th, 2004 3:55:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Monday, July 26th, 2004 3:55:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist/" at "Monday, July 26th, 2004 3:55:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Monday, July 26th, 2004 3:55:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist" at "Monday, July 26th, 2004 3:55:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Monday, July 26th, 2004 3:55:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2-incremental.ss/home" at "Monday, July 26th, 2004 3:55:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test1-incremental.ss" at "Monday, July 26th, 2004 3:55:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test8.ss/home?a=b&see=d" at "Monday, July 26th, 2004 3:55:06pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test7.ss/home" at "Monday, July 26th, 2004 3:55:06pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test6.ss?a=b&see=d" at "Monday, July 26th, 2004 3:55:07pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test5.ss/home?a=b&see=d" at "Monday, July 26th, 2004 3:55:07pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test4.ss?a=b&see=d" at "Monday, July 26th, 2004 3:55:07pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test3.ss" at "Monday, July 26th, 2004 3:55:08pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2.ss/home" at "Monday, July 26th, 2004 3:55:08pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Monday, July 26th, 2004 4:04:27pm")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Monday, July 26th, 2004 4:04:27pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Monday, July 26th, 2004 4:04:28pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me.jpg" at "Monday, July 26th, 2004 4:04:28pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Monday, July 26th, 2004 4:04:28pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Monday, July 26th, 2004 4:04:28pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Monday, July 26th, 2004 4:04:28pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Monday, July 26th, 2004 4:04:28pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Monday, July 26th, 2004 4:04:28pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Monday, July 26th, 2004 4:04:28pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist/" at "Monday, July 26th, 2004 4:04:28pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Monday, July 26th, 2004 4:04:28pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist" at "Monday, July 26th, 2004 4:04:28pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Monday, July 26th, 2004 4:04:28pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2-incremental.ss/home" at "Monday, July 26th, 2004 4:04:28pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test1-incremental.ss" at "Monday, July 26th, 2004 4:04:37pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test8.ss/home?a=b&see=d" at "Monday, July 26th, 2004 4:04:42pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test7.ss/home" at "Monday, July 26th, 2004 4:04:43pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test6.ss?a=b&see=d" at "Monday, July 26th, 2004 4:04:44pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test5.ss/home?a=b&see=d" at "Monday, July 26th, 2004 4:04:45pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test4.ss?a=b&see=d" at "Monday, July 26th, 2004 4:04:45pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test3.ss" at "Monday, July 26th, 2004 4:04:46pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2.ss/home" at "Monday, July 26th, 2004 4:04:47pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test1-incremental.ss" at "Monday, July 26th, 2004 4:05:39pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test2-incremental.ss" at "Monday, July 26th, 2004 4:05:51pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test2.ss" at "Monday, July 26th, 2004 4:06:33pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test2.ss" at "Monday, July 26th, 2004 4:08:28pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test2-incremental.ss" at "Monday, July 26th, 2004 4:08:31pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test2-incremental-unitsig.ss" at "Monday, July 26th, 2004 4:12:27pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test2.ss" at "Monday, July 26th, 2004 4:15:09pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test2-incremental-unitsig.ss" at "Monday, July 26th, 2004 4:47:20pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test2-incremental-unitsig.ss" at "Monday, July 26th, 2004 4:47:45pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Monday, July 26th, 2004 4:53:47pm")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Monday, July 26th, 2004 4:53:47pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Monday, July 26th, 2004 4:53:48pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me.jpg" at "Monday, July 26th, 2004 4:53:48pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Monday, July 26th, 2004 4:53:48pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Monday, July 26th, 2004 4:53:48pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Monday, July 26th, 2004 4:53:48pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Monday, July 26th, 2004 4:53:48pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Monday, July 26th, 2004 4:53:48pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Monday, July 26th, 2004 4:53:48pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist/" at "Monday, July 26th, 2004 4:53:49pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Monday, July 26th, 2004 4:53:49pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist" at "Monday, July 26th, 2004 4:53:49pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Monday, July 26th, 2004 4:53:49pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2-incremental.ss/home" at "Monday, July 26th, 2004 4:53:49pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test1-incremental.ss" at "Monday, July 26th, 2004 4:53:58pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Monday, July 26th, 2004 4:54:12pm")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Monday, July 26th, 2004 4:54:12pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Monday, July 26th, 2004 4:54:12pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me.jpg" at "Monday, July 26th, 2004 4:54:12pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Monday, July 26th, 2004 4:54:12pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Monday, July 26th, 2004 4:54:12pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Monday, July 26th, 2004 4:54:12pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Monday, July 26th, 2004 4:54:12pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Monday, July 26th, 2004 4:54:12pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Monday, July 26th, 2004 4:54:12pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist/" at "Monday, July 26th, 2004 4:54:12pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Monday, July 26th, 2004 4:54:12pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist" at "Monday, July 26th, 2004 4:54:13pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Monday, July 26th, 2004 4:54:13pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2-incremental.ss/home" at "Monday, July 26th, 2004 4:54:13pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test1-incremental.ss" at "Monday, July 26th, 2004 4:54:22pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test8.ss/home?a=b&see=d" at "Monday, July 26th, 2004 4:54:27pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test7.ss/home" at "Monday, July 26th, 2004 4:54:27pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test6.ss?a=b&see=d" at "Monday, July 26th, 2004 4:54:28pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test5.ss/home?a=b&see=d" at "Monday, July 26th, 2004 4:54:29pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test4.ss?a=b&see=d" at "Monday, July 26th, 2004 4:54:30pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test3.ss" at "Monday, July 26th, 2004 4:54:31pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2.ss/home" at "Monday, July 26th, 2004 4:54:31pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Tuesday, July 27th, 2004 6:59:05pm")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Tuesday, July 27th, 2004 6:59:05pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Tuesday, July 27th, 2004 6:59:06pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me.jpg" at "Tuesday, July 27th, 2004 6:59:06pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Tuesday, July 27th, 2004 6:59:06pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Tuesday, July 27th, 2004 6:59:06pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Tuesday, July 27th, 2004 6:59:06pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Tuesday, July 27th, 2004 6:59:06pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Tuesday, July 27th, 2004 6:59:06pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Tuesday, July 27th, 2004 6:59:06pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist/" at "Tuesday, July 27th, 2004 6:59:07pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Tuesday, July 27th, 2004 6:59:07pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist" at "Tuesday, July 27th, 2004 6:59:07pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Tuesday, July 27th, 2004 6:59:07pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2-incremental.ss/home" at "Tuesday, July 27th, 2004 6:59:07pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test1-incremental.ss" at "Tuesday, July 27th, 2004 6:59:08pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test8.ss/home?a=b&see=d" at "Tuesday, July 27th, 2004 6:59:12pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test7.ss/home" at "Tuesday, July 27th, 2004 6:59:13pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test6.ss?a=b&see=d" at "Tuesday, July 27th, 2004 6:59:14pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test5.ss/home?a=b&see=d" at "Tuesday, July 27th, 2004 6:59:15pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test4.ss?a=b&see=d" at "Tuesday, July 27th, 2004 6:59:15pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test3.ss" at "Tuesday, July 27th, 2004 6:59:16pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2.ss/home" at "Tuesday, July 27th, 2004 6:59:16pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test2-incremental.ss" at "Tuesday, July 27th, 2004 7:04:30pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test2-incremental.ss/home" at "Tuesday, July 27th, 2004 7:04:50pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Tuesday, July 27th, 2004 7:20:06pm")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Tuesday, July 27th, 2004 7:20:07pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Tuesday, July 27th, 2004 7:20:07pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me.jpg" at "Tuesday, July 27th, 2004 7:20:07pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Tuesday, July 27th, 2004 7:20:07pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Tuesday, July 27th, 2004 7:20:07pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Tuesday, July 27th, 2004 7:20:07pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Tuesday, July 27th, 2004 7:20:07pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Tuesday, July 27th, 2004 7:20:07pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Tuesday, July 27th, 2004 7:20:07pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist/" at "Tuesday, July 27th, 2004 7:20:07pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Tuesday, July 27th, 2004 7:20:07pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist" at "Tuesday, July 27th, 2004 7:20:07pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Tuesday, July 27th, 2004 7:20:08pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2-incremental.ss/home" at "Tuesday, July 27th, 2004 7:20:08pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test1-incremental.ss" at "Tuesday, July 27th, 2004 7:20:16pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test8.ss/home?a=b&see=d" at "Tuesday, July 27th, 2004 7:20:21pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test7.ss/home" at "Tuesday, July 27th, 2004 7:20:22pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test6.ss?a=b&see=d" at "Tuesday, July 27th, 2004 7:20:22pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test5.ss/home?a=b&see=d" at "Tuesday, July 27th, 2004 7:20:23pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test4.ss?a=b&see=d" at "Tuesday, July 27th, 2004 7:20:24pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test3.ss" at "Tuesday, July 27th, 2004 7:20:24pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2.ss/home" at "Tuesday, July 27th, 2004 7:20:25pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Wednesday, July 28th, 2004 2:23:52pm")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Wednesday, July 28th, 2004 2:23:52pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Wednesday, July 28th, 2004 2:23:52pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me.jpg" at "Wednesday, July 28th, 2004 2:23:53pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Wednesday, July 28th, 2004 2:23:53pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Wednesday, July 28th, 2004 2:23:53pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Wednesday, July 28th, 2004 2:23:53pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Wednesday, July 28th, 2004 2:23:53pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Wednesday, July 28th, 2004 2:23:53pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Wednesday, July 28th, 2004 2:23:53pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist/" at "Wednesday, July 28th, 2004 2:23:53pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Wednesday, July 28th, 2004 2:23:53pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist" at "Wednesday, July 28th, 2004 2:23:53pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Wednesday, July 28th, 2004 2:23:53pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2-incremental.ss/home" at "Wednesday, July 28th, 2004 2:23:53pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test1-incremental.ss" at "Wednesday, July 28th, 2004 2:24:02pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test8.ss/home?a=b&see=d" at "Wednesday, July 28th, 2004 2:24:07pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test7.ss/home" at "Wednesday, July 28th, 2004 2:24:07pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test6.ss?a=b&see=d" at "Wednesday, July 28th, 2004 2:24:08pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test5.ss/home?a=b&see=d" at "Wednesday, July 28th, 2004 2:24:09pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test4.ss?a=b&see=d" at "Wednesday, July 28th, 2004 2:24:09pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test3.ss" at "Wednesday, July 28th, 2004 2:24:10pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2.ss/home" at "Wednesday, July 28th, 2004 2:24:10pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Wednesday, July 28th, 2004 3:20:41pm")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Wednesday, July 28th, 2004 3:20:41pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Wednesday, July 28th, 2004 3:20:41pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me.jpg" at "Wednesday, July 28th, 2004 3:20:41pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Wednesday, July 28th, 2004 3:20:41pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Wednesday, July 28th, 2004 3:20:41pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Wednesday, July 28th, 2004 3:20:41pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Wednesday, July 28th, 2004 3:20:41pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Wednesday, July 28th, 2004 3:20:41pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Wednesday, July 28th, 2004 3:20:41pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist/" at "Wednesday, July 28th, 2004 3:20:41pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Wednesday, July 28th, 2004 3:20:41pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist" at "Wednesday, July 28th, 2004 3:20:42pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Wednesday, July 28th, 2004 3:20:42pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2-incremental.ss/home" at "Wednesday, July 28th, 2004 3:20:42pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test1-incremental.ss" at "Wednesday, July 28th, 2004 3:20:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test8.ss/home?a=b&see=d" at "Wednesday, July 28th, 2004 3:20:56pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test7.ss/home" at "Wednesday, July 28th, 2004 3:20:57pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test6.ss?a=b&see=d" at "Wednesday, July 28th, 2004 3:20:58pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test5.ss/home?a=b&see=d" at "Wednesday, July 28th, 2004 3:20:58pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test4.ss?a=b&see=d" at "Wednesday, July 28th, 2004 3:20:59pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test3.ss" at "Wednesday, July 28th, 2004 3:21:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2.ss/home" at "Wednesday, July 28th, 2004 3:21:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Wednesday, August 11th, 2004 3:03:50pm")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Wednesday, August 11th, 2004 3:03:50pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Wednesday, August 11th, 2004 3:03:50pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me.jpg" at "Wednesday, August 11th, 2004 3:03:50pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Wednesday, August 11th, 2004 3:03:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Wednesday, August 11th, 2004 3:03:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Wednesday, August 11th, 2004 3:03:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Wednesday, August 11th, 2004 3:03:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Wednesday, August 11th, 2004 3:03:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Wednesday, August 11th, 2004 3:03:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist/" at "Wednesday, August 11th, 2004 3:03:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Wednesday, August 11th, 2004 3:03:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "does-not-exist" at "Wednesday, August 11th, 2004 3:03:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Wednesday, August 11th, 2004 3:03:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2-incremental.ss/home" at "Wednesday, August 11th, 2004 3:03:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test1-incremental.ss" at "Wednesday, August 11th, 2004 3:04:02pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test8.ss/home?a=b&see=d" at "Wednesday, August 11th, 2004 3:04:08pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test7.ss/home" at "Wednesday, August 11th, 2004 3:04:09pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test6.ss?a=b&see=d" at "Wednesday, August 11th, 2004 3:04:11pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test5.ss/home?a=b&see=d" at "Wednesday, August 11th, 2004 3:04:13pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test4.ss?a=b&see=d" at "Wednesday, August 11th, 2004 3:04:14pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test3.ss" at "Wednesday, August 11th, 2004 3:04:16pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2.ss/home" at "Wednesday, August 11th, 2004 3:04:18pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Friday, August 13th, 2004 10:55:05am")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Friday, August 13th, 2004 10:55:35am")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Friday, August 13th, 2004 10:56:06am")
+(from "127.0.0.1" to "127.0.0.1" for "/me.jpg" at "Friday, August 13th, 2004 10:56:36am")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Friday, August 13th, 2004 11:40:05am")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Friday, August 13th, 2004 11:40:35am")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Friday, August 13th, 2004 11:41:05am")
+(from "127.0.0.1" to "127.0.0.1" for "/me.jpg" at "Friday, August 13th, 2004 11:41:36am")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, August 13th, 2004 11:56:38am")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, August 13th, 2004 11:56:38am")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Friday, August 13th, 2004 11:56:38am")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Friday, August 13th, 2004 11:57:05am")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Friday, August 13th, 2004 11:57:36am")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Friday, August 13th, 2004 11:58:06am")
+(from "127.0.0.1" to "127.0.0.1" for "/me.jpg" at "Friday, August 13th, 2004 11:58:36am")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, August 13th, 2004 11:59:06am")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, August 13th, 2004 11:59:06am")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Friday, August 13th, 2004 11:59:06am")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Friday, August 13th, 2004 11:59:06am")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Friday, August 13th, 2004 11:59:06am")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Friday, August 13th, 2004 11:59:06am")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Friday, August 13th, 2004 11:59:06am")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Friday, August 13th, 2004 11:59:07am")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Friday, August 13th, 2004 11:59:07am")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Friday, August 13th, 2004 11:59:07am")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2-incremental.ss/home" at "Friday, August 13th, 2004 11:59:07am")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test1-incremental.ss" at "Friday, August 13th, 2004 11:59:07am")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test8.ss/home?a=b&see=d" at "Friday, August 13th, 2004 11:59:08am")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test7.ss/home" at "Friday, August 13th, 2004 11:59:08am")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test6.ss?a=b&see=d" at "Friday, August 13th, 2004 11:59:08am")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test5.ss/home?a=b&see=d" at "Friday, August 13th, 2004 11:59:09am")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test4.ss?a=b&see=d" at "Friday, August 13th, 2004 11:59:09am")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test3.ss" at "Friday, August 13th, 2004 11:59:10am")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2.ss/home" at "Friday, August 13th, 2004 11:59:11am")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Friday, August 13th, 2004 12:00:35pm")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Friday, August 13th, 2004 12:01:05pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Friday, August 13th, 2004 12:01:35pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me.jpg" at "Friday, August 13th, 2004 12:02:05pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, August 13th, 2004 12:02:35pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, August 13th, 2004 12:02:35pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Friday, August 13th, 2004 12:02:35pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Friday, August 13th, 2004 12:02:35pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Friday, August 13th, 2004 12:02:36pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Friday, August 13th, 2004 12:02:36pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Friday, August 13th, 2004 12:02:36pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Friday, August 13th, 2004 12:02:36pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Friday, August 13th, 2004 12:02:36pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Friday, August 13th, 2004 12:02:36pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2-incremental.ss/home" at "Friday, August 13th, 2004 12:02:36pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test1-incremental.ss" at "Friday, August 13th, 2004 12:02:36pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test8.ss/home?a=b&see=d" at "Friday, August 13th, 2004 12:02:37pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test7.ss/home" at "Friday, August 13th, 2004 12:02:37pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test6.ss?a=b&see=d" at "Friday, August 13th, 2004 12:02:37pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test5.ss/home?a=b&see=d" at "Friday, August 13th, 2004 12:02:38pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test4.ss?a=b&see=d" at "Friday, August 13th, 2004 12:02:38pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test3.ss" at "Friday, August 13th, 2004 12:02:39pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2.ss/home" at "Friday, August 13th, 2004 12:02:40pm")
+(from "129.10.114.109" to "129.10.117.166" for "/" at "Friday, August 13th, 2004 12:04:43pm")
+(from "129.10.114.109" to "129.10.117.166" for "/Defaults/documentation/web-server.gif" at "Friday, August 13th, 2004 12:04:43pm")
+(from "129.10.114.109" to "129.10.117.166" for "/Defaults/documentation/plt-logo.gif" at "Friday, August 13th, 2004 12:04:43pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/bad-require.ss" at "Friday, August 13th, 2004 12:04:55pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/bad-require.ss" at "Friday, August 13th, 2004 12:05:11pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/raise-exception.ss" at "Friday, August 13th, 2004 12:05:18pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/bad-require.ss" at "Friday, August 13th, 2004 12:05:25pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/raise-exception.ss" at "Friday, August 13th, 2004 12:05:30pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Friday, August 13th, 2004 12:12:00pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Friday, August 13th, 2004 12:12:00pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Friday, August 13th, 2004 12:12:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Friday, August 13th, 2004 12:12:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Friday, August 13th, 2004 12:12:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Friday, August 13th, 2004 12:12:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Friday, August 13th, 2004 12:12:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Friday, August 13th, 2004 12:12:47pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Friday, August 13th, 2004 12:12:48pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Friday, August 13th, 2004 12:12:48pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Friday, August 13th, 2004 12:12:48pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Friday, August 13th, 2004 12:12:48pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Friday, August 13th, 2004 12:12:48pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Friday, August 13th, 2004 12:12:48pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Friday, August 13th, 2004 12:13:55pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Friday, August 13th, 2004 12:13:55pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Friday, August 13th, 2004 12:13:55pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Friday, August 13th, 2004 12:13:55pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Friday, August 13th, 2004 12:13:55pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Friday, August 13th, 2004 12:13:55pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Friday, August 13th, 2004 12:13:55pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Friday, August 13th, 2004 1:19:30pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Friday, August 13th, 2004 1:19:31pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Friday, August 13th, 2004 1:20:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Friday, August 13th, 2004 1:20:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Friday, August 13th, 2004 1:20:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Friday, August 13th, 2004 1:20:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Friday, August 13th, 2004 1:20:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Friday, August 13th, 2004 1:25:18pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Friday, August 13th, 2004 1:25:18pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Friday, August 13th, 2004 1:26:57pm")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Friday, August 13th, 2004 1:27:27pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Friday, August 13th, 2004 1:27:57pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me.jpg" at "Friday, August 13th, 2004 1:28:28pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, August 13th, 2004 1:28:58pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, August 13th, 2004 1:28:58pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Friday, August 13th, 2004 1:28:58pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Friday, August 13th, 2004 1:28:59pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Friday, August 13th, 2004 1:29:29pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Friday, August 13th, 2004 1:31:29pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Friday, August 13th, 2004 1:31:29pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Friday, August 13th, 2004 1:31:29pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Friday, August 13th, 2004 1:31:29pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Friday, August 13th, 2004 1:31:29pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2-incremental.ss/home" at "Friday, August 13th, 2004 1:31:29pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test1-incremental.ss" at "Friday, August 13th, 2004 1:31:29pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test8.ss/home?a=b&see=d" at "Friday, August 13th, 2004 1:31:30pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test7.ss/home" at "Friday, August 13th, 2004 1:31:30pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test6.ss?a=b&see=d" at "Friday, August 13th, 2004 1:31:30pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test5.ss/home?a=b&see=d" at "Friday, August 13th, 2004 1:31:31pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test4.ss?a=b&see=d" at "Friday, August 13th, 2004 1:31:31pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test3.ss" at "Friday, August 13th, 2004 1:31:32pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2.ss/home" at "Friday, August 13th, 2004 1:31:33pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test1-incremental.ss" at "Friday, August 13th, 2004 1:32:56pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2-incremental.ss/home" at "Friday, August 13th, 2004 1:54:43pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test1-incremental.ss" at "Friday, August 13th, 2004 1:54:43pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test8.ss/home?a=b&see=d" at "Friday, August 13th, 2004 1:54:46pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test7.ss/home" at "Friday, August 13th, 2004 1:54:46pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test6.ss?a=b&see=d" at "Friday, August 13th, 2004 1:54:46pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test5.ss/home?a=b&see=d" at "Friday, August 13th, 2004 1:54:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test4.ss?a=b&see=d" at "Friday, August 13th, 2004 1:54:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test3.ss" at "Friday, August 13th, 2004 1:54:57pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test1-incremental.ss" at "Friday, August 13th, 2004 1:56:17pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test1-incremental.ss" at "Friday, August 13th, 2004 1:56:43pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test1-incremental.ss" at "Friday, August 13th, 2004 1:56:45pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test1-incremental.ss" at "Friday, August 13th, 2004 1:57:10pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test1-incremental.ss" at "Friday, August 13th, 2004 2:22:16pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test1-incremental.ss" at "Friday, August 13th, 2004 2:22:29pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2-incremental.ss/home" at "Friday, August 13th, 2004 2:23:37pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test1-incremental.ss" at "Friday, August 13th, 2004 2:23:37pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test8.ss/home?a=b&see=d" at "Friday, August 13th, 2004 2:25:37pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test7.ss/home" at "Friday, August 13th, 2004 2:25:37pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test6.ss?a=b&see=d" at "Friday, August 13th, 2004 2:25:37pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test5.ss/home?a=b&see=d" at "Friday, August 13th, 2004 2:25:39pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test4.ss?a=b&see=d" at "Friday, August 13th, 2004 2:25:39pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test3.ss" at "Friday, August 13th, 2004 2:25:41pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2.ss/home" at "Friday, August 13th, 2004 2:25:43pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2-incremental.ss/home" at "Friday, August 13th, 2004 2:26:34pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test1-incremental.ss" at "Friday, August 13th, 2004 2:26:34pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test2.ss" at "Friday, August 13th, 2004 2:27:37pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test2.ss" at "Friday, August 13th, 2004 2:33:32pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test2.ss" at "Friday, August 13th, 2004 2:45:33pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test2.ss" at "Friday, August 13th, 2004 2:52:00pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test2.ss" at "Friday, August 13th, 2004 2:53:32pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test2.ss" at "Friday, August 13th, 2004 2:54:08pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test2.ss" at "Friday, August 13th, 2004 2:55:56pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test2.ss" at "Friday, August 13th, 2004 2:57:12pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test2.ss" at "Friday, August 13th, 2004 2:59:25pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test2.ss" at "Friday, August 13th, 2004 3:07:19pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Friday, August 13th, 2004 3:07:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2-incremental.ss/home" at "Friday, August 13th, 2004 3:08:27pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test1-incremental.ss" at "Friday, August 13th, 2004 3:08:27pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Friday, August 13th, 2004 3:09:43pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test2-incremental.ss" at "Friday, August 13th, 2004 3:09:56pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test2-incremental.ss" at "Friday, August 13th, 2004 3:11:13pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Friday, August 13th, 2004 3:11:57pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2-incremental.ss/home" at "Friday, August 13th, 2004 3:12:30pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test1-incremental.ss" at "Friday, August 13th, 2004 3:12:30pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test2-incremental.ss/home" at "Friday, August 13th, 2004 3:13:44pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test2-incremental.ss" at "Friday, August 13th, 2004 3:13:52pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test2-incremental.ss/home" at "Friday, August 13th, 2004 3:14:09pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Friday, August 13th, 2004 3:16:56pm")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Friday, August 13th, 2004 3:17:26pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Friday, August 13th, 2004 3:17:57pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me.jpg" at "Friday, August 13th, 2004 3:18:27pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, August 13th, 2004 3:18:57pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, August 13th, 2004 3:18:57pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Friday, August 13th, 2004 3:18:57pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Friday, August 13th, 2004 3:18:57pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Friday, August 13th, 2004 3:19:27pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Friday, August 13th, 2004 3:21:27pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Friday, August 13th, 2004 3:21:27pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Friday, August 13th, 2004 3:21:27pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Friday, August 13th, 2004 3:21:27pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Friday, August 13th, 2004 3:21:28pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2-incremental.ss/home" at "Friday, August 13th, 2004 3:21:28pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test1-incremental.ss" at "Friday, August 13th, 2004 3:21:28pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test2-incremental.ss/home" at "Friday, August 13th, 2004 3:23:10pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test2-incremental.ss/home" at "Friday, August 13th, 2004 3:23:15pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test2-incremental.ss/home" at "Friday, August 13th, 2004 4:11:41pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Friday, August 13th, 2004 4:13:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Friday, August 13th, 2004 4:13:31pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Friday, August 13th, 2004 4:14:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me.jpg" at "Friday, August 13th, 2004 4:14:31pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, August 13th, 2004 4:15:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, August 13th, 2004 4:15:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Friday, August 13th, 2004 4:15:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Friday, August 13th, 2004 4:15:01pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Friday, August 13th, 2004 4:15:31pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Friday, August 13th, 2004 4:17:31pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Friday, August 13th, 2004 4:17:31pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Friday, August 13th, 2004 4:17:31pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Friday, August 13th, 2004 4:17:32pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Friday, August 13th, 2004 4:17:32pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2-incremental.ss/home" at "Friday, August 13th, 2004 4:17:32pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test1-incremental.ss" at "Friday, August 13th, 2004 4:19:32pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test2-incremental.ss/home" at "Friday, August 13th, 2004 4:21:20pm")
+(from "127.0.0.1" to "127.0.0.1" for "/" at "Friday, August 13th, 2004 4:22:50pm")
+(from "127.0.0.1" to "127.0.0.1" for "/index.html" at "Friday, August 13th, 2004 4:23:20pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me2.JPG" at "Friday, August 13th, 2004 4:23:50pm")
+(from "127.0.0.1" to "127.0.0.1" for "/me.jpg" at "Friday, August 13th, 2004 4:24:20pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, August 13th, 2004 4:24:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/index.html" at "Friday, August 13th, 2004 4:24:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "/secret/" at "Friday, August 13th, 2004 4:24:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/raise-exception.ss" at "Friday, August 13th, 2004 4:24:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/bad-require.ss" at "Friday, August 13th, 2004 4:25:21pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/does-not-exist" at "Friday, August 13th, 2004 4:25:52pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Friday, August 13th, 2004 4:25:52pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist/" at "Friday, August 13th, 2004 4:25:52pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Friday, August 13th, 2004 4:25:52pm")
+(from "127.0.0.1" to "127.0.0.1" for "/does-not-exist" at "Friday, August 13th, 2004 4:25:52pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2-incremental.ss/home" at "Friday, August 13th, 2004 4:25:52pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test1-incremental.ss" at "Friday, August 13th, 2004 4:27:52pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test8.ss/home?a=b&see=d" at "Friday, August 13th, 2004 4:29:52pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test7.ss/home" at "Friday, August 13th, 2004 4:29:54pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test6.ss?a=b&see=d" at "Friday, August 13th, 2004 4:31:54pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test5.ss/home?a=b&see=d" at "Friday, August 13th, 2004 4:31:56pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test4.ss?a=b&see=d" at "Friday, August 13th, 2004 4:31:58pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test3.ss" at "Friday, August 13th, 2004 4:32:00pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2.ss/home" at "Friday, August 13th, 2004 4:34:00pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2-incremental.ss/home" at "Friday, August 13th, 2004 4:46:41pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test1-incremental.ss" at "Friday, August 13th, 2004 4:48:41pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test8.ss/home?a=b&see=d" at "Friday, August 13th, 2004 4:50:41pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test7.ss/home" at "Friday, August 13th, 2004 4:50:41pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test6.ss?a=b&see=d" at "Friday, August 13th, 2004 4:52:41pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test5.ss/home?a=b&see=d" at "Friday, August 13th, 2004 4:52:42pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test4.ss?a=b&see=d" at "Friday, August 13th, 2004 4:52:42pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test3.ss" at "Friday, August 13th, 2004 4:52:42pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2.ss/home" at "Friday, August 13th, 2004 4:54:42pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test8.ss" at "Friday, August 13th, 2004 4:55:27pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test8.ss?a=b&see=d" at "Friday, August 13th, 2004 4:56:04pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test8.ss?a=b&see=d" at "Friday, August 13th, 2004 4:59:47pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test8.ss?a=b&see=d" at "Friday, August 13th, 2004 4:59:55pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test8.ss?a=b&see=d" at "Friday, August 13th, 2004 4:59:58pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test8.ss?a=b&see=d" at "Friday, August 13th, 2004 5:02:11pm")
+(from "129.10.114.109" to "129.10.117.166" for "/servlets/test8.ss?a=b&see=d" at "Friday, August 13th, 2004 5:02:38pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2-incremental.ss/home" at "Friday, August 13th, 2004 5:14:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test1-incremental.ss" at "Friday, August 13th, 2004 5:16:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test8.ss/home?a=b&see=d" at "Friday, August 13th, 2004 5:18:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test7.ss/home" at "Friday, August 13th, 2004 5:20:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test6.ss?a=b&see=d" at "Friday, August 13th, 2004 5:22:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test5.ss/home?a=b&see=d" at "Friday, August 13th, 2004 5:24:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test4.ss?a=b&see=d" at "Friday, August 13th, 2004 5:26:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test3.ss" at "Friday, August 13th, 2004 5:28:51pm")
+(from "127.0.0.1" to "127.0.0.1" for "/servlets/test2.ss/home" at "Friday, August 13th, 2004 5:30:51pm")
diff --git a/collects/tests/web-server/scheme-units/test-web-root/passwords b/collects/tests/web-server/scheme-units/test-web-root/passwords
new file mode 100644
index 0000000000..c6ca1020c9
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/test-web-root/passwords
@@ -0,0 +1 @@
+'(("secret stuff" "/secret(/.*)?" (bubba "bbq") (|Billy| "BoB")))
diff --git a/collects/tests/web-server/scheme-units/test-web-root/servlets/bad-require.ss b/collects/tests/web-server/scheme-units/test-web-root/servlets/bad-require.ss
new file mode 100644
index 0000000000..2b1f3e6ee8
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/test-web-root/servlets/bad-require.ss
@@ -0,0 +1,2 @@
+;; Try requiring a file that does not exist.
+(require "I-do-not-exist.ss")
diff --git a/collects/tests/web-server/scheme-units/test-web-root/servlets/raise-exception.ss b/collects/tests/web-server/scheme-units/test-web-root/servlets/raise-exception.ss
new file mode 100644
index 0000000000..898b0a602f
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/test-web-root/servlets/raise-exception.ss
@@ -0,0 +1,2 @@
+;; Raise an exception
+(raise 'ka-boom!)
diff --git a/collects/tests/web-server/scheme-units/test-web-root/servlets/test1-incremental.ss b/collects/tests/web-server/scheme-units/test-web-root/servlets/test1-incremental.ss
new file mode 100644
index 0000000000..e74fe22ae1
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/test-web-root/servlets/test1-incremental.ss
@@ -0,0 +1,21 @@
+;; Incremental servlet with no arguments on the URL, in text/html, no URL
+;; path.
+(module test1-incremental mzscheme
+  (require (lib "servlet.ss" "web-server")
+           )
+
+  (provide start timeout interface-version)
+
+  (define timeout 1)
+  (define interface-version 'v1)
+
+  (define (start req)
+    (send/finish
+      (make-html-response/incremental
+        (lambda (output-chunk)
+          (output-chunk "<html><head><title>")
+          (output-chunk "Title")
+          (sleep 4)
+          (output-chunk "</title></head></html>")))))
+  )
+
diff --git a/collects/tests/web-server/scheme-units/test-web-root/servlets/test1.ss b/collects/tests/web-server/scheme-units/test-web-root/servlets/test1.ss
new file mode 100644
index 0000000000..a72a6bc9b1
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/test-web-root/servlets/test1.ss
@@ -0,0 +1,17 @@
+;; Non-incremental servlet with no arguments on the URL, in text/html, no URL
+;; path.
+(module test1 mzscheme
+  (require (lib "servlet.ss" "web-server")
+           )
+
+  (provide start timeout interface-version)
+
+  (define timeout 1)
+  (define interface-version 'v1)
+
+  (define (start req)
+    (send/finish
+      '(html
+         (head
+           (title "Title")))))
+  )
diff --git a/collects/tests/web-server/scheme-units/test-web-root/servlets/test2-incremental-unitsig.ss b/collects/tests/web-server/scheme-units/test-web-root/servlets/test2-incremental-unitsig.ss
new file mode 100644
index 0000000000..2f567945c3
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/test-web-root/servlets/test2-incremental-unitsig.ss
@@ -0,0 +1,21 @@
+;; Incremental servlet with no arguments on the URL, in text/html, with URL
+;; path.
+(require (lib "unitsig.ss")
+         (lib "servlet-sig.ss" "web-server")
+         )
+(unit/sig ()
+  (import servlet^)
+(let ((cd (path->string (current-directory))))
+  (send/finish
+    (make-html-response/incremental
+      (lambda (output-chunked)
+        (output-chunked "<html><head><title>")
+        (output-chunked "Title")
+        (sleep 1)
+        (output-chunked "</title></head><body><h1>Title</h1>")
+        (output-chunked "<p>Current path: ")
+        (sleep 1)
+        (output-chunked cd)
+        (output-chunked "</p></body></html>")))))
+  )
+
diff --git a/collects/tests/web-server/scheme-units/test-web-root/servlets/test2-incremental.ss b/collects/tests/web-server/scheme-units/test-web-root/servlets/test2-incremental.ss
new file mode 100644
index 0000000000..ce8fc6c163
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/test-web-root/servlets/test2-incremental.ss
@@ -0,0 +1,24 @@
+;; Incremental servlet with no arguments on the URL, in text/html, with URL
+;; path.
+(module test2-incremental mzscheme
+  (require (lib "servlet.ss" "web-server")
+           )
+
+  (provide start timeout interface-version)
+
+  (define timeout 1)
+  (define interface-version 'v1)
+
+  (define (start req)
+    (send/finish
+      (make-html-response/incremental
+        (lambda (output-chunked)
+          (output-chunked "<html><head><title>")
+          (output-chunked "Title")
+          (sleep 4)
+          (output-chunked "</title></head><body><h1>Title</h1>")
+          (output-chunked "<p>Current path: ")
+          (sleep 4)
+          (output-chunked (path->string (current-directory)))
+          (output-chunked "</p></body></html>")))))
+  )
diff --git a/collects/tests/web-server/scheme-units/test-web-root/servlets/test2.ss b/collects/tests/web-server/scheme-units/test-web-root/servlets/test2.ss
new file mode 100644
index 0000000000..ee1ea3042d
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/test-web-root/servlets/test2.ss
@@ -0,0 +1,20 @@
+;; Non-incremental servlet with no arguments on the URL, in text/html, with URL
+;; path.
+(module test2 mzscheme
+  (require (lib "servlet.ss" "web-server")
+           )
+
+  (provide start timeout interface-version)
+
+  (define timeout 1)
+  (define interface-version 'v1)
+
+  (define (start req)
+    (send/finish
+      `(html
+         (head
+           (title "Title"))
+         (body
+           (h1 "Title")
+           (p "Current path: " ,(path->string (current-directory)))))))
+  )
diff --git a/collects/tests/web-server/scheme-units/test-web-root/servlets/test3.ss b/collects/tests/web-server/scheme-units/test-web-root/servlets/test3.ss
new file mode 100644
index 0000000000..7742c7f477
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/test-web-root/servlets/test3.ss
@@ -0,0 +1,16 @@
+;; Non-incremental servlet with no arguments on the URL, in text/plain, no URL
+;; path.
+(module test3 mzscheme
+  (require (lib "servlet.ss" "web-server")
+           )
+
+  (provide start timeout interface-version)
+
+  (define timeout 1)
+  (define interface-version 'v1)
+
+  (define (start req)
+    (send/finish
+      '("text/plain"
+        "blah blah plain text")))
+  )
diff --git a/collects/tests/web-server/scheme-units/test-web-root/servlets/test4-incremental.ss b/collects/tests/web-server/scheme-units/test-web-root/servlets/test4-incremental.ss
new file mode 100644
index 0000000000..e69de29bb2
diff --git a/collects/tests/web-server/scheme-units/test-web-root/servlets/test4.ss b/collects/tests/web-server/scheme-units/test-web-root/servlets/test4.ss
new file mode 100644
index 0000000000..8700274b7c
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/test-web-root/servlets/test4.ss
@@ -0,0 +1,23 @@
+;; Non-incremental servlet with arguments on the URL, in text/html, no URL
+;; path.
+(module test4 mzscheme
+  (require (lib "servlet.ss" "web-server")
+           )
+
+  (provide start timeout interface-version)
+
+  (define timeout 1)
+  (define interface-version 'v1)
+
+  (define (start req)
+    (send/finish
+      `(html
+         (head
+           (title "Title"))
+         (body
+           (h1 "Title")
+           ,@(map
+               (lambda (binding)
+                 (list 'p (symbol->string (car binding)) (cdr binding)))
+               (request-bindings req))))))
+  )
diff --git a/collects/tests/web-server/scheme-units/test-web-root/servlets/test5.ss b/collects/tests/web-server/scheme-units/test-web-root/servlets/test5.ss
new file mode 100644
index 0000000000..a2a4313647
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/test-web-root/servlets/test5.ss
@@ -0,0 +1,24 @@
+;; Non-incremental servlet with arguments on the URL, in text/html, with URL
+;; path.
+(module test5 mzscheme
+  (require (lib "servlet.ss" "web-server")
+           )
+
+  (provide start timeout interface-version)
+
+  (define timeout 1)
+  (define interface-version 'v1)
+
+  (define (start req)
+    (send/finish
+      `(html
+         (head
+           (title "Title"))
+         (body
+           (h1 "Title")
+           ,@(map
+               (lambda (binding)
+                 (list 'p (symbol->string (car binding)) (cdr binding)))
+               (request-bindings req))
+           (p "Current path: " ,(path->string (current-directory)))))))
+  )
diff --git a/collects/tests/web-server/scheme-units/test-web-root/servlets/test6.ss b/collects/tests/web-server/scheme-units/test-web-root/servlets/test6.ss
new file mode 100644
index 0000000000..398135a6ad
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/test-web-root/servlets/test6.ss
@@ -0,0 +1,19 @@
+;; Non-incremental servlet with arguments on the URL, in text/plain, no URL
+;; path.
+(module test6 mzscheme
+  (require (lib "servlet.ss" "web-server")
+           )
+
+  (provide start timeout interface-version)
+
+  (define timeout 1)
+  (define interface-version 'v1)
+
+  (define (start req)
+    (send/finish
+      (cons "text/plain"
+            (map
+              (lambda (binding)
+                (string-append (symbol->string (car binding)) (cdr binding)))
+              (request-bindings req)))))
+  )
diff --git a/collects/tests/web-server/scheme-units/test-web-root/servlets/test7.ss b/collects/tests/web-server/scheme-units/test-web-root/servlets/test7.ss
new file mode 100644
index 0000000000..e94f6cbbcc
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/test-web-root/servlets/test7.ss
@@ -0,0 +1,16 @@
+;; Non-incremental servlet no arguments on the URL, in text/plain, with URL
+;; path.
+(module test7 mzscheme
+  (require (lib "servlet.ss" "web-server")
+           )
+
+  (provide start timeout interface-version)
+
+  (define timeout 1)
+  (define interface-version 'v1)
+
+  (define (start req)
+    (send/finish
+      (list "text/plain"
+            (path->string (current-directory)))))
+  )
diff --git a/collects/tests/web-server/scheme-units/test-web-root/servlets/test8.ss b/collects/tests/web-server/scheme-units/test-web-root/servlets/test8.ss
new file mode 100644
index 0000000000..63a25efb6a
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/test-web-root/servlets/test8.ss
@@ -0,0 +1,21 @@
+;; Non-incremental servlet with arguments on the URL, in text/plain, with URL
+;; path.
+(module test8 mzscheme
+  (require (lib "servlet.ss" "web-server")
+           )
+
+  (provide start timeout interface-version)
+
+  (define timeout 1)
+  (define interface-version 'v1)
+
+  (define (start req)
+    (send/finish
+      (cons "text/plain"
+            (cons
+              (path->string (current-directory))
+              (map
+                (lambda (binding)
+                  (string-append (symbol->string (car binding)) (cdr binding)))
+                (request-bindings req))))))
+  )
diff --git a/collects/tests/web-server/scheme-units/test-web-server-process.ss b/collects/tests/web-server/scheme-units/test-web-server-process.ss
new file mode 100644
index 0000000000..5253bc9b20
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/test-web-server-process.ss
@@ -0,0 +1,40 @@
+;; Mike Burns, July 28th, 2004, netgeek@speakeasy.net
+;; Test if the Web server can start and stop via the command line.
+;; Not sure if this is needed, but it was in Paul's.
+(module test-web-server-process mzscheme
+  (require (lib "test.ss" "schemeunit")
+           (lib "process.ss"))
+
+  (provide test-web-server-process)
+
+  (define the-configuration-file "configuration-table")
+
+  (define the-port 8135)
+
+  ;;; TODO resurrect
+  (define test-web-server-process
+    (make-test-suite
+      "Start and stop the Web server via the command line"
+        ;; Start it
+        (let-values (((mz-subprocess mz-out mz-in mz-err)
+                      (subprocess #f #f #f
+                                  (find-executable-path "web-server" #f)
+                                  "-p" (number->string the-port)
+                                  "-f" the-configuration-file)))
+          (sleep 5)
+          (make-test-case
+            "Start the Web server on a port with a configuration file"
+            ;; Test it
+            (and (assert-eq? 'running (subprocess-status mz-subprocess))
+                 (assert-false (char-ready? mz-err)))
+            ;; Kill it
+            (let ((pid (subprocess-pid mz-subprocess))
+                  (kill-path (find-executable-path "kill" #f)))
+              (unless (or (zero? pid) (not kill-path))
+                (let-values (((kill-subprocess kill-out kill-in kill-err)
+                              (subprocess #f #f #f kill-path (number->string pid))))
+                  (close-input-port kill-out)
+                  (close-output-port kill-in)
+                  (close-input-port kill-err)
+                  (subprocess-wait kill-subprocess))))))))
+  )
diff --git a/collects/tests/web-server/scheme-units/test-web-server.ss b/collects/tests/web-server/scheme-units/test-web-server.ss
new file mode 100644
index 0000000000..02449b36fc
--- /dev/null
+++ b/collects/tests/web-server/scheme-units/test-web-server.ss
@@ -0,0 +1,46 @@
+;; Mike Burns, July 26th, 2004, netgeek@speakeasy.net
+;; Test the ability to start and stop the server via the library.
+(module test-web-server mzscheme
+  (require (lib "web-server.ss" "web-server")
+           (lib "configuration.ss" "web-server")
+           (lib "test.ss" "schemeunit")
+           (lib "etc.ss"))
+
+  (provide test-web-server)
+
+  (define the-configuration
+    ;;; TODO: test load-configuration
+    (load-configuration (expand-path "configuration-table")))
+
+  (define the-port 8135)
+  
+  (define the-ip "127.0.0.1")
+
+  (define test-web-server
+    (make-test-suite
+      "Start and stop the Web server from the library"
+      (let ((stop #f))
+        (make-test-case
+          "Start the Web server with just the configuration"
+          (assert-pred procedure? (begin
+                                    (set! stop (serve the-configuration))
+                                    stop))
+          (when stop (stop))))
+      (let ((stop #f))
+        (make-test-case
+          "Start the Web server with the configuration and port"
+          (assert-pred procedure? (begin
+                                    (set! stop (serve the-configuration
+                                                      the-port))
+                                    stop))
+          (when stop (stop))))
+      (let ((stop #f))
+        (make-test-case
+          "Start the Web server with the configuration, port, and IP address"
+          (assert-pred procedure? (begin
+                                    (set! stop (serve the-configuration
+                                                      the-port the-ip))
+                                    stop))
+          (when stop (stop))))))
+
+  )
diff --git a/collects/tests/web-server/sclient.ss b/collects/tests/web-server/sclient.ss
new file mode 100644
index 0000000000..6666c3cec0
--- /dev/null
+++ b/collects/tests/web-server/sclient.ss
@@ -0,0 +1,110 @@
+; copyright 11/29/2001 A.D. by Paul Graunke and the PLT
+; This is a rip-off---err---port of the Rice systems group's sclient 2.0 software
+; by gaurav, peter, and gang.
+; The TCP/IP stuff isn't as finely controlled, so it's my fault if it stinks.
+(module sclient mzscheme
+  (require (lib "etc.ss"))
+  
+  ; old-state = 'nothing | 'waiting | 'reading | 'writing
+  
+  ; old-client = (make-client iport oport state nat nat nat nat nat)
+  ;(define-struct
+  ; old-client
+  ; (in out state bytes-read partial-req-written num-reqs-done timestamp start-time))
+  
+  ; client = (make-client nat^4)
+  (define-struct client (bytes-read num-reqs-done timestamp start-time))
+  
+  ; why 6Mb? - it isn't used in the original either
+  ;(define PERCONBUFSIZE (* 6 1000 1000))
+  
+  ; FIX? - see about eliminating mutation
+  (define *start-time* 0)
+  (define *last-connect* 0)
+  
+  ; main : str str nat nat nat nat nat -> ???
+  (define (main host-machine target-file port reps num-clients rate cpu-mhz)
+    (let* ([request-string (build-http-request target-file)]
+           [request-length (string-length request-string)]
+           [cycles-per-request (* cpu-mhz (/ 1000000 rate))]
+           [max-connect-cycles (* 50000 cpu-mhz)])
+      (printf "A request will be issued every: ~a cycles i.e. every ~a us\n"
+              cycles-per-request (/ cycles-per-request cpu-mhz))
+      ;(init-clients host-machine port) ; just did DNS lookup in original
+      (set! *start-time* (current-milliseconds))
+      (let* ([all-clients-threads
+              (build-list num-clients
+                          (lambda (i) (simple-connect host-machine port request-string)))]
+             [all-clients (map car all-clients-threads)]
+             [all-threads (map cdr all-clients-threads)])
+        (for-each thread-wait all-threads)
+        ; print-stats
+        (let* ([diff-time0 (- (current-milliseconds) *start-time*)]
+               [diff-time (if (zero? diff-time0) 1 diff-time0)]
+               [diff-seconds (/ diff-time 1e6)]
+               [total-bytes-read (apply + (map client-bytes-read all-clients))]
+               [reqs-done (apply + (map client-num-reqs-done all-clients))]
+               [reps-done reqs-done] ; FIX?
+               [n-diff-samples reqs-done] ; FIX?
+               ;[diff-sum (apply + '(...))] FIX!
+               [diff-sum -inf.0]
+               [speed (* 8.0 (/ total-bytes-read diff-time))])
+          ; the original was in micro seconds
+          (printf "Elapsed time: ~a milliseconds\n" diff-time)
+          (printf "reps done: ~a\n" reps-done)
+          (printf "request rate: ~a\n"
+                  (/ reqs-done diff-seconds))
+          (printf "[ ~a Mb/s, ~a ~a S, ~a B, ~a R, ~a cl, pt ~a ~a c/s]\n"
+                  speed target-file diff-seconds total-bytes-read
+                  reps-done num-clients port
+                  (/ reps-done diff-seconds))
+          (printf "average response time: ~a us\n"
+                  (exact->inexact (/ diff-sum n-diff-samples)))
+          (printf "maximum number of pseudo clients: ~a\n" num-clients)))))
+  
+  ; build-http-request : str -> str
+  (define (build-http-request host-name)
+    ; This was clearly broken in the original:
+    ;"GET http://fxp2.cs.rice.edu:8080/%s HTTP/1.0\r\n"
+    (string-append "GET /" host-name" HTTP/1.0\r\n"
+                   "Accept: text/plain\r\n"
+                   "Accept: text/html\r\n"
+                   "Accept: */*\r\n"))
+  
+  ; simple-connect : str nat str -> (cons client thread)
+  ; original - this took two unused arguments and banged its result into a vector
+  ; FIX? - should it report statistics when exceptions occur?
+  (define (simple-connect host-name port request)
+    (let* ([start-time (current-milliseconds)]
+           [client (make-client 0 0 start-time start-time)])
+      (cons client
+            (thread
+             (lambda ()
+               (let connect ()
+                 (let-values ([(in out) (tcp-connect host-name port)])
+                   (set! *last-connect* (current-milliseconds))
+                   ; FIX? - Gaurav's paper said something about not filling the server's
+                   ; TCP/IP queue with waiting clients.  It sounds like this needs a
+                   ; timeout of a little more than twice the expected round trip delay
+                   ; or whatever.
+                   (send-http in out client request)
+                   (read-from-connection in out client)
+                   ; FIX? - do something like deadline-passed, perhaps?
+                   (set-client-num-reqs-done! client (add1 (client-num-reqs-done client))))
+                 (connect)))))))
+  
+  ; send-http : iport oport client str -> void
+  ; The original did all sorts of funny stuff for asynchronous I/O.
+  (define (send-http in out client request)
+    (display request out))
+  
+  (define read-increments (* 8 1024))
+  (define *singe-read-buffer* (make-string read-increments #\space))
+  
+  ; read-from-connection : iport oport client -> void
+  (define (read-from-connection in out client)
+    (let read-all ()
+      (let ([x (read-string-avail! *singe-read-buffer* in)])
+        (unless (eof-object? x)
+          (set-client-bytes-read! client (+ x (client-bytes-read client)))
+          (read-all))))))
\ No newline at end of file
diff --git a/collects/tests/web-server/servlets/color2.ss b/collects/tests/web-server/servlets/color2.ss
new file mode 100644
index 0000000000..5fe859b91d
--- /dev/null
+++ b/collects/tests/web-server/servlets/color2.ss
@@ -0,0 +1,23 @@
+; needs first defined (i.e. use a teaching langauge)
+; needs the servlet.ss teachpack
+
+(require (lib "etc.ss"))
+
+; : sym -> str
+; to input an opinion about a color
+(define (color the-color)
+  (extract-binding/single 
+   'color 
+   (request-bindings
+    (send/suspend 
+     (build-suspender '("hi") 
+                      `((p ,(format
+                             "What do you think about the color ~a?" 
+                             the-color))
+                        (input ([type "text"] [name "color"]))))))))
+
+(define blue (color (identity (first (list 'blue)))))
+(define green (color 'green))
+
+(send/finish `(html (body (p "Thoughts about blue: " ,blue)
+                          (p "What you wrote about green: " ,green))))
diff --git a/collects/tests/web-server/servlets/dir-tp.ss b/collects/tests/web-server/servlets/dir-tp.ss
new file mode 100644
index 0000000000..6e3b572d3e
--- /dev/null
+++ b/collects/tests/web-server/servlets/dir-tp.ss
@@ -0,0 +1,6 @@
+; requires empty (from a teaching language)
+; requires servlet2.ss and dir.ss teachpacks
+
+(define my-dir (make-dir "a-fake-dir-name" empty empty))
+
+(final-page (dir-name my-dir))
\ No newline at end of file
diff --git a/collects/tests/web-server/servlets/s1.ss b/collects/tests/web-server/servlets/s1.ss
new file mode 100644
index 0000000000..d4f228e407
--- /dev/null
+++ b/collects/tests/web-server/servlets/s1.ss
@@ -0,0 +1,21 @@
+; expects the servlet.ss teachpack 
+; works in any language above beginner  (including beginner with qq)
+
+; : sym -> str
+; to input an opinion about a color
+(define (color the-color)
+  (extract-binding/single 
+   'color 
+   (request-bindings
+    (send/suspend 
+     (build-suspender '("hi") 
+                      `((p ,(format
+                             "What do you think about the color ~a?" 
+                             the-color))
+                        (input ([type "text"] [name "color"]))))))))
+
+(define blue (color 'navy))
+(define green (color 'green))
+
+(send/finish `(html (body (p "Thoughts about blue: " ,blue)
+                          (p "What you wrote about green: " ,green))))
diff --git a/collects/tests/web-server/servlets/sparrow.ss b/collects/tests/web-server/servlets/sparrow.ss
new file mode 100644
index 0000000000..42935d1072
--- /dev/null
+++ b/collects/tests/web-server/servlets/sparrow.ss
@@ -0,0 +1,13 @@
+(define (pass) (final-page "You may pass."))
+
+(define name (single-query "What is your name?"))
+(define quest (single-query "What is your quest?"))
+
+(if (string-ci=? name "Matthias")
+    (let ([v (string->number (single-query "What is the terminal velocity of a sparrow?"))])
+      (if (and v (= v 5))
+          (pass)
+          (final-page "Study sparrows more.")))
+    (begin 
+      (single-query "What is your favorite color?")
+      (pass)))
diff --git a/collects/tests/web-server/suite.ss b/collects/tests/web-server/suite.ss
new file mode 100644
index 0000000000..2428c3f246
--- /dev/null
+++ b/collects/tests/web-server/suite.ss
@@ -0,0 +1,445 @@
+; HOW TO RUN:
+; Call broken? with a port number (greater than 1024 unless you're root)
+; i.e. (broken? 8080)
+; It should return #f if it's not broken, otherwise it returns a string explaining the brokenness.
+
+; note - should be run on multiple platforms
+
+; more-here - test flushing pending requests to a terminated servlet
+
+(module suite mzscheme
+  (provide broken? broken?/remote start-server files-broken? authentication-broken?
+           normal-servlets-broken? errors-broken?)
+  (require (lib "process.ss")
+           (lib "etc.ss")
+           "my-url.ss"
+           (lib "base64.ss" "net")
+           (lib "xml.ss" "xml")
+           (lib "channel.ss" "web-server"))
+
+  (define myprint void)
+  
+  ; header-pattern = (listof (cons sym (+ regexp str)))
+  
+  (error-print-width 800)
+  
+  (define test-directory (build-path (collection-path "tests") "web-server"))
+  (define web-root (build-path test-directory "web-root"))
+  ;(define web-root (collection-path "web-server" "default-web-root"))
+  (define answers-directory (build-path test-directory "answers"))
+  (define TEST-IP "127.0.0.1")
+  
+  (print-struct #t)
+
+  ;; broken?/remote: nat -> (union falses str)
+  ;; same as broken? but connect to a running web-server
+  ;; rather than starting a new one
+  (define (broken?/remote port)
+    (or (files-broken? port)
+        (authentication-broken? port)
+        (normal-servlets-broken? port)
+        (extended-servlets-broken? port)
+        (errors-broken? port)
+        (timeouts-broken? port)))
+  
+  ; broken? : nat -> (+ false str)
+  ;; the cadilac broken? function, starts the server automatically.
+  (define (broken? port)
+    (or (channels-broken?)
+        (let ([server (start-server port)])
+	  (dynamic-wind
+	      void
+	      (lambda ()
+		(or (and (not (subprocess? server)) server)
+		    (files-broken? port)
+		    (authentication-broken? port)
+                    (normal-servlets-broken? port)
+		    (extended-servlets-broken? port)
+		    (errors-broken? port)
+		    (timeouts-broken? port)))
+	      (lambda () (kill-subprocess server))))))
+
+  ; channels-broken? : -> (U str #f)
+  ; more here - stress test for synchronization defects
+  (define (channels-broken?)
+    (let ([c (make-async-channel)]
+          [v (gensym)])
+      (async-channel-put c v)
+      (if (eq? v (async-channel-get c))
+          (or (let ([*x* #f])
+                (async-channel-get-available
+                 c
+                 (lambda (y) (set! *x* "channel: not empty")))
+                *x*)
+              (let ([*x* "channel: nothing available"])
+                (async-channel-put c v)
+                (async-channel-get-available c (lambda (y) (set! *x* #f)))
+                *x*)
+              (let/ec k
+                (async-channel-try-get c (lambda () (k #f)))
+                "channel: removed item from empty channel")
+              (let/ec k
+                (let ([x (gensym)])
+                  (async-channel-put c x)
+                  (async-channel-try-get
+                   c
+                   (lambda () (k "channel: fail to remove x")))
+                  #f)))
+          "channel: put/get mismatch")))
+  
+  ; start-server : nat -> (U str subprocess)
+  (define (start-server port)
+    (let-values ([(mz-subprocess mz-out mz-in mz-err)
+                  (subprocess #f #f #f
+                              (find-executable-path "web-server" #f)
+                              "-p" (number->string port)
+                              "-f" (path->string (build-path test-directory "configuration-table")) )])
+      (sleep 5)
+      (if (not (eq? 'running (subprocess-status mz-subprocess)))
+          (format "server mzscheme isn't running:~n~s"
+                  ; just print the first 20 lines of junk or so
+                  (read-string 1600 mz-err))
+          (if (char-ready? mz-err)
+              (format "server printed error: ~s" (read-line mz-err))
+              mz-subprocess))))
+  
+  ; kill-subprocess : subprocess -> void
+  (define (kill-subprocess p)
+    (let ([pid (subprocess-pid p)]
+          [kill-path (find-executable-path "kill" #f)])
+      (unless (or (zero? pid) (not kill-path))
+        (let-values ([(kill-subprocess out in err)
+                      (subprocess #f #f #f kill-path (number->string pid))])
+          (close-input-port out)
+          (close-output-port in)
+          (close-input-port err)
+          (subprocess-wait kill-subprocess)))))
+  
+  ; wont-start? : nat -> (+ false str)
+  ; effect: tries to start the server
+  '(define (wont-start? port)
+     (with-handlers ([void (lambda (exn) (format "start-server: exn = ~a" exn))])
+       (let*-values ([(mz-subprocess mz-out mz-in mz-err)
+                      (subprocess #f #f #f
+                                  (find-executable-path "web-server" #f)
+                                  "-p" (number->string port))]
+                     [(send-command)
+                      ; String -> Void
+                      (lambda (command)
+                        (write command mz-in)
+                        (newline mz-in))])
+         ;(send-command `(current-directory ,web-root))
+         (send-command `(serve ,port))
+         (sleep 5)
+         (if (not (eq? 'running (subprocess-status mz-subprocess)))
+             (format "server mzscheme isn't running:~n~s"
+                     ; just print the first 20 lines of junk or so
+                     (read-string 1600 mz-err))
+             (if (char-ready? mz-err)
+                 (format "server printed error: ~s" (read-line mz-err))
+                 #f)))))
+  
+  (define date-regexp "^(Sun|Mon|Tue|Wed|Thu|Fri|Sat), [0-9]* (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec) [0-9]* [0-9][0-9]:[0-9][0-9]:[0-9][0-9] GMT$")
+  
+  (define usual-headers
+    `((date ,date-regexp)
+      (Last-Modified ,date-regexp)
+      (server "^PLT Scheme$")
+      (content-type "^text/html$")
+      (connection "^close$")))
+  
+  (define jpeg-headers
+    `((date ,date-regexp)
+      (Last-Modified ,date-regexp)
+      (server "^PLT Scheme$")
+      (content-type "^image/jpeg$")
+      (connection "^close$")))
+ 
+  ; content-length-header : str -> (list sym str)
+  (define (content-length-header file-path)
+    (myprint "   file-path = ~s~n" file-path)
+    `(content-length ,(format "^~a$" (file-size file-path))))
+  
+  ; files-broken? : nat -> (+ false string)
+  (define (files-broken? port)
+    (myprint "files-broken?~n")
+    (with-handlers ([void (lambda (exn) (format "test-files: error starting up ~a" exn))])
+      (let* ([file-path (build-path web-root "htdocs" "index.html")]
+	     [implicit-url (local-url port "")]
+	     [explicit-url (combine-url/relative implicit-url "index.html")]
+	     [pattern (append usual-headers (list (content-length-header file-path)))]
+
+             ;; jpeg tests
+             ;; for PR#6302
+             [picture1-path (build-path web-root "htdocs" "me.jpg")]
+             [picture1-url (combine-url/relative implicit-url "me.jpg")]
+             [picture1-pattern (append jpeg-headers (list (content-length-header picture1-path)))]
+             
+             ;; reproduces PR#6302 b-cuz me2.JPG has upper-case extension
+             [picture2-path (build-path web-root "htdocs" "me2.JPG")]
+             [picture2-url (combine-url/relative implicit-url "me2.JPG")]
+             [picture2-pattern (append jpeg-headers (list (content-length-header picture2-path)))]
+             )
+	(or (problem-with-url? file-path pattern explicit-url)
+	    (problem-with-url? file-path pattern implicit-url)
+            (problem-with-url? picture1-path picture1-pattern picture1-url)
+            (problem-with-url? picture2-path picture2-pattern picture2-url)
+            ))))
+  
+  ; problem-with-url? : str header-pattern url [(listof str)] -> (U false str)
+  (define problem-with-url?
+    (opt-lambda (file-path header-match url [extra-headers null])
+      (delimit-resources
+       (lambda ()
+	 (with-handlers ([void (lambda (exn) (format "test-url: url = ~a~n  ~a~n" url exn))])
+	   (call-with-input-file file-path
+	     (lambda (file-input)
+	       (let* ([http-port (get-impure-port url extra-headers)]
+		      [headers (purify-port http-port)])
+		 (error-add (format "problem-with-url: ~s: " (url->string url))
+                            (or (mime-headers-problem? headers header-match)
+                                (input-port-diff http-port file-input)))))))))))
+  
+  (define (print-port i-port)
+    (printf "inside print-port~n")
+    (let loop ([l (read-line i-port)])
+      (unless (eof-object? l)
+        (printf "~a~n" l)
+        (loop (read-line i-port)))))
+  
+  ; : url header-pattern regexp -> (U false str)
+  (define (broken-url-regexp? to-test header-match expected)
+    (delimit-resources
+     (lambda ()
+       (with-handlers ([void (lambda (exn) (format "exception for url ~e~n~e" to-test exn))])
+         (let* ([http-port (get-impure-port to-test)]
+                [headers (purify-port http-port)])
+           (error-add (format "url did not match: ~e: " (url->string to-test))
+                      (or (mime-headers-problem? headers header-match)
+                          (regexp-match expected http-port))))))))
+  
+  ; delimit-resources : (-> a) -> a
+  (define (delimit-resources thunk)
+    (let ([cust (make-custodian)]
+	  [old-cust (current-custodian)])
+      (dynamic-wind (lambda () (current-custodian cust))
+		    thunk
+		    (lambda ()
+		      (current-custodian old-cust)
+		      (custodian-shutdown-all cust)))))
+  
+  ; authentication-broken? : nat -> (+ false str)
+  (define (authentication-broken? port)
+    (myprint "authentication-broken?~n")
+    (let* ([forbidden-file-path (build-path web-root "conf" "forbidden.html")]
+	   [okay-file-path (build-path web-root "htdocs" "secret" "index.html")]
+	   [forbidden-content-length (content-length-header forbidden-file-path)]
+	   [okay-content-length (content-length-header okay-file-path)]
+	   [auth-header `(www-authenticate "^Basic realm=\"secret stuff\"$")]
+	   [forbidden-headers (append usual-headers (list forbidden-content-length auth-header))]
+	   [okay-headers (append usual-headers (list okay-content-length))]
+;	   [authorization (list (format "authorization: Basic ~a" (base64-encode "bubba:bbq")))]
+           [authorization (list (bytes->string/utf-8 (bytes-append #"authorization: Basic " (base64-encode #"bubba:bbq"))))]
+           )
+      (or (problem-with-url? forbidden-file-path
+			     forbidden-headers
+			     (local-url port "secret/"))
+	  (problem-with-url? okay-file-path
+			     okay-headers
+			     (local-url port "secret/")
+			     authorization)
+	  (problem-with-url? forbidden-file-path
+			     forbidden-headers
+			     (local-url port "secret/index.html"))
+	  (problem-with-url? okay-file-path
+			     okay-headers
+			     (local-url port "secret/index.html")
+			     authorization))))
+  
+  ; normal-servlets-broken? : Nat -> (+ false str)
+  (define (normal-servlets-broken? port)
+    (myprint "normal-servlets-broken?~n")
+    (let* ([local-test-url
+            (lambda (path)
+              (local-url port (string-append "servlets/tests/" path)))]
+           [broken-url?
+            (lambda (answer prog)
+              (let ([answer-1 (build-path answers-directory answer)])
+                (problem-with-url? answer-1
+                                   (append usual-headers (list (content-length-header answer-1)))
+                                   (local-test-url prog))))])
+      (or (broken-url? "test.servlet-1" "test.ss")
+	  (broken-url? "test.servlet-2" "test.ss?a=b&see=def")
+	  (problem-with-url? (build-path answers-directory "incremental")
+                             usual-headers
+                             (local-url port "servlets/tests/incremental.ss"))
+          ; more here - test chunked version
+	  ;(problem-with-url? (build-path answers-directory "incremental")
+          ;                   `(,(car usual-headers)
+          ;                     ,(cadr usual-headers)
+          ;                     ,(caddr usual-headers)
+          ;                     (Transfer-Encoding "^chunked$"))
+          ;                   (local-url port "servlets/tests/incremental.ss"))
+          (let ([string-answer (build-path answers-directory "mime-servlet")])
+	    (problem-with-url? string-answer
+			       `(,(car usual-headers)
+				 ,(cadr usual-headers)
+				 ,(caddr usual-headers)
+				 (content-type "^text/uber-format$")
+				 (connection "^close$")
+				 ,(content-length-header string-answer))
+			       (local-url port "servlets/tests/mime.ss")))
+          (broken-url? "a-module" "a-module.ss")
+          (broken-url? "b-module" "b-module.ss?texan=big-hat")
+          ;(broken-url? "suspended-module" "suspended-module.ss") ; k-id is random
+          (broken-url-regexp? (local-test-url "suspended-module.ss")
+                              (append usual-headers (list `(content-length "[0-9]*")))
+                              suspended-module-regexp))))
+  
+  (define suspended-module-regexp
+    (regexp "<html><head><meta http-equiv=\"Pragma\" content=\"no-cache\" /><meta http-equiv=\"expires\" content=\"-1\" /><title>What is your name?</title></head><body bgcolor=\"white\"><form action=\"/servlets/tests/suspended-module.ss;id[0-9]*[*]k1-[0-9]*\" method=\"post\">What is your name?<input type=\"text\" name=\"name\" /></form></body></html>"))
+  
+  ; extended-servlets-broken? : Nat -> (+ false str)
+  (define (extended-servlets-broken? port)
+    #f)
+
+  ; : (list sym str)
+  (define generic-content-length-header
+    `(content-length "^[0-9][0-9]*$"))
+  
+  ; errors-broken? : Nat -> (+ false str)
+  ; tests file-not-found, servlet-error, and protocol-error.  The access-denied error is under authentication-broken?
+  (define (errors-broken? port)
+    (printf "errors-broken?:~n")
+    (let* ([not-found-path (build-path web-root "conf" "not-found.html")]
+	   [not-found-headers (append usual-headers (list (content-length-header not-found-path)))]
+	   [non-unit-headers (append usual-headers (list generic-content-length-header))]
+	   [servlet-error-path (build-path web-root "conf" "servlet-error.html")]
+           [servlet-error-headers (append usual-headers (list (content-length-header servlet-error-path)))])
+      (or (problem-with-url? not-found-path
+			     not-found-headers
+			     (local-url port "/conf/some-file-name-that-is-not-there.hmtl"))
+          (problem-with-url? not-found-path
+			     not-found-headers
+			     (local-url port "some-file-name-that-is-not-there.hmtl"))
+	  (problem-with-url? not-found-path
+			     not-found-headers
+			     (local-url port "servlets/some-program-name-that-is-not-there"))
+	  (problem-with-url? servlet-error-path
+			     servlet-error-headers
+			     (local-url port "servlets/tests/broken.ss"))
+	  (broken-url-regexp? (local-url port "servlets/tests/non-unit.ss")
+			      non-unit-headers
+			      "Servlet didn't load. \"Loading \\\".*non-unit.ss\\\" produced \n5\n instead of a servlet.\"")
+          (broken-url-regexp? (local-url port "servlets/tests/bad-require.ss")
+			      (append usual-headers (list generic-content-length-header))
+			      "Servlet didn't load. open-input-file: cannot open input file: \".*not-there-on-purpose.ss\" (No such file or directory; errno=2)")
+	  #|(problem-with-url? servlet-error-path
+			       servlet-error-headers
+			       (local-url port "servlets/tests/bad-return.ss"))
+	  |#)))
+  
+  ; timeouts-broken? : nat -> (U false str)
+  (define (timeouts-broken? port)
+    (printf "timeouts-broken?:~n")
+    (delimit-resources
+     (lambda ()
+       (let-values ([(in out) (tcp-connect TEST-IP port)])
+         (sleep 40) ; must be big enough to timeout
+         (if (and (char-ready? in) (eof-object? (read-char in)))
+             #f
+             "Did not timeout")))))
+  
+  ; local-url : nat str -> url
+  (define (local-url port extra)
+    (string->url (format "http://~a:~a/~a" TEST-IP port extra)))
+  
+  ; error-add : str (+ false str) -> (+ false str)
+  (define (error-add prefix result)
+    (and result (string-append prefix result)))
+  
+  ; mime-headers-problem? : (listof mime-header) header-pattern -> (+ false str)
+  (define (mime-headers-problem? headers answers)
+    (myprint "mime-headers-problem?~n")
+    (if (not (= (length headers) (length answers)))
+	(format "wrong number of headers.~n  expected ~s~n  received ~s"
+		answers (map (lambda (h)
+                               (list (mime-header-name h)
+                                     (mime-header-value h)))
+                             headers))
+	(ormap (lambda (h a)
+		 (if (and (string-ci=? (mime-header-name h)
+                                       (symbol->string (car a)))
+			  (regexp-match (cadr a) (mime-header-value h)))
+		     #f
+		     (format "mime-header results:~s" (list (list (car a) (mime-header-name h))
+					(list (cadr a) (mime-header-value h))))))
+	       headers
+	       answers)))
+  
+  ; input-port-diff : iport iport -> (+ false str)
+  ; effect: consumes all input on at least the shorter port
+  (define (input-port-diff a b)
+    (myprint "input-port-diff~n")
+    (let compare ([n 0])
+      (let* ([c-a (read-char a)]
+	     [c-b (read-char b)]
+	     [differ (lambda () (format "(<where> <actual> <expected>): ~s" (list n c-a c-b)))])
+	(cond
+	  [(eof-object? c-a)
+	   (cond
+	     [(eof-object? c-b) #f]
+	     [else (differ)])]
+	  [else
+	   (cond
+	     [(eof-object? c-b) (differ)]
+	     [else (if (char=? c-a c-b)
+		       (compare (add1 n))
+		       (differ))])]))))
+  
+  ; extract-k-url : iport -> str
+  ; to extract the action url from an html form
+  (define (extract-k-url in)
+    (or (let search-content ([el (document-element (read-xml in))])
+	  (cond
+	    [(element? el)
+	     (or (if (eq? 'form (element-name el))
+		     (let action-attribute ([attrs (element-attributes el)])
+		       (cond
+			 [(null? attrs) #f]
+			 [else (if (eq? 'action (attribute-name (car attrs)))
+				   (attribute-value (car attrs))
+				   (action-attribute (cdr attrs)))]))
+		     #f)
+		 (ormap search-content (element-content el)))]
+	    [else #f]))
+	(raise "couldn't find action url")))
+  
+  #| 
+  ; Meta tests:
+  
+  ; input-port-diff
+  (call-with-input-file "/home/ptg/to-do"
+    (lambda (in1)
+      (call-with-input-file "/home/ptg/to-do"
+	(lambda (in2)
+	  (input-port-diff in1 in2)))))
+  (call-with-input-file "/etc/passwd"
+    (lambda (in1)
+      (call-with-input-file "/home/ptg/to-do"
+	(lambda (in2)
+	  (input-port-diff in1 in2)))))
+  |# #|
+  (mime-headers-problem? (list (make-mime-header "server" ": PLT"))
+			 '((server ": PLT")))
+  (mime-headers-problem? (list (make-mime-header "server" ": PLT"))
+			 '((server ": PLT2")))
+  |#
+  #|
+  (string=? "boing" (extract-k-url (open-input-string "<html><form action='boing'>hi</form></html>")))
+  (string=? "boing" (extract-k-url (open-input-string "<html><form><form action='boing'>hi</form></form></html>")))
+  (with-handlers ([void (lambda (exn) (string=? exn "couldn't find action url"))])
+    (extract-k-url (open-input-string "<html><p>pair of graph</p></html>"))
+    #f)
+  |#
+  )
diff --git a/collects/tests/web-server/web-hammer.ss b/collects/tests/web-server/web-hammer.ss
new file mode 100644
index 0000000000..8529e93b20
--- /dev/null
+++ b/collects/tests/web-server/web-hammer.ss
@@ -0,0 +1,40 @@
+(module web-hammer mzscheme
+  (require (lib "url.ss" "net"))
+  (provide server-performance)
+  (provide (all-from (lib "url.ss" "net")))
+
+  (define BUFFER-SIZE 8192)
+
+  ;; server-performance : Url Nat Nat Nat -> Num
+  ;; num-clients client threads request the url from the server repeatedly
+  ;; think-time-msecs appart for duration-seconds
+  ;; the performance is completed requests per second
+  (define (server-performance url num-clients think-time-msec duration-seconds)
+    (let ([cust (make-custodian)]
+	  [think-time-seconds (/ think-time-msec 1000)]
+	  [responses (make-vector num-clients 0)]
+	  [start (current-milliseconds)])
+      (parameterize ([current-custodian cust])
+	(let loop ([n num-clients])
+	  (let ([n-1 (sub1 n)])
+	    (unless (zero? n)
+	      (thread
+	       (lambda ()
+		 (let request ()
+		   (with-handlers ([exn:fail? void])
+		     (parameterize ([current-custodian (make-custodian)])
+		       (let ([port (get-pure-port url)])
+			 (let discard-all ()
+			   (let ([s (read-string BUFFER-SIZE port)])
+			     (unless (eof-object? s)
+			       (discard-all)))))
+		       (custodian-shutdown-all (current-custodian)))
+		     ; vector-set! is inside ignore errors so it doesn't happen for unfulfilled requests
+		     (vector-set! responses n-1 (add1 (vector-ref responses n-1))))
+		   (sleep think-time-seconds)
+		   (request))))
+	      (loop n-1)))))
+      (sleep duration-seconds)
+      (custodian-shutdown-all cust)
+      (let ([stop (current-milliseconds)])
+	(* 1000 (/ (apply + (vector->list responses)) (- stop start)))))))
diff --git a/collects/tests/web-server/web-root/conf/forbidden.html b/collects/tests/web-server/web-root/conf/forbidden.html
new file mode 100644
index 0000000000..fcd2eb9032
--- /dev/null
+++ b/collects/tests/web-server/web-root/conf/forbidden.html
@@ -0,0 +1,7 @@
+<html>
+<head><title>Access Denied</title></head>
+<body>
+<p>The server could not verify that you have permissions to access the requested document.</p>
+<p>Powered by <a href="http://www.plt-scheme.org/">PLT</a></p>
+</body>
+</html>
\ No newline at end of file
diff --git a/collects/tests/web-server/web-root/conf/not-found.html b/collects/tests/web-server/web-root/conf/not-found.html
new file mode 100644
index 0000000000..19bc1a0570
--- /dev/null
+++ b/collects/tests/web-server/web-root/conf/not-found.html
@@ -0,0 +1,7 @@
+<html>
+<head><title>Not Found</title></head>
+<body bgcolor='white'>
+<p>The file you were looking for was not found on this server.</p>
+<p>Powered by <a href="http://www.plt-scheme.org/">PLT</a></p>
+</body>
+</html>
diff --git a/collects/tests/web-server/web-root/conf/passwords-refresh.html b/collects/tests/web-server/web-root/conf/passwords-refresh.html
new file mode 100644
index 0000000000..3f283393ab
--- /dev/null
+++ b/collects/tests/web-server/web-root/conf/passwords-refresh.html
@@ -0,0 +1,7 @@
+<html>
+<head><title>Passwords Refreshed</title></head>
+<body bgcolor='white'>
+<p>The Web server is now using the new password file.</p>
+<p>Powered by <a href="http://www.plt-scheme.org/">PLT</a></p>
+</body>
+</html>
diff --git a/collects/tests/web-server/web-root/conf/protocol-error.html b/collects/tests/web-server/web-root/conf/protocol-error.html
new file mode 100644
index 0000000000..122732cc8d
--- /dev/null
+++ b/collects/tests/web-server/web-root/conf/protocol-error.html
@@ -0,0 +1,7 @@
+<html>
+<head><title>Browser Error</title></head>
+<body>
+<p>The browser sent a malformed request.</p>
+<p>Powered by <a href="http://www.plt-scheme.org/">PLT</a></p>
+</body>
+</html>
diff --git a/collects/tests/web-server/web-root/conf/servlet-error.html b/collects/tests/web-server/web-root/conf/servlet-error.html
new file mode 100644
index 0000000000..bf6b698231
--- /dev/null
+++ b/collects/tests/web-server/web-root/conf/servlet-error.html
@@ -0,0 +1,9 @@
+<html>
+<head><title>Servlet Error</title></head>
+<body>
+<p>The servlet terminated abnormally.<br />
+   Please ask the author to fix the problem based on the details in
+   the Web server's log file.</p>
+<p>Powered by <a href="http://www.plt-scheme.org/">PLT</a></p>
+</body>
+</html>
diff --git a/collects/tests/web-server/web-root/conf/servlet-refresh.html b/collects/tests/web-server/web-root/conf/servlet-refresh.html
new file mode 100644
index 0000000000..8db24b53c5
--- /dev/null
+++ b/collects/tests/web-server/web-root/conf/servlet-refresh.html
@@ -0,0 +1,7 @@
+<html>
+<head><title>Servlets Refreshed</title></head>
+<body bgcolor='white'>
+<p>Fresh copies of Servlets will now be (re)loaded from disk.</p>
+<p>Powered by <a href="http://www.plt-scheme.org/">PLT</a></p>
+</body>
+</html>
diff --git a/collects/tests/web-server/web-root/htdocs/10k.html b/collects/tests/web-server/web-root/htdocs/10k.html
new file mode 100644
index 0000000000..e2da76124d
--- /dev/null
+++ b/collects/tests/web-server/web-root/htdocs/10k.html
@@ -0,0 +1,136 @@
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghi
diff --git a/collects/tests/web-server/web-root/htdocs/1k.html b/collects/tests/web-server/web-root/htdocs/1k.html
new file mode 100644
index 0000000000..46fa3f599e
--- /dev/null
+++ b/collects/tests/web-server/web-root/htdocs/1k.html
@@ -0,0 +1,14 @@
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-+\|[]{}()~
+abcdefghijklmnopqrstuvwxyz0123456789A
diff --git a/collects/tests/web-server/web-root/htdocs/index.html b/collects/tests/web-server/web-root/htdocs/index.html
new file mode 100644
index 0000000000..5e187ce3c6
--- /dev/null
+++ b/collects/tests/web-server/web-root/htdocs/index.html
@@ -0,0 +1,40 @@
+<html>
+ <head>
+   <title>Welcome to the PLT Web server!</title>
+ </head>
+
+ <body bgcolor="white">
+ <img src="/Defaults/documentation/web-server.gif" width="61" height="57" />
+
+<blockquote>
+
+<table width="66%" bgcolor="white">
+<tr><td>
+  <h2>Welcome to the PLT Web Server</h2>
+
+  <p>
+    Find out more about <a href='/Defaults/'>the server and configure</a> it.
+  </p>
+
+  <p>Please replace this page with your favorite index page. 
+  <br />For future configuration changes, remember to look up
+  <br />
+<center>
+   <code> http://127.0.0.1:<em>port</em>/Defaults/ </code>
+</center>
+
+  <p>Powered by 
+  <a href="http://www.plt-scheme.org/">
+   <img width="53" height="19" src="/Defaults/documentation/plt-logo.gif" />
+   </a>
+  <p><font size="-2">
+  For more information on PLT Software, please follow the icon link.
+  </font>
+  </p>
+  </p>
+</table>
+
+</blockquote>
+
+ </body>
+</html>
diff --git a/collects/tests/web-server/web-root/htdocs/me.jpg b/collects/tests/web-server/web-root/htdocs/me.jpg
new file mode 100644
index 0000000000..2b3e9ac372
Binary files /dev/null and b/collects/tests/web-server/web-root/htdocs/me.jpg differ
diff --git a/collects/tests/web-server/web-root/htdocs/me2.JPG b/collects/tests/web-server/web-root/htdocs/me2.JPG
new file mode 100644
index 0000000000..2b3e9ac372
Binary files /dev/null and b/collects/tests/web-server/web-root/htdocs/me2.JPG differ
diff --git a/collects/tests/web-server/web-root/htdocs/secret/index.html b/collects/tests/web-server/web-root/htdocs/secret/index.html
new file mode 100644
index 0000000000..1eb484cb30
--- /dev/null
+++ b/collects/tests/web-server/web-root/htdocs/secret/index.html
@@ -0,0 +1,8 @@
+<html>
+<head><title>Home</title></head>
+<body>
+<p>
+Hi.
+</p>
+</body>
+</html>
diff --git a/collects/tests/web-server/web-root/passwords b/collects/tests/web-server/web-root/passwords
new file mode 100644
index 0000000000..c6ca1020c9
--- /dev/null
+++ b/collects/tests/web-server/web-root/passwords
@@ -0,0 +1 @@
+'(("secret stuff" "/secret(/.*)?" (bubba "bbq") (|Billy| "BoB")))
diff --git a/collects/tests/web-server/web-root/servlets/configure.ss b/collects/tests/web-server/web-root/servlets/configure.ss
new file mode 100644
index 0000000000..a62aea6ff3
--- /dev/null
+++ b/collects/tests/web-server/web-root/servlets/configure.ss
@@ -0,0 +1,8 @@
+; DO NOT DELETE THIS SERVLET,
+; unless you never want to reconfigure the Web server again.
+; The servlet accepts requests only from the *same machine* as the Web server
+; for security purposes.
+
+(require (lib "configure.ss" "web-server"))
+
+servlet
diff --git a/collects/tests/web-server/web-root/servlets/tests/a-module.ss b/collects/tests/web-server/web-root/servlets/tests/a-module.ss
new file mode 100644
index 0000000000..02c5b05358
--- /dev/null
+++ b/collects/tests/web-server/web-root/servlets/tests/a-module.ss
@@ -0,0 +1,12 @@
+(module a-module mzscheme
+  (provide interface-version timeout start)
+  
+  (define interface-version 'v1)
+  
+  (define timeout +inf.0)
+  
+  ; start : request -> response
+  (define (start initial-request)
+    `(html (head (title "A Test Page"))
+           (body ([bgcolor "white"])
+                 (p "A simple module servlet works.")))))
\ No newline at end of file
diff --git a/collects/tests/web-server/web-root/servlets/tests/b-module.ss b/collects/tests/web-server/web-root/servlets/tests/b-module.ss
new file mode 100644
index 0000000000..1f988b19d3
--- /dev/null
+++ b/collects/tests/web-server/web-root/servlets/tests/b-module.ss
@@ -0,0 +1,14 @@
+(module b-module mzscheme
+  (provide interface-version timeout start)
+  (require (lib "servlet-sig.ss" "web-server"))
+  
+  (define interface-version 'v1)
+  
+  (define timeout +inf.0)
+  
+  ; start : request -> response
+  (define (start initial-request)
+    `(html (head (title "A Test Page"))
+           (body ([bgcolor "white"])
+                 (p ,(format "Here are the initial bindings: ~v"
+                             (request-bindings initial-request)))))))
\ No newline at end of file
diff --git a/collects/tests/web-server/web-root/servlets/tests/bad-require.ss b/collects/tests/web-server/web-root/servlets/tests/bad-require.ss
new file mode 100644
index 0000000000..3453e0b6c2
--- /dev/null
+++ b/collects/tests/web-server/web-root/servlets/tests/bad-require.ss
@@ -0,0 +1 @@
+(require "not-there-on-purpose.ss")
diff --git a/collects/tests/web-server/web-root/servlets/tests/bad-return.ss b/collects/tests/web-server/web-root/servlets/tests/bad-return.ss
new file mode 100644
index 0000000000..19080d0ef0
--- /dev/null
+++ b/collects/tests/web-server/web-root/servlets/tests/bad-return.ss
@@ -0,0 +1,5 @@
+(require (lib "unitsig.ss"))
+(require (lib "servlet-sig.ss" "web-server"))
+(unit/sig ()
+  (import servlet^)
+  5)
diff --git a/collects/tests/web-server/web-root/servlets/tests/broken.ss b/collects/tests/web-server/web-root/servlets/tests/broken.ss
new file mode 100644
index 0000000000..f162ee3ada
--- /dev/null
+++ b/collects/tests/web-server/web-root/servlets/tests/broken.ss
@@ -0,0 +1,5 @@
+(require (lib "unitsig.ss"))
+(require (lib "servlet-sig.ss" "web-server"))
+(unit/sig ()
+  (import servlet^)
+  (raise 'kablooie))
diff --git a/collects/tests/web-server/web-root/servlets/tests/cut-module.ss b/collects/tests/web-server/web-root/servlets/tests/cut-module.ss
new file mode 100644
index 0000000000..1ba3fac298
--- /dev/null
+++ b/collects/tests/web-server/web-root/servlets/tests/cut-module.ss
@@ -0,0 +1,55 @@
+; purpose: to test send/suspend, send/forward, send/back, and send/finish
+(module cut-module mzscheme
+  (provide interface-version timeout start)
+  (require (lib "servlet.ss" "web-server")
+           (lib "servlet-sig.ss" "web-server"))
+  
+  (define interface-version 'v1)
+  
+  (define timeout (* 7 24 60 60))
+  
+  ; : request -> response
+  (define (start initial-request)
+    (let ([order (extract-binding/single
+                  'order
+                  (request-bindings
+                   (send/suspend (let ([question "Place your order"])
+                                   (build-suspender
+                                    `(,question)
+                                    `(,question (input ([type "text"] [name "order"]))))))))])
+      (if (string=? "coconut" order)
+          (continue-shopping)
+          (retry-order))))
+  
+  ; : -> doesn't
+  (define (continue-shopping)
+    (let* ([next-request
+            (send/forward
+             (build-suspender
+              '("Keep shopping")
+              `((p "Your order has shipped to a random location.  You may not go back.")
+                (p (input ([type "submit"] [name "go"] [value "Keep Shopping"])))
+                (p (input ([type "submit"] [name "stop"] [value "Logout"]))))))]
+           [next (request-bindings next-request)])
+      (cond
+        [(exists-binding? 'go next)
+         (start next-request)]
+        [(exists-binding? 'stop next)
+         (send/finish goodbye-page)]
+        [else
+         (send/finish
+          `(html (head (title "Oops"))
+                 (body ([bgcolor "white"])
+                       (p "Oops " ,(format "next = ~v" next)))))])))
+  
+  ; : -> doesn't
+  (define (retry-order)
+    (send/back '(html (head (title "oops"))
+                      (body (p "This store only sells coconuts.  Please click the browser's back button and type "
+                               (code "coconut") " in the field.")))))
+  
+  (define goodbye-page
+    `(html (head (title "Goodbye"))
+           (body (p "Thank you for shopping.")))))
+  
+  
diff --git a/collects/tests/web-server/web-root/servlets/tests/incremental.ss b/collects/tests/web-server/web-root/servlets/tests/incremental.ss
new file mode 100644
index 0000000000..d01748f4bf
--- /dev/null
+++ b/collects/tests/web-server/web-root/servlets/tests/incremental.ss
@@ -0,0 +1,14 @@
+(require (lib "servlet-sig.ss" "web-server")
+         (lib "unitsig.ss"))
+
+(unit/sig ()
+  (import servlet^)
+  
+  (send/finish
+   (make-html-response/incremental
+    (lambda (output-chunk)
+      (output-chunk "<html><head><title>"
+                    "my-title</title></head>\n")
+      (output-chunk "<body><p>The first paragraph</p>\n")
+      (sleep 4)
+      (output-chunk "<p>The second paragraph</p></body></html>\n")))))
diff --git a/collects/tests/web-server/web-root/servlets/tests/mime.ss b/collects/tests/web-server/web-root/servlets/tests/mime.ss
new file mode 100644
index 0000000000..8c14f5c57e
--- /dev/null
+++ b/collects/tests/web-server/web-root/servlets/tests/mime.ss
@@ -0,0 +1,7 @@
+(require (lib "unitsig.ss"))
+(require (lib "servlet-sig.ss" "web-server"))
+(unit/sig ()
+  (import servlet^)
+  `("text/uber-format"
+    "uber uber uber"
+    "-de-doo"))
diff --git a/collects/tests/web-server/web-root/servlets/tests/module-suspended-init.ss b/collects/tests/web-server/web-root/servlets/tests/module-suspended-init.ss
new file mode 100644
index 0000000000..0c782285a5
--- /dev/null
+++ b/collects/tests/web-server/web-root/servlets/tests/module-suspended-init.ss
@@ -0,0 +1,26 @@
+(module module-suspended-init mzscheme
+  (provide interface-version timeout start)
+  (require (lib "servlet.ss" "web-server")
+           (lib "servlet-sig.ss" "web-server"))
+  
+  (define interface-version 'v1)
+  
+  (define timeout (* 7 24 60 60))
+  
+  ; : request -> response
+  (define (start initial-request)
+    (let ([name (extract-binding/single
+                 'name
+                 (request-bindings
+                  (send/suspend (let ([question "What is your name?"])
+                                  (build-suspender
+                                   `(,question)
+                                   `(,question (input ([type "text"] [name "name"]))))))))])
+      `(html (head (title "Hi " ,name "!"))
+             (body (p "Hello, " ,name "!  Don't you feel special now?")))))
+  
+  (send/suspend
+   (build-suspender '("Module Init")
+                    '((p "Maybe calling send/suspend during the module initialization is not a good idea.")
+                      (p "This call to send/suspend fails in the development environment since the parameter is #f")
+                      (p "It fails in the server because the instance id is not yet installed into the table.")))))
diff --git a/collects/tests/web-server/web-root/servlets/tests/non-unit.ss b/collects/tests/web-server/web-root/servlets/tests/non-unit.ss
new file mode 100644
index 0000000000..7ed6ff82de
--- /dev/null
+++ b/collects/tests/web-server/web-root/servlets/tests/non-unit.ss
@@ -0,0 +1 @@
+5
diff --git a/collects/tests/web-server/web-root/servlets/tests/response.ss b/collects/tests/web-server/web-root/servlets/tests/response.ss
new file mode 100644
index 0000000000..5eb100c500
--- /dev/null
+++ b/collects/tests/web-server/web-root/servlets/tests/response.ss
@@ -0,0 +1,5 @@
+(define title "A Test of Direct Responses")
+
+`(html (head (title ,title))
+       (body (h2 ,title)
+             (p "This is only a test.")))
\ No newline at end of file
diff --git a/collects/tests/web-server/web-root/servlets/tests/size.ss b/collects/tests/web-server/web-root/servlets/tests/size.ss
new file mode 100644
index 0000000000..174feec2db
--- /dev/null
+++ b/collects/tests/web-server/web-root/servlets/tests/size.ss
@@ -0,0 +1,22 @@
+(require (lib "unitsig.ss"))
+(require (lib "servlet-sig.ss" "web-server"))
+
+(let* ([line-size 80]
+       [build-a-str
+        (lambda (n)
+          (list->string (let loop ([n n])
+                          (cond
+                            [(zero? n) (list #\newline)]
+                            [else (cons #\a (loop (sub1 n)))]))))]
+       [line (build-a-str (sub1 line-size))]
+       [html-overhead 68])
+  (unit/sig ()
+    (import servlet^)
+    
+    (define size (- (string->number (cdr (assq 'size bindings))) html-overhead))
+    (define nlines (quotient size line-size))
+    (define extra (remainder size line-size))
+    
+    `(html (head (title "A Page"))
+           (body (p ,@(vector->list (make-vector nlines line))
+                    ,(build-a-str extra))))))
diff --git a/collects/tests/web-server/web-root/servlets/tests/suspended-module.ss b/collects/tests/web-server/web-root/servlets/tests/suspended-module.ss
new file mode 100644
index 0000000000..5518774a0a
--- /dev/null
+++ b/collects/tests/web-server/web-root/servlets/tests/suspended-module.ss
@@ -0,0 +1,20 @@
+(module suspended-module mzscheme
+  (provide interface-version timeout start)
+  (require (lib "servlet.ss" "web-server")
+           (lib "servlet-sig.ss" "web-server"))
+  
+  (define interface-version 'v1)
+  
+  (define timeout (* 7 24 60 60))
+  
+  ; : request -> response
+  (define (start initial-request)
+    (let ([name (extract-binding/single
+                 'name
+                 (request-bindings
+                  (send/suspend (let ([question "What is your name?"])
+                                  (build-suspender
+                                   `(,question)
+                                   `(,question (input ([type "text"] [name "name"]))))))))])
+      `(html (head (title "Hi " ,name "!"))
+             (body (p "Hello, " ,name "!  Don't you feel special now?"))))))
diff --git a/collects/tests/web-server/web-root/servlets/tests/test.ss b/collects/tests/web-server/web-root/servlets/tests/test.ss
new file mode 100644
index 0000000000..63e5674d51
--- /dev/null
+++ b/collects/tests/web-server/web-root/servlets/tests/test.ss
@@ -0,0 +1,15 @@
+(require (lib "unitsig.ss"))
+(require (lib "servlet-sig.ss" "web-server"))
+(let ([count 0])
+  (unit/sig ()
+    (import servlet^)
+(with-handlers ([void (lambda (exn) `(html (body (p ,(exn-message exn)))))])
+    (set! count (add1 count))
+    `(html (head (title "Testing 1...2...3"))
+	   (body (p "This is a generated web page.")
+		 (p ,(format "Here are the bindings:~n~s~n" (request-bindings initial-request))
+		    (br)
+		    "Count = " ,(number->string count)
+		    (br)
+		    ,(format "Here are the headers:~n~s~n" (request-headers initial-request)))))))
+)
diff --git a/collects/tests/web-server/web-root/servlets/tests/url.ss b/collects/tests/web-server/web-root/servlets/tests/url.ss
new file mode 100644
index 0000000000..c2de118b06
--- /dev/null
+++ b/collects/tests/web-server/web-root/servlets/tests/url.ss
@@ -0,0 +1,11 @@
+(require (lib "unitsig.ss")
+         (lib "servlet-sig.ss" "web-server")
+         (lib "url.ss" "net"))
+(let ([count 0])
+  (unit/sig ()
+    (import servlet^)
+    (set! count (add1 count))
+    `(html (head (title "URL Test"))
+           (body (p "The method requested is: " ,(format "~s" (request-method initial-request)))
+                 (p "The URL requested is: " ,(url->string (request-uri initial-request)))
+                 (p "count is: " ,(number->string count))))))
\ No newline at end of file
diff --git a/collects/tex2page/info.ss b/collects/tex2page/info.ss
new file mode 100644
index 0000000000..9a8d870f84
--- /dev/null
+++ b/collects/tex2page/info.ss
@@ -0,0 +1,6 @@
+
+(module info (lib "infotab.ss" "setup")
+  (define name "tex2page")
+
+  (define mzscheme-launcher-libraries (list "start.ss"))
+  (define mzscheme-launcher-names (list "tex2page")))
diff --git a/collects/tex2page/start.ss b/collects/tex2page/start.ss
new file mode 100644
index 0000000000..d00167cb7b
--- /dev/null
+++ b/collects/tex2page/start.ss
@@ -0,0 +1,12 @@
+(module start mzscheme
+  (require "tex2page.ss"
+	   (lib "cmdline.ss"))
+
+  (command-line
+   "tex2page"
+   (current-command-line-arguments)
+   [once-each
+    [("--version") "Reports long help and version information"
+     (tex2page "--version")]]
+   [args file "Processes each <file>"
+	 (map tex2page file)]))
diff --git a/collects/tex2page/tex2page-aux.ss b/collects/tex2page/tex2page-aux.ss
new file mode 100644
index 0000000000..e78c7a9b11
--- /dev/null
+++ b/collects/tex2page/tex2page-aux.ss
@@ -0,0 +1,9248 @@
+;tex2page
+;(c) Dorai Sitaram, 1997-2002
+
+(module tex2page-aux mzscheme
+  (require (lib "process.ss"))
+  (require (lib "date.ss"))
+  (provide (all-defined-except ))
+
+(define make-table
+  (lambda z (if (null? z) (make-hash-table) (make-hash-table 'equal))))
+
+(define table-get
+  (lambda (ht k . d)
+    (hash-table-get ht k (let ((d (if (null? d) #f (car d)))) (lambda () d)))))
+
+; ensure shell-magic above
+;Configured for Scheme dialect plt by scmxlate, v 2004-09-08,
+;(c) Dorai Sitaram, 
+;http://www.ccs.neu.edu/~dorai/scmxlate/scmxlate.html
+
+(define *tex2page-version* "20050501")
+
+(define *tex2page-website*
+  "http://www.ccs.neu.edu/~dorai/tex2page/tex2page-doc.html")
+
+(define *operating-system*
+  (if (getenv "COMSPEC")
+    (let ((term (getenv "TERM")))
+      (if (and (string? term) (string=? term "cygwin")) 'unix 'windows))
+    'unix))
+
+(define *enable-write-18?* #t)
+
+(define *output-extension* ".html")
+
+(define *ghostscript*
+  (case *operating-system*
+    ((windows)
+     (or (ormap
+          (lambda (f) (and (file-exists? f) f))
+          '("c:\\cygwin\\bin\\gs.exe"
+            "g:\\cygwin\\bin\\gs.exe"
+            "c:\\aladdin\\gs6.01\\bin\\gswin32c.exe"
+            "d:\\aladdin\\gs6.01\\bin\\gswin32c.exe"
+            "d:\\gs\\gs8.00\\bin\\gswin32.exe"
+            "g:\\gs\\gs8.00\\bin\\gswin32.exe"))
+         "gswin32.exe"))
+    (else "gs")))
+
+(define *image-format* 'gif)
+
+(define *use-advanced-html-entities?* #f)
+
+(define *use-closing-p-tag?* #t)
+
+(define *metapost* (case *operating-system* ((windows) "mp") (else "mpost")))
+
+(define *navigation-sentence-begin* "Go to ")
+
+(define *navigation-first-name* "first")
+
+(define *navigation-previous-name* "previous")
+
+(define *navigation-next-name* "next")
+
+(define *navigation-page-name* " page")
+
+(define *navigation-contents-name* "contents")
+
+(define *navigation-index-name* "index")
+
+(define *navigation-sentence-end* "")
+
+(define *last-modified* "Last modified")
+
+(define *html-conversion-by* "HTML conversion by")
+
+(define *doctype*
+  (string-append
+    "html public "
+    "\"-//W3C//DTD HTML 4.01 Transitional//EN\" "
+    "\"http://www.w3.org/TR/html4/loose.dtd\""))
+
+(define *scheme-version* (string-append "MzScheme " (version)))
+
+(define *path-separator* (if (eqv? *operating-system* 'windows) #\; #\:))
+
+(define *directory-separator* (if (eqv? *operating-system* 'windows) "\\" "/"))
+
+(define *bye-tex*
+  (case *operating-system*
+    ((windows) " \\bye")
+    ((unix) " \\\\bye")
+    (else " \\\\bye")))
+
+(define *int-corresp-to-0* (char->integer #\0))
+
+(define *aux-file-suffix* "-Z-A")
+
+(define *bib-aux-file-suffix* "-Z-B")
+
+(define *css-file-suffix* "-Z-S.css")
+
+(define *eval-file-suffix* "-Z-E-")
+
+(define *html-node-prefix* "node_")
+
+(define *html-page-suffix* "-Z-H-")
+
+(define *img-file-suffix* "-Z-G-")
+
+(define *imgdef-file-suffix* "D-")
+
+(define *index-file-suffix* "-Z-I")
+
+(define *label-file-suffix* "-Z-L")
+
+(define *mfpic-tex-file-suffix* ".Z-M-tex")
+
+(define *toc-file-suffix* "-Z-C")
+
+(define *ghostscript-options*
+  " -q -dBATCH -dNOPAUSE -dNO_PAUSE -sDEVICE=ppmraw")
+
+(define *invisible-space* (list '*invisible-space*))
+
+(define *month-names*
+  (vector
+    "January"
+    "February"
+    "March"
+    "April"
+    "May"
+    "June"
+    "July"
+    "August"
+    "September"
+    "October"
+    "November"
+    "December"))
+
+(define *if-aware-ctl-seqs*
+  '("\\csname" "\\else" "\\end" "\\eval" "\\fi" "\\let"))
+
+(define *html-bull* "&curren;")
+
+(define *html-dagger* "&plusmn;")
+
+(define *html-cap-dagger* "&plusmn;&plusmn;")
+
+(define *html-ldquo* "``")
+
+(define *html-lsaquo* "&lt;")
+
+(define *html-lsquo* "`")
+
+(define *html-mdash* " -- ")
+
+(define *html-ndash* "-")
+
+(define *html-oelig* "oe")
+
+(define *html-cap-oelig* "OE")
+
+(define *html-rdquo* "''")
+
+(define *html-rsaquo* "&gt;")
+
+(define *html-rsquo* "'")
+
+(define *html-scaron* "<u>s</u>")
+
+(define *html-cap-scaron* "<u>S</u>")
+
+(define *html-trade* "<sup>TM</sup>")
+
+(define *html-cap-yuml* "Y&quot;")
+
+(define html-advanced-entities
+  (lambda ()
+    (set! *use-advanced-html-entities?* #t)
+    (set! *html-bull* "&#8226;")
+    (set! *html-dagger* "&#8224;")
+    (set! *html-cap-dagger* "&#8225;")
+    (set! *html-ldquo* "&#8220;")
+    (set! *html-lsaquo* "&#8249;")
+    (set! *html-lsquo* "&#8216;")
+    (set! *html-mdash* "&#8212;")
+    (set! *html-ndash* "&#8211;")
+    (set! *html-cap-oelig* "&#338;")
+    (set! *html-oelig* "&#339;")
+    (set! *html-rdquo* "&#8221;")
+    (set! *html-rsaquo* "&#8250;")
+    (set! *html-rsquo* "&#8217;")
+    (set! *html-cap-scaron* "&#352;")
+    (set! *html-scaron* "&#353;")
+    (set! *html-trade* "&#8482;")
+    (set! *html-cap-yuml* "&#376;")))
+
+(define *filename-delims* '())
+
+(define *scm-token-delims*
+  (list #\( #\) #\[ #\] #\{ #\} #\' #\` #\" #\; #\, #\|))
+
+(define *tex-extra-letters* '())
+
+(define *return* (integer->char 13))
+
+(define *tab* (integer->char 9))
+
+(define *afterpar* '())
+
+(define *afterbye* '())
+
+(define *aux-dir* #f)
+
+(define *aux-dir/* "")
+
+(define *aux-port* #f)
+
+(define *bib-aux-port* #f)
+
+(define *bibitem-num* 0)
+
+(define *colophon-links-to-tex2page-website?* #t)
+
+(define *colophon-mentions-last-mod-time?* #t)
+
+(define *colophon-mentions-tex2page?* #t)
+
+(define *colophon-on-first-page?* #t)
+
+(define *color-names* '())
+
+(define *comment-char* #\%)
+
+(define *css-port* #f)
+
+(define *current-source-file* #f)
+
+(define *current-tex2page-input* #f)
+
+(define *display-justification* 'center)
+
+(define *dotted-counters* #f)
+
+(define *dumping-nontex?* #f)
+
+(define *epsf-xsize* #f)
+
+(define *epsf-ysize* #f)
+
+(define *equation-number* #f)
+
+(define *equation-numbered?* #t)
+
+(define *equation-position* 0)
+
+(define *esc-char* #\\)
+
+(define *esc-char-std* #\\)
+
+(define *esc-char-verb* #\|)
+
+(define *eval-file-count* 0)
+
+(define *eval-for-tex-only?* #f)
+
+(define *expand-escape?* #f)
+
+(define *external-label-tables* #f)
+
+(define *footnote-list* '())
+
+(define *footnote-sym* 0)
+
+(define *global-texframe* #f)
+
+(define *graphics-file-extensions* '())
+
+(define *html* #f)
+
+(define *html-head* #f)
+
+(define *html-only* #f)
+
+(define *html-page* #f)
+
+(define *html-page-count* #f)
+
+(define *ignore-timestamp?* #f)
+
+(define *ignore-active-space?* #f)
+
+(define *img-magnification* 1)
+
+(define *img-file-count* 0)
+
+(define *img-file-extn* "")
+
+(define *img-file-tally* 0)
+
+(define *imgdef-file-count* 0)
+
+(define *imgpreamble* #f)
+
+(define *imgpreamble-inferred* #f)
+
+(define *in-alltt?* #f)
+
+(define *in-display-math?* #f)
+
+(define *in-para?* #f)
+
+(define *in-small-caps?* #f)
+
+(define *includeonly-list* #f)
+
+(define *index-table* #f)
+
+(define *index-count* #f)
+
+(define *index-page* #f)
+
+(define *index-port* #f)
+
+(define *infructuous-calls-to-tex2page* #f)
+
+(define *input-line-no* 0)
+
+(define *input-streams* '())
+
+(define *inputting-boilerplate?* #f)
+
+(define *inside-appendix?* #f)
+
+(define *jobname* "texput")
+
+(define *label-port* #f)
+
+(define *label-source* #f)
+
+(define *label-table* #f)
+
+(define *last-modification-time* #f)
+
+(define *last-page-number* #f)
+
+(define *latex-probability* #f)
+
+(define *ligatures?* #f)
+
+(define *loading-external-labels?* #f)
+
+(define *log-file* #f)
+
+(define *log-port* #f)
+
+(define *main-tex-file* #f)
+
+(define *math-mode?* #f)
+
+(define *math-script-mode?* #f)
+
+(define *math-roman-mode?* #f)
+
+(define *mfpic-file-num* #f)
+
+(define *mfpic-file-stem* #f)
+
+(define *mfpic-port* #f)
+
+(define *missing-eps-files* #f)
+
+(define *missing-pieces* #f)
+
+(define *mp-files* #f)
+
+(define *not-processing?* #f)
+
+(define *output-streams* '())
+
+(define *outputting-external-title?* #f)
+
+(define *outputting-to-non-html?* #f)
+
+(define *recent-node-name* #f)
+
+(define *remember-index-number* #f)
+
+(define *scm-builtins* '())
+
+(define *scm-dribbling?* #f)
+
+(define *scm-keywords*
+  '("=>"
+    "and"
+    "begin"
+    "begin0"
+    "case"
+    "cond"
+    "define"
+    "define-macro"
+    "define-syntax"
+    "defmacro"
+    "defstruct"
+    "delay"
+    "do"
+    "else"
+    "flet"
+    "fluid-let"
+    "if"
+    "labels"
+    "lambda"
+    "let"
+    "let-syntax"
+    "let*"
+    "letrec"
+    "letrec-syntax"
+    "macrolet"
+    "or"
+    "quasiquote"
+    "quote"
+    "set!"
+    "syntax-case"
+    "syntax-rules"
+    "unless"
+    "unquote"
+    "unquote-splicing"
+    "when"
+    "with"
+    "with-handlers"))
+
+(define *scm-variables* '())
+
+(define *section-counters* #f)
+
+(define *section-counter-dependencies* #f)
+
+(define *slatex-like-comments?* #f)
+
+(define *slatex-math-escape* #f)
+
+(define *source-changed-since-last-run?* #f)
+
+(define *stylesheets* #f)
+
+(define *subjobname* *jobname*)
+
+(define *tabular-stack* '())
+
+(define *temp* #f)
+
+(define *temp-string-count* #f)
+
+(define *tex2page-inputs* #f)
+
+(define *tex-env* '())
+
+(define *tex-format* #f)
+
+(define *tex-if-stack* '())
+
+(define *title* #f)
+
+(define *toc-list* #f)
+
+(define *toc-page* #f)
+
+(define *tracingcommands?* #f)
+
+(define *tracingmacros?* #f)
+
+(define *unresolved-xrefs* #f)
+
+(define *use-image-for-displayed-math?* #t)
+
+(define *use-image-for-intext-math?* #t)
+
+(define *using-bibliography?* #f)
+
+(define *using-chapters?* #f)
+
+(define *using-index?* #f)
+
+(define *verb-display?* #f)
+
+(define *verb-port* #f)
+
+(define *verb-visible-space?* #f)
+
+(define *verb-written-files* '())
+
+(define *write-log-max* 55)
+
+(define *write-log-index* 0)
+
+(define *write-log-possible-break?* #f)
+
+(define strftime-like
+  (lambda (ignore-format d)
+    (string-append
+      (date->string d #t)
+      (let ((tz (getenv "TZ"))) (if tz (string-append " " tz) "")))))
+
+(define seconds->human-time
+  (lambda (s) (strftime-like "%a, %b %e, %Y, %l:%M %p %Z" (seconds->date s))))
+
+(define number->roman
+  (lambda (n upcase?)
+    (unless (and (integer? n) (>= n 0))
+      (terror 'number->roman "Missing number"))
+    (let ((roman-digits
+            '((1000 #\m 100)
+              (500 #\d 100)
+              (100 #\c 10)
+              (50 #\l 10)
+              (10 #\x 1)
+              (5 #\v 1)
+              (1 #\i 0)))
+          (approp-case (lambda (c) (if upcase? (char-upcase c) c))))
+      (let loop ((n n) (dd roman-digits) (s '()))
+        (if (null? dd)
+          (if (null? s) "0" (list->string (reverse! s)))
+          (let* ((d (car dd))
+                 (val (car d))
+                 (char (approp-case (cadr d)))
+                 (nextval (caddr d)))
+            (let loop2 ((q (quotient n val)) (r (remainder n val)) (s s))
+              (if (= q 0)
+                (if (>= r (- val nextval))
+                  (loop
+                   (remainder r nextval)
+                   (cdr dd)
+                   (cons char (cons (approp-case (cadr (assv nextval dd))) s)))
+                  (loop r (cdr dd) s))
+                (loop2 (- q 1) r (cons char s))))))))))
+
+(define list-index
+  (lambda (L o)
+    (let loop ((L L) (i 0))
+      (cond
+       ((null? L) #f)
+       ((eqv? (car L) o) i)
+       (else (loop (cdr L) (+ i 1)))))))
+
+(define string-index
+  (lambda (s c)
+    (let ((n (string-length s)))
+      (let loop ((i 0))
+        (cond
+         ((>= i n) #f)
+         ((char=? (string-ref s i) c) i)
+         (else (loop (+ i 1))))))))
+
+(define string-reverse-index
+  (lambda (s c)
+    (let loop ((i (- (string-length s) 1)))
+      (cond
+       ((< i 0) #f)
+       ((char=? (string-ref s i) c) i)
+       (else (loop (- i 1)))))))
+
+(define substring?
+  (lambda (s1 s2)
+    (let* ((s1-len (string-length s1))
+           (s2-len (string-length s2))
+           (n-give-up (+ 1 (- s2-len s1-len))))
+      (let loop ((i 0))
+        (if (< i n-give-up)
+          (let loop2 ((j 0) (k i))
+            (if (< j s1-len)
+              (if (char=? (string-ref s1 j) (string-ref s2 k))
+                (loop2 (+ j 1) (+ k 1))
+                (loop (+ i 1)))
+              i))
+          #f)))))
+
+(define list-position
+  (lambda (x s)
+    (let loop ((s s) (i 0))
+      (cond
+       ((null? s) #f)
+       ((eq? (car s) x) i)
+       (else (loop (cdr s) (+ i 1)))))))
+
+(define-syntax defstruct
+  (lambda (so)
+    (datum->syntax-object
+      so
+      (let ((so-d (syntax-object->datum so)))
+        (let ((s (cadr so-d)) (ff (cddr so-d)))
+          (let ((s-s (symbol->string s)) (n (length ff)))
+            (let* ((n+1 (+ n 1)) (vv (make-vector n+1)))
+              (let loop ((i 1) (ff ff))
+                (if (< i n+1)
+                  (let ((f (car ff)))
+                    (vector-set! vv i (if (pair? f) (cadr f) '(if #f #f)))
+                    (loop (+ i 1) (cdr ff)))))
+              (let ((ff (map (lambda (f) (if (pair? f) (car f) f)) ff)))
+                `(begin
+                   (define ,(string->symbol (string-append "make-" s-s))
+                     (lambda fvfv
+                       (let ((st (make-vector ,n+1)) (ff ',ff))
+                         (vector-set! st 0 ',s)
+                         ,@(let loop ((i 1) (r '()))
+                             (if (>= i n+1)
+                               r
+                               (loop
+                                (+ i 1)
+                                (cons
+                                 `(vector-set! st ,i ,(vector-ref vv i))
+                                 r))))
+                         (let loop ((fvfv fvfv))
+                           (unless (null? fvfv)
+                             (vector-set!
+                               st
+                               (+ (list-position (car fvfv) ff) 1)
+                               (cadr fvfv))
+                             (loop (cddr fvfv))))
+                         st)))
+                   ,@(let loop ((i 1) (procs '()))
+                       (if (>= i n+1)
+                         procs
+                         (loop
+                          (+ i 1)
+                          (let ((f (symbol->string (list-ref ff (- i 1)))))
+                            (cons
+                             `(define (unquote
+                                       (string->symbol
+                                         (string-append s-s "." f)))
+                                (lambda (x) (vector-ref x ,i)))
+                             (cons
+                              `(define (unquote
+                                        (string->symbol
+                                          (string-append "set!" s-s "." f)))
+                                 (lambda (x v) (vector-set! x ,i v)))
+                              procs))))))
+                   (define ,(string->symbol (string-append s-s "?"))
+                     (lambda (x)
+                       (and (vector? x) (eq? (vector-ref x 0) ',s)))))))))))))
+
+(define lassoc
+  (lambda (k al equ?)
+    (let loop ((al al))
+      (if (null? al)
+        #f
+        (let ((c (car al))) (if (equ? (car c) k) c (loop (cdr al))))))))
+
+(define ldelete
+  (lambda (y xx equ?)
+    (let loop ((xx xx) (r '()))
+      (if (null? xx)
+        (reverse! r)
+        (let ((x (car xx))) (loop (cdr xx) (if (equ? x y) r (cons x r))))))))
+
+(defstruct counter (value 0) (within #f))
+
+(defstruct tocentry level number page label header)
+
+(define string-trim-blanks
+  (lambda (s)
+    (let ((orig-n (string-length s)))
+      (let ((i 0) (n orig-n))
+        (let loop ((k i))
+          (cond
+           ((>= k n) (set! i n))
+           ((char-whitespace? (string-ref s k)) (loop (+ k 1)))
+           (else (set! i k))))
+        (let loop ((k (- n 1)))
+          (cond
+           ((<= k i) (set! n (+ k 1)))
+           ((char-whitespace? (string-ref s k)) (loop (- k 1)))
+           (else (set! n (+ k 1)))))
+        (if (and (= i 0) (= n orig-n)) s (substring s i n))))))
+
+(define char-tex-alphabetic?
+  (lambda (c)
+    (or (char-alphabetic? c)
+        (ormap (lambda (d) (char=? c d)) *tex-extra-letters*))))
+
+(define gen-temp-string
+  (lambda ()
+    (set! *temp-string-count* (+ *temp-string-count* 1))
+    (string-append "Temp_" (number->string *temp-string-count*))))
+
+(define file-stem-name
+  (lambda (f)
+    (let ((slash (string-reverse-index f #\/)))
+      (when slash (set! f (substring f (+ slash 1) (string-length f))))
+      (let ((dot (string-reverse-index f #\.)))
+        (if dot (substring f 0 dot) f)))))
+
+(define file-extension
+  (lambda (f)
+    (let ((slash (string-reverse-index f #\/))
+          (dot (string-reverse-index f #\.)))
+      (if (and dot (not (= dot 0)) (or (not slash) (< (+ slash 1) dot)))
+        (substring f dot (string-length f))
+        #f))))
+
+(define ensure-file-deleted (lambda (f) (if (file-exists? f) (delete-file f))))
+
+(define write-aux (lambda (e) (write e *aux-port*) (newline *aux-port*)))
+
+(define write-label
+  (lambda (e)
+    (unless *label-port*
+      (let ((f
+             (string-append *aux-dir/* *jobname* *label-file-suffix* ".scm")))
+        (ensure-file-deleted f)
+        (set! *label-port* (open-output-file f))))
+    (write e *label-port*)
+    (newline *label-port*)))
+
+(define write-bib-aux
+  (lambda (x)
+    (unless *bib-aux-port*
+      (let ((f
+             (string-append
+               *aux-dir/*
+               *jobname*
+               *bib-aux-file-suffix*
+               ".aux")))
+        (ensure-file-deleted f)
+        (set! *bib-aux-port* (open-output-file f))))
+    (display x *bib-aux-port*)))
+
+(define write-log
+  (lambda (x)
+    (unless *log-port*
+      (set! *log-file* (string-append *aux-dir/* *jobname* ".hlog"))
+      (ensure-file-deleted *log-file*)
+      (set! *log-port* (open-output-file *log-file*)))
+    (when (and
+           *write-log-possible-break?*
+           (char? x)
+           (ormap (lambda (c) (char=? x c)) '(#\) #\] #\} #\,)))
+      (set! *write-log-possible-break?* #f))
+    (when (and
+           *write-log-possible-break?*
+           (> *write-log-index* *write-log-max*))
+      (newline *log-port*)
+      (newline)
+      (set! *write-log-possible-break?* #f)
+      (set! *write-log-index* 0))
+    (unless (and
+             (= *write-log-index* 0)
+             (or (eqv? x 'separation-newline) (eqv? x 'separation-space)))
+      (case x
+        ((#\newline separation-newline)
+         (when *write-log-possible-break?*
+           (set! *write-log-possible-break?* #f))
+         (newline *log-port*)
+         (newline)
+         (set! *write-log-index* 0))
+        ((separation-space) (set! *write-log-possible-break?* #t))
+        (else
+         (when *write-log-possible-break?*
+           (write-char #\space *log-port*)
+           (write-char #\space)
+           (set! *write-log-index* (+ *write-log-index* 1))
+           (set! *write-log-possible-break?* #f))
+         (display x *log-port*)
+         (display x)
+         (flush-output)
+         (set! *write-log-index*
+           (+
+            *write-log-index*
+            (cond
+             ((char? x) 1)
+             ((number? x) (string-length (number->string x)))
+             ((string? x) (string-length x))
+             (else 1)))))))))
+
+(define display-error-context-lines
+  (lambda ()
+    (let ((n (let ((c (find-count "\\errorcontextlines"))) (if c (cadr c) 0))))
+      (when (and *current-source-file* (> n 0))
+        (let* ((n1 (max 0 (- *input-line-no* (quotient (- n 1) 2))))
+               (nf (+ n1 n -1))
+               (ll
+                (call-with-input-file
+                  *current-source-file*
+                  (lambda (ip)
+                    (let loop ((i 1) (ll '()))
+                      (let ((L (read-line ip)))
+                        (cond
+                         ((eof-object? L) ll)
+                         ((< i n1) (loop (+ i 1) ll))
+                         ((<= i nf) (loop (+ i 1) (cons (cons i L) ll)))
+                         (else ll))))))))
+          (unless (null? ll)
+            (let* ((border "__________________________...")
+                   (only-1? (= (length ll) 1))
+                   (nf (caar ll))
+                   (ll (reverse! ll))
+                   (n1 (caar ll)))
+              (write-log "Likely error context: ")
+              (write-log *current-source-file*)
+              (write-log ", line")
+              (unless only-1? (write-log "s"))
+              (write-log " ")
+              (write-log n1)
+              (unless only-1? (write-log "-") (write-log nf))
+              (write-log ":")
+              (write-log #\newline)
+              (write-log " /")
+              (write-log border)
+              (write-log #\newline)
+              (for-each
+                (lambda (L)
+                  (write-log " | ")
+                  (write-log (cdr L))
+                  (write-log #\newline))
+                ll)
+              (write-log " |")
+              (write-log border)
+              (write-log #\newline)
+              (write-log "/"))))))))
+
+(define terror
+  (lambda (where . args)
+    (write-log 'separation-newline)
+    (write-log "! ")
+    (for-each write-log args)
+    (write-log 'separation-newline)
+    (write-log "l.")
+    (write-log *input-line-no*)
+    (write-log #\space)
+    (write-log where)
+    (write-log " failed.")
+    (write-log 'separation-newline)
+    (display-error-context-lines)
+    (close-all-open-ports)
+    (output-stats)
+    (display "Type e to edit file at point of error; x to quit.")
+    (newline)
+    (display "? ")
+    (flush-output)
+    (let ((c (read-char)))
+      (when (and (not (eof-object? c)) (char-ci=? c #\e))
+        (edit-offending-file)))
+    (error "TeX2page fatal error")))
+
+(define edit-offending-file
+  (lambda ()
+    (let ((bad-texedit? #f) (cmd #f))
+      (cond
+       ((getenv "TEXEDIT")
+        =>
+        (lambda (s)
+          (cond
+           ((substring? "%d" s)
+            =>
+            (lambda (i)
+              (set! s
+                (string-append
+                  (substring s 0 i)
+                  (number->string *input-line-no*)
+                  (substring s (+ i 2) (string-length s))))))
+           (else (set! bad-texedit? #t)))
+          (cond
+           ((and (not bad-texedit?) (substring? "%s" s))
+            =>
+            (lambda (i)
+              (set! s
+                (string-append
+                  (substring s 0 i)
+                  *current-source-file*
+                  (substring s (+ i 2) (string-length s))))))
+           (else (set! bad-texedit? #t)))
+          (cond
+           (bad-texedit? (display "Bad TEXEDIT; using EDITOR.") (newline))
+           (else (set! cmd s))))))
+      (cond
+       ((and (not cmd) (or (getenv "EDITOR") "vi"))
+        =>
+        (lambda (s)
+          (set! cmd
+            (string-append
+              s
+              " +"
+              (number->string *input-line-no*)
+              " "
+              *current-source-file*)))))
+      (when cmd (system cmd)))))
+
+(define trace-if
+  (lambda (write? . args)
+    (when write?
+      (write-log 'separation-newline)
+      (when (> *input-line-no* 0)
+        (write-log "l.")
+        (write-log *input-line-no*)
+        (write-log #\space))
+      (for-each write-log args)
+      (write-log 'separation-newline))))
+
+(define do-errmessage
+  (lambda ()
+    (write-log 'separation-newline)
+    (write-log "! ")
+    (write-log (tex-string->html-string (get-group)))
+    (write-log 'separation-newline)
+    (terror "\\errmessage")))
+
+(define do-tracingall
+  (lambda () (do-tracingcommands #t) (do-tracingmacros #t)))
+
+(define do-tracingcommands
+  (lambda (unconditional-set?)
+    (set! *tracingcommands?*
+      (or unconditional-set? (begin (get-equal-sign) (> (get-number) 0))))))
+
+(define do-tracingmacros
+  (lambda (unconditional-set?)
+    (set! *tracingmacros?*
+      (or unconditional-set? (begin (get-equal-sign) (> (get-number) 0))))))
+
+(defstruct bport (port #f) (buffer '()))
+
+(define call-with-input-file/buffered
+  (lambda (f th)
+    (unless (file-exists? f)
+      (terror 'call-with-input-file/buffered "I can't find file " f))
+    (call-with-input-file
+      f
+      (lambda (i)
+        (fluid-let
+          ((*current-tex2page-input* (make-bport 'port i))
+           (*current-source-file* f)
+           (*input-line-no* 1))
+          (th))))))
+
+(define call-with-input-string/buffered
+  (lambda (s th)
+    (fluid-let
+      ((*current-tex2page-input* (make-bport 'buffer (string->list s)))
+       (*input-line-no* *input-line-no*))
+      (th))))
+
+(define call-with-input-string
+  (lambda (s p)
+    (let* ((i (open-input-string s)) (r (p i))) (close-input-port i) r)))
+
+(define snoop-char (lambda () (let ((c (get-char))) (toss-back-char c) c)))
+
+(define get-char
+  (lambda ()
+    (let ((b (bport.buffer *current-tex2page-input*)))
+      (if (null? b)
+        (let ((p (bport.port *current-tex2page-input*)))
+          (if (not p)
+            eof
+            (let ((c (read-char p)))
+              (cond
+               ((eof-object? c) c)
+               ((char=? c #\newline)
+                (set! *input-line-no* (+ *input-line-no* 1))
+                c)
+               (else c)))))
+        (let ((c (car b)))
+          (set!bport.buffer *current-tex2page-input* (cdr b))
+          c)))))
+
+(define toss-back-string
+  (lambda (s)
+    (set!bport.buffer
+      *current-tex2page-input*
+      (append! (string->list s) (bport.buffer *current-tex2page-input*)))))
+
+(define toss-back-char
+  (lambda (c)
+    (set!bport.buffer
+      *current-tex2page-input*
+      (cons c (bport.buffer *current-tex2page-input*)))))
+
+(define emit (lambda (s) (display s *html*)))
+
+(define emit-newline (lambda () (newline *html*)))
+
+(define emit-visible-space
+  (lambda () (display "<font color=red>&middot;</font>" *html*)))
+
+(define invisible-space? (lambda (x) (eq? x *invisible-space*)))
+
+(define snoop-actual-char
+  (lambda ()
+    (let ((c (snoop-char)))
+      (cond
+       ((eof-object? c) c)
+       ((invisible-space? c) (get-char) (snoop-actual-char))
+       ((char=? c *return*)
+        (get-char)
+        (let ((c (snoop-actual-char)))
+          (if (and (not (eof-object? c)) (char=? c #\newline))
+            c
+            (begin (toss-back-char #\newline) #\newline))))
+       (else c)))))
+
+(define get-actual-char
+  (lambda ()
+    (let ((c (get-char)))
+      (cond
+       ((eof-object? c) c)
+       ((invisible-space? c) (get-actual-char))
+       ((char=? c *return*)
+        (let ((c (snoop-actual-char)))
+          (if (and (not (eof-object? c)) (char=? c #\newline))
+            (get-actual-char)
+            #\newline)))
+       (else c)))))
+
+(define get-line
+  (lambda ()
+    (let loop ((r '()))
+      (let ((c (get-actual-char)))
+        (cond
+         ((eof-object? c) (if (null? r) c (list->string (reverse! r))))
+         ((char=? c #\newline) (list->string (reverse! r)))
+         (else (loop (cons c r))))))))
+
+(define ignorespaces
+  (lambda ()
+    (if (and (find-chardef #\space) (not *ignore-active-space?*))
+      (when (= (the-count "\\TIIPobeyspacestrictly") 0)
+        (let ((c (snoop-actual-char)))
+          (cond ((eof-object? c) #t) ((char=? c #\newline) #t) (else #t))))
+      (let ((newline-active? (find-chardef #\newline))
+            (newline-already-read? #f))
+        (let loop ()
+          (let ((c (snoop-actual-char)))
+            (cond
+             ((eof-object? c) #t)
+             ((char=? c #\newline)
+              (cond
+               (newline-active? #t)
+               (newline-already-read? (toss-back-char #\newline))
+               (else
+                (get-actual-char)
+                (set! newline-already-read? #t)
+                (loop))))
+             ((char-whitespace? c) (get-actual-char) (loop))
+             (else #t))))))))
+
+(define ignore-all-whitespace
+  (lambda ()
+    (let loop ()
+      (let ((c (snoop-actual-char)))
+        (unless (eof-object? c)
+          (when (char-whitespace? c) (get-actual-char) (loop)))))))
+
+(define munch-newlines
+  (lambda ()
+    (let loop ((n 0))
+      (let ((c (snoop-actual-char)))
+        (cond
+         ((eof-object? c) n)
+         ((char=? c #\newline) (get-actual-char) (loop (+ n 1)))
+         ((char-whitespace? c) (get-actual-char) (loop n))
+         (else n))))))
+
+(define munched-a-newline?
+  (lambda ()
+    (let loop ()
+      (let ((c (snoop-actual-char)))
+        (cond
+         ((eof-object? c) #f)
+         ((char=? c #\newline) (get-actual-char) #t)
+         ((char-whitespace? c) (get-actual-char) (loop))
+         (else #f))))))
+
+(define do-xspace
+  (lambda ()
+    (let ((c (snoop-actual-char)))
+      (unless (memv c '(#\space #\" #\. #\! #\, #\: #\; #\? #\/ #\' #\) #\-))
+        (emit #\space)))))
+
+(define do-relax (lambda () #t))
+
+(define get-ctl-seq
+  (lambda ()
+    (let ((bs (get-actual-char)))
+      (unless (char=? bs *esc-char*)
+        (terror 'get-ctl-seq "Missing control sequence (" bs ")")))
+    (let ((c (get-char)))
+      (cond
+       ((eof-object? c) "\\ ")
+       ((invisible-space? c) "\\ ")
+       ((char-tex-alphabetic? c)
+        (list->string
+          (reverse!
+            (let loop ((s (list c #\\)))
+              (let ((c (snoop-char)))
+                (cond
+                 ((eof-object? c) s)
+                 ((invisible-space? c) s)
+                 ((char-alphabetic? c) (get-char) (loop (cons c s)))
+                 (else
+                  (unless (or *math-mode?* *not-processing?*) (ignorespaces))
+                  s)))))))
+       (else (string #\\ c))))))
+
+(define get-char-as-ctl-seq
+  (lambda ()
+    (let* ((cs (get-ctl-seq)) (c (string-ref cs 1)))
+      (if (char=? c #\^)
+        (let ((c2 (snoop-actual-char)))
+          (if (char=? c2 #\^)
+            (begin
+              (get-actual-char)
+              (let ((c3 (get-actual-char)))
+                (case c3
+                  ((#\M) #\newline)
+                  ((#\I) *tab*)
+                  (else (terror 'get-char-as-ctl-seq)))))
+            c))
+        c))))
+
+(define ctl-seq? (lambda (z) (char=? (string-ref z 0) #\\)))
+
+(define if-aware-ctl-seq?
+  (lambda (z)
+    (or (ormap (lambda (y) (string=? z y)) *if-aware-ctl-seqs*)
+        (and (>= (string-length z) 3)
+             (char=? (string-ref z 1) #\i)
+             (char=? (string-ref z 2) #\f))
+        (let ((z-th (find-corresp-prim-thunk z)))
+          (if (string? z-th)
+            #f
+            (ormap
+             (lambda (y) (eq? z-th (find-corresp-prim-thunk y)))
+             *if-aware-ctl-seqs*))))))
+
+(define get-group-as-reversed-chars
+  (lambda ()
+    (ignorespaces)
+    (let ((c (get-actual-char)))
+      (if (eof-object? c) (terror 'get-group "Runaway argument?"))
+      (unless (char=? c #\{) (terror 'get-group "Missing {"))
+      (let loop ((s (list c)) (nesting 0) (escape? #f))
+        (let ((c (get-actual-char)))
+          (if (eof-object? c) (terror 'get-group "Runaway argument?"))
+          (cond
+           (escape? (loop (cons c s) nesting #f))
+           ((char=? c *esc-char*)
+            (if *expand-escape?*
+              (let ((s1
+                     (begin
+                       (toss-back-char c)
+                       (let ((x
+                              (fluid-let
+                                ((*not-processing?* #t))
+                                (get-ctl-seq))))
+                         (cond
+                          ((ormap
+                            (lambda (z) (string=? x z))
+                            '("\\ " "\\{" "\\}"))
+                           (string (string-ref x 1)))
+                          (else
+                           (fluid-let
+                             ((*esc-char* *esc-char-std*))
+                             (tex-string->html-string x))))))))
+                (loop (append! (reverse! (string->list s1)) s) nesting #f))
+              (loop (cons c s) nesting #t)))
+           ((char=? c #\{) (loop (cons c s) (+ nesting 1) #f))
+           ((char=? c #\})
+            (if (= nesting 0) (cons c s) (loop (cons c s) (- nesting 1) #f)))
+           (else (loop (cons c s) nesting #f))))))))
+
+(define get-group
+  (lambda () (list->string (reverse! (get-group-as-reversed-chars)))))
+
+(define get-peeled-group
+  (lambda () (string-trim-blanks (ungroup (get-group)))))
+
+(define get-token-or-peeled-group
+  (lambda () (string-trim-blanks (ungroup (get-token)))))
+
+(define get-grouped-environment-name-if-any
+  (lambda ()
+    (let ((c (snoop-actual-char)))
+      (if (or (eof-object? c) (not (char=? c #\{)))
+        #f
+        (begin
+          (get-actual-char)
+          (let loop ((s '()))
+            (let ((c (snoop-actual-char)))
+              (cond
+               ((or (char-alphabetic? c) (char=? c #\*))
+                (get-actual-char)
+                (loop (cons c s)))
+               ((and (pair? s) (char=? c #\}))
+                (get-actual-char)
+                (list->string (reverse! s)))
+               (else
+                (for-each toss-back-char s)
+                (toss-back-char #\{)
+                #f)))))))))
+
+(define get-bracketed-text-if-any
+  (lambda ()
+    (ignorespaces)
+    (let ((c (snoop-actual-char)))
+      (if (or (eof-object? c) (not (char=? c #\[)))
+        #f
+        (begin
+          (get-actual-char)
+          (list->string
+            (reverse!
+              (let loop ((s '()) (nesting 0) (escape? #f))
+                (let ((c (get-actual-char)))
+                  (if (eof-object? c)
+                    (terror 'get-bracketed-text-if-any "Runaway argument?"))
+                  (cond
+                   (escape? (loop (cons c s) nesting #f))
+                   ((char=? c *esc-char*) (loop (cons c s) nesting #t))
+                   ((char=? c #\{) (loop (cons c s) (+ nesting 1) #f))
+                   ((char=? c #\}) (loop (cons c s) (- nesting 1) #f))
+                   ((char=? c #\])
+                    (if (= nesting 0) s (loop (cons c s) nesting #f)))
+                   (else (loop (cons c s) nesting #f))))))))))))
+
+(define ungroup
+  (lambda (s)
+    (let* ((n (string-length s)) (n-1 (- n 1)))
+      (if (or (< n 2)
+              (not (char=? (string-ref s 0) #\{))
+              (not (char=? (string-ref s n-1) #\})))
+        s
+        (substring s 1 n-1)))))
+
+(define get-filename
+  (lambda (braced?)
+    (ignorespaces)
+    (when braced?
+      (let ((c (snoop-actual-char)))
+        (if (and (char? c) (char=? c #\{))
+          (get-actual-char)
+          (set! braced? #f))))
+    (list->string
+      (reverse!
+        (let loop ((s '()))
+          (let ((c (snoop-actual-char)))
+            (cond
+             ((eof-object? c) s)
+             ((and (not braced?)
+                   (or (char-whitespace? c)
+                       (and *comment-char* (char=? c *comment-char*))
+                       (ormap (lambda (d) (char=? c d)) *filename-delims*)))
+              (unless *not-processing?* (ignorespaces))
+              s)
+             ((and braced? (char=? c #\})) (get-actual-char) s)
+             ((and *esc-char* (char=? c *esc-char*))
+              (let ((x (get-ctl-seq)))
+                (if (string=? x "\\jobname")
+                  (loop (append! (reverse! (string->list *jobname*)) s))
+                  (begin
+                    (toss-back-char *invisible-space*)
+                    (toss-back-string x)
+                    s))))
+             (else (get-actual-char) (loop (cons c s))))))))))
+
+(define get-plain-filename (lambda () (get-filename #f)))
+
+(define get-filename-possibly-braced
+  (lambda ()
+    (ignorespaces)
+    (let ((c (snoop-actual-char)))
+      (get-filename (and (char? c) (char=? c #\{))))))
+
+(define get-integer
+  (lambda (base)
+    (ignorespaces)
+    (string->number
+      (list->string
+        (reverse!
+          (let loop ((s '()))
+            (let ((c (snoop-actual-char)))
+              (cond
+               ((eof-object? c) s)
+               ((or (char-numeric? c) (and (= base 16) (char-alphabetic? c)))
+                (get-actual-char)
+                (loop (cons c s)))
+               (else (ignorespaces) s))))))
+      base)))
+
+(define get-real
+  (lambda ()
+    (ignorespaces)
+    (let ((minus? #f) (c (snoop-actual-char)))
+      (when (char=? c #\-) (set! minus? #t))
+      (when (or minus? (char=? c #\+)) (get-actual-char))
+      (let ((n
+             (string->number
+               (list->string
+                 (reverse!
+                   (let loop ((s '()))
+                     (let ((c (snoop-actual-char)))
+                       (cond
+                        ((eof-object? c) s)
+                        ((or (char-numeric? c) (char=? c #\.))
+                         (get-actual-char)
+                         (loop (cons c s)))
+                        (else (ignorespaces) s)))))))))
+        (if minus? (- n) n)))))
+
+(define get-equal-sign
+  (lambda ()
+    (ignorespaces)
+    (when (char=? (snoop-actual-char) #\=) (get-actual-char))))
+
+(define get-by
+  (lambda ()
+    (ignorespaces)
+    (when (char=? (snoop-actual-char) #\b)
+      (get-actual-char)
+      (if (char=? (snoop-actual-char) #\y)
+        (get-actual-char)
+        (toss-back-char #\b)))))
+
+(define get-to
+  (lambda ()
+    (ignorespaces)
+    (when (char=? (snoop-actual-char) #\t)
+      (get-actual-char)
+      (cond
+       ((char=? (snoop-actual-char) #\o) (get-actual-char) (ignorespaces))
+       (else (toss-back-char #\t))))))
+
+(define get-number-corresp-to-ctl-seq
+  (lambda (x)
+    (cond
+     ((string=? x "\\the") (get-number-corresp-to-ctl-seq (get-ctl-seq)))
+     ((string=? x "\\active") 13)
+     ((string=? x "\\pageno") *html-page-count*)
+     ((string=? x "\\inputlineno") *input-line-no*)
+     ((string=? x "\\footnotenumber") (get-gcount "\\footnotenumber"))
+     ((string=? x "\\figurenumber")
+      (counter.value (table-get *dotted-counters* "figure")))
+     ((string=? x "\\sectiondnumber")
+      (table-get *section-counters* (string->number (ungroup (get-token))) 0))
+     ((find-count x) => cadr)
+     (else (or (string->number (or (resolve-defs x) x)))))))
+
+(define get-number-or-false
+  (lambda ()
+    (ignorespaces)
+    (let ((c (snoop-actual-char)))
+      (cond
+       ((char=? c *esc-char*) (get-number-corresp-to-ctl-seq (get-ctl-seq)))
+       ((char=? c #\') (get-actual-char) (get-integer 8))
+       ((char=? c #\") (get-actual-char) (get-integer 16))
+       ((char=? c #\`)
+        (get-actual-char)
+        (ignorespaces)
+        (char->integer
+          (if (char=? (snoop-actual-char) *esc-char*)
+            (string-ref (get-ctl-seq) 1)
+            (get-actual-char))))
+       ((char=? c #\+) (get-actual-char) (get-number-or-false))
+       ((char=? c #\-)
+        (get-actual-char)
+        (let ((n (get-number-or-false))) (and n (- n))))
+       ((char-numeric? c) (get-integer 10))
+       (else #f)))))
+
+(define get-number (lambda () (or (get-number-or-false) (terror 'get-number))))
+
+(define get-tex-char-spec
+  (lambda ()
+    (ignorespaces)
+    (case (snoop-actual-char)
+      ((#\`)
+       (get-actual-char)
+       (ignorespaces)
+       (if (char=? (snoop-actual-char) #\\)
+         (get-char-as-ctl-seq)
+         (get-actual-char)))
+      ((#\') (get-actual-char) (integer->char (get-integer 8)))
+      ((#\") (get-actual-char) (integer->char (get-integer 16)))
+      (else (integer->char (get-integer 10))))))
+
+(define get-url
+  (lambda ()
+    (ignorespaces)
+    (let ((c (get-actual-char)))
+      (cond
+       ((eof-object? c) (terror 'get-url "Missing {"))
+       ((not (char=? c #\{)) (terror 'get-url "Missing {")))
+      (string-trim-blanks
+        (list->string
+          (reverse!
+            (let loop ((nesting 0) (s '()))
+              (let ((c (get-actual-char)))
+                (cond
+                 ((eof-object? c) (terror 'get-url "Missing }"))
+                 ((and *comment-char* (char=? c *comment-char*))
+                  (let ((c1 (snoop-actual-char)))
+                    (loop
+                     nesting
+                     (if (and (char? c1) (char-whitespace? c1))
+                       (begin (ignore-all-whitespace) s)
+                       (cons c s)))))
+                 ((char=? c #\{) (loop (+ nesting 1) (cons c s)))
+                 ((char=? c #\})
+                  (if (= nesting 0) s (loop (- nesting 1) (cons c s))))
+                 (else (loop nesting (cons c s))))))))))))
+
+(define get-csv
+  (lambda ()
+    (ignorespaces)
+    (let ((rev-lbl
+            (let loop ((s '()) (nesting 0))
+              (let ((c (get-actual-char)))
+                (cond
+                 ((eof-object? c)
+                  (terror
+                    'get-csv
+                    "Runaway argument of \\cite, "
+                    "\\nocite, \\expandhtmlindex?")
+                  s)
+                 ((and (char=? c #\,) (= nesting 0)) s)
+                 ((char=? c #\{) (loop (cons c s) (+ nesting 1)))
+                 ((char=? c #\})
+                  (if (= nesting 0)
+                    (begin (toss-back-char c) s)
+                    (loop (cons c s) (- nesting 1))))
+                 (else (loop (cons c s) nesting)))))))
+      (if (null? rev-lbl) #f (list->string (reverse! rev-lbl))))))
+
+(define get-raw-token
+  (lambda ()
+    (let ((c (snoop-actual-char)))
+      (cond
+       ((eof-object? c) c)
+       ((char=? c *esc-char*)
+        (fluid-let ((*not-processing?* #t)) (get-ctl-seq)))
+       (else (string (get-actual-char)))))))
+
+(define get-raw-token/is
+  (lambda ()
+    (ignorespaces)
+    (let ((c (snoop-actual-char)))
+      (cond
+       ((eof-object? c) c)
+       ((char=? c *esc-char*) (get-ctl-seq))
+       ((and *comment-char* (char=? c *comment-char*))
+        (eat-till-eol)
+        (get-raw-token/is))
+       (else (string (get-actual-char)))))))
+
+(define get-token
+  (lambda ()
+    (ignorespaces)
+    (let ((c (snoop-actual-char)))
+      (cond
+       ((eof-object? c) c)
+       ((char=? c *esc-char*) (get-ctl-seq))
+       ((char=? c #\{) (get-group))
+       ((and *comment-char* (char=? c *comment-char*))
+        (eat-till-eol)
+        (get-token))
+       (else (string (get-actual-char)))))))
+
+(define eat-word
+  (lambda (word)
+    (ignorespaces)
+    (let ((n (string-length word)))
+      (let loop ((i 0) (r '()))
+        (if (>= i n)
+          #t
+          (let ((c (snoop-actual-char)))
+            (cond
+             ((char=? c (string-ref word i))
+              (get-actual-char)
+              (loop (+ i 1) (cons c r)))
+             (else (for-each toss-back-char r) #f))))))))
+
+(define eat-dimen
+  (lambda ()
+    (get-equal-sign)
+    (fluid-let
+      ((*not-processing?* #t))
+      (let loop ((first? #t))
+        (ignorespaces)
+        (let ((c (snoop-actual-char)))
+          (cond
+           ((eof-object? c) 'done)
+           ((and (char=? c *esc-char*) first?) (get-ctl-seq))
+           ((or (char-numeric? c) (char=? c #\.)) (get-real) (loop first?))
+           ((or (char=? c #\') (char=? c #\")) (get-number) (loop first?))
+           ((ormap eat-word '("+" "-")) (loop first?))
+           ((ormap
+             eat-word
+             '("bp"
+               "cc"
+               "cm"
+               "dd"
+               "em"
+               "ex"
+               "filll"
+               "fill"
+               "fil"
+               "in"
+               "minus"
+               "mm"
+               "pc"
+               "plus"
+               "pt"
+               "sp"
+               "true"))
+            (loop #f))
+           (else 'done)))))))
+
+(define eat-integer
+  (lambda ()
+    (fluid-let
+      ((*not-processing?* #t))
+      (ignorespaces)
+      (get-equal-sign)
+      (get-number))))
+
+(define scm-get-token
+  (lambda ()
+    (list->string
+      (reverse!
+        (let loop ((s '()) (esc? #f))
+          (let ((c (snoop-actual-char)))
+            (cond
+             ((eof-object? c) s)
+             (esc? (get-actual-char) (loop (cons c s) #f))
+             ((char=? c #\\) (get-actual-char) (loop (cons c s) #t))
+             ((or (char-whitespace? c) (memv c *scm-token-delims*)) s)
+             (else (get-actual-char) (loop (cons c s) #f)))))))))
+
+(define emit-html-char
+  (lambda (c)
+    (unless (eof-object? c)
+      (cond
+       ((char=? c #\newline) (emit-newline))
+       (*outputting-to-non-html?* (emit c))
+       (else
+        (case c
+          ((#\<) (emit "&lt;"))
+          ((#\>) (emit "&gt;"))
+          ((#\") (emit "&quot;"))
+          ((#\&) (emit "&amp;"))
+          (else (emit c))))))))
+
+(define emit-html-string
+  (lambda (s)
+    (let ((n (string-length s)))
+      (let loop ((i 0))
+        (unless (>= i n) (emit-html-char (string-ref s i)) (loop (+ i 1)))))))
+
+(define member/string-ci=?
+  (lambda (s ss) (ormap (lambda (x) (string-ci=? x s)) ss)))
+
+(defstruct
+  texframe
+  (definitions '())
+  (chardefinitions '())
+  (counts '())
+  (toks '())
+  (dimens '())
+  (postludes '())
+  (aftergroups '()))
+
+(set! *global-texframe* (make-texframe))
+
+(define *primitive-texframe* (make-texframe))
+
+(define *math-primitive-texframe* (make-texframe))
+
+(define bgroup (lambda () (set! *tex-env* (cons (make-texframe) *tex-env*))))
+
+(define egroup
+  (lambda ()
+    (if (null? *tex-env*) (terror 'egroup "Too many }'s"))
+    (perform-postludes)
+    (perform-aftergroups)
+    (set! *tex-env* (cdr *tex-env*))))
+
+(define perform-postludes
+  (lambda () (for-each (lambda (p) (p)) (texframe.postludes (top-texframe)))))
+
+(define perform-aftergroups
+  (lambda ()
+    (let ((ags (texframe.aftergroups (top-texframe))))
+      (unless (null? ags) (toss-back-char *invisible-space*))
+      (for-each (lambda (ag) (ag)) ags))))
+
+(define add-postlude-to-top-frame
+  (lambda (p)
+    (let ((fr (if (null? *tex-env*) *global-texframe* (car *tex-env*))))
+      (set!texframe.postludes fr (cons p (texframe.postludes fr))))))
+
+(define add-aftergroup-to-top-frame
+  (lambda (ag)
+    (let ((fr (if (null? *tex-env*) *global-texframe* (car *tex-env*))))
+      (set!texframe.aftergroups fr (cons ag (texframe.aftergroups fr))))))
+
+(define top-texframe
+  (lambda () (if (null? *tex-env*) *global-texframe* (car *tex-env*))))
+
+(defstruct
+  tdef
+  (argpat '())
+  (expansion "")
+  (optarg #f)
+  (thunk #f)
+  (prim #f)
+  (defer #f))
+
+(defstruct cdef (argpat #f) (expansion #f) (optarg #f) (active #f))
+
+(define kopy-tdef
+  (lambda (lft rt)
+    (set!tdef.argpat lft (tdef.argpat rt))
+    (set!tdef.expansion lft (tdef.expansion rt))
+    (set!tdef.optarg lft (tdef.optarg rt))
+    (set!tdef.thunk lft (tdef.thunk rt))
+    (set!tdef.prim lft (tdef.prim rt))
+    (set!tdef.defer lft (tdef.defer rt))))
+
+(define kopy-cdef
+  (lambda (lft rt)
+    (set!cdef.argpat lft (cdef.argpat rt))
+    (set!cdef.expansion lft (cdef.expansion rt))
+    (set!cdef.optarg lft (cdef.optarg rt))
+    (set!cdef.active lft (cdef.active rt))))
+
+(define cleanse-tdef
+  (lambda (d)
+    (set!tdef.argpat d '())
+    (set!tdef.expansion d "")
+    (set!tdef.optarg d #f)
+    (set!tdef.thunk d #f)
+    (set!tdef.prim d #f)
+    (set!tdef.defer d #f)))
+
+(define tex-def
+  (lambda (name argpat expansion optarg thunk prim defer frame)
+    (unless frame (set! frame (top-texframe)))
+    (let ((d
+           (cond
+            ((lassoc name (texframe.definitions frame) string=?) => cdr)
+            (else
+             (let ((d (make-tdef)))
+               (set!texframe.definitions
+                 frame
+                 (cons (cons name d) (texframe.definitions frame)))
+               d)))))
+      (set!tdef.argpat d argpat)
+      (set!tdef.expansion d expansion)
+      (set!tdef.optarg d optarg)
+      (set!tdef.thunk d thunk)
+      (set!tdef.prim d prim)
+      (set!tdef.defer d defer))))
+
+(define tex-def-prim
+  (lambda (prim thunk)
+    (tex-def prim '() #f #f thunk prim #f *primitive-texframe*)))
+
+(define tex-def-0arg
+  (lambda (cs expn fr) (tex-def cs '() expn #f #f #f #f fr)))
+
+(define tex-let
+  (lambda (lft rt frame)
+    (unless frame (set! frame (top-texframe)))
+    (let ((lft-def
+            (cond
+             ((lassoc lft (texframe.definitions frame) string=?) => cdr)
+             (else
+              (let ((lft-def (make-tdef)))
+                (set!texframe.definitions
+                  frame
+                  (cons (cons lft lft-def) (texframe.definitions frame)))
+                lft-def)))))
+      (cond
+       ((find-def rt) => (lambda (rt-def) (kopy-tdef lft-def rt-def)))
+       (else (cleanse-tdef lft-def) (set!tdef.defer lft-def rt))))))
+
+(define tex-let-prim (lambda (lft rt) (tex-let lft rt *primitive-texframe*)))
+
+(define tex-def-thunk
+  (lambda (name thunk frame)
+    (unless (inside-false-world?)
+      (tex-def name '() #f #f thunk name #f frame))))
+
+(define tex-def-count
+  (lambda (name num global?)
+    (let ((frame (if global? *global-texframe* (top-texframe))))
+      (cond
+       ((lassoc name (texframe.counts frame) string=?)
+        =>
+        (lambda (c) (set-car! (cdr c) num)))
+       (else
+        (set!texframe.counts
+          frame
+          (cons (list name num) (texframe.counts frame))))))))
+
+(define tex-def-toks
+  (lambda (name tokens global?)
+    (let ((frame (if global? *global-texframe* (top-texframe))))
+      (cond
+       ((lassoc name (texframe.toks frame) string=?)
+        =>
+        (lambda (c) (set-car! (cdr c) tokens)))
+       (else
+        (set!texframe.toks
+          frame
+          (cons (list name tokens) (texframe.toks frame))))))))
+
+(define tex-def-dimen
+  (lambda (name global?)
+    (let ((frame (if global? *global-texframe* (top-texframe))))
+      (cond
+       ((lassoc name (texframe.dimens frame) string=?) #t)
+       (else
+        (set!texframe.dimens
+          frame
+          (cons (list name) (texframe.dimens frame))))))))
+
+(define tex-def-char
+  (lambda (char argpat expansion frame)
+    (unless frame (set! frame (top-texframe)))
+    (let ((d (ensure-cdef char frame)))
+      (set!cdef.argpat d argpat)
+      (set!cdef.expansion d expansion))))
+
+(define ensure-cdef
+  (lambda (c f)
+    (let ((x (assoc c (texframe.chardefinitions f))))
+      (if x
+        (cdr x)
+        (let ((d (make-cdef)))
+          (set!texframe.chardefinitions
+            f
+            (cons (cons c d) (texframe.chardefinitions f)))
+          d)))))
+
+(define find-chardef
+  (lambda (c)
+    (let ((x
+           (or (ormap
+                (lambda (f) (assoc c (texframe.chardefinitions f)))
+                *tex-env*)
+               (assoc c (texframe.chardefinitions *global-texframe*))
+               (assoc c (texframe.chardefinitions *primitive-texframe*)))))
+      (and x (let ((d (cdr x))) (and (cdef.active d) d))))))
+
+(define find-chardef-in-top-frame
+  (lambda (c)
+    (let ((x
+           (if (null? *tex-env*)
+             (or (assoc c (texframe.chardefinitions *global-texframe*))
+                 (assoc c (texframe.chardefinitions *primitive-texframe*)))
+             (assoc c (texframe.chardefinitions (car *tex-env*))))))
+      (and x (let ((d (cdr x))) (and (cdef.active d) d))))))
+
+(define do-defcsactive
+  (lambda (global?)
+    (ignorespaces)
+    (let* ((cs (get-ctl-seq))
+           (c (string-ref cs 1))
+           (argpat (get-def-arguments c))
+           (rhs (ungroup (get-group)))
+           (f (and global? *global-texframe*)))
+      (activate-cdef c)
+      (tex-def-char c argpat rhs f))))
+
+(define activate-cdef
+  (lambda (c)
+    (let ((y
+           (cond
+            ((find-chardef-in-top-frame c)
+             =>
+             (lambda (y) (set!cdef.active y #t) y))
+            (else
+             (let* ((d (find-chardef c)) (y (ensure-cdef c (top-texframe))))
+               (when d (kopy-cdef y d))
+               (set!cdef.active y #t)
+               y)))))
+      (add-postlude-to-top-frame (lambda () (set!cdef.active y #f))))))
+
+(define deactivate-cdef
+  (lambda (c)
+    (cond
+     ((find-chardef-in-top-frame c) => (lambda (y) (set!cdef.active y #f)))
+     ((find-chardef c)
+      =>
+      (lambda (y)
+        (let ((d (ensure-cdef c (top-texframe))))
+          (kopy-cdef d y)
+          (set!cdef.active d #f)))))))
+
+(define do-undefcsactive
+  (lambda () (ignorespaces) (deactivate-cdef (string-ref (get-ctl-seq) 1))))
+
+(define do-catcode
+  (lambda ()
+    (let* ((c (get-tex-char-spec)) (val (begin (get-equal-sign) (get-number))))
+      (if (= val 13)
+        (activate-cdef c)
+        (begin (deactivate-cdef c) (when (= val 0) (set! *esc-char* c)))))))
+
+(define do-global
+  (lambda ()
+    (ignorespaces)
+    (let ((next (get-ctl-seq)))
+      (cond
+       ((ormap (lambda (z) (string=? next z)) '("\\def" "\\edef")) (do-def #t))
+       ((string=? next "\\let") (do-let #t))
+       ((string=? next "\\newcount") (do-newcount #t))
+       ((string=? next "\\newtoks") (do-newtoks #t))
+       ((string=? next "\\newdimen") (do-newdimen #t))
+       ((string=? next "\\advance") (do-advance #t))
+       ((string=? next "\\multiply") (do-multiply #t))
+       ((string=? next "\\divide") (do-divide #t))
+       ((string=? next "\\read") (do-read #t))
+       ((ormap (lambda (z) (string=? next z)) '("\\imgdef" "\\gifdef"))
+        (make-reusable-img #t))
+       ((find-count next) (do-count= next #t))
+       ((find-toks next) (do-toks= next #t))
+       (else (toss-back-string next))))))
+
+(define do-externaltitle
+  (lambda ()
+    (write-aux `(!preferred-title ,(tex-string->html-string (get-group))))))
+
+(define tex2page-string
+  (lambda (s) (call-with-input-string/buffered s (lambda () (generate-html)))))
+
+(define make-external-title
+  (lambda (title)
+    (fluid-let
+      ((*outputting-external-title?* #t))
+      (bgroup)
+      (let ((s
+             (tex-string->html-string
+               (string-append
+                 "\\let\\\\\\ignorespaces"
+                 "\\def\\resizebox#1#2#3{}"
+                 "\\let\\thanks\\TIIPgobblegroup"
+                 "\\let\\urlh\\TIIPgobblegroup "
+                 title))))
+        (egroup)
+        s))))
+
+(define output-external-title
+  (lambda ()
+    (fluid-let
+      ((*outputting-external-title?* #t))
+      (emit "<title>")
+      (emit-newline)
+      (emit (or *title* *jobname*))
+      (emit-newline)
+      (emit "</title>")
+      (emit-newline))))
+
+(define output-title
+  (lambda (title)
+    (emit "<h1 class=title>")
+    (bgroup)
+    (tex2page-string (string-append "\\let\\\\\\break " title))
+    (egroup)
+    (emit "</h1>")
+    (emit-newline)))
+
+(define do-subject
+  (lambda ()
+    (do-end-para)
+    (let ((title (get-group)))
+      (unless *title* (flag-missing-piece 'document-title))
+      (write-aux `(!default-title ,(make-external-title title)))
+      (output-title title))))
+
+(define do-latex-title
+  (lambda ()
+    (let ((title (get-group)))
+      (unless *title* (flag-missing-piece 'document-title))
+      (write-aux `(!default-title ,(make-external-title title)))
+      (toss-back-string title)
+      (toss-back-string "\\def\\TIIPtitle"))))
+
+(define do-title
+  (lambda () ((if (eqv? *tex-format* 'latex) do-latex-title do-subject))))
+
+(define do-author (lambda () (toss-back-string "\\def\\TIIPauthor")))
+
+(define do-date (lambda () (toss-back-string "\\def\\TIIPdate")))
+
+(define do-today
+  (lambda ()
+    (let ((m (get-gcount "\\month")))
+      (if (= m 0)
+        (emit "[today]")
+        (begin
+          (emit (vector-ref *month-names* (- m 1)))
+          (emit " ")
+          (emit (get-gcount "\\day"))
+          (emit ", ")
+          (emit (get-gcount "\\year")))))))
+
+(define add-afterpar (lambda (ap) (set! *afterpar* (cons ap *afterpar*))))
+
+(define do-end-para
+  (lambda ()
+    (when *in-para?*
+      (when *use-closing-p-tag?* (emit "</p>"))
+      (unless (null? *afterpar*)
+        (for-each (lambda (ap) (ap)) (reverse! *afterpar*))
+        (set! *afterpar* '()))
+      (emit-newline)
+      (set! *in-para?* #f))))
+
+(define do-para
+  (lambda ()
+    (do-end-para)
+    (let ((in-table?
+            (and (not (null? *tabular-stack*))
+                 (memv (car *tabular-stack*) '(block)))))
+      (when in-table? (emit "</td></tr><tr><td>") (emit-newline))
+      (emit "<p>")
+      (set! *in-para?* #t))))
+
+(define do-maketitle
+  (lambda ()
+    (do-end-para)
+    (bgroup)
+    (tex2page-string
+      (string-append
+        "\\let\\\\\\break"
+        "\\let\\and\\break"
+        "\\let\\thanks\\symfootnote"))
+    (output-title "\\TIIPtitle")
+    (do-para)
+    (do-end-para)
+    (emit "<div align=center>")
+    (emit-newline)
+    (tex2page-string "\\TIIPauthor")
+    (do-para)
+    (tex2page-string "\\TIIPdate")
+    (do-end-para)
+    (emit "</div>")
+    (emit-newline)
+    (egroup)
+    (do-para)))
+
+(define do-inputcss
+  (lambda ()
+    (ignorespaces)
+    (let ((f (get-filename-possibly-braced)))
+      (when (null? *stylesheets*) (flag-missing-piece 'stylesheets))
+      (write-aux `(!stylesheet ,f)))))
+
+(define do-csname
+  (lambda ()
+    (ignorespaces)
+    (let loop ((r '()))
+      (let ((c (snoop-actual-char)))
+        (cond
+         ((char=? c *esc-char*)
+          (let ((x (get-ctl-seq)))
+            (cond
+             ((string=? x "\\endcsname")
+              (toss-back-char *invisible-space*)
+              (for-each toss-back-string r)
+              (toss-back-char *esc-char*))
+             (else (loop (cons (expand-ctl-seq-into-string x) r))))))
+         (else (get-actual-char) (loop (cons (string c) r))))))))
+
+(define do-cssblock
+  (lambda ()
+    (fluid-let
+      ((*dumping-nontex?* #t))
+      (dump-till-end-env "cssblock" *css-port*))))
+
+(define link-stylesheets
+  (lambda ()
+    (emit "<link rel=\"stylesheet\" type=\"text/css\" href=\"")
+    (emit *jobname*)
+    (emit *css-file-suffix*)
+    (emit "\" title=default>")
+    (emit-newline)
+    (for-each
+      (lambda (css)
+        (emit "<link rel=\"stylesheet\" type=\"text/css\" href=\"")
+        (emit css)
+        (emit "\" title=default>")
+        (emit-newline))
+      *stylesheets*)))
+
+(define increment-section-counter
+  (lambda (seclvl unnumbered?)
+    (unless unnumbered?
+      (hash-table-put!
+        *section-counters*
+        seclvl
+        (+ 1 (table-get *section-counters* seclvl 0))))
+    (hash-table-for-each
+      *section-counters*
+      (lambda (k v)
+        (if (and (> k seclvl) (> k 0))
+          (hash-table-put! *section-counters* k 0))))
+    (for-each
+      (lambda (counter-name)
+        (set!counter.value (table-get *dotted-counters* counter-name) 0))
+      (table-get *section-counter-dependencies* seclvl '()))))
+
+(define section-counter-value
+  (lambda (seclvl)
+    (if (= seclvl -1)
+      (number->roman (table-get *section-counters* -1) #t)
+      (let ((i (if *using-chapters?* 0 1)))
+        (let ((outermost-secnum
+                (let ((n (table-get *section-counters* i 0)))
+                  (if *inside-appendix?*
+                    (string (integer->char (+ (char->integer #\A) -1 n)))
+                    (number->string n)))))
+          (let loop ((i (+ i 1)) (r outermost-secnum))
+            (if (> i seclvl)
+              r
+              (loop
+               (+ i 1)
+               (string-append
+                 r
+                 "."
+                 (number->string (table-get *section-counters* i 0)))))))))))
+
+(define section-ctl-seq?
+  (lambda (s)
+    (cond
+     ((string=? s "\\sectiond") (string->number (ungroup (get-token))))
+     ((string=? s "\\part") -1)
+     ((string=? s "\\chapter")
+      (!using-chapters)
+      (write-aux `(!using-chapters))
+      (if (and (eqv? *tex-format* 'latex) (< (get-gcount "\\secnumdepth") -1))
+        (set-gcount! "\\secnumdepth" 2))
+      0)
+     (else
+      (let ((n (string-length s)))
+        (cond
+         ((< n 8) #f)
+         ((and (>= n 10) (string=? (substring s (- n 9) n) "paragraph"))
+          (let ((n-9 (- n 9)))
+            (let loop ((i 1) (i+3 4) (k 4))
+              (cond
+               ((> i+3 n-9) k)
+               ((string=? (substring s i i+3) "sub")
+                (loop i+3 (+ i+3 3) (+ k 1)))
+               (else #f)))))
+         ((string=? (substring s (- n 7) n) "section")
+          (let ((n-7 (- n 7)))
+            (let loop ((i 1) (i+3 4) (k 1))
+              (cond
+               ((> i+3 n-7) k)
+               ((string=? (substring s i i+3) "sub")
+                (loop i+3 (+ i+3 3) (+ k 1)))
+               (else #f)))))
+         (else #f)))))))
+
+(define do-heading
+  (lambda (seclvl)
+    (let* ((starred?
+             (cond
+              ((char=? (snoop-actual-char) #\*) (get-actual-char) #t)
+              (else #f)))
+           (too-deep?
+             (let ((secnumdepth (get-gcount "\\secnumdepth")))
+               (cond
+                ((< secnumdepth -1) #f)
+                ((> seclvl secnumdepth) #t)
+                (else #f))))
+           (unnumbered? (or starred? too-deep?)))
+      (if (<= seclvl 0) (do-eject))
+      (increment-section-counter seclvl unnumbered?)
+      (let* ((htmlnum
+               (max 1 (min 6 (if *using-chapters?* (+ seclvl 1) seclvl))))
+             (header (get-group))
+             (lbl-val (if unnumbered? "IGNORE" (section-counter-value seclvl)))
+             (lbl
+              (string-append
+                *html-node-prefix*
+                (case seclvl ((-1) "part") ((0) "chap") (else "sec"))
+                "_"
+                (if unnumbered? (gen-temp-string) lbl-val))))
+        (unless #f
+          (tex-def-toks "\\TIIPrecentlabelname" lbl #f)
+          (tex-def-toks "\\TIIPrecentlabelvalue" lbl-val #f))
+        (do-end-para)
+        (emit-anchor lbl)
+        (emit-newline)
+        (ignore-all-whitespace)
+        (emit "<h")
+        (emit htmlnum)
+        (case seclvl
+          ((-1) (emit " class=part align=center"))
+          ((0) (emit " class=chapter")))
+        (emit ">")
+        (let ((write-to-toc?
+                (and *toc-page*
+                     (not
+                      (and (eqv? *tex-format* 'latex)
+                           (string=? header "{Contents}"))))))
+          (case seclvl
+            ((-1)
+             (emit "<div class=partheading>")
+             (if unnumbered?
+               (emit-nbsp 1)
+               (begin
+                 (when write-to-toc?
+                   (emit-page-node-link-start
+                     *toc-page*
+                     (string-append *html-node-prefix* "toc_" lbl)))
+                 (tex2page-string "\\partname")
+                 (emit " ")
+                 (emit lbl-val)
+                 (when write-to-toc? (emit-link-stop))))
+             (emit "</div><br>")
+             (emit-newline))
+            ((0)
+             (emit-newline)
+             (emit "<div class=chapterheading>")
+             (if unnumbered?
+               (emit-nbsp 1)
+               (begin
+                 (when write-to-toc?
+                   (emit-page-node-link-start
+                     *toc-page*
+                     (string-append *html-node-prefix* "toc_" lbl)))
+                 (tex2page-string
+                   (if *inside-appendix?* "\\appendixname" "\\chaptername"))
+                 (emit " ")
+                 (emit lbl-val)
+                 (when write-to-toc? (emit-link-stop))))
+             (emit "</div><br>")
+             (emit-newline)))
+          (when write-to-toc?
+            (emit-page-node-link-start
+              *toc-page*
+              (string-append *html-node-prefix* "toc_" lbl)))
+          (unless (or (<= seclvl 0) unnumbered?) (emit lbl-val) (emit-nbsp 2))
+          (fluid-let
+            ((*tabular-stack* (list 'header)))
+            (tex2page-string header))
+          (when write-to-toc? (emit-link-stop))
+          (emit "</h")
+          (emit htmlnum)
+          (emit ">")
+          (emit-newline)
+          (do-para)
+          (let ((tocdepth (get-gcount "\\tocdepth")))
+            (when (and
+                   write-to-toc?
+                   (not (and (eqv? *tex-format* 'latex) starred?))
+                   (or (< tocdepth -1) (<= seclvl tocdepth)))
+              (write-aux
+                `(!toc-entry
+                   ,(if (= seclvl -1)
+                      -1
+                      (if *using-chapters?* seclvl (- seclvl 1)))
+                   ,lbl-val
+                   ,*html-page-count*
+                   ,lbl
+                   ,header)))))
+        (when *recent-node-name*
+          (do-label-aux *recent-node-name*)
+          (set! *recent-node-name* #f))))))
+
+(define do-addcontentsline
+  (lambda ()
+    (let* ((toc (get-group))
+           (section-type (string-trim-blanks (ungroup (get-group))))
+           (seclvl (if (string=? section-type "chapter") 0 1))
+           (header (get-group)))
+      (write-aux
+        `(!toc-entry
+           ,(if (= seclvl -1) -1 (if *using-chapters?* seclvl (- seclvl 1)))
+           ,(get-toks "\\TIIPrecentlabelvalue")
+           ,*html-page-count*
+           ,(get-toks "\\TIIPrecentlabelname")
+           ,header)))))
+
+(define do-documentclass
+  (lambda ()
+    (probably-latex)
+    (get-bracketed-text-if-any)
+    (let ((x (get-peeled-group)))
+      (when (ormap (lambda (z) (string=? x z)) '("report" "book"))
+        (!using-chapters)
+        (write-aux `(!using-chapters))))))
+
+(define do-beginsection
+  (lambda ()
+    (ignorespaces)
+    (let ((header
+            (let loop ((r '()) (newline? #f))
+              (let ((c (get-actual-char)))
+                (cond
+                 ((or (eof-object? c) (and newline? (char=? c #\newline)))
+                  (list->string (reverse! r)))
+                 (else
+                  (loop
+                   (cons c r)
+                   (if newline?
+                     (char-whitespace? c)
+                     (char=? c #\newline)))))))))
+      (do-end-para)
+      (emit "<h1 class=beginsection>")
+      (bgroup)
+      (fluid-let ((*tabular-stack* (list 'header))) (tex2page-string header))
+      (egroup)
+      (emit "</h1>")
+      (emit-newline))))
+
+(define do-appendix
+  (lambda ()
+    (unless *inside-appendix?*
+      (set! *inside-appendix?* #t)
+      (hash-table-put! *section-counters* (if *using-chapters?* 0 1) 0))))
+
+(define do-table-plain
+  (lambda () (do-end-para) (emit "<table width=100%><tr><td>")))
+
+(define do-end-table-plain
+  (lambda () (do-end-para) (emit "</td></tr></table>")))
+
+(define do-table/figure
+  (lambda (type)
+    (do-end-para)
+    (bgroup)
+    (when (and (eqv? type 'figure) (char=? (snoop-actual-char) #\*))
+      (get-actual-char))
+    (set! *tabular-stack* (cons type *tabular-stack*))
+    (get-bracketed-text-if-any)
+    (let ((tbl-tag
+            (string-append
+              *html-node-prefix*
+              (if (eqv? type 'table) "tbl_" "fig_")
+              (gen-temp-string))))
+      (tex-def-toks "\\TIIPrecentlabelname" tbl-tag #f)
+      (emit-anchor tbl-tag)
+      (emit-newline)
+      (emit "<div class=")
+      (emit type)
+      (emit " align=")
+      (emit *display-justification*)
+      (emit "><table width=100%><tr><td align=")
+      (emit *display-justification*)
+      (emit ">"))))
+
+(define pop-tabular-stack
+  (lambda (type)
+    (if (null? *tabular-stack*)
+      (terror 'pop-tabular-stack "Bad environment closer: " type)
+      (set! *tabular-stack* (cdr *tabular-stack*)))))
+
+(define do-end-table/figure
+  (lambda (type)
+    (when (and (eqv? type 'figure) (char=? (snoop-actual-char) #\*))
+      (get-actual-char))
+    (do-end-para)
+    (emit "</td></tr>")
+    (emit "</table>")
+    (emit "</div>")
+    (pop-tabular-stack type)
+    (egroup)
+    (do-para)))
+
+(define bump-dotted-counter
+  (lambda (name)
+    (let* ((counter (table-get *dotted-counters* name))
+           (new-value (+ 1 (counter.value counter))))
+      (set!counter.value counter new-value)
+      (let ((num
+             (string-append
+               (cond
+                ((counter.within counter)
+                 =>
+                 (lambda (sec-num)
+                   (string-append (section-counter-value sec-num) ".")))
+                (else ""))
+               (number->string new-value))))
+        (tex-def-toks "\\TIIPrecentlabelvalue" num #f)
+        num))))
+
+(define do-caption
+  (lambda ()
+    (do-end-para)
+    (let* ((i-fig (list-index *tabular-stack* 'figure))
+           (i-tbl (list-index *tabular-stack* 'table))
+           (type
+            (cond
+             ((and (not i-fig) (not i-tbl))
+              (terror 'do-caption "Mislaid \\caption"))
+             ((not i-fig) 'table)
+             ((not i-tbl) 'figure)
+             ((< i-fig i-tbl) 'figure)
+             ((< i-tbl i-fig) 'table)
+             (else (terror 'do-caption "cant happen"))))
+           (counter-name (if (eqv? type 'table) "table" "figure"))
+           (caption-title (if (eqv? type 'table) "\\tablename" "\\figurename"))
+           (num (bump-dotted-counter counter-name)))
+      (get-bracketed-text-if-any)
+      (emit "</td></tr>")
+      (emit-newline)
+      (emit "<tr><td align=")
+      (emit *display-justification*)
+      (emit "><b>")
+      (tex2page-string caption-title)
+      (emit " ")
+      (emit num)
+      (emit ":</b>")
+      (emit-nbsp 2)
+      (tex2page-string (get-group))
+      (emit "</td></tr>")
+      (emit-newline)
+      (emit "<tr><td>"))))
+
+(define do-marginpar
+  (lambda ()
+    (get-bracketed-text-if-any)
+    (emit "<table align=left border=2><tr><td>")
+    (tex2page-string (get-group))
+    (emit "</td></tr></table>")))
+
+(define do-minipage
+  (lambda ()
+    (get-bracketed-text-if-any)
+    (get-group)
+    (let ((in-table?
+            (and (not (null? *tabular-stack*))
+                 (memv (car *tabular-stack*) '(block figure table)))))
+      (if in-table? (emit "</td><td>") (begin (do-para) (do-end-para)))
+      (emit "<div align=left>")
+      (set! *tabular-stack* (cons 'minipage *tabular-stack*)))))
+
+(define do-endminipage
+  (lambda ()
+    (pop-tabular-stack 'minipage)
+    (let ((in-table?
+            (and (not (null? *tabular-stack*))
+                 (memv (car *tabular-stack*) '(block figure table)))))
+      (emit "</div>")
+      (if in-table? (emit "</td><td>") (do-para)))))
+
+(define do-tabbing
+  (lambda () (set! *tabular-stack* (cons 'tabbing *tabular-stack*)) (do-para)))
+
+(define do-end-tabbing (lambda () (pop-tabular-stack 'tabbing) (do-para)))
+
+(define do-equation
+  (lambda (type)
+    (cond
+     (*use-image-for-displayed-math?*
+      (do-latex-env-as-image
+        (if (eqv? type 'equation) "equation" "eqnarray")
+        'display))
+     (else
+      (do-end-para)
+      (bgroup)
+      (when (and (eqv? type 'eqnarray) (eat-star)) (set! type 'eqnarray*))
+      (set! *tabular-stack* (cons type *tabular-stack*))
+      (set! *math-mode?* #t)
+      (set! *in-display-math?* #t)
+      (let ((eqn-tag
+              (string-append *html-node-prefix* "eqn_" (gen-temp-string))))
+        (tex-def-toks "\\TIIPrecentlabelname" eqn-tag #f)
+        (emit-anchor eqn-tag)
+        (emit-newline)
+        (unless (eqv? type 'eqnarray*)
+          (set! *equation-number* (bump-dotted-counter "equation")))
+        (emit "<div align=")
+        (emit *display-justification*)
+        (emit "><table width=100%>")
+        (emit-newline)
+        (emit "<tr><td align=")
+        (emit (if (eqv? type 'equation) "center" "right"))
+        (emit ">"))))))
+
+(define do-end-equation
+  (lambda ()
+    (do-end-para)
+    (emit "</td>")
+    (unless (or
+             (and (not (null? *tabular-stack*))
+                  (eqv? (car *tabular-stack*) 'eqnarray*))
+             (not *equation-numbered?*))
+      (emit "<td>(")
+      (emit *equation-number*)
+      (emit ")</td>"))
+    (emit "</tr>")
+    (emit-newline)
+    (emit "</table></div>")
+    (pop-tabular-stack 'equation)
+    (set! *math-mode?* #f)
+    (set! *in-display-math?* #f)
+    (egroup)
+    (set! *equation-numbered?* #t)
+    (set! *equation-position* 0)
+    (do-para)))
+
+(define do-eqnarray
+  (lambda ()
+    (do-end-para)
+    (bgroup)
+    (let ((star? (eat-star)))
+      (set! *tabular-stack*
+        (cons (if star? 'eqnarray* 'eqnarray) *tabular-stack*))
+      (set! *math-mode?* #t)
+      (let ((eqn-tag
+              (string-append *html-node-prefix* "eqn_" (gen-temp-string))))
+        (tex-def-toks "\\TIIPrecentlabelname" eqn-tag #f)
+        (emit-anchor eqn-tag)
+        (emit-newline)
+        (emit "<div align=")
+        (emit *display-justification*)
+        (emit "><table width=100%>")
+        (emit-newline)
+        (emit "<tr><td align=right>")))))
+
+(define do-nonumber (lambda () (set! *equation-numbered?* #f)))
+
+(define indent-n-levels
+  (lambda (n)
+    (let loop ((i -1))
+      (unless (>= i n)
+        (emit-nbsp 1)
+        (emit " ")
+        (emit-nbsp 1)
+        (emit " ")
+        (loop (+ i 1))))))
+
+(define do-toc
+  (lambda ()
+    (fluid-let
+      ((*subjobname* (string-append *jobname* *toc-file-suffix*))
+       (*img-file-count* 0)
+       (*imgdef-file-count* 0))
+      (when (eqv? *tex-format* 'latex)
+        (tex2page-string
+          (if *using-chapters?*
+            "\\chapter*{\\contentsname}"
+            "\\section*{\\contentsname}")))
+      (emit-anchor (string-append *html-node-prefix* "toc_start"))
+      (!toc-page *html-page-count*)
+      (write-aux `(!toc-page ,*html-page-count*))
+      (cond
+       ((null? *toc-list*)
+        (flag-missing-piece 'toc)
+        (non-fatal-error "Table of contents not generated; rerun TeX2page"))
+       (else
+        (let ((tocdepth (get-gcount "\\tocdepth")))
+          (for-each
+            (lambda (x)
+              (let* ((lvl (tocentry.level x))
+                     (secnum (tocentry.number x))
+                     (seclabel (tocentry.label x))
+                     (subentries?
+                       (or (= lvl -1)
+                           (and (= lvl 0)
+                                (or (< tocdepth -1)
+                                    (and *using-chapters?* (> tocdepth 0))
+                                    (and (not *using-chapters?*)
+                                         (> tocdepth 1)))))))
+                (when subentries? (do-para) (emit "<b>") (emit-newline))
+                (indent-n-levels lvl)
+                (emit-anchor
+                  (string-append *html-node-prefix* "toc_" seclabel))
+                (emit-page-node-link-start (tocentry.page x) seclabel)
+                (unless (string=? secnum "IGNORE") (emit secnum) (emit-nbsp 2))
+                (fluid-let
+                  ((*tabular-stack* (list 'header)))
+                  (tex2page-string (tocentry.header x)))
+                (emit-link-stop)
+                (when subentries? (emit "</b>"))
+                (emit "<br>")
+                (emit-newline)))
+            *toc-list*)))))))
+
+(defstruct footnotev mark text tag caller)
+
+(define do-numbered-footnote (lambda () (do-footnote-aux #f)))
+
+(define do-symfootnote
+  (lambda ()
+    (set! *footnote-sym* (+ *footnote-sym* 1))
+    (do-footnote-aux (number->footnote-symbol *footnote-sym*))))
+
+(define number->footnote-symbol
+  (lambda (n)
+    (list-ref
+      '("*"
+        "\\dag"
+        "\\ddag"
+        "\\S"
+        "\\P"
+        "\\Vert"
+        "**"
+        "\\dag\\dag"
+        "\\ddag\\ddag")
+      (modulo (- n 1) 9))))
+
+(define do-plain-footnote
+  (lambda () (let ((fnmark (get-token))) (do-footnote-aux fnmark))))
+
+(define do-footnote
+  (lambda ()
+    ((if (eqv? *tex-format* 'latex) do-numbered-footnote do-plain-footnote))))
+
+(define do-footnote-aux
+  (lambda (non-number-mark)
+    (let* ((fnmark
+             (or non-number-mark
+                 (let ((n (+ (get-gcount "\\footnotenumber") 1)))
+                   (set-gcount! "\\footnotenumber" n)
+                   (number->string n))))
+           (fnlabel (if non-number-mark (gen-temp-string) fnmark))
+           (fntag (string-append *html-node-prefix* "footnote_" fnlabel))
+           (fncalltag
+             (string-append *html-node-prefix* "call_footnote_" fnlabel))
+           (fn-tmp-port (open-output-string)))
+      (emit-anchor fncalltag)
+      (emit-page-node-link-start #f fntag)
+      (emit "<sup><small>")
+      (tex2page-string fnmark)
+      (emit "</small></sup>")
+      (emit-link-stop)
+      (ignorespaces)
+      (unless (char=? (get-actual-char) #\{)
+        (terror 'do-footnote-aux "Missing {"))
+      (bgroup)
+      (let ((old-html *html*))
+        (set! *html* fn-tmp-port)
+        (tex-def-toks "\\TIIPrecentlabelname" fntag #f)
+        (tex-def-toks "\\TIIPrecentlabelvalue" fnmark #f)
+        (add-aftergroup-to-top-frame
+          (lambda ()
+            (set! *footnote-list*
+              (cons
+               (make-footnotev
+                 'mark
+                 fnmark
+                 'text
+                 (get-output-string fn-tmp-port)
+                 'tag
+                 fntag
+                 'caller
+                 fncalltag)
+               *footnote-list*))
+            (set! *html* old-html)))))))
+
+(define output-footnotes
+  (lambda ()
+    (let ((n (length *footnote-list*)))
+      (unless (= n 0)
+        (emit "<div class=footnoterule><hr></div>")
+        (do-para)
+        (do-end-para)
+        (emit "<div class=footnote>")
+        (let loop ((i (- n 1)))
+          (unless (< i 0)
+            (let ((fv (list-ref *footnote-list* i)))
+              (do-para)
+              (emit-anchor (footnotev.tag fv))
+              (emit-page-node-link-start #f (footnotev.caller fv))
+              (emit "<sup><small>")
+              (tex2page-string (footnotev.mark fv))
+              (emit "</small></sup>")
+              (emit-link-stop)
+              (emit " ")
+              (emit (footnotev.text fv))
+              (do-end-para)
+              (loop (- i 1)))))
+        (emit "</div>")
+        (emit-newline)))))
+
+(define rgb.dec->hex
+  (let ((f
+         (lambda (x)
+           (let* ((n (inexact->exact (round (* 1.0 x))))
+                  (s (number->string n 16)))
+             (if (< n 16) (string-append "0" s) s)))))
+    (lambda (r g b) (string-append (f r) (f g) (f b)))))
+
+(define rgb.frac->hex
+  (lambda (r g b) (rgb.dec->hex (* r 255) (* g 255) (* b 255))))
+
+(define cmyk->rgb
+  (let ((f (lambda (x k) (- 1 (min (max (+ x k) 0) 1)))))
+    (lambda (c m y k) (rgb.frac->hex (f c k) (f m k) (f y k)))))
+
+(define do-color
+  (lambda ()
+    (let ((model (get-bracketed-text-if-any)))
+      (do-switch
+        (cond
+         ((not model) 'colornamed)
+         ((string=? model "rgb") 'rgb)
+         ((string=? model "RGB") 'rgb255)
+         ((string=? model "cmyk") 'cmyk)
+         ((string=? model "gray") 'gray)
+         (else 'colornamed))))))
+
+(define do-definecolor
+  (lambda ()
+    (let* ((name (get-peeled-group))
+           (model (get-peeled-group))
+           (spec (get-peeled-group)))
+      (bgroup)
+      (set! *color-names*
+        (cons
+         (cons
+          name
+          (if (string=? model "named")
+            (let ((c (lassoc name *color-names* string=?)))
+              (if c
+                (cdr c)
+                (terror 'do-definecolor "Color name " name " not defined")))
+            (let ((rgb #f))
+              (call-with-input-string
+                (tex-string->html-string
+                  (string-append "\\defcsactive\\,{ }" spec))
+                (lambda (i)
+                  (cond
+                   ((string=? model "cmyk")
+                    (let* ((c (read i)) (m (read i)) (y (read i)) (k (read i)))
+                      (cmyk->rgb c m y k)))
+                   ((string=? model "rgb")
+                    (let* ((r (read i)) (g (read i)) (b (read i)))
+                      (rgb.frac->hex r g b)))
+                   ((string=? model "gray") (cmyk->rgb 0 0 0 (read i)))
+                   (else (terror 'do-definecolor "Unknown color model"))))))))
+         *color-names*))
+      (egroup))))
+
+(define do-switch
+  (lambda (sw)
+    (ignorespaces)
+    (unless *outputting-external-title?*
+      (add-postlude-to-top-frame
+        (case sw
+          ((rm)
+           (when *math-mode?*
+             (let ((old-math-roman-mode? *math-roman-mode?*))
+               (set! *math-roman-mode?* #t)
+               (lambda () (set! *math-roman-mode?* old-math-roman-mode?)))))
+          ((em) (emit "<em>") (lambda () (emit "</em>")))
+          ((it itshape sl) (emit "<i>") (lambda () (emit "</i>")))
+          ((bf strong) (emit "<strong>") (lambda () (emit "</strong>")))
+          ((tt)
+           (let ((old-ligatures? *ligatures?*))
+             (set! *ligatures?* #f)
+             (emit "<tt>")
+             (lambda () (emit "</tt>") (set! *ligatures?* old-ligatures?))))
+          ((sc scshape)
+           (let ((old-in-small-caps? *in-small-caps?*))
+             (set! *in-small-caps?* #t)
+             (lambda () (set! *in-small-caps?* old-in-small-caps?))))
+          ((tiny) (emit "<span class=tiny>") (lambda () (emit "</span>")))
+          ((scriptsize)
+           (emit "<span class=scriptsize>")
+           (lambda () (emit "</span>")))
+          ((footnotesize fiverm)
+           (emit "<span class=footnotesize>")
+           (lambda () (emit "</span>")))
+          ((small sevenrm)
+           (emit "<span class=small>")
+           (lambda () (emit "</span>")))
+          ((normalsize)
+           (emit "<span class=normalsize>")
+           (lambda () (emit "</span>")))
+          ((large) (emit "<span class=large>") (lambda () (emit "</span>")))
+          ((large-cap)
+           (emit "<span class=largecap>")
+           (lambda () (emit "</span>")))
+          ((large-up)
+           (emit "<span class=largeup>")
+           (lambda () (emit "</span>")))
+          ((huge) (emit "<span class=huge>") (lambda () (emit "</span>")))
+          ((huge-cap)
+           (emit "<span class=hugecap>")
+           (lambda () (emit "</span>")))
+          ((cmyk)
+           (bgroup)
+           (call-with-input-string
+             (tex-string->html-string
+               (string-append "\\defcsactive\\,{}" (get-token)))
+             (lambda (i)
+               (let* ((c (read i)) (m (read i)) (y (read i)) (k (read i)))
+                 (ignorespaces)
+                 (emit "<font color=\"#")
+                 (emit (cmyk->rgb c m y k))
+                 (emit "\">"))))
+           (egroup)
+           (lambda () (emit "</font>")))
+          ((rgb)
+           (bgroup)
+           (call-with-input-string
+             (tex-string->html-string
+               (string-append "\\defcsactive\\,{}" (get-token)))
+             (lambda (i)
+               (let* ((r (read i)) (g (read i)) (b (read i)))
+                 (ignorespaces)
+                 (emit "<font color=\"#")
+                 (emit (rgb.frac->hex r g b))
+                 (emit "\">"))))
+           (egroup)
+           (lambda () (emit "</font>")))
+          ((rgb255)
+           (bgroup)
+           (call-with-input-string
+             (tex-string->html-string
+               (string-append "\\defcsactive\\,{}" (get-token)))
+             (lambda (i)
+               (let* ((r (read i)) (g (read i)) (b (read i)))
+                 (ignorespaces)
+                 (emit "<font color=\"#")
+                 (emit (rgb.dec->hex r g b))
+                 (emit "\">"))))
+           (egroup)
+           (lambda () (emit "</font>")))
+          ((gray)
+           (call-with-input-string
+             (tex-string->html-string (get-token))
+             (lambda (i)
+               (let ((g (read i)))
+                 (ignorespaces)
+                 (emit "<font color=\"#")
+                 (emit (cmyk->rgb 0 0 0 (- 1 g)))
+                 (emit "\">"))))
+           (lambda () (emit "</font>")))
+          ((colornamed)
+           (let* ((name (get-peeled-group))
+                  (c (lassoc name *color-names* string=?)))
+             (ignorespaces)
+             (emit "<font color=\"")
+             (emit (if c (begin (emit #\#) (cdr c)) name))
+             (emit "\">")
+             (lambda () (emit "</font>"))))
+          ((bgcolor)
+           (emit "<font style=\"background-color: ")
+           (let ((color (ungroup (get-group))))
+             (if (string->number color 16) (emit "#"))
+             (emit color)
+             (emit "\">")
+             (lambda () (emit "</font>"))))
+          ((strike) (emit "<strike>") (lambda () (emit "</strike>")))
+          ((narrower) (emit "<blockquote>") (lambda () (emit "</blockquote>")))
+          ((raggedleft)
+           (do-end-para)
+           (emit "<div align=right>")
+           (lambda () (do-end-para) (emit "</div>") (do-para)))
+          (else (terror 'do-switch "Unknown switch " sw)))))))
+
+(define do-obeylines
+  (lambda ()
+    (if (eqv? (snoop-actual-char) #\newline) (get-actual-char))
+    (activate-cdef #\newline)
+    (tex-def-char #\newline '() "\\TIIPbr" #f)))
+
+(define do-obeyspaces
+  (lambda ()
+    (activate-cdef #\space)
+    (tex-def-char #\space '() "\\TIIPnbsp" #f)))
+
+(define do-obeywhitespace (lambda () (do-obeylines) (do-obeyspaces)))
+
+(define do-block
+  (lambda (z)
+    (do-end-para)
+    (emit "<div ")
+    (emit
+     (case z
+       ((flushleft) "align=left")
+       ((flushright) "align=right")
+       (else "align=center")))
+    (emit ">")
+    (set! *tabular-stack* (cons 'block *tabular-stack*))
+    (emit "<table><tr><td>")
+    (bgroup)
+    (emit-newline)))
+
+(define do-end-block
+  (lambda ()
+    (do-end-para)
+    (egroup)
+    (emit "</td></tr></table></div>")
+    (pop-tabular-stack 'block)
+    (emit-newline)))
+
+(define do-function
+  (lambda (fn)
+    (fluid-let
+      ((*math-mode?* *math-mode?*))
+      (cond
+       (*outputting-external-title?* #f)
+       ((string=? fn "\\emph") (emit "<em>"))
+       ((string=? fn "\\leftline") (do-end-para) (emit "<div align=left>"))
+       ((string=? fn "\\centerline")
+        (do-end-para)
+        (emit "<div align=center>&nbsp;"))
+       ((string=? fn "\\rightline")
+        (do-end-para)
+        (emit "<div align=right>&nbsp;"))
+       ((string=? fn "\\underline") (emit "<u>"))
+       ((string=? fn "\\textbf") (set! *math-mode?* #f) (emit "<b>"))
+       ((ormap (lambda (z) (string=? fn z)) '("\\textit" "\\textsl"))
+        (set! *math-mode?* #f)
+        (emit "<i>"))
+       ((string=? fn "\\textrm") (set! *math-mode?* #f))
+       ((string=? fn "\\texttt") (set! *math-mode?* #f) (emit "<tt>"))
+       (else (terror 'do-function "Unknown function " fn)))
+      (bgroup)
+      (tex2page-string (get-token))
+      (egroup)
+      (cond
+       (*outputting-external-title?* #f)
+       ((string=? fn "\\emph") (emit "</em>"))
+       ((string=? fn "\\rightline") (emit "</div>") (emit-newline))
+       ((ormap (lambda (z) (string=? fn z)) '("\\leftline" "\\centerline"))
+        (do-end-para)
+        (emit "&nbsp;</div>")
+        (emit-newline))
+       ((string=? fn "\\underline") (emit "</u>"))
+       ((string=? fn "\\textbf") (emit "</b>"))
+       ((ormap (lambda (z) (string=? fn z)) '("\\textsl" "\\textit"))
+        (emit "</i>"))
+       ((string=? fn "\\texttt") (emit "</tt>"))))))
+
+(define do-discretionary
+  (lambda () (tex2page-string (get-group)) (get-group) (get-group)))
+
+(define do-aftergroup
+  (lambda ()
+    (ignorespaces)
+    (let ((z (get-ctl-seq)))
+      (add-aftergroup-to-top-frame (lambda () (toss-back-string z))))))
+
+(define do-space (lambda () (emit #\space)))
+
+(define do-tab (lambda () (emit-nbsp 8)))
+
+(define emit-nbsp
+  (lambda (n)
+    (let loop ((n n)) (unless (<= n 0) (emit "&nbsp;") (loop (- n 1))))))
+
+(define get-pixels
+  (lambda ()
+    (let ((n (or (get-real) 1)))
+      (ignorespaces)
+      (inexact->exact
+        (floor
+         (*
+          n
+          1.0
+          (if (char=? (snoop-actual-char) *esc-char*)
+            (let ((x (get-ctl-seq))) (* 6.5 72.27))
+            (let loop ()
+              (cond
+               ((eat-word "bp") (* (/ 72) 72.27))
+               ((eat-word "cc") (* 12 1238 (/ 1157)))
+               ((eat-word "cm") (* (/ 2.54) 72.27))
+               ((eat-word "dd") (/ 1238 1157))
+               ((eat-word "em") 10)
+               ((eat-word "ex") 4.5)
+               ((eat-word "in") 72.27)
+               ((eat-word "mm") (* 0.1 (/ 2.54) 72.27))
+               ((eat-word "pc") 12)
+               ((eat-word "pt") 1)
+               ((eat-word "sp") (/ 65536))
+               ((eat-word "true") (loop))
+               (else 1))))))))))
+
+(define do-hskip (lambda () (emit-nbsp (/ (get-pixels) 5))))
+
+(define do-newline
+  (lambda () (when (>= (munch-newlines) 1) (do-para)) (emit-newline)))
+
+(define do-br
+  (lambda ()
+    (if (or (find-chardef #\space)
+            (not (= (the-count "\\TIIPobeylinestrictly") 0)))
+      (emit "<br>")
+      (unless (eqv? (snoop-actual-char) #\newline) (emit "<br>")))
+    (emit-newline)))
+
+(define do-sup
+  (lambda ()
+    (emit "<sup>")
+    (fluid-let ((*math-script-mode?* #t)) (tex2page-string (get-token)))
+    (emit "</sup>")))
+
+(define do-sub
+  (lambda ()
+    (emit "<sub>")
+    (fluid-let ((*math-script-mode?* #t)) (tex2page-string (get-token)))
+    (emit "</sub>")))
+
+(define do-hyphen
+  (lambda ()
+    (cond
+     (*math-mode?*
+      (emit
+       (cond
+        (*math-roman-mode?* "-")
+        (*math-script-mode?* "<tt>-</tt>")
+        (else " <tt>-</tt> "))))
+     ((not *ligatures?*) (emit #\-))
+     (else
+      (let ((c (snoop-actual-char)))
+        (if (and (char? c) (char=? c #\-))
+          (begin (get-actual-char) (do-ndash))
+          (emit #\-)))))))
+
+(define do-excl
+  (lambda ()
+    (if (or *math-mode?* (not *ligatures?*))
+      (emit #\!)
+      (let ((c (snoop-actual-char)))
+        (if (and (char? c) (char=? c #\`))
+          (begin (get-actual-char) (emit "&iexcl;"))
+          (emit #\!))))))
+
+(define do-quest
+  (lambda ()
+    (if (or *math-mode?* (not *ligatures?*))
+      (emit #\?)
+      (let ((c (snoop-actual-char)))
+        (if (and (char? c) (char=? c #\`))
+          (begin (get-actual-char) (emit "&iquest;"))
+          (emit #\?))))))
+
+(define do-ndash
+  (lambda ()
+    (emit
+     (let ((c (snoop-actual-char)))
+       (if (and (char? c) (char=? c #\-))
+         (begin (get-actual-char) *html-mdash*)
+         *html-ndash*)))))
+
+(define do-lsquo
+  (lambda ()
+    (emit
+     (if (not *ligatures?*)
+       *html-lsquo*
+       (let ((c (snoop-actual-char)))
+         (if (and (char? c) (char=? c #\`))
+           (begin (get-actual-char) *html-ldquo*)
+           *html-lsquo*))))))
+
+(define do-rsquo
+  (lambda ()
+    (emit
+     (if (not *ligatures?*)
+       *html-rsquo*
+       (let ((c (snoop-actual-char)))
+         (if (and (char? c) (char=? c #\'))
+           (begin (get-actual-char) *html-rdquo*)
+           *html-rsquo*))))))
+
+(defstruct label (src #f) page name value)
+
+(define get-label
+  (lambda ()
+    (let loop ((lbl (get-peeled-group)))
+      (let ((i
+             (or (string-index lbl #\space)
+                 (string-index lbl *tab*)
+                 (string-index lbl #\newline))))
+        (if (not i)
+          lbl
+          (let loop ((s (string->list lbl)) (r '()) (ws? #f))
+            (if (null? s)
+              (list->string (reverse! r))
+              (let ((c (car s)))
+                (loop
+                 (cdr s)
+                 (if (char-whitespace? c)
+                   (if ws? r (cons #\space r))
+                   (cons c r))
+                 (char-whitespace? c))))))))))
+
+(define emit-anchor
+  (lambda (lbl) (emit "<a name=\"") (emit lbl) (emit "\"></a>")))
+
+(define emit-link-start
+  (lambda (link) (emit "<a href=\"") (emit link) (emit "\">")))
+
+(define emit-ext-page-node-link-start
+  (lambda (extfile pageno node)
+    (emit "<a href=\"")
+    (unless (and (not extfile) (or (not pageno) (= *html-page-count* pageno)))
+      (emit (or extfile *jobname*))
+      (unless (= pageno 0) (emit *html-page-suffix*) (emit pageno))
+      (emit *output-extension*))
+    (when node (emit "#") (emit node))
+    (emit "\">")))
+
+(define emit-page-node-link-start
+  (lambda (pageno node) (emit-ext-page-node-link-start #f pageno node)))
+
+(define emit-link-stop (lambda () (emit "</a>")))
+
+(define do-label (lambda () (do-label-aux (get-label))))
+
+(define do-node (lambda () (set! *recent-node-name* (get-peeled-group))))
+
+(define do-label-aux
+  (lambda (label)
+    (let ((name (get-toks "\\TIIPrecentlabelname"))
+          (value (get-toks "\\TIIPrecentlabelvalue")))
+      (!label label *html-page-count* name value)
+      (write-label `(!label ,label ,*html-page-count* ,name ,value)))))
+
+(define do-inputexternallabels
+  (lambda ()
+    (let* ((f (get-filename-possibly-braced))
+           (fq-f
+            (if (fully-qualified-pathname? f) f (string-append *aux-dir/* f)))
+           (ext-label-file (string-append fq-f *label-file-suffix* ".scm"))
+           (ext-label-table (table-get *external-label-tables* f)))
+      (unless ext-label-table
+        (set! ext-label-table (make-table 'equ string=?))
+        (hash-table-put! *external-label-tables* f ext-label-table))
+      (when (file-exists? ext-label-file)
+        (fluid-let
+          ((*label-source* fq-f) (*label-table* ext-label-table))
+          (load-tex2page-data-file ext-label-file))))))
+
+(define do-includeexternallabels
+  (lambda ()
+    (let ((jobname (get-filename-possibly-braced)))
+      (let ((ext-label-file
+              (string-append
+                (if (fully-qualified-pathname? jobname)
+                  jobname
+                  (string-append *aux-dir/* jobname))
+                *label-file-suffix*
+                ".scm")))
+        (when (file-exists? ext-label-file)
+          (fluid-let
+            ((*label-source* jobname))
+            (load-tex2page-data-file ext-label-file)))))))
+
+(define do-tag
+  (lambda ()
+    (let ((tag-name (get-peeled-group))) (do-tag-aux tag-name (get-group)))))
+
+(define do-tag-aux
+  (lambda (tag-name tag-val)
+    (let ((node-name
+            (string-append *html-node-prefix* "tag_" (gen-temp-string))))
+      (tex-def-toks "\\TIIPrecentlabelname" node-name #f)
+      (tex-def-toks "\\TIIPrecentlabelvalue" tag-val #f)
+      (emit-anchor node-name)
+      (do-label-aux tag-name))))
+
+(define do-htmlpagelabel
+  (lambda ()
+    (let ((label (get-peeled-group)))
+      (!label label *html-page-count* #f #f)
+      (write-label `(!label ,label ,*html-page-count* #f #f)))))
+
+(define do-ref (lambda () (do-ref-aux (get-label) #f #f)))
+
+(define do-refexternal
+  (lambda ()
+    (let ((ext-file (get-peeled-group)))
+      (do-ref-aux (get-label) ext-file #f))))
+
+(define do-ref-aux
+  (lambda (label ext-file link-text)
+    (let* ((label-ref (label-bound? label ext-file))
+           (label-text
+             (cond
+              (link-text (tex-string->html-string link-text))
+              (label-ref (tex-string->html-string (label.value label-ref)))
+              (else label))))
+      (if label-ref
+        (emit-ext-page-node-link-start
+          (or ext-file (label.src label-ref))
+          (label.page label-ref)
+          (label.name label-ref))
+        (emit-link-start (string-append *jobname* ".hlog")))
+      (emit label-text)
+      (emit-link-stop))))
+
+(define maybe-label-page
+  (lambda (this-label-src this-label-pageno)
+    (if (and (not this-label-src) (= *html-page-count* this-label-pageno))
+      "#"
+      (string-append
+        (or this-label-src *jobname*)
+        (if (= this-label-pageno 0)
+          ""
+          (string-append
+            *html-page-suffix*
+            (number->string this-label-pageno)))
+        *output-extension*))))
+
+(define do-htmlref
+  (lambda ()
+    (let* ((text (get-group)) (lbl (get-peeled-group)))
+      (do-ref-aux lbl #f text))))
+
+(define do-htmlrefexternal
+  (lambda ()
+    (let* ((text (get-group))
+           (extf (get-peeled-group))
+           (lbl (get-peeled-group)))
+      (do-ref-aux lbl extf text))))
+
+(define do-hyperref
+  (lambda ()
+    (let* ((text (get-group))
+           (lbl (begin (get-group) (get-group) (get-peeled-group))))
+      (do-ref-aux lbl #f text))))
+
+(define do-hypertarget
+  (lambda () (let ((lbl (get-peeled-group))) (do-tag-aux lbl "hypertarget"))))
+
+(define do-hyperlink
+  (lambda ()
+    (emit-link-start
+      (fully-qualify-url (string-append "#" (get-peeled-group))))
+    (tex2page-string (get-token))
+    (emit-link-stop)))
+
+(define label-bound?
+  (lambda (label . ext-file)
+    (let* ((ext-file (if (pair? ext-file) (car ext-file) #f))
+           (label-table
+             (if ext-file
+               (table-get *external-label-tables* ext-file)
+               *label-table*)))
+      (or (and label-table (table-get label-table label))
+          (begin
+            (flag-unresolved-xref
+              (if ext-file
+                (string-append "{" ext-file " -> " label "}")
+                label))
+            #f)))))
+
+(define flag-unresolved-xref
+  (lambda (xr)
+    (unless (member xr *unresolved-xrefs*)
+      (set! *unresolved-xrefs* (cons xr *unresolved-xrefs*)))))
+
+(define flag-missing-piece
+  (lambda (mp)
+    (unless (member mp *missing-pieces*)
+      (set! *missing-pieces* (cons mp *missing-pieces*)))))
+
+(define show-unresolved-xrefs-and-missing-pieces
+  (lambda ()
+    (unless (and (null? *unresolved-xrefs*) (null? *missing-pieces*))
+      (show-unresolved-xrefs)
+      (show-missing-pieces)
+      (write-log 'separation-newline)
+      (write-log "Rerun: tex2page ")
+      (write-log *main-tex-file*)
+      (write-log 'separation-newline)
+      (write-log "If problem persists, check for ")
+      (write-log "missing \\label's and \\bibitem's"))))
+
+(define show-unresolved-xrefs
+  (lambda ()
+    (unless (null? *unresolved-xrefs*)
+      (write-log 'separation-newline)
+      (write-log "Unresolved cross-reference")
+      (if (> (length *unresolved-xrefs*) 1) (write-log "s"))
+      (write-log ": ")
+      (set! *unresolved-xrefs* (reverse! *unresolved-xrefs*))
+      (write-log (car *unresolved-xrefs*))
+      (for-each
+        (lambda (x)
+          (write-log #\,)
+          (write-log 'separation-space)
+          (write-log x))
+        (cdr *unresolved-xrefs*))
+      (write-log 'separation-newline))))
+
+(define show-missing-pieces
+  (lambda ()
+    (unless (null? *missing-pieces*)
+      (write-log 'separation-newline)
+      (when (memv 'document-title *missing-pieces*)
+        (write-log "Document title not determined")
+        (write-log 'separation-newline))
+      (when (memv 'last-page *missing-pieces*)
+        (write-log "Last page not determined")
+        (write-log 'separation-newline))
+      (when (memv 'last-modification-time *missing-pieces*)
+        (write-log "Last modification time not determined")
+        (write-log 'separation-newline))
+      (when (memv 'stylesheets *missing-pieces*)
+        (write-log "Style sheets not determined")
+        (write-log 'separation-newline))
+      (when (memv 'html-head *missing-pieces*)
+        (write-log "HTML header info not determined")
+        (write-log 'separation-newline))
+      (when (memv 'toc *missing-pieces*)
+        (write-log "Table of contents not determined")
+        (write-log 'separation-newline))
+      (cond
+       ((memv 'fresh-index *missing-pieces*)
+        (write-log "Index not refreshed")
+        (write-log 'separation-newline))
+       ((memv 'index *missing-pieces*)
+        (write-log "Index not included")
+        (write-log 'separation-newline)))
+      (cond
+       ((memv 'fresh-bibliography *missing-pieces*)
+        (write-log "Bibliography not refreshed")
+        (write-log 'separation-newline))
+       ((memv 'bibliography *missing-pieces*)
+        (write-log "Bibliography not included")
+        (write-log 'separation-newline)))
+      (when (memv 'metapost *missing-pieces*)
+        (write-log "MetaPost output not included")
+        (write-log 'separation-newline)))))
+
+(define do-pageref
+  (lambda ()
+    (let ((label-ref (label-bound? (get-peeled-group))))
+      (if label-ref
+        (let ((pageno (label.page label-ref)))
+          (emit-ext-page-node-link-start (label.src label-ref) pageno #f)
+          (emit pageno)
+          (emit-link-stop))
+        (non-fatal-error "***")))))
+
+(define do-htmlpageref
+  (lambda ()
+    (let ((label (get-peeled-group)))
+      (let ((label-ref (label-bound? label)))
+        (emit "\"")
+        (if label-ref
+          (emit
+           (maybe-label-page (label.src label-ref) (label.page label-ref)))
+          (emit *log-file*))
+        (emit "\"")))))
+
+(define fully-qualify-url
+  (lambda (url)
+    (let ((n (string-length url)))
+      (cond
+       ((and (> n 0) (char=? (string-ref url 0) #\#))
+        (let* ((label (substring url 1 n)) (label-ref (label-bound? label)))
+          (if label-ref
+            (string-append
+              (maybe-label-page (label.src label-ref) (label.page label-ref))
+              "#"
+              (label.name label-ref))
+            url)))
+       ((fully-qualified-url? url) url)
+       (else (ensure-url-reachable url) url)))))
+
+(define do-url
+  (lambda ()
+    (let ((url (get-url)))
+      (emit-link-start (fully-qualify-url url))
+      (emit url)
+      (emit-link-stop))))
+
+(define do-mailto
+  (lambda ()
+    (let ((addr (get-url)))
+      (emit-link-start (string-append "mailto:" addr))
+      (emit addr)
+      (emit-link-stop))))
+
+(define do-urlh
+  (lambda ()
+    (emit-link-start (fully-qualify-url (get-url)))
+    (bgroup)
+    (tex2page-string
+      (string-append "\\def\\\\{\\egroup\\endinput}" (get-token)))
+    (egroup)
+    (emit-link-stop)))
+
+(define do-urlhd (lambda () (do-urlh) (get-token)))
+
+(define do-urlp
+  (lambda ()
+    (let ((link-text (get-token)))
+      (emit-link-start (fully-qualify-url (get-url)))
+      (tex2page-string link-text)
+      (emit-link-stop))))
+
+(define do-htmladdimg
+  (lambda ()
+    (let* ((align-info (get-bracketed-text-if-any))
+           (url (fully-qualify-url (get-url))))
+      (emit "<img src=\"")
+      (emit url)
+      (emit "\" border=\"0\" ")
+      (when align-info (tex2page-string align-info))
+      (emit " alt=\"[")
+      (emit url)
+      (emit "]\">"))))
+
+(define do-pdfximage
+  (lambda ()
+    (let ((height #f) (width #f) (depth #f))
+      (let loop ()
+        (cond
+         ((eat-word "height") (set! height (get-pixels)) (loop))
+         ((eat-word "width") (set! width (get-pixels)) (loop))
+         ((eat-word "depth") (set! depth (get-pixels)) (loop))
+         (else #f)))
+      (emit "<img")
+      (when height (emit " height=") (emit height))
+      (when width (emit " width=") (emit width))
+      (emit " src=\"")
+      (emit (fully-qualify-url (get-filename-possibly-braced)))
+      (emit "\">")
+      (ignorespaces)
+      (get-ctl-seq)
+      (ignorespaces)
+      (get-ctl-seq))))
+
+(define do-cite
+  (lambda ()
+    (let ((extra-text (get-bracketed-text-if-any)))
+      (emit "[")
+      (ignorespaces)
+      (unless (char=? (get-actual-char) #\{) (terror 'do-cite "Missing {"))
+      (let ((first-key? #t))
+        (let loop ()
+          (cond
+           ((get-csv)
+            =>
+            (lambda (key)
+              (if first-key?
+                (set! first-key? #f)
+                (begin (emit ",") (emit-nbsp 1)))
+              (write-bib-aux "\\citation{")
+              (write-bib-aux key)
+              (write-bib-aux "}")
+              (write-bib-aux #\newline)
+              (do-ref-aux (string-append "cite{" key "}") #f #f)
+              (loop)))
+           (extra-text (emit ",") (emit-nbsp 1) (tex2page-string extra-text))))
+        (unless (char=? (get-actual-char) #\}) (terror 'do-cite "Missing }"))
+        (if first-key? (terror 'do-cite "Empty \\cite")))
+      (emit "]"))))
+
+(define do-nocite
+  (lambda ()
+    (ignorespaces)
+    (unless (char=? (get-actual-char) #\{) (terror 'do-cite "Missing {"))
+    (let loop ()
+      (cond
+       ((get-csv)
+        =>
+        (lambda (key)
+          (write-bib-aux "\\citation{")
+          (write-bib-aux key)
+          (write-bib-aux "}")
+          (write-bib-aux #\newline)
+          (loop)))))
+    (unless (char=? (get-actual-char) #\}) (terror 'do-nocite "Missing }"))))
+
+(define do-bibliographystyle
+  (lambda ()
+    (let ((s (ungroup (get-token))))
+      (write-bib-aux "\\bibstyle{")
+      (write-bib-aux s)
+      (write-bib-aux "}")
+      (write-bib-aux #\newline))))
+
+(define do-bibliography
+  (lambda ()
+    (set! *using-bibliography?* #t)
+    (let ((bibdata (ungroup (get-token)))
+          (bbl-file
+            (string-append *aux-dir/* *jobname* *bib-aux-file-suffix* ".bbl")))
+      (write-bib-aux "\\bibdata{")
+      (write-bib-aux bibdata)
+      (write-bib-aux "}")
+      (write-bib-aux #\newline)
+      (cond
+       ((file-exists? bbl-file)
+        (set! *bibitem-num* 0)
+        (tex2page-file bbl-file)
+        (emit-newline))
+       (else
+        (flag-missing-piece 'bibliography)
+        (non-fatal-error "Bibliography not generated; rerun TeX2page"))))))
+
+(define do-thebibliography
+  (lambda ()
+    (get-group)
+    (when (eqv? *tex-format* 'latex)
+      (tex2page-string
+        (if *using-chapters?*
+          "\\chapter*{\\bibname}"
+          "\\section*{\\refname}")))
+    (bgroup)
+    (set! *bibitem-num* 0)
+    (tex2page-string "\\let\\em\\it")
+    (tex2page-string "\\def\\newblock{ }")
+    (tex2page-string "\\def\\providecommand#1#2{}")
+    (do-end-para)
+    (emit "<table>")
+    (emit-newline)))
+
+(define do-bibitem
+  (lambda ()
+    (let ((bibmark (get-bracketed-text-if-any)))
+      (do-end-para)
+      (unless (= *bibitem-num* 0) (emit "</td></tr>") (emit-newline))
+      (set! *bibitem-num* (+ *bibitem-num* 1))
+      (emit "<tr><td align=right valign=top>")
+      (let* ((bibitem-num-s (number->string *bibitem-num*))
+             (key (string-append "cite{" (get-peeled-group) "}"))
+             (node-name
+               (string-append *html-node-prefix* "bib_" bibitem-num-s)))
+        (tex-def-toks "\\TIIPrecentlabelname" node-name #f)
+        (unless bibmark (set! bibmark bibitem-num-s))
+        (tex-def-toks "\\TIIPrecentlabelvalue" bibmark #f)
+        (emit-anchor node-name)
+        (emit "[")
+        (tex2page-string bibmark)
+        (emit "]")
+        (emit-nbsp 2)
+        (do-label-aux key)
+        (emit "</td><td valign=top>")))))
+
+(define display-index-entry
+  (lambda (s o)
+    (for-each
+      (lambda (c) (display (if (or (char=? c #\newline)) #\space c) o))
+      (string->list s))))
+
+(define do-index
+  (lambda ()
+    (let ((idx-entry (ungroup (get-group))))
+      (unless (substring? "|)" idx-entry)
+        (set! *index-count* (+ *index-count* 2))
+        (!index *index-count* *html-page-count*)
+        (write-aux `(!index ,*index-count* ,*html-page-count*))
+        (let ((tag
+               (string-append
+                 *html-node-prefix*
+                 "idx_"
+                 (number->string *index-count*))))
+          (emit-anchor tag)
+          (unless *index-port*
+            (let ((idx-file
+                    (string-append
+                      *aux-dir/*
+                      *jobname*
+                      *index-file-suffix*
+                      ".idx")))
+              (ensure-file-deleted idx-file)
+              (set! *index-port* (open-output-file idx-file))))
+          (display "\\indexentry{" *index-port*)
+          (cond
+           ((substring? "|see{" idx-entry)
+            (display-index-entry idx-entry *index-port*))
+           ((substring? "|seealso{" idx-entry)
+            (display-index-entry idx-entry *index-port*))
+           ((substring? "|(" idx-entry)
+            =>
+            (lambda (i)
+              (display-index-entry (substring idx-entry 0 i) *index-port*)
+              (display "|expandhtmlindex" *index-port*)))
+           (else
+            (display-index-entry idx-entry *index-port*)
+            (display "|expandhtmlindex" *index-port*)))
+          (display "}{" *index-port*)
+          (display *index-count* *index-port*)
+          (display "}" *index-port*)
+          (newline *index-port*))))))
+
+(define do-inputindex
+  (lambda (insert-heading?)
+    (set! *using-index?* #t)
+    (when insert-heading?
+      (tex2page-string
+        (if *using-chapters?*
+          "\\chapter*{\\indexname}"
+          "\\section*{\\indexname}"))
+      (emit-newline))
+    (emit-anchor (string-append *html-node-prefix* "index_start"))
+    (!index-page *html-page-count*)
+    (write-aux `(!index-page ,*html-page-count*))
+    (let ((ind-file
+            (string-append *aux-dir/* *jobname* *index-file-suffix* ".ind")))
+      (cond
+       ((file-exists? ind-file) (tex2page-file ind-file))
+       (else
+        (flag-missing-piece 'index)
+        (non-fatal-error "Index not generated; rerun TeX2page"))))))
+
+(define do-theindex
+  (lambda ()
+    (bgroup)
+    (tex2page-string "\\let\\endtheindex\\egroup")
+    (tex2page-string "\\let\\indexspace\\par")
+    (tex2page-string "\\let\\item\\indexitem")
+    (tex2page-string "\\let\\subitem\\indexsubitem")
+    (tex2page-string "\\let\\subsubitem\\indexsubsubitem")
+    (tex2page-string "\\let\\(\\expandhtmlindex")))
+
+(define expand-html-index
+  (lambda (item)
+    (ignorespaces)
+    (unless (char=? (get-actual-char) #\{)
+      (terror 'expand-tex-macro "Missing {"))
+    (let ((first-link? #t))
+      (let loop ((i (if item 1 *remember-index-number*)))
+        (cond
+         ((get-csv)
+          =>
+          (lambda (s)
+            (let* ((n (string->number s)) (pageno (table-get *index-table* n)))
+              (cond
+               (pageno
+                (if first-link? (set! first-link? #f) (emit ", "))
+                (emit-page-node-link-start
+                  pageno
+                  (string-append *html-node-prefix* "idx_" s))
+                (if item
+                  (tex2page-string item)
+                  (begin (emit "[") (emit i) (emit "]")))
+                (emit-link-stop))
+               (else (trace-if #t "Bad index entry around " item)))
+              (loop (+ i 1)))))
+         (else (set! *remember-index-number* i)))))
+    (unless (char=? (get-actual-char) #\})
+      (terror 'expand-html-index "Missing }"))
+    (ignorespaces)))
+
+(define do-see-also
+  (lambda ()
+    (let* ((other-entry (get-group)) (discard (get-group)))
+      (emit "<em>see also</em> ")
+      (tex2page-string other-entry))))
+
+(define do-indexitem
+  (lambda (indent)
+    (emit "<br>")
+    (emit-newline)
+    (emit-nbsp (* indent 4))
+    (let loop ((s '()) (brace-nesting 0))
+      (let ((c (snoop-actual-char)))
+        (cond
+         ((eof-object? c) (tex2page-string (list->string (reverse! s))))
+         ((and (= brace-nesting 0) (char=? c *esc-char*))
+          (let ((x (get-ctl-seq)))
+            (cond
+             ((or (string=? x "\\subitem") (string=? x "\\subsubitem"))
+              (tex2page-string (list->string (reverse! s)))
+              (toss-back-char *invisible-space*)
+              (toss-back-string x))
+             (else
+              (let ((xr (reverse! (string->list x))))
+                (loop
+                 (if (char-alphabetic? (car xr))
+                   (cons #\space (append xr s))
+                   (append xr s))
+                 brace-nesting))))))
+         ((char=? c #\,)
+          (get-actual-char)
+          (if (char-whitespace? (snoop-actual-char))
+            (begin
+              (ignore-all-whitespace)
+              (if (char=? (snoop-actual-char) *esc-char*)
+                (let ((x (get-ctl-seq)))
+                  (cond
+                   ((string=? x "\\expandhtmlindex")
+                    (expand-html-index (list->string (reverse! s))))
+                   ((string=? x "\\see")
+                    (tex2page-string (list->string (reverse! s)))
+                    (emit ", <em>see</em> ")
+                    (tex2page-string (get-group))
+                    (get-group))
+                   ((string=? x "\\seealso")
+                    (tex2page-string (list->string (reverse! s)))
+                    (emit ", <em>see also</em> ")
+                    (tex2page-string (get-group))
+                    (get-group))
+                   (else
+                    (toss-back-char *invisible-space*)
+                    (toss-back-string x)
+                    (toss-back-char *invisible-space*)
+                    (loop (cons #\space (cons #\, s)) brace-nesting))))
+                (loop (cons #\space (cons #\, s)) brace-nesting)))
+            (loop (cons #\, s) brace-nesting)))
+         (else
+          (get-actual-char)
+          (loop
+           (cons c s)
+           (cond
+            ((char=? c #\{) (+ brace-nesting 1))
+            ((char=? c #\}) (- brace-nesting 1))
+            (else brace-nesting)))))))))
+
+(define do-description-item
+  (lambda ()
+    (do-end-para)
+    (emit "</dd><dt>")
+    (let ((thing (get-bracketed-text-if-any)))
+      (when thing
+        (set! thing (string-trim-blanks thing))
+        (unless (string=? thing "")
+          (bgroup)
+          (emit "<b>")
+          (tex2page-string thing)
+          (emit "</b>")
+          (egroup))))
+    (emit "</dt><dd>")))
+
+(define do-regular-item
+  (lambda ()
+    (do-end-para)
+    (emit "<li>")
+    (do-para)
+    (let ((thing (get-bracketed-text-if-any)))
+      (when thing
+        (emit "<b>")
+        (bgroup)
+        (tex2page-string thing)
+        (egroup)
+        (emit "</b>")
+        (emit-nbsp 2)))))
+
+(define do-plain-item
+  (lambda (n)
+    (do-end-para)
+    (emit "<table><tr><td width=20 valign=top align=right>")
+    (let loop ((n n))
+      (unless (<= n 1)
+        (emit "</td><td width=20 valign=top align=right>")
+        (loop (- n 1))))
+    (tex2page-string (get-group))
+    (emit-nbsp 2)
+    (emit "</td><td>")
+    (do-para)
+    (add-afterpar (lambda () (emit "</td></tr></table>")))))
+
+(define do-item
+  (lambda ()
+    (let ((a #f))
+      (unless (null? *tabular-stack*) (set! a (car *tabular-stack*)))
+      (case a
+        ((description) (do-description-item))
+        ((itemize enumerate) (do-regular-item))
+        (else (do-plain-item 1))))))
+
+(define do-bigskip
+  (lambda (type)
+    (do-para)
+    (when (ormap (lambda (z) (string=? type z)) '("\\bigskip" "\\bigbreak"))
+      (emit "<br>")
+      (do-para)
+      (emit "<br>"))
+    (do-para)))
+
+(define do-hspace
+  (lambda ()
+    (ignorespaces)
+    (if (eqv? (snoop-actual-char) #\*) (get-actual-char))
+    (get-group)
+    (emit-nbsp 3)))
+
+(define do-vspace
+  (lambda ()
+    (ignorespaces)
+    (if (eqv? (snoop-actual-char) #\*) (get-actual-char))
+    (get-group)
+    (do-bigskip "vspace")))
+
+(define do-htmlmathstyle
+  (lambda ()
+    (call-with-input-string/buffered
+      (ungroup (get-group))
+      (lambda ()
+        (let loop ()
+          (ignore-all-whitespace)
+          (let ((c (snoop-actual-char)))
+            (unless (eof-object? c)
+              (case (string->symbol (scm-get-token))
+                ((image)
+                 (set! *use-image-for-displayed-math?* #t)
+                 (set! *use-image-for-intext-math?* #t))
+                ((display-image) (set! *use-image-for-displayed-math?* #t))
+                ((in-text-image) (set! *use-image-for-intext-math?* #t))
+                ((no-image)
+                 (set! *use-image-for-displayed-math?* #f)
+                 (set! *use-image-for-intext-math?* #f))
+                ((no-display-image) (set! *use-image-for-displayed-math?* #f))
+                ((no-in-text-image) (set! *use-image-for-intext-math?* #f)))
+              (loop))))))))
+
+(define do-htmldoctype
+  (lambda ()
+    (let ((d (get-peeled-group)))
+      (when (string=? d "") (set! d 'none))
+      (write-aux `(!doctype ,d)))))
+
+(define do-htmlcolophon
+  (lambda ()
+    (call-with-input-string/buffered
+      (ungroup (get-group))
+      (lambda ()
+        (let loop ()
+          (ignore-all-whitespace)
+          (let ((c (snoop-actual-char)))
+            (unless (eof-object? c)
+              (let ((directive (string->symbol (scm-get-token))))
+                (!colophon directive)
+                (write-aux `(!colophon ,directive))
+                (loop)))))))))
+
+(define output-colophon
+  (lambda ()
+    (when (or *colophon-mentions-last-mod-time?* *colophon-mentions-tex2page?*)
+      (do-end-para)
+      (emit "<div align=right class=colophon>")
+      (when (and
+             *colophon-mentions-last-mod-time?*
+             *last-modification-time*
+             (> *last-modification-time* 0))
+        (tex2page-string *last-modified*)
+        (emit ": ")
+        (emit (seconds->human-time *last-modification-time*))
+        (emit "<br>"))
+      (when *colophon-mentions-tex2page?*
+        (emit "<div align=right class=advertisement>")
+        (tex2page-string *html-conversion-by*)
+        (emit " ")
+        (when *colophon-links-to-tex2page-website?*
+          (emit-link-start
+            "http://www.ccs.neu.edu/~dorai/tex2page/tex2page-doc.html"))
+        (emit "TeX2page ")
+        (emit *tex2page-version*)
+        (when *colophon-links-to-tex2page-website?* (emit-link-stop))
+        (emit "</div>"))
+      (emit "</div>")
+      (emit-newline))))
+
+(define output-navigation-bar
+  (lambda (top-or-bottom)
+    (let* ((first-page? (= *html-page-count* 0))
+           (last-page-not-determined? (< *last-page-number* 0))
+           (last-page? (= *html-page-count* *last-page-number*))
+           (toc-page? (and *toc-page* (= *html-page-count* *toc-page*)))
+           (index-page? (and *index-page* (= *html-page-count* *index-page*)))
+           (first-page (string-append *jobname* *output-extension*))
+           (prev-page
+             (cond
+              (first-page? #f)
+              ((= *html-page-count* 1) first-page)
+              (else
+               (string-append
+                 *jobname*
+                 *html-page-suffix*
+                 (number->string (- *html-page-count* 1))
+                 *output-extension*))))
+           (next-page
+             (cond
+              (last-page? #f)
+              (else
+               (string-append
+                 *jobname*
+                 *html-page-suffix*
+                 (number->string (+ *html-page-count* 1))
+                 *output-extension*)))))
+      (unless (and
+               first-page?
+               (or last-page?
+                   (and (eq? top-or-bottom 'top) last-page-not-determined?)))
+        (emit "<div align=right class=navigation><i>[")
+        (emit *navigation-sentence-begin*)
+        (emit "<span")
+        (when first-page? (emit " class=disable"))
+        (emit ">")
+        (unless first-page? (emit-link-start first-page))
+        (emit *navigation-first-name*)
+        (unless first-page? (emit-link-stop))
+        (emit ", ")
+        (unless first-page? (emit-link-start prev-page))
+        (emit *navigation-previous-name*)
+        (unless first-page? (emit-link-stop))
+        (emit "</span>")
+        (emit "<span")
+        (when last-page? (emit " class=disable"))
+        (emit ">")
+        (when first-page? (emit "<span class=disable>"))
+        (emit ", ")
+        (when first-page? (emit "</span>"))
+        (unless last-page? (emit-link-start next-page))
+        (emit *navigation-next-name*)
+        (unless last-page? (emit-link-stop))
+        (emit "</span>")
+        (emit *navigation-page-name*)
+        (when (or *toc-page* *index-page*)
+          (emit "<span")
+          (when (or
+                 (and toc-page? (not *index-page*) (not index-page?))
+                 (and index-page? (not *toc-page*) (not toc-page?)))
+            (emit " class=disable"))
+          (emit ">; ")
+          (emit-nbsp 2)
+          (emit "</span>")
+          (when *toc-page*
+            (emit "<span")
+            (when toc-page? (emit " class=disable"))
+            (emit ">")
+            (unless toc-page?
+              (emit-page-node-link-start
+                *toc-page*
+                (string-append *html-node-prefix* "toc_start")))
+            (emit *navigation-contents-name*)
+            (unless toc-page? (emit-link-stop))
+            (emit "</span>"))
+          (when *index-page*
+            (emit "<span")
+            (when index-page? (emit " class=disable"))
+            (emit ">")
+            (emit "<span")
+            (unless (and *toc-page* (not toc-page?)) (emit " class=disable"))
+            (emit ">")
+            (when *toc-page* (emit "; ") (emit-nbsp 2))
+            (emit "</span>")
+            (unless index-page?
+              (emit-page-node-link-start
+                *index-page*
+                (string-append *html-node-prefix* "index_start")))
+            (emit *navigation-index-name*)
+            (unless index-page? (emit-link-stop))
+            (emit "</span>")))
+        (emit *navigation-sentence-end*)
+        (emit "]</i></div>")
+        (emit-newline)))))
+
+(define do-eject
+  (lambda ()
+    (unless (and
+             (eof-object? (snoop-actual-char))
+             (eqv? *current-source-file* *main-tex-file*))
+      (unless (> *last-page-number* 0)
+        (flag-missing-piece 'last-modification-time))
+      (do-end-page)
+      (set! *html-page-count* (+ *html-page-count* 1))
+      (set! *html-page*
+        (string-append
+          *aux-dir/*
+          *jobname*
+          *html-page-suffix*
+          (number->string *html-page-count*)
+          *output-extension*))
+      (ensure-file-deleted *html-page*)
+      (set! *html* (open-output-file *html-page*))
+      (do-start))))
+
+(define output-html-preamble
+  (lambda ()
+    (when (string? *doctype*)
+      (emit "<!doctype ")
+      (emit *doctype*)
+      (emit ">")
+      (emit-newline))
+    (emit "<html>")
+    (emit-newline)
+    (emit "<!--")
+    (emit-newline)
+    (emit-newline)
+    (emit "Generated from ")
+    (emit *main-tex-file*)
+    (emit " by tex2page, ")
+    (emit "v ")
+    (emit *tex2page-version*)
+    (emit-newline)
+    (emit "(running on ")
+    (emit *scheme-version*)
+    (emit ", ")
+    (emit *operating-system*)
+    (emit "), ")
+    (emit-newline)
+    (emit "(c) Dorai Sitaram, ")
+    (emit-newline)
+    (emit *tex2page-website*)
+    (emit-newline)
+    (emit-newline)
+    (emit "-->")
+    (emit-newline)
+    (emit "<head>")
+    (emit-newline)
+    (output-external-title)
+    (link-stylesheets)
+    (emit "<meta name=robots content=\"")
+    (unless (= *html-page-count* 0) (emit "no"))
+    (emit "index,follow\">")
+    (emit-newline)
+    (for-each emit *html-head*)
+    (emit "</head>")
+    (emit-newline)
+    (emit "<body>")
+    (emit-newline)
+    (emit "<div id=")
+    (emit (if (= *html-page-count* 0) "title" "content"))
+    (emit ">")
+    (emit-newline)))
+
+(define output-html-postamble
+  (lambda ()
+    (do-end-para)
+    (emit "</div>")
+    (emit-newline)
+    (emit "</body>")
+    (emit-newline)
+    (emit "</html>")
+    (emit-newline)))
+
+(define do-start
+  (lambda ()
+    (set! *footnote-list* '())
+    (output-html-preamble)
+    (output-navigation-bar 'top)
+    (do-para)))
+
+(define do-end-page
+  (lambda ()
+    (do-end-para)
+    (output-footnotes)
+    (output-navigation-bar 'bottom)
+    (do-para)
+    (when (or
+           (and *colophon-on-first-page?* (= *html-page-count* 0))
+           (and (not *colophon-on-first-page?*)
+                (= *html-page-count* *last-page-number*)))
+      (output-colophon))
+    (output-html-postamble)
+    (write-log #\[)
+    (write-log *html-page-count*)
+    (write-log #\])
+    (write-log 'separation-space)
+    (close-output-port *html*)))
+
+(define close-all-open-ports
+  (lambda ()
+    (when *aux-port* (close-output-port *aux-port*))
+    (when *css-port* (close-output-port *css-port*))
+    (when *index-port* (close-output-port *index-port*))
+    (when *label-port* (close-output-port *label-port*))
+    (when *bib-aux-port* (close-output-port *bib-aux-port*))
+    (when *verb-port* (close-output-port *verb-port*))
+    (for-each
+      (lambda (c) (let ((p (cdr c))) (when p (close-input-port p))))
+      *input-streams*)
+    (for-each
+      (lambda (c) (let ((p (cdr c))) (when p (close-output-port p))))
+      *output-streams*)))
+
+(define output-stats
+  (lambda ()
+    (write-log 'separation-newline)
+    (cond
+     (*main-tex-file*
+      (let ((num-pages (+ *html-page-count* 1)))
+        (write-log "Output written on ")
+        (write-log *aux-dir/*)
+        (write-log *jobname*)
+        (write-log *output-extension*)
+        (when (> num-pages 1) (write-log ", ..."))
+        (write-log " (")
+        (write-log num-pages)
+        (write-log " page")
+        (unless (= num-pages 1) (write-log #\s)))
+      (when (> *img-file-tally* 0)
+        (write-log ", ")
+        (write-log *img-file-tally*)
+        (write-log " image")
+        (unless (= *img-file-tally* 1) (write-log #\s)))
+      (write-log ")."))
+     (else (write-log "No pages of output.")))
+    (write-log #\newline)
+    (when *log-port* (close-output-port *log-port*))
+    (display "Transcript written on ")
+    (display *log-file*)
+    (display ".")
+    (newline)))
+
+(define do-bye
+  (lambda ()
+    (unless (null? *tex-if-stack*)
+      (let ((n (length *tex-if-stack*)))
+        (trace-if #t "Found " n " incomplete \\if" (if (> n 1) "s" ""))))
+    (unless (null? *tex-env*)
+      (trace-if
+        #t
+        "\\end occurred inside a group at level "
+        (length *tex-env*)))
+    (perform-postludes)
+    (unless (or (>= *last-page-number* 0) (= *html-page-count* 0))
+      (flag-missing-piece 'last-page))
+    (!last-page-number *html-page-count*)
+    (write-aux `(!last-page-number ,*last-page-number*))
+    (do-end-page)
+    (when *last-modification-time*
+      (write-aux `(!last-modification-time ,*last-modification-time*)))
+    (for-each (lambda (th) (th)) *afterbye*)
+    (close-all-open-ports)
+    (call-external-programs-if-necessary)
+    (show-unresolved-xrefs-and-missing-pieces)))
+
+(define insert-missing-end
+  (lambda ()
+    (write-log 'separation-newline)
+    (write-log "! Missing \\end inserted.")
+    (write-log 'separation-newline)))
+
+(define do-diacritic-aux
+  (lambda (diac c)
+    (case diac
+      ((acute)
+       (case c
+         ((#\a #\e #\i #\o #\u #\y #\A #\E #\I #\O #\U #\Y)
+          (emit #\&)
+          (emit c)
+          (emit "acute;"))
+         ((#\space) (emit #\'))
+         (else (emit c) (emit #\'))))
+      ((cedilla)
+       (case c
+         ((#\c #\C) (emit #\&) (emit c) (emit "cedil;"))
+         ((#\space) (emit #\,))
+         (else (emit c) (emit #\,))))
+      ((circumflex)
+       (case c
+         ((#\a #\e #\i #\o #\u #\A #\E #\I #\O #\U)
+          (emit #\&)
+          (emit c)
+          (emit "circ;"))
+         ((#\space) (emit #\^))
+         (else (emit c) (emit #\^))))
+      ((grave)
+       (case c
+         ((#\a #\e #\i #\o #\u #\A #\E #\I #\O #\U)
+          (emit #\&)
+          (emit c)
+          (emit "grave;"))
+         ((#\space) (emit #\`))
+         (else (emit c) (emit #\`))))
+      ((hacek)
+       (case c
+         ((#\s) (emit *html-scaron*))
+         ((#\S) (emit *html-cap-scaron*))
+         ((#\space) (emit #\^))
+         (else (emit c) (emit #\^))))
+      ((ring)
+       (case c
+         ((#\a #\A) (emit #\&) (emit c) (emit "ring;"))
+         ((#\space) (emit "&deg;"))
+         (else (emit c) (emit "&deg;"))))
+      ((tilde)
+       (case c
+         ((#\a #\n #\o #\A #\N #\O) (emit #\&) (emit c) (emit "tilde;"))
+         ((#\space) (emit #\~))
+         (else (emit c) (emit #\~))))
+      ((umlaut)
+       (case c
+         ((#\a #\e #\i #\o #\u #\y #\A #\E #\I #\O #\U)
+          (emit #\&)
+          (emit c)
+          (emit "uml;"))
+         ((#\Y) (emit *html-cap-yuml*))
+         ((#\space) (emit "&quot;"))
+         (else (emit c) (emit "&quot;"))))
+      (else (emit "<u>") (emit c) (emit "</u>")))))
+
+(define do-diacritic
+  (lambda (diac)
+    (let* ((x (ungroup (get-token)))
+           (c
+            (if (string=? x "\\i")
+              #\i
+              (case (string-length x)
+                ((0) #\space)
+                ((1) (string-ref x 0))
+                (else (terror 'do-diacritic "`" x "' is not a character"))))))
+      (do-diacritic-aux diac c))))
+
+(define do-mathdg
+  (lambda ()
+    (fluid-let
+      ((*math-mode?* #t)
+       (*in-display-math?* #t)
+       (*tabular-stack* '())
+       (*ligatures?* #f))
+      (do-end-para)
+      (emit "<div align=")
+      (emit *display-justification*)
+      (emit "><table><tr><td>")
+      (tex2page-string (get-group))
+      (emit "</td></tr></table></div>")
+      (do-para))))
+
+(define do-mathg
+  (lambda ()
+    (fluid-let
+      ((*math-mode?* #t)
+       (*in-display-math?* #f)
+       (*tabular-stack* '())
+       (*ligatures?* #f))
+      (tex2page-string (get-group)))))
+
+(define dump-tex-preamble
+  (lambda (o)
+    (case *tex-format*
+      ((latex)
+       (display "\\documentclass{" o)
+       (display (if *using-chapters?* "report" "article") o)
+       (display "}" o)
+       (newline o)
+       (display *imgpreamble* o)
+       (newline o)
+       (when (memv 'includegraphics *imgpreamble-inferred*)
+         (display "\\ifx\\includegraphics\\UNDEFINED" o)
+         (display "\\usepackage{graphicx}\\fi" o)
+         (newline o))
+       (when (memv 'epsfbox *imgpreamble-inferred*)
+         (display "\\ifx\\epsfbox\\UNDEFINED" o)
+         (display "\\usepackage{epsfig}\\fi" o)
+         (newline o))
+       (display "\\thispagestyle{empty}" o)
+       (newline o)
+       (display "\\begin{document}" o)
+       (newline o))
+      (else
+       (display *imgpreamble* o)
+       (newline o)
+       (when (memv 'epsfbox *imgpreamble-inferred*)
+         (display "\\ifx\\epsfbox\\UNDEFINED" o)
+         (display "\\input epsf \\fi" o)
+         (newline o))
+       (display "\\nopagenumbers" o)
+       (newline o)))))
+
+(define dump-tex-postamble
+  (lambda (o)
+    (case *tex-format*
+      ((latex) (display "\\end{document}" o) (newline o))
+      (else (display "\\bye" o) (newline o)))))
+
+(define skipping-img-file
+  (lambda () (set! *img-file-count* (+ *img-file-count* 1))))
+
+(define next-html-image-file-stem
+  (lambda ()
+    (set! *img-file-count* (+ *img-file-count* 1))
+    (string-append
+      *subjobname*
+      *img-file-suffix*
+      (number->string *img-file-count*))))
+
+(define call-with-html-image-port
+  (lambda (p . alt)
+    (let* ((alt (if (null? alt) #f (car alt)))
+           (img-file-stem (next-html-image-file-stem))
+           (aux-tex-file (string-append img-file-stem ".tex")))
+      (ensure-file-deleted aux-tex-file)
+      (call-with-output-file
+        aux-tex-file
+        (lambda (o) (dump-tex-preamble o) (p o) (dump-tex-postamble o)))
+      (tex-to-img img-file-stem)
+      (source-img-file img-file-stem alt))))
+
+(define do-display-math
+  (lambda (tex-string)
+    (do-end-para)
+    (emit "<div align=")
+    (emit *display-justification*)
+    (emit ">")
+    (let* ((alt-thunk
+             (lambda ()
+               (fluid-let
+                 ((*math-mode?* #t)
+                  (*in-display-math?* #t)
+                  (*tabular-stack* '()))
+                 (emit "<table><tr><td>")
+                 (tex2page-string tex-string)
+                 (emit "</td></tr></table>")))))
+      (if *use-image-for-displayed-math?*
+        (call-with-html-image-port
+          (lambda (o) (display "$$" o) (display tex-string o) (display "$$" o))
+          tex-string)
+        (alt-thunk)))
+    (emit "</div>")
+    (do-para)))
+
+(define do-intext-math
+  (lambda (tex-string)
+    (let* ((alt-thunk
+             (lambda ()
+               (fluid-let
+                 ((*math-mode?* #t)
+                  (*in-display-math?* #f)
+                  (*tabular-stack* '()))
+                 (bgroup)
+                 (tex2page-string tex-string)
+                 (egroup)))))
+      (if *use-image-for-intext-math?*
+        (call-with-html-image-port
+          (lambda (o) (display #\$ o) (display tex-string o) (display #\$ o))
+          tex-string)
+        (alt-thunk)))))
+
+(define do-mathp
+  (lambda ()
+    (call-with-html-image-port
+      (lambda (o) (display #\$ o) (display (get-group) o) (display #\$ o)))))
+
+(define do-latex-intext-math
+  (lambda ()
+    (do-intext-math
+      (let ((o (open-output-string)))
+        (dump-till-ctl-seq "\\)" o)
+        (get-output-string o)))))
+
+(define do-latex-display-math
+  (lambda ()
+    (do-display-math
+      (let ((o (open-output-string)))
+        (dump-till-ctl-seq "\\]" o)
+        (get-output-string o)))))
+
+(define do-math
+  (lambda ()
+    (let ((display? #f))
+      (when (eqv? (snoop-actual-char) #\$)
+        (set! display? #t)
+        (get-actual-char))
+      (let ((o (open-output-string)))
+        (dump-till-char #\$ o)
+        (when display?
+          (let ((c (get-actual-char)))
+            (when (or (eof-object? c) (not (char=? c #\$)))
+              (terror 'do-math))))
+        ((if display? do-display-math do-intext-math)
+         (get-output-string o))))))
+
+(define dump-till-char
+  (lambda (d o)
+    (let loop ((nesting 0) (escape? #f))
+      (let ((c (get-actual-char)))
+        (cond
+         ((eof-object? c) (terror 'dump-till-char))
+         ((and (char=? c d) (= nesting 0)) #t)
+         (else
+          (display c o)
+          (cond
+           (escape? (loop nesting #f))
+           ((char=? c #\{) (loop (+ nesting 1) #f))
+           ((char=? c #\}) (loop (- nesting 1) #f))
+           ((char=? c #\\) (loop nesting #t))
+           (else (loop nesting #f)))))))))
+
+(define dump-till-ctl-seq
+  (lambda (cs o)
+    (fluid-let
+      ((*not-processing?* #t))
+      (let loop ((nesting 0))
+        (let ((c (snoop-actual-char)))
+          (cond
+           ((eof-object? c) (terror 'dump-till-ctl-seq))
+           ((char=? c *esc-char*)
+            (let ((x (get-ctl-seq)))
+              (if (string=? x cs) #t (begin (display x o) (loop nesting)))))
+           (else
+            (display (get-actual-char) o)
+            (cond
+             ((char=? c #\{) (loop (+ nesting 1)))
+             ((char=? c #\}) (loop (- nesting 1)))
+             (else (loop nesting))))))))))
+
+(define dump-till-end-env
+  (lambda (env o)
+    (let* ((endenv (string-append "\\end" env))
+           (endenv-prim (find-corresp-prim endenv))
+           (endenv-prim-th (find-corresp-prim-thunk endenv)))
+      (fluid-let
+        ((*not-processing?* #t))
+        (let loop ((brace-nesting 0) (env-nesting 0))
+          (let ((c (snoop-actual-char)))
+            (cond
+             ((eof-object? c) (terror 'dump-till-end-env env))
+             ((char=? c *esc-char*)
+              (let ((x (get-ctl-seq)))
+                (cond
+                 ((string=? (find-corresp-prim x) endenv-prim) #t)
+                 ((string=? x "\\begin")
+                  (display x o)
+                  (let ((g (get-grouped-environment-name-if-any)))
+                    (when g (display #\{ o) (display g o) (display #\} o))
+                    (loop
+                     brace-nesting
+                     (if (and g (string=? g env))
+                       (+ env-nesting 1)
+                       env-nesting))))
+                 ((string=? x "\\end")
+                  (let ((g (get-grouped-environment-name-if-any)))
+                    (unless (and
+                             g
+                             (or *dumping-nontex?* (= env-nesting 0))
+                             (let ((endg (string-append "\\end" g)))
+                               (or (string=?
+                                     (find-corresp-prim endg)
+                                     endenv-prim)
+                                   (eqv?
+                                    (find-corresp-prim-thunk endg)
+                                    endenv-prim-th))))
+                      (display x o)
+                      (when g (display #\{ o) (display g o) (display #\} o))
+                      (loop
+                       brace-nesting
+                       (if (and g (string=? g env))
+                         (- env-nesting 1)
+                         env-nesting)))))
+                 (else (display x o) (loop brace-nesting env-nesting)))))
+             ((and (char=? c *comment-char*) (not *dumping-nontex?*))
+              (do-comment)
+              (write-char #\% o)
+              (newline o)
+              (loop brace-nesting env-nesting))
+             (else
+              (write-char (get-actual-char) o)
+              (cond
+               ((char=? c #\{) (loop (+ brace-nesting 1) env-nesting))
+               ((char=? c #\}) (loop (- brace-nesting 1) env-nesting))
+               (else (loop brace-nesting env-nesting)))))))))))
+
+(define dump-imgdef
+  (lambda (f)
+    (let ((aux-tex-file (string-append f ".tex")))
+      (ensure-file-deleted aux-tex-file)
+      (call-with-output-file
+        aux-tex-file
+        (lambda (o)
+          (dump-tex-preamble o)
+          (display (ungroup (get-group)) o)
+          (dump-tex-postamble o))))))
+
+(define do-img-preamble
+  (lambda ()
+    (set! *imgpreamble*
+      (fluid-let
+        ((*not-processing?* #t))
+        (let loop ((r *imgpreamble*))
+          (let ((c (snoop-actual-char)))
+            (cond
+             ((eof-object? c)
+              (terror 'do-img-preamble "Missing \\endimgpreamble"))
+             ((char=? c *esc-char*)
+              (let ((x (get-ctl-seq)))
+                (cond
+                 ((ormap
+                   (lambda (z) (string=? x z))
+                   '("\\endimgpreamble"
+                     "\\endgifpreamble"
+                     "\\endmathpreamble"))
+                  r)
+                 (else (loop (string-append r x))))))
+             (else
+              (get-actual-char)
+              (loop (string-append r (string c)))))))))))
+
+(define pick-new-stream-number
+  (lambda (stream-list)
+    (let loop ((i 0))
+      (if (or (assv i stream-list) (= i 16) (= i 18)) (loop (+ i 1)) i))))
+
+(define do-new-stream
+  (lambda (type)
+    (let* ((x (get-ctl-seq))
+           (sl (if (eqv? type 'out) *output-streams* *input-streams*))
+           (n (pick-new-stream-number sl))
+           (sl-new (cons (cons n #f) sl)))
+      (tex-def-count x n #t)
+      (case type
+        ((out) (set! *output-streams* sl-new))
+        (else (set! *input-streams* sl-new))))))
+
+(define do-open-stream
+  (lambda (type)
+    (let* ((n (get-number))
+           (f (get-plain-filename))
+           (sl (if (eqv? type 'out) *output-streams* *input-streams*))
+           (c (assv n sl)))
+      (unless (and c (not (cdr c))) (terror 'do-open-stream))
+      (case type
+        ((out)
+         (set! f (add-dot-tex-if-no-extension-provided f))
+         (ensure-file-deleted f)
+         (set-cdr! c (open-output-file f)))
+        (else
+         (set! f (actual-tex-filename f #f))
+         (set-cdr! c (make-bport 'port (open-input-file f))))))))
+
+(define do-close-stream
+  (lambda (type)
+    (let* ((sl (if (eqv? type 'out) *output-streams* *input-streams*))
+           (o (get-number))
+           (c (assv o sl)))
+      (unless (and c (cdr c)) (terror 'do-close-stream))
+      (case type
+        ((out) (close-output-port (cdr c)))
+        ((in) (close-output-port (bport.port (cdr c)))))
+      (set-cdr! c #f))))
+
+(define tex-write-output-string
+  (lambda (s)
+    (let ((o (open-output-string)))
+      (fluid-let
+        ((*outputting-to-non-html?* #t) (*html* o))
+        (call-with-input-string/buffered
+          s
+          (lambda ()
+            (let loop ()
+              (let ((c (snoop-actual-char)))
+                (unless (eof-object? c)
+                  (case c
+                    ((#\\) (do-tex-ctl-seq (get-ctl-seq)))
+                    (else (emit-html-char (get-actual-char))))
+                  (loop)))))))
+      (get-output-string o))))
+
+(define do-write-aux
+  (lambda (o)
+    (let ((output (tex-write-output-string (get-peeled-group))))
+      (cond
+       ((and (= o 18) *enable-write-18?*) (system output))
+       ((or (= o 16) (= o 18))
+        (write-log output)
+        (write-log 'separation-space))
+       ((assv o *output-streams*)
+        =>
+        (lambda (c)
+          (let ((p (cdr c)))
+            (cond
+             ((not p) (terror 'do-write-aux))
+             (else (display output p) (display #\space p))))))
+       (else (terror 'do-write))))))
+
+(define do-write (lambda () (do-write-aux (get-number))))
+
+(define do-message (lambda () (do-write-aux 16)))
+
+(define read-tex-line
+  (lambda (p)
+    (fluid-let
+      ((*current-tex2page-input* p))
+      (let loop ((r '()))
+        (let ((c (snoop-actual-char)))
+          (cond
+           ((eof-object? c) (if (null? r) c (list->string (reverse! r))))
+           ((char=? c #\newline) (get-actual-char) (list->string (reverse! r)))
+           ((char=? c #\{)
+            (string-append (list->string (reverse! r)) (get-group)))
+           (else (loop (cons (get-actual-char) r)))))))))
+
+(define do-read
+  (lambda (global?)
+    (let* ((i (get-number)) (x (begin (get-to) (get-ctl-seq))) (p #f))
+      (cond
+       ((ormap (lambda (j) (= i j)) '(-1 16))
+        (set! p (make-bport 'port (current-input-port)))
+        (unless (= i -1) (write-log x) (write-log #\=)))
+       ((assv i *input-streams*)
+        =>
+        (lambda (c) (set! p (cdr c)) (unless p (terror 'do-read))))
+       (else (terror 'do-read)))
+      (tex-def-0arg
+        x
+        (let ((line (read-tex-line p))) (if (eof-object? line) "" line))
+        (and global? *global-texframe*)))))
+
+(define do-typein
+  (lambda ()
+    (let ((ctlseq (get-bracketed-text-if-any))
+          (p (make-bport 'port (current-input-port))))
+      (write-log 'separation-newline)
+      (write-log (tex-string->html-string (get-group)))
+      (write-log 'separation-newline)
+      (write-log (or ctlseq "\\@typein"))
+      (write-log #\=)
+      (let ((L (read-tex-line p)))
+        (when (eof-object? L) (set! L ""))
+        (cond
+         (ctlseq (tex-def-0arg ctlseq L #f))
+         (else (tex2page-string L)))))))
+
+(define do-ifeof
+  (lambda ()
+    (let* ((i (get-number)) (c (assv i *input-streams*)))
+      (unless (and c (cdr c)) (terror 'do-ifeof))
+      (if (eof-object? (read-char (cdr c))) do-iftrue do-iffalse))))
+
+(define do-iffalse (lambda () (set! *tex-if-stack* (cons #f *tex-if-stack*))))
+
+(define do-iftrue (lambda () (set! *tex-if-stack* (cons #t *tex-if-stack*))))
+
+(define insert-tex-if (lambda (test) ((if test do-iftrue do-iffalse))))
+
+(define do-ifx
+  (lambda ()
+    (let* ((one (get-raw-token/is)) (two (get-raw-token/is)))
+      ((if (string=? one two)
+         do-iftrue
+         (begin
+           (when (ctl-seq? one)
+             (set! one
+               (cond
+                ((find-def one) => tdef.expansion)
+                ((find-math-def one) => (lambda (x) x))
+                (else "UnDeFiNeD"))))
+           (when (ctl-seq? two)
+             (set! two
+               (cond
+                ((find-def two) => tdef.expansion)
+                ((find-math-def two) => (lambda (x) x))
+                (else "UnDeFiNeD"))))
+           (if (or (eqv? one two)
+                   (and (string? one) (string? two) (string=? one two)))
+             do-iftrue
+             do-iffalse)))))))
+
+(define do-if-get-atomic
+  (lambda ()
+    (let loop ()
+      (let ((x (get-raw-token/is)))
+        (if (ctl-seq? x)
+          (cond
+           ((resolve-defs x)
+            =>
+            (lambda (z)
+              (toss-back-char *invisible-space*)
+              (toss-back-string z)
+              (loop)))
+           (else x))
+          x)))))
+
+(define do-if
+  (lambda ()
+    (let* ((one (do-if-get-atomic)) (two (do-if-get-atomic)))
+      ((if (or (string=? one two) (and (ctl-seq? one) (ctl-seq? two)))
+         do-iftrue
+         do-iffalse)))))
+
+(define do-ifmmode
+  (lambda () (set! *tex-if-stack* (cons *math-mode?* *tex-if-stack*))))
+
+(define do-ifnum
+  (lambda ()
+    (let* ((one (get-number))
+           (rel (string-ref (get-raw-token/is) 0))
+           (two (get-number)))
+      ((if ((case rel
+              ((#\<) <)
+              ((#\=) =)
+              ((#\>) >)
+              (else (terror 'do-ifnum "Missing relation for \\ifnum")))
+            one
+            two)
+         do-iftrue
+         do-iffalse)))))
+
+(define read-ifcase-clauses
+  (lambda ()
+    (fluid-let
+      ((*not-processing?* #t))
+      (let* ((else-clause #f)
+             (or-clauses
+               (let loop ((or-clauses '()) (else? #f))
+                 (let loop2 ((clause ""))
+                   (let ((c (snoop-actual-char)))
+                     (cond
+                      ((eof-object? c)
+                       (terror 'read-ifcase-clauses "Missing \\fi"))
+                      ((char=? c *esc-char*)
+                       (let ((x (get-ctl-seq)))
+                         (cond
+                          ((string=? x "\\or")
+                           (if else?
+                             (terror 'read-ifcase-clauses "\\or after \\else")
+                             (loop (cons clause or-clauses) #f)))
+                          ((string=? x "\\else")
+                           (if else?
+                             (terror
+                               'read-ifcase-clauses
+                               "\\else after \\else")
+                             (loop (cons clause or-clauses) #t)))
+                          ((string=? x "\\fi")
+                           (if else?
+                             (begin (set! else-clause clause) or-clauses)
+                             (cons clause or-clauses)))
+                          (else (loop2 (string-append clause x))))))
+                      (else
+                       (get-actual-char)
+                       (loop2 (string-append clause (string c))))))))))
+        (cons else-clause or-clauses)))))
+
+(define do-ifcase
+  (lambda ()
+    (let* ((num (get-number))
+           (clauses (read-ifcase-clauses))
+           (else-clause (car clauses))
+           (or-clauses (reverse! (cdr clauses)))
+           (num-or-clauses (length or-clauses)))
+      (cond
+       ((< num num-or-clauses) (tex2page-string (list-ref or-clauses num)))
+       (else-clause (tex2page-string else-clause))))))
+
+(define do-ifodd (lambda () ((if (odd? (get-number)) do-iftrue do-iffalse))))
+
+(define do-else
+  (lambda ()
+    (when (null? *tex-if-stack*) (terror 'do-else "Extra \\else"))
+    (let ((top-if (car *tex-if-stack*)))
+      (set-car! *tex-if-stack* (not top-if)))))
+
+(define do-fi
+  (lambda ()
+    (when (null? *tex-if-stack*) (terror 'do-fi "Extra \\fi"))
+    (set! *tex-if-stack* (cdr *tex-if-stack*))))
+
+(define do-newif
+  (lambda ()
+    (let* ((iffoo (get-ctl-seq))
+           (init-val #f)
+           (foo (string-append "\\" (substring iffoo 3 (string-length iffoo))))
+           (foo-register (string-append foo "BOOLEANREGISTER")))
+      (tex-def-count foo-register 0 #f)
+      (tex-def-thunk
+        iffoo
+        (lambda ()
+          (set! *tex-if-stack*
+            (cons (> (the-count foo-register) 0) *tex-if-stack*)))
+        #f)
+      (tex-def-thunk
+        (string-append foo "true")
+        (lambda () (tex-def-count foo-register 1 #f))
+        #f)
+      (tex-def-thunk
+        (string-append foo "false")
+        (lambda () (tex-def-count foo-register 0 #f))
+        #f))))
+
+(define do-htmlimg
+  (lambda (env)
+    (call-with-html-image-port (lambda (o) (dump-till-end-env env o)))))
+
+(define find-img-file-extn
+  (lambda ()
+    (case *image-format*
+      ((gif) ".gif")
+      ((png) ".png")
+      ((jpeg) ".jpeg")
+      (else (set! *image-format* 'gif) ".gif"))))
+
+(define do-htmlimageformat
+  (lambda ()
+    (set! *image-format* (string->symbol (ungroup (get-group))))
+    (set! *img-file-extn* (find-img-file-extn))))
+
+(define do-htmlimgmagnification
+  (lambda ()
+    (set! *img-magnification* (string->number (ungroup (get-group))))))
+
+(define call-tex
+  (lambda (f)
+    (let ((dvifile (string-append f ".dvi"))
+          (call-to-tex
+            (string-append
+              (if (eq? *tex-format* 'latex) "la" "")
+              "tex "
+              f
+              *bye-tex*)))
+      (system call-to-tex)
+      (and (file-exists? dvifile)
+           (let ((logfile (string-append f ".log")))
+             (or (not (file-exists? logfile))
+                 (call-with-input-file
+                   logfile
+                   (lambda (i)
+                     (let loop ()
+                       (let ((x (read-line i)))
+                         (cond
+                          ((eof-object? x) #t)
+                          ((substring? "! I can't find file" x) #f)
+                          (else (loop)))))))))))))
+
+(define ps-to-img/gif
+  (lambda (ps-file f)
+    (system
+      (string-append
+        *ghostscript*
+        *ghostscript-options*
+        " -sOutputFile="
+        f
+        ".ppm.1 "
+        ps-file
+        " quit.ps"))
+    (system (string-append "pnmcrop " f ".ppm.1 > " f ".ppm.tmp"))
+    '(unless (= *img-magnification* 1)
+       (system
+         (string-append
+           "pbmpscale "
+           (number->string *img-magnification*)
+           " "
+           f-ppm-tmp
+           " > "
+           f-ppm))
+       (let ((swp f-ppm)) (set! f-ppm f-ppm-tmp) (set! f-ppm-tmp swp)))
+    (system (string-append "ppmquant 256 < " f ".ppm.tmp > " f ".ppm"))
+    (system
+      (string-append
+        "ppmtogif -transparent rgb:ff/ff/ff < "
+        f
+        ".ppm > "
+        *aux-dir/*
+        f
+        ".gif"))
+    (for-each
+      (lambda (e) (ensure-file-deleted (string-append f e)))
+      '(".ppm" ".ppm.tmp" ".ppm.1"))))
+
+(define ps-to-img/png
+  (lambda (ps-file f)
+    (system
+      (string-append
+        *ghostscript*
+        *ghostscript-options*
+        " -sOutputFile="
+        f
+        ".ppm.1 "
+        ps-file
+        " quit.ps"))
+    (system (string-append "pnmcrop " f ".ppm.1 > " f ".ppm.tmp"))
+    '(system (string-append "ppmquant 256 < " f ".ppm.tmp > " f ".ppm"))
+    (system
+      (string-append
+        "pnmtopng -interlace -transparent \"#FFFFFF\" "
+        " < "
+        f
+        ".ppm.tmp > "
+        *aux-dir/*
+        f
+        ".png"))
+    (for-each
+      (lambda (e) (ensure-file-deleted (string-append f e)))
+      '(".ppm.1" ".ppm.tmp" ".ppm"))))
+
+(define ps-to-img/jpeg
+  (lambda (ps-file f)
+    (system
+      (string-append
+        *ghostscript*
+        *ghostscript-options*
+        " -sOutputFile="
+        f
+        ".ppm.1 "
+        ps-file
+        " quit.ps"))
+    (system (string-append "pnmcrop " f ".ppm.1 > " f ".ppm.tmp"))
+    (system (string-append "ppmquant 256 < " f ".ppm.tmp > " f ".ppm"))
+    (system
+      (string-append
+        "ppmtojpeg --grayscale < "
+        f
+        ".ppm > "
+        *aux-dir/*
+        f
+        ".jpeg"))
+    (for-each
+      (lambda (e) (ensure-file-deleted (string-append f e)))
+      '(".ppm.1" ".ppm.tmp" ".ppm"))))
+
+(define ps-to-img
+  (lambda (ps-file img-file-stem)
+    ((case *image-format*
+       ((gif) ps-to-img/gif)
+       ((png) ps-to-img/png)
+       ((jpeg) ps-to-img/jpeg)
+       (else (terror 'ps-to-img) list))
+     ps-file
+     img-file-stem)))
+
+(define tex-to-img
+  (lambda (f)
+    (set! *img-file-tally* (+ *img-file-tally* 1))
+    (let ((f.img (string-append *aux-dir/* f *img-file-extn*)))
+      (unless (file-exists? f.img)
+        (write-log 'separation-space)
+        (write-log #\{)
+        (write-log (string-append f ".tex"))
+        (write-log 'separation-space)
+        (write-log "->")
+        (write-log 'separation-space)
+        (cond
+         ((call-tex f)
+          (system (string-append "dvips " f ".dvi -o " f ".ps"))
+          (ps-to-img (string-append f ".ps") f)
+          (write-log f.img)
+          '(for-each
+             (lambda (e) (ensure-file-deleted (string-append f e)))
+             '(".aux" ".dvi" ".log" ".ps" ".tex")))
+         (else (write-log "failed, try manually")))
+        (write-log #\})
+        (write-log 'separation-space)))))
+
+(define call-with-lazy-image-port
+  (lambda (eps-file img-file-stem p)
+    (let ((aux-tex-file (string-append img-file-stem ".tex")))
+      (ensure-file-deleted aux-tex-file)
+      (call-with-output-file
+        aux-tex-file
+        (lambda (o) (dump-tex-preamble o) (p o) (dump-tex-postamble o)))
+      (if (file-exists? eps-file)
+        (tex-to-img img-file-stem)
+        (set! *missing-eps-files*
+          (cons (cons eps-file img-file-stem) *missing-eps-files*))))))
+
+(define retry-lazy-image
+  (lambda (eps-file img-file-stem)
+    (cond
+     ((file-exists? eps-file) (tex-to-img img-file-stem))
+     (else
+      (write-log "! I can't find EPS file ")
+      (write-log eps-file)
+      (write-log 'separation-newline)))))
+
+(define lazily-make-epsf-image-file
+  (lambda (eps-file img-file-stem)
+    (fluid-let
+      ((*imgpreamble-inferred* (cons 'epsfbox *imgpreamble-inferred*)))
+      (call-with-lazy-image-port
+        eps-file
+        img-file-stem
+        (lambda (o)
+          (display "\\epsfbox{" o)
+          (display eps-file o)
+          (display #\} o))))))
+
+(define do-epsf-size
+  (lambda (x)
+    (get-equal-sign)
+    (let ((n (get-pixels)))
+      (case x ((x) (set! *epsf-xsize* n)) ((y) (set! *epsf-ysize* n))))))
+
+(define do-epsfbox
+  (lambda ()
+    (let* ((b (get-bracketed-text-if-any)) (f (get-filename-possibly-braced)))
+      (unless *eval-for-tex-only?*
+        (cond
+         ((and (not *epsf-xsize*) (not *epsf-ysize*))
+          (let ((img-file-stem (next-html-image-file-stem)))
+            (lazily-make-epsf-image-file f img-file-stem)
+            (source-img-file img-file-stem)))
+         (else
+          (fluid-let
+            ((*imgpreamble-inferred* (cons 'epsfbox *imgpreamble-inferred*)))
+            (call-with-html-image-port
+              (lambda (o)
+                (when *epsf-xsize*
+                  (display "\\epsfxsize=" o)
+                  (display *epsf-xsize* o)
+                  (set! *epsf-xsize* #f)
+                  (display "bp" o)
+                  (newline o))
+                (when *epsf-ysize*
+                  (display "\\epsfysize=" o)
+                  (display *epsf-ysize* o)
+                  (set! *epsf-ysize* #f)
+                  (display "bp" o)
+                  (newline o))
+                (display "\\epsfbox{" o)
+                (display f o)
+                (display #\} o))))))))))
+
+(define do-epsfig
+  (lambda ()
+    (fluid-let
+      ((*imgpreamble-inferred* (cons 'epsfbox *imgpreamble-inferred*)))
+      (call-with-html-image-port
+        (lambda (o)
+          (display "\\epsfig{" o)
+          (dump-groupoid o)
+          (display #\} o))))))
+
+(define do-convertmptopdf
+  (lambda ()
+    (let ((f (get-filename-possibly-braced))
+          (img-file-stem (next-html-image-file-stem)))
+      (get-token)
+      (get-token)
+      (lazily-make-epsf-image-file f img-file-stem)
+      (source-img-file img-file-stem))))
+
+(define do-includegraphics
+  (lambda ()
+    (let* ((star? (eat-star))
+           (b1 (get-bracketed-text-if-any))
+           (b2 (and b1 (get-bracketed-text-if-any)))
+           (f (get-filename-possibly-braced))
+           (img-file-stem (next-html-image-file-stem))
+           (ffull
+            (if (file-exists? f)
+              f
+              (ormap
+               (lambda (e)
+                 (let ((f2 (string-append f e))) (and (file-exists? f2) f2)))
+               *graphics-file-extensions*))))
+      (fluid-let
+        ((*imgpreamble-inferred*
+           (cons 'includegraphics *imgpreamble-inferred*)))
+        (call-with-lazy-image-port
+          (or ffull f)
+          img-file-stem
+          (lambda (o)
+            (display "\\includegraphics" o)
+            (if star? (display #\* o))
+            (when b1 (display #\[ o) (display b1 o) (display #\] o))
+            (when b2 (display #\[ o) (display b2 o) (display #\] o))
+            (display #\{ o)
+            (display f o)
+            (display #\} o))))
+      (source-img-file img-file-stem))))
+
+(define do-resizebox
+  (lambda ()
+    (let* ((arg1 (get-group)) (arg2 (get-group)) (arg3 (get-group)))
+      (fluid-let
+        ((*imgpreamble-inferred*
+           (cons 'includegraphics *imgpreamble-inferred*)))
+        (call-with-html-image-port
+          (lambda (o)
+            (display "\\resizebox" o)
+            (display arg1 o)
+            (display arg2 o)
+            (display arg3 o)))))))
+
+(define do-mfpic-opengraphsfile
+  (lambda ()
+    (set! *mfpic-file-stem* (get-filename-possibly-braced))
+    (when *mfpic-port* (close-output-port *mfpic-port*))
+    (let ((f (string-append *mfpic-file-stem* *mfpic-tex-file-suffix*)))
+      (ensure-file-deleted f)
+      (set! *mfpic-port* (open-output-file f)))
+    (set! *mfpic-file-num* 0)
+    (display "\\input mfpic \\usemetapost " *mfpic-port*)
+    (newline *mfpic-port*)
+    (display "\\opengraphsfile{" *mfpic-port*)
+    (display *mfpic-file-stem* *mfpic-port*)
+    (display #\} *mfpic-port*)
+    (newline *mfpic-port*)
+    (tex-def-prim
+      "\\headshape"
+      (lambda ()
+        (let* ((g1 (get-group)) (g2 (get-group)) (g3 (get-group)))
+          (display "\\headshape" *mfpic-port*)
+          (display g1 *mfpic-port*)
+          (display g2 *mfpic-port*)
+          (display g3 *mfpic-port*)
+          (newline *mfpic-port*))))
+    (tex-def-prim "\\mfpframesep" eat-dimen)
+    (tex-def-prim "\\mftitle" get-group)))
+
+(define do-mfpic-closegraphsfile
+  (lambda ()
+    (display "\\closegraphsfile" *mfpic-port*)
+    (newline *mfpic-port*)
+    (close-output-port *mfpic-port*)
+    (let ((tex-f (string-append *mfpic-file-stem* *mfpic-tex-file-suffix*))
+          (mp-f (string-append *mfpic-file-stem* ".mp")))
+      (unless (file-exists? mp-f)
+        (fluid-let ((*tex-format* 'plain)) (call-tex tex-f)))
+      (when (file-exists? mp-f)
+        (system (string-append *metapost* " " *mfpic-file-stem*))))))
+
+(define do-mfpic
+  (lambda ()
+    (display "\\mfpic" *mfpic-port*)
+    (dump-till-end-env "mfpic" *mfpic-port*)
+    (display "\\endmfpic" *mfpic-port*)
+    (newline *mfpic-port*)
+    (set! *mfpic-file-num* (+ *mfpic-file-num* 1))
+    (let ((f
+           (string-append
+             *mfpic-file-stem*
+             "."
+             (number->string *mfpic-file-num*)))
+          (img-file-stem (next-html-image-file-stem)))
+      (lazily-make-epsf-image-file f img-file-stem)
+      (source-img-file img-file-stem))))
+
+(define do-following-latex-env-as-image
+  (lambda () (do-latex-env-as-image (ungroup (get-group)) 'display)))
+
+(define do-latex-env-as-image
+  (lambda (env inline-or-display?)
+    (when (char=? (snoop-actual-char) #\*)
+      (get-actual-char)
+      (set! env (string-append env "*")))
+    (egroup)
+    (when (eq? inline-or-display? 'display)
+      (do-end-para)
+      (emit "<div align=")
+      (emit *display-justification*)
+      (emit ">"))
+    (call-with-html-image-port
+      (lambda (o)
+        (display "\\begin{" o)
+        (display env o)
+        (display "}" o)
+        (dump-till-end-env env o)
+        (display "\\end{" o)
+        (display env o)
+        (display "}" o)
+        (newline o)))
+    (when (eq? inline-or-display? 'display) (emit "</div>") (do-para))))
+
+(define do-box
+  (lambda ()
+    (fluid-let ((*ignore-active-space?* #t)) (ignorespaces) (get-to))
+    (eat-dimen)
+    (ignorespaces)
+    (let ((c (snoop-actual-char))) (case c ((#\{) #t) ((#\\) (get-ctl-seq))))
+    (get-actual-char)
+    (bgroup)
+    (add-postlude-to-top-frame
+      (let ((old-math-mode? *math-mode?*)
+            (old-in-display-math? *in-display-math?*)
+            (old-tabular-stack *tabular-stack*)
+            (old-ligatures? *ligatures?*))
+        (set! *math-mode?* #f)
+        (set! *in-display-math?* #f)
+        (set! *tabular-stack* '())
+        (set! *ligatures?* #t)
+        (lambda ()
+          (set! *math-mode?* old-math-mode?)
+          (set! *in-display-math?* old-in-display-math?)
+          (set! *tabular-stack* old-tabular-stack)
+          (set! *ligatures?* old-ligatures?))))))
+
+(define do-latex-frac
+  (lambda ()
+    (emit "(")
+    (tex2page-string (get-token))
+    (emit "/")
+    (tex2page-string (get-token))
+    (emit ")")))
+
+(define do-tex-frac
+  (lambda ()
+    (ignorespaces)
+    (let ((inner-level?
+            (or (not *in-display-math?*) (not (null? *tabular-stack*)))))
+      (fluid-let
+        ((*tabular-stack* (cons 'frac *tabular-stack*)))
+        (cond
+         (inner-level?
+          (emit "<sup>")
+          (tex2page-string (get-till-char #\/))
+          (emit "</sup>/<sub>")
+          (get-actual-char)
+          (ignorespaces)
+          (tex2page-string (get-token))
+          (emit "</sub>"))
+         (else
+          (emit "</td><td><table align=left><tr><td align=center>")
+          (tex2page-string (get-till-char #\/))
+          (get-actual-char)
+          (ignorespaces)
+          (emit "<hr noshade>")
+          (tex2page-string (get-token))
+          (emit "</td></tr></table></td><td>")))))))
+
+(define do-frac
+  (lambda () ((if (eqv? *tex-format* 'latex) do-latex-frac do-tex-frac))))
+
+(define do-eqno
+  (lambda ()
+    (unless *in-display-math?*
+      (terror 'do-eqno "You can't use \\eqno in math mode"))
+    (emit "</td><td width=10% align=right>")))
+
+(define do-eqalign
+  (lambda (type)
+    (ignorespaces)
+    (let ((c (get-actual-char)))
+      (when (eof-object? c) (terror 'do-eqalign "Missing {"))
+      (unless (char=? c #\{) (terror 'do-eqalign "Missing {"))
+      (bgroup)
+      (set! *tabular-stack* (cons type *tabular-stack*))
+      (add-postlude-to-top-frame
+        (lambda ()
+          (emit "</td></tr>")
+          (emit-newline)
+          (emit "</table>")
+          (emit-newline)
+          (when *in-display-math?* (emit "</td><td>"))
+          (pop-tabular-stack type)
+          (set! *equation-position* 0)))
+      (when *in-display-math?* (emit "</td><td>"))
+      (emit-newline)
+      (emit "<table><tr><td>"))))
+
+(define do-noalign
+  (lambda ()
+    (let* ((type (and (not (null? *tabular-stack*)) (car *tabular-stack*)))
+           (split? (memv type '(eqalignno displaylines))))
+      (when split?
+        (egroup)
+        (emit "</td></tr></table></div>")
+        (emit-newline)
+        (do-para))
+      (tex2page-string (get-group))
+      (cond
+       (split?
+        (do-end-para)
+        (emit-newline)
+        (emit "<div align=center><table><tr><td>")
+        (toss-back-char #\{)
+        (do-eqalign type))
+       (else (emit "</td></tr>") (emit-newline) (emit "<tr><td>"))))))
+
+(define do-pmatrix
+  (lambda ()
+    (ignorespaces)
+    (let ((c (get-actual-char)))
+      (if (eof-object? c) (terror 'do-pmatrix "Missing {"))
+      (unless (char=? c #\{) (terror 'do-pmatrix "Missing {"))
+      (bgroup)
+      (set! *tabular-stack* (cons 'pmatrix *tabular-stack*))
+      (add-postlude-to-top-frame
+        (lambda ()
+          (emit "</td></tr></table>")
+          (when *in-display-math?* (emit "</td><td>"))
+          (emit-newline)
+          (pop-tabular-stack 'pmatrix)))
+      (when *in-display-math?* (emit "</td><td>"))
+      (emit "<table border=1><tr><td>")
+      (emit-newline))))
+
+(define eat-till-eol
+  (lambda ()
+    (let loop ()
+      (let ((c (get-actual-char)))
+        (unless (or (eof-object? c) (char=? c #\newline)) (loop))))))
+
+(define do-comment
+  (lambda ()
+    (eat-till-eol)
+    (if (munched-a-newline?)
+      (begin (toss-back-char #\newline) (toss-back-char #\newline)))))
+
+(define latex-style-file?
+  (lambda (f) (let ((e (file-extension f))) (and e (string-ci=? e ".sty")))))
+
+(define path-to-list
+  (lambda (p)
+    (if (not p)
+      '()
+      (let loop ((p p) (r '()))
+        (let ((i (string-index p *path-separator*)))
+          (if i
+            (loop
+             (substring p (+ i 1) (string-length p))
+             (cons (substring p 0 i) r))
+            (reverse! (cons p r))))))))
+
+(define kpsewhich
+  (lambda (f)
+    (let ((tmpf (string-append *aux-dir/* *jobname* "-Z-Z.temp")))
+      (system (string-append "kpsewhich " f " > " tmpf))
+      (let ((f (call-with-input-file tmpf (lambda (i) (read-line i)))))
+        (delete-file tmpf)
+        (if (eof-object? f)
+          #f
+          (let ((f (string-trim-blanks f)))
+            (cond
+             ((= (string-length f) 0) #f)
+             ((file-exists? f) f)
+             (else #f))))))))
+
+(define find-tex-file
+  (lambda (file)
+    (let ((files (list (string-append file ".tex") file)))
+      (or (ormap (lambda (file) (and (file-exists? file) file)) files)
+          (if (not (null? *tex2page-inputs*))
+            (ormap
+             (lambda (dir)
+               (ormap
+                (lambda (file)
+                  (let ((qfile (string-append dir *directory-separator* file)))
+                    (and (file-exists? qfile) qfile)))
+                files))
+             *tex2page-inputs*)
+            (kpsewhich file))))))
+
+(define actual-tex-filename
+  (lambda (f check-timestamp?)
+    (let ((doing-main-file? (not *main-tex-file*)) (f2 (find-tex-file f)))
+      (when doing-main-file?
+        (when f2
+          (set! *jobname* (file-stem-name f2))
+          (make-target-dir)
+          (let ((zeroth-html-page
+                  (string-append *aux-dir/* *jobname* *output-extension*)))
+            (when (string=? zeroth-html-page f2)
+              (let ((f2-save (string-append f2 "_save")))
+                (write-log 'separation-newline)
+                (write-log "Copying weirdly named TeX source file ")
+                (write-log f2)
+                (write-log " to ")
+                (write-log f2-save)
+                (write-log 'separation-newline)
+                (case *operating-system*
+                  ((unix) (system (string-append "cp -pf " f2 " " f2-save)))
+                  ((windows)
+                   (system (string-append "copy/y " f2 " " f2-save))))
+                (set! f2 f2-save))))
+          (initialize-global-texframe))
+        (load-aux-file))
+      (when (and
+             f2
+             check-timestamp?
+             (ormap (lambda (vwf) (string=? f2 vwf)) *verb-written-files*))
+        (set! check-timestamp? #f))
+      (when (and f2 check-timestamp?) (update-last-modification-time f2))
+      f2)))
+
+(define add-dot-tex-if-no-extension-provided
+  (lambda (f)
+    (let ((e (file-extension f))) (if e f (string-append f ".tex")))))
+
+(define ignore-tex-specific-text
+  (lambda (env)
+    (let ((endenv (string-append "\\end" env)))
+      (let loop ()
+        (let ((c (snoop-actual-char)))
+          (cond
+           ((eof-object? c)
+            (terror 'ignore-tex-specific-text "Missing \\end" env))
+           ((char=? c *esc-char*)
+            (let ((x (get-ctl-seq)))
+              (cond
+               ((string=? x endenv) #t)
+               ((string=? x "\\end")
+                (let ((g (get-grouped-environment-name-if-any)))
+                  (unless (and g (string=? g env)) (loop))))
+               (else (loop)))))
+           (else (get-actual-char) (loop))))))))
+
+(define do-rawhtml
+  (lambda ()
+    (let loop ()
+      (let ((c (snoop-actual-char)))
+        (cond
+         ((eof-object? c) (terror 'do-rawhtml "Missing \\endrawhtml"))
+         ((char=? c *esc-char*)
+          (let* ((x (get-ctl-seq)) (y (find-corresp-prim x)))
+            (cond
+             ((string=? y "\\endrawhtml") 'done)
+             ((and (string=? x "\\end") (get-grouped-environment-name-if-any))
+              =>
+              (lambda (g)
+                (let ((y (find-corresp-prim (string-append x g))))
+                  (if (string=? y "\\endrawhtml")
+                    'done
+                    (begin (emit "\\end{") (emit g) (emit "}") (loop))))))
+             ((string=? x "\\\\") (emit c) (toss-back-char c) (loop))
+             (else (emit x) (loop)))))
+         (else (get-actual-char) (emit c) (loop)))))))
+
+(define do-htmlheadonly
+  (lambda ()
+    (when (null? *html-head*) (flag-missing-piece 'html-head))
+    (let loop ((s '()))
+      (let ((c (snoop-actual-char)))
+        (cond
+         ((eof-object? c) (write-aux `(!header ,(list->string (reverse! s)))))
+         ((char=? c *esc-char*)
+          (write-aux `(!header ,(list->string (reverse! s))))
+          (let ((x (get-ctl-seq)))
+            (cond
+             ((string=? x "\\endhtmlheadonly") 'done)
+             ((string=? x "\\input")
+              (let ((f (get-filename-possibly-braced)))
+                (call-with-input-file/buffered f do-htmlheadonly)
+                (loop '())))
+             (else (write-aux `(!header ,x)) (loop '())))))
+         (else (get-actual-char) (loop (cons c s))))))))
+
+(define resolve-chardefs
+  (lambda (c)
+    (cond
+     ((find-chardef c)
+      =>
+      (lambda (y)
+        (get-actual-char)
+        (expand-tex-macro (cdef.optarg y) (cdef.argpat y) (cdef.expansion y))))
+     (else #f))))
+
+(define resolve-defs
+  (lambda (x)
+    (cond
+     ((find-def x)
+      =>
+      (lambda (y)
+        (cond
+         ((tdef.defer y) => (lambda (z) z))
+         ((tdef.thunk y) #f)
+         (else
+          (cond
+           ((and (inside-false-world?)
+                 (not (if-aware-ctl-seq? x))
+                 (> (length (tdef.argpat y)) 0))
+            #f)
+           (else
+            (expand-tex-macro
+              (tdef.optarg y)
+              (tdef.argpat y)
+              (tdef.expansion y))))))))
+     (else #f))))
+
+(define do-expandafter
+  (lambda ()
+    (let* ((first (get-raw-token/is)) (second (get-raw-token/is)))
+      (toss-back-char *invisible-space*)
+      (cond
+       ((ctl-seq? second)
+        (toss-back-string (expand-ctl-seq-into-string second)))
+       (else (toss-back-string second)))
+      (toss-back-char *invisible-space*)
+      (toss-back-string first))))
+
+(define set-start-time
+  (lambda ()
+    (let* ((secs (current-seconds)) (ht (and secs (seconds->date secs))))
+      (cond
+       (ht
+        (tex-def-count "\\time" (+ (* 60 (date-hour ht)) (date-minute ht)) #t)
+        (tex-def-count "\\day" (date-day ht) #t)
+        (tex-def-count "\\month" (+ (date-month ht) (- 1) 1) #t)
+        (tex-def-count "\\year" (+ 0 (date-year ht)) #t))
+       (else
+        (tex-def-count "\\time" 0 #t)
+        (tex-def-count "\\day" 0 #t)
+        (tex-def-count "\\month" 0 #t)
+        (tex-def-count "\\year" 0 #t))))))
+
+(define initialize-global-texframe
+  (lambda ()
+    (set-start-time)
+    (tex-def-count "\\language" 256 #t)
+    (tex-def-count "\\secnumdepth" -2 #t)
+    (tex-def-count "\\tocdepth" -2 #t)
+    (tex-def-count "\\footnotenumber" 0 #t)
+    (tex-def-count "\\TIIPtabularborder" 1 #t)
+    (tex-def-count "\\TIIPnestedtabularborder" 0 #t)
+    (tex-def-count "\\TIIPobeyspacestrictly" 0 #t)
+    (tex-def-count "\\TIIPobeylinestrictly" 0 #t)
+    (tex-def-count "\\errorcontextlines" 5 #t)
+    (tex-def-toks "\\TIIPrecentlabelname" "" #t)
+    (tex-def-toks "\\TIIPrecentlabelvalue" "" #t)
+    (tex-def-toks "\\everypar" "" #t)
+    (tex-def-dotted-count "figure" #f)
+    (tex-def-dotted-count "table" #f)
+    (tex-def-dotted-count "equation" #f)
+    (tex-def "\\empty" '() "" #f #f "\\empty" #f *global-texframe*)))
+
+(define find-def
+  (lambda (ctlseq)
+    (let ((c
+           (or (ormap
+                (lambda (fr)
+                  (lassoc ctlseq (texframe.definitions fr) string=?))
+                *tex-env*)
+               (lassoc
+                 ctlseq
+                 (texframe.definitions *global-texframe*)
+                 string=?)
+               (lassoc
+                 ctlseq
+                 (texframe.definitions *primitive-texframe*)
+                 string=?))))
+      (and c (cdr c)))))
+
+(define find-math-def
+  (lambda (ctlseq)
+    (let ((c
+           (lassoc
+             ctlseq
+             (texframe.definitions *math-primitive-texframe*)
+             string=?)))
+      (and c (cdr c)))))
+
+(define find-count
+  (lambda (ctlseq)
+    (or (ormap
+         (lambda (fr) (lassoc ctlseq (texframe.counts fr) string=?))
+         *tex-env*)
+        (lassoc ctlseq (texframe.counts *global-texframe*) string=?)
+        (lassoc ctlseq (texframe.counts *primitive-texframe*) string=?))))
+
+(define find-toks
+  (lambda (ctlseq)
+    (or (ormap
+         (lambda (fr) (lassoc ctlseq (texframe.toks fr) string=?))
+         *tex-env*)
+        (lassoc ctlseq (texframe.toks *global-texframe*) string=?)
+        (lassoc ctlseq (texframe.toks *primitive-texframe*) string=?))))
+
+(define find-dimen
+  (lambda (ctlseq)
+    (or (ormap
+         (lambda (fr) (lassoc ctlseq (texframe.dimens fr) string=?))
+         *tex-env*)
+        (lassoc ctlseq (texframe.dimens *global-texframe*) string=?)
+        (lassoc ctlseq (texframe.dimens *primitive-texframe*) string=?))))
+
+(define get-toks
+  (lambda (ctlseq)
+    (cond ((find-toks ctlseq) => cadr) (else (terror 'get-toks)))))
+
+(define the-count
+  (lambda (ctlseq)
+    (let ((dracula (find-count ctlseq)))
+      (unless dracula (terror 'the-count))
+      (cadr dracula))))
+
+(define do-count=
+  (lambda (z global?) (get-equal-sign) (tex-def-count z (get-number) global?)))
+
+(define do-toks=
+  (lambda (z global?) (get-equal-sign) (tex-def-toks z (get-group) global?)))
+
+(define do-dimen=
+  (lambda (z global?)
+    (get-equal-sign)
+    (ignorespaces)
+    (if (char=? (snoop-actual-char) *esc-char*) (get-ctl-seq) (eat-dimen))))
+
+(define get-gcount
+  (lambda (ctlseq)
+    (cadr (lassoc ctlseq (texframe.counts *global-texframe*) string=?))))
+
+(define set-gcount! (lambda (ctlseq v) (tex-def-count ctlseq v #t)))
+
+(define do-number (lambda () (emit (get-number))))
+
+(define do-the
+  (lambda ()
+    (let ((ctlseq (get-ctl-seq)))
+      (cond
+       ((get-number-corresp-to-ctl-seq ctlseq) => emit)
+       ((find-toks ctlseq) => (lambda (x) (tex2page-string (cadr x))))
+       (else (trace-if #f "do-the failed"))))))
+
+(define find-corresp-prim
+  (lambda (ctlseq)
+    (let ((y (find-def ctlseq))) (or (and y (tdef.defer y)) ctlseq))))
+
+(define find-corresp-prim-thunk
+  (lambda (ctlseq)
+    (let ((y (find-def ctlseq)))
+      (if (and y (tdef.thunk y)) (tdef.prim y) ctlseq))))
+
+(define do-def
+  (lambda (global?)
+    (unless (inside-false-world?)
+      (let* ((lhs (get-raw-token/is))
+             (argpat (get-def-arguments lhs))
+             (rhs (ungroup (get-group)))
+             (frame (and global? *global-texframe*)))
+        (if (ctl-seq? lhs)
+          (tex-def lhs argpat rhs #f #f #f #f frame)
+          (tex-def-char (string-ref lhs 0) argpat rhs frame))))))
+
+(define do-newcount (lambda (global?) (tex-def-count (get-ctl-seq) 0 global?)))
+
+(define do-newtoks (lambda (global?) (tex-def-toks (get-ctl-seq) "" global?)))
+
+(define do-newdimen (lambda (global?) (tex-def-dimen (get-ctl-seq) global?)))
+
+(define do-advance
+  (lambda (global?)
+    (let* ((ctlseq (get-ctl-seq)) (count (find-count ctlseq)))
+      (get-by)
+      (if count
+        (tex-def-count ctlseq (+ (cadr count) (get-number)) global?)
+        (eat-dimen)))))
+
+(define do-multiply
+  (lambda (global?)
+    (let* ((ctlseq (get-ctl-seq)) (curr-val (cadr (find-count ctlseq))))
+      (get-by)
+      (tex-def-count ctlseq (* curr-val (get-number)) global?))))
+
+(define do-divide
+  (lambda (global?)
+    (let* ((ctlseq (get-ctl-seq)) (curr-val (cadr (find-count ctlseq))))
+      (get-by)
+      (tex-def-count ctlseq (quotient curr-val (get-number)) global?))))
+
+(define do-newcommand
+  (lambda (renew?)
+    (ignorespaces)
+    (let* ((lhs (string-trim-blanks (ungroup (get-token))))
+           (optarg #f)
+           (argc
+            (cond
+             ((get-bracketed-text-if-any)
+              =>
+              (lambda (s)
+                (cond
+                 ((get-bracketed-text-if-any) => (lambda (s) (set! optarg s))))
+                (string->number (string-trim-blanks s))))
+             (else 0)))
+           (rhs (ungroup (get-token)))
+           (ok-to-def? (or renew? (not (find-def lhs)))))
+      (tex-def lhs (latex-arg-num->plain-argpat argc) rhs optarg #f #f #f #f)
+      (unless ok-to-def?
+        (trace-if *tracingcommands?* lhs " already defined")))))
+
+(define do-advancetally
+  (lambda (global?)
+    (let* ((ctlseq (get-ctl-seq))
+           (increment
+             (string->number (string-trim-blanks (ungroup (get-token))))))
+      (tex-def
+        ctlseq
+        '()
+        (number->string
+          (+ (string->number (or (resolve-defs ctlseq) ctlseq)) increment))
+        #f
+        #f
+        #f
+        #f
+        global?))))
+
+(define do-newenvironment
+  (lambda (renew?)
+    (ignorespaces)
+    (let* ((envname (string-trim-blanks (ungroup (get-token))))
+           (bs-envname (string-append "\\" envname))
+           (optarg #f)
+           (argc
+            (cond
+             ((get-bracketed-text-if-any)
+              =>
+              (lambda (s)
+                (cond
+                 ((get-bracketed-text-if-any) => (lambda (s) (set! optarg s))))
+                (string->number (string-trim-blanks s))))
+             (else 0)))
+           (beginning (string-append "\\begingroup " (ungroup (get-token))))
+           (ending (string-append (ungroup (get-token)) "\\endgroup"))
+           (ok-to-def? (or renew? (not (find-def bs-envname)))))
+      (tex-def
+        bs-envname
+        (latex-arg-num->plain-argpat argc)
+        beginning
+        optarg
+        #f
+        #f
+        #f
+        #f)
+      (tex-def (string-append "\\end" envname) '() ending #f #f #f #f #f)
+      (unless ok-to-def? (trace-if #t "{" envname "} already defined")))))
+
+(define tex-def-dotted-count
+  (lambda (counter-name sec-num)
+    (when sec-num
+      (hash-table-put!
+        *section-counter-dependencies*
+        sec-num
+        (cons
+         counter-name
+         (table-get *section-counter-dependencies* sec-num '()))))
+    (hash-table-put!
+      *dotted-counters*
+      counter-name
+      (make-counter 'within sec-num))))
+
+(define do-newtheorem
+  (lambda ()
+    (let* ((env (ungroup (get-group)))
+           (numbered-like (get-bracketed-text-if-any))
+           (counter-name (or numbered-like env))
+           (caption (ungroup (get-group)))
+           (within (if numbered-like #f (get-bracketed-text-if-any)))
+           (sec-num
+             (and within (section-ctl-seq? (string-append "\\" within)))))
+      (unless numbered-like (tex-def-dotted-count counter-name sec-num))
+      (tex-def
+        (string-append "\\" env)
+        '()
+        (string-append
+          "\\par\\begingroup\\TIIPtheorem{"
+          counter-name
+          "}{"
+          caption
+          "}")
+        #f
+        #f
+        #f
+        #f
+        *global-texframe*)
+      (tex-def
+        (string-append "\\end" env)
+        '()
+        "\\endgroup\\par"
+        #f
+        #f
+        #f
+        #f
+        *global-texframe*))))
+
+(define do-theorem
+  (lambda ()
+    (let* ((counter-name (ungroup (get-group)))
+           (counter (table-get *dotted-counters* counter-name))
+           (caption (ungroup (get-group))))
+      (unless counter (terror 'do-theorem))
+      (let ((new-counter-value (+ 1 (counter.value counter))))
+        (set!counter.value counter new-counter-value)
+        (let* ((thm-num
+                 (let ((sec-num (counter.within counter)))
+                   (if sec-num
+                     (string-append
+                       (section-counter-value sec-num)
+                       "."
+                       (number->string new-counter-value))
+                     (number->string new-counter-value))))
+               (lbl (string-append *html-node-prefix* "thm_" thm-num)))
+          (tex-def-toks "\\TIIPrecentlabelname" lbl #f)
+          (tex-def-toks "\\TIIPrecentlabelvalue" thm-num #f)
+          (emit-anchor lbl)
+          (emit-newline)
+          (emit "<b>")
+          (emit caption)
+          (emit " ")
+          (emit thm-num)
+          (emit ".</b>")
+          (emit-nbsp 2))))))
+
+(define do-begin
+  (lambda ()
+    (cond
+     ((get-grouped-environment-name-if-any)
+      =>
+      (lambda (env)
+        (toss-back-char *invisible-space*)
+        (toss-back-string (string-append "\\" env))
+        (unless (ormap
+                 (lambda (y) (string=? env y))
+                 '("htmlonly"
+                   "cssblock"
+                   "document"
+                   "latexonly"
+                   "rawhtml"
+                   "texonly"
+                   "verbatim"
+                   "verbatim*"))
+          (toss-back-string "\\begingroup")
+          (do-end-para))))
+     (else (terror 'do-begin "\\begin not followed by environment name")))))
+
+(define do-end
+  (lambda ()
+    (cond
+     ((get-grouped-environment-name-if-any)
+      =>
+      (lambda (env)
+        (toss-back-char *invisible-space*)
+        (unless (ormap (lambda (y) (string=? env y)) '("htmlonly" "document"))
+          (do-end-para)
+          (toss-back-string "\\endgroup"))
+        (toss-back-string (string-append "\\end" env))))
+     (else (toss-back-char *invisible-space*) (toss-back-string "\\bye")))))
+
+(define latex-arg-num->plain-argpat
+  (lambda (n)
+    (let loop ((n n) (s '()))
+      (if (<= n 0)
+        s
+        (loop
+         (- n 1)
+         (cons #\# (cons (integer->char (+ *int-corresp-to-0* n)) s)))))))
+
+(define do-let
+  (lambda (global?)
+    (unless (inside-false-world?)
+      (ignorespaces)
+      (let* ((lhs (get-ctl-seq))
+             (rhs (begin (get-equal-sign) (get-raw-token/is)))
+             (frame (and global? *global-texframe*)))
+        (unless (and
+                 (ormap
+                  (lambda (z) (string=? lhs z))
+                  '("\\texonly" "\\endtexonly"))
+                 (string=? rhs "\\relax"))
+          (if (ctl-seq? rhs)
+            (tex-let lhs rhs frame)
+            (tex-def lhs '() rhs #f #f #f #f frame)))))))
+
+(define make-reusable-img
+  (lambda (global?)
+    (set! *imgdef-file-count* (+ *imgdef-file-count* 1))
+    (ignorespaces)
+    (let ((lhs (get-ctl-seq))
+          (imgdef-file-stem
+            (string-append
+              *subjobname*
+              *img-file-suffix*
+              *imgdef-file-suffix*
+              (number->string *imgdef-file-count*))))
+      (dump-imgdef imgdef-file-stem)
+      (tex-to-img imgdef-file-stem)
+      (tex-def
+        lhs
+        '()
+        (string-append "\\TIIPreuseimage{" imgdef-file-stem "}")
+        #f
+        #f
+        #f
+        #f
+        (and global? *global-texframe*)))))
+
+(define valid-img-file?
+  (lambda (f)
+    (and (file-exists? f)
+         (or (call-with-input-file
+               f
+               (lambda (i) (not (eof-object? (read-char i)))))
+             (begin (delete-file f) #f)))))
+
+(define source-img-file
+  (lambda (img-file-stem . alt)
+    (let* ((alt (if (null? alt) #f (car alt)))
+           (img-file (string-append img-file-stem *img-file-extn*))
+           (f (string-append *aux-dir/* img-file)))
+      (write-log #\()
+      (write-log f)
+      (write-log 'separation-space)
+      (valid-img-file? f)
+      (emit "<img src=\"")
+      (emit img-file)
+      (emit "\" border=\"0\" alt=\"")
+      (cond (alt (emit alt)) (else (emit "[") (emit img-file) (emit "]")))
+      (emit "\">")
+      (write-log #\))
+      (write-log 'separation-space)
+      #t)))
+
+(define source-scaled-image-file
+  (lambda (image-file-stem ht wth)
+    (let* ((image-file (string-append image-file-stem *img-file-extn*))
+           (f (string-append *aux-dir/* image-file)))
+      (write-log #\()
+      (write-log f)
+      (write-log 'separation-space)
+      (valid-img-file? f)
+      (emit "<img")
+      (when ht (emit " height=") (emit ht))
+      (when wth (emit " width=") (emit wth))
+      (emit " src=\"")
+      (emit image-file)
+      (emit "\" border=\"0\">")
+      (write-log #\))
+      (write-log 'separation-space)
+      #t)))
+
+(define reuse-img (lambda () (source-img-file (ungroup (get-group)))))
+
+(define get-def-arguments
+  (lambda (lhs)
+    (let aux ()
+      (let ((c (snoop-actual-char)))
+        (cond
+         ((eof-object? c)
+          (terror
+            'get-def-arguments
+            "EOF found while scanning definition of "
+            lhs))
+         ((char=? c #\{) '())
+         (else
+          (cond
+           ((char=? c #\newline) (get-actual-char) (ignorespaces))
+           ((char-whitespace? c) (ignorespaces) (set! c #\space))
+           (else (get-actual-char)))
+          (cons c (aux))))))))
+
+(define get-till-char
+  (lambda (c0)
+    (list->string
+      (reverse!
+        (let loop ((s '()) (nesting 0) (escape? #f))
+          (let ((c (snoop-actual-char)))
+            (cond
+             ((eof-object? c) (terror 'get-till-char "File ended too soon"))
+             (escape? (loop (cons (get-actual-char) s) nesting #f))
+             ((char=? c c0) s)
+             ((char=? c *esc-char*)
+              (loop (cons (get-actual-char) s) nesting #t))
+             ((char=? c #\{)
+              (loop (cons (get-actual-char) s) (+ nesting 1) #f))
+             ((char=? c #\})
+              (loop (cons (get-actual-char) s) (- nesting 1) #f))
+             ((> nesting 0) (loop (cons (get-actual-char) s) nesting #f))
+             ((and (char-whitespace? c)
+                   (not (char=? c0 #\newline))
+                   (char-whitespace? c0))
+              s)
+             (else (loop (cons (get-actual-char) s) nesting #f)))))))))
+
+(define digit->int (lambda (d) (- (char->integer d) *int-corresp-to-0*)))
+
+(define do-halign
+  (lambda ()
+    (do-end-para)
+    (ignorespaces)
+    (let ((c (get-actual-char)))
+      (if (eof-object? c) (terror 'do-halign "Missing {"))
+      (unless (char=? c #\{) (terror 'do-halign "Missing {")))
+    (fluid-let
+      ((*tabular-stack* (cons 'halign *tabular-stack*)))
+      (bgroup)
+      (emit "<table>")
+      (let ((tmplt (get-halign-template)))
+        (let loop ()
+          (ignorespaces)
+          (let ((c (snoop-actual-char)))
+            (cond
+             ((eof-object? c) (terror 'do-halign "Eof inside \\halign"))
+             ((char=? c #\})
+              (get-actual-char)
+              (emit "</table>")
+              (egroup)
+              (do-para))
+             (else (expand-halign-line tmplt) (loop)))))))))
+
+(define get-halign-template
+  (lambda ()
+    (let loop ((s '()))
+      (let ((x (get-raw-token)))
+        (cond
+         ((eof-object? x) (terror 'get-halign-template "Eof in \\halign"))
+         ((string=? x "\\cr") (reverse! (cons #f s)))
+         ((string=? x "#") (loop (cons #t s)))
+         ((string=? x "&") (loop (cons #f s)))
+         (else (loop (cons x s))))))))
+
+(define expand-halign-line
+  (lambda (tmplt)
+    (emit "<tr>")
+    (let loop ((tmplt tmplt) (ins " "))
+      (let ((x (get-raw-token)))
+        (cond
+         ((eof-object? x) (terror 'expand-halign-line "Eof in \\halign"))
+         ((or (string=? x "&") (string=? x "\\cr"))
+          (let loop2 ((tmplt tmplt) (r "{"))
+            (if (null? tmplt)
+              (terror 'expand-halign-line "Eof in \\halign")
+              (let ((y (car tmplt)))
+                (case y
+                  ((#f)
+                   (emit "<td>")
+                   (tex2page-string (string-append r "}"))
+                   (emit "</td>")
+                   (if (string=? x "\\cr")
+                     (begin (emit "</tr>") (emit-newline))
+                     (loop (cdr tmplt) " ")))
+                  ((#t) (loop2 (cdr tmplt) (string-append r ins)))
+                  (else (loop2 (cdr tmplt) (string-append r y))))))))
+         (else (loop tmplt (string-append ins x))))))))
+
+(define read-till-next-sharp
+  (lambda (k argpat)
+    (let ((n (length argpat)))
+      (let loop ((ss '()))
+        (let loop2 ((i k) (s '()))
+          (let ((c (if (< i n) (list-ref argpat i) #\#)))
+            (if (char=? c #\#)
+              (cons i (list->string (reverse! ss)))
+              (let ((d (snoop-actual-char)))
+                (cond
+                 ((and (char=? c #\space) (char-whitespace? d))
+                  (if (char=? d #\newline) (get-actual-char) (ignorespaces))
+                  (loop2 (+ i 1) (cons c s)))
+                 ((and (char=? c #\newline)
+                       (char-whitespace? d)
+                       (or (munched-a-newline?) (begin (toss-back-char d) #f)))
+                  (loop2 (+ i 1) (cons c s)))
+                 ((char=? c d) (get-actual-char) (loop2 (+ i 1) (cons c s)))
+                 ((= i k)
+                  (loop
+                   (if (and (char=? d #\{)
+                            (or (null? ss) (not (char=? (car ss) *esc-char*))))
+                     (append (get-group-as-reversed-chars) ss)
+                     (begin
+                       (if (and (char-whitespace? d)
+                                (not (char=? d #\newline)))
+                         (ignorespaces)
+                         (get-actual-char))
+                       (cons d ss)))))
+                 (else (loop (append s ss))))))))))))
+
+(define read-macro-args
+  (lambda (argpat k r)
+    (let ((n (length argpat)))
+      (reverse!
+        (let loop ((k k) (r r))
+          (if (>= k n)
+            r
+            (let ((c (list-ref argpat k)))
+              (cond
+               ((char=? c #\#)
+                (cond
+                 ((= k (- n 1)) (cons (get-till-char #\{) r))
+                 ((= k (- n 2)) (cons (ungroup (get-token)) r))
+                 (else
+                  (let ((c2 (list-ref argpat (+ k 2))))
+                    (if (char=? c2 #\#)
+                      (loop (+ k 2) (cons (ungroup (get-token)) r))
+                      (let ((x (read-till-next-sharp (+ k 2) argpat)))
+                        (loop (car x) (cons (cdr x) r))))))))
+               (else
+                (let ((d (get-actual-char)))
+                  (cond
+                   ((eof-object? d)
+                    (terror
+                      'read-macro-args
+                      "Eof before macro got enough args"))
+                   ((char=? c d) (loop (+ k 1) r))
+                   (else
+                    (terror
+                      'read-macro-args
+                      "Misformed macro call")))))))))))))
+
+(define expand-tex-macro
+  (lambda (optarg argpat rhs)
+    (let* ((k 0)
+           (r
+            (if (not optarg)
+              '()
+              (begin
+                (set! k 2)
+                (list
+                 (cond
+                  ((get-bracketed-text-if-any) => (lambda (s) s))
+                  (else optarg))))))
+           (args (read-macro-args argpat k r))
+           (rhs-n (string-length rhs)))
+      (list->string
+        (let aux ((k 0))
+          (if (>= k rhs-n)
+            '()
+            (let ((c (string-ref rhs k)))
+              (cond
+               ((char=? c #\\)
+                (let loop ((j (+ k 1)) (s (list #\\)))
+                  (if (>= j rhs-n)
+                    (reverse! s)
+                    (let ((c (string-ref rhs j)))
+                      (cond
+                       ((char-alphabetic? c) (loop (+ j 1) (cons c s)))
+                       ((and (char=? c #\#) (> (length s) 1))
+                        (append (reverse! s) (cons #\space (aux j))))
+                       ((= (length s) 1)
+                        (append (reverse! (cons c s)) (aux (+ j 1))))
+                       (else (append (reverse! s) (aux j))))))))
+               ((char=? c #\#)
+                (if (= k (- rhs-n 1))
+                  (list #\#)
+                  (let ((n (string-ref rhs (+ k 1))))
+                    (cond
+                     ((char=? n #\#) (cons #\# (aux (+ k 2))))
+                     ((and (char-numeric? n) (<= (digit->int n) (length args)))
+                      (append
+                        (string->list (list-ref args (- (digit->int n) 1)))
+                        (aux (+ k 2))))
+                     (else (cons #\# (aux (+ k 1))))))))
+               (else (cons c (aux (+ k 1))))))))))))
+
+(define do-verbescapechar
+  (lambda ()
+    (ignorespaces)
+    (let* ((c1 (get-actual-char)) (c2 (get-actual-char)))
+      (unless (char=? c1 *esc-char*)
+        (terror 'do-verbescapechar "Arg must be \\<char>"))
+      (set! *esc-char-verb* c2))))
+
+(define do-verb-braced
+  (lambda (ignore)
+    (fluid-let
+      ((*esc-char* *esc-char-verb*) (*tex-extra-letters* '()))
+      (let loop ((nesting 0))
+        (let ((c (get-actual-char)))
+          (cond
+           ((eof-object? c) (terror 'do-verb-braced "Eof inside verbatim"))
+           ((char=? c *esc-char*)
+            (toss-back-char c)
+            (let ((x (fluid-let ((*not-processing?* #t)) (get-ctl-seq))))
+              (cond
+               ((ormap (lambda (z) (string=? x z)) '("\\ " "\\{" "\\}"))
+                (emit (string-ref x 1)))
+               (else
+                (fluid-let
+                  ((*esc-char* *esc-char-std*))
+                  (do-tex-ctl-seq-completely x)))))
+            (loop nesting))
+           ((char=? c #\{) (emit #\{) (loop (+ nesting 1)))
+           ((char=? c #\})
+            (unless (= nesting 0) (emit #\}) (loop (- nesting 1))))
+           ((char=? c #\space)
+            (if *verb-visible-space?* (emit-visible-space) (emit #\space))
+            (loop nesting))
+           ((char=? c #\newline)
+            (cond
+             (*verb-display?* (emit "&nbsp;") (emit-newline))
+             (*verb-visible-space?* (emit-visible-space))
+             (else (emit-newline)))
+            (loop nesting))
+           (else (emit-html-char c) (loop nesting))))))))
+
+(define do-verb-delimed
+  (lambda (d)
+    (let loop ()
+      (let ((c (get-actual-char)))
+        (cond
+         ((eof-object? c) (terror 'do-verb-delimed "Eof inside verbatim"))
+         ((char=? c d) 'done)
+         ((char=? c #\space)
+          (if *verb-visible-space?* (emit-visible-space) (emit #\space))
+          (loop))
+         ((char=? c #\newline)
+          (cond
+           (*verb-display?* (emit "&nbsp;") (emit-newline))
+           (*verb-visible-space?* (emit-visible-space))
+           (else (emit-newline)))
+          (loop))
+         (else (emit-html-char c) (loop)))))))
+
+(define do-verb
+  (lambda ()
+    (ignorespaces)
+    (bgroup)
+    (fluid-let
+      ((*verb-visible-space?* (eat-star)) (*ligatures?* #f))
+      (let ((d (get-actual-char)))
+        (fluid-let
+          ((*verb-display?* (munched-a-newline?)))
+          (cond
+           (*outputting-external-title?* #f)
+           (*verb-display?* (do-end-para) (emit "<pre class=verbatim>"))
+           (else (emit "<code class=verbatim>")))
+          ((if (char=? d #\{) do-verb-braced do-verb-delimed) d)
+          (cond
+           (*outputting-external-title?* #f)
+           (*verb-display?* (emit "</pre>") (do-para))
+           (else (emit "</code>"))))))
+    (egroup)))
+
+(define do-verbc
+  (lambda ()
+    (ignorespaces)
+    (bgroup)
+    (fluid-let
+      ((*ligatures?* #f))
+      (emit "<code class=verbatim>")
+      (emit-html-char (get-actual-char))
+      (emit "</code>"))
+    (egroup)))
+
+(define do-verbatiminput
+  (lambda ()
+    (ignorespaces)
+    (let ((f
+           (add-dot-tex-if-no-extension-provided
+             (get-filename-possibly-braced))))
+      (cond
+       ((file-exists? f)
+        (do-end-para)
+        (bgroup)
+        (emit "<pre class=verbatim>")
+        (call-with-input-file
+          f
+          (lambda (p)
+            (let loop ()
+              (let ((c (read-char p)))
+                (unless (eof-object? c) (emit-html-char c) (loop))))))
+        (emit "</pre>")
+        (egroup)
+        (do-para))
+       (else (non-fatal-error "File " f " not found"))))))
+
+(define do-verbwritefile
+  (lambda ()
+    (let* ((f (get-filename-possibly-braced)) (e (file-extension f)))
+      (unless e (set! e ".tex") (set! f (string-append f e)))
+      (when *verb-port* (close-output-port *verb-port*))
+      (ensure-file-deleted f)
+      (set! *verb-written-files* (cons f *verb-written-files*))
+      (when (string-ci=? e ".mp") (set! *mp-files* (cons f *mp-files*)))
+      (set! *verb-port* (open-output-file f)))))
+
+(define verb-ensure-output-port
+  (lambda ()
+    (unless *verb-port*
+      (let ((output-file (string-append *jobname* ".txt")))
+        (ensure-file-deleted output-file)
+        (set! *verb-port* (open-output-file output-file))))))
+
+(define dump-groupoid
+  (lambda (p)
+    (ignorespaces)
+    (let ((write-char write-char) (d (get-actual-char)))
+      (unless p (set! write-char (lambda (x y) #f)))
+      (case d
+        ((#\{)
+         (let loop ((nesting 0))
+           (let ((c (get-actual-char)))
+             (cond
+              ((eof-object? c) (terror 'dump-groupoid "Eof inside verbatim"))
+              ((char=? c *esc-char-verb*)
+               (write-char c p)
+               (write-char (get-actual-char) p)
+               (loop nesting))
+              ((char=? c #\{) (write-char c p) (loop (+ nesting 1)))
+              ((char=? c #\})
+               (unless (= nesting 0) (write-char c p) (loop (- nesting 1))))
+              (else (write-char c p) (loop nesting))))))
+        (else
+         (let loop ()
+           (let ((c (get-actual-char)))
+             (cond
+              ((eof-object? c) (terror 'dump-groupoid "Eof inside verbatim"))
+              ((char=? c d) 'done)
+              (else (write-char c p) (loop))))))))))
+
+(define do-makehtmlimage
+  (lambda ()
+    (ignorespaces)
+    (unless (char=? (snoop-actual-char) #\{)
+      (terror 'do-makehtmlimage "\\makehtmlimage's argument must be a group"))
+    (call-with-html-image-port dump-groupoid)))
+
+(define do-verbwrite
+  (lambda () (verb-ensure-output-port) (dump-groupoid *verb-port*)))
+
+(define do-string
+  (lambda ()
+    (let ((c (snoop-actual-char)))
+      (cond
+       ((eof-object? c) #f)
+       ((char=? c *esc-char*)
+        (get-actual-char)
+        (toss-back-char *invisible-space*)
+        (toss-back-string "\\TIIPbackslash"))
+       ((char=? c *comment-char*) (eat-till-eol) (do-string))
+       (else (toss-back-char (get-actual-char)))))))
+
+(define do-verbatim-latex
+  (lambda ()
+    (do-end-para)
+    (bgroup)
+    (fluid-let
+      ((*verb-visible-space?* (eat-star)))
+      (emit "<pre class=verbatim>")
+      (munched-a-newline?)
+      (fluid-let
+        ((*ligatures?* #f))
+        (let loop ()
+          (let ((c (snoop-actual-char)))
+            (cond
+             ((eof-object? c)
+              (terror 'do-verbatim-latex "Eof inside verbatim"))
+             ((char=? c #\\)
+              (let ((end? (get-ctl-seq)))
+                (if (string=? end? "\\end")
+                  (cond
+                   ((get-grouped-environment-name-if-any)
+                    =>
+                    (lambda (e)
+                      (unless (or
+                               (and (not *verb-visible-space?*)
+                                    (string=? e "verbatim"))
+                               (and *verb-visible-space?*
+                                    (string=? e "verbatim*")))
+                        (emit-html-string end?)
+                        (emit-html-char #\{)
+                        (emit-html-string e)
+                        (emit-html-char #\})
+                        (loop))))
+                   (else (emit-html-string end?) (loop)))
+                  (begin (emit-html-string end?) (loop)))))
+             ((char=? c #\space)
+              (get-actual-char)
+              (if *verb-visible-space?*
+                (emit "<font color=red>&middot;</font>")
+                (emit #\space))
+              (loop))
+             (else (emit-html-char (get-actual-char)) (loop))))))
+      (emit "</pre>"))
+    (egroup)
+    (do-para)))
+
+(define do-alltt
+  (lambda ()
+    (do-end-para)
+    (bgroup)
+    (emit "<pre class=verbatim>")
+    (munched-a-newline?)
+    (fluid-let
+      ((*in-alltt?* #t))
+      (let loop ()
+        (let ((c (snoop-actual-char)))
+          (if (eof-object? c)
+            (terror 'do-alltt "Eof inside alltt")
+            (begin
+              (case c
+                ((#\\) (do-tex-ctl-seq (get-ctl-seq)))
+                ((#\{) (get-actual-char) (bgroup))
+                ((#\}) (get-actual-char) (egroup))
+                (else (emit-html-char (get-actual-char))))
+              (if *in-alltt?* (loop)))))))))
+
+(define do-end-alltt
+  (lambda () (emit "</pre>") (egroup) (do-para) (set! *in-alltt?* #f)))
+
+(define *scm-special-symbols* (make-table 'equ string=?))
+
+(define do-scm-set-specialsymbol
+  (lambda ()
+    (let* ((sym (get-peeled-group)) (xln (get-group)))
+      (hash-table-put! *scm-special-symbols* sym xln))))
+
+(define do-scm-unset-specialsymbol
+  (lambda ()
+    (call-with-input-string/buffered
+      (ungroup (get-group))
+      (lambda ()
+        (let loop ()
+          (ignore-all-whitespace)
+          (unless (eof-object? (snoop-actual-char))
+            (hash-table-put! *scm-special-symbols* (scm-get-token) #f)
+            (loop)))))))
+
+(define do-scm-set-builtins
+  (lambda ()
+    (call-with-input-string/buffered
+      (ungroup (get-group))
+      (lambda ()
+        (let loop ()
+          (ignore-all-whitespace)
+          (let ((c (snoop-actual-char)))
+            (unless (eof-object? c)
+              (let ((s (scm-get-token)))
+                (set! *scm-keywords* (ldelete s *scm-keywords* string=?))
+                (set! *scm-variables* (ldelete s *scm-variables* string=?))
+                (set! *scm-builtins* (cons s *scm-builtins*)))
+              (loop))))))))
+
+(define do-scm-set-keywords
+  (lambda ()
+    (call-with-input-string/buffered
+      (ungroup (get-group))
+      (lambda ()
+        (let loop ()
+          (ignore-all-whitespace)
+          (let ((c (snoop-actual-char)))
+            (unless (eof-object? c)
+              (let ((s (scm-get-token)))
+                (set! *scm-builtins* (ldelete s *scm-builtins* string=?))
+                (set! *scm-variables* (ldelete s *scm-variables* string=?))
+                (set! *scm-keywords* (cons s *scm-keywords*)))
+              (loop))))))))
+
+(define do-scm-set-variables
+  (lambda ()
+    (call-with-input-string/buffered
+      (ungroup (get-group))
+      (lambda ()
+        (let loop ()
+          (ignore-all-whitespace)
+          (let ((c (snoop-actual-char)))
+            (unless (eof-object? c)
+              (let ((s (scm-get-token)))
+                (set! *scm-builtins* (ldelete s *scm-builtins* string=?))
+                (set! *scm-keywords* (ldelete s *scm-keywords* string=?))
+                (set! *scm-variables* (cons s *scm-variables*)))
+              (loop))))))))
+
+(define scm-emit-html-char
+  (lambda (c)
+    (unless (eof-object? c)
+      (when *scm-dribbling?* (write-char c *verb-port*))
+      (emit-html-char c))))
+
+(define scm-output-next-chunk
+  (lambda ()
+    (let ((c (snoop-actual-char)))
+      (cond
+       ((and *slatex-math-escape* (char=? c *slatex-math-escape*))
+        (scm-escape-into-math))
+       ((char=? c #\;) (scm-output-comment) (do-end-para))
+       ((char=? c #\") (scm-output-string))
+       ((char=? c #\#) (scm-output-hash))
+       ((char=? c #\,)
+        (get-actual-char)
+        (emit "<span class=keyword>")
+        (scm-emit-html-char c)
+        (let ((c (snoop-actual-char)))
+          (when (char=? c #\@) (get-actual-char) (scm-emit-html-char c)))
+        (emit "</span>"))
+       ((or (char=? c #\') (char=? c #\`))
+        (get-actual-char)
+        (emit "<span class=keyword>")
+        (scm-emit-html-char c)
+        (emit "</span>"))
+       ((or (char-whitespace? c) (memv c *scm-token-delims*))
+        (get-actual-char)
+        (scm-emit-html-char c))
+       (else (scm-output-token (scm-get-token)))))))
+
+(define scm-set-mathescape
+  (lambda (yes?)
+    (let ((c
+           (fluid-let
+             ((*esc-char* (integer->char 0)))
+             (string-ref (ungroup (get-group)) 0))))
+      (cond
+       (yes?
+        (set! *slatex-math-escape* c)
+        (set! *scm-token-delims*
+          (cons *slatex-math-escape* *scm-token-delims*)))
+       (else
+        (set! *slatex-math-escape* #f)
+        (set! *scm-token-delims* (ldelete c *scm-token-delims* char=?)))))))
+
+(define scm-escape-into-math
+  (lambda ()
+    (get-actual-char)
+    (let ((math-text (get-till-char *slatex-math-escape*)))
+      (get-actual-char)
+      (emit "<span class=variable>")
+      (fluid-let
+        ((*esc-char* *esc-char-std*))
+        (tex2page-string (string-append "$" math-text "$")))
+      (emit "</span>"))))
+
+(define scm-output-slatex-comment
+  (lambda ()
+    (let ((s (get-line)))
+      (emit "<span class=comment>")
+      (when *scm-dribbling?* (display s *verb-port*) (newline *verb-port*))
+      (fluid-let ((*esc-char* *esc-char-std*)) (tex2page-string s))
+      (do-end-para)
+      (emit "</span>")
+      (toss-back-char #\newline))))
+
+(define scm-output-verbatim-comment
+  (lambda ()
+    (emit "<span class=comment>")
+    (let loop ()
+      (let ((c (get-actual-char)))
+        (cond
+         ((or (eof-object? c) (char=? c #\newline))
+          (emit "</span>")
+          (scm-emit-html-char c))
+         ((and (char-whitespace? c)
+               (let ((c2 (snoop-actual-char)))
+                 (or (eof-object? c2) (char=? c2 #\newline))))
+          (emit "</span>")
+          (scm-emit-html-char (get-actual-char)))
+         (else (scm-emit-html-char c) (loop)))))))
+
+(define scm-output-comment
+  (lambda ()
+    ((if *slatex-like-comments?*
+       scm-output-slatex-comment
+       scm-output-verbatim-comment))))
+
+(define scm-output-extended-comment
+  (lambda ()
+    (get-actual-char)
+    (emit "<span class=comment>")
+    (scm-emit-html-char #\#)
+    (scm-emit-html-char #\|)
+    (let loop ()
+      (let ((c (get-actual-char)))
+        (cond
+         ((eof-object? c) #t)
+         ((char=? c #\|)
+          (let ((c2 (snoop-actual-char)))
+            (cond
+             ((eof-object? c2) (scm-emit-html-char c))
+             ((char=? c2 #\#) (get-actual-char))
+             (else (scm-emit-html-char c) (loop)))))
+         (else (scm-emit-html-char c) (loop)))))
+    (scm-emit-html-char #\|)
+    (scm-emit-html-char #\#)
+    (emit "</span>")))
+
+(define scm-output-string
+  (lambda ()
+    (get-actual-char)
+    (emit "<span class=selfeval>")
+    (scm-emit-html-char #\")
+    (let loop ((esc? #f))
+      (let ((c (get-actual-char)))
+        (case c
+          ((#\") (when esc? (scm-emit-html-char c) (loop #f)))
+          ((#\\) (scm-emit-html-char c) (loop (not esc?)))
+          (else (scm-emit-html-char c) (loop #f)))))
+    (scm-emit-html-char #\")
+    (emit "</span>")))
+
+(define scm-output-hash
+  (lambda ()
+    (get-actual-char)
+    (let ((c (snoop-actual-char)))
+      (cond
+       ((eof-object? c)
+        (emit "<span class=selfeval>")
+        (scm-emit-html-char #\#)
+        (emit "</span>"))
+       ((char=? c #\|) (scm-output-extended-comment))
+       (else (toss-back-char #\#) (scm-output-token (scm-get-token)))))))
+
+(define scm-output-token
+  (lambda (s)
+    (case (scm-get-type s)
+      ((special-symbol)
+       (fluid-let
+         ((*esc-char* *esc-char-std*))
+         (tex2page-string (table-get *scm-special-symbols* s))))
+      ((keyword)
+       (emit "<span class=keyword>")
+       (scm-display-token s)
+       (emit "</span>"))
+      ((global)
+       (emit "<span class=global>")
+       (scm-display-token s)
+       (emit "</span>"))
+      ((selfeval)
+       (emit "<span class=selfeval>")
+       (scm-display-token s)
+       (emit "</span>"))
+      ((builtin)
+       (emit "<span class=builtin>")
+       (scm-display-token s)
+       (emit "</span>"))
+      ((background) (scm-display-token s))
+      (else
+       (emit "<span class=variable>")
+       (scm-display-token s)
+       (emit "</span>")))))
+
+(define scm-display-token
+  (lambda (s)
+    (let ((n (string-length s)))
+      (let loop ((k 0))
+        (when (< k n) (scm-emit-html-char (string-ref s k)) (loop (+ k 1)))))))
+
+(define do-scm-braced
+  (lambda (result?)
+    (get-actual-char)
+    (let ((display? (munched-a-newline?)))
+      (cond
+       ((not display?)
+        (emit "<code class=scheme")
+        (when result? (emit "response"))
+        (emit ">"))
+       (else (do-end-para) (emit "<pre class=scheme>")))
+      (bgroup)
+      (fluid-let
+        ((*esc-char* *esc-char-verb*) (*verb-display?* display?))
+        (let loop ((nesting 0))
+          (let ((c (snoop-actual-char)))
+            (cond
+             ((eof-object? c) (terror 'do-scm-braced "Eof inside verbatim"))
+             ((char=? c *esc-char*)
+              (let ((x (fluid-let ((*not-processing?* #t)) (get-ctl-seq))))
+                (cond
+                 ((ormap (lambda (z) (string=? x z)) '("\\ " "\\{" "\\}"))
+                  (scm-emit-html-char (string-ref x 1)))
+                 (else
+                  (fluid-let
+                    ((*esc-char* *esc-char-std*))
+                    (do-tex-ctl-seq-completely x)))))
+              (loop nesting))
+             ((char=? c #\{)
+              (get-actual-char)
+              (scm-emit-html-char c)
+              (loop (+ nesting 1)))
+             ((char=? c #\})
+              (get-actual-char)
+              (unless (= nesting 0)
+                (scm-emit-html-char c)
+                (loop (- nesting 1))))
+             (else (scm-output-next-chunk) (loop nesting))))))
+      (egroup)
+      (if (not display?) (emit "</code>") (begin (emit "</pre>") (do-para))))))
+
+(define do-scm-delimed
+  (lambda (result?)
+    (let ((d (get-actual-char)))
+      (let ((display? (munched-a-newline?)))
+        (cond
+         ((not display?)
+          (emit "<code class=scheme")
+          (when result? (emit "response"))
+          (emit ">"))
+         (else (do-end-para) (emit "<pre class=scheme>")))
+        (fluid-let
+          ((*verb-display?* display?)
+           (*scm-token-delims* (cons d *scm-token-delims*)))
+          (let loop ()
+            (let ((c (snoop-actual-char)))
+              (cond
+               ((eof-object? c) (terror 'do-scm-delimed "Eof inside verbatim"))
+               ((char=? c d) (get-actual-char))
+               (else (scm-output-next-chunk) (loop))))))
+        (if (not display?)
+          (emit "</code>")
+          (begin (emit "</pre>") (do-para)))))))
+
+(define do-scm
+  (lambda (result?)
+    (cond
+     (*outputting-external-title?* (do-verb))
+     (else
+      (ignorespaces)
+      (bgroup)
+      (fluid-let
+        ((*ligatures?* #f))
+        ((if (char=? (snoop-actual-char) #\{) do-scm-braced do-scm-delimed)
+         result?))
+      (egroup)))))
+
+(define do-scminput
+  (lambda ()
+    (ignorespaces)
+    (do-end-para)
+    (bgroup)
+    (emit "<pre class=scheme>")
+    (let ((f
+           (add-dot-tex-if-no-extension-provided
+             (get-filename-possibly-braced))))
+      (call-with-input-file/buffered
+        f
+        (lambda ()
+          (let loop ()
+            (let ((c (snoop-actual-char)))
+              (unless (eof-object? c) (scm-output-next-chunk) (loop)))))))
+    (emit "</pre>")
+    (egroup)
+    (do-para)))
+
+(define do-scmdribble
+  (lambda ()
+    (verb-ensure-output-port)
+    (fluid-let ((*scm-dribbling?* #t)) (do-scm #f))
+    (newline *verb-port*)))
+
+(define do-scm-slatex-lines
+  (lambda (env display? result?)
+    (let ((endenv (string-append "\\end" env))
+          (in-table?
+            (and (not (null? *tabular-stack*))
+                 (memv (car *tabular-stack*) '(block figure table)))))
+      (cond (display? (do-end-para)) (in-table? (emit "</td><td>")))
+      (munched-a-newline?)
+      (bgroup)
+      (emit "<div align=left><pre class=scheme")
+      (when result? (emit "response"))
+      (emit ">")
+      (fluid-let
+        ((*ligatures?* #f) (*verb-display?* #t) (*not-processing?* #t))
+        (let loop ()
+          (let ((c (snoop-actual-char)))
+            (cond
+             ((eof-object? c) (terror 'do-scm-slatex-lines "Eof inside " env))
+             ((char=? c #\newline)
+              (get-actual-char)
+              (scm-emit-html-char c)
+              (cond
+               ((not *slatex-like-comments?*) #f)
+               ((char=? (snoop-actual-char) #\;)
+                (get-actual-char)
+                (if (char=? (snoop-actual-char) #\;)
+                  (toss-back-char #\;)
+                  (scm-output-slatex-comment))))
+              (loop))
+             ((char=? c *esc-char*)
+              (let ((x (get-ctl-seq)))
+                (cond
+                 ((string=? x endenv) #t)
+                 ((string=? x "\\end")
+                  (let ((g (get-grouped-environment-name-if-any)))
+                    (if (and g (string=? g env))
+                      (egroup)
+                      (begin
+                        (scm-output-token x)
+                        (when g
+                          (scm-output-token "{")
+                          (scm-output-token g)
+                          (scm-output-token "}"))
+                        (loop)))))
+                 (else (scm-output-token x) (loop)))))
+             (else (scm-output-next-chunk) (loop))))))
+      (emit "</pre></div>")
+      (egroup)
+      (cond (display? (do-para)) (in-table? (emit "</td><td>"))))))
+
+(define string-is-all-dots?
+  (lambda (s)
+    (let ((n (string-length s)))
+      (let loop ((i 0))
+        (cond
+         ((>= i n) #t)
+         ((char=? (string-ref s i) #\.) (loop (+ i 1)))
+         (else #f))))))
+
+(define string-is-flanked-by-stars?
+  (lambda (s)
+    (let ((n (string-length s)))
+      (and (>= n 3)
+           (char=? (string-ref s 0) #\*)
+           (char=? (string-ref s (- n 1)) #\*)))))
+
+(define string-starts-with-hash? (lambda (s) (char=? (string-ref s 0) #\#)))
+
+(define scm-get-type
+  (lambda (s)
+    (cond
+     ((table-get *scm-special-symbols* s) 'special-symbol)
+     ((member/string-ci=? s *scm-keywords*) 'keyword)
+     ((member/string-ci=? s *scm-builtins*) 'builtin)
+     ((member/string-ci=? s *scm-variables*) 'variable)
+     ((string-is-flanked-by-stars? s) 'global)
+     (else
+      (let ((colon (string-index s #\:)))
+        (cond
+         (colon (if (= colon 0) 'selfeval 'variable))
+         ((string-is-all-dots? s) 'background)
+         ((string-starts-with-hash? s) 'selfeval)
+         ((string->number s) 'selfeval)
+         (else 'variable)))))))
+
+(define eat-star
+  (lambda ()
+    (let ((c (snoop-actual-char)))
+      (if (and (not (eof-object? c)) (char=? c #\*)) (get-actual-char) #f))))
+
+(define do-cr
+  (lambda (z)
+    (ignorespaces)
+    (let ((top-tabular
+            (if (not (null? *tabular-stack*)) (car *tabular-stack*) 'nothing)))
+      (case top-tabular
+        ((tabular)
+         (get-bracketed-text-if-any)
+         (egroup)
+         (emit "</td></tr>")
+         (emit-newline)
+         (emit "<tr><td valign=top ")
+         (do-tabular-multicolumn))
+        ((eqnarray*)
+         (emit "</td></tr>")
+         (emit-newline)
+         (set! *equation-position* 0)
+         (emit "<tr><td align=right>"))
+        ((eqnarray)
+         (emit "</td>")
+         (cond
+          (*equation-numbered?*
+           (emit "<td>(")
+           (emit *equation-number*)
+           (bump-dotted-counter "equation")
+           (emit ")</td>"))
+          (else (set! *equation-numbered?* #t)))
+         (emit "</tr>")
+         (emit-newline)
+         (set! *equation-position* 0)
+         (emit "<tr><td align=right>"))
+        ((ruled-table) (emit "</td></tr>") (emit-newline) (emit "<tr><td>"))
+        ((minipage tabbing)
+         (get-bracketed-text-if-any)
+         (emit "<br>")
+         (emit-newline))
+        ((eqalign eqalignno displaylines pmatrix)
+         (unless (char=? (snoop-actual-char) #\})
+           (emit "</td></tr>")
+           (emit-newline)
+           (emit "<tr><td>")
+           (set! *equation-position* 0)
+           (emit-newline)))
+        ((header) (emit #\space))
+        (else
+         (when (and (eqv? *tex-format* 'latex) (string=? z "\\\\"))
+           (get-bracketed-text-if-any)
+           (let ((c (snoop-actual-char)))
+             (when (and (not (eof-object? c)) (char=? c #\*))
+               (get-actual-char)))
+           (emit "<br>")
+           (emit-newline)))))))
+
+(define do-ruledtable
+  (lambda ()
+    (set! *tabular-stack* (cons 'ruled-table *tabular-stack*))
+    (emit "<table border=2><tr><td>")
+    (emit-newline)))
+
+(define do-endruledtable
+  (lambda ()
+    (emit-newline)
+    (emit "</td></tr></table>")
+    (emit-newline)
+    (pop-tabular-stack 'ruled-table)))
+
+(define do-tabular
+  (lambda ()
+    (do-end-para)
+    (get-bracketed-text-if-any)
+    (bgroup)
+    (add-postlude-to-top-frame
+      (let ((old-math-mode? *math-mode?*)
+            (old-in-display-math? *in-display-math?*))
+        (set! *math-mode?* #f)
+        (set! *in-display-math?* #f)
+        (lambda ()
+          (set! *math-mode?* old-math-mode?)
+          (set! *in-display-math?* old-in-display-math?))))
+    (let ((border-width (if (string-index (get-group) #\|) 1 0)))
+      (set! *tabular-stack* (cons 'tabular *tabular-stack*))
+      (emit "<table border=")
+      (emit border-width)
+      (emit "><tr><td valign=top ")
+      (do-tabular-multicolumn))))
+
+(define do-end-tabular
+  (lambda ()
+    (egroup)
+    (do-end-para)
+    (emit "</td></tr></table>")
+    (pop-tabular-stack 'tabular)
+    (egroup)))
+
+(define do-tabular-colsep
+  (lambda () (egroup) (emit "</td><td valign=top ") (do-tabular-multicolumn)))
+
+(define do-tabular-multicolumn
+  (lambda ()
+    (let loop ()
+      (ignorespaces)
+      (let ((c (snoop-actual-char)))
+        (when (and (char? c) (char=? c #\\))
+          (let ((x (get-ctl-seq)))
+            (cond
+             ((string=? x "\\hline") (loop))
+             ((string=? x "\\multicolumn")
+              (let ((n (ungroup (get-token))))
+                (get-token)
+                (emit " colspan=")
+                (emit n)))
+             (else
+              (toss-back-char *invisible-space*)
+              (toss-back-string x)))))))
+    (emit ">")
+    (bgroup)))
+
+(define do-ruledtable-colsep
+  (lambda ()
+    (emit-newline)
+    (emit "</td><td")
+    (ignorespaces)
+    (let ((c (snoop-actual-char)))
+      (if (char=? c #\\)
+        (let ((x (get-ctl-seq)))
+          (if (string=? x "\\multispan")
+            (let ((n (ungroup (get-token)))) (emit " colspan=") (emit n))
+            (toss-back-string x)))))
+    (emit ">")
+    (emit-newline)))
+
+(define do-tex-logo (lambda () (emit "T<small>E</small>X")))
+
+(define do-latex-logo (lambda () (emit "L<small>A</small>") (do-tex-logo)))
+
+(define do-latex2e-logo (lambda () (do-latex-logo) (emit "2<small>E</small>")))
+
+(define do-romannumeral
+  (lambda (upcase?) (emit (number->roman (get-integer 10) upcase?))))
+
+(define set-latex-counter
+  (lambda (add?)
+    (let* ((counter-name (get-peeled-group))
+           (new-value (string->number (get-token-or-peeled-group))))
+      (cond
+       ((table-get *dotted-counters* counter-name)
+        =>
+        (lambda (counter)
+          (set!counter.value
+            counter
+            (if add? (+ new-value (counter.value counter)) new-value))))
+       (else
+        (let ((count-seq (string-append "\\" counter-name)))
+          (cond
+           ((section-ctl-seq? count-seq)
+            =>
+            (lambda (n)
+              (hash-table-put!
+                *section-counters*
+                n
+                (if add?
+                  (+ new-value (table-get *section-counters* n 0))
+                  new-value))))
+           ((find-count count-seq)
+            (set-gcount!
+              count-seq
+              (if add? (+ new-value (get-gcount count-seq)) new-value)))
+           (else #f))))))))
+
+(define do-tex-prim
+  (lambda (z)
+    (cond
+     ((find-def z)
+      =>
+      (lambda (y)
+        (cond
+         ((tdef.defer y) => toss-back-string)
+         ((tdef.thunk y) => (lambda (th) (th)))
+         (else
+          (expand-tex-macro
+            (tdef.optarg y)
+            (tdef.argpat y)
+            (tdef.expansion y))))))
+     ((section-ctl-seq? z) => (lambda (n) (do-heading n)))
+     (*math-mode?* (do-math-ctl-seq z))
+     (else (trace-if *tracingcommands?* "Ignoring " z)))))
+
+(define do-char (lambda () (emit-html-char (get-tex-char-spec))))
+
+(define do-tex-char
+  (lambda (c)
+    (cond
+     ((and *comment-char* (char=? c *comment-char*)) (do-comment))
+     ((or (memv #f *tex-if-stack*) (memv '? *tex-if-stack*)) #t)
+     ((char=? c #\{) (bgroup))
+     ((char=? c #\}) (egroup))
+     ((char=? c #\$) (do-math))
+     ((char=? c #\-) (do-hyphen))
+     ((char=? c #\`) (do-lsquo))
+     ((char=? c #\') (do-rsquo))
+     ((char=? c #\~) (emit-nbsp 1))
+     ((char=? c #\!) (do-excl))
+     ((char=? c #\?) (do-quest))
+     ((or (char=? c #\<) (char=? c #\>) (char=? c #\")) (emit-html-char c))
+     ((char=? c #\&)
+      (cond
+       ((not (null? *tabular-stack*))
+        (do-end-para)
+        (case (car *tabular-stack*)
+          ((pmatrix eqalign displaylines) (emit "</td><td>"))
+          ((eqalignno)
+           (set! *equation-position* (+ *equation-position* 1))
+           (emit "</td><td")
+           (when (= *equation-position* 2) (emit " width=30% align=right"))
+           (emit ">"))
+          ((eqnarray eqnarray*)
+           (set! *equation-position* (+ *equation-position* 1))
+           (emit "</td><td")
+           (when (= *equation-position* 1) (emit " align=center width=2%"))
+           (emit ">"))
+          ((tabular) (do-tabular-colsep))
+          ((ruled-table) (do-ruledtable-colsep))))
+       (else (emit-html-char c))))
+     ((char=? c #\|)
+      (if (and (not (null? *tabular-stack*))
+               (eqv? (car *tabular-stack*) 'ruled-table))
+        (do-ruledtable-colsep)
+        (emit c)))
+     ((char=? c #\newline) (do-newline))
+     ((char=? c #\space) (do-space))
+     ((char=? c *tab*) (do-tab))
+     (else
+      (cond
+       (*math-mode?*
+        (case c
+          ((#\^) (do-sup))
+          ((#\_) (do-sub))
+          ((#\+ #\=)
+           (unless *math-script-mode?* (emit #\space))
+           (emit c)
+           (unless *math-script-mode?* (emit #\space)))
+          (else
+           (if (and (char-alphabetic? c) (not *math-roman-mode?*))
+             (begin (emit "<em>") (emit c) (emit "</em>"))
+             (emit c)))))
+       ((and *in-small-caps?* (char-lower-case? c))
+        (emit "<small>")
+        (emit (char-upcase c))
+        (emit "</small>"))
+       (else (emit c)))))))
+
+(define do-tex-ctl-seq-completely
+  (lambda (x)
+    (cond
+     ((resolve-defs x) => tex2page-string)
+     ((do-tex-prim (find-corresp-prim x))
+      =>
+      (lambda (y) (if (eqv? y ':encountered-undefined-command) (emit x)))))))
+
+(define inside-false-world?
+  (lambda () (or (memv #f *tex-if-stack*) (memv '? *tex-if-stack*))))
+
+(define do-tex-ctl-seq
+  (lambda (z)
+    (trace-if *tracingcommands?* z)
+    (cond
+     ((resolve-defs z)
+      =>
+      (lambda (s)
+        (trace-if *tracingmacros?* "    --> " s)
+        (toss-back-char *invisible-space*)
+        (toss-back-string s)))
+     ((and (inside-false-world?) (not (if-aware-ctl-seq? z))) #f)
+     ((string=? z "\\enddocument") (probably-latex) ':encountered-bye)
+     ((string=? z "\\bye") ':encountered-bye)
+     ((string=? z "\\endinput")
+      (let ((next-token (get-token)))
+        (when (and (not (eof-object? next-token)) (string=? next-token "\\fi"))
+          (do-fi)))
+      ':encountered-endinput)
+     ((find-count z) (do-count= z #f))
+     ((find-toks z) (do-toks= z #f))
+     ((find-dimen z) (do-dimen= z #f))
+     (else (do-tex-prim z)))))
+
+(define generate-html
+  (lambda ()
+    (let loop ()
+      (let ((c (snoop-actual-char)))
+        (cond
+         ((eof-object? c) #t)
+         ((resolve-chardefs c)
+          =>
+          (lambda (s)
+            (toss-back-char *invisible-space*)
+            (toss-back-string s)
+            (loop)))
+         ((char=? c *esc-char*)
+          (let ((r (do-tex-ctl-seq (get-ctl-seq))))
+            (case r
+              ((:encountered-endinput) #t)
+              ((:encountered-bye) ':encountered-bye)
+              (else (loop)))))
+         (else (get-actual-char) (do-tex-char c) (loop)))))))
+
+(define do-iffileexists
+  (lambda ()
+    (let* ((file (actual-tex-filename (get-filename-possibly-braced) #f))
+           (thene (ungroup (get-group)))
+           (elsee (ungroup (get-group))))
+      (tex2page-string (if file thene elsee)))))
+
+(define check-input-file-timestamp?
+  (lambda (f)
+    (cond
+     ((let ((e (file-extension f)))
+        (and e (member/string-ci=? e '(".t2p" ".bbl" ".ind"))))
+      #f)
+     (*inputting-boilerplate?* #f)
+     (*ignore-timestamp?* #f)
+     ((> *html-only* 0) #f)
+     ((and (>= (string-length f) 3)
+           (char=? (string-ref f 0) #\.)
+           (char=? (string-ref f 1) #\/))
+      #f)
+     ((member f *verb-written-files*) #f)
+     (else #t))))
+
+(define do-inputiffileexists
+  (lambda ()
+    (let* ((f (actual-tex-filename (get-filename-possibly-braced) #f))
+           (then-txt (ungroup (get-group)))
+           (else-txt (ungroup (get-group))))
+      (cond
+       (f (tex2page-string then-txt) (tex2page-file f))
+       (else (tex2page-string else-txt))))))
+
+(define tex2page-file
+  (lambda (f)
+    (write-log #\()
+    (write-log f)
+    (write-log 'separation-space)
+    (set! f (tex2page-massage-file f))
+    (trace-if *tracingcommands?* "Inputting file " f)
+    (let ((r (call-with-input-file/buffered f generate-html)))
+      (write-log #\))
+      (write-log 'separation-space)
+      r)))
+
+(define do-input
+  (lambda ()
+    (ignorespaces)
+    (let ((f (get-filename-possibly-braced)))
+      (let ((boilerplate-index *inputting-boilerplate?*))
+        (when (eqv? *inputting-boilerplate?* 0)
+          (set! *inputting-boilerplate?* #f))
+        (fluid-let
+          ((*inputting-boilerplate?*
+             (and boilerplate-index (+ boilerplate-index 1))))
+          (cond
+           ((or (latex-style-file? f)
+                (member/string-ci=?
+                  f
+                  '("btxmac"
+                    "btxmac.tex"
+                    "eplain"
+                    "eplain.tex"
+                    "epsf"
+                    "epsf.tex"
+                    "supp-pdf"
+                    "supp-pdf.tex")))
+            #f)
+           ((ormap (lambda (z) (string=? f z)) '("texinfo" "texinfo.tex"))
+            (let ((txi2p (actual-tex-filename "texi2p" #f)))
+              (if txi2p
+                (begin
+                  (tex2page-file txi2p)
+                  (tex2page-file *current-source-file*)
+                  ':encountered-endinput)
+                (terror 'do-input "File texi2p.tex not found"))))
+           ((actual-tex-filename f (check-input-file-timestamp? f))
+            =>
+            tex2page-file)
+           (else
+            (write-log #\()
+            (write-log f)
+            (write-log 'separation-space)
+            (write-log "not found)")
+            (write-log 'separation-space))))))))
+
+(define do-includeonly
+  (lambda ()
+    (ignorespaces)
+    (when (eq? *includeonly-list* #t) (set! *includeonly-list* '()))
+    (let ((c (get-actual-char)))
+      (when (or (eof-object? c) (not (char=? c #\{)))
+        (terror 'do-includeonly)))
+    (fluid-let
+      ((*filename-delims* (cons #\} (cons #\, *filename-delims*))))
+      (let loop ()
+        (ignorespaces)
+        (let ((c (snoop-actual-char)))
+          (cond
+           ((eof-object? c) (terror 'do-includeonly))
+           ((and *comment-char* (char=? c *comment-char*))
+            (eat-till-eol)
+            (ignorespaces)
+            (loop))
+           ((char=? c #\,) (get-actual-char) (loop))
+           ((char=? c #\}) (get-actual-char))
+           ((ormap (lambda (d) (char=? c d)) *filename-delims*)
+            (terror 'do-includeonly))
+           (else
+            (set! *includeonly-list*
+              (cons (get-plain-filename) *includeonly-list*))
+            (loop))))))))
+
+(define do-include
+  (lambda ()
+    (let ((f (ungroup (get-group))))
+      (when (or
+             (eq? *includeonly-list* #t)
+             (ormap (lambda (i) (string=? f i)) *includeonly-list*))
+        (fluid-let
+          ((*subjobname* (file-stem-name f))
+           (*img-file-count* 0)
+           (*imgdef-file-count* 0))
+          (tex2page-file
+            (actual-tex-filename f (check-input-file-timestamp? f))))))))
+
+(define do-eval-string
+  (lambda (s)
+    (call-with-input-string
+      s
+      (lambda (i)
+        (let loop ()
+          (let ((x (read i))) (unless (eof-object? x) (eval x) (loop))))))))
+
+(define with-output-to-port
+  (lambda (o th) (parameterize ((current-output-port o)) (th))))
+
+(define do-eval
+  (lambda (fmts)
+    (let ((s
+           (ungroup
+             (fluid-let
+               ((*esc-char* *esc-char-verb*) (*expand-escape?* #t))
+               (get-group)))))
+      (unless (inside-false-world?)
+        (when (> *html-only* 0) (set! fmts 'html))
+        (case fmts
+          ((html)
+           (let ((o (open-output-string)))
+             (with-output-to-port o (lambda () (do-eval-string s)))
+             (tex2page-string (get-output-string o))))
+          ((quiet) (do-eval-string s))
+          (else
+           (set! *eval-file-count* (+ *eval-file-count* 1))
+           (let ((eval4tex-file
+                   (string-append
+                     *jobname*
+                     *eval-file-suffix*
+                     (number->string *eval-file-count*)
+                     ".tex")))
+             (ensure-file-deleted eval4tex-file)
+             (with-output-to-file
+               eval4tex-file
+               (lambda () (do-eval-string s) (display "\\relax")))
+             (fluid-let
+               ((*ignore-timestamp?* #t))
+               (tex2page-file eval4tex-file)))))))))
+
+(define eval-for-tex-only
+  (lambda ()
+    (set! *eval-for-tex-only?* #t)
+    (do-end-page)
+    (ensure-file-deleted *html-page*)
+    (set! *main-tex-file* #f)
+    (set! *html-page* ".eval4texignore")
+    (ensure-file-deleted *html-page*)
+    (set! *html* (open-output-file *html-page*))))
+
+(define expand-ctl-seq-into-string
+  (lambda (cs)
+    (let ((tmp-port (open-output-string)))
+      (fluid-let ((*html* tmp-port)) (do-tex-ctl-seq cs))
+      (get-output-string tmp-port))))
+
+(define tex-string->html-string
+  (lambda (ts)
+    (let ((tmp-port (open-output-string)))
+      (fluid-let ((*html* tmp-port)) (tex2page-string ts))
+      (get-output-string tmp-port))))
+
+(define call-with-html-output-going-to
+  (lambda (p th) (fluid-let ((*html* p)) (th))))
+
+(define call-external-programs-if-necessary
+  (lambda ()
+    (let ((run-bibtex?
+            (cond
+             ((not *using-bibliography?*) #f)
+             ((not
+               (file-exists?
+                 (string-append
+                   *aux-dir/*
+                   *jobname*
+                   *bib-aux-file-suffix*
+                   ".aux")))
+              #f)
+             ((memv 'bibliography *missing-pieces*) #t)
+             (*source-changed-since-last-run?*
+              (flag-missing-piece 'fresh-bibliography)
+              #t)
+             (else #f)))
+          (run-makeindex?
+            (cond
+             ((not *using-index?*) #f)
+             ((not
+               (file-exists?
+                 (string-append
+                   *aux-dir/*
+                   *jobname*
+                   *index-file-suffix*
+                   ".idx")))
+              #f)
+             ((memv 'index *missing-pieces*) #t)
+             (*source-changed-since-last-run?*
+              (flag-missing-piece 'fresh-index)
+              #t)
+             (else #f))))
+      (when run-bibtex?
+        (write-log 'separation-newline)
+        (write-log "Running: bibtex ")
+        (write-log *aux-dir/*)
+        (write-log *jobname*)
+        (write-log *bib-aux-file-suffix*)
+        (write-log #\space)
+        (system
+          (string-append "bibtex " *aux-dir/* *jobname* *bib-aux-file-suffix*))
+        (unless (file-exists?
+                 (string-append *jobname* *bib-aux-file-suffix* ".bbl"))
+          (write-log " ... failed; try manually"))
+        (write-log 'separation-newline))
+      (when run-makeindex?
+        (write-log 'separation-newline)
+        (write-log "Running: makeindex ")
+        (write-log *aux-dir/*)
+        (write-log *jobname*)
+        (write-log *index-file-suffix*)
+        (write-log #\space)
+        (system
+          (string-append
+            "makeindex "
+            *aux-dir/*
+            *jobname*
+            *index-file-suffix*))
+        (unless (file-exists?
+                 (string-append
+                   *aux-dir/*
+                   *jobname*
+                   *index-file-suffix*
+                   ".ind"))
+          (write-log " ... failed; try manually"))
+        (write-log 'separation-newline))
+      (for-each
+        (lambda (f)
+          (when (file-exists? f)
+            (write-log 'separation-newline)
+            (write-log "Running: metapost ")
+            (write-log f)
+            (write-log 'separation-newline)
+            (system (string-append *metapost* " " f))))
+        *mp-files*)
+      (for-each
+        (lambda (eps-file+img-file-stem)
+          (retry-lazy-image
+            (car eps-file+img-file-stem)
+            (cdr eps-file+img-file-stem)))
+        *missing-eps-files*))))
+
+(define first-file-that-exists
+  (lambda ff (ormap (lambda (f) (and f (file-exists? f) f)) ff)))
+
+(define file-in-home
+  (lambda (f)
+    (let ((home (getenv "HOME")))
+      (and home
+           (let ((slash-already?
+                   (let ((n (string-length home)))
+                     (and (>= n 0)
+                          (let ((c (string-ref home (- n 1))))
+                            (or (char=? c #\/) (char=? c #\\)))))))
+             (string-append home (if slash-already? "" "/") f))))))
+
+(define make-target-dir
+  (lambda ()
+    (let ((hdir-file
+            (first-file-that-exists
+              (string-append *jobname* ".hdir")
+              ".tex2page.hdir"
+              (file-in-home ".tex2page.hdir"))))
+      (when hdir-file
+        (let ((hdir
+               (call-with-input-file/buffered
+                 hdir-file
+                 (lambda () (get-filename-possibly-braced)))))
+          (unless (= (string-length hdir) 0)
+            (case *operating-system*
+              ((unix)
+               (system (string-append "mkdir -p " hdir))
+               (system (string-append "touch " hdir "/probe")))
+              ((windows)
+               (system (string-append "mkdir " hdir))
+               (system (string-append "echo probe > " hdir "\\probe"))))
+            (let ((probe (string-append hdir "/probe")))
+              (when (file-exists? probe)
+                (ensure-file-deleted probe)
+                (set! *aux-dir* hdir)
+                (set! *aux-dir/* (string-append *aux-dir* "/"))))))))))
+
+(define move-aux-files-to-aux-dir
+  (lambda (f)
+    (when (and
+           *aux-dir*
+           (or (file-exists? (string-append f ".tex"))
+               (file-exists? (string-append f ".scm"))
+               (file-exists? (string-append f *img-file-extn*))))
+      (case *operating-system*
+        ((unix) (system (string-append "mv " f ".* " *aux-dir*)))
+        ((windows)
+         (system (string-append "copy " f ".* " *aux-dir*))
+         (when (or
+                (file-exists? (string-append f ".tex"))
+                (file-exists? (string-append f ".scm")))
+           (system (string-append "del " f ".*"))))))))
+
+(define start-css-file
+  (lambda ()
+    (let ((css-file (string-append *aux-dir/* *jobname* *css-file-suffix*)))
+      (ensure-file-deleted css-file)
+      (set! *css-port* (open-output-file css-file))
+      (display
+        "\n               body {\n               color: black;\n               /*   background-color: #e5e5e5;*/\n               background-color: #ffffff;\n               /*background-color: beige;*/\n               margin-top: 2em;\n               margin-left: 8%;\n               margin-right: 8%;\n               }\n\n               h1,h2,h3,h4,h5,h6 {\n               margin-top: .5em;\n               }\n\n               .title {\n               font-size: 200%;\n               font-weight: normal;\n               margin-top: 2.8em;\n               text-align: center;\n               }\n\n               .partheading {\n               font-size: 100%;\n               }\n\n               .chapterheading {\n               font-size: 100%;\n               }\n\n               .beginsection {\n               font-size: 110%;\n               }\n\n               .tiny {\n               font-size: 40%;\n               }\n\n               .scriptsize {\n               font-size: 60%;\n               }\n\n               .footnotesize {\n               font-size: 75%;\n               }\n\n               .small {\n               font-size: 90%;\n               }\n\n               .normalsize {\n               font-size: 100%;\n               }\n\n               .large {\n               font-size: 120%;\n               }\n\n               .largecap {\n               font-size: 150%;\n               }\n\n               .largeup {\n               font-size: 200%;\n               }\n\n               .huge {\n               font-size: 300%;\n               }\n\n               .hugecap {\n               font-size: 350%;\n               }\n\n               pre {\n               margin-left: 2em;\n               }\n\n               blockquote {\n               margin-left: 2em;\n               }\n\n               ol {\n               list-style-type: decimal;\n               }\n\n               ol ol {\n               list-style-type: lower-alpha;\n               }\n\n               ol ol ol {\n               list-style-type: lower-roman;\n               }\n\n               ol ol ol ol {\n               list-style-type: upper-alpha;\n               }\n\n               tt i {\n               font-family: serif;\n               }\n\n               .verbatim em {\n               font-family: serif;\n               }\n\n               /*\n               .verbatim {\n               color: #4d0000;\n               }\n               */\n\n               .scheme em {\n               color: black;\n               font-family: serif;\n               }\n\n               .scheme {\n               color: brown;\n               }\n\n               .scheme .keyword {\n               color: #990000;\n               font-weight: bold;\n               }\n\n               .scheme .builtin {\n               color: #990000;\n               }\n\n               .scheme .variable {\n               color: navy;\n               }\n\n               .scheme .global {\n               color: purple;\n               }\n\n               .scheme .selfeval {\n               color: green;\n               }\n\n               .scheme .comment {\n               color:  teal;\n               }\n\n               .schemeresponse {\n               color: green;\n               }\n\n               .navigation {\n               color: red;\n               text-align: right;\n               font-size: medium;\n               font-style: italic;\n               }\n\n               .disable {\n               /* color: #e5e5e5; */\n               color: gray;\n               }\n\n               .smallcaps {\n               font-size: 75%;\n               }\n\n               .smallprint {\n               color: gray;\n               font-size: 75%;\n               text-align: right;\n               }\n\n               /*\n               .smallprint hr {\n               text-align: left;\n               width: 40%;\n               }\n               */\n\n               .footnoterule {\n               text-align: left;\n               width: 40%;\n               }\n\n               .colophon {\n               color: gray;\n               font-size: 80%;\n               font-style: italic;\n               text-align: right;\n               }\n\n               .colophon a {\n               color: gray;\n               }\n               "
+        *css-port*))))
+
+(define load-aux-file
+  (lambda ()
+    (let ((label-file
+            (string-append *aux-dir/* *jobname* *label-file-suffix* ".scm")))
+      (when (file-exists? label-file)
+        (load-tex2page-data-file label-file)
+        (delete-file label-file)))
+    (unless (string=? *jobname* "texput")
+      (let ((jobname-aux (string-append "texput" *aux-file-suffix* ".scm")))
+        (when (file-exists? jobname-aux) (delete-file jobname-aux))))
+    (let ((aux-file
+            (string-append *aux-dir/* *jobname* *aux-file-suffix* ".scm")))
+      (when (file-exists? aux-file)
+        (load-tex2page-data-file aux-file)
+        (delete-file aux-file))
+      (set! *aux-port* (open-output-file aux-file)))
+    (start-css-file)
+    (unless (null? *toc-list*) (set! *toc-list* (reverse! *toc-list*)))
+    (unless (null? *stylesheets*)
+      (set! *stylesheets* (reverse! *stylesheets*)))
+    (unless (null? *html-head*) (set! *html-head* (reverse! *html-head*)))))
+
+(define update-last-modification-time
+  (lambda (f)
+    (let ((s (file-or-directory-modify-seconds f)))
+      (when (and
+             s
+             (or (not *last-modification-time*)
+                 (> s *last-modification-time*)))
+        (set! *source-changed-since-last-run?* #t)
+        (!last-modification-time s)
+        (when (and
+               *colophon-mentions-last-mod-time?*
+               *colophon-on-first-page?*
+               (> *html-page-count* 1))
+          (flag-missing-piece 'last-modification-time))))))
+
+(define probably-latex
+  (lambda ()
+    (when (null? *tex-env*)
+      (set! *latex-probability* (+ *latex-probability* 1))
+      (if (>= *latex-probability* 2) (definitely-latex)))))
+
+(define definitely-latex
+  (let ((already-noted? #f))
+    (lambda ()
+      (unless already-noted?
+        (set! already-noted? #t)
+        (!definitely-latex)
+        (write-aux `(!definitely-latex))))))
+
+(define !toc-page (lambda (p) (set! *toc-page* p)))
+
+(define !index-page (lambda (p) (set! *index-page* p)))
+
+(define !toc-entry
+  (lambda (level number page label header)
+    (set! *toc-list*
+      (cons
+       (make-tocentry
+         'level
+         level
+         'number
+         number
+         'page
+         page
+         'label
+         label
+         'header
+         header)
+       *toc-list*))))
+
+(define !label
+  (lambda (label html-page name value)
+    (hash-table-put!
+      *label-table*
+      label
+      (make-label
+        'src
+        *label-source*
+        'page
+        html-page
+        'name
+        name
+        'value
+        value))))
+
+(define !index
+  (lambda (index-number html-page-number)
+    (hash-table-put! *index-table* index-number html-page-number)))
+
+(define !last-modification-time (lambda (s) (set! *last-modification-time* s)))
+
+(define !last-page-number (lambda (n) (set! *last-page-number* n)))
+
+(define !using-chapters (lambda () (set! *using-chapters?* #t)))
+
+(define !definitely-latex
+  (lambda ()
+    (set! *tex-format* 'latex)
+    (when (< (get-gcount "\\secnumdepth") -1)
+      (set-gcount! "\\secnumdepth" 3))))
+
+(define !using-external-program (lambda (x) #f))
+
+(define !external-labels (lambda (f) #f))
+
+(define !doctype (lambda (d) (set! *doctype* d)))
+
+(define !colophon
+  (lambda (x)
+    (case x
+      ((last-page) (set! *colophon-on-first-page?* #f))
+      ((no-timestamp) (set! *colophon-mentions-last-mod-time?* #f))
+      ((dont-credit-tex2page ingrate) (set! *colophon-mentions-tex2page?* #f))
+      ((dont-link-to-tex2page-website)
+       (set! *colophon-links-to-tex2page-website?* #f)))))
+
+(define fully-qualified-url?
+  (lambda (u) (or (substring? "//" u) (char=? (string-ref u 0) #\/))))
+
+(define fully-qualified-pathname?
+  (lambda (f)
+    (let ((n (string-length f)))
+      (if (= n 0)
+        #t
+        (let ((c0 (string-ref f 0)))
+          (cond
+           ((char=? c0 #\/) #t)
+           ((= n 1) #f)
+           ((and (char-alphabetic? c0) (char=? (string-ref f 1) #\:)) #t)
+           (else #f)))))))
+
+(define ensure-url-reachable
+  (lambda (f)
+    (if (and *aux-dir* (not (fully-qualified-url? f)) (not (substring? "/" f)))
+      (let ((real-f (string-append *aux-dir/* f)))
+        (when (and (file-exists? f) (not (file-exists? real-f)))
+          (case *operating-system*
+            ((unix) (system (string-append "cp -p " f " " real-f)))
+            ((windows) (system (string-append "copy/b " f " " *aux-dir*)))))
+        real-f)
+      f)))
+
+(define !stylesheet
+  (lambda (css)
+    (if (file-exists? (ensure-url-reachable css))
+      (set! *stylesheets* (cons css *stylesheets*))
+      (begin
+        (write-log "! Can't find stylesheet ")
+        (write-log css)
+        (write-log 'separation-newline)))))
+
+(define !header (lambda (s) (set! *html-head* (cons s *html-head*))))
+
+(define !default-title (lambda (title) (unless *title* (set! *title* title))))
+
+(define !preferred-title (lambda (title) (set! *title* title)))
+
+(define !infructuous-calls-to-tex2page
+  (lambda (n) (set! *infructuous-calls-to-tex2page* n)))
+
+(define load-tex2page-data-file
+  (lambda (f)
+    (when (file-exists? f)
+      (fluid-let
+        ((*current-source-file* f) (*input-line-no* 0))
+        (call-with-input-file
+          f
+          (lambda (i)
+            (let loop ()
+              (let ((e (read i)))
+                (unless (eof-object? e)
+                  (set! *input-line-no* (+ *input-line-no* 1))
+                  (let ((x (car e)))
+                    (apply
+                     (case x
+                       ((!colophon) !colophon)
+                       ((!default-title) !default-title)
+                       ((!definitely-latex) !definitely-latex)
+                       ((!doctype) !doctype)
+                       ((!external-labels) !external-labels)
+                       ((!header) !header)
+                       ((!html-head) !header)
+                       ((!index) !index)
+                       ((!index-page) !index-page)
+                       ((!infructuous-calls-to-tex2page)
+                        !infructuous-calls-to-tex2page)
+                       ((!label) !label)
+                       ((!last-modification-time) !last-modification-time)
+                       ((!last-page-number) !last-page-number)
+                       ((!preferred-title) !preferred-title)
+                       ((!stylesheet) !stylesheet)
+                       ((!toc-entry) !toc-entry)
+                       ((!toc-page) !toc-page)
+                       ((!using-chapters) !using-chapters)
+                       ((!using-external-program) !using-external-program)
+                       (else
+                        (terror
+                          'load-tex2page-data-file
+                          "Unrecognized aux file directive "
+                          x)))
+                     (cdr e))
+                    (loop)))))))))))
+
+(define tex2page-massage-file (lambda (f) f))
+
+(define tex2page-help
+  (lambda (not-a-file)
+    (write-aux
+      `(!infructuous-calls-to-tex2page ,(+ *infructuous-calls-to-tex2page* 1)))
+    (unless (or
+             (string=? not-a-file "--help")
+             (string=? not-a-file "--missing-arg")
+             (string=? not-a-file "--version"))
+      (write-log "! I can't find file ")
+      (write-log not-a-file)
+      (write-log 'separation-newline))
+    (cond
+     ((string=? not-a-file "--version")
+      (write-log
+        "Copyright (c) 1997-2005, Dorai Sitaram.\n\nPermission to distribute and use this work for any\npurpose is hereby granted provided this copyright\nnotice is included in the copy.  This work is provided\nas is, with no warranty of any kind.\n\nFor more information on TeX2page, please see")
+      (write-log #\newline)
+      (write-log *tex2page-website*)
+      (write-log #\.)
+      (write-log #\newline)
+      (write-log #\newline))
+     ((string=? not-a-file "--help")
+      (write-log
+        "\nThe command tex2page converts a (La)TeX document into\nWeb pages.  Call tex2page with the relative or full\npathname of the main (La)TeX file.  The file extension\nis optional if it is .tex.\n\nThe relative pathnames of the main and any subsidiary\n(La)TeX files are resolved against the current working\ndirectory and the list of directories in the\nenvironment variable TIIPINPUTS, or if that does not\nexist, TEXINPUTS.  \n\nThe output Web files are generated in the current\ndirectory by default.  An alternate location can be\nspecified in  <jobname>.hdir, tex2page.hdir, or\n~/tex2page.hdir, where <jobname> is the basename of the\nmain (La)TeX file.  \n\nFor more information on tex2page, please see")
+      (write-log #\newline)
+      (write-log *tex2page-website*)
+      (write-log #\.)
+      (write-log #\newline)
+      (write-log #\newline))
+     (else
+      (when (string=? not-a-file "--missing-arg")
+        (write-log "! Missing command-line argument.")
+        (write-log 'separation-newline))
+      (when (> *infructuous-calls-to-tex2page* 0)
+        (write-log "You have called TeX2page")
+        (write-log #\space)
+        (write-log (+ *infructuous-calls-to-tex2page* 1))
+        (write-log #\space)
+        (write-log "times without a valid input document.")
+        (write-log 'separation-newline))
+      (cond
+       ((>= *infructuous-calls-to-tex2page* 4)
+        (write-log "I can't go on meeting you like this.")
+        (write-log 'separation-newline)
+        (write-log "Good bye!")
+        (write-log 'separation-newline))
+       (else
+        (write-log
+          "Do you need help using TeX2page?\nTry the commands\n  tex2page --help\n  tex2page --version")
+        (write-log 'separation-newline)))))
+    (close-all-open-ports)))
+
+(define non-fatal-error
+  (lambda ss
+    (emit-link-start (string-append *jobname* ".hlog"))
+    (emit "[")
+    (for-each emit-html-string ss)
+    (emit "]")
+    (emit-link-stop)))
+
+(define do-math-ctl-seq
+  (lambda (s)
+    (cond
+     ((find-math-def s) => (lambda (x) ((tdef.thunk x))))
+     (else (emit (substring s 1 (string-length s)))))))
+
+(define tex-def-math-prim
+  (lambda (cs thunk)
+    (tex-def cs '() #f #f thunk cs #f *math-primitive-texframe*)))
+
+(define make-reusable-math-image-as-needed
+  (lambda (cs . expn)
+    (let ((expn (if (null? expn) cs (car expn))))
+      (tex-def-math-prim
+        cs
+        (lambda ()
+          (tex2page-string
+            (string-append "\\global\\imgdef" cs "{$" expn "$}"))
+          (tex2page-string cs))))))
+
+(tex-def-math-prim "\\beta" (lambda () (emit "<i>&szlig;</i>")))
+
+(tex-def-math-prim "\\iota" (lambda () (emit "<i><small>I</small></i>")))
+
+(tex-def-math-prim "\\kappa" (lambda () (emit "<i><small>K</small></i>")))
+
+(tex-def-math-prim "\\mu" (lambda () (emit "&micro;")))
+
+(tex-def-math-prim "\\ell" (lambda () (emit "<i>l</i>")))
+
+(tex-def-math-prim "\\partial" (lambda () (emit "&eth;")))
+
+(tex-def-math-prim "\\prime" (lambda () (emit "<small>/</small>")))
+
+(tex-def-math-prim "\\emptyset" (lambda () (emit "&Oslash;")))
+
+(tex-def-math-prim "\\|" (lambda () (emit "||")))
+
+(tex-def-math-prim "\\backslash" (lambda () (emit "\\")))
+
+(tex-def-math-prim "\\forall" (lambda () (emit "<b>A</b>")))
+
+(tex-def-math-prim "\\exists" (lambda () (emit "<b>E</b>")))
+
+(tex-def-math-prim "\\neg" (lambda () (emit "&not;")))
+
+(tex-def-math-prim "\\sharp" (lambda () (emit "#")))
+
+(tex-def-math-prim "\\pm" (lambda () (emit "&plusmn;")))
+
+(tex-def-math-prim "\\setminus" (lambda () (emit "\\")))
+
+(tex-def-math-prim "\\cdot" (lambda () (emit " &middot; ")))
+
+(tex-def-math-prim "\\div" (lambda () (emit "&divide;")))
+
+(tex-def-math-prim "\\times" (lambda () (emit "&times;")))
+
+(tex-def-math-prim "\\ast" (lambda () (emit #\*)))
+
+(tex-let-prim "\\star" "\\ast")
+
+(tex-def-math-prim "\\circ" (lambda () (emit "<small>o</small>")))
+
+(tex-def-math-prim "\\bullet" (lambda () (emit *html-bull*)))
+
+(tex-def-math-prim "\\vee" (lambda () (emit "V")))
+
+(tex-def-math-prim "\\wedge" (lambda () (emit "^")))
+
+(tex-def-math-prim "\\dagger" (lambda () (emit *html-dagger*)))
+
+(tex-def-math-prim "\\ddagger" (lambda () (emit *html-cap-dagger*)))
+
+(tex-def-math-prim "\\leq" (lambda () (emit "<u>&lt;</u>")))
+
+(tex-def-math-prim "\\ll" (lambda () (emit "&lt;&lt;")))
+
+(tex-def-math-prim "\\geq" (lambda () (emit "<u>&gt;</u>")))
+
+(tex-def-math-prim "\\gg" (lambda () (emit "&gt;&gt;")))
+
+(tex-def-math-prim "\\equiv" (lambda () (emit "<u>=</u>")))
+
+(tex-def-math-prim "\\sim" (lambda () (emit "~")))
+
+(tex-def-math-prim "\\simeq" (lambda () (emit "<u>~</u>")))
+
+(tex-def-math-prim "\\mid" (lambda () (emit "|")))
+
+(tex-def-math-prim "\\parallel" (lambda () (emit "||")))
+
+(tex-def-math-prim "\\perp" (lambda () (emit "<u>|</u>")))
+
+(tex-def-math-prim "\\not" (lambda () (emit #\!)))
+
+(tex-def-math-prim "\\leftarrow" (lambda () (emit "&lt;--")))
+
+(tex-def-math-prim "\\Leftarrow" (lambda () (emit "&lt;==")))
+
+(tex-def-math-prim "\\rightarrow" (lambda () (emit "-->")))
+
+(tex-def-math-prim "\\Rightarrow" (lambda () (emit "==&gt;")))
+
+(tex-def-math-prim "\\leftrightarrow" (lambda () (emit "&lt;--&gt;")))
+
+(tex-def-math-prim "\\Leftrightarrow" (lambda () (emit "&lt;==&gt;")))
+
+(tex-def-math-prim "\\longleftarrow" (lambda () (emit "&lt;---")))
+
+(tex-def-math-prim "\\Longleftarrow" (lambda () (emit "&lt;===")))
+
+(tex-def-math-prim "\\longrightarrow" (lambda () (emit "---&gt;")))
+
+(tex-def-math-prim "\\Longrightarrow" (lambda () (emit "===&gt;")))
+
+(tex-def-math-prim "\\longleftrightarrow" (lambda () (emit "&lt;---&gt;")))
+
+(tex-def-math-prim "\\Longleftrightarrow" (lambda () (emit "&lt;===&gt;")))
+
+(tex-def-math-prim
+  "\\uparrow"
+  (lambda () (emit "<table><tr><td>^</td></tr><tr><td>|</td></tr></table>")))
+
+(tex-def-math-prim "\\lbrack" (lambda () (emit "[")))
+
+(tex-def-math-prim "\\lbrace" (lambda () (emit "{")))
+
+(tex-def-math-prim "\\langle" (lambda () (emit *html-lsaquo*)))
+
+(tex-def-math-prim "\\rbrack" (lambda () (emit "]")))
+
+(tex-def-math-prim "\\rbrace" (lambda () (emit "}")))
+
+(tex-def-math-prim "\\rangle" (lambda () (emit *html-rsaquo*)))
+
+(tex-def-math-prim "\\colon" (lambda () (emit #\:)))
+
+(tex-def-math-prim "\\ne" (lambda () (emit "!=")))
+
+(tex-let-prim "\\neq" "\\ne")
+
+(tex-let-prim "\\le" "\\leq")
+
+(tex-let-prim "\\ge" "\\geq")
+
+(tex-let-prim "\\{" "\\lbrace")
+
+(tex-let-prim "\\}" "\\rbrace")
+
+(tex-let-prim "\\to" "\\rightarrow")
+
+(tex-let-prim "\\gets" "\\leftarrow")
+
+(tex-let-prim "\\land" "\\wedge")
+
+(tex-let-prim "\\lor" "\\vee")
+
+(tex-let-prim "\\lnot" "\\neg")
+
+(tex-let-prim "\\vert" "\\mid")
+
+(tex-let-prim "\\Vert" "\\parallel")
+
+(tex-let-prim "\\iff" "\\Longleftrightarrow")
+
+(tex-def-prim "\\S" (lambda () (emit "&sect;")))
+
+(tex-def-prim "\\P" (lambda () (emit "&para;")))
+
+(tex-let-prim "\\dag" "\\dagger")
+
+(tex-let-prim "\\ddag" "\\ddagger")
+
+(tex-def-math-prim "\\eqalign" (lambda () (do-eqalign 'eqalign)))
+
+(tex-def-math-prim "\\eqalignno" (lambda () (do-eqalign 'eqalignno)))
+
+(tex-def-math-prim "\\displaylines" (lambda () (do-eqalign 'displaylines)))
+
+(tex-let-prim "\\leqalignno" "\\eqalignno")
+
+(tex-def-math-prim "\\noalign" do-noalign)
+
+(tex-def-math-prim "\\frac" do-frac)
+
+(tex-def-math-prim "\\pmatrix" do-pmatrix)
+
+(tex-def-math-prim "\\eqno" do-eqno)
+
+(tex-let-prim "\\leqno" "\\eqno")
+
+(tex-def-math-prim "\\," do-space)
+
+(tex-def-math-prim "\\;" do-space)
+
+(tex-def-math-prim "\\!" do-relax)
+
+(tex-def-math-prim "\\mathbf" do-relax)
+
+(tex-def-math-prim "\\mathrm" do-relax)
+
+(tex-def-math-prim "\\over" (lambda () (emit "/")))
+
+(tex-def-math-prim
+  "\\sqrt"
+  (lambda ()
+    (emit "(")
+    (tex2page-string (get-token))
+    (emit ")<sup>1/2</sup>")))
+
+(tex-def-math-prim "\\left" do-relax)
+
+(tex-def-math-prim "\\right" do-relax)
+
+(tex-def-prim "\\AA" (lambda () (emit "&Aring;")))
+
+(tex-def-prim "\\aa" (lambda () (emit "&aring;")))
+
+(tex-def-prim
+  "\\abstract"
+  (lambda ()
+    (tex2page-string "\\quote")
+    (tex2page-string "\\centerline{\\bf\\abstractname}\\par")))
+
+(tex-def-prim "\\addtocounter" (lambda () (set-latex-counter #t)))
+
+(tex-def-prim "\\advance" (lambda () (do-advance #f)))
+
+(tex-def-prim "\\advancetally" (lambda () (do-advancetally #f)))
+
+(tex-def-prim "\\AE" (lambda () (emit "&AElig;")))
+
+(tex-def-prim "\\ae" (lambda () (emit "&aelig;")))
+
+(tex-def-prim "\\aftergroup" do-aftergroup)
+
+(tex-def-prim "\\alltt" do-alltt)
+
+(tex-def-prim "\\appendix" do-appendix)
+
+(tex-def-prim "\\appendixname" (lambda () (emit "Appendix ")))
+
+(tex-def-prim "\\author" do-author)
+
+(tex-def-prim "\\b" (lambda () (do-diacritic 'a)))
+
+(tex-def-prim "\\begin" do-begin)
+
+(tex-def-prim "\\bgroup" bgroup)
+
+(tex-def-prim "\\beginsection" do-beginsection)
+
+(tex-def-prim "\\bf" (lambda () (do-switch 'bf)))
+
+(tex-def-prim "\\bgcolor" (lambda () (do-switch 'bgcolor)))
+
+(tex-def-prim "\\bibitem" do-bibitem)
+
+(tex-def-prim "\\bibliography" do-bibliography)
+
+(tex-def-prim "\\bibliographystyle" do-bibliographystyle)
+
+(tex-def-prim "\\bigbreak" (lambda () (do-bigskip "\\bigbreak")))
+
+(tex-def-prim "\\bigskip" (lambda () (do-bigskip "\\bigskip")))
+
+(tex-def-prim "\\break" (lambda () (emit "<br>")))
+
+(tex-def-prim "\\c" (lambda () (do-diacritic 'cedilla)))
+
+(tex-def-prim "\\caption" do-caption)
+
+(tex-def-prim "\\catcode" do-catcode)
+
+(tex-def-math-prim
+  "\\cdots"
+  (lambda () (emit "<tt>&middot;&middot;&middot;</tt>")))
+
+(tex-def-prim "\\center" (lambda () (do-block 'center)))
+
+(tex-def-prim "\\centerline" (lambda () (do-function "\\centerline")))
+
+(tex-def-prim
+  "\\chapter"
+  (lambda ()
+    (!using-chapters)
+    (write-aux `(!using-chapters))
+    (when (and (eqv? *tex-format* 'latex) (< (get-gcount "\\secnumdepth") -1))
+      (set-gcount! "\\secnumdepth" 2))
+    (do-heading 0)))
+
+(tex-def-prim "\\chaptername" (lambda () (emit "Chapter ")))
+
+(tex-def-prim "\\char" do-char)
+
+(tex-def-prim "\\cite" do-cite)
+
+(tex-def-prim "\\closegraphsfile" do-mfpic-closegraphsfile)
+
+(tex-def-prim "\\closein" (lambda () (do-close-stream 'in)))
+
+(tex-def-prim "\\closeout" (lambda () (do-close-stream 'out)))
+
+(tex-def-prim "\\color" do-color)
+
+(tex-def-prim "\\convertMPtoPDF" do-convertmptopdf)
+
+(tex-def-prim "\\copyright" (lambda () (emit "&copy;")))
+
+(tex-def-prim "\\CR" (lambda () (do-cr "\\CR")))
+
+(tex-def-prim "\\cr" (lambda () (do-cr "\\cr")))
+
+(tex-def-prim "\\csname" do-csname)
+
+(tex-def-prim "\\cssblock" do-cssblock)
+
+(tex-def-prim "\\dag" (lambda () (emit *html-dagger*)))
+
+(tex-def-prim "\\date" do-date)
+
+(tex-def-prim "\\ddag" (lambda () (emit *html-cap-dagger*)))
+
+(tex-def-prim "\\def" (lambda () (do-def #f)))
+
+(tex-def-prim "\\defcsactive" (lambda () (do-defcsactive #f)))
+
+(tex-def-prim "\\definecolor" do-definecolor)
+
+(tex-def-prim "\\DefineNamedColor" (lambda () (get-token) (do-definecolor)))
+
+(tex-def-prim "\\definitelylatex" definitely-latex)
+
+(tex-def-prim "\\defschememathescape" (lambda () (scm-set-mathescape #t)))
+
+(tex-def-prim
+  "\\description"
+  (lambda ()
+    (do-end-para)
+    (set! *tabular-stack* (cons 'description *tabular-stack*))
+    (emit "<dl><dt></dt><dd>")))
+
+(tex-def-prim "\\DH" (lambda () (emit "&ETH;")))
+
+(tex-def-prim "\\dh" (lambda () (emit "&eth;")))
+
+(tex-def-prim "\\discretionary" do-discretionary)
+
+(tex-def-prim
+  "\\displaymath"
+  (lambda () (do-latex-env-as-image "displaymath" 'display)))
+
+(tex-def-prim "\\divide" (lambda () (do-divide #f)))
+
+(tex-def-prim "\\document" probably-latex)
+
+(tex-def-prim "\\documentclass" do-documentclass)
+
+(tex-def-prim
+  "\\dontuseimgforhtmlmath"
+  (lambda ()
+    (set! *use-image-for-displayed-math?* #f)
+    (set! *use-image-for-intext-math?* #f)))
+
+(tex-def-prim
+  "\\dontuseimgforhtmlmathdisplay"
+  (lambda () (set! *use-image-for-displayed-math?* #f)))
+
+(tex-def-prim
+  "\\dontuseimgforhtmlmathintext"
+  (lambda () (set! *use-image-for-intext-math?* #f)))
+
+(tex-def-prim "\\dots" (lambda () (emit "<tt>...</tt>")))
+
+(tex-def-prim "\\egroup" egroup)
+
+(tex-def-prim "\\eject" do-eject)
+
+(tex-def-prim "\\else" (lambda () (do-else)))
+
+(tex-def-prim "\\em" (lambda () (do-switch 'em)))
+
+(tex-def-prim "\\emph" (lambda () (do-function "\\emph")))
+
+(tex-def-prim "\\end" do-end)
+
+(tex-def-prim "\\endalltt" do-end-alltt)
+
+(tex-def-prim "\\endcenter" do-end-block)
+
+(tex-def-prim
+  "\\enddescription"
+  (lambda ()
+    (pop-tabular-stack 'description)
+    (do-end-para)
+    (emit "</dd></dl>")
+    (do-para)))
+
+(tex-def-prim "\\endeqnarray" do-end-equation)
+
+(tex-def-prim "\\endequation" do-end-equation)
+
+(tex-def-prim
+  "\\endenumerate"
+  (lambda ()
+    (pop-tabular-stack 'enumerate)
+    (do-end-para)
+    (emit "</ol>")
+    (do-para)))
+
+(tex-def-prim "\\endfigure" (lambda () (do-end-table/figure 'figure)))
+
+(tex-def-prim "\\endflushleft" do-end-block)
+
+(tex-def-prim "\\endflushright" do-end-block)
+
+(tex-def-prim "\\endgraf" do-para)
+
+(tex-def-prim
+  "\\endhtmlimg"
+  (lambda () (terror 'tex-def-prim "Unmatched \\endhtmlimg")))
+
+(tex-def-prim "\\endhtmlonly" (lambda () (set! *html-only* (- *html-only* 1))))
+
+(tex-def-prim
+  "\\enditemize"
+  (lambda ()
+    (pop-tabular-stack 'itemize)
+    (do-end-para)
+    (emit "</ul>")
+    (do-para)))
+
+(tex-def-prim "\\endminipage" do-endminipage)
+
+(tex-def-prim "\\endruledtable" do-endruledtable)
+
+(tex-def-prim "\\endtabbing" do-end-tabbing)
+
+(tex-def-prim "\\endtable" (lambda () (do-end-table/figure 'table)))
+
+(tex-def-prim "\\endtableplain" do-end-table-plain)
+
+(tex-def-prim "\\endtabular" do-end-tabular)
+
+(tex-def-prim
+  "\\endthebibliography"
+  (lambda () (emit "</table>") (egroup) (do-para)))
+
+(tex-def-prim "\\enspace" (lambda () (emit-nbsp 2)))
+
+(tex-def-prim
+  "\\enumerate"
+  (lambda ()
+    (do-end-para)
+    (set! *tabular-stack* (cons 'enumerate *tabular-stack*))
+    (emit "<ol>")))
+
+(tex-def-prim "\\epsfbox" do-epsfbox)
+
+(tex-def-prim "\\epsfig" do-epsfig)
+
+(tex-def-prim "\\epsfxsize" (lambda () (do-epsf-size 'x)))
+
+(tex-def-prim "\\epsfysize" (lambda () (do-epsf-size 'y)))
+
+(tex-def-prim "\\eqnarray" (lambda () (do-equation 'eqnarray)))
+
+(tex-def-prim "\\equation" (lambda () (do-equation 'equation)))
+
+(tex-def-prim "\\errmessage" do-errmessage)
+
+(tex-def-prim "\\eval" (lambda () (do-eval 'both)))
+
+(tex-def-prim "\\evalh" (lambda () (do-eval 'html)))
+
+(tex-def-prim "\\evalq" (lambda () (do-eval 'quiet)))
+
+(tex-def-prim "\\expandafter" do-expandafter)
+
+(tex-def-prim "\\expandhtmlindex" (lambda () (expand-html-index #f)))
+
+(tex-def-prim "\\externaltitle" do-externaltitle)
+
+(tex-def-prim "\\fi" (lambda () (do-fi)))
+
+(tex-def-prim "\\figure" (lambda () (do-table/figure 'figure)))
+
+(tex-def-prim "\\fiverm" (lambda () (do-switch 'fiverm)))
+
+(tex-def-prim "\\flushleft" (lambda () (do-block 'flushleft)))
+
+(tex-def-prim "\\flushright" (lambda () (do-block 'flushright)))
+
+(tex-def-prim "\\footnote" do-footnote)
+
+(tex-def-prim "\\footnotesize" (lambda () (do-switch 'footnotesize)))
+
+(tex-def-prim "\\gdef" (lambda () (do-def #t)))
+
+(tex-def-prim "\\global" do-global)
+
+(tex-def-prim "\\globaladvancetally" (lambda () (do-advancetally #t)))
+
+(tex-def-prim "\\gobblegroup" get-group)
+
+(tex-def-prim "\\\"" (lambda () (do-diacritic 'umlaut)))
+
+(tex-def-prim "\\halign" do-halign)
+
+(tex-def-prim "\\hbox" do-box)
+
+(tex-def-prim "\\hfill" (lambda () (emit-nbsp 5)))
+
+(tex-def-prim
+  "\\hrule"
+  (lambda () (do-end-para) (emit "<hr>") (emit-newline) (do-para)))
+
+(tex-def-prim "\\hskip" do-hskip)
+
+(tex-def-prim "\\hspace" do-hspace)
+
+(tex-def-prim "\\htmladdimg" do-htmladdimg)
+
+(tex-def-prim "\\htmladvancedentities" html-advanced-entities)
+
+(tex-def-prim "\\htmlcolophon" do-htmlcolophon)
+
+(tex-def-prim "\\htmldoctype" do-htmldoctype)
+
+(tex-def-prim "\\htmlgif" (lambda () (do-htmlimg "htmlgif")))
+
+(tex-def-prim "\\htmlheadonly" do-htmlheadonly)
+
+(tex-def-prim "\\htmlimageformat" do-htmlimageformat)
+
+(tex-def-prim "\\htmlimg" (lambda () (do-htmlimg "htmlimg")))
+
+(tex-def-prim "\\htmlimgmagnification" do-htmlimgmagnification)
+
+(tex-def-prim "\\htmlmathstyle" do-htmlmathstyle)
+
+(tex-def-prim "\\htmlonly" (lambda () (set! *html-only* (+ *html-only* 1))))
+
+(tex-def-prim "\\htmlpagelabel" do-htmlpagelabel)
+
+(tex-def-prim "\\htmlpageref" do-htmlpageref)
+
+(tex-def-prim "\\htmlref" do-htmlref)
+
+(tex-def-prim "\\htmlrefexternal" do-htmlrefexternal)
+
+(tex-def-prim "\\huge" (lambda () (do-switch 'huge)))
+
+(tex-def-prim "\\Huge" (lambda () (do-switch 'huge-cap)))
+
+(tex-def-prim "\\hyperref" do-hyperref)
+
+(tex-def-prim "\\hyperlink" do-hyperlink)
+
+(tex-def-prim "\\hypertarget" do-hypertarget)
+
+(tex-def-prim "\\if" do-if)
+
+(tex-def-prim "\\ifcase" do-ifcase)
+
+(tex-def-prim "\\ifeof" do-ifeof)
+
+(tex-def-prim "\\ifdim" do-iffalse)
+
+(tex-def-prim "\\iffalse" do-iffalse)
+
+(tex-def-prim "\\IfFileExists" do-iffileexists)
+
+(tex-def-prim "\\ifmmode" do-ifmmode)
+
+(tex-def-prim "\\ifnum" (lambda () (do-ifnum)))
+
+(tex-def-prim "\\iftrue" do-iftrue)
+
+(tex-def-prim "\\ifx" do-ifx)
+
+(tex-def-prim "\\ifodd" do-ifodd)
+
+(tex-def-prim
+  "\\ignorenextinputtimestamp"
+  (lambda ()
+    (unless *inputting-boilerplate?* (set! *inputting-boilerplate?* 0))))
+
+(tex-def-prim "\\ignorespaces" ignorespaces)
+
+(tex-def-prim "\\imgdef" (lambda () (make-reusable-img #f)))
+
+(tex-def-prim "\\imgpreamble" do-img-preamble)
+
+(tex-def-prim
+  "\\IMGtabbing"
+  (lambda () (do-latex-env-as-image "tabbing" 'display)))
+
+(tex-def-prim
+  "\\IMGtabular"
+  (lambda () (do-latex-env-as-image "tabular" 'display)))
+
+(tex-def-prim "\\include" do-include)
+
+(tex-def-prim "\\includeexternallabels" do-includeexternallabels)
+
+(tex-def-prim "\\includeonly" do-includeonly)
+
+(tex-def-prim "\\includegraphics" do-includegraphics)
+
+(tex-def-prim "\\index" do-index)
+
+(tex-def-prim "\\indexitem" (lambda () (do-indexitem 0)))
+
+(tex-def-prim "\\indexsubitem" (lambda () (do-indexitem 1)))
+
+(tex-def-prim "\\indexsubsubitem" (lambda () (do-indexitem 2)))
+
+(tex-def-prim "\\input" do-input)
+
+(tex-def-prim "\\inputcss" do-inputcss)
+
+(tex-def-prim "\\inputexternallabels" do-inputexternallabels)
+
+(tex-def-prim "\\InputIfFileExists" do-inputiffileexists)
+
+(tex-def-prim "\\inputindex" (lambda () (do-inputindex #f)))
+
+(tex-def-prim "\\it" (lambda () (do-switch 'it)))
+
+(tex-def-prim "\\item" do-item)
+
+(tex-def-prim "\\itemitem" (lambda () (do-plain-item 2)))
+
+(tex-def-prim
+  "\\itemize"
+  (lambda ()
+    (do-end-para)
+    (set! *tabular-stack* (cons 'itemize *tabular-stack*))
+    (emit "<ul>")))
+
+(tex-def-prim "\\itshape" (lambda () (do-switch 'itshape)))
+
+(tex-def-prim "\\jobname" (lambda () (tex2page-string *jobname*)))
+
+(tex-def-prim "\\label" do-label)
+
+(tex-def-prim "\\large" (lambda () (do-switch 'large)))
+
+(tex-def-prim "\\Large" (lambda () (do-switch 'large-cap)))
+
+(tex-def-prim "\\LARGE" (lambda () (do-switch 'large-up)))
+
+(tex-def-prim "\\LaTeX" do-latex-logo)
+
+(tex-def-prim "\\LaTeXe" do-latex2e-logo)
+
+(tex-def-prim "\\latexonly" (lambda () (ignore-tex-specific-text "latexonly")))
+
+(tex-def-prim
+  "\\leftdisplays"
+  (lambda () (set! *display-justification* 'left)))
+
+(tex-def-prim "\\leftline" (lambda () (do-function "\\leftline")))
+
+(tex-def-prim "\\let" (lambda () (do-let #f)))
+
+(tex-def-prim
+  "\\linebreak"
+  (lambda () (get-bracketed-text-if-any) (emit "<br>")))
+
+(tex-def-prim "\\mailto" do-mailto)
+
+(tex-def-prim "\\makehtmlimage" do-makehtmlimage)
+
+(tex-def-prim "\\maketitle" do-maketitle)
+
+(tex-def-prim "\\marginpar" do-marginpar)
+
+(tex-def-prim "\\mathg" do-mathg)
+
+(tex-def-prim "\\mathdg" do-mathdg)
+
+(tex-def-prim "\\mathp" do-mathp)
+
+(tex-def-prim "\\medbreak" (lambda () (do-bigskip "\\medbreak")))
+
+(tex-def-prim "\\medskip" (lambda () (do-bigskip "\\medskip")))
+
+(tex-def-prim "\\message" do-message)
+
+(tex-def-prim "\\mfpic" do-mfpic)
+
+(tex-def-prim "\\minipage" do-minipage)
+
+(tex-def-prim "\\multiply" (lambda () (do-multiply #f)))
+
+(tex-def-prim "\\narrower" (lambda () (do-switch 'narrower)))
+
+(tex-def-prim "\\newcommand" (lambda () (do-newcommand #f)))
+
+(tex-def-prim "\\newcount" (lambda () (do-newcount #f)))
+
+(tex-def-prim "\\newdimen" (lambda () (do-newdimen #f)))
+
+(tex-def-prim "\\newenvironment" (lambda () (do-newenvironment #f)))
+
+(tex-def-prim "\\newif" do-newif)
+
+(tex-def-prim "\\newread" (lambda () (do-new-stream 'in)))
+
+(tex-def-prim "\\newtheorem" do-newtheorem)
+
+(tex-def-prim "\\newtoks" (lambda () (do-newtoks #f)))
+
+(tex-def-prim "\\newwrite" (lambda () (do-new-stream 'out)))
+
+(tex-def-prim
+  "\\noad"
+  (lambda () (set! *colophon-links-to-tex2page-website?* #f)))
+
+(tex-def-prim "\\nocite" do-nocite)
+
+(tex-def-prim "\\node" do-node)
+
+(tex-def-prim "\\nonumber" do-nonumber)
+
+(tex-def-prim
+  "\\noslatexlikecomments"
+  (lambda () (set! *slatex-like-comments?* #f)))
+
+(tex-def-prim
+  "\\notimestamp"
+  (lambda () (set! *colophon-mentions-last-mod-time?* #f)))
+
+(tex-def-prim "\\nr" (lambda () (do-cr "\\nr")))
+
+(tex-def-prim "\\number" do-number)
+
+(tex-def-prim "\\numfootnote" do-numbered-footnote)
+
+(tex-def-prim "\\O" (lambda () (emit "&Oslash;")))
+
+(tex-def-prim "\\o" (lambda () (emit "&oslash;")))
+
+(tex-def-prim "\\obeylines" do-obeylines)
+
+(tex-def-prim "\\obeyspaces" do-obeyspaces)
+
+(tex-def-prim "\\obeywhitespace" do-obeywhitespace)
+
+(tex-def-prim "\\OE" (lambda () (emit *html-oelig*)))
+
+(tex-def-prim "\\oe" (lambda () (emit *html-cap-oelig*)))
+
+(tex-def-prim "\\opengraphsfile" do-mfpic-opengraphsfile)
+
+(tex-def-prim "\\openin" (lambda () (do-open-stream 'in)))
+
+(tex-def-prim "\\openout" (lambda () (do-open-stream 'out)))
+
+(tex-def-prim "\\pagebreak" (lambda () (get-bracketed-text-if-any) (do-eject)))
+
+(tex-def-prim "\\pageno" (lambda () (emit *html-page-count*)))
+
+(tex-def-prim "\\pageref" do-pageref)
+
+(tex-def-prim "\\part" (lambda () (do-heading -1)))
+
+(tex-def-prim "\\pdfximage" do-pdfximage)
+
+(tex-def-prim
+  "\\picture"
+  (lambda () (do-latex-env-as-image "picture" 'inline)))
+
+(tex-def-prim "\\plainfootnote" do-plain-footnote)
+
+(tex-def-prim "\\pounds" (lambda () (emit "&pound;")))
+
+(tex-def-prim "\\printindex" (lambda () (do-inputindex #t)))
+
+(tex-def-prim "\\quad" (lambda () (emit-nbsp 4)))
+
+(tex-def-prim "\\qquad" (lambda () (emit-nbsp 8)))
+
+(tex-def-prim
+  "\\quote"
+  (lambda () (do-end-para) (emit "<blockquote>") (bgroup)))
+
+(tex-def-prim
+  "\\endquote"
+  (lambda () (do-end-para) (egroup) (emit "</blockquote>")))
+
+(tex-def-prim "\\r" (lambda () (do-diacritic 'ring)))
+
+(tex-def-prim "\\raggedleft" (lambda () (do-switch 'raggedleft)))
+
+(tex-def-prim "\\rawhtml" do-rawhtml)
+
+(tex-def-prim "\\read" (lambda () (do-read #f)))
+
+(tex-def-prim "\\ref" do-ref)
+
+(tex-def-prim "\\refexternal" do-refexternal)
+
+(tex-def-prim "\\relax" do-relax)
+
+(tex-def-prim "\\renewcommand" (lambda () (do-newcommand #t)))
+
+(tex-def-prim "\\renewenvironment" (lambda () (do-newenvironment #t)))
+
+(tex-def-prim "\\resizebox" do-resizebox)
+
+(tex-def-prim "\\rightline" (lambda () (do-function "\\rightline")))
+
+(tex-def-prim "\\rm" (lambda () (if *math-mode?* (do-switch 'rm))))
+
+(tex-def-prim "\\romannumeral" (lambda () (do-romannumeral #f)))
+
+(tex-def-prim "\\Romannumeral" (lambda () (do-romannumeral #t)))
+
+(tex-def-prim "\\ruledtable" do-ruledtable)
+
+(tex-def-prim "\\sc" (lambda () (do-switch 'sc)))
+
+(tex-def-prim
+  "\\schemedisplay"
+  (lambda () (do-scm-slatex-lines "schemedisplay" #t #f)))
+
+(tex-def-prim
+  "\\schemebox"
+  (lambda () (do-scm-slatex-lines "schemebox" #f #f)))
+
+(tex-def-prim
+  "\\schemeresponse"
+  (lambda () (do-scm-slatex-lines "schemeresponse" #t 'result)))
+
+(tex-def-prim
+  "\\schemeresponsebox"
+  (lambda () (do-scm-slatex-lines "schemeresponsebox" #f 'result)))
+
+(tex-def-prim "\\schemeresult" (lambda () (do-scm 'result)))
+
+(tex-def-prim "\\scm" (lambda () (do-scm #f)))
+
+(tex-def-prim "\\scmbuiltin" do-scm-set-builtins)
+
+(tex-def-prim "\\scmdribble" do-scmdribble)
+
+(tex-def-prim "\\scminput" do-scminput)
+
+(tex-def-prim "\\scmkeyword" do-scm-set-keywords)
+
+(tex-def-prim "\\scmspecialsymbol" do-scm-set-specialsymbol)
+
+(tex-def-prim "\\scmvariable" do-scm-set-variables)
+
+(tex-def-prim "\\scriptsize" (lambda () (do-switch 'scriptsize)))
+
+(tex-def-prim "\\section" (lambda () (do-heading 1)))
+
+(tex-def-prim "\\seealso" do-see-also)
+
+(tex-def-prim "\\setcounter" (lambda () (set-latex-counter #f)))
+
+(tex-def-prim "\\sevenrm" (lambda () (do-switch 'sevenrm)))
+
+(tex-def-prim "\\sf" do-relax)
+
+(tex-def-prim "\\sl" (lambda () (do-switch 'sl)))
+
+(tex-def-prim "\\slatexdisable" get-group)
+
+(tex-def-prim
+  "\\slatexlikecomments"
+  (lambda () (set! *slatex-like-comments?* #t)))
+
+(tex-def-prim "\\small" (lambda () (do-switch 'small)))
+
+(tex-def-prim "\\smallbreak" (lambda () (do-bigskip "\\smallbreak")))
+
+(tex-def-prim "\\smallskip" (lambda () (do-bigskip "\\smallskip")))
+
+(tex-def-prim "\\ss" (lambda () (emit "&szlig;")))
+
+(tex-def-prim "\\strike" (lambda () (do-switch 'strike)))
+
+(tex-def-prim "\\string" do-string)
+
+(tex-def-prim "\\subject" do-subject)
+
+(tex-def-prim
+  "\\subsection"
+  (lambda () (get-bracketed-text-if-any) (do-heading 2)))
+
+(tex-def-prim "\\subsubsection" (lambda () (do-heading 3)))
+
+(tex-def-prim "\\symfootnote" do-symfootnote)
+
+(tex-def-prim "\\tabbing" do-tabbing)
+
+(tex-def-prim "\\table" (lambda () (do-table/figure 'table)))
+
+(tex-def-prim "\\tableplain" do-table-plain)
+
+(tex-def-prim "\\tableofcontents" do-toc)
+
+(tex-def-prim "\\tabular" do-tabular)
+
+(tex-def-prim "\\tag" do-tag)
+
+(tex-def-prim "\\TeX" do-tex-logo)
+
+(tex-def-prim "\\texonly" (lambda () (ignore-tex-specific-text "texonly")))
+
+(tex-def-prim "\\textasciicircum" (lambda () (emit "^")))
+
+(tex-def-prim "\\textbar" (lambda () (emit "|")))
+
+(tex-def-prim "\\textbackslash" (lambda () (emit "\\")))
+
+(tex-def-prim "\\textbf" (lambda () (do-function "\\textbf")))
+
+(tex-def-prim "\\textbullet" (lambda () (emit *html-bull*)))
+
+(tex-def-prim "\\textdegree" (lambda () (emit "&deg;")))
+
+(tex-def-prim "\\textemdash" (lambda () (emit *html-mdash*)))
+
+(tex-def-prim "\\textendash" (lambda () (emit *html-ndash*)))
+
+(tex-def-prim "\\textexclamdown" (lambda () (emit "&iexcl;")))
+
+(tex-def-prim "\\textgreater" (lambda () (emit "&gt;")))
+
+(tex-def-prim "\\textit" (lambda () (do-function "\\textit")))
+
+(tex-def-prim "\\textless" (lambda () (emit "&lt;")))
+
+(tex-def-prim "\\textperiodcentered" (lambda () (emit "&middot;")))
+
+(tex-def-prim "\\textquestiondown" (lambda () (emit "&iquest;")))
+
+(tex-def-prim "\\textquotedblleft" (lambda () (emit *html-ldquo*)))
+
+(tex-def-prim "\\textquotedblright" (lambda () (emit *html-rdquo*)))
+
+(tex-def-prim "\\textquoteleft" (lambda () (emit *html-lsquo*)))
+
+(tex-def-prim "\\textquoteright" (lambda () (emit *html-rsquo*)))
+
+(tex-def-prim "\\textregistered" (lambda () (emit "&reg;")))
+
+(tex-def-prim "\\textrm" (lambda () (do-function "\\textrm")))
+
+(tex-def-prim
+  "\\textsc"
+  (lambda ()
+    (fluid-let ((*in-small-caps?* #t)) (tex2page-string (get-group)))))
+
+(tex-def-prim "\\textsl" (lambda () (do-function "\\textsl")))
+
+(tex-def-prim "\\textasciitilde" (lambda () (emit "~")))
+
+(tex-def-prim "\\texttrademark" (lambda () (emit *html-trade*)))
+
+(tex-def-prim "\\texttt" (lambda () (do-function "\\texttt")))
+
+(tex-def-prim "\\textvisiblespace" emit-visible-space)
+
+(tex-def-prim "\\TH" (lambda () (emit "&THORN;")))
+
+(tex-def-prim "\\th" (lambda () (emit "&thorn;")))
+
+(tex-def-prim "\\the" do-the)
+
+(tex-def-prim "\\thebibliography" do-thebibliography)
+
+(tex-def-prim "\\theindex" do-theindex)
+
+(tex-def-prim "\\TIIPbackslash" (lambda () (emit "\\")))
+
+(tex-def-prim "\\TIIPbr" do-br)
+
+(tex-def-prim "\\TIIPcmyk" (lambda () (do-switch 'cmyk)))
+
+(tex-def-prim "\\TIIPcomment" eat-till-eol)
+
+(tex-def-prim "\\TIIPeatstar" eat-star)
+
+(tex-def-prim "\\TIIPendgraf" do-end-para)
+
+(tex-def-prim "\\TIIPgobblegroup" get-group)
+
+(tex-def-prim "\\TIIPgray" (lambda () (do-switch 'gray)))
+
+(tex-def-prim "\\TIIPlatexenvasimage" do-following-latex-env-as-image)
+
+(tex-def-prim "\\TIIPnbsp" (lambda () (emit-nbsp 1)))
+
+(tex-def-prim "\\TIIPnewline" do-newline)
+
+(tex-def-prim "\\TIIPnull" get-actual-char)
+
+(tex-def-prim "\\TIIPreuseimage" reuse-img)
+
+(tex-def-prim "\\TIIPrgb" (lambda () (do-switch 'rgb)))
+
+(tex-def-prim "\\TIIPRGB" (lambda () (do-switch 'rgb255)))
+
+(tex-def-prim "\\TIIPtheorem" do-theorem)
+
+(tex-def-prim "\\tiny" (lambda () (do-switch 'tiny)))
+
+(tex-def-prim "\\title" do-title)
+
+(tex-def-prim "\\today" do-today)
+
+(tex-def-prim "\\trademark" (lambda () (emit *html-trade*)))
+
+(tex-def-prim "\\tracingall" do-tracingall)
+
+(tex-def-prim "\\tracingcommands" (lambda () (do-tracingcommands #f)))
+
+(tex-def-prim "\\tracingmacros" (lambda () (do-tracingmacros #f)))
+
+(tex-def-prim "\\tt" (lambda () (do-switch 'tt)))
+
+(tex-def-prim "\\typein" do-typein)
+
+(tex-def-prim "\\undefcsactive" do-undefcsactive)
+
+(tex-def-prim "\\undefschememathescape" (lambda () (scm-set-mathescape #f)))
+
+(tex-def-prim "\\underline" (lambda () (do-function "\\underline")))
+
+(tex-def-prim "\\unscmspecialsymbol" do-scm-unset-specialsymbol)
+
+(tex-def-prim "\\url" do-url)
+
+(tex-def-prim "\\urlh" do-urlh)
+
+(tex-def-prim "\\urlhd" do-urlhd)
+
+(tex-def-prim "\\urlp" do-urlp)
+
+(tex-def-prim "\\v" (lambda () (do-diacritic 'hacek)))
+
+(tex-def-prim
+  "\\vdots"
+  (lambda ()
+    (emit "<tt><table><tr><td>.</td></tr>")
+    (emit "<tr><td>.</td></tr>")
+    (emit "<tr><td>.</td></tr></table></tt>")))
+
+(tex-def-prim "\\verb" do-verb)
+
+(tex-def-prim "\\verbatim" do-verbatim-latex)
+
+(tex-def-prim "\\verbatiminput" do-verbatiminput)
+
+(tex-def-prim "\\verbc" do-verbc)
+
+(tex-def-prim "\\verbescapechar" do-verbescapechar)
+
+(tex-def-prim "\\verbwrite" do-verbwrite)
+
+(tex-def-prim "\\verbwritefile" do-verbwritefile)
+
+(tex-def-prim "\\vskip" (lambda () (eat-dimen) (do-bigskip "vskip")))
+
+(tex-def-prim "\\vspace" do-vspace)
+
+(tex-def-prim "\\write" do-write)
+
+(tex-def-prim "\\xspace" do-xspace)
+
+(tex-def-prim "\\yen" (lambda () (emit "&yen;")))
+
+(tex-def-prim "\\contentsname" (lambda () (emit "Contents")))
+
+(tex-def-prim "\\listfigurename" (lambda () (emit "List of Figures")))
+
+(tex-def-prim "\\listtablename" (lambda () (emit "List of Tables")))
+
+(tex-def-prim "\\refname" (lambda () (emit "References")))
+
+(tex-def-prim "\\indexname" (lambda () (emit "Index")))
+
+(tex-def-prim "\\figurename" (lambda () (emit "Figure")))
+
+(tex-def-prim "\\tablename" (lambda () (emit "Table")))
+
+(tex-def-prim "\\partname" (lambda () (emit "Part")))
+
+(tex-def-prim "\\appendixname" (lambda () (emit "Appendix")))
+
+(tex-def-prim "\\abstractname" (lambda () (emit "Abstract")))
+
+(tex-def-prim "\\bibname" (lambda () (emit "Bibliography")))
+
+(tex-def-prim "\\chaptername" (lambda () (emit "Chapter")))
+
+(tex-def-prim "\\\\" (lambda () (do-cr "\\\\")))
+
+(tex-def-prim "\\`" (lambda () (do-diacritic 'grave)))
+
+(tex-def-prim "\\(" do-latex-intext-math)
+
+(tex-def-prim "\\[" do-latex-display-math)
+
+(tex-def-prim "\\)" egroup)
+
+(tex-def-prim "\\]" egroup)
+
+(tex-def-prim "\\{" (lambda () (emit "{")))
+
+(tex-def-prim "\\}" (lambda () (emit "}")))
+
+(tex-let-prim "\\-" "\\relax")
+
+(tex-def-prim "\\'" (lambda () (do-diacritic 'acute)))
+
+(tex-def-prim
+  "\\="
+  (lambda ()
+    (unless (and
+             (not (null? *tabular-stack*))
+             (eqv? (car *tabular-stack*) 'tabbing))
+      (do-diacritic 'circumflex))))
+
+(tex-def-prim
+  "\\>"
+  (lambda ()
+    (if (and (not (null? *tabular-stack*))
+             (eqv? (car *tabular-stack*) 'tabbing))
+      (emit-nbsp 3))))
+
+(tex-def-prim "\\^" (lambda () (do-diacritic 'circumflex)))
+
+(tex-def-prim "\\~" (lambda () (do-diacritic 'tilde)))
+
+(tex-def-prim "\\#" (lambda () (emit "#")))
+
+(tex-def-prim "\\ " (lambda () (emit #\space)))
+
+(tex-def-prim "\\%" (lambda () (emit "%")))
+
+(tex-def-prim "\\&" (lambda () (emit "&amp;")))
+
+(tex-def-prim "\\@" (lambda () (emit "@")))
+
+(tex-def-prim "\\_" (lambda () (emit "_")))
+
+(tex-def-prim "\\$" (lambda () (emit "$")))
+
+(tex-def-prim (string #\\ #\newline) emit-newline)
+
+(tex-let-prim "\\displaystyle" "\\relax")
+
+(tex-let-prim "\\textstyle" "\\relax")
+
+(tex-let-prim "\\endsloppypar" "\\relax")
+
+(tex-let-prim "\\frenchspacing" "\\relax")
+
+(tex-let-prim "\\noindent" "\\relax")
+
+(tex-let-prim "\\oldstyle" "\\relax")
+
+(tex-let-prim "\\protect" "\\relax")
+
+(tex-let-prim "\\raggedbottom" "\\relax")
+
+(tex-let-prim "\\raggedright" "\\relax")
+
+(tex-let-prim "\\sloppy" "\\relax")
+
+(tex-let-prim "\\sloppypar" "\\relax")
+
+(tex-let-prim "\\normalfont" "\\relax")
+
+(tex-let-prim "\\textnormal" "\\relax")
+
+(tex-let-prim "\\unskip" "\\relax")
+
+(tex-def-prim "\\font" eat-till-eol)
+
+(tex-def-prim "\\cline" get-group)
+
+(tex-def-prim "\\externalref" get-group)
+
+(tex-def-prim "\\GOBBLEARG" get-group)
+
+(tex-def-prim "\\hyphenation" get-group)
+
+(tex-def-prim "\\newcounter" get-group)
+
+(tex-def-prim "\\newlength" get-group)
+
+(tex-def-prim "\\hphantom" get-group)
+
+(tex-def-prim "\\vphantom" get-group)
+
+(tex-def-prim "\\phantom" get-group)
+
+(tex-def-prim "\\pagenumbering" get-group)
+
+(tex-def-prim "\\pagestyle" get-group)
+
+(tex-def-prim "\\raisebox" get-group)
+
+(tex-def-prim "\\thispagestyle" get-group)
+
+(tex-def-prim "\\manpagesection" get-group)
+
+(tex-def-prim "\\manpagedescription" get-group)
+
+(tex-def-prim "\\externallabels" (lambda () (get-group) (get-group)))
+
+(tex-let-prim "\\markboth" "\\externallabels")
+
+(tex-def-prim "\\hbadness" eat-integer)
+
+(tex-def-prim "\\exhyphenpenalty" eat-integer)
+
+(tex-def-prim "\\hyphenpenalty" eat-integer)
+
+(tex-def-prim "\\showboxdepth" eat-integer)
+
+(tex-def-prim "\\pretolerance" eat-integer)
+
+(tex-def-prim "\\tolerance" eat-integer)
+
+(tex-def-prim "\\widowpenalty" eat-integer)
+
+(tex-def-prim "\\baselineskip" eat-dimen)
+
+(tex-def-prim "\\columnsep" eat-dimen)
+
+(tex-def-prim "\\columnseprule" eat-dimen)
+
+(tex-def-prim "\\evensidemargin" eat-dimen)
+
+(tex-def-prim "\\fboxsep" eat-dimen)
+
+(tex-def-prim "\\headsep" eat-dimen)
+
+(tex-def-prim "\\itemsep" eat-dimen)
+
+(tex-def-prim "\\kern" eat-dimen)
+
+(tex-def-prim "\\leftcodeskip" eat-dimen)
+
+(tex-def-prim "\\lower" eat-dimen)
+
+(tex-def-prim "\\oddsidemargin" eat-dimen)
+
+(tex-def-prim "\\overfullrule" eat-dimen)
+
+(tex-def-prim "\\parindent" eat-dimen)
+
+(tex-def-prim "\\parsep" eat-dimen)
+
+(tex-def-prim "\\parskip" eat-dimen)
+
+(tex-def-prim "\\raise" eat-dimen)
+
+(tex-def-prim "\\rightcodeskip" eat-dimen)
+
+(tex-def-prim "\\sidemargin" eat-dimen)
+
+(tex-def-prim "\\textheight" eat-dimen)
+
+(tex-def-prim "\\textwidth" eat-dimen)
+
+(tex-def-prim "\\topmargin" eat-dimen)
+
+(tex-def-prim "\\topsep" eat-dimen)
+
+(tex-def-prim "\\vertmargin" eat-dimen)
+
+(tex-def-prim "\\addtolength" (lambda () (get-token) (get-token)))
+
+(tex-let-prim "\\addvspace" "\\vspace")
+
+(tex-let-prim "\\setlength" "\\addtolength")
+
+(tex-let-prim "\\settowidth" "\\addtolength")
+
+(tex-let-prim "\\hookaction" "\\addtolength")
+
+(tex-def-prim "\\enlargethispage" (lambda () (eat-star) (get-group)))
+
+(tex-def-prim "\\parbox" (lambda () (get-bracketed-text-if-any) (get-group)))
+
+(tex-def-prim
+  "\\ProvidesFile"
+  (lambda () (get-group) (get-bracketed-text-if-any)))
+
+'(tex-def-prim
+   "\\addcontentsline"
+   (lambda () (get-group) (get-group) (get-group)))
+
+(tex-def-prim "\\addcontentsline" do-addcontentsline)
+
+(tex-def-prim
+  "\\makebox"
+  (lambda () (get-bracketed-text-if-any) (get-bracketed-text-if-any)))
+
+(tex-let-prim "\\framebox" "\\makebox")
+
+(tex-def-prim
+  "\\rule"
+  (lambda () (get-bracketed-text-if-any) (get-group) (get-group)))
+
+(tex-def-prim "\\GOBBLEOPTARG" get-bracketed-text-if-any)
+
+(tex-def-prim "\\nolinebreak" get-bracketed-text-if-any)
+
+(tex-def-prim "\\nopagebreak" get-bracketed-text-if-any)
+
+(tex-def-prim "\\hyphenchar" (lambda () (get-token) (eat-integer)))
+
+(tex-def-prim
+  "\\usepackage"
+  (lambda () (get-bracketed-text-if-any) (get-group) (probably-latex)))
+
+(tex-def-prim "\\readindexfile" (lambda () (get-token) (do-inputindex #f)))
+
+(tex-let-prim "\\enskip" "\\enspace")
+
+(tex-let-prim "\\colophon" "\\htmlcolophon")
+
+(tex-let-prim "\\path" "\\verb")
+
+(tex-let-prim "\\par" "\\endgraf")
+
+(tex-let-prim "\\u" "\\`")
+
+(tex-let-prim "\\vbox" "\\hbox")
+
+(tex-let-prim "\\endabstract" "\\endquote")
+
+(tex-let-prim "\\mbox" "\\hbox")
+
+(tex-let-prim "\\supereject" "\\eject")
+
+(tex-let-prim "\\dosupereject" "\\eject")
+
+(tex-let-prim "\\endgroup" "\\egroup")
+
+(tex-let-prim "\\begingroup" "\\bgroup")
+
+(tex-let-prim "\\d" "\\b")
+
+(tex-let-prim "\\." "\\b")
+
+(tex-let-prim "\\k" "\\c")
+
+(tex-let-prim "\\ldots" "\\dots")
+
+(tex-let-prim "\\documentstyle" "\\documentclass")
+
+(tex-let-prim "\\edef" "\\def")
+
+(tex-let-prim "\\H" "\\\"")
+
+(tex-let-prim "\\/" "\\relax")
+
+(tex-let-prim "\\leavevmode" "\\relax")
+
+(tex-let-prim "\\space" "\\ ")
+
+(tex-let-prim "\\quotation" "\\quote")
+
+(tex-let-prim "\\endquotation" "\\endquote")
+
+(tex-let-prim "\\xdef" "\\gdef")
+
+(tex-let-prim "\\TIIPdate" "\\today")
+
+(tex-let-prim "\\schemeinput" "\\scminput")
+
+(tex-let-prim "\\sidx" "\\index")
+
+(tex-let-prim "\\obeywhitespaces" "\\obeywhitespace")
+
+(tex-let-prim "\\ensuremath" "\\mathg")
+
+(tex-let-prim "\\epsffile" "\\epsfbox")
+
+(tex-let-prim "\\iffileexists" "\\IfFileExists")
+
+(tex-let-prim "\\htmlimgformat" "\\htmlimageformat")
+
+(tex-let-prim "\\p" "\\verb")
+
+(tex-let-prim "\\ttraggedright" "\\tt")
+
+(tex-let-prim "\\ttfamily" "\\tt")
+
+(tex-let-prim "\\htmladdnormallink" "\\urlp")
+
+(tex-let-prim "\\htmladdnormallinkfoot" "\\urlp")
+
+(tex-let-prim "\\pagehtmlref" "\\htmlref")
+
+(tex-let-prim "\\circledR" "\\textregistered")
+
+(tex-let-prim "\\registered" "\\textregistered")
+
+(tex-let-prim "\\href" "\\urlhd")
+
+(tex-let-prim "\\scmconstant" "\\scmbuiltin")
+
+(tex-let-prim "\\setbuiltin" "\\scmbuiltin")
+
+(tex-let-prim "\\setconstant" "\\scmconstant")
+
+(tex-let-prim "\\setkeyword" "\\scmkeyword")
+
+(tex-let-prim "\\setvariable" "\\scmvariable")
+
+(tex-let-prim "\\unssetspecialsymbol" "\\unscmspecialsymbol")
+
+(tex-let-prim "\\setspecialsymbol" "\\scmspecialsymbol")
+
+(tex-let-prim "\\scmp" "\\scm")
+
+(tex-let-prim "\\q" "\\scm")
+
+(tex-let-prim "\\scheme" "\\scm")
+
+(tex-let-prim "\\tagref" "\\ref")
+
+(tex-let-prim "\\numberedfootnote" "\\numfootnote")
+
+(tex-let-prim "\\f" "\\numfootnote")
+
+(tex-let-prim "\\newpage" "\\eject")
+
+(tex-let-prim "\\clearpage" "\\eject")
+
+(tex-let-prim "\\cleardoublepage" "\\eject")
+
+(tex-let-prim "\\htmlpagebreak" "\\eject")
+
+(tex-let-prim "\\typeout" "\\message")
+
+(tex-let-prim "\\unorderedlist" "\\itemize")
+
+(tex-let-prim "\\htmlstylesheet" "\\inputcss")
+
+(tex-let-prim "\\hr" "\\hrule")
+
+(tex-let-prim "\\htmlrule" "\\hrule")
+
+(tex-let-prim "\\numberedlist" "\\enumerate")
+
+(tex-let-prim "\\orderedlist" "\\enumerate")
+
+(tex-let-prim "\\endunorderedlist" "\\enditemize")
+
+(tex-let-prim "\\endnumberedlist" "\\endenumerate")
+
+(tex-let-prim "\\endorderedlist" "\\endenumerate")
+
+(tex-let-prim "\\newline" "\\break")
+
+(tex-let-prim "\\gifdef" "\\imgdef")
+
+(tex-let-prim "\\schemeeval" "\\eval")
+
+(tex-let-prim "\\gifpreamble" "\\imgpreamble")
+
+(tex-let-prim "\\mathpreamble" "\\imgpreamble")
+
+(tex-let-prim "\\scmverbatim" "\\scm")
+
+(tex-let-prim "\\scmfilename" "\\verbwritefile")
+
+(tex-let-prim "\\scmwritefile" "\\verbwritefile")
+
+(tex-let-prim "\\verbfilename" "\\verbwritefile")
+
+(tex-let-prim "\\scmfileonly" "\\verbwrite")
+
+(tex-let-prim "\\scmverbatimfile" "\\scminput")
+
+(tex-let-prim "\\scmverbatiminput" "\\scminput")
+
+(tex-let-prim "\\scmwrite" "\\verbwrite")
+
+(tex-let-prim "\\scmfile" "\\scmdribble")
+
+(tex-let-prim "\\scmverb" "\\scm")
+
+(tex-let-prim "\\verbinput" "\\verbatiminput")
+
+(tex-let-prim "\\verbatimfile" "\\verbatiminput")
+
+(tex-let-prim "\\setverbatimescapechar" "\\verbescapechar")
+
+(tex-let-prim "\\nohtmlmathimg" "\\dontuseimgforhtmlmath")
+
+(tex-let-prim "\\nohtmlmathintextimg" "\\dontuseimgforhtmlmathintext")
+
+(tex-let-prim "\\nohtmlmathdisplayimg" "\\dontuseimgforhtmlmathdisplay")
+
+(define tex2page
+  (lambda (tex-file)
+    (unless (= *write-log-index* 0) (newline))
+    (fluid-let
+      ((*afterpar* '())
+       (*afterbye* '())
+       (*aux-dir* #f)
+       (*aux-dir/* "")
+       (*aux-port* #f)
+       (*bib-aux-port* #f)
+       (*bibitem-num* 0)
+       (*colophon-links-to-tex2page-website?*
+         *colophon-links-to-tex2page-website?*)
+       (*colophon-mentions-last-mod-time?* *colophon-mentions-last-mod-time?*)
+       (*colophon-mentions-tex2page?* *colophon-mentions-tex2page?*)
+       (*colophon-on-first-page?* *colophon-on-first-page?*)
+       (*color-names* '())
+       (*comment-char* #\%)
+       (*css-port* #f)
+       (*current-tex2page-input* #f)
+       (*current-source-file* #f)
+       (*display-justification* 'center)
+       (*doctype* *doctype*)
+       (*dotted-counters* (make-table 'equ string=?))
+       (*dumping-nontex?* #f)
+       (*equation-number* #f)
+       (*equation-numbered?* #t)
+       (*equation-position* 0)
+       (*esc-char* #\\)
+       (*esc-char-std* #\\)
+       (*esc-char-verb* #\|)
+       (*eval-file-count* 0)
+       (*eval-for-tex-only?* #f)
+       (*external-label-tables* (make-table 'equ string=?))
+       (*footnote-list* '())
+       (*footnote-sym* 0)
+       (*global-texframe* (make-texframe))
+       (*graphics-file-extensions* '(".eps"))
+       (*html* #f)
+       (*html-head* '())
+       (*html-only* 0)
+       (*html-page* #f)
+       (*html-page-count* 0)
+       (*image-format* *image-format*)
+       (*img-file-count* 0)
+       (*img-file-extn* (find-img-file-extn))
+       (*img-file-tally* 0)
+       (*imgdef-file-count* 0)
+       (*imgpreamble* "")
+       (*imgpreamble-inferred* '())
+       (*in-alltt?* #f)
+       (*in-display-math?* #f)
+       (*in-para?* #f)
+       (*in-small-caps?* #f)
+       (*includeonly-list* #t)
+       (*index-table* (make-table))
+       (*index-count* 0)
+       (*index-page* #f)
+       (*index-port* #f)
+       (*infructuous-calls-to-tex2page* 0)
+       (*input-line-no* 0)
+       (*input-streams* '())
+       (*inputting-boilerplate?* #f)
+       (*inside-appendix?* #f)
+       (*jobname* "texput")
+       (*label-port* #f)
+       (*label-source* #f)
+       (*label-table* (make-table 'equ string=?))
+       (*last-modification-time* #f)
+       (*last-page-number* -1)
+       (*latex-probability* 0)
+       (*ligatures?* #t)
+       (*loading-external-labels?* #f)
+       (*log-file* #f)
+       (*log-port* #f)
+       (*main-tex-file* #f)
+       (*math-mode?* #f)
+       (*mfpic-file-num* #f)
+       (*mfpic-file-stem* #f)
+       (*mfpic-port* #f)
+       (*missing-eps-files* '())
+       (*missing-pieces* '())
+       (*mp-files* '())
+       (*not-processing?* #f)
+       (*output-streams* '())
+       (*outputting-external-title?* #f)
+       (*outputting-to-non-html?* #f)
+       (*recent-node-name* #f)
+       (*scm-dribbling?* #f)
+       (*section-counter-dependencies* (make-table))
+       (*section-counters* (make-table))
+       (*slatex-like-comments?* #f)
+       (*slatex-math-escape* #f)
+       (*source-changed-since-last-run?* #f)
+       (*stylesheets* '())
+       (*subjobname* #f)
+       (*tabular-stack* '())
+       (*temp-string-count* 0)
+       (*tex2page-inputs* (path-to-list (getenv "TIIPINPUTS")))
+       (*tex-env* '())
+       (*tex-format* 'plain)
+       (*tex-if-stack* '())
+       (*title* #f)
+       (*toc-list* '())
+       (*toc-page* #f)
+       (*tracingcommands?* #f)
+       (*tracingmacros?* #f)
+       (*unresolved-xrefs* '())
+       (*use-image-for-displayed-math?* #t)
+       (*use-image-for-intext-math?* #t)
+       (*using-bibliography?* #f)
+       (*using-chapters?* #f)
+       (*using-index?* #f)
+       (*verb-display?* #f)
+       (*verb-port* #f)
+       (*verb-visible-space?* #f)
+       (*verb-written-files* '())
+       (*write-log-index* 0)
+       (*write-log-possible-break?* #f))
+      (when *use-advanced-html-entities?* (html-advanced-entities))
+      (set! *main-tex-file*
+        (actual-tex-filename tex-file (check-input-file-timestamp? tex-file)))
+      (write-log "This is TeX2page, Version ")
+      (write-log *tex2page-version*)
+      (write-log #\space)
+      (write-log #\()
+      (write-log *scheme-version*)
+      (write-log #\,)
+      (write-log #\space)
+      (write-log *operating-system*)
+      (write-log #\))
+      (write-log 'separation-newline)
+      (cond
+       (*main-tex-file*
+        (set! *subjobname* *jobname*)
+        (set! *html-page*
+          (string-append *aux-dir/* *jobname* *output-extension*))
+        (ensure-file-deleted *html-page*)
+        (set! *html* (open-output-file *html-page*))
+        (do-start)
+        (let ((t2p-file
+                (actual-tex-filename (string-append *jobname* ".t2p") #f)))
+          (when t2p-file
+            (fluid-let
+              ((*html-only* (+ *html-only* 1)))
+              (tex2page-file t2p-file))))
+        (unless (eqv? (tex2page-file *main-tex-file*) ':encountered-bye)
+          (insert-missing-end))
+        (do-bye))
+       (else (tex2page-help tex-file)))
+      (output-stats))))
+
+
+)
diff --git a/collects/tex2page/tex2page.ss b/collects/tex2page/tex2page.ss
new file mode 100644
index 0000000000..47cf046662
--- /dev/null
+++ b/collects/tex2page/tex2page.ss
@@ -0,0 +1,11 @@
+(module tex2page mzscheme
+  (require (lib "etc.ss"))
+  (provide tex2page)
+  (define
+   tex2page
+   (lambda (f)
+     (parameterize
+       ((current-namespace (make-namespace)))
+       (namespace-require
+	(build-path (this-expression-source-directory) "tex2page-aux.ss"))
+       ((namespace-variable-value 'tex2page) f)))))
diff --git a/collects/texpict/balloon.ss b/collects/texpict/balloon.ss
new file mode 100644
index 0000000000..da10e2dac3
--- /dev/null
+++ b/collects/texpict/balloon.ss
@@ -0,0 +1,165 @@
+(module balloon mzscheme
+  (require "mrpict.ss"
+	   "utils.ss"
+	   (lib "mred.ss" "mred")
+           (lib "class.ss")
+           (lib "etc.ss")
+           (lib "math.ss"))
+  
+  (provide wrap-balloon
+	   place-balloon
+	   pin-balloon
+	   (rename mk-balloon balloon)
+           make-balloon
+	   balloon?
+           balloon-pict
+           balloon-point-x
+           balloon-point-y
+	   balloon-color)
+  
+  (define-struct balloon (pict point-x point-y))
+    
+  (define no-pen (find-pen "white" 1 'transparent))
+  (define no-brush (find-brush "white" 'transparent))
+  (define black-pen (find-pen "black"))
+
+  (define (series dc steps start-c end-c f pen? brush?)
+    (color-series dc steps #e0.5 start-c end-c f pen? brush?))
+    
+  (define (mk-balloon w h corner-radius spike-pos dx dy color)
+    (let ([dw (if (< corner-radius 1)
+                  (* corner-radius w)
+                  corner-radius)]
+          [dh (if (< corner-radius 1)
+                  (* corner-radius h)
+                  corner-radius)]
+          [dxbig (lambda (v) (if (> (abs dx) (abs dy))
+                                 v
+                                 0))]
+          [dybig (lambda (v) (if (<= (abs dx) (abs dy))
+                                 v
+                                 0))])
+      (let-values ([(x0 y0 x1 y1 xc yc mx0 mx1 my0 my1 mfx mfy)
+                    (case spike-pos
+                      [(w) (values 1 (/ (- h dh) 2)
+                                   1 (/ (+ h dh) 2)
+                                   1 (/ h 2)
+                                   0.5 1 0.5 -1
+                                   1 0)]
+                      [(nw) (values 0 dh
+                                    dw 0
+                                    0 0
+                                    1 -0.5 -1 0.5
+                                    (dxbig 1) (dybig 1))]
+                      [(e) (values (sub1 w) (/ (- h dh) 2)
+                                   (sub1 w) (/ (+ h dh) 2)
+                                   (sub1 w) (/ h 2)
+                                   -1 -1 1 -1
+                                   -1 0)]
+                      [(ne) (values (- w dw) 0
+                                    w dh
+                                    w 0
+                                    0.5 -1 0.5 -1
+                                    (dxbig -1) (dybig 1))]
+                      [(s) (values (/ (- w dw) 2) (sub1 h)
+                                   (/ (+ w dw) 2) (sub1 h)
+                                   (/ w 2) (sub1 h)
+                                   1 -1 -1 -1
+                                   0 -1)]
+                      [(n) (values (/ (- w dw) 2) 1
+                                   (/ (+ w dw) 2) 1
+                                   (/ w 2) 1
+                                   1 -1 1 1
+                                   0 1)]
+                      [(sw) (values 0 (- h dh)
+                                    dw (sub1 h)
+                                    0 (sub1 h)
+                                    0.5 -1 0.5 -1
+                                    (dxbig 1) (dybig -1))]
+                      [(se) (values (- w dw) h
+                                    w (- h dh)
+                                    w h
+                                    1 -1 1 -1
+                                    (dxbig -1) (dybig -1))])])
+        (let ([xf (+ xc dx)]
+              [yf (+ yc dy)]
+              [dark-color (scale-color #e0.6 color)])
+          (make-balloon
+           (dc (lambda (dc x y)
+                 (let ([b (send dc get-brush)]
+                       [p (send dc get-pen)]
+                       [draw-once
+                        (lambda (i rr?)
+                          (when rr?
+			    (send dc draw-rounded-rectangle 
+                                  (+ x (/ i 2)) (+ y (/ i 2))
+                                  (- w i) (- h i)
+                                  (if (and (< (* 2 corner-radius) (- w i))
+					   (< (* 2 corner-radius) (- h i)))
+				      corner-radius
+				      (/ (min (- w i) (- h i)) 2)))
+                            (let ([p (send dc get-pen)])
+                              (send dc set-pen no-pen)
+                              (send dc draw-polygon (list (make-object point% (+ x0 (* i mx0)) (+ y0 (* i my0)))
+                                                          (make-object point% (+ xf (* i mfx)) (+ yf (* i mfy)))
+                                                          (make-object point% (+ x1 (* i mx1)) (+ y1 (* i my1))))
+                                    x y)
+                              (send dc set-pen p)))
+                          (send dc draw-line (+ x x0 (* i mx0)) (+ y y0 (* i my0)) 
+                                (+ x xf (* i mfx)) (+ y yf (* i mfy)))
+                          (send dc draw-line (+ x x1 (* i mx1)) (+ y y1 (* i my1))
+                                (+ x xf (* i mfx)) (+ y yf (* i mfy))))])
+                   (series dc 5
+                           dark-color
+                           (if (string? color) (make-object color% color) color)
+                           (lambda (i) (draw-once i #t))
+                           #t #t)
+                   (send dc set-brush no-brush)
+                   (send dc set-pen (find-pen dark-color))
+                   (draw-once 0 #f)
+                   
+                   (send dc set-pen p)
+                   (send dc set-brush b)))
+               w h 0 0)
+           xf yf)))))
+
+  (define balloon-color (make-object color% 255 255 170))
+  
+  (define corner-size 32)
+
+  (define wrap-balloon
+    (opt-lambda (p corner dx dy [color balloon-color][c-rad corner-size])
+      (let ([b (mk-balloon (+ (pict-width p) (* 2 c-rad))
+			   (+ (pict-height p) c-rad)
+			   c-rad
+			   corner dx dy
+			   color)])
+	(make-balloon
+	 (cc-superimpose
+	  (balloon-pict b)
+	  p)
+	 (balloon-point-x b)
+	 (balloon-point-y b)))))
+  
+  (define (do-place-balloon flip-proc? balloon p to find-to)
+    (let-values ([(x y) (if (and (number? to) 
+				 (number? find-to)) 
+			    (values to (- (pict-height p)
+					  find-to))
+			    (if flip-proc?
+				(let-values ([(x y) (find-to p to)])
+				  (values x (- (pict-height p) y)))
+				(find-to p to)))])
+      (cons-picture
+       p
+       `((place ,(- x (balloon-point-x balloon))
+                ,(- y  ; up-side down!
+                    (- (pict-height (balloon-pict balloon))
+                       (balloon-point-y balloon)))
+                ,(balloon-pict balloon))))))
+
+  (define (place-balloon balloon p to find-to)
+    (do-place-balloon #f balloon p to find-to))
+
+  (define (pin-balloon balloon p to find-to)
+    (do-place-balloon #t balloon p to find-to)))
diff --git a/collects/texpict/code.ss b/collects/texpict/code.ss
new file mode 100644
index 0000000000..4962381615
--- /dev/null
+++ b/collects/texpict/code.ss
@@ -0,0 +1,332 @@
+(module code mzscheme
+  (require "mrpict.ss"
+	   (lib "class.ss")
+           (lib "mred.ss" "mred")
+	   (lib "unitsig.ss"))
+
+  (provide define-code code^ code-params^ code@)
+
+  (define-syntax (define-code stx)
+    (syntax-case stx ()
+      [(_ code typeset-code)
+       (syntax/loc stx
+	 (define-syntax (code stx)
+	   (define (stx->loc-s-expr v)
+	     (cond
+	      [(syntax? v)
+	       `(datum->syntax-object
+		 #f
+		 ,(syntax-case v (unsyntax)
+		    [(unsyntax e) #'e]
+		    [else (stx->loc-s-expr (syntax-e v))])
+		 (list 'code
+		       ,(syntax-line v)
+		       ,(syntax-column v)
+		       ,(syntax-position v)
+		       ,(syntax-span v)))]
+	      [(pair? v) `(cons ,(stx->loc-s-expr (car v))
+				,(stx->loc-s-expr (cdr v)))]
+	      [(vector? v) `(vector ,@(map
+				       stx->loc-s-expr
+				       (vector->list v)))]
+	      [(box? v) `(box ,(stx->loc-s-expr (unbox v)))]
+	      [(null? v) 'null]
+	      [else `(quote ,v)]))
+	   (define (cvt s)
+	     (datum->syntax-object #'here (stx->loc-s-expr s)))
+	   (syntax-case stx ()
+	     [(_ expr) #`(typeset-code #,(cvt #'expr))]
+	     [(_ expr (... ...))
+	      #`(typeset-code #,(cvt #'(code:line expr (... ...))))])))]))
+  
+  (define-signature code^
+    (typeset-code 
+     comment-color keyword-color id-color literal-color
+     code-align current-code-tt
+     current-keyword-list current-const-list code-colorize-enabled
+     current-comment-color current-keyword-color 
+     current-base-color current-id-color current-literal-color))
+
+  (define-signature code-params^
+    (current-font-size 
+     line-sep))
+
+  (define-syntax (define-computed stx)
+    (syntax-case stx ()
+      [(_ id v)
+       #'(begin
+	   (define (get-val) v)
+	   (define-syntax id
+	     (syntax-id-rules (set!)
+	       [(x (... ...)) ,illegal-use-of-once]
+	       [x (get-val)])))]))
+
+  (define code@
+    (unit/sig code^
+      (import code-params^)
+      
+      (define (default-tt s)
+	(text s `(bold . modern) (current-font-size)))
+
+      (define current-code-tt (make-parameter default-tt))
+
+      (define (tt s)
+	((current-code-tt) s))
+
+      (define (code-align p)
+	(lift (inset p 0 (pict-height p) 0 0) (pict-height p)))
+      
+      (define current-keyword-list 
+	(make-parameter '("define" "cond" "define-struct" "and" "or" "else"
+			  "lambda" "require" "provide"  "require-for-syntax"
+			  "define-syntax" "let" "letrec" "let*" "syntax-rules"
+			  "syntax-case" "set!" "begin" "quote-syntax" "module")))
+      (define current-const-list 
+	(make-parameter '("null")))
+
+      (define code-colorize-enabled
+	(make-parameter #t))
+
+      (define (maybe-colorize p c)
+	(if (code-colorize-enabled)
+	    (colorize p c)
+	    p))
+      
+      (define current-base-color (make-parameter "brown"))
+      (define keyword-color "black")
+      (define current-keyword-color (make-parameter keyword-color))
+      (define id-color "navy")
+      (define current-id-color (make-parameter id-color))
+      (define literal-color (make-object color% 51 135 39))
+      (define current-literal-color (make-parameter literal-color))
+      (define comment-color (current-base-color))
+      (define current-comment-color (make-parameter comment-color))
+      
+      (define-computed open-paren-p (colorize (tt "(") (current-base-color)))
+      (define-computed close-paren-p (colorize (tt ")") (current-base-color)))
+      (define-computed open-sq-p (colorize (tt "[") (current-base-color)))
+      (define-computed close-sq-p (colorize (tt "]") (current-base-color)))
+      (define-computed quote-p (colorize (tt "'") (current-literal-color)))
+      (define-computed syntax-p (colorize (tt "#'") (current-keyword-color)))
+      (define-computed semi-p (colorize (tt "; ") (current-comment-color)))
+      (define-computed open-paren/lit-p (colorize (tt "(") (current-literal-color)))
+      (define-computed close-paren/lit-p (colorize (tt ")") (current-literal-color)))
+      (define-computed open-paren/tmpl-p (colorize (tt "(") (current-comment-color)))
+      (define-computed close-paren/tmpl-p (colorize (tt ")") (current-comment-color)))
+
+      (define-computed dot-p (colorize (tt " . ") (current-base-color)))
+
+      (define (get-close mode)
+	(case mode
+	  [(literal) close-paren/lit-p]
+	  [(template comment) close-paren/tmpl-p]
+	  [(cond template-cond local) close-sq-p]
+	  [else close-paren-p]))
+
+      (define (get-open mode)
+	(case mode
+	  [(literal) open-paren/lit-p]
+	  [(template comment) open-paren/tmpl-p]
+	  [(contract line) (blank)]
+	  [(cond template-cond local) open-sq-p]
+	  [else open-paren-p]))
+      
+      (define (add-close p closes)
+	(cond
+	 [(null? closes) p]
+	 [(memq (car closes) '(contract line))
+	  (add-close p (cdr closes))]
+	 [else
+	  (add-close (hbl-append p (get-close (car closes)))
+		     (cdr closes))]))
+
+      (define (pad-left space p)
+	(if (= 0 space)
+	    p
+	    (htl-append (tt (make-string space #\space)) p)))
+
+      (define (pad-bottom space p)
+	(if (= 0 space)
+	    p
+	    (vl-append line-sep (tt " ") (pad-bottom (sub1 space) p))))
+
+      (define (colorize-id str mode)
+	(cond
+	 [(and ((string-length str) . > . 1)
+	       (char=? #\_ (string-ref str 0))
+	       (not (char=? #\_ (string-ref str 1))))
+	  (maybe-colorize (text (substring str 1) `(bold italic . modern) (current-font-size))
+			  (current-id-color))]
+	 [(regexp-match #rx"^(.+)_([0-9a-z]+)\\^([0-9a-z]+)$" str)
+	  => (lambda (m)
+	       (hbl-append (colorize-id (cadr m) mode)
+			   (cc-superimpose
+			    (text (caddr m) `(subscript bold . modern) (current-font-size))
+			    (text (cadddr m) `(superscript bold . modern) (current-font-size)))))]
+	 [(regexp-match #rx"^(.+)\\^([0-9a-z]+)_([0-9a-z]+)$" str)
+	  => (lambda (m)
+	       (hbl-append (colorize-id (cadr m) mode)
+			   (cc-superimpose
+			    (text (cadddr m) `(subscript bold . modern) (current-font-size))
+			    (text (caddr m) `(superscript bold . modern) (current-font-size)))))]
+	 [(regexp-match #rx"^(.+)\\^([0-9a-z]+)$" str)
+	  => (lambda (m)
+	       (hbl-append (colorize-id (cadr m) mode)
+			   (text (caddr m) `(superscript bold . modern) (current-font-size))))]
+	 [(regexp-match #rx"^(.+)_([0-9a-z]+)$" str)
+	  => (lambda (m)
+	       (hbl-append (colorize-id (cadr m) mode)
+			   (text (caddr m) `(subscript bold . modern) (current-font-size))))]
+	 [else
+	  (maybe-colorize
+	   (tt str)
+	   (cond
+	    [(eq? mode 'literal) (current-literal-color)]
+	    [(memq mode '(comment template)) (current-comment-color)]
+	    [(member str (current-keyword-list)) (current-keyword-color)]
+	    [(member str (current-const-list)) (current-literal-color)]
+	    [else (current-id-color)]))]))
+
+      (define (sub-mode mode)
+	(case mode
+	  [(line cond local) #f]
+	  [(template-cond) 'template]
+	  [(contract) 'comment]
+	  [else mode]))
+
+      (define (cond? s)
+	(memq (syntax-e s) '(cond))) ;  syntax-rules syntax-case)))
+
+      (define (local? s)
+	(memq (syntax-e s) '(local)))
+
+      (define (get-span stx)
+        (syntax-case stx (code:blank)
+          [code:blank 1]
+          [_ (or (syntax-span stx) 1)]))
+      
+      (define (add-semis p)
+	(let loop ([p p] [semis semi-p])
+	  (if ((pict-height p) . > . (+ (pict-height semis) 1))
+	      (loop p (vl-append line-sep semi-p semis))
+	      (htl-append semis p))))
+
+      (define (typeset-code stx)
+	(let loop ([stx stx][closes null][mode #f])
+	  (syntax-case* stx (quote syntax-unquote syntax
+				   code:contract code:comment code:line
+				   code:template code:blank $)
+			(lambda (a b) (eq? (syntax-e a) (syntax-e b)))
+	    [() (add-close (htl-append (get-open mode) (get-close mode))
+			   closes)]
+	    [code:blank (tt " ")]
+	    [$ (colorize-id "|" closes)]
+	    [(quote x)
+	     (htl-append quote-p (loop #'x closes 'literal))]
+	    [(syntax x)
+	     (htl-append syntax-p (loop #'x closes mode))]
+	    [(code:contract i ...)
+	     (add-semis (loop (datum->syntax-object #f (syntax->list #'(i ...)))
+			      closes 'contract))]
+	    [(code:line i ...)
+	     (loop (datum->syntax-object #f (syntax->list #'(i ...)))
+		   closes 'line)]
+	    [(code:comment s ...)
+	     (apply htl-append 
+		    semi-p 
+		    (map (lambda (s)
+			   (if (pict? (syntax-e s))
+			       (syntax-e s)
+			       (maybe-colorize (tt (syntax-e s)) (current-comment-color))))
+			 (syntax->list #'(s ...))))]
+	    [(code:template i)
+	     (add-semis (loop #'i closes 'template))]
+	    [(i ...)
+	     (let ([is (syntax->list #'(i ...))])
+	       ;; Convert each i to a picture, include close paren in last item:
+	       (let ([ips (let iloop ([is is][sub-mode (sub-mode mode)])
+			    (cond
+			     [(null? (cdr is)) (list (loop (car is) (cons mode closes) sub-mode))]
+			     [else (cons (loop (car is) null sub-mode)
+					 (iloop (cdr is) (cond
+							  [(cond? (car is))
+							   (if (eq? mode 'template)
+							       'template-cond
+							       'cond)]
+							  [(local? (car is))
+							   'local]
+							  [(eq? sub-mode 'local)
+							   #f]
+							  [else
+							   sub-mode])))]))])
+		 ;; Combine the parts:
+		 (let ([left (or (syntax-column stx) +inf.0)])
+		   (let loop ([stxs is]
+			      [ps ips]
+			      [line-so-far (get-open mode)]
+			      [col (+ left 1)]
+			      [line (syntax-line stx)]
+			      [always-space? #f]
+                              [col->width (make-hash-table 'equal)])
+		     (cond
+		      [(null? ps) (blank)]
+		      [(or (not line)
+			   (= line (or (syntax-line (car stxs)) line)))
+		       (let* ([space (if (syntax-column (car stxs))
+					 (inexact->exact
+					  (max (if always-space? 1 0) (- (syntax-column (car stxs)) col)))
+					 (if always-space? 1 0))]
+			      [p (htl-append
+				  line-so-far
+				  (pad-left space (car ps)))])
+			 (unless (equal? +inf.0 (+ space col))
+			   (hash-table-put! col->width 
+					    (+ space col) 
+					    (pict-width (htl-append line-so-far (pad-left space (blank))))))
+			 (if (null? (cdr stxs))
+			     p
+			     (loop (cdr stxs)
+				   (cdr ps)
+				   p
+				   (if (not (syntax-column (car stxs)))
+				       +inf.0
+				       (+ col space (get-span (car stxs))))
+				   (or line (syntax-line (car stxs)))
+				   #t
+                                   col->width)))]
+		      [else
+		       (vl-append
+			line-sep
+			line-so-far
+			(let* ([space (max 0 (- (or (syntax-column (car stxs)) 0) left))]
+			       [p 
+                                (let/ec k
+                                  (htl-append
+                                   (blank (hash-table-get col->width 
+                                                          (+ space left)
+                                                          (lambda ()
+                                                            (k (pad-left space (car ps)))))
+                                          0)
+                                   (car ps)))])
+			  (if (null? (cdr stxs))
+			      p
+			      (loop (cdr stxs)
+				    (cdr ps)
+				    p
+				    (+ left space (get-span (car stxs)))
+				    (or (syntax-line (car stxs)) (add1 line))
+				    #t
+                                    (make-hash-table 'equal)))))])))))]
+	    [id
+	     (identifier? stx)
+	     (add-close (colorize-id (symbol->string (syntax-e stx)) mode) closes)]
+	    [(a . b)
+	     (hbl-append open-paren-p (loop #'a null mode)
+			 dot-p (loop #'b (cons mode closes) mode))]
+	    [else
+	     (add-close (if (pict? (syntax-e stx))
+			    (syntax-e stx)
+			    (maybe-colorize (tt (format "~s" (syntax-e stx))) (current-literal-color)))
+			closes)])))
+      
+      )))
diff --git a/collects/texpict/doc.txt b/collects/texpict/doc.txt
new file mode 100644
index 0000000000..2132f2819e
--- /dev/null
+++ b/collects/texpict/doc.txt
@@ -0,0 +1,1131 @@
+
+_texpict_ is a MzScheme/MrEd library for creating pictures using a
+MrEd dc<%> (including post-script-dc% for _PostScript_ output) or
+_LaTeX_ as the back-end. The library was originally designed for LaTeX
+output, hence the name.
+
+Pictures are created as `pict' structures. Some procedures in the
+texpict library create new simple picts (e.g., `hline'). Others build
+new picts out of existing picts (e.g., `ht-append'). In the latter
+case, the embedded picts retain their identity, so that offset-finding
+functions (e.g., `lt-find') can find the offset of an embedded pict in
+a larger pict.
+
+A pict has the following structure:
+                w
+        ------------------
+       |                  | a  \
+       |------------------|    |
+       |                  |    | h
+       |------------------|    |
+       |                  | d  /
+        ------------------     
+
+For a single text line, d is descent below the baseline and
+a + d = h. For multiple text lines (created with vX-append), a is 
+ascent of top line above baseline and d is descent of bottom line,
+so a + d < h. Most other boxes have d = 0 and a = h.
+
+The size information for a pict is computed when the pict is
+created. This strategy supports programs that create new picts though
+arbitrarily complex computations on the size and shape of existing
+picts. However, it also means that a pict cannot be generated before
+its target device is known.
+
+A slightly different set of picture-making function are available for
+MrEd and LaTeX output. For example, the LaTeX set includes `tex',
+which accepts a string of arbitrary LaTeX code, and the MrEd set
+includes `dc', which accepts an arbitrary Scheme procedure for drawing
+to a dc<%>.
+
+When creating pictures with the obsolte `picture' or `cons-picture'
+functions, or when finding relative picture locations with the
+obsolete `find-lt', etc., the coordinate system is upside-down: (0, 0)
+is in the lower left.
+
+Slideshow output
+----------------
+
+Slideshow (see the "slideshow" collection) takes care of configuring
+texpict and rendering them to the screen or printer. In particular,
+the `slide' function takes any number of picts and assembles them into
+a slide.
+
+If you are using Slideshow, skip the following two sections. In the
+reference below, functions marked "MrEd only" or "MrEd only, in
+utils.ss" are available, and functions marked "LaTeX only" are not
+available.
+
+For non-Slideshow users, _utils.ss_ library provides additional
+drawing procedures for MrEd (not LaTeX) output. These are marked below
+with "MrEd only, in utils.ss".
+
+
+MrEd (or PostScript) output
+---------------------------
+
+The MrEd texpict function set is loaded by the _mrpict.ss_ library.
+The library is available in unit form via _mrpictr.ss_, which produces
+a unit importing mred^. The _mrpicts.ss_ library file defines the
+unit's signature.
+
+When creating a picture for a MrEd dc<%> that contains text, texpict
+needs a drawing context for measuring the text. Provide a dc<%> before
+constructing pictures via the `dc-for-text-size' parameter. The dc<%>
+should have the same text-measuring results as the destination dc<%>;
+in particular, use a post-script-dc% for preparing PostScript output,
+and a bitmap-dc% will work fine for bitmap-dc% or canvas% output.
+
+The `draw-pict' function takes a picture, a device context
+
+ ;; Example of producing PostScript output
+ (require (lib "mrpict.ss" "texpict"))
+
+ ;; Create PS context
+ (define ps-dc (make-object post-script-dc%))
+ (send ps-dc start-doc "Pict output")
+ (send ps-dc start-page)
+
+ ;; Install context for sizing
+ (dc-for-text-size ps-dc)
+
+ ;; Create the pict
+ (define p ...)
+
+ ;; Output pict
+ (draw-pict p ps-dc 0 0)
+ (send ps-dc end-page)
+ (send ps-dc end-doc)
+
+If the output dc<%> has a "user scale", it is not reflected in the
+size information reported for pictures. This is consistent with MrEd's
+usual policy for reporting size information.
+
+LaTeX output
+------------
+
+The LaTeX texpict function set is loaded by the _texpict.ss_ library.
+The library is available in unit form via _texpictr.ss_, which
+produces a unit with no imports. The _texpicts.ss_ library file
+defines the unit's signature.
+
+To create a LaTeX picture, assemble a pict and then
+call `pict->string'. This string can be `display'ed to obtain the
+LaTeX code, which is usually of the form:
+   \begin{picture} ... \end{picture}
+When using colors, the output may be of the form:
+   \special{color push ...} ... \special{color pop ...}
+so consider putting the output in an \hbox{} when using color.
+
+The `tex' function creates a pict given an arbitrary LaTeX
+expression as a string. Initially, `tex' guess at the size of the
+resulting pict. (It always guesses 10 x 10.) The LaTeX expression
+generated for a `tex' pict causes information to be written to an
+auxiliary file when LaTeX evaluates the expression. If you use
+`tex' boxes, then:
+
+   * Use the package "mztp.sty" at the start of your LaTeX
+     document "X.tex".
+   * In the MzScheme code creating `tex' picts, call
+     (read-in-sizes "X.mztp") before calling `tex'.
+   * Run the texpict-LaTeX cycle twice to get properly
+     draw pictures.
+
+texpict keys `tex' size information on the exact LaTeX expression
+provided to `tex'. If you use a single `tex' pict in two different
+contexts where the provided expression produces differently sized
+output, texpict will not distinguish the uses (and the size of the
+first instance of the pict will be used) by default. The
+`serialize-tex-picts' parameter can solve this problem, but
+serialization requires that the output is built in exactly the same
+order every time, and generally requires more texpict-tex cycles to
+reach a fixed point after a small change to the output. The
+`tex-series-prefix' parameter may be used to explicitly tag `tex'
+sequences in different contexts.
+
+For LaTeX output, all positions and sizes must be specified as exact
+integers, but texpict does not check that exact integers are supplied.
+
+------------------------------------------------------------
+Structures
+------------------------------------------------------------
+
+A pict is an instance of the `pict' structure type:
+
+> struct:pict :: (struct pict (draw width height ascent descent children panbox))
+
+The `children' field is a list of `child' structures:
+
+> struct:child :: (struct child (pict dx dy sx sy))
+
+------------------------------------------------------------
+Procedures
+------------------------------------------------------------
+
+Basic Constructors:
+-------------------
+
+>  (dc draw-proc w h) -> pict
+>  (dc draw-proc w h a d) -> pict
+       where draw proc is (dc x y -> void)
+
+   Creates an arbitrary self-rendering pict.  The arguments to the
+   rendering procedure will be a device context and top-left
+   location for drawing.
+  
+   When the rendering procedure is called, the current pen and
+   brush will be solid and in the pict's color (and linewidth), and
+   the scale and offset of the dc will be set. The text mode will
+   be transparent, but the font and colors are not guaranteed to be
+   anything in particular.
+      [MrEd only]
+
+>  (blank)  -> pict
+>  (blank s)  -> pict   ; s is side length of square
+>  (blank w h)  -> pict
+>  (blank w a d)  -> pict  ; => h = a + d
+>  (blank w g a d)  -> pict
+
+   Creates an empty pict
+
+>  (text string [text-style null] [size 12] [angle 0]) -> pict
+
+   Creates a pict from a string, style, size, and rotation.
+    A _text-style_ is one of
+      null (the default, same a 'default),
+      a font% object,
+      a font family symbol (e.g., 'roman),
+      a font face string (e.g., "-adobe-symbol"),
+      `(bold . ,text-style),
+      `(italic . ,text-style), 
+      `(subscript . ,text-style), 
+      `(superscript . ,text-style),
+      `(combine . ,text-style), or
+      `(no-combine . ,text-style).
+    A size is an exact number in [1, 255] in pixels; the
+     default size is 12, but the size is ignored if
+     a font% object is provided in the text-style.
+    The default rotation is 0; for a non-zero rotation,
+     the pict covers the rotated text, and the descent
+     is zero and the ascent is the height
+    By default, text drawing can combine characters (to
+     form ligatures, for kerning, etc.), unless the
+     base text-style is 'modern. The 'combine text-style symbol
+     overrides the default to allow combining, and the
+     'no-combine text-style symbol overrides the default to
+     disable combining; if both 'combine and 'no-combine
+     are specified, the first one takes precedence
+      [MrEd only]
+
+>  (caps-text string [text-style null] [size 12] [angle 0]) -> pict
+
+   Same as `text', but use small caps:
+
+>  (hline w h) -> pict
+>  (dash-hline w h seg-length) -> pict ; default seg-length is 5
+>  (vline w h) -> pict
+>  (dash-vline w h seg-length) -> pict ; default seg-length is 5
+
+   To draw other kinds of lines, use `picture' or `cons-picture'
+
+>  (frame pict) -> pict
+>  (dash-frame pict seg-length) -> pict ; default seg-length is 5
+>  (oval pict) -> pict
+>  (oval/radius pict r) -> pict ; r is radius of corners
+
+>  (big-circle diameter) -> pict
+
+   Creates a fairly round circle using four splines (intended
+   for LaTeX output)
+
+>  (color-frame pict color-string) -> pict
+>  (color-frame pict color-string line-w) -> pict
+>  (color-dash-frame pict seg-length color-string) -> pict
+>  (color-dash-frame pict seg-length color-string line-w) -> pict
+
+   Like `frame' and `dash-frame', but the frame gets a color and
+   optional line width
+      [MrEd only, in utils.ss]
+
+>  (round-frame pict) -> pict
+>  (color-round-frame pict color-string) -> pict
+>  (color-round-frame pict color-string line-w) -> pict
+
+   Rounded frames
+      [MrEd only, in utils.ss]
+
+>  (circle diameter) -> pict
+>  (disk diameter) -> pict
+
+   Unfilled and filled circles; works for all sizes.
+      [MrEd only, in utils.ss]
+
+>  (ellipse width height) -> pict
+>  (filled-ellipse width height) -> pict
+
+   Unfilled and filled ellipses; works for all sizes.
+      [MrEd only, in utils.ss]
+
+>  (rectangle width height) -> pict
+>  (filled-rectangle width height) -> pict
+
+   Unfilled and filled rectangle; works for all sizes.
+      [MrEd only, in utils.ss]
+
+>  (rounded-rectangle width height [corner]) -> pict
+>  (filled-rounded-rectangle width height [corner]) -> pict
+
+   Unfilled and filled rounded rectangle; works for all sizes.
+      [MrEd only, in utils.ss]
+
+>  (arrow size radians) -> pict
+>  (arrowhead size radians) -> pict
+
+   Creates an arrow or arrowhead in the specific direction
+    within a size x size pict. (Points on the arrow may
+    extend slightly beyond the box.)
+      [MrEd only, in utils.ss]
+
+>  (pt-line dx dy size) -> pict
+>  (pt-arrow-line dx dy size) -> pict
+>  (pt-arrows-line dx dy size) -> pict
+
+   Creates a line [with arrowhead(s)] as a 0-sized picture suitable
+   for use with `pin-over'. The 0-sized picture contains the starting
+   point.
+      [MrEd only, in utils.ss]
+
+>  (bitmap filename) -> pict
+>  (bitmap bitmap%-object) -> pict
+
+   Loads a bitmap into a pict; if the bitmap is not ok,
+    the result is a box containing the words "bitmap failed"
+      [MrEd only, in utils.ss]
+
+>  (cloud w h [color-string "gray"]) -> pict
+
+   Fluffy cloud.
+      [MrEd only, in utils.ss]
+
+>  (file-icon w h gray [fancy? ...]) -> pict
+
+   Creates a MacOS-like file icon, optionally shaded.
+   Default for `fancy?': gray = #f -> white
+                         gray = #t -> default color
+                         gray = color/string -> uses color
+
+      [MrEd only, in utils.ss]
+
+>  (jack-o-lantern size [pumpkin-color "orange"] [face-color "black"]) -> pict
+
+   Creates a jack-o-lantern; use the same pumpkin-color and
+   face color to get a plain pumpkin. The size is the width.
+      [MrEd only, in utils.ss]
+
+>  (angel-wing w h left?) -> pict
+
+   Creates an angel wing, left or right, or any size.
+   The color and pen width for drawing the wing outline is the
+   current one.
+      [MrEd only, in utils.ss]
+
+
+>  (standard-fish w h [direction 'left] [color "blue"] 
+                      [eye-color "black"] [open-mouth? #t]) -> pict
+
+   Creates a fish, swimming either 'left or 'right.
+      [MrEd only, in utils.ss]
+
+
+Combiners:
+----------
+
+>  (vl-append [d 0] pict ...) -> pict ; d units between each picture
+>  (vc-append [d 0] pict ...) -> pict
+>  (vr-append [d 0] pict ...) -> pict
+>  (ht-append [d 0] pict ...) -> pict
+>  (hc-append [d 0] pict ...) -> pict
+>  (hb-append [d 0] pict ...) -> pict
+>  (htl-append [d 0] pict ...) -> pict  ; align bottoms of ascents
+>  (hbl-append [d 0] pict ...) -> pict  ; align tops of descents (normal text alignment)
+
+   Make a new picture as a column (vX-append) or row (hX-append)
+   of other pictures. Different procedures align pictures in the
+   orthogonal direction in different ways; e.g, vl-append left-aligns
+   all of the pictures. A specified amount of space is inserted
+   between each pair of pictures in making the column or row.
+   The descent of the result corresponds to baseline that is lowest
+   in the result among all of the picts' descent-specified
+   baselines; similarly, the ascent of the result corresponds to
+   the highest ascent-specified baseline.
+
+>  (lt-superimpose pict ...) -> pict
+>  (lb-superimpose pict ...) -> pict
+>  (lc-superimpose pict ...) -> pict
+>  (ltl-superimpose pict ...) -> pict
+>  (lbl-superimpose pict ...) -> pict
+>  (rt-superimpose pict ...) -> pict
+>  (rb-superimpose pict ...) -> pict
+>  (rc-superimpose pict ...) -> pict
+>  (rtl-superimpose pict ...) -> pict
+>  (rbl-superimpose pict ...) -> pict
+>  (ct-superimpose pict ...) -> pict
+>  (cb-superimpose pict ...) -> pict
+>  (cc-superimpose pict ...) -> pict
+>  (ctl-superimpose pict ...) -> pict
+>  (cbl-superimpose pict ...) -> pict
+
+   Make a new picture by superimposing a set of pictures. The
+   alignment indicators are essentially as above: horizontal
+   alignment then vertical alignment. The descent and the ascent
+   of the result is also computed as above (i.e., lowest descent
+   and highest ascent).
+
+>  (pin-over pict dx dy pict) -> pict
+>  (pin-over pict sub-pict find-proc pict) -> pict
+
+   Creates a pict with the same bounding box, ascent, and descent
+   as the initial argument, but with the second pict placed on top.
+   The dx and dy argument specify how far right and down the second
+   pict's corner is from the first pict's corner.
+   Alternately, the sub-pict and procedure arguments find a point
+   in the initial pict for the second pict's corner. The procedure
+   should be like lt-find.
+
+>  (pin-under pict dx dy pict) -> pict
+>  (pin-under pict sub-pict find-proc pict) -> pict
+
+   Like pin-over, but the second pict is drawn first, then the
+   initial pict.
+
+>  (table ncols pict-list col-aligns row-aligns col-seps row-seps) -> pict
+
+   Make a table given a list of picts. The list is a
+   concatenation of rows (which means that a Scheme `list' call
+   can be formatted to reflect the shape of the output table).
+  
+   The col-aligns, row-aligns, col-seps, and row-seps arguments are
+   `lists' specifying the row and columns alignments separation
+   between rows and columns.  For C columns and R rows, the first
+   two should have C and R superimpose procedures, and the last two
+   should have C - 1 and R - 1 numbers, respectively. The lists can
+   be improper (e.g. just a number), in which case the non-pair cdr
+   is used as the value for all remaining list items that were
+   expected. The alignment procedures are used to superimpose all
+   of the cells in a column or row; this superimposition determines
+   the total width or height of the column or row, and also
+   determines the horizontal or vertical placement of each cell in
+   the column or row.
+
+>  (record pict pict ...) -> pict
+
+   Make a UML-like record picture, where the
+   first argument is the title and the rest are fields.
+
+
+Drawing Adjusters:
+------------------
+
+>  (scale pict factor) -> pict
+>  (scale pict x-factor y-factor) -> pict
+
+   Scales a pict (by adjusting the destination dc<%>'s
+   scale while drawing the pict.
+      [MrEd only, in utils.ss]
+
+>  (ghost pict) -> pict
+
+   Make a container picture that doesn't draw the child picture,
+   but uses the child's size
+
+>  (thick pict) -> pict
+>  (thin pict) -> pict
+
+   Set the line thickness for a picture. For MrEd output,
+   selects between a pen width of 0 or 1.
+
+>  (linewidth w pict) -> pict
+
+   Set a specific pen width for drawing.
+      [MrEd only]
+
+>  (colorize pict color-string) -> pict
+
+   Apply a color to a picture. If the given picture has a colorized
+   sub-picture, the color of the sub-picture is not affected.
+   Be sure to use the LaTeX package `colordvi'.
+
+>  (colorize pict color%) -> pict
+
+   Same as above, except uses the color% object instead of a string
+   to indicate the color of the pict.
+      [MrEd only]
+
+>  (colorize pict num-list) -> pict
+
+   Same as above, except the list of three numbers indicate the
+   red, green, and blue components of the color.
+      [MrEd only]
+
+>  (clip pict)
+
+   Clips a pict to its bounding box.
+      [MrEd only, in utils.ss]
+
+>  (scale/improve-new-text pict-expr s-expr)
+>  (scale/improve-new-text pict-expr sx-expr sy-expr)
+
+   Syntax that is like `scale', but also sets
+   `current-expected-text-scale' while evaluating
+   `pict-expr':
+      [MrEd only, in utils.ss]
+
+>  (inset/clip pict amt)
+>  (inset/clip pict h-amt v-amt)
+>  (inset/clip pict l-amt t-amt r-amt b-amt)
+
+   Insets and clips the pict's drawing to its
+   bounding box. (Usually the inset amounts are negative.)
+      [MrEd only, in utils.ss]
+
+
+Bounding-Box Adjusters:
+-----------------------
+
+>  (inset pict i) -> pict
+>  (inset pict hi vi) -> pict
+>  (inset pict li ti ri bi) -> pict
+
+   Extends picture size by adding the give amounts to the
+    corersponding side; ascent and descent are extended, too.
+
+>  (clip-descent pict) -> pict
+
+   Truncates picture, removing descent part.
+
+>  (lift pict n) -> pict
+
+   Lifts picture relative to its baseline, extending
+    the height if necessary
+
+>  (drop pict n) -> pict
+
+   Drops picture below its ascent line, extending
+    the height if necessary
+
+>  (baseless pict) -> pict
+
+   Makes the descent 0 and the ascent the height
+
+>  (refocus pict pict) -> pict
+
+   Given a pict and an embedded pict, shifts the
+    given pict's bounding box to that of the
+    embedded pict
+
+>  (panorama pict) -> pict
+
+   Given a pict, shifts the given pict's bounding box
+    to enclose the bounding boxes of all sub-picts
+    (laundered or not)
+
+
+Finders:
+--------
+
+>  (lt-find pict pict-path) -> dx dy
+>  (lc-find pict pict-path) -> dx dy
+>  (lb-find pict pict-path) -> dx dy
+>  (ltl-find pict pict-path) -> dx dy
+>  (lbl-find pict pict-path) -> dx dy
+>  (rt-find pict pict-path) -> dx dy
+>  (rc-find pict pict-path) -> dx dy
+>  (rb-find pict pict-path) -> dx dy
+>  (rtl-find pict pict-path) -> dx dy
+>  (rbl-find pict pict-path) -> dx dy
+>  (ct-find pict pict-path) -> dx dy
+>  (cc-find pict pict-path) -> dx dy
+>  (cb-find pict pict-path) -> dx dy
+>  (ctl-find pict pict-path) -> dx dy
+>  (cbl-find pict pict-path) -> dx dy
+
+   Finds an embedded pictur.
+   A pict-path is either
+    pict
+    non-empty-pict-path-list
+
+>  (launder pict) -> pict
+
+   Creates a new pict that hides the given pict from XX-find
+
+
+Other constructors:
+-------------------
+
+>  pin-line                ; pict 
+                           ; src-pict (pict pict -> x y)
+                           ; dest-pict (pict pict -> x y)
+                           ; [line-w [color-string [lines-under?]]]
+                           ; -> pict
+>  pin-arrow-line          ; arrow-size pict 
+                           ; src-pict (pict pict -> x y)
+                           ; dest-pict (pict pict -> x y)
+                           ; [line-w [color-string [lines-under?]]]
+                           ; -> pict
+>  pin-arrows-line         ; arrow-size pict 
+                           ; src-pict (pict pict -> x y)
+                           ; dest-pict (pict pict -> x y)
+                           ; [line-w [color-string [lines-under?]]] 
+                           ; -> pict
+
+   Adds a line or line-with-arrows onto a pict, using
+   one of the sub-pict-finding functions (e.g., `lt-find')
+   to extract the source and destination of the line.
+      [MrEd only, in utils.ss]
+
+>  (hyperlinkize pict) -> pict
+
+   Adds an underline and blue color. The pict's
+    height and descent are extended.
+      [MrEd only, in utils.ss]
+
+
+Renderers:
+----------
+
+>  (show-pict pict [w #f] [h #f]) -> void
+
+   Opens a frame that displays the pict.
+   The frame adds one method: 
+     set-pict : pict -> void
+   that changes the visible pict.
+   the optional w and h arguments must
+   be either numbers of #f. If numbers,
+   the window is at least that size
+   and the pict is drawn in the middle of
+   the window.
+      [MrEd only]
+
+>  (draw-pict pict dc x y) -> void
+
+   Draw a pict to a dc<%>
+      [MrEd only]
+
+>  (make-pict-drawer pict) -> ((dc x y) -> void)
+
+   Generate a pict-drawer procedure for multiple renderings of a
+   pict (much faster than repeated calls to draw-pict)
+      [MrEd only]
+
+
+MrEd DC Helpers:
+----------------
+
+>  (scale-color factor string-or-color%) -> color%
+
+   Scales a color, making it brighter or darker. If the
+   factor is < 1, the color is darkened by multiplying
+   the RGB components by the factor. If the factor is > 1,
+   the color is lightened by dividing the gap between
+   the RGB components and 255 by the factor.
+      [MrEd only, in utils.ss]
+
+>  (find-pen string-or-color% [size 1] [style 'solid]) -> pen%
+
+   Gets an immutable pen% from the-pen-list
+      [MrEd only, in utils.ss]
+
+>  (find-brush string-or-color% [style 'solid]) -> brush%
+
+   Gets an immutable brush from the-brush-list
+      [MrEd only, in utils.ss]
+
+>  color-series            ; dc<%> num-steps step-delta
+                           ;  start-color-or-string%
+                           ;  end-color-or-string%
+                           ;  (num -> any)
+                           ;  set-pen? set-brush? -> void
+
+   Calls a drawing function multiple times, gradually
+   changing the pen/brush color for each call. The
+   step count and step delta should be exact numbers;
+   the procedure is called with each number from 0 to 
+   the step count, using the step delta. For the first
+   call, the current pen and/or brush color matches the
+   starting color; for the last call, it matches the
+   ending color; and for intermediate calls, the color
+   is an intermediate color.
+      [MrEd only, in utils.ss]
+
+------------------------------------------------------------
+Additional LaTex Utilities
+------------------------------------------------------------
+
+>  (tex string) -> pict
+>  (text-line string) -> pict
+>  (text-line/phantom string string) -> pict
+>  (tex-paragraph w string ['top|'bottom]) -> pict
+
+   Create picts from LaTeX code
+      [LaTeX only]
+
+>  (left-brace h) -> pict
+>  (right-brace h) -> pict
+>  (left-delimit str h) -> pict
+>  (right-delimit str h) -> pict
+>  (middle-delimit str h) -> pict
+>  (top-brace w) -> pict
+>  (bottom-brace w) -> pict
+
+   Delimiters to go around height h (result is taller than h;
+    try h/2)
+   Delimiter to go around width w (result is w wide)
+      [LaTeX only]
+
+>  (pict->string pict) -> string
+
+   Generate the LaTeX code for a pict.
+      [LaTeX only]
+
+------------------------------------------------------------
+MrEd and LaTex Setup
+------------------------------------------------------------
+
+>  dc-for-text-size
+
+   Parameter specifying the dc<%> to use for measuring text.
+   Default: #f
+      [MrEd only]
+
+>  current-expected-text-scale ; -> (list num num)
+                               ; (list num num) -> void
+
+   A parameter used to refine text measurements to better
+   match an expected scaling of the image.
+   Default: 1
+      [MrEd only]
+
+>  (read-in-sizes string) -> void
+
+   Load `tex' pict size information generated by a LaTeX run.
+      [LaTeX only]
+
+>  output-measure-commands
+
+   Parameter specifying whether to produce LaTeX commands to
+   produce size information for a future run.
+   Default: #t
+      [LaTeX only]
+
+>  using-pict2e-package
+
+   Parameter specifying whether the `pict2e' package is active.
+   Default: #f
+      [LaTeX only]
+
+>  draw-bezier-lines
+
+   Parameter specifying whether to draw precise lines for `connect'
+   with bezier curves. The value is a Boolean or a procedure that
+   takes a length and returns the number of points to use.
+   Default: #f
+      [LaTeX only]
+
+>  use-old-connect
+
+   Parameter to use the old implementation of `connect'.
+   Default: #f
+      [LaTeX only]
+
+>  tex-series-prefix
+
+   Parameter specifying a string to embed in the sizing key for a
+   pict created with `tex'. The prefix is applied when the `tex'
+   pict is created. Turning on the `serialize-tex-picts' parameter
+   effectively generates a new series prefix for every `tex' pict.
+   Default: #f
+      [LaTeX only]
+   
+>  serialize-tex-picts
+
+   Parameter specifying whether to assign serial numbers to
+   `tex'-generated strings for sizing purposes. Serial numbers
+   allow the same tex string to be used in multiple contexts, but
+   the output must be built in the same order every time.
+   Default: #f
+      [LaTeX only]
+
+>  black-and-white
+
+   Parameter specifying whether to draw in B&W or color (when
+   `colorize' is used).
+   Default: #f
+
+------------------------------------------------------------
+Obsolete functions
+------------------------------------------------------------
+
+>  (picture w h command-list) -> pict
+
+   Obsolte: describes a picture with low-level commands; see below.
+
+>  (cons-picture pict command-list) -> pict
+>  (cons-picture* pict command-list) -> pict
+
+   Create a new picture by `cons'ing drawing commands onto
+   an existing picture. `cons-picture*' maintains the pict's
+   descent and ascent.
+
+>  (cons-colorized-picture pict color-string command-list) -> pict
+
+   Like `cons-picture', but the newly consed commands get a
+   color
+
+>  (place-over pict dx dy pict) -> pict
+>  (place-over pict sub-pict find-proc pict) -> pict
+
+   Obsolete versions of `pin-over', where a procedure is expected
+   to return a flipped y value, like find-lt.
+
+>  (place-under pict dx dy pict) -> pict
+>  (place-under pict sub-pict find-proc pict) -> pict
+
+   Like `place-over', but the second pict is drawn first, then the
+   initial pict.
+
+>  find-lt
+>  find-lc
+>  find-lb
+>  find-ltl
+>  find-lbl
+>  find-ct
+>  find-cc
+>  find-cb
+>  find-ctl
+>  find-cbl
+>  find-rt
+>  find-rc
+>  find-rb
+>  find-rtl
+>  find-rbl
+
+   Obsolete versions of ...-find, where the result y is flipped
+
+>  (arrow-line dx dy size) -> pict
+>  (arrows-line dx dy size) -> pict
+
+   Obsolte versions of the `line+arrow[s]' functions,
+   where the vertical delta is negated.
+      [MrEd only, in utils.ss]
+
+>  add-line
+>  add-arrow-line
+>  add-arrows-line
+
+   Obsolete variants of the pin-...line functions
+   where the pict-finding functions are like `find-lt' (i.e.,
+   the y result is flipped)
+      [MrEd only, in utils.ss]
+
+------------------------------------------------------------
+Obsolete: Commands, Putables, and Drawables
+------------------------------------------------------------
+
+Commands:
+---------
+
+These commands use LaTeX-style coordinates: bottom-left
+is (0, 0).
+
+The varieties of `connect' commands are for LaTeX, where
+lines are constrained to a small set of allowed angles.
+For MrEd, all of the commands below act the same, and produce
+lines with precisely the requested angle.
+
+A command is one of the following:
+   `(place ,x ,y ,pict)
+   `(put ,x ,y ,putable)
+   
+
+   `(connect ,x1 ,y1 ,x2 ,y2 ,bool)         ; line or vector; bool => vector;
+                                            ;   from (x1,y1) to (~x2,~y2)
+                                            ;   as close as possible
+                                            ;   (synonym for connect~xy with 
+                                            ;   an infinite tolerance when
+                                            ;   draw-bezier-lines is #f, or
+                                            ;   for curve when draw-bezier-lines
+                                            ;   is #t)
+   `(dconnect ,x ,y ,dx ,dy ,bool)          ; line or vector; bool => vector;
+                                            ;   from (x,y) to (~(x+dx),~(y+dy))
+                                            ;   as close as possible (uses
+                                            ;   connect)
+   `(connect~y ,tol ,x1 ,y2 ,x2 ,y2 ,bool)  ; sequence of lines from
+                                            ;  (~x1,~y1) to (~x2,~y2) where
+                                            ;  either: 
+                                            ;    1) ~x2=x2 and |~y2-y2|<tol
+                                            ;    2) ~y2=y2 and |~x2-x2|<tol and 
+                                            ;       the final line is vertical
+   `(connect~x ,tol ,x1 ,y2 ,x2 ,y2 ,bool)  ; like connect~y, but either:
+                                            ;    1) ~x2=x2 and |~y2-y2|<tol
+                                            ;       the final line is horizontal
+                                            ;    2) ~y2=y2 and |~x2-x2|<tol
+   `(connect~xy ,tol ,x1 ,y2 ,x2 ,y2 ,bool) ; like connect~y, but either:
+                                            ;    1) ~x2=x2 and |~y2-y2|<tol
+                                            ;       the final line is horizontal
+                                            ;    2) ~y2=y2 and |~x2-x2|<tol
+                                            ;       the final line is vertical
+                                            ;    3) |(x2,y2)-(~x2,~y2)|<tol
+   `(curve ,x1 ,y1 ,x2 ,y2 ,xc ,yc ,d)      ; bezier curve; d is optional density
+                                            ;  for LaTeX; the default d is 1.0
+
+  [Notes: curve can generate more precise lines than connect~, but it usually 
+          requires more LaTeX memory.]
+
+Putables:
+---------
+
+A putable is one of the following:
+   draw
+   `(line ,dh ,dv ,hlen)       ; LaTeX-style line - slope and size is limited
+   `(vector ,dh ,dv ,hlen)     ; LaTeX-style vector - slope and size is limited
+   `(circle ,d)                ; LaTeX-style circle - size is limited
+   `(circle* ,d)
+   `(frame ,draw)
+   `(colorbox ,color-str ,draw)
+   `(oval ,str ,w ,h)  ; str is portion a la LaTeX: e.g., "" or "[bl]";
+                       ;  the oval is centered at the put position, instead of
+                       ;  bl-aligned
+   ; plus some more undocumented ones...
+
+Draws:
+------
+
+A draw is one of the following:
+   string ; latex string
+   `(picture ,w ,h ,@command-list)
+   `(color ,color-string ,draw)
+   `(thickness ,thickness ,draw) ; thickness is thicklines or thinlines
+
+------------------------------------------------------------
+_slideshow-run.ss_ and _slideshow.ss_
+------------------------------------------------------------
+
+The "slideshow-run.ss" and "slideshow.ss" modules simply re-export
+`(lib "run.ss" "slideshow")' and `(lib "slideshow.ss" "slideshow")'
+for backward compatibility.
+
+See the "slideshow" collection for more details.
+
+------------------------------------------------------------
+_balloon.ss_
+------------------------------------------------------------
+
+The "balloon.ss" module produce functions for creating and placing
+cartoon-speech balloons.
+
+> (wrap-balloon pict spike-sym dx dy [color corner-radius])
+
+Superimposes `pict' on top of a balloon that wraps it.
+
+The `spike-sym' indicates the corner from which a spike protrudes from
+the balloon (i.e., the spike that points to whatever the balloon is
+about). It's one of 'n, 's, 'e, 'w, 'ne, 'se, 'sw, or 'nw.
+
+The `dx' and `dy' arguments specify how far the spike should protrude.
+For a 'w spike, `dx' should be negative, etc.
+
+The `color' argument is the background color for the balloon. It
+defaults to `balloon-color'.
+
+The result is a balloon, not a pict. The `balloon-pict' function
+extracts a pict whose bounding box does not include the spike, but
+includes the rest of the image. (The `balloon-point-x' and
+`balloon-point-y' functions specify the location of the spike point.)
+
+> (pin-balloon balloon pict to-pict find-to-pos)
+> (pin-balloon balloon pict x y)
+
+Superimposes the pict in `balloon' onto `pict' to produce a new
+pict. The balloon is positioned so that its spike points to the
+location specified by either `x' and `y' (numbers) or `to-pict' and
+`find-to-pos'. In the latter case, `to-pict' is a sub-pict in `pict'
+and `find-to-pos' is a function like `lt-find'.
+
+The resulting pict has the same bounding box, descent, and ascent as
+`pict', even if the balloon extends beyond the bounding box.
+
+> (place-balloon balloon pict to-pict find-to-pos)
+> (place-balloon balloon pict x y)
+
+Obsolete version of `pin-balloon' where `find-to-pos' is a function
+like `find-lt' (i.e., the y result is flipped).
+
+> (balloon w h corner-radius spike-pos dx dy color)
+
+Creates a balloon, much like `wrap-balloon' except that the balloon's
+width is `w' and its height is `h'. The `corner-radius' argument
+specifies the radius for the balloon's rounded corners; if the radius
+is positive, the value is used as the radius of the rounded corner,
+but if radius is negative, the absolute value is used as the the
+proportion of the smallest dimension of the balloon.
+
+> (make-balloon pict num num) -> balloon
+> (balloon-pict balloon)      -> pict
+> (balloon-point-x balloon)   -> num
+> (balloon-point-y balloon)   -> num
+> (balloon? v)                -> bool
+
+A balloon value encapsulates a pict and the position of the balloon's
+spike relative to the balloon's top-left corner.
+
+> balloon-color
+
+The default background color for a balloon.
+
+------------------------------------------------------------
+_face.ss_
+------------------------------------------------------------
+
+The "face.ss" module provides functions for a kind of
+Mr.-Potatohead-style face library. The _face-demo.ss_ module
+implements an interactive browser for face configurations.
+
+> default-face-color - orange
+
+> (face mood-symbol [color]) - returns a pict a pre-configured face
+  with the given base color. The built-in configurations, selected by
+  mood-symbol, are as follows:
+
+    'unhappy - (face* 'none 'plain #t default-face-color 6)
+    'sortof-unhappy - (face* 'worried 'grimace #t default-face-color 6)
+    'sortof-happy - (face* 'worried 'medium #f default-face-color 6)
+    'happy - (face* 'none 'plain #f default-face-color 6)
+    'happier - (face* 'none 'large #f default-face-color 3)
+    'embarrassed - (face* 'worried 'medium #f default-face-color 3)
+    'badly-embarrassed - (face* 'worried 'medium #t default-face-color 3)
+    'unhappier - (face* 'normal 'large #t default-face-color 3)
+    'happiest - (face* 'normal 'huge #f default-face-color 0 -3)
+    'unhappiest - (face* 'normal 'huge #t default-face-color 0 -3)
+    'mad - (face* 'angry 'grimace #t default-face-color 0)
+    'mean - (face* 'angry 'narrow #f default-face-color 0)
+
+> (face* eyebrow-kind mouth-kind frown? [color eye-inset eyebrow-dy pupil-dx pupil-dy])
+  - returns a pict for a configured face:
+
+      - eyebrow-kind is one of 'none, 'normal, 'worried, or 'angry
+      - mouth-kind is one of 'plain, 'narrow, 'medium, 'large, 'huge, 
+                             'grimace, or 'tongue
+      - frown? determines whether the mouth is up or down
+      - color is either a color string or a color% object
+      - eye-inset adjusts the eye size; recommend values: between 0 and 10
+      - eyebrow-dy adjusts the eyebrows; recommend values: between -5 and 5
+      - pupil-dx adjusts the pupil; recommend values: between -10 and 10
+      - pupil-dy adjusts the pupil; recommend values: between -15 and 15
+
+------------------------------------------------------------
+_code.ss_
+------------------------------------------------------------
+
+The "code.ss" module provides a unit for typesetting Scheme code a la
+SlaTeX.
+
+The _code@_ signed unit imports _code-params^_ and exports _code^_.
+The _code-params^_ signature contains two elements:
+
+   current-font-size - a thunk to obtain the font size to use for
+                       text
+   line-sep - an integer for the amount of space (in drawing units) to
+              insert between lines of text
+
+The _code^_ unit supplies the following
+
+> (typeset-code stx) - produces a pict for code in the given syntax
+  object. The source-location information of the syntax object
+  determines the line breaks, line indenting, and space within a row.
+  Empty rows are ignored.
+
+  Normally, `typeset-code' is used through a macro (often called
+  `code') that is generated by `define-code'. See below for more
+  information.
+
+  Embedded picts within `stx' are used directly. Row elements are
+  combined using `htl-append', so use `code-align' (see below) as
+  necessary to add an ascent to ascentless picts.
+
+  An identifier that starts with an underscore is italicized in
+  the pict. Underscores and carets in the middle of a word
+  create superscripts and subscripts (like TeX). For example
+  `foo_^4_ok' is displayed as the identifier "foo" with a "4"
+  superscript and an "ok" subscript.
+
+  Further, uses of certain keywords in `stx' typeset specially:
+
+>    code:blank - produces a space
+>    (code:comment s ...) - produces a comment block, with each `s'
+                            on its own line; each `s' must be a string
+                            or a pict
+>    (code:line datum ...) - typesets the `datum' sequence, mostly useful
+                             for the top-level sequence, since 
+                             `typeset-code' takes only one argument
+>    (code:contract datum ...) - like code:line, but every `datum' is
+                                 colored as a comment, and a semi-colon
+                                 is prefixed to every line
+>    (code:template datum ...) - like code:line, but a semi-colon
+                                 is prefixed to every line
+>     $                        - typesets as a vertical bar (for no
+                                 particularly good reason)
+
+> current-code-tt - parameter for a one-argument function to turn a
+  string into a pict, used to typeset text. The default is
+    (lambda (s) (text s `(bold . modern) (current-font-size)))
+
+> current-comment-color - parameter for a string or color% for comments
+> current-keyword-color - parameter for a string or color% for keywords
+> current-id-color - parameter for a string or color% for identifiers
+> current-literal-color - parameter for a string or color% for literals
+> current-base-color - parameter for a string or color% for everything else
+
+For backward compatibility:
+> comment-color - default string/color% for comments
+> keyword-color - default string/color% for keywords
+> id-color - default string/color% for ids
+> literal-color - default string/color% for literals
+
+> (code-align pict) - adjusts the ascent of `pict' so that its bottom
+  aligns with the baseline for text; use this function when `pict'
+  has no ascent.
+
+> current-keyword-list - a list of identifiers to color as keywords; the
+  default includes the MzScheme syntactic form names
+
+> current-const-list - a list of identifiers to color ad literals; the
+  default is 'empty
+
+> code-colorize-enabled - a parameter to enable or disable all code
+  coloring
+
+In addition to the `code@' unit, the "code.ss" module exports a
+`define-code' macro for defining other macros:
+
+> (define-code code-id typeset-code-id) - defines `code-id' as a macro
+  that uses `typeset-code-id', which is a function with the same input
+  as `typeset-code'.
+
+  The `code-id' syntactic form takes a sequence of `datum's:
+
+    (code datum ...)
+
+  It produces a pict that typesets the sequence. Source-location
+  information for the `datum' determine the layout of code in the
+  resulting pict.
+
+  If a `datum' contains `(unsyntax expr)' (perhaps as #,expr), then
+  the `expr' is evaluated and the result datum is spliced in place of
+  the `unsyntax' form in `datum'. If the result is not a syntax object,
+  it is given the source location of the `(unsyntax expr)'.
+
+  The `code' syntactic form expands to a use of `typeset-code'. The
+  `datum's are not merely syntax-quoted, because then the compiled
+  form of the call would loose source information. Instead, `code'
+  expands to an expression that preserves expansion-time
+  source-location information.
diff --git a/collects/texpict/face-demo.ss b/collects/texpict/face-demo.ss
new file mode 100644
index 0000000000..a53810b266
--- /dev/null
+++ b/collects/texpict/face-demo.ss
@@ -0,0 +1,139 @@
+(module face-demo mzscheme
+(require (lib "mred.ss" "mred")
+	 (lib "class.ss")
+	 (lib "utils.ss" "texpict")
+	 (lib "mrpict.ss" "texpict")
+         (lib "face.ss" "texpict"))
+
+(define f (new frame% (label "frame")))
+
+(define canvas-scale 1)
+
+(define c (new canvas%
+	       (parent f)
+	       (paint-callback
+		(lambda (x dc) 
+                  (send dc set-scale canvas-scale canvas-scale)
+                  (cb dc)))))
+
+
+(define moods
+  '(unhappiest
+    unhappier
+    unhappy
+    sortof-unhappy
+    sortof-happy
+    happy
+    happier
+    happiest
+    embarassed
+    badly-embarassed
+    mad
+    mean))
+
+(new button%
+     (label "Face Color...")
+     (parent f)
+     (callback (lambda (b e) 
+                 (let ([c (get-color-from-user "Face Color" f face-color)])
+                   (when c
+                     (set! face-color c)
+                     (new-face-callback))))))
+(new choice%
+     (label #f)
+     (choices (append (map symbol->string moods) (list "Custom")))
+     (parent f)
+     (callback (lambda (c e) 
+                 (let ([v (send c get-selection)])
+                   (set! face-mood (and (v . < . (length moods))
+                                        (list-ref moods v)))
+                   (new-face-callback)))))
+
+(define custom-panel (new group-box-panel% (label "Custom") (parent f)))
+(let ([choices '(none normal worried angry raised)])
+  (new choice%
+       (label "Eyebrows")
+       (choices (map symbol->string choices)) 
+       (parent custom-panel)
+       (callback (lambda (c e)
+                   (set! face-eyebrow-kind (list-ref choices (send c get-selection)))
+                   (new-face-callback)))))
+(let ([choices '(plain narrow medium large huge grimace)])
+  (new choice%
+       (label "Mouth")
+       (choices (map symbol->string choices)) 
+       (parent custom-panel)
+       (callback (lambda (c e)
+                   (set! face-mouth-kind (list-ref choices (send c get-selection)))
+                   (new-face-callback)))))
+(new check-box%
+     (label "Frown")
+     (parent custom-panel)
+     (callback (lambda (c e)
+                 (set! face-frown? (send c get-value))
+                 (new-face-callback))))
+(new slider%
+     (label "Eye Inset")
+     (parent custom-panel)
+     (min-value 0)
+     (max-value 10)
+     (callback (lambda (s e)
+                 (set! face-eye-inset (send s get-value))
+                 (new-face-callback))))
+(new slider%
+     (label "Eyebrow Y")
+     (parent custom-panel)
+     (min-value -5)
+     (max-value 5)
+     (init-value 0)
+     (callback (lambda (s e)
+                 (set! face-eyebrow-dy (send s get-value))
+                 (new-face-callback))))
+(let ([pupils
+       (lambda (label setter hi)
+         (new slider%
+              (label label)
+              (parent custom-panel)
+              (min-value (- hi))
+              (max-value hi)
+              (init-value 0)
+              (callback (lambda (s e)
+                          (setter (send s get-value))
+                          (new-face-callback)))))])
+  (pupils "Pupil X" (lambda (v) (set! face-pupils-dx v)) 10)
+  (pupils "Pupil Y" (lambda (v) (set! face-pupils-dy v)) 15))
+
+
+(send custom-panel enable #f)
+
+(dc-for-text-size (send c get-dc))
+
+(define face-color default-face-color)
+(define face-mood (car moods))
+(define face-eyebrow-kind 'none)
+(define face-mouth-kind 'plain)
+(define face-frown? #f)
+(define face-eye-inset 0)
+(define face-eyebrow-dy 0)
+(define face-pupils-dx 0)
+(define face-pupils-dy 0)
+
+(define the-pict (face face-mood face-color))
+
+(define (new-face-callback)
+  (send custom-panel enable (not face-mood))
+  (set! the-pict (if face-mood
+		     (face face-mood face-color)
+		     (face* face-eyebrow-kind
+			    face-mouth-kind face-frown?
+			    face-color
+			    face-eye-inset face-eyebrow-dy
+			    face-pupils-dx face-pupils-dy)))
+  (send c on-paint))
+
+(define (cb dc) (draw-pict the-pict dc 0 0))
+
+(send c min-width (inexact->exact (floor (* canvas-scale (pict-width the-pict)))))
+(send c min-height (inexact->exact (floor (* canvas-scale (pict-height the-pict)))))
+
+(send f show #t))
diff --git a/collects/texpict/face.ss b/collects/texpict/face.ss
new file mode 100644
index 0000000000..df272d31a2
--- /dev/null
+++ b/collects/texpict/face.ss
@@ -0,0 +1,326 @@
+(module face mzscheme
+  (require (lib "mred.ss" "mred")
+           (lib "mrpict.ss" "texpict")
+           (lib "utils.ss" "texpict")
+           (lib "class.ss")
+           (lib "math.ss")
+           (lib "etc.ss"))
+
+  (provide face face* default-face-color)
+  
+  (define no-brush (find-brush "white" 'transparent))
+  (define no-pen (find-pen "white" 1 'transparent))
+
+  (define (series dc steps start-c end-c f pen? brush?)
+    (color-series dc steps #e0.5 start-c end-c f pen? brush?))
+
+  (define default-face-color (make-object color% "orange"))
+
+  (define face*
+    (opt-lambda (eyebrows-kind
+                 mouth-kind
+                 frown?
+                 [in-face-color default-face-color]
+                 [eye-inset 0]
+                 [eyebrow-dy 0]
+                 [eye-dx 0]
+                 [eye-dy 0])
+      (define face-color (if (string? in-face-color)
+                             (make-object color% in-face-color)
+                             in-face-color))
+      (define face-bright-edge-color (scale-color #e1.6 face-color))
+      (define face-edge-color (scale-color #e0.8 face-color))
+      (define face-hard-edge-color (scale-color #e0.8 face-edge-color))
+      (let ([w 300]
+            [h 300])
+          (dc (lambda (dc x y)
+                (define old-pen (send dc get-pen))
+                (define old-brush (send dc get-brush))
+                
+                (define (one-eye l? p? dd look?)
+                  (define s (if p? 1/3 1))
+                  (define sdd (if p? 1 1/2))
+                  (define dx (+ (if p? (* 1/5 w 1/3) 0) (if look? eye-dx 0)))
+                  (define dy (+ (if p? (* 1/4 w 1/3) 0) (if look? eye-dy 0)))
+                  (send dc draw-ellipse
+                        (+ x (* w (if l? 1/5 3/5)) dx (* dd sdd)) (+ y (* h 1/5) dy (* dd sdd))
+                        (- (* w 1/5 s) (* 2 dd)) (- (* h 1/4 s) (* 2 dd))))
+                
+                (define (one-eye-brow l? dd dy dr)
+                  (send dc draw-arc
+                        (+ x (* w (if l? 1/5 3/5)))
+                        (+ y (* h 3/20) dd dy)
+                        (* w 1/5) 
+                        (* h 1/4)
+                        ((if l? + -) (* pi 1/3) dr) ((if l? + -) (* pi 2/3) dr)))
+                
+                (define (eye-series steps start-c end-c p? extra-inset look?)
+                  (series dc steps start-c end-c
+                          (lambda (i)
+                            (one-eye #t p? (+ extra-inset i) look?)
+                            (one-eye #f p? (+ extra-inset i) look?))
+                          #f #t))
+                
+                (define (eyebrows dy dr)
+                  (send dc set-brush no-brush)
+                  (series dc 3
+                          face-hard-edge-color
+                          face-edge-color
+                          (lambda (i)
+                            (one-eye-brow #t i dy dr)
+                            (one-eye-brow #f i dy dr))
+                          #t #f)
+                  (send dc set-pen no-pen))
+                
+                (define (normal-eyebrows dy)
+                  (eyebrows dy 0))
+                
+                (define (worried-eyebrows dy)
+                  (eyebrows dy 0.3))
+                
+                (define (angry-eyebrows dy)
+                  (eyebrows dy -0.3))
+                
+                (define (smile sw sh i da path dy flip?)
+		  ;; Either draw or set path.
+                  ((if path 
+                       (lambda (x y w h s e)
+			 (send path arc x y w h s e))
+                       (lambda (x y w h s e)
+                         (send dc draw-arc x y w h s e)))
+                   (+ x (/ (- w sw) 2) (* 1/6 sw)) 
+                   (+ y (/ (- sh h) 2) (* 1/8 h) dy (if flip? i 0) (if flip? (- (* h 1/2) (- sh h)) 0))
+                   (* sw 2/3) (+ (if flip? 0 i) (* h 2/3))
+                   (- (* pi (- 5/4 (if flip? 1 0))) da) (+ (* pi (- 7/4 (if flip? 1 0))) da)))
+                
+                (define (plain-smile flip? tongue?)
+		  (send dc set-brush no-brush)
+		  (series dc 3
+                          (make-object color% "black")
+                          face-edge-color
+                          (lambda (i)
+                            (smile w h i 0 #f 0 flip?)
+                            (smile w h (- i) 0 #f 0 flip?)) 
+                          #t #f)
+		  (when tongue?
+		    (let ([path (new dc-path%)]
+			  [rgn (make-object region% dc)])
+		      (smile w h 2 0 path 0 flip?)
+		      (send path line-to (+ w x) (+ h y))
+		      (send path line-to x (+ h y))
+		      (send rgn set-path path)
+		      (send dc set-clipping-region rgn)
+		      (send dc set-pen no-pen)
+		      (let ([dx (+ x (if flip?
+					 (* 1/3 w)
+					 (* 1/2 w)))]
+			    [dy (+ y (if flip?
+					 (* 1/2 h)
+					 (* 13/20 h)))]
+			    [tw (* 1/5 w)]
+			    [th (* 1/4 h)])
+			(series dc 3
+				face-color
+				(make-object color% "red")
+				(lambda (i)
+				  (send dc draw-ellipse dx dy (- tw i) (- th i)))
+				#f #t)
+			(series dc 4
+				(make-object color% "black")
+				(scale-color 0.6 (make-object color% "red"))
+				(lambda (i)
+				  (send dc draw-line (- (+ dx i) (* tw 1/10)) dy (+ dx (* tw 0.65)) (+ dy (* th 0.75))))
+				#t #f)
+			(send dc set-clipping-region #f)))))
+                
+                (define (teeth)
+                  ;; Assumes clipping region is set
+                  (send dc set-brush (find-brush "white"))
+                  (send dc draw-ellipse x y w h)
+                  (series dc 5
+                          (make-object color% "darkgray")
+                          (make-object color% "lightgray")
+                          (lambda (i)
+                            (let loop ([j 0][delta 0][tw (* w 1/10)])
+                              (unless (= j 5)
+                                (send dc draw-rectangle
+                                      (+ x (* w 1/2) delta 1) y
+                                      (- tw i 1) h)
+                                (send dc draw-rectangle
+                                      (+ x (* w 1/2) (- delta) (- tw) 1) y
+                                      (- tw i 1) h)
+                                (loop (add1 j) (+ delta tw) (* 8/10 tw)))))
+                          #f #t))
+                
+                (define (toothy-smile tw th ta bw bh ba flip? ddy)
+                  (let-values ([(path) (make-object dc-path%)]
+			       [(tmp-rgn1) (make-object region% dc)]
+                               [(dy) (+ ddy (/ (- h (if flip? (+ th (abs (- bh th))) th)) 2))])
+                    ;; Teeth:
+                    (smile tw th 0 ta path dy flip?)
+		    (send path reverse)
+                    (smile bw bh 0 ba path dy flip?)
+		    (send tmp-rgn1 set-path path)
+                    (send dc set-clipping-region tmp-rgn1)
+                    (teeth)
+                    (send dc set-clipping-region #f)
+                    
+                    ;; Smile edges:
+                    (send dc set-brush no-brush)
+                    (series dc 3
+                            (if flip? face-bright-edge-color face-hard-edge-color)
+                            (if flip? face-color face-edge-color)
+                            (lambda (i)
+                              (smile bw bh (if flip? i (- i)) ba #f dy flip?))
+                            #t #f)
+                    (series dc 3
+                            (if flip? face-hard-edge-color face-bright-edge-color)
+                            (if flip? face-edge-color face-color)
+                            (lambda (i)
+                              (smile tw th (if flip? (- i) i) ta #f dy flip?))
+                            #t #f)))
+                
+                (define (grimace tw th ta flip?)
+                  (let-values ([(path) (make-object dc-path%)]
+                               [(tmp-rgn1) (make-object region% dc)]
+                               [(dy) (/ (- h th) 2)]
+                               [(elx ely) (values (+ x (* w 0.27)) (+ y (* h 0.65) (if flip? 3 1)))])
+                    ;; Teeth:
+		    (smile tw th 0 ta path (+ (if flip? -30 0) dy) flip?)
+		    (send path arc elx ely 30 30 (* 1/2 pi) (* 3/2 pi) #t)
+		    (send path reverse)
+		    (send path arc (- (+ x w) (- elx x) 30) ely 30 30 (* 1/2 pi) (* 3/2 pi) #f)
+		    (smile tw th 0 ta path (+ (if flip? 0 -30) dy) flip?)
+                    (send tmp-rgn1 set-path path)
+                    (send dc set-clipping-region tmp-rgn1)
+		    (teeth)
+                    (send dc set-clipping-region #f)
+		    
+                    ;; Smile edges:
+                    (send dc set-brush no-brush)
+                    (let ([sides (lambda (top? i)
+                                   (send dc draw-arc (- elx (/ i 2)) (- ely (/ i 2)) 30 (+ 30 i) 
+                                         (* pi (if top? 1 1/2)) (* pi (if top? 3/2 1)))
+                                   (send dc draw-arc (+ (- (+ x w) (- elx x) 30) (/ i 2)) (- ely (/ i 2)) 30 (+ 30 i) 
+                                         (* pi (if top? -1/2 0)) (* pi (if top? 0 1/2))))])
+                      (series dc 3
+                              (if flip? face-bright-edge-color face-hard-edge-color)
+                              (if flip? face-color face-edge-color)
+                              (lambda (i)
+                                (sides flip? i)
+                                (smile tw th (if flip? i (- i)) ta #f (+ (if flip? -2 -30) dy) flip?))
+                              #t #f)
+                      (series dc 3
+                              (if flip? face-hard-edge-color face-bright-edge-color)
+                              (if flip? face-edge-color face-color)
+                              (lambda (i)
+                                (sides (not flip?) i)
+                                (smile tw th (if flip? (- i) i) ta #f (+ (if flip? -30 0) dy) flip?))
+                              #t #f))))
+                
+                (define (medium-grimace flip?)
+                  (grimace
+                   (* 1.2 w) (* h 0.9) (- (* 0.1 pi))
+                   flip?))
+                
+                (define (large-smile flip?)
+                  (toothy-smile
+                   w (* 1.05 h) (* 0.10 pi)
+                   (* 1.1 w) (* h 0.95) (* 0.05 pi)
+                   flip? 0))
+                
+                (define (largest-smile flip?)            
+                  (toothy-smile
+                   w (* 1.1 h) (* 0.14 pi)
+                   (* 1.2 w) (* h 0.9) (* 0.05 pi)
+                   flip? (if flip? (* h 0.1) 0)))
+                
+                (define (narrow-smile flip?)
+                  (toothy-smile
+                   (* 0.8 w) (* h 0.7) (- (* 0.00 pi))
+                   (* 1.0 w) (* h 0.6) (- (* 0.06 pi))
+                   flip? (if flip? (- (* h 0.2)) 0)))
+                
+                (define (medium-smile flip?)
+                  (toothy-smile
+                   (* 0.8 w) (* h 0.9) (* 0.08 pi)
+                   (* 1.0 w) (* h 0.75) (- (* 0.01 pi))
+                   flip? 0))
+
+                
+                (define (draw-eyes inset)
+                  ;; Draw eyes
+                  (eye-series 10 
+                              (make-object color% "lightgray")
+                              (make-object color% "white")
+                              #f
+                              inset
+                              #f)
+                  
+                  ;; Draw pupils
+                  (eye-series 3
+                              (make-object color% 220 220 220)
+                              (make-object color% "black")
+                              #t
+                              0
+                              #t))
+                
+                (send dc set-pen no-pen)
+                
+                ;; Draw face background
+                (series dc 5
+                        face-edge-color
+                        face-color
+                        (lambda (i)
+                          (send dc draw-ellipse 
+                                (+ x (/ i 2)) (+ y (/ i 2))
+                                (- w (* 2 i)) (- h (* 2 i))))
+                        #f #t)
+
+		(draw-eyes eye-inset)
+		(case eyebrows-kind
+		  [(normal) (normal-eyebrows eyebrow-dy)]
+		  [(worried) (worried-eyebrows eyebrow-dy)]
+		  [(angry) (angry-eyebrows eyebrow-dy)]
+		  [(none) (void)])
+		(case mouth-kind
+		  [(plain) (plain-smile frown? #f)]
+                  [(narrow) (narrow-smile frown?)]
+		  [(medium) (medium-smile frown?)]
+		  [(large) (large-smile frown?)]
+		  [(huge) (largest-smile frown?)]
+		  [(grimace) (medium-grimace frown?)]
+		  [(tongue) (plain-smile frown? #t)])
+                
+                (send dc set-brush old-brush)
+                (send dc set-pen old-pen))
+              w h 0 0))))
+
+  (define face
+    (opt-lambda (mood [face-color default-face-color])
+      (case mood
+	[(unhappy)
+	 (face* 'none 'plain #t face-color 6)]
+	[(sortof-happy)
+	 (face* 'worried 'medium #f face-color 6)]
+	[(sortof-unhappy)
+	 (face* 'worried 'grimace #t face-color 6)]
+	[(happy)
+	 (face* 'none 'plain #f face-color 6)]
+	[(happier)
+	 (face* 'none 'large #f face-color 3)]
+	[(embarassed)
+	 (face* 'worried 'medium #f face-color 3)]
+	[(badly-embarassed)
+	 (face* 'worried 'medium #t face-color 3)]
+	[(unhappier)
+	 (face* 'normal 'large #t face-color 3)]
+	[(happiest)
+	 (face* 'normal 'huge #f face-color 0 -3)]
+	[(unhappiest)
+	 (face* 'normal 'huge #t face-color 0 -3)]
+        [(mad)
+         (face* 'angry 'grimace #t face-color 0)]
+        [(mean)
+         (face* 'angry 'narrow #f face-color 0)]
+	[else (error 'face "unknown mood: ~e" mood)]))))
diff --git a/collects/texpict/info.ss b/collects/texpict/info.ss
new file mode 100644
index 0000000000..eee8b4a669
--- /dev/null
+++ b/collects/texpict/info.ss
@@ -0,0 +1,5 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Texpict")
+  (define doc.txt "doc.txt")
+  (define help-desk-message
+    "Mz/Mr: `(require (lib \"texpict.ss\" \"texpict\"))"))
diff --git a/collects/texpict/mrpict-sig.ss b/collects/texpict/mrpict-sig.ss
new file mode 100644
index 0000000000..900cc51409
--- /dev/null
+++ b/collects/texpict/mrpict-sig.ss
@@ -0,0 +1,12 @@
+
+(module mrpict-sig mzscheme
+  (require (lib "unitsig.ss"))
+  
+  (require "private/common-sig.ss")
+  (require "private/mrpict-sig.ss")
+  
+  (provide mrpict^)
+  (define-signature mrpict^
+    ((open texpict-common^)
+     (open mrpict-extra^))))
+
diff --git a/collects/texpict/mrpict-unit.ss b/collects/texpict/mrpict-unit.ss
new file mode 100644
index 0000000000..58ce122ffb
--- /dev/null
+++ b/collects/texpict/mrpict-unit.ss
@@ -0,0 +1,27 @@
+
+(module mrpict-unit mzscheme
+  (require (lib "unitsig.ss"))
+
+  (require (lib "mred-sig.ss" "mred"))
+
+  (require "private/mrpict-sig.ss"
+	   "private/common-sig.ss"
+	   "private/common-unit.ss"
+	   "private/mrpict-extra.ss")
+	
+  (provide mrpict@)
+  (define mrpict@
+    (compound-unit/sig
+     (import (MRED : mred^))
+     (link [COMMON : ((open texpict-common^)
+		      (open texpict-internal^))
+		   (common@
+		    (MRPICTX : texpict-common-setup^))]
+	   [MRPICTX : ((open mrpict-extra^)
+		       (open texpict-common-setup^))
+		    (mrpict-extra@
+		     MRED
+		     COMMON)])
+     (export (open (COMMON : texpict-common^))
+	     (open (MRPICTX : mrpict-extra^))))))
+
diff --git a/collects/texpict/mrpict.ss b/collects/texpict/mrpict.ss
new file mode 100644
index 0000000000..bff9ba5b89
--- /dev/null
+++ b/collects/texpict/mrpict.ss
@@ -0,0 +1,16 @@
+
+(module mrpict mzscheme
+  (require (lib "unitsig.ss"))
+
+  (require (lib "mred-sig.ss" "mred")
+	   (lib "mred.ss" "mred"))
+
+  (require "mrpict-sig.ss"
+	   "mrpict-unit.ss")
+
+  (define-values/invoke-unit/sig mrpict^
+    mrpict@
+    #f
+    mred^)
+
+  (provide-signature-elements mrpict^))
diff --git a/collects/texpict/mztp.sty b/collects/texpict/mztp.sty
new file mode 100644
index 0000000000..e92286c791
--- /dev/null
+++ b/collects/texpict/mztp.sty
@@ -0,0 +1,9 @@
+
+\newwrite\mztpOUT
+\newbox\mztpBOX
+\immediate\openout\mztpOUT=\jobname.mztp
+
+\newcommand{\mztpMeasure}[2]{%
+\setbox\mztpBOX\hbox{#1}%
+\immediate\write\mztpOUT{#2 \the\wd\mztpBOX\space\the\ht\mztpBOX\space\the\dp\mztpBOX}%
+\usebox\mztpBOX}
diff --git a/collects/texpict/pict-value-snip.ss b/collects/texpict/pict-value-snip.ss
new file mode 100644
index 0000000000..e05b939d5c
--- /dev/null
+++ b/collects/texpict/pict-value-snip.ss
@@ -0,0 +1,337 @@
+#|
+
+TODO: copying/pasting of pict snips doesn't preserve all of the information.
+It only preserves the look, for now. The bounding boxes for children, in particular,
+are gone.
+
+When pressing or releasing the modifier keys, the snip doesn't update immediately;
+the user has to move the mouse first.
+
+|#
+
+(module pict-value-snip mzscheme
+  (require (lib "mrpict.ss" "texpict")
+           (lib "utils.ss" "texpict")
+           (lib "class.ss")
+           (lib "mred.ss" "mred")
+           (lib "etc.ss")
+           (lib "list.ss"))
+  
+  (provide pict-value-snip%)
+
+  (define pict-value-snip%
+    (class snip%
+      (init-field pict)
+      (define top-align? #t)
+      (define white? #f)
+      (define pict-drawer (make-pict-drawer pict))
+      (define/override (draw dc x y left top right bottom dx dy draw-caret)
+        (pict-drawer dc x y)
+        (let ([old-pen (send dc get-pen)]
+              [old-brush (send dc get-brush)])
+          (send dc set-brush (send the-brush-list find-or-create-brush "black" 'transparent))
+          (send dc set-pen (send the-pen-list find-or-create-pen
+                                 (if white? "white" "black")
+                                 1
+                                 'solid))
+          (for-each (lambda (child)
+                      (send dc draw-rectangle
+                            (+ x (hbox-x child))
+                            (+ y (hbox-y child))
+                            (hbox-w child)
+                            (hbox-h child)))
+                    highlight-children)
+          (send dc set-pen old-pen)
+          (send dc set-brush old-brush)))
+      (define/override (get-extent dc x y w h descent space lspace rspace)
+        (set-box/f! w (pict-width pict))
+        (set-box/f! h (pict-height pict))
+        (cond
+          [top-align?
+           (set-box/f! descent (- (pict-height pict) (pict-ascent pict)))
+           (set-box/f! space 0)]
+          [else
+           (set-box/f! descent (pict-descent pict))
+           (set-box/f! space 0)])
+        (set-box/f! lspace 0)
+        (set-box/f! rspace 0))
+      
+      (define highlight-children '())
+      
+      (define/override (on-event dc x y editorx editory evt)
+        (let* ([sx (- (send evt get-x) x)]
+               [sy (- (send evt get-y) y)]
+               [needs-update? #f]
+               [update-children
+                (lambda (children)
+                  (unless (equal? children highlight-children)
+                    (set! needs-update? #t)
+                    (set! highlight-children children)))])
+          
+          (unless (equal? white? (send evt get-shift-down))
+            (set! white? (send evt get-shift-down))
+            (set! needs-update? #t))
+          
+          (cond
+            [(send evt get-control-down)
+             (update-children (all-boxes pict))]
+            [(or (send evt get-alt-down)
+                 (send evt get-meta-down))
+             (update-children (included-boxes pict sx sy))]
+            [else
+             (update-children (minimal-boxes pict sx sy))])
+          
+          (when needs-update?
+            (refresh))))
+      
+      ;; this doesn't work at all.
+      (define/override (on-char dc x y editorx editory evt)
+        (cond
+          [(eq? (send evt get-key-code) 'shift)
+           (set! white? (eq? 'press (send evt get-key-release-code)))
+           (refresh)]
+          [else (void)]))
+      
+      (define/override (adjust-cursor dc x y editorx editory event)
+        arrow-cursor)
+      
+      (inherit get-admin)
+      (define/private (refresh)
+        (let ([admin (get-admin)])
+          (when admin
+            (send admin needs-update this 0 0 (pict-width pict) (pict-height pict)))))
+          
+      (define/override (copy) (new pict-value-snip% (pict pict)))
+      
+      (define/override (write in)
+        (let ([w (inexact->exact (ceiling (pict-width pict)))]
+              [h (inexact->exact (ceiling (pict-height pict)))])
+          (send in put h)
+          (let* ([bm (make-object bitmap% w h)]
+                 [str (make-bytes (* w h 4))]
+                 [bdc (make-object bitmap-dc% bm)])
+            (send bdc clear)
+            (pict-drawer bdc 0 0)
+            (send bdc get-argb-pixels 0 0 w h str)
+            (send bdc set-bitmap #f)
+            (send in put (+ 1 (bytes-length str)) str))))
+      
+      (super-new)
+      (inherit set-snipclass set-flags get-flags)
+      (set-snipclass pict-snipclass)
+      (set-flags (cons 'handles-events (get-flags)))))
+  
+  (define arrow-cursor (make-object cursor% 'arrow))
+
+  (define pict-snip-class%
+    (class snip-class%
+      (define/override (read in)
+        (define pict
+          (let ([h (send in get-exact)]
+                [bitmap-bstr (send in get-bytes)])
+            (cond
+              [(and (number? h)
+                    (bytes? bitmap-bstr)
+                    (zero? (modulo (bytes-length bitmap-bstr) (* 4 h))))
+               (let* ([w (quotient (bytes-length bitmap-bstr) (* 4 h))]
+                      [bm (make-object bitmap% w h)]
+                      [bdc (make-object bitmap-dc% bm)])
+                 (send bdc set-argb-pixels 0 0 w h bitmap-bstr)
+                 (send bdc set-bitmap #f)
+                 (bitmap bm))]
+              [else (x-out (ellipse 10 10))])))
+        (new pict-value-snip% (pict pict)))
+      (super-new)))
+  
+  (define (x-out p)
+    (cc-superimpose
+     p
+     (dc (lambda (dc dx dy)
+           (send dc draw-line dx dy (+ dx (pict-width p)) (+ dy (pict-height p)))
+           (send dc draw-line dx (+ dy (pict-height p)) (+ dx (pict-width p)) dy))
+         (pict-width p)
+         (pict-height p)
+         0
+         0)))
+  
+  (define pict-snipclass (new pict-snip-class%))
+  (send pict-snipclass set-classname "drscheme:pict-value-snip%")
+  (send pict-snipclass set-version 0)
+  (send (get-the-snip-class-list) add pict-snipclass)
+  
+  (define (set-box/f! b v) (when (box? b) (set-box! b v)))
+  
+  (define (minimal-boxes pict x y)
+    (minimal-boxes/a '() (included-boxes pict x y)))
+  
+  (define (minimal-boxes/a minimal included)
+    (cond
+      [(null? included) minimal]
+      [else (minimal-boxes/a (adjust-minimal minimal (car included))
+                             (cdr included))]))
+  
+  (define (adjust-minimal minimal candidate)
+    (cond
+      [(ormap (lambda (x) (inside? x candidate)) minimal)
+       minimal]
+      [(ormap (lambda (x) (inside? candidate x)) minimal)
+       (cons
+        candidate
+        (filter (lambda (x) (not (inside? candidate x)))
+                minimal))]
+      [else (cons candidate minimal)]))
+       
+  (define (inside? c1 c2)
+    (and (<= (hbox-x c2)
+             (hbox-x c1)
+             (+ (hbox-x c1) (hbox-w c1))
+             (+ (hbox-x c2) (hbox-w c2)))
+         (<= (hbox-y c2)
+             (hbox-y c1)
+             (+ (hbox-y c1) (hbox-h c1))
+             (+ (hbox-y c2) (hbox-h c2)))))
+  
+  (define (test)
+    
+    (define (same-boxes? l1 l2)
+      (and (list? l1)
+           (list? l2)
+           (andmap hbox? l1)
+           (andmap hbox? l2)
+           (andmap (lambda (e1) (memf (same-box? e1) l2)) l1)
+           (andmap (lambda (e2) (memf (same-box? e2) l1)) l2)
+           #t))
+    (define ((same-box? b1) b2)
+      (and (= (hbox-x b1) (hbox-x b2))
+           (= (hbox-y b1) (hbox-y b2))
+           (= (hbox-w b1) (hbox-w b2))
+           (= (hbox-h b1) (hbox-h b2))))
+    
+    (define (chk l1 l2)
+      (cond
+        [(same-boxes? l1 l2) #t]
+        [else
+         (printf "got ~s expected ~s\n" (map conv l1) (map conv l2))
+         #f]))
+    
+    (list (chk (minimal-boxes/a '() (list (make-hbox 1 1 10 10)))
+               (list (make-hbox 1 1 10 10)))
+          (chk (minimal-boxes/a '() (list (make-hbox 5 5 10 10)
+                                          (make-hbox 0 0 20 20)))
+               (list (make-hbox 5 5 10 10)))
+          (chk (minimal-boxes/a '() (list (make-hbox 5 5 10 10)
+                                          (make-hbox 6 6 10 10)))
+               (list (make-hbox 5 5 10 10)
+                     (make-hbox 6 6 10 10)))
+          (chk (minimal-boxes/a '() (list (make-hbox 0 0 10 10)
+                                          (make-hbox 0 0 20 20)))
+               (list (make-hbox 0 0 10 10)))
+          (chk (minimal-boxes/a '() (list (make-hbox 0 0 20 20)
+                                          (make-hbox 0 0 10 10)))
+               (list (make-hbox 0 0 10 10)))))
+
+  (define (conv x)
+    (list (hbox-x x) (hbox-y x) (hbox-w x) (hbox-h x)))
+  
+  
+  (define (included-boxes pict x y)
+    (filter (lambda (child)
+              (and (<= (hbox-x child)
+                       x
+                       (+ (hbox-x child) (hbox-w child)))
+                   (<= (hbox-y child)
+                       y
+                       (+ (hbox-y child) (hbox-h child)))))
+            (all-boxes pict)))
+    
+  ;; y coordinates is from top going down (not bottom going up, which is what picts do)
+  (define-struct hbox (x y w h))
+  
+  (define (make-hbox/conv orig-pict x y w h)
+    (make-hbox x
+               (- (pict-height orig-pict) y h)
+               w
+               h))
+  
+  ;; all-boxes : pict -> (listof hbox)
+  (define (all-boxes orig-pict)
+    (let loop ([pict orig-pict]
+               [adx 0]
+               [ady 0]
+               [boxes (list (make-hbox 0 0 (pict-width orig-pict) (pict-height orig-pict)))])
+      (let ([children (pict-children pict)])
+        (let i-loop ([children children]
+                     [boxes boxes])
+          (cond
+            [(null? children) boxes]
+            [else 
+             (let ([child (car children)])
+               (i-loop (cdr children)
+                       (loop (child-pict child)
+                             (+ adx (child-dx child))
+                             (+ ady (child-dy child))
+                             (cons 
+                              (make-hbox/conv
+                               orig-pict
+                               (+ adx (child-dx child))
+                               (+ ady (child-dy child))
+                               (pict-width (child-pict child))
+                               (pict-height (child-pict child)))
+                              boxes))))])))))
+
+  #|
+  (define (fish color open?)
+    (standard-fish 30 20 'left color "black" open?))
+  
+  (define lunch-fish (fish "orange" #f))
+  (define small-fish (fish "blue" #f))
+  (define small-aaah-fish (fish "blue" #t))
+  
+  (define spacer (blank 10 0))
+  
+  (define fc 6)
+
+  (define meal-fish 
+    (build-list (- fc 1) 
+                (lambda (i) (launder lunch-fish))))
+  (define eating-fish 
+    (build-list fc
+                (lambda (i) (launder (scale small-fish (sqrt (+ i 1)))))))
+  (define eating-aaah-fish 
+    (build-list fc
+                (lambda (i) (launder (scale small-aaah-fish (sqrt (+ i 1)))))))
+  
+  (define (on set pict) (if (memq pict set) pict (ghost pict)))
+
+  (define (main-characters active)
+    (foldl (lambda (meal-fish eating-fish eating-aaah-fish rest-of-scene)
+             (lc-superimpose
+              (on active eating-fish)
+              (on active eating-aaah-fish)
+              (hc-append (on active meal-fish)
+                         spacer
+                         rest-of-scene)))
+           (cc-superimpose (on active (car eating-fish))
+                           (on active (car eating-aaah-fish)))
+           meal-fish
+           (cdr eating-fish)
+           (cdr eating-aaah-fish)))
+
+  
+  (dc-for-text-size (make-object bitmap-dc% (make-object bitmap% 1 1)))
+  
+  (define txt (vc-append (text "yXy" 'roman 12) (text "y" 'roman 12)))
+  
+  (all-boxes txt)
+  
+  (define t (new text%))
+  (send t insert (new pict-snip% (pict (main-characters (append meal-fish eating-fish eating-aaah-fish)))))
+  (send t copy #f 0 0 1)
+  (send t insert "\n")
+  (send t paste)
+  (define f (new frame% (label "") (width 600) (height 200)))
+  (define ec (new editor-canvas% (editor t) (parent f)))
+  (send f show #t)
+
+|#
+  )
\ No newline at end of file
diff --git a/collects/texpict/private/common-sig.ss b/collects/texpict/private/common-sig.ss
new file mode 100644
index 0000000000..7960f9cf61
--- /dev/null
+++ b/collects/texpict/private/common-sig.ss
@@ -0,0 +1,129 @@
+(module common-sig mzscheme
+  (require (lib "unitsig.ss"))
+
+  (provide texpict-common^)
+  (define-signature texpict-common^
+    ((struct pict (draw width height ascent descent children))
+     (struct child (pict dx dy))
+
+     black-and-white
+
+     lt-find
+     lc-find
+     lb-find
+     ltl-find
+     lbl-find
+     ct-find
+     cc-find
+     cb-find
+     ctl-find
+     cbl-find
+     rt-find
+     rc-find
+     rb-find
+     rtl-find
+     rbl-find
+
+     find-lt  ; (left & top)  ; pict pict-path -> dx dy
+     find-lc  ; (left & vertical center)
+     find-lb  ; (left & bottom)
+     find-ltl ; (left and top baseline)
+     find-lbl ; (left and bottom baseline)
+     find-ct  ; (horizontal center & top)
+     find-cc
+     find-cb
+     find-ctl
+     find-cbl
+     find-rt
+     find-rc
+     find-rb
+     find-rtl
+     find-rbl
+
+     launder  ; pict -> pict
+
+     blank        ; -> pict
+     ; w h -> pict
+     ; w h d -> pict
+
+     clip-descent   ; pict -> pict
+     clip-ascent    ; pict -> pict
+     lift           ; pict -> pict
+     drop           ; pict -> pict
+     baseless       ; pict -> pict
+     inset          ; pict i -> pict
+                    ; pict hi vi -> pict
+                    ; pict l t r b -> pict
+     refocus        ; pict pict -> pict
+     panorama       ; pict -> pict
+
+     hline        ; w h -> pict
+     dash-hline   ; w h seg-length -> pict ; default seg-length is 5
+     vline        ; w h -> pict
+     dash-vline   ; w h seg-length -> pict ; default seg-length is 5
+
+     frame        ; pict -> pict
+     dash-frame   ; pict seg-length -> pict ; default seg-length is 5
+     oval         ; pict -> pict
+     oval/radius  ; pict r -> pict ; r is radius of corners
+
+     big-circle   ; diameter -> pict
+
+     thick       ; pict -> pict
+     thin        ; pict -> pict
+
+     ghost        ; pict -> pict
+
+     record       ; pict pict ... -> pict
+
+     vl-append    ; d pict ... -> pict ; d units between each picture
+     vc-append
+     vr-append
+     ht-append
+     hc-append
+     hb-append
+     htl-append       ; align bottoms of ascents
+     hbl-append       ; align tops of descents (normal text alignment)
+
+     lt-superimpose ; pict ... -> pict
+     lb-superimpose
+     lc-superimpose
+     ltl-superimpose
+     lbl-superimpose
+     rt-superimpose
+     rb-superimpose
+     rc-superimpose
+     rtl-superimpose
+     rbl-superimpose
+     ct-superimpose
+     cb-superimpose
+     cc-superimpose
+     ctl-superimpose
+     cbl-superimpose
+
+     table ; ncols pict-list col-aligns row-aligns col-seps row-seps -> pict
+
+     colorize ; pict color-string -> pict
+
+     picture       ; w h command-list -> pict
+     picture*      ; w h a d command-list -> pict
+
+     cons-picture  ; pict command-list -> pict
+     cons-picture* ; pict command-list -> pict
+
+     place-over
+     place-under
+     pin-over
+     pin-under
+     ))
+
+  (provide texpict-common-setup^)
+  (define-signature texpict-common-setup^
+    (connect
+     ~connect))
+
+  (provide texpict-internal^)
+  (define-signature texpict-internal^
+    (prepare-for-output
+     pict->command-list
+     line-thickness)))
diff --git a/collects/texpict/private/common-unit.ss b/collects/texpict/private/common-unit.ss
new file mode 100644
index 0000000000..5ad8260af0
--- /dev/null
+++ b/collects/texpict/private/common-unit.ss
@@ -0,0 +1,957 @@
+
+(module common-unit mzscheme
+  (require (lib "unitsig.ss")
+           (lib "etc.ss"))
+
+  (require "common-sig.ss")
+
+  (provide common@)
+  (define common@
+    (unit/sig ((open texpict-common^) (open texpict-internal^))
+      (import texpict-common-setup^)
+
+      (define default-seg 5)
+      (define recordseplinespace 4)
+
+      (define-struct pict (draw     ; drawing instructions
+			   width    ; total width
+			   height   ; total height >= ascent + desecnt
+			   ascent   ; portion of height above top baseline
+			   descent  ; portion of height below bottom baseline
+			   children ; list of child records
+			   panbox)) ; panorama box
+      (define-struct child (pict dx dy sx sy))
+      (define-struct bbox (x1 y1 x2 y2 ay dy))
+
+      (define (quotient* a b)
+	(if (integer? a)
+	    (quotient a b)
+	    (/ a b)))
+
+      (define blank 
+	(case-lambda
+	 [() (blank 0 0 0)]
+	 [(s) (blank s s)]
+	 [(w h) (blank w h 0)]
+	 [(w a d) (make-pict `(picture ,w ,(+ a d)) w (+ a d) a d null #f)]
+	 [(w h a d) (make-pict `(picture ,w ,h) w h a d null #f)]))
+
+      (define (extend-pict box dx dy dw da dd draw)
+	(let ([w (pict-width box)]
+	      [h (pict-height box)]
+	      [d (pict-descent box)]
+	      [a (pict-ascent box)])
+	  (make-pict (if draw draw (pict-draw box))
+		     (+ w dw) (+ h da dd) 
+		     (max 0 (+ a da)) (max 0 (+ d dd))
+		     (list (make-child box dx dy 1 1))
+		     #f)))
+
+      (define (single-pict-offset pict subbox)
+	(let floop ([box pict]
+		    [found values]
+		    [not-found (lambda () (error 'find-XX
+						 "sub-pict: ~a not found in: ~a" 
+						 subbox pict))])
+	  (if (eq? box subbox)
+	      (found 0 0 1 1)
+	      (let loop ([c (pict-children box)])
+		(if (null? c) 
+		    (not-found)
+		    (floop (child-pict (car c))
+			   (lambda (dx dy sx sy)
+			     (let ([tsx (child-sx (car c))]
+				   [tsy (child-sy (car c))])
+			       (found (+ (* tsx dx)
+					 (child-dx (car c)))
+				      (+ (* tsy dy)
+					 (child-dy (car c)))
+				      (* sx tsx)
+				      (* sy tsy))))
+			   (lambda ()
+			     (loop (cdr c)))))))))
+
+      (define (find-lbx pict subbox-path)
+	(if (pict? subbox-path)
+	    (single-pict-offset pict subbox-path)
+	    (let loop ([p pict][l subbox-path][dx 0][dy 0][sx 1][sy 1])
+	      (if (null? l)
+		  (values dx dy sx sy)
+		  (let-values ([(x y tsx tsy) (find-lbx p (car l))])
+		    (loop (car l) (cdr l) 
+			  (+ (* sx x) dx) (+ (* sy y) dy)
+			  (* sx tsx) (* sy tsy)))))))
+
+      (define-values (find-lt
+		      find-lc
+		      find-lb
+		      find-ltl
+		      find-lbl
+		      find-ct
+		      find-cc
+		      find-cb
+		      find-ctl
+		      find-cbl
+		      find-rt
+		      find-rc
+		      find-rb
+		      find-rtl
+		      find-rbl)
+	(let ([lb (lambda (x sx w d a) x)]
+	      [c (lambda (x sx w d a) (+ x (* sx (quotient* w 2))))]
+	      [rt (lambda (x sx w d a) (+ x (* sx w)))]
+	      [tline (lambda (x sx w d a) (+ x (* sx (- w a))))]
+	      [bline (lambda (x sx w d a) (+ x (* sx d)))]
+	      [find (lambda (get-x get-y)
+		      (lambda (pict pict-path)
+			(let-values ([(dx dy sx sy) (find-lbx pict pict-path)])
+			  (let ([p (let loop ([path pict-path])
+				     (cond
+				      [(pict? path) path]
+				      [(null? (cdr path)) (loop (car path))]
+				      [else (loop (cdr path))]))])
+			    (values (get-x dx sx (pict-width p) 0 0)
+				    (get-y dy sy (pict-height p) (pict-descent p) (pict-ascent p)))))))])
+	  (values (find lb rt)
+		  (find lb c)
+		  (find lb lb)
+		  (find lb tline)
+		  (find lb bline)
+		  (find c rt)
+		  (find c c)
+		  (find c lb)
+		  (find c tline)
+		  (find c bline)
+		  (find rt rt)
+		  (find rt c)
+		  (find rt lb)
+		  (find rt tline)
+		  (find rt bline))))
+
+      (define-values (lt-find
+		      lc-find
+		      lb-find
+		      ltl-find
+		      lbl-find
+		      ct-find
+		      cc-find
+		      cb-find
+		      ctl-find
+		      cbl-find
+		      rt-find
+		      rc-find
+		      rb-find
+		      rtl-find
+		      rbl-find)
+	(let ([flip (lambda (orig)
+		      (lambda (pict pict-path)
+			(let-values ([(x y) (orig pict pict-path)])
+			  (values x (- (pict-height pict) y)))))])
+	  (values (flip find-lt)
+		  (flip find-lc)
+		  (flip find-lb)
+		  (flip find-ltl)
+		  (flip find-lbl)
+		  (flip find-ct)
+		  (flip find-cc)
+		  (flip find-cb)
+		  (flip find-ctl)
+		  (flip find-cbl)
+		  (flip find-rt)
+		  (flip find-rc)
+		  (flip find-rb)
+		  (flip find-rtl)
+		  (flip find-rbl))))
+
+      (define (launder box)
+	(unless (pict-panbox box)
+	  (panorama-box! box))
+	(let ([b (extend-pict box 0 0 0 0 0 #f)])
+	  (set-pict-children! b null)
+	  (set-pict-panbox! b (pict-panbox box))
+	  b))
+
+      (define (lift p n)
+	(let* ([dh (- (max 0 (- n (pict-descent p))))]
+	       [do-a? (= (pict-height p)
+			 (+ (pict-ascent p) (pict-descent p)))]
+	       [h2 (+ dh (pict-height p))]
+	       [d2 (max 0 (- (pict-descent p) n))])
+	  (make-pict (pict-draw p)
+		     (pict-width p) h2
+		     (if do-a?
+			 (- h2 d2)
+			 (pict-ascent p))
+		     d2
+		     (map (lambda (c)
+			    (make-child 
+			     (child-pict c)
+			     (child-dx c)
+			     (+ dh (child-dy c))
+			     1 1))
+			  (pict-children p))
+		     #f)))
+
+      (define (drop p n)
+	(let* ([dh (- (max 0 (- n (pict-ascent p))))]
+	       [do-d? (= (pict-height p)
+			 (+ (pict-ascent p) (pict-descent p)))]
+	       [h2 (+ dh (pict-height p))]
+	       [a2  (max 0 (- (pict-ascent p) n))])
+	  (make-pict (pict-draw p)
+		     (pict-width p) h2
+		     a2
+		     (if do-d?
+			 (- h2 a2)
+			 (pict-descent p))
+		     (pict-children p)
+		     #f)))
+
+      (define (baseless p)
+	(let ([p (lift p (pict-descent p))])
+	  (drop p (- (pict-ascent p) (pict-height p)))))
+
+      (define (refocus p c)
+	(let-values ([(x y) (find-lt p c)])
+	  (let ([p (inset p 
+			  (- x) (- y (pict-height p)) 
+			  (- (- (pict-width p) x (pict-width c)))
+			  (- (pict-height c) y))])
+	    (make-pict (pict-draw p)
+		       (pict-width c) (pict-height c)
+		       (pict-ascent c) (pict-descent c)
+		       (pict-children p)
+		       #f))))
+
+      (define (panorama-box! p)
+	(let ([bb (pict-panbox p)])
+	  (if bb
+	      (values (bbox-x1 bb) (bbox-y1 bb) (bbox-x2 bb) (bbox-y2 bb)
+		      (bbox-ay bb) (bbox-dy bb))
+	      (let loop ([x1 0][y1 0][x2 (pict-width p)][y2 (pict-height p)]
+			 [ay (- (pict-height p) (pict-ascent p))][dy (pict-descent p)]
+			 [l (pict-children p)])
+		(if (null? l)
+		    (begin
+		      (set-pict-panbox! p (make-bbox x1 y1 x2 y2 ay dy))
+		      (values x1 y1 x2 y2 ay dy))
+		    (let ([c (car l)])
+		      (let-values ([(cx1 cy1 cx2 cy2 cay cdy) (panorama-box! (child-pict c))])
+			(loop (min x1 (* (+ cx1 (child-dx c)) (child-sx c)))
+			      (min y1 (* (+ cy1 (child-dy c)) (child-sy c)))
+			      (max x2 (* (+ cx2 (child-dx c)) (child-sx c)))
+			      (max y2 (* (+ cy2 (child-dy c)) (child-sy c)))
+			      (max ay (* (+ cay (child-dy c)) (child-sy c)))
+			      (min dy (* (+ cdy (child-dy c)) (child-sy c)))
+			      (cdr l)))))))))
+
+      (define (panorama p)
+	(let-values ([(x1 y1 x2 y2 ay dy) (panorama-box! p)])
+	  (let ([h (- y2 y1)])
+	    (place-over (blank (- x2 x1) h (- h ay) dy)
+			(- x1) (- y2 (pict-height p))
+			p))))
+
+      (define (clip-descent b)
+	(let* ([w (pict-width b)]
+	       [h (pict-height b)]
+	       [d (pict-descent b)])
+	  (extend-pict
+	   b 0 (- d) 
+	   0 0 (- d)
+	   `(picture ,w ,(- h d)
+		     (put 0 ,(- d) ,(pict-draw b))))))
+
+      (define (clip-ascent b)
+	(let* ([w (pict-width b)]
+	       [h (pict-height b)]
+	       [a (pict-descent b)])
+	  (extend-pict
+	   b 0 a
+	   0 (- a) 0
+	   `(picture ,w ,(- h a)
+		     (put 0 0 ,(pict-draw b))))))
+
+      (define (thickness mode b)
+	(let* ([w (pict-width b)]
+	       [h (pict-height b)])
+	  (extend-pict
+	   b 0 0 0 0 0
+	   `(picture ,w ,h
+		     (thickness ,mode ,(pict-draw b))))))
+
+      (define (thick b) (thickness 'thicklines b))
+      (define (thin b) (thickness 'thinlines b))
+      (define (line-thickness n b) (thickness n b))
+
+      (define inset
+	(case-lambda
+	 [(box a) (inset box a a a a)]
+	 [(box h v) (inset box h v h v)]
+	 [(box l t r b)
+	  (let ([w (+ l r (pict-width box))]
+		[h (+ t b (pict-height box))])
+	    (extend-pict
+	     box l b
+	     (+ l r) t b
+	     `(picture
+	       ,w ,h
+	       (put ,l ,b ,(pict-draw box)))))]))
+
+      (define dash-frame 
+	(case-lambda
+	 [(box) (dash-frame box default-seg)]
+	 [(box seg)
+	  (let ([w (pict-width box)]
+		[h (pict-height box)])
+	    (extend-pict
+	     box 0 0 0 0 0
+	     `(picture
+	       ,w ,h
+	       (put 0 0 ,(pict-draw box))
+	       (put 0 0 ,(pict-draw (dash-hline w 0 seg)))
+	       (put 0 ,h ,(pict-draw (dash-hline w 0 seg)))
+	       (put 0 0 ,(pict-draw (dash-vline 0 h seg)))
+	       (put ,w 0 ,(pict-draw (dash-vline 0 h seg))))))]))
+
+      (define (frame box)
+	(dash-frame box (max (pict-width box) (pict-height box))))
+
+      (define (dash-line width height rotate seg)
+	(let ([vpos (quotient* height 2)])
+	  (make-pict
+	   `(picture
+	     ,@(rotate width height)
+	     ,@(if (>= seg width)
+		   `((put ,@(rotate 0 vpos) (line ,@(rotate 1 0) ,width)))
+		   (let* ([remain (+ (- width (floor width))
+				     (remainder (floor width) (* 2 seg)))]
+			  [count (inexact->exact (floor (quotient* width (* 2 seg))))]
+			  [lremain (quotient* remain 2)]
+			  [rremain (- remain lremain)])
+		     `((put ,@(rotate 0 vpos) (line ,@(rotate 1 0) ,lremain))
+		       ,@(let loop ([count count][pos lremain])
+			   (if (zero? count)
+			       null
+			       (cons `(put ,@(rotate (+ pos seg) vpos) 
+					   (line ,@(rotate 1 0) ,seg))
+				     (loop (sub1 count) (+ pos seg seg)))))
+		       (put ,@(rotate (- width rremain) vpos) 
+			    (line ,@(rotate 1 0) ,rremain))))))
+	   (car (rotate width height))
+	   (cadr (rotate width height))
+	   (cadr (rotate 0 height)) 0
+	   null
+	   #f)))
+
+      (define (rlist b a) (list a b))
+
+      (define (hline width height)
+	(dash-line width height list width))
+
+      (define (vline width height)
+	(dash-line height width rlist height))
+
+      (define dash-hline
+	(case-lambda 
+	 [(width height) (dash-hline width height default-seg)]
+	 [(width height seg) (dash-line width height list seg)]))
+
+      (define dash-vline
+	(case-lambda 
+	 [(width height) (dash-vline width height default-seg)]
+	 [(width height seg) (dash-line height width rlist seg)]))
+
+      (define (oval box)
+	(let ([w (pict-width box)]
+	      [h (pict-height box)])
+	  (extend-pict
+	   box 0 0 0 0 0
+	   `(picture
+	     ,w ,h
+	     (put 0 0 ,(pict-draw box))
+	     (put ,(quotient* w 2) ,(quotient* h 2) (oval "" ,w ,h))))))
+
+      (define (oval/radius box r)
+	(let* ([w (pict-width box)]
+	       [h (pict-height box)]
+	       [rr (* 2 r)]
+	       [lw (- w rr)]
+	       [lh (- h rr)])
+	  (extend-pict
+	   box 0 0 0 0 0
+	   `(picture
+	     ,w ,h
+	     (put 0 0 ,(pict-draw box))
+	     (put ,r ,r (oval "[bl]" ,rr ,rr))
+	     (put ,r 0 (line 1 0 ,lw))
+	     (put ,(- w r) ,r (oval "[br]" ,rr ,rr))
+	     (put ,w ,r (line 0 1 ,lh))
+	     (put ,r ,(- h r) (oval "[tl]" ,rr ,rr))
+	     (put ,r ,h (line 1 0 ,lw))
+	     (put ,(- w r) ,(- h r) (oval "[tr]" ,rr ,rr))
+	     (put ,0 ,r (line 0 1 ,lh))))))
+
+      (define (big-circle d)
+	(let ([r (quotient* d 2)])
+	  (picture
+	   d d
+	   `((curve 0 ,r ,r 0 0 0)
+	     (curve ,r 0 ,d ,r ,d 0)
+	     (curve ,d ,r ,r ,d ,d ,d)
+	     (curve ,r ,d 0 ,r 0 ,d)))))
+
+      (define (ghost box)
+	(let ([w (pict-width box)]
+	      [h (pict-height box)])
+	  (extend-pict
+	   box 0 0 0 0 0
+	   `(picture
+	     ,w ,h))))
+
+      (define-values (vl-append 
+		      vc-append 
+		      vr-append 
+		      ht-append
+		      hc-append
+		      hb-append
+		      htl-append
+		      hbl-append)
+	(let ([make-append-boxes 
+	       (lambda (wcomb hcomb fxoffset fyoffset rxoffset ryoffset 
+			      combine-ascent combine-descent)
+                 (rec *-append
+                   (lambda (sep . args)
+                     (unless (number? sep)
+                       (set! args (cons sep args))
+                       (set! sep 0))
+                     (let append-boxes ([args args])
+                       (cond
+                         [(null? args) (blank)]
+                         [(null? (cdr args)) (car args)]
+                         [else
+                          (let* ([first (car args)]
+                                 [rest (append-boxes (cdr args))]
+                                 [w (wcomb (pict-width first) (pict-width rest) sep first rest)]
+                                 [h (hcomb (pict-height first) (pict-height rest) sep first rest)]
+                                 [fw (pict-width first)]
+                                 [fh (pict-height first)]
+                                 [rw (pict-width rest)]
+                                 [rh (pict-height rest)]
+                                 [fd1 (pict-ascent first)]
+                                 [fd2 (pict-descent first)]
+                                 [rd1 (pict-ascent rest)]
+                                 [rd2 (pict-descent rest)]
+                                 [dx1 (fxoffset fw fh rw rh sep fd1 fd2 rd1 rd2)]
+                                 [dy1 (fyoffset fw fh rw rh sep fd1 fd2 rd1 rd2 h)]
+                                 [dx2 (rxoffset fw fh rw rh sep fd1 fd2 rd1 rd2)]
+                                 [dy2 (ryoffset fw fh rw rh sep fd1 fd2 rd1 rd2 h)])
+                            (make-pict
+                             `(picture 
+                               ,w ,h
+                               (put ,dx1
+                                    ,dy1
+                                    ,(pict-draw first))
+                               (put ,dx2
+                                    ,dy2
+                                    ,(pict-draw rest)))
+                             w h
+                             (combine-ascent fd1 rd1 fd2 rd2 fh rh h (+ dy1 fh) (+ dy2 rh))
+                             (combine-descent fd2 rd2 fd1 rd1 fh rh h (- h dy1) (- h dy2))
+                             (list (make-child first dx1 dy1 1 1)
+                                   (make-child rest dx2 dy2 1 1))
+			     #f))])))))]
+	      [2max (lambda (a b c . rest) (max a b))]
+	      [zero (lambda (fw fh rw rh sep fd1 fd2 rd1 rd2 . args) 0)]
+	      [fv (lambda (a b . args) a)]
+	      [sv (lambda (a b . args) b)]
+	      [min2 (lambda (a b . args) (min a b))]
+	      [max2 (lambda (a b . args) (max a b))]
+              [3+ (lambda (a b c . args) (+ a b c))]
+              [a-max (lambda (a b c first rest)
+                       (+ (max (pict-ascent first) (pict-ascent rest))
+                          (max (- (pict-height first) (pict-ascent first))
+                               (- (pict-height rest) (pict-ascent rest)))))]
+              [d-max (lambda (a b c first rest)
+                       (+ (max (pict-descent first) (pict-descent rest))
+                          (max (- (pict-height first) (pict-descent first))
+                               (- (pict-height rest) (pict-descent rest)))))]
+	      [min-ad (lambda (a b oa ob ah bh h da db)
+			(- h (max oa ob) (max (- ah oa a)
+					      (- bh ob b))))]
+	      [xmin-ad (lambda (a b oa ob ah bh h da db)
+			 (min (+ (- h da) a) (+ (- h db) b)))])
+	  (values
+	   (make-append-boxes 2max 3+ 
+			      zero (lambda (fw fh rw rh sep . a) (+ sep rh))
+			      zero zero 
+			      fv sv)
+	   (make-append-boxes 2max 3+ 
+			      (lambda (fw fh rw rh sep . a) (quotient* (- (max fw rw) fw) 2))
+			      (lambda (fw fh rw rh sep . a) (+ sep rh))
+			      (lambda (fw fh rw rh sep . a) (quotient* (- (max fw rw) rw) 2))
+			      zero 
+			      fv sv)
+	   (make-append-boxes 2max 3+ 
+			      (lambda (fw fh rw rh sep . a) (- (max fw rw) fw))
+			      (lambda (fw fh rw rh sep . a) (+ sep rh))
+			      (lambda (fw fh rw rh sep . a) (- (max fw rw) rw))
+			      zero 
+			      fv sv)
+	   (make-append-boxes 3+ 2max
+			      zero
+			      (lambda (fw fh rw rh sep . a) (- (max fh rh) fh))
+			      (lambda (fw fh rw rh sep . a) (+ sep fw))
+			      (lambda (fw fh rw rh sep . a) (- (max fh rh) rh))
+			      xmin-ad xmin-ad)
+	   (make-append-boxes 3+ 2max
+			      zero
+			      (lambda (fw fh rw rh sep . a) (quotient* (- (max fh rh) fh) 2))
+			      (lambda (fw fh rw rh sep . a) (+ sep fw))
+			      (lambda (fw fh rw rh sep . a) (quotient* (- (max fh rh) rh) 2))
+			      xmin-ad xmin-ad)
+	   (make-append-boxes 3+ 2max 
+			      zero zero
+			      (lambda (fw fh rw rh sep . a) (+ sep fw)) zero
+			      xmin-ad xmin-ad)
+	   (make-append-boxes 3+ a-max
+			      zero
+			      (lambda (fw fh rw rh sep fd1 fd2 rd1 rd2 h) 
+				(- h fh (- (max fd1 rd1) fd1)))
+			      (lambda (fw fh rw rh sep . a) (+ sep fw))
+			      (lambda (fw fh rw rh sep fd1 fd2 rd1 rd2 h) 
+				(- h rh (- (max fd1 rd1) rd1)))
+			      max2 min-ad)
+	   (make-append-boxes 3+ d-max
+			      zero
+			      (lambda (fw fh rw rh sep fd1 fd2 rd1 rd2 h) 
+				(- (max fd2 rd2) fd2))
+			      (lambda (fw fh rw rh sep . a) (+ sep fw))
+			      (lambda (fw fh rw rh sep fd1 fd2 rd1 rd2 h) 
+				(- (max fd2 rd2) rd2))
+			      min-ad max2))))
+
+      (define-values (lt-superimpose
+		      lb-superimpose
+		      lc-superimpose
+		      ltl-superimpose
+		      lbl-superimpose
+		      rt-superimpose
+		      rb-superimpose
+		      rc-superimpose
+		      rtl-superimpose
+		      rbl-superimpose
+		      ct-superimpose
+		      cb-superimpose
+		      cc-superimpose
+		      ctl-superimpose
+		      cbl-superimpose)
+	(let ([make-superimpose 
+	       (lambda (get-h get-v get-th)
+		 (lambda boxes
+		   (let ([max-w (apply max (map pict-width boxes))]
+			 [max-h (apply max (map pict-height boxes))]
+			 [max-a (apply max (map pict-ascent boxes))]
+			 [max-a-complement (apply max (map (lambda (b) (- (pict-height b) (pict-ascent b)))
+							   boxes))]
+			 [max-d (apply max (map pict-descent boxes))]
+			 [max-d-complement (apply max (map (lambda (b) (- (pict-height b) (pict-descent b)))
+							   boxes))])
+		     (let ([p (picture max-w (get-th max-h max-a max-d max-a-complement max-d-complement)
+				       (map (lambda (box)
+					      `(place ,(get-h max-w (pict-width box))
+						      ,(get-v max-h (pict-height box)
+							      max-d (pict-descent box)
+							      max-a-complement (pict-ascent box))
+						      ,box))
+					    boxes))])
+		       ;; Figure out top and bottom baselines by finding the picts again, etc:
+		       (let ([ys (map (lambda (box)
+					(let-values ([(x y) (find-lt p box)])
+					  y))
+				      boxes)])
+			 (let ([min-a (apply min (map (lambda (box y)
+							(+ (- (pict-height p) y) (pict-ascent box)))
+						      boxes ys))]
+			       [min-d (apply min (map (lambda (box y)
+							(+ (- y (pict-height box)) (pict-descent box)))
+						      boxes ys))])
+			   (make-pict (pict-draw p)
+				      (pict-width p) (pict-height p)
+				      min-a min-d
+				      (pict-children p)
+				      #f)))))))]
+	      [norm (lambda (h a d ac dc) h)]
+	      [tbase (lambda (h a d ac dc) (+ a ac))] 
+	      [bbase (lambda (h a d ac dc) (+ d dc))] 
+	      [lb (lambda (m v . rest) 0)]
+	      [rt (lambda (m v . rest) (- m v))]
+	      [tline (lambda (m v md d mac a) (- mac (- v a)))]
+	      [bline (lambda (m v md d mac a) (- md d))]
+	      [c (lambda (m v . rest) (quotient* (- m v) 2))])
+	  (values
+	   (make-superimpose lb rt norm)
+	   (make-superimpose lb lb norm)
+	   (make-superimpose lb c norm)
+	   (make-superimpose lb tline tbase)
+	   (make-superimpose lb bline bbase)
+	   (make-superimpose rt rt norm)
+	   (make-superimpose rt lb norm)
+	   (make-superimpose rt c norm)
+	   (make-superimpose rt tline tbase)
+	   (make-superimpose rt bline bbase)
+	   (make-superimpose c rt norm)
+	   (make-superimpose c lb norm)
+	   (make-superimpose c c norm)
+	   (make-superimpose c tline tbase)
+	   (make-superimpose c bline bbase))))
+
+      (define table
+	(case-lambda
+	 [(ncol cells col-aligns row-aligns col-seps row-seps)
+	  (unless (positive? ncol)
+	    (raise-type-error 'table "positive column count" ncol))
+	  (let ([count (length cells)])
+	    (unless (zero? (remainder count ncol))
+	      (error 'table "cell count isn't divisble by the provided column count"))
+	    (let* ([w ncol]
+		   [h (/ count w)]
+		   [cells (let rloop ([r h][cells cells][r-acc null])
+			    (if (zero? r)
+				(list->vector (reverse r-acc))
+				(let loop ([c w][cells cells][one-acc null])
+				  (if (zero? c)
+				      (rloop (sub1 r) cells (cons (list->vector (reverse one-acc)) r-acc))
+				      (loop (sub1 c) (cdr cells) (cons (car cells) one-acc))))))]
+		   [imp-list->vector (lambda (l n)
+				       (let ([v (make-vector n)])
+					 (let loop ([l l][p 0])
+					   (unless (= n p)
+					     (vector-set! v
+							  p
+							  (if (pair? l)
+							      (car l)
+							      l))
+					     (loop (if (pair? l) (cdr l) l) (add1 p))))
+					 v))]
+		   [ralign (imp-list->vector row-aligns h)]
+		   [calign (imp-list->vector col-aligns w)]
+		   [rsep (imp-list->vector row-seps h)]
+		   [csep (imp-list->vector col-seps w)]
+		   [get-cell (lambda (c r) (vector-ref (vector-ref cells r) c))]
+		   [nmap (lambda (f w)
+			   (let loop ([n w][acc null])
+			     (if (zero? n)
+				 acc
+				 (loop (sub1 n) (cons (f (sub1 n)) acc)))))]
+		   [rowmap (lambda (f) (nmap f h))]
+		   [colmap (lambda (f) (nmap f w))]
+		   [superimposed-rows (list->vector
+				       (rowmap (lambda (r)
+						 (apply
+						  (vector-ref ralign r)
+						  (colmap (lambda (c) (get-cell c r)))))))]
+		   [superimposed-cols (list->vector
+				       (colmap (lambda (c)
+						 (apply
+						  (vector-ref calign c)
+						  (rowmap (lambda (r) (get-cell c r)))))))])
+	      ; No space after the last row/col
+	      (vector-set! rsep (sub1 h) 0)
+	      (vector-set! csep (sub1 w) 0)
+
+	      (apply
+	       vl-append
+	       0
+	       (rowmap
+		(lambda (r)
+		  (vl-append
+		   0
+		   (apply
+		    ht-append
+		    0
+		    (colmap (lambda (c)
+			      (ht-append
+			       0
+			       (let* ([cell (get-cell c r)]
+				      [sc (vector-ref superimposed-cols c)]
+				      [sr (vector-ref superimposed-rows r)]
+				      [w (pict-width sc)]
+				      [h (pict-height sr)])
+				 (let-values ([(x __) (find-lb sc cell)]
+					      [(_  y) (find-lb sr cell)])
+				   (picture
+				    w h
+				    `((place ,x ,y ,cell)))))
+			       (blank (vector-ref csep c) 0)))))
+		   (blank 0 (vector-ref rsep r))))))))]))
+
+      (define (record title . fields)
+	(let* ([totalwidth (apply max (pict-width title) (map pict-width fields))]
+	       [linespace (if (null? fields) 0 recordseplinespace)]
+	       [totalheight (+ (pict-height title) (apply + (map pict-height fields))
+			       linespace)]
+	       [title-y (- totalheight (pict-height title))]
+	       [field-ys (let loop ([pos (- totalheight (pict-height title) linespace)]
+				    [fields fields])
+			   (if (null? fields)
+			       null
+			       (let* ([p (- pos (pict-height (car fields)))])
+				 (cons p
+				       (loop p (cdr fields))))))])
+	  (make-pict
+	   `(picture
+	     ,totalwidth ,totalheight
+	     (put 0 0 (line 1 0 ,totalwidth))
+	     (put 0 ,totalheight (line 1 0 ,totalwidth))
+	     (put 0 0 (line 0 1 ,totalheight))
+	     (put ,totalwidth 0 (line 0 1 ,totalheight))
+	     (put 0 ,title-y ,(pict-draw title))
+	     ,@(if (null? fields)
+		   '()
+		   `((put 0 ,(- totalheight (pict-height title) (quotient* linespace 2))
+			  (line 1 0 ,totalwidth))))
+	     ,@(map (lambda (f p) `(put 0 ,p ,(pict-draw f)))
+		    fields field-ys))
+	   totalwidth totalheight
+	   totalheight 0
+	   (cons
+	    (make-child title 0 title-y 1 1)
+	    (map (lambda (child child-y) (make-child child 0 child-y 1 1)) fields field-ys))
+	   #f)))
+
+      (define (picture* w h a d commands)
+	(let loop ([commands commands][translated null][children null])
+	  (if (null? commands)
+	      (make-pict
+	       `(picture ,w ,h
+			 ,@(reverse translated))
+	       w h a d
+	       children
+	       #f)
+	      (let ([c (car commands)]
+		    [rest (cdr commands)])
+		(unless (and (pair? c) (symbol? (car c)))
+		  (error 'picture "bad command: ~a" c))
+		(case (car c)
+		  [(connect) (loop rest
+				   (append (apply connect (cdr c))
+					   translated)
+				   children)]
+		  [(dconnect) (loop rest
+				    (let ([x (cadr c)]
+					  [y (caddr c)]
+					  [dx (cadddr c)]
+					  [dy (list-ref c 4)])
+				      (append (connect x y (+ x dx) (+ y dy)
+						       (if (null? (list-tail c 5))
+							   #t
+							   (list-ref c 5)))
+					      translated))
+				    children)]
+		  [(connect~y) (loop rest
+				     (append (apply ~connect 'x (cdr c))
+					     translated)
+				     children)]
+		  [(connect~x) (loop rest
+				     (append (apply ~connect 'y (cdr c))
+					     translated)
+				     children)]
+		  [(connect~xy) (loop rest
+				      (append (apply ~connect 'r (cdr c))
+					      translated)
+				      children)]
+		  [(curve) (loop rest
+				 (let ([x1 (cadr c)]
+				       [y1 (caddr c)]
+				       [x2 (cadddr c)]
+				       [y2 (list-ref c 4)]
+				       [xm (list-ref c 5)]
+				       [ym (list-ref c 6)]
+				       [d (if (null? (list-tail c 7))
+					      1.0
+					      (list-ref c 7))])
+				   (let ([p (if (and d (>= d 0))
+						(inexact->exact (floor (* d (sqrt (+ (expt (- x2 x1) 2) (expt (- y2 y1) 2))))))
+						#f)])
+				     (if (and (= x1 x2) (= y1 y2))
+					 translated
+					 (cons `(qbezier ,p ,x1 ,y1 ,xm ,ym ,x2 ,y2)
+					       translated))))
+				 children)]
+		  [(place) (let ([x (cadr c)]
+				 [y (caddr c)]
+				 [p (cadddr c)])
+			     (loop rest
+				   (cons
+				    `(put ,x ,y ,(pict-draw p))
+				    translated)
+				   (cons
+				    (make-child p x y 1 1)
+				    children)))]
+		  [else (loop rest (cons c translated) children)])))))
+
+      (define (picture w h commands)
+	(picture* w h h 0 commands))
+
+      (define (cons-picture p commands)
+	(picture
+	 (pict-width p) (pict-height p)
+	 (cons
+	  `(place 0 0 ,p)
+	  commands)))
+
+      (define (cons-picture* p commands)
+	(picture*
+	 (pict-width p) (pict-height p)
+	 (pict-ascent p) (pict-descent p)
+	 (cons
+	  `(place 0 0 ,p)
+	  commands)))
+
+      (define (place-it who flip? base dx dy target)
+	(let-values ([(dx dy)
+		      (cond
+		       [(and (number? dx) (number? dy))
+			(values dx (- (pict-height base) dy))]
+		       [(and (pict? dx) (procedure? dy)
+			     (procedure-arity-includes? dy 2))
+			(if flip?
+			    (let-values ([(dx dy) (dy base dx)])
+			      (values dx (- (pict-height base) dy)))
+			    (dy base dx))]
+		       [else
+			(error who
+			       "expects two numbers or a sub-pict and a find procedure")])])
+	  (cons-picture*
+	   base
+	   `((place ,dx ,(- dy (pict-height target)) ,target)))))
+
+      (define (place-over base dx dy target)
+	(place-it 'place-over #f base dx dy target))
+      (define (place-under base dx dy target)
+	(cc-superimpose
+	 (place-it 'place-under #f (ghost base) dx dy target)
+	 base))
+
+      (define (pin-over base dx dy target)
+	(place-it 'pin-over #t base dx dy target))
+      (define (pin-under base dx dy target)
+	(cc-superimpose
+	 (place-it 'pin-under #t (ghost base) dx dy target)
+	 base))
+
+      (define black-and-white
+	(make-parameter #f
+			(lambda (x)
+			  (and x #t))))
+
+      (define colorize
+        (case-lambda
+          [(p color)
+           (if (black-and-white)
+               p
+               (extend-pict 
+                p 0 0 0 0 0
+                `(color ,color ,(pict-draw p))))]))
+
+      (define (optimize s)
+	(let o-loop ([s s][dx 0][dy 0])
+	  (if (string? s)
+	      s
+	      (let ([tag (car s)])
+		(case tag
+		  [(picture)
+		   (list* 'picture (cadr s) (caddr s)
+			  (map optimize (cdddr s)))]
+		  [(color)
+		   (let ([next (caddr s)])
+		     (if (and (pair? next) (eq? (car next) 'color))
+			 (optimize next)
+			 (list* 'color (cadr s) 
+				(list 'put dx dy (optimize next)))))]
+		  [(thickness)
+		   (let ([t (cadr s)]
+			 [p (caddr s)])
+		     (list 'put dx dy 
+			   (list 'thickness t 
+				 (optimize p))))]
+		  [(put)
+		   (let ([x (cadr s)]
+			 [y (caddr s)]
+			 [next (cadddr s)])
+		     (if (and (pair? next) (eq? (car next) 'picture))
+			 ; optmize put-picture to just contents ...
+			 (cons 'begin (map (lambda (s) (o-loop s (+ x dx) (+ y dy))) (cdddr next)))
+			 ; normal
+			 (list 'put (+ x dx) (+ y dy) (optimize next))))]
+		  [(qbezier)
+		   (let ([x1 (list-ref s 2)]
+			 [y1 (list-ref s 3)]
+			 [xm (list-ref s 4)]
+			 [ym (list-ref s 5)]
+			 [x2 (list-ref s 6)]
+			 [y2 (list-ref s 7)]
+			 [p (list-ref s 1)])
+		     (list 'qbezier p
+			   (+ x1 dx) (+ y1 dy)
+			   (+ xm dx) (+ ym dy)
+			   (+ x2 dx) (+ y2 dy)))]
+		  [(frame)
+		   (list 'frame (optimize (cadr s)))]
+		  [(colorbox)
+		   (list 'colorbox (cadr s) (optimize (caddr s)))]
+		  [(line vector dirline dirvector circle circle* make-box oval prog) s]
+		  [else (error 'optimize "bad tag: ~s" tag)])))))
+
+      (define (fixup-top s)
+	(cond
+	 [(and (pair? s) (eq? (car s) 'color))
+	  ;; Drop initial put
+	  (list* 'color (cadr s) (caddr (cdddr s)))]
+	 [(and (pair? s) (eq? (car s) 'put))
+	  ;; Wrap initial put (from thickness) in a pair of braces
+	  `(local ,(cadddr s))]
+	 [else
+	  ;; Do nothing
+	  s]))
+
+      (define (prepare-for-output s)
+	(fixup-top (optimize (pict-draw s))))
+
+      (define (pict->command-list s)
+	(let output ([s (prepare-for-output s)])
+	  (if (string? s)
+	      (list s)
+	      (let ([tag (car s)])
+		(case tag
+		  [(local)
+		   (output (cadr s))]
+		  [(begin)
+		   (apply append (map output (cdr s)))]
+		  [(picture)
+		   (apply append (map output (cdddr s)))]
+		  [(color)
+		   `((with-color ,(cadr s) ,(output (cddr s))))]
+		  [(thickness)
+		   `((with-thickness ,(cadr s) ,(output (caddr s))))]
+		  [(put)
+		   `((offset ,(cadr s) ,(caddr s) ,(output (cadddr s))))]
+		  [(qbezier)
+		   `((bezier ,@(cddr s)))]
+		  [(line vector)
+		   `((,tag ,(cadr s) ,(caddr s) ,(cadddr s)))]
+		  [(circle circle*)
+		   `((,tag ,(cadr s)))]
+		  [(frame)
+		   `((frame ,(output (cadr s))))]
+		  [(colorbox)
+		   `((colorbox ,(cadr s) ,(output (caddr s))))]
+		  [(oval)
+		   `((oval ,(caddr s) ,(cadddr s) ,(cadr s)))]
+		  [(make-box)
+		   `((make-box ,(cadr s) ,(caddr s) ,(cadddr s) ,(car (cddddr s))))]
+		  [(prog)
+		   `((prog ,(cadr s) ,(caddr s)))]
+		  [else (error 'pict->commands "bad tag: ~s" tag)])))))
+      )))
diff --git a/collects/texpict/private/info.ss b/collects/texpict/private/info.ss
new file mode 100644
index 0000000000..262f25776f
--- /dev/null
+++ b/collects/texpict/private/info.ss
@@ -0,0 +1,3 @@
+
+(module info (lib "infotab.ss" "setup")
+  (define name "Texpict private"))
diff --git a/collects/texpict/private/mrpict-extra.ss b/collects/texpict/private/mrpict-extra.ss
new file mode 100644
index 0000000000..b58aac0ecb
--- /dev/null
+++ b/collects/texpict/private/mrpict-extra.ss
@@ -0,0 +1,422 @@
+
+(module mrpict-extra mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "class.ss")
+           (lib "etc.ss"))
+
+  (require (lib "mred-sig.ss" "mred"))
+
+  (require "mrpict-sig.ss"
+	   "common-sig.ss")
+
+  (provide mrpict-extra@)
+  (define mrpict-extra@
+    (unit/sig ((open mrpict-extra^)
+	       (open texpict-common-setup^))
+      (import mred^
+	      ((open texpict-common^)
+	       (open texpict-internal^)))
+
+      (define show-pict
+        (opt-lambda (p [w #f] [h #f])
+          (define the-pict p)
+          (define pict-drawer (make-pict-drawer the-pict))
+          (define no-redraw? #f)
+          (define pict-frame%
+            (class frame%
+              (define/public (set-pict p)
+                (set! the-pict p)
+                (set! pict-drawer (make-pict-drawer the-pict))
+                (set! no-redraw? #t)
+                (let ([pw (inexact->exact (floor (pict-width the-pict)))]
+                      [ph (inexact->exact (floor (pict-height the-pict)))])
+                  (send c min-width (if w (max w pw) pw))
+                  (send c min-height (if h (max h ph) ph)))
+                (set! no-redraw? #f)
+                (send c on-paint))
+              (super-instantiate ())))
+          (define pict-canvas%
+            (class canvas%
+              (inherit get-dc)
+              (define/override (on-paint)
+                (unless no-redraw?
+                  (let ([dc (get-dc)])
+                    (send dc clear)
+                    (let* ([pw (pict-width the-pict)]
+                           [ph (pict-height the-pict)]
+                           [xo (if (and w
+                                        (pw . < . w))
+                                   (- (/ w 2) (/ pw 2))
+                                   0)]
+                           [yo (if (and h
+                                        (ph . < . h))
+                                   (- (/ h 2) (/ ph 2))
+                                   0)])
+                      (pict-drawer dc xo yo)))))
+              (super-instantiate ())))
+          (define f (make-object pict-frame% "MrPict"))
+          (define c (make-object pict-canvas% f))
+          (send f set-pict p)
+          (send f show #t)))
+      
+      (define dc-for-text-size (make-parameter 
+				#f
+				(lambda (x)
+				  (unless (or (not x)
+					      (is-a? x dc<%>))
+				    (raise-type-error 'dc-for-parameter "dc<%> object or #f" x))
+				  x)))
+
+      (define dc 
+	(case-lambda
+	 [(f w h a d)
+	  (make-pict `(prog ,f ,h) w h a d null #f)]
+	 [(f w h)
+	  (dc f w h h 0)]))
+      (define prog-picture dc)
+
+      (define current-expected-text-scale (make-parameter (list 1 1)))
+      (define (with-text-scale dc thunk)
+	(let ([x (current-expected-text-scale)])
+	  (if (equal? x '(1 1))
+	      (thunk)
+	      (begin
+		(send dc set-scale (car x) (cadr x))
+		(let-values ([(w h d s) (thunk)])
+		  (send dc set-scale 1 1)
+	          (values w h d s))))))
+
+      (define (memq* a l)
+	(if (pair? l)
+	    (or (eq? (car l) a)
+		(memq* a (cdr l)))
+	    #f))
+
+      (define (extend-font font size style weight)
+	(if (send font get-face)
+	    (send the-font-list find-or-create-font
+		  size 
+		  (send font get-face)
+		  (send font get-family)
+		  style
+		  weight
+		  #f
+		  'default
+		  #t)
+	    (send the-font-list find-or-create-font
+		  size 
+		  (send font get-family)
+		  style
+		  weight
+		  #f
+		  'default
+		  #t)))
+
+      (define text
+	(case-lambda
+	 [(string) (text string '() 12)]
+	 [(string style) (text string style 12)]
+	 [(string style size) (text string style size 0)]
+	 [(string orig-style size angle)
+	  (let ([font
+		 (let loop ([style orig-style])
+		   (cond
+		    [(null? style) 
+		     (send the-font-list find-or-create-font
+			   size 'default 'normal 'normal #f 'default #t)]
+		    [(is-a? style font%)
+		     style]
+		    [(memq style '(default decorative roman script swiss modern symbol system))
+		     (send the-font-list find-or-create-font
+			   size style 'normal 'normal #f 'default #t)]
+		    [(string? style)
+		     (send the-font-list find-or-create-font
+			   size style 'default 'normal 'normal #f 'default #t)]
+		    [(string? style)
+		     (send the-font-list find-or-create-font
+			   size style 'default 'normal 'normal #f 'default #t)]
+		    [(and (pair? style)
+			  (memq (car style)
+				'(superscript 
+				  subscript
+				  bold italic)))
+		     (let ([font (loop (cdr style))]
+			   [style (car style)])
+		       (cond
+			[(eq? style 'bold)
+			 (extend-font font
+				      (send font get-point-size)
+				      (send font get-style)
+				      'bold)]
+			[(eq? style 'italic)
+			 (extend-font font
+				      (send font get-point-size)
+				      'italic
+				      (send font get-weight))]
+			[else font]))]
+		    [(and (pair? style)
+			  (memq (car style) '(combine no-combine)))
+		     (loop (cdr style))]
+		    [else (raise-type-error 'text
+					    "style"
+					    orig-style)]))]
+		[combine? (let loop ([style orig-style])
+			    (cond
+			     [(eq? style 'modern) #f]
+			     [(not (pair? style)) #t]
+			     [(eq? (car style) 'combine) #t]
+			     [(eq? (car style) 'no-combine) #f]
+			     [else (loop (cdr style))]))]
+		[sub? (memq* 'subscript orig-style)]
+		[sup? (memq* 'superscript orig-style)])
+	    (let ([s-font (if (or sub? sup?)
+			      (extend-font font
+					   (floor (* 1/2 (send font get-point-size)))
+					   (send font get-style)
+					   (send font get-weight))
+			      font)]
+		  [dc (dc-for-text-size)])
+	      (unless dc
+		(error 'text "no dc<%> object installed for sizing"))
+	      (let-values ([(w h d s) (with-text-scale
+				       dc
+				       (lambda ()
+					 (send dc get-text-extent string s-font combine?)))])
+		(if (or sub? sup?)
+		    (let-values ([(ww wh wd ws) (with-text-scale
+						 dc
+						 (lambda ()
+						   (send dc get-text-extent "Wy" font)))])
+		      (prog-picture (lambda (dc x y)
+				      (let ([f (send dc get-font)])
+					(send dc set-font s-font)
+					(send dc draw-text string
+					      x (if sub?
+						    (+ y (- wh h))
+						    y)
+					      combine?)
+					(send dc set-font f)))
+				    w wh (- wh wd) wd))
+		    (if (zero? angle)
+			;; Normal case: no rotation
+			(prog-picture (lambda (dc x y)
+					(let ([f (send dc get-font)])
+					  (send dc set-font font)
+					  (send dc draw-text string x y combine?)
+					  (send dc set-font f)))
+				      w h (- h d) d)
+			;; Rotation case. Need to find the bounding box.
+			;; Calculate the four corners, relative to top left as origin:
+			(let* ([tlx 0]
+			       [tly 0]
+			       [ca (cos angle)]
+			       [sa (sin angle)]
+			       [trx (* w ca)]
+			       [try (- (* w sa))]
+			       [brx (+ trx (* h sa))]
+			       [bry (- try (* h ca))]
+			       [blx (* h sa)]
+			       [bly (- (* h ca))]
+			       ;;min-x and min-y must be non-positive,
+			       ;; since tlx and tly are always 0
+			       [min-x (min tlx trx blx brx)]
+			       [min-y (min tly try bly bry)])
+			  (let ([pw (- (max tlx trx blx brx) min-x)]
+				[ph (- (max tly try bly bry) min-y)]
+				[dx (cond
+				     [(and (positive? ca) (positive? sa)) 0]
+				     [(positive? ca) (- (* h sa))]
+				     [(positive? sa) (- (* w ca))]
+				     [else (+ (- (* w ca)) (- (* h sa)))])]
+				[dy (cond
+				     [(and (positive? ca) (negative? sa)) 0]
+				     [(positive? ca) (* w sa)]
+				     [(negative? sa) (- (* h ca))]
+				     [else (+ (- (* h ca)) (* w sa))])])
+			    (prog-picture (lambda (dc x y)
+					    (let ([f (send dc get-font)])
+					      (send dc set-font font)
+					      (send dc draw-text string (+ x dx) (+ y dy)
+						    combine? 0 angle)
+					      (send dc set-font f)))
+					  pw ph ph 0))))))))]))
+
+      (define caps-text
+	(case-lambda
+	 [(string) (caps-text string '() 12)]
+	 [(string style) (caps-text string style 12)]
+	 [(string style size)
+	  (let ([strings
+		 (let loop ([l (string->list string)][this null][results null][up? #f])
+		   (if (null? l)
+		       (reverse! (cons (reverse! this) results))
+		       (if (eq? up? (char-upper-case? (car l)))
+			   (loop (cdr l) (cons (car l) this) results up?)
+			   (loop (cdr l) (list (car l)) (cons (reverse! this) results) (not up?)))))]
+		[cap-style
+		 (let loop ([s style])
+		   (cond
+		    [(pair? s) (cons (car s) (loop (cdr s)))]
+		    [(is-a? s font%) (send the-font-list find-or-create-font
+					   (floor (* 8/10 (send s get-point-size)))
+					   (send s get-family)
+					   (send s get-style)
+					   (send s get-weight)
+					   (send s get-underlined?)
+					   (send s get-smoothing)
+					   (send s get-size-in-pixels?))]
+		    [else s]))]
+		[cap-size (floor (* 8/10 size))])
+	    (let ([picts
+		   (let loop ([l strings][up? #f])
+		     (if (null? l)
+			 null
+			 (cons (text (list->string (map char-upcase (car l)))
+				     (if up? style cap-style)
+				     (if up? size cap-size))
+			       (loop (cdr l) (not up?)))))])
+	      (apply hbl-append 0 picts)))]))
+
+      (define (linewidth n p) (line-thickness n p))
+
+      (define connect
+	(case-lambda
+	 [(x1 y1 x2 y2) (connect x1 y1 x2 y2 #f)]
+	 [(x1 y1 x2 y2 arrow?) (~connect 'r +inf.0 x1 y1 x2 y2 arrow?)]))
+
+      (define ~connect 
+	(case-lambda
+	 [(exact close-enough x1 y1 x2 y2) (~connect exact close-enough x1 y1 x2 y2 #f)]
+	 [(exact close-enough x1 y1 x2 y2 arrow?)
+	  `((put ,x1 ,y1 (,(if arrow? 'vector 'line) ,(- x2 x1) ,(- y2 y1) #f)))]))
+
+      (define (render dc h+top l dx dy)
+	(define b&w? #f)
+	
+	(with-method ([draw-line (dc draw-line)]
+		      [draw-spline (dc draw-spline)]
+		      [draw-ellipse (dc draw-ellipse)]
+		      [get-pen (dc get-pen)]
+		      [get-brush (dc get-brush)]
+		      [get-text-foreground (dc get-text-foreground)]
+		      [set-pen (dc set-pen)]
+		      [set-brush (dc set-brush)]
+		      [set-text-foreground (dc set-text-foreground)]
+		      [find-or-create-pen (the-pen-list find-or-create-pen)]
+		      [find-or-create-brush (the-brush-list find-or-create-brush)])
+
+	  (set-brush (find-or-create-brush "black" 'solid))
+	  
+	  (let loop ([dx dx][dy dy][l l])
+	    (unless (null? l)
+	      (let ([x (car l)])
+		(if (string? x)
+		    (error 'draw-pict "how did a string get here?: ~s" x)
+		    (case (car x)
+		      [(offset) (loop (+ dx (cadr x))
+				      (+ dy (caddr x))
+				      (cadddr x))]
+		      [(line vector)
+		       (let ([xs (cadr x)]
+			     [ys (caddr x)]
+			     [len (cadddr x)])
+			 (let ([mx (if len (abs (if (zero? xs) ys xs)) 1)]
+			       [len (or len 1)])
+			   (draw-line dx (- h+top dy)
+				      (+ dx (* (/ xs mx) len)) (- h+top (+ dy (* (/ ys mx) len))))))]
+		      [(circle circle*)
+		       (let ([size (cadr x)])
+			 (draw-ellipse (- dx (/ size 2)) (- h+top dy (/ size 2))
+				       size size))]
+		      [(oval)
+		       (let ([b (get-brush)]
+			     [rx (- dx (/ (cadr x) 2))]
+			     [ry (- h+top dy (/ (caddr x) 2))])
+			 (set-brush (find-or-create-brush "BLACK" 'transparent))
+			 (let ([part (cadddr x)]
+			       [cr (send dc get-clipping-region)]
+			       [set-rect (lambda (l t r b)
+					   (let ([cr (make-object region% dc)])
+					     (send cr set-rectangle
+						   (+ rx (* l (cadr x)))
+						   (+ ry (* t (caddr x)))
+						   (* (- r l) (cadr x))
+						   (* (- b t) (caddr x)))
+					     cr))])
+			   (send dc set-clipping-region
+				 (cond
+				  [(string=? part "[l]")
+				   (set-rect 0 0 0.5 1.0)]
+				  [(string=? part "[tl]")
+				   (set-rect 0 0 0.5 0.5)]
+				  [(string=? part "[tr]")
+				   (set-rect 0.5 0 1.0 0.5)]
+				  [(string=? part "[r]")
+				   (set-rect 0.5 0 1.0 1.0)]
+				  [(string=? part "[bl]")
+				   (set-rect 0 0.5 0.5 1.0)]
+				  [(string=? part "[br]")
+				   (set-rect 0.5 0.5 1.0 1.0)]
+				  [else cr]))
+			   (send dc draw-rounded-rectangle
+				 rx ry
+				 (cadr x) (caddr x)
+				 (if (string=? part "") -0.2 -0.5))
+			   (send dc set-clipping-region cr)
+			   (set-brush b)))]
+		      [(bezier)
+		       (draw-spline (+ dx (list-ref x 1))
+				    (- h+top (+ dy (list-ref x 2)))
+				    (+ dx (list-ref x 3))
+				    (- h+top (+ dy (list-ref x 4)))
+				    (+ dx (list-ref x 5))
+				    (- h+top (+ dy (list-ref x 6))))]
+		      [(with-color)
+		       (if b&w?
+			   (loop dx dy (caddr x))
+			   (let ([p (get-pen)]
+				 [b (get-brush)]
+				 [fg (get-text-foreground)])
+			     (let* ([requested-color (cond
+                                                       [(is-a? (cadr x) color%) (cadr x)]
+                                                       [(string? (cadr x))
+                                                        (send the-color-database find-color (cadr x))]
+                                                       [(list? (cadr x))
+                                                        (apply make-object color% (cadr x))])]
+				    [color (or requested-color 
+					       (send the-color-database find-color "BLACK"))])
+			       (unless requested-color
+				 (fprintf (current-error-port)
+					  "WARNING: couldn't find color: ~s~n" (cadr x)))
+			       (set-pen (find-or-create-pen color (send p get-width) 'solid))
+			       (set-brush (find-or-create-brush color 'solid))
+			       (set-text-foreground color))
+			     (loop dx dy (caddr x))
+			     (set-pen p)
+			     (set-brush b)
+			     (set-text-foreground fg)))]
+		      [(with-thickness)
+		       (let ([p (get-pen)])
+			 (set-pen (find-or-create-pen (send p get-color) 
+						      (if (number? (cadr x))
+							  (cadr x)
+							  (if (eq? (cadr x) 'thicklines)
+							      1
+							      0))
+						      'solid))
+			 (loop dx dy (caddr x))
+			 (set-pen p))]
+		      [(prog)
+		       ((cadr x) dc dx (- h+top dy (caddr x)))]
+		      [else (error 'render "unknown command: ~a~n" x)])))
+	      (loop dx dy (cdr l))))))
+
+      (define (make-pict-drawer p)
+	(let ([cmds (pict->command-list p)])
+	  (lambda (dc dx dy)
+	    (render dc (+ (pict-height p) dy)
+		    cmds
+		    dx 0))))
+
+      (define (draw-pict p dc dx dy)
+	((make-pict-drawer p) dc dx dy)))))
diff --git a/collects/texpict/private/mrpict-sig.ss b/collects/texpict/private/mrpict-sig.ss
new file mode 100644
index 0000000000..16430736a5
--- /dev/null
+++ b/collects/texpict/private/mrpict-sig.ss
@@ -0,0 +1,14 @@
+
+(module mrpict-sig mzscheme
+  (require (lib "unitsig.ss"))
+
+  (provide mrpict-extra^)
+  (define-signature mrpict-extra^
+    (dc-for-text-size
+     show-pict
+     text caps-text current-expected-text-scale
+     dc
+     linewidth
+     
+     draw-pict
+     make-pict-drawer)))
diff --git a/collects/texpict/private/texpict-extra.ss b/collects/texpict/private/texpict-extra.ss
new file mode 100644
index 0000000000..d6e1397cee
--- /dev/null
+++ b/collects/texpict/private/texpict-extra.ss
@@ -0,0 +1,470 @@
+
+(module texpict-extra mzscheme
+  (require (lib "unitsig.ss")
+	   (lib "etc.ss")
+	   (lib "list.ss"))
+
+  (require "texpict-sig.ss"
+	   "common-sig.ss")
+
+  (provide texpict-extra@)
+  (define texpict-extra@
+    (unit/sig ((open texpict-extra^)
+	       (open texpict-common-setup^))
+      (import ((open texpict-common^)
+	       (open texpict-internal^)))
+
+      (define using-pict2e-package
+	(make-parameter #f
+			(lambda (x)
+			  (and x #t))))
+
+      (define use-old-connect
+	(make-parameter #f
+			(lambda (x)
+			  (and x #t))))
+
+      (define output-measure-commands
+	(make-parameter #t
+			(lambda (x)
+			  (and x #t))))
+
+      (define draw-bezier-lines
+	(make-parameter #f
+			(lambda (x)
+			  (if (procedure? x)
+			      (begin
+				(unless (procedure-arity-includes? x 1)
+				  (raise-type-error 'draw-bezier-lines
+						    "boolean or procedure of one argument"
+						    x))
+				x)
+			      (and x #t)))))
+
+      (define serialize-tex-picts
+	(make-parameter #f
+			(lambda (x)
+			  (and x #t))))
+
+      (define tex-series-prefix
+	(make-parameter #f
+			(lambda (s)
+			  (when s
+			    (unless (string? s)
+			      (raise-type-error 'tex-series-prefix "string or #f" s)))
+			  s)))
+
+      (define current-tex-sizer
+	(make-parameter (lambda (t) #f)))
+
+      (define label-sizes null)
+      (define (extract-num s) ; strip off trainling `pt'
+	(let ([str (symbol->string s)])
+	  (inexact->exact
+	   (ceiling
+	    (string->number (substring str 0 (- (string-length str) 2)))))))
+
+      (define (read-in-sizes file)
+	(parameterize ([read-case-sensitive #t])
+	  (when (file-exists? file)
+	    (set! label-sizes
+		  (append (with-input-from-file file
+			    (lambda ()
+			      (let loop ()
+				(let ([e (read)])
+				  (if (eof-object? e)
+				      null
+				      (let ([w (read)]
+					    [h (read)]
+					    [d (read)])
+					(cons (list e
+						    (extract-num w) 
+						    (extract-num h)
+						    (extract-num d))
+					      (loop))))))))
+			  label-sizes)))))
+
+      ;; Marshall a tex string into a simple symbol
+      (define digits (make-vector 64))
+      (let loop ([i 0])
+	(unless (= i 10)
+	  (vector-set! digits i (integer->char (+ i (char->integer #\0))))
+	  (loop (add1 i))))
+      (let loop ([i 0])
+	(unless (= i 26)
+	  (vector-set! digits (+ i 10) (integer->char (+ i (char->integer #\a))))
+	  (vector-set! digits (+ i 36) (integer->char (+ i (char->integer #\A))))
+	  (loop (add1 i))))
+      (vector-set! digits 62 #\-)
+      (vector-set! digits 63 #\+)
+      (define (number->base-64-string prefix n)
+	(let loop ([n n][s null])
+	  (if (zero? n)
+	      (list->string (cons prefix s))
+	      (loop (arithmetic-shift n -6)
+		    (cons (vector-ref digits (bitwise-and 63 n)) s)))))
+      (define serial-number 0)
+      (define (serialize s)
+	(cond
+	 [(serialize-tex-picts)
+	  (set! serial-number (add1 serial-number))
+	  (format "~a.~a" serial-number s)]
+	 [(tex-series-prefix)
+	  (format "~a.~a" (tex-series-prefix) s)]
+	 [else s]))
+      (define (make-label s)
+	(string->symbol
+	 (serialize
+	  (number->base-64-string
+	   #\T
+	   (let loop ([l (string->list s)][n 0])
+	     (if (null? l)
+		 n
+		 (loop (cdr l) (+ (arithmetic-shift n 7) (char->integer (car l))))))))))
+
+      (define tex
+	(case-lambda
+	 [(t) (tex t 10 10)]
+	 [(t guess-width guess-height)
+	  (let* ([label (make-label t)]
+		 [info (or (assq label label-sizes)
+			   (let ([v ((current-tex-sizer) t)])
+			     (and v
+				  (cons label v))))]
+		 [w (if info (cadr info) guess-width)]
+		 [h (if info (caddr info) guess-height)]
+		 [d (if info (cadddr info) guess-height)])
+	    (make-pict `(picture ,w ,(+ d h)
+				 (put 0 ,d
+				      ,(if (output-measure-commands)
+					   (format "\\mztpMeasure{~a}{~a}"
+						   t label)
+					   t)))
+		       w
+		       (+ d h)
+		       h d
+		       null
+		       #f))]))
+
+      (define (text-line/phantom text phantom . args)
+	(apply tex (format "\\makebox[0pt]{\\vphantom{~a}}~a" phantom text) args))
+
+      (define (text-line text . args)
+	(apply text-line/phantom text "Xy" args))
+
+      (define (tex-no-descent . args)
+	(clip-descent (apply tex args)))
+
+      (define tex-paragraph
+	(case-lambda
+	 [(w str) (tex-paragraph w str 'top)]
+	 [(w str align)
+	  (tex (format "\\parbox[~a]{~apt}{~a}"
+		       (case align
+			 [(top) 't]
+			 [(bottom) 'b]
+			 [else (error 'tex-paragraph "bad alignment: ~a" align)])
+		       w
+		       str))]))
+
+      (define delimit-str
+	"\\hbox{$\\~a{\\hbox{$\\left~a\\rule{0pt}{~apt}\\right.$}}$}")
+
+      (define (mk-delimit left? middle? right? delim h)
+	(let ([str (format delimit-str
+			   (cond
+			    [left? "mathopen"]
+			    [right? "mathclose"]
+			    [middle? "mathrel"])
+			   delim
+			   h)])
+	  (tex str 10 h)))
+
+      (define (left-delimit delim h)
+	(mk-delimit #t #f #f delim h))
+      (define (middle-delimit delim h)
+	(mk-delimit #f #t #f delim h))
+      (define (right-delimit delim h)
+	(mk-delimit #f #f #t delim h))
+
+      (define (left-brace h)
+	(left-delimit "\\{" h))
+      (define (right-brace h)
+	(right-delimit "\\}" h))
+
+      (define (make-h-brace kind w)
+	(tex (format "$\\~a{\\hbox{\\begin{picture}(~a,0)(0,0)\\end{picture}}}$"
+		     kind w)))
+
+      (define (top-brace w)
+	(make-h-brace "overbrace" w))
+      (define (bottom-brace w)
+	(make-h-brace "underbrace" w))
+
+      (define (generate-possible-slopes n)
+	(let ([positives
+	       (quicksort
+		(remove-duplicates
+		 (apply append (build-list n
+					   (lambda (i)
+					     (build-list n
+							 (lambda (j) (/ (+ i 1) (+ j 1))))))))
+		<=)])
+	  (append
+	   (reverse (map - positives))
+	   (list 0)
+	   positives)))
+
+      (define (remove-duplicates lst)
+	(cond
+	 [(null? lst) null]
+	 [else (cons (car lst)
+		     (remove-duplicates
+		      (filter
+		       (lambda (x) (not (equal? x (car lst))))
+		       (cdr lst))))]))
+
+      (define possible-arrow-slopes (generate-possible-slopes 4))
+      (define possible-line-slopes (generate-possible-slopes 6))
+
+      (define (find-slope/robby dh dv possible-slopes)
+	(if (= dh 0)
+	    'vertical
+	    (let* ([slope (/ dv dh)])
+	      (let loop ([best (car possible-slopes)]
+			 [rst (cdr possible-slopes)])
+		(cond
+		 [(null? rst) best]
+		 [else
+		  (if (<= (abs (- slope (car rst)))
+			  (abs (- slope best)))
+		      (loop (car rst) (cdr rst))
+		      (loop best (cdr rst)))])))))
+
+      (define (find-slope dh dv max-slope-num h-within v-within) ; max-slope-num is 4 or 6
+	; Result is (slope new-dh), where slope can be 'vertical, in which case
+	;                           new-dh is really dv
+	(letrec ([best-of-two
+		  (lambda (a b)
+		    (let*-values ([(ls lh) (a)]
+				  [(rs rh) (b)])
+		      (if (and ls (or (not rs) (< (abs (- lh dh)) (abs (- rh dh)))))
+			  (values ls lh)
+			  (values rs rh))))]
+		 [search-h
+		  (lambda (dh dv depth direction)
+		    (if (zero? depth)
+			(values #f #f)
+			(if (zero? dh)
+			    (values 'vertical dv)
+			    (let ([slope (/ dv dh)])
+			      (if (and (<= (abs (numerator slope)) max-slope-num)
+				       (<= (abs (denominator slope)) max-slope-num))
+				  (values slope dh)
+				  (search-h (+ dh direction) dv (sub1 depth) direction))))))]
+		 [sign (lambda (x) (if (positive? x) 1 -1))]
+		 [flip
+		  (lambda (s l)
+		    (if s
+			(cond
+			 [(eq? s 'vertical) (values (sign l) 0 (abs l))]
+			 [(zero? s) (values 'vertical l)]
+			 [else (values (/ 1 s) (round (* s l)))])
+			(values #f #f)))]
+		 [search-v
+		  (lambda (dh dv depth direction)
+		    (call-with-values (lambda () (search-h dv dh depth direction))
+				      flip))]
+		 [change-h
+		  (lambda (dh dv h-within)
+		    (best-of-two (lambda () (search-h dh dv h-within -1))
+				 (lambda () (search-h dh dv h-within 1))))]
+		 [change-v
+		  (lambda (dh dv v-within)
+		    (call-with-values (lambda () (change-h dv dh v-within))
+				      flip))])
+	  (cond
+	   [(zero? v-within) (change-h dh dv h-within)]
+	   [(zero? h-within) (change-v dh dv v-within)]
+	   [else (let-values ([(s l) (search-h dh dv 1 0)])
+		   (if s
+		       (values s l)
+		       (best-of-two 	 
+			(lambda ()
+			  (best-of-two (lambda () (find-slope dh (add1 dv) max-slope-num h-within (sub1 v-within)))
+				       (lambda () (find-slope dh (sub1 dv) max-slope-num h-within (sub1 v-within)))))
+			(lambda ()
+			  (best-of-two (lambda () (find-slope (add1 dh) dv max-slope-num (sub1 h-within) v-within))
+				       (lambda () (find-slope (sub1 dh) dv max-slope-num (sub1 h-within) v-within)))))))])))
+      
+      (define (parse-slope sl dh dv)
+	(if (eq? sl 'vertical)
+	    (if (negative? dv)
+		(values 0 -1 (- dv))
+		(values 0 1 dv))
+	    (let ([d (denominator sl)]
+		  [n (numerator sl)])
+	      (if (negative? dh)
+		  (values (- d) (- n) (abs dh))
+		  (values d n dh)))))
+
+      (define connect 
+	(case-lambda
+	 [(x1 y1 x2 y2) (connect x1 y1 x2 y2 #f)]
+	 [(x1 y1 x2 y2 arrow?)
+	  (if (not (or (use-old-connect) (draw-bezier-lines)))
+	      (~connect 'r +inf.0 x1 y1 x2 y2 arrow?)
+	      (if (draw-bezier-lines)
+		  (let* ([get-len (lambda () (sqrt (+ (* (- x1 x2) (- x1 x2))
+						      (* (- y1 y2)  (- y1 y2)))))]
+			 [c (if (procedure? (draw-bezier-lines))
+				((draw-bezier-lines) (get-len))
+				#f)])
+		    `((qbezier ,c ,x1 ,y1 ,(quotient (+ x1 x2) 2) ,(quotient (+ y1 y2) 2) ,x2 ,y2)))	      
+		  (let* ([dh (- x2 x1)]
+			 [dv (- y2 y1)]
+			 [s
+			  (if (using-pict2e-package)
+			      (/ dv dh)
+			      (find-slope/robby
+			       (- x2 x1)
+			       (- y2 y1)
+			       (if arrow? possible-arrow-slopes possible-line-slopes)))])
+		    (let-values ([(lh lv ll) (parse-slope s dh dv)])
+		      `((put ,x1 ,y1 (,(if arrow? 'vector 'line) ,lh ,lv ,ll)))))))]))
+
+      #|
+
+      ;; old body of connect
+
+      (let loop ([dd (if (draw-bezier-lines) 0 1)])
+	(if (> dd (if (draw-bezier-lines) 0 4))
+	    ; give up
+	    (if (draw-bezier-lines)
+		(let* ([get-len (lambda () (sqrt (+ (* (- x1 x2) (- x1 x2))
+						    (* (- y1 y2)  (- y1 y2)))))]
+		       [c (if (procedure? (draw-bezier-lines))
+			      ((draw-bezier-lines) (get-len))
+			      #f)])
+		  `((qbezier ,c ,x1 ,y1 ,(quotient (+ x1 x2) 2) ,(quotient (+ y1 y2) 2) ,x2 ,y2)))
+		(let ([xd (- x2 x1)])
+		  `((put ,x1 ,y1 (line ,(if (negative? xd) -1 1) 0 ,(abs xd))))))
+	    (let-values ([(s l) (find-slope (- x2 x1) (- y2 y1) 
+					    (if (using-pict2e-package)
+						+inf.0
+						(if arrow? 4 6))
+					    dd dd)])
+	      (if s
+		  (let-values ([(lh lv ll) (parse-slope s l)])
+		    `((put ,x1 ,y1 (,(if arrow? 'vector 'line) ,lh ,lv ,ll))))
+		  (loop (add1 dd))))))
+
+      |#
+
+      (define ~connect 
+	(case-lambda
+	 [(exact close-enough x1 y1 x2 y2) (~connect exact close-enough x1 y1 x2 y2 #f)]
+	 [(exact close-enough x1 y1 x2 y2 arrow?)
+	  (if (= x2 x1)
+	      ; "infinite" slope
+	      (let ([dy (- y2 y1)])
+		`((put ,x1 ,y1 (,(if arrow? 'vector 'line) 0 ,(if (negative? dy) -1 1) ,(abs dy)))))
+	      (let ([real-slope (/ (- y2 y1) (- x2 x1))]
+		    [split (lambda (xm ym)
+			     (append
+			      (~connect exact close-enough xm ym x1 y1 #f)
+			      (~connect exact close-enough xm ym x2 y2 arrow?)))])
+		(if (or (>= real-slope (if arrow? 7/8 11/12))
+			(<= real-slope (if arrow? -7/8 -11/12)))
+		    ; rounds to "infinite" slope
+		    (if (> (abs (- x2 x1)) close-enough)
+			(split x1 (truncate (quotient (+ y1 y2) 2)))
+			(let ([dy (- y2 y1)])
+			  `((put ,x1 ,y1 (,(if arrow? 'vector 'line) 
+					  0 
+					  ,(if (negative? dy) -1 1) ,(abs dy))))))
+		    (let* ([slope (let loop ([slope real-slope][tolerances
+								(if arrow?
+								    '(1/100 1/12 1/4)
+								    '(1/100 1/50 1/25 1/10 1/6))])
+				    (if (<= (denominator slope) (if arrow? 4 6))
+					slope
+					(loop (rationalize real-slope (car tolerances))
+					      (cdr tolerances))))]
+			   [exact-x? (or (eq? exact 'x) (zero? slope))]
+			   [r (sqrt (+ (* (- x1 x2) (- x1 x2)) (* (- y1 y2) (- y1 y2))))]
+			   [dx (cond
+				[exact-x? (- x2 x1)]
+				[(eq? exact 'r) (truncate (* r (let ([d (denominator slope)]
+								     [n (numerator slope)])
+								 (/ d (sqrt (+ (* d d) (* n n)))))))]
+				[else (truncate (* (/ slope) (- y2 y1)))])]
+			   [dy (truncate (* slope dx))])
+		      (if (or (and exact-x?
+				   (> (abs (- dy (- y2 y1))) close-enough))
+			      (and (not exact-x?) (eq? exact 'y)
+				   (> (abs (- dx (- x2 x1))) close-enough))
+			      (and (not exact-x?) (eq? exact 'y)
+				   (> (abs (- (sqrt (+ (* dx dx) (* dy dy))) r)) close-enough)))
+			  (if (or exact-x? (eq? exact 'r))
+			      (let ([xm (truncate (quotient (+ x1 x2) 2))]) 
+				(split xm (+ y1 (truncate (* slope (- xm x1))))))
+			      (let ([ym (truncate (quotient (+ y1 y2) 2))]) 
+				(split (+ x1 (truncate (* (/ slope) (- ym y1)))) ym)))
+			  (let ([same-sign (lambda (v s)
+					     (if (negative? s)
+						 (- (abs v))
+						 (abs v)))])
+			    `((put ,x1 ,y1 (,(if arrow? 'vector 'line) 
+					    ,(same-sign (denominator slope) (- x2 x1))
+					    ,(same-sign (numerator slope) (- y2 y1))
+					    ,(abs dx))))))))))]))
+
+      (define (pict->string s)
+	(let output ([s (prepare-for-output s)])
+	  (if (string? s)
+	      s
+	      (let ([tag (car s)])
+		(case tag
+		  [(local)
+		   (format "{~a}~n" (output (cadr s)))]
+		  [(begin)
+		   (apply string-append (map output (cdr s)))]
+		  [(picture)
+		   (format "\\begin{picture}(~a,~a)~n~a\\end{picture}~n"
+			   (cadr s) (caddr s)
+			   (apply string-append (map output (cdddr s))))]
+		  [(color)
+		   (format "\\special{color push ~a}~n~a\\special{color pop}~n"
+			   (cadr s) (output (cddr s)))]
+		  [(thickness)
+		   (format "\\~a~a" (cadr s) (output (caddr s)))]
+		  [(put)
+		   (format "\\put(~a,~a){~a}~n" (cadr s) (caddr s) (output (cadddr s)))]
+		  [(qbezier)
+		   (apply format "\\qbezier~a(~a,~a)(~a,~a)(~a,~a)~n"
+			  (if (cadr s)
+			      (format "[~a]" (cadr s))
+			      "")
+			  (cddr s))]
+		  [(line vector)
+		   (format "\\~a(~a,~a){~a}" tag (cadr s) (caddr s) (cadddr s))]
+		  [(circle)
+		   (format "\\circle{~a}" (cadr s))]
+		  [(circle*)
+		   (format "\\circle*{~a}" (cadr s))]
+		  [(frame)
+		   (format "\\frame{~a}" (output (cadr s)))]
+		  [(colorbox)
+		   (format "\\colorbox{~a}{~a}" (cadr s) (output (caddr s)))]
+		  [(oval)
+		   (format "\\oval(~a,~a)~a" (caddr s) (cadddr s) (cadr s))]
+		  [(make-box)
+		   (format "\\makebox(~a, ~a)[~a]{~a}"
+			   (cadr s) (caddr s) (cadddr s) (car (cddddr s)))]
+		  [(prog)
+		   (error 'pict->string "cannot handle prog pict")]
+		  [else (error 'pict->string "bad tag: ~s" tag)])))))
+
+      (define pict->commands pict->command-list))))
+
diff --git a/collects/texpict/private/texpict-sig.ss b/collects/texpict/private/texpict-sig.ss
new file mode 100644
index 0000000000..0c5a3ac9c0
--- /dev/null
+++ b/collects/texpict/private/texpict-sig.ss
@@ -0,0 +1,37 @@
+
+(module texpict-sig mzscheme
+  (require (lib "unitsig.ss"))
+
+  (provide texpict-extra^)
+  (define-signature texpict-extra^
+    (read-in-sizes  ; string -> void
+
+     using-pict2e-package
+
+     draw-bezier-lines
+     
+     use-old-connect
+
+     output-measure-commands
+
+     tex-series-prefix
+     serialize-tex-picts
+     
+     current-tex-sizer
+
+     tex               ; string -> pict
+     text-line         ; string -> pict
+     text-line/phantom ; string string -> pict
+     tex-paragraph     ; w string ['top|'bottom] -> pict
+
+     left-brace     ; h -> pict
+     right-brace    ; h -> pict
+     left-delimit   ; str h -> pict
+     right-delimit  ; str h -> pict
+     middle-delimit ; str h -> pict
+     top-brace      ; w -> pict
+     bottom-brace   ; w -> pict
+
+     pict->string
+
+     pict->commands)))
diff --git a/collects/texpict/slideshow-run.ss b/collects/texpict/slideshow-run.ss
new file mode 100644
index 0000000000..f55c550991
--- /dev/null
+++ b/collects/texpict/slideshow-run.ss
@@ -0,0 +1,6 @@
+
+(module slideshow-run "slideshow.ss"
+  (require (prefix slideshow: (lib "run.ss" "slideshow")))
+
+  (provide (all-from-except "slideshow.ss" #%module-begin)
+           (rename slideshow:#%module-begin #%module-begin)))
diff --git a/collects/texpict/slideshow.ss b/collects/texpict/slideshow.ss
new file mode 100644
index 0000000000..019edd695c
--- /dev/null
+++ b/collects/texpict/slideshow.ss
@@ -0,0 +1,3 @@
+
+(module slideshow (lib "slideshow.ss" "slideshow")
+  (provide (all-from (lib "slideshow.ss" "slideshow"))))
diff --git a/collects/texpict/symbol.ss b/collects/texpict/symbol.ss
new file mode 100644
index 0000000000..a73990ecb6
--- /dev/null
+++ b/collects/texpict/symbol.ss
@@ -0,0 +1,20 @@
+(module symbol (lib "slideshow.ss" "slideshow")
+  
+  (provide symbol
+	   sym:in sym:rightarrow sym:infinity sym:times 
+	   sym:implies sym:emdash 
+	   sym:therefore)
+  
+  (define (symbol n)
+    (text (string (integer->char n)) 'symbol font-size))
+
+  (define sym:in (symbol #x2208))
+  (define sym:rightarrow (symbol #x2192))
+  (define sym:leftarrow (symbol #x2190))
+  (define sym:infinity (symbol #x221E))
+  (define sym:times (symbol 215))
+  (define sym:implies (symbol #x21D2))
+  (define sym:emdash (symbol 8212))
+  (define sym:therefore (symbol #x2234)))
+
+
diff --git a/collects/texpict/texpict-sig.ss b/collects/texpict/texpict-sig.ss
new file mode 100644
index 0000000000..baa7703d20
--- /dev/null
+++ b/collects/texpict/texpict-sig.ss
@@ -0,0 +1,12 @@
+
+(module texpict-sig mzscheme
+  (require (lib "unitsig.ss"))
+  
+  (require "private/common-sig.ss")
+  (require "private/texpict-sig.ss")
+  
+  (provide texpict^)
+  (define-signature texpict^
+    ((open texpict-common^)
+     (open texpict-extra^))))
+
diff --git a/collects/texpict/texpict-unit.ss b/collects/texpict/texpict-unit.ss
new file mode 100644
index 0000000000..913568ab50
--- /dev/null
+++ b/collects/texpict/texpict-unit.ss
@@ -0,0 +1,25 @@
+
+(module texpict-unit mzscheme
+  (require (lib "unitsig.ss"))
+
+  (require "private/texpict-sig.ss"
+	   "private/common-sig.ss"
+	   "private/common-unit.ss"
+	   "private/texpict-extra.ss")
+	
+  (provide texpict@)
+  (define texpict@
+    (compound-unit/sig
+     (import)
+     (link
+      [common : ((open texpict-common^)
+		 (open texpict-internal^))
+	      (common@
+	       (texpictx : texpict-common-setup^))]
+      [texpictx : ((open texpict-extra^)
+		   (open texpict-common-setup^))
+		(texpict-extra@
+		 common)])
+     (export (open (common : texpict-common^))
+	     (open (texpictx : texpict-extra^))))))
+
diff --git a/collects/texpict/texpict.ss b/collects/texpict/texpict.ss
new file mode 100644
index 0000000000..d3a337e971
--- /dev/null
+++ b/collects/texpict/texpict.ss
@@ -0,0 +1,12 @@
+
+(module texpict mzscheme
+  (require (lib "unitsig.ss"))
+
+  (require "texpict-sig.ss"
+	   "texpict-unit.ss")
+
+  (define-values/invoke-unit/sig texpict^
+    texpict@)
+
+  (provide-signature-elements texpict^))
+
diff --git a/collects/texpict/utils.ss b/collects/texpict/utils.ss
new file mode 100644
index 0000000000..de6f681b1e
--- /dev/null
+++ b/collects/texpict/utils.ss
@@ -0,0 +1,943 @@
+
+(module utils mzscheme
+  (require (lib "class.ss")
+	   (lib "math.ss")
+	   (lib "etc.ss")
+	   (lib "mred.ss" "mred"))
+
+  (require "mrpict.ss")
+
+  ;; Utilities for use with mrpict
+  
+  (provide cons-colorized-picture
+	   color-frame
+	   round-frame
+	   color-round-frame
+	   color-dash-frame
+
+	   arrow
+	   arrowhead
+	   arrowhead/offset
+	   arrow-line
+	   arrows-line
+	   pt-line
+	   pt-arrow-line
+	   pt-arrows-line
+	   
+           ellipse
+           filled-ellipse
+	   circle
+	   disk
+           rectangle
+           filled-rectangle
+	   rounded-rectangle
+           filled-rounded-rectangle
+           
+	   cloud
+	   file-icon
+	   jack-o-lantern
+	   angel-wing
+	   desktop-machine
+	   standard-fish
+
+	   pin-line
+	   pin-arrow-line
+	   pin-arrows-line
+
+	   add-line
+	   add-arrow-line
+	   add-arrows-line
+
+	   bitmap
+	   bitmap-draft-mode
+
+           find-pen
+           find-brush
+           
+           color-series
+           scale-color
+	   scale
+	   scale/improve-new-text
+
+	   inset/clip
+           clip
+
+	   hyperlinkize)
+
+  (define (re-pict box naya)
+    (let ([w (pict-width box)]
+	  [h (pict-height box)]
+	  [d (pict-descent box)]
+	  [a (pict-ascent box)])
+      (make-pict (pict-draw naya)
+		 w h
+		 a d
+		 (list (make-child box 0 0 1 1))
+		 #f)))
+  
+  (define cons-colorized-picture
+    (lambda (p color cmds)
+      (re-pict
+       p
+       (cc-superimpose
+	p
+	(colorize
+	 (cons-picture
+	  (ghost (launder p))
+	  cmds)
+	 color)))))
+
+  (define (round-frame p radius)
+    (re-pict
+     p
+     (cc-superimpose
+      p
+      (let ([w (pict-width p)]
+	    [h (pict-height p)])
+	(dc (lambda (dc x y)
+	      (let ([b (send dc get-brush)])
+		(send dc set-brush (send the-brush-list find-or-create-brush
+					 "white" 'transparent))
+		(send dc draw-rounded-rectangle x y w h radius)
+		(send dc set-brush b)))
+	    (pict-width p) (pict-height p))))))
+
+  ;; FIXME: abstract common part of color-frame, etc.
+
+  (define color-frame
+    (case-lambda
+     [(p color w)
+      (re-pict
+       p
+       (cc-superimpose
+	p
+	(let ([p2 (colorize (frame (ghost (launder p))) color)])
+	  (if w
+	      (linewidth w p2)
+	      p2))))]
+     [(p color) (color-frame p color #f)]))
+  
+  (define color-round-frame
+    (case-lambda
+     [(p radius color w)
+      (re-pict
+       p
+       (cc-superimpose
+	p
+	(let ([p2 (colorize (round-frame (ghost (launder p)) radius) color)])
+	  (if w
+	      (linewidth w p2)
+	      p2))))]
+     [(p radius color) (color-round-frame p radius color #f)]))  
+
+  (define color-dash-frame
+    (case-lambda
+     [(p seg-length color w)
+      (re-pict
+       p
+       (cc-superimpose
+	p
+	(let ([p2 (colorize (dash-frame (ghost (launder p)) seg-length) color)])
+	  (if w
+	      (linewidth w p2)
+	      p2))))]
+     [(p seg-length color) (color-dash-frame p seg-length color #f)]))  
+
+  ;; Returns three values: pict dx dy
+  ;;  dx is in [-size, 0] and dy is in [0, size]
+  (define (generic-arrow stem? solid? size angle pen-thickness)
+    (values
+     (dc
+      (lambda (dc x y)
+	(define (pt->xform-obj p)
+	  (let* ([x (car p)]
+		 [y (cadr p)]
+		 [d (sqrt (+ (* x x) (* y y)))]
+		 [a (atan y x)])
+	    (make-object point% 
+              (* d size 1/2 (cos (+ a angle)))
+              (* d size 1/2 (- (sin (+ a angle)))))))
+	(let ([b (send dc get-brush)]
+	      [p (send dc get-pen)])
+	  (send dc set-pen (send the-pen-list
+				 find-or-create-pen
+				 (send p get-color)
+				 0
+				 'solid))
+	  (send dc set-brush (send the-brush-list
+				   find-or-create-brush
+				   (send p get-color)
+				   (if solid? 'solid 'transparent)))
+	  (send dc draw-polygon 
+		(map pt->xform-obj
+		     (if stem?
+			 `((1 0)
+			   (0 -1)
+			   (0 -1/2)
+			   (-1 -1/2)
+			   (-1 1/2)
+			   (0 1/2)
+			   (0 1))
+			 `((1 0)
+			   (-1 -1)
+			   (-1/2 0)
+			   (-1 1))))
+		(+ x (/ size 2)) (+ y (/ size 2)))
+	  (send dc set-brush b)
+	  (send dc set-pen p)))
+      size size 0 0)
+     (- (- 0 (* 1/2 size (cos angle))) (/ size 2))
+     (- (+ (* 1/2 size) (- (* 1/2 size (sin angle)))) size)))
+
+  (define (arrow/delta size angle)
+    (generic-arrow #t #t size angle 0))
+  (define (arrow size angle)
+    (let-values ([(p dx dy) (arrow/delta size angle)])
+      p))
+
+  (define (arrowhead/delta pen-thickness size angle)
+    (generic-arrow #f #t size angle pen-thickness))
+  (define (arrowhead size angle)
+    (let-values ([(p dx dy) (arrowhead/delta 0 size angle)])
+      p))
+  (define (arrowhead/offset size angle)
+    (arrowhead/delta 0 size angle))
+
+  (define (pt-line dx dy size)
+    (picture
+     0 0
+     `((connect 0 0 ,dx ,(- dy)))))
+
+  (define (arrow-line dx dy size)
+    (let-values ([(a adx ady) (arrowhead/delta 0 size (atan dy dx))])
+      (picture
+       0 0
+       `((connect 0 0 ,dx ,dy)
+	 (place ,(+ dx adx) ,(+ ady dy) ,a)))))
+
+  (define (pt-arrow-line dx dy size)
+    (arrow-line dx (- dy) size))
+
+  (define (arrows-line dx dy size)
+    (picture
+     0 0
+     `((place 0 0 ,(arrow-line dx dy size))
+       (place ,dx ,dy ,(arrow-line (- dx) (- dy) size)))))
+
+  (define (pt-arrows-line dx dy size)
+    (arrows-line dx (- dy) size))
+
+  (define (filled-rectangle w h)
+    (dc
+     (lambda (dc x y)
+       (send dc draw-rectangle x y w h))
+     w
+     h))
+  
+  (define (rectangle w h)
+    (dc
+     (lambda (dc x y)
+       (let ([b (send dc get-brush)])
+         (send dc set-brush (send the-brush-list find-or-create-brush
+                                  "white" 'transparent))
+         (send dc draw-rectangle x y w h)
+         (send dc set-brush b)))
+     w
+     h))
+  
+  (define filled-rounded-rectangle
+    (opt-lambda (w h [corner -0.25])
+      (dc
+       (lambda (dc x y)
+	 (send dc draw-rounded-rectangle x y w h corner))
+       w
+       h)))
+  
+  (define rounded-rectangle
+    (opt-lambda (w h [corner -0.25])
+      (dc
+       (lambda (dc x y)
+	 (let ([b (send dc get-brush)])
+	   (send dc set-brush (send the-brush-list find-or-create-brush
+				    "white" 'transparent))
+	   (send dc draw-rounded-rectangle x y w h corner)
+	   (send dc set-brush b)))
+       w
+       h)))
+  
+  (define (circle size) (ellipse size size))
+  
+  (define (ellipse width height)
+    (dc (lambda (dc x y)
+	  (let ([b (send dc get-brush)])
+	    (send dc set-brush (send the-brush-list find-or-create-brush
+				     "white" 'transparent))
+	    (send dc draw-ellipse x y width height)
+	    (send dc set-brush b)))
+	width height))
+
+  (define (disk size) (filled-ellipse size size))
+  
+  (define (filled-ellipse width height)
+    (dc (lambda (dc x y)
+	  (send dc draw-ellipse x y width height))
+	width height))
+
+  (define cloud
+    (case-lambda
+     [(w h) (cloud w h "gray")]
+     [(w h color)
+      (dc
+       (lambda (dc x y)
+	 (let ([b (send dc get-brush)]
+	       [p (send dc get-pen)])
+	   (send dc set-pen (send the-pen-list
+				  find-or-create-pen
+				  "white" 0 'transparent))
+	   (send dc set-brush (send the-brush-list
+				    find-or-create-brush
+				    color
+				    'solid))
+	   (send dc draw-ellipse
+		 x (+ y (* 1/4 h))
+		 (* 1/2 w) (* 1/2 h))
+	   (send dc draw-ellipse
+		 (+ x (* 1/5 w)) y
+		 (* 3/5 w) (add1 (* 2/5 h)))
+	   (send dc draw-ellipse
+		 (+ x (* 1/5 w)) (+ y (* 1/3 h))
+		 (* 3/5 w) (* 2/3 h))
+	   (send dc draw-ellipse
+		 (+ x (* 3/5 w)) (+ y (* 1/4 h))
+		 (* 2/5 w) (* 1/3 h))
+	   (send dc draw-ellipse
+		 (+ x (* 3/5 w)) (+ y (* 1/2 h))
+		 (* 2/5 w) (* 1/3 h))
+
+	   (send dc set-brush b)
+	   (send dc set-pen p)))
+       w h)]))
+
+  (define file-icon
+    (opt-lambda (w h gray [fancy? #f])
+      (dc
+       (let* ([sw (lambda (x) (* (/ w 110) x))]
+	      [sh (lambda (y) (* (/ h 150) y))]
+	      [->pt (lambda (l)
+		      (map (lambda (p)
+			     (make-object point% 
+					  (sw (car p))
+					  (sh (cadr p))))
+			   l))])
+	 (lambda (dc x y)
+	   (define p (send dc get-pen))
+	   (define b (send dc get-brush))
+
+	   (let* ([bg-color (cond
+                                 [(or (string? gray) (is-a? gray color%)) gray]
+                                 [gray (make-object color% 200 200 255)]
+                                 [else "white"])]
+                  [line-color (if fancy?
+                                  (scale-color 0.6 bg-color)
+                                  "black")]
+                  [color (send the-brush-list
+                               find-or-create-brush
+                               bg-color
+                               'solid)])
+
+	     (send dc set-pen (send the-pen-list 
+				    find-or-create-pen 
+                                    line-color
+				    (send p get-width)
+				    'solid))
+	     (send dc set-brush color)
+	     
+	     (send dc draw-polygon 
+		   (->pt '((0 0)
+			   (0 150)
+			   (110 150)
+			   (110 20)
+			   (90 0)))
+		   x y)
+
+             (send dc draw-line (+ x (sw 90)) (+ y 1) (+ x (sw 90)) (+ y (sh 20)))
+             (send dc draw-line (+ x (sw 90)) (+ y (sh 20)) (+ x (sw 110) -1) (+ y (sh 20))))
+	   
+           (send dc set-brush b)
+	   (send dc set-pen p)))
+       w h)))
+
+  (define angel-wing
+    (opt-lambda (w h left?)
+      (dc
+       (lambda (dc x y)
+	 (let-values ([(sx sy) (send dc get-scale)]
+		      [(dx dy) (send dc get-origin)])
+	   (let ([nsx (* sx (/ w 54))]
+		 [nsy (* sy (/ h 110))])
+	     (send dc set-origin (+ dx (* x sx) (* (- 16) nsx)) (+ dy (* y sy) (* (- 20) nsy)))
+	     (send dc set-scale nsx nsy)
+
+	     (let ([wing
+		    (list
+		     
+		     (list 70 (+ 50 40)  35 65     20 20)
+		     (list 20 20    (- 20 5) (+ 20 30)    (+ 20 5) (+ 20 60))
+		     (list (+ 20 5) (+ 20 60)    50 100    70 (+ 50 45))
+		     
+		     (list 22 70   (- 30 5) (+ 65 30)   (+ 30 5) (+ 65 40))
+		     (list (+ 30 5) (+ 65 40)  50 110     70 (+ 50 50))
+		     
+		     (list 32 102   (- 40 5) (+ 65 50)   (+ 40 5) (+ 65 58))
+		     (list (+ 40 5) (+ 65 58)   60  130    70 (+ 50 52)))])
+	       (when left?
+		 (for-each
+		  (lambda (spline)
+		    (send dc draw-spline . spline))
+		  wing))
+	       (unless left?
+		 (for-each
+		  (lambda (spline)
+		    (let-values ([(x1 y1 x2 y2 x3 y3) (apply values spline)])
+		      (send dc draw-spline (- 87 x1) y1 (- 86 x2) y2 (- 86 x3) y3)))
+		  wing)))
+
+	     (send dc set-origin dx dy)
+	     (send dc set-scale sx sy))))
+       w h)))
+
+  (define desktop-machine
+    (opt-lambda (s [style null])
+      (define icon
+	(let ([bm (if (and (list? style) (memq 'plt style))
+		      (make-object bitmap% (build-path (collection-path "icons") "plt-small-shield.gif"))
+		      #f)])
+	  (dc (lambda (dc x y)
+		(let-values ([(sx sy) (send dc get-scale)]
+			     [(dx dy) (send dc get-origin)]
+			     [(op) (send dc get-pen)]
+			     [(ob) (send dc get-brush)])
+		  (send dc set-origin (+ dx (* sx x) (* s sx 10)) (+ dy (* sy y) (* s sy 15)))
+		  (send dc set-scale (* sx s) (* sy s))
+		  
+		  (let ([gray (send the-brush-list
+				    find-or-create-brush
+				    "gray"
+				    'solid)])
+		    (send dc set-brush gray)
+		    (send dc draw-polygon (list
+					   (make-object point% 10 60)
+					   (make-object point% 0 80)
+					   (make-object point% 80 80)
+					   (make-object point% 100 60)
+					   (make-object point% 100 0)
+					   (make-object point% 20 0)
+					   (make-object point% 10 5))))
+		  (send dc draw-line 80 80 90 60)
+		  (send dc draw-rectangle 10 5 80 55)
+		  (send dc set-brush (send the-brush-list
+					   find-or-create-brush
+					   "white"
+					   'solid))
+		  (send dc draw-rounded-rectangle 15 10 70 45 5)
+
+		  (when (and (list? style) 
+			     (or (memq 'devil style)
+				 (memq 'binary style)))
+		    (send dc set-font (make-object font% 12 'modern 'normal 'normal))
+		    (let-values ([(w h d a) (send dc get-text-extent "101010")])
+		      (let ([dx (+ (/ (- 70 w) 2) 15)]
+			    [dy (+ (/ (- 45 (* 2 h) 2) 2) 10)])
+			(send dc draw-text "101010" dx dy)
+			(send dc draw-text "010101" dx (+ dy h 2))))
+		    
+		    (when (memq 'devil style)
+		      (send dc set-brush (send the-brush-list
+					       find-or-create-brush
+					       "red"
+					       'solid))
+		      (let ([horn (list
+				   (make-object point% 0 17)
+				   (make-object point% 2 0)
+				   (make-object point% 4 17))])
+			(send dc draw-polygon horn 30 -15)
+			(send dc draw-polygon horn 70 -15))
+		      
+		      (send dc draw-polygon (list
+					     (make-object point% 0 0)
+					     (make-object point% 10 2)
+					     (make-object point% 0 6))
+			    115 32)
+		      
+		      (send dc set-pen (send the-pen-list
+					     find-or-create-pen
+					     "red"
+					     2
+					     'solid))
+		      (send dc draw-line 101 55 110 55)
+		      (send dc draw-spline 110 55   130 50    110  45)
+		      (send dc draw-spline 110 45   90 40    115  35)))
+		    
+		  (send dc set-origin dx dy)
+
+		  (send dc set-pen op)
+		  (send dc set-brush ob)
+
+		  (send dc set-scale (* sx s 2/3) (* sy s 2/3))
+
+		  (when (and (list? style) (memq 'plt style))
+		    (when (send bm ok?)
+		      (let ([w (send bm get-width)]
+			    [h (send bm get-height)])
+			(send dc draw-bitmap bm 
+			      (/ (+ x (/ (- (* s 70) (* w 2/3 s)) 2) (* s 25)) (* 2/3 s))
+			      (/ (+ y (/ (- (* s 45) (* h 2/3 s)) 2) (* s 25)) (* 2/3 s))))))
+
+		  (send dc set-scale sx sy)))
+	      (* s 120) (* s 115))))
+      (if (pict? style)
+	  (lt-superimpose
+	   icon
+	   (inset
+	    (cc-superimpose (blank (* s 70) (* s 45)) style)
+	    (* s 25) (* s 25) 0 0))
+	  icon)))
+
+  (define jack-o-lantern
+    (opt-lambda (size [pumpkin-color "orange"] [face-color "black"] [stem-color "brown"])
+      (dc (lambda (dc x y)
+	    (let ([b (send dc get-brush)]
+		  [p (send dc get-pen)]
+		  [set-brush (lambda (c)
+			       (send dc set-brush 
+				     (send the-brush-list
+					   find-or-create-brush
+					   c 'solid)))]
+		  [r (make-object region% dc)]
+		  [path (make-object dc-path%)]
+		  [c (send dc get-clipping-region)])
+	      (send dc set-pen (send the-pen-list
+				     find-or-create-pen
+				     "white" 1 'transparent))
+
+	      ;; Stem ----------------------------------------
+	      (send path arc
+		    (+ x (* 0.42 size)) (- y (*  0.2 size))
+		    size size
+		    (* 0.8 pi) pi)
+	      (send path arc
+		    (+ x (* 0.52 size)) (- y (* 0.1 size))
+		    (* 0.8 size) (* 0.8 size)
+		    pi (* 0.8 pi) #f)
+	      (send r set-path path)
+	      (send dc set-clipping-region r)
+	      (set-brush stem-color)
+	      (send dc draw-rectangle x y size size)
+
+	      ;; Body ----------------------------------------
+	      (send dc set-clipping-region c)
+	      (set-brush pumpkin-color)
+
+	      (send dc draw-ellipse 
+		    x (+ y (* 0.2 size))
+		    (* 0.4 size) (* 0.8 size))
+	      (send dc draw-ellipse 
+		    (+ x (* 0.6 size)) (+ y (* 0.2 size))
+		    (* 0.4 size) (* 0.8 size))
+
+	      (send dc draw-ellipse 
+		    (+ x (* 0.2 size)) (+ y (* 0.15 size))
+		    (* 0.4 size) (* 0.9 size))
+	      (send dc draw-ellipse 
+		    (+ x (* 0.4 size)) (+ y (* 0.15 size))
+		    (* 0.4 size) (* 0.9 size))
+
+	      ;; Smile ----------------------------------------
+
+	      (send r set-rectangle x (+ y (* 0.4 size)) size (* 0.7 size))
+	      (send dc set-clipping-region r)
+
+	      (set-brush face-color)
+	      (send dc draw-ellipse
+		    (+ x (* 0.15 size)) (+ y (* 0.2 size))
+		    (* 0.7 size) (* 0.7 size))
+	      
+	      (set-brush pumpkin-color)
+	      (send dc draw-ellipse
+		    (+ x (* 0.15 size)) (sub1 (+ y (* 0.2 size)))
+		    (* 0.7 size) (* 0.5 size))
+	      (send dc draw-rectangle
+		    (+ x (* 0.35 size)) (+ y (* 0.55 size))
+		    (* 0.1 size) (* 0.2 size))
+	      
+	      ;; Eyes ----------------------------------------
+	      (send dc set-clipping-region c)
+	      (set-brush face-color)
+
+	      (send dc draw-ellipse
+		    (+ x (* 0.25 size)) (+ y (* 0.3 size))
+		    (* 0.175 size) (* 0.25 size))
+	      (send dc draw-ellipse
+		    (+ x (* (- 0.75 0.175) size)) (+ y (* 0.3 size))
+		    (* 0.175 size) (* 0.25 size))
+
+	      (set-brush pumpkin-color)
+
+	      (send dc draw-polygon
+		    (list
+		     (make-object point%
+				  (* 0.5 size)
+				  (* 0.45 size))
+		     (make-object point%
+				  (* 0.2 size)
+				  (* 0.25 size))
+		     (make-object point%
+				  (* 0.8 size)
+				  (* 0.25 size)))
+		    x y)
+	      
+	      (send dc set-brush b)
+	      (send dc set-pen p)))
+	  size (* 1.1 size))))
+
+  (define standard-fish 
+    (opt-lambda (w h [direction 'left] [c "blue"] [ec #f] [mouth-open? #f])
+      (define no-pen (send the-pen-list find-or-create-pen "black" 1 'transparent))
+      (define color (if (string? c) (make-object color% c) c))
+      (define dark-color (scale-color 0.8 color))
+      (define eye-color (and ec (if (string? ec) (make-object color% ec) ec)))
+      (define dark-eye-color color)
+      (dc (lambda (dc x y)
+            (let ([rgn (make-object region% dc)]
+                  [old-rgn (send dc get-clipping-region)]
+                  [old-pen (send dc get-pen)]
+                  [old-brush (send dc get-brush)]
+                  [flip-rel (lambda (x0) 
+                              (if (eq? direction 'left)
+                                  x0
+                                  (- w x0)))]
+                  [flip (lambda (x0 w0) 
+                          (if (eq? direction 'left)
+                              x0
+                              (+ x (- w (- x0 x) w0))))]
+		  [set-rgn (lambda (rgn flip?)
+			     (let ([dy (if flip? (/ h 2) 0)])
+			       (if mouth-open?
+				   (send rgn set-polygon
+					 (list (make-object point% 0 dy)
+					       (make-object point% w dy)
+					       (make-object point% w (- (* 1/2 h) dy))
+					       (make-object point% (* 1/6 w) (- (* 1/2 h) dy))
+					       (make-object point% 0 (if flip?
+									 (* 1/6 h)
+									 (* 1/3 h))))
+					 x (+ y dy))
+				   (send rgn set-rectangle 
+					 x (+ y dy)
+					 w (/ h 2)))))])
+              (send dc set-pen no-pen)
+              (color-series
+               dc 4 1
+               dark-color color
+               (lambda (ii)
+		 (define i (* ii (min 1 (* w 1/100))))
+
+                 (send dc draw-polygon (list (make-object point% (flip-rel (+ (* 1/2 w) i)) (* 1/10 h))
+                                             (make-object point% (flip-rel (- (* 3/4 w) i)) (+ 0 i))
+                                             (make-object point% (flip-rel (- (* 3/4 w) i)) (- (* 2/10 h) i)))
+                       x y)
+                 (send dc draw-polygon (list (make-object point% (flip-rel (+ (* 1/2 w) i)) (* 9/10 h))
+                                             (make-object point% (flip-rel (- (* 3/4 w) i)) (- h i))
+                                             (make-object point% (flip-rel (- (* 3/4 w) i)) (+ (* 8/10 h) i)))
+                       x y)
+                 (send dc draw-polygon (list (make-object point% (flip-rel (+ (* 3/4 w) i)) (/ h 2))
+                                             (make-object point% (flip-rel (- w i)) (+ (* 1/10 h) i))
+                                             (make-object point% (flip-rel (- w i)) (- (* 9/10 h) i)))
+                       x y))
+               #f #t)
+	      (set-rgn rgn #f)
+	      (send dc set-clipping-region rgn)
+              (color-series
+               dc 4 1
+               dark-color color
+               (lambda (i)
+                 (send dc draw-ellipse (+ (- x (* 1/4 w)) i) (+ y i)
+                       (- (* 6/4 w) (* 2 i)) (- (* 4 h) (* 2 i))))
+               #f #t)
+              (send dc set-clipping-region old-rgn)
+              (set-rgn rgn #t)
+              (send dc set-clipping-region rgn)
+              (color-series
+               dc 4 1
+               dark-color color
+               (lambda (i)
+                 (send dc draw-ellipse (+ (- x (* 1/4 w)) i) (+ (- y (* 3 h)) i)
+                       (- (* 6/4 w) (* 2 i)) (- (* 4 h) (* 2 i))))
+               #f #t)
+              (send dc set-clipping-region old-rgn)
+              (color-series
+               dc 4 1
+               dark-color color
+               (lambda (ii)
+		 (define i (* ii (min 1 (* w 1/100))))
+		 (send dc draw-polygon (list (make-object point% (flip-rel (+ (* 1/2 w) i)) (/ h 2))
+					     (make-object point% (flip-rel (- (* 5/8 w) i)) (+ (* 1/4 h) i))
+					     (make-object point% (flip-rel (- (* 5/8 w) i)) (- (* 3/4 h) i)))
+		       x y))
+               #f #t)
+              (when eye-color
+		(if (eq? eye-color 'x)
+		    (begin
+		      (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
+		      (let* ([ew (* 1/10 w)]
+			     [eh (* 1/10 h)]
+			     [x0 (flip (+ x (* 1/5 w)) ew)]
+			     [x1 (flip (+ x (* 1/5 w) ew) ew)]
+			     [y0 (+ y (* 2/3 h))]
+			     [y1 (- (+ y (* 2/3 h)) eh)])
+			(send dc draw-line x0 y0 x1 y1)
+			(send dc draw-line x0 y1 x1 y0))
+		      )
+		    (color-series
+		     dc
+		     1/20 1/80
+		     dark-eye-color eye-color
+		     (lambda (s)
+		       (let ([ew (* (- 1/10 s) w)])
+			 (send dc draw-ellipse 
+			       (flip (+ x (* 1/5 w) (* s 1/2 w)) ew)
+			       (+ y (* 1/3 h) (* (* s 4/2) 1/2 h))
+			       ew
+			       (* (- 1/10 s) 4/2 h))))
+		     #f #t)))
+              (send dc set-pen old-pen)
+              (send dc set-brush old-brush)))
+          w h)))
+
+  (define (-add-line base src find-src dest find-dest thickness color arrow-size arrow2-size under?)
+    (let-values ([(sx sy) (find-src base src)]
+                 [(dx dy) (find-dest base dest)])
+      (let ([arrows
+             (let ([p (cons-picture
+                       (ghost (launder base))
+                       `(,(let* ([angle (atan (- sy dy) 
+                                              (- sx dx))]
+                                 [cosa (cos angle)]
+                                 [sina (sin angle)]
+                                 ;; If there's an arrow, line goes only half-way in
+                                 [ddx (* (or arrow-size 0) 0.5 cosa)]
+                                 [ddy (* (or arrow-size 0) 0.5 sina)]
+                                 [dsx (* (or arrow2-size 0) 0.5 (- cosa))]
+                                 [dsy (* (or arrow2-size 0) 0.5 (- sina))])
+                            `(connect ,(+ sx dsx) ,(+ sy dsy) ,(+ dx ddx) ,(+ dy ddy)))
+                         ,@(if arrow-size
+                               (let-values ([(arrow xo yo)
+                                             (arrowhead/delta
+                                              (or thickness 0)
+                                              arrow-size 
+                                              (atan (- dy sy) 
+                                                    (- dx sx)))])
+                                 `((place ,(+ dx xo) ,(+ dy yo) ,arrow)))
+                               null)
+                         ,@(if arrow2-size
+                               (let-values ([(arrow xo yo)
+                                             (arrowhead/delta
+                                              (or thickness 0)
+                                              arrow-size 
+                                              (atan (- sy dy) 
+                                                    (- sx dx)))])
+                                 `((place ,(+ sx xo) ,(+ sy yo) ,arrow)))
+                               null)))])
+               (let ([p2 (if thickness
+                             (linewidth thickness p)
+                             p)])
+                 (if color
+                     (colorize p2 color)
+                     p2)))])
+        (if under?
+            (cc-superimpose arrows base)
+            (cc-superimpose base arrows)))))
+
+  (define add-line
+    (opt-lambda (base src find-src dest find-dest [thickness #f] [color #f] [under? #f])
+      (-add-line base src find-src dest find-dest thickness color #f #f under?)))
+  
+  (define add-arrow-line
+    (opt-lambda (arrow-size base src find-src dest find-dest [thickness #f] [color #f] [under? #f])
+      (-add-line base src find-src dest find-dest thickness color arrow-size #f under?)))
+  
+  (define add-arrows-line
+    (opt-lambda (arrow-size base src find-src dest find-dest [thickness #f] [color #f] [under? #f])
+      (-add-line base src find-src dest find-dest thickness color arrow-size arrow-size under?)))
+
+  (define (flip-find-y find-)
+    (lambda (base path)
+      (let-values ([(x y) (find- base path)])
+	(values x (- (pict-height base) y)))))
+
+  (define pin-line
+    (opt-lambda (base src find-src dest find-dest [thickness #f] [color #f] [under? #f])
+      (-add-line base src (flip-find-y find-src) dest (flip-find-y find-dest)
+		 thickness color #f #f under?)))
+  
+  (define pin-arrow-line
+    (opt-lambda (arrow-size base src find-src dest find-dest [thickness #f] [color #f] [under? #f])
+      (-add-line base src (flip-find-y find-src) dest (flip-find-y find-dest)
+		 thickness color arrow-size #f under?)))
+  
+  (define pin-arrows-line
+    (opt-lambda (arrow-size base src find-src dest find-dest [thickness #f] [color #f] [under? #f])
+      (-add-line base src (flip-find-y find-src) dest (flip-find-y find-dest)
+		 thickness color arrow-size arrow-size under?)))
+  
+  (define black-color (make-object color% 0 0 0))
+
+  (define bitmap-draft-mode (make-parameter #f (lambda (x) (and x #t))))
+
+  (define (bitmap filename)
+    (let ([bm (cond
+	       [(bitmap-draft-mode) #f]
+	       [(filename . is-a? . bitmap%) filename]
+	       [(filename . is-a? . image-snip%) (send filename get-bitmap)]
+	       [else (make-object bitmap% filename 'unknown/mask)])])
+      (if (and bm (send bm ok?))
+	  (let ([w (send bm get-width)]
+		[h (send bm get-height)])
+	    (dc
+	     (lambda (dc x y)
+	       (send dc draw-bitmap bm x y 'solid black-color (send bm get-loaded-mask)))
+	     w h))
+	  (frame (inset (colorize (text "bitmap failed") "red") 2)))))
+  
+  (define find-brush
+    (opt-lambda (color [style 'solid])
+      (send the-brush-list find-or-create-brush color style)))
+  (define find-pen
+    (opt-lambda (color [size 1] [style 'solid])
+      (send the-pen-list find-or-create-pen color size style)))  
+
+  (define (color-series dc steps dstep start-c end-c f pen? brush?)
+    (let ([start-c (if (string? start-c)
+		       (make-object color% start-c)
+		       start-c)]
+	  [end-c (if (string? end-c)
+		       (make-object color% end-c)
+		       end-c)])
+      (let ([sr (send start-c red)]
+	    [sg (send start-c green)]
+	    [sb (send start-c blue)]
+	    [er (send end-c red)]
+	    [eg (send end-c green)]
+	    [eb (send end-c blue)]
+	    [c (make-object color%)]
+	    [s (lambda (start end i)
+		 (floor (+ start (* (- end start) (/ i steps)))))])
+	(let loop ([i 0])
+	  (send c set (s sr er i) (s sg eg i) (s sb eb i))
+	  (when brush?
+	    (send dc set-brush (find-brush c)))
+	  (when pen?
+	    (send dc set-pen (find-pen c)))
+	  (f i)
+	  (unless (= i steps)
+	    (loop (+ dstep i)))))))
+  
+  (define (scale-color s c)
+    (let ([c (if (string? c)
+                 (make-object color% c)
+                 c)])
+      (let ([s (lambda (v)
+                 (if (> s 1)
+                     (- 255 (inexact->exact (floor (/ (- 255 v) s))))
+                     (min 255 (inexact->exact (floor (* v s))))))])
+        (make-object color%
+          (s (send c red))
+          (s (send c green))
+          (s (send c blue))))))
+  
+  (define scale
+    (case-lambda
+     [(p x-factor y-factor)
+      (let ([drawer (make-pict-drawer p)])
+	(let ([new
+	       (dc
+		(lambda (dc x y)
+		  (define (reset-pen)
+		    (let ([p (send dc get-pen)])
+		      (send dc set-pen (send the-pen-list
+					     find-or-create-pen
+					     "white" 1 'transparent))
+		      (send dc set-pen p)))
+		  (let-values ([(xs ys) (send dc get-scale)])
+		    (send dc set-scale (* xs x-factor) (* ys y-factor))
+		    (reset-pen)
+		    (drawer dc
+			    (/ x x-factor)
+			    (/ y y-factor))
+		    (send dc set-scale xs ys)
+		    (reset-pen)))
+		(* (pict-width p) x-factor)
+		(* (pict-height p) y-factor)
+		(* (pict-ascent p) y-factor)
+		(* (pict-descent p) y-factor))])
+	  (make-pict (pict-draw new)
+		     (pict-width new)
+		     (pict-height new)
+		     (pict-ascent new)
+		     (pict-descent new)
+		     (list (make-child p 0 0 x-factor y-factor))
+		     #f)))]
+     [(p factor) (scale p factor factor)]))
+
+  (define inset/clip
+    (case-lambda
+     [(p l t r b)
+      (let* ([p (inset p l t r b)]
+	     [drawer (make-pict-drawer p)]
+	     [w (pict-width p)]
+	     [h (pict-height p)])
+	(let ([new
+	       (dc
+		(lambda (dc x y)
+		  (let ([rgn (make-object region% dc)])
+		    (send rgn set-rectangle x y w h)
+		    (let ([r (send dc get-clipping-region)])
+		      (when r
+			(send rgn intersect r))
+		      (send dc set-clipping-region rgn)
+		      (drawer dc x y)
+		      (send dc set-clipping-region r))))
+		w h (pict-ascent p) (pict-descent p))])
+	  (make-pict (pict-draw new)
+		     (pict-width new)
+		     (pict-height new)
+		     (pict-ascent new)
+		     (pict-descent new)
+		     (list (make-child p 0 0 1 1))
+		     #f)))]
+     [(p h v) (inset/clip p h v h v)]
+     [(p a) (inset/clip p a a a a)]))
+  
+  (define (clip p) (inset/clip p 0))
+  
+  (define-syntax scale/improve-new-text
+    (syntax-rules ()
+      [(_ expr s)
+       (scale/improve-new-text expr s s)]
+      [(_ expr sx sy)
+       (let ([xs sx]
+	     [ys sy])
+	 (parameterize ([current-expected-text-scale
+			 (let ([s (current-expected-text-scale)])
+			   (list (* xs (car s)) (* ys (cadr s))))])
+	   (scale expr xs ys)))]))
+
+  (define (hyperlinkize r)
+    (colorize (inset
+	       (place-over r
+			   0 (pict-height r)
+			   (linewidth 2 (hline (pict-width r) 1)))
+	       0 0 0 2)
+	      "blue"))
+  
+  )
diff --git a/collects/trace/calltrace-lib.ss b/collects/trace/calltrace-lib.ss
new file mode 100644
index 0000000000..db0081ca0a
--- /dev/null
+++ b/collects/trace/calltrace-lib.ss
@@ -0,0 +1,76 @@
+
+;; Poor man's stack-trace-on-exceptions/profiler.
+;; See doc.txt for information.
+
+(module calltrace-lib mzscheme
+  (require "stacktrace.ss"
+           (lib "list.ss") 
+           (lib "etc.ss")
+           (lib "unitsig.ss"))
+
+
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; Eval handler, exception handler
+
+  (define instrumenting-enabled (make-parameter #t))
+
+  (define output-port (current-error-port))
+  
+  ;; (union symbol #f) syntax-object (list-of value) boolean int -> void
+  ;; effect: prints out the context surrounding the exception
+  (define (print-call-trace inferred-name original? src args improper? depth)
+    (build-list depth (lambda (n) (fprintf output-port " ")))
+    (fprintf output-port "~v\n" (cons (or inferred-name src) 
+                                      (if improper? 
+                                          (list->improper-list args)
+                                          args))))
+
+
+  (define calltrace-eval-handler    
+    (let ([orig (current-eval)]
+          [ns (current-namespace)])
+      (lambda (e)
+        (if (and (eq? ns (current-namespace))
+		 (not (compiled-expression? (if (syntax? e)
+						(syntax-e e)
+						e))))
+            ;; Loop to flatten top-level `begin's:
+            (let loop ([e (if (syntax? e)
+			      e
+			      (namespace-syntax-introduce
+			       (datum->syntax-object #f e)))])
+              (let ([top-e (expand-syntax-to-top-form e)])
+                (syntax-case top-e (begin)
+                  [(begin expr ...)
+                   ;; Found a `begin', so expand/eval each contained
+                   ;; expression one at a time
+                   (foldl (lambda (e old-val)
+                            (loop e))
+                          (void)
+                          (syntax->list #'(expr ...)))]
+                  [_else
+                   ;; Not `begin', so proceed with normal expand and eval
+                   (let* ([ex (expand-syntax top-e)]
+                          [a (if (not (instrumenting-enabled))
+                                 ex
+                                 (annotate ex))])
+                     (orig a))])))
+            (orig e)))))
+
+  (define (list->improper-list a)
+    (cond [(null? a) (error 'list->improper-list "list->improper-list called with null argument: ~e" a)]
+          [(and (cons? a) (null? (cdr a))) (car a)]
+          [else (cons (car a) (list->improper-list (cdr a)))]))
+
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; Stacktrace instrumenter
+  
+  (define calltrace-key #`(quote #,(gensym 'key)))
+  
+  (define-values/invoke-unit/sig stacktrace^ stacktrace@ #f stacktrace-imports^)
+
+  (provide calltrace-eval-handler
+           instrumenting-enabled
+           annotate))
+ 
diff --git a/collects/trace/calltrace.ss b/collects/trace/calltrace.ss
new file mode 100644
index 0000000000..f41ef32f37
--- /dev/null
+++ b/collects/trace/calltrace.ss
@@ -0,0 +1,10 @@
+
+;; Poor man's call tracer.
+;; See doc.txt for information.
+
+(module calltrace mzscheme
+  (require "calltrace-lib.ss")
+  
+  (provide instrumenting-enabled)
+  
+  (current-eval calltrace-eval-handler))
\ No newline at end of file
diff --git a/collects/trace/doc.txt b/collects/trace/doc.txt
new file mode 100644
index 0000000000..26effb6f89
--- /dev/null
+++ b/collects/trace/doc.txt
@@ -0,0 +1,55 @@
+
+ [index entries: _debug_ _debugger_ _debugging_ ]
+
+_Calltrace_ is a tool that displays all calls to user procedures. It
+ displays the arguments to the calls, and indents to show the depth of
+ the continuation.
+
+ Quick instructions
+------------------
+
+  0) Throw away .zo versions of your source
+
+  1) Prefix your program with
+      (require (lib "calltrace.ss" "trace"))
+
+  2) Run your program
+
+The calltrace module is odd; don't import it into another
+module. Instead, the calltrace module is meant to be invoked from the
+top-level, so that it can install an evaluation handler, exception
+handler, etc.
+
+To reuse parts of the code of errortrace, import
+_calltrace-lib.ss_. It contains all of the names here but
+does not set the eval-handler.
+
+Exception Information
+---------------------
+
+Invoking the calltrace.ss module sets the eval handler to instrument
+Scheme source code.
+
+ NOTE: errortrace has no effect on code loaded as compiled byte code
+ (i.e., from a .zo file) or native code (i.e., from a .dll or .so
+ file).
+
+Errortrace's instrumentation can be explicitly disabled via the
+`instrumenting-enabled' boolean parameter. Instrumentation is on by
+default. The `instrumenting-enabled' parameter affects only the way
+that source code is compiled, not the way that exception information
+is reported.
+
+> (instrumenting-enabled) - returns #t if error tracing instrumentation is
+  enabled, #f otherwise
+> (instrumenting-enabled on?) - enables/disables error tracing
+  instrumentation
+
+<slowdown information elided.>
+
+Do not load calltrace before writing .zo files. Calltrace
+instruments S-expressions with unprintable values; this works fine if
+the instrumented S-expression is passed to the default eval handler,
+but neither the S-expression nor its byte-code form can be marshalled
+to a string.
+
diff --git a/collects/trace/info.ss b/collects/trace/info.ss
new file mode 100644
index 0000000000..697ad0c319
--- /dev/null
+++ b/collects/trace/info.ss
@@ -0,0 +1,6 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Calltrace")
+  (define doc.txt "doc.txt")
+  (define blurb
+    (list
+     "Calltrace is a simple annotater that enables call tracing.")))
diff --git a/collects/trace/stacktrace.ss b/collects/trace/stacktrace.ss
new file mode 100644
index 0000000000..c2d88630ca
--- /dev/null
+++ b/collects/trace/stacktrace.ss
@@ -0,0 +1,173 @@
+
+(module stacktrace mzscheme
+  (require (lib "unitsig.ss")
+           (lib "kerncase.ss" "syntax")
+           (lib "stx.ss" "syntax"))
+  
+  (provide stacktrace@ stacktrace^ stacktrace-imports^)
+  
+  (define-signature stacktrace-imports^ (calltrace-key print-call-trace))
+  (define-signature stacktrace^ (annotate))
+  
+  (define o (current-output-port))
+  (define (oprintf . args) (apply fprintf o args))
+  
+  (define-struct stx-protector (stx))
+  
+  (define stacktrace@
+    (unit/sig stacktrace^
+      (import stacktrace-imports^)
+  
+      ;; TEMPLATE FUNCTIONS:
+      ;;  these functions' definitions follow the data definitions presented in the Syntax
+      ;;  chapter of the MzScheme Manual. 
+      
+      (define (top-level-expr-iterator stx)
+        (kernel-syntax-case stx #f
+          [(module identifier name (#%plain-module-begin . module-level-exprs))
+           #`(module identifier name
+               (#%plain-module-begin 
+                #,@(map module-level-expr-iterator (syntax->list #'module-level-exprs))))]
+          [else-stx
+           (general-top-level-expr-iterator stx)]))
+      
+      (define (module-level-expr-iterator stx)
+        (kernel-syntax-case stx #f
+          [(provide . provide-specs)
+           stx]
+          [else-stx
+           (general-top-level-expr-iterator stx)]))
+      
+      (define (general-top-level-expr-iterator stx)
+        (kernel-syntax-case stx #f
+          [(define-values (var ...) expr)
+           (let ([var-list (syntax->list #'(var ...))])
+             (cond [(= (length var-list) 1) #`(define-values (var ...) #,(expr-iterator #'expr (car var-list)))]
+                   [else #`(define-values (var ...) #,(expr-iterator #'expr #f))]))]
+          [(define-syntaxes (var ...) expr)
+           #`(define-syntaxes (var ...) #,(expr-iterator #'expr #f))]
+          [(begin . top-level-exprs)
+           #`(begin #,@(map top-level-expr-iterator (syntax->list #'top-level-exprs)))]
+          [(require . require-specs)
+           stx]
+          [(require-for-syntax . require-specs)
+           stx]
+          [else
+           (expr-iterator stx #f)]))
+  
+      (define (expr-iterator stx potential-name)
+        (let* ([name-guess (or (syntax-property stx 'inferred-name) potential-name)]
+               [recur-tail (lambda (expr) (expr-iterator expr name-guess))]
+               [recur-non-tail (lambda (expr) (expr-iterator expr #f))]
+               [recur-with-name (lambda (expr name) (expr-iterator expr name))]
+               [recur-on-sequence (lambda (exprs) 
+                                    (let loop ([remaining exprs])
+                                      (cond [(null? remaining) null]
+                                            [(null? (cdr remaining)) (list (recur-tail (car remaining)))]
+                                            [else (cons (recur-non-tail (car remaining))
+                                                        (loop (cdr remaining)))])))]
+               [lambda-clause-abstraction
+                (lambda (clause)
+                  (kernel-syntax-case clause #f
+                    [(arglist . bodies)
+                     (let-values ([(arglist-proper improper?) (arglist-flatten #'arglist)])
+                       (if name-guess
+                           #`(arglist (with-continuation-mark 
+                                          #,calltrace-key
+                                        'unimportant
+                                        (begin (let ([call-depth (length (continuation-mark-set->list
+                                                                          (current-continuation-marks)
+                                                                          #,calltrace-key))])
+                                                 (#,print-call-trace 
+                                                    (quote-syntax #,name-guess)
+                                                    #,(syntax-original? name-guess)
+                                                    (#,stx-protector-stx #,(make-stx-protector stx))
+                                                    (list #,@arglist-proper)
+                                                    #,improper?
+                                                    call-depth))
+                                               #,@(recur-on-sequence (syntax->list #'bodies)))))
+                           #`(arglist #,@(recur-on-sequence (syntax->list #'bodies)))))]
+                    [else
+                     (error 'expr-syntax-object-iterator 
+                            "unexpected (case-)lambda clause: ~a" 
+                            (syntax-object->datum stx))]))]
+               [let-values-abstraction
+                (lambda (stx)
+                  (kernel-syntax-case stx #f
+                    [(kwd (((variable ...) rhs) ...) . bodies)
+                     (let* ([clause-fn 
+                             (lambda (vars rhs)
+                               (let ([var-list (syntax->list vars)])
+                                 (cond [(= (length var-list) 1) 
+                                        #`(#,vars #,(recur-with-name rhs (car var-list)))]
+                                       [else
+                                        #`(#,vars #,(recur-non-tail rhs))])))])
+                       (with-syntax ([(new-clause ...)
+                                      (map clause-fn
+                                           (syntax->list #`((variable ...) ...))
+                                           (syntax->list #`(rhs ...)))])
+                         #`(kwd (new-clause ...) #,@(recur-on-sequence (syntax->list #'bodies)))))]
+                    [else
+                     (error 'expr-syntax-object-iterator 
+                            "unexpected let(rec) expression: ~a"
+                            stx
+                            ;(syntax-object->datum stx)
+                            )]))]) 
+          (kernel-syntax-case stx #f
+            [var-stx
+             (identifier? (syntax var-stx))
+             stx]
+            [(lambda . clause)
+             #`(lambda #,@(lambda-clause-abstraction #'clause))]
+            [(case-lambda . clauses)
+             #`(case-lambda #,@(map lambda-clause-abstraction (syntax->list #'clauses)))]
+            [(if test then)
+             #`(if #,(recur-non-tail #'test) #,(recur-tail #'then))]
+            [(if test then else)
+             #`(if
+                #,(recur-non-tail #'test)
+                #,(recur-non-tail #'then)
+                #,(recur-non-tail #'else))]
+            [(begin . bodies)
+             #`(begin #,@(recur-on-sequence (syntax->list #'bodies)))]
+            [(begin0 . bodies)
+             #`(begin #,@(map recur-non-tail #'bodies))]
+            [(let-values . _)
+             (let-values-abstraction stx)]
+            [(letrec-values . _)
+             (let-values-abstraction stx)]
+            [(set! var val)               
+             #`(set! var #,(recur-with-name #'val #'var))]
+            [(quote _)
+             stx]
+            [(quote-syntax _)
+             stx]
+            [(with-continuation-mark key mark body)
+             #`(with-continuation-mark
+                #,(recur-non-tail #'key)
+                #,(recur-non-tail #'mark)
+                #,(recur-tail #'body))]
+            [(#%app . exprs)
+             #`(#%app #,@(map recur-non-tail (syntax->list #'exprs)))]
+            [(#%datum . _)
+             stx]
+            [(#%top . var)
+             stx]
+            [else
+             (error 'expr-iterator "unknown expr: ~a" 
+                    (syntax-object->datum stx))]))) 
+      
+      (define (arglist-flatten arglist)
+        (let loop ([remaining arglist]
+                   [so-far null])
+        (syntax-case remaining ()
+          [()
+           (values (reverse so-far) #f)]
+          [var
+           (identifier? (syntax var))
+           (values (reverse (cons #'var so-far)) #t)]
+          [(var . rest)
+           (loop #'rest (cons #'var so-far))])))
+      
+      
+      (define (annotate x) (top-level-expr-iterator x)))))
diff --git a/collects/trace/test-cases-proposed.txt b/collects/trace/test-cases-proposed.txt
new file mode 100644
index 0000000000..d362763845
--- /dev/null
+++ b/collects/trace/test-cases-proposed.txt
@@ -0,0 +1,8 @@
+factorial
+tail recursion
+odd & even
+all flavors of improper arglist
+anonymous procedures
+all language constructs
+indentation of first call (from error)
+unannotated code
diff --git a/collects/version/check-gui.ss b/collects/version/check-gui.ss
new file mode 100644
index 0000000000..87e5ee7fb2
--- /dev/null
+++ b/collects/version/check-gui.ss
@@ -0,0 +1,6 @@
+(module check-gui mzscheme
+  (require "private/gui-defs.ss" "private/go-check.ss" (lib "etc.ss"))
+  (provide check-version)
+  (define check-version
+    (opt-lambda ([parent-frame #f] [sync? #f])
+      (go-check parent-frame sync? gui-defs@))))
diff --git a/collects/version/check-text.ss b/collects/version/check-text.ss
new file mode 100644
index 0000000000..86849c80d8
--- /dev/null
+++ b/collects/version/check-text.ss
@@ -0,0 +1,4 @@
+(module check-text mzscheme
+  (require "private/text-defs.ss" "private/go-check.ss")
+  (provide check-version)
+  (define (check-version) (go-check #f #f text-defs@)))
diff --git a/collects/version/doc.txt b/collects/version/doc.txt
new file mode 100644
index 0000000000..42508f9349
--- /dev/null
+++ b/collects/version/doc.txt
@@ -0,0 +1,44 @@
+_Version_ or _version_: PLT software online version checking
+============================================================
+
+The version collection allows online version checking of PLT software.
+The user-side software sends version information about installed
+software to a server that compares that information against the latest
+released versions.
+
+In particular, the user-side software sends to the server
+
+ - the binary version as reported by (version), a MzScheme primitive,
+   and
+ - the values of the release-version and release-iteration fields in
+   the info.ss file for collections, if those fields exist
+
+If the binary version is out of date, that information is reported to
+the user.  Otherwise, the status of each package is reported.  The
+determination of whether a package is up-to-date is made on the server
+side.
+
+Two files may be used to run version checks from MrEd and MzScheme:
+_check-text.ss_ for (MrEd or MzScheme), and _check-gui.ss_ (for MrEd).
+These files contain modules that export a procedure named
+check-version:
+
+ (require (lib "check-gui.ss" "version"))
+
+and
+
+ (require (lib "check-text.ss" "version"))
+
+For check-text.ss, the procedure is called with
+
+> (check-version)
+
+For check-gui.ss, the procedure is called with
+
+> (check-version [frame] [sync?])
+
+where the optional argument `frame' is either a frame% instance or #f,
+the default.  The optional `sync?' argument is any Scheme value, #f by
+default.  If `sync?' is #f, the procedure returns immediately;
+otherwise, it returns after the user clicks OK on the dialog box that
+appears (or when an error occurs).
diff --git a/collects/version/info.ss b/collects/version/info.ss
new file mode 100644
index 0000000000..223173d643
--- /dev/null
+++ b/collects/version/info.ss
@@ -0,0 +1,3 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Version")
+  (define doc.txt "doc.txt"))
diff --git a/collects/version/patchlevel.ss b/collects/version/patchlevel.ss
new file mode 100644
index 0000000000..c8ea9af2e5
--- /dev/null
+++ b/collects/version/patchlevel.ss
@@ -0,0 +1,5 @@
+;; this file contains the current patch level of DrScheme
+;; it is usually `0' in cvs, and changed only when a patch is made.
+(module patchlevel mzscheme
+  (define patchlevel 0)
+  (provide patchlevel))
diff --git a/collects/version/private/checksigs.ss b/collects/version/private/checksigs.ss
new file mode 100644
index 0000000000..ebf7a0977d
--- /dev/null
+++ b/collects/version/private/checksigs.ss
@@ -0,0 +1,15 @@
+(module checksigs mzscheme
+  (require (lib "unitsig.ss"))
+  (provide empty^ extra-params^ defs^)
+  (define-signature empty^
+    ())
+  (define-signature extra-params^
+    (check-frame
+     sync?))
+  (define-signature defs^
+    (run-thunk
+     show-ok
+     show-error-ok
+     make-wait-dialog
+     show-wait-dialog
+     hide-wait-dialog)))
diff --git a/collects/version/private/go-check.ss b/collects/version/private/go-check.ss
new file mode 100644
index 0000000000..a28fb5c4aa
--- /dev/null
+++ b/collects/version/private/go-check.ss
@@ -0,0 +1,15 @@
+(module go-check mzscheme
+  (require (lib "unitsig.ss") "checksigs.ss" "runcheck.ss")
+  (provide go-check)
+  (define (go-check frame the-sync defs@)
+    (let ([extra-params@ (unit/sig extra-params^ (import)
+                           (define check-frame frame)
+                           (define sync? the-sync))])
+      (invoke-unit/sig
+       (compound-unit/sig
+        (import)
+        (link
+         [CFRAME : extra-params^ (extra-params@)]
+         [DEFS : defs^ (defs@)]
+         [RUNCHECK : empty^ (runcheck@ (CFRAME) (DEFS))])
+        (export))))))
diff --git a/collects/version/private/gui-defs.ss b/collects/version/private/gui-defs.ss
new file mode 100644
index 0000000000..168c744916
--- /dev/null
+++ b/collects/version/private/gui-defs.ss
@@ -0,0 +1,119 @@
+(module gui-defs mzscheme
+  (require (lib "unitsig.ss") (lib "class.ss") (lib "mred.ss" "mred")
+           (lib "string-constant.ss" "string-constants")
+           "checksigs.ss")
+  (provide gui-defs@)
+  (define gui-defs@
+    (unit/sig defs^ (import)
+
+      (define (run-thunk th)
+        (parameterize ([current-eventspace (make-eventspace)])
+          (queue-callback th)))
+
+      ;; string (list string (listof string)) (union (listof string) #f) -> void
+      (define (show-ok title captions details ok-thunk)
+        (letrec ([frame
+                  (instantiate frame% ()
+                    [label title]
+                    [min-width 50]
+                    [alignment '(left center)]
+                    [stretchable-height #f]
+                    [stretchable-width #f]
+                    [style '(no-resize-border)])]
+                 [main-panel (instantiate vertical-panel% ()
+                               [parent frame]
+                               [stretchable-width #f]
+                               [stretchable-height #f]
+                               [alignment '(center center)])]
+                 [panel-sep 4]
+                 [msg-width 50]
+                 [make-make-panel
+                  (lambda (c%)
+                    (lambda ()
+                      (instantiate c% ()
+                        [parent main-panel]
+                        [vert-margin panel-sep]
+                        [alignment '(center center)])))]
+                 [make-hpanel (make-make-panel horizontal-panel%)]
+                 [make-vpanel (make-make-panel vertical-panel%)]
+                 [row-panel (make-vpanel)]
+                 [make-msg
+                  (lambda (msg panel)
+                    (instantiate message% ()
+                      [min-width msg-width] [label msg] [parent panel]))]
+                 [status-msgs (map (lambda (msg) (make-msg msg row-panel))
+                                   captions)]
+                 [details-panel #f]
+                 [showing-details #f]
+                 [details-text "Details "]
+                 [show-details-button-text (string-append details-text ">>")]
+                 [hide-details-button-text (string-append details-text "<<")]
+                 [hide-details
+                  (lambda ()
+                    (set! showing-details #f)
+                    (send main-panel delete-child details-panel)
+                    (send details-button set-label show-details-button-text)
+                    (set! details-panel #f))]
+                 [show-details
+                  (lambda ()
+                    (set! showing-details #t)
+                    (send details-button set-label hide-details-button-text)
+                    (set! details-button-callback hide-details)
+                    (unless details-panel
+                      (set! details-panel
+                            (instantiate vertical-panel% ()
+                              (parent main-panel)
+                              (style '(border))
+                              (border 2)
+                              (vert-margin panel-sep)
+                              (alignment '(left center))))
+                      (for-each (lambda (d) (make-msg d details-panel))
+                                details)))]
+                 [details-button-callback
+                  (lambda (e bv)
+                    (if showing-details (hide-details) (show-details)))]
+                 [buttons-panel (make-hpanel)]
+                 [ok-button (instantiate button% ()
+                              [label "OK"] [min-width 20] [parent buttons-panel]
+                              [callback (lambda (b ev)
+                                          (send frame show #f)
+                                          (ok-thunk))])]
+                 [spacer
+                  (and details
+                       (instantiate message% ()
+                         [min-width 20] [label ""] [parent buttons-panel]))]
+                 [details-button
+                  (and details
+                       (not (null? details))
+                       (instantiate button% ()
+                         [label show-details-button-text]
+                         [min-width 20]
+                         [parent buttons-panel]
+                         [callback details-button-callback]))])
+          (send frame center)
+          (send frame show #t)))
+
+      (define (show-error-ok title caption)
+        (show-ok title
+                 (list (format (string-constant vc-error-format) caption))
+                 #f
+                 void))
+
+      (define (make-wait-dialog parent title caption close-fun)
+        (let ([dialog (instantiate dialog% ()
+                        [label title] [parent parent] [width 100] [height 50]
+                        [stretchable-width #t] [stretchable-height #t])])
+          (instantiate message% () [label caption] [parent dialog])
+          (instantiate button% ()
+            [label (string-constant cancel)]
+            [parent dialog]
+            [callback (lambda (button ce) (close-fun) (send dialog show #f))])
+          dialog))
+
+      (define (show-wait-dialog dialog)
+        (send dialog center)
+        (thread (lambda () (send dialog show #t)))
+        (send dialog focus))
+
+     (define (hide-wait-dialog dialog)
+       (send dialog show #f)))))
diff --git a/collects/version/private/info.ss b/collects/version/private/info.ss
new file mode 100644
index 0000000000..dafaa65745
--- /dev/null
+++ b/collects/version/private/info.ss
@@ -0,0 +1,2 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Version private"))
diff --git a/collects/version/private/runcheck.ss b/collects/version/private/runcheck.ss
new file mode 100644
index 0000000000..e4dc552180
--- /dev/null
+++ b/collects/version/private/runcheck.ss
@@ -0,0 +1,224 @@
+(module runcheck mzscheme
+  (require (lib "unitsig.ss") (lib "list.ss") (lib "url.ss" "net")
+           (lib "getinfo.ss" "setup")
+           (lib "string-constant.ss" "string-constants")
+           "checksigs.ss" (lib "patchlevel.ss" "version"))
+  (provide runcheck@)
+  (define runcheck@
+    (unit/sig empty^ (import extra-params^ defs^)
+
+      (define download-url-string "http://download.plt-scheme.org/")
+
+      (define sync-sem (make-semaphore 0))
+
+      (define ok-thunk
+        (if sync? (lambda () (semaphore-post sync-sem)) void))
+
+      (define current-format (string-constant vc-current-format))
+
+      (define (make-url-string vcs)
+        (string-append
+         (apply string-append
+                "http://download.plt-scheme.org/cgi-bin/check-version?"
+                (map (lambda (cv)
+                       (string-append
+                        "package=" (car cv) "*" (cadr cv) "*" (caddr cv) "&"))
+                     vcs))
+         "binary-version="
+         (if (> patchlevel 0)
+           (format "~ap~a" (version) patchlevel)
+           (version))))
+
+      (define timeout-value 60)
+
+      (define the-port #f)
+
+      (define (get-collect-version-info collect)
+        (let ([info-proc (get-info (list collect))])
+          (if (not info-proc)
+            (list 'no-info-file 'no-info-file)
+            (list (info-proc 'release-version
+                             (lambda _ 'no-release-info))
+                  (info-proc 'release-iteration
+                             (lambda _ 'no-iteration-info))))))
+
+      (define (cvi-triples)
+        ;; find all collections
+        (let ([collects-dirs (current-library-collection-paths)])
+          (let outer-loop ([collects-dirs collects-dirs])
+            (if (null? collects-dirs)
+              '()
+              (let* ([curr-collects-dir (car collects-dirs)]
+                     [dirs (filter
+                            (lambda (d)
+                              (directory-exists?
+                               (build-path curr-collects-dir d)))
+                            (if (directory-exists? curr-collects-dir)
+                              (directory-list curr-collects-dir)
+                              '()))])
+                (let inner-loop ([dirs dirs])
+                  (if (null? dirs)
+                    (outer-loop (cdr collects-dirs))
+                    (let* ([curr-dir (car dirs)]
+                           [dir-version-and-iteration
+                            (get-collect-version-info curr-dir)])
+                      (if (andmap string? dir-version-and-iteration) ; not a symbol indicating an error
+                        (cons (cons curr-dir dir-version-and-iteration)
+                              (inner-loop (cdr dirs)))
+                        (inner-loop (cdr dirs)))))))))))
+
+      (define (go)
+        (let* ([wait-dialog #f]
+               [dialog-sem (make-semaphore 0)]
+               [got-cancel? #f]
+               [timer-proc
+                (lambda ()
+                  (let loop ([n 0])
+                    (if (> n timeout-value)
+                      (begin
+                        (when wait-dialog (hide-wait-dialog wait-dialog))
+                        ;; will force exception on pending read
+                        (if the-port
+                          (close-input-port the-port)
+                          (set! got-cancel? #t))
+                        (run-thunk
+                         (lambda ()
+                           (show-ok (string-constant vc-network-timeout)
+                                    (list (string-constant vc-cannot-connect))
+                                    #f
+                                    ok-thunk))))
+                      (begin (sleep 1) (loop (add1 n))))))]
+               [timeout-thread (thread timer-proc)])
+
+          (run-thunk
+           (lambda ()
+             (set! wait-dialog
+                   (make-wait-dialog
+                    #f
+                    (string-constant vc-please-wait)
+                    (string-constant vc-connecting-version-server)
+                    (lambda ()
+                      (set! got-cancel? #t)
+                      (with-handlers ([void void]) ; thread might already be dead
+                       (kill-thread timeout-thread)
+                       (when the-port
+                         (close-input-port the-port))))))
+             (show-wait-dialog wait-dialog)
+             (semaphore-post dialog-sem)))
+
+          (semaphore-wait dialog-sem)
+
+          (set! the-port
+                (with-handlers ([void
+                                 (lambda _
+                                   (kill-thread timeout-thread)
+                                   (hide-wait-dialog wait-dialog)
+                                   (unless got-cancel?
+                                     (run-thunk
+                                      (lambda ()
+                                        (show-error-ok
+                                         (string-constant vc-network-failure)
+                                         (string-constant vc-cannot-connect)))))
+                                   (raise 'network-error))])
+                  (get-pure-port
+                   (string->url (make-url-string (cvi-triples))))))
+
+          (when got-cancel? ; force exn in read, below
+            (close-input-port the-port))
+
+          (let ([responses
+                 (let loop ()
+                   (let ([r (read the-port)])
+                     (if (eof-object? r)
+                       (begin (kill-thread timeout-thread)
+                              (hide-wait-dialog wait-dialog)
+                              '())
+                       (cons r (loop)))))]
+                [needs-update #f])
+
+            (close-input-port the-port)
+
+            ;; responses are a list of lists of symbol/string pairs:
+            ;;  (((package name)
+            ;;    (installed-version v)
+            ;;    (installed-iteration v)
+            ;;    (latest-version v)
+            ;;    (latest-iteration v)
+            ;;    (verdict s))
+            ;;    ... )
+
+            ;; first handle binary info, which is always first in responses
+
+            (let-values ([(_ binary-version binary-iteration
+                             latest-binary-version latest-binary-iteration
+                             binary-verdict)
+                          (apply values (map cadr (car responses)))])
+
+              (if (eq? binary-verdict 'update)
+
+                ;; inform user of new binary
+
+                (show-ok
+                 (string-constant vc-update-dialog-title)
+                 (list
+                  (string-constant vc-old-binaries)
+                  (format
+                   (string-constant vc-binary-information-format)
+                   binary-version binary-iteration)
+                  (format
+                   (string-constant vc-latest-binary-information-format)
+                   latest-binary-version latest-binary-iteration)
+                  (string-append (string-constant vc-updates-available) " " download-url-string))
+                  #f
+                  ok-thunk)
+
+                ;; else offer info for installed packages
+
+                (let* ([details
+                        (map
+                         (lambda (r)
+                           (let*-values
+                               ([(data) (map cadr r)]
+                                [(package installed-version installed-iteration
+                                          latest-version latest-iteration verdict)
+                                 (apply values data)])
+                             (cond
+                              [(eq? verdict 'up-to-date)
+                               (format current-format
+                                       package installed-version installed-iteration)]
+                              [(eq? verdict 'update)
+                               (set! needs-update #t)
+                               (format (string-constant vc-update-format)
+                                       package
+                                       installed-version installed-iteration
+                                       latest-version latest-iteration)]
+                              [else ""])))
+                          (cdr responses))])
+
+                   (show-ok
+                    (string-constant vc-update-dialog-title)
+                    (list (if needs-update
+                            (string-constant vc-need-update-string)
+                            (string-constant vc-no-update-string))
+                          (format current-format
+                                  (string-constant vc-binary-name)
+                                  binary-version binary-iteration))
+                    (if needs-update
+                      (append details
+                              (list
+                               ""
+                               (string-constant vc-updates-available)
+                               download-url-string))
+                      details)
+                    ok-thunk)))))))
+
+      ;; exceptions are used to report errors elsewhere
+      ;; just ignore here
+
+      (run-thunk
+       (lambda ()
+         (with-handlers ([void (lambda _
+                                 (when sync? (semaphore-post sync-sem)))])
+          (go))))
+
+      (when sync? (semaphore-wait sync-sem)))))
diff --git a/collects/version/private/text-defs.ss b/collects/version/private/text-defs.ss
new file mode 100644
index 0000000000..52c1fa7be5
--- /dev/null
+++ b/collects/version/private/text-defs.ss
@@ -0,0 +1,30 @@
+(module text-defs mzscheme
+  (require (lib "unitsig.ss") "checksigs.ss")
+
+  (provide text-defs@)
+
+  (define text-defs@
+    (unit/sig defs^ (import)
+
+      (define (run-thunk th) (th))
+
+      ;; string (list string (listof string)) (union (listof string) #f) -> void
+      (define (show-ok title captions details ok-thunk) ; ok-thunk for gui, ignore here
+        (printf "~a\n" (car captions))
+        (for-each (lambda (c) (printf " ~a\n" c)) (cdr captions))
+        (when (and details (not (null? details)))
+          (printf "Details:\n")
+          (for-each (lambda (d) (printf " ~a\n" d)) details)))
+
+      (define (show-error-ok title caption)
+        (show-ok title (list (format "Error: ~a" caption)) #f void))
+
+      (define (make-wait-dialog parent title caption close-fun)
+        (list title caption))
+
+      (define (show-wait-dialog dialog)
+        ;; dialog is the pair returned by make-wait-dialog
+        (printf "~a\n" (cadr dialog)))
+
+      (define (hide-wait-dialog dialog)
+        (void)))))
diff --git a/collects/waterworld/README b/collects/waterworld/README
new file mode 100644
index 0000000000..1223a6c41a
--- /dev/null
+++ b/collects/waterworld/README
@@ -0,0 +1,6 @@
+This is WaterWorld, a MineSweeper-like game played on a triangular
+grid.  The game will be used in an undergraduate logic course.
+
+The game was designed by Ian Barland, and coded by Paul Steckler,
+with some implementation ideas taken from Robby Findler's MineSweeper
+game in the games collection.
diff --git a/collects/waterworld/info.ss b/collects/waterworld/info.ss
new file mode 100644
index 0000000000..f8b652c543
--- /dev/null
+++ b/collects/waterworld/info.ss
@@ -0,0 +1,2 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "WaterWorld"))
diff --git a/collects/waterworld/jolly-large-ce.gif b/collects/waterworld/jolly-large-ce.gif
new file mode 100644
index 0000000000..d817bb0a52
Binary files /dev/null and b/collects/waterworld/jolly-large-ce.gif differ
diff --git a/collects/waterworld/jolly-large.gif b/collects/waterworld/jolly-large.gif
new file mode 100644
index 0000000000..bb21591424
Binary files /dev/null and b/collects/waterworld/jolly-large.gif differ
diff --git a/collects/waterworld/jolly-small-ce.gif b/collects/waterworld/jolly-small-ce.gif
new file mode 100644
index 0000000000..d108bbbfb2
Binary files /dev/null and b/collects/waterworld/jolly-small-ce.gif differ
diff --git a/collects/waterworld/jolly-small.gif b/collects/waterworld/jolly-small.gif
new file mode 100644
index 0000000000..31142c5f8f
Binary files /dev/null and b/collects/waterworld/jolly-small.gif differ
diff --git a/collects/waterworld/waterworld.ss b/collects/waterworld/waterworld.ss
new file mode 100644
index 0000000000..9f9ecb9880
--- /dev/null
+++ b/collects/waterworld/waterworld.ss
@@ -0,0 +1,1768 @@
+(module waterworld mzscheme
+  (require (lib "class.ss"))
+  (require (lib "file.ss"))
+  (require (lib "list.ss"))
+  (require (lib "etc.ss"))
+  (require (lib "mred.ss" "mred"))
+  (require (lib "external.ss" "browser"))
+  
+  (define *progname* "WaterWorld")
+
+  (define *prefs-file* 
+	(let*-values 
+	 ([(sys-prefs-file) (find-system-path 'pref-file)]
+	  [(prefs-dir nm mbd) (split-path sys-prefs-file)])
+	 (build-path prefs-dir ".ww-prefs.ss")))
+
+  (define (get-ww-pref sym default)
+    (get-preference sym (lambda () default) #t *prefs-file*))
+
+  (define (put-ww-prefs ss)
+    (let ([syms (map car ss)]
+	  [vals (map cadr ss)])
+      (put-preferences syms vals
+		       (lambda _
+			 (message-box
+			  "WaterWorld error"
+			  "Error saving preferences"
+			  #f
+			  '(ok)))
+		       *prefs-file*)))
+
+  ; base dimensions
+  (define *base-tile-edge-length* 48) ; length of triangular tile edge
+
+  ; scaled dimensions
+  (define *large-tile-scaling-factor* 2.0)
+  (define *small-tile-scaling-factor* 1.0)
+  (define *tile-scaling-factor* #f)
+  (define (tile-scale n)
+    (inexact->exact (round (* *tile-scaling-factor* n))))
+
+  (define *tile-edge-length* #f)
+  (define *half-edge-length* #f)
+  (define *tile-height* #f)
+  (define *half-tile-height* #f)
+  (define *even-slope* #f)
+  (define *odd-slope* #f)
+
+  ; height of equilateral triangle
+  (define *base-tile-height* 
+    (inexact->exact (ceiling (* (/ (expt 3 1/2) 2.0) 
+				*base-tile-edge-length*))))
+  (define *base-half-tile-height* (/ *base-tile-height* 2))
+
+  (define *teaching-board-height* 4)
+  (define *teaching-board-width* 6)
+  (define *teaching-tile-size* 'large)
+
+  (define *default-rows* *teaching-board-height*)
+  (define *default-cols* *teaching-board-width*)
+  (define *default-density* 20)
+  (define *default-tile-size* 'large)
+  (define *default-autoclick* 'yes)
+
+  (define *current-rows* (get-ww-pref 'ww:numrows *default-rows*))
+  (define *current-cols* (get-ww-pref 'ww:numcols *default-cols*))
+  (define *current-density* (get-ww-pref 'ww:density *default-density*))
+  (define *current-tile-size* (get-ww-pref 'ww:tile-size *default-tile-size*))
+  (define *current-autoclick* (get-ww-pref 'ww:autoclick *default-autoclick*))
+
+  (define *last-game-dir* #f) 
+
+  (define *click-sem* (make-semaphore 1))
+
+  (define *default-message-1*
+    "Hold Shift to indicate a pirate (instead of safe water)")
+  (define *default-message-2*
+    "Hold Control to make an assertion (not just a guess)")
+  (define *checking-message*
+    "Considering your move ...")
+
+  (define (make-bitmap s)
+    (make-object bitmap% 
+		 (build-path 
+		  (collection-path "waterworld") s) 'gif))
+  (define *jolly-bitmap* #f)
+  (define *jolly-ce-bitmap* #f)
+  (define *jolly-large-bitmap* (make-bitmap "jolly-large.gif"))
+  (define *jolly-small-bitmap* (make-bitmap "jolly-small.gif"))
+  (define *jolly-large-ce-bitmap* (make-bitmap "jolly-large-ce.gif"))
+  (define *jolly-small-ce-bitmap* (make-bitmap "jolly-small-ce.gif"))
+
+  (define *jolly-small-desc* (list *jolly-small-bitmap* *jolly-small-ce-bitmap* 16 16))
+  (define *jolly-large-desc* (list *jolly-large-bitmap* *jolly-large-ce-bitmap* 23 27))
+
+  (define *jolly-width* #f)
+  (define *jolly-height* #f) 
+  (define *jolly-column-offset* #f)
+  (define *jolly-row-offset-fraction* 1/4)
+  (define *jolly-even-row-offset* #f)
+  (define *jolly-odd-row-offset* #f)
+
+  (define (set-tile-dimensions!)
+    (set! *tile-scaling-factor*
+	 (case *current-tile-size*
+	   [(large) *large-tile-scaling-factor*]
+	   [(small) *small-tile-scaling-factor*]
+	   [else 
+	    (error (format "Unknown tile size: ~a" *current-tile-size*))]))
+    (set! *tile-edge-length* (tile-scale *base-tile-edge-length*))
+    (set! *half-edge-length* (/ *tile-edge-length* 2))
+    (set! *tile-height*  (inexact->exact 
+			  (ceiling (* (/ (expt 3 1/2) 2.0) 
+				      *tile-edge-length*))))
+    (set! *half-tile-height* (/ *tile-height* 2))
+    (set! *even-slope* (/ *tile-height* (- *half-edge-length*)))
+    (set! *odd-slope* (- *even-slope*))
+    (let-values 
+     ([(bmp ce-bmp w h) (apply values 
+			       (case *current-tile-size*
+				 ((large) *jolly-large-desc*) 
+				 ((small) *jolly-small-desc*)
+				 (else "This is unreachable")))])
+     (set! *jolly-bitmap* bmp)
+     (set! *jolly-ce-bitmap* ce-bmp)
+     (set! *jolly-width* w)
+     (set! *jolly-height* h))
+    (set! *jolly-column-offset* 
+	  (round (/ (- *tile-edge-length* *jolly-width*) 2)))
+    (set! *jolly-even-row-offset* 
+	  (round (* (- *tile-height* *jolly-height*) 
+		    (- 1 *jolly-row-offset-fraction*))))
+    (set! *jolly-odd-row-offset* 
+	  (round (* (- *tile-height* *jolly-height*) 
+		    *jolly-row-offset-fraction*))))
+
+  (set-tile-dimensions!)
+    
+  (define *excluded-labels* '("I" "O"))
+  (define *teaching-mode-labels*
+    (let ([offset (char->integer #\A)])
+      (list->vector 
+       (filter (lambda (c) (not (member c *excluded-labels*)))
+	       (build-list 26 (lambda (n) 
+				(string (integer->char 
+					 (+ n offset)))))))))
+  (define (make-color s)
+    (make-object color% s))
+  (define *alpha-color*
+    (make-color "seagreen"))
+  (define *zero-color*
+    (make-color "gray"))
+  (define *non-zero-color*
+    (make-color "red"))
+  (define (make-colored-brush s)
+    (make-object brush% (make-color s) 'solid))
+  (define *concealed-brush* 
+    (make-colored-brush "lightblue"))
+  (define *exposed-brush* 
+    (make-colored-brush "white"))
+  (define *counterexample-brush*
+    (make-colored-brush "red"))
+
+  ; limits
+  (define *min-rows* 3)
+  (define *max-small-rows* 18)
+  (define *max-large-rows* 10)
+  (define *min-cols* 3)
+  (define *max-small-cols* 20)
+  (define *max-large-cols* 12)
+  (define *min-density* 0)
+  (define *max-density* 100)
+
+  (define *need-to-reset-size* #f)
+
+  ; misc
+
+  (define (trim s)
+    (let ([len (string-length s)])
+      (let loop ([start 0])
+	(if (>= start len)
+	    ""
+	    (if (char-whitespace? (string-ref s start))
+		(loop (add1 start))
+		(let loop2 ([end (sub1 len)])
+		  (if (or (<= end start)
+			  (not (char-whitespace? (string-ref s end))))
+		      (substring s start (add1 end))
+		      (loop2 (sub1 end)))))))))
+
+  (define (fold-string . ss)
+    (foldr
+     (lambda (s a)
+       (if a
+	   (format "~a~n~a"
+		   s a)
+	   s))
+     #f
+     ss))
+
+  ; classes
+
+  (define location%
+    (class object% 
+      (init-field 
+       safe? 
+       row 
+       column 
+       [concealed? #t]
+       [unsafe-count 0])
+      (field 
+       [neighbors #f]
+       [revealed-neighbors 0]
+       [unsafe-revealed-neighbors 0]
+       [counterexample-safe? #f]
+       [in-counterexample-set? #f])
+      (public*
+	[get-row
+	 (lambda () row)]
+	[get-column
+	 (lambda () column)]
+	[get-safe?
+	 (lambda () safe?)]
+	[make-unsafe!
+	 (lambda () (set! safe? #f))]
+	[get-counterexample-safe?
+	 (lambda () counterexample-safe?)]
+	[set-counterexample-safe!
+	 (lambda (v) (set! counterexample-safe? v))]
+	[get-in-counterexample-set?
+	 (lambda () in-counterexample-set?)]
+	[set-in-counterexample-set!
+	 (lambda (v) (set! in-counterexample-set? v))]
+	[set-unsafe-count!
+	 (lambda (n) (set! unsafe-count n))]
+	[get-unsafe-count
+	 (lambda () unsafe-count)]
+	[get-concealed?
+	 (lambda () concealed?)]
+	[get-neighbors
+	 (lambda () neighbors)]
+	[get-revealed-neighbors 
+	 (lambda () revealed-neighbors)]
+	[incr-revealed-neighbors! 
+	 (lambda () (set! revealed-neighbors (add1 revealed-neighbors)))]
+	[incr-unsafe-revealed-neighbors! 
+	 (lambda () (set! unsafe-revealed-neighbors (add1 unsafe-revealed-neighbors)))]
+	[set-unsafe-revealed-neighbors! 
+	 (lambda (n) (set! unsafe-revealed-neighbors n))]
+	[get-unsafe-revealed-neighbors
+	 (lambda ()
+	    unsafe-revealed-neighbors)]
+	[set-neighbors!
+	 (lambda (ns) (set! neighbors ns))]
+	[expose
+	 (lambda ()
+	   (if concealed?
+	       (begin
+		 (set! concealed? #f)
+		 #t) ; indicates to caller it was concealed
+	       #f))])
+      (super-instantiate ())))
+
+  (define (remove-duplicates lst)
+    (if (null? lst) 
+	'()
+	(let ([the-car (car lst)])
+	  (cons the-car
+		(remq the-car
+		      (remove-duplicates (cdr lst)))))))
+
+  (define board%
+    (class object%
+      (init-field (rows *current-rows*) (columns *current-cols*)) 
+      (field [board-vector #f]
+	     [pirates-left #f]
+	     [pirates-ratio #f]
+	     [unsafe-count #f]
+	     [num-concealed (* rows columns)]
+	     [frontier-table #f]
+	     [teaching-mode? #f]
+	     [canvas #f]
+	     [current-counterexample #f])
+      (private*
+       [do-board-map 
+	(lambda (f update?)
+	  (when board-vector
+		(let ([olen (vector-length board-vector)]
+		      [ilen (vector-length (vector-ref board-vector 0))])
+		  (let oloop ([i 0])
+		    (when (< i olen)
+			  (let ([row-vec (vector-ref board-vector i)])    
+			    (let iloop ([j 0])
+			      (when (< j ilen)
+				    (let ([r (f (vector-ref row-vec j))])
+				      (when update? 
+					    (vector-set! row-vec j r)))
+				    (iloop (add1 j))))
+			    (oloop (add1 i))))))))]
+       [sum-location-unsafe
+	(lambda (s)
+	  (foldr (lambda (loc accum)
+		   (if (send loc get-safe?)
+		       accum
+		       (add1 accum)))
+		 0
+		 s))]
+       [set-unsafe-count!
+	(lambda ()
+	  (set! unsafe-count 
+		(inexact->exact (round (* (/ *current-density* 100.0) 
+					  rows columns)))))]
+       [decrement-concealed!
+	(lambda ()
+	  (set! num-concealed (sub1 num-concealed))
+	  (calc-pirates-ratio!))]
+       [decrement-pirates-left!
+	(lambda ()
+	  (set! pirates-left (sub1 pirates-left))
+	  (calc-pirates-ratio!))]
+       [num-unsafe-in-assignment
+	(lambda (assn)
+	  (foldl 
+	   (lambda (a total)
+	     (if a
+		 (add1 total)
+		 total))
+	   0
+	   (map cdr assn)))]
+       [beyond-frontier
+	(lambda ()
+	  (let ([locs null])
+	    (board-for-each ; OK, mutation here
+	     (lambda (loc)
+	       (when (and (send loc get-concealed?)
+			  (not (in-frontier? loc)))
+		     (set! locs (cons loc locs)))))
+	    locs))]
+       [get-frontier-elements
+	(lambda ()
+	  (hash-table-map frontier-table (lambda (key _) key)))]
+       [get-revealed-border
+	(lambda ()
+	  (filter (lambda (elt)
+		    (and (not (send elt get-concealed?))
+			 (send elt get-safe?)))
+		  (remove-duplicates
+		   (apply append 
+			  (map (lambda (elt)
+				 (get-neighbors elt))
+			       (get-frontier-elements))))))]
+       [get-border-counts
+	(lambda (border)
+	  ; assoc list, in which for each list element:
+	  ; the car is a revealed neighbor of the frontier
+	  ; the cdr is the difference between the number
+	  ;  of unsafe neighbors (what the user sees)
+	  ;  and the number of already-revealed neighbors;
+	  ;  a consistent frontier assignment must contribute
+	  ;  that difference 
+	  (map (lambda (loc)
+		 (cons loc
+		       (- (send loc get-unsafe-count)
+			  (send loc get-unsafe-revealed-neighbors))))
+	       border))]
+       [locally-consistent?
+	(lambda (loc assns)
+	  (let ([very-locally-consistent?
+		 (lambda (nbr)
+		   (let* ([nbr-nbrs (send nbr get-neighbors)]
+			  [nbr-contribution
+			   (foldr
+			    (lambda (nbr-nbr accum)
+			      (if (and (not (send nbr-nbr
+						  get-concealed?))
+				       (not (send nbr-nbr get-safe?)))
+				  (add1 accum)
+				  accum))
+			    0
+			    nbr-nbrs)]
+			  [assn-contribution
+			   (foldr
+			    (lambda (a accum)
+			      (let ([entry (assq a assns)])
+				(if (and entry
+					 (cdr entry))
+				    (add1 accum)
+				    accum)))
+			    0
+			    nbr-nbrs)])
+		     (<= (+ nbr-contribution
+			    assn-contribution)
+			 (send nbr get-unsafe-count))))]
+		[revealed-neighbors 
+		 (filter (lambda (nbr) 
+			   (and (not (send nbr get-concealed?))
+				(send nbr get-safe?)))
+			 (send loc get-neighbors))])
+	    (andmap very-locally-consistent? revealed-neighbors)))]
+       [check-assignment
+	(lambda (curr fr assns escape-info)
+	  (if (or (not (cdar assns)) ; #f consistent if (cdr assns) was
+		  (locally-consistent? curr assns))
+	      (gen-locally-consistent-assignments fr assns escape-info)
+	      null))]
+       [gen-locally-consistent-assignments 
+	(lambda (fr assns escape-info)
+	  (if (null? fr)
+	      ; escape-info is true iff we're looking for just
+	      ;  one consistent assignment
+	      (if escape-info
+		  (let-values
+		   ([(loc safe? border
+			  border-frontier-neighbors
+			  border-counts
+			  thunk
+			  k)
+		     (apply values escape-info)])
+		   (if (and (let* ([loc-entry (assq loc assns)]
+				   [loc-assn (and loc-entry (cdr loc-entry))])
+			      ; really a counterexample
+			      (and loc-entry (eq? loc-assn safe?)))
+			    (check-consistency assns
+					       border 
+					       border-frontier-neighbors
+					       border-counts))
+			 ; show counterexample, then escape
+		       (k (counterexample-prompt assns loc safe? thunk))
+		       (list assns)))
+		  (list assns))
+	      (let* ([curr (car fr)]
+		     [rest-fr (cdr fr)])
+		(apply 
+		 append
+		 (map (lambda (b)
+			(check-assignment
+			 curr rest-fr (cons (cons curr b) assns)
+			 escape-info))
+		      (list #f #t))))))]
+       [gen-all-consistent-assignments
+	(lambda ()
+	  (let* ([fr (frontier-list)]
+		 [assns null]
+		 [border (get-revealed-border)]
+		 [border-frontier-neighbors 
+		  (map (lambda (b)
+			 (cons b (filter (lambda (loc) (in-frontier? loc))
+					 (send b get-neighbors))))
+		       border)]
+		 [border-counts (get-border-counts border)])
+	    (filter (lambda (assn)
+		      (check-consistency assn
+					 border
+					 border-frontier-neighbors
+					 border-counts))
+		    (gen-locally-consistent-assignments fr assns #f))))]
+       [all-assignments-consistent?
+	; do all consistent assignments have the same
+	;  value for particular location
+	(lambda (loc)
+	  (let* ([all-assns (gen-all-consistent-assignments)]
+		 [first-assn (car all-assns)] ; must be at least one
+		 [loc-val (cdr (assq loc first-assn))])
+	    (let loop ([assns (cdr all-assns)])
+	      (if (null? assns)
+		  #t
+		  (if (eq? (cdr (assq loc (car assns)))
+			   loc-val)
+		      (loop (cdr assns))
+		      #f)))))]
+       [uniform-consistent-frontiers
+	(lambda ()
+	  (let ([all-assns (gen-all-consistent-assignments)])
+	    (let loop ([assns all-assns]
+		       [count #f])
+	      (if (null? assns)
+		  all-assns
+		  (if count
+		      (if (= (num-unsafe-in-assignment (car assns))
+			     count)
+			  (loop (cdr assns) count)
+			  #f)
+		      (loop (cdr assns) (num-unsafe-in-assignment 
+					 (car assns))))))))]
+       [dump-assignment
+	(lambda (assn)
+	  (printf "*** dumping assignment ***~n")
+	  (let loop ([curr assn])
+	    (unless (null? curr)
+		    (let ([loc (caar curr)]
+			  [val (cdar curr)])
+		      (printf "row: ~a col: ~a val: ~a~n"
+			      (send loc get-row) 
+			      (send loc get-column) 
+			      val))
+		    (loop (cdr curr)))))]
+       [check-consistency
+	(lambda (assignment border border-frontier-neighbors border-counts)
+          (if (> (num-unsafe-in-assignment assignment) pirates-left)
+	      #f ; can't put more in assignment than total remaining
+	      (let* ([assignment-counts 
+                      ; the unsafe counts for revealed tiles with frontier
+		      ;  neighbor that the frontier assignment *would* yield
+		      (map
+		       (lambda (loc-nbrs)
+			 (cons (car loc-nbrs)
+			       (let loop ([nbrs (cdr loc-nbrs)])
+				 (if (null? nbrs)
+				     0
+				     (let* ([first-nbr (car nbrs)]
+					    [mem-front
+					     (assq first-nbr assignment)])
+				       (if (cdr mem-front)
+					; increment hypothetical unsafe count
+					   (add1 (loop (cdr nbrs)))
+					   (loop (cdr nbrs))))))))
+		       border-frontier-neighbors)])
+		(let ([unsafe-count-consistent?
+		       (let loop ([acs assignment-counts])
+			 (if (null? acs)
+			     #t
+			     (let ([first-ac (car acs)])
+			       (if (eq? (cdr (assq (car first-ac)
+						   border-counts))
+					(cdr first-ac))
+				   (loop (cdr acs))
+				   #f))))])
+		  unsafe-count-consistent?))))]
+       [counterexample-prompt
+	(lambda (assignment loc safe? thunk)
+	  (let ([mbox-result
+		 (message-box/custom 
+		  *progname*
+		  (fold-string
+		   "There is a counterexample to your claim"
+		   (if teaching-mode?
+		       (format 
+			"that the tile labeled ~a is ~a."
+			(vector-ref 
+			 *teaching-mode-labels*
+			 (+ (* (send loc get-row) 
+			       *teaching-board-width*)
+			    (send loc get-column)))
+			(if safe? "safe" "unsafe"))
+		       (format "that the tile on row ~a, column ~a is ~a."
+			       (add1 (send loc get-row))
+			       (add1 (send loc get-column))
+			       (if safe? "safe" "unsafe")))
+		   ""
+		   "Do you wish to see the counterexample?"
+		   "")
+		  "Yes, show me"        ; button 1
+		  "No, finish click"    ; button 2
+		  "No, don't click"     ; button 3
+		  #f
+		  '(default=1)
+		  3)])
+	    (case mbox-result
+	      [(1)
+	       (set! current-counterexample assignment)
+		; clear any existing counterexample
+	       (board-for-each
+		(lambda (loc)
+		  (send loc set-in-counterexample-set! #f)))
+		; set locations in assignment
+	       (for-each
+		(lambda (assn)
+		  (let ([loc (car assn)])
+		    (send loc set-counterexample-safe! (not (cdr assn)))
+		    (send loc set-in-counterexample-set! #t)))
+		assignment)
+		; set locations not in assignment
+	       (let ([unsafe-needed
+		      (- pirates-left
+			 (num-unsafe-in-assignment assignment))])
+		 (board-for-each
+		  (lambda (loc)
+		    (unless (or (assq loc assignment)
+				(not (send loc get-concealed?)))
+			    (send loc set-in-counterexample-set! #t)
+			    (if (> unsafe-needed 0)
+				(begin
+				  (send loc set-counterexample-safe! #f)
+				  (set! unsafe-needed (sub1 unsafe-needed)))
+				(send loc set-counterexample-safe! #t))))))
+	       (send canvas set-in-counterexample! #t)
+	       (draw)]
+	      [(2) (thunk)]
+	      [(3) (void)])))]
+       [forced-location?
+        ; returns #t if loc is required to be safe?
+	(lambda (loc safe?)
+	  (cond
+	   [(= pirates-left 0) safe?]
+	   [(= pirates-left num-concealed) (not safe?)]
+	   [else #f]))]
+       [find-consistent-frontier
+	(lambda (loc safe? thunk)
+	  (let/ec k
+            (let* ([fr (frontier-list)]
+		   [assns null]
+		   [border (get-revealed-border)]
+		   [border-frontier-neighbors 
+		    (map (lambda (b)
+			   (cons b (filter (lambda (loc) (in-frontier? loc))
+					   (send b get-neighbors))))
+			 border)]
+		   [border-counts (get-border-counts border)])
+	      (gen-locally-consistent-assignments 
+	       fr assns 
+	       (list loc safe? 
+		     border
+		     border-frontier-neighbors
+		     border-counts
+		     thunk
+		     k))
+	      (thunk))))])
+      (public*
+       [ww-messages
+	(lambda (s1 s2)
+	  (and canvas
+	       (send canvas ww-messages s1 s2)))]
+       [reset-ww-messages!
+	(lambda ()
+	  (and canvas
+	       (send canvas reset-ww-messages!)))]
+       [get-num-concealed
+	(lambda () num-concealed)]
+       [draw
+	(lambda ()
+	  (board-for-each 
+	   (lambda (loc) 
+	     (send canvas paint-tile loc))))]
+       [clear-counterexample!
+	(lambda ()
+	  (send canvas set-in-counterexample! #f)
+	  (draw))]
+       [set-teaching-mode!
+	(lambda (mode)
+	  (set! teaching-mode? mode))]
+       [set-canvas!
+	(lambda (cnv)
+	  (set! canvas cnv))]
+       [update-settings!
+	(lambda ()
+	  (set! rows *current-rows*)
+	  (set! columns *current-cols*)
+	  (set-unsafe-count!))]
+       [calc-unsafe!
+	(lambda ()
+	  (board-for-each
+	   (lambda (loc)
+	     (let* ([neighbors (get-neighbors loc)]
+		    [unsafe/revealed
+		     (foldl 
+		      (lambda (nbr tot)
+			(let ([c? (send nbr get-concealed?)]
+			      [s? (send nbr get-safe?)])
+			  (if s?
+			      tot ; safe
+			      (if c?
+				  ; unsafe but concealed
+				  (list (add1 (car tot)) (cadr tot))
+				  ; unsafe revealed
+				  (list (add1 (car tot)) (add1 (cadr tot)))))))
+		      (list 0 0)
+		      neighbors)])
+	       (send loc set-unsafe-revealed-neighbors! (cadr unsafe/revealed))
+	       (send loc set-unsafe-count! (car unsafe/revealed))))))]
+       [do-expose-row-col
+	(lambda (loc r c safe?)
+	  (let ([neighbors (get-neighbors loc)]
+		[actually-safe? (send loc get-safe?)])
+	    (when (send loc expose)
+		  (send frame draw-tile r c) ; really should notify a controller
+		  (update-frontier! loc)
+		  (for-each
+		   (lambda (nbr)
+		     (send nbr incr-revealed-neighbors!)
+		     (unless actually-safe?
+			     (send nbr incr-unsafe-revealed-neighbors!)))
+		   neighbors)
+		  (decrement-concealed!)
+		  (if (not actually-safe?)
+		      (decrement-pirates-left!)
+		      (let* ([unsafe-count 
+			      (sum-location-unsafe neighbors)])
+			(send loc set-unsafe-count! unsafe-count)
+			(when (eq? *current-autoclick* 'yes)
+			      (when (= 0 unsafe-count)
+				    (for-each
+				     (lambda (nloc)
+				       (when (send nloc get-concealed?)
+					     (expose-row-col 
+					      (send nloc get-row)
+					      (send nloc get-column)
+					      #f
+					      #f
+					      #t)))
+				     neighbors))))))))]
+       [guess-demerit
+	(lambda (loc safe? thunk)
+	  (thunk)
+	  (ww-messages
+	   (string-append
+	    "Aaargh! Yer guessed "
+	    (if (eq? safe? (send loc get-safe?))
+		"right"
+		"wrong") " when ya ought notta guessed!")
+	   ""))]
+       [check-guess
+	(lambda (loc safe? thunk)
+	  (thunk)
+	  (unless (eq? safe? (send loc get-safe?))
+		  (ww-messages
+		   "Yer guess waren't so good, matey!" "")))]
+       [expose-row-col
+	(lambda (r c safe? assert auto-clicked?)
+	  (let* ([loc (get-location r c)]
+		 [expose-thunk (lambda () 
+				 (do-expose-row-col 
+				  loc r c safe?))])
+	    (if auto-clicked?
+		(expose-thunk)
+		(if assert
+                    ; assertion, not guess
+		    (cond
+		     [(forced-location? loc safe?)
+		      (expose-thunk)]
+		     [(forced-location? loc (not safe?))
+		      (counterexample-prompt (list (cons loc safe?))
+					     loc safe? expose-thunk)]
+		     [(in-frontier? loc)
+		      ; if there's any consistent frontier
+		      ;  with the opposite assertion
+		      ;  the assertion must be wrong
+		      (find-consistent-frontier loc safe? expose-thunk)]
+		     [else ; special cases for beyond frontier
+		      (cond
+		       [(uniform-consistent-frontiers)
+			=>
+			(lambda (frontiers)
+			  (let ([k (num-unsafe-in-assignment 
+				    (car frontiers))])
+			    (if (= k pirates-left)
+                                ; no pirates beyond frontier
+				(when safe?
+				    (expose-thunk)
+				    (counterexample-prompt 
+				     (car frontiers)
+				     loc #f expose-thunk))
+				(let ([b-f (beyond-frontier)])
+				  (if (= (- pirates-left k)
+					 (length b-f))
+				      ; all beyond frontier unsafe
+				      (if safe?
+					  (counterexample-prompt 
+					   (cons 
+					    (cons loc #t)
+					    (append
+					     (map
+					      (lambda (c)
+						(cons c #t))
+					      b-f)
+					     (car frontiers)))
+					   loc #t
+					   expose-thunk)
+					  (expose-thunk))
+                                      ; must be a counterexample
+				      (counterexample-prompt 
+				       (cons
+					(cons loc safe?)
+					(car frontiers))
+				       loc safe?
+				      expose-thunk))))))]
+		       [else ; a counterexample must exist
+			(find-consistent-frontier loc safe? expose-thunk)])])
+                    ; guess, not assertion
+		    (cond
+		     [(or (forced-location? loc safe?)
+			  (forced-location? loc (not safe?)))
+		      (guess-demerit loc safe? expose-thunk)]
+		     [(in-frontier? loc)
+		      (if (all-assignments-consistent? loc) ;safe?)
+			    (guess-demerit loc safe? expose-thunk)
+			    (check-guess loc safe? expose-thunk))]
+		     [(uniform-consistent-frontiers)
+		      =>
+		      (lambda (frontiers)
+			(let ([k (num-unsafe-in-assignment (car frontiers))])
+			    (if (or (= k pirates-left)
+				    (= (- pirates-left k)
+				       (length (beyond-frontier))))
+				(guess-demerit loc safe? expose-thunk))
+			        (check-guess loc safe? expose-thunk)))]
+		     [else
+		      (check-guess loc safe? expose-thunk)])))))]
+       [get-rows
+	(lambda () rows)]
+       [get-columns
+	(lambda () columns)] 
+       [set-rows!
+	(lambda (rs)
+	  (set! rows rs))]
+       [set-columns!
+	(lambda (cs)
+	  (set! columns cs))]
+       [set-size! 
+	(lambda (rs cs)
+	  (set-rows! rs)
+	  (set-columns! cs))]
+       [get-location
+	(lambda (r c)
+	  (let ([row-vector (vector-ref board-vector r)])
+	    (vector-ref row-vector c)))]
+       [get-neighbor-unsafe-count
+	(lambda (r c)
+	  (sum-location-unsafe (get-neighbors r c)))]
+       [get-neighbors 
+	(case-lambda 
+	 [(loc)
+	  (or (send loc get-neighbors)
+	      (let ([nbrs
+		     (get-neighbors
+		      (send loc get-row)
+		      (send loc get-column))])
+		; opportunity to cache neighbor info 
+		(send loc set-neighbors! nbrs)
+		nbrs))]
+	 [(r c)
+	  (let* ([this-row (vector-ref board-vector r)]
+		 [eligible-rows (list (sub1 r) r (add1 r))]
+		 [eligible-cols ; row above, this row, row below
+		  (if (even? (+ r c))
+		      `(() (,(sub1 c) ,(add1 c)) (,c))
+		      `((,c) (,(sub1 c) ,(add1 c)) ()))]
+		 [neighbors
+		  (let oloop ([rs eligible-rows]
+			      [cs eligible-cols])
+		    (if (null? rs)
+			'()
+			(let iloop ([cols (car cs)] ; length of cs = length of rs
+				    [curr-row (car rs)])
+			  (if (null? cols)
+			      (oloop (cdr rs) (cdr cs))
+			      (let ([curr-col (car cols)])
+				(if (and (>= curr-row 0)
+					 (< curr-row rows)
+					 (>= curr-col 0)
+					 (< curr-col columns))
+				    (cons (vector-ref (vector-ref board-vector curr-row) curr-col)
+					  (iloop (cdr cols) curr-row))
+				    (iloop (cdr cols) curr-row)))))))])
+	    neighbors)])]
+       [get-pirates-left
+	(lambda ()
+	  pirates-left)]
+       [get-pirates-ratio
+	(lambda ()
+	  pirates-ratio)]
+       [calc-pirates-ratio!
+	(lambda ()
+	  (set! pirates-ratio 
+		(if (= 0 num-concealed)
+		    #f
+		    (inexact->exact
+		     (round (* 100.0 (/ pirates-left num-concealed)))))))]
+       [board-for-each
+	(lambda (f)
+	  (do-board-map f #f))]
+       [board-map!
+	(lambda (f)
+	  (do-board-map f #t))]
+       [new-game
+	(lambda ()
+	  (set! board-vector
+		(build-vector
+		 rows
+		 (lambda (r)
+		   (build-vector 
+		    columns
+		    (lambda (c)
+		      (instantiate location% ()
+				   (safe? #t) (row r) (column c)))))))
+		; create unsafe location pseudo-randomly
+	  (random-seed (modulo (current-milliseconds) 1000))
+	  (let loop ([i 0])
+	    (when (< i unsafe-count)
+		  (let ([rand-loc (get-location (random rows) (random columns))])
+		    (if (send rand-loc get-safe?)
+			(begin
+			  (send rand-loc make-unsafe!)
+			  (loop (add1 i)))
+			(loop i)))))
+	  (send frame set-default-label!)
+	  (calc-neighbors!)
+	  (reset-pirate-counts!)
+	  (clear-counterexample!)
+	  (reset-ww-messages!)
+	  (reset-frontier!))]
+       [reset-pirate-counts!
+	(lambda () 
+	  (set! pirates-left unsafe-count)
+	  (set! num-concealed (* rows columns))
+	  (calc-pirates-ratio!))]
+       [calc-neighbors!
+	(lambda ()
+	  (board-for-each
+	   (lambda (loc)
+	     (get-neighbors loc))))]
+       [calc-frontier!
+	(lambda ()
+	  (reset-frontier!)
+	  (board-for-each
+	   (lambda (loc)
+	     (unless (send loc get-concealed?)
+               (let* ([row (send loc get-row)]
+		      [col (send loc get-column)]
+		      [neighbors
+		       (or (send loc get-neighbors)
+			   (let ([nbrs (get-neighbors row col)])
+			     (send loc set-neighbors! nbrs)
+			     nbrs))]
+		      [frontier-neighbors 
+		       (filter (lambda (nbr) (send nbr get-concealed?))
+			       neighbors)])
+		 (for-each
+		  (lambda (nbr)
+		    (add-to-frontier nbr))
+		  frontier-neighbors))))))]
+       [reset-frontier!
+	(lambda ()
+	  (set! frontier-table (make-hash-table)))]
+       [in-frontier?
+	(lambda (loc)
+	  (hash-table-get frontier-table loc (lambda _ #f)))]
+       [add-to-frontier
+	(lambda (loc)
+	  (hash-table-put! frontier-table loc #t))]
+       [remove-from-frontier
+	(lambda (loc)
+	  (hash-table-remove! frontier-table loc))]
+       [update-frontier!
+	(lambda (loc)
+          ; this is called when a location has been exposed 
+          ; if loc was in the frontier, remove it
+          (when (in-frontier? loc)
+	    (remove-from-frontier loc))
+	  ; invariant: the neighbors of each location have been 
+	  ;  calculated before calling this method
+	  ; for each exposed location, add its neighbors to the 
+	  ;  frontier
+	  (for-each
+	   (lambda (nb)
+	     (unless (or (not (send nb get-concealed?))
+			 (in-frontier? nb))
+		     (add-to-frontier nb)))
+	   (send loc get-neighbors)))]
+       [frontier-list
+	(lambda ()
+	  (hash-table-map frontier-table (lambda (k v) k)))]
+       [dump-frontier
+	(lambda ()
+	  (printf "Current frontier:~n")
+	  (hash-table-for-each frontier-table
+			       (lambda (loc _)
+				 (printf "row: ~a  col: ~a~n"
+					 (send loc get-row)
+					 (send loc get-column)))))]
+       [dump-border
+	(lambda ()
+	  (printf "Current border:~n")
+	  (for-each
+	   (lambda (loc)
+	     (printf "row: ~a  col: ~a~n"
+		     (send loc get-row)
+		     (send loc get-column)))
+	   (get-revealed-border)))]
+       [load-from-file 
+	(lambda (filename)
+	  (if (not (file-exists? filename))
+	      (message-box *progname*
+			   (format "WaterWorld game file \"~a\" does not exist" filename)
+			   frame)
+	      (with-input-from-file filename
+		(lambda ()
+		  (let ([game (read)])
+		    (let*-values
+		     ([(_ row-info col-info locations-info)
+		       (apply values game)]
+		      [(locations) (cdr locations-info)]
+		      [(unsafe-tally) 0]
+		      [(pirates-left-tally) 0]
+		      [(concealed-tally) 0])
+		     (set! rows (cadr row-info))
+		     (set! columns (cadr col-info))
+		     (send canvas set-board-size! rows columns)
+		     (send canvas update-teaching-mode!)
+		     (set! board-vector
+			   (build-vector
+			    rows
+			    (lambda (r)
+			      (build-vector 
+			       columns
+			       (lambda (c) #f)))))
+		     (board-map!
+		      (lambda (_)
+			(let-values 
+			 ([(_ loc-row-info loc-col-info 
+			      loc-safe-info loc-concealed-info)
+			   (apply values (car locations))])
+			 (let ([safe? (cadr loc-safe-info)]
+			       [row (cadr loc-row-info)]
+			       [column (cadr loc-col-info)]
+			       [concealed? (cadr loc-concealed-info)])
+			   (unless safe?
+				   (set! unsafe-tally (add1 unsafe-tally))
+				   (when concealed?
+					 (set! pirates-left-tally (add1 pirates-left-tally))))
+			   (when concealed?
+				 (set! concealed-tally (add1 concealed-tally)))
+			   (set! locations (cdr locations))
+			   (instantiate location% ()
+					(safe? safe?)
+					(row row)
+					(column column)
+					(concealed? concealed?))))))
+		     (set! *current-rows* rows)
+		     (set! *current-cols* columns)
+		     (set! *current-density* (inexact->exact 
+					      (round (/ (* 100.0 unsafe-tally) 
+							(* rows columns)))))
+		     (set! pirates-left pirates-left-tally)
+		     (set! num-concealed concealed-tally)
+		     (clear-counterexample!)
+		     (set-unsafe-count!)
+		     (set-unsafe-count!)
+		     (calc-frontier!)
+		     (calc-unsafe!)
+		     (calc-pirates-ratio!)))))))]
+       [save-to-file 
+	(lambda (filename)
+	  (when (file-exists? filename)
+		(delete-file filename))
+	  (with-output-to-file filename
+	    (lambda ()
+	      (printf "(game~n")
+	      (printf "  (rows ~a)~n" rows)
+	      (printf "  (columns ~a)~n" columns)
+	      (printf "  (locations")
+	      (board-for-each
+	       (lambda (loc)
+		 (printf "~n    (location (row ~a) (column ~a) (safe? ~a) (concealed? ~a))" 
+			 (send loc get-row) (send loc get-column) 
+			 (send loc get-safe?) (send loc get-concealed?))))
+	      (printf "))~n"))))])
+      (super-instantiate ())
+      (set-unsafe-count!)
+      (reset-pirate-counts!)))
+  
+  (define ww-frame%
+    (class frame% 
+	   (init-field board)
+	   (inherit set-label show get-label get-x get-y)
+	   (field
+	    [frame-label *progname*]
+	    [game-over-frame-label 
+	     (string-append frame-label
+			    " [game over]")]
+	    [current-filename #f]
+	    [canvas #f]
+	    [new-game-panel #f]
+	    [status-panel #f]
+	    [message-panel #f]
+	    [pirates-left-msg #f]
+	    [pirates-ratio-msg #f]
+	    [status-msg-1 #f]
+	    [status-msg-2 #f]
+	    [clear-counterexample-button #f]
+	    [new-game-button #f])
+	   (private*
+	    [draw-location-tile
+	     (lambda (loc) 
+	       (send canvas paint-tile loc))])
+	   (public*
+	    [set-default-label!
+	     (lambda () (set-label frame-label))]
+	    [get-top-status-line
+	     (lambda () (send status-msg-1 get-label))]
+	    [set-game-over-label!
+	     (lambda () (set-label game-over-frame-label))]
+	    [set-ce-button-state!
+	     (lambda (v)
+	       (send clear-counterexample-button enable v)
+	       (if v
+		   (send clear-counterexample-button focus)
+		   (send new-game-button focus)))]
+	    [new-game
+	     (lambda ()
+	       (if *need-to-reset-size*
+		   (begin
+		     (set! *need-to-reset-size* #f)
+		     (set-tile-dimensions!)
+		     (update-board-size! *current-rows* *current-cols*)
+	             (send board update-settings!)		     	
+		     (send board new-game)
+		     (reset-frame!))
+		   (send board new-game))
+	       (update-status!)
+	       (draw-board))]
+	    [set-filename!
+	     (lambda (s)
+	       (set! current-filename s))]
+	    [reset-bottom-panels!
+	     (lambda ()
+	       (for-each
+		(lambda (panel)
+		  (when panel
+			(send panel show #f)))
+		(list new-game-panel status-panel message-panel))
+	       (set! new-game-panel 
+		     (instantiate horizontal-panel% ()
+				  (parent this)
+				  (stretchable-height #f)
+				  (vert-margin 2)
+				  (alignment '(center center))))
+	       (set! new-game-button
+		     (instantiate button% ()
+				  (label "New game")
+				  (parent new-game-panel)
+				  (callback (lambda (b ev) 
+					      (new-game)))))
+	       (set! clear-counterexample-button
+		     (instantiate button% ()
+				  (label "Clear counterexample")
+				  (parent new-game-panel)
+				  (enabled #f)
+				  (callback 
+				   (lambda (b ev) 
+				     (send board 
+					   clear-counterexample!)))))
+	       (set! status-panel 
+		     (instantiate horizontal-panel% ()
+				  (parent this)
+				  (border 2)
+				  (horiz-margin 2)
+				  (vert-margin 2)
+				  (stretchable-height #f)
+				  (style '(border))))
+	       (send status-panel stretchable-height #f)
+	       (let ([make-status-vpane 
+		      (lambda ()
+			(let ([vp (instantiate vertical-pane% ()
+					       (parent status-panel))])
+			  (send vp set-alignment 'center 'center)
+			  vp))])
+		 (set! pirates-left-msg
+		       (instantiate message% ()
+				    (label "Pirates left: 00000") 
+				    (parent (make-status-vpane))))
+		 (set! pirates-ratio-msg
+		       (instantiate message% () 
+				    (label "Ratio: 100%") 
+				    (parent (make-status-vpane)))))
+	       (set! message-panel 
+		     (instantiate horizontal-panel% ()
+				  (parent this)
+				  (horiz-margin 2)
+				  (vert-margin 2)
+				  (stretchable-height #f)))
+	       (send message-panel stretchable-height #f)
+	       (let* ([msg-vpane 
+		       (instantiate vertical-pane% ()
+				    (parent message-panel))]
+		      [mk-status-msg
+		       (lambda (msg)
+			 (instantiate message% ()
+				      (label msg)
+				      (stretchable-width #t)
+				      (parent msg-vpane)))])
+		 (set! status-msg-1
+		       (mk-status-msg *default-message-1*))
+		 (set! status-msg-2
+		       (mk-status-msg *default-message-2*))))]
+	    [update-status!
+	     (lambda ()
+	       (send pirates-left-msg set-label
+		     (format "Pirates left: ~a" (send board get-pirates-left)))
+	       (let ([ratio (send board get-pirates-ratio)])
+		 (send pirates-ratio-msg set-label
+		       (if ratio
+			   (format "Ratio: ~a~a" ratio "%")
+			   ""))))]
+	    [ww-messages
+	     (lambda (s1 s2)
+	       (send status-msg-1 set-label s1)
+	       (send status-msg-2 set-label s2))]
+	    [update-board-size!
+	     (lambda (rs cs)
+	       (send canvas set-board-size! rs cs)
+	       (send board set-size! rs cs))]
+	    [dump-board ; for debugging
+	     (lambda ()
+	       (printf "** board dump **~n")
+	       (send board 
+		     board-for-each 
+		     (lambda (loc) 
+		       (let ([row (send loc get-row)]
+			     [col (send loc get-column)]
+			     [safe? (send loc get-safe?)]
+			     [concealed? (send loc get-concealed?)])
+			 (printf "row=~a col=~a safe?=~a concealed?=~a~n" 
+				 row col safe? concealed?))))
+	       (printf "** end of dump **~n"))]
+	    [expose-row-col
+	     (lambda (r c safe? assert)
+	       (send board expose-row-col r c safe? assert #f))]
+	    [draw-tile
+	     (lambda (r c)
+	       (draw-location-tile (send board get-location r c)))]
+	    [draw-board
+	     (lambda ()
+	       (send board draw))])
+	    (private*
+	     [reset-frame! 
+	      (lambda ()
+		(let ([new-frame
+		       (instantiate ww-frame% ()
+				    (board board)
+				    (label (get-label))
+				    (style '(no-resize-border))
+				    (x (max 0 (get-x)))
+				    (y (max 0 (get-y))))])
+		  (send new-frame update-board-size! 
+			(send board get-rows) (send board get-columns))
+		  (send new-frame update-status!)
+		  (send new-frame draw-board)
+		  (show #f)
+		  (send new-frame show #t)
+		  (set! frame new-frame)))]
+	     [get-game-filename
+	      (lambda ()
+		(let ([fn (get-file 
+			   "WaterWorld game files"
+			   this
+			   (or *last-game-dir*
+			       (build-path (collection-path "waterworld") 
+					   "games"))
+			   #f
+			   "ss"
+			   '()
+			   '(("Scheme files" "*.ss")))])
+		  (when fn
+			(let-values 
+			 ([(base n d) (split-path fn)])
+			 (set! *last-game-dir* base)))
+		  fn))]
+	     [save-game
+	      (lambda () 
+		(if current-filename
+		    (send board save-to-file current-filename)
+		    (save-game-as)))]
+	     [save-game-as
+	      (lambda () 
+		(let ([filename (get-game-filename)])
+		  (when filename
+			(set! current-filename filename)
+			(send board save-to-file current-filename))))]
+	     [open-game
+	      (lambda () 
+		(let ([filename (get-game-filename)])
+		  (when filename
+			(send board load-from-file filename)
+			(reset-frame!)
+			(send frame set-filename! filename))))]
+	     [open-settings
+	      (lambda () 
+		(let* ([settings-frame 
+			(instantiate frame% ()
+				     (label "WaterWorld settings")
+				     (style '(no-resize-border)))]
+		       [main-panel (instantiate vertical-panel% () 
+						(parent settings-frame) 
+						(alignment '(center center)))]
+		       [msg-width 100]
+		       [panel-sep 4]
+		       [make-hpanel
+			(lambda ()
+			  (instantiate horizontal-panel% () 
+				       (parent main-panel)
+				       (vert-margin panel-sep)
+				       (alignment '(center center))))]
+		       [row-panel (make-hpanel)]
+		       [make-msg
+			(lambda (msg panel)
+			  (instantiate message% () 
+				       (min-width msg-width)
+				       (label msg) (parent panel)))]
+		       [row-msg (make-msg "Number of rows" row-panel)]
+		       [make-canvas
+			(lambda (panel)
+			  (let ([txt (instantiate text% ())])
+			    (instantiate editor-canvas% () 
+					 (editor txt)
+					 (min-height 30)
+					 (min-width 50)
+					 (stretchable-width #f)
+					 (parent panel) 
+					 (style '(no-hscroll no-vscroll)))))]
+		       [row-canvas (make-canvas row-panel)]
+		       [col-panel (make-hpanel)]
+		       [col-msg (make-msg "Number of columns" col-panel)]
+		       [col-text (instantiate text% ())]
+		       [col-canvas (make-canvas col-panel)]
+		       [density-panel (make-hpanel)]
+		       [density-msg (make-msg "Pirate density (%)" density-panel)]
+		       [density-text (instantiate text% ())]
+		       [density-canvas (make-canvas density-panel)]
+		       [tile-panel (make-hpanel)]
+		       [tile-msg (make-msg "           Tile size" tile-panel)]
+		       [tile-map '(large small)]  ; list position corresponds to radio button index
+		       [tile-radio (instantiate radio-box% () 
+						(label #f) (parent tile-panel) 
+						(choices '("Large" "Small"))
+						(callback (lambda (rb ev) #f))
+						(style '(horizontal)))]
+		       [auto-panel (make-hpanel)]
+		       [auto-msg (make-msg "Autoclick empty cells?" auto-panel)]
+		       [auto-map '(yes no)] ; list position corresponds to radio button index
+		       [auto-radio (instantiate radio-box% () 
+						(label #f) (parent auto-panel) 
+						(choices '("Yes" "No"))
+						(callback (lambda (rb ev) #f))
+						(style '(horizontal)))]
+		       [list-pos 
+			(lambda (lst sym)
+			  (let loop ([i 0]
+				     [lst lst])
+			    (if (null? lst)
+				#f
+				(if (eq? sym (car lst))
+				    i
+				    (loop (add1 i) (cdr lst))))))]
+		       [get-canv-text
+			(lambda (canv)
+			  (send (send canv get-editor)
+				get-text))]
+		       [valid-number?
+			(lambda (s)
+			  (with-handlers
+			   ([void (lambda _ #f)])
+			   (string->number (trim s))))]
+		       [test-range
+			(lambda (v min max)
+			  (or (not v)
+			      (< v min)
+			      (> v max)))]
+		       [range-error
+			(lambda (lab v min max)
+			  (message-box
+			   "Settings error"
+			   (format "~a value \"~a\" is not a number or is out of the range [~a..~a]"
+				   lab v min max)
+			   settings-frame
+			   '(ok)))]
+		       [validate-and-save
+			(lambda ()
+			  (let* ([row (get-canv-text row-canvas)]
+				 [col (get-canv-text col-canvas)]
+				 [density (get-canv-text density-canvas)]
+				 [autoclick 
+				  (if (eq? (send auto-radio get-selection) 0)
+				      'yes
+				      'no)]
+				 [tile-size 
+				  (if (eq? (send tile-radio get-selection) 0)
+				      'large
+				      'small)]
+				 [row-num (valid-number? row)]
+				 [col-num (valid-number? col)]
+				 [density-num (valid-number? density)])
+					; validate
+			    (let ([max-rows (if (eq? tile-size 'large)
+						*max-large-rows*
+						*max-small-rows*)]
+				  [max-cols (if (eq? tile-size 'large)
+						*max-large-cols*
+						*max-small-cols*)])
+			      (cond
+			       [(test-range row-num *min-rows* max-rows)
+				(range-error "Row" row *min-rows* max-rows)]
+			       [(test-range col-num *min-cols* max-cols)
+				(range-error "Column" col *min-cols* max-cols)]
+			       [(test-range density-num *min-density* *max-density*)
+				(range-error "Density percentage" density *min-density* *max-density*)]
+			       [else ; save
+				(let ([prefs 
+				       `((ww:numrows ,row-num)
+					 (ww:numcols ,col-num)
+					 (ww:density ,density-num)
+					 (ww:tile-size ,tile-size)
+					 (ww:autoclick ,autoclick))])
+				  (put-ww-prefs prefs)
+				  (set! *current-rows* row-num)
+				  (set! *current-cols* col-num)
+				  (set! *current-density* density-num)
+				  (set! *current-tile-size* tile-size)
+				  (set! *current-autoclick* autoclick)
+				  (set! *need-to-reset-size* #t)
+				  (send settings-frame show #f))]))))]
+		       [notice-panel (make-hpanel)]
+		       [notice-msg (make-msg "Some settings take effect on next game" notice-panel)]
+		       [init-text
+			(lambda (canv v)
+			  (let* ([editor (send canv get-editor)]
+				 [len (string-length (send editor get-text))])
+			    (send editor insert v 0 len)))]
+		       [init-num-text
+			(lambda (canv v)
+			  (init-text canv (number->string v)))]
+		       [buttons-panel (make-hpanel)]
+		       [ok-button (instantiate button% ()
+					       (label "OK")
+					       (min-width 50)
+					       (parent buttons-panel)
+					       (callback (lambda (b ev) 
+							   (validate-and-save))))]
+		       [spacer 
+			(instantiate message% () 
+				     (min-width 20)
+				     (label "") (parent buttons-panel))]
+		       [cancel-button (instantiate button% ()
+						   (label "Cancel")
+						   (min-width 50)
+						   (parent buttons-panel)
+						   (callback (lambda (b ev) 
+							       (send settings-frame show #f))))]
+		       [spacer2 
+			(instantiate message% () 
+				     (min-width 20)
+				     (label "") (parent buttons-panel))]
+		       [defaults-button (instantiate button% ()
+						     (label "Defaults")
+						     (min-width 50)
+						     (parent buttons-panel)
+						     (callback 
+						      (lambda (b ev) 
+							(send tile-radio set-selection
+							      (list-pos tile-map *default-tile-size*))
+							(send auto-radio set-selection
+							      (list-pos auto-map *default-autoclick*))
+							(init-num-text row-canvas *default-rows*)
+							(init-num-text col-canvas *default-cols*)
+							(init-num-text density-canvas *default-density*))))])
+		  
+		  (init-num-text row-canvas *current-rows*)
+		  (init-num-text col-canvas *current-cols*)
+		  (init-num-text density-canvas *current-density*)
+		  (send tile-radio set-selection
+			(if (eq? *current-tile-size* 'large) 0 1))
+		  (send auto-radio set-selection
+			(if (eq? *current-autoclick* 'yes) 0 1))
+		  (send settings-frame show #t)))]
+	     [exit-game
+	      (lambda () 
+		(send this show #f)
+		(exit))]
+	     [how-to-play
+	      (lambda () 
+		(let ([url (string-append 
+			    "file://"
+			    (build-path 
+			     (collection-path "waterworld")
+			     "ww.html"))])
+		  (send-url url)))])
+	    (super-instantiate ())
+	    (let* ([menu-bar (instantiate menu-bar% () (parent this))]
+		   [game-menu (instantiate menu% ()
+					   (label "&Game")
+					   (parent menu-bar))]
+		   [help-menu
+		    (instantiate menu% ()
+				 (label "&Help")
+				 (parent menu-bar))]
+		   [game-menu-items
+		    `(("&New"
+		       ,(lambda (m ev) (new-game)))
+		      ("&Open..."
+		       ,(lambda (m ev) (open-game)))
+		      ("&Save"
+		       ,(lambda (m ev) (save-game)))
+		      ("Save &as..."
+		       ,(lambda (m ev) (save-game-as)))
+		      ("S&ettings..."
+		       ,(lambda (m ev) (open-settings)))
+		      ("E&xit"
+		       ,(lambda (m ev) (exit-game))))]
+		   [help-menu-items
+		    `(("How to &play"
+		       ,(lambda (m ev) (how-to-play))))])
+	      (for-each
+	       (lambda (it) 
+		 (instantiate menu-item% ()
+			      (label (car it))
+			      (parent game-menu)
+			      (callback (cadr it))))
+	       game-menu-items)
+	      (for-each
+	       (lambda (it) 
+		 (instantiate menu-item% ()
+			      (label (car it))
+			      (parent help-menu)
+			      (callback (cadr it))))
+	       help-menu-items)
+	      (set! canvas (instantiate board-canvas% ()
+					(frame this) 
+					(board board)
+					(tile-size *current-tile-size*)
+					(stretchable-height #f)
+					(stretchable-width #f)))
+	      (reset-bottom-panels!))))
+    
+    (define board-canvas%
+      (class canvas% 
+	     (init-field frame) 
+	     (init-field board)
+	     (init-field tile-size)
+	     (init-field (teaching-mode? #f))
+	     (inherit get-dc min-client-width min-client-height 
+		      stretchable-width stretchable-height)
+	     (field
+	      [board-height (send board get-rows)]
+	      [board-width (send board get-columns)]
+	      [intercepts-vector #f]
+	      [triangle-points-even ; right-side-up, pointy side up
+	       (map
+		(lambda (xy)
+		  (make-object point% (car xy) (cadr xy)))
+		`((0 ,*tile-height*)
+		  (,*half-edge-length* 0)
+		  (,*tile-edge-length* 
+		   ,*tile-height*)))]
+	      [triangle-points-odd ; inverted triangle, pointy side down
+	       (map
+		(lambda (xy)
+		  (make-object point% (car xy) (cadr xy)))
+		`((0 0)
+		  (,*half-edge-length* ,*tile-height*)
+		  (,*tile-edge-length* 0)))]
+	      [in-counterexample? #f])
+	     (public*
+	      [ww-messages
+	       (lambda (s1 s2)
+		 (send frame ww-messages s1 s2))]
+	      [reset-ww-messages!
+	       (lambda ()
+		 (ww-messages *default-message-1* *default-message-2*))]
+	      [end-checking-ww-messages
+	       (lambda ()
+		 (when (equal? (send frame get-top-status-line)
+			       *checking-message*)
+		       (reset-ww-messages!)))]
+	      [set-in-counterexample!
+	       (lambda (v)
+		 (set! in-counterexample? v)
+		 (send frame set-ce-button-state! v))]
+	      [x-y->row-column
+	       (lambda (x y)
+		 (let* ([id (lambda (x) x)]
+			[raw-col (floor (/ x *half-edge-length*))]
+			[row (floor (/ y *tile-height*))]
+			[calc-x-y
+			 (lambda (m col-fun-1 col-fun-2)
+			   (let ([b (get-intercept row raw-col)])
+			     (if (> y (+ (* m x) b))
+				 (values (col-fun-1 raw-col) row)
+				 (values (col-fun-2 raw-col) row))))])
+		   (if (even? (+ raw-col row))
+		       (calc-x-y *even-slope* id sub1)
+		       (calc-x-y *odd-slope* sub1 id))))]
+	      [draw-alpha-label
+	       (lambda (r c x y)
+		 (let ([color (send dc get-text-foreground)])
+		   (send dc set-text-foreground *alpha-color*)
+		   (send dc draw-text 
+			 (vector-ref *teaching-mode-labels*
+				     (+ (* r *teaching-board-width*) c))
+			 (+ x 14)
+			 (if (even? (+ r c))
+			     (+ y *tile-edge-length* -34)
+			     (+ y 2)))
+		   (send dc set-text-foreground color)))]
+	      [paint-polygon
+	       (lambda (row col xoff yoff even-tile?)
+		 (send dc draw-polygon 
+		       (if even-tile?
+			   triangle-points-even
+			   triangle-points-odd)
+		       (* col *half-edge-length*)
+		       (* row *tile-height*))
+		 (when teaching-mode?
+		       (draw-alpha-label row col xoff yoff)))]
+	      [paint-jolly
+	       (lambda (bitmap row col even-tile?)
+		 (send dc draw-bitmap bitmap
+		       (+ (* col *half-edge-length*) 
+			  *jolly-column-offset*)
+		       (+ (* row *tile-height*)
+			  (if even-tile?
+			      *jolly-even-row-offset* 
+			      *jolly-odd-row-offset*))))]
+	      [paint-counterexample-tile
+	       (lambda (row col safe?)
+		 (let ([even-tile? (even? (+ row col))])
+		   (send dc set-brush *counterexample-brush*)
+		   (let ([xoff (* col *half-edge-length*)]
+			 [yoff (* row *tile-height*)])
+		     (paint-polygon row col xoff yoff even-tile?)
+		     (unless safe?
+			     (paint-jolly *jolly-ce-bitmap* row col even-tile?)))))]
+	      [paint-tile
+	       (lambda (loc)
+		 (let ([row (send loc get-row)]
+		       [col (send loc get-column)])
+		   (if (and in-counterexample? 
+			    (send loc get-in-counterexample-set?))
+		       (paint-counterexample-tile 
+			row col 
+			(send loc get-counterexample-safe?))
+		       (let ([safe? (send loc get-safe?)]
+			     [concealed? (send loc get-concealed?)]
+			     [neighbor-count-thunk 
+			      (lambda ()
+				(send board get-neighbor-unsafe-count row col))]
+			     [even-tile? (even? (+ row col))])
+			 (if concealed?
+			     (send dc set-brush *concealed-brush*)
+			     (send dc set-brush *exposed-brush*))
+			 (let ([xoff (* col *half-edge-length*)]
+			       [yoff (* row *tile-height*)])
+			   (paint-polygon row col xoff yoff even-tile?)
+			   (unless concealed?
+				   (if safe?
+				       (let* ([ns (neighbor-count-thunk)]
+					      [ns-string (number->string ns)]
+					      [fg-color (send dc get-text-foreground)])
+					 (send dc set-text-foreground 
+					       (if (zero? ns)
+						   *zero-color*
+						   *non-zero-color*))
+					 (send dc draw-text 
+					       ns-string
+					       (+ xoff *half-edge-length* -4) 
+					       (+ yoff *half-tile-height* 
+						  (if even-tile? 
+						      -4
+						      -12)))
+					 (send dc set-text-foreground fg-color))
+				       (paint-jolly *jolly-bitmap* row col even-tile?))))))))]
+	      [set-intercepts!
+	       (lambda ()
+		 (set! intercepts-vector
+		       (build-vector
+			board-height
+			(lambda (r)
+			  (build-vector 
+			   (add1 board-width)
+			   (lambda (c)
+					; y - mx
+			     (let ([x (* (add1 c) *half-edge-length*)])
+			       (if (even? (+ r c))
+				   (- (* r *tile-height*)
+				      (* *even-slope* x))
+				   (- (* (add1 r) *tile-height*)
+				      (* *odd-slope* x))))))))))]
+	      [get-intercept
+	       (lambda (r c)
+		 (vector-ref (vector-ref intercepts-vector r) c))]
+	      [set-board-width!
+	       (lambda (w)
+		 (set! board-width w)
+		 (set-client-width!))]
+	      [set-board-height!
+	       (lambda (h)
+		 (set! board-height h)
+		 (set-client-height!))]
+	      [set-board-size!
+	       (lambda (h w)
+		 (set-board-height! h) 
+		 (set-board-width! w)
+		 (set-intercepts!)
+		 (update-teaching-mode!))]
+	      [get-teaching-mode
+	       (lambda () teaching-mode?)]
+	      [update-teaching-mode!
+	       (lambda ()
+		 (set! teaching-mode? 
+		       (and (= board-height *teaching-board-height*)
+			    (= board-width *teaching-board-width*)
+			    (eq? tile-size *teaching-tile-size*)))
+		 (send board set-teaching-mode! teaching-mode?))]
+	      [set-client-height!
+	       (lambda ()
+		 (min-client-height (add1 (* board-height *tile-height*))))]
+	      [set-client-width!
+	       (lambda ()
+		 (min-client-width (* (/ (add1 board-width) 2) 
+				      *tile-edge-length*)))]
+	      [set-client-size!
+	       (lambda ()
+		 (set-client-height!)
+		 (set-client-width!))])
+	     (override*
+	      [on-event        ; handle a click
+	       (lambda (e)
+		 (when (and (not in-counterexample?)
+			    (send e button-down?))
+		   (when (semaphore-try-wait? *click-sem*)
+			 (let-values
+			  ([(col row) (x-y->row-column
+				       (send e get-x)
+				       (send e get-y))])
+			  (when (and (>= col 0)
+				     (< col board-width)
+				     (>= row 0)
+				     (< row board-height)
+				     (> (send board get-num-concealed) 0))
+				(ww-messages *checking-message* "")
+				(yield)
+				(begin-busy-cursor)
+				(send frame expose-row-col
+				      row col
+				      (not (send e get-shift-down))
+				      (send e get-control-down))
+				(send frame update-status!)
+				(end-checking-ww-messages)
+				(end-busy-cursor)
+				(when (zero? (send board get-num-concealed))
+				      (send frame set-game-over-label!))))
+			 (semaphore-post *click-sem*))))]
+	      [on-paint
+	       (lambda () 
+		 (send frame draw-board))])
+	     (super-instantiate (frame))
+	     
+	     ;; tie board and canvas
+	     (send board set-canvas! this)
+	     
+	     ;; Make canvas size always match the board size:
+	     (set-client-size!)
+	     (set-intercepts!)
+	     (stretchable-width #f)
+	     (stretchable-height #f)
+	     
+             ; use teaching board if right dimensions
+	     (update-teaching-mode!)
+	     
+	     (define dc (get-dc))))
+    
+    (define frame 
+      (instantiate ww-frame%
+		   ()
+		   (board (instantiate board% ()))
+		   (label *progname*)
+		   (style '(no-resize-border))))
+    
+    (send frame new-game)
+    (send frame show #t))
diff --git a/collects/waterworld/wwdoc.ss b/collects/waterworld/wwdoc.ss
new file mode 100644
index 0000000000..6a6da81480
--- /dev/null
+++ b/collects/waterworld/wwdoc.ss
@@ -0,0 +1,70 @@
+(module wwdoc mzscheme
+  (require (lib "xml.ss" "xml"))
+
+  (define *the-file* "ww.html")
+  (define *the-page* 
+    `(html 
+      (body 
+       "You are exploring WaterWorld, where each location is either "
+       "empty sea, or contains pirates. "
+       "When you enter a location, you must "
+       (em "correctly") " "
+       "anticipate whether or not it contains pirates:"
+       (ul 
+	(li 
+	 "If you anticipate pirates, shift-click on the location, "
+	 "meaning you've brought gold "
+	 "to appease them with."
+	 (ul 
+	  (li 
+	   "If you are correct, the pirates relieve you of your burden "
+	   "before it pulls you down, and let you live.")
+	  (li 
+	   "However, if you are incorrect and there were no pirates, "
+	   "then the gold "
+	   "weighs you down, and you drown.")))
+	(li 
+	 "If you anticipate the location is empty, just click on the "
+	 "location, meaning you "
+	 (em  "haven't") " "
+	 "brought gold"
+	 (ul 
+	  (li 
+	   "If you are correct, you can measure the "
+	   "pollution content of the water, "
+	   "and find out how many neighboring locations have pirates "
+	   "(though not which ones).")
+	  (li 
+	   "However, if you are incorrect and there are pirates, "
+	   "they will keel-haul you, then impress you into slavery."))))
+       (p)
+       "Note the asymmetry of the situation: you get further information "
+       "only after exploring empty locations."
+       (hr)
+       (h2 "Format of games")
+       "WaterWorld games are stored as S-expressions in the following format:"
+       (pre 
+	"(game" (br)
+	" (rows n)" (br)
+	" (columns m)" (br) 
+	" (locations" (br)
+	"  (location (row p) (column q) (safe? b) (concealed? c))" (br)
+	"   ..." (br)
+	" ))")
+       "where " 
+       (tt "n" ) ", "
+       (tt "m" ) ", "
+       (tt "p" ) ", and "
+       (tt "q" ) " are numbers, and "
+       (tt "b" ) " and "
+       (tt "c" ) " are Scheme booleans. "
+       "The locations must be enumerated in row-major order.  That is, "
+       "all columns within a row are given, in order, before listing the "
+       "next row.  Both rows and columns are enumerated from 0.")))
+
+  (when (file-exists? *the-file*)
+	(delete-file *the-file*))
+  (let ([html-port (open-output-file *the-file*)])
+    (write-xml/content
+     (xexpr->xml *the-page*) html-port)
+    (close-output-port html-port)))
diff --git a/collects/web-server/configuration-structures.ss b/collects/web-server/configuration-structures.ss
new file mode 100644
index 0000000000..2076aebd08
--- /dev/null
+++ b/collects/web-server/configuration-structures.ss
@@ -0,0 +1,26 @@
+(module configuration-structures mzscheme
+  (require "util.ss"
+           "configuration-table-structs.ss")
+  (provide (struct timeouts (default-servlet password servlet-connection file-per-byte file-base))
+           (struct paths (host-base log htdocs servlet)))
+
+  ; configuration is now a unit.  See sig.ss
+
+  ; host = (make-host (listof str) (str str sym url str -> str)
+  ;                   passwords resopnders timeouts paths)
+  (provide-define-struct
+   host (indices log-message passwords responders timeouts paths))
+
+  ; passwords = (listof (list* relm:str protected-dir-regexp:str
+  ;                            (listof (list user:sym password:str))))
+
+  ; responders = (make-responders (url tst -> response)
+  ;                               (url tst -> response)
+  ;                               (url (cons sym str) -> response)
+  ;                               response
+  ;                               response
+  ;                               (url -> response)
+  ;                               response)
+  (provide-define-struct
+   responders
+   (servlet servlet-loading authentication servlets-refreshed passwords-refreshed file-not-found protocol)))
diff --git a/collects/web-server/configuration-table b/collects/web-server/configuration-table
new file mode 100644
index 0000000000..6cd7e4edad
--- /dev/null
+++ b/collects/web-server/configuration-table
@@ -0,0 +1,30 @@
+((port 80)
+ (max-waiting 40)
+ (initial-connection-timeout 30)
+ (default-host-table
+   (host-table
+     (default-indices "index.html" "index.htm")
+     (log-format parenthesized-default)
+     (messages
+       (servlet-message "servlet-error.html")
+       (authentication-message "forbidden.html")
+       (servlets-refreshed "servlet-refresh.html")
+       (passwords-refreshed "passwords-refresh.html")
+       (file-not-found-message "not-found.html")
+       (protocol-message "protocol-error.html"))
+     (timeouts
+      (default-servlet-timeout 60)
+      ;(default-servlet-timeout 300)
+      ;(default-servlet-timeout 10)
+      (password-connection-timeout 300)
+      (servlet-connection-timeout 86400)
+       (file-per-byte-connection-timeout 1/20)
+       (file-base-connection-timeout 30))
+     (paths
+      (configuration-root "conf")
+      (host-root "default-web-root")
+      (log-file-path "log")
+      (file-root "htdocs")
+      (servlet-root ".")
+      (password-authentication "passwords"))))
+ (virtual-host-table))
diff --git a/collects/web-server/configuration-table-structs.ss b/collects/web-server/configuration-table-structs.ss
new file mode 100644
index 0000000000..5f6e6fce99
--- /dev/null
+++ b/collects/web-server/configuration-table-structs.ss
@@ -0,0 +1,24 @@
+(module configuration-table-structs mzscheme
+  (require "util.ss")
+  
+  ; configuration-table = (make-configuration-table nat nat num host-table (listof (cons str host-table)))
+  (provide-define-struct
+   configuration-table
+   (port max-waiting initial-connection-timeout default-host virtual-hosts))
+  
+  ; host-table = (make-host-table (listof str) sym messages timeouts paths)
+  (provide-define-struct host-table (indices log-format messages timeouts paths))
+  
+  ; passwords = (listof (list* relm:str protected-dir-regexp:str (listof (list user:sym password:str))))
+  ; passwords moved back to a separate file
+  
+  ; messages = (make-messages str^6)
+  (provide-define-struct messages
+    (servlet ;servlet-loading
+     authentication servlets-refreshed passwords-refreshed file-not-found protocol))
+  
+  ; timeouts = (make-timeouts nat^5)
+  (provide-define-struct timeouts (default-servlet password servlet-connection file-per-byte file-base))
+  
+  ; paths = (make-paths str^6)
+  (provide-define-struct paths (conf host-base log htdocs servlet passwords)))
diff --git a/collects/web-server/configuration.ss b/collects/web-server/configuration.ss
new file mode 100644
index 0000000000..afe149f30e
--- /dev/null
+++ b/collects/web-server/configuration.ss
@@ -0,0 +1,308 @@
+; configuration language example
+(module configuration mzscheme
+  (require "configuration-structures.ss"
+           "configuration-table-structs.ss"
+           "sig.ss"
+           "util.ss"
+           "parse-table.ss"
+           ;"servlet-helpers.ss"
+           "response.ss"
+           (lib "unitsig.ss")
+           (lib "contract.ss")
+           (lib "url.ss" "net")
+           (lib "date.ss"))
+
+  (provide complete-configuration
+           build-developer-configuration
+           build-developer-configuration/vhosts ;; added 2/3/05 by Jacob
+           default-configuration-table-path
+           update-configuration
+           )
+
+  (provide/contract
+   [load-configuration (path? . -> . unit/sig?)]
+   [load-developer-configuration (path? . -> . unit/sig?)])
+
+
+  (define default-configuration-table-path
+    (build-path (collection-path "web-server") "configuration-table"))
+
+  ; get-configuration : path -> configuration-table
+  (define (get-configuration table-file-name)
+    (parse-configuration-table (call-with-input-file table-file-name read)))
+
+  ; load-configuration : path -> configuration
+  (define (load-configuration table-file-name)
+    (complete-configuration (directory-part table-file-name) (get-configuration table-file-name)))
+
+  ; load-developer-configuration : path -> configuration
+  (define (load-developer-configuration table-file-name)
+    (complete-developer-configuration (directory-part table-file-name)
+                                      (get-configuration table-file-name)))
+
+  ; build-developer-configuration : tst -> configuration-table
+  (define (build-developer-configuration s-expr)
+    (complete-developer-configuration (directory-part default-configuration-table-path)
+                                      (parse-configuration-table s-expr)))
+
+  ;; added 2/3/05 by Jacob -- Help Desk needs to support virtual hosts
+  ; build-developer-configuration/vhosts : tst -> configuration-table
+  (define (build-developer-configuration/vhosts s-expr)
+    (complete-developer-configuration/vhosts (directory-part default-configuration-table-path)
+                                             (parse-configuration-table s-expr)))
+  
+  ; : str configuration-table/vhosts -> configuration
+  (define (complete-developer-configuration/vhosts base table)
+    (build-configuration
+     table     
+     (let ([default-host
+             (apply-default-functions-to-host-table
+              base (configuration-table-default-host table) ignore-log)]
+           [expanded-virtual-host-table
+            (map (lambda (x)
+                   (list (regexp (string-append (car x) "(:[0-9]*)?"))
+                         (apply-default-functions-to-host-table base (cdr x) ignore-log)))
+                 (configuration-table-virtual-hosts table))])
+       (gen-virtual-hosts expanded-virtual-host-table default-host))))
+  
+  ; : str configuration-table -> configuration
+  (define (complete-configuration base table)
+    (build-configuration
+     table
+     (let ([default-host
+             (apply-default-functions-to-host-table
+              base (configuration-table-default-host table) gen-log-message)]
+           [expanded-virtual-host-table
+            (map (lambda (x)
+                   (list (regexp (string-append (car x) "(:[0-9]*)?"))
+                         (apply-default-functions-to-host-table base (cdr x) gen-log-message)))
+                 (configuration-table-virtual-hosts table))])
+       (gen-virtual-hosts expanded-virtual-host-table default-host))))
+
+  ; : str configuration-table -> configuration
+  (define (complete-developer-configuration base table)
+    (build-configuration
+     table
+     (gen-virtual-hosts null (apply-default-functions-to-host-table
+                              base
+                              (configuration-table-default-host table) ignore-log))))
+
+  ; : configuration-table host-table -> configuration
+  (define (build-configuration table the-virtual-hosts)
+    (unit/sig web-config^
+      (import)
+      (define port (configuration-table-port table))
+      (define max-waiting (configuration-table-max-waiting table))
+      (define listen-ip #f) ; more here - add to configuration table
+      (define initial-connection-timeout (configuration-table-initial-connection-timeout table))
+      (define virtual-hosts the-virtual-hosts)
+      (define access (make-hash-table))
+      (define instances (make-hash-table))
+      (define scripts (box (make-hash-table 'equal)))
+      (define make-servlet-namespace the-make-servlet-namespace)))
+
+  ; begin stolen from commander.ss, which was stolen from private/drscheme/eval.ss
+  ; FIX - abstract this out to a namespace library somewhere (ask Robby and Matthew)
+
+
+  (define to-be-copied-module-specs
+    '(mzscheme
+      ;; allow people (SamTH) to use MrEd primitives from servlets.
+      ;; GregP: putting mred.ss here is a bad idea because it will cause
+      ;; web-server-text to have a dependency on mred
+      ;(lib "mred.ss" "mred")
+      (lib "servlet.ss" "web-server")))
+
+
+  ; JBC : added error-handler hack; the right answer is only to transfer the 'mred'
+  ; module binding when asked to, e.g. by a field in the configuration file.
+  ; GregP: put this back in if Sam's code breaks
+  ;  (for-each (lambda (x) (with-handlers ([exn:fail? (lambda (exn) 'dont-care)])
+  ;                          ; dynamic-require will fail when running web-server-text.
+  ;                          ; maybe a warning message in the exception-handler?
+  ;                          (dynamic-require x #f)))
+  ;            to-be-copied-module-specs)
+
+  ;; get the names of those modules.
+  (define to-be-copied-module-names
+    (let ([get-name
+           (lambda (spec)
+             (if (symbol? spec)
+                 spec
+                 ((current-module-name-resolver) spec #f #f)))])
+      (map get-name to-be-copied-module-specs)))
+  ; end stolen
+
+  (define (the-make-servlet-namespace)
+    (let ([server-namespace (current-namespace)]
+          [new-namespace (make-namespace)])
+      (parameterize ([current-namespace new-namespace])
+        (for-each (lambda (name) (namespace-attach-module server-namespace name))
+                  to-be-copied-module-names)
+        new-namespace)))
+
+  ; : (listof (cons sym TST)) -> configuration
+  ; more here - this is ugly.  It also does not catch "unbound identifiers" since I use symbols.
+  ; I considered several other solutions:
+  ; - write the compound unit multiple times (no abstraction)
+  ; - use opt-lambda and pass in 'please-use-the-default for unchanged flags
+  ; - write three different functional updaters and re-compound the unit 1--3 times
+  (define (update-configuration configuration flags)
+    (compound-unit/sig
+     (import)
+     (link
+      [config : web-config^ (configuration)]
+      [new-config : web-config/local^
+                  ((unit/sig web-config/local^
+                     (import (raw : web-config/local^))
+                     (define port (extract-flag 'port flags raw:port))
+                     (define listen-ip (extract-flag 'ip-address flags raw:listen-ip))
+                     (define instances (extract-flag 'instances flags raw:instances))
+                     (define make-servlet-namespace (extract-flag 'namespace flags raw:make-servlet-namespace)))
+                   (config : web-config/local^))])
+     (export (open (config : web-config/pervasive^))
+             (open (new-config : web-config/local^)))))
+
+  ; error-response : nat str str [(cons sym str) ...] -> response
+  ; more here - cache files with a refresh option.
+  ; The server should still start without the files there, so the
+  ; configuration tool still runs.  (Alternatively, find an work around.)
+  (define (error-response code short text-file . extra-headers)
+    (make-response/full code short
+                        (current-seconds) TEXT/HTML-MIME-TYPE
+                        extra-headers
+                        (list (read-file text-file))))
+
+
+  ; servlet-loading-responder : url tst -> response
+  ; more here - parameterize error based on a configurable file, perhaps?
+  ; This is slightly tricky since the (interesting) content comes from the exception.
+  (define (servlet-loading-responder url exn)
+    (make-response/full 500 "Servlet didn't load"
+                        (current-seconds)
+                        #"text/plain" ;TEXT/HTML-MIME-TYPE
+                        '() ; check
+                        (list "Servlet didn't load.\n"
+                              (exn->string exn))))
+
+  ; gen-servlet-not-found : str -> url -> response
+  (define (gen-servlet-not-found file-not-found-file)
+    (lambda (url)
+      (error-response 404 "Servlet not found" file-not-found-file)))
+
+  ; gen-servlet-responder : str -> url tst -> response
+  (define (gen-servlet-responder servlet-error-file)
+    (lambda (url exn)
+      ; more here - use separate log file
+      ((error-display-handler)
+       (format "Servlet exception:\n~a\n" (exn-message exn))
+       exn)
+      (error-response 500 "Servlet error" servlet-error-file)))
+
+  ; gen-servlets-refreshed : str -> -> response
+  (define (gen-servlets-refreshed servlet-refresh-file)
+    (lambda ()
+      (error-response 200 "Servlet cache refreshed" servlet-refresh-file)))
+
+  ; gen-passwords-refreshed : str -> -> response
+  (define (gen-passwords-refreshed password-refresh-file)
+    (lambda ()
+      (error-response 200 "Passwords refreshed" password-refresh-file)))
+
+  ; gen-authentication-responder : str -> url (cons sym str) -> response
+  (define (gen-authentication-responder access-denied-file)
+    (lambda (uri recommended-header)
+      (error-response 401 "Authorization Required" access-denied-file
+                      recommended-header)))
+
+  ; gen-protocol-responder : str -> str -> response
+  (define (gen-protocol-responder protocol-file)
+    (lambda (error-message)
+      (error-response 400 "Malformed Request" protocol-file)))
+
+  ; gen-file-not-found-responder : str -> url -> response
+  (define (gen-file-not-found-responder file-not-found-file)
+    (lambda (url)
+      (error-response 404 "File not found" file-not-found-file)))
+
+  (define servlet?
+    (let ([servlets-regexp (regexp "^/servlets/.*")])
+      (lambda (str)
+        (regexp-match servlets-regexp str))))
+
+  ; access-denied? : str sym str -> (U #f str)
+  ; (define (access-denied? client-ip user-name password) ???)
+  ; The configuration needs a simple way to combine ip and username authentication with
+  ; boolean-and, boolean-or, and perhaps others operations.
+  ; Using quote in the old password system enabled abstraction, which
+  ; I never used.
+  ; ...
+
+  ; gen-log-message : sym str -> str str sym url str -> str
+  ; more here - check apache log configuration formats
+  ; other server's include the original request line,
+  ; including the major and minor HTTP version numbers
+  ; to produce a string that is displayed into the log file
+  (define (gen-log-message log-format log-path)
+    (let ([outsem (make-semaphore 1)])
+      (lambda (host-ip client-ip method uri host)
+        (semaphore-wait outsem)
+        ; do the display all at once by formating first
+        (display
+          (format "~s~n"
+            (list 'from client-ip 'to host-ip 'for (url->string uri) 'at
+                  (date->string (seconds->date (current-seconds)) #t)))
+          (open-output-file log-path 'append))
+        (semaphore-post outsem))))
+
+  ; ignore-log : sym str -> str str sym url str -> str
+  (define (ignore-log log-format log-path) void)
+
+  ; read-file : str -> str
+  (define (read-file path)
+    (call-with-input-file path
+      (lambda (in) (read-string (file-size path) in))))
+
+  ; apply-default-functions-to-host-table : str host-table (sym str -> str str sym url str -> str) -> host
+  ;; Greg P: web-server-root is the directory-part of the path to the configuration-table (I don't think I like this.)
+  (define (apply-default-functions-to-host-table web-server-root host-table gen-log-message-maybe)
+    (let ([paths (expand-paths web-server-root (host-table-paths host-table))])
+      (make-host
+       (host-table-indices host-table)
+       (gen-log-message-maybe (host-table-log-format host-table) (paths-log paths))
+       (paths-passwords paths)
+       (let ([m (host-table-messages host-table)]
+             [conf (paths-conf paths)])
+         (make-responders
+          (gen-servlet-responder (build-path-unless-absolute conf (messages-servlet m)))
+          servlet-loading-responder
+          (gen-authentication-responder (build-path-unless-absolute conf (messages-authentication m)))
+          (gen-servlets-refreshed (build-path-unless-absolute conf (messages-servlets-refreshed m)))
+          (gen-passwords-refreshed (build-path-unless-absolute conf (messages-passwords-refreshed m)))
+          (gen-file-not-found-responder (build-path-unless-absolute conf (messages-file-not-found m)))
+          (gen-protocol-responder (build-path-unless-absolute conf (messages-protocol m)))))
+       (host-table-timeouts host-table)
+       paths)))
+
+  ; expand-paths : str paths -> paths
+  (define (expand-paths web-server-root paths)
+    (let ([host-base (build-path-unless-absolute web-server-root (paths-host-base paths))])
+      (make-paths (build-path-unless-absolute host-base (paths-conf paths))
+                  host-base
+                  (build-path-unless-absolute host-base (paths-log paths))
+                  (build-path-unless-absolute host-base (paths-htdocs paths))
+                  (build-path-unless-absolute host-base (paths-servlet paths))
+                  (build-path-unless-absolute host-base (paths-passwords paths)))))
+
+  ; gen-virtual-hosts : (listof (list regexp host)) host ->
+  ; str -> host-configuration
+  (define (gen-virtual-hosts expanded-virtual-host-table default-host)
+    (lambda (host-name-possibly-followed-by-a-collon-and-a-port-number)
+      (or (ormap (lambda (x)
+                   (and (regexp-match (car x) host-name-possibly-followed-by-a-collon-and-a-port-number)
+                        (cadr x)))
+                 expanded-virtual-host-table)
+          default-host)))
+
+
+  )
diff --git a/collects/web-server/configure.ss b/collects/web-server/configure.ss
new file mode 100644
index 0000000000..843d5e33a5
--- /dev/null
+++ b/collects/web-server/configure.ss
@@ -0,0 +1,842 @@
+(module configure mzscheme
+  (provide servlet servlet-maker)
+  (require (lib "unitsig.ss")
+           (lib "servlet-sig.ss" "web-server")
+           (lib "url.ss" "net")
+           (lib "etc.ss")
+           (lib "list.ss")
+           (lib "pretty.ss")
+           (lib "file.ss")
+           (rename (lib "configuration.ss" "web-server")
+                   default-configuration-table-path default-configuration-table-path)
+           (lib "configuration-table-structs.ss" "web-server")
+           (lib "parse-table.ss" "web-server")
+           (all-except (lib "util.ss" "web-server") translate-escapes))
+
+  ;; FIX
+  ; - fuss with changing absolute paths into relative ones internally
+  ; - move old config files instead of copying default ones
+  ;   - ask: - move exisiting (don't move defaults)
+  ;          - copy defaults to new location
+  ;          - use files existing in the new location (ask only when they exist)
+  ;   - do this when either
+  ;     - changing the root dir (and at least one other file depends on it?)
+  ;     - editing an individual path
+  ; - change all configuration paths (in the configure servlet and in the server) to
+  ;   use a platform independent representation (i.e. a listof strings)
+
+  ; servlet-maker : str -> (unit/sig servlet^ -> ())
+  (define (servlet-maker default-configuration-path)
+    (unit/sig ()
+      (import servlet^)
+
+      (define CONFIGURE-SERVLET-NAME "configure.ss")
+      (define WIDE "70")
+
+      (adjust-timeout! (* 12 60 60))
+      (error-print-width 800) ; 10-ish lines
+
+      ; passwords = (listof realm)
+      ; realm = (make-realm str str (listof user-pass))
+      (define-struct realm (name pattern allowed))
+
+      ; user-pass = (make-user-pass sym str)
+      (define-struct user-pass (user pass))
+
+      (define doc-dir "Defaults/documentation")
+
+      (define edit-host-button-name "Edit Minor Details")
+
+      ; build-footer : str -> html
+      (define (build-footer base)
+        (let ([scale (lambda (n) (number->string (round (/ n 4))))])
+          `(p "Powered by "
+              (a ([href "http://www.plt-scheme.org/"])
+                 (img ([width ,(scale 211)] [height ,(scale 76)]
+                       [src ,(string-append base doc-dir "/plt-logo.gif")]))))))
+
+      (define footer (build-footer "/"))
+
+      ; access-error-page : html
+      (define access-error-page
+        `(html (head (title "Web Server Configuration Access Error"))
+               (body ([bgcolor "white"])
+                     (p "You must connect to the configuration tool from the machine the server runs on using 127.0.0.1 for the host part of the URL.")
+                     ,footer)))
+
+      ; permission-error-page : path -> html
+      (define (permission-error-page configuration-path)
+        `(html (head (title "Web Server Configuration Permissions Error"))
+               (body ([bgcolor "white"])
+                     (p "You must have read and write access to "
+                        (code ,(path->string configuration-path))
+                        " in order to configure the server."))))
+
+      ; check-ip-address : request -> request
+      (define (check-ip-address request)
+        (unless (string=? "127.0.0.1" (request-host-ip request))
+          (send/finish access-error-page))
+        request)
+
+      (check-ip-address initial-request)
+
+      (define web-base (directory-part default-configuration-path))
+
+      ; more here - abstract with static pages?
+      (define web-server-icon
+        `(img ([src ,(string-append "/" doc-dir "/web-server.gif")]
+               ;[width "123"] [height "115"]
+               [width "61"] [height "57"])))
+
+      ; interact : (str -> response) -> bindings
+      (define (interact page)
+        (request-bindings (check-ip-address (send/suspend page))))
+
+      ; choose-configuration-file : -> doesn't
+      (define (choose-configuration-file)
+        (let ([configuration-path (ask-for-configuration-path)])
+          (let loop ()
+            (if (file-exists? configuration-path)
+                (let ([perms (file-or-directory-permissions configuration-path)])
+                  ; race condition - changing the permissions after the check
+                  ; will result in an exception later (which serves them right)
+                  (if (and (memq 'write perms) (memq 'read perms))
+                      (configure-top-level configuration-path)
+                      (send/finish (permission-error-page configuration-path))))
+                (begin (send/suspend (copy-configuration-file configuration-path))
+                       (with-handlers ([exn:fail:filesystem:exists? send-exn])
+                         (let-values ([(base name must-be-dir) (split-path configuration-path)])
+                           (ensure-directory-shallow base))
+                         (copy-file default-configuration-path configuration-path))
+                       (loop))))))
+
+      ; copy-configuration-file : path -> html
+      (define (copy-configuration-file configuration-path)
+        (build-suspender
+         '("Copy Configuration File")
+         `((h1 "Copy Configuration File")
+           (p "The configuration file "
+              (blockquote (code ,(path->string configuration-path)))
+              "does not exist.  Would you like to copy the default configuration to this "
+              "location?")
+           (center (input ([type "submit"] [name "ok"] [value "Copy"]))))))
+
+      ; ask-for-configuration-path : -> path
+      (define (ask-for-configuration-path)
+        (build-path
+         (extract-binding/single
+          'path
+          (request-bindings (send/suspend configuration-path-page)))))
+
+      ; configuration-path-page : str -> html
+      (define configuration-path-page
+        (build-suspender
+         '("Choose a Configuration File")
+         `((h1 "Choose a Web Server Configuration File")
+           ,web-server-icon
+           (p "Choose a Web server configuration file to edit. "
+              (br)
+              "This Web server uses the configuration in "
+              (blockquote (code ,(path->string default-configuration-path))))
+           (table (tr (th "Configuration path")
+                      (td (input ([type "text"] [name "path"] [size ,WIDE]
+                                  [value ,(path->string default-configuration-path)]))))
+                  (tr (td ([colspan "2"] [align "center"])
+                          (input ([type "submit"] [name "choose-path"] [value "Select"]))))))))
+
+      ; configure-top-level : path -> doesn't
+      (define (configure-top-level configuration-path)
+        (with-handlers ([exn:fail:filesystem:exists? send-exn])
+          (let ([original-configuration (read-configuration configuration-path)])
+            (let loop ([configuration original-configuration])
+              (let* ([update-bindings (interact (request-new-configuration-table configuration original-configuration))]
+                     [form-configuration
+                      (delete-hosts (update-configuration configuration update-bindings)
+                                    (foldr (lambda (b acc)
+                                             (if (string=? "Delete" (cdr b))
+                                                 (cons (symbol->string (car b)) acc)
+                                                 acc))
+                                           null
+                                           update-bindings))]
+                     [new-configuration
+                      (cond
+                        [(assq 'add-host update-bindings)
+                         (add-virtual-host form-configuration (extract-bindings 'host-prefixes update-bindings))]
+                        [(reverse-assoc edit-host-button-name update-bindings)
+                         =>
+                         (lambda (edit)
+                           ; write the configuration twice when editing a host: once before and once after.
+                           ; The after may never happen if the user doesn't continue
+                           (write-configuration form-configuration configuration-path)
+                           (configure-hosts form-configuration (string->number (symbol->string (car edit)))))]
+                        [else form-configuration])])
+                (write-configuration new-configuration configuration-path)
+                (loop new-configuration))))))
+
+      ; switch-to-current-port : configuration-table -> (U #f configuration-table)
+      ; doesn't work - the browser doesn't send the port and it wouldn't be reliable anyway
+      ; perhaps the server could include it?
+      '(define (switch-to-current-port old)
+         (let ([current-port (url-port (request-uri initial-request))])
+           (and (not (= current-port (configuration-table-port old)))
+                (make-configuration-table
+                 current-port
+                 (configuration-table-max-waiting old)
+                 (configuration-table-initial-connection-timeout old)
+                 (configuration-table-default-host old)
+                 (configuration-table-virtual-hosts old)))))
+
+      ; send-exn : tst -> doesn't
+      (define (send-exn exn)
+        (send/back (exception-error-page exn)))
+
+      ; reverse-assoc : a (listof (cons b a)) -> (U #f (cons b a))
+      (define (reverse-assoc x lst)
+        (cond
+          [(null? lst) #f]
+          [else (if (equal? x (cdar lst))
+                    (car lst)
+                    (reverse-assoc x (cdr lst)))]))
+
+      ; add-virtual-host : configuration-table (listof str) -> configuration-table
+      (define (add-virtual-host conf existing-prefixes)
+        (update-hosts conf (cons (cons "my-host.my-domain.org"
+                                       (configuration-table-default-host conf))
+                                 (configuration-table-virtual-hosts conf))))
+
+      ; update-hosts : configuration-table (listof (cons str host-table))
+      (define (update-hosts conf new-hosts)
+        (make-configuration-table
+         (configuration-table-port conf)
+         (configuration-table-max-waiting conf)
+         (configuration-table-initial-connection-timeout conf)
+         (configuration-table-default-host conf)
+         new-hosts))
+
+      ; write-to-file : str TST -> void
+      (define (write-to-file file-name x)
+        (call-with-output-file file-name
+          (lambda (out) (pretty-print x out))
+          'truncate))
+
+      ; delete-hosts : configuration-table (listof str) -> configuration-table
+      ; pre: (>= (length (configuration-table-virtual-hosts conf)) (max to-delete))
+      (define (delete-hosts conf to-delete)
+        ; the if is not needed, it just avoids some work
+        (if (null? to-delete)
+            conf
+            (update-hosts
+             conf
+             (drop (configuration-table-virtual-hosts conf) to-delete))))
+
+      ; drop : (listof a) (listof str) -> (listof a)
+      ; pre: (apply < to-delete)
+      ; to delete the entries in to-filter indexed by to-delete
+      (define (drop to-filter to-delete)
+        (let loop ([to-filter to-filter] [to-delete (map string->number to-delete)] [i 0])
+          (cond
+            [(null? to-delete) to-filter]
+            [else (if (= i (car to-delete))
+                      (loop (cdr to-filter) (cdr to-delete) (add1 i))
+                      (cons (car to-filter) (loop (cdr to-filter) to-delete (add1 i))))])))
+
+      ; configure-hosts : configuration-table (U #f nat) -> configuration-table
+      ; n is either the virtual host number or #f for the default virtual host
+      (define (configure-hosts old n)
+        (if n
+            (update-hosts old
+                          ; more here - consider restructuring this map.  Perhaps it is fine.
+                          ; Perhaps it should short circuit.  Perhaps the number of virtual hosts
+                          ; is small so it doesn't matter. Perhaps that is a sloppy way to think/program.
+                          ; The code is really a functional array update except it's on a list.
+                          (map (lambda (host this-n)
+                                 (if (= n this-n)
+                                     (cons (car host) (configure-host (cdr host)))
+                                     host))
+                               (configuration-table-virtual-hosts old)
+                               (build-list (length (configuration-table-virtual-hosts old)) (lambda (x) x))))
+            (make-configuration-table
+             (configuration-table-port old)
+             (configuration-table-max-waiting old)
+             (configuration-table-initial-connection-timeout old)
+             (configure-host (configuration-table-default-host old))
+             (configuration-table-virtual-hosts old))))
+
+      ; configure-host : host-table -> host-table
+      (define (configure-host old)
+        (let* ([bindings (interact (request-new-host-table old))]
+               [new (update-host-table old bindings)])
+          (when (assq 'edit-passwords bindings)
+            (let* ([paths (host-table-paths new)]
+                   [password-path
+                    ;; build-path-unless-absolute is defined in configuration.ss
+                    (build-path-unless-absolute
+                     (build-path-unless-absolute web-base (paths-host-base paths))
+                     (paths-passwords paths))])
+              (unless (file-exists? password-path)
+                (write-to-file password-path ''()))
+              (configure-passwords password-path)))
+          new))
+
+      (define restart-message
+        `((h3 (font ([color "red"]) "Restart the Web server to use the new settings."))))
+
+      ; request-new-configuration-table : configuration-table configuration-table -> str -> html
+      (define (request-new-configuration-table old orig)
+        (build-suspender
+         '("PLT Web Server Configuration")
+         `((h1 "PLT Web Server Configuration Management")
+           ,web-server-icon
+           "copyright 2001 by Paul Graunke and PLT"
+           (hr)
+           (h2 "Basic Configuration")
+           (table
+            ,(make-tr-num "Port" 'port (configuration-table-port old))
+            ,(make-tr-num "Maximum Waiting Connections"
+                          'waiting (configuration-table-max-waiting old))
+            ,(make-tr-num "Initial Connection Timeout (seconds)" 'time-initial
+                          (configuration-table-initial-connection-timeout old)))
+           (hr)
+           (h2 "Host Name Configuration")
+           (p "The Web server accepts requests on behalf of multiple " (em "hosts")
+              " each corresponding to a domain name."
+              " The table below maps domain names to host specific configurations.")
+           (table ([width "50%"])
+                  (tr (th ([align "left"]) "Name") ;(th "Host configuration path")
+                      (th "Host Directory")
+                      (th nbsp)
+                      (th nbsp))
+                  (tr (td ,"Default Host")
+                      (td ,(make-field-size "text" 'default-host-root
+                                       (table->host-root (configuration-table-default-host old))
+                                       WIDE))
+                      (td ([align "center"])
+                          (input ([type "submit"] [name "default"] [value ,edit-host-button-name])))
+                      (td nbsp))
+                  ,@(map (lambda (host n)
+                           `(tr (td ,(make-field "text" 'host-regexps (car host)))
+                                (td ,(make-field-size "text" 'host-roots (table->host-root (cdr host)) WIDE))
+                                (td ([align "center"])
+                                    (input ([type "submit"] [name ,n] [value ,edit-host-button-name])))
+                                (td ([align "center"])
+                                    (input ([type "submit"] [name ,n] [value "Delete"])))))
+                         (configuration-table-virtual-hosts old)
+                         (build-list (length (configuration-table-virtual-hosts old)) number->string))
+                  (tr (td (input ([type "submit"] [name "add-host"] [value "Add Host"])))
+                      (td nbsp); (input ([type "submit"] [name "configure"] [value "Delete"]))
+                      ;(td (input ([type "submit"] [name "edit-host-details"] [value "Edit"])))
+                      (td nbsp)))
+           (hr)
+           (table ([width "90%"])
+                  ,@(if (equal? old orig) ; This only tests eq? because structures are more opaque now.
+                        null
+                        `((tr (td ,@restart-message))))
+                  (tr (td (input ([type "submit"] [name "configure"] [value "Update Configuration"])))))
+           (hr)
+           ,footer)))
+
+      ; table->host-root : host-table -> str
+      (define (table->host-root t)
+        (path->string (build-path-unless-absolute web-base (paths-host-base (host-table-paths t)))))
+
+      ; gen-make-tr : nat -> xexpr sym str [xexpr ...] -> xexpr
+      (define (gen-make-tr size-n)
+        (let ([size-str (number->string size-n)])
+          (lambda (label tag default-text . extra-tds)
+            `(tr (td (a ([href ,(format "/~a/terms/~a.html" doc-dir tag)]) ,label))
+                 (td ,(make-field-size "text" tag (format "~a" default-text) size-str))
+                 . ,extra-tds))))
+
+      (define make-tr-num (gen-make-tr 20))
+
+      (define make-tr-str (gen-make-tr 70))
+
+      ; make-field : str sym str -> xexpr
+      (define (make-field type label value)
+        (make-field-size type label value "30"))
+
+      ; make-field-size : str sym str str -> xexpr
+      (define (make-field-size type label value size)
+        `(input ([type ,type] [name ,(symbol->string label)] [value ,value] [size ,size])))
+
+      ; update-configuration : configuration-table bindings -> configuration-table
+      (define (update-configuration old bindings)
+        (let ([ubp (un-build-path web-base)]) ;; web-base returned by directory-part is a path
+        (make-configuration-table
+         (string->nat (extract-binding/single 'port bindings))
+         (string->nat (extract-binding/single 'waiting bindings))
+         (string->num (extract-binding/single 'time-initial bindings))
+         (update-host-root (configuration-table-default-host old)
+                           (ubp (build-path (extract-binding/single 'default-host-root bindings))))
+         (map (lambda (h root pattern)
+                (cons pattern (update-host-root (cdr h) (ubp (build-path root)))))
+              (configuration-table-virtual-hosts old)
+              (extract-bindings 'host-roots bindings)
+              (extract-bindings 'host-regexps bindings)))))
+
+      ; update-host-root : host-table str -> host-table
+      (define (update-host-root host new-root)
+        (host-table<-paths host (paths<-host-base (host-table-paths host) new-root)))
+
+      ; host-table<-paths : host-table paths -> host-table
+      ; more here - create these silly functions automatically from def-struct macro
+      (define (host-table<-paths host paths)
+        (make-host-table
+         (host-table-indices host)
+         (host-table-log-format host)
+         (host-table-messages host)
+         (host-table-timeouts host)
+         paths))
+
+      ; paths<-host-base : paths str -> paths
+      ; more here - create these silly functions automatically from def-struct macro
+      (define (paths<-host-base paths host-base)
+        (make-paths (paths-conf paths)
+                    host-base
+                    (paths-log paths)
+                    (paths-htdocs paths)
+                    (paths-servlet paths)
+                    (paths-passwords paths)))
+
+      ; string->num : str -> nat
+      (define (string->num str)
+        (or (string->number str) (error 'string->nat "~s is not a number" str)))
+
+      ; string->nat : str -> nat
+      (define (string->nat str)
+        (let ([n (string->number str)])
+          (if (and n (integer? n) (exact? n) (>= n 0))
+              n
+              (error 'string->nat "~s is not exactly a natural number" str))))
+
+      ; request-new-host-table : host-table -> str -> response
+      (define (request-new-host-table old)
+        (let* ([timeouts (host-table-timeouts old)]
+               [paths (host-table-paths old)]
+               [m (host-table-messages old)]
+               [host-root (build-path-unless-absolute web-base (paths-host-base paths))]
+               [conf (build-path-unless-absolute host-root (paths-conf paths))])
+          (build-suspender
+           '("Configure Host")
+           `((h1 "PLT Web Server Host configuration")
+             (input ([type "submit"] [value "Save Configuration"]))
+             (hr)
+             (table
+              (tr (th ([colspan "2"]) "Paths"))
+              ,(make-tr-str "Log file"
+                            'path-log (build-path-unless-absolute host-root (paths-log paths)))
+              ,(make-tr-str "Web document root"
+                            'path-htdocs (build-path-unless-absolute host-root (paths-htdocs paths)))
+              ,(make-tr-str "Servlet root"
+                            'path-servlet (build-path-unless-absolute host-root (paths-servlet paths)))
+              ,(make-tr-str "Password File"
+                            'path-password (build-path-unless-absolute host-root (paths-passwords paths)))
+              (tr (td ([colspan "2"])
+                      ,(make-field "submit" 'edit-passwords "Edit Passwords")))
+              (tr (td ([colspan "2"]) (hr)))
+              (tr (th ([colspan "2"]) "Message Paths"))
+              ,(make-tr-str "Servlet error" 'path-servlet-message
+                            (build-path-unless-absolute conf (messages-servlet m)))
+              ,(make-tr-str "Access Denied" 'path-access-message
+                            (build-path-unless-absolute conf (messages-authentication m)))
+              ,(make-tr-str "Servlet cache refreshed" 'servlet-refresh-message
+                            (build-path-unless-absolute conf (messages-servlets-refreshed m)))
+              ,(make-tr-str "Password cache refreshed" 'password-refresh-message
+                            (build-path-unless-absolute conf (messages-passwords-refreshed m)))
+              ,(make-tr-str "File not found" 'path-not-found-message
+                            (build-path-unless-absolute conf (messages-file-not-found m)))
+              ,(make-tr-str "Protocol error" 'path-protocol-message
+                            (build-path-unless-absolute conf (messages-protocol m)))
+              (tr (td ([colspan "2"]) (hr)))
+              (tr (th ([colspan "2"]) "Timeout Seconds"))
+              ,(make-tr-num "Default Servlet" 'time-default-servlet (timeouts-default-servlet timeouts))
+              ,(make-tr-num "Password" 'time-password (timeouts-password timeouts))
+              ,(make-tr-num "Servlet Connection" 'time-servlet-connection (timeouts-servlet-connection timeouts))
+              ,(make-tr-num "per Byte When Transfering Files" 'time-file-per-byte (timeouts-file-per-byte timeouts))
+              ,(make-tr-num "Base When Transfering Files" 'time-file-base (timeouts-file-base timeouts)))
+             (hr)
+             (input ([type "submit"] [value "Save Configuration"]))
+             ,footer))))
+
+      ; update-host-table : host-table (listof (cons sym str)) -> host-table
+      (define (update-host-table old bindings)
+        (let* ([eb (lambda (tag) (build-path (extract-binding/single tag bindings)))]
+               [paths (host-table-paths old)]
+               [host-root (paths-host-base paths)]
+               [expanded-host-root (build-path-unless-absolute web-base host-root)]
+               [conf (build-path-unless-absolute expanded-host-root (paths-conf paths))]
+               [ubp (un-build-path expanded-host-root)]
+               [eb-host-root (lambda (tag) (ubp (eb tag)))]
+               [ubp-conf (un-build-path conf)]
+               [eb-conf (lambda (tag) (ubp-conf (eb tag)))])
+          (make-host-table
+           (host-table-indices old)
+           (host-table-log-format old)
+           (apply make-messages
+                  (map eb-conf '(path-servlet-message path-access-message servlet-refresh-message password-refresh-message path-not-found-message path-protocol-message)))
+           (apply make-timeouts
+                  (map (lambda (tag) (string->number (extract-binding/single tag bindings)))
+                       '(time-default-servlet time-password time-servlet-connection time-file-per-byte time-file-base)))
+           (let ([old-paths (host-table-paths old)])
+             (apply make-paths
+                    (paths-conf old-paths)
+                    ((un-build-path web-base) (build-path (paths-host-base old-paths)))
+                    (map eb-host-root '(path-log path-htdocs path-servlet path-password)))))))
+
+      ; un-build-path : path -> path -> string
+      ; (GregP) Theory: this should return a string not a path so that the result can be
+      ;                 written to the configuration file.
+      (define (un-build-path possible-base)
+        (let ([base-list (path->list possible-base)])
+          (lambda (path)
+            (let ([path-list (path->list path)])
+              (cond
+                [(suffix base-list path-list)
+                 => (lambda (x) (path->string (apply build-path x)))]
+                [else
+                 (path->string path)])))))
+
+      ; suffix : (listof a) (listof a) -> (U #f (listof a))
+      ; to return the extra elements in b after removing all elements from a in order
+      (define (suffix a b)
+        (cond
+          [(null? a) (if (null? b) #f b)]
+          [else (cond
+                  [(null? b) #f]
+                  [else (and (equal? (car a) (car b))
+                             (suffix (cdr a) (cdr b)))])]))
+
+      ; Password Configuration
+
+      ; configure-passwords : path -> void
+      (define (configure-passwords password-path)
+        (edit-passwords
+         password-path
+         (if (file-exists? password-path)
+             (call-with-input-file password-path read-passwords)
+             null)))
+
+      ; edit-passwords : path passwords -> passwords
+      (define (edit-passwords which-one passwords)
+        (let* ([bindings (interact (password-updates which-one passwords))]
+               [to-deactivate (extract-bindings 'deactivate bindings)]
+               [again
+                (lambda (new-passwords)
+                  (write-to-file which-one (format-passwords new-passwords))
+                  (edit-passwords which-one new-passwords))])
+          (cond
+            [(assq 'edit bindings)
+             => (lambda (edit)
+                  (again (drop (map (let ([to-edit (string->number (cdr edit))])
+                                      (lambda (r n)
+                                        (if (= to-edit n)
+                                            (edit-realm r)
+                                            r)))
+                                    passwords
+                                    (build-list (length passwords) (lambda (x) x)))
+                               to-deactivate)))]
+            [(assq 'add bindings)
+             (again (cons (make-realm "new realm" "" null)
+                          (drop passwords to-deactivate)))]
+            [else (drop passwords to-deactivate)])))
+
+      ; password-updates : path passwords -> request
+      (define (password-updates which-one passwords)
+        (let ([which-one (path->string which-one)])
+          (build-suspender
+           `("Updating Passwords for " ,which-one)
+           `((h1 "Updating Passwords for ")
+             (h3 ,which-one)
+             (h2 "You may wish to " (font ([color "red"]) "backup") " this password file.")
+             (p "Each authentication " (em "realm") " password protects URLs that match a pattern. "
+                "Choose a realm to edit below:")
+             (table
+              (tr (th "Realm Name") (th "Delete") (th "Edit"))
+              . ,(map (lambda (realm n)
+                        `(tr (td ,(realm-name realm))
+                             (td ,(make-field "checkbox" 'deactivate n))
+                             (td ,(make-field "radio" 'edit n))))
+                      passwords
+                      (build-list (length passwords) number->string)))
+             ,(make-field "submit" 'add "Add Realm")
+             ,(make-field "submit" 'edit-button "Edit")
+             ,footer))))
+
+      ; edit-realm : realm -> realm
+      (define (edit-realm realm)
+        (let* ([bindings (interact (realm-updates realm))]
+               [new-name (extract-binding/single 'realm-name bindings)]
+               [new-pattern (extract-binding/single 'realm-pattern bindings)]
+               [new-allowed
+                (drop (map (lambda (u p) (make-user-pass (string->symbol u) p))
+                           (extract-bindings 'user bindings)
+                           (extract-bindings 'pass bindings))
+                      (extract-bindings 'deactivate bindings))])
+          ; more here - check something?  Everything is a string or symbol, though.
+          (cond
+            [(assq 'add-user bindings)
+             (edit-realm (make-realm new-name new-pattern
+                                     (cons (make-user-pass 'ptg "Scheme-is-cool!") new-allowed)))]
+            [(assq 'update bindings)
+             (make-realm new-name new-pattern new-allowed)]
+            [else (error 'edit-realm "Didn't find either 'add-user or 'update in ~s" bindings)])))
+
+      ; realm-updates : realm -> request
+      (define (realm-updates realm)
+        (build-suspender
+         `("Update Authentication Realm " ,(realm-name realm))
+         `((h1 "Update Authentication Realm")
+           (table
+            ,(make-tr-str "Realm Name" 'realm-name (realm-name realm))
+            ,(make-tr-str "Protected URL Path Pattern" 'realm-pattern (realm-pattern realm)))
+           (hr)
+           (table
+            (tr (th "User Name") (th "Password") (th "Delete"))
+            . ,(map (lambda (x n)
+                      `(tr (td ,(make-field "text" 'user (symbol->string (user-pass-user x))))
+                           (td ,(make-field "text" 'pass (user-pass-pass x)))
+                           (td ,(make-field "checkbox" 'deactivate n))))
+                    (realm-allowed realm)
+                    (build-list (length (realm-allowed realm)) number->string)))
+           (input ([type "submit"] [name "add-user"] [value "Add User"]))
+           (input ([type "submit"] [name "update"] [value "Update Realm"]))
+           ,footer)))
+
+      ; read-passwords : iport -> passwords
+      ; only works if the file starts with (quote ...)
+      (define (read-passwords in)
+        (let ([raw (read in)])
+          (unless (and (pair? raw) (eq? 'quote (car raw))
+                       (null? (cddr raw)))
+            (error 'read-passwords "The password file must be quoted to use the configuration tool."))
+          (map (lambda (raw-realm)
+                 ; more here - error checking
+                 (make-realm (car raw-realm)
+                             (cadr raw-realm)
+                             (map (lambda (x) (make-user-pass (car x) (cadr x)))
+                                  (cddr raw-realm))))
+               (cadr raw))))
+
+      ; format-passwords : passwords -> s-expr
+      (define (format-passwords passwords)
+        (list 'quote
+              (map (lambda (r)
+                     (list* (realm-name r)
+                            (realm-pattern r)
+                            (map (lambda (x)
+                                   (list (user-pass-user x) (user-pass-pass x)))
+                                 (realm-allowed r))))
+                   passwords)))
+
+      ; Little Helpers
+
+      ; initialization-error-page : response
+      (define initialization-error-page
+        `(html (head (title "Web Server Configuration Program Invocation Error"))
+               (body ([bgcolor "white"])
+                     (p "Please direct your browser directly to the "
+                        (a ([href ,(url->string (request-uri initial-request))]) "configuration program,")
+                        " not through another URL.")
+                     ,footer)))
+
+      ; done-page : html
+      (define done-page
+        ; more-here - consider adding more useful information
+        `(html (head (title "done"))
+               (body ([bgcolor "white"])
+                     (h2 "Configuration Saved.")
+                     (p "Click your browser's back button to continue configuring the server.")
+                     ,footer)))
+
+      ; exception-error-page : TST -> html
+      (define (exception-error-page exn)
+        `(html (head (title "Error"))
+               (body ([bgcolor "white"])
+                     (p "Servlet exception: "
+                        (pre ,(exn->string exn)))
+                     ,footer)))
+
+      (define must-select-host-page
+        `(html (head (title "Web Server Configuration Error"))
+               (body ([bgcolor "white"])
+                     (p "Please select which host to edit before clicking the Edit button.")
+                     ,footer)))
+
+      ; io
+
+      ; read-configuration : path -> configuration-table
+      (define (read-configuration configuration-path)
+        (parse-configuration-table (call-with-input-file configuration-path read)))
+
+      ; write-configuration : configuration-table path -> void
+      ; writes out the new configuration file and
+      ; also copies the configure.ss servlet to the default-host's servlet directory
+      (define (write-configuration new configuration-path)
+        (ensure-configuration-servlet configuration-path (configuration-table-default-host new))
+        (ensure-configuration-paths new)
+        (write-to-file
+         configuration-path
+         `((port ,(configuration-table-port new))
+           (max-waiting ,(configuration-table-max-waiting new))
+           (initial-connection-timeout ,(configuration-table-initial-connection-timeout new))
+           (default-host-table
+            ,(format-host (configuration-table-default-host new)))
+           (virtual-host-table
+            . ,(map (lambda (h) (list (car h) (format-host (cdr h))))
+                    (configuration-table-virtual-hosts new))))))
+
+      ; ensure-configuration-servlet : path host-table -> void
+      (define (ensure-configuration-servlet configuration-path host)
+        (let* ([paths (host-table-paths host)]
+               [root (build-path-unless-absolute web-base
+                                       (paths-host-base paths))]
+               [servlets-path
+                (build-path (build-path-unless-absolute root (paths-servlet paths)) "servlets")])
+          (ensure-config-servlet configuration-path servlets-path)
+          (let ([defaults (build-path "Defaults")])
+            (ensure* (collection-path "web-server" "default-web-root" "htdocs")
+                     (build-path-unless-absolute root (paths-htdocs paths))
+                     defaults))))
+
+      ; ensure-configuration-paths : configuration-table -> void
+      ; to ensure that all the referenced config files exist for an entire configuration
+      (define (ensure-configuration-paths configuration)
+        (ensure-host-configuration (configuration-table-default-host configuration))
+        (for-each (lambda (x) (ensure-host-configuration (cdr x)))
+                  (configuration-table-virtual-hosts configuration)))
+
+      ; ensure-host-configuration : host-table -> void
+      ; to ensure that all the referenced config files exist for a virtual host
+      (define (ensure-host-configuration host)
+        (let* ([paths (host-table-paths host)]
+               [host-base (build-path-unless-absolute web-base (paths-host-base paths))]
+               [conf (build-path-unless-absolute host-base (paths-conf paths))]
+               [log (build-path-unless-absolute host-base (paths-log paths))])
+          ; skip passwords since a missing file is an okay default
+          (ensure-directory-shallow conf)
+          (ensure-directory-shallow host-base)
+          ;(ensure-file log ...) ; empty log file is okay
+          (ensure-directory-shallow (build-path-unless-absolute host-base (paths-htdocs paths)))
+          (ensure-directory-shallow (build-path-unless-absolute host-base (paths-servlet paths)))
+          (let* ([messages (host-table-messages host)]
+                 ; more here maybe - check default config file instead? maybe not
+                 [from-conf (collection-path "web-server" "default-web-root" "conf")]
+                 [copy-conf
+                  (lambda (from to)
+                    (let ([to-path (build-path-unless-absolute conf to)])
+                      ; more here - check existance of from path?
+                      (copy-file* (build-path from-conf from) to-path)))])
+            (copy-conf "passwords-refresh.html" (messages-passwords-refreshed messages))
+            (copy-conf "servlet-refresh.html" (messages-servlets-refreshed messages))
+            (copy-conf "forbidden.html" (messages-authentication messages))
+            (copy-conf "protocol-error.html" (messages-protocol messages))
+            (copy-conf "not-found.html" (messages-file-not-found messages))
+            (copy-conf "servlet-error.html" (messages-servlet messages)))))
+
+      ; ensure-file : path path path -> void
+      ; to copy (build-path from name) to (build-path to name), creating directories as
+      ; needed if the latter does not already exist.
+      (define (ensure-file from to name)
+        (let ([to (simplify-path to)])
+          (ensure-directory-shallow to)
+          (let ([to-path (build-path to name)])
+            (unless (file-exists? to-path)
+              (copy-file (build-path from name) to-path)))))
+
+      ; copy-file* : str str -> void
+      (define (copy-file* from-path to-path)
+        (unless (file-exists? to-path)
+          (let-values ([(to-path-base to-path-name must-be-dir?) (split-path to-path)])
+            (ensure-directory-shallow to-path-base))
+          (copy-file from-path to-path)))
+
+      ; ensure* : path path path -> void
+      ;; GregP: Don't know what the heck this does (thanks Paul)
+      ;;        but the first two arguments are now paths.
+      (define (ensure* from to name)
+        (ensure-directory-shallow to)
+        (let ([p (build-path from name)])
+          (cond
+            [(directory-exists? p)
+             (unless (member (path->string name) '("CVS" ".svn")) ; yuck
+               (let ([dest (build-path to name)])
+                 (ensure-directory-shallow dest)
+                 (for-each (lambda (x) (ensure* p dest x))
+                           (directory-list p))))]
+            [(file-exists? p)
+             (ensure-file from to name)])))
+
+      ; ensure-directory-shallow : path -> void
+      (define (ensure-directory-shallow to)
+        (unless (directory-exists? to)
+          ; race condition - someone else could make the directory
+          (make-directory* to)))
+
+      ; ensure-config-servlet : str path -> void
+      ; to create, if necessary, a stub configuration servlet that includes the main configuration servlet
+      ; at the desired location in a new web tree
+      (define (ensure-config-servlet configuration-path servlets-path)
+        (ensure-directory-shallow servlets-path)
+        (let ([file-path (build-path servlets-path CONFIGURE-SERVLET-NAME)])
+          (unless (file-exists? file-path) ; more here - check that it's a well formed servlet?
+            (call-with-output-file
+                file-path
+              (lambda (out)
+                (pretty-print
+                 `(require (lib ,CONFIGURE-SERVLET-NAME "web-server"))
+                 out)
+                (newline out)
+                (pretty-print
+                 `(servlet-maker ,(path->string configuration-path))
+                 out))))))
+
+      ; format-host : host-table
+      (define (format-host host)
+        (let ([t (host-table-timeouts host)]
+              [p (host-table-paths host)]
+              [m (host-table-messages host)])
+          `(host-table
+            ; more here - configure
+            (default-indices "index.html" "index.htm")
+            ; more here - configure
+            (log-format parenthesized-default)
+            (messages
+             (servlet-message ,(messages-servlet m))
+             (authentication-message ,(messages-authentication m))
+             (servlets-refreshed ,(messages-servlets-refreshed m))
+             (passwords-refreshed ,(messages-passwords-refreshed m))
+             (file-not-found-message ,(messages-file-not-found m))
+             (protocol-message ,(messages-protocol m)))
+            (timeouts
+             (default-servlet-timeout ,(timeouts-default-servlet t))
+             (password-connection-timeout ,(timeouts-password t))
+             (servlet-connection-timeout ,(timeouts-servlet-connection t))
+             (file-per-byte-connection-timeout ,(timeouts-file-per-byte t))
+             (file-base-connection-timeout ,(timeouts-file-base t)))
+            (paths
+             (configuration-root ,(paths-conf p))
+             (host-root ,(paths-host-base p))
+             (log-file-path ,(paths-log p))
+             (file-root ,(paths-htdocs p))
+             (servlet-root ,(paths-servlet p))
+             (password-authentication ,(paths-passwords p))))))
+
+      ; extract-definition : sym (listof s-expr) -> s-expr
+      ; to return the rhs from (def name rhs) not (def (name . args) body)
+      (define (extract-definition name defs)
+        (or (ormap (lambda (def)
+                     (and (pair? def) (eq? 'define (car def))
+                          (pair? (cdr def)) (eq? name (cadr def))
+                          (pair? (cddr def))
+                          (caddr def)))
+                   defs)
+            (error 'extract-definition "definition for ~a not found" name)))
+
+      ; passwords = str (i.e. path to a file)
+
+      (define build-path-maybe-expression->file-name caddr)
+
+      ; main
+      (choose-configuration-file)))
+
+  (define servlet (servlet-maker default-configuration-table-path)))
diff --git a/collects/web-server/connection-manager.ss b/collects/web-server/connection-manager.ss
new file mode 100644
index 0000000000..d529199b3d
--- /dev/null
+++ b/collects/web-server/connection-manager.ss
@@ -0,0 +1,48 @@
+;; this is an trivial implementation of the connection-manger interface that
+;; uses timeouts instead of a queued-model.
+
+;; the queued-model is also fully implemented but won't be used at this time.
+(module connection-manager mzscheme
+  (require "timer.ss"
+           (lib "contract.ss"))
+
+  (define-struct connection (timer i-port o-port custodian close?)
+    (make-inspector))
+
+  (provide/contract
+   [struct connection
+           ([timer timer?]
+            [i-port input-port?] [o-port output-port?] [custodian custodian?]
+            [close? boolean?])]
+   [start-connection-manager (custodian? . -> . void)]
+   [new-connection (number? input-port? output-port? custodian? boolean? . -> . connection?)]
+   [kill-connection! (connection? . -> . void)]
+   [adjust-connection-timeout! (connection? number? . -> . void)])
+
+  ;; start-connection-manager: custodian -> void
+  ;; does nothing
+  (define start-connection-manager void)
+
+  ;; new-connection: number i-port o-port custodian -> connection
+  ;; ask the connection manager for a new connection
+  (define (new-connection time-to-live i-port o-port cust close?)
+    (make-connection
+     (start-timer time-to-live
+                  (lambda () 
+                    (close-output-port o-port)
+                    (close-input-port i-port)
+                    (custodian-shutdown-all cust)))
+     i-port o-port cust close?))
+
+  ;; kill-connection!: connection -> void
+  ;; kill this connection
+  (define (kill-connection! conn-demned)
+    (close-output-port (connection-o-port conn-demned))
+    (close-input-port (connection-i-port conn-demned))
+    (custodian-shutdown-all (connection-custodian conn-demned)))
+
+  ;; adjust-connection-timeout!: connection number -> void
+  ;; change the expiration time for this connection
+  (define (adjust-connection-timeout! conn time)
+    (reset-timer (connection-timer conn) time))
+  )
diff --git a/collects/web-server/default-web-root/conf/forbidden.html b/collects/web-server/default-web-root/conf/forbidden.html
new file mode 100644
index 0000000000..fcd2eb9032
--- /dev/null
+++ b/collects/web-server/default-web-root/conf/forbidden.html
@@ -0,0 +1,7 @@
+<html>
+<head><title>Access Denied</title></head>
+<body>
+<p>The server could not verify that you have permissions to access the requested document.</p>
+<p>Powered by <a href="http://www.plt-scheme.org/">PLT</a></p>
+</body>
+</html>
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/conf/not-found.html b/collects/web-server/default-web-root/conf/not-found.html
new file mode 100644
index 0000000000..19bc1a0570
--- /dev/null
+++ b/collects/web-server/default-web-root/conf/not-found.html
@@ -0,0 +1,7 @@
+<html>
+<head><title>Not Found</title></head>
+<body bgcolor='white'>
+<p>The file you were looking for was not found on this server.</p>
+<p>Powered by <a href="http://www.plt-scheme.org/">PLT</a></p>
+</body>
+</html>
diff --git a/collects/web-server/default-web-root/conf/passwords-refresh.html b/collects/web-server/default-web-root/conf/passwords-refresh.html
new file mode 100644
index 0000000000..3f283393ab
--- /dev/null
+++ b/collects/web-server/default-web-root/conf/passwords-refresh.html
@@ -0,0 +1,7 @@
+<html>
+<head><title>Passwords Refreshed</title></head>
+<body bgcolor='white'>
+<p>The Web server is now using the new password file.</p>
+<p>Powered by <a href="http://www.plt-scheme.org/">PLT</a></p>
+</body>
+</html>
diff --git a/collects/web-server/default-web-root/conf/protocol-error.html b/collects/web-server/default-web-root/conf/protocol-error.html
new file mode 100644
index 0000000000..122732cc8d
--- /dev/null
+++ b/collects/web-server/default-web-root/conf/protocol-error.html
@@ -0,0 +1,7 @@
+<html>
+<head><title>Browser Error</title></head>
+<body>
+<p>The browser sent a malformed request.</p>
+<p>Powered by <a href="http://www.plt-scheme.org/">PLT</a></p>
+</body>
+</html>
diff --git a/collects/web-server/default-web-root/conf/servlet-error.html b/collects/web-server/default-web-root/conf/servlet-error.html
new file mode 100644
index 0000000000..bf6b698231
--- /dev/null
+++ b/collects/web-server/default-web-root/conf/servlet-error.html
@@ -0,0 +1,9 @@
+<html>
+<head><title>Servlet Error</title></head>
+<body>
+<p>The servlet terminated abnormally.<br />
+   Please ask the author to fix the problem based on the details in
+   the Web server's log file.</p>
+<p>Powered by <a href="http://www.plt-scheme.org/">PLT</a></p>
+</body>
+</html>
diff --git a/collects/web-server/default-web-root/conf/servlet-refresh.html b/collects/web-server/default-web-root/conf/servlet-refresh.html
new file mode 100644
index 0000000000..8db24b53c5
--- /dev/null
+++ b/collects/web-server/default-web-root/conf/servlet-refresh.html
@@ -0,0 +1,7 @@
+<html>
+<head><title>Servlets Refreshed</title></head>
+<body bgcolor='white'>
+<p>Fresh copies of Servlets will now be (re)loaded from disk.</p>
+<p>Powered by <a href="http://www.plt-scheme.org/">PLT</a></p>
+</body>
+</html>
diff --git a/collects/web-server/default-web-root/htdocs/Defaults/documentation/api.html b/collects/web-server/default-web-root/htdocs/Defaults/documentation/api.html
new file mode 100644
index 0000000000..a5af714237
--- /dev/null
+++ b/collects/web-server/default-web-root/htdocs/Defaults/documentation/api.html
@@ -0,0 +1,4 @@
+<html><head><title>PLT Web Server: Embedding Interface</title></head><body bgcolor="white"><img src="/Defaults/documentation/web-server.gif" width="61" height="57" /><h2>PLT Web Server: Embedding Interface</h2><p>To use the Web server inside another PLT-Scheme program, require the Web server module: <blockquote><code>(require (lib "web-server.ss" "web-server"))</code></blockquote>
+This provides one main function:
+  <blockquote><code>serve : configuration [nat] [str] -&gt; (-&gt; void)<br />(define (serve configuration port ip-address) ...)
+  </code></blockquote>The serve function starts the Web server, just like the launcher does, but the configuration argument supplies the server's settings.  The optional port argument overrides the port supplied by the configuration. The optional ip-address restricts accepted web requests to come only from that address.<p>The result of invoking serve is a function of no arguments that shuts down the server.</p></p><p>Powered by <a href="http://www.plt-scheme.org/"><img width="53" height="19" src="/Defaults/documentation/plt-logo.gif" /></a></p></body></html>
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/htdocs/Defaults/documentation/examples/add.ss b/collects/web-server/default-web-root/htdocs/Defaults/documentation/examples/add.ss
new file mode 100644
index 0000000000..e373c57a20
--- /dev/null
+++ b/collects/web-server/default-web-root/htdocs/Defaults/documentation/examples/add.ss
@@ -0,0 +1,30 @@
+(require (lib "unitsig.ss")
+         (lib "servlet-sig.ss" "web-server")
+         (lib "servlet-helpers.ss" "web-server")
+         (lib "date.ss"))
+
+(unit/sig () (import servlet^)
+  
+  ; request-number : str -> num
+  (define (request-number which-number)
+    (string->number
+     (extract-binding/single
+      'number
+      (request-bindings (send/suspend (build-request-page which-number))))))
+  
+  ; build-request-page : str -> str -> response
+  (define (build-request-page which-number)
+    (lambda (k-url)
+      `(html (head (title "Enter a Number to Add"))
+             (body ([bgcolor "white"])
+                   (form ([action ,k-url] [method "post"])
+                         "Enter the " ,which-number " number to add: "
+                         (input ([type "text"] [name "number"] [value ""]))
+                         (input ([type "submit"] [name "enter"] [value "Enter"])))))))
+  
+  (send/suspend
+   (lambda (k-url)
+     `(html (head (title "Sum"))
+            (body ([bgcolor "white"])
+                  (p "The sum is "
+                     ,(number->string (+ (request-number "first") (request-number "second")))))))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/htdocs/Defaults/documentation/examples/count.ss b/collects/web-server/default-web-root/htdocs/Defaults/documentation/examples/count.ss
new file mode 100644
index 0000000000..b7b00a73f6
--- /dev/null
+++ b/collects/web-server/default-web-root/htdocs/Defaults/documentation/examples/count.ss
@@ -0,0 +1,14 @@
+(require (lib "unitsig.ss")
+         (lib "servlet-sig.ss" "web-server")
+         (lib "date.ss"))
+
+(let ([count 0]
+      [date (date->string (seconds->date (current-seconds)) 'time-too)])
+  (unit/sig () (import servlet^)
+    
+  (set! count (add1 count))
+    
+  `(html (head (title "Counter"))
+         (body ([bgcolor "white"])
+               (p "This servlet was called " ,(number->string count)
+                  " times since loaded on " ,date ".")))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/htdocs/Defaults/documentation/examples/hello.ss b/collects/web-server/default-web-root/htdocs/Defaults/documentation/examples/hello.ss
new file mode 100644
index 0000000000..5c3fb60ea7
--- /dev/null
+++ b/collects/web-server/default-web-root/htdocs/Defaults/documentation/examples/hello.ss
@@ -0,0 +1,10 @@
+(require (lib "unitsig.ss")
+         (lib "servlet-sig.ss" "web-server"))
+
+(unit/sig () (import servlet^)
+  
+  (define the-text "Hello, Web!")
+  
+  `(html (head (title ,the-text))
+         (body ([bgcolor "white"])
+               (p ,the-text))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/htdocs/Defaults/documentation/install.html b/collects/web-server/default-web-root/htdocs/Defaults/documentation/install.html
new file mode 100644
index 0000000000..4ea05bc692
--- /dev/null
+++ b/collects/web-server/default-web-root/htdocs/Defaults/documentation/install.html
@@ -0,0 +1,2 @@
+<html><head><title>PLT Web Server: Installation</title></head><body bgcolor="white"><img src="/Defaults/documentation/web-server.gif" width="61" height="57" /><h2>PLT Web Server: Installation</h2><p>Follow the following simple steps to start using the PLT Web server:</p><dl><dt>1. <b>Install DrScheme</b></dt><dd>The Web server requires <a href="http://www.drscheme.org/">DrScheme</a> or <a href="http://www.plt-scheme.org/software/mzscheme/">MzScheme</a> version 200alpha1 or later.</dd><dt>2. <b>Download the server</b></dt><dd>Choose <u><em>one</em></u> of the following installation options: <ul><li>Click <a href="http://www.ccs.neu.edu/home/ptg/packages/web-server.plt"><code>here</code></a> from within help-desk.</li><li>Choose "Open URL..." from help-desk's "File" menu and
+                enter <a href="http://www.ccs.neu.edu/home/ptg/packages/web-server.plt"><code>http://www.ccs.neu.edu/home/ptg/packages/web-server.plt</code></a></li><li>Download the file using another browser.  Then select "Open" from the "File" menu in help-desk.</li><li>Download the file using another browser and save it as <code>web-server.plt</code>.  Then run <blockquote><code>setup-plt web-server.plt</code></blockquote>This option works with MzScheme as well as with DrScheme.</li></ul></dd><dt>3. <b>Start the server</b></dt><dd>Launch the <code>web-server</code> program created in the same location as the other PLT programs such as DrScheme.<br />The server may need to use a different port, such as 8080, on some systems.  Choose a different port by starting the server with an optional port number:<blockquote><code>web-server 8080</code></blockquote></dd><dt>4. <b>Try it out</b></dt><dd>Direct a Web browser to <blockquote><code>http://localhost/</code></blockquote> or to <blockquote><code>http://localhost:8080/</code></blockquote> depending on the server's port.</dd><dt>5. <b>Configure</b></dt><dd>You may configure your server by following the links on the default index page.  </dd></dl><p>We know you have a choice.  Thank you for choosing PLT software.</p><p>Powered by <a href="http://www.plt-scheme.org/"><img width="53" height="19" src="/Defaults/documentation/plt-logo.gif" /></a></p></body></html>
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/htdocs/Defaults/documentation/monitor.html b/collects/web-server/default-web-root/htdocs/Defaults/documentation/monitor.html
new file mode 100644
index 0000000000..f727a4e6db
--- /dev/null
+++ b/collects/web-server/default-web-root/htdocs/Defaults/documentation/monitor.html
@@ -0,0 +1 @@
+<html><head><title>Web Server Monitoring</title></head><body bgcolor="white"><img src="/Defaults/documentation/web-server.gif" width="61" height="57" /><h2>Web Server Monitoring</h2><p>The Web server collection provides a program for monitoring Web servers. It periodically checks that a server responds to requests.To use the tool, start the <code>web-server-monitor</code> launcher as follows: </p><blockquote><code>web-server-monitor</code> alert-email host-name [port] [poll-frequency-seconds] [server-response-timeout-seconds]</blockquote><p>The monitor will send a HTTP HEAD request to the server at <code>host-name</code> on port <code>port</code> (or 80) every <code>poll-frequency-seconds</code> seconds (or 1 hour).  If the server does not respond within <code>server-response-timeout-seconds</code> (or 75) seconds then the monitor will email <code>alert-email</code> about the problem.  Also, if the Web server responds with an error, the monitor will email the error message to <code>alert-email</code>. For example, the following monitors the Web server for the book ``How to Design Programs''</p><blockquote><code>web-server-monitor ptg www.htdp.org</code></blockquote><p>On UNIX systems, it is usually a good idea to redirect standard in, out, and error to <code>/dev/null</code> so the monitor will not quit due to a <code>SIGHUP</code> (hangup signal) when you log out.  i.e.</p><blockquote><code>web-server-monitor ptg www.htdp.org &gt; /dev/null &lt; /dev/null 2&gt;&amp;1 &amp;</code></blockquote><p>Powered by <a href="http://www.plt-scheme.org/"><img width="53" height="19" src="/Defaults/documentation/plt-logo.gif" /></a></p></body></html>
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/htdocs/Defaults/documentation/plt-logo.gif b/collects/web-server/default-web-root/htdocs/Defaults/documentation/plt-logo.gif
new file mode 100644
index 0000000000..99c0e15928
Binary files /dev/null and b/collects/web-server/default-web-root/htdocs/Defaults/documentation/plt-logo.gif differ
diff --git a/collects/web-server/default-web-root/htdocs/Defaults/documentation/servlet-examples.html b/collects/web-server/default-web-root/htdocs/Defaults/documentation/servlet-examples.html
new file mode 100644
index 0000000000..1aab0d245c
--- /dev/null
+++ b/collects/web-server/default-web-root/htdocs/Defaults/documentation/servlet-examples.html
@@ -0,0 +1 @@
+<html><head><title>PLT Servlet Examples</title></head><body bgcolor="white"><img src="/Defaults/documentation/web-server.gif" width="61" height="57" /><h2>PLT Servlet Examples</h2><p>The table below links to small example servlets.<br />The configuration tool is a larger example.<br />The `go' links only work when served from the PLT Web server.</p><table><tr><th>Source Code</th><th>Evaluate</th></tr><tr><td><a href="examples/add.ss">add.ss</a></td><td><a href="/servlets/examples/add.ss">go</a></td></tr><tr><td><a href="examples/count.ss">count.ss</a></td><td><a href="/servlets/examples/count.ss">go</a></td></tr><tr><td><a href="examples/hello.ss">hello.ss</a></td><td><a href="/servlets/examples/hello.ss">go</a></td></tr></table><p>Powered by <a href="http://www.plt-scheme.org/"><img width="53" height="19" src="/Defaults/documentation/plt-logo.gif" /></a></p></body></html>
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/htdocs/Defaults/documentation/servlet.html b/collects/web-server/default-web-root/htdocs/Defaults/documentation/servlet.html
new file mode 100644
index 0000000000..4793a760db
--- /dev/null
+++ b/collects/web-server/default-web-root/htdocs/Defaults/documentation/servlet.html
@@ -0,0 +1,30 @@
+<html><head><title>PLT Web Server: Servlet Interface</title></head><body bgcolor="white"><img src="/Defaults/documentation/web-server.gif" width="61" height="57" /><h2>PLT Web Server: Servlet Interface</h2><p>Instead of serving files from a special directory verbatim, the Web server executes the contained Scheme code and serves the output.  By default, the special directory  is named "servlets" within the "default-web-root" of the "web-server" collection directory.  Each file in that directory must evaluate to a servlet.
+A servlet is a <code>unit/sig</code> that imports the <code>servlet^</code>
+signature and exports nothing.  (Search in <code>help-desk</code> for more information on <code>unit/sig</code> and on signatures.)  To construct a <code>unit/sig</code> with the appropriate imports, the servlet must require the two modules providing<code>unit/sig</code>s and the <code>servlet^</code> signature:</p><blockquote><code><pre>
+(require (lib "unitsig.ss")
+         (lib "servlet-sig.ss" "web-server"))
+(unit/sig ()
+  (import servlet^)
+</pre>&nbsp;&nbsp;...insert servlet code here...<code>)</code></code></blockquote><p>The last value in the <code>unit/sig</code> must be a <em>response</em> to an HTTP request.</p><p>A <code>Response</code> is one of the following:
+</p><ul><li>an <code>X-expression</code> representing HTML <br />
+    (Search for XML in <code>help-desk</code>.)</li><li>a <code>(listof string)</code> where
+<ul><li>The first string is the mime type (often "text/html", but see <a href="http://www.cis.ohio-state.edu/cgi-bin/rfc/rfc2822.html">RFC 2822</a> for other options).The rest of the strings provide the document's content.</li></ul></li><li><code>(make-response/full</code> code message seconds mime extras body<code>)</code> where 
+<ul><li>code is a natural number indicating the HTTP response code</li><li>message is a string describing the code to a human</li><li>seconds is a natural number indicating the time the resource was
+    created.  Use (current-seconds) for dynamically created responses.</li><li>mime is a string indicating the response type.</li><li>extras is a <code>(listof (cons symbol string))</code> containing extra headers for redirects, authentication, or cookies.</li><li>body is a <code>(listof string)</code></li></ul></li></ul><p>Evaluating <code>(require (lib "servlet-sig.ss" "web-server"))</code> loads
+the <code>servlet^</code> signature consisting of the following imports:</p><ul><li>initial-request : <code>request</code>, where a request is <br /><code>(make-request method uri headers bindings host-ip client-ip)</code>, where
+<ul><li> method : <code>(Union 'get 'post)</code></li><li> uri : <code>URL</code> <br />
+  see the <code>net</code> collection in <code>help-desk</code> for details</li><li> headers : <code>(listof (cons symbol string))</code> <br />
+  optional HTTP headers for this request</li><li> bindings : <code>(listof (cons symbol string))</code> <br />
+  name value pairs from the form submitted or the query part of the URL.</li></ul></li></ul><p>The <code>path</code> part of the URL suplies the file path to the servlet relative to the "servlets" directory.  However, paths may also contain extra path components that servlets may use as additional input.  For example all of the following URLs refer to the same servlet: <ul><li><code>http://www.plt-scheme.org/servlets/my-servlet</code></li><li><code>http://www.plt-scheme.org/servlets/my-servlet/extra</code></li><li><code>http://www.plt-scheme.org/servlets/my-servlet/extra/directories</code></li></ul></p><p>The above imports support handling a single input from a Web form. To ease the development of more interactive servlets, the <code>servlet^</code> signature also provides the following functions:
+</p><ul><li><code>send/suspend : (str -&gt; Response) -&gt; request</code></li></ul>The argument, a function that consumes a string, is given a <code>URL</code> that can be used in the document.  The argument function must produce a
+  response corresponding to the document's body.  Requests to the
+  given <code>URL</code> resume the computation at the point
+  <code>send/suspend</code> was invoked.  Thus, the argument function normally
+  produces an HTML form with the "action" attribute set to the provided
+  <code>URL</code>.  The result of <code>send/suspend</code> represents the
+  next request.
+
+<ul><li><code>send/finish : Response -&gt;</code> doesn't return <br />This provides a convenient way to report an error or otherwise produce a final response.  Once called, all URLs generated by send/suspend become invalid.  Calling send/finish allows the system to reclaim resources consumed by the servlet.</li><li><code>adjust-timeout! : Nat -&gt; Void</code><br />
+ The server will shutdown each instance of a servlet after an unspecified default amount of time since the last time that servlet instance handled a request.  Calling adjust-timeout! allows programmers to choose this number of seconds.  Larger numbers consume more resources
+  while smaller numbers force servlet users to restart computations more often.
+</li></ul><p>The <code>servlet-helpers</code> module, required with <blockquote><code>(require (lib "servlet-helpers.ss" "web-server"))</code></blockquote> provides a few additional functions helpful for constructing servlets: <ul><li><code>extract-binding/single : sym (listof (cons sym str)) -&gt; str</code>This extracts a single value associated with sym in the form bindings. If multiple or zero values are associated with the name, it raises an exception.</li><li>extract-bindings : sym (listof (cons sym str)) -&gt; (listof str)returns a list of values assocaited with the name sym.</li><li><code>extract-user-pass : (listof (cons sym str)) -&gt; (U #f (cons str str))</code><br /><code>(define (extract-user-pass headers) ...)</code>Servlets may easily implement password based authentication by extracting password information from the HTTP headers.  The return value is either a pair consisting of the username and password from the headers or #f if no password was provided.</li></ul></p><h3>Special URLs</h3><p>The Web server caches passwords and servlets for performance reasons. Requesting the URL<blockquote><a href="/conf/refresh-passwords"><code>http://my-host/conf/refresh-passwords</code></a></blockquote>reloads the password file.  After updating a servlet, loading the URL <blockquote><a href="/conf/refresh-servlets"><code>http://my-host/conf/refresh-servlets</code></a></blockquote>causes the server to reload each servlet on the next invocation. This loses any per-servlet state (not per servlet instance state) computed before the unit invocation.</p><p><a href="servlet-examples.html">Examples of Servlets</a></p><p>Powered by <a href="http://www.plt-scheme.org/"><img width="53" height="19" src="/Defaults/documentation/plt-logo.gif" /></a></p></body></html>
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/password-refresh-message.html b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/password-refresh-message.html
new file mode 100644
index 0000000000..d25a03a516
--- /dev/null
+++ b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/password-refresh-message.html
@@ -0,0 +1 @@
+<html><head><title>Configuration Explanation</title></head><body bgcolor="white"><img src="/Defaults/documentation/web-server.gif" width="61" height="57" /><dl><dt><a name="password-refresh-message"><b>Password cache refreshed</b></a></dt><dd>To update the password cache, visit the URL <blockquote><a href="/conf/refresh-passwords"><code>http://</code>your-host<code>/conf/refresh-passwords</code></a></blockquote>Doing so updates the password cache and displays the <em>password cache refreshed</em> page.</dd></dl><p>Powered by <a href="http://www.plt-scheme.org/"><img width="53" height="19" src="/Defaults/documentation/plt-logo.gif" /></a></p></body></html>
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/path-access-message.html b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/path-access-message.html
new file mode 100644
index 0000000000..7f54199313
--- /dev/null
+++ b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/path-access-message.html
@@ -0,0 +1 @@
+<html><head><title>Configuration Explanation</title></head><body bgcolor="white"><img src="/Defaults/documentation/web-server.gif" width="61" height="57" /><dl><dt><a name="path-access-message"><b>Access Denied</b></a></dt><dd>Failed attempts to access a password protected page cause the Web server to produce the contents of the <em>Access Denied</em> page.</dd></dl><p>Powered by <a href="http://www.plt-scheme.org/"><img width="53" height="19" src="/Defaults/documentation/plt-logo.gif" /></a></p></body></html>
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/path-host-root.html b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/path-host-root.html
new file mode 100644
index 0000000000..15b90acd4b
--- /dev/null
+++ b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/path-host-root.html
@@ -0,0 +1 @@
+<html><head><title>Configuration Explanation</title></head><body bgcolor="white"><img src="/Defaults/documentation/web-server.gif" width="61" height="57" /><dl><dt><a name="path-host-root"><b>Host root</b></a></dt><dd>All the configuration files for a host reside in the <em>Host root</em> or its subdirectories.</dd></dl><p>Powered by <a href="http://www.plt-scheme.org/"><img width="53" height="19" src="/Defaults/documentation/plt-logo.gif" /></a></p></body></html>
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/path-htdocs.html b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/path-htdocs.html
new file mode 100644
index 0000000000..21ea89a158
--- /dev/null
+++ b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/path-htdocs.html
@@ -0,0 +1 @@
+<html><head><title>Configuration Explanation</title></head><body bgcolor="white"><img src="/Defaults/documentation/web-server.gif" width="61" height="57" /><dl><dt><a name="path-htdocs"><b>Web document root</b></a></dt><dd>Files containing HTML pages, pictures, or other Web media come from this directory.<br />The URL referring to a file `my-web-page.html' immediately inside the <em>Web document root</em> is <blockquote><code>http://this-host-name/my-web-page.html</code></blockquote></dd></dl><p>Powered by <a href="http://www.plt-scheme.org/"><img width="53" height="19" src="/Defaults/documentation/plt-logo.gif" /></a></p></body></html>
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/path-log.html b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/path-log.html
new file mode 100644
index 0000000000..61683deaee
--- /dev/null
+++ b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/path-log.html
@@ -0,0 +1 @@
+<html><head><title>Configuration Explanation</title></head><body bgcolor="white"><img src="/Defaults/documentation/web-server.gif" width="61" height="57" /><dl><dt><a name="path-log"><b>Log file</b></a></dt><dd>The server stores messages into the <em>Log file</em>.</dd></dl><p>Powered by <a href="http://www.plt-scheme.org/"><img width="53" height="19" src="/Defaults/documentation/plt-logo.gif" /></a></p></body></html>
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/path-message-root.html b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/path-message-root.html
new file mode 100644
index 0000000000..6ce299f9ed
--- /dev/null
+++ b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/path-message-root.html
@@ -0,0 +1 @@
+<html><head><title>Configuration Explanation</title></head><body bgcolor="white"><img src="/Defaults/documentation/web-server.gif" width="61" height="57" /><dl><dt><a name="path-message-root"><b>Message root</b></a></dt><dd>This directory contains messages sent to the user.  See the other path settings for details.</dd></dl><p>Powered by <a href="http://www.plt-scheme.org/"><img width="53" height="19" src="/Defaults/documentation/plt-logo.gif" /></a></p></body></html>
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/path-not-found-message.html b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/path-not-found-message.html
new file mode 100644
index 0000000000..40a0d60274
--- /dev/null
+++ b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/path-not-found-message.html
@@ -0,0 +1 @@
+<html><head><title>Configuration Explanation</title></head><body bgcolor="white"><img src="/Defaults/documentation/web-server.gif" width="61" height="57" /><dl><dt><a name="path-not-found-message"><b>File not found</b></a></dt><dd>When a file or servlet is not found on the server, the server uses the message from the <em>File not found</em> page.</dd></dl><p>Powered by <a href="http://www.plt-scheme.org/"><img width="53" height="19" src="/Defaults/documentation/plt-logo.gif" /></a></p></body></html>
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/path-password.html b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/path-password.html
new file mode 100644
index 0000000000..e486165560
--- /dev/null
+++ b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/path-password.html
@@ -0,0 +1 @@
+<html><head><title>Configuration Explanation</title></head><body bgcolor="white"><img src="/Defaults/documentation/web-server.gif" width="61" height="57" /><dl><dt><a name="path-password"><b>Password File</b></a></dt><dd>To restrict access to files in the <a href="path-htdocs.html">Web document root</a> provide the path to a password file.</dd></dl><p>Powered by <a href="http://www.plt-scheme.org/"><img width="53" height="19" src="/Defaults/documentation/plt-logo.gif" /></a></p></body></html>
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/path-protocol-message.html b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/path-protocol-message.html
new file mode 100644
index 0000000000..099f5f44c6
--- /dev/null
+++ b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/path-protocol-message.html
@@ -0,0 +1 @@
+<html><head><title>Configuration Explanation</title></head><body bgcolor="white"><img src="/Defaults/documentation/web-server.gif" width="61" height="57" /><dl><dt><a name="path-protocol-message"><b>Protocol error</b></a></dt><dd>When a browser violates the HTTP protocol, confusing the server, the <em>protocol error</em> message may appear.  It should never appear when interacting with the server through a properly functioning Web browser.Depending on the error, the server may close the connection instead.</dd></dl><p>Powered by <a href="http://www.plt-scheme.org/"><img width="53" height="19" src="/Defaults/documentation/plt-logo.gif" /></a></p></body></html>
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/path-servlet-message.html b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/path-servlet-message.html
new file mode 100644
index 0000000000..f2f73cc35a
--- /dev/null
+++ b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/path-servlet-message.html
@@ -0,0 +1 @@
+<html><head><title>Configuration Explanation</title></head><body bgcolor="white"><img src="/Defaults/documentation/web-server.gif" width="61" height="57" /><dl><dt><a name="path-servlet-message"><b>Servlet error</b></a></dt><dd>When a servlet raises an uncaught exception, the server provides an error message starting with a description of the specific error and ending with the contents of the <em>servlet error</em> page.</dd></dl><p>Powered by <a href="http://www.plt-scheme.org/"><img width="53" height="19" src="/Defaults/documentation/plt-logo.gif" /></a></p></body></html>
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/path-servlet.html b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/path-servlet.html
new file mode 100644
index 0000000000..f0e3ec5b4c
--- /dev/null
+++ b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/path-servlet.html
@@ -0,0 +1 @@
+<html><head><title>Configuration Explanation</title></head><body bgcolor="white"><img src="/Defaults/documentation/web-server.gif" width="61" height="57" /><dl><dt><a name="path-servlet"><b>Servlet root</b></a></dt><dd>Instead of serving out files contained in the <em>Servlet root</em> directory verbatim, the Web server executes them as <a href="/Defaults/documentation/servlet.html">Scheme servlets</a></dd></dl><p>Powered by <a href="http://www.plt-scheme.org/"><img width="53" height="19" src="/Defaults/documentation/plt-logo.gif" /></a></p></body></html>
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/port.html b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/port.html
new file mode 100644
index 0000000000..9e3610ec1f
--- /dev/null
+++ b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/port.html
@@ -0,0 +1 @@
+<html><head><title>Configuration Explanation</title></head><body bgcolor="white"><img src="/Defaults/documentation/web-server.gif" width="61" height="57" /><dl><dt><a name="port"><b>Port</b></a></dt><dd>The Web server waits for requests to arrive on this <em>port</em>. The port appears in some URLs after the host name. i.e. 8080 in <blockquote><code>http://www.ccs.neu.edu:8080/home/ptg/file.html</code></blockquote> HTTP specifies that 80 is the default port.</dd></dl><p>Powered by <a href="http://www.plt-scheme.org/"><img width="53" height="19" src="/Defaults/documentation/plt-logo.gif" /></a></p></body></html>
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/realm-name.html b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/realm-name.html
new file mode 100644
index 0000000000..10197e4405
--- /dev/null
+++ b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/realm-name.html
@@ -0,0 +1 @@
+<html><head><title>Configuration Explanation</title></head><body bgcolor="white"><img src="/Defaults/documentation/web-server.gif" width="61" height="57" /><dl><dt><a name="realm-name"><b>Realm Name</b></a></dt><dd>Realm Name appears in the dialog box that prompts for a username and password.<br />It indicates which username and password the server requires.</dd></dl><p>Powered by <a href="http://www.plt-scheme.org/"><img width="53" height="19" src="/Defaults/documentation/plt-logo.gif" /></a></p></body></html>
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/realm-pattern.html b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/realm-pattern.html
new file mode 100644
index 0000000000..459ea6fd43
--- /dev/null
+++ b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/realm-pattern.html
@@ -0,0 +1 @@
+<html><head><title>Configuration Explanation</title></head><body bgcolor="white"><img src="/Defaults/documentation/web-server.gif" width="61" height="57" /><dl><dt><a name="realm-pattern"><b>Realm URL Path Pattern</b></a></dt><dd>If the path part of a requested URL matches the pattern, then the server requests a username and password.  For details on pattern syntax, search for <code>regexp</code> in <code>help-desk</code>.</dd></dl><p>Powered by <a href="http://www.plt-scheme.org/"><img width="53" height="19" src="/Defaults/documentation/plt-logo.gif" /></a></p></body></html>
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/servlet-refresh-message.html b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/servlet-refresh-message.html
new file mode 100644
index 0000000000..ea0de6d77b
--- /dev/null
+++ b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/servlet-refresh-message.html
@@ -0,0 +1 @@
+<html><head><title>Configuration Explanation</title></head><body bgcolor="white"><img src="/Defaults/documentation/web-server.gif" width="61" height="57" /><dl><dt><a name="servlet-refresh-message"><b>Servlet cache refreshed</b></a></dt><dd><p>The Web server caches servlets (not the output of servlets).  When developers update servlets, they must visit the URL <blockquote><a href="/conf/refresh-servlets"><code>http://</code>your-host<code>/conf/refresh-servlets</code></a></blockquote>to refresh the cache.  When they do, they see the message from the <em>servlet cache refreshed</em> file.</p><p>Refreshing servlets does not affect currently running servlets, including suspended ones.Only servlets started from the beginning will execute the updated code.</p></dd></dl><p>Powered by <a href="http://www.plt-scheme.org/"><img width="53" height="19" src="/Defaults/documentation/plt-logo.gif" /></a></p></body></html>
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/time-default-servlet.html b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/time-default-servlet.html
new file mode 100644
index 0000000000..58fcc4ef57
--- /dev/null
+++ b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/time-default-servlet.html
@@ -0,0 +1 @@
+<html><head><title>Configuration Explanation</title></head><body bgcolor="white"><img src="/Defaults/documentation/web-server.gif" width="61" height="57" /><dl><dt><a name="time-default-servlet"><b>Default Servlet Timeout Seconds</b></a></dt><dd>This value determines how long a servlet can wait in between requests before shutting down, unless the servlet calls <code>adjust-timeout!</code> to alter this value. Large values consume more memory, while smaller values annoy end users who must restart servlets.</dd></dl><p>Powered by <a href="http://www.plt-scheme.org/"><img width="53" height="19" src="/Defaults/documentation/plt-logo.gif" /></a></p></body></html>
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/time-file-base.html b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/time-file-base.html
new file mode 100644
index 0000000000..2d128453a9
--- /dev/null
+++ b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/time-file-base.html
@@ -0,0 +1 @@
+<html><head><title>Configuration Explanation</title></head><body bgcolor="white"><img src="/Defaults/documentation/web-server.gif" width="61" height="57" /><dl><dt><a name="time-file-base"><b>Base When Transferring Files</b></a></dt><dd>The total number of seconds the server has to send a file is the sum of <em>Base When Transferring Files</em> and the product of <a href="time-file-per-byte.html">per Byte When Transferring Files</a> and the number of bytes in the file.</dd></dl><p>Powered by <a href="http://www.plt-scheme.org/"><img width="53" height="19" src="/Defaults/documentation/plt-logo.gif" /></a></p></body></html>
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/time-file-per-byte.html b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/time-file-per-byte.html
new file mode 100644
index 0000000000..b48df6b4e2
--- /dev/null
+++ b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/time-file-per-byte.html
@@ -0,0 +1 @@
+<html><head><title>Configuration Explanation</title></head><body bgcolor="white"><img src="/Defaults/documentation/web-server.gif" width="61" height="57" /><dl><dt><a name="time-file-per-byte"><b>per Byte When Transferring Files</b></a></dt><dd>The total number of seconds the server has to send a file is the sum of <a href="time-file-base.html">Base When Transferring Files</a> and the product of <em>per Byte When Transferring Files</em> and the number of bytes in the file.</dd></dl><p>Powered by <a href="http://www.plt-scheme.org/"><img width="53" height="19" src="/Defaults/documentation/plt-logo.gif" /></a></p></body></html>
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/time-initial.html b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/time-initial.html
new file mode 100644
index 0000000000..40aa41fb1c
--- /dev/null
+++ b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/time-initial.html
@@ -0,0 +1 @@
+<html><head><title>Configuration Explanation</title></head><body bgcolor="white"><img src="/Defaults/documentation/web-server.gif" width="61" height="57" /><dl><dt><a name="time-initial"><b>Initial Connection Timeout</b></a></dt><dd>After a client connects to the Web server, the server only waits for an HTTP request for this many seconds before closing the connection. Browsers tend to send requests immediately, so a small number will do. Choosing a truely enormous number could cause problems. When a computer crashes or its network connection fails due to an external cause, it fails to ask the Web server to reclaim the connection. If about a thousand of these hung connections accumulate without timing out, the Web server can not accept new legitimate connections.</dd></dl><p>Powered by <a href="http://www.plt-scheme.org/"><img width="53" height="19" src="/Defaults/documentation/plt-logo.gif" /></a></p></body></html>
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/time-password.html b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/time-password.html
new file mode 100644
index 0000000000..7c10aa972f
--- /dev/null
+++ b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/time-password.html
@@ -0,0 +1 @@
+<html><head><title>Configuration Explanation</title></head><body bgcolor="white"><img src="/Defaults/documentation/web-server.gif" width="61" height="57" /><dl><dt><a name="time-password"><b>Password Timeout Seconds</b></a></dt><dd>This is the number of seconds a user has to enter a username and password. Some users may need a while to remember (or look for) this information.</dd></dl><p>Powered by <a href="http://www.plt-scheme.org/"><img width="53" height="19" src="/Defaults/documentation/plt-logo.gif" /></a></p></body></html>
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/time-servlet-connection.html b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/time-servlet-connection.html
new file mode 100644
index 0000000000..82598878d4
--- /dev/null
+++ b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/time-servlet-connection.html
@@ -0,0 +1 @@
+<html><head><title>Configuration Explanation</title></head><body bgcolor="white"><img src="/Defaults/documentation/web-server.gif" width="61" height="57" /><dl><dt><a name="time-servlet-connection"><b>Servlet Connection Timeout Seconds</b></a></dt><dd>This is the number of seconds a servlet has to respond to a single request. Some servlets may perform substantial computation on a loaded server before generating a page. On the other hand, most users will not wait very long for a response.</dd></dl><p>Powered by <a href="http://www.plt-scheme.org/"><img width="53" height="19" src="/Defaults/documentation/plt-logo.gif" /></a></p></body></html>
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/waiting.html b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/waiting.html
new file mode 100644
index 0000000000..cb7f91ffeb
--- /dev/null
+++ b/collects/web-server/default-web-root/htdocs/Defaults/documentation/terms/waiting.html
@@ -0,0 +1 @@
+<html><head><title>Configuration Explanation</title></head><body bgcolor="white"><img src="/Defaults/documentation/web-server.gif" width="61" height="57" /><dl><dt><a name="waiting"><b>Maximum Waiting Connections</b></a></dt><dd>This is the maximum number of clients that can wait for a TCP/IP connection to the Web server.  This limit usually does not cause problems because the Web server quickly accepts connections as requested and there is no limit on the number of simultaneous connections.  On some platforms, choosing a large number may consume too many resources.</dd></dl><p>Powered by <a href="http://www.plt-scheme.org/"><img width="53" height="19" src="/Defaults/documentation/plt-logo.gif" /></a></p></body></html>
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/htdocs/Defaults/documentation/web-server.gif b/collects/web-server/default-web-root/htdocs/Defaults/documentation/web-server.gif
new file mode 100644
index 0000000000..261ad1ceeb
Binary files /dev/null and b/collects/web-server/default-web-root/htdocs/Defaults/documentation/web-server.gif differ
diff --git a/collects/web-server/default-web-root/htdocs/Defaults/index.html b/collects/web-server/default-web-root/htdocs/Defaults/index.html
new file mode 100644
index 0000000000..0e8f96d681
--- /dev/null
+++ b/collects/web-server/default-web-root/htdocs/Defaults/index.html
@@ -0,0 +1,2 @@
+<html><head><title>Welcome to the PLT Web Server!</title></head><body bgcolor="white"><img src="/Defaults/documentation/web-server.gif" width="61" height="57" /><h2>Welcome to the PLT Web Server!</h2><p>To start using the Web Server, follow these steps:</p><dl><dt><b><a href="documentation/install.html">Installation</a></b></dt><dd>You can skip the install instructions if you are reading this through the PLT Web server.<p /></dd><dt><b><a href="/servlets/configure.ss">Customization</a></b></dt><dd>Use the online configuration tool to customize the server.<p /></dd><dt><b><a href="documentation/servlet.html">Servlet Interface</a></b></dt><dd>Learn how to write Scheme Servlets.<p /></dd><dt><b><a href="documentation/api.html">Embedding Interface</a></b></dt><dd>Embed the Web server in other applications.<p /></dd><dt><b><a href="documentation/monitor.html">Monitoring</a></b></dt><dd>Periodically check that Web servers continue to function.<p /></dd></dl><p>If you use the PLT Web server, please let us know at
+   <a href="mailto:ptg@acm.org"><code>ptg@acm.org</code></a>.</p><p>Powered by <a href="http://www.plt-scheme.org/"><img width="53" height="19" src="/Defaults/documentation/plt-logo.gif" /></a></p></body></html>
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/htdocs/index.html b/collects/web-server/default-web-root/htdocs/index.html
new file mode 100644
index 0000000000..5e187ce3c6
--- /dev/null
+++ b/collects/web-server/default-web-root/htdocs/index.html
@@ -0,0 +1,40 @@
+<html>
+ <head>
+   <title>Welcome to the PLT Web server!</title>
+ </head>
+
+ <body bgcolor="white">
+ <img src="/Defaults/documentation/web-server.gif" width="61" height="57" />
+
+<blockquote>
+
+<table width="66%" bgcolor="white">
+<tr><td>
+  <h2>Welcome to the PLT Web Server</h2>
+
+  <p>
+    Find out more about <a href='/Defaults/'>the server and configure</a> it.
+  </p>
+
+  <p>Please replace this page with your favorite index page. 
+  <br />For future configuration changes, remember to look up
+  <br />
+<center>
+   <code> http://127.0.0.1:<em>port</em>/Defaults/ </code>
+</center>
+
+  <p>Powered by 
+  <a href="http://www.plt-scheme.org/">
+   <img width="53" height="19" src="/Defaults/documentation/plt-logo.gif" />
+   </a>
+  <p><font size="-2">
+  For more information on PLT Software, please follow the icon link.
+  </font>
+  </p>
+  </p>
+</table>
+
+</blockquote>
+
+ </body>
+</html>
diff --git a/collects/web-server/default-web-root/htdocs/secret/index.html b/collects/web-server/default-web-root/htdocs/secret/index.html
new file mode 100644
index 0000000000..1eb484cb30
--- /dev/null
+++ b/collects/web-server/default-web-root/htdocs/secret/index.html
@@ -0,0 +1,8 @@
+<html>
+<head><title>Home</title></head>
+<body>
+<p>
+Hi.
+</p>
+</body>
+</html>
diff --git a/collects/web-server/default-web-root/passwords b/collects/web-server/default-web-root/passwords
new file mode 100644
index 0000000000..c6ca1020c9
--- /dev/null
+++ b/collects/web-server/default-web-root/passwords
@@ -0,0 +1 @@
+'(("secret stuff" "/secret(/.*)?" (bubba "bbq") (|Billy| "BoB")))
diff --git a/collects/web-server/default-web-root/servlets/configure.ss b/collects/web-server/default-web-root/servlets/configure.ss
new file mode 100644
index 0000000000..a62aea6ff3
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/configure.ss
@@ -0,0 +1,8 @@
+; DO NOT DELETE THIS SERVLET,
+; unless you never want to reconfigure the Web server again.
+; The servlet accepts requests only from the *same machine* as the Web server
+; for security purposes.
+
+(require (lib "configure.ss" "web-server"))
+
+servlet
diff --git a/collects/web-server/default-web-root/servlets/examples/README b/collects/web-server/default-web-root/servlets/examples/README
new file mode 100644
index 0000000000..688ba3f08a
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/examples/README
@@ -0,0 +1,20 @@
+This directory contains several examples of PLT-Scheme servlets.
+
+hello.ss
+  The hello servlet demonstrates how a minimal servlet can provide 
+  functionality similar to server-side includes.
+
+count.ss
+  The count servlet shows how a servlet can maintain state between invocations.
+  The state is reset when the cache of loaded servlets is refreshed.
+
+add.ss
+  The add servlet uses send/suspend to interact with the user multiple times.
+
+quiz.ss english-measure-questions.ss
+  The quiz servlet demonstrates how to implement a web-based multiple choice
+  quiz. A big thank you to Don Felgar for providing this sample.
+
+
+To construct a multi-unit servlet that combines code from several files,
+see the subdirectory "compound".
diff --git a/collects/web-server/default-web-root/servlets/examples/add.ss b/collects/web-server/default-web-root/servlets/examples/add.ss
new file mode 100644
index 0000000000..8c797dc131
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/examples/add.ss
@@ -0,0 +1,27 @@
+(require (lib "unitsig.ss")
+         (lib "servlet-sig.ss" "web-server")
+         (lib "date.ss"))
+
+(unit/sig () (import servlet^)
+
+  ; request-number : str -> num
+  (define (request-number which-number)
+    (string->number
+     (extract-binding/single
+      'number
+      (request-bindings (send/suspend (build-request-page which-number))))))
+
+  ; build-request-page : str -> str -> response
+  (define (build-request-page which-number)
+    (lambda (k-url)
+      `(html (head (title "Enter a Number to Add"))
+             (body ([bgcolor "white"])
+                   (form ([action ,k-url] [method "post"])
+                         "Enter the " ,which-number " number to add: "
+                         (input ([type "text"] [name "number"] [value ""]))
+                         (input ([type "submit"] [name "enter"] [value "Enter"])))))))
+
+  `(html (head (title "Sum"))
+         (body ([bgcolor "white"])
+               (p "The sum is "
+                  ,(number->string (+ (request-number "first") (request-number "second")))))))
diff --git a/collects/web-server/default-web-root/servlets/examples/compound/README b/collects/web-server/default-web-root/servlets/examples/compound/README
new file mode 100644
index 0000000000..bf9cf26d6e
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/examples/compound/README
@@ -0,0 +1,19 @@
+To build libraries that use send/suspend, the library code must reside inside
+a unit that imports send/suspend.  Servlets that use the library must
+link the main servlet with the code from the library using a compound-unit.
+
+helper.ss
+  This file provides the function _get-number_ that uses send/suspend
+  to interact with the consumer.
+  
+helper-sig.ss
+  This file provides a unit signature required for linking to the helper
+  library.
+
+add.ss
+  The add servlet links to the helper unit and calls get-number.
+
+multiply.ss
+  The multiply servlet also uses the helper library.
+
+
diff --git a/collects/web-server/default-web-root/servlets/examples/compound/add.ss b/collects/web-server/default-web-root/servlets/examples/compound/add.ss
new file mode 100644
index 0000000000..46b447a22a
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/examples/compound/add.ss
@@ -0,0 +1,20 @@
+(require (lib "unitsig.ss")
+         (lib "servlet-sig.ss" "web-server")
+         "helper-sig.ss")
+
+(define main@
+  (unit/sig ()
+    (import servlet^ my-servlet-helpers^)
+    
+    `(html (head (title "Sum"))
+           (body ([bgcolor "white"])
+                 (p "The sum is "
+                    ,(number->string (+ (get-number "the first number to add")
+                                        (get-number "the second number to add"))))))))
+
+(compound-unit/sig
+  (import (S : servlet^))
+  (link
+   [H : my-servlet-helpers^ ((load-relative "helper.ss") S)]
+   [M : () (main@ S H)])
+  (export (open M)))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/examples/compound/helper-sig.ss b/collects/web-server/default-web-root/servlets/examples/compound/helper-sig.ss
new file mode 100644
index 0000000000..24311dda73
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/examples/compound/helper-sig.ss
@@ -0,0 +1,5 @@
+(module helper-sig mzscheme
+  (provide my-servlet-helpers^)
+  (require (lib "unitsig.ss"))
+  
+  (define-signature my-servlet-helpers^ (get-number)))
diff --git a/collects/web-server/default-web-root/servlets/examples/compound/helper.ss b/collects/web-server/default-web-root/servlets/examples/compound/helper.ss
new file mode 100644
index 0000000000..4c4138ccd4
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/examples/compound/helper.ss
@@ -0,0 +1,26 @@
+(require (lib "xml.ss" "xml")
+         (lib "unitsig.ss")
+         (lib "servlet-sig.ss" "web-server")
+         (lib "servlet-helpers.ss" "web-server")
+         "helper-sig.ss")
+
+(unit/sig my-servlet-helpers^
+  (import servlet^)
+  
+  ; get-number : string -> number
+  ; to prompt the user for a number
+  (define (get-number which-number)
+    (let ask ([error-message null])
+      (let* ([n-str
+              (extract-binding/single
+               'n
+               (request-bindings
+                (send/suspend
+                 (let ([prompt (string-append "Enter " which-number ": ")])
+                   (build-suspender
+                    (list prompt)
+                    `(,@error-message
+                      (p ,prompt (input ([type "text"] [name "n"])))
+                      (input ([type "submit"] [value "Okay"]))))))))]
+             [n (string->number n-str)])
+        (or n (ask `((p (font ([color "red"]) ,n-str) " is not a number.  Please enter a number."))))))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/examples/compound/multiply.ss b/collects/web-server/default-web-root/servlets/examples/compound/multiply.ss
new file mode 100644
index 0000000000..9d925430dd
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/examples/compound/multiply.ss
@@ -0,0 +1,95 @@
+(require (lib "servlet-sig.ss" "web-server")
+         (lib "servlet-helpers.ss" "web-server")
+         (lib "unitsig.ss")
+         (lib "etc.ss")
+         "helper-sig.ss")
+
+(define multiply@
+  (unit/sig ()
+    (import servlet^ my-servlet-helpers^)
+    
+    ; matrix = (listof (listof num))
+    
+    ; matrix-multiply : matrix matrix -> matrix
+    (define (matrix-multiply a b)
+      (map (lambda (a-row)
+             (side-map (lambda (b-column)
+                         (apply + (map * a-row b-column)))
+                       b))
+           a))
+    
+    ; side-map : ((listof a) -> b) (listof (listof a)) -> (listof b)
+    (define (side-map f m)
+      (cond
+        [(null? (car m)) null]
+        [else (cons (f (map car m))
+                    (side-map f (map cdr m)))]))
+    
+    ; ---
+    
+    ; get-dimentions : -> nat nat
+    ; to ask for and return the number of rows and columns
+    (define (get-dimentions)
+      (values
+       (get-number "the number of rows in the first matrix")
+       (get-number "the number of rows in the second matrix")))
+    
+    ; get-matrix : nat nat -> matrix
+    (define (get-matrix rows columns)
+      (let ([b (get-matrix-bindings rows columns)])
+        (build-list
+         rows
+         (lambda (r)
+           (build-list
+            columns
+            (lambda (c)
+              (string->number (extract-binding/single (string->symbol (field-name r c)) b))))))))
+    
+    ; get-matrix-bindings : nat nat -> (listof (cons sym str))
+    (define (get-matrix-bindings rows columns)
+      (request-bindings
+       (send/suspend
+        (build-suspender
+         (list "Enter a " (number->string rows) " by "
+               (number->string columns) " Matrix")
+         `((table
+            . ,(build-list
+                rows
+                (lambda (r)
+                  `(tr . ,(build-list
+                           columns
+                           (lambda (c)
+                             `(td (input ([type "text"] [name ,(field-name r c)])))))))))
+           (input ([type "submit"] [name "submit"] [value "Okay"])))))))
+    
+    ; field-name : nat nat -> str
+    (define (field-name row column)
+      (format "x-~a-~a" row column))
+    
+    ; ---
+    
+    ; render-matrix : matrix -> html
+    (define (render-matrix m)
+      `(table
+        ([border "1"])
+        . ,(map (lambda (row)
+                  `(tr . ,(map (lambda (n)
+                                 `(td ,(number->string n)))
+                               row)))
+                m)))
+    
+    ; main
+    `(html (head (title "Matrix Product"))
+           (body
+            (p "The matrix product is"
+               ,(render-matrix
+                 (let-values ([(r c) (get-dimentions)])
+                   (matrix-multiply (get-matrix r c)
+                                    (get-matrix c r)))))))))
+
+(compound-unit/sig
+ (import (S : servlet^))
+ (link
+  [H : my-servlet-helpers^ ((load-relative "helper.ss") S)]
+  [M : () (multiply@ S H)])
+ (export (open M)))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/examples/count.ss b/collects/web-server/default-web-root/servlets/examples/count.ss
new file mode 100644
index 0000000000..b7b00a73f6
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/examples/count.ss
@@ -0,0 +1,14 @@
+(require (lib "unitsig.ss")
+         (lib "servlet-sig.ss" "web-server")
+         (lib "date.ss"))
+
+(let ([count 0]
+      [date (date->string (seconds->date (current-seconds)) 'time-too)])
+  (unit/sig () (import servlet^)
+    
+  (set! count (add1 count))
+    
+  `(html (head (title "Counter"))
+         (body ([bgcolor "white"])
+               (p "This servlet was called " ,(number->string count)
+                  " times since loaded on " ,date ".")))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/examples/dir.ss b/collects/web-server/default-web-root/servlets/examples/dir.ss
new file mode 100644
index 0000000000..c5f8da3389
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/examples/dir.ss
@@ -0,0 +1,13 @@
+(require (lib "unitsig.ss")
+         (lib "servlet-sig.ss" "web-server")
+         (lib "servlet-helpers.ss" "web-server")
+         (lib "date.ss"))
+
+(unit/sig () (import servlet^)
+
+  (send/back
+   `(html (head (title "Current Directory Page"))
+          (body
+           (h1 "Current Directory Page")
+           (p "The current directory is: " (em ,(current-directory)))))))
+
diff --git a/collects/web-server/default-web-root/servlets/examples/english-measure-questions.ss b/collects/web-server/default-web-root/servlets/examples/english-measure-questions.ss
new file mode 100644
index 0000000000..667adec1d2
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/examples/english-measure-questions.ss
@@ -0,0 +1,155 @@
+;; Data file for quiz.ss, written by Don Felgar
+
+'("This is a quiz on English weights and measures.  Good luck!"
+  (
+   ("How many imperial gallons in a firkin?"
+    ("4" "5" "8" "9")
+    3
+    "The firkin is a liquor volume, equalling nine imperial gallons.
+An imperial gallon is equals 1.20095 gallons, by the way.
+Alternatively te firkin is one-fourth of a barrel.")
+   ("How many tablespoons in a cup?"
+    ("4" "6" "8" "16")
+    3
+    "Recipes in the US most often use tablespoons, teaspoons, and
+cups.")
+   ("How many teacups in a cup?"
+    ("1/2" "3/4" "1" "1.5")
+    1
+    "")
+   ("A magnum is how many gallons?"
+    ("0.5" "1" "1.5" "2")
+    3
+    "Wine bottles, in order of size, are: bottle, magnum, jeroboam,
+rehoboam, methuselah, salmanazar, balthazar, and nebuchadnezzar, which
+holds 5 gallons.")
+   ("A kilderkin is how many gallons?"
+    ("5" "18" "20" "25")
+    1
+    "")
+   ("How many magnums in a rehoboam?"
+    ("3" "4" "5" "10")
+    0
+    "Wine bottles, in order of size, are: bottle, magnum, jeroboam,
+rehoboam, methuselah, salmanazar, balthazar, and nebuchadnezzar, which
+holds 5 gallons.")
+   ("How many scruples in a Troy ounce?"
+    ("8" "24" "48" "196")
+    1
+    "20 grains in a scruple, 24 scruples in a Troy ounce.  The scruple is an apothecary measurement.")
+   ("How many cups are in a quart?"
+    ("2" "2.5" "3" "4")
+    3
+    "Two cups in a pint, two pints in a quart, four quarts in a gallon.")
+   ("How many cups in a pint?"
+    ("2" "2.5" "3" "4")
+    0
+    "Two cups in a pint, two pints in a quart, four quarts in a gallon.")
+   ("How many pecks in a bushel?"
+    ("4" "5" "8" "10")
+    0
+    "Note: The Winchester bushel, formerly used in England,
+contained 2150.42 cubic inches, being the volume of a cylinder 181/2
+inches in internal diameter and eight inches in depth. The standard
+bushel measures, prepared by the United States Government and
+distributed to the States, hold each 77.6274 pounds of distilled
+water, at 39.8[deg] Fahr. and 30 inches atmospheric pressure, being
+the equivalent of the Winchester bushel. The imperial bushel now in
+use in England is larger than the Winchester bushel, containing 2218.2
+cubic inches, or 80 pounds of water at 62[deg] Fahr.")
+   ("A jigger is:"
+    ("1/3 of a tablespoon" "2 tablespoons" "3 tablespoons" "4 tablespoons")
+    2
+    "A jigger is the amount a shot glass contains.  The pony is
+another drink volume measure, equalling half a jigger.  There's also
+the English beer gallon.")
+   ("How many grains in a pound:"
+    ("400" "500" "512" "7000")
+    3
+    "According to Webster's: \"The unit of the English system of
+weights; -- so called because considered equal to the average of
+grains taken from the middle of the ears of wheat. 7,000 grains
+constitute the pound avoirdupois, and 5,760 grains the pound troy. A
+grain is equal to .0648 gram.\"")
+   ("How many tablespoons in a fluid ounce:"
+    ("0.5" "1" "2" "4")
+    2
+    "Recipes in the US most often use tablespoons, teaspoons, and
+cups.")
+   ("At standard temperature and pressure, one fluid ounce of water
+weighs:"
+    ("1.04158 ounces avoirdupois" "1 ounce avoirdupois" "1 troy ounce" "none of the above")
+    0
+    "Good question.")
+   ("A person who weighs 10 stone weighs how many pounds:"
+    ("90" "100" "120" "140")
+    3
+    "One stone for human weight is 14 pounds. Note: The stone of
+butchers' meat or fish is reckoned at 8 lbs.; of cheese, 16 lbs.; of
+hemp, 32 lbs.; of glass, 5 lbs. (Webster's).  Time to go metric.")
+   ("How many cord foot are in a cord?"
+    ("2" "4" "8" "9")
+    2
+    "According to Webster's, a cord is \"A solid measure,
+equivalent to 128 cubic feet; a pile of wood, or other coarse
+material, eight feet long, four feet high, and four feet broad; --
+originally measured with a cord or line.\"")
+   ("A teacup is how many fluid ounces?"
+    ("4" "5" "6" "8")
+    0
+    "")
+   ("A mile is how many feet?"
+    ("4,000" "5,120" "5,280" "6,000")
+    2
+    "5,280 feet, 1,760 yards.")
+   ("How many acres in a square mile?"
+    ("320" "400" "500" "640")
+    3
+    "")
+   ("How many fluid ounces in a gallon?"
+    ("32" "64" "128" "256")
+    2
+    "")
+   ("In the US we refer to oil quantities in barrels.  How many
+gallons in an oil barrel (also known as petroleum barrel)?"
+    ("42" "120" "128" "150")
+    0
+    "Alternatively, one oil barrel equals 896 tea cups.")
+   ("How many teaspoons in a tablespoon?"
+    ("2" "2.5" "3" "4")
+    2
+    "")
+   ("One fluid dram equals how many fluid ounces:"
+    ("0.1" "0.125" "0.5" "0.75")
+    1
+    "As with the ounce, there is a fluid dram and a weight dram.  A
+weight dram is 0.0625 of an ounce.  What's worse, there is a Troy
+ounce as well as an avoirdupois ounce.")
+   ("One Troy carat is equal to:"
+    ("3.2 grains Troy" "5 grains Troy" "7.5 grains Troy" "10 grains Troy")
+    0
+    "\"Note: The carat equals three and one fifth grains Troy, and is
+divided into four grains, sometimes called carat grains. Diamonds and
+other precious stones are estimated by carats and fractions of carats,
+and pearls, usually, by carat grains. --Tiffany\" (As quoted from
+Webster's).  Additionally, carat can mean 24th part; 22 carat gold is
+22/24's gold.")
+   ("How many Troy ounces are in a pound?"
+    ("8" "10" "12" "16")
+    2
+    "According to Webster's: \"Troy weight, the weight which gold and
+silver, jewels, and the like, are weighed. It was so named from
+Troyes, in France, where it was first adopted in Europe. The troy
+ounce is supposed to have been brought from Cairo during the
+crusades. In this weight the pound is divided into 12 ounces, the
+ounce into 20 pennyweights, and the pennyweight into 24 grains; hence,
+the troy ounce contains 480 grains, and the troy pound contains 5760
+grains. The avoirdupois pound contains 7000 troy grains; so that 175
+pounds troy equal 144 pounds avoirdupois, or 1 pound troy = 0.82286 of
+a pound avoirdupois, and 1 ounce troy = 117/175 or 1.09714 ounce
+avoirdupois. Troy weight when divided, the pound into 12 ounces, the
+ounce into 8 drams, the dram into 3 scruples, and the scruple into 20
+grains, is called apothecaries' weight, used in weighing medicines,
+etc. In the standard weights of the United States, the troy ounce is
+divided decimally down to the 1/10000 part.\"")
+   ))
diff --git a/collects/web-server/default-web-root/servlets/examples/hello.ss b/collects/web-server/default-web-root/servlets/examples/hello.ss
new file mode 100644
index 0000000000..5c3fb60ea7
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/examples/hello.ss
@@ -0,0 +1,10 @@
+(require (lib "unitsig.ss")
+         (lib "servlet-sig.ss" "web-server"))
+
+(unit/sig () (import servlet^)
+  
+  (define the-text "Hello, Web!")
+  
+  `(html (head (title ,the-text))
+         (body ([bgcolor "white"])
+               (p ,the-text))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/examples/quiz.ss b/collects/web-server/default-web-root/servlets/examples/quiz.ss
new file mode 100644
index 0000000000..bbe6da17af
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/examples/quiz.ss
@@ -0,0 +1,208 @@
+;; Written by Don Felgar, edited by Greg Pettyjohn
+;;
+;; Multiple-choice quiz PLT servlet sample.
+;;
+;;
+;; Question sexp interface:
+;; Questions = (listof intro-text (listof question))
+;; intro-text = string explaining what test is about
+;; question = (question-text choices correct-answer explanation)
+;; question-text = string, the actual question
+;; choices = (listof string), possible answers to the question
+;; correct-answer = integer, index into choices
+;;
+
+;; Configuration
+(define *data-file*
+  (build-path (collection-path "web-server")
+              "default-web-root" "servlets" "examples" "english-measure-questions.ss"))
+(define *questions-per-quiz* 5)
+
+
+(require (lib "unitsig.ss")
+         (lib "servlet-sig.ss" "web-server")
+         (lib "servlet-helpers.ss" "web-server")
+         (lib "list.ss")
+         (lib "etc.ss"))
+
+(unit/sig () (import servlet^)
+
+ ;; Accessors into question sexp's
+ (define question-text car)
+ (define question-choices cadr)
+ (define question-answer caddr)
+ (define question-explanation cadddr)
+
+ (define quiz (load *data-file*))
+ (define quiz-intro (car quiz))
+ (define all-questions (cadr quiz))
+
+ ;; ask-question: question number number -> (listof (cons symbol string))
+ ;; Page for asking quiz question.
+ ;; result contains a binding for 'answer
+ (define (ask-question question-sexp question-number n-questions)
+   (request-bindings
+    (send/suspend
+     (lambda (k-url)
+       (let ((answer-num -1))
+         `(html
+           (head
+            (title "Quiz Servlet")
+            (body
+             (p ,(format "Question ~A of ~A" (add1 question-number)
+                         n-questions))
+             (p ,(question-text question-sexp))
+             (form ((method "post") (action ,k-url))
+                   ,@(map (lambda (choice)
+                            (set! answer-num (add1 answer-num))
+                            `(p
+                              ,(choice-descriptor answer-num) ". "
+                              (input ((type "radio")
+                                      (name "answer")
+                                      (value ,(number->string
+                                               answer-num))))
+                              ,choice))
+                          (cadr question-sexp))
+                   (input ((type "submit")
+                           (value "Next"))))))))))))
+
+ ;; ((listof question-sexp) size) -> (listof question-sexp)
+ ;; Choose a subset (without duplicates) of given size from a given list
+ ;; assume subset-size <= (length questions)
+ (define (random-question-set questions subset-size)
+   (let choose-questions ([questions questions]
+                          [chosen '()])
+     (if (= (length chosen) subset-size)
+       chosen
+       (let ([qstn (list-ref questions (random (length questions)))])
+         (choose-questions
+          (filter
+           (lambda (q)
+             (not (eq? qstn q)))
+           questions)
+          (cons qstn chosen))))))
+
+ ;; choice-descriptor: number -> character
+ ;; Map 0 to "A", 1 to "B", etc
+ (define (choice-descriptor number)
+   (string (integer->char (+ (char->integer #\A) number))))
+
+ ;; begin-quiz: -> request
+ ;; request bindings are not currently used
+ (define (begin-quiz)
+   (send/suspend
+    (lambda (k-url)
+      `(html
+        (head
+         (title "Quiz Servlet"))
+        (body
+         (p ,quiz-intro)
+         (form ((method "post") (action ,k-url))
+               (input ((type "submit")
+                       (value "Begin Quiz")))))))))
+
+ ;; Compare list of questions to answers.
+ ;; ((listof question-sexp) (listof integer|false)) -> (listof integer)
+ (define (score-quiz questions answers)
+   (foldr
+    (lambda (question answer csw)
+      (let ([correct-answer (question-answer question)])
+        (apply
+         (lambda (correct skipped wrong)
+           (cond
+            [(not answer)
+             (list correct (add1 skipped) wrong)]
+            [(= answer correct-answer)
+             (list (add1 correct) skipped wrong)]
+            [else
+             (list correct skipped (add1 wrong))]))
+         csw)))
+    (list 0 0 0) questions answers))
+
+ ;; end-quiz: (listof question) (listof (union number false)) -> request
+ ;; request bindings are not currently used.
+ (define (end-quiz questions answers)
+   (send/forward
+    (lambda (k-url)
+      (let* ((score (score-quiz questions answers))
+             (correct (car score))
+             (skipped (cadr score))
+             (wrong (caddr score))
+             (xml
+              `(html
+                (head
+                 (title "Quiz Servlet"))
+                (body
+                 (p ,(format "Your score: ~A/~A"
+                             correct
+                             (+ correct wrong skipped)))
+                 (p ,(format "Correct: ~A" correct))
+                 (p ,(format "Skipped: ~A" skipped))
+                 (p ,(format "Wrong: ~A" wrong))
+                 (table ((border "5"))
+                        (tr (td "Question") (td "Correct Answer")
+                            (td "Your Answer") (td "Explanation"))
+                        ,@(map
+                           (lambda (q a)
+                             `(tr
+                               (td ,(question-text q))
+                               (td ,(format "~A. ~A"
+                                            (choice-descriptor
+                                             (question-answer q))
+                                            (list-ref (question-choices q)
+                                                      (question-answer q))))
+                               (td ,(if a
+                                      (format "~A. ~A" (choice-descriptor a)
+                                              (list-ref
+                                               (question-choices q) a))
+                                      "Skipped"))
+                               (td ,(question-explanation q))))
+                           questions answers))
+                 (form ((method "get")
+                        (action ,k-url))
+                       (input ((type "submit")
+                               (value "New Quiz"))))))))
+        xml))))
+
+ ;; Return the first value for key in bindings, if it at least one
+ ;; exists, otherwise #f.
+ (define (binding-value key bindings)
+   (and (exists-binding? key bindings)
+        (extract-binding/single key bindings)))
+
+ ;; run-quiz: -> void
+ ;; run quizes until the student gets tired
+ (define (run-quiz)
+   (let ([*questions-per-quiz*
+          (if (> *questions-per-quiz* (length all-questions))
+            (begin
+              (display (format "~A ~A ~A ~A\n"
+                               "Configuration error.  *questions-per-quiz*:"
+                               *questions-per-quiz*
+                               "for a question list of size"
+                               (length all-questions)))
+              (length all-questions))
+            *questions-per-quiz*)])
+
+     (let ([questions (random-question-set all-questions
+                                           *questions-per-quiz*)])
+       (begin-quiz)
+       (let ([answers
+              (build-list (length questions)
+                          (lambda (question-number)
+                            (let ([answer
+                                   (binding-value 'answer
+                                                  (ask-question
+                                                   (list-ref questions question-number)
+                                                   question-number
+                                                   *questions-per-quiz*))])
+                              (and answer (string->number answer)))))])
+         (end-quiz questions answers))))
+   (run-quiz))
+
+ ;; Entry point into servlet.
+ (run-quiz)
+
+ )
+
+
diff --git a/collects/web-server/default-web-root/servlets/tests/a-module.ss b/collects/web-server/default-web-root/servlets/tests/a-module.ss
new file mode 100644
index 0000000000..02c5b05358
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/a-module.ss
@@ -0,0 +1,12 @@
+(module a-module mzscheme
+  (provide interface-version timeout start)
+  
+  (define interface-version 'v1)
+  
+  (define timeout +inf.0)
+  
+  ; start : request -> response
+  (define (start initial-request)
+    `(html (head (title "A Test Page"))
+           (body ([bgcolor "white"])
+                 (p "A simple module servlet works.")))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/b-module.ss b/collects/web-server/default-web-root/servlets/tests/b-module.ss
new file mode 100644
index 0000000000..1f988b19d3
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/b-module.ss
@@ -0,0 +1,14 @@
+(module b-module mzscheme
+  (provide interface-version timeout start)
+  (require (lib "servlet-sig.ss" "web-server"))
+  
+  (define interface-version 'v1)
+  
+  (define timeout +inf.0)
+  
+  ; start : request -> response
+  (define (start initial-request)
+    `(html (head (title "A Test Page"))
+           (body ([bgcolor "white"])
+                 (p ,(format "Here are the initial bindings: ~v"
+                             (request-bindings initial-request)))))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/bad-require.ss b/collects/web-server/default-web-root/servlets/tests/bad-require.ss
new file mode 100644
index 0000000000..3453e0b6c2
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/bad-require.ss
@@ -0,0 +1 @@
+(require "not-there-on-purpose.ss")
diff --git a/collects/web-server/default-web-root/servlets/tests/bad-return.ss b/collects/web-server/default-web-root/servlets/tests/bad-return.ss
new file mode 100644
index 0000000000..19080d0ef0
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/bad-return.ss
@@ -0,0 +1,5 @@
+(require (lib "unitsig.ss"))
+(require (lib "servlet-sig.ss" "web-server"))
+(unit/sig ()
+  (import servlet^)
+  5)
diff --git a/collects/web-server/default-web-root/servlets/tests/broken.ss b/collects/web-server/default-web-root/servlets/tests/broken.ss
new file mode 100644
index 0000000000..f162ee3ada
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/broken.ss
@@ -0,0 +1,5 @@
+(require (lib "unitsig.ss"))
+(require (lib "servlet-sig.ss" "web-server"))
+(unit/sig ()
+  (import servlet^)
+  (raise 'kablooie))
diff --git a/collects/web-server/default-web-root/servlets/tests/cut-module.ss b/collects/web-server/default-web-root/servlets/tests/cut-module.ss
new file mode 100644
index 0000000000..6fdf62b460
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/cut-module.ss
@@ -0,0 +1,56 @@
+; purpose: to test send/suspend, send/forward, send/back, and send/finish
+(module cut-module mzscheme
+  (provide interface-version timeout start)
+  (require (lib "servlet.ss" "web-server")
+           (lib "servlet-helpers.ss" "web-server")
+           (lib "servlet-sig.ss" "web-server"))
+  
+  (define interface-version 'v1)
+  
+  (define timeout (* 7 24 60 60))
+  
+  ; : request -> response
+  (define (start initial-request)
+    (let ([order (extract-binding/single
+                  'order
+                  (request-bindings
+                   (send/suspend (let ([question "Place your order"])
+                                   (build-suspender
+                                    `(,question)
+                                    `(,question (input ([type "text"] [name "order"]))))))))])
+      (if (string=? "coconut" order)
+          (continue-shopping)
+          (retry-order))))
+  
+  ; : -> doesn't
+  (define (continue-shopping)
+    (let* ([next-request
+            (send/forward
+             (build-suspender
+              '("Keep shopping")
+              `((p "Your order has shipped to a random location.  You may not go back.")
+                (p (input ([type "submit"] [name "go"] [value "Keep Shopping"])))
+                (p (input ([type "submit"] [name "stop"] [value "Logout"]))))))]
+           [next (request-bindings next-request)])
+      (cond
+        [(exists-binding? 'go next)
+         (start next-request)]
+        [(exists-binding? 'stop next)
+         (send/finish goodbye-page)]
+        [else
+         (send/finish
+          `(html (head (title "Oops"))
+                 (body ([bgcolor "white"])
+                       (p "Oops " ,(format "next = ~v" next)))))])))
+  
+  ; : -> doesn't
+  (define (retry-order)
+    (send/back '(html (head (title "oops"))
+                      (body (p "This store only sells coconuts.  Please click the browser's back button and type "
+                               (code "coconut") " in the field.")))))
+  
+  (define goodbye-page
+    `(html (head (title "Goodbye"))
+           (body (p "Thank you for shopping.")))))
+  
+  
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/incremental.ss b/collects/web-server/default-web-root/servlets/tests/incremental.ss
new file mode 100644
index 0000000000..72ba947100
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/incremental.ss
@@ -0,0 +1,15 @@
+(require (lib "servlet-sig.ss" "web-server")
+;         (lib "servlet-helpers.ss" "web-server")
+         (lib "unitsig.ss"))
+
+(unit/sig ()
+  (import servlet^)
+  
+  (send/finish
+   (make-html-response/incremental
+    (lambda (output-chunk)
+      (output-chunk "<html><head><title>"
+                    "my-title</title></head>\n")
+      (output-chunk "<body><p>The first paragraph</p>\n")
+      (sleep 4)
+      (output-chunk "<p>The second paragraph</p></body></html>\n")))))
diff --git a/collects/web-server/default-web-root/servlets/tests/mime.ss b/collects/web-server/default-web-root/servlets/tests/mime.ss
new file mode 100644
index 0000000000..8c14f5c57e
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/mime.ss
@@ -0,0 +1,7 @@
+(require (lib "unitsig.ss"))
+(require (lib "servlet-sig.ss" "web-server"))
+(unit/sig ()
+  (import servlet^)
+  `("text/uber-format"
+    "uber uber uber"
+    "-de-doo"))
diff --git a/collects/web-server/default-web-root/servlets/tests/module-suspended-init.ss b/collects/web-server/default-web-root/servlets/tests/module-suspended-init.ss
new file mode 100644
index 0000000000..5f0456f04f
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/module-suspended-init.ss
@@ -0,0 +1,27 @@
+(module module-suspended-init mzscheme
+  (provide interface-version timeout start)
+  (require (lib "servlet.ss" "web-server")
+           (lib "servlet-helpers.ss" "web-server")
+           (lib "servlet-sig.ss" "web-server"))
+  
+  (define interface-version 'v1)
+  
+  (define timeout (* 7 24 60 60))
+  
+  ; : request -> response
+  (define (start initial-request)
+    (let ([name (extract-binding/single
+                 'name
+                 (request-bindings
+                  (send/suspend (let ([question "What is your name?"])
+                                  (build-suspender
+                                   `(,question)
+                                   `(,question (input ([type "text"] [name "name"]))))))))])
+      `(html (head (title "Hi " ,name "!"))
+             (body (p "Hello, " ,name "!  Don't you feel special now?")))))
+  
+  (send/suspend
+   (build-suspender '("Module Init")
+                    '((p "Maybe calling send/suspend during the module initialization is not a good idea.")
+                      (p "This call to send/suspend fails in the development environment since the parameter is #f")
+                      (p "It fails in the server because the instance id is not yet installed into the table.")))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/non-unit.ss b/collects/web-server/default-web-root/servlets/tests/non-unit.ss
new file mode 100644
index 0000000000..7ed6ff82de
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/non-unit.ss
@@ -0,0 +1 @@
+5
diff --git a/collects/web-server/default-web-root/servlets/tests/response.ss b/collects/web-server/default-web-root/servlets/tests/response.ss
new file mode 100644
index 0000000000..5eb100c500
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/response.ss
@@ -0,0 +1,5 @@
+(define title "A Test of Direct Responses")
+
+`(html (head (title ,title))
+       (body (h2 ,title)
+             (p "This is only a test.")))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/size.ss b/collects/web-server/default-web-root/servlets/tests/size.ss
new file mode 100644
index 0000000000..174feec2db
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/size.ss
@@ -0,0 +1,22 @@
+(require (lib "unitsig.ss"))
+(require (lib "servlet-sig.ss" "web-server"))
+
+(let* ([line-size 80]
+       [build-a-str
+        (lambda (n)
+          (list->string (let loop ([n n])
+                          (cond
+                            [(zero? n) (list #\newline)]
+                            [else (cons #\a (loop (sub1 n)))]))))]
+       [line (build-a-str (sub1 line-size))]
+       [html-overhead 68])
+  (unit/sig ()
+    (import servlet^)
+    
+    (define size (- (string->number (cdr (assq 'size bindings))) html-overhead))
+    (define nlines (quotient size line-size))
+    (define extra (remainder size line-size))
+    
+    `(html (head (title "A Page"))
+           (body (p ,@(vector->list (make-vector nlines line))
+                    ,(build-a-str extra))))))
diff --git a/collects/web-server/default-web-root/servlets/tests/suspended-module.ss b/collects/web-server/default-web-root/servlets/tests/suspended-module.ss
new file mode 100644
index 0000000000..fe174791d7
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/suspended-module.ss
@@ -0,0 +1,21 @@
+(module suspended-module mzscheme
+  (provide interface-version timeout start)
+  (require (lib "servlet.ss" "web-server")
+           (lib "servlet-helpers.ss" "web-server")
+           (lib "servlet-sig.ss" "web-server"))
+  
+  (define interface-version 'v1)
+  
+  (define timeout (* 7 24 60 60))
+  
+  ; : request -> response
+  (define (start initial-request)
+    (let ([name (extract-binding/single
+                 'name
+                 (request-bindings
+                  (send/suspend (let ([question "What is your name?"])
+                                  (build-suspender
+                                   `(,question)
+                                   `(,question (input ([type "text"] [name "name"]))))))))])
+      `(html (head (title "Hi " ,name "!"))
+             (body (p "Hello, " ,name "!  Don't you feel special now?"))))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/test.ss b/collects/web-server/default-web-root/servlets/tests/test.ss
new file mode 100644
index 0000000000..63e5674d51
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/test.ss
@@ -0,0 +1,15 @@
+(require (lib "unitsig.ss"))
+(require (lib "servlet-sig.ss" "web-server"))
+(let ([count 0])
+  (unit/sig ()
+    (import servlet^)
+(with-handlers ([void (lambda (exn) `(html (body (p ,(exn-message exn)))))])
+    (set! count (add1 count))
+    `(html (head (title "Testing 1...2...3"))
+	   (body (p "This is a generated web page.")
+		 (p ,(format "Here are the bindings:~n~s~n" (request-bindings initial-request))
+		    (br)
+		    "Count = " ,(number->string count)
+		    (br)
+		    ,(format "Here are the headers:~n~s~n" (request-headers initial-request)))))))
+)
diff --git a/collects/web-server/default-web-root/servlets/tests/url.ss b/collects/web-server/default-web-root/servlets/tests/url.ss
new file mode 100644
index 0000000000..c2de118b06
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/url.ss
@@ -0,0 +1,11 @@
+(require (lib "unitsig.ss")
+         (lib "servlet-sig.ss" "web-server")
+         (lib "url.ss" "net"))
+(let ([count 0])
+  (unit/sig ()
+    (import servlet^)
+    (set! count (add1 count))
+    `(html (head (title "URL Test"))
+           (body (p "The method requested is: " ,(format "~s" (request-method initial-request)))
+                 (p "The URL requested is: " ,(url->string (request-uri initial-request)))
+                 (p "count is: " ,(number->string count))))))
\ No newline at end of file
diff --git a/collects/web-server/gui-launch.ss b/collects/web-server/gui-launch.ss
new file mode 100644
index 0000000000..427552c1bd
--- /dev/null
+++ b/collects/web-server/gui-launch.ss
@@ -0,0 +1,22 @@
+
+(module gui-launch mzscheme
+  (require "launch.ss"
+	   (lib "class.ss")
+	   (lib "mred.ss" "mred"))
+
+  (define shutdown (serve))
+
+  (when (current-eventspace-has-menu-root?) 
+    (let ([mb (make-object menu-bar% 'root)])
+      (unless (current-eventspace-has-standard-menus?)
+	(make-object menu-item%
+		     "Quit"
+		     (make-object menu% "File" mb)
+		     (lambda (i e)
+		       (shutdown)
+		       (exit))))))
+  (application-quit-handler (lambda ()
+			      (shutdown)
+			      (exit)))
+
+  (yield (make-semaphore)))
diff --git a/collects/web-server/info.ss b/collects/web-server/info.ss
new file mode 100644
index 0000000000..705da9b830
--- /dev/null
+++ b/collects/web-server/info.ss
@@ -0,0 +1,9 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Web Server")
+  (define mzscheme-launcher-libraries (list "text-launch.ss" "monitor-launch.ss"))
+  (define mzscheme-launcher-names (list "web-server-text" "web-server-monitor"))
+
+  (define mred-launcher-libraries (list "gui-launch.ss"))
+  (define mred-launcher-names (list "web-server"))
+
+  (define compile-omit-files (list "servlet-primitives.ss")))
diff --git a/collects/web-server/internal-structs.ss b/collects/web-server/internal-structs.ss
new file mode 100644
index 0000000000..d8bf496464
--- /dev/null
+++ b/collects/web-server/internal-structs.ss
@@ -0,0 +1,24 @@
+(module internal-structs mzscheme
+  (provide current-servlet-stuff)
+  (require "util.ss")
+  
+  ; more here - rename
+  (define current-servlet-stuff (make-parameter #f (lambda (x) x)))
+  
+  ; servlet-instance = (make-servlet-instance Nat Channel (Hashtable Symbol -> cont))
+  (provide-define-struct servlet-instance (k-counter channel cont-table))
+
+  ; config = (make-config host-table script-table instance-table access-table)
+  (provide-define-struct config (hosts scripts instances access))
+  
+  ; more here - rename
+  ; more here - check if method is needed.  (I think it's for purge-table.)
+  ; note: the url is the initial starting url without instance or continuation specific stuff at the end.
+  ; servlet-stuff = (make-servlet-stuff url sym instance-table (response -> void) (instance -> doesn't) method)
+  (provide-define-struct servlet-stuff (url invoke-id instances output-page resume method))
+  
+  ;; a connection is a structure
+  ;; (make-connection custodian input-port output-port timer boolean)
+  (provide-define-struct connection (i-port o-port close?))
+  
+  )
\ No newline at end of file
diff --git a/collects/web-server/launch.ss b/collects/web-server/launch.ss
new file mode 100644
index 0000000000..fc68ae1d2a
--- /dev/null
+++ b/collects/web-server/launch.ss
@@ -0,0 +1,61 @@
+; The main program of the "web-server" launcher.
+(module launch mzscheme
+  (require (lib "cmdline.ss")
+           (lib "pregexp.ss")
+           "util.ss"
+           "web-server-unit.ss"
+           "sig.ss"
+           "configuration.ss"
+           (lib "unitsig.ss")
+           (lib "tcp-sig.ss" "net"))
+
+  (define configuration@
+    (parse-command-line
+     "web-server"
+     (current-command-line-arguments)
+     `((once-each
+        [("-f" "--configuration-table")
+         ,(lambda (flag file-name)
+            (cond
+             [(not (file-exists? file-name))
+              (error 'web-server "configuration file ~s not found" file-name)]
+             [(not (memq 'read (file-or-directory-permissions file-name)))
+              (error 'web-server "configuration file ~s is not readable" file-name)]
+             [else (cons 'config (string->path file-name))]))
+         ("Use an alternate configuration table" "file-name")]
+        [("-p" "--port")
+         ,(lambda (flag port)
+            (let ([p (string->number port)])
+              (if (and (number? p) (integer? p) (exact? p) (<= 1 p 65535))
+                  (cons 'port p)
+                  (error 'web-server "port expects an argument of type <exact integer in [1, 65535]>; given ~s" port))))
+         ("Use an alternate network port." "port")]
+        [("-a" "--ip-address")
+         ,(lambda (flag ip-address)
+            ; note the double backslash I initially left out.  That's a good reason to use Olin's regexps.
+            (let ([addr (pregexp-split "\\." ip-address)])
+              (if (and (= 4 (length addr))
+                       (andmap (lambda (s)
+                                 (let ([n (string->number s)])
+                                   (and (integer? n) (<= 0 n 255))))
+                               addr))
+                  (cons 'ip-address ip-address)
+                  (error 'web-server "ip-address expects a numeric ip-address (i.e. 127.0.0.1); given ~s" ip-address))))
+         ("Restrict access to come from ip-address" "ip-address")]))
+     (lambda (flags)
+       (update-configuration
+        (load-configuration
+         (extract-flag 'config flags default-configuration-table-path))
+        flags))
+     '()))
+
+  (define-values/invoke-unit/sig web-server^
+    (compound-unit/sig
+     (import (T : net:tcp^))
+     (link
+      [C : web-config^ (configuration@)]
+      [S : web-server^ (web-server@ T C)])
+     (export (open S)))
+    #f net:tcp^)
+
+  (provide serve))
diff --git a/collects/web-server/min-servlet.ss b/collects/web-server/min-servlet.ss
new file mode 100644
index 0000000000..d982653467
--- /dev/null
+++ b/collects/web-server/min-servlet.ss
@@ -0,0 +1,58 @@
+;; This file is intended to include the minimum set of *utilities*
+;; needed to write servlets. It is based on the *old* version of "servlet-sig.ss"
+(module min-servlet mzscheme
+  (require (lib "xml.ss" "xml")
+           (rename "util.ss" translate-escapes translate-escapes))
+  (provide response?
+           (struct response/full (code message seconds mime extras body))
+           (struct response/incremental ())
+           (struct request (method uri headers host-ip client-ip))
+           (rename request-bindings request-bindings/raw)
+           (rename get-parsed-bindings request-bindings)
+           translate-escapes)
+
+  ; : TST -> bool
+  (define (response? page)
+    (or (response/full? page)
+        ; this could fail for dotted lists - rewrite andmap
+        (and (pair? page) (pair? (cdr page)) (andmap string? page))
+                                        ; insist the xexpr has a root element
+        (and (pair? page) (xexpr? page))))
+
+  ; more here - these should really have a common super type, but I don't want to break
+  ; the existing interface.
+  (define-struct response/full (code message seconds mime extras body))
+  (define-struct (response/incremental response/full) ())
+
+  ; request = (make-request sym URL (listof (cons sym str)) (U str (listof (cons sym str))) str str)
+  ; Outside this module, bindings looks like an association list (due to renaming request-bindings).
+  ; Inside it is a string for normal requests, but for file uploads it is still an association list.
+  ; more here - perhaps it should always be a string inside this module.
+  (define-struct request (method uri headers bindings host-ip client-ip))
+
+  ; get-parsed-bindings : request -> (listof (cons sym str))
+  (define (get-parsed-bindings r)
+    (let ([x (request-bindings r)])
+      (if (list? x)
+          x
+          (parse-bindings x))))
+
+  ; parse-bindings : (U #f String) -> (listof (cons Symbol String))
+  (define (parse-bindings raw)
+    (if (string? raw)
+        (let ([len (string-length raw)])
+          (let loop ([start 0])
+            (let find= ([key-end start])
+              (if (>= key-end len)
+                  null
+                  (if (eq? (string-ref raw key-end) #\=)
+                      (let find-amp ([amp-end (add1 key-end)])
+                        (if (or (= amp-end len) (eq? (string-ref raw amp-end) #\&))
+                            (cons (cons (string->symbol (substring raw start key-end))
+                                        (translate-escapes
+                                         (substring raw (add1 key-end) amp-end)))
+                                  (loop (add1 amp-end)))
+                            (find-amp (add1 amp-end))))
+                      (find= (add1 key-end)))))))
+        null))
+)
diff --git a/collects/web-server/monitor-emailer.ss b/collects/web-server/monitor-emailer.ss
new file mode 100644
index 0000000000..d9b4c2ebe4
--- /dev/null
+++ b/collects/web-server/monitor-emailer.ss
@@ -0,0 +1,19 @@
+(module monitor-emailer mzscheme
+  (require (lib "sendmail.ss" "net")
+           (lib "contract.ss"))
+  
+  (provide/contract [send-email-alert (string? ; email address
+                                       string? ; server-name
+                                       number? ; server-port 
+                                       string? ; message
+                                       . -> .
+                                       void?)])
+  
+  ; send-email-alert : send an email to the specified address informing them of the failure.
+  (define (send-email-alert alert-address server-name server-port message)
+    (send-mail-message alert-address
+                       (format "The server ~a:~a is not responding!" server-name server-port)
+                       (list alert-address)
+                       null
+                       null
+                       (list message '("" "Fix it ASAP!!!")))))
diff --git a/collects/web-server/monitor-launch.ss b/collects/web-server/monitor-launch.ss
new file mode 100644
index 0000000000..b2a1754081
--- /dev/null
+++ b/collects/web-server/monitor-launch.ss
@@ -0,0 +1,31 @@
+; The main program of the "web-server-monitor" launcher. 
+(module monitor-launch mzscheme
+  (require "monitor-server.ss"
+           "util.ss"
+           (lib "cmdline.ss"))
+  
+  ; handle-numeric-flag : sym -> str str -> (cons sym num)
+  (define (handle-numeric-flag name)
+    (lambda (dc-flag arg)
+      (cons name (string->number arg))))
+  
+  (parse-command-line
+   "web-server-monitor"
+   (current-command-line-arguments)
+   `((once-each
+      [("-p" "--port")
+       ,(handle-numeric-flag 'port)
+       ("Connects to the network port <port>." "port")]
+      [("-f" "--frequency")
+       ,(handle-numeric-flag 'frequency)
+       ("Polls every <frequency> seconds." "frequency")]
+      [("-t" "--timeout")
+       ,(handle-numeric-flag 'timeout)
+       ("Assumes failure after <timeout> seconds." "timeout")]))
+   (lambda (flags email-address host-name)
+     (monitor email-address
+              host-name
+              (extract-flag 'port flags default-server-port)
+              (extract-flag 'frequency flags default-poll-frequency-seconds)
+              (extract-flag 'timeout flags default-server-response-timeout-seconds)))
+   '("email-address" "host-name")))
diff --git a/collects/web-server/monitor-poke-web-server.ss b/collects/web-server/monitor-poke-web-server.ss
new file mode 100644
index 0000000000..a7a80cabc9
--- /dev/null
+++ b/collects/web-server/monitor-poke-web-server.ss
@@ -0,0 +1,85 @@
+(module monitor-poke-web-server mzscheme
+  (require (lib "contract.ss")
+           (lib "match.ss"))
+  
+  ;; this file contains functions to check whether a given host is responding to HTTP requests,
+  ;; specifically to a "HEAD ~a HTTP/1.0" request, where ~a is supplied by the caller.
+  
+  ;; the original code was Paul Graunke's, refactored & encontracted by John Clements
+  
+  
+  (define (poke-result? result)
+    (match result
+      [`(fail ,(? string? server-name) ,(? number? server-port) ,(? string? msg)) #t]
+      [`(timeout ,(? string? server-name) ,(? number? server-port) ,(? number? timeout-seconds)) #t]
+      [`(exn ,(? string? server-name) ,(? number? server-port) ,(? exn? exn)) #t]
+      [`(ok) #t]
+      [else #f]))
+  
+  (provide/contract [poke-web-server (channel? ; result-channel
+                                      string? ; server-name 
+                                      number? ; server-port
+                                      number? ; timeout-seconds
+                                      . -> . 
+                                      void?)]
+                    [poke-web-server/path (string? ; path
+                                           channel? ; result-channel
+                                           string? ; server-name
+                                           number? ; server-port
+                                           number? ; timeout-seconds
+                                           . -> .
+                                           void?)]
+                    [result->message (poke-result? . -> . string?)])
+  
+  (define OK-REGEXP (regexp "^HTTP/[0-9]*.[0-9]* 200"))
+  
+  
+  ; result->message : given a poke-result?, produce a reasonable error message.
+  (define (result->message result)
+    (match result
+      [`(fail ,server-name ,server-port ,line) 
+       (string-append
+        (format "The web server ~a:~a did not respond\n" server-name server-port)
+        "to a head request for its home page with an 'okay' result.\n"
+        (format "Received: ~a\n" line))]
+      [`(timeout ,server-name ,server-port ,timeout-seconds)
+       (string-append
+        (format "Attempting to send a head request to ~a:~a\n" server-name server-port)
+        (format "timed out after ~a seconds.\n" timeout-seconds))]
+      [`(exn ,server-name ,server-port ,exn)
+       (string-append
+        (format "Attempting to send a head request to ~a:~a\n" server-name server-port)
+        "resulted in the following exception:\n"
+        "\n"
+        (format "~a\n" (if (exn? exn)
+                           (exn-message exn)
+                           exn)))]
+      [`(ok) "no error"]))
+  
+  (define (poke-web-server result-channel server-name server-port timeout-seconds)
+    (poke-web-server/path "/" result-channel server-name server-port timeout-seconds))
+
+  (define (poke-web-server/path path result-channel server-name server-port timeout-seconds)
+    (let* ([cust (make-custodian)]
+           [blow-up-handler (lambda (exn)
+                              (channel-put result-channel `(exn ,server-name ,server-port ,exn))
+                              (custodian-shutdown-all cust))])
+      (parameterize ([current-custodian cust])
+        (thread (lambda ()
+                  (with-handlers ([void blow-up-handler])
+                    (sleep timeout-seconds))
+                  (channel-put result-channel `(timeout ,server-name ,server-port ,timeout-seconds))
+                  (custodian-shutdown-all cust)))
+        (thread
+         (lambda ()
+           (with-handlers ([void blow-up-handler])
+             (let-values ([(in out) (tcp-connect server-name server-port)])
+               (fprintf out "HEAD ~a HTTP/1.0\r\n" path)
+               (fprintf out "Host: ~a\r\n\r\n" server-name) ; what the jiminy cricket does this line do;?
+               (flush-output out) ;; now required for all TCP ports
+               (let ([line (read-line in)])
+                 (if (regexp-match OK-REGEXP line)
+                     (channel-put result-channel '(ok))
+                     (channel-put result-channel `(fail ,server-name ,server-port ,line)))
+                 (custodian-shutdown-all cust))))))
+        (void)))))
\ No newline at end of file
diff --git a/collects/web-server/monitor-server.ss b/collects/web-server/monitor-server.ss
new file mode 100644
index 0000000000..d39a574852
--- /dev/null
+++ b/collects/web-server/monitor-server.ss
@@ -0,0 +1,36 @@
+(module monitor-server mzscheme
+  (require (lib "etc.ss")
+           "monitor-poke-web-server.ss"
+           "monitor-emailer.ss"
+           (lib "match.ss"))
+  
+  (provide monitor
+           default-server-port
+           default-poll-frequency-seconds
+           default-server-response-timeout-seconds)
+  
+  (define default-server-port 80)
+  (define default-poll-frequency-seconds 3600)
+  (define default-server-response-timeout-seconds 75)
+  
+  ; monitor : str str [nat] [num] [num] -> doesn't
+  (define monitor
+    (opt-lambda (email-address
+                 server-name
+                 [server-port default-server-port]
+                 [poll-frequency-seconds default-poll-frequency-seconds]
+                 [server-response-timeout-seconds default-server-response-timeout-seconds])
+      
+      (define result-channel (make-channel))
+      
+      (define (send-email msg)
+        (send-email-alert email-address server-name server-port msg))
+      
+      (let check-server ()
+        (poke-web-server result-channel server-name server-port server-response-timeout-seconds)
+        (let ([result (channel-get result-channel)])
+          (match result
+            [`(ok) (void)]
+            [else (send-email (result->message result))])
+          (sleep poll-frequency-seconds)
+          (check-server))))))
\ No newline at end of file
diff --git a/collects/web-server/parse-table.ss b/collects/web-server/parse-table.ss
new file mode 100644
index 0000000000..8a1e4af3b1
--- /dev/null
+++ b/collects/web-server/parse-table.ss
@@ -0,0 +1,74 @@
+(module parse-table mzscheme
+  (require (lib "match.ss")
+           "configuration-table-structs.ss")
+  (provide parse-configuration-table)
+    
+  ; parse-configuration-table : tst -> configuration-table
+  (define parse-configuration-table
+    (match-lambda
+     [`((port ,port)
+        (max-waiting ,max-waiting)
+        (initial-connection-timeout ,initial-connection-timeout)
+        (default-host-table
+         ,default-host-table)
+        (virtual-host-table . ,virtual-host-table))
+      (if (and (nat? port) (nat? max-waiting) (number? initial-connection-timeout)
+               ; more here - list? isn't really picky enough
+               (list? virtual-host-table))
+          (make-configuration-table
+           port max-waiting initial-connection-timeout
+           (parse-host default-host-table)
+           (map (lambda (h)
+                  (if (and (pair? h) (pair? (cdr h)) (null? (cddr h)))
+                      (cons (car h) (parse-host (cadr h)))
+                      (error 'parse-configuration-table "invalid virtual-host entry ~s" h)))
+                virtual-host-table))
+          (error 'parse-configuration-table "invalid configuration values ~s"
+                 (list port max-waiting initial-connection-timeout default-host-table virtual-host-table)))]
+     [x (error 'parse-configuration-table "malformed configuration ~s" x)]))
+  
+  ; parse-host : tst -> host-table
+  (define parse-host
+    (match-lambda
+     [`(host-table
+        (default-indices . ,default-indices)
+        (log-format ,log-format)
+        (messages
+         (servlet-message ,servlet-message)
+         (authentication-message ,authentication-message)
+         (servlets-refreshed ,servlets-refreshed)
+         (passwords-refreshed ,passwords-refreshed)
+         (file-not-found-message ,file-not-found-message)
+         (protocol-message ,protocol-message))
+        (timeouts
+         (default-servlet-timeout ,default-servlet-timeout)
+         (password-connection-timeout ,password-connection-timeout)
+         (servlet-connection-timeout ,servlet-connection-timeout)
+         (file-per-byte-connection-timeout ,file-per-byte-connection-timeout)
+         (file-base-connection-timeout ,file-base-connection-timeout))
+        (paths
+         (configuration-root ,configuration-root)
+         (host-root ,host-root)
+         (log-file-path ,log-file-path)
+         (file-root ,file-root)
+         (servlet-root ,servlet-root)
+         (password-authentication ,password-authentication)))
+      (make-host-table
+       default-indices log-format
+       (make-messages servlet-message
+                      authentication-message
+                      servlets-refreshed
+                      passwords-refreshed
+                      file-not-found-message
+                      protocol-message)
+       (make-timeouts default-servlet-timeout
+                      password-connection-timeout
+                      servlet-connection-timeout
+                      file-per-byte-connection-timeout
+                      file-base-connection-timeout)
+       (make-paths configuration-root host-root log-file-path file-root servlet-root password-authentication))]
+     [x (error 'parse-host "malformed host ~s" x)]))
+  
+  ; nat? : tst -> bool
+  (define (nat? x)
+    (and (number? x) (exact? x) (integer? x) (<= 0 x))))
diff --git a/collects/web-server/request-parsing.ss b/collects/web-server/request-parsing.ss
new file mode 100644
index 0000000000..c7144ab2df
--- /dev/null
+++ b/collects/web-server/request-parsing.ss
@@ -0,0 +1,248 @@
+(module request-parsing mzscheme
+  (require (lib "contract.ss")
+           (lib "url.ss" "net")
+           (lib "list.ss")
+           "util.ss"
+           "connection-manager.ss"
+           (lib "port.ss")
+           )
+
+  ;; the request struct as currently doc'd
+  (define-struct request (method uri headers bindings host-ip client-ip))
+
+  ;; path-prefix: (listof string)
+  ;; The part of the URL path that maps to the servlet
+  ;; path-suffix: (listof string)
+  ;; The part of the URL path that gets passed to the servlet as arguments.
+
+  ;; header?: anyd/c -> boolean
+  ;; is this a header?
+  (define header?
+    (cons/c symbol? bytes?))
+
+  ;; bindings? any/c -> boolean
+  ;; is this a binding
+  (define binding?
+    (cons/c symbol? string?))
+
+  (provide/contract
+   [struct request ([method symbol?] [uri url?] [headers (listof header?)]
+                    [bindings (union (listof binding?) string?)]
+                    [host-ip string?]
+                    [client-ip string?])]
+   [read-request ((input-port?) . ->* . (request? boolean?))]
+   [read-bindings (connection? symbol? url? (listof header?)
+                               . -> . (union (listof binding?) string?))])
+
+  ;; **************************************************
+  ;; read-request: input-port -> request boolean?
+  ;; read the request line, and the headers, determine if the connection should
+  ;; be closed after servicing the request and build a request structure
+  (define (read-request ip)
+    (let-values ([(method uri major-version minor-version)
+                  (read-request-line ip)])
+      (let ([headers (read-headers ip)])
+        (let-values ([(host-ip client-ip)
+                      (if (tcp-port? ip)
+                          (tcp-addresses ip)
+                          (values "127.0.0.1" "127.0.0.1"))])
+          (values
+           (make-request method uri headers '() host-ip client-ip)
+           (close-connection?
+            headers major-version minor-version client-ip host-ip))))))
+
+  ;; **************************************************
+  ;; close-connection?
+
+  ; close-connection? : (listof (cons symbol bytes)) number number string string -> boolean
+  ; determine if this connection should be closed after serving the response
+  (define (close-connection? headers major minor client-ip host-ip)
+    (or (< major 1)
+        (and (= major 1) (= minor 0))
+        (cond
+          [(assq 'connection headers)
+           => (lambda (x) (string-ci=? "close" (bytes->string/utf-8 (cdr x))))]
+          [else #f])
+        (msie-from-local-machine? headers client-ip host-ip)))
+
+  ; : table str str -> bool
+  ; to work around a bug in MSIE for documents < 265 bytes when connecting from the local
+  ; machine.  The server could pad the response as MSIIS does, but closing the connection works, too.
+  ; We do not check for version numbers since IE 6 under windows is 5.2 under macosX
+  (define (msie-from-local-machine? headers client-ip host-ip)
+    (and (string=? host-ip client-ip)
+         (cond
+           [(or (assq 'HTTP_USER_AGENT headers)
+                (assq 'user-agent headers))
+            => (lambda (client)
+                 (and (regexp-match MSIE-regexp (cdr client))
+                      #t))]
+           [else #f])))
+
+  (define MSIE-regexp (regexp "MSIE"))
+
+  ;; **************************************************
+  ;; read-request-line
+
+  ; Method = (U 'get 'post 'head 'put 'delete 'trace)
+  (define METHOD:REGEXP
+    (byte-regexp #"^(GET|HEAD|POST|PUT|DELETE|TRACE) (.+) HTTP/([0-9]+)\\.([0-9]+)$"))
+
+  (define (match-method x)
+    (regexp-match METHOD:REGEXP x))
+  ;:(define match-method (type: (str -> (union false (list str str str str str)))))
+
+
+  ; read-request-line : iport -> symbol url number number
+  ; to read in the first line of an http request, AKA the "request line"
+  ; effect: in case of errors, complain [MF: where] and close the ports
+  (define (read-request-line ip)
+    (let ([line (read-bytes-line ip 'any)])
+      (if (eof-object? line)
+          (error 'read-request "http input closed abruptly")
+          (cond
+            [(match-method line)
+             => (lambda (x)
+                  (values
+                   (lowercase-symbol! (list-ref x 1))
+                   (string->url (bytes->string/utf-8 (list-ref x 2)))
+                   (string->number (bytes->string/utf-8 (list-ref x 3)))
+                   (string->number (bytes->string/utf-8 (list-ref x 4)))))]
+            [else (error 'read-request "malformed request ~a" line)]))))
+
+
+
+  ;; **************************************************
+  ;; read-headers
+
+  ;(define COLON:REGEXP (regexp (format "^([^:]*):[ ~a]*(.*)" #\tab)))
+  (define COLON:REGEXP (byte-regexp (bytes-append #"^([^:]*):[ " (bytes 9) #"]*(.*)")))
+
+  (define (match-colon s)
+    (regexp-match COLON:REGEXP s))
+  ;:(define match-colon (type: (str -> (union false (list str str str)))))
+
+
+  ; read-headers : iport -> (listof (cons symbol bytes))
+  (define (read-headers in)
+    (let read-header ()
+      (let ([l (read-bytes-line in 'any)])
+        (cond
+          [(eof-object? l) null]
+          [(zero? (bytes-length l)) null]
+          [(match-colon l) =>
+                           (lambda (match)
+                             ; (cadr match) exists because COLON:REGEXP contains two (.)
+                             ; (caddr match) exists because COLON:REGEXP contains two (.)
+                             (cons (cons (lowercase-symbol! (cadr match))
+                                         (read-one-head in (caddr match)))
+                                   (read-header)))]
+          [else (error 'read-headers "malformed header")]))))
+
+
+  ; read-one-head : iport bytes -> bytes
+  (define (read-one-head in rhs)
+    (let ([c (peek-byte in)])
+      (cond
+        [(or (= c 32) (= c 9)) ;(or (eq? c #\space) (eq? c #\tab))
+
+         ; (read-bytes-line in 'any) can't return eof
+         ; because we just checked with peek-char
+         ; Spidey: FLOW
+         (read-one-head in (bytes-append rhs (read-bytes-line in 'any)))]
+        [else rhs])))
+
+  ;; **************************************************
+  ;; read-bindings
+
+  (define INPUT-BUFFER-SIZE 4096)
+
+  ;; read-bindings: connection symboll url (listof header?) -> (union (listof binding?) string?)
+  (define (read-bindings conn meth uri headers)
+    (case meth
+      [(get) (url-query uri)]
+      [(post)
+       (let ([content-type (assq 'content-type headers)])
+         (cond
+           [(and content-type (regexp-match FILE-FORM-REGEXP (cdr content-type)))
+             => (lambda (content-boundary)
+                  (map (lambda (part)
+                         ;; more here - better checks, avoid string-append
+                         (cons (get-field-name (cdr (assq 'content-disposition (car part))))
+                               (apply string-append (cdr part))))
+                       (read-mime-multipart (bytes->string/utf-8 (cadr content-boundary)) (connection-i-port conn))))]
+             [else
+             (let ([len-str (assq 'content-length headers)]
+                   [in (connection-i-port conn)])
+               (if len-str
+                 (cond
+                   [(string->number (bytes->string/utf-8 (cdr len-str)))
+                    => (lambda (len) (read-string len in))]
+                    [else (error "Post request contained a non-numeric content-length")])
+                 (apply string-append
+                        (let read-to-eof ()
+                          (let ([s (read-string INPUT-BUFFER-SIZE in)])
+                            (if (eof-object? s)
+                              null
+                              (cons s (read-to-eof))))))))]))]
+      [else (error "unsupported method" meth)]))
+
+  (define FILE-FORM-REGEXP (regexp "multipart/form-data; *boundary=(.*)"))
+
+  ;; GregP: this is where I would get the filename out.
+  ; get-field-name : str -> symbol
+  (define (get-field-name rhs)
+    (let ([x (regexp-match "name=(\"([^\"]*)\"|([^ ;]*))" rhs)])
+      (unless x
+        (error 'get-field-name "Couldn't extract form field name for file upload from ~a" x))
+      (lowercase-symbol! (or (caddr x) (cadddr x)))))
+
+  ;; **************************************************
+  ;; read-mime-multipart
+
+  ; read-mime-multipart : str iport -> (listof part)
+  (define (read-mime-multipart boundary in)
+    (let* ([boundary-len (string-length boundary)]
+           [start-boundary (string-append "--" boundary)]
+           [end-boundary (string-append start-boundary "--")])
+      (let skip-preamble ()
+        (let ([line (read-line in 'return-linefeed)])
+          (cond
+            [(string=? line start-boundary)
+             (let read-parts ()
+               (let ([headers (read-headers in)])
+                 (let read-mime-part-body ([more-k (lambda (contents)
+                                                     (cons (construct-mime-part
+                                                            headers contents)
+                                                           (read-parts)))]
+                                           [end-k (lambda (contents)
+                                                    (list (construct-mime-part
+                                                           headers contents)))])
+                   (let ([line (read-line in 'return-linefeed)])
+                     (cond
+                       [(string=? line start-boundary)
+                        (more-k null)]
+                       [(string=? line end-boundary)
+                        (end-k null)]
+                       [else (read-mime-part-body
+                              (lambda (x) (more-k (cons line x)))
+                              (lambda (x) (end-k (cons line x))))])))))]
+            [(string=? line end-boundary) null]
+            [else (skip-preamble)])))))
+
+  ; more here - use structure, perhaps
+  ; construct-mime-part : (listof header) (listof str) -> part
+  (define (construct-mime-part headers body)
+    (cons headers
+          (cond
+            [(null? body) null]
+            [else (cons (car body)
+                        (foldr (lambda (str acc)
+                                 (list* CR-NL str acc))
+                               null
+                               (cdr body)))])))
+
+  (define CR-NL (format "~a~a" #\return #\newline))
+
+
+  )
diff --git a/collects/web-server/response.ss b/collects/web-server/response.ss
new file mode 100644
index 0000000000..e1a41b517d
--- /dev/null
+++ b/collects/web-server/response.ss
@@ -0,0 +1,357 @@
+(module response mzscheme
+  (require (lib "list.ss")
+           (lib "contract.ss")
+           (lib "port.ss")
+           (lib "pretty.ss")
+           (lib "xml.ss" "xml")
+           (lib "13.ss" "srfi")
+           "connection-manager.ss")
+
+  ;; **************************************************
+  ;; DATA DEF for response
+  ;; (make-response/basic number string number string  (listof (cons symbol string)))
+  (define-struct response/basic (code message seconds mime extras))
+  ;; (make-response/full ... (listof string))
+  (define-struct (response/full response/basic) (body))
+  ;; (make-response/incremental ... ((string* -> void) -> void))
+  (define-struct (response/incremental response/basic) (generator))
+
+  ; response = (cons string (listof string)), where the first string is a mime-type
+  ;          | x-expression
+  ;          | (make-response/full ... (listof string))
+  ;          | (make-response/incremental ... ((string* -> void) -> void))
+
+  ;; **************************************************
+  ;; response?: any -> boolean
+  ;; Determine if an object is a response
+  (define (response? x)
+    (or (and (response/basic? x)
+             (number? (response/basic-code x))
+             (string? (response/basic-message x))
+             (number? (response/basic-seconds x))
+             (bytes? (response/basic-mime x))
+             (and (list? (response/basic-extras x))
+                  (andmap
+                    (lambda (p)
+                      (and (pair? p)
+                           (symbol? (car p))
+                           (string? (cdr p))))
+                    (response/basic-extras x))))
+                                        ; this could fail for dotted lists - rewrite andmap
+        (and (pair? x) (pair? (cdr x)) (andmap
+                                        (lambda (x)
+                                          (or (string? x)
+                                              (bytes? x)))
+                                        x))
+                                        ; insist that the xexpr has a root element
+        (and (pair? x) (xexpr? x))))
+
+
+  ;; Weak contracts for output-response because the response? is checked inside
+  ;; output-response, handled, etc.
+  (provide/contract
+   [struct (response/full response/basic)
+           ([code number?]
+                  [message string?]
+                  [seconds number?]
+                  [mime bytes?]
+                  [extras (listof (cons/c symbol? string?))]
+                  [body (listof (union string?
+                                       bytes?))])]
+   [struct (response/incremental response/basic)
+           ([code number?]
+            [message string?]
+            [seconds number?]
+            [mime bytes?]
+            [extras (listof (cons/c symbol? string?))]
+            [generator ((() (listof (union bytes? string?)) . ->* . any) . ->
+                        . any)]
+            )]
+   [response? (any/c . -> . boolean?)]
+   [output-response (connection? any/c . -> . any)]
+   [output-response/method (connection? response? symbol? . -> . any)]
+   [output-file (connection? path? symbol? bytes? . -> . any)]
+   [TEXT/HTML-MIME-TYPE bytes?]
+   )
+
+
+
+
+  ;; Table 1. head responses:
+; ------------------------------------------------------------------------------
+; |method | close? | x-fer coding || response actions
+; |-----------------------------------------------------------------------------
+; |-----------------------------------------------------------------------------
+; |head   |   #t   | chunked      || 1. Output the headers only.
+; |-------------------------------|| 2. Add the special connection-close header.
+; |head   |   #t   | not-chunked  ||
+; |-----------------------------------------------------------------------------
+; |head   |   #f   | chunked      || 1. Output the headers only.
+; |-------------------------------|| 2. Don't add the connection-close header.
+; |head   |   #f   | not-chunked  ||
+; |-----------------------------------------------------------------------------
+
+  ;; Table 2. get responses:
+; ------------------------------------------------------------------------------
+; |method | x-fer-coding | close? || response actions
+; |-----------------------------------------------------------------------------
+; |-----------------------------------------------------------------------------
+; | get   | chunked      |   #t   || 1. Output headers as above.
+; |       |              |        || 2. Generate trivial chunked response.
+; |-----------------------------------------------------------------------------
+; | get   | chunked      |   #f   || 1. Output headers as above.
+; |       |              |        || 2. Generate chunks as per RFC 2616 sec. 3.6
+; |-----------------------------------------------------------------------------
+; | get   | not chunked  |   #t   || 1. Output headers as above.
+; |-------------------------------|| 2. Generate usual non-chunked response.
+; | get   | not chunked  |   #f   ||
+; |-----------------------------------------------------------------------------
+
+  ;; Notes:
+  ;; 1. close? is a boolean which corresponds roughly to the protocol version.
+  ;;    #t |-> 1.0 and #f |-> 1.1. See function close-connection? in
+  ;;    #request-parsing.ss
+  ;;
+  ;; 2. In the case of a chunked response when close? = #f, then the response
+  ;;    must be compliant with http 1.0. In this case the chunked response is
+  ;;    simply turned into a non-chunked one.
+
+  (define TEXT/HTML-MIME-TYPE #"text/html")
+
+
+  ;;**************************************************
+  ;; output-headers: connection number string (listof (listof String))
+  ;;                 number string -> void
+  ;; Write the headers portion of a response to an output port.
+  ;; NOTE: According to RFC 2145 the server should write HTTP/1.1
+  ;;       header for *all* clients.
+  (define (output-headers conn code message extras seconds mime)
+    (let ([o-port (connection-o-port conn)])
+      (for-each
+       (lambda (line)
+         (for-each
+          (lambda (word) (display word o-port))
+          line)
+         (fprintf o-port "\r\n"))
+       (list* `("HTTP/1.1 " ,code " " ,message)
+              `("Date: " ,(seconds->gmt-string (current-seconds)))
+              `("Last-Modified: " ,(seconds->gmt-string seconds))
+              `("Server: PLT Scheme")
+              `("Content-type: " ,mime)
+              (if (connection-close? conn)
+                  (cons `("Connection: close") extras)
+                  extras)))
+      (fprintf o-port "\r\n")))
+
+; seconds->gmt-string : Nat -> String
+; format is rfc1123 compliant according to rfc2068 (http/1.1)
+  (define (seconds->gmt-string s)
+    (let* ([local-date (seconds->date s)]
+           [date (seconds->date (- s
+                                   (date-time-zone-offset local-date)
+                                   (if (date-dst? local-date) 3600 0)))])
+      (format "~a, ~a ~a ~a ~a:~a:~a GMT"
+              (vector-ref DAYS (date-week-day date))
+              (two-digits (date-day date))
+              (vector-ref MONTHS (sub1 (date-month date)))
+              (date-year date)
+              (two-digits (date-hour date))
+              (two-digits (date-minute date))
+              (two-digits (date-second date)))))
+
+; two-digits : num -> str
+  (define (two-digits n)
+    (let ([str (number->string n)])
+      (if (< n 10) (string-append "0" str) str)))
+
+  (define MONTHS
+    #("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
+
+  (define DAYS
+    #("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"))
+
+
+
+  ;; **************************************************
+  ;; output-response: connection response -> void
+  (define (output-response conn resp)
+    (cond
+     [(response/full? resp)
+      (output-response/basic
+       conn resp (response/full->size resp)
+       (lambda (o-port)
+         (for-each
+          (lambda (str) (display str o-port))
+          (response/full-body resp))))]
+     [(response/incremental? resp)
+      (output-response/incremental conn resp)]
+     [(and (pair? resp) (string? (car resp)))
+      (output-response/basic
+       conn
+       (make-response/basic 200 "Okay" (current-seconds) (car resp) '())
+       (apply + (map
+                 (lambda (c)
+                   (if (string? c)
+                       (string-length c)
+                       (bytes-length c)))
+                 (cdr resp)))
+       (lambda (o-port)
+         (for-each
+          (lambda (str) (display str o-port))
+          (cdr resp))))]
+     [else
+      ;; TODO: make a real exception for this.
+      (with-handlers
+          ([exn:invalid-xexpr?
+            (lambda (exn)
+              (output-response/method
+                conn
+                (xexpr-exn->response exn resp)
+                'ignored))]
+           [exn? (lambda (exn)
+                   (raise exn))])
+        (let ([str (and (validate-xexpr resp) (xexpr->string resp))])
+          (output-response/basic
+           conn
+           (make-response/basic 200
+                                "Okay"
+                                (current-seconds)
+                                TEXT/HTML-MIME-TYPE
+                                '())
+           (add1 (string-length str))
+           (lambda (o-port)
+             (display str o-port)
+             (newline o-port)))))]))
+
+  ;; response/full->size: response/full -> number
+  ;; compute the size for a response/full
+  (define (response/full->size resp/f)
+    (apply + (map
+              (lambda (c)
+                (if (string? c)
+                    (string-length c)
+                    (bytes-length c)))
+              (response/full-body resp/f))))
+
+  ;; **************************************************
+  ;; output-file: connection path symbol bytes -> void
+  (define (output-file conn file-path method mime-type)
+    (output-headers conn 200 "Okay"
+                    `(("Content-length: " ,(file-size file-path)))
+                    (file-or-directory-modify-seconds file-path)
+                    mime-type)
+    (when (eq? method 'get)
+      (call-with-input-file file-path
+        (lambda (i-port) (copy-port i-port (connection-o-port conn))))))
+
+  ;; **************************************************
+  ;; output-response/method: connection response/full symbol -> void
+  ;; If it is a head request output headers only, otherwise output as usual
+  (define (output-response/method conn resp meth)
+    (cond
+     [(eqv? meth 'head)
+      (output-headers/response conn resp `(("Content-length: "
+                                            ,(response/full->size resp))))]
+     [else
+      (output-response conn resp)]))
+
+  ;; **************************************************
+  ;; output-headers/response: connection response (listof (listof string)) -> void
+  ;; Write the headers for a response to an output port
+  (define (output-headers/response conn resp extras)
+    (output-headers conn
+                    (response/basic-code resp)
+                    (response/basic-message resp)
+                    extras
+                    (response/basic-seconds resp)
+                    (response/basic-mime resp)))
+
+  ;; **************************************************
+  ;; output-response/basic: connection response number (o-port -> void) -> void
+  ;; Write a normal response to an output port
+  (define (output-response/basic conn resp size responder)
+    (output-headers/response conn resp
+                             `(("Content-length: " ,size)
+                               . ,(extras->strings resp)))
+    (responder (connection-o-port conn)))
+
+  ;; **************************************************
+  ;; output-response/incremental: connection response/incremental -> void
+  ;; Write a chunked response to an output port.
+  (define (output-response/incremental conn resp/inc)
+    (let ([o-port (connection-o-port conn)])
+      (cond
+       [(connection-close? conn)
+        (output-headers/response conn resp/inc '())
+        ((response/incremental-generator resp/inc)
+         (lambda chunks
+           (for-each (lambda (chunk) (display chunk o-port)) chunks)))]
+       [else
+        (output-headers/response conn resp/inc
+                                 `(("Transfer-Encoding: chunked")
+                                   . ,(extras->strings resp/inc)))
+        ((response/incremental-generator resp/inc)
+         (lambda chunks
+           (fprintf o-port "~x\r\n"
+                    (foldl
+                     (lambda (c acc)
+                       (if (string? c)
+                           (+ (string-length c) acc)
+                           (+ (bytes-length c) acc)))
+                     0 chunks))
+           (for-each (lambda (chunk) (display chunk o-port)) chunks)
+           (fprintf o-port "\r\n")))
+           ; one \r\n ends the last (empty) chunk and the second \r\n ends the (non-existant) trailers
+        (fprintf o-port "0\r\n\r\n")])))
+
+  ;; extras->strings: response/basic -> (listof (listof string))
+  ;; convert the response/basic-extras to the form used by output-headers
+  (define (extras->strings r/bas)
+    (map
+      (lambda (xtra)
+        (list (symbol->string (car xtra)) ": " (cdr xtra)))
+      (response/basic-extras r/bas)))
+
+  ;; Turn an exn:invalid-xexpr into a response.
+  (define (xexpr-exn->response exn x)
+    ;;; Does it matter what number I use for pretty-print-size-hook?
+    (pretty-print-size-hook (lambda (v display? op) 20))
+    (pretty-print-print-hook (pretty-print-hook/web-errors
+                               (exn:invalid-xexpr-code exn)))
+    (make-response/full
+      500 "Servlet Error"
+      (current-seconds)
+      #"text/html"
+      '()
+      (list
+        (string-append
+          "<html><head><title>Erroneous Xexpr</title></head>"
+          "<body><h1>Erroneous Xexpr</h1>"
+          "<p>An Xexpr in the servlet is malformed. The exact error is</p>"
+          "<pre>" (exn-message exn) "</pre>"
+          "<h2>The Full Xexpr Is</h2>"
+          "<pre>"
+          (let ((o (open-output-string)))
+            (pretty-print x o)
+            (get-output-string o))
+          "</pre>"))))
+
+  ;; Format everything normally, except for the erroneous data.
+  (define (pretty-print-hook/web-errors err)
+    (letrec ((f-aux (lambda (v)
+                      (cond
+                        ((equal? v err)
+                         (format
+                           (string-append
+                             "<span style='font-weight: bold; "
+                             "color: red; background-color: white;'>"
+                             "~a</span>") v))
+                        ((list? v) (string-append "("
+                                                  (string-join (map f-aux v)
+                                                               " ")
+                                                  ")"))
+                        (else (format "~a" v))))))
+      (lambda (v display? op)
+        ((if display? display write) (f-aux v) op))))
+
+  )
diff --git a/collects/web-server/servlet-builder.ss b/collects/web-server/servlet-builder.ss
new file mode 100644
index 0000000000..0901d72d40
--- /dev/null
+++ b/collects/web-server/servlet-builder.ss
@@ -0,0 +1,227 @@
+(module servlet-builder mzscheme
+  (require (lib "tool.ss" "drscheme")
+           (lib "framework.ss" "framework")
+           (lib "mred.ss" "mred")
+           (lib "unitsig.ss")
+           (lib "class.ss")
+           (lib "list.ss")
+           (lib "etc.ss")
+           (lib "pretty.ss")
+           (lib "sig.ss" "web-server")
+           (lib "min-servlet.ss" "web-server")
+           (lib "string-constant.ss" "string-constants")
+           (all-except (lib "util.ss" "web-server") translate-escapes))
+  
+  (provide tool@)
+  
+  (define tool@
+    (unit/sig drscheme:tool-exports^
+      (import drscheme:tool^)
+      
+      (define phase1 void)
+      (define phase2 void)
+      
+      ; language-prefs text% -> (listof s-expr)
+      ; to read the program from the definitions window
+      (define (read-program lang-prefs definitions-text)
+        (let* ([language (drscheme:language-configuration:language-settings-language lang-prefs)]
+               [settings (drscheme:language-configuration:language-settings-settings lang-prefs)]
+               [front-end (send language front-end/complete-program
+                                (drscheme:language:make-text/pos
+                                 definitions-text
+                                 0 ; (drscheme:language:get-post-hash-bang-start definitions-text)
+                                 (send definitions-text last-position))
+                                settings)])
+          (let loop ()
+            (let ([x (front-end)])
+              (cond
+                [(syntax? x) (cons (syntax-object->datum x) (loop))]
+                [(eof-object? x) null]
+                [else (cons x (loop))])))))
+      
+      ; : s-expr (listof str) (listof s-expr) -> (listof s-expr)
+      (define (wrap language teachpacks program)
+        (let-values ([(require-exprs other-exprs) (extract-requires program)])
+          (let ([all-requires
+                 (list* `(require
+                          (lib "unitsig.ss")
+                          (lib "sig.ss" "web-server")
+                          (lib "min-servlet.ss" "web-server")
+                          (lib "servlet-helpers.ss" "web-server"))
+                        `(require ,language)
+                        `(require
+                          . ,(map (lambda (tp) `(file ,tp))
+                                  (filter (lambda (tp)
+                                            (not (servlet-teachpack? tp)))
+                                          teachpacks)))
+                        require-exprs)])
+            (if (includes-servlet2? teachpacks)
+                `(,@all-requires
+                  (require (lib "servlet2-unit.ss" "htdp"))
+                  (compound-unit/sig
+                    (import (S1 : servlet^))
+                    (link
+                     [S2 : servlet2^ (servlet2@ S1)]
+                     [U : () ((unit/sig ()
+                                (import servlet^ servlet2^)
+                                . ,other-exprs)
+                              S1 S2)])
+                    (export)))
+                
+                `(,@all-requires
+                  (unit/sig ()
+                    (import servlet^)
+                    . ,other-exprs))))))
+      
+      ; : (listof s-expr) -> (listof s-expr)^2
+      ; to separate a program into top level requires expressions and other expressions
+      (define (extract-requires x)
+        (let loop ([x x] [k (lambda (r o) (values r o))])
+          (cond
+            [(null? x) (k null null)]
+            [else
+             (let ([expr (car x)])
+               (loop (cdr x)
+                     (if (and (pair? expr) (eq? 'require (car expr)))
+                         (lambda (r o) (k (cons expr r) o))
+                         (lambda (r o) (k r (cons expr o))))))])))
+      
+      ; : str -> bool
+      ; to check in a full path to a teachpack refers to a servlet teachpack
+      ; FIX this - mimic how drscheme finds teachpacks
+      (define (servlet-teachpack? tp)
+        (let-values ([(base name must-be-dir?) (split-path tp)])
+          (and (string? name) (or (string=? name "servlet.ss") (string=? name "servlet2.ss")))))
+      
+      ; : (listof str) -> bool
+      (define (includes-servlet2? tps)
+        (ormap (lambda (tp)
+                 (let-values ([(base name must-be-dir?) (split-path tp)])
+                   (and (string? name) (string=? name "servlet2.ss"))))
+               tps))
+      
+      ; exn:unknown-language = (make-exn:unknown-language str mark-set str)
+      (define-struct (exn:unknown-language exn) (lang))
+      
+      ; language-prefs -> s-expr
+      ; to find the module to require for the language
+      (define (find-language-require lang-prefs)
+        (let ([lang-name
+               (send (drscheme:language-configuration:language-settings-language lang-prefs)
+                     get-language-name)])
+          (hash-table-get
+           language-table (string->symbol lang-name)
+           (lambda ()
+             (raise (make-exn:unknown-language
+                     (format "Unsupported servlet language: ~e" lang-name)
+                     (current-continuation-marks)
+                     lang-name))))))
+      
+      (define language-table
+        (let ([table (make-hash-table)])
+          (for-each (lambda (name-req)
+                      (hash-table-put! table (string->symbol (car name-req)) (cadr name-req)))
+                    (list 
+                     (list (string-constant r5rs-lang-name)
+                           `(lib "r5rs.ss" "lang"))
+                     (list (string-constant beginning-student)
+                           `(lib "htdp-beginner.ss" "lang"))
+                     (list (string-constant beginning-student/abbrev)
+                           `(lib "htdp-beginner-abbr.ss" "lang"))
+                     (list (string-constant intermediate-student)
+                           `(lib "htdp-intermediate.ss" "lang"))
+                     (list (string-constant intermediate-student/lambda)
+                           `(lib "htdp-intermediate-lambda.ss" "lang"))
+                     (list (string-constant advanced-student)
+                           `(lib "htdp-advanced.ss" "lang"))
+                     (list "Essentials of Programming Languages"
+                           `(lib "eopl.ss" "eopl"))
+                     (list (string-constant mzscheme-w/debug)
+                           `(lib "plt-mzscheme.ss" "lang"))
+                     (list (string-constant mred-w/debug)
+                           `(lib "plt-mred.ss" "lang"))
+                     (list (string-constant pretty-big-scheme)
+                           `(lib "plt-pretty-big.ss" "lang")))
+                    ; teachpacks don't work with the module language
+                    ; algol60?
+                    )
+          table))
+      
+      ; : menu% -> (U menu% #f)
+      ; to crawl up and down the menu hierarcy to find the scheme menu
+      ; This attempts to work even if
+      ; a) the menus and menu items are in a different langauge
+      ; b) the menus are in Philippe's language where they are all blank (and hence the same)
+      ; It starts by selecting the menu by position to avoid problem b).
+      ; Just to be paranoid, it looks in other positions, too.
+      ; The scheme menu must have "Create Executable..." in some language as a menu item.
+      (define (find-scheme-menu special-menu)
+        (let* ([bar (send special-menu get-parent)]
+               [menus (send bar get-items)]
+               [ordered-menus (if (< (length menus) 5)
+                                  menus
+                                  (cons (car (cddddr menus)) menus))])
+          (ormap (lambda (m)
+                   (and (string=? (string-constant scheme-menu-name)
+                                  (send m get-label))
+                        (ormap is-create-executable-item? (send m get-items))
+                        m))
+                 ordered-menus)))
+      
+      ; : menu% menu-item% -> void
+      ; to move all the menu items between "Create Executable..." and "Create Servlet..." to the end.
+      (define (arrange-scheme-menu scheme-menu servlet-item)
+        (let ([between-items
+               (let delete ([kids (let skip-first-few ([kids (send scheme-menu get-items)])
+                                    (cond
+                                      [(is-create-executable-item? (car kids)) (cdr kids)]
+                                      [else (skip-first-few (cdr kids))]))])
+                 (cond
+                   [(eq? servlet-item (car kids)) null]
+                   [else (cons (car kids) (delete (cdr kids)))]))])
+          (for-each (lambda (item) (send item delete) (send item restore)) between-items)))
+      
+      ; menu-item% -> bool
+      (define (is-create-executable-item? item)
+        (and (is-a? item labelled-menu-item<%>)
+             (string=? (string-constant create-executable-menu-item-label)
+                       (send item get-label))))
+      
+      (drscheme:get/extend:extend-unit-frame
+       (lambda (super%)
+         (class super%
+           (super-instantiate ())
+           (inherit get-definitions-text get-special-menu)
+           
+           (let ([scheme-menu (find-scheme-menu (get-special-menu))])
+             (when scheme-menu
+               (arrange-scheme-menu
+                scheme-menu
+                (instantiate menu-item% ()
+                  (label (string-constant create-servlet))
+                  (parent scheme-menu)
+                  (callback
+                   (lambda (me event)
+                     (with-handlers ([exn:unknown-language?
+                                      (lambda (exn)
+                                        (message-box (string-constant create-executable-menu-item-label)
+                                                     (format (string-constant create-servlet-unsupported-language)
+                                                             (exn:unknown-language-lang exn))
+                                                     #f
+                                                     '(ok stop)))])
+                       (let* ([lang-prefs
+                               (preferences:get
+                                (drscheme:language-configuration:get-settings-preferences-symbol))]
+                              [program (read-program lang-prefs (get-definitions-text))]
+                              [teachpacks (drscheme:teachpack:teachpack-cache-filenames (preferences:get 'drscheme:teachpacks))]
+                              [wrapped (wrap (find-language-require lang-prefs) teachpacks program)]
+                              ; FIX - use file name as default file name
+                              [file-name (put-file (string-constant create-servlet) this
+                                                   (build-path (collection-path "web-server")
+                                                               "default-web-root" "servlets")
+                                                   #f ".ss")])
+                         (when file-name
+                           (call-with-output-file file-name
+                             (lambda (out)
+                               (for-each (lambda (x) (write x out)) wrapped))
+                             'truncate))))))))))))))))
diff --git a/collects/web-server/servlet-helpers.ss b/collects/web-server/servlet-helpers.ss
new file mode 100644
index 0000000000..44ae561d88
--- /dev/null
+++ b/collects/web-server/servlet-helpers.ss
@@ -0,0 +1,158 @@
+(module servlet-helpers mzscheme
+  (require (lib "list.ss")
+           (lib "etc.ss")
+           "util.ss"
+           "response.ss"
+           "request-parsing.ss"
+           (lib "xml.ss" "xml")
+           (lib "base64.ss" "net"))
+
+  (provide extract-binding/single
+           extract-bindings
+           exists-binding?
+           extract-user-pass
+           build-suspender
+           make-html-response/incremental
+           report-errors-to-browser
+           redirect-to
+           permanently
+           temporarily
+           see-other
+           (all-from-except "request-parsing.ss" request-bindings)
+           (rename request-bindings request-bindings/raw)
+           (rename get-parsed-bindings request-bindings)
+           translate-escapes
+           )
+
+  ;; get-parsed-bindings : request -> (listof (cons sym str))
+  (define (get-parsed-bindings r)
+    (let ([x (request-bindings r)])
+      (if (list? x)
+          x
+          (parse-bindings x))))
+
+  ;; parse-bindings : (U #f String) -> (listof (cons Symbol String))
+  (define (parse-bindings raw)
+    (if (string? raw)
+        (let ([len (string-length raw)])
+          (let loop ([start 0])
+            (let find= ([key-end start])
+              (if (>= key-end len)
+                  null
+                  (if (eq? (string-ref raw key-end) #\=)
+                      (let find-amp ([amp-end (add1 key-end)])
+                        (if (or (= amp-end len) (eq? (string-ref raw amp-end) #\&))
+                            (cons (cons (string->symbol (substring raw start key-end))
+                                        (translate-escapes
+                                         (substring raw (add1 key-end) amp-end)))
+                                  (loop (add1 amp-end)))
+                            (find-amp (add1 amp-end))))
+                      (find= (add1 key-end)))))))
+        null))
+
+  ; extract-binding/single : sym (listof (cons str str)) -> str
+  (define (extract-binding/single name bindings)
+    (let ([lst (extract-bindings name bindings)])
+      (cond
+        [(null? lst)
+         (error 'extract-binding/single "~a not found in ~a" name bindings)]
+        [(null? (cdr lst)) (car lst)]
+        [else (error 'extract-binding/single "~a occurs multiple times in ~a" name bindings)])))
+
+  ; extract-bindings : sym (listof (cons str str)) -> (listof str)
+  (define (extract-bindings name bindings)
+    (map cdr (filter (lambda (x) (equal? name (car x))) bindings)))
+
+  ; exists-binding? : sym (listof (cons sym str)) -> bool
+  ; for checkboxes
+  (define (exists-binding? name bindings)
+    (if (assq name bindings)
+        #t
+        #f))
+
+  ; build-suspender : (listof html) (listof html) [(listof (cons sym str))] [(listof (cons sym str))] -> str -> response
+  (define build-suspender
+    (opt-lambda (title content [body-attributes '([bgcolor "white"])] [head-attributes null])
+      (lambda (k-url)
+        `(html (head ,head-attributes
+                     (meta ([http-equiv "Pragma"] [content "no-cache"])) ; don't cache in netscape
+                     (meta ([http-equiv "expires"] [content "-1"])) ; don't cache in IE
+                     ; one site said to use -1, another said to use 0.
+                     (title . ,title))
+               (body ,body-attributes
+                     (form ([action ,k-url] [method "post"])
+                           . ,content))))))
+
+  ; redirection-status = (make-redirection-status nat str)
+  (define-struct redirection-status (code message))
+
+  (define permanently (make-redirection-status 301 "Moved Permanently"))
+  (define temporarily (make-redirection-status 302 "Moved Temporarily"))
+  (define see-other (make-redirection-status 303 "See Other"))
+
+  ; : str [redirection-status] -> response
+  (define redirect-to
+    (opt-lambda (uri [perm/temp permanently])
+      (make-response/full (redirection-status-code perm/temp)
+                          (redirection-status-message perm/temp)
+                          (current-seconds) #"text/html"
+                          `((location . ,uri)) (list (redirect-page uri)))))
+
+  ; : str -> str
+  (define (redirect-page url)
+    (xexpr->string `(html (head (meta ((http-equiv "refresh") (url ,url)))
+                                "Redirect to " ,url)
+                          (body (p "Redirecting to " (a ([href ,url]) ,url))))))
+
+  ; make-html-response/incremental : ((string -> void) -> void) -> response/incremental
+  (define (make-html-response/incremental chunk-maker)
+    (make-response/incremental
+     200 "Okay" (current-seconds) #"text/html" '()
+     chunk-maker))
+
+  ; : (response -> doesn't) -> void
+  ; to report exceptions that occur later to the browser
+  ; this must be called at the begining of a servlet
+  (define (report-errors-to-browser send/finish-or-back)
+    (current-exception-handler
+     (lambda (exn)
+       (send/finish-or-back
+        `(html (head (title "Servlet Error"))
+               (body ([bgcolor "white"])
+                     (p "The following error occured: "
+                        (pre ,(exn->string exn)))))))))
+
+  ; Authentication
+
+  (define AUTHENTICATION-REGEXP (regexp "([^:]*):(.*)"))
+  (define (match-authentication x) (regexp-match AUTHENTICATION-REGEXP x))
+  ;:(define match-authentication (type: (str -> (union false (list str str str)))))
+
+  ; extract-user-pass : (listof (cons sym bytes)) -> (U #f (cons str str))
+  ;; Notes (GregP)
+  ;; 1. This is Basic Authentication (RFC 1945 SECTION 11.1)
+  ;;    e.g. an authorization header will look like this:
+  ;;         Authorization: Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==
+  ;; 2. Headers should be read as bytes and then translated to unicode as appropriate.
+  ;; 3. The Authorization header should have bytes (i.e. (cdr pass-pair) is bytes
+  (define (extract-user-pass headers)
+    (let ([pass-pair (assq 'authorization headers)])
+      (and pass-pair
+           (let ([basic-credentials (cdr pass-pair)])
+             (cond
+              [(and (basic? basic-credentials)
+                    (match-authentication
+                     (base64-decode (subbytes basic-credentials 6 (bytes-length basic-credentials))))
+                     )
+               => (lambda (user-pass)
+                    (cons (cadr user-pass) (caddr user-pass)))]
+              [else #f])))))
+
+  ;; basic?: bytes -> (union (listof bytes) #f)
+  ;; does the second part of the authorization header start with #"Basic "
+  (define basic?
+    (let ([basic-regexp (byte-regexp #"^Basic .*")])
+      (lambda (some-bytes)
+        (regexp-match basic-regexp some-bytes))))
+
+  )
diff --git a/collects/web-server/servlet-language.ss b/collects/web-server/servlet-language.ss
new file mode 100644
index 0000000000..2c64e667af
--- /dev/null
+++ b/collects/web-server/servlet-language.ss
@@ -0,0 +1,103 @@
+(module servlet-language mzscheme
+  (require (lib "class.ss")
+           (lib "tool.ss" "drscheme")
+           ;(lib "mred.ss" "mred")
+           (lib "unitsig.ss"))
+
+  (provide tool@)
+
+  (define tool@
+    (unit/sig drscheme:tool-exports^
+      (import drscheme:tool^)
+      (define (phase1) (void))
+      (define (phase2)
+        (add-servlet-language))
+
+      ;; add-servlet-language : -> void
+      ;; adds the servlet language to drscheme
+      (define (add-servlet-language)
+        (define servlet-language%
+          (srvlt-lang-mixin
+           ((drscheme:language:get-default-mixin)
+            (drscheme:language:module-based-language->language-mixin
+             (drscheme:language:simple-module-based-language->module-based-language-mixin
+              drscheme:language:simple-module-based-language%)))))
+        (drscheme:language-configuration:add-language
+         (instantiate servlet-language% ())))
+
+      (define servlet-language<%>
+        (interface ()
+          ))
+
+      ;; srvlt-lang-mixin : (implements drscheme:language:language<%>)
+      ;;                  -> (implements drscheme:language:language<%>)
+      (define (srvlt-lang-mixin %)
+        (class* % (servlet-language<%>)
+
+          (field [program-results #f])
+
+          (define/override (on-execute settings run-in-user-thread)
+            (set! program-results #f)
+            (super on-execute settings run-in-user-thread)
+            (run-in-user-thread
+             (lambda ()
+               (error-display-handler
+                (drscheme:debug:make-debug-error-display-handler (error-display-handler)))
+               (current-eval
+                (drscheme:debug:make-debug-eval-handler (current-eval)))
+               (with-handlers ([void (lambda (x)  (printf "~a~n" (exn-message x)))])
+                 (eval '(define start-servlet (dynamic-require '(lib "servlet-startup.ss" "web-server") 'start-servlet)))
+                 (eval '(define raw-servlet->unit/sig (dynamic-require '(lib "servlet-startup.ss" "web-server") 'raw-servlet->unit/sig)))
+                 (eval '(define create-module-servlet (dynamic-require '(lib "servlet-startup.ss" "web-server") 'create-module-servlet)))))))
+
+          (define/override (front-end/complete-program input settings teachpack-cache)
+            (let ([super-thunk (super front-end/complete-program input settings teachpack-cache)])
+              (unless program-results
+                (let loop ([continue-with-results
+                            (lambda (rslts)
+                              (set! program-results rslts))]
+                           [res-cadr #f])
+                  (let ([res-car (super-thunk)])
+                    (cond
+                      ;; end of empty definitions window
+                      [(and (eof-object? res-car)
+                            (eof-object? res-cadr))
+                       (continue-with-results '())]
+
+                      ;; end of non-empty definitions window
+                      [(and (eof-object? res-car) res-cadr)
+                       ;(continue-with-results (list #`(ignore-it #,res-cadr)))
+                       (continue-with-results (list #`(start-servlet
+                                                       (raw-servlet->unit/sig #,res-cadr))))
+                       ]
+
+                      ;; middle
+                      [res-cadr
+                       (loop
+                        (lambda (rslts)
+                          (continue-with-results (cons res-cadr rslts)))
+                        res-car)]
+
+                      ;; start of definitions window
+                      [else
+                       (loop continue-with-results res-car)])))))
+            (lambda ()
+              (if (null? program-results)
+                  eof
+                  (begin0
+                    (car program-results)
+                    (set! program-results (cdr program-results)))))
+              )
+
+          (super-instantiate ()
+            (module '(lib "plt-mred.ss" "lang"))
+
+            ;; GregP: when you settle on a name, use string-constant here
+            (language-position (list "Web Server" "Advanced Servlet"))
+
+            ;; GregP: figure out what these language-numbers are
+            ;(language-numbers (list -1000 1000))
+            ))
+
+        )))
+  )
diff --git a/collects/web-server/servlet-primitives.ss b/collects/web-server/servlet-primitives.ss
new file mode 100644
index 0000000000..4387af90b9
--- /dev/null
+++ b/collects/web-server/servlet-primitives.ss
@@ -0,0 +1,156 @@
+;; NOTES:
+;; 1. This is where the send/blah primtives are defined that get used by the
+;;    servlet and servlet2 teachpacks.
+;; 2. There's no chance that this code works anymore, and so I've excluded it
+;;    from compilation in the info.ss until I have a chance to get the
+;;    teachpacks going again.
+;; 3. In the original server, send/blah were implemented twice, once for the
+;;    normal server and then again in here for the teachpacks. Now that I've
+;;    got the new continuation model in place, I will see if I can eliminate
+;;    this redundancy.
+
+(module servlet-primitives mzscheme
+  (require "channel.ss"
+           "configuration.ss"
+           ;"configuration-structures.ss"
+           "web-server-unit.ss"
+           "min-servlet.ss"
+           ;"servlet.ss"
+           "servlet-tables.ss"
+           "internal-structs.ss"
+           ;(lib "xml.ss" "xml")
+           (lib "url.ss" "net")
+           (lib "external.ss" "browser")
+           ; more here - use contracts when they support suitable error messages
+           ;(lib "contracts.ss" "framework")
+           (lib "unitsig.ss")
+           (lib "tcp-sig.ss" "net")
+           )
+  (provide servlet@)
+
+  ; the unit doesn't contain much since it's better to start as few servers as possible
+  ; this is unitized so the servlet2.ss teachpack can work with either
+  ; the development environment or with the actual server.
+  ; more here - maybe this is not needed anymore with the parameter that
+  ; affects send/suspend.
+  (define servlet@
+    (unit/sig servlet^
+      (import)
+
+      (define send/suspend the-send/suspend)
+      (define send/finish the-send/finish)
+      (define send/back the-send/back)
+      (define send/forward the-send/forward)
+      (define initial-request the-initial-request)
+      (define adjust-timeout! the-adjust-timeout!)))
+
+  ; : num -> void
+  (define (the-adjust-timeout! n) (void))
+
+  ; send/finish : response -> doesn't
+  (define (the-send/finish page)
+    (unless (response? page)
+      (error 'send/finish "expected <response> as 1st argument, given: ~e"
+             page))
+    (output-page page)
+    (kill-thread (current-thread))
+    (set! *page-channel* #f))
+
+  ; *page-channel* : #f | channel
+  (define *page-channel* #f)
+
+  ; update-channel! : channel -> void
+  (define (update-channel! x)
+    (set! *page-channel* x))
+
+  (define *last-page-sent* #f)
+  ;(define *open-new-window* #t)
+  ; always re-use an exisiting window.
+  (define *open-new-window* #f)
+
+  ; output-page : page -> void
+  (define (output-page page)
+    (set! *last-page-sent* page)
+    ;(unless *page-channel*
+    ;  (init-channel))
+    (init-channel)
+    (async-channel-put *page-channel* page))
+
+  ; : instance -> doesn't
+  (define resume-next-request
+    (gen-resume-next-request void update-channel!))
+
+  ; init-channel : -> void
+  (define (init-channel)
+    ((gen-send/suspend uri invoke-id instances void resume-next-request)
+     (lambda (url)
+       (send-url url *open-new-window*)
+       (set! *open-new-window* #f))))
+
+  (define-values (listener port)
+    (let loop ([port 8000])
+      (with-handlers ([void (lambda (exn) (loop (add1 port)))])
+        (values (tcp-listen port 10 #f "127.0.0.1")
+                port))))
+
+  (define instances (make-hash-table))
+  (define uri (string->url (format "http://127.0.0.1:~a/servlets/" port)))
+  (define invoke-id (string->symbol (symbol->string (gensym "id"))))
+
+  ; : (str -> response) -> request
+  (define the-send/suspend
+    (lambda (k->page)
+      (let ((s/s (gen-send/suspend uri invoke-id instances output-page resume-next-request)))
+        (s/s (lambda (k-url)
+               (let ([page (k->page k-url)])
+                 (unless (response? page)
+                   (error 'send/suspend "expected <~a> as 1st argument, given a function that produced: ~e"
+                          "a function that produces a response"
+                          page))
+                 page))))))
+
+  ; : (response -> doesn't)
+  (define (the-send/back page)
+    (the-send/suspend (lambda (not-used-k-url) page)))
+
+  ; : (str -> response) -> request
+  (define (the-send/forward page-maker)
+    ;(set-servlet-instance-cont-table!
+    ; (hash-table-get invoke-id instances)
+    ; (make-hash-table))
+    ; FIX - this is wrong.  The hash table must be cleared or the reference in the server must be reset, not our reference.
+    ; try (set-config-instances! the-config (make-hash-table))
+;    (set! instances (make-hash-table))
+;    (add-new-instance invoke-id instances)
+;    (the-send/suspend page-maker))
+    (purge-table 'post uri instances invoke-id
+                 (lambda (inst) (set-servlet-instance-cont-table! inst (make-hash-table))))
+    (the-send/suspend page-maker))
+
+
+  (define the-initial-request
+    (make-request 'post uri null null "127.0.0.1" "127.0.0.1"))
+
+  (add-new-instance invoke-id instances)
+
+  ; override some configuration options
+  (define the-configuration@
+    (load-developer-configuration default-configuration-table-path))
+
+  (thread (lambda ()
+            (invoke-unit/sig
+             (compound-unit/sig
+              (import (T : net:tcp^))
+              (link
+               [c : web-config^ ((update-configuration the-configuration@ `((instances . ,instances))))]
+               [s : web-server^ (web-server@ T C)]
+               [m : () ((unit/sig ()
+                          (import web-server^)
+                          (server-loop (current-custodian)
+                                       (lambda () (tcp-accept listener))
+                                       (lambda ()
+                                         (init-channel)
+                                         (async-channel-put *page-channel* *last-page-sent*))))
+                        s)])
+              (export))
+             net:tcp^))))
diff --git a/collects/web-server/servlet-sig.ss b/collects/web-server/servlet-sig.ss
new file mode 100644
index 0000000000..281f9de215
--- /dev/null
+++ b/collects/web-server/servlet-sig.ss
@@ -0,0 +1,8 @@
+;; Default choice for writing signed-unit servlets
+;; (To write signed-unit servlets using a smaller servlet library then
+;;  require sig.ss in conjunction with min-servlet.ss
+(module servlet-sig mzscheme
+  (require "sig.ss"
+           "servlet-helpers.ss")
+  (provide (all-from "sig.ss")
+           (all-from "servlet-helpers.ss")))
diff --git a/collects/web-server/servlet-tables.ss b/collects/web-server/servlet-tables.ss
new file mode 100644
index 0000000000..99ca8fa069
--- /dev/null
+++ b/collects/web-server/servlet-tables.ss
@@ -0,0 +1,161 @@
+(module servlet-tables mzscheme
+  (require (lib "contract.ss")
+           (lib "url.ss" "net")
+           (lib "list.ss"))
+  (provide (struct exn:servlet-instance ())
+           (struct exn:servlet-continuation ())
+           (struct execution-context (connection request suspend))
+           (struct servlet-instance (id k-table custodian context mutex))
+           current-servlet-instance)
+
+  ;; current-servlet-instance. The server will parameterize
+  ;; over the current-servlet-instance before invoking a servlet
+  ;; or invoking a continuation. The current-servlet-instance
+  ;; will be in affect for the entire dynamic extent of every
+  ;; continuation associated with that instance.
+  (define current-servlet-instance (make-parameter #f))
+  (define-struct servlet-instance (id k-table custodian context mutex))
+  (define-struct execution-context (connection request suspend))
+
+  ;; Notes:
+  ;; * The servlet-instance-id is the key used for finding the servlet-instance in
+  ;;   instance table.
+  ;; * The servlet-instance-k-table stores continuations that were created
+  ;;   during this instance.
+  ;; * The servlet-instance-execution-context stores the context in which the
+  ;;   instance is executing. The servlet-instance can have only one
+  ;;   execution-context at any particular time. The execution-context will be
+  ;;   updated whenever a continuation associated with this instance is
+  ;;   invoked.
+  ;; * The servlet-instance-mutex is used to guarentee mutual-exclusion in the
+  ;;   case when it is attempted to invoke multiple continuations
+  ;;   simultaneously.
+
+  (provide/contract
+   [continuation-url? (url? . -> . (union boolean? (list/c symbol? number? number?)))]
+   [store-continuation! (procedure? url? servlet-instance? . -> . string?)]
+   [create-new-instance! (hash-table? custodian? execution-context? semaphore?
+                                      . -> . servlet-instance?)]
+   [remove-instance! (hash-table? servlet-instance? . -> . any)]
+   [clear-continuations! (servlet-instance? . -> . any)]
+   )
+
+  ;; not found in the instance table
+  (define-struct (exn:servlet-instance exn) ())
+  ;; not found in the continuatin table
+  (define-struct (exn:servlet-continuation exn) ())
+
+  (define-values (make-k-table get-k-id!)
+    (let ([id-slot 'next-k-id])
+      (values
+
+       ;; make-k-table: -> (hash-table-of continuation)
+       ;; Create a continuation table with an initial value for the next
+       ;; continuation id.
+       (lambda ()
+         (let ([k-table (make-hash-table)])
+           (hash-table-put! k-table id-slot 0)
+           k-table))
+
+       ;; get-k-id!: hash-table -> number
+       ;; get the current-continuation id and increment the internal value
+       (lambda (k-table)
+         (let ([id (hash-table-get k-table id-slot)])
+           (hash-table-put! k-table id-slot (add1 id))
+           id)))))
+
+  ;; store-continuation!: continuation execution-context servlet-instance -> url-string
+  ;; store a continuation in a k-table for the provided servlet-instance
+  (define (store-continuation! k uri inst)
+    (let ([k-table (servlet-instance-k-table inst)])
+      (let ([next-k-id (get-k-id! k-table)]
+            [salt      (random 100000000)])
+        (hash-table-put! k-table next-k-id (list k salt))
+        (embed-ids (servlet-instance-id inst) next-k-id salt uri))))
+
+  ;; clear-continuations!: servlet-instance -> void
+  ;; replace the k-table for the given servlet-instance
+  (define (clear-continuations! inst)
+    (set-servlet-instance-k-table!
+     inst
+     (make-k-table)))
+
+  ;; create-new-instance! hash-table custodian execution-context semaphore-> servlet-instance
+  (define (create-new-instance! instance-table cust ctxt sema)
+    (let* ([inst-id (string->symbol (symbol->string (gensym 'id)))]
+           [inst
+            (make-servlet-instance
+             inst-id (make-k-table) cust ctxt sema)])
+      (hash-table-put! instance-table inst-id inst)
+      inst))
+
+  ;; remove-instance!: hash-table servlet-instance -> void
+  (define (remove-instance! instance-table inst)
+    (hash-table-remove! instance-table (servlet-instance-id inst)))
+
+  ;; ********************************************************************************
+  ;; Parameter Embedding
+
+  (define URL-PARAMS:REGEXP (regexp "([^\\*]*)\\*([^\\*]*)\\*([^\\*]*)"))
+
+  (define (match-url-params x) (regexp-match URL-PARAMS:REGEXP x))
+
+  ;; embed-ids: number number number url -> string
+  ;; embedd the two numbers in a url
+  (define (embed-ids inst-id k-id salt in-url)
+    (insert-param
+     in-url
+     (format "~a*~a*~a" inst-id k-id salt)))
+
+  ;; continuation-url?: url -> (union (list number number number) #f)
+  ;; determine if this url encodes a continuation and extract the instance id and
+  ;; continuation id.
+  (define (continuation-url? a-url)
+    (let ([str (url->param a-url)])
+      (and str
+           (let ([param-match (cdr (match-url-params str))])
+             (list (string->symbol (car param-match))
+                   (string->number (cadr param-match))
+                   (string->number (caddr param-match)))))))
+
+  ;; url->param: url -> (union string #f)
+  (define (url->param a-url)
+    (let ([l (filter path/param? (url-path a-url))])
+      (and (not (null? l))
+           (path/param-param (car l)))))
+
+  ;; insert-param: url string -> string
+  ;; add a path/param to the path in a url
+  ;; (assumes that there is only one path/param)
+  (define (insert-param in-url new-param-str)
+    (url->string
+     (replace-path
+      (lambda (old-path)
+        (if (null? old-path)
+            (list (make-path/param "" new-param-str))
+            (let* ([car-old-path (car old-path)])
+              (cons (make-path/param (if (path/param? car-old-path)
+                                         (path/param-path car-old-path)
+                                         car-old-path)
+                                     new-param-str)
+                    (cdr old-path)))))
+      in-url)))
+
+  ;; replace-path: (url-path -> url-path) url -> url
+  ;; make a new url by replacing the path part of a url with a function
+  ;; of the url's old path
+  ;; also remove the query
+  (define (replace-path proc in-url)
+    (let ([new-path (proc (url-path in-url))])
+      (make-url
+       (url-scheme in-url)
+       (url-user in-url)
+       (url-host in-url)
+       (url-port in-url)
+       new-path
+       '()
+       (url-fragment in-url))))
+
+  ;; **************************************************
+
+  )
diff --git a/collects/web-server/servlet.ss b/collects/web-server/servlet.ss
new file mode 100644
index 0000000000..57401ad292
--- /dev/null
+++ b/collects/web-server/servlet.ss
@@ -0,0 +1,85 @@
+;; Default choice for writing module servlets
+(module servlet mzscheme
+  (require (lib "contract.ss")
+           (all-except "request-parsing.ss" request-bindings)
+           "servlet-tables.ss"
+           "response.ss"
+           "servlet-helpers.ss"
+           "xexpr-callback.ss")
+
+  ;; Weak contracts: the input is checked in output-response, and a message is
+  ;; sent directly to the client (Web browser) instead of the terminal/log.
+  (provide/contract
+    (send/back (any/c . -> . any))
+    (send/finish (any/c . -> . any))
+    (send/suspend ((string? . -> . any/c) . -> . request?))
+    (send/forward ((string? . -> . any/c) . -> . request?))
+    ;;; validate-xexpr/callback is not checked anywhere:
+    (send/suspend/callback (xexpr/callback? . -> . any))
+    )
+
+  (provide
+    (all-from "servlet-helpers.ss")
+    (all-from "xexpr-callback.ss")
+    )
+
+
+  ;; ************************************************************
+  ;; EXPORTS
+
+  ;; send/back: response -> void
+  ;; send a response and don't clear the continuation table
+  (define (send/back resp)
+    (let ([ctxt (servlet-instance-context (current-servlet-instance))])
+      (output-response (execution-context-connection ctxt) resp)
+      ((execution-context-suspend ctxt))))
+
+  ;; send/finish: response -> void
+  ;; send a response and clear the continuation table
+  (define (send/finish resp)
+    (clear-continuations! (current-servlet-instance))
+    (send/back resp))
+
+  ;; send/suspend: (url -> response) -> request
+  ;; send a response and apply the continuation to the next request
+  (define (send/suspend response-generator)
+    (let/cc k
+      (let* ([inst (current-servlet-instance)]
+             [ctxt (servlet-instance-context inst)])
+        (output-response
+         (execution-context-connection ctxt)
+         (response-generator
+          (store-continuation!
+           k (request-uri (execution-context-request ctxt))
+           inst)))
+        ((execution-context-suspend ctxt)))))
+
+  ;; send/forward: (url -> response) -> request
+  ;; clear the continuation table, then behave like send/suspend
+  (define (send/forward response-generator)
+    (clear-continuations! (current-servlet-instance))
+    (send/suspend response-generator))
+
+  ;; send/suspend/callback : xexpr/callback? -> void
+  ;; send/back a response with callbacks in it; send/suspend those callbacks.
+  (define (send/suspend/callback p-exp)
+    (let/cc k0
+      (send/back
+        (replace-procedures
+          p-exp (lambda (proc)
+                  (let/cc k1 (k0 (proc (send/suspend k1)))))))))
+
+
+  ;; ************************************************************
+  ;; HELPERS
+
+  ;; replace-procedures : xexpr/callbacks? (xexpr/callbacks? -> xexpr?) -> xexpr?
+  ;; Change procedures to the send/suspend of a k-url
+  (define (replace-procedures p-exp p->a)
+    (cond
+      ((list? p-exp) (map (lambda (p-e) (replace-procedures p-e p->a))
+                          p-exp))
+      ((procedure? p-exp) (p->a p-exp))
+      (else p-exp)))
+
+)
diff --git a/collects/web-server/sig.ss b/collects/web-server/sig.ss
new file mode 100644
index 0000000000..d769e14ee6
--- /dev/null
+++ b/collects/web-server/sig.ss
@@ -0,0 +1,26 @@
+(module sig mzscheme
+  (require (lib "unitsig.ss"))
+  (provide web-server^ servlet^ web-config^ web-config/pervasive^ web-config/local^)
+
+  (define-signature web-server^
+    (serve
+     serve-ports
+     ; for environment:
+     server-loop))
+  
+  (define-signature servlet^
+    (initial-request send/suspend send/finish send/back send/forward adjust-timeout!))
+
+  ; more here - rename
+  (define-signature web-config/pervasive^
+    (max-waiting 
+     virtual-hosts
+     access
+     scripts ;; : equal-hash-table
+     initial-connection-timeout))
+
+  ; more here - rename
+  (define-signature web-config/local^ (port listen-ip instances make-servlet-namespace))
+
+  (define-signature web-config^
+    ((open web-config/pervasive^) (open web-config/local^))))
\ No newline at end of file
diff --git a/collects/web-server/text-launch.ss b/collects/web-server/text-launch.ss
new file mode 100644
index 0000000000..b281c7afd9
--- /dev/null
+++ b/collects/web-server/text-launch.ss
@@ -0,0 +1,7 @@
+
+(module text-launch mzscheme
+  (require "launch.ss")
+
+  (serve)
+
+  (semaphore-wait (make-semaphore)))
diff --git a/collects/web-server/timer.ss b/collects/web-server/timer.ss
new file mode 100644
index 0000000000..9e663898e0
--- /dev/null
+++ b/collects/web-server/timer.ss
@@ -0,0 +1,40 @@
+(module timer mzscheme
+  (provide timer? start-timer reset-timer)
+
+  ; BUG: reducing the timeout is ineffective
+  ; efficiency: too many threads
+
+  (define-struct timer (expire-seconds))
+
+  ; start-timer : num (-> void) -> timer
+  ; to make a timer that calls to-do after msec from make-timer's application
+  (define (start-timer sec to-do)
+    (let ([timer (make-timer (+ (current-seconds) sec))])
+      (letrec ([snooze
+                (lambda ()
+                  (let ([remaining (- (timer-expire-seconds timer) (current-seconds))])
+                    (cond
+                      [(<= remaining 0)
+                       ; use call-in-nested-thread or something when a single thread is used for all timeouts
+                       (to-do)]
+                      [else (sleep remaining)
+                            (snooze)])))])
+        (thread snooze))
+      timer))
+
+  ; reset-timer : timer num -> void
+  ; to cause timer to expire after sec from the adjust-msec-to-live's application
+  (define (reset-timer timer sec)
+    (set-timer-expire-seconds! timer (+ sec (current-seconds)))))
+
+
+
+; --- timeout plan
+
+; start timeout on connection startup
+; for POST requests increase the timeout proportionally when content-length is read
+; adjust timeout in read-to-eof
+; adjust timeout to starting timeout for next request with persistent connections
+
+; adjust timeout proportionally when responding
+; for servlet - make it a day until the output is produced
diff --git a/collects/web-server/tools/backend-servlet-testing.ss b/collects/web-server/tools/backend-servlet-testing.ss
new file mode 100644
index 0000000000..8021c70f24
--- /dev/null
+++ b/collects/web-server/tools/backend-servlet-testing.ss
@@ -0,0 +1,97 @@
+(module backend-servlet-testing mzscheme
+  (require (lib "connection-manager.ss" "web-server")
+           (lib "servlet-tables.ss" "web-server")
+           (lib "request-parsing.ss" "web-server")
+           "backend.ss"
+           (lib "url.ss" "net")
+           (lib "xml.ss" "xml")
+           (lib "match.ss")
+           )
+
+  (provide run-servlet simple-start-servlet simple-resume-servlet)
+
+  ;; run-servlet: bindings (listof bindings) (-> response) -> boolean
+  ;; feed a bunch of requests to a servlet
+  (define (run-servlet bdg0 bdgs svt)
+    (let ((resp (simple-start-servlet
+                  (new-request/url
+                    (embed-url-bindings bdg0 (string->url "")))
+                  svt)))
+      (or (null? bdgs)
+          (resume-test bdgs (form->k-url resp)))))
+
+  ;; resume-test: (listof (listof (cons symbol string))) url -> boolean
+  ;; having a gotten a response, feed a bunch of requests to a servlet
+  (define (resume-test bdgs a-url)
+    (or (null? bdgs)
+        (let* ([resp (simple-resume-servlet
+                       (new-request/url (embed-url-bindings (car bdgs) a-url))
+                       a-url)]
+               [next-url (form->k-url resp)])
+          (resume-test (cdr bdgs) next-url))))
+
+
+  ;; Produce the k-url for the form on this page
+  ;; TODO: bad cut and paste
+  (define (form->k-url an-xexpr)
+    (string->url
+     (string-append
+      "http://nowhere.com"
+      (let recur ([sub-xexpr an-xexpr])
+        (match sub-xexpr
+          ((`form ((attrs rhss) ...) . rest)
+           (ormap (lambda (attr rhs) (and (eqv? attr 'action) rhs))
+                  attrs rhss))
+          ((tag (attrs ...) body ...) (ormap recur body))
+          (else #f))))))
+
+  ;; ****************************************
+
+  (define the-instance-table (make-hash-table))
+  (define the-instance-timeout 10)
+
+  ;; simple-start-servlet: request (-> response) -> response
+  ;; run the servlet until it produces a response
+  (define (simple-start-servlet req svt)
+    (let* ([i-port (open-input-string "")]
+           [o-port (open-output-string)]
+           [conn (new-connection 86400 i-port o-port (make-custodian) #t)])
+      (start-servlet conn req the-instance-table the-instance-timeout
+                     (lambda (adjust-timeout! initial-request)
+                       (svt)))
+      (let ([i-p (open-input-string (get-output-string o-port))])
+        (purify-port i-p)
+        (xml->xexpr (read-xml/element i-p)))))
+
+  ;; simple-resume-servlet: request url -> response
+  ;; resume the servlet continuation until it produces a response
+  (define (simple-resume-servlet req url)
+    (let* ([k-ref (continuation-url? url)]
+           [i-port (open-input-string "")]
+           [o-port (open-output-string)]
+           [conn (new-connection 86400 i-port o-port (make-custodian) #t)])
+      (resume-servlet conn req k-ref the-instance-table)
+      (let ([i-p (open-input-string (get-output-string o-port))])
+        (purify-port i-p)
+        (xml->xexpr (read-xml/element i-p)))))
+
+  ;; embed-url-bindings: (listof (cons symbol string)) url -> url
+  ;; encode bindings in a url
+  (define (embed-url-bindings env in-url)
+    (let* ((query (url-query in-url))
+           (old-env (or query '())))
+      (make-url
+       (url-scheme in-url)
+       (url-user in-url)
+       (url-host in-url)
+       (url-port in-url)
+       (url-path in-url)
+       (append env old-env)
+       (url-fragment in-url))))
+
+  ;; Produce a new request, with an url
+  (define (new-request/url new-url)
+    (make-request
+      'get new-url '() (url-query new-url) "a-host-ip" "a-client-ip"))
+
+  )
diff --git a/collects/web-server/tools/backend.ss b/collects/web-server/tools/backend.ss
new file mode 100644
index 0000000000..dc8984741c
--- /dev/null
+++ b/collects/web-server/tools/backend.ss
@@ -0,0 +1,91 @@
+(module backend mzscheme
+  (require (lib "servlet.ss" "web-server")
+           (lib "servlet-tables.ss" "web-server")
+           (lib "timer.ss" "web-server")
+           (lib "response.ss" "web-server")
+           (all-except (lib "request-parsing.ss" "web-server") request-bindings)
+           (lib "connection-manager.ss" "web-server"))
+
+  (provide start-servlet resume-servlet)
+
+  ;; make-servlet-custodian: -> custodian
+  (define make-servlet-custodian
+    (let ([cust (current-custodian)])
+      (lambda () (make-custodian cust))))
+
+  ;; start-servlet: connection request hash-table number (number->void request -> response) -> void
+  ;; start a new instance of a servlet
+  (define (start-servlet conn req instance-table instance-timeout svt)
+    (let ([sema (make-semaphore 0)])
+      (let/cc suspend
+        (let* ([servlet-custodian (make-servlet-custodian)]
+               [inst (create-new-instance!
+                      instance-table servlet-custodian
+                      (make-execution-context
+                       conn req (lambda () (suspend #t)))
+                      sema)]
+               [servlet-exit-handler (make-servlet-exit-handler inst instance-table)]
+               [time-bomb (start-timer instance-timeout
+                                       (lambda () (servlet-exit-handler #f)))])
+          (parameterize ([current-custodian servlet-custodian]
+                         [current-servlet-instance inst]
+                         [exit-handler servlet-exit-handler])
+            (with-handlers ([(lambda (x) #t)
+                             (make-servlet-exception-handler inst)])
+              (let ([r (svt (lambda (secs)
+                              (reset-timer time-bomb secs))
+                            req)])
+                (when (response? r)
+                  (send/back r)))))))
+      (semaphore-post sema)))
+
+  ;; make-servlet-exit-handler: servlet-instance -> alpha -> void
+  ;; exit handler for a servlet
+  (define (make-servlet-exit-handler inst instance-table)
+    (lambda (x)
+      (remove-instance! instance-table inst)
+      (kill-connection!
+       (execution-context-connection
+        (servlet-instance-context inst)))
+      (custodian-shutdown-all (servlet-instance-custodian inst))))
+
+  ;; make-servlet-exception-handler: host -> exn -> void
+  ;; This exception handler traps all unhandled servlet exceptions
+  (define (make-servlet-exception-handler inst)
+    (lambda (the-exn)
+      (let* ([ctxt (servlet-instance-context inst)]
+             [req (execution-context-request ctxt)])
+        (output-response/method
+         (execution-context-connection ctxt)
+         `(html (head (title "Error"))
+                (body
+                 (p "there was an error:")
+                 (p ,(exn-message the-exn))))
+         (request-method req))
+        ((execution-context-suspend ctxt)))))
+
+  ;; resume-servlet: connection request continuation-reference hash-table -> void
+  ;; pull the continuation out of the table and apply it
+  (define (resume-servlet conn req k-ref instance-table)
+    (let* ([inst (hash-table-get instance-table (car k-ref)
+                                 (lambda ()
+                                   (raise
+                                    (make-exn:servlet-instance
+                                     "" (current-continuation-marks)))))]
+           [k-table
+            (servlet-instance-k-table inst)])
+      (let/cc suspend
+        (set-servlet-instance-context!
+         inst
+         (make-execution-context
+          conn req (lambda () (suspend #t))))
+        (semaphore-wait (servlet-instance-mutex inst))
+        ((hash-table-get k-table (cadr k-ref)
+                         (lambda ()
+                           (raise
+                            (make-exn:servlet-continuation
+                             "" (current-continuation-marks)))))
+         req))
+      (semaphore-post (servlet-instance-mutex inst))))
+  )
+
diff --git a/collects/web-server/tools/send-assertions.ss b/collects/web-server/tools/send-assertions.ss
new file mode 100644
index 0000000000..4890320440
--- /dev/null
+++ b/collects/web-server/tools/send-assertions.ss
@@ -0,0 +1,165 @@
+;; Drive a servlet. Pretend to be a Web browser, and send a request to the
+;; server. Produce the response.
+
+(module send-assertions mzscheme
+  (require (lib "contract.ss")
+           (lib "test.ss" "schemeunit")
+           (lib "etc.ss")
+           (lib "match.ss")
+           "servlet-testing-framework.ss"
+           (lib "servlet.ss" "web-server"))
+
+  (provide
+    assert-output-response/suspended
+    (struct unknown ())
+    hyperlink->k-url
+    form->k-url)
+
+  ;; The unknown value
+  (define-struct unknown () (make-inspector))
+
+  #|
+  (define in?
+    (union
+      (list-immutable/c (xexpr/callback? . -> . string?)
+                        (listof (cons/c symbol? string?)))
+      (symbols 'back 'forward)
+      (list-immutable/c (xexpr/callback? . -> . string?)
+                        (listof (cons/c symbol? string?))
+                        (listof (cons/c symbol? string?)))))
+  |#
+
+  ;; Ensure output-response produces the right value. Feed the send/suspends.
+  ;; (-> response) (listof in?) xexpr? . -> . boolean?
+  (define (assert-output-response/suspended outputter ins out)
+    (special-equal?
+      (assert-loop ins (start-servlet outputter) 0 '())
+      out))
+
+  ;; A history is a
+  ;; (make-history string? (listof (cons/p symbol? string?))
+  ;;                       (union #f (listof (cons/p symbol? string?)))
+  (define-struct history (k-url bindings headers))
+
+  ;; Go over the input list, resuming the servlet on each choice, until the
+  ;; end. Support the back-button with an indexed list.
+  ;; This is written in a pattern-matching style to increment/decrement the
+  ;; counter correctly, and do any sanity checks (e.g. 'forward after a
+  ;; non-'back).
+  (define (assert-loop ins r i hs)
+    (let ((forward-error (make-exn:fail:contract:variable
+                           (string->immutable-string
+                             "Cannot go forward more times than back")
+                           (current-continuation-marks)
+                           'blah)))
+      (match ins
+        (('back 'back . ls) (assert-loop (cons 'back ls)
+                                         (resumer (list-ref hs (add1 i)))
+                                         (add1 i)
+                                         hs))
+        (('back 'forward . ls) (assert-loop (cons 'forward ls)
+                                            (resumer (list-ref hs (add1 i)))
+                                            (add1 i)
+                                            hs))
+        (('back l . ls) (assert-loop (cons l ls)
+                                     (resumer (list-ref hs (add1 i)))
+                                     0
+                                     (list-tail hs (add1 i))))
+        (('forward 'back . ls) (if (> i 0)
+                                 (assert-loop (cons 'back ls)
+                                              (resumer (list-ref hs (sub1 i)))
+                                              (sub1 i)
+                                              hs)
+                                 (raise forward-error)))
+        (('forward 'forward . ls) (if (> i 0)
+                                    (assert-loop (cons 'forward ls)
+                                                 (resumer (list-ref hs (sub1 i)))
+                                                 (sub1 i)
+                                                 hs)
+                                    (raise forward-error)))
+        (('forward l . ls) (if (> i 0)
+                             (assert-loop (cons l ls)
+                                          (resumer (list-ref hs (sub1 i)))
+                                          0
+                                          (list-tail (sub1 i)))
+                             (raise forward-error)))
+        ((l 'back . ls) (let ((h (history/list l r)))
+                          (assert-loop (cons 'back ls)
+                                       (resumer h)
+                                       0
+                                       (cons h hs))))
+        ((l n . ls) (if (and (symbol? n) (symbol=? n 'forward))
+                      (raise forward-error)
+                      (let ((h (history/list l r)))
+                        (assert-loop (cons n ls)
+                                     (resumer h)
+                                     0
+                                     (cons h hs)))))
+        (('back) (resumer (list-ref hs (add1 i))))
+        (('forward) (if (> i 0)
+                      (resumer (list-ref hs (sub1 i)))
+                      (raise forward-error)))
+        ((l) (resumer (history/list l r)))
+        ((? null?) r))))
+
+  ;; history/list : (union (list/p (xexpr? . -> . string?)
+  ;;                               (listof (cons/p symbol? string?)))
+  ;;                       (list/p (xexpr? . -> . string?)
+  ;;                               (listof (cons/p symbol? string?))
+  ;;                               (listof (cons/p symbol? string?))))
+  ;;                response? . -> . history?
+  (define (history/list l r)
+    (let ((k-url ((car l) r)))
+      (if k-url
+        (cond
+          ((= (length l) 2) (make-history k-url (cadr l) #f))
+          ((= (length l) 3) (make-history k-url (cadr l) (caadr l))))
+        (fail (format "~a~n~v~n~a~v~n"
+                       "Failed to match the response" r
+                       "with the function" (car l))))))
+
+  ;; resumer : history? . -> . response?
+  ;; Resume the servlet correctly.
+  (define (resumer a-history)
+    (if (history-headers a-history)
+      (resume-servlet/headers (history-k-url a-history)
+                              (history-bindings a-history)
+                              (history-headers a-history))
+      (resume-servlet (history-k-url a-history)
+                      (history-bindings a-history))))
+
+  ;; True if:
+  ;;  a or b is `unknown'
+  ;;  a and b are not pairs and are equal?
+  ;;  a and b are pairs and their car and cdr are special-equal?
+  (define (special-equal? a b)
+    (cond
+      ((or (unknown? a) (unknown? b)) #t)
+      ((and (not (pair? a)) (not (pair? b))) (equal? a b))
+      ((and (pair? a) (pair? b)) (and (special-equal? (car a) (car b))
+                                      (special-equal? (cdr a) (cdr b))))
+      (else (equal? a b))))
+
+  ;; Produce the k-url for the form on this page
+  (define form->k-url
+    (match-lambda
+      ((`form ((attrs rhss) ...) . rest)
+       (ormap (lambda (attr rhs) (and (eqv? attr 'action) rhs))
+              attrs rhss))
+      ((tag (attrs ...) body ...) (ormap form->k-url body))
+      (else #f)))
+
+  ;; Produce the k-url used for the next part of the form
+  ;; (xexpr/callback? . -> . (union false? string?))
+  (define-syntax hyperlink->k-url
+    (syntax-rules ()
+      ((_ str)
+       (letrec ((f (match-lambda
+                     (('a ((attrs rhss) (... ...)) str)
+                      (ormap (lambda (attr rhs) (and (eqv? attr 'href) rhs))
+                             attrs rhss))
+                     ((tag (attrs (... ...)) body (... ...)) (ormap f body))
+                     (else #f))))
+         f))))
+
+ )
diff --git a/collects/web-server/tools/servlet-testing-framework.ss b/collects/web-server/tools/servlet-testing-framework.ss
new file mode 100644
index 0000000000..580b5c9a48
--- /dev/null
+++ b/collects/web-server/tools/servlet-testing-framework.ss
@@ -0,0 +1,139 @@
+;; The idea is to mimick the entire Web server as part of the framework for
+;; this testing infrastructure. Copy most of this stuff from v299. The v299 Web
+;; server was written with the assumption that continuations exist across
+;; threads; this is not the case in the exp Web server. As a result, only one
+;; thread should be used at a time.
+
+;; Since the real send/* are used, with their full continuation table, one can
+;; use this to fully pretend to be a Web browser, including back buttons and
+;; cloning Web pages.
+(module servlet-testing-framework mzscheme
+  (require (lib "match.ss")
+           (lib "list.ss")
+           (lib "url.ss" "net")
+           (lib "uri-codec.ss" "net")
+           (lib "xml.ss" "xml")
+
+           (lib "servlet.ss" "web-server")
+           (lib "servlet-tables.ss" "web-server")
+           (lib "connection-manager.ss" "web-server")
+           (lib "timer.ss" "web-server")
+           (all-except (lib "request-parsing.ss" "web-server")
+                       request-bindings)
+           )
+
+  (provide start-servlet resume-servlet resume-servlet/headers)
+
+  ;; Start the servlet
+  (define (start-servlet svt)
+    (run-servlet (new-request) svt))
+
+  (define the-instance
+    (make-servlet-instance 'id0 (make-hash-table) 0 (make-semaphore 0)))
+
+  ;; new-servlet-context: request o-port (-> void) -> servlet-context
+  (define (new-servlet-context req op suspend )
+    (make-servlet-context
+      the-instance
+      (let ((cust (make-custodian)))
+        (make-connection
+          (start-timer 15 (lambda () (custodian-shutdown-all cust)))
+          (open-input-string "foo") op cust #t))
+      req
+      suspend))
+
+   ;; run-servlet: request string -> s-expression
+   ;; Run a servlet and return its next response. Note that the servlet may be a
+   ;; continuation.
+   (define (run-servlet req svt)
+     (let* ((cust (make-custodian))
+            (result-channel (make-channel))
+            (op (open-output-string))
+            (sc (new-servlet-context
+                  req op
+                  (make-suspender result-channel op cust))))
+       (parameterize ((current-custodian cust))
+         (thread
+           (lambda ()
+             (thread-cell-set! current-servlet-context sc)
+             (svt))))
+       (channel-get result-channel)))
+
+   ;; make-suspender: channel o-port custodian -> (-> void)
+   (define (make-suspender result-channel op cust)
+     (lambda ()
+       (channel-put
+         result-channel
+         (let ((ip (open-input-string (get-output-string op))))
+           (purify-port ip)
+           (xml->xexpr (read-xml/element ip))))))
+
+  (define (resume-servlet/headers prev-url input headers)
+    (with-handlers
+      ((exn:fail:contract?
+         (lambda (e)
+           `(html (head (title "Timeout"))
+                  (body
+                    (p "The transaction referred to by this url is no longer "
+                       "active.  Please "
+                       (a ((href ,(servlet-instance-k-table the-instance)))
+                          "restart")
+                       " the transaction."))))))
+    (let ((u (string->url prev-url)))
+      (cond
+        ((continuation-url? u)
+         => (lambda (res)
+              (let ((k (hash-table-get (servlet-instance-k-table the-instance)
+                                       (cadr res)))
+                    (new-req (new-request/url+headers
+                               (embed-url-bindings input u) headers)))
+                (run-servlet new-req (lambda () (k new-req))))))
+        (else (error "url doesn't encode a servlet continuation"))))))
+
+  ;; Resume the servlet
+  (define (resume-servlet prev-url input)
+    (resume-servlet/headers prev-url input '()))
+
+  ;; embed-url-bindings: (listof (cons string string)) url -> url
+  ;; encode bindings in a url
+  (define (embed-url-bindings env in-url)
+    (let* ((query (url-query in-url))
+           (old-env (or query '())))
+      (make-url
+        (url-scheme in-url)
+        (url-user in-url)
+        (url-host in-url)
+        (url-port in-url)
+        (url-path in-url)
+        (append env old-env)
+        (url-fragment in-url))))
+
+  (define (remove-query an-url)
+    (make-url
+      (url-scheme an-url)
+      (url-user an-url)
+      (url-host an-url)
+      (url-port an-url)
+      (url-path an-url)
+      '()
+      (url-fragment an-url)))
+
+  ;; Produce a new request
+  (define (new-request)
+    (new-request/bindings '()))
+
+  ;; Produce a new request, with an url
+  (define (new-request/url new-url)
+    (new-request/url+headers new-url '()))
+
+  ;; Produce a new request, with an url and headers
+  (define (new-request/url+headers new-url headers)
+    (make-request 'get (remove-query new-url) headers (url-query new-url)
+                  "a-host-ip" "a-client-ip"))
+
+  ;; Produce a new request, with bindings
+  (define (new-request/bindings bs)
+    (make-request 'get (string->url "http://www.example.com/") '() bs
+                  "a-host-ip" "a-client-ip"))
+
+  )
diff --git a/collects/web-server/tools/test-send-assertions.ss b/collects/web-server/tools/test-send-assertions.ss
new file mode 100644
index 0000000000..588ef71ae2
--- /dev/null
+++ b/collects/web-server/tools/test-send-assertions.ss
@@ -0,0 +1,61 @@
+(module test-send-assertions mzscheme
+  (require (lib "test.ss" "schemeunit")
+           (lib "servlet.ss" "web-server")
+           "send-assertions.ss"
+           )
+
+  (provide test-send-assertions)
+
+  (define test-send-assertions
+    (make-test-suite
+      "Test the test suite that tests send/*"
+
+      (make-test-case
+        "Test send/finish"
+        (assert-output-response/suspended
+          (lambda () (send/finish '(p "The output")))
+          '()
+          '(p () "The output")))
+
+      (make-test-case
+        "Test send/suspend and send/finish"
+        (assert-output-response/suspended
+          (lambda ()
+            (let ((num (extract-binding/single
+                         'num
+                         (request-bindings
+                           (send/suspend
+                             (lambda (k-url)
+                               `(form ((action ,k-url)) (input ((name "num"))))))))))
+              (send/finish `(p ,num))))
+          (list (cons (lambda (x) (cadr (car (cadr x))))
+                      (list (cons 'num "5"))))
+          '(p () "5")))
+
+      (make-test-case
+        "Test send/suspend/callback once"
+        (assert-output-response/suspended
+          (lambda ()
+            (send/suspend/callback
+              `(p () (a ((href ,(lambda (req) (send/finish '(p "Finished")))))
+                        "Next"))))
+          (list (cons (lambda (x) (cadr (car (cadr (caddr x)))))
+                      '()))
+          '(p () "Finished")))
+
+      (make-test-case
+        "Test mutual send/suspend/callbacks"
+        (assert-output-response/suspended
+          (lambda ()
+            (letrec ((p1 `(p () (a ((href ,(lambda (req) (send/suspend/callback p2))))
+                                   "Next")))
+                     (p2 `(p () (a ((href ,(lambda (req) (send/suspend/callback p1))))
+                                   "Previous"))))
+              (send/suspend/callback p1)))
+          (list (cons (lambda (x) (cadr (car (cadr (caddr x))))) '())
+                (cons (lambda (x) (cadr (car (cadr (caddr x))))) '()))
+          `(p () (a ((href ,(make-unknown))) "Next")))))
+
+    )
+
+  )
diff --git a/collects/web-server/util.ss b/collects/web-server/util.ss
new file mode 100644
index 0000000000..1218ba8eac
--- /dev/null
+++ b/collects/web-server/util.ss
@@ -0,0 +1,272 @@
+(module util mzscheme
+  (require (lib "contract.ss")
+           (lib "string.ss")
+           (lib "list.ss")
+           (lib "url.ss" "net")
+           (lib "errortrace-lib.ss" "errortrace"))
+  
+  (provide provide-define-struct
+           extract-flag
+           translate-escapes
+           hash-table-empty?)
+  
+  (provide/contract
+   [path->list  (path? . -> . (cons/c (union path? (symbols 'up 'same))
+                                      (listof (union path? (symbols 'up 'same)))))]
+   [url-path->path ((union (symbols 'up 'same) path?) string? . -> . path?)]
+   [directory-part (path? . -> . path?)]
+   [lowercase-symbol! ((union string? bytes?) . -> . symbol?)]
+   [exn->string ((union exn? any/c) . -> . string?)]
+   [get-mime-type (path? . -> . bytes?)]
+   [build-path-unless-absolute (path? (union string? path?) . -> . path?)])
+  
+  ;; build-path-unless-absolute : path (union string? path?) -> path?
+  (define (build-path-unless-absolute base path)
+    (if (absolute-path? path)
+        (build-path path)
+        (build-path base path)))
+  
+  ;; exn->string : (union exn any) -> string
+  ;; builds an error message, including errortrace annotations (if present)
+  ;; TODO: do we really need this? Ask Robby about better ways to print exceptions.
+  (define (exn->string exn)
+    (if (exn? exn)
+        (let ([op (open-output-string)])
+          (display (exn-message exn) op)
+          (newline op)
+          (print-error-trace op exn)
+          (get-output-string op))
+        (format "~s\n" exn)))
+  
+  ; lowercase-symbol! : (union string bytes) -> symbol
+  (define (lowercase-symbol! s)
+    (let ([s (if (bytes? s)
+                 (bytes->string/utf-8 s)
+                 s)])
+      (string-lowercase! s)
+      (string->symbol s)))
+  
+  ; prefix? : str -> str -> bool
+  ; more here - consider moving this to mzlib's string.ss
+  ;; Notes: (GregP)
+  ;; 1. What's the significance of char # 255 ???
+  ;; 2. 255 isn't an ascii character. ascii is 7-bit
+  ;; 3. OK fuck this. It is only used in three places, some of them
+  ;;    will involve bytes while the others may involve strings. So
+  ;;    I will just use regular expressions and get on with life.
+  (define (prefix?-old prefix)
+    (let* ([len (string-length prefix)]
+           [last (string-ref prefix (sub1 len))]
+           [ascii (char->integer last)])
+      (if (= 255 ascii)
+          ; something could be done about this - ab255 -> ac
+          ; and all 255's eliminates upper range check
+          (error 'prefix? "prefix can't end in the largest character")
+          (let ([next (string-append (substring prefix 0 (sub1 len))
+                                     (string (integer->char (add1 ascii))))])
+            (lambda (x)
+              (and (string<=? prefix x) (string<? x next)))))))
+  
+  
+  ;; get-mime-type: path -> bytes
+  ;; determine the mime type based on the filename's suffix
+  ;;
+  ;; Notes (GregP):
+  ;; 1. Can we determine the mime type based on file contents?
+  ;; 2. Assuming that 7-bit ASCII is correct for mime-type
+  (define get-mime-type
+    (let ([file-suffix-regexp (byte-regexp #".*\\.([^\\.]*$)")])
+      (lambda (path)
+        (let ([sffx (cadr (regexp-match file-suffix-regexp (path->bytes path)))])
+          (hash-table-get MIME-TYPE-TABLE
+                          (lowercase-symbol! sffx)
+                          ;(string->symbol (bytes->string/utf-8 sffx))
+                          (lambda () DEFAULT-MIME-TYPE))))))
+  
+  
+  (define DEFAULT-MIME-TYPE #"text/plain")
+  
+  (define MIME-TYPE-TABLE
+    (let ([table (make-hash-table)])
+      (for-each (lambda (x) (hash-table-put! table (car x) (cdr x)))
+                '((htm  . #"text/html")
+                  (html . #"text/html")
+                  (css  . #"text/css")
+                  (txt  . #"text/plain")
+                  (hqx  . #"application/mac-binhex40")
+                  (doc  . #"application/msword")
+                  (plt  . #"application/octet-stream")
+                  (w02  . #"application/octet-stream")
+                  (w03  . #"application/octet-stream")
+                  (exe  . #"application/octet-stream")
+                  (bin  . #"application/octet-stream")
+                  (pdf  . #"application/pdf")
+                  (ps   . #"application/postscript")
+                  (rtf  . #"application/rtf")
+                  (dvi  . #"application/x-dvi")
+                  (tar  . #"application/x-tar")
+                  (tex  . #"application/x-tex")
+                  (zip  . #"application/zip")
+                  (xls  . #"application/msexcel")
+                  (ppt  . #"application/powerpoint")
+                  (pot  . #"application/powerpoint")
+                  (ppf  . #"application/persuasion")
+                  (fm   . #"application/filemaker")
+                  (pm6  . #"application/pagemaker")
+                  (psd  . #"application/x-photoshop")
+                  (pdd  . #"application/x-photoshop")
+                  (ram  . #"audio/x-pn-realaudio")
+                  (ra   . #"audio/x-realaudio")
+                  (swf  . #"application/x-shockwave-flash")
+                  (aif  . #"audio/aiff")
+                  (au   . #"audio/basic")
+                  (voc  . #"audio/voice")
+                  (wav  . #"audio/wave")
+                  (mov  . #"video/quicktime")
+                  (mpg  . #"video/mpeg")
+                  (png  . #"image/png")
+                  (bmp  . #"image/bmp")
+                  (gif  . #"image/gif")
+                  (jpg  . #"image/jpeg")
+                  (tif  . #"image/tiff")
+                  (pic  . #"image/x-pict")))
+      table))
+  
+  (define (directory-part path)
+    (let-values ([(base name must-be-dir) (split-path path)])
+      (cond
+        [(eq? 'relative base) (current-directory)]
+        [(not base) (error 'directory-part "~a is a top-level directory" path)]
+        [(path? base) base])))
+
+  ; more here - ".." should probably raise an error instead of disappearing.
+  (define (url-path->path base p)
+    (let ((path-elems (chop-string #\/ p)))
+      ;;; Hardcoded, bad, and wrong
+      (if (or (string=? (car path-elems) "servlets")
+              (and (string=? (car path-elems) "")
+                   (string=? (cadr path-elems) "servlets")))
+          ;; Servlets can have extra stuff after them
+          (let loop ((p-e (if (string=? (car path-elems) "")
+                              (cddr path-elems)
+                              (cdr path-elems)))
+                     (f (build-path base 
+                                    (if (string=? (car path-elems) "")
+                                        (cadr path-elems)
+                                        (car path-elems)))))
+            (cond
+              ((null? p-e) f)
+              ((directory-exists? f) (loop (cdr p-e) (build-path f (car p-e))))
+              ((file-exists? f) f)
+              (else f))) ;; Don't worry about e.g. links for now
+          ; spidey can't check build-path's use of only certain symbols
+          (apply build-path base
+                 (foldr (lambda (x acc)
+                          (cond
+                            [(string=? x "") acc]
+                            [(string=? x ".") acc]
+                            [(string=? x "..") acc] ; ignore ".." (cons 'up acc)]
+                            [else (cons x acc)]))
+                        null
+                        (chop-string #\/ p))))))
+  
+  ; update-params : Url (U #f String) -> String
+  ; to create a new url just like the old one, but with a different parameter part
+  ;; GREGP: this is broken! replace with the version from new-kernel
+  ;  (define (update-params uri params)
+  ;    (url->string
+  ;     (make-url (url-scheme uri)
+  ;               (url-user uri)
+  ;               (url-host uri)
+  ;               (url-port uri)
+  ;               (url-path uri)
+  ;               params
+  ;               (url-query uri)
+  ;               (url-fragment uri))))
+  
+  ; to convert a platform dependent path into a listof path parts such that
+  ; (forall x (equal? (path->list x) (path->list (apply build-path (path->list x)))))
+  (define (path->list p)
+    (let loop ([p p] [acc null])
+      (let-values ([(base name must-be-dir?) (split-path p)])
+        (let ([new-acc (cons name acc)])
+          (cond
+            [(string? base) (loop base new-acc)]
+            [else ; conflate 'relative and #f
+             new-acc])))))
+  
+  ; chop-string : Char String -> (listof String)
+  (define (chop-string separator s)
+    (let ([p (open-input-string s)])
+      (let extract-parts ()
+        (cons (list->string
+               (let part ()
+                 (let ([char (peek-char p)])
+                   (cond
+                     [(eof-object? char) null]
+                     [else (cond
+                             [(eq? separator char) null]
+                             [else (read-char p) (cons char (part))])]))))
+              (cond
+                [(eof-object? (read-char p)) null]
+                [else (extract-parts)])))))
+  
+  
+  ; this should go somewhere that other collections can use it too
+  (define-syntax provide-define-struct
+    (lambda (stx)
+      (syntax-case stx ()
+        [(_ (struct-name parent-name) (field ...))
+         (syntax (begin (define-struct (struct-name parent-name) (field ...))
+                        (provide (struct struct-name (field ...)))))]
+        [(_ struct-name (field ...))
+         (syntax (begin (define-struct struct-name (field ...))
+                        (provide (struct struct-name (field ...)))))])))
+  
+  ; this is used by launchers
+  ; extract-flag : sym (listof (cons sym alpha)) alpha -> alpha
+  (define (extract-flag name flags default)
+    (let ([x (assq name flags)])
+      (if x
+          (cdr x)
+          default)))
+  
+  ; hash-table-empty? : hash-table -> bool
+  (define (hash-table-empty? table)
+    (let/ec out
+      (hash-table-for-each table (lambda (k v) (out #f)))
+      #t))
+  
+  ; This comes from Shriram's collection, and should be exported form there.
+  ; translate-escapes : String -> String
+  (define-struct servlet-error ())
+  (define-struct (invalid-%-suffix servlet-error) (chars))
+  (define-struct (incomplete-%-suffix invalid-%-suffix) ())
+  (define (translate-escapes raw)
+    (list->string
+     (let loop ((chars (string->list raw)))
+       (if (null? chars) null
+           (let ((first (car chars))
+                 (rest (cdr chars)))
+             (let-values (((this rest)
+                           (cond
+                             ((char=? first #\+)
+                              (values #\space rest))
+                             ((char=? first #\%)
+                              ; MF: I rewrote this code so that Spidey could eliminate all checks.
+                              ; I am more confident this way that this hairy expression doesn't barf.
+                              (if (pair? rest)
+                                  (let ([rest-rest (cdr rest)])
+                                    (if (pair? rest-rest)
+                                        (values (integer->char
+                                                 (or (string->number (string (car rest) (car rest-rest)) 16)
+                                                     (raise (make-invalid-%-suffix
+                                                             (if (string->number (string (car rest)) 16)
+                                                                 (car rest-rest)
+                                                                 (car rest))))))
+                                                (cdr rest-rest))
+                                        (raise (make-incomplete-%-suffix rest))))
+                                  (raise (make-incomplete-%-suffix rest))))
+                             (else (values first rest)))))
+               (cons this (loop rest))))))))
+  )
diff --git a/collects/web-server/web-server-unit.ss b/collects/web-server/web-server-unit.ss
new file mode 100644
index 0000000000..26d92c9ea2
--- /dev/null
+++ b/collects/web-server/web-server-unit.ss
@@ -0,0 +1,660 @@
+(module web-server-unit mzscheme
+  (require "sig.ss"
+           "connection-manager.ss"
+           (all-except "request-parsing.ss" request-bindings)
+           "configuration-structures.ss"
+           "util.ss"
+           "response.ss"
+           "servlet-tables.ss"
+           "servlet.ss"
+           "servlet-helpers.ss"
+           "timer.ss"
+           (lib "tcp-sig.ss" "net")
+           (lib "unitsig.ss")
+           (lib "string.ss")
+           (lib "url.ss" "net")
+           (lib "xml.ss" "xml")
+           )
+  (provide web-server@)
+
+  (define myprint
+    (lambda args
+      (apply fprintf (cons (current-error-port) args))))
+
+
+  ;; ****************************************
+  ;; stick this auxilliary outside the unit so
+  ;; I can get at it with require/expose
+
+  ;; get-host : Url (listof (cons Symbol String)) -> String
+  ;; host names are case insesitive---Internet RFC 1034
+  (define DEFAULT-HOST-NAME "<none>")
+  (define (get-host uri headers)
+    (let ([lower!
+           (lambda (s)
+             (string-lowercase! s)
+             s)])
+      (cond
+        [(url-host uri) => lower!]
+        [(assq 'host headers)
+         =>
+         (lambda (h) (lower! (bytes->string/utf-8 (cdr h))))]
+        [else DEFAULT-HOST-NAME])))
+
+  ;; ****************************************
+
+  (define web-server@
+    (unit/sig web-server^
+      (import net:tcp^ (config : web-config^))
+
+      (define current-server-custodian (make-parameter #f))
+
+      ;; make-servlet-custodian: -> custodian
+      ;; create a custodian for the dynamic extent of a servlet continuation
+      (define (make-servlet-custodian)
+        (make-custodian (current-server-custodian)))
+
+      ;; serve: -> -> void
+      ;; start the server and return a thunk to shut it down
+      (define (serve)
+        (let ([the-server-custodian (make-custodian)])
+          (start-connection-manager the-server-custodian)
+          (parameterize ([current-custodian the-server-custodian]
+                         [current-server-custodian the-server-custodian])
+            (let ([get-ports
+                   (let ([listener (tcp-listen config:port config:max-waiting
+                                               #t config:listen-ip)])
+                     (lambda () 
+                       (let-values ([(ip op) (tcp-accept listener)])
+                         (file-stream-buffer-mode op 'none)
+                         (values ip op))))])
+              (thread
+               (lambda ()
+                 (server-loop get-ports)))))
+          (lambda ()
+            (custodian-shutdown-all the-server-custodian))))
+
+      ;; server-loop: (-> i-port o-port) -> void
+      ;; start a thread to handle each incoming connection
+      (define (server-loop get-ports)
+        (let loop ()
+          (let ([connection-cust (make-custodian)])
+            (parameterize ([current-custodian connection-cust])
+              (let-values ([(ip op) (get-ports)])
+                (thread
+                 (lambda ()
+                   (serve-connection
+                    (new-connection config:initial-connection-timeout
+                                    ip op (current-custodian) #f))))))
+            (loop))))
+
+      ;; serve-ports : input-port output-port -> void
+      ;; returns immediately, spawning a thread to handle
+      ;; the connection
+      ;; NOTE: this doesn't use a connection manager since
+      ;;       connection managers don't do anything anyways. -robby
+      ;; NOTE: (GregP) should allow the user to pass in a connection-custodian
+      (define (serve-ports ip op)
+        (let ([connection-cust (make-custodian)]
+              [server-cust (make-custodian)])
+          (parameterize ([current-custodian connection-cust]
+                         [current-server-custodian server-cust])
+            (thread
+             (lambda ()
+               (serve-connection
+                (new-connection config:initial-connection-timeout
+                                ip op connection-cust #f)))))))
+
+      ;; serve-connection: connection -> void
+      ;; respond to all requests on this connection
+      (define (serve-connection conn)
+        (let connection-loop ()
+          (let-values ([(req close?) (read-request (connection-i-port conn))])
+            (let* ([host (get-host (request-uri req) (request-headers req))]
+                   [host-conf (config:virtual-hosts host)])
+              ((host-log-message host-conf) (request-host-ip req)
+               (request-client-ip req) (request-method req) (request-uri req) host)
+              (set-connection-close?! conn close?)
+              (dispatch conn req host-conf)
+              (adjust-connection-timeout! conn config:initial-connection-timeout)
+              (cond
+                [close? (kill-connection! conn)]
+                [else (connection-loop)])))))
+
+
+
+      ;; dispatch: connection request host -> void
+      ;; NOTE: (GregP) I'm going to use the dispatch logic out of v208 for now.
+      ;;       I will move the other  dispatch logic out of the prototype
+      ;;       at a later time.
+      (define (dispatch conn req host-info)
+        (let* ([uri (request-uri req)]
+               [method (request-method req)]
+               [path (translate-escapes (url-path->string (url-path uri)))])
+          (cond
+           [(access-denied? method path (request-headers req) host-info
+                            config:access)
+            => (lambda (realm)
+                 (adjust-connection-timeout! conn (timeouts-password
+                                                   (host-timeouts host-info)))
+                 (request-authentication conn method uri host-info realm))]
+           [(conf-prefix? path)
+            (cond
+             [(string=? "/conf/refresh-servlets" path)
+              ;; more here - this is broken - only out of date or specifically mentioned
+              ;; scripts should be flushed.  This destroys persistent state!
+              (set-box! config:scripts (make-hash-table 'equal))
+              (output-response/method
+               conn
+               ((responders-servlets-refreshed (host-responders host-info)))
+                method)]
+             [(string=? "/conf/refresh-passwords" path)
+              ;; more here - send a nice error page
+              (hash-table-put! config:access host-info
+                               (read-passwords host-info))
+              (output-response/method
+               conn
+               ((responders-passwords-refreshed (host-responders host-info)))
+               method)
+              ]
+             [else
+              (output-response/method
+               conn
+               ((responders-file-not-found (host-responders host-info))  uri)
+               method)])]
+           [(servlet-bin? path)
+            (adjust-connection-timeout!
+             conn
+             (timeouts-servlet-connection (host-timeouts host-info)))
+            ;; more here - make timeouts proportional to size of bindings
+            (servlet-content-producer conn req host-info)]
+
+           [else (file-content-producer conn req host-info)])))
+
+
+      ;; conf-prefix?: string -> (union (listof string) #f)
+      ;; does the path string have "/conf/" as a prefix?
+      (define conf-prefix?
+        (let ([conf-re (regexp "^/conf/.*")])
+          (lambda (str)
+            (regexp-match conf-re str))))
+
+      (define servlet-bin?
+        (let ([svt-bin-re (regexp "^/servlets/.*")])
+          (lambda (str)
+            (regexp-match svt-bin-re str))))
+
+      ;; ripped this off from url-unit.ss
+      (define (url-path->string strs)
+        (apply
+         string-append
+         (let loop ([strs strs])
+           (cond
+            [(null? strs) '()]
+            [else (list* "/"
+                         (maybe-join-params (car strs))
+                         (loop (cdr strs)))]))))
+
+      ;; needs to unquote things!
+      (define (maybe-join-params s)
+        (cond
+         [(string? s) s]
+         [else (path/param-path s)]))
+
+      ;; ****************************************
+      ;; ****************************************
+      ;; ACCESS CONTROL
+
+      ;; pass-entry = (make-pass-entry str regexp (list sym str))
+      (define-struct pass-entry (domain pattern users))
+
+      ;; access-denied? : Method string x-table host Access-table -> (+ false str)
+      ;; the return string is the prompt for authentication
+      (define (access-denied? method uri-str headers host-info access-table)
+        ;; denied?: str sym str -> (U str #f)
+        ;; a function to authenticate the user
+        (let ([denied?
+
+               ;; GregP lookup the authenticator function, if you can't find it, then try to load the
+               ;; passwords file for this host.
+               (hash-table-get
+                access-table host-info
+                (lambda ()
+                  ; more here - a malformed password file will kill the connection
+                  (let ([f (read-passwords host-info)])
+                    (hash-table-put! access-table host-info f)
+                    f)))])
+          (let ([user-pass (extract-user-pass headers)])
+            (if user-pass
+                (denied? uri-str (lowercase-symbol! (car user-pass)) (cdr user-pass))
+                (denied? uri-str fake-user "")))))
+
+      (define-struct (exn:password-file exn) ())
+
+      ;; : host -> (str sym str -> (U str #f))
+      ;; to produce a function that checks if a given url path is accessible by a given user with a given
+      ;; password.  If not, the produced function returns a string, prompting for the password.
+      ;; If the password file does not exist, all accesses are allowed.  If the file is malformed, an
+      ;; exn:password-file is raised.
+      (define (read-passwords host-info)
+        (let ([password-path (host-passwords host-info)])
+          (with-handlers ([void (lambda (exn)
+                                  (raise (make-exn:password-file (format "could not load password file ~a" password-path)
+                                                                 (current-continuation-marks))))])
+            (if (and (file-exists? password-path) (memq 'read (file-or-directory-permissions password-path)))
+                (let ([passwords
+                       (let ([raw (load password-path)])
+                         (unless (password-list? raw)
+                           (raise "malformed passwords"))
+                         (map (lambda (x) (make-pass-entry (car x) (regexp (cadr x)) (cddr x)))
+                              raw))])
+
+                  ;; string symbol bytes -> (union #f string)
+                  (lambda (request-path user-name password)
+                    (ormap (lambda (x)
+                             (and (regexp-match (pass-entry-pattern x) request-path)
+                                  (let ([name-pass (assq user-name (pass-entry-users x))])
+                                    (if (and name-pass
+                                             (string=?
+                                              (cadr name-pass)
+                                              (bytes->string/utf-8 password)))
+                                        #f
+                                        (pass-entry-domain x)))))
+                           passwords)))
+                (lambda (req user pass) #f)))))
+
+      (define fake-user (gensym))
+
+      ;; password-list? : TST -> bool
+
+      ;; Note: andmap fails for dotted pairs at end.
+      ;; This is okay, since #f ends up raising a caught exception anyway.
+      (define (password-list? passwords)
+        (and (list? passwords)
+             (andmap (lambda (domain)
+                       (and (pair? domain) (pair? (cdr domain)) (list (cddr domain))
+                            (string? (car domain))
+                            (string? (cadr domain))
+                            (andmap (lambda (x)
+                                      (and (pair? x) (pair? (cdr x)) (null? (cddr x))
+                                           (symbol? (car x)) (string? (cadr x))))
+                                    (cddr domain))))
+                     passwords)))
+
+      ;; request-authentication : connection Method URL iport oport host str bool -> bool
+      ;; GregP: at first look, it seems that this gets called when the user
+      ;; has supplied bad authentication credentials.
+      (define (request-authentication conn method uri host-info realm)
+        (output-response/method
+         conn
+         ((responders-authentication (host-responders host-info))
+          uri `(WWW-Authenticate . ,(string-append " Basic
+                       realm=\"" realm "\"")))
+         method))
+
+
+      ;; ************************************************************
+      ;; ************************************************************
+      ;; SERVING FILES
+
+      ;; file-content-producer: connection request host -> void
+      (define (file-content-producer conn req host-info)
+        (serve-file conn (request-method req) (request-uri req) host-info))
+
+      ;; serve-file : connection symbol uri host -> void
+      ;; to find the file, including searching for implicit index files, and serve it out
+      (define (serve-file conn method uri host-info)
+        (let ([path (url-path->path (paths-htdocs (host-paths host-info))
+                                    (translate-escapes (url-path->string (url-path uri))))])
+          (cond
+            [(file-exists? path)
+             (output-file conn path method (get-mime-type path))]
+            [(directory-exists? path)
+             (let loop ([dir-defaults (host-indices host-info)])
+               (cond
+                [(pair? dir-defaults)
+                 (let ([full-name (build-path path (car dir-defaults))])
+                   (if (file-exists? full-name)
+                       (cond
+                        [(looks-like-directory? (url-path->string (url-path uri)))
+                         (output-file conn full-name method (get-mime-type full-name))]
+                        [else
+                         (output-slash-message conn method (url-path->string (url-path uri)))])
+                       (loop (cdr dir-defaults))))]
+                [else
+                 (output-response/method
+                  conn
+                  ((responders-file-not-found
+                    (host-responders host-info)) uri)
+                  method)]))]
+            [else
+             (output-response/method
+              conn ((responders-file-not-found (host-responders host-info))
+                    uri)
+              method)])))
+
+      ;; looks-like-directory : str -> bool
+      ;; to determine if is url style path looks like it refers to a directory
+      (define (looks-like-directory? path)
+        (eq? #\/ (string-ref path (sub1 (string-length path)))))
+
+      ;; output-slash-message: connection symbol string -> void
+      ;; basically this is just a special error response
+      (define (output-slash-message conn method url-path-str)
+        (output-response/method
+         conn
+         (make-response/full
+          301 "Moved Permanently"
+          (current-seconds)
+          TEXT/HTML-MIME-TYPE
+          `([Location . ,(string-append url-path-str "/")])
+          (list
+           (xml->string
+            (xexpr->xml
+             `(html
+               (head (title "Add a Slash"))
+               (body "Please use "
+                     (a ([href ,(string-append
+                                 url-path-str "/")])
+                        "this url") " instead."))))))
+         method))
+
+      ;; xml->string: xml -> string
+      (define (xml->string some-xml)
+        (let ([o-port (open-output-string)])
+          (write-xml/content some-xml o-port)
+          (get-output-string o-port)))
+
+
+      ;; ************************************************************
+      ;; ************************************************************
+      ;; SERVING SERVLETS
+
+      ;; servlet-content-producer: connection request host -> void
+      (define (servlet-content-producer conn req host-info)
+        (let ([meth (request-method req)])
+          (if (eq? meth 'head)
+              (output-response/method
+               conn
+               (make-response/full
+                200 "Okay" (current-seconds) TEXT/HTML-MIME-TYPE
+                '() (list "ignored"))
+               meth)
+              (let ([uri (request-uri req)])
+                (set-request-bindings!
+                 req
+                 (read-bindings/handled conn meth uri (request-headers req)
+                                        host-info))
+
+                (cond
+                 [(continuation-url? uri)
+                  => (lambda (k-ref)
+                       (invoke-servlet-continuation conn req k-ref host-info))]
+                 [else
+                  (servlet-content-producer/path conn req host-info uri)])))))
+
+      ;; read-bindings/handled: connection symbol url headers host -> (listof (list (symbol string))
+      ;; read the bindings and handle any exceptions
+      (define (read-bindings/handled conn meth uri headers host-info)
+        (with-handlers ([exn? (lambda (e)
+                                (output-response/method
+                                 conn
+                                 ;((responders-protocol (host-responders host-info))
+                                                        ; (exn-message e))
+                                 ((responders-servlet-loading (host-responders
+                                                               host-info))
+                                  uri e)
+
+
+                                 meth)
+                                '())])
+          (read-bindings conn meth uri headers)))
+
+      ;; servlet-content-producer/path: connection request host url -> void
+      ;; This is not a continuation url so the loading behavior is determined
+      ;; by the url path. Build the servlet path and then load the servlet
+      (define (servlet-content-producer/path conn req host-info uri)
+        (with-handlers (;; couldn't find the servlet
+                        [exn:fail:filesystem:exists:servlet?
+                        (lambda (the-exn)
+                          (output-response/method
+                            conn
+                            ((responders-file-not-found (host-responders
+                                                          host-info))
+                             (request-uri req))
+                            (request-method req)))]
+                        ;; servlet won't load (e.g. syntax error)
+                        [(lambda (x) #t)
+                         (lambda (the-exn)
+                           (output-response/method
+                            conn
+                            ((responders-servlet-loading (host-responders
+                                                          host-info)) uri
+                                                          the-exn)
+                            (request-method req)))])
+
+          (let ([sema (make-semaphore 0)])
+            (let/cc suspend
+              (let* ([servlet-custodian (make-servlet-custodian)]
+                     [inst (create-new-instance!
+                            config:instances servlet-custodian
+                            (make-execution-context
+                             conn req (lambda () (suspend #t)))
+                           sema)]
+                     [real-servlet-path (url-path->path
+                                         (paths-servlet (host-paths host-info))
+                                         (url-path->string (url-path uri)))]
+                     [servlet-exit-handler (make-servlet-exit-handler inst)]
+                     )
+
+                (parameterize ([current-directory (get-servlet-base-dir real-servlet-path)]
+                               [current-custodian servlet-custodian]
+                               [current-servlet-instance inst]
+                               [exit-handler servlet-exit-handler])
+
+
+                  (let (;; timer thread must be within the dynamic extent of
+                        ;; servlet custodian
+                        [time-bomb (start-timer (timeouts-default-servlet
+                                                 (host-timeouts host-info))
+                                                (lambda ()
+                                                  (servlet-exit-handler #f)))]
+                        ;; any resources (e.g. threads) created when the
+                        ;; servlet is loaded should be within the dynamic
+                        ;; extent of the servlet custodian
+                        [servlet-program (cached-load real-servlet-path)])
+
+                    (with-handlers ([(lambda (x) #t)
+                                     (make-servlet-exception-handler inst
+                                                                     host-info)])
+
+
+                      ;; The following bindings need to be in scope for the
+                      ;; invoke-unit/sig
+                      (let ([adjust-timeout!
+                             (lambda (secs) (reset-timer time-bomb secs))]
+                            [initial-request req])
+
+                        ;; Two possibilities:
+                        ;; - module servlet. start : Request -> Void handles
+                        ;;   output-response via send/finish, etc.
+                        ;; - unit/sig or simple xexpr servlet. These must produce a
+                        ;;   response, which is then output by the server.
+                        ;; Here, we do not know if the servlet was a module,
+                        ;; unit/sig, or Xexpr; we do know whether it produces a
+                        ;; response.
+                        (let ([r (invoke-unit/sig servlet-program servlet^)])
+                          (when (response? r)
+                            (send/back r)))))))))
+            (semaphore-post sema))))
+
+      ;; make-servlet-exit-handler: servlet-instance -> alpha -> void
+      ;; exit handler for a servlet
+      (define (make-servlet-exit-handler inst)
+        (lambda (x)
+          (remove-instance! config:instances inst)
+          (kill-connection!
+           (execution-context-connection
+            (servlet-instance-context inst)))
+          (custodian-shutdown-all (servlet-instance-custodian inst))))
+
+      ;; make-servlet-exception-handler: host -> exn -> void
+      ;; This exception handler traps all unhandled servlet exceptions
+      ;; * Must occur within the dynamic extent of the servlet
+      ;;   custodian since several connection custodians will typically
+      ;;   be shutdown during the dynamic extent of a continuation
+      ;; * Use the connection from the current-servlet-context in case
+      ;;   the exception is raised while invoking a continuation.
+      ;; * Use the suspend from the servlet-instanct-context which is
+      ;;   closed over the current tcp ports which may need to be
+      ;;   closed for an http 1.0 request.
+      ;; * Also, suspend will post to the semaphore so that future
+      ;;   requests won't be blocked.
+      ;; * This fixes PR# 7066
+      (define (make-servlet-exception-handler inst host-info)
+        (lambda (the-exn)
+          (let* ([ctxt (servlet-instance-context inst)]
+                 [req (execution-context-request ctxt)]
+                 [resp ((responders-servlet (host-responders
+                                             host-info))
+                        (request-uri req)
+                        the-exn)])
+            (output-response/method
+             (execution-context-connection ctxt)
+             resp (request-method req))
+            ((execution-context-suspend ctxt)))))
+
+      ;; path -> path
+      ;; The actual servlet's parent directory.
+      (define (get-servlet-base-dir servlet-path)
+        (let loop ((path servlet-path))
+          (let-values ([(base name must-be-dir?) (split-path path)])
+            (if must-be-dir?
+              (or (and (directory-exists? path) path)
+                  (loop base))
+              (or (and (directory-exists? base) base)
+                  (loop base))))))
+
+
+      ;; invoke-servlet-continuation: connection request continuation-reference
+      ;;                              host -> void
+      ;; pull the continuation out of the table and apply it
+      (define (invoke-servlet-continuation conn req k-ref host-info)
+        (with-handlers ([exn:servlet-instance?
+                         (lambda (the-exn)
+                           (output-response/method
+                            conn
+                            ((responders-file-not-found (host-responders
+                                                         host-info))
+                             (request-uri req))
+                            (request-method req)))]
+                        [exn:servlet-continuation?
+                         (lambda (the-exn)
+                           (output-response/method
+                            conn
+                            ((responders-file-not-found (host-responders
+                                                         host-info))
+                             (request-uri req))
+                            (request-method req)))])
+          (let* ([inst (hash-table-get config:instances (car k-ref)
+                                       (lambda ()
+                                         (raise
+                                          (make-exn:servlet-instance
+                                           "" (current-continuation-marks)))))]
+                 [k-table
+                  (servlet-instance-k-table inst)])
+            (let/cc suspend
+              (set-servlet-instance-context!
+               inst
+               (make-execution-context
+                conn req (lambda () (suspend #t))))
+              (semaphore-wait (servlet-instance-mutex inst))
+              (let ((k*salt
+                     (hash-table-get k-table (cadr k-ref)
+                                     (lambda ()
+                                       (raise
+                                        (make-exn:servlet-continuation
+                                         "" (current-continuation-marks)))))))
+                (if (= (cadr k*salt) (caddr k-ref))
+                    ((car k*salt) req)
+                    (raise
+                     (make-exn:servlet-continuation
+                      "" (current-continuation-marks))))))
+        (semaphore-post (servlet-instance-mutex inst)))))
+
+      ;; ************************************************************
+      ;; ************************************************************
+      ;; Paul's ugly loading code:
+
+      ;; cached-load : str -> script
+      ;; timestamps are no longer checked for performance.  The cache must be explicitly
+      ;; refreshed (see dispatch).
+      (define (cached-load name)
+        (hash-table-get (unbox config:scripts)
+                        name
+                        (lambda () (reload-servlet-script name))))
+
+      ;; exn:i/o:filesystem:servlet-not-found =
+      ;; (make-exn:fail:filesystem:exists:servlet str continuation-marks str sym)
+      (define-struct (exn:fail:filesystem:exists:servlet
+                      exn:fail:filesystem:exists) ())
+
+      ;; reload-servlet-script : str -> script
+      ;; The servlet is not cached in the servlet-table, so reload it from the filesystem.
+      (define (reload-servlet-script servlet-filename)
+        (cond
+          [(load-servlet/path servlet-filename)
+           => (lambda (svlt)
+                (hash-table-put! (unbox config:scripts) servlet-filename svlt)
+                svlt)]
+          [else
+           (raise (make-exn:fail:filesystem:exists:servlet
+                   (string->immutable-string (format "Couldn't find ~a" servlet-filename))
+                   (current-continuation-marks) ))]))
+
+       ;; load-servlet/path path -> (union #f signed-unit)
+      ;; given a string path to a filename attempt to load a servlet
+      ;; A servlet-file will contain either
+      ;;;; A signed-unit-servlet
+      ;;;; A module servlet
+      ;;;;;; (two versions, 'v1 and I don't know what 'typed-model-split-store0 is)
+      ;;;; A response
+      (define (load-servlet/path a-path)
+        (and (file-exists? a-path)
+             (let ([s (load/use-compiled a-path)])
+               (cond
+                 ;; signed-unit servlet
+                 ; MF: I'd also like to test that s has the correct import signature.
+                 [(unit/sig? s) s]
+                 ; FIX - reason about exceptions from dynamic require (catch and report if not already)
+                 ;; module servlet
+                 [(void? s)
+                  (parameterize ([current-namespace (config:make-servlet-namespace)])
+                    (let* ([module-name `(file ,(path->string a-path))]
+                           [version (dynamic-require module-name 'interface-version)])
+                      (case version
+                        [(v1)
+                         (let ([timeout (dynamic-require module-name 'timeout)]
+                               [start (dynamic-require module-name 'start)])
+                           (unit/sig ()
+                             (import servlet^)
+                             (adjust-timeout! timeout)
+                             (start initial-request)))]
+                        [(typed-model-split-store-0)
+                         (let ([constrained (dynamic-require module-name 'type)]
+                               [the-servlet (dynamic-require module-name 'servlet)])
+                           ; more here - check constraints
+                           the-servlet)]
+                        [else
+                         (raise (format "unknown sevlet version ~e" version))])))]
+                 ;; response
+                 [(response? s)
+                  (letrec ([go (lambda ()
+                                 (begin
+                                   (set! go (lambda () (load/use-compiled a-path)))
+                                   s))])
+                    (unit/sig () (import servlet^) (go)))]
+                 [else
+                  (raise (format "Loading ~e produced ~n~e~n instead of a servlet." a-path s))]))))
+
+      )))
\ No newline at end of file
diff --git a/collects/web-server/web-server.ss b/collects/web-server/web-server.ss
new file mode 100644
index 0000000000..6ac4b335d3
--- /dev/null
+++ b/collects/web-server/web-server.ss
@@ -0,0 +1,34 @@
+(module web-server mzscheme
+  (require (lib "tcp-sig.ss" "net")
+           (lib "unitsig.ss")
+           "sig.ss"
+           "web-server-unit.ss"
+	   "configuration.ss")
+  (provide serve)
+  
+  ; : configuration [nat] [(U str #f)] -> -> void
+  (define serve
+    (case-lambda
+      [(config)
+       (run-the-server config)]
+      [(config port)
+       (run-the-server (update-configuration config `((port . ,port))))]
+      [(config port listen-ip)
+       (run-the-server (update-configuration config `((port . ,port) (ip-address . ,listen-ip))))]))
+  
+  ; : configuration -> -> void
+  (define (run-the-server config)
+    (invoke-unit/sig
+     (compound-unit/sig
+       (import (t : net:tcp^))
+       (link
+        [c : web-config^ (config)]
+        [s : web-server^ (web-server@ t c)]
+        [m : () ((unit/sig ()
+                   (import web-server^)
+                   (serve))
+                 s)])
+       (export))
+     net:tcp^))
+
+)
\ No newline at end of file
diff --git a/collects/web-server/xexpr-callback.ss b/collects/web-server/xexpr-callback.ss
new file mode 100644
index 0000000000..0015102cc9
--- /dev/null
+++ b/collects/web-server/xexpr-callback.ss
@@ -0,0 +1,89 @@
+;; Mike Burns 2004
+
+;; Used for send/suspend/callback.
+
+;; A xexpr/callback is one of:
+;; - string
+;; - symbol
+;; - number
+;; - comment
+;; - processing instruction
+;; - procedure
+;; - (symbol xexpr/callback ...)
+;; - (symbol ((symbol attrib-value) ...) xexpr/callback ...)
+
+;; An attrib-value is one of:
+;; - string
+;; - procedure
+
+(module xexpr-callback mzscheme
+  (require (lib "xml.ss" "xml"))
+  (provide xexpr/callback?)
+
+  ;; Is it a Xexpr, or an Xexpr with procedures?
+  (define (xexpr/callback? x)
+    (correct-xexpr-callback? x #t #f))
+
+  ;;; Copied and pasted from xml/private/xexpr.ss, then modified to include
+  ;;; procedures.
+
+  ;; correct-xexpr? : any any any -> any
+  (define (correct-xexpr-callback? x true false)
+    (cond
+      ((string? x) true)
+      ((symbol? x) true)
+      ((number? x) true)
+      ((comment? x) true)
+      ((pi? x) true)
+      ;; Modified here
+      ((procedure? x) true)
+      ;;
+      ((list? x)
+       (or (null? x)
+           (if (symbol? (car x))
+             (if (has-attribute? x)
+               (and (attribute-pairs? (cadr x) true false)
+                    (andmap (lambda (part)
+                              (correct-xexpr-callback? part true false))
+                            (cddr x))
+                    true)
+               (andmap (lambda (part)
+                         (correct-xexpr-callback? part true false))
+                       (cdr x)))
+             false)))
+      (else false)))
+
+  ;; has-attribute? : List -> Boolean
+  ;; True if the Xexpr provided has an attribute list.
+  (define (has-attribute? x)
+    (and (> (length x) 1)
+         (list? (cadr x))
+         (andmap (lambda (attr)
+                   (pair? attr))
+                 (cadr x))))
+
+  ;; attribute-pairs? : List any any -> any
+  ;; True if the list is a list of pairs.
+  (define (attribute-pairs? attrs true false)
+    (or (and (null? attrs) true)
+        (let ((attr (car attrs)))
+          (if (pair? attr)
+            (and (attribute-symbol-string? attr true false)
+                 (attribute-pairs? (cdr attrs) true false)
+                 true)
+            false))))
+
+  ;; attribute-symbol-string? : List any any
+  ;;                            -> any
+  ;; True if the list is a list of String,Symbol pairs.
+  (define (attribute-symbol-string? attr true false)
+    (if (symbol? (car attr))
+      (or (and (or (string? (cadr attr))
+                   ;; Modified here
+                   (procedure? (cadr attr)))
+                   ;;
+               true)
+          false)
+      false))
+
+  )
diff --git a/collects/xelda/Physics101.xls b/collects/xelda/Physics101.xls
new file mode 100644
index 0000000000..324cbf243f
Binary files /dev/null and b/collects/xelda/Physics101.xls differ
diff --git a/collects/xelda/currency_table.xls b/collects/xelda/currency_table.xls
new file mode 100644
index 0000000000..c16a9fef99
Binary files /dev/null and b/collects/xelda/currency_table.xls differ
diff --git a/collects/xelda/private/formula.ss b/collects/xelda/private/formula.ss
new file mode 100644
index 0000000000..dff6c17930
--- /dev/null
+++ b/collects/xelda/private/formula.ss
@@ -0,0 +1,14 @@
+(module formula mzscheme
+
+  (provide (all-defined))
+
+  (define-struct formula (name dependencies) (make-inspector))
+  (define-struct (xl-number formula) (val) (make-inspector))
+  (define-struct (cell-ref formula) () (make-inspector))
+  (define-struct (named-cell-ref cell-ref) (cell-name) (make-inspector))
+  (define-struct (binary-op formula) (op arg1 arg2) (make-inspector))
+  (define-struct (boolean-op formula) (op arg1 arg2) (make-inspector))
+  (define-struct (unary-op formula) (op arg) (make-inspector))
+  (define-struct (tbl-top formula) (input-cell) (make-inspector))
+  (define-struct (tbl-left formula) (input-cell) (make-inspector))
+  (define-struct (application formula) (fun args) (make-inspector)))
diff --git a/collects/xelda/private/parser.ss b/collects/xelda/private/parser.ss
new file mode 100644
index 0000000000..0ce8713cb8
--- /dev/null
+++ b/collects/xelda/private/parser.ss
@@ -0,0 +1,297 @@
+(module parser mzscheme
+  
+  (require (lib "string.ss"))
+  (require (lib "yacc.ss" "parser-tools"))
+  (require (lib "lex.ss" "parser-tools"))
+  (require (lib "list.ss"))
+  
+  (require "xl-util.ss")
+  (require "formula.ss")
+  
+  (provide call-parser
+           make-parser
+           parse-unit)
+  
+  (define (string-downcase s)
+    (let ([tmp (string-copy s)])
+      (string-lowercase! tmp)
+      tmp))
+  
+  (define-tokens data-tokens 
+                 (STRING 
+                  QUOTED_STRING 
+                  NUMBER
+                  CELL-REF
+                  UNIT
+                  IDENTIFIER))
+  
+  (define-tokens op-tokens
+                 (ADD-OP
+                  MULT-OP
+                  BOOL-OP
+                  TBL-BEGIN
+                  EXP-OP))
+  
+  (define-empty-tokens cmp-tokens
+                       (LT LTE NE GT GTE)) 
+  
+  (define-empty-tokens syntax-tokens
+                       (INVALID-TOKEN
+                        EOF
+                        EQ 
+                        NEG ; for precedence
+                        LPAREN RPAREN
+                        LBRACE RBRACE
+                        COMMA
+                        RANGE-SEP SHEET-SEP))
+  
+  (define-lex-abbrevs 
+   [digit (- "0" "9")]
+   [pos-digit (- "1" "9")]
+   [number-sequence (+ digit)]
+   [number-with-point (@ number-sequence "." number-sequence)]
+   [unsigned-number (: number-sequence number-with-point)]
+   [number unsigned-number]
+   [pos-int (@ pos-digit number-sequence)]
+   [letter (: (- "a" "z") (- "A" "Z"))]
+   [letter-to-V (: (- "a" "v") (- "A" "V"))]
+   [letter-to-I (: (- "a" "h") (- "A" "H"))]
+   [alphanum_ (: digit letter "_")]
+   [alphanum (: letter digit)]
+   [cell-letter-sequence (: letter (@ letter-to-I letter) (@ (: "i" "I") letter-to-V))]
+   [cell-number-sequence (: pos-digit (@ pos-digit digit)
+                            (@ pos-digit digit digit)
+                            (@ pos-digit digit digit digit))]
+   [cell-reference (@ (? "$") cell-letter-sequence (? "$") cell-number-sequence)]
+   [whitespace (: #\space #\tab #\newline #\return)]
+   [add-op (: "+" "-")]
+   [mult-op (: "*" "/")]
+   [exp-op "^"]
+   [bool-op (: "<" ">" "<=" ">=" "=" "<>")]
+   [tbl-begin "=TABLE("]
+   [function-name 
+    (: "NOT"
+       "AND"
+       "OR"
+       "SUM"
+       "AVERAGE"
+       "MIN"
+       "MAX"
+       )]
+   [special-unit-chars (: "(" ")" "^" "*" "-" "/")]
+   [unit-chars (^ (: whitespace special-unit-chars))]
+   [non-num (^ (: digit whitespace special-unit-chars))]
+   [unit (@ (* unit-chars) non-num (* unit-chars))]
+   [identifier (: (@ (* letter) (* alphanum_) "_" (* alphanum_))
+                  (@ (* alphanum) letter)
+                  (@ letter letter letter (* alphanum))
+                  (@ (: (- "j" "z") (- "J" "Z")) letter digit)
+                  (@ (: "i" "I") (: (- "w" "z") (- "W" "Z")) digit)
+                  (@ letter "0"))])
+  
+  (define unit-lex
+    (lexer
+     [whitespace (unit-lex input-port)]
+     [(eof) 'EOF]
+     [number (token-NUMBER (string->number lexeme))]
+     [mult-op (token-MULT-OP (string->symbol lexeme))]
+     ["-" (token-MULT-OP (string->symbol lexeme))]
+     [exp-op (token-EXP-OP (string->symbol lexeme))]
+     [unit (token-UNIT lexeme)]
+     ["(" (token-LPAREN)]
+     [")" (token-RPAREN)]))
+  
+  (define xl-lex
+    (lexer
+     [whitespace 
+      (xl-lex input-port)]
+     [(eof) 'EOF]
+     [number
+      (token-NUMBER (string->number lexeme))]
+     [add-op
+      (token-ADD-OP (string->symbol lexeme))]
+     [mult-op
+      (token-MULT-OP (string->symbol lexeme))]
+     [exp-op
+      (token-EXP-OP (string->symbol lexeme))]
+     [bool-op
+      (token-BOOL-OP (string->symbol lexeme))]
+     [cell-reference
+      (token-CELL-REF 
+       (string->symbol 
+        (list->string
+         (filter (lambda (c) (not (equal? c #\$)))
+                 (string->list (string-downcase lexeme))))))]
+     [identifier (token-IDENTIFIER lexeme)]
+     [tbl-begin (token-TBL-BEGIN lexeme)]
+     [":" (token-RANGE-SEP)]
+     ["," (token-COMMA)]
+     ["(" (token-LPAREN)]
+     [")" (token-RPAREN)]
+     ["{" (token-LBRACE)]
+     ["}" (token-RBRACE)]
+     ["=" (token-EQ)]))
+  
+  (define make-parser 
+    (lambda (symbol-table)
+      (parser
+       
+       (start start)
+       (end EOF)
+       (error (lambda (a b c) (void)))
+       (tokens data-tokens 
+               op-tokens
+               cmp-tokens
+               syntax-tokens)
+       
+       (precs (left ADD-OP)
+              (left MULT-OP)
+              (left EXP-OP)
+              (left BOOL-OP)
+              (left NEG)
+              (right LPAREN)
+              (left RPAREN))
+       
+       (grammar
+        
+        (start [() #f]
+               [(error start) $2]
+               [(expr) $1])
+        
+        (formula [(EQ expr) $2])
+        
+        (expr
+         ; cells have their own names
+         [(CELL-REF) (make-cell-ref $1 (list $1))]
+         [(IDENTIFIER)
+          (let ([cell-loc (cadr (assoc $1 symbol-table))])
+            (make-named-cell-ref cell-loc (list cell-loc) (string->symbol $1)))]
+         [(NUMBER) (make-xl-number (gensym) null $1)]
+         [(TBL-BEGIN expr COMMA RPAREN)
+          (make-tbl-top
+           (gensym)
+           (formula-dependencies $2)
+           $2)]
+         [(TBL-BEGIN COMMA expr RPAREN)
+          (make-tbl-left
+           (gensym)
+           (formula-dependencies $3)
+           $3)]
+         [(LPAREN expr RPAREN) $2]
+         [(expr ADD-OP expr) 
+          (make-binary-op 
+           (gensym)
+           (append (formula-dependencies $1)
+                   (formula-dependencies $3))
+           $2
+           $1 $3)]
+         [(expr MULT-OP expr) 
+          (make-binary-op 
+           (gensym)
+           (append (formula-dependencies $1)
+                   (formula-dependencies $3))
+           $2
+           $1 $3)]
+         [(expr EXP-OP expr) 
+          (make-binary-op 
+           (gensym)
+           (append (formula-dependencies $1)
+                   (formula-dependencies $3))
+           $2
+           $1 $3)]
+         [(expr BOOL-OP expr)
+          (make-boolean-op
+           (gensym)
+           (append (formula-dependencies $1)
+                   (formula-dependencies $3))
+           $2
+           $1 $3)]
+         [(ADD-OP expr) (prec NEG)
+          (cond [(xl-number? $2) 
+                 (make-xl-number (formula-name $2) 
+                                 null 
+                                 (- 0 (xl-number-val $2)))]
+                [else
+                 (make-unary-op 
+                  (gensym)
+                  (formula-dependencies $2)
+                  $1 $2)])]
+         [(IDENTIFIER LPAREN RPAREN)
+          (make-application
+           (gensym)
+           empty (string->symbol (string-downcase $1)) empty)]
+         [(IDENTIFIER LPAREN args RPAREN)
+          (make-application 
+           (gensym) 
+           (cadr $3) (string->symbol (string-downcase $1)) (car $3))])
+        
+        ; returns list of symbols denoting cells
+        (cell-range
+         [(CELL-REF RANGE-SEP CELL-REF)
+          (get-range-cells $1 $3)])
+        
+        ; returns two-elt list, (expr deps)
+        (arg
+         [(expr) (list (list $1) (formula-dependencies $1))]
+         [(cell-range) (list (map (lambda (c)
+                                    (make-cell-ref c (list c)))
+                                  $1)
+                             $1)])
+        (args
+         [(arg) (list (car $1) (cadr $1))]
+         [(arg COMMA args) 
+          (let ([arg1 (car $1)]
+                [dep1 (cadr $1)]
+                [arg2 (car $3)]
+                [dep2 (cadr $3)])
+            (list (append arg1 arg2) (append dep1 dep2)))])))))
+  
+  (define (call-parser parser s)
+    (let* ([port (open-input-string s)]
+	   [lex-thunk (lambda () (xl-lex port))])
+      (parser lex-thunk)))
+  
+  (define unit-parser 
+    (parser
+     
+     (start start)
+     (end EOF)
+     (error (lambda (a b c) (void)))
+     (tokens data-tokens 
+             op-tokens
+             cmp-tokens
+             syntax-tokens)
+     
+     (precs (left MULT-OP)
+            (left EXP-OP)
+            (left NEG)
+            (right LPAREN)
+            (left RPAREN))
+     
+     (grammar
+      
+      (start [() #f]
+             [(error start) $2]
+             [(expr) $1])
+      
+      (expr
+       [(expr EXP-OP expr)
+        (map (lambda (u)
+               (cond [(number? $3) (list (first u) (* $3 (second u)))]
+                     [else u])) $1)]
+       [(expr MULT-OP expr)
+        (let ([invert (lambda (l)
+                        (map (lambda (u)
+                               (list (first u) (- 0 (second u)))) l))])
+          (cond [(eq? $2 '/) (append $1 (invert $3))]
+                [else (append $1 $3)]))]
+       [(LPAREN expr RPAREN) $2]
+       [(LPAREN RPAREN) (list (list 'empty_unit 1))]
+       [(NUMBER) $1]
+       [(MULT-OP expr)(prec NEG) (- 0 $2)]
+       [(UNIT) (list (list (string->symbol $1) 1))]))))
+  
+  (define (parse-unit s)
+    (let* ([port (open-input-string s)]
+           [lex-thunk (lambda () (unit-lex port))])
+      (unit-parser lex-thunk))))
diff --git a/collects/xelda/private/xelda-checker.ss b/collects/xelda/private/xelda-checker.ss
new file mode 100644
index 0000000000..c37583b1b9
--- /dev/null
+++ b/collects/xelda/private/xelda-checker.ss
@@ -0,0 +1,1328 @@
+(module xelda-checker mzscheme
+  (require (lib "class.ss"))
+  (require (lib "list.ss"))
+  (require (lib "match.ss"))
+  
+  (require "xl-util.ss")
+  (require "formula.ss")
+  (require "parser.ss")
+  (require "xelda-lib.ss")
+  (require "xelda-com.ss")
+  
+  (provide unit-check)
+  
+  (define (unit-check gui)
+    (let* ([all-formula-texts
+            (begin
+              (send gui update-status (format "+++SPREADSHEET PREPROCESSING BEGIN+++~n"))
+              (send gui update-status "Preprocessing all formula texts.... ")
+              (iterate-over-worksheet
+               (lambda (cell) (get-cell-formula cell))
+               (lambda (formula)
+                 (and (not (string=? formula ""))
+                      (eq? (string-ref formula 0) #\=)))))]
+           [all-names
+            (begin
+              (send gui next-update-status "Preprocessing all names")
+              (iterate-over-worksheet
+               (lambda (cell) (get-cell-name cell))
+               (lambda (s) (not (string=? s "")))))]
+           [symbol-table
+            (begin
+              (send gui next-update-status "Preprocessing symbol-table")
+              (map (lambda (pr) (list (cadr pr) (car pr))) all-names))]
+           [parser (make-parser symbol-table)]
+           [formulas
+            (begin
+              (send gui next-update-status "Preprocessing all formulas")
+              (map (lambda (f)
+                     (let ([cell (car f)]
+                           [form (cadr f)])
+                       (cond
+                         [(tbl-top? form)
+                          (list cell
+                                (make-tbl-top 
+                                 (formula-name form)
+                                 (append (formula-dependencies form)
+                                         (list (top-of cell)
+                                               (get-formula-loc-left cell
+                                                                     parser
+                                                                     all-formula-texts)))
+                                 (tbl-top-input-cell form)))]
+                         [(tbl-left? form)
+                          (list cell
+                                (make-tbl-left 
+                                 (formula-name form)
+                                 (append (formula-dependencies form)
+                                         (list (left-of cell)
+                                               (get-formula-loc-up cell
+                                                                   parser
+                                                                   all-formula-texts)))
+                                 (tbl-left-input-cell form)))]
+                         [else f])))
+                   (map (lambda (frm-text)
+                          (list (car frm-text)
+                                (call-parser parser (cadr frm-text))))
+                        all-formula-texts)))]
+           [all-formulas (formula-sort formulas)]
+           [circular-non-circular (split-circular-non-circular all-formulas)]
+           [all-circular-formulas (first circular-non-circular)]
+           [all-non-circular-formulas (second circular-non-circular)]
+           [good-and-bad-units
+            (split-list
+             (begin
+               (send gui next-update-status "Preprocessing all units")
+               (iterate-over-worksheet
+                (lambda (cell)
+                  (with-handlers
+                      ([void (lambda _ 'bad-unit-format)])
+                    (let ([comment-txt (get-cell-comment cell)])
+                      (cond
+                        [(string=? "" comment-txt) empty]
+                        [else (parse-unit comment-txt)]))))
+                (lambda (u) (and (not (empty? u)) (pair? u)))))
+             (lambda (e) (dim? (second e))))]
+           [all-units
+            (map (lambda (entry)
+                   (list (car entry) (canonicalize-units (cadr entry))))
+                 (first good-and-bad-units))]
+           [bad-format-units (second good-and-bad-units)]
+           [hashed-units (make-hash-table)]
+           [hashed-vars (make-hash-table)]
+           [hashed-constraints-vars (make-hash-table)])
+      (send gui update-status (format "done~n"))
+      (send gui update-status (format "+++SPREADSHEET PREPROCESSING END+++~n"))
+      
+      ;; When bad formatted units are present, don't do unit checking
+      (time
+       (cond
+         [(not (empty? bad-format-units)) 
+          (send gui set-bad-format-cells
+                (map (lambda (u) (car u)) bad-format-units))]
+         [else      
+          ;; Place all non-formulas units in the computed units(hashed-units)
+          (init-hash hashed-units
+                     (filter (lambda (u) (not (assq (car u) all-formulas)))
+                             all-units))
+          
+          (send gui update-status (format "+++UNIT CHECKING BEGIN+++~n"))
+          
+          ;; Compute non-circular formula units
+          (send gui update-status "Checking non-circular formulas.... ")
+          ;;(printf "ALL NON CIRCULAR CELLS:~n~a~n" 
+          ;;        (map (lambda (f) (car f))
+          ;;             (reverse all-non-circular-formulas)))
+          (for-each (lambda (f)
+                      (compute-cell-unit f hashed-units 
+                                         all-formulas all-formula-texts parser))
+                    (reverse all-non-circular-formulas))
+          
+          ;; Compute circular formula units. Start by assigning unit variables.
+          (send gui next-update-status "Assigning dimension variables for circular formulas");
+          (assign-variables hashed-vars hashed-units all-circular-formulas)
+          
+          ;; Generate constraints
+          (send gui next-update-status "Creating constraints")
+          (let* ([constraints (create-constraints 
+                               hashed-units hashed-vars 
+                               all-formulas all-circular-formulas all-formula-texts parser)]
+                 [eq-app-cs (split-list constraints (lambda (c) (eq? (first c) '=)))]
+                 [equality-constraints (first eq-app-cs)]
+                 [append-constraints (second eq-app-cs)])
+            ;; Create equivalence classes from the equality constraints
+            (send gui next-update-status "Creating equivalence classes")
+            ;;(printf "EQUALITY CONSTRAINTS:~n")
+            ;;(show-constraints equality-constraints)
+            ;;(printf "APPEND CONSTRAINTS:~n")
+            ;;(show-constraints append-constraints)
+            (prune-constraints equality-constraints hashed-constraints-vars)
+            
+            ;; Replace variables in append-constraints with their equivalence class
+            ;; representative variable or unit (unit only for operands where possible)
+            (let ([append-constraints (replace-equiv-in-constraints hashed-constraints-vars
+                                                                    append-constraints)])
+              ;; Flatten the append constraints
+              (send gui next-update-status "Solving constraints")
+              ;;(printf "APPEND CONSTRAINTS: ~a~n" append-constraints)
+              (solve-constraints (gaussian-elimination append-constraints)
+                                 hashed-constraints-vars hashed-vars hashed-units)
+              (send gui update-status (format "done~n"))
+              (send gui update-status (format "+++UNIT CHECKING END+++~n"))
+              
+              ;; Report any error back to the gui
+              (send gui set-computation-errors 
+                    (computation-errors hashed-units all-formula-texts all-formulas))
+              (send gui set-mismatch-errors 
+                    (mismatch-errors hashed-units all-units all-formula-texts all-formulas))))]))))
+  
+  (define (compute-cell-unit _formula hashed-units all-formulas all-formula-texts parser)
+    (let ([cell-name (car _formula)]
+          [formula (cadr _formula)])
+      (when (not (in-hash? hashed-units cell-name))
+        (hash-table-put! 
+         hashed-units cell-name
+         (let ([unit (compute-formula formula cell-name hashed-units 
+                                      all-formulas all-formula-texts parser)])
+           (cond ((> (length unit) 1)
+                  (filter (lambda (u) (not (eq? (car u) 'empty_unit)))
+                          unit))
+                 (else unit)))))))
+  
+  (define (compute-formula formula cell-loc hashed-units all-formulas all-formula-texts parser)
+    (match formula
+      [($ xl-number name deps val) (empty-unit)]
+      [($ cell-ref name cell-name)
+       (cond
+         [(in-hash? hashed-units name)
+          (hash-table-get hashed-units name)]
+         [(not (not (assq name all-formulas)))
+          (let ([u (compute-formula (cadr (assq name all-formulas))
+                                    name
+                                    hashed-units
+                                    all-formulas
+                                    all-formula-texts
+                                    parser)])
+            (hash-table-put! hashed-units name u)
+            u)]
+         [(string=? "" (get-cell-text (formula-name formula)))
+          (list (list 'error/empty-formula cell-loc))]
+         [else (empty-unit)])]
+      [($ named-cell-ref name cell-name actual-name)
+       (cond
+         [(in-hash? hashed-units name)
+          (hash-table-get hashed-units name)]
+         [(not (not (assq name all-formulas)))
+          (let ([u (compute-formula (cadr (assq name all-formulas))
+                                    name
+                                    hashed-units
+                                    all-formulas
+                                    all-formula-texts
+                                    parser)])
+            (hash-table-put! hashed-units name u)
+            u)]
+         [(string=? "" (get-cell-text (formula-name formula)))
+          (list (list 'error/empty-formula cell-loc))]
+         [else (empty-unit)])]
+      [($ binary-op name deps op arg1 arg2)
+       (let ([arg1-unit (compute-formula arg1
+                                         cell-loc
+                                         hashed-units
+                                         all-formulas
+                                         all-formula-texts
+                                         parser)]
+             [arg2-unit (compute-formula arg2
+                                         cell-loc
+                                         hashed-units
+                                         all-formulas
+                                         all-formula-texts
+                                         parser)])
+         (case op
+           [(+ -) (check-equal-units (list arg1-unit arg2-unit) cell-loc)]
+           [(*) (let ([result (gen-mult-units arg1-unit arg2-unit cell-loc)])
+                  (cond ((null? result) (empty-unit))
+                        (else result)))]
+           [(/) (let ([result (gen-div-units arg1-unit arg2-unit cell-loc)])
+                  (cond ((null? result) (empty-unit))
+                        (else result)))]
+           [(^) (gen-exp-units arg1-unit
+                               (cond
+                                 [(xl-number? arg2) (xl-number-val arg2)]
+                                 [(or (cell-ref? arg2)
+                                      (named-cell-ref? arg2))
+                                  (get-cell-value (formula-name arg2))]
+                                 [else 'bad-exp]) cell-loc)]))]
+      [($ boolean-op name deps op arg1 arg2)
+       (let ([arg1-unit (compute-formula arg1
+                                         cell-loc
+                                         hashed-units
+                                         all-formulas
+                                         all-formula-texts
+                                         parser)]
+             [arg2-unit (compute-formula arg2 
+                                         cell-loc
+                                         hashed-units
+                                         all-formulas
+                                         all-formula-texts
+                                         parser)])
+         (if (equal? arg1-unit arg2-unit)
+             (empty-unit)
+             (list (list 'error/bool-non-empty cell-loc))))]
+      [($ unary-op name deps op arg)
+       (let ([arg-unit (compute-formula arg
+                                        cell-loc
+                                        hashed-units
+                                        all-formulas
+                                        all-formula-texts
+                                        parser)])
+         (case op
+           [(+ -) arg-unit]
+           [else (error op "Unknown unary op")]))]
+      [($ tbl-left name deps input-cell)
+       (let ([left-cell (left-of cell-loc)]
+             [formula-cell (get-formula-loc-up cell-loc parser all-formula-texts)]
+             [left-cell-unit empty]
+             [input-cell-unit (compute-formula input-cell
+                                               cell-loc
+                                               hashed-units
+                                               all-formulas
+                                               all-formula-texts
+                                               parser)])
+         (if (in-hash? hashed-units left-cell)
+             (set! left-cell-unit (hash-table-get hashed-units left-cell))
+             (set! left-cell-unit (compute-cell-unit (assoc left-cell all-formulas)
+                                                     hashed-units
+                                                     all-formulas all-formula-texts parser)))
+         (compute-formula (replace-in-formula
+                           (cadr (assq formula-cell all-formulas))
+                           (formula-name input-cell) left-cell)
+                          cell-loc
+                          hashed-units
+                          all-formulas
+                          all-formula-texts
+                          parser))]
+      [($ tbl-top name deps input-cell)
+       (let ([input-cell-unit (compute-formula input-cell
+                                               cell-loc
+                                               hashed-units
+                                               all-formulas
+                                               all-formula-texts
+                                               parser)]
+             [top-cell (top-of cell-loc)]
+             [formula-cell (get-formula-loc-left cell-loc parser all-formula-texts)]
+             [top-cell-unit empty])
+         (if (in-hash? hashed-units top-cell)
+             (set! top-cell-unit (hash-table-get hashed-units top-cell))
+             (set! top-cell-unit (compute-cell-unit (assoc top-cell all-formulas)
+                                                    hashed-units
+                                                    all-formulas all-formula-texts parser)))
+         (compute-formula (replace-in-formula
+                           (cadr (assq formula-cell all-formulas))
+                           (formula-name input-cell) top-cell)
+                          cell-loc
+                          hashed-units
+                          all-formulas
+                          all-formula-texts
+                          parser))]
+      [($ application name deps fun args) 
+       (let ([arg-units (map (lambda (a)
+                               (compute-formula a 
+                                                cell-loc
+                                                hashed-units
+                                                all-formulas
+                                                all-formula-texts
+                                                parser)) args)])
+         (case fun
+           [(average sum min max mina maxa) (check-equal-units arg-units cell-loc)]
+           [(not or and)
+            (if (andmap empty-unit? arg-units)
+                (empty-unit)
+                (list (list 'error/bool-non-empty cell-loc)))]
+           [(if) (cond
+                   ((= 3 (length args))
+                    (let ([if-unit (second arg-units)]
+                          [else-unit (third arg-units)]
+                          [test-unit (first arg-units)])
+                      (if (empty-unit? test-unit)
+                          (check-equal-units (list if-unit else-unit) cell-loc)
+                          (list (list 'error/if-bool-non-empty cell-loc)))))
+                   (else (error fun "illegal use")))]
+           [(abs) (cond
+                    ((= 1 (length args)) (first arg-units))
+                    (else (error fun "illegal use")))]
+           [(ceiling round)
+            (cond
+              ((= 2 (length args))
+               (let ([num-unit (first arg-units)]
+                     [prec-unit (second arg-units)])
+                 (cond 
+                   ((empty-unit? prec-unit) num-unit)
+                   (else (list (list 'error/non-empty-precision cell-loc))))))
+              (else (error fun "illegal use")))]
+           [(large) (let ([split-units (split-large-args arg-units)])
+                      (cond
+                        ((= 1 (length (car split-units)))
+                         (check-equal-units (cadr split-units) cell-loc))
+                        (else (list (list 'error/large-empty-unit cell-loc)))))]
+           [(acos acosh asin asinh atan atanh cos cosh sin sinh tan tanh exp)
+            (let ([arg-unit (first arg-units)])
+              (cond ((= 1 (length args))
+                     (if (empty-unit? arg-unit)
+                         arg-unit
+                         (list (list 'error/non-empty-argument cell-loc))))
+                    (else (error fun "illegal use"))))]
+           [(sqrt) (let ([arg-unit (first arg-units)])
+                     (cond
+                       ((= 1 (length args))
+                        (cond [(empty-unit? arg-unit) arg-unit]
+                              [(andmap (lambda (s_u)
+                                         (= (modulo (cadr s_u) 2) 0))
+                                       arg-unit)
+                               (map (lambda (s_u)
+                                      (list (car s_u) (/ (cadr s_u) 2)))
+                                    arg-unit)]
+                              [else
+                               (list (list 'error/invalid-sqrt-dimension cell-loc))]))
+                       (else (error fun "illegal use"))))]
+           [(fact ln log) (let ([arg-unit (first arg-units)])
+                            (cond
+                              ((= 1 (length args))
+                               (if (empty-unit? arg-unit)
+                                   arg-unit
+                                   (list (list 'error/non-unitless-argument cell-loc))))
+                              (else (error fun "illegal use"))))]
+           [(isnumber)
+            (cond ((= 1 (length arg-units)) (empty-unit))
+                  (else (error fun "illegal use")))]
+           [(median stdev) (check-equal-units arg-units cell-loc)]
+           [(npv) (cond
+                    [(>= (length args) 2)
+                     (cond [(empty-unit? (first arg-units))
+                            (let ([u (first (rest arg-units))])
+                              (foldl (lambda (curr prev) (check-equal-units curr prev))
+                                     u
+                                     (rest (rest arg-units))))]
+                           [else
+                            (list (list 'error/npv-rate-non-dimensionless cell-loc))])]
+                    [else (error fun "illegal use")])]
+           [(intercept)
+            (cond
+              [(> (length arg-units) 0)
+               (let* ([x-unit (first arg-units)]
+                      [xy-units (split-list (rest arg-units) (lambda (u) (equal? u x-unit)))]
+                      [x-units (cons x-unit (first xy-units))]
+                      [y-units (second xy-units)])
+                 (cond [(= (length x-units) (length y-units))
+                        (check-equal-units y-units cell-loc)]
+                       [else (list (list 'error/intercept-invalid-points cell-loc))]))]
+              [else (empty-unit)])]
+           [(count) (empty-unit)]
+           [(frequency)
+            (let ([args-unit (check-equal-units arg-units cell-loc)])
+              (cond [(is-error-unit? args-unit) args-unit]
+                    [else (empty-unit)]))]
+           [(mod)
+            (cond ((= 2 (length arg-units)) (first arg-units))
+                  (else (error fun "illegal use")))]
+           [(na pi today now) (cond ((empty? args) (empty-unit))
+                                    (else (error fun "illegal use")))]
+           [(mmult) (let* ([formula-text (lookup-formula-text cell-loc all-formula-texts)]
+                           [Ms (identify-matrices
+                                (substring formula-text 7
+                                           (sub1 (string-length formula-text))))])
+                      (cond
+                        [(= 2 (length Ms))
+                         (let* ([cell-xy (get-cell-row-col cell-loc)]
+                                [M1-row (car cell-xy)]
+                                [M2-col (cadr cell-xy)]
+                                [M1-row-unit (check-equal-units
+                                              (matrix-row-units (car Ms) M1-row hashed-units)
+                                              cell-loc)]
+                                [M2-col-unit (check-equal-units
+                                              (matrix-col-units (cadr Ms) M2-col hashed-units)
+                                              cell-loc)])
+                           (cond
+                             [(is-error-unit? M1-row-unit) M1-row-unit]
+                             [(is-error-unit? M2-col-unit) M2-col-unit]
+                             [else (gen-mult-units M1-row-unit M2-col-unit cell-loc)]))]
+                        [else (error fun "illegal use")]))]
+           [else (empty-unit)]))]))  ;; unimplemented functions -> empty unit
+  
+  (define (replace-in-formula formula orig new)
+    (match formula
+      [($ xl-number name deps val) formula]
+      [($ cell-ref name cell-name)
+       (cond
+         [(eq? name orig) (make-cell-ref new empty)]
+         [else formula])]
+      [($ named-cell-ref name cell-name actual-name) formula]
+      [($ binary-op name deps op arg1 arg2)
+       (make-binary-op name deps op
+                       (replace-in-formula arg1 orig new)
+                       (replace-in-formula arg2 orig new))]
+      [($ boolean-op name deps op arg1 arg2)
+       (make-boolean-op name deps op
+                        (replace-in-formula arg1 orig new)
+                        (replace-in-formula arg2 orig new))]
+      [($ unary-op name deps op arg)
+       (make-unary-op name deps op (replace-in-formula arg orig new))]
+      [($ tbl-left name deps input-cell)
+       (cond [(eq? input-cell orig)
+              (make-tbl-left name deps new)]
+             [else formula])]
+      [($ tbl-top name deps input-cell)
+       (cond [(eq? input-cell orig)
+              (make-tbl-top name deps new)]
+             [else formula])]
+      [($ application name deps fun args) 
+       (let ([replaced-args
+              (map (lambda (a)
+                     (replace-in-formula a orig new)) args)])
+         (make-application name deps fun replaced-args))]
+      [else formula]))
+  
+  (define (remove-duplicates lst)
+    (cond
+      [(null? lst) null]
+      [(member (car lst) (cdr lst)) (remove-duplicates (cdr lst))]
+      [else (cons (car lst) (remove-duplicates (cdr lst)))]))
+  
+  (define (formula-sort fs)
+    (quicksort fs
+               (lambda (f1 f2)
+                 (let* ([name (car f1)]
+                        [deps (formula-dependencies (cadr f2))])
+                   (memq name deps)))))
+  
+  (define (get-formula-loc-up loc parser all-formula-texts)
+    (let ([formula (call-parser parser (cadr (assoc loc all-formula-texts)))])
+      (cond ((not (tbl-left? formula)) loc)
+            (else (let* ([xy (cellref->numbers loc)]
+                         [x (sub1 (car xy))]
+                         [y (sub1 (cadr xy))])
+                    (get-formula-loc-up (numbers->cellref (list x y))
+                                        parser all-formula-texts))))))
+  
+  (define (get-formula-loc-left loc parser all-formula-texts)
+    (let ([formula (call-parser parser (cadr (assoc loc all-formula-texts)))])
+      (cond ((not (tbl-top? formula)) loc)
+            (else (let* ([xy (cellref->numbers loc)]
+                         [x (- (car xy) 2)]
+                         [y (cadr xy)])
+                    (get-formula-loc-left (numbers->cellref (list x y))
+                                          parser all-formula-texts))))))
+  
+  (define (assign-variables hashed-vars hashed-units all-circular-formulas)
+    (for-each (lambda (f)
+                (let ([a_s (gen-alpha-var)])
+                  (hash-table-put! hashed-vars a_s 
+                                   (list (car f) (list (list 'error/missing-dimensions (car f)))))
+                  (hash-table-put! hashed-units (car f) a_s)))
+              all-circular-formulas))
+  
+  (define (gen-alpha-var)
+    (string->symbol (string-append "a_" (symbol->string (gensym)))))
+  
+  (define (gen-beta-var)
+    (string->symbol (string-append "b_" (symbol->string (gensym)))))
+  
+  (define (alpha-var? a)
+    (and (symbol? a)
+         (let [(l (string->list (symbol->string a)))]
+           (and (> (length l) 3)
+                (equal? (first l) #\a)
+                (equal? (second l) #\_)
+                (equal? (third l) #\g)))))
+  
+  (define (beta-var? b)
+    (and (symbol? b)
+         (let [(l (string->list (symbol->string b)))]
+           (and (> (length l) 3)
+                (equal? (first l) #\b)
+                (equal? (second l) #\_)
+                (equal? (third l) #\g)))))
+  
+  (define (dim-var? s) (or (alpha-var? s) (beta-var? s)))
+  
+  (define (dim? u) (and (list? u)
+                        (andmap (lambda (u_)
+                                  (and (list? u_)
+                                       (= 2 (length u_))
+                                       (symbol? (car u_))
+                                       (integer? (cadr u_)))) u)))
+  
+  (define (constraint-var c) (second c))
+  (define (constraint-operator c) (first c))
+  (define (constraint-left-side c) (third c))
+  (define (constraint-right-side c) (fourth c))
+  
+  (define (create-constraints hashed-units hashed-vars 
+                              all-formulas all-circular-formulas all-formula-texts parser)
+    (foldl (lambda (f constraints)
+             (let ([a_s (hash-table-get hashed-units (car f))])
+               (create-constraints-for-formula a_s (cadr f) (car f) constraints
+                                               hashed-units hashed-vars 
+                                               all-formulas all-formula-texts parser)))
+           empty all-circular-formulas))
+  
+  (define (create-constraints-for-formula sym formula cell-loc formula-constraints
+                                          hashed-units  hashed-vars 
+                                          all-formulas all-formula-texts parser)
+    (match formula
+      [($ xl-number name deps val)
+       (cons (list '= sym (empty-unit)) formula-constraints)]
+      [($ cell-ref name cell-name)
+       (cond [(in-hash? hashed-units name)
+              (cons
+               (list '= sym (hash-table-get hashed-units name))
+               formula-constraints)]
+             [else (cons (list '= sym (empty-unit)) formula-constraints)])]
+      [($ named-cell-ref name cell-name actual-name)
+       (cond [(in-hash? hashed-units name)
+              (cons
+               (list '= sym (hash-table-get hashed-units name))
+               formula-constraints)]
+             [else (cons (list '= sym (empty-unit)) formula-constraints)])]
+      [($ binary-op name deps op arg1 arg2)
+       (let* ([left-op (gen-beta-var)]
+              [right-op (gen-beta-var)]
+              [new-constraints
+               (create-constraints-for-formula 
+                left-op arg1 cell-loc
+                (create-constraints-for-formula
+                 right-op arg2 cell-loc formula-constraints hashed-units hashed-vars
+                 all-formulas all-formula-texts parser)
+                hashed-units hashed-vars all-formulas all-formula-texts parser)])
+         (case op
+           [(+ -)
+            (cons (list '= sym left-op)
+                  (cons (list '= sym right-op) new-constraints))]
+           [(*)
+            (cons (list '@ sym left-op right-op) new-constraints)]
+           [(/)
+            (cons (list '@/ sym left-op right-op) new-constraints)]
+           [(^)
+            (cons (list '= right-op (empty-unit)) new-constraints)]))]
+      [($ boolean-op name deps op arg1 arg2)
+       (let* ([left-op (gen-beta-var)]
+              [right-op (gen-beta-var)]
+              [new-constraints
+               (create-constraints-for-formula 
+                left-op arg1 cell-loc
+                (create-constraints-for-formula
+                 right-op arg2 cell-loc formula-constraints hashed-units hashed-vars
+                 all-formulas all-formula-texts parser)
+                hashed-units hashed-vars all-formulas all-formula-texts parser)])
+         (cons (list '= left-op right-op)
+               (cons (list '= sym (empty-unit)) new-constraints)))]
+      [($ unary-op name deps op arg)
+       (let ([op-sym (gen-beta-var)])
+         (cons (list '= sym op-sym)
+               (create-constraints-for-formula op-sym arg cell-loc formula-constraints
+                                               hashed-units hashed-vars
+                                               all-formulas all-formula-texts parser)))]
+      [($ tbl-left name deps input-cell)
+       (let* ([left-cell (left-of cell-loc)]
+              [formula-cell (get-formula-loc-up cell-loc parser all-formula-texts)]
+              [formula-sym (gen-beta-var)])
+         (cons (list '= sym formula-sym)
+               (create-constraints-for-formula 
+                formula-sym 
+                (replace-in-formula (cadr (assq formula-cell all-formulas))
+                                    (formula-name input-cell) left-cell)
+                formula-cell formula-constraints hashed-units hashed-vars
+                all-formulas all-formula-texts parser)))]
+      [($ tbl-top name deps input-cell)
+       (let* ([top-cell (top-of cell-loc)]
+              [formula-cell (get-formula-loc-left cell-loc parser all-formula-texts)]
+              [formula-sym (gen-beta-var)])
+         (cons (list '= sym formula-sym)
+               (create-constraints-for-formula 
+                formula-sym 
+                (replace-in-formula (cadr (assq formula-cell all-formulas))
+                                    (formula-name input-cell) top-cell)
+                formula-cell formula-constraints hashed-units hashed-vars
+                all-formulas all-formula-texts parser)))]
+      [($ application name deps fun args)
+       (let* ([arg-syms (map (lambda (a) (gen-beta-var)) args)]
+              [arg-constraints
+               (letrec ([gen-arg-constraints
+                         (lambda (as as-syms)
+                           (cond 
+                             [(empty? as) formula-constraints]
+                             [else
+                              (create-constraints-for-formula 
+                               (first as-syms) (first as) cell-loc
+                               (gen-arg-constraints (rest as) (rest as-syms))
+                               hashed-units hashed-vars 
+                               all-formulas all-formula-texts parser)]))])
+                 (gen-arg-constraints args arg-syms))])
+         (case fun
+           [(average sum min max mina maxa)
+            (foldl (lambda (arg constraints) (cons (list '= sym arg) constraints))
+                   arg-constraints arg-syms)]
+           [(not or and)
+            (cons (list '= sym (empty-unit))
+                  (foldl (lambda (arg constraints) (cons (list '= sym empty-unit) constraints))
+                         arg-constraints arg-syms))]               
+           [(if) (cond
+                   [(= 3 (length args))
+                    (let ([if-sym (second arg-syms)]
+                          [else-sym (third arg-syms)]
+                          [test-sym (first arg-syms)])
+                      (cons (list '= test-sym (empty-unit))
+                            (cons (list '= if-sym else-sym)
+                                  (cons (list '= sym if-sym) arg-constraints))))]
+                   [else (error fun "illegal use")])]
+           [(abs) (cond
+                    [(= 1 (length args)) (cons (list '= sym (first arg-syms) arg-constraints))]
+                    [else (error fun "illegal use")])]
+           [(ceiling round)
+            (cond
+              [(= 2 (length args))
+               (let ([num-sym (first arg-syms)]
+                     [prec-sym (second arg-syms)])
+                 (cons (list '= prec-sym (empty-unit))
+                       (cons (list '= sym num-sym) arg-constraints)))]
+              [else (error fun "illegal use")])]
+           [(large) (let* ([reversed-syms (reverse arg-syms)]
+                           [k-sym (first reversed-syms)]
+                           [array-syms (rest reversed-syms)])
+                      (cons (list '= k-sym (empty-unit))
+                            (foldl (lambda (arg constraints) (cons (list '= sym arg) constraints))
+                                   arg-constraints array-syms)))]
+           [(acos acosh asin asinh atan atanh cos cosh sin sinh tan tanh exp)
+            (let ([arg-sym (first arg-syms)])
+              (cond [(= 1 (length args))
+                     (cons (list '= arg-sym (empty-unit))
+                           (cons (list '= sym (empty-unit)) arg-constraints))]
+                    [else (error fun "illegal use")]))]
+           [(sqrt) (let ([arg-sym (first arg-syms)])
+                     (cond
+                       [(= 1 (length args))
+                        (cons (list '@/ sym arg-sym sym) arg-constraints)]
+                       [else (error fun "illegal use")]))]
+           [(fact ln log) (let ([arg-sym (first arg-syms)])
+                            (cond
+                              [(= 1 (length args))
+                               (cons (list '= arg-sym (empty-unit))
+                                     (cons (list '= sym (empty-unit)) arg-constraints))]
+                              [else (error fun "illegal use")]))]
+           [(isnumber)
+            (cond [(= 1 (length arg-syms)) (cons (list '= sym (empty-unit)) arg-constraints)]
+                  [else (error fun "illegal use")])]
+           [(median stdev)
+            (foldl (lambda (arg constraints) (cons (list '= sym arg) constraints))
+                   arg-constraints arg-syms)]
+           [(npv)
+            (cond [(>= (length args) 2)
+                   (cons (cons '= (first arg-syms) (empty-unit))
+                         (foldl (lambda (arg constraints) (cons (list '= sym arg) constraints))
+                                arg-constraints (rest arg-syms)))]
+                  [else (error fun "illegal use")])]
+           [(count) (cons (list '= sym (empty-unit)) arg-constraints)]
+           [(frequency)
+            (when (not (empty? arg-syms))
+              (let ([first-sym (first arg-syms)])
+                (cons (list '= sym (empty-unit))
+                      (foldl (lambda (arg constraints) (cons (list '= first-sym arg) constraints))
+                             arg-constraints (rest arg-syms)))))]
+           [(mod)
+            (cond [(= 2 (length args)) (cons (list '= sym (first arg-syms)) arg-constraints)]
+                  [else (error fun "illegal use")])]
+           [(na pi today now) 
+            (cond [(empty? args) (cons (list '= sym (empty-unit)) arg-constraints)]
+                  [else (error fun "illegal use")])]
+           [(mmult) (let* ([formula-text (lookup-formula-text cell-loc all-formula-texts)]
+                           [Ms (identify-matrices
+                                (substring formula-text 7
+                                           (sub1 (string-length formula-text))))])
+                      (cond
+                        [(= 2 (length Ms))
+                         (let* ([cell-xy (get-cell-row-col cell-loc)]
+                                [M1-row (car cell-xy)]
+                                [M2-col (cadr cell-xy)]
+                                [M1-row-sym (gen-beta-var)]
+                                [M2-col-sym (gen-beta-var)]
+                                [row-syms-constraints (matrix-row-syms (car Ms) M1-row
+                                                                       hashed-units hashed-vars)]
+                                [row-syms (first row-syms-constraints)]
+                                [row-constraints (second row-syms-constraints)]
+                                [col-syms-constraints (matrix-col-syms (cadr Ms) M2-col
+                                                                       hashed-units hashed-vars)]
+                                [col-syms (first col-syms-constraints)]
+                                [col-constraints (second col-syms-constraints)])
+                           (cons (list '@ sym M1-row-sym M2-col-sym)
+                                 (foldl (lambda (arg constraints)
+                                          (cons (list '= M1-row-sym arg) constraints))
+                                        (foldl (lambda (arg constraints)
+                                                 (cons (list '= M2-col-sym arg) constraints))
+                                               (append arg-constraints row-constraints
+                                                       col-constraints)
+                                               col-syms)
+                                        row-syms)))]
+                        [else (error fun "illegal use")]))]         
+           [else (cons (list '= sym (list (list 'error/unimplemented-function 1)))
+                       arg-constraints)]))]))
+  
+  (define (prune-constraints equality-constraints hashed-constraints-vars)
+    (for-each (lambda (c)
+                (let* ([syms (cond [(or (dim? (second c)) (is-error-unit? (second c)))
+                                    (list (third c) (second c))]
+                                   [else (list (second c) (third c))])]
+                       [sym1 (first syms)]
+                       [sym2 (second syms)])
+                  (if (or (dim? sym2) (is-error-unit? sym2))
+                      (resolve-var-dim sym1 sym2 hashed-constraints-vars)
+                      (resolve-var-var sym1 sym2 hashed-constraints-vars))))
+              equality-constraints))
+  
+  (define (replace-equiv-in-constraints hashed-constraints-vars append-constraints)
+    (let* ([replace-head
+            (lambda (var)
+              (cond
+                [(in-hash? hashed-constraints-vars var)
+                 (first (find-rep (first (hash-table-get hashed-constraints-vars var))))]
+                [else var]))]
+           [replace-operands
+            (lambda (operands)
+              (let ([replace-op
+                     (lambda (op)
+                       (if (dim-var? op)
+                           (cond
+                             [(in-hash? hashed-constraints-vars op)
+                              (let* ([rep (first 
+                                           (find-rep 
+                                            (first (hash-table-get hashed-constraints-vars op))))]
+                                     [rep-u (second (hash-table-get hashed-constraints-vars rep))])
+                                (if (empty? rep-u)
+                                    (list (list rep 1))
+                                    rep-u))]
+                             [else (list (list op 1))])
+                           op))])
+                (append (replace-op (first operands)) (replace-op (second operands)))))]
+           [map-replace 
+            (lambda (c)
+              (cons (replace-head (second c))
+                    (cons '= (replace-operands (rest (rest c))))))])
+      (remove-duplicates (map map-replace append-constraints))))
+  
+  (define (resolve-var-dim var u hashed-constraints-vars)
+    (if (not (in-hash? hashed-constraints-vars var))
+        (hash-table-put! hashed-constraints-vars var (list (make-equiv-class var) u))
+        (let* ([tbl-entry (hash-table-get hashed-constraints-vars var)]
+               [rep (first (find-rep (first tbl-entry)))]
+               [rep-tbl-entry (hash-table-get hashed-constraints-vars rep)])
+          (let ([var-u
+                 (cond [(empty? (second tbl-entry)) u]
+                       [(not (or (equal? (second tbl-entry) u) 
+                                 (is-error-unit? (second tbl-entry))))
+                        (cond [(is-error-unit? u) u]
+                              [else (list (list 'error/equality var))])]
+                       [else u])])
+            (hash-table-put! hashed-constraints-vars  var
+                             (list (first tbl-entry) var-u))
+            (let ([rep-u
+                   (cond [(empty? (second rep-tbl-entry)) var-u]
+                         [(not (or (equal? (second rep-tbl-entry) u)
+                                   (is-error-unit? (second rep-tbl-entry))))
+                          (cond [(is-error-unit? u) u]
+                                [else (list (list 'error/equality rep))])]
+                         [else var-u])])
+              (hash-table-put! hashed-constraints-vars rep
+                               (list (first rep-tbl-entry) rep-u)))))))
+  
+  (define (resolve-var-var var1 var2 hashed-constraints-vars)
+    (when (not (in-hash? hashed-constraints-vars var1))
+      (hash-table-put! hashed-constraints-vars var1 (list (make-equiv-class var1) empty)))
+    (when (not (in-hash? hashed-constraints-vars var2))
+      (hash-table-put! hashed-constraints-vars var2 (list (make-equiv-class var2) empty)))
+    (let ([var1-tbl-entry (hash-table-get hashed-constraints-vars var1)]
+          [var2-tbl-entry (hash-table-get hashed-constraints-vars var2)])
+      (union (first (hash-table-get hashed-constraints-vars var1))
+             (first (hash-table-get hashed-constraints-vars var2)))
+      (let* ([var1-u (second var1-tbl-entry)]
+             [var2-u (second var2-tbl-entry)]
+             [var-u
+              (cond [(empty? var1-u) var2-u]
+                    [(empty? var2-u) var1-u]
+                    [(not (equal? var1-u var2-u))
+                     (list (list 'error/equality var1))]
+                    [else var1-u])]
+             [rep (first (find-rep (first var1-tbl-entry)))]
+             [rep-tbl-entry (hash-table-get hashed-constraints-vars rep)]
+             [rep-u (second rep-tbl-entry)]
+             [new-u
+              (cond [(empty? var-u) rep-u]
+                    [(empty? rep-u) var-u]
+                    [(not (equal? var-u rep-u))
+                     (list (list 'error/equality rep))]
+                    [else var-u])])
+        (hash-table-put! hashed-constraints-vars var1
+                         (list (first var1-tbl-entry) new-u))
+        (hash-table-put! hashed-constraints-vars var2
+                         (list (first var2-tbl-entry) new-u))
+        (hash-table-put! hashed-constraints-vars rep
+                         (list (first rep-tbl-entry) new-u)))))
+  
+  (define (filter-out-bad-constraints cs)
+    (let* ([bad-vars (make-hash-table)]
+           [new-cs
+            (filter
+             (lambda (c)
+               (let ([right-side (rest (rest c))]
+                     [left-side (first c)])
+                 (cond [(or (not (assq left-side right-side))
+                            (andmap (lambda (u) (dim-var? (first u))) right-side)) #t]
+                       [else
+                        (cond [(dim-var? (first (first right-side)))
+                               (hash-table-put! bad-vars (first (first right-side))
+                                                '((error/circular 1)))]
+                              [else
+                               (hash-table-put! bad-vars (first (second right-side))
+                                                '((error/circular 1)))])
+                        #f])))
+             cs)])
+      new-cs))
+  
+  (define (rearrange-constraints cs)
+    (map (lambda (c)
+           (let ([right-side (rest (rest c))]
+                 [left-side (first c)])
+             (cond [(not (assq left-side right-side))
+                    (cons (list left-side -1) right-side)]
+                   [else
+                    (filter
+                     (lambda (u) (not (= 0 (second u))))
+                     (map (lambda (u)
+                            (cond [(eq? left-side (first u))
+                                   (list (first u) (sub1 (second u)))]
+                                  [else u]))
+                          right-side))])))
+         cs))
+  
+  (define (ordered-variables eqs)
+    (remove-duplicates
+     (quicksort
+      (foldl (lambda (eq vars)
+               (append
+                (foldl (lambda (u eq-vars)
+                         (cond [(dim-var? (first u)) (cons (first u) eq-vars)]
+                               [else eq-vars]))
+                       empty eq)
+                vars))
+             empty eqs)
+      (lambda (var1 var2) (string<? (symbol->string var1) (symbol->string var2))))))
+  
+  (define (reorder-eqs eqs)
+    (let ([ordered-vars (ordered-variables eqs)])
+      (list 
+       ordered-vars
+       (map
+        (lambda (eq)
+          (let* ([vars-dims (split-list eq (lambda (u) (dim-var? (first u))))]
+                 [vars (first vars-dims)])
+            (list
+             (map
+              (lambda (var)
+                (let ([var-exp (assq var vars)])
+                  (cond [var-exp (second var-exp)]
+                        [else 0])))
+              ordered-vars)
+             (second vars-dims))))
+        eqs))))
+  
+  (define (reduce eq)
+    (foldr
+     (lambda (u new-eq)
+       (cond [(= 0 (second u)) new-eq]
+             [(assq (first u) new-eq)
+              (filter
+               (lambda (u) (not (= 0 (second u))))
+               (map (lambda (u_new)
+                      (cond [(eq? (first u) (first u_new))
+                             (list (first u) (+ (second u) (second u_new)))]
+                            [else u_new]))
+                    new-eq))]
+             [else (cons u new-eq)]))
+     empty eq))
+  
+  (define (first-n l n)
+    (cond [(> n (length l)) l]
+          [else
+           (letrec ([loop (lambda (l n)
+                            (cond [(>= 0 n) empty]
+                                  [else (cons (first l) (loop (rest l) (sub1 n)))]))])
+             (loop l n))]))
+  
+  (define (normalize-unit us)
+    (let* ([sorted-us (quicksort us (lambda (u1 u2)
+                                      (string<=?
+                                       (symbol->string (car u1))
+                                       (symbol->string (car u2)))))]
+           [new-u (filter
+                   (lambda (u)
+                     (not (= 0 (second u))))
+                   (foldr (lambda (u new-us)
+                            (cond
+                              [(eq? 'empty_unit (first u)) new-us]
+                              [(assq (first u) new-us)
+                               (map (lambda (new_u)
+                                      (cond [(eq? (first new_u) (first u))
+                                             (list (first u) (+ (second u) (second new_u)))]
+                                            [new_u]))
+                                    new-us)]
+                              [else (cons u new-us)]))
+                          empty sorted-us))])
+      (cond [(empty? new-u) (empty-unit)]
+            [else new-u])))
+  
+  (define (select-nth eqs eqn n)
+    (letrec ([split
+              (lambda (eqs i)
+                (cond [(>= i (length eqs)) (list empty eqs)]
+                      [else
+                       (let* ([eq-i (list-ref eqs i)]
+                              [row (first eq-i)]
+                              [nth-val (list-ref row n)])
+                         (cond [(not (= 0 nth-val))
+                                (list
+                                 (list
+                                  (map (lambda (val) (/ val nth-val)) row)
+                                  (normalize-unit
+                                   (map (lambda (u) (list (first u) (/ (second u) nth-val)))
+                                        (second eq-i))))
+                                 (append (first-n eqs i) (list-tail eqs (add1 i))))]
+                               [else (split eqs (add1 i))]))]))])
+      (let* ([nth-rest (split eqs 0)]
+             [nth-eq (first nth-rest)]
+             [nth-eq-u (cond [(empty? nth-eq) (empty-unit)]
+                             [else (second nth-eq)])]
+             [transform
+              (lambda (eqs kth-eq)
+                (map
+                 (lambda (eq)
+                   (let* ([row (first eq)]
+                          [kth-row (first kth-eq)]
+                          [nth-eq (list-ref row n)]
+                          [nth-kth-eq (list-ref kth-row n)]
+                          [ratio (/ nth-eq nth-kth-eq)])
+                     (letrec ([simplify
+                               (lambda (i)
+                                 (cond [(>= i (length row)) empty]
+                                       [else (cons (- (list-ref row i)
+                                                      (* ratio (list-ref kth-row i)))
+                                                   (simplify (add1 i)))]))])
+                       (cond [(= 0 ratio) eq]
+                             [else (list (simplify 0)
+                                         (normalize-unit
+                                          (append (second eq)
+                                                  (map (lambda (u) (list (first u) (* (- 0 ratio) (second u))))
+                                                       nth-eq-u))))]))))
+                 eqs))])
+              ;;(printf "NTH-EQ: ~a || n = ~a~n" nth-eq n)
+              ;;(printf "TRANSFORMED REST: ~a~n" (transform (second nth-rest) nth-eq))
+        (cond [(empty? (first nth-rest)) (list eqs eqn)]
+              [else
+               (let ([transformed-eq (transform (second nth-rest) nth-eq)])
+                 (cond [(ormap (lambda (eq) (and (andmap (lambda (v) (= 0 v)) (first eq))
+                                                 (not (or (empty? (second eq))
+                                                          (eq? (first (first (second eq))) 'empty_unit)))))
+                               transformed-eq)
+                        (list
+                         (cons (list (first nth-eq) '((error/circular 1))) transformed-eq)
+                         (add1 eqn))]
+                       [else
+                        (list
+                         (cons nth-eq transformed-eq)
+                         (add1 eqn))]))]))))
+  
+  (define (modify-eqs eqs)
+    (let* ([order-eqs (reorder-eqs eqs)]
+           [ordered-vars (first order-eqs)]
+           [eqs (second order-eqs)]
+           [select-eq-for-n-var
+            (lambda (eqs eqn n)
+              ;;(printf "EQS:~a~n" eqs)
+              (let* ([good-eqs (first-n eqs eqn)]
+                     [mod-eqs (list-tail eqs eqn)]
+                     [meqs-eqn (select-nth mod-eqs eqn n)])
+                ;;(printf "SELECT-NTH MEQS-EQN: ~a~n" meqs-eqn)
+                (list (append good-eqs (first meqs-eqn)) (second meqs-eqn))))])
+      (letrec ([modify
+                (lambda (eqs n eqn)
+                  (cond [(>= n (length ordered-vars))
+                         (list ordered-vars (first-n eqs eqn))]
+                        [else
+                         (let ([neweqs-eqn (select-eq-for-n-var eqs eqn n)])
+                           ;;(printf "NEW-EQS-EQN: ~a~n" neweqs-eqn)
+                           (modify (first neweqs-eqn) (+ n 1) (second neweqs-eqn)))]))])
+        (modify eqs 0 0))))
+  
+  (define (gaussian-elimination append-constraints)
+    (let* ([eqs (rearrange-constraints
+                 (filter-out-bad-constraints append-constraints))]
+           [order-triang-eqs (modify-eqs eqs)]
+           [ordered-vars (first order-triang-eqs)])
+      ;;(printf "EQS: ~a~n" eqs)
+      ;;(printf "ORDERED TRIANG EQS: ~a~n" order-triang-eqs)
+      (letrec ([nth-var (lambda (row n) (cond [(= 0 (length row)) -1]
+                                              [(= 1 (first row)) n]
+                                              [else (nth-var (rest row) (add1 n))]))])
+        (map
+         (lambda (var-sol)
+           (list (first var-sol)
+                 (cond [(ormap (lambda (u) (not (integer? (second u)))) (second var-sol))
+                        '((error/circular 1))]
+                       [else (second var-sol)])))
+         (foldr
+          (lambda (eq sols)
+            (let* ([n (nth-var (first eq) 0)]
+                   [var (list-ref ordered-vars n)])
+              ;;(printf "eq: ~a || n = ~a || nth-var = ~a~n" (first eq) n var)
+              (cons
+               (list
+                var
+                (letrec [(computed-u (lambda (n)
+                                       (cond [(>= n (length (first eq))) empty]
+                                             [else
+                                              (let* ([n-var (list-ref ordered-vars n)]
+                                                     [var-exp (assq n-var sols)])
+                                                ;;(printf "n-var = ~a || var-exp = ~a~n" n-var var-exp)
+                                                (cond
+                                                  [var-exp 
+                                                   (let ([factor (- 0 (list-ref (first eq) n))])
+                                                     (append (map (lambda (u) (list (first u) (* factor (second u))))
+                                                                  (second var-exp))
+                                                             (computed-u (add1 n))))]
+                                                  [else '((error/circular 1))]))])))]
+                  (let ([c-u (computed-u (add1 n))])
+                    ;;(printf "VAR = ~a | c-u = ~a | second eq = ~a~n" var c-u (second eq))
+                    (cond [(ormap (lambda (u) (or (eq? (first u) 'error/circular)
+                                                  (not (integer? (second u)))))
+                                  c-u)
+                           '((error/circular 1))]
+                          [else (normalize-unit
+                                 (append c-u (map (lambda (u) (list (first u) (- 0 (second u)))) (second eq))))]))))
+               sols)))
+          empty
+          (second order-triang-eqs))))))
+  
+  (define (solve-constraints solved-constraints
+                             hashed-constraints-vars hashed-vars hashed-units)
+    ;;(printf "HASHED VARS:~n")
+    ;;(all-hashed-values hashed-vars)
+    ;;(printf "HASHED CONSTRAINTS:~n")
+    ;;(all-hashed-values hashed-constraints-vars)
+    ;;(printf "SOLVED CONSTRAINTS: ~a~n" solved-constraints)
+    (for-each (lambda (c) (resolve-var-dim (first c) (second c) hashed-constraints-vars))
+              solved-constraints)
+    ;;(printf "HASHED CONSTRAINTS AFTER GAUSSIAN:~n")
+    ;;(all-hashed-values hashed-constraints-vars)
+    (resolve-constraints-vars hashed-constraints-vars)
+    ;;(printf "HASHED CONSTRAINTS AFTER RESOLVE:~n")
+    ;;(all-hashed-values hashed-constraints-vars)
+    (replace-constraints-vars hashed-constraints-vars hashed-vars hashed-units))
+  
+  (define (resolve-constraints-vars hashed-constraints-vars)
+    (hash-table-for-each
+     hashed-constraints-vars
+     (lambda (var vals)
+       (let* ([var-u (second vals)]
+              [rep (first (find-rep (first vals)))]
+              [rep-tbl-entry (hash-table-get hashed-constraints-vars rep)]
+              [rep-u (second rep-tbl-entry)])
+         (when (not (eq? var rep))
+           (let ([new-u
+                  (cond [(empty? rep-u) var-u]
+                        [(and (not (empty? var-u)) (not (equal? rep-u var-u)))
+                         (list (list 'error/equality rep))]
+                        [else rep-u])])
+             (hash-table-put! hashed-constraints-vars rep
+                              (list (first rep-tbl-entry) new-u)))))))
+    (hash-table-for-each
+     hashed-constraints-vars
+     (lambda (var vals) (hash-table-put!
+                         hashed-constraints-vars var
+                         (list (first vals)
+                               (second (hash-table-get 
+                                        hashed-constraints-vars
+                                        (first (find-rep (first vals))))))))))
+  
+  (define (replace-constraints-vars hashed-constraints-vars hashed-vars hashed-units)
+    (hash-table-for-each
+     hashed-constraints-vars
+     (lambda (var val)
+       (when (alpha-var? var)
+         (let ([cell-loc (first (hash-table-get hashed-vars var))]
+               [u (second val)])
+           (when (not (empty? u))
+             (when (is-error-unit? u)
+               (set! u (list (list (first (first u)) cell-loc))))
+             (hash-table-put! hashed-vars var (list cell-loc u)))))))
+    (hash-table-for-each
+     hashed-vars
+     (lambda (var val)
+       (let ([cell-loc (first val)]
+             [u (second val)])
+         (hash-table-put! hashed-units cell-loc u)))))
+  
+  (define (lookup-formula-text cell-sym all-formula-texts)
+    (let ([entry (assq cell-sym all-formula-texts)])
+      (and entry (cadr entry))))
+  
+  (define (identify-matrices str)
+    (map (lambda (range)
+           (map (lambda (cell)
+                  (string->symbol cell))
+                (split-string range #\:)))
+         (split-string (to-lower str) #\,)))
+  
+  (define (matrix-row-units M row hashed-units)
+    (let ([row-cells (get-range-cells (first-cell-in-row M row)
+                                      (last-cell-in-row M row))])
+      (map (lambda (cellref)
+             (cond ((in-hash? hashed-units cellref)
+                    (hash-table-get hashed-units cellref))
+                   (else (empty-unit))))
+           row-cells)))
+  
+  (define (matrix-row-syms M row hashed-units hashed-vars)
+    (let ([row-cells (get-range-cells (first-cell-in-row M row)
+                                      (last-cell-in-row M row))])
+      (foldl (lambda (cellref syms-constraints)
+               (let ([sym (gen-beta-var)]
+                     [syms (first syms-constraints)]
+                     [constraints (second syms-constraints)])
+                 (cond [(in-hash? hashed-units cellref)
+                        (let ([u (hash-table-get hashed-units cellref)])
+                          (cond [(in-hash? hashed-vars u) (list (cons u syms) constraints)]
+                                [else (list (cons sym syms)
+                                            (cons (list '= sym u) constraints))]))]
+                       [else (list (cons sym syms)
+                                   (cons (list '= sym (empty-unit)) constraints))])))
+             row-cells)))
+  
+  (define (first-cell-in-row M row)
+    (let ([xy (cellref->numbers (car M))])
+      (numbers->cellref (list (sub1 (car xy)) (+ (cadr xy) row)))))
+  
+  (define (last-cell-in-row M row)
+    (let ([xy-upper (cellref->numbers (car M))]
+          [xy-lower (cellref->numbers (cadr M))])
+      (numbers->cellref (list (sub1 (car xy-lower)) (+ (cadr xy-upper) row)))))
+  
+  (define (matrix-col-units M col hashed-units)
+    (let ([col-cells (get-range-cells (first-cell-in-col M col)
+                                      (last-cell-in-col M col))])
+      (map (lambda (cellref)
+             (cond ((in-hash? hashed-units cellref)
+                    (hash-table-get hashed-units cellref))
+                   (else (empty-unit))))
+           col-cells)))
+  
+  (define (matrix-col-syms M col hashed-units hashed-vars)
+    (let ([col-cells (get-range-cells (first-cell-in-col M col)
+                                      (last-cell-in-col M col))])
+      (foldl (lambda (cellref syms-constraints)
+               (let ([sym (gen-beta-var)]
+                     [syms (first syms-constraints)]
+                     [constraints (second syms-constraints)])
+                 (cond [(in-hash? hashed-units cellref)
+                        (let ([u (hash-table-get hashed-units cellref)])
+                          (cond [(in-hash? hashed-vars u) (list (cons u syms) constraints)]
+                                [else (list (cons sym syms)
+                                            (cons (list '= sym u) constraints))]))]
+                       [else (list (cons sym syms)
+                                   (cons (list '= sym (empty-unit)) constraints))])))
+             col-cells)))
+  
+  (define (first-cell-in-col M col)
+    (let ([xy (cellref->numbers (car M))])
+      (numbers->cellref (list (+ (sub1 (car xy)) col) (cadr xy)))))
+  
+  (define (last-cell-in-col M col)
+    (let ([xy-upper (cellref->numbers (car M))]
+          [xy-lower (cellref->numbers (cadr M))])
+      (numbers->cellref (list (+ (sub1 (car xy-upper)) col) (cadr xy-lower)))))
+  
+  (define (split-large-args l)
+    (let ([reversed-l (reverse l)])
+      (list (list (first reversed-l)) (reverse (rest reversed-l)))))
+  
+  (define (split-circular-non-circular all-formulas)
+    (let ([visited (make-hash-table)])
+      (letrec ([is-circular?
+                (lambda (f fs)
+                  (ormap 
+                   (lambda (dep)
+                     (cond [(in-hash? visited dep)
+                            (let ([circularity (hash-table-get visited dep)])
+                              (cond [(eq? 'circular circularity) #t]
+                                    [else #f]))]
+                           [else
+                            (let ([circularity
+                                   (or (memq dep fs)
+                                       (let ([dep_f (assq dep all-formulas)])
+                                         (and dep_f
+                                              (is-circular? dep_f (cons dep fs)))))])
+                              (cond [circularity
+                                     (hash-table-put! visited dep 'circular)]
+                                    [else
+                                     (hash-table-put! visited dep 'non-circular)])
+                              circularity)]))
+                   (formula-dependencies (cadr f))))])
+        (split-list (reverse all-formulas) (lambda (f) (is-circular? f (list (car f))))))))
+  
+  (define (computation-errors hashed-units all-formula-texts all-formulas)
+    (filter 
+     (lambda (l) (not (empty? l)))
+     (hash-table-map
+      hashed-units
+      (lambda (cell unit)
+        (if (is-error-unit? unit)
+            (let ([o (open-output-string)])
+              (cond [(equal? 'error/propagated (first (first unit)))
+                     (fprintf o "ERROR propagated from cell: ~a"
+                              (second (first unit)))]
+                    [else
+                     (fprintf o "ERROR computed: ~n~a " (car (first unit)))
+                     (fprintf o ", cell formula: ~a~n" 
+                              (lookup-formula-text cell all-formula-texts))])
+              (list cell 
+                    unit 
+                    (get-output-string o) 
+                    (formula-dependencies (cadr (assq cell all-formulas)))))
+            empty)))))
+  
+  (define (mismatch-errors hashed-units all-units all-formula-texts all-formulas)
+    (foldl 
+     (lambda (annot mismatches)
+       (let* ([cell (car annot)]
+              [actual (hash-table-get hashed-units cell)])
+         (cond [(not (or (is-error-unit? actual)
+                         (empty-unit? (cadr annot))
+                         (equal? actual (cadr annot))))
+                (let ([o (open-output-string)])
+                  (fprintf o "MISMATCH computed:~n~a " (unit-pp actual))
+                  (fprintf o "cell-formula: ~a~n" (lookup-formula-text cell all-formula-texts))
+                  (cons (list cell 
+                              actual 
+                              (get-output-string o) 
+                              (formula-dependencies (cadr (assq cell all-formulas))))
+                        mismatches))]
+               [else mismatches])))
+     empty
+     all-units))
+  
+  (define (unit-pp unit)
+    (cond [(empty-unit? unit) "()"]
+          [else
+           (let* ([unit-top-bottom (split-list unit (lambda (u) (> (second u) 0)))]
+                  [unit-top (first unit-top-bottom)]
+                  [unit-bottom (map (lambda (u) (list (first u) (- 0 (second u))))
+                                    (second unit-top-bottom))]
+                  [to-string
+                   (lambda (unit)
+                     (foldl 
+                      (lambda (u visited)
+                        (string-append
+                         (cond [(> (second u) 1)
+                                (string-append "-" (symbol->string (first u)) 
+                                               "^" (number->string (second u)))]
+                               [else
+                                (string-append "-" (symbol->string (first u)))])
+                         visited))
+                      ""
+                      unit))]
+                  [top-string (to-string unit-top)]
+                  [bottom-string (to-string unit-bottom)]
+                  [top-len (string-length top-string)]
+                  [bottom-len (string-length bottom-string)])
+             (cond [(and (= 0 top-len) (= 0 bottom-len)) ""]
+                   [(= 0 top-len) (substring bottom-string 1 bottom-len)]
+                   [(= 0 bottom-len) (substring top-string 1 top-len)]
+                   [else
+                    (string-append (substring top-string 1 top-len) "/("
+                                   (substring bottom-string 1 bottom-len) ")")]))]))
+  )
+
diff --git a/collects/xelda/private/xelda-com.ss b/collects/xelda/private/xelda-com.ss
new file mode 100644
index 0000000000..2205117457
--- /dev/null
+++ b/collects/xelda/private/xelda-com.ss
@@ -0,0 +1,225 @@
+(module xelda-com mzscheme
+  
+  (require (lib "mysterx.ss" "mysterx"))
+  (require (lib "list.ss"))
+  (require (lib "class.ss"))
+  
+  (require "xl-util.ss")
+  
+  (provide load-xl-file           ;; filename -> void
+           set-gui!               ;; gui -> void
+           ;; gui is an instance of the class %xelda-frame% in xelda.ss
+           close-xl-workbook      ;; void -> void
+           clear-cell-precedents  ;; cellref -> void
+           ;; cellref as a symbol representing a cell (ex: 'a1 for cell A1)
+           get-cell-text          ;; cellref -> string
+           get-cell-value         ;; cellref -> cell-value
+           get-cell-formula       ;; cellref -> string
+           get-cell-name          ;; cellref -> string
+           get-cell-row-col       ;; cellref -> (N , N)
+           ;; cell-value is defined as per Excel specifications for "Value" property
+           get-cell-color         ;; cellref -> color
+           set-cell-color!        ;; cellref color -> void
+           get-cell-comment       ;; cellref -> string
+           set-cell-comment!      ;; cellref string -> void
+           delete-cell-comment!   ;; cellref -> void
+           iterate-over-worksheet ;; (cellref -> V) (V -> bool) -> (Listof (cellref , V))
+           work-sheet-enabled?    ;; void -> bool
+           )
+  
+  (define *cached-ws* empty)
+  (define *wb* #f)
+  (define *ws* #f)
+  (define *excel-progid* "Excel.Application")
+  (define *xl* (cci/progid *excel-progid*))
+  (define *gui* #f)
+  
+  (define (range-from-coords row col)
+    (string-append (number->cell-alpha (sub1 col))
+                   (number->string row)))
+  
+  (define (set-gui! gui) (set! *gui* gui))
+  
+  (define (work-sheet-enabled?)
+    (not (equal? *ws* #f)))
+  
+  (define (iterate-over-worksheet f pred?)
+    (when (empty? *cached-ws*)
+      (let* ([ur (com-get-property *ws* "UsedRange")]
+             [cells (com-get-property ur "Cells")]
+             [first-row (com-get-property cells "Row")]
+             [first-col (com-get-property cells "Column")]
+             [num-rows (com-get-property cells "Rows" "Count")]
+             [num-cols (com-get-property cells "Columns" "Count")]
+             [last-row (sub1 (+ first-row num-rows))]
+             [last-col (sub1 (+ first-col num-cols))])
+        (let row-loop ([curr-row first-row]
+                       [row-results null])
+          (if (> curr-row last-row)
+              (set! *cached-ws* row-results)
+              (let col-loop ([curr-col first-col]
+                             [col-results null])
+                (if (> curr-col last-col)
+                    (row-loop (add1 curr-row) 
+                              (append col-results 
+                                      row-results))
+                    (col-loop (add1 curr-col)
+                              (cons (string->symbol (range-from-coords curr-row curr-col))
+                                    col-results))))))))
+    (foldl (lambda (cached-cell selected-cells)
+             (let ([cell-content (f cached-cell)])
+               (if (pred? cell-content)
+                   (cons (list cached-cell cell-content) selected-cells)
+                   selected-cells)))
+           empty *cached-ws*))
+  
+  (define (get-cell-name cell)
+    (with-handlers
+        ([void (lambda _ "")])
+      (com-get-property (com-get-property (cellref->rng cell) "Name") "Name")))
+  
+  (define (get-cell-formula cell)
+    (com-get-property (cellref->rng cell) "Formula"))
+  
+  (define (get-cell-row-col cell)
+    (let* ([rng (cellref->rng cell)]
+           [M (com-get-property rng "CurrentArray")]
+           [first-row (com-get-property M "Row")]
+           [first-col (com-get-property M "Column")]
+           [cell-row (com-get-property rng "Row")]
+           [cell-col (com-get-property rng "Column")])
+      (list (- cell-row first-row) (- cell-col first-col))))
+  
+  
+  (define (set-cell-comment! cell comment-text)
+    (let* ([rng (cellref->rng cell)]
+           [comment-obj (com-get-property rng "Comment")])
+      (with-handlers ([void (lambda _ "")])
+        (com-invoke comment-obj "Delete"))
+      (com-invoke rng "AddComment" (format "~a" comment-text))))
+  
+  (define (delete-cell-comment! cell)
+    (let* ([rng (cellref->rng cell)]
+           [comment-obj (com-get-property rng "Comment")])
+      (with-handlers ([void (lambda _ "")])
+        (com-invoke comment-obj "Delete"))))
+  
+  (define (get-cell-comment cell)
+    (with-handlers ([void (lambda _ "")])
+      (com-invoke (com-get-property (cellref->rng cell) "Comment") "Text")))
+  
+  (define (get-cell-color cellref)
+    (com-get-property (com-get-property (cellref->rng cellref) "Interior") "Color"))
+  
+  (define (set-cell-color! cellref rgb)
+    (let ([rng (cellref->rng cellref)])
+      (com-set-property! 
+       (com-get-property rng "Interior")
+       "Color" rgb)
+      (com-set-property!
+       (com-get-property rng "Borders")
+       "Color" 11842740)))
+  
+  (define (get-cell-text cellref)
+    (com-get-property (cellref->rng cellref) "Text"))
+  
+  (define (get-cell-value cellref)
+    (com-get-property (cellref->rng cellref) "Value"))
+  
+  (define (get-cell row col)
+    (com-get-property 
+     *ws* 
+     `("Range" ,(range-from-coords row col))))
+  
+  (define (cellref->rng cell)
+    (let ([xy (cellref->numbers cell)])
+      (get-cell (cadr xy) (car xy))))
+  
+  (define (clear-cell-precedents cellref)
+    (com-invoke (cellref->rng cellref) "ShowPrecedents" #t))
+  
+  (define (open-xl-workbook xl fname)
+    (let ([wbs (com-get-property xl "Workbooks")])
+      (with-handlers
+          (((lambda (_) #t) (lambda (_) #f)))
+        (com-invoke wbs "Open" fname))))
+  
+  (define (close-xl-workbook)
+    (let ([wbs (com-get-property *xl* "Workbooks")])
+      (with-handlers
+          (((lambda (_) #t) (lambda (_) #f)))
+        (com-invoke wbs "Close"))))
+  
+  (define (add-xl-workbook xl)
+    (let* ([wbs (com-get-property xl "Workbooks")])
+      (com-invoke wbs "Add")))
+  
+  (define (load-xl-file filename)
+    (set! *cached-ws* empty)
+    (com-set-property! *xl* "Visible" #t)
+    (set! *wb* (open-xl-workbook *xl* filename))
+    (set! *ws* (com-get-property *wb* "ActiveSheet"))
+    
+    ;;
+    ;; Event handlers
+    ;;  
+    (com-register-event-handler
+     *wb* "SheetActivate"
+     (lambda (wb-arg)
+       (when *ws*
+         (send *gui* unmark-errors)
+         (com-unregister-event-handler *ws* "SelectionChange"))
+       (set! *ws* (com-get-property *wb* "ActiveSheet"))
+       (set! *cached-ws* empty)
+       (com-register-event-handler
+        *ws* "SelectionChange"
+        (lambda (rng)
+          (when (send *gui* file-opened?)
+            (let* ([row (com-get-property rng "Row")]
+                   [col (com-get-property rng "Column")]
+                   [rows (com-get-property rng "Rows" "Count")]
+                   [cols (com-get-property rng "Columns" "Count")]
+                   [left-top (numbers->cellref (list (sub1 col) row))]
+                   [right-bottom (numbers->cellref (list (- (+ col cols) 2)
+                                                         (sub1 (+ row rows))))])
+              (send *gui* erase-cell-selections)
+              (send *gui* set-cell-selections (format "~a:~a" left-top right-bottom))))))))
+    
+    (com-register-event-handler
+     *ws* "SelectionChange"
+     (lambda (rng)
+       (when (send *gui* file-opened?)
+         (let* ([row (com-get-property rng "Row")]
+                [col (com-get-property rng "Column")]
+                [rows (com-get-property rng "Rows" "Count")]
+                [cols (com-get-property rng "Columns" "Count")]
+                [left-top (numbers->cellref (list (sub1 col) row))]
+                [right-bottom (numbers->cellref (list (- (+ col cols) 2)
+                                                      (sub1 (+ row rows))))])
+           (send *gui* erase-cell-selections)
+           (send *gui* set-cell-selections (format "~a:~a" left-top right-bottom))))))
+    
+    (com-register-event-handler
+     *wb* "BeforeClose"
+     (lambda (cancel) (when (send *gui* file-opened?) (send *gui* close-frame!)))))
+  
+  (com-register-event-handler 
+   *xl* "SheetBeforeRightClick"
+   (lambda (ws rng b)
+     (let* ([row (com-get-property rng "Row")]
+            [col (com-get-property rng "Column")]
+            [cell-ref (numbers->cellref (list (sub1 col) row))])
+       (when (send *gui* error-cell? cell-ref)
+         (set-box! b #t)
+         (let ([dependencies (send *gui* get-error-cell-dependencies cell-ref)])
+           (if (eq? (send *gui* get-error-cell-state cell-ref) 'off)
+               (begin
+                 (send *gui* set-error-cell-state cell-ref 'on)
+                 (send *gui* color-dependents dependencies 'off)
+                 (com-invoke rng "ShowPrecedents" #t))
+               (begin
+                 (send *gui* set-error-cell-state cell-ref 'off)
+                 (send *gui* color-dependents dependencies 'on)
+                 (com-invoke rng "ShowPrecedents")))))))))
+
+
diff --git a/collects/xelda/private/xelda-lib.ss b/collects/xelda/private/xelda-lib.ss
new file mode 100644
index 0000000000..e556074845
--- /dev/null
+++ b/collects/xelda/private/xelda-lib.ss
@@ -0,0 +1,153 @@
+(module xelda-lib mzscheme
+  
+  (require (lib "list.ss"))
+  
+  (provide 
+   average
+   gen-equal-units
+   gen-mult-units
+   gen-div-units
+   gen-exp-units
+   split-list
+   check-empty-units
+   check-equal-units
+   is-error-unit?
+   empty-unit?
+   empty-unit
+   canonicalize-units
+   verify-equal-units)
+   
+  (define (empty-unit) (list (list 'empty_unit 1)))
+     
+  (define (canonicalize-units us)
+    (filter 
+     (lambda (u)
+       (not (zero? (cadr u))))
+     (quicksort us (lambda (u1 u2)
+                     (string<=?  
+                      (symbol->string (car u1))
+                      (symbol->string (car u2)))))))
+
+  (define (empty-unit? u)
+    (and (= (length u) 1)
+         (eq? (car (first u)) 'empty_unit)))
+
+  (define (split-list lst p?)
+    (let loop ([lst lst]
+	       [yes null]
+	       [no null])
+      (if (null? lst)
+	  (list (reverse yes) (reverse no))
+	  (if (p? (car lst))
+	      (loop (cdr lst) (cons (car lst) yes) no)
+	      (loop (cdr lst) yes (cons (car lst) no))))))
+  
+  (define (average . ns)
+    (/ (apply + ns) (length ns)))
+  
+  (define (gen-equal-units . us)
+    (let ([u1 (car us)])
+      (if (andmap (lambda (u) (equal? u u1))
+		  (cdr us))
+	  u1
+	  '((error/equality 1)))))
+  
+  (define (is-error-unit? u)
+    (if (and (list? u) (pair? (first u)))
+        (let ([str (symbol->string (car (first u)))])
+          (cond
+            ((and (> (string-length str) 6)
+                  (string=? (substring str 0 6) "error/")) #t)
+            (else #f)))
+        #f))
+  
+  (define (check-equal-units unts sym)
+    (let* ([us (map (lambda (_us)
+                      (map (lambda (u)
+                             (cond ((eq? (car u) 'empty_unit)
+                                    (list 'empty_unit 1))
+                                   (else u))) _us)) unts)]
+           [base-unit (first us)]
+           [err-us (filter (lambda (u) (is-error-unit? u)) us)])
+      (if (not (empty? err-us))
+          (if (eq? sym (second (first (first err-us))))
+              (first err-us)
+              (list (list 'error/propagated (second (first (first err-us))))))
+          (if (andmap (lambda (u) (equal? u base-unit)) us)
+              base-unit
+              (list (list 'error/equality sym))))))
+  
+  (define (verify-equal-units cell-name u1 u2)
+    (if (equal? u1 u2)
+	(printf "Verified units for cell ~a~n" cell-name)
+	(printf (string-append 
+		 "Units problem with cell ~a:~n"
+		 "Cell annotated with ~a, formula yields ~a~n")
+		cell-name u1 u2)))
+  
+  (define (gen-mult-units u1 u2 sym)
+    (cond [(is-error-unit? u1)
+           (cond [(eq? sym (second (first u1))) u1]
+                 [else (list (list 'error/propagated
+                                   (second (first u1))))])]
+          [(is-error-unit? u2)
+           (cond [(eq? sym (second (first u2))) u2]
+                 [else (list (list 'error/propagated
+                                   (second (first u2))))])]
+          [(empty-unit? u1) u2]
+          [(empty-unit? u2) u1]
+          [else
+           (let ([raw-us (append u1 u2)])
+             (let loop ([new-us raw-us]
+                        [result null])
+               (if (null? new-us)
+                   (canonicalize-units result)
+                   (let* ([u (car new-us)]
+                          [u-name (car u)]
+                          [u-exp (cadr u)]
+                          [u-and-non-u 
+                           (split-list (cdr new-us) 
+                                       (lambda (x) 
+                                         (eq? (car x) u-name)))]
+                          [new-u-exp (+ u-exp 
+                                        (apply + (map cadr (car u-and-non-u))))]
+                          [non-u (cadr u-and-non-u)])
+                     (loop non-u (cons (list u-name new-u-exp) result))))))]))
+  
+  (define (gen-div-units u1 u2 sym)
+    (cond [(is-error-unit? u1)  
+           (cond [(eq? sym (second (first u1))) u1]
+                 [else (list (list 'error/propagated
+                                   (second (first u1))))])]
+          [(is-error-unit? u2)
+           (cond [(eq? sym (second (first u2))) u2]
+                 [else (list (list 'error/propagated
+                                   (second (first u2))))])]
+          [(empty-unit? u2) u1]
+          [else
+           (gen-mult-units u1 (map (lambda (u)
+                                     (let ([u-name (car u)]
+                                           [u-exp (cadr u)])
+                                       (list u-name (- 0 u-exp)))) u2) sym)]))
+  
+  (define (gen-exp-units u exp sym)
+    (cond [(is-error-unit? u)
+           (cond [(eq? sym (second (first u))) u]
+                 [else (list (list 'error/propagated (second (first u))))])]
+          [else
+           (if (not (integer? exp))
+               '((error/exponentiation sym))
+               (cond [(empty-unit? u) u]
+                     [else
+                      (map (lambda (u_)
+                             (let ([u-name (car u_)]
+                                   [u-exp (cadr u_)])
+                               (list u-name (inexact->exact 
+                                             (* exp u-exp)))))
+                           u)]))]))
+  
+  (define (check-empty-units . us)
+    (if (andmap null? us)
+	null
+	'((error/empty-unit 1)))))
+
diff --git a/collects/xelda/private/xl-util.ss b/collects/xelda/private/xl-util.ss
new file mode 100644
index 0000000000..198cf39e53
--- /dev/null
+++ b/collects/xelda/private/xl-util.ss
@@ -0,0 +1,188 @@
+(module xl-util mzscheme
+  (require (lib "list.ss"))
+  
+  (provide 
+   cell-alpha->number
+   number->cell-alpha
+   get-range-cells
+   numbers->cellref
+   cellref->numbers
+   split-string
+   in-list?
+   make-equiv-class
+   find-rep
+   union
+   to-lower
+   show-constraints
+   all-hashed-values
+   in-hash?
+   init-hash
+   left-of
+   top-of)   
+      
+  (define (show-constraints constraints)
+    (for-each (lambda (c) (printf "constraint: ~a~n" c)) constraints))
+
+  (define (in-hash? ht v)
+    (not (not (hash-table-get ht v (lambda () #f)))))
+  
+  (define (init-hash ht l)
+    (if (not (empty? l))
+        (begin
+          (let ([cell-name (car (first l))]
+                [u (cadr (first l))])
+            (if (not (in-hash? ht cell-name))
+                (hash-table-put! ht cell-name u)))
+          (init-hash ht (rest l)))))
+  
+  (define (all-hashed-values ht)
+    (hash-table-for-each ht
+                         (lambda (key val)
+                           (printf "Key:~a -> Value:~a~n" key val))))
+
+  (define (make-equiv-class a) (list a))
+  
+  (define (find-rep equiv-class)
+    (let ([rep (last-pair equiv-class)])
+      (when (not (eq? equiv-class rep))
+        (set-cdr! equiv-class rep))
+      rep))
+  
+  (define (union equiv-class1 equiv-class2)
+    (let ([rep1 (find-rep equiv-class1)]
+          [rep2 (find-rep equiv-class2)])
+      (unless (eq? rep1 rep2)
+        (set-cdr! rep2 rep1))
+      rep1))
+  
+  (define (in-list? e l)
+    (cond [(empty? l) #f]
+          [(equal? e (first l)) #t]
+          [else (in-list? e (rest l))]))
+  
+  (define (to-lower str)
+    (letrec ([loop (lambda (l)
+                     (cond
+                       ((empty? l) empty)
+                       ((char-upper-case? (first l))
+                        (cons (integer->char 
+                               (+ (- (char->integer (first l))
+                                     (char->integer #\A))
+                                  (char->integer #\a)))
+                              (loop (rest l))))
+                       (else (cons (first l) (loop (rest l))))))])
+      (list->string (loop (string->list str)))))
+  
+  (define (split-string str c)
+    (letrec ([loop (lambda (i first max c)
+                     (cond
+                       ((>= first max) empty)
+                       ((>= i max) 
+                        (list (substring str first max)))
+                       ((eq? (string-ref str i) c)
+                        (cons 
+                         (substring str first i)
+                         (loop (add1 i) (add1 i) max c)))
+                       (else (loop (add1 i) first max c))))])
+      (loop 0 0 (string-length str) c)))
+  
+  ; #\a = 0, #\b = 1, etc.
+  (define (letter->number c)
+    (- (char->integer c) 97)) ; #\a
+  (define (number->letter n)
+    (integer->char (+ n 97)))
+  
+  ; "a" = 0, "b" = 1, ... , "aa" = 26, ... , "ba" = 52, ...
+  (define (cell-alpha->number s)
+    (let ([len (string-length s)])
+      (if (= len 1)
+	  (letter->number (string-ref s 0))
+	  (+  (* 26 (add1 (letter->number (string-ref s 0))))
+	      (letter->number (string-ref s 1))))))
+  (define (number->cell-alpha n)
+    (if (< n 26)
+	(string (number->letter n))
+	(string-append 
+	 (string (number->letter (sub1 (quotient n 26))))
+	 (string (number->letter (modulo n 26))))))
+  
+  
+  ; given a cell address as a symbol, such as 'D5
+  ; returns the alpha and numeric pieces as a string and a number
+  (define (get-cell-components csym)
+    (let* ([c (symbol->string csym)]
+	   [len (string-length c)])
+      (if (char-numeric? (string-ref c 1))
+	  (values (substring c 0 1) 
+		  (string->number (substring c 1 len)))
+	  (values (substring c 0 2) 
+		  (string->number (substring c 2 len))))))
+  
+  ; from pair of numbers representing a cell address in its alpha
+  ; and numeric components, return symbol
+  ; (1 1) = A1, ... , (27 0) = AA0, ...
+  (define (numbers->cellref ns)
+    (let ([alpha-part (car ns)]
+	  [num-part (cadr ns)])
+      (string->symbol
+       (string-append
+	(number->cell-alpha alpha-part)
+	(number->string num-part)))))
+  (define (cellref->numbers cell)
+    (letrec ([iter (lambda (l x y)
+                     (cond
+                       ((empty? l) (list x y))
+                       (else
+                        (let ([c (first l)])
+                          (cond
+                            ((char-numeric? c)
+                             (iter (rest l) x (+ (* 10 y)
+                                                 (- (char->integer c)
+                                                    (char->integer #\0)))))
+                            (else
+                             (iter (rest l) (+ (* 26 x)
+                                               (- (char->integer c)
+                                                  (char->integer #\a)) 1) y)))))))])
+      (iter (string->list (symbol->string cell)) 0 0)))
+  
+  (define (left-of loc)
+    (let* ([xy (cellref->numbers loc)]
+           [x (- (car xy) 2)]
+           [y (cadr xy)])
+      (numbers->cellref (list x y))))
+  
+  (define (top-of loc)
+    (let* ([xy (cellref->numbers loc)]
+           [x (sub1 (car xy))]
+           [y (sub1 (cadr xy))])
+      (numbers->cellref (list x y))))
+  
+  ; given two corner cells (as symbols), return list of symbols
+  ; for all contained cells
+  (define (get-range-cells c1 c2)
+    (let*-values
+        ([(a1 n1) (get-cell-components c1)]
+         [(a2 n2) (get-cell-components c2)]
+         [(alow ahigh) 
+          (if (string<? a1 a2) 
+              (values a1 a2)
+              (values a2 a1))]
+         [(nlow nhigh)
+          (if (< n1 n2) 
+              (values n1 n2)
+              (values n2 n1))]
+         [(numalow numahigh)
+          (values (cell-alpha->number alow)
+                  (cell-alpha->number ahigh))])
+      (let oloop ([curr-a numalow]
+                  [oresult null])
+        (if (> curr-a numahigh)
+            (map numbers->cellref oresult)
+            (let iloop ([curr-n nlow]
+                        [iresult null])
+              (if (> curr-n nhigh)
+                  (oloop (add1 curr-a)
+                         (append iresult oresult))
+                  (iloop (add1 curr-n)
+                         (cons (list curr-a curr-n) iresult)))))))))
+
diff --git a/collects/xelda/units.xls b/collects/xelda/units.xls
new file mode 100644
index 0000000000..9c2ed0a202
Binary files /dev/null and b/collects/xelda/units.xls differ
diff --git a/collects/xelda/xelda.ss b/collects/xelda/xelda.ss
new file mode 100644
index 0000000000..1b43d04cf2
--- /dev/null
+++ b/collects/xelda/xelda.ss
@@ -0,0 +1,423 @@
+(module xelda mzscheme
+  (require (lib "class.ss"))
+  (require (lib "list.ss"))
+  (require (lib "mred.ss" "mred"))
+  
+  (require "private/xelda-com.ss")
+  (require "private/xelda-checker.ss")
+  (require "private/parser.ss")
+  (require "private/xl-util.ss")
+  (require "private/formula.ss")
+  
+  (define-struct dependent (count orig-color) (make-inspector))
+  
+  (define xelda-frame%
+    (class frame%
+      (field
+       [bad-format-cells empty]
+       [bad-format-cells-colors #f]
+       [colored-dependents #f]
+       [error-cells #f]
+       [file-checked #f]
+       [filename #f]
+       [file-opened #f]
+       [parser (make-parser empty)]
+       [status-text-editor #f]
+       [range-text-editor #f]
+       [status-panel #f]
+       [status-text #f]
+       [status-message #f]
+       [assign-panel #f]
+       [assign-button #f]
+       [range-text #f]
+       [units-text #f]
+       [buttons-panel #f]
+       [load-button #f]
+       [quit-button #f]
+       [close-button #f]
+       [clear-button #f]
+       [check-button #f])
+      (public*
+       [error-cell? (lambda (cell) (and (hash-table? error-cells)
+                                        (in-hash? error-cells cell)))]
+       [get-error-cell-dependencies (lambda (cell) (second (hash-table-get error-cells cell)))]
+       [get-error-cell-state (lambda (cell) (first (hash-table-get error-cells cell)))]
+       [set-error-cell-state 
+        (lambda (cell state)
+          (hash-table-put! error-cells cell 
+                           (list state (second (hash-table-get error-cells cell)))))] 
+       [set-cell-selections (lambda (str) (send range-text-editor insert str))]
+       [erase-cell-selections (lambda () (send range-text-editor erase))]
+       [file-opened? (lambda () file-opened)]
+       [set-status (lambda (str)
+                     (send status-text-editor erase)
+                     (send status-text-editor insert str))]
+       [update-status (lambda (str) (send status-text-editor insert str))]
+       [next-update-status (lambda (str) (update-status (format "done~n~a.... " str)))]
+       [set-bad-format-cells (lambda (bad-cells) (set! bad-format-cells bad-cells))]
+       [set-computation-errors 
+        (lambda (errors)
+          (update-status (format "+++ERROR REPORTING+++~n"))
+          (set! error-cells (make-hash-table))
+          (for-each
+           (lambda (cell-unit-str-dependencies)
+             (let ([cell (first cell-unit-str-dependencies)]
+                   [unit (second cell-unit-str-dependencies)]
+                   [str (third cell-unit-str-dependencies)]
+                   [dependencies (fourth cell-unit-str-dependencies)])
+               (cond [(equal? 'error/propagated (first (first unit)))
+                      (set-cell-color! cell (rgb 209 35 238))
+                      (update-status
+                       (format "Cell ~a error propagation from cell~a~n"
+                               cell
+                               (second (first unit))))]
+                     [else
+                      (set-cell-color! cell (rgb 255 255 51))
+                      (update-status (format "Cell ~a error in computed units!~n" cell))])
+               (append-cell-comment! cell str)
+               (hash-table-put! error-cells cell (list 'on dependencies))))
+           errors))]
+       [set-mismatch-errors 
+        (lambda (errors)
+          (for-each 
+           (lambda (cell-actual-str-dependencies)         
+             (let ([cell (first cell-actual-str-dependencies)]
+                   [actual (second cell-actual-str-dependencies)]
+                   [str (third cell-actual-str-dependencies)]
+                   [dependencies (fourth cell-actual-str-dependencies)])
+               (set-cell-color! cell (rgb 255 153 51))
+               (append-cell-comment! cell str)
+               (hash-table-put! error-cells cell (list 'on dependencies))
+               (update-status 
+                (format "Cell ~a mismatch between annotated and computed units!~n"
+                        cell))))
+           errors))]
+       [close-frame!
+        (lambda()
+          (set! file-opened #f)
+          (set-status (format "Load Excel file~n"))
+          (send load-button enable #t)
+          (send close-button enable #f)
+          (send check-button enable #f)
+          (send clear-button enable #f)
+          (send assign-button enable #f)
+          (send range-text enable #f)
+          (send units-text enable #f)
+          (close-xl-workbook))]
+       [color-dependents 
+        (lambda (l action)
+          (when (not (empty? l))
+            (set-cell-color! (first l) (get-dependent-color (first l) action))
+            (color-dependents (rest l) action)))]
+       [unmark-errors
+        (lambda ()
+          (when (hash-table? error-cells)
+            (let ([orig-col (get-cell-color 'a1)])
+              (hash-table-for-each 
+               error-cells
+               (lambda (k v)
+                 (let ([state (first v)]
+                       [dependencies (second v)])
+                   (when (eq? state 'off)
+                     (color-dependents dependencies 'off)
+                     (clear-cell-precedents k))
+                   (let ([orig (original-comment (get-cell-comment k))])
+                     (cond 
+                       ((and (>= (string-length orig) 2)
+                             (string=? "()" (substring orig 0 2)))
+                        (delete-cell-comment! k))
+                       (else (set-cell-comment! k orig))))
+                   (set-cell-color! k orig-col))))
+              (set! error-cells #f)
+              (set! colored-dependents #f))))]
+       [reset-frame!
+        (lambda()
+          (for-each (lambda (panel)
+                      (when panel (send panel show #f)))
+                    (list status-panel buttons-panel))
+          (set! buttons-panel
+                (instantiate horizontal-panel% ()
+                  (parent this)
+                  (stretchable-height #f)
+                  (vert-margin 2)
+                  (alignment '(center center))))
+          (set! status-panel
+                (instantiate vertical-panel% ()
+                  (parent this)
+                  (border 5)
+                  (horiz-margin 5)
+                  (vert-margin 10)
+                  (stretchable-height #t)
+                  (style '(border))))
+          (set! assign-panel
+                (instantiate vertical-panel% ()
+                  (parent this)
+                  (stretchable-height #f)
+                  (style '(border))
+                  (border 5)
+                  (spacing 3)
+                  (horiz-margin 5)
+                  (vert-margin 5)
+                  (alignment '(center center))))
+          (set! status-message
+                (instantiate message% ()
+                  (label "XeLda Status:")
+                  (parent status-panel)))
+          (set! status-text
+                (instantiate text-field% ()
+                  (label #f)
+                  (init-value (format "Ready to load Excel file~n"))
+                  (parent status-panel)
+                  (style (list 'multiple))
+                  (stretchable-height #t)
+                  (enabled #t)
+                  (callback (lambda (txt-fld cntrl-evnt) ()))))
+          (set! status-text-editor (send status-text get-editor))
+          (set! range-text
+                (instantiate text-field% ()
+                  (label "Cell(s) Range(s):")
+                  (parent assign-panel)
+                  (enabled #f)
+                  (callback (lambda (txg-fld cntrl-evnt) ()))))
+          (set! range-text-editor (send range-text get-editor))
+          (set! units-text
+                (instantiate text-field% ()
+                  (label "      Cell(s) Units:")
+                  (parent assign-panel)
+                  (enabled #f)
+                  (callback (lambda (txt-fld cntrl-evnt) ()))))
+          (set! assign-button
+                (instantiate button% ()
+                  (label "Assign Units")
+                  (parent assign-panel)
+                  (enabled #f)
+                  (callback 
+                   (lambda (b env)
+                     (let* ([range-editor (send range-text get-editor)]
+                            [units-editor (send units-text get-editor)]
+                            [range-txt (send range-editor get-text)]
+                            [units-txt (send units-editor get-text)]
+                            [unit-list (get-ranges-from-txt range-txt parser)]
+                            [unit (get-units-from-txt units-txt)])
+                       (cond
+                         ((empty? unit)
+                          (message-box "Invalid Input"
+                                       "Improper unit format"
+                                       this
+                                       '(ok)))
+                         ((empty? unit-list)
+                          (message-box "Invalid Input"
+                                       "Improper range format"
+                                       this
+                                       '(ok)))
+                         (else
+                          (send range-editor erase)
+                          (send units-editor erase)
+                          (for-each (lambda (us)
+                                      (for-each (lambda (c) 
+                                                  (set-cell-comment! c units-txt))
+                                                us))
+                                    unit-list))))))))
+          (set! load-button
+                (instantiate button% ()
+                  (label "Load File")
+                  (parent buttons-panel)
+                  (callback (lambda (b ev)
+                              (let ([file-name (get-filename)])
+                                (when file-name
+                                  (set! file-checked #f)
+                                  (set! file-opened #t)
+                                  (set! filename file-name)
+                                  (update-status (format "Loaded file: ~a~n" filename))
+                                  (open-frame!)))))))
+          (set! close-button
+                (instantiate button% ()
+                  (label "Close File")
+                  (parent buttons-panel)
+                  (enabled #f)
+                  (callback (lambda (b ev)
+                              (close-frame!)))))
+          (set! check-button
+                (instantiate button% ()
+                  (label "Analyze")
+                  (parent buttons-panel)
+                  (enabled #f)
+                  (callback (lambda (b ev)
+                              (send quit-button enable #f)
+                              (send close-button enable #f)
+                              (send clear-button enable #f)
+                              (send check-button enable #f)
+                              (send assign-button enable #f)
+                              (send units-text enable #f)
+                              (send range-text enable #f)
+                              (thread (lambda()
+                                        (time
+                                         (begin
+                                           (when file-checked (unmark-errors))
+                                           (unit-check-xl-file)
+                                           (set! file-checked #t)
+                                           (send clear-button enable #t)
+                                           (send check-button enable #t)
+                                           (send close-button enable #t)
+                                           (send assign-button enable #t)
+                                           (send units-text enable #t)
+                                           (send range-text enable #t)
+                                           (send quit-button enable #t)))))))))
+          (set! clear-button
+                (instantiate button% ()
+                  (label "Clear")
+                  (parent buttons-panel)
+                  (enabled #f)
+                  (callback (lambda (b ev)
+                              (unmark-errors)
+                              (clear-all-precedents)))))
+          (set! quit-button
+                (instantiate button% ()
+                  (label "Quit Xelda")
+                  (parent buttons-panel)
+                  (callback (lambda (b ev)
+                              (when file-opened (close-xl-workbook))
+                              (send this show #f))))))])
+      (private*
+       [unit-check-xl-file
+        (lambda ()
+          (when (not (empty? bad-format-cells))
+            (clear-bad-format-cells))
+          (cond [(empty? bad-format-cells) 
+                 (unit-check this)
+                 (set! colored-dependents (make-hash-table))
+                 (update-status (format "+++XeLda DONE!+++~n"))]
+                [else (mark-bad-format-cells)]))]
+       [clear-bad-format-cells
+        (lambda ()
+          (for-each
+           (lambda (bad-cell-with-unit)
+             (let* ([bad-cell (first bad-cell-with-unit)]
+                    [bad-unit (second bad-cell-with-unit)]
+                    [orig-col (hash-table-get bad-format-cells-colors bad-cell)])
+               (set-cell-color! bad-cell orig-col)))
+           bad-format-cells)
+          (set! bad-format-cells-colors #f)
+          (set! bad-format-cells empty))]
+       [mark-bad-format-cells
+        (lambda ()
+          (when (not (empty? bad-format-cells))
+            (set! bad-format-cells-colors (make-hash-table))
+            (update-status 
+             (format "+++PREPROCESSING ERROR++~nImproper unit format for the following cells:~n"))
+            (for-each 
+             (lambda (bad-cell-with-unit)
+               (let* ([bad-cell (first bad-cell-with-unit)]
+                      [bad-unit (second bad-cell-with-unit)]
+                      [orig-col (get-cell-color bad-cell)])
+                 (update-status (format "cell: ~a - Improper unit format~n" bad-cell))
+                 (hash-table-put! bad-format-cells-colors bad-cell orig-col)
+                 (set-cell-color! bad-cell (rgb 120 170 120))))
+             bad-format-cells)))]
+       [clear-all-precedents
+        (lambda ()
+          (when (hash-table? error-cells)
+            (hash-table-for-each
+             error-cells
+             (lambda (cell v)
+               (let ([state (first v)]
+                     [dependencies (second v)])
+                 (when (eq? state 'off)
+                   (hash-table-put! error-cells cell (list 'on dependencies))
+                   (color-dependents dependencies 'off)
+                   (clear-cell-precedents cell)))))))]
+       [get-dependent-color 
+        (lambda (loc action)
+          (if (eq? action 'on)
+              (begin
+                (if (in-hash? colored-dependents loc)
+                    (let ([dep (hash-table-get colored-dependents loc)])
+                      (hash-table-put! colored-dependents loc
+                                       (make-dependent (+ (dependent-count dep) 1)
+                                                       (dependent-orig-color dep))))
+                    (hash-table-put! colored-dependents loc
+                                     (make-dependent 
+                                      0
+                                      (get-cell-color loc))))
+                (rgb 250 0 0))
+              (let ([dep (hash-table-get colored-dependents loc)])
+                (if (= 0 (dependent-count dep))
+                    (begin
+                      (hash-table-remove! colored-dependents loc)
+                      (dependent-orig-color dep))
+                    (begin
+                      (hash-table-put! colored-dependents loc
+                                       (make-dependent (sub1 (dependent-count dep))
+                                                       (dependent-orig-color dep)))
+                      (rgb 250 0 0))))))]  
+       [open-frame!
+        (lambda()
+          (send load-button enable #f)
+          (send close-button enable #t)
+          (send check-button enable #t)
+          (send assign-button enable #t)
+          (send range-text enable #t)
+          (send units-text enable #t)
+          (load-xl-file filename))])
+      (super-instantiate())
+      (reset-frame!)))
+  
+  (define *gui*
+    (instantiate xelda-frame% ()
+      (label "XeLda")
+      (width 400)
+      (height 550)))
+  
+  (send *gui* center)
+  (send *gui* show #t)
+  (set-gui! *gui*)
+  
+  (define (get-filename)
+    (get-file ".xls files"
+              *gui*
+              (collection-path "xelda")
+              #f
+              "xls"
+              '()
+              '(("Excel Files" "*.xls"))))
+  
+  (define (rgb r g b) 
+    (+ (* 65536 b) (* 256 g) r))
+  
+  (define (original-comment comment)
+    (letrec ([loop (lambda (str i max)
+                     (cond [(= i max) str]
+                           [(equal? #\; (string-ref str i)) (substring str 0 (sub1 i))]
+                           [else (loop str (+ i 1) max)]))])
+      (loop comment 0 (string-length comment))))
+  
+  (define (append-cell-comment! cellref scheme-comment)
+    (let ([orig-comment (get-cell-comment cellref)])
+      (cond [(string=? "" orig-comment)
+             (set-cell-comment! cellref (format "()~n;; ~a" scheme-comment))]
+            [else
+             (set-cell-comment! cellref (format "~a~n;; ~a" orig-comment scheme-comment))])))
+  
+  (define (get-ranges-from-txt str parser)
+    (let* ([s (list->string (filter (lambda (c) (not (char-whitespace? c)))
+                                    (string->list str)))]
+           [ranges-txt (split-string s #\,)]
+           [ranges (map (lambda (r) (split-string r #\:)) ranges-txt)]
+           [valid-ranges (filter (lambda (r) (not (empty? r)))
+                                 (map (lambda (r)
+                                        (filter (lambda (c)
+                                                  (cell-ref? (call-parser parser c)))
+                                                r))
+                                      ranges))])
+      (map (lambda (r)
+             (cond ((= 2 (length r)) (get-range-cells (first r) (second r)))
+                   (else r)))
+           (map (lambda (r)
+                  (map (lambda (c) (string->symbol (to-lower c))) r))
+                valid-ranges))))
+  
+  (define (get-units-from-txt str)
+    (with-handlers ([void (lambda _ '())])
+      (parse-unit str)))
+  )
+
diff --git a/collects/xml/XML.jpg b/collects/xml/XML.jpg
new file mode 100644
index 0000000000..2c21ca52cc
Binary files /dev/null and b/collects/xml/XML.jpg differ
diff --git a/collects/xml/doc.txt b/collects/xml/doc.txt
new file mode 100644
index 0000000000..c3de195789
--- /dev/null
+++ b/collects/xml/doc.txt
@@ -0,0 +1,356 @@
+_XML_ Library
+=============
+
+Files: xml.ss xmlr.ss xmls.ss
+Signature: xml^
+
+Basic XML Data Types
+====================
+
+Document:
+       This structure represents an XML document.  The only useful part is
+       the document-element, which contains all the content.  The rest of
+       of the structure contains DTD information, which isn't supported,
+       and processing-instructions.
+
+Element:
+       Each pair of start/end tags and everything in between is an element.
+       It has the following pieces:
+              a name
+              attributes
+              contents including sub-elements
+Xexpr:
+       S-expression representations of XML data.
+
+The end of this document has more details.
+
+Exceptions
+==========
+
+> (define-struct (exn:invalid-xexpr exn) (code))
+       Raised by validate-xexpr when passed an invalid Xexpr. Code contains an
+       invalid part of an Xexpr.
+
+Functions
+=========
+
+> read-xml : [Input-port] -> Document
+       reads in an XML document from the given or current input port
+       XML documents contain exactly one element.  It throws an xml-read:error
+       if there isn't any element or if there are more than one element.
+       
+       Malformed xml is reported with source locations in
+       the form `l.c/o', where l, c, and o are the line number,
+       column number, and next port position, respectively as
+       returned by port-next-location.
+
+       Any non-characters other than eof read from the input-port will
+       appear in the document content.  Such special values may only appear
+       where XML content may.  See make-custom-input-port for information
+       about creating ports that return non-character values.
+       
+> read-xml/element : [Input-port] -> Element
+       reads an XML element from the port.  The next non-whitespace character
+       read must start an XML element.  The input-port may contain other data
+       after the element.
+
+> syntax:read-xml : [Input-port] -> Syntax
+       reads in an XML document and produces a syntax object version of
+       an xexpression.
+
+> syntax:read-xml/element : [Input-port] -> Syntax
+       is just like read-xml/element except it produces a syntax version
+       of an xexpression
+       
+> write-xml : Document [Output-port] -> Void
+       writes a document to the given or current output port, currently
+       ignoring everything except the document's root element.
+
+> write-xml/content : Content [Output-port] -> Void
+       writes a document's contents to the given or current output port
+
+> display-xml : Document [Output-port] -> Void
+       just like write-xml, but newlines and indentation make the output more
+       readable, though less technically correct when white space is
+       significant.
+
+> display-xml/content : Content [Output-port] -> Void
+       just like write-xml/content, but with indentation and newlines
+
+> xml->xexpr : Content -> Xexpr
+       converts the interesting part of an XML document into an Xexpression
+
+> xexpr->xml : Xexpr -> Content
+       converts an Xexpression into the interesting part of an XML document
+
+> xexpr->string : Xexpression -> String
+       converts an Xexpression into a string representation
+       
+> eliminate-whitespace : (listof Symbol) (Bool -> Bool) -> Element -> Element
+       Some elements should not contain any text, only other tags, except they
+       often contain whitespace for formating purposes.  Given a list of tag
+       names and the identity function, eliminate-whitespace produces a
+       function that filters out pcdata consisting solely of whitespace from
+       those elements and raises an error if any non-whitespace text appears.
+       Passing in the function called "not" instead of the identity function
+       filters all elements which are not named in the list.  Using void
+       filters all elements regardless of the list.
+
+> xexpr? : any -> Boolean
+       Is the given thing an Xexpr?
+
+> validate-xexpr : any -> #t
+       If the given thing is an Xexpr, produce true. Otherwise, raise
+       _exn:invalid-xexpr_, with the message set to "Expected something, given
+       something-else", where "something" is what it expected and
+       "something-else" set to what it was really given; and the code set to
+       the part of the non-Xexpr that caused the exception.
+
+Parameters
+==========
+
+> empty-tag-shorthand : 'always | 'never | (listof Symbol)
+       Default: 'always
+       This determines if the output functions should use the <empty/>
+       tag notation instead of writing <empty></empty>.  If the
+       argument is 'always, the abbreviated notation is always used,
+       and if the argument is 'never, the open/close pair is always
+       generated.  If a list of symbols is provided, tags with names
+       in this list will be abbreviated.  The first form is the
+       preferred XML notation.  However, most browsers designed for
+       HTML will only properly render XHTML if the document uses a
+       mixture of the two formats.  _html-empty-tags_ contains the W3
+       consortium's recommended list of XHTML tags that should use the
+       shorthand.
+
+> collapse-whitespace : Bool
+       Default: #f
+       All consecutive whitespace is replaced by a single space.
+       CDATA sections are not affected.
+
+> trim-whitespace : Bool
+       This parameter no longer exists.  Consider using collapse-whitespace
+       and eliminate-whitespace instead.
+
+> read-comments : Bool
+       Default: #f
+       Comments, by definition, should be ignored by programs.  However,
+       interoperating with ad hoc extentions to other languages sometimes
+       requires processing comments anyway.
+
+> xexpr-drop-empty-attributes : Bool
+       Default: #f
+       It's easier to write functions processing Xexpressions, if they always
+       have a list of attributes.  On the other hand, it's less cumbersome to
+       write Xexpresssions by hand without empty lists of attributes
+       everywhere.  Normally xml->xexpr leaves in empty attribute lists.
+       Setting this parameter to #t drops them, so further editing the
+       Xexpression by hand is less annoying.
+
+Examples
+========
+
+Reading an Xexpression:
+       (xml->xexpr (document-element (read-xml input-port)))
+
+Writing an Xexpression:
+       (empty-tag-shorthand html-empty-tags)
+       (write-xml/content (xexpr->xml `(html (head (title ,banner))
+					     (body ((bgcolor "white"))
+						   ,text)))
+			  output-port)
+
+What this Library Doesn't Provide
+=================================
+
+       Document Type Declaration (DTD) processing
+       Validation
+       Expanding user-defined entites
+       Reading user-defined entites in attributes
+       Unicode support
+
+XML Datatype Details
+====================
+
+Note: Users of the XML collection don't need to know most of these definitions.
+
+Note: Xexpr is the only important one to understand.  Even then,
+      Processing-instructions may be ignored.
+
+> Xexpr = String
+        |  (cons Symbol (cons (listof (list Symbol String)) (listof Xexpr)))
+        |  (cons Symbol (listof Xexpr)) ;; an element with no attributes
+        |  Symbol ;; symbolic entities such as &nbsp;
+        |  Number ;; numeric entities like &#20;
+        |  Misc
+
+> Document = (make-document Prolog Element (listof Processing-instruction))
+  (define-struct document (prolog element misc))
+
+> Prolog = (make-prolog (listof Misc) Document-type [Misc ...])
+  (define-struct prolog (misc dtd misc2))
+  The last field is a (listof Misc), but the maker accepts optional
+  arguments instead for backwards compatibility.
+
+> Document-type = #f | (make-document-type Symbol External-dtd #f)
+  (define-struct document-type (name external inlined))
+
+> External-dtd = (make-external-dtd/public str str)
+               | (make-external-dtd/system str)
+               | #f
+  (define-struct external-dtd (system))
+  (define-struct (external-dtd/public external-dtd) (public))
+  (define-struct (external-dtd/system external-dtd) ())
+
+> Element = (make-element Location Location
+			    Symbol
+			    (listof Attribute)
+			    (listof Content))
+  (define-struct (element struct:source) (name attributes content))
+
+> Attribute = (make-attribute Location Location Symbol String)
+  (define-struct (attribute struct:source) (name value))
+
+> Content = Pcdata
+          |  Element
+          |  Entity
+          |  Misc
+
+  Misc = Comment
+       |  Processing-instruction
+
+> Pcdata = (make-pcdata Location Location String)
+  (define-struct (pcdata struct:source) (string))
+
+> Entity = (make-entity (U Nat Symbol))
+  (define-struct entity (text))
+
+> Processing-instruction = (make-pi Location Location String (list String))
+  (define-struct (pi struct:source) (target-name instruction))
+
+> Comment = (make-comment String)
+  (define-struct comment (text))
+
+  Source = (make-source Location Location)
+  (define-struct source (start stop))
+
+  Location = (make-location Nat Nat Nat) | Symbol
+  (define-struct location (line char offset))
+  Note: read-xml records location structures, while xexpr->xml inserts a
+        symbol.  Other functions that must fabricate XML Locations
+        without prior source location should use a sensible "comment" symbol.
+
+
+The PList Library
+=================
+
+Files: plist.ss
+
+The PList library provides the ability to read and write xml documents which 
+conform to the "plist" DTD, used to store 'dictionaries' of string - value
+associations.  This format is typically used by Mac OS X --- the operating 
+system and its applications --- to store all kinds of data.
+
+To Load
+=======
+
+(require (lib "plist.ss" "xml"))
+
+Functions
+=========
+
+> read-plist : Port -> PLDict
+       reads a plist from a port, and produces a 'dict' x-expression  
+
+> write-plist : PLDict Port -> Void
+       writes a plist to the given port.  May raise the exn:application:type
+       exception if the plist is badly formed.
+
+Datatypes
+=========
+
+NB: all of these are subtypes of x-expression:
+
+> PLDict = (list 'dict Assoc-pair ...)
+
+> PLAssoc-pair = (list 'assoc-pair String PLValue)
+
+> PLValue = String
+	  
+          | (list 'true)
+          | (list 'false)
+          | (list 'integer Integer)
+          | (list 'real Real)
+          | PLDict
+          | PLArray
+
+> PLArray = (list 'array PLValue ...)
+
+In fact, the PList DTD also defines Data and Date types, but we're ignoring
+these for the moment.
+
+Examples
+========
+
+Here's a sample PLDict:
+
+(define my-dict
+     `(dict (assoc-pair "first-key"
+			"just a string
+                         with some whitespace in it")
+	    (assoc-pair "second-key"
+			(false))
+	    (assoc-pair "third-key"
+			(dict ))
+	    (assoc-pair "fourth-key"
+			(dict (assoc-pair "inner-key"
+					  (real 3.432))))
+	    (assoc-pair "fifth-key"
+			(array (integer 14)
+			       "another string"
+			       (true)))
+	    (assoc-pair "sixth-key"
+			(array))))
+
+Let's write it to disk:
+
+   (call-with-output-file "/Users/clements/tmp.plist"
+     (lambda (port)
+       (write-plist my-dict port))
+     'truncate)
+
+Let's read it back from the disk:
+
+   (define new-dict
+     (call-with-input-file "/Users/clements/tmp.plist"
+       (lambda (port)
+	 (read-plist port))))
+
+Here's what that (hand-formatted) text file looks like:
+
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist SYSTEM "file://localhost/System/Library/DTDs/PropertyList.dtd">
+<plist version="0.9">
+  <dict>
+    <key>first-key</key>
+    <string>just a string
+                         with some whitespace in it</string>
+    <key>second-key</key>
+    <false />
+    <key>third-key</key>
+    <dict />
+    <key>fourth-key</key>
+    <dict>
+      <key>inner-key</key>
+      <real>3.432</real>
+    </dict>
+    <key>fifth-key</key>
+    <array>
+      <integer>14</integer>
+      <string>another string</string>
+      <true />
+    </array>
+    <key>sixth-key</key>
+    <array />
+  </dict>
+</plist>
diff --git a/collects/xml/info.ss b/collects/xml/info.ss
new file mode 100644
index 0000000000..1585179812
--- /dev/null
+++ b/collects/xml/info.ss
@@ -0,0 +1,14 @@
+
+(module info (lib "infotab.ss" "setup")
+  (define name "XML")
+  (define doc.txt "doc.txt")
+  ;; the XML tool has been moved to the stepper collection, so that 
+  ;; the stepper can create xml snips.  See collects/stepper/tool.ss for (a bit) more information
+  (define help-desk-message "Mz/Mr: (require (lib \"xml.ss\" \"xml\"))")
+  (define blurb
+    `("The XML collection provides functions for reading, writing, and manipulating XML documents."))
+  (define tools (list "text-box-tool.ss"))
+  (define tool-name (list "Text Box")))
+
+
+  
diff --git a/collects/xml/plist.ss b/collects/xml/plist.ss
new file mode 100644
index 0000000000..23e6495319
--- /dev/null
+++ b/collects/xml/plist.ss
@@ -0,0 +1,200 @@
+(module plist mzscheme
+
+  (require "xml.ss"
+           (lib "contract.ss"))
+
+  (provide read-plist)
+  (provide/contract [write-plist (xexpr? output-port? . -> . void?)])
+  
+   ; a dict is (list 'dict assoc-pair ...)
+   ; an assoc-pair is (list 'assoc-pair key value)
+   ; a key is a string
+   ; a value is either: 
+   ;  a string,
+   ;  a boolean, 
+   ;  an integer : (list 'integer number)
+   ;  a real : (list 'real number)
+   ;  a dict, or
+   ;  an array : (list 'array value ...)
+   ; (we're ignoring data & date)
+
+
+   ; raise-plist-exn : string mark-set xexpr symbol -> ???
+   (define (raise-plist-exn tag mark-set xexpr type)
+     (raise (make-exn:fail:contract (string-append "badly formed '" tag "'")
+				    mark-set)))
+
+   ; expand-dict : xexpr -> xexpr
+   (define (expand-dict x)
+     (cond [(and (eq? (car x) 'dict)
+		 (map expand-assoc-pair (cdr x)))
+	    =>
+	    (lambda (x) `(dict ,@(apply append x)))]
+	   [else
+	    (raise-plist-exn "dict" (current-continuation-marks) x 'plist:dict)]))
+
+   ; expand-assoc-pair : xexpr -> (list xexpr xexpr)
+   (define (expand-assoc-pair x)
+     (cond [(and (eq? (car x) 'assoc-pair)
+		 (string? (cadr x))
+		 (expand-value (caddr x)))
+	    =>
+	    (lambda (z) `((key ,(cadr x))
+			  ,z))]
+	   [else
+	    (raise-plist-exn "assoc-pair" (current-continuation-marks) x 'plist:assoc-pair)]))
+
+   ; expand-value : xexpr -> xexpr
+   (define (expand-value x)
+     (cond [(string? x)
+	    `(string ,x)]
+	   [(or (equal? x '(true))
+		(equal? x '(false)))
+	    x]
+	   [(and (eq? (car x) 'integer)
+		 (expand-integer x))
+	    => 
+	    (lambda (x) x)]
+	   [(and (eq? (car x) 'real)
+		 (expand-real x))
+	    =>
+	    (lambda (x) x)]
+	   [(and (eq? (car x) 'dict)
+		 (expand-dict x))
+	    =>
+	    (lambda (x) x)]
+	   [(and (eq? (car x) 'array)
+		 (expand-array x))
+	    =>
+	    (lambda (x) x)]
+	   [else
+	    (raise-plist-exn "value" (current-continuation-marks) x 'plist:value)]))
+
+   ; expand-real : xexpr -> xexpr
+   (define (expand-real x)
+     (cond [(and (eq? (car x) 'real)
+		 (real? (cadr x)))
+	    `(real ,(number->string (cadr x)))]
+	   [else
+	    (raise-plist-exn "real" (current-continuation-marks) x 'plist:real)]))
+
+   ; expand-integer : xexpr -> xexpr
+   (define (expand-integer x)
+     (cond [(and (eq? (car x) 'integer)
+		 (integer? (cadr x)))
+	    `(integer ,(number->string (cadr x)))]
+	   [else
+	    (raise-plist-exn "integer" (current-continuation-marks) x 'plist:integer)]))
+
+   ; expand-array : xexpr -> xexpr
+   (define (expand-array x)
+     (cond [(and (eq? (car x) 'array)
+		 (map expand-value (cdr x)))
+	    =>
+	    (lambda (x)
+	      `(array ,@x))]
+	   [else
+	    (raise-plist-exn "array" (current-continuation-marks) x 'plist:array)]))
+
+   ; dict? tst -> boolean
+   (define (dict? x)
+     (with-handlers [(exn:fail:contract? (lambda (exn) #f))]
+       (expand-dict x)
+       #t))
+
+   ; write-plist : xexpr port -> (void)
+   (define (write-plist xexpr port)
+     (let ([plist-xexpr `(plist ,(expand-dict xexpr))])
+       (write-xml 
+	(make-document (make-prolog (list (make-pi #f #f 'xml "version=\"1.0\" encoding=\"UTF-8\"")) 
+				    (make-document-type 'plist
+							(if (eq? (system-type) 'macosx)
+							    (make-external-dtd/system 
+							     "file://localhost/System/Library/DTDs/PropertyList.dtd")
+							    #f)
+							#f))
+		       (xexpr->xml `(plist ((version "0.9"))
+					   ,(expand-dict xexpr)))
+		       null)
+	port)))
+
+
+   ; collapse-dict : xexpr -> dict
+   (define (collapse-dict x)
+     `(dict ,@(collapse-assoc-pairs (cdr x))))
+
+   ; collapse-assoc-pairs : (listof xexpr) -> (listof assoc-pairs)
+   (define (collapse-assoc-pairs args)
+     (if (null? args)
+	 null
+	 (let ([key (car args)]
+	       [value (cadr args)]
+	       [rest (cddr args)])
+	   (cons `(assoc-pair ,(cadr key) ,(collapse-value value))
+		 (collapse-assoc-pairs rest)))))
+
+   ; collapse-value : xexpr -> value
+   (define (collapse-value value)
+     (case (car value)
+       [(string) (cadr value)]
+       [(true false) value]
+       [(integer real) (list (car value) (string->number (cadr value)))]
+       [(dict) (collapse-dict value)]
+       [(array) (collapse-array value)]))
+
+   ; collapse-array : xexpr -> array
+   (define (collapse-array xexpr)
+     `(array ,@(map collapse-value (cdr xexpr))))
+
+   (define tags-without-whitespace
+     '(plist dict array))
+
+   ; read-plist : port -> dict
+   (define (read-plist port)
+     (let* ([xml-doc (read-xml port)]
+	    [content (parameterize ([xexpr-drop-empty-attributes #t])
+		       (xml->xexpr
+			((eliminate-whitespace tags-without-whitespace (lambda (x) x))
+			 (document-element xml-doc))))])
+       (unless (eq? (car content) 'plist)
+	       (error 'read-plist "xml expression is not a plist: ~a" content))
+       (collapse-dict (caddr content))))
+
+   ;; TEST
+
+   '(define my-dict
+     `(dict (assoc-pair "first-key"
+			"just a string
+                         with some whitespace in it")
+	    (assoc-pair "second-key"
+			(false))
+	    (assoc-pair "third-key"
+			(dict ))
+	    (assoc-pair "fourth-key"
+			(dict (assoc-pair "inner-key"
+					  (real 3.432))))
+	    (assoc-pair "fifth-key"
+			(array (integer 14)
+			       "another string"
+			       (true)))
+	    (assoc-pair "sixth-key"
+			(array))))
+
+   '(call-with-output-file "/Users/clements/tmp.plist"
+     (lambda (port)
+       (write-plist my-dict port))
+     'truncate)
+
+   '(define new-dict
+     (call-with-input-file "/Users/clements/tmp.plist"
+       (lambda (port)
+	 (read-plist port))))
+
+   '(equal? new-dict my-dict)
+
+   ;; END OF TEST
+	 
+)		 
+		 
+	    
+		   
diff --git a/collects/xml/private/info.ss b/collects/xml/private/info.ss
new file mode 100644
index 0000000000..3d4aad0b5e
--- /dev/null
+++ b/collects/xml/private/info.ss
@@ -0,0 +1,6 @@
+
+(module info (lib "infotab.ss" "setup")
+  (define name "XML private"))
+
+
+  
diff --git a/collects/xml/private/reader.ss b/collects/xml/private/reader.ss
new file mode 100644
index 0000000000..b5fa170abc
--- /dev/null
+++ b/collects/xml/private/reader.ss
@@ -0,0 +1,468 @@
+(module reader mzscheme
+  (require (lib "unitsig.ss")
+           (lib "list.ss")
+           (lib "etc.ss"))
+  
+  (require "sig.ss")
+  
+  (provide reader@)
+  
+  (define reader@
+    (unit/sig reader^
+      (import xml-structs^)
+      
+      ;; Start-tag ::= (make-start-tag Location Location Symbol (listof Attribute))
+      (define-struct (start-tag source) (name attrs))
+      
+      ;; End-tag ::= (make-end-tag Location Location Symbol)
+      (define-struct (end-tag source) (name))
+      
+      ;; Token ::= Contents | Start-tag | End-tag | Eof
+      
+      (define read-comments (make-parameter #f))
+      (define collapse-whitespace (make-parameter #f))
+      
+      ;; read-xml : [Input-port] -> Document
+      (define read-xml
+        (opt-lambda ([in (current-input-port)])
+          (let*-values ([(in pos) (positionify in)]
+                        [(misc0 start) (read-misc in pos)])
+            (make-document (make-prolog misc0 #f)
+                           (read-xml-element-helper pos in start)
+                           (let ([loc-before (pos)])
+                             (let-values ([(misc1 end-of-file) (read-misc in pos)])
+                               (unless (eof-object? end-of-file)
+                                 (let ([loc-after (pos)])
+                                   (parse-error (list-immutable
+                                                 (make-srcloc
+                                                  (object-name in)
+                                                  #f
+                                                  #f
+                                                  (location-offset loc-before)
+                                                  (- (location-offset loc-after)
+                                                     (location-offset loc-before))))
+                                                "extra stuff at end of document ~a"
+                                                end-of-file)))
+                               misc1))))))
+      
+      ;; read-xml/element : [Input-port] -> Element
+      (define read-xml/element
+        (opt-lambda ([in (current-input-port)])
+          (let-values ([(in pos) (positionify in)])
+            (skip-space in)
+            (read-xml-element-helper pos in (lex in pos)))))
+      
+      ;; read-xml-element-helper : Nat Iport Token -> Element
+      (define (read-xml-element-helper pos in start)
+        (cond
+          [(start-tag? start) (read-element start in pos)]
+          [(element? start) start]
+          [else (parse-error (list-immutable
+                              (make-srcloc
+                               (object-name in)
+                               #f
+                               #f
+                               1
+                               (- (location-offset (pos)) 1)))
+                             "expected root element - received ~a"
+                             start)]))
+      
+      ;; read-misc : Input-port (-> Location) -> (listof Misc) Token
+      (define (read-misc in pos)
+        (let read-more ()
+          (let ([x (lex in pos)])
+            (cond
+              [(or (pi? x) (comment? x))
+               (let-values ([(lst next) (read-more)])
+                 (values (cons x lst) next))]
+              [(and (pcdata? x) (andmap char-whitespace? (string->list (pcdata-string x))))
+               (read-more)]
+              [else (values null x)]))))
+      
+      ;; read-element : Start-tag Input-port (-> Location) -> Element
+      (define (read-element start in pos)
+        (let ([name (start-tag-name start)]
+              [a (source-start start)]
+              [b (source-stop start)])
+          (let read-content ([k (lambda (body end-loc)
+                                  (make-element
+                                   a end-loc name (start-tag-attrs start)
+                                   body))])
+            (let ([x (lex in pos)])
+              (cond
+                [(eof-object? x)
+                 (parse-error (list-immutable
+                               (make-srcloc
+                                (object-name in)
+                                #f
+                                #f
+                                (location-offset (source-start start))
+                                (- (location-offset (source-stop start))
+                                   (location-offset (source-start start)))))
+                              "unclosed `~a' tag at [~a ~a]"
+                              name
+                              (format-source a)
+                              (format-source b))]
+                [(start-tag? x)
+                 (let ([next-el (read-element x in pos)])
+                   (read-content (lambda (body end-loc)
+                                   (k (cons next-el body)
+                                      end-loc))))]
+                [(end-tag? x)
+                 (let ([end-loc (source-stop x)])
+                   (unless (eq? name (end-tag-name x))
+                     (parse-error
+                      (list-immutable
+                       (make-srcloc (object-name in)
+                                    #f
+                                    #f
+                                    (location-offset a)
+                                    (- (location-offset b) (location-offset a)))
+                       (make-srcloc (object-name in)
+                                    #f
+                                    #f
+                                    (location-offset (source-start x))
+                                    (- (location-offset end-loc) (location-offset (source-start x)))))
+                      "start tag `~a' at [~a ~a] doesn't match end tag `~a' at [~a ~a]"
+                      name
+                      (format-source a)
+                      (format-source b)
+                      (end-tag-name x)
+                      (format-source (source-start x))
+                      (format-source end-loc)))
+                   (k null end-loc))]
+                [(entity? x) (read-content (lambda (body end-loc)
+                                             (k (cons (expand-entity x) body)
+                                                end-loc)))]
+                [(comment? x) (if (read-comments)
+                                  (read-content (lambda (body end-loc) (k (cons x body) end-loc)))
+                                  (read-content k))]
+                [else (read-content (lambda (body end-loc) (k (cons x body) end-loc)))])))))
+      
+      ;; expand-entity : Entity -> (U Entity Pcdata)
+      ;; more here - allow expansion of user defined entities
+      (define (expand-entity x)
+        (let ([expanded (default-entity-table (entity-text x))])
+          (if expanded
+              (make-pcdata (source-start x) (source-stop x) expanded)
+              x)))
+      
+      ;; default-entity-table : Symbol -> (U #f String)
+      (define (default-entity-table name)
+        (case name
+          [(amp) "&"]
+          [(lt) "<"]
+          [(gt) ">"]
+          [(quot) "\""]
+          [(apos) "'"]
+          [else #f]))
+      
+      ;; lex : Input-port (-> Location) -> (U Token special)
+      (define (lex in pos)
+        (let ([c (peek-char-or-special in)])
+          (cond
+            [(eof-object? c) c]
+            [(eq? c #\&) (lex-entity in pos)]
+            [(eq? c #\<) (lex-tag-cdata-pi-comment in pos)]
+            [(not (char? c)) (read-char-or-special in)]
+            [else (lex-pcdata in pos)])))
+      
+      ; lex-entity : Input-port (-> Location) -> Entity
+      ; pre: the first char is a #\&
+      (define (lex-entity in pos)
+        (let ([start (pos)])
+          (read-char in)
+          (let ([data (case (peek-char in)
+                        [(#\#)
+                         (read-char in)
+                         (let ([n (case (peek-char in)
+                                    [(#\x) (read-char in)
+                                     (string->number (read-until #\; in pos) 16)]
+                                    [else (string->number (read-until #\; in pos))])])
+                           (unless (number? n)
+                             (lex-error in pos "malformed numeric entity"))
+                           n)]
+                        [else
+                         (begin0
+                           (lex-name in pos)
+                           (unless (eq? (read-char in) #\;)
+                             (lex-error in pos "expected ; at the end of an entity")))])])
+            (make-entity start (pos) data))))
+      
+      ; lex-tag-cdata-pi-comment : Input-port (-> Location) -> Start-tag | Element | End-tag | Pcdata | Pi | Comment
+      ; pre: the first char is a #\<
+      (define (lex-tag-cdata-pi-comment in pos)
+        (let ([start (pos)])
+          (read-char in)
+          (case (non-eof peek-char-or-special in pos)
+            [(#\!)
+             (read-char in)
+             (case (non-eof peek-char in pos)
+               [(#\-) (read-char in)
+                (unless (eq? (read-char-or-special in) #\-)
+                  (lex-error in pos "expected second - after <!-"))
+                (let ([data (lex-comment-contents in pos)])
+                  (unless (eq? (read-char in) #\>)
+                    (lex-error in pos "expected > to end comment (\"--\" can't appear in comments)"))
+                  ;(make-comment start (pos) data)
+                  (make-comment data))]
+               [(#\[) (read-char in)
+                (unless (string=? (read-string 6 in) "CDATA[")
+                  (lex-error in pos "expected CDATA following <["))
+                (let ([data (lex-cdata-contents in pos)])
+                  (make-pcdata start (pos) data))]
+               [else (skip-dtd in pos)
+                     (skip-space in)
+                     (unless (eq? (peek-char-or-special in) #\<)
+                       (lex-error in pos "expected pi, comment, or element after doctype"))
+                     (lex-tag-cdata-pi-comment in pos)])]
+            [(#\?) (read-char in)
+             (let ([name (lex-name in pos)])
+               (skip-space in)
+               (let ([data (lex-pi-data in pos)])
+                 (make-pi start (pos) name data)))]
+            [(#\/) (read-char in)
+             (let ([name (lex-name in pos)])
+               (skip-space in)
+               (unless (eq? (read-char-or-special in) #\>)
+                 (lex-error in pos "expected > to close ~a's end tag" name))
+               (make-end-tag start (pos) name))]
+            [else ; includes 'special, but lex-name will fail in that case
+             (let ([name (lex-name in pos)]
+                   [attrs (lex-attributes in pos)])
+               (skip-space in)
+               (case (read-char-or-special in)
+                 [(#\/)
+                  (unless (eq? (read-char in) #\>)
+                    (lex-error in pos "expected > to close empty element ~a" name))
+                  (make-element start (pos) name attrs null)]
+                 [(#\>) (make-start-tag start (pos) name attrs)]
+                 [else (lex-error in pos "expected / or > to close tag `~a'" name)]))])))
+      
+      ;; lex-attributes : Input-port (-> Location) -> (listof Attribute)
+      (define (lex-attributes in pos)
+        (quicksort (let loop ()
+                     (skip-space in)
+                     (cond
+                       [(name-start? (peek-char-or-special in))
+                        (cons (lex-attribute in pos) (loop))]
+                       [else null]))
+                   (lambda (a b)
+                     (let ([na (attribute-name a)]
+                           [nb (attribute-name b)])
+                       (cond
+                         [(eq? na nb) (lex-error in pos "duplicated attribute name ~a" na)]
+                         [else (string<? (symbol->string na) (symbol->string nb))])))))
+      
+      ;; lex-attribute : Input-port (-> Location) -> Attribute
+      (define (lex-attribute in pos)
+        (let ([start (pos)]
+              [name (lex-name in pos)])
+          (skip-space in)
+          (unless (eq? (read-char in) #\=)
+            (lex-error in pos "expected = in attribute ~a" name))
+          (skip-space in)
+          ;; more here - handle entites and disallow "<"
+          (let* ([delimiter (read-char-or-special in)]
+                 [value (case delimiter
+                          [(#\' #\")
+                           (list->string
+                            (let read-more ()
+                              (let ([c (non-eof peek-char-or-special in pos)])
+                                (cond
+                                  [(eq? c 'special)
+                                   (lex-error in pos "attribute values cannot contain non-text values")]
+                                  [(eq? c delimiter) (read-char in) null]
+                                  [(eq? c #\&)
+                                   (let ([entity (expand-entity (lex-entity in pos))])
+                                     (if (pcdata? entity)
+                                         (append (string->list (pcdata-string entity)) (read-more))
+                                         ;; more here - do something with user defined entites
+                                         (read-more)))]
+                                  [else (read-char in) (cons c (read-more))]))))]
+                          [else (if (char? delimiter)
+                                    (lex-error in pos "attribute values must be in ''s or in \"\"s")
+                                    delimiter)])])
+            (make-attribute start (pos) name value))))
+      
+      ;; skip-space : Input-port -> Void
+      ;; deviation - should sometimes insist on at least one space
+      (define (skip-space in)
+        (let loop ()
+          (let ([c (peek-char-or-special in)])
+            (when (and (char? c)
+                       (char-whitespace? c))
+              (read-char in)
+              (loop)))))
+      
+      ;; lex-pcdata : Input-port (-> Location) -> Pcdata
+      ;; deviation - disallow ]]> "for compatability" with SGML, sec 2.4 XML spec 
+      (define (lex-pcdata in pos)
+        (let ([start (pos)]
+              [data (let loop ()
+                      (let ([next (peek-char-or-special in)])
+                        (cond
+                          [(or (eof-object? next)
+			       (not (char? next))
+			       (eq? next #\&)
+			       (eq? next #\<))
+                           null]
+                          [(and (char-whitespace? next) (collapse-whitespace))
+                           (skip-space in)
+                           (cons #\space (loop))]
+                          [else (cons (read-char in) (loop))])))])
+          (make-pcdata start
+                       (pos)
+                       (list->string data))))
+      
+      ;; lex-name : Input-port (-> Location) -> Symbol
+      (define (lex-name in pos)
+        (let ([c (non-eof read-char-or-special in pos)])
+          (unless (name-start? c)
+            (lex-error in pos "expected name, received ~s" c))
+          (string->symbol
+           (list->string
+            (cons c (let lex-rest ()
+                      (let ([c (non-eof peek-char-or-special in pos)])
+                        (cond
+                         [(eq? c 'special)
+                          (lex-error in pos "names cannot contain non-text values")]
+                         [(name-char? c)
+                          (cons (read-char in) (lex-rest))]
+                         [else null]))))))))
+      
+      ;; skip-dtd : Input-port (-> Location) -> Void
+      (define (skip-dtd in pos)
+        (let skip ()
+          (case (non-eof read-char in pos)
+            [(#\') (read-until #\' in pos) (skip)]
+            [(#\") (read-until #\" in pos) (skip)]
+            [(#\<)
+             (case (non-eof read-char in pos)
+               [(#\!) (case (non-eof read-char in pos)
+                        [(#\-) (read-char in) (lex-comment-contents in pos) (read-char in) (skip)]
+                        [else (skip) (skip)])]
+               [(#\?) (lex-pi-data in pos) (skip)]
+               [else (skip) (skip)])]
+            [(#\>) (void)]
+            [else (skip)])))
+      
+      ;; name-start? : Char -> Bool
+      (define (name-start? ch)
+        (and (char? ch)
+             (or (char-alphabetic? ch)
+                 (eq? ch #\_)
+                 (eq? ch #\:))))
+      
+      ;; name-char? : Char -> Bool
+      (define (name-char? ch)
+        (and (char? ch)
+             (or (name-start? ch)
+                 (char-numeric? ch)
+                 (eq? ch #\.)
+                 (eq? ch #\-))))
+      
+      ;; read-until : Char Input-port (-> Location) -> String
+      ;; discards the stop character, too
+      (define (read-until char in pos)
+        (list->string
+         (let read-more ()
+           (let ([c (non-eof read-char in pos)])
+             (cond
+               [(eq? c char) null]
+               [else (cons c (read-more))])))))
+      
+      ;; non-eof : (Input-port -> (U Char Eof)) Input-port (-> Location) -> Char
+      (define (non-eof f in pos)
+        (let ([c (f in)])
+          (cond
+            [(eof-object? c) (lex-error in pos "unexpected eof")]
+            [else c])))
+      
+      ;; gen-read-until-string : String -> Input-port (-> Location) -> String
+      ;; uses Knuth-Morris-Pratt from
+      ;; Introduction to Algorithms, Cormen, Leiserson, and Rivest, pages 869-876
+      ;; discards stop from input
+      (define (gen-read-until-string stop)
+        (let* ([len (string-length stop)]
+               [prefix (make-vector len 0)]
+               [fall-back
+                (lambda (k c)
+                  (let ([k (let loop ([k k])
+                             (cond
+                               [(and (> k 0) (not (eq? (string-ref stop k) c)))
+                                (loop (vector-ref prefix (sub1 k)))]
+                               [else k]))])
+                    (if (eq? (string-ref stop k) c)
+                        (add1 k)
+                        k)))])
+          (let init ([k 0] [q 1])
+            (when (< q len)
+              (let ([k (fall-back k (string-ref stop q))])
+                (vector-set! prefix q k)
+                (init k (add1 q)))))
+          ;; (vector-ref prefix x) = the longest suffix that matches a prefix of stop
+          (lambda (in pos)
+            (list->string
+             (let/ec out
+               (let loop ([matched 0] [out out])
+                 (let* ([c (non-eof read-char in pos)]
+                        [matched (fall-back matched c)])
+                   (cond
+                     [(= matched len) (out null)]
+                     [(zero? matched) (cons c (let/ec out (loop matched out)))]
+                     [else (cons c (loop matched out))]))))))))
+      
+      ;; "-->" makes more sense, but "--" follows the spec.
+      (define lex-comment-contents (gen-read-until-string "--"))
+      (define lex-pi-data (gen-read-until-string "?>"))
+      (define lex-cdata-contents (gen-read-until-string "]]>"))
+      
+      ;; positionify : Input-port -> Input-port (-> Location)
+      ; This function predates port-count-lines! and port-next-location.
+      ; Otherwise I would have used those directly at the call sites.
+      (define (positionify in)
+        (port-count-lines! in)
+        (values
+         in
+         (lambda ()
+           (let-values ([(line column offset) (port-next-location in)])
+             (make-location line column offset)))))
+      
+      ;; locs : (listof (list number number))
+      (define-struct (exn:xml exn:fail:read) ())
+      
+      ;; lex-error : Input-port String (-> Location) TST* -> alpha
+      ;; raises a lexer error, using exn:xml
+      (define (lex-error in pos str . rest)
+        (let* ([the-pos (pos)]
+               [offset (location-offset the-pos)])
+          (raise
+           (make-exn:xml
+            (string->immutable-string
+             (format "read-xml: lex-error: at position ~a: ~a" 
+                     (format-source the-pos)
+                     (apply format str rest)))
+            (current-continuation-marks)
+            (list-immutable (make-srcloc 
+                             (object-name in)
+                             #f
+                             #f
+                             offset
+                             1))))))
+      
+      ;; parse-error : (listof srcloc) (listof TST) *-> alpha
+      ;; raises a parsing error, using exn:xml
+      (define (parse-error src fmt . args)
+        (raise (make-exn:xml
+                (string->immutable-string
+                 (apply format (string-append "read-xml: parse-error: " fmt) args))
+                (current-continuation-marks)
+                src)))
+      
+      ;; format-source : Location -> string
+      ;; to format the source location for an error message
+      (define (format-source loc)
+        (if (location? loc)
+            (format "~a.~a/~a" (location-line loc) (location-char loc) (location-offset loc))
+            (format "~a" loc))))))
diff --git a/collects/xml/private/sig.ss b/collects/xml/private/sig.ss
new file mode 100644
index 0000000000..2d3a6ae938
--- /dev/null
+++ b/collects/xml/private/sig.ss
@@ -0,0 +1,58 @@
+
+(module sig mzscheme
+  (require (lib "unitsig.ss"))
+
+  (define-signature xml-structs^
+    ((struct location (line char offset))
+     (struct document (prolog element misc))
+     (struct comment (text))
+     (struct prolog (misc dtd misc2))
+     (struct document-type (name external inlined))
+     (struct external-dtd (system))
+     (struct external-dtd/public (public))
+     (struct external-dtd/system ())
+     (struct element (name attributes content))
+     (struct attribute (name value))
+     (struct pi (target-name instruction))
+     (struct source (start stop))
+     (struct pcdata (string))
+     (struct entity (text))
+     content?))
+
+  (define-signature writer^
+    (write-xml
+      display-xml
+      write-xml/content
+      display-xml/content
+      empty-tag-shorthand
+      html-empty-tags))
+
+  (define-signature reader^ 
+    (read-xml
+     read-xml/element
+     read-comments
+     collapse-whitespace
+     (struct exn:xml ())))
+
+  (define-signature xexpr^
+    (xml->xexpr
+      xexpr->xml
+      xexpr->string
+      xexpr-drop-empty-attributes
+      xexpr?
+      validate-xexpr
+      (struct exn:invalid-xexpr (code))
+      xexpr-attribute?
+      listof?))
+
+  (define-signature extra-xexpr^
+    ((open xexpr^) assoc-sort bcompose attribute->srep))
+
+  (define-signature space^ (eliminate-whitespace))
+
+  (provide xml-structs^
+	  writer^
+	  reader^
+	  xexpr^
+	  extra-xexpr^
+	  space^))
diff --git a/collects/xml/private/space.ss b/collects/xml/private/space.ss
new file mode 100644
index 0000000000..b31d10306c
--- /dev/null
+++ b/collects/xml/private/space.ss
@@ -0,0 +1,39 @@
+
+(module space mzscheme
+  (require (lib "unitsig.ss")
+	  (lib "list.ss"))
+
+  (require "sig.ss")
+
+  (provide space@)
+
+  (define space@
+    (unit/sig space^
+      (import xml-structs^)
+      
+      ;; eliminate-whitespace : (listof Symbol) (Bool -> Bool) -> Element -> Element
+      (define (eliminate-whitespace special eliminate-special?)
+	(letrec ([blank-it
+		  (lambda (el)
+		    (let ([name (element-name el)]
+			  [content (map (lambda (x)
+					  (if (element? x) (blank-it x) x))
+					(element-content el))])
+		      (make-element
+		       (source-start el)
+		       (source-stop el)
+		       name
+		       (element-attributes el)
+		       (cond
+			[(eliminate-special? (memq (element-name el) special))
+			 (filter (lambda (s)
+				   (not (and (pcdata? s)
+					     (or (all-blank (pcdata-string s))
+						 (error 'eliminate-blanks "Element <~a> is not allowed to contain text ~s" name (pcdata-string s))))))
+				 content)]
+			[else content]))))])
+	  blank-it))
+      
+      ;; all-blank : String -> Bool
+      (define (all-blank s) (andmap char-whitespace? (string->list s))))))
+
diff --git a/collects/xml/private/structures.ss b/collects/xml/private/structures.ss
new file mode 100644
index 0000000000..a4cee54a58
--- /dev/null
+++ b/collects/xml/private/structures.ss
@@ -0,0 +1,82 @@
+
+(module structures mzscheme
+  (require (lib "unitsig.ss"))
+
+  (require "sig.ss")
+
+  (provide xml-structs@)
+
+  (define xml-structs@
+    (unit/sig xml-structs^
+      (import)
+      
+      ; Location = (make-location Nat Nat Nat) | Symbol
+      (define-struct location (line char offset))
+
+      ; Source = (make-source Location Location)
+      (define-struct source (start stop))
+      
+      ; Document = (make-document Prolog Element (listof Misc))
+      (define-struct document (prolog element misc))
+      
+      ; Prolog = (make-prolog (listof Misc) Document-type [Misc ...])
+      ; The Misc items after the Document-type are optional arguments to maintain
+      ; backward compatability with older versions of the XML library.
+      ;(define-struct prolog (misc dtd misc2))
+
+      (define-values (struct:prolog real-make-prolog prolog? access-prolog set-prolog!)
+        (make-struct-type 'prolog #f 3 0))
+      
+      (define (make-prolog misc dtd . misc2)
+        (real-make-prolog misc dtd misc2))
+      
+      (define prolog-misc (make-struct-field-accessor access-prolog 0 'misc))
+      (define set-prolog-misc! (make-struct-field-mutator set-prolog! 0 'misc))
+      
+      (define prolog-dtd (make-struct-field-accessor access-prolog 1 'dtd))
+      (define set-prolog-dtd! (make-struct-field-mutator set-prolog! 1 'dtd))
+      
+      (define prolog-misc2 (make-struct-field-accessor access-prolog 2 'misc2))
+      (define set-prolog-misc2! (make-struct-field-mutator set-prolog! 2 'misc2))
+      
+      ; Document-type = (make-document-type sym External-dtd #f)
+      ;               | #f
+      (define-struct document-type (name external inlined))
+      
+      ; External-dtd = (make-external-dtd/public str str)
+      ;              | (make-external-dtd/system str)
+      ;              | #f
+      (define-struct external-dtd (system))
+      (define-struct (external-dtd/public external-dtd) (public))
+      (define-struct (external-dtd/system external-dtd) ())
+      
+      ; Element = (make-element Location Location Symbol (listof Attribute) (listof Content))
+      (define-struct (element source) (name attributes content))
+      
+      ; Attribute = (make-attribute Location Location Symbol String)
+      (define-struct (attribute source) (name value))
+      
+      ; Pcdata = (make-pcdata Location Location String)
+      (define-struct (pcdata source) (string))
+      
+      ; Content = Pcdata  
+      ;         |  Element
+      ;         |  Entity
+      ;         |  Misc
+      
+      ; Misc = Comment
+      ;      |  Processing-instruction
+      
+      ; Entity = (make-entity Location Location (U Nat Symbol))
+      (define-struct (entity source) (text))
+      
+      ; Processing-instruction = (make-pi Location Location String (list String))
+      ; also represents XMLDecl
+      (define-struct (pi source) (target-name instruction))
+      
+      ; Comment = (make-comment String)
+      (define-struct comment (text))
+      
+      ; content? : TST -> Bool
+      (define (content? x)
+	(or (pcdata? x) (element? x) (entity? x) (comment? x) (pi? x))))))
diff --git a/collects/xml/private/syntax.ss b/collects/xml/private/syntax.ss
new file mode 100644
index 0000000000..0e950827ab
--- /dev/null
+++ b/collects/xml/private/syntax.ss
@@ -0,0 +1,205 @@
+(module syntax mzscheme
+  (provide syntax-structs@)
+  (require (lib "unitsig.ss")
+           "sig.ss")
+  
+  ; to make error-raising functions named like structure mutators
+  (define-syntax (struct! stx)
+    (syntax-case stx ()
+      [(struct-src name (field ...))
+       (with-syntax ([struct:name (datum->syntax-object
+                                   (syntax name)
+                                   (string->symbol (string-append "struct:" (symbol->string (syntax-object->datum (syntax name))))))]
+                     [(setter-name ...)
+                      (let ([struct-name
+                             (symbol->string (syntax-object->datum (syntax name)))])
+                        (map (lambda (field-name)
+                               (datum->syntax-object
+                                field-name
+                                (string->symbol
+                                 (string-append
+                                  "set-"
+                                  struct-name
+                                  "-"
+                                  (symbol->string (syntax-object->datum field-name))
+                                  "!"))))
+                             (syntax->list (syntax (field ...)))))])
+         (syntax
+          (begin
+            (define struct:name void)
+            (define (setter-name s v)
+              (error (quote setter-name) "cannot mutate XML syntax"))
+            ...)))]))
+  
+  (define syntax-structs@
+    (unit/sig xml-structs^
+      (import)
+      
+      ; The locations from the two sets of structures shouldn't mingle, so I'm
+      ; re-defining the location structure.  Maybe this is not a good idea, but I
+      ; think it's okay.
+      (define-struct location (line char offset))
+      (define-struct source (start stop))
+      
+      ; make-document : prolog element ? -> document
+      (define (make-document p e ?) e)
+      
+      ; make-prolog : ? #f -> prolog
+      (define (make-prolog ? ??) #f)
+      
+      ; make-element : src src sym (listof attribute) (listof content) -> element
+      (define (make-element from to name attrs content)
+        (wrap (list* name attrs content) from to))
+      
+      ; make-pcdata : src src str -> pcdata
+      (define (make-pcdata from to x)
+        (wrap x from to))
+      
+      ; make-entity : src src (U sym num) -> entity
+      (define (make-entity from to entity)
+        (wrap entity from to))
+      
+      ; make-comment : str -> comment
+      ; There is no syntax object representation for comments
+      (define (make-comment x) #f)
+      
+      ; make-pi : src src sym str -> pi
+      ; There's not really a syntax object representation for pi's either
+      (define (make-pi from to name val) #f)
+      
+      ; make-attribute : src src sym str -> attribute
+      (define (make-attribute from to name val)
+        (wrap (list name val) from to))
+      
+      (define (make-document-type . x) #f)
+      (define (make-external-dtd . x) #f)
+      (define (make-external-dtd/public . x) #f)
+      (define (make-external-dtd/system . x) #f)
+      
+      ; wrap : tst src src -> syntax
+      (define (wrap x from to)
+        (datum->syntax-object #f x (position from to)))
+      
+      ; position : src src -> (list #f nat nat nat nat)
+      (define (position from to)
+        (let ([start-offset (location-offset from)])
+          (list #f (location-line from) (location-char from) start-offset
+                (- (location-offset to) start-offset))))
+      
+      ; : syntax -> syntax
+      (define (attribute-name a) (car (syntax->list a)))
+      (define (attribute-value a) (cadr (syntax->list a)))
+      
+      ; : syntax -> syntax
+      (define (element-name e) (car (syntax->list e)))
+      (define (element-attributes e) (cadr (syntax->list e)))
+      (define (element-content e) (cddr (syntax->list e)))
+      
+      (define (entity-text e) (syntax-e e))
+      
+      (define (pcdata-string x) (syntax-e x))
+      
+      (define (comment-text c)
+        (error 'comment-text "expected a syntax representation of an XML comment, received ~a" c))
+      ; conflate documents with their root elements
+      (define (document-element d) d)
+      ; more here - spoof document pieces better?
+      (define (document-misc d) null)
+      (define (document-prolog d) null)
+      
+      (define (document-type-external dtd)
+        (error 'document-type-external "expected a dtd, given ~a" dtd))
+      
+      (define (document-type-inlined dtd)
+        (error 'document-type-inlined "expected a dtd, given ~a" dtd))
+      
+      (define (document-type-name dtd)
+        (error 'document-type-name "expected a dtd, given ~a" dtd))
+      
+      (define (external-dtd-system x)
+        (error 'external-dtd-system "expected an external dtd, given ~a" x))
+      
+      (define (external-dtd/public-public x)
+        (error 'external-dtd/public-public "expected an external dtd, given ~a" x))
+      
+      (define (pi-instruction x)
+        (error 'pi-instruction "expected a pi, given ~a" x))
+      
+      (define (pi-target-name x)
+        (error 'pi-target-name "expected a pi, given ~a" x))
+      
+      (define (prolog-dtd x)
+        (error 'prolog-dtd "expected a prolog, given ~a" x))
+      
+      (define (prolog-misc x)
+        (error 'prolog-misc "expected a prolog, given ~a" x))
+      
+      (define (prolog-misc2 x)
+        (error 'prolog-misc2 "expected a prolog, given ~a" x))
+      
+      ; : tst -> bool
+      (define (attribute? a)
+        (and (syntax? a)
+             (let ([x (syntax-object->datum a)])
+               (and (pair? x) (symbol? (car x))
+                    (pair? (cdr x)) (string? (cadr x))
+                    (null? (cddr x))))))
+      
+      
+      ; : tst -> bool
+      (define (comment? x) #f)
+      
+      ; : tst -> bool
+      (define (content? x)
+        (and (syntax? x)
+             (or (string? (syntax-object->datum x))
+                 (element? x))))
+      
+      ; : tst -> bool
+      (define (element? x)
+        (and (syntax? x)
+             (let ([e (syntax-e x)])
+               (and (pair? e) (symbol? (car e))
+                    (pair? (cdr e)) (list? (cadr e))
+                    (andmap attribute? (cadr e))
+                    (list? (cddr e))
+                    (andmap content? (cddr e))))))
+      
+      ; : tst -> bool
+      (define document? element?)
+      
+      ; : tst -> bool
+      (define (document-type? x) #f)
+      
+      ; : tst -> bool
+      (define (external-dtd/public? x) #f)
+      (define (external-dtd/system? x) #f)
+      (define (external-dtd? x) #f)
+      
+      (define (prolog? x) #f)
+      (define (pi? x) #f)
+      
+      ; : tst -> bool
+      (define (pcdata? x)
+        (and (syntax? x) (string (syntax-e x))))
+      
+      ; : tst -> bool
+      (define (entity? x)
+        (and (syntax? x) (let ([r (syntax-e x)]) (or (symbol? r) (number? r)))))
+      
+      ;(struct! location (line char offset))
+      (struct! document (prolog element misc))
+      (struct! comment (text))
+      (struct! prolog (misc dtd misc2))
+      (struct! document-type (name external inlined))
+      (struct! external-dtd (system))
+      (struct! external-dtd/public (public))
+      (struct! external-dtd/system ())
+      (struct! element (name attributes content))
+      (struct! attribute (name value))
+      (struct! pi (target-name instruction))
+      ;(struct! source (start stop))
+      (struct! pcdata (string))
+      (struct! entity (text))
+      
+      )))
diff --git a/collects/xml/private/writer.ss b/collects/xml/private/writer.ss
new file mode 100644
index 0000000000..a5b9c31546
--- /dev/null
+++ b/collects/xml/private/writer.ss
@@ -0,0 +1,163 @@
+
+(module writer mzscheme
+  (require (lib "unitsig.ss")
+           (lib "list.ss")
+	   (lib "string.ss")
+           (lib "etc.ss"))
+  
+  (require "sig.ss")
+  
+  (provide writer@)
+  
+  (define writer@
+    (unit/sig writer^
+      (import xml-structs^)
+      
+      ;; (empty-tag-shorthand) : (U 'always 'never (listof Symbol))
+      (define empty-tag-shorthand
+	(make-parameter 'always
+			(lambda (x)
+			  (if (or (eq? x 'always) (eq? x 'never) (and (list? x) (andmap symbol? x)))
+			      x
+			      (error 'empty-tag-shorthand "expected 'always, 'never, or a list of symbols: received ~a" x)))))
+      
+      (define html-empty-tags '(param meta link isindex input img hr frame col br basefont base area))
+      
+      ;; gen-write/display-xml/content : (Nat Output-port -> Void) -> Content [Output-Port]-> Void
+      (define (gen-write/display-xml/content dent)
+	(opt-lambda (c [out (current-output-port)]) (write-xml-content c 0 dent out)))
+      
+      ;; indent : Nat Output-port -> Void
+      (define (indent n out)
+	(newline out)
+	(let loop ([n n])
+	  (unless (zero? n)
+	    (display #\space out)
+	    (loop (sub1 n)))))
+      
+      ;; write-xml/content : Content [Output-port] -> Void
+      (define write-xml/content (gen-write/display-xml/content void))
+      
+      ;; display-xml/content : Content [Output-port] -> Void
+      (define display-xml/content (gen-write/display-xml/content indent))
+      
+      ;; gen-write/display-xml : (Content [Output-port] -> Void) -> Document [Output-port] -> Void
+      (define (gen-write/display-xml output-content)
+	(opt-lambda (doc [out (current-output-port)])
+          (let ([prolog (document-prolog doc)])
+            (display-outside-misc (prolog-misc prolog) out)
+            (display-dtd (prolog-dtd prolog) out)
+            (display-outside-misc (prolog-misc2 prolog) out))
+          (output-content (document-element doc) out)
+          (display-outside-misc (document-misc doc) out)))
+      
+      ; display-dtd : document-type oport -> void
+      (define (display-dtd dtd out)
+        (when dtd
+          (fprintf out "<!DOCTYPE ~a" (document-type-name dtd))
+          (let ([external (document-type-external dtd)])
+            (cond
+              [(external-dtd/public? external)
+               (fprintf out " PUBLIC \"~a\" \"~a\""
+                        (external-dtd/public-public external)
+                        (external-dtd-system external))]
+              [(external-dtd/system? external)
+               (fprintf out " SYSTEM \"~a\"" (external-dtd-system external))]
+              [(not external) (void)]))
+          (display ">" out)
+          (newline out)))
+      
+      ;; write-xml : Document [Output-port] -> Void
+      (define write-xml (gen-write/display-xml write-xml/content))
+      
+      ;; display-xml : Document [Output-port] -> Void
+      (define display-xml (gen-write/display-xml display-xml/content))
+      
+      ;; display-outside-misc : (listof Misc) Output-port -> Void
+      (define (display-outside-misc misc out)
+	(for-each (lambda (x)
+		    ((cond
+                       [(comment? x) write-xml-comment]
+                       [(pi? x) write-xml-pi]) x 0 void out)
+		    (newline out))
+		  misc))
+      
+      ;; write-xml-content : Content Nat (Nat Output-Stream -> Void) Output-Stream -> Void
+      (define (write-xml-content el over dent out)
+	((cond
+           [(element? el) write-xml-element]
+           [(pcdata? el) write-xml-pcdata]
+           [(entity? el) write-xml-entity]
+           [(comment? el) write-xml-comment]
+           [(pi? el) write-xml-pi]
+           [else (error 'write-xml-content "received ~a" el)])
+	 el over dent out))
+      
+      ;; write-xml-element : Element Nat (Nat Output-Stream -> Void) Output-Stream -> Void
+      (define (write-xml-element el over dent out)
+	(let* ([name (element-name el)]
+	       [start (lambda (f) (write-xml-base (format f name) over dent out))]
+	       [content (element-content el)])
+	  (start "<~a")
+	  (for-each (lambda (att)
+		      (fprintf out " ~a=\"~a\"" (attribute-name att)
+			       (escape (attribute-value att) escape-attribute-table)))
+		    (element-attributes el))
+	  (if (and (null? content)
+		   (let ([short (empty-tag-shorthand)])
+		     (case short
+		       [(always) #t]
+		       [(never) #f]
+		       [else (memq (lowercase-symbol name) short)])))
+	      (fprintf out " />")
+	      (begin
+		(fprintf out ">")
+		(for-each (lambda (c) (write-xml-content c (incr over) dent out)) content)
+		(start "</~a")
+		(fprintf out ">")))))
+
+      ; : sym -> sym
+      (define (lowercase-symbol x)
+	(let ([s (symbol->string x)])
+	   (string-lowercase! s)
+	   (string->symbol s)))
+      
+      ;; write-xml-base : (U String Char Symbol) Nat (Nat Output-Stream -> Void) Output-Stream -> Void
+      (define (write-xml-base el over dent out)
+	(dent over out)
+	(display el out))
+      
+      ;; write-xml-pcdata : Pcdata Nat (Nat Output-Stream -> Void) Output-Stream -> Void
+      (define (write-xml-pcdata str over dent out)
+	(write-xml-base (escape (pcdata-string str) escape-table) over dent out))
+      
+      ;; write-xml-pi : Processing-instruction Nat (Nat Output-Stream -> Void) Output-Stream -> Void
+      (define (write-xml-pi pi over dent out)
+	(write-xml-base (format "<?~a ~a?>" (pi-target-name pi) (pi-instruction pi)) over dent out))
+      
+      ;; write-xml-comment : Comment Nat (Nat Output-Stream -> Void) Output-Stream -> Void
+      (define (write-xml-comment comment over dent out)
+	(write-xml-base (format "<!--~a-->" (comment-text comment)) over dent out))
+      
+      ;; write-xml-entity : Entity Nat (Nat Output-stream -> Void) Output-stream -> Void
+      (define (write-xml-entity entity over dent out)
+	(let ([n (entity-text entity)])
+	  (fprintf out (if (number? n) "&#~a;" "&~a;") n)))
+      
+      (define escape-table
+	(map (lambda (x y) (cons (regexp (symbol->string x)) y))
+	     '(< > &)
+	     '("\\&lt;" "\\&gt;" "\\&amp;")))
+      
+      (define escape-attribute-table
+	(list* (cons (regexp "\"") "\\&quot;") escape-table))
+      
+      ;; escape : String -> String
+      ;; more here - this could be much more efficient
+      (define (escape x table)
+	(foldr (lambda (esc str) (regexp-replace* (car esc) str (cdr esc)))
+	       x
+	       table))
+      
+      ;; incr : Nat -> Nat
+      (define (incr n) (+ n 2)))))
diff --git a/collects/xml/private/xexpr.ss b/collects/xml/private/xexpr.ss
new file mode 100644
index 0000000000..0d7eb2e158
--- /dev/null
+++ b/collects/xml/private/xexpr.ss
@@ -0,0 +1,223 @@
+
+(module xexpr mzscheme
+  (require (lib "unitsig.ss")
+	  (lib "list.ss")
+	  (lib "etc.ss"))
+
+  (require "sig.ss")
+
+  (provide xexpr@)
+
+  (define xexpr@
+    (unit/sig extra-xexpr^
+      (import xml-structs^ writer^)
+      ;; Xexpr ::= String
+      ;;        |  (list* Symbol (listof Attribute-srep) (listof Xexpr))
+      ;;        |  (cons Symbol (listof Xexpr))
+      ;;        |  Symbol
+      ;;        |  Nat
+      ;;        |  Comment
+      ;;        |  Processing-instruction
+      ;; Attribute-srep ::= (list Symbol String)
+      
+      ;; sorting is no longer necessary, since xt3d uses xml->zxexpr, which sorts.
+      
+      ;; assoc-sort : (listof (list Symbol a)) -> (listof (list Symbol a))
+      (define (assoc-sort to-sort)
+	(quicksort to-sort (bcompose string<? (compose symbol->string car))))
+      
+      (define xexpr-drop-empty-attributes (make-parameter #f))
+
+      #|
+      ; : tst -> bool
+      (define (xexpr? x)
+	(or (string? x) (symbol? x) (number? x) (pcdata? x) (comment? x)
+	    (and (cons? x) (symbol? (car x))
+		 (or (and (cons? (cdr x)) (listof? xexpr-attribute? (cadr x))
+			  (listof? xexpr? (cddr x)))
+		     (listof? xexpr? (cdr x))))))
+      |#
+
+      (define (xexpr? x)
+        (correct-xexpr? x (lambda () #t) (lambda (exn) #f)))
+                                       
+
+      (define (validate-xexpr x)
+        (correct-xexpr? x (lambda () #t) (lambda (exn) (raise exn))))
+
+      ;; ;; ;; ;; ;; ;; ;
+      ;; ; xexpr? helpers
+
+      (define-struct (exn:invalid-xexpr exn) (code))
+
+      ;; correct-xexpr? : any (-> a) (exn -> a) -> a
+      (define (correct-xexpr? x true false)
+        (cond
+          ((string? x) (true))
+          ((symbol? x) (true))
+          ((number? x) (true))
+          ((comment? x) (true))
+          ((pi? x) (true))
+          ((list? x)
+           (or (null? x)
+               (if (symbol? (car x))
+                 (if (has-attribute? x)
+                   (and (attribute-pairs? (cadr x) true false)
+                        (andmap (lambda (part)
+                                  (correct-xexpr? part true false))
+                                (cddr x))
+                        (true))
+                   (andmap (lambda (part)
+                             (correct-xexpr? part true false))
+                           (cdr x)))
+                 (false (make-exn:invalid-xexpr
+                          (string->immutable-string
+                            (format
+                              "Expected a symbol as the element name, given ~a"
+                              (car x)))
+                          (current-continuation-marks)
+                          x)))))
+          (else (false
+                  (make-exn:invalid-xexpr
+                    (string->immutable-string
+                      (format
+                        (string-append
+                          "Expected a string, symbol, number, comment, "
+                          "processing instruction, or list, given ~a")
+                        x))
+                    (current-continuation-marks)
+                    x)))))
+
+      ;; has-attribute? : List -> Boolean
+      ;; True if the Xexpr provided has an attribute list.
+      (define (has-attribute? x)
+        (and (> (length x) 1)
+             (list? (cadr x))
+             (andmap (lambda (attr)
+                       (pair? attr))
+                     (cadr x))))
+
+      ;; attribute-pairs? : List (-> a) (exn -> a) -> a
+      ;; True if the list is a list of pairs.
+      (define (attribute-pairs? attrs true false)
+        (if (null? attrs)
+          (true)
+          (let ((attr (car attrs)))
+            (if (pair? attr)
+              (and (attribute-symbol-string? attr true false)
+                   (attribute-pairs? (cdr attrs) true false )
+                   (true))
+              (false
+                (make-exn:invalid-xexpr
+                  (string->immutable-string
+                    (format "Expected a pair, given ~a" attr))
+                  (current-continuation-marks)
+                  attr))))))
+
+      ;; attribute-symbol-string? : List (-> a) (exn -> a) -> a
+      ;; True if the list is a list of String,Symbol pairs.
+      (define (attribute-symbol-string? attr true false)
+        (if (symbol? (car attr))
+          (if (string? (cadr attr))
+            (true)
+            (false (make-exn:invalid-xexpr
+                     (string->immutable-string
+                       (format "Expected a string, given ~a" (cadr attr)))
+                     (current-continuation-marks)
+                     (cadr attr))))
+          (false (make-exn:invalid-xexpr
+                   (string->immutable-string
+                     (format "Expected a symbol, given ~a" (car attr)))
+                   (current-continuation-marks)
+                   (cadr attr)))))
+
+      ;; ; end xexpr? helpers
+      ;; ;; ;; ;; ;; ;; ;; ;;
+
+     
+      ; : (a -> bool) tst -> bool
+      ; To check if l is a (listof p?)
+      ; Don't use (and (list? l) (andmap p? l)) because l may be improper.
+      (define (listof? p? l)
+        (let listof-p? ([l l])
+          (or (null? l)
+              (and (cons? l) (p? (car l)) (listof-p? (cdr l))))))
+      
+      ; : tst -> bool
+      (define (xexpr-attribute? b)
+        (and (pair? b)
+             (symbol? (car b))
+             (pair? (cdr b))
+             (string? (cadr b))
+             (null? (cddr b))))
+
+      ;; xml->xexpr : Content -> Xexpr
+      ;; The contract is loosely enforced.
+      (define (xml->xexpr x)
+        (let* ([non-dropping-combine
+                (lambda (atts body)
+                  (cons (assoc-sort (map attribute->srep atts))
+                        body))]
+               [combine (if (xexpr-drop-empty-attributes)
+                          (lambda (atts body)
+                            (if (null? atts)
+                              body
+                              (non-dropping-combine atts body)))
+                          non-dropping-combine)])
+          (let loop ([x x])
+            (cond
+              [(element? x)
+              (let ([body (map loop (element-content x))]
+                          [atts (element-attributes x)])
+                (cons (element-name x) (combine atts body)))]
+              [(pcdata? x) (pcdata-string x)]
+              [(entity? x) (entity-text x)]
+              [(or (comment? x) (pi? x)) x]
+              [(document? x) (error 'xml->xexpr "Expected content, given ~e~nUse document-element to extract the content." x)]
+              [else ;(error 'xml->xexpr "Expected content, given ~e" x)
+              x]))))
+
+      ;; attribute->srep : Attribute -> Attribute-srep
+      (define (attribute->srep a)
+	(list (attribute-name a) (attribute-value a)))
+      
+      ;; srep->attribute : Attribute-srep -> Attribute
+      (define (srep->attribute a)
+	(unless (and (pair? a) (pair? (cdr a)) (null? (cddr a)) (symbol? (car a)) (string? (cadr a)))
+	  (error 'srep->attribute "expected (list Symbol String) given ~e" a))
+	(make-attribute 'scheme 'scheme (car a) (cadr a)))
+
+      ;; xexpr->xml : Xexpr -> Content
+      ;; The contract is enforced.
+      (define (xexpr->xml x)
+        (cond
+          [(pair? x)
+          (let ([f (lambda (atts body)
+                     (unless (list? body)
+                       (error 'xexpr->xml
+                              "expected a list of xexprs for the body in ~e"
+                              x))
+                     (make-element 'scheme 'scheme (car x)
+                                   atts
+                                   (map xexpr->xml body)))])
+            (if (and (pair? (cdr x))
+                     (or (null? (cadr x))
+                         (and (pair? (cadr x)) (pair? (caadr x)))))
+              (f (map srep->attribute (cadr x)) (cddr x))
+              (f null (cdr x))))]
+          [(string? x) (make-pcdata 'scheme 'scheme x)]
+          [(or (symbol? x) (and (integer? x) (>= x 0)))
+          (make-entity 'scheme 'scheme x)]
+          [(or (comment? x) (pi? x)) x]
+          [else ;(error 'xexpr->xml "malformed xexpr ~s" x)
+          x]))
+
+      ;; xexpr->string : Xexpression -> String
+      (define (xexpr->string xexpr)
+        (let ([port (open-output-string)])
+          (write-xml/content (xexpr->xml xexpr) port)
+          (get-output-string port)))
+      
+      ;; bcompose : (a a -> c) (b -> a) -> (b b -> c)
+      (define (bcompose f g)
+	(lambda (x y) (f (g x) (g y)))))))
diff --git a/collects/xml/scheme-snipclass.ss b/collects/xml/scheme-snipclass.ss
new file mode 100644
index 0000000000..b40e6dbfef
--- /dev/null
+++ b/collects/xml/scheme-snipclass.ss
@@ -0,0 +1,35 @@
+(module scheme-snipclass mzscheme
+  (require (lib "xml-snip-helpers.ss" "stepper" "private")
+           (lib "class.ss")
+           (lib "mred.ss" "mred"))
+  
+  (provide snip-class scheme-snip%)
+
+  (define scheme-snip%
+    (class* editor-snip% (scheme-snip<%> readable-snip<%>)
+      (init-field splice?)
+      (define/public (get-splice?) splice?)
+
+      (define/public (read-special file line col pos)
+        (scheme-read-special this
+			     file
+			     line
+			     col
+			     pos))
+      
+      (super-instantiate ())))
+  
+  (define scheme-snipclass%
+    (class snip-class%
+      (define/override (read stream-in)
+        (let* ([splice? (zero? (send stream-in get-exact))]
+               [snip (instantiate scheme-snip% ()
+                       (splice? splice?))])
+          (send (send snip get-editor) read-from-file stream-in #f)
+          snip))
+      (super-instantiate ())))
+  
+  (define snip-class (make-object scheme-snipclass%))
+  (send snip-class set-version 1)
+  (send snip-class set-classname (format "~s" '(lib "scheme-snipclass.ss" "xml")))
+  (send (get-the-snip-class-list) add snip-class))
\ No newline at end of file
diff --git a/collects/xml/test.ss b/collects/xml/test.ss
new file mode 100644
index 0000000000..ca99430627
--- /dev/null
+++ b/collects/xml/test.ss
@@ -0,0 +1,71 @@
+;; run these tests with:
+;;  % mzscheme --require test.ss
+
+(module test mzscheme
+  (require (lib "xml.ss" "xml"))
+
+
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;
+  ;; utils
+  ;;
+
+  ;; test-bad-read-input : format-str str -> void
+  ;; First argument is the input, second is the error message
+  (define (test-bad-read-input format-str err-string)
+    (let ([str (format format-str)])
+      (with-handlers ([exn:xml?
+                       (lambda (x)
+                         (unless (equal? (exn-message x) err-string)
+                           (report-err format-str (exn-message x) err-string)))])
+        (read-xml (open-input-string str))
+        (report-err str "no error" err-string))))
+
+  ;; tests-failed : number
+  ;; incremened for each test that fails
+  (define tests-failed 0)
+
+  ;; report-err : string string string -> void
+  ;; reports an error in the test suite
+  ;; increments tests-failed.
+  (define (report-err test got expected)
+    (set! tests-failed (+ tests-failed 1))
+    (printf "FAILED     test: ~a~n            got: ~a~n       expected: ~a~n"
+            test got expected))
+
+  ;; done : -> void
+  ;; prints out a message saying the tests are done.
+  ;; if any tests failed, prints a message saying how many
+  (define (done)
+    (if (= tests-failed 0)
+        (printf "All tests passed~n")
+        (printf "~a tests failed~n" tests-failed)))
+
+
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;
+  ;; reader error tests
+  ;;
+
+  (test-bad-read-input "<" "read-xml: lex-error: at position 1.1/2: unexpected eof")
+  (test-bad-read-input "<a>" "read-xml: parse-error: unclosed `a' tag at [1.0/1 1.3/4]")
+  (test-bad-read-input
+   "<a></b>"
+   "read-xml: parse-error: start tag `a' at [1.0/1 1.3/4] doesn't match end tag `b' at [1.3/4 1.7/8]")
+  (test-bad-read-input
+   "<a <a>" "read-xml: lex-error: at position 1.4/5: expected / or > to close tag `a'")
+
+  (test-bad-read-input "~n<" "read-xml: lex-error: at position 2.1/3: unexpected eof")
+  (test-bad-read-input "~n<a>" "read-xml: parse-error: unclosed `a' tag at [2.0/2 2.3/5]")
+  (test-bad-read-input
+   "~n<a></b>"
+   "read-xml: parse-error: start tag `a' at [2.0/2 2.3/5] doesn't match end tag `b' at [2.3/5 2.7/9]")
+  (test-bad-read-input
+   "~n<a <a>" "read-xml: lex-error: at position 2.4/6: expected / or > to close tag `a'")
+
+
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;
+  ;; done
+  ;;
+  (done))
diff --git a/collects/xml/text-box-tool.ss b/collects/xml/text-box-tool.ss
new file mode 100644
index 0000000000..bcfb880175
--- /dev/null
+++ b/collects/xml/text-box-tool.ss
@@ -0,0 +1,155 @@
+(module text-box-tool mzscheme
+  (require (lib "tool.ss" "drscheme")
+           (lib "mred.ss" "mred")
+           (lib "framework.ss" "framework")
+           (lib "unitsig.ss")
+           (lib "class.ss")
+	   (lib "string-constant.ss" "string-constants")
+           (lib "include-bitmap.ss" "mrlib"))
+  
+  (provide tool@)
+
+  ;; chunk-string: (listof any) -> (listof any)
+  (define (chunk-string s acc)
+    (cond
+      ((and (null? s) (null? acc)) null)
+      ((null? s) (list (list->string (reverse acc))))
+      ((char? (car s)) (chunk-string (cdr s) (cons (car s) acc)))
+      ((null? acc) (cons (car s) (chunk-string (cdr s) null)))
+      (else (cons (list->string (reverse acc)) (cons (car s) (chunk-string (cdr s) null))))))
+              
+  ;; marshall: writable -> string
+  (define (marshall s)
+    (let ((os (open-output-string)))
+      (with-handlers ((exn:fail? (lambda (x) "")))
+        (write s os)
+        (get-output-string os))))
+
+  (define icon
+    (let* ((x (make-object bitmap% 10 10))
+           (y (make-object bitmap-dc% x)))
+      (send y set-font (make-object font% 24 'default 'normal 'normal ))
+      (send y draw-text "\"" 0 0)
+      x))
+  
+  (define tool@
+    (unit/sig drscheme:tool-exports^
+      (import drscheme:tool^)
+      
+      (define (phase1) (void))
+      (define (phase2) (void))
+      
+      (define snipclass-text-box%
+        (class decorated-editor-snipclass%
+          (define/override (make-snip stream-in) (new text-box%))
+          (super-instantiate ())))
+      
+      (define snipclass (new snipclass-text-box%))
+      (send snipclass set-version 1)
+      (send snipclass set-classname "text-box%")
+      (send (get-the-snip-class-list) add snipclass)
+
+      (define text-box%
+        (class* decorated-editor-snip% (readable-snip<%>)          
+          (define/override (make-editor) (new text:keymap%))
+          (define/override (make-snip) (make-object text-box%))
+          (inherit get-editor get-admin)
+          
+          
+          (define/override (get-corner-bitmap)
+            icon)
+
+          (define/override (get-menu)
+            (let ([menu (new popup-menu%)])
+              (new menu-item%
+                   (label "Convert to string")
+                   (parent menu)
+                   (callback
+                    (lambda (x y)
+                      (let ([to-ed (find-containing-editor)])
+                        (when to-ed
+                          (let ([this-pos (find-this-position)])
+                            (when this-pos
+                              (let ([from-ed (get-editor)])
+                                (send to-ed begin-edit-sequence)
+                                (send from-ed begin-edit-sequence)
+                                (send to-ed delete this-pos (+ this-pos 1))
+                                (let* ((p (open-input-text-editor from-ed 0 'end
+                                                                  (lambda (s)
+                                                                    (values (box s) 1))))
+                                       (contents
+                                        (let loop ((next (read-char-or-special p)))
+                                          (cond
+                                            ((eof-object? next) null)
+                                            (else
+                                             (cons next (loop (read-char-or-special p)))))))
+                                       (repaired-contents
+                                        (map (lambda (x)
+                                               (if (string? x)
+                                                   (marshall x)
+                                                   (send (unbox x) copy)))
+                                             (chunk-string contents null))))
+                                  (for-each
+                                   (lambda (x)
+                                     (send to-ed insert x this-pos))
+                                   (reverse repaired-contents)))
+                                (send to-ed end-edit-sequence)
+                                (send from-ed end-edit-sequence)))))))))
+              menu))
+          
+          ;; find-containing-editor : -> (union #f editor)
+          (define/private (find-containing-editor)
+            (let ([admin (get-admin)])
+              (and admin
+                   (send admin get-editor))))
+          
+          ;; find-this-position : -> (union #f number)
+          (define/private (find-this-position)
+            (let ([ed (find-containing-editor)])
+              (and ed
+                   (send ed get-snip-position this))))
+
+          ;; input-port -> (union (listof char) char eof-object? syntax-object)
+          (define/private (get-next port)
+	    (let ([v (read-char-or-special port)])
+	      (if (special-comment? v)
+		  (get-next port)
+		  v)))
+          
+          (define/public (read-special source line column position)
+            (let* ((ed (get-editor))
+                   (port (open-input-text-editor ed))
+                   (str (let loop ((next (get-next port)))
+                          (cond
+                            ((eof-object? next) null)
+                            ((char? next)
+                             (cons next (loop (get-next port))))
+                            (else (cons #`(marshall #,next) (loop (get-next port))))))))
+	      #`(let ((marshall
+		       (lambda (s)
+			 (let ((os (open-output-string)))
+			   (with-handlers ((exn:fail? (lambda (x) "")))
+			     (display s os)
+			     (get-output-string os))))))
+		  (string-append #,@(chunk-string str null)))))
+          
+          (super-instantiate ())
+          (inherit set-snipclass)
+          (set-snipclass snipclass)))
+                    
+            
+      (define (text-box-mixin %)
+        (class %
+          (inherit get-special-menu get-edit-target-object)
+          (super-new)
+          (new menu-item%
+               (label (string-constant insert-text-box-item))
+               (parent (get-special-menu))
+               (callback
+                (lambda (menu event)
+                  (let ([c-box (new text-box%)]
+                        [text (get-edit-target-object)])
+                    (send text insert c-box)
+                    (send text set-caret-owner c-box 'global)))))))
+      
+      (drscheme:get/extend:extend-unit-frame text-box-mixin))))
diff --git a/collects/xml/xml-sig.ss b/collects/xml/xml-sig.ss
new file mode 100644
index 0000000000..8e00d94ae3
--- /dev/null
+++ b/collects/xml/xml-sig.ss
@@ -0,0 +1,14 @@
+
+(module xml-sig mzscheme
+  (require (lib "unitsig.ss"))
+  
+  (require "private/sig.ss")
+
+  (define-signature xml^
+    ((open xml-structs^) (open reader^) (open writer^) (open xexpr^) (open space^)
+     syntax:read-xml syntax:read-xml/element))
+
+  (provide xml^))
+
+
+
diff --git a/collects/xml/xml-snipclass.ss b/collects/xml/xml-snipclass.ss
new file mode 100644
index 0000000000..55fd0ee2ce
--- /dev/null
+++ b/collects/xml/xml-snipclass.ss
@@ -0,0 +1,35 @@
+(module xml-snipclass mzscheme
+  (require (lib "xml-snip-helpers.ss" "stepper" "private")
+           (lib "class.ss")
+           (lib "mred.ss" "mred"))
+  
+  (provide snip-class xml-snip%)
+
+  (define xml-snip%
+    (class* editor-snip% (xml-snip<%> readable-snip<%>)
+      (init-field eliminate-whitespace-in-empty-tags?)
+      
+      (define/public (read-special file line col pos)
+        (xml-read-special eliminate-whitespace-in-empty-tags?
+			  this
+			  file
+			  line
+			  col
+			  pos))
+      
+      (super-new)))
+  
+  (define xml-snipclass%
+    (class snip-class%
+      (define/override (read stream-in)
+        (let* ([eliminate-whitespace-in-empty-tags? (zero? (send stream-in get-exact))]
+               [snip (instantiate xml-snip% ()
+                       (eliminate-whitespace-in-empty-tags? eliminate-whitespace-in-empty-tags?))])
+          (send (send snip get-editor) read-from-file stream-in #f)
+          snip))
+      (super-new)))
+  
+  (define snip-class (make-object xml-snipclass%))
+  (send snip-class set-version 1)
+  (send snip-class set-classname (format "~s" '(lib "xml-snipclass.ss" "xml")))
+  (send (get-the-snip-class-list) add snip-class))
\ No newline at end of file
diff --git a/collects/xml/xml-unit.ss b/collects/xml/xml-unit.ss
new file mode 100644
index 0000000000..858cc40fd3
--- /dev/null
+++ b/collects/xml/xml-unit.ss
@@ -0,0 +1,28 @@
+
+(module xml-unit mzscheme
+  (require (lib "unitsig.ss"))
+
+  (require "xml-sig.ss" "private/sig.ss"
+	  "private/structures.ss"
+	  "private/reader.ss"
+	  "private/writer.ss"
+	  "private/xexpr.ss"
+	  "private/space.ss"
+          "private/syntax.ss")
+
+  (provide xml@)
+
+  (define xml@
+    (compound-unit/sig
+     (import)
+     (link
+      [S : xml-structs^ (xml-structs@)]
+      [SS : xml-structs^ (syntax-structs@)]
+      [R : reader^ (reader@ S)]
+      [R2 : reader^ (reader@ SS)]
+      (U : writer^ (writer@ S))
+      (T : xexpr^ (xexpr@ S U))
+      (W : space^ (space@ S)))
+     (export (open S) (open R) (var (R2 read-xml) syntax:read-xml)
+             (var (R2 read-xml/element) syntax:read-xml/element)
+             (open U) (open T) (open W)))))
diff --git a/collects/xml/xml.png b/collects/xml/xml.png
new file mode 100644
index 0000000000..8372ce9526
Binary files /dev/null and b/collects/xml/xml.png differ
diff --git a/collects/xml/xml.ss b/collects/xml/xml.ss
new file mode 100644
index 0000000000..d758f2de77
--- /dev/null
+++ b/collects/xml/xml.ss
@@ -0,0 +1,10 @@
+
+(module xml mzscheme
+  (require (lib "unitsig.ss"))
+
+  (require "xml-sig.ss"
+	   "xml-unit.ss")
+  
+  (define-values/invoke-unit/sig xml^ xml@)
+
+  (provide-signature-elements xml^))